From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/9drpc.adb | 1051 ++ gcc/ada/ChangeLog | 260 + gcc/ada/ChangeLog-2001 | 2239 +++ gcc/ada/ChangeLog-2002 | 986 + gcc/ada/ChangeLog-2003 | 3021 +++ gcc/ada/ChangeLog-2004 | 8347 +++++++++ gcc/ada/ChangeLog-2005 | 8014 ++++++++ gcc/ada/ChangeLog-2006 | 4462 +++++ gcc/ada/ChangeLog-2007 | 9221 ++++++++++ gcc/ada/ChangeLog-2008 | 7464 ++++++++ gcc/ada/ChangeLog-2009 | 12171 +++++++++++++ gcc/ada/ChangeLog-2010 | 10088 ++++++++++ gcc/ada/ChangeLog.ptr | 27 + gcc/ada/ChangeLog.tree-ssa | 36 + gcc/ada/Make-generated.in | 103 + gcc/ada/Makefile.in | 5 + gcc/ada/Makefile.rtl | 650 + gcc/ada/a-assert.adb | 52 + gcc/ada/a-assert.ads | 36 + gcc/ada/a-astaco.adb | 65 + gcc/ada/a-astaco.ads | 41 + gcc/ada/a-btgbso.adb | 605 + 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 | 114 + gcc/ada/a-caldel-vms.adb | 107 + gcc/ada/a-caldel.adb | 132 + gcc/ada/a-caldel.ads | 53 + gcc/ada/a-calend-vms.adb | 1296 ++ gcc/ada/a-calend-vms.ads | 270 + gcc/ada/a-calend.adb | 1523 ++ gcc/ada/a-calend.ads | 358 + gcc/ada/a-calfor.adb | 944 + gcc/ada/a-calfor.ads | 215 + gcc/ada/a-catizo.adb | 69 + gcc/ada/a-catizo.ads | 34 + gcc/ada/a-cbdlli.adb | 2005 ++ gcc/ada/a-cbdlli.ads | 270 + gcc/ada/a-cbhama.adb | 1068 ++ gcc/ada/a-cbhama.ads | 343 + gcc/ada/a-cbhase.adb | 1737 ++ gcc/ada/a-cbhase.ads | 466 + gcc/ada/a-cborma.adb | 1348 ++ gcc/ada/a-cborma.ads | 244 + gcc/ada/a-cborse.adb | 1718 ++ gcc/ada/a-cborse.ads | 294 + gcc/ada/a-cdlili.adb | 1835 ++ gcc/ada/a-cdlili.ads | 276 + gcc/ada/a-cgaaso.adb | 129 + gcc/ada/a-cgaaso.ads | 41 + gcc/ada/a-cgarso.adb | 50 + gcc/ada/a-cgarso.ads | 26 + gcc/ada/a-cgcaso.adb | 121 + gcc/ada/a-cgcaso.ads | 27 + gcc/ada/a-chacon.adb | 261 + gcc/ada/a-chacon.ads | 86 + gcc/ada/a-chahan.adb | 568 + gcc/ada/a-chahan.ads | 150 + gcc/ada/a-charac.ads | 18 + gcc/ada/a-chlat1.ads | 298 + gcc/ada/a-chlat9.ads | 332 + gcc/ada/a-chtgbk.adb | 322 + gcc/ada/a-chtgbk.ads | 106 + gcc/ada/a-chtgbo.adb | 473 + gcc/ada/a-chtgbo.ads | 140 + gcc/ada/a-chtgke.adb | 313 + gcc/ada/a-chtgke.ads | 104 + gcc/ada/a-chtgop.adb | 703 + gcc/ada/a-chtgop.ads | 174 + gcc/ada/a-chzla1.ads | 376 + gcc/ada/a-chzla9.ads | 388 + gcc/ada/a-cidlli.adb | 1910 ++ gcc/ada/a-cidlli.ads | 268 + gcc/ada/a-cihama.adb | 1080 ++ gcc/ada/a-cihama.ads | 332 + gcc/ada/a-cihase.adb | 2022 +++ gcc/ada/a-cihase.ads | 461 + gcc/ada/a-ciorma.adb | 1362 ++ gcc/ada/a-ciorma.ads | 256 + gcc/ada/a-ciormu.adb | 1861 ++ gcc/ada/a-ciormu.ads | 493 + gcc/ada/a-ciorse.adb | 1761 ++ gcc/ada/a-ciorse.ads | 320 + gcc/ada/a-clrefi.adb | 528 + gcc/ada/a-clrefi.ads | 100 + gcc/ada/a-cobove.adb | 2439 +++ gcc/ada/a-cobove.ads | 369 + gcc/ada/a-cohama.adb | 955 + gcc/ada/a-cohama.ads | 336 + gcc/ada/a-cohase.adb | 1850 ++ gcc/ada/a-cohase.ads | 461 + gcc/ada/a-cohata.ads | 74 + gcc/ada/a-coinve.adb | 3582 ++++ gcc/ada/a-coinve.ads | 370 + gcc/ada/a-colien.adb | 72 + gcc/ada/a-colien.ads | 55 + gcc/ada/a-colire.adb | 124 + gcc/ada/a-colire.ads | 79 + gcc/ada/a-comlin.adb | 131 + gcc/ada/a-comlin.ads | 139 + gcc/ada/a-contai.ads | 24 + gcc/ada/a-convec.adb | 3120 ++++ gcc/ada/a-convec.ads | 380 + gcc/ada/a-coorma.adb | 1244 ++ gcc/ada/a-coorma.ads | 258 + gcc/ada/a-coormu.adb | 1767 ++ gcc/ada/a-coormu.ads | 497 + gcc/ada/a-coorse.adb | 1657 ++ gcc/ada/a-coorse.ads | 309 + gcc/ada/a-coprnu.adb | 58 + gcc/ada/a-coprnu.ads | 51 + gcc/ada/a-coteio.ads | 24 + gcc/ada/a-crbltr.ads | 68 + gcc/ada/a-crbtgk.adb | 563 + gcc/ada/a-crbtgk.ads | 192 + gcc/ada/a-crbtgo.adb | 1155 ++ gcc/ada/a-crbtgo.ads | 163 + gcc/ada/a-crdlli.adb | 1500 ++ gcc/ada/a-crdlli.ads | 337 + 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.adb | 1303 ++ gcc/ada/a-direct.ads | 487 + gcc/ada/a-direio.adb | 283 + gcc/ada/a-direio.ads | 191 + gcc/ada/a-diroro.ads | 39 + gcc/ada/a-dirval-mingw.adb | 182 + gcc/ada/a-dirval-vms.adb | 200 + gcc/ada/a-dirval.adb | 113 + gcc/ada/a-dirval.ads | 52 + gcc/ada/a-disedf.ads | 50 + gcc/ada/a-dispat.ads | 20 + gcc/ada/a-dynpri.adb | 164 + gcc/ada/a-dynpri.ads | 33 + gcc/ada/a-einuoc.adb | 48 + gcc/ada/a-einuoc.ads | 40 + gcc/ada/a-elchha.adb | 138 + gcc/ada/a-elchha.ads | 43 + gcc/ada/a-envvar.adb | 226 + gcc/ada/a-envvar.ads | 59 + gcc/ada/a-etgrbu.ads | 87 + gcc/ada/a-excach.adb | 74 + gcc/ada/a-except-2005.adb | 1514 ++ gcc/ada/a-except-2005.ads | 370 + gcc/ada/a-except.adb | 1326 ++ gcc/ada/a-except.ads | 324 + gcc/ada/a-excpol-abort.adb | 62 + gcc/ada/a-excpol.adb | 42 + gcc/ada/a-exctra.adb | 43 + gcc/ada/a-exctra.ads | 55 + gcc/ada/a-exetim-default.ads | 98 + gcc/ada/a-exetim-mingw.adb | 159 + gcc/ada/a-exetim-mingw.ads | 98 + gcc/ada/a-exetim-posix.adb | 157 + gcc/ada/a-exetim.ads | 84 + gcc/ada/a-exexda.adb | 728 + gcc/ada/a-exexpr-gcc.adb | 729 + gcc/ada/a-exexpr.adb | 121 + gcc/ada/a-exextr.adb | 216 + gcc/ada/a-exstat.adb | 260 + gcc/ada/a-extiti.ads | 61 + gcc/ada/a-filico.adb | 80 + gcc/ada/a-filico.ads | 102 + gcc/ada/a-finali.adb | 87 + gcc/ada/a-finali.ads | 71 + gcc/ada/a-flteio.ads | 21 + gcc/ada/a-fwteio.ads | 19 + gcc/ada/a-fzteio.ads | 19 + gcc/ada/a-inteio.ads | 19 + gcc/ada/a-interr.adb | 125 + gcc/ada/a-interr.ads | 71 + gcc/ada/a-intnam-aix.ads | 197 + gcc/ada/a-intnam-darwin.ads | 149 + gcc/ada/a-intnam-dummy.ads | 46 + gcc/ada/a-intnam-freebsd.ads | 132 + gcc/ada/a-intnam-hpux.ads | 150 + gcc/ada/a-intnam-irix.ads | 191 + gcc/ada/a-intnam-linux.ads | 164 + gcc/ada/a-intnam-lynxos.ads | 162 + gcc/ada/a-intnam-mingw.ads | 63 + gcc/ada/a-intnam-rtems.ads | 114 + gcc/ada/a-intnam-solaris.ads | 175 + gcc/ada/a-intnam-tru64.ads | 147 + gcc/ada/a-intnam-vms.ads | 76 + gcc/ada/a-intnam-vxworks.ads | 42 + gcc/ada/a-intnam.ads | 29 + gcc/ada/a-intsig.adb | 46 + gcc/ada/a-intsig.ads | 42 + gcc/ada/a-ioexce.ads | 30 + gcc/ada/a-iwteio.ads | 19 + gcc/ada/a-izteio.ads | 19 + gcc/ada/a-lcteio.ads | 24 + gcc/ada/a-lfteio.ads | 19 + gcc/ada/a-lfwtio.ads | 19 + gcc/ada/a-lfztio.ads | 19 + gcc/ada/a-liteio.ads | 19 + gcc/ada/a-liwtio.ads | 19 + gcc/ada/a-liztio.ads | 19 + gcc/ada/a-llctio.ads | 24 + gcc/ada/a-llftio.ads | 19 + gcc/ada/a-llfwti.ads | 19 + gcc/ada/a-llfzti.ads | 19 + gcc/ada/a-llitio.ads | 19 + gcc/ada/a-lliwti.ads | 19 + gcc/ada/a-llizti.ads | 19 + gcc/ada/a-locale.adb | 65 + gcc/ada/a-locale.ads | 31 + gcc/ada/a-ncelfu.ads | 23 + gcc/ada/a-ngcefu.adb | 708 + gcc/ada/a-ngcefu.ads | 55 + gcc/ada/a-ngcoar.adb | 1502 ++ gcc/ada/a-ngcoar.ads | 281 + gcc/ada/a-ngcoty.adb | 681 + gcc/ada/a-ngcoty.ads | 157 + gcc/ada/a-ngelfu.adb | 999 + gcc/ada/a-ngelfu.ads | 73 + gcc/ada/a-ngrear.adb | 784 + gcc/ada/a-ngrear.ads | 139 + gcc/ada/a-nlcefu.ads | 21 + gcc/ada/a-nlcoar.ads | 23 + gcc/ada/a-nlcoty.ads | 21 + gcc/ada/a-nlelfu.ads | 21 + gcc/ada/a-nllcar.ads | 24 + gcc/ada/a-nllcef.ads | 21 + gcc/ada/a-nllcty.ads | 21 + gcc/ada/a-nllefu.ads | 21 + gcc/ada/a-nllrar.ads | 21 + gcc/ada/a-nlrear.ads | 21 + gcc/ada/a-nscefu.ads | 21 + gcc/ada/a-nscoty.ads | 21 + gcc/ada/a-nselfu.ads | 21 + gcc/ada/a-nucoar.ads | 23 + gcc/ada/a-nucoty.ads | 21 + gcc/ada/a-nudira.adb | 94 + gcc/ada/a-nudira.ads | 73 + gcc/ada/a-nuelfu.ads | 21 + gcc/ada/a-nuflra.adb | 102 + gcc/ada/a-nuflra.ads | 72 + gcc/ada/a-numaux-darwin.adb | 185 + gcc/ada/a-numaux-darwin.ads | 107 + gcc/ada/a-numaux-libc-x86.ads | 106 + gcc/ada/a-numaux-vxworks.ads | 108 + gcc/ada/a-numaux-x86.adb | 569 + gcc/ada/a-numaux-x86.ads | 82 + gcc/ada/a-numaux.ads | 109 + gcc/ada/a-numeri.ads | 32 + gcc/ada/a-nurear.ads | 21 + gcc/ada/a-rbtgbk.adb | 599 + gcc/ada/a-rbtgbk.ads | 193 + gcc/ada/a-rbtgbo.adb | 1118 ++ gcc/ada/a-rbtgbo.ads | 155 + gcc/ada/a-rbtgso.adb | 630 + gcc/ada/a-rbtgso.ads | 106 + gcc/ada/a-reatim.adb | 253 + gcc/ada/a-reatim.ads | 139 + gcc/ada/a-retide.adb | 78 + gcc/ada/a-retide.ads | 48 + gcc/ada/a-rttiev.adb | 372 + gcc/ada/a-rttiev.ads | 81 + gcc/ada/a-scteio.ads | 24 + gcc/ada/a-secain.adb | 59 + gcc/ada/a-secain.ads | 38 + gcc/ada/a-sequio.adb | 271 + gcc/ada/a-sequio.ads | 158 + gcc/ada/a-sfteio.ads | 19 + gcc/ada/a-sfwtio.ads | 19 + gcc/ada/a-sfztio.ads | 19 + gcc/ada/a-shcain.adb | 41 + gcc/ada/a-shcain.ads | 37 + gcc/ada/a-siocst.adb | 86 + gcc/ada/a-siocst.ads | 54 + gcc/ada/a-siteio.ads | 19 + gcc/ada/a-siwtio.ads | 19 + gcc/ada/a-siztio.ads | 19 + gcc/ada/a-slcain.adb | 72 + gcc/ada/a-slcain.ads | 36 + gcc/ada/a-ssicst.adb | 84 + gcc/ada/a-ssicst.ads | 53 + gcc/ada/a-ssitio.ads | 19 + gcc/ada/a-ssiwti.ads | 19 + gcc/ada/a-ssizti.ads | 19 + gcc/ada/a-stboha.adb | 40 + gcc/ada/a-stboha.ads | 25 + gcc/ada/a-stfiha.ads | 21 + gcc/ada/a-stmaco.ads | 916 + gcc/ada/a-storio.adb | 60 + gcc/ada/a-storio.ads | 47 + gcc/ada/a-strbou.adb | 106 + gcc/ada/a-strbou.ads | 914 + gcc/ada/a-stream.ads | 69 + gcc/ada/a-strfix.adb | 738 + gcc/ada/a-strfix.ads | 251 + gcc/ada/a-strhas.adb | 38 + gcc/ada/a-strhas.ads | 22 + gcc/ada/a-string.ads | 35 + gcc/ada/a-strmap.adb | 322 + gcc/ada/a-strmap.ads | 412 + gcc/ada/a-strsea.adb | 607 + gcc/ada/a-strsea.ads | 121 + gcc/ada/a-strsup.adb | 1917 ++ gcc/ada/a-strsup.ads | 488 + gcc/ada/a-strunb-shared.adb | 2099 +++ gcc/ada/a-strunb-shared.ads | 490 + gcc/ada/a-strunb.adb | 1074 ++ gcc/ada/a-strunb.ads | 437 + gcc/ada/a-ststio.adb | 481 + gcc/ada/a-ststio.ads | 221 + gcc/ada/a-stunau-shared.adb | 62 + gcc/ada/a-stunau.adb | 62 + gcc/ada/a-stunau.ads | 72 + gcc/ada/a-stunha.adb | 40 + gcc/ada/a-stunha.ads | 21 + gcc/ada/a-stuten.adb | 209 + gcc/ada/a-stuten.ads | 146 + gcc/ada/a-stwibo.adb | 94 + gcc/ada/a-stwibo.ads | 921 + gcc/ada/a-stwifi.adb | 684 + gcc/ada/a-stwifi.ads | 254 + gcc/ada/a-stwiha.adb | 40 + gcc/ada/a-stwiha.ads | 21 + gcc/ada/a-stwima.adb | 737 + gcc/ada/a-stwima.ads | 240 + gcc/ada/a-stwise.adb | 604 + gcc/ada/a-stwise.ads | 125 + gcc/ada/a-stwisu.adb | 1920 ++ gcc/ada/a-stwisu.ads | 494 + gcc/ada/a-stwiun-shared.adb | 2119 +++ gcc/ada/a-stwiun-shared.ads | 492 + gcc/ada/a-stwiun.adb | 1098 ++ gcc/ada/a-stwiun.ads | 443 + gcc/ada/a-stzbou.adb | 94 + gcc/ada/a-stzbou.ads | 937 + gcc/ada/a-stzfix.adb | 688 + gcc/ada/a-stzfix.ads | 264 + gcc/ada/a-stzhas.adb | 36 + gcc/ada/a-stzhas.ads | 25 + gcc/ada/a-stzmap.adb | 742 + gcc/ada/a-stzmap.ads | 242 + gcc/ada/a-stzsea.adb | 610 + gcc/ada/a-stzsea.ads | 130 + gcc/ada/a-stzsup.adb | 1931 ++ gcc/ada/a-stzsup.ads | 504 + gcc/ada/a-stzunb-shared.adb | 2132 +++ gcc/ada/a-stzunb-shared.ads | 510 + gcc/ada/a-stzunb.adb | 1111 ++ gcc/ada/a-stzunb.ads | 452 + gcc/ada/a-suenco.adb | 390 + gcc/ada/a-suenco.ads | 61 + gcc/ada/a-suenst.adb | 341 + gcc/ada/a-suenst.ads | 65 + gcc/ada/a-suewst.adb | 370 + gcc/ada/a-suewst.ads | 67 + gcc/ada/a-suezst.adb | 429 + gcc/ada/a-suezst.ads | 64 + gcc/ada/a-suteio-shared.adb | 132 + gcc/ada/a-suteio.adb | 159 + gcc/ada/a-suteio.ads | 61 + gcc/ada/a-swbwha.adb | 41 + gcc/ada/a-swbwha.ads | 25 + gcc/ada/a-swfwha.ads | 22 + gcc/ada/a-swmwco.ads | 450 + gcc/ada/a-swunau-shared.adb | 65 + gcc/ada/a-swunau.adb | 65 + gcc/ada/a-swunau.ads | 76 + gcc/ada/a-swuwha.adb | 40 + gcc/ada/a-swuwha.ads | 23 + gcc/ada/a-swuwti-shared.adb | 134 + gcc/ada/a-swuwti.adb | 161 + gcc/ada/a-swuwti.ads | 69 + gcc/ada/a-sytaco.adb | 104 + gcc/ada/a-sytaco.ads | 78 + gcc/ada/a-szbzha.adb | 41 + gcc/ada/a-szbzha.ads | 28 + gcc/ada/a-szfzha.ads | 24 + gcc/ada/a-szmzco.ads | 450 + gcc/ada/a-szunau-shared.adb | 65 + gcc/ada/a-szunau.adb | 65 + gcc/ada/a-szunau.ads | 78 + gcc/ada/a-szuzha.adb | 40 + gcc/ada/a-szuzha.ads | 21 + gcc/ada/a-szuzti-shared.adb | 135 + gcc/ada/a-szuzti.adb | 162 + gcc/ada/a-szuzti.ads | 71 + gcc/ada/a-tags.adb | 1002 + gcc/ada/a-tags.ads | 577 + gcc/ada/a-tasatt.adb | 764 + gcc/ada/a-tasatt.ads | 68 + gcc/ada/a-taside.adb | 194 + gcc/ada/a-taside.ads | 72 + gcc/ada/a-taster.adb | 191 + gcc/ada/a-taster.ads | 43 + gcc/ada/a-teioed.adb | 2910 +++ gcc/ada/a-teioed.ads | 194 + gcc/ada/a-textio.adb | 2205 +++ gcc/ada/a-textio.ads | 472 + gcc/ada/a-tgdico.ads | 33 + gcc/ada/a-tiboio.adb | 179 + gcc/ada/a-tiboio.ads | 50 + gcc/ada/a-ticoau.adb | 202 + gcc/ada/a-ticoau.ads | 69 + gcc/ada/a-ticoio.adb | 140 + gcc/ada/a-ticoio.ads | 84 + gcc/ada/a-tideau.adb | 261 + gcc/ada/a-tideau.ads | 92 + gcc/ada/a-tideio.adb | 137 + gcc/ada/a-tideio.ads | 88 + gcc/ada/a-tienau.adb | 260 + gcc/ada/a-tienau.ads | 69 + gcc/ada/a-tienio.adb | 121 + gcc/ada/a-tienio.ads | 75 + gcc/ada/a-tifiio.adb | 717 + gcc/ada/a-tifiio.ads | 88 + gcc/ada/a-tiflau.adb | 234 + gcc/ada/a-tiflau.ads | 72 + gcc/ada/a-tiflio.adb | 145 + gcc/ada/a-tiflio.ads | 88 + gcc/ada/a-tigeau.adb | 474 + gcc/ada/a-tigeau.ads | 191 + gcc/ada/a-tigeli.adb | 227 + gcc/ada/a-tiinau.adb | 296 + gcc/ada/a-tiinau.ads | 83 + gcc/ada/a-tiinio.adb | 154 + gcc/ada/a-tiinio.ads | 84 + gcc/ada/a-timoau.adb | 301 + gcc/ada/a-timoau.ads | 87 + gcc/ada/a-timoio.adb | 141 + gcc/ada/a-timoio.ads | 84 + gcc/ada/a-tiocst.adb | 84 + gcc/ada/a-tiocst.ads | 53 + gcc/ada/a-tirsfi.adb | 39 + gcc/ada/a-tirsfi.ads | 40 + gcc/ada/a-titest.adb | 46 + gcc/ada/a-titest.ads | 23 + gcc/ada/a-tiunio.ads | 61 + gcc/ada/a-unccon.ads | 23 + gcc/ada/a-uncdea.ads | 23 + gcc/ada/a-wichha.adb | 186 + gcc/ada/a-wichha.ads | 120 + gcc/ada/a-wichun.adb | 178 + gcc/ada/a-wichun.ads | 196 + gcc/ada/a-widcha.ads | 21 + gcc/ada/a-witeio.adb | 1940 ++ gcc/ada/a-witeio.ads | 496 + gcc/ada/a-wrstfi.adb | 39 + gcc/ada/a-wrstfi.ads | 41 + gcc/ada/a-wtcoau.adb | 202 + gcc/ada/a-wtcoau.ads | 69 + gcc/ada/a-wtcoio.adb | 159 + gcc/ada/a-wtcoio.ads | 62 + gcc/ada/a-wtcstr.adb | 85 + gcc/ada/a-wtcstr.ads | 53 + gcc/ada/a-wtdeau.adb | 265 + gcc/ada/a-wtdeau.ads | 93 + gcc/ada/a-wtdeio.adb | 164 + gcc/ada/a-wtdeio.ads | 84 + gcc/ada/a-wtedit.adb | 2766 +++ gcc/ada/a-wtedit.ads | 197 + gcc/ada/a-wtenau.adb | 351 + gcc/ada/a-wtenau.ads | 69 + gcc/ada/a-wtenio.adb | 104 + gcc/ada/a-wtenio.ads | 74 + gcc/ada/a-wtfiio.adb | 126 + gcc/ada/a-wtfiio.ads | 84 + gcc/ada/a-wtflau.adb | 234 + gcc/ada/a-wtflau.ads | 72 + gcc/ada/a-wtflio.adb | 127 + gcc/ada/a-wtflio.ads | 84 + gcc/ada/a-wtgeau.adb | 515 + gcc/ada/a-wtgeau.ads | 184 + gcc/ada/a-wtinau.adb | 291 + gcc/ada/a-wtinau.ads | 83 + gcc/ada/a-wtinio.adb | 145 + gcc/ada/a-wtinio.ads | 60 + gcc/ada/a-wtmoau.adb | 301 + gcc/ada/a-wtmoau.ads | 87 + gcc/ada/a-wtmoio.adb | 141 + gcc/ada/a-wtmoio.ads | 80 + gcc/ada/a-wttest.adb | 46 + gcc/ada/a-wttest.ads | 24 + gcc/ada/a-wwboio.adb | 179 + gcc/ada/a-wwboio.ads | 50 + gcc/ada/a-wwunio.ads | 61 + gcc/ada/a-zchara.ads | 18 + gcc/ada/a-zchhan.adb | 186 + gcc/ada/a-zchhan.ads | 126 + gcc/ada/a-zchuni.adb | 178 + gcc/ada/a-zchuni.ads | 195 + gcc/ada/a-zrstfi.adb | 39 + gcc/ada/a-zrstfi.ads | 41 + gcc/ada/a-ztcoau.adb | 202 + gcc/ada/a-ztcoau.ads | 69 + gcc/ada/a-ztcoio.adb | 159 + gcc/ada/a-ztcoio.ads | 62 + gcc/ada/a-ztcstr.adb | 85 + gcc/ada/a-ztcstr.ads | 53 + gcc/ada/a-ztdeau.adb | 263 + gcc/ada/a-ztdeau.ads | 93 + gcc/ada/a-ztdeio.adb | 164 + gcc/ada/a-ztdeio.ads | 84 + gcc/ada/a-ztedit.adb | 2765 +++ gcc/ada/a-ztedit.ads | 198 + gcc/ada/a-ztenau.adb | 353 + gcc/ada/a-ztenau.ads | 69 + gcc/ada/a-ztenio.adb | 104 + gcc/ada/a-ztenio.ads | 75 + gcc/ada/a-ztexio.adb | 1940 ++ gcc/ada/a-ztexio.ads | 498 + gcc/ada/a-ztfiio.adb | 126 + gcc/ada/a-ztfiio.ads | 84 + gcc/ada/a-ztflau.adb | 234 + gcc/ada/a-ztflau.ads | 72 + gcc/ada/a-ztflio.adb | 126 + gcc/ada/a-ztflio.ads | 84 + gcc/ada/a-ztgeau.adb | 515 + gcc/ada/a-ztgeau.ads | 184 + gcc/ada/a-ztinau.adb | 291 + gcc/ada/a-ztinau.ads | 83 + gcc/ada/a-ztinio.adb | 145 + gcc/ada/a-ztinio.ads | 60 + gcc/ada/a-ztmoau.adb | 301 + gcc/ada/a-ztmoau.ads | 88 + gcc/ada/a-ztmoio.adb | 141 + gcc/ada/a-ztmoio.ads | 80 + gcc/ada/a-zttest.adb | 46 + gcc/ada/a-zttest.ads | 24 + gcc/ada/a-zzboio.adb | 180 + gcc/ada/a-zzboio.ads | 50 + gcc/ada/a-zzunio.ads | 63 + gcc/ada/ada.ads | 19 + gcc/ada/adadecode.c | 404 + gcc/ada/adadecode.h | 53 + gcc/ada/adaint.c | 3688 ++++ gcc/ada/adaint.h | 264 + gcc/ada/ali-util.adb | 514 + gcc/ada/ali-util.ads | 154 + gcc/ada/ali.adb | 2475 +++ gcc/ada/ali.ads | 1054 ++ gcc/ada/alloc.ads | 160 + gcc/ada/argv.c | 118 + gcc/ada/arit64.c | 57 + gcc/ada/aspects.adb | 272 + gcc/ada/aspects.ads | 218 + gcc/ada/atree.adb | 6784 +++++++ gcc/ada/atree.ads | 3353 ++++ gcc/ada/atree.h | 736 + gcc/ada/aux-io.c | 98 + gcc/ada/back_end.adb | 328 + gcc/ada/back_end.ads | 64 + gcc/ada/bcheck.adb | 1185 ++ gcc/ada/bcheck.ads | 49 + gcc/ada/binde.adb | 1707 ++ gcc/ada/binde.ads | 52 + gcc/ada/binderr.adb | 233 + gcc/ada/binderr.ads | 132 + gcc/ada/bindgen.adb | 3583 ++++ gcc/ada/bindgen.ads | 40 + gcc/ada/bindusg.adb | 283 + gcc/ada/bindusg.ads | 33 + gcc/ada/butil.adb | 164 + gcc/ada/butil.ads | 54 + gcc/ada/cal.c | 109 + gcc/ada/calendar.ads | 18 + gcc/ada/casing.adb | 200 + gcc/ada/casing.ads | 89 + gcc/ada/ceinfo.adb | 219 + gcc/ada/checks.adb | 7181 ++++++++ gcc/ada/checks.ads | 721 + gcc/ada/cio.c | 131 + gcc/ada/clean.adb | 1998 ++ gcc/ada/clean.ads | 33 + gcc/ada/comperr.adb | 441 + gcc/ada/comperr.ads | 76 + gcc/ada/config-lang.in | 27 + gcc/ada/csets.adb | 1187 ++ gcc/ada/csets.ads | 97 + gcc/ada/csinfo.adb | 641 + gcc/ada/cstand.adb | 1937 ++ gcc/ada/cstand.ads | 49 + gcc/ada/cstreams.c | 244 + gcc/ada/ctrl_c.c | 166 + gcc/ada/debug.adb | 906 + gcc/ada/debug.ads | 188 + gcc/ada/debug_a.adb | 144 + gcc/ada/debug_a.ads | 63 + gcc/ada/dec.ads | 38 + gcc/ada/directio.ads | 24 + gcc/ada/einfo.adb | 8632 +++++++++ gcc/ada/einfo.ads | 7997 ++++++++ gcc/ada/elists.adb | 492 + gcc/ada/elists.ads | 176 + gcc/ada/elists.h | 97 + gcc/ada/env.c | 325 + gcc/ada/env.h | 37 + gcc/ada/err_vars.ads | 153 + gcc/ada/errno.c | 66 + gcc/ada/errout.adb | 3060 ++++ gcc/ada/errout.ads | 828 + gcc/ada/erroutc.adb | 1380 ++ gcc/ada/erroutc.ads | 505 + gcc/ada/errutil.adb | 774 + gcc/ada/errutil.ads | 155 + gcc/ada/eval_fat.adb | 791 + gcc/ada/eval_fat.ads | 102 + gcc/ada/exit.c | 55 + gcc/ada/exp_aggr.adb | 6721 +++++++ gcc/ada/exp_aggr.ads | 65 + gcc/ada/exp_atag.adb | 904 + gcc/ada/exp_atag.ads | 193 + gcc/ada/exp_attr.adb | 5791 ++++++ gcc/ada/exp_attr.ads | 34 + gcc/ada/exp_cg.adb | 670 + gcc/ada/exp_cg.ads | 47 + gcc/ada/exp_ch10.ads | 29 + gcc/ada/exp_ch11.adb | 2035 +++ gcc/ada/exp_ch11.ads | 95 + gcc/ada/exp_ch12.adb | 67 + gcc/ada/exp_ch12.ads | 32 + gcc/ada/exp_ch13.adb | 498 + gcc/ada/exp_ch13.ads | 36 + gcc/ada/exp_ch2.adb | 744 + gcc/ada/exp_ch2.ads | 45 + gcc/ada/exp_ch3.adb | 9142 ++++++++++ gcc/ada/exp_ch3.ads | 158 + gcc/ada/exp_ch4.adb | 10537 +++++++++++ gcc/ada/exp_ch4.ads | 100 + gcc/ada/exp_ch5.adb | 3933 ++++ gcc/ada/exp_ch5.ads | 38 + gcc/ada/exp_ch6.adb | 7498 ++++++++ gcc/ada/exp_ch6.ads | 166 + gcc/ada/exp_ch7.adb | 3631 ++++ gcc/ada/exp_ch7.ads | 248 + gcc/ada/exp_ch8.adb | 429 + gcc/ada/exp_ch8.ads | 35 + gcc/ada/exp_ch9.adb | 13112 +++++++++++++ gcc/ada/exp_ch9.ads | 354 + gcc/ada/exp_code.adb | 498 + gcc/ada/exp_code.ads | 127 + gcc/ada/exp_dbug.adb | 1445 ++ gcc/ada/exp_dbug.ads | 1592 ++ gcc/ada/exp_disp.adb | 8090 +++++++++ gcc/ada/exp_disp.ads | 391 + gcc/ada/exp_dist.adb | 11604 ++++++++++++ gcc/ada/exp_dist.ads | 165 + gcc/ada/exp_fixd.adb | 2391 +++ gcc/ada/exp_fixd.ads | 140 + gcc/ada/exp_imgv.adb | 1274 ++ gcc/ada/exp_imgv.ads | 96 + gcc/ada/exp_intr.adb | 1226 ++ gcc/ada/exp_intr.ads | 40 + gcc/ada/exp_pakd.adb | 2744 +++ gcc/ada/exp_pakd.ads | 280 + gcc/ada/exp_prag.adb | 829 + gcc/ada/exp_prag.ads | 34 + gcc/ada/exp_sel.adb | 201 + gcc/ada/exp_sel.ads | 112 + gcc/ada/exp_smem.adb | 391 + gcc/ada/exp_smem.ads | 59 + gcc/ada/exp_strm.adb | 1753 ++ gcc/ada/exp_strm.ads | 154 + gcc/ada/exp_tss.adb | 547 + gcc/ada/exp_tss.ads | 248 + gcc/ada/exp_util.adb | 5846 ++++++ gcc/ada/exp_util.ads | 727 + gcc/ada/exp_vfpt.adb | 606 + gcc/ada/exp_vfpt.ads | 64 + gcc/ada/expander.adb | 528 + gcc/ada/expander.ads | 167 + gcc/ada/expect.c | 513 + gcc/ada/fe.h | 253 + gcc/ada/final.c | 42 + gcc/ada/fmap.adb | 535 + gcc/ada/fmap.ads | 81 + gcc/ada/fname-sf.adb | 139 + gcc/ada/fname-sf.ads | 60 + gcc/ada/fname-uf.adb | 612 + gcc/ada/fname-uf.ads | 114 + gcc/ada/fname.adb | 204 + gcc/ada/fname.ads | 99 + gcc/ada/freeze.adb | 5889 ++++++ gcc/ada/freeze.ads | 243 + gcc/ada/frontend.adb | 426 + gcc/ada/frontend.ads | 29 + gcc/ada/g-allein.ads | 1354 ++ gcc/ada/g-alleve.adb | 4956 +++++ gcc/ada/g-alleve.ads | 525 + gcc/ada/g-altcon.adb | 514 + gcc/ada/g-altcon.ads | 101 + gcc/ada/g-altive.ads | 477 + gcc/ada/g-alveop.adb | 9702 ++++++++++ gcc/ada/g-alveop.ads | 8103 +++++++++ gcc/ada/g-alvety.ads | 150 + gcc/ada/g-alvevi.ads | 156 + gcc/ada/g-arrspl.adb | 313 + gcc/ada/g-arrspl.ads | 187 + gcc/ada/g-awk.adb | 1510 ++ gcc/ada/g-awk.ads | 643 + gcc/ada/g-boubuf.adb | 92 + gcc/ada/g-boubuf.ads | 103 + gcc/ada/g-boumai.ads | 98 + gcc/ada/g-bubsor.adb | 58 + gcc/ada/g-bubsor.ads | 68 + gcc/ada/g-busora.adb | 60 + gcc/ada/g-busora.ads | 65 + gcc/ada/g-busorg.adb | 60 + gcc/ada/g-busorg.ads | 74 + gcc/ada/g-byorma.adb | 197 + gcc/ada/g-byorma.ads | 102 + gcc/ada/g-bytswa-x86.adb | 194 + gcc/ada/g-bytswa.adb | 151 + gcc/ada/g-bytswa.ads | 206 + gcc/ada/g-calend.adb | 549 + gcc/ada/g-calend.ads | 150 + gcc/ada/g-casuti.adb | 40 + gcc/ada/g-casuti.ads | 79 + gcc/ada/g-catiio.adb | 827 + gcc/ada/g-catiio.ads | 156 + gcc/ada/g-cgi.adb | 496 + gcc/ada/g-cgi.ads | 257 + gcc/ada/g-cgicoo.adb | 407 + gcc/ada/g-cgicoo.ads | 122 + gcc/ada/g-cgideb.adb | 316 + gcc/ada/g-cgideb.ads | 49 + gcc/ada/g-comlin.adb | 3432 ++++ gcc/ada/g-comlin.ads | 1125 ++ gcc/ada/g-comver.adb | 74 + gcc/ada/g-comver.ads | 63 + gcc/ada/g-crc32.adb | 87 + gcc/ada/g-crc32.ads | 113 + gcc/ada/g-ctrl_c.adb | 57 + gcc/ada/g-ctrl_c.ads | 61 + gcc/ada/g-curexc.ads | 114 + gcc/ada/g-debpoo.adb | 1724 ++ gcc/ada/g-debpoo.ads | 341 + gcc/ada/g-debuti.adb | 190 + gcc/ada/g-debuti.ads | 83 + gcc/ada/g-decstr.adb | 972 + gcc/ada/g-decstr.ads | 163 + gcc/ada/g-deutst.ads | 45 + gcc/ada/g-diopit.adb | 398 + gcc/ada/g-diopit.ads | 94 + gcc/ada/g-dirope.adb | 775 + gcc/ada/g-dirope.ads | 277 + gcc/ada/g-dynhta.adb | 348 + gcc/ada/g-dynhta.ads | 242 + gcc/ada/g-dyntab.adb | 406 + gcc/ada/g-dyntab.ads | 225 + gcc/ada/g-eacodu-vms.adb | 71 + gcc/ada/g-eacodu.adb | 49 + gcc/ada/g-enblsp-vms-alpha.adb | 130 + gcc/ada/g-enblsp-vms-ia64.adb | 127 + gcc/ada/g-encstr.adb | 260 + gcc/ada/g-encstr.ads | 111 + gcc/ada/g-enutst.ads | 45 + gcc/ada/g-excact.adb | 131 + gcc/ada/g-excact.ads | 116 + gcc/ada/g-except.ads | 84 + gcc/ada/g-exctra.adb | 119 + gcc/ada/g-exctra.ads | 98 + gcc/ada/g-expect-vms.adb | 1306 ++ gcc/ada/g-expect.adb | 1453 ++ gcc/ada/g-expect.ads | 649 + gcc/ada/g-flocon.ads | 61 + gcc/ada/g-heasor.adb | 132 + gcc/ada/g-heasor.ads | 74 + gcc/ada/g-hesora.adb | 136 + gcc/ada/g-hesora.ads | 71 + gcc/ada/g-hesorg.adb | 144 + gcc/ada/g-hesorg.ads | 90 + gcc/ada/g-htable.adb | 42 + gcc/ada/g-htable.ads | 229 + gcc/ada/g-io-put-vxworks.adb | 55 + gcc/ada/g-io-put.adb | 42 + gcc/ada/g-io.adb | 193 + gcc/ada/g-io.ads | 93 + gcc/ada/g-io_aux.adb | 107 + gcc/ada/g-io_aux.ads | 56 + gcc/ada/g-locfil.adb | 134 + gcc/ada/g-locfil.ads | 74 + 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 | 38 + gcc/ada/g-md5.ads | 51 + gcc/ada/g-memdum.adb | 125 + gcc/ada/g-memdum.ads | 56 + gcc/ada/g-moreex.adb | 87 + gcc/ada/g-moreex.ads | 76 + gcc/ada/g-os_lib.adb | 38 + gcc/ada/g-os_lib.ads | 51 + gcc/ada/g-pehage.adb | 2599 +++ gcc/ada/g-pehage.ads | 240 + gcc/ada/g-rannum.adb | 308 + gcc/ada/g-rannum.ads | 138 + gcc/ada/g-regexp.adb | 38 + gcc/ada/g-regexp.ads | 72 + gcc/ada/g-regist.adb | 545 + gcc/ada/g-regist.ads | 157 + gcc/ada/g-regpat.adb | 39 + gcc/ada/g-regpat.ads | 74 + gcc/ada/g-sechas.adb | 366 + gcc/ada/g-sechas.ads | 193 + 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-semaph.adb | 86 + gcc/ada/g-semaph.ads | 99 + gcc/ada/g-sercom-linux.adb | 302 + gcc/ada/g-sercom-mingw.adb | 273 + gcc/ada/g-sercom.adb | 136 + gcc/ada/g-sercom.ads | 125 + gcc/ada/g-sestin.ads | 50 + gcc/ada/g-sha1.adb | 36 + gcc/ada/g-sha1.ads | 51 + 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-signal.adb | 65 + gcc/ada/g-signal.ads | 52 + gcc/ada/g-soccon.ads | 40 + gcc/ada/g-socket-dummy.adb | 34 + gcc/ada/g-socket-dummy.ads | 39 + gcc/ada/g-socket.adb | 2577 +++ gcc/ada/g-socket.ads | 1252 ++ gcc/ada/g-socthi-dummy.adb | 34 + gcc/ada/g-socthi-dummy.ads | 39 + gcc/ada/g-socthi-mingw.adb | 635 + gcc/ada/g-socthi-mingw.ads | 245 + gcc/ada/g-socthi-vms.adb | 478 + gcc/ada/g-socthi-vms.ads | 260 + gcc/ada/g-socthi-vxworks.adb | 494 + gcc/ada/g-socthi-vxworks.ads | 231 + gcc/ada/g-socthi.adb | 499 + gcc/ada/g-socthi.ads | 262 + gcc/ada/g-soliop-mingw.ads | 44 + gcc/ada/g-soliop-solaris.ads | 45 + gcc/ada/g-soliop.ads | 44 + gcc/ada/g-sothco-dummy.adb | 34 + gcc/ada/g-sothco-dummy.ads | 39 + gcc/ada/g-sothco.adb | 79 + gcc/ada/g-sothco.ads | 419 + gcc/ada/g-souinf.ads | 78 + gcc/ada/g-spchge.adb | 163 + gcc/ada/g-spchge.ads | 67 + gcc/ada/g-speche.adb | 53 + gcc/ada/g-speche.ads | 57 + gcc/ada/g-spipat.adb | 6452 +++++++ gcc/ada/g-spipat.ads | 1189 ++ gcc/ada/g-spitbo.adb | 771 + gcc/ada/g-spitbo.ads | 396 + gcc/ada/g-sptabo.ads | 43 + gcc/ada/g-sptain.ads | 43 + gcc/ada/g-sptavs.ads | 42 + gcc/ada/g-sse.ads | 137 + gcc/ada/g-ssvety.ads | 105 + gcc/ada/g-stheme.adb | 76 + gcc/ada/g-string.adb | 36 + gcc/ada/g-string.ads | 38 + gcc/ada/g-strspl.ads | 44 + gcc/ada/g-stseme.adb | 58 + gcc/ada/g-stsifd-sockets.adb | 236 + gcc/ada/g-table.adb | 331 + gcc/ada/g-table.ads | 206 + gcc/ada/g-tasloc.adb | 38 + gcc/ada/g-tasloc.ads | 48 + gcc/ada/g-tastus.ads | 38 + gcc/ada/g-thread.adb | 188 + gcc/ada/g-thread.ads | 151 + gcc/ada/g-timsta.adb | 59 + gcc/ada/g-timsta.ads | 40 + gcc/ada/g-traceb.adb | 52 + gcc/ada/g-traceb.ads | 103 + gcc/ada/g-trasym-unimplemented.adb | 72 + gcc/ada/g-trasym-unimplemented.ads | 66 + gcc/ada/g-trasym-vms-alpha.adb | 303 + gcc/ada/g-trasym-vms-ia64.adb | 345 + gcc/ada/g-trasym.adb | 154 + gcc/ada/g-trasym.ads | 96 + gcc/ada/g-u3spch.adb | 53 + gcc/ada/g-u3spch.ads | 59 + gcc/ada/g-utf_32.adb | 36 + gcc/ada/g-utf_32.ads | 47 + gcc/ada/g-wispch.adb | 51 + gcc/ada/g-wispch.ads | 55 + gcc/ada/g-wistsp.ads | 44 + gcc/ada/g-zspche.adb | 51 + gcc/ada/g-zspche.ads | 55 + gcc/ada/g-zstspl.ads | 44 + gcc/ada/gcc-interface/Make-lang.in | 4464 +++++ gcc/ada/gcc-interface/Makefile.in | 2836 +++ gcc/ada/gcc-interface/ada-tree.def | 74 + gcc/ada/gcc-interface/ada-tree.h | 454 + gcc/ada/gcc-interface/ada.h | 73 + gcc/ada/gcc-interface/config-lang.in | 43 + gcc/ada/gcc-interface/cuintp.c | 202 + gcc/ada/gcc-interface/decl.c | 8853 +++++++++ gcc/ada/gcc-interface/gadaint.h | 35 + gcc/ada/gcc-interface/gigi.h | 954 + gcc/ada/gcc-interface/lang-specs.h | 48 + gcc/ada/gcc-interface/lang.opt | 119 + gcc/ada/gcc-interface/misc.c | 760 + gcc/ada/gcc-interface/targtyps.c | 261 + gcc/ada/gcc-interface/trans.c | 8007 ++++++++ gcc/ada/gcc-interface/utils.c | 5579 ++++++ gcc/ada/gcc-interface/utils2.c | 2574 +++ gcc/ada/get_scos.adb | 399 + gcc/ada/get_scos.ads | 58 + gcc/ada/get_targ.adb | 77 + gcc/ada/get_targ.ads | 114 + gcc/ada/gnat-style.texi | 930 + gcc/ada/gnat.ads | 39 + gcc/ada/gnat1drv.adb | 1092 ++ gcc/ada/gnat1drv.ads | 32 + gcc/ada/gnat_rm.texi | 17952 ++++++++++++++++++ gcc/ada/gnat_ugn.texi | 28265 +++++++++++++++++++++++++++++ gcc/ada/gnatbind.adb | 982 + gcc/ada/gnatbind.ads | 28 + gcc/ada/gnatchop.adb | 1889 ++ gcc/ada/gnatclean.adb | 41 + gcc/ada/gnatcmd.adb | 2646 +++ gcc/ada/gnatcmd.ads | 58 + gcc/ada/gnatdll.adb | 584 + gcc/ada/gnatfind.adb | 389 + gcc/ada/gnathtml.pl | 1114 ++ gcc/ada/gnatkr.adb | 137 + gcc/ada/gnatkr.ads | 39 + gcc/ada/gnatlink.adb | 2272 +++ gcc/ada/gnatlink.ads | 30 + gcc/ada/gnatls.adb | 1880 ++ gcc/ada/gnatls.ads | 28 + gcc/ada/gnatmake.adb | 39 + gcc/ada/gnatmake.ads | 30 + gcc/ada/gnatname.adb | 704 + gcc/ada/gnatname.ads | 30 + gcc/ada/gnatprep.adb | 36 + gcc/ada/gnatprep.ads | 161 + gcc/ada/gnatsym.adb | 359 + gcc/ada/gnatvsn.adb | 84 + gcc/ada/gnatvsn.ads | 98 + gcc/ada/gnatxref.adb | 327 + gcc/ada/gprep.adb | 823 + gcc/ada/gprep.ads | 33 + gcc/ada/gsocket.h | 240 + gcc/ada/hlo.adb | 43 + gcc/ada/hlo.ads | 36 + gcc/ada/hostparm.ads | 90 + gcc/ada/i-c.adb | 826 + gcc/ada/i-c.ads | 230 + gcc/ada/i-cexten.ads | 263 + gcc/ada/i-cobol.adb | 994 + gcc/ada/i-cobol.ads | 553 + gcc/ada/i-cpoint.adb | 277 + gcc/ada/i-cpoint.ads | 99 + gcc/ada/i-cpp.adb | 35 + gcc/ada/i-cpp.ads | 50 + gcc/ada/i-cstrea-vms.adb | 253 + gcc/ada/i-cstrea.adb | 137 + gcc/ada/i-cstrea.ads | 274 + gcc/ada/i-cstrin.adb | 342 + gcc/ada/i-cstrin.ads | 102 + gcc/ada/i-forbla-darwin.adb | 38 + gcc/ada/i-forbla-unimplemented.ads | 45 + gcc/ada/i-forbla.adb | 42 + gcc/ada/i-forbla.ads | 261 + gcc/ada/i-forlap.ads | 414 + gcc/ada/i-fortra.adb | 142 + gcc/ada/i-fortra.ads | 69 + 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 | 221 + gcc/ada/i-vxwork.ads | 215 + gcc/ada/impunit.adb | 752 + gcc/ada/impunit.ads | 75 + gcc/ada/indepsw-aix.adb | 67 + gcc/ada/indepsw-gnu.adb | 67 + gcc/ada/indepsw-mingw.adb | 67 + gcc/ada/indepsw.adb | 67 + gcc/ada/indepsw.ads | 82 + gcc/ada/init.c | 2460 +++ gcc/ada/initialize.c | 362 + gcc/ada/inline.adb | 1233 ++ gcc/ada/inline.ads | 153 + gcc/ada/interfac.ads | 171 + gcc/ada/ioexcept.ads | 24 + gcc/ada/itypes.adb | 121 + gcc/ada/itypes.ads | 171 + gcc/ada/krunch.adb | 265 + gcc/ada/krunch.ads | 138 + gcc/ada/layout.adb | 3239 ++++ gcc/ada/layout.ads | 83 + gcc/ada/lib-list.adb | 118 + gcc/ada/lib-load.adb | 911 + gcc/ada/lib-load.ads | 204 + gcc/ada/lib-sort.adb | 99 + gcc/ada/lib-util.adb | 292 + gcc/ada/lib-util.ads | 86 + gcc/ada/lib-writ.adb | 1328 ++ gcc/ada/lib-writ.ads | 794 + gcc/ada/lib-xref.adb | 2245 +++ gcc/ada/lib-xref.ads | 681 + gcc/ada/lib.adb | 1101 ++ gcc/ada/lib.ads | 862 + gcc/ada/link.c | 256 + gcc/ada/live.adb | 345 + gcc/ada/live.ads | 36 + gcc/ada/locales.c | 56 + gcc/ada/machcode.ads | 18 + gcc/ada/make.adb | 8593 +++++++++ gcc/ada/make.ads | 35 + gcc/ada/makeusg.adb | 377 + gcc/ada/makeusg.ads | 29 + gcc/ada/makeutl.adb | 1210 ++ gcc/ada/makeutl.ads | 241 + gcc/ada/math_lib.adb | 1025 ++ gcc/ada/mdll-fil.adb | 92 + gcc/ada/mdll-fil.ads | 48 + gcc/ada/mdll-utl.adb | 366 + gcc/ada/mdll-utl.ads | 64 + gcc/ada/mdll.adb | 517 + gcc/ada/mdll.ads | 81 + gcc/ada/memtrack.adb | 404 + gcc/ada/mingw32.h | 135 + gcc/ada/mkdir.c | 73 + gcc/ada/mlib-fil.adb | 149 + gcc/ada/mlib-fil.ads | 52 + gcc/ada/mlib-prj.adb | 2494 +++ gcc/ada/mlib-prj.ads | 55 + gcc/ada/mlib-tgt-specific-aix.adb | 225 + gcc/ada/mlib-tgt-specific-darwin.adb | 176 + gcc/ada/mlib-tgt-specific-hpux.adb | 164 + gcc/ada/mlib-tgt-specific-irix.adb | 182 + gcc/ada/mlib-tgt-specific-linux.adb | 148 + gcc/ada/mlib-tgt-specific-lynxos.adb | 149 + gcc/ada/mlib-tgt-specific-mingw.adb | 162 + gcc/ada/mlib-tgt-specific-solaris.adb | 145 + gcc/ada/mlib-tgt-specific-tru64.adb | 168 + gcc/ada/mlib-tgt-specific-vms-alpha.adb | 513 + gcc/ada/mlib-tgt-specific-vms-ia64.adb | 517 + gcc/ada/mlib-tgt-specific-vxworks.adb | 217 + gcc/ada/mlib-tgt-specific-xi.adb | 219 + gcc/ada/mlib-tgt-specific.adb | 47 + gcc/ada/mlib-tgt-specific.ads | 34 + gcc/ada/mlib-tgt-vms_common.adb | 155 + gcc/ada/mlib-tgt-vms_common.ads | 30 + gcc/ada/mlib-tgt.adb | 505 + gcc/ada/mlib-tgt.ads | 270 + gcc/ada/mlib-utl.adb | 656 + gcc/ada/mlib-utl.ads | 67 + gcc/ada/mlib.adb | 470 + gcc/ada/mlib.ads | 97 + gcc/ada/namet-sp.adb | 203 + gcc/ada/namet-sp.ads | 46 + gcc/ada/namet.adb | 1343 ++ gcc/ada/namet.ads | 544 + gcc/ada/namet.h | 129 + gcc/ada/nlists.adb | 1459 ++ gcc/ada/nlists.ads | 374 + gcc/ada/nlists.h | 130 + gcc/ada/nmake.adt | 80 + gcc/ada/opt.adb | 321 + gcc/ada/opt.ads | 1907 ++ gcc/ada/osint-b.adb | 219 + gcc/ada/osint-b.ads | 96 + gcc/ada/osint-c.adb | 509 + gcc/ada/osint-c.ads | 174 + gcc/ada/osint-l.adb | 42 + gcc/ada/osint-l.ads | 43 + gcc/ada/osint-m.adb | 60 + gcc/ada/osint-m.ads | 50 + gcc/ada/osint.adb | 3337 ++++ gcc/ada/osint.ads | 776 + gcc/ada/output.adb | 431 + gcc/ada/output.ads | 222 + gcc/ada/par-ch10.adb | 1188 ++ gcc/ada/par-ch11.adb | 259 + gcc/ada/par-ch12.adb | 1262 ++ gcc/ada/par-ch13.adb | 697 + gcc/ada/par-ch2.adb | 523 + gcc/ada/par-ch3.adb | 4674 +++++ gcc/ada/par-ch4.adb | 3034 ++++ gcc/ada/par-ch5.adb | 2382 +++ gcc/ada/par-ch6.adb | 1727 ++ gcc/ada/par-ch7.adb | 294 + gcc/ada/par-ch8.adb | 188 + gcc/ada/par-ch9.adb | 1861 ++ gcc/ada/par-endh.adb | 1268 ++ gcc/ada/par-labl.adb | 541 + gcc/ada/par-load.adb | 475 + gcc/ada/par-prag.adb | 1286 ++ gcc/ada/par-sync.adb | 343 + gcc/ada/par-tchk.adb | 904 + gcc/ada/par-util.adb | 728 + gcc/ada/par.adb | 1541 ++ gcc/ada/par.ads | 41 + gcc/ada/par_sco.adb | 1510 ++ gcc/ada/par_sco.ads | 73 + gcc/ada/prep.adb | 1483 ++ gcc/ada/prep.ads | 135 + gcc/ada/prepcomp.adb | 788 + gcc/ada/prepcomp.ads | 66 + gcc/ada/prj-attr-pm.adb | 73 + gcc/ada/prj-attr-pm.ads | 48 + gcc/ada/prj-attr.adb | 990 + gcc/ada/prj-attr.ads | 340 + gcc/ada/prj-com.ads | 40 + gcc/ada/prj-conf.adb | 1394 ++ gcc/ada/prj-conf.ads | 200 + gcc/ada/prj-dect.adb | 1791 ++ gcc/ada/prj-dect.ads | 61 + gcc/ada/prj-env.adb | 2189 +++ gcc/ada/prj-env.ads | 227 + gcc/ada/prj-err.adb | 125 + gcc/ada/prj-err.ads | 97 + gcc/ada/prj-ext.adb | 133 + gcc/ada/prj-ext.ads | 68 + gcc/ada/prj-makr.adb | 1522 ++ gcc/ada/prj-makr.ads | 88 + gcc/ada/prj-nmsc.adb | 8025 ++++++++ gcc/ada/prj-nmsc.ads | 45 + gcc/ada/prj-pars.adb | 142 + gcc/ada/prj-pars.ads | 68 + gcc/ada/prj-part.adb | 2003 ++ gcc/ada/prj-part.ads | 57 + gcc/ada/prj-pp.adb | 959 + gcc/ada/prj-pp.ads | 94 + gcc/ada/prj-proc.adb | 2862 +++ gcc/ada/prj-proc.ads | 78 + gcc/ada/prj-strt.adb | 1556 ++ gcc/ada/prj-strt.ads | 109 + gcc/ada/prj-tree.adb | 3112 ++++ gcc/ada/prj-tree.ads | 1502 ++ gcc/ada/prj-util.adb | 1191 ++ gcc/ada/prj-util.ads | 253 + gcc/ada/prj.adb | 1309 ++ gcc/ada/prj.ads | 1709 ++ gcc/ada/projects.texi | 3969 ++++ gcc/ada/put_scos.adb | 205 + gcc/ada/put_scos.ads | 54 + gcc/ada/raise-gcc.c | 1237 ++ gcc/ada/raise.c | 81 + gcc/ada/raise.h | 62 + gcc/ada/repinfo.adb | 1435 ++ gcc/ada/repinfo.ads | 311 + gcc/ada/repinfo.h | 77 + gcc/ada/restrict.adb | 994 + gcc/ada/restrict.ads | 361 + gcc/ada/rident.ads | 49 + gcc/ada/rtsfind.adb | 1490 ++ gcc/ada/rtsfind.ads | 3057 ++++ gcc/ada/s-addima.adb | 72 + gcc/ada/s-addima.ads | 42 + gcc/ada/s-addope.adb | 110 + gcc/ada/s-addope.ads | 87 + gcc/ada/s-arit64.adb | 673 + gcc/ada/s-arit64.ads | 79 + gcc/ada/s-assert.adb | 49 + gcc/ada/s-assert.ads | 48 + gcc/ada/s-asthan-vms-alpha.adb | 603 + gcc/ada/s-asthan.adb | 58 + gcc/ada/s-asthan.ads | 57 + gcc/ada/s-atacco.adb | 38 + gcc/ada/s-atacco.ads | 75 + gcc/ada/s-auxdec-empty.adb | 34 + gcc/ada/s-auxdec-empty.ads | 47 + gcc/ada/s-auxdec-vms-alpha.adb | 809 + gcc/ada/s-auxdec-vms_64.ads | 695 + gcc/ada/s-auxdec.adb | 718 + gcc/ada/s-auxdec.ads | 677 + gcc/ada/s-bitops.adb | 220 + gcc/ada/s-bitops.ads | 99 + gcc/ada/s-boarop.ads | 65 + 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 | 107 + 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 | 58 + gcc/ada/s-commun.adb | 55 + gcc/ada/s-commun.ads | 49 + 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 | 199 + gcc/ada/s-crtrun.ads | 46 + gcc/ada/s-direio.adb | 389 + gcc/ada/s-direio.ads | 142 + gcc/ada/s-dsaser.ads | 54 + gcc/ada/s-except.adb | 75 + gcc/ada/s-except.ads | 78 + gcc/ada/s-exctab.adb | 246 + gcc/ada/s-exctab.ads | 75 + gcc/ada/s-exnint.adb | 70 + gcc/ada/s-exnint.ads | 39 + gcc/ada/s-exnllf.adb | 97 + gcc/ada/s-exnllf.ads | 42 + 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 | 87 + gcc/ada/s-expmod.ads | 45 + gcc/ada/s-expuns.adb | 73 + gcc/ada/s-expuns.ads | 47 + gcc/ada/s-fatflt.ads | 47 + gcc/ada/s-fatgen.adb | 921 + gcc/ada/s-fatgen.ads | 129 + gcc/ada/s-fatlfl.ads | 47 + gcc/ada/s-fatllf.ads | 47 + gcc/ada/s-fatsfl.ads | 47 + gcc/ada/s-ficobl.ads | 161 + gcc/ada/s-fileio.adb | 1234 ++ gcc/ada/s-fileio.ads | 254 + gcc/ada/s-filofl.ads | 52 + gcc/ada/s-finimp.adb | 540 + gcc/ada/s-finimp.ads | 158 + gcc/ada/s-finroo.adb | 63 + gcc/ada/s-finroo.ads | 85 + gcc/ada/s-fishfl.ads | 52 + gcc/ada/s-fore.adb | 56 + gcc/ada/s-fore.ads | 41 + gcc/ada/s-fvadfl.ads | 54 + gcc/ada/s-fvaffl.ads | 54 + gcc/ada/s-fvagfl.ads | 54 + gcc/ada/s-gearop.adb | 526 + gcc/ada/s-gearop.ads | 396 + gcc/ada/s-gecobl.adb | 350 + gcc/ada/s-gecobl.ads | 102 + gcc/ada/s-gecola.adb | 493 + gcc/ada/s-gecola.ads | 131 + gcc/ada/s-gerebl.adb | 311 + gcc/ada/s-gerebl.ads | 96 + gcc/ada/s-gerela.adb | 564 + gcc/ada/s-gerela.ads | 128 + gcc/ada/s-geveop.adb | 133 + gcc/ada/s-geveop.ads | 66 + gcc/ada/s-gloloc-mingw.adb | 109 + gcc/ada/s-gloloc.adb | 149 + gcc/ada/s-gloloc.ads | 63 + gcc/ada/s-hibaen.ads | 99 + gcc/ada/s-htable.adb | 376 + gcc/ada/s-htable.ads | 216 + gcc/ada/s-imenne.adb | 128 + gcc/ada/s-imenne.ads | 85 + gcc/ada/s-imgbiu.adb | 154 + 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 | 400 + gcc/ada/s-imgdec.ads | 83 + gcc/ada/s-imgenu.adb | 128 + gcc/ada/s-imgenu.ads | 78 + gcc/ada/s-imgint.adb | 122 + gcc/ada/s-imgint.ads | 57 + gcc/ada/s-imgllb.adb | 157 + gcc/ada/s-imgllb.ads | 72 + gcc/ada/s-imglld.adb | 82 + gcc/ada/s-imglld.ads | 67 + gcc/ada/s-imglli.adb | 98 + gcc/ada/s-imglli.ads | 57 + gcc/ada/s-imgllu.adb | 87 + gcc/ada/s-imgllu.ads | 61 + gcc/ada/s-imgllw.adb | 136 + gcc/ada/s-imgllw.ads | 69 + gcc/ada/s-imgrea.adb | 704 + gcc/ada/s-imgrea.ads | 76 + gcc/ada/s-imguns.adb | 87 + gcc/ada/s-imguns.ads | 60 + gcc/ada/s-imgwch.adb | 125 + gcc/ada/s-imgwch.ads | 56 + gcc/ada/s-imgwiu.adb | 134 + gcc/ada/s-imgwiu.ads | 69 + gcc/ada/s-inmaop-dummy.adb | 201 + gcc/ada/s-inmaop-posix.adb | 338 + gcc/ada/s-inmaop-vms.adb | 303 + gcc/ada/s-inmaop.ads | 125 + gcc/ada/s-interr-dummy.adb | 306 + gcc/ada/s-interr-hwint.adb | 1105 ++ gcc/ada/s-interr-sigaction.adb | 664 + gcc/ada/s-interr-vms.adb | 1128 ++ gcc/ada/s-interr.adb | 1467 ++ gcc/ada/s-interr.ads | 276 + gcc/ada/s-intman-dummy.adb | 45 + gcc/ada/s-intman-irix.adb | 139 + gcc/ada/s-intman-mingw.adb | 59 + gcc/ada/s-intman-posix.adb | 293 + gcc/ada/s-intman-solaris.adb | 237 + gcc/ada/s-intman-susv3.adb | 170 + gcc/ada/s-intman-vms.adb | 76 + gcc/ada/s-intman-vms.ads | 119 + gcc/ada/s-intman-vxworks.adb | 153 + gcc/ada/s-intman-vxworks.ads | 112 + gcc/ada/s-intman.ads | 111 + gcc/ada/s-io.adb | 129 + gcc/ada/s-io.ads | 64 + gcc/ada/s-linux-alpha.ads | 119 + gcc/ada/s-linux-hppa.ads | 128 + gcc/ada/s-linux-mipsel.ads | 118 + gcc/ada/s-linux-sparc.ads | 119 + gcc/ada/s-linux.ads | 119 + gcc/ada/s-maccod.ads | 126 + gcc/ada/s-mantis.adb | 53 + gcc/ada/s-mantis.ads | 42 + gcc/ada/s-mastop-irix.adb | 351 + gcc/ada/s-mastop-tru64.adb | 165 + gcc/ada/s-mastop-vms.adb | 276 + gcc/ada/s-mastop.adb | 108 + gcc/ada/s-mastop.ads | 107 + gcc/ada/s-memcop.ads | 72 + gcc/ada/s-memory-mingw.adb | 221 + gcc/ada/s-memory.adb | 150 + gcc/ada/s-memory.ads | 107 + gcc/ada/s-multip.adb | 45 + gcc/ada/s-multip.ads | 28 + gcc/ada/s-os_lib.adb | 2731 +++ gcc/ada/s-os_lib.ads | 992 + gcc/ada/s-oscons-tmplt.c | 1372 ++ gcc/ada/s-osinte-aix.adb | 232 + gcc/ada/s-osinte-aix.ads | 602 + gcc/ada/s-osinte-darwin.adb | 170 + gcc/ada/s-osinte-darwin.ads | 596 + gcc/ada/s-osinte-dummy.ads | 53 + gcc/ada/s-osinte-freebsd.adb | 115 + gcc/ada/s-osinte-freebsd.ads | 650 + gcc/ada/s-osinte-hpux-dce.adb | 500 + gcc/ada/s-osinte-hpux-dce.ads | 483 + gcc/ada/s-osinte-hpux.ads | 571 + gcc/ada/s-osinte-irix.adb | 87 + gcc/ada/s-osinte-irix.ads | 522 + gcc/ada/s-osinte-kfreebsd-gnu.ads | 544 + gcc/ada/s-osinte-linux.ads | 568 + gcc/ada/s-osinte-lynxos-3.adb | 575 + gcc/ada/s-osinte-lynxos-3.ads | 559 + gcc/ada/s-osinte-lynxos.adb | 121 + gcc/ada/s-osinte-lynxos.ads | 585 + gcc/ada/s-osinte-mingw.ads | 363 + gcc/ada/s-osinte-posix.adb | 112 + gcc/ada/s-osinte-rtems.adb | 125 + gcc/ada/s-osinte-rtems.ads | 629 + gcc/ada/s-osinte-solaris-posix.ads | 554 + gcc/ada/s-osinte-solaris.adb | 89 + gcc/ada/s-osinte-solaris.ads | 544 + gcc/ada/s-osinte-tru64.adb | 142 + gcc/ada/s-osinte-tru64.ads | 592 + gcc/ada/s-osinte-vms.adb | 79 + gcc/ada/s-osinte-vms.ads | 652 + gcc/ada/s-osinte-vxworks.adb | 252 + gcc/ada/s-osinte-vxworks.ads | 506 + gcc/ada/s-osprim-darwin.adb | 175 + gcc/ada/s-osprim-mingw.adb | 342 + gcc/ada/s-osprim-posix.adb | 173 + gcc/ada/s-osprim-solaris.adb | 132 + gcc/ada/s-osprim-unix.adb | 132 + gcc/ada/s-osprim-vms.adb | 209 + gcc/ada/s-osprim-vms.ads | 110 + gcc/ada/s-osprim-vxworks.adb | 165 + gcc/ada/s-osprim.ads | 91 + gcc/ada/s-pack03.adb | 112 + gcc/ada/s-pack03.ads | 50 + gcc/ada/s-pack05.adb | 112 + gcc/ada/s-pack05.ads | 50 + gcc/ada/s-pack06.adb | 165 + gcc/ada/s-pack06.ads | 60 + gcc/ada/s-pack07.adb | 112 + gcc/ada/s-pack07.ads | 50 + gcc/ada/s-pack09.adb | 112 + gcc/ada/s-pack09.ads | 50 + gcc/ada/s-pack10.adb | 165 + gcc/ada/s-pack10.ads | 60 + gcc/ada/s-pack11.adb | 112 + gcc/ada/s-pack11.ads | 50 + gcc/ada/s-pack12.adb | 165 + gcc/ada/s-pack12.ads | 60 + gcc/ada/s-pack13.adb | 112 + gcc/ada/s-pack13.ads | 50 + gcc/ada/s-pack14.adb | 163 + gcc/ada/s-pack14.ads | 60 + gcc/ada/s-pack15.adb | 112 + gcc/ada/s-pack15.ads | 50 + gcc/ada/s-pack17.adb | 112 + gcc/ada/s-pack17.ads | 50 + gcc/ada/s-pack18.adb | 163 + gcc/ada/s-pack18.ads | 60 + gcc/ada/s-pack19.adb | 112 + gcc/ada/s-pack19.ads | 50 + gcc/ada/s-pack20.adb | 163 + gcc/ada/s-pack20.ads | 60 + gcc/ada/s-pack21.adb | 112 + gcc/ada/s-pack21.ads | 50 + gcc/ada/s-pack22.adb | 163 + gcc/ada/s-pack22.ads | 60 + gcc/ada/s-pack23.adb | 112 + gcc/ada/s-pack23.ads | 50 + gcc/ada/s-pack24.adb | 163 + gcc/ada/s-pack24.ads | 60 + gcc/ada/s-pack25.adb | 114 + gcc/ada/s-pack25.ads | 50 + gcc/ada/s-pack26.adb | 163 + gcc/ada/s-pack26.ads | 60 + gcc/ada/s-pack27.adb | 112 + gcc/ada/s-pack27.ads | 50 + gcc/ada/s-pack28.adb | 163 + gcc/ada/s-pack28.ads | 60 + gcc/ada/s-pack29.adb | 112 + gcc/ada/s-pack29.ads | 50 + gcc/ada/s-pack30.adb | 163 + gcc/ada/s-pack30.ads | 60 + gcc/ada/s-pack31.adb | 112 + gcc/ada/s-pack31.ads | 50 + gcc/ada/s-pack33.adb | 112 + gcc/ada/s-pack33.ads | 50 + gcc/ada/s-pack34.adb | 163 + gcc/ada/s-pack34.ads | 60 + gcc/ada/s-pack35.adb | 112 + gcc/ada/s-pack35.ads | 50 + gcc/ada/s-pack36.adb | 163 + gcc/ada/s-pack36.ads | 60 + gcc/ada/s-pack37.adb | 112 + gcc/ada/s-pack37.ads | 50 + gcc/ada/s-pack38.adb | 163 + gcc/ada/s-pack38.ads | 60 + gcc/ada/s-pack39.adb | 112 + gcc/ada/s-pack39.ads | 50 + gcc/ada/s-pack40.adb | 163 + gcc/ada/s-pack40.ads | 60 + gcc/ada/s-pack41.adb | 112 + gcc/ada/s-pack41.ads | 50 + gcc/ada/s-pack42.adb | 163 + gcc/ada/s-pack42.ads | 60 + gcc/ada/s-pack43.adb | 112 + gcc/ada/s-pack43.ads | 50 + gcc/ada/s-pack44.adb | 163 + gcc/ada/s-pack44.ads | 60 + gcc/ada/s-pack45.adb | 112 + gcc/ada/s-pack45.ads | 50 + gcc/ada/s-pack46.adb | 163 + gcc/ada/s-pack46.ads | 60 + gcc/ada/s-pack47.adb | 112 + gcc/ada/s-pack47.ads | 50 + gcc/ada/s-pack48.adb | 163 + gcc/ada/s-pack48.ads | 60 + gcc/ada/s-pack49.adb | 112 + gcc/ada/s-pack49.ads | 50 + gcc/ada/s-pack50.adb | 163 + gcc/ada/s-pack50.ads | 60 + gcc/ada/s-pack51.adb | 112 + gcc/ada/s-pack51.ads | 50 + gcc/ada/s-pack52.adb | 163 + gcc/ada/s-pack52.ads | 60 + gcc/ada/s-pack53.adb | 112 + gcc/ada/s-pack53.ads | 50 + gcc/ada/s-pack54.adb | 163 + gcc/ada/s-pack54.ads | 60 + gcc/ada/s-pack55.adb | 112 + gcc/ada/s-pack55.ads | 50 + gcc/ada/s-pack56.adb | 163 + gcc/ada/s-pack56.ads | 60 + gcc/ada/s-pack57.adb | 112 + gcc/ada/s-pack57.ads | 50 + gcc/ada/s-pack58.adb | 163 + gcc/ada/s-pack58.ads | 60 + gcc/ada/s-pack59.adb | 112 + gcc/ada/s-pack59.ads | 50 + gcc/ada/s-pack60.adb | 163 + gcc/ada/s-pack60.ads | 60 + gcc/ada/s-pack61.adb | 112 + gcc/ada/s-pack61.ads | 50 + gcc/ada/s-pack62.adb | 163 + gcc/ada/s-pack62.ads | 60 + gcc/ada/s-pack63.adb | 112 + gcc/ada/s-pack63.ads | 50 + gcc/ada/s-parame-ae653.ads | 204 + gcc/ada/s-parame-hpux.ads | 202 + gcc/ada/s-parame-rtems.adb | 78 + gcc/ada/s-parame-vms-alpha.ads | 204 + gcc/ada/s-parame-vms-ia64.ads | 204 + gcc/ada/s-parame-vms-restrict.ads | 204 + gcc/ada/s-parame-vxworks.adb | 75 + gcc/ada/s-parame-vxworks.ads | 204 + gcc/ada/s-parame.adb | 82 + gcc/ada/s-parame.ads | 204 + gcc/ada/s-parint.adb | 320 + gcc/ada/s-parint.ads | 190 + gcc/ada/s-pooglo.adb | 104 + gcc/ada/s-pooglo.ads | 79 + gcc/ada/s-pooloc.adb | 160 + 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-proinf-irix-athread.adb | 225 + gcc/ada/s-proinf-irix-athread.ads | 76 + gcc/ada/s-proinf.adb | 41 + gcc/ada/s-proinf.ads | 43 + gcc/ada/s-purexc.ads | 77 + gcc/ada/s-rannum.adb | 703 + gcc/ada/s-rannum.ads | 153 + gcc/ada/s-regexp.adb | 1670 ++ gcc/ada/s-regexp.ads | 139 + gcc/ada/s-regpat.adb | 3715 ++++ gcc/ada/s-regpat.ads | 646 + gcc/ada/s-restri.adb | 59 + gcc/ada/s-restri.ads | 73 + gcc/ada/s-rident.ads | 420 + gcc/ada/s-rpc.adb | 111 + gcc/ada/s-rpc.ads | 94 + gcc/ada/s-scaval.adb | 328 + gcc/ada/s-scaval.ads | 93 + gcc/ada/s-secsta.adb | 539 + gcc/ada/s-secsta.ads | 119 + gcc/ada/s-sequio.adb | 165 + gcc/ada/s-sequio.ads | 78 + gcc/ada/s-shasto.adb | 585 + gcc/ada/s-shasto.ads | 183 + gcc/ada/s-soflin.adb | 333 + gcc/ada/s-soflin.ads | 397 + gcc/ada/s-solita.adb | 222 + gcc/ada/s-solita.ads | 43 + 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-stache.adb | 38 + gcc/ada/s-stache.ads | 82 + gcc/ada/s-stalib.adb | 104 + gcc/ada/s-stalib.ads | 276 + gcc/ada/s-stausa.adb | 677 + gcc/ada/s-stausa.ads | 347 + gcc/ada/s-stchop-limit.ads | 53 + gcc/ada/s-stchop-rtems.adb | 113 + gcc/ada/s-stchop-vxworks.adb | 153 + gcc/ada/s-stchop.adb | 279 + gcc/ada/s-stchop.ads | 82 + gcc/ada/s-stoele.adb | 130 + gcc/ada/s-stoele.ads | 117 + gcc/ada/s-stopoo.adb | 63 + gcc/ada/s-stopoo.ads | 86 + gcc/ada/s-stratt-xdr.adb | 1891 ++ gcc/ada/s-stratt.adb | 708 + gcc/ada/s-stratt.ads | 210 + gcc/ada/s-strcom.adb | 140 + gcc/ada/s-strcom.ads | 59 + gcc/ada/s-strhas.adb | 68 + gcc/ada/s-strhas.ads | 60 + gcc/ada/s-string.adb | 61 + gcc/ada/s-string.ads | 63 + gcc/ada/s-strops.adb | 109 + gcc/ada/s-strops.ads | 56 + gcc/ada/s-ststop.adb | 685 + gcc/ada/s-ststop.ads | 163 + gcc/ada/s-stusta.adb | 261 + gcc/ada/s-stusta.ads | 77 + gcc/ada/s-taasde.adb | 412 + gcc/ada/s-taasde.ads | 149 + gcc/ada/s-tadeca.adb | 53 + gcc/ada/s-tadeca.ads | 41 + gcc/ada/s-tadert.adb | 53 + gcc/ada/s-tadert.ads | 41 + gcc/ada/s-taenca.adb | 666 + gcc/ada/s-taenca.ads | 97 + gcc/ada/s-taprob.adb | 281 + gcc/ada/s-taprob.ads | 246 + gcc/ada/s-taprop-dummy.adb | 519 + gcc/ada/s-taprop-hpux-dce.adb | 1247 ++ gcc/ada/s-taprop-irix.adb | 1348 ++ gcc/ada/s-taprop-linux.adb | 1354 ++ gcc/ada/s-taprop-lynxos.adb | 1423 ++ gcc/ada/s-taprop-mingw.adb | 1380 ++ gcc/ada/s-taprop-posix.adb | 1455 ++ gcc/ada/s-taprop-solaris.adb | 1990 ++ gcc/ada/s-taprop-tru64.adb | 1361 ++ gcc/ada/s-taprop-vms.adb | 1276 ++ gcc/ada/s-taprop-vxworks.adb | 1418 ++ gcc/ada/s-taprop.ads | 546 + gcc/ada/s-tarest.adb | 643 + gcc/ada/s-tarest.ads | 225 + gcc/ada/s-tasdeb.adb | 373 + gcc/ada/s-tasdeb.ads | 148 + gcc/ada/s-tasinf-irix.ads | 118 + gcc/ada/s-tasinf-linux.adb | 55 + gcc/ada/s-tasinf-linux.ads | 101 + gcc/ada/s-tasinf-mingw.adb | 65 + gcc/ada/s-tasinf-mingw.ads | 102 + gcc/ada/s-tasinf-solaris.adb | 87 + gcc/ada/s-tasinf-solaris.ads | 141 + gcc/ada/s-tasinf-tru64.ads | 110 + gcc/ada/s-tasinf-vxworks.ads | 90 + gcc/ada/s-tasinf.adb | 41 + gcc/ada/s-tasinf.ads | 92 + gcc/ada/s-tasini.adb | 829 + gcc/ada/s-tasini.ads | 190 + gcc/ada/s-taskin.adb | 227 + gcc/ada/s-taskin.ads | 1130 ++ gcc/ada/s-tasloc.adb | 56 + gcc/ada/s-tasloc.ads | 100 + gcc/ada/s-taspri-dummy.ads | 67 + gcc/ada/s-taspri-hpux-dce.ads | 118 + gcc/ada/s-taspri-lynxos.ads | 125 + gcc/ada/s-taspri-mingw.ads | 124 + gcc/ada/s-taspri-posix-noaltstack.ads | 124 + gcc/ada/s-taspri-posix.ads | 123 + gcc/ada/s-taspri-solaris.ads | 156 + gcc/ada/s-taspri-tru64.ads | 119 + gcc/ada/s-taspri-vms.ads | 132 + gcc/ada/s-taspri-vxworks.ads | 126 + gcc/ada/s-tasque.adb | 625 + gcc/ada/s-tasque.ads | 99 + gcc/ada/s-tasren.adb | 1802 ++ gcc/ada/s-tasren.ads | 329 + gcc/ada/s-tasres.ads | 35 + gcc/ada/s-tassta.adb | 2026 +++ gcc/ada/s-tassta.ads | 310 + gcc/ada/s-tasuti.adb | 529 + gcc/ada/s-tasuti.ads | 104 + gcc/ada/s-tataat.adb | 217 + gcc/ada/s-tataat.ads | 129 + gcc/ada/s-tfsetr-default.adb | 311 + gcc/ada/s-tfsetr-vxworks.adb | 105 + gcc/ada/s-tpinop.adb | 77 + gcc/ada/s-tpinop.ads | 50 + gcc/ada/s-tpoben.adb | 463 + gcc/ada/s-tpoben.ads | 230 + gcc/ada/s-tpobop.adb | 1099 ++ gcc/ada/s-tpobop.ads | 213 + gcc/ada/s-tpopde-vms.adb | 161 + gcc/ada/s-tpopde-vms.ads | 53 + gcc/ada/s-tpopsp-lynxos.adb | 111 + gcc/ada/s-tpopsp-posix-foreign.adb | 106 + gcc/ada/s-tpopsp-posix.adb | 78 + gcc/ada/s-tpopsp-rtems.adb | 116 + gcc/ada/s-tpopsp-solaris.adb | 106 + gcc/ada/s-tpopsp-vxworks.adb | 101 + gcc/ada/s-tporft.adb | 109 + gcc/ada/s-tposen.adb | 638 + gcc/ada/s-tposen.ads | 295 + gcc/ada/s-traceb-hpux.adb | 604 + gcc/ada/s-traceb-mastop.adb | 112 + gcc/ada/s-traceb.adb | 93 + gcc/ada/s-traceb.ads | 87 + gcc/ada/s-traces-default.adb | 71 + gcc/ada/s-traces.adb | 54 + gcc/ada/s-traces.ads | 114 + gcc/ada/s-traent-vms.adb | 61 + gcc/ada/s-traent-vms.ads | 60 + gcc/ada/s-traent.adb | 54 + gcc/ada/s-traent.ads | 61 + gcc/ada/s-trafor-default.adb | 113 + gcc/ada/s-trafor-default.ads | 61 + gcc/ada/s-tratas-default.adb | 365 + gcc/ada/s-tratas.adb | 119 + gcc/ada/s-tratas.ads | 95 + gcc/ada/s-unstyp.ads | 210 + gcc/ada/s-utf_32.adb | 6341 +++++++ gcc/ada/s-utf_32.ads | 211 + gcc/ada/s-vaflop-vms-alpha.adb | 776 + gcc/ada/s-vaflop.adb | 503 + gcc/ada/s-vaflop.ads | 247 + 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 | 79 + gcc/ada/s-valenu.adb | 154 + gcc/ada/s-valenu.ads | 80 + gcc/ada/s-valint.adb | 100 + gcc/ada/s-valint.ads | 73 + gcc/ada/s-vallld.adb | 70 + gcc/ada/s-vallld.ads | 81 + gcc/ada/s-vallli.adb | 102 + gcc/ada/s-vallli.ads | 73 + gcc/ada/s-valllu.adb | 304 + gcc/ada/s-valllu.ads | 86 + gcc/ada/s-valrea.adb | 403 + gcc/ada/s-valrea.ads | 70 + gcc/ada/s-valuns.adb | 299 + gcc/ada/s-valuns.ads | 86 + gcc/ada/s-valuti.adb | 326 + gcc/ada/s-valuti.ads | 113 + gcc/ada/s-valwch.adb | 176 + 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-vmexta.adb | 187 + gcc/ada/s-vmexta.ads | 59 + gcc/ada/s-vxwext-kernel.adb | 89 + gcc/ada/s-vxwext-kernel.ads | 104 + gcc/ada/s-vxwext-rtp.adb | 124 + gcc/ada/s-vxwext-rtp.ads | 98 + gcc/ada/s-vxwext.adb | 47 + gcc/ada/s-vxwext.ads | 99 + gcc/ada/s-vxwork-arm.ads | 51 + gcc/ada/s-vxwork-m68k.ads | 74 + gcc/ada/s-vxwork-mips.ads | 55 + gcc/ada/s-vxwork-ppc.ads | 55 + gcc/ada/s-vxwork-sparcv9.ads | 60 + gcc/ada/s-vxwork-x86.ads | 54 + gcc/ada/s-wchcnv.adb | 468 + 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 | 316 + gcc/ada/s-winext.ads | 125 + 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/scans.adb | 187 + gcc/ada/scans.ads | 503 + gcc/ada/scil_ll.adb | 144 + gcc/ada/scil_ll.ads | 48 + gcc/ada/scn.adb | 494 + gcc/ada/scn.ads | 83 + gcc/ada/scng.adb | 2764 +++ gcc/ada/scng.ads | 100 + gcc/ada/scos.adb | 57 + gcc/ada/scos.ads | 472 + gcc/ada/sdefault.ads | 38 + gcc/ada/seh_init.c | 313 + gcc/ada/sem.adb | 2319 +++ gcc/ada/sem.ads | 663 + gcc/ada/sem_aggr.adb | 4112 +++++ gcc/ada/sem_aggr.ads | 36 + gcc/ada/sem_attr.adb | 8846 +++++++++ gcc/ada/sem_attr.ads | 607 + gcc/ada/sem_aux.adb | 904 + gcc/ada/sem_aux.ads | 225 + gcc/ada/sem_case.adb | 1052 ++ gcc/ada/sem_case.ads | 87 + gcc/ada/sem_cat.adb | 2252 +++ gcc/ada/sem_cat.ads | 159 + gcc/ada/sem_ch10.adb | 6163 +++++++ gcc/ada/sem_ch10.ads | 78 + gcc/ada/sem_ch11.adb | 653 + gcc/ada/sem_ch11.ads | 37 + gcc/ada/sem_ch12.adb | 12533 +++++++++++++ gcc/ada/sem_ch12.ads | 176 + gcc/ada/sem_ch13.adb | 7788 ++++++++ gcc/ada/sem_ch13.ads | 239 + gcc/ada/sem_ch2.adb | 126 + gcc/ada/sem_ch2.ads | 43 + gcc/ada/sem_ch3.adb | 19171 +++++++++++++++++++ gcc/ada/sem_ch3.ads | 299 + gcc/ada/sem_ch4.adb | 7394 ++++++++ gcc/ada/sem_ch4.ads | 66 + gcc/ada/sem_ch5.adb | 2402 +++ gcc/ada/sem_ch5.ads | 57 + gcc/ada/sem_ch6.adb | 9612 ++++++++++ gcc/ada/sem_ch6.ads | 260 + gcc/ada/sem_ch7.adb | 2583 +++ gcc/ada/sem_ch7.ads | 79 + gcc/ada/sem_ch8.adb | 7828 ++++++++ gcc/ada/sem_ch8.ads | 160 + gcc/ada/sem_ch9.adb | 2486 +++ gcc/ada/sem_ch9.ads | 55 + gcc/ada/sem_disp.adb | 2268 +++ gcc/ada/sem_disp.ads | 135 + gcc/ada/sem_dist.adb | 786 + gcc/ada/sem_dist.ads | 106 + gcc/ada/sem_elab.adb | 3190 ++++ gcc/ada/sem_elab.ads | 159 + gcc/ada/sem_elim.adb | 997 + gcc/ada/sem_elim.ads | 68 + gcc/ada/sem_eval.adb | 5453 ++++++ gcc/ada/sem_eval.ads | 438 + gcc/ada/sem_intr.adb | 488 + gcc/ada/sem_intr.ads | 46 + gcc/ada/sem_mech.adb | 493 + gcc/ada/sem_mech.ads | 178 + gcc/ada/sem_prag.adb | 14404 +++++++++++++++ gcc/ada/sem_prag.ads | 115 + gcc/ada/sem_res.adb | 10542 +++++++++++ gcc/ada/sem_res.ads | 131 + gcc/ada/sem_scil.adb | 223 + gcc/ada/sem_scil.ads | 50 + gcc/ada/sem_smem.adb | 157 + gcc/ada/sem_smem.ads | 40 + gcc/ada/sem_type.adb | 3295 ++++ gcc/ada/sem_type.ads | 260 + gcc/ada/sem_util.adb | 11921 ++++++++++++ gcc/ada/sem_util.ads | 1336 ++ gcc/ada/sem_vfpt.adb | 168 + gcc/ada/sem_vfpt.ads | 55 + gcc/ada/sem_warn.adb | 4534 +++++ gcc/ada/sem_warn.ads | 273 + gcc/ada/sequenio.ads | 24 + gcc/ada/sfn_scan.adb | 729 + gcc/ada/sfn_scan.ads | 96 + gcc/ada/sinfo-cn.adb | 110 + gcc/ada/sinfo-cn.ads | 68 + gcc/ada/sinfo.adb | 6314 +++++++ gcc/ada/sinfo.ads | 12262 +++++++++++++ gcc/ada/sinput-c.adb | 209 + gcc/ada/sinput-c.ads | 36 + gcc/ada/sinput-d.adb | 114 + gcc/ada/sinput-d.ads | 60 + gcc/ada/sinput-l.adb | 784 + gcc/ada/sinput-l.ads | 129 + gcc/ada/sinput-p.adb | 184 + gcc/ada/sinput-p.ads | 82 + gcc/ada/sinput.adb | 1266 ++ gcc/ada/sinput.ads | 827 + gcc/ada/snames.adb-tmpl | 458 + gcc/ada/snames.ads-tmpl | 1800 ++ gcc/ada/snames.h-tmpl | 66 + gcc/ada/socket.c | 690 + gcc/ada/sprint.adb | 4482 +++++ gcc/ada/sprint.ads | 161 + gcc/ada/stand.adb | 127 + gcc/ada/stand.ads | 463 + gcc/ada/stringt.adb | 449 + gcc/ada/stringt.ads | 163 + gcc/ada/stringt.h | 86 + gcc/ada/style.adb | 266 + gcc/ada/style.ads | 217 + gcc/ada/styleg.adb | 1114 ++ gcc/ada/styleg.ads | 177 + gcc/ada/stylesw.adb | 570 + gcc/ada/stylesw.ads | 332 + gcc/ada/switch-b.adb | 589 + gcc/ada/switch-b.ads | 43 + gcc/ada/switch-c.adb | 1179 ++ gcc/ada/switch-c.ads | 52 + gcc/ada/switch-m.adb | 949 + gcc/ada/switch-m.ads | 81 + gcc/ada/switch.adb | 258 + gcc/ada/switch.ads | 131 + gcc/ada/symbols-processing-vms-alpha.adb | 318 + gcc/ada/symbols-processing-vms-ia64.adb | 430 + gcc/ada/symbols-vms.adb | 637 + gcc/ada/symbols.adb | 90 + gcc/ada/symbols.ads | 116 + gcc/ada/sysdep.c | 1014 ++ gcc/ada/system-aix.ads | 155 + gcc/ada/system-aix64.ads | 155 + gcc/ada/system-darwin-ppc.ads | 171 + gcc/ada/system-darwin-ppc64.ads | 149 + gcc/ada/system-darwin-x86.ads | 171 + gcc/ada/system-darwin-x86_64.ads | 171 + gcc/ada/system-freebsd-x86.ads | 145 + gcc/ada/system-freebsd-x86_64.ads | 145 + gcc/ada/system-hpux-ia64.ads | 145 + gcc/ada/system-hpux.ads | 221 + gcc/ada/system-irix-n32.ads | 160 + gcc/ada/system-irix-n64.ads | 160 + gcc/ada/system-irix-o32.ads | 148 + gcc/ada/system-linux-alpha.ads | 143 + gcc/ada/system-linux-armeb.ads | 153 + gcc/ada/system-linux-armel.ads | 153 + gcc/ada/system-linux-hppa.ads | 145 + gcc/ada/system-linux-ia64.ads | 153 + gcc/ada/system-linux-mips.ads | 144 + gcc/ada/system-linux-mips64el.ads | 144 + gcc/ada/system-linux-mipsel.ads | 144 + gcc/ada/system-linux-ppc.ads | 153 + gcc/ada/system-linux-ppc64.ads | 153 + gcc/ada/system-linux-s390.ads | 143 + gcc/ada/system-linux-s390x.ads | 143 + gcc/ada/system-linux-sh4.ads | 153 + gcc/ada/system-linux-sparc.ads | 143 + gcc/ada/system-linux-sparcv9.ads | 143 + gcc/ada/system-linux-x86.ads | 153 + gcc/ada/system-linux-x86_64.ads | 153 + gcc/ada/system-lynxos-ppc.ads | 159 + gcc/ada/system-lynxos-x86.ads | 159 + gcc/ada/system-mingw-x86_64.ads | 197 + gcc/ada/system-mingw.ads | 197 + gcc/ada/system-rtems.ads | 164 + gcc/ada/system-solaris-sparc.ads | 145 + gcc/ada/system-solaris-sparcv9.ads | 145 + gcc/ada/system-solaris-x86.ads | 145 + gcc/ada/system-solaris-x86_64.ads | 145 + gcc/ada/system-tru64.ads | 216 + gcc/ada/system-vms-ia64.ads | 257 + gcc/ada/system-vms_64.ads | 257 + gcc/ada/system-vxworks-arm.ads | 158 + gcc/ada/system-vxworks-m68k.ads | 158 + gcc/ada/system-vxworks-mips.ads | 158 + gcc/ada/system-vxworks-ppc.ads | 158 + gcc/ada/system-vxworks-sparcv9.ads | 160 + gcc/ada/system-vxworks-x86.ads | 158 + gcc/ada/system.ads | 175 + gcc/ada/table.adb | 420 + gcc/ada/table.ads | 238 + gcc/ada/targext.c | 56 + gcc/ada/targparm.adb | 662 + gcc/ada/targparm.ads | 621 + gcc/ada/tb-alvms.c | 396 + gcc/ada/tb-alvxw.c | 941 + gcc/ada/tb-gcc.c | 126 + gcc/ada/tb-ivms.c | 89 + gcc/ada/tbuild.adb | 810 + gcc/ada/tbuild.ads | 328 + gcc/ada/tempdir.adb | 146 + gcc/ada/tempdir.ads | 47 + gcc/ada/text_io.ads | 24 + gcc/ada/tracebak.c | 529 + gcc/ada/tree_gen.adb | 77 + gcc/ada/tree_gen.ads | 28 + gcc/ada/tree_in.adb | 76 + gcc/ada/tree_in.ads | 42 + gcc/ada/tree_io.adb | 661 + gcc/ada/tree_io.ads | 114 + gcc/ada/treepr.adb | 2008 ++ gcc/ada/treepr.ads | 81 + gcc/ada/treeprs.adt | 104 + gcc/ada/ttypes.ads | 218 + gcc/ada/types.adb | 249 + gcc/ada/types.ads | 823 + gcc/ada/types.h | 383 + gcc/ada/ug_words | 230 + gcc/ada/uintp.adb | 2716 +++ gcc/ada/uintp.ads | 540 + gcc/ada/uintp.h | 96 + gcc/ada/uname.adb | 658 + gcc/ada/uname.ads | 176 + gcc/ada/unchconv.ads | 22 + gcc/ada/unchdeal.ads | 21 + gcc/ada/urealp.adb | 1635 ++ gcc/ada/urealp.ads | 368 + gcc/ada/urealp.h | 50 + gcc/ada/usage.adb | 634 + gcc/ada/usage.ads | 28 + gcc/ada/validsw.adb | 242 + gcc/ada/validsw.ads | 164 + gcc/ada/vms_cmds.ads | 52 + gcc/ada/vms_conv.adb | 2340 +++ gcc/ada/vms_conv.ads | 161 + gcc/ada/vms_data.ads | 7230 ++++++++ gcc/ada/vx_stack_info.c | 61 + gcc/ada/vxaddr2line.adb | 481 + gcc/ada/widechar.adb | 241 + gcc/ada/widechar.ads | 98 + gcc/ada/xeinfo.adb | 512 + gcc/ada/xgnatugn.adb | 1423 ++ gcc/ada/xnmake.adb | 467 + gcc/ada/xoscons.adb | 494 + gcc/ada/xr_tabls.adb | 1634 ++ gcc/ada/xr_tabls.ads | 389 + gcc/ada/xref_lib.adb | 1835 ++ gcc/ada/xref_lib.ads | 179 + gcc/ada/xsinfo.adb | 254 + gcc/ada/xsnamest.adb | 277 + gcc/ada/xtreeprs.adb | 357 + gcc/ada/xutil.adb | 77 + gcc/ada/xutil.ads | 44 + 2020 files changed, 1130078 insertions(+) create mode 100644 gcc/ada/9drpc.adb create mode 100644 gcc/ada/ChangeLog create mode 100644 gcc/ada/ChangeLog-2001 create mode 100644 gcc/ada/ChangeLog-2002 create mode 100644 gcc/ada/ChangeLog-2003 create mode 100644 gcc/ada/ChangeLog-2004 create mode 100644 gcc/ada/ChangeLog-2005 create mode 100644 gcc/ada/ChangeLog-2006 create mode 100644 gcc/ada/ChangeLog-2007 create mode 100644 gcc/ada/ChangeLog-2008 create mode 100644 gcc/ada/ChangeLog-2009 create mode 100644 gcc/ada/ChangeLog-2010 create mode 100644 gcc/ada/ChangeLog.ptr create mode 100644 gcc/ada/ChangeLog.tree-ssa create mode 100644 gcc/ada/Make-generated.in create mode 100644 gcc/ada/Makefile.in create mode 100644 gcc/ada/Makefile.rtl create mode 100755 gcc/ada/a-assert.adb create mode 100755 gcc/ada/a-assert.ads create mode 100644 gcc/ada/a-astaco.adb create mode 100644 gcc/ada/a-astaco.ads create mode 100644 gcc/ada/a-btgbso.adb create mode 100644 gcc/ada/a-btgbso.ads create mode 100644 gcc/ada/a-calari.adb create mode 100644 gcc/ada/a-calari.ads create mode 100644 gcc/ada/a-calcon.adb create mode 100644 gcc/ada/a-calcon.ads create mode 100644 gcc/ada/a-caldel-vms.adb create mode 100644 gcc/ada/a-caldel.adb create mode 100644 gcc/ada/a-caldel.ads create mode 100644 gcc/ada/a-calend-vms.adb create mode 100644 gcc/ada/a-calend-vms.ads create mode 100644 gcc/ada/a-calend.adb create mode 100644 gcc/ada/a-calend.ads create mode 100644 gcc/ada/a-calfor.adb create mode 100644 gcc/ada/a-calfor.ads create mode 100644 gcc/ada/a-catizo.adb create mode 100644 gcc/ada/a-catizo.ads create mode 100644 gcc/ada/a-cbdlli.adb create mode 100644 gcc/ada/a-cbdlli.ads create mode 100644 gcc/ada/a-cbhama.adb create mode 100644 gcc/ada/a-cbhama.ads create mode 100644 gcc/ada/a-cbhase.adb create mode 100644 gcc/ada/a-cbhase.ads create mode 100644 gcc/ada/a-cborma.adb create mode 100644 gcc/ada/a-cborma.ads create mode 100644 gcc/ada/a-cborse.adb create mode 100644 gcc/ada/a-cborse.ads create mode 100644 gcc/ada/a-cdlili.adb create mode 100644 gcc/ada/a-cdlili.ads create mode 100644 gcc/ada/a-cgaaso.adb create mode 100644 gcc/ada/a-cgaaso.ads create mode 100644 gcc/ada/a-cgarso.adb create mode 100644 gcc/ada/a-cgarso.ads create mode 100644 gcc/ada/a-cgcaso.adb create mode 100644 gcc/ada/a-cgcaso.ads create mode 100755 gcc/ada/a-chacon.adb create mode 100755 gcc/ada/a-chacon.ads create mode 100644 gcc/ada/a-chahan.adb create mode 100644 gcc/ada/a-chahan.ads create mode 100644 gcc/ada/a-charac.ads create mode 100644 gcc/ada/a-chlat1.ads create mode 100644 gcc/ada/a-chlat9.ads create mode 100644 gcc/ada/a-chtgbk.adb create mode 100644 gcc/ada/a-chtgbk.ads create mode 100644 gcc/ada/a-chtgbo.adb create mode 100644 gcc/ada/a-chtgbo.ads create mode 100644 gcc/ada/a-chtgke.adb create mode 100644 gcc/ada/a-chtgke.ads create mode 100644 gcc/ada/a-chtgop.adb create mode 100644 gcc/ada/a-chtgop.ads create mode 100644 gcc/ada/a-chzla1.ads create mode 100644 gcc/ada/a-chzla9.ads create mode 100644 gcc/ada/a-cidlli.adb create mode 100644 gcc/ada/a-cidlli.ads create mode 100644 gcc/ada/a-cihama.adb create mode 100644 gcc/ada/a-cihama.ads create mode 100644 gcc/ada/a-cihase.adb create mode 100644 gcc/ada/a-cihase.ads create mode 100644 gcc/ada/a-ciorma.adb create mode 100644 gcc/ada/a-ciorma.ads create mode 100644 gcc/ada/a-ciormu.adb create mode 100644 gcc/ada/a-ciormu.ads create mode 100644 gcc/ada/a-ciorse.adb create mode 100644 gcc/ada/a-ciorse.ads create mode 100644 gcc/ada/a-clrefi.adb create mode 100644 gcc/ada/a-clrefi.ads create mode 100644 gcc/ada/a-cobove.adb create mode 100644 gcc/ada/a-cobove.ads create mode 100644 gcc/ada/a-cohama.adb create mode 100644 gcc/ada/a-cohama.ads create mode 100644 gcc/ada/a-cohase.adb create mode 100644 gcc/ada/a-cohase.ads create mode 100644 gcc/ada/a-cohata.ads create mode 100644 gcc/ada/a-coinve.adb create mode 100644 gcc/ada/a-coinve.ads create mode 100644 gcc/ada/a-colien.adb create mode 100644 gcc/ada/a-colien.ads create mode 100644 gcc/ada/a-colire.adb create mode 100644 gcc/ada/a-colire.ads create mode 100644 gcc/ada/a-comlin.adb create mode 100644 gcc/ada/a-comlin.ads create mode 100644 gcc/ada/a-contai.ads create mode 100644 gcc/ada/a-convec.adb create mode 100644 gcc/ada/a-convec.ads create mode 100644 gcc/ada/a-coorma.adb create mode 100644 gcc/ada/a-coorma.ads create mode 100644 gcc/ada/a-coormu.adb create mode 100644 gcc/ada/a-coormu.ads create mode 100644 gcc/ada/a-coorse.adb create mode 100644 gcc/ada/a-coorse.ads create mode 100644 gcc/ada/a-coprnu.adb create mode 100644 gcc/ada/a-coprnu.ads create mode 100755 gcc/ada/a-coteio.ads create mode 100644 gcc/ada/a-crbltr.ads create mode 100644 gcc/ada/a-crbtgk.adb create mode 100644 gcc/ada/a-crbtgk.ads create mode 100644 gcc/ada/a-crbtgo.adb create mode 100644 gcc/ada/a-crbtgo.ads create mode 100644 gcc/ada/a-crdlli.adb create mode 100644 gcc/ada/a-crdlli.ads create mode 100644 gcc/ada/a-cwila1.ads create mode 100644 gcc/ada/a-cwila9.ads create mode 100644 gcc/ada/a-decima.adb create mode 100644 gcc/ada/a-decima.ads create mode 100644 gcc/ada/a-diocst.adb create mode 100644 gcc/ada/a-diocst.ads create mode 100644 gcc/ada/a-direct.adb create mode 100644 gcc/ada/a-direct.ads create mode 100644 gcc/ada/a-direio.adb create mode 100644 gcc/ada/a-direio.ads create mode 100644 gcc/ada/a-diroro.ads create mode 100644 gcc/ada/a-dirval-mingw.adb create mode 100644 gcc/ada/a-dirval-vms.adb create mode 100644 gcc/ada/a-dirval.adb create mode 100644 gcc/ada/a-dirval.ads create mode 100644 gcc/ada/a-disedf.ads create mode 100644 gcc/ada/a-dispat.ads create mode 100644 gcc/ada/a-dynpri.adb create mode 100644 gcc/ada/a-dynpri.ads create mode 100644 gcc/ada/a-einuoc.adb create mode 100644 gcc/ada/a-einuoc.ads create mode 100644 gcc/ada/a-elchha.adb create mode 100644 gcc/ada/a-elchha.ads create mode 100755 gcc/ada/a-envvar.adb create mode 100755 gcc/ada/a-envvar.ads create mode 100644 gcc/ada/a-etgrbu.ads create mode 100644 gcc/ada/a-excach.adb create mode 100644 gcc/ada/a-except-2005.adb create mode 100644 gcc/ada/a-except-2005.ads create mode 100644 gcc/ada/a-except.adb create mode 100644 gcc/ada/a-except.ads create mode 100644 gcc/ada/a-excpol-abort.adb create mode 100644 gcc/ada/a-excpol.adb create mode 100644 gcc/ada/a-exctra.adb create mode 100644 gcc/ada/a-exctra.ads create mode 100644 gcc/ada/a-exetim-default.ads create mode 100755 gcc/ada/a-exetim-mingw.adb create mode 100755 gcc/ada/a-exetim-mingw.ads create mode 100644 gcc/ada/a-exetim-posix.adb create mode 100644 gcc/ada/a-exetim.ads create mode 100644 gcc/ada/a-exexda.adb create mode 100644 gcc/ada/a-exexpr-gcc.adb create mode 100644 gcc/ada/a-exexpr.adb create mode 100644 gcc/ada/a-exextr.adb create mode 100644 gcc/ada/a-exstat.adb create mode 100644 gcc/ada/a-extiti.ads create mode 100644 gcc/ada/a-filico.adb create mode 100644 gcc/ada/a-filico.ads create mode 100644 gcc/ada/a-finali.adb create mode 100644 gcc/ada/a-finali.ads create mode 100644 gcc/ada/a-flteio.ads create mode 100644 gcc/ada/a-fwteio.ads create mode 100755 gcc/ada/a-fzteio.ads create mode 100644 gcc/ada/a-inteio.ads create mode 100644 gcc/ada/a-interr.adb create mode 100644 gcc/ada/a-interr.ads create mode 100644 gcc/ada/a-intnam-aix.ads create mode 100644 gcc/ada/a-intnam-darwin.ads create mode 100644 gcc/ada/a-intnam-dummy.ads create mode 100644 gcc/ada/a-intnam-freebsd.ads create mode 100644 gcc/ada/a-intnam-hpux.ads create mode 100644 gcc/ada/a-intnam-irix.ads create mode 100644 gcc/ada/a-intnam-linux.ads create mode 100644 gcc/ada/a-intnam-lynxos.ads create mode 100644 gcc/ada/a-intnam-mingw.ads create mode 100644 gcc/ada/a-intnam-rtems.ads create mode 100644 gcc/ada/a-intnam-solaris.ads create mode 100644 gcc/ada/a-intnam-tru64.ads create mode 100644 gcc/ada/a-intnam-vms.ads create mode 100644 gcc/ada/a-intnam-vxworks.ads create mode 100644 gcc/ada/a-intnam.ads create mode 100644 gcc/ada/a-intsig.adb create mode 100644 gcc/ada/a-intsig.ads create mode 100644 gcc/ada/a-ioexce.ads create mode 100644 gcc/ada/a-iwteio.ads create mode 100755 gcc/ada/a-izteio.ads create mode 100755 gcc/ada/a-lcteio.ads create mode 100644 gcc/ada/a-lfteio.ads create mode 100644 gcc/ada/a-lfwtio.ads create mode 100644 gcc/ada/a-lfztio.ads create mode 100644 gcc/ada/a-liteio.ads create mode 100644 gcc/ada/a-liwtio.ads create mode 100644 gcc/ada/a-liztio.ads create mode 100755 gcc/ada/a-llctio.ads create mode 100644 gcc/ada/a-llftio.ads create mode 100644 gcc/ada/a-llfwti.ads create mode 100644 gcc/ada/a-llfzti.ads create mode 100644 gcc/ada/a-llitio.ads create mode 100644 gcc/ada/a-lliwti.ads create mode 100644 gcc/ada/a-llizti.ads create mode 100644 gcc/ada/a-locale.adb create mode 100644 gcc/ada/a-locale.ads create mode 100644 gcc/ada/a-ncelfu.ads create mode 100644 gcc/ada/a-ngcefu.adb create mode 100644 gcc/ada/a-ngcefu.ads create mode 100644 gcc/ada/a-ngcoar.adb create mode 100644 gcc/ada/a-ngcoar.ads create mode 100644 gcc/ada/a-ngcoty.adb create mode 100644 gcc/ada/a-ngcoty.ads create mode 100644 gcc/ada/a-ngelfu.adb create mode 100644 gcc/ada/a-ngelfu.ads create mode 100644 gcc/ada/a-ngrear.adb create mode 100644 gcc/ada/a-ngrear.ads create mode 100644 gcc/ada/a-nlcefu.ads create mode 100644 gcc/ada/a-nlcoar.ads create mode 100644 gcc/ada/a-nlcoty.ads create mode 100644 gcc/ada/a-nlelfu.ads create mode 100644 gcc/ada/a-nllcar.ads create mode 100644 gcc/ada/a-nllcef.ads create mode 100644 gcc/ada/a-nllcty.ads create mode 100644 gcc/ada/a-nllefu.ads create mode 100644 gcc/ada/a-nllrar.ads create mode 100644 gcc/ada/a-nlrear.ads create mode 100644 gcc/ada/a-nscefu.ads create mode 100644 gcc/ada/a-nscoty.ads create mode 100644 gcc/ada/a-nselfu.ads create mode 100644 gcc/ada/a-nucoar.ads create mode 100644 gcc/ada/a-nucoty.ads create mode 100644 gcc/ada/a-nudira.adb create mode 100644 gcc/ada/a-nudira.ads create mode 100644 gcc/ada/a-nuelfu.ads create mode 100644 gcc/ada/a-nuflra.adb create mode 100644 gcc/ada/a-nuflra.ads create mode 100644 gcc/ada/a-numaux-darwin.adb create mode 100644 gcc/ada/a-numaux-darwin.ads create mode 100644 gcc/ada/a-numaux-libc-x86.ads create mode 100644 gcc/ada/a-numaux-vxworks.ads create mode 100644 gcc/ada/a-numaux-x86.adb create mode 100644 gcc/ada/a-numaux-x86.ads create mode 100644 gcc/ada/a-numaux.ads create mode 100644 gcc/ada/a-numeri.ads create mode 100644 gcc/ada/a-nurear.ads create mode 100644 gcc/ada/a-rbtgbk.adb create mode 100644 gcc/ada/a-rbtgbk.ads create mode 100644 gcc/ada/a-rbtgbo.adb create mode 100644 gcc/ada/a-rbtgbo.ads create mode 100644 gcc/ada/a-rbtgso.adb create mode 100644 gcc/ada/a-rbtgso.ads create mode 100644 gcc/ada/a-reatim.adb create mode 100644 gcc/ada/a-reatim.ads create mode 100644 gcc/ada/a-retide.adb create mode 100644 gcc/ada/a-retide.ads create mode 100644 gcc/ada/a-rttiev.adb create mode 100644 gcc/ada/a-rttiev.ads create mode 100755 gcc/ada/a-scteio.ads create mode 100644 gcc/ada/a-secain.adb create mode 100644 gcc/ada/a-secain.ads create mode 100644 gcc/ada/a-sequio.adb create mode 100644 gcc/ada/a-sequio.ads create mode 100644 gcc/ada/a-sfteio.ads create mode 100644 gcc/ada/a-sfwtio.ads create mode 100644 gcc/ada/a-sfztio.ads create mode 100644 gcc/ada/a-shcain.adb create mode 100644 gcc/ada/a-shcain.ads create mode 100644 gcc/ada/a-siocst.adb create mode 100644 gcc/ada/a-siocst.ads create mode 100644 gcc/ada/a-siteio.ads create mode 100644 gcc/ada/a-siwtio.ads create mode 100644 gcc/ada/a-siztio.ads create mode 100644 gcc/ada/a-slcain.adb create mode 100644 gcc/ada/a-slcain.ads create mode 100644 gcc/ada/a-ssicst.adb create mode 100644 gcc/ada/a-ssicst.ads create mode 100644 gcc/ada/a-ssitio.ads create mode 100644 gcc/ada/a-ssiwti.ads create mode 100644 gcc/ada/a-ssizti.ads create mode 100644 gcc/ada/a-stboha.adb create mode 100644 gcc/ada/a-stboha.ads create mode 100644 gcc/ada/a-stfiha.ads create mode 100644 gcc/ada/a-stmaco.ads create mode 100644 gcc/ada/a-storio.adb create mode 100644 gcc/ada/a-storio.ads create mode 100644 gcc/ada/a-strbou.adb create mode 100644 gcc/ada/a-strbou.ads create mode 100644 gcc/ada/a-stream.ads create mode 100644 gcc/ada/a-strfix.adb create mode 100644 gcc/ada/a-strfix.ads create mode 100644 gcc/ada/a-strhas.adb create mode 100644 gcc/ada/a-strhas.ads create mode 100644 gcc/ada/a-string.ads create mode 100644 gcc/ada/a-strmap.adb create mode 100644 gcc/ada/a-strmap.ads create mode 100644 gcc/ada/a-strsea.adb create mode 100644 gcc/ada/a-strsea.ads create mode 100644 gcc/ada/a-strsup.adb create mode 100644 gcc/ada/a-strsup.ads create mode 100644 gcc/ada/a-strunb-shared.adb create mode 100644 gcc/ada/a-strunb-shared.ads create mode 100644 gcc/ada/a-strunb.adb create mode 100644 gcc/ada/a-strunb.ads create mode 100644 gcc/ada/a-ststio.adb create mode 100644 gcc/ada/a-ststio.ads create mode 100644 gcc/ada/a-stunau-shared.adb create mode 100644 gcc/ada/a-stunau.adb create mode 100644 gcc/ada/a-stunau.ads create mode 100644 gcc/ada/a-stunha.adb create mode 100644 gcc/ada/a-stunha.ads create mode 100644 gcc/ada/a-stuten.adb create mode 100644 gcc/ada/a-stuten.ads create mode 100644 gcc/ada/a-stwibo.adb create mode 100644 gcc/ada/a-stwibo.ads create mode 100644 gcc/ada/a-stwifi.adb create mode 100644 gcc/ada/a-stwifi.ads create mode 100644 gcc/ada/a-stwiha.adb create mode 100644 gcc/ada/a-stwiha.ads create mode 100644 gcc/ada/a-stwima.adb create mode 100644 gcc/ada/a-stwima.ads create mode 100644 gcc/ada/a-stwise.adb create mode 100644 gcc/ada/a-stwise.ads create mode 100644 gcc/ada/a-stwisu.adb create mode 100644 gcc/ada/a-stwisu.ads create mode 100644 gcc/ada/a-stwiun-shared.adb create mode 100644 gcc/ada/a-stwiun-shared.ads create mode 100644 gcc/ada/a-stwiun.adb create mode 100644 gcc/ada/a-stwiun.ads create mode 100644 gcc/ada/a-stzbou.adb create mode 100644 gcc/ada/a-stzbou.ads create mode 100644 gcc/ada/a-stzfix.adb create mode 100644 gcc/ada/a-stzfix.ads create mode 100644 gcc/ada/a-stzhas.adb create mode 100644 gcc/ada/a-stzhas.ads create mode 100644 gcc/ada/a-stzmap.adb create mode 100644 gcc/ada/a-stzmap.ads create mode 100644 gcc/ada/a-stzsea.adb create mode 100644 gcc/ada/a-stzsea.ads create mode 100644 gcc/ada/a-stzsup.adb create mode 100644 gcc/ada/a-stzsup.ads create mode 100644 gcc/ada/a-stzunb-shared.adb create mode 100644 gcc/ada/a-stzunb-shared.ads create mode 100644 gcc/ada/a-stzunb.adb create mode 100644 gcc/ada/a-stzunb.ads create mode 100755 gcc/ada/a-suenco.adb create mode 100755 gcc/ada/a-suenco.ads create mode 100755 gcc/ada/a-suenst.adb create mode 100755 gcc/ada/a-suenst.ads create mode 100755 gcc/ada/a-suewst.adb create mode 100755 gcc/ada/a-suewst.ads create mode 100755 gcc/ada/a-suezst.adb create mode 100755 gcc/ada/a-suezst.ads create mode 100644 gcc/ada/a-suteio-shared.adb create mode 100644 gcc/ada/a-suteio.adb create mode 100644 gcc/ada/a-suteio.ads create mode 100644 gcc/ada/a-swbwha.adb create mode 100644 gcc/ada/a-swbwha.ads create mode 100644 gcc/ada/a-swfwha.ads create mode 100644 gcc/ada/a-swmwco.ads create mode 100644 gcc/ada/a-swunau-shared.adb create mode 100644 gcc/ada/a-swunau.adb create mode 100644 gcc/ada/a-swunau.ads create mode 100644 gcc/ada/a-swuwha.adb create mode 100644 gcc/ada/a-swuwha.ads create mode 100644 gcc/ada/a-swuwti-shared.adb create mode 100644 gcc/ada/a-swuwti.adb create mode 100644 gcc/ada/a-swuwti.ads create mode 100644 gcc/ada/a-sytaco.adb create mode 100644 gcc/ada/a-sytaco.ads create mode 100644 gcc/ada/a-szbzha.adb create mode 100644 gcc/ada/a-szbzha.ads create mode 100644 gcc/ada/a-szfzha.ads create mode 100644 gcc/ada/a-szmzco.ads create mode 100644 gcc/ada/a-szunau-shared.adb create mode 100644 gcc/ada/a-szunau.adb create mode 100644 gcc/ada/a-szunau.ads create mode 100644 gcc/ada/a-szuzha.adb create mode 100644 gcc/ada/a-szuzha.ads create mode 100644 gcc/ada/a-szuzti-shared.adb create mode 100644 gcc/ada/a-szuzti.adb create mode 100644 gcc/ada/a-szuzti.ads create mode 100644 gcc/ada/a-tags.adb create mode 100644 gcc/ada/a-tags.ads create mode 100644 gcc/ada/a-tasatt.adb create mode 100644 gcc/ada/a-tasatt.ads create mode 100644 gcc/ada/a-taside.adb create mode 100644 gcc/ada/a-taside.ads create mode 100644 gcc/ada/a-taster.adb create mode 100644 gcc/ada/a-taster.ads create mode 100644 gcc/ada/a-teioed.adb create mode 100644 gcc/ada/a-teioed.ads create mode 100644 gcc/ada/a-textio.adb create mode 100644 gcc/ada/a-textio.ads create mode 100644 gcc/ada/a-tgdico.ads create mode 100644 gcc/ada/a-tiboio.adb create mode 100644 gcc/ada/a-tiboio.ads create mode 100644 gcc/ada/a-ticoau.adb create mode 100644 gcc/ada/a-ticoau.ads create mode 100644 gcc/ada/a-ticoio.adb create mode 100644 gcc/ada/a-ticoio.ads create mode 100644 gcc/ada/a-tideau.adb create mode 100644 gcc/ada/a-tideau.ads create mode 100644 gcc/ada/a-tideio.adb create mode 100644 gcc/ada/a-tideio.ads create mode 100644 gcc/ada/a-tienau.adb create mode 100644 gcc/ada/a-tienau.ads create mode 100644 gcc/ada/a-tienio.adb create mode 100644 gcc/ada/a-tienio.ads create mode 100644 gcc/ada/a-tifiio.adb create mode 100644 gcc/ada/a-tifiio.ads create mode 100644 gcc/ada/a-tiflau.adb create mode 100644 gcc/ada/a-tiflau.ads create mode 100644 gcc/ada/a-tiflio.adb create mode 100644 gcc/ada/a-tiflio.ads create mode 100644 gcc/ada/a-tigeau.adb create mode 100644 gcc/ada/a-tigeau.ads create mode 100644 gcc/ada/a-tigeli.adb create mode 100644 gcc/ada/a-tiinau.adb create mode 100644 gcc/ada/a-tiinau.ads create mode 100644 gcc/ada/a-tiinio.adb create mode 100644 gcc/ada/a-tiinio.ads create mode 100644 gcc/ada/a-timoau.adb create mode 100644 gcc/ada/a-timoau.ads create mode 100644 gcc/ada/a-timoio.adb create mode 100644 gcc/ada/a-timoio.ads create mode 100644 gcc/ada/a-tiocst.adb create mode 100644 gcc/ada/a-tiocst.ads create mode 100755 gcc/ada/a-tirsfi.adb create mode 100755 gcc/ada/a-tirsfi.ads create mode 100644 gcc/ada/a-titest.adb create mode 100644 gcc/ada/a-titest.ads create mode 100644 gcc/ada/a-tiunio.ads create mode 100644 gcc/ada/a-unccon.ads create mode 100644 gcc/ada/a-uncdea.ads create mode 100755 gcc/ada/a-wichha.adb create mode 100755 gcc/ada/a-wichha.ads create mode 100644 gcc/ada/a-wichun.adb create mode 100644 gcc/ada/a-wichun.ads create mode 100644 gcc/ada/a-widcha.ads create mode 100644 gcc/ada/a-witeio.adb create mode 100644 gcc/ada/a-witeio.ads create mode 100644 gcc/ada/a-wrstfi.adb create mode 100644 gcc/ada/a-wrstfi.ads create mode 100644 gcc/ada/a-wtcoau.adb create mode 100644 gcc/ada/a-wtcoau.ads create mode 100644 gcc/ada/a-wtcoio.adb create mode 100644 gcc/ada/a-wtcoio.ads create mode 100644 gcc/ada/a-wtcstr.adb create mode 100644 gcc/ada/a-wtcstr.ads create mode 100644 gcc/ada/a-wtdeau.adb create mode 100644 gcc/ada/a-wtdeau.ads create mode 100644 gcc/ada/a-wtdeio.adb create mode 100644 gcc/ada/a-wtdeio.ads create mode 100644 gcc/ada/a-wtedit.adb create mode 100644 gcc/ada/a-wtedit.ads create mode 100644 gcc/ada/a-wtenau.adb create mode 100644 gcc/ada/a-wtenau.ads create mode 100644 gcc/ada/a-wtenio.adb create mode 100644 gcc/ada/a-wtenio.ads create mode 100644 gcc/ada/a-wtfiio.adb create mode 100644 gcc/ada/a-wtfiio.ads create mode 100644 gcc/ada/a-wtflau.adb create mode 100644 gcc/ada/a-wtflau.ads create mode 100644 gcc/ada/a-wtflio.adb create mode 100644 gcc/ada/a-wtflio.ads create mode 100644 gcc/ada/a-wtgeau.adb create mode 100644 gcc/ada/a-wtgeau.ads create mode 100644 gcc/ada/a-wtinau.adb create mode 100644 gcc/ada/a-wtinau.ads create mode 100644 gcc/ada/a-wtinio.adb create mode 100644 gcc/ada/a-wtinio.ads create mode 100644 gcc/ada/a-wtmoau.adb create mode 100644 gcc/ada/a-wtmoau.ads create mode 100644 gcc/ada/a-wtmoio.adb create mode 100644 gcc/ada/a-wtmoio.ads create mode 100644 gcc/ada/a-wttest.adb create mode 100644 gcc/ada/a-wttest.ads create mode 100644 gcc/ada/a-wwboio.adb create mode 100644 gcc/ada/a-wwboio.ads create mode 100644 gcc/ada/a-wwunio.ads create mode 100755 gcc/ada/a-zchara.ads create mode 100755 gcc/ada/a-zchhan.adb create mode 100755 gcc/ada/a-zchhan.ads create mode 100755 gcc/ada/a-zchuni.adb create mode 100755 gcc/ada/a-zchuni.ads create mode 100755 gcc/ada/a-zrstfi.adb create mode 100755 gcc/ada/a-zrstfi.ads create mode 100644 gcc/ada/a-ztcoau.adb create mode 100644 gcc/ada/a-ztcoau.ads create mode 100644 gcc/ada/a-ztcoio.adb create mode 100644 gcc/ada/a-ztcoio.ads create mode 100644 gcc/ada/a-ztcstr.adb create mode 100644 gcc/ada/a-ztcstr.ads create mode 100644 gcc/ada/a-ztdeau.adb create mode 100644 gcc/ada/a-ztdeau.ads create mode 100644 gcc/ada/a-ztdeio.adb create mode 100644 gcc/ada/a-ztdeio.ads create mode 100644 gcc/ada/a-ztedit.adb create mode 100644 gcc/ada/a-ztedit.ads create mode 100644 gcc/ada/a-ztenau.adb create mode 100644 gcc/ada/a-ztenau.ads create mode 100644 gcc/ada/a-ztenio.adb create mode 100644 gcc/ada/a-ztenio.ads create mode 100644 gcc/ada/a-ztexio.adb create mode 100644 gcc/ada/a-ztexio.ads create mode 100644 gcc/ada/a-ztfiio.adb create mode 100644 gcc/ada/a-ztfiio.ads create mode 100644 gcc/ada/a-ztflau.adb create mode 100644 gcc/ada/a-ztflau.ads create mode 100644 gcc/ada/a-ztflio.adb create mode 100644 gcc/ada/a-ztflio.ads create mode 100644 gcc/ada/a-ztgeau.adb create mode 100644 gcc/ada/a-ztgeau.ads create mode 100644 gcc/ada/a-ztinau.adb create mode 100644 gcc/ada/a-ztinau.ads create mode 100644 gcc/ada/a-ztinio.adb create mode 100644 gcc/ada/a-ztinio.ads create mode 100644 gcc/ada/a-ztmoau.adb create mode 100644 gcc/ada/a-ztmoau.ads create mode 100644 gcc/ada/a-ztmoio.adb create mode 100644 gcc/ada/a-ztmoio.ads create mode 100644 gcc/ada/a-zttest.adb create mode 100644 gcc/ada/a-zttest.ads create mode 100644 gcc/ada/a-zzboio.adb create mode 100644 gcc/ada/a-zzboio.ads create mode 100644 gcc/ada/a-zzunio.ads create mode 100644 gcc/ada/ada.ads create mode 100644 gcc/ada/adadecode.c create mode 100644 gcc/ada/adadecode.h create mode 100644 gcc/ada/adaint.c create mode 100644 gcc/ada/adaint.h create mode 100644 gcc/ada/ali-util.adb create mode 100644 gcc/ada/ali-util.ads create mode 100644 gcc/ada/ali.adb create mode 100644 gcc/ada/ali.ads create mode 100644 gcc/ada/alloc.ads create mode 100644 gcc/ada/argv.c create mode 100644 gcc/ada/arit64.c create mode 100755 gcc/ada/aspects.adb create mode 100755 gcc/ada/aspects.ads create mode 100644 gcc/ada/atree.adb create mode 100644 gcc/ada/atree.ads create mode 100644 gcc/ada/atree.h create mode 100644 gcc/ada/aux-io.c create mode 100644 gcc/ada/back_end.adb create mode 100644 gcc/ada/back_end.ads create mode 100644 gcc/ada/bcheck.adb create mode 100644 gcc/ada/bcheck.ads create mode 100644 gcc/ada/binde.adb create mode 100644 gcc/ada/binde.ads create mode 100644 gcc/ada/binderr.adb create mode 100644 gcc/ada/binderr.ads create mode 100644 gcc/ada/bindgen.adb create mode 100644 gcc/ada/bindgen.ads create mode 100644 gcc/ada/bindusg.adb create mode 100644 gcc/ada/bindusg.ads create mode 100644 gcc/ada/butil.adb create mode 100644 gcc/ada/butil.ads create mode 100644 gcc/ada/cal.c create mode 100644 gcc/ada/calendar.ads create mode 100644 gcc/ada/casing.adb create mode 100644 gcc/ada/casing.ads create mode 100644 gcc/ada/ceinfo.adb create mode 100644 gcc/ada/checks.adb create mode 100644 gcc/ada/checks.ads create mode 100644 gcc/ada/cio.c create mode 100644 gcc/ada/clean.adb create mode 100644 gcc/ada/clean.ads create mode 100644 gcc/ada/comperr.adb create mode 100644 gcc/ada/comperr.ads create mode 100644 gcc/ada/config-lang.in create mode 100644 gcc/ada/csets.adb create mode 100644 gcc/ada/csets.ads create mode 100644 gcc/ada/csinfo.adb create mode 100644 gcc/ada/cstand.adb create mode 100644 gcc/ada/cstand.ads create mode 100644 gcc/ada/cstreams.c create mode 100644 gcc/ada/ctrl_c.c create mode 100644 gcc/ada/debug.adb create mode 100644 gcc/ada/debug.ads create mode 100644 gcc/ada/debug_a.adb create mode 100644 gcc/ada/debug_a.ads create mode 100644 gcc/ada/dec.ads create mode 100644 gcc/ada/directio.ads create mode 100644 gcc/ada/einfo.adb create mode 100644 gcc/ada/einfo.ads create mode 100644 gcc/ada/elists.adb create mode 100644 gcc/ada/elists.ads create mode 100644 gcc/ada/elists.h create mode 100644 gcc/ada/env.c create mode 100644 gcc/ada/env.h create mode 100644 gcc/ada/err_vars.ads create mode 100644 gcc/ada/errno.c create mode 100644 gcc/ada/errout.adb create mode 100644 gcc/ada/errout.ads create mode 100644 gcc/ada/erroutc.adb create mode 100644 gcc/ada/erroutc.ads create mode 100644 gcc/ada/errutil.adb create mode 100644 gcc/ada/errutil.ads create mode 100644 gcc/ada/eval_fat.adb create mode 100644 gcc/ada/eval_fat.ads create mode 100644 gcc/ada/exit.c create mode 100644 gcc/ada/exp_aggr.adb create mode 100644 gcc/ada/exp_aggr.ads create mode 100644 gcc/ada/exp_atag.adb create mode 100644 gcc/ada/exp_atag.ads create mode 100644 gcc/ada/exp_attr.adb create mode 100644 gcc/ada/exp_attr.ads create mode 100644 gcc/ada/exp_cg.adb create mode 100644 gcc/ada/exp_cg.ads create mode 100644 gcc/ada/exp_ch10.ads create mode 100644 gcc/ada/exp_ch11.adb create mode 100644 gcc/ada/exp_ch11.ads create mode 100644 gcc/ada/exp_ch12.adb create mode 100644 gcc/ada/exp_ch12.ads create mode 100644 gcc/ada/exp_ch13.adb create mode 100644 gcc/ada/exp_ch13.ads create mode 100644 gcc/ada/exp_ch2.adb create mode 100644 gcc/ada/exp_ch2.ads create mode 100644 gcc/ada/exp_ch3.adb create mode 100644 gcc/ada/exp_ch3.ads create mode 100644 gcc/ada/exp_ch4.adb create mode 100644 gcc/ada/exp_ch4.ads create mode 100644 gcc/ada/exp_ch5.adb create mode 100644 gcc/ada/exp_ch5.ads create mode 100644 gcc/ada/exp_ch6.adb create mode 100644 gcc/ada/exp_ch6.ads create mode 100644 gcc/ada/exp_ch7.adb create mode 100644 gcc/ada/exp_ch7.ads create mode 100644 gcc/ada/exp_ch8.adb create mode 100644 gcc/ada/exp_ch8.ads create mode 100644 gcc/ada/exp_ch9.adb create mode 100644 gcc/ada/exp_ch9.ads create mode 100644 gcc/ada/exp_code.adb create mode 100644 gcc/ada/exp_code.ads create mode 100644 gcc/ada/exp_dbug.adb create mode 100644 gcc/ada/exp_dbug.ads create mode 100644 gcc/ada/exp_disp.adb create mode 100644 gcc/ada/exp_disp.ads create mode 100644 gcc/ada/exp_dist.adb create mode 100644 gcc/ada/exp_dist.ads create mode 100644 gcc/ada/exp_fixd.adb create mode 100644 gcc/ada/exp_fixd.ads create mode 100644 gcc/ada/exp_imgv.adb create mode 100644 gcc/ada/exp_imgv.ads create mode 100644 gcc/ada/exp_intr.adb create mode 100644 gcc/ada/exp_intr.ads create mode 100644 gcc/ada/exp_pakd.adb create mode 100644 gcc/ada/exp_pakd.ads create mode 100644 gcc/ada/exp_prag.adb create mode 100644 gcc/ada/exp_prag.ads create mode 100644 gcc/ada/exp_sel.adb create mode 100644 gcc/ada/exp_sel.ads create mode 100644 gcc/ada/exp_smem.adb create mode 100644 gcc/ada/exp_smem.ads create mode 100644 gcc/ada/exp_strm.adb create mode 100644 gcc/ada/exp_strm.ads create mode 100644 gcc/ada/exp_tss.adb create mode 100644 gcc/ada/exp_tss.ads create mode 100644 gcc/ada/exp_util.adb create mode 100644 gcc/ada/exp_util.ads create mode 100644 gcc/ada/exp_vfpt.adb create mode 100644 gcc/ada/exp_vfpt.ads create mode 100644 gcc/ada/expander.adb create mode 100644 gcc/ada/expander.ads create mode 100644 gcc/ada/expect.c create mode 100644 gcc/ada/fe.h create mode 100644 gcc/ada/final.c create mode 100644 gcc/ada/fmap.adb create mode 100644 gcc/ada/fmap.ads create mode 100644 gcc/ada/fname-sf.adb create mode 100644 gcc/ada/fname-sf.ads create mode 100644 gcc/ada/fname-uf.adb create mode 100644 gcc/ada/fname-uf.ads create mode 100644 gcc/ada/fname.adb create mode 100644 gcc/ada/fname.ads create mode 100644 gcc/ada/freeze.adb create mode 100644 gcc/ada/freeze.ads create mode 100644 gcc/ada/frontend.adb create mode 100644 gcc/ada/frontend.ads create mode 100644 gcc/ada/g-allein.ads create mode 100644 gcc/ada/g-alleve.adb create mode 100644 gcc/ada/g-alleve.ads create mode 100644 gcc/ada/g-altcon.adb create mode 100644 gcc/ada/g-altcon.ads create mode 100644 gcc/ada/g-altive.ads create mode 100644 gcc/ada/g-alveop.adb create mode 100644 gcc/ada/g-alveop.ads create mode 100644 gcc/ada/g-alvety.ads create mode 100644 gcc/ada/g-alvevi.ads create mode 100644 gcc/ada/g-arrspl.adb create mode 100644 gcc/ada/g-arrspl.ads create mode 100644 gcc/ada/g-awk.adb create mode 100644 gcc/ada/g-awk.ads create mode 100644 gcc/ada/g-boubuf.adb create mode 100644 gcc/ada/g-boubuf.ads create mode 100644 gcc/ada/g-boumai.ads create mode 100644 gcc/ada/g-bubsor.adb create mode 100644 gcc/ada/g-bubsor.ads create mode 100644 gcc/ada/g-busora.adb create mode 100644 gcc/ada/g-busora.ads create mode 100644 gcc/ada/g-busorg.adb create mode 100644 gcc/ada/g-busorg.ads create mode 100755 gcc/ada/g-byorma.adb create mode 100755 gcc/ada/g-byorma.ads create mode 100644 gcc/ada/g-bytswa-x86.adb create mode 100644 gcc/ada/g-bytswa.adb create mode 100644 gcc/ada/g-bytswa.ads create mode 100644 gcc/ada/g-calend.adb create mode 100644 gcc/ada/g-calend.ads create mode 100644 gcc/ada/g-casuti.adb create mode 100644 gcc/ada/g-casuti.ads create mode 100644 gcc/ada/g-catiio.adb create mode 100644 gcc/ada/g-catiio.ads create mode 100644 gcc/ada/g-cgi.adb create mode 100644 gcc/ada/g-cgi.ads create mode 100644 gcc/ada/g-cgicoo.adb create mode 100644 gcc/ada/g-cgicoo.ads create mode 100644 gcc/ada/g-cgideb.adb create mode 100644 gcc/ada/g-cgideb.ads create mode 100644 gcc/ada/g-comlin.adb create mode 100644 gcc/ada/g-comlin.ads create mode 100644 gcc/ada/g-comver.adb create mode 100644 gcc/ada/g-comver.ads create mode 100644 gcc/ada/g-crc32.adb create mode 100644 gcc/ada/g-crc32.ads create mode 100644 gcc/ada/g-ctrl_c.adb create mode 100644 gcc/ada/g-ctrl_c.ads create mode 100644 gcc/ada/g-curexc.ads create mode 100644 gcc/ada/g-debpoo.adb create mode 100644 gcc/ada/g-debpoo.ads create mode 100644 gcc/ada/g-debuti.adb create mode 100644 gcc/ada/g-debuti.ads create mode 100755 gcc/ada/g-decstr.adb create mode 100755 gcc/ada/g-decstr.ads create mode 100644 gcc/ada/g-deutst.ads create mode 100644 gcc/ada/g-diopit.adb create mode 100644 gcc/ada/g-diopit.ads create mode 100644 gcc/ada/g-dirope.adb create mode 100644 gcc/ada/g-dirope.ads create mode 100644 gcc/ada/g-dynhta.adb create mode 100644 gcc/ada/g-dynhta.ads create mode 100644 gcc/ada/g-dyntab.adb create mode 100644 gcc/ada/g-dyntab.ads create mode 100644 gcc/ada/g-eacodu-vms.adb create mode 100644 gcc/ada/g-eacodu.adb create mode 100644 gcc/ada/g-enblsp-vms-alpha.adb create mode 100644 gcc/ada/g-enblsp-vms-ia64.adb create mode 100755 gcc/ada/g-encstr.adb create mode 100755 gcc/ada/g-encstr.ads create mode 100644 gcc/ada/g-enutst.ads create mode 100644 gcc/ada/g-excact.adb create mode 100644 gcc/ada/g-excact.ads create mode 100644 gcc/ada/g-except.ads create mode 100644 gcc/ada/g-exctra.adb create mode 100644 gcc/ada/g-exctra.ads create mode 100644 gcc/ada/g-expect-vms.adb create mode 100644 gcc/ada/g-expect.adb create mode 100644 gcc/ada/g-expect.ads create mode 100644 gcc/ada/g-flocon.ads create mode 100644 gcc/ada/g-heasor.adb create mode 100644 gcc/ada/g-heasor.ads create mode 100644 gcc/ada/g-hesora.adb create mode 100644 gcc/ada/g-hesora.ads create mode 100644 gcc/ada/g-hesorg.adb create mode 100644 gcc/ada/g-hesorg.ads create mode 100644 gcc/ada/g-htable.adb create mode 100644 gcc/ada/g-htable.ads create mode 100644 gcc/ada/g-io-put-vxworks.adb create mode 100644 gcc/ada/g-io-put.adb create mode 100644 gcc/ada/g-io.adb create mode 100644 gcc/ada/g-io.ads create mode 100644 gcc/ada/g-io_aux.adb create mode 100644 gcc/ada/g-io_aux.ads create mode 100644 gcc/ada/g-locfil.adb create mode 100644 gcc/ada/g-locfil.ads create mode 100644 gcc/ada/g-mbdira.adb create mode 100644 gcc/ada/g-mbdira.ads create mode 100644 gcc/ada/g-mbflra.adb create mode 100644 gcc/ada/g-mbflra.ads create mode 100644 gcc/ada/g-md5.adb create mode 100644 gcc/ada/g-md5.ads create mode 100644 gcc/ada/g-memdum.adb create mode 100644 gcc/ada/g-memdum.ads create mode 100644 gcc/ada/g-moreex.adb create mode 100644 gcc/ada/g-moreex.ads create mode 100644 gcc/ada/g-os_lib.adb create mode 100644 gcc/ada/g-os_lib.ads create mode 100644 gcc/ada/g-pehage.adb create mode 100644 gcc/ada/g-pehage.ads create mode 100644 gcc/ada/g-rannum.adb create mode 100644 gcc/ada/g-rannum.ads create mode 100644 gcc/ada/g-regexp.adb create mode 100644 gcc/ada/g-regexp.ads create mode 100644 gcc/ada/g-regist.adb create mode 100644 gcc/ada/g-regist.ads create mode 100644 gcc/ada/g-regpat.adb create mode 100644 gcc/ada/g-regpat.ads create mode 100644 gcc/ada/g-sechas.adb create mode 100644 gcc/ada/g-sechas.ads create mode 100644 gcc/ada/g-sehamd.adb create mode 100644 gcc/ada/g-sehamd.ads create mode 100644 gcc/ada/g-sehash.adb create mode 100644 gcc/ada/g-sehash.ads create mode 100644 gcc/ada/g-semaph.adb create mode 100644 gcc/ada/g-semaph.ads create mode 100644 gcc/ada/g-sercom-linux.adb create mode 100644 gcc/ada/g-sercom-mingw.adb create mode 100644 gcc/ada/g-sercom.adb create mode 100644 gcc/ada/g-sercom.ads create mode 100644 gcc/ada/g-sestin.ads create mode 100644 gcc/ada/g-sha1.adb create mode 100644 gcc/ada/g-sha1.ads create mode 100644 gcc/ada/g-sha224.ads create mode 100644 gcc/ada/g-sha256.ads create mode 100644 gcc/ada/g-sha384.ads create mode 100644 gcc/ada/g-sha512.ads create mode 100644 gcc/ada/g-shsh32.adb create mode 100644 gcc/ada/g-shsh32.ads create mode 100644 gcc/ada/g-shsh64.adb create mode 100644 gcc/ada/g-shsh64.ads create mode 100644 gcc/ada/g-shshco.adb create mode 100644 gcc/ada/g-shshco.ads create mode 100644 gcc/ada/g-signal.adb create mode 100644 gcc/ada/g-signal.ads create mode 100644 gcc/ada/g-soccon.ads create mode 100644 gcc/ada/g-socket-dummy.adb create mode 100644 gcc/ada/g-socket-dummy.ads create mode 100644 gcc/ada/g-socket.adb create mode 100644 gcc/ada/g-socket.ads create mode 100644 gcc/ada/g-socthi-dummy.adb create mode 100644 gcc/ada/g-socthi-dummy.ads create mode 100644 gcc/ada/g-socthi-mingw.adb create mode 100644 gcc/ada/g-socthi-mingw.ads create mode 100644 gcc/ada/g-socthi-vms.adb create mode 100644 gcc/ada/g-socthi-vms.ads create mode 100644 gcc/ada/g-socthi-vxworks.adb create mode 100644 gcc/ada/g-socthi-vxworks.ads create mode 100644 gcc/ada/g-socthi.adb create mode 100644 gcc/ada/g-socthi.ads create mode 100644 gcc/ada/g-soliop-mingw.ads create mode 100644 gcc/ada/g-soliop-solaris.ads create mode 100644 gcc/ada/g-soliop.ads create mode 100644 gcc/ada/g-sothco-dummy.adb create mode 100644 gcc/ada/g-sothco-dummy.ads create mode 100644 gcc/ada/g-sothco.adb create mode 100644 gcc/ada/g-sothco.ads create mode 100644 gcc/ada/g-souinf.ads create mode 100755 gcc/ada/g-spchge.adb create mode 100755 gcc/ada/g-spchge.ads create mode 100644 gcc/ada/g-speche.adb create mode 100644 gcc/ada/g-speche.ads create mode 100644 gcc/ada/g-spipat.adb create mode 100644 gcc/ada/g-spipat.ads create mode 100644 gcc/ada/g-spitbo.adb create mode 100644 gcc/ada/g-spitbo.ads create mode 100644 gcc/ada/g-sptabo.ads create mode 100644 gcc/ada/g-sptain.ads create mode 100644 gcc/ada/g-sptavs.ads create mode 100644 gcc/ada/g-sse.ads create mode 100644 gcc/ada/g-ssvety.ads create mode 100644 gcc/ada/g-stheme.adb create mode 100644 gcc/ada/g-string.adb create mode 100644 gcc/ada/g-string.ads create mode 100644 gcc/ada/g-strspl.ads create mode 100644 gcc/ada/g-stseme.adb create mode 100644 gcc/ada/g-stsifd-sockets.adb create mode 100644 gcc/ada/g-table.adb create mode 100644 gcc/ada/g-table.ads create mode 100644 gcc/ada/g-tasloc.adb create mode 100644 gcc/ada/g-tasloc.ads create mode 100644 gcc/ada/g-tastus.ads create mode 100644 gcc/ada/g-thread.adb create mode 100644 gcc/ada/g-thread.ads create mode 100644 gcc/ada/g-timsta.adb create mode 100644 gcc/ada/g-timsta.ads create mode 100644 gcc/ada/g-traceb.adb create mode 100644 gcc/ada/g-traceb.ads create mode 100644 gcc/ada/g-trasym-unimplemented.adb create mode 100644 gcc/ada/g-trasym-unimplemented.ads create mode 100644 gcc/ada/g-trasym-vms-alpha.adb create mode 100644 gcc/ada/g-trasym-vms-ia64.adb create mode 100644 gcc/ada/g-trasym.adb create mode 100644 gcc/ada/g-trasym.ads create mode 100755 gcc/ada/g-u3spch.adb create mode 100755 gcc/ada/g-u3spch.ads create mode 100644 gcc/ada/g-utf_32.adb create mode 100644 gcc/ada/g-utf_32.ads create mode 100755 gcc/ada/g-wispch.adb create mode 100755 gcc/ada/g-wispch.ads create mode 100644 gcc/ada/g-wistsp.ads create mode 100755 gcc/ada/g-zspche.adb create mode 100755 gcc/ada/g-zspche.ads create mode 100644 gcc/ada/g-zstspl.ads create mode 100644 gcc/ada/gcc-interface/Make-lang.in create mode 100644 gcc/ada/gcc-interface/Makefile.in create mode 100644 gcc/ada/gcc-interface/ada-tree.def create mode 100644 gcc/ada/gcc-interface/ada-tree.h create mode 100644 gcc/ada/gcc-interface/ada.h create mode 100644 gcc/ada/gcc-interface/config-lang.in create mode 100644 gcc/ada/gcc-interface/cuintp.c create mode 100644 gcc/ada/gcc-interface/decl.c create mode 100644 gcc/ada/gcc-interface/gadaint.h create mode 100644 gcc/ada/gcc-interface/gigi.h create mode 100644 gcc/ada/gcc-interface/lang-specs.h create mode 100644 gcc/ada/gcc-interface/lang.opt create mode 100644 gcc/ada/gcc-interface/misc.c create mode 100644 gcc/ada/gcc-interface/targtyps.c create mode 100644 gcc/ada/gcc-interface/trans.c create mode 100644 gcc/ada/gcc-interface/utils.c create mode 100644 gcc/ada/gcc-interface/utils2.c create mode 100644 gcc/ada/get_scos.adb create mode 100644 gcc/ada/get_scos.ads create mode 100644 gcc/ada/get_targ.adb create mode 100644 gcc/ada/get_targ.ads create mode 100644 gcc/ada/gnat-style.texi create mode 100644 gcc/ada/gnat.ads create mode 100644 gcc/ada/gnat1drv.adb create mode 100644 gcc/ada/gnat1drv.ads create mode 100644 gcc/ada/gnat_rm.texi create mode 100644 gcc/ada/gnat_ugn.texi create mode 100644 gcc/ada/gnatbind.adb create mode 100644 gcc/ada/gnatbind.ads create mode 100644 gcc/ada/gnatchop.adb create mode 100644 gcc/ada/gnatclean.adb create mode 100644 gcc/ada/gnatcmd.adb create mode 100644 gcc/ada/gnatcmd.ads create mode 100644 gcc/ada/gnatdll.adb create mode 100644 gcc/ada/gnatfind.adb create mode 100644 gcc/ada/gnathtml.pl create mode 100644 gcc/ada/gnatkr.adb create mode 100644 gcc/ada/gnatkr.ads create mode 100644 gcc/ada/gnatlink.adb create mode 100644 gcc/ada/gnatlink.ads create mode 100644 gcc/ada/gnatls.adb create mode 100644 gcc/ada/gnatls.ads create mode 100644 gcc/ada/gnatmake.adb create mode 100644 gcc/ada/gnatmake.ads create mode 100644 gcc/ada/gnatname.adb create mode 100644 gcc/ada/gnatname.ads create mode 100644 gcc/ada/gnatprep.adb create mode 100644 gcc/ada/gnatprep.ads create mode 100644 gcc/ada/gnatsym.adb create mode 100644 gcc/ada/gnatvsn.adb create mode 100644 gcc/ada/gnatvsn.ads create mode 100644 gcc/ada/gnatxref.adb create mode 100644 gcc/ada/gprep.adb create mode 100644 gcc/ada/gprep.ads create mode 100644 gcc/ada/gsocket.h create mode 100644 gcc/ada/hlo.adb create mode 100644 gcc/ada/hlo.ads create mode 100644 gcc/ada/hostparm.ads create mode 100644 gcc/ada/i-c.adb create mode 100644 gcc/ada/i-c.ads create mode 100644 gcc/ada/i-cexten.ads create mode 100644 gcc/ada/i-cobol.adb create mode 100644 gcc/ada/i-cobol.ads create mode 100644 gcc/ada/i-cpoint.adb create mode 100644 gcc/ada/i-cpoint.ads create mode 100644 gcc/ada/i-cpp.adb create mode 100644 gcc/ada/i-cpp.ads create mode 100644 gcc/ada/i-cstrea-vms.adb create mode 100644 gcc/ada/i-cstrea.adb create mode 100644 gcc/ada/i-cstrea.ads create mode 100644 gcc/ada/i-cstrin.adb create mode 100644 gcc/ada/i-cstrin.ads create mode 100644 gcc/ada/i-forbla-darwin.adb create mode 100644 gcc/ada/i-forbla-unimplemented.ads create mode 100644 gcc/ada/i-forbla.adb create mode 100644 gcc/ada/i-forbla.ads create mode 100644 gcc/ada/i-forlap.ads create mode 100644 gcc/ada/i-fortra.adb create mode 100644 gcc/ada/i-fortra.ads create mode 100644 gcc/ada/i-pacdec.adb create mode 100644 gcc/ada/i-pacdec.ads create mode 100644 gcc/ada/i-vxwoio.adb create mode 100644 gcc/ada/i-vxwoio.ads create mode 100644 gcc/ada/i-vxwork-x86.ads create mode 100644 gcc/ada/i-vxwork.ads create mode 100644 gcc/ada/impunit.adb create mode 100644 gcc/ada/impunit.ads create mode 100644 gcc/ada/indepsw-aix.adb create mode 100644 gcc/ada/indepsw-gnu.adb create mode 100644 gcc/ada/indepsw-mingw.adb create mode 100644 gcc/ada/indepsw.adb create mode 100644 gcc/ada/indepsw.ads create mode 100644 gcc/ada/init.c create mode 100644 gcc/ada/initialize.c create mode 100644 gcc/ada/inline.adb create mode 100644 gcc/ada/inline.ads create mode 100644 gcc/ada/interfac.ads create mode 100644 gcc/ada/ioexcept.ads create mode 100644 gcc/ada/itypes.adb create mode 100644 gcc/ada/itypes.ads create mode 100644 gcc/ada/krunch.adb create mode 100644 gcc/ada/krunch.ads create mode 100644 gcc/ada/layout.adb create mode 100644 gcc/ada/layout.ads create mode 100644 gcc/ada/lib-list.adb create mode 100644 gcc/ada/lib-load.adb create mode 100644 gcc/ada/lib-load.ads create mode 100644 gcc/ada/lib-sort.adb create mode 100644 gcc/ada/lib-util.adb create mode 100644 gcc/ada/lib-util.ads create mode 100644 gcc/ada/lib-writ.adb create mode 100644 gcc/ada/lib-writ.ads create mode 100644 gcc/ada/lib-xref.adb create mode 100644 gcc/ada/lib-xref.ads create mode 100644 gcc/ada/lib.adb create mode 100644 gcc/ada/lib.ads create mode 100644 gcc/ada/link.c create mode 100644 gcc/ada/live.adb create mode 100644 gcc/ada/live.ads create mode 100644 gcc/ada/locales.c create mode 100644 gcc/ada/machcode.ads create mode 100644 gcc/ada/make.adb create mode 100644 gcc/ada/make.ads create mode 100644 gcc/ada/makeusg.adb create mode 100644 gcc/ada/makeusg.ads create mode 100644 gcc/ada/makeutl.adb create mode 100644 gcc/ada/makeutl.ads create mode 100644 gcc/ada/math_lib.adb create mode 100644 gcc/ada/mdll-fil.adb create mode 100644 gcc/ada/mdll-fil.ads create mode 100644 gcc/ada/mdll-utl.adb create mode 100644 gcc/ada/mdll-utl.ads create mode 100644 gcc/ada/mdll.adb create mode 100644 gcc/ada/mdll.ads create mode 100644 gcc/ada/memtrack.adb create mode 100644 gcc/ada/mingw32.h create mode 100644 gcc/ada/mkdir.c create mode 100644 gcc/ada/mlib-fil.adb create mode 100644 gcc/ada/mlib-fil.ads create mode 100644 gcc/ada/mlib-prj.adb create mode 100644 gcc/ada/mlib-prj.ads create mode 100644 gcc/ada/mlib-tgt-specific-aix.adb create mode 100644 gcc/ada/mlib-tgt-specific-darwin.adb create mode 100644 gcc/ada/mlib-tgt-specific-hpux.adb create mode 100644 gcc/ada/mlib-tgt-specific-irix.adb create mode 100644 gcc/ada/mlib-tgt-specific-linux.adb create mode 100644 gcc/ada/mlib-tgt-specific-lynxos.adb create mode 100644 gcc/ada/mlib-tgt-specific-mingw.adb create mode 100644 gcc/ada/mlib-tgt-specific-solaris.adb create mode 100644 gcc/ada/mlib-tgt-specific-tru64.adb create mode 100644 gcc/ada/mlib-tgt-specific-vms-alpha.adb create mode 100644 gcc/ada/mlib-tgt-specific-vms-ia64.adb create mode 100644 gcc/ada/mlib-tgt-specific-vxworks.adb create mode 100644 gcc/ada/mlib-tgt-specific-xi.adb create mode 100644 gcc/ada/mlib-tgt-specific.adb create mode 100644 gcc/ada/mlib-tgt-specific.ads create mode 100644 gcc/ada/mlib-tgt-vms_common.adb create mode 100644 gcc/ada/mlib-tgt-vms_common.ads create mode 100644 gcc/ada/mlib-tgt.adb create mode 100644 gcc/ada/mlib-tgt.ads create mode 100644 gcc/ada/mlib-utl.adb create mode 100644 gcc/ada/mlib-utl.ads create mode 100644 gcc/ada/mlib.adb create mode 100644 gcc/ada/mlib.ads create mode 100755 gcc/ada/namet-sp.adb create mode 100755 gcc/ada/namet-sp.ads create mode 100644 gcc/ada/namet.adb create mode 100644 gcc/ada/namet.ads create mode 100644 gcc/ada/namet.h create mode 100644 gcc/ada/nlists.adb create mode 100644 gcc/ada/nlists.ads create mode 100644 gcc/ada/nlists.h create mode 100644 gcc/ada/nmake.adt create mode 100644 gcc/ada/opt.adb create mode 100644 gcc/ada/opt.ads create mode 100644 gcc/ada/osint-b.adb create mode 100644 gcc/ada/osint-b.ads create mode 100644 gcc/ada/osint-c.adb create mode 100644 gcc/ada/osint-c.ads create mode 100644 gcc/ada/osint-l.adb create mode 100644 gcc/ada/osint-l.ads create mode 100644 gcc/ada/osint-m.adb create mode 100644 gcc/ada/osint-m.ads create mode 100644 gcc/ada/osint.adb create mode 100644 gcc/ada/osint.ads create mode 100644 gcc/ada/output.adb create mode 100644 gcc/ada/output.ads create mode 100644 gcc/ada/par-ch10.adb create mode 100644 gcc/ada/par-ch11.adb create mode 100644 gcc/ada/par-ch12.adb create mode 100644 gcc/ada/par-ch13.adb create mode 100644 gcc/ada/par-ch2.adb create mode 100644 gcc/ada/par-ch3.adb create mode 100644 gcc/ada/par-ch4.adb create mode 100644 gcc/ada/par-ch5.adb create mode 100644 gcc/ada/par-ch6.adb create mode 100644 gcc/ada/par-ch7.adb create mode 100644 gcc/ada/par-ch8.adb create mode 100644 gcc/ada/par-ch9.adb create mode 100644 gcc/ada/par-endh.adb create mode 100644 gcc/ada/par-labl.adb create mode 100644 gcc/ada/par-load.adb create mode 100644 gcc/ada/par-prag.adb create mode 100644 gcc/ada/par-sync.adb create mode 100644 gcc/ada/par-tchk.adb create mode 100644 gcc/ada/par-util.adb create mode 100644 gcc/ada/par.adb create mode 100644 gcc/ada/par.ads create mode 100644 gcc/ada/par_sco.adb create mode 100644 gcc/ada/par_sco.ads create mode 100644 gcc/ada/prep.adb create mode 100644 gcc/ada/prep.ads create mode 100644 gcc/ada/prepcomp.adb create mode 100644 gcc/ada/prepcomp.ads create mode 100644 gcc/ada/prj-attr-pm.adb create mode 100644 gcc/ada/prj-attr-pm.ads create mode 100644 gcc/ada/prj-attr.adb create mode 100644 gcc/ada/prj-attr.ads create mode 100644 gcc/ada/prj-com.ads create mode 100644 gcc/ada/prj-conf.adb create mode 100644 gcc/ada/prj-conf.ads create mode 100644 gcc/ada/prj-dect.adb create mode 100644 gcc/ada/prj-dect.ads create mode 100644 gcc/ada/prj-env.adb create mode 100644 gcc/ada/prj-env.ads create mode 100644 gcc/ada/prj-err.adb create mode 100644 gcc/ada/prj-err.ads create mode 100644 gcc/ada/prj-ext.adb create mode 100644 gcc/ada/prj-ext.ads create mode 100644 gcc/ada/prj-makr.adb create mode 100644 gcc/ada/prj-makr.ads create mode 100644 gcc/ada/prj-nmsc.adb create mode 100644 gcc/ada/prj-nmsc.ads create mode 100644 gcc/ada/prj-pars.adb create mode 100644 gcc/ada/prj-pars.ads create mode 100644 gcc/ada/prj-part.adb create mode 100644 gcc/ada/prj-part.ads create mode 100644 gcc/ada/prj-pp.adb create mode 100644 gcc/ada/prj-pp.ads create mode 100644 gcc/ada/prj-proc.adb create mode 100644 gcc/ada/prj-proc.ads create mode 100644 gcc/ada/prj-strt.adb create mode 100644 gcc/ada/prj-strt.ads create mode 100644 gcc/ada/prj-tree.adb create mode 100644 gcc/ada/prj-tree.ads create mode 100644 gcc/ada/prj-util.adb create mode 100644 gcc/ada/prj-util.ads create mode 100644 gcc/ada/prj.adb create mode 100644 gcc/ada/prj.ads create mode 100644 gcc/ada/projects.texi create mode 100644 gcc/ada/put_scos.adb create mode 100644 gcc/ada/put_scos.ads create mode 100644 gcc/ada/raise-gcc.c create mode 100644 gcc/ada/raise.c create mode 100644 gcc/ada/raise.h create mode 100644 gcc/ada/repinfo.adb create mode 100644 gcc/ada/repinfo.ads create mode 100644 gcc/ada/repinfo.h create mode 100644 gcc/ada/restrict.adb create mode 100644 gcc/ada/restrict.ads create mode 100644 gcc/ada/rident.ads create mode 100644 gcc/ada/rtsfind.adb create mode 100644 gcc/ada/rtsfind.ads create mode 100644 gcc/ada/s-addima.adb create mode 100644 gcc/ada/s-addima.ads create mode 100644 gcc/ada/s-addope.adb create mode 100644 gcc/ada/s-addope.ads create mode 100644 gcc/ada/s-arit64.adb create mode 100644 gcc/ada/s-arit64.ads create mode 100644 gcc/ada/s-assert.adb create mode 100644 gcc/ada/s-assert.ads create mode 100644 gcc/ada/s-asthan-vms-alpha.adb create mode 100644 gcc/ada/s-asthan.adb create mode 100644 gcc/ada/s-asthan.ads create mode 100644 gcc/ada/s-atacco.adb create mode 100644 gcc/ada/s-atacco.ads create mode 100644 gcc/ada/s-auxdec-empty.adb create mode 100644 gcc/ada/s-auxdec-empty.ads create mode 100644 gcc/ada/s-auxdec-vms-alpha.adb create mode 100644 gcc/ada/s-auxdec-vms_64.ads create mode 100644 gcc/ada/s-auxdec.adb create mode 100644 gcc/ada/s-auxdec.ads create mode 100644 gcc/ada/s-bitops.adb create mode 100644 gcc/ada/s-bitops.ads create mode 100644 gcc/ada/s-boarop.ads create mode 100644 gcc/ada/s-carsi8.adb create mode 100644 gcc/ada/s-carsi8.ads create mode 100644 gcc/ada/s-carun8.adb create mode 100644 gcc/ada/s-carun8.ads create mode 100644 gcc/ada/s-casi16.adb create mode 100644 gcc/ada/s-casi16.ads create mode 100644 gcc/ada/s-casi32.adb create mode 100644 gcc/ada/s-casi32.ads create mode 100644 gcc/ada/s-casi64.adb create mode 100644 gcc/ada/s-casi64.ads create mode 100644 gcc/ada/s-casuti.adb create mode 100644 gcc/ada/s-casuti.ads create mode 100644 gcc/ada/s-caun16.adb create mode 100644 gcc/ada/s-caun16.ads create mode 100644 gcc/ada/s-caun32.adb create mode 100644 gcc/ada/s-caun32.ads create mode 100644 gcc/ada/s-caun64.adb create mode 100644 gcc/ada/s-caun64.ads create mode 100644 gcc/ada/s-chepoo.ads create mode 100644 gcc/ada/s-commun.adb create mode 100644 gcc/ada/s-commun.ads create mode 100644 gcc/ada/s-conca2.adb create mode 100644 gcc/ada/s-conca2.ads create mode 100644 gcc/ada/s-conca3.adb create mode 100644 gcc/ada/s-conca3.ads create mode 100644 gcc/ada/s-conca4.adb create mode 100644 gcc/ada/s-conca4.ads create mode 100644 gcc/ada/s-conca5.adb create mode 100644 gcc/ada/s-conca5.ads create mode 100644 gcc/ada/s-conca6.adb create mode 100644 gcc/ada/s-conca6.ads create mode 100644 gcc/ada/s-conca7.adb create mode 100644 gcc/ada/s-conca7.ads create mode 100644 gcc/ada/s-conca8.adb create mode 100644 gcc/ada/s-conca8.ads create mode 100644 gcc/ada/s-conca9.adb create mode 100644 gcc/ada/s-conca9.ads create mode 100644 gcc/ada/s-crc32.adb create mode 100644 gcc/ada/s-crc32.ads create mode 100644 gcc/ada/s-crtl.ads create mode 100644 gcc/ada/s-crtrun.ads create mode 100644 gcc/ada/s-direio.adb create mode 100644 gcc/ada/s-direio.ads create mode 100644 gcc/ada/s-dsaser.ads create mode 100755 gcc/ada/s-except.adb create mode 100644 gcc/ada/s-except.ads create mode 100644 gcc/ada/s-exctab.adb create mode 100644 gcc/ada/s-exctab.ads create mode 100644 gcc/ada/s-exnint.adb create mode 100644 gcc/ada/s-exnint.ads create mode 100644 gcc/ada/s-exnllf.adb create mode 100644 gcc/ada/s-exnllf.ads create mode 100644 gcc/ada/s-exnlli.adb create mode 100644 gcc/ada/s-exnlli.ads create mode 100644 gcc/ada/s-expint.adb create mode 100644 gcc/ada/s-expint.ads create mode 100644 gcc/ada/s-explli.adb create mode 100644 gcc/ada/s-explli.ads create mode 100644 gcc/ada/s-expllu.adb create mode 100644 gcc/ada/s-expllu.ads create mode 100644 gcc/ada/s-expmod.adb create mode 100644 gcc/ada/s-expmod.ads create mode 100644 gcc/ada/s-expuns.adb create mode 100644 gcc/ada/s-expuns.ads create mode 100644 gcc/ada/s-fatflt.ads create mode 100644 gcc/ada/s-fatgen.adb create mode 100644 gcc/ada/s-fatgen.ads create mode 100644 gcc/ada/s-fatlfl.ads create mode 100644 gcc/ada/s-fatllf.ads create mode 100644 gcc/ada/s-fatsfl.ads create mode 100644 gcc/ada/s-ficobl.ads create mode 100644 gcc/ada/s-fileio.adb create mode 100644 gcc/ada/s-fileio.ads create mode 100644 gcc/ada/s-filofl.ads create mode 100644 gcc/ada/s-finimp.adb create mode 100644 gcc/ada/s-finimp.ads create mode 100644 gcc/ada/s-finroo.adb create mode 100644 gcc/ada/s-finroo.ads create mode 100644 gcc/ada/s-fishfl.ads create mode 100644 gcc/ada/s-fore.adb create mode 100644 gcc/ada/s-fore.ads create mode 100644 gcc/ada/s-fvadfl.ads create mode 100644 gcc/ada/s-fvaffl.ads create mode 100644 gcc/ada/s-fvagfl.ads create mode 100644 gcc/ada/s-gearop.adb create mode 100644 gcc/ada/s-gearop.ads create mode 100644 gcc/ada/s-gecobl.adb create mode 100644 gcc/ada/s-gecobl.ads create mode 100644 gcc/ada/s-gecola.adb create mode 100644 gcc/ada/s-gecola.ads create mode 100644 gcc/ada/s-gerebl.adb create mode 100644 gcc/ada/s-gerebl.ads create mode 100644 gcc/ada/s-gerela.adb create mode 100644 gcc/ada/s-gerela.ads create mode 100644 gcc/ada/s-geveop.adb create mode 100644 gcc/ada/s-geveop.ads create mode 100644 gcc/ada/s-gloloc-mingw.adb create mode 100644 gcc/ada/s-gloloc.adb create mode 100644 gcc/ada/s-gloloc.ads create mode 100644 gcc/ada/s-hibaen.ads create mode 100644 gcc/ada/s-htable.adb create mode 100644 gcc/ada/s-htable.ads create mode 100644 gcc/ada/s-imenne.adb create mode 100644 gcc/ada/s-imenne.ads create mode 100644 gcc/ada/s-imgbiu.adb create mode 100644 gcc/ada/s-imgbiu.ads create mode 100644 gcc/ada/s-imgboo.adb create mode 100644 gcc/ada/s-imgboo.ads create mode 100644 gcc/ada/s-imgcha.adb create mode 100644 gcc/ada/s-imgcha.ads create mode 100644 gcc/ada/s-imgdec.adb create mode 100644 gcc/ada/s-imgdec.ads create mode 100644 gcc/ada/s-imgenu.adb create mode 100644 gcc/ada/s-imgenu.ads create mode 100644 gcc/ada/s-imgint.adb create mode 100644 gcc/ada/s-imgint.ads create mode 100644 gcc/ada/s-imgllb.adb create mode 100644 gcc/ada/s-imgllb.ads create mode 100644 gcc/ada/s-imglld.adb create mode 100644 gcc/ada/s-imglld.ads create mode 100644 gcc/ada/s-imglli.adb create mode 100644 gcc/ada/s-imglli.ads create mode 100644 gcc/ada/s-imgllu.adb create mode 100644 gcc/ada/s-imgllu.ads create mode 100644 gcc/ada/s-imgllw.adb create mode 100644 gcc/ada/s-imgllw.ads create mode 100644 gcc/ada/s-imgrea.adb create mode 100644 gcc/ada/s-imgrea.ads create mode 100644 gcc/ada/s-imguns.adb create mode 100644 gcc/ada/s-imguns.ads create mode 100644 gcc/ada/s-imgwch.adb create mode 100644 gcc/ada/s-imgwch.ads create mode 100644 gcc/ada/s-imgwiu.adb create mode 100644 gcc/ada/s-imgwiu.ads create mode 100644 gcc/ada/s-inmaop-dummy.adb create mode 100644 gcc/ada/s-inmaop-posix.adb create mode 100644 gcc/ada/s-inmaop-vms.adb create mode 100644 gcc/ada/s-inmaop.ads create mode 100644 gcc/ada/s-interr-dummy.adb create mode 100644 gcc/ada/s-interr-hwint.adb create mode 100644 gcc/ada/s-interr-sigaction.adb create mode 100644 gcc/ada/s-interr-vms.adb create mode 100644 gcc/ada/s-interr.adb create mode 100644 gcc/ada/s-interr.ads create mode 100644 gcc/ada/s-intman-dummy.adb create mode 100644 gcc/ada/s-intman-irix.adb create mode 100644 gcc/ada/s-intman-mingw.adb create mode 100644 gcc/ada/s-intman-posix.adb create mode 100644 gcc/ada/s-intman-solaris.adb create mode 100644 gcc/ada/s-intman-susv3.adb create mode 100644 gcc/ada/s-intman-vms.adb create mode 100644 gcc/ada/s-intman-vms.ads create mode 100644 gcc/ada/s-intman-vxworks.adb create mode 100644 gcc/ada/s-intman-vxworks.ads create mode 100644 gcc/ada/s-intman.ads create mode 100644 gcc/ada/s-io.adb create mode 100644 gcc/ada/s-io.ads create mode 100644 gcc/ada/s-linux-alpha.ads create mode 100644 gcc/ada/s-linux-hppa.ads create mode 100644 gcc/ada/s-linux-mipsel.ads create mode 100644 gcc/ada/s-linux-sparc.ads create mode 100644 gcc/ada/s-linux.ads create mode 100644 gcc/ada/s-maccod.ads create mode 100644 gcc/ada/s-mantis.adb create mode 100644 gcc/ada/s-mantis.ads create mode 100644 gcc/ada/s-mastop-irix.adb create mode 100644 gcc/ada/s-mastop-tru64.adb create mode 100644 gcc/ada/s-mastop-vms.adb create mode 100644 gcc/ada/s-mastop.adb create mode 100644 gcc/ada/s-mastop.ads create mode 100644 gcc/ada/s-memcop.ads create mode 100644 gcc/ada/s-memory-mingw.adb create mode 100644 gcc/ada/s-memory.adb create mode 100644 gcc/ada/s-memory.ads create mode 100644 gcc/ada/s-multip.adb create mode 100644 gcc/ada/s-multip.ads create mode 100755 gcc/ada/s-os_lib.adb create mode 100755 gcc/ada/s-os_lib.ads create mode 100644 gcc/ada/s-oscons-tmplt.c create mode 100644 gcc/ada/s-osinte-aix.adb create mode 100644 gcc/ada/s-osinte-aix.ads create mode 100644 gcc/ada/s-osinte-darwin.adb create mode 100644 gcc/ada/s-osinte-darwin.ads create mode 100644 gcc/ada/s-osinte-dummy.ads create mode 100644 gcc/ada/s-osinte-freebsd.adb create mode 100644 gcc/ada/s-osinte-freebsd.ads create mode 100644 gcc/ada/s-osinte-hpux-dce.adb create mode 100644 gcc/ada/s-osinte-hpux-dce.ads create mode 100644 gcc/ada/s-osinte-hpux.ads create mode 100644 gcc/ada/s-osinte-irix.adb create mode 100644 gcc/ada/s-osinte-irix.ads create mode 100644 gcc/ada/s-osinte-kfreebsd-gnu.ads create mode 100644 gcc/ada/s-osinte-linux.ads create mode 100644 gcc/ada/s-osinte-lynxos-3.adb create mode 100644 gcc/ada/s-osinte-lynxos-3.ads create mode 100644 gcc/ada/s-osinte-lynxos.adb create mode 100644 gcc/ada/s-osinte-lynxos.ads create mode 100644 gcc/ada/s-osinte-mingw.ads create mode 100644 gcc/ada/s-osinte-posix.adb create mode 100644 gcc/ada/s-osinte-rtems.adb create mode 100644 gcc/ada/s-osinte-rtems.ads create mode 100644 gcc/ada/s-osinte-solaris-posix.ads create mode 100644 gcc/ada/s-osinte-solaris.adb create mode 100644 gcc/ada/s-osinte-solaris.ads create mode 100644 gcc/ada/s-osinte-tru64.adb create mode 100644 gcc/ada/s-osinte-tru64.ads create mode 100644 gcc/ada/s-osinte-vms.adb create mode 100644 gcc/ada/s-osinte-vms.ads create mode 100644 gcc/ada/s-osinte-vxworks.adb create mode 100644 gcc/ada/s-osinte-vxworks.ads create mode 100644 gcc/ada/s-osprim-darwin.adb create mode 100644 gcc/ada/s-osprim-mingw.adb create mode 100644 gcc/ada/s-osprim-posix.adb create mode 100644 gcc/ada/s-osprim-solaris.adb create mode 100644 gcc/ada/s-osprim-unix.adb create mode 100644 gcc/ada/s-osprim-vms.adb create mode 100644 gcc/ada/s-osprim-vms.ads create mode 100644 gcc/ada/s-osprim-vxworks.adb create mode 100644 gcc/ada/s-osprim.ads create mode 100644 gcc/ada/s-pack03.adb create mode 100644 gcc/ada/s-pack03.ads create mode 100644 gcc/ada/s-pack05.adb create mode 100644 gcc/ada/s-pack05.ads create mode 100644 gcc/ada/s-pack06.adb create mode 100644 gcc/ada/s-pack06.ads create mode 100644 gcc/ada/s-pack07.adb create mode 100644 gcc/ada/s-pack07.ads create mode 100644 gcc/ada/s-pack09.adb create mode 100644 gcc/ada/s-pack09.ads create mode 100644 gcc/ada/s-pack10.adb create mode 100644 gcc/ada/s-pack10.ads create mode 100644 gcc/ada/s-pack11.adb create mode 100644 gcc/ada/s-pack11.ads create mode 100644 gcc/ada/s-pack12.adb create mode 100644 gcc/ada/s-pack12.ads create mode 100644 gcc/ada/s-pack13.adb create mode 100644 gcc/ada/s-pack13.ads create mode 100644 gcc/ada/s-pack14.adb create mode 100644 gcc/ada/s-pack14.ads create mode 100644 gcc/ada/s-pack15.adb create mode 100644 gcc/ada/s-pack15.ads create mode 100644 gcc/ada/s-pack17.adb create mode 100644 gcc/ada/s-pack17.ads create mode 100644 gcc/ada/s-pack18.adb create mode 100644 gcc/ada/s-pack18.ads create mode 100644 gcc/ada/s-pack19.adb create mode 100644 gcc/ada/s-pack19.ads create mode 100644 gcc/ada/s-pack20.adb create mode 100644 gcc/ada/s-pack20.ads create mode 100644 gcc/ada/s-pack21.adb create mode 100644 gcc/ada/s-pack21.ads create mode 100644 gcc/ada/s-pack22.adb create mode 100644 gcc/ada/s-pack22.ads create mode 100644 gcc/ada/s-pack23.adb create mode 100644 gcc/ada/s-pack23.ads create mode 100644 gcc/ada/s-pack24.adb create mode 100644 gcc/ada/s-pack24.ads create mode 100644 gcc/ada/s-pack25.adb create mode 100644 gcc/ada/s-pack25.ads create mode 100644 gcc/ada/s-pack26.adb create mode 100644 gcc/ada/s-pack26.ads create mode 100644 gcc/ada/s-pack27.adb create mode 100644 gcc/ada/s-pack27.ads create mode 100644 gcc/ada/s-pack28.adb create mode 100644 gcc/ada/s-pack28.ads create mode 100644 gcc/ada/s-pack29.adb create mode 100644 gcc/ada/s-pack29.ads create mode 100644 gcc/ada/s-pack30.adb create mode 100644 gcc/ada/s-pack30.ads create mode 100644 gcc/ada/s-pack31.adb create mode 100644 gcc/ada/s-pack31.ads create mode 100644 gcc/ada/s-pack33.adb create mode 100644 gcc/ada/s-pack33.ads create mode 100644 gcc/ada/s-pack34.adb create mode 100644 gcc/ada/s-pack34.ads create mode 100644 gcc/ada/s-pack35.adb create mode 100644 gcc/ada/s-pack35.ads create mode 100644 gcc/ada/s-pack36.adb create mode 100644 gcc/ada/s-pack36.ads create mode 100644 gcc/ada/s-pack37.adb create mode 100644 gcc/ada/s-pack37.ads create mode 100644 gcc/ada/s-pack38.adb create mode 100644 gcc/ada/s-pack38.ads create mode 100644 gcc/ada/s-pack39.adb create mode 100644 gcc/ada/s-pack39.ads create mode 100644 gcc/ada/s-pack40.adb create mode 100644 gcc/ada/s-pack40.ads create mode 100644 gcc/ada/s-pack41.adb create mode 100644 gcc/ada/s-pack41.ads create mode 100644 gcc/ada/s-pack42.adb create mode 100644 gcc/ada/s-pack42.ads create mode 100644 gcc/ada/s-pack43.adb create mode 100644 gcc/ada/s-pack43.ads create mode 100644 gcc/ada/s-pack44.adb create mode 100644 gcc/ada/s-pack44.ads create mode 100644 gcc/ada/s-pack45.adb create mode 100644 gcc/ada/s-pack45.ads create mode 100644 gcc/ada/s-pack46.adb create mode 100644 gcc/ada/s-pack46.ads create mode 100644 gcc/ada/s-pack47.adb create mode 100644 gcc/ada/s-pack47.ads create mode 100644 gcc/ada/s-pack48.adb create mode 100644 gcc/ada/s-pack48.ads create mode 100644 gcc/ada/s-pack49.adb create mode 100644 gcc/ada/s-pack49.ads create mode 100644 gcc/ada/s-pack50.adb create mode 100644 gcc/ada/s-pack50.ads create mode 100644 gcc/ada/s-pack51.adb create mode 100644 gcc/ada/s-pack51.ads create mode 100644 gcc/ada/s-pack52.adb create mode 100644 gcc/ada/s-pack52.ads create mode 100644 gcc/ada/s-pack53.adb create mode 100644 gcc/ada/s-pack53.ads create mode 100644 gcc/ada/s-pack54.adb create mode 100644 gcc/ada/s-pack54.ads create mode 100644 gcc/ada/s-pack55.adb create mode 100644 gcc/ada/s-pack55.ads create mode 100644 gcc/ada/s-pack56.adb create mode 100644 gcc/ada/s-pack56.ads create mode 100644 gcc/ada/s-pack57.adb create mode 100644 gcc/ada/s-pack57.ads create mode 100644 gcc/ada/s-pack58.adb create mode 100644 gcc/ada/s-pack58.ads create mode 100644 gcc/ada/s-pack59.adb create mode 100644 gcc/ada/s-pack59.ads create mode 100644 gcc/ada/s-pack60.adb create mode 100644 gcc/ada/s-pack60.ads create mode 100644 gcc/ada/s-pack61.adb create mode 100644 gcc/ada/s-pack61.ads create mode 100644 gcc/ada/s-pack62.adb create mode 100644 gcc/ada/s-pack62.ads create mode 100644 gcc/ada/s-pack63.adb create mode 100644 gcc/ada/s-pack63.ads create mode 100644 gcc/ada/s-parame-ae653.ads create mode 100644 gcc/ada/s-parame-hpux.ads create mode 100644 gcc/ada/s-parame-rtems.adb create mode 100644 gcc/ada/s-parame-vms-alpha.ads create mode 100644 gcc/ada/s-parame-vms-ia64.ads create mode 100644 gcc/ada/s-parame-vms-restrict.ads create mode 100644 gcc/ada/s-parame-vxworks.adb create mode 100644 gcc/ada/s-parame-vxworks.ads create mode 100644 gcc/ada/s-parame.adb create mode 100644 gcc/ada/s-parame.ads create mode 100644 gcc/ada/s-parint.adb create mode 100644 gcc/ada/s-parint.ads create mode 100644 gcc/ada/s-pooglo.adb create mode 100644 gcc/ada/s-pooglo.ads create mode 100644 gcc/ada/s-pooloc.adb create mode 100644 gcc/ada/s-pooloc.ads create mode 100644 gcc/ada/s-poosiz.adb create mode 100644 gcc/ada/s-poosiz.ads create mode 100644 gcc/ada/s-powtab.ads create mode 100644 gcc/ada/s-proinf-irix-athread.adb create mode 100644 gcc/ada/s-proinf-irix-athread.ads create mode 100644 gcc/ada/s-proinf.adb create mode 100644 gcc/ada/s-proinf.ads create mode 100644 gcc/ada/s-purexc.ads create mode 100644 gcc/ada/s-rannum.adb create mode 100644 gcc/ada/s-rannum.ads create mode 100755 gcc/ada/s-regexp.adb create mode 100755 gcc/ada/s-regexp.ads create mode 100755 gcc/ada/s-regpat.adb create mode 100755 gcc/ada/s-regpat.ads create mode 100644 gcc/ada/s-restri.adb create mode 100644 gcc/ada/s-restri.ads create mode 100644 gcc/ada/s-rident.ads create mode 100644 gcc/ada/s-rpc.adb create mode 100644 gcc/ada/s-rpc.ads create mode 100644 gcc/ada/s-scaval.adb create mode 100644 gcc/ada/s-scaval.ads create mode 100644 gcc/ada/s-secsta.adb create mode 100644 gcc/ada/s-secsta.ads create mode 100644 gcc/ada/s-sequio.adb create mode 100644 gcc/ada/s-sequio.ads create mode 100644 gcc/ada/s-shasto.adb create mode 100644 gcc/ada/s-shasto.ads create mode 100644 gcc/ada/s-soflin.adb create mode 100644 gcc/ada/s-soflin.ads create mode 100644 gcc/ada/s-solita.adb create mode 100644 gcc/ada/s-solita.ads create mode 100644 gcc/ada/s-sopco3.adb create mode 100644 gcc/ada/s-sopco3.ads create mode 100644 gcc/ada/s-sopco4.adb create mode 100644 gcc/ada/s-sopco4.ads create mode 100644 gcc/ada/s-sopco5.adb create mode 100644 gcc/ada/s-sopco5.ads create mode 100644 gcc/ada/s-stache.adb create mode 100644 gcc/ada/s-stache.ads create mode 100644 gcc/ada/s-stalib.adb create mode 100644 gcc/ada/s-stalib.ads create mode 100644 gcc/ada/s-stausa.adb create mode 100644 gcc/ada/s-stausa.ads create mode 100644 gcc/ada/s-stchop-limit.ads create mode 100644 gcc/ada/s-stchop-rtems.adb create mode 100644 gcc/ada/s-stchop-vxworks.adb create mode 100644 gcc/ada/s-stchop.adb create mode 100644 gcc/ada/s-stchop.ads create mode 100644 gcc/ada/s-stoele.adb create mode 100644 gcc/ada/s-stoele.ads create mode 100644 gcc/ada/s-stopoo.adb create mode 100644 gcc/ada/s-stopoo.ads create mode 100644 gcc/ada/s-stratt-xdr.adb create mode 100644 gcc/ada/s-stratt.adb create mode 100644 gcc/ada/s-stratt.ads create mode 100644 gcc/ada/s-strcom.adb create mode 100644 gcc/ada/s-strcom.ads create mode 100644 gcc/ada/s-strhas.adb create mode 100644 gcc/ada/s-strhas.ads create mode 100755 gcc/ada/s-string.adb create mode 100755 gcc/ada/s-string.ads create mode 100644 gcc/ada/s-strops.adb create mode 100644 gcc/ada/s-strops.ads create mode 100644 gcc/ada/s-ststop.adb create mode 100644 gcc/ada/s-ststop.ads create mode 100644 gcc/ada/s-stusta.adb create mode 100644 gcc/ada/s-stusta.ads create mode 100644 gcc/ada/s-taasde.adb create mode 100644 gcc/ada/s-taasde.ads create mode 100644 gcc/ada/s-tadeca.adb create mode 100644 gcc/ada/s-tadeca.ads create mode 100644 gcc/ada/s-tadert.adb create mode 100644 gcc/ada/s-tadert.ads create mode 100644 gcc/ada/s-taenca.adb create mode 100644 gcc/ada/s-taenca.ads create mode 100644 gcc/ada/s-taprob.adb create mode 100644 gcc/ada/s-taprob.ads create mode 100644 gcc/ada/s-taprop-dummy.adb create mode 100644 gcc/ada/s-taprop-hpux-dce.adb create mode 100644 gcc/ada/s-taprop-irix.adb create mode 100644 gcc/ada/s-taprop-linux.adb create mode 100644 gcc/ada/s-taprop-lynxos.adb create mode 100644 gcc/ada/s-taprop-mingw.adb create mode 100644 gcc/ada/s-taprop-posix.adb create mode 100644 gcc/ada/s-taprop-solaris.adb create mode 100644 gcc/ada/s-taprop-tru64.adb create mode 100644 gcc/ada/s-taprop-vms.adb create mode 100644 gcc/ada/s-taprop-vxworks.adb create mode 100644 gcc/ada/s-taprop.ads create mode 100644 gcc/ada/s-tarest.adb create mode 100644 gcc/ada/s-tarest.ads create mode 100644 gcc/ada/s-tasdeb.adb create mode 100644 gcc/ada/s-tasdeb.ads create mode 100644 gcc/ada/s-tasinf-irix.ads create mode 100644 gcc/ada/s-tasinf-linux.adb create mode 100644 gcc/ada/s-tasinf-linux.ads create mode 100644 gcc/ada/s-tasinf-mingw.adb create mode 100644 gcc/ada/s-tasinf-mingw.ads create mode 100644 gcc/ada/s-tasinf-solaris.adb create mode 100644 gcc/ada/s-tasinf-solaris.ads create mode 100644 gcc/ada/s-tasinf-tru64.ads create mode 100644 gcc/ada/s-tasinf-vxworks.ads create mode 100644 gcc/ada/s-tasinf.adb create mode 100644 gcc/ada/s-tasinf.ads create mode 100644 gcc/ada/s-tasini.adb create mode 100644 gcc/ada/s-tasini.ads create mode 100644 gcc/ada/s-taskin.adb create mode 100644 gcc/ada/s-taskin.ads create mode 100755 gcc/ada/s-tasloc.adb create mode 100755 gcc/ada/s-tasloc.ads create mode 100644 gcc/ada/s-taspri-dummy.ads create mode 100644 gcc/ada/s-taspri-hpux-dce.ads create mode 100644 gcc/ada/s-taspri-lynxos.ads create mode 100644 gcc/ada/s-taspri-mingw.ads create mode 100644 gcc/ada/s-taspri-posix-noaltstack.ads create mode 100644 gcc/ada/s-taspri-posix.ads create mode 100644 gcc/ada/s-taspri-solaris.ads create mode 100644 gcc/ada/s-taspri-tru64.ads create mode 100644 gcc/ada/s-taspri-vms.ads create mode 100644 gcc/ada/s-taspri-vxworks.ads create mode 100644 gcc/ada/s-tasque.adb create mode 100644 gcc/ada/s-tasque.ads create mode 100644 gcc/ada/s-tasren.adb create mode 100644 gcc/ada/s-tasren.ads create mode 100644 gcc/ada/s-tasres.ads create mode 100644 gcc/ada/s-tassta.adb create mode 100644 gcc/ada/s-tassta.ads create mode 100644 gcc/ada/s-tasuti.adb create mode 100644 gcc/ada/s-tasuti.ads create mode 100644 gcc/ada/s-tataat.adb create mode 100644 gcc/ada/s-tataat.ads create mode 100644 gcc/ada/s-tfsetr-default.adb create mode 100644 gcc/ada/s-tfsetr-vxworks.adb create mode 100644 gcc/ada/s-tpinop.adb create mode 100644 gcc/ada/s-tpinop.ads create mode 100644 gcc/ada/s-tpoben.adb create mode 100644 gcc/ada/s-tpoben.ads create mode 100644 gcc/ada/s-tpobop.adb create mode 100644 gcc/ada/s-tpobop.ads create mode 100644 gcc/ada/s-tpopde-vms.adb create mode 100644 gcc/ada/s-tpopde-vms.ads create mode 100644 gcc/ada/s-tpopsp-lynxos.adb create mode 100644 gcc/ada/s-tpopsp-posix-foreign.adb create mode 100644 gcc/ada/s-tpopsp-posix.adb create mode 100644 gcc/ada/s-tpopsp-rtems.adb create mode 100644 gcc/ada/s-tpopsp-solaris.adb create mode 100644 gcc/ada/s-tpopsp-vxworks.adb create mode 100644 gcc/ada/s-tporft.adb create mode 100644 gcc/ada/s-tposen.adb create mode 100644 gcc/ada/s-tposen.ads create mode 100644 gcc/ada/s-traceb-hpux.adb create mode 100644 gcc/ada/s-traceb-mastop.adb create mode 100644 gcc/ada/s-traceb.adb create mode 100644 gcc/ada/s-traceb.ads create mode 100644 gcc/ada/s-traces-default.adb create mode 100644 gcc/ada/s-traces.adb create mode 100644 gcc/ada/s-traces.ads create mode 100644 gcc/ada/s-traent-vms.adb create mode 100644 gcc/ada/s-traent-vms.ads create mode 100644 gcc/ada/s-traent.adb create mode 100644 gcc/ada/s-traent.ads create mode 100644 gcc/ada/s-trafor-default.adb create mode 100644 gcc/ada/s-trafor-default.ads create mode 100644 gcc/ada/s-tratas-default.adb create mode 100644 gcc/ada/s-tratas.adb create mode 100644 gcc/ada/s-tratas.ads create mode 100644 gcc/ada/s-unstyp.ads create mode 100755 gcc/ada/s-utf_32.adb create mode 100755 gcc/ada/s-utf_32.ads create mode 100644 gcc/ada/s-vaflop-vms-alpha.adb create mode 100644 gcc/ada/s-vaflop.adb create mode 100644 gcc/ada/s-vaflop.ads create mode 100644 gcc/ada/s-valboo.adb create mode 100644 gcc/ada/s-valboo.ads create mode 100644 gcc/ada/s-valcha.adb create mode 100644 gcc/ada/s-valcha.ads create mode 100644 gcc/ada/s-valdec.adb create mode 100644 gcc/ada/s-valdec.ads create mode 100644 gcc/ada/s-valenu.adb create mode 100644 gcc/ada/s-valenu.ads create mode 100644 gcc/ada/s-valint.adb create mode 100644 gcc/ada/s-valint.ads create mode 100644 gcc/ada/s-vallld.adb create mode 100644 gcc/ada/s-vallld.ads create mode 100644 gcc/ada/s-vallli.adb create mode 100644 gcc/ada/s-vallli.ads create mode 100644 gcc/ada/s-valllu.adb create mode 100644 gcc/ada/s-valllu.ads create mode 100644 gcc/ada/s-valrea.adb create mode 100644 gcc/ada/s-valrea.ads create mode 100644 gcc/ada/s-valuns.adb create mode 100644 gcc/ada/s-valuns.ads create mode 100644 gcc/ada/s-valuti.adb create mode 100644 gcc/ada/s-valuti.ads create mode 100644 gcc/ada/s-valwch.adb create mode 100644 gcc/ada/s-valwch.ads create mode 100644 gcc/ada/s-veboop.adb create mode 100644 gcc/ada/s-veboop.ads create mode 100644 gcc/ada/s-vector.ads create mode 100644 gcc/ada/s-vercon.adb create mode 100644 gcc/ada/s-vercon.ads create mode 100644 gcc/ada/s-vmexta.adb create mode 100644 gcc/ada/s-vmexta.ads create mode 100644 gcc/ada/s-vxwext-kernel.adb create mode 100644 gcc/ada/s-vxwext-kernel.ads create mode 100644 gcc/ada/s-vxwext-rtp.adb create mode 100644 gcc/ada/s-vxwext-rtp.ads create mode 100644 gcc/ada/s-vxwext.adb create mode 100644 gcc/ada/s-vxwext.ads create mode 100644 gcc/ada/s-vxwork-arm.ads create mode 100644 gcc/ada/s-vxwork-m68k.ads create mode 100644 gcc/ada/s-vxwork-mips.ads create mode 100644 gcc/ada/s-vxwork-ppc.ads create mode 100644 gcc/ada/s-vxwork-sparcv9.ads create mode 100644 gcc/ada/s-vxwork-x86.ads create mode 100644 gcc/ada/s-wchcnv.adb create mode 100644 gcc/ada/s-wchcnv.ads create mode 100755 gcc/ada/s-wchcon.adb create mode 100644 gcc/ada/s-wchcon.ads create mode 100644 gcc/ada/s-wchjis.adb create mode 100644 gcc/ada/s-wchjis.ads create mode 100644 gcc/ada/s-wchstw.adb create mode 100644 gcc/ada/s-wchstw.ads create mode 100644 gcc/ada/s-wchwts.adb create mode 100644 gcc/ada/s-wchwts.ads create mode 100644 gcc/ada/s-widboo.adb create mode 100644 gcc/ada/s-widboo.ads create mode 100644 gcc/ada/s-widcha.adb create mode 100644 gcc/ada/s-widcha.ads create mode 100644 gcc/ada/s-widenu.adb create mode 100644 gcc/ada/s-widenu.ads create mode 100644 gcc/ada/s-widlli.adb create mode 100644 gcc/ada/s-widlli.ads create mode 100644 gcc/ada/s-widllu.adb create mode 100644 gcc/ada/s-widllu.ads create mode 100644 gcc/ada/s-widwch.adb create mode 100644 gcc/ada/s-widwch.ads create mode 100644 gcc/ada/s-win32.ads create mode 100644 gcc/ada/s-winext.ads create mode 100644 gcc/ada/s-wwdcha.adb create mode 100644 gcc/ada/s-wwdcha.ads create mode 100644 gcc/ada/s-wwdenu.adb create mode 100644 gcc/ada/s-wwdenu.ads create mode 100644 gcc/ada/s-wwdwch.adb create mode 100644 gcc/ada/s-wwdwch.ads create mode 100644 gcc/ada/scans.adb create mode 100644 gcc/ada/scans.ads create mode 100644 gcc/ada/scil_ll.adb create mode 100644 gcc/ada/scil_ll.ads create mode 100644 gcc/ada/scn.adb create mode 100644 gcc/ada/scn.ads create mode 100644 gcc/ada/scng.adb create mode 100644 gcc/ada/scng.ads create mode 100644 gcc/ada/scos.adb create mode 100644 gcc/ada/scos.ads create mode 100644 gcc/ada/sdefault.ads create mode 100644 gcc/ada/seh_init.c create mode 100644 gcc/ada/sem.adb create mode 100644 gcc/ada/sem.ads create mode 100644 gcc/ada/sem_aggr.adb create mode 100644 gcc/ada/sem_aggr.ads create mode 100644 gcc/ada/sem_attr.adb create mode 100644 gcc/ada/sem_attr.ads create mode 100755 gcc/ada/sem_aux.adb create mode 100755 gcc/ada/sem_aux.ads create mode 100644 gcc/ada/sem_case.adb create mode 100644 gcc/ada/sem_case.ads create mode 100644 gcc/ada/sem_cat.adb create mode 100644 gcc/ada/sem_cat.ads create mode 100644 gcc/ada/sem_ch10.adb create mode 100644 gcc/ada/sem_ch10.ads create mode 100644 gcc/ada/sem_ch11.adb create mode 100644 gcc/ada/sem_ch11.ads create mode 100644 gcc/ada/sem_ch12.adb create mode 100644 gcc/ada/sem_ch12.ads create mode 100644 gcc/ada/sem_ch13.adb create mode 100644 gcc/ada/sem_ch13.ads create mode 100644 gcc/ada/sem_ch2.adb create mode 100644 gcc/ada/sem_ch2.ads create mode 100644 gcc/ada/sem_ch3.adb create mode 100644 gcc/ada/sem_ch3.ads create mode 100644 gcc/ada/sem_ch4.adb create mode 100644 gcc/ada/sem_ch4.ads create mode 100644 gcc/ada/sem_ch5.adb create mode 100644 gcc/ada/sem_ch5.ads create mode 100644 gcc/ada/sem_ch6.adb create mode 100644 gcc/ada/sem_ch6.ads create mode 100644 gcc/ada/sem_ch7.adb create mode 100644 gcc/ada/sem_ch7.ads create mode 100644 gcc/ada/sem_ch8.adb create mode 100644 gcc/ada/sem_ch8.ads create mode 100644 gcc/ada/sem_ch9.adb create mode 100644 gcc/ada/sem_ch9.ads create mode 100644 gcc/ada/sem_disp.adb create mode 100644 gcc/ada/sem_disp.ads create mode 100644 gcc/ada/sem_dist.adb create mode 100644 gcc/ada/sem_dist.ads create mode 100644 gcc/ada/sem_elab.adb create mode 100644 gcc/ada/sem_elab.ads create mode 100644 gcc/ada/sem_elim.adb create mode 100644 gcc/ada/sem_elim.ads create mode 100644 gcc/ada/sem_eval.adb create mode 100644 gcc/ada/sem_eval.ads create mode 100644 gcc/ada/sem_intr.adb create mode 100644 gcc/ada/sem_intr.ads create mode 100644 gcc/ada/sem_mech.adb create mode 100644 gcc/ada/sem_mech.ads create mode 100644 gcc/ada/sem_prag.adb create mode 100644 gcc/ada/sem_prag.ads create mode 100644 gcc/ada/sem_res.adb create mode 100644 gcc/ada/sem_res.ads create mode 100644 gcc/ada/sem_scil.adb create mode 100644 gcc/ada/sem_scil.ads create mode 100644 gcc/ada/sem_smem.adb create mode 100644 gcc/ada/sem_smem.ads create mode 100644 gcc/ada/sem_type.adb create mode 100644 gcc/ada/sem_type.ads create mode 100644 gcc/ada/sem_util.adb create mode 100644 gcc/ada/sem_util.ads create mode 100644 gcc/ada/sem_vfpt.adb create mode 100644 gcc/ada/sem_vfpt.ads create mode 100644 gcc/ada/sem_warn.adb create mode 100644 gcc/ada/sem_warn.ads create mode 100644 gcc/ada/sequenio.ads create mode 100644 gcc/ada/sfn_scan.adb create mode 100644 gcc/ada/sfn_scan.ads create mode 100644 gcc/ada/sinfo-cn.adb create mode 100644 gcc/ada/sinfo-cn.ads create mode 100644 gcc/ada/sinfo.adb create mode 100644 gcc/ada/sinfo.ads create mode 100644 gcc/ada/sinput-c.adb create mode 100644 gcc/ada/sinput-c.ads create mode 100644 gcc/ada/sinput-d.adb create mode 100644 gcc/ada/sinput-d.ads create mode 100644 gcc/ada/sinput-l.adb create mode 100644 gcc/ada/sinput-l.ads create mode 100644 gcc/ada/sinput-p.adb create mode 100644 gcc/ada/sinput-p.ads create mode 100644 gcc/ada/sinput.adb create mode 100644 gcc/ada/sinput.ads create mode 100644 gcc/ada/snames.adb-tmpl create mode 100644 gcc/ada/snames.ads-tmpl create mode 100644 gcc/ada/snames.h-tmpl create mode 100644 gcc/ada/socket.c create mode 100644 gcc/ada/sprint.adb create mode 100644 gcc/ada/sprint.ads create mode 100644 gcc/ada/stand.adb create mode 100644 gcc/ada/stand.ads create mode 100644 gcc/ada/stringt.adb create mode 100644 gcc/ada/stringt.ads create mode 100644 gcc/ada/stringt.h create mode 100644 gcc/ada/style.adb create mode 100644 gcc/ada/style.ads create mode 100644 gcc/ada/styleg.adb create mode 100644 gcc/ada/styleg.ads create mode 100644 gcc/ada/stylesw.adb create mode 100644 gcc/ada/stylesw.ads create mode 100644 gcc/ada/switch-b.adb create mode 100644 gcc/ada/switch-b.ads create mode 100644 gcc/ada/switch-c.adb create mode 100644 gcc/ada/switch-c.ads create mode 100644 gcc/ada/switch-m.adb create mode 100644 gcc/ada/switch-m.ads create mode 100644 gcc/ada/switch.adb create mode 100644 gcc/ada/switch.ads create mode 100644 gcc/ada/symbols-processing-vms-alpha.adb create mode 100644 gcc/ada/symbols-processing-vms-ia64.adb create mode 100644 gcc/ada/symbols-vms.adb create mode 100644 gcc/ada/symbols.adb create mode 100644 gcc/ada/symbols.ads create mode 100644 gcc/ada/sysdep.c create mode 100644 gcc/ada/system-aix.ads create mode 100644 gcc/ada/system-aix64.ads create mode 100644 gcc/ada/system-darwin-ppc.ads create mode 100644 gcc/ada/system-darwin-ppc64.ads create mode 100644 gcc/ada/system-darwin-x86.ads create mode 100644 gcc/ada/system-darwin-x86_64.ads create mode 100644 gcc/ada/system-freebsd-x86.ads create mode 100644 gcc/ada/system-freebsd-x86_64.ads create mode 100644 gcc/ada/system-hpux-ia64.ads create mode 100644 gcc/ada/system-hpux.ads create mode 100644 gcc/ada/system-irix-n32.ads create mode 100644 gcc/ada/system-irix-n64.ads create mode 100644 gcc/ada/system-irix-o32.ads create mode 100644 gcc/ada/system-linux-alpha.ads create mode 100644 gcc/ada/system-linux-armeb.ads create mode 100644 gcc/ada/system-linux-armel.ads create mode 100644 gcc/ada/system-linux-hppa.ads create mode 100644 gcc/ada/system-linux-ia64.ads create mode 100644 gcc/ada/system-linux-mips.ads create mode 100644 gcc/ada/system-linux-mips64el.ads create mode 100644 gcc/ada/system-linux-mipsel.ads create mode 100644 gcc/ada/system-linux-ppc.ads create mode 100644 gcc/ada/system-linux-ppc64.ads create mode 100644 gcc/ada/system-linux-s390.ads create mode 100644 gcc/ada/system-linux-s390x.ads create mode 100644 gcc/ada/system-linux-sh4.ads create mode 100644 gcc/ada/system-linux-sparc.ads create mode 100644 gcc/ada/system-linux-sparcv9.ads create mode 100644 gcc/ada/system-linux-x86.ads create mode 100644 gcc/ada/system-linux-x86_64.ads create mode 100644 gcc/ada/system-lynxos-ppc.ads create mode 100644 gcc/ada/system-lynxos-x86.ads create mode 100644 gcc/ada/system-mingw-x86_64.ads create mode 100644 gcc/ada/system-mingw.ads create mode 100644 gcc/ada/system-rtems.ads create mode 100644 gcc/ada/system-solaris-sparc.ads create mode 100644 gcc/ada/system-solaris-sparcv9.ads create mode 100644 gcc/ada/system-solaris-x86.ads create mode 100644 gcc/ada/system-solaris-x86_64.ads create mode 100644 gcc/ada/system-tru64.ads create mode 100644 gcc/ada/system-vms-ia64.ads create mode 100644 gcc/ada/system-vms_64.ads create mode 100644 gcc/ada/system-vxworks-arm.ads create mode 100644 gcc/ada/system-vxworks-m68k.ads create mode 100644 gcc/ada/system-vxworks-mips.ads create mode 100644 gcc/ada/system-vxworks-ppc.ads create mode 100644 gcc/ada/system-vxworks-sparcv9.ads create mode 100644 gcc/ada/system-vxworks-x86.ads create mode 100644 gcc/ada/system.ads create mode 100644 gcc/ada/table.adb create mode 100644 gcc/ada/table.ads create mode 100644 gcc/ada/targext.c create mode 100644 gcc/ada/targparm.adb create mode 100644 gcc/ada/targparm.ads create mode 100644 gcc/ada/tb-alvms.c create mode 100644 gcc/ada/tb-alvxw.c create mode 100644 gcc/ada/tb-gcc.c create mode 100644 gcc/ada/tb-ivms.c create mode 100644 gcc/ada/tbuild.adb create mode 100644 gcc/ada/tbuild.ads create mode 100644 gcc/ada/tempdir.adb create mode 100644 gcc/ada/tempdir.ads create mode 100644 gcc/ada/text_io.ads create mode 100644 gcc/ada/tracebak.c create mode 100644 gcc/ada/tree_gen.adb create mode 100644 gcc/ada/tree_gen.ads create mode 100644 gcc/ada/tree_in.adb create mode 100644 gcc/ada/tree_in.ads create mode 100644 gcc/ada/tree_io.adb create mode 100644 gcc/ada/tree_io.ads create mode 100644 gcc/ada/treepr.adb create mode 100644 gcc/ada/treepr.ads create mode 100644 gcc/ada/treeprs.adt create mode 100644 gcc/ada/ttypes.ads create mode 100644 gcc/ada/types.adb create mode 100644 gcc/ada/types.ads create mode 100644 gcc/ada/types.h create mode 100644 gcc/ada/ug_words create mode 100644 gcc/ada/uintp.adb create mode 100644 gcc/ada/uintp.ads create mode 100644 gcc/ada/uintp.h create mode 100644 gcc/ada/uname.adb create mode 100644 gcc/ada/uname.ads create mode 100644 gcc/ada/unchconv.ads create mode 100644 gcc/ada/unchdeal.ads create mode 100644 gcc/ada/urealp.adb create mode 100644 gcc/ada/urealp.ads create mode 100644 gcc/ada/urealp.h create mode 100644 gcc/ada/usage.adb create mode 100644 gcc/ada/usage.ads create mode 100644 gcc/ada/validsw.adb create mode 100644 gcc/ada/validsw.ads create mode 100644 gcc/ada/vms_cmds.ads create mode 100644 gcc/ada/vms_conv.adb create mode 100644 gcc/ada/vms_conv.ads create mode 100644 gcc/ada/vms_data.ads create mode 100644 gcc/ada/vx_stack_info.c create mode 100644 gcc/ada/vxaddr2line.adb create mode 100644 gcc/ada/widechar.adb create mode 100644 gcc/ada/widechar.ads create mode 100644 gcc/ada/xeinfo.adb create mode 100644 gcc/ada/xgnatugn.adb create mode 100644 gcc/ada/xnmake.adb create mode 100644 gcc/ada/xoscons.adb create mode 100644 gcc/ada/xr_tabls.adb create mode 100644 gcc/ada/xr_tabls.ads create mode 100644 gcc/ada/xref_lib.adb create mode 100644 gcc/ada/xref_lib.ads create mode 100644 gcc/ada/xsinfo.adb create mode 100644 gcc/ada/xsnamest.adb create mode 100644 gcc/ada/xtreeprs.adb create mode 100644 gcc/ada/xutil.adb create mode 100644 gcc/ada/xutil.ads (limited to 'gcc/ada') diff --git a/gcc/ada/9drpc.adb b/gcc/ada/9drpc.adb new file mode 100644 index 000000000..787f0b020 --- /dev/null +++ b/gcc/ada/9drpc.adb @@ -0,0 +1,1051 @@ +------------------------------------------------------------------------------ +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Version for ??? + +with Unchecked_Deallocation; +with Ada.Streams; + +with System.RPC.Net_Trace; +with System.RPC.Garlic; +with System.RPC.Streams; +pragma Elaborate (System.RPC.Garlic); + +package body System.RPC is + + -- ??? general note: the debugging calls are very heavy, especially + -- those that create exception handlers in every procedure. Do we + -- really still need all this stuff? + + use type Ada.Streams.Stream_Element_Count; + use type Ada.Streams.Stream_Element_Offset; + + use type Garlic.Protocol_Access; + use type Garlic.Lock_Method; + + Max_Of_Message_Id : constant := 127; + + subtype Message_Id_Type is + Integer range -Max_Of_Message_Id .. Max_Of_Message_Id; + -- A message id is either a request id or reply id. A message id is + -- provided with a message to a receiving stub which uses the opposite + -- as a reply id. A message id helps to retrieve to which task is + -- addressed a reply. When the environment task receives a message, the + -- message id is extracted : a positive message id stands for a call, a + -- negative message id stands for a reply. A null message id stands for + -- an asynchronous request. + + subtype Request_Id_Type is Message_Id_Type range 1 .. Max_Of_Message_Id; + -- When a message id is positive, it is a request + + type Message_Length_Per_Request is array (Request_Id_Type) + of Ada.Streams.Stream_Element_Count; + + Header_Size : Ada.Streams.Stream_Element_Count := + Streams.Get_Integer_Initial_Size + + Streams.Get_SEC_Initial_Size; + -- Initial size needed for frequently used header streams + + Stream_Error : exception; + -- Occurs when a read procedure is executed on an empty stream + -- or when a write procedure is executed on a full stream + + Partition_RPC_Receiver : RPC_Receiver; + -- Cache the RPC_Receiver passed by Establish_RPC_Receiver + + type Anonymous_Task_Node; + + type Anonymous_Task_Node_Access is access Anonymous_Task_Node; + -- Types we need to construct a singly linked list of anonymous tasks + -- This pool is maintained to avoid a task creation each time a RPC + -- occurs - to be cont'd + + task type Anonymous_Task_Type (Self : Anonymous_Task_Node_Access) is + + entry Start + (Message_Id : Message_Id_Type; + Partition : Partition_ID; + Params_Size : Ada.Streams.Stream_Element_Count; + Result_Size : Ada.Streams.Stream_Element_Count; + Protocol : Garlic.Protocol_Access); + -- This entry provides an anonymous task a remote call to perform. + -- This task calls for a Request id is provided to construct the + -- reply id by using -Request. Partition is used to send the reply + -- message. Params_Size is the size of the calling stub Params stream. + -- Then Protocol (used by the environment task previously) allows + -- extraction of the message following the header (The header is + -- extracted by the environment task) + -- Note: grammar in above is obscure??? needs cleanup + + end Anonymous_Task_Type; + + type Anonymous_Task_Access is access Anonymous_Task_Type; + + type Anonymous_Task_List is record + Head : Anonymous_Task_Node_Access; + Tail : Anonymous_Task_Node_Access; + end record; + + type Anonymous_Task_Node is record + Element : Anonymous_Task_Access; + Next : Anonymous_Task_Node_Access; + end record; + -- Types we need to construct a singly linked list of anonymous tasks. + -- This pool is maintained to avoid a task creation each time a RPC occurs. + + protected Garbage_Collector is + + procedure Allocate + (Item : out Anonymous_Task_Node_Access); + -- Anonymous task pool management : if there is an anonymous task + -- left, use it. Otherwise, allocate a new one + + procedure Deallocate + (Item : in out Anonymous_Task_Node_Access); + -- Anonymous task pool management : queue this task in the pool + -- of inactive anonymous tasks. + + private + + Anonymous_List : Anonymous_Task_Node_Access; + -- The list root of inactive anonymous tasks + + end Garbage_Collector; + + task Dispatcher is + + entry New_Request (Request : out Request_Id_Type); + -- To get a new request + + entry Wait_On (Request_Id_Type) + (Length : out Ada.Streams.Stream_Element_Count); + -- To block the calling stub when it waits for a reply + -- When it is resumed, we provide the size of the reply + + entry Wake_Up + (Request : Request_Id_Type; + Length : Ada.Streams.Stream_Element_Count); + -- To wake up the calling stub when the environment task has + -- received a reply for this request + + end Dispatcher; + + task Environnement is + + entry Start; + -- Receive no message until Partition_Receiver is set + -- Establish_RPC_Receiver decides when the environment task + -- is allowed to start + + end Environnement; + + protected Partition_Receiver is + + entry Is_Set; + -- Blocks if the Partition_RPC_Receiver has not been set + + procedure Set; + -- Done by Establish_RPC_Receiver when Partition_RPC_Receiver + -- is known + + private + + Was_Set : Boolean := False; + -- True when Partition_RPC_Receiver has been set + + end Partition_Receiver; + -- Anonymous tasks have to wait for the Partition_RPC_Receiver + -- to be established + + type Debug_Level is + (D_Elaborate, -- About the elaboration of this package + D_Communication, -- About calls to Send and Receive + D_Debug, -- Verbose + D_Exception); -- Exception handler + -- Debugging levels + + package Debugging is new System.RPC.Net_Trace (Debug_Level, "RPC : "); + -- Debugging package + + procedure D + (Flag : Debug_Level; Info : String) renames Debugging.Debug; + -- Shortcut + + ------------------------ + -- Partition_Receiver -- + ------------------------ + + protected body Partition_Receiver is + + ------------------------------- + -- Partition_Receiver.Is_Set -- + ------------------------------- + + entry Is_Set when Was_Set is + begin + null; + end Is_Set; + + ---------------------------- + -- Partition_Receiver.Set -- + ---------------------------- + + procedure Set is + begin + Was_Set := True; + end Set; + + end Partition_Receiver; + + --------------- + -- Head_Node -- + --------------- + + procedure Head_Node + (Index : out Packet_Node_Access; + Stream : Params_Stream_Type) + is + begin + Index := Stream.Extra.Head; + + exception + when others => + D (D_Exception, "exception in Head_Node"); + raise; + end Head_Node; + + --------------- + -- Tail_Node -- + --------------- + + procedure Tail_Node + (Index : out Packet_Node_Access; + Stream : Params_Stream_Type) + is + begin + Index := Stream.Extra.Tail; + + exception + when others => + D (D_Exception, "exception in Tail_Node"); + raise; + end Tail_Node; + + --------------- + -- Null_Node -- + --------------- + + function Null_Node (Index : Packet_Node_Access) return Boolean is + begin + return Index = null; + + exception + when others => + D (D_Exception, "exception in Null_Node"); + raise; + end Null_Node; + + ---------------------- + -- Delete_Head_Node -- + ---------------------- + + procedure Delete_Head_Node (Stream : in out Params_Stream_Type) is + + procedure Free is + new Unchecked_Deallocation + (Packet_Node, Packet_Node_Access); + + Next_Node : Packet_Node_Access := Stream.Extra.Head.Next; + + begin + -- Delete head node and free memory usage + + Free (Stream.Extra.Head); + Stream.Extra.Head := Next_Node; + + -- If the extra storage is empty, update tail as well + + if Stream.Extra.Head = null then + Stream.Extra.Tail := null; + end if; + + exception + when others => + D (D_Exception, "exception in Delete_Head_Node"); + raise; + end Delete_Head_Node; + + --------------- + -- Next_Node -- + --------------- + + procedure Next_Node (Node : in out Packet_Node_Access) is + begin + -- Node is set to the next node + -- If not possible, Stream_Error is raised + + if Node = null then + raise Stream_Error; + else + Node := Node.Next; + end if; + + exception + when others => + D (D_Exception, "exception in Next_Node"); + raise; + end Next_Node; + + --------------------- + -- Append_New_Node -- + --------------------- + + procedure Append_New_Node (Stream : in out Params_Stream_Type) is + Index : Packet_Node_Access; + + begin + -- Set Index to the end of the linked list + + Tail_Node (Index, Stream); + + if Null_Node (Index) then + + -- The list is empty : set head as well + + Stream.Extra.Head := new Packet_Node; + Stream.Extra.Tail := Stream.Extra.Head; + + else + -- The list is not empty : link new node with tail + + Stream.Extra.Tail.Next := new Packet_Node; + Stream.Extra.Tail := Stream.Extra.Tail.Next; + + end if; + + exception + when others => + D (D_Exception, "exception in Append_New_Node"); + raise; + end Append_New_Node; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : in out Params_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + renames System.RPC.Streams.Read; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : in out Params_Stream_Type; + Item : Ada.Streams.Stream_Element_Array) + renames System.RPC.Streams.Write; + + ----------------------- + -- Garbage_Collector -- + ----------------------- + + protected body Garbage_Collector is + + -------------------------------- + -- Garbage_Collector.Allocate -- + -------------------------------- + + procedure Allocate (Item : out Anonymous_Task_Node_Access) is + New_Anonymous_Task_Node : Anonymous_Task_Node_Access; + Anonymous_Task : Anonymous_Task_Access; + + begin + -- If the list is empty, allocate a new anonymous task + -- Otherwise, reuse the first queued anonymous task + + if Anonymous_List = null then + + -- Create a new anonymous task + -- Provide this new task with its id to allow it + -- to enqueue itself into the free anonymous task list + -- with the function Deallocate + + New_Anonymous_Task_Node := new Anonymous_Task_Node; + Anonymous_Task := + new Anonymous_Task_Type (New_Anonymous_Task_Node); + New_Anonymous_Task_Node.all := (Anonymous_Task, null); + + else + -- Extract one task from the list + -- Set the Next field to null to avoid possible bugs + + New_Anonymous_Task_Node := Anonymous_List; + Anonymous_List := Anonymous_List.Next; + New_Anonymous_Task_Node.Next := null; + + end if; + + -- Item is an out parameter + + Item := New_Anonymous_Task_Node; + + exception + when others => + D (D_Exception, "exception in Allocate (Anonymous Task)"); + raise; + end Allocate; + + ---------------------------------- + -- Garbage_Collector.Deallocate -- + ---------------------------------- + + procedure Deallocate (Item : in out Anonymous_Task_Node_Access) is + begin + -- Enqueue the task in the free list + + Item.Next := Anonymous_List; + Anonymous_List := Item; + + exception + when others => + D (D_Exception, "exception in Deallocate (Anonymous Task)"); + raise; + end Deallocate; + + end Garbage_Collector; + + ------------ + -- Do_RPC -- + ------------ + + procedure Do_RPC + (Partition : Partition_ID; + Params : access Params_Stream_Type; + Result : access Params_Stream_Type) + is + Protocol : Protocol_Access; + Request : Request_Id_Type; + Header : aliased Params_Stream_Type (Header_Size); + R_Length : Ada.Streams.Stream_Element_Count; + + begin + -- Parameters order : + -- Opcode (provided and used by garlic) + -- (1) Size (provided by s-rpc and used by garlic) + -- (size of (2)+(3)+(4)+(5)) + -- (2) Request (provided by calling stub (resp receiving stub) and + -- used by anonymous task (resp Do_RPC)) + -- *** ZERO IF APC *** + -- (3) Res.len. (provided by calling stubs and used by anonymous task) + -- *** ZERO IF APC *** + -- (4) Receiver (provided by calling stubs and used by anonymous task) + -- (5) Params (provided by calling stubs and used by anonymous task) + + -- The call is a remote call or a local call. A local call occurs + -- when the pragma All_Calls_Remote has been specified. Do_RPC is + -- called and the execution has to be performed in the PCS + + if Partition /= Garlic.Get_My_Partition_ID then + + -- Get a request id to be resumed when the reply arrives + + Dispatcher.New_Request (Request); + + -- Build header = request (2) + result.initial_size (3) + + D (D_Debug, "Do_RPC - Build header"); + Streams.Allocate (Header); + Streams.Integer_Write_Attribute -- (2) + (Header'Access, Request); + System.RPC.Streams.SEC_Write_Attribute -- (3) + (Header'Access, Result.Initial_Size); + + -- Get a protocol method to communicate with the remote partition + -- and give the message size + + D (D_Communication, + "Do_RPC - Lookup for protocol to talk to partition" & + Partition_ID'Image (Partition)); + Garlic.Initiate_Send + (Partition, + Streams.Get_Stream_Size (Header'Access) + + Streams.Get_Stream_Size (Params), -- (1) + Protocol, + Garlic.Remote_Call); + + -- Send the header by using the protocol method + + D (D_Communication, "Do_RPC - Send Header to partition" & + Partition_ID'Image (Partition)); + Garlic.Send + (Protocol.all, + Partition, + Header'Access); -- (2) + (3) + + -- The header is deallocated + + Streams.Deallocate (Header); + + -- Send Params from Do_RPC + + D (D_Communication, "Do_RPC - Send Params to partition" & + Partition_ID'Image (Partition)); + Garlic.Send + (Protocol.all, + Partition, + Params); -- (4) + (5) + + -- Let Garlic know we have nothing else to send + + Garlic.Complete_Send + (Protocol.all, + Partition); + D (D_Debug, "Do_RPC - Suspend"); + + -- Wait for a reply and get the reply message length + + Dispatcher.Wait_On (Request) (R_Length); + D (D_Debug, "Do_RPC - Resume"); + + declare + New_Result : aliased Params_Stream_Type (R_Length); + begin + -- Adjust the Result stream size right now to be able to load + -- the stream in one receive call. Create a temporary result + -- that will be substituted to Do_RPC one + + Streams.Allocate (New_Result); + + -- Receive the reply message from receiving stub + + D (D_Communication, "Do_RPC - Receive Result from partition" & + Partition_ID'Image (Partition)); + Garlic.Receive + (Protocol.all, + Partition, + New_Result'Access); + + -- Let Garlic know we have nothing else to receive + + Garlic.Complete_Receive + (Protocol.all, + Partition); + + -- Update calling stub Result stream + + D (D_Debug, "Do_RPC - Reconstruct Result"); + Streams.Deallocate (Result.all); + Result.Initial := New_Result.Initial; + Streams.Dump ("|||", Result.all); + + end; + + else + -- Do RPC locally and first wait for Partition_RPC_Receiver to be + -- set + + Partition_Receiver.Is_Set; + D (D_Debug, "Do_RPC - Locally"); + Partition_RPC_Receiver.all (Params, Result); + + end if; + + exception + when others => + D (D_Exception, "exception in Do_RPC"); + raise; + end Do_RPC; + + ------------ + -- Do_APC -- + ------------ + + procedure Do_APC + (Partition : Partition_ID; + Params : access Params_Stream_Type) + is + Message_Id : Message_Id_Type := 0; + Protocol : Protocol_Access; + Header : aliased Params_Stream_Type (Header_Size); + + begin + -- For more informations, see above + -- Request = 0 as we are not waiting for a reply message + -- Result length = 0 as we don't expect a result at all + + if Partition /= Garlic.Get_My_Partition_ID then + + -- Build header = request (2) + result.initial_size (3) + -- As we have an APC, the request id is null to indicate + -- to the receiving stub that we do not expect a reply + -- This comes from 0 = -0 + + D (D_Debug, "Do_APC - Build Header"); + Streams.Allocate (Header); + Streams.Integer_Write_Attribute + (Header'Access, Integer (Message_Id)); + Streams.SEC_Write_Attribute + (Header'Access, 0); + + -- Get a protocol method to communicate with the remote partition + -- and give the message size + + D (D_Communication, + "Do_APC - Lookup for protocol to talk to partition" & + Partition_ID'Image (Partition)); + Garlic.Initiate_Send + (Partition, + Streams.Get_Stream_Size (Header'Access) + + Streams.Get_Stream_Size (Params), + Protocol, + Garlic.Remote_Call); + + -- Send the header by using the protocol method + + D (D_Communication, "Do_APC - Send Header to partition" & + Partition_ID'Image (Partition)); + Garlic.Send + (Protocol.all, + Partition, + Header'Access); + + -- The header is deallocated + + Streams.Deallocate (Header); + + -- Send Params from Do_APC + + D (D_Communication, "Do_APC - Send Params to partition" & + Partition_ID'Image (Partition)); + Garlic.Send + (Protocol.all, + Partition, + Params); + + -- Let Garlic know we have nothing else to send + + Garlic.Complete_Send + (Protocol.all, + Partition); + else + + declare + Result : aliased Params_Stream_Type (0); + begin + -- Result is here a dummy parameter + -- No reason to deallocate as it is not allocated at all + + Partition_Receiver.Is_Set; + D (D_Debug, "Do_APC - Locally"); + Partition_RPC_Receiver.all (Params, Result'Access); + + end; + + end if; + + exception + when others => + D (D_Exception, "exception in Do_APC"); + raise; + end Do_APC; + + ---------------------------- + -- Establish_RPC_Receiver -- + ---------------------------- + + procedure Establish_RPC_Receiver + (Partition : Partition_ID; + Receiver : RPC_Receiver) + is + begin + -- Set Partition_RPC_Receiver and allow RPC mechanism + + Partition_RPC_Receiver := Receiver; + Partition_Receiver.Set; + D (D_Elaborate, "Partition_Receiver is set"); + + exception + when others => + D (D_Exception, "exception in Establish_RPC_Receiver"); + raise; + end Establish_RPC_Receiver; + + ---------------- + -- Dispatcher -- + ---------------- + + task body Dispatcher is + Last_Request : Request_Id_Type := Request_Id_Type'First; + Current_Rqst : Request_Id_Type := Request_Id_Type'First; + Current_Size : Ada.Streams.Stream_Element_Count; + + begin + loop + -- Three services: + + -- New_Request to get an entry in Dispatcher table + + -- Wait_On for Do_RPC calls + + -- Wake_Up called by environment task when a Do_RPC receives + -- the result of its remote call + + select + accept New_Request (Request : out Request_Id_Type) do + Request := Last_Request; + + -- << TODO >> + -- ??? Availability check + + if Last_Request = Request_Id_Type'Last then + Last_Request := Request_Id_Type'First; + else + Last_Request := Last_Request + 1; + end if; + + end New_Request; + + or + accept Wake_Up + (Request : Request_Id_Type; + Length : Ada.Streams.Stream_Element_Count) + do + -- The environment reads the header and has been notified + -- of the reply id and the size of the result message + + Current_Rqst := Request; + Current_Size := Length; + + end Wake_Up; + + -- << TODO >> + -- ??? Must be select with delay for aborted tasks + + select + + accept Wait_On (Current_Rqst) + (Length : out Ada.Streams.Stream_Element_Count) + do + Length := Current_Size; + end Wait_On; + + or + -- To free the Dispatcher when a task is aborted + + delay 1.0; + + end select; + + or + terminate; + end select; + + end loop; + + exception + when others => + D (D_Exception, "exception in Dispatcher body"); + raise; + end Dispatcher; + + ------------------------- + -- Anonymous_Task_Type -- + ------------------------- + + task body Anonymous_Task_Type is + Whoami : Anonymous_Task_Node_Access := Self; + C_Message_Id : Message_Id_Type; -- Current Message Id + C_Partition : Partition_ID; -- Current Partition + Params_S : Ada.Streams.Stream_Element_Count; -- Params message size + Result_S : Ada.Streams.Stream_Element_Count; -- Result message size + C_Protocol : Protocol_Access; -- Current Protocol + + begin + loop + -- Get a new RPC to execute + + select + accept Start + (Message_Id : Message_Id_Type; + Partition : Partition_ID; + Params_Size : Ada.Streams.Stream_Element_Count; + Result_Size : Ada.Streams.Stream_Element_Count; + Protocol : Protocol_Access) + do + C_Message_Id := Message_Id; + C_Partition := Partition; + Params_S := Params_Size; + Result_S := Result_Size; + C_Protocol := Protocol; + end Start; + or + terminate; + end select; + + declare + Params : aliased Params_Stream_Type (Params_S); + Result : aliased Params_Stream_Type (Result_S); + Header : aliased Params_Stream_Type (Header_Size); + + begin + -- We reconstruct all the client context : Params and Result + -- with the SAME size, then we receive Params from calling stub + + D (D_Communication, + "Anonymous Task - Receive Params from partition" & + Partition_ID'Image (C_Partition)); + Garlic.Receive + (C_Protocol.all, + C_Partition, + Params'Access); + + -- Let Garlic know we don't receive anymore + + Garlic.Complete_Receive + (C_Protocol.all, + C_Partition); + + -- Check that Partition_RPC_Receiver has been set + + Partition_Receiver.Is_Set; + + -- Do it locally + + D (D_Debug, + "Anonymous Task - Perform Partition_RPC_Receiver for request" & + Message_Id_Type'Image (C_Message_Id)); + Partition_RPC_Receiver (Params'Access, Result'Access); + + -- If this was a RPC we send the result back + -- Otherwise, do nothing else than deallocation + + if C_Message_Id /= 0 then + + -- Build Header = -C_Message_Id + Result Size + -- Provide the request id to the env task of the calling + -- stub partition We get the real result stream size : the + -- calling stub (in Do_RPC) updates its size to this one + + D (D_Debug, "Anonymous Task - Build Header"); + Streams.Allocate (Header); + Streams.Integer_Write_Attribute + (Header'Access, Integer (-C_Message_Id)); + Streams.SEC_Write_Attribute + (Header'Access, + Streams.Get_Stream_Size (Result'Access)); + + -- Get a protocol method to communicate with the remote + -- partition and give the message size + + D (D_Communication, + "Anonymous Task - Lookup for protocol talk to partition" & + Partition_ID'Image (C_Partition)); + Garlic.Initiate_Send + (C_Partition, + Streams.Get_Stream_Size (Header'Access) + + Streams.Get_Stream_Size (Result'Access), + C_Protocol, + Garlic.Remote_Call); + + -- Send the header by using the protocol method + + D (D_Communication, + "Anonymous Task - Send Header to partition" & + Partition_ID'Image (C_Partition)); + Garlic.Send + (C_Protocol.all, + C_Partition, + Header'Access); + + -- Send Result toDo_RPC + + D (D_Communication, + "Anonymous Task - Send Result to partition" & + Partition_ID'Image (C_Partition)); + Garlic.Send + (C_Protocol.all, + C_Partition, + Result'Access); + + -- Let Garlic know we don't send anymore + + Garlic.Complete_Send + (C_Protocol.all, + C_Partition); + Streams.Deallocate (Header); + end if; + + Streams.Deallocate (Params); + Streams.Deallocate (Result); + end; + + -- Enqueue into the anonymous task free list : become inactive + + Garbage_Collector.Deallocate (Whoami); + + end loop; + + exception + when others => + D (D_Exception, "exception in Anonymous_Task_Type body"); + raise; + end Anonymous_Task_Type; + + ----------------- + -- Environment -- + ----------------- + + task body Environnement is + Partition : Partition_ID; + Message_Size : Ada.Streams.Stream_Element_Count; + Result_Size : Ada.Streams.Stream_Element_Count; + Message_Id : Message_Id_Type; + Header : aliased Params_Stream_Type (Header_Size); + Protocol : Protocol_Access; + Anonymous : Anonymous_Task_Node_Access; + + begin + -- Wait the Partition_RPC_Receiver to be set + + accept Start; + D (D_Elaborate, "Environment task elaborated"); + + loop + -- We receive first a fixed size message : the header + -- Header = Message Id + Message Size + + Streams.Allocate (Header); + + -- Garlic provides the size of the received message and the + -- protocol to use to communicate with the calling partition + + Garlic.Initiate_Receive + (Partition, + Message_Size, + Protocol, + Garlic.Remote_Call); + D (D_Communication, + "Environment task - Receive protocol to talk to active partition" & + Partition_ID'Image (Partition)); + + -- Extract the header to route the message either to + -- an anonymous task (Message Id > 0 <=> Request Id) + -- or to a waiting task (Message Id < 0 <=> Reply Id) + + D (D_Communication, + "Environment task - Receive Header from partition" & + Partition_ID'Image (Partition)); + Garlic.Receive + (Protocol.all, + Partition, + Header'Access); + + -- Evaluate the remaining size of the message + + Message_Size := Message_Size - + Streams.Get_Stream_Size (Header'Access); + + -- Extract from header : message id and message size + + Streams.Integer_Read_Attribute (Header'Access, Message_Id); + Streams.SEC_Read_Attribute (Header'Access, Result_Size); + + if Streams.Get_Stream_Size (Header'Access) /= 0 then + + -- If there are stream elements left in the header ??? + + D (D_Exception, "Header is not empty"); + raise Program_Error; + + end if; + + if Message_Id < 0 then + + -- The message was sent by a receiving stub : wake up the + -- calling task - We have a reply there + + D (D_Debug, "Environment Task - Receive Reply from partition" & + Partition_ID'Image (Partition)); + Dispatcher.Wake_Up (-Message_Id, Result_Size); + + else + -- The message was send by a calling stub : get an anonymous + -- task to perform the job + + D (D_Debug, "Environment Task - Receive Request from partition" & + Partition_ID'Image (Partition)); + Garbage_Collector.Allocate (Anonymous); + + -- We subtracted the size of the header from the size of the + -- global message in order to provide immediately Params size + + Anonymous.Element.Start + (Message_Id, + Partition, + Message_Size, + Result_Size, + Protocol); + + end if; + + -- Deallocate header : unnecessary - WARNING + + Streams.Deallocate (Header); + + end loop; + + exception + when others => + D (D_Exception, "exception in Environment"); + raise; + end Environnement; + +begin + -- Set debugging information + + Debugging.Set_Environment_Variable ("RPC"); + Debugging.Set_Debugging_Name ("D", D_Debug); + Debugging.Set_Debugging_Name ("E", D_Exception); + Debugging.Set_Debugging_Name ("C", D_Communication); + Debugging.Set_Debugging_Name ("Z", D_Elaborate); + D (D_Elaborate, "To be elaborated"); + + -- When this body is elaborated we should ensure that RCI name server + -- has been already elaborated : this means that Establish_RPC_Receiver + -- has already been called and that Partition_RPC_Receiver is set + + Environnement.Start; + D (D_Elaborate, "ELABORATED"); + +end System.RPC; diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog new file mode 100644 index 000000000..dd9f70710 --- /dev/null +++ b/gcc/ada/ChangeLog @@ -0,0 +1,260 @@ +2013-04-12 Release Manager + + * GCC 4.6.4 released. + +2013-02-21 Jakub Jelinek + + PR bootstrap/56258 + * gnat-style.texi (@title): Remove @hfill. + * projects.texi: Avoid line wrapping inside of @pxref or + @xref. + +2013-02-07 Simon Wright + + PR target/50678 + * init.c (__darwin_major_version): New function for x86-64/Darwin. + (__gnat_adjust_context_for_raise) [Darwin]: Disable the workaround + on Darwin 12 and above. + +2012-12-16 Eric Botcazou + + PR ada/54614 + Backport from mainline + + 2012-10-01 Vincent Pucci + + * s-gearop.adb (Vector_Matrix_Product): Fix dimension check and index + of Left in S evaluation. + +2012-05-26 Eric Botcazou + + * gcc-interface/decl.c (variant_desc): Rename 'record' to 'new_type'. + (build_variant_list): Adjust to above renaming. + (gnat_to_gnu_entity) : Likewise. Give a unique name + to the type of the variant containers. + (create_variant_part_from): Likewise. Give a unique name to the type + of the variant part. + +2012-03-01 Release Manager + + * GCC 4.6.3 released. + +2012-01-21 Eric Botcazou + + PR ada/46192 + * gcc-interface/decl.c (gnat_to_gnu_entity) : In the case of a + renaming, preserve the volatileness through the indirection, if any. + +2012-01-09 Eric Botcazou + + * gcc-interface/trans.c (addressable_p) : Fix thinko. + +2012-01-02 Eric Botcazou + + * gnatvsn.ads (Current_Year): Bump to 2011. + +2011-12-08 Eric Botcazou + + PR tree-optimization/51315 + Backport from mainline + 2011-09-25 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Do not promote + the alignment if this doesn't prevent BLKmode access to the object. + +2011-11-13 Iain Sandoe + + Backport from mainline r181474 + PR target/50678 + * init.c (__gnat_error_handler) [Darwin]: Move work-around to the + bug filed as radar #10302855 from __gnat_error_handler ... + ... to (__gnat_adjust_context_for_raise) [Darwin]: New. + (HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE) [Darwin]: Define. + (__gnat_error_handler) [Darwin]: Use __gnat_adjust_context_for_raise. + +2011-11-18 Tristan Gingold + Iain Sandoe + + PR target/49992 + * mlib-tgt-specific-darwin.adb (Archive_Indexer_Options): Remove. + * gcc-interface/Makefile.in (darwin): Remove ranlib special-casing + for Darwin. + +2011-11-13 Iain Sandoe + + Backport from mainline r181319 + * gcc-interface/Makefile.in (stamp-gnatlib-$(RTSDIR)): Don't link + s-oscons.ads. + (OSCONS_CPP, OSCONS_EXTRACT): New. + (./bldtools/oscons/xoscons): New Target. + ($(RTSDIR)/s-oscons.ads): New Target. + (gnatlib): Depend on $(RTSDIR)/s-oscons.ads. + * Make-generated.in: Remove machinery to generate xoscons and + ada/s-oscons.ads. + +2011-10-26 Release Manager + + * GCC 4.6.2 released. + +2011-09-19 Iain Sandoe + + Backport from mainline (restore powerpc-darwin Ada bootstrap). + * traceback.c (Darwin) USE_GCC_UNWINDER for Darwin versions >= 8. + +2011-09-11 Eric Botcazou + + * gcc-interface/decl.c (maybe_pad_type): Do not try to change the form + of an addressable type. + * gcc-interface/trans.c (gnat_gimplify_expr) : New. + Deal with those cases for which creating a temporary is mandatory. + +2011-09-08 Iain Sandoe + + Backport from mainline (restore powerpc-darwin Ada bootstrap). + * gcc-interface/Makefile.in (darwin): Provide powerpc64 system + implementation. + * system-darwin-ppc64.ads: New file. + +2011-09-06 Iain Sandoe + + Backport from mainline. + * gcc-interface/Makefile.in (darwin, SO_OPTS): Provide architecture + size switches to the link phase for shared libs. + +2011-07-23 Eric Botcazou + + Backport from mainline + 2011-07-23 Arnaud Charlet + + PR ada/49819 + * gcc-interface/Makefile.in (powerpc-linux): Remove reference to + g-trasym-dwarf.adb. + +2011-07-15 Eric Botcazou + + PR ada/48711 + * g-socthi-mingw.adb (Fill): Fix formatting. + +2011-07-14 John David Anglin + + PR ada/46350 + * s-taprop-hpux-dce.adb (Abort_Task): Remove unnecessary cast. + +2011-07-14 Florian Weimer + + PR ada/48711 + * g-socthi-mingw.adb (Fill): Guard against invalid MSG_WAITALL. + +2011-07-01 Eric Botcazou + + * gcc-interface/Make-lang.in (gnat1): Prepend '+' to the command. + (gnatbind): Likewise. + +2011-06-27 Release Manager + + * GCC 4.6.1 released. + +2011-06-18 Eric Botcazou + + * gcc-interface/trans.c (Identifier_to_gnu): Don't set TREE_THIS_NOTRAP + on a dereference built for a by-ref object if it has an address clause. + +2011-05-05 Eric Botcazou + + PR ada/48844 + * gcc-interface/gigi.h (get_variant_part): Declare. + * gcc-interface/decl.c (get_variant_part): Make global. + * gcc-interface/utils2.c (find_common_type): Do not return T1 if the + types have the same constant size, are record types and T1 has a + variant part while T2 doesn't. + +2011-04-17 Eric Botcazou + + * gcc-interface/Make-lang.in (gnatbind): Replace $(ALL_CFLAGS) with + $(CFLAGS) on the link line. + +2011-03-25 Release Manager + + * GCC 4.6.0 released. + +2011-02-14 Eric Botcazou + + * gcc-interface/misc.c (gnat_init_options): Do not concatenate -I and + its argument, except for the special -I- switch. + +2011-02-12 Gerald Pfeifer + + * gnat_ugn.texi (Compiling Different Versions of Ada): Update + link to "Ada Issues". + +2011-02-08 Eric Botcazou + + * gcc-interface/Makefile.in (x86-64 darwin): Handle multilibs. + +2011-02-03 Eric Botcazou + + * gcc-interface/gigi.h (fill_vms_descriptor): Take GNU_TYPE instead of + GNAT_FORMAL. + * gcc-interface/utils2.c (fill_vms_descriptor): Move from here to... + * gcc-interface/utils.c (fill_vms_descriptor): ...here. Take GNU_TYPE + instead of GNAT_FORMAL. Protect the expression against multiple uses. + Do not generate the check directly, instead instantiate the template + check present in the descriptor. + (make_descriptor_field): Move around. + (build_vms_descriptor32): Build a template check in the POINTER field. + (build_vms_descriptor): Remove useless suffixes. + * gcc-interface/trans.c (call_to_gnu): Adjust fill_vms_descriptor call. + +2011-01-26 Eric Botcazou + + PR bootstrap/47467 + * targext.c: Include target files if IN_RTS is defined. + +2011-01-26 Richard Guenther + + PR bootstrap/47467 + * targext.c: Include config.h. + * gcc-interface/Make-lang.in (ada/targext.o): Add $(CONFIG_H) + dependency. + +2011-01-04 Pascal Obry + Eric Botcazou + + * gcc-interface/decl.c: Disable Stdcall convention handling for 64-bit. + +2011-01-04 Eric Botcazou + + * gcc-interface/trans.c (Case_Statement_to_gnu): Put the SLOC of the + end-of-case on the end label and its associated gotos, if any. + +2011-01-04 Eric Botcazou + + * gcc-interface/trans.c (Subprogram_Body_to_gnu): Evaluate the + expressions of the parameter cache within the statement group of + the CICO mechanism. + +2011-01-04 Olivier Hainque + Eric Botcazou + + * gcc-interface/trans.c (BLOCK_SOURCE_END_LOCATION): Provide default. + (set_end_locus_from_node): New function. + (Subprogram_Body_to_gnu): Use it to mark both the inner BIND_EXPR we + make and the function end_locus. + (Compilation_Unit_to_gnu): Call it instead of a straight Sloc_to_locus + for the elaboration subprogram. + (set_gnu_expr_location_from_node) : Use it to attempt to + set the end_locus of the expression as well. + +2011-01-04 Eric Botcazou + + PR ada/47131 + * gcc-interface/trans.c (Identifier_to_gnu): In SJLJ mode, do not make + variables that are referenced in exception handlers volatile. + + + +Copyright (C) 2011 Free Software Foundation, Inc. + +Copying and distribution of this file, with or without modification, +are permitted in any medium without royalty provided the copyright +notice and this notice are preserved. diff --git a/gcc/ada/ChangeLog-2001 b/gcc/ada/ChangeLog-2001 new file mode 100644 index 000000000..ffc40022b --- /dev/null +++ b/gcc/ada/ChangeLog-2001 @@ -0,0 +1,2239 @@ +2001-12-23 Richard Henderson + + * utils.c (end_subprog_body): Push GC context around + rest_of_compilation for nested functions. + +2001-12-23 Richard Henderson + + * 5nosinte.ads: Get definition of "int" from Interfaces.C. + +2001-12-23 Florian Weimer + + * gnat-style.texi (Declarations and Types): Remove ancient style + rule which was mandated by code generation issues. + + * gnat-style.texi (header): Add @dircategory, @direntry. + (title page): Remove date. + (general) Add @./@: where approriate, and two spaces after the + full stop at the end of a sentence. Use @samp markup when + referring concrete lexical entities (keywords, attribute names + etc.), and @syntax for ARM grammar elements. Use @r for English + text in comments. Use @emph for emphasis. Change "if-statements" + etc. to "if statements" (without @samp). Break long lines. Make + casing of section names consistent. + (Identifiers): Use @samp markup for variable names. + (Comments): Use @samp markup for comment characters. Line-end + comments may follow any Ada code, not just statements. Fix + misspelling of "Integer" as "integer". + (Loop statements): Do not use variable name "I", use "J". + (Subprogram Declarations): Document alignment. + (Subprogram Bodies, Block statements): Document empty line before + "begin". + +2001-12-22 Florian Weimer + + * make.adb (Add_Switch): Make Generic_Position a procedure. The + function approach did not work well because of a side effect (the + function call could reallocate the table which was being indexed + using its result). Fixes ada/4851. + +2001-12-19 Robert Dewar + + * bindgen.adb: Minor reformatting + + * cstand.adb: Minor reformatting + + * fmap.adb: Minor reformatting + Change name from Add for Add_To_File_Map (Add is much too generic) + Change Path_Name_Of to Mapped_Path_Name + Change File_Name_Of to Mapped_File_Name + Fix copyright dates in header + + * fmap.ads: + Change name from Add for Add_To_File_Map (Add is much too generic) + Change Path_Name_Of to Mapped_Path_Name + Change File_Name_Of to Mapped_File_Name + Fix copyright dates in header + + * fname-uf.adb: Minor reformatting. New names of stuff in Fmap. + Add use clause for Fmap. + + * make.adb: Minor reformatting + + * osint.adb: Minor reformatting. Change of names in Fmap. + Add use clause for Fmap. + + * prj-env.adb: Minor reformatting + + * prj-env.ads: Minor reformatting + + * switch.adb: Minor reformatting. Do proper raise of Bad_Switch if + error found (there were odd exceptions to this general rule in + -gnatec/-gnatem processing) + +2001-12-19 Olivier Hainque + + * raise.c (__gnat_eh_personality): Exception handling personality + routine for Ada. Still in rough state, inspired from the C++ version + and still containing a bunch of debugging artifacts. + (parse_lsda_header, get_ttype_entry): Local (static) helpers, also + inspired from the C++ library. + + * raise.c (eh_personality): Add comments. Part of work for the GCC 3 + exception handling integration. + +2001-12-19 Arnaud Charlet + + * Makefile.in: Remove use of 5smastop.adb which is obsolete. + (HIE_SOURCES): Add s-secsta.ad{s,b}. + (HIE_OBJS): Add s-fat*.o + (RAVEN_SOURCES): Remove files that are no longer required. Add + interrupt handling files. + (RAVEN_MOD): Removed, no longer needed. + +2001-12-19 Robert Dewar + + * a-ngelfu.adb: Remove ??? comment for inappropriate Inline_Always + Add 2001 to copyright date + + * g-regpat.adb: Change pragma Inline_Always to Inline. There is no + need to force universal inlining for these cases. + +2001-12-19 Arnaud Charlet + + * s-taprob.adb: Minor clean ups so that this unit can be used in + Ravenscar HI. + + * exp_ch7.adb: Allow use of secondary stack in HI mode. + Disallow it when pragma Restrictions (No_Secondary_Stack) is specified. + +2001-12-19 Vincent Celier + + * prj-tree.ads (Project_Node_Record): Add comments for components + Pkg_Id and Case_Insensitive. + +2001-12-19 Pascal Obry + + * g-socket.adb: Minor reformatting. Found while reading code. + +2001-12-19 Robert Dewar + + * prj-tree.ads: Minor reformatting + +2001-12-20 Joseph S. Myers + + * config-lang.in (diff_excludes): Remove. + +2001-12-17 Ed Schonberg + + * sem_res.adb (Resolve_Selected_Component): do not generate a + discriminant check if the selected component is a component of + the argument of an initialization procedure. + + * trans.c (tree_transform, case of arithmetic operators): If result + type is private, the gnu_type is the base type of the full view, + given that the full view itself may be a subtype. + +2001-12-17 Robert Dewar + + * sem_res.adb: Minor reformatting + + * trans.c (tree_transform, case N_Real_Literal): Add missing third + parameter in call to Machine (unknown horrible effects from this + omission). + + * urealp.h: Add definition of Round_Even for call to Machine + Add third parameter for Machine + +2001-12-17 Ed Schonberg + + * sem_warn.adb (Check_One_Unit): Suppress warnings completely on + predefined units in No_Run_Time mode. + +2001-12-17 Richard Kenner + + * misc.c (insn-codes.h): Now include. + +2001-12-17 Olivier Hainque + + * a-except.adb: Preparation work for future integration of the GCC 3 + exception handling mechanism + (Notify_Handled_Exception, Notify_Unhandled_Exception): New routines + to factorize previous code sequences and make them externally callable, + e.g. for the Ada personality routine when the GCC 3 mechanism is used. + (Propagate_Exception, Raise_Current_Excep, Raise_From_Signal_Handler): + Use the new notification routines. + +2001-12-17 Emmanuel Briot + + * prj-tree.ads (First_Choice_Of): Document the when others case + +2001-12-17 Arnaud Charlet + + * bindgen.adb (Gen_Ada_Init_*): Set priority of environment task in + HI-E mode, in order to support Ravenscar profile properly. + + * cstand.adb (Create_Standard): Duration is a 32 bit type in HI-E + mode on 32 bits targets. + +2001-12-17 Vincent Celier + + * fmap.adb: Initial version. + + * fmap.ads: Initial version. + + * fname-uf.adb (Get_File_Name): Use mapping if unit name mapped. + If search is successfully done, add to mapping. + + * frontend.adb: Initialize the mapping if a -gnatem switch was used. + + * make.adb: + (Gnatmake): Add new local variable Mapping_File_Name. + Create mapping file when using project file(s). + Delete mapping file before exiting. + + * opt.ads (Mapping_File_Name): New variable + + * osint.adb (Find_File): Use path name found in mapping, if any. + + * prj-env.adb (Create_Mapping_File): New procedure + + * prj-env.ads (Create_Mapping_File): New procedure. + + * switch.adb (Scan_Front_End_Switches): Add processing for -gnatem + (Mapping_File) + + * usage.adb: Add entry for new switch -gnatem. + + * Makefile.in: Add dependencies for fmap.o. + +2001-12-17 Ed Schonberg + + * sem_ch10.adb (Analyze_With_Clause): Retrieve proper entity when unit + is a package instantiation rewritten as a package body. + (Install_Withed_Unit): Undo previous change, now redundant. + +2001-12-17 Gary Dismuke + + * layout.adb: + (Compute_Length): Move conversion to Unsigned to callers. + (Get_Max_Size): Convert Len expression to Unsigned after calls to + Compute_Length and Determine_Range. + (Layout_Array_Type): Convert Len expression to Unsigned after calls to + Compute_Length and Determine_Range. + Above changes fix problem with length computation for supernull arrays + where Max (Len, 0) wasn't getting applied due to the Unsigned + conversion used by Compute_Length. + +2001-12-17 Arnaud Charlet + + * rtsfind.ads: + (OK_To_Use_In_No_Run_Time_Mode): Allow Ada.Exceptions and + System.Secondary_Stack. + (OK_To_Use_In_Ravenscar_Mode): New table needed to implement Ravenscar + in HI-E mode. + Remove unused entity RE_Exception_Data. + + * rtsfind.adb (RTE): Allow Ravenscar Profile in HI mode. + + * rident.ads (No_Secondary_Stack): New restriction. + +2001-12-17 Joel Brobecker + + * gnat_rm.texi: Fix minor typos. Found while reading the section + regarding "Bit_Order Clauses" that was sent to a customer. + Very interesting documentation! + +2001-12-17 Robert Dewar + + * sem_case.adb (Choice_Image): Avoid creating improper character + literal names by using the routine Set_Character_Literal_Name. This + fixes bombs in certain error message cases. + +2001-12-17 Arnaud Charlet + + * a-reatim.adb: Minor reformatting. + +2001-12-17 Ed Schonberg + + * sem_ch12.adb (Validate_Derived_Type_Instance): Handle properly the + case where the formal is an extension of another formal in the current + unit or in a parent generic unit. + +2001-12-17 Arnaud Charlet + + * s-tposen.adb: Update comments. Minor reformatting. + Minor code clean up. + + * s-tarest.adb: Update comments. Minor code reorganization. + +2001-12-17 Gary Dismukes + + * exp_attr.adb (Attribute_Tag): Suppress expansion of 'Tag + when Java_VM. + +2001-12-17 Robert Dewa + + * exp_attr.adb: Minor reformatting + +2001-12-17 Ed Schonberg + + * sem_ch3.adb (Build_Derived_Private_Type): Refine check to handle + derivations nested within a child unit: verify that the parent + type is declared in an outer scope. + +2001-12-17 Robert Dewar + + * sem_ch12.adb: Minor reformatting + +2001-12-17 Ed Schonberg + + * sem_warn.adb (Check_One_Unit): In No_Run_Time mode, do not post + warning if current unit is a predefined one, from which bodies may + have been deleted. + +2001-12-17 Robert Dewar + + * eval_fat.ads: Add comment that Round_Even is referenced in Ada code + Fix header format. Add 2001 to copyright date. + + * exp_dbug.adb (Get_Encoded_Name): Fix out of bounds reference, + which caused CE during compilation if checks were enabled. + +2001-12-17 Vincent Celier + + * make.adb: + (Switches_Of): New function + (Test_If_Relative_Path): New procedure + (Add_Switches): Use new function Switches_Of + (Collect_Arguments_And_Compile): Use new function Switches_Of. + When using a project file, test if there are any relative + search path. Fail if there are any. + (Gnatmake): Only add switches for the primary directory when not using + a project file. When using a project file, change directory to the + object directory of the main project file. When using a project file, + test if there are any relative search path. Fail if there are any. + When using a project file, fail if specified executable is relative + path with directory information, and prepend executable, if not + specified as an absolute path, with the exec directory. Make sure + that only one -o switch is transmitted to the linker. + + * prj-attr.adb (Initialization_Data): Add project attribute Exec_Dir + + * prj-nmsc.adb: + (Ada_Check): Get Spec_Suffix_Loc and Impl_Suffix_Loc, + when using a non standard naming scheme. + (Check_Ada_Naming_Scheme): Make sure that error messages + do not raise exceptions. + (Is_Illegal_Append): Return True if there is no dot in the suffix. + (Language_Independent_Check): Check the exec directory. + + * prj.adb (Project_Empty): Add new component Exec_Directory + + * prj.ads: + (Default_Ada_Spec_Suffix, Default_Ada_Impl_Suffix): Add defaults. + (Project_Data): Add component Exec_Directory + + * snames.adb: Updated to match snames.ads revision 1.215 + + * snames.ads: Added Exec_Dir + +2001-12-17 Robert Dewar + + * make.adb: Minor reformatting + + * prj-nmsc.adb: Minor reformatting + + * snames.adb: Updated to match snames.ads + + * snames.ads: Alphebetize entries for project file + +2001-12-17 Ed Schonberg + + * trans.c (process_freeze_entity): Do nothing if the entity is a + subprogram that was already elaborated. + +2001-12-17 Richard Kenner + + * decl.c (gnat_to_gnu_entity, object): Do not back-annotate Alignment + and Esize if object is referenced via pointer. + +2001-12-17 Ed Schonberg + + * sem_ch3.adb (Analyze_Variant_Part): check that type of discriminant + is discrete before analyzing choices. + +2001-12-17 Joel Brobecker + + * bindgen.adb (Gen_Output_File_Ada): Generate a new C-like string + containing the name of the Ada Main Program. This string is mainly + intended for the debugger. + (Gen_Output_File_C): Do the equivalent change when generating a C file. + +2001-12-17 Robert Dewar + + * ali.adb: Set new Dummy_Entry field in dependency entry + + * ali.ads: Add Dummy_Entry field to source dependency table + + * bcheck.adb (Check_Consistency): Ignore dummy D lines + + * lib-writ.adb (Writ_ALI): Write dummy D lines for missing source files + + * lib-writ.ads: Document dummy D lines for missing files. + + * types.ads: (Dummy_Time_Stamp): New value for non-existant files + +2001-12-17 Robert Dewar + + * ali.adb: Type reference does not reset current file. + + * ali.adb: Recognize and scan renaming reference + + * ali.ads: Add spec for storing renaming references. + + * lib-xref.ads: Add documentation for handling of renaming references + + * lib-xref.adb: Implement output of renaming reference. + + * checks.adb: + (Determine_Range): Document local variables + (Determine_Range): Make sure Hbound is initialized. It looks as though + there could be a real problem here with an uninitialized reference + to Hbound, but no actual example of failure has been found. + +2001-12-17 Laurent Pautet + + * g-socket.ads: + Fix comment of Shutdown_Socket and Close_Socket. These functions + should not fail silently because if they are called twice, this + probably means that there is a race condition in the user program. + Anyway, this behaviour is consistent with the rest of this unit. + When an error occurs, an exception is raised with the error message + as exception message. + +2001-12-17 Robert Dewar + + * frontend.adb: Move call to Check_Unused_Withs from Frontend, so + that it happens before modification of Sloc values for -gnatD. + + * gnat1drv.adb: Move call to Check_Unused_Withs to Frontend, + so that it happens before modification of Sloc values for -gnatD. + + * switch.adb: Minor reformatting + +2001-12-15 Richard Henderson + + * sem_ch7.adb: Wrap comment. + +2001-12-16 Joseph S. Myers + + * 5ataprop.adb, 5atpopsp.adb, 5ftaprop.adb, 5gmastop.adb, + 5gtaprop.adb, 5htaprop.adb, 5itaprop.adb, 5lintman.adb, + 5omastop.adb, 5oosinte.adb, 5otaprop.adb, 5staprop.adb, + 5vinterr.adb, 5vtaprop.adb, 5vtpopde.adb, 5wintman.adb, + 5wtaprop.adb, 5zinterr.adb, 5ztaprop.adb, 6vcstrea.adb, + 7sintman.adb, 7staprop.adb, 9drpc.adb, ChangeLog, Makefile.in, + a-except.adb, a-tags.ads, a-tasatt.adb, a-teioed.adb, + a-textio.ads, a-witeio.ads, a-wtedit.adb, ali.ads, comperr.adb, + cstand.adb, einfo.ads, errout.adb, exp_ch11.adb, exp_ch2.adb, + exp_ch3.adb, exp_ch4.adb, exp_ch5.adb, exp_ch6.adb, exp_ch9.adb, + exp_util.adb, exp_util.ads, fname-uf.adb, g-cgi.ads, g-exctra.ads, + g-expect.ads, g-regist.adb, g-spipat.adb, gnatchop.adb, + gnatlink.adb, gnatls.adb, gnatmain.adb, gnatmem.adb, init.c, + make.adb, make.ads, mdlltool.adb, nlists.ads, osint.ads, + par-ch3.adb, par-ch4.adb, par-ch5.adb, par-ch6.adb, par.adb, + repinfo.adb, s-fatflt.ads, s-fatlfl.ads, s-fatllf.ads, + s-fatsfl.ads, s-finimp.adb, s-finimp.ads, s-interr.adb, + s-secsta.ads, s-shasto.ads, s-stalib.adb, s-stalib.ads, + s-tarest.ads, s-tasdeb.adb, s-tassta.adb, s-tassta.ads, + s-vaflop.ads, scans.ads, scn.adb, sem.ads, sem_aggr.adb, + sem_attr.adb, sem_case.ads, sem_ch10.adb, sem_ch12.adb, + sem_ch13.adb, sem_ch3.adb, sem_ch3.ads, sem_ch5.adb, sem_ch7.adb, + sem_ch8.adb, sem_ch8.ads, sem_type.adb, sem_util.ads, sinfo.ads, + sprint.adb, tbuild.ads, types.ads, utils.c, xeinfo.adb: Fix + spelling errors. + +2001-12-14 Vincent Celier + + * osint.adb(Create_Debug_File): When an object file is specified, + put the .dg file in the same directory as the object file. + +2001-12-14 Robert Dewar + + * osint.adb: Minor reformatting + + * lib-xref.adb (Output_Instantiation): New procedure to generate + instantiation references. + + * lib-xref.ads: Add documentation of handling of generic references. + + * ali.adb (Read_Instantiation_Ref): New procedure to read + instantiation references + + * ali.ads: Add spec for storing instantiation references + + * bindusg.adb: Minor reformatting + + * switch.adb: Add entry for Latin-5 (Cyrillic ISO-8859-5) + + * usage.adb: Add entry for Latin-5 (Cyrillic ISO-8859-5) + + * gnatcmd.adb: Add entry for Latin-5 (Cyrillic ISO-8859-5) + + * csets.adb: Add entry for Latin-5 (Cyrillic ISO-8859-5) + + * csets.ads: + Fix header format + Add 2001 to copyright date + Add entry for Latin-5 (Cyrillic ISO-8859-5) + +2001-12-14 Matt Gingell + + * adaint.c: mktemp is a macro on Lynx and can not be used as an + expression. + +2001-12-14 Richard Kenner + + * misc.c (gnat_expand_constant): Do not strip UNCHECKED_CONVERT_EXPR + if operand is CONSTRUCTOR. + +2001-12-14 Ed Schonberg + + * trans.c (tree_transform, case N_Assignment_Statement): Set lineno + before emiting check on right-hand side, so that exception information + is correct. + +2001-12-14 Richard Kenner + + * utils.c (create_var_decl): Throw away initializing expression + if just annotating types and non-constant. + +2001-12-14 Vincent Celier + + * prj-nmsc.adb: (Ada_Check): Migrate drom Ada_Default_... to + Default_Ada_... + + * prj.adb: (Ada_Default_Spec_Suffix, Ada_Default_Impl_Suffix): + Remove functions. + (Default_Ada_Spec_Suffix, Default_Ada_Impl_Suffix): Move to spec. + + * prj.ads: (Ada_Default_Spec_Suffix, Ada_Default_Impl_Suffix): + Remove functions. + (Default_Ada_Spec_Suffix, Default_Ada_Impl_Suffix): Move from body. + +2001-12-16 Joseph S. Myers + + * ChangeLog: Remove piece of diff output. + +2001-12-14 Geert Bosch + + * config-lang.in: Update copyright notice + + * layout.adb: Remove commented out code. + + * mdllfile.ads: Update copyright notice. Fix header format. + + * sem_case.ads: Likewise. + + * sem_ch3.adb: Minor reformatting. + +2001-12-12 Geert Bosch + + * freeze.ads: Update copyright date. + + * g-comlin.ads: Minor reformatting. + + * gnat-style.texi: Fix typo. + +2001-12-12 Geert Bosch + + * einfo.h: Regenerate. + +2001-12-12 Ed Schonberg + + * sem_ch12.adb (Save_Entity_Descendant): Use syntactic field names + on known node types, rather than untyped fields. Further cleanups. + +2001-12-12 Robert Dewar + + * sem_ch12.adb: + (Save_Entity_Descendant): Minor comment update. + (Copy_Generic_Node): Deal with incorrect reference to Associated_Node + of an N_Attribute_Reference node. As per note below, this does not + eliminate need for Associated_Node in attribute ref nodes. + (Associated_Node): Documentation explicitly mentions attribute + reference nodes, since this field is used in such nodes. + + * sem_ch12.adb (Associated_Node): Minor documentation cleanup. + +2001-12-12 Robert Dewar + + * s-stalib.adb: Add more comments on with statements being needed + + * par-ch12.adb: Minor reformatting + + * prj-dect.ads: Fix copyright header + + * s-arit64.adb (Multiply_With_Ovflo_Check): Fix case where both + inputs fit in 32 bits, but the result still overflows. + + * s-fatgen.ads: Minor comment improvement + +2001-12-12 Ed Schonberg + + * sem_ch4.adb (Analyze_Selected_Component): If the prefix is of a + formal derived type, look for an inherited component from the full + view of the parent, if any. + +2001-12-12 Robert Dewar + + * checks.ads (Apply_Alignment_Check): New procedure. + + * exp_ch13.adb (Expand_N_Freeze_Entity): Generate dynamic check to + ensure that the alignment of objects with address clauses is + appropriate, and raise PE if not. + + * exp_util.ads (Must_Be_Aligned): Removed, replaced by + Exp_Pakd.Known_Aligned_Enough + + * mdllfile.ads: Minor reformatting + + * mlib-fil.ads: Minor reformatting + +2001-12-12 Ed Schonberg + + * exp_ch8.adb (Expand_N_Object_Renaming_Declaration): Extend previous + fix to any component reference if enclosing record has non-standard + representation. + +2001-12-12 Vincent Celier + + * g-dirope.ads (Find, Wildcard_Iterator): Moved to child package + Iteration + +2001-12-12 Ed Schonberg + + * freeze.ads: Make Freeze_Fixed_Point_Type visible, for use in + sem_attr. + +2001-12-12 Robert Dewar + + * impunit.adb: Add entry for GNAT.Directory_Operations.Iteration + +2001-12-12 Emmanuel Briot + + * g-regexp.adb: Remove all debug code, since it isn't required anymore, + and it adds dependencies to system.io. + +2001-12-12 Pascal Obry + + * g-dirope.adb (Expand_Path.Var): Correctly detect end of + variable name. + +2001-12-11 Ed Schonberg + + * sem_ch10.adb (Install_Withed_Unit): If the unit is a generic instance + that is the parent of other generics, the instance body replaces the + instance node. Retrieve the instance of the spec, which is the one + that is visible in clients and within the body. + +2001-12-11 Vincent Celier + + * gnatmain.adb: Initial version. + + * gnatmain.ads: Initial version. + + * prj-attr.adb (Initialisation_Data): Add package Gnatstub. + + * snames.adb: Updated to match snames.ads. + + * snames.ads: Added Gnatstub. + +2001-12-11 Vincent Celier + + * prj-attr.adb (Initialization_Data): Change name from + Initialisation_Data. + +2001-12-11 Emmanuel Briot + + * g-regpat.adb (Parse_Literal): Properly handle simple operators ?, + + and * applied to backslashed expressions like \r. + +2001-12-11 Vasiliy Fofanov + + * g-os_lib.ads: String_List type added, Argument_List type is now + subtype of String_List. + +2001-12-11 Robert Dewar + + * g-os_lib.ads: Change copyright to FSF + Add comments for String_List type + +2001-12-11 Vincent Celier + + * g-dirope.adb (Expand_Path): Fix bug. (wrong length when adding a + string to the buffer). + +2001-12-11 Ed Schonberg + + * freeze.adb: Make Freeze_Fixed_Point_Type visible, for use in + sem_attr. + + * sem_attr.adb: Simplify previous fix for Address. + (Set_Bounds): If prefix is a non-frozen fixed-point type, freeze now, + to avoid anomalies where the bound of the type appears to raise + constraint error. + +2001-12-11 Robert Dewar + + * lib-xref.adb (Output_Refs): Make sure pointers are always properly + handled. + +2001-12-11 Ed Schonber + + * sem_ch12.adb (Analyze_Subprogram_Instantiation): Check for a + renamed unit before checking for recursive instantiations. + +2001-12-11 Emmanuel Briot + + * prj.ads: Add comments for some of the fields. + +2001-12-11 Robert Dewar + + * lib-xref.adb (Output_Refs): Don't output type references outside + the main unit if they are not otherwise referenced. + +2001-12-11 Ed Schonberg + + * sem_attr.adb (Analyze_attribute, case Address and Size): Simplify + code and diagnose additional illegal uses + + * sem_util.adb (Is_Object_Reference): An indexed component is an + object only if the prefix is. + +2001-12-11 Vincent Celier + + * g-diopit.adb: Initial version. + + * g-diopit.ads: Initial version. + + * g-dirope.adb: + (Expand_Path): Avoid use of Unbounded_String + (Find, Wildcard_Iterator): Moved to child package Iteration + + * Makefile.in: Added g-diopit.o to GNATRTL_NONTASKING_OBJS + +2001-12-11 Robert Dewar + + * sem_attr.adb: Minor reformatting + +2001-12-11 Ed Schonberg + + * sem_ch3.adb: Clarify some ???. + +2001-12-11 Robert Dewar + + * exp_util.adb (Must_Be_Aligned): Removed, replaced by + Exp_Pakd.Known_Aligned_Enough + + * sem_ch13.adb (Check_Address_Alignment): Removed, extended + version is moved to Exp_Ch13. + +2001-12-11 Robert Dewar + + * einfo.ads: Minor reformatting + + * exp_ch5.adb: Add comment for previous.change + + * ali.adb: New interface for extended typeref stuff. + + * ali.ads: New interface for typeref stuff. + + * checks.adb (Apply_Alignment_Check): New procedure. + + * debug.adb: Add -gnatdM for modified ALI output + + * exp_pakd.adb (Known_Aligned_Enough): Replaces Known_Aligned_Enough. + + * lib-xref.adb: Extend generation of <..> notation to cover + subtype/object types. Note that this is a complete rewrite, + getting rid of the very nasty quadratic algorithm previously + used for derived type output. + + * lib-xref.ads: Extend description of <..> notation to cover + subtype/object types. Uses {..} for these other cases. + Also use (..) for pointer types. + + * sem_util.adb (Check_Potentially_Blocking_Operation): Slight cleanup. + + * exp_pakd.adb: Minor reformatting. Note that prevous RH should say: + (Known_Aligned_Enough): Replaces Must_Be_Aligned. + +2001-12-11 Vincent Celier + + * gnatcmd.adb: + Changed /COMPILE_ONLY to /ACTIONS=COMPILE + Changed /BIND_ONLY to /ACTIONS=BIND + Changed /LINK_ONLY to /ACTIONS=LINK + +2001-12-11 Ed Schonberg + + * sem_ch8.adb (Find_Selected_Component): improved search for a + candidate package in case of error. + + * sem_ch12.adb (Inline_Instance_Body): place head of use_clause + chain back on scope stack before reinstalling use clauses. + + * exp_ch5.adb (Expand_N_If_Statement): if Constant_Condition_Warnings + is enabled, do not kill the code for the condition, to preserve + warning. + +2001-12-11 Robert Dewar + + * checks.adb (Insert_Valid_Check): Apply validity check to expression + of conversion, not to result of conversion. + +2001-12-11 Ed Schonberg + + * sem_ch3.adb (Build_Derived_Record_Type): set Controlled flag + before freezing parent. If the declarations are mutually recursive, + an access to the current record type may be frozen before the + derivation is complete. + +2001-12-05 Vincent Celier + + * gnatcmd.adb: (MAKE): Add new translations: -b /BIND_ONLY, + -c /COMPILE_ONLY, -l /LINK_ONLY + + * opt.ads: + (Bind_Only): New Flag + (Link_Only): New flag + + * switch.adb (Scan_Make_Switches): Add processing for -b (Bind_Only) + and -l (Link_Only) + + * makeusg.adb: Add new switches -b and -l. Update Copyright notice. + + * make.adb: + (Do_Compile_Step, Do_Bind_Step, Do_Link_Step): New flags. + (Gnatmake): Set the step flags. Only perform a step if the + corresponding step flag is True. + (Scan_Make_Arg): Reset the bind and link step flags when -u + or -gnatc has been specified. + +2001-12-05 Ed Schonberg + + * sem_eval.adb (Eval_Concatenation): If left operand is a null string, + get bounds from right operand. + + * sem_eval.adb: Minor reformatting + + * exp_util.adb (Make_Literal_Range): use bound of literal rather + than Index'First, its lower bound may be different from 1. + + * exp_util.adb: Undo earlier change, fixes ACVC regressions C48009B + and C48009J + +2001-12-05 Vincent Celier + + * prj-nmsc.adb Minor reformatting + + * prj-nmsc.adb (Language_Independent_Check): Reset Library flag if + set and libraries are not supported. + +2001-12-05 Ed Schonberg + + * sem_ch3.adb (Build_Derived_Private_Type): set Public status of + private view explicitly, so the back-end can treat as a global + when appropriate. + +2001-12-05 Ed Schonberg + + * sem_ch12.adb (Instantiate_Package_Body): if instance is a compilation + unit, always replace instance node with new body, for ASIS use. + +2001-12-05 Vincent Celier + + * prj-nmsc.adb (Language_Independent_Check): Issue a warning if + libraries are not supported and both attributes Library_Name and + Library_Dir are specified. + + * prj-proc.adb (Expression): Set location of Result to location of + first term. + + * Makefile.in: Add mlib.o, mlib-fil.o, mlib-tgt and mlib-utl to GNATLS. + (prj-nmsc is now importing MLib.Tgt) + + * prj-proc.adb: Put the change indicated above that was forgotten. + +2001-12-05 Robert Dewar + + * Makefile.in: Add dependencies for System.IO for GNAT.Regexp + +2001-12-05 Ed Schonberg + + * sem_ch3.adb (Build_Derived_Concurrent_Type): If derivation imposes a + constraint, introduce explicit subtype declaration and derive from it. + + * sem_ch3.adb: Minor reformatting + +2001-12-05 Robert Dewar + + * checks.adb (Determine_Range): Increase cache size for checks. + Minor reformatting + + * exp_ch6.adb: Minor reformatting + (Expand_N_Subprogram_Body): Reset Is_Pure for any subprogram that has + a parameter whose root type is System.Address, since treating such + subprograms as pure in the code generator is almost surely a mistake + that will lead to unexpected results. + + * exp_util.adb (Remove_Side_Effects): Clean up old ??? comment and + change handling of conversions. + + * g-regexp.adb: Use System.IO instead of Ada.Text_IO. + +2001-12-05 Ed Schonberg + + * sem_ch3.adb (Analyze_Object_Declaration): If expression is an + aggregate with static wrong size, attach generated Raise node to + declaration. + +2001-12-05 Robert Dewar + + * sem_attr.adb (Analyze_Attribute): Defend against bad Val attribute. + Fixes compilation abandoned bomb in B24009B. + +2001-12-05 Ed Schonberg + + * sem_ch12.adb: + Document use of Associated_Node on Selected_Components. + (Save_Global_Operand_Descendants): Change to Save_Entity_Descendants, + to clarify use of untyped descendant fields. + +2001-12-05 Robert Dewar + + * prj-dect.ads: Add ??? comment + Add 2001 to copyright notice (was not done in after all) + + * prj-part.adb: Minor reformatting. Reword one awkward error message. + + * prj.ads: Minor reformatting throughout, and add some ??? comments + + * snames.ads: Minor reformatting + +2001-12-05 Geert Bosch + + * snames.adb: Autoupdate + +2001-12-05 Vincent Celier + + * prj-dect.adb (Parse): Rename parameter Modifying to Extends. + + * prj-dect.ads (Parse): Rename parameter Modifying to Extends. + + * prj-env.adb: Minor comment changes (modifying -> extends). + + * prj-nmsc.adb: Minor comment changes (modifying -> extends). + + * prj-part.adb (Parse_Single_Project): Change Tok_Modifying to + Tok_Extends. + + * prj.adb (Initialize): Change Modifying to Extends. + + * scans.ads (Token_Type): Change Tok_Modifying to Tok_Extends. + + * prj.ads: Minor comment change (Modifying -> extending). + + * snames.ads: Change modifying to extends. + +2001-12-05 Robert Dewar + + * sem_warn.adb: Remove stuff for conditionals, we are not going to + do this after all. + + * sem_warn.ads: Remove stuff for conditionals, we are not going to + do this after all. Add 2001 to copyright notice + +2001-12-04 Geert Bosch + + * einfo.h, sinfo.h, treeprs.ads: Regenerate. + +2001-12-04 Robert Dewar + + * errout.adb (Error_Msg): Ignore attempt to put error msg at junk + location if we already have errors. Stops some cases of cascaded + errors. + + * errout.adb: Improve comment. + +2001-12-04 Robert Dewar + + * sem_ch12.adb: + (Analyze_Formal_Type_Definition): Defend against Error. + (Analyze_Formal_Subprogram): Defend against Error. + + * par-ch12.adb (F_Formal_Type_Declaration): In case of error, + remove following semicolon if present. Removes cascaded error. + +2001-12-04 Douglas B. Rupp + + * bindgen.adb: + (Gen_Exception_Table_Ada): Write "begin" and then return if Num + exceptions equals 0. + (Gen_Exception_Table_C): Return if Num exceptions equals 0. + Fixes PIWG E tests (which have to be run with -gnatL). + +2001-12-04 Robert Dewar + + * einfo.ads: Minor reformatting + +2001-12-04 Ed Schonberg + + * einfo.ads: Block_Node points to the identifier of the block, not to + the block node itself, to preserve the link when the block is + rewritten, e.g. within an if-statement with a static condition. + + * inline.adb (Cleanup_Scopes): recover block statement from block + entity using new meaning of Block_Node. + + * sem_ch5.adb (Analyze_Block_Statement): set Block_Node to point to + identifier of block node, rather than to node itself. + +2001-12-04 Gary Dismukes + + * layout.adb: + (Get_Max_Size): Fix "start of processing" comment to say Get_Max_Size. + (Discrimify): Go back to setting the Etypes of the selected component + because the Vname component does not exist at this point and will + fail name resolution. Also set Analyzed. + Remove with and use of Sem_Res. + +2001-12-04 Arnaud Charlet + + * Makefile.in: (HIE_SOURCES): add s-fat*. + +2001-12-04 Robert Dewar + + * sem_attr.adb: + (Compile_Time_Known_Attribute): New procedure. + (Eval_Attribute, case Size): Use Compile_Time_Known_Attribute to ensure + proper range check. + +2001-12-04 Ed Schonberg + + * sem_ch7.adb (New_Private_Type): Set Is_Tagged_Type flag before + processing discriminants to diagnose illegal default values. + +2001-12-04 Ed Schonberg + + * sem_attr.adb (Resolve_Attribute): Handle properly an non-classwide + access discriminant within a type extension that constrains its + parent discriminants. + +2001-12-04 Ed Schonberg + + * sem_ch3.adb (Find_Type_Of_Subtype_Indic): If subtype indication + is malformed, use instance of Any_Id to allow analysis to proceed. + + * par-ch12.adb (P_Formal_Type_Declaration): Propagate Error if + type definition is illegal. + (P_Formal_Derived_Type_Definition): Better recovery when TAGGED is + misplaced. + +2001-12-04 Ed Schonberg + + * sem_warn.adb (Output_Unreferenced_Messages): Extend previous fix to + constants. + +2001-12-04 Robert Dewar + + * errout.adb: Minor reformatting + +2001-12-04 Robert Dewar + + * exp_util.adb: Minor reformatting from last change + + * errout.adb (Check_For_Warning): For a Raised_Constraint_Error node + which is a rewriting of an expression, traverse the original + expression to remove warnings that may have been posted on it. + +2001-12-04 Ed Schonberg + + * exp_util.adb (Must_Be_Aligned): Return false for a component of a + record that has other packed components. + +2001-12-04 Douglass B. Rupp + + * adaint.c: Minor cleanups. + +2001-12-04 Douglass B. Rupp + + * adaint.c: Do not use utime.h on vxworks. + +2001-12-04 Arnaud Charlet + + * Makefile.adalib: Clarify step 3 (use of gnat.adc) as it causes + more confusion than it solves. + +2001-12-04 Geert bosch + + * einfo.h, nmake.adb, nmake.ads, sinfo.h treeprs.ads: Regenerate. + +2001-12-04 Geert Bosch + + * Makefile.in (update-sources): New target. + For use by gcc_release script. + +2001-12-04 Ed Schonberg + + * sem_prag.adb (Analyze_Pragma, case Validity_Checks): do not treat as + a configuration pragma, it is now legal wherever a pragma can appear. + +2001-12-04 Zack Weinberg + + * Makefile.in: Don't set ALL. Delete @cross_defines@, + @cross_overrides@, @build_overrides@ stanzas. INTERNAL_CFLAGS + is now @CROSS@ -DIN_GCC; update comment. + +2001-12-04 Robert Dewar + + * einfo.adb (Has_Pragma_Pure_Function): New flag. + Fix problem that stopped ceinfo from working + + * einfo.ads (Has_Pragma_Pure_Function): New flag. + + * sem_prag.adb (Pure_Function): Set new flag Has_Pragma_Pure_Function. + +2001-12-04 Douglas B. Rupp + + * gnatchop.adb: + (File_Time_Stamp): New procedure. + (Preserve_Mode): New boolean. + (Write_Unit): Pass time stamp. + Implement -p switch (preserve time stamps). + + * gnatcmd.adb (CHOP): Add translation for -p (/PRESERVE). + + * gnatchop.adb: Do usage info for -p switch + + * adaint.h (__gnat_set_file_time_name): New function + + * adaint.c (__gnat_set_file_time_name): Implement + + * adaint.h: Fix typo + +2001-12-03 Robert Dewar + + * sinfo.ads: Minor reformatting. N_Freeze_Entity node does not + have Associated_Node. + +2001-12-03 Robert Dewar + + * prj-proc.adb: Minor reformatting + + * make.adb: Minor reformatting + +2001-12-03 Geert Bosch + + * make.adb: Minor reformatting. + +2001-12-03 Robert Dewar + + * sem_ch12.adb: Minor reformatting + +2001-12-03 Ed Schonberg + + * sem_ch12.adb (Inline_Instance_Body): Use Save_Scope_Stack and + push Standard on the stack before analyzing the instance body, + in order to have a clean visibility environment. + + * sem_ch12.adb (Inline_Instance_Body): Remove redundant code. + +2001-12-03 Ed Schonberg + + * sem_ch12.adb (Instantiate_Package_Body): Protect against double + instantiation of a body that contains an inlined body. + +2001-12-03 Ed Schonberg + + * sem_ch12.adb: + (Analyze_generic_subprogram_Declaration): Set outer_generic_scope, + to prevent freezing within formal packages. + (Freeze_Subprogram_Body): If body comes from another instance that + appeared before its own body, place freeze node at end of current + declarative part, to prevent a back-end crash. + (Inline_Instance_Body): Handle properly a package instance within + a subprogram instance that is a child unit. + +2001-12-01 Graham Stott + + * Makefile.in (misc.o): Add missing $(srcdir) prefix + and add optabs.h dependency. + + * misc.c: Include optabs.h + (gnat_tree_code_type): Make static and const. + (gnat_tree_code_length): Likewise. + (gnat_tree_code_name): Likewise. + (update_setjmp_buf): Obtain operands mode from insn_data. + +2001-11-29 Richard Henderson + + * init.c: Remove obsolete dwarf2 frame.h section. + +2001-11-29 Joseph S. Myers + + * Make-lang.in (ada.generated-manpages): New dummy target. + +2001-11-29 Ed Schonberg + + * g-os_lib.adb (Add_To_Command): use explicit loop to move string + into Command, an array conversion is illegal here. Uncovered by + ACATS B460005. + +2001-11-28 Geert Bosch + + * init.c: Minor whitespace changes. + +2001-11-28 Doug Rupp + + * init.c: (__gnat_install_handler,VMS): Increase size of alternate + signal stack. + +2001-11-28 Zack Weinberg + + * misc.c (gnat_expand_constant): Move declaration above + definition of lang_hooks. + (LANG_HOOKS_EXPAND_CONSTANT): Set to gnat_expand_constant. + (gnat_init): lang_expand_constant no longer exists. + + (internal_error_function): Remove #ifdef HAVE_VPRINTF. We + always have vprintf. + (gnat_init): Always call set_internal_error_function. + +2001-11-27 Andreas Jaeger + + * Makefile.in (stamp-tool_src_dir): Use symbolic link. + +2001-11-27 Laurent Guerby + + * Makefile.in: Regenerate Ada dependencies. + +2001-11-26 Richard Henderson + + * Make-lang.in (gnatbind, gnatmake, gnatbl, gnatchop, gnatcmd, + gnatlink, gnatkr, gnatls, gnatmem, gnatprep, gnatpsta, gnatpsys, + gnatxref, gnatfind, gnatlbr): Depend on CONFIG_H and prefix.o. + +2001-11-25 Laurent Guerby + + * sysdep.c (rts_get_*): Fix style. + +2001-11-19 Laurent Guerby + + * Makefile.in (INCLUDES_FOR_SUBDIR): Remove redundant system include + since it is of no apparent use and cause warnings. + +2001-11-18 Neil Booth + + * misc.c (gnat_decode_option, gnat_init_options): Make definitions + static too. + (gnat_init): Don't return NULL. + (finish_parse): Remove. + +2001-11-17 Laurent Guerby + + * Make-lang.in (GNATLIBFLAGS): Add -W -Wall. + * gigi.h (init_decl_processing): Rename to gnat_init_decl_processing. + * io-aux.c: Provide K&R prototypes to all functions, reformat code. + * lang-spec.h: Add missing struct field to silence warnings. + * sysdep.c (rts_get_*): Provide K&R prototype. + * sysdep.c (Unlock_Task, Lock_Task): Move to K&R prototype. + * traceback.c (Unlock_Task, Lock_Task): Likewise. + * tracebak.c (__gnat_backtrace): Remove unused variable. + * utils.c (end_subprog_body): Move to K&R style. + +Thu Nov 15 18:16:17 2001 Richard Kenner + + * trans.c, utils2.c: Remove PALIGN parameter to get_inner_reference. + +2001-11-15 Neil Booth + + * misc.c (gnat_init): Change prototype. Include the + functionality of the old init_parse and init_decl_processing. + (gnat_init_decl_processing): New prototype. + (init_parse): Remove. + * utils.c (init_decl_processing): Rename gnat_init_decl_processing. + +2001-11-09 Neil Booth + + * misc.c (gnat_print_decl, gnat_print_type): Renamed. + (LANG_HOOKS_PRINT_DECL, LANG_HOOKS_PRINT_TYPE): Override. + (print_lang_statistics, lang_print_xnode, print_lang_identifier, + set_yydebug): Remove. + +2001-11-09 Neil Booth + + * misc.c (LANG_HOOKS_NAME, LANG_HOOKS_IDENTIFIER_SIZE): Override. + (struct lang_hooks): Constify. + (language_string, lang_identify): Remove. + * utils.c (init_decl_processing): Update. + +2001-11-06 Neil Booth + + * misc.c: Include langhooks-def.h. + * Makefile.in: Update. + +2001-10-30 Robert Dewar + + * style.adb: + (Check_Identifier): Rewrite circuit to be compatible with use of letters + in the upper half of ASCII. + (Check_Identifier): Minor reformatting + +2001-10-30 Geert Bosch + + * (Associated_Node, Set_Associated_Node): Do not check for + Freeze_Entity. + +2001-10-30 Robert Dewar + + * a-reatim.ads: Minor reformatting + +2001-10-30 Robert Dewar + + * gnatdll.adb: Minor reformatting throughout. Many ??? added for + undocumented declarations. + +2001-10-30 Pascal Obry + + * gnatdll.adb (Parse_Command_Line): handle -g option to be passed + to the binder and linker. + Minor style fix. + + * mdll.ads: Fix layout. Update copyright notice. + + * mdll.adb: Fix layout. Update copyright notice. + +2001-10-30 Robert Dewar + + * usage.adb: Minor fix to output for -gnaty. + +2001-10-30 Ed Schonberg + + * a-reatim.ads: Makes Seconds_Count into a 64-bit integer, + to accommodate all its possible values. + + * a-reatim.adb (Split): Special-case handling of Time_Span_First + and of small absolute values of T. + +2001-10-30 Richard Kenner + + * misc.c (gnat_expand_expr, case NULL_EXPR): Remove call to + set_mem_attributes since not needed and wrong if RESULT if a REG; + fixes ACATS failures. + +2001-10-30 Geert Bosch + + * 86numaux.adb, a-tigeau.ads, a-wtgeau.ads, fname-sf.ads, g-traceb.ads, + s-tasdeb.ads, sem_maps.ads: Add 2001 to copyright notice. + +2001-10-30 Robert Dewar + + * bindusg.adb: Undocument -f switch. + + * gnatcmd.adb: Remove /FULL_ELABORATION. + + * opt.ads (Force_RM_Elaboration_Order): Document that this is + obsolescent. + + * gnatbind.adb: Output new warning for use of obsolescent -f switch. + + * gnatbind.adb: Minor update of warning msg. + +2001-10-30 Vincent Celier + + * gnatcmd.adb (MAKE, BIND, LINK, LIST, FIND, XREF): Add translations + for project file switches (-P (/PROJECT_FILE=), + -X (/EXTERNAL_REFERENCE=) and -vPx (/PROJECT_FILE_VERBOSITY=DEFAULT + or MEDIUM or HIGH) + +2001-10-30 Geert Bosch + + * decl.c: Minor whitespace fixes. + +2001-10-30 Richard Kenner + + * utils2.c (build_allocator): Test for SIZE overflow in array case too + +2001-10-30 Geert Bosch + + * ali-util.adb (Initialize_Checksum): Use out-mode instead of in out. + Found due to GCC 3.0 warning of using uninitialized value. + + * layout.adb: + (Get_Max_Size): Use variant record for tracking value/expression. + Makes logic clearer and prevents warnings for uninitialized variables. + (Layout_Array_Type): Use variant record for tracking value/expression. + Makes logic clearer and prevents warnings for uninitialized variables. + +2001-10-30 Robert Dewar + + * lib.adb: Minor reformatting + + * s-taprop.ads: Minor reformatting + +2001-10-29 Laurent Guerby + + * init.c: + (Raise_From_Signal_Handler, Propagate_Signal_Exception): Make arg + const. + (_gnat_error_handler): Make MSG const. + +2001-10-29 Richard Kenner + + * sysdep.c: Fix localtime_r problem on LynxOS. + Also remove #elif to avoid warnings. + + * misc.c (yyparse): Don't set up and register jmpbuf; remove decls + used by this. + + * decl.c (annotate_value): Make SIZE unsigned to avoid warning. + +2001-10-28 Joseph S. Myers + + * 86numaux.adb, a-tigeau.ads, a-wtgeau.ads, decl.c, exp_ch6.adb, + exp_ch9.adb, exp_util.adb, fname-sf.ads, freeze.ads, g-awk.adb, + g-comlin.ads, g-dirope.adb, g-dyntab.ads, g-socket.ads, + g-table.ads, g-traceb.ads, gnat-style.texi, gnatchop.adb, init.c, + layout.adb, layout.ads, mdllfile.ads, mlib-fil.ads, osint.ads, + s-fatgen.adb, s-imgrea.adb, s-taprop.ads, s-tasdeb.ads, + sem_aggr.adb, sem_attr.adb, sem_case.ads, sem_ch13.adb, + sem_ch3.adb, sem_elab.adb, sem_maps.ads, sem_res.adb, + sem_util.ads, sinfo.ads, sinput.ads, table.adb, table.ads, + types.ads, urealp.adb: Fix spelling errors. + +2001-10-27 Laurent Guerby + + * trans.c (gigi): Fix non determinism leading to bootstrap + comparison failures for debugging information. + +2001-10-26 Florian Weimer + + * gnat_rm.texi: Use @./@: where appropriate. + +2001-10-26 Robert Dewar + + * sinfo.adb: Define Associated_Node to overlap Entity field. Cleanup. + +2001-10-26 Richard Kenner + + * gmem.c (__gnat_gmem_read_next): Properly check for EOF + +2001-10-26 Richard Kenner + + * decl.c (validate_size): Modify message for bad size to avoid + implication that compiler is modifying the size. + +2001-10-26 Robert Dewar + + * prj-util.adb: Minor reformatting. Fix bad header format. + +2001-10-26 Robert Dewar + + * sinfo.ads: Define Associated_Node to overlap Entity field. Cleanup. + + * sinfo.ads: Clarify use of Associated_Node (documentation only). + + * sem_ch12.adb: Change Node4 to Associated_Node. Change + Associated_Node to Get_Associated_Node. Put use of Unchecked_Access + much more narrowly in places where needed. These are cleanups. + +2001-10-26 Joel Brobecker + + * 5zosinte.ads (null_pthread): new constant. + + * 5ztaprop.adb: + (Initialize_TCB): Initialize thread ID to null, to be able to verify + later that this field has been set. + (Finalize_TCB): ditto. + (Suspend_Task): Verify that the thread ID is not null before using it. + (Resume_Task): ditto. + + * s-tasdeb.adb: + (Resume_All_Tasks): Lock the tasks list before using it. + (Suspend_All_Tasks): ditto. + +2001-10-26 Richard Kenner + + * decl.c (gnat_to_gnu_entity, case E_General_Access_Type): + Make constant variant of designated type for Is_Access_Constant. + Call update_pointer_to with main variant. + + * trans.c (process_freeze_entity, process_type): + Call update_pointer_to on main variant. + + * utils.c (update_pointer_to): Make corresponding variant for NEW_TYPE. + If main variant, update all other variants. + + * utils2.c (build_unary_op, case INDIRECT_REF): No longer set + TREE_STATIC. + +2001-10-26 Robert Dewar + + * prj-util.adb: Minor reformatting + +2001-10-26 Robert Dewar + + * prj-util.adb: Minor reformatting + +2001-10-26 Robert Dewar + + * prj-attr.adb: Minor reformatting throughout + +2001-10-26 Robert Dewar + + * prj-attr.ads: Minor reformatting + Add ??? comment (this whole spec has almost no comments) + +2001-10-26 Vincent Celier + + * g-os_lib.adb (Normalize_Pathname): Preserve the double slash + ("//") that precede the drive letter on Interix. + +2001-10-26 Geert Bosch + + * gnat_rm.texi: Add GNAT Reference Manual. + +2001-10-25 Robert Dewar + + * sem_ch8.adb (Analyze_Package_Renaming): Skip analysis if Name + is Error. Similar change for other renaming cases. + +2001-10-25 Robert Dewar + + * s-atacco.ads: Add pragma Inline_Always for functions. + Fix header format. Add copyright 2001 + +2001-10-25 Ed Schonberg + + * par-ch3.adb (P_Subtype_Mark_Resync): for an anonymous array + return Error rather than Empty so that analysis can proceed. + +2001-10-25 Ed Schonberg + + * sem_util.adb (Enter_Name): better handling of cascaded error + messages when a unit appears in its own context. + +2001-10-25 Ed Schonberg + + * sem_util.adb (Defining_Entity): in case of error, attach created + entity to specification, so that semantic analysis can proceed. + +2001-10-25 Robert Dewar + + * sem_util.adb + (Defining_Entity): Deal with Error. + (Process_End_Label): Deal with bad end label for. + +2001-10-25 Ed Schonberg + + * sem_elab.adb (Check_A_Call): refine message when call is in an + instance but callee is not declared in the generic unit. + +2001-10-25 Ed Schonberg + + * sem_elab.adb (Check_A_Call): check for renaming before finding the + enclosing unit, which may already be different from the calling unit. + +2001-10-25 Geert Bosch + + * 4gintnam.ads: fix header format. + +2001-10-25 Ed Schonberg + + * sem_res.adb (Resolve_Call): if the call is actually an indexing + operation on the result of a parameterless call, perform elaboration + check after the node has been properly rewritten. + + * sem_ch12.adb (Copy_Generic_Node): after the proper body has been + inlined within the generic tree, the defining identifier is not a + compilation_unit. + +2001-10-25 Ed Schonberg + + * sem_res.adb (Resolve): special-case resolution of Null in an + instance or an inlined body to avoid view conflicts. + + * sem_ch12.adb (Copy_Generic_Node): for allocators, check for view + compatibility by retrieving the access type of the generic copy. + +2001-10-25 Robert Dewar + + * sem_ch3.adb: + (Analyze_Number_Declaration): Handle error expression. + (Signed_Integer_Type_Declaration): Handle error bound. + (Analyze_Subtype_Indication): Handle error range. + + * sem_util.adb (Get_Index_Bounds): Check for Error. + +2001-10-25 Robert Dewar + + * restrict.adb (Set_No_Run_Time_Mode): Set Discard_Names as default + in no run time mode. + +2001-10-25 Pascal Obry + + * gnatmem.adb (Read_Next): fix Curs2 value to properly handle quiet + mode case for ALLOC case. + + * gnatmem.adb (Read_Next): correctly fix parsing in Quiet mode on + all platforms. Improvement of last change. + +2001-10-25 Robert Dewar + + * exp_ch4.adb (Expand_N_Allocator): Minor reformatting. + +2001-10-25 Geert Bosch + + * osint.adb (Is_Relative): Remove duplicate. + +2001-10-25 Pascal Obry + + * osint.adb (Read_Default_Search_Dirs): correctly detect relative + pathnames in UNIX and DOS style with drive letter. + (Is_Relative): new routine. + + * osint.adb: Minor reformatting + + * osint.adb (Is_Relative): implementation using + GNAT.OS_Lib.Is_Absolute_Path. Better fix. + +2001-10-25 Pascal Obry + + * g-dirope.adb (Basename): correctly compute offset between the + original Path and the translated one. + + * g-dirope.adb: (Base_Name): add some comments. + +2001-10-25 Robert Dewar + + * exp_imgv.adb (Expand_Image_Attribute): Defend against bad use + in HIE mode, avoids compilation abandoned message + + * exp_imgv.adb: Correct typo in previous change + + * exp_imgv.adb: Correct typo in previous change (not my day!) + +2001-10-25 Robert Dewar + + * s-tpinop.ads: Add 2001 to copyright notice. Fix header format. + +2001-10-25 Pascal Obry + + * g-awk.ads: Move all pragma inlines next to the routine + declarations. This is more uniform with other GNAT spec. + +2001-10-22 Geert Bosch + + * Make-lang.in (gnattools, cross-gnattools): Remove gnatmem. + +2001-10-19 Geert Bosch + + * Makefile.in (tools, gnattools): Remove gnatmem. + +2001-10-17 Richard Henderson + + * Makefile.in (misc.o): Depend on langhooks.h. + * misc.c: Include it. + (LANG_HOOKS_INIT, LANG_HOOKS_INIT_OPTIONS): New. + (LANG_HOOKS_DECODE_OPTION): New. + (lang_hooks): Use LANG_HOOKS_INITIALIZER. + +2001-10-16 Florian Weimer + + * trans.c (tree_transform): Adjust to recent change in + expand_asm_operands to implement named asm operands. + +2001-10-11 Ed Schonberg + + * exp_ch8.adb (Expand_N_Object_Renaming_Declaration): Bugfix in + renaming of discriminant for mutable record type. + +2001-10-11 Robert Dewar + + * validsw.adb: Properly save -gnatVn status. + +2001-10-11 Robert Dewar + + * usage.adb: Add lines for V switch. + + * gnatcmd.adb (COMPILE): Revise translations for -gnatV + (/VALIDITY_CHECKING). + +2001-10-11 Ed Schonberg + + * sem_type.adb (Add_One_Interp): an operator for a type declared in + an extension of System is known to be visible. + +2001-10-11 Ed Schonberg + + * sem_eval.adb (Compare_Fixup): get the bounds of a String_Literal + properly. Fixes regression on ACATS C34005G. + +2001-10-11 Robert Dewar + + * sem_ch5.adb (Analyze_Iteration_Scheme): Suppress warning on null + loop in generic instance, since this is likely not very useful. + +2001-10-11 Robert Dewar + + * restrict.adb (Disallow in No_Run_Time_Mode): Properly specialize + the error message for high integrity mode. + + * rtsfind.adb (RTE): Give message if we try to find an entity that + is not available in high integrity mode. + + * rtsfind.ads: + (OK_To_Use_In_HIE_Mode): New array. + (RTE): May return Empty in high integrity mode. + + * rtsfind.ads (OK_To_Use_In_No_Run_Time_Mode): New name for + OK_To_Use_In_HIE_Mode, now includes System_FAT_xxx. + + * sem_ch6.adb (Analyze_Subprogram_Body): Kill body in predefined + unit if not inlined always and in no runtime mode. Fixes problem + caused by new Rtsfind changes. + + * sem_ch6.adb (Analyze_Subrogram_Body): Do not Check_References if + body is deleted. + + * rtsfind.adb (RTE): Make sure we do not try to load unit after + giving message for entity not available in high integrity mode. + +2001-10-11 Pascal Obry + + * impunit.adb: Add GNAT.CRC32. + +2001-10-11 Ed Schonberg + + * exp_fixd.adb (Expand_Multiply_Fixed_By_Fixed_Giving_Fixed): handle + properly the case where one universal operand in a non-static + exponentiation of a real literal. + +2001-10-11 Ed Schonberg + + * exp_ch7.adb (Find_Final_List): for a type appearing in a with_type + clause, return the gobal finalization list, for lack of anthing else. + +2001-10-11 Ed Schonberg + + * exp_ch7.adb (Make_Transient_Block): if statement is within + exception handler, always use new transient scope to place Clean + procedure. + +2001-10-11 Pascal Obry + + * Makefile.in: + (GNAT_ADA_OBJS): add g-crc32.o, a-tags.o, a-stream.o + (GNATBIND_OBJS): add g-crc32.o, a-tags.o, a-stream.o + (GNATLS_RTL_OBJS): add g-crc32.o + (GNATMAKE_RTL_OBJS): add g-crc32.o + + * ali-util.adb: + (CRC_Match): new function. + (Get_File_Checksum): renamed Get_File_CRC. Use the GNAT.CRC32 unit + instead of the previous simple checksum algorithm. + (Time_Stamp_Mismatch): use CRC_Match for comparison. + (Set_Source_Table): idem. + + * ali-util.ads: + (Get_File_Checksum): renamed Get_File_CRC as now we compute CRC + instead of simple checksum. + (CRC_Match): new function. + (CRC_Error): new constant. + + * ali.adb (Scan_ALI): rename variable Chk to CRC as we are handling + a CRC now and not a simple checksum. A CRC uses lower-case hex + letters, fixes ambiguity in parsing. + + * ali.ads (Sdep_Record.Checksum): renamed Sdep_Record.CRC as this + is what this variable will store. + + * bcheck.adb: Change reference to chechsum in comments by CRC. + (Check_Consistency): Rename Get_File_Checksum to Get_File_CRC. + rename All_Checksum_Match to All_CRC_Match. Change due to API + renaming since now GNAT does not use a simple checksum but a + CRC using GNAT.CRC32. + + * gnatls.adb: Rename Checksum to CRC in many places, we use a CRC + now and not anymore a simple checksum. + + * lib-load.adb: Use Source_CRC instead of Source_Checksum in many + places. + + * lib-writ.adb (Write_ALI): Use Source_CRC instead of Source_Checksum. + + * scans.adb: + (Restore_Scan_State): rename Checksum to CRC. + (Save_Scan_State): idem. + + * scans.ads: + With GNAT.CRC32. + (Checksum): rename to CRC. + (Saved_Scan_State): Save_Checksum field renamed to Save_CRC + + * scn-nlit.adb: Rename many Accumulate_Checksum to Update (from + GNAT.CRC32). Update copyright notice. + + * scn-slit.adb: Rename many Accumulate_Checksum to Update (from + GNAT.CRC32). Update copyright notice. + + * scn.adb: + (Accumulate_Checksum): removed. + (Update): new procedure. Add a wide-character into the CRC. + + * sinput-l.adb: + (Complete_Source_File_Entry): use CRC32 instead of simple checksum. + (Load_File): fix initialization of S (change Source_Checksum to + Source_CRC) + + * sinput-p.adb (Load_Project_File): rename Source_Checksum to + Source_CRC in S initialization. + + * sinput.adb (Source_Checksum): renamed to Source_CRC. + + * sinput.ads (Source_Checksum): renamed to Source_CRC. + Update comments for the CRC. + + * types.adb (Hex): Use lowercase for the letter part. + + * types.ads (Get_Hex_String): Returns the hexadecimal representation + for a word. This is currently used only for CRC. In previous version, + the checksum was using a representation with all letter being + upper-case. With the new implementation (using CRC) we do not remove + the 32th bit of the CRC, so we can have an upper-case starting letter + in the CRC. This is not possible to parse in Scan_ALI (ali.adb). + It is ambigous since the CRC was optional and could be followed by + options like EB, EE. So now this routines uses lower-case letter for + the hexadecimal representation. Strange enough only lower case letters + where checked in Scan_ALI (even if this was not a possible case). + + * gnatvsn.ads (Library_Version): changed to 3.15a. + + * s-crc32.ads: Initial version from GNAT.CRC32. This is the version + for the compiler. + + * s-crc32.adb: Initial version from GNAT.CRC32. This is the version + for the compiler. + + * ali-util.adb: Redo previous change to avoid using word CRC everywhere + Add 2001 to copyright notice + (Accumulate_Checksum): Modify to use System.CRC32. + + * ali-util.ads: Redo changes of previous revision to continue to use + the word Checksum. Add 2001 to copyright notice. + + * ali.adb: Undo some of previous changes, not needed. + Keep the change for lower case letters in the checksum. + + * ali.ads: Undo previous change not needed. + + * bcheck.adb: Undo most of previous change, not needed. + But do use Checksums_Match for checksum comparison. + + * gnatls.adb: Undo most of previous change, not needed. + But do use Checksums_Match for comparing checksums. + + * lib-load.adb: Undo previous change, not needed. + + * lib-writ.adb: Undo previous change, not needed. + + * lib-writ.ads: Document that checksums use lower case, + not upper case letters. + + * scans.adb: Undo previous change, not needed + + * scans.ads: Undo previous change, not needed. + + * scn-nlit.adb: Undo previous changes, not needed. + + * scn-slit.adb: Undo previous change, not needed. Fix header format. + + * scn.adb: + (Accumulate_Checksum): Use System.CRC32. + (Initialize_Checksum): New procedure. + Remove other changes of previous revision. + + * sinput-p.adb: Undo previous change, not needed. + + * sinput.adb: Undo previous change, not needed. + + * sinput-l.adb: Undo previous change, not needed. + + * sinput.ads: Undo previous change, not needed. Keep only comment + on new checksum algorithm + + * Makefile.in: Add s-crc32 as needed, remove g-crc32. + Also remove a-tags and a-stream from GNAT sources. + + * ali.adb (Scan_ALI): fix typo introduce in latest check-in. + + * Makefile.in (GNATRTL_NONTASKING_OBJS): Add g-crc32.o. + +2001-10-11 Geert Bosch + + * einfo.h: Regenerate. + + * nmake.ads: Regenerate. + + * nmake.adb: Regenerate. + + * sinfo.h: Regenerate. + + * treeprs.adb: Regenerate. + +2001-10-10 Geert Bosch + + * gnat-style.texi: New file describing coding guidelines for Ada. + +2001-10-10 Ed Schonberg + + * einfo.adb (Write_Entity_Flags): Elaboration_Entity_Required + is Flag174. + +2001-10-10 Geert Bosch + + * snames.ads: Add new names for project facility. + + * snames.adb: Update to reflect snames.ads changes. + + * snames.h: Update to reflect snames.ads changes. + +2001-10-10 Vincent Celier + + * make.adb: + (Add_Switches): reflect the changes for the switches attributes + Default_Switches indexed by the programming language, + Switches indexed by the file name. + (Collect_Arguments_And_Compile): Idem. + Reflect the attribute name changes. + + * prj-attr.adb: + (Initialisation_Data): Change the names of some packages and + attributes. + (Initialize): process case insensitive associative arrays. + + * prj-attr.ads: + (Attribute_Kind): Remove Both, add Case_Insensitive_Associative_Array. + + * prj-dect.adb: + (Parse_Attribute_Declaration): For case insensitive associative + arrays, set the index string to lower case. + + * prj-env.adb: + Reflect the changes of the project attributes. + + * prj-nmsc.adb: + Replace Check_Naming_Scheme by Ada_Check and + Language_Independent_Check. + + * prj-nmsc.ads: + Replaced Check_Naming_Scheme by 2 procedures: + Ada_Check and Language_Independent_Check. + + * prj-proc.adb: + (Process_Declarative_Items): For case-insensitive associative + arrays, set the index string to lower case. + (Recursive_Check): Call Prj.Nmsc.Ada_Check, instead of + Prj.Nmsc.Check_Naming_Scheme. + + * prj-tree.adb: + (Case_Insensitive): New function + (Set_Case_Insensitive): New procedure + + * prj-tree.ads: + (Case_Insensitive): New function + (Set_Case_Insensitive): New procedure + (Project_Node_Record): New flag Case_Insensitive. + + * prj-util.adb: + (Value_Of): new function to get the string value of a single + string variable or attribute. + + * prj-util.ads: + (Value_Of): new function to get the string value of a single + string variable or attribute. + + * prj.adb: + (Ada_Default_Spec_Suffix): New function + (Ada_Default_Impl_Suffix): New function + Change definitions of several constants to reflect + new components of record types. + + * prj.ads: + (Naming_Data): Change several components to reflect new + elements of naming schemes. + (Project_Data): New flags Sources_Present and + Language_Independent_Checked. + (Ada_Default_Spec_Suffix): New function. + (Ada_Default_Impl_Suffix): New function. + + * snames.ads: + Modification of predefined names for project manager: added + Implementation, Specification_Exceptions, Implementation_Exceptions, + Specification_Suffix, Implementation_Suffix, Separate_Suffix, + Default_Switches, _Languages, Builder, Cross_Reference, + Finder. Removed Body_Part, Specification_Append, Body_Append, + Separate_Append, Gnatmake, Gnatxref, Gnatfind, Gnatbind, + Gnatlink. + + * prj.ads: (Ada_Default_Spec_Suffix, Ada_Default_Impl_Suffix): + Add comments. + + * prj-nmsc.adb (Ada_Check): Test that Separate_Suffix is defaulted, + not that it is Nil_Variable_Value. + + * prj.ads: Add ??? for uncommented declarations + +2001-10-10 Ed Schonberg + + * sem_prag.adb: (Analyze_Pragma, case External): If entity is a + constant, do not indicate possible modification, so that gigi can + treat it as a bona fide constant. + +2001-10-10 Robert Dewar + + * sem_prag.adb: Add processing for pragma External. + + * snames.ads: Add entry for pragma External. + + * par-prag.adb: Add pragma External. + + * snames.adb: Updated to match snames.ads. + +2001-10-10 Ed Schonberg + + * exp_ch4.adb (Expand_N_Allocator): Generate meaningful names for + a dynamic task if the allocator appears in an indexed assignment + or selected component assignment. + + * exp_util.adb (Build_Task_Array_Image, Build_Task_Record_Image): + For a dynamic task in an assignment statement, use target of + assignment to generate meaningful name. + +2001-10-10 Ed Schonberg + + * einfo.adb (Write_Field19_Name): Body_Entity is also defined for + a generic package. + + * einfo.ads: Body_Entity is also defined for generic package. + Documentation change only + + * exp_aggr.adb (Build_Array_Aggr_Code): When expanding an + others_choice for a discriminated component initialization, + convert discriminant references into the corresponding discriminals. + + * exp_ch3.adb (Get_Simple_Init_Val): Add qualification to aggregate + only if original type is private and expression has to be wrapped + in a conversion. + + * checks.adb: + (Apply_Constraint_Check): Do not perform length check + if expression is an aggregate with only an others_choice. + (Length_N_Cond): two references to the same in_parameter + (typically the discriminal in an init_proc) denote the same value. + Two useful optimization uncovered by bugfixes above. + +2001-10-10 Robert Dewar + + * xeinfo.adb: Change int to char in translation of enumeration types. + This fixes a problem in the C representation of component alignment. + Add 2001 to copyright notice + +2001-10-10 Richard Kenner + + * decl.c: (validate_size): Do check size of object of integral type + if it is a packed array type. + +2001-10-10 Richard Kenner + + * decl.c: (gnat_to_gnu_entity, case object): Also materialize + VAR_DECL for constant if not Is_Public but -O0. + +2001-10-10 Richard Kenner + + * misc.c (struct lang_hooks): Add new initializer to match GCC change. + +2001-10-10 Geert Bosch + + * xnmake.adb (XNmake): Fix handling of -s/-b options. No longer + use '/' as switch character, allowing for absolute file names. + +2001-10-09 Joseph S. Myers + + * 4gintnam.ads, Make-lang.in, Makefile.in, config-lang.in: Update + FSF address. + +2001-10-08 Geert Bosch + + * Makefile.in (treeprs.ads, einfo.h, sinfo.h, nmake.adb, nmake.ads): + Automatically build utilities when files need to be regenerated. + +2001-10-08 Geert Bosch + + * xsnames.adb: New utility for updating snames.ads and snames.adb + +2001-10-08 Zack Weinberg + + * Make-lang.in (ADAFLAGS): Add -W -Wall. + (ADA_FLAGS_TO_PASS): Set ADA_CFLAGS=$(CFLAGS) also. + (gnat1): Also depend on attribs.o. + (gnatlib, gnatlib-shared): Set CC and ADAC in recursive make. + * Makefile.in (X_ADAFLAGS, T_ADAFLAGS): New. + (ADAC): Set to @ADAC@ in stage1, $(CC) later. + (ADAFLAGS): Add -W -Wall. + (ALL_ADAFLAGS, MOST_ADAFLAGS): Add X_ADAFLAGS and T_ADAFLAGS; + take out CFLAGS. + + (.adb.o, .ads.o, a-numaux.o, a-teioed.o, s-interr.o, + s-taskin.o, sdefault.o, s-tasdeb.o, s-vaflop.o, a-except.o, + s-assert.o, s-stalib.o, s-memory.o, memtrack.o, mlib-tgt.o): + Use $(ADAC), not $(CC), as compilation command. + + (gnattools): Depend directly on tools to build, don't use + recursive make. + (gnatlib): Set ADA_CFLAGS=$(GNATLIBCFLAGS) in recursive make. + + * einfo.h, sinfo.h: New files (autogenerated). + +2001-10-08 Richard Henderson + + * comperr.adb (Abort_In_Progress): New. + (Compiler_Abort): Use it to prevent recursion. + +2001-10-08 Robert Dewar + + * atree.adb: Set Error_Posted in Error node, helps error recovery. + + * par-endh.adb (Output_End_Expected): We should also not test + Error_Posted on the Error node, since now it is always set. + + * cstand.adb (Create_Standard): Set Etype of Error to Any_Type + to help error recovery. Part of general work on 9407-004. + + * par.adb: Add ??? for misuse of error + + * sem_res.adb: + (Resolve): Defend against Error, fixes 9407-003. + (Resolve_Discrete_Subtype_Indication): Defend against Error. + + * sinfo.ads (N_Error): Now has Etype field (which will be set + to Any_Type to help error recovery). + +2001-10-08 Richard Kenner + + * misc.c (gnat_expand_expr, case UNCHECKED_CONVERT_EXPR): + Consistently set MEM attributes from expression; fixes + bootstrap failure on x86. + +2001-10-08 Geert Bosch + + * 5oosinte.adb: Add 2001 to copyright notice. + +2001-10-08 Geert Bosch + + * ceinfo.adb: Add utility for consistency checking of einfo.ad[bs]. + + * csinfo.adb: Add utility for consistency checking of sinfo.ad[bs]. + +2001-10-07 Joseph S. Myers + + * 5oosinte.adb: Fix spelling error of "separate" as "seperate". + +2001-10-05 Geert Bosch + + * adaint.h: Small formatting fix. + +2001-10-04 Geert Bosch + + * sysdep.c (__gnat_set_binary_mode, __gnat_set_text_mode): + Arg is int, not FILE *, in dummy version of functions. + + * adaint.h (__gnat_set_binary_mode, __gnat_set_text_mode): + Arg is int, not FILE *. + +2001-10-04 Geert Bosch + + * 3lsoccon.ads: Added file, missed with initial check ins. + + * 4lintnam.ads: Fix header format. + Change Linux to GNU/Linux. + + * 5iosinte.adb: Change Linux to GNU/Linux. + + * 5iosinte.ads: Change Linux to GNU/Linux. + + * 5itaprop.adb: Change Linux to GNU/Linux. + + * 5itaspri.ads: Change Linux to GNU/Linux. + Update copyright notice. + + * 5lintman.adb: Change Linux to GNU/Linux. + + * 5lml-tgt.adb: Change Linux to GNU/Linux. + + * 5losinte.ads: Change Linux to GNU/Linux. + + * 5lsystem.ads: Change Linux to GNU/Linux. + + * 5qosinte.adb: Change Linux to GNU/Linux. + + * 5qosinte.ads: Change Linux to GNU/Linux. + + * 5qparame.ads: Change Linux to GNU/Linux. + + * 5qtaprop.adb: Change Linux to GNU/Linux. + + * 5qtaspri.ads: Change Linux to GNU/Linux. + Add 2001 to copyright notice. + + * 5vintman.ads: Change Linux to GNU/Linux. + Fix header format. Add 2001 to copyright notice. + + * g-soccon.ads: Change Linux to GNU/Linux. + + * g-trasym.ads: Change Linux to GNU/Linux. + Add 2001 to copyright notice. + + * memtrack.adb: Change Linux to GNU/Linux. + + * s-intman.ads: Change Linux to GNU/Linux. + Add 2001 to copyright notice. Fix header format. + + * s-stache.adb: Change Linux to GNU/Linux. + + * adaint.c: Change Linux to GNU/Linux. + + * cio.c: Change Linux to GNU/Linux. + + * cstreams.c: Change Linux to GNU/Linux. + + * init.c: Change Linux to GNU/Linux. + + * gmem.c: Change Linux to GNU/Linux. + + * tracebak.c: Change Linux to GNU/Linux. + +2001-10-02 Geert Bosch + + * misc.c (insert_default_attributes): Add dummy version. + + + +Copyright (C) 2001 Free Software Foundation, Inc. + +Copying and distribution of this file, with or without modification, +are permitted in any medium without royalty provided the copyright +notice and this notice are preserved. diff --git a/gcc/ada/ChangeLog-2002 b/gcc/ada/ChangeLog-2002 new file mode 100644 index 000000000..09580b3db --- /dev/null +++ b/gcc/ada/ChangeLog-2002 @@ -0,0 +1,986 @@ +2002-12-28 Joseph S. Myers + + * gnat_rm.texi, gnat_ug.texi: Use @copying. + * gnat_ug_unx.texi, gnat_ug_vms.texi, gnat_ug_vxw.texi, + gnat_ug_wnt.texi: Regenerate. + +2002-12-23 Joseph S. Myers + + * gnat_rm.texi: Include gcc-common.texi. Use GCC version number + only. + * Make-lang.in ($(srcdir)/ada/gnat_ug_unx.info, + $(srcdir)/ada/gnat_ug_vms.info, $(srcdir)/ada/gnat_ug_vxw.info, + $(srcdir)/ada/gnat_ug_wnt.info, $(srcdir)/ada/gnat_rm.info, + ada/gnat_ug_unx.dvi, ada/gnat_ug_vms.dvi, ada/gnat_ug_vxw.dvi, + ada/gnat_ug_wnt.dvi, ada/gnat_rm.dvi): Depend on + $(srcdir)/doc/include/gcc-common.texi. + +2002-12-15 Geert Bosch + + * sem_ch6.adb (Analyze_Subprogram_Body): Fix typo and formatting + +2002-12-14 Geert Bosch + + PR ada/5690 + * sem_ch6.adb (Analyze_Subprogram_Body): Recognize additional + case of a body created for a Renaming_As_Body, on which + conformance checks are not performed. + +2002-11-30 Zack Weinberg + + * cuintp.c, decl.c, deftarg.c, misc.c, targtyps.c, trans.c, + utils.c, utils2.c: Include coretypes.h and tm.h, and system.h when + not already included. + * Make-lang.in: Update dependencies. + +2002-11-18 Nathanael Nerode + * adaint.c (__gnat_tmp_name): Better, but good enough for now, + solution to buffer overflow bug on GNU/Linux. + +2002-11-14 Nathanael Nerode + + PR ada/5856 + PR ada/6919 + * bindgen.adb: Remove all references to Public_Version. + * comperr.adb: Remove all references to Public_Version and + GNATPRO_Version; correct bug reporting instructions. + * comperr.ads: Change to match bug box. + * gnatvsn.ads: Remove all references to Public version and + GNATPRO version. + +2002-11-13 Nathanael Nerode + + PR ada/6919 + * adaint.c (__gnat_tmp_name): Remove buffer overflow bug on + GNU/Linux. + + PR ada/6558 + * config-lang.in: Remove diff_excludes. + +2002-11-05 Graham Stott + + PR ada/8358 + * trans.c (gnu_pending_elaboration_lists): New GC root. + (build_unit_elab): Use.. + +2002-10-30 Geert Bosch + + PR ada/6558 + * misc.c : Include optabs.h + + * Make-lang.in (misc.o): Add dependency on optabs.h + +2002-10-29 Geert Bosch + + PR ada/6558 + * Make-lang.in (gnatbind): Depend on CONFIG_H + +2002-10-29 Geert bosch + + PR ada/6558 + * misc.c: Unrevert misc.c (1.13) + +2002-10-28 Nathanael Nerode + + * a-chlat9.ads a-cwila9.ads a-dynpri.adb a-retide.adb: Update + maintainership comments. + +2002-09-25 Nathanael Nerode + + PR ada/5904 + * 5ataprop.adb 5atpopsp.adb 5bosinte.adb 5ftaprop.adb + 5gtaprop.adb 5htaprop.adb 5rosinte.ads 5staprop.adb + 5stpopse.adb 5vtaspri.ads 5zintman.adb 5ztaprop.adb + 7staprop.adb: Correct statements in comments about + maintainership of GNAT. + + PR ada/5904 + * 1ssecsta.adb 1ssecsta.ads adadecode.c adadecode.h aux-io.c + gnatname.adb gnatname.ads mkdir.c osint-b.adb osint-b.ads + osint-c.adb osint-c.ads osint-l.adb osint-l.ads osint-m.adb + osint-m.ads prj-makr.adb prj-makr.ads prj-pp.adb prj-pp.ads + s-atacco.ads s-traceb.adb s-traceb.ads s-traces.adb + s-traces.ads s-tratas.adb s-tratas.ads sinput-d.adb + sinput-d.ads switch-b.adb switch-b.ads switch-c.adb + switch-c.ads switch-m.adb switch-m.ads: Correct statements in + comments about maintainership of GNAT. + + PR ada/6919 (forward port of patch for PR ada/5904) + * 1aexcept.adb 1aexcept.ads 41intnam.ads 42intnam.ads + 4aintnam.ads 4cintnam.ads 4dintnam.ads 4hexcpol.adb + 4lintnam.ads 4mintnam.ads 4nintnam.ads 4onumaux.ads + 4pintnam.ads 4rintnam.ads 4sintnam.ads 4uintnam.ads + 4vcalend.adb 4vintnam.ads 4wcalend.adb 4wexcpol.adb + 4wintnam.ads 4zintnam.ads 4znumaux.ads 4zsytaco.adb + 4zsytaco.ads 51osinte.adb 51osinte.ads 52osinte.adb + 52osinte.ads 52system.ads 53osinte.ads 5aosinte.ads + 5asystem.ads 5atasinf.ads 5ataspri.ads 5avxwork.ads + 5bosinte.ads 5bsystem.ads 5cosinte.ads 5dosinte.ads + 5esystem.ads 5fosinte.ads 5fsystem.ads 5ftasinf.ads + 5ginterr.adb 5gmastop.adb 5gosinte.ads 5gproinf.adb + 5gproinf.ads 5gsystem.ads 5gtasinf.adb 5gtasinf.ads + 5gtpgetc.adb 5hparame.ads 5hsystem.ads 5htaspri.ads + 5iosinte.ads 5itaspri.ads 5ksystem.ads 5kvxwork.ads + 5losinte.ads 5lsystem.ads 5mosinte.ads 5mvxwork.ads + 5ninmaop.adb 5nintman.adb 5nosinte.ads 5ntaspri.ads + 5oosprim.adb 5oparame.adb 5osystem.ads 5posinte.ads + 5posprim.adb 5pvxwork.ads 5rosinte.ads 5rparame.adb + 5sintman.adb 5sosinte.ads 5sparame.adb 5ssystem.ads + 5stasinf.adb 5stasinf.ads 5staspri.ads 5svxwork.ads + 5tosinte.ads 5uosinte.ads 5vasthan.adb 5vinterr.adb + 5vintman.ads 5vosinte.ads 5vosprim.adb 5vosprim.ads + 5vparame.ads 5vsystem.ads 5vtaspri.ads 5vtpopde.adb + 5vtpopde.ads 5vvaflop.adb 5wintman.adb 5wmemory.adb + 5wosinte.ads 5wosprim.adb 5wsystem.ads 5wtaprop.adb + 5wtaspri.ads 5ysystem.ads 5zinterr.adb 5zosinte.adb + 5zosinte.ads 5zosprim.adb 5zsystem.ads 6vcpp.adb 6vcstrea.adb + 7sosprim.adb 86numaux.adb 86numaux.ads 9drpc.adb a-astaco.adb + a-caldel.ads a-calend.adb a-calend.ads a-chahan.adb + a-chahan.ads a-colien.adb a-colien.ads a-colire.adb + a-colire.ads a-comlin.adb a-comlin.ads a-cwila1.ads + a-decima.adb a-decima.ads a-diocst.adb a-diocst.ads + a-direio.adb a-direio.ads a-einuoc.adb a-einuoc.ads + a-except.adb a-except.ads a-excpol.adb a-exctra.adb + a-exctra.ads a-filico.adb a-filico.ads a-finali.adb + a-finali.ads a-interr.ads a-intsig.adb a-intsig.ads + a-ngcefu.adb a-ngcoty.adb a-ngcoty.ads a-ngelfu.adb + a-nudira.adb a-nudira.ads a-nuflra.adb a-nuflra.ads + a-numaux.ads a-reatim.ads a-retide.ads a-sequio.adb + a-sequio.ads a-siocst.adb a-siocst.ads a-ssicst.adb + a-ssicst.ads a-stmaco.ads a-storio.adb a-strbou.adb + a-strbou.ads a-stream.ads a-strfix.adb a-strfix.ads + a-strmap.adb a-strmap.ads a-strsea.adb a-strsea.ads + a-strunb.adb a-strunb.ads a-ststio.adb a-ststio.ads + a-stunau.adb a-stunau.ads a-stwibo.adb a-stwibo.ads + a-stwifi.adb a-stwima.adb a-stwima.ads a-stwise.adb + a-stwise.ads a-stwiun.adb a-stwiun.ads a-suteio.adb + a-suteio.ads a-swmwco.ads a-swuwti.adb a-swuwti.ads + a-sytaco.adb a-sytaco.ads a-tags.adb a-tags.ads a-tasatt.ads + a-taside.adb a-taside.ads a-teioed.adb a-teioed.ads + a-textio.adb a-textio.ads a-ticoau.adb a-ticoau.ads + a-ticoio.adb a-ticoio.ads a-tideau.adb a-tideau.ads + a-tideio.adb a-tideio.ads a-tienau.adb a-tienau.ads + a-tienio.adb a-tienio.ads a-tifiio.adb a-tifiio.ads + a-tiflau.adb a-tiflau.ads a-tiflio.adb a-tiflio.ads + a-tigeau.adb a-tigeau.ads a-tiinau.adb a-tiinau.ads + a-tiinio.adb a-tiinio.ads a-timoau.adb a-timoau.ads + a-timoio.adb a-timoio.ads a-tiocst.adb a-tiocst.ads + a-titest.adb a-witeio.adb a-witeio.ads a-wtcoau.adb + a-wtcoau.ads a-wtcoio.adb a-wtcstr.adb a-wtcstr.ads + a-wtdeau.adb a-wtdeau.ads a-wtdeio.adb a-wtdeio.ads + a-wtedit.adb a-wtedit.ads a-wtenau.adb a-wtenau.ads + a-wtenio.adb a-wtenio.ads a-wtfiio.adb a-wtfiio.ads + a-wtflau.adb a-wtflau.ads a-wtflio.adb a-wtflio.ads + a-wtgeau.adb a-wtgeau.ads a-wtinau.adb a-wtinau.ads + a-wtinio.adb a-wtmoau.adb a-wtmoau.ads a-wtmoio.adb + a-wtmoio.ads a-wttest.adb ada-tree.def ada-tree.h ada.h + adaint.c adaint.h ali-util.adb ali-util.ads ali.adb ali.ads + alloc.ads argv.c atree.adb atree.ads atree.h back_end.adb + back_end.ads bcheck.adb bcheck.ads binde.adb binde.ads + binderr.adb binderr.ads bindgen.adb bindgen.ads bindusg.adb + bindusg.ads butil.adb butil.ads cal.c casing.adb casing.ads + ceinfo.adb checks.adb checks.ads cio.c comperr.adb comperr.ads + csets.adb csets.ads csinfo.adb cstand.adb cstand.ads + cstreams.c cuintp.c debug.adb debug.ads debug_a.adb + debug_a.ads dec-io.adb dec-io.ads dec.ads decl.c deftarg.c + einfo.adb einfo.ads einfo.h elists.adb elists.ads elists.h + errno.c errout.adb errout.ads eval_fat.adb eval_fat.ads exit.c + exp_aggr.adb exp_aggr.ads exp_attr.adb exp_attr.ads + exp_ch10.ads exp_ch11.adb exp_ch11.ads exp_ch12.adb + exp_ch12.ads exp_ch13.adb exp_ch13.ads exp_ch2.adb exp_ch2.ads + exp_ch3.adb exp_ch3.ads exp_ch4.adb exp_ch4.ads exp_ch5.adb + exp_ch5.ads exp_ch6.adb exp_ch6.ads exp_ch7.adb exp_ch7.ads + exp_ch8.adb exp_ch8.ads exp_ch9.adb exp_ch9.ads exp_code.adb + exp_code.ads exp_dbug.adb exp_dbug.ads exp_disp.adb + exp_disp.ads exp_dist.adb exp_dist.ads exp_fixd.adb + exp_fixd.ads exp_imgv.adb exp_imgv.ads exp_intr.adb + exp_intr.ads exp_pakd.adb exp_pakd.ads exp_prag.adb + exp_prag.ads exp_smem.adb exp_smem.ads exp_strm.adb + exp_strm.ads exp_tss.adb exp_tss.ads exp_util.adb exp_util.ads + exp_vfpt.adb exp_vfpt.ads expander.adb expander.ads fe.h + final.c fmap.adb fmap.ads fname-sf.adb fname-sf.ads + fname-uf.adb fname-uf.ads fname.adb fname.ads freeze.adb + freeze.ads frontend.adb frontend.ads g-calend.ads g-comlin.adb + g-debpoo.adb g-debpoo.ads g-locfil.adb g-os_lib.ads + g-regist.adb g-regist.ads get_targ.adb get_targ.ads gigi.h + gmem.c gnat1drv.adb gnat1drv.ads gnat_ug.texi gnatbind.adb + gnatbind.ads gnatbl.c gnatcmd.adb gnatcmd.ads gnatdll.adb + gnatfind.adb gnatkr.adb gnatkr.ads gnatlbr.adb gnatlink.adb + gnatlink.ads gnatls.adb gnatls.ads gnatmake.adb gnatmake.ads + gnatmem.adb gnatprep.adb gnatprep.ads gnatpsta.adb gnatvsn.ads + gnatxref.adb hlo.adb hlo.ads hostparm.ads i-c.adb i-cexten.ads + i-cobol.adb i-cobol.ads i-cpoint.adb i-cpoint.ads i-cpp.adb + i-cpp.ads i-cstrea.adb i-cstrea.ads i-cstrin.adb i-cstrin.ads + i-fortra.adb i-os2err.ads i-os2lib.adb i-os2lib.ads + i-os2syn.ads i-os2thr.ads i-pacdec.adb i-pacdec.ads + impunit.adb impunit.ads init.c inline.adb inline.ads io-aux.c + itypes.adb itypes.ads krunch.adb krunch.ads lang-options.h + lang-specs.h layout.adb layout.ads lib-list.adb lib-load.adb + lib-load.ads lib-sort.adb lib-util.adb lib-util.ads + lib-writ.adb lib-writ.ads lib-xref.adb lib-xref.ads lib.adb + lib.ads link.c live.adb live.ads make.adb make.ads makeusg.adb + makeusg.ads math_lib.adb mdll.adb mdll.ads memtrack.adb misc.c + namet.adb namet.ads namet.h nlists.adb nlists.ads nlists.h + nmake.adb nmake.ads nmake.adt opt.adb opt.ads osint.adb + osint.ads output.adb output.ads par-ch10.adb par-ch11.adb + par-ch12.adb par-ch13.adb par-ch2.adb par-ch3.adb par-ch4.adb + par-ch5.adb par-ch6.adb par-ch7.adb par-ch8.adb par-ch9.adb + par-endh.adb par-labl.adb par-load.adb par-prag.adb + par-sync.adb par-tchk.adb par-util.adb par.adb par.ads + prj-attr.adb prj-attr.ads prj-com.adb prj-com.ads prj-dect.adb + prj-dect.ads prj-env.adb prj-env.ads prj-ext.adb prj-ext.ads + prj-nmsc.adb prj-nmsc.ads prj-pars.adb prj-pars.ads + prj-part.adb prj-part.ads prj-proc.adb prj-proc.ads + prj-strt.adb prj-strt.ads prj-tree.adb prj-tree.ads + prj-util.adb prj-util.ads prj.adb prj.ads raise.c raise.h + repinfo.adb repinfo.ads repinfo.h restrict.adb restrict.ads + rident.ads rtsfind.adb rtsfind.ads s-addima.adb s-addima.ads + s-arit64.adb s-arit64.ads s-assert.adb s-assert.ads + s-asthan.adb s-asthan.ads s-atacco.adb s-auxdec.adb + s-auxdec.ads s-bitops.adb s-bitops.ads s-chepoo.ads + s-direio.adb s-direio.ads s-except.ads s-exctab.adb + s-exctab.ads s-exnflt.ads s-exngen.adb s-exngen.ads + s-exnint.ads s-exnlfl.ads s-exnlin.ads s-exnllf.ads + s-exnlli.ads s-exnsfl.ads s-exnsin.ads s-exnssi.ads + s-expflt.ads s-expgen.adb s-expgen.ads s-expint.ads + s-explfl.ads s-explin.ads s-expllf.ads s-explli.ads + s-expllu.adb s-expllu.ads s-expmod.adb s-expmod.ads + s-expsfl.ads s-expsin.ads s-expssi.ads s-expuns.adb + s-expuns.ads s-fatflt.ads s-fatgen.adb s-fatgen.ads + s-fatlfl.ads s-fatllf.ads s-fatsfl.ads s-ficobl.ads + s-fileio.adb s-fileio.ads s-finimp.adb s-finimp.ads + s-finroo.adb s-finroo.ads s-fore.adb s-fore.ads s-imgbiu.adb + s-imgbiu.ads s-imgboo.adb s-imgboo.ads s-imgcha.adb + s-imgcha.ads s-imgdec.adb s-imgdec.ads s-imgenu.adb + s-imgenu.ads s-imgint.adb s-imgint.ads s-imgllb.adb + s-imgllb.ads s-imglld.adb s-imglld.ads s-imglli.adb + s-imglli.ads s-imgllu.adb s-imgllu.ads s-imgllw.adb + s-imgllw.ads s-imgrea.adb s-imgrea.ads s-imguns.adb + s-imguns.ads s-imgwch.adb s-imgwch.ads s-imgwiu.adb + s-imgwiu.ads s-inmaop.ads s-interr.adb s-interr.ads + s-intman.ads s-io.adb s-io.ads s-maccod.ads s-mantis.adb + s-mantis.ads s-memory.adb s-memory.ads s-osprim.ads + s-pack03.adb s-pack03.ads s-pack05.adb s-pack05.ads + s-pack06.adb s-pack06.ads s-pack07.adb s-pack07.ads + s-pack09.adb s-pack09.ads s-pack10.adb s-pack10.ads + s-pack11.adb s-pack11.ads s-pack12.adb s-pack12.ads + s-pack13.adb s-pack13.ads s-pack14.adb s-pack14.ads + s-pack15.adb s-pack15.ads s-pack17.adb s-pack17.ads + s-pack18.adb s-pack18.ads s-pack19.adb s-pack19.ads + s-pack20.adb s-pack20.ads s-pack21.adb s-pack21.ads + s-pack22.adb s-pack22.ads s-pack23.adb s-pack23.ads + s-pack24.adb s-pack24.ads s-pack25.adb s-pack25.ads + s-pack26.adb s-pack26.ads s-pack27.adb s-pack27.ads + s-pack28.adb s-pack28.ads s-pack29.adb s-pack29.ads + s-pack30.adb s-pack30.ads s-pack31.adb s-pack31.ads + s-pack33.adb s-pack33.ads s-pack34.adb s-pack34.ads + s-pack35.adb s-pack35.ads s-pack36.adb s-pack36.ads + s-pack37.adb s-pack37.ads s-pack38.adb s-pack38.ads + s-pack39.adb s-pack39.ads s-pack40.adb s-pack40.ads + s-pack41.adb s-pack41.ads s-pack42.adb s-pack42.ads + s-pack43.adb s-pack43.ads s-pack44.adb s-pack44.ads + s-pack45.adb s-pack45.ads s-pack46.adb s-pack46.ads + s-pack47.adb s-pack47.ads s-pack48.adb s-pack48.ads + s-pack49.adb s-pack49.ads s-pack50.adb s-pack50.ads + s-pack51.adb s-pack51.ads s-pack52.adb s-pack52.ads + s-pack53.adb s-pack53.ads s-pack54.adb s-pack54.ads + s-pack55.adb s-pack55.ads s-pack56.adb s-pack56.ads + s-pack57.adb s-pack57.ads s-pack58.adb s-pack58.ads + s-pack59.adb s-pack59.ads s-pack60.adb s-pack60.ads + s-pack61.adb s-pack61.ads s-pack62.adb s-pack62.ads + s-pack63.adb s-pack63.ads s-parame.adb s-parame.ads + s-parint.adb s-parint.ads s-pooglo.adb s-pooglo.ads + s-pooloc.adb s-pooloc.ads s-poosiz.adb s-poosiz.ads + s-powtab.ads s-proinf.adb s-proinf.ads s-rpc.adb s-rpc.ads + s-scaval.ads s-secsta.adb s-secsta.ads s-sequio.adb + s-sequio.ads s-shasto.adb s-shasto.ads s-soflin.adb + s-soflin.ads s-sopco3.adb s-sopco3.ads s-sopco4.adb + s-sopco4.ads s-sopco5.adb s-sopco5.ads s-stache.adb + s-stache.ads s-stalib.adb s-stalib.ads s-stoele.adb + s-stopoo.ads s-stratt.adb s-stratt.ads s-strops.adb + s-strops.ads s-taprob.ads s-taprop.ads s-tarest.ads + s-tasdeb.adb s-tasdeb.ads s-tasinf.adb s-tasinf.ads + s-tasini.ads s-taskin.ads s-tasren.ads s-tasres.ads + s-tassta.ads s-tpinop.adb s-tpinop.ads s-tpoben.ads + s-tpobop.ads s-unstyp.ads s-vaflop.adb s-vaflop.ads + s-valboo.adb s-valboo.ads s-valcha.adb s-valcha.ads + s-valdec.adb s-valdec.ads s-valenu.adb s-valenu.ads + s-valint.adb s-valint.ads s-vallld.adb s-vallld.ads + s-vallli.adb s-vallli.ads s-valllu.adb s-valllu.ads + s-valrea.adb s-valrea.ads s-valuns.adb s-valuns.ads + s-valuti.adb s-valuti.ads s-valwch.adb s-valwch.ads + s-vercon.adb s-vercon.ads s-vmexta.adb s-vmexta.ads + s-wchcnv.adb s-wchcnv.ads s-wchcon.ads s-wchjis.adb + s-wchjis.ads s-wchstw.adb s-wchstw.ads s-wchwts.adb + s-wchwts.ads s-widboo.adb s-widboo.ads s-widcha.adb + s-widcha.ads s-widenu.adb s-widenu.ads s-widlli.adb + s-widlli.ads s-widllu.adb s-widllu.ads s-widwch.adb + s-widwch.ads s-wwdcha.adb s-wwdcha.ads s-wwdenu.adb + s-wwdenu.ads s-wwdwch.adb s-wwdwch.ads scans.adb scans.ads + scn-nlit.adb scn-slit.adb scn.adb scn.ads sdefault.ads sem.adb + sem.ads sem_aggr.adb sem_aggr.ads sem_attr.adb sem_attr.ads + sem_case.adb sem_case.ads sem_cat.adb sem_cat.ads sem_ch10.adb + sem_ch10.ads sem_ch11.adb sem_ch11.ads sem_ch12.adb + sem_ch12.ads sem_ch13.adb sem_ch13.ads sem_ch2.adb sem_ch2.ads + sem_ch3.adb sem_ch3.ads sem_ch4.adb sem_ch4.ads sem_ch5.adb + sem_ch5.ads sem_ch6.adb sem_ch6.ads sem_ch7.adb sem_ch7.ads + sem_ch8.adb sem_ch8.ads sem_ch9.adb sem_ch9.ads sem_disp.adb + sem_disp.ads sem_dist.adb sem_dist.ads sem_elab.adb + sem_elab.ads sem_elim.adb sem_elim.ads sem_eval.adb + sem_eval.ads sem_intr.adb sem_intr.ads sem_maps.adb + sem_maps.ads sem_mech.adb sem_mech.ads sem_prag.adb + sem_prag.ads sem_res.adb sem_res.ads sem_smem.adb sem_smem.ads + sem_type.adb sem_type.ads sem_util.adb sem_util.ads + sem_vfpt.adb sem_vfpt.ads sem_warn.adb sem_warn.ads + sfn_scan.adb sfn_scan.ads sinfo-cn.adb sinfo-cn.ads sinfo.adb + sinfo.ads sinfo.h sinput-l.adb sinput-l.ads sinput-p.adb + sinput-p.ads sinput.adb sinput.ads snames.adb snames.ads + snames.h sprint.adb sprint.ads stand.adb stand.ads stringt.adb + stringt.ads stringt.h style.adb style.ads stylesw.adb + stylesw.ads switch.adb switch.ads sysdep.c system.ads + table.adb table.ads targparm.adb targparm.ads targtyps.c + tbuild.adb tbuild.ads trans.c tree_gen.adb tree_gen.ads + tree_in.adb tree_in.ads tree_io.adb tree_io.ads treepr.adb + treepr.ads treeprs.ads treeprs.adt ttypef.ads ttypes.ads + types.adb types.ads types.h uintp.adb uintp.ads uintp.h + uname.adb uname.ads urealp.adb urealp.ads urealp.h usage.adb + usage.ads utils.c utils2.c validsw.adb validsw.ads + widechar.adb widechar.ads xeinfo.adb xnmake.adb xr_tabls.adb + xr_tabls.ads xref_lib.adb xref_lib.ads xsinfo.adb xsnames.adb + xtreeprs.adb: Correct statements in comments about maintainership + of GNAT. + +2002-09-23 Zack Weinberg + + * Make-lang.in (EXTRA_GNATBIND_OBJS): Add version.o. + * Makefile.in (TOOLS_LIBS): Add ../../version.o. + * gnatvsn.ads: Gnat_Version_String is now a function. + * gnatvsn.adb: New file. When asked for Gnat_Version_String, + copy the C version_string into a String and return it. + * gnatcmd.adb, gnatkr.adb, gnatlbr.adb, gnatlink.adb, + gnatls.adb,gnatmake.adb, gnatprep.adb, gnatpsta.adb: + Remove pragma Ident (Gnat_Version_String). If this was the + sole use of package Gnatvsn, remove the with statement too. + * gnat1drv.adb: Tweak -gnatv output. + +2002-09-17 Richard Henderson + + * trans.c (tree_transform): Use real_ldexp not REAL_VALUE_LDEXP. + * config/dsp16xx/dsp16xx.md (fixuns_trunchfhi2): Use real_2expN. + * config/mips/mips.md (fixuns_truncdfsi2): Likewise. + (fixuns_truncdfdi2, fixuns_truncsfsi2, fixuns_truncsfdi2): Likewise. + * config/m68k/m68k.c (floating_exact_log2): Use real_exponent + and real_2expN instead of a loop. + * doc/tm.texi (REAL_VALUE_LDEXP): Remove. + (REAL_VALUE_RNDZINT, REAL_VALUE_UNSIGNED_RNDZINT): Remove. + +2002-08-25 Andre Leis + David Billinghurst + + * sysdep.c (__gnat_ttyname): include on cygwin + +2002-08-13 Rainer Orth + + * Make-lang.in (gnatbind$(exeext)): Link with $(SYSLIBS). + Remove $(CONFIG_H) dependency. + +2002-08-08 Nathan Sidwell + + * ada/Make-lang.in (ada.mostlyclean): Remove coverage files. + +2002-07-29 Kaveh R. Ghazi + + * adadecode.c (ada_demangle): Use xstrdup in lieu of + xmalloc/strcpy. + * misc.c (gnat_decode_option): Likewise. + +2002-07-15 Florian Weimer + + * make.adb (Add_Switch): Make Generic_Position a procedure. The + function approach did not work well because of a side effect (the + function call could reallocate the table which was being indexed + using its result). Fixes ada/4851. [RESURRECTED] + +2002-07-01 Roger Sayle + + * ada/utils.c (builtin_function): Accept an additional parameter. + +2002-06-28 Andreas Jaeger + + PR ada/7144 + * Makefile.in: Fix typo in comment, patch by Adrian Knoth + . + +2002-06-24 Kaveh R. Ghazi + + * Makefile.in (SHELL): Set to @SHELL@. + +2002-06-20 Kaveh R. Ghazi + + * utils.c (init_gigi_decls): Use ARRAY_SIZE in lieu of explicit + array size calculation. + +2002-06-04 Andreas Jaeger + + * Make-lang.in (gnatbind): Readd rule that has been lost in last + patch. + +2002-06-03 Geoffrey Keating + + Merge from pch-branch: + + * config-lang.in (gtfiles): Add ada-tree.h. + * ada-tree.h (SET_TYPE_CI_CO_LIST): New. + (SET_TYPE_MODULUS): New. + (SET_TYPE_INDEX): New. + (SET_TYPE_DIGITS_VALUE): New. + (SET_TYPE_RM_SIZE): New. + (SET_TYPE_UNCONSTRAINED_ARRAY): New. + (SET_TYPE_ADA_SIZE): New. + (SET_TYPE_ACTUAL_BOUNDS): New. + (SET_DECL_CONST_CORRESPONDING_VAR): New. + (SET_DECL_ORIGINAL_FIELD): New. + (TREE_LOOP_ID): Correct typo. + * decl.c: Use new macros. + * utils.c: Include debug.h, use new macros. + * utils2.c: Use new macros. + + * ada-tree.h: Update all macros for new tree description. + (struct tree_loop_id): New. + (union lang_tree_node): New. + (struct lang_decl): New. + (struct lang_type): New. + * misc.c (gnat_mark_tree): Delete. + (LANG_HOOKS_MARK_TREE): Delete. + * trans.c (tree_transform): No longer any need to cast + for TREE_LOOP_ID. + + * utils.c (struct language_function): New dummy structure. + + * Makefile.in (decl.o): gt-ada- is in objdir, not srcdir. + (misc.o): Likewise. + (utils.o): Likewise; also gtype-ada.h. + * Make-lang.in (gnat1): Add dependency on s-gtype. + (gnatbind): Add dependency on $(CONFIG_H). + * utils.c: Correct last #include. + (stuct e_stack): Remove unnecessary 'static'. + (mark_e_stack): Remove unused prototype. + + * scn-nlit.adb: Remove whitespace after version number to + keep lines under 80 chars. + * snames.adb: Likewise. + * treepr.ads: Likewise. + + * Makefile.in (decl.o): Include gt-ada-.h. + (misc.o): Likewise. + (utils.o): Include gt-ada-.h and gtype-ada.h. + * config-lang.in (gtfiles): New. + * decl.c: Use gengtype for roots. + * gigi.h: Use gengtype for roots. + * trans.c: Use gengtype for roots. + * utils.c: Use gengtype for roots, marking. Include gtype-ada.h. + +2002-06-02 Gabriel Dos Reis + + * misc.c (gnat_init): Adjust setting of internal_error_function. + +2002-06-01 Joseph S. Myers + + * gnat_ug.texi: Use @ifnottex instead of @ifinfo. + * gnat_ug_unx.texi, gnat_ug_vms.texi, gnat_ug_vxw.texi, + gnat_ug_wnt.texi: Regenerate. + +2002-05-31 Florian Weimer + + * 5ntaprop.adb (with System.OS_Primitives): Remove. + + * cstreams.c (max_path_len): Move from here ... + * adaint.c (__gnat_max_path_len): ... to here. + * adaint.c (__gnat_max_path_len): Declare. + * g-dirope.adb (Max_Path): Adjust. + * g-os_lib.adb (Normalize_Pathname.Max_Path): Adjust. + * i-cstrea.ads (max_path_len): Adjust. + * osint.adb (Get_RTS_Search_Dir.Max_Path): Adjust. + * xr_tabls.adb (Dir_Name.Max_Path: Adjust. + + * Makefile.in, Make-lang.in: Documentation is now built in + Make-lang.in. Store Info and generated Texinfo files in the + source directory. + * gnat_ug.texi: Remove CVS keywords, correct version number. + Set file name correctly. + + * gnat_ug_*.texi: Add. + * .cvsignore: Ignore generated Texinfo files. + +2002-05-30 Zack Weinberg + + * ada.h: Add MI guard macro. + (SUBTYPE): Define constants with an anonymous enum, not static + const variables. + (IN): Cast constants to appropriate type before use. + +2002-05-26 Joseph S. Myers + + * gnatvsn.ads (Gnat_Version_String): Change to "3.2 20020526 + (experimental)". + +2002-05-23 Rainer Orth + + * Make-lang.in (CP, ECHO): Copy from Makefile.in. + (X_ADA_CFLAGS, T_ADA_CFLAGS, X_ADAFLAGS, T_ADAFLAGS): Likewise. + (ALL_ADAFLAGS, FORCE_DEBUG_ADAFLAGS, ADA_CFLAGS): Likewise. + (ALL_ADA_CFLAGS): Likewise. + (ADA_INCLUDES): Likewise. + Adapt for new working dir. + (GNATBIND): Use Makefile.in version. + (.SUFFIXES): Copy from Makefile.in. + (ada-warn): Define. + (.adb.o, .ads.o): Copy from Makefile.in. + Added $(OUTPUT_OPTION). + (GNAT1_C_OBJS): Moved from Makefile.in. + Prefix with ada subdir. + (GNAT_ADA_OBJS, GNAT1_ADA_OBJS, GNAT1_OBJS, GNATBIND_OBJS): Likewise. + (EXTRA_GNAT1_OBJS): Moved from Makefile.in. + Adapt for new working dir. + (EXTRA_GNATBIND_OBJS): Likewise. + (ADA_BACKEND): Moved from Makefile.in. + Renamed to avoid conflict with global BACKEND. + Use that one. + (TARGET_ADA_SRCS): Moved from Makefile.in. + (gnat1$(exeext)): Replaced recursive rule with Makefile.in version. + Use ADA_BACKEND. + (gnatbind$(exeext)): Replaced recursive rule with Makefile.in version. + (ada_extra_files): Moved from Makefile.in. + Prefix with ada subdir. + (ada/b_gnat1.c, ada/b_gnat1.o, ada/b_gnatb.c, ada/b_gnatb.o): Likewise. + (ada/treeprs.ads, ada/einfo.h, ada/sinfo.h, ada/nmake.adb): Likewise. + (ada/nmake.ads): Likewise. + (update-sources): Moved from Makefile.in. + Prefix with ada subdir. + (ada/sdefault.adb, ada/stamp-sdefault, ada/sdefault.o): Likewise. + (ADA_TREE_H): Likewise. + (ada/a-except.o, ada/s-assert.o, ada/s-memory.o): Likewise. + (ada/memtrack.o): Likewise. + (ada/adadecode.o): Likewise. + Update dependencies. + (ada/adaint.o): New. + (ada/argv.o): Moved from Makefile.in. + Prefix with ada subdir. + Update dependencies. + (ada/cstreams.o, ada/exit.o, ada/final.o, ada/link.o): Likewise. + (ada/cio.o, ada/init.o, ada/raise.o, ada/tracebak.o): Likewise. + (ada/cuintp.o, ada/decl.o, ada/misc.o): Moved from Makefile.in. + Prefix with ada subdir. + (ada/targtyps.o, ada/trans.o, ada/utils.o, ada/utils2.o): Likewise. + (GNAT DEPENDENCIES): Regenerate. + * Makefile.in (MACHMODE_H, RTL_H, TREE_H): Removed, provided by + toplevel Makefile.in. + (EXTRA_GNAT1_OBJS, EXTRA_GNATBIND_OBJS): Removed. + (TARGET_ADA_SRCS): Removed. + (GNAT1_C_OBJS, GNAT_ADA_OBJS, GNAT1_ADA_OBJS, GNAT1_OBJS): Likewise. + (GNATBIND_OBJS): Likewise. + (ADA_INCLUDE_DIR, ADA_RTL_OBJ_DIR): Moved here. + (BACKEND): Removed. + (../gnat1$(exeext), ../gnatbind$(exeext)): Likewise. + (TREE_H): Likewise. + (ada_extra_files): Likewise. + (b_gnat1.c, b_gnat1.o, b_gnatb.c, b_gnatb.o): Likewise. + (treeprs.ads, einfo.h, sinfo.h, nmake.adb, nmake.ads): Likewise. + (update-sources): Likewise. + (sdefault.adb, stamp-sdefault, sdefault.o): Likewise + (ADA_TREE_H): Likewise. + (adadecoce.o): Likewise. + (cuintp.o, decl.o, misc.o, trans.o, utils.o, utils2.o): Likewise. + (GNAT DEPENDENCIES): Likewise. + +2002-05-16 Rainer Orth + + * Makefile.adalib: Allow for PWDCMD to override hardcoded pwd. + * Makefile.in: Likewise. + +2002-05-14 Rainer Orth + + * Make-lang.in (gnat1$(exeext), gnatbind$(exeext), gnattools): + Restore $(CONFIG_H) and prefix.o dependencies. + (ada.stage[1-4]): Depend on stage?-start. + + * Makefile.in (b_gnatb.c): Depend on interfac.o. + +2002-05-02 Jim Wilson + + * utils.c (finish_record_type): Change record_size to record_type. + +2001-05-02 John David Anglin + + * ada/Makefile.in (X_ADA_CFLAGS, T_ADA_CFLAGS): New fragment overrides. + (ALL_ADA_CFLAGS): Define. Replace ADA_CFLAGS with ALL_ADA_CFLAGS in + ALL_ADAFLAGS, MOST_ADAFLAGS, and all compilations using CC. + +2002-04-25 Neil Booth + + * misc.c (gnat_parse_file): Update. + +2002-04-24 Neil Booth + + * misc.c (gnat_init): Don't set lang_attribute_common. + +2002-04-21 Joseph S. Myers + + * gnat_rm.texi: Use @ifnottex instead of @ifinfo. + +2002-04-21 Florian Weimer + + * gnat_ug.texi: New file. + + * gnat_rm.texi: Do not include texiplus.texi. Include fdl.texi + instead of gfdl.texi + + * xgnatug.adb, ug_words: New files. + + * Makefile.in (doc, dvi): New targets. Build gnat_ug_*, + gnat_rm and gnat-style manuals. + +2002-04-18 Neil Booth + + * gigi.h (incomplete_type_error): Remove. + * utils.c (incomplete_type_error): Remove. + +2002-04-16 Mark Mitchell + + * trans.c (tree_transform): Add has_scope argument to + expand_start_stmt_expr. + +2002-04-04 Neil Booth + + * gigi.h (truthvalue_conversion): Rename. + * misc.c (LANG_HOOKS_TRUTHVALUE_CONVERSION): Redefine. + * trans.c (tree_transform): Update. + * utils2.c (truthvalue_conversion): Rename, update. + (build_binary_op, build_unary_op): Update. + +2002-04-04 Laurent Guerby + + * make.adb: Implement -margs, remove restriction about file name placement. + * makeusg.adb: Documentation update. + * Makefile.in (TOOLS_FLAGS_TO_PASS): Add VPATH=$(fsrcdir). + * Makefile.in (gnattools3): Comment out, gnatmem does not build without libaddr2line. + +2002-04-04 Neil Booth + + * utils.c (create_subprog_decl): Use SET_DECL_ASSEMBLER_NAME. + (builtin_function): Similarly. + +2002-04-01 Neil Booth + + * decl.c (gnat_to_gnu_entity): Update. + * gigi.h (mark_addressable): Rename. + * misc.c (LANG_HOOKS_MARK_ADDRESSABLE): Redefine. + * trans.c (tree_transform): Update. + * utils.c (create_var_decl): Update. + * util2.c (build_binary_op, build_unary_op, + fill_vms_descriptor): Update. + (mark_addressable): Rename, update. + +2002-04-01 Neil Booth + + * gigi.h (unsigned_type, signed_type, signed_or_unsigned_type): + Rename. + * misc.c (LANG_HOOKS_SIGNED_TYPE, LANG_HOOKS_UNSIGNED_TYPE, + LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE): New. + * trans.c (tree_transform, convert_with_check): Update. + * utils.c (unsigned_type, signed_type, signed_or_unsigned_type): + Rename. + +2002-03-31 Neil Booth + + * gigi.h (finish_incomplete_decl): Rename. + * misc.c (LANG_HOOKS_FINISH_INCOMPLETE_DECL): Redefine. + * utils.c (gnat_init_decl_processing): Don't set hook. + (finish_incomplete_decl): Rename. + +2002-03-29 Andreas Schwab + + * Makefile.in: Pass VPATH=$(fsrcdir) when calling make in rts + directory. + +2001-03-28 Robert Dewar + + * checks.ads: + (Remove_Checks): New procedure + + * checks.adb: + (Remove_Checks): New procedure + + * exp_util.adb: + Use new Duplicate_Subexpr functions + (Duplicate_Subexpr_No_Checks): New procedure + (Duplicate_Subexpr_No_Checks_Orig): New procedure + (Duplicate_Subexpr): Restore original form (checks duplicated) + (Duplicate_Subexpr): Call Remove_Checks + + * exp_util.ads: + (Duplicate_Subexpr_No_Checks): New procedure + (Duplicate_Subexpr_No_Checks_Orig): New procedure + Add 2002 to copyright notice + + * sem_util.adb: Use new Duplicate_Subexpr functions + + * sem_eval.adb: + (Eval_Indexed_Component): This is the place to call + Constant_Array_Ref and to replace the value. We simply merge + the code of this function in here, since it is now no longer + used elsewhere. This fixes the problem of the back end not + realizing we were clever enough to see that this was + constant. + (Expr_Val): Remove call to Constant_Array_Ref + (Expr_Rep_Val): Remove call to Constant_Array_Ref + Minor reformatting + (Constant_Array_Ref): Deal with string literals (patch + suggested by Zack Weinberg on the gcc list) + +2001-03-28 Ed Schonberg + + * exp_util.adb: Duplicate_Subexpr_No_Checks_Orig => + Duplicate_Subexpr_Move_Checks. + + * exp_util.ads: Duplicate_Subexpr_No_Checks_Orig => + Duplicate_Subexpr_Move_Checks. + + * sem_eval.adb: (Constant_Array_Ref): Verify that constant + value of array exists before retrieving it (it may a private + protected component in a function). + +2002-03-28 Geert Bosch + + * prj-pp.adb : New file. + + * prj-pp.ads : New file. + +2002-03-28 Andreas Jaeger + + * Makefile.in (stamp-sdefault): Fix path for Makefile. + +2002-03-28 Neil Booth + + * misc.c (gnat_expand_expr): Move prototype. + +2002-03-27 Neil Booth + + * misc.c (insert_default_attributes): Remove. + +2002-03-27 Neil Booth + + * misc.c (LANG_HOOKS_EXPAND_EXPR): Redefine. + (gnat_init): Don't set hook. + (gnat_expand_expr): Fix prototype. + +2002-03-27 Neil Booth + + * misc.c (ggc_p): Remove. + +2002-03-27 Geert Bosch + + * prj-makr.ads, prj-makr.adb : New files. + +2002-03-26 Neil Booth + + * misc.c (LANG_HOOKS_MARK_TREE): Redefine. + (lang_mark_tree): Make static, rename. + +2002-03-25 Neil Booth + + * misc.c (maybe_build_cleanup): Remove. + +2002-03-24 Neil Booth + + * gigi.h (yyparse): Remove. + +2002-03-23 Florian Weimer + + From Ben Brosgol + * gnat_rm.texi: Sync with ACT version. + +2002-03-20 Neil Booth + + * misc.c (LANG_HOOKS_DECL_PRINTABLE_NAME): Redefine. + (gnat_init): Remove old hook. + +2002-03-17 Neil Booth + + * misc.c (LANG_HOOKS_PARSE_FILE): Redefine. + (yyparse): Rename gnat_parse_file. + +2002-03-14 Geoffrey Keating + + Delete all lines containing "$Revision:". + * xeinfo.adb: Don't look for revision numbers. + * xnmake.adb: Likewise. + * xsinfo.adb: Likewise. + * xsnames.adb: Likewise. + * xtreeprs.adb: Likewise. + +2002-03-12 Kaveh R. Ghazi + + * misc.c (gnat_tree_code_type, gnat_tree_code_length, + gnat_tree_code_name): Delete. + (tree_code_type, tree_code_length, tree_code_name): Define. + (gnat_init): Don't try to copy into the various tree_code + arrays. + +2002-03-11 Richard Henderson + + * Makefile.in (.NOTPARALLEL): Add fake tag. + +2002-03-07 Geert Bosch + + * adadecode.c, adadecode.h, aux-io.c, s-traces.adb, s-traces.ads, + s-tratas.adb, s-tratas.ads, sinput-d.adb, sinput-d.ads, + switch-b.adb, switch-b.ads, switch-c.adb, switch-c.ads, + switch-m.adb, switch-m.ads : New files. + +2002-03-07 Geert Bosch + + * 41intnam.ads, 42intnam.ads, 4aintnam.ads, 4cintnam.ads, + 4dintnam.ads, 4gintnam.ads, 4hintnam.ads, 4lintnam.ads, + 4mintnam.ads, 4pintnam.ads, 4rintnam.ads, 4sintnam.ads, + 4uintnam.ads, 4vcalend.adb, 4zintnam.ads, 52system.ads, + 5amastop.adb, 5asystem.ads, 5ataprop.adb, 5atpopsp.adb, + 5avxwork.ads, 5bosinte.adb, 5bsystem.ads, 5esystem.ads, + 5fsystem.ads, 5ftaprop.adb, 5ginterr.adb, 5gmastop.adb, + 5gsystem.ads, 5gtaprop.adb, 5gtasinf.adb, 5gtasinf.ads, + 5hparame.ads, 5hsystem.ads, 5htaprop.adb, 5htraceb.adb, + 5itaprop.adb, 5ksystem.ads, 5kvxwork.ads, 5lintman.adb, + 5lsystem.ads, 5mvxwork.ads, 5ninmaop.adb, 5nosinte.ads, + 5ntaprop.adb, 5ointerr.adb, 5omastop.adb, 5oosinte.adb, + 5osystem.ads, 5otaprop.adb, 5otaspri.ads, 5pvxwork.ads, + 5qtaprop.adb, 5sintman.adb, 5ssystem.ads, 5staprop.adb, + 5stpopse.adb, 5svxwork.ads, 5tosinte.ads, 5uintman.adb, + 5vasthan.adb, 5vinmaop.adb, 5vinterr.adb, 5vintman.adb, + 5vmastop.adb, 5vparame.ads, 5vsystem.ads, 5vtaprop.adb, + 5vtpopde.adb, 5wmemory.adb, 5wsystem.ads, 5wtaprop.adb, + 5ysystem.ads, 5zinterr.adb, 5zintman.adb, 5zosinte.adb, + 5zosinte.ads, 5zsystem.ads, 5ztaprop.adb, 6vcpp.adb, 6vcstrea.adb, + 7sintman.adb, 7staprop.adb, 7stpopsp.adb, 9drpc.adb, + Make-lang.in, Makefile.in, a-caldel.adb, a-comlin.ads, + a-dynpri.adb, a-except.adb, a-except.ads, a-finali.adb, + a-ncelfu.ads, a-reatim.adb, a-retide.adb, a-stream.ads, + a-ststio.adb, a-ststio.ads, a-stwifi.adb, a-tags.adb, a-tasatt.adb, + a-textio.adb, a-tideau.adb, a-tiflau.adb, a-tigeau.adb, + a-tigeau.ads, a-tiinau.adb, a-timoau.adb, a-witeio.adb, + a-wtdeau.adb, a-wtenau.adb, a-wtflau.adb, a-wtgeau.adb, + a-wtgeau.ads, a-wtinau.adb, a-wtmoau.adb, ada-tree.def, ada-tree.h, + adaint.c, adaint.h, ali-util.adb, ali.adb, ali.ads, atree.adb, + atree.ads, atree.h, back_end.adb, bcheck.adb, bindgen.adb, + bindusg.adb, checks.adb, comperr.adb, config-lang.in, csets.adb, + csets.ads, cstand.adb, cstreams.c, debug.adb, debug.ads, decl.c, + einfo.adb, einfo.ads, einfo.h, elists.h, errout.adb, errout.ads, + eval_fat.adb, exp_aggr.adb, exp_attr.adb, exp_ch11.adb, + exp_ch12.adb, exp_ch13.adb, exp_ch2.adb, exp_ch3.adb, exp_ch3.ads, + exp_ch4.adb, exp_ch5.adb, exp_ch6.adb, exp_ch7.adb, exp_ch7.ads, + exp_ch9.adb, exp_ch9.ads, exp_dbug.adb, exp_dbug.ads, exp_disp.ads, + exp_dist.adb, exp_fixd.adb, exp_intr.adb, exp_pakd.adb, + exp_prag.adb, exp_strm.adb, exp_util.adb, exp_util.ads, + expander.adb, expect.c, fe.h, fmap.adb, fmap.ads, fname-uf.adb, + freeze.adb, frontend.adb, g-awk.adb, g-cgideb.adb, g-comlin.adb, + g-comlin.ads, g-debpoo.adb, g-dirope.adb, g-dirope.ads, + g-dyntab.adb, g-expect.adb, g-expect.ads, g-io.ads, g-io_aux.adb, + g-io_aux.ads, g-locfil.adb, g-locfil.ads, g-os_lib.adb, + g-os_lib.ads, g-regexp.adb, g-regpat.adb, g-socket.adb, + g-socket.ads, g-spipat.adb, g-table.adb, g-trasym.adb, + g-trasym.ads, gigi.h, gmem.c, gnat1drv.adb, gnatbind.adb, gnatbl.c, + gnatchop.adb, gnatcmd.adb, gnatdll.adb, gnatfind.adb, gnatlbr.adb, + gnatlink.adb, gnatls.adb, gnatmem.adb, gnatprep.adb, gnatvsn.ads, + gnatxref.adb, hlo.adb, hostparm.ads, i-cobol.adb, i-cpp.adb, + i-cstrea.ads, i-cstrin.adb, i-pacdec.adb, i-vxwork.ads, + impunit.adb, init.c, inline.adb, io-aux.c, layout.adb, lib-load.adb, + lib-util.adb, lib-writ.adb, lib-writ.ads, lib-xref.adb, + lib-xref.ads, lib.adb, lib.ads, make.adb, makeusg.adb, mdll.adb, + memroot.adb, misc.c, mlib-tgt.adb, mlib-utl.adb, mlib-utl.ads, + mlib.adb, namet.adb, namet.ads, namet.h, nlists.h, nmake.adb, + nmake.ads, nmake.adt, opt.adb, opt.ads, osint.adb, osint.ads, + output.adb, output.ads, par-ch2.adb, par-ch3.adb, par-ch5.adb, + par-prag.adb, par-tchk.adb, par-util.adb, par.adb, prj-attr.adb, + prj-dect.adb, prj-env.adb, prj-env.ads, prj-nmsc.adb, prj-part.adb, + prj-proc.adb, prj-strt.adb, prj-tree.adb, prj-tree.ads, prj.adb, + prj.ads, raise.c, raise.h, repinfo.adb, restrict.adb, restrict.ads, + rident.ads, rtsfind.adb, rtsfind.ads, s-arit64.adb, s-asthan.adb, + s-atacco.adb, s-atacco.ads, s-auxdec.adb, s-crc32.adb, s-crc32.ads, + s-direio.adb, s-fatgen.adb, s-fileio.adb, s-finimp.adb, + s-gloloc.adb, s-gloloc.ads, s-interr.adb, s-mastop.adb, + s-mastop.ads, s-memory.adb, s-parame.ads, s-parint.adb, + s-pooglo.adb, s-pooloc.adb, s-rpc.adb, s-secsta.adb, s-sequio.adb, + s-shasto.adb, s-soflin.adb, s-soflin.ads, s-stache.adb, + s-taasde.adb, s-taasde.ads, s-tadeca.adb, s-tadeca.ads, + s-tadert.adb, s-tadert.ads, s-taenca.adb, s-taenca.ads, + s-taprob.adb, s-taprop.ads, s-tarest.adb, s-tasdeb.adb, + s-tasini.adb, s-tasini.ads, s-taskin.adb, s-taskin.ads, + s-tasque.adb, s-tasque.ads, s-tasren.adb, s-tasren.ads, + s-tassta.adb, s-tasuti.adb, s-tasuti.ads, s-tataat.adb, + s-tataat.ads, s-tpoben.adb, s-tpoben.ads, s-tpobop.adb, + s-tposen.adb, s-tposen.ads, s-traceb.adb, s-traceb.ads, + s-unstyp.ads, s-widenu.adb, scn-nlit.adb, scn.adb, sem.adb, + sem_aggr.adb, sem_attr.adb, sem_attr.ads, sem_case.adb, + sem_ch10.adb, sem_ch11.adb, sem_ch11.ads, sem_ch12.adb, + sem_ch13.adb, sem_ch13.ads, sem_ch2.adb, sem_ch3.adb, sem_ch3.ads, + sem_ch4.adb, sem_ch5.adb, sem_ch6.adb, sem_ch6.ads, sem_ch7.adb, + sem_ch8.adb, sem_ch8.ads, sem_ch9.adb, sem_disp.adb, sem_dist.adb, + sem_elab.adb, sem_elim.adb, sem_elim.ads, sem_eval.adb, + sem_intr.adb, sem_mech.adb, sem_prag.adb, sem_res.adb, + sem_type.adb, sem_util.adb, sem_util.ads, sem_vfpt.adb, + sem_warn.adb, sinfo.adb, sinfo.ads, sinfo.h, sinput-l.adb, + sinput-l.ads, sinput.adb, sinput.ads, snames.adb, snames.ads, + snames.h, sprint.adb, sprint.ads, stringt.adb, stringt.ads, + stringt.h, style.adb, switch.adb, switch.ads, sysdep.c, system.ads, + table.adb, targparm.adb, targparm.ads, targtyps.c, tbuild.adb, + tbuild.ads, tracebak.c, trans.c, tree_gen.adb, tree_io.adb, + treepr.adb, treepr.ads, treeprs.ads, treeprs.adt, ttypes.ads, + types.adb, types.ads, types.h, uintp.ads, urealp.ads, usage.adb, + utils.c, utils2.c, validsw.adb, xnmake.adb, xr_tabls.adb, + xr_tabls.ads, xref_lib.adb, xref_lib.ads : Merge in ACT changes. + + * 1ssecsta.adb, 1ssecsta.ads, a-chlat9.ads, a-cwila9.ads, + g-enblsp.adb, g-md5.adb, g-md5.ads, gnatname.adb, gnatname.ads, + mkdir.c, osint-b.adb, osint-b.ads, osint-c.adb, osint-c.ads, + osint-l.adb, osint-l.ads, osint-m.adb, osint-m.ads : New files + + * 3lsoccon.ads, 5qparame.ads, 5qvxwork.ads, 5smastop.adb, + 5zparame.ads, gnatmain.adb, gnatmain.ads, gnatpsys.adb : Removed + + * mdllfile.adb, mdllfile.ads, mdlltool.adb, mdlltool.ads : Renamed + to mdll-fil.ad[bs] and mdll-util.ad[bs] + + * mdll-fil.adb, mdll-fil.ads, mdll-utl.adb, mdll-utl.ads : Renamed + from mdllfile.ad[bs] and mdlltool.ad[bs] + +2002-03-03 Kaveh R. Ghazi + + * utils.c (init_gnat_to_gnu, init_gigi_decls): Use ARRAY_SIZE in + lieu of explicit sizeof/sizeof. + +2002-02-28 Neil Booth + + * misc.c (copy_lang_decl): Remove. + +2002-02-27 Zack Weinberg + + * misc.c: Delete traditional-mode-related code copied from the + C front end but not used, or used only to permit the compiler + to link. + +2002-02-07 Richard Henderson + + * adaint.c (__gnat_to_gm_time): First arg is int, not time_t. + * adaint.h (__gnat_to_gm_time): Update prototype. + +2002-01-30 Richard Henderson + + * trans.c (tree_transform) [N_Loop_Statement]: Use + expand_exit_loop_top_cond. + + + +Copyright (C) 2002 Free Software Foundation, Inc. + +Copying and distribution of this file, with or without modification, +are permitted in any medium without royalty provided the copyright +notice and this notice are preserved. diff --git a/gcc/ada/ChangeLog-2003 b/gcc/ada/ChangeLog-2003 new file mode 100644 index 000000000..6b950685e --- /dev/null +++ b/gcc/ada/ChangeLog-2003 @@ -0,0 +1,3021 @@ +2003-12-23 Kelley Cook + + * gnat_ug.texi: Force a CVS commit by updating copyright. + * gnat_ug_vxw.texi: Regenerate. + * gnat_ug_wnt.texi: Regenerate. + * gnat_ug_vms.texi: Regenerate. + * gnat_ug_unx.texi: Regenerate. + +2003-12-20 Kazu Hirata + + * trans.c: Remove uses of "register" specifier in + declarations of local variables. + +2003-12-18 Kelley Cook + + * stamp-xgnatug: New stamp file. + * Make-lang.in (stamp-xgnatug): New stamp file and comment. + (ada/doctools/xgnatug): Add $(build_exeext). + (ada/gnat_ug_unx.texi, ada/gnat_ug_vwx.texi, ada/gnat_ug_vms.texi + ada/gnat_ug_wnt.texi): Update to depend on stamp-xgnatug. + +2003-12-17 Ed Falis + + * a-elchha.adb (Tailored_Exception_Information): made Info constant to + eliminate warning. + + * a-exextr.adb: Add context clause for + Ada.Exceptions.Last_Chance_Handler. + +2003-12-17 Sergey Rybin + + * cstand.adb (Create_Standard): Change the way how the declaration of + the Duration type is created (making it the same way as it is for all + the other standard types). + +2003-12-17 Robert Dewar + + * s-crtl.ads: Fix header format + Change Pure to Preelaborate + +2003-12-17 Ed Schonberg + + * checks.adb (Selected_Length_Checks): Generate an Itype reference for + the expression type only if it is declared in the current unit. + + * sem_ch3.adb (Constrain_Index): Handle properly a range whose bounds + are universal and already analyzed, as can occur in constrained + subcomponents that depend on discriminants, when one constraint is a + subtype mark. + + * sem_res.adb (Resolve_Type_Conversion): Any arithmetic expression of + type Any_Fixed is legal as the argument of a conversion, if only one + fixed-point type is in context. + +2003-12-17 GNAT Script + + * Make-lang.in: Makefile automatically updated + +2003-12-15 Robert Dewar + + * exp_ch6.adb (Expand_Thread_Body): Fix error in picking up default + sec stack size. + +2003-12-15 Vincent Celier + + * gnatchop.adb: (Error_Msg): Do not exit on error for a warning + (Gnatchop): Do not set failure status when reporting the number of + warnings. + +2003-12-15 Doug Rupp + + * s-ctrl.ads: New file. + + * Makefile.rtl (GNAT_RTL_NONTASKING_OBJS): Add s-crtl$(objext). + + * Make-lang.in: (GNAT_ADA_OBJS): Add ada/s-crtl.o. + (GNATBIND_OBJS): Add ada/s-crtl.o. + + * Makefile.in [VMS]: Clean up ifeq rules. + + * gnatlink.adb, 6vcstrea.adb, a-direio.adb, a-sequio.adb, + a-ststio.adb, a-textio.adb, g-os_lib.adb, a-witeio.adb, + g-os_lib.ads, i-cstrea.adb, i-cstrea.ads, s-direio.adb, + s-fileio.adb, s-memcop.ads, s-memory.adb, s-stache.adb, + s-tasdeb.adb: Update copyright. + Import System.CRTL. + Make minor modifications to use System.CRTL declared functions instead + of importing locally. + +2003-12-15 GNAT Script + + * Make-lang.in: Makefile automatically updated + +2003-12-11 Ed Falis + + * 5zinit.adb: Clean up. + + * 5zintman.adb (Notify_Exception): replaced case statement with a call + to __gnat_map_signal, imported from init.c to support + signal -> exception mappings that depend on the vxWorks version. + + * init.c: + Created and exported __gnat_map_signal to support signal -> exception + mapping that is dependent on the VxWorks version. + Change mapping of SIGBUS from Program_Error to Storage_Error on VxWorks + +2003-12-11 Vasiliy Fofanv + + * 5wosinte.ads: Link with -mthreads switch. + +2003-12-11 Arnaud Charlet + + * init.c (__gnat_install_handler [NetBSD]): Set + __gnat_handler_installed, as done on all other platforms. + Remove duplicated code. + +2003-12-11 Jerome Guitton + + * Makefile.in (rts-zfp, rts-ravenscar): Create libgnat.a. + +2003-12-11 Thomas Quinot + + * sinfo.ads: Fix inconsistent example code in comment. + +2003-12-11 Robert Dewar + + * a-tiinau.adb: Add a couple of comments + + * sem_ch3.adb: Minor reformatting + + * sem_prag.adb: + Fix bad prototype of Same_Base_Type in body (code reading cleanup) + Minor reformatting throughout + +2003-12-11 Ed Schonberg + + * exp_ch7.adb (Establish_Transient_Scope): If the call is within the + bounds of a loop, create a separate block in order to generate proper + cleanup actions to prevent memory leaks. + + * sem_res.adb (Resolve_Call): After a call to + Establish_Transient_Scope, the call may be rewritten and relocated, in + which case no further processing is needed. + + * sem_util.adb: (Wrong_Type): Refine previous fix. + Fixes ACATS regressions. + + PR ada/13353 + * sem_prag.adb (Back_End_Cannot_Inline): A renaming_as_body can always + be inlined. + +2003-12-08 Jerome Guitton + + * 5ytiitho.adb, 5zthrini.adb, 5ztiitho.adb, i-vthrea.adb, + i-vthrea.ads, s-tpae65.adb, s-tpae65.ads: Cleanup: Remove a bunch of + obsolete files. + + * Makefile.in: (rts-ravenscar): Generate an empty libgnat.a. + (rts-zfp): Ditto. + +2003-12-08 Robert Dewar + + * 7sintman.adb: Minor reformatting + + * bindgen.adb: Configurable_Run_Time mode no longer suppresses the + standard linker options to get standard libraries linked. We now plan + to provide dummy versions of these libraries to match the appropriate + configurable run-time (e.g. if a library is not needed at all, provide + a dummy empty library). + + * targparm.ads: Configurable_Run_Time mode no longer affects linker + options (-L parameters and standard libraries). What we plan to do is + to provide dummy libraries where the libraries are not required. + + * gnatbind.adb: Minor comment improvement + +2003-12-08 Javier Miranda + + * exp_aggr.adb (Build_Record_Aggr_Code): Do not remove the expanded + aggregate in the parent. Otherwise constants with limited aggregates + are not supported. Add new formal to pass the component type (Ctype). + It is required to call the corresponding IP subprogram in case of + default initialized components. + (Gen_Assign): In case of default-initialized component, generate a + call to the IP subprogram associated with the component. + (Build_Record_Aggr_Code): Remove the aggregate from the parent in case + of aggregate with default initialized components. + (Has_Default_Init_Comps): Improve implementation to recursively check + all the present expressions. + + * exp_ch3.ads, exp_ch3.adb (Build_Initialization_Call): Add new formal + to indicate that the initialization call corresponds to a + default-initialized component of an aggregate. + In case of default initialized aggregate with tasks this parameter is + used to generate a null string (this is just a workaround that must be + improved later). In case of discriminants, this parameter is used to + generate a selected component node that gives access to the discriminant + value. + + * exp_ch9.ads, exp_ch9.adb (Build_Task_Allocate_Block_With_Stmts): New + subprogram, based on Build_Task_Allocate_Block, but adapted to expand + allocated aggregates with default-initialized components. + + * par-ch4.adb (P_Aggregate_Or_Paren_Expr): Improve error message if + the box notation is used in positional aggregates. + +2003-12-08 Samuel Tardieu + + * lib.ads: Fix typo in comment + +2003-12-08 Vincent Celier + + * prj.adb (Project_Empty): New component Unkept_Comments + (Scan): Remove procedure; moved to Prj.Err. + + * prj.ads (Project_Data): New Boolean component Unkept_Comments + (Scan): Remove procedure; moved to Prj.Err. + + * prj-dect.adb: Manage comments for the different declarations. + + * prj-part.adb (With_Record): New component Node + (Parse): New Boolean parameter Store_Comments, defaulted to False. + Set the scanner to return ends of line and comments as tokens, if + Store_Comments is True. + (Pre_Parse_Context_Clause): Create the N_With_Clause nodes so that + comments are associated with these nodes. Store the node IDs in the + With_Records. + (Post_Parse_Context_Clause): Use the N_With_Clause nodes stored in the + With_Records. + (Parse_Single_Project): Call Pre_Parse_Context_Clause before creating + the N_Project node. Call Tree.Save and Tree.Reset before scanning the + current project. Call Tree.Restore afterwards. Set the various nodes + for comment storage (Next_End, End_Of_Line, Previous_Line, + Previous_End). + + * prj-part.ads (Parse): New Boolean parameter Store_Comments, + defaulted to False. + + * prj-pp.adb (Write_String): New Boolean parameter Truncated, defaulted + to False. When Truncated is True, truncate the string, never go to the + next line. + (Write_End_Of_Line_Comment): New procedure + (Print): Process comments for nodes N_With_Clause, + N_Package_Declaration, N_String_Type_Declaration, + N_Attribute_Declaration, N_Typed_Variable_Declaration, + N_Variable_Declaration, N_Case_Construction, N_Case_Item. + Process nodes N_Comment. + + * prj-tree.ads, prj-tree.adb (Default_Project_Node): If it is a node + without comments and there are some comments, set the flag + Unkept_Comments to True. + (Scan): If there are comments, set the flag Unkept_Comments to True and + clear the comments. + (Project_Node_Kind): Add enum values N_Comment_Zones, N_Comment + (Next_End_Nodes: New table + (Comment_Zones_Of): New function + (Scan): New procedure; moved from Prj. Accumulate comments in the + Comments table and set end of line comments, comments after, after end + and before end. + (Add_Comments): New procedure + (Save, Restore, Seset_State): New procedures + (There_Are_Unkept_Comments): New function + (Set_Previous_Line_Node, Set_Previous_End_Node): New procedures + (Set_End_Of_Line, Set_Next_End_Node, Remove_Next_End_Node): New + procedures. + (First_Comment_After, First_Comment_After_End): New functions + (First_Comment_Before, First_Comment_Before_End): New functions + (Next_Comment): New function + (End_Of_Line_Comment, Follows_Empty_Line, + Is_Followed_By_Empty_Line): New functions + (Set_First_Comment_After, Set_First_Comment_After_End): New procedures + (Set_First_Comment_Before, Set_First_Comment_Before_End): New procedures + (Set_Next_Comment): New procedure + (Default_Project_Node): Associate comment before if the node can store + comments. + + * scans.ads (Token_Type): New enumeration value Tok_Comment + (Comment_Id): New global variable + + * scng.ads, scng.adb (Comment_Is_Token): New Boolean global variable, + defaulted to False. + (Scan): Store position of start of comment. If comments are tokens, set + Comment_Id and set Token to Tok_Comment when scanning a comment. + (Set_Comment_As_Token): New procedure + + * sinput-p.adb: Update Copyright notice + (Source_File_Is_Subunit): Call Prj.Err.Scanner.Scan instead of Prj.Scan + that no longer exists. + +2003-12-08 Javier Miranda + + * sem_aggr.adb: Add dependence on Exp_Tss package + Correct typo in comment + (Resolve_Aggregate): In case of array aggregates set the estimated + type of the aggregate before calling resolve. This is needed to know + the name of the corresponding IP in case of limited array aggregates. + (Resolve_Array_Aggregate): Delay the resolution to the expansion phase + in case of default initialized array components. + + * sem_ch12.adb (Analyze_Formal_Object_Declaration): Allow limited + types. Required to give support to limited aggregates in generic + formals. + +2003-12-08 Ed Schonberg + + * sem_ch3.adb (Check_Initialization): For legality purposes, an + inlined body functions like an instantiation. + (Decimal_Fixed_Point_Declaration): Do not set kind of first subtype + until bounds are analyzed, to diagnose premature use of type. + + * sem_util.adb (Wrong_Type): Improve error message when the type of + the expression is used prematurely. + +2003-12-08 GNAT Script + + * Make-lang.in: Makefile automatically updated + +2003-12-08 Arnaud Charlet + + * sinfo.h, einfo.h, nmake.ads, nmake.adb, treeprs.ads: Removed, since + they are automatically generated by Make-lang.in and cause nothing but + maintenance troubles. + +2003-12-05 Thomas Quinot + + * 3ssoliop.ads: Fix comment (this is the Solaris, not the UnixWare, + version of this unit). + +2003-12-05 Olivier Hainque + + * 53osinte.ads, 54osinte.ads, 55osinte.ads, 56osinte.ads, 5bosinte.ads, + 5cosinte.ads, 5hosinte.ads, 5iosinte.ads, 5losinte.ads, + 5tosinte.ads: Define the SA_SIGINFO constant, to allow references from + the body of System.Interrupt_Management common to several targets. + Update copyright notice when appropriate. + + * 52osinte.ads, 5posinte.ads: Define a dummy value for the SA_SIGINFO + constant. + + * 7sintman.adb (elaboration): Set SA_SIGINFO in the sigaction flags, + to ensure that the kernel fills in the interrupted context structure + before calling a signal handler, which is necessary to be able to + unwind past it. Update the copyright notice. + +2003-12-05 Jerome Guitton + + * a-elchha.ads: New file. + + * a-elchha.adb: New default last chance handler. Contents taken from + Ada.Exceptions.Exception_Traces.Unhandled_Exception_Terminate. + + * a-exextr.adb (Unhandled_Exception_Terminate): Most of this routine + is moved to a-elchha.adb to provide a target-independent default last + chance handler. + + * Makefile.rtl: Add a-elchha.o + + * Make-lang.in (GNAT_ADA_OBJS, GNATBIND_OBJS): Add a-elchha.o. + +2003-12-05 Ed Schonberg + + * exp_ch6.adb (Expand_Call): If the subprogram is inlined and is + declared in an instance, do not inline the call if the instance is not + frozen yet, to prevent order of elaboration problems. + + * sem_prag.adb: Add comments for previous fix. + +2003-12-05 Samuel Tardieu + + * g-table.adb: Use the right variable in Set_Item. + Update copyright notice. + +2003-12-05 Arnaud Charlet + + * Makefile.in: Remove unused rules. + +2003-12-05 Vincent Celier + + * switch-c.adb (Scan_Front_End_Switches): Remove processing of + -nostdlib. Not needed here after all. + +2003-12-03 Thomas Quinot + + PR ada/11724 + * adaint.h, adaint.c, g-os_lib.ads: + Do not assume that the offset argument to lseek(2) is a 32 bit integer, + on some platforms (including FreeBSD), it is a 64 bit value. + Introduce a __gnat_lseek wrapper in adaint.c to allow for portability. + +2003-12-03 Arnaud Charlet + + * gnatvsn.ads (Library_Version): Now contain only the relevant + version info. + (Verbose_Library_Version): New constant. + + * g-spipat.adb, g-awk.adb, g-debpoo.adb, + g-memdum.adb, g-thread.adb, s-geveop.adb, s-interr.adb, + s-taskin.adb, s-tassta.adb: Make code compile with -gnatwa. + + * gnatlbr.adb: Clean up: replace Library_Version by + Verbose_Library_Version. + + * make.adb, lib-writ.adb, exp_attr.adb: + Clean up: replace Library_Version by Verbose_Library_Version. + + * 5lintman.adb: Removed. + + * Makefile.in: + Update and simplify computation of LIBRARY_VERSION. + Fix computation of GSMATCH_VERSION. + 5lintman.adb is no longer used: replaced by 7sintman.adb. + +2003-12-03 Robert Dewar + + * exp_ch5.adb: + (Possible_Bit_Aligned_Component): Maybe_Bit_Aligned_Large_Component new + name. Modified to consider small non-bit-packed arrays as troublesome + and in need of component-by-component assigment expansion. + +2003-12-03 Vincent Celier + + * lang-specs.h: Process nostdlib as nostdinc + + * back_end.adb: Update Copyright notice + (Scan_Compiler_Arguments): Process -nostdlib directly. + +2003-12-03 Jose Ruiz + + * Makefile.in: + When defining LIBGNAT_TARGET_PAIRS for bare board targets, remove the + redundant inclusion of EXTRA_HIE_NONE_TARGET_PAIRS, which is always + included in HIE_NONE_TARGET_PAIRS. + +2003-12-03 Ed Schonberg + + * sem_attr.adb: + (Legal_Formal_Attribute): Attribute is legal in an inlined body, as it + is legal in an instance, because legality is cheched in the template. + + * sem_prag.adb: + (Analyze_Pragma, case Warnings): In an inlined body, the pragma may be + appplied to an unchecked conversion of a formal parameter. + + * sem_warn.adb: + (Output_Unreferenced_Messages): Suppress "not read" warnings on imported + variables. + +2003-12-03 Olivier Hainque + + * tb-alvms.c (unwind_regular_code, unwind_kernel_handler): New + routines. The second one is new functionality to deal with backtracing + through signal handlers. + (unwind): Split into the two separate subroutines above. + Update the documentation, and deal properly with sizeof (REG) different + from sizeof (void*). + +2003-12-01 Nicolas Setton + + * a-except.adb (Raise_Current_Excep): Add a pragma Inspection_Point, + so that the debugger can reliably access the value of the parameter, + and therefore is able to display the exception name when an exception + breakpoint is reached. + +2003-12-01 Thomas Quinot + + * fmap.adb: Fix typo in warning message. + + * g-socket.ads, g-socket.adb: Make Free a visible instance of + Ada.Unchecked_Deallocation (no need to wrap it in a subprogram). + +2003-12-01 Vincent Celier + + * mlib-prj.adb (Build_Library.Process): Do not check a withed unit if + ther is no Afile. + (Build_Library): Get the switches only if Default_Switches is declared + in package Binder. + +2003-12-01 Ed Schonberg + + * exp_ch6.adb (Expand_Actuals): When applying validity checks to + actuals that are indexed components, reanalyze actual to ensure that + packed array references are properly expanded. + + * sem_ch5.adb (Diagnose_Non_Variable_Lhs): Add special case for + attempted assignment to a discriminant. + +2003-12-01 Robert Dewar + + * rtsfind.adb, exp_ch4.adb, s-exnint.ads, s-exnint.adb: Minor + reformatting. + + * switch-c.adb: Minor reformatting of comments + +2003-12-01 Arnaud Charlet + + * Makefile.in: Clean ups. + +2003-12-01 GNAT Script + + * Make-lang.in: Makefile automatically updated + +2003-12-01 Arnaud Charlet + + * 5wsystem.ads: Disable zero cost exception, not ready yet. + +2003-11-29 Ulrich Weigand + + * Make-lang.in (nmake.ads): Add dependency on ada/nmake.adb + to force serialization. + +2003-11-26 Thomas Quinot + + * g-socket.ads, g-socket.adb: + Clarify documentation of function Stream. Introduce a Free procedure + to release the returned Stream once it becomes unused. + + * 5asystem.ads: For Alpha Tru64, enable ZCX by default. + +2003-11-26 Arnaud Charlet + + (Cond_Timed_Wait): Introduce new constant Time_Out_Max, + since NT 4 cannot handle timeout values that are too large, + e.g. DWORD'Last - 1. + +2003-11-26 Ed Schonberg + + * exp_ch4.adb: + (Expand_N_Slice): Recognize all cases of slices that appear as actuals + in procedure calls and whose expansion must be deferred. + + * exp_ch6.adb (Add_Call_By_Copy_Node): Remove previous fix. Proper fix + is in exp_ch4. + + * sem_ch3.adb: + (Build_Derived_Array_Type): Create operator for unconstrained type + if ancestor is unconstrained. + +2003-11-26 Vincent Celier + + * make.adb (Project_Object_Directory): New global variable + (Change_To_Object_Directory): New procedure + (Collect_Arguments_And_Compile): Call Change_To_Object_Directory instead + of Change_Dir directly. Do not change working directory to object + directory of main project after each compilation. + (Gnatmake): Use Change_To_Object_Directory instead of Change_Dir + directly. + Change to object directory of main project before binding step. + (Initialize): Initialize Project_Object_Directory to No_Project + + * mlib-prj.adb: + (Build_Library): Take into account Builder'Default_Switches ("Ada") when + binding a Stand-Alone Library. + + * output.adb: Update Copyright notice + (Write_Char): Output buffer when full + +2003-11-26 Robert Dewar + + * sem_ch13.adb: (Check_Size): Reset size if size is too small + + * sem_ch13.ads: + (Check_Size): Fix documentation to include bit-packed array case + + * sem_res.adb: Implement restriction No_Direct_Boolean_Operators + + * s-rident.ads: Put No_Direct_Boolean_Operators in proper order + + * s-rident.ads: Add new restriction No_Direct_Boolean_Operators + +2003-11-24 Arnaud Charlet + + PR ada/13142 + * utils.c (init_gigi_decls): Change name of built-in setjmp to + __builtin_setjmp, since this is apparently needed by recent + non Ada changes. + +2003-11-24 Rainer Orth + + * adadecode.c: Only include ctype.h if not IN_GCC. + (__gnat_decode): Use ISDIGIT from safe-ctype.h. + +2003-11-24 Jose Ruiz + + * Makefile.in: + Use 5zintman.ads for VxWorks targets. This file avoid confusion between + signals and interrupts. + + * 5zintman.ads: New File. + + * 5zintman.adb: Replace Exception_Interrupts by Exception_Signals, and + add exception signals to the set of unmasked signals. + + * 5ztaprop.adb: + Use Abort_Task_Signal instead of Abort_Task_Interrupt to avoid confusion + between signals and interrupts. + Add to Unblocked_Signal_Mask the set of signals that are in + Keep_Unmasked. + + * 7sinmaop.adb: + Adding a check to see whether the Interrupt_ID we want to unmask is in + the range of Keep_Unmasked (in procedure Interrupt_Self_Process). The + reason is that the index type of the Keep_Unmasked array is not always + Interrupt_ID; it may be a subtype of Interrupt_ID. + +2003-11-24 Gary Dismukes + + * exp_util.adb: + (Remove_Side_Effects): Condition constantness of object created for a + an unchecked type conversion on the constantness of the expression + to ensure the correct value for 'Constrained when passing components + of view-converted class-wide objects. + +2003-11-24 Robert Dewar + + * par-load.adb (Load): Improve handling of misspelled and missing units + Removes several cases of compilation abandoned messages + + * lib.adb: (Remove_Unit): New procedure + + * lib.ads: (Remove_Unit): New procedure + + * lib-load.adb: Minor reformatting + +2003-11-24 Vincent Celier + + * make.adb: + (Gnatmake, Initialize): Call Usage instead of Makeusg directly + (Marking_Label): Label to mark processed source files. Incremented for + each executable. + (Gnatmake): Increase Marking_Labet for each executable + (Is_Marked): Compare against marking label + (Mark): Mark with marking label + +2003-11-24 Jerome Guitton + + * s-thread.ads: + Move the declaration of the TSD for System.Threads to System.Soft_Links. + Add some comments. + + * Makefile.in: Added target pair for s-thread.adb for cert runtime. + (rts-cert): build a single relocatable object for the run-time lib. + Fix perms. + +2003-11-24 Vasiliy Fofanov + + * Make-lang.in: + Use gnatls rather than gcc to obtain the location of GNAT RTL for + crosstools build. + +2003-11-24 Sergey Rybin + + * opt.adb (Tree_Write): Gnat_Version_String is now a function, so we + can not use it as before (that is, as a variable) when dumping it into + the tree file. Add a local variable to store the result of this + function and to be used as the string to be written into the tree. + + * scn.adb (Initialize_Scanner): Add comments explaining the recent + changes. + + * sinput.adb (Source_First, Source_Last): In case of + Internal_Source_File, replace returning attributes of + Internal_Source_Ptr (which is wrong) with returning attributes of + Internal_Source. + +2003-11-24 Ed Schonberg + + * sem_ch3.adb: + (New_Concatenation_Op): Proper name for New_Binary_Operator, only + used for implicit concatenation operators. + Code cleanup. + + * sem_elab.adb: + (Check_Elab_Call): Set No_Elaboration_Check appropriately on calls in + task bodies that are in the scope of a Suppress pragma. + (Check_A Call): Use the flag to prevent spurious elaboration checks. + + * sinfo.ads, sinfo.adb: + New flag No_Elaboration_Check on function/procedure calls, to properly + suppress checks on calls in task bodies that are within a local suppress + pragma. + + * exp_ch4.adb: + (Expand_Concatenate_Other): Use the proper integer type for the + expression for the upper bound, to avoid universal_integer computations + when possible. + +2003-11-21 Kelley Cook + + * .cvsignore: Delete. + +2003-11-21 Andreas Schwab + + * 55system.ads: Set ZCX_By_Default and GCC_ZCX_Support to True. + +2003-11-21 Vasiliy Fofanov + + * 5wsystem.ads: Enable zero cost exception. + +2003-11-21 Jerome Guitton + + * 5ztiitho.adb: Remove an unreferenced variable. + +2003-11-21 Thomas Quinot + + * adaint.c: For FreeBSD, use mkstemp. + +2003-11-21 Arnaud Charlet + + * gnatlbr.adb: Now reference Gnat_Static_Version_String. + +2003-11-21 Robert Dewar + + * bld.adb: Remove useless USE of gnatvsn + + * gnatchop.adb: Minor reformatting + Clean up version handling to be more consistent + + * gnatxref.adb: Minor reformatting + + * gprcmd.adb: Minor reformatting + Fix output of copyright to be more consistent with other tools + +2003-11-21 Vincent Celier + + * make.adb (Scan_Make_Args): Do not transmit --RTS= to gnatlink + +2003-11-21 Sergey Rybin + + * atree.adb (Initialize): Add initializations for global variables + used in New_Copy_Tree. + + * cstand.adb (Create_Standard): Add call to Initialize_Scanner (with + Internal_Source_File as the actual). + Put the set of statements creating Any_Character before the set of + statements creating Any_Array to have Any_Character fully initialized + when it is used in creating Any_Array. + + * scn.adb (Initialize_Scanner): Do not set Comes_From_Source ON and do + not call Scan in case if the actual is Internal_Source_File + Add 2003 to copyright note. + + * sinput.adb (Source_First, Source_Last, Source_Text): Add code for + processing Internal_Source_File. + + * types.ads: Add the constant Internal_Source_File representing the + source buffer for artificial source-code-like strings created within + the compiler (the definition of Source_File_Index is changed). + +2003-11-20 Arnaud Charlet + + * 35soccon.ads, 45intnam.ads, 55osinte.adb, 55osinte.ads, + 56system.ads: New file, FreeBSD version. + +2003-11-20 Joseph S. Myers + + * Make-lang.in (ada.extraclean): Delete. + +2003-11-19 Arnaud Charlet + + * gnatmem.adb: Clean up verbose output. + + * gprcmd.adb: Change copyright to FSF. + +2003-11-19 Vincent Celier + + * symbols.adb: (Initialize): New parameters Reference, Symbol_Policy + and Version (ignored). + + * symbols.ads: (Policy): New type + (Initialize): New parameter Reference, Symbol_Policy and + Library_Version. + Remove parameter Force. + Minor reformatting. + + * snames.ads, snames.adbadb: New standard names + Library_Reference_Symbol_File and Library_Symbol_Policy + + * mlib-prj.adb: + (Build_Library): Call Build_Dinamic_Library with the Symbol_Data of the + project. + + * mlib-tgt.adb: + (Build_Dynamic_Library): New parameter Symbol_Data (ignored) + + * mlib-tgt.ads: (Build_Dynamic_Library): New parameter Symbol_Data + + * prj.adb: (Project_Empty): New component Symbol_Data + + * prj.ads: (Policy, Symbol_Record): New types + (Project_Data): New component Symbol_Data + + * prj-attr.adb: + New attributes Library_Symbol_File, Library_Symbol_Policy and + Library_Reference_Symbol_File. + + * prj-nmsc.adb: + (Ada_Check): When project is a Stand-Alone library project, process + attribute Library_Symbol_File, Library_Symbol_Policy and + Library_Reference_Symbol_File. + + * 5aml-tgt.adb, 5bml-tgt.adb, 5gml-tgt.adb, 5hml-tgt.adb, + 5wml-tgt.adb, 5zml-tgt.adb, 5lml-tgt.adb, + 5sml-tgt.adb (Build_Dynamic_Library): New parameter + Symbol_Data (ignored). + + * 5vml-tgt.adb (VMS_Options): Remove --for-linker=gsmatch=equal,1,0 + (Build_Dynamic_Library): New parameter Symbol_Data. New internal + functions Option_File_Name and Version_String. Set new options of + gnatsym related to symbol file, symbol policy and reference symbol + file. + + * 5vsymbol.adb: + Extensive modifications to take into account the reference symbol file, + the symbol policy, the library version and to put in the symbol file the + minor and major IDs. + + * bld.adb (Process_Declarative_Items): Put second argument of + gprcmd to_absolute between single quotes, to avoid problems with + Windows. + + * bld-io.adb: Update Copyright notice. + (Flush): Remove last character of a line, if it is a back slash, to + avoid make problems. + + * gnatsym.adb: + Implement new scheme with reference symbol file and symbol policy. + + * g-os_lib.ads: (Is_Directory): Clarify comment + +2003-11-19 Robert Dewar + + * atree.adb: Move New_Copy_Tree global variables to head of package + + * errout.adb: Minor reformatting + +2003-11-19 Javier Miranda + + * sem_ch4.adb: (Diagnose_Call): Improve error message. + Add reference to Ada0Y (AI-50217) + + * sem_ch6.adb, sem_ch8.adb, sem_type.adb, + sem_util.adb: Add reference to AI-50217 + + * sinfo.ads: (N_With_Clause): Document fields referred to AI-50217 + + * sprint.adb: Add reference to Ada0Y (AI-50217, AI-287) + + * sem_aggr.adb: Complete documentation of AI-287 changes + + * par-ch4.adb: Document previous changes. + + * lib-load.adb, lib-writ.adb, einfo.ads, par-ch10.adb, + sem_cat.adb, sem_ch3.adb, sem_ch10.adb, sem_ch12.adb: Add references to + Ada0Y (AI-50217) + + * exp_aggr.adb: Add references to AI-287 in previous changes + +2003-11-19 Ed Schonberg + + * exp_ch6.adb: + (Add_Call_By_Copy_Node): Do not original node of rewritten expression + in the rewriting is the result of an inlined call. + + * exp_ch6.adb (Add_Call_By_Copy_Node): If actual for (in-)out + parameter is a type conversion, use original node to construct the + post-call assignment, because expression may have been rewritten, e.g. + if it is a packed array. + + * sem_attr.adb: + (Resolve_Attribute, case 'Constrained): Attribute is legal in an inlined + body, just as it is in an instance. + Categorization routines + + * sem_ch12.adb (Analyze_Association, Instantiate_Formal_Subprogram, + Instantiate_Object): Set proper sloc reference for message on missing + actual. + +2003-11-19 Thomas Quinot + + * Makefile.in: Add FreeBSD libgnat pairs. + + * usage.adb: Fix typo in usage message. + +2003-11-19 Jerome Guitton + + * Makefile.in: On powerpc-wrs-vxworksae: Add s-thread.ad?, + s-thrini.ad? and s-tiitho.adb to the full runtime, to support the + pragma Thread_Body. + Remove i-vthrea.ad? and s-tpae65.ad?, not needed anymore. + + * s-thread.adb: This file is now a dummy implementation of + System.Thread. + +2003-11-19 Sergey Rybin + + * rtsfind.adb (Initialize): Add initialization for RTE_Is_Available + +2003-11-19 Emmanuel Briot + + * xref_lib.adb (Parse_Identifier_Info): Add handling of generic + instanciation references in the parent type description. + +2003-11-18 Richard Kenner + + * ada-tree.def: (ALLOCATE_EXPR): Class is "2", not "s". + + * decl.c (gnat_to_gnu_entity, case E_Floating_Point_Subtype): Set + TYPE_PRECISION directly from esize. + +2003-11-18 Thomas Quinot + + * cstreams.c: + Use realpath(3) on FreeBSD. Fix typo in comment while we are at it. + + * init.c: Initialization routines for FreeBSD + + * link.c: Link info for FreeBSD + + * sysdep.c: Add the case of FreeBSD + +2003-11-17 Jerome Guitton + + * 5zthrini.adb: Remove the call to Init_RTS at elaboration, as it is + already called in System.Threads. + + * 5ztiitho.adb (Initialize_Task_Hooks): Remove the registration of the + environment task, as it has been moved to System.Threads.Initialization. + +2003-11-17 Arnaud Charlet + + * adaint.c (__gnatlib_install_locks): Only reference + __gnat_install_locks on VMS, since other platforms can avoid using + --enable-threads=gnat + +2003-11-17 Richard Kenner + + * ada-tree.h: (TYPE_IS_PACKED_ARRAY_TYPE_P): New macro. + + * decl.c (gnat_to_gnu_entity, case E_Array_Subtype): Set + TYPE_PACKED_ARRAY_TYPE_P. + (validate_size): Do not verify size if TYPE_IS_PACKED_ARRAY_TYPE_P. + + Part of PR ada/12806 + * utils.c (float_type_for_precision): Renamed from float_type_for_size. + Use GET_MODE_PRECISION instead of GET_MODE_BITSIZE. + +2003-11-17 Vincent Celier + + * gnatchop.adb (Error_Msg): New Boolean parameter Warning, defaulted + to False. + Do not set exit status to Failure when Warning is True. + (Gnatchop): Make errors "no compilation units found" and + "no source files written" warnings only. + + * make.adb (Gnatmake): When using a project file, set + Look_In_Primary_Dir to False. + (Configuration_Pragmas_Switch): Check for Global_Configuration_Pragmas + and Local_Configuration_Pragmas in the project where they are declared + not an extending project which might have inherited them. + + * osint.adb (Locate_File): If Name is already an absolute path, do not + look for a directory. + + * par-ch10.adb (P_Compilation_Unit): If source contains no token, and + -gnats (Check_Syntax) is used, issue only a warning, not an error. + + * prj.adb (Register_Default_Naming_Scheme): Add new component Project + in objects of type Variable_Value. + + * prj.ads: (Variable_Value): New component Project + + * prj-nmsc.adb (Ada_Check.Warn_If_Not_Sources): No warning if source + is in a project extended by Project. + + * prj-proc.adb (Add_Attributes): New parameter Project. Set component + Project of Variable_Values to this new parameter value. + (Expression): Set component Project of Variable_Values. + (Process_Declarative_Items): Call Add_Attributes with parameter Project. + Set the component Project in array elements. + +2003-11-17 Sergey Rybin + + * errout.adb: (Initialize): Add initialization for error nodes. + + * sem_ch12.adb (Initialize): Add missing initializations for + Exchanged_Views and Hidden_Entities. + +2003-11-17 Ed Schonberg + + * sem_ch12.adb (Copy_Generic_Node): Preserve entity when copying an + already instantiated tree for use in subsequent inlining. + (Analyze_Associations, Instantiate_Formal_Subprogram, + Instantiate_Object): improve error message for mismatch in + instantiations. + + * sem_ch6.adb (Build_Body_To_Inline): Major cleanup to handle + instantiations of subprograms declared in instances. + +2003-11-17 Javier Miranda + + * sem_ch4.adb (Analyze_Allocator): Previous modification must be + executed only under the Extensions_Allowed flag. + +2003-11-17 Robert Dewar + + * a-exexda.adb (Address_Image): Fix documentation to indicate leading + zeroes suppressed. + (Address_Image): Fix bug of returning 0x instead of 0x0 + Minor reformatting (function specs). + + * einfo.ads: Minor fix for documentation of Is_Bit_Packed_Array + (missed case of 33-63) + + * freeze.adb, sem_ch13.adb: Properly check size of packed bit array + + * s-thread.adb: Add comments for pragma Restriction + + * exp_aggr.adb, g-debuti.adb, par-ch4.adb, sem_aggr.adb, + sem_ch6.adb, sprint.adb, xref_lib.adb: Minor reformatting + +2003-11-17 Ed Falis + + * s-thread.adb: Added No_Tasking restriction for this implementation. + +2003-11-17 Emmanuel Briot + + * xref_lib.adb (Parse_Identifier_Info): Add handling of generic + instanciation references in the parent type description. + +2003-11-17 GNAT Script + + * Make-lang.in: Makefile automatically updated + +2003-11-16 Jason Merrill + + * Make-lang.in (ada.tags): Create TAGS.sub files in each directory + and TAGS files that include them for each front end. + +2003-11-14 Andreas Jaeger + + * lang.opt: Change -Wno-long-long to -Wlong-long since the latter + is the canonical version. + * misc.c (gnat_handle_option): Likewise. + + * Makefile.in (LIBGNAT_TARGET_PAIRS): Add rules for x86_64-linux. + + * 5nsystem.ads: New file for x86_64-linux-gnu. + +2003-11-14 Arnaud Charlet + + * nmake.ads, nmake.adb, sinfo.h, treeprs.ads: Regenerated. + + * comperr.adb: Fix logic in previous change. + +2003-11-13 Vincent Celier + + * 5bml-tgt.adb (Build_Dynamic_Library): Use + Osint.Include_Dir_Default_Prefix instead of + Sdefault.Include_Dir_Default_Name. + + * gnatlbr.adb: Update Copyright notice + (Gnatlbr): : Use Osint.Include_Dir_Default_Prefix instead of + Sdefault.Include_Dir_Default_Name and Osint.Object_Dir_Default_Prefix + instead of Sdefault.Object_Dir_Default_Name + + * gnatlink.adb: + (Process_Binder_File): Never suppress the option following -Xlinker + + * mdll-utl.adb: + (Gcc): Use Osint.Object_Dir_Default_Prefix instead of + Sdefault.Object_Dir_Default_Name. + + * osint.ads, osint.adb: + (Include_Dir_Default_Prefix, Object_Dir_Default_Prefix): New functions + Minor reformatting. + + * vms_conv.ads: Minor reformating + Remove GNAT STANDARD and GNAT PSTA + + * vms_conv.adb: + Allow GNAT MAKE to have several files on the command line. + (Init_Object_Dirs): Use Osint.Object_Dir_Default_Prefix instead of + Sdefault.Object_Dir_Default_Name. + Minor Reformating + Remove data for GNAT STANDARD + + * vms_data.ads: + Add new compiler qualifier /PRINT_STANDARD (-gnatS) + Remove data for GNAT STANDARD + Remove options and documentation for -gnatwb/-gnatwB: these warning + options no longer exist. + +2003-11-13 Ed Falis + + * 5zthrini.adb: (Init_RTS): Made visible + + * 5zthrini.adb: + (Register): Removed unnecessary call to taskVarGet that checked whether + an ATSD was already set as a task var for the argument thread. + + * s-thread.adb: + Updated comment to reflect that this is a VxWorks version + Added context clause for System.Threads.Initialization + Added call to System.Threads.Initialization.Init_RTS + +2003-11-13 Jerome Guitton + + * 5zthrini.adb: + (Init_RTS): New procedure, for the initialization of the run-time lib. + + * s-thread.adb: + Remove dependancy on System.Init, so that this file can be used in the + AE653 sequential run-time lib. + +2003-11-13 Robert Dewar + + * bindgen.adb: Minor reformatting + +2003-11-13 Ed Schonberg + + * checks.adb: + (Apply_Discriminant_Check): Do no apply check if target type is derived + from source type with no applicable constraint. + + * lib-writ.adb: + (Ensure_System_Dependency): Do not apply the style checks that may have + been specified for the main unit. + + * sem_ch8.adb: + (Find_Selected_Component): Further improvement in error message, with + RM reference. + + * sem_res.adb: + (Resolve): Handle properly the case of an illegal overloaded protected + procedure. + +2003-11-13 Javier Miranda + + * exp_aggr.adb: + (Has_Default_Init_Comps): New function to check the presence of + default initialization in an aggregate. + (Build_Record_Aggr_Code): Recursively expand the ancestor in case of + extension aggregate of a limited record. In addition, a new formal + was added to do not initialize the record controller (if any) during + this recursive expansion of ancestors. + (Init_Controller): Add support for limited record components. + (Expand_Record_Aggregate): In case of default initialized components + convert the aggregate into a set of assignments. + + * par-ch4.adb (P_Aggregate_Or_Paren_Expr): Update the comment + describing the new syntax. + Nothing else needed to be done because this subprogram delegates part of + its work to P_Precord_Or_Array_Component_Association. + (P_Record_Or_Array_Component_Association): Give support to the new + syntax for default initialization of components. + + * sem_aggr.adb: + (Resolve_Aggregate): Relax the strictness of the frontend in case of + limited aggregates. + (Resolve_Record_Aggregate): Give support to default initialized + components. + (Get_Value): In case of default initialized components, duplicate + the corresponding default expression (from the record type + declaration). In case of default initialization in the *others* + choice, do not check that all components have the same type. + (Resolve_Extension_Aggregate): Give support to limited extension + aggregates. + + * sem_ch3.adb: + (Check_Initialization): Relax the strictness of the front-end in case + of aggregate and extension aggregates. This test is now done in + Get_Value in a per-component manner. + + * sem_ch4.adb (Analyze_Allocator): Don't post an error if the + expression corresponds to a limited aggregate. This test is now done + in Get_Value. + + * sinfo.ads, sinfo.adb (N_Component_Association): Addition of + Box_Present flag. + + * sprint.adb (Sprint_Node_Actual): Modified to print an mbox if + present in an N_Component_Association node + +2003-11-13 Thomas Quinot + + * sem_ch9.adb (Analyze_Accept_Statement): A procedure hides a + type-conformant entry only if they are homographs. + +2003-11-13 GNAT Script + + * Make-lang.in: Makefile automatically updated + +2003-11-12 Rainer Orth + + * adadecode.c: Use <> form of include for ctype.h. + * sysdep.c [IN_RTS]: Use <> form of include for time.h. + +2003-11-12 Rainer Orth + + * 5gsystem.ads (Functions_Return_By_DSP): Set to False. + Works around PR middle-end/6552. + +2003-11-10 Ed Falis + + * 5ytiitho.adb: (procStartHookAdd): Definition and call deleted + + * 5zinit.adb: (Install_Handler): Moved back to spec + (Install_Signal_Handlers): Deleted + + * 5zthrini.adb: Added context clause for System.Storage_Elements + (Register): Only handles creation of taskVar; initialization moved to + Thread_Body_Enter. + (Reset_TSD): Deleted; replaced by Thread_Body_Enter + Added declaration of environment task secondary stack and + initialization. + + * s-thread.adb: Implement bodies for thread body processing + + * s-thread.ads: + Added comment identifying supported targets for pragma Thread_Body. + +2003-11-10 Pascal Obry + + * adaint.c (_gnat_stat) [WIN32]: Check if name is not bigger than + GNAT_MAX_PATH_LEN. + + * s-fileio.adb: + (Open): Properly check for string length before copying into the buffer. + Raises Name_Error if buffer is too small. Note that this was a potential + buffer overflow. + +2003-11-10 Romain Berrendonner + + * bindgen.adb, comperr.adb: Code clean ups. + * gnatvsn.ads, gnatvsn.adb (Get_Gnat_Version_Type): New function. + +2003-11-10 Sergey Rybin + + * gnat1drv.adb: Add call to Sem_Elim.Initialize. + +2003-11-10 Vincent Celier + + * gprcmd.adb: + (Gprcmd): Add new command "prefix" to get the prefix of the GNAT + installation. + + * make.adb (Scan_Make_Arg): Transmit -nostdlib to the compiler + + * prj.adb: (Project_Empty): Add new boolean component Virtual + + * prj.ads: (Virtual_Prefix): New constant string + (Project_Data): New boolean component Virtual + + * prj-nmsc.adb (Language_Independent_Check): Adjust error message when + a library project is extended by a virtual extending project. + + * prj-part.adb: + Modifications throughout to implement extending-all project, including: + (Virtual_Hash, Processed_Hash): New hash tables + (Create_Virtual_Extending_Project): New procedure + (Look_For_Virtual_Projects_For): New procedure + + * prj-proc.adb: + (Process): After checking the projects, if main project is an + extending-all project, set the object directory of all virtual extending + project to the object directory of the main project. + Adjust error message when a virtual extending project has the same + object directory as an project being extended. + (Recursive_Process): If name starts with the virtual prefix, set Virtual + to True in the project data. + + * prj-tree.adb: + (Default_Project_Node): Add new boolean component Extending_All + (Is_Extending_All): New function + (Set_Is_Extending_All): New procedure + + * prj-tree.ads: (Is_Extending_All): New function + (Set_Is_Extending_All): New procedure + (Project_Node_Record): New boolean component Extending_All + + * switch-c.adb: (Scan_Front_End_Switches): Process -nostdlib + + * vms_data.ads: + Add qualifier /NOSTD_LIBRARIES (-nostdlib) for the compiler + + * bld.adb (Recursive_Process): If MAKE_ROOT is not defined, call + "gprcmd prefix" to define it. + +2003-11-10 Thomas Quinot + + * einfo.ads: Fix a typo and remove an extraneous word in comments. + + * lib-load.adb: + (Create_Dummy_Package_Unit): Set the scope of the entity for the + created dummy package to Standard_Standard, not to itself, to + defend other parts of the front-end against encoutering a cycle in + the scope chain. + + * sem_ch10.adb: + (Analyze_With_Clause): When setting the entities for the successive + N_Expanded_Names that constitute the name of a child unit, do not + attempt to go further than Standard_Standard in the chain of scopes. + This case arises from the placeholder units created by + Create_Dummy_Package_Unit in the case of a with_clause for a + nonexistent child unit. + +2003-11-10 Ed Schonberg + + * exp_ch6.adb: + (Expand_Thread_Body): Place subprogram on scope stack, so that new + declarations are given the proper scope. + + * sem_ch13.adb: + (Check_Expr_Constants): Reject an expression that contains a constant + created during expansion, and that appears after the object to which + the address clause applies. + + * sem_ch5.adb (Check_Controlled_Array_Attribute): Subsidiary of + Analyze_Iteration_Scheme, to rewrite a loop parameter specification + that uses 'Range of a function call with controlled components, so + that the function result can be finalized before starting the loop. + + * sem_ch8.adb: + (Find_Selected_Component): Improve error message when prefix is + an implicit dereference of an incomplete type. + +2003-11-10 Robert Dewar + + * opt.ads: New Print_Standard flag for -gnatS switch + + * sem_ch13.adb: Remove some additional checks for unaligned arrays + + * cstand.adb (Create_Standard): Print out package standard if -gnatS + switch set + + * debug.adb: Update doc for -gnatds to discuss relationship with new + -gnatS flag + + * sinfo.adb: Add new field Entity_Or_Associated_Node + + * sinfo.ads: Add new field Entity_Or_Associated_Node + Update documentation for Associated_Node and Entity fields to clarify + relationship and usage. + + * sprint.adb: + (Write_Id): Properly process Associated_Node field in generic template + + * switch-c.adb: + Recognize new -gnatS switch for printing package Standard + This replaces gnatpsta + + * usage.adb: + Add line for new -gnatS switch for printing package Standard + This replaces gnatpsta + +2003-11-10 Andreas Jaeger + + * 7sosprim.adb: tv_usec of struct_timeval and time_t are long + integer. + +2003-11-10 Arnaud Charlet + + * misc.c, lang.opt: Add handling of -nostdlib, now recognized/needed + by gnat1. + +2003-11-10 Arnaud Charlet + + * Makefile.in, Make-lang.in: Remove build of gnat_wrapper and gnatpsta, + no longer needed. + + * gnatpsta.adb, gnat_wrapper.adb: Removed, no longer needed. + + * sysdep.c: Add handling of cygwin. + +2003-11-10 GNAT Script + + * Make-lang.in: Makefile automatically updated + +2003-11-10 Arnaud Charlet + + PR 12950 + * osint.ads, osint.adb (Relocate_Path, Executable_Suffix): New + functions. Used to handle dynamic prefix relocation, via set_std_prefix. + Replace GNAT_ROOT by GCC_ROOT. + + * Make-lang.in: Use new function Relocate_Path to generate sdefault.adb + +2003-11-06 Zack Weinberg + + * misc.c (fp_prec_to_size, fp_size_to_prec): Use GET_MODE_PRECISION + and update for changed meaning of GET_MODE_BITSIZE. + +2003-11-04 Doug Rupp + + * sysdep.c: Problem discovered during IA64 VMS port. + [VMS] #include to get proper prototypes. + + * adaint.c: + Issues discovered/problems fixed during IA64 VMS port. + [VMS] #define _POSIX_EXIT for proper semantics. + [VMS] #include for proper prototypes. + [VMS] (fork): #define IA64 version. + (__gnat_os_exit): Remove unnecessary VMS specific code. + +2003-11-04 Richard Kenner + + Part of PR ada/12806 + * ada-tree.h (TYPE_DIGITS_VALUE, SET_TYPE_DIGITS_VALUE): Save count as + tree, not integer. + + * decl.c: + (gnat_to_gnu_entity, case E_Floating_Point_Type): Save count as tree, + not integer. + + * targtyps.c, decl.c, misc.c, + gigi.h (fp_prec_to_size, fp_size_to_prec): Temporary + routines to work around change in FP sizing semantics in GCC. + + * utils.c: + (build_vms_descriptor): TYPE_DIGITS_VALUE is tree, not integer. + + * gigi.h: (enumerate_modes): New function. + + * Make-lang.in: (ada/misc.o): Add real.h. + + * misc.c: (enumerate_modes): New function. + +2003-11-04 Robert Dewar + + * 3vtrasym.adb: Minor reformatting + Use terminology encoded/decoded name, rather than C++ specific notion + of mangling (this is the terminology used throughout GNAT). + + * einfo.h: Regenerated + + * einfo.ads, einfo.adb: Add new flag Is_Thread_Body + + * exp_ch6.adb: + (Expand_N_Subprogram_Body): Handle expansion of thread body procedure + + * par-prag.adb: Add dummy entry for Thread_Body pragma + + * rtsfind.ads: + Add entries for System.Threads entities for thread body processing + + * sem_attr.adb: + (Analyze_Pragma, Access attributes): Check these are not applied to a + thread body, since this is not permitted + + * sem_prag.adb: Add processing for Thread_Body pragma. + Minor comment fix. + + * sem_res.adb: + (Resolve_Call): Check for incorrect attempt to call a thread body + procedure with a direct call. + + * snames.ads, snames.adb: Add entry for Thread_Body pragma + Add names associated with thread body expansion + + * snames.h: Add entry for Thread_Body pragma + + * s-thread.adb: Add entries for thread body processing + These are dummy bodies so far + + * s-thread.ads: Add documentation on thread body handling. + Add entries for thread body processing. + +2003-11-04 Javier Miranda + + * sem_ch10.adb: + (Build_Limited_Views): Return after posting an error in case of limited + with_clause on subprograms, generics, instances or generic renamings + (Install_Limited_Withed_Unit): Do nothing in case of limited with_clause + on subprograms, generics, instances or generic renamings + +2003-11-04 Arnaud Charlet + + * raise.c (setup_to_install): Correct mistake in last revision; two + arguments out of order. + + * trans.c, cuintp.c, argv.c, aux-io.c, cal.c, errno.c, exit.c, + gnatbl.c, init.c, stringt.h, utils.c, utils2.c: Update copyright + notice, missed in previous change. + Remove trailing blanks and other style errors introduced in previous + change. + +2003-11-04 Olivier Hainque + + * decl.c (gnat_to_gnu_field): Adjust the conditions under which we get + rid of the wrapper for a LJM type, ensuring we don't do that if the + field is addressable. This avoids potential low level type view + mismatches later on, for instance in a by-reference argument passing + process. + +2003-11-04 Richard Kenner + + * decl.c (gnat_to_gnu_field): No longer check for BLKmode being + aligned at byte boundary. + +2003-11-04 Joel Brobecker + + * decl.c (components_to_record): Do not delete the empty variants from + the end of the union type. + +2003-11-04 Ed Schonberg + + * exp_ch4.adb (Expand_N_Op_Eq): Use base type when locating primitive + operation for a derived type, an explicit declaration may use a local + subtype of Boolean. + +2003-11-04 Vincent Celier + + * make.adb (Gnatmake): Allow main sources on the command line with a + library project when it is only for compilation (no binding or + linking). + +2003-11-04 Rainer Orth + + * Makefile.in: Remove many duplicate variables. + +2003-11-03 Kelley Cook + + * Make-lang.in (dvi): Move targets to $(docobjdir). + (gnat_ug_vms.dvi): Simplify rule and adjust target. + (gnat_ug_wnt.dvi): Likewise. + (gnat_ug_unx.dvi): Likewise. + (gnat_ug_vxw.dvi): Likewise. + (gnat_rm.dvi): Likewise. + (gnat-style.dvi): Likewise. + +2003-10-31 Kelley Cook + + * gigi.h: Missed commit from update for C90. + +2003-10-31 Kelley Cook + + * Makefile.in (ada/b_gnat1.o): Compile with -Wno-error. + +2003-10-31 Andreas Schwab + + * raise.c (get_action_description_for): Fix typo in last change. + +2003-10-31 Nathanael Nerode + + PR ada/12761 + * ada/Make-lang.in: Move default definitions of X_ADA_CFLAGS, + T_ADA_CFLAGS, X_ADAFLAGS, T_ADAFLAGS from here to master Makefile.in. + +2003-10-30 Kelley Cook + + * adadecode.c, adaint.c, argv.c, aux-io.c, cal.c, cio.c, cstreams.c, + ctrl_c.c, cuintp.c, decl.c, errno.c, exit.c, expect.c, final.c, + gigi.h, gmem.c, gnatbl.c, init.c, misc.c, mkdir.c, raise.c, socket.c, + sysdep.c, sysdep.c, targtyps.c, tb-alvms.c, tb-alvxw.c, tracebak.c, + trans.c, utils.c, utils2.c: Convert function prototypes to C90. + +2003-10-30 Vasiliy Fofanov + + * 3vtrasym.adb: + Demangle Ada symbols returned by TBK$SYMBOLIZE. Correctly align line + numbers when symbol name is too long. + +2003-10-30 Ed Falis + + * g-signal.ads, g-signal.adb: New files + + * impunit.adb: (Non_Imp_File_Names): Added "g-signal" + + * Makefile.rtl: Introduce GNAT.Signals + +2003-10-30 Robert Dewar + + * freeze.adb: Minor reformatting + + * lib-writ.adb (Write_ALI): Never write ali file if -gnats is specified + + * par.adb, par-ch12.adb, par-ch13.adb, par-ch2.adb, par-ch3.adb, + par-ch5.adb, par-ch6.adb, par-ch9.adb, par-util.adb: + New handling of Id_Check parameter to improve recognition of keywords + used as identifiers. + Update copyright notice to include 2003 + +2003-10-29 Robert Dewar + + * 3vtrasym.adb, 5vtraent.ads, sprint.adb, + sem_ch10.adb: Minor reformatting + + * exp_ch5.adb (Expand_Assign_Array): Test for bit unaligned operands + (Expand_Assign_Record): Test right hand side for bit unaligned as well + +2003-10-29 Vasiliy Fofanov + + * 3vtrasym.adb, 5vtraent.adb, 5vtraent.ads, tb-alvms.c: + Support for TBK$SYMBOLIZE-based symbolic traceback. + +2003-10-29 Jose Ruiz + + * exp_disp.adb: + Revert previous change, that did not work well when pragma No_Run_Time + was used in conjunction with a run-time other than ZFP. + +2003-10-29 Vincent Celier + + * make.adb: + (Gnatmake): When there are no Ada mains in attribute Main, disable the + bind and link steps only is switch -z is not used. + +2003-10-29 Arnaud Charlet + + * Makefile.generic: Remove duplicated setting of CC. + + * Makefile.prolog: Set CC to gcc by default, to override make's + default (cc). + + * einfo.h: Regenerated. + +2003-10-29 Ed Schonberg + + * sem_ch10.adb (Analyze_Subunit): Restore state of suppress flags for + current body, after compiling subunit. + + * itypes.adb (Create_Itype): In ASIS_Mode, do not freeze the itype + when in deleted code, because gigi needs properly ordered freeze + actions to annotate types. + + * freeze.adb (Is_Fully_Defined): Predicate must be recursive, to + prevent the premature freezing of record type that contains + subcomponents with a private type that does not yet have a completion. + +2003-10-29 Javier Miranda + + * sem_ch12.adb: + (Analyze_Package_Instantiation): Check that instances can not be used in + limited with_clauses. + + * sem_ch8.adb: + (Analyze_Package_Renaming): Check that limited withed packages cannot + be renamed. Improve text on error messages related to limited + with_clauses. + + * einfo.adb, einfo.ads: Remove Non_Limited_Views attribute. + + * sprint.adb: (Sprint_Node_Actual): Print limited with_clauses. + Update copyright notice. + + * sem_ch10.adb: (Build_Limited_Views): Complete its documentation. + (Install_Limited_Context_Clauses): New subprogram that isolates all the + checks required for limited context_clauses and installs the limited + view. + (Install_Limited_Withed_Unit): Complete its documentation. + (Analyze_Context): Check that limited with_clauses are only allowed in + package specs. + (Install_Context): Call Install_Limited_Context_Clauses after the + parents have been installed. + (Install_Limited_Withed_Unit): Add documentation. Mark the installed + package as 'From_With_Type'; this mark indicates that the limited view + is installed. Used to check bad usages of limited with_clauses. + (Build_Limited_Views): Do not add shadow entities to the scope's list + of entities. Do not add real entities to the Non_Limited_Views chain. + Improve error notification. + (Remove_Context_Clauses): Remove context clauses in two phases: + limited views first and regular views later (to maintain the + stack model). + (Remove_Limited_With_Clause): If the package is analyzed then reinstall + its visible entities. + +2003-10-29 Thomas Quinot + + * sem_type.adb (Specific_Type): Type Universal_Fixed is compatible + with any type that Is_Fixed_Point_Type. + + * sinfo.ads: Fix documentation for Associated_Node attribute. + +2003-10-29 Sergey Rybin + + * switch-c.adb (Scan_Front_End_Switches): ASIS_Mode is set now when + both '-gnatc' and '-gnatt' are specified. + + * atree.adb (Initialize): Add initialization for Node_Count (set to + zero). + +2003-10-29 Richard Kenner + + * decl.c (gnat_to_gnu_entity, case E_Subprogram): If no return value, + do not consider as Pure. + + Part of implementation of function-at-a-time: + + * trans.c (gnat_to_gnu_code): If IS_STMT, call expand_expr_stmt. + (tree_transform): Add new argument to build_component_ref. + (tree_transform, case N_Assignment_Statement): Make and return an + EXPR_STMT. + (tree_transform): If result IS_STMT, set flags and return it. + (gnat_expand_stmt, set_lineno_from_sloc): New functions. + + * utils2.c (build_simple_component_ref, build_component_ref): Add new + arg, NO_FOLD_P. + (build_binary_op, case EQ_EXPR): Pass additional arg to it. + (build_allocator): Likewise. + + * utils.c (convert_to_fat_pointer, convert_to_thin_pointer, convert): + Add new arg to build_component_ref. + (maybe_unconstrained_array, unchecked_convert): Likewise. + + * ada-tree.def (EXPR_STMT): New code. + + * ada-tree.h (IS_STMT, TREE_SLOC, EXPR_STMT_EXPR): New macros. + + * decl.c (gnat_to_gnu_entity, case object): Add extra arg to + build_component_ref calls. + + * misc.c (gnat_expand_expr): If IS_STMT, call gnat_expand_stmt. + + * gigi.h (gnat_expand_stmt, set_lineno_from_sloc): New functions. + (build_component_ref): Add new argument, NO_FOLD_P. + +2003-10-27 Arnaud Charlet + + * Makefile.generic: Add missing substitution on object_deps handling. + + PR ada/5909 + * Make-lang.in (check-ada): Enable ACATS test suite. + +2003-10-27 Robert Dewar + + * exp_ch3.adb: + (Freeze_Array_Type): We do not need an initialization routine for types + derived from String or Wide_String. They should be treated the same + as String and Wide_String themselves. This caused problems with the + use of Initialize_Scalars. + + * exp_ch5.adb: + (Expand_Assign_Record): Do component-wise assignment of non-byte aligned + composites. This allows use of component clauses that are not byte + aligned. + + * sem_prag.adb: + (Analyze_Pragma, case Pack): Generate warning and ignore pack if there + is an attempt to pack an array of atomic objects. + + * make.adb, prj-env.adb, prj-env.ads: Minor reformatting + +2003-10-27 Pascal Obry + + * g-dirope.adb: + (Basename): Check for drive letters in a pathname only on DOS based OS. + +2003-10-27 Vincent Celier + + * make.adb: + (Gnatmake): When unable to change dir to the object dir, display the + content of the parent dir of the obj dir, to try to understand why this + happens. + +2003-10-27 GNAT Script + + * Make-lang.in: Makefile automatically updated + +2003-10-27 Ed Schonberg + + * sem_ch12.adb: + (Inline_Instance_Body): Indicate that the save/restore of use_clauses + should not be done in Save/Restore_Scope_Stack, because it is performed + locally. + + * sem_ch8.adb: + (Save_Scope_Stack, Restore_Scope_Stack): Add parameter to indicate + whether use clauses should be removed/restored. + + * sem_ch8.ads: + (Save_Scope_Stack, Restore_Scope_Stack): Add parameter to indicate + whether use clauses should be removed/restored. + +2003-10-26 Andreas Jaeger + + * Makefile.in: Remove duplicated lines. + +2003-10-24 Arnaud Charlet + + * gnatvsn.ads (Gnat_Static_Version_String): New constant, used to + minimize the differences with ACT tree. + + * gnatkr.adb, gnatlink.adb, gnatls.adb, gnatmake.adb, + gnatprep.adb, gnatpsta.adb, gnatvsn.ads: Take advantage of + Gnatvsn.Gnat_Static_Version_String to reduce differences between + ACT and FSF trees. + +2003-10-24 Pascal Obry + + PR ada/12014 + * adadecode.c (ostrcpy): New function. + (__gnat_decode): Use ostrcpy of strcpy. + (has_prefix): Set first parameter a const. + (has_suffix): Set first parameter a const. + Update copyright notice. Fix source name in header. + Removes a trailing space. + +2003-10-24 Jose Ruiz + + * exp_disp.adb: + Remove the test against being in No_Run_Time_Mode before generating a + call to Register_Tag. It is redundant with the test against the + availability of the function Register_Tag. + +2003-10-24 Vincent Celier + + * g-catiio.adb: (Month_Name): Correct spelling of February + + * make.adb: (Mains): New package + (Initialize): Call Mains.Delete + (Gnatmake): Check that each main on the command line is a source of a + project file and, if there are several mains, each of them is a source + of the same project file. + (Gnatmake): When a foreign language is specified in attribute Languages, + no main is specified on the command line and attribute Mains is not + empty, only build the Ada main. If there is no Ada main, just compile + the Ada sources and their closure. + (Gnatmake): If a main is specified on the command line with directory + information, check that the source exists and, if it does, that the path + is the actual path of a source of a project. + + * prj-env.adb: + (File_Name_Of_Library_Unit_Body): New Boolean parameter Full_Path. When + Full_Path is True, return the full path instead of the simple file name. + (Project_Of): New function + + * prj-env.ads: + (File_Name_Of_Library_Unit_Body): New Boolean parameter Full_Path, + defaulted to False. + (Project_Of): New function + +2003-10-24 Arnaud Charlet + + * Makefile.generic: + Ensure objects of main project are always checked and rebuilt if needed. + Set CC to gcc by default. + Prepare new handling of link by creating a global archive (not activated + yet). + + * adadecode.h, atree.h, elists.h, nlists.h, raise.h, + stringt.h: Update copyright notice. Remove trailing blanks. + Fix source name in header. + +2003-10-24 Robert Dewar + + * sem_ch12.adb: Minor reformatting + + * sem_ch3.adb: + Minor reformatting (including new function return style throughout) + + * sem_ch3.ads: + Minor reformatting (including new function return style throughout) + +2003-10-24 Arnaud Charlet + + * adadecode.h, atree.h, elists.h, nlists.h, raise.h, + stringt.h: Update copyright notice. Remove trailing blanks. + Fix source name in header. + +2003-10-24 GNAT Script + + * Make-lang.in: Makefile automatically updated + +2003-10-23 Nathanael Nerode + + * adadecode.h, atree.h, elists.h, namet.h, nlists.h, raise.h, + stringt.h: Convert to ISO C90 declarations and definitions. + +2003-10-23 Thomas Quinot + + PR ada/11978 + * exp_ch13.adb (Expand_N_Freeze_Entity): Do not consider inherited + External_Tag attribute definition clauses. + +2003-10-23 Ed Schonberg + + PR ada/7613 + * exp_dbug.adb (Debug_Renaming_Declaration): For the renaming of a + child unit, generate a fully qualified name to avoid spurious errors + when the context contains renamings of different child units with + the same simple name. + + * exp_dbug.ads: Add documentation on name qualification for renamings + of child units. + +2003-10-23 Robert Dewar + + * g-regpat.ads, g-regpat.adb: Minor reformatting + +2003-10-23 Jose Ruiz + + * Makefile.in: Use the file 1atags.ads with the ZFP and cert run-times. + +2003-10-23 Richard Kenner + + * trans.c: (tree_transform, case N_Real_Literal): Add extra arg to + Machine call. + + * urealp.h: (Machine): Update to proper definition. + +2003-10-23 Arnaud Charlet + + * init.c, adaint.c: Minor reformatting. + +2003-10-23 Danny Smith + + * adaint.c (w32_epoch_offset): Define static const at file level. + (win32_filetime): Replace offset with w32_epoch_offset. Use NULL + rather than t_create, t_access in call to GetFileTime. Use union + to convert between FILETIME and unsigned long long. + (__gnat_file_time_name): Test for invalid file handle. + (__gnat_set_filetime_name): Support win32 targets using + w32api SetFileTime. + +2003-10-22 Danny Smith + + * sysdep.c: Include conio.h if __MINGW32__ and !OLD_MINGW. + + * ctrl_c.c (__gnat_int_handler): Remove declaration. + + * decl.c (creat_concat_name): Const-ify prefix. + + * adaint.c: Include ctype.h if __MINGW32__. + (__gnat_readlink): Mark arguments as possibly unused. + (__gnat_symlink): Likewise. + (__gnat_is_symbolic_link): Likewise. + (__gnat_portable_spawn): Likewise. Cast last arg of spawnvp to match + declaration + (__gnat_file_time_name): Don't declare struct stat statbuf when + not needed. + (__gnat_is_absolute_path): Add parenthesis around condition of + 'if' statement to avoid warning. + (__gnat_plist_init): Specify void as parameter. + (plist_enter): Likewise. + (plist_leave): Likewise. + (remove_handle): Make static. Initialize prev. + +2003-10-22 Arnaud Charlet + + PR ada/10110 + * Makefile.in: Disable build of gnatpsta. + * cstreams.c (__gnat_full_name): Minor improvements and clean up + of previous change. + +2003-10-22 Rainer Orth + + * tracebak.c (MAX): Avoid redefinition warning. + + * init.c [sgi] (__gnat_error_handler): Remove i, unused. + Change msg to const char *. + (__gnat_install_handler): Remove ss, unused. + [sun && __SVR4 && !__vxworks] (__gnat_error_handler): Change msg + to const char *. + * cstreams.c (__gnat_full_name): Declare p only when used. + (__gnat_full_name) [sgi] Return buffer. + +2003-10-22 Arnaud Charlet + + * mingw32.h: New file. + * gnat_wrapper.adb: New file. + +2003-10-22 Jerome Roussel + + * g-regpat.ads, g-regpat.adb (Match): new function, to know if a + string match a pre compiled regular expression (the corresponding + version of the function working on a raw regular expression) + Fix typos in various comments + Update copyright notice in spec + +2003-10-21 Gary Dismukes + + * exp_ch3.adb: + (Component_Needs_Simple_Initialization): Return False when the type is a + packed bit array. Revise spec comments to document this case. + + * exp_prag.adb: + (Expand_Pragma_Import): Set any expression on the imported object to + empty to avoid initializing imported objects (in particular this + covers the case of zero-initialization of bit arrays). + Update copyright notice. + +2003-10-21 Ed Schonberg + + * sem_ch12.adb: + (Load_Parent_Of_Generic): If parent is compilation unit, stop search, + a subunit is missing. + (Instantiate_Subprogram_Body): If body of function is missing, set type + of return expression explicitly in dummy body, to prevent cascaded + errors when a subunit is missing. + Fixes PR 5677. + + * sem_ch3.adb: + (Access_Subprogram_Declaration): Verify that return type is valid. + Fixes PR 8693. + + * sem_elab.adb: + (Check_Elab_Calls): Do not apply elaboration checks if the main unit is + generic. + Fixes PR 12318. + + * sem_util.adb: + (Corresponding_Discriminant): If the scope of the discriminant is a + private type without discriminant, use its full view. + Fixes PR 8247. + +2003-10-21 Arnaud Charlet + + * 3psoccon.ads, 3veacodu.adb, 3vexpect.adb, 3vsoccon.ads, + 3vsocthi.adb, 3vsocthi.ads, 3vtrasym.adb, 3zsoccon.ads, + 3zsocthi.adb, 3zsocthi.ads, 50system.ads, 51system.ads, + 55system.ads, 56osinte.adb, 56osinte.ads, 56taprop.adb, + 56taspri.ads, 56tpopsp.adb, 57system.ads, 58system.ads, + 59system.ads, 5aml-tgt.adb, 5bml-tgt.adb, 5csystem.ads, + 5dsystem.ads, 5fosinte.adb, 5gml-tgt.adb, 5hml-tgt.adb, + 5isystem.ads, 5lparame.adb, 5msystem.ads, 5psystem.ads, + 5sml-tgt.adb, 5sosprim.adb, 5stpopsp.adb, 5tsystem.ads, + 5usystem.ads, 5vml-tgt.adb, 5vsymbol.adb, 5vtraent.adb, + 5vtraent.ads, 5wml-tgt.adb, 5xparame.ads, 5xsystem.ads, + 5xvxwork.ads, 5yparame.ads, 5ytiitho.adb, 5zinit.adb, + 5zml-tgt.adb, 5zparame.ads, 5ztaspri.ads, 5ztfsetr.adb, + 5zthrini.adb, 5ztiitho.adb, 5ztpopsp.adb, 7stfsetr.adb, + 7straces.adb, 7strafor.adb, 7strafor.ads, 7stratas.adb, + a-excach.adb, a-exexda.adb, a-exexpr.adb, a-exextr.adb, + a-exstat.adb, a-strsup.adb, a-strsup.ads, a-stwisu.adb, + a-stwisu.ads, bld.adb, bld.ads, bld-io.adb, + bld-io.ads, clean.adb, clean.ads, ctrl_c.c, + erroutc.adb, erroutc.ads, errutil.adb, errutil.ads, + err_vars.ads, final.c, g-arrspl.adb, g-arrspl.ads, + g-boubuf.adb, g-boubuf.ads, g-boumai.ads, g-bubsor.adb, + g-bubsor.ads, g-comver.adb, g-comver.ads, g-ctrl_c.ads, + g-dynhta.adb, g-dynhta.ads, g-eacodu.adb, g-excact.adb, + g-excact.ads, g-heasor.adb, g-heasor.ads, g-memdum.adb, + g-memdum.ads, gnatclean.adb, gnatsym.adb, g-pehage.adb, + g-pehage.ads, g-perhas.ads, gpr2make.adb, gpr2make.ads, + gprcmd.adb, gprep.adb, gprep.ads, g-semaph.adb, + g-semaph.ads, g-string.adb, g-string.ads, g-strspl.ads, + g-wistsp.ads, i-vthrea.adb, i-vthrea.ads, i-vxwoio.adb, + i-vxwoio.ads, Makefile.generic, Makefile.prolog, Makefile.rtl, + prep.adb, prep.ads, prepcomp.adb, prepcomp.ads, + prj-err.adb, prj-err.ads, s-boarop.ads, s-carsi8.adb, + s-carsi8.ads, s-carun8.adb, s-carun8.ads, s-casi16.adb, + s-casi16.ads, s-casi32.adb, s-casi32.ads, s-casi64.adb, + s-casi64.ads, s-casuti.adb, s-casuti.ads, s-caun16.adb, + s-caun16.ads, s-caun32.adb, s-caun32.ads, s-caun64.adb, + s-caun64.ads, scng.adb, scng.ads, s-exnint.adb, + s-exnllf.adb, s-exnlli.adb, s-expint.adb, s-explli.adb, + s-geveop.adb, s-geveop.ads, s-hibaen.ads, s-htable.adb, + s-htable.ads, sinput-c.adb, sinput-c.ads, s-memcop.ads, + socket.c, s-purexc.ads, s-scaval.adb, s-stopoo.adb, + s-strcom.adb, s-strcom.ads, s-strxdr.adb, s-rident.ads, + s-thread.adb, s-thread.ads, s-tpae65.adb, s-tpae65.ads, + s-tporft.adb, s-traent.adb, s-traent.ads, styleg.adb, + styleg.ads, styleg-c.adb, styleg-c.ads, s-veboop.adb, + s-veboop.ads, s-vector.ads, symbols.adb, symbols.ads, + tb-alvms.c, tb-alvxw.c, tempdir.adb, tempdir.ads, + vms_conv.ads, vms_conv.adb, vms_data.ads, + vxaddr2line.adb: Files added. Merge with ACT tree. + + * 4dintnam.ads, 4mintnam.ads, 4uintnam.ads, 52system.ads, + 5dosinte.ads, 5etpopse.adb, 5mosinte.ads, 5qosinte.adb, + 5qosinte.ads, 5qstache.adb, 5qtaprop.adb, 5qtaspri.ads, + 5stpopse.adb, 5uintman.adb, 5uosinte.ads, adafinal.c, + g-enblsp.adb, io-aux.c, scn-nlit.adb, scn-slit.adb, + s-exnflt.ads, s-exngen.adb, s-exngen.ads, s-exnlfl.ads, + s-exnlin.ads, s-exnsfl.ads, s-exnsin.ads, s-exnssi.ads, + s-expflt.ads, s-expgen.adb, s-expgen.ads, s-explfl.ads, + s-explin.ads, s-expllf.ads, s-expsfl.ads, s-expsin.ads, + s-expssi.ads, style.adb: Files removed. Merge with ACT tree. + + * 1ic.ads, 31soccon.ads, 31soliop.ads, 3asoccon.ads, + 3bsoccon.ads, 3gsoccon.ads, 3hsoccon.ads, 3ssoccon.ads, + 3ssoliop.ads, 3wsoccon.ads, 3wsocthi.adb, 3wsocthi.ads, + 3wsoliop.ads, 41intnam.ads, 42intnam.ads, 4aintnam.ads, + 4cintnam.ads, 4gintnam.ads, 4hexcpol.adb, 4hintnam.ads, + 4lintnam.ads, 4nintnam.ads, 4ointnam.ads, 4onumaux.ads, + 4pintnam.ads, 4sintnam.ads, 4vcaldel.adb, 4vcalend.adb, + 4vintnam.ads, 4wexcpol.adb, 4wintnam.ads, 4zintnam.ads, + 51osinte.adb, 51osinte.ads, 52osinte.adb, 52osinte.ads, + 53osinte.ads, 54osinte.ads, 5aosinte.adb, 5aosinte.ads, + 5asystem.ads, 5ataprop.adb, 5atasinf.ads, 5ataspri.ads, + 5atpopsp.adb, 5avxwork.ads, 5bosinte.adb, 5bosinte.ads, + 5bsystem.ads, 5cosinte.ads, 5esystem.ads, 5fintman.adb, + 5fosinte.ads, 5fsystem.ads, 5ftaprop.adb, 5ftasinf.ads, + 5ginterr.adb, 5gintman.adb, 5gmastop.adb, 5gosinte.ads, + 5gproinf.ads, 5gsystem.ads, 5gtaprop.adb, 5gtasinf.ads, + 5gtpgetc.adb, 5hosinte.adb, 5hosinte.ads, 5hsystem.ads, + 5htaprop.adb, 5htaspri.ads, 5htraceb.adb, 5iosinte.adb, + 5itaprop.adb, 5itaspri.ads, 5ksystem.ads, 5kvxwork.ads, + 5lintman.adb, 5lml-tgt.adb, 5losinte.ads, 5lsystem.ads, + 5mvxwork.ads, 5ninmaop.adb, 5nintman.adb, 5nosinte.ads, + 5ntaprop.adb, 5ntaspri.ads, 5ointerr.adb, 5omastop.adb, + 5oosinte.adb, 5oosinte.ads, 5oosprim.adb, 5oparame.adb, + 5osystem.ads, 5otaprop.adb, 5otaspri.ads, 5posinte.ads, + 5posprim.adb, 5pvxwork.ads, 5sintman.adb, 5sosinte.adb, + 5sosinte.ads, 5ssystem.ads, 5staprop.adb, 5stasinf.ads, + 5staspri.ads, 5svxwork.ads, 5tosinte.ads, 5vasthan.adb, + 5vinmaop.adb, 5vinterr.adb, 5vintman.adb, 5vintman.ads, + 5vmastop.adb, 5vosinte.adb, 5vosinte.ads, 5vosprim.adb, + 5vsystem.ads, 5vtaprop.adb, 5vtaspri.ads, 5vtpopde.adb, + 5vtpopde.ads, 5wgloloc.adb, 5wintman.adb, 5wmemory.adb, + 5wosprim.adb, 5wsystem.ads, 5wtaprop.adb, 5wtaspri.ads, + 5ysystem.ads, 5zinterr.adb, 5zintman.adb, 5zosinte.adb, + 5zosinte.ads, 5zosprim.adb, 5zsystem.ads, 5ztaprop.adb, + 6vcpp.adb, 6vcstrea.adb, 6vinterf.ads, 7sinmaop.adb, + 7sintman.adb, 7sosinte.adb, 7sosprim.adb, 7staprop.adb, + 7staspri.ads, 7stpopsp.adb, 7straceb.adb, 9drpc.adb, + a-caldel.adb, a-caldel.ads, a-charac.ads, a-colien.ads, + a-comlin.adb, adaint.c, adaint.h, ada-tree.def, + a-diocst.adb, a-diocst.ads, a-direio.adb, a-except.adb, + a-except.ads, a-excpol.adb, a-exctra.adb, a-exctra.ads, + a-filico.adb, a-interr.adb, a-intsig.adb, a-intsig.ads, + ali.adb, ali.ads, ali-util.adb, ali-util.ads, + a-ngcefu.adb, a-ngcoty.adb, a-ngelfu.adb, a-nudira.adb, + a-nudira.ads, a-nuflra.adb, a-nuflra.ads, a-reatim.adb, + a-reatim.ads, a-retide.ads, a-sequio.adb, a-siocst.adb, + a-siocst.ads, a-ssicst.adb, a-ssicst.ads, a-strbou.adb, + a-strbou.ads, a-strfix.adb, a-strmap.adb, a-strsea.ads, + a-strunb.adb, a-strunb.ads, a-ststio.adb, a-stunau.adb, + a-stunau.ads, a-stwibo.adb, a-stwibo.ads, a-stwifi.adb, + a-stwima.adb, a-stwiun.adb, a-stwiun.ads, a-tags.adb, + a-tags.ads, a-tasatt.adb, a-taside.adb, a-teioed.adb, + a-textio.adb, a-textio.ads, a-tienau.adb, a-tifiio.adb, + a-tiflau.adb, a-tiflio.adb, a-tigeau.adb, a-tigeau.ads, + a-tiinau.adb, a-timoau.adb, a-tiocst.adb, a-tiocst.ads, + atree.adb, atree.ads, a-witeio.adb, a-witeio.ads, + a-wtcstr.adb, a-wtcstr.ads, a-wtdeio.adb, a-wtedit.adb, + a-wtenau.adb, a-wtflau.adb, a-wtinau.adb, a-wtmoau.adb, + bcheck.adb, binde.adb, bindgen.adb, bindusg.adb, + checks.adb, checks.ads, cio.c, comperr.adb, + comperr.ads, csets.adb, cstand.adb, cstreams.c, + debug_a.adb, debug_a.ads, debug.adb, decl.c, + einfo.adb, einfo.ads, errout.adb, errout.ads, + eval_fat.adb, eval_fat.ads, exp_aggr.adb, expander.adb, + expander.ads, exp_attr.adb, exp_ch11.adb, exp_ch13.adb, + exp_ch2.adb, exp_ch3.adb, exp_ch3.ads, exp_ch4.adb, + exp_ch5.adb, exp_ch6.adb, exp_ch7.adb, exp_ch7.ads, + exp_ch8.adb, exp_ch9.adb, exp_code.adb, exp_dbug.adb, + exp_dbug.ads, exp_disp.adb, exp_dist.adb, expect.c, + exp_fixd.adb, exp_imgv.adb, exp_intr.adb, exp_pakd.adb, + exp_prag.adb, exp_strm.adb, exp_strm.ads, exp_tss.adb, + exp_tss.ads, exp_util.adb, exp_util.ads, exp_vfpt.adb, + fe.h, fmap.adb, fmap.ads, fname.adb, + fname.ads, fname-uf.adb, fname-uf.ads, freeze.adb, + freeze.ads, frontend.adb, g-awk.adb, g-awk.ads, + g-busora.adb, g-busora.ads, g-busorg.adb, g-busorg.ads, + g-casuti.adb, g-casuti.ads, g-catiio.adb, g-catiio.ads, + g-cgi.adb, g-cgi.ads, g-cgicoo.adb, g-cgicoo.ads, + g-cgideb.adb, g-cgideb.ads, g-comlin.adb, g-comlin.ads, + g-crc32.adb, g-crc32.ads, g-debpoo.adb, g-debpoo.ads, + g-debuti.adb, g-debuti.ads, g-diopit.adb, g-diopit.ads, + g-dirope.adb, g-dirope.ads, g-dyntab.adb, g-dyntab.ads, + g-except.ads, g-exctra.adb, g-exctra.ads, g-expect.adb, + g-expect.ads, g-hesora.adb, g-hesora.ads, g-hesorg.adb, + g-hesorg.ads, g-htable.adb, g-htable.ads, gigi.h, + g-io.adb, g-io.ads, g-io_aux.adb, g-io_aux.ads, + g-locfil.adb, g-locfil.ads, g-md5.adb, g-md5.ads, + gmem.c, gnat1drv.adb, gnatbind.adb, gnatchop.adb, + gnatcmd.adb, gnatfind.adb, gnatkr.adb, gnatlbr.adb, + gnatlink.adb, gnatls.adb, gnatmake.adb, gnatmem.adb, + gnatname.adb, gnatprep.adb, gnatprep.ads, gnatpsta.adb, + gnatxref.adb, g-os_lib.adb, g-os_lib.ads, g-regexp.adb, + g-regexp.ads, g-regist.adb, g-regist.ads, g-regpat.adb, + g-regpat.ads, g-soccon.ads, g-socket.adb, g-socket.ads, + g-socthi.adb, g-socthi.ads, g-soliop.ads, g-souinf.ads, + g-speche.adb, g-speche.ads, g-spipat.adb, g-spipat.ads, + g-spitbo.adb, g-spitbo.ads, g-sptabo.ads, g-sptain.ads, + g-sptavs.ads, g-table.adb, g-table.ads, g-tasloc.adb, + g-tasloc.ads, g-thread.adb, g-thread.ads, g-traceb.adb, + g-traceb.ads, g-trasym.adb, g-trasym.ads, hostparm.ads, + i-c.ads, i-cobol.adb, i-cpp.adb, i-cstrea.ads, + i-cstrin.adb, i-cstrin.ads, impunit.adb, init.c, + inline.adb, interfac.ads, i-pacdec.ads, itypes.adb, + itypes.ads, i-vxwork.ads, lang.opt, lang-specs.h, + layout.adb, lib.adb, lib.ads, lib-list.adb, + lib-load.adb, lib-load.ads, lib-sort.adb, lib-util.adb, + lib-writ.adb, lib-writ.ads, lib-xref.adb, lib-xref.ads, + link.c, live.adb, make.adb, make.ads, + Makefile.adalib, Makefile.in, Make-lang.in, makeusg.adb, + mdll.adb, mdll-fil.adb, mdll-fil.ads, mdll-utl.adb, + mdll-utl.ads, memroot.adb, memroot.ads, memtrack.adb, + misc.c, mkdir.c, mlib.adb, mlib.ads, + mlib-fil.adb, mlib-fil.ads, mlib-prj.adb, mlib-prj.ads, + mlib-tgt.adb, mlib-tgt.ads, mlib-utl.adb, mlib-utl.ads, + namet.adb, namet.ads, namet.h, nlists.ads, + nlists.h, nmake.adt, opt.adb, opt.ads, + osint.adb, osint.ads, osint-b.adb, osint-c.adb, + par.adb, par-ch10.adb, par-ch11.adb, par-ch2.adb, + par-ch3.adb, par-ch4.adb, par-ch5.adb, par-ch6.adb, + par-ch9.adb, par-endh.adb, par-labl.adb, par-load.adb, + par-prag.adb, par-sync.adb, par-tchk.adb, par-util.adb, + prj.adb, prj.ads, prj-attr.adb, prj-attr.ads, + prj-com.adb, prj-com.ads, prj-dect.adb, prj-dect.ads, + prj-env.adb, prj-env.ads, prj-ext.adb, prj-ext.ads, + prj-makr.adb, prj-makr.ads, prj-nmsc.adb, prj-nmsc.ads, + prj-pars.adb, prj-pars.ads, prj-part.adb, prj-part.ads, + prj-pp.adb, prj-pp.ads, prj-proc.adb, prj-proc.ads, + prj-strt.adb, prj-strt.ads, prj-tree.adb, prj-tree.ads, + prj-util.adb, prj-util.ads, raise.c, raise.h, + repinfo.adb, repinfo.h, restrict.adb, restrict.ads, + rident.ads, rtsfind.adb, rtsfind.ads, s-addima.ads, + s-arit64.adb, s-assert.adb, s-assert.ads, s-atacco.adb, + s-atacco.ads, s-auxdec.adb, s-auxdec.ads, s-bitops.adb, + scans.ads, scn.adb, scn.ads, s-crc32.adb, + s-crc32.ads, s-direio.adb, sem.adb, sem.ads, + sem_aggr.adb, sem_attr.adb, sem_attr.ads, sem_case.adb, + sem_case.ads, sem_cat.adb, sem_cat.ads, sem_ch10.adb, + sem_ch11.adb, sem_ch12.adb, sem_ch12.ads, sem_ch13.adb, + sem_ch13.ads, sem_ch3.adb, sem_ch3.ads, sem_ch4.adb, + sem_ch5.adb, sem_ch5.ads, sem_ch6.adb, sem_ch6.ads, + sem_ch7.adb, sem_ch7.ads, sem_ch8.adb, sem_ch8.ads, + sem_ch9.adb, sem_disp.adb, sem_disp.ads, sem_dist.adb, + sem_elab.adb, sem_eval.adb, sem_eval.ads, sem_intr.adb, + sem_maps.adb, sem_mech.adb, sem_prag.adb, sem_prag.ads, + sem_res.adb, sem_res.ads, sem_type.adb, sem_type.ads, + sem_util.adb, sem_util.ads, sem_warn.adb, s-errrep.adb, + s-errrep.ads, s-exctab.adb, s-exctab.ads, s-exnint.ads, + s-exnllf.ads, s-exnlli.ads, s-expint.ads, s-explli.ads, + s-expuns.ads, s-fatflt.ads, s-fatgen.adb, s-fatgen.ads, + s-fatlfl.ads, s-fatllf.ads, s-fatsfl.ads, s-fileio.adb, + s-fileio.ads, s-finimp.adb, s-finimp.ads, s-finroo.adb, + s-finroo.ads, sfn_scan.adb, s-gloloc.adb, s-gloloc.ads, + s-imgdec.adb, s-imgenu.adb, s-imgrea.adb, s-imgwch.adb, + sinfo.adb, sinfo.ads, s-inmaop.ads, sinput.adb, + sinput.ads, sinput-d.adb, sinput-l.adb, sinput-l.ads, + sinput-p.adb, sinput-p.ads, s-interr.adb, s-interr.ads, + s-intman.ads, s-maccod.ads, s-mastop.adb, s-mastop.ads, + s-memory.adb, s-memory.ads, snames.adb, snames.ads, + snames.h, s-osprim.ads, s-parame.ads, s-parint.ads, + s-pooloc.adb, s-pooloc.ads, s-poosiz.adb, sprint.adb, + s-proinf.ads, s-scaval.ads, s-secsta.adb, s-secsta.ads, + s-sequio.adb, s-shasto.adb, s-shasto.ads, s-soflin.ads, + s-stache.adb, s-stache.ads, s-stalib.adb, s-stalib.ads, + s-stoele.ads, s-stopoo.ads, s-stratt.adb, s-stratt.ads, + s-strops.adb, s-strops.ads, s-taasde.adb, s-taasde.ads, + s-tadeca.adb, s-tadeca.ads, s-tadert.adb, s-tadert.ads, + s-taenca.adb, s-taenca.ads, s-taprob.adb, s-taprob.ads, + s-taprop.ads, s-tarest.adb, s-tarest.ads, s-tasdeb.adb, + s-tasdeb.ads, s-tasinf.adb, s-tasinf.ads, s-tasini.adb, + s-tasini.ads, s-taskin.adb, s-taskin.ads, s-tasque.adb, + s-tasque.ads, s-tasren.adb, s-tasren.ads, s-tasres.ads, + s-tassta.adb, s-tassta.ads, s-tasuti.adb, s-tasuti.ads, + s-tataat.adb, s-tataat.ads, s-tpinop.adb, s-tpinop.ads, + s-tpoben.adb, s-tpoben.ads, s-tpobop.adb, s-tpobop.ads, + s-tposen.adb, s-tposen.ads, s-traceb.adb, s-traceb.ads, + stringt.adb, stringt.ads, stringt.h, style.ads, + stylesw.adb, stylesw.ads, s-unstyp.ads, s-vaflop.ads, + s-valrea.adb, s-valuti.adb, s-vercon.adb, s-vmexta.adb, + s-wchcnv.ads, s-wchcon.ads, s-widcha.adb, switch.adb, + switch.ads, switch-b.adb, switch-c.adb, switch-m.adb, + s-wwdcha.adb, s-wwdwch.adb, sysdep.c, system.ads, + table.adb, table.ads, targparm.adb, targparm.ads, + targtyps.c, tbuild.adb, tbuild.ads, tracebak.c, + trans.c, tree_io.adb, treepr.adb, treeprs.adt, + ttypes.ads, types.ads, types.h, uintp.adb, + uintp.ads, uintp.h, uname.adb, urealp.adb, + urealp.ads, urealp.h, usage.adb, utils2.c, + utils.c, validsw.adb, validsw.ads, widechar.adb, + xeinfo.adb, xnmake.adb, xref_lib.adb, xref_lib.ads, + xr_tabls.adb, xr_tabls.ads, xtreeprs.adb, xsnames.adb, + einfo.h, sinfo.h, treeprs.ads, nmake.ads, nmake.adb, + gnatvsn.ads: Merge with ACT tree. + + * gnatvsn.adb: Rewritten in a simpler and more efficient way. + +2003-10-20 Mark Mitchell + + * Make-lang.in (gnat_ug_unx.info): Add dependency on stmp-docobjdir. + (gnat_ug_vmx.info): Likewise. + (gnat_ug_vxw.info): Likewise. + (gnat_ug_wnt.info): Likewise. + (gnat_rm.info): Likewise. + (gnat-style.info): Likewise. + + * Make-lang.in (ada.install-info): Remove target. + (info): New target. + (install-info): Likewise. + (gnat_ug_unx.info): Simplify rule. + (gnat_ug_vmx.info): Likewise. + (gnat_ug_vxw.info): Likewise. + (gnat_ug_wnt.info): Likewise. + (gnat_rm.info): Likewise. + (gnat-style.info): Likewise. + +2003-10-14 Nathanael Nerode + + * Make-lang.in: Replace uses of $(target_alias) with + $(target_noncanonical). + * ada/Makefile.in: Remove unused mention of $(target_alias). + +2003-10-06 Mark Mitchell + + * Make-lang.in (ada.info): Replace with ... + (info): ... this. + (ada.dvi): Replace with ... + (dvi): ... this. + +2003-09-29 Zack Weinberg + + * trans.c (gigi): Use REAL_ARITHMETIC, not REAL_VALUE_ATOF, to + initialize dconstp5 and dconstmp5. + +2003-09-28 Richard Henderson + + * trans.c (tree_transform): Update call to expand_asm_operands. + +2003-09-21 Richard Henderson + + * trans.c, utils.c: Revert. + +2003-09-21 Richard Henderson + + * trans.c, utils.c: Update for DECL_SOURCE_LOCATION rename and + change to const. + +2003-09-04 Michael Matz + + * misc.c: Include "target.h". + * Make-lang.in (misc.o): Add dependency on target.h. + +2003-09-03 DJ Delorie + + * misc.c (default_pass_by_ref): Convert to calls.return_in_memory + hook. + +2003-08-30 Zack Weinberg + + * Makefile.in: Update substitutions to match changes to + configure. Use include directives instead of @-insertions + to read in host and target fragments. Add a rule to + regenerate ada/Makefile. + +2003-07-18 Neil Booth + + * lang-options.h: Remove. + * lang.opt: Add help text. + +2003-07-07 Nathan Sidwell + + * trans.c (build_unit_elab, set_lineno): Adjust emit_line_note + calls. + +2003-07-06 Neil Booth + + * misc.c (gnat_handle_option): Don't handle filenames. + +2003-07-04 H.J. Lu + + * Make-lang.in: Replace PWD with PWD_COMMAND. + * Makefile.adalib: Likewise. + * Makefile.in: Likewise. + +2003-07-04 Matt Kraai + + * misc.c (gnat_argv): Revert last change. + (gnat_handle_option, gnat_init_options): Copy arguments. + +2003-07-03 Neil Booth + + * misc.c (gnat_argv): Make const. + +2003-07-02 Neil Booth + + * misc.c (save_argc, save_argv): Keep non-static! + +2003-07-02 Neil Booth + + * misc.c (save_argc, save_argv): Make static. + (gnat_init_options): New prototype. + (gnat_init_options): Update. + +2003-07-01 Matt Kraai + + * gnat_ug.texi: Remove unlikely characters from @vars. + * gnat_ug_vms.texi: Regenerate. + +2003-06-27 Nathan Sidwell + + * misc.c (record_code_position): Adjust emit_note call. + +2003-06-26 Neil Booth + + * misc.c (gnat_handle_option): Don't check for missing arguments. + +2003-06-20 Nathan Sidwell + + * utils.c (end_subprog_body): Adjust expand_function_end call. + +2003-06-16 Matt Kraai + + * bindgen.adb (Gen_Main_Ada, Gen_Main_C): Do not test + Bind_Main_Program. + +2003-06-15 Neil Booth + + * lang.opt: Declare Ada. + * misc.c (gnat_init_options): Update. + +2003-06-14 Nathan Sidwell + + * utils.c (begin_subprog_body): Adjust init_function_start call. + +2003-06-14 Neil Booth + + * Make-lang.in: Update to use options.c and options.h. + * misc.c: Include options.h not aoptions.h. + (gnat_handle_option): Abort on unrecognized switch. + (gnat_init_options): Request Ada switches. + +2003-06-14 Neil Booth + + * lang.opt: Add -Wall. + * misc.c (gnat_handle_option): Handle it. + +2003-06-12 Neil Booth + + * misc.c (gnat_handle_option): Fix warnings. + +2003-06-11 Matt Kraai + + * Make-lang.in (gnatbind): Remove $(LIBIBERTY). + +2003-06-11 Neil Booth + + * Make-lang.in: Update to handle command-line options. + * lang.opt: New file. + * misc.c: Include aoptions.h. + (cl_options_count, cl_options): Remove. + (gnat_handle_option): New. + (gnat_decode_option): Remove. + (LANG_HOOKS_DECODE_OPTION): Remove. + (LANG_HOOKS_HANDLE_OPTION): Override. + +2003-06-10 Nathanael Nerode + + * init.c, misc.c, trans.c, utils.c: Remove dead code. + +2003-06-09 Nathanael Nerode + + * Makefile.in: Replace "host_canonical" with "host" for autoconf + substitution. + +2003-06-08 Neil Booth + + * Make-lang.in: Update. + * misc.c: Include opts.h. Define cl_options_count and cl_options. + +2003-06-07 Neil Booth + + * misc.c (gnat_init_options): Update. + +2003-06-05 Matt Kraai + + * Make-lang.in (ada/b_gnatb.o-warn): Remove. + * bindgen.adb (Gen_Main_C): Mark ensure_reference with + __attribute__ ((__unused__)). + +2003-06-05 Jan Hubicka + + * Make-lang.in: Add support for stageprofile and stagefeedback + +2003-06-05 Matt Kraai + + * bindgen.adb (Gen_Adafinal_C, Gen_Adainit_C, Gen_Elab_Defs_C) + (Gen_Main_C, Gen_Output_File_C): Generate ISO C. + +2003-06-04 Matt Kraai + + * gnat_ug.texi (The GNAT Run-Time Library Builder gnatlbr): + Remove non-VMS directive. + (Switches for gnatlbr, Optimization Levels): Remove non-VMS + alternatives. + (Examples of gnatls Usage): Remove VMS alternative. + +2003-06-04 Olivier Hainque + + PR ada/9953 + * 5hsystem.ads: Remove pragma Linker_Option for pthreads library, + and turn ZCX_By_Default back to False since the underlying support + is not quite there yet. + +2003-06-01 Andreas Jaeger + + * utils.c (finish_record_type): Remove usages of ROUND_TYPE_SIZE + and ROUND_TYPE_SIZE_UNIT. + +2003-05-22 Geert Bosch + + * gnat_rm.texi : Remove reference to Ada Core Technologies. + +2003-05-03 Nathan Sidwell + + * trans.c (tree_transform): Use location_t and input_location + directly. + (build_unit_elab): Likewise. + * utils.c (create_label_decl): Likewise. + +2003-05-01 Nathan Sidwell + + * trans.c (tree_transform, build_unit_elab, + set_lineno): Rename lineno to input_line. + * utils.c (pushdecl, create_label_decl, begin_subprog_body, + end_subprog_body): Likewise. + * utils2.c (build_call_raise): Likewise. + +2003-05-01 Laurent Guerby + + PR ada/10546 + * 5iosinte.ads: Increase pthread_cond_t size to match recent + LinuxThread and NPTL version, merge from ACT. + +2003-04-28 Zack Weinberg + + * utils.c (convert): No need to clear TREE_CST_RTL. + +2003-04-23 Geert Bosch + + * 1aexcept.adb, 1aexcept.ads, 1ic.ads, 1ssecsta.adb, + 1ssecsta.ads, 31soccon.ads, 31soliop.ads, 3asoccon.ads, + 3bsoccon.ads, 3gsoccon.ads, 3hsoccon.ads, 3ssoccon.ads, + 3ssoliop.ads, 3wsoccon.ads, 3wsocthi.adb, 3wsocthi.ads, + 3wsoliop.ads, 41intnam.ads, 42intnam.ads, 4aintnam.ads, + 4cintnam.ads, 4dintnam.ads, 4gintnam.ads, 4hexcpol.adb, + 4hintnam.ads, 4lintnam.ads, 4mintnam.ads, 4nintnam.ads, + 4ointnam.ads, 4onumaux.ads, 4pintnam.ads, 4rintnam.ads, + 4sintnam.ads, 4uintnam.ads, 4vcaldel.adb, 4vcalend.adb, + 4vcalend.ads, 4vintnam.ads, 4wcalend.adb, 4wexcpol.adb, + 4wintnam.ads, 4zintnam.ads, 4znumaux.ads, 4zsytaco.adb, + 4zsytaco.ads, 51osinte.adb, 51osinte.ads, 52osinte.adb, + 52osinte.ads, 52system.ads, 53osinte.ads, 54osinte.ads, + 5amastop.adb, 5aosinte.adb, 5aosinte.ads, 5asystem.ads, + 5ataprop.adb, 5atasinf.ads, 5ataspri.ads, 5atpopsp.adb, + 5avxwork.ads, 5bosinte.adb, 5bosinte.ads, 5bsystem.ads, + 5cosinte.ads, 5dosinte.ads, 5esystem.ads, 5etpopse.adb, + 5fintman.adb, 5fosinte.ads, 5fsystem.ads, 5ftaprop.adb, + 5ftasinf.ads, 5ginterr.adb, 5gintman.adb, 5gmastop.adb, + 5gosinte.ads, 5gproinf.adb, 5gproinf.ads, 5gsystem.ads, + 5gtaprop.adb, 5gtasinf.adb, 5gtasinf.ads, 5gtpgetc.adb, + 5hosinte.adb, 5hosinte.ads, 5hparame.ads, 5hsystem.ads, + 5htaprop.adb, 5htaspri.ads, 5htraceb.adb, 5iosinte.adb, + 5iosinte.ads, 5itaprop.adb, 5itaspri.ads, 5ksystem.ads, + 5kvxwork.ads, 5lintman.adb, 5lml-tgt.adb, 5losinte.ads, + 5lsystem.ads, 5mosinte.ads, 5mvxwork.ads, 5ninmaop.adb, + 5nintman.adb, 5nosinte.ads, 5ntaprop.adb, 5ntaspri.ads, + 5ointerr.adb, 5omastop.adb, 5oosinte.adb, 5oosinte.ads, + 5oosprim.adb, 5oparame.adb, 5osystem.ads, 5otaprop.adb, + 5otaspri.ads, 5posinte.ads, 5posprim.adb, 5pvxwork.ads, + 5qosinte.adb, 5qosinte.ads, 5qstache.adb, 5qtaprop.adb, + 5qtaspri.ads, 5rosinte.adb, 5rosinte.ads, 5rparame.adb, + 5sintman.adb, 5sosinte.adb, 5sosinte.ads, 5sparame.adb, + 5ssystem.ads, 5staprop.adb, 5stasinf.adb, 5stasinf.ads, + 5staspri.ads, 5stpopse.adb, 5svxwork.ads, 5tosinte.ads, + 5uintman.adb, 5uosinte.ads, 5vasthan.adb, 5vinmaop.adb, + 5vinterr.adb, 5vintman.adb, 5vintman.ads, 5vmastop.adb, + 5vosinte.adb, 5vosinte.ads, 5vosprim.adb, 5vosprim.ads, + 5vparame.ads, 5vsystem.ads, 5vtaprop.adb, 5vtaspri.ads, + 5vtpopde.adb, 5vtpopde.ads, 5vvaflop.adb, 5wgloloc.adb, + 5wintman.adb, 5wmemory.adb, 5wosinte.ads, 5wosprim.adb, + 5wsystem.ads, 5wtaprop.adb, 5wtaspri.ads, 5ysystem.ads, + 5zinterr.adb, 5zintman.adb, 5zosinte.adb, 5zosinte.ads, + 5zosprim.adb, 5zsystem.ads, 5ztaprop.adb, 6vcpp.adb, + 6vcstrea.adb, 6vinterf.ads, 7sinmaop.adb, 7sintman.adb, + 7sosinte.adb, 7sosprim.adb, 7staprop.adb, 7staspri.ads, + 7stpopsp.adb, 7straceb.adb, 86numaux.adb, 86numaux.ads, + 9drpc.adb, a-astaco.adb, a-astaco.ads, a-caldel.adb, + a-caldel.ads, a-calend.adb, a-calend.ads, a-chahan.adb, + a-chahan.ads, a-charac.ads, a-chlat1.ads, a-chlat9.ads, + a-colien.adb, a-colien.ads, a-colire.adb, a-colire.ads, + a-comlin.adb, a-comlin.ads, a-cwila1.ads, a-cwila9.ads, + a-decima.adb, a-decima.ads, a-diocst.adb, a-diocst.ads, + a-direio.adb, a-direio.ads, a-dynpri.adb, a-dynpri.ads, + a-einuoc.adb, a-einuoc.ads, a-except.adb, a-except.ads, + a-excpol.adb, a-exctra.adb, a-exctra.ads, a-filico.adb, + a-filico.ads, a-finali.adb, a-finali.ads, a-flteio.ads, + a-fwteio.ads, a-inteio.ads, a-interr.adb, a-interr.ads, + a-intnam.ads, a-intsig.adb, a-intsig.ads, a-ioexce.ads, + a-iwteio.ads, a-lfteio.ads, a-lfwtio.ads, a-liteio.ads, + a-liwtio.ads, a-llftio.ads, a-llfwti.ads, a-llitio.ads, + a-lliwti.ads, a-ncelfu.ads, a-ngcefu.adb, a-ngcefu.ads, + a-ngcoty.adb, a-ngcoty.ads, a-ngelfu.adb, a-ngelfu.ads, + a-nlcefu.ads, a-nlcoty.ads, a-nlelfu.ads, a-nllcef.ads, + a-nllcty.ads, a-nllefu.ads, a-nscefu.ads, a-nscoty.ads, + a-nselfu.ads, a-nucoty.ads, a-nudira.adb, a-nudira.ads, + a-nuelfu.ads, a-nuflra.adb, a-nuflra.ads, a-numaux.ads, + a-numeri.ads, a-reatim.adb, a-reatim.ads, a-retide.adb, + a-retide.ads, a-sequio.adb, a-sequio.ads, a-sfteio.ads, + a-sfwtio.ads, a-siocst.adb, a-siocst.ads, a-siteio.ads, + a-siwtio.ads, a-ssicst.adb, a-ssicst.ads, a-ssitio.ads, + a-ssiwti.ads, a-stmaco.ads, a-storio.adb, a-storio.ads, + a-strbou.adb, a-strbou.ads, a-stream.ads, a-strfix.adb, + a-strfix.ads, a-string.ads, a-strmap.adb, a-strmap.ads, + a-strsea.adb, a-strsea.ads, a-strunb.adb, a-strunb.ads, + a-ststio.adb, a-ststio.ads, a-stunau.adb, a-stunau.ads, + a-stwibo.adb, a-stwibo.ads, a-stwifi.adb, a-stwifi.ads, + a-stwima.adb, a-stwima.ads, a-stwise.adb, a-stwise.ads, + a-stwiun.adb, a-stwiun.ads, a-suteio.adb, a-suteio.ads, + a-swmwco.ads, a-swuwti.adb, a-swuwti.ads, a-sytaco.adb, + a-sytaco.ads, a-tags.adb, a-tags.ads, a-tasatt.adb, + a-tasatt.ads, a-taside.adb, a-taside.ads, a-teioed.adb, + a-teioed.ads, a-textio.adb, a-textio.ads, a-ticoau.adb, + a-ticoau.ads, a-ticoio.adb, a-ticoio.ads, a-tideau.adb, + a-tideau.ads, a-tideio.adb, a-tideio.ads, a-tienau.adb, + a-tienau.ads, a-tienio.adb, a-tienio.ads, a-tifiio.adb, + a-tifiio.ads, a-tiflau.adb, a-tiflau.ads, a-tiflio.adb, + a-tiflio.ads, a-tigeau.adb, a-tigeau.ads, a-tiinau.adb, + a-tiinau.ads, a-tiinio.adb, a-tiinio.ads, a-timoau.adb, + a-timoau.ads, a-timoio.adb, a-timoio.ads, a-tiocst.adb, + a-tiocst.ads, a-titest.adb, a-titest.ads, a-unccon.ads, + a-uncdea.ads, a-witeio.adb, a-witeio.ads, a-wtcoau.adb, + a-wtcoau.ads, a-wtcoio.adb, a-wtcoio.ads, a-wtcstr.adb, + a-wtcstr.ads, a-wtdeau.adb, a-wtdeau.ads, a-wtdeio.adb, + a-wtdeio.ads, a-wtedit.adb, a-wtedit.ads, a-wtenau.adb, + a-wtenau.ads, a-wtenio.adb, a-wtenio.ads, a-wtfiio.adb, + a-wtfiio.ads, a-wtflau.adb, a-wtflau.ads, a-wtflio.adb, + a-wtflio.ads, a-wtgeau.adb, a-wtgeau.ads, a-wtinau.adb, + a-wtinau.ads, a-wtinio.adb, a-wtinio.ads, a-wtmoau.adb, + a-wtmoau.ads, a-wtmoio.adb, a-wtmoio.ads, a-wttest.adb, + a-wttest.ads, ada-tree.h, ada.ads, ada.h, + adadecode.c, adadecode.h, ali-util.adb, ali-util.ads, + ali.adb, ali.ads, alloc.ads, argv.c, + atree.adb, atree.ads, atree.h, aux-io.c, + back_end.adb, back_end.ads, bcheck.adb, bcheck.ads, + binde.adb, binde.ads, binderr.adb, binderr.ads, + bindgen.adb, bindgen.ads, bindusg.adb, bindusg.ads, + butil.adb, butil.ads, cal.c, calendar.ads, + casing.adb, casing.ads, ceinfo.adb, checks.adb, + checks.ads, cio.c, comperr.adb, comperr.ads, + config-lang.in, csets.adb, csets.ads, csinfo.adb, + cstand.adb, cstand.ads, cuintp.c, debug.adb, + debug.ads, debug_a.adb, debug_a.ads, dec-io.adb, + dec-io.ads, dec.ads, deftarg.c, directio.ads, + einfo.adb, einfo.ads, elists.adb, elists.ads, + elists.h, errno.c, errout.adb, errout.ads, + eval_fat.adb, eval_fat.ads, exit.c, exp_aggr.adb, + exp_aggr.ads, exp_attr.adb, exp_attr.ads, exp_ch10.ads, + exp_ch11.adb, exp_ch11.ads, exp_ch12.adb, exp_ch12.ads, + exp_ch13.adb, exp_ch13.ads, exp_ch2.adb, exp_ch2.ads, + exp_ch3.adb, exp_ch3.ads, exp_ch4.adb, exp_ch4.ads, + exp_ch5.adb, exp_ch5.ads, exp_ch6.adb, exp_ch6.ads, + exp_ch7.adb, exp_ch7.ads, exp_ch8.adb, exp_ch8.ads, + exp_ch9.adb, exp_ch9.ads, exp_code.adb, exp_code.ads, + exp_dbug.adb, exp_dbug.ads, exp_disp.adb, exp_disp.ads, + exp_dist.adb, exp_dist.ads, exp_fixd.adb, exp_fixd.ads, + exp_imgv.adb, exp_imgv.ads, exp_intr.adb, exp_intr.ads, + exp_pakd.adb, exp_pakd.ads, exp_prag.adb, exp_prag.ads, + exp_smem.adb, exp_smem.ads, exp_strm.adb, exp_strm.ads, + exp_tss.adb, exp_tss.ads, exp_util.adb, exp_util.ads, + exp_vfpt.adb, exp_vfpt.ads, expander.adb, expander.ads, + fmap.adb, fmap.ads, fname-sf.adb, fname-sf.ads, + fname-uf.adb, fname-uf.ads, fname.adb, fname.ads, + freeze.adb, freeze.ads, frontend.adb, frontend.ads, + g-awk.adb, g-awk.ads, g-busora.adb, g-busora.ads, + g-busorg.adb, g-busorg.ads, g-calend.adb, g-calend.ads, + g-casuti.adb, g-casuti.ads, g-catiio.adb, g-catiio.ads, + g-cgi.adb, g-cgi.ads, g-cgicoo.adb, g-cgicoo.ads, + g-cgideb.adb, g-cgideb.ads, g-comlin.adb, g-comlin.ads, + g-crc32.adb, g-crc32.ads, g-curexc.ads, g-debpoo.adb, + g-debpoo.ads, g-debuti.adb, g-debuti.ads, g-diopit.adb, + g-diopit.ads, g-dirope.adb, g-dirope.ads, g-dyntab.adb, + g-dyntab.ads, g-enblsp.adb, g-except.ads, g-exctra.adb, + g-exctra.ads, g-expect.adb, g-expect.ads, g-flocon.ads, + g-hesora.adb, g-hesora.ads, g-hesorg.adb, g-hesorg.ads, + g-htable.adb, g-htable.ads, g-io.adb, g-io.ads, + g-io_aux.adb, g-io_aux.ads, g-locfil.ads, g-md5.adb, + g-md5.ads, g-moreex.adb, g-moreex.ads, g-os_lib.adb, + g-os_lib.ads, g-regexp.adb, g-regexp.ads, g-regist.ads, + g-regpat.adb, g-regpat.ads, g-soccon.ads, g-socket.adb, + g-socket.ads, g-socthi.adb, g-socthi.ads, g-soliop.ads, + g-souinf.ads, g-speche.adb, g-speche.ads, g-spipat.adb, + g-spipat.ads, g-spitbo.adb, g-spitbo.ads, g-sptabo.ads, + g-sptain.ads, g-sptavs.ads, g-table.adb, g-table.ads, + g-tasloc.adb, g-tasloc.ads, g-thread.adb, g-thread.ads, + g-traceb.adb, g-traceb.ads, g-trasym.adb, g-trasym.ads, + get_targ.adb, get_targ.ads, gnat-style.texi, gnat.ads, + gnat1drv.adb, gnat1drv.ads, gnatbind.adb, gnatbind.ads, + gnatbl.c, gnatchop.adb, gnatcmd.adb, gnatcmd.ads, + gnatdll.adb, gnatfind.adb, gnatkr.adb, gnatkr.ads, + gnatlbr.adb, gnatlink.adb, gnatlink.ads, gnatls.adb, + gnatls.ads, gnatmake.adb, gnatmake.ads, gnatmem.adb, + gnatname.adb, gnatname.ads, gnatprep.adb, gnatprep.ads, + gnatpsta.adb, gnatvsn.adb, gnatvsn.ads, gnatxref.adb, + hlo.adb, hlo.ads, hostparm.ads, i-c.adb, + i-c.ads, i-cexten.ads, i-cobol.adb, i-cobol.ads, + i-cpoint.adb, i-cpoint.ads, i-cpp.adb, i-cpp.ads, + i-cstrea.adb, i-cstrea.ads, i-cstrin.adb, i-cstrin.ads, + i-fortra.adb, i-fortra.ads, i-os2err.ads, i-os2lib.adb, + i-os2lib.ads, i-os2syn.ads, i-os2thr.ads, i-pacdec.adb, + i-pacdec.ads, i-vxwork.ads, impunit.adb, impunit.ads, + inline.adb, inline.ads, interfac.ads, ioexcept.ads, + itypes.adb, itypes.ads, krunch.adb, krunch.ads, + layout.adb, layout.ads, lib-list.adb, lib-load.adb, + lib-load.ads, lib-sort.adb, lib-util.adb, lib-util.ads, + lib-writ.adb, lib-writ.ads, lib-xref.adb, lib-xref.ads, + lib.adb, lib.ads, live.adb, live.ads, + machcode.ads, make.adb, make.ads, makeusg.adb, + makeusg.ads, math_lib.adb, mdll-fil.adb, mdll-fil.ads, + mdll-utl.adb, mdll-utl.ads, mdll.adb, mdll.ads, + memroot.adb, memroot.ads, memtrack.adb, mlib-fil.adb, + mlib-fil.ads, mlib-prj.adb, mlib-prj.ads, mlib-tgt.adb, + mlib-tgt.ads, mlib-utl.adb, mlib-utl.ads, mlib.adb, + mlib.ads, namet.adb, namet.ads, nlists.adb, + nlists.ads, opt.adb, opt.ads, osint-b.adb, + osint-b.ads, osint-c.adb, osint-c.ads, osint-l.adb, + osint-l.ads, osint-m.adb, osint-m.ads, osint.adb, + osint.ads, output.adb, output.ads, par-ch10.adb, + par-ch11.adb, par-ch12.adb, par-ch13.adb, par-ch2.adb, + par-ch3.adb, par-ch4.adb, par-ch5.adb, par-ch6.adb, + par-ch7.adb, par-ch8.adb, par-ch9.adb, par-endh.adb, + par-labl.adb, par-load.adb, par-prag.adb, par-sync.adb, + par-tchk.adb, par-util.adb, par.adb, par.ads, + prj-attr.adb, prj-attr.ads, prj-com.adb, prj-com.ads, + prj-dect.adb, prj-dect.ads, prj-env.adb, prj-env.ads, + prj-ext.adb, prj-ext.ads, prj-makr.adb, prj-makr.ads, + prj-nmsc.adb, prj-nmsc.ads, prj-pars.adb, prj-pars.ads, + prj-part.adb, prj-part.ads, prj-pp.adb, prj-pp.ads, + prj-proc.adb, prj-proc.ads, prj-strt.adb, prj-strt.ads, + prj-tree.adb, prj-tree.ads, prj-util.adb, prj-util.ads, + prj.adb, prj.ads, repinfo.adb, repinfo.ads, + restrict.adb, restrict.ads, rident.ads, rtsfind.adb, + rtsfind.ads, s-addima.adb, s-addima.ads, s-arit64.adb, + s-arit64.ads, s-assert.adb, s-assert.ads, s-asthan.adb, + s-asthan.ads, s-atacco.adb, s-atacco.ads, s-auxdec.adb, + s-auxdec.ads, s-bitops.adb, s-bitops.ads, s-chepoo.ads, + s-crc32.adb, s-crc32.ads, s-direio.adb, s-direio.ads, + s-errrep.adb, s-errrep.ads, s-except.ads, s-exctab.adb, + s-exctab.ads, s-exnflt.ads, s-exngen.adb, s-exngen.ads, + s-exnint.ads, s-exnlfl.ads, s-exnlin.ads, s-exnllf.ads, + s-exnlli.ads, s-exnsfl.ads, s-exnsin.ads, s-exnssi.ads, + s-expflt.ads, s-expgen.adb, s-expgen.ads, s-expint.ads, + s-explfl.ads, s-explin.ads, s-expllf.ads, s-explli.ads, + s-expllu.adb, s-expllu.ads, s-expmod.adb, s-expmod.ads, + s-expsfl.ads, s-expsin.ads, s-expssi.ads, s-expuns.adb, + s-expuns.ads, s-fatflt.ads, s-fatgen.adb, s-fatgen.ads, + s-fatlfl.ads, s-fatllf.ads, s-fatsfl.ads, s-ficobl.ads, + s-fileio.adb, s-fileio.ads, s-finimp.adb, s-finimp.ads, + s-finroo.adb, s-finroo.ads, s-fore.adb, s-fore.ads, + s-gloloc.adb, s-gloloc.ads, s-imgbiu.adb, s-imgbiu.ads, + s-imgboo.adb, s-imgboo.ads, s-imgcha.adb, s-imgcha.ads, + s-imgdec.adb, s-imgdec.ads, s-imgenu.adb, s-imgenu.ads, + s-imgint.adb, s-imgint.ads, s-imgllb.adb, s-imgllb.ads, + s-imglld.adb, s-imglld.ads, s-imglli.adb, s-imglli.ads, + s-imgllu.adb, s-imgllu.ads, s-imgllw.adb, s-imgllw.ads, + s-imgrea.adb, s-imgrea.ads, s-imguns.adb, s-imguns.ads, + s-imgwch.adb, s-imgwch.ads, s-imgwiu.adb, s-imgwiu.ads, + s-inmaop.ads, s-interr.adb, s-interr.ads, s-intman.ads, + s-io.adb, s-io.ads, s-maccod.ads, s-mantis.adb, + s-mantis.ads, s-mastop.adb, s-mastop.ads, s-memory.adb, + s-memory.ads, s-osprim.ads, s-pack03.adb, s-pack03.ads, + s-pack05.adb, s-pack05.ads, s-pack06.adb, s-pack06.ads, + s-pack07.adb, s-pack07.ads, s-pack09.adb, s-pack09.ads, + s-pack10.adb, s-pack10.ads, s-pack11.adb, s-pack11.ads, + s-pack12.adb, s-pack12.ads, s-pack13.adb, s-pack13.ads, + s-pack14.adb, s-pack14.ads, s-pack15.adb, s-pack15.ads, + s-pack17.adb, s-pack17.ads, s-pack18.adb, s-pack18.ads, + s-pack19.adb, s-pack19.ads, s-pack20.adb, s-pack20.ads, + s-pack21.adb, s-pack21.ads, s-pack22.adb, s-pack22.ads, + s-pack23.adb, s-pack23.ads, s-pack24.adb, s-pack24.ads, + s-pack25.adb, s-pack25.ads, s-pack26.adb, s-pack26.ads, + s-pack27.adb, s-pack27.ads, s-pack28.adb, s-pack28.ads, + s-pack29.adb, s-pack29.ads, s-pack30.adb, s-pack30.ads, + s-pack31.adb, s-pack31.ads, s-pack33.adb, s-pack33.ads, + s-pack34.adb, s-pack34.ads, s-pack35.adb, s-pack35.ads, + s-pack36.adb, s-pack36.ads, s-pack37.adb, s-pack37.ads, + s-pack38.adb, s-pack38.ads, s-pack39.adb, s-pack39.ads, + s-pack40.adb, s-pack40.ads, s-pack41.adb, s-pack41.ads, + s-pack42.adb, s-pack42.ads, s-pack43.adb, s-pack43.ads, + s-pack44.adb, s-pack44.ads, s-pack45.adb, s-pack45.ads, + s-pack46.adb, s-pack46.ads, s-pack47.adb, s-pack47.ads, + s-pack48.adb, s-pack48.ads, s-pack49.adb, s-pack49.ads, + s-pack50.adb, s-pack50.ads, s-pack51.adb, s-pack51.ads, + s-pack52.adb, s-pack52.ads, s-pack53.adb, s-pack53.ads, + s-pack54.adb, s-pack54.ads, s-pack55.adb, s-pack55.ads, + s-pack56.adb, s-pack56.ads, s-pack57.adb, s-pack57.ads, + s-pack58.adb, s-pack58.ads, s-pack59.adb, s-pack59.ads, + s-pack60.adb, s-pack60.ads, s-pack61.adb, s-pack61.ads, + s-pack62.adb, s-pack62.ads, s-pack63.adb, s-pack63.ads, + s-parame.adb, s-parame.ads, s-parint.adb, s-parint.ads, + s-pooglo.adb, s-pooglo.ads, s-pooloc.adb, s-pooloc.ads, + s-poosiz.adb, s-poosiz.ads, s-powtab.ads, s-proinf.adb, + s-proinf.ads, s-rpc.adb, s-rpc.ads, s-scaval.ads, + s-secsta.adb, s-secsta.ads, s-sequio.adb, s-sequio.ads, + s-shasto.adb, s-shasto.ads, s-soflin.adb, s-soflin.ads, + s-sopco3.adb, s-sopco3.ads, s-sopco4.adb, s-sopco4.ads, + s-sopco5.adb, s-sopco5.ads, s-stache.adb, s-stache.ads, + s-stalib.adb, s-stalib.ads, s-stoele.adb, s-stoele.ads, + s-stopoo.ads, s-stratt.adb, s-stratt.ads, s-strops.adb, + s-strops.ads, s-taasde.adb, s-taasde.ads, s-tadeca.adb, + s-tadeca.ads, s-tadert.adb, s-tadert.ads, s-taenca.adb, + s-taenca.ads, s-taprob.adb, s-taprob.ads, s-taprop.ads, + s-tarest.adb, s-tarest.ads, s-tasdeb.adb, s-tasdeb.ads, + s-tasinf.adb, s-tasinf.ads, s-tasini.adb, s-tasini.ads, + s-taskin.adb, s-taskin.ads, s-tasque.adb, s-tasque.ads, + s-tasren.adb, s-tasren.ads, s-tasres.ads, s-tassta.adb, + s-tassta.ads, s-tasuti.adb, s-tasuti.ads, s-tataat.adb, + s-tataat.ads, s-tpinop.adb, s-tpinop.ads, s-tpoben.adb, + s-tpoben.ads, s-tpobop.adb, s-tpobop.ads, s-tposen.adb, + s-tposen.ads, s-traceb.adb, s-traceb.ads, s-traces.adb, + s-traces.ads, s-tratas.adb, s-tratas.ads, s-unstyp.ads, + s-vaflop.adb, s-vaflop.ads, s-valboo.adb, s-valboo.ads, + s-valcha.adb, s-valcha.ads, s-valdec.adb, s-valdec.ads, + s-valenu.adb, s-valenu.ads, s-valint.adb, s-valint.ads, + s-vallld.adb, s-vallld.ads, s-vallli.adb, s-vallli.ads, + s-valllu.adb, s-valllu.ads, s-valrea.adb, s-valrea.ads, + s-valuns.adb, s-valuns.ads, s-valuti.adb, s-valuti.ads, + s-valwch.adb, s-valwch.ads, s-vercon.adb, s-vercon.ads, + s-vmexta.adb, s-vmexta.ads, s-wchcnv.adb, s-wchcnv.ads, + s-wchcon.ads, s-wchjis.adb, s-wchjis.ads, s-wchstw.adb, + s-wchstw.ads, s-wchwts.adb, s-wchwts.ads, s-widboo.adb, + s-widboo.ads, s-widcha.adb, s-widcha.ads, s-widenu.adb, + s-widenu.ads, s-widlli.adb, s-widlli.ads, s-widllu.adb, + s-widllu.ads, s-widwch.adb, s-widwch.ads, s-wwdcha.adb, + s-wwdcha.ads, s-wwdenu.adb, s-wwdenu.ads, s-wwdwch.adb, + s-wwdwch.ads, scans.adb, scans.ads, scn-nlit.adb, + scn-slit.adb, scn.adb, scn.ads, sdefault.ads, + sem.adb, sem.ads, sem_aggr.adb, sem_aggr.ads, + sem_attr.adb, sem_attr.ads, sem_case.adb, sem_case.ads, + sem_cat.adb, sem_cat.ads, sem_ch10.adb, sem_ch10.ads, + sem_ch11.adb, sem_ch11.ads, sem_ch12.adb, sem_ch12.ads, + sem_ch13.adb, sem_ch13.ads, sem_ch2.adb, sem_ch2.ads, + sem_ch3.adb, sem_ch3.ads, sem_ch4.adb, sem_ch4.ads, + sem_ch5.adb, sem_ch5.ads, sem_ch6.adb, sem_ch6.ads, + sem_ch7.adb, sem_ch7.ads, sem_ch8.adb, sem_ch8.ads, + sem_ch9.adb, sem_ch9.ads, sem_disp.adb, sem_disp.ads, + sem_dist.adb, sem_dist.ads, sem_elab.adb, sem_elab.ads, + sem_elim.adb, sem_elim.ads, sem_eval.adb, sem_eval.ads, + sem_intr.adb, sem_intr.ads, sem_maps.adb, sem_maps.ads, + sem_mech.adb, sem_mech.ads, sem_prag.adb, sem_prag.ads, + sem_res.adb, sem_res.ads, sem_smem.adb, sem_smem.ads, + sem_type.adb, sem_type.ads, sem_util.adb, sem_util.ads, + sem_vfpt.adb, sem_vfpt.ads, sem_warn.adb, sem_warn.ads, + sequenio.ads, sfn_scan.adb, sfn_scan.ads, sinfo-cn.adb, + sinfo-cn.ads, sinfo.adb, sinfo.ads, sinput-d.adb, + sinput-d.ads, sinput-l.adb, sinput-l.ads, sinput-p.adb, + sinput-p.ads, sinput.adb, sinput.ads, snames.adb, + snames.ads, sprint.adb, sprint.ads, stand.adb, + stand.ads, stringt.adb, stringt.ads, style.adb, + style.ads, stylesw.adb, stylesw.ads, switch-b.adb, + switch-b.ads, switch-c.adb, switch-c.ads, switch-m.adb, + switch-m.ads, switch.adb, switch.ads, system.ads, + table.adb, table.ads, targparm.adb, targparm.ads, + tbuild.adb, tbuild.ads, text_io.ads, trans.c, + tree_gen.adb, tree_gen.ads, tree_in.adb, tree_in.ads, + tree_io.adb, tree_io.ads, treepr.adb, treepr.ads, + ttypef.ads, ttypes.ads, types.adb, types.ads, + uintp.adb, uintp.ads, uname.adb, uname.ads, + unchconv.ads, unchdeal.ads, urealp.adb, urealp.ads, + usage.adb, usage.ads, validsw.adb, validsw.ads, + widechar.adb, widechar.ads, xeinfo.adb, xnmake.adb, + xr_tabls.adb, xr_tabls.ads, xref_lib.adb, xref_lib.ads, + xsinfo.adb, xsnames.adb, xtreeprs.adb : Merge header, + formatting and other trivial changes from ACT. + +2003-04-12 Zack Weinberg + + * gigi.h, utils2.c (build_constructor): + Rename gnat_build_constructor. Use build_constructor. + * decl.c (gnat_to_gnu_entity) + * trans.c (tree_transform, pos_to_constructor, extract_values) + * ada/utils.c (build_template, convert_to_fat_pointer, convert) + (unchecked_convert) + * ada/utils2.c (build_binary_op, build_call_raise, build_allocator) + (fill_vms_descriptor): + Update to match. + +2003-04-06 Zack Weinberg + + * ada-tree.def: Make fourth element for GNAT_LOOP_ID zero. + * misc.c (gnat_tree_size): New function. + (LANG_HOOKS_TREE_SIZE): Override. + +2003-04-03 Jason Merrill + + * misc.c (gnat_adjust_rli): #if 0. + +2003-03-31 Geert Bosch + + PR ada/10020 + * link.c : Fix misspelled "const" keyword + +2003-03-23 Mark Mitchell + + PR c++/7086 + * utils2.c: Adjust calls to put_var_into_stack. + +2003-03-12 Nathanael Nerode + + * Make-lang.in, Makefile.in, config-lang.in: GCC, not GNU CC. + +2003-03-08 Neil Booth + + * misc.c (gnat_init): Update for new prototype. + +2003-03-05 Olivier Hainque + + ada/9961 + * raise.c (__gnat_Unwind_RaiseException): Add prototype to avoid + warning, and fix return type for the IN_RTS && !SJLJ case. + +2003-03-04 Tom Tromey + + * Make-lang.in (ada.tags): New target. + +2003-03-04 Olivier Hainque + + ada/9911 + * a-except.adb (Unwind_RaiseException): Import a GNAT specific + wrapper, which name remains constant whatever underlying GCC + scheme. + + * raise.c (__gnat_Unwind_RaiseException): New wrappers, providing + the stable interface needed for a-except. + +2003-03-02 Andreas Jaeger + + * gnat_ug_unx.texi, gnat_ug_vms.texi, gnat_ug_vxw.texi, + gnat_ug_wnt.texi: Regenerate. + +2003-03-02 Laurent Guerby + + * Makefile.in (install-gnatlib): Match previous change there + so it works. + +2003-02-28 Andreas Schwab + + * Make-lang.in (install-gnatlib): Change to ada directory before + running make instead of using ada/Makefile directly. + +2003-02-18 Ben Elliston + + Part of PR ada/9406 + * gnat_ug.texi (Binder output file): Grammar fix. + +2003-02-18 Ben Elliston + + PR other/7350 + * 5qtaprop.adb (Sleep): Fix typo in comment. + +2003-02-04 Joseph S. Myers + + * gnat_rm.texi, gnat_ug.texi: Update to GFDL 1.2. + * gnat_ug_unx.texi, gnat_ug_vms.texi, gnat_ug_vxw.texi, + gnat_ug_wnt.texi: Regenerate. + +2003-02-03 Christian Cornelssen + + * Make-lang.in (ada.install-info): Let $(DESTDIR)$(infodir) + be created if necessary. + (ada.install-common): Let $(DESTDIR)$(bindir) be created + if necessary. Remove erroneous and redundant gnatchop + installation commands. Test for gnatdll before attempting + to install it. + (ada.uninstall): Also uninstall gnatfind, gnatxref, gnatlbr, + and gnatdll from all plausible locations. + +2003-02-01 Richard Sandiford + + * utils2.c (build_unary_op): Don't check flag_volatile. + * gnat_ug.texi: Remove -fvolatile from example. + * gnat_ug_vxw.texi: Likewise. + +2003-01-29 Laurent Guerby + + PR ada/8344 + * final.c: rename to adafinal.c to avoid file name conflicts with gcc file. + * Makefile.in: match previous change. + * Make-lang.in: match previous change. + +2003-01-29 Joel Sherrill + + * 5rosinte.ads: Add SIGXCPU. + * 5rtpopsp.adb: New file. + * Make-lang.in: Do not build gnatpsta and gnatpsys when cross. + * Makefile.in: Recognize more RTEMS targets and add the RTEMS + specific file 5rtpopsp.adb. + * adaint.h: Add include of when target is RTEMS. This + is likely needed for all newlib targets. + * init.c: Add RTEMS specific version of __gnat_initialize(). + +2003-01-28 Rainer Orth + + * adaint.c, adaint.h, gmem.c, init.c: Update copyright year. + +2003-01-27 Rainer Orth + + * init.c (__gnat_error_handler): Make msg const. + + * gmem.c (convert_addresses): Move declaration ... + * adaint.h: ... here. + * adaint.c (convert_addresses): Adapt addrs type to match + prototype. + + * adaint.c (__gnat_try_lock): Cast pid_t to long, adapt format. + +2003-01-24 Andreas Schwab + + * ada-tree.h (SET_TYPE_DIGITS_VALUE): Add intermediate cast to + size_t to avoid warning. + +2003-01-21 Zack Weinberg + + * Make-lang.in: Disable -Werror for tracebak.c and b_gnatb.c. + +2003-01-09 Geoffrey Keating + + * gnat_rm.texi: Remove RCS version number. + + * ada-tree.h (union lang_tree_node): Add chain_next option. + +2003-01-09 Christian Cornelssen + + * Make-lang.in (ada.install-info, ada.install-common, + ada.uninstall): Prepend $(DESTDIR) to the destination + directory in all (un)installation commands. + * Makefile.in (install-gnatlib, install-rts): Ditto. + + + +Copyright (C) 2003 Free Software Foundation, Inc. + +Copying and distribution of this file, with or without modification, +are permitted in any medium without royalty provided the copyright +notice and this notice are preserved. diff --git a/gcc/ada/ChangeLog-2004 b/gcc/ada/ChangeLog-2004 new file mode 100644 index 000000000..aee7b460d --- /dev/null +++ b/gcc/ada/ChangeLog-2004 @@ -0,0 +1,8347 @@ +2004-12-30 Sohail Somani + + PR ada/19128 + * trans.c (gnat_to_gnu): Fix typo: Use correct return variable. + +2004-12-23 Eric Botcazou + + * trans.c (Attribute_to_gnu): Adjust call to get_inner_reference. + * utils2.c (build_unary_op): Likewise. + +2004-12-22 Richard Kenner + + * trans.c (mark_visited): Set TYPE_SIZES_GIMPLIFIED. + +2004-12-19 Richard Henderson + + * trans.c (gigi): Update gimplify_body call. + +2004-12-09 Nathan Sidwell + + * decl.c (gnat_substitute_in_type): Remove SET_TYPE case. + +2004-12-07 Ed Falis + + * s-intman-vxworks.adb (Notify_Exception): removed useless check for + current task being suspended. + + * init.c (__gnat_clear_exception): added to reset VxWorks exception + count. + (__gnat_map_signal): removed test for current task being suspended. + +2004-12-07 Gary Dismukes + + * a-exexpr.adb (Others_Value, All_Others_Value): Change initial values + from 16#BEEF# to 16#7FFF# to avoid exceeding Integer'Last on 16-bit + targets (such as AAMP). + +2004-12-07 Ed Schonberg + + * atree.adb (Visit_Itype): Create a new name for the generated itype, + because the back-end may otherwise treat it as a redefinition of the + old symbol. + +2004-12-07 Eric Botcazou + + * back_end.adb (Scan_Back_End_Switches): Accept --param. + + * lang-specs.h: Accept --param. + +2004-12-07 Vincent Celier + + * make.adb (Check_Mains, Switches_Of): Adapt to name changes in + package Prj (Current_Spec_Suffix => Ada_Spec_Suffix, + Current_Body_Suffix => Ada_Body_Suffix). + Take into account Externally_Built attribute. + + * clean.adb (In_Extension_Chain): Always return False when one of the + parameter is No_Project. + (Clean_Project): Adapt to changes in package Prj (Lang_Ada => + Ada_Language_Index). + (Gnatclean): Adapt to change in package Prj.Pars (no parameter + Process_Languages for procedure Parse). + + * gnatcmd.adb (Carg_Switches): New table. + (GNATCmd): Put all switches following -cargs in the Carg_Switches table. + Adapt to name changes in package Prj (Current_Spec_Suffix => + Ada_Spec_Suffix, Current_Body_Suffix => Ada_Body_Suffix). + + * mlib-prj.adb: Adapt to changes in packages Prj and Prj.Com: type + Header_Num and function Hash are now declared in package Prj, + not Prj.Com. + + * prj.adb (Suffix_Of): New function. + (Set (Suffix)): New procedure. + (Hash): One function moved from Prj.Com + (Is_Present, Language_Processing_Data_Of): New functions + (Set): Two new procedures + (Add_Language_Name, Display_Language_Name): New procedures + + * prj.ads: (Suffix_Of): New function + (Set (Suffix)): New procedure + Add several types and tables for multi-language support. + (Header_Num): Type moved from Prj.Com + (Hash): Two functions moved from Prj.Com + (Is_Present, Language_Processing_Data_Of): New functions + (Set): Two new procedures + (Add_Language_Name, Display_Language_Name): New procedures + (Naming): Component name changes: + Current_Spec_Suffix => Ada_Spec_Suffix, + Current_Body_Suffix => Ada_Body_Suffix. Add new components: + Impl_Suffixes, Supp_Suffixes. + (Project_Data): New components: Externally_Built, Supp_Languages, + First_Language_Processing, Supp_Language_Processing, Default_Linker, + Default_Linker_Path. + + * prj-attr.adb: Add new attributes Ada_Roots and Externally_Built and + new package Language_Processing with its attributes (Compiler_Driver, + Compiler_Kind, Dependency_Option, Compute_Dependency, Include_Option, + Binder_Driver, Default_Linker). + + * prj-com.ads, prj-com.adb (Hash): Function moved to package Prj. + (Header_Num): Type moved to package Prj + + * prj-env.adb: Adapt to name changes in package Prj + (Current_Spec_Suffix => Ada_Spec_Suffix, + Current_Body_Suffix => Ada_Body_Suffix). + + * prj-ext.adb: Add the default project dir (/log/gnat) by + default to the project path, except the "-" is one of the directories + in env var ADA_PROJECT_PATH. + (Current_Project_Path): Global variable, replacing Project_Path + that was in the body of Prj.Part. + (Project_Path): New function + (Set_Project_Path): New procedure + Initialize Current_Project_Path during elaboration of the package + Remove dependency on Prj.Com, no longer needed + + * prj-ext.ads (Project_Path): New function + (Set_Project_Path): New procedure + + * prj-nmsc.adb (Body_Suffix_Of): New function. Returns . when no + suffix is defined for language . + (Find_Sources, Record_Other_Sources): Use Body_Suffix_Of, instead of + accessing directly the components of Naming. + (Look_For_Sources): Use Set (Suffix) to set the suffix of a language. + Reorganise of this package. + Break procedure Check in several procedures. + + * prj-nmsc.ads: Replace all procedures (Ada_Check, + Other_Languages_Check and Language_Independent_Check) with a single + procedure Check. + + * prj-pars.ads, prj-pars.adb (Parse): Remove parameter + Process_Languages, no longer needed. + + * prj-part.adb (Project_Path): Move to the body of Prj.Ext as + Current_Project_Path. + Remove elaboration code, moved to the body of Prj.Ext + Use new function Prj.Ext.Project_Path instead of old variable + Project_Path. + (Post_Parse_Context_Clause): Get Resolved_Path as a case-sensitive path. + When comparing with project paths on the stack, first put the resolved + path in canonical case. + (Parse_Single_Project): Set the path name of the project file in the + tree to the normalized path. + + * prj-proc.ads, prj-proc.adb (Check, Recursive_Check, Process): Remove + parameter Process_Languages, no longer needed. + (Recursive_Check): Call Prj.Nmsc.Check, instead of Ada_Check and + Other_Languages_Check. + + * prj-tree.ads (Project_Name_And_Node): New component Canonical_Path + to store the resolved canonical path of the project file. + Remove dependency to Prj.Com, no longer needed + + * prj-util.adb: Adapt to name changes in package Prj + (Current_Spec_Suffix => Ada_Spec_Suffix, Current_Body_Suffix => + Ada_Body_Suffix). + + * snames.ads, snames.adb: New standard names: Ada_Roots, Binder_Driver, + Compiler_Driver, Compiler_Kind, Compute_Dependency, Default_Linker, + Externally_Built, Include_Option, Language_Processing. + + * makegpr.adb: Numerous changes due to changes in packages + Prj and Prj.Nmsc. + + * gnatls.adb: Add the default project dir (/log/gnat) by + default to the project path, except whe "-" is one of the directories + in env var ADA_PROJECT_PATH. + (Gnatls): In verbose mode, add the new section "Project Search Path:" + +2004-12-07 Robert Dewar + + * debug.adb: Document that -gnatdA automatically sets -gnatR3m + + * gnat1drv.adb (Gnat1drv): If debug flag A set, then automatically + set -gnatR3m mode. + + * repinfo.adb (List_Rep_Info): Remove special handling of -gnatdA + flag. No longer needed now that we handle this in gnat1drv.adb. + + * repinfo.ads: Minor reformatting + +2004-12-07 Richard Kenner + Olivier Hainque + Eric Botcazou + + * decl.c (maybe_pad_type): Use TYPE_SIZE_UNIT of the input type for + TYPE_SIZE_UNIT of result type if SIZE is not specified. + (make_aligning_type): Pass -1 as ADDRESSABLE to prevent the creation + of a bitfield, which we know is useless and causes trouble because of + alignment implications. + + * utils.c (create_var_decl): Set DECL_COMMON again on targets without + BSS sections. + (process_attributes): Clear DECL_COMMON again when a section attribute + is present. + (finish_record_type): Independently track if RECORD_TYPE has SIZE and/or + SIZE_UNIT already set and use to compute final SIZE and SIZE_UNIT. + (create_field_decl): Special case ADDRESSABLE negative to mean + "no bitfield creation", to be used by make_aligning_type. Don't + restrict bitfield creation to !ADDRESSABLE any more, as some BLKmode + fields claimed addressable still have to be bitfields. Use + value_factor_p instead of a raw binop construction to check for the + position's alignment. + +2004-12-07 Geert Bosch + + * eval_fat.adb: Revert previous change. + +2004-12-07 Thomas Quinot + Ed Schonberg + + * exp_ch4.adb (Expand_N_Indexed_Component): For an indexed component + with an implicit dereference as its prefix, use + Insert_Explicit_Dereference instead of merely rewriting the prefix into + an explicit dereference. This ensures that a reference to the original + prefix is generated, if appropriate. + + * sem_util.adb (Insert_Explicit_Dereference): When an implicit + dereference is rewritten to an explicit one, generate a reference to + the entity denoted by its prefix using the original prefix node, so + the dereference can be properly recorded as a read of the denoted + access value, if appropriate. + + * sem_warn.adb (Output_Unreferenced_Messages): Do not abstain from + emitting 'assigned but never read' warning on a variable on the basis + that it has an access type. + (Check_References): Emit unreferenced warning when the scope is a + subprogram body. + +2004-12-07 Robert Dewar + Ed Schonberg + + * exp_ch6.adb (Expand_Call): Add comment on handling of back end + intrinsic + + * exp_intr.adb (Expand_Intrinsic_Call): Ignore unrecognized intrinsic, + leaving call unchanged. + This deals with the case where the pragma Import specified + an external name, to be handled by the back end. + + * sem_prag.adb (Process_Import_Or_Interface): Do not check validity of + subprogram which is Imported with convention Intrinsic if an + External_Name argument is specified. + (Process_Import_Or_Interface): Properly diagnose link name argument. + (Inlining_Not_Possible): New name for Cannot_Inline, to avoid confusion + with Sem_Ch6.Cannot_Inline. + (Process_Inline): Provide separate warning for inapplicable inline + pragma. + (Cannot_Inline): Reject subprograms that have an at_end handler, so that + treatment is uniform on different targets. + +2004-12-07 Ed Schonberg + + * exp_ch7.adb (Expand_Cleanup_Actions): If statement sequence of + construct is rewritten, preserve end label to permit source navigation. + +2004-12-07 Thomas Quinot + + * exp_dist.adb (Specific_Build_General_Calling_Stubs, + Specific_Build_Stub_Target): New subprograms. + (Build_Subprogram_Calling_Stubs): Make this procedure independent from + the PCS implementation used, using the above PCS-customized subprograms. + Minor reformatting. + (PolyORB_Support.Helpers): New subunit containing supporting subprograms + for generation of DSA code targeted to the PolyORB PCS. + (Add_Stub_Type): Rewrite to isolate the parts that are specific to one + implementation of the partition communication subsystem in ancillary + subprograms. + (Specific_Build_Stub_Type, GARLIC_Support.Build_Stub_Type, + PolyORB_Support.Build_Stub_Type): New subrograms containing the + PCS-specific part of Add_Stub_Type. + (Insert_Partition_Check): Use runtime library function to perform + E.4(19) check. + + * rtsfind.ads: New entity System.PolyORB_Interface.Make_Ref + (RE_Same_Partition): New entity, from s-parint. + + * s-parint.ads, s-parint.adb (Same_Partition): New subprogram. + +2004-12-07 Gary Dismukes + + * gnatmem.adb, gnatname.adb, gnatsym.adb, gprcmd.adb, vms_conv.adb: + Output the copyright message on a separate line from the version + message. + +2004-12-07 Joel Brobecker + + * g-os_lib.adb (Spawn): Explicitly initialize Saved_Error to avoid a + compile-time warning. + +2004-12-07 Robert Dewar + + * g-regpat.adb: (Match): Change a misuse of or to or else + +2004-12-07 Ed Schonberg + + * lib-xref.adb: + (Generate_Reference): Handle properly a reference to an entry formal, + when an accept statement has a pragma Unreferenced for it. + + * sem_ch9.adb (Analyze_Accept_Statement): Reset the Is_Referenced flag + and the Has_Pragma_Unreferenced flag for each formal before analyzing + the body, to ensure that warnings are properly emitted for each accept + statement of a given task entry. + +2004-12-07 Vasiliy Fofanov + + * Makefile.in: Add support for foreign threads on VMS. + +2004-12-07 Richard Kenner + + * misc.c (gnat_types_compatible_p, LANG_HOOKS_TYPES_COMPATIBLE_P): + Remove. + (LANG_HOOKS_REDUCE_BIT_FIELD_OPERATIONS): New. + + * adaint.h: (__gnat_dup, __gnat_dup2): Add missing decls. + + * trans.c (Exception_Handler_to_gnu_sjlj): Also handle renamed + exception. + (call_to_gnu): Convert to actual DECL_ARG_TYPE, not variant of it. + +2004-12-07 Robert Dewar + + * nlists.adb (Prepend_Debug): Remove parameters and nest within + Prepend. + (Remove_Next_Debug): Same fix + + * nlists.ads: Correct bad comments for Prev and Prev_Non_Pragma (we do + maintain back pointers now, though we did not used to, and comments + were out of date). + (Prepend): Remove pragma Inline. + (Remove_Next): Same cleanup + +2004-12-07 Thomas Quinot + + * sem_ch4.adb (Process_Implicit_Dereference_Prefix): New subprogram + used to record an implicit dereference as a read operation on its + prefix when operating under -gnatc. Necessary to avoid spurious + 'variable assigned but never read' warnings in that mode. + (Process_Indexed_Component, Analyze_Selected_Component): When the prefix + is a non-overloaded implicit dereference, call the above subprogram to + ensure proper recording of references. + +2004-12-07 Gary Dismukes + + * sem_ch5.adb (One_Bound): Remove call to Resolve, as the bound needs + to be resolved later as part of Analyze_Iteration_Scheme's call to + Make_Index. + +2004-12-07 Ed Schonberg + + * sem_ch8.adb (Find_Type): If node is a reference to 'Base and the + prefix is not a scalar type, place error message on prefix, not on + type entity. + +2004-12-07 Bernard Banner + + * vxaddr2line.adb: Add support for x86 vxworks + +2004-12-07 Thomas Quinot + + * g-socket.ads (Get_Host_By_Address, Get_Host_By_Name): Clarify + documentation of the behaviour of these functions when passed an IP + address that has no record in the system hosts database and no reverse + record in the DNS. + + * cstand.adb, a-tags.ads: Fix typos in comment. + +2004-12-07 Robert Dewar + + * exp_ch2.adb, exp_ch3.adb, exp_ch5.adb, exp_ch8.adb, + exp_ch9.adb, exp_pakd.adb, interfac.ads, sem_ch6.adb, + sem_ch7.adb, sem_ch10.adb, sem_ch13.adb, sem_ch3.adb, + s-poosiz.ads: Minor reformatting + + * make.adb: Minor reformatting + Add some ??? comments asking for more comments + + * s-poosiz.adb: Minor reformatting + Add comments on alignment requirement + + * sinfo.ads: Remove obsolete comment and fix typo. + +2004-12-07 Vincent Celier + Sergey Rybin + + * gnat_ugn.texi: Update the section "The GNAT Driver and Project + Files" with the new tool and package names. + Reformatting to suppress most of the warnings for line too long + Document the new section "Project Search Path:" in the output of + gnatls -v. + Add gnatmetric section + +2004-12-07 Vincent Celier + + * vms_data.ads: Correct GNAT METRIC qualifiers: -I-, -Idir and + -gnatec= are not direct switches of gnatmetric. Changed -eis to -eps + and -eit to -ept. Added qualifier + /ELEMENT_METRICS=CONSTRUCT_NESTING_MAX for new switch -ec. + +2004-11-27 Andreas Schwab + + * Make-lang.in (ada/trans.o): Depend on $(EXPR_H). + +2004-11-25 Arnaud Charlet + + * g-socthi-mingw.ads, g-socthi-vms.ads: Remove C_Read and C_Write from + internal implementation unit GNAT.Sockets.Thin, + as their usage for sockets is non-portable (using the read and write + functions from the system runtime library is fine on UNIX but won't + work under Windows). + + * mingw32.h: Update copyright notice. + +2004-11-25 Arnaud Charlet + + * ada-tree.h: Minor reformatting of previous change to avoid lines + longer than 79 characters. + +2004-11-25 Olivier Hainque + + * tb-gcc.c: GCC infrastructure based implementation of + __gnat_backtrace. + +2004-11-24 Steven Bosscher + + * misc.c (gnat_post_options): Don't clear + flag_inline_functions. + +2004-11-22 Andrew Pinski + + PR ada/17986 + * ada-tree.h (lang_tree_node): Set chain_next to be the chain of the + tree. + +2004-11-21 Andreas Jaeger + + * stylesw.adb: Change Style_Check_Subprogram_Order to + Style_Check_Order_Subprograms. + +2004-11-18 Arnaud Charlet + + * adaint.h, adaint.c + (__gnat_portable_spawn): Fix cast of spawnvp third parameter + to avoid warnings. + Add also a cast to kill another warning. + (win32_no_block_spawn): Initialize CreateProcess's dwCreationFlags + parameter with the priority class of the parent process instead of + always using the NORMAL_PRIORITY_CLASS. + (__gnat_dup): New function. + (__gnat_dup2): New function. + (__gnat_is_symbolic_link): Enable the effective body of this + function when __APPLE__ is defined. + + * g-os_lib.ads, g-os_lib.adb (Spawn): Two new procedures. + Update comments. + +2004-11-18 Olivier Hainque + + * a-exexpr.adb (Others_Value, All_Others_Value): New variables, the + address of which may be used to represent "others" and "all others" + choices in exception tables, instead of the current harcoded + (void *)0 and (void *)1. + (Setup_Exception): Do nothing in the GNAT SJLJ case. + + * gigi.h (others_decl, all_others_decl): New decls representing the + new Others_Value and All_Others_Value objects. + (struct attrib): Rename "arg" component as "args", since GCC expects a + list of arguments in there. + + * raise.c (GNAT_OTHERS, GNAT_ALL_OTHERS): Are now the address of the + corresponding objects exported by a-exexpr, instead of hardcoded dummy + addresses. + + * trans.c (Exception_Handler_to_gnu_zcx): Use the address of + others_decl and all_others_decl instead of hardcoded dummy addresses + to represent "others" and "all others" choices, which is cleaner and + more flexible with respect to the possible eh pointer encoding policies. + + * utils.c (init_gigi_decls): Initialize others_decl and all_others_decl. + (process_attributes): Account for the naming change of the "args" + attribute list entry component. + + * decl.c (build_attr_list): Rename into prepend_attributes to allow + cumulating attributes for different entities into a single list. + (gnat_to_gnu_entity): Use prepend_attributes to build the list of + attributes for the current entity and propagate first subtype + attributes to other subtypes. + : Attribute arguments are attr->args and not + attr->arg any more. + (build_attr_list): Ditto. Make attr->args a TREE_LIST when there is an + argument provided, as this is what GCC expects. Use NULL_TREE instead + of 0 for trees. + +2004-11-18 Robert Dewar + + * a-stmaco.ads, exp_util.ads, exp_util.adb, i-cpp.ads, i-cpp.adb: + Minor reformatting througout (including new function specs) + Add ??? comments asking for clarification. + +2004-11-18 Thomas Quinot + + * butil.ads, butil.adb, bindgen.adb (Get_Unit_Name_String): Remove + incomplete duplicate implementation of this subprogram from butil. + +2004-11-18 Thomas Quinot + + * exp_dist.adb (Build_RPC_Receiver_Body): New subprogram. This + procedures factors the common processing for building an RPC receiver + for an RCI package or an RACW type. + Stylistic cleanup: change '/= Empty' to 'Present ()'; move body of + Build_Remote_Subprogram_Proxy_Type into proper alphabetical order. + (Get_PCS_Name): New subprogram. Returns the name of the PCS currently + in use. + (Specific_Add_RACW_Features): New subprogram. PCS-specific part of + Add_RACW_Features. + (Specific_Add_RAST_Features): New subprogram. PCS-specific part of + Add_RAST_Features. + (Assign_Subprogram_Identifier): New subprogram. Provision for assigning + distribution subprogram identifiers that are either subprogram numbers + or strings. + (Get_Subprogram_Ids): New subprogram. Retrieve both the numeric and + string distribution identifiers assigned to a given subprogram. + (Get_Subprogram_Id): Reimplement in terms of Get_Subprogram_Ids. + (Add_RAS_Dereference_TSS): Add comments. + (Build_General_Calling_Stubs): Note that the RACW_Type formal parameter + is not referenced yet because it will be used by the PolyORB DSA + implementation. + (Insert_Partition_Check): Remove fossile code. + (First_RCI_Subprogram_Id): Document this constant. + (Add_RAS_Access_TSS): Correct the setting of the Etype of the + RAS_Access TSS. + (Get_Pkg_Name_String): Remove subprogram. Usage occurrences are + replaced with calls to Get_Library_Unit_Name_String. Previously there + were several instances of the same code in different locations in the + compiler; this checkin completes the replacement of all of these + instances with calls to a common subprogram. + Minor reformatting. + + * sem_dist.adb: Remove comment noting that RPC receiver generation + should be disabled for RACWs that implement RASs. + (Process_Partition_Id): Use new subprogram Get_Library_Unit_Name_String. + + * sem_util.ads, sem_util.adb (Has_Stream): New function + (Get_Library_Unit_Name_String): New subprogram to retrieve the fully + qualified name of a library unit into the name buffer. + (Note_Possible_Modification): Generate a reference only + if the context comes from source. + + * snames.ads (PCS_Names): New subtype corresponding to names of + supported implementations of the Partition Communication Subsystem + (PCS) (i.e. the runtime library support modules for the distributed + systems annex). + +2004-11-18 Robert Dewar + Ed Schonberg + + * einfo.ads, einfo.adb: Remove Is_Psected flag, no longer used + (Has_Rep_Pragma): New function + (Has_Attribute_Definition_Clause): New function + (Record_Rep_Pragma): Moved here from sem_ch13.adb + (Get_Rep_Pragma): Remove junk kludge for Stream_Convert pragma + + * sem_ch13.ads, sem_ch13.adb (Record_Rep_Pragma): Moved to einfo.adb + + * exp_prag.adb: (Expand_Pragma_Common_Object): New procedure + (Expand_Pragma_Psect_Object): New procedure + These procedures contain the revised and cleaned up processing for + these two pragmas. This processing was formerly in Sem_Prag, but + is more appropriately moved here. The cleanup involves making sure + that the pragmas are properly attached to the tree, and that no + nodes are improperly shared. + + * sem_prag.adb: Move expansion of Common_Object and Psect_Object + pragmas to Exp_Prag, which is more appropriate. + Attach these two pragmas to the Rep_Item chain Use Rep_Item chain to + check for duplicates Remove use of Is_Psected flag, no longer needed. + Use new Make_String_Literal function with string. + + * exp_attr.adb (Expand_Fpt_Attribute): The floating-point attributes + that are functions return universal values, that have to be converted + to the context type. + Use new Make_String_Literal function with string. + (Get_Stream_Convert_Pragma): New function, replaces the use of + Get_Rep_Pragma, which had to be kludged to work in this case. + + * freeze.adb: Use new Has_Rep_Pragma function + + * exp_intr.adb, exp_ch3.adb, sem_attr.adb: Use new Make_String_Literal + function with string. + Use new Has_Rep_Pragma function. + + * tbuild.ads, tbuild.adb (Make_String_Literal): New function, takes + string argument. + +2004-11-18 Robert Dewar + + * errout.ads, errout.adb: (First_Sloc): New function + + * par-ch5.adb (P_Condition): Check for redundant parens is now a style + check (-gnatyx) instead of being included as a redundant construct + warning. + + * sem_ch6.adb: Change name Style_Check_Subprogram_Order to + Style_Check_Order_Subprograms. + + * style.ads, styleg.ads, styleg.adb, styleg-c.adb, stylesw.ads, + stylesw.adb: Add Style_Check_Xtra_Parens + + * usage.adb: Add line for -gnatyx (check extra parens) + + * vms_data.ads: Add entry for STYLE_CHECKS=XTRA_PARENS => -gnatyx + +2004-11-18 Ed Schonberg + Robert Dewar + + * exp_ch4.adb (Expand_N_Selected_Component): If the component is the + discriminant of a constrained subtype, analyze the copy of the + corresponding constraint, because in some cases it may be only + partially analyzed. + Removes long-lived ??? comments. + + * exp_ch7.adb (Establish_Transient_Scope): Remove complex code that + handled controlled or secondary-stack expressions within the + iteration_scheme of a loop. + + * sem_ch5.adb (Analyze_Iteration_Scheme): Build a block to evaluate + bounds that may contain functions calls, to prevent memory leaks when + the bound contains a call to a function that uses the secondary stack. + (Check_Complex_Bounds): Subsidiary of Analyze_Iteration_Scheme, to + generate temporaries for loop bounds that might contain function calls + that require secondary stack and/or finalization actions. + + * sem_ch4.adb (Analyze_Indexed_Component_Form): If the prefix is a + selected component and the selector is overloadable (not just a + function) treat as function call, Analyze_Call will disambiguate if + necessary. + (Analyze_Selected_Component): Do not generate an actual subtype for the + selected component if expansion is disabled. The actual subtype is only + needed for constraint checks. + (Analyze_Allocator): If restriction No_Streams is set, then do + not permit objects to be declared of a stream type, or of a + composite type containing a stream. + + * restrict.ads: Remove the a-stream entry from Unit_Array, since + No_Streams no longer prohibits with'ing this package. + + * sem_ch3.adb (Build_Derived_Record_Type): If the parent type has + discriminants, but the parent base has unknown discriminants, there is + no discriminant constraint to inherit. Such a discrepancy can arise + when the actual for a formal type with unknown discriminants is a + similar private type whose full view has discriminants. + (Analyze_Object_Declaration): If restriction No_Streams is set, then + do not permit objects to be declared of a stream type, or of a + composite type containing a stream. + +2004-11-18 Ed Schonberg + + * exp_dbug.ads: Update documentation to reflect simpler encoding for + protected operations. + + * exp_ch9.adb (Build_Selected_Name): Do not include "PT" suffix in + generated name, it complicates decoding in gdb and hinders debugging + of protected operations. + (Build_Barrier_Function_Specification): Set the Needs_Debug_Info + flag for the protected entry barrier function. + (Build_Protected_Entry_Specification): Set the Needs_Debug_Info + flag for the protected entry function. + +2004-11-18 Nicolas Setton + + * expect.c: Define __unix__ when __APPLE__ is defined. + + * Makefile.in: Inform the value of the variable GMEM_LIB in the + Darwin-specific section. + + * lang-specs.h: Change the placement of the %1 marker. + Works around the fact that gcc adds -fPIC by default under Darwin. + +2004-11-18 Ed Schonberg + + * exp_pakd.adb (Convert_To_PAT_Type): After replacing the original + type of the object with the packed array type, set the Analyzed flag + on the object if it is an entity or simple indexed component, to avoid + spurious type errors. + +2004-11-18 Gary Dismukes + + * gnat1drv.adb, gnatbind.adb, gnatchop.adb, gnatfind.adb, gnatlink.adb, + gnatls.adb, gnatxref.adb, gprep.adb: Output the copyright message on a + separate line from the version message. + +2004-11-18 Ed Falis + + * init.c (__gnat_map_signal): map SIGSEGV to Storage_Error for AE653 + vthreads. + (init_float): Eliminate initialization of floating point status for + AE653. The instructions have no effect for vThreads. + +2004-11-18 Vincent Celier + + * make.adb (Gnatmake): Invoke gnatlink with -shared-libgcc when + gnatbind is invoked with -shared. + +2004-11-18 Jose Ruiz + + * s-tposen.adb (Lock_Entry): Remove the code for raising Program_Error + for Detect_Blocking which is redundant with the check done within the + procedure Protected_Single_Entry_Call. + (Lock_Read_Only_Entry): Remove the code for raising Program_Error for + Detect_Blocking which is redundant with the check done within the + procedure Protected_Single_Entry_Call. + +2004-11-18 Vincent Celier + + * makegpr.adb (Compile): Put the compiling switches (in package + Compiler and on the command line) immediately after "-c", instead of + at the end of the command line invocation of the compiler, when + compiling a non-Ada file. + (Build_Global_Archive): When there is no need to rebuild the archive, + set Global_Archive_Exists, so that the archive is passed to the linker + if one is needed. + +2004-11-18 Robert Dewar + Sergey Rybin + + * gnat_ugn.texi: + Remove extra paren check from list of checks for redundant constructs + Add documentation of new -gnatyx style check (check extra parens) + Remove paragraph about gnatelim debug options. + + * gnat_rm.texi: Document that Ada.Streams now forbids creating stream + objects rather than forbidding dependencies on the package Ada.Streams. + + * sinfo.ads: Add ??? note that we should document pragmas passed to + back end. + + * g-expect.ads: Fix a few typos in the comments. + +2004-11-09 Joseph S. Myers + + * misc.c (gnat_handle_option): Use %< and %> for quoting in + warning message. + +2004-11-08 Rainer Orth + + * a-numaux-x86.adb (Tan): Fix fdivp syntax. + +2004-11-07 Andreas Schwab + + * Makefile.in (install-gnatlib): Remove spurious hyphen. + +2004-11-02 Andrew Pinski + + PR ada/18228 + * Makefile.in (darwin): Set soext to .dylib. + +2004-10-26 Vincent Celier + Thomas Quinot + + * g-socthi-vms.adb, g-socthi-mingw.adb, g-socthi-vxworks.ads: + (C_Writev): Change MSG_Forced_Flags to Constants.MSG_Forced_Flags as + there is no use of GNAT.Sockets.Constants. + Remove remaining pragma Import for C_Write + Remove C_Read and C_Write from internal implementation unit + GNAT.Sockets.Thin, as their usage for sockets is non-portable (using + the read and write functions from the system runtime library is fine + on UNIX but won't work under Windows). + + * g-socket.adb: (Abort_Selector): Use C_Send instead of C_Write. + (Check_Selector): Use C_Recv instead of C_Read. + Selectors are the GNAT.Sockets abstraction to perform a select() + call on a set of descriptors. To allow abortion of an ongoing + select operation, some data is written to a dedicated socket that + is always monitored. + Under Windows, the write and read library functions cannot operate + on sockets, so we need to use send and recv instead, which is portable + across all supported platforms. + + * g-socthi.ads: Remove C_Read and C_Write from internal implementation + unit GNAT.Sockets.Thin, as their usage for sockets is non-portable + (using the read and write functions from the system runtime library is + fine on UNIX but won't work under Windows). + +2004-10-26 Nicolas Setton + + * mlib-tgt-darwin.adb: New file. + + * mlib-tgt-tru64.adb, mlib-tgt-aix.adb, mlib-tgt-irix.adb, + mlib-tgt-hpux.adb, mlib-tgt-linux.adb, mlib-tgt-solaris.adb, + mlib-tgt-vms-alpha.adb, mlib-tgt-vms-ia64.adb, + mlib-tgt-mingw.adb, mlib-tgt-vxworks.adb (Archive_Indexer_Options): New + subprogram body. + + * Makefile.in: Add support for building shared libraries under Darwin. + (EXTRA_GNATRTL_NONTASKING_OBJS, ppc-vxworks): Add s-vxwexc.o, containing + the low level EH init subprogram to be called from __gnat_initialize. + + * mlib-tgt.ads, mlib-tgt.adb (Archive_Indexer_Options): New subprogram, + indicates which options to pass to the archive indexer. + + * mlib-utl.adb: Add support for calling ranlib with additional + options. This is needed for instance under Mac OS X. + (Ranlib_Options): New global variable, used to store the potential + options to pass to ranlib. + (Ar): Use Ranlib_Options when spawning ranlib. + (Initialize): Set the value of ranlib option. + +2004-10-26 Olivier Hainque + + * s-parame-linux.adb (Minimum_Stack_Size): Adjust to return 12K + instead of 8K, to reflect the real potential needs for stack-checking + in the ZCX case. + +2004-10-26 Pascal Obry + + * s-parame-mingw.adb (Default_Stack_Size): Add some comments. + + * s-taprop-mingw.adb (Create_Task): Set initial stack size to 1024. On + Windows only the initial thread stack size can be set so it is good to + start we a low stack size. + The OS will adjust the size as needed. + +2004-10-26 Olivier Hainque + Nicolas Setton + + * expect.c, adaint.c, link.c, sysdep.c (unix sections): Guard with + "__unix__" instead of "unix". + The latter is implicitly defined by gcc3.2 but not by gcc >= 3.4, so the + sections were just mistakenly ignored. The former is + implicitely defined by gcc2.8, gcc3.2 and gcc3.4. + Update #ifdef preprocessor macro to detect the symbol __hpux__ instead + of hpux. This prevents an unwanted definition of the symbol + convert_addresses in adaint.o. + +2004-10-26 Gary Dismukes + + * a-exexpr.adb (Setup_Key): Change initial value to 16#DEAD#, for + compatibility with type Unwind_Word on 16-bit targets such as AAMP. + +2004-10-26 Cyrille Comar + + * a-filico.ads, a-filico.adb: fix incorrect header. + +2004-10-26 Javier Miranda + + * a-ststio.ads: Fix typo in identifier + +2004-10-26 Thomas Quinot + + * sem_ch4.adb: Minor reformatting. + +2004-10-26 Ed Schonberg + + * checks.adb (Expr_Known_Valid): If floating-point validity checks are + enabled, check the result of unary and binary operations when the + expression is the right-hand side of an assignment. + +2004-10-26 Vincent Celier + + * clean.adb (Delete): Do not output warnings when in quiet output and + not in verbose mode. + (Force_Deletions): New Boolean flag, defaulted to False + (Delete): Only delete a file if it is writable, and when + Force_Deletions is True. + (Parse_Cmd_Line): New switch -f: set Force_Deletions to True + (Usage): Line for new switch -f + (Clean_Directory): Use GNAT.OS_Lib.Set_Writable instead of rolling our + own. + +2004-10-26 Eric Botcazou + + * decl.c (gnat_to_gnu_field): Use the type of the inner object for a + JM type only if its size matches that of the wrapper. When a size is + prescribed and the field is not aliased, remove the wrapper of a JM + type only if the size is not greater than that of the packed array. + (gnat_to_gnu_entity): Change the extension of packed array wrappers + from LJM to JM. + +2004-10-26 Geert Bosch + + * eval_fat.adb (Eps_Model,Eps_Denorm): Remove, no longer used. + (Succ): Re-implement using Scaling, Exponent and Ceiling attributes. + (Pred): Implement in terms of Succ. + +2004-10-26 Ed Schonberg + + * exp_aggr.adb (Safe_Component): An aggregate component that is an + unchecked conversion is safe for in-place use if the expression of the + conversion is safe. + (Expand_Array_Aggregate): An aggregate that initializes an allocator may + be expandable in place even if the aggregate does not come from source. + (Convert_Array_Aggr_In_Allocator): New procedure to initialize the + designated object of an allocator in place, rather than building it + first on the stack. The previous scheme forces a full copy of the array, + and may be altogether unsusable if the size of the array is too large + for stack allocation. + +2004-10-26 Robert Dewar + + * exp_ch4.adb (Expand_N_Op_Eq): Make sure we expand a loop for array + compares if the component is atomic. + + * exp_ch5.adb (Expand_Assign_Array): Make sure we expand a loop for + array assignment if the component type is atomic. + +2004-10-26 Ed Schonberg + Eric Botcazou + + * exp_ch6.adb (Expand_Actuals): If the actual for an in-out parameter + is aliased and is a by_reference type, do not pass by copy. + (Expand_N_Function_Call) : New function to + detect whether the call is in the right side of an assignment or + the expression of an object declaration. Recurse on component + association within aggregates. + Call it in the condition that determines whether the temporary is + necessary for correct stack-checking. + +2004-10-26 Thomas Quinot + + * exp_dist.adb (Build_General_Calling_Stubs): New formal parameter + RACW_Type, used in the PolyORB version. + Rename RCI_Info to RCI_Locator, for consistency between the PolyORB + version and the GARLIC version. + + * snames.ads, snames.adb, s-parint.ads, s-parint.adb: + Rename RCI_Info to RCI_Locator for better consistency between the + GARLIC and PolyORB versions of the distributed systems annex. + (DSA_Implementation_Name): This enumeration lists the possible + implementations of the Partition Communication Subsystem for the + Distributed Systems Annex (DSA). The three available implementations + are the dummy stub implementation (No_DSA), and two versions based on + two different distribution runtime libraries: GARLIC and PolyORB. Both + the GARLIC PCS and the PolyORB PCS are part of the GLADE distribution + technology. + Change the literal GLADE_DSA to GARLIC_DSA to accurately describe + that organization. + + * rtsfind.ads: Rename RCI_Info to RCI_Locator for better consistency + between the GARLIC and PolyORB versions of the distributed systems + annex. + Remove RE_Unbounded_Reclaim_Pool since it is unused. + +2004-10-26 Gary Dismukes + + * gnat1drv.adb: Suppress calling the back end when + Frontend_Layout_On_Target is true. + +2004-10-26 Thomas Quinot + + * g-os_lib.ads, g-os_lib.adb (Set_Executable, Set_Writable, + Set_Read_Only): New subprograms. + These new routines allow the user to set or unset the Owner execute + and Owner write permission flags on a file. + + * makegpr.adb, mlib.adb, mlib-prj.adb: Use + GNAT.OS_Lib.Set_Executable instead of rolling our own. + +2004-10-26 Matthew Gingell + + * i-cpp.ads, i-cpp.adb: Change layout of VTable for new C++ ABI. + +2004-10-26 Pascal Obry + + * init.c (__gnat_error_handler) [Win32]: Instead of trying to read the + memory before the faulting page we properly test the process read + access for this address using appropriate Win32 routine. + (HPUX sections): guard with "__hpux__" instead of "hpux". + +2004-10-26 Robert Dewar + + * lib-xref.adb (Generate_Reference): Don't complain about reference to + entry parameter if pragma Unreferenced set, since we do not properly + handle the case of multiple parameters. + +2004-10-26 Vincent Celier + + * prj-env.adb: (Contains_ALI_Files): New Boolean function + (Ada_Objects_Path.Add): For a library project, add to the object path + the library directory only if there is no object directory or if the + library directory contains ALI files. + (Set_Ada_Paths.Add.Recursive_Add): Ditto + +2004-10-26 Vincent Celier + + * prj-nmsc.adb (Language_Independent_Check): Do not forbid virtual + extension of library projects. + + * prj-part.adb: If env var ADA_PROJECT_PATH is not defined, project + path defaults to ".:/lib/gnat". + (Parse): For an extending all project, allow direct import of a project + that is virtually extended. + + * prj-proc.adb (Imported_Or_Extended_Project_From): If a project with + the specified name is directly imported, return its ID. Otherwise, if + an extension of this project is imported, return the ID of the + extension. + +2004-10-26 Robert Dewar + + * s-arit64.adb: (Le3): New function, used by Scaled_Divide + (Sub3): New procedure, used by Scaled_Divide + (Scaled_Divide): Substantial rewrite, avoid duplicated code, and also + correct more than one instance of failure to propagate carries + correctly. + (Double_Divide): Handle overflow case of largest negative number + divided by minus one. + + * s-arit64.ads (Double_Divide): Document that overflow can occur in + the case of a quotient value out of range. + Fix comments. + +2004-10-26 Robert Dewar + + * s-bitops.adb (Bit_Eq): Remove redundant check. + + * s-bitops.ads: Minor comment updates + Change some occurrences of Address to System.Address + + * s-carsi8.ads: Fix minor cut-and-paste error in comments + +2004-10-26 Ed Schonberg + + * sem_attr.adb (Resolve_Attribute, case 'Access): Apply proper + accessibility check to prefix that is a protected operation. + +2004-10-26 Ed Schonberg + + * sem_ch10.adb (Optional_Subunit): If file of expected subunit is + empty, post message on stub. + +2004-10-26 Ed Schonberg + Javier Miranda + + * sem_ch12.adb (In_Main_Context): Predicate to determine whether the + current instance appears within a unit that is directly in the context + of the main unit. + Used to determine whether the body of the instance should be analyzed + immediately after its spec, to make its subprogram bodies available + for front-end inlining. + (Analyze_Formal_Array_Type): Cleanup condition that checks that range + constraint is not allowed on the component type (AARM 12.5.3(3)) + +2004-10-26 Cyrille Comar + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause, case + 'Storage_Pool): enhance, document & limit detection of non-sharable + internal pools. + + * impunit.adb: Make System.Pool_Global and System.Pool_Local visible. + + * s-pooglo.ads: Add more documentation now that this pool is properly + documented. + +2004-10-26 Ed Schonberg + + * sem_ch3.adb (Complete_Private_Subtype): If the full view is a task + or protected type with discriminants, do not constrain the + corresponding record type if the subtype declaration has no + discriminant constraints. This can be the case in source code, or in + the subtype declaration created to rename an actual type within an + instantiation. + +2004-10-26 Ed Schonberg + + * sem_ch6.adb (Analyze_Subprogram_Body): If body is a subunit for a + different kind of stub (possibly wrong name for file), do not check + for conformance. + (Uses_Secondary_Stack): New subsidiary to Build_Body_To_Inline. If body + includes call to some function that returns an unconstrained type, do + not inline. + +2004-10-26 Ed Schonberg + + * sem_elab.adb (Check_Elab_Call): Do not check a call that does not + appear in the code for the main unit. Dependencies among units in the + context of the main unit are established when those other units are + compiled. Otherwise spurious elaboration constraints can generate + incorrect elaboration circularities. + +2004-10-26 Thomas Quinot + Ed Schonberg + + * sem_util.adb (Is_Aliased_View): Defend against the case where this + subprogram is called with a parameter that is not an object name. This + situation arises for some cases of illegal code, which is diagnosed + later, and in this case it is wrong to call Is_Aliased, as that might + cause a compiler crash. + (Explain_Limited_Type): Refine previous fix to include + inherited components of derived types, to provide complete information. + + * exp_ch9.adb (Set_Privals): Set the Ekind of the actual object that + is the prival for a protected object. + It is necessary to mark this entity as a variable, in addition to + flagging it as Aliased, because Sem_Util.Is_Aliased_View has been + modified to avoid checking the Aliased flag on entities that are not + objects. (Checking that flag for non-objects is erroneous and could + lead to a compiler crash). + +2004-10-26 Robert Dewar + + * s-fatgen.adb (Pred): Fix redundant test for X > 0.0, since if + X_Frac = 0.5, then we know that the number X must be positive. + (Succ): Remove the same redundant test, and also fix the primary test + to test for X_Frac = -0.5 (used to be 0.5) which is clearly wrong. + Minor reformatting + (Decompose): Add fuller comments to spec + +2004-10-26 Pascal Obry + + * tracebak.c (IS_BAD_PTR): Use IsBadCodePtr on Win32 to check for ptr + validity (process must have read access). Set to 0 in all other cases. + (STOP_FRAME): Now check for ptr validity to avoid a segmentation + violation on Win32. + (VALID_STACK_FRAME): Check for ptr validity on Win32 to avoid a + segmentation violation. + +2004-10-26 Eric Botcazou + + * trans.c (call_to_gnu): For an (in-)out parameter passed by reference + whose type is a constructed subtype of an aliased object with an + unconstrained nominal subtype, convert the actual to the constructed + subtype before taking its address. + +2004-10-26 Vincent Celier + + * a-dirval.ads, a-dirval.adb, a-dirval-vms.adb, a-dirval-mingw.adb + (Is_Path_Name_Case_Sensitive): New function + + * a-direct.adb (To_Lower_If_Case_Insensitive): New procedure + (Base_Name, Simple_Name, Current_Directory, Compose, + Containing_Directory, Full_Name): Call To_Lower_If_Case_Insensitive on + the result. + +2004-10-26 Cyrille Comar + Vasiliy Fofanov + Vincent Celier + + * gnat_ugn.texi: Generalize "finding memory problems" section into a + "memory management issues" section and document some of the useful + memory pools provided as part of the GNAT library. + Remove "virtual" from declaration of A::method2 in + the simple example of Ada/C++ mixed system. + Library Projects may be virtually extended: their virtual extensions + are not Library Projects. + Added section on extending project hierarchies. + +2004-10-19 Aaron W. LaFramboise + + * adaint.c (__gnat_get_libraries_from_registry): Cast value + to LPBYTE. + (__gnat_portable_spawn): Remove const. + + * mingw32.h (MAXPATHLEN): Check for previous definition. + +2004-10-17 Matthias Klose + + * gnatvsn.ads: Set gnat library version to 4.0. + +2004-10-05 Vincent Celier + + * mlib-tgt.ads: (Build_Dynamic_Library): New parameter Options_2 + +2004-10-04 Laurent Guerby + + PR ada/15156 + * Makefile.in: Define and use RANLIB_FLAGS. + +2004-10-04 Pascal Obry + + * tracebak.c: Always set LOWEST_ADDR to 0 on Win32 (as done on all + other x86 platforms). + +2004-10-04 Olivier Hainque + + * s-tassta.adb (Task_Wrapper): Make it Convention C, which makes sense + in general and triggers stack alignment adjustment for thread entry + points on targets where this is necessary. + +2004-10-04 Bernard Banner + + PR ada/13897 + * Makefile.in: Add section for powerpc linux + Add variant i-vxwork-x86.ads + + * i-vxwork-x86.ads, system-linux-ppc.ads: New files. + +2004-10-04 Olivier Hainque + + * init.c (__gnat_initialize): Call an Ada subprogram to perform the + table registration calls when need be. Ensures no reference to the crt + ctors symbol are issued in the SJLJ case, which avoids possible + undefined symbol errors in the case of modules to be statically linked + with the kernel. + +2004-10-04 Javier Miranda + + * sem_ch4.adb (Try_Object_Operation): Reformat the code to expand + in-line the code corresponding to subprogram Analyze_Actuals. In + addition, analyze the actuals only in case of subprogram call. + +2004-10-04 Ed Falis + + * s-vxwork-x86.ads: (FP_CONTEXT): Defined to be correct size + +2004-10-04 Sergey Rybin + + * g-dirope.ads (Base_Name): Clarify the meaning of the Suffix parameter + in the documentation. + +2004-10-04 Robert Dewar + + * sem_ch5.adb (Unblocked_Exit_Count): Now used for blocks as well as + IF and CASE. + (Analyze_Block_Statement): Add circuitry to detect following dead code + (Check_Unreachable_Code): Handle case of block exit + +2004-10-04 Robert Dewar + + * g-spipat.adb: (XMatch): Avoid warning for Logic_Error call + (XMatchD): Avoid warning for Logic_Error call + +2004-10-04 Robert Dewar + + * exp_ch4.adb (Is_Procedure_Actual): Correct so that this does not + consider expressions buried within a procedure actual to be an actual. + This caused some blowups with uses of packed slices within a procedure + actual. + +2004-10-04 Robert Dewar + + * exp_ch3.adb (Needs_Simple_Initialization): Modular packed arrays no + longer need to be initialized to zero. + (Get_Simple_Init_Val): Modular packed arrays no longer need to be + initialized to zero. + + * checks.adb (Expr_Known_Valid): Packed arrays are now always + considered valid, even if the representation is modular. That's correct + now that we no longer initialize packed modular arrays to zero. + + * exp_dbug.ads: Clarify documentation on handling of PAD and JM + suffixes. These are now documented as the only cases in which the + debugger ignores outer records. + Previously, the spec allowed arbitrary suffixes for this purpose. + Change name of LJM to JM for packed array pad records + Create separate section on packed array handling, and add a whole new + set of comments to this section describing the situation with packed + modular types and justification requirements depending on endianness. + +2004-10-04 Robert Dewar + + * a-except.adb: Add a comment for last change + + * einfo.ads: Minor spelling correction in comment + + * exp_pakd.adb, gnatdll.adb, prj-attr.ads: Minor reformatting + + * sem_ch11.adb: Fix a case of using | instead of \ for continuation + messages. + + * sem_util.ads: Minor comment update + +2004-10-04 Ed Schonberg + + * sem_ch6.adb (Analyze_Subprogram_Body): Do not treat Inline as + Inline_Always when in Configurable_Run_Time mode. + + * sem_prag.adb (Process_Convention): If entity is an inherited + subprogram, apply convention to parent subprogram if in same scope. + (Analyze_Pragma, case Inline): Do not treat Inline as Inline_Always + when in Configurable_Run_Time mode. + +2004-10-04 Ed Schonberg + + * sem_ch3.adb (Build_Derived_Record_Type): Set First/Last entity of + class_wide type after component list has been inherited. + +2004-10-04 Ed Schonberg + + * sem_ch12.adb (Check_Generic_Actuals): New predicate + Denotes_Previous_Actual, to handle properly the case of a private + actual that is also the component type of a subsequent array actual. + The visibility status of the first actual is not affected when the + second is installed. + (Process_Nested_Formal): Subsidiary of Instantiate_Formal_Package, to + make fully recursive the treatment of formals of packages declared + with a box. + (Restore_Nested_Formal): Subsidiary of Restore_Private_Views, to undo + the above on exit from an instantiation. + (Denotes_Formal_Package): When called from Restore_Private_Views, ignore + current instantiation which is now complete. + (Analyze_Package_Instantiation): No instantiated body is needed if the + main unit is generic. Efficient, and avoid anomalies when a instance + appears in a package accessed through rtsfind. + +2004-10-04 Ed Schonberg + + * exp_ch6.adb (Expand_N_Function_Call): If stack checking is enabled, + do not generate a declaration for a temporary if the call is part of a + library-level instantiation. + +2004-10-04 Ed Schonberg + + * sem_util.adb (Explain_Limited_Type): Ignore internal components when + searching for a limited component to flag. + + * exp_attr.adb (Freeze_Stream_Subprogram): Subsidiary procedure to + expansion of Input, to account for the fact that the implicit call + generated by the attribute reference must freeze the user-defined + stream subprogram. This is only relevant to 'Input, because it can + appear in an object declaration, prior to the body of the subprogram. + + * sem_ch13.adb (Rep_Item_Too_Late): Make the error non-serious, so that + expansion can proceed and further errors uncovered. + (Minor clean up): Fix cases of using | instead of \ for continuation + messages. + +2004-10-04 Richard Kenner + + * cuintp.c, decl.c, utils2.c: Use gcc_assert and gcc_unreachable. + + * trans.c (assoc_to_constructor): Fix unused var warning if no checking. + (gnat_gimplify_expr, case ADDR_EXPR): Fix error in last change. + Use gcc_assert and gcc_unreachable. + + * decl.c (gnat_to_gnu_entity, case object): Check and process a + specified alignment before validating size. + (gnat_to_gnu_entity) : Create a + stripped-down declaration for the type of the inner field when making + a JM type. + + * utils.c (finish_record_type): Do not compute the size in units + incrementally. Instead compute it once for the rep clause case. + Use gcc_assert and gcc_unreachable. + +2004-10-04 Vincent Celier + + * a-dirval-mingw.adb (Invalid_Character): Add '\' as invalid character + in file name. + (Is_Valid_Path_Name): Take '/' as a directory separator. + +2004-10-04 Vincent Celier + + * prj-part.adb (Parse_Single_Project): Call Is_Extending_All + (Extended_Project) only if Extended_Project is defined, to avoid + assertion error. + (Post_Parse_Context_Clause): Always call Set_Path_Name_Of with a + resolved path. + (Parse_Single_Project): Ditto. + + * prj-env.adb (Set_Ada_Paths.Add.Recursive_Add): Do not call + Add_To_Project_Path for virtual projects. + +2004-10-04 Vincent Celier + + * mlib-tgt-tru64.adb, mlib-tgt-aix.adb, mlib-tgt-irix.adb, + mlib-tgt-hpux.adb, mlib-tgt-linux.adb, mlib-tgt-solaris.adb, + mlib-tgt-vms-alpha.adb, mlib-tgt-vms-ia64.adb, mlib-tgt-mingw.adb, + mlib-tgt-vxworks.adb, mlib-tgt.adb (Build_Dynamic_Library): New + parameter Options_2. + + * mlib-prj.ads, mlib-prj.adb (Build_Library): Call + Build_Dynamic_Library with an empty Options_2. + + * mlib-utl.ads, mlib-utl.adb (Gcc): Parameter Options_2 has no + default anymore. + + * makegpr.adb (Get_Imported_Directories.add): Remove trailing + directory separator, if any. + (Gprmake): Do not allow mains on the command line for library projects. + Do not attempt to link when the project is a library project. + (Library_Opts): New table to store Library_Options. + (Build_Library): If Library_Options is specified, pass these options + when building a shared library. + +2004-10-04 Jose Ruiz + + * s-tposen.adb (Service_Entry): The object must be always unlocked at + the end of this procedure now that the unlock operation was inserted + by the expander. + +2004-10-04 Jose Ruiz + + * targparm.ads, targparm.adb (Targparm_Tags): Add PAS value + corresponding to the Preallocated_Stacks flags in System. + (Get_Target_Parameters): Including the processing for + Preallocated_Stacks. + + * system.ads, system-vxworks-x86.ads, system-darwin-ppc.ads, + system-vms_64.ads, system-unixware.ads, system-linux-ia64.ads, + system-freebsd-x86.ads, system-lynxos-ppc.ads, system-lynxos-x86.ads, + system-linux-x86_64.ads, system-tru64.ads, system-aix.ads, + system-vxworks-sparcv9.ads, system-vxworks-xscale.ads, + system-solaris-x86.ads, system-irix-o32.ads, system-irix-n32.ads, + system-hpux.ads, system-vxworks-m68k.ads, system-linux-x86.ads, + system-vxworks-mips.ads, system-os2.ads, system-interix.ads, + system-solaris-sparc.ads, system-solaris-sparcv9.ads, system-vms.ads, + system-mingw.ads, system-vms-zcx.ads, system-vxworks-ppc.ads, + system-vxworks-alpha.ads: Add the flag Preallocated_Stacks, that is + used to signal whether the compiler creates the required stacks and + descriptors for the different tasks (when True) or it is done by the + underlying operating system at run time (when False). + It is initially set to False in all targets. + + * exp_ch9.adb (Expand_N_Task_Type_Declaration): Create the task stack + if it is supported by the target. + (Make_Task_Create_Call): Pass the stack address if it has been + previously created. Otherwise pass a Null_Address. + + * snames.adb: Add _stack. + + * snames.ads: Add Name_uStack. Required to allow the expander to + statically allocated task stacks. + + * s-tarest.ads, s-tarest.adb (Create_Restricted_Task): Add + Stack_Address argument. + Check that its value is equal to Null_Address because this target does + not support the static stack allocation. + +2004-10-04 Thomas Quinot + + * usage.adb: Change "pragma inline" to "pragma Inline" in information + and error messages + +2004-10-04 Thomas Quinot + + * exp_dist.adb: Split declaration of asynchronous flag out of + Add_RACW_Read_Attribute. + Minor reformatting for better alignment with PolyORB version. + Store the entity for the asynchronous flag of an RACW, rather than the + expression, in the asynchronous flags table. This will allow this flag + to be used in other subprograms beside Add_RACW_Read_Attribute. + +2004-10-04 Thomas Quinot + + * g-socket.ads, g-socket.adb, g-socthi.adb, socket.c, + g-soccon-aix.ads, g-soccon-irix.ads, g-soccon-hpux.ads, + g-soccon-interix.ads, g-soccon-solaris.ads, g-soccon-vms.adb, + g-soccon-mingw.ads, g-soccon-vxworks.ads, g-soccon-freebsd.ads, + g-soccon.ads, g-soccon-unixware.ads, g-soccon-tru64.ads: Add new + sockets constant MSG_NOSIGNAL (Linux-specific). + Add new sockets constant MSG_Forced_Flags, list of flags to be set on + all Send operations. + For Linux, set MSG_NOSIGNAL on all send operations to prevent them + from trigerring SIGPIPE. + Rename components to avoid clash with Ada 2005 possible reserved + word 'interface'. + (Check_Selector): When the select system call returns with an error + condition, propagate Socket_Error to the caller. + +2004-10-01 Jan Hubicka + + * misc.c (gnat_expand_body): Update call of tree_rest_of_compilation. + +2004-09-23 Robert Dewar + + PR ada/17540 + * sem_prag.adb (Process_Import_Or_Interface): Don't set Is_Public here, + instead do this at freeze time (we won't do it if there is an address + clause). + Change "pragma inline" to "pragma Inline" in information and error + messages. + Minor reformatting. + + * freeze.adb (Check_Address_Clause): Remove previous change, not the + right way of doing things after all. + (Freeze_Entity): For object, set Is_Public for imported entities + unless there is an address clause present. + +2004-09-21 Olivier Hainque + + * decl.c (gnat_to_gnu_entity) : Check for a + dummy designated type via TYPE_MODE instead of COMPLETE_TYPE_P. This + ensures proper handling of types with rep clauses, which might have + their TYPE_SIZE set already. + +2004-09-21 Robert Dewar + + * decl.c (gnat_to_gnu_type, case E_Modular_Integer_Type): Wrap modular + packed array types in both little- and big-endian cases. This change + ensures that we no longer count on the unused bits being initialized + for such types (and in particular ensures that equality testing will + only read the relevant bits). + Change name TYPE_LEFT_JUSTIFIED_MODULAR_P to TYPE_JUSTIFIED_MODULAR_P + These changes mean that we no longer need to initialize small packed + arrays. + (gnat_to_gnu_entity) : Apply the same + optimization to an LJM field as to its parent field. + + * ada-tree.h, trans.c, utils.c, utils2.c: + Change name TYPE_LEFT_JUSTIFIED_MODULAR_P to TYPE_JUSTIFIED_MODULAR_P + +2004-09-20 Jan Hubicka + + * utils.c (gnat_finalize): Remove. + (end_subprog_body): Directly call cgraph_finalize_function; + do not lower the nested functions. + +2004-09-20 Robert Dewar + + PR ada/17540 + * freeze.adb (Check_Address_Clause): Reset Is_Imported and Is_Public + if an address clause is present, since that means that the Import + should be ignored. + +2004-09-20 Arnaud Charlet + + * 5tsystem.ads: Removed, no longer used. + +2004-09-17 Jeffrey D. Oldham + Zack Weinberg + + * ada-tree.def: Use tree_code_class enumeration constants + instead of code letters. + * ada-tree.h, decl.c, misc.c, trans.c, utils.c, utils2.c: + Update for new tree-class enumeration constants. + +2004-09-17 Vincent Celier + + * prj-attr-pm.ads, prj-attr-pm.adb: New files, to split some private + capabilities of the general project manager. + +2004-09-09 Vincent Celier + + * a-direct.ads: Add pragma Ada_05 + (Directory_Entry_Type): Give default value to component Kind to avoid + not initialized warnings. + + * a-direct.adb (Current_Directory): Remove directory separator at the + end. + (Delete_Directory, Delete_Tree): Raise Name_Error if Directory is not + an existing directory. + (Fetch_Next_Entry): Give default value to variable Kind to avoid warning + (Size (String)): Function C_Size returns Long_Integer, not File_Size. + Convert the result to File_Size. + + * prj.ads: (Project_Error): New exception + + * prj-attr.adb: Except in procedure Initialize, Fail comes from + Prj.Com, not from Osint. + (Attrs, Package_Attributes): Tables moved to private part of spec + (Add_Attribute, Add_Unknown_Package): Moved to new child package + Prj.Attr.PM. + (Register_New_Package (Name, Attributes), Register_New_Attribute): Raise + Prj.Project_Error after call to Fail. + (Register_New_Package (Name, Id)): Set Id to Empty_Package after calling + Fail. Check that package name is not already in use. + + * prj-attr.ads: Comment updates to indicate that all subprograms may be + used by tools, not only by the project manager, and to indicate that + exception Prj.Prj_Error may be raised in case of problem. + (Add_Unknown_Package, Add_Attribute): Moved to new child package + Prj.Attr.PM. + (Attrs, Package_Attributes): Table instantiations moved from the body to + the private part to be accessible from Prj.Attr.PM body. + + * prj-dect.adb (Parse_Package_Declaration): Call Add_Unknown_Package + from new package Prj.Attr.PM. + (Parse_Attribute_Declaration): Call Add_Attribute from new package + Prj.Attr.PM. + + * Makefile.in: Add prj-attr-pm.o to gnatmake object list + + * gnatbind.adb (Gnatbind): Correct warning message (Elaboration_Check + instead of Elaboration_Checks). + + * a-calend.adb: Minor reformatting + +2004-09-09 Richard Kenner + + * gigi.h (maybe_pad_type): New declaration. + (create_subprog_type): New arg RETURNS_BY_TARGET_PTR. + + * ada-tree.h: (TYPE_RETURNS_BY_TARGET_PTR_P): New macro. + + * cuintp.c: Convert to use buildN. + + * decl.c (maybe_pad_type): No longer static. + (gnat_to_gnu_entity, case E_Function): Handle case of returning by + target pointer. + Convert to use buildN. + + * trans.c (call_to_gnu): Add arg GNU_TARGET; support + TYPE_RETURNS_BY_TARGET_PTR_P. All callers changed. + (gnat_to_gnu, case N_Assignment_Statement): Call call_to_gnu if call on + RHS. + (gnat_to_gnu, case N_Return): Handle TYPE_RETURN_BY_TARGET_PTR_P. + (gnat_gimplify_expr, case ADDR_EXPR): New case. + Convert to use buildN. + + * utils2.c (gnat_build_constructor): Also set TREE_INVARIANT and + TREE_READONLY for const. + Convert to use buildN. + + * utils.c (create_subprog_type): New operand RETURNS_BY_TARGET_PTR. + (create_var_decl): Refine when TREE_STATIC is set. + Convert to use buildN. + +2004-09-09 Gary Dismukes + + * gnat_ugn.texi: Delete text relating to checking of ali and object + consistency. + + * a-except.adb (Rcheck_*): Add pragmas No_Return for each of these + routines. + +2004-09-09 Jose Ruiz + + * gnat_ugn.texi: Add Detect_Blocking to the list of configuration + pragmas recognized by GNAT. + + * gnat_rm.texi: Document pragma Detect_Blocking. + + * s-solita.adb (Timed_Delay_T): When pragma Detect_Blocking is active, + raise Program_Error if called from a protected operation. + + * s-taprob.adb (Lock): When pragma Detect_Blocking is active increase + the protected action nesting level. + (Lock_Read_Only): When pragma Detect_Blocking is active increase the + protected action nesting level. + (Unlock): When pragma Detect_Blocking is active decrease the protected + action nesting level. + + * s-taskin.adb (Initialize_ATCB): Initialize to 0 the + Protected_Action_Nesting. + + * s-taskin.ads: Adding the field Protected_Action_Nesting to the + Common_ATCB record. It contains the dynamic level of protected action + nesting for each task. It is needed for checking whether potentially + blocking operations are called from protected operations. + (Detect_Blocking): Adding a Boolean constant reflecting whether pragma + Detect_Blocking is active or not in the partition. + + * s-tasren.adb (Call_Simple): When pragma Detect_Blocking is active, + raise Program_Error if called from a protected operation. + (Task_Entry_Call): When pragma Detect_Blocking is active, raise + Program_Error if called from a protected operation. + (Timed_Task_Entry_Call): When pragma Detect_Blocking is active, raise + Program_Error if called from a protected operation. + + * s-tassta.adb (Abort_Tasks): When pragma Detect_Blocking is active, + raise Program_Error if called from a protected operation. + + * s-tpoben.adb (Lock_Entries): When pragma Detect_Blocking is active, + raise Program_Error if called from a protected operation, and increase + the protected action nesting level. + (Lock_Read_Only_Entries): When pragma Detect_Blocking is active, raise + Program_Error if called from a protected operation, and increase the + protected action nesting level. + (Unlock_Entries): When pragma Detect_Blocking is active decrease the + protected action nesting level. + + * s-tposen.adb (Lock_Entry): When pragma Detect_Blocking is active, + raise Program_Error if called from a protected operation, and increase + the protected action nesting level. + (Lock_Read_Only_Entry): When pragma Detect_Blocking is active, raise + Program_Error if called from a protected operation, and increase the + protected action nesting level. + (Protected_Single_Entry_Call): When pragma Detect_Blocking is active, + raise Program_Error if called from a protected operation. + (Timed_Protected_Single_Entry_Call): When pragma Detect_Blocking is + active, raise Program_Error if called from a protected operation. + (Unlock_Entry): When pragma Detect_Blocking is active decrease the + protected action nesting level. + + * sem_util.adb (Check_Potentially_Blocking_Operation): Remove the + insertion of the statement raising Program_Error. The run time + contains the required machinery for handling that. + + * sem_util.ads: Change comment associated to procedure + Check_Potentially_Blocking_Operation. + This procedure does not insert a call for raising the exception because + that is currently done by the run time. + + * raise.h (__gnat_set_globals): Pass the detect_blocking parameter. + + * init.c: Add the global variable __gl_detect_blocking that indicates + whether pragma Detect_Blocking is active (1) or not (0). Needed for + making the pragma available at run time. + (__gnat_set_globals): Pass and update the detect_blocking parameter. + + * lib-writ.adb (Write_ALI): Set the DB flag in the ali file if + pragma Detect_Blocking is active. + + * lib-writ.ads: Document the Detect_Blocking flag (DB) in ali files. + + * ali.adb (Scan_ALI): Set the Detect_Blocking value to true if the flag + DB is found in the ali file. Any unit compiled with pragma + Detect_Blocking active forces its effect in the whole partition. + + * a-retide.adb (Delay_Until): Raise Program_Error if pragma + Detect_Blocking is active and delay is called from a protected + operation. + + * bindgen.adb (Gen_Adainit_Ada): When generating the call to + __gnat_set_globals, pass 1 as Detect_Blocking parameter if pragma + Detect_Blocking is active (0 otherwise). + (Gen_Adainit_C): When generating the call to __gnat_set_globals, pass 1 + as Detect_Blocking parameter if pragma Detect_Blocking is active (0 + otherwise). + +2004-09-09 Thomas Quinot + + * gnat_rm.texi: Rename GNAT.Perfect_Hash.Generators to + GNAT.Perfect_Hash_Generators, and remove the empty GNAT.Perfect_Hash + package. + + * s-parint.ads, s-parint.adb (Get_RAS_Info): New subprogram. + (Register_Receiving_Stub): Add Subp_Info formal parameter. + Update API in placeholder implemetation of s-parint to reflect changes + in distribution runtime library. + + * sem_ch3.adb (Expand_Derived_Record): Rename to + Expand_Record_Extension. + + * sem_disp.adb (Check_Controlling_Formals): Improve error message for + primitive operations of potentially distributed object types that have + non-controlling anonymous access formals. + + * sem_dist.ads, sem_dist.adb (Build_RAS_Primitive_Specification): New + subprogram. + New implementation of expansion for remote access-to-subprogram types, + based on the RACW infrastructure. + This version of sem_dist is compatible with PolyORB/DSA as well as + GLADE. + + * sem_prag.adb (Analyze_Pragma, case Pragma_Asynchronous): For a pragma + Asynchrronous that applies to a remote access-to-subprogram type, mark + the underlying RACW type as asynchronous. + + * link.c: FreeBSD uses GNU ld: set __gnat_objlist_file_supported and + __gnat_using_gnu_linker to 1. + + * Makefile.rtl, impunit.adb, g-perhas.ads, g-pehage.ads, + g-pehage.adb: Rename GNAT.Perfect_Hash.Generators to + GNAT.Perfect_Hash_Generators, and remove the empty + GNAT.Perfect_Hash package. + + * atree.adb: Minor reformatting + + * exp_ch3.adb (Expand_Derived_Record): Rename to + Expand_Record_Extension. + (Build_Record_Init_Proc.Build_Assignment): The default expression in + a component declaration must remain attached at that point in the + tree so New_Copy_Tree copies it if the enclosing record type is derived. + It is therefore necessary to take a copy of the expression when building + the corresponding assignment statement in the init proc. + As a side effect, in the case of a derived record type, we now see the + original expression, without any rewriting that could have occurred + during expansion of the ancestor type's init proc, and we do not need + to go back to Original_Node. + + * exp_ch3.ads (Expand_Derived_Record): Rename to + Expand_Record_Extension. + + * exp_dist.ads, exp_dist.adb (Underlying_RACW_Type): New subprogram. + Returns the RACW type used to implement a remote access-to-subprogram + type. + (Add_RAS_Proxy_And_Analyze, Build_Remote_Subprogram_Proxy_Type): + New subprograms. Used to create a proxy tagged object for a remote + subprogram. The proxy object is used as the designated object + for RAS values on the same partition (unless All_Calls_Remote applies). + (Build_Get_Unique_RP_Call): New subprogram. Build a call to + System.Partition_Interface.Get_Unique_Remote_Pointer. + (Add_RAS_Access_TSS, Add_RAS_Dereference_TSS): + Renamed from Add_RAS_*_Attribute. + (Add_Receiving_Stubs_To_Declarations): Generate a table of local + subprograms. + New implementation of expansion for remote access-to-subprogram types, + based on the RACW infrastructure. + + * exp_dist.ads (Copy_Specification): Update comment to note that this + function can copy the specification from either a subprogram + specification or an access-to-subprogram type definition. + +2004-09-09 Ed Schonberg + + * sem_type.adb (Disambiguate): Handle properly an accidental ambiguity + in an instance, between an explicit subprogram an one inherited from a + type derived from an actual. + + * exp_ch6.adb (Expand_N_Subprogram_Body): If polling is enabled, do not + add a polling call if the subprogram is to be inlined by the back-end, + to avoid repeated calls with multiple inlinings. + + * checks.adb (Apply_Alignment_Check): If the expression in the address + clause is a call whose name is not a static entity (e.g. a dispatching + call), treat as dynamic. + +2004-09-09 Robert Dewar + + * g-trasym.ads: Minor reformatting + + * exp_ch3.adb (Component_Needs_Simple_Initialization): Don't except + packed arrays, since unused bits are expected to be zero for a + comparison. + +2004-09-09 Eric Botcazou + + * exp_pakd.ads: Fix an inacurracy and a couple of typos in the head + comment. + +2004-09-09 Pascal Obry + + * mdll.ads, mdll.adb (Build_Dynamic_Library): New parameter Map_File to + enable map file generation. Add the right option to generate the map + file if Map_File is set to True. + + * gnatdll.adb (Gen_Map_File): New variable. + (Syntax): Add info about new -m (Map_File) option. + (Parse_Command_Line): Add support for -m option. + (gnatdll): Pass Gen_Map_File to Build_Dynamic_Library calls. + Minor reformatting. + +2004-09-09 Laurent Pautet + + * gnatls.adb: Add a very verbose mode -V. Such mode is required by the + new gnatdist implementation. + Define a subpackage isolating the output routines specific to this + verbose mode. + +2004-09-09 Joel Brobecker + + * Makefile.rtl: (GNATRTL_NONTASKING_OBJS): Add g-dynhta. + + * gnat_ugn.texi (Main Subprograms): Fix typo. Deduced, not deducted. + +2004-09-09 Cyrille Comar + + * opt.adb (Set_Opt_Config_Switches): Use Ada_Version_Runtime to compile + internal unit. + + * opt.ads: Add Ada_Version_Runtime constant used to decide which + version of the language is used to compile the run time. + +2004-09-09 Arnaud Charlet + + * sem_util.adb (Requires_Transient_Scope): Re-enable handling + of variable length temporaries for function return now that the + back-end and gigi support it. + +2004-09-01 Richard Kenner + + * misc.c (gnat_print_type): Use TYPE_RM_SIZE_NUM. + + * trans.c (struct stmt_group): Delete field GLOBAL. + (gnat_init_stmt_group): Do not initialize it. + (call_to_gnu): Use save_expr, not protect_multiple_eval. + (Exception_Handler_to_gnu_sjlj): Call build_int_cst, not build_int_2 + (gnat_to_gnu, case N_Character_Literal, N_String_Literal): Likewise. + (gnat_to_gnu, case N_Compilation_Unit): Do not set GLOBAL in stmt group. + (start_stmt_group): Likewise. + (add_stmt, add_decl_expr): Rework handling of global DECL_EXPRs. + + * utils2.c (ggc.h): Include. + (build_call_raise): Call build_int_cst, not build_int_2. + + * utils.c (gnat_init_decl_processing): Fix arg to + build_common_tree_nodes. + (create_subprog_type): Do not use SET_TYPE_CI_CO_LIST. + (gnat_define_builtin): Set built_in_decls. + (init_gigi_decls): Call build_int_cst, not build_int_2. + + * ada-tree.h (struct lang_decl, struct lang_type): Field is type tree. + (GET_TYPE_LANG_SPECIFIC, SET_TYPE_LANG_SPECIFIC): New macros. + (GET_DECL_LANG_SPECIFIC, SET_DECL_LANG_SPECIFIC): Likewise. + (TYPE_CI_CO_LIST, SET_TYPE_CI_CO_LIST, TYPE_MODULE, + SET_TYPE_MODULE): Use them. + (TYPE_INDEX_TYPE, SET_TYPE_INDEX_TYPE, TYPE_DIGITS_VALUE): Likewise. + (SET_TYPE_DIGITS_VALUE, TYPE_UNCONSTRAINED_ARRAY): Likewise. + (SET_TYPE_UNCONSTRAINED_ARRAY, TYPE_ADA_SIZE, + SET_TYPE_ADA_SIZE): Likewise. + (TYPE_ACTUAL_BOUNDS, SET_TYPE_ACTUAL_BOUNDS): Likewise. + (DECL_CONST_CORRESPONDING_VAR, + SET_DECL_CONST_CORRESPONDING_VAR): Likewise. + (DECL_ORIGINAL_FIELD, SET_DECL_ORIGINAL_FIELD): Likewise. + (TYPE_RM_SIZE_INT, TYPE_RM_SIZE_ENUM, SET_TYPE_RM_SIZE_ENUM): Deleted. + (TYPE_RM_SIZE_NUM): New macro. + (TYPE_RM_SIZE): Modified to use above. + + * cuintp.c: (build_cst_from_int): New function. + (UI_To_gnu): Use it. + + * decl.c (gnat_to_gnu_entity): Use TYPE_RM_SIZE_NUM. + (make_type_from_size): Avoid changing TYPE_UNSIGNED of a type. + (gnat_substitute_in_type, case ARRAY_TYPE): If old had a + MIN_EXPR for the size, copy it into new. + +2004-09-01 Robert Dewar + + * exp_ch6.adb (Expand_Call): Properly handle validity checks for + packed indexed component where array is an IN OUT formal. This + generated garbage code previously. + + * gnat_ugn.texi: Document -fverbose-asm + + * gnat-style.texi: Minor updates (note that boolean constants and + variables are joined with AND/OR rather than short circuit forms). + +2004-09-01 Ed Schonberg + + * exp_util.adb (Safe_Unchecked_Type_Conversion): Conversion is safe if + it is an upward conversion of an untagged type with no representation + change. + +2004-09-01 Thomas Quinot + + * rtsfind.ads: Move RCI_Subp_Info and RCI_Subp_Info_Array to + System.Partition_Interface. + + * checks.adb (Apply_Access_Checks): Do not generate checks when + expander is not active (but check for unset reference to prefix of + dereference). + + * sem_prag.adb (Analyze_Pragma, case Pragma_Debug): Uniformly rewrite + pragma Debug as an if statement with a constant condition, for + consistent treatment of entity references contained within the + enclosed procedure call. + +2004-09-01 Vincent Celier + + * bindgen.adb: (Set_EA_Last): New procedure + (Gen_Exception_Table_Ada, Gen_Exception_Table_C): Use new procedure + Set_EA_Last. + (Gen_Adafinal_Ada): If no finalization, adafinal does nothing + (Gen_Output_File_Ada): Always call Gen_Adafinal_Ada, so that SAL can be + linked without errors. + (Gen_Exception_Table_Ada): Correct bugs when generating code for arrays + ST and EA. + (Gen_Exception_Table_C): Correct same bugs + + * vms_data.ads: Add new qualifier /VERBOSE_ASM to GCC_Switches + + * g-os_lib.adb (Normalize_Pathname.Get_Directory): When Dir is empty, + on Windows, make sure that the drive letter is in upper case. + + * g-os_lib.ads (Normalize_Pathname): Add a comment to indicate that on + Windows, when the drive letter is added and Case_Sensitive is True, the + drive letter is forced to upper case. + + * mlib-tgt-irix.adb (Build_Dynamic_Library): Transfer all -lxxx options + to Options_2 for the call to MLib.Utl.Gcc. + + * bld.adb (Put_Include_Project): Use '/', not '\' on Windows as + directory separator when defining BASE_DIR. + +2004-09-01 Pascal Obry + + * gprcmd.adb (Extend): Do not output trailing directory separator. This + is not needed and it confuses Windows GNU/make which does not report + directory terminated by a slash as a directory. + (gprcmd): Idem for "pwd" internal command. + + * Makefile.generic: Use __GPRCOLON__ instead of pipe character in + target names rewrite to fix regressions with recent version of + GNU/make. Starting with GNU/make 3.80 the pipe character was not + handled properly anymore. + +2004-09-01 Andreas Schwab + + * Make-lang.in (EXTRA_GNATBIND_OBJS): Revert last change. + * raise.c [!IN_RTS]: Undef abort. + +2004-08-27 Nathan Sidwell + + * utils2.c (build_allocator): Use ssize_int. + + * utils.c (gnat_init_decl_processing): Ada has a signed sizetype. + +2004-08-27 Andreas Schwab + + * Make-lang.in (EXTRA_GNATBIND_OBJS): Add errors.o. + +2004-08-25 Nathan Sidwell + Richard Kenner + + * ada-tree.h (TYPE_RM_SIZE_INT): Use TYPE_LANG_SLOT_1. + +2004-08-25 Nathan Sidwell + + * cuintp.c (UI_To_gnu): Adjust build_int_cst calls. + * trans.c (Exception_Handler_to_gnu_sjlj, gnat_to_gnu): Likewise. + * utils.c (init_gigi_decls): Likewise. + * utils2.c (build_call_raise, build_allocator): Likewise. + +2004-08-24 Nathan Sidwell + + * utils.c (gnat_init_decl_processing): Adjust + build_common_tree_nodes call. + +2004-08-20 Nathan Sidwell + + * utils2.c (build_allocator): Use build_int_cst for negative + size types. + +2004-08-18 Richard Henderson + + * misc.c (LANG_HOOKS_HONOR_READONLY): Remove. + +2004-08-16 Nathan Sidwell + + * cuintp.c (UI_To_gnu): Be more conservative with build_int_cst + call.s + * trans.c (Exception_Handler_to_gnu_sjlj): Likewise. + (gnat_to_gnu): Likewise. + +2004-08-16 Pascal Obry + + * adaint.c (__gnat_prj_add_obj_files): Set to 0 only on Win32 for GCC + backend prior to GCC 3.4. With GCC 3.4 we are using the GCC's shared + option and not mdll anymore. Update comment. + +2004-08-16 Pascal Obry + + * bld.adb (Put_Include_Project): Properly handle directory separators + on Windows. + +2004-08-16 Ed Schonberg + + * sem_ch4.adb (Try_Object_Operation): Restructure code. Optimize by + decreasing the number of allocated junk nodes while searching for the + appropriate subprogram. + +2004-08-15 Nathan Sidwell + + * cuintp.c (UI_To_gnu): Use build_int_cst.. + * trans.c (Exception_Handler_to_gnu_sjlj, gnat_to_gnu): Likewise. + * utils.c (init_gigi_decls): Likewise. + * utils2.c (build_call_raise): Likewise. + +2004-08-13 Olivier Hainque + + * decl.c (gnat_to_gnu_entity) : When building an allocator + for a global aliased object with a variable size and an unconstrained + nominal subtype, pretend there is no initializer if the one we have is + incomplete, and avoid referencing an inexistant component in there. The + part we have will be rebuilt anyway and the reference may confuse + further operations. + +2004-08-13 Thomas Quinot + + * einfo.ads: Minor reformatting + + * lib-writ.adb (Output_Main_Program_Line): Do not set parameter + restrictions in the ALI if we only want to warn about violations. + +2004-08-13 Vincent Celier + + * ali.adb (Scan_ALI): Initialize component Body_Needed_For_SAL to False + when creating a new Unit_Record in table Units. + + * gnatls.adb (Output_Unit): In verbose mode, output the restrictions + that are violated, if any. + + * prj-nmsc.adb (Ada_Check.Get_Path_Names_And_Record_Sources): Do not + add directory separator if path already ends with a directory separator. + +2004-08-13 Ed Schonberg + + * rtsfind.adb (Entity_Not_Defined): If the error ocurrs in a predefined + unit, this is an attempt to inline a construct that is not available in + the current restricted mode, so abort rather than trying to continue. + + * sem_ch3.adb (Build_Underlying_Full_View): If the new type has + discriminants that rename those of the parent, recover names of + original discriminants for the constraint on the full view of the + parent. + (Complete_Private_Subtype): Do not create a subtype declaration if the + subtype is an itype. + + * gnat_rm.texi: Added section on implementation of discriminated + records with default values for discriminants. + +2004-08-13 Ed Schonberg + + PR ada/15601 + * sem_res.adb (Make_Call_Into_Operator): Handle properly the case where + the second operand is overloaded. + +2004-08-10 Richard Henderson + + * utils.c (gnat_install_builtins): Remove __builtin_stack_alloc, + add __builtin_alloca. + +2004-08-10 Richard Henderson + + * config-lang.in (boot_language): Yes. + +2004-08-09 Thomas Quinot + + * g-socket.adb (Abort_Selector): Initialize Buf to prevent valgrind + from complaining on potential uninitialized reference. + Change calls to GNAT.Sockets.Thin.Is_Socket_In_Set to account for + new specification and test explicitly for non-zero return value. + + * g-socthi.ads (Is_Socket_In_Set): Declare imported function as + returning C.int, to avoid using a derived boolean type. + + * exp_ch5.adb (Make_Tag_Ctrl_Assignments): Use + Duplicate_Subexpr_No_Checks in preference to direct use of + Remove_Side_Effects and New_Copy_Tree. + Clear Comes_From_Source on prefix of 'Size attribute reference. + + * g-socthi.adb, g-socthi-vms.adb, g-socthi-mingw.adb, + g-socthi-vxworks.adb: Change calls to + GNAT.Sockets.Thin.Is_Socket_In_Set to account for new specification + and test explicitly for non-zero return value. + + * g-socthi-vms.ads, g-socthi-mingw.ads, g-socthi-vxworks.ads: + (Is_Socket_In_Set): Declare imported function as returning C.int, to + avoid using a derived boolean type. + +2004-08-09 Albert Lee + + * system-irix-n32.ads: Refine tasking priority constants for IRIX. + +2004-08-09 Pascal Obry + + * gnat_ugn.texi: Document new way to build DLLs on Windows using + GCC's -shared option. + + * mlib-tgt-mingw.adb (Build_Dynamic_Library): Pass GCC's options into + Options_2 parameter (options put after object files). + +2004-08-09 Olivier Hainque + + * decl.c (gnat_to_gnu_entity) : Adjust condition to + ignore overflows on low and high bounds of an index to also account for + differences in signedness between sizetype and gnu_index_subtype. + These are as legitimate as the ones caused by a lower TYPE_PRECISION + on sizetype. + +2004-08-09 Robert Dewar + + * s-solita.ads, s-solita.adb: Minor reformatting + + * gnat_rm.texi: Add documentation for pragma Profile (Restricted) + Move pragma Restricted_Run_Time, No_Run_Time, Ravenscar to new + obsolescent section + Add note that No_Implicit_Conditionals does not suppress + run time constraint checks. + + * vms_conv.ads: Minor reformatting + + * s-secsta.adb: Use SS_Ptr instead of Mark_Id as stack pointer (cleanup + and necessary for following change). + (Mark): Return new format Mark_Id containing sec stack address + (Release): Use sec stack address from Mark_Id avoiding Self call + + * s-secsta.ads: Define SS_Ptr to be used instead of Mark_Id as stack + pointer (cleanup and necessary for following change). + Define Mark_Id as record containing address of secondary stack, that way + Release does not need to find the stack again, decreasing the number of + calls to Self and improving efficiency. + + * sem_util.ads: Add a ??? comment for Is_Local_Variable_Reference + + * sem_ch5.adb (Analyze_Case_Statement): Add circuitry to track value of + case variable into the individual case branches when possible. + + * sem_ch11.adb: Minor reformatting + + * prj.ads: Correct spelling of suffixs + + * prj-nmsc.adb: Minor reformatting + Correct spelling suffixs throughout (also in identifiers) + + * freeze.adb: Minor spelling correction + + * exp_ch2.adb: Cleanups to handling of Current_Value + (no functional effect). + + * bld.adb: Correct spelling of suffixs + + * einfo.adb (Enclosing_Dynamic_Scope): Defend against junk argument + +2004-08-09 Ed Schonberg + + PR ada/15408 + * sem_ch7.adb (Install_Private_Declarations): In the body of the + package or of a child, private entities are both immediately_visible + and not hidden. + +2004-08-09 Ed Schonberg + + * sem_eval.adb (Eval_Integer_Literal): If the context is Any_Integer, + there are no range checks on the value of the literal. + + * exp_ch7.adb (Insert_Actions_In_Scope_Around): If the node being + wrapped is the triggering alternative of an asynchronous select, action + statements mustbe inserted before the select itself. + + * sem_attr.adb (Analyze_Attribute, case 'Size): Handle properly the + case where the prefix is a protected function call. + (Resolve_Attribute, case 'Access): The attribute reference on a + subprogram is legal in a generic body if the subprogram is declared + elsewhere. + +2004-08-09 Vincent Celier + + * makegpr.adb (Build_Library): Link with g++ if C++ is one of the + languages, otherwise building the library may fail with unresolved + symbols. + (Compile_Sources): Do not build libraries if -c switch is used + + * gnatlink.adb (Process_Args): New switches -M and -Mmap + (Write_Usage): If map file creation is supported, output new switches + -M and -Mmap. + (Gnatlink): When -M is specified, add the necessary switch(es) to the + gcc call, when supported. + + * Makefile.in: Added indepsw.o to the object list for gnatlink + Specified the AIX, GNU/Linux and Windows versions of indepsw.adb + + * indepsw-aix.adb, indepsw-linux.adb, indepsw-mingw.adb, + indepsw.adb, indepsw.ads: New files. + +2004-08-09 Bernard Banner + + * system-vxworks-x86.ads, s-vxwork-x86.ads: New files. + + * Makefile.in: add section for vxworks x86 + +2004-08-09 Hristian Kirtchev + + * exp_ch3.adb (Build_Init_Statements): Add extra condition to deal with + per-object constrained components where the discriminant is of an + Access type. + (Build_Record_Init_Proc): Add condition to prevent the inheritance of + the parent initialization procedure for derived Unchecked_Unions. + Instead, derived Unchecked_Unions build their own initialization + procedure. + (Build_Variant_Record_Equality): Implement Unchecked_Union equality. + Check the body of the subprogram for details. + (Freeze_Record_Type): Prevent the inheritance of discriminant checking + functions for derived Unchecked_Union types by introducing a condition. + Allow the creation of TSS equality functions for Unchecked_Unions. + (Make_Eq_Case): Rename formal parameter Node to E in function signature. + Add formal parameter Discr to function signature. Discr is used to + control the generated case statement for Unchecked_Union types. + (Make_Eq_If): Rename formal parameter Node to E in function signature. + + * exp_ch4.adb (Build_Equality_Call): Implement equality calls for + Unchecked_Unions. + Check the body of the subprogram for details. + (Expand_Composite_Equality): Augment composite type equality to include + correct handling of Unchecked_Union components. + (Expand_N_In): Add condition to detect illegal membership tests when the + subtype mark is a constrained Unchecked_Union and the expression lacks + inferable discriminants, and build a Raise_Program_Error node. + (Expand_N_Op_Eq): Add function Has_Unconstrained_UU_Component. Used + to detect types that contain components of unconstrained Unchecked_Union + subtype. Add condition to detect equality between types that have an + unconstrained Unchecked_Union component, and build a Raise_Program_Error + node. Add condition to detect equality between Unchecked_Union types + that lack inferable discriminants, and build a Raise_Program_Error node. + Otherwise build a TSS equality function call. + (Expand_N_Type_Conversion): Add condition to detect illegal conversions + from a derived Unchecked_Union to an unconstrained non-Unchecked_Union + with the operand lacking inferable discriminants, and build a Raise_ + Program_Error node. + (Expand_Record_Equality): Remove guard that prevents Unchecked_Union + composite equality. + (Has_Inferable_Discriminants): Implement new predicate for objects and + expressions of Unchecked_Union type. Check the body of subprogram for + details. + (Has_Unconstrained_UU_Components): Add function + Component_Is_Unconstrained_UU. It is used to detect whether a single + component is of an unconstrained Unchecked_Union subtype. Add function + Variant_Is_Unconstrained_UU. It is used to detect whether a single + component inside a variant is of an unconstrained Unchecked_Union type. + + * exp_ch5.adb (Expand_Assign_Record): Add condition to copy the + inferred discriminant values. Add condition to generate a case + statement with an inferred discriminant as the switch. + (Make_Component_List_Assign): Introduce a Boolean flag that determines + the behaviour of the subprogram in the presence of an Unchecked_Union. + Add condition to trigger the usage of the inferred discriminant value + as the generated case statement switch. + (Make_Field_Assign): Introduce a Boolean flag that determines the + behaviour of the subprogram in the presence of an Unchecked_Union. Add + condition to trigger the usage of the inferred discriminant value as + the right-hand side of the generated assignment. + + * exp_ch6.adb (Expand_Call): Add condition to skip extra actual + parameter generation when dealing with Unchecked_Unions. + + * checks.adb (Apply_Discriminant_Check): Do not apply discriminant + checks for Unchecked_Unions. + + * einfo.ads: Update comment on usage of flag Has_Per_Object_Constraint + + * exp_attr.adb (Expand_N_Attribute_Reference): Produce + Raise_Program_Error nodes for the execution of Read and Write + attributes of Unchecked_Union types and the execution of Input and + Output attributes of Unchecked_Union types that lack default + discriminant values. + + * sem_prag.adb (Analyze_Pragma): Remodel the analysis of pragma + Unchecked_Union. Add procedure Check_Component. It is used to inspect + per-object constrained components of Unchecked_Unions for being + Unchecked_Unions themselves. Add procedure Check_Variant. It is used to + check individual components withing a variant. + + * sem_res.adb (Resolve_Comparison_Op): Remove guard that prevents + comparison of Unchecked_Unions. + (Resolve_Equality_OP): Remove guard that prevents equality between + Unchecked_Unions. + + * sem_util.adb (Build_Component_Subtype): Add guard to prevent creation + of component subtypes for Unchecked_Union components. + (Get_Actual_Subtype): Add condition that returs the Unchecked_Union type + since it is the actual subtype. + + * sem_ch12.adb (Instantiate_Type): Add condition to detect the correct + pass of Unchecked_Union subtypes as generic actuals to formal types + that lack known_discriminant_parts or that are derived Unchecked_Union + types, and do nothing. In any other case, produce an error message. + + * sem_ch3.adb (Analyze_Component_Declaration): Add function + Contains_POC. It determines whether a constraint uses the discriminant + of an enclosing record type. + Add condition to detect per-object constrained component and set the + appropriate flag. + (Derived_Type_Declaration): Remove guard that prevents derivation from + Unchecked_Union types. + (Process_Subtype): Remove quard that prevents the creation of Unchecked_ + Union subtypes. + + * sem_ch4.adb (Analyze_Selected_Component): Correct the detection of + references to Unchecked_Union discriminants. + + * sem_ch6.adb (Create_Extra_Formals): Add condition to skip extra + formal generation when dealing with Unchecked_Unions. + (Set_Actual_Subtypes): Add condition to prevent generation of actual + subtypes for Unchecked_Unions. + + * sem_ch7.adb (Analyze_Package_Specification): Add procedure + Inspect_Unchecked_Union_Completion. It is used to detect incorrect + completions of discriminated partial views by Unchecked_Unions and + produce an error message. + +2004-08-09 Richard Kenner + + * trans.c (struct stmt_group): New field, GLOBAL. + (global_stmt_group, gnu_elab_proc_decl, build_unit_elab): Deleted. + (struct elab_info): New struct. + (elab_info_list, gnu_elab_proc_stack): New variables. + (Compilation_Unit_to_gnu): New procedure. + (gigi): Call it and also handle elaboration procs we've saved. + (gnat_init_stmt_group): Don't set global_stmt_group; instead initialize + global field from parent. + (gnat_to_gnu): Get decl from gnu_elab_proc_stack. + (gnat_to_gnu, case N_Compilation_Unit): Call Compilation_Unit_to_gnu. + (start_stmt_group): Initialize global field from parent. + (add_decl_expr): Set to global for current statement group. + (gnat_gimplify_expr, case NULL_EXPR): Add operand 0 to pre list, not + post. + + * utils.c (global_bindings_p): True when no current_function_decl; no + longer check current_binding_level. + +2004-08-09 Ben Brosgol + + * xgnatugn.adb: Added logic to deal with @ifset/@ifclear for edition + choice. + + * gnat_rm.texi, gnat_ugn.texi: Added edition conditionalization logic. + +2004-08-06 Andreas Schwab + + * utils.c (gnat_define_builtin): Remove second parameter of + make_decl_rtl. + (begin_subprog_body): Likewise. + +2004-07-26 Arnaud Charlet + + * sem_util.adb (Requires_Transient_Scope): Temporarily disable + optimization, not supported by the tree-ssa back-end. + +2004-07-26 Olivier Hainque + + * s-mastop-irix.adb: Update comments. + + * a-except.adb (Exception_Information): Raise Constraint_Error if + exception Id is Null_Id. + This is required behavior, which is more reliably and clearly checked + at the top level interface level. + +2004-07-26 Javier Miranda + + * exp_aggr.adb (Build_Array_Aggr_Code): Do not build the initialization + call if a component has no default_expression and the box is used. + + * sem_aggr.adb (Resolve_Array_Aggregate): If a component has no + default_expression and you use box, it behaves as if you had declared a + stand-alone object. + (Resolve_Record_Aggregate): If a component has no default_expression and + you use box, it behaves as if you had declared a stand-alone object. + + * sem_ch10.adb (Install_Siblings): Do not make visible the private + entities of private-with siblings. + +2004-07-26 Ed Schonberg + + * sem_ch3.adb (Build_Underlying_Full_View): If this is the full view + for a component of an itype, set the parent pointer for analysis, + there is no list in which to insert it. + + * sem_res.adb (Resolve): Call Rewrite_Renamed_Operator only for + bona-fide renamings, not for inherited operations. + + * exp_ch4.adb (Expand_Allocator_Expression): If the allocator is an + actual for a formal that is an access parameter, create local + finalization list even if the expression is not an aggregate. + +2004-07-26 Ed Schonberg + + PR ada/16213 + * sem_ch8.adb (Attribute_Renaming, Check_Library_Level_Renaming): + Diagnose properly illegal subprogram renamings that are library units. + +2004-07-26 Ed Schonberg + + PR ada/15588 + * sem_util.adb (Is_OK_Variable_For_Out_Formal): If actual is a type + conversion rewritten as an unchecked conversion, check that original + expression is a variable. + + * exp_ch4.adb (Expand_N_Type_Conversion): If rewriting as an + unchecked_conversion, create new node rather than rewriting in place, + to preserve original construct. + +2004-07-26 Richard Kenner + + * gigi.h (gnat_expand_body): Deleted. + + * Make-lang.in: (trans.o): Depends on function.h. + + * misc.c: (gnat_expand_body): Moved to here. + + * trans.c (gnat_expand_body_1): Deleted. + (gnat_expand_body): Moved from here. + (gnat_to_gnu): N_Implicit_Label_Declaration forces being in elab proc. + (add_stmt): Check for marked visited with global_bindings_p. + (gnat_gimplify_expr, case COMPONENT_REF): New case. + (gnat_gimplify_expr, case NULL_EXPR): Set TREE_NO_WARNING for temp. + + * utils2.c (build_binary_op, case MODIFY_EXPR): Put LHS in a + VIEW_CONVERT_EXPR if not operation type. + + * utils.c (update_pointer_to): Set DECL_ORIGINAL_FIELD for + fat pointer. + + * decl.c, cuintp.c, gigi.h, misc.c, trans.c, utils.c, utils2.c: Minor + changes: reformatting of negation operators, removing unneeded + inequality comparison with zero, converting equality comparisons with + zero to negations, changing int/0/1 to bool/false/true, replace calls + to gigi_abort with abort, and various other similar changes. + +2004-07-26 Vincent Celier + + * gnatcmd.adb (GNATCmd): Add processing for new built-in command + "setup". + + * make.adb (Gnatmake): Fail when a library is not present and there is + no object directory. + + * mlib-prj.adb (Check_Library): No need to check if the library needs + to be rebuilt if there is no object directory, hence no object files + to build the library. + + * opt.ads (Setup_Projects): New Boolean flag. + + * prj-nmsc.adb (Locate_Directory): New parameter Project, Kind and + Location. + Create directory when Kind /= "" and in "gnat setup". Report error if + directory cannot be created. + (Ada_Check): Create library interface copy dir if it does not exist + and we are in "gnat setup". + (Find_Sources): No error if in "gnat setup" and no Ada sources were + found. + (Language_Independent_Check): Create object directory, exec directory + and/or library directory if they do not exist and we are in + "gnat setup". + + * vms_conv.ads: (Command_Type): New command Setup. + + * vms_conv.adb (Initialize): Add Setup component of Cammand_List. + + * vms_data.ads: Add qualifiers/switches for new built-in command + "setup". + +2004-07-25 Richard Henderson + + * utils.c (create_subprog_decl): Set DECL_ARTIFICIAL and + DECL_IGNORED_P on RESULT_DECL. + +2004-07-20 Olivier Hainque + + * a-elchha.adb (Last_Chance_Handler): Remove the bogus buffer dynamic + allocation and potentially overflowing update with + Tailored_Exception_Information. Use the sec-stack free procedural + interface to output Exception_Information instead. + + * a-except.adb (To_Stderr): New subprogram for character, and string + version moved from a-exextr to be visible from other separate units. + (Tailored_Exception_Information): Remove the procedural version, + previously used by the default Last_Chance_Handler and not any more. + Adjust various comments. + + * a-exexda.adb: Generalize the exception information procedural + interface, to minimize the use of secondary stack and the need for + local buffers when the info is to be output to stderr: + (Address_Image): Removed. + (Append_Info_Character): New subprogram, checking for overflows and + outputing to stderr if buffer to fill is of length 0. + (Append_Info_String): Output to stderr if buffer to fill is of length 0. + (Append_Info_Address, Append_Info_Exception_Name, + Append_Info_Exception_Message, Append_Info_Basic_Exception_Information, + Append_Info_Basic_Exception_Traceback, + Append_Info_Exception_Information): New subprograms. + (Append_Info_Nat, Append_Info_NL): Use Append_Info_Character. + (Basic_Exception_Info_Maxlength, Basic_Exception_Tback_Maxlength, + Exception_Info_Maxlength, Exception_Name_Length, + Exception_Message_Length): New subprograms. + (Exception_Information): Use Append_Info_Exception_Information. + (Tailored_Exception_Information): Use + Append_Info_Basic_Exception_Information. + Export services for the default Last_Chance_Handler. + + * a-exextr.adb (To_Stderr): Remove. Now in a-except to be usable by + other separate units. + +2004-07-20 Vincent Celier + + * clean.adb, mlib-utl.adb, osint.adb, makegpr.adb: Minor reformatting. + +2004-07-20 Ed Schonberg + + * freeze.adb (Freeze_Entity): If entity is a discriminated record type, + emit itype references for the designated types of component types that + are declared outside of the full record declaration, and that may + denote a partial view of that record type. + +2004-07-20 Ed Schonberg + + PR ada/15607 + * sem_ch3.adb (Build_Discriminated_Subtype): Do not attach a subtype + which is the designated type in an access component declaration, to the + list of incomplete dependents of the parent type, to avoid elaboration + issues with out-of-scope subtypes. + (Complete_Private_Subtype): Recompute Has_Unknown_Discriminants from the + full view of the parent. + +2004-07-20 Ed Schonberg + + PR ada/15610 + * sem_ch8.adb (Find_Expanded_Name): If name is overloaded, reject + entities that are hidden, such as references to generic actuals + outside an instance. + +2004-07-20 Javier Miranda + + * sem_ch4.adb (Try_Object_Operation): New subprogram that gives + support to the new notation. + (Analyze_Selected_Component): Add call to Try_Object_Operation. + +2004-07-20 Jose Ruiz + + * s-taprob.adb: Adding the elaboration code required for initializing + the tasking soft links that are common to the full and the restricted + run times. + + * s-tarest.adb (Init_RTS): Tasking soft links that are shared with the + restricted run time has been moved to the package + System.Soft_Links.Tasking. + + * s-tasini.adb (Init_RTS): Tasking soft links that are shared with the + restricted run time has been moved to the package + System.Soft_Links.Tasking. + + * Makefile.rtl: Add entry for s-solita.o in run-time library list. + + * s-solita.ads, s-solita.adb: New files. + +2004-07-20 Richard Kenner + + * trans.c (Identifier_to_gnu, Pragma_to_gnu, Attribute_to_gnu, + Case_Statement_to_gnu): Split off from gnat_to_gnu. + (Loop_Statement_to_gnu, Subprogram_Body_to_gnu, call_to_gnu, + Handled_Sequence_Of_Statements_to_gnu, Exception_Handler_to_gnu_sjlj, + Exception_Handler_to_gnu_zcx): Likewise. + +2004-07-17 Joseph S. Myers + + * gigi.h (builtin_function): Declare. + +2004-07-15 Robert Dewar + + * makegpr.adb, s-secsta.ads, sem_ch3.adb, sem_case.adb: Minor + reformatting + + * gnat_ugn.texi: Add instantiation of direct_io or sequential_io with + access values as an example of a warning. + + * gnat_rm.texi: Document new attribute Has_Access_Values + + * gnat-style.texi: Document that box comments belong on nested + subprograms + + * sem_util.ads (Has_Access_Values): Improved documentation + + * s-finimp.ads, s-finimp.adb: Fix spelling error in comment + + * sem_prag.adb (Check_Duplicated_Export_Name): New procedure + (Process_Interface_Name): Call to this new procedure + (Set_Extended_Import_Export_External_Name): Call to this new procedure + + * s-mastop-x86.adb, 9drpc.adb: Fix spelling error in comment + + * a-direio.ads, a-sequio.ads: Warn if Element_Type has access values + + * einfo.ads: Minor comment typo fixed + +2004-07-15 Jose Ruiz + + * snames.adb: Add _atcb. + + * snames.ads: Add Name_uATCB. + + * s-tarest.adb (Create_Restricted_Task): ATCBs are always preallocated + (in the expanded code) when using the restricted run time. + + * s-tarest.ads (Create_Restricted_Task): Created_Task transformed into + a in parameter in order to allow ATCBs to be preallocated (in the + expanded code). + + * s-taskin.adb (Initialize_ATCB): T converted into a in parameter in + order to allow ATCBs to be preallocated. In case of error, the ATCB is + deallocated in System.Tasking.Stages. + + * s-taskin.ads (Initialize_ATCB): T converted into a in parameter in + order to allow ATCBs to be preallocated. + + * s-tassta.adb (Create_Task): In case of error the ATCB is deallocated + here. It was previously done in Initialize_ATCB. + + * rtsfind.ads: Make the Ada_Task_Control_Block visible. + + * exp_ch9.adb: Preallocate the Ada_Task_Control_Block when using the + Restricted run time. + + * exp_ch3.adb: When using the Restricted run time, pass the + preallocated Ada_Task_Control_Block when creating a task. + +2004-07-15 Ed Schonberg + + * sem_util.adb (Normalize_Actuals): If there are no actuals on a + function call that is itself an actual in an enclosing call, diagnose + problem here rather than assuming that resolution will catch it. + + * sem_ch7.adb (Analyze_Package_Specification): If the specification is + the local copy of a generic unit for a formal package, and the generic + is a child unit, install private part of ancestors before compiling + private part of spec. + + * sem_cat.adb (Validate_Categorization_Dependency): Simplify code to + use scope entities rather than tree structures, to handle properly + parent units that are instances rewritten as bodies for inlining + purposes. + + * sem_ch10.adb (Get_Parent_Entity, Implicit_With_On_Parent, + Remove_Parents): Handle properly a parent unit that is an + instantiation, when the unit has been rewritten as a body for inlining + purposes. + + * par.adb (Goto_List): Global variable to collect goto statements in a + given unit, for use in detecting natural loops. + + * par-ch5.adb (P_Goto_Statement): Add goto to global Goto_List, for + use in detecting natural loops. + + * par-labl.adb (Find_Natural_Loops): Recognize loops create by + backwards goto's, and rewrite as a infinite loop, to improve locality + of temporaries. + + * exp_util.adb (Force_Evaluation): Recognize a left-hand side + subcomponent that includes an indexed reference, to prevent the + generation of copies that would miscompile the desired assignment + statement. + (Build_Task_Image_Decls): Add a numeric suffix to + generated name for string variable, to avoid spurious conflicts with + the name of the type of a single protected object. + + * exp_ch4.adb (Expand_Array_Equality): If indices are distinct, use a + loop with an explicit exit statement, to avoid generating an + out-of-range value with 'Succ leading to spurious constraint_errors + when compiling with -gnatVo. + +2004-07-15 Thomas Quinot + + * sem_ch4.adb (Analyze_Slice): Always call Analyze on the prefix: it + might not be analyzed yet, even if its Etype is already set (case of an + unchecked conversion built using Unchecked_Convert_To, for example). + If the prefix has already been analyzed, this will be a nop anyway. + + * exp_ch5.adb (Make_Tag_Ctrl_Assignment): For an assignment of a + controller type, or an assignment of a record type with controlled + components, copy only user data, and leave the finalization chain + pointers untouched. + +2004-07-15 Vincent Celier + + * make.adb (Collect_Arguments): Improve error message when attempting + to compile a source not part of any project, when -x is not used. + + * prj.ads: (Defined_Variable_Kind): New subtype + + * prj-attr.adb (Register_New_Package): Two new procedures to register + a package with or without its attributes. + (Register_New_Attribute): Mew procedure to register a new attribute in a + package. + New attribute oriented subprograms: Attribute_Node_Id_Of, + Attribute_Kind_Of, Set_Attribute_Kind_Of, Attribute_Name_Of, + Variable_Kind_Of, Set_Variable_Kind_Of, Optional_Index_Of, + Next_Attribute. + New package oriented subprograms: Package_Node_Id_Of, + Add_Unknown_Package, First_Attribute_Of, Add_Attribute. + + * prj-attr.ads (Attribute_Node_Id): Now a private, self initialized + type. + (Package_Node_Id): Now a private, self initialized type + (Register_New_Package): New procedure to register a package with its + attributes. + New attribute oriented subprograms: Attribute_Node_Id_Of, + Attribute_Kind_Of, Set_Attribute_Kind_Of, Attribute_Name_Of, + Variable_Kind_Of, Set_Variable_Kind_Of, Optional_Index_Of, + Next_Attribute. + New package oriented subprograms: Package_Node_Id_Of, + Add_Unknown_Package, First_Attribute_Of, Add_Attribute. + + * prj-dect.adb (Parse_Attribute_Declaration, + Parse_Package_Declaration): Adapt to new spec of Prj.Attr. + + * prj-makr.adb (Make): Parse existing project file before creating + other files. Fail if there was an error during parsing. + + * prj-proc.adb (Add_Attributes, Process_Declarative_Items): Adapt to + new spec of Prj.Attr. + + * prj-strt.adb (Attribute_Reference, Parse_Variable_Reference): Adapt + to new spec of Prj.Attr. + +2004-07-15 Richard Kenner + + * utils2.c: Fix typo in comment. + +2004-07-14 Richard Kenner + + * trans.c (add_decl_expr): Clear TREE_READONLY if clear DECL_INITIAL. + * utils.c (unchecked_convert): Don't do two VIEW_CONVERT_EXPRs. + +2004-07-14 Andreas Schwab + + * trans.c (gnat_init_stmt_group): Remove duplicate definition. + +2004-07-13 Richard Kenner + + * decl.c: (gnat_to_gnu_entity, object case): Convert initializer to + object type. + (gnat_to_gnu_entity, case E_Record_Subtype): Properly set + TYPE_STUB_DECL. + + * misc.c (gnat_types_compatible_p): New function. + (LANG_HOOKS_TYPES_COMPATIBLE_P): New hook, to use it. + (LANG_HOOKS_TYPE_MAX_SIZE, gnat_type_max_size): New. + + * trans.c (gigi): Move processing of main N_Compilation_Unit here. + (gnat_to_gnu, case N_Compilation_Unit): Just handle nested case here. + (add_stmt): Force walking of sizes and DECL_INITIAL for DECL_EXPR. + (mark_visited): Don't mark dummy type. + (tree_transform ): Unless this is an In + parameter, we must remove any LJM building from GNU_NAME. + (gnat_to_gnu, case N_String_Literal): Fill in indices in CONSTRUCTOR. + (pos_to_constructor): Use int_const_binop. + (gnat_to_gnu, case N_Identifier): Don't reference DECL_INITIAL of + PARM_DECL. + + * utils.c (gnat_init_decl_processing): Don't make two "void" decls. + (gnat_pushlevel): Set TREE_USE on BLOCK node. + (gnat_install_builtins): Add __builtin_memset. + +2004-07-13 Olivier Hainque + + * decl.c (gnat_to_gnu_entity ): If we are making a pointer + for a renaming, stabilize the initialization expression if we are at a + local level. At the local level, uses of the renaming may be performed + by a direct dereference of the initializing expression, and we don't + want possible variables there to be evaluated for every use. + + * trans.c (gnat_stabilize_reference, gnat_stabilize_reference_1): + Propagate TREE_SIDE_EFFECTS and TREE_THIS_VOLATILE to avoid loosing + them on the way. Account for the fact that we may introduce side + effects in the process. + +2004-07-13 Richard Henderson + + * misc.c (default_pass_by_ref): Use pass_by_reference. + +2004-07-11 Joseph S. Myers + + * misc.c (LANG_HOOKS_CLEAR_BINDING_STACK, LANG_HOOKS_PUSHLEVEL, + LANG_HOOKS_POPLEVEL, LANG_HOOKS_SET_BLOCK): Remove. + +2004-07-08 Richard Henderson + + * trans.c (gnat_to_gnu ): Update + commentary. + +2004-07-06 Vincent Celier + + * vms_conv.ads: Minor reformatting. + Alphabetical order for enumerated values of type Command_Type, to have + the command in alphabetical order for the usage. + + * vms_conv.adb (Process_Argument): Set Keep_Temporary_Files to True for + the special qualifier /KEEP_TEMPORARY_FILES (minimum 6 characters). + + * gnat_ugn.texi: Document new switch -dn for the GNAT driver. + + * makegpr.adb (Global_Archive_Exists): New global Boolean variable + (Add_Archive_Path): Only add the global archive if there is one. + (Build_Global_Archive): Set Global_Archive_Exists depending if there is + or not any object file to put in the global archive, and don't build + a global archive if there is none. + (X_Switches): New table + (Compile_Link_With_Gnatmake): Pass to gnatmake the -X switches stored + in the X_Switches table, if any. + (Initialize): Make sure the X_Switches table is empty + (Scan_Arg): Record -X switches in table X_Switches + + * opt.ads (Keep_Temporary_Files): New Boolean flag, defaulted to False. + + * make.adb: Minor comment fix + + * gnatname.adb (Gnatname): When not on VMS, and gnatname has been + invoked with directory information, add the directory in front of the + path. + + * gnatchop.adb (Gnatchop): When not on VMS, and gnatchop has been + invoked with directory information, add the directory in front of the + path. + + * gnatcmd.adb (Delete_Temp_Config_Files): Only delete temporary files + when Keep_Temporary_Files is False. + (GNATCmd): When not on VMS, and the GNAT driver has been invoked with + directory information, add the directory in front of the path. + When not on VMS, handle new switch -dn before the command to set + Keep_Temporary_Files to True. + (Non_VMS_Usage): Use lower case for the non VMS usage: this is valid + everywhere. + + * gnatlink.adb (Gnatlink): When not on VMS, and gnatlink has been + invoked with directory information, add the directory in front of the + path. + +2004-07-06 Thomas Quinot + + * snames.ads, snames.adb (Name_Stub): New name for the distributed + systems annex. + + * rtsfind.ads: New RTE TC_Object, for DSA/PolyORB. + New RTEs RAS_Proxy_Type and RAS_Proxy_Type_Access, for DSA. + + * g-socket.adb (To_Timeval): Fix incorrect conversion of + Selector_Duration to Timeval for the case of 0.0. + + * exp_util.ads (Evolve_Or_Else): Fix overenthusiastic copy/paste of + documentation from Evolve_And_Then. + +2004-07-06 Jose Ruiz + + * s-taprop-tru64.adb, s-taprop-os2.adb, + s-taprop-mingw.adb, s-taprop-posix.adb: Update comment. + +2004-07-06 Robert Dewar + + * s-osinte-hpux.ads, s-osinte-freebsd.ads, + s-osinte-lynxos.ads, s-taprop-lynxos.adb, s-osinte-tru64.ads, + s-osinte-aix.ads, s-osinte-irix.ads, s-taprop-irix.adb, + s-interr-sigaction.adb, s-taprop-irix-athread.adb, + s-osinte-hpux-dce.adb, s-taprop-hpux-dce.adb, + s-taprop-linux.adb, s-taprop-dummy.adb, s-taprop-solaris.adb, + s-interr-vms.adb, s-osinte-vms.ads, s-taprop-vms.adb, + s-osinte-vxworks.ads, s-osprim-vxworks.adb, a-numaux-x86.adb, + a-except.adb, a-exexpr.adb, a-intsig.adb, a-tags.adb, + a-tags.ads, bindgen.ads, checks.adb, checks.adb, + csets.ads, einfo.ads, einfo.ads, elists.adb, exp_ch4.adb, + exp_ch7.adb, exp_dist.adb, exp_util.adb, freeze.adb, + g-dynhta.adb, gnatmem.adb, g-regexp.adb, inline.adb, + i-os2thr.ads, osint.adb, prj.adb, scng.adb, sem_cat.adb, + sem_ch10.adb, sem_ch12.adb, sem_ch4.adb, sem_ch7.adb, + sem_ch8.adb, sem_disp.adb, sem_prag.adb, sem_res.adb, + sem_type.adb, sem_type.ads, sem_warn.adb, s-ficobl.ads, + s-finimp.adb, s-htable.adb, sinfo.ads, sinput-l.ads, + s-interr.adb, s-interr.ads, sprint.adb, s-tarest.adb, + s-tasini.ads, s-taskin.ads, s-taskin.ads, uname.adb, + vms_data.ads: Minor reformatting, + Fix bad box comment format. + + * gnat_rm.texi: Fix minor grammatical error + + * sem_attr.adb, exp_attr.adb: New attribute Has_Access_Values + + * sem_util.ads, sem_util.adb (Requires_Transient_Scope): Allow many + more cases of discriminated records to be recognized as not needing a + secondary stack. + (Has_Access_Values): New function. + + * snames.h, snames.adb, snames.ads: New attribute Has_Access_Values + + * cstand.adb, layout.ads, layout.adb, sem_ch13.ads: Change name + Set_Prim_Alignment to Set_Elem_Alignment (more accurate correspondence + with LRM terminology). + Change terminology in comments primitive type => elementary type. + +2004-07-06 Ed Schonberg + + PR ada/15602 + * sem_ch7.adb (Unit_Requires_Body): For a generic package, the formal + parameters do not impose any requirements on the presence of a body. + +2004-07-06 Ed Schonberg + + PR ada/15593 + * sem_ch12.adb (Analyze_Package_Instantiation): If the generic is not a + compilation unit and is in an open scope at the point of instantiation, + assume that a body may be present later. + +2004-07-06 Ed Schonberg + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause, case 'Size): + Improve error message when specified size is not supported. + + * sem_ch6.adb (Maybe_Primitive_Operation): A library-level subprogram + is never a primitive operation. + +2004-07-05 Andreas Schwab + + * ada-tree.h (TYPE_LEFT_JUSTIFIED_MODULAR_P): Use + RECORD_OR_UNION_CHECK. + (TYPE_CONTAINS_TEMPLATE_P): Likewise. + +2004-07-04 Kelley Cook + + * Make-lang.in (doc/gnat_ugn_unw.texi): Eliminate explicit + dependency on xgnatugn, instead build it via a submake. + (ADA_INFOFILES): Add doc/gnat_ugn_unw.texi. + +2004-07-04 Richard Henderson + + * utils2.c (gnat_mark_addressable): Don't put_var_into_stack. + +2004-07-01 Richard Henderson + + * trans.c (gnat_stabilize_reference): Don't handle RTL_EXPR. + * utils.c (max_size): Likewise. + +2004-06-28 Richard Kenner + + * decl.c: Remove calls to add_decl_expr, pushdecl, rest_of_compilation, + and rest_of_type_compilation; add arg to create_*_decl. + (annotate_decl_with_node): Deleted. + (gnat_to_gnu_entity, case E_Array_Type): Set location of fields. + * gigi.h (get_decls, block_has_vars, pushdecl): Deleted. + (get_current_block_context, gnat_pushdecl): New declarations. + (gnat_init_stmt_group): Likewise. + (create_var_decl, create_type_decl, create_subprog_decl): Add new arg. + * misc.c (LANG_HOOKS_CLEAR_BINDING_STACK): Deleted. + (LANG_HOOKS_GETDECLS, LANG_HOOKS_PUSHDECL): Deleted. + (gnat_init): Call gnat_init_stmt_group. + * trans.c (global_stmt_group, gnu_elab_proc_decl): New variables. + (gnu_pending_elaboration_list): Deleted. + (mark_visited, mark_unvisited, gnat_init_stmt_group): New functions. + (gigi): Rearrange initialization calls and move some to last above. + (gnat_to_gnu): If statement and not in procedure, go into elab proc. + Delete calls to add_decl_expr; add arg to create_*_decl. + (gnat_to_gnu, case N_Loop): Recalculate side effects on COND_EXPR. + (gnat_to_gnu, case N_Subprogram_Body): Move some code to + begin_subprog_body and call it. + Don't push and pop ggc context. + (gnat_to_gnu, case N_Compilation_Unit): Rework to support elab proc. + (add_stmt): Remove handling of DECL_EXPR from here. + If not in function, mark visited. + (add_decl_expr): Put global at top level. + Check for cases of DECL_INITIAL we have to handle here. + (process_type): Add extra arg to create_type_decl. + (build_unit_elab): Rework to just gimplify. + * utils.c (pending_elaborations, elist_stack, getdecls): Deleted. + (block_has_vars, mark_visited, add_pending_elaborations): Likewise. + (get_pending_elaborations, pending_elaborations_p): Likewise. + (push_pending_elaborations, pop_pending_elaborations): Likewise. + (get_elaboration_location, insert_elaboration_list): Likewise. + (gnat_binding_level): Renamed from ada_binding_level. + (init_gnat_to_gnu): Don't clear pending_elaborations. + (global_bindings_p): Treat as global if no current_binding_level. + (set_current_block_context): New function. + (gnat_pushdecl): Renamed from pushdecl; major rework. + All callers changed. + (create_type_decl, create_var_decl, create_subprog_decl): Add new arg. + (finish_record_type): Call call pushdecl for stub decl. + (function_nesting_depth): Deleted. + (begin_subprog_body): Delete obsolete code. + * utils2.c (build_call_alloc_dealloc): Add new arg to create_var_decl. + +2004-06-28 Robert Dewar + + * mlib-tgt-tru64.adb, mlib-tgt-aix.adb, mlib-tgt-irix.adb, + mlib-tgt-irix.adb, mlib-tgt-hpux.adb, mlib-tgt-linux.adb, + mlib-tgt-linux.adb, mlib-tgt-solaris.adb, mlib-tgt-solaris.adb, + mlib-tgt-vms-alpha.adb, mlib-tgt-vms-alpha.adb, mlib-tgt-vms-ia64.adb, + a-strmap.adb, a-strmap.ads, clean.adb: Minor reformatting + + * exp_util.adb (Is_Possibly_Unaligned_Slice): Completely rewritten, to + deal with problem of inefficient slices on machines with strict + alignment, when the slice is a component of a composite. + + * checks.adb (Apply_Array_Size_Check): Do not special case 64-bit + machines, we need the check there as well. + +2004-06-28 Ed Schonberg + + * exp_ch5.adb (Expand_Assign_Array): Use correct condition to + determine safe copying direction for overlapping slice assignments + when component is controlled. + + * sem_ch12.adb (Instantiate_Formal_Package): Implicit operations of a + formal derived type in the actual for a formal package are visible in + the enclosing instance. + +2004-06-28 Ed Schonberg + + PR ada/15600 + * sem_util.adb (Trace_Components): Diagnose properly an illegal + circularity involving a private type whose completion includes a + self-referential component. + (Enter_Name): Use Is_Inherited_Operation to distinguish a source + renaming or an instantiation from an implicit derived operation. + +2004-06-28 Pascal Obry + + * mlib-tgt-mingw.adb: (Library_Exists_For): Remove "lib" prefix from + DLL. + (Library_File_Name_For): Idem. + +2004-06-28 Matthew Gingell + + * g-traceb.ads: Add explanatory note on the format of addresses + expected by addr2line. + +2004-06-28 Jerome Guitton + + * Makefile.in: Force debugging information on s-tasdeb.adb, + a-except.adb and s-assert.adb needed by the debugger. + +2004-06-28 Vincent Celier + + * make.adb (Collect_Arguments_And_Compile): Change Flag1 to + Need_To_Build_Lib. + (Gnatmake): Ditto. + + * mlib-prj.adb (Check_Library): Replace Flag1 with Need_To_Build_Lib + + * prj.adb: Minor reformatting + (Project_Empty): Change Flag1 to Need_To_Build_Lib. Remove Flag2. + + * prj.ads: Comment updates + Minor reformatting + (Project_Data): Change Flag1 to Need_To_Build_Lib. + Remove Flag2: not used. + + * prj-dect.adb (Parse_Declarative_Items): Accept "null" as a + declaration. + + * gnat_ugn.texi: Put a "null;" declaration in one project file example + + * gnat_rm.texi: Document Empty declarations "null;". + + * makegpr.adb (Compile_Link_With_Gnatmake): Put the global archives in + front of the linker options. + (Link_Foreign): Put the global archives and the libraries in front of + the linker options. + +2004-06-28 Javier Miranda + + * rtsfind.adb: (Get_Unit_Name): Fix typo in comment + (RTU_Loaded): Code cleanup + (Set_RTU_Loaded): New procedure to register as *loaded* explicitly + withed predefined units. + + * rtsfind.ads (Set_RTU_Loaded): New procedure to register as *loaded* + explicitly withed predefined units. + Fix typo in comment + + * sem_ch10.adb (Analyze_Compilation_Unit): Register as *loaded* + explicitly withed predefined units. + +2004-06-26 Richard Kenner + + * ada-tree.def (DECL_STMT): Deleted. + * ada-tree.h (IS_ADA_STMT): Now test against STMT_STMT. + (DECL_STMT_VAR): Deleted. + * decl.c: add_decl_stmt now add_decl_expr. + * gigi.h: Likewise. + * trans.c: Likewise. + (gnat_gimplify_type_sizes, gnat_gimplify_one_sizepos): Deleted. + (gnat_to_gnu, case N_Subprogram_Body): Set cfun->function_end_locus. + (add_stmt): Only handle padded type here. + (add_stmt_with_node): Allow gnat_node to not be present. + (gnat_gimplify_stmt, case USE_STMT): Set *STMT_P to null. + (gnat_gimplify_stmt, case DECL_STMT): Deleted. + (gnat_stabilize_reference_1): If COMPONENT_REF of fat pointer, + make a SAVE_EXPR for the entire fat pointer. + * utils.c (pushdecl): Walk a DECL_EXPR in global case. + (create_index_type): Make a DECL_EXPR. + (end_subprog_body): Don't call allocate_struct_function here but + do clear cfun. + +2004-06-25 Pascal Obry + + * makegpr.adb (Build_Library): Remove parameter Lib_Address and + Relocatable from Build_Dynamic_Library call. + + * gnat_ugn.texi: Change documentation about Library_Kind. Dynamic and + Relocatable are now synonym. + + * Makefile.in: Use s-parame-mingw.adb on MingW platform. + + * mlib-prj.adb (Build_Library): Remove DLL_Address constant definition. + Remove parameter Lib_Address and Relocatable from Build_Dynamic_Library + call. + + * mlib-tgt.ads, mlib-tgt.adb (Build_Dynamic_Library): Remove parameter + Lib_Address and Relocatable. + (Default_DLL_Address): Removed. + + * mlib-tgt-tru64.adb, mlib-tgt-aix.adb, mlib-tgt-irix.adb, + mlib-tgt-hpux.adb, mlib-tgt-linux.adb, mlib-tgt-solaris.adb, + mlib-tgt-vms-alpha.adb, mlib-tgt-vms-ia64.adb, mlib-tgt-vxworks.adb: + (Build_Dynamic_Library): Remove parameter Lib_Address and Relocatable. + (Default_DLL_Address): Removed. + + * mlib-tgt-mingw.adb: Ditto. + (Build_Dynamic_Library): Do not add "lib" prefix to the DLL name. + + * s-taprop-mingw.adb (Create_Task): Use Adjust_Storage_Size to compute + the initial thread stack size. + + * a-strmap.ads: Move package L to private part as it is not used in + the spec. Found while reading code. + +2004-06-25 Olivier Hainque + + * tracebak.c: Introduce support for a GCC infrastructure based + implementation of __gnat_backtrace. + + * raise.c: Don't rely on a C mapping of the GNAT_GCC_Exception record + any more. Use accessors instead. This eases maintenance and relaxes + some alignment constraints. + (_GNAT_Exception structure): Remove the Ada specific fields + (EID_For, Adjust_N_Cleanups_For): New accessors, exported by + a-exexpr.adb. + (is_handled_by, __gnat_eh_personality): Replace component references to + exception structure by use of the new accessors. + + * init.c (__gnat_initialize): Adjust comments to match the just + reverted meaning of the -static link-time option. + + * adaint.c (convert_addresses): Arrange not to define a stub for + mips-irix any more, as we now want to rely on a real version from a + recent libaddr2line. + + * a-exexpr.adb: Provide new accessors to a GNAT_GCC occurrence, so that + the personality routine can use them and not have to rely on a C + counterpart of the record anymore. This simplifies maintenance and + relaxes the constraint of having Standard'Maximum_Alignment match + BIGGEST_ALIGNMENT. + Update comments, and add a section on the common header alignment issue. + +2004-06-25 Geert Bosch + + * a-ngelfu.adb (Tanh): Use full 20 digit precision for constants in + polynomial approximation. Fixes inconsistency with Cody/Waite algorithm. + +2004-06-25 Robert Dewar + + * gnat_rm.texi: Fix section on component clauses to indicate that the + restriction on byte boundary placement still applies for bit packed + arrays. + Add comment on stack usage from Initialize_Scalars + + * gnat_ugn.texi: Add documentation for -gnatyLnnn + + * stylesw.ads, stylesw.adb: Implement new -gnatyLnnn option for + limiting nesting level. + + * usage.adb: Add line for -gnatyLnnn switch + + * g-debpoo.ads, xtreeprs.adb, sinput.ads, sem_ch13.ads, + sem_ch13.adb, exp_aggr.adb: Minor reformatting + + * sem_prag.adb (Process_Atomic_Shared_Volatile): Set Is_Atomic on base + type as well as on the subtype. This corrects a problem in freeze in + setting alignments of atomic types. + + * sem_eval.ads: Minor comment typo fixed + + * par-util.adb (Push_Scope_Stack): Check for violation of max nesting + level. Minor reformatting. + + * fname.adb (Is_Predefined_File_Name): Require a letter after the + minus sign. This means that file names like a--b.adb will not be + considered predefined. + + * freeze.adb: Propagate new flag Must_Be_On_Byte_Boundary to containing + record Test new flag and give diagnostic for bad component clause. + (Freeze_Entity): Set alignment of array from component alignment in + cases where this is safe to do. + + * exp_pakd.adb: Set new flag Must_Be_On_Byte_Boundary for large packed + arrays. + + * cstand.adb: (Create_Standard): Set alignment of String to 1 + + * einfo.ads, einfo.adb: Introduce new flag Must_Be_On_Byte_Boundary + + * exp_ch4.adb (Expand_Array_Equality): Improve efficiency of generated + code in the common constrained array cases. + + * a-storio.adb: Change implementation to avoid possible alignment + problems on machines requiring strict alignment (data should be moved + as type Buffer, not type Elmt). + + * checks.adb (Apply_Array_Size_Check): Improve these checks by + killing the overflow checks which we really do not need (64-bits is + enough). + +2004-06-25 Vincent Celier + + * makegpr.adb (Is_Included_In_Global_Archive): New Boolean function + (Add_Archives.Recursive_Add_Archives): Call Add_Archive_Path + inconditionally for the main project. + (Recursive_Add_Archives.Add_Archive_Path): New procedure + (Link_Executables.Check_Time_Stamps): New procedure + (Link_Executables.Link_Foreign): New procedure + Changes made to reduce nesting level of this package + (Check): New procedure + (Add_Switches): When not in quiet output, check that a switch is not + the concatenation of several valid switches. If it is, issue a warning. + (Build_Global_Archive): If the global archive is rebuilt, linking need + to be done. + (Compile_Sources): Rebuilding a library archive does not imply + rebuilding the global archive. + (Build_Global_Archive): New procedure + (Build_Library): New name for Build_Archive, now only for library + project + (Check_Archive_Builder): New procedure + (Create_Global_Archive_Dependency_File): New procedure + (Gprmake): Call Build_Global_Archive before linking + * makegpr.adb: Use Other_Sources_Present instead of Sources_Present + throughout. + (Scan_Arg): Display the Copyright notice when -v is used + + * gnat_ugn.texi: Document new switch -files= (VMS qualifier /FILES=) + for gnatls. + + * vms_data.ads: Add qualifier /MAX_NESTING=nnn (-gnatyLnnn) for GNAT + COMPILE. + Add new GNAT LIST qualifier /FILES= + Added qualifier /DIRECTORY= to GNAT METRIC + Added qualifier /FILES= to GNAT METRIC + Added qualifier /FILES to GNAT PRETTY + + * switch.adb (Is_Front_End_Switch): Refine the test for --RTS or -fRTS, + to take into account both versions of the switch. + + * switch-c.adb (Scan_Front_End_Switches): New switch -gnatez. Should + always be the last switch to the gcc driver. Disable switch storing so + that switches automatically added by the gcc driver are not put in the + ALI file. + + * prj.adb (Project_Empty): Take into account changes in components of + Project_Data. + + * prj.ads (Languages_Processed): New enumaration value All_Languages. + + * prj.ads (Project_Data): Remove component Lib_Elaboration: never + used. Split Boolean component Ada_Sources_Present in two Boolean + components Ada_Sources_Present and Other_Sources_Present. + Minor reformatting + + * prj-env.adb (For_All_Source_Dirs.Add): Use Ada_Sources_Present + instead of Sources_Present. + (Set_Ada_Paths.Add.Recursive_Add): Ditto + + * prj-nmsc.adb: Minor reformatting + (Check_Ada_Naming_Scheme): New name of procedure Check_Naming_Scheme + (Check_Ada_Naming_Scheme_Validity): New name of previous procedure + Check_Ada_Naming_Scheme. + Change Sources_Present to Ada_Sources_Present or Other_Sources_Present + throughout. + + * prj-part.adb (Post_Parse_Context_Clause): New Boolean parameter + In_Limited. + Make sure that all cycles where there is at least one "limited with" + are detected. + (Parse_Single_Project): New Boolean parameter In_Limited + + * prj-proc.adb (Recursive_Check): When Process_Languages is + All_Languages, call first Prj.Nmsc.Ada_Check, then + Prj.Nmsc.Other_Languages_Check. + + * prj-proc.adb (Process): Use Ada_Sources_Present or + Other_Sources_Present (instead of Sources_Present) depending on + Process_Languages. + + * lang-specs.h: Keep -g and -m switches in the same order, and as the + last switches. + + * lib.adb (Switch_Storing_Enabled): New global Boolean flag + (Disable_Switch_Storing): New procedure. Set Switch_Storing_Enabled to + False. + (Store_Compilation_Switch): Do nothing if Switch_Storing_Enabled is + False. + + * lib.ads (Disable_Switch_Storing): New procedure. + + * make.adb: Modifications to reduce nesting level of this package. + (Check_Standard_Library): New procedure + (Gnatmake.Check_Mains): New procedure + (Gnatmake.Create_Binder_Mapping_File): New procedure + (Compile_Sources.Compile): Add switch -gnatez as the last option + (Display): Never display -gnatez + + * Makefile.generic: + When using $(MAIN_OBJECT), always use $(OBJ_DIR)/$(MAIN_OBJECT) + + * gnatcmd.adb (Check_Project): New function + (Process_Link): New procedure to reduce nesting depth + (Check_Files): New procedure to reduce the nesting depth. + For GNAT METRIC, include the inherited sources in extending projects. + (GNATCmd): When GNAT LS is invoked with a project file and no files, + add the list of files from the sources of the project file. If this list + is too long, put it in a temp text files and use switch -files= + (Delete_Temp_Config_Files): Delete the temp text file that contains + a list of source for gnatpp or gnatmetric, if one has been created. + (GNATCmd): For GNAT METRIC and GNAT PRETTY, if the number of sources + in the project file is too large, create a temporary text file that + list them and pass it to the tool with "-files=". + (GNATCmd): For GNAT METRIC add "-d=" as the first switch + + * gnatlink.adb (Gnatlink): Do not compile with --RTS= when the + generated file is in not in Ada. + + * gnatls.adb: Remove all parameters And_Save that are no longer used. + (Scan_Ls_Arg): Add processing for -files= + (Usage): Add line for -files= + + * g-os_lib.adb (On_Windows): New global constant Boolean flag + (Normalize_Pathname): When on Windows and the path starts with a + directory separator, make sure that the resulting path will start with + a drive letter. + + * clean.adb (Clean_Archive): New procedure + (Clean_Project): When there is non-Ada code, delete the global archive, + the archive dependency files, the object files and their dependency + files, if they exist. + (Gnatclean): Call Prj.Pars.Parse for All_Languages, not for Ada only. + +2004-06-25 Thomas Quinot + + * sinfo.ads: Fix typo in comment. + + * sem_dist.adb (Process_Remote_AST_Attribute): Simplify code that uses + the TSS for remote access-to-subprogram types, since these TSS are + always present once the type has been analyzed. + (RAS_E_Dereference): Same. + + * sem_attr.adb (Analyze_Attribute): When analysis of an attribute + reference raises Bad_Attribute, mark the reference as analyzed so the + node (and any children resulting from rewrites that could have occurred + during the analysis that ultimately failed) is not analyzed again. + + * exp_ch7.ads (Find_Final_List): Fix misaligned comment. + + * exp_dist.adb: Minor comment fix. + + * exp_ch4.adb (Expand_N_Allocator): For an allocator whose expected + type is an anonymous access type, no unchecked deallocation of the + allocated object can occur. If the object is controlled, attach it with + a count of 1. This allows attachment to the Global_Final_List, if + no other relevant list is available. + (Get_Allocator_Final_List): For an anonymous access type that is + the type of a discriminant or record component, the corresponding + finalisation list is the one of the scope of the type. + +2004-06-25 Ed Schonberg + + * sem_ch3.adb (Replace_Type): When computing the signature of an + inherited subprogram, use the first subtype if the derived type + declaration has no constraint. + + * exp_ch6.adb (Add_Call_By_Copy_Code): Check that formal is an array + before applying previous optimization. Minor code cleanup. + + * exp_util.adb (Is_Possibly_Unaligned_Slice): If the component is + placed at the beginning of an unpacked record without explicit + alignment, a slice of it will be aligned and does not need a copy when + used as an actual. + +2004-06-25 Ed Schonberg + + PR ada/15591 + PR ada/15592 + * sem_ch8.adb (Attribute_Renaming): Reject renaming if the attribute + reference is written with expressions mimicking parameters. + +2004-06-25 Hristian Kirtchev + + PR ada/15589 + * sem_ch3.adb (Build_Derived_Record_Type): Add additional check to + STEP 2a. The constraints of a full type declaration of a derived record + type are checked for conformance with those declared in the + corresponding private extension declaration. The message + "not conformant with previous declaration" is emitted if an error is + detected. + +2004-06-25 Vasiliy Fofanov + + * g-traceb.ads: Document the need for -E binder switch in the spec. + + * g-trasym.ads: Document the need for -E binder switch in the spec. + +2004-06-25 Jose Ruiz + + * sem_prag.adb: Add handling of pragma Detect_Blocking. + + * snames.h, snames.ads, snames.adb: Add entry for pragma + Detect_Blocking. + + * s-rident.ads: Change reference to pragma Detect_Blocking. + + * targparm.ads, targparm.adb: Allow pragma Detect_Blocking in + system.ads. + + * opt.ads (Detect_Blocking): New Boolean variable (defaulted to False) + to indicate whether pragma Detect_Blocking is active. + + * par-prag.adb: Add entry for pragma Detect_Blocking. + + * rtsfind.adb (RTU_Loaded): Fix the temporary kludge to get past bug + of not handling WITH. + Note that this replaces the previous update which was incorrect. + +2004-06-25 Javier Miranda + + * sem_ch10.adb (Re_Install_Use_Clauses): Force the installation of the + use-clauses to have a clean environment. + + * sem_ch8.adb (Install_Use_Clauses): Addition of a new formal to force + the installation of the use-clauses to stablish a clean environment in + case of compilation of a separate unit; otherwise the call to + use_one_package is protected by the barrier Applicable_Use. + + * sem_ch8.ads (Install_Use_Clauses): Addition of a new formal to force + the installation of the use-clauses to stablish a clean environment in + case of compilation of a separate unit. + (End_Use_Clauses): Minor comment cleanup. + +2004-06-25 Sergey Rybin + + * gnat_ugn.texi: Add description of the gnatpp 'files' switch + +2004-06-23 Richard Henderson + + * trans.c (gnat_gimplify_stmt): Update gimplify_type_sizes call. + +2004-06-20 Richard Kenner + + * decl.c (elaborate_expression, elaborate_expression_1): Arguments + now bool instead of int. + (gnat_to_gnu_entity, elaborate_expression_1): New arg to COMPONENT_REF. + * trans.c (gnu_switch_label_stack): New function. + (gnat_to_gnu, N_Object_Renaming_Declaration): Result is what the + elaboration of renamed entity returns. + (gnat_to_gnu, case N_Case_Statement): Add branches to end label. + (add_decl_stmt): Don't add TYPE_DECL for UNCONSTRAINED_ARRAY_TYPE. + (gnat_gimplify_stmt): Use alloc_stmt_list, not build_empty_stmt. + (gnat_gimplify_stmt, case DECL_STMT): gimplify DECL_SIZE and + DECL_SIZE_UNIT and simplify variable-sized case. + (gnat_gimplify_type_sizes, gnat_gimplify_one_sizepos): Deleted. + Callers changes to call gimplify_type_sizes and gimplify_one_sizepos. + (gnat_stabilize_reference): Add arg to COMPONENT_REF. + (build_unit_elab): Disable for now. + * utils.c (mark_visited): New function. + (pushdecl): Walk tree to call it for global decl. + (update_pointer_to): Update all variants of pointer and ref types. + Add arg to COMPONENT_REF. + (convert): Likewise. + Move check for converting between variants lower down. + * utils2.c (build_simple_component_ref): Add arg to COMPONENT_REF. + (build_allocator): Don't force type of MODIFY_EXPR. + (gnat_mark_addressable, case VAR_DECL): Unconditionally call + put_var_into_stack. + +2004-06-14 Richard Kenner + + * ada-tree.def (LOOP_STMT, EXIT_STMT): Update documentation. + * ada-tree.h (EXIT_STMT_LABEL): Renamed from EXIT_STMT_LOOP. + * decl.c (gnat_to_gnu_entity): Also set force_global for imported + subprograms. + * trans.c (gnu_loop_label_stack): Renamed from gnu_loop_stmt_stack; + all callers changed. + (gnat_to_gnu, case N_Loop_Statement, case N_Exit_Statement): Change + the way that EXIT_STMT finds the loop label. + (gnat_gimplify_stmt, case LOOP_STMT, EXIT_STMT): Likewise. + (gnat_gimplify_stmt, case DECL_STMT): Handle variable-sized decls here. + (add_stmt): Use annotate_with_locus insted of setting directly. + (pos_to_construct): Set TREE_PURPOSE of each entry to index. + (gnat_stabilize_reference, case ARRAY_RANGE_REF): Merge with ARRAY_REF. + * utils.c (gnat_install_builtins): Install __builtin_memcmp. + (build_vms_descriptor): Add extra args to ARRAY_REF. + (convert): Use VIEW_CONVERT_EXPR between aggregate types. + * utils2.c (gnat_truthvalue_conversion, case INTEGER_CST, REAL_CST): + New cases. + (build_binary_op): Don't make explicit CONVERT_EXPR. + Add extra rgs to ARRAY_REF. + +2004-06-14 Pascal Obry + + * gnat_ugn.texi: Document relocatable vs. dynamic Library_Kind on + Windows. Fix minor typo. + + * mlib-tgt-mingw.adb: New implementation using the GCC -shared option + which is now supported on Windows. With this implementation using the + Library Project feature is no different on Windows than on UNIX. + +2004-06-14 Vincent Celier + + * makegpr.adb (Compile_Sources): Nothing to do when there are no + non-Ada sources. + + * mlib-tgt-vxworks.adb (Library_Exists_For): Remove incorrect comment + + * prj-part.adb (Parse_Single_Project): When a duplicate project name is + found, show the project name and the path of the previously parsed + project file. + +2004-06-14 Ed Schonberg + + * exp_ch6.adb (Add_Call_By_Copy_Code): For an out-parameter that is an + array, avoid copying the actual before the call. + +2004-06-14 Thomas Quinot + + * g-debpoo.adb: Remove alignment assumptions from GNAT.Debug_Pools. + Instead, allocate memory on worst-case alignment assumptions, and then + return an aligned address within the allocated zone. + +2004-06-14 Robert Dewar + + * bindgen.adb (Gen_Adainit_Ada): Do not generate external references to + elab entities in predefined units in No_Run_Time_Mode. + (Gen_Adainit_C): Same fix + (Gen_Elab_Calls_Ada): Do not generate calls to elaborate predefined + units in No_Run_Time_Mode + (Gen_Elab_Calls_C): Same fix + + * symbols-vms-alpha.adb: Minor reformatting + + * g-debpoo.ads: Minor reformatting + + * lib.adb (In_Same_Extended_Unit): Version working on node id's + + * lib.ads (In_Same_Extended_Unit): Version working on node id's + + * lib-xref.adb: Minor cleanup, use new version of In_Same_Extended_Unit + working on nodes. + + * make.adb: Minor reformatting + + * par-ch12.adb: Minor reformatting + + * par-prag.adb: Add dummy entry for pragma Profile_Warnings + + * prj-strt.adb: Minor reformatting + + * restrict.ads, restrict.adb: Redo handling of profile restrictions to + be more general. + + * sem_attr.adb: Minor reformatting + + * sem_ch7.adb: Minor reformatting + + * sem_elab.adb (Check_A_Call): Deal with problem of calling init proc + for type in the same unit as the object declaration. + + * sem_prag.adb (Check_Arg_Is_External_Name): New procedure, allows + static string expressions and not just string literals. + Minor reformatting + (Set_Warning): Reset restriction warning flag for restriction pragma + Implement pragma Profile_Warnings + Implement pragma Profile (Restricted) + Give obolescent messages for old restrictions and pragmas + + * snames.h, snames.ads, snames.adb: Add new entry for pragma + Profile_Warnings. + + * s-rident.ads: Add declarations for restrictions required by profile + Restricted and profile Ravenscar. + + * targparm.ads, targparm.adb: Allow pragma Profile in system.ads + + * gnat_ugn.texi: Correct some missing entries in the list of GNAT + configuration pragmas. + +2004-06-11 Vincent Celier + + * mlib-tgt-vms-alpha.adb (Build_Dynamic_Library): Issue switch -R to + gnatsym, when symbol policy is Restricted. + + * mlib-tgt-vms-ia64.adb (Build_Dynamic_Library): Issue switch -R to + gnatsym, when symbol policy is Restricted. + + * symbols-vms-alpha.adb (Initialize): When symbol policy is Restricted, + read the symbol file. + (Finalize): Fail in symbol policy Restricted if a symbol in the original + symbol file is not in the object files. Do not create a new symbol file + when symbol policy is Restricted. + + * gnatbind.adb (Gnatbind): Initialize Snames, because Snames is used + in Scng. + + * gnatsym.adb (Parse_Vmd_Line): Process new switch -R for symbol policy + Restricted. + (Usage): Line for new switch -R + + * make.adb (Initialize): When the platform is not VMS, add the + directory where gnatmake is invoked in the front of the path, if + gnatmake is invoked with directory information. Change the Scan_Args + while loop to a for loop. + (Recursive_Compute_Depth): Remove parameter Visited. Improve efficiency: + if Depth is equal or greater than the proposed depth, there is nothing + to do. + (Initialize): Call Recursive_Compute_Depth with initial Depth equal to 1 + instead of 0. + + * prj.ads: Add new symbol policy Restricted. + + * prj-dect.adb (Parse_Case_Construction): Call End_Case_Construction + with the new parameters Check_All_Labels and Case_Location. + + * prj-nmsc.adb (Ada_Check): Process new symbol policy Restricted + (Library_Symbol_File needs to be defined). + + * prj-strt.adb (End_Case_Construction): New parameters Check_All_Labels + and Case_Location If Check_All_Labels is True, check that all values of + the string type are used, and output warning(s) if they are not. + + * prj-strt.ads (End_Case_Construction): New parameters Check_All_Labels + and Case_Location. + + * gnat_ugn.texi: Reorder subclauses in menus "Switches for gcc" + + * gnat_ugn.texi: Update documentation about the library directory in + Library Projects. + + * makegpr.adb (Display_Command): In verbose mode, also display the + value of the CPATH env var, when the compiler is gcc. + (Initialize): Change the Scan_Args while loop to a for loop + (Compile_Individual_Sources): Change directory to object directory + before compilations. + + * symbols.ads: New symbol policy Restricted. + +2004-06-11 Olivier Hainque + + * a-except.adb (Raise_After_Setup family): Remove. The responsibility + is now taken care of internally in the Exception_Propagation package + and does not require clients assistance any more. + + * a-exexpr.adb (Is_Setup_And_Not_Propagated, + Set_Setup_And_Not_Propagated, and Clear_Setup_And_Not_Propagated): New + functions. Helpers to maintain a predicate required in the handling of + occurrence transfer between tasks. + This is now handled internally and does not require clients assistance + for the setup/propagate separation anymore. + (Setup_Exception, Propagate_Exception): Simplify the Private_Data + allocation strategy, handle the Setup_And_Not_Propagated predicate and + document. + + * s-taenca.adb (Check_Exception): Use raise_with_msg instead of + raise_after_setup, now that everything is handled internally within the + setup/propagation engine. + +2004-06-11 Hristian Kirtchev + + * exp_ch6.adb (Expand_Inlined_Call): Add function Formal_Is_Used_Once. + Add additional conditions for the case of an actual being a simple + name or literal. Improve inlining by preventing the generation + of temporaries with a short lifetime (one use). + +2004-06-11 Hristian Kirtchev + + PR ada/15587 + * einfo.ads: Minor comment updates for Has_Completion and + E_Constant list of flags. + + * sem_ch3.adb (Analyze_Object_Declaration): Full constant declarations + and constant redeclarations now set the Has_Completion flag of their + defining identifiers. + + * sem_ch7.adb (Analyze_Package_Spec): Add procedure + Inspect_Deferred_Constant_Completion. + Used to detect private deferred constants that have not been completed + either by a constant redeclaration or pragma Import. Emits error message + "constant declaration requires initialization expression". + + * sem_prag.adb (Process_Import_Or_Interface): An Import pragma now + completes a deferred constant. + +2004-06-11 Geert Bosch + + * eval_fat.adb (Decompose_Int): Fix rounding of negative numbers. + + * s-fatgen.adb (Gradual_Scaling): Correct off-by-one error in + calculating exponent for scaling denormal numbers. + (Leading_Part): Properly raise Constraint_Error for zero or negative + Adjustment. + (Remainder): Properly raise Constraint_Error for zero divisor. + +2004-06-11 Thomas Quinot + + * sem_util.adb: Minor reformatting. + + * exp_ch2.adb (Expand_Entry_Parameter): Generate an explicit + dereference when accessing the entry parameter record. + (Check_Array_Type): Always check for possible implicit dereference. + (maybe_implicit_dereference): Rename to check_no_implicit_derefence. + Abort if a pointer is still present (denoting that an implicit + dereference was left in the tree by the front-end). + + * sem_attr.adb (Expand_Entry_Parameter): Generate an explicit + dereference when accessing the entry parameter record. + (Check_Array_Type): Always check for possible implicit dereference. + (maybe_implicit_dereference): Rename to check_no_implicit_derefence. + Abort if a pointer is still present (denoting that an implicit + dereference was left in the tree by the front-end). + +2004-06-11 Emmanuel Briot + + * g-debpoo.adb (Deallocate, Dereference): Add prefix "error:" to error + message, like the compiler itself does. Easier to parse the output. + + * g-debpoo.ads: (Allocate, Deallocate, Dereference): Add comments. + + * gnat_ugn.texi (gnatxref, gnatfind): Clarify that source names should + be base names, and not includes directories. + +2004-06-11 Arnaud Charlet + + * Makefile.generic ($(EXEC)): Depend on $(OBJECTS), not $(OBJ_FILES), + so that dependencies are properly taken into account by make. + +2004-06-11 Arnaud Charlet + + PR ada/15622 + * s-unstyp.ads, s-maccod.ads, sem_ch8.adb, s-auxdec.ads, + exp_intr.adb, s-auxdec-vms_64.ads: Fix typo: instrinsic -> intrinsic + +2004-06-11 Jerome Guitton + + * Makefile.in (install-gnatlib): install target-specific run-time files. + + * Make-lang.in: Remove obsolete targets. + +2004-06-11 Ed Schonberg + + * par-ch12.adb (P_Generic): Add scope before analyzing subprogram + specification, to catch misuses of program unit names. + + * sem_res.adb (Resolve_Type_Conversion): Do not emit warnings on + superfluous conversions in an instance. + +2004-06-11 Ed Schonberg + + PR ada/15403 + * sem_ch12.adb (Save_References): If operator node has been folded to + enumeration literal, associated_node must be discarded. + +2004-06-11 Jose Ruiz + + * s-stchop-vxworks.adb: Add required pragma Convention to + Task_Descriptor because it is updated by a C function. + +2004-06-08 Arnaud Charlet + + PR ada/15568 + * Makefile.in: Remove target specific SO_OPT on IRIX + +2004-06-07 Richard Kenner + + * ada-tree.def (TRANSFORM_EXPR, ALLOCATE_EXPR, USE_EXPR): Deleted. + (GNAT_NOP_EXPR, GNAT_LOOP_ID, EXPR_STMT, NULL_STMT): Likewise. + (BLOCK_STMT, IF_STMT, GOTO_STMT, LABEL_STMT, RETURN_STMT): Likewise. + (ASM_STMT, BREAK_STMT, REGION_STMT,HANDLER_STMT): Likewise. + (STMT_STMT, USE_STMT): New statement codes. + (LOOP_STMT, EXIT_STMT): Make slight semantic changes. + * ada-tree.h: Reflect above changes. + (struct tree_loop_id): Deleted. + (union lang_tree_node, struct lang_decl, struct lang_type): + Now just contains a tree node; update macros using TYPE_LANG_SPECIFIC + and DECL_LANGUAGE_SPECIFIC to reflect these changes. + (DECL_INIT_BY_ASSIGN_P, TRE_LOOP_NODE_ID, TREE_SLOC): Deleted. + (IS_ADA_STMT): New macro. + * decl.c (annotate_decl_with_node): New function. + (gnat_to_gnu_entity): Use it and Sloc_to_locus instead of set_lineno. + (gnat_to_gnu_entity, case object): Remove call to expand CONVERT_EXPR. + Call add_stmt_with_node to do needed assignments. + Add call to update setjmp buffer directly, not via EXPR_STMT. + (maybe_variable): Argment GNAT_NODE deleted. + * gigi.h (maybe_variable): Likewise. + (make_transform, add_stmt_with_node, set_block_for_group): New. + (gnat_gimplify_expr, gnat_expand_body, Sloc_to_locus): Likewise. + (set_block_jmpbuf_decl, get_block_jmpbuf_decl): Likewise. + (discard_file_names, gnu_block_stack, gnat_to_code): Deleted. + (set_lineno, set_lineno_from_sloc): Likewise. + (record_code_position, insert_code_for): Likewise. + (gnat_poplevel): Now returns void. + (end_subprog_body): Now takes argument. + * misc.c (cgraph.h, tree-inline.h): New includes. + (gnat_tree_size, LANG_HOOKS_TREE_SIZE): Deleted. + (gnat_post_options, LANG_HOOKS_POST_OPTIONS): New. + (LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION): Likewise. + (LANG_HOOKS_RTL_EXPAND_STMT, LANG_HOOKS_GIMPLIFY_EXPR): Likewise. + (gnat_parse_file): Don't set immediate_size_expand. + Call cgraph functions. + (gnat_expand_expr): Remove most cases. + (record_code_position, insert_code_for): Remove from here. + * trans.c (toplev.h, tree-gimple.h): Now included. + (discard_file_names): Deleted. + (gnu_block_stack, gnu_block_stmt_node, gnu_block_stmt_free_list): Del. + (first_nondeleted_insn, make_expr_stmt_from_rtl): Likewise. + (struct stmt_group, current_stmt_group, stmt_group_free_list): New. + (gnu_stack_free_list, record_cost_position, insert_code_for): Likewise. + (add_cleanup, push_stack, gnat_gimplify_stmt, add_cleanup): Likewise. + (gnat_gimplify_type_sizes, gnat_gimplify_one_sizepos): Likewise. + (gnat_expand_body_1, gnat_gimplify_expr, annotate_with_node): Likewise. + (set_block_for_group, add_stmt_list): Likewise. + (start_stmt_group): Renamed from start_block_stmt. + (end_stmt_group): Likewise, from end_block_stmt. + (build_stmt_group): Likewise, from build_block_stmt, also add arg. + (gigi): Don't set discard_file_names or call set_lineno. + Disallow front end ZCX; call gnat_to_gnu, not gnat_to_code. + (tree_transform): Deleted, now renamed to be gnat_to_gnu. + Numerous changes throughout to reflect new names and complete + function-at-a-time implementation. + (gnat_expand_stmt): Delete or comment out all cases. + (process_inlined_subprograms): Use add_stmt. + (process_decls): Use gnat_to_gnu, not gnat_to_code, and don't + call set_lineno; also remove unneeded block handling. + (process_type): Remove unneeded block handling. + (build_unit_elab): Remove calls to deleted functions. + * utils.c (cgraph.h, tree-inline.h, tree-gimple.h): Now include. + (tree-dump.h): Likewise. + (struct ada_binding_level): Add field jmpbuf_decl. + (gnat_define_builtin, gnat_install_builtins): New. + (gnat_gimplify_function, gnat_finalize): Likewise. + (gnat_poplevel): No longer return BLOCK, set it instead. + Remove code dealing with nested functions. + (gnat_init_decl_processing): Also set size_type_node. + Call gnat_install_builtins. + (create_var_decl): Don't set DECL_INIT_BY_ASSIGN. + (create_subprog_decl): Change handling of inline_flag; set TREE_STATIC. + Remove special-case for "main". + (end_subprog_body): Add arg and rework for tree-ssa. + (convert): Don't use GNAT_NOP_EXPR or look for TRANSFORM_EXPR. + Add case for BOOLEAN_TYPE. + * utils2.c (rtl.h): Now include. + (build_call_raise): Test Debug_Flag_NN directly. + (build_call_alloc_dealloc): Don't use local stack allocation for now. + (gnat_mark_addressable, case GNAT_NOP_EXPR): Deleted. + (gnat_mark_addressable, case VAR_DECL): Handle both early & late cases. + +2004-06-07 Robert Dewar + + * a-direct.ads, einfo.ads: Minor comment updates + + * s-taprop-lynxos.adb, s-taprop-tru64.adb, s-taprop-irix.adb, + s-taprop-irix-athread.adb, s-taprop-hpux-dce.adb, s-taprop-linux.adb, + s-taprop-dummy.adb, s-taprop-os2.adb, s-taprop-solaris.adb, + s-taprop-vms.adb, s-taprop-mingw.adb, s-taprop-vxworks.adb, + s-taprop-posix.adb, s-taprop.ads, exp_dbug.adb: Minor reformatting. + + * s-interr-sigaction.adb: Remove unreferenced variable + (Attached_Interrupts). Minor reformatting. + Avoid use of variable I (replace by J). + + * par-ch10.adb: Fix text of one error message + + * checks.adb, checks.ads, cstand.adb, vms_data.ads, errout.ads, + exp_aggr.adb, exp_ch3.adb, exp_ch3.ads, exp_ch5.adb, exp_ch6.adb, + exp_ch9.adb, exp_code.adb, gnat1drv.adb, lib-load.adb, lib-writ.adb, + opt.adb, par.adb, opt.ads, par-ch11.adb, par-ch3.adb, par-ch4.adb, + par-ch5.adb, par-ch6.adb, par-ch8.adb, par-ch9.adb, par-prag.adb, + par-util.adb, scng.adb, sem_aggr.adb, sem_attr.adb, sem_cat.adb, + sem_ch10.adb, sem_ch10.adb, sem_ch11.adb, sem_ch12.adb, sem_ch2.adb, + sem_ch3.adb, sem_ch3.ads, sem_ch4.adb, sem_ch5.adb, sem_ch6.adb, + sem_ch7.adb, sem_ch8.adb, sem_ch9.adb, sem_eval.adb, sem_prag.adb, + sem_res.adb, sem_type.adb, sem_util.adb, sinfo.ads, snames.adb, + snames.ads, snames.h, sprint.adb, switch-c.adb: Modifications for Ada + 2005 support. + +2004-06-07 Doug Rupp + + * mlib-tgt-vms.adb: Rename mlib-tgt-vms.adb mlib-tgt-vms-alpha.adb + + * s-vaflop-vms.adb: Rename s-vaflop-vms.adb to s-vaflop-vms-alpha.adb + + * mlib-tgt-vms-ia64.adb: New file. + + * Makefile.in: Rename mlib-tgt-vms.adb to mlib-tgt-vms-alpha.adb + Add mlib-tgt-vms-ia64.adb + Rename s-vaflop-vms.adb to s-vaflop-vms-alpha.adb. + Move to alpha specific ifeq section. + Add VMS specific versions of symbols.adb + Renaming of 5q vms files. + + * 5qsystem.ads renamed to system-vms_64.ads. + +2004-06-07 Vincent Celier + + * a-calend.ads: Add a GNAT Note comment after function Time_Of to + explain that when a time of day corresponding to the non existing hour + on the day switching to DST is specified, Split may return a different + value for Seconds. + + * gnatcmd.adb: Add processing of GNAT METRIC (for gnatmetric), similar + to GNAT PRETTY. + + * g-os_lib.adb (OpenVMS): New Boolean value imported from System. + (Normalize_Pathname): Only resolve VMS logical names when on VMS. + + * mlib-prj.adb (Build_Library): New flag Gtrasymobj_Needed, initialize + to False. + If Gtrasymobj_Needed is True, add the full path of g-trasym.obj to + the linking options. + (Build_Library.Check_Libs): On VMS, if there is a dependency on + g-trasym.ads, set Gtrasymobj_Needed to True. + + * prj-attr.adb: Add new package Metrics for gnatmetric + + * prj-nmsc.adb (Record_Other_Sources): Put source file names in + canonical case to take into account files with upper case characters on + Windows. + (Ada_Check): Load the reference symbol file name in the name buffer to + check it, not the symbol file name. + + * snames.ads, snames.adb: Add standard name Metrics (name of project + file package for gnatmetric). + + * vms_conv.ads: Add Metric to Comment_Type + + * vms_conv.adb (Initialize): Add component dor Metric in Command_List + + * vms_data.ads: Add qualifiers for GNAT METRIC + + * makegpr.adb (Link_Executables): Take into account the switches + specified in package Linker of the main project. + +2004-06-07 Thomas Quinot + + * bindgen.adb (Set_Unit_Number): Units is an instance of Table, and so + the index of the last element is Units.Last, not Units.Table'Last + (which is usually not a valid index within the actually allocated + storage for the table). + + * exp_ch4.adb (Insert_Dereference_Action): Change predicate that + determines whether to generate a call to a checked storage pool + Dereference action. + Generate such a call only for a dereference that either comes from + source, or is the result of rewriting a dereference that comes from + source. + +2004-06-07 Romain Berrendonner + + * bindgen.adb (Gen_Output_File): Add support for GAP builds. + +2004-06-07 Eric Botcazou + + (gnat_to_gnu_entity) : For multi-dimensional arrays at + file level, elaborate the stride for inner dimensions in alignment + units, not bytes. + + * exp_ch5.adb: Correct wrong reference to Component_May_Be_Bit_Aligned + in a comment. + +2004-06-07 Javier Miranda + + * exp_ch6.adb: Correct wrong modification in previous patch + +2004-06-07 Vasiliy Fofanov + + * g-trasym.ads: Corrected comment to properly reflect level of support + on VMS. + +2004-06-07 Hristian Kirtchev + + * lib-xref.adb (Generate_Reference): Add nested function Is_On_LHS. It + includes case of a variable referenced on the left hand side of an + assignment, therefore remove redundant code. Variables and prefixes of + indexed or selected components are now marked as referenced on left + hand side. Warnings are now properly emitted when variables or prefixes + are assigned but not read. + + * sem_warn.adb (Output_Unreferenced_Messages): Add additional checks to + left hand side referenced variables. Private access types do not + produce the warning "variable ... is assigned but never read". + Add also additional checks to left hand side referenced variables. + Aliased, renamed objects and access types do not produce the warning + "variable ... is assigned but never read" since other entities may read + the memory location. + +2004-06-07 Jerome Guitton + + * Makefile.in: In the powerpc/vxworks-specific section, restore + EXTRA_GNATRTL_NONTASKING_OBJS and EXTRA_GNATRTL_TASKING_OBJS (removed + by mistake). + +2004-06-07 Ed Schonberg + + * sem_ch4.adb (Remove_Abstract_Operations): Refine the removal of + predefined operators. + Removes spurious type errors from g-trasym-vms.adb. + + * sem_res.adb (Rewrite_Renamed_Operator): If intrinsic operator is + distinct from the operator appearing in the source, call appropriate + routine to insert conversions when needed, and complete resolution of + node. + (Resolve_Intrinsic_Operator): Fix cut-and-paste bug on transfer of + interpretations for rewritten right operand. + (Set_Mixed_Mode_Operand): Handle properly a universal real operand when + the other operand is overloaded and the context is a type conversion. + +2004-06-07 Richard Kenner + + * ada-tree.def (BLOCK_STMT): Now has two operands. + (BREAK_STMT): New. + + * ada-tree.h: (BLOCK_STMT_BLOCK): New macro. + + * gigi.h: (gnat_poplevel): Now returns a tree. + + * trans.c (end_block_stmt): Add arg; all callers changed. + (tree_transform, case N_Case_Statement): Make a BLOCK_STMT for a WHEN. + (start_block_stmt): Clear BLOCK_STMT_BLOCK. + (add_stmt): Set TREE_TYPE. + (gnat_expand_stmt, case BLOCK_STMT): Handle BLOCK_STMT_BLOCK. + (gnat_expand_stmt, case BREAK_STMT): New case. + + * utils.c (gnat_poplevel): Return a BLOCK, if we made one. + +2004-06-07 Jose Ruiz + + * s-stchop.adsm s-stchop.adb, s-stchop-vxworks.adb: Remove the + procedure Set_Stack_Size that is not needed. + +2004-06-07 Sergey Rybin + + * gnat_ugn.texi: Clarify the case when non-standard naming scheme is + used for gnatpp input file and for the files upon which it depends + +2004-06-07 Ben Brosgol + + * gnat_ugn.texi: Wordsmithing of "GNAT and Libraries" chapter + +2004-06-07 Arnaud Charlet + + * gnatvsn.ads: Bump version numbers appropriately. + Add new build type. + +2004-06-07 Pascal Obry + + * gnat_ugn.texi: Improve comments about imported names and link names + on Windows. Add a note about the requirement to use -k gnatdll's option + when working with a DLL which has stripped stdcall symbols (no @nn + suffix). + +2004-05-27 Vincent Celier + + * vms_data.ads: Add new GNAT PRETTY qualifiers /NO_BACKUP and + COMMENTS_LAYOUT=UNTOUCHED + + * symbols-vms.adb, symbols-vms-alpha.adb: Renamed symbols-vms.adb to + symbols-vms-alpha.adb + +2004-05-27 Thomas Quinot + + * sem.ads: Clarify documentation on checks suppression. + + * einfo.ads (Is_Known_Non_Null): Minor comment typo fix and rephrasing. + +2004-05-27 Ed Schonberg + + * sem_util.adb (Is_Descendent_Of): Examine properly all ancestors in + the case of multiple derivations. + (Is_Object_Reference): For a selected component, verify that the prefix + is itself an object and not a value. + + * sem_ch12.adb (Same_Instantiated_Constant): New name for + Same_Instantiated_Entity. + (Same_Instantiated_Variable): Subsidiary to + Check_Formal_Package_Instance, to recognize actuals for in-out generic + formals that are obtained from a previous formal package. + (Instantiate_Subprogram_Body): Emit proper error when + generating code and the proper body of a stub is missing. + + * sem_ch4.adb (Remove_Address_Interpretations): If the operation still + has a universal interpretation, do the disambiguation here. + + * exp_ch4.adb (Expand_N_Type_Conversion, + Expand_N_Unchecked_Type_Conversion): Special handling when target type + is Address, to avoid typing anomalies when Address is a visible integer + type. + + * exp_ch6.adb (Expand_N_Subprogram_Body): Use Is_Descendent_Of_Address + to determine whether a subprogram should not be marked Pure, even when + declared in a pure package. + +2004-05-27 Jose Ruiz + + * gnat_ugn.texi: Replace pragma Ravenscar by pragma Profile. + + * gnat_rm.texi: Replace Max_Entry_Queue_Depth by Max_Entry_Queue_Length + Document No_Dynamic_Attachment, that supersedes No_Dynamic_Interrupts. + Update the documentation about the Ravenscar profile, following the + definition found in AI-249. + + * sem_prag.adb: Use FIFO_Within_Priorities and Ceiling_Locking when + setting the Profile (Ravenscar). This must be done in addition to + setting the required restrictions. + + * rtsfind.ads: Add the set of operations defined in package + Ada.Interrupts. + + * exp_ch6.adb: Check whether we are violating the No_Dynamic_Attachment + restriction. + +2004-05-27 Eric Botcazou + + lang-specs.h: Always require -c or -S and always redirect to /dev/null + if -gnatc or -gnats is passed. + +2004-05-27 Hristian Kirtchev + + * sem_prag.adb (Sig_Flags): A Pragma_Unchecked_Union does not count as + a significant reference. Warnings are now properly emitted when a + discriminated type is not referenced. + + * lib-xref.adb (Generate_Reference): A deferred constant completion, + record representation clause or record type discriminant does not + produce a reference to its corresponding entity. Warnings are now + properly emitted when deferred constants and record types are not + referenced. + +2004-05-27 Geert Bosch + + * Makefile.in: Use long version of libm routines on ia64 gnu/linux. + Fixes ACATS Annex G tests. + +2004-05-27 Robert Dewar + + * rtsfind.adb (RTU_Loaded): Temporary kludge to get past bug of not + handling WITH + +2004-05-27 Arnaud Charlet + + * s-interr.adb (Server_Task): Take into account case of early return + from sigwait under e.g. linux. + +2004-05-27 Sergey Rybin + + * gnat_ugn.texi: Add description for the new gnatpp options: + -rnb - replace the original source without creating its backup copy + -c0 - do not format comments + +2004-05-24 Geert Bosch + + * a-numaux-x86.adb (Reduce): Reimplement using an approximation of Pi + with 192 bits of precision, sufficient to reduce a double-extended + arguments X with a maximum relative error of T'Machine_Epsilon, for X + in -2.0**32 .. 2.0**32. + (Cos, Sin): Always reduce arguments of 1/4 Pi or larger, to prevent + reduction by the processor, which only uses a 68-bit approximation of + Pi. + (Tan): Always reduce arguments and compute function either using + the processor's fptan instruction, or by dividing sin and cos as needed. + +2004-05-24 Doug Rupp + + * adaint.c (__gnat_readdir): Cast CRTL function retun value to avoid + gcc error on 32/64 bit VMS. + +2004-05-24 Olivier Hainque + + * init.c (__gnat_error_handler): Handle EEXIST as EACCES for SIGSEGVs, + since this is what we get for stack overflows although not documented + as such. + Document the issues which may require adjustments to our signal + handlers. + +2004-05-24 Ed Schonberg + + * inline.adb (Add_Scope_To_Clean): Do not add cleanup actions to the + enclosing dynamic scope if the instantiation is within a generic unit. + +2004-05-24 Arnaud Charlet + + * exp_dbug.ads: Fix typo. + + * Makefile.in: s-osinte-linux-ia64.ads was misnamed. + Rename it to its proper name: system-linux-ia64.ads + (stamp-gnatlib1): Remove extra target specific run time files when + setting up the rts directory. + +2004-05-24 Javier Miranda + + * einfo.ads, einfo.adb (Limited_Views): Removed. + (Limited_View): New attribute that replaces the previous one. It is + now a bona fide package with the limited-view list through the + first_entity and first_private attributes. + + * sem_ch10.adb (Install_Private_With_Clauses): Give support to + limited-private-with clause. + (Install_Limited_Withed_Unit): Install the private declarations of a + limited-private-withed package. Update the installation of the shadow + entities according to the new structure (see Build_Limited_Views) + (Build_Limited_Views): Replace the previous implementation of the + limited view by a package entity that references the first shadow + entity plus the first shadow private entity (required for limited- + private-with clause) + (New_Internal_Shadow_Entity): Code cleanup. + (Remove_Limited_With_Clause): Update the implementation to undo the + new work carried out by Build_Limited_Views. + (Build_Chain): Complete documentation. + Replace Ada0Y by Ada 0Y in comments + Minor reformating + + * sem_ch3.adb (Array_Type_Declaration): In case of anonymous access + types the level of accessibility depends on the enclosing type + declaration. + + * sem_ch8.adb (Find_Expanded_Name): Fix condition to detect shadow + entities. Complete documentation of previous change. + +2004-05-24 Robert Dewar + + * namet.adb: Minor reformatting + Avoid use of name I (replace by J) + Minor code restructuring + + * sem_ch6.adb: Minor reformatting + + * lib-writ.adb: Do not set restriction as active if this is a + Restriction_Warning case. + + * sem_prag.adb: Reset restriction warning flag if real pragma + restriction encountered. + + * s-htable.adb: Minor reformatting + Change rotate count to 3 in Hash (improves hash for small strings) + + * 5qsystem.ads: Add comments for type Address (no literals allowed). + + * gnat_ugn.texi: Add new section of documentation "Code Generation + Control", which describes the use of -m switches. + +2004-05-24 Eric Botcazou + + trans.c (tree_transform) : Do the dereference directly + through the DECL_INITIAL for renamed variables. + +2004-05-24 Arnaud Charlet + + * s-osinte-linux-ia64.ads: Renamed system-linux-ia64.ads + +2004-05-19 Joel Brobecker + + * exp_dbug.ads: Correct comments concerning handling of overloading, + since we no longer use $ anymore. + +2004-05-19 Sergey Rybin + + * sem_ch10.adb (Optional_Subunit): When loading a subunit, do not + ignore errors if ASIS_Mode is set. This prevents creating ASIS trees + with illegal subunits. + +2004-05-19 Ed Schonberg + + * sem_ch6.adb (Check_Following_Pragma): When compiling a subprogram + body with front-end inlining enabled, check whether an inline pragma + appears immediately after the body and applies to it. + + * sem_prag.adb (Cannot_Inline): Emit warning if front-end inlining is + enabled and the pragma appears after the body of the subprogram. + +2004-05-17 Richard Kenner + + Part of function-at-a-time conversion + + * misc.c (adjust_decl_rtl): Deleted. + (LANG_HOOKS_PUSHLEVEL, LANG_HOOKS_POPLEVEL, LANG_HOOKS_SET_BLOCK): + Define. + + * gigi.h: (adjust_decl_rtl, kept_level_p, set_block): Deleted. + (add_decl_stmt, add_stmt, block_has_vars): New functions. + (gnat_pushlevel, gnat_poplevel): Renamed from pushlevel and poplevel. + + * decl.c (elaborate_expression, maybe_pad_type): Call add_decl_stmt + when making a decl. + (gnat_to_gnu_entity): Likewise. + Use add_stmt to update setjmp buffer. + Set TREE_ADDRESSABLE instead of calling put_var_into_stack and + flush_addressof. + No longer call adjust_decl_rtl. + (DECL_INIT_BY_ASSIGN_P): New macro. + (DECL_STMT_VAR): Likewise. + + * trans.c (gigi): Call start_block_stmt to make the outermost + BLOCK_STMT. + (gnat_to_code, gnu_to_gnu, tree_transform, process_decls, process_type): + Call start_block_stmt and end_block_stmt temporarily. + Use gnat_expand_stmt instead of expand_expr_stmt. + (add_decl_stmt): New function. + (tree_transform): Call it. + (add_stmt): Also emit initializing assignment for DECL_STMT if needed. + (end_block_stmt): Set type and NULL_STMT. + (gnat_expand_stmt): Make recursize call instead of calling + expand_expr_stmt. + (gnat_expand_stmt, case DECL_STMT): New case. + (set_lineno_from_sloc): Do nothing if global. + (gnu_block_stmt_node, gnu_block_stmt_free_list): New variables. + (start_block_stmt, add_stmt, end_block_stmt): New functions. + (build_block_stmt): Call them. + (gnat_to_code): Don't expand NULL_STMT. + (build_unit_elab): Rename pushlevel and poplevel to gnat_* and change + args. + (tree_transform): Likewise. + (tree_transform, case N_Null_Statement): Return NULL_STMT. + (gnat_expand_stmt, case NULL_STMT): New case. + (gnat_expand_stmt, case IF_STMT): Allow nested IF_STMT to have no + IF_STMT_TRUE. + + * utils2.c (gnat_mark_addressable, case VAR_DECL): Do not set + TREE_ADDRESSABLE. + + * utils.c (create_var_decl): Do not call expand_decl or + expand_decl_init. + Set TREE_ADDRESSABLE instead of calling gnat_mark_addressable. + Set DECL_INIT_BY_ASSIGN_P when needed and do not generate MODIFY_EXPR + here. + (struct e_stack): Add chain_next to GTY. + (struct binding_level): Deleted. + (struct ada_binding_level): New struct. + (free_block_chain): New. + (global_binding_level, clear_binding_level): Deleted. + (global_bindings_p): Rework to see if no chain. + (kept_level_p, set_block): Deleted. + (gnat_pushlevel): Renamed from pushlevel and extensive reworked to use + new data structure and work directly on BLOCK node. + (gnat_poplevel): Similarly. + (get_decls): Look at BLOCK_VARS. + (insert_block): Work directly on BLOCK node. + (block_has_var): New function. + (pushdecl): Rework for new binding structures. + (gnat_init_decl_processing): Rename and rework calls to pushlevel and + poplevel. + (build_subprog_body): Likewise. + (end_subprog_body): Likewise; also set up BLOCK in DECL_INITIAL. + + * ada-tree.def (DECL_STMT, NULL_STMT): New codes. + + * ada-tree.h: (DECL_INIT_BY_ASSIGN_P): New macro. + (DECL_STMT_VAR): Likewise. + +2004-05-17 Robert Dewar + + * restrict.ads, restrict.adb (Process_Restriction_Synonym): New + procedure + + * sem_prag.adb (Analyze_Pragma, case Restrictions): Cleanup handling + of restriction synonyums by using + Restrict.Process_Restriction_Synonyms. + + * snames.ads, snames.adb: Add entries for Process_Restriction_Synonym + + * s-restri.ads (Tasking_Allowed): Correct missing comment + + * s-rident.ads: Add entries for restriction synonyms + + * ali.adb: Fix some problems with badly formatted ALI files that can + result in infinite loops. + + * s-taprop-lynxos.adb, s-tpopsp-lynxos.adb, s-taprop-tru64.adb, + s-tpopsp-posix-foreign.adb, s-taprop-irix.adb, s-interr-sigaction.adb, + s-taprop-irix-athread.adb, s-taprop-hpux-dce.adb, s-taprop-linux.adb, + s-taprop-dummy.adb, s-interr-dummy.adb, s-taprop-os2.adb, + s-taprop-solaris.adb, s-tpopsp-solaris.adb, s-asthan-vms.adb, + s-inmaop-vms.adb, s-interr-vms.adb, s-taprop-vms.adb, + s-tpopde-vms.adb, s-taprop-mingw.adb, s-interr-vxworks.adb, + s-taprop-vxworks.adb, s-tpopsp-vxworks.adb, s-taprop-posix.adb, + s-tpopsp-posix.adb, s-tratas-default.adb, a-dynpri.adb, + a-tasatt.adb, a-taside.adb, a-taside.ads, exp_attr.adb, + exp_ch9.adb, g-thread.adb, rtsfind.ads, sem_attr.adb, + s-interr.adb, s-interr.ads, s-soflin.ads, s-taasde.adb, + s-taasde.ads, s-taenca.adb, s-taenca.ads, s-taprop.ads, + s-tarest.adb, s-tarest.ads, s-tasdeb.adb, s-tasdeb.ads, + s-tasini.adb, s-tasini.ads, s-taskin.adb, s-taskin.ads, + s-tasque.adb, s-tasque.ads, s-tasren.adb, s-tasren.ads, + s-tassta.adb, s-tassta.ads, s-tasuti.adb, s-tasuti.ads, + s-tataat.adb, s-tataat.ads, s-tpinop.adb, s-tpinop.ads, + s-tpoben.adb, s-tpobop.adb, s-tpobop.ads, s-tporft.adb, + s-tposen.adb, s-tposen.ads, s-tratas.adb, s-tratas.ads: Change Task_ID + to Task_Id (minor cleanup). + +2004-05-17 Vincent Celier + + * g-os_lib.adb (Normalize_Pathname.Final_Value): Remove trailing + directory separator. + + * prj-proc.adb (Recursive_Process): Inherit attribute Languages from + project being extended, if Languages is not declared in extending + project. + +2004-05-17 Javier Miranda + + * sem_ch10.adb (Install_Limited_Withed_Unit): Do not install the + limited view of a visible sibling. + +2004-05-14 Robert Dewar + + * gnat_ugn.texi: Minor change to -gnatS documentation + + * sprint.adb: Remove some instances of Assert (False) and for this + purpose replace them by output of a ??? string. + + * checks.adb, exp_aggr.adb, sem_elim.adb: Remove useless pragma + Assert (False). + + * lib-writ.adb, lib-load.adb, lib.ads, lib.adb: Remove Dependent_Unit + flag processing. This was suppressing required dependencies in + No_Run_Time mode and is not needed since the binder does not generate + references for things in libgnat anyway. + + * sem_ch3.adb (Access_Type_Declaration): Reorganize code to avoid GCC + warning. + +2004-05-14 Thomas Quinot + + * gnat_ugn.texi: Document AIX-specific issue with initialization of + resolver library. + + * exp_ch4.adb (Insert_Dereference_Action): Do not generate dereference + action for the case of an actual parameter in an init proc call. + +2004-05-14 Ed Schonberg + + * sem_ch4.adb (Analyze_Selected_Component): If prefix is a protected + subtype, check visible entities in base type. + + * exp_ch7.adb (Clean_Simple_Protected_Objects): Do not generate cleanup + actions if the object is a renaming. + + * sem_ch12.adb (Same_Instantiated_Entity): Predicate for + Check_Formal_Package_Instance, to determine more precisely when the + formal and the actual denote the same entity. + +2004-05-14 Javier Miranda + + * par-ch10.adb (P_Context_Clause): Complete documentation on AI-262 + + * sem_ch10.adb (Analyze_With_Clause): After analyzed, the entity + corresponding to a private_with must be removed from visibility; it + will be made visible later, just before we analyze the private part of + the package. + (Check_Private_Child_Unit): Allow private_with clauses in public + siblings. + (Install_Siblings): Make visible the private entities of private-withed + siblings. + (Install_Withed_Unit): Do not install the private withed unit if we + are compiling a package declaration and the Private_With_OK flag was + not set by the caller. These declarations will be installed later, + just before we analyze the private part of the package. + + * sem_ch3.adb (Analyze_Object_Declaration): In case of errors detected + during the evaluation of the expression that initializes the object, + decorate it with the expected type to avoid cascade errors. + Code cleanup. + + * sem_ch6.adb (Analyze_Subprogram_Body): If we are compiling a library + subprogram we have to install the private_with clauses after its + specification has been analyzed (as documented in AI-262.TXT). + + * sem_ch8.adb (Has_Private_With): New function. Determines if the + current compilation unit has a private with on a given entity. + (Find_Direct_Name): Detect the Beaujolais problem described in + AI-262.TXT + + * sem_utils.ads, sem_util.adb (Is_Ancestor_Package): New function. It + provides the functionality of the function Is_Ancestor that was + previously available in sem_ch10. It has been renamed to avoid + overloading. + + * sprint.adb (Sprint_Node_Actual): Print limited_with clauses + +2004-05-14 Richard Kenner + + * utils.c (build_vms_descriptor): Use SImode pointers. + +2004-05-14 Vasiliy Fofanov + + * gnat_ugn.texi: Revised chapter "GNAT and Libraries". + +2004-05-14 GNAT Script + + * Make-lang.in: Makefile automatically updated + +2004-05-14 Arnaud Charlet + + Renaming of target specific files for clarity + + * Makefile.in: Rename GNAT target specific files. + + * 31soccon.ads, 31soliop.ads 35soccon.ads, 3asoccon.ads, + 3bsoccon.ads, 3gsoccon.ads, 3hsoccon.ads, 3psoccon.ads, + 3ssoccon.ads, 3ssoliop.ads, 3veacodu.adb, 3vexpect.adb, + 3vsoccon.ads, 3vsocthi.adb, 3vsocthi.ads, 3vtrasym.adb, + 3wsoccon.ads, 3wsocthi.adb, 3wsocthi.ads, 3wsoliop.ads, + 3zsoccon.ads, 3zsocthi.adb, 3zsocthi.ads, 41intnam.ads, + 42intnam.ads, 45intnam.ads, 4aintnam.ads, 4cintnam.ads, + 4gintnam.ads, 4hexcpol.adb, 4hintnam.ads, 4lintnam.ads, + 4nintnam.ads, 4ointnam.ads, 4onumaux.ads, 4pintnam.ads, + 4sintnam.ads, 4vcaldel.adb, 4vcalend.adb, 4vcalend.ads, + 4vintnam.ads, 4wcalend.adb, 4wexcpol.adb, 4wintnam.ads, + 4zintnam.ads, 4znumaux.ads, 4zsytaco.adb, 4zsytaco.ads, + 51osinte.adb, 51osinte.ads, 51system.ads, + 52osinte.adb, 52osinte.ads, 53osinte.ads, 54osinte.ads, + 55osinte.adb, 55osinte.ads, 55system.ads, 56osinte.adb, + 56osinte.ads, 56system.ads, 56taprop.adb, 56taspri.ads, + 56tpopsp.adb, 57system.ads, 58system.ads, + 5amastop.adb, 5aml-tgt.adb, 5aosinte.adb, 5aosinte.ads, + 5asystem.ads, 5ataprop.adb, 5atasinf.ads, 5ataspri.ads, + 5atpopsp.adb, 5avxwork.ads, 5bml-tgt.adb, 5bosinte.adb, + 5bosinte.ads, 5bsystem.ads, 5cosinte.ads, 5csystem.ads, + 5dsystem.ads, 5esystem.ads, 5fintman.adb, 5fosinte.adb, + 5fosinte.ads, 5fsystem.ads, 5ftaprop.adb, 5ftasinf.ads, + 5ginterr.adb, 5gintman.adb, 5gmastop.adb, 5gml-tgt.adb, + 5gosinte.ads, 5gproinf.adb, 5gproinf.ads, 5gsystem.ads, + 5gtaprop.adb, 5gtasinf.adb, 5gtasinf.ads, 5gtpgetc.adb, + 5hml-tgt.adb, 5hosinte.adb, 5hosinte.ads, 5hparame.ads, + 5hsystem.ads, 5htaprop.adb, 5htaspri.ads, 5htraceb.adb, + 5iosinte.adb, 5iosinte.ads, 5itaprop.adb, 5itaspri.ads, + 5ksystem.ads, 5kvxwork.ads, 5lml-tgt.adb, 5losinte.ads, + 5lparame.adb, 5lsystem.ads, 5msystem.ads, 5mvxwork.ads, + 5ninmaop.adb, 5nintman.adb, 5nosinte.ads, 5nsystem.ads, + 5ntaprop.adb, 5ntaspri.ads, 5ointerr.adb, 5omastop.adb, + 5oosinte.adb, 5oosinte.ads, 5oosprim.adb, 5oparame.adb, + 5osystem.ads, 5otaprop.adb, 5otaspri.ads, 5posinte.ads, + 5posprim.adb, 5psystem.ads, 5pvxwork.ads, 5sintman.adb, + 5sml-tgt.adb, 5sosinte.adb, 5sosinte.ads, 5sosprim.adb, + 5sparame.adb, 5ssystem.ads, 5staprop.adb, 5stasinf.adb, + 5stasinf.ads, 5staspri.ads, 5stpopsp.adb, 5svxwork.ads, + 5tosinte.ads, 5usystem.ads, 5vasthan.adb, 5vdirval.adb, + 5vinmaop.adb, 5vinterr.adb, 5vintman.adb, 5vintman.ads, + 5vmastop.adb, 5vml-tgt.adb, 5vosinte.adb, 5vosinte.ads, + 5vosprim.adb, 5vosprim.ads, 5vparame.ads, 5vsymbol.adb, + 5vsystem.ads, 5vtaprop.adb, 5vtaspri.ads, 5vtpopde.adb, + 5vtpopde.ads, 5vtraent.adb, 5vtraent.ads, 5vvaflop.adb, + 5wdirval.adb, 5wgloloc.adb, 5wintman.adb, 5wmemory.adb, + 5wml-tgt.adb, 5wosinte.ads, 5wosprim.adb, 5wsystem.ads, + 5wtaprop.adb, 5wtaspri.ads, 5xparame.ads, 5xsystem.ads, + 5xvxwork.ads, 5yparame.ads, 5ysystem.ads, 5zinterr.adb, + 5zintman.adb, 5zintman.ads, 5zml-tgt.adb, 5zosinte.adb, + 5zosinte.ads, 5zosprim.adb, 5zparame.ads, 5zstchop.adb, + 5zsystem.ads, 5ztaprop.adb, 5ztaspri.ads, 5ztfsetr.adb, + 5ztpopsp.adb, 6vcpp.adb, 6vcstrea.adb, 6vinterf.ads, + 7sinmaop.adb, 7sintman.adb, 7sosinte.adb, 7sosprim.adb, + 7staprop.adb, 7staspri.ads, 7stfsetr.adb, 7stpopsp.adb, + 7straceb.adb, 7straces.adb, 7strafor.adb, 7strafor.ads, + 7stratas.adb, 86numaux.adb, 86numaux.ads: Replaced by files below. + + * a-caldel-vms.adb, a-calend-mingw.adb, a-calend-vms.adb, + a-calend-vms.ads, a-dirval-mingw.adb, a-dirval-vms.adb, + a-excpol-abort.adb, a-excpol-interix.adb, a-intnam-aix.ads, + a-intnam-dummy.ads, a-intnam-freebsd.ads, a-intnam-hpux.ads, + a-intnam-interix.ads, a-intnam-irix.ads, a-intnam-linux.ads, + a-intnam-lynxos.ads, a-intnam-mingw.ads, a-intnam-os2.ads, + a-intnam-solaris.ads, a-intnam-tru64.ads, a-intnam-unixware.ads, + a-intnam-vms.ads, a-intnam-vxworks.ads, a-numaux-libc-x86.ads, + a-numaux-vxworks.ads, a-numaux-x86.adb, a-numaux-x86.ads, + a-sytaco-vxworks.adb, a-sytaco-vxworks.ads, g-eacodu-vms.adb, + g-expect-vms.adb, g-soccon-aix.ads, g-soccon-freebsd.ads, + g-soccon-hpux.ads, g-soccon-interix.ads, g-soccon-irix.ads, + g-soccon-mingw.ads, g-soccon-solaris.ads, g-soccon-tru64.ads, + g-soccon-unixware.ads, g-soccon-vms.adb, g-soccon-vxworks.ads, + g-socthi-mingw.adb, g-socthi-mingw.ads, g-socthi-vms.adb, + g-socthi-vms.ads, g-socthi-vxworks.adb, g-socthi-vxworks.ads, + g-soliop-mingw.ads, g-soliop-solaris.ads, g-soliop-unixware.ads, + g-trasym-vms.adb, i-cpp-vms.adb, i-cstrea-vms.adb, + interfac-vms.ads, mlib-tgt-aix.adb, mlib-tgt-hpux.adb, + mlib-tgt-irix.adb, mlib-tgt-linux.adb, mlib-tgt-mingw.adb, + mlib-tgt-solaris.adb, mlib-tgt-tru64.adb, mlib-tgt-vms.adb, + mlib-tgt-vxworks.adb, s-asthan-vms.adb, s-gloloc-mingw.adb, + s-inmaop-dummy.adb, s-inmaop-posix.adb, s-inmaop-vms.adb, + s-interr-dummy.adb, s-interr-sigaction.adb, s-interr-vms.adb, + s-interr-vxworks.adb, s-intman-dummy.adb, s-intman-irix.adb, + s-intman-irix-athread.adb, s-intman-mingw.adb, s-intman-posix.adb, + s-intman-solaris.adb, s-intman-vms.adb, s-intman-vms.ads, + s-intman-vxworks.adb, s-intman-vxworks.ads, s-mastop-irix.adb, + s-mastop-tru64.adb, s-mastop-vms.adb, s-mastop-x86.adb, + s-memory-mingw.adb, s-osinte-aix.adb, s-osinte-aix.ads, + s-osinte-aix-fsu.ads, s-osinte-dummy.ads, s-osinte-freebsd.adb, + s-osinte-freebsd.ads, s-osinte-fsu.adb, s-osinte-hpux.ads, + s-osinte-hpux-dce.adb, s-osinte-hpux-dce.ads, s-osinte-interix.ads, + s-osinte-irix.adb, s-osinte-irix.ads, s-osinte-irix-athread.ads, + s-osinte-linux.ads, s-osinte-linux-fsu.ads, s-osinte-linux-ia64.ads, + s-osinte-lynxos-3.adb, s-osinte-lynxos-3.ads, s-osinte-lynxos.adb, + s-osinte-lynxos.ads, s-osinte-mingw.ads, s-osinte-os2.adb, + s-osinte-os2.ads, s-osinte-posix.adb, s-osinte-solaris.adb, + s-osinte-solaris.ads, s-osinte-solaris-fsu.ads, + s-osinte-solaris-posix.ads, s-osinte-tru64.adb, s-osinte-tru64.ads, + s-osinte-unixware.adb, s-osinte-unixware.ads, s-osinte-vms.adb, + s-osinte-vms.ads, s-osinte-vxworks.adb, + s-osinte-vxworks.ads, s-osprim-mingw.adb, + s-osprim-os2.adb, s-osprim-posix.adb, s-osprim-solaris.adb, + s-osprim-unix.adb, s-osprim-vms.adb, s-osprim-vms.ads, + s-osprim-vxworks.adb, s-parame-ae653.ads, s-parame-hpux.ads, + s-parame-linux.adb, s-parame-os2.adb, s-parame-solaris.adb, + s-parame-vms.ads, s-parame-vms-restrict.ads, s-parame-vxworks.ads, + s-proinf-irix-athread.adb, s-proinf-irix-athread.ads, + s-stchop-vxworks.adb, s-taprop-dummy.adb, + s-taprop-hpux-dce.adb, s-taprop-irix.adb, + s-taprop-irix-athread.adb, s-taprop-linux.adb, s-taprop-lynxos.adb, + s-taprop-mingw.adb, s-taprop-os2.adb, s-taprop-posix.adb, + s-taprop-solaris.adb, s-taprop-tru64.adb, s-taprop-vms.adb, + s-taprop-vxworks.adb, s-tasinf-irix.ads, s-tasinf-irix-athread.adb, + s-tasinf-irix-athread.ads, s-tasinf-solaris.adb, s-tasinf-solaris.ads, + s-tasinf-tru64.ads, s-taspri-dummy.ads, s-taspri-hpux-dce.ads, + s-taspri-linux.ads, s-taspri-lynxos.ads, s-taspri-mingw.ads, + s-taspri-os2.ads, s-taspri-posix.ads, s-taspri-solaris.ads, + s-taspri-tru64.ads, s-taspri-vms.ads, s-taspri-vxworks.ads, + s-tfsetr-default.adb, s-tfsetr-vxworks.adb, s-tpopde-vms.adb, + s-tpopde-vms.ads, s-tpopsp-lynxos.adb, s-tpopsp-posix.adb, + s-tpopsp-posix-foreign.adb, s-tpopsp-solaris.adb, s-tpopsp-vxworks.adb, + s-traceb-hpux.adb, s-traceb-mastop.adb, s-traces-default.adb, + s-traent-vms.adb, s-traent-vms.ads, s-trafor-default.adb, + s-trafor-default.ads, s-tratas-default.adb, s-vaflop-vms.adb, + s-vxwork-alpha.ads, s-vxwork-m68k.ads, s-vxwork-mips.ads, + s-vxwork-ppc.ads, s-vxwork-sparcv9.ads, s-vxwork-xscale.ads, + symbols-vms.adb, system-aix.ads, system-freebsd-x86.ads, + system-hpux.ads, system-interix.ads, system-irix-n32.ads, + system-irix-o32.ads, system-linux-x86_64.ads, + system-linux-x86.ads, system-lynxos-ppc.ads, system-lynxos-x86.ads, + system-mingw.ads, system-os2.ads, system-solaris-sparc.ads, + system-solaris-sparcv9.ads, system-solaris-x86.ads, system-tru64.ads, + system-unixware.ads, system-vms.ads, system-vms-zcx.ads, + system-vxworks-alpha.ads, system-vxworks-m68k.ads, + system-vxworks-mips.ads, system-vxworks-ppc.ads, + system-vxworks-sparcv9.ads, system-vxworks-xscale.ads: Replace files + above. + +2004-05-13 Zack Weinberg + + * trans.c (gnat_stabilize_reference_1): Remove case 'b'. + +2004-05-13 Diego Novillo + + Merge from tree-ssa-20020619-branch. + + * config-lang.in (boot_language, build_by_default): Set + to no. + * utils.c (unchecked_convert): Use OEP_ONLY_CONST. + (max_size): Add static chain op for call_expr. + +2004-05-12 Richard Sandiford + + PR target/15331 + * 5gmastop.adb (Roff): Choose between '4' and '0', not '4' and ' '. + +2004-05-11 Roger Sayle + + * utils.c (max_size): Use MIN_EXPR to find the minimum value of a + COND_EXPR. + +2004-05-10 Doug Rupp + + * 5qsystem.ads: Remove Short_Address subtype declaration. Moved to + system.aux_dec. + + * s-auxdec.ads: Add Short_Address subtype (moved here from System). + + * Makefile.in: [VMS]: Add translation for 5qauxdec.ads. + + * init.c: [VMS] Macroize LIB$ calls for IA64 and Alpha. + Fixes undefined symbols in IA64 gnatlib. + + * 5vinmaop.adb: Reference s-auxdec for Short_Address. + + * 5xsystem.ads, 5vsystem.ads: Back out last change (addition of subtype + Short_Address). This will be moved to system.auxdec. + +2004-05-10 Thomas Quinot + + * sem_util.adb: Replace test for presence of a node that is always + present with a call to Discard_Node. + + * sem_ch10.adb (Analyze_Compilation_Unit): Remove superfluous call to + Analyze on the library unit node after generation of distribution stub + constructs. The call was a no-op because Unit_Node has already been + Analyzed, and the tree fragments for the distribution stubs are + analyzed as they are inserted in Exp_Dist. + Update comment regarding to distribution stubs to reflect that we + do not generate stub in separate files anymore. + + * einfo.ads: Clarify the fact that a tagged private type has the + E_Record_Type_With_Private Ekind. + + * erroutc.adb: Minor reformatting + + * erroutc.ads (Max_Msg_Length): Increase to cover possible larger + values if line length is increased using -gnatyM (noticed during code + reading). + + * eval_fat.adb: Minor reformatting + Put spaces around exponentiation operator + +2004-05-10 Ed Schonberg + + PR ada/15005 + * sem_util.adb (Is_Dependent_Component_Of_Mutable_Object): If prefix + has been rewritten as an explicit dereference, retrieve type of + original node to check for possibly unconstrained record type. + +2004-05-10 Ed Schonberg + + * exp_ch7.adb (Check_Visibly_Controlled): If given operation is not + overriding, use the operation of the parent unconditionally. + + * sem_ch4.adb (Remove_Address_Interpretations): Remove address + operation when either operand is a literal, to avoid further + ambiguities. + + * sem_ch6.adb (New_Overloaded_Entity): If new entity is inherited and + overridden by a previous explicit declaration, mark the previous entity + as overriding. + + * sem_disp.adb (Check_Dispatching_Operation): New predicate + Is_Visibly_Controlled, to determine whether a declaration of a + primitive control operation for a derived type overrides an inherited + one. Add warning if the explicit declaration does not override. + +2004-05-10 Vincent Celier + + * gnatls.adb (Gnatls): Initialize Snames, to avoid assertion error in + some cases when the sources are no longer present. + + * make.adb (Collect_Arguments): Fail if an external source, not part + of any project need to be compiled, when switch -x has not been + specified. + + * makeusg.adb: Document new switch -x + + * opt.ads (External_Unit_Compilation_Allowed): New Boolean flag, + defaulted to False. + + * switch-m.adb (Scan_Make_Switches): New switch -x + + * vms_data.ads: Add VMS qualifier /NON_PROJECT_UNIT_COMPILATION for + gnatmake switch -x. + + * gnat_ugn.texi: Document new gnatmake switch -x + +2004-05-10 Eric Botcazou + + * misc.c (gnat_init_options): Set flag_zero_initialized_in_bss to 0. + + * utils.c (create_var_decl): Do not modify the DECL_COMMON flag. + (process_attributes): Likewise. + +2004-05-10 Joel Brobecker + + * s-inmaop.ads: Fix spelling mistake in one of the comments. + +2004-05-10 Robert Dewar + + * gnat_ugn.texi: Document that for config pragma files, the maximum + line length is always 32767. + + * gnat_rm.texi: For pragma Eliminate, note that concatenation of string + literals is now allowed. + + * gnat-style.texi: Remove statement about splitting long lines before + an operator rather than after, since we do not follow this rule at all. + Clarify rule (really lack of rule) for spaces around exponentiation + + * sem_elim.adb: Allow concatenation of string literals as well as a + single string literal for pragma arguments. + + * sem_prag.ads, sem_prag.adb: (Is_Config_Static_String): New function + + * a-textio.adb (Terminate_Line): Do not add line feed if nothing + written for append case. + + * frontend.adb: Changes to avoid checking max line length in config + pragma files. + + * g-os_lib.ads: Minor reformatting + + * mlib-utl.adb: Do not define Max_Line_Length locally (definition was + wrong in any case. Instead use standard value. Noticed during code + reading. + + * opt.ads (Max_Line_Length): New field, used to implement removal of + limitation on length of lines when scanning config pragma files. + + * osint.ads, prj-dect.adb, prj-strt.adb, prj-tree.adb, + makeutl.ads, makeutl.adb: Minor reformatting + + * scn.adb: Do not check line length while scanning config pragma files + Do not check line length while scanning out license information + + * scng.adb: Changes to avoid line length checks while parsing config + pragma files. + +2004-05-10 GNAT Script + + * Make-lang.in: Makefile automatically updated + +2004-05-05 Arnaud Charlet + + * osint.adb (Find_Program_Name): Fix handling of VMS version + number. + +2004-05-05 Emmanuel Briot + + * g-os_lib.ads (Invalid_Time): New constant + + * adaint.h, adaint.c (__gnat_file_time_name, __gnat_file_time_fd): Now + return OS_Time instead of time_t to match what is imported by Ada. + Now return -1 if the file doesn't exist, instead of a random value + +2004-05-05 Robert Dewar + + * usage.adb: Add line for -gnatR?s switch + + * sem_ch13.adb, exp_ch2.adb: Minor reformatting + + * g-regpat.ads, g-regpat.adb: Add documentation on handling of Size + and for Match (Data_First, Data_last) + + * lib-writ.adb (Write_With_Lines): Ensure that correct index number is + written when we are dealing with multi-unit files. + +2004-05-05 Jerome Guitton + + * Makefile.in: Remove unused targets and variables. + +2004-05-05 Vincent Celier + + * switch-m.adb: New gnatmake switch -eI + + * vms_data.ads: Add VMS equivalents of new gnatclean swith -innn and + of new gnatmake switch -eInnn. + + * makegpr.adb: Take into account new parameters Index and Src_Index in + Prj.Util. + + * clean.adb: Implement support for multi-unit sources, including new + switch -i. + + * gnatcmd.adb (GNATCmd): Call Prj.Util.Value_Of with new parameter + Src_Index. + + * make.ads, make.adb (Insert_Q): New parameter Index, defaulted to 0 + (Extract_From_Q): New out parameter Index + (Mark, Is_Marked): Subprograms moved to Makeutl + (Switches_Of): New parameter Source_Index + (Add_Switch): New parameter Index + (Check): New parameter Source_Index + (Collect_Arguments): New parameter Source_Index + (Collect_Arguments_And_Compile): New parameter Source_Index + (Compile): New parameter Source_Index + Put subprograms in alphabetical order + Add support for multi-source sources, including in project files. + + * makeutl.ads, makeutl.adb (Unit_Index_Of): New function + (Mark, Is_Marked, Delete_All_Marks): New subprograms, moved from + Make. + + * makeusg.adb: New gnatmake switch -eInnn + + * mlib-prj.adb (Build_Library): Add new parameter Src_Index to call to + Prj.Util.Value_Of. + + * opt.ads (Main_Index): New variable, defaulted to 0. + + * osint.ads, osinte.adb (Add_File): New parameter Index + (Current_Source_Index): New function + + * prj.adb: Take into account new components Index and Src_Index + + * prj.ads (String_Element): New component Index + (Variable_Value): New component Index + (Array_Element): New component Src_Index + + * prj-attr.adb: Indicate that optional index may be specified for + attributes Main, Executable, Spec, Body and some of Switches. + + * prj-attr.ads (Attribute_Kind): New values for optional indexes + (Attribute_Record): New component Optional_Index + + * prj-com.ads (File_Name_Data): New component Index + + * prj-dect.adb (Parse_Attribute_Declaration): Process optional index + + * prj-env.adb (Put): Output optional index + + * prj-makr.adb: Put indexes for multi-unit sources in SFN pragmas and + attributes Spec and Body. + + * prj-nmsc.adb: Process optional indexes + + * prj-pp.adb: Ouput "at" for optional indexes + + * prj-proc.adb: Take into account optional indexes + + * prj-strt.ads, prj-strt.adb (Terms): New Boolean parameter + Optional_Index. For string literal, + process optional index when Optional_Index is True. + (Parse_Expresion): New Boolean parameter Optional_Index + + * prj-tree.ads, prj-tree.adb (Source_Index_Of): New function + (Set_Source_Index_Of): New procedure + + * prj-util.adb (Executable_Of, Value_Of): Take into account optional + index. + + * prj-util.ads (Executable_Of): New parameter Index + (Value_Of (Name_Id, Array_Element_Id) returning Variable_Value): + New parameter Src_Index, defaulted to 0. + +2004-05-05 Ed Schonberg + + PR ada/15257 + * sem_ch3.adb (Access_Definition): If this is an access parameter + whose designated type is imported through a limited_with clause, do + not add the enclosing subprogram to the list of private dependents of + the type. + +2004-05-05 Ed Schonberg + + PR ada/15258 + * sem_ch6.adb (Base_Types_Match): True if one type is imported through + a limited_with clause, and the other is its non-limited view. + +2004-05-05 Thomas Quinot + + * cstand.adb (Create_Standard): Initialize Stand.Boolean_Literals. + + * exp_attr.adb, exp_ch5.adb, exp_ch9.adb, exp_disp.adb, + exp_fixd.adb, sem_attr.adb, sem_dist.adb, sem_util.adb: Use + Stand.Boolean_Literals to produce references to entities + Standard_False and Standard_True from compile-time computed boolean + values. + + * stand.ads (Boolean_Literals): New variable, provides the entity + values for False and True, for use by the expander. + +2004-05-05 Doug Rupp + + * 5vinmaop.adb, 5[vx]system.ads: Add Short_Address subtype + 5vinmaop.adb: Unchecked convert Short_Address vice Address + + * adaint.c, raise.c: Caste CRTL function return value + to avoid gcc error on 32/64 bit IVMS. + + * Makefile.in [VMS]: Use iar archiver if host = Alpha/VMS and + target = IA64/VMS. + + * init.c[VMS]: Only call Alpha specific __gnat_error_prehandler IN_RTS. + + * 5qsystem.ads (Address): Declare as Long_Integer + (Short_Address): Declare as 32 bit subtype of Address + Declare abstract address operations to avoid gratuitous ambiguities. + +2004-05-05 Jose Ruiz + + * gnat_rm.texi: Use the new restriction Simple_Barriers (AI-249) + instead of the old Boolean_Entry_Barriers. + Ditto for No_Task_Attributes_Package instead of No_Task_Attributes. + +2004-05-05 GNAT Script + + * Make-lang.in: Makefile automatically updated + +2004-05-03 Arnaud Charlet + + * 50system.ads, 59system.ads, s-thread.ads: Removed, no longer used. + +2004-05-03 Olivier Hainque + + PR ada/15152 + * exp_ch2.adb (Expand_Current_Value): Leave Machine_Code Asm arguments + alone. Replacing object references by literals is inappropriate in a + so low level context. + +2004-05-03 Arnaud Charlet + + * a-exexpr.adb: Add comments + +2004-05-03 Joel Brobecker + + * a-tags.adb (Tag_Table): Add Index_Check pragma Suppress. Allows us to + declare the Ancestor_Tags array in Type_Specific_Data with a small size + without risking a bounds check error when accessing one of its + components. + (Type_Specific_Data): Define Ancestor_Tags as a small array. + This prevents us from hitting a limitation during the debug info + generation when using stabs. + + * a-tags.adb (Dispatch_Table): Define the Prims_Ptr component as a + small array. + This prevents us from hitting a limitation during the debug info + generation when using stabs. + +2004-05-03 Eric Botcazou + + lang-specs.h: Remove -gnatz* from specs. + +2004-05-03 Vincent Celier + + * gprmake.adb, makegpr.ads, makegpr.adb: New files. + + * Make-lang.in, Makefile.in: Add gprmake + +2004-05-03 Thomas Quinot + + * sem_aggr.adb: Fix typo in comment. + +2004-05-03 Robert Dewar + + * make.adb: Minor reformatting + + * rtsfind.ads, rtsfind.adb: (RTU_Loaded): New function + + * sem_attr.adb (Eval_Attribute, case Type_Class): Fix check for address + so that it works when address is not a private type. + + * sem_ch13.adb (Check_Expr_Constants, case N_Integer_Literal): Deal + properly with rewritten unchecked conversions. This prevents + order-of-elaboration issues that can otherwise arise. + (Minimum_Size): Don't check size of access types under VMS + + * sem_ch4.adb (Remove_Address_Interpretation): New circuit to remove + interpretations of integer literals as type System.Address. + + * sem_util.ads, sem_util.adb (Is_Descendent_Of_Address): New function + (Is_Descendent_Of): New function + +2004-05-03 Jose Ruiz + + * sem_prag.adb: Boolean_Entry_Barriers is a synonym of Simple_Barriers. + Max_Entry_Queue_Depth is a synonym of Max_Entry_Queue_Length. + No_Dynamic_Interrupts is a synonym of No_Dynamic_Attachment. + + * sem_res.adb: Use the new restriction Max_Entry_Queue_Length instead + of the old Max_Entry_Queue_Depth. + + * snames.adb: Boolean_Entry_Barriers is a synonym of Simple_Barriers. + Max_Entry_Queue_Depth is a synonym of Max_Entry_Queue_Length + No_Dynamic_Interrupts is a synonym of No_Dynamic_Attachment + + * snames.ads: New entry for proper handling of Boolean_Entry_Barriers. + New entry for proper handling of Max_Entry_Queue_Depth. + New entry for proper handling of No_Dynamic_Interrupts. + + * s-rident.ads: Adding restriction Simple_Barriers (AI-00249) that + supersedes the GNAT specific restriction Boolean_Entry_Barriers. + Adding restriction Max_Entry_Queue_Length (AI-00249) that supersedes + the GNAT specific restriction Max_Entry_Queue_Depth. + Adding restriction No_Dynamic_Attachment (AI-00249) that supersedes + the GNAT specific restriction No_Dynamic_Interrupts. + + * restrict.ads, restrict.adb: Use the new restriction Simple_Barriers + instead of the old Boolean_Entry_Barriers. + Use the new restriction No_Dynamic_Attachment instead of the old + No_Dynamic_Interrupts. + + * exp_ch9.adb: Check restriction Simple_Barriers (AI-00249) that + supersedes the GNAT specific restriction Boolean_Entry_Barriers. + + * gnatbind.adb: Use the new restriction Max_Entry_Queue_Length instead + of the old Max_Entry_Queue_Depth. + +2004-05-03 GNAT Script + + * Make-lang.in: Makefile automatically updated + +2004-04-29 Ed Schonberg + + * checks.adb (Enable_Range_Check): If the prefix of an index component + is an access to an unconstrained array, perform check unconditionally. + +2004-04-29 Richard Kenner + + * decl.c (gnat_to_gnu_field): Also call make_packable_type if + Component_Clause. + +2004-04-29 Olivier Hainque + + * init.c (__gnat_install_handler, __gnat_error_handler): Remove + alternate stack setting. There was no support for the tasking cases + and the changes eventually caused a number of side-effect failures in + the non-tasking case too. + +2004-04-29 Eric Botcazou + + lang-specs.h: Redirect output to /dev/null if -gnatc or -gnatz or + -gnats is passed. + +2004-04-29 Vincent Celier + + * make.adb (Gnatmake): Increase max size of argument array for + gnatbind for the potential addition of -F. + If there are Stand-Alone Library projects, invoke gnatbind with -F to + be sure that elaboration flags will be checked. + + * switch-c.adb: Correct call to Scan_Pos for -gnateI + +2004-04-29 Thomas Quinot + + * sem_warn.adb (Check_References): Move ' may be + null' warning out of under Warn_On_No_Value_Assigned. + +2004-04-29 Ed Falis + + * gnat_ugn.texi: Fixed texi error + +2004-04-29 Robert Dewar + + * sem_ch4.adb (Remove_Abstract_Operations): Unconditionally remove + abstract operations if they come from predefined files. + + * gnat_rm.texi: Fix bad doc for pragma Elaboration_Checks (should be + Dynamic, not RM). + + * s-addope.adb: Correct obvious error in mod function + +2004-04-28 Andrew W. Reynolds + + * Makefile.in: Add target pairs for powerpc darwin* + tasking support. + + * a-intnam-darwin.ads, s-osinte-darwin.adb, + s-osinte-darwin.ads, system-darwin-ppc.ads: New files. + +2004-04-28 Ulrich Weigand + + * Makefile.in: Add target macro definitions for s390*-linux*. + * system-linux-s390.ads: New file. + * system-linux-s390x.ads: New file. + +2004-04-28 Joseph S. Myers + + * gnat_ugn.texi: Correct argument to @setfilename. + +2004-04-28 Ulrich Weigand + + * a-exexpr.adb (Unwind_Word): New data type. + (Unwind_Exception): Use it as type of Private1 and Private2. + + * raise.c (db_action_for): Fix debug printf. + +2004-04-27 Ed Schonberg + + * a-wtmoio.ads: Formal type must be a modular type, not a signed + integer type. + +2004-04-27 Richard Kenner + + * decl.c (gnat_to_gnu_entity, case object): Call + __builtin_update_setjmp_buf. + + * gigi.h (update_setjmp_buf): Deleted. + (ADT_update_setjmp_buf_decl, update_setjmp_buf_decl): New. + + * misc.c: (update_setjmp_buf): Deleted. + + * trans.c (gnat_to_gnu): Call do_pending_stack_adjust and emit_queue + around block of RTL. + + * utils.c (init_gigi_decls): Initialize update_setjmp_buf. + +2004-04-26 Thomas Quinot + + * sem_dist.adb, exp_dist.adb: When constructing a RAS value for a local + subprogram for which no pragma All_Calls_Remote applies, store the + address of the real subprogram in the underlying record type, so local + dereferences do not go through the PCS. + +2004-04-26 Robert Dewar + + * i-c.ads: Add some type qualifications to avoid ambiguities when + compiling with s-auxdec.ads and a non-private address type. + +2004-04-26 Arnaud Charlet + + * Makefile.rtl: Fix error in previous check-in: + Add s-addope.o to non tasking object list (rather than tasking object + list). + +2004-04-26 Javier Miranda + + * sem_aggr.adb: Fix typo in comments + (Resolve_Aggr_Expr): Propagate the type to the nested aggregate. + Required to check the null-exclusion attribute. + + * sem_attr.adb (Resolve_Attribute): Check the accessibility level in + case of anonymous access types in record and array components. For a + component definition the level is the same of the enclosing composite + type. + + * sem_ch3.adb (Analyze_Component_Declaration): In case of components + that are anonymous access types the level of accessibility depends on + the enclosing type declaration. In order to have this information, set + the scope of the anonymous access type to the enclosing record type + declaration. + (Array_Type_Declaration): In case of components that are anonymous + access types the level of accessibility depends on the enclosing type + declaration. In order to have this information, set the scope of the + anonymous access type to the enclosing array type declaration. + + * sem_ch3.adb (Array_Type_Declaration): Set the scope of the anonymous + access type. + + * sem_ch8.adb (Analyze_Object_Renaming): Add check to verify that + renaming of anonymous access-to-constant types allowed if and only if + the renamed object is access-to-constant. + + * sem_util.adb (Type_Access_Level): In case of anonymous access types + that are component_definition or discriminants of a nonlimited type, + the level is the same as that of the enclosing component type. + +2004-04-26 Sergey Rybin + + * sem_elim.adb: Some minor code reorganization from code reading. Fix + misprint in the function name (File_Name_Match). + +2004-04-23 Laurent Guerby + + * Makefile.in: Remove RANLIB_TEST, use -$(RANLIB) including after + install. + +2004-04-23 Rainer Orth + + * Make-lang.in (GNATBIND_OBJS): Add s-addope.o. + +2004-04-23 Emmanuel Briot + + * adaint.c (__gnat_try_lock): No longer requires that the parent + directory be writable, the directory itself is enough. + (gnat_is_absolute_path): Change profile, so that the call from + GNAT.OS_Lib can be made more efficient. + + * adaint.h (gnat_is_absolute_path): Change profile, so that the call + from GNAT.OS_Lib can be made more efficient. + + * g-os_lib.adb (Is_Absolute_Path): More efficient implementation, avoid + one copy of the file name. Found by code reading. + +2004-04-23 Vincent Celier + + * gnat_ugn.texi: Add documentation for gnatmake switch -eL + Correct documentation on gnatmake switches transmitted to the compiler + + * ali.ads: Minor comment fix + +2004-04-23 Javier Miranda + + * sem_ch6.adb: (Confirming Types): Code cleanup + + * decl.c (gnat_to_gnu_entity): Give support to anonymous access to + subprogram types: E_Anonymous_Access_Subprogram_Type and + E_Anonymous_Access_Protected_Subprogram_Type. + +2004-04-23 Thomas Quinot + + * sem_dist.adb: Add a new paramter to the RAS_Access TSS indicating + whether a pragma All_Calls_Remote applies to the subprogram on which + 'Access is taken. + No functional change is introduced by this revision; the new parameter + will be used to allow calls to local RCI subprograms to be optimized + to not use the PCS in the case where no pragma All_Calls_Remote applies, + as is already done in the PolyORB implementation of the DSA. + + * exp_dist.adb: Add a new paramter to the RAS_Access TSS indicating + whether a pragma All_Calls_Remote applies to the subprogram on which + 'Access is taken. + No functional change is introduced by this revision; the new parameter + will be used to allow calls to local RCI subprograms to be optimized + to not use the PCS in the case where no pragma All_Calls_Remote applies, + as is already done in the PolyORB implementation of the DSA. + +2004-04-23 Robert Dewar + + * Makefile.rtl: Add entry for s-addope.o in run time library list + * Make-lang.in: Add entry for s-addope.o to GNAT1 objects + * s-addope.ads, s-addope.adb: New files. + + * s-carsi8.adb, s-carun8.adb, s-casi16.adb, s-casi32.adb, + s-casi64.adb, s-caun16.adb, s-caun32.adb, s-caun64.adb, + s-finimp.adb, s-geveop.adb, s-stoele.adb: Modifications to allow + System.Address to be non-private and signed. + + * sem_elim.adb: Minor reformatting (fairly extensive) + Some minor code reorganization from code reading + Add a couple of ??? comments + +2004-04-23 Richard Kenner + + * trans.c (tree_transform, build_unit_elab): Don't call getdecls. + (tree_transform, case N_If_Statement): Remove non-determinism. + + * utils.c (begin_subprog_body): Just set DECL_CONTEXT in PARM_DECL. + +2004-04-23 Sergey Rybin + + * gnat_rm.texi: Small fixes in the changes made in the 'pragma + Eliminate' section. + + * snames.ads, snames.adb: Remove Name_Homonym_Number (Homonym_Number is + no longer used as a parameter name for Eliminate pragma). + +2004-04-22 Laurent Guerby + + PR optimization/14984 + PR optimization/14985 + * trans.c (gigi): Fix non determinism leading to bootstrap + comparison failures. + +2004-04-21 Pascal Obry + + * adaint.c (__gnat_portable_spawn): Quote first argument (argv[0]) + passed to spawnvp() to properly handle program pathname with spaces on + Win32. + +2004-04-21 Emmanuel Briot + + * g-debpoo.adb (Print_Info): Avoid extra work if Display_Slots is False. + (Allocate, Deallocate, Free_Physically): Make sure the tasks are + unlocked in case of exceptions. + +2004-04-21 Joel Brobecker + + * gigi.h (get_target_no_dollar_in_label): Remove extern declaration. + This function does not exist anymore. + +2004-04-21 Thomas Quinot + + * gnatbind.adb, gnatlink.adb: Update name of imported C symbol. + + * link.c: Move variables to the __gnat name space. + + * Makefile.in: list link.o explicitly when needed. + + * mlib.adb: Remove pragma Linker_Option for "link.o" from mlib. + +2004-04-21 Javier Miranda + + * einfo.adb (Original_Access_Type): New subprogram + (Set_Original_Access_Type): New subprogram + (Write_Field21_Name): Write the name of the new field + + * einfo.ads (Original_Access_Type): New field present in access to + subprogram types. + Addition of two new entities: E_Anonymous_Access_Subprogram_Type, and + E_Anonymous_Access_Protected_Subprogram_Type. + + * lib-xref.adb (Output_One_Ref): Give support to anonymous access to + subprogram types. + + * lib-xref.ads (Xref_Entity_Letters): Initialize values corresponding + to anonymous access to subprogram types. + + * sem_attr.adb (Resolve_Attribute): Give support to anonymous access + to subprogram types. + + * sem_ch3.adb (Access_Definition): Complete decoration of entities + corresponding to anonymous access to subprogram types. + (Analyze_Component_Declaration): Add new actual to the call to + subprogram replace_anonymous_access_to_protected_subprogram. + (Array_Type_Declaration): Add new actual to the call to subprogram + replace_anonymous_access_to_protected_subprogram. + (Process_Discriminants): Add new actual to the call to subprogram + replace_anonymous_access_to_protected_subprogram. + (Replace_Anonymous_Access_To_Protected_Subprogram): New formal. + + * sem_ch3.ads (Replace_Anonymous_Access_To_Protected_Subprogram): New + formal. + + * sem_ch6.adb, sem_type.adb, sem_res.adb: Give support to anonymous + access to subprogram types. + + * sem_util.adb (Has_Declarations): Addition of package_specification + nodes. + +2004-04-21 Ed Schonberg + + * sem_prag.adb (Make_Inline): If subprogram is a renaming, propagate + inlined flags to renamed entity only if in current unit. + +2004-04-21 Thomas Quinot + + * s-parint.ads: Add DSA implementation marker. + + * rtsfind.ads, rtsfind.adb, snames.ads, snames.adb, s-rpc.adb: Use the + value of System.Partition_Interface.DSA_Implementation to determine + what version of the distributed systems annex is available (no + implementation, GLADE, or PolyORB). + +2004-04-21 Joel Brobecker + + * targtyps.c (get_target_no_dollar_in_label): Remove, no longer used. + +2004-04-21 Richard Kenner + + * utils.c (convert, case CONSTRUCTOR, COMPONENT_REF): Do not make node + with new type if alias sets differ. + Fixes ACATS c41103b. + +2004-04-21 Vincent Celier + + * prj.ads: Remove FORTRAN as an accepted language: not tested yet. + Add array Lang_Args for the language specific compiling argument + switches. + + * gnat_ugn.texi: Explain in more details when a library is rebuilt. + +2004-04-21 Sergey Rybin + + * gnat_rm.texi: Update the descripton of the Eliminate pragma + according to the recent changes in the format of the parameters of the + pragma (replacing Homonym_Number with Source_Location). + +2004-04-19 Arnaud Charlet + + * 5isystem.ads: Removed, unused. + + * gnat_rm.texi: Redo 1.13 change. + +2004-04-19 Robert Dewar + + * s-stoele.ads: Clean up definition of Storage_Offset (the new + definition is cleaner, avoids the kludge of explicit Standard operator + references, and also is consistent with a visible System.Address with + no visible operations. + + * s-geveop.adb: Add declarations to avoid assumption of visible + operations on type System.Address (since these might not be available + if Address is a non-private type for which the operations + are made abstract). + + * sem_eval.adb: Minor reformatting + + * s-carsi8.ads, s-carun8.ads, s-casi16.ads, s-casi32.ads, + s-casi64.ads, s-caun16.ads, s-caun32.ads, s-caun64.ads: Minor + reformatting (new function spec format). + + * s-auxdec.adb, s-carsi8.adb, s-carun8.adb, s-casi16.adb, + s-casi32.adb, s-casi64.adb, s-caun16.adb, s-caun32.adb, + s-caun64.adb: Add declarations to avoid assumption of visible + operations on type System.Address (since these might not be available + if Address is a non-private type for which the operations are made + abstract). + + * lib.ads, lib.adb (Synchronize_Serial_Number): New procedure. + + * exp_intr.adb: Minor comment update + + * exp_aggr.adb, exp_attr.adb, exp_ch13.adb: Minor reformatting. + + * 5omastop.adb: Add declarations to avoid assumption of visible + operations on type System.Address (since these might not be available + if Address is a non-private type for which the operations + are made abstract). + +2004-04-19 Vincent Celier + + * switch-m.adb: (Scan_Make_Switches): Process new switch -eL + + * prj-pars.ads (Parse): New Boolean parameter Process_Languages, + defaulted to Ada. + + * prj-proc.adb (Process): New Boolean parameter Process_Languages, + defaulted to Ada. + Call Check with Process_Languages. + (Check): New Boolean parameter Process_Languages. Call Recursive_Check + with Process_Languages. + (Recursive_Check): New Boolean parameter Process_Languages. Call + Nmsc.Ada_Check or Nmsc.Other_Languages_Check according to + Process_Languages. + + * prj-proc.ads (Process): New Boolean parameter Process_Languages, + + * prj-util.ads, prj-util.adb (Executable_Of): New Boolean + parameter Ada_Main, defaulted to True. + Check for Ada specific characteristics only when Ada_Main is True. + + * opt.ads: (Follow_Links): New Boolean flag for gnatmake + + * prj.adb: (Project_Empty): Add new Project_Data components. + + * prj.ads: New types and tables for non Ada languages. + (Project_Data): New components Languages, Impl_Suffixes, + First_Other_Source, Last_Other_Source, Imported_Directories_Switches, + Include_Path, Include_Data_Set. + + * prj-env.ads, prj-env.adb: Minor reformatting + + * prj-nmsc.ads, prj-nmsc.adb: (Other_Languages_Check): New procedure + Put subprograms in alphabetical order + + * prj-pars.adb (Parse): New Boolean parameter Process_Languages, + defaulted to Ada; Call Prj.Proc.Process with Process_Languages and + Opt.Follow_Links. + + * mlib-prj.adb: Back out modification in last version, as they are + incorrect. + (Build_Library.Check_Libs): Remove useless pragma Warnings (Off) + + * make.adb: (Mains): Moved to package Makeutl + (Linker_Opts): Moved to package Makeutl + (Is_External_Assignment): Moved to package Makeutl + (Test_If_Relative_Path): Moved to package Makeutl + (Gnatmake): Move sorting of linker options to function + Makeutl.Linker_Options_Switches. + + * makeutl.ads, makeutl.adb: New files. + + * Makefile.in: Add makeutl.o to the object files for gnatmake + + * makeusg.adb: Add line for new switch -eL. + + * gnatls.adb (Image): New function. + (Output_Unit): If in verbose mode, output the list of restrictions + specified by pragmas Restrictions. + + * 5bml-tgt.adb, 5vml-tgt.adb (Build_Dynamic_Library): Do not use + Text_IO. + + * a-calend.adb (Split): Shift the date by multiple of 56 years, if + needed, to put it in the range 1970 (included) - 2026 (excluded). + (Time_Of): Do not shift Unix_Min_Year (1970). + Shift the date by multiple of 56 years, if needed, to put it in the + range 1970 (included) - 2026 (excluded). + + * adaint.h, adaint.c (__gnat_set_executable): New function. + +2004-04-19 Richard Kenner + + * trans.c (tree_transform, case N_Subprogram_Body): Temporarily push + and pop GC context. + (tree_transform, case N_Procedure_Call): Fix typo in setting TREE_TYPE. + (tree_transform, case N_Label): Don't set LABEL_STMT_FIRST_IN_EH. + (tree_transform, case N_Procedure_Call_Statement): Build a tree. + (tree_transform, case N_Code_Statement): Likewise. + (gnat_expand_stmt, case LABEL_STMT): Don't look at + LABEL_STMT_FIRST_IN_EH. + (gnat_expand_stmt, case ASM_STMT): New case. + + * utils2.c (build_unary_op): Properly set TREE_READONLY of + UNCONSTRAINED_ARRAY_REF. + + * utils.c (poplevel): Temporarily push/pop GC context around inline + function expansion. + + * decl.c (maybe_variable): Properly set TREE_READONLY of + UNCONSTRAINED_ARRAY_REF. + (make_packable_type): Only reference TYPE_IS_PADDING_P for RECORD_TYPE. + + * ada-tree.def: (ASM_STMT): New. + + * ada-tree.h: (LABEL_STMT_FIRST_IN_EH): Deleted. + (ASM_STMT_TEMPLATE, ASM_STMT_OUTPUT, ASM_STMT_ORIG_OUT, + ASM_STMT_INPUT): New. + (ASM_STMT_CLOBBER): Likewise. + +2004-04-19 Thomas Quinot + + * a-except.adb, s-parint.ads, s-parint.adb, types.ads, types.h: Use + general rcheck mechanism to raise Program_Error for E.4(18), instead + of a custom raiser in System.Partition_Interface. + Part of general cleanup work before PolyORB integration. + + * snames.ads, snames.adb: Add new runtime library entities and names + for PolyORB DSA. + + * sem_dist.ads, sem_dist.adb (Get_Subprogram_Id): Move from sem_dist to + exp_dist. + (Build_Subprogram_Id): New subprogram provided by exp_dist + Code reorganisation in preparation for PolyORB integration. + + * exp_dist.ads, exp_dist.adb (Get_Subprogram_Id): Move from sem_dist to + exp_dist. + (Build_Subprogram_Id): New subprogram provided by exp_dist + + * sem_ch4.adb (Analyze_One_Call): Fix error message for mismatch in + actual parameter types for call to dereference of an + access-to-subprogram type. + + * rtsfind.ads: Add new runtime library entities and names for PolyORB + DSA. + + * gnatlink.adb (Value): Remove. Use Interfaces.C.Strings.Value + instead, which has the same behaviour here since we never pass it a + NULL pointer. + + * link.c (run_path_option, Solaris case): Use -Wl, as for other + platforms. + + * Makefile.in: adjust object file lists for gnatlink and gnatmake + to account for new dependency upon Interfaces.C.Strings + link.o + For x86 FreeBSD, use 86numaux. + + * make.adb, gnatcmd.adb: Linker_Library_Path_Option has been moved up + from Mlib.Tgt to Mlib. + + * mlib.ads, mlib.adb (Linker_Library_Path_Option): New subprogram, now + target-independent. + + * mlib-tgt.ads, mlib-tgt.adb (Linker_Library_Path_Option): Remove + target-specific versions of this subprogram, now implemented as a + target-independent function in Mlib. + + * 5aml-tgt.adb, 5bml-tgt.adb, 5gml-tgt.adb, 5hml-tgt.adb, 5lml-tgt.adb, + 5sml-tgt.adb, 5vml-tgt.adb, 5zml-tgt.adb, 5wml-tgt.adb + (Linker_Library_Path_Option): Remove target-specific versions of this + subprogram, now implemented as a target-independent function in Mlib. + + * atree.adb: (Allocate_Initialize_Node): New subprogram. + Factors out node table slots allocation. + (Fix_Parents): New subprogram. + Encapsulate the pattern of fixing up parent pointers for syntactic + children of a rewritten node. + (New_Copy_Tree): Use New_Copy to copy non-entity nodes. + (Rewrite): Use New_Copy when creating saved copy of original node. + (Replace): Use Copy_Node to copy nodes. + +2004-04-19 Javier Miranda + + * sprint.adb (Sprint_Node_Actual): Give support to the new + Access_To_Subprogram node available in Access_Definition nodes. In + addition, give support to the AI-231 node fields: null-exclusion, + all-present, constant-present. + + * sem_util.ads, sem_util.adb: (Has_Declarations): New subprogram + + * sinfo.ads, sinfo.adb: + New field Access_To_Subprogram_Definition in Access_Definition nodes + + * sem_ch6.adb (Process_Formals): Move here the code that creates and + decorates internal subtype declaration corresponding to the + null-excluding formal. This code was previously in Set_Actual_Subtypes. + In addition, carry out some code cleanup on this code. In case of + access to protected subprogram call + Replace_Anonymous_Access_To_Protected_Subprogram. + (Set_Actual_Subtypes): Code cleanup. + + * sem_ch8.adb (Analyze_Object_Renaming): Remove un-necessary call to + Find_Type in case of anonymous access renamings. Add warning in case of + null-excluding attribute used in anonymous access renaming. + + * sem_ch3.ads (Replace_Anonymous_Access_To_Protected_Subprogram): New + subprogram + + * sem_ch3.adb (Replace_Anonymous_Access_To_Protected_Subprogram): New + subprogram. + (Access_Definition): In case of anonymous access to subprograms call + the corresponding semantic routine to decorate the node. + (Access_Subprogram_Declaration): Addition of some comments indicating + some code that probably should be added here. Detected by comparison + with the access_definition subprogram. + (Analyze_Component_Declaration): In case of access to protected + subprogram call Replace_Anonymous_Access_To_Protected. + (Array_Type_Declaration): In case of access to protected subprogram call + Replace_Anonymous_Access_To_Protected_Subprogram. + (Process_Discriminants): In case of access to protected subprogram call + Replace_Anonymous_Access_To_Protected_Subprogram. + + * par.adb (P_Access_Definition): New formal that indicates if the + null-exclusion part was present. + (P_Access_Type_Definition): New formal that indicates if the caller has + already parsed the null-excluding part. + + * par-ch3.adb (P_Subtype_Declaration): Code cleanup. + (P_Identifier_Declarations): Code cleanup and give support to renamings + of anonymous access to subprogram types. + (P_Derived_Type_Def_Or_Private_Ext_Decl): Code cleanup. + (P_Array_Type_Definition): Give support to AI-254. + (P_Component_Items): Give support to AI-254. + (P_Access_Definition): New formal that indicates if the header was + already parsed by the caller. + (P_Access_Type_Definition): New formal that indicates if the caller has + already parsed the null-excluding part. + + * par-ch6.adb (P_Formal_Part): Add the null-excluding parameter to the + call to P_Access_Definition. + +2004-04-19 Geert Bosch + + * checks.adb (Apply_Float_Conversion_Check): New procedure to implement + the delicate semantics of floating-point to integer conversion. + (Apply_Type_Conversion_Checks): Use Apply_Float_Conversion_Check. + + * eval_fat.adb (Machine_Mantissa): Moved to spec. + (Machine_Radix): New function. + + * eval_fat.ads (Machine_Mantissa): Moved from body for use in + conversion checks. + (Machine_Radix): New function also for use in conversion checks. + +2004-04-19 Ed Schonberg + + * par-prag.adb (Source_File_Name_Project): Fix typo in error message. + + * exp_ch9.adb (Expand_Access_Protected_Subprogram_Type): Call analyze + to decorate the access-to-protected subprogram and the equivalent type. + + * checks.adb (Null_Exclusion_Static_Checks): Code cleanup. Give support + to anonymous access to subprogram types. + + * exp_ch4.adb (Expand_N_In): Preserve Static flag before + constant-folding, for legality checks in contexts that require an RM + static expression. + + * exp_ch6.adb (Expand_N_Function_Call): If call may generate large + temporary but stack checking is not enabled, increment serial number + to so that symbol generation is consistent with and without stack + checking. + + * exp_util.ads, exp_util.adb (May_Generate_Large_Temp): Predicate is + independent on whether stack checking is enabled, caller must check + the corresponding flag. + + * sem_ch3.adb (Constrain_Index): Index bounds given by attributes need + range checks. + (Build_Derived_Concurrent_Type): Inherit Is_Constrained flag from + parent if it has discriminants. + (Build_Derived_Private_Type): Constructed full view does + not come from source. + (Process_Discriminants): Default discriminants on a tagged type are + legal if this is the internal completion of a private untagged + derivation. + + * sem_ch6.adb (Set_Actual_Subtypes): The generated declaration needs + no constraint checks, because it corresponds to an existing object. + + * sem_prag.adb (Process_Convention): Pragma applies + only to subprograms in the same declarative part, i.e. the same unit, + not the same scope. + + * sem_res.adb (Valid_Conversion): In an instance or inlined body, + ignore type mismatch on a numeric conversion if expression comes from + expansion. + +2004-04-19 Sergey Rybin + + * sem_elim.adb (Process_Eliminate_Pragma): Remove the processing for + Homonym_Number parameter, add processing for Source_Location parameter + corresponding. + (Check_Eliminated): Remove the check for homonym numbers, add the check + for source location traces. + + * sem_elim.ads (Process_Eliminate_Pragma): Replace Arg_Homonym_Number + with Arg_Source_Location corresponding to the changes in the format of + the pragma. + + * sem_prag.adb: (Analyze_Pragma): Changes in the processing of + Eliminate pragma corresponding to the changes in the format of the + pragma: Homonym_Number is replaced with Source_Location, two ways of + distinguishing homonyms are mutially-exclusive. + +2004-04-19 Joel Brobecker + + * get_targ.ads (Get_No_Dollar_In_Label): Remove. + + * exp_dbug.adb (Output_Homonym_Numbers_Suffix): Remove use of + No_Dollar_In_Label, no longer necessary, as it is always True. + (Strip_Suffixes): Likewise. + +2004-04-19 Gary Dismukes + + * s-stalib.ads (type Exception_Code): Use Integer'Size for exponent of + modulus for compatibility with size clause on targets with 16-bit + Integer. + + * layout.adb (Discrimify): In the case of private types, set Vtyp to + full type to fix type mismatches on calls to size functions for + discriminant-dependent array components. + +2004-04-19 Jerome Guitton + + * Makefile.in (gnatlib-zcx): New target, for building a ZCX run-time + lib. + +2004-04-19 Pascal Obry + + * mdll-utl.adb (Locate): New version is idempotent. + +2004-04-17 Laurent Guerby + + PR ada/14988 (partial) + * impunit.adb: Fix typo. + +2004-04-14 Nathanael Nerode + + * Make-lang.in: Remove obsolete rts-none, rts-cert, install-rts-none, + and install-rts-cert targets. Remove all gnatlib and gnattools + targets and all other rts-* targets (moved to libada). Remove (now) + unused Make variables CHMOD, CHMOD_AX_FLAGS, shext, THREAD_KIND, + TRACE, GNATLIBFLAGS, GNATLIBCFLAGS. + +2004-04-08 Richard Kenner + + * trans.c (tree_transform): Shortcut returning error_mark_node for + statements in annotate_only_mode. + (tree_transform, case N_Label, case N_Return_Statement, + N_Goto_Statement): Make statement tree instead of generating code. + (tree_transform, case N_Assignment_Statement): No longer check + type_annotate_only. + (gnat_expand_stmt, case GOTO_STMT, case LABEL_STMT, case + RETURN_STMT): New. + (first_nondeleted_insn, build_block_stmt, make_expr_stmt_from_rtl): + New fcns. + (gnat_to_gnu): Collect any RTL generated and deal with it. + (tree_transform, case N_And_Then): Refine when have non-null RTL_EXPR. + (tree_transform case N_If_Statement): Rewrite to make IF_STMT. + (gnat_expand_stmt, case BLOCK_STMT, IF_STMT): New cases. + + * ada-tree.def (GOTO_STMT, LABEL_STMT, RETURN_STMT): New tree nodes. + + * ada-tree.def (EXPR_STMT): Fix typo in name. + (BLOCK_STMT, IF_STMT): New nodes. + + * ada-tree.h (GOTO_STMT_LABEL, LABEL_STMT_LABEL, + LABEL_STMT_FIRST_IN_EH): New macros. + (RETURN_STMT_EXPR): Likewise. + + * ada-tree.h: (BLOCK_STMT_LIST, IF_STMT_COND, IF_STMT_TRUE, + IF_STMT_ELSEIF, IF_STMT_ELSE): New macros. + +2004-04-08 Thomas Quinot + + * atree.ads: Correct documentation on extended nodes. + + * link.c: Set run_path_option for FreeBSD. + +2004-04-08 Vincent Celier + + * mlib-prj.adb (Build_Library.Check_Libs): On OpenVMS, if dec.ali is + one of the ALI file, do not link with DEC lib. + + * par.adb Remove the last two characters ("%s" or "%b") when checking + if a language defined unit may be recompiled. + +2004-04-08 Ed Schonberg + + * sem_ch4.adb (Remove_Abstract_Operations): Improve error message when + removal of abstract operation leaves no possible interpretation for + expression. + + * sem_eval.adb (Eval_Qualified_Expression): Use + Set_Raises_Constraint_Error on node when needed, so that it does not + get optimized away by subsequent optimizations. + + * sem_res.adb (Resolve_Intrinsic_Operator): Save interpretations of + operands even when they are not wrapped in a type conversion. + +2004-04-08 Olivier Hainque + + * sem_prag.adb (Set_Exported): Warn about making static as result of + export only when the export is coming from source. This may be not + be true e.g. on VMS where we expand export pragmas for exception codes + together with imported or exported exceptions, and we don't want the + user to be warned about something he didn't write. + +2004-04-08 Thomas Quinot + + * sem_util.adb (Note_Possible_Modification): Reorganize to remove code + duplication between normal entities and those declared as renamings. + No functional change. + + * s-fileio.ads (Form): Remove pragma Inline, as we cannot currently + inline functions returning an unconstrained result. + +2004-04-08 Eric Botcazou + + * utils.c (type_for_mode): Handle BLKmode and VOIDmode properly, to + conform to what other front-ends do. + +2004-04-08 Doug Rupp + + * 5vml-tgt.adb: Use Gas instead of VMS Macro to build auto init shared + libraries. + +2004-04-06 Pascal Obry + + * adaint.c (DIR_SEPARATOR): Properly set DIR_SEPARATOR on Win32. + + * osint.adb (Program_Name): Do not look past a directory separator. + +2004-04-06 Thomas Quinot + + * atree.adb: Update comment (Rewrite_Substitute_Node no longer exists). + + * exp_ch6.adb (Rewrite_Function_Call): Clarify documentation of + requirement for preserving a copy of the original assignment node. + + * sinfo.ads: Update comment (Original_Tree -> Original_Node). + +2004-04-06 Olivier Hainque + + (__gnat_initialize [Vxworks]): Enable references to the crtstuff bits + when supported. + +2004-04-06 Ed Schonberg + + * sem_ch4.adb (Remove_Abstract_Operations): Extend previous changes to + operator calls in functional notation, and apply + Universal_Interpretation to operands, not to their type. + +2004-04-06 Robert Dewar + + * 5wdirval.adb: Minor reformatting + +2004-04-06 Ed Falis + + * gnat_rm.texi: Improve a reference to the GCC manual + +2004-04-05 Vincent Celier + + * adaint.h, adaint.c: Add function __gnat_named_file_length + + * impunit.adb: Add Ada.Directories to the list + + * Makefile.in: Add VMS and Windows versions of + Ada.Directories.Validity package body. + + * Makefile.rtl: Add a-direct and a-dirval + + * mlib-tgt.ads: Minor comment update. + + * a-dirval.ads, a-dirval.adb, 5vdirval.adb, 5wdirval.adb, + a-direct.ads, a-direct.adb: New files. + +2004-04-05 Vincent Celier + + PR ada/13620 + * make.adb (Scan_Make_Arg): Pass any -fxxx switches to gnatlink, not + just to the compiler. + +2004-04-05 Robert Dewar + + * a-except.adb (Exception_Name_Simple): Make sure lower bound of + returned string is 1. + + * ali-util.adb: Use proper specific form for Warnings (Off, entity) + + * eval_fat.ads: Minor reformatting + + * g-curexc.ads: Document that lower bound of returned string values + is always one. + + * gnatlink.adb: Add ??? comment for previous change + (need to document why this is VMS specific) + + * s-stoele.ads: Minor reformatting + + * tbuild.ads: Minor reformatting throughout (new function specs) + + * par-ch10.adb (P_Context_Clause): Handle comma instead of semicolon + after WITH. + + * scng.adb: Minor reformatting + +2004-04-05 Geert Bosch + + * eval_fat.adb (Machine): Remove unnecessary suppression of warning. + (Leading_Part): Still perform truncation to machine number if the + specified radix_digits is greater or equal to machine_mantissa. + +2004-04-05 Javier Miranda + + * par-ch3.adb: Complete documentation of previous change + Correct wrong syntax documentation of the OBJECT_DECLARATION rule + (aliased must appear before constant). + + * par-ch4.adb: Complete documentation of previous change. + + * par-ch6.adb: Complete documentation of previous change. + + * sinfo.ads: Fix typo in commment. + +2004-04-05 Ed Schonberg + + * sem_ch3.adb (Inherit_Components): If derived type is private and has + stored discriminants, use its discriminants to constrain parent type, + as is done for non-private derived record types. + + * sem_ch4.adb (Remove_Abstract_Operations): New subprogram to implement + Ada 2005 AI-310: an abstract non-dispatching operation is not a + candidate interpretation in an overloaded call. + + * tbuild.adb (Unchecked_Convert_To): Preserve conversion node if + expression is Null and target type is not an access type (e.g. a + non-private address type). + +2004-04-05 Thomas Quinot + + * exp_ch6.adb (Rewrite_Function_Call): When rewriting an assignment + statement whose right-hand side is an inlined call, save a copy of the + original assignment subtree to preserve enough consistency for + Analyze_Assignment to proceed. + + * sem_ch5.adb (Analyze_Assignment): Remove a costly copy of the + complete assignment subtree which is now unnecessary, as the expansion + of inlined call has been improved to preserve a consistent assignment + tree. Note_Possible_Modification must be called only + after checks have been applied, or else unnecessary checks will + be generated. + + * sem_util.adb (Note_Possible_Modification): Reorganise the handling + of explicit dereferences that do not Come_From_Source: + - be selective on cases where we must go back to the dereferenced + pointer (an assignment to an implicit dereference must not be + recorded as modifying the pointer); + - do not rely on Original_Node being present (Analyze_Assignment + calls Note_Possible_Modification on a copied tree). + + * sem_warn.adb (Check_References): When an unset reference to a pointer + that is never assigned is encountered, prefer ' may be null' + warning over ' is never assigned a value'. + +2004-04-05 Ramon Fernandez + + * tracebak.c: Change STOP_FRAME in ppc vxworks to be compliant with + the ABI. + +2004-04-05 Olivier Hainque + + * 5gmastop.adb (Pop_Frame): Comment out the pragma Linker_Option for + libexc. We currently don't reference anything in this library and + linking it in triggers linker warnings we don't want to see. + + * init.c: Update comments. + +2004-04-05 Richard Kenner + + * decl.c (gnat_to_gnu_entity): Use TYPE_READONLY. + * utils.c (create_field_decl): Likewise. + * utils2.c (build_unary_op, gnat_build_constructor): Likewise. + +2004-04-02 Arnaud Charlet + + * gnat-style.texi, gnat_rm.texi, gnat_ugn.texi: Remove RCS tags. + Replace ifinfo by ifnottex, to make makeinfo --html happy again. + Add info directory entry and category. + +2004-04-02 Jan Hubicka + + * utils.c: Include function.h + (end_subprog_body): Clear DECL_STRUCT_FUNCTION. + +2004-04-01 Arnaud Charlet + + PR ada/14150 + * Make-lang.in: Clean up generation of documentation + + * gnat-style.texi, gnat_rm.texi, ug_words: Resync with AdaCore version + + * xgnatug.adb: Removed, replaced by xgnatugn.adb + + * xgnatugn.adb: Replaces xgnatug.adb + + * gnat_ug.texi: Removed, replaced by gnat_ugn.texi + + * gnat_ugn.texi: Replaces gnat_ug.texi. Resync with AdaCore version + + * gnat_ug_unx.texi, gnat_ug_vms.texi, gnat_ug_vxw.texi, + gnat_ug_wnt.texi: Removed. + +2004-04-01 Arnaud Charlet + + * utils2.c: Update copyright notice. + +2004-04-01 Robert Dewar + + * checks.adb: Minor reformatting throughout + Note that prev checkin added RM reference to alignment warning + +2004-04-01 Ed Schonberg + + * exp_aggr.adb (Get_Component_Val): Treat a string literal as + non-static when building aggregate for bit-packed array. + + * exp_ch4.adb (Expand_N_Slice): If a packed slice is an actual of a + function call that is itself the actual in a procedure call, build + temporary for it. + + * exp_pakd.adb (Expand_Bit_Packed_Element_Set): If right-hand side is + a string literal, create a temporary for it, constant folding only + handles scalars here. + +2004-04-01 Vincent Celier + + * ali-util.adb (Post_Scan, Error_Msg, Error_Msg_S, Error_Msg_SC, + Error_Msg_SP): New empty procedures to instantiate the Scanner. + (Style, Scanner): Instantiations of Styleg and Scng to be able to scan + tokens. + (Accumulate_Checksum, Initialize_Checksum): Remove procedures. + (Get_File_Checksum): Use the instantiated scanner to scan all the tokens + and get the checksum. + + * make.adb (Gnatmake): Do not insert into Q the Main_Source if it is + already in the Q. + Increase the Marking_Label at the end of the Multiple_Main_Loop, + instead of at the beginning. + + * osint.adb (Lib_File_Name): Use Multi_Unit_Index_Character, not '~' + directly. + (Osint package elaboration): Change Multi_Unit_Index_Character to '$' if + on VMS. + + * osint.ads (Multi_Unit_Index_Character): New Character global variable + + * osint-c.adb (Set_Library_Info_Name): Use Multi_Unit_Index_Character, + not '~' directly. + + * par.adb: Remove test on file name to detect language defined units. + Add test on unit name, after parsing, to detect language defined units + that are not compiled with -gnatg (except System.RPC and its children) + + * par-ch10.adb (P_Compilation_Unit): In multi-unit sources, scan the + following units without style checking. + + * switch-c.adb: Change -gnatC to -gnateI + + * usage.adb: Document new switch -gnateInnn + + * scng.adb (Accumulate_Token_Checksum): New procedure + (Scan): Call Accumulate_Token_Checksum after each identifier, reserved + word or literal number. + (Scan.Nlit.Scan_Integer): Do not accumulate internal '_' in litteral + numbers. + +2004-04-01 Thomas Quinot + + * a-tasatt.adb, + g-comlin.adb, sinput-c.adb, s-secsta.adb, s-tpobop.adb, + switch-m.adb, 56taprop.adb, 5ginterr.adb, 5gmastop.adb, + 5staprop.adb, 5vinterr.adb, 5vtaprop.adb, 5vtpopde.adb, + 5vtpopde.adb: Add missing 'constant' keywords. + +2004-04-01 Javier Miranda + + * par-ch4.adb: (P_Allocator): Code cleanup + + * sem_ch3.adb (Access_Definition): Properly set the null-excluding + attribute. + + * sinfo.ads: Complete documentation of previous change + +2004-04-01 Pascal Obry + + * gnatlink.adb (Process_Binder_File): Remove duplicate linker options + only on VMS. This special handling was done because an old GNU/ld bug + on Windows which has been fixed. + +2004-04-01 GNAT Script + + * Make-lang.in: Makefile automatically updated + +2004-03-31 Richard Kenner + + * decl.c (gnat_to_gnu_entity, make_type_from_size): + Use TYPE_UNSIGNED, not TREE_UNSIGNED. + * trans.c (tree_transform, convert_with_check): Likewise. + * utils.c (gnat_signed_or_unsigned_type): Likewise. + (build_vms_descriptor, unchecked_convert): Likewise. + * utils2.c (nonbinary_modular_operation): Likewise. + +2004-03-29 Javier Miranda + + * checks.adb (Null_Exclusion_Static_Checks): New subprogram + (Install_Null_Excluding_Check): Local subprogram that determines whether + an access node requires a runtime access check and if so inserts the + appropriate run-time check. + (Apply_Access_Check): Call Install_Null_Excluding check if required + (Apply_Constraint_Check): Call Install_Null_Excluding check if required + + * checks.ads: (Null_Exclusion_Static_Checks): New subprogram + + * einfo.ads: Fix typo in comment + + * exp_ch3.adb (Build_Assignment): Generate conversion to the + null-excluding type to force the corresponding run-time check. + (Expand_N_Object_Declaration): Generate conversion to the null-excluding + type to force the corresponding run-time check. + + * exp_ch5.adb (Expand_N_Assignment_Statement): Generate conversion to + the null-excluding type to force the corresponding run-time check. + + * exp_ch6.adb (Expand_Call): Do not generate the run-time check in + case of access types unless they have the null-excluding attribute. + + * sprint.adb (Sprint_Node_Actual): Give support to the null-exclusing + part. + + * exp_util.ads: Fix typo in comment + + * par.adb (P_Null_Exclusion): New subprogram + (P_Subtype_Indication): New formal that indicates if the null-excluding + part has been scanned-out and it was present + + * par-ch3.adb, par-ch4.adb, par-ch6.adb: Give support to AI-231 + + * sem_aggr.adb: (Check_Can_Never_Be_Null): New subprogram + (Aggregate_Constraint_Checks): Generate conversion to the null-excluding + type to force the corresponding run-time check + (Resolve_Aggregate): Propagate the null-excluding attribute to the array + components + (Resolve_Array_Aggregate): Carry out some static checks + (Resolve_Record_Aggregate.Get_Value): Carry out some static check + + * sem_ch3.adb (Access_Definition): In Ada 0Y the Can_Never_Be_Null + attribute must be set only if specified by means of the null-excluding + part. In addition, we must also propagate the access-constant attribute + if present. + (Access_Subprogram_Declaration, Access_Type_Declaration, + Analyze_Component_Declaration, Analyze_Object_Declaration, + Array_Type_Declaration, Process_Discriminants, + Analyze_Subtype_Declaration): Propagate the null-excluding attribute + and carry out some static checks. + (Build_Derived_Access_Type): Set the null-excluding attribute + (Derived_Type_Declaration, Process_Subtype): Carry out some static + checks. + + * sem_ch4.adb (Analyze_Allocator): Carry out some static checks + + * sem_ch5.adb (Analyze_Assignment): Carry out some static checks + + * sem_ch6.adb (Process_Formals): Carry out some static checks. + (Set_Actual_Subtypes): Generate null-excluding subtype if the + null-excluding part was present; it is not required to be done here in + case of anonymous access types. + (Set_Formal_Mode): Ada 0Y allows anonymous access to have the null + value. + + * sem_res.adb (Resolve_Actuals): Carry out some static check + (Resolve_Null): Allow null in anonymous access + + * sinfo.adb: New subprogram Null_Exclusion_Present + All_Present and Constant_Present available on access_definition nodes + + * sinfo.ads: New flag Null_Exclusion_Present on subtype_declaration, + object_declaration, derived_type_definition, component_definition, + discriminant_specification, access_to_object_definition, + access_function_definition, allocator, access_procedure_definition, + access_definition, parameter_specification, All_Present and + Constant_Present flags available on access_definition nodes. + +2004-03-29 Robert Dewar + + * fname.adb, fname.ads, fname-sf.adb, fname-uf.adb, fname-uf.ads, + gnat1drv.adb, lib.adb, lib.ads, lib-load.adb, lib-writ.adb, + opt.ads, osint.adb, osint.ads, osint-c.adb, par.adb, + par-ch10.adb, par-load.adb, par-prag.adb, sfn_scan.adb, + sfn_scan.ads, sinput-l.adb, sinput-l.ads, switch-c.adb, + sem_prag.adb: Updates to handle multiple units/file + + * par.adb: Change test for s-rpc to s-rp for detecting rpc and children + + * par.adb, memtrack.adb, prj-makr.adb, prj-part.adb, + sem_util.adb: Minor reformatting + + * sem_ch12.adb: Add comment for previous change + +2004-03-29 Laurent Pautet + + * osint.adb (Executable_Prefix): Set Exec_Name to the current + executable name when not initialized. Otherwise, use its current value. + + * osint.ads (Exec_Name): Move Exec_Name from body to spec in order to + initialize it to another executable name than the current one. This + allows to configure paths for an executable name (gnatmake) different + from the current one (gnatdist). + +2004-03-29 Ed Schonberg + + * exp_ch6.adb (Expand_Call): A call to a function declared in the + current unit cannot be inlined if it appears in the body of a withed + unit, to avoid order of elaboration problems in gigi. + + * exp_ch9.adb (Build_Protected_Sub_Specification): Generate debugging + information for protected (wrapper) operation as well, to simplify gdb + use. + + * sem_ch6.adb (Analyze_Subprogram_Body): For a private operation in a + protected body, indicate that the entity for the generated spec comes + from source, to ensure that references are properly generated for it. + (Build_Body_To_Inline): Do not inline a function that returns a + controlled type. + + * sem_prag.adb (Process_Convention): If subprogram is overloaded, only + apply convention to homonyms that are declared explicitly. + + * sem_res.adb (Make_Call_Into_Operator): If the operation is a function + that renames an equality operator and the operands are overloaded, + resolve them with the declared formal types, before rewriting as an + operator. + +2004-03-29 GNAT Script + + * Make-lang.in: Makefile automatically updated + +2004-03-25 Vasiliy Fofanov + + * memtrack.adb: Log realloc calls, which are treated as free followed + by alloc. + +2004-03-25 Vincent Celier + + * prj-makr.adb (Process_Directories): Detect when a file contains + several units. Do not include such files in the config pragmas or + in the naming scheme. + + * prj-nmsc.adb (Record_Source): New parameter Trusted_Mode. + Resolve links only when not in Trusted_Mode. + (Find_Sources, Recursive_Find_Dirs, Find_Source_Dirs, Locate_Directory): + Do not resolve links for the display names. + + * prj-part.adb (Parse_Single_Project, Project_Path_Name_Of): Do not + resolve links when computing the display names. + +2004-03-25 Thomas Quinot + + * sem_attr.adb (Check_Dereference): When the prefix of a 'Tag + attribute reference does not denote a subtype, it can be any + expression that has a classwide type, potentially after an implicit + dereference. In particular, the prefix can be a view conversion for + a classwide type (for which Is_Object_Reference holds), but it can + also be a value conversion for an access-to-classwide type. In the + latter case, there is an implicit dereference, and the original node + for the prefix does not verify Is_Object_Reference. + + * sem_util.adb (Is_Dependent_Component_Of_Mutable_Object): A view + conversion of a discriminant-dependent component of a mutable object + is one itself. + +2004-03-25 Ed Schonberg + + * freeze.adb (Freeze_Entity): When an inherited subprogram is + inherited, has convention C, and has unconstrained array parameters, + place the corresponding warning on the derived type declaration rather + than the original subprogram. + + * sem_ch12.adb (Instantiate_Formal_Subprogram): Set From_Default + indication on renaming declaration, if formal has a box and actual + is absent. + + * sem_ch8.adb (Analyze_Subprogram_Renaming): Use From_Default flag to + determine whether to generate an implicit or explicit reference to + the renamed entity. + + * sinfo.ads, sinfo.adb: New flag From_Default, to indicate that a + subprogram renaming comes from a defaulted formal subprogram in an + instance. + +2004-03-25 Gary Dismukes + + * sem_elab.adb (Check_Elab_Call): Refine loop that checks for default + value expressions to ensure that calls within a component definition + will be checked (since those are evaluated during the record type's + elaboration). + +2004-03-25 Arnaud Charlet + + * s-tpobop.adb: Code clean up: + (Requeue_Call): Extract from PO_Service_Entries to remove duplicated + code. + (PO_Do_Or_Queue): Remove duplicated code and use Requeue_Call. + +2004-03-25 Jose Ruiz + + * Makefile.in: Clean up in the ravenscar run time. + +2004-03-23 Richard Kenner + + * decl.c (gnat_to_gnu_entity, case E_Access_Type): Pass value + of No_Strict_Aliasing to build_pointer_type_for_mode. + * utils.c (update_pointer_to): Walk pointer and ref chains. + +2004-03-22 Cyrille Comar + + * ali.ads: Fix Comment about Dynamic_Elab. + + * gnatls.adb (Output_Unit): Add output of many flags (Dynamic_Elab, + Has_RACW, Is_Generic, etc.) + (Output_Object, Gnatls): Take into account ALI files not attached to + an object. + +2004-03-22 Vincent Celier + + * gprep.adb: Change all String_Access to Name_Id + (Is_ASCII_Letter): new function + (Double_File_Name_Buffer): New procedure + (Preprocess_Infile_Name): New procedure + (Process_Files): New procedure + (Gnatprep): Check if output and input are existing directories. + Call Process_Files to do the real job. + +2004-03-22 Robert Dewar + + * prj-env.adb, prj-nmsc.ads, prj-proc.ads, + s-stache.ads, s-stache.adb: Comment updates. Minor reformatting. + +2004-03-22 Sergey Rybin + + * scn.adb (Contains): Add check for EOF, is needed for a degenerated + case when the source contains only comments. + +2004-03-22 Ed Schonberg + + * sem_ch10.adb (Analyze_Compilation_Unit): When generating a + declaration for a child subprogram body that acts as a spec, indicate + that the entity in the declaration needs debugging information. + + * sem_ch3.adb (Complete_Private_Subtype): Do not build an underlying + full view if the subtype is created for a constrained record component; + gigi has enough information to construct the record, and there is no + place in the tree for the declaration. + + * sem_ch6.adb (Build_Body_To_Inline): Use an internal name without + serial number for the dummy body that is built for analysis, to avoid + inconsistencies in the generation of internal names when compiling + with -gnatN. + +2004-03-22 Thomas Quinot + + * sem_util.adb (Is_Object_Reference): A view conversion denotes an + object. + +2004-03-22 GNAT Script + + * Make-lang.in: Makefile automatically updated + +2004-03-21 Richard Kenner + + * decl.c (gnat_to_gnu_entity): Use SUBSTITUTE_PLACEHOLDER_IN_EXPR. + * trans.c (tree_transform, emit_index_check): Likewise. + * utils.c (build_template): Likewise. + (max_size, convert): Remove handling of WITH_RECORD_EXPR. + (maybe_unconstrained_array, unchecked_convert): Likewise. + * utils2.c (gnat_truthvalue_conversion, build_binary_op): Likewise. + (build_unary_op): Likewise. + (compare_arrays, build_allocator): Use SUBSTITUTE_PLACEHOLDER_IN_EXPR. + (fill_vms_descriptor): Likewise. + (build_call_alloc_dealloc): Likewise. + ALIGN is unsigned. + * gigi.h (build_call_alloc_dealloc): Alignment is unsigned. + +2004-03-20 Joseph S. Myers + + PR other/14630 + * gnat_ug.texi: Add info directory category and entry. + * gnat_ug_unx.texi, gnat_ug_vms.texi, gnat_ug_vxw.texi, + gnat_ug_wnt.texi: Regenerate. + +2004-03-19 Arnaud Charlet + + * ada-tree.h: Update copyright notice. + Minor reformatting. + +2004-03-19 Olivier Hainque + + * decl.c (gnat_to_gnu_entity, case E_Exception): Handle VMS exceptions + as regular exception objects and not as mere integers representing the + condition code. The latter approach required some dynamics to mask off + severity bits, which did not fit well into the GCC table based model. + (gnat_to_gnu_entity, objects): Don't supply an external name for VMS + exception data objects. We don't it and it would conflict with the other + external symbol we have to generate for such exceptions. + + * trans.c (tree_transform, case N_Exception_Handler): Remove part of + the special code for VMS exceptions, since these are now represented + as regular exceptions objects. + +2004-03-19 Richard Kenner + + * decl.c (debug_no_type_hash): Remove. + (gnat_to_gnu_entity, case E_Array_Type): Don't set and clear it. + * misc.c (LANG_HOOK_HASH_TYPE): Redefine. + +2004-03-19 Laurent Guerby + + * sem_prag.adb (Suppress_Unsuppress_Echeck): use loop instead of + aggregate, allows bootstrap from 3.3 on powerpc-darwin. + +2004-03-18 Richard Kenner + + * ada-tree.h (TYPE_LEFT_JUSTIFIED_MODULAR_P): Add checking. + (TYPE_CONTAINS_TEMPLATE_P, TYPE_OBJECT_RECORD_TYPE): Likewise. + (TYPE_RM_SIZE_INT): Directly use type.values. + (TREE_LOOP_ID): Clean up check. + * decl.c (gnat_to_gnu_entity, case E_Enumeration_Type): Use + TYPE_VALUES, not TYPE_FIELDS. + * trans.c (convert_with_check): Delay access of bounds of basetype + until sure is numeric. + +2004-03-18 Arnaud Charlet + + * 5atpopsp.adb: Remove RTEMS from list of platforms using this file. + + Code clean up: + * 5ataprop.adb, 5ftaprop.adb, 5htaprop.adb, 5itaprop.adb, 5staprop.adb, + 5vtaprop.adb, 5wtaprop.adb, 7staprop.adb (Finalize_TCB): Use + Specific.Set instead of direct call to e.g pthread_setspecific. + +2004-03-18 Thomas Quinot + + * adaint.c: Update comments. + + * Makefile.in: set PREFIX_OBJS, SYMLIB, THREADSLIB, and + GNATLIB_SHARED for FreeBSD. + +2004-03-18 Jose Ruiz + + * init.c [VxWorks]: Do not fix the stack size for the environment task. + When needed (stack checking) the stack size is retrieved + from the VxWorks kernel. + + * Makefile.in: Flag -nostdinc is required when building the run time + for avoiding looking for files in the base compiler. + Add the VxWorks specific version of the package body for + System.Stack_checking.Operations (5zstchop.adb). + + * Make-lang.in: Add the object file for + System.Stack_Checking.Operations. + + * Makefile.rtl: Add object file for the package + System.Stack_Checking.Operations. + + * s-stchop.ads, s-stchop.adb, 5zstchop.adb: New files. + + * s-stache.ads, s-stache.adb: Move the operations related to stack + checking from this package to package System.Stack_Checking.Operations. + This way, stack checking operations are only linked in the final + executable when using the -fstack-check flag. + +2004-03-18 Doug Rupp + + * Makefile.in [VMS]: Handle 64 bit specs (5qsystem.ads, 5xcrtl.ads). + Reorganize ifeq's. + + * 5qsystem.ads, 5xcrtl.ads: New files. + +2004-03-18 Vincent Celier + + * prj.adb (Reset): Reset hash table Files_Htable + + * prj-env.adb (Source_Paths, Object_Paths): New tables. + (Add_To_Source_Path, Add_To_Object_Path): New procedures, to replace + the procedures Add_To_Path_File. + (Set_Ada_Paths): Accumulate source and object dirs in the tables, + making sure that each directory is present only once and, for object + dirs, when a directory already present is added, the duplicate is + removed and the directory is always put as the last in the table. + Write the path files at the end of these accumulations. + + * prj-nmsc.adb (Record_Source): Add source file name in hash table + Files_Htable for all sources. + + * prj-proc.adb (Process): Remove restrictions between not directly + related extending projects. + +2004-03-18 Emmanuel Briot + + * prj-nmsc.ads, prj-nmsc.adb (Ada_Check): New parameter Trusted_Mode. + (Find_Sources): Minor speed optimization. + + * prj-proc.ads, prj-proc.adb (Check, Recursive_Check, Process): New + parameter Trusted_Mode. + +2004-03-18 Sergey Rybin + + * scn.adb (Determine_License): Take into account a degenerated case + when the source contains only comments. + +2004-03-18 Ed Schonberg + + * sem_warn.adb (Check_References): For a warning on a selected + component that does not come from source, locate an uninitialized + component of the record type to produce a more precise error message. + +2004-03-15 Jerome Guitton + + * 3zsoccon.ads: Fix multicast options. + + * s-thread.ads: Move unchecked conversion from ATSD_Access to Address + in the spec. + +2004-03-15 Robert Dewar + + * sem_prag.adb: Make sure No_Strict_Aliasing flag is set right when + pragma used for a private type. + + * lib-xref.adb (Generate_Reference): Do not generate warning if + reference is in a different unit from the pragma Unreferenced. + + * 5vtpopde.adb: Minor reformatting + Fix casing of To_Task_ID + + * sem_ch13.adb (Validate_Unchecked_Conversion): Set No_Strict_Aliasing + flag if we have an unchecked conversion to an access type in the same + unit. + +2004-03-15 Geert Bosch + + * a-ngcoty.adb (Modulus): In alternate formula for large real or + imaginary parts, use Double precision throughout. + + * a-tifiio.adb (Put_Scaled): Remove remaining pragma Debug. Not only + we want to be able to compile run-time with -gnata for testing, but + this may also be instantiated in user code that is compiled with -gnata. + +2004-03-15 Olivier Hainque + + * s-stalib.ads (Exception_Code): New type, to represent Import/Export + codes. Having a separate type for this is useful to enforce consistency + throughout the various run-time units. + (Exception_Data): Use Exception_Code for Import_Code. + + * s-vmextra.ads, s-vmexta.adb: Use Exception_Code instead of a mix of + Natural and Integer in various places. + (Register_VMS_Exception): Use Base_Code_In to compute the exception code + with the severity bits masked off. + (Register_VMS_Exception): Handle the additional exception data pointer + argument. + + * raise.c (_GNAT_Exception structure): Remove the handled_by_others + component, now reflected by an exported accessor. + (is_handled_by): New routine to compute whether the propagated + occurrence matches some handler choice specification. Extracted out of + get_action_description_for, and expanded to take care of the VMS + specifities. + (get_action_description_for): Use is_handled_by instead of an explicit + complex condition to decide if the current choice at hand catches the + propagated occurrence. + + * raise.h (Exception_Code): New type for C. + + * rtsfind.ads (RE_Id, RE_Unit_Table): Add + System.Standard_Library.Exception_Code, to allow references from the + pragma import/export expander. + + * a-exexpr.adb (Is_Handled_By_Others, Language_For, Import_Code_For): + New accessors to allow easy access to GNAT exception data + characteristics. + (GNAT_GCC_Exception record, Propagate_Exception): Get rid of the + redundant Handled_By_Others component, helper for the personality + routine which will now be able to call the appropriate exception data + accessor instead. + + * cstand.adb (Create_Standard): Adjust the type of the Import_Code + component of Standard_Exception_Type to be the closest possible to + Exception_Code in System.Standard_Library, that we cannot get at this + point. Expand a ??? comment to notify that this type node should + probably be rewritten later on. + + * exp_prag.adb (Expand_Pragma_Import_Export_Exception): Adjust the + registration call to include a pointer to the exception object in the + arguments. + + * init.c (__gnat_error_handler): Use Exception_Code and Base_Code_In + instead of int and explicit bitmasks. + +2004-03-15 Vincent Celier + + * vms_data.ads: Add new GNAT BIND qualifier /STATIC. Makes /NOSHARED + equivalent to /STATIC and /NOSTATIC equivalent to /SHARED. + + * a-tasatt.adb (To_Access_Code): Remove this UC instantiation, no + longer needed now that it is in the spec of + System.Tasking.Task_Attributes. + + * adaint.h, adaint.c: (__gnat_create_output_file): New function + + * gnatcmd.adb: Fix bug introduced in previous rev: /= instead of = + + * g-os_lib.ads, g-os_lib.adb (Create_Output_Text_File): New function. + + * make.adb (Gnatmake): Do not check the executable suffix; it is being + taken care of in Scan_Make_Arg. + (Scan_Make_Arg): Add the executable suffix only if the argument + following -o, in canonical case, does not end with the executable + suffix. When in verbose mode and executable file name does not end + with executable suffix, output the executable name, in canonical case. + + * s-tataat.ads (Access_Dummy_Wrapper): Add pragma No_Strict_Aliasing + to avoid warnings when instantiating Ada.Task_Attributes. + Minor reformating. + + * mlib-prj.adb (Process_Imported_Libraries): Get the imported libraries + in the correct order. + + * prj-makr.adb (Process_Directory): No longer use GNAT.Expect, but + redirect standard output and error to a file for the invocation of the + compiler, then read the file. + + * prj-nmsc.adb (Find_Sources): Use the Display_Value for each + directory, instead of the Value. + (Find_Source_Dirs): Remove useless code & comments. + +2004-03-15 Ed Schonberg + + * exp_ch3.adb (Freeze_Record_Type): If a primitive operation of a + tagged type is inherited, and the parent operation is not frozen yet, + force generation of a freeze node for the inherited operation, so the + corresponding dispatch entry is properly initialized. + (Make_Predefined_Primitive_Specs): Check that return type is Boolean + when looking for user-defined equality operation. + + * exp_ch4.adb (Expand_Composite_Equality): Check that return type is + boolean when locating primitive equality of tagged component. + + * exp_ch5.adb (Expand_Assign_Array): If the left-hand side is a + bit-aligned field and the right-hand side a string literal, introduce + a temporary before expanding assignment into a loop. + + * exp_ch9.adb (Expand_N_Task_Type_Declaration): Copy expression for + priority in full, to ensure that any expanded subepxressions of it are + elaborated in the scope of the init_proc. + + * exp_prag.adb (Expand_Pragma_Import): Search for initialization call + after object declaration, skipping over code that may have been + generated for validity checks. + + * sem_ch12.adb (Validate_Private_Type_Instance): If type has unknown + discriminants, ignore the known discriminants of its full view, if + any, to check legality. + + * sem_ch3.adb (Complete_Private_Subtype): Do not create constrained + component if type has unknown discriminants. + (Analyze_Private_Extension_Declaration): Discriminant constraint is + null if type has unknown discriminants. + + * sem_ch6.adb (Analyze_Generic_Subprogram_Body): Generate reference + for end label when present. + + * s-fileio.adb (Open): When called with a C_Stream, use given name for + temporary file, rather than an empty string. + +2004-03-15 Ed Falis + + * s-thread.adb: Removed, no longer used. + +2004-03-15 Richard Kenner + + * decl.c (target.h): Now include. + (gnat_to_gnu_entity, case E_Access_Type): Use mode derived from ESIZE + in new build_pointer_from_mode calls for non-fat/non-thin pointer. + (validate_size): For POINTER_TYPE, get smallest size permitted on + machine. + + * fe.h: Sort Einfo decls and add Set_Mechanism. + + * Makefile.in: (LIBGNAT_SRCS): Remove types.h. + (ada/decl.o): Depends on target.h. + + * trans.c (tree_transform, N_Unchecked_Type_Conversion): Do not use + FUNCTION_BOUNDARY; always use TYPE_ALIGN. + +2004-03-15 Thomas Quinot + + * 5ztpopsp.adb, 56tpopsp.adb: Fix spelling of Task_ID. + + * exp_ch4.adb (Expand_N_Indexed_Component): Do not call + Insert_Dereference_Action when rewriting an implicit dereference into + an explicit one, this will be taken care of during expansion of the + explicit dereference. + (Expand_N_Slice): Same. Always do the rewriting, even for the case + of non-packed slices, since the dereference action generated by + expansion of the explicit dereference is needed in any case. + (Expand_N_Selected_Component): When rewriting an implicit dereference, + analyze and resolve the rewritten explicit dereference so it is seen + by the expander. + (Insert_Dereference_Action): This procedure is now called only for the + expansion of an N_Explcit_Dereference_Node. Do insert a check even for + dereferences that do not come from source (including explicit + dereferences resulting from rewriting implicit ones), but do not + recursively insert a check for the dereference nodes contained within + the check. + (Insert_Dereference_Action): Clarify and correct comment. + +2004-03-08 Paolo Bonzini + + PR ada/14131 + Move language detection to the top level. + * config-lang.in: Build by default. + +2004-03-05 Robert Dewar + + * 56taprop.adb, 5ataprop.adb: Remove unneeded unchecked conversions + + * a-tags.adb, a-tags.ads, s-finimp.adb, s-finroo.ads, + i-cpoint.ads, i-cpoint.adb, i-cstrin.adb, i-cstrin.ads, + 5iosinte.ads, 5sosinte.ads, 5staspri.ads, 5itaprop.adb, + 5staprop.adb, 5wtaprop.adb, s-tataat.ads, s-tataat.adb: Move + unchecked conversion to spec to avoid warnings. + + * s-tasini.adb, s-taskin.ads, 5atpopsp.adb: Correct spelling Task_Id + to Task_ID + + * 7stpopsp.adb: Correct casing in To_Task_ID call + + * a-strsea.ads, a-strsea.adb: Minor reformatting + + * einfo.ads, einfo.adb: Define new flag No_Strict_Aliasing + + * errout.ads: Switch for VMS is now NO_STRICT_ALIASING. + Adjust Max_Msg_Length to be clearly large enough. + + * fe.h: Define In_Same_Source_Unit + + * osint.adb: Add pragma Warnings Off to suppress warnings + * g-dyntab.adb, g-table.adb, g-thread.adb: Add Warnings (Off) to kill + aliasing warnings. + + * opt.ads: Put entries in alpha order. Add entry for No_Strict_Aliasing + + * par-prag.adb: Add dummy entry for No_Strict_Aliasing pragma + + * sem_ch13.adb: Generate validate unchecked conversion nodes for gcc. + + * sem_ch3.adb: Set No_Strict_Aliasing flag if config pragma set. + + * sem_prag.adb: Implement pragma No_Strict_Aliasing. + + * sinfo.ads: Remove obsolete comment on validate unchecked conversion + node. We now do generate them for gcc back end. + + * table.adb, sinput.adb: Add pragma Warnings Off to suppress aliasing + warning. + + * sinput-c.adb: Fix bad name in header. + Add pragma Warnings Off to suppress aliasing warning. + + * sinput-l.adb: Add pragma Warnings Off to suppress aliasing warning. + + * snames.h, snames.ads, snames.adb: Add entry for pragma + No_Strict_Aliasing. + +2004-03-05 Vincent Celier + + * prj-com.ads: Add hash table Files_Htable to check when a file name + is already a source of another project. + + * prj-nmsc.adb (Record_Source): Before recording a new source, check + if its file name is not already a source of another project. Report an + error if it is. + + * gnatcmd.adb: When GNAT PRETTY is invoked with a project file and no + source file name, call gnatpp with all the sources of the main project. + + * vms_conv.adb (Initialize): GNAT PRETTY may be called with any number + of file names. + + * vms_data.ads: Correct documentation of new /OPTIMIZE keyword + NO_STRICT_ALIASING. Add new qualifier for GNAT PRETTY: + /RUNTIME_SYSTEM=, converted to --RTS= + /NOTABS, converted to -notabs + +2004-03-05 Pascal Obry + + * make.adb: Minor reformatting. + +2004-03-05 Ed Schonberg + + Part of implemention of AI-262. + * par-ch10.adb (P_Context_Clause): Recognize private with_clauses. + + * sem_ch10.ads, sem_ch10.adb: (Install_Private_With_Clauses): New + procedure. + + * sem_ch3.adb (Analyze_Component_Declaration): Improve error message + when component type is a partially constrained class-wide subtype. + (Constrain_Discriminated_Type): If parent type has unknown + discriminants, a constraint is illegal, even if full view has + discriminants. + (Build_Derived_Record_Type): Inherit discriminants when deriving a type + with unknown discriminants whose full view is a discriminated record. + + * sem_ch7.adb (Preserve_Full_Attributes): Preserve Has_Discriminants + flag, to handle properly derivations of tagged types with unknown + discriminants. + (Analyze_Package_Spec, Analyze_Package_Body): Install + Private_With_Clauses before analyzing private part or body. + + * einfo.ads: Indicate that both Has_Unknown_Discriminants and + Has_Discriminants can be true for a given type (documentation). + +2004-03-05 Arnaud Charlet + + * s-restri.ads: Fix license (GPL->GMGPL). + + * s-tassta.adb: Minor reformatting. + + * s-tasren.adb: Replace manual handling of Self_Id.ATC_Nesting_Level + by calls to Exit_One_ATC_Level, since additional clean up is performed + by this function. + + * s-tpobop.adb: Replace manual handling of Self_Id.ATC_Nesting_Level + by calls to Exit_One_ATC_Level, since additional clean up is performed + by this function. + +2004-03-05 Richard Kenner + + * trans.c: Reflect GCC changes to fix bootstrap problem. + Add warning for suspicious aliasing unchecked conversion. + +2004-03-05 GNAT Script + + * Make-lang.in: Makefile automatically updated + +2004-03-02 Emmanuel Briot + + * ali.adb (Read_Instantiation_Instance): Do not modify the + current_file_num when reading information about instantiations, since + this corrupts files in later references. + +2004-03-02 Vincent Celier + + * bcheck.adb (Check_Consistency): Get the full path of an ALI file + before checking if it is read-only. + + * bld.adb (Recursive_Process): Concatenate .src_dirs in front + of SRC_DIRS and eliminate duplicates. + + * gprcmd.adb: Replace command "path" with command "path_sep" to return + the path separator. + (Usage): Document path_sep + + * Makefile.generic: For Ada and GNU C++ cases, link directly with the + C++ compiler. No need for a script. + Replace use of C*_INCLUDE_PATH env var for GCC compilers with CPATH. + Do not call gprcmd to build the C*_INCLUDE_PATHs, do it with function + subst. + + * prj-env.adb (For_All_Source_Dirs): Only add source dirs in project + where there are Ada sources. + (Set_Ada_Paths): Only add to the include path the source dirs of project + with Ada sources. + (Add_To_Path): Add the Display_Values of the directories, not their + Values. + + * prj-nmsc.adb (Find_Sources): Set flag Sources_Present in the project + data. + + * prj-nmsc.adb (Add_ALI_For): Make sure that the element Display_Value + is not No_Name. + (Find_Source_Dirs): Set Display_Value to a non canonicalized value, only + Value is canonicalized. + (Language_Independent_Check): Do not copy Value to Display_Value when + canonicalizing Value. + + * prj-part.adb (Post_Parse_Context_Clause): Compare canonical cased + path to find limited with cycles. + (Parse_Single_Project): Use canonical cased path to find the end of a + with cycle. + +2004-03-02 Ed Schonberg + + * sem_ch10.adb (Optional_Subunit): Verify that unit contains a subunit + and not a child unit. + + * sinfo.ads, sinfo.adb: Rearrange flags so that Private_Present can + appear in a with_clause. + + * decl.c (gnat_to_gnu_type): If entity is a generic type, which can + only happen in type_annotate mode, do not try to elaborate it. + + * exp_util.adb (Force_Evaluation): If expression is a selected + component on the left of an assignment, use a renaming rather than a + temporary to remove side effects. + + * freeze.adb (Freeze_Entity): Do not freeze a global entity within an + inlined instance body, which is analyzed before the end of the + enclosing scope. + +2004-03-02 Robert Dewar + + * par-ch10.adb, par-ch3.adb, par-ch4.adb, scng.adb, + sem_ch4.adb: Use new feature for substitution of keywords in VMS + + * errout.ads, errout.adb: Implement new circuit for substitution of + keywords in VMS. + + * sem_case.adb (Analyze_Choices): Place message properly when case is + a subtype reference rather than an explicit range. + + * sem_elim.adb, s-tpobop.ads, exp_ch2.adb: Minor reformatting + +2004-03-02 Doug Rupp + + * init.c (__gnat_initialize)[VMS]: Resignal RDB-E-STREAM_EOF. + +2004-03-02 Thomas Quinot + + * s-tporft.adb: Add missing locking around call to Initialize_ATCB. + +2004-03-02 Richard Kenner + + * utils.c (finish_record_type): Do not set DECL_NONADDRESSABLE for a + BLKmode bitfield. + +2004-02-25 Robert Dewar + + * 51osinte.ads, 52osinte.ads, 53osinte.ads, 54osinte.ads, + 55osinte.ads, 56osinte.ads, 5aosinte.ads, 5bosinte.ads, + 5cosinte.ads, 5fosinte.ads, 5gosinte.ads, 5hosinte.ads, + 5iosinte.ads, 5losinte.ads, 5nosinte.ads, 5oosinte.ads, + 5posinte.ads, 5sosinte.ads, 5tosinte.ads, 5vosinte.ads, + 5wosinte.ads, 5zosinte.ads: Move instances of Unchecked_Conversion to + the defining instance of the type to avoid aliasing problems. + Fix copyright header. Fix bad comments in package header. + + * exp_util.adb, prj-part.adb, prj-part.adb: Minor reformatting + +2004-02-25 Ed Schonberg + + * exp_ch2.adb (Param_Entity): Handle properly formals that have been + rewritten as references when aliased through an address clause. + + * sem_ch4.adb (Try_Indirect_Call): Normalize actuals before checking + whether call can be interpreted as an indirect call to the result of a + parameterless function call returning an access subprogram. + +2004-02-25 Arnaud Charlet + + Code clean up: + * exp_ch7.adb (Make_Clean): Remove generation of calls to + Unlock[_Entries], since this is now done by Service_Entries directly. + + * exp_ch9.adb (Build_Protected_Subprogram_Body): ditto. + + * s-tpobop.ads, s-tpobop.adb (PO_Service_Entries): New nested procedure + Requeue_Call for better code readability. Change spec and update calls: + PO_Service_Entries now unlock the PO on exit. + (Protected_Entry_Call, Timed_Protected_Entry_Call): Update calls to + PO_Service_Entries. + + * s-tposen.ads, s-tposen.adb (Service_Entry): Now unlock the PO on exit. + + * s-taenca.adb, s-tasren.adb: Update calls to PO_Service_Entries. + +2004-02-25 Sergey Rybin + + * exp_ch9.adb (Build_Simple_Entry_Call): Prevent expanding the + protected subprogram call and analyzing the result of such expanding + in case when the called protected subprogram is eliminated. + + * sem_elim.adb (Check_Eliminated): Skip blocks when comparing scope + names. + +2004-02-25 Jerome Guitton + + * Makefile.in: Clean ups. + +2004-02-23 Ed Schonberg + + * exp_ch6.adb (Expand_N_Subprogram_Declaration): Do not create + protected operations if original subprogram is flagged as eliminated. + (Expand_N_Subprogram_Body): For a protected operation, create + discriminals for next operation before checking whether the operation + is eliminated. + + * exp_ch9.adb (Expand_N_Protected_Body, + Expand_N_Protected_Type_Declaration): Do not generate specs and bodies + for internal protected operations if the original subprogram is + eliminated. + + * sem_elim.adb (Check_Eliminated): Handle properly protected operations + declared in a single protected object. + +2004-02-23 Vincent Celier + + * prj-attr.adb: Make attribute Builder'Executable an associative array, + case insensitive if file names are case insensitive, instead of a + standard associative array. + + * prj-attr.adb (Initialize): For 'b' associative arrays, do not set + them as case insensitive on platforms where the file names are case + sensitive. + + * prj-part.adb (Parse_Single_Project): Make sure, when checking if + project file has already been parsed that canonical path are compared. + +2004-02-23 Robert Dewar + + * sinput-c.ads: Correct bad unit title in header + + * freeze.adb: Minor reformatting + +2004-02-23 Richard Kenner + + * trans.c (tree_transform, case N_Procedure_Call_Statement): For + nonaddressable COMPONENT_REF that is removing padding that we are + taking the address of, take the address of the padded record instead + if item is variable size. + +2004-02-20 Robert Dewar + + * bld.adb, exp_util.adb, gprcmd.adb: Minor reformatting + +2004-02-20 Ed Schonberg + + * freeze.adb (Freeze_Record_Type): Generalize mechanism that generates + itype references for the constrained designated type of a component + whose base type is already frozen. + +2004-02-20 Arnaud Charlet + + * init.c (__gnat_error_handler [tru64]): Rewrite previous change to + avoid GCC warnings. + +2004-02-20 Sergey Rybin + + * sem_ch12.adb (Analyze_Formal_Package): Create a new defining + identifier for a phantom package that rewrites the formal package + declaration with a box. The Add semantic decorations for the defining + identifier from the original node (that represents the formal package). + +2004-02-19 Matt Kraai + + * Make-lang.in (ada/stamp-sdefault): Use the top level + move-if-change. + +2004-02-19 Richard Henderson + + * misc.c (record_code_position): Add third build arg for RTL_EXPR. + +2004-02-18 Emmanuel Briot + + * ali.ads, ali.adb (First_Sdep_Entry): No longer a constant, so that + Scan_ALI can be used for multiple ALI files without reinitializing + between calls. + +2004-02-18 Robert Dewar + + * debug.adb: Minor reformatting. + +2004-02-18 Richard Kenner + + * decl.c (gnat_to_gnu_entity, case object): Set DECL_POINTER_ALIAS_SET + to zero if there is an address clause. + +2004-02-18 Thomas Quinot + + * exp_util.adb (Side_Effect_Free): Any literal is side effects free. + +2004-02-18 Gary Dismukes + + * layout.adb (Layout_Component_List): Revise generation of call to + discriminant-checking function to pass selections of all of the type's + discriminants rather than just the variant-controlling discriminant. + +2004-02-18 Olivier Hainque + + * 5gmastop.adb (Pop_Frame): Do not call exc_unwind, which is bound to + fail in the current setup and triggers spurious system error messages. + Pretend it occurred and failed instead. + +2004-02-18 Vincent Celier + + * bld.adb: Mark FLDFLAGS as saved + (Process_Declarative_Items): Add Linker'Linker_Options to FLDFLAGS when + it is not the root project. Put each directory to be + extended between double quotes to prevent it to be expanded on Windows. + (Recursive_Process): Reset CFLAGS/CXXFLAGS to nothing before processing + the project file. Set them back to their initial values if they have not + been set in the project file. + + * gprcmd.adb: (Gprdebug, Debug): New global variables + (Display_Command): New procedure + (Usage): Document new command "linkopts" + Call Display_Command when env var GPRDEBUG has the value "TRUE" + Implement new command "linkopts" + Remove quotes that may be around arguments for "extend" + Always call Normalize_Pathname with arguments formatted for the platform + + * Makefile.generic: Link C/C++ mains with $(FLDFLAGS) + Change @echo to @$(display) in target clean to be able to clean silently + + * Makefile.prolog: Save FLDFLAGS and give it an initial empty value + + * prj-part.adb (Project_Path_Name_Of): Do not put final result in + canonical case. + + * prj-part.adb (Parse_Single_Project): Always call with From_Extended + = Extending_All when current project is an extending all project. + + * vms_conv.adb (Output_File_Expected): New Boolean global variable, + set to True only for LINK command, after Unix switch -o. + (Process_Arguments): Set Output_File_Expected to True for LINK command + after Unix switch -o. When Output_File_Expected is True, never add an + extension to a file name. + + * 5vml-tgt.adb (Build_Dynamic_Library): Do not append "/OPTIONS" to the + option file name, only to the --for-linker= switch. + (Option_File_Name): If option file name do not end with ".opt", append + "/OPTIONS". + +2004-02-18 GNAT Script + + * Make-lang.in: Makefile automatically updated + +2004-02-17 Matt Kraai + + * Make-lang.in (stamp-sdefault): Do not depend on + move-if-change. + +2004-02-12 Zack Weinberg + + * config-lang.in: Disable Ada by default until probe logic for + a bootstrap Ada compiler can be moved to the top level configure + script. + +2004-02-12 Olivier Hainque + + * decl.c (components_to_record): Don't claim that the internal fields + we make to hold the variant parts are semantically addressable, because + they are not. + + * exp_pakd.adb (Create_Packed_Array_Type): Rename Esiz into PASize and + adjust the comment describing the modular type form when we can use it. + (Install_PAT): Account for the Esiz renaming. + + * init.c (__gnat_error_handler for alpha-tru64): Arrange to clear the + sc_onstack context indication before raising the exception to which + the signal is mapped. Allows better handling of later signals possibly + triggered by the resumed user code if the exception is handled. + +2004-02-12 Arnaud Charlet + + * 5zinit.adb: Removed, no longer used. + +2004-02-12 Robert Dewar + + * ali.adb: Remove separating space between parameters on R line. Makes + format consistent with format used by the binder for Set_Globals call. + + * atree.ads, atree.adb: Minor reformatting (new function header format) + + * bindgen.adb: Add Run-Time Globals documentation section containing + detailed documentation of the globals passed from the binder file to + the run time. + + * gnatls.adb: Minor reformatting + + * init.c (__gnat_set_globals): Add note pointing to documentation in + bindgen. + + * lib-writ.ads, lib-writ.adb: Remove separating space between + parameters on R line. + Makes format consistent with format used by the binder for Set_Globals + call. + + * osint.ads: Add 2004 to copyright notice + Minor reformatting + + * snames.ads: Correct capitalization of FIFO_Within_Priorities + Noticed during code reading, documentation issue only + + * usage.adb: Remove junk line for obsolete C switch + Noticed during code reading + +2004-02-12 Vincent Celier + + * bld.adb (Process_Declarative_Items): For Source_Dirs call gprcmd + extend for each directory, so that multiple /** directories are + extended individually. + (Recursive_Process): Set the default for LANGUAGES to ada + + * gprcmd.adb: Define new command "ignore", to do nothing. + Implement new comment "path". + + * Makefile.generic: Suppress output when SILENT is set + Make sure that when compiler for C/C++ is gcc, the correct -x switch is + used, so that the correct compiler is invoked. + When compiler is gcc/g++, put search path in env vars C_INCLUDE_PATH/ + CXX_INCLUDE_PATH, to avoid failure with too long command lines. + +2004-02-12 Jerome Guitton + + * Makefile.in: Clean ups and remove obsolete targets. + +2004-02-12 Ed Schonberg + + * exp_ch5.adb: Remove Possible_Unligned_Slice, in favor of the similar + predicate declared in exp_util. + + * exp_util.adb: Add comments. + + * sem_ch10.adb (Analyze_Subunit): Remove ultimate parent unit from + visibility before compiling context of the subunit. + + * sem_res.adb (Check_Parameterless_Call): If the context expects a + value but the name is a procedure, do not attempt to analyze as a call, + in order to obtain more telling diagnostics. + + * sem_util.adb (Wrong_Type): Further enhancement to diagnose missing + 'Access on parameterless function calls. + (Normalize_Actuals): For a parameterless function call with missing + actuals, defer diagnostic until resolution of enclosing call. + + * sem_util.adb (Wrong_Type): If the context type is an access to + subprogram and the expression is a procedure name, suggest a missing + 'attribute. + +2004-02-10 Arnaud Charlet , + Nathanael Nerode + + PR ada/6637 + PR ada/5911 + Merge with libada-branch: + * config-lang.in: Build libada only when ada is built. + +2004-02-09 Ed Schonberg + + * exp_ch4.adb (Expand_N_Op_Eq): When looking for the primitive equality + for a tagged type, verify that both formals have the same type. + + * exp_ch6.adb (Add_Call_By_Copy_Code): Initialize properly the + temporary when the formal is an in-parameter and the actual a possibly + unaligned slice. + + * exp_ch9.adb (Expand_Entry_Barrier): Resolve barrier expression even + when expansion is disabled, to ensure proper name capture with + overloaded literals. Condition can be of any boolean type, resolve + accordingly. + + * sem_ch8.adb (Analyze_Subprogram_Renaming): Emit warning if the + renaming is for a formal subprogram with a default operator name, and + there is a usable operator that is visible at the point of + instantiation. + +2004-02-09 Robert Dewar + + * ali.adb (Scan_Ali) Add Ignore_Errors argument. This is a major + rewrite to ignore errors in ali files, intended to allow tools downward + compatibility with new versions of ali files. + + * ali.ads: Add new parameter Ignore_Errors + + * bcheck.adb (Check_Consistent_Restrictions): Fix error of sometimes + duplicating the error message giving the file with restrictions. + + * debug.adb: Add debug flag I for gnatbind + + * errout.adb (Set_Msg_Insertion_Node): Suppress extra quotes around + operators for the case where the operator is a defining operator. + + * exp_ch3.adb: Minor reformatting (new function spec format). + + * exp_ch4.adb: Add comment for previous change, and make minor + adjustment to loop to always check for improper loop termination. + Minor reformatting throughout (new function spec format). + + * gnatbind.adb: Implement -di debug flag for gnatbind + + * gnatlink.adb: Call Scan_ALI with Ignore_Errors set to True + + * gnatls.adb: Call Scan_ALI with Ignore_Errors set to True + + * lib-load.adb: Fix bad assertion. + Found by testing and code reading. + Minor reformatting. + + * lib-load.ads: Minor reformatting. + + * lib-writ.adb: There is only one R line now. + + * lib-writ.ads: Add documentation on making downward compatible changes + to ali files so old tools work with new ali files. + There is only one R line now. + Add documentation on format incompatibilities (with special GPS note) + + * namet.ads, namet.adb: (Is_Operator_Name): New procedure + + * par-load.adb: Minor reformatting + + * sem_ch8.adb: Fix to error message from last update + Minor reformatting and restructuring of code from last update + + * par-prag.adb, snames.adb, snames.ads, snames.h, + sem_prag.adb: Implement pragma Profile. + + * stylesw.adb: Implement -gnatyN switch to turn off all style check + options. + + * usage.adb: Add line for -gnatyN switch + + * vms_data.ads: Add entry STYLE_CHECKS=NONE for -gnatyN + +2004-02-09 Albert Lee + + * errno.c: define _SGI_MP_SOURCE for task-safe errno on IRIX + +2004-02-09 Ed Schonberg + + * exp_ch3.adb (Build_Slice_Assignment): Handle properly case of null + slices. + + * exp_ch6.adb (Expand_Call): Do not inline a call when the subprogram + is nested in an instance that is not frozen yet, to avoid + order-of-elaboration problems in gigi. + + * sem_attr.adb (Analyze_Attribute, case 'Access): Within an inlined + body the attribute is legal. + +2004-02-09 Robert Dewar + + * s-rident.ads: Minor comment correction + + * targparm.adb: Remove dependence on uintp completely. There was + always a bug in Make in that it called Targparm before initializing + the Uint package. The old code appeared to get away with this, but + the new code did not! This caused an assertion error in gnatmake. + + * targparm.ads: Fix bad comment, restriction pragmas with parameters + are indeed fully supported. + +2004-02-06 Alan Modra + + * misc.c (default_pass_by_ref): Update INIT_CUMULATIVE_ARGS call. + +2004-02-05 Kazu Hirata + + * ada/utils.c (create_param_decl): Replace PROMOTE_PROTOTYPES + with targetm.calls.promote_prototypes. + +2004-02-04 Robert Dewar + + * 5gtasinf.adb, 5gtasinf.ads, 5gtaprop.adb, ali.adb, + ali.ads, gprcmd.adb: Minor reformatting + + * bindgen.adb: Output restrictions string for new style restrictions + handling + + * impunit.adb: Add s-rident.ads (System.Rident) and + s-restri (System.Restrictions) + + * lib-writ.adb: Fix bug in writing restrictions string (last few + entries wrong) + + * s-restri.ads, s-restri.adb: Change name Restrictions to + Run_Time_Restrictions to avoid conflict with package name. + Add circuit to read and acquire run time restrictions. + +2004-02-04 Jose Ruiz + + * restrict.ads, restrict.adb: Use the new restriction + No_Task_Attributes_Package instead of the old No_Task_Attributes. + + * sem_prag.adb: No_Task_Attributes is a synonym of + No_Task_Attributes_Package. + + * snames.ads, snames.adb: New entry for proper handling of + No_Task_Attributes. + + * s-rident.ads: Adding restriction No_Task_Attributes_Package + (AI-00249) that supersedes the GNAT specific restriction + No_Task_Attributes. + +2004-02-04 Ed Schonberg + + * sem_prag.adb: + (Analyze_Pragma, case Warnings): In an inlined body, as in an instance + body, an identifier may be wrapped in an unchecked conversion. + +2004-02-04 Vincent Celier + + * lib-writ.ads: Comment update for the W lines + + * bld.adb: (Expression): An empty string list is static + + * fname-uf.adb: Minor comment update + + * fname-uf.ads: (Get_File_Name): Document new parameter May_Fail + + * gnatbind.adb: Initialize Cumulative_Restrictions with the + restrictions on the target. + +2004-02-03 Kazu Hirata + + * ada/trans.c (gigi): Use gen_rtx_SYMBOL_REF instead of + gen_rtx. + +2004-02-02 Arnaud Charlet + + * Makefile.in: Remove setting of THREADSLIB on mips o32, unneeded. + +2004-02-02 Vincent Celier + + * gprcmd.adb (Check_Args): If condition is false, print the invoked + comment before the usage. + Gprcmd: Fail when command is not recognized. + (Usage): Document command "prefix" + + * g-md5.adb (Digest): Process last block. + (Update): Do not process last block. Store remaining characters and + length in Context. + + * g-md5.ads (Update): Document that several call to update are + equivalent to one call with the concatenated string. + (Context): Add fields to allow new Update behaviour. + + * fname-uf.ads/adb (Get_File_Name): New Boolean parameter May_Fail, + defaulted to False. + When May_Fail is True and no existing file can be found, return No_File. + + * 6vcstrea.adb: Inlined functions are now wrappers to implementation + functions. + + * lib-writ.adb (Write_With_Lines): When body file does not exist, use + spec file name instead on the W line. + +2004-02-02 Robert Dewar + + * ali.adb: Read and acquire info from new format restrictions lines + + * bcheck.adb: Add circuits for checking restrictions with parameters + + * bindgen.adb: Output dummy restrictions data + To be changed later + + * ali.ads, checks.adb, exp_aggr.adb, exp_attr.adb, exp_ch11.adb, + exp_ch3.adb, exp_ch5.adb, exp_ch6.adb, exp_ch7.adb, exp_util.adb, + freeze.adb, gnat1drv.adb, sem_attr.adb, sem_ch10.adb, sem_ch11.adb, + sem_ch12.adb, targparm.adb, targparm.ads, tbuild.adb, sem_ch2.adb, + sem_elab.adb, sem_res.adb: Minor changes for new restrictions handling. + + * exp_ch9.adb (Build_Master_Entity): Cleanup the code (also suppresses + the warning message on access to possibly uninitialized variable S) + Minor changes for new restrictions handling. + + * gnatbind.adb: Minor reformatting + Minor changes for new restrictions handling + Move circuit for -r processing here from bcheck (cleaner) + + * gnatcmd.adb, gnatlink.adb: Minor reformatting + + * lib-writ.adb: Output new format restrictions lines + + * lib-writ.ads: Document new R format lines for new restrictions + handling. + + * s-restri.ads/adb: New files + + * Makefile.rtl: Add entry for s-restri.ads/adb + + * par-ch3.adb: Fix bad error messages starting with upper case letter + Minor reformatting + + * restrict.adb: Major rewrite throughout for new restrictions handling + Major point is to handle restrictions with parameters + + * restrict.ads: Major changes in interface to handle restrictions with + parameters. Also generally simplifies setting of restrictions. + + * snames.ads/adb: New entry for proper handling of No_Requeue + + * sem_ch3.adb (Count_Tasks): New circuitry for implementing Max_Tasks + restriction counting. + Other minor changes for new restrictions handling + + * sem_prag.adb: No_Requeue is a synonym for No_Requeue_Statements. + Restriction_Warnings now allows full parameter notation + Major rewrite of Restrictions for new restrictions handling + +2004-02-02 Javier Miranda + + * par-ch3.adb (P_Identifier_Declarations): Give support to the Ada 0Y + syntax rule for object renaming declarations. + (P_Array_Type_Definition): Give support for the Ada 0Y syntax rule for + component definitions. + + * sem_ch3.adb (Analyze_Component_Declaration): Give support to access + components. + (Array_Type_Declaration): Give support to access components. In addition + it was also modified to reflect the name of the object in anonymous + array types. The old code did not take into account that it is possible + to have an unconstrained anonymous array with an initial value. + (Check_Or_Process_Discriminants): Allow access discriminant in + non-limited types. + (Process_Discriminants): Allow access discriminant in non-limited types + Initialize the new Access_Definition field in N_Object_Renaming_Decl + node. Change Ada0Y to Ada 0Y in comments + + * sem_ch4.adb (Find_Equality_Types): Allow anonymous access types in + equality operators. + Change Ada0Y to Ada 0Y in comments + + * sem_ch8.adb (Analyze_Object_Renaming): Give support to access + renamings Change Ada0Y to Ada 0Y in comments + + * sem_type.adb (Find_Unique_Type): Give support to the equality + operators for universal access types + Change Ada0Y to Ada 0Y in comments + + * sinfo.adb (Access_Definition, Set_Access_Definition): New subprograms + + * sinfo.ads (N_Component_Definition): Addition of Access_Definition + field. + (N_Object_Renaming_Declaration): Addition of Access_Definition field + Change Ada0Y to Ada 0Y in comments + + * sprint.adb (Sprint_Node_Actual): Give support to the new syntax for + component definition and object renaming nodes + Change Ada0Y to Ada 0Y in comments + +2004-02-02 Jose Ruiz + + * restrict.adb: Use the new restriction identifier + No_Requeue_Statements instead of the old No_Requeue for defining the + restricted profile. + + * sem_ch9.adb (Analyze_Requeue): Check the new restriction + No_Requeue_Statements. + + * s-rident.ads: Adding restriction No_Requeue_Statements (AI-00249) + that supersedes the GNAT specific restriction No_Requeue. The later is + kept for backward compatibility. + +2004-02-02 Ed Schonberg + + * lib.ads, i-cobol.ads, * s-stoele.ads, s-thread.ads, style.ads, + 5staprop.adb, atree.adb, atree.ads, g-crc32.ads: Remove redundant + pragma and fix incorrect ones. + + * sem_prag.adb For pragma Inline and pragma Pure_Function, emit a + warning if the pragma is redundant. + +2004-02-02 Thomas Quinot + + * 5staprop.adb: Add missing 'constant' keywords. + + * Makefile.in: use consistent value for SYMLIB on + platforms where libaddr2line is supported. + +2004-02-02 Richard Kenner + + * utils.c (end_subprog_body): Do not call rest_of_compilation if just + annotating types. + +2004-02-02 Olivier Hainque + + * init.c (__gnat_install_handler): Setup an alternate stack for signal + handlers in the environment thread. This allows proper propagation of + an exception on stack overflows in this thread even when the builtin + ABI stack-checking scheme is used without support for a stack reserve + region. + + * utils.c (create_field_decl): Augment the head comment about bitfield + creation, and don't account for DECL_BIT_FIELD in DECL_NONADDRESSABLE_P + here, because the former is not accurate enough at this point. + Let finish_record_type decide instead. + Don't make a bitfield if the field is to be addressable. + Always set a size for the field if the record is packed, to ensure the + checks for bitfield creation are triggered. + (finish_record_type): During last pass over the fields, clear + DECL_BIT_FIELD when possible in the !STRICT_ALIGNMENT case, as this is + not covered by the calls to layout_decl. Adjust DECL_NONADDRESSABLE_P + from DECL_BIT_FIELD. + +2004-01-30 Kelley Cook + + * Make-lang.in (doc/gnat_ug_unx.dvi): Use $(abs_docdir). + (doc/gnat_ug_vms.dvi, doc/gnat_ug_unx.dvi): Likewise. + (doc/gnat_ug_unx.dvi, doc/gnat-style.dvi): Likewise. + +2004-01-26 Rainer Orth + + * Makefile.in (mips-sgi-irix5): Remove -lathread from THREADSLIB. + + * 5fsystem.ads (Functions_Return_By_DSP): Set to False. + (ZCX_By_Default): Likewise. + (Front_End_ZCX_Support): Likewise. + + * 5gtaprop.adb (Stack_Guard): Mark T, On unreferenced. + (Initialize_Lock): Mark Level unreferenced. + (Sleep): Mark Reason unreferenced. + (Timed_Sleep): Likewise. + (Wakeup): Likewise. + (Exit_Task): Use Result. + (Check_No_Locks): Mark Self_ID unreferenced. + + * 5gtasinf.adb (New_Sproc): Make Attr constant. + (Bound_Thread_Attributes): Make Sproc constant. + (New_Bound_Thread_Attributes): Likewise. + +2004-01-26 Ed Schonberg + + * exp_ch3.adb (Build_Slice_Assignment): New TSS procedure for + one-dimensional array an slice assignments, when component type is + controlled. + + * exp_ch5.adb (Expand_Assign_Array): If array is one-dimensional, + component type is controlled, and control_actions are in effect, use + TSS procedure rather than generating inline code. + + * exp_tss.ads (TSS_Slice_Assign): New TSS procedure for one-dimensional + arrays with controlled components. + +2004-01-26 Vincent Celier + + * gnatcmd.adb (GNATCmd): Add specification of argument file on the + command line for the non VMS case. + + * gnatlink.adb (Process_Binder_File): When building object file, if + GNU linker is used, put all object paths between quotes, to prevent ld + error when there are unusual characters (such as '!') in the paths. + + * Makefile.generic: When there are sources in Ada and the main is in + C/C++, invoke gnatmake with -B, instead of -z. + + * vms_conv.adb (Preprocess_Command_Data): New procedure, extracted + from VMS_Conversion. + (Process_Argument): New procedure, extracted from VMS_Conversion. Add + specification of argument file on the command line. + +2004-01-26 Bernard Banner + + * Makefile.in: Enable GMEM_LIB and SYMLIB for x86_64 + +2004-01-26 Ed Schonberg + + * snames.adb: Update copyright notice. + Add info on slice assignment for controlled arrays. + +2004-01-23 Robert Dewar + + * exp_aggr.adb: Minor reformatting + + * exp_ch9.adb: Minor code clean up + Minor reformatting + Fix bad character in comment + + PR ada/13471 + * targparm.adb (Get_Target_Parameters): Give clean abort error on + unexpected end of file, along with more detailed message. + +2004-01-23 Richard Kenner + + * exp_pakd.adb (Install_PAT): Clear Freeze_Node for PAT and Etype of + PAT. + + * decl.c (copy_alias_set): New function. + (gnat_to_gnu_entity, make_aligning_type, make_packable_type): Use it. + +2004-01-23 Doug Rupp + + * Makefile.in (install-gnatlib): Change occurrences of lib$$file to + lib$${file} in case subsequent character is not a separator. + +2004-01-23 Vincent Celier + + * 5vml-tgt.adb (Build_Dynamic_Library): Invoke gcc with -shared-libgcc + when the GCC version is at least 3. + + * make.adb: (Scan_Make_Arg): Pass -B to Scan_Make_Switches + Remove all "Opt.", to prepare for opt split + + * prj-part.adb (Parse_Single_Project): New Boolean out parameter + Extends_All. Set to True when the project parsed is an extending all + project. Fails for importing an extending all project only when the + imported project is an extending all project. + (Post_Parse_Context_Clause): Set Is_Extending_All to the with clause, + depending on the value of Extends_All returned. + + * prj-proc.adb (Process): Check that no project shares its object + directory with a project that extends it, directly or indirectly, + including a virtual project. + Check that no project extended by another project shares its object + directory with another also extended project. + + * prj-tree.adb (Is_Extending_All, Set_Is_Extending_All): Allow for + Kind = N_With_Clause + + * prj-tree.ads: Minor reformatting + Indicate that Flag2 also applies to N_With_Clause (Is_Extending_All). + +2004-01-23 Ed Schonberg + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause): If the attribute + applies to a type with an incomplete view, use full view in Name of + clause, for consistency with uses of Get_Attribute_Definition_Clause. + +2004-01-23 Arnaud Charlet + + * 5itaprop.adb (Set_Priority): Reset the priority to 0 when using + SCHED_RR, since other values are not supported by this policy. + (Initialize): Move initialization of mutex attribute to package + elaboration, to prevent early access to this variable. + + * Makefile.in: Remove mention of Makefile.adalib, unused. + + * Makefile.adalib, 1aexcept.adb, 1aexcept.ads, 1ic.ads, 1ssecsta.adb, + 1ssecsta.ads: Removed, unused. + +2004-01-21 Javier Miranda + + * exp_aggr.adb (Build_Record_Aggr_Code): Do not build the master + entity if already built in the current scope. + + * exp_ch9.adb (Build_Master_Entity): Do not set the has_master_entity + reminder in internal scopes. Required for nested limited aggregates. + +2004-01-21 Doug Rupp + + * Makefile.in (hyphen): New variable, default value '-'. Set to '_' on + VMS. Replace all occurences of libgnat- and libgnarl- with + libgnat$(hyphen) and libgnarl$(hyphen). + Fixed shared library build problem on VMS. + +2004-01-21 Robert Dewar + + * mlib-prj.adb: Minor reformatting + +2004-01-21 Thomas Quinot + + * prj-tree.adb, 7staprop.adb, vms_conv.adb, xr_tabls.adb: Add missing + 'constant' keywords for declaration of pointers that are not modified. + + * exp_pakd.adb: Fix English in comment. + +2004-01-21 Ed Schonberg + + PR ada/10889 + * sem_ch3.adb (Analyze_Subtype_Declaration): For an array subtype, + copy all attributes of the parent, including the foreign language + convention. + +2004-01-21 Sergey Rybin + + PR ada/10565 + * sem_ch9.adb (Analyze_Delay_Alternative): Add expression type check + for 'delay until' statement. + +2004-01-20 Kelley Cook + + * Make-lang.in: Replace $(docdir) with doc. + (doc/gnat_ug_unx.info, doc/gnat_ug_vwx.info, doc/gnat_ug_vms.info + doc/gnat_ug_wnt.info, doc/gnat_rm.info, doc/gnat-style.info): Update + to use consistent MAKEINFO rule. + (ada.man, ada.srcman): Dummy entry. + (ADA_INFOFILES): Define. + (ada.info, ada.srcinfo): New rules. + +2004-01-19 Arnaud Charlet + + * utils.c: Update copyright notice, missed in previous change. + +2004-01-19 Vincent Celier + + * mlib-prj.adb (Build_Library.Add_ALI_For): Only add the ALI to the + args if Bind is True. Set First_ALI, if not already done. + (Build_Library): For Stand Alone Libraries, extract from one ALI file + an eventual --RTS switch, for gnatbind, and all backend switches + + --RTS, for linking. + +2004-01-19 Robert Dewar + + * sem_attr.adb, memtrack.adb: Minor reformatting + +2004-01-19 Ed Schonberg + + * exp_ch6.adb (Expand_Call): Remove code to fold calls to functions + that rename enumeration literals. This is properly done in sem_eval. + + * sem_eval.ads, sem_eval.adb (Eval_Call): New procedure to fold calls + to functions that rename enumeration literals. + + * sem_res.adb (Resolve_Call): Use Eval_Call to fold static calls to + functions that rename enumeration literals. + +2004-01-16 Kazu Hirata + + * Make-lang.in (utils.o): Depend on target.h. + * utils.c: Include target.h. + (process_attributes): Use targetm.have_named_sections instead + of ASM_OUTPUT_SECTION_NAME. + +2004-01-16 Andreas Jaeger + + * Makefile.in: Add $(DESTDIR). + +2004-01-15 Olivier Hainque + + * decl.c (gnat_to_gnu_entity, E_Variable): Retrieve the object size + also when not defining if a Size clause applies. That information is + not to be ignored. + +2004-01-15 Arnaud Charlet + + * Makefile.in (install-gnatlib, gnatlib-shared-default): Set up + symbolic links for the shared gnat run time when needed. + +2004-01-15 Vasiliy Fofanov + + * memtrack.adb (Gmem_Initialize): check that gmem.out could be opened + for writing, and terminate with an error message if not. + +2004-01-15 Ed Schonberg + + * sem_attr.adb (Resolve_Attribute, case 'Access): Remove spurious + warning on an access to subprogram in an instance, when the target + type is declared in the same generic unit. + (Eval_Attribute): If 'access is known to fail accessibility check, + rewrite as a raise statement. + +2004-01-15 GNAT Script + + * Make-lang.in: Makefile automatically updated + +2004-01-15 Kelley Cook + + * Make-lang.in (ada.srcextra): Dummy entry. + +2004-01-14 Kelley Cook + + * Make-lang.in: Only regenerate texi files if --enable-maintainer-mode. + +2004-01-13 Ed Schonberg + + * exp_ch3.adb (Build_Assignment): Fix bug in handling of controlled + components that are initialized with aggregates. + +2004-01-13 Vincent Celier + + * gnatlink.adb (Process_Binder_File): To find directory of shared + libgcc, if "gcc-lib" is not a subdirectory, look for the last + subdirectory "lib" in the path of the shared libgnat or libgnarl. + + * make.adb (Gnatmake): If GCC version is at least 3, link with + -shared-libgcc, when there is at least one shared library project. + + * opt.ads (GCC_Version): New integer constant. + + * adaint.c (get_gcc_version): New function. + +2004-01-13 Robert Dewar + + * sem_dist.adb, sem_res.adb, sem_util.adb, + sprint.adb, 3zsocthi.adb, einfo.adb, cstand.adb, + exp_ch4.adb, exp_ch9.adb, exp_dist.adb: Minor reformatting + +2004-01-13 Thomas Quinot + + * s-interr.adb, s-stache.adb, s-taenca.adb, g-regpat.adb, + g-spitbo.adb, 5itaprop.adb: Add missing 'constant' keywords in object + declarations. + +2004-01-12 Arnaud Charlet + + * misc.c: Remove trailing spaces. + Update copyright notice missed in previous change. + + PR ada/13572 + * bld.adb (Recursive_Process): Reference prefix/share/gnat instead of + prefix/share/make + + * Makefile.generic: Update copyright. + Add license notice. + + * Makefile.in (ADA_SHARE_MAKE_DIR): Set to prefix/share/gnat instead + of prefix/share/make. + + * Makefile.prolog: Update copyright. + Add license notice. + +2004-01-12 Laurent Pautet + + * 3vsocthi.adb, 3vsocthi.ads, 3wsocthi.adb, + 3wsocthi.ads, 3zsocthi.adb, 3zsocthi.ads, g-socthi.adb, + g-socthi.ads (Socket_Error_Message): Return C.Strings.chars_ptr + instead of String. + + * g-socket.adb (Raise_Socket_Error): Use new Socket_Error_Message + signature. + +2004-01-12 Javier Miranda + + * cstand.adb, exp_aggr.adb, exp_ch3.adb, exp_ch9.adb, exp_dist.adb, + exp_imgv.adb, exp_pakd.adb, exp_util.adb, par-ch3.adb, sem.adb, + sem_ch12.adb, sem_ch3.adb, sem_dist.adb, sem_prag.adb, sem_res.adb, + sem_util.adb, sinfo.adb, sinfo.ads, sprint.adb: Addition of + Component_Definition node. + +2004-01-12 Ed Falis + + * impunit.adb: Add GNAT.Secondary_Stack_Info as user-visible unit + +2004-01-12 Thomas Quinot + + * link.c: Change default libgnat kind to STATIC for FreeBSD. + +2004-01-12 Bernard Banner + + * Makefile.in: map 86numaux to a-numaux for x86_64 + +2004-01-12 Ed Schonberg + + * lib-xref.adb (Get_Type_Reference): If the type is the subtype entity + generated to rename a generic actual, go to the actual itself, the + subtype is not a user-visible entity. + + * sem_ch7.adb (Uninstall_Declarations): If an entity in the visible + part is a private subtype, reset the visibility of its full view, if + any, to be consistent. + + PR ada/13417 + * sem_ch12.adb (Analyze_Formal_Package): Diagnose properly an attempt + to use a generic package G as a formal package for another generic + declared within G. + +2004-01-12 Robert Dewar + + * trans.c (Eliminate_Error_Msg): New procedure called to generate msg + + * usage.adb: Remove mention of obsolete -gnatwb switch + Noticed during code reading + +2004-01-12 Jerome Guitton + + * 1ssecsta.adb: Minor changes for -gnatwa warnings + +2004-01-12 GNAT Script + + * Make-lang.in: Makefile automatically updated + +2004-01-09 Mark Mitchell + + * misc.c (gnat_expand_expr): Add alt_rtl parameter. + +2004-01-07 Rainer Orth + + * link.c [sgi] (shared_libgnat_default): Change to STATIC. + +2004-01-05 Kelley Cook + + * Make-lang.in: Revert stamp-xgnatug change from 2003-12-18. + Update comment and copyright date. + * stamp-xgnatug: Delete. + +2004-01-05 Robert Dewar + + * 1ssecsta.ads: Default_Secondary_Stack is not a constant since it may + be modified by the binder generated main program if the -D switch is + used. + + * 4onumaux.ads, 4znumaux.ads: Add Pure_Function pragmas for all + imported functions (since now we expect this to be done for imported + functions) + + * 5vtaprop.adb: Add several ??? for sections requiring more comments + Minor reformatting throughout + + * 5zinit.adb: Minor reformatting + Add 2004 to copyright date + Minor changes to avoid -gnatwa warnings + Correct some instances of using OR instead of OR ELSE (noted while + doing reformatting) + + * sprint.adb: Minor updates to avoid -gnatwa warnings + + * s-secsta.ads, s-secsta.adb: + (SS_Get_Max): New function to obtain high water mark for ss stack + Default_Secondary_Stack is not a constant since it may be modified by + the binder generated main program if the -D switch is used. + + * switch-b.adb: New -Dnnn switch for binder + + * switch-c.adb: + Make -gnatg imply all warnings currently in -gnatwa + + * vms_conv.adb: Minor reformatting + Add 2004 to copyright notice + Add 2004 to printed copyright notice + + * 3vexpect.adb, 4zsytaco.adb, 3wsocthi.adb, 3zsocthi.adb, + 3zsocthi.adb, 56taprop.adb, 56tpopsp.adb, 5amastop.adb, + 5aml-tgt.adb, 5ataprop.adb, 5ataprop.adb, 5atpopsp.adb, + 5ftaprop.adb, 5ginterr.adb, 5gmastop.adb, 5gml-tgt.adb, + 5gtaprop.adb, 5hml-tgt.adb, 5hml-tgt.adb, 5hml-tgt.adb, + 5htaprop.adb, 5htraceb.adb, 5itaprop.adb, 5lml-tgt.adb, + 5sml-tgt.adb, 5staprop.adb, 5staprop.adb, 5stpopsp.adb, + 5vasthan.adb, 5vinmaop.adb, 5vinterr.adb, 5vtaprop.adb, + 5vml-tgt.adb, 5vtaprop.adb, 5wosprim.adb, 5wtaprop.adb, + 5zinterr.adb, 5zintman.adb, 5zml-tgt.adb, 5ztaprop.adb, + 6vcpp.adb, 6vcstrea.adb, 7staprop.adb, 7stpopsp.adb, + vxaddr2line.adb, vxaddr2line.adb, xref_lib.adb, xr_tabls.adb, + xr_tabls.ads, s-tasdeb.adb, s-tasdeb.adb, sem_res.ads, + sem_util.adb, sem_util.adb, sem_util.ads, s-interr.adb, + checks.adb, clean.adb, cstand.adb, einfo.ads, + einfo.adb, exp_aggr.adb, exp_ch11.adb, exp_ch3.adb, + exp_ch4.adb, exp_ch5.adb, exp_ch7.adb, exp_ch9.adb, + prj-nmsc.adb, prj-pp.adb, prj-util.adb, sem_attr.adb, + sem_ch10.adb, sem_ch12.adb, sem_ch4.adb, g-dirope.adb, + g-dirope.ads, gnatlbr.adb, i-cstrea.adb, inline.adb, + lib-xref.adb, sem_ch5.adb, sem_ch7.adb, sem_ch8.adb: + Minor reformatting and code clean ups. + Minor changes to prevent -gnatwa warnings + + * ali.adb: Minor reformatting and cleanup of code + Acquire new SS indication of secondary stack use from ali files + + * a-numaux.ads: Add Pure_Function pragmas for all imported functions + (since now we expect this to be done for imported functions) + + * bindgen.adb: Generate call to modify default secondary stack size if + -Dnnn switch given + + * bindusg.adb: Add line for new -D switch + + * exp_aggr.adb (Type_May_Have_Bit_Aligned_Components): More appropriate + replacement name for Type_May_Have_Non_Bit_Aligned_Components! + Add circuitry for both records and arrays to avoid gigi + processing if the type involved has non-bit-aligned components + + * exp_ch5.adb (Expand_Assign_Array): Avoid assumption that + N_String_Literal node always references an E_String_Literal_Subtype + entity. This may not be true in the future. + (Possible_Bit_Aligned_Component): Move processing of + Component_May_Be_Bit_Aligned from exp_ch5 to exp_util + + * exp_ch6.adb (Expand_Thread_Body): Pick up + Default_Secondary_Stack_Size as variable so that we get value modified + by possible -Dnnn binder parameter. + + * exp_util.adb (Component_May_Be_Bit_Aligned): New function. + (Type_May_Have_Bit_Aligned_Components): New function. + + * exp_util.ads (Component_May_Be_Bit_Aligned): New function. + (Type_May_Have_Bit_Aligned_Components): New function. + + * fe.h: (Set_Identifier_Casing): Fix prototype. + Add declaration for Sem_Elim.Eliminate_Error_Msg. + Minor reformatting. + + * freeze.adb (Freeze_Entity): Add RM reference to error message about + importing constant atomic/volatile objects. + (Freeze_Subprogram): Reset Is_Pure indication for imported subprogram + unless explicit Pure_Function pragma given, to avoid insidious bug of + call to non-pure imported function getting eliminated. + + * gnat1drv.adb, gnatbind.adb, gnatchop.adb, gnatfind.adb, + gnatls.adb, gnatlink.adb, gnatmem.adb, gnatname.adb, gnatsym.adb, + gnatxref.adb, gprcmd.adb, gprep.adb, make.adb: Minor reformatting + Add 2004 to printed copyright notice + + * lib-writ.ads, lib-writ.adb: Put new SS flag in ali file if secondary + stack used. + + * Makefile.rtl: Add entry for g-sestin.o + g-sestin.ads: New file. + + * mdll.adb: Minor changes to avoid -gnatwa warnings + + * mlib-tgt.adb: Minor reformatting + + * opt.ads: New parameter Default_Secondary_Stack_Size (GNATBIND) + New switch Sec_Stack_Used (GNAT, GNATBIND) + Make Default_Secondary_Stack_Size a variable instead of a constant, + so that it can be modified by the new -Dnnn bind switch. + + * rtsfind.adb (Load_Fail): Give full error message in configurable + run-time mode if all_errors mode is set. This was not done in the case + of a file not found, which was an oversight. + Note if secondary stack unit is used by compiler. + + * sem_elab.adb (Check_A_Call): Rewrite to avoid trying to put + ineffective elaborate all pragmas on non-visible packages (this + happened when a renamed subprogram was called). Now the elaborate all + always goes on the package containing the renaming rather than the one + containing the renamed subprogram. + + * sem_elim.ads, sem_elim.adb (Eliminate_Error_Msg): New procedure + (Process_Eliminate_Pragma): Add parameter to capture pragma location. + + * sem_eval.adb (Eval_String_Literal): Do not assume that string literal + has an Etype that references an E_String_Literal. + (Eval_String_Literal): Avoid assumption that N_String_Literal node + always references an E_String_Literal_Subtype entity. This may not + be true in the future. + + * sem_prag.adb (Process_Eliminate_Pragma): Add parameter to capture + pragma location. + + * sem_res.adb (Resolve): Specialize msg for function name used in proc + call. + +2004-01-05 Ed Falis + + * g-debuti.adb: Replaced direct boolean operator with short-circuit + form. + +2004-01-05 Vincent Celier + + * bld.adb: Minor comment updates + (Process_Declarative_Items): Correct incorrect name (Index_Name instead + of Item_Name). + + * make.adb (Gnatmake): Special process for files to compile/check when + -B is specified. Fail when there are only foreign mains in attribute + Main of the project file and -B is not specified. Do not skip bind/link + steps when -B is specified. + + * makeusg.adb: Document new switch -B + + * opt.ads (Build_Bind_And_Link_Full_Project): New Boolean flag + + * switch-m.adb: (Scan_Make_Switches): Process -B switch + + * vms_data.ads: Add new GNAT PRETTY qualifier + /FORM_FEED_AFTER_PRAGMA_PAGE for switch -ff + +2004-01-05 Richard Kenner + + * trans.c (tree_transform, case N_Free_Statement): Handle thin pointer + case. + + * misc.c (gnat_printable_name): If VERBOSITY is 2, call + Set_Identifier_Casing. + + * decl.c (gnat_to_gnu_entity, E_Function): Give error if return type + has size that overflows. + +2004-01-05 Gary Dismukes + + * exp_ch4.adb (Expand_Array_Comparison): Add Boolean constant to avoid + -gnatwa warning on static condition. + +2004-01-05 Doug Rupp + + * link.c: (shared_libgnat_default) [VMS]: Change to STATIC. + +2004-01-05 Arnaud Charlet + + * Makefile.in: Install ali files using INSTALL_DATA_DATE to preserve + all attributes, including read-only attribute. + +2004-01-05 Pascal Obry + + * bindgen.adb (Gen_Object_Files_Options): Generate the new shared + library naming scheme. + + * mlib-prj.adb (Build_Library): Generate different names for the static + or dynamic version of the GNAT runtime. This is needed to support the + new shared library naming scheme. + (Process_Binder_File): Add detection of shared library in binder file + based on the new naming scheme. + + * gnatlink.adb (Process_Binder_File): Properly detect the new naming + scheme for the shared runtime libraries. + + * Makefile.in: + (LIBRARY_VERSION) [VMS]: Convert all . to _ to conform to new naming + scheme. + (install-gnatlib): Do not create symlinks for shared libraries. + (gnatlib-shared-default): Idem. + (gnatlib-shared-dual-win32): New target. Not used for now as the + auto-import feature does not support arrays/records. + (gnatlib-shared-win32): Do not create copy for the shared libraries. + (gnatlib-shared-vms): Fix shared runtime libraries names. + + * osint.ads, osint.adb (Shared_Lib): New routine, returns the target + dependent runtime shared library name. + +2004-01-05 Vasiliy Fofanov + + * osint.adb (Read_Library_Info): Remove bogus check if ALI is older + than the object. + +2004-01-05 Ed Schonberg + + * sem_ch4.adb (Analyze_Allocator): Check restriction on dynamic + protected objects when allocator has a subtype indication, not a + qualified expression. Note that qualified expressions may have to be + checked when limited aggregates are implemented. + + * sem_prag.adb (Analyze_Pragma, case Import): If enclosing package is + pure, emit warning. + (Analyze_Pragma, case Pure_Function): If enclosing package is pure and + subprogram is imported, remove warning. + +2004-01-05 Geert Bosch + + * s-poosiz.adb: Update copyright notice. + (Allocate): Use Task_Lock to protect against concurrent access. + (Deallocate): Likewise. + +2004-01-05 Joel Brobecker + + * s-stalib.adb (Elab_Final_Code): Add missing year in date inside ??? + comment. + + + +Copyright (C) 2004 Free Software Foundation, Inc. + +Copying and distribution of this file, with or without modification, +are permitted in any medium without royalty provided the copyright +notice and this notice are preserved. diff --git a/gcc/ada/ChangeLog-2005 b/gcc/ada/ChangeLog-2005 new file mode 100644 index 000000000..19301f923 --- /dev/null +++ b/gcc/ada/ChangeLog-2005 @@ -0,0 +1,8014 @@ +2005-12-28 John David Anglin + + * s-osinte-linux-hppa.ads: Correct alignment of atomic_lock_t. + +2005-12-12 Arnaud Charlet + + * Makefile.in: Remove dummy setting of GCC_FOR_TARGET, no longer + needed. + +2005-12-12 Arnaud Charlet + + * Make-lang.in: Update dependencies + +2005-12-12 Arnaud Charlet + + * Make-lang.in: Add rule for ada/exp_sel.o + +2005-12-12 Arnaud Charlet + + * Makefile.in (mingw section): Remove EH_MECHANISM setting. + +2005-12-09 Arnaud Charlet + + * gnatvsn.ads (Library_Version): Bump to version 4.2 + (ASIS_Version_Number): Bumped. + +2005-12-09 Doug Rupp + + * mlib-tgt-vms-ia64.adb, mlib-tgt-vms-alpha.adb (Is_Interface): Change + Ada bind file prefix on VMS from b$ to b__. + (Build_Dynamic_Library): Change Init file suffix on VMS from $init to + __init. + + * prj-nmsc.adb: Change some Hostparm.OpenVMS checks to + Targparm.OpenVMS_On_Target. + (Object_Suffix): Initialize with target object suffix. + (Get_Unit): Change Ada bind file prefix on VMS from b$ to b__. + + * butil.adb: Change some Hostparm.OpenVMS checks to + Targparm.OpenVMS_On_Target. + + * clean.adb: Change some Hostparm.OpenVMS checks to + Targparm.OpenVMS_On_Target. + (Object_Suffix): Initialize with call to Get_Target_Object_Suffix. + ({declaraction},Delete_Binder_Generated_Files,{initialization}): Change + Ada bind file prefix on VMS from b$ to b__. + + * gnatlink.adb (Process_Args): Call Add_Src_Search_Dir for -I in + --GCC so that Get_Target_Parameters can find system.ads. + (Gnatlink): Call Get_Target_Parameters in mainline. + Initialize standard packages for Targparm. + Change some Hostparm.OpenVMS checks to Targparm.OpenVMS_On_Target. + (Process_Args): Also Check for object files with target object + extension. + (Make_Binder_File_Names): Create with target object extension. + (Make_Binder_File_Names): Change Ada bind file prefix on VMS from b$ + to b__. + + * mlib-prj.adb: Change some Hostparm.OpenVMS checks to + Targparm.OpenVMS_On_Target. + ({declaration},Build_Library,Check_Library): Change Ada bind file + prefix on VMS from b$ to b__. + + * osint-b.adb: Change some Hostparm.OpenVMS checks to + Targparm.OpenVMS_On_Target. + (Create_Binder_Output): Change Ada bind file prefix on VMS from b$ to + b__. + + * targext.c: New file. + + * Makefile.in: add support for vxworks653 builds + (../../vxaddr2line): gnatlink with targext.o. + (TOOLS_LIBS): Move targext.o to precede libgnat. + (init.o, initialize.o): Minor clean up in dependencies. + (GNATLINK_OBJS): Add targparm.o, snames.o + Add rules fo building targext.o and linking it explicitly with all + tools. + Also add targext.o to gnatlib. + + * Make-lang.in: Add rules for building targext.o and linking it in + with gnat1 and gnatbind. + Add entry for exp_sel.o. + + * osint.adb Change some Hostparm.OpenVMS checks to + Targparm.OpenVMS_On_Target. + (Object_File_Name): Use target object suffix. + + * osint.ads (Object_Suffix): Remove, no longer used. + (Target_Object_Suffix): Initialize with target object suffix. + + * rident.ads: Add special exception to license. + + * targparm.adb (Get_Target_Parameters): Set the value of + Multi_Unit_Index_Character after OpenVMS_On_Target gets its definitive + value. + (Get_Target_Parameters): Set OpenVMS_On_Target if openvms. + + * targparm.ads: Add special exception to license. + + * g-os_lib.ads, g-os_lib.adb (Get_Target_Debuggable_Suffix): New + function. + (Copy_File): Make sure from file is closed if error on to file + (Get_Target_Executable_Suffix, Get_Target_Object_Suffix): New functions. + + * make.adb (Object_Suffix): Intialize with Get_Target_Object_Suffix. + (Executable_Suffix): Intialize with Get_Target_Executable_Suffix. + + * osint-c.adb (Set_Output_Object_File_Name): Initialize extension with + target object suffix. + +2005-12-09 Jose Ruiz + Quentin Ochem + Florian Villoing + + * a-taster.ads, a-taster.adb: New files. + + * a-elchha.adb (Last_Chance_Handler): Change the task termination soft + link to the version that does nothing. This way the task termination + routine is not executed twice for the environment task when finishing + because of an unhandled exception. + + * a-exextr.adb (Notify_Unhandled_Exception): Call the task termination + handler because of an unhandled exception. + + * a-taside.adb (Abort_Tasks): Call the Abort_Tasks procedure from + System.Tasking.Utilities instead of that in System.Tasking.Stages. + + * s-finimp.adb (initialization code): Modify the soft link for the + finalization of the global list instead of Adafinal. + + * s-soflin.ads, s-soflin.adb (Task_Termination_NT): Add this + non-tasking version of the soft link for task termination. We do + nothing since if we are using the non-tasking version it + means that the task termination functionality is not used. + (Null_Finalize_Global_List): Add this null version for the procedure + in charge of finalizing the global list for controlled objects. + (Null_Adafinal): Remove this procedure. Adafinal_NT has been created + instead for handling run-time termination in a more flexible way. + (Adafinal_NT): This new procedure will take care of finalizing the + global list for controlled objects if needed, but no tasking + finalization. + + * s-tarest.adb (Task_Lock): Do not try to lock again the + Global_Task_Lock if we already own it. Otherwise, we get blocked in + some run-time operations. + (Task_Unlock): Do not try to actually unlock the Global_Task_Lock + until all nested locks have been released. + (Task_Wrapper): Call the fall-back task termination handler. It + applies to all tasks but the environment task. + (Finalize_Global_Tasks): Add the call for the task termination + procedure for the environment task. + (Task_Wrapper): suppress warnings around declaration of + Secondary_Stack_Address. + + * s-tasini.adb (Final_Task_Unlock): Global_Task_Lock_Nesting has been + moved to the Common_ATCB record. + (Task_Lock): Global_Task_Lock_Nesting has been moved to the + Common_ATCB record. + (Task_Unlock): Global_Task_Lock_Nesting has been moved to the + Common_ATCB record. + + * s-taskin.adb (Initialize_ATCB): Initialize Global_Task_Lock_Nesting, + Fall_Back_Handler, and Specific_Handler. + + * s-taskin.ads (Cause_Of_Termination): Redefine this type here, already + defined in Ada.Task_Termination, to avoid circular dependencies. + (Termination_Handler): Redefine this type here, alredy defined in + Ada.Task_Termination, for avoiding circular dependencies. + (Common_ATCB): Add the Fall_Back_Handler and Specific_Handler required + for storing task termination handlers. In addition, + Global_Task_Lock_Nesting has been moved from Ada_Task_Control_Block to + Common_ATCB because it is used by both the regular and the restricted + run times. + (Ada_Task_Control_Block): Move Global_Task_Lock_Nesting from here to + Common_ATCB because it is used by both the regular and the restricted + run times. + (Common_ATCB): Added a dynamic task analyzer field. + + * s-tassta.adb (Abort_Tasks): Move the code in charge of checking + potentially blocking operations to System.Tasking.Utilities.Abort_Tasks. + (Task_Wrapper): Call the task termination handler. It applies to all + tasks but the environment task. + (Finalize_Global_Tasks): Call the task termination procedure for the + environment task. The call to Finalize_Global_List is now performed + using the soft links mechanism. + (Task_Wrapper): added dynamic stack analysis. + + * s-tasuti.adb (Abort_Tasks): The code in charge of checking + potentially blocking operations has been moved from + System.Tasking.Stages.Abort_Tasks to this procedure. There can be + direct calls to System.Tasking.Utilities.Abort_Tasks that do not pass + through System.Tasking.Stages.Abort_Tasks, and we do not want to miss + this run-time check. + + * s-solita.adb (Task_Termination_Handler_T): Add this task-safe version + of task termination procedure. + (Init_Tasking_Soft_Links): Install the task-safe version of the soft + link for the task termination procedure. + + * bindusg.adb: (Bindusg): Added documentation for -u option. + + * bindgen.adb (Get_Main_Ada) Added handling of dynamic stack analysis. + (Get_Main_C): Add handling of dynamic stack analysis. + (Gen_Output_File_C): Add external functions for dynamic stack analysis. + + * Makefile.rtl: Add entry for a-taster (Ada.Task_Termination). + (GNATRTL_NONTASKING_OBJS) Added entries for dynamic stack analysis + (GNATRTL_NONTASKING_OBJS): Add AltiVec files. + + * opt.ads: Added flags used by dynamic stack measurement. + (Max_Line_Length): Remove (not used anymore) + + * s-io.ads, s-io.adb (Standard_Error): new subprogram + (Standart_Output): new subprogram + (Set_Output): new subprogram + (Put): now uses the value of Current_Out to know if the output has to be + send to stderr or stdout. + + * s-stausa.ads: Complete implementation. + + * switch-b.adb: Added handling of -u switch for dynamic stack analysis. + + * impunit.adb (Non_Imp_File_Names_05): Add Ada.Task_Termination to the + list of Ada 05 files. + (GNAT Library Units): Add AltiVec files. + + * g-allein.ads, g-alleve.adb, g-alleve.ads, g-altcon.adb, + g-altcon.ads, g-altive.ads, g-alveop.adb, g-alveop.ads + g-alvety.ads, g-alvevi.ads: New files providing altivec API. + +2005-12-09 Nicolas Setton + + * adaint.c (__gnat_locate_regular_file): Return immediately if + file_name is empty. + +2005-12-09 Javier Miranda + Hristian Kirtchev + + * a-tags.ads, a-tags.adb (Offset_To_Top): Moved from the package body + to the specification because the frontend generates code that uses this + subprogram. + (Set_Interface_Table): Add missing assertion. + Update documentation describing the run-time structure. + (Displace): New subprogram that displaces the pointer to the object + to reference one of its secondary dispatch tables. + (IW_Membership): Modified to use the new table of interfaces. + (Inherit_TSD): Modified to use the new table of interfaces. + (Register_Interface_Tag): Use the additional formal to fill the + contents of the new table of interfaces. + (Set_Interface_Table): New subprogram that stores in the TSD the + pointer to the table of interfaces. + (Set_Offset_To_Top): Use the additional formal to save copy of + the offset value in the table of interfaces. + Update structure of GNAT Primary and Secondary dispatch table diagram. + Add comment section on GNAT dispatch table prologue. + (Offset_To_Signature): Update the constant value of the Signature field. + (Dispatch_Table): Update comment on hidden fields in the prologue. + (Get_Entry_Index, Get_Prim_Op_Kind, Get_Offset_Index, OSD, + Set_Entry_Index, Set_Offset_Index, Set_Prim_Op_Kind, SSD, TSD): Change + the type of formal parameter T to Tag, introduce additional assertions. + (Get_Num_Prim_Ops, Set_Num_Prim_Ops): Remove an unnecessary type + conversion. + (Get_Tagged_Kind, Set_Tagged_Kind): New bodies. + + * exp_ch6.adb (Register_Interface_DT_Entry): Remove the Thunk_Id actual + in all the calls to Expand_Interface_Thunk. Instead of referencing the + record component containing the tag of the secondary dispatch table we + have to use the Offset_To_Top run-time function to get this information; + otherwise if the pointer to the base of the object has been displace + we get a wrong value if we use the 'position attribute. + + * exp_disp.adb (Expand_Interface_Thunk): Remove the Thunk_Id actual in + all the calls to Expand_Interface_Thunk. + (Make_Secondary_DT): Secondary dispatch tables do not have a table of + interfaces; hence the call to Set_Interface_Table was clearly wrong. + (Collect_All_Interfaces): Modify the internal subprogram Collect to + ensure that the interfaces implemented by the ancestors are placed + at the header of the generated list. + (Expand_Interface_Conversion): Handle the case in which the displacement + associated with the interface conversion is not statically known. In + this case we generate a call to the new run-time subprogram Displace. + (Make_DT): Generate and fill the new table of interfaces. + (Ada_Actions, Action_Is_Proc, Action_Nb_Arg): Add entries for + Get_Tagged_Kind and Set_Tagged_Kind. + (Tagged_Kind): New function that determines the tagged kind of a type + with respect to limitedness and concurrency and returns a reference to + RE_Tagged_Kind. + (Make_Disp_Asynchronous_Select_Body, Make_Disp_Conditional_Select_Body, + Make_Disp_Timed_Select_Body): Correctly retrieve the pointer to the + primary dispatch table for a type. + (Make_DT, Make_Secondary_DT): Set the tagged kind in the primary and + secondary dispatch table respectively of a tagged type. + + * exp_disp.ads (Expand_Interface_Thunk): Remove Thunk_Id formal. + (Expand_Interface_Conversion): New subprogram to indicate if the + displacement of the type conversion is statically known. + (DT_Access_Action): Add values Get_Tagged_Kind and Set_Tagged_Kind. + + * rtsfind.ads (RE_Offset_To_Top): New entity + (RTU_Id): Add Ada_Task_Termination to the list so that it is made + accessible to users. + (Re_Displace): New entity + (RE_Interface_Data): New entity + (RE_Set_Interface_Data): New_Entity + (RE_Id, RE_Unit_Table): Add entry for RE_Get_Tagged_Kind, + Set_Tagged_Kind, RE_Tagged_Kind, RE_TK_Abstract_Limited_Tagged, + RE_TK_Abstract_Tagged, RE_TK_Limited_Tagged, RE_TK_Protected, + RE_TK_Tagged, RE_TK_Task. + + * exp_ch3.adb (Init_Secondary_Tags): Modify the subprogram + Init_Secondary_Tags_Internal to allow its use with interface types and + also to generate the code for the new additional actual required + by Set_Offset_To_Top. + (Build_Init_Statements): In case of components associated with abstract + interface types there is no need to generate a call to its IP. + (Freeze_Record_Type): Generate Select Specific Data tables only for + concurrent types. + (Make_Predefined_Primitive_Specs, Predefined_Primitive_Bodies): Generate + the bodies and specifications of the predefined primitive operations + dealing with dispatching selects and abort, 'Callable, 'Terminated only + for concurrent types. + + * exp_sel.ads, exp_sel.adb: New files. + + * exp_ch9.adb (Build_Protected_Entry, Expand_N_Protected_Body, + Expand_N_Protected_Type_Declaration, Make_Initialize_Protection): Handle + properly protected objects and attach handler in the case of the + restricted profile. + Move embeded package Select_Expansion_Utilities into a separate external + package. + (Expand_N_Asynchronous_Select, Expand_N_Conditional_Select, + Expand_N_Timed_Entry_Call): Correct calls external package Exp_Sel. + (Build_K, Build_S_Assignment): New subprograms, part of the select + expansion utilities. + (Expand_N_Asynchronous_Select, Expand_N_Conditional_Entry_Call, + Expand_N_Timed_Entry_Call): Optimize expansion of select statements + where the trigger is a dispatching procedure of a limited tagged type. + +2005-12-09 Olivier Hainque + + * decl.c (gnat_to_gnu_entity, renaming object case): Don't early expand + pointer initialization values. Make a SAVE_EXPR instead. Add comments + about the use and expansion of SAVE_EXPRs in the various possible + renaming handling cases. + (components_to_record, compare_field_bitpos): Sort by DECL_UID, not by + abusing DECL_FCONTEXT. + +2005-12-09 Matthew Heaney + + * a-convec.adb (Merge): Added assertions to check whether vector params + are sorted. + + * a-coinve.adb (Merge): Added assertions to check whether vector params + are sorted. + + * a-cohama.ads (Cursor'Write): raises Program_Error per latest AI-302 + draft. + (Cursor'Read): raises PE + + * a-cohama.adb (Insert.New_Node): Uses box-style syntax to init elem + to its default value. + + * a-cihama.adb: Manually check whether cursor's key and elem are + non-null + + * a-cidlli.ads, a-cidlli.adb (Splice): Changed param name and param mode + (Merge): Assert that target and source lists are in order + (Swap): Declare non-const temporaries, to pass to Splice + + * a-cdlili.ads: (Splice): Changed param name and param mode + + * a-cdlili.adb: (Splice): Changed param name and param mode + (Merge): Assert that target and source lists are in order + (Swap): Declare non-const temporaries, to pass to Splice + + * a-ciorma.ads, a-coorma.ads: (Read): declare Stream param as not null + (Write): declare Stream param as not null + + * a-ciorma.adb, a-coorma.adb: All explicit raise statements now include + an exception message. + +2005-12-09 Thomas Quinot + Robert Dewar + + * hostparm.ads (Max_Line_Length): Set to Types.Column_Number'Last - 1, + which is the absolute maximum length we can support. + + * frontend.adb: For the processing of configuration pragma files, + remove references to Opt.Max_Line_Length, which is not checked anymore. + + * namet.ads (Name_Buffer): Adjust size to reflect increase on max line + length. + + * scn.adb, scng.adb: + Always check line length against the absolute supported maximum, + Hostparm.Max_Line_Length. + + * stylesw.adb (Set_Style_Check_Options, case M): The maximum supported + value for the maximum line length is Max_Line_Length (not + Column_Number'Last). + Minor error msg update + (Set_Style_Check_Options): New interface returning error msg + Minor code reorganization (processing for 'M' was out of alpha order) + + * switch-c.adb: New interface for Set_Style_Check_Options + + * stylesw.ads (Set_Style_Check_Options): New interface returning error + msg. + +2005-12-09 Javier Miranda + + * exp_aggr.adb (Build_Record_Aggr_Code): Default-initialialized records + with IP subprogram were only supported if there were limited types. + + * sem_aggr.adb (Resolve_Record_Aggregate): Default-initialialized + records with IP subprogram were only supported if there were limited + types. + +2005-12-09 Olivier Hainque + Eric Botcazou + + * trans.c (tree_transform, emit_check): Adjust calls to + build_call_raise, passing the now expected GNAT_NODE argument. + + * gigi.h (build_call_raise): Add a GNAT_NODE argument to convey better + source line information than what the current global locus indicates + when appropriate. + + * utils2.c (build_simple_component_ref): Return 0 if the offset of the + field has overflowed. + (build_call_raise): Add a GNAT_NODE argument to convey better source + line information than what the current global locus indicates when + appropriate. + (build_component_ref): Adjust call to build_call_raise. + +2005-12-09 Pascal Obry + + * g-diopit.adb (Find): Fix test to exit the iterator and make sure that + the iterator is quitting iteration on parent directory. + +2005-12-09 Javier Miranda + + * exp_ch5.adb (Expand_N_Assignment_Statement): In case of tagged types + and the assignment to a class-wide object, before the assignment we + generate a run-time check to ensure that the tag of the Target is + covered by the tag of the source. + +2005-12-09 Robert Dewar + + * exp_imgv.adb (Expand_Image_Attribute): Generate extra boolean + parameter in call to Image_Wide_Character. + + * s-imgwch.ads, s-imgwch.adb (Image_Wide_Character): Add boolean + parameter Ada_2005 to deal with annoying FFFE/FFFF inconsistency. + (Image_Wide_Character): Add boolean parameter Ada_2005 to deal with + annoying FFFE/FFFF inconsistency. + +2005-12-09 Robert Dewar + Javier Miranda + Ed Schonberg + + * exp_util.ads, exp_util.adb (Is_Ref_To_Bit_Packed_Slice): Handle case + of type conversion. + (Find_Interface): New subprogram that given a tagged type and one of its + component associated with the secondary table of an abstract interface + type, return the entity associated with such abstract interface type. + (Make_Subtype_From_Expr): If type has unknown discriminants, always use + base type to create anonymous subtype, because entity may be a locally + declared subtype or generic actual. + (Find_Interface): New subprogram that given a tagged type and one of its + component associated with the secondary table of an abstract interface + type, return the entity associated with such abstract interface type. + + * sem_res.adb (Resolve_Type_Conversion): Handle the case in which the + conversion cannot be handled at compile time. In this case we pass this + information to the expander to generate the appropriate code. + +2005-12-09 Robert Dewar + Ed Schonberg + Gary Dismukes + Javier Miranda + Hristian Kirtchev + + * einfo.adb (Itype_Printed): New flag + (Is_Limited_Type): Derived types do not inherit limitedness from + interface progenitors. + (Is_Return_By_Reference_Type): Predicate does not apply to limited + interfaces. + + * einfo.ads (Itype_Printed): New flag + Move Is_Wrapper_Package to proper section + Add missing Inline for Is_Volatile + + * output.ads, output.adb (Write_Erase_Char): New procedure + (Save/Restore_Output_Buffer): New procedures + (Save/Restore_Output_Buffer): New procedures + + * sprint.ads, sprint.adb (Write_Itype): Handle case of record itypes + Add missing support for anonymous access type + (Write_Id): Insert calls to Write_Itype + (Write_Itype): New procedure to output itypes + + * par-ch12.adb (P_Formal_Derived_Type_Definition): In Ada 2005, handle + use of "limited" in declaration. + + * sinfo.ads, sinfo.adb: + Formal derived types can carry an explicit "limited" indication. + + * sem_ch3.adb: Add with and use of Targparm. + (Create_Component): If Frontend_Layout_On_Target is True and the + copied component does not have a known static Esize, then reset + the size and positional fields of the new component. + (Analyze_Component_Declaration): A limited component is + legal within a protected type that implements an interface. + (Collect_Interfaces): Do not add to the list the interfaces that + are implemented by the ancestors. + (Derived_Type_Declaration): If the parent of the full-view is an + interface perform a transformation of the tree to ensure that it has + the same parent than the partial-view. This simplifies the job of the + expander in order to generate the correct object layout, and it is + needed because the list of interfaces of the full-view can be given in + any order. + (Process_Full_View): The parent of the full-view does not need to be + a descendant of the parent of the partial view if both parents are + interfaces. + (Analyze_Private_Extension_Declaration): If declaration has an explicit + "limited" the parent must be a limited type. + (Build_Derived_Record_Type): A derived type that is explicitly limited + must have limited ancestor and progenitors. + (Build_Derived_Type): Ditto. + (Process_Full_View): Verify that explicit uses of "limited" in partial + and full declarations are consistent. + (Find_Ancestor_Interface): Remove function. + (Collect_Implemented_Interfaces): New procedure used to gather all + implemented interfaces by a type. + (Contain_Interface): New function used to check whether an interface is + present in a list. + (Find_Hidden_Interface): New function used to determine whether two + lists of interfaces constitute a set equality. If not, the first + differing interface is returned. + (Process_Full_View): Improve the check for the "no hidden interface" + rule as defined by AI-396. + +2005-12-09 Robert Dewar + + * freeze.adb (Freeze_Record_Type): Only test for useless pack on record + types, not on record subtypes. + (Freeze_Entity): Code cleanup. Add barrier to the loop + that generates the references for primitive operations. This allows to + remove an unnecessary exception handler. + Code reformatting and comment clean ups. + +2005-12-09 Vincent Celier + + * gnatcmd.adb (GNATCmd): GNAT CHECK accepts switch -U + If GNAT CHECK is called with a project file, but with no + source on the command line, call gnatcheck with all the compilable + sources of the project. + Take into account the new command Check, for gnatcheck. Treat as for + other ASIS tools: take into account project, specific package Check and + Compiler switches. + For ASIS tools, add the switches in package Compiler for + the invocation of the compiler. + + * prj-attr.adb: Add package Check and its attributes + + * vms_conv.ads (Command_Type): New command Check, for gnatcheck + + * vms_conv.adb (Initialize): Change Params of command Check to + unlimited files. + Change some Hostparm.OpenVMS checks to Targparm.OpenVMS_On_Target. + Add data for new command Check + + * vms_data.ads: Add project related qualifiers for GNAT CHECK and GNAT + ELIM. + Add qualifiers for Check command options + (Command_Type): New command Check + +2005-12-09 Thomas Quinot + + * mlib-utl.adb (Ar): Use Output.Buffer_Max to determine whether a + command line switch overruns the output buffer. + +2005-12-09 Robert Dewar + + * sem_prag.adb: Processing for new pragma Complete_Representation + (Analyze_Pragma, case Debug): Implement two argument form. + + * par-prag.adb: Entry for new pragma Complete_Representation + (Prag, case Debug): Recognize two argument form of pragma Debug + New interface for Set_Style_Check_Options. + + * sem_ch13.adb: Implement new pragma Complete_Representation. + + * snames.adb, snames.ads, snames.h: Entry for new pragma + Complete_Representation. + +2005-12-09 Gary Dismukes + + * sem_cat.adb (Validate_RCI_Subprogram_Declaration): Revise test for + available user-specified stream attributes on limited parameters to + also test the type directly rather than only its underlying type (for + Ada 95) and, in the case of Ada 2005, to check that the user-specified + attributes are visible at the point of the subprogram declaration. + For Ada 2005, the error message is modified to indicate that the + type's stream attributes must be visible (again, only for -gnat05). + +2005-12-09 Ed Schonberg + + * sem_ch12.adb (Subtypes_Match): Handle properly Ada05 arrays of + anonymous access types. + + * sem_eval.adb (Subtypes_Statically_Match): Implement new rules for + matching of anonymous access types and anonymous access to subprogram + types. 'R'M 4.9.1 (2/2). + +2005-12-09 Ed Schonberg + + * sem_ch4.adb (Remove_Abstract_Operations): Do not apply preference + rule prematurely when operands are universal, remaining ambiguities + will be removed during resolution. + Code cleanup. + + * sem_type.adb (Disambiguate): In Ada95 mode, discard interpretations + that are Ada 2005 functions. + (Has_Abstract_Interpretation): Subsidiary to + Remove_Conversions, to remove ambiguities caused by abstract operations + on numeric types when operands are universal. + +2005-12-09 Robert Dewar + + * sem_ch6.adb (Analyze_Subprogram_Body): Properly check categorization + for case where spec is categorized. + +2005-12-09 Javier Miranda + + * sem_ch8.adb (Find_Type): In case of tagged types that are concurrent + types use the corresponding record type. This was not needed before + the implementation of Ada 2005 synchronized types because + concurrent types were never tagged types in Ada 95. + +2005-12-09 Ed Schonberg + + * sem_ch9.adb (Analyze_Delay_Alternative, Analyze_Delay_Until): Use the + first subtype of the type of the expression to verify that it is a + legal Time type. + +2005-12-09 Robert Dewar + + * sem_util.ads, sem_util.adb (Full_Qualified_Name): Now provides + decoded names. + +2005-12-09 Quentin Ochem + Robert Dewar + Ed Falis + Florian Villoing + Thomas Quinot + Arnaud Charlet + + * gnat_ugn.texi: Created section "Stack Related Tools" + Moved "Stack Overflow Checking" subsection from "Switches for gcc" to + "Stack Related Tools" + Added subsection "Static Stack Usage Analysis" + Added subsection "Dynamic Stack Usage Analysis" + Include documentation of itypes in sprint listing (-gnatG) + Documented gnatbind -D switch (default sec stack size for fixed sec + stacks). + Added Interrupt_State and Persistent_BSS to list of configuration + pragmas. + Add missing doc for maximum value of nnn in -gnatyMnnn + + * gnat_rm.texi: Document the AltiVec binding. + Add documentation for pragma Complete_Representation + Shortened an overly long line (> 79 chars) + Clarify documentation of unchecked conversion in implementation + defined cases. + Document two argument form of pragma Debug + + * types.ads (Column_Number): Update documentation. + + * exp_ch7.ads (Make_Adjust_Call): Document the special processing for + library level Finalize_Storage_Only objects (these are not attached to + any finalization list). + + * system-mingw.ads: (Underlying_Priorities): Update comment. + +2005-12-09 Robert Dewar + + * i-c.adb, i-cexten.ads, i-cobol.adb, i-cobol.ads, i-cpoint.ads, + i-cpp.adb, i-cpp.ads, i-cstrea.ads, i-cstrin.adb, i-cstrin.ads, + inline.adb, interfac.ads, i-os2err.ads, i-os2lib.ads, i-os2syn.ads, + i-os2thr.ads, itypes.adb, itypes.adb, itypes.ads, krunch.ads, + krunch.adb, lib.adb, lib.ads, lib-list.adb, lib-load.adb, + lib-load.ads, lib-sort.adb, live.adb, make.ads, i-cstrea-vms.adb, + interfac-vms.ads, makegpr.adb, indepsw-gnu.adb, indepsw.ads, + s-wchcon.ads, sdefault.ads, sem_ch10.adb, sem_eval.ads: Minor + reformatting. + +2005-12-09 Robert Dewar + + * s-vaflop-vms-alpha.adb: (Ne_F): New function + (Ne_G): New function + + * exp_ch4.adb (Expand_Allocator_Expression): Factor duplicated code + for tag assignment. + (Rewrite_Comparison): Handle case where operation is not a comparison + and ignore, and also handle type conversion case. + +2005-12-09 Thomas Quinot + + * exp_aggr.ads: Fix typo in comment. + ???-mark Convert_Aggr_In_Assignment as needing documentation. + +2005-12-09 Gary Dismukes + + * layout.adb: Replace various uses of byte by storage unit throughout. + (Get_Max_SU_Size): Name changed from Get_Max_Size. In the case of a + static size, convert to storage units before returning, to conform to + spec. + +2005-12-09 Matthew Gingell + + * g-exctra.ads: Fix typo in comment. + +2005-12-09 Richard Kenner + + * utils.c: Minor reformatting. + +2005-12-09 Robert Dewar + + * g-soccon.ads: + Further comment fixes to make the status of the default file clear + + * s-bitops.adb: Clarify comment for Bits_Array + +2005-12-07 Rafael Ávila de Espíndola + + * Make-lang.in (ada.install-normal): Remove. + +2005-12-07 Rafael Ávila de Espíndola + + * Make-lang.in: Remove all dependencies on s-gtype. + +2005-12-05 Richard Guenther + + * utils.c (convert): Use fold_convert where appropriate. + +2005-12-05 Paolo Bonzini + + * Makefile.in (gnatlib): Fix regex, using \. instead of . when + a period is meant. + +2005-12-02 Richard Guenther + + * trans.c (gnat_gimplify_expr): Use buildN instead of build. + +2005-12-01 Roger Sayle + + * utils.c (max_size): Only test for TREE_OVERFLOW on INTEGER_CST + nodes. + +2005-11-23 Laurent Guerby + + * mlib-prj.adb (Build_Library): Initialize Delete. + +2005-11-21 Joel Sherrill + + * socket.c: Add extern int h_errno for rtems since networking header + files are not available at this point in a tool bootstrap. Newlib + only has basic C library header files. + +2005-11-19 Richard Guenther + Roger Sayle + + PR ada/23717 + * misc.c (internal_error_function): Don't use vsprintf to format + the error message text, instead use pp_format_text and the new + pretty printer APIs. This allows handling of %qs, %w, etc. + +2005-11-18 Laurent Guerby + + PR ada/24857 + * Makefile.in: Use s-auxdec-empty for RTEMS. + +2005-11-17 Richard Kenner + + PR ada/22333 + * trans.c (gnat_gimplify_expr, case ADDR_EXPR): Always make + a temporary if taking the address of something that is neither + reference, declaration, or constant, since the gimplifier + can't handle that case. + +2005-11-17 Laurent Guerby + + PR ada/24857 + * s-auxdec-empty.ads, s-auxdec-empty.adb: New files. + +2005-11-16 Richard Guenther + + * Makefile.in: Add EH_MECHANISM=-gcc to s390(x) linux. + +2005-11-16 Joel Sherrill + + PR ada/24855 + * raise-gcc.c: Add missing stdarg.h include. + +2005-11-16 Richard Guenther + + * Make-lang.in (ada/decl.o): Add $(EXPR_H) dependency. + (ada/misc.o): Likewise. + +2005-11-14 Thomas Quinot + + * g-soccon.ads: Minor reformatting. Update comments. + + * gsocket.h: Include in the VxWorks case, in order to + gain visibility on the declaration of struct timeval. + + * g-soccon-freebsd.ads, + g-soccon-darwin.ads, + g-soccon-tru64.ads, + g-soccon-aix.ads, + g-soccon-irix.ads, + g-soccon-hpux.ads, + g-soccon-solaris.ads, + g-soccon-vms.ads, + g-soccon-mingw.ads, + g-soccon-vxworks.ads (SIZEOF_tv_sec, SIZEOF_tv_usec): New constants. + + * g-soccon-hpux-ia64.ads, g-soccon-linux-ppc.ads, + g-soccon-solaris-64.ads, g-soccon-linux-64.ads, + g-soccon-linux-x86.ads: New files. + + * g-socthi-mingw.adb: + (Socket_Error_Message): Remove redundant use of GNAT.Sockets.Constants + + * g-socthi-vxworks.ads, g-socthi-vms.ads, g-socthi-mingw.ads + (time_t, suseconds_t): New types constructed to match the tv_sec + and tv_usec fields of C struct timeval. + (Timeval): Construct structure in terms of the new types. + (Host_Errno): New function (imported from socket.c), returns last hosts + database error. + + * g-socthi-vxworks.adb: Add error handling circuitry. + + * g-socket.ads, g-socket.adb (To_Timeval): Reflect change of type for + components of struct timeval. + (Get_Host_By_Name, Get_Host_By_Address): Fix error reporting circuitry. + (Check_Selector): In error conditions, clear internal socket sets to + avoid a memory leak. + (Get_Socket_Option, Set_Socket_Option): Support for Multicast_If, + Send_Timeout, Receive_Timeout. + + * g-socthi.ads (time_t, suseconds_t): New types constructed to match + the tv_sec and tv_usec fields of C struct timeval. + (Timeval): Construct structure in terms of the new types. + (Host_Errno): New function (imported from socket.c), returns last hosts + database error. + + * socket.c (__gnat_get_h_errno): New function to retrieve h_errno, the + hosts database last error code. + + * gen-soccon.c: Complete value expansion should not be performed on + TARGET, as it has the form of a math expression, and some components + may be platform-defined macros. + For VxWorks, generate the OK and ERROR values. + New constants giving the sizes of the components of C struct timeval. + +2005-11-14 Robert Dewar + Ed Schonberg + + PR ada/18434 + * types.ads: Include All_Checks in Suppress_Array + + * checks.adb (Check_Needed): Remove kludge for a/=b rewritten as + not(a=b), since we no longer do this rewriting, and hence it is not + needed. + (Elaboration_Checks_Suppressed): Add special casing to + deal with different cases of static and dynamic elaboration checks (all + checks does not count in the first case, but does in the second). + (Expr_Known_Valid): Do not assume that the result of any arbitrary + function call is valid, since this is not the case. + (Ensure_Valid): Do not apply validity check to a real literal + in a universal or fixed context + + * exp_ch4.adb (Expand_N_Op_Ne): Don't expand a/=b to not(a=b) for + elementary types using the operator in standard. It is cleaner not to + modify the programmers intent, especially in the case of floating-point. + (Rewrite_Comparison): Fix handling of /= (this was always wrong, but + it did not matter because we always rewrote a/=b to not(a=b). + (Expand_Allocator_Expression): For an allocator expression whose nominal + subtype is an unconstrained packed type, convert the expression to its + actual constrained subtype. + Implement warning for <= or >= where < or > not possible + Fix to Vax_Float tests (too early in many routines, causing premature + Vax_Float expansions. + + * sem_prag.adb (Analyze_Pragma, case Obsolescent): Allow this pragma + to be used with packages and generic packages as well as with + subprograms. + (Suppress): Set All_Checks, but not Elaboration_Check, for case + of pragma Suppress (All_Checks) + (Analyze_Pragma, case Warnings): Implement first argument allowed to be + a string literal for precise control over warnings. + Avoid raise of pragma in case of unrecognized pragma and just return + instead. + + * sem_prag.ads: Minor reformatting + + * switch-c.adb (Scan_Front_End_Switches): Replace "raise Bad_Switch;" + with call to new procedure Bad_Switch. Call Scan_Pos with new parameter + Switch. Do not handle any exception. + Include -gnatwx as part of -gnatg (warn on redundant parens) + Allow optional = after -gnatm + (Scan_Front_End_Switches): The -gnatp switch sets All_Checks, but no + longer sets Elaboration_Checks. + Code to set warning mode moved to Sem_Warn + so that it can be shared by pragma processing. + + * s-mastop-tru64.adb (Pop_Frame): Remove redundant parentheses in if + statement. + + * s-taprop-solaris.adb: + Change some <= to =, to avoid new warning + + * a-exexda.adb, prj-proc.adb: + Fix obvious typo (Num_Tracebacks compared <= 0 instead of < 0) + Fix obvious typo (Total_Errors_Detected <= 0 should be = 0) + +2005-11-14 Robert Dewar + + * exp_vfpt.adb: Handle /= case + (Expand_Vax_Conversion): Properly recognize Conversion_OK flag + so that we do not get duplicate scaling for fixed point conversions. + + * s-vaflop.ads, s-vaflop.adb: (Ne_F): New function + +2005-11-14 Matthew Gingell + + * system-lynxos-ppc.ads, system-lynxos-x86.ads: + Increase default priority on Lynx from 15 to 17, and meet the Ada + requirement that Default_Priority be ((Priority'First + + Priority'Last) / 2) by increasing the range of Interrupt_Priority. + +2005-11-14 Vincent Celier + + * mlib-tgt-tru64.adb, mlib-tgt-aix.adb, mlib-tgt-irix.adb, + mlib-tgt-hpux.adb, mlib-tgt-hpux.adb, mlib-tgt-linux.adb, + mlib-tgt-solaris.adb, mlib-tgt-vms-alpha.adb, mlib-tgt-vms-alpha.adb, + mlib-tgt-vms-ia64.adb, mlib-tgt-mingw.adb, mlib-tgt-vxworks.adb, + mlib-tgt-darwin.adb, mlib-tgt.adb, mlib-tgt.ads, + mlib-tgt-lynxos.adb (DLL_Prefix): New function + +2005-11-14 Doug Rupp + + * system-vms.ads, system-vms_64.ads: ADA$GNAT: New exported object in + private part. + +2005-11-14 Arnaud Charlet + + * s-traces-default.adb, s-trafor-default.ads, + s-tratas-default.adb: Fix compilation errors. + +2005-11-14 Jose Ruiz + + * s-taprop-posix.adb (Initialize_Lock): Destroy mutex attribute before + raising the exception so the memory used is freed. + +2005-11-14 Arnaud Charlet + + * adaint.h, adaint.c (__gnat_is_cross_compiler): New constant. + (Gnat_Install_Locks, __gnatlib_install_locks): Removed, no longer used. + (convert_address): Update comments and list of platforms using this. + + * s-tasini.adb (Gnat_Install_Locks, __gnatlib_install_locks): Removed, + no longer used. + +2005-11-14 Pascal Obry + Vincent Celier + + * gnatdll.adb (Parse_Command_Line): Remove redundant use of + GNAT.Command_Line. + + * memroot.adb: Remove redundant with/use clause on + System.Storage_Elements. + +2005-11-14 Arnaud Charlet + + * a-except.adb (Zero_Cost_Exceptions): Removed, no longer used. + (builtin_longjmp, Process_Raise_Exceeption): Move setjmp/longjmp + related code to a-exexpr.adb + (Save_Occurrence_And_Private): Move GCC EH related code to + a-exexpr-gcc.adb + (Raise_Current_Excep): Add new variable Id with pragma + volatile, to ensure that the variable lives on stack. + + * a-exexpr-gcc.adb, raise-gcc.c: New file. + + * a-exexpr.adb (builtin_longjmp, Propagate_Exception): Moved here code + from a-except.adb. + Move GCC EH related code to a-exexpr-gcc.adb + + * Makefile.in: Add or update g-soccon LIBGNAT pairs for Linux/PPC and + 64-bit Solaris + Split the Linux version of g-soccon into separate variants for 32 and 64 + bit platforms. + (gnatlib): Use $(AR_FOR_TARGET) and $(RANLIB_FOR_TARGET) + vice $(AR) and $(RANLIB). Remove use of host variable $(RANLIB_FLAGS). + install-gnatlib: Use $(RANLIB_FOR_TARGET) vice $(RANLIB). Remove use + of host variable $(RANLIB_FLAGS). + (alpha64-dec-*vms*): Fix translations for 64 bit compiler. + Code clean up: remove unused/obsolete targets. + (EH_MECHANISM): New variable introduced to differenciate between the + two EH mechanisms statically. + (gnatlib-zcx, gnatlib-sjlj): Force EH_MECHANISM manually. + (LIBGNAT_OBJS): Add raise-gcc.o + (LIBGNAT_TARGET_PAIRS for ppc-vxworks): Use an specialized version of + s-osinte.adb, s-tpopsp.adb, and system.ads for the run time that + supports VxWorks 6 RTPs. + (EXTRA_GNATRTL_NONTASKING_OBJS for ppc-vxworks): Remove the use of + i-vxworks and i-vxwoio from the run time that supports VxWorks 6 RTPs. + + * raise.c: Move all GCC EH-related routines to raise-gcc.c + +2005-11-14 Jose Ruiz + + * s-tassta.adb (Create_Task): Move the code in charge of resetting the + deferral level, when abort is not allowed, to a later stage (the + Task_Wrapper). + (Task_Wrapper): If Abort is not allowed, reset the deferral level since + it will not get changed by the generated code. It was previously done + in Create_Task. + +2005-11-14 Thomas Quinot + Olivier Hainque + Eric Botcazou + + * decl.c: + Factor common code to build a storage type for an unconstrained object + from a fat or thin pointer type and a constrained object type. + (annotate_value): Handle BIT_AND_EXPR. + (annotate_rep): Don't restrict the back annotation of inherited + components to the type_annotate_only case. + (gnat_to_gnu_entity) : Do not invoke create_type_decl if + we are not defining the type. + : Likewise. + (gnat_to_gnu_entity) : Adjust comments and structure + to get advantage of the new maybe_stabilize_reference interface, to + ensure that what we reference is indeed stabilized instead of relying + on assumptions on what the stabilizer does. + (gnat_to_gnu_entity) : If the entity is an incomplete + type imported through a limited_with clause, use its non-limited view. + (Has_Stdcall_Convention): New macro, to centralize the Windows vs others + differentiation. + (gnat_to_gnu_entity): Use Has_Stdcall_Convention instead of a spread mix + of #if sections + explicit comparisons of convention identifiers. + (gnat_to_gnu_entity) : Decrement force_global if necessary + before early-returning for certain types when code generation is + disabled. + (gnat_to_gnu_entity) : Adjust comment attached to the + nullification of gnu_expr we do for objects with address clause and + that we are not defining. + (elaborate_expression_1): Do not create constants when creating + variables needed by the debug info: the dwarf2 writer considers that + CONST_DECLs is used only to represent enumeration constants, and emits + nothing for them. + (gnat_to_gnu_entity) : When turning a non-definition of an + object with an address clause into an indirect reference, drop the + initializing expression. + Include "expr.h". + (STACK_CHECK_BUILTIN): Delete. + (STACK_CHECK_PROBE_INTERVAL): Likewise. + (STACK_CHECK_MAX_FRAME_SIZE): Likewise. + (STACK_CHECK_MAX_VAR_SIZE): Likewise. + (gnat_to_gnu_entity): If gnat_entity is a renaming, do not mark the tree + corresponding to the renamed object as ignored for debugging purposes. + + * trans.c (tree_transform, case N_Attribute_Reference, case Attr_Size & + related): For a prefix that is a dereference of a fat or thin pointer, + if there is an actual subtype provided by the front-end, use that + subtype to build an actual type with bounds template. + (tree_transform, case N_Free_Statement): If an Actual_Designated_Subtype + is provided by the front-end, use that subtype to compute the size of + the deallocated object. + (gnat_to_gnu): When adding a statement into an elaboration procedure, + check for a potential violation of a No_Elaboration_Code restriction. + (maybe_stabilize_reference): New function, like gnat_stabilize_reference + with extra arguments to control whether to recurse through non-values + and to let the caller know if the stabilization has succeeded. + (gnat_stabilize_reference): Now a simple wrapper around + maybe_stabilize, for common uses without restriction on lvalues and + without need to check for the success indication. + (gnat_to_gnu, call_to_gnu): Adjust calls to gnat_stabilize_reference, to + pass false instead of 0 as the FORCE argument which is a bool. + (Identifier_to_gnu): Remove checks ensuring that an renamed object + attached to a renaming pointer has been properly stabilized, as no such + object is attached otherwise. + (call_to_gnu): Invoke create_var_decl to create the temporary when the + function uses the "target pointer" return mechanism. + Reinstate conversion of the actual to the type of the formal + parameter before any other specific treatment based on the passing + mechanism. This turns out to be necessary in order for PLACEHOLDER + substitution to work properly when the latter type is unconstrained. + + * gigi.h (build_unc_object_type_from_ptr): New subprogram, factoring a + common pattern. + (maybe_stabilize_reference): New function, like gnat_stabilize_reference + with extra arguments to control whether to recurse through non-values + and to let the caller know if the stabilization has succeeded. + + * utils2.c (gnat_build_constructor): Only sort the fields for possible + static output of record constructor if all the components are constant. + (gnat_build_constructor): For a record type, sort the list of field + initializers in increasing bit position order. + Factor common code to build a storage type for an unconstrained object + from a fat or thin pointer type and a constrained object type. + (build_unary_op) : Always recurse down conversions between + types variants, and process special cases of VIEW_CONVERT expressions + as their NOP_EXPR counterpart to ensure we get to the + CORRESPONDING_VARs associated with CONST_DECls. + (build_binary_op) : Do not strip VIEW_CONVERT_EXPRs + on the right-hand side. + + * utils.c (build_unc_object_type_from_ptr): New subprogram, factoring + a common pattern. + (convert) : Return the inner operand directly if we + are converting back to its original type. + (convert) : Fallthrough regular conversion code instead of + extracting the object if converting to a type variant. + (create_var_decl): When a variable has an initializer requiring code + generation and we are at the top level, check for a potential violation + of a No_Elaboration_Code restriction. + (create_var_decl): call expand_decl for CONST_DECLs, to set MODE, ALIGN + SIZE and SIZE_UNIT which we need for later back-annotations. + * utils.c: (convert) : Remove obsolete code. + : Do not lift the conversion if the target type + is an unchecked union. + (pushdecl): Set DECL_NO_STATIC_CHAIN on imported nested functions. + (convert) : When the types have the same + main variant, just replace the VIEW_CONVERT_EXPR. + : Revert 2005-03-02 change. + + * repinfo.h, repinfo.ads: Add tcode for BIT_AND_EXPR. + + * repinfo.adb (Print_Expr, Rep_Value): Handle Bit_And_Expressions. + +2005-11-14 Matthew Heaney + + * a-crbtgo.ads, a-crbtgo.adb, a-coorse.ads, a-coorse.adb, a-convec.ads, + a-convec.adb, a-coinve.ads, a-coinve.adb, a-cohama.ads, a-cohama.adb, + a-ciorse.ads, a-ciorse.adb, a-cihama.ads, a-cihama.adb, a-cidlli.ads, + a-cidlli.adb, a-cdlili.ads, a-cdlili.adb, a-coormu.adb, a-ciormu.adb, + a-cihase.adb, a-cihase.ads, a-cohase.adb, a-cohase.ads, a-ciorma.ads, + a-coorma.ads, a-ciormu.ads, a-coormu.ads, a-ciorma.adb, a-coorma.adb: + Compiles against the spec for ordered maps described in sections + A.18.6 of the most recent (August 2005) AI-302 draft. + +2005-11-14 Olivier Hainque + + * cuintp.c (UI_To_gnu): Use a proper type for intermediate computations + to ensure bias adjustments take place when need be and to prevent + occurrences of intermediate overflows. + +2005-11-14 Matthew Gingell + Olivier Hainque + + * tb-gcc.c (trace_callback): Work around problem with _Unwind_GetIP on + ia64 HP-UX. + + * tracebak.c (ia64 configuration): Enable _Unwind_Backtrace driven + tracebacks on ia64 HP-UX and provide explanatory comment. + Enable backtraces on ia64 GNU/Linux. + (x86 configuration): Bump FRAME_LEVEL to 1 to ensure we retrieve a real + base pointer from builtin_frame_address. Adjust BASE_SKIP accordingly. + +2005-11-14 Hristian Kirtchev + Javier Miranda + + * rtsfind.ads, exp_util.adb, exp_util.ads, exp_disp.adb, exp_disp.ads, + exp_ch7.adb, sem_ch9.adb, snames.adb, snames.ads, + exp_ch9.adb, exp_ch9.ads, exp_ch6.adb, exp_ch3.adb, exp_ch3.ads, + einfo.ads, einfo.adb: Complete support for Ada 2005 interfaces. + + * a-tags.ads, a-tags.adb: Major rewrite and additions to implement + properly new Ada 2005 interfaces (AI-345) and add run-time checks (via + assertions). + + * exp_dbug.ads, exp_dbug.adb (Get_Secondary_DT_External_Name): New + subprogram that generates the external name associated with a + secondary dispatch table. + (Get_Secondary_DT_External_Name): New subprogram that generates the + external name associated with a secondary dispatch table. + +2005-11-14 Emmanuel Briot + + * xref_lib.adb (Parse_Identifier_Info): It is possible for an entity + line in the ALI file to include both an instantiation reference, and a + returned value. + +2005-11-14 Vincent Celier + + * clean.adb (Check_Project): Look for Ada code in extending project, + even if Ada is not specified as a language. + Use new function DLL_Prefix for DLL_Name + (Clean_Interface_Copy_Directory): New procedure + (Clean_Library_Directory): New procedure + (Clean_Directory): Remove procedure, no longer used + (Clean_Project): Do not delete any file in an externally built project + + * prj-env.adb (Set_Ada_Paths.Add.Recursive_Add): Add the object + directory of an extending project, even when there are no Ada source + present. + (Ada_Objects_Path.Add): Add Library_ALI_Dir, not Library_Dir to the path + (Set_Ada_Paths.Add.Recursive_Add): Ditto + + * mlib-prj.adb (Check_Library): For all library projects, get the + library file timestamp. + (Build_Library): Copy ALI files in Library_ALI_Dir, not in Library_Dir + (Build_Library): Use new function DLL_Prefix for the DLL_Name + (Clean): Remove procedure, no longer used + (Ultimate_Extension_Of): New function + (Build_Library): When cleaning the library directory, only remove an + existing library file and any ALI file of a source of the project. + When cleaning the interface copy directory, remove any source that + could be a source of the project. + + * prj.ads, prj.adb (Project_Empty): Add values of new components + Library_TS and All_Imported_Projects. + (Project_Empty): Add values for new components of Project_Data: + Library_ALI_Dir and Display_Library_ALI_Dir + + * prj-attr.adb: New project level attribute name Library_ALI_Dir + + * prj-nmsc.adb (Check_Library_Attributes): Take into account new + attribute Library_ALI_Dir. + (Check_Library_Attributes): The library directory cannot be the same as + any source directory of the project tree. + (Check_Stand_Alone_Library): The interface copy directory cannot be + the same as any source directory of the project tree. + + * mlib.adb: Use Prj.Com.Fail, instead of Osint.Fail directly, to delete + all temporary files. + +2005-11-14 Robert Dewar + Ed Schonberg + + * sem_elab.adb: Change name Is_Package to Is_Package_Or_Generic_Package + (Check_Elab_Call): A call within a protected body is never an + elaboration call, and does not require checking. + (Same_Elaboration_Scope): Take into account protected types for both + entities. + (Activate_Elaborate_All_Desirable): New procedure + + * ali.ads, ali.adb: Implement new AD/ED for Elaborate_All/Elaborate + desirable + + * binde.adb: Implement new AD/ED for Elaborate_All/Elaborate desirable + (Elab_Error_Msg): Use -da to include internal unit links, not -de. + + * lib-writ.ads, lib-writ.adb: + Implement new AD/ED for Elaborate_All/Elaborate desirable + Use new Elaborate_All_Desirable flag in N_With_Clause node + + * sinfo.ads, sinfo.adb (Actual_Designated_Subtype): New attribute for + N_Free_Statement nodes. + Define new class N_Subprogram_Instantiation + Add Elaborate_Desirable flag to N_With_Clause node + Add N_Delay_Statement (covering two kinds of delay) + + * debug.adb: Introduce d.f flag for compiler + Add -da switch for binder + +2005-11-14 Ed Schonberg + Cyrille Comar + + * exp_aggr.adb (Build_Record_Aggr_Code): Do not create master entity + for task component, in the case of a limited aggregate. The enclosed + object declaration will create it earlier. Otherwise, in the case of a + nested aggregate, the object may appear in the wrong scope. + (Convert_Aggr_In_Object_Decl): Create a transient scope when needed. + (Gen_Assign): If the component being assigned is an array type and the + expression is itself an aggregate, wrap the assignment in a block to + force finalization actions on the temporary created for each row of the + enclosing object. + (Build_Record_Aggr_Code): Significant rewrite insuring that ctrl + structures are initialized after all discriminants are set so that + they can be accessed even when their offset is dynamic. + +2005-11-14 Robert Dewar + Hristian Kirtchev + + * sem_attr.adb: Implement Machine_Rounding attribute + (Analyze_Access_Attribute): The access attribute may appear within an + aggregate that has been expanded into a loop. + (Check_Task_Prefix): Add semantic check for attribute 'Callable and + 'Terminated whenever the prefix is of a task interface class-wide type. + (Analyze_Attribute): Add semantic check for attribute 'Identity whenever + the prefix is of a task interface class-wide type. + + * s-vaflop-vms-alpha.adb: Valid_D, Valid_F, Valid_G: Make Val constant + to avoid warnings. + + * s-fatgen.ads, s-fatgen.adb (Machine_Rounding): New function + Remove pragma Inline for [Unaligned_]Valid. + Add comments that Valid routines do not work for Vax_Float + + * exp_attr.adb: Implement Machine_Rounding attribute + + * snames.h: Add entry for Machine_Rounding attribute + +2005-11-14 Javier Miranda + Robert Dewar + Hristian Kirtchev + + * exp_attr.adb (Expand_N_Attribute_Reference, cases of Attribute_Size + and related): For a prefix that is an explicit dereference of an + access to unconstrained packed array type, annotate the dereference + with an actual subtype so GIGI can make a correct size computation. + (Expand_N_Attribute_Reference): In case of 'Unchecked_Access and + 'Unrestricted_Access, if the designated type is an interface we + add a type conversion to force the displacement of the pointer + to the secondary dispatch table. + Use Universal_Real instead of Long_Long_Float when we need a high + precision float type for the generated code (prevents gratuitous + Vax_Float stuff when pragma Float_Representation (Vax_Float) used) + (Expand_N_Attribute_Reference): Add support for attribute 'Callable and + 'Terminated for task interface class-wide objects. Generate a call to + the predefined dispatching routine used to retrieve the _task_id from + a task corresponding record. + (Expand_Fpt_Attribute): Major change to properly handle Vax_Float + + * sem_disp.adb: Change name Is_Package to Is_Package_Or_Generic_Package + (Check_Dispatching_Operation): Protect the frontend againts + previously detected errors. + + * Makefile.rtl: Add new instantiations of system.fat_gen + + * s-fatflt.ads, s-fatlfl.ads, s-fatllf.ads, s-fatsfl.ads: + Change name of instantiated package for better consistency + with newly added system.fat_gen instantiations. + + * s-filofl.ads, s-fishfl.ads, s-fvadfl.ads, s-fvaffl.ads, + s-fvagfl.ads: New files. + +2005-11-14 Cyrille Comar + Thomas Quinot + + * exp_ch5.adb (Expand_N_Assignment_Statement, Tagged_Case): For an + assignment of a value of a tagged type that has been rewritten to a + block statement, it is known by construction that no checks are + necessary for the statements within the block: analyze it with checks + suppressed. + (Expand_N_If_Statement): When killing a dead then-branch in an + if-statement that has elsif_parts, recompute the Current_Value node + for any entity whose value is known from the condition of the first + elsif_part. + (Expand_N_Return_Statement): When returning a mutable record, convert + the return value into its actual subtype in order to help the backend + to return the actual size instead of the maximum. This is another + aftermath of not returning mutable records on the sec-stack anymore. + + * sem_ch5.ads, sem_ch5.adb (Analyze_Iteration_Scheme): Minor change to + handling of error msg for suspicious reverse range iteration. + (Check_Possible_Current_Value_Condition): Move declaration from body to + spec, to allow this subprogram to be called from exp_ch5. + +2005-11-14 Thomas Quinot + + * exp_dist.adb (Append_Array_Traversal): Modify constrained case to + generate a set of nested array aggregates instead of a single flat + aggregate for multi-dimensional arrays. + +2005-11-14 Pascal Obry + + * expect.c (__gnat_kill) [Win32]: Fix implementation, the pid returned + by spawnve is a process handle, no need to convert. Add a parameter + close to control wether the process handle must be closed. + (__gnat_waitpid): Fix implementation, the pid returned by spawnve is + a process handle, not need to convert. + (__gnat_kill) [*]: Add dummy parameter close to match the Win32 spec. + + * g-expect.adb: (Kill): Document the new close parameter. + (Close): Do not release the process handle in the kill there as + waitpid() is using it. + (Send_Signal): Release the process handle. + +2005-11-14 Robert Dewar + + * exp_fixd.adb: Use Universal_Real instead of Long_Long_Float when we + need a high precision float type for the generated code (prevents + gratuitous Vax_Float stuff when pragma Float_Representation (Vax_Float) + used). + + * exp_imgv.adb: Use Universal_Real instead of Long_Long_Float when we + need a high precision float type for the generated code (prevents + gratuitous Vax_Float stuff when pragma Float_Representation (Vax_Float) + used). + (Expand_Width_Attribute): In configurable run-time, the attribute is not + allowed on non-static enumeration subtypes. Force a load error to emit + the correct diagnostic. + +2005-11-14 Thomas Quinot + Robert Dewar + Ed Schonberg + + * exp_intr.adb (Expand_Unc_Deallocation): If GIGI needs an actual + subtype to compute the size of the designated object at run-time, + create such a subtype and store it in the Actual_Designated_Subtype + attribute of the N_Free_Statement. + Generate itype for classwide designated object in both cases of + user-specified storage pool: specific and class-wide, not only in the + specific case. + Raise CE when trying to set a not null access type object to null. + (Expand_Dispatching_Constructor_Call): Retrieve subprogram actual with + an explicit loop, because freeze nodes make its position variable. + + * sem_intr.adb (Check_Intrinsic_Call): Given warning for freeing not + null object. + +2005-11-14 Javier Miranda + + * exp_strm.adb (Build_Stream_Attr_Profile, Build_Stream_Function, + Build_Stream_Procedure): Add the null-excluding attribute to the first + formal. + This has no semantic meaning under Ada95 mode but it is a + requirement under Ada05 mode. + + * par-ch3.adb (P_Access_Definition): Addition of warning message if + the null exclusion is used under Ada95 mode + (P_Null_Exclusion): The qualifier has no semantic meaning in Ada 95. + (P_Access_Definition): Remove assertion that forbids the use of + the null-exclusion feature in Ada95. + +2005-11-14 Robert Dewar + + * impunit.adb: Exclude container helper units not intended for use by + users. + +2005-11-14 Ed Schonberg + + * freeze.adb (Freeze_Entity): For an access formal that is an access + to subprogram, freeze the anonymous subprogram type at the same time, + to prevent later freezing in the wrong scope, such as the enclosing + subprogram body. + (Freeze_Entity): Freeze the equivalent_type of an access_to_protected_ + subprogram whenever available. + +2005-11-14 Arnaud Charlet + + PR ada/23732 + * gnatvsn.ads (Library_Version): Bump to 4.1 + +2005-11-14 Robert Dewar + + * g-debpoo.adb (Set_Valid): Use Integer_Address instead of + Storage_Offset to avoid wrap around causing invalid results. + +2005-11-14 Pascal Obry + + * gnatbind.adb (Is_Cross_Compiler): New function returning True for + cross-compiler. + (Scan_Bind_Arg): Fail with an error message if -M option is used + on a native compiler. + +2005-11-14 Robert Dewar + Vincent Celier + + * gprep.adb: Implement -C switch to scan comments + + * scng.adb: Scan comment symbol separately if Replace_In_Comments set + + * scans.ads: Comment updates (including new use of Tok_Comment in + preprocessing) + + * opt.ads: Add documentation for flags that are used by gprmake, + currently and in the next version of gprmake. + (Verbosity_Level): New variable + Add Replace_In_Comments switch + + * vms_data.ads: Add VMS equivalent for new gnatmake switches -vl, -vm + and -vm. + Add /REPLACE_IN_COMMENTS for gnatprep -C switch + +2005-11-14 Arnaud Charlet + + * g-regpat.adb (Fail): raise Expression_Error including the diagnostic + message, friendlier. + +2005-11-14 Robert Dewar + + * g-spitbo.adb: (Hash): Rotate by 3 instead of 1 + +2005-11-14 Doug Rupp + + * init.c [VMS]: Don't install __gnat_error_handler if DBG$TDBG defined. + +2005-11-14 Robert Dewar + + * interfac.ads: Change declarations of IEEE float types so that we no + longer need a separate version of this package for VMS. + +2005-11-14 Ed Schonberg + + * lib-xref.adb (Generate_Definition, Generate_Reference): Treat the + internal entity created for the declaration of a child subprogram body + with no spec as coming from source, to generate proper cross-reference + information. + +2005-11-14 Vincent Celier + + * make.adb (Compile_Sources): Change verbose message to minimum + verbosity level High for "is in an Ada library", "is a read-only + library" and "is an internal library", + (Create_Binder_Mapping_File): Path name of ALI file for library project + must include the library directory, not the object directory. + (Scan_Make_Arg): Make sure that Switch.M.Scan_Make_Switches is called + for new switches -vl, -vm and -vh. + (Verbose_Msg): Add new defaulted parameter Minimum_Verbosity + (Check): Use minimum verbosity Medium for some Verbose_Msg calls + (Compile_Sources): Do not attempt to compile if an ALI file is missing + in a project that is externally built. + (Compute_All_Imported_Projects): New procedure + (Gnatmake): Check if importing libraries should be regenerated because + at least an imported library is more recent. + (Initialize): For each project compute the list of the projects it + imports directly or indirectly. + (Add_Library_Search_Dir): New procedure, used in place of + Add_Lib_Search_Dir in procedure Scan_Make_Arg so that absolute paths are + put in the search paths. + (Add_Source_Search_Dir): New procedure, used in place of + Add_Src_Search_Dir in procedure Scan_Make_Arg so that absolute paths are + put in the search paths. + (Mark_Directory): Resolve the absolute path the directory before marking + it. + + * switch-m.adb (Scan_Make_Switches): Replace "raise Bad_Switch;" with + call to new procedure Bad_Switch. Call Scan_Pos with new parameter + Switch. Do not handle any exception. + (Scan_Make_Switches): Increment Ptr for new switches -vl, -vm and -vh + so that the switch is recognized as valid. + (Scan_Make_Switches): Implement new switches -vl, -vm and -vh. + +2005-11-14 GNAT Script + + * Make-lang.in: Makefile automatically updated + +2005-11-14 Pascal Obry + + * mdll.adb (Build_Reloc_DLL): Fix parameter handling when a map file is + used. + (Ada_Build_Reloc_DLL): Fix parameter handling when a map file is used. + In both cases the last argument was dropped. + +2005-11-14 Eric Botcazou + + * namet.h: (Column_Numbe): New type. + (Get_Column_Number): Define to sinput__get_column_number. + (Instantiation): Define to sinput__instantiation. + (Get_Column_Number): Declare. + (Instantiation): Likewise. + +2005-11-14 Robert Dewar + + * par-ch10.adb (P_Compilation_Unit): Add defenses against junk unit + syntax, which could cause compiler hangs. + +2005-11-14 Vincent Celier + + * prj-ext.adb: Take into account new environment variable + GPR_PROJECT_PATH. Warn if both GPR_PROJECT_PATH and ADA_PROJECT_PATH + are defined. + (Prj.Ext elaboration): For each directory in the ADA_PROJECT_PATH, + normalize its path name, making it absolute and resolving symbolic + links, and replace the original if resolved path is different. + +2005-11-14 Vincent Celier + + * prj-part.adb (Create_Virtual_Extending_Project): Put virtual project + into Prj.Tree.Tree_Private_Part.Projects_Htable for GPS. + +2005-11-14 Emmanuel Briot + + * prj-pp.adb (Print): Do not output the with statement if the + associated name is empty, which happens for virtual extending projects. + (Print): Preserve the "extends all" attribute when printing the project. + + * prj-tree.ads (String_Value_Of): Add comment about returned value for + a virtual extending project. + +2005-11-14 Ed Schonberg + + * sem_aggr.adb (Resolve_Aggregate): An others choice is legal on the + rhs of an assignment even if the type is unconstrained, when the + context is non-expanding. + In an inlined body, if the context type is private, + resolve with its full view, which must be a composite type. + +2005-11-14 Robert Dewar + Ed Schonberg + + * sem_ch10.adb: Change name Is_Package to Is_Package_Or_Generic_Package + Do not give obsolescent warning on with of subprogram (since we + diagnose calls) + (Analyze_With_Clause): Add test for obsolescent package + (Install_Context_Clauses): If the unit is the body of a child unit, do + not install twice the private declarations of the parents, to prevent + circular lists of Use_Clauses in a parent. + (Implicit_With_On_Parent): Do add duplicate with_clause on parent when + compiling body of child unit. + Use new class N_Subprogram_Instantiation + (Expand_With_Clause): If this is a private with_clause for a child unit, + appearing in the context of a package declaration, then the implicit + with_clauses generated for parent units are private as well. + (License_Check): Do not generate message if with'ed unit is internal + +2005-11-14 Gary Dismukes + Ed Schonberg + Thomas Quinot + + * sem_ch12.ads, sem_ch12.adb (Map_Entities): Exclude entities whose + names are internal, because they will not have a corresponding partner + in the actual package. + (Analyze_Formal_Package): Move the setting of the formal package spec's + Generic_Parent field so that it occurs prior to analyzing the package, + to allow proper operation of Install_Parent_Private_Declarations. + (Analyze_Package_Instantiation): Set the instantiated package entity's + Package_Instantiation field. + (Get_Package_Instantiation_Node): Move declaration to package spec. + Retrieve the N_Package_Instantiation node when the Package_Instantiation + field is present. + (Check_Generic_Child_Unit): Within an inlined call, the only possible + instantiation is Unchecked_Conversion, for which no parents are needed. + (Inline_Instance_Body): Deinstall and record the use_clauses for all + parent scopes of a scope being removed prior to inlining an instance + body. + (Analyze_Package_Instantiation): Do not perform front-end inlining when + the current context is itself an instance within a non-instance child + unit, to prevent scope stack errors. + (Save_References): If the node is an aggregate that is an actual in a + call, rewrite as a qualified expression to preserve some type + information, to resolve possible ambiguities in the instance. + (Instance_Parent_Unit): New global variable to record the ultimate + parent unit associated with a generic child unit instance (associated + with the existing Parent_Unit_Visible flag). + (type Instance_Env): New component Instance_Parent_Unit for stacking + parents recorded in the global Instance_Parent_Unit. + (Init_Env): Save value of Instance_Parent_Unit in the Instance_Env + stack. + (Install_Spec): Save the parent unit entity in Instance_Parent_Unit when + it's not a top-level unit, and only do this if Instance_Parent_Unit is + not already set. Replace test of Is_Child_Unit with test of parent's + scope against package Standard. Add comments and a ??? comment. + (Remove_Parent): Revise condition for resetting Is_Immediately_Visible + on a child instance parent to test that the parent equals + Instance_Parent rather than simply checking that the unit is not a + child unit. + (Restore_Env): Restore value of Instance_Parent_Unit from Instance_Env. + (Validate_Derived_Interface_Type_Instance): Verify that all ancestors of + a formal interface are ancestors of the corresponding actual. + (Validate_Formal_Interface_Type): Additional legality checks. + (Analyze_Formal_Derived_Interface_Type): New procedure to handle formal + interface types with ancestors. + (Analyze_Formal_Package): If formal is a renaming, use renamed entity + to diagnose attempts to use generic within its own declaration. + +2005-11-14 Ed Schonberg + Javier Miranda + + * sem_ch3.ads, sem_ch3.adb (Build_Discriminal): Add link to original + discriminant. + (Build_Private_Derived_Type): The entity of the created full view of the + derived type does not come from source. If after installing the private + declarations of the parent scope the parent is still private, use its + full view to construct the full declaration of the derived type. + (Build_Derived_Record_Type): Relax the condition that controls the + execution of the check that verifies that the partial view and + the full view agree in the set of implemented interfaces. In + addition, this test now only takes into account the progenitors. + (Derive_Interface_Subprograms): No need to derive subprograms + of ancestors that are interfaces. + (Derive_Subprograms): Remove formal No_Predefined_Prims and the + associated code. + Change name Is_Package to Is_Package_Or_Generic_Package + (Complete_Subprograms_Derivation): Handle the case in which the full + view is a transitive derivation of the ancestor of the partial view. + (Process_Full_View): Rename local subprogram Find_Interface_In_ + Descendant to Find_Ancestor_Interface to leave the code more clear. + Remove wrong code that avoids the generation of an error message + when the immediate ancestor of the partial view is an interface. + In addition some minor reorganization of the code has been done to + leave it more clear. + (Analyze_Type_Declaration): If type has previous incomplete tagged + partial view, inherit properly its primitive operations. + (Collect_Interfaces): Make public, for analysis of formal + interfaces. + (Analyze_Interface_Declaration): New procedure for use for regular and + formal interface declarations. + (Build_Derived_Record_Type): Add support for private types to the code + that checks if a tagged type implements abstract interfaces. + (Check_Aliased_Component_Type): The test applies in the spec of an + instance as well. + (Access_Type_Declaration): Clean up declaration of malformed type + declared as an access to its own classwide type, to prevent cascaded + crash. + (Collect_Interfaces): For private extensions and for derived task types + and derived protected types, the parent may be an interface that must + be included in the interface list. + (Access_Definition): If the designated type is an interface that may + contain tasks, create Master_Id for it before analyzing the expression + of the declaration, which may be an allocator. + (Record_Type_Declaration): Set properly the interface kind, for use + in allocators, the creation of master id's for task interfaces, etc. + +2005-11-14 Javier Miranda + Ed Schonberg + + * sem_ch6.adb (Check_Conformance): The null-exclusion feature can be + omitted in case of stream attribute subprograms. + (Check_Inline_Pragma): Handle Inline and Inline_Always pragmas that + appear immediately after a subprogram body, when there is no previous + subprogram declaration. + Change name Is_Package to Is_Package_Or_Generic_Package + (Process_Formals): A non null qualifier on a non null named access + type is not an error, and is a warning only if Redundant_Constructs + are flagged. + +2005-11-14 Gary Dismukes + Ed Schonberg + + * sem_ch7.adb (Install_Parent_Private_Declarations): New procedure + nested within Analyze_Package_Specification to install the private + declarations and use clauses within each of the parent units of a + package instance of a generic child package. + (Analyze_Package_Specification): When entering a private part of a + package associated with a generic instance or formal package, the + private declarations of the parent must be installed (by calling new + procedure Install_Parent_Private_Declarations). + Change name Is_Package to Is_Package_Or_Generic_Package + (Preserve_Full_Attributes): For a synchronized type, the corresponding + record is absent in a generic context, which does not indicate a + compiler error. + +2005-11-14 Ed Schonberg + + * sem_ch8.adb (Analyze_Subprogram_Renaming): In a generic context, do + not try to rewrite a renamed stream attribute, because the operations + on the type may not have been generated. + Handle properly a renaming_as_body generated for a stream operation + whose default is abstract because the object type itself is abstract. + (Find_Type): If the type is incomplete and appears as the prefix of a + 'Class reference, it is tagged, and its list of primitive operations + must be initialized properly. + (Chain_Use_Clauses): When chaining the use clauses that appear in the + private declaration of a parent unit, prior to compiling the private + part of a child unit, find on the scope stack the proper parent entity + on which to link the use clause. + (Note_Redundant_Use): Emit a warning when a redundant use clause is + detected. + (Analyze_Object_Renaming): An attribute reference is not a legal object + if it is not a function call. + +2005-11-14 Robert Dewar + Ed Schonberg + + * sem_eval.adb: Implement d.f flag + (Subtype_Statically_Match): A generic actual type has unknown + discriminants when the corresponding actual has a similar partial view. + If the routine is called to validate the signature of an inherited + operation in a child instance, the generic actual matches the full view, + +2005-11-14 Hristian Kirtchev + Ed Schonberg + Robert Dewar + Thomas Quinot + + * sem_res.adb (Resolve_Call): Provide a better error message whenever + a procedure call is used as a select statement trigger and is not an + entry renaming or a primitive of a limited interface. + (Valid_Conversion): If the operand has a single interpretation do not + remove address operations. + (Check_Infinite_Recursion): Skip freeze nodes when looking for a raise + statement to inhibit warning. + (Resolve_Unary_Op): Do not produce a warning when + processing an expression of the form -(A mod B) + Use Universal_Real instead of Long_Long_Float when we need a high + precision float type for the generated code (prevents gratuitous + Vax_Float stuff when pragma Float_Representation (Vax_Float) used) + (Resolve_Concatenation_Arg): Improve error message when argument is an + ambiguous call to a function that returns an array. + (Make_Call_Into_Operator, Operand_Type_In_Scope): Do not check that + there is an implicit operator in the given scope if we are within an + instance: legality check has been performed on the generic. + (Resolve_Unary_Op): Apply warnings checks on argument of Abs operator + after resolving operand, to avoid false warnings on overloaded calls. + +2005-11-14 Ed Schonberg + Javier Miranda + + PR ada/15604 + * sem_type.adb (Covers): In an inlined body, a composite type matches + a private type whose full view is a composite type. + (Interface_Present_In_Ancestor): Protect the frontend against + previously detected errors to ensure that its compilation + with assertions enabled gives the same output that its + compilation without assertions. + (Interface_Present_In_Ancestor): Add support for private types. + Change name In_Actual to In_Generic_Actual (clean up) + (Disambiguate): New predicate In_Actual, to recognize expressions that + appear in the renaming declaration generated for generic actuals, and + which must be resolved in the outer context. + +2005-11-14 Robert Dewar + Thomas Quinot + Hristian Kirtchev + Ed Schonberg + + * sem_util.ads, sem_util.adb: Change name Is_Package to + Is_Package_Or_Generic_Package. + (Check_Obsolescent): New procedure. + (Set_Is_Public): Remove obsolete junk test. + (Set_Public_Status): Do not set Is_Public on an object whose declaration + occurs within a handled_sequence_of_statemets. + (Is_Controlling_Limited_Procedure): Factor some of the logic, account + for a parameterless procedure. + (Enter_Name): Recognize renaming declarations created for private + component of a protected type within protected operations, so that + the source name of the component can be used in the debugger. + +2005-11-14 Ed Schonberg + Robert Dewar + + * sem_warn.ads, sem_warn.adb (Publicly_Referenceable): Generic formals + of a generic subprogram are not visible outside the body. + (Set_Warning_Switch): New procedure (code to set warning mode moved + here from Switch.C so that it can be shared by pragma processing. + (Check_References): Special case warning for non-modified non-imported + volatile objects. + * par-prag.adb: Modify processing of pragma Warnings to accomodate new + form with a string literal argument + +2005-11-14 Javier Miranda + + * s-finroo.ads, s-finroo.adb (Read): Addition of "not null" to the + anonymous access. + (Write): Addition of "not null" to the anonymous access. + (Read): Addition of "not null" to the anonymous access. + (Write): Addition of "not null" to the anonymous access. + + * s-strxdr.adb, s-stratt.ads, s-stratt.adb (I_AD, I_AS, I_B, I_C, I_F, + I_I, I_LF, I_LI, I_LLF, I_LLI, I_LLU, I_LU, I_SF, I_SI, I_SSI, I_SSU, + I_SU, I_U, I_WC): Addition of "not null" to the anonymous access. + (W_AD, W_AS, W_B, W_C, W_F, W_I, W_LF, W_LI, W_LLF, W_LLI, W_LLU, + W_LU, W_SF, W_SI, W_SSI, W_SSU, W_SU, W_U, W_WC): Addition of + "not null" to the anonymous access. + +2005-11-14 Robert Dewar + + * s-stoele.adb: Fix code for Address mod Storage_Offset for negative + offset values + +2005-11-14 Vincent Celier + + * switch.adb (Bad_Switch): New procedure + (Scan_Nat, Scan_Pos): Directly call Osint.Fail with the appropriate + message when in error. + + * switch.ads (Bad_Switch, Bad_Switch_Value, Missing_Switch_Value, + Too_Many_Output_Files): Remove declarations, no longer used. + (Scan_Nat): New parameter Switch + (Scan_Pos): Ditto + (Bad_Switch): New procedure + + * switch-b.adb (Scan_Binder_Switches): Replace "raise Bad_Switch;" + with call to new procedure Bad_Switch. Call Scan_Pos and Scan_Natwith + new parameter Switch. Replace "raise Too_Many_Output_Files;" with call + to Osint.Fail. Do not handle any exception. + +2005-11-14 Vincent Celier + + * tempdir.adb (Tempdir): Do not use environment variable TMPDIR if it + designates a non existent directory. + +2005-11-14 Robert Dewar + + * xgnatugn.adb: Replace invalid membership test by 'Valid + +2005-11-14 Vincent Celier + + * makegpr.adb (Gprmake): Do not attempt to build the global archive if + there is no object directory. + +2005-11-14 Robert Dewar + + * usage.adb: Minor adjustment to output format, use nn instead of nnn + (so that -gnateInnn does not run into next column) + +2005-11-14 Ed Falis + + * s-bitops.adb (Bits_Array): corrected comment: "unconstrained" => + "constrained" + +2005-11-14 Cyrille Comar + + * s-chepoo.ads: Add comments on Dereference. + Remove unnecessary inherited abstract primitives. + Cosmetic cleanup. + +2005-11-14 Robert Dewar + + * sem_cat.ads (Validate_Access_Type_Declaration): Remove declaration + node parameter, not needed, since it is available as Declaration_Node. + +2005-11-14 Geert Bosch + + * s-exnllf.adb (Exn_LLF): Fix comment to be more precise and + grammatically correct. + +2005-11-14 Vincent Celier + + * s-fileio.ads: Correct spelling error in comment + +2005-11-14 Cyrille Comar + Robert Dewar + Vincent Celier + Ben Brosgol + Jose Ruiz + Pascal Obry + + * gnat_ugn.texi: + Document that -fstack-check is needed for strict compliance with the + Ada 95 Reference Manual. + Correct reference to VAX systems to meet HP guidelines + Add documentation for new gnatmake switches -vl, -vm and -vh + Replace DEC Ada by HP Ada + Replace DIGITAL by HP + Remove empty section on tools in compatibility section + Clarify the Windows convention semantics. + Document the Win32 calling convention. + The Stdcall, Win32 and DLL convention are synonyms. + Add a note in -gnatR description about zero size record components + Note on new >= and <= warnings for -gnatwc + Document that equal sign after -gnatm is optional. + Note that strip is working fine on DLL built with a Library + Project. The restriction apply only to DLL built with gnatdll. + Update section about the way to debug a DLL. + Update information about the DLL convention. + Document -C switch for gnatprep + Document new attribute Library_ALI_Dir + Update elaboration doc to include implicit Elaborate pragmas now + generated for subprogram instantiations. + Document limitation on executable names that include spaces for --GCC, + --GNATBIND, and --GNATLINK switches. + Document that -w causes -gnatws to be added at start of gcc switches + + * gnat_rm.texi: Document that -mieee is needed for generating infinite + and NaN values in case of overflow on machines that are not fully + compliant with the IEEE floating-point standard. + Create a section describing the set of compiler options needed for + strict compliance with the Ada 95 Reference Manual. + Add documentation for pragma Obsolescent applied to a package + Clarify potential issues of mixed language programs related to the + I/O buffering enabling in the elaboration of the GNAT runtime. + Add extra documentation for pragma Restrictions (No_Elaboration_Code) + This documentation only patch adds extra documentsion for pragma + Restrictions (No_Elaboration_Code), explaining why it is not possible + to document this restriction in terms of allowed source constructs. + Document string literal form of pragma Warnings + Document new attribute Library_ALI_Dir + Add documentation on stable attributes in project files that was missing + + * gnat-style.texi: Indicate that paragraphs within a single comment + should be separated by empty comment lines + + * ug_words: Added replacements for -gnat95 and -gnat05 (/95 and + /05 respectively) + + * bindusg.adb: Minor cleanup, put -m before -M for consistency + +2005-11-14 Robert Dewar + + * a-secain.adb, a-slcain.adb, a-shcain.adb, a-chtgke.ads, a-chtgke.adb, + a-stwiha.adb, a-strhas.adb, a-chzla1.ads, a-chzla9.ads, a-stzbou.adb, + a-stzbou.ads, a-stzfix.adb, a-stzhas.adb, a-stzmap.adb, a-stzmap.ads, + a-stzsea.adb, a-stzsea.ads, a-stzsup.adb, a-stzsup.ads, a-stzunb.adb, + a-stzunb.ads, a-szuzha.adb, a-szuzha.ads, a-szuzti.adb, a-szuzti.ads, + a-ztcoau.adb, a-ztcoau.ads, a-ztcoio.adb, a-ztcstr.adb, a-ztcstr.ads, + a-ztdeau.adb, a-ztdeau.ads, a-ztdeio.adb, a-ztdeio.ads, a-ztedit.adb, + a-ztedit.ads, a-ztenau.ads, a-ztenio.adb, a-ztenio.ads, a-ztexio.adb, + a-ztexio.ads, a-ztfiio.adb, a-ztfiio.ads, a-ztflau.adb, a-ztflau.ads, + a-ztflio.adb, a-ztflio.ads, a-ztgeau.adb, a-ztgeau.ads, a-ztinau.adb, + a-ztinau.ads, a-ztinio.adb, a-ztmoau.ads, a-ztmoio.adb, a-ztmoio.ads, + a-zttest.adb, g-enblsp-vms-alpha.adb, g-enblsp-vms-alpha.adb, + g-enblsp-vms-ia64.adb, g-enblsp-vms-ia64.adb, system-linux-hppa.ads, + a-chacon.adb, a-chacon.ads, a-wichun.adb, a-wichun.ads, a-zchuni.adb, + a-zchuni.ads, g-trasym-vms-alpha.adb, g-trasym-vms-ia64.adb, + system-hpux-ia64.ads, g-soccon-unixware.ads, g-soliop-unixware.ads, + g-soccon-interix.ads, g-soliop-solaris.ads, g-eacodu-vms.adb, + g-expect-vms.adb, g-socthi-vms.adb, g-soliop-mingw.ads, + a-intnam-unixware.ads, a-intnam-lynxos.ads, a-intnam-tru64.ads, + a-intnam-aix.ads, a-intnam-linux.ads, a-intnam-linux.ads, + a-intnam-dummy.ads, a-numaux-libc-x86.ads, a-intnam-interix.ads, + a-intnam-solaris.ads, a-calend-vms.adb, a-calend-vms.ads, + a-intnam-vms.ads, a-calend-mingw.adb, a-intnam-mingw.ads, + a-intnam-vxworks.ads, a-numaux-vxworks.ads, system-unixware.ads, + system-linux-ia64.ads, a-intnam-freebsd.ads, system-freebsd-x86.ads, + system-lynxos-ppc.ads, system-linux-x86_64.ads, a-stunha.adb, + a-cgaaso.ads, a-cgaaso.adb, a-chtgop.adb, a-cgcaso.adb, a-cgarso.adb, + a-cohata.ads, a-crbtgk.adb, a-crbltr.ads, a-coprnu.adb, a-rbtgso.adb, + a-intnam-darwin.ads, system-darwin-ppc.ads, gprmake.adb, makegpr.ads, + system-tru64.ads, system-aix.ads, system-solaris-x86.ads, + system-irix-o32.ads, s-interr-sigaction.adb, system-irix-n32.ads, + s-parame-mingw.adb, system-hpux.ads, s-traceb-hpux.adb, + system-linux-x86.ads, s-inmaop-dummy.adb, system-os2.ads, + system-interix.ads, system-solaris-sparc.ads, + system-solaris-sparcv9.ads, s-inmaop-vms.adb, + s-mastop-vms.adb, expander.adb, expander.ads, s-gloloc-mingw.adb, + system-mingw.ads, system-vms-zcx.ads, s-osinte-fsu.adb, + s-traceb-mastop.adb, a-exextr.adb, a-exstat.adb, a-filico.ads, + a-finali.ads, a-interr.ads, a-intsig.adb, a-intsig.ads, + a-except.ads, a-numaux-x86.ads, a-astaco.adb, a-calend.adb, + a-calend.ads, a-chahan.adb, a-chahan.ads, a-chlat9.ads, + a-colien.adb, a-colien.ads, a-colire.adb, a-colire.ads, + a-comlin.adb, a-comlin.ads, a-cwila1.ads, a-cwila9.ads, + a-elchha.adb, a-decima.adb, a-decima.ads, a-diocst.ads, + a-direio.adb, a-direio.ads, a-excach.adb, a-excach.adb, + a-exctra.ads, ali-util.adb, a-ngcefu.adb, a-ngcoty.adb, + a-ngcoty.ads, a-nudira.adb, a-nudira.ads, a-nuflra.adb, + a-numaux.ads, a-reatim.ads, a-sequio.adb, a-sequio.ads, + a-siocst.ads, a-ssicst.ads, a-stmaco.ads, a-storio.adb, + a-strbou.adb, a-strbou.ads, a-stream.ads, a-strfix.adb, + a-strmap.adb, a-strmap.ads, a-strsea.adb, a-strsea.ads, + a-strsup.adb, a-strsup.ads, a-strunb.adb, a-strunb.ads, + a-stwibo.adb, a-stwibo.ads, a-stwifi.adb, a-stwima.adb, + a-stwima.ads, a-stwise.adb, a-stwise.ads, a-stwisu.adb, + a-stwisu.ads, a-stwiun.adb, a-stwiun.ads, a-suteio.adb, + a-suteio.ads, a-swmwco.ads, a-swuwti.adb, a-swuwti.ads, + a-sytaco.adb, a-sytaco.ads, a-tasatt.adb, a-taside.adb, + a-taside.ads, a-teioed.adb, a-textio.adb, a-textio.ads, + a-ticoau.adb, a-ticoau.ads, a-ticoio.adb, a-tideau.adb, + a-tideio.adb, a-tienau.adb, a-tienio.adb, a-tifiio.adb, + a-tiflio.adb, a-tigeau.adb, a-tigeau.ads, a-tiinau.adb, + a-tiinio.adb, a-timoau.adb, a-timoio.adb, a-timoio.ads, + a-tiocst.ads, a-titest.adb, atree.adb, a-witeio.adb, + a-witeio.ads, a-wtcoau.adb, a-wtcoau.ads, a-wtcoio.adb, + a-wtcstr.ads, a-wtdeau.adb, a-wtdeio.adb, a-wtedit.adb, + a-wtedit.ads, a-wtenau.adb, a-wtenio.adb, a-wtfiio.adb, + a-wtflio.adb, a-wtgeau.adb, a-wtinau.adb, a-wtinio.adb, + a-wtmoau.adb, a-wtmoio.adb, a-wttest.adb, back_end.adb, + bindgen.adb, butil.adb, butil.ads, checks.ads, cio.c, comperr.adb, + csets.ads, cstand.adb, debug.ads, elists.ads, errno.c, errout.adb, + errout.ads, erroutc.adb, erroutc.ads, errutil.adb, errutil.ads, + errutil.ads, err_vars.ads, eval_fat.adb, exp_ch11.adb, exp_ch11.ads, + exp_ch2.adb, exp_ch7.ads, exp_imgv.ads, exp_pakd.adb, exp_prag.adb, + exp_prag.ads, exp_tss.adb, exp_tss.ads, exp_vfpt.ads, fe.h, fmap.adb, + freeze.ads, frontend.adb, frontend.ads, g-arrspl.adb, g-arrspl.ads, + g-awk.adb, g-awk.ads, g-boumai.ads, g-calend.adb, g-calend.ads, + g-catiio.adb, g-comlin.adb, g-comlin.ads, g-comlin.ads, g-comlin.ads, + g-comver.adb, g-crc32.adb, g-crc32.ads, g-ctrl_c.ads, g-curexc.ads, + g-debpoo.ads, g-debuti.adb, g-diopit.adb, g-diopit.ads, g-dirope.adb, + g-dirope.ads, g-dyntab.adb, g-dyntab.ads, g-excact.adb, g-excact.ads, + g-except.ads, g-exctra.adb, g-exctra.ads, g-expect.ads, g-flocon.ads, + g-hesorg.ads, g-io.adb, g-locfil.ads, g-md5.adb, g-md5.ads, g-md5.ads, + g-moreex.adb, g-signal.ads, g-signal.adb, gnatbind.ads, gnatchop.adb, + gnatcmd.adb, gnatfind.adb, gnatlbr.adb, gnatmake.ads, gnatmem.adb, + gnatprep.adb, gnatprep.ads, gnatsym.adb, gnatxref.adb, g-os_lib.adb, + g-os_lib.ads, g-pehage.adb, g-pehage.ads, gprep.ads, g-regexp.adb, + g-regexp.ads, g-regist.adb, g-regist.ads, g-regpat.ads, g-semaph.adb, + g-socthi.adb, g-soliop.ads, g-spipat.adb, g-spipat.ads, g-sptabo.ads, + g-sptain.ads, g-sptavs.ads, g-string.ads, g-tasloc.adb, g-tasloc.ads, + g-trasym.adb, g-trasym.ads, i-fortra.adb, i-fortra.ads, inline.adb, + layout.adb, live.adb, make.ads, makeutl.ads, makeutl.adb, mdll-fil.adb, + mdll-fil.ads, mdll-utl.ads, memroot.ads, memtrack.adb, mlib.ads, + mlib-fil.adb, mlib-fil.ads, mlib-prj.ads, mlib-utl.adb, mlib-utl.ads, + nlists.adb, nlists.ads, osint.adb, osint.ads, osint-c.adb, osint-l.adb, + osint-l.ads, osint-m.ads, output.adb, par.adb, par.adb, par.ads, + par-ch11.adb, par-ch12.adb, par-ch2.adb, par-ch4.adb, par-ch5.adb, + par-ch6.adb, par-ch9.adb, par-endh.adb, par-labl.adb, par-load.adb, + par-tchk.adb, prep.adb, prepcomp.adb, prepcomp.ads, prj-attr.ads, + prj-com.ads, prj-dect.adb, prj-dect.ads, prj-env.ads, prj-err.ads, + prj-ext.ads, prj-makr.adb, prj-makr.ads, prj-nmsc.ads, prj-pars.adb, + prj-pars.ads, prj-part.ads, prj-pp.ads, prj-proc.ads, prj-strt.adb, + prj-strt.ads, prj-tree.adb, prj-util.adb, prj-util.ads, rtsfind.adb, + sem.adb, sem.ads, sem_case.adb, sem_case.ads, sem_ch11.adb, + sem_ch4.adb, sem_ch6.ads, sem_ch7.ads, sem_dist.ads, sem_elab.ads, + sem_elim.ads, sem_eval.ads, sem_intr.ads, sem_maps.adb, sem_maps.ads, + sem_maps.ads, sem_res.ads, sem_type.ads, sfn_scan.adb, sfn_scan.ads, + s-imgwch.ads, s-imgwiu.adb, s-imgwiu.ads, s-inmaop.ads, sinput.adb, + sinput.ads, s-pack03.adb, s-pack03.ads, s-pack05.adb, s-pack05.ads, + s-pack06.adb, s-pack06.ads, s-pack07.adb, s-pack07.ads, s-pack09.adb, + s-pack09.ads, s-pack10.adb, s-pack10.ads, s-pack11.adb, s-pack11.ads, + s-pack12.adb, s-pack12.ads, s-pack13.adb, s-pack13.ads, s-pack14.adb, + s-pack14.ads, s-pack15.adb, s-pack15.ads, s-pack17.adb, s-pack17.ads, + s-pack18.adb, s-pack18.ads, s-pack19.adb, s-pack19.ads, s-pack20.adb, + s-pack20.ads, s-pack21.adb, s-pack21.ads, s-pack22.adb, s-pack22.ads, + s-pack23.adb, s-pack23.ads, s-pack24.adb, s-pack24.ads, s-pack25.adb, + s-pack25.ads, s-pack26.adb, s-pack26.ads, s-pack27.adb, s-pack27.ads, + s-pack28.adb, s-pack28.ads, s-pack29.adb, s-pack29.ads, s-pack30.adb, + s-pack30.ads, s-pack31.adb, s-pack31.ads, s-pack33.adb, s-pack33.ads, + s-pack34.adb, s-pack34.ads, s-pack35.adb, s-pack35.ads, s-pack36.adb, + s-pack36.ads, s-pack37.adb, s-pack37.ads, s-pack38.adb, s-pack38.ads, + s-pack39.adb, s-pack39.ads, s-pack40.adb, s-pack40.ads, s-pack41.adb, + s-pack41.ads, s-pack42.adb, s-pack42.ads, s-pack43.adb, s-pack43.ads, + s-pack44.adb, s-pack44.ads, s-pack45.adb, s-pack45.ads, s-pack46.adb, + s-pack46.ads, s-pack47.adb, s-pack47.ads, s-pack48.adb, s-pack48.ads, + s-pack49.adb, s-pack49.ads, s-pack50.adb, s-pack50.ads, s-pack51.adb, + s-pack51.ads, s-pack52.adb, s-pack52.ads, s-pack53.adb, s-pack53.ads, + s-pack54.adb, s-pack54.ads, s-pack55.adb, s-pack55.ads, s-pack56.adb, + s-pack56.ads, s-pack57.adb, s-pack57.ads, s-pack58.adb, s-pack58.ads, + s-pack59.adb, s-pack59.ads, s-pack60.adb, s-pack60.adb, s-pack60.ads, + s-pack61.adb, s-pack61.ads, s-pack62.adb, s-pack62.ads, s-pack63.adb, + s-pack63.ads, s-parint.adb, s-parint.adb, s-parint.ads, sprint.ads, + s-purexc.ads, s-restri.ads, s-restri.adb, s-scaval.adb, s-scaval.ads, + s-secsta.adb, s-secsta.ads, s-sequio.adb, s-sequio.ads, stand.ads, + s-tasuti.adb, s-traceb.adb, s-traceb.ads, stringt.adb, stringt.ads, + styleg.ads, s-valboo.adb, s-valboo.ads, s-valcha.adb, s-valcha.ads, + s-valdec.adb, s-valdec.ads, s-valint.adb, s-valint.ads, s-valint.ads, + s-vallld.adb, s-vallld.ads, s-vallli.adb, s-vallli.ads, s-valllu.adb, + s-valllu.ads, s-valrea.adb, s-valrea.ads, s-valuns.adb, s-valuns.ads, + s-valuti.adb, s-valuti.ads, s-valwch.ads, s-veboop.adb, s-veboop.ads, + s-vercon.adb, s-vercon.ads, s-wchcnv.adb, s-wchcnv.ads, s-wchcon.ads, + s-wchjis.adb, s-wchjis.ads, s-wchstw.adb, s-wchstw.adb, s-wchstw.ads, + s-wchwts.adb, s-wchwts.ads, s-widboo.adb, s-widboo.ads, s-widcha.adb, + s-widcha.ads, s-widenu.adb, s-widenu.ads, s-widlli.adb, s-widlli.ads, + s-widllu.adb, s-widllu.ads, s-widwch.adb, s-widwch.ads, s-wwdcha.adb, + s-wwdcha.ads, s-wwdenu.adb, s-wwdenu.ads, symbols.adb, symbols.ads, + table.ads, targparm.adb, targparm.ads, tb-alvms.c, tb-alvxw.c, + tbuild.adb, tree_io.ads, treepr.adb, treeprs.adt, ttypef.ads, + ttypes.ads, types.adb, uintp.adb, uintp.ads, uname.ads, urealp.ads, + usage.ads, validsw.ads, vxaddr2line.adb, widechar.adb, widechar.ads, + xeinfo.adb, xnmake.adb, xref_lib.ads, xr_tabls.adb, xr_tabls.ads, + xsinfo.adb, xtreeprs.adb, xsnames.adb, vms_conv.ads, vms_conv.adb, + a-dirval.ads, a-dirval.adb, a-dirval-mingw.adb, a-direct.ads, + a-direct.adb, indepsw.ads, prj-attr-pm.ads, system-linux-ppc.ads, + a-numaux-darwin.ads, a-numaux-darwin.adb, + a-swuwha.ads, a-stunha.ads: Minor reformatting + +2005-11-14 Robert Dewar + + PR ada/18434 + * osint-m.adb: Add pragma Elaborate_All for Osint + +2005-11-10 Eric Botcazou + + PR ada/23995 + * trans.c (call_to_gnu): Restore statement lost in translation. + +2005-11-08 Eric Botcazou + + * init.c: Use the Linux-specific section for the IA-64/Linux target. + (__gnat_adjust_context_for_raise): Add conditional code so that the + IA-64 is also supported. + +2005-11-03 James E Wilson + + PR ada/23427 + * trans.c (gnat_to_gnu): Use TYPE_SIZE_UNIT not TYPE_SIZE in + TREE_OVERFLOW check. + +2005-09-21 Olivier Hainque + + PR ada/22418 + * decl.c (maybe_pad_type): Use proper bitsizetype for XVZ objects, + as we create them to store a size in bits. + +2005-10-21 Eric Botcazou + + PR ada/21937 + PR ada/22328 + PR ada/22381 + PR ada/22383 + PR ada/22419 + PR ada/22420 + * utils2.c (build_return_expr): New helper function. + * gigi.h (build_return_expr): Declare it. + * trans.c (Subprogram_Body_to_gnu): Use build_return_expr instead + of manually building the RETURN_EXPR tree. + (call_to_gnu): Pass MODIFY_EXPR through build_binary_op. + (gnat_to_gnu) : Pass MODIFY_EXPR through + build_binary_op for the "target pointer" case. Use build_return_expr + instead of manually building the RETURN_EXPR tree. + +2005-09-16 Laurent Guerby + + PR ada/23788 + * s-tpinop.ads: Make this unit Preelaborate. + +2005-09-16 Andreas Jaeger + + * socket.c: Add string.h for memcpy. + +2005-09-05 Arnaud Charlet + + * dec-io.ads, dec-io.adb: Removed, no longer used. + +2005-09-01 Arnaud Charlet + + * a-calend-mingw.adb: Add call to OS_Primitives.Initialize; + + * s-taprop-mingw.adb, s-taprop-vms.adb, s-taprop-solaris.adb, + s-taprop-os2.adb, s-taprop-irix-athread.adb, s-taprop-linux.adb, + s-taprop-hpux-dce.adb, s-taprop-irix.adb, s-taprop-tru64.adb, + s-taprop-lynxos.adb: Move with clauses outside Warnings Off now that + dependent units are Preelaborate. + (Initialize): Call Interrupt_Managemeent.Initialize and + OS_Primitives.Initialize to ensure proper initialization of this unit. + Remove use of System.Soft_Links + Make this unit Preelaborate. + + * s-stache.ads, s-taspri-vxworks.ads, s-taspri-mingw.ads, + s-taspri-vms.ads, s-tasinf-solaris.ads, s-taspri-os2.ads, + s-taspri-lynxos.ads, s-taspri-hpux-dce.ads, s-taspri-tru64.ads, + s-tasinf-tru64.ads, s-tasinf-irix.ads, s-tasinf-irix-athread.ads, + s-proinf-irix-athread.adb, s-proinf-irix-athread.ads, + s-tratas.ads, s-tasinf.ads: Minor reformatting. + Add pragma Preelaborate, since these packages are suitable for this + categorization. + Update comments. + + * s-traent-vms.ads, s-intman-dummy.adb, + s-taprop-dummy.adb: Make this unit Preelaborate. + + * s-osprim-vxworks.adb, s-osprim-vms.adb, s-osprim-vms.ads, + s-osprim-mingw.adb, s-intman-vxworks.ads, s-intman-vxworks.adb, + s-intman-vms.adb, s-intman-mingw.adb, s-intman-vms.ads, + s-osprim-unix.adb, s-osprim-os2.adb, s-osprim-solaris.adb, + s-intman-solaris.adb, s-intman-irix-athread.adb, + s-intman-irix.adb: Mark this unit Preelaborate. + (Initialize): New procedure. + Update comments. + + * s-taspri-linux.ads: Removed. + + * s-tpopsp-solaris.adb (Initialize): Create the key in this procedure, + as done by other implementations (e.g. posix). + + * s-taprop.ads (Timed_Delay): Update spec since the caller now is + responsible for deferring abort. + Mark this unit Preelaborate. + + * s-taprob.adb, s-tarest.adb: Call System.Tasking.Initialize to ensure + proper initialization of the tasking run-time. + + * s-tasdeb.ads: Mark this unit Preelaborate. + (Known_Tasks): Add explicit default value to avoid elaboration code. + + * s-inmaop-vms.adb (Elaboration code): Add call to + Interrupt_Management.Initialize since the elaboration code depends on + proper initialization of this package. + + * s-intman.ads, s-inmaop-posix.adb, s-intman-posix.adb, + s-osprim.ads, s-taprop-posix.adb, s-taspri-posix.ads, + s-osprim-posix.adb: Make this unit Preelaborate. + + * a-calend.adb: Add call to OS_Primitives.Initialize + + * a-elchha.adb: Update use of Except.Id.Full_Name. + Minor reformatting. + Remove use of Ada.Exceptions.Traceback when possible, cleaner. + + * a-dynpri.adb, a-sytaco.adb, a-sytaco.ads: + Move with clauses outside Warnings Off now that dependent units are + Preelaborate. + Use raise xxx with "..."; Ada 2005 form. + + * a-taside.ads, a-taside.adb: + Remove some dependencies, to make it easier to make this unit truly + Preelaborate. + Rewrite some code to be conformant with Preelaborate rules. + + * g-os_lib.adb: Remove non-preelaborate code so that this unit can be + marked Preelaborate in the future. + + * s-proinf.ads, g-string.ads, s-auxdec.ads, s-auxdec-vms_64.ads: Make + these units Preelaborate. + + * s-exctab.adb: Update use of Except.Id.Full_Name. + + * s-soflin.ads, s-soflin.adb: Mark this unit Preelaborate_05. + (Set_Exc_Stack_Addr_Soft, Get_Exc_Stack_Addr_NT, Set_Exc_Stack_Addr_NT, + Set_Exc_Stack_Addr): Removed, no longer used. + Remove reference to *Machine_State_Addr*, no longer needed. + + * s-stalib.ads: Mark this unit as Preelaborate[_05]. + (Exception_Data): Full_Name is now a System.Address so that this unit + can be made Preelaborate. + Clean up/simplify code thanks to Full_Name being a System.Address. + Remove obsolete pragma Suppress (All_Checks), no longer needed. + + * s-taskin.ads, s-taskin.adb: + Move with clauses outside Warnings Off now that dependent units are + Preelaborate. + Make this unit Preelaborate. + (Initialize): New proceduure, replace elaboration code and makes the + set up of the tasking run-time cleaner. + (Detect_Blocking): Now a function instead of a deferred boolean, to + obey Preelaborate rules. + + * s-tassta.adb (Finalize_Global_Tasks): Remove Get/Set_Exc_Stack_Addr + soft links, no longer used. + + * s-traces.ads, s-traent.ads: Add pragma Preelaborate, since these + packages are suitable for this categorization. + + * s-solita.adb: Replace use of Ada.Exception by raise xxx with "..." + since we compile run-time sources in Ada 2005 mode. + (Timed_Delay_T): Call Abort_Defer/Undefer around Timed_Delay, to + avoid having s-taprop*.adb depend on s-soflin and to avoid code + duplication. + Remove reference to *Machine_State_Addr*, no longer needed. + +2005-09-01 Arnaud Charlet + + * s-mastop-tru64.adb, s-mastop-irix.adb, s-mastop-vms.adb + (Enter_Handler, Set_Signal_Machine_State): Removed, no longer used. + Remove reference to System.Exceptions. + + * s-mastop-x86.adb: Removed, no longer used. + + * s-traceb-mastop.adb: Adjust calls to Pop_Frame. + + * a-excach.adb: Minor reformatting. + + * a-except.ads, a-except.adb: Remove global Warnings (Off) pragma, and + instead fix new warnings that were hidden by this change. + (AAA, ZZZ): Removed, replaced by... + (Code_Address_For_AAA, Code_Address_For_ZZZ): ... these functions, who + are used instead of constants, to help make Ada.Exception truly + preelaborate. + (Rcheck_*, Raise_Constraint_Error, Raise_Program_Error, + Raise_Storage_Error): File is now a System.Address, to simplify code. + (Elab code): Removed, no longer used. + (Null_Occurrence): Remove Warnings Off and make this construct + preelaborate. + Remove code related to front-end zero cost exception handling, since + it is no longer used. + Remove -gnatL/-gnatZ switches. + + * a-exexda.adb (Append_Info_Exception_Name, Set_Exception_C_Msg): + Update use of Except.Msg. + + * gnat1drv.adb, inline.adb, bindgen.adb, debug.adb, exp_ch11.ads, + freeze.adb, frontend.adb, lib.adb, exp_ch11.adb: Remove code related + to front-end zero cost exception handling, since it is no longer used. + Remove -gnatL/-gnatZ switches. + + * lib-writ.ads: Minor reformatting + Remove doc of UX + + * Makefile.rtl: Remove references to s-except*, s-mastop-x86* + + * Make-lang.in: Remove references to s-except.ads + + * s-except.ads: Removed, no longer used. + + * s-mastop.ads, s-mastop.adb: + (Enter_Handler, Set_Signal_Machine_State): Removed, no longer used. + Remove reference to System.Exceptions. + + * raise.h, usage.adb, targparm.adb, targparm.ads, switch-m.adb, + switch-b.adb: Remove code related to front-end zero cost exception + handling, since it is no longer used. + Remove -gnatL/-gnatZ switches. + +2005-09-01 Robert Dewar + Gary Dismukes + Javier Miranda + + * exp_ch4.adb (Expand_N_In): Replace test of expression in its own + type by valid test and generate warning. + (Tagged_Membership): Generate call to the run-time + subprogram IW_Membership in case of "Iface_CW_Typ in Typ'Class" + Change formal name Subtype_Mark to Result_Definition in several calls to + Make_Function_Specification. + (Expand_Allocator_Expression): Add tests for suppression of the AI-344 + check for proper accessibility of the operand of a class-wide allocator. + The check can be left out if checks are suppressed or if the expression + has a specific tagged type whose level is known to be safe. + + * exp_ch5.adb (Expand_N_Assignment_Statement): Simplify the code that + generates the run-time check associated with null-excluding entities. + (Expand_N_Return_Statement): Add tests to determine if the accessibility + check on the level of the return expression of a class-wide function + can be elided. The check usually isn't needed if the expression has a + specific type (unless it's a conversion or a formal parameter). Also + add a test for whether accessibility checks are suppressed. Augment + the comments to describe the conditions for performing the check. + +2005-09-01 Hristian Kirtchev + Javier Miranda + Gary Dismukes + Ed Schonberg + + * a-tags.adb (IW_Membership): Give support to + "Iface_CW_Typ in T'Class". For this purpose the functionality of this + subprogram has been extended to look for the tag in the ancestors tag + table. + Update the structure of the GNAT Dispatch Table to reflect the + additional two tables used in dispatching selects. + Introduce appropriate array types and record components in + Type_Specific_Data to reflect the two tables. + (Get_Entry_Index, Set_Entry_Index): Retrieve and set the entry index in + the TSD of a tag, indexed by position. + (Get_Prim_Op_Kind, Set_Prim_Op_Kind): Retrieve and set the primitive + operation kind in the TSD of a tag, indexed by position. + + * a-tags.ads: Introduce an enumeration type to capture different + primitive operation kinds. Define a constant reflecting the number of + predefined primitive operations. + (Get_Entry_Index, Set_Entry_Index): Set and retrieve the entry index + of an entry wrapper. + (Get_Prim_Op_Kind, Set_Prim_Op_Kind): Set and retrieve the kind of + callable entity of a primitive operation. + + * exp_ch3.adb (Freeze_Record_Type): Generate the declarations of the + primitive operations used in dispatching selects for limited + interfaces, limited tagged, task and protected types what implement a + limited interface. + (Freeze_Type): Generate the bodies of the primitive operations used in + dispatching selects for limited tagged, task and protected types that + implement a limited interface. Generate statements to populate the two + auxiliary tables used for dispatching in select statements. + (Freeze_Record_Type): Add call to initialize the dispatch table entries + associated with predefined interface primitive operations. + (Build_Dcheck_Function): Change Set_Subtype_Mark to + Set_Result_Definition. + (Build_Variant_Record_Equality): Change Subtype_Mark to + Result_Definition. + (Freeze_Enumeration_Type): Change Subtype_Mark to Result_Definition. + (Predef_Spec_Or_Body): Change Subtype_Mark to Result_Definition. + (Build_Assignment): Simplify the code that adds the run-time-check. + (Expand_N_Object_Declaration): Code cleanup. + + * exp_ch7.adb (Make_Clean): Select the appropriate type for locking + entries when there is a protected type that implements a limited + interface. + + * exp_ch9.adb: Add package Select_Expansion_Utilities that contains + common routines used in expansion of dispatching selects. + (Add_Private_Declarations): Select the appropriate protection type when + there is a protected type that implements a limited interface. + (Build_Parameter_Block): Generate a wrapped parameter block. + (Build_Protected_Subprogram_Body): Select the appropriate type for + locking entries when there is a protected type that implements a + limited interface. + (Build_Wrapper_Spec): Set the flag and wrapped entity for procedures + classified as entry wrappers. + (Expand_N_Asynchronous_Select): Add support for expansion of dispatching + asynchronous selects. + (Expand_N_Conditional_Entry_Call): Add support for expansion of + dispatching conditional selects. + (Expand_N_Protected_Type_Declaration): Select the appropriate type for + protection when there is a protected type that implements limited + interfaces. + (Expand_N_Timed_Entry_Call): Add support for expansion of dispatching + timed selects. + (Extract_Dispatching_Call): Extract the entity of the name of a + dispatching call, the object parameter, actual parameters and + corresponding formals. + (Make_Initialize_Protection): Correct logic of protection initialization + when there is a protected type that implements a limited interface. + (Parameter_Block_Pack): Populate a wrapped parameter block with the + values of actual parameters. + (Parameter_Block_Unpack): Retrieve the values from a wrapped parameter + block and assign them to the original actual parameters. + + * exp_ch9.ads (Subprogram_Protection_Mode): New type. + (Build_Protected_Sub_Specification): Change the type and name of the + last formal to account for the increased variety of protection modes. + + * einfo.ads, einfo.adb (Was_Hidden): New attribute. Present in all + entities. Used to save the value of the Is_Hidden attribute when the + limited-view is installed. + (Is_Primitive_Wrapper, Set_Is_Primitive_Wrapper): Retrieve and change + the attribute of procedures classified as entry wrappers. + (Wrapped_Entity, Set_Wrapped_Entity): Retrieve and change the wrapped + entity of a primitive wrapper. + (Write_Entity_Flags): Output the name and value of the + Is_Primitive_Wrapper attribute. + (Write_Field27_Name): Output the name and entity of the field Wrapped_ + Entity. + (Underlying_Type): If we have an incomplete entity that comes from + the limited view then we return the Underlying_Type of its non-limited + view if it is already available. + (Abstract_Interface_Alias): Flag applies to all subrogram kinds, + including operators. + (Write_Field26_Name): Add entry for Overridden_Operation + (Overridden_Operation): New attribute of functions and procedures. + + * exp_disp.ads, exp_disp.adb (Default_Prim_Op_Position): Return a + predefined position in the dispatch table for the primitive operations + used in dispatching selects. + (Init_Predefined_Interface_Primitives): Remove the hardcoded number of + predefined primitive operations and replace it with + Default_Prim_Op_Count. + (Make_Disp_Asynchronous_Select_Spec, Make_Disp_Conditional_Select_Spec, + Make_Disp_Get_Prim_Op_Kind_Spec, Make_Disp_Timed_Select_Spec): Update + the names of the generated primitive operations used in dispatching + selects. + (Init_Predefined_Interface_Primitives): No need to inherit primitives in + case of abstract interface types. They will be inherit by the objects + implementing the interface. + (Make_DT): There is no need to inherit the dispatch table of the + ancestor interface for the elaboration of abstract interface types. + The dispatch table will be inherited by the object implementing the + interface. + (Copy_Secondary_DTs): Add documentation. + (Validate_Position): Improve this static check in case of + aliased subprograms because aliased subprograms must have + the same position. + (Init_Predefined_Interface_Primitives): New subprogram that initializes + the entries associated with predefined primitives of all the secondary + dispatch tables. + (Build_Anonymous_Access_Type): Removed. + (Expand_Interface_Actuals): With the previous cleanup there is no need + to build an anonymous access type. This allows further cleanup in the + code generated by the expander. + (Expand_Interface_Conversion): If the actual is an access type then + build an internal function to handle the displacement. If the actual + is null this function returns null because no displacement is + required; otherwise performs a type conversion that will be + expanded in the code that returns the value of the displaced actual. + (Expand_Interface_Actuals): Avoid the generation of unnecessary type + conversions that have no effect in the generated code because no + displacement is required. Code cleanup; use local variables to + avoid repeated calls to the subprogram directly_designated_type(). + + * exp_util.ads, exp_util.adb (Is_Predefined_Dispatching_Operation): + Classify the primitive operations used in dispatching selects as + predefined. + (Implements_Limited_Interface): Determine whether some type either + directly implements a limited interface or extends a type that + implements a limited interface. + (Build_Task_Image_Function): Change Subtype_Mark to Result_Definition. + (Expand_Subtype_From_Expr): Do not build actual subtype if the + expression is limited. + (Find_Interface_Tag): Add code to handle class-wide types and + entities from the limited-view. + + * rtsfind.ads: Add entries in RE_Id and RE_Unit_Table for + Get_Entry_Index, Get_Prim_Op_Kind, POK_Function, POK_Procedure, + POK_Protected_Entry, POK_Protected_Function, POK_Protected_Procedure, + POK_Task_Entry, POK_Task_Procedure, Prim_Op_Kind, Set_Entry_Index, + Set_Prim_Op_Kind. + + * sem_ch9.adb (Analyze_Triggering_Alternative): Check for legal type + of procedure name or prefix that appears as a trigger in a triggering + alternative. + + * uintp.ads: Introduce constants Uint_11 and Uint_13. + +2005-09-01 Arnaud Charlet + + * s-tataat.adb, a-tasatt.adb: + Replace calls to Defer/Undefer_Abortion by Defer/Undefer_Abort. + + * s-tasini.ads, s-tasini.adb (Defer_Abortion, Undefer_Abortion): Moved + these procedures to body, and renamed Abort_Defer, Abort_Undefer. + (Get_Exc_Stack_Addr, Set_Exc_Stack_Addr): Removed, no + longer used. + +2005-09-01 Arnaud Charlet + Jose Ruiz + + * s-taprop-vxworks.adb: + Move with clauses outside Warnings Off now that dependent units are + Preelaborate. + (Initialize): Call Interrupt_Managemeent.Initialize to ensure proper + initialization of this unit. + (Specific): Add new procedures Initialize and Delete so that this + package can be used for VxWorks 5.x and 6.x + (ATCB_Key, ATCB_Key_Address): Moved to Specific package body to hide + differences between VxWorks 5.x and 6.x + Minor reformatting. + (Timed_Delay): Remove calls to Defer/Undefer_Abort, now performed by + caller. + Use only Preelaborate-compatible constructs. + + * s-tpopsp-vxworks.adb (ATBC_Key, ATCB_Key_Addr): Moved from + Primitives.Operations. + (Delete, Initialize): New procedures. + + * s-osinte-vxworks.adb: Body used to handle differences between + VxWorks 5.x and 6.x + (kill, Set_Time_Slice, VX_FP_TASK): New functions. + + * s-osinte-vxworks.ads: Minor reformatting. + Add VxWworks 6.x specific functions (only called from VxWorks 6 files). + (VX_FP_TASK): Now a function, to handle differences between VxWorks 5 + and 6. + (Set_Time_Slice): New function, replacing kerneltimeSlice to share code + between Vxworks 5 and 6. + (taskLock, taskUnlock): Removeed, no longer used. + + * adaint.c: The wait.h header is not located in the sys directory on + VxWorks when using RTPs. + (__gnat_set_env_value): Use setenv instead of putenv on VxWorks when + using RTPs. + (__gnat_dup): dup is available on Vxworks when using RTPs. + (__gnat_dup2): dup2 is available on Vxworks when using RTPs. + + * cal.c: Use the header time.h for Vxworks 6.0 when using RTPs. + + * expect.c: The wait.h header is not located in the sys directory on + VxWorks when using RTPs. + +2005-09-01 Thomas Quinot + + * g-soccon-vms.adb: Renamed to g-soccon-vms.ads + + * g-soccon-vms.ads: Renamed from g-soccon-vms.adb + + * g-soccon.ads, g-soccon-tru64.ads, g-soccon-aix.ads, + g-soccon-darwin.ads, g-soccon-irix.ads, g-soccon-hpux.ads, + g-soccon-solaris.ads, g-soccon-mingw.ads, g-soccon-vxworks.ads, + g-soccon-freebsd.ads: Add new constants: + IP_MULTICAST_IF + SO_RCVTIMEO/SO_SNDTIMEO + IOV_MAX + + * gen-soccon.c: + Move all target-specific file inclusions and macro definitions to + gsocket.h, in order to ensure that any C code in socket.c will see a + set of constants that is consistent with the contents of g-soccon.ads. + + * gsocket.h: Code imported from gen-soccon.c: + Move all target-specific file inclusions and macro definitions to + gsocket.h, in order to ensure that any C code in socket.c will see a set + of constants that is consistent with the contents of g-soccon.ads. + This change also makes gen-soccon self-contained (removing dependencies + upon GCC internal headers). + + * g-socket.adb (Send_Vector): Make calls to Writev at most IOV_MAX + iovecs at a time. + (To_Inet_Addr): Now a procedure instead of a function, more efficient. + + * socket.c: Minor reformatting. + +2005-09-01 Ed Schonberg + Thomas Quinot + + * fname-sf.adb, mlib-tgt.ads, + back_end.adb, casing.adb, g-debpoo.adb, g-excact.adb, g-spipat.adb, + g-spipat.ads, g-thread.adb, lib-list.adb, makeutl.adb, mlib.adb, + osint.adb, par-ch10.adb, par-load.adb, prep.adb, prj.adb, prj-attr.ads, + prj-env.ads, prj-err.adb, prj-err.ads, prj-ext.adb, prj-ext.ads, + prj-makr.adb, prj-makr.ads, prj-pars.ads, prj-part.adb, prj-strt.adb, + prj-tree.ads, prj-util.ads, sem_dist.adb, sinput-c.ads, sinput-l.ads, + sinput-p.ads, styleg-c.ads, xr_tabls.adb, prj-attr-pm.ads, + makegpr.adb: Remove redundant use_clauses. + +2005-09-01 Arnaud Charlet + + * s-stoele.ads, s-stopoo.ads, s-stratt.ads, s-strops.ads, s-unstyp.ads, + s-valboo.ads, s-valcha.ads, s-valdec.ads, s-valenu.ads, s-valint.ads, + s-vallld.ads, s-vallli.ads, s-valllu.ads, s-valrea.ads, s-valuns.ads, + s-valuti.ads, s-valwch.ads, s-veboop.ads, s-vector.ads, s-vercon.ads, + s-wchcnv.ads, s-wchcon.ads, s-wchjis.ads, s-wchstw.ads, s-wchwts.ads, + s-widboo.ads, s-widcha.ads, s-widenu.ads, s-widlli.ads, s-widllu.ads, + s-widwch.ads, s-wwdcha.ads, s-wwdenu.ads, s-wwdwch.ads, system.ads, + table.ads, types.ads, system-vms_64.ads, s-crtl-vms64.ads, + s-addope.ads, system-darwin-ppc.ads, system-vxworks-x86.ads, + s-vxwork-x86.ads, system-linux-ppc.ads, i-vxwork-x86.ads, + a-numaux-darwin.ads, a-crbtgo.ads, a-crbtgk.ads, a-crbltr.ads, + a-coprnu.ads, a-convec.ads, a-contai.ads, a-coinve.ads, a-cohata.ads, + a-cohama.ads, a-cihama.ads, a-cidlli.ads, a-cdlili.ads, + a-numaux-libc-x86.ads, a-numaux-vxworks.ads, system-linux-ia64.ads, + system-freebsd-x86.ads, system-unixware.ads, system-lynxos-ppc.ads, + system-lynxos-x86.ads, system-linux-x86_64.ads, system-tru64.ads, + s-vxwork-alpha.ads, system-aix.ads, system-vxworks-sparcv9.ads, + system-solaris-x86.ads, system-irix-o32.ads, system-irix-n32.ads, + s-parame-hpux.ads, system-hpux.ads, system-vxworks-m68k.ads, + s-vxwork-m68k.ads, system-linux-x86.ads, system-vxworks-mips.ads, + s-vxwork-mips.ads, system-os2.ads, system-interix.ads, + s-vxwork-ppc.ads, system-solaris-sparc.ads, s-vxwork-sparcv9.ads, + system-solaris-sparcv9.ads, s-parame-vms.ads, system-vms.ads, + s-osinte-mingw.ads, system-mingw.ads, s-parame-vms-restrict.ads, + system-vms-zcx.ads, s-parame-ae653.ads, system-vxworks-ppc.ads, + s-parame-vxworks.ads, system-vxworks-alpha.ads, interfac-vms.ads, + a-numaux-x86.ads, a-astaco.ads, a-chahan.ads, a-charac.ads, + a-chlat1.ads, a-chlat9.ads, a-colire.adb, a-colire.ads, a-comlin.ads, + a-cwila1.ads, a-cwila9.ads, ada.ads, a-decima.ads, a-exextr.adb, + a-filico.ads, a-finali.ads, a-interr.ads, a-ioexce.ads, a-dynpri.ads, + a-ngcefu.ads, a-ngcefu.adb, a-ngcoty.adb, a-ngcoty.ads, a-ngelfu.ads, + a-nudira.adb, a-nudira.ads, a-nuflra.adb, a-numaux.ads, a-numeri.ads, + a-reatim.adb, a-stmaco.ads, a-storio.ads, a-strbou.ads, a-stream.ads, + a-strfix.ads, a-string.ads, a-strmap.ads, a-strsea.ads, a-strsup.ads, + a-strunb.ads, a-stunau.ads, a-stwibo.ads, a-stwifi.ads, a-stwima.ads, + a-stwise.ads, a-stwisu.ads, a-stwiun.ads, a-swmwco.ads, a-textio.ads, + csets.ads, debug.ads, dec.ads, g-curexc.ads, get_targ.ads, + g-except.ads, system-linux-hppa.ads, a-chacon.ads, a-widcha.ads, + a-zchara.ads, system-hpux-ia64.ads, a-ciorma.ads, a-coorma.ads, + a-ciormu.ads, a-coormu.ads, a-rbtgso.ads, a-chzla1.ads, a-chzla9.ads, + a-stzbou.ads, a-stzfix.ads, a-stzmap.ads, a-stzsea.ads, a-stzsup.ads, + a-stzunb.ads, a-swunau.ads, a-szunau.ads, gnat.ads, g-regpat.ads, + g-speche.ads, g-spitbo.ads, g-table.ads, g-tasloc.ads, g-trasym.ads, + i-c.ads, i-cpoint.ads, i-cpp.ads, i-cstrin.ads, i-fortra.ads, + interfac.ads, i-os2err.ads, i-os2lib.ads, i-os2syn.ads, i-os2thr.ads, + i-vxwork.ads, output.ads, s-arit64.ads, s-atacco.ads, s-boarop.ads, + s-casuti.ads, s-crtl.ads, s-exctab.ads, s-exnint.ads, s-exnllf.ads, + s-exnlli.ads, s-expint.ads, s-explli.ads, s-expllu.ads, s-expmod.ads, + s-expuns.ads, s-fatflt.ads, s-fatgen.ads, s-fatlfl.ads, s-fatllf.ads, + s-fatsfl.ads, s-finimp.ads, s-finroo.ads, s-fore.ads, s-geveop.ads, + s-htable.ads, s-imgbiu.ads, s-imgboo.ads, s-imgcha.ads, s-imgdec.ads, + s-imgenu.ads, s-imgint.ads, s-imgllb.ads, s-imglld.ads, s-imglli.ads, + s-imgllu.ads, s-imgllw.ads, s-imgrea.ads, s-imguns.ads, s-imgwch.ads, + s-imgwiu.ads, s-io.ads, s-maccod.ads, s-mantis.ads, s-memcop.ads, + s-pack03.ads, s-pack05.ads, s-pack06.ads, s-pack07.ads, s-pack09.ads, + s-pack10.ads, s-pack11.ads, s-pack12.ads, s-pack13.ads, s-pack14.ads, + s-pack15.ads, s-pack17.ads, s-pack18.ads, s-pack19.ads, s-pack20.ads, + s-pack21.ads, s-pack22.ads, s-pack23.ads, s-pack24.ads, s-pack25.ads, + s-pack26.ads, s-pack27.ads, s-pack28.ads, s-pack29.ads, s-pack30.ads, + s-pack31.ads, s-pack33.ads, s-pack34.ads, s-pack35.ads, s-pack36.ads, + s-pack37.ads, s-pack38.ads, s-pack39.ads, s-pack40.ads, s-pack41.ads, + s-pack42.ads, s-pack43.ads, s-pack44.ads, s-pack45.ads, s-pack46.ads, + s-pack47.ads, s-pack48.ads, s-pack49.ads, s-pack50.ads, s-pack51.ads, + s-pack52.ads, s-pack53.ads, s-pack54.ads, s-pack55.ads, s-pack56.ads, + s-pack57.ads, s-pack58.ads, s-pack59.ads, s-pack60.ads, s-pack61.ads, + s-pack62.ads, s-pack63.ads, s-parame.ads, s-pooglo.ads, s-pooloc.ads, + s-poosiz.ads, s-powtab.ads, s-purexc.ads, s-sopco3.ads, s-sopco4.ads, + s-sopco5.ads: Minor reformatting: reindent pragma Pure/Preelaborate + and always use the no parameter form for consistency. + + * gnat-style.texi: Document rules about Preelaborate/Pure pragmas. + +2005-09-01 Robert Dewar + + * binde.adb: Minor reformatting + (Find_Elab_Order): Output warning if -p used with static elab order + +2005-09-01 Robert Dewar + + * checks.adb (Check_Needed): New procedure, deals with removing checks + based on analysis of short-circuited forms. Also generates warnings for + improper use of non-short-circuited forms. + Code clean ups. + +2005-09-01 Robert Dewar + + * a-ztexio.adb, a-textio.adb, a-witeio.adb: Replace bad range checks + with 'Valid tests. + +2005-09-01 Robert Dewar + + * errout.ads, errout.adb (Fix Error_Msg_F): Fix implementation to meet + spec. + Implement new insertion char < (conditional warning) + * errutil.adb, erroutc.adb: Implement new insertion char < + (conditional warning). + * sem_elab.adb, prj-dect.adb, erroutc.ads, err_vars.ads + (Error_Msg_Warn): New variable for < insertion char. + * prj-nmsc.adb: Implement new errout insertion char < (conditional + warning). + (Check_For_Source): Change value of Source_Id only after the current + source has been dealt with. + +2005-09-01 Robert Dewar + Doug Rupp + + * exp_attr.adb: Handle vax fpt for 'Valid attribute + * exp_vfpt.ads, exp_vfpt.adb: (Expand_Vax_Valid): New procedure + * s-vaflop-vms-alpha.adb, s-vaflop.ads, s-vaflop.adb + (Valid_D, Valid_F, Valid_G): New functions + +2005-09-01 Ed Schonberg + Hristian Kirtchev + Javier Miranda + + * exp_ch6.adb (Expand_Call): If an actual is a function call rewritten + from object notation, the original node is unanalyzed and carries no + semantic information, so that accessiblity checks must be performed on + the type of the actual itself. + (Expand_N_Subprogram_Declaration): Change last actual parameter for + compatibility with Build_Protected_Sub_Specification. + (Check_Overriding_Inherited_Interfaces): Add suport to handle + overloaded primitives. + (Register_Interface_DT_Entry): Use the new name of the formal + the the calls to Expand_Interface_Thunk + + * exp_dbug.ads: Augment comments on encoding of protected types to + include the generation of dispatching subprograms when the type + implements at least one interface. + + * lib.ads: Extend information in Load_Stack to include whether a given + load comes from a Limited_With_Clause. + + * lib-load.adb (From_Limited_With_Chain): New predicate to determine + whether a potential circularity is harmless, because it includes units + loaded through a limited_with clause. Extends previous treatment which + did not handle properly arbitrary combinations of limited and + non-limited clauses. + +2005-09-01 Nicolas Setton + + * exp_dbug.adb (Get_Encoded_Name): Fixed bug that caused biaised types + to be encoded as typ___XBLU_lowerbound__upperbound instead of + typ___XB_lowerbound__upperbound. + +2005-09-01 Thomas Quinot + + * exp_dist.adb (Add_RACW_TypeCode, Add_RAS_TypeCode): Do not generate + dummy access formal for RACW/RAS TypeCode TSS. + (Build_TypeCode_Call): Do not generate dummy null access actual for + calls to the TypeCode TSS. + +2005-09-01 Ed Schonberg + + * exp_intr.adb (Expand_Source_Name): For Enclosing_Entity, generate + fully qualified name, to distinguish instances with the same local name. + + * g-souinf.ads (Enclosing_Entity): Document that entity name is now + fully qualified. + +2005-09-01 Robert Dewar + + * exp_pakd.adb (Create_Packed_Array_Type): Properly handle very large + packed arrays. + +2005-09-01 Jerome Lambourg + + * g-expect.adb (Non_Blocking_Spawn): Initialize the filters field to + (Free): New deallocation procedure for filter elements + (Close): Deallocate any existing filter for the concerned connection + +2005-09-01 Laurent Pautet + + * g-pehage.ads, g-pehage.adb (Select_Char_Position): When no character + position set is provided, we compute one in order to reduce the maximum + length of the keys. This computation first selects a character + position between 1 and the minimum length of the keys in order to + avoid reducing one of the keys to an empty string. + (Initialize, Compute): When the ratio V to K is too low, the algorithm + does not converge. The initialization procedure now comes with a + maximum number of iterations such that when exceeded, an exception is + raised in Compute. The user can initialize this ratio to another value + and try again + Reformating and updated headers. + +2005-09-01 Javier Miranda + + * itypes.ads, itypes.adb (Create_Null_Excluding_Itype): New subprogram + that given an entity T creates and returns an Itype that duplicates the + contents of T. The returned Itype has the null-exclusion + attribute set to True, and its Etype attribute references T + to keep the association between the two entities. + Update copyright notice + + * sem_aggr.adb (Check_Can_Never_Be_Null, + Aggregate_Constraint_Checks, Resolve_Aggregate, + Resolve_Array_Aggregate, Resolve_Record_Aggregate): Code cleanup. + + * sem_ch5.adb (Analyze_Assignment): Code cleanup. + +2005-09-01 Gary Dismukes + Robert Dewar + Hristian Kirtchev + + * layout.adb (SO_Ref_From_Expr): Change Subtype_Mark to + Result_Definition. + + * par-ch6.adb (P_Subprogram): Handle parsing of Access_Definitions in + function specs. + Call Set_Result_Definition instead of Set_Subtype_Mark. + (P_Subprogram_Specification): Add parsing of anonymous access result + plus null exclusions. Call Set_Result_Definition instead of + Set_Subtype_Mark. + + * par-ch3.adb: Add support for LIMITED NEW for Ada 2005 AI-419 + (P_Access_Type_Definition): Add parsing for an anonymous access result + subtype, plus parsing for null exclusions. Call Set_Result_Definition + instead of Set_Subtype_Mark. + + * sinfo.adb: Add support for LIMITED NEW for Ada 2005 AI-419 + (Null_Exclusion_Present): Allow this flag for N_Function_Specification. + (Result_Definition): New function for N_Function_Specifications. + (Subtype_Mark): No longer allowed for N_Access_Function_Definition and + N_Function_Specification. + (Set_Null_Exclusion_Present): Allow this flag for + N_Function_Specification. + (Set_Result_Definition): New procedure for N_Function_Specifications. + (Set_Subtype_Mark): No longer allowed for N_Access_Function_Definition + and N_Function_Specification. + + * sinfo.ads: Update grammar rules for 9.7.2: Entry_Call_Alternative, + Procedure_Or_Entry_Call; 9.7.4: Triggering_Statement. + Add support for LIMITED NEW for Ada 2005 AI-419 + Update the syntax of PARAMETER_AND_RESULT_PROFILE to reflect the new + syntax for anonymous access results. + Replace Subtype_Mark field by Result_Definition in + N_Function_Specification and N_Access_Definition specs. + Add Null_Exclusion_Present to spec of N_Function_Specification. + (Result_Definition): New function for N_Function_Specification and + N_Access_Function_Definition. + (Set_Result_Definition): New procedure for N_Function_Specification and + N_Access_Function_Definition. + + * sprint.adb (S_Print_Node_Actual): Change Subtype_Mark calls to + Result_Definition for cases of N_Access_Function_Definition and + N_Function_Specification. + Print "not null" if Null_Exclusion_Present on N_Function_Specification. + +2005-09-01 Vincent Celier + + * lib-writ.adb: Update Copyright notice + (Write_With_Lines): On platforms where file names are case-insensitive, + record the file names in lower case. + (Write_ALI): For D lines, on platforms where file names are + case-insensitive, record the file names in lower case. + +2005-09-01 Ed Schonberg + Emmanuel Briot + + * lib-xref.adb (Output_Overridden_Op): Display information on + overridden operation. + + * lib-xref.ads: Add documentation on overridden operations. + + * ali.ads (Xref_Entity_Record): Add support for storing the overriding + information. + + * ali.adb (Get_Typeref): New subprogram. Adds support for parsing the + overriding entity information. + +2005-09-01 Vincent Celier + + * mlib-prj.adb (Copy_Interface_Sources): Copy all interface sources, + including those that are inherited. + +2005-09-01 Robert Dewar + + * opt.ads, opt.adb: Add new switches Debug_Pragmas_Enabled[_Config] + + * par-prag.adb: Implement new pragma Debug_Policy + + * sem_prag.adb Implement new pragma Debug_Policy + (Analyze_Pragma, case Pack): do not let pragma Pack override an explicit + Component_Size attribute specification. Give warning for ignored pragma + Pack. + + * snames.h, snames.ads, snames.adb: Introduce entries in + Preset_Names for Name_Disp_Asynchronous_Select, + Name_Disp_Conditional_Select, Name_Disp_Get_Prim_Op_Kind, + Name_Disp_Timed_Select. + New pragma Debug_Policy + + * switch-c.adb (Scan_Front_End_Switches): Set Ada 2005 mode + explicitly. + Switch -gnata also sets Debug_Pragmas_Enabled + + * sem.adb, par.adb (Set_Opt_Config_Switch): Add parameter Main_Unit to + handle an explicit -gnata when compiling predefined files. + +2005-09-01 Vincent Celier + + * prj-env.adb (Set_Ada_Paths.Add.Recursive_Add): Do not add the object + directories of projects that have no Ada sources. + +2005-09-01 Robert Dewar + + * scng.adb (Check_End_Of_Line): Count characters, rather than bytes + (makes a difference for wide characters) + + * widechar.adb, widechar.ads: + Add Wide_Char_Byte_Count feature to count chars vs bytes + +2005-09-01 Thomas Quinot + Ed Schonberg + Robert Dewar + + * sem_attr.adb (Resolve_Attribute, case 'Address): For an illegal + 'Address attribute reference with an overloaded prefix, use the + location of the prefix (not the location of the attribute reference) as + the error location. + (Analyze_Attribute, case 'Size): The name of an enumeration literal, or + a function renaming thereof, is a valid prefix for 'Size (where it is + intepreted as a function call). + (Statically_Denotes_Entity): New predicate to determine whether the + prefix of an array attribute can be considered static. + + PR ada/9087 + (Eval_Attr): Fix failure to evaluate Component_Size for + unconstrained arrays (resulted in wrong value in packed case, since + back end cannot handle this case) + +2005-09-01 Robert Dewar + + * sem_cat.adb (Check_Categorization_Dependencies): Add more detail to + error msgs for most common cases. + Use new errout insertion char < (conditional warning) + +2005-09-01 Javier Miranda + Ed Schonberg + + * sem_ch10.adb (In_Chain): Moved from the scope of a subprogram to + become local to the whole package. + (Install_Limited_Withed_Unit): Instead of unchaining real entities if + the package was already analyzed the new algorithm "replaces" the + real entities by the shadow ones. This is required to ensure that + the order of these entities in the homonym chains does not change; + otherwise we can have undefined references at linking time because + in case of conflicts the external name of the entities will have + a suffix that depends on the order of the entities in the chain. + (Remove_Limited_With_Clause): Complementary code that completes the + new algorithm and replaces the shadow entities by the real ones. + (Install_Limited_Withed_Unit): When unchaining entities before the + installation of the shadow entities, only regular entities of the + public part must be taken into account. This is required to + keep this routine in synch with the work done by Remove_Limited_ + With_Clause + (Install_Limited_With_Clause): Introduce implicit limited_with_clause + even if unit is analyzed, because the analysis of the unit is + idempotent in any case, and the limited view of the unit may have to + be installed for proper visibility. + (Expand_Limited_With_Clause): Even if the unit in the implicit + with_clause has been analyzed already, a limited view of the package + must be built for the current context, if it does not exist yet. + +2005-09-01 Ed Schonberg + Javier Miranda + Gary Dismukes + + * sem_ch12.adb (Instantiate_Subprogram_Body): When creating the + defining entity for the instance body, make a new defining identifier + rather than copying the entity of the spec, to prevent accidental + sharing of the entity list. + (Check_Private_View): When exchanging views of private types, build the + list of exchanged views as a stack, to ensure that on exit the exchanges + are undone in the proper order. + (Analyze_Package_Instantiation, Analyze_Subprogram_Instantiation): + Restore the compilation environment in case of instantiation_error. + (Analyze_Generic_Subprogram_Declaration): Handle creation of type entity + for an anonymous access result. + (Instantiate_Generic_Subprogram): Subtype_Mark => Result_Definition + (Formal_Entity): Handle properly the case of a formal package that + denotes a generic package renaming. + +2005-09-01 Thomas Quinot + + * sem_ch13.adb (Analyze_Enumeration_Representation_Clause): Reject the + clause if the array aggregate is surrounded by parentheses. + +2005-09-01 Cyrille Comar + Gary Dismukes + Ed Schonberg + Javier Miranda + + * sem_ch3.ads, sem_ch3.adb (Analyze_Object_Declaration): Go to the + underlying type + to check if a type is Constrained in cases related to code generation + (rather than semantic checking) since otherwise we do not generate + similar code for mutable private types depending if their + discriminants are visible or not. + (Check_Abstract_Overriding): Do not complain about failure to override + the primitive operations used in dispatching selects since they will + always be overriden at the freeze point of the type. + (Access_Definition): Separate out handling for resetting the scope + of an anonymous access function result type. Retrieve the scope + of the associated function rather than using Current_Scope, which + does not have a consistent value (depends on whether we're in the + middle of analyzing formal parameters). Add ??? comment about + finding a cleaner way to handle the special cases of scope setting. + (Process_Incomplete_Dependents): A protected operation is never a + dispatching operation (only its wrapper may be). + (Build_Derived_Record_Type): In case of tagged private types that + implement interfaces add derivation of predefined primitive + operations. + (Derive_Subprograms): Replace the Is_Interface_Derivation parameter + by two parameters that are used in case of derivation from abstract + interface types: No_Predefined_Prims is used to avoid the derivation + of predefined primitives from the interface, and Predefined + Prims_Only is used to complete the derivation predefined primitives + in case of private tagged types implementing interfaces. + Fix typo in comments + (Find_Interface_In_Descendant): Protect the frontend against + wrong code with large circularity chains. + (Is_Private_Overriding): Add support for entities overriding interface + subprograms. The test failed because Entities associated with overriden + interface subprograms are always marked as hidden (and used to build + the secondary dispatch table); in this case the overriden entity is + available through the field abstract_interface_alias (cf. override_ + dispatching_operation) + (Access_Definition): Set the scope of the type to Current_Scope for the + case of a function with an anonymous access result type. + (Access_Subprogram_Declaration): Handle creation of the type entity for + an access-to-function type with an anonymous access result. + (Check_Anonymous_Access_Types): Change Subtype_Mark to Result_Definition + in handling for N_Access_Function_Definition. + (Analyze_Subtype_Declaration): Modify the text of error message. + (Derived_Type_Declaration): Modify the text of error message. + (Process_Subtype): Modify the text of error message plus cleanup + of one redundant error message. + (Analyze_Component_Declaration): Code cleanup. + (Analyze_Object_Declaration): Code cleanup. + (Analyze_Subtype_Declaration): Propagate the null-exclusion + attribute in case of access types. Code cleanup. + (Array_Type_Declaration): Code cleanup. + (Process_Discriminants): Create the new null-excluding itype + if required. Code cleanup. + (Process_Subtype): Create the new null-excluding itype if + required. Code cleanup. + (Build_Derived_Record_Type): Code cleanup to avoid calling + twice the subprogram derive_subprograms in case of private + types that implement interfaces. In this particular case the + subprogram Complete_Subprograms_Derivation already does the + job associated with the second call. + + * exp_strm.adb (Build_Elementary_Input_Call): Add an explicit + conversion to the full view when generating an operation for a + discriminant whose type may currently be private. + +2005-09-01 Ed Schonberg + Javier Miranda + + * sem_ch4.adb (Transform_Object_Operation): In a context off the form + V (Obj.F), the rewriting does not involve the indexed component, but + only the selected component itself. + Do not apply the transformation if the analyzed node is an actual of a + call to another subprogram. + (Complete_Object_Operation): Retain the entity of the + dispatching operation in the selector of the rewritten node. The + entity will be used in the expansion of dispatching selects. + (Analyze_One_Call): Improve location of the error message associated + with interface. + (Analyze_Selected_Component): No need to resolve prefix when it is a + function call, resolution is done when parent node is resolved, as + usual. + (Analyze_One_Call): Add a flag to suppress analysis of the first actual, + when attempting to resolve a call transformed from its object notation. + (Try_Object_Operation, Transform_Object_Operastion): Avoid makind copies + of the argument list for each interpretation of the operation. + (Try_Object_Operation): The designated type of an access parameter may + be an incomplete type obtained through a limited_with clause, in which + case the primitive operations of the type are retrieved from its full + view. + (Analyze_Call): If this is an indirect call, and the return type of the + access_to_subprogram is incomplete, use its full view if available. + +2005-09-01 Javier Miranda + Gary Dismukes + + * sem_ch6.ads, sem_ch6.adb (Check_Conformance): In case of anonymous + access types the null-exclusion and access-to-constant attributes must + also match. + (Analyze_Return_Statement): When the result type is an anonymous access + type, apply a conversion of the return expression to the access type + to ensure that appropriate accessibility checks are performed. + (Analyze_Return_Type): For the case of an anonymous access result type, + generate the Itype and set Is_Local_Anonymous_Access on the type. + Add ??? placeholder for check to disallow returning a limited object + in Ada 2005 unless it's an aggregate or a result of a function call. + Change calls from Subtype_Mark to Result_Definition. + (Analyze_Subprogram_Body): Change formal Subtype_Mark to + Result_Definition in call to Make_Function_Specification. + (Build_Body_To_Inline): Change Set_Subtype_Mark to + Set_Result_Definition. + (Make_Inequality_Operator): Change formal Subtype_Mark to + Result_Definition in call to Make_Function_Specification. + (Process_Formals): Create the new null-excluding itype if required. + (New_Overloaded_Entity): For an entity overriding an interface primitive + check if the entity also covers other abstract subprograms in the same + scope. This is required to handle the general case, that is, overriding + other interface primitives and overriding abstract subprograms inherited + from some abstract ancestor type. + (New_Overloaded_Entity): For an overriding entity that comes from + source, note the operation that it overrides. + (Check_Conformance, Type_Conformant): Addition of one new formal + to skip controlling formals in the analysis. This is used to + handle overloading of abstract interfaces. + (Base_Types_Match): Add missing case for types imported from + limited-with clauses + (New_Overloaded_Entity): Add barrier to protect the use of + the "alias" attribute. + +2005-09-01 Ed Schonberg + + * sem_ch8.adb (Analyze_Renamed_Entry): For a renaming_as_declaration, + verify that the procedure and the entry are mode conformant. + (Analyze_Subprogram_Renaming): Emit a warning if an operator is renamed + as a different operator, which is often a cut-and-paste error. + +2005-09-01 Javier Miranda + Ed Schonberg + + * sem_disp.adb (Check_Controlling_Formals): Anonymous access types + used in controlling parameters exclude null because it is necessary to + read the tag to dispatch, and null has no tag. + (Override_Dispatching_Operation): If the previous operation is inherited + from an interface, it becomes hidden and does not participate in later + name resolution. + +2005-09-01 Javier Miranda + Ed Schonberg + Gary Dismukes + + * sem_res.adb (Resolve_Membership_Op): In case of the membership test + "Iface_CW_Typ in T'Class" we have nothing else to do in the frontend; + the expander will generate the corresponding run-time check to evaluate + the expression. + (Resolve_Call): Check for legal type of procedure name or prefix that + appears as a trigger in a triggering alternative. + (Valid_Conversion): If expression is ambiguous and the context involves + an extension of System, remove System.Address interpretations. + (Resolve_Qualified_Expression): Reject the case of a specific-type + qualification applied to a class-wide argument. Enhance comment + to explain checking of Original_Node. + (Resolve_Type_Conversion): The location of the error message was not + general enough to handle the general case and hence it has been removed. + In addition, this patch improves the text of the message. + (Resolve_Type_Conversion): Add missing support for access to interface + types. + (Resolve_Type_Conversion): If the target is a class-wide interface type, + do not expand if the expression is the actual in a call, because proper + expansion will take place when the call itself is expanded. + (Resolve_Allocator): If the context is an unchecked conversion, the + allocator inherits its storage pool, if any, from the target type of + the conversion. + +2005-09-01 Ed Schonberg + Javier Miranda + + * sem_type.adb (Add_One_Interp): If a candidate operation is an + inherited interface operation that has an implementation, use the + implementation to avoid spurious ambiguities. + (Interface_Present_In_Ancestor): In case of concurrent types we can't + use the Corresponding_Record_Typ attribute to look for the interface + because it is set by the expander (and hence it is not always + available). For this reason we traverse the list of interfaces + (available in the parent of the concurrent type). + (Interface_Present_In_Ancestor): Handle entities from the limited view + +2005-09-01 Ed Schonberg + + * sem_util.ads, sem_util.adb (Gather_Components): Omit interface tags + from the list of required components. + (Is_Controlling_Limited_Procedure): Determine whether an entity is a + primitive procedure of a limited interface with a controlling first + parameter. + (Is_Renamed_Entry): Determine whether an entry is a procedure renaming + of an entry. + (Safe_To_Capture_Value): A value (such as non_null) is not safe to + capture if it is generated in the second operand of a short-circuit + operation. + Do not capture values for variables with address clauses. + (Is_Object_Reference): Treat a function call as an object reference only + if its type is not Standard_Void_Type. + +2005-09-01 Ed Schonberg + + * sem_warn.adb (Warn_On_Known_Condition): Refine warning when applied + to a variable that is statically known to be constant. + +2005-09-01 Geert Bosch + Robert Dewar + + * ttypef.ads (VAXDF_Safe_First): Use correct value for constant. + (VAXGF_Safe_First): Idem. + +2005-09-01 Robert Dewar + Arnaud Charlet + + * g-dirope.ads: Minor reformatting + Document that bounds of result of Base_Name match the input index + positions. + Add documentation on environment variable syntax for Expand_Path + + * gnat_ugn.texi: Update documentation to include mention of -m switches + Document new treatment of wide characters in max line length + style check. + Remove -gnatL/-gnatZ switches, no longer used. + Add note on pragmas Assertion_Policy and Debug_Policy in discussion + of -gnata switch. + + * gnat_rm.texi: Add doc for two argument form of pragma + Float_Representation. + Add documentation for pragma No_Strict_Aliasing + Add note that explicit component clause overrides pragma Pack. + Add documentation of pragma Debug_Policy + +2005-09-01 Matthew Heaney + + * a-cihase.adb, a-coorse.ads, a-coorse.adb, a-cohama.adb, + a-ciorse.ads, a-ciorse.adb, a-cihama.adb, a-cdlili.adb, + a-cidlli.adb, a-chtgop.adb, a-cihase.adb, a-cihase.ads, + a-cohase.adb, a-cohase.adb, a-cohase.ads: Synchronized with latest + draft (Draft 13, August 2005) of Ada Amendment 1. + +2005-09-01 Arnaud Charlet + + * Makefile.in: Adjust the libgnat target pairs for Xscale to ARM. + Note that the platform-specific version of g-soccon.ads for VMS is now + named g-soccon-vms.ads (it was previously g-soccon-vms.adb, although it + really is a package spec). + Replace s-taspri-linux.ads by s-taspri-posix.ads + Remove references to s-mastop-x86.adb + + * system-vxworks-xscale.ads: Removed, no longer used. + * s-vxwork-xscale.ads: Removed, no longer used. + +2005-09-01 Robert Dewar + + * a-dirval-mingw.adb, a-direct.adb, a-coinve.adb, + g-dynhta.adb, g-dynhta.ads, cstand.adb, exp_smem.adb, g-debuti.ads, + g-dirope.adb, g-table.adb, lib-sort.adb, sem_maps.adb, + exp_fixd.adb, exp_aggr.adb, a-intnam-mingw.ads, a-intnam-vxworks.ads, + g-arrspl.adb, g-arrspl.ads, g-awk.adb, g-awk.ads, g-boubuf.ads, + g-boubuf.ads, g-boubuf.ads, g-bubsor.ads, g-bubsor.adb, g-busora.adb, + g-busora.ads, g-busorg.adb, g-busorg.ads, g-calend.adb, g-calend.ads, + g-casuti.adb, g-casuti.ads, g-catiio.adb, g-catiio.ads, g-cgi.adb, + g-cgi.ads, g-cgicoo.adb, g-cgicoo.ads, g-cgideb.adb, g-cgideb.ads, + g-comlin.adb, g-comver.ads, g-semaph.ads, g-socthi.ads, + sem_ch7.adb, a-direio.adb, a-caldel.ads, i-cstrea-vms.adb, + a-ztedit.adb, a-ztenau.adb, g-socthi-vms.adb, g-socthi-vms.ads, + g-socthi-mingw.adb, g-socthi-mingw.ads, g-socthi-vxworks.ads, + a-intnam-irix.ads, a-intnam-irix.ads, a-intnam-hpux.ads, + a-intnam-os2.ads, a-intnam-os2.ads, a-caldel-vms.adb, a-calend-vms.adb, + a-calend-vms.ads, g-heasor.adb, g-heasor.ads, g-hesora.adb, + g-hesora.ads, g-hesorg.adb, g-hesorg.ads, g-htable.adb, g-htable.ads, + g-io.adb, g-io.ads, g-io_aux.adb, g-io_aux.ads, g-locfil.ads, + g-memdum.adb, g-memdum.ads, g-traceb.adb, g-traceb.ads, i-cobol.adb, + i-cobol.ads, i-cstrea.ads, i-cstrin.adb, a-wtedit.adb, a-tifiio.adb, + a-wtenau.adb, a-wtenau.adb, a-teioed.adb: Minor reformatting + +2005-08-29 Arnaud Charlet + + PR ada/23187 + * adaint.c + (GNAT_MAXPATH_LEN): Use default value if MAXPATHLEN is undefined. + +2005-08-29 Arnaud Charlet + Doug Rupp + + * s-stalib.adb: Add missing pragma Warnings (On) to reenable Warnings + when needed. + (Inside_Elab_Final_Code): Moved to init.c to avoid having to keep + this code in the GNAT run-time. + + * decl.c, fe.h: Replace GCC_ZCX by Back_End_Exceptions. + + PR ada/21053 + * init.c (__gnat_error_handler [many]): Mark "msg" as const + (__gnat_error_handler [HPUX]): Mark siginfo parameter as unused + + (__gnat_inside_elab_final_code): Moved here from + Standard_Library and only defined for the compiler. + __gnat_error_handler [VMS]: Adjust sigargs to account for PC & PSL. + (__gnat_inum_to_ivec): Do not define this function on VxWorks when + using RTPs because directly vectored Interrupt routines are not + supported on this configuration. + (getpid): Do not redefine this function on VxWorks when using RTPs + because this primitive is well supported by the RTP libraries. + (copy_msg): Correct the code that checks for buffer overflow. + Discovered during code reading. + +2005-08-29 Olivier Hainque + + * decl.c (gnat_to_gnu_entity) : When allocating storage for + a library level mutable variable with an initializer, tell + build_allocator to ignore the initializer's size. It may not be large + enough for all the values that might be assigned to the variable later + on. + +2005-08-29 Arnaud Charlet + Eric Botcazou + + * trans.c: Protect < in error msg with quote + Replace GCC_ZCX by Back_End_Exceptions. + (addressable_p) : Also return 1 if the field + has been sufficiently aligned in the record. + +2005-08-15 James E. Wilson + + * system-linux-alpha.ads: Change ia64 to alpha. + +2005-08-01 Kazu Hirata + + * decl.c, utils.c: Fix comment typos. + +2005-07-29 Kazu Hirata + + * decl.c, init.c, initialize.c: Fix comment typos. + +2005-07-20 Giovanni Bajo + + Make CONSTRUCTOR use VEC to store initializers. + * decl.c (gnat_to_gnu_entity): Update to cope with VEC in + CONSTRUCTOR_ELTS. + * trans.c (extract_values): Likewise. + * utils.c (convert, remove_conversions): Likewise. + * utils2.c (contains_save_expr_p, build_binary_op, build_unary_op, + gnat_build_constructor): Likewise. + +2005-07-09 Andrew Pinski + + * decl.c (components_to_record): Use DECL_FCONTEXT instead of + DECL_SECTION_NAME. + (compare_field_bitpos): Likewise. + +2005-07-09 Andrew Pinski + + * utils.c (create_var_decl): Only set DECL_COMMON on + VAR_DECLs. Only set SET_DECL_ASSEMBLER_NAME on + VAR_OR_FUNCTION_DECL_P. + +2005-07-08 Daniel Berlin + + * utils.c (create_param_decl): DECL_ARG_TYPE_AS_WRITTEN is + removed. + +2005-07-07 Pascal Obry + + * g-socthi-mingw.adb (C_Inet_Addr): New body used to convert the + returned type on Windows. + + * g-socthi-mingw.ads (C_Inet_Addr): Remove pragma Import for this + routine. + + * g-socket.adb (Inet_Addr): Check for empty Image and raises an + exception in this case. + Simplify the code as "Image (Image'Range)" = "Image". + +2005-07-07 Vincent Celier + + * bindgen.adb (Gen_Output_File_C): When switch -a was specified, put + the destructor/constructor attributes for final/init. + + * gnatbind.adb (Gnatbind): Allow -a to be used in conjunction with -C + +2005-07-07 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : Do not strip the padding + type if the parameter is not passed by copy but reference by default. + +2005-07-07 Javier Miranda + + * exp_ch3.adb (Build_Record_Init_Proc/Freeze_Record_Type): + Reimplementation of the support for abstract interface types in order + to leave the code more clear and easy to maintain. + + * exp_ch6.adb (Freeze_Subprogram): Reimplementation of the support for + abstract interface types in order to leave the code clearer and easier + to maintain. + + * exp_disp.ads, exp_disp.adb (Fill_DT_Entry): Part of its functionality + is now implemented by the new subprogram Fill_Secondary_DT_Entry. + (Fill_Secondary_DT_Entry): Generate the code necessary to fill the + appropriate entry of the secondary dispatch table. + (Make_DT): Add code to inherit the secondary dispatch tables of + the ancestors. + + * exp_util.adb (Find_Interface_Tag/Find_Interface_ADT): Instead of + implementing both functionalities by means of a common routine, each + routine has its own code. + +2005-07-07 Javier Miranda + + * freeze.adb (Freeze_Entity): Check wrong uses of tag incomplete types. + + * par-ch3.adb (P_Type_Declaration): Give support to tagged incomplete + types: + -- + type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [IS TAGGED]; + -- + + * sem_attr.adb (Check_Not_Incomplete_Type): Additional checks for wrong + use of tag incomplete types. + + * sem_ch3.adb (Analyze_Incomplete_Type): Add mininum decoration to + give support to tagged incomplete types. + + * sem_ch5.adb (Analyze_Case_Statement): In generated code, if the + expression is a discriminant reference and its type is private, as can + happen within a stream operation for a mutable record, use the full + view of the type to resolve the case alternatives. + (Analyze_Assignment): Check wrong dereference of incomplete types. + + * sem_ch6.adb (Process_Formals): Allow the use of tagged incomplete + types. + + * sem_res.adb (Resolve_Explicit_Dereference): Allow the use of tagged + incomplete types. + + * sinfo.adb (Taggged_Present/Set_Taggged_Present): Applicable to + N_Incomplete_Type_Declaration nodes. + + * sinfo.ads (N_Incomplete_Type_Declaration): Addition of attribute + Tag_Present to give support to tagged incomplete types: + -- + type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [IS TAGGED]; + -- + +2005-07-07 Olivier Hainque + + PR ada/22301 + * raise.c: Only include unwind.h if IN_RTS, and provide dummy type + definitions for the Unwind wrappers in the compiler case. + +2005-07-07 Ed Schonberg + Javier Miranda + + * par-load.adb (Load): If a child unit is loaded through a limited_with + clause, each parent must be loaded as a limited unit as well. + + * sem_ch10.adb (Previous_Withed_Unit): Better name for + Check_Withed_Unit. Return true if there is a previous with_clause for + this unit, whether limited or not. + (Expand_Limited_With_Clause): Do not generate a limited_with_clause on + the current unit. + (Is_Visible_Through_Renamings): New local subprogram of install_limited + _withed_unit that checks if some package installed through normal with + clauses has a renaming declaration of package whose limited-view is + ready to be installed. This enforces the check of the rule 10.1.2 (21/2) + of the current Draft document for Ada 2005. + (Analyze_Context): Complete the list of compilation units that + are allowed to contain limited-with clauses. It also contains + checks that were previously done by Install_Limited_Context_Clauses. + This makes the code more clear and easy to maintain. + (Expand_Limited_With_Clause) It is now a local subprogram of + Install_Limited_Context_Clauses, and contains the code that adds + the implicit limited-with clauses for parents of child units. + This functionality was prevously done by Analyze_Context. + + * sem_ch4.adb (Analyze_Selected_Component): Check wrong use of + incomplete type. + + * sem_ch7.adb (Analyze_Package_Declaration): Check if the package has + been erroneously named in a limited-with clause of its own context. + In this case the error has been previously notified by Analyze_Context. + +2005-07-07 Ed Schonberg + + * sem_ch8.adb (Find_Direct_Name): Handle properly the case of a + generic package that contains local declarations with the same name. + (Analyze_Object_Renaming): Check wrong renaming of incomplete type. + +2005-07-07 Bernard Banner + + * tracebak.c: Refine tracebacks to use Unwind_Backtrace scheme on + ia64 platform only on platforms that you the GCC unwind library + rather than the system unwind library. + +2005-07-07 Thomas Quinot + + * expect.c: Minor reformatting + +2005-07-07 Sergey Rybin + + * vms_data.ads: Add VMS qualifiers for new gnatpp switch + --no-separate-is + + * gnat_ugn.texi: Add description for new gnatpp option + (--no-separate-is) + +2005-07-04 Thomas Quinot + + * g-expect-vms.adb, g-expect.ads, g-expect.adb + (Get_Command_Output): New subprogram to launch a process and get its + standard output as a string. + +2005-07-04 Eric Botcazou + Olivier Hainque + + * s-mastop-tru64.adb (Pop_Frame): Use exc_lookup_function_entry to + fetch a code-range descriptor associated with the machine state. On + failure set the machine state's PC to 0; on success, pass the + descriptor to exc_virtual_unwind. + + * init.c (Tru64 section): New function __gnat_set_code_loc. + +2005-07-04 Vincent Celier + + * mlib-tgt-tru64.adb, mlib-tgt-aix.adb, mlib-tgt-irix.adb, + mlib-tgt-hpux.adb, mlib-tgt-linux.adb, mlib-tgt-solaris.adb, + mlib-tgt-mingw.adb, mlib-tgt-darwin.adb (Build_Dynamic_Library): + Remove all auto-initialization code, as this is now done through the + constructor mechanism. + + * adaint.h, adaint.c (__gnat_binder_supports_auto_init, + __gnat_sals_init_using_constructors): New functions. + + * bindgen.adb (Gen_Output_File_Ada): Generate pragmas + Linker_Constructor and Linker_Destructor when switch -a is used. + + * bindusg.adb: Add line for new switch -a + + * gnatbind.adb (Gnatbind_Supports_Auto_Init): New Boolean function + (Gnatbind): When switch -a is used, check if it is allowed + + * switch-b.adb (Scan_Binder_Switches): Process new switch -a + +2005-07-04 Joel Brobecker + + * a-tags.adb (Type_Specific_Data): Define Tags_Table as a small array. + This prevents us from hitting a limitation during the debug info + generation when using stabs. + (Prims_Ptr): Likewise. + +2005-07-04 Gary Dismukes + Ed Schonberg + Javier Miranda + + * checks.adb (Null_Exclusion_Static_Checks): In the case of + N_Object_Declaration, only perform the checks if the Object_Definition + is not an Access_Definition. + + * sem_ch3.adb (Access_Subprogram_Declaration): Add test for the case + where the parent of an the access definition is an N_Object_Declaration + when determining the Associated_Node_For_Itype and scope of an + anonymous access-to-subprogram type. + + * exp_ch6.adb (Expand_N_Subprogram_Declaration): Set the + Corresponding_Spec on the body created for a null procedure. Add ??? + comment. Remove New_Copy_Tree call on body argument to + Set_Body_To_Inline. + + * exp_ch6.adb (Add_Simple_Call_By_Copy_Code): For an out parameter with + discriminants, use the type of the actual as well, because the + discriminants may be read by the called subprogram. + + * sem_ch3.adb (Access_Type_Declaration): If the designated type is an + access type we do not need to handle non-limited views. + (Build_Derived_Record_Type): Additional check to check that in case of + private types, interfaces are only allowed in private extensions. + +2005-07-04 Eric Botcazou + + * decl.c (prepend_attributes) : New case. + : Likewise. + + * einfo.ads (Has_Gigi_Rep_Item): Document Pragma_Linker_Constructor and + Pragma_Linker_Destructor. + + * gigi.h (attr_type): Add ATTR_LINK_CONSTRUCTOR and + ATTR_LINK_DESTRUCTOR. + (static_ctors, static_dtors): New variables. + + * misc.c (gnat_expand_body): Output current function as constructor + and destructor if requested. + + * par-prag.adb: Add processing for pragma Linker_Constructor and + Linker_Destructor. + + * sem_prag.adb (Find_Unique_Parameterless_Procedure): New function + extracted from Check_Interrupt_Or_Attach_Handler. + (Check_Interrupt_Or_Attach_Handler): Invoke it. + Implement pragma Linker_Constructor and Linker_Destructor with the + help of Find_Unique_Parameterless_Procedure. + Replace Name_Alias with Name_Target for pragma Linker_Alias. + + * snames.h, snames.ads, snames.adb: + Add Name_Linker_Constructor and Name_Linker_Destructor. + Add Pragma_Linker_Constructor and Pragma_Linker_Destructor. + * snames.adb: Remove Name_Alias. + + * trans.c: Include cgraph.h. + (build_global_cdtor): New function. + (Compilation_Unit_to_gnu): Build global constructor and destructor if + needed. + (tree_transform) : Substitute renaming of view-conversions + of objects too. + (addressable_p) : Unconditionally test + DECL_NONADDRESSABLE_P on STRICT_ALIGNMENT platforms. + + * utils.c (process_attributes) : Do not assemble the + variable if it is external. + + (static_ctors, static_dtors): New global variables. + (process_attributes) : New case. + : Likewise. + (end_subprog_body): Chain function as constructor and destructor + if requested. + + * exp_util.adb (Force_Evaluation): Unconditionally invoke + Remove_Side_Effects with Variable_Ref set to true. + (Remove_Side_Effects): Handle scalar types first. Use a renaming + for non-scalar types even if Variable_Ref is true and for class-wide + expressions. + +2005-07-04 Ed Schonberg + + * exp_attr.adb (Mod): Evaluate condition expression with checks off, + to prevent spurious warnings. + +2005-07-04 Thomas Quinot + + * exp_dist.adb (Build_TypeCode_Call): Remove incorrect processing for + Itypes. Itypes are really unexpected there. + (Build_TypeCode_Function): Generalise special processing for Itypes to + handle the case of numeric implicit base types as well as enumerated + ones. + +2005-07-04 Ed Schonberg + + * exp_intr.adb (Expand_Unc_Deallocation): If the designated type is + controlled, indicate the expected type of the dereference that is + created for the call to Deep_Finalize, to prevent spurious errors when + the designated type is private and completed with a derivation from + another private type. + +2005-07-04 Vincent Celier + + * make.adb (Change_To_Object_Directory): When unable to change the + current dir to the object directory, output the full path of the + directory. + +2005-07-04 Matthew Gingell + + * Makefile.in: Replace indepsw-linux.adb by indepsw-gnu.adb + + * indepsw-linux.adb: Replace by... + + * indepsw-gnu.adb: ...this new file + +2005-07-04 Vincent Celier + + * mlib-prj.adb (Auto_Initialize): New constant String + (SALs_Use_Constructors): New Boolean function + (Build_Library): Call gnatbind with Auto_Initialize switch when + SALs_Use_Constructors returns True. + + * mlib-tgt.ads: Minor reformatting + + * mlib-utl.ads: Minor reformatting + + * opt.ads: (Use_Pragma_Linker_Constructor): New Boolean flag + +2005-07-04 Ed Schonberg + + * par-ch9.adb (P_Task, P_Protected): Indicate that single task and + single protected declarations can have an interface list. + (P_Entry_Declaration): Add handler for Error_Resync, which can be raised + with seriously malformed entry declarations, and lead to compilation + abandoned messages. + +2005-07-04 Javier Miranda + + * par-load.adb: Load the context items in two rounds. + +2005-07-04 Robert Dewar + + * scng.adb: Do not consider Mod used as an attribute to be a keyword + +2005-07-04 Ed Schonberg + Javier Miranda + + * sem_ch10.adb (Build_Limited_Views): A type declared with a private + type extension needs a limited view. + Remove previous restriction on private types available through the + limited-view (only tagged private types were previously allowed). + (Install_Withed_Unit): In the code that implements the + legality rule given in AI-377, exclude a child unit with the name + Standard, because it is a homonym of the Standard environment package. + +2005-07-04 Thomas Quinot + + * sem_ch4.adb (Transform_Object_Operation): For an actual that is an + overloaded function call, carry interpretations from the original tree + to the copy. + +2005-07-04 Ed Schonberg + + * sem_ch6.adb (Conforming_Types): If the types are anonymous access + types check whether some designated type is a limited view, and use + the non-limited view if available. + +2005-07-04 Gary Dismukes + + * sem_eval.adb (Subtypes_Statically_Match): Use the discriminant + constraint of full view of a private view T1 if present, when T2 is a + discriminated full view. + +2005-07-04 Thomas Quinot + + * sem_res.adb (Resolve_Actuals): Do not resolve the expression of an + actual that is a view conversion of a bit packed array reference. + +2005-07-04 Ed Schonberg + + * sem_type.adb (Covers): Verify that Corresponding_Record_Type is + present before checking whether an interface type covers a synchronized + type. + +2005-07-04 Ed Schonberg + + * sem_util.adb (Is_Object_Reference): An indexed or selected component + whose prefix is an implicit dereference is an object reference. Removes + spurious errors when compiling with -gnatc. + +2005-07-04 Robert Dewar + + PR ada/22039 + * s-sopco3.ads, s-sopco4.ads, s-sopco5.ads: Minor documentation fix + +2005-07-04 Matthew Gingell + + * tracebak.c: Enable tracebacks on ia64 platforms + +2005-07-04 Vincent Celier + + * vms_conv.adb (Initialize): Allow multiple ALI files to be given to + the GNAT BIND command, as gnatbind accepts multiples ALI files with + the -L or -n switches. + +2005-07-04 Vincent Celier + + * makegpr.adb (Build_Global_Archive): Make sure the list of sources is + correctly computed and the main project data is not modified while + doing so. + (Add_C_Plus_Plus_Link_For_Gnatmake): Always link with the C++ compiler + (Choose_C_Plus_Plus_Link_Process): Do not generate shell script + c++linker as this does not work on some platforms. + +2005-07-04 Matthew Heaney + + * a-convec.ads, a-coinve.ads: Declaration of subtype Extended_Index + was changed. + * a-coinve.adb: Perform constraint checks explicitly. + +2005-07-04 Richard Kenner + Thomas Quinot + + * Make-lang.in: (ada/targtyps.o): Add missing TREE_H dependency. + new target gen-soccon. + +2005-07-04 Robert Dewar + + * s-mastop-irix.adb, s-mastop-vms.adb: Minor reformatting + +2005-07-04 Thomas Quinot + + * g-socket.ads (Check_Selector): Minor rewording of comment. + +2005-07-04 Vincent Celier + + * vms_data.ads: Add VMS qualifiers for new gnatpp switch --eol= + +2005-07-04 Thomas Quinot + + * gen-soccon.c: Add constants SO_SNDTIMEO and SO_RCVTIMEO. + +2005-07-04 Sergey Rybin + + * gnat_ugn.texi: Add description of --eol gnatpp option + +2005-07-04 Eric Botcazou + Thomas Quinot + + * gnat_rm.texi: Add a note that pragma Unreferenced is not appropriate + if the user wants all calls of a subprogram to be flagged, + independently of whether they are made from within the same unit or + another unit. + Mention restriction for pragma Linker_Alias on some platforms. + Document pragma Linker_Constructor and Linker_Destructor. + Rewrite documentation of Weak_External, Linker_Section and + Linker_Alias pragmas. + +2005-07-04 Arnaud Charlet + + * s-stausa.ads, s-stausa.adb: New files. + +2005-06-30 Kelley Cook + + * all files: Update FSF address in copyright headers. + * gen-soccon.co (main): Output new FSF address in generated files. + +2005-06-28 Paul Brook + + * misc.c (gnat_init_gcc_eh): Call default_init_unwind_resume_libfunc. + +2005-06-14 Olivier Hainque + Eric Botcazou + + * s-mastop-irix.adb (Pop_Frame): Revert shorcuts avoiding calls to + exc_unwind, now that we are generating proper .debug_frame output for + that target. + + * tracebak.c: Remove the mips-irix section, as we are now using the + s-mastop based unwinder again. + Under SPARC/Solaris, take into account the stack bias to compute the + frame offset. The stack bias is 0 for the V8 ABI and 2047 for the V9 + ABI. + +2005-06-14 Doug Rupp + + * g-trasym-vms.adb: renamed g-trasym-vms-alpha.adb + + * g-trasym-vms-alpha.adb, g-trasym-vms-ia64.adb: New files + +2005-06-14 Pascal Obry + + * a-strhas.ads, a-secain.adb, a-secain.ads, a-rbtgso.ads, a-cgaaso.adb, + a-cgaaso.ads, a-cgarso.adb, a-cgcaso.adb, a-cgarso.ads, a-cgcaso.ads, + a-contai.ads, a-coprnu.ads, a-coprnu.adb: Fix header style (spaces in + package name). + + * a-intnam-lynxos.ads, a-intnam-unixware.ads, a-intnam-tru64.ads, + a-intnam-aix.ads, a-intnam-irix.ads, a-excpol-interix.adb, + a-intnam-hpux.ads, a-intnam-linux.ads, a-intnam-dummy.ads, + a-intnam-os2.ads, a-numaux-libc-x86.ads, a-intnam-interix.ads, + a-intnam-solaris.ads, a-caldel-vms.adb, a-calend-vms.ads, + a-intnam-vms.ads, a-excpol-abort.adb, a-intnam-mingw.ads, + a-intnam-vxworks.ads, a-numaux-vxworks.ads, s-osinte-unixware.adb, + s-osinte-unixware.ads, s-osinte-lynxos-3.adb, s-osinte-lynxos-3.ads, + s-osinte-hpux.ads, s-osinte-solaris-posix.ads, a-intnam-freebsd.ads, + s-osinte-freebsd.adb, s-osinte-freebsd.ads, s-osinte-lynxos.adb, + s-osinte-lynxos.ads, s-tpopsp-lynxos.adb, s-osinte-tru64.adb, + s-osinte-tru64.ads, s-tpopsp-posix-foreign.adb, s-vxwork-alpha.ads, + s-osinte-aix.adb, s-osinte-aix.ads, s-osinte-aix-fsu.ads, + s-osinte-irix.adb, s-osinte-irix.ads, s-interr-sigaction.adb, + s-osinte-irix-athread.ads, s-osinte-hpux-dce.adb, + s-osinte-hpux-dce.ads, s-osinte-posix.adb, s-osinte-linux.ads, + s-vxwork-m68k.ads, s-osinte-linux-fsu.ads, s-vxwork-mips.ads, + s-osinte-dummy.ads, s-interr-dummy.adb, s-osinte-os2.adb, + s-osinte-os2.ads, s-osprim-os2.adb, s-osinte-interix.ads, + s-osprim-unix.adb, s-vxwork-ppc.ads, s-osinte-solaris.adb, + s-osinte-solaris.ads, s-osprim-solaris.adb, s-tpopsp-solaris.adb, + s-vxwork-sparcv9.ads, s-osinte-solaris-fsu.ads, s-interr-vms.adb, + s-osinte-vms.adb, s-osinte-vms.ads, s-osprim-vms.adb, + s-osprim-vms.ads, s-tpopde-vms.adb, s-tpopde-vms.ads, + s-osprim-mingw.adb, s-vxwork-xscale.ads, s-interr-vxworks.adb, + s-osinte-vxworks.adb, s-osinte-vxworks.ads, s-osprim-vxworks.adb, + s-tfsetr-vxworks.adb, s-tpopsp-vxworks.adb, s-intman-posix.adb, + s-osinte-fsu.adb, s-osprim-posix.adb, s-tfsetr-default.adb, + s-tpopsp-posix.adb, s-traces-default.adb, s-trafor-default.adb, + s-trafor-default.ads, s-tratas-default.adb, a-numaux-x86.adb, + a-numaux-x86.ads, a-astaco.adb, a-astaco.ads, a-caldel.adb, + a-caldel.ads, a-charac.ads, a-chlat1.ads, a-chlat9.ads, a-colien.adb, + a-colien.ads, a-colire.adb, a-colire.ads, a-comlin.adb, a-cwila1.ads, + a-cwila9.ads, ada.ads, a-decima.adb, a-diocst.ads, a-direio.adb, + a-dynpri.adb, a-dynpri.ads, a-excpol.adb, a-flteio.ads, a-fwteio.ads, + a-inteio.ads, a-interr.adb, a-intnam.ads, a-intsig.adb, a-intsig.ads, + a-ioexce.ads, a-iwteio.ads, a-lfteio.ads, a-lfwtio.ads, a-liteio.ads, + a-liwtio.ads, a-llftio.ads, a-llfwti.ads, a-llitio.ads, a-lliwti.ads, + a-ncelfu.ads, a-ngcefu.adb, a-ngcefu.ads, a-ngcoty.adb, a-ngelfu.adb, + a-ngelfu.ads, a-nlcefu.ads, a-nlcoty.ads, a-nlelfu.ads, a-nllcef.ads, + a-nllcty.ads, a-nllefu.ads, a-nscefu.ads, a-nscoty.ads, a-nselfu.ads, + a-nucoty.ads, a-nudira.adb, a-nuelfu.ads, a-nuflra.adb, a-numaux.ads, + a-numeri.ads, a-reatim.adb, a-retide.adb, a-retide.ads, a-sequio.adb, + a-sequio.ads, a-sfteio.ads, a-sfwtio.ads, a-siocst.ads, a-siteio.ads, + a-siwtio.ads, a-ssicst.ads, a-ssitio.ads, a-ssiwti.ads, a-stmaco.ads, + a-storio.adb, a-strbou.adb, a-strfix.adb, a-string.ads, a-strmap.adb, + a-strsea.adb, a-strsup.adb, a-strunb.ads, a-ststio.adb, a-stunau.adb, + a-stunau.ads, a-stwibo.adb, a-stwifi.adb, a-stwifi.ads, a-stwima.adb, + a-stwise.adb, a-stwisu.adb, a-suteio.adb, a-suteio.ads, a-swuwti.adb, + a-swuwti.ads, a-teioed.adb, a-ticoau.adb, a-ticoau.ads, a-ticoio.adb, + a-tideau.adb, a-tideio.adb, a-tienau.adb, a-tienio.adb, a-tifiio.adb, + a-tiflio.adb, a-tigeau.adb, a-tigeau.ads, a-tiinio.adb, a-timoau.adb, + a-timoio.adb, a-timoio.ads, a-tiocst.ads, a-titest.adb, a-titest.ads, + a-witeio.adb, a-wtcoau.adb, a-wtcoau.ads, a-wtcoio.adb, a-wtcoio.ads, + a-wtcstr.ads, a-wtdeau.adb, a-wtdeio.adb, a-wtenau.adb, a-wtenio.adb, + a-wtfiio.adb, a-wtflio.adb, a-wtgeau.adb, a-wtinau.adb, a-wtinio.adb, + a-wtinio.ads, a-wtmoau.adb, a-wtmoio.adb, a-wttest.adb, calendar.ads, + dec.ads, dec-io.adb, dec-io.ads, directio.ads, errno.c, g-bubsor.adb, + g-bubsor.ads, g-busora.adb, g-busora.ads, g-busorg.adb, g-busorg.ads, + g-casuti.adb, g-casuti.ads, g-debuti.ads, g-heasor.adb, g-heasor.ads, + g-hesora.adb, g-hesora.ads, g-hesorg.adb, g-hesorg.ads, g-htable.adb, + g-htable.ads, g-io.adb, g-io.ads, g-io_aux.adb, g-io_aux.ads, + g-memdum.adb, g-memdum.ads, g-sestin.ads, g-signal.ads, g-signal.adb, + gnat.ads, g-souinf.ads, g-speche.adb, g-speche.ads, g-table.adb, + g-table.ads, g-thread.adb, g-thread.ads, ioexcept.ads, i-vxwoio.adb, + i-vxwoio.ads, math_lib.adb, s-assert.adb, s-assert.ads, s-asthan.ads, + s-bitops.adb, s-bitops.ads, s-boarop.ads, s-carsi8.adb, s-carsi8.ads, + s-carun8.adb, s-carun8.ads, s-casi16.adb, s-casi16.ads, s-casi32.adb, + s-casi32.ads, s-casi64.adb, s-casi64.ads, s-casuti.adb, s-casuti.ads, + s-caun16.adb, s-caun16.ads, s-caun32.adb, s-caun32.ads, s-caun64.adb, + s-caun64.ads, s-direio.adb, s-direio.ads, sequenio.ads, s-errrep.adb, + s-errrep.ads, s-exnint.adb, s-exnint.ads, s-exnllf.adb, s-exnllf.ads, + s-exnlli.adb, s-exnlli.ads, s-expint.adb, s-expint.ads, s-explli.adb, + s-explli.ads, s-expllu.adb, s-expllu.ads, s-expmod.adb, s-expmod.ads, + s-expuns.adb, s-expuns.ads, s-fore.adb, s-fore.ads, s-geveop.adb, + s-geveop.ads, s-htable.adb, s-htable.ads, s-imgbiu.adb, s-imgbiu.ads, + s-imgboo.adb, s-imgboo.ads, s-imgcha.adb, s-imgcha.ads, s-imgdec.adb, + s-imgdec.ads, s-imgenu.adb, s-imgenu.ads, s-imgint.adb, s-imgint.ads, + s-imgllb.adb, s-imgllb.ads, s-imglld.adb, s-imglld.ads, s-imglli.adb, + s-imglli.ads, s-imgllu.adb, s-imgllu.ads, s-imgllw.adb, s-imgllw.ads, + s-imgrea.ads, s-imguns.adb, s-imguns.ads, s-imgwiu.adb, s-imgwiu.ads + s-interr.ads, s-io.adb, s-mantis.adb, s-mantis.ads, s-osprim.ads, + s-pack03.adb, s-pack03.ads, s-pack05.adb, s-pack05.ads, s-pack06.adb, + s-pack06.ads, s-pack07.adb, s-pack07.ads, s-pack09.adb, s-pack09.ads, + s-pack10.adb, s-pack10.ads, s-pack11.adb, s-pack11.ads, s-pack12.adb, + s-pack12.ads, s-pack13.adb, s-pack13.ads, s-pack14.adb, s-pack14.ads, + s-pack15.adb, s-pack15.ads, s-pack17.adb, s-pack17.ads, s-pack18.adb, + s-pack18.ads, s-pack19.adb, s-pack19.ads, s-pack20.adb, s-pack20.ads, + s-pack21.adb, s-pack21.ads, s-pack22.adb, s-pack22.ads, s-pack23.adb, + s-pack23.ads, s-pack24.adb, s-pack24.ads, s-pack25.adb, s-pack25.ads, + s-pack26.adb, s-pack26.ads, s-pack27.adb, s-pack27.ads, s-pack28.adb, + s-pack28.ads, s-pack29.adb, s-pack29.ads, s-pack30.adb, s-pack30.ads, + s-pack31.adb, s-pack31.ads, s-pack33.adb, s-pack33.ads, s-pack34.adb, + s-pack34.ads, s-pack35.adb, s-pack35.ads, s-pack36.adb, s-pack36.ads, + s-pack37.adb, s-pack37.ads, s-pack38.adb, s-pack38.ads, s-pack39.adb, + s-pack39.ads, s-pack40.adb, s-pack40.ads, s-pack41.adb, s-pack41.ads, + s-pack42.adb, s-pack42.ads, s-pack43.adb, s-pack43.ads, s-pack44.adb, + s-pack44.ads, s-pack45.adb, s-pack45.ads, s-pack46.adb, s-pack46.ads, + s-pack47.adb, s-pack47.ads, s-pack48.adb, s-pack48.ads, s-pack49.adb, + s-pack49.ads, s-pack50.adb, s-pack50.ads, s-pack51.adb, s-pack51.ads, + s-pack52.adb, s-pack52.ads, s-pack53.adb, s-pack53.ads, s-pack54.adb, + s-pack54.ads, s-pack55.adb, s-pack55.ads, s-pack56.adb, s-pack56.ads, + s-pack57.adb, s-pack57.ads, s-pack58.adb, s-pack58.ads, s-pack59.adb, + s-pack59.ads, s-pack60.adb, s-pack60.ads, s-pack61.adb, s-pack61.ads, + s-pack62.adb, s-pack62.ads, s-pack63.adb, s-pack63.ads, s-scaval.adb, + s-scaval.ads, s-sequio.adb, s-sequio.ads, s-stache.adb, s-stache.ads, + s-stratt.adb, s-stratt.ads, s-strcom.adb, s-strcom.ads, s-strops.adb, + s-strops.ads, s-taasde.ads, s-tadeca.adb, s-tadeca.ads, s-tadert.adb, + s-tadert.ads, s-taenca.adb, s-taenca.ads, s-taprob.adb, s-taprob.ads, + s-tarest.adb, s-tarest.ads, s-tasdeb.adb, s-tasdeb.ads, s-tasini.adb, + s-tasini.ads, s-taskin.adb, s-taskin.ads, s-tasque.adb, s-tasque.ads, + s-tasren.ads, s-tasres.ads, s-tassta.adb, s-tassta.ads, s-tasuti.adb, + s-tasuti.ads, s-tataat.adb, s-tataat.ads, s-tpinop.adb, s-tpinop.ads, + s-tpoben.adb, s-tpoben.ads, s-tpobop.ads, s-tporft.adb, s-tposen.ads, + s-traces.adb, s-traces.ads, s-tratas.adb, s-tratas.ads, s-valint.ads, + s-unstyp.ads, s-veboop.adb, s-veboop.ads, s-vector.ads, s-vercon.adb, + s-vercon.ads, s-wchcnv.adb, s-wchcnv.ads, s-wchjis.adb, s-wchjis.ads, + s-wchstw.adb, s-wchstw.ads, s-wchwts.adb, s-wchwts.ads, s-widboo.adb, + s-widboo.ads, s-widcha.adb, s-widcha.ads, s-widenu.adb, s-widenu.ads, + s-widlli.adb, s-widlli.ads, s-widllu.adb, s-widllu.ads, s-wwdcha.ads, + s-wwdenu.adb, s-wwdwch.ads, text_io.ads, s-stchop.ads, s-stchop.adb, + s-stchop-vxworks.adb, a-intnam-darwin.ads, s-osinte-darwin.adb, + s-osinte-darwin.ads, s-vxwork-x86.ads, a-numaux-darwin.ads, + a-numaux-darwin.adb, a-chzla1.ads, a-chzla9.ads, a-lfztio.ads, + a-liztio.ads, a-llfzti.ads, a-llizti.ads, a-sfztio.ads, a-siztio.ads, + a-ssizti.ads, a-stzbou.adb, a-stzfix.adb, a-stzfix.ads, a-stzmap.adb, + a-stzsea.adb, a-stzsup.adb, a-swunau.adb, a-swunau.ads, a-szuzti.adb, + a-szuzti.ads, a-tiunio.ads, a-wwunio.ads, a-ztcoau.adb, a-ztcoau.ads, + a-ztcoio.adb, a-ztcoio.ads, a-ztcstr.ads, a-ztdeau.adb, a-ztdeio.adb, + a-ztenio.adb, a-ztexio.adb, a-ztfiio.adb, a-ztflio.adb, a-ztgeau.adb, + a-ztinau.adb, a-ztinio.adb, a-ztinio.ads, a-ztmoau.adb, a-ztmoio.adb, + a-zttest.adb, a-zzunio.ads, g-utf_32.adb: Fix header style. + "GNU Ada" to GNAT, use proper casing for RUN-TIME. + +2005-06-14 Jose Ruiz + Arnaud Charlet + + * a-sytaco.ads, a-sytaco.adb (Suspension_Object): These objects are no + longer protected objects. They have been replaced by lower-level + suspension objects made up by a mutex and a condition variable (or + their equivalent given a particular OS) plus some internal data to + reflect the state of the suspension object. + (Initialize, Finalize): Add this initialization procedure for + Suspension_Object, which is a controlled type. + (Finalize): Add the finalization procedure for Suspension_Object, + which is a controlled type. + + * a-sytaco-vxworks.ads, a-sytaco-vxworks.adb: Remove this version of + Ada.Synchronous_Task_Control because there is no longer a need for a + VxWorks specific version of this package. Target dependencies + has been moved to System.Task_Primitives.Operations. + + * s-osinte-mingw.ads (pCRITICAL_SECTION): Remove this type which is no + longer needed. + (InitializeCriticalSection, EnterCriticalSection, + LeaveCriticalSection, DeleteCriticalSection): Replace the type + pCriticalSection by an anonymous access type so that we avoid problems + of accessibility to local objects. + + * s-taprop.ads, s-taprop-posix.adb, s-taprop-vxworks.adb, + s-taprop-mingw.adb, s-taprop-vms.adb, s-taprop-solaris.adb, + s-taprop-os2.adb, s-taprop-dummy.adb, s-taprop-hpux-dce.adb, + s-taprop-linux.adb, s-taprop-irix.adb, s-taprop-irix-athread.adb, + s-taprop-tru64.adb, s-taprop-lynxos.adb (Elaboration Code): No longer + set the environment task mask here. + (Current_State): Add this function that returns the state of the + suspension object. + (Set_False): Add this procedure that sets the state of the suspension + object to False. + (Set_True): Add this procedure that sets the state of the suspension + object to True, releasing the task that was suspended, if any. + (Suspend_Until_True): Add this procedure that blocks the calling task + until the state of the object is True. Program_Error is raised if + another task is already waiting on that suspension object. + (Initialize): Add this procedure for initializing the suspension + object. It initializes the mutex and the condition variable which are + used for synchronization and queuing, and it sets the internal state + to False. + (Finalize): Add this procedure for finalizing the suspension object, + destroying the mutex and the condition variable. + + * s-taspri-posix.ads, s-taspri-vxworks.ads, s-taspri-mingw.ads, + s-taspri-vms.ads, s-taspri-solaris.ads, s-taspri-os2.ads, + s-taspri-dummy.ads, s-taspri-hpux-dce.ads, s-taspri-linux.ads, + s-taspri-tru64.ads, s-taspri-lynxos.ads (Suspension_Object): New object + which provides a low-level abstraction (using operating system + primitives) for Ada.Synchronous_Task_Control. + This object is made up by a mutex (for ensuring mutual exclusion), a + condition variable (for queuing threads until the condition is + signaled), a Boolean (State) indicating whether the object is open, + and a Boolean (Waiting) reflecting whether there is a task already + suspended on this object. + + * s-intman.ads, s-intman-irix.adb, s-intman-irix-athread.adb, + s-intman-dummy.adb, s-intman-solaris.adb, s-intman-vms.adb, + s-intman-vms.ads, s-intman-mingw.adb, + (Initialize_Interrupts): Removed, no longer used. + + * s-inmaop-posix.adb, s-inmaop-vms.adb, s-inmaop-dummy.adb, + (Setup_Interrupt_Mask): New procedure. + + * s-intman-vxworks.ads, s-intman-vxworks.adb: Update comments. + + * s-inmaop.ads (Setup_Interrupt_Mask): New procedure + + * s-interr.adb: Add explicit call to Setup_Interrupt_Mask now that + this is no longer done in the body of s-taprop + (Server_Task): Explicitely test for Pending_Action in case + System.Parameters.No_Abort is True. + + * s-taasde.adb: Add explicit call to Setup_Interrupt_Mask now that this + is no longer done in the body of s-taprop + +2005-06-14 Robert Dewar + + * system-unixware.ads, system-linux-ia64.ads, system-freebsd-x86.ads, + system-lynxos-ppc.ads, system-lynxos-x86.ads, system-linux-x86_64.ads, + system-tru64.ads, system-aix.ads, system-vxworks-sparcv9.ads, + system-vxworks-xscale.ads, system-solaris-x86.ads, system-irix-o32.ads, + system-irix-n32.ads, system-hpux.ads, system-vxworks-m68k.ads, + system-linux-x86.ads, system-vxworks-mips.ads, system-vxworks-mips.ads, + system-os2.ads, system-interix.ads, system-solaris-sparc.ads, + system-solaris-sparcv9.ads, system-vms.ads, system-mingw.ads, + system-vms-zcx.ads, system-vxworks-ppc.ads, system.ads, + system-darwin-ppc.ads, system-vxworks-x86.ads, system-linux-ppc.ads, + system-linux-hppa.ads, system-vms_64.ads, + system-vxworks-alpha.ads: Minor comment update for + AI-362 (unit is Pure). + + * a-chahan.ads, a-chahan.adb: Move Wide_Wide functions to Conversions + Add pragma Pure_05 for AI-362 + Make remaining conversion functions obsolescent in Ada 95 + + * impunit.adb: Change a-swunha to a-swuwha and a-szunha to a-szuzha + Make Ada.Wide_Characters[.Unicode] available in Ada 95 mode + Add entries for a-wichun and a-zchuni + Add a-widcha a-zchara for AI-395 + Add a-chacon (Ada.Characters.Conversions) to list of Ada 2005 routines + + * Makefile.rtl: Change a-swunha to a-swuwha and a-szunha to a-szuzha + Add entries for a-wichun.o and a-zchuni.o + Entries for a-widcha.o and a-zchara.o + Add entry for a-chacon.o + + * a-ztenau.adb: Add with of Ada.Characters.Conversions + + * a-chacon.ads, a-chacon.adb: New files. + + * a-taside.adb, a-exstat.adb, a-excach.adb: Add warnings off to allow + categorization violations. + + * a-strmap.ads: Add pragma Pure_05 for AI-362 + * a-strmap.ads: Add note on implicit categorization for AI-362 + + * a-tgdico.ads, a-taside.ads: Add pragma Preelaborate_05 for AI-362 + + * par-prag.adb: Dummy entry for pragma Persistent_BSS + Set Ada_Version_Explicit, for implementation of AI-362 + Add processing for pragma Pure_05 and Preelaborate_05 + Add entry for Assertion_Policy pragma + + * sem.adb: Make sure predefined units are compiled with GNAT_Mode true + when needed for proper processing of categorization stuff + + * sem_cat.adb: + For several cases, make errors in preealborate units warnings, + instead of errors, if GNAT_Mode is set. For AI-362. + + * sem_elab.adb (Check_Elab_Call): Call to non-static subprogram in + preelaborate unit is now warning if in GNAT mode + + * s-stoele.ads: Document AI-362 for pragma preelaborate + +2005-06-14 Doug Rupp + + * s-parame-vms.ads, s-parame-hpux.ads, s-parame-vms-restrict.ads, + s-parame-ae653.ads, s-parame.ads, s-parame-vxworks.ads: + Default_Exception_Msg_Max_Length: new parameter. + + * a-except.ads: (Exception_Msg_Max_Length): Set to + System.Parameters.Default_Exception_Msg_Max_Length + Add pragma Preelaborate_05 for AI-362 + Add warnings off to allow categorization violations for AI-362 + +2005-06-14 Vincent Celier + + * gnatsym.adb: Adapt to modification of package Symbols: procedure + Process is now in package Processing. + + * symbols.ads, symbols.adb: + (Processing): New package, containing procedure Process + + * symbols-vms-alpha.adb: + Replaced by symbols-vms.adb and symbols-processing-vms-alpha.adb + + * symbols-vms.adb, symbols-processing-vms-alpha.adb, + symbols-processing-vms-ia64.adb: New files. + +2005-06-14 Pascal Obry + + * mlib-tgt-mingw.adb (Build_Dynamic_Library): Replace the previous + implementation. This new version generates the proper DllMain routine + to initialize the SAL. The DllMain is generated in Ada and compiled + before being added as option to the library build command. + +2005-06-14 Doug Rupp + Pascal Obry + + * adaint.c (__gnat_to_canonical_file_spec): Check for error returns in + call to decc$translate_vms. + (__gnat_locate_regular_file): Check if the path_val contains quotes. We + need to remove those quotes before catenating the filename. + (__gnat_locate_exec_on_path): improvements to the Win32 section: + * avoid allocating the memory twice for better efficiency; + * allocate 32K buffer for environment expansion as suggested by MSDN; + * prepend ".;" to the path so that current directory is searched too. + +2005-06-14 Robert Dewar + + * a-except.adb (Exception_Identity): return Null_Id for null occurrence + instead of raising CE (AI-241) + Add warnings off to allow categorization violations for AI-362 + +2005-06-14 Robert Dewar + + * ali-util.adb, gnatbind.adb: Remove references to + Force_RM_Elaboration_Order. + + * switch-b.adb: Remove recognition of -f switch + +2005-06-14 Pascal Obry + + * a-stzunb.adb, a-stwiun.adb, a-strunb.adb (Realloc_For_Chunk): New + implementation which is slightly more efficient. + +2005-06-14 Gary Dismukes + Javier Miranda + Ed Schonberg + Hristian Kirtchev + + * exp_ch4.adb (Expand_Allocator_Expression): When an initialized + allocator's designated type is a class-wide type, and compiling for + Ada 2005, emit a run-time check that the accessibility level of the + type given in the allocator's expression is not deeper than the level + of the allocator's access type. + + (Tagged_Membership): Modified to gives support to abstract interface + types. + + * a-tags.ads, a-tags.adb (type Type_Specific_Data): Add component + Access_Level. + (Descendant_Tag): New predefined function + (Is_Descendant_At_Same_Level): New predefined function + (Get_Access_Level): New private function + (Set_Access_Level): New private procedure + (IW_Membership): New function. Given the tag of an object and the tag + associated with an interface, evaluate if the object implements the + interface. + (Register_Interface_Tag): New procedure used to initialize the table of + interfaces used by the IW_Membership function. + (Set_Offset_To_Top): Initialize the Offset_To_Top field in the prologue + of the dispatch table. + (Inherit_TSD): Modified to copy the table of ancestor tags plus the + table of interfaces of the parent. + (Expanded_Name): Raise Tag_Error if the passed tag equals No_Tag. + (External_Tag): Raise Tag_Error if the passed tag equals No_Tag. + (Parent_Tag): Return No_Tag in the case of a root-level tagged type, + and raise Tag_Error if the passed tag equalis No_Tag, to conform with + Ada 2005 semantics for the new predefined function. + + * exp_attr.adb (Expand_N_Attribute, case Attribute_Input): Generate + call to Descendant_Tag rather than Internal_Tag. + (Expand_N_Attribute, case Attribute_Output): Emit a check to ensure that + the accessibility level of the attribute's Item parameter is not deeper + than the level of the attribute's prefix type. Tag_Error is raised if + the check fails. The check is only emitted for Ada_05. + (Find_Stream_Subprogram): If a TSS exists on the type itself for the + requested stream attribute, use it. + (Expand_N_Attribute_Reference): If the designated type is an interface + then rewrite the referenced object as a conversion to force the + displacement of the pointer to the secondary dispatch table. + (Expand_N_Attribute_Reference, case 'Constrained): Return false if this + is a dereference of an object with a constrained partial view. + + * exp_ch5.adb (Expand_N_Return_Statement): When a function's result + type is a class-wide type, emit a run-time check that the accessibility + level of the returned object is not deeper than the level of the + function's master (only when compiling for Ada 2005). + + * exp_disp.ads, exp_disp.adb (Ada_Actions, Action_Is_Proc, + Action_Nb_Arg): Add entries for new Get_Access_Level and + Set_Access_Level routines in these tables. + (Make_DT): Generate a call to set the accessibility level of the + tagged type in its TSD. + (Make_DT): Code cleanup. The functionality of generating all the + secondary dispatch tables has been moved to freeze_record_type. + (Make_Abstract_Interface_DT): Minor code cleanup. + (Set_All_DT_Position): Code cleanup. As part of the code cleanup + this subprogram implements a new algorithm that provides the + same functionality and it is more clear in case of primitives + associated with abstract interfaces. + (Set_All_Interfaces_DTC_Entity): Removed. As part of the code + clean up, the functionality of this subprogram is now provided + by Set_All_DT_Position. + (Write_DT): New subprogram: a debugging procedure designed to be called + within gdb to display the dispatch tables associated with a tagged + type. + (Collect_All_Interfaces): New subprogram that collects the whole list + of interfaces that are directly or indirectly implemented by a tagged + type. + (Default_Prim_Op_Position): New subprogram that returns the fixed + position in the dispatch table of the default primitive operations. + (Expand_Interface_Actuals): New subprogram to generate code that + displaces all the actuals corresponding to class-wide interfaces to + reference the interface tag of the actual object. + (Expand_Interface_Conversion): New subprogram. Reference the base of + the object to give access to the interface tag associated with the + secondary dispatch table. + (Expand_Interface_Thunk): New subprogram that generates the code of the + thunk. This is required for compatibility with the C+ ABI. + (Make_Abstract_Interface_DT): New subprogram that generate the + declarations for the secondary dispatch tables associated with an + abstract interface. + (Set_All_Interfaces_DTC_Entity): New subprogram that sets the DTC_Entity + attribute for each primitive operation covering interface subprograms + (Expand_Dispatching_Call, Fill_DT_Entry, Make_DT, Set_All_DT_Position): + These subprograms were upgraded to give support to abstract interfaces + + * rtsfind.ads (type RE_Id): Add RE_Descendant_Tag, + RE_Is_Descendant_At_Same_Level, RE_Get_Access_Level, and + RE_Set_Access_Level. + (RE_Unit_Table): Add entries for new Ada.Tags operations. + Add support to call the followig new run-time subprograms: + IW_Membership, Register_Interface_Tag, and Set_Offset_To_Top + + * sem_ch3.adb (Constant_Redeclaration): Allow a deferred constant to + match its full declaration when both have an access definition with + statically matching designated subtypes. + (Analyze_Component_Declaration): Delete commented out code that was + incorrectly setting the scope of an anonymous access component's type. + (Process_Discriminants): Set Is_Local_Anonymous_Access for the type of + an access discriminant when the containing type is nonlimited. + (Make_Incomplete_Type_Declaration): Create an incomplete type + declaration for a record type that includes self-referential access + components. + (Check_Anonymous_Access_Types): Before full analysis of a record type + declaration, create anonymous access types for each self-referential + access component. + (Analyze_Component_Declaration, Array_Type_Declaration): Indicate that + an access component in this context is a Local_Anonymous_Access, for + proper accessibility checks. + (Access_Definition): Set properly the scope of the anonymous access type + created for a stand-alone access object. + (Find_Type_Of_Object): An object declaration may be given with an access + definition. + (Complete_Subprograms_Derivation): New subprogram used to complete + type derivation of private tagged types implementing interfaces. + In this case some interface primitives may have been overriden + with the partial-view and, instead of re-calculating them, they + are included in the list of primitive operations of the full-view. + (Build_Derived_Record_Type): Modified to give support to private + types implemening interfaces. + (Access_Definition): Reject ALL on anonymous access types. + (Build_Derived_Record_Type): In the case of Ada 2005, allow a tagged + type derivation to occur at a deeper accessibility level than the + parent type. + For the case of derivation within a generic body however, disallow the + derivation if the derived type has an ancestor that is a formal type + declared in the formal part of an enclosing generic. + (Analyze_Object_Declaration): For protected objects, remove the check + that they cannot contain interrupt handlers if not declared at library + level. + (Add_Interface_Tag_Components): New subprogram to add the tag components + corresponding to all the abstract interface types implemented by a + record type or a derived record type. + (Analyze_Private_Extension_Declaration, Build_Derived_Record_Type, + Derived_Type_Declaration, Find_Type_Name, Inherit_Components, + Process_Full_View, Record_Type_Declaration): Modified to give + support to abstract interface types + (Collect_Interfaces): New subprogram that collects the list of + interfaces that are not already implemented by the ancestors + (Process_Full_View): Set flag Has_Partial_Constrained_View appropriately + when partial view has no discriminants and full view has defaults. + (Constrain_Access): Reject a constraint on a general access type + if the discriminants of the designated type have defaults. + (Access_Subprogram_Declaration): Associate the Itype node with the inner + full-type declaration or subprogram spec. This is required to handle + nested anonymous declarations. + (Analyze_Private_Extension_Declaration, Build_Derived_Record_Type, + Derived_Type_Declaration, Find_Type_Name, Inherit_Components, + Process_Full_View, Record_Type_Declaration): Modified to give + support to abstract interface types + (Derive_Subprograms): Addition of a new formal to indicate if + we are in the case of an abstact-interface derivation + (Find_Type_Of_Subtype_Indic): Moved from the body of the package + to the specification because it is requied to analyze all the + identifiers found in a list of interfaces + + * debug.adb: Complete documentation of flag "-gnatdZ" + + * exp_ch3.adb: Implement config version of persistent_bss pragma + (Check_Stream_Attributes): Use Stream_Attribute_Available instead of + testing for TSS presence to properly enforce visibility rules. + (Freeze_Record_Type): Code cleanup. Modified to call the subprogram + Make_Abstract_Interfaces_DT to generate the secondary tables + associated with abstract interfaces. + (Build_Init_Procedure): Modified to initialize all the tags + corresponding. + (Component_Needs_Simple_Initialization): Similar to other tags, + interface tags do not need initialization. + (Freeze_Record_Type): Modified to give support to abstract interface + types. + (Expand_N_Object_Declaration): Do not generate an initialization for + a scalar temporary marked as internal. + + * exp_ch6.adb (Add_Simple_Call_By_Copy_Code): Handle properly an + in-out parameter that is a component in an initialization procedure, + whose constraint might depend on discriminants, and that may be + misaligned because of packing or representation clauses. + (Is_Legal_Copy): New predicate to determine whether a possibly + misaligned in-out actual can actually be passed by copy/return. This + is an error in case the type is by_reference, and a warning if this is + the consequence of a DEC import pragma on the subprogram. + (Expand_Call, Freeze_Subprogram): Modified to give support to abstract + interface types + (Expand_Inlined_Call): Mark temporary generated for the return value as + internal, so that no useless scalar normalization is generated for it. + (Expand_N_Subprogram_Declaration): Save unanalyzed body so calls to + null procedure can always be inlined. + (Expand_N_Subprogram_Declaration): If this is the declaration of a null + procedure, generate an explicit empty body for it. + + * exp_util.ads, exp_util.adb (Find_Interface_ADT): New subprogram. + Given a type implementing an interface, returns the corresponding + access_disp_table value. + (Find_Interface_Tag): New subprogram. Given a type implementing an + interface, returns the record component containing the tag of the + interface. + (Find_Interface_Tag): New overloaded subprogram. Subsidiary to the + previous ones that return the corresponding tag and access_disp_table + entities. + (Is_Predefined_Dispatching_Operation): Determines if a subprogram + is a predefined primitive operation. + (Expand_Subtype_From_Expr): If the expression is a selected component + within an initialization procedure, compute its actual subtype, because + the component may depend on the discriminants of the enclosing record. + + * i-cpp.ads, i-cpp.adb: + This package has been left available for compatibility with previous + versions of the frontend. As part of the new layout this is now a + dummy package that uses declarations available at a-tags.ads + + * par-ch3.adb (P_Identifier_Declarations): Give an error for use of + "constant access" and "aliased [constant] access" when not compiling + with -gnat05. + Suppress Ada 2005 keyword warning if -gnatwY used + (P_Identifier_Declarations): Add support for object declarations with + access definitions. + (Private_Extension_Declaration): Complete the documentation + (P_Derived_Type_Def_Or_Private_Ext_Decl): Fill the inteface_list + attribute in case of private extension declaration + (P_Type_Declaration): Mark as "abstract" the type declarations + corresponding with protected, synchronized and task interfaces + (P_Declarative_Items): "not" and "overriding" are overriding indicators + for a subprogram or instance declaration. + + * sem_ch12.adb (Analyze_Subprogram_Instantiation): Verify that an + instantiation that is a dispatching operation has controlling access + parameters that are null excluding. + Save and restore Ada_Version_Explicit, for implementation of AI-362 + (Validate_Derived_Type_Instance): Add check for abstract interface + types. + (Analyze_Formal_Package): Establish Instantiation source for the copy of + the generic that is created to represent the formal package. + (Analyze_Package_Instantiation): Instantiate body immediately if the + package is a predefined unit that contains inlined subprograms, and + we are compiling for a Configurable_Run_Time. + (Instantiate_Formal_Subprogram): Indicate that null default subprogram + If the program has a null default, generate an empty body for it. + + * sem_ch6.adb, sem_ch9.adb (Analyze_Subprograms_Declaration): Update + error message condition, null procedures are correctly detected now. + (New_Overloaded_Entity): Bypass trivial overriding indicator check + for subprograms in the context of protected types. Instead, the + indicator is examined in Sem_Ch9 while analysing the subprogram + declaration. + (Check_Overriding_Indicator): Check consistency of overriding indicator + on subprogram stubs as well. + (Analyze_Subprogram_Declaration): Diagnose null procedures declared at + the library level. + (Analize_Subprogram_Specification): When analyzing a subprogram in which + the type of the first formal is a concurrent type, replace this type + by the corresponding record type. + (Analyze_Subprogram_Body): Undo the previous work. + (Analyze_Procedure_Call): If the call has the form Object.Op, the + analysis of the prefix ends up analyzing the call itself, after which + we are done. + (Has_Interface_Formals): New subprogram subsidiary to analyze + subprogram_specification that returns true if some non + class-wide interface subprogram is found + (New_Overloaded_Entity): Modified to give support to abstract + interface types + (Conforming_Types): In Ada 2005 mode, conformance checking of anonymous + access to subprograms must be recursive. + (Is_Unchecked_Conversion): Improve the test that recognizes + instantiations of Unchecked_Conversion, and allows them in bodies that + are to be inlined by the front-end. When the body comes from an + instantiation, a reference to Unchecked_Conversion will be an + Expanded_Name, even though the body has not been analyzed yet. + Replace Is_Overriding and Not_Overriding in subprogram_indication with + Must_Override and Must_Not_Override, to better express intent of AI. + (Analyze_Subprogram_Body): If an overriding indicator is given, check + that it is consistent with the overrinding status of the subprogram + at this point. + (Analyze_Subprogram_Declaration): Indicate that a null procedure is + always inlined. + If the subprogram is a null procedure, indicate that it does not need + a completion. + + * sem_disp.adb (Check_Controlling_Type): Give support to entities + available through limited-with clauses. + (Check_Dispatching_Operation): A stub acts like a body, and therefore is + allowed as the last primitive of a tagged type if it has no previous + spec. + (Override_Dispatching_Operation, Check_Dispatching_Operation): Modified + to give support to abstract interface types + + * sem_res.adb (Valid_Conversion): Perform an accessibility level check + in the case where the target type is an anonymous access type of an + object or component (that is, when Is_Local_Anonymous_Access is true). + Prevent the special checks for conversions of access discriminants in + the case where the discriminant belongs to a nonlimited type, since + such discriminants have their accessibility level defined in the same + way as a normal component of an anonymous access type. + (Resolve_Allocator): When an allocator's designated type is a class-wide + type, check that the accessibility level of type given in the + allocator's expression or subtype indication is not statically deeper + than the level of the allocator's access type. + (Check_Discriminant_Use): Diagnose discriminant given by an expanded + name in a discriminant constraint of a record component. + (Resolve_Explicit_Dereference): Do not check whether the type is + incomplete when the dereference is a use of an access discriminant in + an initialization procedure. + (Resolve_Type_Conversion): Handle conversions to abstract interface + types. + (Valid_Tagged_Conversion): The conversion of a tagged type to an + abstract interface type is always valid. + (Valid_Conversion): Modified to give support to abstract interface types + (Resolve_Actuals): Enable full error reporting on view conversions + between unrelated by_reference array types. + The rule for view conversions of arrays with aliased components is + weakened in Ada 2005. + Call to obsolescent subprogram is now considered to be a violation of + pragma Restrictions (No_Obsolescent_Features). + (Check_Direct_Boolean_Operator): If the boolean operation has been + constant-folded, there is nothing to check. + (Resolve_Comparison_Op, Resolve_Equality_Op, Resolve_Boolean_Op): Defer + check on possible violation of restriction No_Direct_Boolean_Operators + until after expansion of operands, to prevent spurious errors when + operation is constant-folded. + + * sem_type.ads, sem_type.adb (Covers, Intersect_Types, Specific_Type, + Has_Compatible_Type): Modified to give support to abstract interface + types. + (Interface_Present_In_Ancestor): New function to theck if some ancestor + of a given type implements a given interface + + * sem_ch4.adb (Analyze_Call): Handle properly an indirect call whose + prefix is a parameterless function that returns an access_to_procedure. + (Transform_Object_Operation): Handle properly function calls of the + form Obj.Op (X), which prior to analysis appear as indexed components. + (Analyze_One_Call): Complete the error notification to help new Ada + 2005 users. + (Analyze_Allocator): For an allocator without an initial value, where + the designated type has a constrained partial view, a discriminant + constraint is illegal. + +2005-06-14 Robert Dewar + + * a-textio.adb (Set_Col): Fix two errors noticed recently, having to + do with treatment of Set_Col when positioned at end of line character. + +2005-06-14 Robert Dewar + + * atree.adb: (Elist*): Protect against uninitialized field + +2005-06-14 Ed Schonberg + + * checks.adb (Install_Null_Excluding_Check): Do not generate checks + for an attribute reference that returns an access type. + (Apply_Discriminant_Check): No need for check if (designated) type has + constrained partial view. + + (Apply_Float_Conversion_Check): Generate a short-circuit expression for + both bound checks, rather than a conjunction. + (Insert_Valid_Check): If the expression is an actual that is an indexed + component of a bit-packed array, force expansion of the packed element + reference, because it is specifically inhibited elsewhere. + +2005-06-14 Vincent Celier + + * clean.adb (Clean_Project): Correctly delete executable specified as + absolute path names. + + * make.adb (Gnatmake): Allow relative executable path names with + directory information even when project files are used. + (Change_To_Object_Directory): Fail gracefully when unable to change + current working directory to object directory of a project. + (Gnatmake): Remove exception handler that could no longer be exercized + (Compile_Sources.Compile): Use deep copies of arguments, as some of them + may be deallocated by Normalize_Arguments. + (Collect_Arguments): Eliminate empty arguments + + * gnatcmd.adb (All_Projects): New Boolean flag, initialized to False, + and set to True when -U is used for GNAT PRETTY or GNAT METRIC. + (Check_Project): Return False when Project is No_Project. Return True + when All_Projects is True. + (GNATCmd): Recognize switch -U for GNAT PRETTY and GNAT METRIC and set + All_Projects to True. + Minor reformatting + +2005-06-14 Ed Schonberg + Javier Miranda + Thomas Quinot + Robert Dewar + Hristian Kirtchev + Gary Dismukes + + * einfo.ads, einfo.adb (Is_Local_Anonymous_Access): New flag on + anonymous access types, to indicate that the accessibility level of + the type is determined by that of the enclosing declaration. + (Has_Persistent_BSS): New flag + (Set_Is_Primitive_Wrapper): Upgrade the barrier to allow the usage + of this attribute with functions. + (Is_Primitive_Wrapper): Remove the barrier. + (Has_Specified_Stream_Input, Has_Specified_Stream_Output, + Has_Specified_Stream_Read, Has_Specified_Stream_Write): + New subprograms. + (Set_Has_Specified_Stream_Input, Set_Has_Specified_Stream_Output, + Set_Has_Specified_Stream_Read, Set_Has_Specified_Stream_Write): + New subprograms. + (Is_Pure_Unit_Access_Type): New flag + (Abstract_Interfaces): Complete the assertion to cover all usages. + (Set_Is_Interface): Complete the assertion to cover all usages. + (Is_Primitive_Wrapper): New attribute. + (Is_Obsolescent): Now applies to all entities (though it is only set + for subprograms currently) + New flag: Has_Constrained_Partial_View, to implemente Ada 2005 AI-363, + which solves various problems concerning access subtypes. + (Has_Persistent_BSS): New flag + (Is_Primitive_Wrapper, Set_Primitive_Wrapper): Code cleanup. + Remove these subprograms because this attribute is currently + not used. + New entity flags: + Has_Specified_Stream_Input (Flag190) + Has_Specified_Stream_Output (Flag191) + Has_Specified_Stream_Read (Flag192) + Has_Specified_Stream_Write (Flag193) + Present in all type and subtype entities. Set for a given view if the + corresponding stream-oriented attribute has been defined by an + attribute definition clause. When such a clause occurs, a TSS is set + on the underlying full view; the flags are used to track visibility of + the attribute definition clause for partial or incomplete views. + (Is_Pure_Unit_Access_Type): New flag + Clarify use of Is_Internal. + (Is_Primitive_Wrapper): New attribute present in primitive subprograms + internally generated to wrap the invocation of tasks and protected + types that implement interfaces. + (Implementation_Base_Type): Documentation correction + (Is_Obsolescent): Now applies to all entities (though it is only set + for subprograms currently) + New flag: Has_Constrained_Partial_View, to implement Ada 2005 AI-363, + which solves various problems concerning access subtypes. + + * exp_ch9.adb (Type_Conformant_Parameters): Introduce mode conformance + for examined parameters. Identify unequal parameter list lengths as + non-conformant parameters. + (Overriding_Possible): Do not check for "All" qualifier in declaration + of controlling access parameter, following prescription of AI-404. + (Build_Entry_Wrapper_Spec, Build_Entry_Wrapper_Body): New subprograms + that build the procedure body that wraps an entry invocation + (Build_Corresponding_Record, Build_Protected_Sub_Specification, + Expand_N_Protected_Body, Expand_N_Protected_Type_Declaration, + Expand_N_Task_Body, Expand_N_Task_Type_Declaration): Modified to + give support to abstract interface types + + * freeze.adb (Freeze_Entity): Issue error message if + Is_Pure_Unit_Access_Type set, unless we are in Ada 2005 mode and the + type has no storage pool (Ada 2005) AI-366. + Also modified to give support to abstract interface types + (Freeze_Subprogram): Issue an error for a dispatching subprogram with an + Inline_Always pragma. + + * par-ch9.adb (P_Task_Items): Reserved words "not" or "overriding" may + now begin an entry declaration. + (P_Entry_Or_Subprogram_With_Indicator): New procedure in + P_Protected_Operation_Declaration_Opt. Parse an entry declaration or + a subprogram declaration preceded by an overriding indicator. + (P_Protected_Operation_Declaration_Opt): Add case for parsing entry + declarations or subprogram declarations preceded by reserved words + "not" or "overriding". + (P_Entry_Declaration): Update comment. Parse and check overriding + indicator, set semantic flags of entry declarations. + (P_Task): New error message in case of private applied + to a task type declaration. + (P_Protected): New error message in case of private applied + to a task type declaration. + + * sem_ch7.adb (Preserve_Full_Attributes): Modified to handle the case + in which the full view of a type implementing an interface is a + concurrent type. + (Has_Overriding_Pragma): Remove obsolete implementation of AI-218. + Declare_Inherited_Private_Subprograms): If an explicit operation + overrides an operation that is inherited in the private part, mark the + explicit one as overriding, to enable overriding indicator checks. + (Preserve_Full_Attributes): Propagate Is_Unchecked_Union attribute from + full view to partial view, to simplify handling in back-end. + + * sprint.adb: Print interface lists where needed: derived types, + protected types, task types. + output "is null" for null procedures. Part of implementation of + + * sem_cat.adb (Validate_Access_Type_Declaration): Implement AI-366 + relaxation of rules for access types in pure, shared passive partitions. + + * exp_strm.adb (Build_Mutable_Record_Read_Procedure): Reorganize to + first read discriminants into temporary objects, performing checks on + the read values, then possibly performing discriminant checks on the + actual (if it is constrained), and only finally reading the components + into a constrained temporary object. + (Build_Elementary_Input_Call): Adjust the specific circuitry for the + case of reading discriminants of a mutable record type to recognize + the new form of the code generated by + Build_Mutable_Record_Read_Procedure. + + * exp_tss.ads, exp_tss.adb (Make_Init_Proc_Name): Reimplement in terms + of a simple call to Make_TSS_Name. + (Make_TSS_Name_Local): Add the TSS name as the last thing in the name + buffer, in order for Is_TSS to work correctly on local TSS names. + + * sem_attr.ads, sem_attr.adb (Resolve_Attribute, case 'Access): Use flag + Is_Local_Anonymous_Access to check legaliy of attributes in the + context of access components and stand-alone access objects. + (Stream_Attribute_Available): In Ada 95 mode, a stream attribute is + treated as available for a limited private type if there is an + attribute_definition_clause that applies to its full view, but not in + other cases where the attribute is available for the full view + (specifically, the sole fact that the full view is non-limited does not + make the attribute available for the partial view). + (Build_Access_Subprogram_Type): Diagnose attempt to apply 'access to a + non-overloaded intrinsic subprogram. + (Check_Stream_Attribute): Reject an attribute reference for an + unavailable stream attribute even if the prefix is not a limited type + (case of a 'Input attribute reference for an abstract, non-classwide + type) + (Stream_Attribute_Available): New function to determine whether a stream + attribute is available at a place. + (Check_Attribute): Use Stream_Attribute_Available instead of just + testing for TSS presence on the implementation base type. + (Analyze_Attribute): Modified to give support to task interfaces. + (Analyze_Access_Attribute): Add error check for use of an Access (or + Unrestricted_Access) attribute with a subprogram marked as + Inline_Always. + (Analyze_Attribute, case Attribute_Address): Add error check for use of + an Address attribute with a subprogram marked as Inline_Always. + Update Eval_Attribute to handle new value of Width from AI-395 + + * sem_ch13.adb (Analyze_Stream_TSS_Definition): New subprogram. + (Analyze_Attribute_Definition_Clause, cases Input, Output, Read, Write): + Factor common code across the stream-oriented attribute circcuits into + a new subprogram, Analyze_Stream_TSS_Definition. The new uniform + processing is functionally identical to the previous duplicated one, + except that an expression that denotes an abstract subprogram will now + be rejected, as mandated by AI-195 item 5. + + * sem_util.ads, sem_util.adb (Type_Access_Level): Use flag + Is_Local_Anonymous_Access to apply accessibility checks to access + components and stand-alone access objects. + (Has_Discriminant_Dependent_Constraint): Moved to spec for use + elsewhere. + (Is_Potentially_Persistent_Type): New function + (Is_Dependent_Component_Of_Mutable_Object): If the enclosing object is + a heap-object whose type has a constrained partial view, the object is + unconstrained and the component may depend on a discriminant, making its + renaming illegal. + + * sinfo.ads, sinfo.adb + (Must_Not_Override): Flag applicable to N_Entry_Declaration. + (Must_Override): Flag applicable to N_Entry_Declaration. + Indicate that interface_list can appear in single task and single + protected declarations. + Replace Is_Overriding and Not_Overriding with Must_Override and + Must_Not_Override, to better express intent of AI. + Is_Overriding, Not_Overriding: Ada2005 flags that indicate the presence + of an overriding indicator in a subprogram or instance. + Ada 2005 (AI-248) Null_Present can appear in a procedure specification. + Add the overriding indicator [[not] overriding] construct to the + following grammar productions: + ENTRY_DECLARATION + GENERIC_INSTANTIATION + SUBPROGRAM_SPECIFICATION + + * par-ch10.adb (P_Compilation_Unit): Subprogram declaration or body + can start with an overriding indicator. + + * par-ch6.adb (P_Subprogram): Recognize overriding indicator, and set + flags accordingly on subrogram specifications or instances. + + * sem_ch8.adb: + (Analyze_Subprogram_Renaming): For a renaming_as_body, verify that the + overriding_indicator, if present, is consistent with status of spec. + Improve error message for null-excluding checks on controlling access + parameters. + (Check_In_Previous_With_Clause): Protect the frontend against + previously reported critical errors in the context clauses. + Save and restore Ada_Version_Explicit, for implementation of AI-362 + (Analyze_Subprogram_Renaming): If the new entity is a dispatching + operation verify that controlling formals of the renamed entity that + are access parameters are explicitly non-null. + (Find_Expanded_Name): Improve error message when prefix is an illegal + reference to a private child unit. + + * exp_imgv.adb, s-imgwch.ads, s-imgwch.adb, s-valwch.adb, + s-valwch.ads, s-widwch.adb, s-widwch.ads, s-wwdcha.adb, s-wwdwch.adb: + Rewrite to correspond to new wide character names in AI-395 + + * par-ch12.adb (P_Formal_Subprogram_Declaration): Recognize null + default procedures. + +2005-06-14 Ed Schonberg + Robert Dewar + + * errout.ads, errout.adb (Error_Msg_NW): Only emit warning on user + code, not on the bodies of predefined operations, to cut down on + spurious noise. + +2005-06-14 Ed Schonberg + + * exp_aggr.adb (Aggr_Size_OK): An array with no components can always + be expanded in place. The size computation does not require a + subtraction, which would raise an exception on a compiler built with + assertions when the upper bound is Integer'first. + (Flatten): For an array of composite components, take into account the + size of the components to determine whether it is safe to expand the + array into a purely positional representation. + +2005-06-14 Thomas Quinot + + * exp_ch2.adb (Param_Entity): Take the case of an expanded_name + denoting a formal parameter into account. + +2005-06-14 Ed Schonberg + + * exp_ch7.adb (Find_Node_To_Be_Wrapped): If the node appears within + the entry_call alternative of a conditional entry call, wrap the + conditional entry call itself. + +2005-06-14 Nicolas Setton + Ed Schonberg + + * exp_dbug.ads, exp_dbug.adb (Get_Variant_Part): Fix the encoding of + the "simple_choice" member in a variant record, in accordance with the + description in the package spec: the information output for a constant + should be "S number", not "SS number". + (Get_Encoded_Name): Return at once if not generating code. Avoids name + overflow problem when compiling with -gnatct, for ASIS/gnatmetrics. + +2005-06-14 Thomas Quinot + + * exp_dist.adb (Add_RACW_Primitive_Declarations_And_Bodies): For an + RACW without any primitives, do not generate the if statement for + dispatching by name in the PolyORB/DSA case, as it would be malformed + (it would have an Elsif_Parts list that is not No_List, but with a + length of 0). + +2005-06-14 Robert Dewar + + * exp_intr.adb, par-ch5.adb: Minor fix to error message text + +2005-06-14 Jose Ruiz + + * fe.h: Add entry for Opt.Exception_Locations_Suppressed so that gigi + can determine whether pragma Suppress_Exception_Locations is in effect. + + * utils2.c (build_call_raise): Do not pass the file name to the + exception handler if pragma Suppress_Exception_Locations is in effect. + (build_allocator): Add and process arg IGNORE_INIT_TYPE. + +2005-06-14 Emmanuel Briot + + * g-debpoo.adb (Deallocate, Dereference): Improve output. + +2005-06-14 Nicolas Roche + + * g-diopit.adb (Wildcard_Iterator): Return directly if Path is equal + to "" + (Next_Level): Fix minor bug in handling of ../dir case + (Read): Add dir separator to Directory name so that "" is understood as + "/" + +2005-06-14 Pascal Obry + + * g-dynhta.ads, g-dynhta.adb (Reset): Free the table itself after + releasing the items. + +2005-06-14 Vincent Celier + Cyrille Comar + + * g-os_lib.ads, g-os_lib.adb (Non_Blocking_Spawn): Two new versions + with output file descriptor and with output file name. + (Dup, Dup2): Now global procedures as they are used by two subprograms + (Copy): Allocate the 200K buffer on the heap rather than on the stack. + +2005-06-14 Thomas Quinot + + PR ada/6717 + * g-socket.ads, g-socket.adb (Inet_Addr): Special case the all-ones + broadcast address. + (Create_Selector): Bind listening socket used to create the signalling + socket pair to 127.0.0.1 to limit the scope for 'theft' of connection. + Set listen backlog to 1 to ensure that we detect socket theft by a + failure of our own connect(2) call. + (Check_Selector): Improve documentation of the selector mechanism. + (Broadcast_Inet_Addr): New constant. + +2005-06-14 Gary Dismukes + + * layout.adb (Discrimify): Remove resetting of Vtype to the underlying + type which turns out to be an incomplete and incorrect fix. + (Layout_Array_Type): Use Underlying_Type when checking whether the scope + of the type is declared in a record (for determination of insertion + type). + (SO_Ref_From_Expr): Test whether Vtype denotes a partial or full view of + a private type and ensure that the primary entity is used for the type + of the newly created function's V formal by taking the Etype of the + view. + +2005-06-14 Javier Miranda + Jose Ruiz + Robert Dewar + Ed Schonberg + + * lib-load.ads, lib-load.adb (Load_Unit): Addition of a new parameter + that indicates if we are parsing a compilation unit found in a + limited-with clause. + It is use to avoid the circularity check. + + * par.ads, par.adb (Par): Addition of a new parameter to indicate if + we are parsing a compilation unit found in a limited-with clause. This + is use to avoid the circularity check. + + * par-load.adb (Load): Indicate Lib.Load_Unit if we are loading the + unit as a consequence of parsing a limited-with clause. This is used + to avoid the circularity check. + + * sem_ch10.adb: Suppress Ada 2005 unit warning if -gnatwY used + (Analyze_Context): Limited-with clauses are now allowed + in more compilation units. + (Analyze_Subunit_Context, Check_Parent): Protect the frontend + againts previously reported critical errors in context clauses + (Install_Limited_Withed_Unit): Code cleanup plus static detection + of two further errors: renamed subprograms and renamed packages + are not allowed in limited with clauses. + (Install_Siblings): Do not install private_with_clauses on the package + declaration for a non-private child unit. + (Re_Install_Parents): When a parent of the subunit is reinstalled, + reset visibility of child units properly. + (Install_Withed_Unit): When a child unit appears in a with_clause of its + parent, it is immediately visible. + +2005-06-14 Ed Schonberg + Emmanuel Briot + + * lib-xref.ads, lib-xref.adb (Generate_Definition): Treat any entity + declared within an inlined body as referenced, to prevent spurious + warnings. + (Output_One_Ref): If an entity renames an array component, indicate in + the ALI file that this aliases (renames) the array. Capture as well + function renamings that rename predefined operations. + Add information about generic parent for package and subprogram + instances. + (Get_Type_Reference): For a subtype that is the renaming of an actual in + an instantiation, use the first_subtype to ensure that we don't generate + cross-reference information for internal types. + For objects and parameters of a generic private type, retain the '*' + indicator to distinguish such an entity from its type. + + * ali.ads (Xref_Entity_Record): New fields Iref_File_Num and Iref_Line, + to store information about instantiated entities. + + * ali.adb (Scan_ALI): Add support for parsing the reference to the + generic parent + + * xref_lib.adb (Skip_To_Matching_Closing_Bracket): New subprogram + (Parse_Identifier_Info, Parse_Token): Add support for the generic parent + information. + +2005-06-10 Doug Rupp + Arnaud Charlet + Olivier Hainque + Jose Ruiz + + * Make-lang.in: Add initialize.o when needed. + Remove obsolete references to RT_FLAGS. + Add missing dependencies for sdefault.o + + * initialize.c: New file. + + * init.c [VMS] Declare ADA$ externs weak to fix build problem in IVMS. + [VMS] cond_signal_table: Fix problem in declaration. + [VMS] __gnat_error_handler: rewrite. + Move all __gnat_initialize() routines to initialize.c + Specialize the former "hpux" section to "hppa hpux", as this is what the + section really is here for and we now have other hpux ports that need + different contents. + (__gnat_adjust_context_for_raise) i386-linux: First version of this + function for this target. Adjust PC by one in the machine context. This + adjustment was previously done in the MD_FALLBACK_FRAME_STATE_FOR, but + it is more reliable to do that in the signal handler itself. + (__gnat_install_handler) i386-linux: Set SA_SIGINFO in the sigaction + flags, so that the handler is passed the context structure to adjust + prior to the raise. + (__gnat_error_handler) i386-linux: Adjust the signature to match what a + SA_SIGINFO sigaction should look like. Call + __gnat_adjust_context_for_raise before actually raising. Cleanup unused + Machine_State_Operations stuff. + Add conditional code so that the x86_64 is also supported. + +2005-06-14 Pascal Obry + + * mdll.adb (Get_Dll_Name): New routine that returns the DLL name given + the library name. + +2005-06-14 Robert Dewar + + * opt.ads, opt.adb: New flags for persistent_bss mode + Add Ada_Version_Explicit, for implementation of AI-362 + Add Assertions_Enabled_Config and associated handling + Needed since setting can be changed with Assertion_Policy pragma + Add new flag Warn_On_Ada_2005_Compatibility + + * switch-c.adb: Recognize -gnatwy/Y + Set Ada_Version_Explicit, for implementation of AI-362 + The -gnatg switch now includes -gnatyu + + * usage.adb: Add -gnatwy/Y + Remove wrong asterisk on -gnatwX line + Add line for -gnatyu switch + +2005-06-14 Vincent Celier + + * osint.adb (Add_Default_Search_Dirs): Put source and object + directories of project files before directories coming from + ADA_INCLUDE_PATH and ADA_OBJECTS_PATH. + +2005-06-14 Robert Dewar + + PR ada/15613 + * par-ch2.adb (Scan_Pragma_Argument): New procedure + (P_Pragma): Implement RM 2.8(4) check for no pos args after named args + +2005-06-14 Vincent Celier + + * prep.adb (Preprocess): Ignore error when scanning the first token of + a line. + +2005-06-14 Vincent Celier + + * prj-nmsc.adb (Suffix_For): Change default suffix for C++ to ".cpp" + (Check_Stand_Alone_Library): If the specified reference symbol file does + not exist, only issue a warning when the symbol policy is not + Controlled. And, when symbol policy is Compliant, set the symbol + policy to Autonomous. + +2005-06-14 Vincent Celier + + * prj-part.adb (Pre_Parse_Context_Clause): Call Set_Is_Not_Last_In_List + when the project file in a with clause is not the last one, that is the + project file name is followed by a comma. + * prj-pp.adb: (First_With_In_List): New Boolean global variable + (Print): Issue list of project files separated by commas in with clauses + according to the values returned by Is_Not_Last_In_List. + * prj-tree.ads, prj-tree.adb: (Is_Not_Last_In_List): New function + (Set_Is_Not_Last_In_List): New procedure + +2005-06-14 Eric Botcazou + + * s-atacco.ads: Put a pragma No_Strict_Aliasing on Object_Pointer. + +2005-06-14 Robert Dewar + + * scng.adb: Add call to new Check_EOF routine + (Accumulate_Checksum): Properly handle wide wide char >= 2 ** 24 + Add some comments regarding wide character handling + + * style.ads, styleg.ads, styleg.adb: Implement new style switch -gnatyu + + * stylesw.ads, stylesw.adb: Implement new style switch -gnatyu + + * g-utf_32.ads, g-utf_32.adb (Is_UTF_32_Non_Graphic): Other_Format + characters are now considered graphic characters and hence yield false + in this call. + + * nmake.adt: Modify header so that xnmake does not generate output + files with multiple blank lines. + + * treeprs.adt: Remove a blank line so that output from xtreeprs does + not have an extra blank line + +2005-06-14 Gary Dismukes + + * sem_aggr.adb (Aggregate_Constraint_Checks): Apply a conversion to the + expression when the component type is an anonymous access type to + ensure that appropriate accessibility checks are done. + + * sem_ch5.adb (Analyze_Assignment): Apply a implicit conversion to the + expression of an assignment when the target object is of an anonymous + access type. This ensures that required accessibility checks are done. + (One_Bound): Move the check for type Universal_Integer to + Process_Bounds. + (Process_Bounds): Check whether the type of the preanalyzed range is + Universal_Integer, and in that case set Typ to Integer_Type prior + to setting the type of the original range and the calls to One_Bound. + +2005-06-14 Ed Schonberg + + * sem_case.adb (Expand_Others_Choice): Improve warning. + +2005-06-14 Ed Schonberg + + * sem_eval.adb (Subtypes_Statically_Match): Use discriminant + constraint of full view if present, when other type is discriminated. + (Eval_Relational_Op): Recognize tests of pointer values against Null, + when the pointer is known to be non-null, and emit appropriate warning. + +2005-06-14 Robert Dewar + Ed Schonberg + + PR ada/10671 + * sem_prag.adb: Implement pragma Persistent_BSS + Remove obsolete pragma Persistent_Data, Persistent_Object + Set Ada_Version_Explicit, for implementation of AI-362 + Test Ada_Version_Explicit for Preelaborate_05 and Pure_05 + Add processing for pragma Pure_05 and Preelaborate_05 + Add processing for Assertion_Policy pragma + Add pragma identifiers for Assert + (Analyze_Pragma, case Assert): Check number of arguments + (Process_Inline): Additional guard against an illegal program, where the + argument of the pragma is undefined, and warnings on redundant + constructs are enabled. + (Analyze_Pragma, case Obsolescent): Allow an optional second argument + Ada_05 to this pragma, specifying that the pragma is only active in + Ada_05 mode. + (Check_Arg_Order): New procedure + Add appropriate calls to this procedure throughout + Also throughout, check entity name before doing any other checks + + * snames.h snames.ads, snames.adb: Add pragma Persistent_BSS + Remove obsolete pragma Persistent_Data, Persistent_Object + Add entries for pragma Pure_05 and Preelaborate_05 + Add entries for Assertion_Policy pragma and associated names + Add some names for pragma argument processing + + * tbuild.ads, tbuild.adb: (Make_Linker_Section_Pragma): New function + +2005-06-14 Ed Schonberg + + * sem_warn.adb (Warn_On_Known_Condition): If the constant expression + appears within a negation (either from source or as a rewriting of + inequality) adjust text of warning accordingly. + +2005-06-14 Thomas Quinot + + * s-strxdr.adb: Follow AI95-00132 + +2005-06-14 Arnaud Charlet + + * s-tasren.adb (Exceptional_Complete_Rendezvous): Fix race condition. + +2005-06-14 Arnaud Charlet + Jose Ruiz + + * s-tposen.adb, s-tpobop.adb + (Exceptional_Complete_Rendezvous): Save the occurrence and not only + the exception id. + (PO_Do_Or_Queue): Before queuing a task on an entry queue we check that + there is no violation of the Max_Entry_Queue_Length restriction (if it + has been set); Program_Error is raised otherwise. + (Requeue_Call): Before requeuing the task on the target entry queue we + check that there is no violation of the Max_Entry_Queue_Length + restriction (if it has been set); Program_Error is raised otherwise. + +2005-06-14 Robert Dewar + + * styleg.adb: Fix several remaining problems in -gnatyu switch + Blank line count not reset at start + Scanning outside source buffer in some cases + Confusing message for blanks at end of file + Non-empty blank lines not recognized + + * nmake.adt: Modify header so that xnmake does not generate output + files with multiple blank lines. + + * treeprs.adt: Remove a blank line so that output from xtreeprs does + not have an extra blank line + +2005-06-14 Sergey Rybin + + * styleg-c.adb (Body_With_No_Spec): Remove ':' from warning message. + +2005-06-14 Doug Rupp + Vincent Celier + + * vms_conv.ads, vms_conv.adb: Remove "Library" command. + Update copyright. + + * vms_data.ads: Add entry for -gnaty/Y [NO]ADA_2005_COMPATIBILITY + Remove "Library" command. + Change keyword for style check -gnatyd from NOCRLF to + DOS_LINE_ENDINGS. + Remove useless second style check keyword NONE + Remove help documentation for inexistent style check keyword + RM_COLUMN_LAYOUT. + Add help documentation for style check keywords DOS_LINE_ENDINGS, + UNNECESSARY_BLANK_LINES and XTRA_PARENS + Add UNNECESSARY_BLANK_LINES for -gnatyu + Add qualifiers /ALL_PROJECTS (-U) for GNAT PRETTY and GNAT METRIC + + * ug_words: Add entry for -gnaty/Y [NO]ADA_2005_COMPATIBILITY + +2005-06-14 Vincent Celier + + * makegpr.adb (Compile_Link_With_Gnatmake): Invoke gnatmake with -d if + gprmake was invoked with -d. + (Compile_Sources): If -d was used, output the "completed ..." message + for each compilation. + (Scan_Arg): Recognize new switch -d + When -c and at least one main is specified, set + Unique_Compile to True to guarantee that no other sources will be + compiled. + +2005-06-14 Matthew Heaney + + * a-swunha.ads, a-swunha.adb: Removed. Replaced by a-swuwha.ad[sb] + * a-swuwha.ads, a-swuwha.adb: New files + + * a-szunha.ads, a-szunha.adb: Removed, replaced by a-szuzha.ad[sb] + * a-szuzha.ads, a-szuzha.adb: New files. + + * a-rbtgso.adb, a-crbtgo.ads, a-crbtgo.adb, a-crbtgk.ads, + a-crbtgk.adb, a-crbltr.ads, a-coorse.ads, a-coorse.adb, a-convec.ads, + a-convec.adb, a-coinve.ads, a-coinve.adb, a-cohata.ads, a-cohama.ads, + a-cohama.adb, a-ciorse.ads, a-ciorse.adb, a-cihama.ads, a-cihama.adb, + a-cidlli.ads, a-cidlli.adb, a-chtgop.ads, a-chtgop.adb, a-cdlili.ads, + a-cdlili.adb, a-coormu.adb, a-ciormu.adb, a-cihase.adb, a-cohase.adb, + a-cohase.ads, a-ciorma.ads, a-coorma.ads, a-ciormu.ads, a-coormu.ads, + a-swunha.adb, a-stunha.adb, a-ciorma.adb, a-coorma.adb, a-shcain.ads, + a-shcain.adb, a-chtgke.ads, a-chtgke.adb, a-stwiha.ads, a-stwiha.adb, + a-strhas.adb, a-stzhas.adb: synchronized to the latest version of the + Ada 2005 RM. + +2005-06-10 Eric Botcazou + Olivier Hainque + Richard Kenner + Pascal Obry + + * gigi.h: (build_allocator): Add arg IGNORE_INIT_TYPE. + + * trans.c (call_to_gnu): Issue a warning for users of Starlet when + making a temporary around a procedure call because of non-addressable + actual parameter. + (process_freeze_entity): If entity is a private type, capture size + information that may have been computed for the full view. + (tree_transform, case N_Allocator): If have initializing expression, + check type for Has_Constrained_Partial_View and pass that to + build_allocator. + (tree_transform, case N_Return_Statement): Pass extra arg to + build_allocator. + + * decl.c (annotate_value): Remove early return if -gnatR is not + specified. + (gnat_to_gnu_field): Don't make a packable type for a component clause + if the position is byte aligned, the field is aliased, and the clause + size isn't a multiple of the packable alignment. It serves no useful + purpose packing-wise and would be rejected later on. + (gnat_to_gnu_entity, case object): Pass extra arg to build_allocator. + + PR ada/20515 + (gnat_to_gnu_entity): Remove use of macro _WIN32 which is wrong in the + context of cross compilers. We use TARGET_DLLIMPORT_DECL_ATTRIBUTES + instead. + (create_concat_name): Idem. + +2005-06-10 Robert Dewar + Eric Botcazou + Ben Brosgol + Cyrille Comar + Sergey Rybin + Pascal Obry + + * gnat_rm.texi: Add documentation for pragma Persistent_BSS + Document second argument (Ada_05) of pragma Obsolescent + Add note that call to subprogram marked with pragma Obsolescent + is now considered to be a violation of program Restrictions + (No_Obsolescent_Features). + (Implementation Defined Pragmas) : Make it clear + that only machine-dependent attributes are supported. + + * gnat_ugn.texi: + Commented out menu lines and empty section for gnatclean examples + Document -gnatwy/Y + Fix some over long lines + Clarify and enhance documentation of ADA_PROJECT_PATH. + Rework section 2.11.2(3) about linking with a non-GNU compiler. + Mention new switch -fcallgraph-info. + Mention new switch -fstack-usage. + For gnatpp, replace '-notab' with '-N' and add this option to Index + Corrected VMS example. + VMS keyword for style check -gnatyd is DOS_LINE_ENDINGS, no NOCRLF + Minor reformatting + Add documentation for -gnatyu switch (unnecessary blank lines) + Document new switch -U for GNAT PRETTY and GNAT METRIC + Add note about Stdcall being handled as C convention on non Windows OS. + Remove some junk typo in description of gnatbind -S switch + Remove reference to Extensions_Allowed pragma + Document the new order of the directories to be searched (source and + object directories of project files before directories in ADA_*_PATH + environment variables. + + * g-trasym.ads: Document that IRIX is supported + +2005-06-10 Arnaud Charlet + + * Makefile.in: Add initialize.o when needed. + Adapt to new VMS package body Symbols and subunits + No specialized version of a-sytaco is needed for VxWorks. + + * a-wichun.ads, a-wichun.adb, a-zchuni.ads, a-zchuni.adb: New files. + * a-zchara.ads, a-widcha.ads: New files. + + * system-hpux-ia64.ads: New file. + + * i-vxwork-x86.ads, i-vxwork.ads (intContext): Add this function which + is imported from the VxWorks kernel. + +2005-06-14 Robert Dewar + + * g-soliop-mingw.ads, g-soccon-vms.adb, a-swmwco.ads, exp_smem.adb, + fmap.adb, a-szmzco.ads, s-traent-vms.adb, s-traent-vms.ads, + a-direio.ads, a-exctra.ads, a-exexda.adb, a-exextr.adb, a-stream.ads, + s-restri.ads, s-restri.adb, s-traent.adb, s-traent.ads, a-slcain.adb, + a-stzhas.ads, a-tiinau.adb, comperr.adb, exp_ch11.adb, g-boubuf.adb, + g-calend.adb, g-debpoo.ads, g-moreex.ads, gprep.adb, g-regpat.ads, + i-cexten.ads, i-os2thr.ads, makeutl.ads, memroot.adb, mlib-prj.adb, + namet.adb, namet.ads, prj-makr.adb, prj-proc.adb, sem_dist.adb, + sem_elim.ads, s-valint.adb, s-vallli.adb, s-vallli.adb, s-vallli.ads, + s-valllu.adb, s-valllu.ads, s-valrea.adb, s-valrea.ads, scn.adb, + s-tasinf.adb, targparm.adb, uname.adb, uname.ads, xnmake.adb, + xsinfo.adb, a-direct.ads: Remove extra blank lines. Minor reformatting. + +2005-06-14 Thomas Quinot + + * xeinfo.adb: Fix typo in comment + +2005-06-14 Javier Miranda + + * repinfo.ads: Fix typo in comment + +2005-06-14 Gary Dismukes + + * s-finimp.adb (Parent_Tag): Delete this imported function (function + Parent_Tag is now in the visible part of Ada.Tags). + (Get_Deep_Controller): Call Ada.Tags.Parent_Tag directly instead of + using imported function. + +2005-06-14 Bernard Banner + + * vxaddr2line.adb: Add support for Windows hosted x86 vxworks. Should + also apply for handling support for VxSim 653. + +2005-06-14 Eric Botcazou + + * xsnames.adb: Add automatic generation of snames.h. + +2005-06-14 Thomas Quinot + + * gen-soccon.c: Add IP_MULTICAST_IF constant + Minor reformatting and adjustments to prevent warnings. + +2005-06-14 Pascal Obry + + * seh_init.c: Do not include . This is not needed. + +2005-06-03 Andrew Pinski + + * trans.c (gnat_gimplify_expr): Call + recompute_tree_invarant_for_addr_expr when we change + the operand of the ADDR_EXPR. + +2005-05-31 Kaveh R. Ghazi + + * misc.c: Don't include errors.h. + +2005-05-29 Kaveh R. Ghazi + + * raise.c (db): Add ATTRIBUTE_PRINTF_2. + +2005-05-29 Kazu Hirata + + * cal.c, decl.c, init.c, raise.c, trans.c, utils2.c: Fix + comment typos. + * gnat_rm.texi, gnat_ugn.texi: Fix typos. + +2005-05-16 Nathanael Nerode + + PR ada/20270 + * Makefile.in: Make TGT_LIB behave correctly. + +2005-04-23 DJ Delorie + + * misc.c: Adjust warning() callers. + +2005-04-16 Laurent Guerby + + PR ada/18847 + * a-nudira.adb (Value): Check for valid string. + * a-nuflra.adb (Value): Likewise. + +2005-04-11 Richard Sandiford + + * lang.opt: Refer to the GCC internals documentation instead of c.opt. + +2005-04-10 Kazu Hirata + + * adaint.c, init.c, tracebak.c: Fix comment typos. + * gnat-style.texi, gnat_rm.texi, gnat_ugn.texi: Fix typos. + +2005-04-07 Laurent Guerby + John David Anglin + + * Makefile.in: Add make ifeq define for hppa linux tasking support. + * system-hpux.ads: Define Signed_Zeros to be True. + * system-linux-hppa.ads, s-osinte-linux-hppa.ads: New files. + +2005-04-01 Kazu Hirata + + * adaint.c, cal.c, decl.c, gigi.h, gmem.c, init.c, link.c, + raise.c, tracebak.c, trans.c, utils2.c, utils.c: Fix comment + typos. + +2005-03-30 Tom Tromey + + * decl.c (gnat_substitute_in_type): Don't handle FILE_TYPE. + +2005-03-30 Aaron W. LaFramboise + + * adaint.c (_gnat_set_close_on_exec): Mark parameters unused. + +2005-03-29 Robert Dewar + + * sem_res.adb (Resolve_Real_Literal): Generate warning if static + fixed-point expression has value that is not a multiple of the Small + value. + + * opt.ads (Warn_On_Bad_Fixed_Value): New flag + + * s-taprop-tru64.adb (RT_Resolution): Return an integer number of + nanoseconds. + + * ug_words: Add entry for [NO_]BAD_FIXED_VALUES for -gnatwb/-gnatwB + +2005-03-29 Vincent Celier + + * mlib-tgt-vms-ia64.adb, mlib-tgt-vms-alpha.adb + (Build_Dynamic_Library.Version_String): Return the empty string when + Lib_Version is empty or when the symbol policy is not Autonomous. + + * symbols-vms-alpha.adb (Finalize): For symbol policy Compliant, when + a symbol is not in the reference symbol file, increase the Major ID + and set the Minor ID to 0. + Use gsmatch=lequal instead of gsmatch=equal + +2005-03-29 Doug Rupp + + * adaint.c (__gnat_to_canonical_file_spec [VMS]): Check for logical + name and translate. + +2005-03-29 Javier Miranda + + * a-tags.ads, a-tags.adb (Get_TSD): Subprogram removed. + (Inherit_DT): The first formal has been redefined as a Tag. + This allows us the removal of the subprogram Get_TSD. + (TSD): Replace the call to Get_TSD by the actual code. + + * exp_disp.ads, exp_disp.adb: Remove support to call Get_TSD. + (Make_DT): Upgrade the call to Inherit_TSD according to the + new interface: the first formal is now a Tag. + + * i-cpp.ads, i-cpp.adb (CPP_Inherit_DT): The first formal has been + redefined as a Tag. + This change allows us to remove the subprogram Get_TSD. + (CPP_Get_TSD): Subprogram removed. + (TSD): Replace the call to CPP_Get_TSD by the actual code. + + * rtsfind.ads: Remove support to call the run-time + subprogram Get_TSD + +2005-03-29 Robert Dewar + + * errutil.adb, errout.adb: + Minor comment updates on Line_Terminator references + + * par-ch10.adb: Add ??? comment about line terminator + + * styleg.adb (Check_Line_Terminator): Add check for new switch -gnatyd + (check dos line terminator). + (Check_Line_Max_Length): New procedure, split off from the existing + Check_Line_Terminator routine. Separating this out allows -gnatyf to + be properly recognized. + + * styleg.adb: Add ??? comment for line terminator reference + + * scng.adb (Check_End_Of_Line): Fix bug of -gnatyf being ignored + (Check_End_Of_Line): Add -gnatyd handling (check dos line terminators) + + * styleg.ads (Check_Line_Terminator): Add check for new switch -gnatyd + (check dos line terminator). + (Check_Line_Max_Length): New procedure, split off from the existing + Check_Line_Terminator routine. Separating this out allows -gnatyf to + be properly recognized. + + * stylesw.ads, stylesw.adb: + Add handling for new -gnatyd switch (check dos line terminator) + + * switch-c.adb: Recognize new -gnatyd switch (check dos line terminator) + Recognize -gnatwb/-gnatwB switches + Include Warn_On_Bad_Fixed_Value for -gnatg + + * usage.adb: + Add line for new -gnatyd switch (check dos line terminator) + + * usage.adb: Add lines for -gnatwb/-gnatwB + + * vms_data.ads: Add entry for NOCRLF (-gnatyd) + + * vms_data.ads: [NO_]BAD_FIXED_VALUES synonym for -gnatwb/-gnatwB + + * gnat_ugn.texi: Fix overlong lines + Document new -gnatyd switch + Document new -gnatwb/-gnatwB switches + +2005-03-29 Ed Schonberg + + * exp_ch4.adb (Has_Unconstrained_UU_Component): Use the base type in + order to retrieve the component list of the type, before examining + individual components. + + * sem_type.adb (Covers): Types are compatible if one is the base type + of the other, even though their base types might differ when private + views are involved. + +2005-03-29 Thomas Quinot + + * exp_dist.adb (Add_RAST_Features, PolyORB version): Set the From_Any, + To_Any and TypeCode TSSs on RAS types directly using Set_TSS, instead + of using Set_Renaming_TSS. This ensures that the TSS bodies are not + analyzed if expansion is disabled (which could otherwise cause spurious + error messages if expansion has been disabled due to previous + (unrelated) errors). + + * sem_prag.adb (Analyze_Pragma, case Asynchronous): If RAS expansion + is disabled, the entity denoted by the argument is the access type + itself, not an underlying record type, so there is no need to go back + to the Corresponding_Remote_Type. + +2005-03-29 Gary Dismukes + Robert Dewar + + * exp_intr.adb (Expand_Dispatching_Constructor_Call): New procedure to + expand a call to an instance of + Ada.Tags.Generic_Dispatching_Constructor into a dispatching call to the + Constructor actual of the instance. A class-wide membership + check is also generated, to ensure that the tag passed to the instance + denotes a type in the class. + (Expand_Intrinsic_Call): Call Expand_Dispatching_Constructor in the case + of Name_Generic_Dispatching_Constructor. + + * Makefile.rtl: Add a-tgdico.ads to the list of library units (new Ada + 05 unit for AI-260-02). + + * a-tgdico.ads: New file. + + * impunit.adb (Non_Imp_File_Names_05): Add entry "a-tgdico" for new + predefined Ada 05 generic unit Ada.Tags.Generic_Dispatching_Constructor. + + * snames.ads, snames.adb (Preset_Names): Add entry for + Generic_Dispatching_Constructor. + + PR ada/20300 + * sem_ch8.adb (Find_Direct_Name): Go to root type for check of + character type cases. + (Analyze_Subprogram_Renaming): Add special handling for + the case of renaming of stream attributes when the renaming denotes a + generic formal subprogram association for an abstract formal subprogram. + Check that the attribute is a primitive stream attribute (and not + a class-wide stream attribute) and then rewrite the attribute name + as the name of the appropriate compiler-generated stream primitive. + +2005-03-29 Robert Dewar + + * exp_util.adb (Remove_Side_Effects): Properly propagate arguments to + recursive calls. + (Is_Possibly_Unaligned_Object): Correct typo that + resulted in inaccurate result for unaligned scalars within records. + +2005-03-29 Ed Schonberg + + * freeze.adb (Freeze_Record_Type): If the type of the component is an + itype whose parent is controlled and not yet frozen, do not create a + freeze node for the itype if expansion is disabled. + +2005-03-29 Vincent Celier + + * make.adb (Gnatmake): Don't fail if the main project file is declared + as having no Ada sources. Do not display message "no sources to + compile" in quiet output. + +2005-03-29 Doug Rupp + + * Makefile.in [VMS] (EXTRA_GNATTOOLS): Add vms_help and gnat.hlp as + extra tools. + +2005-03-29 Robert Dewar + + * par-ch12.adb (P_Generic): Give better msg for illegal private generic + child. + +2005-03-29 Robert Dewar + + * par-ch3.adb (P_Type_Declaration): Fix bad error recovery after + missing TYPE Improve the error message generated when compiling a + limited interface in Ada83 or Ada95 mode. + +2005-03-29 Robert Dewar + + * par-ch4.adb (P_Name): When a bad attribute is returned, return error, + rather than proceed ahead using a junk attribute name. + +2005-03-29 Vincent Celier + + * prj.ads, prj.adb: (Project_Data): Add new component Display_Name + + * prj-part.adb (Parse_Single_Project): Set the location of a project + on its defining identifier, rather than on the reserved word "project". + + * prj-proc.adb (Expression): Adapt to the fact that default of external + references may be string expressions, not always literal strings. + (Recursive_Process): Set Display_Name equal to Name + when Location is No_Location, that is when there is no actual file. + Get the Display_Name of the project from the source, when it is not a + virtual project. + (Process): Use the Display_Name in error messages + + * prj-strt.adb (External_Reference): Allow default to be string + expressions, not only literal strings. + +2005-03-29 Vincent Celier + + * prj-nmsc.adb (Check_Stand_Alone_Library): Do not forbid the symbol + file and the reference symbol file to be the same file. + +2005-03-29 Thomas Quinot + + * sem_cat.adb (Validate_Remote_Types_Type_Conversion): Perform check to + forbid conversion of a local access-to-subprogram type to a remote one. + + * sem_util.adb (Wrong_Type): For a record type that is the expanded + equivalent type for a remote access-to-subprogram type, go back to the + original RAS entity when displaying an error message, so the casing is + the original source casing. + +2005-03-29 Robert Dewar + + * sem_ch11.adb (Analyze_Raise_Statement): Change message for warning + on param update. + +2005-03-29 Ed Schonberg + + * sem_ch4.adb (Analyze_Selected_Component): Do not generate an actual + subtype if code is being pre-analyzed, to prevent un-expanded + references to protected formals, among others. + (Analyze_Explicit_Dereference): If the overloaded prefix includes some + interpretation that can be a call, include the result of the call as a + possible interpretation of the dereference. + + * sem_ch5.adb (Process_Bounds): Determine type of range by + pre-analyzing a copy of the original range, and then analyze the range + with the expected type. + + * sem_res.adb (Check_Parameterless_Call): For an explicit dereference + with an overloaded prefix where not all interpretations yield an + access to subprogram, do not rewrite node as a call. + (Resolve_Explicit_Dereference): Recognize the previous case and rewrite + the node as a call once the context identifies the interpretation of + the prefix whose call yields the context type. + (Valid_Conversion): For the case of a conversion between + local access-to-subprogram types, check subtype conformance using + Check_Subtype_Conformant instead of Subtype_Conformant, to have a more + detailed error message. + +2005-03-29 Ed Schonberg + + * sem_ch6.adb (Set_Formal_Mode): If the subtype has a non_null + indicator, indicate that the formal can never be null. + (Process_Formals): If a formal has a non_null indicator, insert the + resulting subtype immediately before the enclosing subprogram decl, + and not at the beginning of the corresponding declarative part, to + prevent access before elaboration (Ada2005). + +2005-03-29 Richard Kenner + + PR ada/19956 + * utils.c (finish_record_type): Use variable_size when setting sizes. + +2005-03-29 Robert Dewar + + * xtreeprs.adb, xnmake.adb: Use Stream_IO instead of Text_IO to + guarantee Unix style line terminators for the output files, even when + running on windows. + +2005-03-29 Robert Dewar + + * a-direct.ads, a-direct.adb (Start_Search): Free allocated search + buffer if an exception is raised. + +2005-03-29 Ed Falis + + * cio.c: Undefine putchar and getchar for VTHREADS: incompatible with + VxWorks 653 1.4 + +2005-03-29 Robert Dewar + + * sem_util.ads: Minor reformatting + * gnat_rm.texi: Minor editing. + +2005-03-29 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : Rework comment. + * trans.c (tree_transform) : Use correct predicates. + +2005-03-24 Aaron W. LaFramboise + + * adaint.c (__gnat_portable_spawn): Adjust cast. + +2005-03-23 Joseph S. Myers + + * misc.c (LANG_HOOKS_TRUTHVALUE_CONVERSION): Remove. + +2005-03-17 Pascal Obry + + * adaint.h, adaint.c (__gnat_waitpid): Moved to expect.c where it is + used. + + * expect.c (__gnat_waitpid): Moved here from adaint.c. + Reimplement under Win32 using Win32 API. + + (__gnat_kill) [Win32]: Properly close the process handle before leaving + this routine. + +2005-03-17 Eric Botcazou + + * ada-tree.h: (DECL_RENAMING_GLOBAL_P): New predicate. + (DECL_RENAMED_OBJECT): New accessor macro. + (SET_DECL_RENAMED_OBJECT): New setter macro. + + * decl.c (gnat_to_gnu_entity) : Stabilize the renamed + object in all cases. Attach the renamed object to the VAR_DECL. + (gnat_to_gnu_field): Do not lift the record wrapper if the size of the + field is not prescribed. + + * misc.c (gnat_handle_option): Handle -gnatO separately. + (gnat_print_decl) : New case. + Print the DECL_RENAMED_OBJECT node. + + * lang.opt: Declare separate -gnatO option. + + * trans.c (tree_transform) : If the object is a renaming + pointer, replace it with the renamed object. + : Warn for a conversion to a fat + pointer type if the source is not a fat pointer type whose underlying + array has the same non-zero alias set as that of the destination array. + +2005-03-17 Javier Miranda + + * a-tags.ads, a-tags.adb (Get_Expanded_Name): Removed. + (Get_Inheritance_Depth): Removed. + (Set_Inheritance_Depth): Removed. + + * rtsfind.ads, exp_disp.ads, exp_disp.adb: Remove support to call the + subprogram Get_Expanded_Name because it is not referenced by the + frontend. + + * i-cpp.ads, i-cpp.adb (CPP_Get_Expanded_Name): Removed. + (CPP_Get_Inheritance_Depth): Removed. + (CPP_Set_Inheritance_Depth): Removed. + + * tbuild.ads, tbuild.adb (Make_DT_Component): Removed. + +2005-03-17 Robert Dewar + + * checks.adb (Apply_Array_Size_Check): Completely remove this for GCC + 3, since we now expect GCC 3 to do all the work. + +2005-03-17 Javier Miranda + + * einfo.adb (First_Private_Entity, Set_First_Private_Entity): Addition + of one barrier to avoid wrong usage of this attribute. + + * sem_ch12.adb (Formal_Entity): Fix erroneous usage of the attribute + First_Private_Entity. + + * sem_ch7.adb (Install_Visible_Declarations): Add a barrier to protect + the subprogram against wrong usage. + Adapt the code to traverse the entities in the + scope of a record_type because in addition to its usage regarding + packages, this subprogram is also called by Expand_N_Freeze_Entity + to install the visible declarations of the enclosing scope of a + record_type_with_private to establish the proper visibility before + freezing the entity and related subprograms. + +2005-03-17 Ed Schonberg + + * exp_ch2.adb (In_Assignment_Context): Recognize slice assignments to + entry formals. + +2005-03-17 Thomas Quinot + + * exp_ch3.adb (Check_Attr): New subprogram. + (Check_Stream_Attribute): Move the code for 13.13.2(9/1) enforcement + into a new Check_Attr subprogram, in order to provide a more + explanatory error message (including the name of the missing attribute). + (Stream_Operation_OK): Renamed from Stream_Operations_OK. This + subprogram determines whether a default implementation exists for a + given stream attribute. + (Make_Predefined_Primitive_Specs, Predefined_Primitive_Bodies): + Determine whether to generate a default implementation for each stream + attribute separately, as this depends on the specific attribute. + + * exp_strm.adb (Make_Field_Attribute): For the case of an illegal + limited extension where a stream attribute is missing for a limited + component (which will have been flagged in Exp_Ch3.Sem_Attr), do not + generate a bogus reference to the missing attribute to prevent + cascaded errors. Instead, generate a null statement. + + * sem_attr.adb (Check_Stream_Attribute): A stream attribute is + available for a limited type if it has been specified for an ancestor + of the type. + +2005-03-17 Ed Schonberg + + * exp_ch6.adb (Expand_Inlined_Call): handle the case when the renamed + entity is an operator. + +2005-03-17 Thomas Quinot + + * exp_dist.adb (Get_PCS_Name): Move from Exp_Dist body to Sem_Dist + spec, to make this predicate available to other units. + + * rtsfind.adb (Check_RPC): Use Sem_Dist.Get_PCS_Name instead of + reimplementing it. + + * sem_ch8.adb: Disable expansion of remote access-to-subprogram types + when no distribution runtime library is available. + + * sem_res.adb, sem_dist.adb: Disable expansion of remote + access-to-subprogram types when no distribution runtime library is + available. + (Get_PCS_Name): Move from Exp_Dist body to Sem_Dist spec, to make this + predicate available to other units. + + * sem_dist.ads (Get_PCS_Name): Move from Exp_Dist body to Sem_Dist + spec, to make this predicate available to other units. + +2005-03-17 Vincent Celier + + * make.adb (Insert_Project_Sources): Make sure the Q is always + initialized. + + * prj-nmsc.adb (Check_Ada_Naming_Scheme_Validity): Check Naming against + the default for the tree, not the global default naming. + + * prj-proc.adb (Recursive_Process): No need to put the default naming + in the project data, it's already there. + +2005-03-17 Doug Rupp + + * Makefile.in: (ia64-hp-*vms*): Use s-crtl-vms64.ads. + + * 5xcrtl.ads: Renamed to... + * s-crtl-vms64.ads: ...this new file + +2005-03-17 Robert Dewar + + PR ada/19519 + * namet.adb (Copy_One_Character): Set proper wide character encoding + for upper half character if we have upper half encoding. + +2005-03-17 Robert Dewar + + * par.adb (Par): Improved msg for attempt to recompile predefined unit + +2005-03-17 Thomas Quinot + + * sem_ch13.adb (New_Stream_Function, New_Stream_Procedure): For a + tagged limited type, the TSS is a newly built renaming declaration: + insert it using Set_TSS, not Copy_TSS. + +2005-03-17 Javier Miranda + + * sem_ch4.adb (Try_Primitive_Operation, Class_Wide_Operation and + Try_Object_Operation): Analyze the object that is accessible + through the prefix of the subprogram call before we apply + the transformation of the object-operation notation. + +2005-03-17 Jose Ruiz + + * s-taprob.adb (Initialize_Protection): Initialize the protected + object's owner to Null_Task. + (Lock): If pragma Detect_Blocking is in effect and the caller of this + procedure is already the protected object's owner then Program_Error + is raised. In addition the protected object's owner is updated. + (Lock_Read_Only): If pragma Detect_Blocking is in effect and the caller + of this procedure is already the protected object's owner then + Program_Error is raised. + In addition the protected object's owner is updated. + (Unlock): Remove the ownership of the protected object. + + * s-taprob.ads (Protection): Add the field Owner, used to store the + protected object's owner. + This component is needed for detecting one type of potentially blocking + operations (external calls on a protected subprogram with the same + target object as that of the protected action). Document the rest of + the components. + + * s-tposen.adb, s-tpoben.adb (Initialize_Protection_Entries): + Initialize the protected object's owner to Null_Task. + (Lock_Read_Only_Entries): If pragma Detect_Blocking is in effect and the + caller of this procedure is already the protected object's owner then + Program_Error is raised. + Do not raise Program_Error when this procedure is called from a + protected action. + (Unlock_Entries): Remove the ownership of the protected object. + (Lock_Entries): If pragma Detect_Blocking is in effect and the caller + of this procedure is already the protected object's owner then + Program_Error is raised. + Do not raise Program_Error when this procedure is called from + a protected action. + + * s-tposen.ads, s-tpoben.ads (Protection_Entries): Add the field Owner, + used to store the protected object's owner. + + * s-tpobop.adb (Protected_Entry_Call): If pragma Detect_Blocking is in + effect and this procedure (a potentially blocking operation) is called + from whithin a protected action, Program_Error is raised. + (Timed_Protected_Entry_Call): If pragma Detect_Blocking is in effect + and this procedure (a potentially blocking operation) is called from + whithin a protected action, Program_Error is raised. + +2005-03-17 Vincent Celier + Nicolas Setton + + * mlib-tgt-darwin.adb (Build_Dynamic_Library): Remove the "-fini" + switch, not supported by the linker on Darwin. Add '_' before + init, as this character is added unconditionally by the + compiler. + (Is_Archive_Ext): Replace the wrong library extension ".dyld" by the + correct one ".dylib". This fixes detection of the archive files when + building library projects. + +2005-03-17 Vincent Celier + + * switch-m.adb (Normalize_Compiler_Switches): Recognize switches + -gnat83, -gnat95 and -gnat05. + +2005-03-17 Vasiliy Fofanov + + * gnat_ugn.texi: Document gnatmem restriction + +2005-03-17 Thomas Quinot + + * snames.adb: Document new TSS names introduced by exp_dist/exp_tss + cleanup + +2005-03-17 Robert Dewar + + * s-interr.ads, s-interr.adb, sem_ch3.adb, prj.ads, prj.adb, + a-interr.adb, a-interr.ads, s-interr-sigaction.adb, s-interr-dummy.adb, + s-interr-vms.adb, s-interr-vxworks.adb: Minor reformatting + + * casing.adb: Comment improvements + +2005-03-17 Pascal Obry + + * g-expect.adb: Minor reformatting. + +2005-03-15 Zack Weinberg + + * Make-lang.in (doc/gnat_ugn_unw.info, doc/gnat_rm.info) + (doc/gnat_ugn_unw.dvi, doc/gnat_rm.dvi): Add gcc-vers.texi + to dependencies. + +2005-03-15 Vincent Celier + + * mlib-tgt-darwin.adb (Library_Exist_For, Library_File_Name_For): + Add new parameter In_Tree to specify the project tree: needed + by the project manager. Adapt to changes in project manager + using new parameter In_Tree. + +2005-03-15 Jakub Jelinek + + * Make-lang.in (ada/treeprs.ads, ada/einfo.h, ada/sinfo.h, + ada/nmake.adb, ada/nmake.ads): Use unique subdirectories of + ada/bldtools to avoid make -jN failures. + +2005-03-15 Eric Botcazou + + * trans.c (gnat_to_gnu) : Set gnu_result + to NULL_TREE on entry. + +2005-03-15 Robert Dewar + + * system-unixware.ads, system-linux-ia64.ads, system-freebsd-x86.ads, + system-lynxos-ppc.ads, system-lynxos-x86.ads, system-linux-x86_64.ads, + system-tru64.ads, system-aix.ads, system-vxworks-sparcv9.ads, + system-vxworks-xscale.ads, system-solaris-x86.ads, system-irix-o32.ads, + system-irix-n32.ads, system-hpux.ads, system-vxworks-m68k.ads, + system-linux-x86.ads, system-vxworks-mips.ads, system-os2.ads, + system-interix.ads, system-solaris-sparc.ads, + system-solaris-sparcv9.ads, system-vms.ads, system-mingw.ads, + system-vms-zcx.ads, system-vxworks-ppc.ads, system-vxworks-alpha.ads, + system-vms_64.ads, system-darwin-ppc.ads, system-vxworks-x86.ads, + system-linux-ppc.ads, system-linux-alpha.ads, system-linux-sparc.ads, + system-linux-s390.ads, system-linux-s390x.ads: Add line defining + Compiler_System_Version to be False. + + * opt.ads: Add new flag Opt.Address_Is_Private + + * targparm.ads, targparm.adb: Set new flag Opt.Address_Is_Private + Add new parameter Compiler_System_Version to avoid checking for + completeness of parameters when compiler is compiling itself. + Allows old versions of GNAT to be compiled with new compiler. + +2005-03-15 Eric Botcazou + + * s-osinte-tru64.ads, s-osinte-tru64.adb (Get_Stack_Base): New function + (Hide_Yellow_Zone): New procedure to hide the Yellow Zone of the + calling thread. + (Stack_Base_Available): New flag. + (Get_Page_Size): New overloaded functions imported from C. + (PROT_NONE, PROT_READ, PROT_WRITE, PROT_EXEC, PROT_ALL, + PROT_ON, PROT_OFF): New constants. + (mprotect): New function imported from C. + (pthread_teb_t): New record type. + + * s-taprop-tru64.adb: (Enter_Task): Invoke Hide_Yellow_Zone. + (Create_Task): Account for the Yellow Zone and the guard page. + +2005-03-15 Vincent Celier + + * mlib-tgt-tru64.adb, mlib-tgt-aix.adb, mlib-tgt-irix.adb, + mlib-tgt-hpux.adb, mlib-tgt-linux.adb, mlib-tgt-solaris.adb, + mlib-tgt-vms-alpha.adb, mlib-tgt-vms-ia64.adb, mlib-tgt-mingw.adb, + mlib-tgt-vxworks.adb, mlib-tgt-lynxos.adb (Library_Exist_For, + Library_File_Name_For): Add new parameter In_Tree + to specify the project tree: needed by the project manager. + Adapt to changes in project manager using new parameter In_Tree. + Remove local imports, use functions in System.CRTL. + + * make.adb, clean.adb, gnatcmd.adb (Project_Tree): New constant needed + to use the project manager. + + * makeutl.ads, makeutl.adb (Linker_Options_Switches): New parameter + In_Tree to designate the project tree. Adapt to changes in the project + manager, using In_Tree. + + * mlib-prj.ads, mlib-prj.adb (Build_Library, Check_Library, + Copy_Interface_Sources): Add new parameter In_Tree to specify the + project tree: needed by the project manager. + (Build_Library): Check that Arg'Length >= 6 before checking if it + contains "--RTS=...". + + * mlib-tgt.ads, mlib-tgt.adb (Library_Exist_For, + Library_File_Name_For): Add new parameter In_Tree to specify the + project tree: needed by the project manager. + + * prj.ads, prj.adb: Major modifications to allow several project trees + in memory at the same time. + Change tables to dynamic tables and hash tables to dynamic hash + tables. Move tables and hash tables from Prj.Com (in the visible part) + and Prj.Env (in the private part). Move some constants from the visible + part to the private part. Make other constants deferred. + (Project_Empty): Make it a variable, not a function + (Empty_Project): Add parameter Tree. Returns the data with the default + naming data of the project tree Tree. + (Initialize): After updating Std_Naming_Data, copy its value to the + component Naming of Project Empty. + (Register_Default_Naming_Scheme): Use and update the default naming + component of the project tree, instead of the global variable + Std_Naming_Data. + (Standard_Naming_Data): Add defaulted parameter Tree. If project tree + Tree is not defaulted, return the default naming data of the Tree. + (Initial_Buffer_Size): Constant moved from private part + (Default_Ada_Spec_Suffix_Id, Default_Ada_Body_Suffix_Id, Slash_Id); new + variables initialized in procedure Initialize. + (Add_To_Buffer): Add two in out parameters to replace global variables + Buffer and Buffer_Last. + (Default_Ada_Spec_Suffix, Default_Body_Spec_Suffix, Slash): New + functions. + Adapt to changes to use new type Project_Tree_Ref and dynamic tables and + hash tables. + (Initialize, Reset, register-Default_Namng-Scheme): Add a new parameter + for the project tree. + (Project_Tree_Data, Project_Tree_Ref, No_Project): Declare types and + constant at the beginning of the package spec, so that they cane be used + in subprograms before their full declarations. + (Standard_Naming_Data): Add defaulted parameter of type Project_Node_Ref + (Empty_Project): Add parameter of type Project_Node_Ref + (Private_Project_Tree_Data): Add component Default_Naming of type + Naming_Data. + (Buffer, Buffer_Last): remove global variables + (Add_To_Buffer): Add two in out parameters to replace global variables + Buffer and Buffer_Last. + (Current_Packages_To_Check): Remove global variable + (Empty_Name): Move to private part + (No-Symbols): Make it a constant + (Private_Project_Tree_Data): New type for the private part of the + project tree data. + (Project_Tree_Data): New type for the data of a project tree + (Project_Tree_Ref): New type to designate a project tree + (Initialize, Reset, register-Default_Namng-Scheme): Add a new parameter + for the project tree. + + * prj-attr.ads: Add with Table; needed, as package Prj no longer + imports package Table. + + * prj-com.adb: Remove empty, no longer needed body + + * prj-com.ads: Move most of the content of this package to package Prj. + + * prj-dect.ads, prj-dect.adb (Parse): New parameters In_Tree to + designate the project node tree and Packages_To_Check to replace + global variable Current_Packages_To_Check. + Add new parameters In_Tree and Packages_To_Check to local subprograms, + when needed. Adapt to changes in project manager with project node tree + In_Tree. + + * prj-env.ads, prj-env.adb: Add new parameter In_Tree to designate the + project tree to most subprograms. Move tables and hash tables to + private part of package Prj. + Adapt to changes in project manager using project tree In_Tree. + + * prj-makr.adb (Tree): New constant to designate the project node tree + Adapt to change in project manager using project node tree Tree + + * prj-nmsc.ads, prj-nmsc.adb (Check_Stand_Alone_Library): Correctly + display the Library_Src_Dir and the Library_Dir. + Add new parameter In_Tree to designate the project node tree to most + subprograms. Adapt to changes in the project manager, using project tree + In_Tree. + (Check_Naming_Scheme): Do not alter the casing on platforms where + the casing of file names is not significant. + (Check): Add new parameter In_Tree to designate the + + * prj-pars.ads, prj-pars.adb (Parse): Add new parameter In_Tree to + designate the project tree. + Declare a project node tree to call Prj.Part.Parse and Prj.Proc.Process + + * prj-part.ads, prj-part.adb (Buffer, Buffer_Last): Global variables, + to replace those that were in the private part of package Prj. + Add new parameter In__Tree to designate the project node tree to most + subprograms. Adapt to change in Prj.Tree with project node tree In_Tree. + (Post_Parse_Context_Clause): When specifying the project node of a with + clause, indicate that it is a limited with only if there is "limited" + in the with clause, not necessarily when In_Limited is True. + (Parse): Add new parameter In_Tree to designate the project node tree + + * prj-pp.ads, prj-pp.adb (Pretty_Print): Add new parameter In_Tree to + designate the project node tree. Adapt to change in Prj.Tree with + project node tree In_Tree. + + * prj-proc.ads, prj-proc.adb (Recursive_Process): Specify the project + tree In_Tree in the call to function Empty_Process to give its initial + value to the project data Processed_Data. + Add new parameters In_Tree to designate the project tree and + From_Project_Node_Tree to designate the project node tree to several + subprograms. Adapt to change in project manager with project tree + In_Tree and project node tree From_Project_Node_Tree. + + * prj-strt.ads, prj-strt.adb (Buffer, Buffer_Last): Global variables, + to replace those that were in the private part of package Prj. + Add new parameter In_Tree to designate the project node tree to most + subprograms. Adapt to change in Prj.Tree with project node tree In_Tree. + + * prj-tree.ads, prj-tree.adb: Add new parameter of type + Project_Node_Tree_Ref to most subprograms. + Use this new parameter to store project nodes in the designated project + node tree. + (Project_Node_Tree_Ref): New type to designate a project node tree + (Tree_Private_Part): Change table to dynamic table and hash tables to + dynamic hash tables. + + * prj-util.ads, prj-util.adb: Add new parameter In_Tree to designate + the project tree to most subprograms. Adapt to changes in project + manager using project tree In_Tree. + + * makegpr.adb (Project_Tree): New constant needed to use project + manager. + +2005-03-15 Olivier Hainque + + * s-intman-posix.adb (Notify_Exception): Adjust signature, as handler + for sigactions with SA_SIGINFO set. Call + __gnat_adjust_context_for_raise before raising, to perform the + potentially required adjustments to the machine context for the GCC + unwinder. + + * raise.h (__gnat_adjust_context_for_raise): New prototype. + + * init.c (__gnat_adjust_context_for_raise) HPUX: Initial revision. + Adjust PC by one in the provided machine context. + (__gnat_install_handler) HPUX: Set SA_SIGINFO in the sigaction flags, + so that the handler is passed the context structure to adjust prior to + the raise. + (__gnat_error_handler) HPUX: Adjust the signature to match what an + SA_SIGINFO sigaction should look like. Call + __gnat_adjust_context_for_raise before actually raising. + (__gnat_adjust_context_for_raise): Default noop to help PC + adjustments before raise from signal handlers. + (__gnat_error_handler): Indirectly call a predicate function to + determine if a condition should be resignaled or not. + (__gnat_set_resignal_predicate): User interface to modify the predicate. + (__gnat_default_resignal_p): Default GNAT predicate. + +2005-03-15 Doug Rupp + + * adaint.c: Prefix #include of VMS system header files with vms/ + [VMS] (HOST_EXECUTABLE_SUFFIX, HOST_OBJECT_SUFFIX): Define for VMS. + Do not define a dummy function "convert_addresses" under Darwin, + not needed. + + * tb-alvms.c, expect.c: Prefix #include of VMS system header files + with vms/ + +2005-03-15 Nicolas Setton + + * tracebak.c: Under Darwin, use the same unwinding mechanisms as under + PPC/AIX. + +2005-03-15 Robert Dewar + + * a-reatim.ads, a-reatim.adb: Add functions Minutes and Seconds for + AI-386. + + * a-retide.ads: Minor comment changes + +2005-03-15 Robert Dewar + + * a-stzunb.adb, a-stzunb.adb a-stzunb.ads, a-stzunb.ads, + a-stwiun.ads, a-stwiun.adb, a-strunb.ads, a-strunb.adb: Move + Realloc_For_Chunk to private part of package. + New subprograms for AI-301 + + * a-szuzti.adb, a-suteio.adb, a-swuwti.adb: Improve efficiency of + Get_Line procedure. + Avoid unnecessary use of Get/Set_Wide_String + +2005-03-15 Robert Dewar + + PR ada/13470 + * a-stunau.ads, a-stunau.adb: + Change interface to allow efficient (and correct) implementation + The previous changes to allow extra space in unbounded strings had + left this interface a bit broken. + + * a-suteio.adb: Avoid unnecessary use of Get/Set_String + + * g-spipat.ads, g-spipat.adb: New interface for Get_String + Minor reformatting (function specs) + + * g-spitbo.adb: New interface for Get_String + + * g-spitbo.ads: Minor reformatting + + * a-swunau.ads, a-swunau.adb: New interface for Get_Wide_String + + * a-szunau.ads, a-szunau.adb: New interface for Get_Wide_Wide_String + +2005-03-15 Javier Miranda + Robert Dewar + Thomas Quinot + Richard Kenner + + * atree.ads, atree.adb: Add support for Elist24 field + + * atree.h: Fix wrong definition of Field27 + Add support for Elist16 field + Add support for Elist24 field + + * einfo.ads, einfo.adb (Abstract_Interfaces, + Set_Abstract_Interfaces): New subprograms. + (Abstract_Interface_Alias, Set_Abstract_Interface_Alias): New + subprograms. + (Access_Disp_Table, Set_Access_Disp_Table): Modified to handle a list of + entities rather than a single node. + (Is_Interface, Set_Is_Interface): New subprogram + (First_Tag_Component): New syntesized attribute + (Next_Tag_Component): New synthesized attribute + (Write_Entity_Flags): Upgraded to write Is_Interface + (Write_Field24_Name): Upgraded to write Abstract_Interfaces + (Write_Field25_Name): Upgraded to write Abstract_Interface_Alias + (Task_Body_Procedure): New subprogram to read this attribute. + (Set_Task_Body_Procedure): New subprogram to set this attribute. + (Has_Controlled_Component): Now applies to all entities. + This is only a documentation change, since it always worked to apply + this to other than composite types (yielding false), but now this is + official. + Update documentation on Must_Be_Byte_Aligned for new spec + + * tbuild.adb, exp_dist.adb, exp_disp.adb, exp_ch3.ads, exp_ch3.adb, + exp_attr.adb, exp_aggr.adb, exp_ch4.adb, exp_ch5.adb: Upgrade all the + uses of the Access_Disp_Table attribute to reference the first dispatch + table associated with a tagged type. As + part of the implementation of abstract interface types, + Access_Disp_Table has been redefined to contain a list of dispatch + tables (rather than a single dispatch table). + Similarly, upgrade all the references to Tag_Component by the + new attribute First_Tag_Component. + (Find_Inherited_TSS): Moved to exp_tss. + Clean up test in Expand_N_Object_Declaration for cases + where we need to do a separate assignment of the initial value. + (Expand_N_Object_Declaration): If the expression in the + declaration of a tagged type is an aggregate, no need to generate an + additional tag assignment. + (Freeze_Type): Now a function that returns True if the N_Freeze_Entity + is to be deleted. + Bit packed array ops are only called if operands are known to be + aligned. + (Component_Equality): When returning an N_Raise_Program_Error statement, + ensure that its Etype is set to Empty to avoid confusing GIGI (which + expects that only expressions have a bona fide type). + (Make_Tag_Ctrl_Assignment): Use Build_Actual_Subtype to correctly + determine the amount of data to be copied. + + * par.adb (P_Interface_Type_Definition): New subprogram that parses the + new syntax rule of Ada 2005 interfaces (for AI-251 and AI-345): + INTERFACE_TYPE_DEFINITION ::= + [limited | task | protected | synchronized] interface + [AND interface_list] + + * par-ch3.adb (P_Type_Declaration): Modified to give support to + interfaces. + (P_Derived_Type_Def_Or_Private_Ext_Decl): Modified to give support to + interfaces. + (P_Interface_Type_Definition): New subprogram that parses the new + syntax rule of Ada 2005 interfaces + (P_Identifier_Declarations): fix two occurrences of 'RENAMES' in error + messages by the correct RENAMES (quotes removed). + + * sem_prag.adb: Upgrade all the references to Tag_Component by the new + attribute First_Tag_Component. + + * sinfo.ads, sinfo.adb: Remove OK_For_Stream flag, not used, not needed + (Interface_List, Set_Interface_List): New subprograms. + (Interface_Present, Set_Interface_Present): New subprograms. + (Limited_Present, Set_Limited_Present): Available also in derived + type definition nodes. + (Protected_Present, Set_Protected_Present): Available also in + record type definition and + derived type definition nodes. + (Synchronized_Present, Set_Synchronized_Present): New subprograms. + (Task_Present, Set_Task_Present): New subprogram. + (Task_Body_Procedure): Removed. + (Set_Task_Body_Procedure): Removed. + These subprogram have been removed because the attribute + Task_Body_Procedure has been moved to the corresponding task type + or task subtype entity to leave a field free to store the list + of interfaces implemented by a task (for AI-345) + Add Expression field to N_Raise_Statement node for Ada 2005 AI-361 + (Null_Exclusion_Present): Change to Flag11, to avoid conflict with + expression flag Do_Range_Check + (Exception_Junk): Change to Flag7 to accomodate above change + (Box_Present, Default_Name, Specification, Set_Box_Present, + Set_Default_Name, Set_Specification): Expand the expression + "X in N_Formal_Subprogram_Declaration" into the corresponding + two comparisons. Required to use the csinfo tool. + + * exp_ch11.adb (Expand_N_Raise_Statement): Deal with case where + "with string" given. + + * sem_ch11.adb (Analyze_Raise_Statement): Handle case where string + expression given. + + * par-ch11.adb (P_Raise_Statement): Recognize with string expression + in 2005 mode + + * exp_ch9.adb (Build_Task_Proc_Specification): Modified to use entity + attribute Task_Body_Procedure rather than the old semantic field that + was available in the task_type_declaration node. + + * par-ch12.adb (P_Formal_Type_Definition): Modified to handle formal + interface type definitions. + (P_Formal_Derived_Type_Definition): Modified to handle the list of + interfaces. + + * par-ch9.adb (P_Task): Modified to handle the list of interfaces in a + task type declaration. + (P_Protected): Modified to handle the list of interfaces in a + protected type declaration. + +2005-03-15 Doug Rupp + Vincent Celier + + * bindgen.adb (Gen_Main_C): Change WBI __posix_exit to decc$posix_exit + (Gen_Output_File_C): Likewise. + (Gen_Main_C): Issue #include to avoid warning + +2005-03-15 Thomas Quinot + + * checks.adb (Get_E_First_Or_Last): When the expression being retrieved + is an N_Raise_Constraint_Error node, create a new copy of it without + going through a call to Duplicate_Subexpr. + +2005-03-15 Eric Botcazou + Richard Kenner + Nicolas Setton + Ed Schonberg + + PR ada/19900 + PR ada/19408 + PR ada/19140 + PR ada/20255 + * decl.c (gnat_to_gnu_field): Reject aliased components with a + representation clause that prescribes a size not equal to the rounded + size of their types. + (gnat_to_gnu_entity, case E_Component): Always look at + Original_Record_Component if Present and not the entity. + (gnat_to_gnu_entity, case E_Record_Subtype): Rework handling of subtypes + of tagged extension types by not making field for components that are + inside the parent. + (gnat_to_gnu_entity) : Fix typo in the alignment formula + (gnat_to_gnu_entity) : Do not convert again the + expression to the type of the object when the object is constant. + Reverse defer_debug_incomplete_list before traversing it, so that trees + are processed in the order at which they were added to the list. This + order is important when using the stabs debug format. + If we are deferring the output of debug information, also defer this + output for a function return type. + When adding fields to a record, prevent emitting debug information + for incomplete records, emit the information only when the record is + complete. + (components_to_record): New parameter defer_debug. + (gnat_to_gnu_entity, case E_Array_Subtype): Call copy_alias_set. + (gnat_to_gnu_field_decl): New function. + (substitution_list, annotate_rep): Call it. + (gnat_to_gnu_entity, case E_Record_Subtype): Likewise. + (gnat_to_gnu_entity, case E_Record_Type): Likewise. + No longer update discriminants to not be a COMPONENT_REF. + (copy_alias_set): Strip padding from input type; also handle + unconstrained arrays properly. + + * gigi.h (write_record_type_debug_info): New function. + Convert to use ANSI-style prototypes. Remove unused + declarations for emit_stack_check, elab_all_gnat and + set_second_error_entity. + (gnat_to_gnu_field_decl): New decl. + + * utils.c (write_record_type_debug_info): New function. + (finish_record_type): Delegate generation of debug information to + write_record_type_debug_info. + (update_pointer_to): Remove unneeded calls to rest_of_decl_compilation. + (update_pointer_to): Fix pasto. + (convert) : Accept slight type variations when + converting to an unchecked union type. + + * exp_ch13.adb (Expand_N_Freeze_Entity): If Freeze_Type returns True, + replace the N_Freeze_Entity with a null statement. + + * freeze.adb (Freeze_Expression): If the freeze nodes are generated + within a constrained subcomponent of an enclosing record, place the + freeze nodes in the scope stack entry for the enclosing record. + (Undelay_Type): New Subprogram. + (Set_Small_Size): Pass T, the type to modify; all callers changed. + (Freeze_Entity, Freeze_Record_Type): Change the way we handle types + within records; allow them to have freeze nodes if their base types + aren't frozen yet. + + * exp_util.adb (Remove_Side_Effects): Properly test for + Expansion_Delayed and handle case when it's inside an + N_Qualified_Expression. + + * sem_ch3.adb (Derived_Type_Declaration): New predicate + Comes_From_Generic, to recognize accurately that the parent type in a + derived type declaration can be traced back to a formal type, because + it is one or is derived from one, or because its completion is derived + from one. + (Constrain_Component_Type): If component comes from source and has no + explicit constraint, no need to constrain in in a subtype of the + enclosing record. + (Constrain_Access, Constrain_Array): Allow itypes to be delayed. + Minor change to propagate Is_Ada_2005 flag + + * trans.c (gnat_to_gnu, case N_Aggregate): Verify that + Expansion_Delayed is False. + (assoc_to_constructor): Ignore fields that have a + Corresponding_Discriminant. + (gnat_to_gnu) : Restructure. If the + function returns "by target", dereference the target pointer using the + type of the actual return value. + : Be prepared for a null gnu_result. + (processed_inline_subprograms): Check flag_really_no_inline + instead of flag_no_inline. + (set_second_error_entity): Remove unused function. + (gnat_to_gnu, case N_Selected_Component): Call + gnat_to_gnu_field_decl. + (assoc_to_constructor): Likewise. + +2005-03-15 Robert Dewar + Ed Schonberg + Richard Kenner + + * exp_pakd.adb (Create_Packed_Array_Type): Do not set + Must_Be_Byte_Aligned for cases where we do not need to use a + System.Pack_nn unit. + + * exp_ch6.adb (Expand_Call): Call Expand_Actuals for functions as well + as procedures. + Needed now that we do some processing for IN parameters as well. This + may well fix some unrelated errors. + (Expand_Call): Handle case of unaligned objects (in particular those + that come from packed arrays). + (Expand_Inlined_Call): If the subprogram is a renaming as body, and the + renamed entity is an inherited operation, re-expand the call using the + original operation, which is the one to call. + Detect attempt to inline parameterless recursive subprogram. + (Represented_As_Scalar): Fix to work properly with private types + (Is_Possibly_Unaligned_Object): Major rewrite to get a much more + accurate estimate. Yields True in far fewer cases than before, + improving the quality of code that depends on this test. + + * exp_util.adb (Kill_Dead_Code): For a package declaration, iterate + over both visible and private declarations to remove them from tree, + and mark subprograms declared in package as eliminated, to prevent + spurious use in subsequent compilation of generic units in the context. + + * exp_util.ads: Minor cleanup in variable names + + * sem_eval.ads, sem_eval.adb: Minor reformatting + (Compile_Time_Known_Bounds): New function + +2005-03-15 Ed Schonberg + + * exp_ch7.adb (Convert_View): Use base types of underlying types when + determining whether an unchecked conversion is needed for the argument + of an initialization call. + +2005-03-15 Ed Schonberg + + * exp_intr.adb (Expand_Unc_Conversion): As a target type, use the type + that appears in the instantiation rather than the internal subtype + generated in the wrapper package, to avoid anomalies in gigi when the + target is derived from a private type whose full view is an access type. + +2005-03-15 Robert Dewar + + * exp_smem.adb, sem_attr.adb: Remove OK_For_Stream flag, not used, + not needed. + Add documentation to replace the use of this flag + Fix kludge for Maximum_Alignment on x86 so that it does not apply to + the x86_64. + +2005-03-15 Thomas Quinot + + * exp_tss.ads, exp_tss.adb (Find_Inherited_TSS): New subprogram, moved + here from exp_attr so it can be shared between exp_attr and exp_dist. + (TSS_Names): Renamed from OK_TSS_Names. This array contains the list of + all TSS names, not a subset thereof, and the previous name introduced + an unnecessarily confusion that a distinction might exist between + "OK" TSS names and some "not OK" TSS names. + +2005-03-15 Doug Rupp + + * gnatchop.adb (Locate_Executable): Normalize the possibly VMS style + Command_Name. + +2005-03-15 Pascal Obry + Eric Botcazou + + PR ada/20226 + PR ada/20344 + * init.c (__gnat_initialize): Do not call __gnat_install_SEH_handler() + when IN_RTS. This is to work around a bootstrap path problem. + + * misc.c (gnat_parse_file): Create a SEH (Structured Exception Handler) + table and pass it to __gnat_install_SEH_handler(). + (gnat_handle_option): Accept OPT_fRTS_, not OPT_fRTS. + + * lang.opt: Fix specification of -fRTS=. + +2005-03-15 Doug Rupp + Bernard Banner + Vincent Celier + Arnaud Charlet + + PR ada/6852 + This change works fine when gnatlib is built from the gcc directory, + but does not work when using the libada Makefile, since GCC_FOR_TARGET + is not passed to ada/Makefile.in, so more work is needed by a + Makefile/configure expert. + + * Makefile.in(gnatlib): Use $(GCC_FOR_TARGET) for compiling library. + set GMEM_LIB on ia64 linux to add optional support for gnatmem. + Setup gnatlink switch -M for x86_64 linux, as it is already setup + for Linux x86. + (gnatlib-shared-default): Use GNATLIBCFLAGS as well. + Run ranlib on libgccprefix.a + Define PREFIX_OBJS for Darwin, to build libgccprefix. + (ADA_INCLUDE_SRCS): Split Ada packages. + +2005-03-15 Robert Dewar + + * Make-lang.in: Add g-utf_32 unit for gnat and gnatbind + + * impunit.adb: Add GNAT.UTF_32 + + * scng.adb: Use gnat.utf_32 instead of widechar for utf_32 stuff + + * widechar.ads, widechar.adb: Remove redundant UTF-32 tables (scng + now uses GNAT.UTF_32). + + * g-utf_32.ads, g-utf_32.adb: This is a new unit with full + capabilities for categorizing characters using Unicode categories + +2005-03-15 Ed Schonberg + + * sem_ch10.adb (Build_Ancestor_Name): If the ancestor is an + instantiation that has been rewritten as a package body, retrieve spec + to generate proper name for implicit_with_clause. + (Install_Parents): Recognize a parent that is an instantiation but has + been rewritten as a package declaration during analysis. + +2005-03-15 Javier Miranda + Ed Schonberg + + * sem_ch12.adb (Instantiate_Object): If the analysis of the actual + parameter reported some error we immediately return. This improves the + behaviour of the frontend in case of errors. + (Install_Parent, Remove_Parent): Introduce new flag + Parent_Unit_Visible, to preserve the proper visibility of the ultimate + ancestor of a generic child unit, when the child is being instantiated. + (Inline_Instance_Body): If we are compiling the private + part or the body of a child unit, restore the proper visibility of the + parents after compiling the instance body. + +2005-03-15 Ed Schonberg + Javier Miranda + + PR ada/15608 + * sem_util.adb (Get_Task_Body_Procedure): Type may be the completion + of a private type, in which case it is underlying_type that denotes + the proper task. Also modified to use the new entity attribute + that is directly available in the task type and task subtype entities + (Build_Actual_Subtype_Of_Component): Handle properly multidimensional + arrays when other dimensions than the first are constrained by + discriminants of an enclosing record. + (Insert_Explicit_Dereference): If the prefix is an indexed component or + a combination of indexed and selected components, find ultimate entity + and generate the appropriate reference for it, to suppress spurious + warnings. + (Note_Possible_Modification): If an entity name has no entity, return. + (Is_Variable): A function call never denotes a variable. + (Requires_Transient_Scope): For record types, recurse only on + components, not on internal subtypes that may have been generated for + constrained components. + +2005-03-15 Ed Schonberg + + * sem_ch4.adb (Analyze_Concatenation): Do not consider operators marked + Eliminated as candidates for resolution. Both efficient, and avoids + anomalies with operators declared in deleted code. + (Process_Implicit_Dereference_Prefix): Use this procedure whenever + expansion is disabled (as when compiling a generic) to prevent spurious + warnings on prefixes of selected components. + +2005-03-15 Ed Schonberg + + * sem_ch6.adb (Is_Private_Declaration): Verify that the declaration is + attached to a list before checking whether it appears in the private + declarations of the current package. + (Make_Inequality_Operator): Insert declaration in proper declarative + list rather than just setting the Parent field, so that + Is_Private_Declaration can handle it properly. + +2005-03-15 Ed Schonberg + + * sem_ch8.adb (Analyze_Subprogram_Renaming): In a generic, if this is + a renaming a body, check that the renamed subprogram in not intrinsic. + (Find_Direct_Name): If several use_visible entities hide + each other, and the context is a predefined file compiled through + rtsfind, keep only the entity that comes from a predefined file. + +2005-03-15 Geert Bosch + + * s-fatgen.adb (Valid): Extend special exceptions to account for long + long float padding to also cover AMD64 and IA64. + +2005-03-15 Gary Dismukes + + * s-imgwch.adb: Add with and use of Interfaces. + (Img_Wide_Character): Change type of Val to Unsigned_16. + (Img_Wide_Wide_Character): Change type of Val to Unsigned_32. + +2005-03-15 Matthew Gingell + + * sysdep.c: Implement __gnat_localtime_r as call to localtime_r on AIX. + +2005-03-15 Robert Dewar + + * usage.adb: Add missing lines for -gnat95 and -gnat05 switches + + * sem_ch7.adb: Minor change to propagate Is_Ada_2005 flag + + * i-c.adb: Clarify that AI-258 behavior is also intended in Ada 95 + +2005-03-15 Robert Dewar + + * s-bitops.adb, s-bitops.ads, + s-taprop-os2.adb, s-intman-vms.ads, s-intman-vxworks.ads, + s-taprop-vxworks.adb, a-caldel.ads, a-calend.adb, a-tasatt.adb, + tbuild.ads, s-finimp.adb, s-imgwch.adb, s-intman.ads, s-intman.ads, + s-memory.adb, s-soflin.ads, s-taasde.ads, s-taprob.adb, s-taprop.ads, + s-taprop.ads, s-tasini.adb, s-tasini.ads, s-tasini.ads, s-tasini.ads, + s-taskin.ads, s-tasren.adb, s-tassta.adb, s-tassta.ads, s-tassta.ads, + s-tasuti.ads, s-tataat.ads, s-tataat.ads, s-tataat.ads, s-tataat.ads, + s-tpoben.adb, s-tpoben.adb, s-tpobop.ads: Update comments. Minor + reformatting. + +2005-03-15 Eric Botcazou + + * utils2.c (build_binary_op): Fix typo. + +2005-03-15 Doug Rupp + + * s-crtl.ads (popen,pclose): New imports. + +2005-03-15 Cyrille Comar + + * comperr.adb (Compiler_Abort): remove references to obsolete + procedures in the bug boxes for various GNAT builds. + +2005-03-15 Vincent Celier + + * snames.ads, snames.adb: Save as Unix text file, not as DOS text file + +2005-03-15 Geert Bosch + Arnaud Charlet + Robert Dewar + Cyrille Comar + Sergey Rybin + + * gnat_ugn.texi: Remove extended inline assembly example, as it was far + too specific and long-winded to be appropriate for the GNAT User's + Guide. + Warn about use of GCC switches not documented in the GNAT User's Guide, + as these may cause generated code to not conform to Ada semantics. + Remove mention of -gdwarf-2 for sparc64, since this is now the default. + Add documentation for -gnat95 and -gnat05 switches + Remove paragraph documenting obsolete way to refer to third party + libraries. + Add a few references to Ada_05 that were missing. + Update documentation on -gnatZ/-gnatL. + Document limitation when using -m64 under Solaris. + Change the "Name Casing" subsection of the pretty-printer section + according to the changes in the dictionary processing. + + * gnat_rm.texi: Document the Ada_05 pragma. + Section on record representation clauses describes the new more + relaxed rules about placement of large packed bit array components. + Add documentation of GNAT.UTF_32 + +2005-03-12 Daniel Berlin + + * misc.c (gnat_post_options): Turn off structural + aliasing for now. + +2005-03-08 Laurent Guerby + + * system-linux-sparc.ads: Fix typo in previous commit. + +2005-03-07 James A. Morrison + Laurent Guerby + + PR ada/20035 + * system-linux-sparc.ads: New. + * Makefile.in: Add sparc linux entry. + +2005-02-27 Danny Smith + + * seh_init.c (__gnat_SEH_error_handler): Mark third and fourth + parameters as unused. + +2005-02-26 Nathanael Nerode + Partial merge from libada-gnattools-branch: + + 2004-12-02 Nathanael Nerode + * Makefile.in: Move gnattools{1,1re,2,3,4} and corresponding flags + into code in gnattools/Makefile.in. Remove direct dependencies on + stamp-tools by tools clauses. + 2004-12-02 Nathanael Nerode + * config-lang.in: Add gnattools to $lang_dirs. + +2005-02-13 Andrew Pinski + + PR ada/19942 + * utils.c (gnat_type_for_mode): Return null instead of ICE because + we asked for an unknown mode. + +2005-02-12 Richard Henderson + + * utils.c (gnat_type_for_mode): Return NULL for COMPLEX modes; + validate SCALAR_INT_MODE_P before calling gnat_type_for_size. + +2005-02-10 Andreas Jaeger + + * init.c (__gnat_initialize): Mark parameter as unused. + +2005-02-09 Doug Rupp + + * g-expect-vms.adb (Non_Blocking_Spawn): Separate out. + * g-enblsp-vms-alpha.adb g-enblsp-vms-ia64.adb: New subunits. + +2005-02-09 Doug Rupp + + * gnatchop.adb (dup, dup2), + g-dirope.adb (closedir, opendir, rmdir): Reference via System.CRTL. + + * gnatlbr.adb (mkdir), + mlib-tgt-vms-ia64.adb (popen, plose): Import with decc$ prefix. + + * s-crtl.ads (closdir, dup, dup2, opendir, rmdir): Import. + +2005-02-09 Doug Rupp + + * s-tpopde-vms.adb: Add pragma Warnings (Off) for Task_Id conversions. + +2005-02-09 Robert Dewar + Thomas Quinot + Javier Miranda + Pascal Obry + Ed Schonberg + Doug Rupp + Gary Dismukes + Richard Kenner + + * g-zstspl.ads: New file. + + * a-chahan.ads, a-chahan.adb: Add declarations from AI-285 + + * a-string.ads: Add pragma Ada_05 for wide_wide_space to get warning in + Ada 95 mode + Add definition of Wide_Wide_Space for AI-285 + + * impunit.ads, impunit.adb, sem_ch10.adb: Complete rewrite and new + interface (to support Ada 95 and Ada 2005 units). + Add Unbounded_IO files + Add entries for Wide_Wide packages for AI-285 + Add list of containers packages to Ada 2005 unit list + + * a-swuwti.ads, a-swuwti.adb, a-suteio.ads, a-suteio.adb: Updates to + support new Unbounded_IO package cleanly. + + * g-utf_32.ads, g-utf_32.adb: New files. + + * Makefile.rtl: Add entry for g-utf_32 + Add new files for Unbounded_IO + Adjust make file for new AI-285 wide wide packages + Add AI-302 containers to the run time. + + * a-stwibo.adb, a-stwibo.ads, a-stwisu.adb, a-stwisu.ads, + a-strbou.ads, a-strbou.adb, a-strsup.ads, a-strsup.adb: New + subprograms for AI-301. + + * a-stwiun.adb, a-stwiun.ads: Minor reformatting. + + * a-stunau.ads: Minor comment correction + + * rtsfind.ads, rtsfind.adb: Add definitions for Wide_Wide attributes + etc. + Also extend Text_IO_Kludge to support Wide_Wide_Text_IO + (Check_RPC): Update to match changes in expanded code. + Clean up unused entity. + + * exp_ch3.ads, exp_ch3.adb: Fix various places where Wide_Wide_String + was not taken into account. + This includes proper initialization with Normalize_Scalars. + (Get_Simple_Init_Val): Major rewrite for initialize scalars and + normalize scalars cases (particularly the latter) to do a better job + of finding invalid representations. + + * s-scaval.ads, s-scaval.adb: Add values for zero invalid values + + * s-strops.ads, s-strops.adb: Remove string normalize routines, never + used + + * exp_dist.adb: Add support for wide wide character type + (Expand_Receiving_Stubs_Bodies): For a package declaration that has a + private part, generate stub bodies at the end of the private part, + not the visible part. + (Add_RACW_Primitive_Operations_And_Bodies): Add last missing code for + PolyORB support. + (Add_Obj_RPC_Receiver_Completion): Add PCS-specific subprograms and + generic wrapper to execute final processing after completing the + expansion of the RPC receiver for an RACW. + + * snames.h, snames.ads, snames.adb: Add definitions for wide_wide + packages and attributes. + (Preset_Names): Addition of the new reserved words of Ada 2005, + that is interface, overriding and synchronized. + (Get_Pragma_Id): Give support to the use of the new reserved word + "interface" as a pragma name. + (Is_Pragma_Name): Give support to the use of the new reserved word + "interface" as a pragma name. + (Preset_Names): Add stream_size string for the Stream_Size Ada2005 + attribute implementation. + + * exp_attr.adb (Expand_Attribute_Reference): Do not apply validity + checks to entities that are output parameters of Asm operations. + Handle the Stream_Size attribute. + Add implementation of Wide_Wide_Value, Wide_Wide_Image, Wide_Wide_Width + + * exp_imgv.ads, exp_imgv.adb: Add support for wide wide character type + + * sem_attr.adb (Eval_Attribute): Raise compile-time constraint error + for second parameter being 0.0. + Add support for wide wide character type. + (Analyze_Attribute, Eval_Attribute): Handle the Stream_Size attribute. + + * s-valwch.adb, s-valwch.ads, s-imgwch.ads, s-imgwch.adb, + s-wchstw.ads, s-wchstw.adb, s-wchwts.adb, s-wchwts.ads, + s-widwch.adb, s-widwch.ads, s-wwdcha.adb, s-wwdcha.ads, + s-wwdenu.adb, s-wwdenu.ads, s-wwdwch.adb, s-wwdwch.ads: Add support + for wide wide character cases. + + * cstand.adb: Create entities for Wide_Wide_Character and + Wide_Wide_String. + + * i-c.ads, i-c.adb: Fix not raising CE for null wide strings in + accordance with AI-258. + Add new declarations for 16/32 bit C character types (Part of AI285) + + * einfo.ads, einfo.adb (Is_Obsolescent, Is_Ada_2005): New flag + (Obsolescent_Warning): New field + (Rep_Clause): New local subprogram used to share code. Returns the rep + clause for which the name is given in parameter. + (Has_Stream_Size_Clause): New routine. + (Stream_Size_Clause): Idem. Implementation is based on Rep_Clause. + (Address_Clause): Implementation is now using Rep_Clause. + (Alignment_Clause): Idem. + (Size_Clause): Idem. + + * lib-xref.adb (Generate_Reference): Test for reference to Ada 2005 + entity in non-Ada 2005 mode and generate warning. + + * par-prag.adb: Add handling of one argument form for pragma Ada_05. + (Prag): Code cleanup. Remove old gnat pragma "overriding" + + * sem_prag.adb: Add handling of one argument form for pragma Ada_05 + (Analyze_Pragma, case Elaborate, Elaborate_All): Do not disable warnings + on the named unit if the pragma is not in the current compilation unit, + so that elaboration calls in the current unit can set up an elaboration + dependency on the named unit, as needed. + (Analyze_Pragma, case Obsolescent): Allow pragma to be used for library + subprogram as well as for subprograms declared within a package. + (Analyze_Pragma, Sig_Flags): Code cleanup. Remove support for the GNAT + pragma overriding. + + * krunch.ads, krunch.adb: Add special handling of Wide_Wide (krunched + to z) to avoid some instances of duplication for Wide_Wide packages. + + * namet.ads, namet.adb: Implement encoding (WWhhhhhhhh) for wide wide + characters. + + * scn.adb: Char_Literal_Value field is now a Uint + + * scng.adb: Significant rewrite to handle new Ada 2005 features + allowing wide and wide wide characters in program text, e.g. for + identifiers, as described in AI-285. + (Set_Reserved): New procedure, makes setting up keywords cleaner. + (Initialize_Scanner): Register the new reserved words of Ada 2005. + (Scan): Give support to the new reserved words. + + * par-ch2.adb (P_Identifier): Compiling in Ada95 mode, generate a + warning notifying that interface, overriding, and synchronized are + new reserved words. + (P_Pragma): Allow the use of the new reserved word "interface" as + a pragma name. + + * gnatls.adb, gnatbind.adb, + ali-util.adb, binde.adb, ali.ads, ali.adb: Code cleanup. Rename + identifiers named "interface" to "SAL_Interface". + + * bindgen.adb (Gen_Main_Ada): Add support for the new SEH + (Structured Exception handling). + (Gen_Main_C): Idem. + + * bindgen.adb: + (Gen_Main_Ada): Set the default exit code if specified. + (Gen_Main_C): Likewise. + Part of *DC20-006. + (Gen_Output_File_C): Remove redundant output of gnat_exit_status. + Code cleanup. Rename identifiers named "interface" to "SAL_Interface" + + * switch-b.adb, bindusg.adb, opt.ads, vms_data.ads: Add handling of + new -Xnnn switch. + + * mlib-prj.adb, mlib.adb: Code cleanup. Rename one identifier that + has a collision with the new Ada 2005 "interface" reserved word. + + * par-ch3.adb (P_Defining_Identifier): Compiling in Ada95 mode, + generate a warning notifying that interface, overriding, and + synchronized are new reserved words. + + * scans.ads (Token_Type): Addition of the tokens corresponding to the + new reserved words of Ada 2005: Tok_Interface, Tok_Overriding + and Tok_Synchronized. + + * sem_res.adb (Resolve_Actuals): Change error messages to refer to + "dispatching" rather than "primitive" operations, since dispatching + calls are now allowed to abstract formal subprograms (which are not + primitive). + Char_Literal_Value field is now a Uint + (Resolve_Slice): If the prefix is an access to an unconstrained array, + compute the actual subtype of the designated object to impose the proper + index constraints. + (Resolve_Selected_Component): Do not insert an access check if the + prefix is an access type: such a node is expanded into an explicit + dereference, on which the access check is performed anyway. Removes + expensive duplicate checks. + (Resolve_Call): Use new flag Is_Obsolescent and field + Obsolescent_Warning so that pragma Obsolescent works on library + subprograms. + Add support for wide wide character type + (Resolve_Allocator): Replace the error message on wrong null-exclusion + value by a warning message. + (Resolve_Type_Conversion): If the mixed-mode expression is interpreted + as fixed-point, and one of the operands is non-static and universal, it + can only be an illegal exponentiation operation, in which case there is + no real value to retrieve. + + * exp_strm.adb: Add support for wide wide character type + (Build_Elementary_Input_Call): Compute the size of the stream element by + querying the rep chain to find the Stream_Attribute attribute value. + (Build_Elementary_Write_Call): Ditto. + + * sem_aggr.adb: Char_Literal_Value field is now a Uint + Add support for wide wide character type + Replace the error messages on wrong null-exclusion value by warnings + as described in Ada 2005. + (Resolve_Extension_Aggregate): Document the fact that the error + message on class-wide expressions in extensions aggregates. + + * sem_case.adb: Add support for wide wide character type + + * sem_ch13.adb: Add support for wide wide character type + (Analyze_Attribute_Definition_Clause): Handle the Stream_Size attribute. + + * sem_ch3.adb: Add support for wide wide character type + (Process_Subtype): If constraint is illegal for the type, set Ekind of + now-useless Itype, to prevent cascaded errors on a compiler built + without -gnatp. + + * sem_ch8.adb: Add with and use of Sem_Disp. + (Analyze_Subprogram_Renaming): Replace unclean uses of + Corresponding_Spec with Corresponding_Formal_Spec (and delete setting + of Corresponding_Spec to Empty). + (Attribute_Renaming): Replace use of Corresponding_Spec with + Corresponding_ Formal_Spec and simplify condition. + (Use_One_Package): Check that scope of homonym of identifier is defined, + before checking whether it is a wrapper package. + Add support for wide wide character type + + * sem_eval.adb: Add support for wide wide character type. + (Eval_Arithmetic_Op): Check for compile time known signed integer + overflow in the non-static case. + (Subtypes_Statically_Match): A formal scalar type and its base type do + not statically match. + + * sem_util.adb (Collect_Primitive_Operations): Minor change of "/=" to + "not in" for test of N_Formal_Subprogram_Declaration (which is now a + subtype). + (Unit_Declaration_Node): Ditto. + (Is_Variable_Prefix): For the case of an indexed component whose prefix + has a packed array type, the prefix has been rewritten into a type + conversion. Determine variable-ness from the converted expression. + Handle wide wide character cases. + + * stand.ads: Add types Wide_Wide_Character and Wide_Wide_String + + * stringt.ads, stringt.adb: Handle full UTF-32 range. + Remove ["0A"] from comment, since it can look like a line terminator. + Currently we don't permit this, but this is under discussion by the + ARG, and it is easy enough to use a different example. + + * s-wchcon.ads, s-wchcnv.ads, s-wchcnv.adb: Add new subprograms for + handling UTF-32 encoding for wide wide character. + Implement new brackets coding ["hhhhhhhh"] + Add UTF-8 encodings for full UTF-32 range + + * ttypes.ads: Add definition of Standard_Wide_Wide_Character_Size + + * types.h, types.ads, types.adb: Wide_Wide_Character now has full 31 + bit range Add full UTF-32 support. + (RT_Exception_Code): Addition of CE_Null_Not_Allowed; used to + notify that constraint error will be raised at run-time + because a null value is assigned to a null-excluding object. + Remove some obsolete declarations and make Char_Code + unsigned. + + * a-except.adb (Rcheck_30): New subprogram. Addition of the message + corresponding to CE_Null_Not_Allowed, and adjust the output of all the + Rcheck subprograms. + + * checks.adb (Check_Null_Not_Allowed): Replace the error message on + wrong null-exclusion value by a warning message. + (Enable_Range_Check): Do range check if the prefix is an + explicit dereference whose designated object is an unconstrained array. + Current algorithm for removing duplicate checks is over-eager in this + case. + + * sem_ch5.adb (Analyze_Assignment): Replace the error messages on wrong + null-exclusion value by a warning message + + * atree.h, atree.ads, atree.adb: Remove Char_Code field support + completely. Add support for Uint2 field + + sem_ch2.adb, exp_ch11.adb, exp_dbug.adb, + exp_prag.adb: Char_Literal_Value field is now a Uint. + + * exp_util.adb (Insert_Actions): Replace + N_Formal_Subprogram_Declaration by + N_Formal_{Abstract|Concrete}_Subprogram_Declaration. + Char_Literal_Value field is now a Uint. + + * sinfo.ads, sinfo.adb (Corresponding_Formal_Spec): New function + defined for subprogram renaming declarations. When set, the field + indicates the defining entity of a corresponding formal subprogram + when the renaming corresponds to a formal subprogram association in an + instantiation. + (Set_Corresponding_Formal_Spec): New procedure to return + Corresponding_Formal_Spec field. + Minor changes of "=" to "in" in tests of N_Formal_Subprogram_Declaration + (which is now a subtype). + Char_Literal_Value field is now a Uint + + * exp_disp.ads, exp_disp.adb (Make_DT): Generate code that moves the + pointer to the base of the dispatch table. + Minor changes to comments. + (Controlling_Type): New function for determining the tagged type + associated with a tagged primitive subprogram. + (Expand_Dispatching_Call): Add support for a controlling actual that is + directly a value of type Ada.Tag rather than a tagged object. + + * i-cpp.ads, i-cpp.adb, a-tags.ads, a-tags.adb: Update documentation + describing the new layout. + (Dispatch_Table): The expander computes the actual array size, allocates + the Dispatch_Table record accordingly, and generates code that displaces + the base of the record after the Typeinfo_Ptr component. The access to + these components is done by means of local functions. + (Offset_To_Top): New function. + (Typeinfo_Ptr): New function. + (Get_TSD): Modified to access the new position of the TSD. + (Set_TSD): Modified to save the TSD in its new position. + + * par-ch12.adb (P_Formal_Subprogram_Declaration): Add parsing for the + case of formal abstract subprograms. Add check and message for -gnat05. + Update comments. + + * sem_ch12.adb: Add with and use for Sem_Disp. + (Analyze_Associations): Minor change from "=" to "in" for use of + N_Formal_Subtype_Declaration (which is now a subtype). + (Set_Analyzed_Formal): Minor changes from "=" to "in" for uses of + N_Formal_Subtype_Declaration (which is now a subtype). + (Analyze_Formal_Subprogram): Add handling for + N_Formal_Abstract_Subprogram, marking the formal as abstract and + dispatching, setting the controlling status of the formal parameters + and result, and issuing an error if there is no controlling type for + the formal subprogram. + (Instantiate_Formal_Subprogram): Rather than setting Corresponding_Spec, + which is an unclean use of that field, we set the new field + Corresponding_Formal_Spec to make the formal subprogram available to + processing in Analyze_Subprogram_Declaration. + (Analyze_Formal_{Discrete, Decimal_Fixed_Point, Fixed_Point, + Floating_Point, Modular_Integer, Signed_Integer}_Type: Make formal type + Constrained, so that it is is does not statically match its anonymous + base type. + + * sem_ch6.adb (Analyze_Subprogram_Specification): Include test for + abstract formal subprograms in error check for functions returning + abstract types. Set scope of new designator for + a parameterless subprogram, so that it is available when checking the + body for nested subprograms, before full analysis of said body. + (Analyze_Subprogram_Body): Warn on inlining bodies with nested + subprogram only if inner one comes from source. + (Analyze_Function_Call): If the call is given in object notation, the + analysis of the name rewrites the node and analyzes it with the proper + argument list. After analyzing the name, if the call has been rewritten + and the result type is set, no further analysis is needed. + (Analyze_Return_Type): Subsidiary to Process_Formals: analyze subtype + mark in function specification, in a context where the formals are + visible and hide outer homographs. + + * sem_disp.adb (Check_Controlling_Type): Relax the check for same scope + as the tagged type for the cases of abstract formal subprograms and + renamings of those. Clean up spec comments. + (Check_Dispatching_Context): Add error message to indicate "abstract + procedure", covering the case of a call to a formal abstract procedure + that has statically tagged operands. + (Check_Dispatching_Call): Check for the case of an actual given by + a tag-indeterminate function call whose type is an ancestor of the + containing call's associated tagged type. This situation can occur + for inherited primitives with function defaults. In this case we + use the tagged type's tag directly as the controlling argument for + the calls. + (Expand_Call): Name change on call to Expand_Dispatch_Call. + + * sprint.adb (Sprint_Node_Actual): Split + N_Formal_Subprogram_Declaration into two alternatives for the new + cases N_Formal_Abstract_Subprogram_Declaration and + N_Formal_Concrete_Subprogram_Declaration. + Char_Literal_Value field is now a Uint. + + * trans.c: Get rid of junk Uint2 reference. + Char_Literal_Value field is now a Uint. + (gnat_to_gnu, case N_Aggregate): Check TYPE_UNCHECKED_UNION_P. + (gigi): Correct third arg to gimplify_body. + + * ada-tree.h: (TYPE_UNCHECKED_UNION_P): New flag. + (TYPE_LANG_FLAG_0): Check for record or union. + + * treepr.adb: Char_Literal_Value field is now a Uint + + * uintp.h, uintp.ads, uintp.adb: Add new routines UI_To_CC and + UI_From_CC. + + * widechar.ads, widechar.adb (Is_UTF_32_Non_Graphic): New function + Add full UTF-32 support + Char_Code is now 32 bits + + * sinput.ads, sinput.adb (Skip_Line_Terminators): Extend to deal with + wide character UTF_32 line terminators. + Initialize Main_Source_File to avoid error when no main + source is loaded. + + * errout.adb (Finalize): Do not check Num_SRef_Pragmas + (Main_Source_File) when no main source has been loaded, to avoid + potential crash. + +2005-02-09 Robert Dewar + + * a-strunb.ads, a-strunb.adb: Add missing pragma Ada_05 statements + Fix name of Set routine + + * a-strfix.ads, a-strfix.adb: Add new index functions from AI-301 to + fixed packages. + + * a-stwise.ads, a-stwise.adb, a-stwifi.ads, a-stwifi.adb, + a-strsea.ads, a-strsea.adb: Add new index functions from AI-301 to + fixed packages + + * a-witeio.ads, a-witeio.adb, a-textio.ads, a-textio.adb: New function + forms of Get_Line subprograms for AI-301. + + * a-wtcoau.adb, a-wtcoau.ads, a-wtcoio.adb, a-wtcoio.ads, + a-wtedit.adb, a-wtedit.adb, a-wtedit.ads, a-wttest.adb, + a-wttest.ads, a-strmap.ads, a-strmap.adb, a-stwima.adb, + a-stwima.ads: Minor reformatting. + +2005-02-09 Doug Rupp + Thomas Quinot + + * adaint.c, adaint.h + [VMS] (to_ptr32): New function. + (MAYBE_TO_PTR32): New macro. + (__gnat_portable_spawn,__gnat_portable_no_block_spawn): Adjust argv + for pointer size. + [VMS] (descriptor_s, ile_s): Use __char_ptr32 for adr field. + [VMS] (#define fork()): Remove since unneccessary. + (__gnat_set_close_on_exec): New routine to support + GNAT.OS_Lib.Set_Close_On_Exec. + + * g-expect.adb (Set_Up_Communications): Mark the pipe descriptors for + the parent side as close-on-exec so that they are not inherited by the + child. + + * g-os_lib.ads, g-os_lib.adb (Set_Close_On_Exec): New subprogram to + set or clear the FD_CLOEXEC flag on a file descriptor. + +2005-02-09 Eric Botcazou + Richard Kenner + + PR ada/19386 + * decl.c: + (gnat_to_gnu_field): Do not necessarily invoke make_packable_type + on the field if Pragma Component_Alignment (Storage_Unit). + (gnat_to_gnu_entity, case object): Do not treat a renaming that has + side-effects as if it were a constant; also make SAVE_EXPR to protect + side-effects. + (gnat_to_gnu_entity, case E_Record_Subtype): If have _Parent, make a + UNION_TYPE. + (make_dummy_type): Set TYPE_UNCHECKED_UNION_P. + (components_to_record): Test it. + Fix improper usage of REFERENCE_CLASS_P. + + * utils2.c (build_binary_op, case MODIFY_EXPRP): Treat UNION_TYPE as + RECORD_TYPE. + + * utils2.c: Minor reformatting. + + * utils.c (convert, case UNION_TYPE): Check TYPE_UNCHECKED_UNION; + handle other cases like RECORD_TYPE. + + * utils.c (gnat_pushdecl): Set TREE_NO_WARNING. + +2005-02-09 Ed Schonberg + + * exp_aggr.adb (Gen_Assign): If the expression is an aggregate for a + component of an array of arrays in an assignment context, and the + aggregate has component associations that require sliding on + assignment, force reanalysis of the aggregate to generate a temporary + before the assignment. + (Must_Slide): Make global to the package, for use in Gen_Assign. + +2005-02-09 Ed Schonberg + + * exp_ch4.adb (Expand_Composite_Equality): If a component is an + unchecked union with no inferable discriminants, return a + Raise_Program_Error node, rather than inserting it at the point the + type is frozen. + (Expand_Record_Equality, Component_Equality): Handle properly the case + where some subcomponent is an unchecked union whose generated equality + code raises program error. + +2005-02-09 Doug Rupp + + * gnatbl.c: [VMS] (_POSIX_EXIT): Define. + [VMS] (#define exit hack): Remove. + +2005-02-09 Pascal Obry + Arnaud Charlet + + * init.c (__gnat_initialize): Add a new parameter eh which contains the + address of the exception registration. The Win32 version of this + routine calls __gnat_install_SEH_handler() to initialize the SEH + (Structured Exception Handling) handler. + (__gnat_error_handler) [Win32]: Removed. Not needed as we use + SEH (Structured Exception Handling) now. + (__gnat_install_handler) [Win32]: Nothing to do now as we use SEH. + (__gnat_initialize for ppc-vxworks): Adjust comments and the + preprocessor condition protecting the call to the extra eh setup + subprogram, which is only available for the ppc target. + (__gnat_clear_exception_count): replaced reference to + variable taskIdCurrent by call to taskIdSelf(), cleaner. + + * seh_init.c: New file. + + * Make-lang.in: (GNAT_ADA_OBJS): Add seh_init.o. + (GNATBIND_OBJS): Idem. + + * misc.c (gnat_parse_file): Update call to __gnat_initialize. This + routine takes a new parameter (a pointer to the exception registration + for the SEH (Structured Exception Handling) support. + + * raise.h: (__gnat_install_SEH_handler): New prototype. + Update copyright notice. + + * s-tassta.adb (Task_Wrapper): Declare the exception registration + record and initialize it by calling __gnat_install_SEH_handler. + +2005-02-09 Vincent Celier + + * make.adb (Gnatmake): Do not fail when the main project has no object + directory. + +2005-02-09 Doug Rupp + + * Makefile.in [VMS] (LN,LN_S): Define as cp -p + Rename s-asthan-vms.adb to s-asthan-vms-alpha.adb. + [VMS]: Add translations for g-enblsp.adb. + + * s-asthan-vms.adb: Removed. + * s-asthan-vms-alpha.adb: Added. + +2005-02-09 Pascal Obry + + * Makefile.in (LIBGNAT_SRCS): Add seh_init.c. + (LIBGNAT_OBJS): Add seh_init.o. + +2005-02-09 Arnaud Charlet + + PR ada/16592 + * Makefile.in: Link all gnat tools with -static-libgcc, since + -shared-libgcc is now used by default on some systems (e.g. linux with + recent binutils). + Remove references to Makefile.prolog/generic, no longer used. + +2005-02-09 Vincent Celier + + * prj-makr.adb (Process_Directory): Put file name in canonical case + before matching against the patterns. + If gnatname has been invoked as -gnatname + then invoke the compiler as -gcc, not just "gcc". + +2005-02-09 Ed Schonberg + + * sem_ch4.adb (Analyze_Selected_Component): Create Actual_Subtype even + with expansion disabled. The actual subtype is needed among other + places when the selected component appears in the context of a loop + bound, and denotes a packed array. + (Operator_Check): Always use the first subtype in the + error message, to avoid the appearance of internal base types. + (Transform_Object_Operation): Copy each actual in full + to the parameter associations of the constructed call, rather than + using the shallow copy mechanism of New_Copy_List. This ensures that + the chaining of named associations is done properly. + (Complete_Object_Operation): Rewrite node, rather than + replacing it, so that we can trace back to the original selected + component. + + * sem_elab.adb (Set_Elaboration_Constraint): For initialization calls, + and calls that use object notation, if the called function is not + declared in a withed unit, place the elaboration constraint on the + unit in the context that makes the function accessible. + (Check_Elab_Subtype_Declaration): Check whether a subtype declaration + imposes an elaboration constraint between two packages. + +2005-02-09 Ed Schonberg + + * sem_ch7.adb (Uninstall_Declarations): Exchange full and private + views of a private type after handling its private dependents, to + maintain proper stack discipline between entry and exit from the + package. + +2005-02-09 Cyrille Comar + + * s-finimp.adb: (Finalize_List): Optimize in the no-abort case. + Minor reformatting. + +2005-02-09 Arnaud Charlet + + * s-tporft.adb (Register_Foreign_Thread): Initialize Task_Image[_Len] + fields for foreign threads. + +2005-02-09 Doug Rupp + + * s-vaflop.adb: Add pragma Warnings (Off) to eliminate infinite + recursion warnings when compiled with -gnatdm. + +2005-02-09 Robert Dewar + + * usage.adb: Add line for switch -gnat05 (allow Ada 2005 extensions) + Slight fix to documentation of -gnaty with no parameters + + * xr_tabls.ads: Add ??? comment for missing overall comment + + * xsinfo.adb: Make default file name be sinfo.h, since this is what + we now use by default. + + * xsnames.adb: Adjust end of file test to look for five space followed + by '#' instead of six spaces. The format of xsnames.adb was modified + in the last update. + + * a-numeri.ads: Add reference to AI-388 for greek letter pi + identifier. + + * clean.adb: Minor reformatting. + + * gnat1drv.adb, gnatfind.adb, gnatlink.adb, gnatmem.adb, + gnatname.adb: Minor reformatting + Add 2005 to copyright output when utility is run + + * csets.adb: Eliminate obsolete comment + + * debug.adb, g-socket.ads, i-cobol.adb: Minor reformatting throughout + Update comments. + + * sem_eval.ads (Eval_Integer_Literal): Do not inline this, not useful. + +2005-02-09 Sergey Rybin + + * gnat_ugn.texi: Add to the gnatpp section the paragraph describing + the difference between compact and incompact layout and add the record + representation clause to the example illustrating different layouts. + Add the description of '-A5' gnatpp option ("align 'AT' keywords in + component clauses"). + +2005-02-09 Florian Villoing + + * gnat_ugn.texi: Fix typos. + Use @command to display 'gcc', 'gnatbind', etc. insted of @code or + @file. + Make proper use of @ref, @xref and @pxref to avoid duplication of "see" + in the generated documentation. + +2005-02-09 Arnaud Charlet + + * gnat_ugn.texi: Remove all mentions of FSU threads, which are no + longer supported. + Update linker wrapper when linking with non GNU C++. + +2005-02-09 Pascal Obry + + * gnat_ugn.texi: + Document the procedure to debug the DllMain routine on Windows. + Add note about -funwind-tables and mixed Ada and C/C++ programming in + ZCX mode. + Document new BIND qualifer /RETURN_CODES=VMS. + +2005-02-09 Ben Brosgol + + * gnat_ugn.texi: Wordsmithing of "GNAT and Libraries" chapter + Edited gnatmetric chapter + +2005-02-09 Robert Dewar + + * gnat_rm.texi: + Changes to document new wide wide character support + For AI-285 + Update documentation on Normalize_Scalars and Initialize_Scalars + +2005-02-09 Pascal Obry + + * s-taprop-mingw.adb, s-soflin.ads: Minor reformatting. + +2005-02-09 Jose Ruiz + + * s-osinte-vxworks.ads (taskPriorityGet): Add this function (imported + from the VxWorks kernel) that is needed for getting the active + priority of the different tasks. + + * s-atacco.ads, s-atacco.adb (Nothing): Remove this dummy procedure. + Use a pragma Elaborate_Body in the spec file instead. + Noticed by code reading. + +2005-02-09 Thomas Quinot + + * exp_util.ads: Minor correction in comment. + +2005-02-09 Arnaud Charlet + + * s-taprop.ads (Initialize): Update comments. Remove pragma Inline, + since this procedure is now too complex to be worth inlining. + +2005-02-09 Richard Henderson + + * utils.c (gnat_define_builtin): Remove. + (gnat_install_builtins): Use build_common_builtin_nodes. + +2005-02-09 Arnaud Charlet + + * a-rbtgso.adb, a-crbtgo.ads, a-crbtgo.adb, a-crbtgk.ads, + a-crbtgk.adb, a-crbltr.ads, a-coprnu.ads, a-coprnu.adb, + a-coorse.ads, a-coorse.adb, a-convec.ads, a-convec.adb, + a-contai.ads, a-coinve.ads, a-coinve.adb, a-cohata.ads, + a-cohama.ads, a-cohama.adb, a-ciorse.ads, a-ciorse.adb, + a-cihama.ads, a-cihama.adb, a-cidlli.ads, a-cidlli.adb, + a-chtgop.ads, a-chtgop.adb, a-cgcaso.ads, a-cgcaso.adb, + a-cgarso.ads, a-cgarso.adb, a-cdlili.ads, a-cdlili.adb, + a-cgaaso.adb, a-coormu.adb, a-ciormu.adb, a-cihase.adb, + a-cihase.ads, a-cohase.adb, a-cohase.ads, a-ciorma.ads, + a-coorma.ads, a-swunha.ads, a-stunha.ads, a-ciormu.ads, + a-coormu.ads, a-rbtgso.ads, a-swunha.adb, a-stunha.adb, + a-cgaaso.ads, a-ciorma.adb, a-coorma.adb, a-secain.adb, + a-secain.ads, a-slcain.ads, a-slcain.adb, a-shcain.ads, + a-shcain.adb, a-chtgke.ads, a-chtgke.adb, a-stwiha.ads, + a-stwiha.adb, a-strhas.ads, a-strhas.adb, a-chzla1.ads, + a-chzla9.ads, a-lfztio.ads, a-liztio.ads, a-llfzti.ads, + a-llizti.ads, a-sfztio.ads, a-siztio.ads, a-ssizti.ads, + a-stzbou.adb, a-stzbou.ads, a-stzfix.adb, a-stzfix.ads, + a-stzhas.adb, a-stzhas.ads, a-stzmap.adb, a-stzmap.ads, + a-stzsea.adb, a-stzsea.ads, a-stzsup.adb, a-stzsup.ads, + a-stzunb.adb, a-stzunb.ads, a-swunau.adb, a-swunau.ads, + a-szmzco.ads, a-szunau.adb, a-szunau.ads, a-szunha.adb, + a-szunha.ads, a-szuzti.adb, a-szuzti.ads, a-tiunio.ads, + a-wwunio.ads, a-ztcoau.adb, a-ztcoau.ads, a-ztcoio.adb, + a-ztcoio.ads, a-ztcstr.adb, a-ztcstr.ads, a-ztdeau.adb, + a-ztdeau.ads, a-ztdeio.adb, a-ztdeio.ads, a-ztedit.adb, + a-ztedit.ads, a-ztenau.adb, a-ztenau.ads, a-ztenio.adb, + a-ztenio.ads, a-ztexio.adb, a-ztexio.ads, a-ztfiio.adb, + a-ztfiio.ads, a-ztflau.adb, a-ztflau.ads, a-ztflio.adb, + a-ztflio.ads, a-ztgeau.adb, a-ztgeau.ads, a-ztinau.adb, + a-ztinau.ads, a-ztinio.adb, a-ztinio.ads, a-ztmoau.adb, + a-ztmoau.ads, a-ztmoio.adb, a-ztmoio.ads, a-zttest.adb, + a-zttest.ads, a-zzunio.ads: New files. Part of new Ada 2005 + library. + +2005-01-27 Laurent Guerby + + * Makefile.in: Fix a-intnam.ads from previous commit, + add 2005 to copyright. + * a-intman-rtems.ads: Renamed to... + * a-intnam-rtems.ads: + +2005-01-27 Laurent Guerby + + * Makefile.in: Rename GNAT RTEMS specific files. + * 5rtpopsp.adb, 4rintnam.ads, 5rosinte.adb, + 5rosinte.ads, 5rparame.adb: Replaced by files below. + * s-tpopsp-rtems.adb, a-intman-rtems.ads, s-osinte-rtems.adb, + s-osinte-rtems.ads, s-parame-rtems.adb: Replace files above. + +2005-01-27 Joel Sherrill + Laurent Guerby + + PR ada/19488 + * 5rosinte.ads: Add No_Key constant. + * 5rtpopsp.adb: Initialize ATCB_Key with No_Key and fix style. + * gsocket.h: Do not include with RTEMS either. + +2005-01-26 Laurent Guerby + + PR ada/19414 + * i-cobol.adb (Valid_Numeric): Handle zero length case. + +2005-01-20 Richard Henderson + + * Makefile.in (alpha-linux, LIBGNAT_TARGET_PAIRS): Use + a-intnam-linux.ads and system-linux-alpha.ads. + * a-intnam-linux-alpha.ads: Remove file. + * s-osinte-linux-alpha.ads (SIGUNUSED, SIGSTKFLT, SIGLOST): New. + * system-linux-alpha.ads: New file. + +2005-01-18 Jakub Jelinek + + PR ada/13470 + * a-stunau.adb (Get_String): Don't return U.Reference, but Ret that is + set to the new string. + +2005-01-18 Toon Moene + + * system-linux-ppc.ads: Set ZCX_By_Default and GCC_ZCX_Support + to True. + +2005-01-18 Richard Henderson + + * Makefile.in (LIBGNAT_TARGET_PAIRS, TOOLS_TARGET_PAIRS, MISCLIB, + THREADSLIB, GNATLIB_SHARED, PREFIX_OBJS, LIBRARY_VERSION): Specialize + for alpha-linux. + * s-osinte-linux-alpha.ads, a-intnam-linux-alpha.ads: New files. + +2005-01-14 Andrew Pinski + + * system-darwin-ppc.ads (ZCX_By_Default): Change to True. + (GCC_ZCX_Support): Likewise. + +2005-01-11 Bastian Blank + + * system-linux-s390.ads: Define Preallocated_Stacks. + * system-linux-s390x.ads: Likewise. + +2005-01-04 Arnaud Charlet + + * gnat_ugn.texi: Fix texi errors with null variables. + +2005-01-03 Thomas Quinot + + * gen-soccon.c: New utility program to generate g-soccon.ads + automatically. + + * socket.c, gsocket.h: Split inclusion of system header files into a + gsocket.h file separated from socket.c, to allow reuse in gen-soccon.c. + + * g-soccon.ads, g-soccon-unixware.ads, g-soccon-tru64.ads, + g-soccon-aix.ads, g-soccon-irix.ads, g-soccon-hpux.ads, + g-soccon-interix.ads, g-soccon-solaris.ads, g-soccon-mingw.ads, + g-soccon-vxworks.ads, g-soccon-freebsd.ads: Note that these files + should not be edited by hand anymore, but should be regenerated using + gen-soccon. + +2005-01-03 Robert Dewar + Ed Schonberg + Vincent Celier + + * s-atacco.ads, a-direio.adb: Protect use of 'Constrained by warnings + on/off, since this is an obsolescent feature, for which we now generate + a warning. + + * sem_attr.adb (Analyze_Attribute, case Constrained): Issue warning if + warning mode is set and obsolescent usage of this attribute occurs. + (Resolve_Access, case 'Access): Note that GNAT uses the context type to + disambiguate overloaded prefixes, in accordance with AI-235. GNAT code + predates, and partly motivates, the adoption of the AI. + Implement new Ada 2005 attribute Mod + + * exp_attr.adb (Expand_N_Attribute_Reference): Implement Ada 2005 + attribute Mod. + + * par-ch4.adb (P_Name): In Ada 2005 mode, recognize new attribute Mod + + * snames.h, snames.ads, snames.adb: Add entry for No_Dependence for + pragma restrictions. + New entry for Ada 2005 attribute Mod. + + * par-prag.adb: + Add recognition of new pragma Restrictions No_Dependence + Recognize restriction No_Obsolescent_Features at parse time + + * bcheck.adb: Add circuitry for checking for consistency of + No_Dependence restrictions. + + * lib-writ.ads, lib-writ.adb: Output new R lines for No_Dependence + restrictions. + + * restrict.ads, restrict.adb: Add subprograms to deal with + No_Dependence restrictions. + + * rtsfind.adb: Check that implicit with's do not violate No_Dependence + restrictions. + + * sem_ch3.adb, sem_ch11.adb, sem_ch13.adb, lib-xref.adb, + sem_attr.adb: Add check for new restriction No_Obsolescent_Features + + * scn.ads, prj-err.ads, prj-err.adb, ali-util.adb, gprep.adb: Add new + dummy parameter to scng instantiation. + Needed for new restriction No_Obsolescent_Features + + * scn.adb: (Obsolescent_Check): New procedure + Needed for new restriction No_Obsolescent_Features + + * scng.ads, scng.adb: Always allow wide characters in Ada 2005 mode, as + specified by AI-285, needed for implementation of AI-388 (adding greek + pi to Ada.Numerics). + Add new generic formal to scng, needed for new restriction + No_Obsolescent_Features. + + * s-rident.ads: Add new restriction No_Obsolescent_Features. + + * ali.ads, ali.adb: Adjustments for reading new No_Dependence + restrictions lines. + (Scan_ALI): When finding an unexpected character on an R line, raise + exception Bad_R_Line, instead of calling Fatal_Error, so that, when + Ignore_Errors is True, default restrictions are set and scanning of the + ALI file continues with the next line. Also, when Bad_R_Line is raised + and Ignore_Errors is True, skip to the end of le line. + + * sem_ch10.adb: Check that explicit with's do not violate + No_Dependence restrictions. + (Install_Withed_Unit): Add code to implement AI-377 and diagnose + illegal context clauses containing child units of instance. + + * sem_prag.adb: Processing and checking for new No_Dependence + restrictions. + (Analyze_Pragma, case Psect_Object): Call Check_Arg_Is_External_Name to + analyze and check the External argument. + + * a-numeri.ads: Add greek letter pi as alternative spelling of Pi + +2005-01-03 Robert Dewar + + * atree.adb: Add a fifth component to entities + This allows us to add 32 flags and four new fields + + * atree.ads: Add a fifth component to entities + This allows us to add 32 flags and four new fields + + * einfo.ads, einfo.adb: Document new fields and new flags now available + Add routines for printing new fields + + * treepr.adb: Call routines to print out additional fields if present + +2005-01-03 Arnaud Charlet + + * bld.ads, bld.adb, bld-io.ads, bld-io.adb, gprcmd.adb, + gpr2make.ads, gpr2make.adb: Remove gpr2make, replaced by gprmake. + + * Makefile.in: Add support to build shared Ada libraries on solaris x86 + Remove gpr2make, replaced by gprmake. + Remove references to gnatmem and libaddr2line. + Add indepsw.adb + + * checks.adb (Apply_Alignment_Check): Generate a warning if an object + address is incompatible with its base type alignment constraints when + this can be decided statically. + +2005-01-03 Olivier Hainque + + * decl.c (compatible_signatures_p): New function. The intended purpose + is to check if two function signatures for a call-site and a callee are + compatible enough for the call to be valid. The underlying purpose is + to check if a call to a mapped builtin is using the right interface. + The current code actually does not check antyhing - this a placeholder + for future refinements. + (gnat_to_gnu_entity) : Add preliminary bits to handle + builtin calls for convention Intrinsic. + + * gigi.h (builtin_decl_for): Declare (new function). + + * utils.c (gnat_install_builtins): Install the target specific builtins. + (builtin_decl_for): New function, provide a dummy body for now. + +2005-01-03 Geert Bosch + + * eval_fat.adb: (Eps_Model,Eps_Denorm): Remove, no longer used. + (Succ): Re-implement using Scaling, Exponent and Ceiling attributes. + (Pred): Implement in terms of Succ. + + * trans.c (convert_with_check): Reimplement conversion of float to + integer. + +2005-01-03 Ed Schonberg + Vincent Celier + + * exp_aggr.adb (Packed_Array_Aggregate_Handled): The values of the + bounds can be negative, and must be declared Int, not Nat. + + * sem_elim.adb (Line_Num_Match): Correct wrong code when index in an + array is checked after using the index in the array. + + * makegpr.adb (Add_Switches): Check if there is a package for the + processor. If there is no package, do not look for switches. + +2005-01-03 Ed Schonberg + + * exp_ch3.adb (Stream_Operations_OK): Predicate to determine when the + generation of predefined stream operations (specs and bodies) should + proceed. Under various restrictions these subprograms must not be + generated. + +2005-01-03 Thomas Quinot + + * exp_dist.adb: + Declare subprogram index in Build_RPC_Receiver_Body, to reduce the + amount of PCS-specific code in RACW stubs generation. + (Copy_Specification): Set Etype on copied formal parameter entities, as + this information is needed for PolyORB stubs generation. + (PolyORB_Support.Build_Subprogram_Receiving_Stubs): Remove unused + variable Dynamic_Async. + (Build_Subprogram_Receiving_Stubs): Make PCS-specific + (Build_RPC_Receiver_Specification): Make generic again, as recent + changes have allowed RPC receivers to have the same profile for both + variants of the PCS. + Reorganise RPC receiver generation to reduce differences between the + structure of GARLIC and PolyORB RPC receivers. + (Add_Receiving_Stubs_To_Declarations): Make this subprogram + PCS-specific. + Simplify elaboration code for RCI packages. + + * s-parint.ads, s-parint.adb, rtsfind.ads: Reorganise RPC receiver + generation to reduce differences between the structure of GARLIC and + PolyORB RPC receivers. + + * s-stratt.adb: Fix typo in comment. + +2005-01-03 Thomas Quinot + + * exp_ch7.ads (Make_Final_Call): Rewrite comment (was incorrectly + copied from Make_Init_Call). + + * exp_strm.adb (Build_Mutable_Record_Read_Procedure): Do component + reads and assignments on a temporary variable declared with appropriate + discriminants. + +2005-01-03 Robert Dewar + + * i-c.adb (To_C): Raise CE if string is null and Append_Null + +2005-01-03 Robert Dewar + + * i-cstrin.adb (Update): Do not append a null in form called with a + String. This avoids unintended behavior. + +2005-01-03 Arnaud Charlet + + PR ada/17527 + * init.c: Fix warnings on Free BSD section. + +2005-01-03 Arnaud Charlet + + PR ada/16949 + * sinfo.ads: Fix obsolete reference to xsinfo.spt (replaced by + xsinfo.adb). + +2005-01-03 Vincent Celier + + * make.adb (Collect_Arguments_And_Compile): Do not attempt to build + libraries when Unique_Compile is True (-u switch). + (Gnatmake): ditto. + +2005-01-03 Robert Dewar + + * namet.adb (Get_Decoded_Name_With_Brackets): Fix case of not allowing + upper case letter or underscore after W, as allowed by spec. + +2005-01-03 Arnaud Charlet + + * s-osinte-darwin.ads, s-osinte-darwin.adb: Clean up + darwin port by using proper type definitions from header files. + Use SIGTERM instead of SIGABRT for SIGADAABORT. + +2005-01-03 Robert Dewar + + * par.adb: Enhance error message handling for configuration file + pragmas. + +2005-01-03 Robert Dewar + + * s-arit64.adb (Double_Divide): Put back changes that got accidentally + removed during the previous update (test properly for case of dividing + largest negative number by -1, which generates overflow). + +2005-01-03 Ed Schonberg + Sergey Rybin + + * sem_ch12.adb (Analyze_Package_Instantiation): Create a separate node + to use as the defining identifier for a formal package. + (Remove_Parent): If the instance takes place within (an instance of) + a sibling, preserve private declarations of common parent. + +2005-01-03 Ed Schonberg + + * sem_ch4.adb (Has_Fixed_Op): New predicate in Check_Arithmetic_Pair, + to determine whether one of the operands is a fixed-point type for + which a user-defined multiplication or division operation might be + defined. + + * sem_res.adb (Valid_Conversion): The legality rules for conversions + of access types are symmetric in Ada 2005: either designated type can + be unconstrained. + +2005-01-03 Vincent Celier + + * s-fileio.adb (Temp_File_Record): Change length of string component + Name from L_tmpnam + 1 to max_path_len + 1. + +2005-01-03 Arnaud Charlet + + * s-tasini.ads, s-tasini.adb (Undefer_Abortion): Handle case of + Self_Id.Deferral_Level = 0. + (Do_Pending_Action): Move this function to the spec. + + * s-tasren.adb (Selective_Wait [Terminate_Selected]): Call + Do_Pending_Action explicitely when needed, in case we're using + No_Abort restrictions. + + * s-tassta.adb (Create_Task): If Abort is not allowed, reset the + deferral level since it will not get changed by the generated code. + Keeping a default value of 1 would prevent some operations (e.g. + select or delay) to proceed successfully. + +2005-01-03 Ben Brosgol + Robert Dewar + Cyrille Comar + + * ug_words, gnat_ugn.texi: Added alpha-ivms transitioning section to + porting guide chapter (vms version). + Revised doc title (removed "for native platforms") and subtitle. + Add discussion on warning flag for obsolescent features. First we + note that it applies to obsolete GNAT features, which was previously + omitted. Second we contrast the behavior with that of the new + Ada 2005 AI-368 restriction No_Obsolescent_Features. + Preliminary rewriting of GNAT & libraries chapter in order to take + into account default project locations & new project manager + capabilities. + +2005-01-03 Robert Dewar + + * cstand.adb (Create_Operators): Clean up format and documentation of + unary and binary operator result tables. No change in code, just + reformatting and addition of comments. + + * errout.ads, gnatfind.adb, s-maccod.ads, sem.adb, + sem_ch2.adb: Minor reformatting + + * atree.ads, elists.ads, lib.ads, namet.ads, nlists.ads, repinfo.ads, + sinput.ads, stringt.ads, uintp.ads, urealp.ads: Minor clarification to + comments for Tree_Read and Tree_Write. + +2005-01-03 Pascal Obry + + * exp_attr.ads: Minor reformatting. + +2005-01-03 Romain Berrendonner + + * comperr.adb (Compiler_Abort): Add specialized message for GAP + versions. + +2005-01-03 Ed Schonberg + + * exp_pakd.adb (Create_Packed_Array_Type): Add a guard to check + whether the ancestor type is private, as may be the case with nested + instantiations. + + + +Copyright (C) 2005 Free Software Foundation, Inc. + +Copying and distribution of this file, with or without modification, +are permitted in any medium without royalty provided the copyright +notice and this notice are preserved. diff --git a/gcc/ada/ChangeLog-2006 b/gcc/ada/ChangeLog-2006 new file mode 100644 index 000000000..b43e0106f --- /dev/null +++ b/gcc/ada/ChangeLog-2006 @@ -0,0 +1,4462 @@ +2006-12-07 Geoffrey Keating + + * Makefile.in: Replace CROSS_COMPILE with CROSS_DIRECTORY_STRUCTURE. + * adaint.c: Likewise. + +2006-12-05 Aldy Hernandez + + Merge from gimple-tuples-branch: + 2006-11-02 Aldy Hernandez + + * ada-tree.h (lang_tree_node): Handle gimple tuples. + * trans.c (gnat_gimplify_expr): Replace MODIFY_EXPR with + GIMPLE_MODIFY_STMT. + +2006-12-02 Kazu Hirata + + * Makefile.in, mingw32.h, trans.c: Fix comment typos. + * gnat_rm.texi, gnat_ugn.texi: Follow spelling conventions. + Fix typos. + +2006-11-17 Eric Botcazou + + PR ada/27936 + * trans.c (add_decl_expr): Do not dynamically elaborate padded objects + if the initializer takes into account the padding. + +2006-11-11 Richard Guenther + + * trans.c (maybe_stabilize_reference): Remove handling of + FIX_CEIL_EXPR, FIX_FLOOR_EXPR and FIX_ROUND_EXPR. + +2006-11-05 Arnaud Charlet + + PR ada/29707 + * s-osinte-linux-alpha.ads, s-osinte-linux-hppa.ads + (To_Target_Priority): New function. + +2006-10-31 Robert Dewar + + * a-taster.adb, s-traent-vms.adb, a-elchha.ads, a-elchha.adb, + a-exctra.adb, ali-util.adb, exp_disp.ads, s-stalib.ads, s-traent.adb, + s-addope.ads, s-addope.adb, a-rbtgso.adb, a-crbltr.ads, a-coprnu.adb, + a-cgcaso.adb, a-cgarso.adb, a-cgaaso.adb, a-coormu.adb, a-ciormu.adb, + a-rbtgso.ads, a-stunha.adb, a-stunha.adb, a-ciorma.adb, a-coorma.adb, + a-secain.adb, a-slcain.adb, a-shcain.adb, a-stwiha.adb, a-stwiha.adb, + a-strhas.adb, a-strhas.adb, a-stzhas.adb, a-stzhas.adb, a-szuzha.adb, + a-chacon.adb, a-chacon.adb, a-chacon.ads, a-stboha.adb, a-swbwha.adb, + a-szbzha.adb: Minor reformatting. Fix header. + + * a-numaux-x86.adb: Add parentheses for use of unary minus + * a-ngcefu.adb: Supply missing parentheses for unary minus + * a-ngcoty.adb: Add parens for use of unary minus + * a-ngelfu.adb: Add missing parens for unary minus + * a-tifiio.adb: Add parentheses for uses of unary minus + +2006-10-31 Robert Dewar + Bob Duff + Ed Schonberg + + * sem_res.adb (Resolve_Unary_Op): Add warning for use of unary minus + with multiplying operator. + (Expected_Type_Is_Any_Real): New function to determine from the Parent + pointer whether the context expects "any real type". + (Resolve_Arithmetic_Op): Do not give an error on calls to the + universal_fixed "*" and "/" operators when they are used in a context + that expects any real type. Also set the type of the node to + Universal_Real in this case, because downstream processing requires it + (mainly static expression evaluation). + Reword some continuation messages + Add some \\ sequences to continuation messages + (Resolve_Call): Refine infinite recursion case. The test has been + sharpened to eliminate some false positives. + Check for Current_Task usage now includes entry barrier, and is now a + warning, not an error. + (Resolve): If the call is ambiguous, indicate whether an interpretation + is an inherited operation. + (Check_Aggr): When resolving aggregates, skip associations with a box, + which are priori correct, and will be replaced by an actual default + expression in the course of expansion. + (Resolve_Type_Conversion): Add missing support for conversion from + a class-wide interface to a tagged type. Minor code cleanup. + (Valid_Tagged_Converion): Add support for abstact interface type + conversions. + (Resolve_Selected_Component): Call Generate_Reference here rather than + during analysis, and use May_Be_Lvalue to distinguish read/write. + (Valid_Array_Conversion): New procedure, abstracted from + Valid_Conversion, to incorporate accessibility checks for arrays of + anonymous access types. + (Valid_Conversion): For a conversion to a numeric type occurring in an + instance or inlined body, no need to check that the operand type is + numeric, since this has been checked during analysis of the template. + Remove legacy test for scope name Unchecked_Conversion. + + * sem_res.ads: Minor reformatting + + * a-except.adb, a-except-2005.adb: Turn off subprogram ordering + (PE_Current_Task_In_Entry_Body): New exception code + (SE_Restriction_Violation): Removed, not used + + * a-except.ads: Update comments. + + * types.h, types.ads: Add definition for Validity_Check + (PE_Current_Task_In_Entry_Body): New exception code + (SE_Restriction_Violation): Removed, not used + +2006-10-31 Thomas Quinot + + * g-socthi-vxworks.adb (C_Gethostbyname): Fix wrong test for returned + error status. + +2006-10-31 Hristian Kirtchev + Jose Ruiz + + * a-calend-vms.adb (Leap_Sec_Ops): Temp body for package in private + part of Ada.Calendar: all subprogram raise Unimplemented. + (Split_W_Offset): Temp function body, raising Unimplemented + + * a-calend.ads, a-calend-vms.ads: + Add imported variable Invalid_TZ_Offset used to designate targets unable + to support time zones. + (Unimplemented): Temporary function raised by the body of new + subprograms below. + (Leap_Sec_Ops): New package in the private part of Ada.Calendar. This + unit provides handling of leap seconds and is used by the new Ada 2005 + packages Ada.Calendar.Arithmetic and Ada.Calendar.Formatting. + (Split_W_Offset): Identical spec to that of Ada.Calendar.Split. This + version returns an extra value which is the offset to UTC. + + * a-calend.adb (Split_W_Offset): Add call to localtime_tzoff. + (Leap_Sec_Ops): New body for package in private part of Ada.Calendar. + (Split_W_Offset): New function body. + (Time_Of): When a date is close to UNIX epoch, compute the time for + that date plus one day (that amount is later substracted after + executing mktime) so there are no problems with time zone adjustments. + + * a-calend-mingw.adb: Remove Windows specific version no longer needed. + + * a-calari.ads, a-calari.adb, a-calfor.ads, a-calfor.adb, + a-catizo.ads, a-catizo.adb: New files. + + * impunit.adb: Add new Ada 2005 entries + + * sysdep.c: Add external variable __gnat_invalid_tz_offset. + Rename all occurences of "__gnat_localtime_r" to + "__gnat_localtime_tzoff". + (__gnat_localtime_tzoff for Windows): Add logic to retrieve the time + zone data and calculate the GMT offset. + (__gnat_localtime_tzoff for Darwin, Free BSD, Linux, Lynx and Tru64): + Use the field "tm_gmtoff" to extract the GMT offset. + (__gnat_localtime_tzoff for AIX, HPUX, SGI Irix and Sun Solaris): Use + the external variable "timezone" to calculate the GMT offset. + +2006-10-31 Arnaud Charlet + Jose Ruiz + + * s-osinte-posix.adb, s-osinte-linux.ads, s-osinte-freebsd.adb, + s-osinte-freebsd.ads, s-osinte-solaris-posix.ads, s-osinte-hpux.ads, + s-osinte-darwin.adb, s-osinte-darwin.ads, s-osinte-lynxos-3.ads, + s-osinte-lynxos-3.adb (To_Target_Priority): New function maps from + System.Any_Priority to a POSIX priority on the target. + + * system-linux-ia64.ads: + Extend range of Priority types on Linux to use the whole range made + available by the system. + + * s-osinte-aix.adb, s-osinte-aix.ads (To_Target_Priority): New + function maps from System.Any_Priority to a POSIX priority on the + target. + (PTHREAD_PRIO_PROTECT): Set real value. + (PTHREAD_PRIO_INHERIT): Now a function. + (SIGCPUFAIL): New signal. + (Reserved): Add SIGALRM1, SIGWAITING, SIGCPUFAIL, since these signals + are documented as reserved by the OS. + + * system-aix.ads: Use the full range of priorities provided by the + system on AIX. + + * s-taprop-posix.adb: Call new function To_Target_Priority. + (Set_Priority): Take into account Task_Dispatching_Policy and + Priority_Specific_Dispatching pragmas when determining if Round Robin + must be used for scheduling the task. + + * system-linux-x86_64.ads, system-linux-x86.ads, + system-linux-ppc.ads: Extend range of Priority types on Linux to use + the whole range made available by the system. + + * s-taprop-vms.adb, s-taprop-mingw.adb, s-taprop-irix.adb, + s-taprop-tru64.adb, s-taprop-linux.adb, s-taprop-hpux-dce.adb, + s-taprop-lynxos.adb (Finalize_TCB): invalidate the stack-check cache + when deallocating the TCB in order to avoid potential references to + deallocated data. + (Set_Priority): Take into account Task_Dispatching_Policy and + Priority_Specific_Dispatching pragmas when determining if Round Robin + or FIFO within priorities must be used for scheduling the task. + + * s-taprop-vxworks.adb (Enter_Task): Store the user-level task id in + the Thread field (to be used internally by the run-time system) and the + kernel-level task id in the LWP field (to be used by the debugger). + (Create_Task): Reorganize to unify the calls to taskSpawn into a single + instance, and propagate the current task options to the spawned task. + (Set_Priority): Take into account Priority_Specific_Dispatching pragmas. + (Initialize): Set Round Robin dispatching when the corresponding pragma + is in effect. + +2006-10-31 Robert Dewar + + * system-vms_64.ads, system-darwin-ppc.ads, system-vxworks-x86.ads, + system-linux-hppa.ads, system-hpux-ia64.ads, + system-lynxos-ppc.ads, system-lynxos-x86.ads, system-tru64.ads, + system-vxworks-sparcv9.ads, system-solaris-x86.ads, + system-irix-o32.ads, system-irix-n32.ads, system-hpux.ads, + system-vxworks-m68k.ads, system-vxworks-mips.ads, system-interix.ads, + system-solaris-sparc.ads, system-solaris-sparcv9.ads, system-vms.ads, + system-mingw.ads, system-vms-zcx.ads, system-vxworks-ppc.ads, + system-vxworks-alpha.ads, system.ads: Add pragma Warnings(Off, + Default_Bit_Order) to kill constant condition warnings for references + to this switch. + +2006-10-31 Vincent Celier + Eric Botcazou + + * mlib-tgt-lynxos.adb, mlib-tgt-mingw.adb, mlib-tgt-tru64.adb, + mlib-tgt-aix.adb, mlib-tgt-irix.adb, mlib-tgt-hpux.adb, + mlib-tgt-linux.adb, mlib-tgt-solaris.adb: Use Append_To, instead of + Ext_To, when building the library file name + + * mlib-tgt-vxworks.adb: ditto. + (Get_Target_Suffix): Add support for x86 targets. + + * mlib-fil.ads, mlib-fil.adb: (Append_To): New function + + * mlib-tgt-darwin.adb: + Use Append_To, instead of Ext_To, when building the library file name + (Flat_Namespace): New global variable. + (No_Shared_Libgcc_Switch): Rename to No_Shared_Libgcc_Options. + (Shared_Libgcc_Switch): Rename to With_Shared_Libgcc_Options. + (Link_Shared_Libgcc): Delete. + (Build_Dynamic_Library): Adjust for above changes. + Use Opt package. + (Build_Dynamic_Library): Pass -shared-libgcc if GCC 4 or later. + +2006-10-31 Eric Botcazou + + * s-taprop-solaris.adb: (Time_Slice_Val): Change type to Integer. + (Initialize): Add type conversions required by above change. + +2006-10-31 Jose Ruiz + + * s-osinte-vxworks.ads, s-osinte-vxworks.adb: + (getpid): New body for this function that uses the underlying taskIdSelf + function for VxWorks 5 and VxWorks 6 in kernel mode. + (unsigned_int): New type, modular to allow logical bit operations. + (taskOptionsGet): New imported function. + + * s-taspri-vxworks.ads (Private_Data): Change the type for the LWP + field to be compliant with the type used by the corresponding operating + system primitive. + +2006-10-31 Pascal Obry + Eric Botcazou + Vincent Celier + + * adaint.c (__gnat_get_libraries_from_registry): Call explicitly the + ASCII version of the registry API. This is needed as the GNAT runtime + is now UNICODE by default. + Include version.h. + (get_gcc_version): Do not hardcode the return value. + (__gnat_file_time_name): On Windows properly set the default returned + value to -1 which corresponds to Invalid_Time. + (__gnat_fopen): New routine. A simple wrapper on all plateforms + except on Windows where it does conversion for unicode support. + (__gnat_freopen): Idem. + (__gnat_locate_exec_on_path): If environment variable PATH does not + exist, return a NULL pointer + + * adaint.h: (__gnat_fopen): Declare. + (__gnat_freopen): Likewise. + + * mingw32.h (_tfreopen): Define this macro here for older MingW + version. + Activate the unicode support on platforms using a MingW runtime + version 3.9 or newer. + + * s-crtl.ads (fopen): Is now an import to the wrapper __gnat_freopen. + This is needed for proper unicode support on Windows. + (freopen): Idem. + +2006-10-31 Eric Botcazou + Nicolas Setton + Olivier Hainque + Gary Dismukes + + * gigi.h: (tree_code_for_record_type): Declare. + (add_global_renaming_pointer): Rename to record_global_renaming_pointer. + (get_global_renaming_pointers): Rename to + invalidate_global_renaming_pointers. + (static_ctors): Delete. + (static_dtors): Likewise. + (gnat_write_global_declarations): Declare. + (create_var_decl): Adjust descriptive comment to indicate that the + subprogram may return a CONST_DECL node. + (create_true_var_decl): Declare new function, similar to + create_var_decl but forcing the creation of a VAR_DECL node. + (get_global_renaming_pointers): Declare. + (add_global_renaming_pointer): Likewise. + + * ada-tree.h (DECL_READONLY_ONCE_ELAB): New macro. + + * decl.c (gnat_to_gnu_entity) : Don't copy the type + tree before setting TREE_ADDRESSABLE for by-reference return mechanism + processing. + (gnat_to_gnu_entity): Remove From_With_Type from computation for + imported_p. + : Use the Non_Limited_View as the full view of the + designated type if the pointer comes from a limited_with clause. Make + incomplete designated type if it is in the main unit and has a freeze + node. + : Rework to treat Non_Limited_View, Full_View, and + Underlying_Full_View similarly. Return earlier if the full view already + has an associated tree. + (gnat_to_gnu_entity) : Restore comment. + (gnat_to_gnu_entity) : Do not use a dummy type. + (gnat_to_gnu_entity) : Set TYPE_REF_CAN_ALIAS_ALL on the + reference type built for objects with an address clause. + Use create_true_var_decl with const_flag set for + DECL_CONST_CORRESPONDING_VARs, ensuring a VAR_DECL is created with + TREE_READONLY set. + (gnat_to_gnu_entity, case E_Enumeration_Type): Set TYPE_NAME + for Character and Wide_Character types. This info is read by the + dwarf-2 writer, and is needed to be able to use the command "ptype + character" in the debugger. + (gnat_to_gnu_entity): When generating a type representing + a Character or Wide_Character type, set the flag TYPE_STRING_FLAG, + so that debug writers can distinguish it from ordinary integers. + (elaborate_expression_1): Test the DECL_READONLY_ONCE_ELAB flag in + addition to TREE_READONLY to assert the constantness of variables for + elaboration purposes. + (gnat_to_gnu_entity, subprogram cases): Change loops on formal + parameters to call new Einfo function First_Formal_With_Extras. + (gnat_to_gnu_entity): In type_annotate mode, replace a discriminant of a + protected type with its corresponding discriminant, to obtain a usable + declaration + (gnat_to_gnu_entity) : Be prepared + for a multiple elaboration of the "equivalent" type. + (gnat_to_gnu_entity): Adjust for renaming of add_global_renaming_pointer + into record_global_renaming_pointer. + (gnat_to_gnu_entity) : Do not force + TYPE_NONALIASED_COMPONENT to 0 if the element type is an aggregate. + : Likewise. + (gnat_to_gnu_entity) : Add support for regular + incomplete subtypes and incomplete subtypes of incomplete types visible + through a limited with clause. + (gnat_to_gnu_entity) : Take into account the bounds of + the base index type for the maximum size of the array only if they are + constant. + (gnat_to_gnu_entity, renaming object case): Do not wrap up the + expression into a SAVE_EXPR if stabilization failed. + + * utils.c (create_subprog_decl): Turn TREE_ADDRESSABLE on the type of + a result decl into DECL_BY_REFERENCE on this decl, now what is expected + by lower level compilation passes. + (gnat_genericize): New function, lowering a function body to GENERIC. + Turn the type of RESULT_DECL into a real reference type if the decl + has been marked DECL_BY_REFERENCE, and adjust references to the latter + accordingly. + (gnat_genericize_r): New function. Tree walking callback for + gnat_genericize. + (convert_from_reference, is_byref_result): New functions. Helpers for + gnat_genericize_r. + (create_type_decl): Call gnat_pushdecl before calling + rest_of_decl_compilation, to make sure that field TYPE_NAME of + type_decl is properly set before calling the debug information writers. + (write_record_type_debug_info): The heuristics which compute the + alignment of a field in a variant record might not be accurate. Add a + safety test to make sure no alignment is set to a smaller value than + the alignment of the field type. + (make_dummy_type): Use the Non_Limited_View as the underlying type if + the type comes from a limited_with clause. Do not loop on the full view. + (GET_GNU_TREE, SET_GNU_TREE, PRESENT_GNU_TREE): New macros. + (dummy_node_table): New global variable, moved from decl.c. + (GET_DUMMY_NODE, SET_DUMMY_NODE, PRESENT_DUMMY_NODE): New macros. + (save_gnu_tree): Use above macros. + (get_gnu_tree): Likewise. + (present_gnu_tree): Likewise. + (init_dummy_type): New function, moved from decl.c. Use above macros. + (make_dummy_type): Likewise. + (tree_code_for_record_type): New function extracted from make_dummy_type + (init_gigi_decls): Set DECL_IS_MALLOC on gnat_malloc. + (static_ctors): Change it to a vector, make static. + (static_dtors): Likewise. + (end_subprog_body): Adjust for above change. + (build_global_cdtor): Moved from trans.c. + (gnat_write_global_declarations): Emit global constructor and + destructor, and call cgraph_optimize before emitting debug info for + global declarations. + (global_decls): New global variable. + (gnat_pushdecl): Store the global declarations in global_decls, for + later use. + (gnat_write_global_declarations): Emit debug information for global + declarations. + (create_var_decl_1): Former create_var_decl, with an extra argument to + state whether the creation of a CONST_DECL is allowed. + (create_var_decl): Behavior unchanged. Now a wrapper around + create_var_decl_1 allowing CONST_DECL creation. + (create_true_var_decl): New function, similar to create_var_decl but + forcing the creation of a VAR_DECL node (CONST_DECL not allowed). + (create_field_decl): Do not always mark the field as addressable + if its type is an aggregate. + (global_renaming_pointers): New static variable. + (add_global_renaming_pointer): New function. + (get_global_renaming_pointers): Likewise. + + * misc.c (gnat_dwarf_name): New function. + (LANG_HOOKS_DWARF_NAME): Define to gnat_dwarf_name. + (gnat_post_options): Add comment about structural alias analysis. + (gnat_parse_file): Do not call cgraph_optimize here. + (LANG_HOOKS_WRITE_GLOBALS): Define to gnat_write_global_declarations. + + * trans.c (process_freeze_entity): Don't abort if we already have a + non dummy GCC tree for a Concurrent_Record_Type, as it might + legitimately have been elaborated while processing the associated + Concurrent_Type prior to this explicit freeze node. + (Identifier_to_gnu): Do not make a variable referenced in a SJLJ + exception handler volatile if it is of variable size. + (process_type): Remove bypass for types coming from a limited_with + clause. + (call_to_gnu): When processing the copy-out of a N_Type_Conversion GNAT + actual, convert the corresponding gnu_actual to the real destination + type when necessary. + (add_decl_expr): Set the DECL_READONLY_ONCE_ELAB flag on variables + originally TREE_READONLY but whose elaboration cannot be performed + statically. + Part of fix for F504-021. + (tree_transform, subprogram cases): Change loops on formal parameters to + call new Einfo function First_Formal_With_Extras. + (gnat_to_gnu) : Ignore constant overflow + stemming from type conversion for the lhs. + (Attribute_to_gnu) : Also divide the alignment by the + number of bits per unit for components of records. + (gnat_to_gnu) : Mark operands addressable if needed. + (Handled_Sequence_Of_Statements_to_gnu): Register the cleanup associated + with At_End_Proc after the SJLJ EH cleanup. + (Compilation_Unit_to_gnu): Call elaborate_all_entities only on the main + compilation unit. + (elaborate_all_entities): Do not retest type_annotate_only. + (tree_transform) : Process the + result type of an abstract subprogram, which may be an itype associated + with an anonymous access result (related to AI-318-02). + (build_global_cdtor): Move to utils.c. + (Case_Statement_to_gnu): Avoid adding the choice of a when statement if + this choice is not a null tree nor an integer constant. + (gigi): Run unshare_save_expr via walk_tree_without_duplicates + on the body of elaboration routines instead of mark_unvisited. + (add_stmt): Do not mark the tree. + (add_decl_expr): Tweak comment. + (mark_unvisited): Delete. + (unshare_save_expr): New static function. + (call_to_gnu): Issue an error when making a temporary around a + procedure call because of non-addressable actual parameter if the + type of the formal is by_reference. + (Compilation_Unit_to_gnu): Invalidate the global renaming pointers + after building the elaboration routine. + +2006-10-31 Bob Duff + + * a-filico.adb (Finalize(List_Controller)): Mark the finalization list + as finalization-started, so we can raise Program_Error on 'new'. + + * s-finimp.adb: Raise Program_Error on 'new' if finalization of the + collection has already started. + + * s-finimp.ads (Collection_Finalization_Started): Added new special + flag value for indicating that a collection's finalization has started. + + * s-tassta.adb (Create_Task): Raise Program_Error on an attempt to + create a task whose master has already waited for dependent tasks. + +2006-10-31 Robert Dewar + + * lib.adb, lib.ads: (In_Predefined_Unit): New functions + + * a-finali.ads, a-ngcoty.ads, a-strbou.ads, a-stream.ads, a-strmap.ads, + a-strunb.ads, a-stwibo.ads, a-stwima.ads, a-stwiun.ads, a-taside.ads, + a-coorse.ads, a-convec.ads, a-coinve.ads, a-cohama.ads, a-ciorse.ads, + a-cihama.ads, a-cihase.ads, a-cohase.ads, a-ciorma.ads, a-coorma.ads, + a-ciormu.ads, a-coormu.ads, a-stzbou.ads, a-stzmap.ads, a-stzunb.ads, + a-except-2005.ads: Add pragma Preelaborable_Warning + +2006-10-31 Robert Dewar + Jose Ruiz + + * a-dispat.ads, a-dispat.adb, a-diroro.ads, a-diroro.adb: New files. + + * ali.adb (Get_Name): Properly handle scanning of wide character names + encoded with brackets notation. + (Known_ALI_Lines): Add S lines to this list. + (Scan_ALI): Acquire S (priority specific dispatching) lines. + New flag Elaborate_All_Desirable in unit table + + * ali.ads (Priority_Specific_Dispatching): Add this range of + identifiers to be used for Priority_Specific_Dispatching table entries. + (ALIs_Record): Add First_Specific_Dispatching and + Last_Specific_Dispatching that point to the first and last entries + respectively in the priority specific dispatching table for this unit. + (Specific_Dispatching): Add this table for storing each S (priority + specific dispatching) line encountered in the input ALI file. + New flag Elaborate_All_Desirable in unit table + + * bcheck.adb: (Check_Configuration_Consistency): Add call to + Check_Consistent_Dispatching_Policy. + (Check_Consistent_Dispatching_Policy): Add this procedure in charge of + verifying that the use of Priority_Specific_Dispatching, + Task_Dispatching_Policy, and Locking_Policy is consistent across the + partition. + + * bindgen.adb: (Public_Version_Warning): function removed. + (Set_PSD_Pragma_Table): Add this procedure in charge of getting the + required information from ALI files in order to initialize the table + containing the specific dispatching policy. + (Gen_Adainit_Ada): Generate the variables required for priority specific + dispatching entries (__gl_priority_specific_dispatching and + __gl_num_specific_dispatching). + (Gen_Adainit_C): Generate the variables required for priority specific + dispatching entries (__gl_priority_specific_dispatching and + __gl_num_specific_dispatching). + (Gen_Output_File): Acquire settings for Priority_Specific_Dispatching + pragma entries. + (Gen_Restrictions_String_1, Gen_Restrictions_String_2): Removed. + (Gen_Restrictions_Ada, Gen_Restrictions_C, Set_Boolean): New procedures. + (Tab_To): Removed. + (Gen_Output_File_Ada/_C): Set directly __gl_xxx variables instead of + a call to gnat_set_globals. + Generate a string containing settings from + Priority_Specific_Dispatching pragma entries. + (Gen_Object_Files_Options): Do not include the runtime libraries when + pragma No_Run_Time is specified. + + * init.c (__gnat_install_handler, case FreeBSD): Use SA_SIGINFO, for + consistency with s-intman-posix.adb. + (__gnat_error_handler, case FreeBSD): Account for the fact that the + handler is installed with SA_SIGINFO. + (__gnat_adjust_context_for_raise, FreeBSD case): New function for + FreeBSD ZCX support, copied from Linux version. + Add MaRTE-specific definitions for the linux target. Redefine sigaction, + sigfillset, and sigemptyset so the routines defined by MaRTE. + (__gl_priority_specific_dispatching): Add this variable that stores the + string containing priority specific dispatching policies in the + partition. + (__gl_num_specific_dispatching): Add this variable that indicates the + highest priority for which a priority specific dispatching pragma + applies. + (__gnat_get_specific_dispatching): Add this routine that returns the + priority specific dispatching policy, as set by a + Priority_Specific_Dispatching pragma appearing anywhere in the current + partition. The input argument is the priority number, and the result + is the upper case first character of the policy name. + (__gnat_set_globals): Now a dummy function. + (__gnat_handle_vms_condition): Feed adjust_context_for_raise with + mechargs instead of sigargs, as the latter can be retrieved from the + former and sigargs is not what we want on ia64. + (__gnat_adjust_context_for_raise, alpha-vms): Fetch sigargs from the + mechargs argument. + (__gnat_adjust_context_for_raise, ia64-vms): New function. + (tasking_error): Remove unused symbol. + (_abort_signal): Move this symbol to the IRIX specific part since this + is the only target that uses this definition. + (Check_Abort_Status): Move this symbol to the IRIX specific part since + this is the only target that uses this definition. + (Lock_Task): Remove unused symbol. + (Unlock_Task): Remove unused symbol. + + * lib-writ.adb (Write_ALI): Output new S lines for + Priority_Specific_Dispatching pragmas. + Implement new flag BD for elaborate body desirable + + * lib-writ.ads: Document S lines for Priority Specific Dispatching. + (Specific_Dispatching): Add this table for storing the entries + corresponding to Priority_Specific_Dispatching pragmas. + Document new BD flag for elaborate body desirable + + * par-prag.adb (Prag): Add Priority_Specific_Dispatching to the list + of known pragmas. + +2006-10-31 Javier Miranda + + * a-tags.ads, a-tags.adb: + (Predefined_DT): New function that improves readability of the code. + (Get_Predefined_Prim_Op_Address, Set_Predefined_Prim_Op_Address, + Inherit_DT): Use the new function Predefined_DT to improve code + readability. + (Register_Interface_Tag): Update assertion. + (Set_Interface_Table): Update assertion. + (Interface_Ancestor_Tags): New subprogram required to implement AI-405: + determining progenitor interfaces in Tags. + (Inherit_CPP_DT): New subprogram. + + * exp_disp.adb (Expand_Interface_Thunk): Suppress checks during the + analysis of the thunk code. + (Expand_Interface_Conversion): Handle run-time conversion of + access to class wide types. + (Expand_Dispatching_Call): When generating the profile for the + subprogram itype for a dispatching operation, properly terminate the + formal parameters chaind list (set the Next_Entity of the last formal + to Empty). + (Collect_All_Interfaces): Removed. This routine has been moved to + sem_util and renamed as Collect_All_Abstract_Interfaces. + (Set_All_DT_Position): Hidden entities associated with abstract + interface primitives are not taken into account in the check for + 3.9.3(10); this check is done with the aliased entity. + (Make_DT, Set_All_DT_Position): Enable full ABI compatibility for + interfacing with CPP by default. + (Expand_Interface_Conversion): Add missing support for static conversion + from an interface to a tagged type. + (Collect_All_Interfaces): Add new out formal containing the list of + abstract interface types to cleanup the subprogram Make_DT. + (Make_DT): Update the code to generate the table of interfaces in case + of abstract interface types. + (Is_Predefined_Dispatching_Alias): New function that returns true if + a primitive is not a predefined dispatching primitive but it is an + alias of a predefined dispatching primitive. + (Make_DT): If the ancestor of the type is a CPP_Class and we are + compiling under full ABI compatibility mode we avoid the generation of + calls to run-time services that fill the dispatch tables because under + this mode we currently inherit the dispatch tables in the IP subprogram. + (Write_DT): Emit an "is null" indication for a null procedure primitive. + (Expand_Interface_Conversion): Use an address as the type of the formal + of the internally built function that handles the case in which the + target type is an access type. + +2006-10-31 Robert Dewar + + * binde.adb (Better_Choice, Worse_Choice): Implement new preferences. + +2006-10-31 Robert Dewar + + * bindusg.ads, bindusg.adb: + Change to package and rename procedure as Display, which + now ensures that it only outputs usage information once. + +2006-10-31 Jose Ruiz + + * cal.c: Use the header sys/time.h for VxWorks 6.2 or greater when + using RTPs. + + * mkdir.c: Use a different version of mkdir for VxWorks 6.2 or greater + when using RTPs. + +2006-10-31 Robert Dewar + Ed Schonberg + + * treepr.adb: Use new subtype N_Membership_Test + + * checks.ads, checks.adb: Add definition for Validity_Check + (Range_Or_Validity_Checks_Suppressed): New function + (Ensure_Valid): Test Validity_Check suppressed + (Insert_Valid_Check): Test Validity_Check suppressed + (Insert_Valid_Check): Preserve Do_Range_Check flag + (Validity_Check_Range): New procedure + (Expr_Known_Valid): Result of membership test is always valid + (Selected_Range_Checks): Range checks cannot be applied to discriminants + by themselves. Disabling those checks must also be done for task types, + where discriminants may be used for the bounds of entry families. + (Apply_Address_Clause_Check): Remove side-effects if address expression + is non-static and is not the name of a declared constant. + (Null_Exclusion_Static_Checks): Extend to handle Function_Specification. + Code cleanup and new error messages. + (Enable_Range_Check): Test for some cases of suppressed checks + (Generate_Index_Checks): Suppress index checks if index checks are + suppressed for array object or array type. + (Apply_Selected_Length_Checks): Give warning for compile-time detected + length check failure, even if checks are off. + (Ensure_Valid): Do not generate a check on an indexed component whose + prefix is a packed boolean array. + * checks.adb: (Alignment_Checks_Suppressed): New function + (Apply_Address_Clause_Check): New procedure, this is a completely + rewritten replacement for Apply_Alignment_Check + (Get_E_Length/Get_E_First_Or_Last): Add missing barrier to ensure that + we request a discriminal value only in case of discriminants. + (Apply_Discriminant_Check): For Ada_05, only call Get_Actual_Subtype for + assignments where the target subtype is unconstrained and the target + object is a parameter or dereference (other aliased cases are known + to be unconstrained). + +2006-10-31 Robert Dewar + + * clean.adb, gnatname.adb, gnatsym.adb, prep.adb, prep.ads, + prepcomp.adb, prj.ads, prj-strt.adb, sem_maps.ads, + vms_conv.adb: Fix bad table increment values (much too small) + + * table.adb (Realloc): Make sure we get at least some new elements + Defends against silly small values for table increment + +2006-10-31 Robert Dewar + Ed Schonberg + Bob Duff + + * einfo.ads, einfo.adb (Obsolescent_Warning): Now defined on all + entities. Move other fields around to make this possible + (Is_Derived_Type): Add missing call to Is_Type. + (Extra_Formals): New function for subprograms, entries, subprogram + types. + (Set_Extra_Formals): New procedure for subprograms, entries, subp types. + (First_Formal_With_Extras): New function for subprogs, entries, subp + types. + (Write_Field28_Name): New procedure for node display of "Extra_Formals". + Add node information for E_Return_Statement. + (Elaborate_Body_Desirable): New flag + (Is_Return_By_Reference_Type): Rename Is_Return_By_Reference_Type + to be Is_Inherently_Limited_Type, because return-by-reference has + no meaning in Ada 2005. + (E_Return_Statement): New entity kind. + (Return_Applies_To): Field of E_Return_Statement. + (Is_Return_Object): New flag in object entities. + (Is_Dynamic_Scope): Make it True for E_Return_Statement. + (Must_Have_Preelab_Init): New flag + (Known_To_Have_Preelab_Init): New flag + (Is_Formal_Object): Move from Sem_Ch8 body to Einfo + (Is_Visible_Formal): New flag on entities in formal packages. + (Low_Bound_Known): New flag + (Non_Limited_View, Set_Non_Limited_View): Add membership test agains + Incomplete_Kind. + (Write_Field17_Name): Correct spelling of Non_Limited_View. Add name + output when Id is an incomplete subtype. + +2006-10-31 Robert Dewar + + * errout.ads, errout.adb (Finalize): Implement switch -gnatd.m + Avoid abbreviation Creat + (Finalize): List all sources in extended mail source if -gnatl + switch is active. + Suppress copyright notice to file in -gnatl=f mode if -gnatd7 set + (Finalize): Implement new -gnatl=xxx switch to output listing to file + (Set_Specific_Warning_On): New procedure + (Set_Specific_Warning_Off): New procedure + Add implementation of new insertion \\ + (Error_Msg_Internal): Add handling for Error_Msg_Line_Length + (Unwind_Internal_Type): Improve report on anonymous access_to_subprogram + types. + (Error_Msg_Internal): Make sure that we set Last_Killed to + True when a message from another package is suppressed. + Implement insertion character ~ (insert string) + (First_Node): Minor adjustments to get better placement. + + * frontend.adb: + Implement new -gnatl=xxx switch to output listing to file + + * gnat1drv.adb: + Implement new -gnatl=xxx switch to output listing to file + + * opt.ads: (Warn_On_Questionable_Missing_Paren): New switch + (Commands_To_Stdout): New flag + Implement new -gnatl=xxx switch to output listing to file + New switch Dump_Source_Text + (Warn_On_Deleted_Code): New warning flag for -gnatwt + Define Error_Msg_Line_Length + (Warn_On_Assumed_Low_Bound): New switch + + * osint.ads, osint.adb + (Normalize_Directory_Name): Fix bug. + Implement new -gnatl=xxx switch to output listing to file + (Concat): Removed, replaced by real concatenation + Make use of concatenation now allowed in compiler + (Executable_Prefix.Get_Install_Dir): First get the full path, so that + we find the 'lib' or 'bin' directory even when the tool has been + invoked with a relative path. + (Executable_Name): New function taking string parameters. + + * osint-c.ads, osint-c.adb: + Implement new -gnatl=xxx switch to output listing to file + + * sinput-d.adb: Change name Creat_Debug_File to Create_Debug_File + + * switch-c.adb: + Implement new -gnatl=xxx switch to output listing to file + Recognize new -gnatL switch + (no longer keep in old warning about old style usage) + Use concatenation to simplify code + Recognize -gnatjnn switch + (Scan_Front_End_Switches): Clean up handling of -gnatW + (Scan_Front_End_Switches): Include Warn_On_Assumed_Low_Bound for -gnatg + +2006-10-31 Robert Dewar + + * erroutc.ads, erroutc.adb (Set_Specific_Warning_On): New procedure + (Set_Specific_Warning_Off): New procedure + (Warning_Specifically_Suppressed): New function + (Validate_Specific_Warnings): New procedure + (Output_Msg_Text): Complete rewrite to support -gnatjnn + + * err_vars.ads: Implement insertion character ~ (insert string) + +2006-10-31 Bob Duff + Ed Schonberg + + * exp_aggr.adb (Build_Record_Aggr_Code): For extension aggregates, if + the parent part is a build-in-place function call, generate assignments. + (Expand_Record_Aggregate): Call Convert_To_Assignments if any components + are build-in-place function calls. + (Replace_Self_Reference): New subsidiary of + Make_OK_Assignment_Statement, to replace an access attribute that is a + self-reference into an access to the appropriate component of the + target object. Generalizes previous mechanism to handle self-references + nested at any level. + (Is_Self_Referential_Init): Remove, not needed. + (Is_Self_Referential_Init): New predicate to simplify handling of self + referential components in record aggregates. + (Has_Default_Init_Comps, Make_OK_Assignment_Statement): Add guard to + check for presence of entity before checking for self-reference. + (Has_Default_Init_Comps): Return True if a component association is a + self-reference to the enclosing type, which can only come from a + default initialization. + (Make_OK_Assignment_Statement): If the expression is of the form + Typ'Acc, where Acc is an access attribute, the expression comes from a + default initialized self-referential component. + (Build_Record_Aggr_Code): If the type of the aggregate is a tagged type + that has been derived from several abstract interfaces we must also + initialize the tags of the secondary dispatch tables. + +2006-10-31 Ed Schonberg + Thomas Quinot + Javier Miranda + Robert Dewar + + * exp_attr.adb: + (Expand_Access_To_Protected_Op): If the context indicates that an access + to a local operation may be transfered outside of the object, create an + access to the wrapper operation that must be used in an external call. + (Expand_N_Attribute_Reference, case Attribute_Valid): For the AAMP + target, pass the Valid attribute applied to a floating-point prefix on + to the back end without expansion. + (Storage_Size): Use the new run-time function Storage_Size to retrieve + the allocated storage when it is specified by a per-object expression. + (Expand_N_Attribute_Reference): Add case for Attribute_Stub_Type. + Nothing to do here, the attribute has been rewritten during semantic + analysis. + (Expand_Attribute_Reference): Handle expansion of the new Priority + attribute + (Find_Fat_Info): Handle case of universal real + (Expand_Access_To_Protected_Op): Fix use of access to protected + subprogram from inside the body of a protected entry. + (Expand_Access_To_Protected_Op): Common procedure for the expansion of + 'Access and 'Unrestricted_Access, to transform the attribute reference + into a fat pointer. + (Is_Constrained_Aliased_View): New predicate to help determine whether a + subcomponent's enclosing variable is aliased with a constrained subtype. + (Expand_N_Attribute_Reference, case Attribute_Constrained): For Ada_05, + test Is_Constrained_Aliased_View rather than Is_Aliased_View, because + an aliased prefix must be known to be constrained in order to use True + for the attribute value, and now it's possible for some aliased views + to be unconstrained. + +2006-10-31 Robert Dewar + + * exp_ch2.adb: Change Is_Lvalue to May_Be_Lvalue + (Expand_Entity_Reference): Correct error of not handling subprogram + formals in current_value processing. + +2006-10-31 Javier Miranda + Robert Dewar + Ed Schonberg + Gary Dismukes + + * exp_ch3.ads, exp_ch3.adb (Expand_N_Object_Declaration): Do not + register in the final list objects containing class-wide interfaces; + otherwise we incorrectly register the tag of the interface in the final + list. + (Make_Controlling_Function_Wrappers): Add missing barrier to do not + generate the wrapper if the parent primitive is abstract. This is + required to report the correct error message. + (Expand_N_Subtype_Indication): Do validity checks on range + (Clean_Task_Names): If an initialization procedure includes a call to + initialize a task (sub)component, indicate that the procedure will use + the secondary stack. + (Build_Init_Procedure, Init_Secondary_Tags): Enable full ABI + compatibility for interfacing with CPP by default. + (Expand_N_Object_Declaration): Only build an Adjust call when the + object's type is a nonlimited controlled type. + * exp_ch3.adb: Add with and use of Exp_Ch6. + (Expand_N_Object_Declaration): Check for object initialization that is a + call to build-in-place function and apply Make_Build_In_Place_Call_In_ + Object_Declaration to the call. + (Freeze_Type): When the designated type of an RACW was not frozen at the + point where the RACW was declared, validate the primitive operations + with respect to E.2.2(14) when it finally is frozen. + (Build_Initialization_Call,Expand_Record_Controller): Rename + Is_Return_By_Reference_Type to be Is_Inherently_Limited_Type, because + return-by-reference has no meaning in Ada 2005. + (Init_Secondary_Tags): Add missing call to Set_Offset_To_Top + to register tag of the immediate ancestor interfaces in the + run-time structure. + (Init_Secondary_Tags): Moved to the specification to allow the + initialization of extension aggregates with abstract interfaces. + (Build_Master_Renaming): Make public, for use by function declarations + whose return type is an anonymous access type. + (Freeze_Record_Type): Replace call to Insert_List_Before by call to + Insert_List_Before_And_Analyze after the generation of the specs + associated with null procedures. + (Expand_Tagged_Root): Update documentation in its specification. + (Init_Secondary_Tags): Update documentation. + (Build_Init_Procedure): If we are compiling under CPP full ABI compa- + tibility mode and the immediate ancestor is a CPP_Pragma tagged type + then generate code to inherit the contents of the dispatch table + directly from the ancestor. + (Expand_Record_Controller): Insert controller component after tags of + implemented interfaces. + (Freeze_Record_Type): Call new procedure Make_Null_Procedure_Specs to + create null procedure overridings when null procedures are inherited + from interfaces. + (Make_Null_Procedure_Specs): New procedure to generate null procedure + declarations for overriding null primitives inherited from interfaces. + (Is_Null_Interface_Procedure): New function in + Make_Null_Procedure_Specs. + (Make_Predefined_Primitive_Specs/Predefined_Primitive_Bodies): If the + immediate ancestor of a tagged type is an abstract interface type we + must generate the specification of the predefined primitives associated + with controlled types (because the dispatch table of the ancestor is + null and hence these entries cannot be inherited). This is required to + elaborate well the dispatch table. + +2006-10-31 Javier Miranda + Ed Schonberg + Bob Duff + Gary Dismukes + Robert Dewar + + * exp_ch4.adb (Expand_N_Type_Conversion): Handle missing interface type + conversion. + (Expand_N_In): Do validity checks on range + (Expand_Selected_Component): Use updated for of Denotes_Discriminant. + (Expand_N_Allocator): For "new T", if the object is constrained by + discriminant defaults, allocate the right amount of memory, rather than + the maximum for type T. + (Expand_Allocator_Expression): Suppress the call to Remove_Side_Effects + when the allocator is initialized by a build-in-place call, since the + allocator is already rewritten as a reference to the function result, + and this prevents an unwanted duplication of the function call. + Add with and use of Exp_Ch6. + (Expand_Allocator_Expresssion): Check for an allocator whose expression + is a call to build-in-place function and apply + Make_Build_In_Place_Call_In_Allocator to the call (for both tagged and + untagged designated types). + (Expand_N_Unchecked_Type_Conversion): Do not do integer literal + optimization if source or target is biased. + (Expand_N_Allocator): Add comments for case of an allocator within a + function that returns an anonymous access type designating tasks. + (Expand_N_Allocator): apply discriminant checks for access + discriminants of anonymous access types (AI-402, AI-416) + +2006-10-31 Bob Duff + Robert Dewar + Gary Dismukes + Ed Schonberg + + * exp_ch5.ads (Expand_N_Extended_Return_Statement): New procedure. + + * exp_ch5.adb (Expand_N_Loop_Statement): Do validity checks on range + (Expand_N_Assignment_Statement): Call + Make_Build_In_Place_Call_In_Assignment if the right-hand side is a + build-in-place function call. Currently, this can happen only for + assignments that come from aggregates. + Add -gnatd.l --Use Ada 95 semantics for limited function returns, + in order to alleviate the upward compatibility introduced by AI-318. + (Expand_N_Extended_Return_Statement): Add support for handling the + return object as a build-in-place result. + (Expand_Non_Function_Return): Implement simple return statements nested + within an extended return. + (Enable_New_Return_Processing): Turn on the new processing of return + statements. + (Expand_Non_Function_Return): For a return within an extended return, + don't raise Program_Error, because Sem_Ch6 now gives a warning. + (Expand_N_Extended_Return_Statement): Implement AI-318 + (Expand_Simple_Function_Return): Ditto. + (Expand_N_If_Statement): Handle new -gnatwt warning + (Expand_N_Case_Statement): Handle new -gnatwt warning + (Expand_N_Assignment): Handle assignment to the Priority attribute of + a protected object. + (Expand_N_Assignment_Statement): Implement -gnatVe/E to control + validity checking of assignments to elementary record components. + (Expand_N_Return_Statement): return Class Wide types on the secondary + stack independantly of their controlled status since with HIE runtimes, + class wide types are not potentially controlled anymore. + + * expander.adb (Expand): Add case for new N_Extended_Return_Statement + node kind. + + * exp_ch11.adb (Expand_N_Handled_Sequence_Of_Statements): Avoid + Expand_Cleanup_Actions in case of N_Extended_Return_Statement, because + it expects a block, procedure, or task. The return statement will get + turned into a block, and Expand_Cleanup_Actions will happen then. + +2006-10-31 Robert Dewar + Ed Schonberg + Bob Duff + Gary Dismukes + + * exp_ch6.ads, exp_ch6.adb: Use new Validity_Check suppression + capability. + (Expand_Inlined_Call): Tagged types are by-reference types, and + therefore should be replaced by a renaming declaration in the expanded + body, as is done for limited types. + (Expand_Call): If this is a call to a function with dispatching access + result, propagate tag from context. + (Freeze_Subprogram): Enable full ABI compatibility for interfacing with + CPP by default. + (Make_Build_In_Place_Call_In_Assignment): New procedure to do + build-in-place when the right-hand side of an assignment is a + build-in-place function call. + (Make_Build_In_Place_Call_In_Allocator): Apply an unchecked conversion + of the explicit dereference of the allocator to the result subtype of + the build-in-place function. This is needed to satisfy type checking + in cases where the caller's return object is created by an allocator for + a class-wide access type and the type named in the allocator is a + specific type. + (Make_Build_In_Place_Call_In_Object_Declaration): Apply an unchecked + conversion of the reference to the declared object to the result subtype + of the build-in-place function. This is needed to satisfy type checking + in cases where the declared object has a class-wide type. Also, in the + class-wide case, change the type of the object entity to the specific + result subtype of the function, to avoid passing a class-wide object + without explicit initialization to the back end. + (Register_Interface_DT_Entry): Moved outside the body of + Freeze_Subprogram because this routine is now public; it is called from + Check_Dispatching_Overriding to handle late overriding of abstract + interface primitives. + (Add_Access_Actual_To_Build_In_Place_Call): New utility procedure for + adding an implicit access actual on a call to a build-in-place function. + (Expand_Actuals): Test for an actual parameter that is a call to a + build-in-place function and apply + Make_Build_In_Place_Call_In_Anonymous_Context to the call. + (Is_Build_In_Place_Function): New function to determine whether an + entity is a function whose calls should be handled as build-in-place. + (Is_Build_In_Place_Function_Call): New function to determine whether an + expression is a function call that should handled as build-in-place. + (Make_Build_In_Place_Call_In_Allocator): New procedure for handling + calls to build-in-place functions as the initialization of an allocator. + (Make_Build_In_Place_Call_In_Anonymous_Context): New procedure for + handling calls to build-in-place functions in contexts that do not + involve init of a separate object (for example, actuals of subprogram + calls). + (Make_Build_In_Place_Call_In_Object_Declaration): New procedure for + handling calls to build-in-place functions as the initialization of an + object declaration. + (Detect_Infinite_Recursion): Add explicit parameter Process to + instantiation of Traverse_Body to avoid unreferenced warning. + (Check_Overriding_Inherited_Interfaces): Removed. + (Register_Interface_DT_Entry): Code cleanup. + (Register_Predefined_DT_Entry): Code cleanup. + (Expand_Inlined_Call.Rewrite_Procedure_Call): Do not omit block around + inlined statements if within a transient scope. + (Expand_Inlined_Call.Process_Formals): When replacing occurrences of + formal parameters with occurrences of actuals in inlined body, establish + visibility on the proper view of the actual's subtype for the body's + context. + (Freeze_Subprogram): Do nothing if we are compiling under full ABI + compatibility mode and we have an imported CPP subprogram because + for now we assume that imported CPP primitives correspond with + objects whose constructor is in the CPP side (and therefore we + don't need to generate code to register them in the dispatch table). + (Expand_Actuals): Introduce copy of actual, only if it might be a bit- + aligned selected component. + (Add_Call_By_Copy_Node): Add missing code to handle the case in which + the actual of an in-mode parameter is a type conversion. + (Expand_Actuals): If the call does not come from source and the actual + is potentially misaligned, let gigi handle it rather than rejecting the + (Expand_N_Subprogram_Body, Freeze_Subprogram): set subprograms returning + Class Wide types as returning by reference independantly of their + controlled status since with HIE runtimes class wide types are not + potentially controlled anymore. + +2006-10-31 Ed Schonberg + + * exp_ch9.adb (Update_Prival_Types): Simplify code for entity + references that are private components of the protected object. + (Build_Barrier_Function): Set flag Is_Entry_Barrier_Function + (Update_Prival_Subtypes): Add explicit Process argument to Traverse_Proc + instantiation to deal with warnings. + (Initialize_Protection): If expression for priority is non-static, use + System_Priority as its expected type, in case the expression has not + been analyzed yet. + +2006-10-31 Robert Dewar + + * exp_dbug.ads, exp_dbug.adb (Get_External_Name): Add missing + initialization of Homonym_Len. + (Fully_Qualify_Name): Remove kludge to eliminate anonymous block + names from fully qualified name. Fixes problem of duplicate + external names differing only in the presence of such a block name. + +2006-10-31 Thomas Quinot + Pablo Oliveira + + * exp_dist.adb (Get_Subprogram_Ids): This function will no more assign + subprogram Ids, even if they are not yet assigned. + (Build_Subprogram_Id): It is now this function that will take care of + calling Assign_Subprogram_Ids if necessary. + (Add_Receiving_Stubs_To_Declarations): Checking the subprograms ids + should be done only once they are assigned. + (Build_From_Any_Function, case of tagged types): Add missing call to + Allocate_Buffer. + (Corresponding_Stub_Type): New subprogram. Returns the associated stub + type for an RACW type. + (Add_RACW_Features): When processing an RACW declaration for which the + designated type is already frozen, enforce E.2.2(14) rules immediately. + (GARLIC_Support.Build_Subprogram_Receiving_Stubs): Do not perform any + special reordering of controlling formals. + + * exp_dist.ads (Corresponding_Stub_Type): New subprogram. Returns the + associated stub type for an RACW type. + +2006-10-31 Ed Schonberg + + * exp_fixd.adb (Rounded_Result_Set): For multiplication and division of + fixed-point operations in an integer context, i.e. as operands of a + conversion to an integer type, indicate that result must be rounded. + +2006-10-31 Robert Dewar + + * exp_imgv.adb (Expand_Image_Attribute): For Wide_[Wide_]Character + cases, pass the encoding method, since it is now required by the run + time. + + * s-valwch.ads, s-valwch.adb (Value_Wide_Wide_Character): Avoid + assumption that Str'First = 1. + (Value_Wide_Character): Takes EM (encoding method) parameter and passes + it on to the Value_Wide_Wide_Character call. + (Value_Wide_Wide_Character): Takes EM (encoding method) parameter and + properly handles a string of the form quote-encoded_wide_char-quote. + + * s-wchcnv.adb: Minor reformatting + +2006-10-31 Javier Miranda + + * exp_intr.adb (Expand_Dispatching_Constructor_Call): Add missing + run-time membership test to ensure that the constructed object + implements the target abstract interface. + +2006-10-31 Robert Dewar + + * exp_prag.adb (Expand_Pragma_Common_Object): Use a single + Machine_Attribute pragma internally to implement the user pragma. + Add processing for pragma Interface so that it is now completely + equivalent to pragma Import. + + * sem_prag.adb (Analyze_Pragma, case Obsolescent): Extend this pragma + so that it can be applied to all entities, including record components + and enumeration literals. + (Analyze_Pragma, case Priority_Specific_Dispatching): Check whether + priority ranges are correct, verify compatibility against task + dispatching and locking policies, and if everything is correct an entry + is added to the table containing priority specific dispatching entries + for this compilation unit. + (Delay_Config_Pragma_Analyze): Delay processing + Priority_Specific_Dispatching pragmas because when processing the + pragma we need to access run-time data, such as the range of + System.Any_Priority. + (Sig_Flags): Add Pragma_Priority_Specific_Dispatching. + Allow pragma Unreferenced as a context item + Add pragma Preelaborable_Initialization + (Analyze_Pragma, case Interface): Interface is extended so that it is + now syntactically and semantically equivalent to Import. + (Analyze_Pragma, case Compile_Time_Warning): Fix error of blowups on + insertion characters. + Add handling for Pragma_Wide_Character_Encoding + (Process_Restrictions_Restriction_Warnings): Ensure that a warning + never supercedes a real restriction, and that a real restriction + always supercedes a warning. + (Analyze_Pragma, case Assert): Set Low_Bound_Known if assert is of + appropriate form. + +2006-10-31 Bob Duff + Ed Schonberg + Robert Dewar + + * exp_ch7.adb (Build_Array_Deep_Procs, Build_Record_Deep_Procs, + Make_Deep_Record_Body): Rename Is_Return_By_Reference_Type to be + Is_Inherently_Limited_Type, because return-by-reference has no meaning + in Ada 2005. + (Find_Node_To_Be_Wrapped): Use new method of determining the result + type of the function containing a return statement, because the + Return_Type field was removed. We now use the Return_Applies_To field. + + * exp_util.ads, exp_util.adb: Use new subtype N_Membership_Test + (Build_Task_Image_Decl): If procedure is not called from an + initialization procedure, indicate that function that builds task name + uses the sec. stack. Otherwise the enclosing initialization procedure + will carry the indication. + (Insert_Actions): Remove N_Return_Object_Declaration. We now use + N_Object_Declaration instead. + (Kill_Dead_Code): New interface to implement -gnatwt warning for + conditional dead code killed, and change implementation accordingly. + (Insert_Actions): Add N_Return_Object_Declaration case. + Correct comment to mention N_Extension_Aggregate node. + (Set_Current_Value_Condition): Call Safe_To_Capture_Value to avoid bad + attempts to save information for global variables which cannot be + safely tracked. + (Get_Current_Value_Condition): Handle conditions the other way round + (constant on left). Also handle right operand of AND and AND THEN + (Set_Current_Value_Condition): Corresponding changes + (Append_Freeze_Action): Remove unnecessary initialization of Fnode. + (Get_Current_Value_Condition): Handle simple boolean operands + (Get_Current_Value_Condition): Handle left operand of AND or AND THEN + (Get_Current_Value_Condition): If the variable reference is within an + if-statement, does not appear in the list of then_statments, and does + not come from source, treat it as being at unknown location. + (Get_Current_Value_Condition): Enhance to allow while statements to be + processed as well as if statements. + (New_Class_Wide_Subtype): The entity for a class-wide subtype does not + come from source. + (OK_To_Do_Constant_Replacement): Allow constant replacement within body + of loop. This is safe now that we fixed Kill_Current_Values. + (OK_To_Do_Constant_Replacement): Check whether current scope is + Standard, before examining outer scopes. + +2006-10-31 Vincent Celier + + * krunch.ads, krunch.adb (Krunch): New Boolean parameter VMS_On_Target. + When True, apply VMS treatment to children of packages A, G, I and S. + For F320-016 + + * fname-uf.adb (Get_File_Name): Call Krunch with OpenVMS_On_Target + +2006-10-31 Robert Dewar + Ed Schonberg + + * freeze.adb: Add handling of Last_Assignment field + (Warn_Overlay): Supply missing continuation marks in error msgs + (Freeze_Entity): Add check for Preelaborable_Initialization + + * g-comlin.adb: Add Warnings (Off) to prevent new warning + + * g-expect.adb: Add Warnings (Off) to prevent new warning + + * lib-xref.adb: Add handling of Last_Assignment field + (Generate_Reference): Centralize handling of pragma Obsolescent here + (Generate_Reference): Accept an implicit reference generated for a + default in an instance. + (Generate_Reference): Accept a reference for a node that is not in the + main unit, if it is the generic body corresponding to an subprogram + instantiation. + + * xref_lib.adb: Add pragma Warnings (Off) to avoid new warnings + + * sem_warn.ads, sem_warn.adb (Set_Warning_Switch): Add processing for + -gnatwq/Q. + (Warn_On_Useless_Assignment): Suppress warning if enclosing inner + exception handler. + (Output_Obsolescent_Entity_Warnings): Rewrite to avoid any messages on + use clauses, to avoid messages on packages used to qualify, and also + to avoid messages from obsolescent units. + (Warn_On_Useless_Assignments): Don't generate messages for imported + and exported variables. + (Warn_On_Useless_Assignments): New procedure + (Output_Obsolescent_Entity_Warnings): New procedure + (Check_Code_Statement): New procedure + + * einfo.ads, einfo.adb (Has_Static_Discriminants): New flag + Change name Is_Ada_2005 to Is_Ada_2005_Only + (Last_Assignment): New field for useless assignment warning + +2006-10-31 Olivier Hainque + + * g-alleve.adb (lvx, stvx): Ceil-Round the Effective Address to the + closest multiple of VECTOR_ALIGNMENT and not the closest multiple of 16. + +2006-10-31 Bob Duff + Robert Dewar + Ed Schonberg + + * g-awk.adb (Default_Session, Current_Session): Compile this file in + Ada 95 mode, because it violates the new rules for AI-318. + + * g-awk.ads: Use overloaded subprograms in every case where we used to + have a default of Current_Session. This makes the code closer to be + correct for both Ada 95 and 2005. + + * g-moreex.adb (Occurrence): Turn off warnings for illegal-in-Ada-2005 + code, relying on the fact that the compiler generates a warning + instead of an error in -gnatg mode. + + * lib-xref.ads (Xref_Entity_Letters): Add entry for new + E_Return_Statement entity kind. + Add an entry for E_Incomplete_Subtype in Xref_Entity_Letters. + + * par.adb (P_Interface_Type_Definition): Addition of one formal to + report an error if the reserved word abstract has been previously found. + (SS_End_Type): Add E_Return for new extended_return_statement syntax. + + * par-ch4.adb (P_Aggregate_Or_Paren_Expr): Improve message for + parenthesized range attribute usage + (P_Expression_No_Right_Paren): Add missing comment about error recovery. + + * par-ch6.adb (P_Return_Object_Declaration): AI-318: Allow "constant" + in the syntax for extended_return_statement. This is not in the latest + RM, but the ARG is expected to issue an AI allowing this. + (P_Return_Subtype_Indication,P_Return_Subtype_Indication): Remove + N_Return_Object_Declaration. We now use N_Object_Declaration instead. + (P_Return_Object_Declaration, P_Return_Subtype_Indication, + P_Return_Statement): Parse the new syntax for extended_return_statement. + + * par-endh.adb (Check_End, Output_End_Deleted, Output_End_Expected, + Output_End_Missing): Add error-recovery code for the new + extended_return_statement syntax; that is, the new E_Return entry on + the scope stack. + + * s-auxdec-vms_64.ads, s-auxdec.ads (AST_Handler): Change type from + limited to nonlimited, because otherwise we violate the new Ada 2005 + rules about returning limited types in function Create_AST_Handler in + s-asthan.adb. + + * sem.adb (Analyze): Add cases for new node kinds + N_Extended_Return_Statement and N_Return_Object_Declaration. + + * sem_aggr.adb (Aggregate_Constraint_Checks): Verify that component + type is in the same category as type of context before applying check, + to prevent anomalies in instantiations. + (Resolve_Aggregate): Remove test for limited components in aggregates. + It's unnecessary in Ada 95, because if it has limited components, then + it must be limited. It's wrong in Ada 2005, because limited aggregates + are now allowed. + (Resolve_Record_Aggregate): Move check for limited types later, because + OK_For_Limited_Init requires its argument to have been resolved. + (Get_Value): When copying the component default expression for a + defaulted association in an aggregate, use the sloc of the aggregate + and not that of the original expression, to prevent spurious + elaboration errors, when the expression includes function calls. + (Check_Non_Limited_Type): Correct code for AI-287, extension aggregates + were missing. We also didn't handle qualified expressions. Now also + allow function calls. Use new common routine OK_For_Limited_Init. + (Resolve_Extension_Aggregate): Minor fix to bad error message (started + with space can upper case letter). + + * sem_ch3.ads, sem_ch3.adb (Create_Constrained_Components): Set + Has_Static_Discriminants flag + (Record_Type_Declaration): Diagnose an attempt to declare an interface + type with discriminants. + (Process_Range_Expr_In_Decl): Do validity checks on range + (Build_Discriminant_Constraints): Use updated form of + Denotes_Discriminant. + (Process_Subtype): If the subtype is a private subtype whose full view + is a concurrent subtype, introduce an itype reference to prevent scope + anomalies in gigi. + (Build_Derived_Record_Type, Collect_Interface_Primitives, + Record_Type_Declaration): The functionality of the subprograms + Collect_Abstract_Interfaces and Collect_All_Abstract_Interfaces + is now performed by a single routine. + (Build_Derived_Record_Type): If the type definition includes an explicit + indication of limitedness, then the type must be marked as limited here + to ensure that any access discriminants will not be treated as having + a local anonymous access type. + (Check_Abstract_Overriding): Issue a detailed error message when an + abstract subprogram was not overridden due to incorrect mode of its + first parameter. + (Analyze_Private_Extension_Declaration): Add support for the analysis of + synchronized private extension declarations. Verify that the ancestor is + a limited or synchronized interface or in the generic case, the ancestor + is a tagged limited type or synchronized interface and all progenitors + are either limited or synchronized interfaces. + Derived_Type_Declaration): Check for presence of private extension when + dealing with synchronized formal derived types. + Process_Full_View): Enchance the check done on the usage of "limited" by + testing whether the private view is synchronized. + Verify that a synchronized private view is completed by a protected or + task type. + (OK_For_Limited_Init_In_05): New function. + (Analyze_Object_Declaration): Move check for limited types later, + because OK_For_Limited_Init requires its argument to have been resolved. + Add -gnatd.l --Use Ada 95 semantics for limited function returns, + in order to alleviate the upward compatibility introduced by AI-318. + (Constrain_Corresponding_Record): If the constraint is for a component + subtype, mark the itype as frozen, to avoid out-of-scope references to + discriminants in the back-end. + (Collect_Implemented_Interfaces): Protect the recursive algorithm of + this subprogram against wrong sources. + (Get_Discr_Value, Is_Discriminant): Handle properly references to a + discriminant of limited type completed with a protected type, when the + discriminant is used to constrain a private component of the type, and + expansion is disabled. + (Find_Type_Of_Object): Do not treat a return subtype that is an + anonymous subtype as a local_anonymous_type, because its accessibility + level is the return type of the enclosing function. + (Check_Initialization): In -gnatg mode, turn the error "cannot + initialize entities of limited type" into a warning. + (OK_For_Limited_Init): Return true for generated nodes, since it + sometimes violates the legality rules. + (Make_Incomplete_Declaration): If the type for which an incomplete + declaration is created happens to be the currently visible entity, + preserve the homonym chain when removing it from visibility. + (Check_Conventions): Add support for Ada 2005 (AI-430): Conventions of + inherited subprograms. + (Access_Definition): If this is an access to function that is the return + type of an access_to_function definition, context is a type declaration + and the scope of the anonymous type is the current one. + (Analyze_Subtype_Declaration): Add the defining identifier of a regular + incomplete subtype to the set of private dependents of the original + incomplete type. + (Constrain_Discriminated_Type): Emit an error message whenever an + incomplete subtype is being constrained. + (Process_Incomplete_Dependents): Transform an incomplete subtype into a + corresponding subtype of the full view of the original incomplete type. + (Check_Incomplete): Properly detect invalid usage of incomplete types + and subtypes. + +2006-10-31 Hristian Kirtchev + + * g-catiio.ads, g-catiio.adb (Value): New function. + Given an input String, try and parse a valid Time value. + +2006-10-31 Vincent Celier + + * g-debpoo.adb (Is_Valid): Correctly compute Offset using + Integer_Address arithmetic, as in Set_Valid. + +2006-10-31 Arnaud Charlet + Robert Dewar + + * gnatcmd.adb (Process_Link): Use Osint.Executable_Name instead of + handling executable extension manually and duplicating code. + + * make.adb: Implement new -S switch + (Gnatmake): Use new function Osint.Executable_Name instead + of handling executable extension manually. + + * prj-util.adb (Executable_Of): Make sure that if an Executable_Suffix + is specified, the executable name ends with this suffix. + Take advantage of Osint.Executable_Name instead of duplicating code. + + * switch-m.adb: Recognize new gnatmake -S switch + + * targparm.ads, targparm.adb (Executable_Extension_On_Target): New + variable. + (Get_Target_Parameters): Set Executable_Extension_On_Target if + available. + + * makeusg.adb: Add line for gnatmake -S switch + +2006-10-31 Vincent Celier + + * gnatlink.adb (Gnatlink): If gcc is not called with -shared-libgcc, + call it with -static-libgcc, as there are some platforms, such as + Darwin, where one of these two switches is compulsory to link. + +2006-10-31 Vincent Celier + + * gnatls.adb: Take into account GPR_PROJECT_PATH, when it is defined, + instead of ADA_PROJECT_PATH, for the project path. + (Gnatls): When displaying the project path directories, use host dir + specs. + + * prj-ext.adb (Prj.Ext elaboration): On VMS, only expand relative path + names in the project path, as absolute paths may correspond to + multi-valued VMS logical names. + +2006-10-31 Vincent Celier + + * g-os_lib.ads, g-os_lib.adb (Locate_Exec_On_Path): Always return an + absolute path name. + (Locate_Regular_File): Ditto + (Change_Dir): Remove, no longer used + (Normalize_Pathname): Do not use Change_Dir to get the drive letter + on Windows. Get it calling Get_Current_Dir. + (OpenVMS): Remove imported boolean, no longer needed. + (Normalize_Pathname)[VMS]: Do not resolve directory names. + (Pid_To_Integer): New function to convert a Process_Id to Integer + +2006-10-31 Thomas Quinot + + * g-socket.ads, g-socket.adb (Close_Selector): Once the signalling + sockets are closed, reset the R_Sig_Socket and W_Sig_Socket components + to No_Socket. + (Selector_Type): Add default value of No_Socket for R_Sig_Socket and + W_Sig_Socket. + +2006-10-31 Robert Dewar + + * g-speche.ads, g-speche.adb: Add special case to recognize misspelling + initial letter o as a zero. + +2006-10-31 Robert Dewar + + * g-spipat.adb (S_To_PE): Remove incorrect use of 0 instead of Str'First + +2006-10-31 Robert Dewar + + * layout.adb (Layout_Record_Type): Deal with non-static subtypes of + variant records + (Layout_Variant_Record): Retrieve the discriminants from the entity + rather than from the type definition, because in the case of a full + type for a private type we need to take the discriminants from the + partial view. + (Layout_Component_List): When applying the Max operator to variants with + a nonstatic size, check whether either operand is static and scale that + operand from bits to storage units before applying Max. + (Layout_Type): In VMS, if a C-convention access type has no explicit + size clause (and does not inherit one in the case of a derived type), + then the size is reset to 32 from 64. + +2006-10-31 Vincent Celier + + * lib-load.adb (Load_Unit): Skip the test for a unit not found when + its file has already been loaded, according to the unit being loaded, + not to the current value of Multiple_Unit_Index. + +2006-10-31 Thomas Quinot + Eric Botcazou + Arnaud Charlet + + * Makefile.in: Set EH mechanism to ZCX for FreeBSD. + (NO_REORDER_ADAFLAGS): New var defined to -fno-toplevel-reorder if + possible. + (a-except.o): Pass it to the compiler. + (gnatlib-shared-vms): Removed -nostartfiles switch in link step. + (LIBGNAT_TARGET_PAIRS for Windows): Avoid the use of the specific + a-calend-mingw.adb version. + + * Makefile.rtl: Added s-dsaser. + Add object entries for Ada.Calendar.[Arithmetic/Formatting/Time_Zones] + (GNATRTL_TASKING_OBJS): Add Ada.Dispatching and + Ada.Dispatching.Round_Robin. + Added new unit Ada.Containers.Restricted_Bounded_Doubly_Linked_Lists + + * Make-lang.in: Remove all references to gt-ada-decl.h. + Add concatenation (s-strops/s-sopco3/s-sopco4/s-sopco5) to compiler + sources. + Add dependency on ada/s-restri.o for GNAT1 and GNATBIND objects. + Update dependencies. + + * system-freebsd-x86.ads: Make ZCX the default EH mechanism for FreeBSD + +2006-10-31 Vincent Celier + + * mlib-utl.adb (Initialized): Remove, no longer used + (Initialize): Remove, no longer used + (Ar): If Ar_Exec is null, get the location of the archive builder and, + if there is one, the archive indexer. Fail if the archive builder cannot + be found. + (Gcc): If the driver path is unknown, get it. Fail if the driver cannot + be found. + +2006-10-31 Ed Schonberg + + * sem_ch10.ads, sem_ch10.adb (Check_Redundant_Withs, + Process_Body_Clauses): If the context of a body includes a use clause + for P.Q then a with_clause for P in the same body is not redundant, + even if the spec also has a with_clause on P. + Add missing continuation mark to error msg + (Build_Limited_Views): A limited view of a type is tagged if its + declaration includes a record extension. + (Analyze_Proper_Body): Set Corresponding_Stub field in N_Subunit + node, even if the subunit has errors. This avoids malfunction by + Lib.Check_Same_Extended_Unit in the presence of syntax errors. + (Analyze_Compilation_Unit): Add circuit to make sure we get proper + generation of obsolescent messages for with statements (cannot do + this too early, or we cannot implement avoiding the messages in the + case of obsolescent units withing obsolescent units). + (Install_Siblings): If the with_clause is on a remote descendant of + an ancestor of the current compilation unit, find whether there is + a sibling child unit that is immediately visible. + (Remove_Private_With_Clauses): New procedure, invoked after completing + the analysis of the private part of a nested package, to remove from + visibility the private with_clauses of the enclosing package + declaration. + (Analyze_With_Clause): Remove Check_Obsolescent call, this checking is + now centralized in Generate_Reference. + (Install_Limited_Context_Clauses): Remove superfluous error + message associated with unlimited view visible through use + and renamings. In addition, at the point in which the error + is reported, we add the backslash to the text of the error + to ensure that it is reported as a single error message. + Use new // insertion for some continuation messages + (Expand_Limited_With_Clause): Use copy of name rather than name itself, + to create implicit with_clause for parent unit mentioned in original + limited_with_clause. + (Install_Limited_With_Unit): Set entity of parent identifiers if the + unit is a child unit. For ASIS queries. + (Analyze_Subunit): If the subunit appears within a child unit, make all + ancestor child units directly visible again. + +2006-10-31 Robert Dewar + + * par-ch10.adb (P_Context_Clause): Minor error message fix + +2006-10-31 Hristian Kirtchev + Javier Miranda + + * par-ch12.adb: Grammar update and cleanup. + (P_Formal_Type_Definition, P_Formal_Derived_Type_Definition): Add + support for synchronized derived type definitions. + Add the new actual Abstract_Present to every call to + P_Interface_Type_Definition. + (P_Formal_Object_Declarations): Update grammar rules. Handle parsing of + a formal object declaration with an access definition or a subtype mark + with a null exclusion. + (P_Generic_Association): Handle association with box, and others_choice + with box, to support Ada 2005 partially parametrized formal packages. + +2006-10-31 Robert Dewar + Javier Miranda + + * par-ch3.adb (P_Range_Or_Subtype_Mark): Check for bad parentheses + (P_Type_Declaration): Remove barrier against the reserved word "limited" + after "abstract" to give support to the new syntax of AARM 3.4 (2/2). + (P_Type_Declaration): Minor code cleanup. Add support for synchronized + private extensions. + (P_Type_Declaration): Add the new actual Abstract_Present to every call + to P_Interface_Type_Definition. + (P_Interface_Type_Definition): Addition of one formal to report an error + if the reserved word abstract has been previously found. + (P_Identifier_Declarations): Update grammar rules. Handle parsing of an + object renaming declaration with an access definition or subtype mark + with a possible null exclusion. + + * par-ch9.adb: Minor error msg fix + + * par-load.adb: Add missing continuation mark to error msg + + * par-tchk.adb: (Wrong_Token): Code cleanup, use concatenation + +2006-10-31 Vincent Celier + + * prj-dect.adb (Parse_Attribute_Declaration): Do not issue warning for + unknown attribute in unknown package or in package that does not need + to be checked. + (Parse_Package_Declaration): Do not issue warning for unknown package in + quiet output. + +2006-10-31 Vincent Celier + + * prj-makr.adb (Packages_To_Check_By_Gnatname): New global constant + (Make): Call Parse with Packages_To_Check_By_Gnatname for parameter + Packages_To_Check. + +2006-10-31 Vincent Celier + + * prj-nmsc.adb (Check_Ada_Name): For children of package A, G, I and S + on VMS, change "__" to '.' before checking the name. + (Record_Ada_Source): Always add the source file name in the list of + of sources, even if it is not the first time, as it is for another + source index. + (Get_Unit): Replace both '_' (after 'a', 'g', 'i' or 's') with a single + dot, instead of replacing only the first '_'. + + * prj-part.adb (Parse): Convert project file path to canonical form + + * prj-proc.adb (Recursive_Process): Make sure that, when a project is + extended, the project id of the project extending it is recorded in its + data, even when it has already been processed as an imported project. + +2006-10-31 Robert Dewar + + * repinfo.adb (List_Entities): Don't list entities from renaming + declarations. + +2006-10-31 Arnaud Charlet + Robert Dewar + + * restrict.ads, restrict.adb (Restriction_Active): Now returns False if + only a restriction warning is active for the given restriction. This is + desirable because we do not want to modify code in the case where only + a warning is set. + (Set_Profile_Restrictions): Make sure that a Profile_Warnings never + causes overriding of real restrictions. + Take advantage of new No_Restrictions constant. + + * raise.h: (__gnat_set_globals): Change profile. + +2006-10-31 Arnaud Charlet + + * rtsfind.adb: Remove s-polint from comment as it exists no more. + + * rtsfind.ads: + Move entity RE_Get_Active_Partition_Id to package System.DSA_Services. + Move all the entities in obsolete package System.PolyORB_Interface to + System.Partition_Interface. + (RE_Storage_Size): New function in System.Tasking. + (RE_Get_Ceiling): New entity. + (RE_Set_Ceiling): New entity. + (RO_PE_Get_Ceiling): New entity. + (RO_RE_Set_Ceiling): New entity. + (Inherit_CPP_DT): New entity + +2006-10-31 Robert Dewar + + * scng.adb (Scan, case of numeric literal): Better msg for identifier + starting with a digit. + +2006-10-31 Ed Schonberg + Thomas Quinot + Javier Miranda + Gary Dismukes + + * sem_attr.ads, sem_attr.adb (Analyze_Access_Attribute): Diagnose + properly an attempt to apply Unchecked_Access to a protected operation. + (OK_Self_Reference): New subprogram to check the legality of an access + attribute whose prefix is the type of an enclosing aggregate. + Generalizes previous mechanism to handle attribute references nested + arbitrarily deep within the aggregate. + (Analyze_Access_Attribute): An access attribute whose prefix is a type + can appear in an aggregate if this is a default-initialized aggregate + for a self-referential type. + (Resolve_Attribute, case Access): Ditto. + Add support for new implementation defined attribute Stub_Type. + (Eval_Attribute, case Attribute_Stub_Type): New case. + (Analyze_Attribute, case Attribute_Stub_Type): New case. + (Stream_Attribute_Available): Implement using new subprogram from + sem_cat, Has_Stream_Attribute_Definition, instead of incorrect + Has_Specified_Stream_Attribute flag. + Disallow Storage_Size and Storage_Pool for access to subprogram + (Resolve_Attribute, case 'Access et al): Take into account anonymous + access types of return subtypes in extended return statements. Remove + accessibility checks on anonymous access types when Unchecked_Access is + used. + (Analyze_Attribute): Add support for the use of 'Class to convert + a class-wide interface to a tagged type. + Add support for the attribute Priority. + (Resolve_Attribute, case Attribute_Access): For Ada_05, add test for + whether the designated type is discriminated with a constrained partial + view and require static matching in that case. + Add local variable Des_Btyp. The Designated_Type + of an access to incomplete subtype is either its non-limited view if + coming from a limited with or its etype if regular incomplete subtype. + + * sem_cat.ads, sem_cat.adb (Validate_Remote_Access_To_Class_Wide_Type): + Fix predicate to identify and allow cases of (expander-generated) + references to tag of designated object of a RACW. + (Validate_Static_Object_Name): In Ada 2005, a formal object is + non-static, and therefore cannot appear as a primary in a preelaborable + package. + (Has_Stream_Attribute_Definition): New subprogram, abstracted from + Has_Read_Write_Attributes. + (Has_Read_Write_Attributes): Reimplement in termes of + Has_Stream_Attribute_Definition. + (Missing_Read_Write_Attributes): When checking component types in a + record, unconditionally call Missing_Read_Write_Attributes recursively + (remove guard checking for Is_Record_Type / Is_Access_Type). + +2006-10-31 Robert Dewar + + * sem_ch11.adb (Analyze_Handled_Statements): Move final test for + useless assignments here and conditionalize it on absence of exception + handlers. + (Analyze_Exception_Handlers): Small code reorganization of error + detection code, for new handling of formal packages. + +2006-10-31 Ed Schonberg + Hristian Kirtchev + + * sem_ch12.ads, sem_ch12.adb (Save_References): If node is an operator + that has been constant-folded, preserve information of original tree, + for ASIS uses. + (Analyze_Formal_Derived_Type): Set the limited present flag of the newly + generated private extension declaration if the formal derived type is + synchronized. Carry synchronized present over to the generated private + extension. + (Validate_Derived_Type_Instance): Ensure that the actual of a + synchronized formal derived type is a synchronized tagged type. + (Instantiate_Formal_Package): When creating the instantiation used to + validate the actual package of a formal declared without a box, check + whether the formal itself depends on a prior actual. + (Instantiate_Formal_Subprogram): Create new entities for the defining + identifiers of the formals in the renaming declaration, for ASIS use. + (Instantiate_Formal_Subprogram, Instantiate_Formal_Type): When creating + a renaming declaration or a subtype declaration for an actual in an + instance, capture location information of declaration in generic, for + ASIS use. + (Instantiate_Formal_Package): Add comments on needed additional tests. + AI-317 (partial parametrization) is fully implemented. + (Validate_Private_Type_Instance): Add check for actual which + must have preelaborable initialization + Use new // insertion for some continuation messages + (Analyze_Formal_Object_Declaration): Change usage of Expression to + Default_Expression. Add type retrieval when the declaration has an + access definition. Update premature usage of incomplete type check. + (Check_Access_Definition): New subsidiary routine. Check whether the + current compilation version is Ada 05 and the supplied node has an + access definition. + (Instantiate object): Alphabetize local variables. Handle the creation + of new renaming declarations with respect to the kind of definition + used - either an access definition or a subtype mark. Guard against + unnecessary error message in the context of anonymous access types after + they have been resolved. Add check for required null exclusion in a + formal object declaration. + (Switch_View): A private subtype of a non-private type needs to be + switched (the base type can have been switched without its private + dependents because of the last branch of Check_Private_View. + (Check_Private_View): Do not recompute Base_Type (T), instead use cached + value from BT. + (Instantiate_Type): Emit an error message whenever a class-wide type of + a tagged incomplete type is used as a generic actual. + (Find_Actual_Type): Extend routine to handle a component type in a child + unit that is imported from a formal package in a parent. + (Validate_Derived_Type_Instance): Check that analyzed formal and actual + agree on constrainedness, rather than checking against ultimate ancestor + (Instantiate_Subprogram_Body): Create a cross-reference link to the + generic body, for navigation purposes. + +2006-10-31 Robert Dewar + Thomas Quinot + + * sem_ch13.adb: Storage pool cannot be given for access to subprogram + type. + (New_Stream_Subprogram): When processing an attribute definition clause + for a stream-oriented subprogram, record an entity node occurring at + the point of clause to use for checking the visibility of the clause, + as defined by 8.3(23) as amended by AI-195. + (New_Stream_Subprogram): New procedure, factoring behaviour from both + New_Stream_Function and New_Stream_Procedure. + (New_Stream_Function, New_Stream_Procedure): Removed. + (Analyze_Attribute_Definition_Clause, case Address): Check new + Alignment_Check check + +2006-10-31 Ed Schonberg + Javier Miranda + Robert Dewar + + * sem_ch4.adb (Try_Primitive_Operation): Code cleanup to ensure that we + generate the same errors compiling under -gnatc. + (Try_Object_Operation): If no candidate interpretation succeeds, but + there is at least one primitive operation with the right name, report + error in call rather than on a malformed selected component. + (Analyze_Selected_Component): If the prefix is an incomplete type from + a limited view, and the full view is available, use the full view to + determine whether this is a prefixed call to a primitive operation. + (Operator_Check): Verify that a candidate interpretation is a binary + operation before checking the type of its second formal. + (Analyze_Call): Add additional warnings for function call contexts not + yet supported. + (Analyze_Allocator): Move the check for "initialization not allowed for + limited types" after analyzing the expression. This is necessary, + because OK_For_Limited_Init looks at the structure of the expression. + Before analysis, we don't necessarily know what sort of expression it + is. For example, we don't know whether F(X) is a function call or an + indexed component; the former is legal in Ada 2005; the latter is not. + (Analyze_Allocator): Correct code for AI-287 -- extension aggregates + were missing. We also didn't handle qualified expressions. Now also + allow function calls. Use new common routine OK_For_Limited_Init. + (Analyze_Type_Conversion): Do not perform some legality checks in an + instance, because the error message will be redundant or spurious. + (Analyze_Overloaded_Selected_Component): Do not do style check when + setting an entity, since we do not know it is the right entity yet. + (Analyze_Selected_Component): Move Generate_Reference call to Sem_Res + (Analyze_Overloaded_Selected_Component): Same change + (Analyze_Selected_Component): Remove unnecessary prefix type retrieval + since regular incomplete subtypes are transformed into corresponding + subtypes of their full views. + (Complete_Object_Operation): Treat name of transformed subprogram call + as coming from source, for browsing purposes. + (Try_Primitive_Operation): If formal is an access parameter, compare + with base type of object to determine whether it is a primitive + operation. + (Operator_Check): If no interpretation of the operator matches, check + whether a use clause on any candidate might make the operation legal. + (Try_Class_Wide_Operation): Check whether the first parameter is an + access type whose designated type is class-wide. + +2006-10-31 Robert Dewar + Ed Schonberg + Gary Dismukes + + * sem_ch5.ads, sem_ch5.adb (Analyze_Loop_Statement): Add circuit to + warn on infinite loops. + Add \\ to some continuation messages + (Analyze_Assignment_Statement): Call Warn_On_Useless_Assignment + (Process_Bounds): If the bounds are integer literals that result from + constant-folding, and they carry a user-defined type, preserve that type + rather than treating this as an integer range. + (Analyze_Exit_Statement): Test for E_Return_Statement in legality check. + (Analyze_Goto_Statement): Test for E_Return_Stateemnt in legality check. + (Analyze_Assignment_Statement): Add call to Check_Elab_Assign for + left hand side of assignment. + (Analyze_Assignment): Add suport to manage assigments to the attribute + priority of a protected object. + (Check_Possible_Current_Value_Condition): Allow fully qualified names + not just identifiers. + (Check_Possible_Current_Value_Condition): Acquire left operand of AND + or AND THEN for possible tracking. + (Analyze_Iteration_Scheme): Check for setting Current_Value for the + case of while loops so we can track values in the loop body. + +2006-10-31 Ed Schonberg + Hristian Kirtchev + Bob Duff + + * sem_ch6.ads, sem_ch6.adb (Analyze_Subprogram_Declaration): A null + procedure cannot be a protected operation (it is a basic_declaration, + not a subprogram_declaration). + (Check_Overriding_Indicator): Rename formal Does_Override to Overridden_ + Subp. Add logic for entry processing. + (Check_Synchronized_Overriding): New procedure in New_Overloaded_Entity. + Determine whether an entry or subprogram of a protected or task type + override an inherited primitive of an implemented interface. + (New_Overloaded_Entity): Add calls to Check_Synchronized_Overriding. + Update the actual used in calls to Check_Overriding_Indicator. + (Analyze_Generic_Subprogram_Body): If the subprogram is a child unit, + generate the proper reference to the parent unit, for cross-reference. + (Analyze_Subprogram_Declaration): Protect Is_Controlling_Formal with + Is_Formal. + Add -gnatd.l --Use Ada 95 semantics for limited function returns, + (Add_Extra_Formal): Revise procedure to allow passing in associated + entity, scope, and name suffix, and handle setting of the new + Extra_Formals field. + (Create_Extra_Formals): Change existing calls to Add_Extra_Formal to + pass new parameters. Add support for adding the new extra access formal + for functions whose calls are treated as build-in-place. + (Analyze_A_Return_Statement): Correct casing in error message. + Move Pop_Scope to after Analyze_Function_Return, because an extended + return statement really is a full-fledged scope. Otherwise, visibility + doesn't work right. Correct use of "\" for continuation messages. + (Analyze_Function_Return): Call Analyze on the Obj_Decl, rather than + evilly trying to call Analyze_Object_Declaration directly. Otherwise, + the node doesn't get properly marked as analyzed. + (Analyze_Subprogram_Body): If subprogram is a function that returns + an anonymous access type that denotes a task, build a Master Entity + for it. + (Analyze_Return_Type): Add call to Null_Exclusion_Static_Checks. Verify + proper usage of null exclusion in a result definition. + (Process_Formals): Code cleanup and new error message. + (Process_Formals): Detect incorrect application of null exclusion to + non-access types. + (Conforming_Types): Handle conformance between [sub]types and itypes + generated for entities that have null exclusions applied to them. + (Maybe_Primitive_Operation): Add an additional type retrieval when the + base type is an access subtype. This case arrises with null exclusions. + (New_Overloaded_Entity): Do not remove the overriden entity from the + homonym chain if it corresponds with an abstract interface primitive. + (Process_Formals): Replace membership test agains Incomplete_Kind with a + call to the synthesized predicate Is_Incomplete_Type. + (Analyze_Subprogram_Body): Check wrong placement of abstract interface + primitives. + (Analyze_Subprogram_Declaration): Check that abstract interface + primitives are abstract or null. + (Analyze_Subprogram_Specification): Remove previous check for abstract + interfaces because it was not complete. + (Has_Interface_Formals): Removed. + +2006-10-31 Ed Schonberg + Javier Miranda + + * sem_ch7.adb (Check_Anonymous_Access_Types): New procedure, subsidiary + of Analyze_Package_Body, to create Itype references for anonymous + access types created in the package declaration, whose designated types + may have only a limited view. + (Analyze_Package_Specification): For the private part of a nested + package, install private_with_clauses of enclosing compilation unit if + we are in its visible part. + (Declare_Inherited_Private_Subprograms): Complete barrier + to ensure that the primitive operation has an alias to some parent + primitive. This is now required because, after the changes done for the + implementation of abstract interfaces, the contents of the list of + primitives has entities whose alias attribute references entities of + such list of primitives. + (Analyze_Package_Specification): Simplify code that handles parent units + of instances and formal packages. + (Uninstall_Declarations): Check the convention consistency among + primitive overriding operations of a tagged record type. + +2006-10-31 Robert Dewar + Hristian Kirtchev + Javier Miranda + Ed Schonberg + + * sem_ch8.adb: Minor error msg rewording + (Undefined): When checking for misspellings, invert arguments (to get + expected and found set right) + (Analyze_Subprogram_Renaming): Propagate Is_Pure, Is_Preelaborated + (Analyze_Generic_Renaming): Same fix + (Use_One_Package): Do not take into account the internal entities of + abstract interfaces during the analysis of entities that are marked + as potentially use-visible. + (Find_Type): Handle the case of an attribute reference for + implementation defined attribute Stub_Type (simply let the analysis of + the attribute reference rewrite it). + (Use_One_Type, End_Use_Type): Reject a reference to a limited view of a + type that appears in a Use_Type clause. + (Analyze_Object_Renaming): Add support for renaming of the Priority + attribute. + (Find_Type): In Ada 2005, a task type can be used within its own body, + when it appears in an access definition. + (Analyze_Object_Renaming): Remove warning on null_exclusion. + (Analyze_Object_Renaming): Introduce checks for required null exclusion + in a formal object declaration or in a subtype declaration. + (Analyze_Subprogram_Renaming): Add call to Check_Null_Exclusion. + (Check_Null_Exclusion): New local routine to + Analyze_Subprogram_Renaming. Check whether the formals and return + profile of a renamed subprogram have required null exclusions when + their counterparts of the renaming already impose them. + (In_Generic_Scope): New local routine to Analyze_Object_Renaming. + Determine whether an entity is inside a generic scope. + (In_Open_Scope): First pass of documentation update. + (Find_Expanded_Name): Add support for shadow entities associated with + limited withed packages. This is required to handle nested packages. + (Analyze_Package_Renaming): Remove the restriction imposed by AI-217 + that makes a renaming of a limited withed package illegal. + +2006-10-31 Hristian Kirtchev + Ed Schonberg + + * sem_ch9.adb (Analyze_Protected_Definition): Remove call to + Check_Overriding_Indicator. + (Analyze_Task_Definition): Ditto. + (Analyze_Protected_Type, Analyze_Task_Type): Code cleanup. + (Check_Overriding_Indicator): To find overridden interface operation, + examine only homonyms that have an explicit subprogram declaration, not + inherited operations created by an unrelated type derivation. + (Check_Overriding_Indicator): When checking for the presence of "null" + in a procedure, ensure that the queried node is a procedure + specification. + (Matches_Prefixed_View_Profile): Add mechanism to retrieve the parameter + type when the formal is an access to variable. + (Analyze_Protected_Type): Add check for Preelaborable_Initialization + (Analyze_Task_Type): Same addition + (Analyze_Entry_Declaration): Call Generate_Reference_To_Formals, to + provide navigation capabilities for entries. + +2006-10-31 Hristian Kirtchev + Ed Schonberg + Javier Miranda + Gary Dismukes + + * sem_disp.adb (Check_Dispatching_Operation): Do not flag subprograms + inherited from an interface ancestor by another interface in the + context of an instance as 'late'. + (Is_Tag_Indeterminate, Propagate_Tag): Handle properly the dereference + of a call to a function that dispatches on access result. + (Check_Dispatching_Operation): In case of late overriding of a primitive + that covers abstract interface subprograms we register it in all the + secondary dispatch tables associated with abstract interfaces. + (Check_Dispatching_Call): Add check that a dispatching call is not made + to a function with a controlling result of a limited type. This is a + current implementation restriction. + (Check_Controlling_Formal): Remove bogus checks for E.2.2(14). + (Check_Dispatching_Operation): Do no emit a warning if the controlling + argument is an interface type that is a generic formal. + (Is_Interface_Subprogram): Removed. + (Check_Dispatching_Operation): If the subprogram is not a dispatching + operation, check the formals to handle the case in which it is + associated with an abstract interface type. + +2006-10-31 Robert Dewar + Ed Schonberg + + * sem_elab.ads, sem_elab.adb (Check_Elab_Assign): New procedure + Add new calls to this procedure during traversal + (Activate_Elaborate_All_Desirable): Do not set elaboration flag on + another unit if expansion is disabled. + +2006-10-31 Robert Dewar + + * sem_eval.adb (Compile_Time_Compare): Make use of information from + Current_Value in the conditional case, to evaluate additional + comparisons at compile time. + +2006-10-31 Ed Schonberg + Hristian Kirtchev + Javier Miranda + + * sem_type.adb (Add_One_Interp): If node is an indirect call, preserve + subprogram type to provide better diagnostics in case of ambiguity. + (Covers): Handle coverage of formal and actual anonymous access types in + the context of generic instantiation. + (Covers/Interface_Present_In_Ancestors): Use the base type to manage + abstract interface types; this is required to handle concurrent types + with discriminants and abstract interface types. + (Covers): Include type coverage of both regular incomplete subtypes and + incomplete subtypes of incomplete type visibles through a limited with + clause. + +2006-10-31 Robert Dewar + Hristian Kirtchev + Ed Schonberg + + * sem_util.ads, sem_util.adb (Enter_Name): Exclude -gnatwh warning + messages for entities in packages which are not used. + (Collect_Synchronized_Interfaces): New procedure. + (Overrides_Synchronized_Primitive): New function. + (Denotes_Discriminant): Extend predicate to apply to task types. + Add missing continuation marks in error msgs + (Unqualify): New function for removing zero or more levels of + qualification from an expression. There are numerous places where this + ought to be used, but we currently only deal properly with zero or one + level. + (In_Instance); The analysis of the actuals in the instantiation of a + child unit is not within an instantiation, even though the parent + instance is on the scope stack. + (Safe_To_Capture_Value): Exclude the case of variables that are + renamings. + (Check_Obsolescent): Removed + (Is_Aliased_View): A reference to an enclosing instance in an aggregate + is an aliased view, even when rewritten as a reference to the target + object in an assignment. + (Get_Subprogram_Entity): New function + (Known_To_Be_Assigned): New function + (Type_Access_Level): Compute properly the access level of a return + subtype that is an anonymous access type. + (Explain_Limited_Type): Correct use of "\" for continuation messages. + (Is_Transfer): The new extended_return_statement causes a transfer of + control. + (Has_Preelaborable_Initialization): New function + (Has_Null_Exclusion): New function. Given a node N, determine whether it + has a null exclusion depending on its Nkind. + Change Is_Lvalue to May_Be_Lvalue + (May_Be_Lvalue): Extensive additional code to deal with subprogram + arguments (IN parameters are not Lvalues, IN OUT parameters are). + (Safe_To_Capture_Value): Extend functionality so it can be used for + the current value condition case. + (Has_Compatible_Alignment): New function + (Is_Dependent_Component_Of_Mutable_Object): Revise the tests for mutable + objects to handle the Ada 2005 case, where aliasedness no longer implies + that the object is constrained. In particular, for dereferenced names, + the designated object must be assumed to be unconstrained. + (Kill_Current_Values): Properly deal with the case where we encounter + a loop in the scope chain. + (Safe_To_Capture_Value): Do not let a loop stop us from capturing + a value. + (Compile_Time_Constraint_Error): Improve error message in error case + + * exp_ch13.adb (Expand_N_Freeze_Entity): Remove the freezing node + associated with entities of abstract interface primitives. + Call Apply_Address_Clause_Check instead of Apply_Alignment_Check + +2006-10-31 Robert Dewar + + * s-osinte-tru64.adb: + Mark Asm statements Volatile to prevent warnings (seems a + reasonable change anyway) + Fixes new warnings + + * s-mastop-irix.adb: Add Volatile to Asm statements + Suppresses warning, and seems appropriate in any case + + * s-osinte-vms.adb: Add Volatile to Asm statement + + * s-vaflop-vms-alpha.adb: Add Volatile to Asm statements + + * exp_code.ads, exp_code.adb (Asm_Input_Value): Note that Error can be + returned. + Add call to Check_Code_Statement + +2006-10-31 Robert Dewar + Ed Schonberg + Bob Duff + + * sinfo.ads, sinfo.adb (Set_Synchronized_Present, + Synchronized_Present): Add Formal_Derived_Type_Definition and + Private_Extension_Declaration to the list of assertions. + (Is_Entry_Barrier_Function): New flag + (Has_Self_Reference): New flag on aggregates, to indicate that they + contain a reference to the enclosing type, inserted through a default + initialization. + (Next_Rep_Item): Move from Node4 to Node5. + (Entity): Add this field for N_Attribute_Definition_Clause. + (Comes_From_Extended_Return_Statement): New flag on N_Return_Statement + (N_Return_Object_Declaration): Remove this node kind. We now use + N_Object_Declaration instead. + (Actual_Designated_Subtype): Move to a different place to make room in + N_Extended_Return_Statement. + (Procedure_To_Call): Move to a different place to make room in + N_Extended_Return_Statement. + (Return_Type): Removed this field to make room in return statements + (both kinds). + (Return_Statement_Entity): New field in return statements, in part to + replace Return_Type, and in part to support the fact that return + statements are now pushed on the scope stack during semantic analysis. + (Return_Object_Declarations): New field to support extended return + statements. + (N_Extended_Return_Statement): New node for extended_return_statement + nonterminal. + (N_Return_Object_Declaration): New node for part of + extended_return_statement nonterminal. Needed because all the necessary + fields won't fit in N_Extended_Return_Statement. + Generic_associations now carry the Box_Present flag, to indicate a + default for an actual in a partially parametrized formal package. + + * snames.h, snames.ads, snames.adb: Add definition for Validity_Check + (Preset_Names): Add entries for Priority_Specific_Dispatching pragma + and for the new predefined dispatching policies: EDF_Across_Priorities, + Non_Preemptive_Within_Priorities, and Round_Robin_Within_Priorities. + Introduce new name Stub_Type for implementation defined attribute. + Add pragma Preelaborable_Initialization + Add entry for Priority attribute. + Add Pragma_Wide_Character_Encoding + (Get_Convention_Name): Given a convention id, this function returns the + corresponding name id from the names table. + +2006-10-31 Ed Schonberg + Robert Dewar + Bob Duff + + * sprint.adb (Sprint_Node_Actual, case Parameter_Specification): Do not + print null exclusion twice in the case of an access definition, + Implement new -gnatL switch + Remove N_Return_Object_Declaration. We now use + N_Object_Declaration instead. Implement the case for + N_Extended_Return_Statement. Alphabetize the cases. + Add cases for new nodes N_Extended_Return_Statement and + N_Return_Object_Declaration. The code is not yet written. + Update the output for N_Formal_Object_Declaration + and N_Object_Renaming_Declaration. + (Write_Itype): Account for the case of a modular integer subtype whose + base type is private. + +2006-10-31 Arnaud Charlet + + * s-restri.ads, s-restri.adb: Mark this package as Preelaborate. + Remove elaboration code, now done in the binder. + + * s-rident.ads: Make this unit Preelaborate. + (No_Restrictions): New constant used to clean up code and follow + preelaborate constraints. + + * s-stalib.adb: + Add System.Restrictions dependence, referenced directly from the + binder generated file. + +2006-10-31 Gary Dismukes + + * s-scaval.adb (Initialize): Add new Boolean flag AFloat that is set + True when AAMP extended floating-point is in use (48-bit). Change type + ByteLF to ByteLLF, add new array type ByteLF and condition the size of + the two byte array types on AFloat. Change type of IV_Ilf overlay + variable from Byte8 to ByteLF. Add appropriate initializations of + floating-point overlays for AAMP cases. + +2006-10-31 Javier Miranda + + * s-tpoben.ads, s-tpoben.adb, s-taprob.ads, s-taprob.adb + (Get_Ceiling): New subprogram that returns + the ceiling priority of the protected object. + (Set_Ceiling): New subprogram that sets the new ceiling priority of + the protected object. + + * s-tarest.adb: (Create_Restricted_Task): Fix potential CE. + + * s-taskin.ads, s-taskin.adb: (Storage_Size): New function. + +2006-10-31 Jose Ruiz + + * s-tpobop.adb (Requeue_Call): Introduce a dispatching point when + requeuing to the same protected object to give higher priority tasks + the opportunity to execute. + +2006-10-31 Robert Dewar + + * widechar.adb (Is_Start_Of_Wide_Char): In case of brackets encoding, + add more precise check for the character sequence that follows '[' to + avoid possible confusion in case if '[' is the last character of a + string literals. + (Scan_Wide): Always allow brackets encoding + +2006-10-31 Olivier Hainque + + * s-stchop.ads: make this unit preelaborate. This is desirable in + general and made mandatory by the use of this unit by s-taprop which + is itself preelaborate. + + * s-stchop-vxworks.adb (Set_Stack_Info, Task_Descriptor type): Add + Td_Events component. + +2006-10-31 Vincent Celier + + * a-dirval-vms.adb (Invalid_Character): Specify that digits are allowed + in file names. + +2006-10-31 Vincent Celier + + * a-direct.ads, a-direct.adb (Search): New procedure in Ada 2005 + +2006-10-31 Vincent Celier + + * makegpr.adb (Check_Compilation_Needed): Take into account path names + with spaces. + (Check_Compilation_Needed): When checking a C or C++ source, do not + resolve symbolic links. + (Display_Command): New Boolean parameter Ellipse, defaulted to False. + When not in verbose mode and Ellipse is True, display "..." for the + first argument with Display set to False. + (Build_Global_Archive): Always set Display True for the first object + file. Call Display_Command with Ellipse set to True. + +2006-10-31 Matt Heaney + + * a-crbtgo.ads: Commented each subprogram + + * a-crbtgo.adb: Added reference to book from which algorithms were + adapted. + + * a-crbtgk.ads, a-crbtgk.adb (Generic_Insert_Post): pass flag to + indicate which child. + (Generic_Conditional_Insert): changed parameter name from "Success" to + "Inserted". + (Generic_Unconditional_Insert_With_Hint): improved algorithm + + * a-coorse.adb (Replace_Element): changed parameter name in call to + conditional insert operation. + + * a-convec.adb, a-coinve.adb (Insert): removed obsolete comment + + * a-cohama.adb (Iterate): manipulate busy-bit here, instead of in + Generic_Iteration + + * a-ciorse.adb (Replace_Element): changed parameter name in call to + conditional insert operation. + + * a-cihama.adb (Iterate): manipulate busy-bit here, instead of in + Generic_Iteration. + + * a-cidlli.ads, a-cidlli.adb (Splice): Position param is now mode in + instead of mode inout. + + * a-chtgop.adb (Adjust): modified comments to reflect current AI-302 + draft + (Generic_Read): preserve existing buckets array if possible + (Generic_Write): don't send buckets array length anymore + + * a-cdlili.ads, a-cdlili.adb (Splice): Position param is now mode in + instead of mode inout. + + * a-cihase.adb (Difference): iterate over smaller of Tgt and Src sets + (Iterate): manipulate busy-bit here, instead of in Generic_Iteration + + * a-cohase.adb (Difference): iterate over smaller of Tgt and Src sets + (Iterate): manipulate busy-bit here, instead of in Generic_Iteration + (Replace_Element): local operation is now an instantiation + + * a-chtgke.ads, a-chtgke.adb (Generic_Conditional_Insert): manually + check current length. + (Generic_Replace_Element): new operation + +2006-10-31 Doug Rupp + + * g-trasym-vms-alpha.adb: Dummy_User_Act_Proc: New function. + Call TBK$SYMBOLIZE without omitting parameters. + +2006-10-31 Vincent Celier + + * symbols-processing-vms-ia64.adb, + symbols-processing-vms-alpha.adb (Process): Do not include symbols + that come from generic instantiations in bodies. + +2006-10-31 Pat Rogers + + * a-rttiev.ads, a-rttiev.adb: + This is a significant redesign primarily for the sake of automatic + timer task termination but also to fix a design flaw. + Therefore we are now using an RTS lock, instead of a protected + object, to provide mutual exclusion to the queue of pending events + and the type Timing_Event is no longer a protected type. + +2006-10-31 Robert Dewar + Cyrille Comar + Ben Brosgol + + * debug.adb: Update flags documentation + + * gnat_ugn.texi: Add documentation for new -gnatwq switch + Clean up documentation for several other warning switches + Clarify how task stack size can be specified with various + versions of Windows. + Add note that -gnatVo includes ranges including loops + Add documentation for -gnatL switch + Add note on elaboration warning for initializing variables + Add documentation for new -gnatwt warning switch + Document new form of pragma Warnings (On|Off, string) + Add comment on use of pragma Warnings to control warnings + Add documentation for -gnatjnn switch + Modify section on interfacing with C for VMS 64-bit. + Add doc for -gnatVe/E + Add documentation of new warning flags -gnatww/-gnatwW + Add warnings about address clause overlays to list of warnings + (Exception Handling Control): Document that the option --RTS must be + used consistently for gcc and gnatbind. + Clarify that inlining is not always possible + Update documentation on pragma Unchecked_Union. + + * gnat_rm.texi: + Add documentation for new extended version of pragma Obsolescent + Add documentation for implementation defined attribute 'Stub_Type. + Add note on use of Volatile in asm statements + Add documentation on use of pragma Unreferenced in context clause + Document new form of pragma Warnings (On|Off, pattern) + Document pragma Wide_Character_Encoding + Add note that pragma Restrictions (No_Elaboration_Code) is only fully + enforced if code generation is active. + Add section on pragma Suppress to document GNAT specific check + Alignment_Check + Clarify difference between No_Dispatching_Calls & No_Dispatch. + Add documentation for pragma Restrictions (No_Elaboration_Code) + + * gnat-style.texi: + Add comments on layout of subprogram local variables in the + presence of nested subprograms. + + * ug_words: Resync. + + * elists.ads: Minor reformatting + Node returns Node_Or_Entity_Id (doc change only) + + * xgnatugn.adb: Replace ACADEMICEDITION with GPLEDITION + + * g-arrspl.ads (Create): Update comments. + + * sem.ads: Add details on the handling of the scope stack. + + * usage.adb: Update documentation. + + * validsw.ads, validsw.adb: + Add definition of Validity_Check_Components and implement -gnatVe/E + + * vms_data.ads: Add missing VMS qualifiers. + + * s-addope.ads: Add documentation on overflow and divide by zero + +2006-10-31 Robert Dewar + Thomas Quinot + Arnaud Charlet + + * fmap.adb: Put routines in alpha order + + * g-boumai.ads: Remove redundant 'in' keywords + + * g-cgi.adb: Minor reformatting + + * g-cgi.ads: Remove redundant 'in' keywords + + * get_targ.adb: Put routines in alpha order + + * prj-attr.ads: Minor reformatting + + * s-atacco.ads: Minor reformatting + + * scn.adb: Put routines in alpha order + + * sinput-l.adb: Minor comment fix + + * sinput-p.adb: Minor comment fix + + * s-maccod.ads: Minor reformatting + + * s-memory.adb: Minor reformatting + + * s-htable.adb: Fix typo in comment. + + * s-secsta.adb: Minor comment update. + + * s-soflin.adb: Minor reformatting + + * s-stoele.ads: + Add comment about odd qualification in Storage_Offset declaration + + * s-strxdr.adb: + Remove unnecessary 'in' keywords for formal parameters. + + * treeprs.adt: Minor reformatting + + * urealp.adb: Put routines in alpha order + + * s-wchcon.ads, s-wchcon.adb (Get_WC_Encoding_Method): New version + taking string. + + * s-asthan-vms-alpha.adb: Remove redundant 'in' keywords + + * g-trasym-vms-ia64.adb: Remove redundant 'in' keywords + + * env.c (__gnat_unsetenv): Unsetenv is unavailable on LynxOS, so + workaround as on other platforms. + + * g-eacodu-vms.adb: Remove redundant 'in' keywords + * g-expect-vms.adb: Remove redundant 'in' keywords + + * gnatdll.adb (Add_Files_From_List): Handle Name_Error and report a + clear error message if the list-of-files file cannot be opened. + + * g-thread.adb (Unregister_Thread_Id): Add use type Thread_Id so the + equality operator is always visible. + + * lang.opt: Woverlength-strings: New option. + + * nmake.adt: + Update copyright, since nmake.ads and nmake.adb have changed. + + * osint-b.ads, osint-b.adb (Time_From_Last_Bind): removed function . + (Binder_Output_Time_Stamps_Set): removed. + (Old_Binder_Output_Time_Stamp): idem. + (New_Binder_Output_Time_Stamp): idem. + (Recording_Time_From_Last_Bind): idem. + (Recording_Time_From_Last_Bind): Make constant. + + * output.ads, output.adb (Write_Str): Allow LF characters + (Write_Spaces): New procedure + + * prepcomp.adb (Preproc_Data_Table): Change Increment from 5% to 100% + + * inline.adb: Minor reformatting + + * s-asthan-vms-alpha.adb: Remove redundant 'in' keywords + + * s-mastop-vms.adb: Remove redundant 'in' keywords + + * s-osprim-vms.adb: Remove redundant 'in' keywords + + * s-trafor-default.adb: Remove redundant 'in' keywords + + * 9drpc.adb: Remove redundant 'in' keywords + + * s-osinte-mingw.ads: Minor reformatting + + * s-inmaop-posix.adb: Minor reformatting + + * a-direio.ads: Remove quotes from Compile_Time_Warning message + + * a-exexda.adb: Minor code reorganization + + * a-filico.adb: Minor reformatting + + * a-finali.adb: Minor reformatting + + * a-nudira.ads: Remove quote from Compile_Time_Warning message + + * a-numeri.ads: Minor reformatting + + * a-sequio.ads: Remove quotes from Compile_Time_Warning message + + * exp_pakd.ads: Fix obsolete comment + + * a-ztenau.adb, a-ztenio.adb, a-wtenau.adb, a-tienau.adb, + a-wtenio.adb (Put): Avoid assuming low bound of string is 1. + Probably not a bug, but certainly neater and more efficient. + + * a-tienio.adb: Minor reformatting + + * comperr.adb (Compiler_Abort): Call Cancel_Special_Output at start + Avoid assuming low bound of string is 1. + + * gnatbind.adb: Change Bindusg to package and rename procedure as + Display, which now ensures that it only outputs usage information once. + (Scan_Bind_Arg): Avoid assuming low bound of string is 1. + + * g-pehage.adb (Build_Identical_Keysets): Replace use of 1 by + Table'First. + + * g-regpat.adb (Insert_Operator): Add pragma Warnings (Off) to kill + warning. + (Match): Add pragma Assert to ensure that Matches'First is zero + + * g-regpat.ads (Match): Document that Matches lower bound must be zero + + * makeutl.adb (Is_External_Assignment): Add pragma Assert's to check + documented preconditions (also kills warnings about bad indexes). + + * mdll.adb (Build_Dynamic_Library): Avoid assumption that Afiles'First + is 1. + (Build_Import_Library): Ditto; + + * mdll-utl.adb: (Gnatbind): Avoid assumption that Alis'First = 1 + + * rtsfind.adb (RTE_Error_Msg): Avoid assuming low bound of string is 1. + + * sem_case.adb (Analyze_Choices): Add pragma Assert to check that + lower bound of choice table is 1. + + * sem_case.ads (Analyze_Choices): Document that lower bound of + Choice_Table is 1. + + * s-imgdec.adb (Set_Decimal_Digits): Avoid assuming low bound of + string is 1. + + * uintp.adb (Init_Operand): Document that low bound of Vec is always 1, + and add appropriate Assert pragma to suppress warnings. + + * atree.h, atree.ads, atree.adb + Change Elist24 to Elist25 + Add definitions of Field28 and Node28 + (Traverse_Field): Use new syntactic parent table in sinfo. + + * cstand.adb: Change name Is_Ada_2005 to Is_Ada_2005_Only + + * itypes.adb: Change name Is_Ada_2005 to Is_Ada_2005_Only + + * exp_tss.adb: Put routines in alpha order + + * fe.h: Remove redundant declarations. + +2006-10-23 Rafael Ávila de Espíndola + + * utils.c (builtin_function): Rename to gnat_builtin_function. + Move common code to add_builtin_function. + * misc.c (LANG_HOOKS_BUILTIN_FUNCTION): Define as + gnat_builtin_function. + * gigi.h (builtin_function): Rename to gnat_builtin_function. + Change the signature. + +2006-10-16 Brooks Moses + + * Makefile.in: Add TEXI2PDF definition. + * Make-lang.in: Add "ada.pdf" target. + +2006-10-03 Kazu Hirata + + * decl.c, utils.c: Fix comment typos. + * utils.c: Fix a typo. + +2006-09-28 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : Do not set "const" flag + on "pure" Ada subprograms if SJLJ exceptions are used. + * trans.c (Handled_Sequence_Of_Statements_to_gnu): Set TREE_NO_WARNING + on the declaration node of JMPBUF_SAVE. + * utils.c (init_gigi_decls): Set DECL_IS_PURE on the declaration nodes + of Get_Jmpbuf_Address_Soft and Get_GNAT_Exception. + * utils2.c (build_call_0_expr): Do not set TREE_SIDE_EFFECTS. + +2006-08-20 Laurent Guerby + + PR ada/28716 + g-socket.adb (Bind_Socket): Call Set_Address. + +2006-09-15 Eric Botcazou + + PR ada/15802 + * decl.c (same_discriminant_p): New static function. + (gnat_to_gnu_entity) : When there is a parent + subtype and we have discriminants, fix up the COMPONENT_REFs + for the discriminants to make them reference the corresponding + fields of the parent subtype after it has been built. + +2006-09-15 Roger Sayle + + PR ada/18817 + * utils.c (max_size): Perform constant folding of (A ? B : C) - D + into A ? B - D : C - D when calculating the size of a MINUS_EXPR. + +2006-09-13 Olivier Hainque + + PR ada/29025 + * trans.c (gnat_gimplify_expr) : When taking the address + of a SAVE_EXPR, just make the operand addressable/not-readonly and + let the common gimplifier code make and propagate a temporary copy. + (call_to_gnu): Clarify the use of SAVE_EXPR for not addressable + out/in-out actuals and defer setting the addressable/readonly bits + to the gimplifier. + +2006-09-13 Eric Botcazou + + PR ada/28591 + * decl.c (components_to_record): Defer emitting debug info for the + record type associated with the variant until after we are sure to + actually use it. + +2006-09-13 Eric Botcazou + + PR ada/21952 + * gigi.h (gnat_internal_attribute_table): Declare. + * misc.c (LANG_HOOKS_ATTRIBUTE_TABLE): Define to above. + * utils.c (gnat_internal_attribute_table): New global variable. + (builtin_function): Always call decl_attributes on the builtin. + (handle_const_attribute): New static function. + (handle_nothrow_attribute): Likewise. + +2006-07-28 Volker Reichelt + + * Make-lang.in: Use $(HEADER_H) instead of header.h in dependencies. + +2006-06-23 Olivier Hainque + + * misc.c (gnat_type_max_size): Look at TYPE_ADA_SIZE if we have + not been able to get a constant upper bound from TYPE_SIZE_UNIT. + +2006-06-20 James A. Morrison + Eric Botcazou + + PR ada/18692 + * Make-lang.in: Add check-gnat to lang_checks. Rename existing + check-gnat into check-acats. + +2006-06-17 Karl Berry + + * gnat-style.texi (@dircategory): Use "Software development" + instead of "Programming", following the Free Software Directory. + +2006-06-12 John David Anglin + + PR ada/27944 + * s-taprop-hpux-dce.adb: Delete redundant 'with System.Parameters'. + +2006-06-06 Laurent Guerby + + PR ada/27769 + mlib-utl.adb: Use Program_Name. + +2006-05-28 Kazu Hirata + + * decl.c, env.c, gigi.h, init.c, initialize.c, raise-gcc.c, + sem_ch13.adb, sysdep.c, targtyps.c, tb-alvxw.c, tracebak.c, + trans.c, utils.c: Fix comment typos. Follow spelling + conventions. + * gnat_rm.texi, gnat_ugn.texi, : Fix typos. Follow spelling + conventions. + +2006-05-19 Nicolas Setton + + * misc.c (gnat_dwarf_name): New function. + (LANG_HOOKS_DWARF_NAME): Define to it. + +2006-05-14 H.J. Lu + + * Make-lang.in (ada/decl.o): Replace target.h with $(TARGET_H). + (ada/misc.o): Likewise. + (ada/utils.o): Likewise. + +2006-04-08 Aurelien Jarno + + * Makefile.in: Add Ada support for GNU/kFreeBSD. + * s-osinte-kfreebsd-gnu.ads: New file. + +2006-03-29 Carlos O'Donell + + * Make-lang.in: Rename docdir to gcc_docdir. + +2006-03-04 Eric Botcazou + + * gigi.h (get_ada_base_type): Delete. + * utils2.c (get_ada_base_type): Likewise. + * trans.c (convert_with_check): Operate in the real base type. + +2006-03-03 Richard Kenner + + * uintp.adb (Num_Bits): Handle Uint_Int_First specially. + +2006-03-02 Richard Sandiford + + * utils.c (create_var_decl): Use have_global_bss_p when deciding + whether to make the decl common. + +2006-02-20 Rafael Ávila de Espíndola + + * Make-lang.in (Ada): Remove. + (.PHONY): Remove Ada + +2006-02-17 Ed Schonberg + + * sem_ch4.adb (Find_Boolean_Types): If one of the operands is an + aggregate, check the interpretations of the other operand to find one + that may be a boolean array. + + (Analyze_Selected_Component): Fix flow-of-control typo in case where + the prefix is a private extension. + +2006-02-17 Eric Botcazou + + PR ada/26315 + * utils2.c (find_common_type): If both input types are BLKmode and + have the same constant size, keep using the first one. + + * bindgen.adb: (Gen_Versions_Ada): Revert previous workaround. + + * decl.c (gnat_to_gnu_entity): Only check TREE_OVERFLOW for a constant. + + * misc.c (gnat_handle_option): New case for -Woverlength-strings. + +2006-02-17 Jose Ruiz + + * s-taprop-irix.adb, s-taprop-hpux-dce.adb, s-taprop-linux.adb, + s-taprop-solaris.adb, s-taprop-vms.adb, s-taprop-mingw.adb, + s-taprop-posix.adb, s-taprop-vxworks.adb, s-taprop-lynxos.adb, + s-taprop-tru64.adb (Set_False, Set_True, Suspend_Until_True): Add + Abort_Defer/Undefer pairs to avoid the possibility of a task being + aborted while owning a lock. + +2006-02-17 Javier Miranda + Robert Dewar + + * exp_ch4.adb (Expand_N_Allocator): If the allocated object is accessed + through an access to class-wide interface we force the displacement of + the pointer to the allocated object to reference the corresponding + secondary dispatch table. + (Expand_N_Op_Divide): Allow 64 bit divisions by small power of 2, + if Long_Shifts are supported on the target, even if 64 bit divides + are not supported (configurable run time mode). + (Expand_N_Type_Conversion): Do validity check if validity checks on + operands are enabled. + (Expand_N_Qualified_Expression): Do validity check if validity checks + on operands are enabled. + +2006-02-17 Ed Schonberg + + * exp_dbug.adb (Debug_Renaming_Declaration): Indicate that the entity + must be materialized when the renamed expression is an explicit + dereference. + +2006-02-17 Ed Schonberg + + * freeze.adb (Statically_Discriminated_Components): Return false if + the bounds of the type of the discriminant are not static expressions. + + * sem_aggr.adb (Check_Static_Discriminated_Subtype): Return false if + the bounds of the discriminant type are not static. + +2006-02-17 Robert Dewar + + * g-os_lib.adb (Copy_File): Make sure that if From has an Invalid_FD, + then we close To if it is valid. + +2006-02-17 Vasiliy Fofanov + + * init.c (facility_resignal_table): new array + (__gnat_default_resignal_p): enhance default predicate to resignal if + VMS condition has one of the predefined facility codes. + +2006-02-17 Vasiliy Fofanov + + * Makefile.in: Use VMS64 specialized versions of several units in + Interfaces.C hierarchy to be compatible with HP C default size choices. + Use the default version of Ada.Synchronous_Task_Control for VxWorks 653. + +2006-02-17 Ed Schonberg + + * sem_ch10.adb (Analyze_With_Clause): If the unit is a subprogram + instantiation, the corresponding entity is the related_instance of the + wrapper package created for the instance. + +2006-02-17 Ed Schonberg + + * sem_ch12.adb (Analyze_Package_Instantiation): Inline_Now is false if + the current instance is nested within another instance in a child unit. + +2006-02-17 Javier Miranda + Ed Schonberg + + * sem_ch3.adb (Build_Discriminated_Subtype): In case of concurrent + type we cannot inherit the primitive operations; we inherit the + Corresponding_Record_Type (which has the list of primitive operations). + (Check_Anonymous_Access_Types): When creating anonymous access types for + access components, use Rewrite in order to preserve the tree structure, + for ASIS use. + (Analyze_Object_Declaration): For limited types with access + discriminants with defaults initialized by an aggregate, obtain + subtype from aggregate as for other mutable types. + (Derived_Type_Declaration): If the derived type is a limited interface, + set the corresponding flag (Is_Limited_Record is not sufficient). + +2006-02-17 Ed Schonberg + + * sem_ch6.adb (Build_Body_To_Inline): Enforce the rule that in order + to inline a function that returns an unconstrained type, the return + expression must be the first variable declared in the body of the + function. + +2006-02-17 Javier Miranda + + * sem_res.adb (Resolve_Type_Conversion): In case of conversion to an + abstract interface type, the static analysis is not enough to know if + the interface is implemented or not by the source tagged type. Hence + we must pass the work to the expander to generate the required code to + evaluate the conversion at run-time. + (Resolve_Equality_Op): Do not apply previous + transformation if expansion is disasbled, to prevent anomalies when + locating global references in a generic unit. + +2006-02-17 Vincent Celier + + * snames.ads, snames.adb: New standard names for new project attributes: + archive_builder, archive_indexer, compiler_pic_option, + config_body_file_name, config_body_file_name_pattern, + config_file_switches, config_file_unique, config_spec_file_name, + config_spec_file_name_pattern, default_builder_switches, + default_global_compiler_switches, default_language, + dependency_file_kind, global_compiler_switches, include_path, + include_path_file, language_kind, linker_executable_option, + linker_lib_dir_option, linker_lib_name_option, mapping_file_switches, + roots, runtime_project. + +2006-02-17 Matthew Heaney + + * a-convec.ads, a-convec.adb: + (operator "&"): handle potential overflow for large index types + (Insert): removed Contraint_Error when using large index types + (Insert_Space): removed Constraint_Error for large index types + (Length): moved constraint check from Length to Insert + + * a-coinve.ads, a-coinve.adb: Stream attribute procedures are declared + as not null access. + Explicit raise statements now include an exception message. + (operator "&"): handle potential overflow for large index types + (Insert): removed Contraint_Error when using large index types + (Insert_Space): removed Constraint_Error for large index types + (Length): moved constraint check from Length to Insert + +2006-02-17 Robert Dewar + + * s-wchcnv.adb: Document handling of [ on output (we do not change + this to ["5B"] and the new comments say why not. + + * gnat_ugn.texi: + Add note for -gnatVo that this now includes the cases of type + conversions and qualified expressions. + Add comments on handling of brackets encoding for Text_IO + +2006-02-17 Ramon Fernandez + Thomas Quinot + Robert Dewar + Javier Miranda + + * expander.adb: Fix typo in comment + + * exp_pakd.adb: Fix typo + Minor comment reformatting. + + * g-dyntab.adb: Minor reformatting + + * exp_ch6.adb (Register_Interface_DT_Entry): Traverse the list of + aliased subprograms to look for the abstract interface subprogram. + +2006-02-16 Eric Botcazou + + * env.c (__gnat_setenv): Use size_t. + (__gnat_unsetenv): Likewise. + (__gnat_clearenv): Likewise. + +2006-02-16 Arnaud Charlet + + * opt.ads (Ada_Version_Default): Set to Ada 2005 by default. + +2006-02-13 Arnaud Charlet + + * a-intnam-os2.ads, a-intnam-unixware.ads, g-soccon-unixware.ads, + g-soliop-unixware.ads, i-os2err.ads, i-os2lib.adb, i-os2lib.ads, + i-os2syn.ads, i-os2thr.ads, s-intman-irix-athread.adb, + s-osinte-aix-fsu.ads, s-osinte-fsu.adb, s-parame-os2.adb, + s-osinte-irix-athread.ads, s-osinte-linux-fsu.ads, s-osinte-os2.adb, + s-osinte-os2.ads, s-osinte-solaris-fsu.ads, s-osinte-unixware.adb, + s-osinte-unixware.ads, s-osprim-os2.adb, s-taprop-irix-athread.adb, + s-taprop-os2.adb, s-tasinf-irix-athread.adb, s-tasinf-irix-athread.ads, + s-taspri-os2.ads, system-os2.ads, system-unixware.ads: Removed, + no longer used. + +2006-02-13 Jose Ruiz + + * a-taster.adb (Current_Task_Fallback_Handler): Document why explicit + protection against race conditions is not needed. + (Set_Dependents_Fallback_Handler): Add mutual exclusive access to the + fallback handler. + (Set_Specific_Handler): Add mutual exclusive access to the specific + handler. + (Specific_Handler): Add mutual exclusive access for retrieving the + specific handler. + + * s-tarest.adb (Task_Wrapper): Add mutual exclusive access to the fall + back handler. + + * s-taskin.ads (Common_ATCB): Remove pragma Atomic for + Fall_Back_Handler and Specific_Handler. + + * s-tassta.adb (Task_Wrapper): Add mutual exclusive access to the task + termination handlers. + Set two different owerflow depending on the maximal stack size. + + * s-solita.adb (Task_Termination_Handler_T): Document why explicit + protection against race conditions is not needed when executing the + task termination handler. + +2006-02-13 Robert Dewar + + * s-gloloc-mingw.adb, a-cgaaso.ads, a-stzmap.adb, a-stzmap.adb, + a-stzmap.ads, a-ztcoio.adb, a-ztedit.adb, a-ztedit.ads, a-ztenau.adb, + a-ztenau.ads, a-colien.adb, a-colien.ads, a-colire.adb, a-colire.ads, + a-comlin.adb, a-decima.adb, a-decima.ads, a-direio.adb, a-direio.adb, + a-direio.adb, a-direio.ads, a-ngcoty.adb, a-ngcoty.ads, a-nuflra.adb, + a-nuflra.ads, a-sequio.adb, a-sequio.ads, a-sequio.ads, a-storio.ads, + a-stream.ads, a-ststio.adb, a-ststio.adb, a-ststio.ads, a-ststio.ads, + a-stwima.adb, a-stwima.adb, a-stwima.ads, a-stwise.adb, a-teioed.adb, + a-teioed.ads, a-ticoau.adb, a-ticoau.ads, a-ticoio.adb, a-tasatt.ads, + a-tideau.adb, a-tideau.ads, a-tideio.adb, a-tideio.ads, a-tienau.adb, + a-tienau.ads, a-tienio.adb, a-tienio.ads, a-tifiio.ads, a-tiflau.adb, + a-tiflau.ads, a-tiflio.adb, a-tiflio.adb, a-tiflio.ads, a-tigeau.ads, + a-tiinau.adb, a-tiinau.ads, a-tiinio.adb, a-tiinio.ads, a-timoio.adb, + a-timoio.ads, a-titest.adb, a-titest.ads, a-wtcoio.adb, a-wtdeau.adb, + a-wtdeau.ads, a-wtdeio.adb, a-wtdeio.ads, a-wtedit.adb, a-wtedit.adb, + a-wtedit.ads, a-wtenau.adb, a-wtenau.ads, a-wtenau.ads, a-wtenio.adb, + a-wtenio.ads, a-wtfiio.adb, a-wtfiio.ads, a-wtflau.adb, a-wtflau.ads, + a-wtflio.adb, a-wtflio.adb, a-wtflio.ads, a-wtgeau.ads, a-wtinau.adb, + a-wtinau.ads, a-wtinio.adb, a-wtinio.ads, a-wtmoau.adb, a-wtmoau.ads, + a-wtmoio.adb, a-wtmoio.ads, xref_lib.adb, xref_lib.ads, xr_tabls.adb, + g-boubuf.adb, g-boubuf.ads, g-cgideb.adb, g-io.adb, gnatdll.adb, + g-pehage.adb, i-c.ads, g-spitbo.adb, g-spitbo.ads, mdll.adb, + mlib-fil.adb, mlib-utl.adb, mlib-utl.ads, prj-env.adb, prj-tree.adb, + prj-tree.ads, prj-util.adb, s-arit64.adb, s-asthan.ads, s-auxdec.adb, + s-auxdec.ads, s-chepoo.ads, s-direio.adb, s-direio.ads, s-errrep.adb, + s-errrep.ads, s-fileio.adb, s-fileio.ads, s-finroo.adb, s-finroo.ads, + s-gloloc.adb, s-gloloc.ads, s-io.adb, s-io.ads, s-rpc.adb, + s-rpc.ads, s-shasto.ads, s-sequio.adb, s-stopoo.ads, s-stratt.adb, + s-stratt.ads, s-taasde.adb, s-taasde.ads, s-tadert.adb, s-sequio.ads, + s-taskin.adb, s-tasque.adb, s-tasque.ads, s-wchjis.ads, makegpr.adb, + a-coinve.adb, a-cidlli.adb, eval_fat.adb, exp_dist.ads, exp_smem.adb, + fmap.adb, g-dyntab.ads, g-expect.adb, lib-xref.ads, osint.adb, + par-load.adb, restrict.adb, sinput-c.ads, a-cdlili.adb, + system-vms.ads, system-vms-zcx.ads, system-vms_64.ads: Minor + reformatting. + +2006-02-13 Hristian Kirtchev + + * a-tasatt.adb, s-osinte-lynxos-3.adb, s-osinte-lynxos.adb, + s-osinte-aix.adb, s-interr-sigaction.adb, s-asthan-vms-alpha.adb, + s-interr-vms.adb, s-intman-vms.adb, s-interr-vxworks.adb, + s-intman-vxworks.adb, s-asthan-vms-alpha.adb, a-ztexio.adb, + a-reatim.adb, a-taside.adb, a-textio.adb, a-witeio.adb, prj-attr.adb, + s-intman-irix.adb, s-intman-solaris.adb, s-intman-posix.adb, + a-dynpri.adb, a-interr.adb, g-dynhta.adb, s-asthan.adb, s-interr.adb, + s-pooglo.adb, s-pooloc.adb, s-poosiz.adb, s-tasren.adb, s-tasuti.adb, + s-tataat.adb, s-tpobop.adb: Remove redundant with clauses. + +2006-02-13 Arnaud Charlet + + * s-osinte-darwin.adb, s-osinte-darwin.ads, s-osinte-vxworks.ads, + s-osinte-solaris.ads, s-osinte-linux.ads, s-osinte-freebsd.ads, + s-osinte-solaris-posix.ads, s-osinte-lynxos-3.ads, s-osinte-lynxos.ads, + s-osinte-tru64.ads, s-osinte-aix.ads, s-osinte-irix.ads, + s-osinte-hpux-dce.ads, s-osinte-linux-hppa.ads, + s-osinte-linux-alpha.ads, s-inmaop-posix.adb (sigset_t_ptr): Removed, + replaced by anonymous access type. + (pthread_sigmask): Now take an access sigset_t + + * s-osinte-hpux.ads: Ditto. + (pthread_mutex_t, pthread_cond_t): Update definitions to support + properly 32 and 64 bit ABIs. + +2006-02-13 Pascal Obry + + * s-taprop-posix.adb, s-taprop-vxworks.adb, s-taprop-tru64.adb, + s-taprop-lynxos.adb, s-taprop-irix.adb, s-taprop-hpux-dce.adb, + s-taprop-linux.adb, s-taprop-solaris.adb, + s-taprop-vms.adb (Create_Task): Remove task adjustment code. This + adjustement is already done when calling this routine. + +2006-02-13 Pascal Obry + + * system-mingw.ads (Underlying_Priorities): Update the priority mapping + table to take advantage of the 16 priority levels available on Windows + 2000 and XP. On NT4 there are only 7 priority levels, this is properly + supported by this new mapping. + +2006-02-13 Nicolas Setton + + * adadecode.h, adadecode.c: (__gnat_decode): Improve support of types. + (get_encoding): New subprogram. Extracts the encodings from an encoded + Ada name. + +2006-02-13 Pascal Obry + Nicolas Roche + Arnaud Charlet + + * adaint.h, adaint.c (DIR_SEPARATOR): Use _T() macro for Unicode + support. + (__gnat_try_lock): Add unicode support by using a specific section on + Windows. + (__gnat_get_current_dir): Idem. + (__gnat_open_read): Idem. + (__gnat_open_rw): Idem. + (__gnat_open_create): Idem. + (__gnat_create_output_file): Idem. + (__gnat_open_append): Idem. + (__gnat_open_new): Idem. + (__gnat_file_time_name): Idem. + (__gnat_set_file_time_name): Idem. + (__gnat_stat): Idem. + (win32_no_block_spawn): Idem. + (__gnat_locate_exec_on_path): Idem. + (__gnat_opendir): New routine. + (__gnat_closedir): Idem. + (__gnat_readdir): Add new parameter length (pointer to int). Update + implementation to use it and add specific Win32 code for Unicode + support. + (__gnat_get_env_value_ptr): Remove. Replaced by __gnat_getenv in env.c + (__gnat_set_env_value): Remove. Replaced by __gnat_setenv in env.c + (convert_addresses): Do not define this dummy routine on VMS. + + * mingw32.h (GNAT_UNICODE_SUPPORT): New definition, if set the GNAT + runtime Unicode support will be activated. + (S2WS): String to Wide-String conversion. This version just copy a + string in non Unicode version. + (WS2S): Wide-String to String conversion. This version just copy a + string in non Unicode version. + + * g-dirope.adb: (Close): Now import __gnat_closedir from adaint.c. + (Open): Now import __gnat_opendir from adaint.c. + (Read): Change the implementation to support unicode characters. It is + not possible to use strlen() on Windows as this version supports only + standard ASCII characters. So the length of the directory entry is now + returned from the imported __gnat_readdir routine. + Update copyright notice. + + * s-crtl-vms64.ads, s-crtl.ads: (closedir): Moved to adaint.c. + (opendir): Moved to adaint.c. + + * g-os_lib.adb (Copy_Time_Stamp): Fix off-by-one range computation. + (Get_Directory): Fix wrong indexing. + (Getenv): replace __gnat_get_env_value_ptr from adaint.c by + __gnat_getenv from env.c + (Setenv): replace __gnat_set_env_value from adaint.c by __gnat_setenv + from env.c + + * env.h, env.c: New file. + + * s-scaval.adb (Initialize): Replace __gnat_get_env_value_ptr from + adaint.c by __gnat_getenv from env.c + + * s-shasto.adb (Initialize): replace __gnat_get_env_value_ptr from + adaint.c by __gnat_getenv from env.c + + * Make-lang.in: Add env.o in the list of C object needed by gnat1 + and gnatbind. + Update dependencies. + +2006-02-13 Richard Kenner + Olivier Hainque + Eric Botcazou + + * ada-tree.h: (TYPE_UNCHECKED_UNION_P): Deleted. + + * gigi.h (value_factor_p): Add prototype and description, now public. + + * decl.c (gnat_to_gnu_field): Don't attempt BLKmode to integral type + promotion for field with rep clause if the associated size was proven + to be in error. + Expand comments describing attempts to use a packable type. + (gnat_to_gnu_entity) : Inherit alias set of what we are making a + subtype of to ensure conflicts amongst all subtypes in a hierarchy, + necessary since these are not different types and pointers may + actually designate any subtype in this hierarchy. + (gnat_to_gnu_entity, case E_Record_Type): Always make fields for + discriminants but put them into record only if not Unchecked_Union; + pass flag to components_to_record showing Unchecked_Union. + (make_dummy_type): Use UNION_TYPE only if Unchecked_Union and no + components before variants; don't set TYPE_UNCHECKED_UNION_P. + (components_to_record): New argument UNCHECKED_UNION. + Remove special case code for Unchecked_Union and instead use main code + with small changes. + + PR ada/26096 + (gnat_to_gnu_entity) : Do not initialize the aligning + variable with the expression being built, only its inner field. + + * trans.c (Handled_Sequence_Of_Statements_to_gnu): Remove call to + emit_sequence_entry_statements. + (emit_sequence_entry_statements, body_with_handlers_p): Delete. + (establish_gnat_vms_condition_handler): Move before + Subprogram_Body_to_gnu. + (Subprogram_Body_to_gnu): On VMS, establish_gnat_vms_condition_handler + for a subprogram if it has a foreign convention or is exported. + (Identifier_to_gnu): Manually unshare the DECL_INITIAL tree when it is + substituted for a CONST_DECL. + (tree_transform, case N_Aggregate): Remove code for UNION_TYPE and pass + Etype to assoc_to_constructor. + (assoc_to_constructor): New argument, GNAT_ENTITY; use it to ignore + discriminants of Unchecked_Union. + (TARGET_ABI_OPEN_VMS): Define to 0 if not defined, so that later uses + don't need cluttering preprocessor directives. + (establish_gnat_vms_condition_handler): New function. Establish the GNAT + condition handler as current in the compiled function. + (body_with_handlers_p): New function. Tell whether a given sequence of + statements node is attached to a package or subprogram body and involves + exception handlers possibly nested within inner block statements. + (emit_sequence_entry_statements): New function, to emit special + statements on entry of sequences when necessary. Establish GNAT + condition handler in the proper cases for VMS. + (Handled_Sequence_Of_Statements_to_gnu): Start block code with + emit_sequence_entry_statements. + + * utils2.c (find_common_type): If both input types are BLKmode and + have a constant size, use the smaller one. + (build_simple_component_ref): Also match if FIELD and NEW_FIELD are + the same. + + * utils.c (value_factor_p): Make public, to allow uses from other gigi + units. + (create_type_decl): Do not set the flag DECL_IGNORED_P for dummy types. + (convert, case UNION_TYPE): Remove special treatment for unchecked + unions. + + PR ada/18659 + (update_pointer_to): Update variants of pointer types to unconstrained + arrays by attaching the list of fields of the main variant. + +2006-02-13 Arnaud Charlet + Robert Dewar + + * a-exexpr.adb, a-exexpr-gcc.adb + (Process_Raise_Exception): Removed, merged with Propagate_Exception. + (Propagate_Exception): Now take extra From_Signal_Handler parameter. + Remove code unused for exception propagation for the compiler itself + from a-except.adb and update to still share separate packages. + + * a-except.ads, a-except.adb: Ditto. + Add comments that this version is now used only by the compiler and + other basic tools. The full version that includes the Ada 2005 stuff + is in separate files a-except-2005.ads/adb. The reason is that we do + not want to cause bootstrap problems with compilers not recognizing + Wide_Wide_String. + Add exception reason code PE_Implicit_Return + Add new exception reason code (Null Exception_Id) + + * a-except-2005.adb, a-except-2005.ads: New files. + + * s-wchcon.ads: (Get_WC_Encoding_Method): New function. + + * s-wchcon.adb: New file. + + * Makefile.in (LIBGNAT_SRCS): Add tb-gcc.c. + (traceback.o deps): Likewise. + (SPARC/Solaris): Accept sparc[64|v9]-sun-solaris. + Activate build of GMEM instrumentation library on VMS targets. + (gnatlib-sjlj, gnatlib-zcx): Pass EH_MECHANISM to make gnatlib. + Use a-except-2005.ads/adb for all run-time library builds unless + specified otherwise. + [VMS] (LIBGNAT_TARGET_PAIRS_AUX1,2): Rename s-parame-vms.ads to + s-parame-vms-alpha.ads and add s-parame-vms-ia64.ads. + Use s-parame.adb on all native platforms. + Use s-parame-vxworks.adb on all vxworks platforms. + Add env.c env.h in LIBGNAT_SRCS + Add env.o in LIBGNAT_OBJS + (GNATMAKE_OBJS): Remove ctrl_c.o object. + (LIBGNAT_TARGET_PAIRS for x86-vxworks): Use an specialized version of + s-osinte.adb, s-tpopsp.adb, and system.ads for the run time that + supports VxWorks 6 RTPs. + (EXTRA_GNATRTL_NONTASKING_OBJS for x86-vxworks): Remove the use of + i-vxworks and i-vxwoio from the run time that supports VxWorks 6 RTPs. + + * types.h, types.ads (Terminate_Program): New exception + Add comment on modifying multiple versions of a-except.adb when the + table of exception reasons is modified. + Add exception reason code PE_Implicit_Return + Add new exception reason code (Null Exception_Id) + + * clean.adb (Initialize): Get the target parameters before checking + if target is OpenVMS. Move the OpenVMS specific code here from package + body elaboration code. + +2006-02-13 Thomas Quinot + Vincent Celier + Robert Dewar + + * ali-util.adb (Get_File_Checksum): Update to account for change in + profile of Initialize_Scanner. + + * gprep.adb (Gnatprep): Update to account for change in profile of + Initialize_Scanner. + (Process_One_File): Same. + + * lib.adb (Get_Code_Or_Source_Unit): New subprogram factoring the + common code between Get_Code_Unit and Get_Source_Unit. Reimplement + that behaviour using the new Unit information recorded in the source + files table, rather than going through all units every time. + (Get_Code_Unit): Reimplement in terms of Get_Code_Or_Source_Unit. + (Get_Source_Unit): Same. + + * prepcomp.adb (Parse_Preprocessing_Data_File): Update to account for + change in profile of Initialize_Scanner. + (Prepare_To_Preprocess): Same. + + * lib.ads: Fix typo in comment (templace -> template). + + * prj-part.adb (Parse_Single_Project): Update to account for change in + profile of Initialize_Scanner. + + * scn.adb (Initialize_Scanner): Account for change in profile of + Scng.Initialize_Scanner: set Current_Source_Unit in Scn instead of Scng. + Also record the association of the given Source_File_Index to the + corresponding Unit_Number_Type. + + * scng.ads, scng.adb (Initialize_Scanner.Set_Reserved): Remove + procedure. + (Initialize_Scanner): Call Scans.Initialize_Ada_Keywords. + Remove Unit formal for generic scanner: this formal + is only relevant to Scn (the scanner instance used to parse Ada source + files), not to other instances. Update comment accordingly. + (Scan): Use new function Snames.Is_Keyword_Name. + + * sinfo-cn.adb: Fix typo in comment. + + * sinput.adb (Unit, Set_Unit): Accessors for new source file attribute + Unit. + + * sinput.ads (Source_File_Record): New component Unit, used to capture + the unit identifier (if any) associated to a source file. + + * sinput-c.adb, sinput-l.adb (Load_File): Initialize new component + Unit in Source_File_Record. + + * sinput-p.adb (Source_File_Is_Subunit): Update to account for change + in profile of Initialize_Scanner. + + * scans.adb (Initialize_Ada_Keywords): New procedure + + * scans.ads (Initialize_Ada_Keywords): New procedure to initialize the + Ada keywords in the Namet table, without the need to call + Initialize_Scanner. + + * snames.adb: Add pragma Ada_2005 (synonym for Ada_05) + (Is_Keyword_Name): New function + + * snames.ads: Add subtype Configuration_Pragma_Names + Add pragma Ada_2005 (synonym for Ada_05) + (Is_Keyword_Name): New function + + * snames.h: Add pragma Ada_2005 (synonym for Ada_05) + +2006-02-13 Arnaud Charlet + + * a-stwisu.adb, a-strsup.adb, a-stzsup.adb (Super_Slice): Fix slice + index. + + * a-stwima.adb (To_Set): Add extra check when N = 0. + + * g-regpat.adb: (Match_Simple_Operator): Avoid possible overflow. + +2006-02-13 Arnaud Charlet + + * s-parame-mingw.adb, s-parame-linux.adb, + s-parame-solaris.adb: Removed, replaced by s-parame.adb + + * s-parame-vxworks.ads: Fix typo. + + * s-parame-vxworks.adb: New file. + + * s-parame.adb: Version now used by all native platforms. + (Default_Stack_Size): Use 2 megs for default stack size and use + __gl_default_stack_size when available. + (Minimum_Stack_Size): Use 12K. + + * s-taprop-mingw.adb: Set default stack size linker switch to 2megs. + (Create_Task): Refine implementation taking advantage of the XP stack + size support. On XP, we now create the thread using the flag + STACK_SIZE_PARAM_IS_A_RESERVATION. + + * s-osinte-mingw.ads (Stack_Size_Param_Is_A_Reservation): New constant. + + * sysdep.c (__gnat_is_windows_xp): New routine, returns 1 on Windows + XP and 0 on older Windows versions. + + * interfac-vms.ads: Removed, no longer used. + +2006-02-13 Matthew Heaney + + * a-rbtgso.adb, a-crbtgo.adb, a-crbtgk.adb, a-coorse.adb, + a-cohama.adb, a-ciorse.adb, a-cihama.adb, a-cihase.adb, + a-cohase.adb: All explicit raise statements now include an exception + message. + + * a-ciormu.ads, a-ciormu.adb, a-coormu.ads, a-coormu.adb + (Update_Element_Preserving_Key): renamed op to just Update_Element. + Explicit raise statements now include an exception message + + * a-cihase.ads, a-cohase.ads: Removed comment. + + * a-stboha.ads, a-stboha.adb, a-stfiha.ads, a-envvar.adb, + a-envvar.ads, a-swbwha.ads, a-swbwha.adb, a-swfwha.ads, a-szbzha.ads, + a-szbzha.adb, a-szfzha.ads: New files. + +2006-02-13 Matthew Heaney + + * a-cgcaso.adb, a-cgaaso.adb: Implemented using heapsort instead of + quicksort. + +2006-02-13 Eric Botcazou + + * lang.opt: Wvariadic-macros: New option. + Wold-style-definition: Likewise. + Wmissing-format-attribute: Likewise. + + * misc.c (gnat_handle_option): New cases for -Wvariadic-macros, + -Wold-style-definition and -Wmissing-format-attribute. + +2006-02-13 Robert Dewar + + * a-ticoio.ads, a-ticoio.adb: Add use clause (moved here from spec) + + * a-coteio.ads, a-lcteio.ads, a-llctio.ads, a-scteio.ads: New files. + +2006-02-13 Nicolas Roche + + * a-envvar.adb, a-envvar.ads: New files. + +2006-02-13 Douglas Rupp + + * s-parame-vms.ads: Renamed to s-parame-vms-alpha.ads + + * s-parame-vms-alpha.ads, s-parame-vms-ia64.ads: New files. + +2006-02-13 Pat Rogers + + * a-rttiev.adb, a-rttiev.ads: New files. + +2006-02-13 Hristian Kirtchev + + * a-tiboio.adb, a-tiboio.ads, a-wwboio.adb, + a-wwboio.ads, a-zzboio.adb, a-zzboio.ads: New files. + + * impunit.adb, Makefile.rtl: Added new Ada 2005 units. + +2006-02-13 Robert Dewar + + * rtsfind.adb, exp_prag.adb, lib-writ.adb, par-labl.adb, + sem_case.adb: Minor code reorganization (not Present should be No) + +2006-02-13 Geert Bosch + Gary Dismukes + + * a-tifiio.adb (Put_Digits): Test Last against To'First - 1 instead of + 0, since the lower bound of the actual string may be greater than one. + + PR ada/20753 + * a-tifiio.adb (Put): Fix condition to raise Layout_Error when invalid + layout is requested. + +2006-02-13 Vincent Celier + + * back_end.adb (Scan_Compiler_Arguments): Check if + Search_Directory_Present is True and, if it is, add the argument in + the source search directory path. + + * switch-c.adb (Scan_Front_End_Switches): Accept switch "-I". Set + Search_Directory_Present to True. + +2006-02-13 Joel Brobecker + + * bindgen.adb (Gen_Main_C): declare the ensure_reference variable as + volatile, to tell the compiler to preserve this variable at any level + of optimization. + (Gen_Versions_Ada): Temporarily work around codegen bug. + +2006-02-13 Vincent Celier + + * gnatlink.adb (Process_Binder_File): If -shared is specified, invoke + gcc to link with option -shared-libgcc. + (Gnatlink): Remove duplicate switches -shared-libgcc + +2006-02-13 Robert Dewar + + * gnatvsn.ads (Current_Year): New constant, used to easily update + copyright on all GNAT tools. + + * gnatls.adb, gnatname.adb, vms_conv.adb: Add 2006 to displayed + copyright notice. + +2006-02-13 Robert Dewar + + * erroutc.ads, erroutc.adb (Set_Message_Blank): Don't insert space + after hyphen (small aesthetic change useful for a range of numbers + using ^-^. + Suppress range checks for a couple of assignments which otherwise + cause validity checks with validity checking turned on. + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause, case Size): + Improvement in error message for object. + (Rep_Item_Too_Late): Remove '!' in warning message. + +2006-02-13 Robert Dewar + Eric Botcazou + + * err_vars.ads: Suppress range checks for a couple of assignments + which otherwise cause validity checks with validity checking turned on. + Update comments. + + * errout.adb (Error_Msg_Internal): Do not suppress warning messages. + Make message unconditional if it is a warning. + (Error_Msg_NEL): Always output warning messages. + Suppress range checks for a couple of assignments which otherwise + cause validity checks with validity checking turned on. + + * errout.ads (Message Insertion Characters): Document that '!' is + implied by '?' in error messages. + + * gnat1drv.adb: (Bad_Body): Remove '!' in warning message. + (Gnat1drv): Use a goto to end of main subprogram instead of + Exit_Program (E_Success) so that finalization can occur normally. + +2006-02-13 Eric Botcazou + + * s-stchop.adb (Stack_Check): Raise Storage_Error if the argument has + wrapped around. + +2006-02-13 Vincent Celier + + * a-direct.adb (Duration_To_Time, OS_Time_To_Long_Integer): New + Unchecked_Conversion functions. + (Modification_Time): Use direct conversion of OS_Time to Calendar time + when OpenVMS returns False. + + * a-dirval-mingw.adb, a-dirval-vms.adb, a-dirval.ads, + a-dirval.adb (OpenVMS): New Boolean function + +2006-02-13 Ed Schonberg + Thomas Quinot + + * checks.adb (Build_Discriminant_Checks): If the expression being + checks is an aggregate retrieve the values of its discriminants to + generate the check, rather than creating a temporary and a reference + to it. + (Apply_Access_Check): Rewritten to handle new Is_Known_Null flag + (Install_Null_Excluding_Check): Ditto + (Selected_Length_Checks): Build actual subtype for the original Ck_Node, + not for the renamed object, so that the actual itype is attached in the + proper context. + +2006-02-13 Robert Dewar + Vincent Celier + + * debug.adb: Eliminate numeric switches for binder/gnatmake + + * switch-m.adb (Normalize_Compiler_Switches): Record numeric debug + switches for the compiler. + (Scan_Make_Switches): Do not allow numeric debug switches for gnatmake + (Scan_Make_Switches): When failing with an illegal switch, output an + error message with the full switch. + Eliminate numeric switches for binder/gnatmake + + * switch.ads, switch.adb (Bad_Switch): New procedure + + * switch-b.adb (Scan_Binder_Switches): Do not accept combined switches. + Remove 0-9 as debug flag character possibilities + -d is now controlling the primary stack size when its value is a + positive. Also add checks against invalid values, and support for kb, + mb. Ditto for -D switch. + +2006-02-13 Robert Dewar + Serguei Rybin + + * opt.ads opt.adb: Add Ada_Version_Explicit_Config along with + save/restore routines. + Properly handle Ada_Version_Explicit and Ada_Version_Config, which + were not always properly handled previously. + Since we are changing the tree format anyway, also get rid of the + junk obsolete Immediate_Errors flag. + (Tree_Read): Change the way of reading Tree_Version_String - now we + read the version string from the tree even if its length is not the + same as the length of the version string computed from Gnatvsn. + (Search_Directory_Present): New Boolean flag for the compiler. + Define Tree_Version_String as a dynamic string. + (Default_Stack_Size): new variable, used to handle switch -d. + + * par-prag.adb: + For pragma Ada_2005, remove stuff about setting Ada_Version_Explicit + only for main unit. + Add pragma Ada_2005 (synonym for Ada_05) + Properly handle Ada_Version_Explicit and Ada_Version_Config, which + were not always properly handled previously. + + * directio.ads, ioexcept.ads, sequenio.ads, text_io.ads: Change + explicit Ada_95 to Ada_2005. + +2006-02-13 Javier Miranda + Robert Dewar + Ed Schonberg + + * einfo.ads, einfo.adb (First_Tag_Component): Protect the frontend + against errors in the source program: a private types for which the + corresponding full type declaration is missing and pragma CPP_Virtual + is used. + (Is_Unchecked_Union): Check flag on Implementation_Base_Type. + (Is_Known_Null): New flag + (Has_Pragma_Pure): New flag + (No_Return): Present in all entities, set only for procedures + (Is_Limited_Type): A type whose ancestor is an interface is limited if + explicitly declared limited. + (DT_Offset_To_Top_Func): New attribute that is present in E_Component + entities. Only used for component marked Is_Tag. If present it stores + the Offset_To_Top function used to provide this value in tagged types + whose ancestor has discriminants. + + * exp_ch2.adb: Update status of new Is_Known_Null flag + + * sem_ch7.adb: Maintain status of new Is_Known_Null flag + + * sem_cat.adb (Get_Categorization): Don't treat function as Pure in + the categorization sense if Is_Pure was set by pragma Pure_Function. + +2006-02-13 Quentin Ochem + Olivier Hainque + + * bindusg.adb: Updated documentation for -d and -D switches. + + * raise.h (__gnat_set_globals): added new parameter for + Default_Stack_Size. + + * init.c (__gnat_adjust_context_for_raise) : Implement. + (__gnat_handle_vms_condition): Adjust context before raise. + (__gnat_install_handler): Restore the global vector setup for GCC + versions before 3.4, as the frame based circtuitry is not available + in this case. + (__gnat_set_globals): added a parameter default_stack_size + (__gl_default_stack_size): new variable. + +2006-02-13 Ed Schonberg + + * exp_aggr.adb (Build_Array_Aggr_Code): Rename variable + "Others_Mbox_Present" to "Others_Box_Present" because the mbox concept + does not exist in the Ada RM. + (Compatible_Int_Bounds): Determine whether two integer range bounds + are of equal length and have the same start and end values. + (Is_Int_Range_Bounds): Determine whether a node is an integer range. + (Build_Record_Aggr_Code): Perform proper sliding of a nested array + aggregate when it is part of an object declaration. + (Build_Record_Aggr_Code) If the aggregate ttype is a derived type that + constrains discriminants of its parent, add explicitly the discriminant + constraints of the ancestor by retrieving them from the + stored_constraint of the parent. + +2006-02-13 Robert Dewar + + * exp_attr.adb (Expand_N_Attribute_Reference, case Mechanism_Code): If + attribute Mechanism_Code is applied to renamed subprogram, modify + prefix to point to base subprogram. + Max/Min attributes now violate Restriction No_Implicit_Conditionals + + * sinfo.ads: Document that Mechanism_Code cannot be applied to + renamed subprograms so that the front-end must replace the prefix + appropriately. + +2006-02-13 Javier Miranda + Gary Dismukes + + * exp_ch3.adb (Component_Needs_Simple_Initialization): Add check for + availability of RE_Interface_Tag. + (Build_Initialization_Call): Fix wrong access to the discriminant value. + (Freeze_Record_Type): Do not generate the tables associated with + timed and conditional dispatching calls through synchronized + interfaces if compiling under No_Dispatching_Calls restriction. + When compiling for Ada 2005, for a nonabstract + type with a null extension, call Make_Controlling_Function_Wrappers + and insert the wrapper function declarations and bodies (the latter + being appended as freeze actions). + (Predefined_Primitive_Bodies): Do not generate the bodies of the + predefined primitives associated with timed and conditional + dispatching calls through synchronized interfaces if we are + compiling under No_Dispatching_Calls. + (Build_Init_Procedure): Use RTE_Available to check if a run-time + service is available before generating a call. + (Make_Controlling_Function_Wrappers): New procedure. + (Expand_N_Full_Type_Declaration): Create a class-wide master for + access-to-limited-interfaces because they can be used to reference + tasks that implement such limited interface. + (Build_Offset_To_Top_Functions): Build the tree corresponding to the + procedure spec and body of the Offset_To_Top function that is generated + when the parent of a type with discriminants has secondary dispatch + tables. + (Init_Secondary_Tags): Handle the case in which the parent of the type + containing secondary dispatch tables has discriminants to generate the + correct arguments to call Set_Offset_To_Top. + (Build_Record_Init_Proc): Add call to Build_Offset_To_Top_Functions. + + * a-tags.ads, a-tags.adb: (Check_Index): Removed. + Add Wide_[Wide_]Expanded_Name. + (Get_Predefined_Prim_Op_Address): New subprogram that provides exactly + the same functionality of Get_Prim_Op_Address but applied to predefined + primitive operations because the pointers to the predefined primitives + are now saved in a separate table. + (Parent_Size): Modified to get access to the separate table of primitive + operations or the parent type. + (Set_Predefined_Prim_Op_Address): New subprogram that provides the same + functionality of Set_Prim_Op_Address but applied to predefined primitive + operations. + (Set_Signature): New subprogram used to store the signature of a DT. + (Displace): If the Offset_To_Top value is not static then call the + function generated by the expander to get such value; otherwise use + the value stored in the table of interfaces. + (Offset_To_Top): The type of the actual has been changed to Address to + give the correct support to tagged types with discriminants. In this + case this value is stored just immediately after the tag field. + (Set_Offset_To_Top): Two new formals have been added to indicate if the + offset_to_top value is static and hence pass this value to the run-time + to store it in the table of interfaces, or else if this value is dynamic + and then pass to the run-time the address of a function that is + generated by the expander to provide this value for each object of the + type. + + * rtsfind.ads (Default_Prin_Op_Count): Removed. + (Default_Prim_Op_Count): New entity + (Get_Predefined_Prim_Op_Address): New entity + (Set_Predefined_Prim_Op_Address): New entity + (RE_Set_Signature): New entity + +2006-02-13 Thomas Quinot + Ed Schonberg + + * exp_ch4.adb (Expand_Allocator_Expression): Pass Allocator => True to + Make_Adjust_Call done for a newly-allocated object. + + * exp_ch7.ads, exp_ch7.adb (Expand_Cleanup_Actions): If the statements + in a subprogram are wrapped in a cleanup block, indicate that the + subprogram contains an inner block with an exception handler. + (Make_Adjust_Call): New Boolean formal Allocator indicating whether the + Adjust call is for a newly-allocated object. In that case we must not + assume that the finalization list chain pointers are correct (since they + come from a bit-for-bit copy of the original object's pointers) so if + the attach level would otherwise be zero (no change), we set it to 4 + instead to cause the pointers to be reset to null. + + * s-finimp.adb (Attach_To_Final_List): New attach level: 4, meaning + reset chain pointers to null. + +2006-02-13 Ed Schonberg + + * exp_ch5.adb (Expand_Assign_Array): If the right-hand side is a + string, and the context requires a loop for the assignment (e.g. + because the left-hand side is packed), generate a unique name for the + temporary that holds the string, to prevent spurious name clashes. + +2006-02-13 Ed Schonberg + Javier Miranda + Robert Dewar + Gary Dismukes + + * exp_ch6.adb (Expand_Inlined_Call): Handle calls to functions that + return unconstrained arrays. + Update comments. + (Expand_Call): An indirect call through an access parameter of a + protected operation is not a protected call. + Add circuit to raise CE in Ada 2005 mode following call + to Raise_Exception. + (Register_DT_Entry): Do nothing if + the run-time does not give support to abstract interfaces. + (Freeze_Subprogram): In case of dispatching operations, do not generate + code to register the operation in the dispatch table if the source + is compiled with No_Dispatching_Calls. + (Register_Predefined_DT_Entry): Generate code that calls the new + run-time subprogram Set_Predefined_Prim_Op_Address instead of + Set_Prim_Op_Address. + + * sem_ch5.adb (Analyze_Assignment_Statement): Do not apply length checks + on array assignments if the right-hand side is a function call that has + been inlined. Check is performed on the assignment in the block. + (Process_Bounds): If bounds and range are overloaded, apply preference + rule for root operations to disambiguate, and diagnose true ambiguity. + (Analyze_Assignment): Propagate the tag for a class-wide assignment with + a tag-indeterminate right-hand side even when Expander_Active is True. + Needed to ensure that dispatching calls to T'Input are allowed and + get the tag of the target class-wide object. + + * sem_ch6.adb (New_Overloaded_Entity): Handle entities that override + an inherited primitive operation that already overrides several + abstract interface primitives. For transitivity, the new entity must + also override all the abstract interface primitives covered by the + inherited overriden primitive. + Emit warning if new entity differs from homograph in same scope only in + that one has an access parameter and the other one has a parameter of + a general access type with the same designated type, at the same + position in the signature. + (Make_Inequality_Operator): Use source locations of parameters and + subtype marks from corresponding equality operator when creating the + tree structure for the implicit declaration of "/=". This does not + change anything in behaviour except that the decoration of the + components of the subtree created for "/=" allows ASIS to get the + string images of the corresponding identifiers. + (Analyze_Return_Statement): Remove '!' in warning message. + (Check_Statement_Sequence): Likewise. + (Analyze_Subprogram_Body): For an access parameter whose designated type + is an incomplete type imported through a limited_with clause, use the + type of the corresponding formal in the body. + (Check_Returns): Implicit return in No_Return procedure now raises + Program_Error with a compile time warning, instead of beging illegal. + (Has_Single_Return): Function returning unconstrained type cannot be + inlined if expression in unique return statement is not an identifier. + (Build_Body_To_Inline): It is possible to inline a function call that + returns an unconstrained type if all return statements in the function + return the same local variable. Subsidiary procedure Has_Single_Return + verifies that the body conforms to this restriction. + + * sem_res.adb (Resolve_Equality_Op): If the operands do not have the + same type, and one of them is of an anonymous access type, convert + the other operand to it, so that this is a valid binary operation for + gigi. + (Resolve_Type_Conversion): Handle subtypes of protected types and + task types when accessing to the corresponding record type. + (Resolve_Allocator): Add '\' in 2-line warning message. + Remove '!' in warning message. + (Resolve_Call): Add '\' in 2-line warning message. + (Valid_Conversion): Likewise. + (Resolve_Overloaded_Selected_Component): If disambiguation succeeds, the + resulting type may be an access type with an implicit dereference. + Obtain the proper component from the designated type. + (Make_Call_Into_Operator): Handle properly a call to predefined equality + given by an expanded name with prefix Standard, when the operands are + of an anonymous access type. + (Check_Fully_Declared_Prefix): New procedure, subsidiary of Resolve_ + Explicit_Dereference and Resolve_Selected_Component, to verify that the + prefix of the expression is not of an incomplete type. Allows full + diagnoses of all semantic errors. + (Resolve_Actuals): If the actual is an allocator whose directly + designated type is a class-wide interface we build an anonymous + access type to use it as the type of the allocator. Later, when + the subprogram call is expanded, if the interface has a secondary + dispatch table the expander will add a type conversion to force + the displacement of the pointer. + (Resolve_Call): If a function that returns an unconstrained type is + marked Inlined_Always and inlined, the call will be inlined and does + not require the creation of a transient scope. + (Check_Direct_Boolean_Op): Removed + (Resolve_Comparison_Op): Remove call to above + (Resolve_Equality_Op): Remove call to above + (Resolve_Logical_Op): Inline above, since this is only call. + (Valid_Conversion): Handle properly conversions between arrays of + convertible anonymous access types. + + PR ada/25885 + (Set_Literal_String_Subtype): If the lower bound is not static, wrap + the literal in an unchecked conversion, because GCC 4.x needs a static + value for a string bound. + +2006-02-13 Ed Schonberg + Hristian Kirtchev + + * exp_ch9.adb (Expand_N_Protected_Type_Declaration): When creating the + components of the corresponding record, take into account component + definitions that are access definitions. + (Expand_N_Asynchronous_Select): A delay unit statement rewritten as a + procedure is not considered a dispatching call and will be expanded + properly. + +2006-02-13 Javier Miranda + + * exp_disp.ads, exp_disp.adb (Expand_Dispatching_Call): If the + controlling argument of the dispatching call is an abstract interface + class-wide type then we use it directly. + Check No_Dispatching_Calls restriction. + (Default_Prim_Op_Position): Remove the code that looks for the last + entity in the list of aliased subprograms. This code was wrong in + case of renamings. + (Fill_DT_Entry): Add assertion to avoid the use of this subprogram + when the source is compiled with the No_Dispatching_Calls restriction. + (Init_Predefined_Interface_Primitives): No need to inherit primitives + if we are compiling with restriction No_Dispatching_Calls. + (Make_Disp_XXX): Addition of assertion to avoid the use of all these + subprograms if we are compiling under No_Dispatching_Calls restriction. + (Make_DT): Generate a dispatch table with a single dummy entry if + we are compiling with the No_Dispatching_Calls restriction. In + addition, in this case we don't generate code that calls to the + following run-time subprograms: Set_Type_Kind, Inherit_DT. + (Make_Select_Specific_Data_Table): Add assertion to avoid the use + of this subprogram if compiling with the No_Dispatching_Calls + restriction. + (Expand_Type_Conversion): Instead of using the actual parameter, + the argument passed as parameter to the conversion function was + erroneously referenced by the expander. + (Ada_Actions): Addition of Get_Predefined_Prim_Op_Address, + Set_Predefined_Primitive_Op_Address and Set_Signature. + (Expand_Dispatching_Call): Generate call to + Get_Predefined_Prim_Op_Address for predefined primitives. + (Fill_DT_Entry): Generate call to Set_Predefined_Prim_Op_Address for + predefined primitives. + (Make_DT, Make_Secondary_DT): If the tagged type has no user defined + primitives we reserve one dummy entry to ensure that the tag does not + point to some memory that is associated with some other object. In + addition, remove all the old code that generated the assignments + associated with the signature of the dispatch table and replace them + by a call to the new subprogram Set_Signature. + (Set_All_DT_Position): Change the algorithm because now we have a + separate dispatch table associated with predefined primitive operations. + (Expand_Interface_Conversion): In case of non-static offset_to_top + add explicit dereference to get access to the object after the call + to displace the pointer to the object. + (Expand_Interface_Thunk): Modify the generation of the actual used + in the calls to the run-time function Offset_To_Top to fulfil its + new interface. + (Make_DT): Add the new actuals required to call Set_Offset_To_Top. + +2006-02-13 Ed Schonberg + + * exp_dist.adb (Copy_Specification): For access parameters, copy + Null_Exclusion flag, which will have been set for stream subprograms + in Ada2005 mode. + +2006-02-13 Pascal Obry + + * expect.c (__gnat_expect_portable_execvp): New implementation. The + previous implementation was using the C runtime spawnve routine but + the corresponding wait was using directly the Win32 API. This was + causing some times a lock when waiting for an event using + WaitForSingleObject in __gnat_waitpid. This new implementation uses + the Win32 CreateProcess routine. Avoiding mixing C runtime and Win32 + API fixes this problem. + +2006-02-13 Robert Dewar + + * exp_intr.adb (Expand_Unc_Deallocation): Correct error of bad analyze + call. + +2006-02-13 Thomas Quinot + + * exp_pakd.ads: Fix typos in comments. + + * exp_pakd.adb (Convert_To_PAT_Type): For the case of a bit packed + array reference that is an explicit dereference, mark the converted + (packed) array reference as analyzed to prevent a forthcoming + reanalysis from resetting its type to the original (non-packed) array + type. + +2006-02-13 Ed Schonberg + Javier Miranda + Eric Botcazou + + * exp_util.ads, exp_util.adb (Find_Prim_Op, + Is_Predefined_Primitive_Operation): When + searching for the predefined equality operator, verify that operands + have the same type. + (Is_Predefined_Dispatching_Operation): Remove the code that looks + for the last entity in the list of aliased subprograms. This code + was wrong in case of renamings. + (Set_Renamed_Subprogram): New procedure + (Remove_Side_Effects): Replace calls to Etype (Exp) with use of the + Exp_Type constant computed when entering this subprogram. + (Known_Null): New function + (OK_To_Do_Constant_Replacement): New function + (Known_Non_Null): Check scope before believing Is_Known_Non_Null flag + (Side_Effect_Free): An attribute reference 'Input is not free of + side effect, unlike other attributes that are functions. (from code + reading). + (Remove_Side_Effects): Expressions that involve packed arrays or records + are copied at the point of reference, and therefore must be marked as + renamings of objects. + (Is_Predefined_Dispatching_Operation): Return false if the operation is + not a dispatching operation. + + PR ada/18819 + (Remove_Side_Effects): Lift enclosing type conversion nodes for + elementary types in all cases. + +2006-02-13 Javier Miranda + + * freeze.adb (Freeze_Entity): Handle subtypes of protected types and + task types when accessing to the corresponding record type. + Remove '!' in warning message. + +2006-02-13 Olivier Hainque + + * g-altive.ads (VECTOR_ALIGNMENT): Set to Min (16, Max_Alignment), + to avoid useless and space inefficient overalignments on targets where + Max_Alignment is larger than 16. + +2006-02-13 Pascal Obry + + * g-catiio.adb (Sec_Number): New type used to compute the number of + seconds since 1-1-1970. + (Image) [Natural]: The parameter was an Integer, as we can't deal with + negative numbers (years, months...) it is better to have a Natural here. + Code clean-up. + (Image) [Number]: Change parameter from Long_Integer to Number. + (Image): Use Number type to compute the seconds since 1-1-1970 to fix an + overflow for dates past year 2038. + +2006-02-13 Matthew Heaney + + * g-dyntab.adb (Index_Of): conversion from Natural can no longer raise + Constraint_Error. + +2006-02-13 Arnaud Charlet + + * gnatbind.adb (Scan_Bind_Arg): Replace error by warning on -M and + native platforms. + (Gnatbind): Do not call Exit_Program (E_Success) at the end, so that + finalization can occur normally. + +2006-02-13 Vincent Celier + + * gnatcmd.adb (Rules_Switches): New table + (Add_To_Rules_Switches): New procedure + (GNATCmd): For command CHECK, put all options following "-rules" in the + Rules_Switches table. Append these -rules switches after the -cargs + switches. + +2006-02-13 Robert Dewar + + * g-spipat.adb (Image, case PC_Assign_Imm and case PC_Assign_OnM): + These two cases were generating incorrect output, and if this unit + was built with checks on, generated a discriminant mismatch constraint + error. + +2006-02-13 Ed Schonberg + Robert Dewar + + * lib-xref.adb (Get_Type_Reference): For a private type whose full + view is an array type, indicate the component type as well, for + navigation purposes. + (Generate_Reference): Don't consider array ref on LHS to be a case + of violating pragma Unreferenced. + Do not give Ada 2005 warning except on real reference. + +2006-02-13 Vincent Celier + + * make.adb (Collect_Arguments_And_Compile): For VMS, when compiling the + main source, add switch -mdebug-main=_ada_ so that the executable can + be debugged by the standard VMS debugger. + (Gnatmake): Set No_Main_Subprogram to True when there is no main + subprogram, to avoid issuing -mdebug-main=_ada_ for VMS uselessly. + Exit the Multi_Main_Loop when Unique_Compile is True after compilation + of the last source, as the binding and linking phases are never + performed. + Set all executable obsolete when rebuilding a library. + + * makeutl.adb (Linker_Options_Switches): Do not process empty linker + options. + +2006-02-13 Javier Miranda + + PR ada/23973 + * par-ch3.adb (P_Derived_Type_Def_Or_Private_Ext_Decl): Reorganize the + code to improve the error message reported when the program has + declarations of abstract interface types and it is not compiled with + the -gnat05 switch. + (P_Access_Definition): Reorganize the code to improve the error + message reported when the new Ada 2005 syntax for anonymous + access types is used and the program is not compiled with the + -gnat05 switch. + +2006-02-13 Robert Dewar + + * par-ch6.adb, style.ads, styleg.adb, styleg.ads, stylesw.adb, + stylesw.ads, usage.adb, vms_data.ads: Implement -gnatyI switch + (MODE_IN) + +2006-02-13 Javier Miranda + + * par-endh.adb (Explicit_Start_Label): Add code to protect the parser + against source containing syntax errors. + +2006-02-13 Vincent Celier + + * prj.adb (Reset): Initialize the first element of table Namings with + the standard naming data. + +2006-02-13 Vincent Celier + + * prj.ads (Error_Warning): New enumeration type + + * prj-nmsc.ads, prj-nmsc.adb (Error_Msg): If location parameter is + unknown, use the location of the project to report the error. + (When_No_Sources): New global variable + (Report_No_Ada_Sources): New procedure + (Check): New parameter When_No_Sources. Set value of global variable + When_No_Sources, + (Find_Sources): Call Report_No_Ada_Sources when appropriate + (Get_Sources_From_File): Ditto + (Warn_If_Not_Sources): Better warning messages indicating the unit name + and the file name. + + * prj-pars.ads, prj-pars.adb (Parse): New parameter When_No_Sources. + Call Prj.Proc.Process with parameter When_No_Sources. + + * prj-proc.ads, prj-proc.adb (Check): New parameter When_No_Sources. + Call Recursive_Check with parameter When_No_Sources. + (Recursive_Check): New parameter When_No_Sources. Call itself and + Prj.Nmsc.Check with parameter When_No_Sources. + (Process): New parameter When_No_Sources. Call Check with parameter + When_No_Sources. + (Copy_Package_Declarations): New procedure to copy renamed parameters + and setting the location of the declared attributes to the location + of the renamed package. + (Process_Declarative_Items): Call Copy_Package_Declarations for renamed + packages. + +2006-02-13 Vincent Celier + + * prj-makr.adb (Make): Preserve the comments from the original project + file. + When removing nodes (attributes Source_Dirs, Source_Files, + Source_List_File and package Naming), save the comments and attach the + saved comments to the newly created nodes. + Do not add a with clause for the naming package if one already exists. + +2006-02-13 Javier Miranda + Gary Dismukes + Robert Dewar + + * restrict.ads (No_Dispatching_Calls): New GNAT restriction. + + * sem_disp.adb (Override_Dispatching_Operation): Traverse the list of + aliased entities to look for the overriden abstract interface + subprogram. + (Is_Interface_Subprogram): Complete documentation. + (Check_Dispatching_Operation): Do not generate code to register the + operation in the dispatch table if the source is compiled with + restriction No_Dispatching_Calls. + (Override_Dispatching_Operation): Check for illegal attempt to override + No_Return procedure with procedure that is not No_Return + (Check_Dispatching_Call): Suppress the check for an abstract operation + when the original node of an actual is a tag-indeterminate attribute + call, since the attribute, which must be 'Input, can never be abstract. + (Is_Tag_Indeterminate): Handle checking of tag indeterminacy of a + call to the Input attribute (even when rewritten). + (Propagate_Tag): Augment comment to indicate the possibility of a call + to an Input attribute. + + * sem_disp.ads (Override_Dispatching_Operation): Moved to spec to allow + calling it from Exp_Ch3.Make_Controlling_Function_Wrappers. + + * s-rident.ads: (No_Dispatching_Calls): New GNAT restriction. + No_Wide_Characters is no longer partition-wide + No_Implementation_Attributes/Pragmas are now Ada 2005 (AI-257) + rather than GNAT + +2006-02-13 Douglas Rupp + + * s-auxdec-vms_64.ads (Short_Address): Wrap it in a type. + +2006-02-13 Javier Miranda + + * sem_aggr.adb (Resolve_Record_Aggregate): Restructure the code that + handles default-initialized components to keep separate the management + of this feature but also avoid the unrequired resolution and + expansion of components that do not have partially initialized + values. + (Collect_Aggr_Bounds): Add '\' in 2-line warning message. + (Check_Bounds): Likewise. + (Check_Length): Likewise. + +2006-02-13 Javier Miranda + Ed Schonberg + + * sem_attr.adb (Analyze_Attribute): In case of 'Class applied to an + abstract interface type call analyze_and_resolve to expand the type + conversion into the corresponding displacement of the + reference to the base of the object. + (Eval_Attribute, case Width): For systems where IEEE extended precision + is supported, the maximum exponent occupies 4 decimal digits. + (Accessibility_Message): Add '\' in 2-line warning message. + (Resolve_Attribute): Likewise. + (case Attribute_Access): Significantly revise checks + for illegal access-to-subprogram Access attributes to properly enforce + the rules of 3.10.2(32/2). + Diagnose use of current instance with an illegal attribute. + + * sem_util.ads, sem_util.adb (Enclosing_Generic_Body): Change formal + to a Node_Id. + (Enclosing_Generic_Unit): New function to return a node's innermost + enclosing generic declaration node. + (Compile_Time_Constraint_Error): Remove '!' in warning messages. + (Type_Access_Level): The accessibility level of anonymous acccess types + associated with discriminants is that of the current instance of the + type, and that's deeper than the type itself (AARM 3.10.2 (12.3.21)). + (Compile_Time_Constraint_Error): Handle case of conditional expression. + (Kill_Current_Values_For_Entity): New function + (Enter_Name): Change formal type to Entity_Id + +2006-02-13 Hristian Kirtchev + Ed Schonberg + Gary Dismukes + + * sem_ch10.adb (Check_Redundant_Withs): New procedure in + Analyze_Compilation_Unit. + Detect and warn on redundant with clauses detected in a package spec + and/or body when -gnatwr is used. + (Analyze_Context): Analyze config pragmas before other items + (Install_Context_Items): Don't analyze config pragmas here + (Install_Limited_Withed_Unit): Set limited entity of package in + with_clause so that cross-reference information or warning messages on + unused packages can be properly generated + (Is_Visible_Through_Renamings): Return false if the limited_with_clause + has Error_Posted set. Prevent infinite loops in illegal programs. + (Check_Private_Child_Unit): Move test for a nonprivate with clause down + to the point of the error test requiring the current unit to be private. + This ensures that private with clauses are not exempted from the basic + checking for being a descendant of the same library unit parent as a + withed private descendant unit. + (Check_Private_Limited_Withed_Unit): Revise the checking algorithm to + handle private with clauses properly, as well as to account for cases + where the withed unit is a public descendant of a private ancestor + (in which case the current unit must be a descendant of the private + ancestor's parent). The spec comments were updated accordingly. Also, + the old error message in this subprogram was replaced with error + messages that mirror the errors tested and reported by + Check_Private_Child_Unit. + Parameter and variable names improved for readability. + (Install_Limited_Context_Clauses): Remove test for a withed unit being + private as the precondition for calling + Check_Private_Limited_Withed_Unit since that subprogram has been + revised to test public units as well as private units. + +2006-02-13 Thomas Quinot + Robert Dewar + Ed Schonberg + Javier Miranda + + * sem_ch12.adb (Inline_Instance_Body): Remove erroneous assumption + that Scope_Stack.First = 1. + Properly handle Ada_Version_Explicit and Ada_Version_Config, which + were not always properly handled previously. + (Formal_Entity): Complete rewrite, to handle properly some complex case + with multiple levels of parametrization by formal packages. + (Analyze_Formal_Derived_Type): Propagate Ada 2005 "limited" indicator + to the corresponding derived type declaration for proper semantics. + + * sem_prag.adb (Analyze_Pragma): Remove '!' in warning message. + (Check_Component): Enforce restriction on components of + unchecked_unions: a component in a variant cannot contain tasks or + controlled types. + (Unchecked_Union): Allow nested variants and multiple discriminants, to + conform to AI-216. + Add pragma Ada_2005 (synonym for Ada_05) + Properly handle Ada_Version_Explicit and Ada_Version_Config, which + were not always properly handled previously. + Document that pragma Propagate_Exceptions has no effect + (Analyze_Pragma, case Pure): Set new flag Has_Pragma_Pure + (Set_Convention_From_Pragma): Check that if a convention is + specified for a dispatching operation, then it must be + consistent with the existing convention for the operation. + (CPP_Class): Because of the C++ ABI compatibility, the programmer is no + longer required to specify an vtable-ptr component in the record. For + compatibility reasons we leave the support for the previous definition. + (Analyze_Pragma, case No_Return): Allow multiple arguments + + * sem_ch3.ads, sem_ch3.adb (Check_Abstract_Overriding): Flag a + non-overrideen inherited operation with a controlling result as + illegal only its implicit declaration comes from the derived type + declaration of its result's type. + (Check_Possible_Deferred_Completion): Relocate the object definition + node of the subtype indication of a deferred constant completion rather + than directly analyzing it. The analysis of the generated subtype will + correctly decorate the GNAT tree. + (Record_Type_Declaration): Check whether this is a declaration for a + limited derived record before analyzing components. + (Analyze_Component_Declaration): Diagnose record types not explicitly + declared limited when a component has a limited type. + (Build_Derived_Record_Type): Code reorganization to check if some of + the inherited subprograms of a tagged type cover interface primitives. + This check was missing in case of a full-type associated with a private + type declaration. + (Constant_Redeclaration): Check that the subtypes of the partial and the + full view of a constrained deferred constant statically match. + (Mentions_T): A reference to the current type in an anonymous access + component declaration must be an entity name. + (Make_Incomplete_Type_Declaration): If type is tagged, set type of + class_wide type to refer to full type, not to the incomplete one. + (Add_Interface_Tag_Components): Do nothing if RE_Interface_Tag is not + available. Required to give support to the certified run-time. + (Analyze_Component_Declaration): In case of anonymous access components + perform missing checks for AARM 3.9.2(9) and 3.10.2 (12.2). + (Process_Discriminants): For an access discriminant, use the + discriminant specification as the associated_node_for_itype, to + simplify accessibility checks. + +2006-02-13 Ed Schonberg + Javier Miranda + + * sem_ch4.adb (Remove_Abstract_Interpretations): Even if there are no + abstract interpretations on an operator, remove interpretations that + yield Address or a type derived from it, if one of the operands is an + integer literal. + (Try_Object_Operation.Try_Primitive_Operation, + Try_Object_Operation.Try_Class_Wide_Operation): Set proper source + location when creating the new reference to a primitive or class-wide + operation as a part of rewriting a subprogram call. + (Try_Primitive_Operations): If context requires a function, collect all + interpretations after the first match, because there may be primitive + operations of the same type with the same profile and different return + types. From code reading. + (Try_Primitive_Operation): Use the node kind to choose the proper + operation when a function and a procedure have the same parameter + profile. + (Complete_Object_Operation): If formal is an access parameter and prefix + is an object, rewrite as an Access reference, to match signature of + primitive operation. + (Find_Equality_Type, Find_One_Interp): Handle properly equality given + by an expanded name with prefix Standard, when the operands are of an + anonymous access type. + (Remove_Abstract_Operations): If the operation is abstract because it is + inherited by a user-defined type derived from Address, remove it as + well from the set of candidate interpretations of an overloaded node. + (Analyze_Membership_Op): Membership test not applicable to cpp-class + types. + +2006-02-13 Bob Duff + + * sem_ch8.adb (Note_Redundant_Use): Suppress unhelpful warning about + redundant use clauses. + In particular, if the scope of two use clauses overlaps, but one is not + entirely included in the other, we should not warn. This can happen + with nested packages. + (Analyze_Subprogram_Renaming): Protect the compiler against previously + reported errors. The bug was reported when the compiler was built + with assertions enabled. + (Find_Type): If the node is a 'Class reference and the prefix is a + synchronized type without a corresponding record, return the type + itself. + +2006-02-13 Javier Miranda + + * sem_ch9.adb (Analyze_Protected_Type, Analyze_Task_Type): Check that + if this is the full-declaration associated with a private declaration + that implement interfaces, then the private type declaration must be + limited. + (Analyze_Single_Protected, Analyze_Single_Task): Do not mark the object + as aliased. The use of the 'access attribute is not available for such + object (for this purpose the object should be explicitly marked as + aliased, but being an anonymous type this is not possible). + +2006-02-13 Ed Schonberg + Robert Dewar + + * sem_elab.adb (Same_Elaboration_Scope): A package that is a + compilation unit is an elaboration scope. + (Add_Task_Proc): Add '\' in 2-line warning message. + (Activate_All_Desirable): Deal with case of unit with'ed by parent + +2006-02-13 Ed Schonberg + Javier Miranda + + * sem_type.adb (Write_Overloads): Improve display of candidate + interpretations. + (Add_One_Interp): Do not add to the list of interpretations aliased + entities corresponding with an abstract interface type that is an + immediate ancestor of a tagged type; otherwise we have a dummy + conflict between this entity and the aliased entity. + (Disambiguate): The predefined equality on universal_access is not + usable if there is a user-defined equality with the proper signature, + declared in the same declarative part as the designated type. + (Find_Unique_Type): The universal_access equality operator defined under + AI-230 does not cover pool specific access types. + (Covers): If one of the types is a generic actual subtype, check whether + it matches the partial view of the other type. + +2006-02-13 Thomas Quinot + + * sinput-d.adb (Write_Line): Update the Source_Index_Table after each + line. This is necessary to allow In_Extended_Main_Unit to provide + correct results for itypes while writing out expanded source. + (Close_File): No need to update the source_index_table here since it's + now done for each line. + +2006-02-13 Ed Schonberg + Robert Dewar + + * sprint.adb (Write_Itype): Preserve Sloc of declaration, if any, to + preserve the source unit where the itype is declared, and prevent a + backend abort. + (Note_Implicit_Run_Time_Call): New procedure + (Write_Itype): Handle missing cases (E_Class_Wide_Type and + E_Subprogram_Type) + + * sprint.ads: Document use of $ for implicit run time routine call + +2006-02-13 Quentin Ochem + + * s-stausa.adb (Initialize_Analyzer): fixed error in assignment of + task name. + +2006-02-13 Bob Duff + + * s-valint.adb (Scan_Integer): Call Scan_Raw_Unsigned instead of + Scan_Unsigned, so we do not scan leading blanks and sign twice. + Integer'Value("- 5") and Integer'Value("-+5") now correctly + raise Constraint_Error. + + * s-vallli.adb (Scan_Long_Long_Integer): Call + Scan_Raw_Long_Long_Unsigned instead of Scan_Long_Long_Unsigned, so we + do not scan leading blanks and sign twice. + Integer'Value("- 5") and Integer'Value("-+5") now correctly + raise Constraint_Error. + + * s-valllu.ads, s-valllu.adb (Scan_Raw_Long_Long_Unsigned, + Scan_Long_Long_Unsigned): Split out most of the processing from + Scan_Long_Long_Unsigned out into + Scan_Raw_Long_Long_Unsigned, so that Val_LLI can call the Raw_ version. + This prevents scanning leading blanks and sign twice. + Also fixed a bug: Modular'Value("-0") should raise Constraint_Error + See RM-3.5(44). + + * s-valuns.ads, s-valuns.adb (Scan_Raw_Unsigned, Scan_Unsigned): Split + out most of the processing from Scan_Unsigned out into + Scan_Raw_Unsigned, so that Val_LLI can call the Raw_ version. + This prevents scanning leading blanks and sign twice. + + * s-valuti.ads, s-valuti.adb (Scan_Plus_Sign): Add Scan_Plus_Sign, for + use with Modular'Value attribute. + (Scan_Plus_Sign): Add Scan_Plus_Sign, for use with Modular'Value + attribute. + +2006-02-13 Robert Dewar + + * s-wchjis.adb (JIS_To_EUC): Raise Constraint_Error for invalid value + +2006-02-13 Eric Botcazou + + * tracebak.c (PPC AIX/Darwin): Define FORCE_CALL to 1. + (PPC VxWorks): Likewise. + (Generic unwinder): Define FORCE_CALL to 0 if not already defined. + (forced_callee): Make non-inlinable and non-pure. + (__gnat_backtrace): Call forced_callee if FORCE_CALL is set to 1. + +2006-02-13 Arnaud Charlet + Ben Brosgol + Robert Dewar + + * gnat_rm.texi, gnat_ugn.texi: Remove limitations with sparc m64 + support. + Document that gnatbind -M option is for cross environments only. + Added description of using gnatmem to trace gnat rtl allocs and deallocs + Add note on use of $ to label implicit run time calls + Add documentation for -gnatyI (check mode IN) + Updated chapter on compatibility with HP Ada + VMS-oriented edits. + Ran spell and corrected errors + Add documentation for gnatbind -d and rework documentation of -D + at the same time. + Add subprogram/data elimination section. + Minor editing of annex A. + Add section for gnatcheck. + Add documentation for restriction No_Dispatching_Calls + Add documentation for pragma Ada_2005 + Remove mention of obsolete pragma Propagate_Exceptions + Document that pragma Unreferenced can appear after DO in ACCEPT + Clarify Pure_Function for library level units + Mention Max/Min in connection with No_Implicit_Conditionals + No_Wide_Characters restriction is no longer partition-wide + Add a nice example for Universal_Literal_String attribute + Document that pragma No_Return can take multiple arguments + + * ug_words: Added entry for gnatcheck + + * g-ctrl_c.ads (Install_Handler): Enhance comments + + * g-os_lib.ads: Add comments to OS_Exit that it is abrupt termination + + * g-trasym.ads: Add documentation on how to do off line symbolic + traceback computation. + + * s-fatgen.adb: Add comments for Unaligned_Valid + + * stand.ads: Fix typo in comment + +2006-02-09 Rainer Orth + + * Make-lang.in (check-gnat): Run run_acats with $(SHELL). + +2006-02-06 Roger Sayle + + * decl.c (gnat_substitute_in_type): Don't handle CHAR_TYPE. + +2006-02-03 John David Anglin + + PR target/25926 + * initialize.c (__gnat_initialize): Provide HP-UX 10 host and target + implementation that calls __main. + +2006-01-25 Peter O'Gorman + + PR bootstrap/25859 + * Makefile.in (GCC_LINK): Remove quotes. + (tools targets): Link with either $(GNATLINK) --GCC="$(GCC_LINK)" + or $(GCC_LINK). + + (powerpc-darwin): Pass -shared-libgcc when building shared library. + +2006-01-20 John David Anglin + + PR ada/24533 + * s-osinte-linux-hppa.ads: Reduce alignment of atomic_lock_t to 8. + + + +Copyright (C) 2006 Free Software Foundation, Inc. + +Copying and distribution of this file, with or without modification, +are permitted in any medium without royalty provided the copyright +notice and this notice are preserved. diff --git a/gcc/ada/ChangeLog-2007 b/gcc/ada/ChangeLog-2007 new file mode 100644 index 000000000..30a63656e --- /dev/null +++ b/gcc/ada/ChangeLog-2007 @@ -0,0 +1,9221 @@ +2007-12-27 Samuel Tardieu + + PR ada/34553 + * adaint.c (__gnat_open_new_temp, __gnat_tmp_name): Use mkstemp() + instead of mktemp() or tmpnam() on NetBSD. + +2007-12-23 Eric Botcazou + + * trans.c (call_to_gnu): Make the temporary for non-addressable + In parameters passed by reference. + (addressable_p): Return true for STRING_CST and CALL_EXPR. + +2007-12-19 Robert Dewar + + * g-expect-vms.adb, g-expect.adb, s-poosiz.adb: + Add pragma Warnings (Off) for unassigned IN OUT arguments + + * sem_warn.adb (Output_Reference): Suppress messages for internal names + (Check_References): Extensive changes to tune up warnings + (Output_Non_Modifed_In_Out_Warnings): Changes to tune up warnings + (Has_Pragma_Unmodifed_Check_Spec): New function + (Check_References): Implement pragma Unmodified + (Warn_On_Unassigned_Out_Parameter): Implement pragma Unmodified + + * par-prag.adb: Dummy entry for pragma Unmodified + + * sem_prag.adb: Implement pragma Unmodified + + * einfo.ads, einfo.adb: (Has_Pragma_Unmodified): New flag + (Proc_Next_Component_Or_Discriminant): Fix typo. + Update comments. + + * sem_util.adb (Note_Possible_Modification): Add processinng for pragma + Unmodified. + (Reset_Analyzed_Flags): Use Traverse_Proc instead of Traverse_Func, + because the former already takes care of discarding the result. + (Mark_Coextensions): Remove ununused initial value from Is_Dynamic. + Add comment. + + * snames.h, snames.ads, snames.adb: Add entry for pragma Unmodified + +2007-12-19 Eric Botcazou + + * targparm.adb, targparm.ads, system.ads, system-darwin-ppc.ads, + system-vxworks-x86.ads, system-linux-ppc.ads, system-linux-hppa.ads, + system-hpux-ia64.ads, system-vxworks-arm.ads, system-darwin-x86.ads, + system-vms_64.ads, system-vms-ia64.ads, system-linux-ia64.ads, + system-freebsd-x86.ads, system-linux-x86_64.ads, system-tru64.ads, + system-aix.ads, system-vxworks-sparcv9.ads, system-solaris-x86.ads, + system-irix-o32.ads, system-irix-n32.ads, system-hpux.ads, + system-vxworks-m68k.ads, system-linux-x86.ads, system-vxworks-mips.ads, + system-solaris-sparc.ads, system-solaris-sparcv9.ads, system-vms.ads, + system-mingw.ads, system-vms-zcx.ads, system-vxworks-ppc.ads + (Dynamic_Trampolines_Used): Delete. + + * system-lynxos-x86.ads, system-lynxos-ppc.ads: Ditto. + Turn on stack probing mechanism on LynxOS. + +2007-12-19 Bob Duff + + * atree.ads, atree.adb (Traverse_Func): Walk Field2 last, and eliminate + the resulting tail recursion by hand. This prevents running out of + memory on deeply nested concatenations, since Field2 is where the left + operand of concatenations is stored. + Fix bug (was returning OK_Orig in some cases). Fix return subtype to + clarify that it can only return OK or Abandon. + + * sem_res.adb (Resolve_Op_Concat): Replace the recursion on the left + operand by iteration, in order to avoid running out of memory on + deeply-nested concatenations. Use the Parent pointer to get back up the + tree. + (Resolve_Op_Concat_Arg, Resolve_Op_Concat_First, + Resolve_Op_Concat_Rest): New procedures split out of + Resolve_Op_Concat, so the iterative algorithm in Resolve_Op_Concat is + clearer. + + * checks.adb (Remove_Checks): Use Traverse_Proc instead of + Traverse_Func, because the former already takes care of discarding the + result. + + * errout.adb (First_Node): Use Traverse_Proc instead of Traverse_Func, + because the former already takes care of discarding the result. + (Remove_Warning_Messages): Use appropriate subtype for Status and + Discard + +2007-12-19 Ed Schonberg + + * exp_aggr.adb (Not_OK_For_Backend): A component of a private type with + discriminants forces expansion of the aggregate into assignments. + (Init_Record_Controller): If the type of the aggregate is untagged and + is not inherently limited, the record controller is not limited either. + +2007-12-19 Robert Dewar + + * exp_attr.adb (Expand_N_Attribute_Reference, case Size): Fix error in + handling compile time known size of record or array (case of front end + layout active, e.g. in GNAAMP). + +2007-12-19 Javier Miranda + + * exp_ch3.adb (Expand_N_Object_Declaration): Complete the circuitry + that forces the construction of static dispatch tables in case of + record subtypes. + +2007-12-19 Robert Dewar + + * exp_ch9.adb (Null_Statements): Moved to library level + (Trivial_Accept_OK): New function + (Expand_Accept_Declaration): Use Trivial_Accept_OK + (Expand_N_Accept_Statement): Use Trivial_Accept_OK + +2007-12-19 Robert Dewar + + * exp_pakd.adb (Expand_Bit_Packed_Element_Set): Fix packed array type + in complex case where array is Volatile. + +2007-12-19 Ed Schonberg + + * freeze.adb (Freeze_Record_Type, Check_Current_Instance): Implement + properly the Ada2005 rules concerning when the current instance of a + record type is aliased. + +2007-12-19 Ed Schonberg + + * par-ch3.adb (P_Record_Declaration): Guard against cascaded errors in + mangled declaration + (P_Type_Declaration): Diagnose misuse of "abstract" in untagged record + declarations. + (P_Variant_Part): Cleaner patch for parenthesized discriminant + +2007-12-19 Vincent Celier + + * prj-attr.adb (Package_Node_Id_Of): Returns Unknown_Package when + package is not known + + * prj-attr.ads (Unknown_Package): New constant + Do not crash when an unknown package is in several projects + + * prj-dect.adb (Parse_Package_Declaration): Mark an unknown package as + ignored + + * prj-nmsc.adb (Check): Remove obsolete code related to no longer + existing package Language_Processing. + +2007-12-19 Ed Schonberg + Gary Dismukes + Samuel Tardieu + + PR ada/15803, ada/15805 + * sem_ch6.adb, sem_ch3.adb (Constrain_Access): In Ada2005, diagnose + illegal access subtypes when there is a constrained partial view. + (Check_For_Premature_Usage): New procedure inside + Access_Subprogram_Declaration for checking that an access-to-subprogram + type doesn't reference its own name within any formal parameters or + result type (including within nested anonymous access types). + (Access_Subprogram_Declaration): Add call to Check_For_Premature_Usage. + (Sem_Ch3.Analyze_Object_Declaration, Sem_ch6.Process_Formals): if the + context is an access_to_variable, the expression cannot be an + access_to_constant. + +2007-12-19 Bob Duff + + * sem_ch4.adb (Analyze_Concatenation_Rest): New procedure. + (Analyze_Concatenation): Use iteration instead of recursion in order + to avoid running out of stack space for deeply nested concatenations. + +2007-12-19 Ed Schonberg + Gary Dismukes + + * sem_ch8.adb (Analyze_Subprogram_Renaming): Diagnose illegal renamings + whose renamed entity is a subprogram that requires overriding. + (Premature_Usage): Test for the case of N_Full_Type_Declaration when + issuing an error for premature usage and issue a message that says + 'type' rather than 'object'. + +2007-12-19 Gary Dismukes + + PR ada/34149 + * sem_disp.adb (Check_Dispatching_Call): Augment existing test for + presence of a statically tagged operand (Present (Static_Tag)) with + test for Indeterm_Ancestor_Call when determining whether to propagate + the static tag to tag-indeterminate operands (which forces dispatching + on such calls). + (Check_Controlling_Formals): Ada2005, access parameters can have + defaults. + (Add_Dispatching_Operation, Check_Operation_From_Private_View): do + not insert subprogram in list of primitive operations if already there. + +2007-12-19 Tristan Gingold + + * utils.c (create_var_decl_1): call rest_of_decl_compilation only for + global variable. + +2007-12-19 Thomas Quinot + + Part of PR ada/33688 + * gen-soccon.c: Add constant IP_PKTINFO to allow getting ancillary + datagram info on Linux. + +2007-12-19 Vincent Celier + + * makegpr.adb (Check_Compilation_Needed): Normalize C_Source_Path so + that the source path name is always found in the dependencies. + +2007-12-19 Robert Dewar + + * gnat_rm.texi, gnat_ugn.texi: Update documentation of -gnatw.o + Fix name of Wide_Wide_Latin_1/9 file names + Add documentation for Ada.Exceptions.Last_Chance_Handler (a-elchha.ads) + Add missing documentation for Ada.Wide_[Wide_]Characters.Unicode + Add missing documentation for Ada.Command_Line.Response_File + Update list of warning letters for Warnings pragma + Add documentation for pragma Unmodified + +2007-12-19 Samuel Tardieu + + * Makefile.in: Add s-tasinf.ad[bs] substitutions for sh4-linux target. + +2007-12-17 Arnaud Charlet + + * s-vxwork-alpha.ads: Removed, no longer used. + +2007-12-15 Jakub Jelinek + + * Make-lang.in (gnat1, gnatbind): Pass ALL_CFLAGS on the link line. + +2007-12-13 Samuel Tardieu + + PR ada/34360 + * Makefile.in: Change two occurrences of mlib-tgt.adb by correct name + mlib-tgt-specific.adb. + +2007-12-13 Bob Duff + + * trans.c (Attribute_to_gnu): Check for violations of the + No_Implicit_Dynamic_Code restriction. This checking used to be done in + the front end, but is moved here so we can make it more accurate. + +2007-12-13 Pascal Obry + + * adaint.c (__gnat_pthread_setaffinity_np): New routine. A dummy + version is provided for older GNU/Linux distribution not + supporting thread affinity sets. + + * s-osinte-linux.ads (SC_NPROCESSORS_ONLN): New constant for sysconf + call. + (bit_field): New packed boolean type used by cpu_set_t. + (cpu_set_t): New type corresponding to the C type with + the same name. Note that on the Ada side we use a bit + field array for the affinity mask. There is not need + for the C macro for setting individual bit. + (pthread_setaffinity_np): New imported routine. + + * s-taprop-linux.adb (Enter_Task): Check that the CPU affinity mask is + no null. + (Create_Task): Set the processor affinity mask if information + is present. + + * s-tasinf-linux.ads, s-tasinf-linux.adb: New files. + +2007-12-13 Robert Dewar + + * s-osinte-lynxos-3.ads, s-osinte-hpux.ads, s-osinte-solaris-posix.ads, + s-osinte-freebsd.ads, s-osinte-lynxos.ads, s-osinte-tru64.ads, + s-osinte-mingw.ads, s-osinte-aix.ads, s-osinte-hpux-dce.ads, + s-osinte-irix.ads, s-osinte-solaris.ads, s-intman-vms.adb, + s-osinte-vms.ads, s-osinte-vxworks6.ads, s-osinte-vxworks.ads, + s-auxdec.ads, s-auxdec-vms_64.ads, s-osinte-darwin.ads, + s-taprop-vms.adb, s-interr-sigaction.adb, s-osinte-linux-hppa.ads, + i-vxwork-x86.ads, s-tpopde-vms.ads: Add missing pragma Convention C + for subprogram pointers. + + * g-ctrl_c.adb: New file. + + * g-ctrl_c.ads (Install_Handler): New body. + + * freeze.adb (Freeze_Subprogram): Use new flag Has_Pragma_Inline_Always + instead of obsolete function Is_Always_Inlined. + (Freeze_Entity): check for tagged type in imported C subprogram + (Freeze_Entity): check for 8-bit boolean in imported C subprogram + (Freeze_Entity): check for convention Ada subprogram pointer in + imported C subprogram. + (Freeze_Fixed_Point_Type): In the case of a base type where the low + bound would be chopped off and go from negative to zero, force + Loval_Excl_EP to be the same as Loval_Incl_EP (the included lower + bound) so that the size computation for the base type will take + negative values into account. + +2007-12-13 Eric Botcazou + Bob Duff + Tristan Gingold + + * system-linux-ia64.ads, system-freebsd-x86.ads, system-lynxos-ppc.ads, + system-lynxos-x86.ads, system-linux-x86_64.ads, system-tru64.ads, + system-aix.ads, system-vxworks-sparcv9.ads, system-solaris-x86.ads, + system-irix-o32.ads, system-irix-n32.ads, system-hpux.ads, + system-vxworks-m68k.ads, system-linux-x86.ads, system-vxworks-mips.ads, + system-solaris-sparc.ads, system-solaris-sparcv9.ads, system-vms.ads, + system-mingw.ads, system-vms-zcx.ads, system-vxworks-ppc.ads, + system-vxworks-arm.ads, system-darwin-x86.ads, system.ads, + system-vms_64.ads, system-darwin-ppc.ads, system-vxworks-x86.ads, + system-linux-ppc.ads, system-linux-hppa.ads, system-hpux-ia64.ads, + system-vms-ia64.ads (Stack_Check_Limits): New target parameter. + (Always_Compatible_Rep): New flag to control trampolines globally. + (Dynamic_Trampolines_Used): New flag for implementing the + No_Implicit_Dynamic_Code restriction more correctly (not yet used, + and not yet set correctly for some targets). + + * s-taprop-vxworks.adb: Use stack limit method of stack checking. + Simply indirectly call s-stchop when a task is created. + + * ali.ads: + New flag added: Stack_Check_Switch_Set which is set when '-fstack-check' + appears as an argument (entries A) in an ALI file. + + * fe.h (Stack_Check_Limits): Declare new target parameter. + (Check_Implicit_Dynamic_Code_Allowed): New procedure. + + * init.c: Declare __gnat_set_stack_limit_hook for VxWorks kernel RTS. + This variable is declared in C to be sure not subject to elaboration + code. + (__gnat_map_signal, VxWorks): In kernel mode, map SIGILL to + Storage_Error. + + * targparm.ads, targparm.adb (Stack_Check_Limits): New parameter. + (Always_Compatible_Rep, Dynamic_Trampolines_Used): New parameters. + + * s-stchop.ads: Add comments. + + * s-stchop-vxworks.adb: Package almost fully rewritten to use stack + limit method of stack checking. + + * s-stchop-limit.ads: New file. + +2007-12-13 Robert Dewar + + * sem_ch5.adb, s-taskin.adb, a-ciorma.adb, a-coorma.adb, a-cohama.adb, + a-cihama.adb, g-awk.adb, + s-inmaop-posix.adb: Update handling of assigned value/unreferenced + warnings + + * exp_smem.adb: Update handling of assigned value/unreferenced warnings + + * sem.adb: Update handling of assigned value/unreferenced warnings + + * a-exexpr-gcc.adb: Add a pragma warnings off for boolean return + + * lib-xref.ads: Improve documentation for k xref type + + * lib-xref.adb: + Update handling of assigned value/unreferenced warnings + (Generate_Reference): Warning for reference to entity for which a + pragma Unreferenced has been given should be unconditional. + If the entity is a discriminal, mark the original + discriminant as referenced. + + * sem_warn.ads, sem_warn.adb + (Check_One_Unit): Test Renamed_In_Spec to control giving warning for + no entities referenced in package + (Check_One_Unit): Don't give message about no entities referenced in + a package if a pragma Unreferenced has appeared. + Handle new warning flag -gnatw.a/-gnatw.A + Update handling of assigned value/unreferenced warnings + + * atree.h: Add flags up to Flag247 + (Flag231): New macro. + +2007-12-13 Jose Ruiz + + * adaint.h: (__gnat_plist_init): Not defined for RTX. + + * initialize.c (__gnat_initialize): Do not call __gnat_plist_init for + RTX systems. + + * Makefile.in: Add new files s-tasinf-linux.ads and s-tasinf-linux.adb. + (LIBGNAT_TARGET_PAIRS, MISCLIB, THREADSLIB, + EXTRA_GNATRTL_NONTASKING_OBJS, EXTRA_GNATRTL_TASKING_OBJS, + GNATLIB_SHARED for RTX run time): Use the versions required by RTX. + + * mingw32.h: + Do not define GNAT_UNICODE_SUPPORT for RTX since it is not supported. + + * sysdep.c (winflush_function for RTX): Procedure that does nothing + since we only have problems with Windows 95/98, which are not + supported by RTX. + (__gnat_ttyname): Return the empty string on Nucleus, just as + done on vxworks. + +2007-12-13 Robert Dewar + + * a-textio.adb, a-textio.ads: + Extensive changes to private part for wide character encoding + + * a-witeio.adb, a-witeio.ads, a-ztexio.ads, a-ztexio.adb + (Look_Ahead): Fix mishandling of encoded sequences + Move declaration of Wch_Con to private part (should not be visible) + + * ali.adb (Scan_ALI): Set default encoding method to brackets instead of + UTF-8. Probably this is never used, but if it is, brackets is + clearly correct. + + * bindgen.adb (Get_WC_Encoding): New procedure to properly handle + setting wide character encoding for no main program case and when + encoding is specified using -W? + Initialize stack limit of environment task if stack limit method of + stack checking is enabled. + (Gen_Adainit_Ada): Use Get_WC_Encoding to output encoding method + (Gen_Adainit_C): Use Get_WC_Encoding to output encoding method + (Get_Main_Unit_Name): New function. + (Gen_Adainit_Ada): Add call to main program for .NET when needed. + (Gen_Output_File): Set Bind_Main_Program to True for .NET + + * bindusg.adb: Add line for -Wx switch + + * s-wchcon.adb, s-wchcon.ads: (Is_Start_Of_Encoding): New function + Add comments + Add new useful constant WC_Longest_Sequences + + * switch-b.adb: Clean up handling of -Wx switch + For -gnatWx, set Wide_Character_Encoding_Method_Specified + + * switch-c.adb: -gnatg activates warning on assertion errors + For -gnatWx, set Wide_Character_Encoding_Method_Specified + + * s-wchcon.adb: (Is_Start_Of_Encoding): New function + +2007-12-13 Robert Dewar + Ed Schonberg + + * a-ngcoty.adb: New pragma Fast_Math + + * opt.adb: New pragma Fast_Math + + * par-prag.adb: + Add Implemented_By_Entry to the list of pragmas which do not require any + special processing. + (Favor_Top_Level): New pragma. + New pragma Fast_Math + + * exp_attr.adb: Move Wide_[Wide_]Image routines to Exp_Imgv + (Expand_N_Attribute_Reference, Displace_Allocator_Pointer, + Expand_Allocator_Expression): Take into account VM_Target + (Expand_Attribute, case 'Identity): Handle properly the case where + the prefix is a task interface. + New pragma Fast_Math + + * par.adb (Next_Token_Is): New function + (P_Pragma): Add Skipping parameter + (U_Left_Paren): New procedure + (U_Right_Paren): New procedure + New pragma Fast_Math + + * par-ch10.adb (P_Subunit): Unconditional msg for missing ) after + subunit + New pragma Fast_Math + + * sem_prag.adb: Add significance value to table Sig_Flag for pragma + Implemented_By_Entry. + (Analyze_Pragma): Add case for Ada 2005 pragma Implemented_By_Entry. + (Set_Inline_Flags): Do not try to link pragma Inline onto chain of rep + items, since it can apply to more than one overloadable entity. Set + new flag Has_Pragma_Inline_Always for Inline_Always case. + (Analyze_Pragma, case Complex_Representation): Improve error message. + (Analyze_Pragma, case Assert): When assertions are disabled build the + rewritten code with Sloc of expression rather than pragma, so new + warning about failing is not deleted. + (Analyze_Pragma): Allow pragma Preelaborable_Initialization to apply to + protected types and update error message to reflect that. Test whether + the protected type is allowed for the pragma (an error is issued if the + type has any entries, or components that do not have preelaborable + initialization). + New pragma Fast_Math + (Analyze_Pragma, case No_Return): Handle generic instance + + * snames.h, snames.ads, snames.adb: + Add new predefined name for interface primitive _Disp_Requeue. + New pragma Fast_Math + + * a-tags.ads, a-tags.adb: New calling sequence for + String_To_Wide_[Wide_]String + (Secondary_Tag): New subprogram. + + * exp_imgv.ads, exp_imgv.adb: Move Wide_[Wide_]Image routines here + from Exp_Attr + New calling sequence for String_To_Wide_[Wide_]String + (Expand_Image_Attribute): Major rewrite. New calling sequence avoids + the use of the secondary stack for image routines. + + * a-except-2005.adb, s-wchstw.ads, s-wchstw.adb, s-wwdenu.adb: New + calling sequence for String_To_Wide_[Wide_]String + + * par-ch3.adb (P_Declarative_Items): Recognize use of Overriding in + Ada 95 mode + (P_Unknown_Discriminant_Part_Opt): Handle missing parens gracefully + Remove Atree.Delete_Tree/Delete_Node and Nlist.Delete_List + + * par-ch6.adb (P_Subprogram): Recognize use of Overriding in Ada 95 mode + (P_Formal_Part): Use Skipping parameter in P_Pragma call + to improve error recovery + + * par-util.adb (Next_Token_Is): New function + (Signal_Bad_Attribute): Use new Namet.Is_Bad_Spelling_Of function + + * par-ch2.adb (Skip_Pragma_Semicolon): Do not resynchronize to + semicolon if missing + (P_Pragma): Implement new Skipping parameter + Remove Atree.Delete_Tree/Delete_Node and Nlist.Delete_List + Fix location of flag for unrecognized pragma message + + * par-tchk.adb (U_Left_Paren): New procedure + (U_Right_Paren): New procedure + +2007-12-13 Geert Bosch + + * a-tifiio.adb: + (Put_Int64): 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. + (Put): Initialize Pos. + +2007-12-13 Robert Dewar + + atree.ads, atree.adb (Flag231..Flag247): New functions + (Set_Flag231..Set_Flag247): New procedures + (Basic_Set_Convention): Rename Set_Convention to be + Basic_Set_Convention + (Nkind_In): New functions + Remove Atree.Delete_Tree/Delete_Node and Nlist.Delete_List + + * exp_ch6.adb (Expand_Call): Use new flag Has_Pragma_Inline_Always + instead + of obsolete function Is_Always_Inlined + (Register_Predefined_DT_Entry): Initialize slots of the second + secondary dispatch table. + Remove Atree.Delete_Tree/Delete_Node and Nlist.Delete_List + (Expand_N_Function_Call): Remove special provision for stack checking. + + * exp_util.ads, exp_util.adb (Is_Predefined_Dispatching_Operation): + Include _Disp_Requeue in the list of predefined operations. + (Find_Interface_ADT): Modified to fulfill the new specification. + Remove Atree.Delete_Tree/Delete_Node and Nlist.Delete_List + + * par-ch4.adb, nlists.ads, nlists.adb: + Remove Atree.Delete_Tree/Delete_Node and Nlist.Delete_List + + * sinfo.ads, sinfo.adb: (Nkind_In): New functions + Fix location of flag for unrecognized pragma message + + * sem_ch7.adb: Use Nkind_In + +2007-12-13 Vincent Celier + + * opt.ads: + Indicate what flags are used by the Project Manager, gprbuild and + gprclean. + (Opt.Follow_Links_For_Dirs): New flag + (Warn_On_Assertion_Failure): New flag + (Wide_Character_Encoding_Method_Specified): New flag + (Suppress_All_Inlining): New switch set by -fno-inline + (Real_VMS_Target): New flag + New pragma Fast_Math + +2007-12-13 Robert Dewar + + * back_end.adb: Recognize -fno-inline + +2007-12-13 Robert Dewar + + * checks.adb: Fix optimization problem with short-circuited form + +2007-12-13 Bob Duff + + * clean.adb (Usage): Add line for -aP + (Check_Version_And_Help): Change Check_Version_And_Help to be generic, + with a parameter "procedure Usage", instead of passing a pointer to a + procedure. This is to eliminate trampolines (since the Usage procedure + is often nested in a main procedure, and it would be inconvenient to + unnest it). + + * g-comlin.adb (For_Each_Simple_Switch): Change For_Each_Simple_Switch + to be generic, with a parameter "procedure Callback (...)", instead of + passing a pointer to a procedure. This is to eliminate trampolines + (since the Callback procedure is usually nested). + + * gnatfind.adb, switch.adb, switch.ads, gnatlink.adb, gnatls.adb, + gnatname.adb, gnatxref.adb, gnatchop.adb, gprep.adb, gnatbind.adb + (Check_Version_And_Help): Change Check_Version_And_Help to be generic. + + * g-pehage.adb (Compute_Edges_And_Vertices, Build_Identical_Key_Sets): + Use the generic Heap_Sort_G instead of Heap_Sort_A. + +2007-12-13 Hristian Kirtchev + + * einfo.ads, einfo.adb: Flag 232 is now Implemented_By_Entry. + (Implemented_By_Entry, Set_Implemented_By_Entry): New routines. + (Write_Entry_Flags): Add an entry for Implemented_By_Entry. + (Renamed_In_Spec): New flag + (Has_Pragma_Inline_Always): New flag + Add missing doc for pragma Obsolescent_Warning + Add missing doc for 17 additional unused flags (230-247) + (Is_Derived_Type): Remove condition "not Is_Generic_Type". + Alphabetize with clauses. + Separate Is_Thunk and Has_Thunks flags + (Write_Entity_Flags): Add forgotten entry for Has_Thunks + (Related_Interface): Renamed to Related_Type. + (Has_Thunks/Set_Has_Thunks): Subprograms of new attribute. + (Set_Is_Flag): Restrict the assertion. + +2007-12-13 Vincent Celier + + * errout.adb (Output_Source_Line): Do not keep a trailing space after + the source line number if the source line is empty. + +2007-12-13 Geert Bosch + + * eval_fat.adb (Decompose_Int): Handle argument of zero. + (Compose): Remove special casing of zero. + (Exponent): Likewise. + (Fraction): Likewise. + (Machine): Likewise. + (Decompose): Update comment. + +2007-12-13 Ed Schonberg + + * exp_aggr.adb (Build_Record_Aggr_Code): If there is an aggregate for a + limited ancestor part, initialize controllers of enclosing record + before expanding ancestor aggregate. + (Gen_Assign): If a component of the aggregate is box-initialized, add + code to call Initialize if the component is controlled, and explicit + assignment of null if the component is an access type. + + Handle properly aggregates for limited types that appear in object + declarations when the aggregate contains controlled values such as + protected types. + When expanding limited aggregates into individual components, do not + call Adjust on controlled components that are limited. + +2007-12-13 Ed Schonberg + + * expander.adb: Take into account N_Subprogram_Renaming_Declaration + +2007-12-13 Hristian Kirtchev + + * exp_ch3.adb (Predefined_Primitive_Bodies): Generate the body of + predefined primitive _Disp_Requeue. + (Make_Predefined_Primitive_Specs): Create the spec for predefined + primitive _Disp_Requeue. + (Make_Predefined_Primitive_Specs/Predefined_Primitive_Bodies): Set the + type of formal Renamed_Eq to Entity_Id (instead of Node_Id). + (Make_Predefined_Primitive_Specs): Spec of "=" needed if the parent is + an interface type. In case of limited interfaces we now declare all the + predefined primitives associated with synchronized interfaces as + abstract. + (Predef_Spec_Or_Body): For interface types generate abstract subprogram + declarations. + (Predefined_Primitive_Bodies): Add body of "=" if the parent of the + tagged type is an interface type and there is no user-defined equality + function. + Add also bodies of predefined primitives associated with synchronized + interfaces. + (Freeze_Record_Type): Do not build bodies of predefined primitives of + interface types because they are now defined abstract. + Add missing documentation. + (Expand_Record_Controller): Update occurrence of Related_Interface + to Related_Type. + (Build_Offset_To_Top_Functions): Do nothing in case of VM. + (Expand_N_Object_Declaration): Take into account VM_Target when handling + class wide interface object declaration. + (Expand_Previous_Access_Type): Do not create a duplicate master entity + if the access type already has one. + (Expand_N_Object_Declaration): Defend against attempt to validity check + generic types. Noticed for -gnatVcf specified with previous errors. + +2007-12-13 Arnaud Charlet + + * exp_ch4.adb (Expand_N_Attribute_Reference, Displace_Allocator_Pointer, + Expand_Allocator_Expression): Take into account VM_Target + + * exp_ch5.adb (Expand_N_Extended_Return_Statement): Do not use + secondary stack when VM_Target /= No_VM + +2007-12-13 Javier Miranda + Ed Schonberg + + * exp_ch7.adb (Expand_N_Package_Body): Replace occurrence of attribute + Is_Complation_Unit by Is_Library_Level_Entity in the code + that decides if the static dispatch tables need to be built. + (Wrap_Transient_Declaration): Do not generate a finalization call if + this is a renaming declaration and the renamed object is a component + of a controlled type. + +2007-12-13 Gary Dismukes + + * exp_ch8.ads, exp_ch8.adb (Expand_N_Subprogram_Renaming_Declaration): + In the case where the renamed subprogram is a dereference, call + Force_Evaluation on the prefix. + +2007-12-13 Hristian Kirtchev + Ed Schonberg + + * exp_ch9.adb (Expand_N_Asynchronous_Select, + Expand_N_Conditional_Entry_Call, Expand_N_Timed_Entry_Call): Code and + comment reformatting. + (Set_Privals): Inherit aliased flag from formal. From code reading. + (Build_Simple_Entry_Call): Out parameters of an access type are passed + by copy and initialized from the actual. This includes entry parameters. + (Expand_N_Requeue_Statement): Reimplement in order to handle both Ada 95 + and Ada 2005 models of requeue. + (Null_Statements): Still connsider do-end block null if it contains + Unreferenced and Warnings pragmas. + (Expand_N_Accept_Statement): Do not optimize away null do end if + dispatching policy is other than defaulted. + (Expand_N_Timed_Entry_Call): When the triggering statement is a + dispatching call, manually analyze the delay statement. + (Find_Parameter_Type): Move subprogram to Sem_Util. + +2007-12-13 Hristian Kirtchev + Javier Miranda + + * exp_disp.ads, exp_disp.adb (Default_Prim_Op_Position): Primitive + _Disp_Requeue occupies dispatch table slot number 15. Move + _Disp_Timed_Select to slot 16. + (Make_Disp_Requeue_Body, Make_Disp_Requeue_Spec): New routines which + generate the spec and body of _Disp_Reqeueue. + (Make_DT): Build and initialize the second dispatch table. + Handle initialization of RC_Offset when the parent + is a private type with variable size components. + (Make_Secondary_DT): Complete documentation. Add support to + initialize the second dispatch table. + (Make_Tags): Generate the tag of the second dispatch table. + (Register_Primitive): Add support to register primitives in the + second dispatch table. + +2007-12-13 Pascal Obry + + * expect.c (__gnat_kill) [WIN32]: Implement the SIGINT signal on + Windows. This signal is used by gnatmake to kill child processes for + example. + +2007-12-13 Javier Miranda + + * exp_intr.adb (Expand_Dispatching_Constructor_Call): Add missing + support for generic dispatching constructor calls in which we need to + locate the tag of a secondary dispatch table associated with an + interface type to properly dispatch the call. + (Expand_N_Attribute_Reference [case Address], + Expand_Dispatching_Constructor_Call, Expand_Unc_Deallocation): Fix + handling of VM targets. + +2007-12-13 Robert Dewar + Ed Schonberg + + * exp_prag.adb (Expand_Pragma_Assert): Recognize new warning flag for + assert fail + + * ug_words: Add entries for -gnatw.a -gnatw.A + + * sem_res.adb (Set_String_Literal_Subtype): If the context of the + literal is a subtype with non-static constraints, use the base type of + the context as the base of the string subtype, to prevent type + mismatches in gigi. + (Resolve_Actuals): If the actual is an entity name, generate a + reference before the actual is resolved and expanded, to prevent + spurious warnings on formals of enclosing protected operations. + (Analyze_Overloaded_Selected_Component): If type of prefix if + class-wide, use visible components of base type. + (Resolve_Selected_Component): Ditto. + (Resolve_Short_Circuit): Detect case of pragma Assert argument + evaluating to False, and issue warning message. + + * usage.adb: Add lines for -gnatw.a and -gnatw.A + +2007-12-13 Emmanuel Briot + + * g-calend.ads (No_Time): New constant, to represent an uninitialized + time value + + * g-catiio.ads, g-catiio.adb (Value): Added support for more date + formats. + (Month_Name_To_Number): New subprogram + + * g-dirope.adb (Get_Current_Dir): On windows, normalize the drive + letter to upper-case. + +2007-12-13 Robert Dewar + Ed Schonberg + + * gnat1drv.adb (Gnat1drv): Properly set new flag Opt.Real_VMS_Target + + * layout.adb (Resolve_Attribute, case 'Access): If designated type of + context is a limited view, use non-limited view when available. If the + non-limited view is an unconstrained array, this enforces consistency + requirements in 3.10.2 (27). + (Layout_Type): For an access type whose designated type is a limited + view, examine its declaration to determine if it is an unconstrained + array, and size the access type accordingly. + (Layout_Type): Do not force 32-bits for convention c subprogram + pointers in -gnatdm mode, only if real vms target. + + * sem_attr.adb (Analyze_Access_Attribute): Use new flag + Has_Pragma_Inline_Always instead of obsolete function Is_Always_Inlined + (Analyze_Access_Attribute,Attribute_Address): Remove checks for + violations of the No_Implicit_Dynamic_Code restriction. + (Resolve_Attribute, case 'Access): If designated type of context is a + limited view, use non-limited view when available. If the non-limited + view is an unconstrained array, this enforces consistency requirements + in 3.10.2 (27). + (Layout_Type): For an access type whose designated type is a limited + view, examine its declaration to determine if it is an unconstrained + array, and size the access type accordingly. + +2007-12-13 Vincent Celier + + * gnatcmd.adb (GNATCmd): Do not issue -d= switch to gnatmetric when + object directory of main project does not exist. + On VMS, correctly set then environment variable for the source + directories. + +2007-12-13 Vasiliy Fofanov + + * g-regist.ads, g-regist.adb (Set_Value): new parameter Expand; when + set to True this procedure will create the value of type REG_EXPAND_SZ. + It was only possible to create REG_SZ values before. + +2007-12-13 Robert Dewar + + * g-spchge.ads, g-spchge.adb, g-u3spch.adb, g-u3spch.ads, + g-wispch.adb, g-wispch.ads, g-zspche.adb, g-zspche.ads, + namet-sp.adb, namet-sp.ads: New files. + + * g-speche.adb: Use generic routine in g-spchge + + * s-wchcnv.ads, s-wchcnv.adb: + Minor code cleanup (make formal type consistent with spec) + + * namet.adb: Update comments. + + * par-endh.adb (Evaluate_End_Entry): Use new + Namet.Sp.Is_Bad_Spelling_Of function + + * par-load.adb (Load): Use new Namet.Sp.Is_Bad_Spelling_Of function + + * sem_aggr.adb (Resolve_Record_Aggregate): If a component of an + ancestor is an access type initialized with a box, set its type + explicitly, for use in subsequent expansion. + (Check_Misspelled_Component): Use new Namet.Sp.Is_Bad_Spelling_Of + function + +2007-12-13 Robert Dewar + + * g-spipat.adb (Break): Fix accessibility error (vsn taking not null + access Vstring) + +2007-12-13 Robert Dewar + + * inline.adb (Back_End_Cannot_Inline): Use new flag + Has_Pragma_Inline_Always instead of obsolete function Is_Always_Inlined + + * sem_ch6.ads, sem_ch6.adb (Analyze_Subprogram_Body): Use new flag + Has_Pragma_Inline_Always instead. + of obsolete function Is_Always_Inlined + (Build_Body_To_Inline): Same change + (Cannot_Inline): Same change + Do not give warning on exception raise in No_Return function + + * sem_ch13.adb (Analyze_Record_Representation_Clause): If an inherited + component has two inconsistent component clauses in the same record + representation clause, favor the message that complains about + duplication rather than inconsistency. + Update comments. + (Record_Representation_Clause): Do not warn on missing component + clauses for inherited components of a type extension. + (Rep_Item_Too_Late): Do not attempt to link pragma into rep chain for + an overloadable item if it is a pragma that can apply to multiple + overloadable entities (e.g. Inline) because a pragma cannot be on + more than one chain at a time. + (Validate_Unchecked_Conversion): Add code to warn on unchecked + conversion where one of the operands is Ada.Calendar.Time. + (Analyze_Attribute_Definition_Clause): Fix typo in error message. + For now, ignore Component_Size clause on VM targets, as done for + pragma Pack. + +2007-12-13 Emmanuel Briot + Vincent Celier + + * prj.ads, prj.adb (Is_A_Language): Now takes a Name_Id instead of a + string + (Must_Check_Configuration, Default_Language_Is_Ada): new flags in + prj.ads + (Hash): Move instantiation of System.HTable.Hash from spec to body + (prj-nmsc.adb): Optimize calls to Name_Find when on case sensitive + systems, since we do not need to recompute the Name_Id for the canonical + file name. + (Body_Suffix_Id_Of, Spec_Suffix_Id_Of): new version that takes a name_id + as a parameter. This parameter is in fact always "ada" in all calls, and + we were doing 160560 extra calls to Name_Find to convert it to Name_Ada + while loading a project with 40000 files + + * prj-attr.adb: Fix name of attribute Dependency_Driver + Change the kind of indexing for attribute Root + + * prj-dect.adb (Parse_Declarative_Items): Allow redeclarations of + variables already declared, in case constructions. + + * prj-env.adb (Initialize): Reset Current_Source_Path_File and + Current_Object_Path_File to No_Path. + + * prj-ext.adb (Initialize_Project_Path): In multi language mode, use + ADA_PROJECT_PATH if value of GPR_PROJECT_PATH is empty. + + * prj-makr.adb: new parameter Current_Dir + + * prj-nmsc.ads, prj-nmsc.adb (Find_Explicit_Sources): Do not look for + Ada sources when language is not Ada. + Change Opt.Follow_Links to Opt.Follow_Links_For_Files. + (Find_Excluded_Sources, Find_Explicit_Sources): new subprograms + (Must_Check_Configuration, Default_Language_Is_Ada): new flags. + (Locate_Directory): Always resolve links when computing Canonical_Path + (Look_For_Sources): Make sure that Name_Buffer contains the file name + in Source_Files before checking for the presence of a directory + separator. + Optimize calls to Name_Find when on case sensitive systems. + (Body_Suffix_Id_Of, Spec_Suffix_Id_Of): new version that takes a name_id + as a parameter. + (Prj.Nmsc.Check): new parameter Current_Dir + (Check_Ada_Naming_Schemes): Restrictions on suffixes are relaxed. They + cannot be empty and the spec suffix cannot be the same as the body or + separate suffix. + (Get_Unit): When a file name can be of several unit kinds (spec, body or + subunit), always consider the longest suffix. + (Check_Configuration): Do not issue an error if there is no compiler + for a language. Just issue a warning and ignore the sources for the + language. + (Check_Library_Attributes): Only check Library_Dir if Library_Name is + not empty. + (Check_Naming_Schemes.Maked_Unit): Only output message if high verbosity + (Unit_Exceptions): New hash table + (Check_Naming_Schemes): Check if a file that could be a unit because of + the naming scheme is not in fact a source because there is an exception + for the unit. + (Look_For_Sources): Put the unit exceptions in hash table + Unit_Exceptions + (Get_Unit_Exceptions): Give initial value No_Source to local variable + Other_Part to avoid exception when code is compiled with validity + checking. + (Get_Sources_From_File): Check that there is no directory information + in the file names. + (Look_For_Sources): Check that there is no directory information in the + list of file names in Source_Files. + (Look_For_Sources): In multi-language mode, do not allow exception file + names that are excluded. + (Excluded_Sources_Htable): New hash table + (Search_Directories.Check_File): New procedure to simplify + Search_Directories. + (Search_Directories): Do not consider excluded sources + (Look_For_Sources): Populate Excluded_Sources_Htable before calling + Search_Directories. + (Get_Exceptions): Set component Lang_Kind of Source_Data + (Get_Unit_Exceptions): Ditto + (Search_Directories): Ditto + + * prj-pars.adb: new parameter Current_Dir + + * prj-part.ads, prj-part.adb: + Change Opt.Follow_Links to Opt.Follow_Links_For_Files. + (Opt.Follow_Links_For_Dirs): New flag + (Project_Path_Name_Of): Cache information returned by this routine as + Locate_Regular_File is a costly routine. The code to output a log + information and the effective call to Locate_Regular_File is now + factorized into a routine (code clean-up). + (Parse, Parse_Single_Project): new parameter Current_Dir + When main project file cannot be found, indicate in the error + message the project path that was used to do the search. + + * prj-proc.ads, prj-proc.adb (Opt.Follow_Links_For_Dirs): New flag + (Prj.Proc.Process*): new parameter Current_Dir + + * switch-m.adb: Change Opt.Follow_Links to Opt.Follow_Links_For_Files + +2007-12-13 Bob Duff + + * restrict.ads, restrict.adb (Check_Implicit_Dynamic_Code_Allowed): New + procedure to be called from the back end to check the + No_Implicit_Dynamic_Code restriction. + +2007-12-13 Arnaud Charlet + + * rtsfind.adb (Check_CRT): Take into account RTE_Available_Call + Fixes another case where RTE_Available_Call was ignored instead of being + taken into account. + (Load_Fail): Ditto. + + * rtsfind.ads: Add new entries. + +2007-12-13 Robert Dewar + + * g-byorma.adb, g-byorma.ads, g-decstr.adb, g-decstr.ads, + g-deutst.ads, g-encstr.adb, g-encstr.ads, g-enutst.ads: New files. + + * scn.adb: Implement BOM recognition + +2007-12-13 Thomas Quinot + Ed Schonberg + + * sem_ch10.adb (Check_Private_Child_Unit): A non-private library level + subprogram body that acts as its own spec may not have a non-private + WITH clause on a private sibling. + (Build_Unit_Name): If the parent unit in the name in a with_clause on a + child unit is a renaming, create an implicit with_clause on that + parent, and not on the unit it renames, to prevent visibility errors + in the current unit. + +2007-12-13 Ed Schonberg + + * sem_ch12.adb (Instantiate_Formal_Subprogram): In the subprogram + renaming declaration, use the Slocs of the formal parameters from the + declaration of the formal subprogram when creating the formal parameter + entities in the renaming declaration. + (Analyze_Formal_Type_Declaration): Change the placement of the error + message concerning illegal known discriminants. It is now posted on the + type rather than on the first discriminant. This change ensures early + error report. + (Freeze_Subprogram_Body): If the generic subprogram is nested within + the package body that contains the instance, do not generate an + out-of-place freeze node for the enclosing package. + (Collect_Previous_Instantiations): Ignore internal instantiations + generated for formal packages. + (Validate_Derived_Type_Instance): Add a check that when a formal + derived type is Known_To_Have_Preelab_Init then the actual type must + have preelaborable initialization, and issue an error when this + condition is violated. + +2007-12-13 Robert Dewar + + * s-imenne.adb, s-imenne.ads: New files. + + * s-imgboo.adb, s-imgboo.ads, s-imgcha.adb, s-imgcha.ads, s-imgdec.adb, + s-imgdec.ads, s-imgenu.ads, s-imgint.adb, s-imgint.ads, s-imglld.adb, + s-imglld.ads, s-imglli.adb, s-imglli.ads, s-imgllu.adb, s-imgllu.ads, + s-imgrea.adb, s-imgrea.ads, s-imguns.adb, s-imguns.ads, s-imgwch.adb, + s-imgwch.ads: New calling sequence for Image routines to avoid sec + stack usage. + +2007-12-13 Javier Miranda + Ed Schonberg + + * sem_ch3.ads, sem_ch3.adb (Check_Abstract_Overriding): Avoid + generation of spurious error if parent is an interface type; caused + because predefined primitive bodies will be generated later by + Freeze_Record_Type. + (Process_Subtype): The subtype inherits the Known_To_Have_Preelab_Init + flag. + (Derive_Subprograms): Handle derivations of predefined primitives + after all the user-defined primitives to ensure that they are + found in proper order in instantiations. + (Add_Interface_Tag_Components, Inherit_Components): Update occurrences + of Related_Interface to Related_Type. + (Record_Type_Declaration): Minor reordering of calls to decorate the + Tag component because the entity must have set its Ekind attribute + before setting its Is_Tag attribute. + (Analyze_Subtype_Declaration): In the case of subtypes with + Private_Kind, inherit Known_To_Have_Preelab_Init from the parent. + +2007-12-13 Hristian Kirtchev + Ed Schonberg + + * sem_ch4.adb (Analyze_Selected_Component): Include the requeue + statement to the list of contexts where a selected component with a + concurrent tagged type prefix should yield a primitive operation. + (Find_Primitive_Operation): Handle case of class-wide types. + (Analyze_Overloaded_Selected_Component): If type of prefix is + class-wide, use visible components of base type. + (Resolve_Selected_Component): Ditto. + (Try_Primitive_Operation, Collect_Generic_Type_Ops): If the type is a + formal of a generic subprogram. find candidate interpretations by + scanning the list of generic formal declarations.: + (Process_Implicit_Dereference_Prefix): If the prefix has an incomplete + type from a limited_with_clause, and the full view is available, use it + for subsequent semantic checks. + (Check_Misspelled_Selector): Use Namet.Sp.Is_Bad_Spelling_Of function + (Find_Primitive_Operation): New function. + (Analyze_Overloaded_Selected_Component): insert explicit dereference + only once if several interpretations of the prefix yield an access type. + (Try_Object_Operation): Code and comment cleanup. + (Analyze_Selected_Component): Reorder local variables. Minot comment and + code reformatting. When the type of the prefix is tagged concurrent, a + correct interpretation might be available in the primitive and + class-wide operations of the type. + +2007-12-13 Robert Dewar + Ed Schonberg + + * sem_ch8.adb (Analyze_Subprogram_Renaming): Special error message for + renaming entry as subprogram using rename-as-body if subprogram spec + frozen. + (Use_One_Type): The clause is legal on an access type whose designated + type has a limited view. + (Find_Direct_Name): Use Namet.Sp.Is_Bad_Spelling_Of function + (Find_Expanded_Name): Use Namet.Sp.Is_Bad_Spelling_Of function + (Analyze_Renamed_Primitive_Operation): new procedure to determine the + operation denoted by a selected component. + (Analyze_Renamed_Entry): Resolve the prefix of the entry name, because + it can be an expression, possibly overloaded, that returns a task or + an access to one. + +2007-12-13 Hristian Kirtchev + Gary Dismukes + + * sem_ch9.adb (Analyze_Requeue): Add a local flag to capture whether a + requeue statement is dispatching. Do not emit an error when the name is + not an entry and the context is a dispatching select. Add code to + perform subtype conformance between the formals of the current entry + and those of the target interface primitive. + (Analyze_Asynchronous_Select, Analyze_Conditional_Entry_Call, Analyze_ + Timed_Entry_Call): Analyze the triggering statement as the first step of + the processing. If this is a dispatching select, postpone the analysis + of all select statements until the Expander transforms the select. This + approach avoids generating duplicate identifiers after the Expander has + replicated some of the select statements. In case the Expander is + disabled, perform regular analysis. + (Check_Triggering_Statement): New routine. + (Analyze_Requeue): Exclude any interpretations that are not entries when + checking overloaded names in a requeue. Also test type conformance for + matching interpretations rather than requiring subtype conformance at + that point to conform with the RM's resolution rule for requeues. + +2007-12-13 Ed Schonberg + + * sem_disp.adb (Check_Dispatching_Call): If an actual in a call to an + inherited operation is a defaulted tag-indeterminate call, and there is + a statically tagged actual, use the static tag as a controlling actual + for the defaulted actual. + +2007-12-13 Geert Bosch + + * sem_eval.adb (Eval_Real_Literal): N_Constant_Declaration is a static + context, so do not call Check_Non_Static_Context. + +2007-12-13 Hristian Kirtchev + + * sem_type.adb (Function_Interp_Has_Abstract_Op): Add guard to check + whether formal E is an entity which may have parameters. + +2007-12-13 Bob Duff + Javier Miranda + Robert Dewar + + * sem_util.ads, sem_util.adb (Is_Concurrent_Interface): New routine. + (Set_Convention): New procedure to set the Convention flag, and in + addition make sure the Favor_Top_Level flag is kept in sync (all + foreign-language conventions require Favor_Top_Level = True). + (Collect_Abstract_Interfaces): Update occurrences of Related_Interface + to Related_Type. + (Collect_Interfaces_Info): Minor update to handle the two secondary + dispatch tables. Update occurrence of Related_Interface to Related_Type. + (Generate_Parent_Ref): Add parameter to specify entity to check + (Is_Preelaborable_Expression): Allow the name of a discriminant to + initialize a component of a type with preelaborable initialization. + This includes the case of a discriminal used in such a context. + (Is_Dependent_Component_Of_Mutable_Object): Take into account the + latest Ada 2005 rules about renaming and 'Access of + discriminant-dependent components. + (Check_Nested_Access): Add handling when there are no enclosing + subprograms (e.g. case of a package body). + (Find_Parameter_Type): Factor routine from several other compiler files. + Remove routine from Find_Overridden_Synchronized_Primitive. + +2007-12-13 Thomas Quinot + + * sinput.adb (Get_Source_File_Index): Add assertion to guard against + an invalid access to an uninitialized slot in the + Source_File_Index_Table. + +2007-12-13 Thomas Quinot + + * sinput-l.adb (Load_File): Disable style checks when preprocessing. + +2007-12-13 Bob Duff + + * s-soflin.ads: Apply new pragma Favor_Top_Level to all + access-to-subprogram types in this package. + +2007-12-13 Olivier Hainque + + * s-stausa.ads (Stack_Analyzer): Remove First_Is_Topmost, redundant + with Stack_Grows_Down in System.Parameters. Rename Array_Address into + Stack_Overlay_Address and document that we are using an internal + abstraction. + (Byte_Size, Unsigned_32_Size): Remove, now useless. + (Pattern_Type, Bytes_Per_Pattern): New subtype and constant, to be used + consistently throughout the various implementation pieces. + + * s-stausa.adb (Stack_Slots): New type, abstraction for the stack + overlay we are using to fill the stack area with patterns. + (Top_Slot_Index_In, Bottom_Slot_Index_In): Operations on Stack_Slots. + (Push_Index_Step_For, Pop_Index_Step_For): Likewise. + (Fill_Stack, Compute_Result): Use the Stack_Slots abstraction. + +2007-12-13 Robert Dewar + + * s-stoele.adb ("mod"): mod negative value raises Constraint_Error + +2007-12-13 Arnaud Charlet + + * s-tassta.adb: + (Create_Task): Take into account tasks created by foreign threads. + Code clean up: use constants instead of hard coded values. + +2007-12-13 Robert Dewar + + * styleg.adb (Check_Comment): More liberal rules for comment placement + +2007-12-13 Olivier Hainque + + * tb-alvms.c (struct tb_entry_t, __gnat_backtrace): Revert back to use + of Procedure Value instead of Frame Pointer as the invocation + identifier associated with the instruction pointer in each traceback + entry. + + * g-trasym-vms-alpha.adb (Traceback_Entry, PV_For, FP_For, + TB_Entry_For): Revert back to use of Procedure Value instead of Frame + Pointer as the invocation identifier passed to tbk$symbolize. + + * s-traent-vms.ads, s-traent-vms.adb + (Traceback_Entry, PV_For, FP_For, TB_Entry_For): Revert back to use of + Procedure Value instead of Frame Pointer as the invocation identifier + passed to tbk$symbolize. + +2007-12-13 Robert Dewar + + * tbuild.ads, tbuild.adb: + Fix location of flag for unrecognized pragma message + +2007-12-13 Robert Dewar + + * treepr.ads, treepr.adb: (pl): implement use of positive value + shorthands + +2007-12-13 Robert Dewar + + * xeinfo.adb: Remove warnings + * xnmake.adb: Remove warnings + * xsinfo.adb: Remove warnings + * xtreeprs.adb: Remove warnings + * xsnames.adb: Remove warnings + + * a-ngcoar.adb: Fix typo. + * s-interr.adb: Minor reformatting + * env.c: Minor reformatting. + * g-bytswa.adb: Minor reformatting. + * g-rannum.ads: Minor documentation improvements + * s-tasinf-mingw.adb: Minor header fix + * a-clrefi.adb: Minor reformatting + * g-sttsne.ads: Minor documentation improvement + * g-sttsne-locking.ads: Minor documentation improvement + * g-soliop-solaris.ads: Minor documentation improvement + * g-soliop-mingw.ads: Minor documentation improvement + * g-soliop.ads: Minor documentation improvement + * exp_aggr.ads: Minor reformatting + * debug.adb: Add documentation for the gprbuild debug flags + * exp_ch2.adb: Use Nkind_In to simplify code throughout + * exp_pakd.adb: Minor reformatting + + * g-altive.ads, g-alleve.adb: Remove assertions. + Add comment about minor differences between targets regarding + floating-point operations. + + * g-thread.adb: Remove pragma unreferenced. + * lib.ads: Minor reformatting + * par-ch9.adb: Minor reformatting of error messages + * sem_case.adb: Minor reformatting + * s-fileio.adb: Minor reformattinng + * s-vmexta.ads: Minor typo + * vxaddr2line.adb: + Take into account 'Success' value as per new GNAT warning. + +2007-12-13 Vincent Celier + + * a-direct.adb (Create_Path): Always take '/' as a directory separator, + even on Windows + +2007-12-13 Robert Dewar + Bob Duff + + * gnat_ugn.texi: Dcoument new rules for style check comment alignment + Document that suffixes may be terminations of each others + Add doc for -gnatw.a and -gnatw.A + Document gnatbind -Wx switch + Document BOM recognition + Document pragma Implemented_By_Entry. + Document new units. + + * gnat_rm.texi: (Favor_Top_Level): Document new pragma. + Add doc for pragma Unreferenced suppressing no entities referenced msg + Add documentation of GNAT.Directory_Operations.Iteration + Add documentation of GNAT.Random_Numbers + Add documentation for pragma Shared. + Correct documentation for Bit_Order + Add documentation for the Pool_Address attribute. + Fix and improve documentation of pragma machine_attribute. + New pragma Fast_Math + Document BOM recognition + + * vms_data.ads: Add entries for -gnatw.a -gnatw.A + Add /Wide_Character_Encoding for binder + Add qualifier for the new gnatpp option --no-separate-loop-then + +2007-12-13 Matthew Heaney + + * a-cohase.ads, a-cihama.ads, a-cihase.ads, a-cohama.ads: Document + which generic formal operations are called for each operation. + +2007-12-13 Olivier Hainque + + * tb-gcc.c (uw_data_t, trace_callback): Only define if not GCC-SJLJ eh. + (__gnat_backtrace): Early return 0 if using GCC-SJLJ eh. + +2007-12-13 Emmanuel Briot + + * s-os_lib.ads, s-os_lib.adb (Normalize_Pathname): Do not compute + Reference_Dir unless we actually need it. + +2007-12-13 Vasiliy Fofanov + Tristan Gingold + + * g-socthi-vms.ads (Fd_Set_Access): make it 32-bit. + + * s-osprim-vms.adb, + a-calend-vms.adb: Remove pragma warning off and add pragma + unreferenced. + +2007-12-13 Robert Dewar + + * impunit.adb: Add entries for missing units + + * Makefile.rtl: Add new run-time units. + + * Make-lang.in: Update dependencies. + +2007-12-13 Bob Duff + + * itypes.ads, itypes.adb (Create_Itype): For access-to-subprogram + types, set Can_Use_Internal_Rep appropriately, based on + Always_Compatible_Rep_On_Target. + +2007-12-13 Gary Dismukes + Arnaud Charlet + + * make.adb (Scan_Make_Arg): Add test for -aamp_target switch, passing + it to the front end and setting the aamp_target environment variable + to the switch's argument to ensure that gnaampbind and gnaamplink will + take the specified library into account. + (Make): Only set Check_Object_Consistency to False for JVM, not for CIL + target, since the CIL compiler supports an "object" file (.il files). + +2007-12-13 Vincent Celier + + * symbols-processing-vms-ia64.adb (Process.Skip_Half): New procedure + (Process.H): Remove variable. Replace Read_Half (H) with Skip_Half. + +2007-12-13 Geert Bosch + + * s-parame-vxworks.adb: + Update comments to reflect usage of this package by Nucleus. + +2007-12-13 Arnaud Charlet + + * i-vxwork.ads: Kill new warning on Convention C, since changing the + spec would break code. + + * i-forbla-unimplemented.ads, vx_stack_info.c: New files. + + * system-vxworks-alpha.ads: Removed. + +2007-12-10 Eric Botcazou + + * ada-tree.h (TYPE_RETURNS_BY_TARGET_PTR_P): Move around. + +2007-12-09 Samuel Tardieu + + PR ada/34366 + * sem_ch3.adb (Designates_T): New function. + (Mentions_T): Factor reusable part of the logic into Designates_T. + Consider non-access parameters and access and non-access result. + (Check_Anonymous_Access_Components): Set ekind of anonymous access to + E_Subprogram_Type to E_Anonymous_Access_Subprogram_Type. + + * einfo.ads: Update comment for E_Anonymous_Access_Subprogram_Type. + +2007-12-07 Ludovic Brenta + + PR ada/34361 + * mlib-tgt.adb, mlib-tgt.ads: Fix comments at the top to reflect + the new implementation of target-specific calls. + +2007-12-07 Olivier Hainque + + * decl.c (gnat_to_gnu_entity) : When computing + the designated full view, only follow a second level Full_View link + for Non_Limited_Views of from_limited_with references. + +2007-12-07 Samuel Tardieu + + PR ada/15805 + * sem_ch6.adb (Process_Formals): Prevent an access type formal + to be initialized with an access to constant object. + + * sem_ch3.adb (Analyze_Object_Declaration): Signal an error + when an access to constant is used to initialize an access + value. + + PR ada/21346 + * a-direct.adb (Compose): Containing_Directory can be an empty string. + +2007-12-07 Olivier Hainque + + PR ada/34173 + * decl.c (gnat_to_gnu_entity) : When setting + the alignment on the GCC XUA array type, set TYPE_USER_ALIGN if + this is from an alignment clause on the GNAT entity. + * utils.c (create_field_decl): Rewrite the computation of DECL_ALIGN + to distinguish the case where we set it from the type's alignment. + When so, propagate TYPE_USER_ALIGN into DECL_USER_ALIGN to indicate + whether this alignment was set from an explicit alignment clause. + +2007-12-06 Eric Botcazou + + * decl.c (make_packable_type): Revert last change. + (gnat_to_gnu_field): Avoid setting size and position multiple times. + * utils.c (finish_record_type): Retrieve the real name of the type. + +2007-12-05 Eric Botcazou + + * trans.c (lvalue_required_p): Take base node directly instead + of its parent. Rename second parameter to 'gnu_type'. + : Return 0 if the node isn't the prefix. + : Likewise. + (Identifier_to_gnu): Rename parent_requires_lvalue to require_lvalue. + Adjust calls to lvalue_required_p. + +2007-12-05 Samuel Tardieu + + PR ada/21489 + * exp_ch9.adb (Build_Simple_Entry_Call): Initialize OUT access type + parameters of an entry call. + +2007-12-03 Robert Dewar + Samuel Tardieu + + PR ada/34287 + * sem_util.adb (Safe_To_Capture_Value): Do not capture values + of variables declared in a library-level package. + +2007-12-02 Samuel Tardieu + + * clean.adb (Clean_Library_Directory): Use Empty_String'Access intead + of Empty_String'Unchecked_Access. + + * Makefile.in: Add support for sh4-linux. + + * system-linux-sh4.ads: New file. + +2007-12-01 Kostik Belousov + + PR ada/33722 + * env.c (__gnat_setenv): FreeBSD 7 has a POSIX conformant putenv() + and its argument must not be free()ed. + +2007-11-29 Eric Botcazou + + * decl.c (make_packable_type): Retrieve the real name of the type. + (maybe_pad_type): Simplify similar code. + +2007-11-28 Samuel Tardieu + + PR ada/15804 + * par-ch3.adb (P_Variant_Part): Signal an error when anything other + than an identifier is used after "case" in a variant_part. + + PR ada/17318 + * par-ch4.adb (Is_Parameterless_Attribute): New map. + (P_Name, Scan_Apostrophe block): Parse left parenthesis following + attribute name or not depending on the new map. + + * sem-attr.adb (Analyze_Attribute): Parameterless attributes + returning a string or a type will not be called with improper + arguments. + + * sem-attr.ads (Attribute_Class_Array): Move to snames.ads. + + * snames.ads (Attribute_Class_Array): Moved from sem-attr.ads. + + PR ada/32792 + * sem_attr.adb (Analyze_Attribute, Attribute_Integer_Value clause): + Signal an error when attribute argument is a fixed-point value of + an unknown type. + + PR ada/22559 + * sem_ch3.adb (Build_Derived_Numeric_Type): Do not set RM_Size on + a derived ordinary fixed point type. + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Recompute + RM_Size when a Small clause is found. + +2007-11-26 Andreas Krebbel + + PR 34081/C++ + * trans.c (Subprogram_Body_to_gnu, Compilation_Unit_to_gnu): + Pass 'false' for the new allocate_struct_function parameter. + * utils.c (build_function_stub): Likewise. + +2007-11-25 Richard Guenther + + * utils.c (gnat_pushlevel): Use BLOCK_CHAIN. + (gnat_poplevel): Likewise. + +2007-11-25 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : If the type has + strict alignment, no alignment clause and a known static size, cap + the type alignment to the greatest power of 2 factor of the size. + (gnat_to_gnu_field): If the field has a component clause, is aliased + or of a type with strict alignment, require that its size be equal to + that of the type. + (validate_size): Use the type size as the minimum size for a type with + strict alignment. + +2007-11-23 Samuel Tardieu + + * s-inmaop-posix.adb, s-intman-vxworks.adb, s-taprop-hpux-dce.adb, + s-taprop-irix.adb, s-taprop-linux.adb, s-taprop-lynxos.adb, + s-taprop-posix.adb, s-taprop-tru64.adb, s-taprop-vxworks.adb: + Use 'Access instead of 'Unchecked_Access in second and third + arguments of pthread_sigmask. + +2007-11-23 Eric Botcazou + + * decl.c (ceil_alignment): New function. + (gnat_to_gnu_entity): Use it to set the alignment on atomic types. + (make_packable_type): Likewise. + +2007-11-22 Olivier Hainque + + * trans.c (gnat_to_gnu) : Reformat lines + to fit in 80 columns. + +2007-11-21 Aurelien Jarno + + * s-osinte-kfreebsd-gnu.ads (To_Target_Priority): New function. + * Makefile.in: Add EH_MECHANISM=-gcc to kfreebsd-gnu. Remove SYMLIB. + +2007-11-19 Eric Botcazou + + PR ada/34098 + * misc.c (gnat_adjust_rli): Delete. + (gnat_init): Do not initialize the translation code here. + Do not call set_lang_adjust_rli. + * trans.c (init_code_table): Make static. + (gnat_init_stmt_group): Delete. + (gigi): Initialize the translation code entirely here. + Emit debug info for the common types here instead of... + * utils.c (gnat_init_decl_processing): ...here. + * gigi.h (init_code_table): Delete. + (gnat_init_stmt_group): Likewise. + +2007-11-16 Olivier Hainque + + * utils2.c (build_call_alloc_dealloc) : Move the code + retrieving an allocator return value from a super-aligned address from + here to ... + * trans.c (gnat_to_gnu) : ... here, and don't + expect a super-aligned address for a fat or thin pointer. + +2007-11-14 Eric Botcazou + + * trans.c (call_to_gnu): Always set the source location on the call + expression. If the function returns-by-target, also set it on the + address expression. + +2007-11-14 Samuel Tardieu + + * adaint.c, init.c, initialize.c, link.c: Remove system-specific + sections of non-supported Interix target. + + * s-osinte-interix.ads: Removed. + + * i-cstrin.ads (chars_ptr): Make it a C convention type. + +2007-11-13 Samuel Tardieu + + * a-tasatt.adb: Add a comment at the beginning of the package + explaining why in general 'Unchecked_Access must be used instead + of 'Access. + + * sem_prag.adb (Process_Convention): Move the test for the + entity on which the Convention pragma applies down to also + forbid pragma Convention on enumeration literals reached + through renamings. + +2007-11-10 Samuel Tardieu + + * a-tasatt.adb: Revert previous change for this file as it will + generate an error when this package is instantiated from a + local context. + +2007-11-07 Samuel Tardieu + + * a-tasatt.adb: Type Wrapper should be declared in comment instead + of already declared type Node_Access. + Use 'Access instead of 'Unchecked_Access when applicable. Local + lifetime is the one of the package. + (Set_Value): W is allocated on the heap. + + * g-socket.adb: Use 'Access instead of 'Unchecked_Access when + applicable. + (Get_Socket_Option): Optlen formal of C_Getsockopt is of an anonymous + access type. + (Receive_Socket): Fromlen formal of C_Recvfrom is of an anonymous + access type. + + * s-taasde.adb: Use 'Access instead of 'Unchecked_Access when + applicable. + (elaboration code): Timer_Queue lifetime is the one of the + package. + + * tracebak.c (i386 alternative): Remove useless comparaison + which is always false; LOWEST_ADDRESS is 0 and is never greater + than an unsigned integer. + + * sem_attr.adb (Analyze_Attribute): Remove duplicate identical + embedded check for "Ada_Version >= Ada_05". + +2007-11-07 Olivier Hainque + + * decl.c (make_aligning_type): Set the mode of the RECORD_TYPE we + craft and expand comment. + +2007-11-01 Eric Botcazou + + * lang-specs.h: Move translation of -fRTS= after -gnatez switch. + +2007-10-23 Eric Botcazou + + * misc.c (gnat_handle_option): Replace call to abort with + call to gcc_unreachable. + (gnat_init): Likewise. + (gnat_expand_expr): Likewise. + (fp_prec_to_size): Likewise. + (fp_size_to_prec): Likewise. + +2007-10-23 Richard Guenther + + PR bootstrap/33608 + * tracebak.c: #undef abort after including system.h. + +2007-10-20 Danny Smith + + * Makefile.in (LIBGNAT_TARGET_PAIRS) Add s-tasinf-mingw.adb, + s-tasinf-mingw.ads, a-exetim-mingw.adb, a-exetim-mingw.ads + for win32 targets. + (EXTRA_GNATRTL_TASKING_OBJS): Add a-exetim.o for win32 targets. + +2007-10-15 Eric Botcazou + + * s-osinte-tru64.adb: (Hide_Yellow_Zone): Add On parameter. + Set the protection status of the guard page based on the value of On. + + * s-osinte-tru64.ads: (Hide_Yellow_Zone): Add On parameter. + + * s-taprop-tru64.adb: (Enter_Task): Pass True to Hide_Yellow_Zone. + (Exit_Task): Pass False to Hide_Yellow_Zone. + +2007-10-15 Robert Dewar + + * s-taprop-solaris.adb, s-taprop-vms.adb, s-taprop-mingw.adb, + s-taprop-vxworks.adb, s-taprop-posix.adb, a-calend-vms.adb, + a-calend.adb, a-nuflra.adb, a-tigeau.adb, a-wtgeau.adb, + checks.adb, bindgen.adb, eval_fat.adb, exp_fixd.adb, fmap.adb, + freeze.adb, g-awk.adb, g-calend.adb, g-diopit.adb, g-expect.adb, + gnatchop.adb, gnatlink.adb, g-spipat.adb, g-thread.adb, make.adb, + mdll.adb, mlib.adb, mlib-prj.adb, osint.adb, par-ch3.adb, prj.adb, + prj-makr.adb, sem_prag.adb, sem_type.adb, s-fatgen.adb, s-fileio.adb, + sinfo.ads, sinput-d.adb, s-taasde.adb, s-tasdeb.ads, s-tasren.adb, + s-tassta.adb, s-tpobop.adb, s-tposen.adb, stylesw.adb, types.ads, + uintp.adb, validsw.adb, makegpr.adb, a-rbtgso.adb, a-crbtgo.adb, + a-coorse.adb, a-convec.adb, a-coinve.adb, a-cohama.adb, a-ciorse.adb, + a-cihama.adb, a-cidlli.adb, a-chtgop.adb, a-cdlili.adb, a-cdlili.adb, + a-coormu.adb, a-ciormu.adb, a-cihase.adb, a-cohase.adb, a-ciorma.adb, + a-coorma.adb, a-ztgeau.adb, symbols-vms.adb, a-crdlli.adb, + a-calari.adb, a-calfor.adb, s-os_lib.adb, s-regpat.adb, a-ngrear.adb: + Minor reformatting. + Add Unreferenced and Warnings (Off) pragmas for cases of + variables modified calls where they are IN OUT or OUT parameters and + the resulting values are not subsequently referenced. In a few cases, + we also remove redundant code found by the new warnings. + + * ug_words, vms_data.ads, usage.adb, sem_util.adb, sem_util.ads, + sem_warn.adb, sem_warn.ads, sem_res.adb, sem_ch7.adb, sem_ch8.adb, + sem_ch5.adb, opt.ads, lib-xref.adb, lib-xref.ads, exp_smem.adb, + sem_ch11.adb, exp_ch6.adb, einfo.ads, einfo.adb: implement a new + warning controlled by -gnatw.o that warns on cases of out parameter + values being ignored. + +2007-10-15 Geert Bosch + + * adaint.c, socket.c, cal.c: Initial port to arm-mentor-nucleus. + + * expect.c: Initial port to arm-mentor-nucleus. + Use kill for __gnat_kill() on VMS. + +2007-10-15 Emmanuel Briot + + * ali.ads, ali.adb (Scan_ALI): Initialize XE.Tref to a known default + value. + (Xref_Record): Change type for Line, since in the case of a reference to + a predefined entity (as happens for array index types), the line is set + to 0. + Add support for parsing multiple array index types info, or + multiple inherited interfaces info. This information cannot be stored + in Xref_Entity_Record, which only supports a single instance of Tref_*, + and is therefore stored in the list of references instead. It has a + special treatement later on in tools that use this information. + +2007-10-15 Tristan Gingold + + * debug.adb: Document use of -gnatd.a and -gnatd.I + + * layout.adb: On OpenVMS -gnatd.a disables alignment optimization. + +2007-10-15 Javier Miranda + + * exp_attr.adb (Expand_N_Attribute_Reference): Case Access, + Unchecked_Access, and Unrestricted_Access. Cleanup code that takes + care of access to class-wide interface types plus removal of bizarre + conversion of tagged object to access type (reported by Gary + Dismukes). After this patch there is no need to perform any + additional management on these nodes in Expand_Interface_Actuals. + + * exp_disp.adb (Expand_Interface_Actuals): Code cleanup. Remove code + that handles use of 'Access and 'Unchecked_Access applied to + actuals covering interface types. Such code is now + centralized in Expand_N_Attribute_Reference. + +2007-10-15 Ed Schonberg + + * exp_ch3.adb (Build_Init_Procedure): Keep separate the initialization + of tagged types whose ultimate ancestor is a CPP type. + (Freeze_Array_Type): For a packed array type, generate an initialization + procedure if the type is public, to handle properly a client that + specifies Normalize_Scalars. + +2007-10-15 Hristian Kirtchev + + * exp_ch9.adb (Actual_Index_Expression): When the expansion occurs + inside a generic body, retrieve the full view of the entry family + discrete subtype if available. + +2007-10-15 Thomas Quinot + + * exp_dist.adb (Add_RACW_Primitive_Declarations_And_Bodies): Do not + attempt to generate stubs for hidden primitive operations. + +2007-10-15 Vincent Celier + + * mlib-tgt-specific.adb (Support_For_Libraries): New function, + returning None, used when there is no platform specific body for + MLib.Tgt.Specific. + +2007-10-15 Bob Duff + + * sem_case.adb, sem_ch13.adb, lib-sort.adb: Replace use of Heap_Sort_A + (passing'Unrestricted_Access of nested subprograms to Sort) with use of + the generic Heap_Sort_G, in order to avoid trampolines. + +2007-10-15 Vasiliy Fofanov + Jose Ruiz + + * vx_stack_info.c: New file. + + * i-forbla-unimplemented.ads: New file. + + * Makefile.in: i-forbla-unimplemented.ads: a variant of i-forbla.ads + for unsupported configurations; use it on VMS targets instead of the + real one. + (EXTRA_LIBGNAT_SRCS,EXTRA_LIBGNAT_OBJS for VxWorks): Include + vx_stack_info.{c,o} that contains the routine __gnat_get_stack_info + used by VxWorks targets to have access to task-specific data and be + able to extract the stack boundaries for stack checking. + Use system-vms-ia64.ads on ivms. + + * Make-lang.in: Update dependencies. + + * sysdep.c (__gnat_get_stack_info): Move to a standalone file + (vx_stack_info.c). + +2007-10-15 Vincent Celier + + * snames.adb, snames.ads: Add new standard name runtime_library_dir + + * prj.ads (Language_Config): Add new component Runtime_Library_Dir + + * prj-attr.adb: Add project level attribute Runtime_Library_Dir + + * prj-env.adb (Create_Mapping_File): Do not put an entry if the path of + the source is unknown. + + * prj-ext.adb: Spelling error fix + + * prj-nmsc.adb (Check_Ada_Name): Reject any unit that includes an Ada + 95 reserved word in its name. + (Process_Project_Level_Array_Attributes): Process new attribute + Runtime_Library_Dir. + + * prj-part.adb (Parse_Single_Project): Do not check the name of the + config project against the user project names. + + * prj-proc.adb (Expression): In multi-language mode, indexes that do + not include a dot are always case insensitive. + (Process_Declarative_Items): Ditto + (Process_Project_Tree_Phase_1): Set Success to False in case an error is + detected. + + * prj-util.adb (Value_Of (In_Array)): When Force_Lower_Case_Index is + True, compare both indexes in lower case. + +2007-10-15 Robert Dewar + + * rtsfind.adb: (Load_RTU): Turn off style checks for Load call + +2007-10-15 Gary Dismukes + + * sem_aggr.adb (Resolve_Record_Aggregate): In the case of a box + association for an access component, add an association with null as + the expression. Remove testing for array subtypes and the setting in + that case of Ctyp to the array component type, which prevented proper + inclusion of an association for null-initialized arrays. Collapse + condition that tests for array subtypes into just a test of + Is_Partially_Initialized_Type (which already covers arrays anyway). + +2007-10-15 Hristian Kirtchev + + * sem_ch12.adb: Minor code reformatting. + (Check_Generic_Child_Unit): Iterate over the homonym chain in order to + find the parent package which may have been hidden by local + declarations. + +2007-10-15 Gary Dismukes + + * sem_ch3.adb (Build_Derived_Concurrent_Type): Set the Is_Constrained + flag of derived concurrent types, taking into account the flag setting + on the parent subtype and any new set of discriminants. + +2007-10-15 Hristian Kirtchev + + * sem_ch4.adb: Minor code and comment reformatting. + (Analyze_Allocator): When the designated type of an unconstrained + allocator is a record with unknown discriminants or an array with + unknown range bounds, emit a detailed error message depending on the + compilation mode and whether the designated type is limited. + +2007-10-15 Tristan Gingold + + * system-vms-ia64.ads: New file. + + * system-vms_64.ads: Minor comment fix. + +2007-10-15 Ed Schonberg + + * sem_ch6.adb (Find_Corresponding_Spec): If the previous entity is a + body generated for a function with a controlling result that is a null + extension, discard the generated body in favor of the current explicit + one. + +2007-10-15 Ed Schonberg + + * sem_disp.adb (Find_Controlling_Arg): Examine the call node before + examining its original form, to handle properly operator calls that + have been rewritten. + +2007-10-15 Olivier Hainque + + * tb-alvms.c (tb_entry_t, __gnat_backtrace): Store a frame pointer + instead of a procedure value in each traceback entry. + + * g-trasym-vms-alpha.adb (Symbolic_Traceback): Pass frame pointer + instead of procedure value to TBK$SYMBOLIZE. + + * s-traent-vms.adb (PV_For): Rename as FP_For and access the proper + field. + (TB_Entry_For): Account for the PV/FP renaming. + + * s-traent-vms.ads (Traceback_Entry): Rename PV component into FP and + add comment. + (Null_TB_Entry): Account for change of component name. + (PV_For): Rename as FP_For. + +2007-10-15 Tristan Gingold + + * trans.c (gnat_to_gnu): Remove the padding structure more often. + This optimize assignment to over-aligned record. + +2007-10-15 Emmanuel Briot + + * xref_lib.adb (Get_Full_Type): Add support for the 'h' entity type, ie + interfaces. + + * xr_tabls.adb (Add_Reference): Add support for the new 'R' reference + type, for dispatching calls. + +2007-10-15 Vincent Celier + Robert Dewar + + * gnat_ugn.texi: Add documentation for switches --version and --help + for the GNAT tools gnatbind, gnatlink, gnatmake, gnatchop, gnatname, + gnatxref, gnatfind, gnatls, and gnatclean. + Document -gnatw.o. + Mention attribute Excluded_Source_Dirs + Replace obsolescent attribute Locally_Removed_Files with attribute + Excluded_Source_Files. + Improve documentation of -u (gnatbind) + Document how to do reliable stack checking for the environmental task + on iVMS. + + * gnat_rm.texi: Rewrite section about No_Implicit_Dynamic_Code. + Document attribute Excluded_Source_Files and indicate that attribute + Locally_Removed_Files is obsolescent. + +2007-10-15 Thomas Quinot + + * g-soccon-vms.ads: Fix value of MSG_WAITALL. + + * gen-soccon.c: + Update documentation to note that OpenVMS 8.3 or later must be used + to generate g-soccon-vms.ads. + + * atree.adb: Add ??? comment + + * exp_util.adb: Minor reformatting. + Add ??? comment in Kill_Dead_Code. + +2007-10-15 Robert Dewar + + * errout.ads: Comment clarification + + * exp_ch4.adb (Expand_N_Allocator): Code cleanup. + (Expand_N_Op_Eq): Improve handling of array equality with -gnatVa + + * lib.ads: Comment update + + * init.c: Minor reformatting. + + * sem_attr.adb: Minor formatting + + * osint-b.ads: Minor reformatting + + * sem_ch9.adb: Implement -gnatd.I switch + + * g-comlin.adb: (Start): Fix handling of empty command line. + + * gnatcmd.adb (GNATCmd): Do not put the -rules in the -cargs section, + even when -rules follows the -cargs section. + +2007-10-08 Ollie Wild + + * misc.c (LANG_HOOKS_PUSHDECL): Replaced lhd_return_tree with + gnat_return_tree. + (gnat_init_gcc_eh): Replaced gnat_eh_runtime_type with + gnat_return_tree. + (gnat_eh_runtime_type): Removed. + (gnat_return_tree): New function. + +2007-10-08 Ben Elliston + + PR ada/33454 + Revert: + 2007-08-31 Ben Elliston + + * Makefile.in (LIBGNAT_TARGET_PAIRS): Use system-linux-ppc64.ads + when compiling for powerpc64-*-linux. + * system-linux-ppc64.ads: New file. + +2007-09-27 Eric Botcazou + + Mapped location support + * back_end.adb (Call_Back_End): Pass information about source + files instead of units to gigi. + * gigi.h (struct File_Info_Type): New. + (gigi): Rename and change type of number_units parameter, change + type of file_info_ptr parameter. + * trans.c (number_files): New global variable. + (gigi): Rename and change type of number_units parameter, change + type of file_info_ptr parameter. + If mapped location support is enabled, create the isomorphic mapping + between source files and line maps. + (Sloc_to_locus): If mapped location support is enabled, translate + source location into mapped location. + (annotate_with_node): Rename into set_expr_location_from_node. + Call set_expr_location instead of annotate_with_locus. + (Pragma_to_gnu): Adjust for above change. + (Loop_Statement_to_gnu): Likewise. + (call_to_gnu): Likewise. + (Handled_Sequence_Of_Statements_to_gnu): Likewise. + (gnat_to_gnu): Likewise. + (add_stmt_with_node): Likewise. + (add_cleanup): Likewise. + * utils.c (gnat_init_decl_processing): Do not set input_line. + +2007-09-26 Hristian Kirtchev + + * sem_ch8.adb (Analyze_Use_Type): Code cleanup. + (Applicable_Use): Emit a warning when a package tries to use itself. + (Use_One_Type): Add variable Is_Known_Used. Emit a warning when a type + is already in use or the package where it is declared is in use or is + declared in the current package. + (Spec_Reloaded_For_Body): New subsidiary routine for Use_One_Type. + + * a-tasatt.adb, s-osprim-vxworks.adb, g-socthi-mingw.adb, + s-intman-vms.adb, g-socket.adb, g-thread.adb, s-tarest.adb, + s-tassta.adb, s-tporft.adb: Remove redundant 'use type' clause. + +2007-09-26 Hristian Kirtchev + + * a-calend-vms.adb, a-calend.adb: + Add a section on leap seconds control along with two entities used to + enable and disable leap seconds support. The array Leap_Second_Times is + now constant and contains hard time values pre-generated. Remove + all elaboration code used to populate the table of leap seconds. + + * bindgen.adb: + Add entity Leap_Seconds_Support to the list of global run-time variables + along with a comment on its usage and values. + (Gen_Adainit_Ada): Add code to generate the declaration and import of + Integer variable Leap_Seconds_Support. Set its value to zero (disabled) + or one (enabled) depending on the presence of binder switch "-y". + (Gen_Adainit_C): Add code to generate the declaration of external int + __gl_leap_seconds_support. Set is value to zero (disabled) or one + (enabled) depending on the presence of binder switch "-y". + + * init.c: Add __gl_leap_seconds_support to the list of global values + computed by the binder. + +2007-09-26 Jerome Guitton + + * s-taprop-lynxos.adb, s-taprop-tru64.adb, s-taprop-irix.adb, + s-taprop-hpux-dce.adb, s-taprop-linux.adb, s-taprop-dummy.adb, + s-taprop-solaris.adb, s-taprop-vms.adb, s-taprop-mingw.adb, + s-taprop-posix.adb (Stop_Task): New function, dummy implementation. + + * s-taprop.ads, s-taprop-vxworks.adb (Stop_Task): New function. + + * s-tasdeb.adb (Stop_All_Tasks): New function, implementing a run-time + function which can be called by the debugger to interrupt the tasks of + an Ada application asynchronously, as needed on VxWorks. + (Stop_All_Tasks_Handler): Renamed from Stop_All_Tasks. + + * s-tasdeb.ads (Stop_All_Tasks_Handler): New function declaration, + renamed from Stop_All_Tasks. Update comments. + (Stop_All_tasks): New function declaration. + +2007-09-26 Olivier Hainque + + * adaint.c (if defined (__Lynx__)): Wrap #def/#undef VMOS_DEV around + #include and #define GCC_RESOURCE_H before + #include . + Add more protections in __gnat_translate_vms. + + * expect.c (if defined (__Lynx__)): #define GCC_RESOURCE_H before + #include . + +2007-09-26 Thomas Quinot + Sergey Rybin + + * gnatvsn.ads (PCS_Version_Number, ASIS_Version_Number): Removed. + + * exp_dist.ads (PCS_Version_Number): Move from Gnatvsn to Exp_Dist, + where it belongs. + + * opt.ads: Move ASIS_Version_Number from Gnatvsn into Tree_IO. + + * rtsfind.adb (PCS_Version_Number): Move from Gnatvsn to Exp_Dist, + where it belongs. + + * sem_dist.ads: Minor comment fix + + * tree_io.ads: Move ASIS_Version_Number from Gnatvsn into Tree_IO. + +2007-09-26 Javier Miranda + Eric Botcazou + + * a-tags.adb: + (Get_HT_Link/Set_HT_Link): Updated to handle the additional level of + indirection added to the HT_Link component of the TSD. This is required + to statically allocate the TSD. + + * a-tags.ads: + Minor reordering of the declarations in the private part. Required to + add a level of indirection to the contents of the TSD component HT_Link. + This is required to statically allocate the TSD. + + * decl.c (gnat_to_gnu_entity) : Do not exclude objects with + Is_Statically_Allocated set from constant objects. + Do not make exported constants created by the compiler volatile. + (gnat_to_gnu_param): Do not treat an IN parameter whose address is taken + as read-only. + + * trans.c (Identifier_to_gnu): For constants, unshare initializers + before returning them. + + * exp_disp.ads, exp_disp.adb (Building_Static_DT): Spec moved to the + public part of the package. + (Make_DT): Move HT_Link component out of the TSD record. For this + purpose Make_DT now declares a separate object that stores the + HT_Link value, and initializes the TSD component with the address + of this new object. The addition of this level of indirection is + required to statically allocate the TSD because the TSD cannot + have variable components. + (Expand_Interface_Conversion): Improve the expanded code. + (Expand_Interface_Thunk): Set Is_Thunk in the thunk entity. + + * sem_disp.adb (Check_Dispatching_Operation): In case of a body + declaring a primitive operation ---allowed by RM 3.9.2 (13.e/2)---, + if we are building static dispatch tables then we must not generate + extra code to register the primitive because the dispatch table will + be built at the end of the library package; otherwise we notify that + we cannot build the static dispatch table. + +2007-09-26 Robert Dewar + + * checks.adb, gnat1drv.adb, sem_util.ads: Improve warnings for address + overlays. + + * sem_ch13.ads, sem_ch13.adb: Improve warnings for address overlays + (Analyze_Record_Representation_Clause): Suppress junk warning for + missing component clause. + (Analyze_Attribute_Definition_Clause, case Address): Apply the special + tests for controlled type overlay to composites with controlled + components. + (Analyze_Record_Representation_Clause): Add reference for component name + +2007-09-26 Javier Miranda + Gary Dismukes + + * einfo.adb (Is_Thunk): New attribute applicable to subprograms. True + for thunks associated with interface types. + + * einfo.ads: Improve documentatation of Is_Internal + (Is_Thunk): New attribute applicable to subprograms. True for thunks + associated with interface types. + Extensive comment fixes regarding flags that appear in all entities. The + documentation is now consistent for all such flags (there were a number + of errors in the documentation in this regard). + + * exp_attr.adb (Expand_N_Attribute_Reference): Minor code cleanup. + + * exp_ch6.adb (Make_Build_In_Place_Call_*): Return immediately if any + of these procedures are passed a function call that already has + build-in-place actuals (testing new flag + Is_Expanded_Build_In_Place_Call). Set the flag on the function call in + the case where processing continues. + (Expand_Call): If the call is generated from a thunk body then we + propagate the extra actuals associated with the accessibility + level of the access type actuals. + + * sem_ch6.adb (Analyze_Subprogram_Body): Set the Protected_Formal field + of each extra formal of a protected operation to reference the + corresponding extra formal of the subprogram denoted by the + operation's Protected_Body_Subprogram. + + * sinfo.ads, sinfo.adb (Is_Expanded_Build_In_Place_Call): New flag on + N_Function_Call nodes. + +2007-09-26 Robert Dewar + + * exp_ch5.adb: Activate memmove type processing if debug flag d.s is set + + * debug.adb: Add d.s flag. + +2007-09-26 Gary Dismukes + + * exp_dbug.adb (Debug_Renaming_Declaration): Set Is_Internal on the + debug variable so that it won't be initialized when pragma + Initialize_Scalars is in effect. + +2007-09-26 Gary Dismukes + + * freeze.adb (Freeze_Entity): Remove check for preelaborable + initialization of a full view. This is moved to + Analyze_Package_Specification. + + * sem_ch7.adb (Analyze_Package_Specification): Add check for + preelaborable initialization of a full view in entity loop. + (Uninstall_Declarations): If entity is a use-visible compilation unit, + its child units are use-visible only if they are visible child units. + + * sem_util.adb (Is_Preelaborable_Expression): New function to determine + whether an expression can be used within a type declaration that + requires preelaborable init. + (Check_Components): Replace inline code that does partial checking for + preelaborable default expressions with call to + Is_Preelaborable_Expression. + (Has_Preelaborable_Initialization): In the case of a generic actual + subtype, (that is, Is_Generic_Actual is True), return the result of + applying Has_Preelaborable_Initialization to the generic actual's base + type. + +2007-09-26 Hristian Kirtchev + + * g-calend.adb (Has_53_Weeks): Rename to Last_Year_Has_53_Weeks. Add a + call to Jan_1_Day _Of_Week to optimize its performance. + (Is_Leap): Move the routine to the scope of Week_In_Year. + (Jan_1_Day_Of_Week): New routine in Week_In_Year which calculates the + weekday on which January 1 falls of Year - 1 and Year + 1. This function + avoids calling Time_Of and Split, thus making it more efficent. + (Week_In_Year): Reimplemented in oder to follow ISO 8601. + + * g-calend.ads (Week_In_Year): Change comment to reflect new + implementation. + +2007-09-26 Emmanuel Briot + + * g-comlin.ads, g-comlin.adb (Command_Line_Configuration, + Command_Line): New types + (Define_Alias, Define_Prefix, Free): New subprograms. These provide + support for defining how switches can be grouped on a command line (as + is the case for -gnatw... for GNAT), and how simple switches can be + used as aliases for more complex switches (-gnatwa is same as + -gnatwbcef...) + (Set_Command_Line, Add_Switch, Remove_Switch): New subprogram + (Start, Current_*): New subprograms + Added support for parsing an array of strings in addition to the real + command line. + (Opt_Parser, Opt_Parser_Data): New type. As a result, some types had to + be moved from the body to the private part of the spec. + (*): All subprograms now have an extra parameter with default value to + specify which parser should be used. For backward compatibility, it + defaults to parsing the command line of the application. They were also + modified to properly handle cases where each of the argument does not + start at index 1 (which is always true for Ada.Command_Line, but not + when processing any Argument_List). + (Free): New subprogram + (Internal_Initialize_Option_Scan, Find_Longuest_Matching_Switch, + Argument): New subprograms + (Switch_Parameter_Type): New enum, which clarifies the code. The extra + special characters like ':', '=',... are now handled in a single place, + which makes the code more extensible eventually. + (Getopt, Full_Switch): When the switch was returned as part of the + special character '*', make sure it is prepended by the switch character + ('-' in general), so that the application knows whether "foo" or "-foo" + was specified on the command line. + +2007-09-26 Florian Villoing + + * g-dirope.adb (Remove_Dir): In case we are removing directories + recursively, make sure that if an exception is raised during the + processing, the current working directory is reset to its initial + value before propagating the exception. + +2007-09-26 Vincent Celier + + * gnatbind.adb: If there are several ALI files specified and there is + a main program to bind, the first ALI is expected to contain the main + subprogram and the names of the binder generated files will be derived + from the first ALI file name. + (Gnatbind): Fix insertion character in invocation of Error_Msg + +2007-09-26 Vincent Celier + + * gnatcmd.adb (Check_Files): Do not include sources that have been + removed by attributes Exclude_Source_Files or Locally_Removed_Files. + +2007-09-26 Ed Schonberg + + * lib-xref.ads, lib-xref.adb: The entry for array types now carries + information about each of its index types, following the type + reference for its component type. + +2007-09-26 Vincent Celier + + * make.adb: (Kill): New procedure (__gnat_kill imported) + (Running_Compile, Outstanding_Compiles): Global variables that + were previously local to procedure Compile_Sources. + (Sigint_Intercepted): Send signal SIGINT to all outstanding + compilation processes. + + (Gnatmake): If project files are used, create the mapping of all the + sources, so that the correct paths will be found. + + * prj-env.ads, prj-env.adb (Create_Mapping): New procedure + +2007-09-26 Vincent Celier + + * makeutl.ads (Main_Config_Project): Moved to gpr_util.ads + + * prj.ads, prj.adb (Default_Language): Remove function, no longer used + Replace components Compiler_Min_Options and Binder_Min_Options with + Compiler_Required_Switches and Binder_Required_Switches in record + Language_Config. + Remove components Default_Language and Config in Project_Tree_Data, + no longer used. + + * prj-attr.adb: New attributes Required_Switches () in + packages Compiler and Binder. + + * prj-nmsc.adb: Major rewrite of the processing of configuration + attributes for gprbuild. No impact on GNAT tools. + + * prj-proc.ads, prj-proc.adb (Process_Project_Tree_Phase_2): No longer + process configuration attributes: this is done in Prj.Nmsc.Check. + (Recursive_Process): Make a full copy of packages inherited from project + being extended, instead of a shallow copy. + (Process_Project_Tree_Phase_1): New procedure + (Process_Project_Tree_Phase_1): New procedure + (Process): Implementation now uses the two new procedures + + * prj-util.adb (Executable_Of): Get the suffix and the default suffix + from the project config, not the tree config that no longer exists. + +2007-09-26 Vincent Celier + + * Make-lang.in: Update dependencies.. + +2007-09-26 Vincent Celier + + * osint.adb, osint.ads: Minor reformatting + + * osint-b.adb, osint-b.ads (Set_Current_File_Name_Index): New procedure + +2007-09-26 Gary Dismukes + + * par-ch4.adb (P_Record_Or_Array_Component_Association): Change Ada 95 + message to cite use of <> in aggregate component associations rather + than wrongly indicating use of limited aggregates. + +2007-09-26 Robert Dewar + + * sem_attr.adb (Analyze_Access_Attribute): Fix missing set of + Address_Taken. + +2007-09-26 Ed Schonberg + + * sem_ch3.adb (Derive_Subprograms): If the interface parent is a direct + ancestor of the derived type, the operations are inherited from the + primary dispatch table of the parent. + (OK_For_Limited_Init_In_05): Remove old comment. Reject in-place calls + when the context is an explicit type conversion. + +2007-09-26 Ed Schonberg + + * sem_ch4.adb (Analyze_Qualified_Expression): Apply name resolution + rule for qualified expressions properly, to detect improper conversions + and resolve some cases of overloading. + +2007-09-26 Ed Schonberg + + * sem_res.adb (Resolve_Call): If the call is dispatching, generate the + proper kind of reference to the primitive operation, for better source + navigation. + (Valid_Conversion): A tagged conversion is legal if both operands are + tagged. + +2007-09-26 Robert Dewar + + * sem_warn.adb (Check_References): Catch more cases of unreferenced + packages. + +2007-09-26 Vincent Celier + + * snames.adb, snames.ads: Change Include_Option to Include_Switches + +2007-09-26 Robert Dewar + + * s-wchstw.adb: provide messages for run time unit exceptions + + * a-witeio.adb: Minor reformatting + + * exp_ch13.adb: Minor reformatting + +2007-09-26 Sergey Rybin + + * vms_data.ads: Revise gnatmetric qualifiers. + Add qualified for the new gnatbind option '-y' + + * gnat_ugn.texi: Revise the gnatmetric section. + Add entry for new gnatbind option '-y'. + + * gnat_rm.texi: Minor spelling correction. + Document restriction on overlaying controlled types + +2007-09-26 Vincent Celier + + * makegpr.adb (Link_Executables): Do not fail when the root project has + no sources, but is an extending project. + +2007-09-25 Eric Botcazou + + * trans.c: Fix misplaced #define. + +2007-09-22 Eric Botcazou + + * utils2.c (build_unary_op) [INDIRECT_REF]: Propagate + the TYPE_REF_CAN_ALIAS_ALL flag to the result. + +2007-09-21 Olivier Hainque + + * utils.c (type_for_nonaliased_component_p): Return false for + all AGGREGATE_TYPEs. + +2007-09-17 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : Make again the type of an + object covered by 13.3(19) volatile. + +2007-09-12 Eric Botcazou + + PR ada/26797 + PR ada/32407 + * utils.c (unchecked_convert): Use a subtype as the intermediate type + in the special VIEW_CONVERT_EXPR case. + +2007-09-12 Robert Dewar + + * types.ads, a-charac.ads, freeze.adb: Minor reformatting. + + * a-except.adb, g-hesora.adb, g-speche.adb, lib.adb, lib.ads, + lib-load.adb, lib-writ.adb, s-assert.adb, s-carun8.adb, + s-casuti.adb, s-crc32.adb, s-exctab.adb, s-htable.adb, s-imgenu.adb, + s-mastop.adb, s-memory.adb, s-memory.ads, s-secsta.adb, s-soflin.adb, + s-sopco3.adb, s-sopco4.adb, s-sopco5.adb, s-stache.adb, s-stalib.adb, + s-stoele.adb, s-strcom.adb, s-strops.adb, s-traceb.adb, s-traent.adb, + s-wchcnv.adb, s-wchcon.adb, s-wchjis.adb, s-addope.adb, s-except.adb, + s-os_lib.adb, s-string.adb, s-utf_32.adb, a-elchha.adb, + a-chlat1.ads, a-elchha.ads, a-except.ads, g-hesora.ads, g-htable.ads, + g-speche.ads, par-prag.adb, restrict.adb, restrict.ads, s-assert.ads, + s-carun8.ads, s-casuti.ads, s-crc32.ads, sem_ch11.adb, sem_prag.adb, + s-exctab.ads, s-htable.ads, s-imgenu.ads, s-mastop.ads, snames.adb, + snames.ads, snames.h, s-purexc.ads, s-secsta.ads, s-soflin.ads, + s-sopco3.ads, s-sopco4.ads, s-sopco5.ads, s-stache.ads, s-stalib.ads, + s-stoele.ads, s-strcom.ads, s-strops.ads, s-traceb.ads, s-traent.ads, + s-unstyp.ads, s-wchcnv.ads, s-wchcon.ads, s-wchjis.ads, s-addope.ads, + s-except.ads, s-os_lib.ads, s-string.ads, s-utf_32.ads: Implement + pragma Compiler_Unit and adds it to relevant library units. + +2007-09-12 Ed Schonberg + + * sem_aggr.adb (Resolve_Record_Aggregate): An others association with + a box need not correspond to any component. + +2007-09-12 Robert Dewar + + * g-thread.ads: Document use of "with GNAT.Threads" to ensure loading + the tasking version of the Ada run time when foreign threads are + present and there are no explicit Ada tasks or tasking constructs. + + * gnat_rm.texi: Clarify documentation of GNAT.Threads. + +2007-09-12 Hristian Kirtchev + + * bindusg.adb (Display): Correct comment for switch -X. Add a line for + the usage of switch -y. + + * switch-b.adb (Scan_Binder_Switches): Set flag Leap_Seconds_Support + when switch -y is present. + + * opt.ads: Add binder flag Leap_Seconds_Support used to enable/disable + leap seconds in Ada.Calendar and its children. + +2007-09-12 Jose Ruiz + + * a-extiti.ads (Timer): The discriminant is a "not null access + constant" in the Reference Manual. + (Cancel_Handler): Cancelled is an out parameter in the Reference Manual. + +2007-09-12 Robert Dewar + + * a-swuwha.adb: Remove junk RM header + +2007-09-12 Vincent Celier + + * g-bytswa-x86.adb (Swap2, Swap4, Swap8): Remove explicit "in" mode + indicator + + * g-bytswa.ads: Minor reformatting + +2007-09-12 Thomas Quinot + + * g-soccon-solaris-64.ads, g-soccon-hpux-ia64.ads: + Add new constant Thread_Blocking_IO, always True by default, set False + on a per-runtime basis. + (Need_Netdb_Buffer): New constant. + +2007-09-12 Arnaud Charlet + + * s-dsaser.ads (Get_Local_Partition_Id, Get_Passive_Partition_Id): + Added renames for corresponding functions in System.Partition_Interface. + +2007-09-12 Doug Rupp + + * Makefile.in: Remove VMS specific System.CRTL packages which are no + longer needed. + + * s-crtl-vms64.ads: Removed. + +2007-09-12 Olivier Hainque + + * decl.c (gnat_to_gnu_entity) : For a subtype + with discriminant constraints, generalize the code for BIT_FIELDs + to PACKED fields of constant size and propagate DECL_PACKED. + +2007-09-11 Eric Botcazou + + * decl.c (array_type_has_nonaliased_component): New predicate. + (gnat_to_gnu_field) : Invoke the above predicate to + set the TYPE_NONALIASED_COMPONENT flag on the type. + : Likewise. + * gigi.h (type_for_nonaliased_component_p): Declare. + * utils.c (type_for_nonaliased_component_p): New predicate. + (create_field_decl): Invoke the above predicate to set the + DECL_NONADDRESSABLE_P flag on the field. + +2007-09-11 Javier Miranda + + * einfo.ads, einfo.adb (Dispatch_Table_Wrapper): New attribute. Present + in library level record type entities if we are generating statically + allocated dispatch tables. + + * exp_disp.adb (Make_Tags/Make_DT): Replace previous code + importing/exporting the _tag declaration by new code + importing/exporting the dispatch table wrapper. This change allows us + to statically allocate of the TSD. + (Make_DT.Export_DT): New procedure. + (Build_Static_DT): New function. + (Has_DT): New function. + + * freeze.adb (Freeze_Static_Object): Code cleanup: Do not reset flags + True_Constant and Current_Value. Required to statically + allocate the dispatch tables. + (Check_Allocator): Make function iterative instead of recursive. + Also return inner allocator node, when present, so that we do not have + to look for that node again in the caller. + +2007-09-11 Jan Hubicka + + * misc.c (gnat_expand_body): Kill. + (LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION): Kill. + +2007-09-10 Robert Dewar + + * exp_atag.ads, exp_atag.adb, mlib-tgt-tru64.adb, mlib-tgt-aix.adb, + mlib-tgt-irix.adb, mlib-tgt-hpux.adb, mlib-tgt-linux.adb, + mlib-tgt-solaris.adb, mlib-tgt-vms-alpha.adb, mlib-tgt-vms-ia64.adb, + mlib-tgt-mingw.adb, mlib-tgt-vxworks.adb, ali.adb, ali.ads, + ali-util.adb, ali-util.ads, atree.h, back_end.adb, back_end.ads, + bcheck.adb, bcheck.ads, binde.adb, binde.ads, binderr.adb, binderr.ads, + bindgen.adb, bindgen.ads, bindusg.adb, bindusg.ads, butil.adb, + butil.ads, checks.adb, checks.ads, clean.adb, clean.ads, comperr.adb, + comperr.ads, cstand.adb, cstand.ads, debug_a.adb, debug_a.ads, + elists.h, errout.adb, erroutc.ads, errutil.adb, errutil.ads, + err_vars.ads, eval_fat.adb, eval_fat.ads, exp_sel.ads, exp_sel.adb, + exp_aggr.adb, exp_aggr.ads, expander.adb, expander.ads, exp_attr.ads, + exp_ch10.ads, exp_ch11.adb, exp_ch12.adb, exp_ch12.ads, exp_ch13.adb, + exp_ch13.ads, exp_ch2.adb, exp_ch2.ads, exp_ch3.ads, exp_ch4.adb, + exp_ch4.ads, exp_ch5.adb, exp_ch5.ads, exp_ch6.adb, exp_ch6.ads, + exp_ch7.adb, exp_ch7.ads, exp_ch8.adb, exp_ch8.ads, exp_ch9.adb, + exp_ch9.ads, exp_code.adb, exp_code.ads, exp_dbug.adb, exp_dbug.ads, + exp_disp.ads, exp_dist.adb, exp_dist.ads, exp_fixd.adb, exp_fixd.ads, + exp_imgv.adb, exp_imgv.ads, exp_intr.adb, exp_intr.ads, exp_pakd.adb, + exp_pakd.ads, exp_prag.adb, exp_prag.ads, exp_smem.adb, exp_strm.adb, + exp_strm.ads, exp_tss.adb, exp_tss.ads, exp_util.adb, exp_util.ads, + exp_vfpt.adb, exp_vfpt.ads, fmap.adb, fmap.ads, fname-sf.adb, + fname-sf.ads, fname-uf.adb, fname-uf.ads, frontend.adb, frontend.ads, + get_targ.adb, get_targ.ads, gnat1drv.adb, gnat1drv.ads, gnatbind.adb, + gnatbind.ads, gnatbl.c, gnatchop.adb, gnatclean.adb, gnatcmd.adb, + gnatcmd.ads, gnatdll.adb, gnatfind.adb, gnatkr.adb, gnatkr.ads, + gnatlbr.adb, gnatlink.adb, gnatlink.ads, gnatls.adb, gnatls.ads, + gnatmake.adb, gnatmake.ads, gnatmem.adb, gnatname.adb, gnatname.ads, + gnatprep.adb, gnatprep.ads, gnatsym.adb, gnatxref.adb, + gprep.adb, gprep.ads, hlo.adb, hlo.ads, impunit.adb, impunit.ads, + inline.adb, inline.ads, itypes.adb, itypes.ads, layout.adb, layout.ads, + lib-load.adb, lib-load.ads, lib-util.adb, lib-util.ads, lib-writ.adb, + lib-writ.ads, lib-xref.adb, lib-xref.ads, live.adb, live.ads, + make.adb, make.ads, makeutl.ads, makeutl.adb, makeusg.adb, makeusg.ads, + mdll.adb, mdll.ads, mdll-fil.adb, mdll-fil.ads, mdll-utl.adb, + mdll-utl.ads, memroot.adb, memroot.ads, mlib.adb, mlib.ads, + mlib-fil.adb, mlib-fil.ads, mlib-prj.adb, mlib-prj.ads, mlib-tgt.adb, + mlib-tgt.ads, mlib-utl.adb, mlib-utl.ads, namet.h, nmake.adt, + osint.adb, osint.ads, osint-b.adb, osint-b.ads, osint-c.adb, + osint-c.ads, osint-l.adb, osint-l.ads, osint-m.adb, osint-m.ads, + par.adb, par.ads, par-ch10.adb, par-ch11.adb, par-ch12.adb, + par-ch13.adb, par-ch2.adb, par-ch3.adb, par-ch4.adb, par-ch5.adb, + par-ch6.adb, par-ch7.adb, par-ch8.adb, par-ch9.adb, par-endh.adb, + par-labl.adb, par-load.adb, par-prag.adb, par-sync.adb, par-tchk.adb, + par-util.adb, prep.adb, prep.ads, prepcomp.adb, prepcomp.ads, + prj.adb, prj.ads, prj-attr.adb, prj-attr.ads, prj-com.ads, + prj-dect.adb, prj-dect.ads, prj-err.adb, prj-err.ads, prj-ext.adb, + prj-ext.ads, prj-makr.adb, prj-makr.ads, prj-nmsc.adb, prj-nmsc.ads, + prj-pars.adb, prj-pars.ads, prj-part.adb, prj-part.ads, + prj-pp.adb, prj-pp.ads, prj-proc.adb, prj-proc.ads, + prj-strt.adb, prj-strt.ads, prj-tree.adb, prj-tree.ads, + prj-util.adb, prj-util.ads, restrict.adb, restrict.ads, + rtsfind.adb, rtsfind.ads, scn.adb, scn.ads, + scng.adb, scng.ads, sdefault.ads, sem.ads, sem_aggr.ads, sem_attr.adb, + sem_case.adb, sem_case.ads, sem_cat.adb, sem_cat.ads, sem_ch10.adb, + sem_ch10.ads, sem_ch11.adb, sem_ch11.ads, sem_ch12.ads, sem_ch13.adb, + sem_ch13.ads, sem_ch2.adb, sem_ch2.ads, sem_ch3.adb, sem_ch3.ads, + sem_ch4.ads, sem_ch5.adb, sem_ch5.ads, sem_ch6.adb, sem_ch6.ads, + sem_ch7.adb, sem_ch7.ads, sem_ch8.adb, sem_ch8.ads, sem_ch9.adb, + sem_ch9.ads, sem_disp.adb, sem_disp.ads, sem_dist.adb, sem_dist.ads, + sem_elab.adb, sem_elab.ads, sem_elim.adb, sem_elim.ads, sem_eval.adb, + sem_eval.ads, sem_intr.adb, sem_intr.ads, sem_maps.adb, sem_maps.ads, + sem_mech.adb, sem_mech.ads, sem_prag.adb, sem_prag.ads, sem_res.adb, + sem_res.ads, sem_smem.adb, sem_smem.ads, sem_type.adb, sem_type.ads, + sem_util.adb, sem_util.ads, sem_vfpt.adb, sem_vfpt.ads, sem_warn.adb, + sem_warn.ads, sfn_scan.ads, sinfo-cn.adb, sinfo-cn.ads, sinput-c.adb, + sinput-c.ads, sinput-d.adb, sinput-d.ads, sinput-l.adb, sinput-l.ads, + sinput-p.adb, sinput-p.ads, snames.h, sprint.adb, sprint.ads, + stringt.h, style.ads, styleg.adb, styleg.ads, styleg-c.adb, + styleg-c.ads, stylesw.adb, stylesw.ads, switch.adb, switch.ads, + switch-b.adb, switch-b.ads, switch-c.adb, switch-c.ads, switch-m.adb, + switch-m.ads, symbols.adb, symbols.ads, targparm.adb, tbuild.adb, + tbuild.ads, tempdir.adb, tempdir.ads, tree_gen.adb, tree_gen.ads, + treepr.adb, treepr.ads, treeprs.adt, ttypef.ads, ttypes.ads, + types.h, uintp.h, urealp.h, usage.adb, usage.ads, + validsw.adb, validsw.ads, vxaddr2line.adb, xeinfo.adb, xnmake.adb, + xref_lib.adb, xref_lib.ads, xr_tabls.adb, xr_tabls.ads, xsinfo.adb, + xtreeprs.adb, xsnames.adb, vms_conv.ads, vms_conv.adb, xgnatugn.adb, + gprmake.adb, makegpr.ads, makegpr.adb, prj-attr-pm.ads, prj-attr-pm.adb, + mlib-tgt-lynxos.adb, mlib-tgt-darwin.adb, symbols-vms.adb, + symbols-processing-vms-alpha.adb, symbols-processing-vms-ia64.adb, + mlib-tgt-specific.adb, mlib-tgt-specific.ads, mlib-tgt-vms.adb, + mlib-tgt-vms.ads: Replace headers with GPL v3 headers. + +2007-09-10 Emmanuel Briot + + * s-regpat.adb (Parse_Character_Class): Fix handling of empty character + classes ("[]"). + +2007-09-10 Vasiliy Fofanov + + * adaint.c (__gnat_translate_vms): new function. + +2007-09-10 Gary Dismukes + Thomas Quinot + + * exp_ch3.adb (Predef_Spec_Or_Body): When the type is abstract, only + create an abstract subprogram in the case of 'Input. For 'Output we now + create a real spec/body when the type is abstract, since it can + potentially be called. + (Predefined_Primitive_Bodies): Now allow the creation of a predefined + body for 'Output when the type is abstract (only the creation of the + body for 'Input is excluded when the type is abstract). + (Stream_Operation_OK): Add an additional condition in the return + statement, so that False will be returned for TTS_Stream_Input if the + associated tagged type is an abstract extension. Add comments for + return statement. + (Expand_N_Object_Declaration): For the case of a shared passive + variable, insert init proc call only after the shared variable + procedures have been processed, because the IP call needs to undergo + shared passive variable reference expansion, which requires these + procedures to be available (and elaborated). + +2007-09-10 Vincent Celier + + * prj-env.ads, prj-env.adb (Create_Mapping_File (Language)): Remove + parameter Runtime_Project. + +2007-09-10 Ed Schonberg + + * sem_aggr.adb (Build_Record_Aggr_Code): If an aggregate component is + given a box association, the type of the component is discriminated, + and the value of the discriminant is the discriminant of the enclosing + type, retrieve its value from the aggregate itself, where it must have + been supplied. + + * sem_ch4.adb (Analyze_One_Call): Further refinement to previous fix, + to remove other spurious ambiguities on arithmetic operations involving + literals and addresses, on systems where Address is a visible integer + type, when the operator is called in functional notation. + (Try_Primitive_Operation): Within an instance, a call in prefixed form + is legal when the types match, even if the operation is currently + hidden. + +2007-09-10 Ed Schonberg + + * sem_ch12.adb (Build_Local_Package): A formal package with no + associations is legal if all formals have defaults. It is not + equivalent to a formal declared with a box. + +2007-09-10 Sergey Rybin + + * vms_data.ads: Add qualifier for the new gnatmetric '-lratio' option + +2007-09-10 Sergey Rybin + + * gnat_ugn.texi: Add description of the new '-lratio' option + Update 7.3.1 section about availability of the feature. + +2007-09-10 Thomas Quinot + + * exp_smem.ads, exp_smem.adb (Make_Shared_Var_Procs): Return last + inserted node. + +2007-09-10 Olivier Hainque + + * Makefile.in: (mips-irix section): Activate build of libgmem. + +2007-09-10 Eric Botcazou + + * a-numaux-x86.adb (Logarithmic_Pow): Do not silently clobber + x87 registers. + +2007-09-10 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : Deal with variable built for + a debug renaming declaration specially. + +2007-09-08 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : Simplify the condition under + which a constant renaming is treated as a normal object declaration. + * trans.c (lvalue_required_p) : New case, extracted from + the N_Indexed_Component case. + : Fall through to above case. + : Return true for all composite types. + +2007-09-08 Eric Botcazou + + * decl.c (make_packable_type): If the new type has been given BLKmode, + try again to get an integral mode for it. + +2007-09-07 Eric Botcazou + + Re-apply accidentally reverted change: + + 2007-02-07 Andreas Krebbel + + * raise-gcc.c (get_region_description_for, get_call_site_action_for, + get_action_description_for): Replace _Unwind_Word with _uleb128_t + and _Unwind_SWord with _sleb128_t. + +2007-09-06 Eric Botcazou + + * trans.c (convert_with_check): Update call to real_2expN. + +2007-09-05 Sandra Loosemore + + * trans.c (Compilation_unit_to_gnu): Use set_cfun. + * utils.c (end_subprog_body): Likewise. + +2007-09-03 Nick Clifton + + * Make-lang.in: Change copyright header to refer to version 3 of + the GNU General Public License and to point readers at the + COPYING3 file and the FSF's license web page. + * ada-tree.def, nmake.adt, nlists.h, snames.h, utils.c, + Makefile.rtl, Makefile.in, config-lang.in, uintp.h, urealp.h, + namet.h, decl.c, utils2.c, lang.opt, elists.h, atree.h, types.h, + treeprs.adt, lang-specs.h, cuintp.c, stringt.h, gnatbl.c: + Likewise. + +2007-08-31 Vincent Celier + + PR ada/4720 + + * gnatchop.adb, gnatfind.adb, gnatlink.adb, gnatls.adb, + gnatname.adb, gnatxref.adb, gprep.adb, clean.adb gnatbind.adb + (Check_Version_And_Help): New procedure in package Switch to process + switches --version and --help. + Use Check_Version_And_Help in GNAT tools + + * make.adb: Ditto. + (Compile_Sources): Make sure that sources that are "excluded" are not + compiled. + (Gnatmake): Do not issue -aO. to gnatbind and only issue -I- if a + project file is used. + (Version_Switch): Remove, moved to Switch + (Help_Switch): Remove, moved to Switch + (Display_Version): Remove, moved to Switch + + * switch.ads, switch.adb (Check_Version_And_Help): New procedure in + package Switch to process switches --version and --help. + (Display_Version): New procedure + + * gnatvsn.ads, gnatvsn.adb (Copyright_Holder): New function. + +2007-08-31 Javier Miranda + + * a-tags.adb (Internal_Tag): Protect the run-time against wrong + internal tags. + +2007-08-31 Hristian Kirtchev + + * checks.adb (In_Declarative_Region_Of_Subprogram_Body): New routine. + (Mark_Non_Null): If the node for which we just generated an access check + is a reference to an *in* parameter and the reference appears in the + declarative part of a subprogram body, mark the node as known non null. + +2007-08-31 Hristian Kirtchev + + * einfo.ads, einfo.adb: New flag Is_Raised (Flag224). Update the + structure of E_Exception to reflect the new flag. + (Is_Raised, Set_Is_Raised): New inlined routines. + Update the usage of available flag to reflect the addition of Is_Raised. + (Is_Raised, Set_Is_Raised): Bodies of new routines. + (Write_Entity_Flags): Write the status of flag Is_Raised. + (Is_Descendent_Of_Address): New entity flag, to simplify handling of + spurious ambiguities when integer literals appear in the context of an + address type that is a visible integer type. + + * sem_ch11.adb (Analyze_Exception_Handler): Add code to warn on local + exceptions never being raised. + (Analyze_Raise_Statement): When analyzing an exception, mark it as being + explicitly raised. + +2007-08-31 Javier Miranda + + * exp_ch11.adb (Expand_At_End_Handler): Avoid generation of raise + statement when compiling under restriction No_Exceptions_Proparation. + +2007-08-31 Ed Schonberg + + * exp_ch3.adb (Build_Record_Init_Proc): If there is a static + initialization aggregate for the type, generate itype references for + thetypes of its (sub)components, to prevent out-of-scope errors in gigi. + +2007-08-31 Gary Dismukes + + * exp_ch8.adb (Expand_N_Package_Renaming_Declaration): In the case of a + library-level package renaming, pass the declaration associated with + the renaming's special debug variable to Qualify_Entity_Names to ensure + that its encoded name is properly qualified. + + * exp_dbug.adb (Qualify_All_Entity_Names): Check for a variable entity + occurring in the list of entities to qualify, and do not attempt to + traverse an entity list in that case. Variables associated with +` library-level package renamings can now occur in the table. + + * exp_dbug.ads: Revise documentation of the encoding for renaming + declarations. + +2007-08-31 Richard Kenner + + * layout.adb (Layout_Type): Use Underlying_Type to determine whether an + access type points to an unconstrained array. + +2007-08-31 Hristian Kirtchev + + * restrict.adb, namet.adb, par-util.adb: Remove redundant type + conversion. + + * sem_res.adb (Resolve_Qualified_Expression): Add machinery to detect + simple redundant qualifications. The check is performed whenever the + expression is a non-overloaded identifier. + (Resolve_Type_Conversion): Enchance the redundant type conversion check + to include loop parameters. + (Valid_Conversion): Avoid generation of spurious error message. + +2007-08-31 Bob Duff + + * par-ch4.adb (P_Simple_Expression): Fold long sequences of + concatenations of string literals into a single literal, in order to + avoid very deep recursion in the front end, which was causing stack + overflow. + + * sem_eval.adb (Eval_Concatenation): If the left operand is the empty + string, and the right operand is a string literal (the case of "" & + "..."), optimize by avoiding copying the right operand -- just use the + value of the right operand directly. + + * stringt.adb (Store_String_Chars): Optimize by growing the + String_Chars table all at once, rather than appending characters one by + one. + (Write_String_Table_Entry): If the string to be printed is very long, + just print the first few characters, followed by the length. Otherwise, + doing "pn(n)" in the debugger can take an extremely long time. + + * sem_prag.adb (Process_Interface_Name): Replace loop doing + Store_String_Char with Store_String_Chars. + +2007-08-31 Vincent Celier + + * prj-attr.adb: Add new attribute Excluded_Source_Files + + * prj-nmsc.adb: Use attribute Excluded_Source_Files before + Locally_Removed_Files. + + * snames.ads, snames.adb: New standard name Excluded_Source_Files + +2007-08-31 Ed Schonberg + + * sem_ch10.adb (Analyze_Subunit_Context): When analyzing context + clauses of subunits, ignore limited_with_clauses that are illegal and + have not been fully analyzed. + +2007-08-31 Ed Schonberg + + * sem_ch3.adb: The predicate Is_Descendent_Of_Address is now an entity + flag, for effiency. It is called when analyzing arithmetic operators + and also for actuals in calls that are universal_integers. The flag is + set for the predefined type address, and for any type or subtype + derived from it. + + * sem_ch4.adb (Analyze_One_Call): Reject an actual that is a + Universal_Integer, when the formal is a descendent of address and the + call appears in user code. + (Analyze_Selected_Component): if the prefix is a private extension, the + tag component is visible. + + * sem_util.ads, sem_util.adb: Remove Is_Descendent_Of_Address, now an + entity flag. + +2007-08-31 Robert Dewar + + * s-fileio.adb (Open): Normalize file name to lower case in non-case + sensitive file name systems to avoid unexpected mismatch in Vista. + +2007-08-31 Vincent Celier + + * tempdir.adb: On VMS, take into account GNUTMPDIR before TMPDIR + +2007-08-31 Vincent Celier + + * symbols-vms.adb (Initialize): Read symbol files with continuation + lines + (Finalize): If symbol is long, split the line + +2007-08-31 Vincent Celier + + * fmap.ads: Minor comment updates + +2007-08-31 GNAT Script + + * Make-lang.in: Makefile automatically updated + +2007-08-31 Bob Duff + + * sinfo.ads: Minor comment fix. + +2007-08-31 Thomas Quinot + + * stand.ads: (Standard_Debug_Renaming_Type): Make comment consistent + with implementation. + Documentation cleanup only. + +2007-08-31 Sergey Rybin + + * vms_data.ads: Add new qualifier /STMT_NAME_ON_NEW_LINE for the new + gnatpp '--separate-stmt-name' option. + Add new qualifier /USE_ON_NEW_LIN for the new gnatpp '--use-on-new-line' + option. + + * gnat_ugn.texi: Add description for the new gnatpp + '--separate-stmt-name' and '--use-on-new-line' options. + +2007-08-31 Ben Elliston + + * Makefile.in (LIBGNAT_TARGET_PAIRS): Use system-linux-ppc64.ads + when compiling for powerpc64-*-linux. + * system-linux-ppc64.ads: New file. + +2007-08-22 Krister Walfridsson + + * env.c ( __gnat_clearenv): Use the __gnat_unsetenv mechanism for + NetBSD. + +2007-08-16 Kaveh R. Ghazi + + * misc.c (gnat_type_max_size): Constify. + +2007-08-16 Gary Dismukes + + * cstand.adb (Create_Standard): Create an entity for a zero-sized type + associated with Standard_Debug_Renaming_Type, to be used as the type of + the special variables whose names provide debugger encodings for + renaming declarations. + + * einfo.ads, einfo.adb (Debug_Renaming_Link): Change to return Node25. + (Set_Debug_Renaming_Link): Change to set Node25. + (Write_Field13_Name): Remove case for E_Enumeration_Literal. + (Write_Field25_Name): Add case for E_Variable to output + "Debug_Renaming_Link". + (Write_Field23_Name): Correct the output string for "Limited_View". + + * exp_dbug.adb: Add with and use of Tbuild. + (Debug_Renaming_Declaration): Replace creation of an enumeration type + and literal with creation of a variable of type + Standard_Debug_Renaming_Type whose name encodes both the renamed object + and the entity of the renaming declaration. + (Qualify_Entity_Name): Add the delayed qualification of the entity name + part of the name of a variable that has a Debug_Renaming_Link. + + * stand.ads (Standard_Debug_Renaming_Type): New Entity_Id denoting a + special type to be associated with variables that provide debugger + encodings for renaming declarations. + +2007-08-16 Gary Dismukes + Ed Schonberg + Javier Miranda + + * exp_aggr.adb (Build_Record_Aggr_Code): Extend the test for an + ancestor part given by an aggregate to test for an unchecked conversion, + since this can occur in some cases when the ancestor part is a function + call, and we don't want to fall into the recursive call to this + procedure in that case. + + * exp_ch3.adb (Stream_Operation_OK): Revise tests for availability of + stream attributes on limited types to account for user-specified + attributes as well as whether Input (resp. Output) becomes available + due to Read (resp. Write) being available for the type. Change Boolean + variable to the more accurate name + Has_Predefined_Or_Specified_Stream_Attribute. Change convoluted + double-"not" predicate at beginning of return statement to more + understandable form. + + * exp_ch5.adb (Expand_N_Extended_Return_Statement): If the extended + return has an associated N_Handled_Sequence_Of_Statements, then wrap it + in a block statement and use that as the first statement of the + expanded return rather than incorrectly using the handled sequence as + the first statement. + + * exp_ch6.adb (Expand_N_Subprogram_Declaration): If this is a protected + operation, generate an explicit freeze node for it rather than + generating extra formals, to ensure that gigi has the proper order of + elaboration for anonymous subtypes in the signature of the subprograms. + (Build_In_Place_Formal): Move assertion to beginning of loop. + (Is_Build_In_Place_Function_Call): Allow for an unchecked conversion + applied to a function call (occurs for some cases of 'Input). + (Make_Build_In_Place_Call_In_*): Allow for an unchecked conversion + applied to a function call (occurs for some cases of 'Input). + + * exp_strm.adb (Build_Record_Or_Elementary_Input_Function): For Ada + 2005, generate an extended return statement enclosing the result object + and 'Read call. + + * freeze.adb (Freeze_Record_Type): Extend the current management of + components that are access type with an allocator as default value: add + missing support to the use of qualified expressions of the + allocator (which also cause freezing of the designated type!) + (Freeze_Entity): Call Freeze_Subprogram in the case of a predefined + dispatching operation, since extra formals may be needed by calls to + build-in-place functions (such as stream 'Input). + + * sem_ch6.adb (Create_Extra_Formals): Skip creation of the extra + formals for 'Constrained and accessibility level in the case of a + predefined dispatching operation. + + * exp_util.adb (Insert_Actions): A protected body is a valid insertion + point, no need to find the parent node. + +2007-08-16 Javier Miranda + + * exp_attr.adb (Attribute_Priority): Add missing support for entries + and entry barriers. + +2007-08-16 Javier Miranda + + * exp_ch9.adb (Build_Protected_Entry): Undo previous change because it + is not really required and can introduce regression with the debugger. + The original problem is fixed with the patch written for checks.adb. + +2007-08-16 Thomas Quinot + + * g-dyntab.adb, g-table.adb, table.adb: (Set_Item): Suppress + Range_Check on Allocated_Table. + +2007-08-16 Vincent Celier + + * make.adb (Collect_Arguments): Call Test_If_Relative_Path with + Including_Non_Switch set to False. + (Gnatmake): For the compiler, call Test_If_Relative_Path with + Including_Non_Switch set to False. + + * makeutl.adb, makeutl.ads (Test_If_Relative_Path): New Boolean + parameter Including_Non_Switch, defaulted to True. When + Including_Non_Switch is False, options that are not switches and + appear as relative path are not converted to absolute paths. + +2007-08-16 Nicolas Roche + + * Makefile.in (gnatlib): Propagate FORCE_DEBUG_ADAFLAGS value to sub + makefiles + + * Make-lang.in: Update dependencies + +2007-08-16 Hristian Kirtchev + + * sem_ch10.adb (Has_With_Clause): If the name of the with clause + currently inspected is a selected component, retrieve the entity of + its selector. + (Install_Limited_Withed_Unit): Call Has_Limited_With_Clause starting + from the immediate ancestor of Main_Unit_Entity. + (Install_Limited_Withed_Unit): Do not install the limited view of + package P if P is reachable through an ancestor chain from package C + and C also has a with clause for P in its body. + (Has_Limited_With_Clause): New routine. + (Has_With_Clause): New routine. + +2007-08-16 Ed Schonberg + + * sem_ch12.adb (Copy_Generic_Node): A reference to a child unit of the + generic for an enclosing instance is a global reference, even though + its scope is the enclosing instance. + +2007-08-16 Gary Dismukes + Javier Miranda + + * sem_ch3.adb (OK_For_Limited_Init_In_05): Allow calls to 'Input to + initialize a limited object. + (Build_Derived_Record_Type): Add missing check of rules ARM 3.9.4 + 13/2 and 14/2. + Make sure Has_Complex_Representation is inherited by derived type. + +2007-08-16 Robert Dewar + + * sem_ch5.adb (Analyze_Assignment): Make sure we still note update in + exception case + +2007-08-16 Ed Schonberg + + * sem_disp.adb (Check_Dispatching_Operation): If the operation + implements an operation inherited from a progenitor interface, verify + that they are subtype-conformant. + +2007-08-16 Hristian Kirtchev + Bob Duff + Nicolas Setton + + * sem_res.adb (Comes_From_Predefined_Lib_Unit): New. + (Resolve): Alphabetize local variables. Add new variable From_Lib. When + the statement which is being resolved comes from a predefined library + unit, all non-predefined library interpretations are skipped. + (Resolve_Op_Concat): If string concatenation was folded in the parser, + but the "&" is user defined, give an error, because the folding would + be wrong. + + * sinfo.ads, sinfo.adb (Is_Folded_In_Parser): New flag to indicate that + the parser has folded a long sequence of concatenations of string + literals. + + * trans.c (Handled_Sequence_Of_Statements_to_gnu): Mark "JMPBUF_SAVE" + and "JMP_BUF" variables as artificial. + (N_String_Literal): Do not use alloca for very long string literals. Use + xmalloc/free instead. Otherwise the stack might overflow. + + * utils.c (init_gigi_decls): Mark "JMPBUF_T" type as created by the + compiler. + +2007-08-16 Vincent Celier + + * vms_conv.adb (Process_Argument): Ensure that project related options + are not put in the -cargs section when using GNAT COMPILE. + +2007-08-16 Robert Dewar + + * gnat_ugn.texi: Add note on preprocessing (output file not written) + +2007-08-16 Thomas Quinot + + * a-tags.adb: Minor reformatting. + +2007-08-16 Bob Duff + + * sem_type.ads, sem_ch4.adb: Minor reformatting. + +2007-08-14 Thomas Quinot + + * g-soccon-interix.ads, a-excpol-interix.adb, a-intnam-interix.ads, + s-osinte-interix.ads, system-interix.ads: Removed. + +2007-08-14 Hristian Kirtchev + + * a-calend-vms.adb, a-calend.adb ("+", "-", Add, Subtract): Remove + calls to Check_Within_Time_Bounds. + ("+", "-", Add, Subtract): Remove calls to Check_Within_Time_Bounds. + (Difference): Account for possible rounding of the resulting difference + +2007-08-14 Robert Dewar + + * uintp.adb, a-ztedit.adb, s-wchcon.adb, xnmake.adb, s-wchcon.adb, + par-ch5.adb, par-ch10.adb, get_targ.adb, a-wtedit.adb, a-teioed.adb, + s-osinte-solaris.adb, s-osinte-solaris.ads, + s-osinte-freebsd.ads, s-osinte-freebsd.adb: Minor reformatting. + + * styleg.adb, styleg.ads, stylesw.adb, stylesw.ads: implement style + switch -gnatyS. Enable -gnatyS in GNAT style check mode + +2007-08-14 Robert Dewar + Ed Schonberg + + * inline.adb, types.ads, inline.ads, frontend.adb, alloc.ads: + Suppress unmodified in-out parameter warning in some cases + This patch is a also fairly significant change to the way suppressible + checks are handled. + + * checks.ads, checks.adb (Install_Null_Excluding_Check): No check + needed for access to concurrent record types generated by the expander. + (Generate_Range_Check): When generating a temporary to capture the + value of a conversion that requires a range check, set the type of the + temporary before rewriting the node, so that the type is always + properly placed for back-end use. + (Apply_Float_Conversion_Check): Handle case where the conversion is + truncating. + (Get_Discriminal): Code reformatting. Climb the scope stack looking + for a protected type in order to examine its discriminants. + +2007-08-14 Robert Dewar + Gary Dismukes + Ed Schonberg + Thomas Quinot + + * a-stzsup.adb, nlists.adb, lib-util.adb, treepr.adb, + a-stwisu.adb, a-strsup.adb: Fix warnings for range + tests optimized out. + + * exp_ch4.adb (Expand_N_In): Add warnings for range tests optimized out. + (Get_Allocator_Final_List): For the case of an anonymous access type + that has a specified Associated_Final_Chain, do not go up to the + enclosing scope. + (Expand_N_Type_Conversion): Test for the case of renamings of access + parameters when deciding whether to apply a run-time accessibility + check. + (Convert_Aggr_In_Allocator): Use Insert_Actions to place expanded + aggregate code before allocator, and ahead of declaration for + temporary, to prevent access before elaboration when the allocator is + an actual for an access parameter. + (Expand_N_Type_Conversion): On an access type conversion involving an + access parameter, do not apply an accessibility check when the + operand's original node was an attribute other than 'Access. We now + create access conversions for the expansion of 'Unchecked_Access and + 'Unrestricted_Access in certain cases and clearly accessibility should + not be checked for those. + + * exp_ch6.ads, exp_ch6.adb (Add_Call_By_Copy_Code): For an actual that + includes a type conversion of a packed component that has been expanded, + recover the original expression for the object, and use this expression + in the post-call assignment statement, so that the assignment is made + to the object and not to a back-end temporary. + (Freeze_Subprogram): In case of primitives of tagged types not defined + at the library level force generation of code to register the primitive + in the dispatch table. In addition some code reorganization has been + done to leave the implementation clear. + (Expand_Call): When expanding an inherited implicit conversion, + preserve the type of the inherited function after the intrinsic + operation has been expanded. + + * exp_ch2.ads, exp_ch2.adb + (Expand_Entry_Parameter.In_Assignment_Context): An implicit dereference + of an entry formal appearing in an assignment statement does not assign + to the formal. + (Expand_Current_Value): Instead of calling a routine to determine + whether the prefix of an attribute reference should be optimized or + not, prevent the optimization of such prefixes all together. + + * lib-xref.adb (Generate_Reference.Is_On_LHS): An indexed or selected + component whose prefix is known to be of an access type is an implicit + dereference and does not assign to the prefix. + +2007-08-14 Ed Schonberg + Robert Dewar + + * atree.ads, atree.adb (New_Copy_Tree): If hash table is being used and + itype is visited, make an entry into table to link associated node and + new itype. + Add comments and correct harmless error in Build_NCT_Hash_Tables + (Array_Aggr_Subtype): Associate each itype created for an index type to + the corresponding range construct, and not to the aggregate itself. to + maintain a one-to-one correspondence between itype and its associated + node, to prevent errors when complex expression is copied. + Fix mishandling of multiple levels of parens + + * sem_aggr.adb: Create a limited view of an incomplete type, to make + treatment of limited views uniform for all visible declarations in a + limited_withed package. + (New_Copy_Tree): If hash table is being used and itype is visited, + make an entry into table to link associated node and new itype. + (Resolve_Record_Aggregate): Do not add an others box association for a + discriminated record component that has only discriminants, when there + is a box association for the component itself. + + * par-ch4.adb: Fix mishandling of multiple levels of parens + +2007-08-14 Robert Dewar + + * comperr.adb: Fix problem with suppressing warning messages from gigi + + * erroutc.ads, erroutc.adb, errout.ads, + errout.adb (Write_Eol): Remove trailing spaces before writing the line + (Write_Eol_Keep_Blanks): New procedure to write a line, including + possible trailing spaces. + (Output_Source_Line): Call Write_Eol_Keep_Blanks to output a source line + Fix problem with suppressing warning messages from back end + Improve handling of deleted warnings + + * gnat1drv.adb: + Fix problem with suppressing warning messages from back end + Handle setting of Static_Dispatch_Tables flag. + + * prepcomp.adb: + Fix problem with suppressing warning messages from back end + + * exp_intr.adb: Improve handling of deleted warnings + +2007-08-14 Robert Dewar + + * debug.adb: Improve -gnatdI to cover all cases of serialization + Add documentation of dZ, d.t + + * sprint.ads, sprint.adb: Improve -gnatdI to cover all cases of + serialization. + (Sprint_Node_Actual): Generate new output associated with implicit + importation and implicit exportation of object declarations. + +2007-08-14 Ed Schonberg + Robert Dewar + Javier Miranda + Gary Dismukes + + * einfo.ads, einfo.adb: Create a limited view of an incomplete type, + to make treatment of limited views uniform for all visible declarations + in a limited_withed package. + Improve warnings for in out parameters + (Set_Related_Interaface/Related_Interface): Allow the use of this + attribute with constants. + (Write_Field26_Name): Handle attribute Related_Interface in constants. + Warn on duplicate pragma Preelaborable_Initialialization + + * sem_ch6.ads, sem_ch6.adb (Analyze_Subprogram_Body): Force the + generation of a freezing node to ensure proper management of null + excluding access types in the backend. + (Create_Extra_Formals): Test base type of the formal when checking for + the need to add an extra accessibility-level formal. Pass the entity E + on all calls to Add_Extra_Formal (rather than Scope (Formal) as was + originally being done in a couple of cases), to ensure that the + Extra_Formals list gets set on the entity E when the first entity is + added. + (Conforming_Types): Add missing calls to Base_Type to the code that + handles anonymous access types. This is required to handle the + general case because Process_Formals builds internal subtype entities + to handle null-excluding access types. + (Make_Controlling_Function_Wrappers): Create wrappers for constructor + functions that need it, even when not marked Requires_Overriding. + Improve warnings for in out parameters + (Analyze_Function_Return): Warn for disallowed null return + Warn on return from procedure with unset out parameter + Ensure consistent use of # in error messages + (Check_Overriding_Indicator): Add in parameter Is_Primitive. + (Analyze_Function_Return): Move call to Apply_Constraint_Check before + the implicit conversion of the expression done for anonymous access + types. This is required to generate the code of the null excluding + check (if required). + + * sem_warn.ads, sem_warn.adb (Check_References.Publicly_Referenceable): + A formal parameter is never publicly referenceable outside of its body. + (Check_References): For an unreferenced formal parameter in an accept + statement, use the same warning circuitry as for subprogram formal + parameters. + (Warn_On_Unreferenced_Entity): New subprogram, taken from + Output_Unreferenced_Messages, containing the part of that routine that + is now reused for entry formals as described above. + (Goto_Spec_Entity): New function + (Check_References): Do not give IN OUT warning for dispatching operation + Improve warnings for in out parameters + (Test_Ref): Check that the entity is not undefinite before calling + Scope_Within, in order to avoid infinite loops. + Warn on return from procedure with unset out parameter + Improved warnings for unused variables + +2007-08-14 Robert Dewar + Javier Miranda + Gary Dismukes + + * exp_attr.adb (Expand_N_Attribute_Reference): Handle case of child unit + (Expand_N_Attribute_Reference): Further unify the handling of the + three forms of access attributes, using common code now for all three + cases. Add a test for the case of applying an access attribute to + an explicit dereference when the context is an access-to-interface + type. In that case we need to apply the conversion to the prefix + of the explicit dereference rather than the prefix of the attribute. + (Attribute_Version, UET_Address): Set entity as internal to ensure + proper dg output of implicit importation. + (Expand_Access_To_Type): Removed. + (Expand_N_Attribute_Reference): Merge the code from the three cases + of access attributes, since the processing is largely identical for + these cases. The substantive fix here is to process the case of a + type name prefix (current instance case) before handling the case + of interface prefixes. + +2007-08-14 Thomas Quinot + Ed Schonberg + Javier Miranda + Robert Dewar + + * exp_ch3.ads, exp_ch3.adb (Add_Final_Chain): New subprogram. + (Freeze_Array_Type, Freeze_Record_Type): For the case of a component + type that is an anonymous access to controlled object, establish + an associated finalization chain to avoid corrupting the global + finalization list when a dynamically allocated object designated + by such a component is deallocated. + (Make_Controlling_Function_Wrappers): Create wrappers for constructor + functions that need it, even when not marked Requires_Overriding. + (Initialize_Tag): Replace call to has_discriminants by call to + Is_Variable_Size_Record in the circuitry that handles the + initialization of secondary tags. + (Is_Variable_Size_Record): New implementation. + (Expand_N_Object_Declaration): Suppress call to init proc if there is a + Suppress_Initialization pragma for a derived type. + (Is_Variable_Size_Record): New subprogram. + (Build_Offset_To_Top_Functions): New implementation that simplifies the + initial version of this routine and also fixes problems causing + incomplete initialization of the table of interfaces. + (Build_Init_Procedure): Improve the generation of code to initialize the + the tag components of secondary dispatch tables. + (Init_Secondary_Tags): New implementation that simplifies the previous + version of this routine. + (Make_DT): Add parameter to indicate when type has been frozen by an + object declaration, for diagnostic purposes. + (Check_Premature_Freezing): New subsidiary procedure of Make_DT, to + diagnose attemps to freeze a subprogram when some untagged type of its + profile is a private type whose full view has not been analyzed yet. + (Freeze_Array_Type): Generate init proc for packed array if either + Initialize or Normalize_Scalars is set. + (Make_Controlling_Function_Wrappers, Make_Null_Procedure_Specs): when + constructing the new profile, copy the null_exclusion indicator for each + parameter, to ensure full conformance of the new body with the spec. + + * sem_type.ads, sem_type.adb (Make_Controlling_Function_Wrappers): + Create wrappers for constructor functions that need it, even when not + marked Requires_Overriding. + (Covers): Handle properly designated types of anonymous access types, + whose non-limited views are themselves incomplete types. + (Add_Entry): Use an entity to store the abstract operation which hides + an interpretation. + (Binary_Op_May_Be_Hidden): Rename to Binary_Op_Interp_Has_Abstract_Op. + (Collect_Interps): Use Empty as an actual for Abstract_Op in the + initialization aggregate. + (Function_Interp_May_Be_Hidden): Rename to + Function_Interp_Has_Abstract_Op. + (Has_Compatible_Type): Remove machinery that skips interpretations if + they are labeled as potentially hidden by an abstract operator. + (Has_Hidden_Interp): Rename to Has_Abstract_Op. + (Set_May_Be_Hidden): Rename to Set_Abstract_Op. + (Write_Overloads): Output the abstract operator if present. + (Add_Entry): Before inserting a new entry into the interpretation table + for a node, determine whether the entry will be disabled by an abstract + operator. + (Binary_Op_Interp_May_Be_Hidden): New routine. + (Collect_Interps): Add value for flag May_Be_Hidden in initialization + aggregate. + (Function_Interp_May_Be_Hidden): New routine. + (Has_Compatible_Type): Do not consider interpretations hidden by + abstract operators when trying to determine whether two types are + compatible. + (Has_Hidden_Interp): New routine. + (Set_May_Be_Hidden_Interp): New routine. + (Write_Overloads): Write the status of flag May_Be_Hidden. + +2007-08-14 Ed Schonberg + Javier Miranda + + * exp_disp.ads, exp_disp.adb (Build_Dispatch_Tables): Handle tagged + types declared in the declarative part of a nested package body or in + the proper body of a stub. + (Set_All_DT_Position): Add missing check to avoid wrong assignation + of the same dispatch table slot to renamed primitives. + (Make_Select_Specific_Data_Table): Handle private types. + (Tagged_Kind): Handle private types. + (Make_Tags, Make_DT): Set tag entity as internal to ensure proper dg + output of implicit importation and exportation. + (Expand_Interface_Thunk): Fix bug in the expansion assuming that the + first formal of the thunk is always associated with the controlling + type. In addition perform the following code cleanup: remove formal + Thunk_Alias which is no longer required, cleanup evaluation of the + the controlling type, and update the documentation. + Replace occurrence of Default_Prim_Op_Count by + Max_Predef_Prims. Addition of compile-time check to verify + that the value of Max_Predef_Prims is correct. + (Check_Premature_Freezing): Apply check in Ada95 mode as well. + (Make_DT): Add parameter to indicate when type has been frozen by an + object declaration, for diagnostic purposes. + (Build_Static_Dispatch_Tables): New subprogram that takes care of the + construction of statically allocated dispatch tables. + (Make_DT): In case of library-level tagged types export the declaration + of the primary tag. Remove generation of tags (now done by Make_Tags). + Additional modifications to handle non-static generation of dispatch + tables. Take care of building tables for asynchronous interface types + (Make_Tags): New subprogram that generates the entities associated with + the primary and secondary tags of Typ and fills the contents of Access_ + Disp_Table. In case of library-level tagged types imports the forward + declaration of the primary tag that will be declared later by Make_DT. + (Expand_Interface_Conversion): In case of access types to interfaces + replace an itype declaration by an explicit type declaration to avoid + problems associated with the scope of such itype in transient blocks. + +2007-08-14 Robert Dewar + Ed Schonberg + Javier Miranda + + * exp_util.ads, exp_util.adb: + This patch replaces a number of occurrences of explicit tests for N_Null + with calls to Known_Null. This improves tracking of null values, since + Known_Null also catches null constants, and variables currently known to + be null, so we get better tracking. + (Ensure_Defined): create an itype reference only in the scope of the + itype. + (Side_Effect_Free): A selected component of an access type that + denotes a component with a rep clause must be treated as not + side-effect free, because if it is part of a linked structure its + value may be affected by a renaming. + (Expand_Subtype_From_Expr): For limited objects initialized with build + in place function calls, do nothing; otherwise we prematurely introduce + an N_Reference node in the expression initializing the object, which + breaks the circuitry that detects and adds the additional arguments to + the called function. Bug found working in the new patch for statically + allocated dispatch tables. + (Is_Library_Level_Tagged_Type): New subprogram. + (Remove_Side_Effects): If the expression of an elementary type is an + operator treat as a function call. + (Make_Literal_Range): If the index type of the array is not integer, use + attributes properly to compute the constraint on the resulting aggregate + which is a string. + + * freeze.ads, freeze.adb (Freeze_Entity): If the entity is a + class-wide type whose base type is an incomplete private type, leave + class-wide type unfrozen so that freeze nodes can be generated + properly at a later point. + (Freeze_Entity, array case): Handle case of pragma Pack and component + size attributre clause for same array. + +2007-08-14 Vincent Celier + + * prj.ads, prj.adb: Update Project Manager to new attribute names for + gprbuild. + Allow all valid declarations in configuration project files + (Reset): Initialize all tables and hash tables in the project tree data + Major update of the Project Manager and of the project aware tools, + including gprmake, so that the same sources in the GNAT repository + can be used by gprbuild. + (Slash_Id): Change type to be Path_Name_Type + (Slash): Return a Path_Name_Type instead of a File_Name_Type + + * prj-attr.ads, prj-attr.adb: Remove attributes no longer used by + gprbuild. + Update Project Manager to new attribute names for ghprbuild + Allow all valid declarations in configuration project files + Major update of the Project Manager and of the project aware tools, + including gprmake, so that the same sources in the GNAT repository + can be used by gprbuild. + + * prj-com.ads: + Major update of the Project Manager and of the project aware tools, + including gprmake, so that the same sources in the GNAT repository + can be used by gprbuild. + + * prj-dect.adb (Prj.Strt.Attribute_Reference): Set correctly the case + insensitive flag for attributes with optional index. + (Prj.Dect.Parse_Attribute_Declaration): For case insensitive associative + array attribute, put the index in lower case. + Update Project Manager to new attribute names for ghprbuild + Allow all valid declarations in configuration project files + Major update of the Project Manager and of the project aware tools, + including gprmake, so that the same sources in the GNAT repository + can be used by gprbuild. + + * prj-env.ads, prj-env.adb: + Major update of the Project Manager and of the project aware tools, + including gprmake, so that the same sources in the GNAT repository + can be used by gprbuild. + (Get_Reference): Change type of parameter Path to Path_Name_Type + + * prj-ext.ads, prj-ext.adb (Initialize_Project_Path): Make sure, after + removing '-' from the path to start with the first character of the + next directory. + Major update of the Project Manager and of the project aware tools, + including gprmake, so that the same sources in the GNAT repository + can be used by gprbuild. + Major update of the Project Manager and of the project aware tools, + including gprmake, so that the same sources in the GNAT repository + can be used by gprbuild. + + * prj-nmsc.ads, prj-nmsc.adb: + Update Project Manager to new attribute names for ghprbuild + Allow all valid declarations in configuration project files + (Search_Directories): Detect subunits that are specified with an + attribute Body in package Naming. Do not replace a source/unit in the + same project when the order of the source dirs are known. Detect + duplicate sources/units in the same project when the order of the + source dirs are not known. + (Check_Ada_Name): Allow all identifiers that are not reserved words + in Ada 95. + Major update of the Project Manager and of the project aware tools, + including gprmake, so that the same sources in the GNAT repository + can be used by gprbuild. + (Look_For_Sources): If the list of sources is empty, set the object + directory of non extending project to nil. + Change type of path name variables to be Path_Name_Type + (Locate_Directory): Make sure that on Windows '/' is converted to '\', + otherwise creating missing directories will fail. + + * prj-attr-pm.adb, prj-tree.ads, prj-proc.ads, prj-proc.adb, + prj-part.ads, prj-part.adb: + Major update of the Project Manager and of the project aware tools, + including gprmake, so that the same sources in the GNAT repository + can be used by gprbuild. + + * prj-strt.adb (Prj.Strt.Attribute_Reference): Set correctly the case + insensitive flag for attributes with optional index. + (Prj.Dect.Parse_Attribute_Declaration): For case insensitive associative + array attribute, put the index in lower case. + (Parse_Variable_Reference): Allow the current project name to be used in + the prefix of an attribute reference. + + * prj-util.ads, prj-util.adb + (Value_Of (for arrays)): New Boolean parameter Force_Lower_Case_Index, + defaulted to False. When True, always check against indexes in lower + case. + + * snames.ads, snames.h, snames.adb: + Update Project Manager to new attribute names for gprbuild + Allow all valid declarations in configuration project files + +2007-08-14 Robert Dewar + Ed Schonberg + + * opt.ads: Warning for non-local exception propagation now off by + default + New switch -gnatI to disable representation clauses + Implement new pragma Implicit_Packing + + * usage.adb: + Warning for non-local exception propagation now off by default + Add warning for unchecked conversion of pointers wi different + conventions. + New switch -gnatI to disable representation clauses + + * usage.adb: new switch -gnatyS + + * gnat_ugn.texi: For the gnatcheck Non_Qualified_Aggregates rule add a + note that aggregates of anonymous array types are not flagged. + -gnatwc now includes membership tests optimized away + -gnatw.x warnings are now off by default + Added conditional compilation Appendix + Add documentation of -gnatI + Add documentation for new -gnatyS style check + Update documentation about SAL and auto-init on Windows. + + * gnat_rm.texi: + Add documentation for pragma Check_Name and 'Enabled attribute + Document that Eliminate on dispatching operation is ignored + Document IDE attributes VCS_Repository_Root and VCS_Patch_Root. + Document pragma Main + Document pragma Implicit_Packing + + * sem_ch13.adb: Add warning for unchecked conversion of pointers wi + different conventions + New switch -gnatI to disable representation clauses + + * switch-c.adb (Scan_Front_End_Switches): When a -gnat switch is not + recognized, report the invalid characters including "-gnat" instead of + just the first character in the switch. + New switch -gnatI to disable representation clauses + Set Warn_On_Object_Renames_Function true for -gnatg + + * vms_data.ads: Add doc for /IGNORE_REP_CLAUSES + Add STATEMENTS_AFTER_THEN_ELSE as synonym for -gnatyS + Add qualifier /ADD_PROJECT_SEARCH_DIR= for different tools, equivalent + to switch -aP (add directory to project search dir). + + * par-prag.adb: Implement new pragma Implicit_Packing + + * sem_prag.adb (Analyze_Pragma, case Complex_Representation): Mark the + type as having a non-standard representation, to force expansion on + conversion to related types. + (Analyze_Pragma): Warn on misspelled pragma + (Analyze_Pragma, case Convention_Identifier): Fix checking of second arg + Ensure consistent use of # in error messages + Implement pragma Implicit_Packing + +2007-08-14 Olivier Hainque + Eric Botcazou + + * targtyps.c (get_target_maximum_default_alignment): New function. + Maximum alignment + that the compiler might choose by default for a type or object. + (get_target_default_allocator_alignment): New function. Alignment known + to be honored by the target default allocator. + (get_target_maximum_allowed_alignment): New function. Maximum alignment + we might accept for any type or object on the target. + (get_target_maximum_alignment): Now synonym of maximum_default_alignment + + * gigi.h (get_target_maximum_default_alignment): Declare new function. + (get_target_default_allocator_alignment): Likewise. + (get_target_maximum_allowed_alignment): Likewise. + + PR ada/19037 + * decl.c (gnat_to_gnu_entity) : Except for the renaming of the + result of a function call, first try to use a stabilized reference for + a constant renaming too. + (validate_alignment): Use target_maximum_allowed_alignment instead of + MAX_OFILE_ALIGNMENT as the upper bound to what we accept. + (gnat_to_gnu_entity): Use common nodes directly. + (gnat_to_gnu_entity) : Pick the values of the type to annotate + alignment and size for the object. + (lvalue_required_p): Handle N_Parameter_Association like N_Function_Call + and N_Procedure_Call_Statement. + (takes_address): Rename to lvalue_required_p, add third parameter + 'aliased' and adjust recursive calls. + : Update 'aliased' from the array type. + : New case. + : New Likewise. + (Identifier_to_gnu): Adjust for above changes. + (maybe_stabilize_reference) : New case. + + * utils2.c (build_binary_op) : Look through conversion + between type variants. + (build_simple_component_ref): Likewise. + (build_call_alloc_dealloc): Use target_default_allocator_alignment + instead of BIGGEST_ALIGNMENT as the threshold to trigger the super + aligning type circuitry for allocations from the default storage pool. + (build_allocator): Likewise. + (build_simple_component_ref): Manually fold the reference for a + constructor if the record type contains a template. + + * utils.c (value_zerop): Delete. + (gnat_init_decl_processing): Emit debug info for common types. + (rest_of_record_type_compilation): If a union contains a field + with a non-constant qualifier, treat it as variable-sized. + (finish_record_type): Give the stub TYPE_DECL a name. + (rest_of_record_type_compilation): Likewise. + (convert) : New case. Build a new constructor if + types are equivalent array types. + (create_field_decl): Claim fields of any ARRAY_TYPE are addressable, + even if the type is not passed by reference. + (static_ctors, static_dtors): Delete. + (end_subprog_body): Do not record constructors and destructors. + (build_global_cdtor): Delete. + (gnat_write_global_declarations): Do not call build_global_cdtor. + + * lang-spARGET_VXWORKS_RTP is defined, append -mrtp when + -fRTS=rtp is specified. + If CONFIG_DUAL_EXCEPTIONS is 1, append -fsjlj when -fRTS=sjlj is + specified. + + * misc.c (gnat_init_gcc_eh): Use __gnat_eh_personality_sj for the name + of the personality function with SJLJ exceptions. + + * raise-gcc.c (PERSONALITY_FUNCTION): Use __gnat_eh_personality_sj for + the name of the personality function with SJLJ exceptions. + +2007-08-14 Robert Dewar + Ed Schonberg + + * par.ads, par.adb: Improve handling of extra right parens. + (Par): Remove flag From_Limited_With_Clause. + + * par-util.adb, par-ch3.adb: Improve error recovery for bad constraint + Improve handling of extra right parens. + +2007-08-14 Robert Dewar + + * par-tchk.adb (TF_Semicolon): Improve error recovery + +2007-08-14 Robert Dewar + Ed Schonberg + + * sem_attr.ads, sem_attr.adb (Analyze_Attribute, case Value): For + enumeration type, mark all literals as referenced. + (Eval_Attribute, case 'Image): If the argument is an enumeration + literal and names are available, constant-fold but mark nevertheless as + non-static. + Clean up function names. + (Name_Modifies_Prefix): Rename to Name_Implies_Lvalue_Prefix. Clarify + comment. + (Requires_Simple_Name_Prefix): Removed. + +2007-08-14 Robert Dewar + Ed Schonberg + + * sem_ch11.adb: Improved warnings for unused variables + + * sem_ch3.ads, sem_ch3.adb (Build_Derived_Record_Type): If the ancestor + is a synchronized interface, the derived type is limited. + (Analyze_Object_Declaration): Mark the potential coextensions in the + definition and expression of an object declaration node. + (Build_Derived_Type): For the completion of a private type declaration + with a derived type declaration, chain the parent type's representation + items to the last representation item of the derived type (not the + first one) if they are not present already. + (Analyze_Object_Declaration, Constant_Redeclaration): Allow incomplete + object declaration of forward references to tags. + (Access_Subprogram_Declaration): In Ada2005, anonymous access to + subprogram types can appear as access discriminants of synchronized + types. + (OK_For_Limited_Init_In_05): The initialization is legal is it is a call + given in prefixed form as a selected component. + (Process_Discriminants): If not all discriminants have defaults, place + error message on a default that is present. + (Analyze_Private_Extension_Declaration): Diagnose properly an attempt to + extend a synchronized tagged type. + Improved warnings for unused variables + (Is_Visible_Component): Fix a visibility hole on a component inherited + by a private extension when parent is itself declared as a private + extension, and the derivation is in a child unit. + (Find_Hidden_Interface): Move spec from the package body. + +2007-08-14 Robert Dewar + Ed Schonberg + + * sem_ch5.adb: Improve warnings on redundant assignments + + * sem_util.ads, sem_util.adb: (Is_Variable): Add defense against junk + parameter + (Is_Synchronized_Tagged_Type): New subprogram that returns true + in case of synchronized tagged types (AARM 3.9.4 (6/2)). + (Safe_To_Capture_Value): Can now return True for constants, even if Cond + is set to False. Improves handling of Known_[Not_]Null. + (Wrong_Type): Special case address arithmetic attempt + (Collect_Abstract_Interfaces): Add new formal to allow collecting + abstract interfaces just using the partial view of private types. + (Has_Abstract_Interfaces): Add new formal to allow checking types + covering interfaces using the partial view of private types. + (Is_Fully_Initialized_Type): Special VM case for uTag component. This + component still needs to be defined in this case, but is never + initialized as VMs are using other dispatching mechanisms. + (Abstract_Interface_List): For a protected type, use base type to get + proper declaration. + Improve warnings on redundant assignments + (Is_Variable): Handle properly an implicit dereference of a prefixed + function call. + (Build_Actual_Subtype): If this is an actual subtype for an + unconstrained formal parameter, use the sloc of the body for the new + declaration, to prevent anomalises in the debugger. + +2007-08-14 Robert Dewar + + * sem_elim.adb (Set_Eliminated): Ignore pragma Eliminate for + dispatching operation + +2007-08-14 Ed Schonberg + Gary Dismukes + + * exp_aggr.ads, + exp_aggr.adb (Convert_Aggr_In_Allocator): Use Insert_Actions to place + expanded aggregate code before allocator, and ahead of declaration for + temporary, to prevent access before elaboration when the allocator is + an actual for an access parameter. + (Is_Static_Dispatch_Table_Aggregate): Handle aggregates initializing + the TSD and the table of interfaces. + (Convert_To_Assignments): Augment the test for delaying aggregate + expansion for limited return statements to include the case of extended + returns, to prevent creation of an unwanted transient scope. + (Is_Static_Dispatch_Table_Aggregate): New subprogram. + (Expand_Array_Aggregate): Handle aggregates associated with + statically allocated dispatch tables. + (Expand_Record_Aggregate): Handle aggregates associated with + statically allocated dispatch tables. + (Gen_Ctrl_Actions_For_Aggr): Generate a finalization list for allocators + of anonymous access type. + +2007-08-14 Ed Schonberg + + * exp_ch5.adb (Expand_Assign_Array): If source or target of assignment + is a variable that renames a slice, use the variable itself in the + expannsion when the renamed expression itself may be modified between + the declaration of the renaming and the array assignment. + +2007-08-14 Jerome Guitton + + * s-taprop-lynxos.adb, s-taprop-tru64.adb, s-taprop-irix.adb, + s-taprop-hpux-dce.adb, s-taprop-dummy.adb, s-taprop-solaris.adb, + s-taprop-vms.adb, s-taprop-posix.adb (Continue_Task, Stop_All_Tasks): + New functions; dummy implementations. + + * s-osinte-vxworks.ads (Task_Stop, Task_Cont, Int_Lock, Int_Unlock): New + functions, used to implement the multi-tasks mode routines on VxWorks. + + * s-osinte-vxworks.adb, s-osinte-vxworks6.adb (Task_Cont, Task_Stop): + New functions, thin + binding to the VxWorks routines which have changed between VxWorks 5 + and 6. + (Int_Lock, Int_Unlock): New function, thin binding to kernel routines + which are not callable from a RTP. + + * s-taprop-vxworks.adb (Stop_All_Tasks, Continue_Task): New functions, + implemented for the multi-tasks mode on VxWorks 5 and 6. + + * s-taprop.ads (Stop_All_Tasks, Continue_Task): New functions. + + * s-tasdeb.ads, s-tasdeb.adb (Continue_All_Tasks, Stop_All_Tasks): New + functions. + +2007-08-14 Vincent Celier + + * clean.adb, fmap.adb, sinput-p.adb, sinput-p.ads, gnatcmd.adb, + gnatname.adb, makeutl.ads, makeutl.adb, makegpr.adb, mlib-tgt-vms.adb + mlib-tgt-darwin.adb, mlib-tgt-lynxos.adb, mlib-prj.adb, mlib-tgt.adb, + mlib-tgt.ads, mlib-tgt-irix.adb mlib-tgt-hpux.adb, mlib-tgt-linux.adb, + mlib-tgt-solaris.adb, mlib-tgt-vms-alpha.adb, mlib-tgt-vms-ia64.adb, + mlib-tgt-mingw.adb, mlib-tgt-vxworks.adb, mlib-tgt-aix.adb, + mlib-tgt-tru64.adb, mlib.ads, mlib.adb (Create_Sym_Links): New + procedure. + (Major_Id_Name): New function. + mlib-tgt.ads/mlib.tgt.adb: + (Library_Major_Minor_Id_Supported): New function, default returns True + Most mlib-tgt-*.adb that support shared libraries and symbolic links: + (Build_Dynamic_Library): Add support for major/minor ids for shared libs + Other mlib-tgt-*.adb (aix, mingw, vms, vxworks, xi): + Implementation of Library_Major_Minor_Id_Supported returns False + clean.adb: + (Clean_Library_Directory): If major/minor ids are supported, clean all + library files. + Major update of the Project Manager and of the project aware tools, + including gprmake, so that the same sources in the GNAT repository + can be used by gprbuild. + +2007-08-14 Olivier Hainque + + * system-solaris-x86.ads (ZCX_By_Default): Switch to True. + (GCC_ZCX_Support): Switch to True. + + * s-intman-solaris.adb (Notify_Exception): Call + Adjust_Context_For_Raise before raising, as expected for signal + handlers in general. + + * s-intman-posix.adb (Notify_Exception): Remove declaration of + Adjust_Context_For_Raise, moved to the spec of this unit to be visible + to other implementation bodies. + + * s-intman.ads (Adjust_Context_For_Raise): Declare and import here, to + be visible by multiple implementation bodies. + + * init.c [VMS section] (__gnat_handle_vms_condition): Adjust context + only for conditions coming from hardware. + [alpha-tru64 section] (__gnat_adjust_context_for_raise): Implement, + adjustments to signal context prior to exception raise from signal + handler. + (__gnat_map_signal for VxWorks): Map SIGSEGV to Storage_Error in RTP + mode. + Solaris section: (__gnat_adjust_context_for_raise): New function. + Implementation of the machine context adjustments to perform prior to + raise from a signal handler. Version for both sparc and x86. + (HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE): Define. + (__gnat_error_handler): Expect a third argument, ucontext_t *. Adjust it + prior to raising as expected for any handler, before possible nested + faults to make sure all the contexts in a chain have been adjusted by + the time we propagate. + +2007-08-14 Pascal Obry + + * s-osinte-mingw.ads: Add support for Ada.Execution_Time on Windows. + (SYSTEM_INFO): New record. + (SetThreadIdealProcessor): New imported routine needed for supporting + task_info pragma on Windows. + + * s-taprop-mingw.adb (Enter_Task): Check if CPU number given in task + info can be applied to the current host. + (Create_Task): Set the ideal processor if information is present. + + * s-tasinf-mingw.adb, s-tasinf-mingw.ads, + a-exetim-mingw.adb, a-exetim-mingw.ads: New files. + +2007-08-14 Olivier Hainque + + * s-taprop-linux.adb (Get_Stack_Attributes): New subprogram. Fetch the + stack size and initial stack pointer value for a given task. + (Enter_Task): Get the stack attributes of the task we are entering and + let the stack checking engine know about them. + + * s-stchop.adb, s-stchop.ads (Notify_Stack_Attributes): New subprogram. + Let the stack-checking engine know about the initial sp value and stack + size associated with the current task. + (Set_Stack_Info): If a stack base has been notified for the current + task, honor it. Fallback to the previous less accurate method otherwise. + + * s-stchop-vxworks.adb (Notify_Stack_Attributes): Dummy body. + +2007-08-14 Ed Schonberg + + * sem_ch10.adb: Create a limited view of an incomplete type, to make + treatment of limited views uniform for all visible declarations in a + limited_withed package. + Set flag indicating that a subprogram body for a child unit has a + generated spec. + (Analyze_Compilation_Unit): If unit is a subprogram body that has no + separate declaration, remove the unit name from visibility after + compilation, so that environment is clean for subsequent compilations. + (Install_Limited_Context_Clauses): Do not install a + limited_private_with_clause unless the current unit is a body or a + private child unit. + (Analyze_Subunit, Install_Parents): Treat generic and non-generic units + in the same fashion. + (Install_Limited_Withed_Unit): Do not install a limited with clause if + it applies to the declaration of the current package body. + (Remove_Private_With_Clauses): If there is a regular with_clause for + the unit, delete Private_With_Clause from context, to prevent improper + hiding when processing subsequent nested packages and instantiations. + +2007-08-14 Jose Ruiz + + * adaint.c (__gnat_is_absolute_path): For VxWorks systems we accept + dir/file, device:/dir/file, and device:drive_letter:/dir/file as + representing absolute path names. + __gnat_set_file_time_name [VMS]: Fix some 64/32 bit issues. + + * cstreams.c (__gnat_full_name for VxWorks): Use + __gnat_is_absolute_path to detect whether we need to add the current + directory to normalize the path. + +2007-08-14 Javier Miranda + + * a-tags.ads, + a-tags.adb (Displace): Associate a message with the raised CE + exception. + (To_Addr_Ptr, To_Address, To_Dispatch_Table_Ptr, + To_Object_Specific_Data_Ptr To_Predef_Prims_Ptr, + To_Tag_Ptr, To_Type_Specific_Data_Ptr): Moved here from the package + spec. + (Default_Prim_Op_Count): Removed. + (IW_Membership, Get_Entry_Index, Get_Offset_Index, Get_Prim_Op_Kind, + Register_Tag, Set_Entry_Index, Set_Offset_To_Top, Set_Prim_Op_Kind): + Remove pragma Inline_Always. + + * rtsfind.ads (Default_Prim_Op_Count): Removed + (Max_Predef_Prims): New entity + (RE_Expanded_Name): Removed + (RE_HT_Link): Removed + (RE_Iface_Tag): Remmoved + (RE_Ifaces_Table): Removed + (RE_Interfaces_Array): Removed + (RE_Interface_Data_Element): Removed + (RE_Nb_Ifaces): Removed + (RE_RC_Offset): Removed + (RE_Static_Offset_To_Top): Removed + + * exp_atag.ads, exp_atag.adb (Build_Inherit_Prims): Addition of a new + formal. + (Build_Inherit_Predefined_Prims): Replace occurrences of Default_ + Prim_Op_Count by Max_Predef_Prims. + +2007-08-14 Thomas Quinot + Vincent Celier + + * binde.adb (Elab_All_Links): Remove unnecessary call to + Generic_Separately_Compiled (if a unit satisfies this predicate, there + won't be an associated Afile). + (Elab_All_Links): Fail if a referenced unit cannot be found + + * bindgen.adb: + Fix comments in bindgen regarding consistency checks done in Bcheck: + the checks are made across units within a partition, not across several + partitions. + Fix generation of C binder file for VxWorks. + + * lib.ads, lib.adb (Generic_Separately_Compiled): Rename to + Generic_May_Lack_ALI, more descriptive of the current use of the + predicate, and update documentation. + + * lib-writ.ads, lib-writ.adb (Write_With_Lines): Minor code + reorganization and documentation update for the case of predefined + library generics (for which we do not reference an Afile). + +2007-08-14 Robert Dewar + + * s-intman-irix.adb, s-osinte-irix.adb, s-osinte-irix.ads, + s-proinf-irix-athread.ads, s-osinte-hpux-dce.adb, s-osinte-hpux-dce.ads, + s-parame-hpux.ads, s-intman-dummy.adb, s-tasinf-solaris.adb, + s-tasinf-solaris.ads, s-asthan-vms-alpha.adb, s-inmaop-vms.adb, + s-intman-vms.adb, s-intman-vms.ads, s-osprim-mingw.adb, + s-parame-vms-restrict.ads, s-parame-ae653.ads, s-intman-vxworks.ads, + s-intman-vxworks.ads, s-intman-vxworks.adb, s-parame-vxworks.ads, + s-tfsetr-vxworks.adb, s-interr.adb, s-interr.ads, a-tasatt.adb, + exp_ch13.adb, s-htable.ads, s-imgboo.ads, s-imglli.ads, s-imgllu.ads, + s-imguns.ads, g-eacodu.adb, par-ch12.adb, s-stache.ads, s-stausa.adb, + s-poosiz.adb, s-parame.ads, s-mastop.ads, s-osinte-darwin.ads, + a-chtgke.adb, s-asthan-vms-alpha.adb, s-parame-vms-alpha.ads, + s-parame-vms-ia64.ads, s-parame-vxworks.adb, s-except.ads, + g-altcon.adb: Minor reformatting + + ada-tree.h: Delete empty line. + + ali.ads: Minor reformatting + Clarification of comments. + Minor spelling correction + + * exp_dbug.adb: Add Warnings Off to suppress new warning + + * a-witeio.adb (Write): Add Warnings (Off) for unneeded IN OUT mode + formal + + * a-strunb.adb (Set_Unbounded_String): Avoid memory leak by freeing old + value + + * a-textio.adb (Write): Remove an unnecessary IN OUT mode from + + * a-textio.ads: Reorder the standard input/output/error declarations + for consistency. + + * g-dirope.adb, g-dirope.ads: Change Dir to mode IN for Open call + + * par-ch2.adb: Recognize RM specially in errout + Change 'R'M to RM in all error messages + + * scng.adb: Recognize RM specially in errout + + * sem.ads, sem.adb, exp_strm.adb, exp_ch5.ads, expander.adb: Rename + N_Return node to be N_Simple_Return, to reflect Ada 2005 terminology. + + * s-direio.adb: Add missing routine header box. + + * sem_attr.ads: Add ??? comments + + * sem_eval.adb: Recognize RM specially in errout + Change 'R'M to RM in all error messages + + * sem_maps.adb, sem_maps.ads: Remove some unnecessary IN OUT modes + + * s-tasinf.ads: Fix minor comment typo. + + * a-cihama.adb: Minor comment addition + + * a-ztexio.adb (Write): Add Warnings (Off) for unneeded IN OUT mode + formal + + * s-tasinf-tru64.ads: Fix minor comment typo. + + * itypes.ads: Comment update. + + * ali-util.adb: Remove Generic_Separately_Compiled guard, not needed + anymore. + + * argv.c: Added protection against null gnat_argv and gnat_envp. + + * bcheck.adb (Check_Consistency): Use correct markup character ({) in + warning message when Tolerate_Consistency_Errors is True. + + * cstand.adb (Create_Standard): Do not call Init_Size_Alignment for + Any_Id, as this subprogram is only applicable to *type* entities (it + sets RM_Size). Instead initialize just Esize and Alignment. + +2007-08-14 Bob Duff + + * a-cihama.ads, a-cidlli.ads, a-chtgop.ads, a-chtgop.adb, a-cdlili.ads, + a-cihase.adb, a-cihase.ads, a-cohase.adb, a-cohase.ads, a-ciorma.ads, + a-coorma.ads, a-ciormu.ads, a-coormu.ads, a-ciorse.ads, a-cohama.ads, + a-cohata.ads, a-convec.adb, a-coinve.ads, a-coinve.adb, a-convec.ads, + a-coorse.ads (Next): Applied pragma Inline. + Make all Containers packages Remote_Types (unless they are already + Pure). + (Previous): applied pragma Inline + (Elements_Type): is now a record instead of an array + +2007-08-14 Thomas Quinot + + * table.adb, g-table.adb, g-dyntab.adb (Append): Reimplement in terms + of Set_Item. + (Set_Item): When the new item is an element of the currently allocated + table passed by reference, save a copy on the stack if we're going + to reallocate. Also, in Table.Set_Item, make sure we test the proper + variable to determine whether to call Set_Last. + + * sinput-d.adb, sinput-l.adb, stringt.adb, switch-m.adb, + symbols-vms.adb, symbols-processing-vms-alpha.adb, + symbols-processing-vms-ia64.adb, sem_elab.adb, repinfo.adb: Replace + some occurrences of the pattern + T.Increment_Last; + T.Table (T.Last) := Value; + with a cleaner call to + T.Append (Value); + +2007-08-14 Ed Schonberg + Gary Dismukes + Thomas Quinot + + * sem_ch12.ads, sem_ch12.adb (Instantiate_Type): If the formal is a + derived type with interface progenitors use the analyzed formal as the + parent of the actual, to create renamings for all the inherited + operations in Derive_Subprograms. + (Collect_Previous_Instances): new procedure within of + Load_Parent_Of_Generic, to instantiate all bodies in the compilation + unit being loaded, to ensure that the generation of global symbols is + consistent in different compilation modes. + (Is_Tagged_Ancestor): New function testing the ancestor relation that + takes progenitor types into account. + (Validate_Derived_Type_Instance): Enforce the rule of 3.9.3(9) by + traversing over the primitives of the formal and actual types to locate + any abstract subprograms of the actual type that correspond to a + nonabstract subprogram of the formal type's ancestor type(s), and issue + an error if such is found. + (Analyze_Package_Instantiation, Analyze_Subprogram_Instantiation, + Instantiate_Package_Body, Instantiate_Subprogram_Body): + Remove bogus guard around calls to Inherit_Context. + (Reset_Entity): If the entity is the selector of a selected component + that denotes a named number, propagate constant-folding to the generic + template only if the named number is global to the generic unit. + (Set_Instance_Env): Only reset the compilation switches when compiling + a predefined or internal unit. + +2007-08-14 Ed Schonberg + + * sem_ch4.adb (Try_Class_Wide_Operation): use base type of first + parameter to determine whether operation applies to the prefix. + (Complete_Object_Operation): If actual has an access type and + controlling formal is not an in_parameter, reject the actual if it is + an access_to_constant type. + (Try_Primitive_Operation): If the type of the prefix is a formal tagged + type, the candidate operations are found in the scope of declaration of + the type, because the type has no primitive subprograms. + (Analyze_Selected_Component): If prefix is class-wide, and root type is + a private extension, only examine visible components before trying to + analyze as a prefixed call. + Change Entity_List to Type_To_Use, for better readability. + (Has_Fixed_Op): Use base type when checking whether the type of an + operator has a user-defined multiplication/division + (Check_Arithmetic_Pair): Use Ada 2005 rules to remove ambiguities when + user-defined operators are available for fixed-point types. + +2007-08-14 Thomas Quinot + Ed Schonberg + + * sem_cat.ads, sem_cat.adb (Has_Stream_Attribute_Definition): New + formal At_Any_Place indicating, when True, that we want to test for + availability of the stream attribute at any place (as opposed to the + current visibility context only). + (Missing_Read_Write_Attributes): A stream attribute is missing for the + purpose of enforcing E.2.2(8) only if it is not available at any place. + Take into account the Ada2005 pragma Has_Preelaborable_Initialization + when checking the legality of an extension aggregate in a preelaborable + package. Treat the literal null as a valid default expression in a + component declaration for a type with preelaborable initialization. + A limited interface is a legal progenitor for the designated type of a + remote access to class-wide type. + +2007-08-14 Thomas Quinot + Ed Schonberg + + * sem_ch8.ads, sem_ch8.adb (Find_Type, case of a 'Base attribute + reference): Use correct entity as denoted entity for the selector of + the rewritten node. + (Find_Direct_Name): Add comment about Generate_Reference incorrectly + setting the Referenced_As_LHS flag for entities that are implicitly + dereferenced. + (Find_Type): If the type is an internally generated incomplete type, + mark the full view as referenced, to prevent spurious warnings. + (Find_Selected_Component, Has_Components): Handle properly non-limited + views that are themselves incomplete types. + Handle interfaces visible through limited-with clauses. + (Analyze_Subprogram_Renaming): Disambiguate and set the entity of a + subprogram generic actual for which we have generated a renaming. + Warn when the renaming introduces a homonym of + the renamed entity, and the renamed entity is directly visible. + +2007-08-14 Ed Schonberg + Hristian Kirtchev + + * sem_res.adb (Resolve_Allocator): Propagate any coextensions that + appear in the subtree to the current allocator if it is not a static + coextension. + (Resolve_Allocator): Perform cleanup if resolution has determined that + the allocator is not a coextension. + (Resolve): Skip an interpretation hidden by an abstract operator only + when the type of the interpretation matches that of the context. + (Resolve): When looping through all possible interpretations of a node, + do not consider those that are hidden by abstract operators. + (Resolve_Actuals): When verifying that an access to class-wide object + is an actual for a controlling formal, ignore anonymous access to + subprograms whose return type is an access to class_wide type. + (Resolve_Slice): If the prefix of the slice is a selected component + whose type depends on discriminants, build its actual subtype before + applying range checks on the bounds of the slice. + (Valid_Conversion): In an instance or inlined body, compare root types, + to prevent anomalies between private and public views. + (Resolve): Improve error message for ambiguous fixed multiplication + expressions that involve universal_fixed multiplying operations. + +2007-08-14 Javier Miranda + Hristian Kirtchev + + * exp_ch9.adb (Build_Protected_Entry): Propagate the original source + location to allow the correct generation of errors in case of + restrictions applied to the expanded code. + (Expand_Entry_Barrier): Remove all generated renamings for a barrier + function if the condition does not reference them. + (Expand_Entry_Body_Declarations): Mark the index constant as having a + valid value. + +2007-08-14 Thomas Quinot + Pablo Oliveira + + * exp_dist.adb (PolyORB_Support.Build_TypeCode_Function): When creating + typecode parameters for a union (in a variant record), remove + extraneous layer of Any wrapping for member label. + (Expand_Receiving_Stubs_Bodies): For an RCI package body that has + elabration statements, register the package with the name server + at the beginning, not at the end, of the elaboration statements so + that they can create remote access to subprogram values that designate + remote subprograms from the package. + +2007-08-14 Hristian Kirtchev + + * g-catiio.adb (Image): For the case of %s, use Ada.Calendar.Time + values to compute the number of seconds since the Unix Epoc in order to + account for Daylight Savings Time. Perform special processing for dates + that are earlier than the Unix Epoc to obtain a negative number. + +2007-08-14 Emmanuel Briot + + * g-comlin.adb (Getopt): Fix handling of "*" switch when not collapsing + switches. + +2007-08-14 Eric Botcazou + + * gnatlink.adb (Gnatlink): Pass switches to the linker even if the + binder-generated file is not in Ada. + Pass -mrtp to the linker if it is GCC and --RTS=rtp has been + recorded in the ALI file. + Pass -fsjlj to the linker if it is GCC and --RTS=sjlj has been recorded. + +2007-08-14 Vincent Celier + + * gnatls.adb: (Corresponding_Sdep_Entry): Always return a value + (Output_Source): Do nothing if parameter is No_Sdep_Id + + * make.adb (Gnatmake): Do not rebuild an archive simply because a + shared library it imports has a later time stamp. + (Check): Resolve the symbolic links in the path name of the object + directory. + Check that the ALI file is in the correct object directory + Check if a file name does not correspond to the mapping of units + to file names. + (Display_Version): New procedure + (Initialize): Process switches --version and --help + Use type Path_Name_Type for path name + +2007-08-14 Paul Hilfinger + + * impunit.adb: Re-organize System.Random_Numbers and + GNAT.Random_Numbers and add to builds. + + * Makefile.rtl: Add s-rannum.ad* and g-rannum.ad*, a-assert* + + * s-rannum.ads, s-rannum.adb, g-rannum.ads, g-rannum.adb: New files. + + * a-assert.ads, a-assert.adb: New files. + +2007-08-14 Gary Dismukes + + * layout.adb (Layout_Type): In the case of access-to-subprogram types, + if AAMP_On_Target is True, then the size of the type encompasses two + addresses (a static link and a subprogram address), except in the case + of library-level access types. + +2007-08-14 Vincent Celier + + * output.ads, output.adb (Write_Eol): Remove trailing spaces before + writing the line. + (Write_Eol_Keep_Blanks): New procedure to write a line, including + possible trailing spaces. + (Output_Source_Line): Call Write_Eol_Keep_Blanks to output a source line + +2007-08-14 Javier Miranda + + * par-ch6.adb (P_Formal_Part): Fix wrong error message associated with + null-excluding access types. + +2007-08-14 Javier Miranda + + * sem_ch9.adb (Check_Interfaces): New subprogram that factorizes code + that is common to Analyze_Protected_Type and Analyze_Task_Type. In case + of private types add missing check on matching interfaces in the + partial and full declarations. + (Analyze_Protected_Type): Code cleanup. + (Analyze_Task_Type): Code cleanup. + +2007-08-14 Javier Miranda + + * sem_disp.adb (Check_Dispatching_Operation): Do not emit warning on a + generated interface thunk. + +2007-08-14 Ed Schonberg + + * s-ficobl.ads: Declare AFCB as a tagged incomplete type, to prevent + obsolescent warning on application of 'Class to an incomplete type. + + * s-finroo.ads: Declare Root_Controlled as a tagged incomplete type, to + prevent obsolescent warning on application of 'Class to an incomplete + type. + +2007-08-14 Pascal Obry + + * s-fileio.adb (Is_Open): Add check for usability of the underlying + file stream. + +2007-08-14 Cyrille Comar + + * s-finimp.adb (Detach_From_Final_List): make this procedure idempotent + since it is potentially used in cases implying double finalization of + the same object. + +2007-08-14 Jose Ruiz + + * s-tasini.adb (Get_Stack_Info): Move this function to + System.Soft_Links.Tasking because it is common to the full and the + restricted run times. + (Init_RTS): Do not set the Get_Stack_Info soft link because it is done + in SSL.Tasking.Init_Tasking_Soft_Links. + + * s-solita.adb (Get_Stack_Info): Function moved from + System.Tasking.Initialization because it is common to the full and the + restricted run times. + (Init_Tasking_Soft_Links): Set the tasking soft link for Get_Stack_Info. + +2007-08-14 Arnaud Charlet + + * s-tpobop.ads, s-tpobop.adb, s-tasren.ads, s-tasren.adb, + s-taskin.ads (Requeue_With_Abort): Rename field With_Abort. + (PO_Do_Or_Queue, Task_Do_Or_Queue, Requeue_Call): Remove With_Abort + parameter. + + * s-tassta.adb (Task_Wrapper): Increased value of the small overflow + guard to 12K. + +2007-08-14 Gary Dismukes + + * s-veboop.adb (SU): New named number initialized to + System.Storage_Unit. + (True_Val): The initialization expression is revised to use SU (= + Storage_Unit) rather than assuming 8 for the component size of an + unpacked Boolean array. + +2007-08-14 Tristan Gingold + + * tracebak.c: Use tb-ivms.c on OpenVMS Itanium. + + * tb-ivms.c: New file. + + * g-trasym-vms-ia64.adb: Fixed for OpenVMS version 8.2 + +2007-08-14 Geert Bosch + + * i-forbla.ads, i-forbla.adb, a-ngcoar.adb, a-ngcoar.ads, i-forlap.ads, + s-gearop.adb, s-gecobl.adb, s-gecobl.ads, s-gerela.adb, s-gerela.ads: + Add required linker pragmas for automatically linking with the gnalasup + linear algebra support library, and the systems math library. + Rename cdot to cdotu and zdot to zdotu. + Update header comment to describe purpose of package. + +2007-08-14 Thomas Quinot + + * exp_ch7.adb (Find_Final_List): For an anonymous access type that has + an explicitly specified Associated_Final_Chain, use that list. + (Expand_N_Package_Body): Build dispatch tables of library level tagged + types. + (Expand_N_Package_Declaration): Build dispatch tables of library level + tagged types. Minor code cleanup. + +2007-08-14 Vincent Celier + + * gnatchop.adb (Terminate_Program): Remove exception and use + Types.Terminate_Program instead. + + * osint.ads, osint.adb (Current_Exit_Status): New global variable + (Find_Program_Name): Added protection against empty name. + (OS_Exit_Through_Exception): New procedure + + * s-os_lib.ads, s-os_lib.adb (OS_Exit): New procedure body + (OS_Exit_Default): New procedure that contains the previous + implementation of procedure OS_Exit. + (Final_Value): Remove obsolete Interix stuff. + +2007-08-14 Thomas Quinot + + * g-socket.ads: Reorganize example code so that it also works on + Windows XP. + +2007-08-14 Tristan Gingold + + * g-trasym.ads: AIX now supports symbolic backtraces. + +2007-08-14 Ed Schonberg + + * lib-load.adb (From_Limited_With_Chain): Always scan the stack of + units being loaded to detect circularities. A circularity may be + present even if the current chain of pending units to load starts from + a limited_with_clause. + + * lib-load.ads: Change profile of Load_Unit to use a with_clause + rather than a boolean flag, in order to detect circularities in + with_clauses. + + * par-load.adb: Use current with_clause in calls to Load_Unit, rather + than propagating the From_Limited_With flag, in order to handle + properly circularities involving with_clauses. + +2007-08-14 Nicolas Setton + + * link.c (FreeBSD): Add "const" keyword where needed, to eliminate + warnings. + +2007-08-14 Arnaud Charlet + + * Makefile.in: GNATRTL_LINEARALGEBRA_OBJS: New variable holding objects + to build for libgnala. + libgnat: Add rules to build libgnala.a + (LIBGNAT_TARGET_PAIRS for VxWorks): Remove s-osinte-vxworks.adb from + target pairs of the VxWorks 6 kernel runtime, use it only for VxWorks 5. + Add s-osinte-vxworks-kernel.adb to the target pairs of the + kernel run-time lib for VxWorks 6, which would provide a different + implementation for Task_Cont and Task_Stop than the VxWorks 5 version. + x86-solaris section (EH_MECHANISM): Set to -gcc, as this port is now + running ZCX by default. + Add g-sttsne-locking to LynxOS version. + Remove g-sttsne-vxworks.ads; use g-sttsne-locking.ads instead. + On x86/darwin, use a-numaux-x86.ad? and system-darwin-x86.ads. + + * system-darwin-x86.ads: New file. + + * Make-lang.in: Delete files before copying onto them, so if they are + read-only, the copy won't fail. + Update dependencies + +2007-08-14 Pascal Obry + + * mdll-fil.adb, * mdll.adb: Implement a more consistent libraries + naming scheme. + +2007-08-14 Vincent Celier + + * mlib-utl.adb (Gcc_Name): Change from constant String to String_Access + (Gcc): Initialize Gcc_Name at the first call + +2007-08-14 Ed Schonberg + + * sem_ch7.adb (Analyze_Package_Specification): Do not install private + with_clauses of the enclosing unit when analyzing the package + specification of a nested instance. + +2007-08-14 Hristian Kirtchev + + * sinfo.ads, sinfo.adb (Is_Coextension, Set_Is_Coextension): Removed. + (Is_Dynamic_Coextension, Set_Is_Dynamic_Coextension): New routines. + Remove flag Is_Coextension. Add flag Is_Dynamic_Coextension. Update the + layout of N_Allocator. + +2007-08-14 Thomas Quinot + + * rtsfind.adb (Check_RPC): Add PCS version check. + + * gnatvsn.ads, gnatvsn.adb: Add PCS version. + (Gnat_Free_Software): New function. + + * sem_dist.ads, sem_dist.adb (Get_PCS_Version): New subprogram. Returns + the PCS_Version value from s-parint, used to check that it is consistent + with what exp_dist expects. + + * s-parint.ads (PCS_Version): New entity for checking consistency + between exp_dist and PCS. + + * gen-soccon.c: (SO_REUSEPORT): New constant. + +2007-08-14 Hristian Kirtchev + + * a-calfor.adb (Image (Duration; Boolean)): Change type of local + variable Sub_Second to Duration in order to accomodate a larger range + of arithmetic operations. + +2007-08-14 Bob Duff + + * g-sttsne-locking.ads: Move comments from spec to body. + * g-sttsne-locking.adb: Move comments from spec to body. + * g-sttsne-vxworks.ads: Removed. + * g-sttsne-vxworks.adb: Removed. + +2007-08-11 Ian Lance Taylor + + * misc.c (gnat_get_alias_set): Change return type to + alias_set_type. + +2007-08-11 Kaveh R. Ghazi + + * decl.c, utils2.c: Fix whitespace in last change. + +2007-08-11 Kaveh R. Ghazi + + * decl.c (compare_field_bitpos): Constify. + * utils2.c (compare_elmt_bitpos): Likewise. + +2007-07-27 Aurelien Jarno + + * s-osinte-kfreebsd-gnu.ads ((sigset_t_ptr): Removed, replaced by + anonymous access type. + (pthread_sigmask): Now take an access sigset_t. + +2007-07-05 Joel Sherrill + + * s-osinte-rtems.ads: Correct prototype of pthread_sigmask. + +2007-06-21 Eric Botcazou + + PR tree-optimization/25737 + * misc.c (gnat_post_options): Do not force flag_tree_salias to 0. + +2007-06-15 Andrew Pinski + + * trans.c (Attribute_to_gnu): When subtracting an + offset from a pointer, use POINTER_PLUS_EXPR with + NEGATE_EXPR instead of MINUS_EXPR. + (gnat_to_gnu): Likewise. + * utils.c (convert): When converting between + thin pointers, use POINTER_PLUS_EXPR and sizetype + for the offset. + * utils2.c (known_alignment): POINTER_PLUS_EXPR + have the same semantics as PLUS_EXPR for alignment. + (build_binary_op): Add support for the semantics of + POINTER_PLUS_EXPR's operands. + When adding an offset to a pointer, use POINTER_PLUS_EXPR. + +2007-06-11 Rafael Ávila de Espíndola + + * trans.c (Attribute_to_gnu): Use signed_or_unsigned_type_for instead + of get_signed_or_unsigned_type. + * misc.c (LANG_HOOKS_SIGNED_TYPE): Remove. + +2007-06-11 Bob Duff + Thomas Quinot + + * g-stsifd-sockets.adb (Create): Work around strange behavior of + 'bind' on windows that causes 'connect' to fail intermittently, by + retrying the 'bind'. + (GNAT.Sockets.Thin.Signalling_Fds): New procedure Close. + +2007-06-10 Duncan Sands + + * decl.c (gnat_to_gnu_entity): Use pointers to dummy nodes, rather + than to void, for the fields when making a new fat pointer type. + (gnat_substitute_in_type): Now substitute_in_type. + * gigi.h (gnat_substitute_in_type): Likewise. Adjust recursive calls. + * trans.c (gnat_gimplify_expr): Remove COMPONENT_REF kludge. + * utils.c (update_pointer_to): Update fat pointers by updating the + dummy node pointers used for the fields. + +2007-06-06 Thomas Quinot + Bob Duff + + * g-soccon-freebsd.ads, g-soccon-vxworks.ads:, + g-soccon-aix.ads, g-soccon-irix.ads, g-soccon-hpux.ads, + g-soccon-solaris.ads, g-soccon-vms.ads, g-soccon-tru64.ads: Add new + constant Thread_Blocking_IO, always True by default, set False + on a per-runtime basis. + (Need_Netdb_Buffer): New constant. + + * g-stheme.adb, g-sttsne.ads, g-sttsne-locking.ads, + g-sttsne-locking.adb, g-sttsne-vxworks.ads, g-sttsne-vxworks.adb: New + files. + + * g-socthi-vxworks.ads, g-socthi-vxworks.adb, + g-socthi-vms.ads, g-socthi-vms.adb (Safe_Gethostbyname, + Safe_Gethostbyaddr, Safe_Getservbyname, Safe_Getservbyport): Use new + child package Task_Safe_NetDB + (Host_Error_Messages): Add stub body. + (GNAT.Sockets.Thin.Signalling_Fds): New procedure Close. + + * g-soccon-mingw.ads: Add Windows-specific constants. + (Need_Netdb_Buffer): New constant. + (GNAT.Sockets.Thin.C_Inet_Addr, Windows version): Remove useless Ada + wrapper and import inet_addr(3) from the standard sockets library + directly instead. + (In_Addr): Add alignment clause. + (GNAT.Sockets.Thin.Signalling_Fds): New procedure Close. + +2007-06-06 Robert Dewar + + * a-taster.adb, s-osinte-hpux.ads, s-osinte-solaris-posix.ads, + s-osinte-irix.ads, s-interr-sigaction.adb, s-mastop-irix.adb, + s-osinte-hpux-dce.ads, s-osinte-interix.ads, s-osinte-solaris.ads, + s-taspri-solaris.ads, s-inmaop-vms.adb, s-interr-vms.adb, + s-mastop-vms.adb, s-osinte-vms.ads, s-tpopde-vms.adb, + s-osinte-mingw.ads, s-interr-vxworks.adb, i-cstrea-vms.adb, + a-diocst.adb, a-direio.adb, a-interr.adb, a-sequio.adb, a-siocst.adb, + a-ssicst.adb, a-storio.adb, a-ststio.adb, a-stwima.adb, a-tasatt.adb, + a-taside.adb, a-tiocst.adb, a-witeio.adb, a-wtcstr.adb, g-crc32.adb, + g-dirope.adb, g-dyntab.adb, g-memdum.adb, g-regexp.adb, g-spipat.adb, + g-spitbo.adb, g-string.adb, g-string.ads, g-table.adb, g-thread.adb, + i-cobol.adb, i-cpoint.adb, i-cstrea.adb, i-cstrin.adb, i-pacdec.adb, + s-addima.adb, s-arit64.adb, s-auxdec.adb, s-auxdec.ads, + s-auxdec-vms_64.ads, s-carsi8.adb, s-carun8.adb, s-casi16.adb, + s-casi32.adb, s-casi64.adb, s-caun16.adb, s-caun32.adb, s-caun64.adb, + s-direio.adb, s-fileio.adb, s-finimp.ads, s-geveop.adb, s-imgenu.adb, + s-pack03.adb, s-pack05.adb, s-pack06.adb, s-pack07.adb, s-pack09.adb, + s-pack10.adb, s-pack11.adb, s-pack12.adb, s-pack13.adb, s-pack14.adb, + s-pack15.adb, s-pack17.adb, s-pack18.adb, s-pack19.adb, s-pack20.adb, + s-pack21.adb, s-pack22.adb, s-pack23.adb, s-pack24.adb, s-pack25.adb, + s-pack26.adb, s-pack27.adb, s-pack28.adb, s-pack29.adb, s-pack30.adb, + s-pack31.adb, s-pack33.adb, s-pack34.adb, s-pack35.adb, s-pack36.adb, + s-pack37.adb, s-pack38.adb, s-pack39.adb, s-pack40.adb, s-pack41.adb, + s-pack42.adb, s-pack43.adb, s-pack44.adb, s-pack45.adb, s-pack46.adb, + s-pack47.adb, s-pack48.adb, s-pack49.adb, s-pack50.adb, s-pack51.adb, + s-pack52.adb, s-pack53.adb, s-pack54.adb, s-pack55.adb, s-pack56.adb, + s-pack57.adb, s-pack58.adb, s-pack59.adb, s-pack60.adb, s-pack61.adb, + s-pack62.adb, s-pack63.adb, s-pooloc.adb, s-poosiz.adb, s-scaval.adb, + s-sequio.adb, s-shasto.adb, s-stalib.ads, s-stratt.adb, s-strcom.adb, + s-taasde.adb, s-tasdeb.adb, s-tasuti.ads, s-tataat.ads, s-tpoben.ads, + s-valenu.adb, s-widenu.adb, s-wwdenu.adb, s-addope.adb, a-stzmap.adb, + a-ztcstr.adb, a-ztexio.adb, s-osinte-linux-hppa.ads: Replace + Unchecked_* by Ada.Unchecked_* + +2007-06-06 Robert Dewar + + * g-string.adb, s-proinf-irix-athread.adb, s-gloloc-mingw.adb, + s-tfsetr-default.adb, gnatfind.adb, gnatxref.adb, gprep.adb, + g-regexp.adb, g-regexp.ads, g-regpat.ads, g-tasloc.adb, g-tasloc.ads, + output.adb, switch-m.ads, tree_in.ads, tree_io.ads, indepsw.ads, + g-utf_32.adb, g-utf_32.ads, a-wichun.adb, a-wichun.ads, a-zchuni.adb, + a-zchuni.ads: Replace GNAT.xxx by System.xxx when appropriate. + + * s-utf_32.adb, s-utf_32.ads, s-os_lib.adb, s-os_lib.ads, s-regexp.adb, + s-regexp.ads, s-regpat.adb, s-regpat.ads, s-string.adb, s-string.ads, + s-tasloc.adb, s-tasloc.ads: New files. + +2007-06-06 Bob Duff + + * g-expect-vms.adb: + (Send_Signal, Close): Raise Invalid_Process if the process id is invalid. + * g-expect.ads, g-expect.adb (Send): Avoid useless copy of the string. + (Send_Signal, Close): Raise Invalid_Process if the process id is + invalid. + (Pattern_Matcher_Access): Is now a general access type to be able to + use aliased string. + +2007-06-06 Thomas Quinot + Arnaud Charlet + + * a-intnam-aix.ads: Adjust comment to account for SIGADAABORT change + (SIGEMT is now used instead of SIGTERM on AIX). + + * s-osinte-aix.ads (Linker_Options): Use -pthread instead of -lpthreads. + (Time_Slice_Supported): Set to True. + Use SIGEMT instead of SIGTERM as SIGADAABORT. + +2007-06-06 Hristian Kirtchev + + * a-calend.ads, a-calend.adb, a-calend-vms.ads, a-calend-vms.adb ("-" + (Time, Time)): Use To_Relative_Time rather than manual calculation to + express the bounds of Duration as Time. Raise Time_Error when the + result is greater or equal to the higher bound of Duration (on the + margin case). + ("+" (Time, Duration)): Reorder code. Remove the declaration of constant + Ada_High_And_Leaps. + ("-" (Time, Duration)): Reorder code. Remove the declaration of constant + Ada_High_And_Leaps. + ("-" (Time, Time)): Reorder code. + (All_Leap_Seconds): Removed. + (Arithmetic_Operations.Add): Remove sign related kludge. + (Arithmetic_Operations.Difference): Control the leaps seconds processing + with flag Leap_Support. + (Arithmetic_Operations.Subtract): Remove sign related kludge. + (Check_Within_Time_Bounds): New procedure. + (Clock): Control the leap seconds processing with flag Leap_Support. + (Cumulative_Leap_Seconds): Assert that the target supports leap seconds. + (Formatting_Operations.Split): Control the leap seconds processing with + flag Leap_Support. + (Formatting_Operations.Time_Of): Control the leaps seconds processing + with flag Leap_Support. Adjust the year, month and day (if applicable) + when the value of day seconds designates a new day. + (Split): Use parameter associations for better readability. Integrate + flag Is_Ada_05. + (Time_Of): Use parameter associations for better readability. Integrate + flag Is_Ada_05. + + * a-calfor.adb (Split): Use parameter associations for better + readability. Integrate flag Is_Ada_05. + (Time_Of): Remove flag Leap_Checks. Use parameter associations for + better readability. Integrate flag Is_Ada_05. + +2007-06-06 Arnaud Charlet + + * s-taprop-vms.adb, s-taprop-hpux-dce.adb, s-taprop-vxworks.adb, + s-osprim-posix.adb, s-taprop-posix.adb, s-osprim-vxworks.adb, + s-taprop-solaris.adb, s-osprim-solaris.adb, s-taprop-dummy.adb, + s-osprim-unix.adb, s-osinte-freebsd.adb, s-osinte-freebsd.ads, + s-osinte-lynxos.adb, s-osinte-lynxos.ads, s-taprop-tru64.adb, + s-taprop-lynxos.adb, s-taprop-irix.adb, s-osinte-tru64.adb, + s-osinte-tru64.ads, s-taprop-linux.adb, s-parame.ads, + s-parame-vms-alpha.ads, s-parame-vms-ia64.ads, s-parame-hpux.ads, + s-parame-vms-restrict.ads, s-parame-ae653.ads, s-parame-vxworks.ads, + s-taprop-mingw.adb, s-osinte-lynxos-3.ads, s-osinte-lynxos-3.adb, + s-osprim-mingw.adb (Timed_Delay, Timed_Sleep): Register the base + time when entering this routine to detect a backward clock setting + (manual setting or DST adjustment), to avoid waiting for a longer delay + than needed. + (Time_Duration, To_Timeval, struct_timeval): Removed when not relevant. + Remove handling of deferred priority change, and replace by setting the + task priority directly, as required by AI-188. + Update comments. + (Max_Task_Image_Length): New constant. + Replace Warnings (Off) by Unreferenced pragma, cleaner. + (Dynamic_Priority_Support): Removed, no longer needed. + (Poll_Base_Priority_Change): Ditto. + (Set_Ceiling): Add this procedure to change the ceiling priority + associated to a lock. This is a dummy implementation because dynamic + priority ceilings are not supported by the underlying system. + + * a-dynpri.adb (Set_Priority): Take into account case where Target is + accepting a RV with its priority boosted. + Remove handling of deferred priority change, and replace by setting the + task priority directly, as required by AI-188. + + * s-taenca.adb (Try_To_Cancel_Entry_Call): Remove special case for + Succeeded = True. + Remove handling of deferred priority change, and replace by setting the + task priority directly, as required by AI-188. + (Wait_For_Completion, Wait_For_Call, Timed_Selective_Wait): Change state + of Self_Id earlier. + + * s-tasini.ads, s-tasini.adb (Wakeup_Entry_Caller): Relax assertion. + (Poll_Base_Priority_Change): Removed. + Code clean up: use SSL.Current_Target_Exception. + + * s-tasren.adb (Task_Count): Call Yield to let a chance to other tasks + to run as this is a potentially dispatching point. + (Call_Synchronous): Use Local_Defer_Abort. + (Callable): Relax assertion. + (Selective_Wait): Relax assertion in case abort is not allowed. + Remove handling of deferred priority change, and replace by setting the + task priority directly, as required by AI-188. + + * s-tasuti.adb (Make_Passive): Adjust assertions. + Remove handling of deferred priority change, and replace by setting the + task priority directly, as required by AI-188. + +2007-06-06 Arnaud Charlet + + * system-vxworks-sparcv9.ads, system-solaris-x86.ads, + system-irix-o32.ads, system-freebsd-x86.ads, system-lynxos-ppc.ads, + system-lynxos-x86.ads, system-vxworks-m68k.ads, system-linux-x86.ads, + system-vxworks-mips.ads, system-vxworks-alpha.ads, + system-vxworks-x86.ads, system-linux-ppc.ads, system-mingw.ads, + system-vms-zcx.ads, system-darwin-ppc.ads, system-vxworks-ppc.ads, + system-interix.ads, system-linux-hppa.ads, system-tru64.ads, + system-hpux.ads, system-irix-n32.ads, system-solaris-sparc.ads, + system-solaris-sparcv9.ads, system-vms.ads, system.ads, + system-vms_64.ads, system-hpux-ia64.ads, system-linux-x86_64.ads, + system-linux-ia64.ads: Document mapping between Ada and OS priorities. + This patch changes the largest non-binary modulus from 2**31-1 to + 2**32-1. + (Compiler_System_Version): Removed, no longer used. + Clean up system files by removing flags only used on a single target. + Also remove obsolete flags, only used during bootstrap from system.ads + (Address): Add a pragma Preelaborable_Initialization. + + * system-aix.ads: Ditto. + (GCC_ZCX_Support): Set to true. + Update priority range on AIX and map Ada priorities to target + priorities appropriately for different scheduling policies. + + * ttypes.ads: set largest non-binary modulus from 2**31-1 to 2**32-1 + +2007-06-06 Vincent Celier + + * mlib-tgt-specific.adb, mlib-tgt-specific.ads, + mlib-tgt-vms.adb, mlib-tgt-vms.ads: New files. + + * mlib-tgt.adb, mlib-tgt.ads, mlib-tgt-darwin.adb, + mlib-tgt-vxworks.adb, mlib-tgt-mingw.adb, mlib-tgt-lynxos.adb, + mlib-tgt-linux.adb, mlib-tgt-solaris.adb, mlib-tgt-vms-alpha.adb, + mlib-tgt-vms-ia64.adb, mlib-tgt-aix.adb, mlib-tgt-irix.adb, + mlib-tgt-hpux.adb, mlib-tgt-tru64.adb: Make a common body for package + MLib.Tgt, containing the default versions of the exported subprograms. + For each platform, create a specific version of the body of new child + package MLib.Tgt.Specific that contains only the body of subprograms + that are different from the default. + (Archive_Builder_Append_Options): New function. + +2007-06-06 Matthew Gingell + + * s-osinte-aix.adb: Map Ada priorities to target priorities + appropriately for different scheduling policies. + +2007-06-06 Arnaud Charlet + + * s-osinte-linux.ads (sigset_t): Bump alignment to match more closely + its C counterpart. + Remove references to Unchecked_Conversion, and use Ada.xxx instead. + Replace Unchecked_Conversion by Ada.Unchecked_Conversion. + +2007-06-06 Vasiliy Fofanov + + * s-osprim-vms.ads, s-osprim-vms.adb (Initialize): New procedure. + Noop on VMS, added for interface commonality. + +2007-06-06 Eric Botcazou + Richard Kenner + Olivier Hainque + + * decl.c (gnat_to_gnu_entity) : Manually mark the top of the + renamed expression of a full renaming at toplevel. + (gnat_to_gnu_entity, case object): If not defining, do not look inside + the values the constant is initialized to if it is an N_Allocator. + (gnat_to_gnu_entity) : Manually mark the top of the + TYPE_SIZE_UNIT of inner types after the stride is elaborated. + (make_aligning_type): Accept an extra ROOM argument for storage to be + made available before the aligned field, and an extra BASE_ALIGN + argument for callers to pass the alignment guaranteed to be honored for + the whole aligning object. Avoid call to finish_record_type, which only + interferes with the sizes we want to set. + (gnat_to_gnu_entity) : Pass the required extra arguments to + make_aligning_type for super-aligned objects on stack. + (components_to_record): Pass the adjusted size of the type when creating + fields in the qualified union for the variant part. + (gnat_substitute_in_type): Copy TYPE_USER_ALIGN. + (gnat_to_gnu_entity, case E_Signed_Integer_Subtype): Likewise for + packed array type. + (maybe_pad_type): Set TYPE_USER_ALIGN. + (make_aligning_type): Likewise. + ALIGN argument is unsigned int. + (gnat_to_gnu_entity, case E_Function): Back annotate return mechanism. + (gnat_to_gnu_param): Likewise, for parameters. + (gnat_to_gnu_entity) : Always instantiate the renaming object + if it is constant and stems from a function call. + (gnat_to_gnu_entity) : Set packed to -2 if the alignment + of the record is specified. Adjust accordingly. + (adjust_packed): New static function. + (gnat_to_gnu_field): Use it to adjust the packedness setting. + (components_to_record): Likewise. + (gnat_to_gnu_entity) : Do not test the renamed expression for + side-effects if the object is deemed constant. + (gnat_to_gnu_entity) : Create a name for the fat pointer + type instead of merely finalizing it. Tidy. + : Retrieve the type from the TYPE_DECL. + : Likewise. + (defer_debug_incomplete_list): Rename to defer_finalize_list. + (defer_debug_level): Delete. + (gnat_to_gnu_entity) : Likewise + : Call rest_of_record_type_compilation on the fat pointer + type. + : Do not explicitly defer finalizing the type. + Adjust for write_record_type_debug_info renaming. + : Likewise. + Finalize deferred types right after deferred incomplete types are + expanded. + (rest_of_type_decl_compilation): New global function. + (components_to_record): Rename defer_debug parameter to do_not_finalize. + (components_to_record): Propagate the packedness to the fields of the + qualified union type if there is a variant part. + (gnat_to_gnu_entity) : Use new function + instead of inline code to adjust the XUT field offsets. + (gnat_to_gnu_entity): Adjust for new prototype of finish_record_type. + : Do not let finish_record_type compute the sizes + and write the debug info if the type derives from a discriminated one. + (gnat_to_gnu_entity) : Adjust call to create_index_type. + : Likewise. + : Likewise. + (gnat_to_gnu_entity): Set TYPE_USER_ALIGN on types only if they have + an alignment clause. + (maybe_pad_type): Update ORIG_SIZE to the minimum required to meet ALIGN + before giving warning. + (prepend_one_attribute_to): New function, helper to prepend an attribute + to an attribute list. + (gnat_to_gnu_entity) : Use it. + (prepend_attributes): Likewise. + (gnat_to_gnu_entity) : Use constants of the proper type. + : Declare the padding type for the element type, if any. + : Likewise. + (defer_limited_with): New variable. + (Gigi_Equivalent_Type): New function. + (gnat_to_gnu_entity): Use it at start and use result throughout. + (gnat_to_gnu_entity, case E_Access_Type): Rework to use + Gigi_Equivalent_Type, support Limited_With, allow two levels of + indirection, precompute if unconstrained array to simplify logic, and + use defer_limited_with to defer elaboration of some types from limited + with. + (finalize_from_with_types): New function. + +2007-06-06 Gary Dismukes + Eric Botcazou + Tristan Gingold + Olivier Hainque + + * trans.c (Identifier_to_gnu): Change test for deferred constant by + adding guard that the entity is an E_Constant before testing presence + of Full_view (and remove unnecessary test that entity is not a type). + For a CONST_DECL used by reference, manually retrieve + the DECL_INITIAL. Do not invoke fold in the other DECL_P cases either. + (struct language_function): Move from utils.c to here. + (struct parm_attr): New structure. + (parm_attr, parm_attr vector, parm_attr GC vector): New types. + (f_parm_attr_cache): New macro. + (Attribute_to_gnu) : When not optimizing, cache the + expressions for the 'First, 'Last and 'Length attributes of the + unconstrained array IN parameters. + (Subprogram_Body_to_gnu): Use gnu_subprog_decl throughout. + Allocate the information structure for the function earlier, as well + as the language-specific part. + If the parameter attributes cache has been populated, evaluate the + cached expressions on entry. + (takes_address): Add OPERAND_TYPE parameter. Handle N_Function_Call, + N_Procedure_Call_Statement and N_Indexed_Component. + (Pragma_to_gnu): Translate inspection_point to an asm statement + containaing a comment and a reference to the object (either its address + for BLKmode or its value). + (Identifier_to_gnu): Use TREE_CONSTANT instead of CONST_DECL to decide + to go to DECL_INITIAL. Together with the size constraint relaxation + in create_var_decl, enlarges the set of situations in which an + identifier may be used as an initializer without implying elaboration + code. + (Subprogram_Body_to_gnu): Do not fiddle with the debug interface but set + DECL_IGNORED_P on the function if Needs_Debug_Info is not set on the + node. + (maybe_stabilize_reference): Remove lvalues_only parameter. + (gnat_stabilize_reference): Adjust for above change. + (gnat_to_gnu): Do not set location information on the result + if it is a reference. + (add_cleanup): Add gnat_node parameter and set the location of the + cleanup to it. + (Handled_Sequence_Of_Statements_to_gnu): Adjust calls to add_cleanup. + (Exception_Handler_to_gnu_zcx): Likewise. + (gigi): Remove the cgraph node if the elaboration procedure is empty. + (Subprogram_Body_to_gnu): If a stub is attached to the subprogram, emit + the former right after the latter. + (start_stmt_group): Make global. + (end_stmt_group): Likewise. + (gnu_constraint_error_label_stack, gnu_storage_error_label_stack): New + vars. + (gnu_program_error_label_stack): Likewise. + (gigi): Initialize them. + (call_to_gnu, gnat_to_gnu, emit_check): Add new arg to build_call_raise. + (gnat_to_gnu, N_{Push,Pop}_{Constraint,Storage,Program}_Error_Label): + New cases. + (push_exception_label_stack): New function. + (takes_address): New function. + + * utils.c (struct language_function): Move to trans.c from here. + (unchecked_convert): Do not wrap up integer constants in + VIEW_CONVERT_EXPRs. + (create_var_decl_1): Decouple TREE_CONSTANT from CONST_DECL. Prevent + the latter for aggregate types, unexpected by later passes, and relax an + arbitrary size constraint on the former. + (create_field_decl): Use tree_int_cst_equal instead of operand_equal_p + to compare the sizes. + (convert_vms_descriptor): When converting to a fat pointer type, be + prepared for a S descriptor at runtime in spite of a SB specification. + (shift_unc_components_for_thin_pointers): New function. + (write_record_type_debug_info): For variable-sized fields, cap the + alignment of the pointer to the computed alignment. + (finish_record_type): Change HAS_REP parameter into REP_LEVEL. + If REP_LEVEL is 2, do not compute the sizes. + (build_vms_descriptor): Adjust for new prototype of finish_record_type. + (build_unc_object_type): Likewise. + (declare_debug_type): New function. + + * ada-tree.def: USE_STMT: removed (not emitted anymore). + + * misc.c (gnat_expand_expr): Call to gnat_expand_stmt removed because + no statement is expandable anymore. + (gnat_init_gcc_eh): Do not initialize the DWARF-2 CFI machinery twice. + (gnat_handle_option): Only allow flag_eliminate_debug_types to be set + when the user requested it explicitely. + (gnat_post_options): By default, set flag_eliminate_unused_debug_types + to 0 for Ada. + (get_alias_set): Return alias set 0 for a type if + TYPE_UNIVERSAL_ALIASING_P is set on its main variant. + + * ada-tree.h: (TYPE_UNIVERSAL_ALIASING_P): New macro. + (DECL_FUNCTION_STUB): New accessor macro. + (SET_DECL_FUNCTION_STUB): New setter macro. + + * lang.opt (feliminate-unused-debug-types): Intercept this flag for Ada. + + * fe.h (Get_Local_Raise_Call_Entity, Get_RT_Exception_Entity): New + declarations. + +2007-06-06 Jose Ruiz + + * s-intman-vxworks.ads, s-intman-vxworks.adb (Abort_Task_Signal): + Rename to Abort_Task_Interrupt to be able to keep the same interface + as the rest of the targets. + + * s-osinte-vxworks.ads s-osinte-vxworks.adb + (To_VxWorks_Priority): Remove explicit "in" mode indicator + + * s-osinte-vxworks6.ads, s-vxwork-arm.ads, system-vxworks-arm.ads: + New files. + +2007-06-06 Robert Dewar + + * a-chahan.ads: Remove obsolescent pragmas + + * a-chlat1.ads: Minor reformatting + +2007-06-06 Robert Dewar + + * comperr.adb (Compiler_Abort): New Finalize/Output_Messages interface + for Errout + + * errout.adb: New Finalize/Compilation_Errors/Output_Messages + implementation + + * errout.ads (Finalize): Changed interface + (Output_Messages): New procedure + (Compilation_Errors): New Interface + + * prepcomp.ads, prepcomp.adb (Parse_Preprocessing_Data_File): New + Finalize/Output_Messages interface for Errout + (Prepare_To_Preprocess): New Finalize/Output_Messages interface for + Errout. + +2007-06-06 Thomas Quinot + Olivier Hainque + Robert Dewar + + * a-except.ads, a-except.adb: (Rmsg_28): Fix description for E.4(18) + check. + (Raise_Current_Excep): Call Debug_Raise_Exception just before + propagation starts, to let debuggers know about the event in a reliable + fashion. + (Local_Raise): Moved to System.Exceptions + More convenient to have this as a separate unit + + * s-except.adb, s-except.ads: New files. + + * a-exextr.adb (Unhandled_Exception): Delete - replaced by + Debug_Unhandled_Exception in System.Exceptions where it belongs + together with a couple of other debug helpers. + (Notify_Unhandled_Exception): Use Debug_Unhandled_Exception instead of + the former Unhandled_Exception. + + * exp_ch11.ads, exp_ch11.adb: (Possible_Local_Raise): New procedure + (Warn_No_Exception_Propagation): New procedure + (Warn_If_No_Propagation): Rewritten for new warning generation + (Expand_Exception_Handlers): New warning generation + (Expand_N_Raise_xxx_Error): Rewritten for new warnings + (Add_Exception_Label): Use Special_Exception_Package_Used for test + instead of Most_Recent_Exception_Used (accomodates Exception_Traces) + (Expand_Local_Exception_Handlers): Unconditionally add extra block wrap + even if restriction is set (makes life easier in Check_Returns) + (Expand_Local_Exception_Handlers): Follow renamed entity chain when + checking exception identities. + (Expand_Local_Exception_Handlers): Do not optimize when all others case + (Expand_Local_Exception_Handlers): Set Exception_Junk flag on generated + block for handler (used by Check_Returns) + (Expand_Local_Exception_Handlers): Local_Raise now takes an address + (Expand_N_Handled_Sequence_Of_Statements): Properly handle -gnatd.x to + remove all exception handlers when optimizing local raise statements. + (Find_Local_Handler): Use Get_Renamed_Entity + (Expand_N_Handled_Sequence_Of_Statements): If the handled sequence is + marked analyzed after expanding exception handlers, do not generate + redundant cleanup actions, because they have been constructed already. + +2007-06-06 Thomas Quinot + + * a-finali.ads (Ada.Finalization): Add missing pragma Remote_Types. The + presence of this categorization pragma is mandated by the language. + (Limited_Controlled): Add missing pragma Preelaborable_Initialization + for this type. + +2007-06-06 Vincent Celier + Robert Dewar + + * bcheck.adb, binde.adb, binderr.adb, binderr.ads, butil.adb, + butil.ads, erroutc.adb, erroutc.ads, errutil.adb, errutil.ads, + err_vars.ads, exp_tss.adb, exp_tss.ads, fmap.adb, fmap.ads, + fname.adb, fname.ads, fname-sf.adb, fname-uf.adb, fname-uf.ads, + lib-sort.adb, lib-util.adb, lib-util.ads, lib-xref.adb, makeutl.ads, + makeutl.adb, nmake.adt, osint.adb, osint.ads, osint-b.adb, + par-load.adb, prj-attr.adb, prj-dect.adb, prj-err.adb, prj-makr.adb, + prj-part.adb, prj-pp.adb, prj-proc.adb, prj-tree.adb, prj-tree.ads, + prj-util.adb, prj-util.ads, scans.adb, scans.ads, sem_ch2.adb, + sinput-c.adb, styleg-c.adb, tempdir.adb, tempdir.ads, uname.adb, + uname.ads, atree.h, atree.ads, atree.adb, ali-util.ads, ali-util.adb, + ali.ads, ali.adb: + Move Name_Id, File_Name_Type and Unit_Name_Type from package Types to + package Namet. Make File_Name_Type and Unit_Name_Type types derived from + Mame_Id. Add new type Path_Name_Type, also derived from Name_Id. + Use variables of types File_Name_Type and Unit_Name_Type in error + messages. + (Get_Name): Add parameter Ignore_Special, and set it reading file name + (New_Copy): When debugging the compiler, call New_Node_Debugging_Output + here. + Define flags Flag217-Flag230 with associated subprograms + (Flag_Word5): New record type. + (Flag_Word5_Ptr): New access type. + (To_Flag_Word5): New unchecked conversion. + (To_Flag_Word5_Ptr): Likewise. + (Flag216): New function. + (Set_Flag216): New procedure. + +2007-06-06 Arnaud Charlet + + * a-stzunb.adb, a-stwiun.adb, a-strunb.adb: (Insert): Use 'Length + instead of 'Size. + + * a-stwifi.ads, a-stzfix.ads: Minor reformatting + +2007-06-06 Javier Miranda + + * a-tags.ads, a-tags.adb (Tag_Size): This constant is now internal to + the package. + (Object_Specific_Data_Array): This is now internal to the package. + (Object_Specific_Data): This is now internal to the package. + (Select_Specific_Data_Element): This is now internal to the package. + (Select_Specific_Data_Array): This is now internal to the package. + (Select_Specific_Data): This is now internal to the package. + (Offset_To_Top_Function_Ptr): This is now public. + (To_Offset_To_Top_Function_Ptr): Removed. + (Storage_Offset_Ptr,To_Storage_Offset_Ptr): These declarations are now + local to subprogram Offset_To_Top. + (Predefined_DT): Removed. + (Typeinfo_Ptr): Removed. + (OSD): This function is now internal to this package. + (SSD): This function is now internal to this package. + (DT): New function that displaces the pointer to the table of primitives + to get access to the enclosing wrapper record. + (IW_Membership): Code cleanup. + (Offset_To_Top): Code cleanup. + (Predefined_DT): Removed. + (Register_Interface_Tag): Removed. + (Set_Interface_Table): Removed. + (Set_Offset_Index): Removed. + (Set_Offset_To_Top): Code cleanup. + (Set_OSD): Removed. + (Set_Signature): Removed. + (Set_SSD): Removed. + (Set_Tagged_Kind): Removed. + (Typeinfo_Ptr): Removed. + (TSD): Removed. + (Displace): Add missing check on null actual. + + * exp_disp.ads, exp_disp.adb + (Select_Expansion_Utilities): Removed. + (Build_Common_Dispatching_Select_Statements): Moved to exp_atags. + (Expand_Dispatching_Call): Update calls to Get_Prim_Op_Address because + the interface requires a new parameter. + (Make_Disp_Asynchronous_Select_Spec, Make_Disp_Conditional_Select_Spec, + Make_Disp_Get_Prim_Op_Kind_Spec, Make_Disp_Timed_Select_Spec): Replace + calls to subprograms Build_T, Build_S, etc. by the corresponding code. + Done to remove package Select_Expansion_Utilities. + (Make_DT): New implementation for statically allocated dispatch tables. + (Make_Secondary_DT): Moved to the scope of Make_DT. + (Register_Primitive): Code cleanup plus incoporate the use of the new + function DT_Address_Attribute. + (Expand_Interface_Thunk): The profile of this subprogram has been + changed to return the Thunk_Id and the corresponding code. + (Fill_DT_Entry): Removed. Its functionality is now provided by + subprogram Register_Primitive. + (Fill_Secondary_DT_Entry): Removed. Its functionality is now provided by + subprogram Register_Primitive. + (Register_Primitive): New subprogram that incorporates the previous + functionalities of Fill_DT_Entry and Fill_Secondary_DT_Entry. + (Build_Common_Dispatching_Select_Statements): Remove formal Typ. This + was only required to call Make_DT_Access_Action, which is now removed. + (Ada_Actions): Removed + (Action_Is_Proc): Removed + (Action_Nb_Arg): Removed + Replace all the calls to Make_DT_Access_Action by direct calls to + Make_Procedure_Call_Statement or Make_Function_Call. + (Set_DTC_Entity_Value): New subprogram. + (Set_All_DT_Position): Add call to new subprogram Set_DTC_Entity_Value. + (Expand_Interface_Thunk): Add missing support for primitives that are + functions with a controlling result (case in which there is no need + to generate the thunk). + + * exp_atag.ads, exp_atag.adb + (Build_DT): New subprogram that displaces the pointer to reference the + base of the wrapper record. + (Build_Typeinfo_Offset): Removed. + (RTE_Tag_Node): Removed. + (Build_Common_Dispatching_Select_Statements): Moved here from exp_disp + (Build_Get_RC_Offset): Removed. + (Build_Inherit_Predefined_Prims): Removed. + (Build_Inherit_TSD: Removed. + (Build_New_TSD): Removed. + (Build_Set_External_Tag): Removed. + (Build_Set_Predefined_Prim_Op_Address): Add documentation. + (Build_Set_Prim_Op_Address): Add documentation. + (Build_Set_TSD): Removed. + + * rtsfind.ads, rtsfind.adb + (Load_Fail): If load fails and we are not in configurable run-time + mode, then raise Unrecoverable_Error. + (Text_IO_Kludge): Generate an error message if a run-time library is + not available in a given run-time (ie. zfp run-time). + (RTE_Record_Component): Add code to check that the component we search + for is not found in two records in the given run-time package. + (RE_DT_Offset_To_Top_Size, RE_DT_Predef_Prims_Size): Removed + (RE_DT_Predef_Prims_Offset): New entity + (RE_Static_Offset_To_Top): New entity + (RE_HT_Link): New entity. + (System_Address_Image): Addition of this run-time package. + (RE_Address_Image): New entity. + (RE_Abstract_Interface): Removed. + (RE_Default_Prim_Op_Count): Removed. + (RE_DT_Entry_Size): Removed. + (RE_DT_Min_Prologue_Size): Removed. + (RE_DT_Prologue_Size): Removed. + (RE_Ifaces_Table_Ptr): Removed. + (RE_Interface_Data_Ptr): Removed. + (RE_Type_Specific_Data): Removed. + (RE_Primary_DT): Removed. + (RE_Register_Interface_Tag): Removed. + (RE_Set_Offset_Index): Removed. + (RE_Set_OSD): Removed. + (RE_Set_SSD): Removed. + (RE_Set_Signature): Removed. + (RE_Set_Tagged_Kind): Removed. + (RE_Address_Array): New entity. + (RE_DT): New entity. + (RE_Iface_Tag): New entity. + (RE_Interfaces_Table): New entity. + (RE_No_Dispatch_Table): New entity. + (RE_NDT_Prims_Ptr): New entity. + (RE_NDT_TSD): New entity. + (RE_Num_Prims): New entity. + (RE_Offset_To_Top_Function_Ptr): New entity. + (RE_OSD_Table): New entity. + (RE_OSD_Num_Prims): New entity. + (RE_Predef_Prims): New entity + (RE_Predef_Prims_Table_Ptr): New entity. + (RE_Primary_DT): New entity. + (RE_Signature): New entity. + (RE_SSD): New entity. + (RE_TSD): New entity. + (RE_Type_Specific_Data): New entity. + (RE_Tag_Kind): New entity. + +2007-06-06 Thomas Quinot + + * a-textio.ads, a-textio.adb (Write): Add explicit size clause for the + C imported variable. + (Skip_Line): Do not reset Before_LM_PM immediately when Before_LM is set + on entry. + +2007-06-06 Robert Dewar + + * a-tienio.adb (Get): Adjust buffer size to accomodate one extra + character + +2007-06-06 Vincent Celier + + * a-tifiio.adb (Put, internal): For negative numbers, check that there + is room for at least one digit and the minus sign. + (Put.Put_Character): Never put a character outside of the range of + string To. + +2007-06-06 Olivier Hainque + Eric Botcazou + + * utils2.c (build_allocator): Provide the extra arguments to + make_aligning_type for super-aligned objects allocated from the default + pool. Leave enough room for a pointer before the aligning field, and + store the system's allocator return value there. + (build_call_alloc_dealloc): When releasing a super-aligned object, + retrieve the system's allocator return value from where build_allocator + has stored it, just ahead of the adjusted address we are passed. + (build_call_raise): Handle properly the generation of line numbers when + the node is marked No_Location. + (compare_elmt_bitpos): Use tree_int_cst_compare. Stabilize the sort + by using DECL_UID on ties. + (build_binary_op) : Accept fat pointer types with the same + main variant. + (build_call_raise): Handle converting exception into goto; support new + argument KIND. + (build_component_ref): Add new arg to build_call_raise. + +2007-06-06 Hristian Kirtchev + + * a-ztflau.adb, a-wtflau.adb, a-tiflau.adb (Load_Real): Do not parse + "." in the case of nnn.xxx when nnn terminates with an underscore. + Parse the remaining "#" or ":" in the case of nnn#.xxx# + +2007-06-06 Robert Dewar + + * a-tigeau.ads, a-tigeau.adb: (Store_Char): Change Buf to IN OUT + +2007-06-06 Arnaud Charlet + Vincent Celier + Robert Dewar + + * bindgen.adb (Gen_Output_File_Ada): Generate pragma No_Run_Time when + needed. + (Gen_Output_File_Ada, Gen_Output_File_C): Never use __attribute + ((destructor)) for adafinal, even when switch -a is used. + Do not issue pragma Linker_Destructor for adafinal when switch -a is + used. + (Gen_Object_Files_Options): Add formatting of Linker Options, when + Output_Linker_Option_List is set. Suppress this formatting when + Zero_Formatting is set. + Add case for CLI_Target. + (System_Restrictions_Used): New flag, used to avoid generating with of + System_Restrictions and initialization of the data unless there is + some use of System.Restrictions in the partition. + (Check_System_Restrictions_Used): New procedure + + * s-stalib.adb: Remove with of System.Restrictions. No longer needed + since we only with this unit in the binder file if it is used elsewhere + in the partition. + +2007-06-06 Vincent Celier + + * bindusg.adb: Add line for @ + Add lines for new switches -R and -Z + + * gnatbind.adb (Gnatbind): Do not include sources from the GNAT + hierarchy in the list of files of the closure when -R is used + (Gnatbind): Accept arguments starting with '@' to indicate response + files and take the arguments from the response files. + If List_Closure is set, display the referenced files + +2007-06-06 Javier Miranda + Robert Dewar + Ed Schonberg + + * checks.ads, checks.adb (Apply_Address_Clause_Check): Handle case in + which the address-clause is applied to in-mode actuals (allowed by + 13.1(22)). + (Apply_Discriminant_Check): Do not generate a check if the type is + constrained by a current instance. + (Activate_Division_Check): New procedure + (Activate_Overflow_Check): New procedure + (Activate_Range_Check): New procedure + Call these new Activate procedures instead of setting flags directly + (Apply_Array_Size_Check): Removed, no longer needed. + Code clean up: remove obsolete code related to GCC 2. + (Get_E_Length): Protect against bomb in case scope is standard + (Selected_Range_Checks): If the node to be checked is a conversion to + an unconstrained array type, and the expression is a slice, use the + bounds of the slice to construct the required constraint checks. + Improve NOT NULL error messages + (Apply_Constraint_Check): If the context is a null-excluding access + type, diagnose properly the literal null. + +2007-06-06 Pascal Obry + + * clean.adb (Clean_Archive): Use untouched casing for the archive name + and the corresponding .deps file. + (Clean_Interface_Copy_Directory): Use untouched casing for the library + src directory. Minor code-clean-up. Use untouched casing for files + read into the library src dir. + (Clean_Library_Directory): Idem. + (Parse_Cmd_Line): Accept new switch -aP + +2007-06-06 Javier Miranda + Ed Schonberg + Robert Dewar + Eric Botcazou + Arnaud Charlet + + * einfo.ads, einfo.adb (Available_View): New synthesized attribute + applicable to types that have the With_Type flag set. Returns the + non-limited view of the type, if available, otherwise the type itself. + For class-wide types, there is no direct link in the tree, so we have + to retrieve the class-wide type of the non-limited view of the Etype. + New attributes Static_Initialization and Static_Elaboration_Desired. + Remove the pragma Thread_Body, and the associated flag + Is_Thread_Body in entities, and all related code. + (Suppress_Value_Tracking_On_Call): New flag + E_Exception has Esize and Alignment fields + (Universal_Aliasing): New function. + (Set_Universal_Aliasing): New procedure. + (Write_Entity_Flags): Deal with Universal_Aliasing flag. + (Check_Nested_Access): New procedure. + (Has_Up_Level_Access, Set_Has_Up_Level_Access): New procedures. + (Find_Direct_Name, Note_Possible_Modification): Use Check_Nested_Access. + (Related_Interface): New attribute. Present in dispatch table pointer + components of records. Set to point to the entity of the corresponding + interface type. + (Is_By_Reference_Type): Recurse on the full view of an incomplete type. + (Original_Access_Type): Remove, not needed. + (Root_Type): Handle properly subtypes of class-wide-types. + Update comments. + + * sem_ch4.adb (Analyze_Explicit_Dereference): Add support for + class-wide types visible through limited-with clauses. + (Try_Primitive_Operation): When examining all primitive operations of a + tagged type, do not consider subprograms labeled as hidden unless they + belong to a private generic type with a tagged parent. + (Try_Object_Operation): Extensive rewriting, to handle properly various + overloading cases, when several ancestors may have class-wide operations + that are possible candidates, and when the overloaded functions return + array types and have defaulted parameters so that the call may be + interpreted as an indexing. + (Analyze_Allocator): Remove Mark_Allocator and its invocation. + (Process_Function_Call): use Next, rather than Next_Actual, to analyze + successive actuals before analyzing the call itself. + (Try_Primitive_Operation): A primitive operation is compatible with the + prefix if the prefix has a synchronized type and the type of the formal + is its corresponding record, as can be the case when the primitive + operation is declared outside of the body of the type. + (Traverse_Homonyms): New subprocedure of Try_Class_Wide_Operation, to + perform homonym traversal, looking for class-wide operation matches + (formerly done in statements of Try_Class_Wide_Operation). Matches on + access parameters are now restricted to anonymous access types. + (Mark_Allocator): An allocator with a discriminant association parent is + a coextension. + (Try_One_Prefix_Interpretation): If the type of the object is + incomplete, as can be happen when it is a limited view obtained through + a limited_with_clause, the selected component is not part of a prefixed + call. + (Complete_Object_Operation): Diagnose properly an object that is not + aliased when the corresponding controlling formal is an access + parameter. + (Try_Primitive_Operation, Try_Class_Wide_Operation): Diagnose properly + ambiguous calls in prefixed notation, where two primitives differ only + in that the controlling argument of one is an access parameter. + + * sem_ch6.adb (Has_Single_Return): Add guard in code that determines + whether a function that returns an unconstrained type can be inlined. + (Process_Formals): Diagnose properly the illegal use of an incomplete + type in the profile of an access_to_subprogram declaration. + (Check_Synchronized_Overriding): Nothing check for concurrent types, the + operations are attached to the corresponding record. + (Analyze_Subprogram_Specification): Add variables Formal and Formal_Typ. + When processing a primitive of a concurrent type which implements an + interface change the type of all controlling formals to that of the + corresponding record type. + (Check_Synchronized_Overriding): Relax the conditional logic when trying + to determine the tagged type to which a primitive belongs. + (Check_Conventions): Capture condition to ignore a primitive operation + (which is shared between the loop in Check_Conventions and the one in + Check_Convention) in a new local function Skip_Check. + (Check_Convention): Rename Prim_Op to Second_Prim_Op to avoid possible + confusion with Check_Conventions' own Prim_Op local variable. + (Create_Extra_Formals): Test for a tagged result type rather than a + controlling result when determining whether to add a BIP_Alloc_Form + formal and a BIP_Final_List formal to the function. + (Check_Conformance); For parameters that are anonymous access types, + subtype conformance requires that the not null and the constant + indicators must match + (Check_Synchronized_Overriding): New parameter Formal_Typ. Add machinery + to retrieve the appropriate type when processing a concurrent type + declared within a generic. Minor comment reformatting. Change invocation + of Overrides_Synchronized_Primitive to Find_Overridden_Synchronized_Pri- + mitive. + (Analyze_Subprogram_Body): If the return type of a function is an + anonymous access to the limited view of a class-wide type, and the + non-limited view of the type is available, update the type of the + function so that code can be generated. + (Process_Formals): In case of access-subtype itype whose designated + type is also an itype (situation that happens now with access to + subprograms) we mark the access-type itype with the Has_Delayed_Freeze + attribute to avoid backend problems. + (Check_Return_Subtype_Indication): Replace R_Type with R_Stm_Type in + init of R_Stm_Type_Is_Anon_Access. Also check that base types of the + anonymous types' designated types are same before testing + Subtypes_Statically_Match. + (Create_Extra_Formals): Test for a named access parameter that is a + controlling formal as an additional condition for adding an + accessibility level formal. This can occur in the subp type created for + dispatching calls in Expand_Dispatching_Call, and allows calling + Create_Extra_Formals from that procedure rather than special-casing the + extra formals there. + (Create_Extra_Formals): Add BIP_Alloc_Form and BIP_Final_List formals + when the function has a controlling result. + (Check_Returns): Add much more knowledge of the optimization of local + raise statements to gotos, to retain proper warnings in this case. + (Check_Statement_Sequence): Ignore N_Push_xxx_Label and N_Pop_xxx_Label + nodes when looking for last statement. + + * sem_type.ads, sem_type.adb (Specific_Type): Add support for + class-wide types visible through limited with clauses. + (Add_One_Interp): If the operands are anonymous access types, the + predefined operator on universal_access is immediately visibles + (Find_Unique_Type): Handle anonymous access to subprogram types just as + other anonymous access types. + (Disambiguate): Take into account CIL convention. + (Interface_Present_In_Ancestor): Add support for class-wide interfaces. + +2007-06-06 Robert Dewar + + * sinput.ads, sinput.adb, uintp.ads, urealp.adb, stringt.adb, + sem_elim.adb, prj-strt.adb, repinfo.ads, repinfo.adb, namet.ads, + elists.ads, elists.adb, lib.ads, lib.adb (Unlock): New procedure. + Fix lower bound of tables. + Add rep clauses. + + * nlists.adb: Ditto. + (Prev_Node, Next_Node): Change index type to Int so that it properly + covers the range First_Node_Id - 1 up. + +2007-06-06 Javier Miranda + Ed Schonberg + Bob Duff + Hristian Kirtchev + + * exp_aggr.ads, exp_aggr.adb: + (Build_Record_Aggr_Code): Add missing initialization of secondary tags + in extension aggregates. + (Flatten): Other conditions being met, an aggregate is static if the + low bound given by component associations is different from the low + bound of the base index type. + (Packed_Array_Aggregate_Handled): If the component type is itself a + packed array or record, the front-end must expand into assignments. + (Gen_Ctrl_Actions_For_Aggr): In call to Init_Controller, pass False to + Init_Pr, instead of Ancestor_Is_Expression. + (Gen_Ctrl_Actions_For_Aggr): When processing an aggregate of a + coextension chain root, either generate a list controller or use the + already existing one. + (Static_Array_Aggregate): New procedure to construct a positional + aggregate that can be handled by the backend, when all bounds and + components are compile-time known constants. + (Expand_Record_Aggregate): Force conversion of aggregates of tagged + types covering interface types into assignments. + (Replace_Type): move to Build_Record_Aggr_Code. + (Expand_Record_Aggr_Code): if the target of the aggregate is an + interface type, convert to the definite type of the aggregate itself, + so that needed components are visible. + (Convert_Aggr_In_Object_Decl): If the aggregate has controlled + components and the context is an extended return statement do not + create a transient block for it, to prevent premature finalization + before the return is executed. + (Gen_Assign): Do not generate a call to deep adjust routine if the + component type is itself an array of controlled (sub)-components + initialized with an inner aggregate. + (Component_Check): New name for Static_Check. This name is now more + appropriate, and documentation is added which was missing. + (Component_Check): Add test for bit aligned component value + (Component_Not_OK_For_Backend): Renames Has_Delayed_Nested_Aggregate_Or_ + Tagged_Comps, name is more appropriate given added function below. + (Component_Not_OK_For_Backend): Check for bit aligned component ref. + +2007-06-06 Hristian Kirtchev + Javier Miranda + Robert Dewar + + * exp_attr.adb (Expand_N_Attribute_Reference): Case Callable and + Terminated: Add unchecked type conversion from System.Address to + System.Tasking.Task_Id when calling the predefined primitive + _disp_get_task_id. + Disable new Ada 05 accessibility check for JVM.NET targets, which + cannot be implemented in a practical way. + (Expand_N_Attribute_Reference: case Attribute_Tag): The use of 'Tag in + the sources always references the tag of the actual object. Therefore, + if 'Tag is applied in the sources to class-wide interface objects we + generate code that displaces "this" to reference the base of the object. + (Expand_N_Attribute_Reference, case Size): Return specified size if + known to front end. + (Expand_N_Attribute_Reference): The expansion of the 'Address attribute + has code that displaces the pointer of the object to manage interface + types. However this code must not be executed when the prefix is a + subprogram. This bug caused the wrong expansion of the internally + generated assignment that fills the dispatch table when the primitive + is a function returning a class-wide interface type. + (Expand_N_Attribute_Reference:Attribute_Valid): Remove incorrect call to + Set_Attribute_Name for Name_Unaligned_Valid. + +2007-06-06 Ed Schonberg + Gary Dismukes + + * exp_ch13.adb (Expand_N_Attribute_Definition_Clause, case 'Address): + If the initialization is the equivalent aggregate of the initialization + procedure of the type, do not remove it. + (Expand_N_Attribute_Definition_Clause): Exclude access variables + initialized to null from having their expression reset to empty and + note this exception in the comment. + +2007-06-06 Hristian Kirtchev + Robert Dewar + Ed Schonberg + Gary Dismukes + + * exp_ch2.adb: Remove "with" and "use" clauses for Namet and Snames. + Add "with" and "use" clauses for Sem_Attr. + (Expand_Current_Value): Do not replace occurences of attribute + references where the prefix must be a simple name. + + * sem_attr.ads, sem_attr.adb: Remove "with" and "use" clauses for + Namet. Add new arrays Attribute_Name_Modifies_Prefix and + Attribute_Requires_Simple_Name_Prefix. + (Name_Modifies_Prefix): Body of new function. + (Requires_Simple_Name_Prefix): Body of new function. + (Resolve_Attribute, case Access): Improve error message for case of + mismatched conventions. + (Analyze_Attribute, case 'Tag): The prefix the attribute cannot be of an + incomplete type. + (Analyze_Attribute, case 'Access): If the type of the prefix is a + constrained subtype for a nominal unconstrained type, use its base type + to check for conformance with the context. + (Resolve_Attribute): Remove test of the access type being associated + with a return statement from condition for performing accessibility + checks on access attributes, since this case is now captured by + Is_Local_Anonymous_Access. + (Analyze_Access_Attribute): Set Address_Taken on entity + (Analyze_Attribute, case Address): Set Address_Taken on entity + (OK_Self_Reference): Traverse tree to locate enclosing aggregate when + validating an access attribute whose prefix is a current instance. + (Resolve_Attribute): In case of attributes 'Code_Address and 'Address + applied to dispatching operations, if freezing is required then we set + the attribute Has_Delayed_Freeze in the prefix's entity. + (Check_Local_Access): Set flag Suppress_Value_Tracking_On_Call in + current scope if access of local subprogram taken + (Analyze_Access_Attribute): Check legality of self-reference even if the + expression comes from source, as when a single component association in + an aggregate has a box association. + (Resolve_Attribute, case 'Access): Do not apply accessibility checks to + the prefix if it is a protected operation and the attribute is + Unrestricted_Access. + (Resolve_Attribute, case 'Access): Set the Etype of the attribute + reference to the base type of the context, to force a constraint check + when the context is an access subtype with an explicit constraint. + (Analyze_Attribute, case 'Class): If the prefix is an interface and the + node is rewritten as an interface conversion. leave unanalyzed after + resolution, to ensure that type checking against the context will take + place. + +2007-06-06 Ed Schonberg + Javier Miranda + Robert Dewar + + * exp_ch3.adb (Make_Controlling_Function_Wrappers): generate wrapper a + wrapper when the full view of the controlling type of an inherited + function that dispatches on result implements interfaces. + (Expand_N_Object_Declaration): In cases where the type of the + declaration is anonymous access, create finalization list for it. + (Expand_N_Object_Declaration): Generate a persistent_bss directive only + if the object has no explicit initialization, to match description of + functionality of pragam Persistent_BSS. + (Build_Equivalent_Array_Aggregate, Build_Equivalent_Record_Aggregate): + new function to build static aggregates, to replace initialization call + when static initialization is desired. + (Freeze_Type): Generate a list controller for an access type whenever + its designated type has controlled anonymous access discriminants. + (Build_Equivalent_Aggregate): New procedure to compute a static + aggregate to be used as default initialization for composite types, + instead of a generating a call to the initialization procedure for the + type. + (Build_Initialization_Call): When available, replace a call to the + initialization procedure with a copy of the equivalent static aggregate + for the type. + (Expand_N_Object_Declaration): Use New_Occurrence_Of in generated + declarations for objects of a class-wide interface type, rather than + just identifiers, to prevent visibility problems. + (Expand_N_Object_Declaration): When expanding the declaration for an + object of a class-wide interface type, preserve the homonym chain of + the original entity before exchanging it with that of the generated + renaming declaration. + (Freeze_Enumeration_Type): Don't raise CE if No_Exception_Propagation + active, because there is no way to handle the exception. + (Freeze_Record_Type): In case of CPP_Class types add a call to Make_DT + to do a minimum decoration of the Access_Disp_Table list. + (Expand_Record_Controller): Avoid the addition of the controller between + the component containing the tag of a secondary dispatch table and its + adjacent component that stores the offset to the base of the object. + This latter component is only generated when the parent type has + discriminants ---documented in Add_Interface_Tag_Components). + (Apply_Array_Size_Check): Removed, no longer needed. + (Expand_N_Full_Type_Declaration): If the type has anonymous access + components, create a Master_Entity for it only if it contains tasks. + (Build_Init_Procedure): Suppress the tag assignment compiling under + no run-time mode. + (Freeze_Record_Type): Remove code associated with creation of dispatch + table. + (Init_Secondary_Tags): Update type of actuals when generating calls to + Ada.Tags.Set_Offset_To_Top + (Stream_Operation_OK): Disable use of streams compiling under no + run-time mode + (Expand_N_Object_Declaration): Don't do Initialize_Scalars initalization + if Has_Init_Expression set. + (Build_Init_Procedure): Replace call to Fill_DT_Entry by call to + Register_Primitive, which provides the same functionality. + (Requires_Init_Proc): Return false in case of interface types. + (Add_Secondary_Tables): Use the new attribute Related_Interface to + cleanup the code. + (Predefined_Primitive_Freeze): Do not assume that an internal entity + is always associated with a predefined primitive because the internal + entities associated with interface types are not predefined primitives. + Therefore, the call to Is_Internal is replaced by a call to the + function Is_Predefined_Dispatching_Operation. + (Make_Eq_If): When generating the list of comparisons for the + components of a given variant, omit the controller component that is + present if the variant has controlled components. + +2007-06-06 Javier Miranda + Hristian Kirtchev + Bob Duff + + * exp_ch4.adb (Complete_Coextension_Finalization): Add machinery to + handle the creation of finalization lists and calls for nested + coextensions when the root of the chains is part of a return statement. + (Inside_A_Return_Statement): New function inside Complete_Coextension_ + Finalization. + (Expand_Record_Equality): Skip components that are interface types. + (Displace_Allocator_Pointer): Add missing support for interface subtypes + (Expand_N_Allocator): Replace invocation of Is_Local_Access_Discriminant + with Rewrite_Coextension. Change the condition for detecting coextension + root nodes. + (Is_Local_Access_Discriminant): Removed. + (Rewrite_Coextension): New routine which rewrites a static coextension + as a temporary and uses its unrestricted access in the construction of + the outer object. + (Complete_Coextension_Finalization): New routine. Generate finalization + attachment calls to all delayed coextensions. + (Expand_N_Allocator): Call Complete_Coextension_Finalization whenever + the allocator is not a coextension itself and has delayed coextensions. + If the current allocator is controlled, but also a coextension, delay + the generation of the finalization attachment call. + Rename local variable "Node" to "Nod" in order to avoid confusion with + "Elists.Node". + (Expand_Allocator_Expression): Call Adjust for initialized allocators of + limited types that are not inherently limited. Such an allocator is + illegal, but is generated by the expander for a return statement, to + copy the result onto the secondary stack. This is the only case where a + limited object can be copied. Generate code to displace the pointer + to the object if the qualified expression is a class-wide interface + object. Such displacement was missing and hence the copy of the object + was wrong. + (Apply_Accessibility_Check): Handle allocated objects initialized in + place. + (Displace_Allocator_Pointer): Subsidiary procedure to Expand_N_Allocator + and Expand_Allocator_Expression. Allocating class-wide interface objects + this routine displaces the pointer to the allocated object to reference + the component referencing the corresponding secondary dispatch table. + Expand_Allocator_Expression): Add missing support to allocate class-wide + interface objects initialized with a qualified expression. + (Get_Allocator_Final_List): Test for an anonymous access type that is a + function result type, and use the finalization list associated with the + function scope in that case (such an anonymous type should not be + treated like an access parameter's type). + +2007-06-06 Ed Schonberg + Gary Dismukes + Javier Miranda + + * exp_ch5.adb (Expand_N_Assignment_Statement): For the assignment of a + controlled type, use Make_Handler_For_Ctrl_Operation to construct the + required exception handler. + (Expand_Simple_Function_Return, Expand_N_Return_Statement): Handle + properly the case of a function whose return type is a limited + class-wide interface type. Modify the code of the accessibility + check to handle class-wide interface objects. In this case we need to + displace "this" to reference the primary dispatch table to get access + to the TSD of the object (to evaluate its accessibility level). + (Expand_N_Extended_Return_Statement): Test for a tagged result type + rather than a controlling result as one of the conditions for + generating tests of the implicit BIP_Alloc_Form formal. The + initialization assignment is also handled according to whether the + result is tagged instead of controlling. + In the case where the init assignment is inserted in the "then" part of + the allocation conditional, rewrite the target to be a dereference of + the implicit BIP_Object_Access formal. + If the returned value is unconstrained and created on the secondary + stack, mark the enclosing block and function so that the secondary + stack is not reclaimed on return. + Treat returns from functions with controlling results similarly to + returns from functions with unconstrained result subtypes. + If the object returned is unconstrained, and an allocator must be + created for it, analyze the allocator once the block for the extended + return is installed, to ensure that finalizable components + of the expression use the proper finalization list. Guard the call to + Move_Final_List with a check that there is something to finalize. + (Make_Tag_Ctrl_Assignment): Use "old" handling + of controlled type assignment for virtual machines, since new code uses + unsupported features (such as direct access to bytes in memory). + +2007-06-06 Gary Dismukes + Ed Schonberg + + * exp_ch6.ads, exp_ch6.adb (Expand_Call): When adding an extra + accessibility actual, check for the case of an aliased object that has + been rewritten as an Access attribute, and assign Prev to Prev_Orig so + we fall into processing for the attribute rather than the name of the + object. + (Expand_Inline_Call): If an actual is a literal, and the corresponding + formal has its address taken in the body, create a temporary to capture + value. If the return type is a limited interface, do not treat the + return value as Controlled. + (Is_In_Place_Function): If the return type is a limited interface, + treat as returning in place. The actual returned object may not always + be limited, but the caller has to assume that it is returned in place. + (Add_Final_List_Actual_To_Build_In_Place_Call): If the call is the + context of an allocator, use the correct finalization chain (that is, + the chain belonging to the access type, rather than the chain belonging + to the current scope). + (Add_Alloc_Form_Actual_To_Build_In_Place_Call): Test for a tagged + result type rather than a controlling result as a precondition for + adding an allocation form actual to a build-in-place call. + (Add_Final_List_Actual_To_Build_In_Place_Call): Ditto. + (Freeze_Subprogram): Code cleanup. Remove all the code that register the + primitive in the dispatch tables. This work is now done by Make_DT when + the type is frozen. + (Register_Predefined_DT_Entry): Removed. + (Add_Return): If end label is not present, use sloc of last statement + for generated return statement in procedure, for better gdb behavior + on expanded code. + (Add_Access_Actual_To_Build_In_Place_Call): Set parent fields of the + object address nodes to ensure proper processing by routines like + Insert_After*. + (Expand_Call): Fix generation of validity check for parameter + (Add_Alloc_Form_Actual_To_Build_In_Place_Call): Return without passing + the allocation form parameter if the result subtype is constrained, + except when the function has a controlling result. + (Add_Final_List_Actual_To_Build_In_Place_Call): Test Controlled_Type + rather than Is_Controlled and Has_Controlled_Component, since we want to + include class-wide result types in this treatment. Also test for a + controlling result, since that also requires passing a finalization + list. + (Make_Build_In_Place_Call_In_Allocator): Call Add_Alloc_Form_Actual_* + even when the result subtype is constrained, to handle calls involving + controlling results. + (Make_Build_In_Place_Call_In_Anonymous_Context): Add_Alloc_Form_Actual_* + is now called even when the result subtype is constrained, to handle + calls involving controlling results. + (Make_Build_In_Place_Call_In_Assignment): Remove test for Is_Constrained + on call to Add_Alloc_Form_Actual_To_Build_In_Place_Call (that procedure + now performs the test). + (Make_Build_In_Place_Call_In_Object_Declaration): + Add_Alloc_Form_Actual_* is now called even when the result subtype is + constrained, to handle calls involving controlling results. + (Add_Return): Accomodate rewritten pattern from local raise to goto + transformation, so that we still recognize an transfer statement + and do the right thing here in that case. + (Expand_N_Subprogram_Body): Add dummy Push/Pop_xxx_Label nodes at start + and end of subprogram code. + (Register_Interface_DT_Entry, Register_Predefined_DT_Entry): Add missing + support for primitives that are functions (without formals) with a + controlling result. + (Inherited_From_Formal): If the actual subtype has not generic parent + type, it is not an actual for a formal derived type, and there is no + operation to inherit from the formal. + +2007-06-06 Ed Schonberg + Thomas Quinot + + * exp_ch7.ads, exp_ch7.adb (Expand_Cleanup_Actions): Set Sloc of + inserted cleanup code appropriately for GDB use. + (Make_Deep_Proc): Use Make_Handler_For_Ctrl_Operation to create + exception handler for Deep_Adjust or Deep_Finalize. + (Make_Handler_For_Ctrl_Operation): New subprogram. When runtime entity + Raise_From_Controlled_Operation is available, use a call to that + subprogram instead of a plain "raise Program_Error" node to raise + Program_Error if an exception is propagated from an Adjust or Finalize + operation. + (Insert_Actions_In_Scope_Around): If the statement to be wrapped + appears in the optional statement list of a triggering alternative, the + scope actions can be inserted directly there, and not in the list that + includes the asynchronous select itself. + +2007-06-06 Ed Schonberg + Robert Dewar + Hristian Kirtchev + + * exp_ch9.ads, exp_ch9.adb (Build_Protected_Entry): Set sloc of + generated exception handler appropriately when debugging generated code. + Deal properly with No_Exception_Propagation restriction mode. + (Expand_N_Abort_Statement): Add an unchecked type conversion from + System.Address to System.Tasking.Task_Id when processing the result of + the predefined primitive _disp_get_task_id. + (Expand_N_Asynchronous_Select): Clarify comment. + (Expand_N_Protected_Type_Declaration): Minor code cleanup. + (Find_Parameter_Type): New routine inside Type_Conformant_Parameters. + (Type_Conformant_Parameters): New parameter Prim_Op_Typ. Code cleanup. + (Add_Private_Declarations, Build_Protected_Body): Use proper slocs for + privals and for generated call to Complete_Entry_Body, for better gdb + behavior. + (Copy_Result_Type): Utility to construct a parameter and result profile + for protected functions whose return type is an anonymous access to + subprogram. + (Build_Protected_Sub_Spec and Expand_Access_Protected_Subprogram_Type): + call the above. + (Build_Task_Activation_Call): Insert Activate_Tasks call at proper + point when the local-raise-to-goto transformation has taken place. + +2007-06-06 Javier Miranda + Nicolas Setton + + * exp_dbug.adb (Get_Encoded_Name): Modified to continue providing its + functionality when the backend is generating code. + Otherwise any serious error + reported by the backend calling the frontend routine Error_Msg + changes the Compilation_Mode to Check_Semantics, disables the + functionality of this routine and causes the generation of + spureous additional errors. + + * exp_dbug.ads (Pointers to Unconstrained Arrays): Document the + debugging information now generated by the compiler for fat-pointer + types. + Document the contents of DW_AT_producer in the GNAT Vendor extensions to + DWARF2/3. + Document GNAT Vendor extensions to DWARF 2/3 and the "-gdwarf+" switch. + +2007-06-06 Thomas Quinot + + * exp_dist.ads, exp_dist.adb (Make_Transportable_Check): New subprogram + (GARLIC_Support.Build_Subprogram_Receiving_Stubs, + PolyORB_Support.Build_Subprogram_Receiving_Stubs): + For a remote call to a function with a classwide return type, apply an + E.4(18) check to the returned value. + (Add_RACW_Primitive_Declarations_And_Bodies): Do not generate stubs for + stream attributes of the designated type of an RACW, as they are not + dispatching primitive operations. + +2007-06-06 Geert Bosch + + * exp_fixd.adb (Integer_Literal): Add optional argument to construct a + negative literal + (Do_Divide_Fixed_Fixed): Add comments to indicate Frac is always + positive + (Do_Divide_Fixed_Universal): Handle case of negative Frac. + (Do_Multiply_Fixed_Fixed): Add coments to indicate Frac is always + positive + (Do_Multiply_Fixed_Universal): Handle case of negative Frac. + +2007-06-06 Javier Miranda + + * exp_imgv.adb (Expand_Value_Attribute): Disable compilation of this + attribute compiling package Ada.Tags under No_Run_Time_Mode. + +2007-06-06 Javier Miranda + + * exp_intr.adb (Expand_Unc_Deallocation): Add missing support for + deallocation of class-wide interface objects. + (Expand_Dispatching_Constructor_Call): Take into account that if the + result of the dispatching constructor is an interface type, the + function returns a class-wide interface type; otherwise the returned + object would be actual. The frontend previously accepted returning + interface types because Expand_Interface_Actuals silently performed + the management of the returned type "as if" it were a class-wide + interface type. + (Expand_Dispatching_Constructor_Call): Replace call to + Make_DT_Access_Action by direct call to Make_Function_Call. + +2007-06-06 Robert Dewar + Ed Schonberg + + * exp_pakd.adb (Expand_Packed_Not): Use RM_Size rather than ESize to + compute masking constant, since we now set Esize properly to the + underlying size. + (Create_Packed_Array_Type): Set proper Esize value adjusted as required + to match the alignment. + (Create_Packed_Array_Type): Use Short_Short_Unsigned as base type for + packed arrays of 8 bits or less. + + * freeze.adb (Freeze_Entity): When freezing the formals of a + subprogram, freeze the designated type of a parameter of an access type + only if it is an access parameter. + Increase size of C convention enumeration object + (Freeze_Entity, array type case): Make sure Esize value is properly + adjusted for the alignment if it is known. + (Freeze_Entity, array type case): When checking bit packed arrays for + the size being incorrect, check RM_Size, not Esize. + (Freeze_Record_Type): Check for bad discriminated record convention + (In_Exp_Body): Return true if the body is generated for a subprogram + renaming, either an attribute renaming or a renaming as body. + (Check_Itype): If the designated type of an anonymous access component + is a non-protected subprogram type, indicate that it is frozen, to + prevent out-of-scope freeze node at some subsequent call. + (Freeze_Subprogram): On OpenVMS, reject descriptor passing mechanism + only if the subprogram is neither imported nor exported, as well as the + NCA descriptor class if the subprogram is exported. + +2007-06-06 Ed Schonberg + Arnaud Charlet + Robert Dewar + Gary Dismukes + + * exp_prag.adb (Expand_Pragma_Import_Or_Interface): Remove properly a + default initialization on an imported object, when there is no + initialization call generated for it. + (Expand_Pragma_Assert): Add handling of No_Exception_Propagation + restriction + + * snames.h, snames.ads, snames.adb, par-prag.adb: New pragma + Static_Elaboration_Desired. + Remove pragma Thread_Body. + Implement a new pragma No_Body + Removes the Explicit_Overriding pragma + Remove Optional_Overriding pragma + (Prag): Deal with Universal_Aliasing. + (Name_CIL, Name_CIL_Constructor, Convention_CIL, + Pragma_CIL_Constructor): New names. + + * sem_cat.adb (Validate_Object_Declaration): An initialization that + uses the equivalent aggregate of a type must be treated as an implicit + initialization. + (Get_Categorization): Check a unit for pragma Preelaborate only if it + has none of the other categories. + (Process_Import_Or_Interface_Pragma): Report an error for an attempt + to apply Import to an object renaming declaration. + + * sem_prag.adb (Process_Import_Or_Interface): Warn that a type imported + from a C++ class should be declared as limited and that it will be + considererd limited. + (Analyze_Pragma): Warn that a type specified with pragma CPP_Class + should be declared as limited and that it will be considererd limited. + (Ada_2005_Pragma): New procedure, used to deal with Ada 2005 pragmas + (Analyze_Pragma, case Export): Diagnose export of enumeration literal + (Analyze_Pragma): Deal with Universal_Aliasing. + (Sig_Flags): Likewise. + (Set_Encoded_Interface_Name): Suppress encoding when compiling for AAMP. + (Overflow_Checks_Unsuppressed): New flag. + (Process_Suppress_Unsuppress): Set Overflow_Checks_Unsuppressed. + (Analyze_Pragma [case Pack]): Ignore pragma Pack and post warning in + case of JVM or .NET targets, and compiling user code. + Add debugging convenience routine rv + +2007-06-06 Robert Dewar + + * exp_strm.adb (Make_Field_Attributes): Avoid _Parent components that + are interface type. + (Build_Elementary_Input_Call): For floating-point use right type in the + absence of strange size or stream size clauses. + (Build_Elementary_Write_Call): Same fix + (Has_Stream_Standard_Rep): Returns False if Stream_Size attribute + set to value that does not match base type size. + +2007-06-06 Ed Schonberg + + * exp_util.ads, exp_util.adb (Expand_Subtype_From_Expr): In Ada2005, an + object of a limited type can be initialized with a call to a function + that returns in place. If the limited type has unknown discriminants, + and the underlying type is a constrained composite type, build an actual + subtype from the function call, as is done for private types. + (Side_Effect_Free): An expression that is the renaming of an object or + whose prefix is the renaming of a object, is not side-effect free + because it may be assigned through the renaming and its value must be + captured in a temporary. + (Has_Controlled_Coextensions): New routine. + (Expand_Subtype_From_Expr): Do nothing if type is a limited interface, + as is done for other limited types. + (Non_Limited_Designated_Type): new predicate. + (Make_CW_Equivalent_Type): Modified to handle class-wide interface + objects. + Remove all handling of with_type clauses. + + * par-ch10.adb: Remove all handling of with_type clauses. + + * lib-load.ads, lib-load.adb (Load_Main_Source): Do not get the + checksum if the main source could not be parsed. + (Loat_Unit): When processing a child unit, determine properly whether + the parent unit is a renaming when the parent is itself a child unit. + Remove handling of with_type clauses. + + * sinfo.ads, sinfo.adb (Is_Static_Coextension): New function. + (Set_Is_Static_Coextension): New procedure. + (Has_Local_Raise): New function + (Set_Has_Local_Raise): New procedure + (Renaming_Exception): New field + (Has_Init_Expression): New flag + (Delay_Finalize_Attach): Remove because flag is obsolete. + (Set_Delay_Finalize_Attach): Remove because flag is obsolete. + Remove all handling of with_type clauses. + (Exception_Junk): Can now be set in N_Block_Statement + +2007-06-06 Vincent Celier + Robert Dewar + + * frontend.adb (Frontend): Return immediately if the main source could + not be parsed, because of preprocessing errors. + + * gnat1drv.adb (gnat1drv): Handle RE_Not_Available gracefully. + (Gnat1drv): Exit with errors if the main source could not be parsed, + because of preprocessing errors. + (Check_Rep_Info): New procedure + +2007-06-06 Robert Dewar + + * g-hesorg.ads, g-heasor.ads, + g-busorg.ads, g-bubsor.ads: Update documentation + GNAT.Heap/Bubble_Sort_G is now pure + +2007-06-06 Robert Dewar + + * g-catiio.ads, g-catiio.adb (Image): Check for null picture string + +2007-06-06 Robert Dewar + Ed Schonberg + + * g-comlin.ads, g-comlin.adb: + Add new warning for renaming of function return objects + + * opt.adb (Tree_Write, Tree_Read): Use proper expressions for size + (Tree_Read): Use size of object instead of type'object_size, since the + latter is incorrect for packed array types. + (Tree_Write): Same fix + + * opt.ads: Add new warning for renaming of function return objects + (Generating_Code): New boolean variable used to indicate that the + frontend as finished its work and has called the backend to process + the tree and generate the object file. + (GCC_Version): Is now private + (Static_Dispatch_Tables): New constant declaration. + (Overflow_Checks_Unsuppressed): New flag. + (Process_Suppress_Unsuppress): Set Overflow_Checks_Unsuppressed. + (List_Closure): New flag for gnatbind (-R) + Zero_Formatting: New flag for gnatbind (-Z) + (Special_Exception_Package_Used): New flag. + (Warn_On_Unrepped_Components): New flag. + + * sem_ch8.adb (Check_Library_Unit_Renaming): Check that the renamed + unit is a compilation unit, rather than relying on its scope, so that + Standard can be renamed. + (Analyze_Object_Renaming): Add new warning for renaming of function + return objects. + Also reject attempt to rename function return object in Ada 83 mode. + (Attribute_Renaming): In case of tagged types, add the body of the + generated function to the freezing actions of the type. + (Find_Type): A protected type is visible right after the reserved word + "is" is encountered in its type declaration. Set the entity and type + rather than emitting an error message. + (New_Scope): Properly propagate Discard_Names to inner scopes + (Check_Nested_Access): New procedure. + (Has_Nested_Access, Set_Has_Nested_Access): New procedures. + (Find_Direct_Name, Note_Possible_Modification): Use Check_Nested_Access. + + * sem_warn.ads, sem_warn.adb: Improvements to infinite loop warning + Add new warning for renaming of function return objects + (Check_References): Suppress warnings for objects whose type or + base type has Warnings suppressed. + (Set_Dot_Warning_Switch): Add processing for -gnatw.c/C + (Set_Warning_Switch): Include new -gnatwc in -gnatwa + +2007-06-06 Vincent Celier + Emmanuel Briot + Olivier Hainque + + * g-debpoo.ads, g-debpoo.adb (Free_Physically.Free_Blocks): Use the + absolute value of Header.Block_Size when displaying the freed physical + memory in traces. + (Allocate): Compute Storage_Address using Integer_Address, not + Storage_Offset, because the range of Storage_Offset may not be large + enough. + (Configure): New parameter Low_Level_Traces + (Allocate, Deallocation, Free_Physically): Added low-level traces + (Configure): new parameter Errors_To_Stdout. + (Output_File): new subprogram + (Deallocate, Dereference): Send error messages to the proper stream + (Print_Pool, Print_Info_Stdout): Make sure the output goes to stdout, as + documented. Previous code would send it to the current output file + defined in GNAT.IO, which might not be stdout + (Is_Valid): Adjust comment to mention that a positive reply means that + Header_Of may be used to retrieve the allocation header associated with + the subprogram Storage address argument. Return False early if this + address argument is misaligned. + +2007-06-06 Vincent Celier + + * gnatcmd.adb (GNATCmd): Accept switch -aP for commands that accept + switch -P + (ASIS_Main): New global variable + (Get_Closure): New procedure + (GNATCmd): Set ASIS_Main when -P and -U with a main is used for gnat + check, metric or pretty. Call Get_Closure in this case. + (Check_Files): For GNAT LIST, check all sources of all projects when + All_Projects is True. + (GNATCmd): Accept -U for GNAT LIST + +2007-06-06 Vincent Celier + + * gnatlink.adb (Gnatlink): Do not specify -static-libgcc when --LINK= + has been specified + Correct error message when invocation of the linker fails + Add explicit size clause for the C imported variables + Object_List_File_Supported and Using_GNU_Linker to emphasize that + we expect char size. + Read target parameters earlier, since this is needed to set + Target_VM properly. Also do not use -static/shared-libgcc for non GCC + targets. + +2007-06-06 Vincent Celier + + * gnatls.adb: + Add 3 spaces before the default project directory when displaying + the project search path. + Add new command line switch '-l' to display license information. + +2007-06-06 Vasiliy Fofanov + + * gmem.c: Add support for timestamps on memory operations. + + * memtrack.adb, gnatmem.adb: Add support for timestamps on memory + operations (not used currently, just foundation for future + enhancements). Add possibility to perform full dump of gmem.out file. + (Print_Back_Traces): Declare accesses to root arrays constants since + they aren't modified. + (Print_Back_Traces): allocate root arrays on the heap rather than stack. + +2007-06-06 Vincent Celier + + * gnatsym.adb: Update Copyright notice + (Parse_Cmd_Line): Accept new switch -D + (Gnatsym): In Direct policy (switch -D) copy reference file to symbol + file. + + * prj.ads (Policy): New policy Direct + (Yes_No_Unknown): New enumeration type + (Project_Data): New component Libgnarl_Needed + + * prj-nmsc.adb (Check_For_Source): When recording a source file make + use the untouched pathname casing. + (Get_Directories): Ensure that the Display_Exec_Directory is using the + proper casing on non case-sensitive platforms like Windows. + (Get_Unit): Accept file names x__... and x~... (where x = a, g, i or s) + on all platforms, as it is not possible to know which one is allowed + before processing the project files. + (Check_Stand_Alone_Library): Check that Library_Reference_Symbol_File is + specified when symbol policy is Direct. Check that when there is a + symbol file defined (either by default or with attribute + Library_Symbol_File) it is not the same as the reference symbol file. + (Check_Stand_Alone_Library): Recognize new symbol policy Direct. + (Look_For_Sources): Allow Locally_Removed_Files to be declare in non + extending projects. + (Record_Ada_Source): Record a source that has been locally removed in an + imported project. + + * symbols.ads (Policy): New policy Direct + + * symbols-vms.adb (Initialize): Take new policy Direct in case + statement + +2007-06-06 Vincent Celier + + * g-os_lib.ads, g-os_lib.adb (Normalize_Pathname.Get_Directory): + Correct obvious bug (return Dir; instead of return Directory;). + (Normalize_Pathname): Use Reference_Dir'Length, not Reference_Dir'Last + +2007-06-06 Thomas Quinot + + * g-pehage.adb (Produce): Open output files in Binary mode, so that + they have UNIX line endings (LF only) even on Windows, and thus pass + all GNAT style checks. + +2007-06-06 Emmanuel Briot + + * g-regpat.adb (Quote): Fix improper quoting of '.' + +2007-06-06 Thomas Quinot + + * g-soccon.ads: Add new constant Thread_Blocking_IO, always True by + default, set False on a per-runtime basis. + (Need_Netdb_Buffer): New constant. + + * g-socket.ads, g-socket.adb: Import new package + GNAT.Sockets.Thin.Task_Safe_NetDB. + (Raise_Host_Error): Use Host_Error_Message from platform-specific thin + binding to obtain proper message. + (Close_Selector): Use GNAT.Sockets.Thin.Signalling_Fds.Close. + Replace various occurrences of Arry (Arry'First)'Address with the + equivalent Arry'Address (GNAT always follows implementation advice from + 13.3(14)). + (Get_Host_By_Address, Get_Host_By_Name, + Get_Service_By_Name, Get_Service_By_Port): Do not use GNAT.Task_Lock; + instead, rely on platform-specific task safe netdb operations provided + by g-socthi. + + * g-socthi.ads, g-socthi.adb (Initialize): Remove obsolete formal + parameter Process_Blocking_IO. + (Host_Error_Messages): Add stub body. + (GNAT.Sockets.Thin.Signalling_Fds): New procedure Close. + (Safe_Gethostbyname, Safe_Gethostbyaddr, Safe_Getservbyname, + Safe_Getservbyport): Move functions into new child package + Task_Safe_NetDB. + (Nonreentrant_Gethostbyname, Nonreentrant_Gethostbyaddr, + Nonreentrant_Getservbyname, Nonreentrant_Getservbyport): New routines. + (In_Addr): Add alignment clause. + +2007-06-06 Robert Dewar + + * g-trasym.ads, g-traceb.ads: Update list of supported targets + Add note about symbolic traceback + +2007-06-06 Pascal Obry + + * hostparm.ads (Normalized_CWD): Use the host directory separator + instead of the hardcoded forward slash which is not the proper + character on Windows for example. + (Java_VM): Removed. + +2007-06-06 Vincent Celier + Arnaud Charlet + + * a-clrefi.adb, a-clrefi.ads: New files + + * impunit.adb: Add s-os_lib in the list of user visible units. + (Non_Imp_File_Names_95): Add a-clrefi to this list + Remove obsolete run-time entries. + (Non_Imp_File_Names_05): Add Ada 2005 entries for: + "a-exetim" -- Ada.Execution_Time + "a-extiti" -- Ada.Execution_Time.Timers + + * mlib-prj.ads, mlib-prj.adb + (Build_Library): Use untouched object dir and library dir. At the + same time makes sure that the checks are done using the canonical + form. Removes hard-coded directory separator and use the proper host + one instead. + (Process_Project): Do not look in object directory to check if libgnarl + is needed for a library, if there is no object directory. + (Build_Library): Scan the ALI files to decide if libgnarl is needed for + linking. + (Build_Library): When invoking gnatbind, use a response file if the + total size of the arguments is too large. + + * Makefile.rtl: (g-sttsne): New object file. + Add entry for a-clrefi, s-utf_32, System.Exceptions + + * Make-lang.in: Remove bogus dependency of s-memory.o on memtrack.o. + (GNAT_ADA_OBJS, GNATBIND_OBJS): Add s-except.o. + (GNATBIND_OBJS): Add new objects a-clrefi.o and a-comlin.o + Change g-string to s-string, g-os_lib to s-os_lib + Change all g-utf_32 references to s-utf_32 + +2007-06-06 Tristan Gingold + Olivier Hainque + + * init.c: Do not adjust IP of an imported VMS exception of ia64. + LIB$STOP is called to raise an exception and the IP of the exception + is the instruction right after the call. + (__gnat_adjust_context_for_raise, AIX): Implement. + (__gnat_error_handler, AIX): Accept SIGINFO related arguments and call + adjust_context_for_raise before Raise_From_Signal_Hanler. + (__gnat_install_handler, AIX): Add SA_SIGINFO to the sa_flags, to ensure + siginfo is passed to the handler, necessary to let the zcx propagation + engine unwind past it. + +2007-06-06 Olivier Hainque + + * initialize.c (__gnat_initialize for vxworks): Update documentation + on the ZCX support, using different sets of crtstuff objects than with + GCC 3.4. + +2007-06-06 Robert Dewar + + * layout.ads, layout.adb (Adjust_Esize_Alignment): Move spec to package + spec from body + (Layout_Type): Fix recomputation of size from alignment. + +2007-06-06 Ed Schonberg + Javier Miranda + + * sem_ch12.adb (Analyze_Associations): Diagnose use of an others + association in an instance. + (Copy_Generic_Node): If the node is a string literal, no need to copy + its descendants. + (Is_Generic_Formal): For a formal subprogram, the declaration is the + grandparent of the entity. + (Analyze_Formal_Interface_Type): Transform into a full type declaration, + to simplify handling of formal interfaces that derive from other formal + interfaces. + (Instantiate_Subprogram_Body): The defining unit name of the body of + the instance should be a defining identifier. + (Install_Formal_Packages): make global to the package, for use in + instantiations of child units. + (Analyze_Package_Instantiation): Do not attempt to set information on an + enclosing master of an entry when expansion is disabled. + (Instantiate_Type): If the actual is a tagged synchronized type and the + generic ancestor is an interface, create a generic actual for the + corresponding record. + (Analyze_Formal_Derived_Interface_Type): Rewrite as a derived type + declaration, to ensure that the interface list is processed correctly. + (Inline_Instance_Body): If enclosing scope is an instance body, remove + its entities from visibiility as well. + (Pre_Analyze_Actuals): if the actual is an allocator with constraints + given with a named association, analyze the expression only, not the + discriminant association itself. + (Reset_Entity): If the analysis of a selected component is transformed + into an expanded name in the prefix of a call with parameters, do not + transform the original node into an expanded name, to prevent visibility + errors in the case of nested generics. + (Check_Private_View): For an array type, check whether the index types + may need exchanging. + +2007-06-06 Arnaud Charlet + Vincent Celier + + * lib-writ.adb: Handle Convention_CIL in addition to Convention_Java, + since both are separated. + Add support for imported CIL packages. + Add further special handling of "value_type" for CIL. + Add special handling of pragma Import for CIL. + + * make.ads, make.adb: When switch -eS is used, direct all outputs to + standard output instead of standard error, except errors. + (Absolute_Path): Use untouched casing for the parent directory. + (Add_Library_Search_Dir): Use the untouched directory name. + (Add_Source_Search_Dir): Idem. + (Change_To_Object_Directory): Update output to use proper casing. + (Create_Binder_Mapping_File): Use the untouched filename to set + ALI_Name. + (Gnatmake): Use untouched library and executable directory names. + (Insert_Project_Sources): Use untouched filename for spec and body. + (Is_In_Object_Directory): Use untouched object directory. + (Mark_Directory): Idem. + (Collect_Arguments_And_Compile): Ensure that Full_Source_File always + contains the non-canonical filename in all cases. + (Change_To_Object_Directory): In verbose mode, display the name of the + object directory we're changing to. + (Compile_Sources): Make sure, when a project file is used, to compile + the body of the unit, when there is one, even when only the spec is + recorded in an ALI file. + (Gcc_Switches, Binder_Switches, Linker_Switches): Tables moved from the + spec to the body. + (Report_Compilation_Failed): New procedure + (Bind, Display_Commands, Compile_Sources, Initialize, Scan_Make_Arg): + procedures moved from the spec to the body. + (Extract_Failure): Removed, not used + Replace explicit raises of exception Bind_Failed and Link_Failed with + calls to Make_Failed with the proper message. + Replace explicit raises of exception Compilation_Failed with calls to + procedure Report_Compilation_Failed. + (Initialize): Create mapping files unconditionally when using project + files. + + * sem_mech.adb: (Name_CIL, Name_CIL_Constructor, Convention_CIL, + Pragma_CIL_Constructor): New names. + + * targparm.ads, targparm.adb + (Compiler_System_Version): Removed, no longer used. + (Get_Target_Parameters): Relax checks on system.ads validity. Add + handling of two new system flags: JVM and CLI. + +2007-06-06 Jose Ruiz + Arnaud Charlet + + * Makefile.in (LIBGNAT_TARGET_PAIRS for VxWorks 6): For the RTP run + time, use the default s-interr body that provides interrupt support + based on signals. + (LIBGNAT_TARGET_PAIRS for x86-linux): Use specialized versions of + a-exetim.ad{s,b}, a-extiti.ad{s,b}, a-rttiev.ad{s,b}, s-osinte.ad{s,b}, + g-soccon.ads, and s-taprop.adb for the marte run time. + (EXTRA_GNATRTL_TASKING_OBJS for x86-linux): Execution time clocks and + timers are supported on marte. + (EH_MECHANISM for marte): Do not use ZCX. + (THREADSLIB for marte): Use -lmarte. + Add mlib-tgt-vms.o to the list of objects for gnatmake for VMS + Add mlib-tgt-specific.o to gnatmake objects + mlib-tgt-.adb is now the body of MLib.Tgt.Specific, no + longer of MLib.Tgt. + (LIBGNAT_TARGET_PAIRS for vxworks): When building a run time for VxWorks + 6, either kernel or rtp, use a specialized version of s-osinte.ads. + +2007-06-06 Pascal Obry + + * mkdir.c (__gnat_mkdir): Add support for UTF-8. + +2007-06-06 Vincent Celier + + * mlib.ads, mlib.adb (Build_Library): Do not use hard-coded directory + separator, use instead the proper host directory separator. + (Copy_ALI_Files): Make sure that an already existing ALI file in the + ALI copy dir is writable, before doing the copy. + + * mlib-utl.ads, mlib-utl.adb: + (Gcc): If length of command line is too long, put the list of object + files in a response file, if this is supported by the platform. + (Ar): If invocation of the archive builder is allowed to be done in + chunks and building it in one shot would go above an OS dependent + limit on the number of characters on the command line, build the archive + in chunks. + +2007-06-06 Vincent Celier + + * osinte-c.ads, osint-c.adb (Set_Library_Info_Name): Fail if base name + of specified object file is not equal to base name of source. + +2007-06-06 Javier Miranda + Hristian Kirtchev + Ed Schonberg + + * sem_ch3.adb (Process_Full_View): Propagate the CPP_Class attribute to + the full type declaration. + (Analyze_Component_Declaration): Add local variable E to capture the + initialization expression of the declaration. Replace the occurences of + Expression (N) with E. + (OK_For_Limited_Init_In_05): Allow initialization of class-wide + limited interface object with a function call. + (Array_Type_Declaration): If the declaration lacks subtype marks for + indices, create a simple index list to prevent cascaded errors. + (Is_Null_Extension): Ignore internal components created for secondary + tags when checking whether a record extension is a null extension. + (Check_Abstract_Interfaces): Add missing support for interface subtypes + and generic formals. + (Derived_Type_Declaration): Add missing support for interface subtypes + and generic formals. + (Analyze_Object_Declaration): If an initialization expression is + present, traverse its subtree and mark all allocators as static + coextensions. + (Add_Interface_Tag_Component): When looking for components that may be + secondary tags, ignore pragmas that can appear within a record + declaration. + (Check_Abstract_Overriding): an inherited function that dispatches on + result does not need to be overriden if the controlling type is a null + extension. + (Mentions_T): Handle properly a 'class attribute in an anonymous access + component declaration, when the prefix is an expanded name. + (Inherit_Component): If the derivation is for a private extension, + inherited components remain visible and their ekind should not be set + to Void. + (Find_Type_Of_Object): In the case of an access definition, always set + Is_Local_Anonymous_Access. We were previously not marking the anonymous + access type of a return object as a local anonymous type. + (Make_Index): Use Ambiguous_Character to report ambiguity on a discrete + range with character literal bounds. + (Constrain_Array): Initialize the Packed_Array_Type field to Empty. + (Access_Subprogram_Declaration): Indicate that the type declaration + depends on an incomplete type only if the incomplete type is declared + in an open scope. + (Analyze_Subtype_Declaration): Handle properly subtypes of + synchronized types that are tagged, and that may appear as generic + actuals. + (Access_Subprogram_Declaration): An anonymous access to subprogram can + appear as an access discriminant in a private type declaration. + (Add_Interface_Tag_Components): Complete decoration of the component + containing the tag of a secondary dispatch table and the component + containing the offset to the base of the object (this latter component + is only generated when the parent type has discriminants --as documented + in this routine). + (Inherit_Components): Use the new decoration of the tag components to + improve the condition that avoids inheriting the components associated + with secondary tags of the parent. + (Build_Discriminanted_Subtype): Indicate to the backend that the + size of record types associated with dispatch tables is known at + compile time. + (Analyze_Subtype_Declaration): Propagate Is_Interface flag when needed. + (Analyze_Interface_Declaration): Change setting of Is_Limited_Interface + to include task, protected, and synchronized interfaces as limited + interfaces. + (Process_Discriminants): Remove the setting of + Is_Local_Anonymous_Access on the type of (anonymous) access + discriminants of nonlimited types. + (Analyze_Interface_Type_Declaration): Complete the decoration of the + class-wide entity it is is already present. This situation occurs if + the limited-view has been previously built. + (Enumeration_Type_Declaration): Initialize properly the Enum_Pos_To_Rep + field. + (Add_Interface_Tag_Components.Add_Tag): Set the value of the attribute + Related_Interface. + +2007-06-06 Ed Schonberg + + * sem_aggr.adb (Resolve_Record_Aggregate): Ignore internal components + of the type that specify the position of interface tags when the type + inherits discriminated array components from the parent type. + If a component is initialized with a box, check for the presence of a + default expression in its declaration before using its default + initialization procedure. + (Resolve_Record_Aggregate): If a component is box-initialized, and the + component type has a discriminants, create a partial aggregate for it + by copying the discriminants of the component subtype. + Reject attempt to initialize a discriminant with a box. + (Array_Aggr_Subtype): Indicate to the backend that the size of arrays + associated with dispatch tables is known at compile time. + (Get_Value): If an association in a record aggregate has a box + association, and the corresponding record component has a default + expression, always copy the default expression, even when the + association has a single choice, in order to create a proper + association for the expanded aggregate. + +2007-06-06 Ed Schonberg + Robert Dewar + + * par-ch12.adb (P_Generic_Associations): The source position of an + Others association is that of the others keyword, not that of the token + that follows the box. + (P_Formal_Type_Definition): Handle formal access types that carry a + not null indicator. + + * par-ch3.adb (P_Known_Discriminant_Part_Opt, P_Component_Items): If + multiple identifier are present, save Scan_State before scanning the + colon, to ensure that separate trees are constructed for each + declaration. + (P_Identifier_Declarations): For object declaration, set new flag + Has_Init_Expression if initialization expression present. + (P_Null_Exclusion): Properly diagnose NOT NULL coming before NULL + Improve NOT NULL error messages + +2007-06-06 Robert Dewar + + * par-ch4.adb: (P_Name): Recover from literal used as name + +2007-06-06 Vincent Celier + + * prep.ads, prep.adb (Expression): New Boolean parameter Complemented, + defaulted to False. + In the "not" case, recursive call with Complemented set to True. + Do not allow "or" or "and" operators when Complemented is True. + +2007-06-06 Vincent Celier + + * prj.adb (Project_Empty): Gives default value for new component + Libgnarl_Needed + + * prj-attr.ads: Minor reformatting + + * prj-env.ads, prj-env.adb (For_All_Object_Dirs): Register object + directory using the untouched casing. + (For_All_Source_Dirs): Idem. + + * prj-ext.ads, prj-ext.adb (Search_Directories): New table to record + directories specified with switches -aP. + (Add_Search_Project_Directory): New procedure + (Initialize_Project_Path): Put the directories in table + Search_Directories in the project search path. + (Initialize_Project_Path): For VMS, transform into canonical form the + project path. + +2007-06-06 Arnaud Charlet + + * restrict.ads, restrict.adb (No_Exception_Handlers_Set): Only return + true if configurable run-time or No_Run_Time is set. + (Set_Restriction): Avoid setting restriction No_Elaboration_Code when + processing an unit which is not the one being compiled. + +2007-06-06 Arnaud Charlet + + * s-arit64.adb: Replace System.Pure_Exceptions by Ada 05 syntax. + Replace UC by Ada.UC + + * s-bitops.adb: Get rid of System.Pure_Exceptions. + Replace UC by Ada.UC + +2007-06-06 Robert Dewar + + * scng.adb: (Check_End_Of_Line): Deal with very long lines + +2007-06-06 Robert Dewar + + * sem.ads, sem.adb (Semantics): Save and restore Global_Discard_Names + Remove no longer used nodes. + +2007-06-06 Javier Miranda + Ed Schonberg + Robert Dewar + + * sem_ch10.ads, sem_ch10.adb (Analyze_Compilation_Unit): Disable check + on obsolescent withed unit in case of limited-withed units. + (Analyze_Compilation_Unit): Add guard to code that removed an + instantiation from visibility, to prevent compiler aborts when + instantiation is abandoned early on. + (Install_Limited_Withed_Unit): Recognize a limited-with clause on the + current unit being analyzed, and Distinguish local incomplete types + from limited views of types declared elsewhere. + (Build_Limited_Views.Decorate_Tagged_Type): Add documentation + to state that the class-wide entity is shared by the limited-view + and the full-view. + (Analyze_With_Clause): Improve placement of flag for case of + unimplemented unit. + (Analyze_With_Clause): Recognize use of GNAT.Exception_Traces in a + manner similar to GNAT.Current_Exception. This is a violation of + restriction (No_Exception_Propagation), and also inhibits the + optimization of local raise to goto. + (Analyze_With_Clause): Check for Most_Recent_Exception being with'ed, + and if so set Most_Recent_Exception_Used flag in Opt, and also check + for violation of restriction No_Exception_Propagation. + +2007-06-06 Javier Miranda + Hristian Kirtchev + Gary Dismukes + + * sem_ch11.adb (Analyze_Exception_Handlers): Add barrier to avoid the + use of entity Exception_Occurrence if it is not available in the + target run-time. + + * sem_ch9.adb (Analyze_Protected_Type, Analyze_Task_Type): When + concurrent types are declared within an Ada 2005 generic, build their + corresponding record types since they are needed for overriding-related + semantic checks. + (Analyze_Protected_Type): Rearrange and simplify code for testing that a + protected type does not implement a task interface or a nonlimited + interface. + (Analyze_Task_Type): Rearrange and simplify code for testing that a task + type does not implement a protected interface or a nonlimited interface. + (Single_Task_Declaration, Single_Protected_Declaration): use original + entity for variable declaration, to ensure that debugging information + is correcty generated. + (Analyze_Protected_Type, Analyze_Task_Type): Do not call expander + routines if the expander is not active. + (Analyze_Task_Body): Mark all handlers to stop optimization of local + raise, since special things happen for task exception handlers. + + * sem_disp.adb (Check_Controlling_Formals): Add type retrieval for + concurrent types declared within a generic. + (Check_Dispatching_Operation): Do not emit warning about late interface + operations in the context of an instance. + (Check_Dispatching_Call): Remove restriction against calling a + dispatching operation with a limited controlling result. + (Check_Dispatching_Operation): Replace calls to Fill_DT_Entry and + Register_Interface_DT_Entry by calls to Register_Primitive. + (Check_Dispatching_Formals): Handle properly a function with a + controlling access result. + +2007-06-06 Robert Dewar + Arnaud Charlet + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause, case Stream_Size): + Check for restriction No_Implementation_Attributes if in Ada 95 mode. + (Storage_Pool): Do not crash when RE_Stack_Bounded_Pool is not available + (Analyze_Attribute_Definition_Clause [External_Tag]): Generate error + message when using a VM, since this attribute is not supported. + (Analyze_Record_Representation_Clause): Give unrepped component warnings + + * usage.adb: Add new warning for renaming of function return objects + Indicate that -gnatwp and -gnatwP concern front-end inlining + Add line for -gnatyg + Add usage information for -gnatw.c/C + +2007-06-06 Robert Dewar + Ed Schonberg + + * sem_ch5.adb + (Find_Var): Do not consider function call in test for infinite loop + warning if warnings set off for function entity. + (One_Bound): Do not create a temporary for a loop bound if it is a + character literal. + (Analyze_Assignment): Traverse the right hand side of an assignment and + mark all allocators as static coextensions. + (Analyze_Assignment): Exempt assignments involving a dispatching call + to a function with a controlling access result from the check requiring + the target to be class-wide. + +2007-06-06 Hristian Kirtchev + Ed Schonberg + Robert Dewar + Javier Miranda + + * sem_res.ads, sem_res.adb (Process_Allocator): Do not propagate the + chain of coextensions when an allocator serves as the root of such a + chain. + (Propagate_Coextensions): Remove the test for the root being an + allocator. + (Resolve_Allocator): Add condition to ensure that all future decoration + occurs on an allocator node. Add processing and cleanup for static + coextensions. + (Valid_Conversion): If the operand type is the limited view of a + class-wide type, use the non-limited view is available to determine + legality of operation. + (Ambiguous_Character): move to spec, for use elsewhere. + (Ambiguous_Character): Handle Wide_Wide_Character in Ada 2005 mode + (Resolve_Range): Diagnose properly an ambiguous range whose bounds are + character literals. + (Resolve_Arithmetic_Op): Call Activate_Division_Check instead of setting + Do_Division_Check flag explicitly. + (Resolve_Actuals): If the actual is of a synchronized type, and the + formal is of the corresponding record type, this is a call to a + primitive operation of the type, that is declared outside of the type; + the actual must be unchecked-converted to the type of the actual + (Resolve_Call): Kill all current values for any subprogram call if + flag Suppress_Value_Tracking_On_Call is set. + (Resolve_Type_Conversion): Generate error message the the operand + or target of interface conversions come from a limited view. + (Check_Infinite_Recursion): Ignore generated calls + (Check_Allocator_Discrim_Accessibility): New procedure for checking + that an expression that constrains an access discriminant in an + allocator does not denote an object with a deeper level than the + allocator's access type. + (Resolve_Allocator): In the case of an allocator initialized by an + aggregate of a discriminated type, check that associations for any + access discriminants satisfy accessibility requirements by calling + Check_Allocator_Discrim_Accessibility. + (Resolve_Equality_Op): Handle comparisons of anonymous access to + subprogram types in the same fashion as other anonymous access types. + (Resolve_Concatenation_Arg): Remove initial character '\' in an error + message that is not a continuation message. + (Resolve_Type_Conversion): Add missing support for conversion to + interface type. + (Resolve_Actuals): Introduce a transient scope around the call if an + actual is a call to a function returning a limited type, because the + resulting value must be finalized after the call. + (Resolve_Actuals): If the call was given in prefix notations, check + whether an implicit 'Access reference or implicit dereference must be + added to make the actual conform to the controlling formal. + +2007-06-06 Robert Dewar + Javier Miranda + + * sem_ch7.adb (Check_Anonymous_Access_Types): Fix error for null body + (Derive_Inherited_Private_Subprogram): Code cleanup. In case of explicit + overriding of an inherited private subprogram now there is no need to + inherit its dispatching slot and reduce the size of the dispatch table. + Set_All_DT_Position now ensures that the same slot is now assigned to + both entities. This is required to statically build the dispatch table. + (Declare_Inherited_Private_Subprograms): Rewriten to avoid the need + of calling Set_All_DT_Position to re-evaluate the position of the + entries in the dispatch table. Such reevaluation is not desired if + the tagged type is already frozen. + +2007-06-06 Hristian Kirtchev + Gary Dismukes + Robert Dewar + Javier Miranda + + * sem_util.ads, sem_util.adb (May_Be_Lvalue): A prefix of an attribute + reference acts as an lvalue when the attribute name modifies the prefix + (Is_Coextension_Root): New routine. + (Mark_Static_Coextensions): New routine. + (Type_Access_Level): Revise code for checking the level of the + anonymous access type of a return object. + (Safe_To_Capture_Value): Not safe to capture if Address_Taken + (Matches_Prefixed_View_Profile): Remove the no longer necessary + retrieval of the corresponding controlling record type. + (Find_Overridden_Synchronized_Primitive): Code cleanup. Add handling of + concurrent types declared within a generic as well as class wide types. + Emit a mode incompatibility error whenever a protected entry or routine + override an interface routine whose first parameter is not of mode + "out", "in out" or access to variable. + (Overrides_Synchronized_Primitive): Rename to + Find_Overridden_Synchronized_Primitive. + (Collect_Interface_Components): New subprogram that collects all the + components of a tagged record containing tags of secondary dispatch + tables. + (Add_Global_Declaration): New procedure + (Abstract_Interface_List): Handle properly the case of a subtype of a + private extension. + (Type_Access_Level): In the case of a type whose parent scope is a + return statement, call Type_Access_Level recursively on the enclosing + function's result type to determine the level of the return object's + type. + (Build_Elaboration_Entity): Build name of elaboration entity from the + scope chain of the entity, rather than the unit name of the file name. + (Check_Nested_Access): New procedure. + (Has_Up_Level_Access, Set_Has_Up_Level_Access): New procedures. + (Find_Direct_Name, Note_Possible_Modification): Use Check_Nested_Access. + (Get_Renamed_Entity): Utility routine for performing common operation + of chasing the Renamed_Entity field of an entity. + +2007-06-06 Robert Dewar + + * sem_elab.adb (Check_A_Call): Specialize elaboration warnings on + elaboration model + (Check_A_Call): Add check for entry call which was causing blowup + +2007-06-06 Olivier Hainque + + * raise-gcc.c (__gnat_eh_personality): Tweak the signature and add + special code on ia64-vms to handle major incompatibilities between the + GCC unwinding ABI and the VMS Condition Handling Facility, both calling + this routine with a very different set of arguments and expectations on + the return value. + +2007-06-06 Thomas Quinot + + * socket.c (__gnat_close_signalling_fd): New function. + (__gnat_safe_gethostbyaddr, __gnat_safe_gethostbyname, + __gnat_safe_getservbyname, __gnat_safe_getservbyport): + New supporting functions for task safe Netdb operations. + +2007-06-06 Thomas Quinot + Olivier Hainque + + * a-except-2005.ads, a-except-2005.adb + (Raise_From_Controlled_Operation): New procedure in + (private part of) Ada.Exceptions (standard runtime version). Used to + provide informational exception message when Program_Error is raised as + a result of an Adjust or Finalize operation propagating an exception. + (Rmsg_28): Fix description for E.4(18) check. + (Raise_Current_Excep): Call Debug_Raise_Exception just before + propagation starts, to let debuggers know about the event in a reliable + fashion. + Take the address of E and dereference to make sure it is homed on stack + and prevent the stores from being deleted, necessary for proper + debugger behavior on "break exception" hits. + (Local_Raise): Moved to System.Exceptions + + * s-finimp.adb (Raise_From_Finalize): Code to construct an appropriate + exception message from the current occurrence and raise Program_Error + has been moved to Ada.Exceptions.Raise_From_Controlled_Operation. + +2007-06-06 Jose Ruiz + Arnaud Charlet + + * s-taprob.adb (Unlock): Change the ceiling priority of the underlying + lock, if needed. + + * s-taprop.ads (Set_Ceiling): Add this procedure to change the ceiling + priority associated to a lock. + + * s-tpoben.adb ([Vulnerable_]Complete_Task, Lock_Entries): Relax + assertion to take into account case of no abort restriction. + (Initialize_Protection_Entries): Add initialization for the field + New_Ceiling associated to the protected object. + (Unlock_Entries): Change the ceiling priority of the underlying lock, if + needed. + + * s-solita.adb (Get_Current_Excep): Moved back to s-tasini/s-tarest, + since this function needs to be set consistently with Update_Exception. + + * s-tarest.adb (Get_Current_Excep): Moved back to s-tasini/s-tarest, + since this function needs to be set consistently with Update_Exception. + + * s-taskin.ads: Update comments on + Interrupt_Server_Blocked_On_Event_Flag. + (Unbind_Handler): Fix handling of server_task wakeup + (Server_Task): Set self's state so that Unbind_Handler can take + appropriate actions. + (Common_ATCB): Now use a constant from System.Parameters to determine + the max size of the Task_Image field. + + * s-tassta.adb (Task_Wrapper): Now pass the overflow guard to the + Initialize_Analyzer function. + ([Vulnerable_]Complete_Task, Lock_Entries): Relax assertion to + take into account case of no abort restriction. + ([Vulnerable_]Complete_Master): Modify assertion. + + * s-tataat.adb (Finalize): Use the nestable versions of + Defer/Undefer_Abort. + + * s-tpobop.adb (Protected_Entry_Call): Relax assertion. + + * s-tpobop.ads: Update comments. + + * s-tposen.adb (Protected_Single_Entry_Call): Call Lock_Entry instead + of locking the object manually, to avoid inconsistencies between + Lock/Unlock_Entry assertions. + + * s-interr.ads, s-interr.adb (Server_Task): Fix race condition when + terminating + application and System.Parameters.No_Abort is True. + Update comments on Interrupt_Server_Blocked_On_Event_Flag. + (Unbind_Handler): Fix handling of server_task wakeup + (Server_Task): Set self's state so that Unbind_Handler can take + appropriate actions. + +2007-06-06 Thomas Quinot + + * s-finroo.ads, s-finroo.adb (Read, Write): Use null procedure + declarations instead of an explicit null body, for conciseness. + +2007-06-06 Robert Dewar + + * sem_eval.adb (Eval_Relational_Op): nothing to do if an operand is an + illegal aggregate and the type is still Any_Composite. + (Subtypes_Statically_Match): Fix problem of empty discriminant list + +2007-06-06 Ed Schonberg + + * sem_smem.adb (Check_Shared_Var): Check explicitly for as task object, + to prevent subsequent expansion. + +2007-06-06 Robert Dewar + + * sinput-l.ads, sinput-l.adb: implement a new pragma No_Body + +2007-06-06 Ed Schonberg + Robert Dewar + + * sprint.ads, sprint.adb (Sprint_Node_Actual): Output aggregate for + exceptions. + (Write_Itype): Handle case of string literal subtype, which + comes up in this context. + (Update_Itype): when debugging expanded code, update sloc of itypes + associated with defining_identifiers and ranges, for gdb use. + (Sprint_Node_Actual): Add static keyword to object or exception + declaration output if Is_Statically_Allocated is True. + (Sprint_End_Label): Set entity of end marker for a subprogram, package, + or task body, so that the tree carries the proper Sloc information for + debugging use. + (Write_Indent): In Dump_Source_Text mode, ignore implicit label nodes + +2007-06-06 Arnaud Charlet + + * s-secsta.adb (Chunk): Ensure this object has a static size known at + compile time, to avoid dynamic memory allocation + (Elaboration code): Only use dynamic memory allocation when needed. + +2007-06-06 Quentin Ochem + + * s-stausa.ads, s-stausa.adb (Initialize_Analyzer): Added parameter + "Overflow_Guard". + (Stack_Analyzer): Added field "Overflow_Guard" + (Task_Result): Added field "Overflow_Guard". + (Index_Str): New constant. + (Task_Name_Str): New constant. + (Actual_Size_Str): New constant. + (Pattern_Array_Element_Size): New constant. + (Get_Usage_Range): New subprogram. + (Output_Result): Added parameter Max_Size_Len and Max_Actual_Use_Len. + Now align the output. + Added comments. + (Initialize): Added value for Overflow_Guard. + (Fill_Stack): Use constant Pattern_Array_Elem_Size when relevant. + Update the value of the overflow guard according to the actual + beginning of the pattern array. + (Initialize_Analyzer): Added parameter Overflow_Guard. + Take this parameter into accound when computing the max size. + (Compute_Result): Use constant Pattern_Array_Elem_Size when relevant. + (Report_Result): Removed extra useless procedure. + Updated call to Output_Result. + Moved full computation of the Task_Result here. + +2007-06-06 Thomas Quinot + + * g-soccon-darwin.ads, gen-soccon.c: Add new constant + Thread_Blocking_IO, always True by default, set False on a per-runtime + basis. + Add Windows-specific constants + Add new constant Need_Netdb_Buffer. + Add new macros to indicate whether getXXXbyYYY is thread safe and, if + not, whether to use getXXXbyYYY_r. + + * gsocket.h: Add new constant Need_Netdb_Buffer. + Add new macros to indicate whether getXXXbyYYY is thread safe and, if + not, whether to use getXXXbyYYY_r. + +2007-06-06 Eric Botcazou + + * s-stoele.ads, s-stoele.adb: Move inline_always subprograms earlier + than their first call. + Add type Dummy_Communication_Block used in the generation of the pre- + defined dispatching primitive _disp_asynchronous_select. + (Storage_Element): Put Pragma Universal_Aliasing on it. + +2007-06-06 Vincent Celier + + * a-dirval-vms.adb, a-dirval.ads, a-dirval.adb (Windows): New Boolean + function. + + * a-dirval-mingw.adb (Is_Valid_Path_Name): Forbid a path with a drive + letter if it is not followed by a '/' or a '\'. + (Windows): New Boolean function + + * a-direct.ads, a-direct.adb: Remove unnecessary and misplaced pragma + Ada 2005. + (Containing_Directory): On Windows, keep at least one '/' or '\' after a + drive letter. + (Containing_Directory): Raise Use_Error when the directory is a root + directory. + (Extension): When returning the result, use a conversion to Result_Type, + not a qualification. + +2007-06-06 Robert Dewar + + * stylesw.ads, stylesw.adb (Set_GNAT_Style_Check): New procedure + (Set_Style_Check_Options): Recognize new -gnatyg style switch + + * switch-c.adb (Scan_Front_End_Switches, case -gnatg): Set + Warn_On_Non_Local_Exception to False, to turn off warnings for + No_Exception_Propagation in ZFP runtime. + (Scan_Front_End_Switches): Fix handling of --RTS switch for non GCC + back-ends. + (Scan_Front_End_Switches): For 'g', call Set_GNAT_Style_Checks + +2007-06-06 Vincent Celier + + * switch-b.adb (Scan_Binder_Switches): Add processing for new + switches -R and -Z + + * switch-m.adb (Normalize_Compiler_Switches): Do not record switch -E + (Scan_Make_Switches): Recognize new switch -aP + +2007-06-06 Matthew Gingell + Jose Ruiz + + * s-stchop-vxworks.adb (Set_Stack_Info): Instead of trying to map the + VxWorks task descriptor in the Ada run time, call a C subprogram + (__gnat_get_stack_info) that extracts the required information. + + * sysdep.c: Back out temporary lynxos workaround. + (__gnat_get_stack_info): Add this procedure that passes to the Ada run + time the stack information associated to the currently executing task. + Only VxWorks systems require this function. + +2007-06-06 Eric Botcazou + + * tracebak.c (FRAME_OFFSET): Add parameter FP. On SPARC/Solaris, do not + add the stack bias if the offset is computed from a frame address. + (__gnat_backtrace): Adjust for above change. + +2007-06-06 Thomas Quinot + + * types.h, types.ads: Rename PE_Illegal_CW_Actual_E_4_18 to + PE_Non_Transportable_Actual. + (By_Descriptor_Last): New constant. + (By_Copy_Return): Likewise. + +2007-06-06 Vincent Celier + + * vms_conv.adb (Process_Argument): Keep arguments starting with '+' as + is. + + * vms_data.ads: Add entries for -gnatw.x and -gnatw.X + /STYLE_CHECKS=GNAT: Change meaning to -gnatyg + /GNAT_INTERNAL: New compiler qualifier corresponding to -gnatg + Add missing comment for /OPTIMIZE=SPACE + Add entry for OPTIMIZE=SPACE + Add new qualifier /ALL_PROJECTS (= -U) for GNAT LIST + Add documentation for new qualifiers corresponding to -gnatw.c/.C + +2007-06-06 Vincent Celier + Robert Dewar + + * xgnatugn.adb: Allow dots to be used in ug_words (-gnatw.c and + -gnatw.C) + + * gnat_ugn.texi: Fix ordering of -g switch for gnatmake + Document gnatbind switch -a + (case Constructions): Document that variables declarations are allowed + for previously declared variables. + Fix external lib project example + -gnatg: Indicate new VMS qualifier /GNAT_INTERNAL + Indicate that "#if not X or Y then" is not allowed in input files to + gnatprep. + Document gnatw.x and gnatw.X warning flags + Mention -Winline switch to activate warnings when back-end inlining is + ineffective. + Add gnatcheck rule descriptions + Describe how to use the GNAT driver to call a tool on a closure. + Describe how to run project-wide checks or metrics. + Document gnatbind's -R option + Updated to account for Ada 2005 support + + * gnat_rm.texi (Case Construction): Allow variable declarations for + previously declared variables. + (Representation Clauses and Pragmas): Lift restriction on alignment + clauses for record types. + (Ada.Characters.*): Fix typo in reference to A.3.3(27). + Document No_Exception_Propagation restriction + Document No_Body pragma + Updated to account for Ada 2005 support; corrected some typos + (Implementation Defined Pragmas): Document pragma Universal_Aliasing. + + * gnat-style.texi: Make it clear that we never use mode IN for + procedures or functions + + * ug_words: Add entries for -gnatw.x and -gnatw.X + Add entries for -gnatw.c/.C + +2007-06-06 Pascal Obry + Vincent Celier + + * makegpr.adb (Add_Archive_Path): Use untouched object and library + dirs and library name. + (Build_Global_Archive): Idem. Minor code clean-up. Removes duplicate + comments. + (Build_Library): Idem. + (Compile_Individual_Sources): Idem. + (Compile_Link_With_Gnatmake): Idem. + (Compile_Sources): Idem. + (Get_Imported_Directories): Idem. + (Link_Executables): Idem. Same change for the executable dir. + (Check_Compilation_Needed): C_Source_Path new variable containing + the canonical form of Source_Path to check against the source names + in the dependency file. + (Build_Global_Archive, Compile_Individual_Sources, Compile_Sources): In + verbose mode, display the name of the object directory we're changing + to. + (Saved_Switches): New name of table X_Switches + (Scan_Arg): Recognize new switch -aP and save in table Saved_Switches + (Usage): New line for switch -aP + (Get_Imported_Directories.Add): Make sure that Add_Arg is True before + testing if a directory should be added to the search path. + +2007-06-06 Javier Miranda + + * a-cidlli.ads, a-cdlili.ads, a-cohama.ads, a-coinve.ads, + a-convec.ads (Empty_Vector, Empty_Map, Empty_List): Move this object + declaration after freezing point of all its associated tagged types; + otherwise such types are frozen too early. + +2007-06-06 Robert Dewar + + * a-reatim.adb: Documentation addition + + * g-cgideb.adb: Minor code reorganization + + * tree_io.adb, treepr.adb, cstand.adb, krunch.adb, par.adb, + mdll-utl.adb, par-ch5.adb, par-tchk.adb, s-exctab.ads, s-memory.ads, + s-osprim.ads, s-restri.ads, s-soflin.ads: Minor reformatting. + + * debug.ads, debug.adb (Get_Debug_Flag_K): Remove unused obsolete + function. Change name New_Scope to Push_Scope + (Get_Debug_Flag_K): Remove unused obsolete function. + + * exp_ch8.adb, inline.adb, sem_ch8.ads: Change name New_Scope to + Push_Scope. + + * makeusg.adb: Update Copyright notice + Add line for switch -aP + + * makeusg.adb: Fix wording of some usage messages + + * s-assert.adb (Raise_Assert_Failure): Add call to + Debug_Raise_Assert_Failure. + + * s-unstyp.ads (type Packed_Bytes2): Change alignment to use 'Min + (2, Standard'Alignment) for compatibility with AAMP (where alignment + is restricted to 1). + + * s-wchjis.adb: Remove use of System.Pure_Exceptions + + * tbuild.ads, tbuild.adb (Make_Implicit_Exception_Handler): Set the + node location to No_Location when we're not debugging the expanded + code. + +2007-05-22 Alexandre Oliva + + * misc.c (enumerate_modes): Consider log2_b to always be one. + +2007-05-14 Rafael Ávila de Espíndola + + * misc.c (LANG_HOOKS_UNSIGNED_TYPE): Remove. + +2007-05-02 Pascal Obry + + * gnatchop.adb (Write_Source_Reference_Pragma): Change implementation + to use Stream_IO.File_Type. This is needed to make use of the UTF-8 + encoding support of Stream_IO. + (Write_Unit): Idem. + + * adaint.h, adaint.c (__gnat_os_filename): New routine. Returns the + filename and corresponding encoding to match the OS requirement. + (__gnat_file_exists): Do not call __gnat_stat() on Windows as this + routine will fail on specific devices like CON: AUX: ... + + PR ada/29856: Add missing braces + +2007-04-22 Andrew Pinski + + PR ada/31660 + * ada-tree.h (lang_tree_node): Fix typo in chain_next. + +2007-04-21 Jan Hubicka + + * misc.c (gnat_expand_body): Don't call target for destructors, + avoid redundant check on syntax errors. + +2007-04-21 Andrew Pinski + + * ada-tree.h (lang_tree_node): Use GENERIC_NEXT + instead of checking GIMPLE_STMT_P in chain_next. + +2007-04-17 Andreas Krebbel + + PR ada/31576 + * system-linux-alpha.ads: Disable constant condition warning for the + Default_Bit_Order variable. + * system-linux-s390.ads: Likewise. + * system-linux-s390x.ads: Likewise. + * system-linux-sparc.ads: Likewise. + +2007-04-06 Javier Miranda + Matt Heaney + Robert Dewar + + a-coprnu.ads, a-cohata.ads, a-chtgop.ads, a-chtgop.adb, a-cgcaso.ads, + a-cgarso.ads, a-secain.ads, a-slcain.ads, a-shcain.ads, a-chtgke.ads, + a-chtgke.ads, a-coprnu.ads, a-contai.ads, a-chtgke.ads, a-chtgke.adb, + a-stwiha.ads, a-strhas.ads, a-lfztio.ads, a-liztio.ads, a-llfzti.ads, + a-llizti.ads, a-sfztio.ads, a-siztio.ads, a-ssizti.ads, a-stzfix.ads, + a-stzhas.ads, a-szuzha.ads, a-tiunio.ads, a-wwunio.ads, a-ztcoio.ads, + a-ztinio.ads, a-zttest.ads, a-zzunio.ads, a-astaco.ads, a-charac.ads, + a-chlat1.ads, ada.ads, a-dynpri.ads, a-flteio.ads, a-fwteio.ads, + a-inteio.ads, a-intnam.ads, a-ioexce.ads, a-iwteio.ads, a-lfteio.ads, + a-lfwtio.ads, a-liteio.ads, a-liwtio.ads, a-llftio.ads, a-llfwti.ads, + a-llitio.ads, a-lliwti.ads, a-ncelfu.ads, a-ngcefu.ads, a-ngelfu.ads, + a-nlcefu.ads, a-nlcoty.ads, a-nlelfu.ads, a-nllcef.ads, a-nllcty.ads, + a-nllefu.ads, a-nscefu.ads, a-nscoty.ads, a-nselfu.ads, a-nucoty.ads, + a-nuelfu.ads, a-numeri.ads, a-sfteio.ads, a-sfwtio.ads, a-siteio.ads, + a-siwtio.ads, a-ssitio.ads, a-ssiwti.ads, a-storio.ads, a-strfix.ads, + a-string.ads, a-stwifi.ads, a-titest.ads, a-unccon.ads, a-uncdea.ads, + a-wtcoio.ads, a-wtinio.ads, a-wttest.ads, calendar.ads, directio.ads, + i-c.ads, ioexcept.ads, machcode.ads, sequenio.ads, text_io.ads, + unchconv.ads, unchdeal.ads, a-widcha.ads, a-zchara.ads, a-stboha.ads, + a-stfiha.ads, a-coteio.ads, a-envvar.ads, a-lcteio.ads, a-llctio.ads, + a-scteio.ads, a-swbwha.ads, a-swfwha.ads, a-szbzha.ads, a-szfzha.ads, + a-tiboio.ads, a-wwboio.ads, a-zzboio.ads, a-dispat.ads, a-tgdico.ads, + expander.adb, g-socket.ads, par-labl.adb, sinput-c.adb, s-tarest.ads, + s-stchop.ads, g-expect-vms.adb, s-taprop-lynxos.adb, + s-taprop-tru64.adb, s-taprop-irix.adb, + s-taprop-hpux-dce.adb, s-traceb-hpux.adb, + s-taprop-linux.adb, s-taprop-dummy.adb, s-osprim-unix.adb, + s-osprim-solaris.adb, s-taprop-solaris.adb, s-taprop-vms.adb, + s-osprim-mingw.adb, s-taprop-mingw.adb, s-osprim-posix.adb, + s-taprop-posix.adb, a-exexpr-gcc.adb, a-ststio.adb, a-ststio.ads, + a-textio.adb, a-textio.ads, a-tideau.adb, a-tideau.ads, a-witeio.adb, + a-witeio.ads, a-wtdeau.adb, a-wtdeau.ads, g-calend.adb, g-calend.ads, + g-dirope.adb, g-expect.ads, gnatchop.adb, g-spipat.adb, g-spipat.ads, + s-direio.adb, s-direio.ads, s-fatgen.adb, s-fatgen.ads, s-parint.adb, + s-sequio.adb, s-sequio.ads, s-taprop.ads, s-valdec.adb, s-valdec.ads, + s-valint.adb, s-valint.ads, s-vallld.adb, s-vallld.ads, s-vallli.adb, + s-vallli.ads, s-valllu.adb, s-valllu.ads, s-valrea.adb, s-valrea.ads, + s-valuns.adb, s-valuns.ads, s-valuti.adb, s-valuti.ads, xref_lib.adb, + s-stchop.adb, i-vxwork-x86.ads, a-crbtgo.ads, a-crbtgo.adb, + a-coorse.ads, a-coorse.adb, a-cohama.ads, a-cohama.adb, a-ciorse.ads, + a-ciorse.adb, a-cihama.ads, a-cihama.adb, a-chtgop.ads, a-chtgop.ads, + a-coormu.adb, a-ciormu.adb, a-cihase.adb, a-cihase.ads, a-cohase.adb, + a-cohase.ads, a-swuwha.ads, a-ciormu.ads, a-coormu.ads, a-rbtgso.ads, + a-stunha.ads, a-ciorma.adb, a-coorma.adb, a-ztdeau.adb, a-ztdeau.ads, + a-ztexio.adb, a-ztexio.ads: Addition of null-exclusion to anonymous + access types. + Update documentation. + Minor rewording. + +2007-04-06 Robert Dewar + + * system-linux-ia64.ads, system-freebsd-x86.ads, system-lynxos-ppc.ads, + system-lynxos-x86.ads, system-linux-x86_64.ads, system-tru64.ads, + system-vxworks-sparcv9.ads, system-solaris-x86.ads, system-irix-o32.ads, + system-irix-n32.ads, system-hpux.ads, system-vxworks-m68k.ads, + system-linux-x86.ads, system-vxworks-mips.ads, system-interix.ads, + system-solaris-sparc.ads, system-solaris-sparcv9.ads, system-vms.ads, + system-mingw.ads, system-vms-zcx.ads, system-vxworks-ppc.ads, + system-vxworks-alpha.ads, system-vms_64.ads, system-darwin-ppc.ads, + system-vxworks-x86.ads, system-linux-ppc.ads, system-linux-hppa.ads, + system-hpux-ia64.ads, targparm.adb, + targparm.ads (Functions_Return_By_DSP_On_Target): Removed + + * system.ads: Move Functions_Return_By_DSP to obsolete section, + kept for bootstrap purposes only. + +2007-04-06 Arnaud Charlet + + * s-osinte-lynxos-3.ads, s-osinte-hpux.ads, s-osinte-solaris-posix.ads, + s-osinte-freebsd.ads, s-osinte-aix.ads, s-osinte-darwin.ads, + s-taprop-posix.adb (Create_Task): Fix handling of Task_Info. + (PTHREAD_SCOPE_PROCESS, PTHREAD_SCOPE_SYSTEM): New constants. + +2007-04-06 Robert Dewar + + * a-except.adb, a-except.ads, a-except-2005.ads, a-except-2005.adb + (Local_Raise): New dummy procedure called when a raise is converted + to a local goto. Used for debugger to detect that the exception + is raised. + + * debug.adb: Document new d.g flag (expand local raise statements to + gotos even if pragma Restriction (No_Exception_Propagation) is not set) + + * exp_sel.adb: Use Make_Implicit_Exception_Handler + + * exp_ch11.adb (Expand_Exception_Handlers): Use new flag -gnatw.x to + suppress warnings for unused handlers. + (Warn_If_No_Propagation): Use new flag -gnatw.x to suppress + warnings for raise statements not handled locally. + (Get_RT_Exception_Entity): New function + (Get_Local_Call_Entity): New function + (Find_Local_Handler): New function + (Warn_If_No_Propagation): New procedure + (Expand_At_End_Handler): Call Make_Implicit_Handler + (Expand_Exception_Handlers): Major additions to deal with local handlers + (Expand_N_Raise_Constraint_Error, Expand_N_Raise_Program_Error, + Expand_N_Raise_Storage_Error, (Expand_N_Raise_Statement): Add handling + for local raise + + * exp_ch11.ads (Get_RT_Exception_Entity): New function + (Get_Local_Call_Entity): New function + + * gnatbind.adb (Restriction_List): Add No_Exception_Propagation to list + of restrictions that the binder will never suggest adding. + + * par-ch11.adb (P_Exception_Handler): Set Local_Raise_Statements field + to No_Elist. + + * restrict.adb (Check_Restricted_Unit): GNAT.Current_Exception may not + be with'ed in the presence of pragma Restriction + (No_Exception_Propagation). + + * sem.adb (Analyze): Add entries for N_Push and N_Pop nodes + + * sem_ch11.adb (Analyze_Exception_Handler): If there is a choice + parameter, then the handler is not a suitable target for a local raise, + and this is a violation of restriction No_Exception_Propagation. + (Analyze_Handled_Statements): Analyze choice parameters in exception + handlers before analyzing statement sequence (needed for proper + detection of local raise statements). + (Analyze_Raise_Statement): Reraise statement is a violation of the + No_Exception_Propagation restriction. + + * s-rident.ads: Add new restriction No_Exception_Propagation + + * tbuild.ads, tbuild.adb (Make_Implicit_Exception_Handler): New + function, like Make_Exception_Handler but sets Local_Raise_Statements + to No_List. + (Add_Unique_Serial_Number): Deal with case where this is called during + processing of configuration pragmas. + +2007-04-06 Thomas Quinot + Pat Rogers + Pascal Obry + + * g-stsifd-sockets.adb: New file. + + * g-socthi.ads, g-socket.adb, g-socthi-vxworks.adb, + g-socthi-vxworks.ads, g-socthi-mingw.ads, g-socthi-vms.ads, + g-socthi-vms.adb: Move signalling + fd management to a nested package, so that they can conveniently be + moved to a subunit that is shared across Windows, VMS, and VxWorks + (Ada implementation) or completed with imported bodies from socket.c + (UNIX case). + (Read_Signalling_Fd, Write_Signalling_Fd, Create_Signalling_Fds): New + subprograms. + (Check_Selector): Use Read_Signalling_Fd to read and discard data from + the signalling file descriptor. + (Abort_Selector): Use Write_Signalling_Fd to write dummy data to the + signalling file descriptor. + (Create_Selector): Use new C-imported subprogram Create_Signalling_Fds + instead of creating a pair of sockets for signalling here. + + * g-socthi.adb: Ditto. + Set the runtime process to ignore SIGPIPEs on platforms that support + neither SO_NOSIGPIPE nor MSG_NOSIGNAL functionality. + + * g-socthi-mingw.adb: Ditto. + (WS_Version): Use Windows 2.2. + Use Winsock 2.2 (instead of 1.1) for the GNAT.Socket API. + + * g-soliop-mingw.ads: Link with ws2_32 for Windows 2.x support. + Use Winsock 2.2 (instead of 1.1) for the GNAT.Socket API. + + * Makefile.in: New libgnat pair g-stsifd.adb + Vincent Celier + + * a-calend-vms.ads, a-calend.ads, a-calend.adb, a-calend-vms.adb: + New version of Ada.Calendar which supports the new upper bound of Ada + time (2399-12-31 86_399.999999999). + The following modifications have been made to the package: + - New representation of time as count of nanoseconds since the start of + Ada time (1901-1-1 0.0). + - Target independent Split and Time_Of routines which service both + Ada 95 and Ada 2005 code. + - Target independent interface to the Ada 2005 children of Calendar. + - Integrated leap seconds into Ada 95 and Ada 2005 mode. + - Handling of non-leap centenial years. + - Updated clock function. + - Updated arithmetic and comparison operators. + + * a-caldel.adb (To_Duration): Add call to target independent routine in + Ada.Calendar to handle the conversion of time to duration. + + * sysdep.c (__gnat_localtime_tzoff): Test timezone before setting off + (UTC Offset). + If timezone is obviously incorrect (outside of -14 hours .. 14 hours), + set off to 0. + (__gnat_localtime_tzoff for Lynx and VxWorks): Even though these + targets do not have a natural time zone, GMT is used as a default. + (__gnat_get_task_options): New. + + * a-direct.adb (Modification_Time): Add with and use clauses for + Ada.Calendar and Ada. + Calendar.Formatting. Remove with clause for Ada.Unchecked_Conversion + since it is no longer needed. + (Duration_To_Time): Removed. + (OS_Time_To_Long_Integer): Removed. + (Modification_Time): Rewritten to use Ada.Calendar and Ada.Calendar. + Formatting Time_Of routines which automatically handle time zones, + buffer periods and leap seconds. + + * a-calari.ads, a-calari.adb ("+", "-", Difference): Add calls to + target independent routines in Ada.Calendar. + + * a-calfor.ads, a-calfor.adb: + Code cleanup and addition of validity checks in various routines. + (Day_Of_Week, Split, Time_Of): Add call to target independent routine in + Ada.Calendar. + + * a-catizo.ads, a-catizo.adb (UTC_Time_Offset): Add call to target + independent routine in Ada.Calendar. + +2007-04-06 Olivier Hainque + + * adaint.c: + (convert_addresses): Adjust prototype and dummy definition to expect an + extra file_name argument. + + * gmem.c (__gnat_convert_addresses): Wrapper to convert_addresses, + filling the now expected file_name argument with the appropriate + argv[0] expansion. + (__gnat_gmem_a2l_initialize, __gnat_gmem_read_next_frame): Use it. + (tracebk): Array of void * instead of char *, corresponding to what + convert_addresses expects. + (exename): New static global, to hold the executable file name to be + used in all convert_addresses invocations. + (gmem_read_backtrace, __gnat_gmem_symbolic): Account for tracebk type + change. + (__gnat_gmem_a2l_initialize): Resolve exename. + (__gnat_convert_addresses): Use exename as the convert_addresses + file_name argument. + + * g-trasym.adb (Symbolic_Traceback): Adjust signature of imported + "convert_addresses", now expecting a filename argument. Import the + necessary entities to compute the filename to use and pass it to + convert_addresses. + +2007-04-06 Matt Gingell + + * system-aix.ads: Back out previous change. + (Functions_Return_By_DSP): Removed + +2007-04-06 Pascal Obry + + * s-osprim-mingw.adb (Timed_Delay): Use the right clock (standard one + or the monotonic used by Ada.Real_Time) to compute the sleep duration + on Windows. + +2007-04-06 Jose Ruiz + + * s-osinte-vxworks.ads, s-osinte-vxworks.adb (VX_FP_TASK): Remove this + function. Its value changes in different VxWorks versions, and it is + now handled by the function __gnat_get_task_options. + + * s-taprop-vxworks.adb (Create_Task): Call the function + __gnat_get_task_options to get the required options for creating a task. + +2007-04-06 Pascal Obry + Thomas Quinot + + * adaint.c: Replace all occurences of S2WS to S2WSU (Unicode) when + dealing with filename. + (__gnat_fopen): Call the proper macro (8bits or UTF8) to convert the + filename from a standard string to a wide-string depending on the + encoding value. + (__gnat_freopen): Idem. + (__gnat_current_time): New function (wrapper for time(3) standard C + function). + + * g-os_lib.ads (Current_Time): New function. Returns the current + system time as an OS_Time value. + + * s-osprim.ads (Clock): Add more precise definition of UNIX epoch. + (Monotonic_Clock): Same. + +2007-04-06 Quentin Ochem + + * ali.ads, ali.adb (Get_Nat): Raise an exception if the file cursor is + not on a natural. + (Scan_ALI): Cancel the xref line if there has been a reading ALI error. + +2007-04-06 Jose Ruiz + + * a-retide.adb: Add elaboration code to ensure that the tasking run + time is initialized when using delay operations even when no task is + created. + +2007-04-06 Javier Miranda + + * a-tags.ads, a-tags.adb (Object_Specific_Data): Remove + component Num_Prim_Ops. + (Set_Num_Prim_Ops): Removed. + Remove all the assertions because all the routines of this + package are inline always. + (Get_Offset_Index): Add support to primary dispatch tables. + Move the documentation about the dispatch table to a-tags.ads + (Set_External_Tag): Removed + (Inherit_TSD): Removed. + (Interface_Data_Element, Interfaces_Array, Interface_Data): Declarations + moved to a-tags.ads + (Displace, IW_Membership, Inherit_TSD, Interface_Ancestor_Tags, + Register_Interface_Tag, Set_Offset_To_Top): Update all the occurrences + of the TSD field "Table" because this field has been renamed to + "Ifaces_Table". + (Inherit_CPP_DT): Removed. + (K_Typeinfo, K_Offset_To_Top, K_Tagged_Kind, K_Signature, + Cstring, Tag_Table, Type_Specific_Data, Dispatch_Table): These + declarations have been moved to a-tags.ads + (Check_Size): Removed. + (Expanded_Name): Updated to get access to the new field of TSD + containing the address of the expanded name. + (Get_Access_Level/Set_Access_Level): Removed. + (Get_Predefined_Prim_Op_Address): Removed. + (Set_Predefined_Prim_Op_Address): Removed. + (Get_Prim_Op_Address/Set_Prim_Op_Address): Removed. + (Get_Remotely_Callable/Set_Remotely_Callable): Removed. + (Set_Expanded_Name): Removed. + (Inherit_DT): Removed. + (Inherit_CPP_DT): Removed. + (Set_RC_Offset): Removed. + (Set_TSD): Removed. + (Base_Address): New function that displaces "this" to point to the base + of the object (that is, to point to the primary tag of the object). + +2007-04-06 Ed Schonberg + Javier Miranda + + * exp_ch3.ads, exp_ch3.adb (Analyze_N_Full_Type_Declaration): For an + anonymous access component, do not create a master_id if type already + has one, as may happen if the type is a subcomponent of a packed array + type. + (Build_Init_Procedure, Component_Needs_Simple_Initialization, + Initialize_Tag): Remove code associated with the old CPP pragmas. + CPP_Virtual and CPP_Vtable are no longer supported. + (Build_Offset_To_Top_Internal): Add support for concurrent record types + (Build_Offset_To_Top_Functions): Add support for concurrent record types + (Freeze_Record_Type): Remove call to + Init_Predefined_Interface_Primitives. + (Init_Secondary_Tags.Initialize_Tag): New subprogram containing all the + code required to initialize the tags of the secondary dispatch tables. + This leaves the algoritm more clear. + (Init_Secondary_Tags): Add support for concurrent record types + (Make_Predefined_Primitive_Specs): Code cleanup. + (Predefined_Primitive_Bodies): Code cleanup. + (Build_Master_Renaming): New local subprogram. + (Expand_N_Full_Type_Declaration): Build the master_id associated with + anonymous access to task type components. + (Expand_N_Subtype_Indication): The bounds of a range constraint in a + subtype indication are resolved during analysis, and must not be done + here. + (Stream_Operation_OK): Check Restriction_Active before RTE_Available. + +2007-04-06 Geert Bosch + Ed Schonberg + Javier Miranda + Bob Duff + + * exp_ch4.adb (Expand_N_Type_Conversion): Remove special processing + for conversion of a Float_Type'Truncation to integer. + + * exp_attr.adb (Is_Inline_Floating_Point_Attribute): New function to + check if a node is an attribute that can be handled directly by the + back end. + (Expand_N_Attribute_Reference): Suppress expansion of floating-point + attributes that can be handled directly by the back end. + (Expand_N_Attribute_Reference, case 'Access and 'Unchecked_Access): + use new predicate Is_Access_Protected_Subprogram_Type. + (Expand_N_Attribute_Reference, case 'Write): The reference is legal for + and Unchecked_Union if it is generated as part of the default Output + procedure for a type with default discriminants. + (Expand_N_Attribute_Reference): Avoid the expansion of dispatching calls + if we are compiling under restriction No_Dispatching_Calls. + (Constrained): Use Underlying_Type, in case the type is private without + discriminants, but the full type has discriminants. + (Expand_N_Attribute_Reference): Replace call to Get_Access_Level by + call to Build_Get_Access_Level. + (Expand_N_Attribute_Reference): The use of 'Address with class-wide + interface objects requires a call to the run-time subprogram that + returns the base address of the object. + (Valid_Conversion): Improve error message on illegal attempt to store + an anonymous access to subprogram value into a record component. + + * sem_res.adb (Resolve_Equality_Op): Detect ambiguity for "X'Access = + null". + (Simplify_Type_Conversion): New procedure that performs simplification + of Int_Type (Float_Type'Truncation (X)). + (Resolve_Type_Conversion): Call above procedure after resolving operand + and before performing checks. This replaces the existing ineffective + code in Exp_Ch4. + (Set_String_Literal_Subtype): When creating the internal static lower + bound subtype for a string literal, use a newly created copy of the + subtree representing the lower bound. + (Resolve_Call): Exclude build-in-place function calls from transient + scope treatment. Update comments to describe this exception. + (Resolve_Equality_Op): In case of dispatching call check violation of + restriction No_Dispatching_Calls. + (Resolve_Call): If the call returns an array, the context imposes the + component type of the array, and the function has one non-defaulted + parameter, rewrite the call as the indexing of a call with a single + parameter, to handle an Ada 2005 syntactic ambiguity for calls written + in prefix form. + (Resolve_Actuals): If an actual is an allocator for an access parameter, + the master of the created object is the innermost enclosing statement. + (Remove_Conversions): For a binary operator, check if type of second + formal is numeric, to check if an abstract interpretation is present + in the case of exponentiation as well. + +2007-04-06 Ed Schonberg + Bob Duff + + * atree.h, atree.ads, atree.adb (Copy_Node_With_Replacement): When + copying a parameter list in a call, set properly the First_Named_Formal + and Next_Named_Formal fields in the new list and in the enclosing call. + (Watch_Node,New_Node_Breakpoint,New_Node_Debugging_Output): Shorten + names, to ease typing in the debugger. Improve comments. + (Watch_Node): New variable, intended to be set in the debugger. + (New_Node_Breakpoint): New do-nothing procedure to set a breakpoint on, + called when the watched node is created. + (New_Node_Debugging_Output): Combined version of local procedures + New_Node_Debugging_Output and New_Entity_Debugging_Output, now global, + with a parameter so that conditional breakpoints like "if Node = 12345" + work. + (New_Node, New_Entity): Call the global New_Node_Debugging_Output. + Add Elist1 function + +2007-04-06 Thomas Quinot + Ed Schonberg + Gary Dismukes + + * checks.ads, checks.adb (Selected_Range_Checks): No range check is + required for a conversion between two access-to-unconstrained-array + types. + (Expr_Known_Valid): Validity checks do not apply to discriminants, but + to discriminant constraints on discriminant objects. This rule must + apply as well to discriminants of protected types in private components. + (Null_Exclusion_Static_Checks): If No_Initialization is set on an + object of a null-excluding access type then don't require the + the object declaration to have an expression and don't emit a + run-time check. + +2007-04-06 Arnaud Charlet + Eric Botcazou + + * gnatvsn.ads, comperr.adb (Get_Gnat_build_Type): Renamed Build_Type + and made constant. + + * comperr.ads, comperr.adb (Compiler_Abort): Add third parameter + Fallback_Loc. Use it as the sloc info when Current_Error_Node doesn't + carry any. + + * fe.h (Compiler_Abort): Add third parameter. + + * misc.c (internal_error_function): Build third argument from current + input location and pass it to Compiler_Abort. + +2007-04-06 Gary Dismukes + + * cstand.adb (Create_Standard): When the target's storage unit size is + greater than a byte, set Has_Non_Standard_Rep and Has_Pragma_Pack on + Standard_String. + +2007-04-06 Nicolas Roche + + * cstreams.c (__gnat_full_name): Fix issues on VxWorks 6.x for which + absolute path can have the following form: device:/a/b. In this case + '/' should be inserted between the path and the filename. + +2007-04-06 Olivier Hainque + Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : Associate an external + VAR_DECL to a CONST_DECL we make for a public constant when we know the + corresponding definition has created the so made visible variable. + Handle anonymous access to protected subprogram. + (gnat_to_gnu_entity) : Do not make the underlying type of an + object with an address clause volatile. Re-enable original fix. + : Set TYPE_REF_CAN_ALIAS_ALL on the reference type + too. + (gnat_to_gnu_entity) : Retrieve the TYPE_DECL + associated with either the Equivalent or Root type, instead of the + naked type node. + (gnat_to_gnu_entity): Manually mark the top of the DECL_FIELD_OFFSET + subtree for every field of a global record type. + (gnat_to_gnu_entity) : If the subtype has + discriminants, invoke again variable_size on its newly computed sizes. + +2007-04-06 Robert Dewar + Thomas Quinot + Ed Schonberg + Bob Duff + + * einfo.ads, einfo.adb: (First_Component_Or_Discriminant): New function + (Next_Component_Or_Discriminant): New function and procedure + (First_Index, First_Literal, Master_Id, + Set_First_Index, Set_First_Literal, Set_Master_Id): + Add missing Ekind assertions. + (Is_Access_Protected_Subprogram_Type): New predicate. + (Has_RACW): New entity flag, set on package entities to indicate that + the package contains the declaration of a remote accecss-to-classwide + type. + (E_Return_Statement): This node type has the Finalization_Chain_Entity + attribute, in case the result type has controlled parts. + (Requires_Overriding): Add this new flag, because "requires + overriding" is subtly different from "is abstract" (see AI-228). + (Is_Abstract): Split Is_Abstract flag into Is_Abstract_Subprogram and + Is_Abstract_Type. Make sure these are called only when appropriate. + (Has_Pragma_Unreferenced_Objects): New flag + + * exp_ch5.adb (Expand_N_Assignment_Statement): If the left-hand side is + class-wide, the tag of the right-hand side must be an exact match, not + an ancestor of that of the object on left-hand side. + (Move_Activation_Chain): New procedure to create the call to + System.Tasking.Stages.Move_Activation_Chain. + (Expand_N_Extended_Return_Statement): Generate code to call + System.Finalization_Implementation.Move_Final_List at the end of a + return statement if the function's result type has controlled parts. + Move asserts to Build_In_Place_Formal. + (Move_Final_List): New function to create the call statement. + (Expand_N_Assignment_Statement): In case of assignment to a class-wide + tagged type, replace generation of call to the run-time subprogram + CW_Membership by call to Build_CW_Membership. + (Expand_N_Return_Statement): Replace generation of call to the run-time + subprogram Get_Access_Level by call to Build_Get_Access_Level. + (Expand_N_Simple_Function_Return): Replace generation of call to the + run-time subprogram Get_Access_Level by call to Build_Get_Access_Level. + + * exp_ch6.ads, exp_ch6.adb (Expand_Call): Use new predicate + Is_Access_Protected_Subprogram_Type, to handle both named and anonymous + access to protected operations. + (Add_Task_Actuals_To_Build_In_Place_Call): New procedure to add the + master and chain actual parameters to a build-in-place function call + involving tasks. + (BIP_Formal_Suffix): Add new enumeration literals to complete the case + statement. + (Make_Build_In_Place_Call_In_Allocator, + Make_Build_In_Place_Call_In_Anonymous_Context, + Make_Build_In_Place_Call_In_Assignment, + Make_Build_In_Place_Call_In_Object_Declaration): Call + Add_Task_Actuals_To_Build_In_Place_Call with the appropriate master. + (Expand_Inlined_Call): If the subprogram is a null procedure, or a + stubbed procedure with a null body, replace the call with a null + statement without using the full inlining machinery, for efficiency + and to avoid invalid values in source file table entries. + + * exp_ch8.adb (Expand_N_Object_Renaming_Declaration): Add support for + renamings of calls to build-in-place functions. + + * rtsfind.adb (RTE_Record_Component_Available): New subprogram that + provides the functionality of RTE_Available to record components. + (RTU_Entity): The function Entity has been renamed to RTU_Entity + to avoid undesired overloading. + (Entity): New subprogram that returns the entity for the referened + unit. If this unit has not been loaded, it returns Empty. + (RE_Activation_Chain_Access, RE_Move_Activation_Chain): New entities. + Remove no longer used entities. + (RE_Finalizable_Ptr_Ptr, RE_Move_Final_List): New entities. + (RE_Type_Specific_Data): New entity. + (RE_Move_Any_Value): New entity. + (RE_TA_A, RE_Get_Any_Type): New entities. + (RE_Access_Level, RE_Dispatch_Table, E_Default_Prim_Op_Count, + RE_Prims_Ptr, RE_RC_Offset, RE_Remotely_Callable, + RE_DT_Typeinfo_Ptr_Size, RE_Cstring_Ptr, RE_DT_Expanded_Name): Added. + (Entity): New subprogram that returns the entity for the referened + unit. If this unit has not been loaded, it returns Empty. + (RTE): Addition of a new formal that extends the search to the scopes + of the record types found in the chain of the package. + + * sem_ch6.ads, sem_ch6.adb (Check_Overriding_Indicator): Print + "abstract subprograms must be visible" message, whether or not the type + is an interface; that is, remove the special case for interface types. + (Analyze_Function_Return): Remove error message "return of task objects + is not yet implemented" because this is now implemented. + (Create_Extra_Formals): Add the extra master and activation chain + formals in case the result type has tasks. + Remove error message "return of limited controlled objects is not yet + implemented". + (Create_Extra_Formals): Add the extra caller's finalization list formal + in case the result type has controlled parts. + (Process_Formals): In case of access formal types there is no need + to continue with the analysis of the formals if we already notified + errors. + (Check_Overriding_Indicator): Add code to check overriding of predefined + operators. + (Create_Extra_Formals): Prevent creation of useless Extra_Constrained + flags for formals that do not require them,. + (Enter_Overloaded_Entity): Do not give -gnatwh warning message unless + hidden entity is use visible or directly visible. + (Analyze_Abstract_Subprogram_Declaration,Analyze_Subprogram_Body, + Analyze_Subprogram_Declaration,Analyze_Subprogram_Specification, + Check_Conventions,Check_Delayed_Subprogram,Make_Inequality_Operator, + New_Overloaded_Entity): Split Is_Abstract flag into + Is_Abstract_Subprogram and Is_Abstract_Type. + + * s-finimp.ads, s-finimp.adb (Move_Final_List): New procedure to move + a return statement's finalization list to the caller's list, used for + build-in-place functions with result type with controlled parts. + Remove no longer used entities. + + * s-taskin.ads (Activation_Chain): Remove pragma Volatile. It is no + longer needed, because the full type is now limited, and therefore a + pass-by-reference type. + (Foreign_Task_Level): New constant. + + * s-tassta.ads, s-tassta.adb (Move_Activation_Chain): New procedure to + move tasks from the activation chain belonging to a return statement to + the one passed in by the caller, and update the master to the one + passed in by the caller. + (Vulnerable_Complete_Master, Check_Unactivated_Tasks): Check the master + of unactivated tasks, so we don't kill the ones that are being returned + by a build-in-place function. + (Create_Task): Ignore AI-280 for foreign threads. + +2007-04-06 Ed Schonberg + Robert Dewar + Bob Duff + Gary Dismukes + + * errout.adb (Unwind_Internal_Type): Use predicate + Is_Access__Protected_Subprogram_Type. + + * freeze.adb (Size_Known): Use First/Next_Component_Or_Discriminant + (Freeze_Entity, packed array case): Do not override explicitly set + alignment and size clauses. + (Freeze_Entity): An entity declared in an outer scope can be frozen if + the enclosing subprogram is a child unit body that acts as a spec. + (Freeze_Entity): Use new predicate Is_Access_Protected_Subprogram_Type. + (Freeze_Record_Type): New Ada 2005 processing for reverse bit order + Remove all code for DSP option + + * layout.adb (Layout_Record_Type): Use First/ + Next_Component_Or_Discriminant + (Layout_Type): Use new predicate Is_Access_Protected_Subprogram_Type, + to handle properly the anonymous access case. + + * sem_attr.adb (Build_Access_Object_Type): Use E_Access_Attribute_Type + for all access attributes, because overload resolution should work the + same for 'Access, 'Unchecked_Access, and 'Unrestricted_Access. This + causes the error message for the ambiguous "X'Access = Y'Access" and + "X'Unrestricted_Access = Y'Access" and so forth to match. + (Resolve_Attribute, case 'Access): Remove use of Original_Access_Type, + now that anonymous access to protected operations have their own kind. + (Resolve_Attribute): In case of dispatching call check the violation of + restriction No_Dispatching_Calls. + (Check_Array_Type): Check new -gnatyA array index style option + + * sem_ch3.ads, sem_ch3.adb (Derived_Type_Declaration): Reject an + attempt to derive from a synchronized tagged type. + (Analyze_Type_Declaration): If there is a incomplete tagged view of the + type, inherit the class-wide type already created, because it may + already have been used in a self-referential anonymous access component. + (Mentions_T): Recognize self-referential anonymous access components + that use (a subtype of) the class-wide type of the enclosing type. + (Build_Derived_Record_Type): Add earlier setting of Is_Tagged_Type. Pass + Derived_Type for Prev formal on call to + Check_Anonymous_Access_Components rather than Empty. + (Make_Incomplete_Type_Declaration): Add test for case where the type has + a record extension in deciding whether to create a class-wide type, + rather than just checking Tagged_Present. + (Replace_Anonymous_Access_To_Protected_Subprogram): Procedure applies + to stand-alone object declarations as well as component declarations. + (Array_Type_Declaration): Initialize Packed_Array_Type to Empty, to + prevent accidental overwriting when enclosing package appears in + a limited_with_clause. + (Array_Type_Declaration): If the component type is an anonymous access, + the associated_node for the itype is the type declaration itself. + (Add_Interface_Tag_Components): Modified to support concurrent + types with abstract interfaces. + (Check_Abstract_Interfaces): New subprogram that verifies the ARM + rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2). + (Build_Derived_Record_Type): Add call to Analyze_Interface_Declaration + to complete the decoration of synchronized interface types. Add also + a call to Check_Abstract_Interfaces to verify the ARM rules. + (Derive_Interface_Subprograms): Modified to support concurrent types + with abstract interfaces. + (Analyze_Subtype_Indication): Resolve the range with the given subtype + mark, rather than delaying the full resolution depending on context. + (Analyze_Component_Declaration,Analyze_Interface_Declaration, + Analyze_Object_Declaration,Analyze_Subtype_Declaration, + Array_Type_Declaration,Build_Derived_Record_Type, + Build_Discriminated_Subtype,Check_Abstract_Overriding,Check_Completion, + Derive_Interface_Subprograms,Derive_Subprogram,Make_Class_Wide_Type, + Process_Full_View,Record_Type_Declaration): Split Is_Abstract flag into + Is_Abstract_Subprogram and Is_Abstract_Type. Make sure these are + called only when appropriate. + (Copy_And_Swap): Copy Has_Unreferenced_Objects flag from full type + to private type. + (Analyze_Subtype_Declaration): For an access subtype declaration, create + an itype reference for the anonymous designated subtype, to prevent + scope anonmalies in gigi. + (Build_Itype_Reference): New utility, to simplify construction of such + references. + +2007-04-06 Vincent Celier + + * errutil.adb (Initialize): Initialize warnings table, if all warnings + are suppressed, supply an initial dummy entry covering all possible + source locations. + + * make.adb (Scan_Make_Arg): Reject options that should start with "--" + and start with only one, such as "-RTS=none". + (Collect_Arguments): Do not check for sources outside of projects. + Do not collect arguments if project is externally built. + (Compile_Sources): Do nothing, not even check if the source is up to + date, if its project is externally built. + (Compile): When compiling a predefined source, add -gnatpg + as the second switch, after -c. + (Compile_Sources): Allow compilation of Annex J renames without -a + (Is_In_Object_Directory): Check if the ALI file is in the object + even if there is no project extension. + (Create_Binder_Mapping_File): Only put a unit in the mapping file for + gnatbind if the ALI file effectively exists. + (Initialize): Add the directory where gnatmake is invoked in front of + the path if it is invoked from a bin directory, even without directory + information, so that the correct GNAT tools will be used when spawned + without directory information. + + * makeusg.adb: Change switch -S to -eS + Add lines for new switches -we, -wn and -ws + Add line for new switch -p + + * prj-proc.adb (Process): Set Success to False when Warning_Mode is + Treat_As_Error and there are warnings. + + * switch-m.ads, switch-m.adb (Normalize_Compiler_Switches): Do not skip + -gnatww Change gnatmake switch -S to -eS + (Scan_Make_Switches): Code reorganisation. Process separately multi + character switches and single character switches. + (Scan_Make_Switches): New Boolean out parameter Success. Set Success to + False when switch is not recognized by gnatmake. + (Scan_Make_Switches): Set Setup_Projects True when -p or + --create-missing-dirs is specified. + + * fname.adb (Is_Predefined_File_Name): Return True for annex J + renamings Calendar, Machine_Code, Unchecked_Conversion and + Unchecked_Deallocation only when Renamings_Included is True. + + * par.adb: Allow library units Calendar, Machine_Code, + Unchecked_Conversion and Unchecked_Deallocation to be recompiled even + when -gnatg is not specified. + (P_Interface_Type_Definition): Remove the formal Is_Synchronized because + there is no need to generate always a record_definition_node in case + of synchronized interface types. + (SIS_Entry_Active): Initialize global variable to False + (P_Null_Exclusion): For AI-447: Add parameter Allow_Anonymous_In_95 to + indicate cases where AI-447 says "not null" is legal. + + * makeutl.ads, makeutil.adb (Executable_Prefix_Path): New function + + * makegpr.adb (Check_Compilation_Needed): Take into account dependency + files with with several lines starting with the object fileb name. + (Scan_Arg): Set Setup_Projects True when -p or --create-missing-dirs + is specified. + (Initialize): Add the directory where gprmake is invoked in front of the + path, if it is invoked from a bin directory or with directory + information, so that the correct GNAT tools will be used when invoked + directly. + (Check_Compilation_Needed): Process correctly backslashes on Windows. + + * vms_data.ads: Update switches/qualifiers + +2007-04-06 Ed Schonberg + Thomas Quinot + + * exp_aggr.adb: + If the array component is a discriminated record, the array aggregate + is non-static even if the component is given by an aggregate with + static components. + (Expand_Record_Aggregate): Use First/Next_Component_Or_Discriminant + (Convert_Aggr_In_Allocator): If the allocator is for an access + discriminant and the type is controlled. do not place on a finalization + list at this point. The proper list will be determined from the + enclosing object. + (Build_Record_Aggr_Code): If aggregate has box-initialized components, + initialize record controller if needed, before the components, to ensure + that they are properly finalized. + (Build_Record_Aggr_Code): For the case of an array component that has a + corresponding array aggregate in the record aggregate, perform sliding + if required. + +2007-04-06 Javier Miranda + Gary Dismukes + Ed Schonberg + + * exp_ch13.adb (Expand_External_Tag_Definition): Replace call to the + run-time subprogram Set_External_Tag by call to Build_Set_External_Tag. + + * exp_ch4.adb (Expand_Allocator_Expression): Don't perform a run-time + accessibility on class-wide allocators if the allocator occurs at the + same scope level as the allocator's type. The check is guaranteed to + succeed in that case, even when the expression originates from a + parameter of the containing subprogram. + (Expand_N_Op_Eq): Do nothing in case of dispatching call if compiling + under No_Dispatching_Calls restriction. During the semantic analysis + we already notified such violation. + (Tagged_Membership): Constant folding. There is no need to check + the tag at run-time if the type of the right operand is non + class-wide abstract. + Replace call to Is_Ancestor by call to Is_Parent + to support concurrent types with interface types. + (Expand_N_Allocator): Add an assertion associated with the generation + of the master_id. + (Expand_N_Slice): Do not enable range check to nodes associated + with the frontend expansion of the dispatch table. + (Is_Local_Access_Discriminant): Subsidiary function to + Expand_N_Allocator. + (Tagged_Membership): Replace generation of call to the run-time + subprogram CW_Membership by call to Build_CW_Membership. + (Expand_Allocator_Expression): Replace generation of call to the + run-time subprogram Get_Access_Level by call to Build_Get_Access_Level. + + * exp_disp.ads, exp_disp.adb (Make_DT): Code reorganization to + initialize most the TSD components by means of an aggregate. + Modify the declaration of the object containing the TSD + because we now expand code that has a higher level of abstraction. + The TSD has a discriminant containing the Inheritance Depth Level, + value that is used in the membership test but also to fix the size + of the table of ancestors. + (Expand_Interface_Conversion): Insert function body at the closest place + to the conversion expression, to prevent access-before-elaboration + errors in the backend. + Code improved to reduce the size of the dispatch table if + compiling under restriction No_Dispatching_Calls plus code cleanup. + Code reorganization plus removal of calls to Set_Num_Prim_Ops + (Make_Secondary_DT): Remove call to Set_Num_Prim_Ops. + (Expand_Dispatching_Call): Minor code reorganization plus addition of + code to return immediately if compiling under No_Dispatching_Calls + restriction. + (Set_All_DT_Position): Remove code associated with the old CPP pragmas. + CPP_Virtual and CPP_Vtable are no longer supported. + (Expand_Interface_Conversion): Add missing support for interface type + derivations. + (Expand_Interface_Actuals): Replace calls to Is_Ancestor by calls to + Is_Parent to support concurrent types with interfaces. + (Init_Predefined_Interface_Primitives): Removed. + (Make_Secondary_DT): Modified to support concurrent record types. + (Set_All_DT_Position): Modified to support concurrent record types. + (Ada_Actions, Action_Is_Proc, Action_Nb_Arg): Remove entries associated + with Get_External_Tag, Inherit_TSD, Set_External_Tag. + (Ada_Actions, Action_Is_Proc, Action_Nb_Arg): Remove entry associated + with CW_Membership. + (Ada_Actions, Action_Is_Proc, Action_Nb_Arg): Remove entries associated + with Get_Access_Level, Get_Predefined_Prim_Op_Address, + Get_Prim_Op_Address Get_RC_Offset, Get_Remotely_Callable, Inherit_DT, + Set_Access_Level, Set_Expanded_Name, Set_Predefined_Prim_Op_Address, + Set_Prim_Op_Address, Set_RC_Offset, Set_Remotely_Callable, Set_TSD. + (Expand_Dispatching_Call): Replace generation of call to the run-time + subprograms Get_Predefined_Prim_Op_Address and Get_Prim_Op_Address by + calls to Build_Get_Predefined_Prim_Op_Address, and Build_Get_Prim_Op_ + Address. + (Fill_DT_Entry, Fill_Secondary_DT_Entry): Replace generation of call to + the run-time subprograms Set_Predefined_Prim_Op_Address and Set_Prim_ + Op_Address by calls to Build_Set_Predefined_Prim_Op_Address, and + Build_Set_Prim_Op_Address. + (Get_Remotely_Callable): Subprogram removed. + (Init_Predefined_Interface_Primitives): Replace generation of call to + the run-time subprograms Inherit_DT by call to Build_Inherit_Predefined_ + Prims. + + * sem_elab.adb (Set_Elaboration_Constraint): Replace the call to + First (Parameter_Associations ()) with the call to First_Actual that + returns an actual parameter expression for both named and positional + associations. + + * sem_disp.adb (Check_Dispatching_Call): In case of dispatching call + check violation of restriction No_Dispatching_Calls. + (Check_Controlling_Type): A formal of a tagged incomplete type is a + controlling argument. + + * exp_util.ads, exp_util.adb (Type_May_Have_Bit_Aligned_Components): Use + First/Next_Component_Or_Discriminant + (Insert_Actions): Add entries for new N_Push and N_Pop nodes + (Find_Implemented_Interface): Removed. All the calls to this subprogram + specify Any_Limited_Interface, and this functionality is already + provided by the function Has_Abstract_Interfaces. + (Find_Interface, Find_Interface_Tag, Find_Interface_ADT): Modified to + support concurrent types implementing interfaces. + (Find_Implemented_Interface): Removed. All the calls to this subprogram + specify kind Any_Limited_Interface, and this functionality is already + provided by the function Has_Abstract_Interfaces. + (Remove_Side_Effects): replace Controlled_Type by + CW_Or_Controlled_Type whenever the issue is related to + using or not the secondary stack. + + * par-ch12.adb (P_Formal_Type_Definition): Update calls to + P_Interface_Type_Definition to fulfill the new interface (the formal + Is_Synchronized is no longer required). + + * Make-lang.in (GNAT_ADA_OBJS): Addition of exp_atag.o + Update dependencies. + + * exp_atag.ads, exp_atag.adb: New file + +2007-04-06 Ed Schonberg + Bob Duff + Cyrille Comar + + * exp_ch7.ads, exp_ch7.adb (Find_Final_List): If the access type is + anonymous, use finalization list of enclosing dynamic scope. + (Expand_N_Package_Declaration): For a library package declaration + without a corresponding body, generate RACW subprogram bodies in the + spec (just as we do for the task activation call). + (Convert_View): Split Is_Abstract flag into Is_Abstract_Subprogram and + Is_Abstract_Type. Make sure these are called only when appropriate. + Remove all code for DSP option + (CW_Or_Controlled_Type): new subprogram. + +2007-04-06 Eric Botcazou + Ed Schonberg + Gary Dismukes + + * exp_ch9.ads, exp_ch9.adb (Family_Offset): Add new 'Cap' boolean + parameter. If it is set to true, return a result capped according to + the global upper bound for the index of an entry family. + (Family_Size): Add new 'Cap' boolean parameter. Pass it to Family_Offset + (Build_Find_Body_Index): Adjust for above change. + (Entry_Index_Expression): Likewise. + (Is_Potentially_Large_Family): New function extracted from... + (Collect_Entry_Families): ...here. Call it to detect whether the family + is potentially large. + (Build_Entry_Count_Expression): If the family is potentially large, call + Family_Size with 'Cap' set to true. + (Expand_N_Protected_Type_Declaration, Expand_N_Protected_Body): Generate + a protected version of an operation declared in the private part of + a protected object, because they may be invoked through a callback. + (Set_Privals): If the type of a private component is an anonymous access + type, do not create a new itype for each protected body. + If the body of a protected operation creates + controlled types (including allocators for class-widetypes), the + body of the corresponding protected subprogram must include a + finalization list. + (Build_Activation_Chain_Entity): Build the chain entity for extended + return statements. + (Type_Conformant_Parameters): Use common predicate Conforming_Types + to determine whether operation overrides an inherited primitive. + (Build_Wrapper_Spec): Add code to examine the parents while looking + for a possible overriding candidate. + (Build_Simple_Entry_Call): Set No_Initialization on the object used to + hold an actual parameter value since its initialization is separated + from the the declaration. Prevents errors on null-excluding access + formals. + +2007-04-06 Thomas Quinot + Pablo Oliveira + + * exp_dist.ads, exp_dist.adb (Build_To_Any_Call, Build_From_Any_Call): + Do an Unchecked_Conversion to handle the passage from the Underlying + Type to the Base Type when calling Build_To_Any_Call and + Build_From_Any_Call. + (Build_Actual_Object_Declaration): Set Object's Ekind to E_Variable or + E_Constant, depending upon Variable formal. + (GARLIC_Support.Build_Subprogram_Receiving_Stubs, + PolyORB_Support.Build_Subprogram_Receiving_Stubs): For a formal + parameter that requires an extra constrained parameter, declare + temporary for actual as a variable, not a constant. + (Add_RACW_Primitive_Declarations_And_Bodies): Generate bodies only when + the unit being compiled is the one that contains the stub type. + Change primitive operation name for the RACW associated with a RAS + from Call to _Call so it cannot clash with any legal identifier. + (PolyORB_Support.Add_RACW_Write_Attribute): Remove unused constant + Is_RAS. + (Append_RACW_Bodies): New subprogram. + (Expand_Receiving_Stubs_Bodies): Pass a 'Stmts' list to + Add_Receiving_Stubs_To_Declarations functions. + When expanding a package body, this list correspond to the + statements in the HSS at the end of the pacakge. + When expanding a package spec, this list correspond to the + spec declarations. + (Add_Receiving_Stubs_To_Declarations): Append the function + registering the receiving stubs at the end of the 'Stmts' list. + (RCI_Package_Locator): Pass the new Version generic formal when + instantiating a RCI_Locator package. + (Build_From_Any_Function): To compute the High bound for an + unconstrained array actual, we add the Low bound with the length. + Thus we must convert the low bound and the length to an appropriate + type before doing the sum. + (Build_Subprogram_Receiving_Stubs, PolyORB): + * Retrieve the extra formals parameters at the + end of the parameter stream. + * Use Move_Any_Value to write back out parameters + after executing the request as it is more efficient + than Copy_Any_Value. + * Build the any containing Extra Formals with the + appropriate typecode. + (PolyORB_Support.Helpers.Append_Record_Traversal): Nothing to do for an + empty Component_List. + (Build_Actual_Object_Declaration): New subprogram. Build and insert into + the tree the declaration for an object that serves as actual parameter + in server-side stubs. + (GARLIC_Support.Build_Subprogram_Receiving_Stubs, + PolyORB_Support.Build_Subprogram_Receiving_Stubs): + Use Build_Actual_Object_Declaration to prepare the actuals. + (Add_Parameter_To_NVList): Set the parameter mode to In for + Extra Constrained Parameters. + (Build_General_Calling_Stubs): Set the parameter type to boolean for + Extra Constrained parameters. + (Build_To_Any_Function, Build_From_Any_Function, + Built_TypeCode_Function): When Typ is implicit, call the correct + function with the first not implicit parent type. + (TC_Rec_Add_Process_Element, FA_Rec_Add_Process_Element, + (FA_Ary_Add_Process_Element): When Datum is an Any, we cannot infer the + typecode from the Etype. Therefore we retrieve the correct typecode + with a call to Get_Any_Type. + (Copy_Specification): Do controlling formal type substitution based on + Is_Controlling_Formal flag, instead of caller-provided object type. + (Build_Subprogram_Calling_Stubs): When retrieveing the original spec for + a RACW primitive operation, we might get a subprogram declaration for an + ancestor of the RACW designated type (not for the designated type + itself), in the case where this operation is inherited. In this case we + have no easy means of determining the original tagged type for which + the primitive was declared, so instead we now rely on + Copy_Specification to use the Is_Controlling_Formal flag to determine + which formals require type substitution. + +2007-04-06 Robert Dewar + Ed Schonberg + + * exp_intr.adb (Expand_Exception_Call): Calls to subprograms in + GNAT.Current_Exception are not allowed if pragma Restrictions + (No_Exception_Propagation) is set and in any case make the associated + handler unsuitable as a target for a local raise statement. + (Expand_Dispatching_Constructor_Call): Replace generation of call to the + run-time subprogram CW_Membership by call to Build_CW_Membership. + (Expand_Dispatching_Constructor_Call): If the dispatching tag is given + by a function call, a temporary must be created before expanding the + Constructor_Call itself, to prevent out-of-order elaboration in the + back-end when stack checking is enabled.. + +2007-04-06 Ed Schonberg + + * exp_pakd.adb (Expand_Packed_Boolean_Operator): The bounds of the + result are the bounds of the left operand, not the right. + +2007-04-06 Ed Schonberg + + * exp_strm.adb + (Build_Mutable_Record_Write_Procedure): For an Unchecked_Union type, use + discriminant defaults. + (Build_Record_Or_Elementary_Output_Procedure): Ditto. + (Make_Component_List_Attributes): Ditto. + +2007-04-06 Ed Schonberg + Bob Duff + + * sem_aggr.adb (Resolve_Record_Aggregate): In semantics-only mode treat + an association with a box as providing a value even though the + initialization procedure for the type is not available. + (Resolve_Record_Aggregate): Check that a choice of an association with a + box corresponds to a component of the type. + (Resolve_Record_Aggregate): Split Is_Abstract flag into + Is_Abstract_Subprogram and Is_Abstract_Type. + + * exp_tss.adb (Base_Init_Proc): Use Is_Type instead of Type_Kind for + assert. + + * inline.adb (Add_Inlined_Body): Split Is_Abstract flag into + Is_Abstract_Subprogram and Is_Abstract_Type. Make sure these are + called only when appropriate. + +2007-04-06 Olivier Hainque + + * g-alleve.ads (Low Level Vector type definitions): Map each to the + associated vector view instead of all to the unsigned char view. + + * g-altcon.adb (Generic_Conversions): New internal generic package, + offering facilities for all the Vector/View conversion routines + implemented by this unit. + (To_View/To_Vector - all versions): Reimplemented in a systematic + manner, using the internal Generic_Conversions facilities. + +2007-04-06 Pascal Obry + + * g-arrspl.adb (Free) [Element_Access]: New routine to free the source + string. + (Create): Free the source string before storing the new one. + +2007-04-06 Vincent Celier + + * g-debpoo.adb (Validity): New package with a complete new + implementation of subprograms Is_Valid and Set_Valid. + (Is_Valid): Move to local package Validity + (Set_Valid): Move to local package Validity + +2007-04-06 Arnaud Charlet + Pablo Oliveira + + * g-expect.adb (Get_Command_Output): When expanding the output buffer + we must ensure that there is enough place for the new data we are going + to copy in. + +2007-04-06 Thomas Quinot + + * g-md5.ads, g-md5.adb (Digest): Fix off-by-one error in padding + computation. + +2007-04-06 Jose Ruiz + Vincent Celier + + * gnatcmd.adb (B_Start): Add prefix of binder generated file. + (Stack_String): Add this String that contains the name of the Stack + package in the project file. + (Packages_To_Check_By_Stack): Add this list that contains the packages + to be checked by gnatstack, which are the naming and the stack packages. + (Check_Files): If no .ci files were specified for gnatstack we add all + the .ci files belonging to the projects, including binder generated + files. + (Non_VMS_Usage): Document that gnatstack accept project file switches. + (GNATCmd): Update the B_Start variable if we are in a VMS environment. + Add gnatstack to the list of commands that use project file related + switches, and get the single attribute Switches from the stack package + in a project file when calling gnatstack. Parse the -U flag for + processing files belonging to all projects in the project tree. + Remove all processing for command Setup + + * prj-attr.adb: Add new package Stack with single attribute Switches + + * vms_conv.ads (Command_Type): Add command Stack. + Move to body declarations that are only used in the body: types Item_Id, + Translation_Type, Item_Ptr, Item and its subtypes. + + * vms_conv.adb: (Initialize): Add data for new command Stack. + Add declarations moved from the spec: types Item_Id, Translation_Type, + Item_Ptr, Item and its subtypes. + (Cargs_Buffer): New table + (Cargs): New Boolean global variable + (Process_Buffer): New procedure to create arguments + (Place): Put character in table Buffer or Cargs_Buffer depending on the + value of Cargs. + (Process_Argument): Set Cargs when processing qualifiers for GNAT + COMPILE + (VMS_Conversion): Call Process_Buffer for table Buffer and, if it is not + empty, for table Cargs_Buffer. + (Initialize): Remove component Setup in Command_List + +2007-04-06 Vincent Celier + + * gprep.adb (Process_Files.Process_One_File): Use full file name when + issuing pragma Source_Reference. + +2007-04-06 Emmanuel Briot + + * g-regpat.adb (Parse_Posix_Character_Class): Fix handling of + [[:xdigit:]] character class. + Also raise an exception when an invalid character class is used. + +2007-04-06 Pascal Obry + + * i-cstrea.ads: (fopen): Add encoding parameter. + (freopen): Idem. + Change reference from a-sysdep.c to sysdep.c in comment. + Update copyright notice. + This set of patch add support for the encoding form parameter. + + * mingw32.h (S2WSU): New macro to convert from a string to a + wide-string using the UTF-8 encoding. The S2WS macro supports now only + standard 8bits encoding. + (WS2SU): As above but converting from wide-sring to string. + This is needed as it is necessary to have access to both versions in the + runtime for the form parameter encoding support. + This set of patch add support for the encoding form parameter. + (S2WS): Improve implementation to handle cases where the filename is not + UTF-8 encoded. In this case we default to using the current code page + for the conversion. + + * s-crtl-vms64.ads, s-crtl.ads (Filename_Encoding): New enumeration + type (UTF8, ASCII_8bits). This enumeration has a rep clause to match + the constants defined in adaint.h. + (fopen): Add encoding parameter. + (freopen): Idem. + + * s-ficobl.ads (AFCB): Add Encoding field to record the filename + encoding. This is needed for the Reset routine (freopen low level-call). + + * s-fileio.adb (Open): Decode encoding form parameter and set the + corresponding encoding value into AFCB structure. + (Reset): Pass the encoding value to freopen. + (Close): Move the call to Lock_Task to the beginning of the procedure. + +2007-04-06 Geert Bosch + Robert Dewar + + * i-fortra.ads: Add Double_Complex type. + + * impunit.adb: (Is_Known_Unit): New function + Add Gnat.Byte_Swapping + Add GNAT.SHA1 + Add new Ada 2005 units + Ada.Numerics.Generic_Complex_Arrays, Ada.Numerics.Generic_Real_Arrays, + Ada.Numerics.Complex_Arrays, Ada.Numerics.Real_Arrays, + Ada.Numerics.Long_Complex_Arrays, Ada.Numerics.Long_Long_Complex_Arrays, + Ada.Numerics.Long_Long_Real_Arrays and Ada.Numerics.Long_Real_Arrays + + * impunit.ads (Is_Known_Unit): New function + + * a-ngcoar.adb, a-ngcoar.ads, a-ngrear.adb, + a-ngrear.ads, a-nlcoar.ads, a-nllcar.ads, a-nllrar.ads, a-nlrear.ads, + a-nucoar.ads, a-nurear.ads, g-bytswa.adb, g-bytswa-x86.adb, + g-bytswa.ads, g-sha1.adb, g-sha1.ads, i-forbla.ads, i-forlap.ads, + s-gearop.adb, s-gearop.ads, s-gecobl.adb, s-gecobl.ads, s-gecola.adb, + s-gecola.ads, s-gerebl.adb, s-gerebl.ads, s-gerela.adb, s-gerela.ads: + New files. + + * Makefile.rtl: Add g-bytswa, g-sha1, a-fzteio and a-izteio + + * a-fzteio.ads, a-izteio.ads: New Ada 2005 run-time units. + +2007-04-06 Eric Botcazou + Arnaud Charlet + + * init.c: Reuse PA/HP-UX code for IA-64/HP-UX, except + __gnat_adjust_context_for_raise. + (__gnat_init_float): on x86 vxworks 5.x and 6.x, we use the same + implementation of floating point operations as native x86 targets. + So the FPU should be initialized in the same way using finit. Fix + floating point operations accuracy issues. + (__gnat_install_handler, case FreeBSD): Use proper type for sa_sigaction + member in struct sigaction, so as to avoid warning for incompatible + pointer types. + +2007-04-06 Serguei Rybin + + * lib.ads, lib.adb (Tree_Read): Release the memory occupied by the + switches from previously loaded tree + +2007-04-06 Thomas Quinot + + * lib-writ.adb (Write_With_Lines): Factor duplicated code between the + cases where a given dependency has a body or not. + (Write_With_File_Names): New subprogram, common code for the two cases + above. + +2007-04-06 Ed Schonberg + Javier Miranda + + * lib-xref.ads, lib-xref.adb: + Modify the loop that collects type references, to include interface + types that the type implements. List each of these interfaces when + building the entry for the type. + (Generate_Definition): Initialize component Def and Typ of new entry + in table Xrefs, to avoid to have these components unitialized. + (Output_References): Split Is_Abstract flag into + Is_Abstract_Subprogram and Is_Abstract_Type. + (Generate_Reference): Add barrier to do not generate the warning + associated with Ada 2005 entities with entities generated by the + expander. + +2007-04-06 Robert Dewar + Arnaud Charlet + Vincent Celier + + * gnat_rm.texi, gnat_ugn.texi: Add -gnatyl documentation + Update 'Exception Handling Control' chapter which was outdated. + Minor fix to documentation of -gnatwq + Remove section "Adapting the Run Time to a New C++ Compiler" because + it is now obsolete. + Add passage on need of -nostart-files in some non-ada-main cases. + Document new switch -eS (/STANDARD_OUTPUT_FOR_COMMANDS) for gnatmake + Update documentation about Interfacing with C++ + Add documentation for new gnatmake switch -p + Add missing protocol part in URLs. + Document -gnatyA + Document pragma Compile_Time_Error + Add documentation for Object_Size indicating that stand alone + objects can have a larger size in some cases. + Add node for GNAT.Byte_Swapping, GNAT.SHA1 + Update reference to the Ravenscar profile. + Document pragma Unreferenced_Objects + + * gnat-style.texi: Fix typo + +2007-04-06 Vincent Celier + + * mlib.adb (Building_Library): Only output "building a library..." in + verbose mode + + * mlib-prj.adb (Build_Library): Only output lists of object and ALI + files in verbose mode. + + * mlib-utl.adb (Ar): Only output the first object files when not in + verbose mode. + (Gcc): Do not display all the object files if not in verbose mode, only + the first one. + +2007-04-06 Robert Dewar + + * namet.ads, namet.adb (wn): Improve this debugging routine. Calling + it no longer destroys the contents of Name_Buffer or Name_Len and + non-standard and invalid names are handled better. + (Get_Decoded_Name_String): Improve performance by using + Name_Has_No_Encodings flag in the name table. + (Is_Valid_Name): New function to determine whether a Name_Id is valid. + Used for debugging printouts. + +2007-04-06 Robert Dewar + Javier Miranda + Bob Duff + + * par-ch3.adb: (P_Type_Declaration): Set Type_Token_Location + (P_Interface_Type_Definition): Remove the formal Is_Synchronized because + there is no need to generate always a record_definition_node in case + of synchronized interface types. + (P_Type_Declaration): Update calls to P_Interface_Type_Definition. + (P_Null_Exclusion): For AI-447: Remove warnings about "not null" being + illegal in Ada 95, in cases where it is legal. Change the warnings to + errors in other cases. Don't give the error unless the "not null" + parses properly. Correct the source position at which the error occurs. + (P_Known_Discriminant_Part_Opt): Pass Allow_Anonymous_In_95 => True to + P_Null_Exclusion, to suppress "not null" warnings. + (P_Identifier_Declarations): Code cleanup. Removed unrequired label and + associated goto statements. + + * par-endh.adb (Pop_End_Context): Allow more flexibility in placement + of END RECORD + + * scans.ads (Type_Token_Location): New flag + + * par-ch6.adb (P_Mode): Check specifically for case of IN ACCESS + (P_Formal_Part): Pass Allow_Anonymous_In_95 => True to + P_Null_Exclusion, to suppress "not null" warnings. + +2007-04-06 Robert Dewar + Javier Miranda + Bob Duff + Vincent Celier + + * par-prag.adb (Prag): Add dummy entry for pragma Compile_Time_Error + (Extensions_Allowed): No longer sets Ada_Version + Entry for pragma Unreferenced_Objects + + * sem_prag.adb (Analyze_Pragma, case Priority): Force with of + system.tasking if pragma priority used in a procedure + (Analyze_Pragma, case Warning): Handle dot warning switches + (Process_Compile_Time_Warning_Or_Error): New procedure + (Analyze_Pragma): Add processing for Compile_Time_Error + Add support for extra arguments External_Name and Link_Name. + Remove code associated with pragmas CPP_Virtual and CPP_Vtable. + (Process_Import_Or_Interface): Add support for the use of pragma Import + with tagged types. + (Extensions_Allowed): No longer affects Ada_Version + (Analyze_Pragma): Split Is_Abstract flag into Is_Abstract_Subprogram and + Is_Abstract_Type. Make sure these are called only when appropriate. + Add processing for pragma Unreferenced_Objects + + * snames.h, snames.ads, snames.adb: Add entry for pragma + Compile_Time_Error + Add new standard name Minimum_Binder_Options for new gprmake + Add new standard names for gprmake: Archive_Suffix, + Library_Auto_Init_Supported, Library_Major_Minor_Id_Supported, + Library_Support, Library_Version_Options, + Shared_Library_Minimum_Options, + Shared_Library_Prefix, Shared_Library_Suffix, Symbolic_Link_Supported. + Change Name_Call to Name_uCall so that it cannot clash with a legal + subprogram name. + Add new standard names Mapping_Spec_Suffix and Mapping_Body_Suffix + Append C_Plus_Plus to convention identifiers as synonym for CPP + Add new standard names Stack and Builder_Switches + Add new standard names: Compiler_Minimum_Options, Global_Config_File, + Library_Builder, Local_Config_File, Objects_Path, Objects_Path_File, + Run_Path_Option, Toolchain_Version. + Entry for pragma Unreferenced_Objects + + * switch-c.adb (Scan_Front_End_Switches): Store correct -gnateD + switches, without repetition of "eD". Make sure that last character of + -gnatep= switch is not taken as -gnat switch character. + Complete rewrite of circuit for handling saving compilation options + Occasioned by need to support dot switchs for -gnatw, but cleans up + things in general. + -gnatX does not affect Ada_Version + Include -gnatyA in -gnatg style switches + + * sem_warn.ads, sem_warn.adb (Output_Unreferenced_Messages): Exclude + warnings on return objects. + (Warn_On_Useless_Assignment): Exclude warnings on return objects + (Set_Dot_Warning_Switch): New procedure + (Check_References): Add missing case of test for + Has_Pragma_Unreferenced_Objects + (Output_Unreferenced_Messages): Implement effect of new pragma + Unreferenced_Objects, remove special casing of limited controlled + variables. + +2007-04-06 Vincent Celier + + * prj-ext.adb (Initialize_Project_Path): New procedure that initialize + the default project path, initially done during elaboration of the + package. + If the prefix returned by Sdefault is null, get the prefix from a call + to Executable_Prefix_Path. + (Project_Path): Call Initialize_Project_Path if Current_Project_Path is + null. + + * prj-nmsc.adb (Get_Path_Names_And_Record_Sources): Use the non + canonical directory name to open the directory from which files are + retrieved. + (Record_Other_Sources): Idem. + (Locate_Directory): Add the possibility to create automatically missing + directories when Setup_Projects is True. + Call Locate_Directory so that the directory will be created when + Setup_Projects is True, for object dir, library dir, library ALI dir, + library source copy dir and exec dir. + + * prj-pp.adb (Max_Line_Length): Set to 255 for compatibility with older + versions of GNAT. + +2007-04-06 Robert Dewar + + * sem_ch13.ads, sem_ch13.adb (Adjust_Record_For_Reverse_Bit_Order): + Use First/Next_Component_Or_Discriminant + (Analyze_Record_Representation_Clause): + Use First/Next_Component_Or_Discriminant + (Check_Component_Overlap): Use First/Next_Component_Or_Discriminant + (Analyze_Attribute_Definition_Clause, case Value_Size): Reject + definition if type is unconstrained. + (Adjust_Record_For_Reverse_Bit_Order): New procedure + (Analyze_Attribute_Definition_Clause): Split Is_Abstract flag into + Is_Abstract_Subprogram and Is_Abstract_Type. + (Adjust_Record_For_Reverse_Bit_Order): New procedure + + * repinfo.adb (List_Record_Info): Use First/ + Next_Component_Or_Discriminant. + + * style.ads, styleg-c.adb, styleg-c.ads (Check_Array_Attribute_Index): + New procedure. + + * stylesw.ads, stylesw.adb: Recognize new -gnatyA style switch + Include -gnatyA in default switches + + * opt.ads: (Warn_On_Non_Local_Exception): New flag + (Warn_On_Reverse_Bit_Order): New flag + (Extensions_Allowed): Update the documentation. + (Warn_On_Questionable_Missing_Parens): Now on by default + + * usage.adb: Add documentation of -gnatw.x/X switches + Document new -gnatyA style switch + -gnatq warnings are on by default + +2007-04-06 Ed Falis + + * s-carun8.adb, s-carsi8.adb (Compare_Array_?8): modify so that last + full word is no longer compared twice. + +2007-04-06 Ed Schonberg + + * sem_ch10.adb (Install_Limited_Context_Clauses. + Expand_Limited_With_Clause): Use a new copy of selector name in the + call to Make_With_Clause. This fixes the tree structure for ASIS + purposes. Nothing is changed in the compiler behaviour. + (Process_Body_Clauses): Handle properly use clauses whose prefix is + a package renaming. + (Install_Limited_With_Clauses): Do not install non-limited view when it + is still incomplete. + +2007-04-06 Ed Schonberg + Gary Dismukes + + * sem_ch12.adb (Check_Generic_Actuals): Use first subtype of actual + when capturing size information, instead of base type, which for a + formal array type will be the unconstrained type. + (Analyze_Formal_Object_Declaration): Add check for illegal default + expressions for a formal in object of a limited type. + (Instantiate_Object): Ditto. + (Check_Formal_Package_Instance): Skip entities that are formal objects, + because they were defaulted in the formal package and no check applies + to them. + (Check_Formal_Package_Instance): Extend conformance check to other + discrete types beyond Integer. + (Process_Default): Copy directly the unmatched formal. A generic copy + has already been performed in Analyze_Formal_Package. + (Analyze_Associations): If a formal subprogram has no match, check for + partial parametrization before looking for a default, to prevent + spurious errors. + (Analyze_Package_Instantiation, Analyze_Subprogram_Instantiation): Do + not set the instantiation environment before analyzing the actuals. + Fixes regression on 8515-003 with implementation of AI-133. + Set_Instance_Env checks whether the generic unit is a predefined + unit, in which case the instance must be analyzed with the latest Ada + mode. This setting must take place after analysis of the actuals, + because the actuals must be analyzed and frozen in the Ada mode extant + outside of the current instantiation. + (Save_Env, Restore_Env): Preserve and restore the configuration + parameters so that predefined units can be compiled in the proper Ada + mode. + (Analyze_Formal_Object_Declaration,Analyze_Formal_Subprogram, + Instantiate_Type): Split Is_Abstract flag into Is_Abstract_Subprogram + and Is_Abstract_Type. + (Analyze_Formal_Package): For better error recovery, Add exception + handler to catch Instantion_Error, which can be raised in + Analyze_Associations + +2007-04-06 Ed Schonberg + Bob Duff + Gary Dismukes + + * sem_ch4.adb (Try_Primitive_Operation): The call is legal if the + prefix type is a discriminated subtype of the type of the formal. + (Analyze_Allocator): Collect all coextensions regardless of the context. + Whether they can be allocated statically is determined in exp_ch4. + (Analyze_Selected_Component): If the prefix is a limited view and the + non-limited view is available, use the non-limited one. + (Operator_Check): For "X'Access = Y'Access" (which is ambiguous, and + therefore illegal), suggest a qualified expression rather than a type + conversion, because a type conversion would be illegal in this context. + (Anayze_Allocator): Trace recursively all nested allocators so that all + coextensions are on the corresponding list for the root. Do no mark + coextensions if the root allocator is within a declaration for a stack- + allocated object, because the access discriminants will be allocated on + the stack as well. + (Analyze_Call): Remove restriction on calls to limited functions for the + cases of generic actuals for formal objects, defaults for formal objects + and defaults for record components. + (Analyze_Allocator): Before analysis, chain coextensions on the proper + element list. Their expansion is delayed until the enclosing allocator + is processed and its finalization list constructed. + (Try_Primitive_Operation): If the prefix is a concurrent type, looks + for an operation with the given name among the primitive operations of + the corresponding record type. + (Analyze_Selected_Component): If the prefix is a task type that + implements an interface, and there is no entry with the given name, + check whether there is another primitive operation (e.g. a function) + with that name. + (Try_Object_Operation, Analyze_One_Call, Try_Indexed_Call): Handle + properly the indexing of a function call written in prefix form, where + the function returns an array type, and all parameters of the function + except the first have defaults. + (Analyze_Equality_Op): If this is a call to an implicit inequality, keep + the original operands, rather than relocating them, for efficiency and + to work properly when an operand is overloaded. + (Analyze_Allocator,Operator_Check,Remove_Abstract_Operations): Split + Is_Abstract flag into Is_Abstract_Subprogram and Is_Abstract_Type. + (Analyze_Selected_Component): If the prefix is a private extension, only + scan the visible components, not those of the full view. + (Try_Primitive_Operation): If the operation is a procedure, collect all + possible interpretations, as for a function, because in the presence of + classwide parameters several primitive operations of the type can match + the given arguments. + +2007-04-06 Ed Schonberg + Robert Dewar + + * sem_ch5.adb (Analyze_Assignment): Reject a right-hand side that is a + tag-indeterminate call to an abstract function, when the left-hand side + is not classwide. + (Analyze_Loop_Statement): Improve detection of infinite loops + +2007-04-06 Ed Schonberg + Thomas Quinot + + * sem_ch7.ads, sem_ch7.adb (Inspect_Deferred_Constant_Completion): Move + out of Analyze_Package_Declaration, because processing must be applied + to package bodies as well, for deferred constants completed by pragmas. + (Analyze_Package_Declaration): When the package declaration being + analyzed does not require an explicit body, call Check_Completion. + (May_Need_Implicit_Body): An implicit body is required when a package + spec contains the declaration of a remote access-to-classwide type. + (Analyze_Package_Body): If the package contains RACWs, append the + pending subprogram bodies generated by exp_dist at the end of the body. + (New_Private_Type,Unit_Requires_Body): Split Is_Abstract flag into + Is_Abstract_Subprogram and Is_Abstract_Type. + (Preserve_Full_Attributes): The full entity list is not an attribute + that must be preserved from full to partial view. + + * sem_dist.adb (Add_RAS_Dereference_TSS): + Change primitive name to _Call so it cannot clash with any legal + identifier, and be special-cased in Check_Completion. + Mark the full view of the designated type for the RACW associated with + a RAS as Comes_From_Source to get proper view switching when installing + private declarations. + Provite a placeholder nested package body along with the nested spec + to have a place for Append_RACW_Bodies to generate the calling stubs + and stream attributes. + +2007-04-06 Ed Schonberg + Robert Dewar + + * sem_ch8.adb (Has_Components): If the argument is an incomplete type + that is a limited view, check the non-limited view if available. + (Undefined): Refine error message for missing with of Text_IO + (Find_Expanded_Name): Use Is_Known_Unit for more accurate error message + to distinguish real missing with cases. + Fix format of all missing with messages + (Analyze_Subprogram_Renaming): Emit proper error message on illegal + renaming as body when renamed entity is abstract. + +2007-04-06 Ed Schonberg + Javier Miranda + + * sem_type.ads, sem_type.adb (Has_Abstract_Interpretation): Make + predicate recursive, to handle complex expressions on literals whose + spurious ambiguity comes from the abstract interpretation of some + subexpression. + (Interface_Present_In_Ancestor): Add support to concurrent record + types. + (Add_One_Interp,Disambiguate): Split Is_Abstract flag into + Is_Abstract_Subprogram and Is_Abstract_Type. + +2007-04-06 Ed Schonberg + Javier Miranda + + * sem_util.ads, sem_util.adb (Object_Access_Level): If the object is a + dereference of a local object R created as a reference to another + object O, use the access level of O. + (Matches_Prefixed_View_Profile): Use common predicate Conforming_Types, + rather than local Same_Formal_Type, to check whether protected operation + overrides an inherited one. + (Same_Formal_Type): New predicate, used when matching signatures of + overriding synchronized operations, to handle the case when a formal + has a type that is a generic actual. + (Is_Aliased_View): Replace check on E_Task_Type and E_Protected_Type by + predicate Is_Concurrent_Type. This ensures supportin case of subtypes. + (Needs_One_Actual): New predicate, for Ada 2005 use, to resolve + syntactic ambiguities involving indexing of function calls that return + arrays. + (Abstract_Interface_List): New subprogram that returns the list of + abstract interfaces associated with a concurrent type or a + concurrent record type. + (Interface_Present_In_Parent): New subprogram used to check if a + given type or some of its parents implement a given interface. + (Collect_Abstract_Interfaces): Add support for concurrent types + with interface types. + (Has_Abstract_Interfaces): Add support for concurrent types with + interface types. + (Is_Parent): New subprogram that determines whether E1 is a parent + of E2. For a concurrent type its parent is the first element of its + list of interface types; for other types this function provides the + same result than Is_Ancestor. + (Enclosing_Subprogram): Add test for N_Extended_Return_Statement. + (Collect_Synchronized_Interfaces): Removed because the subprogram + Collect_Abstract_Interfaces provides this functionality. + (Collect_Abstract_Interfaces): Minor update to give support to + concurrent types and thus avoid undesired code duplication. + (Get_Subprogram_Entity): Handle entry calls. + (May_Be_Lvalue): Include actuals that appear as in-out parameters in + entry calls. + (Enter_Name): Do not give -gnatwh hiding warning for record component + entities, they never result in hiding. + +2007-04-06 Ed Schonberg + Robert Dewar + + * sinfo.ads, sinfo.adb (Coextensions): New element list for allocators, + to chain nested components that are allocators for access discriminants + of the enclosing object. + Add N_Push and N_Pop nodes + New field Exception_Label added + (Local_Raise_Statements): New field in N_Exception_Handler_Node + (Local_Raise_Not_OK): New flag in N_Exception_Handler_Node + (Is_Coextension): New flag for allocators, to mark allocators that + correspond to access discriminants of dynamically allocated objects. + (N_Block_Statement): Document the fact that the corresponding entity + can be an E_Return_Statement. + (Is_Coextension): New flag for allocators. + Remove all code for DSP option + + * sprint.ads, sprint.adb: Display basic information for class_wide + subtypes. Add handling of N_Push and N_Pop nodes + +2007-04-06 Arnaud Charlet + + * s-tpobop.adb (Exceptional_Complete_Entry_Body): Undefer abortion + before propagating exception. + +2007-04-06 Olivier Hainque + + * tracebak.c (PC_ADJUST - ia64): -4 instead of -16, expected to yield + an address always within the call instruction from a return address. + +2007-04-06 Olivier Hainque + Eric Botcazou + + * trans.c (call_to_gnu) : Return an + expression with a COMPOUND_EXPR including the call instead of emitting + the call directly here. + (gnat_to_gnu) : Do not return a non-constant low bound if the + high bound is constant and the slice is empty. Tidy. + (tree_transform, case N_Op_Not): Handle properly the case where the + operation applies to a private type whose full view is a modular type. + (Case_Statement_To_gnu): If an alternative is an E_Constant with an + Address_Clause, use the associated Expression as the GNAT tree + representing the choice value to ensure the corresponding GCC tree is + of the proper kind. + (maybe_stabilize_reference): Stabilize COMPOUND_EXPRs as a whole + instead of just the operands, as the base GCC stabilize_reference does. + : New case. Directly stabilize the call if an lvalue is not + requested; otherwise fail. + (addressable_p) : Do not test DECL_NONADDRESSABLE_P. + +2007-04-06 Thomas Quinot + + * uintp.ads, uintp.adb (UI_Div_Rem): New subprogram, extending previous + implementation of UI_Div. + (UI_Div): Reimplement as a call to UI_Div_Rem. + (UI_Rem): Take advantage of the fact that UI_Div_Rem provides the + remainder, avoiding the cost of a multiplication and a subtraction. + (UI_Modular_Inverse): Take advantage of the fact that UI_Div_Rem + provides both quotient and remainder in a single computation. + (UI_Modular_Exponentiation, UI_Modular_Inverse): New modular arithmetic + functions for uint. + (UI_Modular_Inverse): Add a note that the behaviour of this subprogram + is undefined if the given n is not inversible. + +2007-04-06 Olivier Hainque + + * utils2.c (known_alignment): Handle COMPOUND_EXPR, COND_EXPR and + BIT_AND_EXPR. Handle also VIEW_CONVERT_EXPR, as the other conversion + opcodes. + +2007-04-06 Eric Botcazou + Olivier Hainque + + * utils.c (update_pointer_to): Make a copy of the couple of FIELD_DECLs + when updating the contents of the old pointer to an unconstrained array. + (end_subprog_body): Set error_gnat_node to Empty. + (write_record_type_debug_info): Do not be unduly sparing with our bytes. + (unchecked_convert): For subtype to base type conversions, require that + the source be a subtype if it is an integer type. + (builtin_decls): New global, vector of available builtin functions. + (gnat_pushdecl): Add global builtin function declaration nodes to the + builtin_decls list. + (gnat_install_builtins): Adjust comments. + (builtin_function): Set DECL_BUILTIN_CLASS and DECL_FUNCTION_CODE before + calling gnat_pushdecl, so that it knows when it handed a builtin + function declaration node. + (builtin_decl_for): Search the builtin_decls list. + +2007-04-06 Eric Botcazou + + * s-stchop-vxworks.adb: + (Stack_Check): Raise Storage_Error if the argument has wrapped around. + +2007-04-06 Robert Dewar + Arnaud Charlet + + * a-diroro.ads: Inserted the pragma Unimplemented_Unit + + * bindgen.adb (Gen_Output_File_Ada): Generate pragma Ada_95 at start + of files + Add mention of -Sev (set initialize_scalars option from environment + variable at run time) in gnatbind usage message. + + * elists.ads, elists.adb: (Append_Unique_Elmt): New procedure + + * fname-uf.ads: Minor comment fix + + * osint.ads: Change pragma Elaborate to Elaborate_All + + * par-load.adb: Add documentation. + + * sem_cat.ads, sem_cat.adb: Minor code reorganization + + * s-parint.ads (RCI_Locator) : Add 'Version' generic formal + + * s-secsta.ads: Extra comments + + * s-soflin.ads: Minor comment fixes + + * s-stratt.ads (Block_Stream_Ops_OK): Removed. + + * s-wchcon.ads: Minor comment addition + + * treepr.adb: Minor change in message + (Print_Name,Print_Node): Make these debug printouts more robust: print + "no such..." instead of crashing on bad input. + +2007-03-30 Rafael Ávila de Espíndola + + * trans.c (Attribute_to_gnu): Use get_signed_or_unsigned_type + instead of gnat_signed_or_unsigned_type. + * utils.c (gnat_signed_or_unsigned_type): Remove. + * misc.c (LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE): Remove + * gigi.h (gnat_signed_or_unsigned_type): Remove + +2007-03-09 Roger Sayle + + * cuintp.c (UI_To_gnu): Use fold_buildN calls instead of calling + fold with the result of buildN. + * decl.c (gnat_to_gnu_entity): Likewise. + * trans.c (Attribute_to_gnu, gnat_to_gnu, emit_check): Likewise. + * utils.c (finish_record_type, merge_sizes, max_size, convert): + Likewise. + * utils2.c (gnat_truthvalue_conversion, compare_arrays, + nonbinary_modular_operation, build_binary_op, build_unary_op, + build_cond_expr): Likewise. + + * utils.c (convert): Use fold_build1 when casting values to void. + * utils2.c (gnat_truthvalue_conversion): Use build_int_cst and + fold_convert instead of convert when appropriate. + +2007-03-01 Brooks Moses + + * Make-lang.in: Add install-pdf target as copied from + automake v1.10 rules. + +2007-02-28 Andreas Schwab + + * Make-lang.in (doc/gnat_ugn_unw.texi): Depend on + $(gcc_docdir)/include/gcc-common.texi and gcc-vers.texi. + (doc/gnat-style.info): Likewise. + +2007-02-26 Brooks Moses + + * gnat-style.texi: Standardize title page. + * gnat_rm.texi: Likewise. + * gnat_ugn.texi: Likewise. + +2007-02-25 Mark Mitchell + + * decl.c (annotate_value): Adjust for refactoring of tree_map + hierarchy. + +2007-02-24 Mark Mitchell + + * decl.c (annotate_value): Adjust for refactoring of tree_map + hierarchy. + +2007-02-21 Ed Schonberg + + PR ada/18819 + * sem_ch3.adb (Create_Constrained_Components): for a subtype of an + untagged derived type, add hidden components to keep discriminant + layout consistent, when a given discriminant of the derived type + constraints several discriminants of the parent type. + +2007-02-16 Eric Botcazou + Sandra Loosemore + + * trans.c (call_to_gnu): Use build_call_list instead of build3 to + build the call expression. + (gnat_stabilize_reference_1): Handle tcc_vl_exp. + * utils.c (max_size) : Delete. + : New case. + : Delete CALL_EXPR subcase. + (build_global_cdtor): Use build_call_nary instead of build3. + * utils2.c (build_call_1_expr): Likewise. + (build_call_2_expr): Likewise. + (build_call_0_expr): Likewise. + (build_call_alloc_dealloc): Likewise. + +2007-02-07 Andreas Krebbel + + * raise-gcc.c (get_region_description_for, get_call_site_action_for, + get_action_description_for): Replace _Unwind_Word with _uleb128_t + and _Unwind_SWord with _sleb128_t. + +2007-02-06 Paolo Bonzini + + * Make-lang.in (ada/decl.o): Add gt-ada-decl.h dependency. + * decl.c: Include gt-ada-decl.h. + (annotate_value_cache): New. + (annotate_value): Use it instead of TREE_COMPLEXITY. + +2007-02-03 Kazu Hirata + + * misc.c, utils2.c: Fix comment typos. + +2007-01-24 Roger Sayle + + * decl.c (gnat_to_gnu_entity): Use TREE_OVERFLOW instead of + TREE_CONSTANT_OVERFLOW. + (allocatable_size_p, annotate_value): Likewise. + * trans.c (gnat_to_gnu): Likewise. + * utils.c (unchecked_convert): Likewise. + * utils2.c (build_simple_component_ref): Likewise. + +2007-01-23 Richard Guenther + + PR bootstrap/30541 + * Make-lang.in: Replace invocations of gnatmake with $(GNATMAKE). + (gnatboot2): Pass staged GNATMAKE instead of STAGE_PREFIX. + (gnatboot3): Likewise. + (GNATBIND): Do not define. + * Makefile.in (GNATBIND): Do not define. + +2007-01-08 Richard Guenther + + * cuintp.c (build_cst_from_int): Use built_int_cst_type. + * trans.c (gnat_to_gnu): Likewise. + + + +Copyright (C) 2007 Free Software Foundation, Inc. + +Copying and distribution of this file, with or without modification, +are permitted in any medium without royalty provided the copyright +notice and this notice are preserved. diff --git a/gcc/ada/ChangeLog-2008 b/gcc/ada/ChangeLog-2008 new file mode 100644 index 000000000..4e34213ea --- /dev/null +++ b/gcc/ada/ChangeLog-2008 @@ -0,0 +1,7464 @@ +2008-12-09 Jakub Jelinek + + PR ada/38450 + * gcc-interface/utils.c (finish_record_type): Use SET_TYPE_MODE. + * gcc-interface/decl.c (gnat_to_gnu_entity, make_aligning_type): + Likewise. + +2008-12-05 Sebastian Pop + + PR bootstrap/38262 + * gcc-interface/Make-lang.in (gnat1): Add BACKENDLIBS, remove GMPLIBS. + +2008-11-29 Eric Botcazou + + PR ada/30827 + * g-comver.adb (Ver_Len_Max): Fix inconsistency. + +2008-11-27 Eric Botcazou + + * gcc-interface/decl.c: Fix various nits. + +2008-11-20 Eric Botcazou + + * gcc-interface/utils.c (init_gigi_decls): Fix type mismatch. + +2008-11-16 Eric Botcazou + + PR ada/38127 + * gcc-interface/decl.c (make_type_from_size) : Do not + special-case boolean types. Propagate the name. + * gcc-interface/targtyps.c: Tweak comment. + +2008-11-15 Geert Bosch + + * gcc-interface/trans.c (emit_check): Put back a final save_expr + to prevent exponential expansion during gimplification. + +2008-11-15 Eric Botcazou + + * gcc-interface/lang-specs.h: Expand -coverage and reorder switches. + +2008-11-15 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Force constants + initialized to a static constant to be statically allocated even if + they are of a padding type, provided the original type also has + constant size. + +2008-11-15 Laurent Guerby + + PR ada/37993 + * gcc-interface/Makefile.in: Add multilib handling for x86_64 + on darwin. + * system-darwin-x86_64.ads: New file. + +2008-11-13 Olivier Hainque + + * gcc-interface/decl.c (gnat_to_gnu_entity) : + Turn Ada Pure on subprograms back into GCC CONST when eh constructs + are explicit to the middle-end. Tidy. + +2008-11-09 Eric Botcazou + + * gcc-interface/ada-tree.def (PLUS_NOMOD_EXPR): New tree code. + (MINUS_NOMOD_EXPR): Likewise. + * gcc-interface/utils2.c (build_binary_op) : Make + unreachable. + : New case. + : Likewise. + * gcc-interface/trans.c (Loop_Statement_to_gnu): Build increment-and- + assignment statement instead of using an increment operator. + +2008-11-07 Rainer Orth + + * system-irix-n64.ads: New file. + * gcc-interface/Makefile.in (mips-sgi-irix6*): Support O32 and N64 + multilibs. + +2008-11-07 Rainer Orth + + PR ada/37681 + * system-solaris-x86_64.ads: New file. + * gcc-interface/Makefile.in (*86-solaris2*): Support x86_64 multilib. + +2008-11-07 Bechir Zalila + Eric Botcazou + + PR ada/34289 + * lib.ads: (Enable_Switch_Storing): Declare. + * lib.adb: (Enable_Switch_Storing): New procedure. + * switch-c.adb (Scan_Front_End_Switches): Add support for -gnatea. + * make.adb: (Compile_Sources.Compile): Add -gnatea as first option. + (Display): Never display -gnatea + * gcc-interface/lang-specs.h: If -gnatea is present, pass -gnatez. + +2008-11-07 Thomas Quinot + + * gcc-interface/trans.c (Attribute_to_gnu, case Attr_Length): Check + for empty range in original base type, not converted result type. + +2008-11-07 Geert Bosch + + * gcc-interface/trans.c (build_binary_op_trapv): Convert arguments + and result for call to __gnat_mulv64. + +2008-11-07 Eric Botcazou + + * gcc-interface/trans.c: Fix formatting nits. + +2008-11-07 Geert Bosch + + * gcc-interface/trans.c (build_binary_op_trapv): Avoid emitting + overflow check for constant result. + +2008-11-07 Geert Bosch + + * gcc-interface/trans.c (build_binary_op_trapv): Use more efficient + overflow check for addition/subtraction if neither operand is constant. + +2008-11-06 Eric Botcazou + + * gcc-interface/Makefile.in (SPARC/Solaris): Use a common set of + files for the target-dependent part of the runtime. + (SPARC/Linux): Likewise. + +2008-11-06 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : If not + optimizing, create a PARM_DECL pointing to the VAR_DECL for debugging + purposes. + +2008-11-06 Eric Botcazou + + * gcc-interface/misc.c (gnat_printable_name): Always return a copy + in GC memory. + +2008-11-06 Eric Botcazou + + PR ada/19419 + * gcc-interface/trans.c (gnat_to_gnu) : + Generate a call to memmove for an assignment between overlapping + array slices. + +2008-11-02 Andreas Krebbel + + PR target/37977 + * gcc-interface/Makefile.in: Add multilib handling for + s390-linux and s390x-linux. + +2008-10-24 Jakub Jelinek + + * gcc-interface/Make-lang.in (check-ada-subtargets): Depend on + check-acats-subtargets and check-gnat-subtargets. + (check_acats_targets): New variable. + (check-acats-subtargets, check-acats%): New targets. + (check-acats): If -j is used and CHAPTERS is empty, run the testing + in multiple make goals, possibly parallel, and afterwards run + dg-extract-results.sh to merge the sum and log files. + +2008-10-17 Geert Bosch + + * gcc-interface/trans.c (gnat_to_gnu) : Simplify expansion + to use only a single check instead of three, and avoid unnecessary + COMPOUND_EXPR. + (emit_check): Avoid useless COMPOUND_EXPRs and SAVE_EXPRs, sometimes + creating more opportunities for optimizations. + +2008-10-13 Jakub Jelinek + + PR middle-end/37601 + * gcc-interface/utils.c (gnat_types_compatible_p): Handle + NULL TYPE_DOMAIN. + +2008-10-07 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Move code + dealing with volatileness to after code dealing with renaming. + +2008-10-06 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Minor tweaks. + * gcc-interface/trans.c (Pragma_to_gnu): Likewise. + +2008-10-06 Eric Botcazou + + * gcc-interface/utils.c (can_fold_for_view_convert_p): New predicate. + (unchecked_convert): Use it to disable problematic folding with + VIEW_CONVERT_EXPR in the general case. Always disable it for the + special VIEW_CONVERT_EXPR built for integral types and cope with + its addressability issues by preserving the first conversion. + +2008-10-01 Andreas Schwab + + * system-linux-ppc64.ads: New file. + * gcc-interface/Makefile.in: Add multilib handling for + powerpc-linux. + +2008-09-26 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : Cap the alignment promotion + to that of ptr_mode instead of word_mode. + +2008-09-26 Eric Botcazou + + PR ada/5911 + * gcc-interface/Makefile.in (SPARC/Solaris): Add multilib support. + +2008-09-25 Samuel Tardieu + + PR ada/37641 + * adaint.c (__gnat_set_non_writable): Use FILE_WRITE_EA + instead of deprecated FILE_WRITE_PROPERTIES. + +2008-09-22 Olivier Hainque + + * gcc-interface/decl.c (gnat_to_gnu_entity): Even when they + are never assigned, volatile entities are not constant for code + generation purposes. + +2008-09-21 Laurent Guerby + + PR ada/5911 + * gcc-interface/Makefile.in: Add multilib handling for x86_64 + and sparc. + * system-linux-sparcv9.ads: New file. + +2008-09-20 Eric Botcazou + + * exp_dbug.ads: Document new convention for the XVZ variable. + * gcc-interface/decl.c (gnat_to_gnu_entity) : Generate + debug info if necessary for the type padding the component type. + : Likewise. + (maybe_pad_type): Emit the XVZ variable in units. + * gcc-interface/trans.c (Loop_Statement_to_gnu): Fix formatting nits. + (Subprogram_Body_to_gnu): Set the source line of the subprogram's node + on statements generated to initialize the parameter attributes cache. + Set the source line of the end label of the body on the special return + statement built for a procedure with copy-in copy-out parameters. + +2008-09-20 Eric Botcazou + + PR ada/37585 + * gcc-interface/utils.c (create_subprog_decl): Disable inlining for + inlined external functions if they contain a nested function not + declared inline. + +2008-09-18 Jan Hubicka + + * gcc-interface/utils.c (create_subprog_decl): Use DECL_DECLARED_INLINE_P. + (end_subprog_body): Do not set DECL_INLINE. + +2008-09-17 Pascal Rigaux + + PR ada/21327 + * gnat_ugn.texi: Use proper format in direntry. + +2008-09-15 Eric Botcazou + + * gcc-interface/trans.c (gigi): Declare the name of the compilation + unit as the first global name. + +2008-09-14 Jan Hubicka + + * gcc-interface/Make-lang.in (gnat1): Add CFLAGS. + +2008-09-14 Ralf Wildenhues + + * a-crbtgk.adb, a-direct.ads, a-tasatt.adb, ali.ads, + bindgen.adb, checks.adb, einfo.ads, exp_aggr.adb, exp_ch11.adb, + exp_ch3.adb, exp_ch4.adb, exp_ch6.adb, exp_ch7.adb, exp_ch9.adb, + exp_dbug.ads, exp_disp.adb, exp_dist.adb, exp_pakd.adb, + exp_util.adb, g-alveop.ads, g-comlin.adb, g-comlin.ads, + g-diopit.adb, g-socket.ads, gcc-interface/decl.c, + gcc-interface/gigi.h, gcc-interface/trans.c, + lib-load.adb, lib-xref.ads, make.adb, mlib-prj.adb, nlists.ads, + opt.ads, par-ch10.adb, par-ch5.adb, par.adb, s-os_lib.ads, + s-oscons-tmplt.c, s-parint.ads, s-regpat.ads, s-shasto.ads, + s-stausa.ads, s-taprop-vms.adb, sem.adb, sem_ch10.adb, + sem_ch11.adb, sem_ch12.adb, sem_ch13.adb, sem_ch3.adb, + sem_ch3.ads, sem_ch4.adb, sem_ch6.adb, sem_ch7.adb, sem_ch8.adb, + sem_elim.adb, sem_prag.adb, sem_util.adb, sem_util.ads, + sem_warn.adb, sinfo.ads, styleg.adb, vms_data.ads: Fix typos in + comments. + * gnathtml.pl: Fix typos. + +2008-09-10 Joel Sherrill + + * gcc-interface/Makefile.in: Switch RTEMS to s-interr-hwint.adb. + * s-osinte-rtems.ads: Add shared hardware interrupt adapter + layer. RTEMS binds to OS provided adapter routines so there are + no modifications to s-osinte-rtems.adb. + +2008-09-09 Arnaud Charlet + Joel Sherrill + + * gcc-interface/Makefile.in: Switch VxWorks to s-interr-hwint.adb. + + * s-interr-vxworks.adb: Renamed to s-interr-hwint.adb + + * s-interr-hwint.adb: New file. + + * s-osinte-vxworks.ads, s-osinte-vxworks.adb: Add new functions + needed by s-interr-hwint.adb. + + * s-osinte-vxworks-kernel.adb: New file. + +2008-09-05 Joel Sherrill + + * s-stchop-rtems.adb: Add file missed in early commit. Already + referenced in gcc-interface/Makefile.in. + +2008-08-30 Thomas Quinot + + * gcc-interface/Make-lang.in: Allow s-oscons.{o,ali} to + be built even without a separate libada directory. + +2008-08-22 Arnaud Charlet + + * lib-xref.ads: Fix typo in subprogram reference definition. + +2008-08-22 Robert Dewar + + * s-sopco3.adb, s-sopco4.adb, s-sopco5.adb, s-strops.adb: Minor code fix + to avoid warning. + + * g-trasym.adb: Ditto + + * s-utf_32.adb (Get_Category): Fix obvious typo + + * s-wwdcha.adb: Minor code reorganization + Remove dead code + +2008-08-22 Robert Dewar + + * checks.adb (Determine_Range): Deal with values that might be invalid + + * opt.adb, opt.ads (Assume_No_Invalid_Values[_Config]): New + configuration switches. + + * par-prag.adb: Dummy entry for pragma Assume_No_Invalid_Values + + * sem_prag.adb: Implement pragma Assume_No_Default_Values + + * snames.adb, snames.ads, snames.h: + Add entries for pragma Assume_No_Invalid_Values + + * switch-c.adb: Add processing for -gnatB switch + + * usage.adb: Add entry for flag -gnatB (no bad invalid values) + +2008-08-22 Javier Miranda + + * exp_ch3.adb (Build_Init_Statements): Transfer to the body of the + init procedure all the expanded code associated with the spec of + task types and protected types. + +2008-08-22 Gary Dismukes + + * exp_aggr.adb (Static_Array_Aggregate): Call Analyze_And_Resolve on the + component expression copies rather than directly setting Etype and + Is_Static_Expression. + +2008-08-22 Gary Dismukes + + * sem_util.adb (Has_Preelaborable_Initialization): Revise checking of + private types to allow for types derived from a private type with + preelaborable initialization, but return False for a private extension + (unless it has the pragma). + +2008-08-22 Robert Dewar + + * opt.ads: Minor code reorganization (put entries in alpha order) + +2008-08-22 Pascal Obry + + * initialize.c, adaint.c: Use Lock_Task and Unlock_Task for non-blocking + spawn. + +2008-08-22 Geert Bosch + + * gcc-interface/trans.c: Define FP_ARITH_MAY_WIDEN + (convert_with_check): Only use longest_float_type if FP_ARITH_MAY_WIDEN is 0 + +2008-08-22 Doug Rupp + + * bindgen.adb [VMS] (Gen_Adainit_Ada, Gen_Adainit_C): Import and call + __gnat_set_features. + + * init.c + (__gnat_set_features): New function. + (__gnat_features_set): New tracking variable. + (__gl_no_malloc_64): New feature global variable + +2008-08-22 Ed Schonberg + + * sem_ch8.adb (Use_One_Type): Do not emit warning message about redundant + use_type_clause in an instance. + +2008-08-22 Bob Duff + + * exp_ch6.ads: Remove pragma Precondition, since it breaks some builds. + +2008-08-22 Robert Dewar + + * exp_ch6.adb: Minor reformatting + + * exp_ch7.adb: Minor reformatting + + * exp_ch7.ads: Put routines in proper alpha order + + * exp_dist.adb: Minor reformatting + +2008-08-22 Vincent Celier + + * prj.ads: Minor comment update + +2008-08-22 Robert Dewar + + * sem_ch5.adb (One_Bound): Fix latent bug involving secondary stack + +2008-08-22 Ed Schonberg + + * exp_tss.adb: + (Base_Init_Proc): For a protected subtype, use the base type of the + corresponding record to locate the propoer initialization procedure. + +2008-08-22 Robert Dewar + + * checks.adb: + (In_Subrange_Of): New calling sequence + (Determine_Range): Prepare for new processing using base type + + * exp_ch4.adb: + (Compile_Time_Compare): Use new calling sequence + + * exp_ch5.adb: + (Compile_Time_Compare): Use new calling sequence + + * sem_eval.adb: + (Compile_Time_Compare): New calling sequence allows dealing with + invalid values. + (In_Subrange_Of): Ditto + + * sem_eval.ads: + (Compile_Time_Compare): New calling sequence allows dealing with + invalid values. + (In_Subrange_Of): Ditto + +2008-08-22 Pascal Obry + + * adaint.c: Fix possible race condition on win32_wait(). + +2008-08-22 Bob Duff + + * exp_ch5.adb, exp_ch7.adb, exp_ch7.ads, exp_util.adb, freeze.adb, + exp_ch4.adb, exp_ch6.ads, exp_ch6.adb, sem_ch6.adb, exp_aggr.adb, + exp_intr.adb, exp_ch3.adb: Rename: + Exp_Ch7.Controlled_Type => Needs_Finalization + Exp_Ch7.CW_Or_Controlled_Type => CW_Or_Has_Controlled_Part + Exp_Ch5.Expand_N_Extended_Return_Statement.Controlled_Type => + Has_Controlled_Parts + (Has_Some_Controlled_Component): Fix bug in array case. + +2008-08-22 Robert Dewar + + * sem_ch8.adb: Minor reformatting + +2008-08-22 Kevin Pouget + + * s-shasto.ads, s-shasto.adb: Move Shared_Var_ROpen, Shared_Var_WOpen and + Shared_Var_Close procedure specifications from package spec to package body. + + * rtsfind.ads: Remove RE_Shared_Var_Close, RE_Shared_Var_ROpen, + RE_Shared_Var_WOpen entries. + + * exp_dist.adb: Update RE_Any_Content_Ptr to RE_Any_Container_Ptr in + Build_To_Any_Call, Build_TypeCode_Call and Build_From_Any_Call procedures. + +2008-08-22 Eric Botcazou + + * init.c: adjust EH support code on Alpha/Tru64 as well. + + * raise-gcc.c: Add back a couple of comments. + +2008-08-22 Ed Schonberg + + * exp_ch5.adb (Expand_Simple_Function_Return): If secondary stack is + involved and the return type is class-wide, use the type of the expression + for the generated access type. Suppress useless discriminant checks on the + allocator. + +2008-08-22 Bob Duff + + * exp_ch7.adb: Minor comment fix + + * exp_ch6.ads: Minor comment fix + +2008-08-22 Thomas Quinot + + * sem_ch8.adb: Minor reformatting + Minor code reorganization (introduce subprogram to factor duplicated + code). + +2008-08-22 Sergey Rybin + + * gnat_ugn.texi: Change the description of gnatcheck default rule + settings. + +2008-08-22 Eric Botcazou + + * init.c (__gnat_adjust_context_for_raise): Delete for AIX, HP-UX, + Solaris, FreeBSD, VxWorks and PowerPC/Linux. For x86{-64}/Linux, + do not adjust the PC anymore. + (__gnat_error_handler): Do not call __gnat_adjust_context_for_raise + on AIX, HP-UX, Solaris, FreeBSD and VxWorks. + + * raise-gcc.c (get_call_site_action_for): Use _Unwind_GetIPInfo + instead of _Unwind_GetIP. + +2008-08-22 Gary Dismukes + + * exp_aggr.adb (Static_Array_Aggregate): When a static array aggregate + with a range is transformed into a positional aggregate, any copied + component literals should be marked Is_Static_Expression. + + * sem_eval.adb (Compile_Time_Known_Value): Don't treat null literals as + not being known at at compile time when Configurable_Run_Time_Mode is + true. + +2008-08-22 Robert Dewar + + * exp_attr.adb: + (Expand_N_Attribute_Reference): No validity checking on OUT parameter of + Read or Input attribute. + +2008-08-22 Ed Schonberg + + * sem_ch8.adb (Use_One_Type): when checking which of two use_type + clauses in related units is redundant, if one of the units is a package + instantiation, use its instance_spec to determine which unit is the + ancestor of the other. + +2008-08-22 Javier Miranda + + * exp_attr.adb (Expand_N_Attribute_Reference): In case of access + attributes add missing support to handle designated types that come + from the limited view. + + * exp_disp.adb (Expand_Interface_Conversion): Remove wrong assertion. + +2008-08-22 Sergey Rybin + + * vms_data.ads: Add entry for new gnatcheck -mNNN option + + * gnat_ugn.texi: Add description for gnatcheck option '-m' + +2008-08-22 Sergey Rybin + + * gnat_ugn.texi: Update the gnatcheck subsection for metric rules + acoording to the latest changes in the metric rule interface + +2008-08-22 Vincent Celier + + * make.adb (Check.File_Not_A_Source_Of): New Boolean function + (Check): Check if the file names registered in the ALI file for the + spec, the body and each of the subunits are the ones expected. + +2008-08-22 Robert Dewar + + * g-catiio.adb: Code cleanup. + +2008-08-20 Vincent Celier + + * make.adb (Gnatmake): Remove extra space in version line + + * ali.adb: + (Scan_ALI): Use Name_Find, not Name_Enter to get the name of a subunit, + as the name may already have been entered in the table by the Project + Manager. + +2008-08-20 Jose Ruiz + + * errno.c (__get_errno, __set_errno for MaRTE): Transform then into + weak symbols so we use the version provided by MaRTE when available. + +2008-08-20 Emmanuel Briot + + * g-catiio.ads, g-catiio.adb: + (Value): Avoid an unnecessary system call to Clock in most cases. + This call is only needed when only the time is provided in the string, + and ignored in all other cases. This is more efficient. + +2008-08-20 Eric Botcazou + + * raise-gcc.c: Fix formatting nits. + +2008-08-20 Robert Dewar + + * sem_ch13.adb: + (Adjust_Record_For_Reverse_Bit_Order): Do not access First_Bit for + non-existing component clause. + + * exp_ch5.adb: Minor reformatting + + * g-comlin.adb: Minor reformatting + + * make.adb: Minor reformatting + + * prj-proc.adb: Minor reformatting + + * stylesw.ads: Minor reformatting + +2008-08-20 Vincent Celier + + * make.adb (Gnatmake_Switch_Found): New Boolean global variable + (Switch_May_Be_Passed_To_The_Compiler): New Boolean global variable + (Add_Switches): New Boolean parameter Unknown_Switches_To_The_Compiler + defaulted to True. Fail when Unknown_Switches_To_The_Compiler is False + and a switch is not recognized by gnatmake. + (Gnatmake): Implement new scheme for gnatmake switches and global + compilation switches. + (Switches_Of): Try successively Switches (), + Switches ("Ada"), Switches (others) and Default_Switches ("Ada"). + +2008-08-20 Ed Schonberg + + * styleg-c.ads, styleg-c.adb (Missing_Overriding): new procedure to + implement style check that overriding operations are explicitly marked + at such. + + * style.ads (Missing_Overriding): new procedure that provides interface + to previous one. + + * stylesw.ads, stylesw.adb: New style switch -gnatyO, to enable check + that the declaration or body of overriding operations carries an + explicit overriding indicator. + + * sem_ch8.adb + (Analyze_Subprogram_Renaming): if operation is overriding, check whether + explicit indicator should be present. + + * sem_ch6.adb (Verify_Overriding_Indicator, + Check_Overriding_Indicator): If operation is overriding, check whether + declaration and/or body of subprogram should be present + +2008-08-20 Vincent Celier + + * prj-nmsc.adb (Check_Naming_Schemes): Accept source file names for + gprbuild when casing is MixedCase, whatever the casing of the letters + in the file name. + +2008-08-20 Gary Dismukes + + * exp_ch3.adb (Build_Array_Init_Proc): Clarify comment related to + creating dummy init proc. + (Requires_Init_Proc): Return False in the case No_Default_Initialization + is in force and the type does not have associated default + initialization. Move test of Is_Public (with tests of restrictions + No_Initialize_Scalars and No_Default_Initialization) to end, past tests + for default initialization. + +2008-08-20 Jerome Lambourg + + * g-comlin.adb (For_Each_Simple_Switch): Take care of switches not part + of any alias or prefix but having attached parameters (as \"-O2\"). + +2008-08-20 Robert Dewar + + * s-fileio.adb: Minor reformatting + +2008-08-20 Thomas Quinot + + * exp_strm.adb (Build_Elementary_Input_Call, + Build_Elementary_Write_Call): Fix incorrect condition in circuitry that + selects the stream attribute routines for long float types. + +2008-08-20 Vincent Celier + + * prj-proc.adb (Process_Declarative_Items): Add Location for Array_Data + + * prj.ads (Array_Data): Add a component Location + +2008-08-20 Ed Schonberg + + * sem_prag.adb: + (Analyze_Pragma, case Obsolescent): Add entity information on the pragma + argument for ASIS and navigation use. + +2008-08-20 Ed Schonberg + + * einfo.ads: Add comment. + +2008-08-20 Bob Duff + + * sem_eval.ads: Minor comment fix. + +2008-08-20 Bob Duff + + * exp_ch4.adb (Expand_N_And_Then, Expand_N_Or_Else): Improve constant + folding. We were folding things like "False and then ...", but not + "X and then ..." where X is a constant whose value is known at compile + time. + +2008-08-20 Hristian Kirtchev + + * exp_ch5.adb (Controlled_Type): New routine. + (Expand_N_Extended_Return_Statement): When generating a move of the + final list in extended return statements, check the type of the + function and in the case of double expanded return statements, the type + of the returned object. + (Expand_Simple_Function_Return): Perform an interface conversion when + the type of the returned object is an interface and the context is an + extended return statement. + +2008-08-20 Ed Schonberg + + * sem_util.adb (Set_Debug_Info_Needed): If the entity is a private type + and the full view is visible, set flag on full view as well. + +2008-08-20 Thomas Quinot + + * g-comlin.adb: Minor reformatting + Minor code reorganization. + + * freeze.adb: Minor reformatting + +2008-08-20 Vincent Celier + + * prj-nmsc.adb (Check_File): An excluded Ada source file may be a + source of another project. + +2008-08-20 Pascal Obry + + * s-os_lib.ads: Minor reformatting. + +2008-08-20 Arnaud Charlet + + * gnatvsn.ads: Minor reformatting. + +2008-08-20 Arnaud Charlet + + * a-crbtgk.adb, repinfo.adb, g-traceb.ads, repinfo.ads, + system-linux-s390x.ads, s-fatflt.ads, s-parame-ae653.ads, g-spipat.adb, + g-spipat.ads, g-tasloc.adb, g-debpoo.adb, g-except.ads, g-debpoo.ads, + mdll-utl.adb, g-string.adb, g-soliop-solaris.ads, par-sync.adb, + exp_ch6.ads, a-cihama.ads, g-curexc.ads, system-linux-sh4.ads, + g-utf_32.adb, g-hesorg.adb, s-proinf-irix-athread.ads, s-parint.adb, + s-parint.ads, exp_ch7.ads, system-linux-alpha.ads, g-dirope.adb, + sinfo-cn.adb, par-labl.adb, a-ciorse.adb, g-calend.adb, + s-parame-vms-alpha.ads, nlists.h, exp_imgv.adb, exp_fixd.ads, + g-calend.ads, gnatcmd.ads, g-table.adb, s-memory-mingw.adb, + g-alveop.ads, g-memdum.ads, g-altive.ads, initialize.c, g-regpat.adb, + g-busorg.ads, g-regpat.ads, g-encstr.ads, g-regexp.adb, g-regexp.ads, + live.ads, g-dyntab.adb, prj-nmsc.ads, par-ch12.adb, 9drpc.adb, + g-alvevi.ads, s-memory.adb, math_lib.adb, s-parame.ads, s-memory.ads, + s-regexp.adb, a-exexda.adb, i-cstrea-vms.adb, a-exexpr.adb, + g-soliop-mingw.ads, s-imgrea.adb, namet.adb, system-vms.ads, + s-inmaop-dummy.adb, s-finroo.ads, a-ngcefu.adb, s-hibaen.ads, + g-soliop.ads, s-auxdec.adb, g-locfil.ads, gnatxref.adb, memroot.adb, + osint-b.ads, memroot.ads, s-parame-hpux.ads, errutil.adb, + system-linux-s390.ads, par-util.adb, osint-c.ads, exp_pakd.ads, + i-pacdec.ads, par-endh.adb, mlib-tgt.ads, prj-strt.ads, + s-osprim-vms.adb, s-proinf.ads, output.ads, g-moreex.ads, + a-finali.ads, s-fatlfl.ads, namet.h, mdll.ads, g-dynhta.ads, + s-imgenu.ads, par-tchk.adb, g-excact.ads, memtrack.adb, s-fatgen.adb, + a-exexpr-gcc.adb, g-arrspl.adb, par-ch4.adb, g-cgideb.adb, freeze.ads, + g-altcon.adb, s-fatllf.ads, gnatfind.adb, s-osinte-lynxos-3.adb, + a-exextr.adb, g-htable.ads, a-calfor.adb, s-imgcha.adb, argv.c, + a-chahan.ads, g-hesora.adb, system-vms_64.ads, par-ch5.adb, g-md5.adb, + lib-xref.ads, g-md5.ads, g-casuti.ads, s-fatsfl.ads, exp_dbug.ads, + s-htable.ads, a-ngcoar.adb, s-arit64.ads, a-ngelfu.adb, a-filico.ads, + par-ch6.adb, s-inmaop.ads, s-parame-vxworks.ads, s-casuti.ads, + a-numaux-darwin.adb, a-cohama.ads, system-linux-sparc.ads, g-os_lib.adb, + system-vms-ia64.ads, s-parame-vms-restrict.ads, a-clrefi.ads, + s-parame-vms-ia64.ads, a-strfix.adb, a-coorse.adb, a-comlin.ads, + a-chtgke.adb, s-imgint.adb, g-expect.ads, exp_ch4.ads, s-finimp.adb, + mingw32.h, g-heasor.adb, g-alleve.adb, a-ngrear.adb, s-mastop-irix.adb, + s-poosiz.adb, link.c: Fix copyright notice. + +2008-08-20 Arnaud Charlet + + * g-comlin.ads: Update comments. + +2008-08-20 Ed Schonberg + + * sem_ch8.adb (Analyze_Subprogram_Renaming): Inherit Is_Imported flag. + +2008-08-20 Gary Dismukes + + * exp_ch11.adb: + (Expand_Exception_Handlers): Call Make_Exception_Handler instead of + Make_Implicit_Exception_Handler when rewriting an exception handler with + a choice parameter, and pass the handler's Sloc instead of that of the + handled sequence of statements. Make_Implicit_Exception_Handler sets the + Sloc to No_Location (unless debugging generated code), which we don't + want for the case of a user handler. + +2008-08-20 Robert Dewar + + * freeze.adb (Freeze_Record_Type): Improve msg for non-contiguous field + + * sem_ch13.adb: + (Adjust_Record_For_Reverse_Bit_Order): Messages about layout are + now labeled as info msgs, not warnings. + + * tbuild.ads: Clarify documentation of Make_Implicit_Exception_Handler + + * usage.adb: Minor change to avoid overlong line for -gnatwz/Z + + * a-textio.adb: Remove redundant test. + + * a-witeio.adb: Minor code reorganization + Remove redundant test found working on another issue + + * a-ztexio.adb: Minor code reorganization + Remove redundant test found working on another issue + +2008-08-20 Thomas Quinot + + * s-fileio.adb (Open) Use C helper function to determine whether a + given errno value corresponds to a "file not found" error. + + * sysdep.c (__gnat_is_file_not_found_error): New C helper function. + +2008-08-20 Jose Ruiz + + * errno.c (__get_errno for MaRTE): Use the MaRTE function pthread_errno + to get access to the per-task errno variable. + (__set_errno for MaRTE): Do not redefine this function here since it is + already defined in MaRTE. + +2008-08-20 Tristan Gingold + + * gnat_ugn.texi: Gcov is not supported on static library on AIX. + +2008-08-20 Robert Dewar + + * freeze.adb: Minor reformatting + + * g-comlin.adb: Minor reformatting + + * g-socket.adb: Minor reformatting + + * g-socthi-mingw.adb: Minor reformatting + + * g-stheme.adb: Minor reformatting + +2008-08-20 Ed Schonberg + + * sem_aggr.adb, sem_type.adb, exp_ch9.ads, einfo.ads, + exp_ch6.adb, exp_aggr.adb (Valid_Ancestor): Resolve + confusion between partial and full views of an ancestor of the context + type when the parent is a private extension declared in a parent unit, + and full views are available for the context type. + +2008-08-18 Samuel Tardieu + Robert Dewar + + PR ada/30827 + * bindgen.adb (Gen_Output_File_Ada): Zero-terminate the + version string. + Move comment in the right place. + * g-comver.adb (Version): Look for a zero-termination in + addition to a closing parenthesis. + +2008-08-18 Samuel Tardieu + + * exp_ch13.adb, exp_disp.adb, sem_cat.adb, sem_ch10.adb, + * sem_ch12.adb, sem_ch6.adb, sem_ch7.adb, sem_ch8.adb, + * sem_prag.adb, sem_util.adb, sem_warn.adb: Use + Is_Package_Or_Generic_Package instead of hand-crafted tests. + +2008-08-18 Samuel Tardieu + + PR ada/15808 + * sem_ch6.adb (Check_Private_Overriding): Check for generic packages + as well. + +2008-08-17 Aaron W. LaFramboise + + * adaint.c (_gnat_set_close_on_exec) [_WIN32]: Implement. + +2008-08-16 Eric Botcazou + + * gcc-interface/trans.c (call_to_gnu): Use the Sloc of the call + for back-copy statements in lieu of that of the actual. + +2008-08-16 Eric Botcazou + + PR ada/20548 + * gcc-interface/decl.c (gnat_to_gnu_entity): Use DECL_SIZE_UNIT in the + setjmp test consistently. Adjust for new behavior of flag_stack_check. + * gcc-interface/utils2.c (build_call_alloc_dealloc): Remove redundant + test of flag_stack_check. Adjust for new behavior of flag_stack_check. + +2008-08-13 Samuel Tardieu + + PR ada/36777 + * sem_util.ads, sem_util.adb (Is_Protected_Self_Reference): New. + * sem_attr.adb (Check_Type): The current instance of a protected + object is not a type name. + (Analyze_Access_Attribute): Accept instances of protected objects. + (Analyze_Attribute, Attribute_Address clause): Ditto. + * exp_attr.adb (Expand_N_Attribute_Reference): Rewrite + the prefix as being the current instance if needed. + +2008-08-12 Danny Smith + + * gcc-interface/Makefile.in (EXTRA_GNATRTL_NONTASKING_OBJS) [WINDOWS]: + Remove duplicate s-win32.o. Add s-winext.o. + +2008-08-12 Danny Smith + + * g-stsifd-sockets.adb (Create): Replace Constants.SOCK_STREAM + with SOSC.SOCK__STREAM. + * g-socthi-mingw.adb (C_Select) Replace Constants.MSG_OOB with + SOSC.MSG_OOB. + +2008-08-11 Joel Sherrill + + * s-oscons-tmplt.c: RTEMS defines AF_INET6 but does support it. + * gsocket.h, socket.c: Update to support RTEMS. + * gcc-interface/Make-lang.in: Include CFLAGS_FOR_TARGET when cross. + +2008-08-10 Samuel Tardieu + Robert Dewar + + * exp_ch4.adb (Expand_N_Op_Expon): Force evaluation of + left argument even when right argument is 0. + (Expand_N_Op_Mod): Ditto when right argument is 1. + (Expand_N_Op_Multiply): Ditto when any argument is 0. + (Expand_N_Op_Rem): Ditto when right argument is 1. + +2008-08-09 Manuel Lopez-Ibanez + + * gcc-interface/misc.c (gnat_handle_option): Replace set_Wunused + by warn_unused. + +2008-08-08 Ed Schonberg + + * freeze.adb (Generate_Prim_Op_References): New procedure, abstracted + from Freeze_Entity. Used to generate cross-reference information for + types declared in generic packages. + +2008-08-08 Thomas Quinot + + * gcc-interface/Makefile.in: Reintroduce g-soccon.ads as a + compatibility shim. + +2008-08-08 Thomas Quinot + + * gsocket.h: + On Windows, include and redefine only selected errno values + from their definitions. + + * s-osinte-freebsd.ads: Minor reformatting + + * s-osinte-hpux.ads, s-osinte-irix.ads: Minor reformatting + + * g-soccon.ads: New file. + + * g-stheme.adb, g-socthi-vms.adb, g-socthi-vxworks.adb, + g-socthi-mingw.adb, g-sttsne-vxworks.adb, g-socthi.adb, + g-stsifd-sockets.adb, g-socket.adb, g-socket.ads, + g-sothco.adb, g-sothco.ads: Add back GNAT.Sockets.Constants as a child + unit, to allow building software that depends on this internal unit + with both older and newer compilers. + +2008-08-08 Robert Dewar + + * s-strxdr.adb: Minor reformatting + +2008-08-08 Bob Duff + + * gnat_ugn.texi: The "Run-Time Checks" section said "arithmetic overflow + checking for integer operations (including division by zero)", which + is wrong -- divide by zero is not part of overflow checking. + Also added misc clarification about what check-suppression means. + + * gnat_rm.texi: Clarify the meaning of pragma Suppress. + +2008-08-08 Jerome Lambourg + + * g-comlin.adb (Add_Switch): Handle addition of switches at the + begining of the command line. + (Append, Add): Renaming of Append to Add as this now allows addition + at the begining of the list. + + * g-comlin.ads (Add_Switch): Handle addition of switches at the + begining of the command line. + +2008-08-08 Thomas Quinot + + * g-sercom.ads: + (Name): Document application scope (only legacy PC serial ports on + Linux and Windows). + +2008-08-08 Thomas Quinot + + * gcc-interface/Makefile.in, gcc-interface/Make-lang.in: Revert + previous change, not needed after all. + +2008-08-08 Ed Schonberg + + * exp_ch4.adb (Expand_Allocator_Expression): add check if null + exclusion indicator is present + +2008-08-08 Robert Dewar + + * g-comlin.adb: Minor code reorganization + Minor reformatting + + * g-comlin.ads: Minor reformatting + + * s-fileio.adb: Minor reformatting + + * sem_attr.adb: Minor code reorganization (use Nkind_In) + Minor reformatting + +2008-08-06 Samuel Tardieu + + * gcc-interface/Make-lang.in: Use GCC_FOR_TARGET when dealing + with s-oscons-tmplt.i. + +2008-08-06 Samuel Tardieu + + * gcc-interface/Make-lang.in (OSCONS_CPPFLAGS): Remove. + +2008-08-06 Ed Schonberg + + * sem_ch3.adb (Analyze_Component_Declaration): Protect against misuse + of incomplete type. + + * sem_ch8.adb (Analyze_Object_Renaming): Diagnose properly a renaming + of a formal parameter of an incomplete type. Improve error message for + other improper uses of incomplete types. + +2008-08-06 Robert Dewar + + * gnat_ugn.texi: Clarify -gnato documentation + +2008-08-06 Thomas Quinot + + * gcc-interface/Makefile.in, + g-socthi-vxworks.adb, g-socthi-mingw.adb, g-sttsne-vxworks.adb, + g-socthi.adb, g-socket.adb, g-socket.ads, g-sothco.ads, + g-soccon-linux-x86.ads, g-soccon-vxworks.ads, g-soccon-mingw.ads, + g-soccon-hpux-ia64.ads, g-soccon-irix.ads, g-soccon-linux-64.ads, + g-soccon-aix.ads, g-soccon-solaris.ads, g-soccon-lynxos.ads, + g-soccon-vms.ads, g-soccon.ads, g-soccon-freebsd.ads, + g-soccon-linux-ppc.ads, g-soccon-tru64.ads, g-soccon-hpux.ads, + g-soccon-solaris-64.ads, gen-oscons.c, g-soccon-darwin.ads, + g-soccon-mingw-64.ads, g-soccon-linux-mips.ads, g-soccon-rtems.ads: + Remove GNAT.Sockets.Constants. This internal package is replaced by + System.OS_Constants. + +2008-08-06 Thomas Quinot + + * gcc-interface/Makefile.in, gcc-interface/Make-lang.in: + Remove obsolete targets referencing gen-soccon + When generating s-oscons.ads, use a file name that includes the + THREAD_KIND, to ensure that the (potentially different) version from a + previous build with a different threads flavour does not get reused. + +2008-08-06 Thomas Quinot + + * sem_res.adb: Minor reformatting + + * s-fileio.adb (Open): When file open operation fails, raise Name_Error + only when the operating system reports a non-existing file or directory + (ENOENT), otherwise raise Name_Error. + + * exp_ch11.adb: Minor reformatting + +2008-08-06 Ed Schonberg + + * sem_ch3.adb (Access_Subprogram_Declaration): If the return type is + incomplete, add the access_to_subprogram type to the list of private + dependents only if the incomplete type will be completed in the current + scope. + (Build_Discriminant_Constraints): If the type of the discriminant is + access_to_variable, reject a constraint that is access_to_constant. + +2008-08-06 Thomas Quinot + + * g-socket-dummy.adb, g-socket-dummy.ads, g-sothco-dummy.adb, + g-sothco-dummy.ads, g-socthi-dummy.adb, g-socthi-dummy.ads, + g-sttsne-dummy.ads: New files. + + * gcc-interface/Makefile.in, Makefile.rtl: Use placeholder sources + with pragma Unimplemented_Unit for sockets packages on Nucleus. + +2008-08-06 Pascal Obry + + * adaint.c: Another fix for ACL support on Windows. + +2008-08-06 Javier Miranda + + * exp_disp (Expand_Interface_Actuals): Adds missing support for + expansion of calls to subprograms using selected components. + +2008-08-06 Ed Schonberg + + * sem_res.adb (Resolve_Call): Use base type to determine whether a + dereference is needed because a subtype of an access_to_subprogram is + simply an access-subtype + +2008-08-06 Jerome Lambourg + + * g-comlin.adb (Set_Command_Line): Now that aliases can contain + parameters, always specify the expected separator. + +2008-08-06 Thomas Quinot + + * xnmake.adb: Use new XUtil package for platform independent text + output. + +2008-08-06 Vincent Celier + + * gnat_ugn.texi: Document compiler switch -gnateG + +2008-08-06 Quentin Ochem + + * s-stausa.adb (Fill_Stack): Fixed pragma assert and top pattern mark + in the case of an empty pattern size. + (Compute_Result): Do not do any computation in the case of an empty + pattern size. + (Report_Result): Fixed computation of the overflow guard. + +2008-08-06 Ed Schonberg + + * g-awk.adb (Finalize): Do not use directly objects of the type in the + finalization routine to prevent elaboration order anomalies in new + finalization scheme. + +2008-08-06 Ed Schonberg + + * sem_ch3.adb (Find_Type_Name): protect against duplicate incomplete + declaration for the same type. + +2008-08-06 Thomas Quinot + + * sem.adb: Minor rewording (comment) + +2008-08-06 Jerome Lambourg + + * g-comlin.adb (Define_Switch, Get_Switches): New. + (Can_Have_Parameter, Require_Parameter, Actual_Switch): New, used when + ungrouping switches. + (For_Each_Simple_Switch): Allow more control over parameters handling. + This generic method now allows ungrouping of switches with parameters + and switches with more than one letter after the prefix. + (Set_Command_Line): Take care of switches that are prefixed with a + switch handling parameters without delimiter (-gnatya and -gnaty3 for + example). + (Add_Switch, Remove_Switch): Handle parameters possibly present inside + a group, as in gnaty3aM80 (3 and 80 are parameters). Report status of + the operation. + (Start, Alias_Switches, Group_Switches): Take care of parameters + possibly present inside a group. + + * g-comlin.ads (Define_Switch): New method used to define a list of + expected switches, that are necessary for correctly ungrouping switches + with more that one character after the prefix. + (Get_Switches): Method that builds a getopt string from the list of + switches as set previously by Define_Switch. + (Add_Switch, Remove_Switch): New versions of the methods, reporting the + status of the operation. Also allow the removal of switches with + parameters only. + (Command_Line_Configuration_Record): Maintain a list of expected + switches. + +2008-08-06 Doug Rupp + + * gcc-interface/decl.c (gnat_to_gnu_param): Force 32bit descriptor if + TARGET_MALLOC64 clear. + + * gcc-interface/utils2.c (build_call_alloc_dealloc): Force 32bit malloc + if TARGET_MALLOC64 clear. + + * gcc-interface/gigi.h (TARGET_ABI_OPEN_VMS): Move here from utils2.c + (TARGET_MALLC64): New macro. Default to clear. + +2008-08-06 Doug Rupp + + * gcc-interface/utils2.c (snames.h) Include + (TARGET_ABI_OPEN_VMS): Initialize. + (build_call_alloc_dealloc); [TARGET_ABI_OPEN_VMS] Allocate on 32bit heap + for Convention C. + +2008-08-06 Ed Schonberg + + * sem_ch3.adb (Process_Discriminants): diagnose redundant or improper + null exclusion in a discriminant declaration + + * sem_ch8.adb (Analyze_Object_Renaming): diagnose null exclusion + indicators when type is not an access type. + + * sem_ch12.adb (Formal_Object_Declaration): diagnose null exclusion + indicators when type is not an access type. + +2008-08-06 Javier Miranda + + * exp_disp (Expand_Interface_Conversion): Freeze the entity associated + with the target interface before expanding the code of the interface + conversion. + +2008-08-05 Ed Schonberg + + * freeze.adb: + (Freeze_Entity): A deferred constant does not violate the restriction + No_Default_Initialization, + + * sem_ch3.adb (Process_Subtype): An allocator is a valid construct that + can carry a null exclusion indicator, and on which an error may be + posted if the indicator is redundant. + + * sem_ch8.adb (Analyze_Object_Renaming): Verify that a null exclusion + does not apply to a subtype mark that already excludes null. + + * sem_ch12.adb (Formal_Object_Declaration): Verify that a null + exclusion does not apply to a subtype mark that already excludes null. + +2008-08-05 Thomas Quinot + + * Makefile.rtl: Compile s-oscons.ads as part of the runtime library. + +2008-08-05 Doug Rupp + + * vms_data.ads: Translation for /POINTER_SIZE qualifier. + +2008-08-05 Thomas Quinot + + * gsocket.h: Make this file includable in a Nucleus environment, which + does not support sockets. + + * socket.c: Remove Nucleus-specific hack. + +2008-08-05 Pascal Obry + + * adaint.c: Remove support for readable attribute on vxworks and nucleus + +2008-08-05 Ed Schonberg + + * sem_attr.adb: + (Analyze_Attribute, case 'Result): handle properly the case where some + operand of the expression in a post-condition generates a transient + block. + + * sem_ch5.adb (Analyze_Assignment_Statement): Apply conversion to + right-hand side when it is an anonymous access_to_subprogram, to force + static accessibility check when needed. + +2008-08-05 Sergey Rybin + + * gnat_ugn.texi: Changing the description of the gnatcheck metrics + rule according to the change in the rule option. + Add documentation for -gnatw.b/-gnatw.B + +2008-08-05 Robert Dewar + + * ug_words: Add entries for -gnatw.b/-gnatw.B + + * vms_data.ads: Add entries for -gnatw.b/-gnatw.B + +2008-08-05 Vincent Celier + + * a-wtdeio.adb (Put (Current_Output)): Use Fore in the call to Put + (File). + + * a-ztdeio.adb: Ditto. + +2008-08-05 Pascal Obry + + * adaint.c, adaint.h, s-os_lib.adb, s-os_lib.ads: Add support for the + readable attribute. + +2008-08-05 Vincent Celier + + * s-wchwts.adb: + (Wide_String_To_String): Returns a String with the same 'First as its + parameter S. + (Wide_Wide_String_To_String): Ditto + + * s-wchwts.ads: + (Wide_String_To_String): Document that the lowest index of the returned + String is equal to S'First. + +2008-08-05 Thomas Quinot + + * xoscons.adb, xutil.ads, xutil.adb, s-oscons-tmplt.c: New files. + + * gcc-interface/Makefile.in, gcc-interface/Make-lang.in: Generate + s-oscons.ads + +2008-08-05 Robert Dewar + + * opt.ads (Warn_On_Biased_Representation): New flag + + * sem_ch13.adb: + (Analyze_Attribute_Definition_Clause): Issue warning when biased + representation is required. + (Minimum_Size): Don't allow biasing if enum rep clause case + + * sem_warn.adb: + (Set_Dot_Warning_Switch): Add handling of -gnatw.b/B switches + (Set_Warning_Switch): Include -gnatw.b in -gnatwa, -gnatw.B in gnatws + + * usage.adb: Add lines for -gnatw.b/B switches + +2008-08-05 Pascal Obry + + * a-coinve.adb: Reorder the code to avoid uninitialized warning. + + * adaint.c: In UNIX cases do not call __gnat_stat but stat directly. + +2008-08-05 Thomas Quinot + + * socket.c: Minor reformatting. + +2008-08-05 Robert Dewar + + * sem_ch3.adb: Minor reformatting + + * prj-nmsc.adb: Minor reformatting + +2008-08-05 Ed Schonberg + + * sem_ch12.adb (Validate_Array_Type_Instance): Only apply complex + visibility check on the component type if the simple test fails. + +2008-08-05 Jose Ruiz + + * init.c (__gnat_install_handler for linux): If we are building the + Xenomai run time then we need to do two additional things: avoid + memory swapping and transform the Linux environment task into a native + Xenomai task. + + * gcc-interface/Makefile.in (LIBGNAT_TARGET_PAIRS for xenomai run + time): Use interface to Xenomai native skin and avoid linux-specific + way of setting CPU affinity. + (EH_MECHANISM for the xenomai run time): Use sjlj exception mechanism. + +2008-08-05 Bob Duff + + * checks.ads: Minor comment fix + +2008-08-05 Thomas Quinot + + * g-sercom.adb, g-sercom.ads, g-sercom-mingw.adb, + g-sercom-linux.adb (Data_Bits): Change literals B7 and B8 to CS7 and + CS8. + +2008-08-05 Robert Dewar + + * mlib.adb: Minor code reorganization + Minor reformatting + + * make.adb: Minor reformatting + + * prj-attr.ads: Minor reformatting + + * s-os_lib.adb: Minor reformatting + + * s-fileio.adb: Minor code reorganization + Minor reformatting + + * prj.ads: Minor reformatting + +2008-08-05 Bob Duff + + * sem_ch3.adb (Analyze_Object_Declaration): Avoid type Any_Access in + unresolved initial value of "null", because it causes implicitly + generated "=" operators to be ambiguous, and because this type should + not be passed to gigi. + +2008-08-05 Vincent Celier + + * mlib.adb: Update comments. + + * make.adb (Switches_Of): Check for Switches (others), before checking + for Default_Switches ("Ada"). + (Gnatmake): Use Builder'Switches (others) in preference to + Builder'Default_Switches ("Ada") if there are several mains. + + * prj-attr-pm.adb: + (Add_Attribute): Add component Others_Allowed in Attribute_Record + aggregate. + + * prj-attr.adb: + Add markers to indicates that attributes Switches allow others as index + (Others_Allowed_For): New Boolean function, returning True for + attributes with the mark. + (Initialize): Recognize optional letter 'O' as the marker for + associative array attributes where others is allowed as the index. + + * prj-attr.ads: + (Others_Allowed_For): New Boolean function + (Attribute_Record): New Boolean component Others_Allowed + + * prj-dect.adb: + (Parse_Attribute_Declaration): For associative array attribute where + others is allowed as the index, allow others as an index. + + * prj-nmsc.adb: + (Process_Binder): Skip associative array attributes with index others + (Process_Compiler): Ditto + + * prj-util.adb: + (Value_Of (Index, In_Array)): Make no attempt to put in lower case when + index is All_Other_Names. + + * prj.ads: + (All_Other_Names): New constant + + * prj-proc.adb: + (Process_Declarative_Items): Skip associative array attribute when index + is reserved word "others". + +2008-08-05 Vasiliy Fofanov + + * gen-oscons.c: Adapt for VMS where termios.h is not available. + +2008-08-05 Thomas Quinot + + * a-rttiev.adb: Minor reformatting (comments) + + * gen-soccon.c: Rename to gen-oscons.c + + * gen-oscons.c: New file. Now generate System.OS_Constants instead of + GNAT.Sockets.Constants. + Add new constants for GNAT.Serial_Communications and System.File_IO. + +2008-08-05 Javier Miranda + + * sem_util.adb (Collect_Interfaces_Info): Minor reformating. + * exp_ch3.adb (Build_Offset_To_Top_Functions): Code cleanup: the + implementation of this routine has been simplified. + +2008-08-05 Pascal Obry + + * adaint.c, adaint.h, s-os_lib.adb, s-os_lib.ads: Fix the + Set_Read_Only Win32 implementation. + +2008-08-05 Thomas Quinot + + * exp_strm.adb: Minor reformatting (comments) + + * sem_ch12.adb: Minor reformatting. + +2008-08-05 Robert Dewar + + * sem_ch3.adb: Minor reformatting + + * checks.adb: Minor reformatting + +2008-08-05 Thomas Quinot + + * tbuild.ads (New_External_Name): Update spec to reflect relaxed + restriction on Prefix. + +2008-08-05 Jerome Lambourg + + * g-comlin.adb (Sort_Sections, Group_Switches): New/Modified internal + methods needed to handle switch sections when building a command line. + (Define_Section, Add_Switch, Remove_Switch, Is_New_Section, + Current_Section): New public methods or methods modified to handle + building command lines with sections. + (Set_Command_Line): Take into account sections when analysing a switch + string. + (Start): Sort the switches by sections before iterating the command line + elements. + + * g-comlin.ads (Define_Section, Add_Switch, Remove_Switch, + Is_New_Section, Current_Section): New methods or methods modified to + handle building command lines with sections. + +2008-08-05 Ed Schonberg + + * exp_strm.adb (Build_Record_Or_Elementary_Input_Function): For access + discriminants, indicate that the corresponding object declaration has + no initialization, to prevent spurious warnings when the access type is + null-excluding. + +2008-08-05 Ed Schonberg + + * sem_res.adb (Resolve_Call): If this is a call to the predefined + Abort_Task, warn if the call appears within a protected operation. + +2008-08-04 Robert Dewar + + * exp_ch4.adb (Expand_N_In): Suppress range warnings in instances + +2008-08-04 Ed Schonberg + + * sem_ch3.adb: + (Replace_Anonymous_Access_To_Protected_Subprogram): Handle properly an + anonymous access to protected subprogram that is the return type of the + specification of a subprogram body. + + * sem_ch6.adb: + (Analyze_Subprogram_Body): if the return type is an anonymous access to + subprogram, freeze it now to prevent access anomalies in the back-end. + + * exp_ch9.adb: Minor code cleanup. + Make sure that new declarations are inserted into the tree before + analysis (from code reading). + +2008-08-04 Robert Dewar + + * exp_ch5.adb: + (Expand_Simple_Function_Return): Check No_Secondary_Stack restriction + at point of return. + +2008-08-04 Thomas Quinot + + * sem_type.adb, sem_ch4.adb, sprint.adb, exp_ch3.adb: Minor reformatting + +2008-08-04 Vasiliy Fofanov + + * g-soccon-mingw.ads: Fix value for MSG_WAITALL + +2008-08-04 Javier Miranda + + * sem_prag.adb (Process_Convention): Add missing support for + N_Private_Extension_Declaration nodes. + +2008-08-04 Robert Dewar + + * exp_ch4.adb: Minor reformatting + +2008-08-04 Pascal Obry + + * adaint.h: Add missing prototype. + + * adaint.c: Refine support for Windows file attributes. + +2008-08-04 Robert Dewar + + * sem_res.adb: + (Valid_Conversion): Catch case of designated types having different + sizes, even though they statically match. + +2008-08-04 Javier Miranda + + * sem_eval.adb (Subtypes_Statically_Match): Remove superfluous patch + added in previous patch to handle access to subprograms. + +2008-08-04 Robert Dewar + + * freeze.adb: + (Freeze_Entity): Only check No_Default_Initialization restriction for + constructs that come from source + +2008-08-04 Thomas Quinot + + * exp_ch6.adb: Minor comment fix. + + * sem_ch4.adb: Minor reformatting. + +2008-08-04 Robert Dewar + + * sem_res.adb: (Large_Storage_Type): Improve previous change. + +2008-08-04 Pascal Obry + + * adaint.c, s-os_lib.adb, s-os_lib.ads: Use Windows ACL to deal with + file attributes. + +2008-08-04 Javier Miranda + + * sem_ch3.adb (Access_Subprogram_Declaration): Adding missing support + for N_Formal_Object_Declaration nodes. Adding kludge required by + First_Formal to provide its functionality with access to functions. + (Replace_Anonymous_Access_To_Protected_Subprogram): Add missing support + for anonymous access types returned by functions. + + * sem_ch5.adb (Analyze_Assignment): Code cleanup to avoid duplicate + conversion of null-excluding access types (required only once to force + the generation of the required runtime check). + + * sem_type.adb (Covers): minor reformating + + * checks.adb (Null_Exclusion_Static_Checks): Avoid reporting errors + with internally generated nodes. Avoid generating the error inside init + procs. + + * sem_res.adb (Resolve_Membership_Test): Minor reformating. + (Resolve_Null): Generate the null-excluding check in case of assignment + to a null-excluding object. + (Valid_Conversion): Add missing support for anonymous access to + subprograms. + + * sem_ch6.adb (Check_Return_Subtype_Indication): Add missing support for + anonymous access types whose designated type is an itype. This case + occurs with anonymous access to protected subprograms types. + (Analyze_Return_Type): Add missing support for anonymous access to + protected subprogram. + + * sem_eval.adb (Subtypes_Statically_Match): In case of access to + subprograms addition of missing check on matching convention. Required + to properly handle access to protected subprogram types. + + * exp_ch3 (Build_Assignment): Code cleanup removing duplicated check on + null excluding access types. + +2008-08-04 Ed Schonberg + + * sem_ch12.adb: Add comments + + * sem_ch4.adb (Analyze_Allocator): If the designated type is a non-null + access type and the allocator is not initialized, warn rather than + reporting an error. + +2008-08-04 Robert Dewar + + * exp_ch4.adb: Minor reformatting + + * exp_dist.adb: Minor reformatting + + * g-comlin.adb: Minor reformatting + +2008-08-04 Gary Dismukes + + * exp_aggr.adb (Build_Record_Aggr_Code): Perform a conversion of the + target to the type of the aggregate in the case where the target object + is class-wide. + + * exp_ch5.adb (Expand_Simple_Function_Return): When the function's + result type is class-wide and inherently limited, and the expression + has a specific type, create a return object of the specific type, for + more efficient handling of returns of build-in-place aggregates (avoids + conversions of the class-wide return object to the specific type on + component assignments). + + * sem_ch6.adb (Check_Return_Subtype_Indication): Suppress the error + about a type mismatch for a class-wide function with a return object + having a specific type when the object declaration doesn't come from + source. Such an object can result from the expansion of a simple return. + +2008-08-04 Vasiliy Fofanov + + * g-soccon-mingw-64.ads, system-mingw-x86_64.ads: New files. + + * gcc-interface/Makefile.in: Use 64bit-specific system files when + compiling for 64bit windows. + +2008-08-04 Jerome Lambourg + + * g-comlin.adb (Group_Switches): Preserve the switch order when + grouping and allow switch grouping of switches with more than one + character extension (e.g. gnatw.x). + (Args_From_Expanded): Remove this now obsolete method. + +2008-08-04 Ed Schonberg + + * exp_ch4.adb (Get_Allocator_Final_List): Freeze anonymous type for + chain at once, to ensure that type is properly decorated for back-end, + when allocator appears within a loop. + +2008-08-04 Kevin Pouget + + * snames.h, snames.adb, snames.ads: + Add Attr_To_Any, Attr_From_Any and Attr_TypeCode defines. + + * exp_dist.ads, exp_dist.adb: Add Build_From_Any_Call, + Build_To_Any_Call and Build_TypeCode_Call procedures. + + * exp_attr.adb, sem_attr.adb: Add corresponding cases. + + * rtsfind.ads: Add corresponding names. + + * tbuild.adb: Update prefix restrictions to allow '_' character. + +2008-08-04 Doug Rupp + + * gigi.h (fill_vms_descriptor): Add third parameter gnat_actual + * trans.c (call_to_gnu): Call fill_vms_descriptor with new parameter. + * utils2.c (fill_vms_descriptor): Add third parameter for error sloc and + use it. Calculate pointer range overflow using 64bit types. + +2008-08-04 Ed Schonberg + + * sem_ch3.adb (Access_Definition): A formal object declaration is a + legal context for an anonymous access to subprogram. + + * sem_ch4.adb (Analyze_One_Call): If the call can be interpreted as an + indirect call, report success to the caller to include possible + interpretation. + + * sem_ch6.adb (Check_Return_Type_Indication): Apply proper conformance + check when the type + of the extended return is an anonymous access_to_subprogram type. + + * sem_res.adb: + (Resolve_Call): Insert a dereference if the type of the subprogram is an + access_to_subprogram and the context requires its return type, and a + dereference has not been introduced previously. + +2008-08-04 Arnaud Charlet + + * usage.adb (Usage): Minor rewording of -gnatwz switch, to improve + gnatcheck support in GPS. + +2008-08-04 Vincent Celier + + * mlib.adb (Create_Sym_Links): Create relative symbolic links when + requested + +2008-08-04 Vincent Celier + + * gprep.adb (Process_One_File): Call Prep.Preprocess with a Boolean + variable, but don't check the resulting value as it has no impact on + the processing. + + * opt.ads: + (Generate_Processed_File): New Boolean flag, set to True in the compiler + when switch -gnateG is used. + + * prep.adb: + (Preprocess): new Boolean out parameter Source_Modified. Set it to True + when the source is modified by the preprocessor and there is no + preprocessing errors. + + * prep.ads (Preprocess): new Boolean out parameter Source_Modified + + * sinput-l.adb: + (Load_File): Output the result of preprocessing if the source text was + modified. + + * switch-c.adb (Scan_Front_End_Switches): Recognize switch -gnateG + + * switch-m.adb (Normalize_Compiler_Switches): Normalize switch -gnateG + + * ug_words: Add VMS equivalent for -gnateG + + * vms_data.ads: + Add VMS option /GENERATE_PROCESSED_SOURCE, equivalent to switch -gnateG + +2008-08-04 Doug Rupp + + * gcc-interface/utils2.c: + (fill_vms_descriptor): Raise CE if attempt made to pass 64bit pointer + in 32bit descriptor. + +2008-08-04 Robert Dewar + + * par-ch10.adb: Minor reformatting + + * i-cobol.adb: Minor reformatting. + +2008-08-04 Ed Schonberg + + * sem_ch3.adb (Access_Definition): Create an itype reference for an + anonymous access return type of a regular function that is not a + compilation unit. + +2008-08-04 Vincent Celier + + * prj-attr.adb: New Builder attribute Global_Compilation_Switches + + * snames.adb: New standard name Global_Compilation_Switches + + * snames.ads: New standard name Global_Compilation_Switches + + * make.adb: Correct spelling error in comment + +2008-08-04 Arnaud Charlet + + * sem_prag.adb (Check_Form_Of_Interface_Name): Fix handling for CLI + target. + +2008-08-04 Thomas Quinot + + * sem_ch10.adb: Minor comment fix. + +2008-08-04 Robert Dewar + + * restrict.adb: Improved messages for restriction warnings + + * restrict.ads: Improved messages for restriction messages + + * s-rident.ads (Profile_Name): Add No_Profile + +2008-08-04 Robert Dewar + + * system-darwin-x86.ads: Correct bad definition of Max_Nonbinary_Modulus + +2008-08-04 Robert Dewar + + * freeze.adb (Freeze_Entity): Check for size clause for boolean warning + +2008-08-04 Vincent Celier + + * prj-proc.adb: + (Copy_Package_Declarations): When inheriting package Naming from a + project being extended, do not inherit source exception names. + +2008-08-04 Ed Schonberg + + * sem_prag.adb (Check_Precondition_Postcondition): When scanning the + list of declaration to find previous subprogram, do not go to the + original node of a generic unit. + +2008-08-02 Eric Botcazou + + * gcc-interface/utils2.c (build_binary_op) : + New case. Convert BOOLEAN_TYPE operation to the default integer type. + +2008-08-01 Eric Botcazou + + * gcc-interface/ada-tree.h (DECL_PARM_ALT): Now DECL_PARM_ALT_TYPE. + * gcc-interface/decl.c (gnat_to_gnu_param): Fix formatting, simplify + and adjust for above renaming. + * gcc-interface/utils.c (convert_vms_descriptor): Likewise. Add new + gnu_expr_alt_type parameter. Convert the expression to it instead + of changing its type in place. + (build_function_stub): Adjust call to above function. + +2008-08-01 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Remove dead + code. Do not get full definition of deferred constants with address + clause for a use. Do not ignore deferred constant definitions with + address clause. Ignore constant definitions already marked with the + error node. + : Remove obsolete comment. For a deferred constant with + address clause, get the initializer from the full view. + * gcc-interface/trans.c (gnat_to_gnu) : + Rework and remove obsolete comment. + : For a deferred constant with address clause, + mark the full view with the error node. + * gcc-interface/utils.c (convert_to_fat_pointer): Rework and fix + formatting nits. + +2008-08-01 Hristian Kirtchev + + * rtsfind.ads: Add block IO versions of stream routines for Strings. + + * bindgen.adb, gnat_rm.texi, gnat_ugn.texi, opt.ads, + sem_prag.adb, snames.adb, snames.ads, snames.h, + par-prag.adb: Undo previous stream related changes. + + * s-rident.ads: Add new restriction No_Stream_Optimizations. + + * s-ststop.ads, s-ststop.adb: Comment reformatting. + Define enumeration type to designate different IO mechanisms. + Enchance generic package Stream_Ops_Internal to include an + implementation of Input and Output. + + * exp_attr.adb (Find_Stream_Subprogram): If restriction + No_Stream_Optimization is active, choose the default byte IO + implementations of stream attributes for Strings. + Otherwise use the corresponding block IO version. + +2008-08-01 Olivier Hainque + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Do not + turn Ada Pure into GCC const, now implicitely implying nothrow as well. + +2008-08-01 Robert Dewar + + * par-ch3.adb (P_Defining_Identifier): Avoid repeated attempt to + convert plain identifier into defining identifier. + +2008-08-01 Robert Dewar + + * sem_prag.adb (Check_Form_Of_Interface_Name): Refine and improve + warnings + + * lib-xref.adb: Add error defense. + +2008-08-01 Bob Duff + + * ioexcept.ads, sequenio.ads, directio.ads: Correct comment. + +2008-08-01 Gary Dismukes + + * exp_ch6.adb (Expand_Call): Adjustment to previous fix for passing + correct accessibility levels. In the "when others" case, retrieve the + access level of the Etype of Prev rather than Prev_Orig, because the + original exression has not always been analyzed. + +2008-08-01 Robert Dewar + + * prj-nmsc.adb: Minor reformatting + + * sem_ch4.adb: Minor reformatting + Minor code reorganization + + * prj.ads: Minor reformatting + + * s-os_lib.adb: Minor reformatting + + * par-prag.adb (Prag, case Wide_Character_Encoding): Deal with upper + half encodings + + * scans.ads: Minor reformatting. + + * sem_prag.adb (Analyze_Pragma): Put entries in alpha order + (Analyze_Pragma): Make sure all GNAT pragmas call GNAT_Pragma + + * sem_res.adb: + (Resolve_Call): Check violation of No_Specific_Termination_Handlers + + * sem_ch12.adb: Minor comment reformatting + + * par-ch3.adb (P_Type_Declaration): Properly handle missing type + keyword + +2008-08-01 Robert Dewar + + * sem_ch6.adb (Process_PPCs): Don't copy spec PPC to body if not + generating code + +2008-08-01 Ed Schonberg + + * checks.adb (Apply_Float_Conversion_Check): If the expression to be + converted is a real literal and the target type has static bounds, + perform the conversion exactly to prevent floating-point anomalies on + some targets. + +2008-08-01 Vincent Celier + + * prj-attr.adb: New attribute Compiler'Name_Syntax () + + * prj-nmsc.adb (Process_Compiler): Recognize attribute Name_Syntax + + * prj.adb (Object_Exist_For): Use Object_Generated, not + Objects_Generated that is removed and was never modified anyway. + + * prj.ads: + (Path_Syntax_Kind): New enumeration type + (Language_Config): New component Path_Syntax, defaulted to Host. + Components PIC_Option and Objects_Generated removed, as they are not + used. + + * snames.adb: New standard name Path_Syntax + + * snames.ads: New standard name Path_Syntax + +2008-08-01 Vincent Celier + + * mlib-utl.adb: + (Adalib_Path): New variable to store the path of the adalib directory + when procedure Specify_Adalib_Dir is called. + (Lib_Directory): If Adalib_Path is not null, return its value + (Specify_Adalib_Dir): New procedure + + * mlib-utl.ads (Specify_Adalib_Dir): New procedure + +2008-08-01 Ed Schonberg + + * sem_prag.adb: + (Check_Precondition_Postcondition): If not generating code, analyze the + expression in a postcondition that appears in a subprogram body, so that + it is properly decorated for ASIS use. + +2008-08-01 Gary Dismukes + + * exp_ch6.adb (Expand_Call): Remove ugly special-case code that resets + Orig_Prev to Prev in the case where the actual is N_Function_Call or + N_Identifier. This was interfering with other cases that are rewritten + as N_Identifier, such as allocators, resulting in passing of the wrong + accessibility level, and based on testing this code is apparently no + longer needed at all. + +2008-08-01 Ed Schonberg + + * sem_ch4.adb (Analyze_One_Call): Handle complex overloading of a + procedure call whose prefix + is a parameterless function call that returns an access_to_procedure. + +2008-08-01 Jose Ruiz + + * adaint.c (__gnat_tmp_name): Refine the generation of temporary names + for RTX. Adding a suffix that is incremented at each iteration. + +2008-08-01 Robert Dewar + + * sem_ch6.adb (Analyze_Subprogram_Body): Remove special casing of + Raise_Exception + +2008-08-01 Jerome Lambourg + + * s-os_lib.adb (Normalize_Pathname): Take care of double-quotes in + paths, which are authorized by Windows but can lead to errors when used + elsewhere. + +2008-08-01 Ed Schonberg + + * sem_ch12.ads (Need_Subprogram_Instance_Body): new function, to create + a pending instantiation for the body of a subprogram that is to be + inlined. + + * sem_ch12.adb: + (Analyze_Subprogram_Instantiation): use Need_Subprogram_Instance_Body. + + * sem_prag.adb (Make_Inline): If the pragma applies to an instance, + create a pending instance for its body, so that calls to the subprogram + can be inlined by the back-end. + +2008-08-01 Jose Ruiz + + * gnat_ugn.texi: Document the RTX run times (rts-rtx-rtss and + rts-rtx-w32). + +2008-08-01 Robert Dewar + + * scng.adb (Error_Illegal_Wide_Character): Bump scan pointer + +2008-08-01 Doug Rupp + + * gnat_rm.texi: Document new mechanism Short_Descriptor. + + * types.ads (Mechanism_Type): Modify range for new Short_Descriptor + mechanism values. + + * sem_prag.adb (Set_Mechanism_Value): Enhance for Short_Descriptor + mechanism and Short_Descriptor mechanism values. + + * snames.adb (preset_names): Add short_descriptor entry. + + * snames.ads: Add Name_Short_Descriptor. + + * types.h: Add new By_Short_Descriptor mechanism values. + + * sem_mech.adb (Set_Mechanism_Value): Enhance for Short_Descriptor + mechanism and Short_Descriptor mechanism values. + + * sem_mech.ads (Mechanism_Type): Add new By_Short_Descriptor mechanism + values. + (Descriptor_Codes): Modify range for new mechanism values. + + * treepr.adb (Print_Entity_Enfo): Handle new By_Short_Descriptor + mechanism values. + + * gcc-interface/decl.c (gnat_to_gnu_entity): Handle By_Short_Descriptor. + (gnat_to_gnu_param): Handle By_Short_Descriptor. + + * gcc-interface/gigi.h (build_vms_descriptor64): Remove prototype. + (build_vms_descriptor32): New prototype. + (fill_vms_descriptor): Remove unneeded gnat_actual parameter. + + * gcc-interface/trans.c (call_to_gnu): Removed unneeded gnat_actual + argument in call fill_vms_descriptor. + + * gcc-interface/utils.c (build_vms_descriptor32): Renamed from + build_vms_descriptor and enhanced to hande Short_Descriptor mechanism. + (build_vms_descriptor): Renamed from build_vms_descriptor64. + (convert_vms_descriptor32): New function. + (convert_vms_descriptor64): New function. + (convert_vms_descriptor): Rewrite to handle both 32bit and 64bit + descriptors. + + * gcc-interface/utils2.c (fill_vms_descriptor): Revert previous changes, + no longer needed. + +2008-08-01 Jose Ruiz + + * adaint.c (__gnat_tmp_name): RTSS applications do not support tempnam + nor tmpnam, so we always use c:\WINDOWS\Temp\gnat-XXXXXX as temporary + name. + +2008-08-01 Jose Ruiz + + * cstreams.c (__gnat_full_name): RTSS applications cannot ask for the + current directory so only fully qualified names are allowed. + +2008-08-01 Robert Dewar + + * gnat_ugn.texi: + Minor editing, remove uncomfortable use of semicolon + + * s-ststop.adb: Add some ??? comments + + * sem_ch10.adb: Minor reformatting + + * snames.ads: + Minor comment fixes, some pragmas were not properly + categorized in the comments, documentation change only + + * xref_lib.adb: Minor reformatting + + * sinput.adb: Minor reformatting + + * gnatchop.adb: Minor reformatting + + * sem_util.ads: Minor reformatting. + + * opt.ads: Minor documentation fix + + * scng.adb: Minor reformatting + + * prj-part.adb: Update comments + +2008-08-01 Ed Schonberg + + * exp_disp.adb (Expand_Interface_Conversion): If the target type is a + tagged synchronized type, use corresponding record type. + +2008-08-01 Doug Rupp + + * mlib-tgt-specific-vms-alpha.adb (Build_Dynamic_Library): Output a + dummy transfer address for debugging. + + * mlib-tgt-specific-vms-ia64.adb (Build_Dynamic_Library): Likewise. + + * vms_data.ads: vms_data.ads: New qualfier /MACHINE_CODE_LISTING + +2008-07-31 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity): Fix formatting. + * gcc-interface/utils.c (create_field_decl): Avoid superfluous work. + +2008-07-31 Pascal Obry + + * prj-nmsc.adb: Keep Object and Exec directory casing. + +2008-07-31 Jose Ruiz + + * system-rtx-rtss.ads + Change the default stack size. It is important to set the commit part. + + * s-taprop-rtx.adb + (Initialize): Get the clock resolution. + (RT_Resolution): Return the clock resolution that is indicated by the + system. + + * s-parame-vxworks.adb + Document that this body is used for RTX in RTSS (kernel) mode. + + * gcc-interface/Makefile.in + (LIBGNAT_TARGET_PAIRS for the rtx_rtss run time): Use the + s-parame-vxworks.adb body in order to have reasonable stack sizes in + RTX RTSS kernel mode. Virtual memory is not used in that case, so we + cannot ask for too big values. + +2008-07-31 Robert Dewar + + * exp_aggr.adb: Minor reformatting + + * makeutl.adb: Minor reformatting + + * prj-env.adb: Minor reformatting + +2008-07-31 Hristian Kirtchev + + * exp_disp.adb (Prim_Op_Kind): Retrieve the full view when a private + tagged type is completed by a concurrent type. + +2008-07-31 Gary Dismukes + + * sem_aggr.adb: + (Resolve_Record_Aggregate): Bypass error that a type without + components must have a "null record" aggregate when compiling for Ada + 2005, since it's legal to give an aggregate of form (others => <>) + for such a type. + +2008-07-31 Javier Miranda + + * sem_ch4.adb (Valid_First_Argument_Of): Complete its functionality to + handle synchronized types. Required to handle well the object.operation + notation applied to synchronized types. + +2008-07-31 Quentin Ochem + + * s-stausa.adb (Fill_Stack): Stack_Used_When_Filling is now stored + anymore - just used internally. + Added handling of very small tasks - when the theoretical size is + already full at the point of the call. + (Report_Result): Fixed result computation, Stack_Used_When_Filling does + not need to be added to the result. + +2008-07-31 Hristian Kirtchev + + * sem_ch6.adb (Disambiguate_Spec): Continue the disambiguation if the + corresponding spec is a primitive wrapper. Update comment. + +2008-07-31 Hristian Kirtchev + + * bindgen.adb Comment reformatting. Update the list of run-time globals. + (Gen_Adainit_Ada): Add the declaration, import and value set for + configuration flag Canonical_Streams. + (Gen_Adainit_C): Add the declaration and initial value of external + symbol __gl_canonical_streams. + + * init.c: Update the list of global values computed by the binder. + + * opt.ads: Add flag Canonical_Streams. + + * par-prag.adb (Prag): Include Pragma_Canonical_Streams to the list of + semantically handled pragmas. + + * sem_prag.adb: Add an entry into enumeration type Sig_Flags. + (Analyze_Pragma): Add case for pragma Canonical_Streams. + + * snames.adb: Add character value for name Canonical_Streams. + + * snames.ads: + Add Name_Canonical_Streams to the list of configuration pragmas. + Add Pragma_Canonical_Streams to enumeration type Pragma_Id. + + * snames.h: Add a definition for Pragma_Canonical_Streams. + + * s-ststop.adb: + Add a flag and import to seize the value of external symbol + __gl_canonical_streams. Update comment and initial value of constant + Use_Block_IO. + + * gnat_rm.texi: Add section of pragma Canonical_Streams. + + * gnat_ugn.texi: + Add pragma Canonical_Streams to the list of configuration pragmas. + +2008-07-31 Ed Schonberg + + * sem_ch10.adb (Build_Unit_Name): If the unit name in a with_clause + has the form A.B.C and B is a unit renaming, analyze its compilation + unit and add a with_clause on A.b to the context. + +2008-07-31 Vincent Celier + + * makeutl.adb (Executable_Prefix_Path): If Locate_Exec_On_Path fails, + return the empty string, instead of raising Constraint_Error. + +2008-07-31 Gary Dismukes + + * checks.ads (Apply_Accessibility_Check): Add parameter Insert_Node. + + * checks.adb (Apply_Accessibility_Check): Insert the check on + Insert_Node. + + * exp_attr.adb: + (Expand_N_Attribute_Refernce, Attribute_Access): Pass attribute node + to new parameter Insert_Node on call to Apply_Accessibility_Check. + Necessary to distinguish the insertion node because the dereferenced + formal may come from a rename, but the check must be inserted in + front of the attribute. + + * exp_ch4.adb: + (Expand_N_Allocator): Pass actual for new Insert_Node parameter on + call to Apply_Accessibility_Check. + (Expand_N_Type_Conversion): Pass actual for new Insert_Node parameter + on call to Apply_Accessibility_Check. + Minor reformatting + +2008-07-31 Javier Miranda + + * sem_type.adb (Has_Compatible_Type): Complete support for synchronized + types when the candidate type is a synchronized type. + + * sem_res.adb (Resolve_Actuals): Reorganize code handling synchronized + types, and complete management of synchronized types adding missing + code to handle formal that is a synchronized type. + + * sem_ch4.adb (Try_Primitive_Operation): Avoid testing attributes that + are not available and cause the compiler to blowup. Found compiling + test with switch -gnatc + + * sem_ch6.adb (Check_Synchronized_Overriding): Remove local subprogram + Has_Correct_Formal_Mode plus code cleanup. + +2008-07-31 Bob Duff + + * sinput.adb (Skip_Line_Terminators): Fix handling of LF/CR -- it was + recognized as two end-of-lines, but it should be just one. + +2008-07-31 Thomas Quinot + + * exp_ch9.adb: Minor reformatting + + * tbuild.ads: Fix several occurrences of incorrectly referring to + Name_Find as Find_Name. + +2008-07-31 Ed Schonberg + + * exp_aggr.adb (Aggr_Size_OK): If the aggregate has a single component + and the context is an object declaration with non-static bounds, treat + the aggregate as non-static. + +2008-07-31 Vincent Celier + + * prj-part.adb, prj-part.ads, prj.adb, prj.ads, prj-env.adb: + Move back spec of Parse_Single_Project to body, as it is not called + outside of package Prj.Part. + (Project_Data): Remove components Linker_Name, Linker_Path and + Minimum_Linker_Options as they are no longer set. + Remove function There_Are_Ada_Sources from package Prj and move code + in the only place it was used, in Prj.Env.Set_Ada_Paths. + +2008-07-31 Arnaud Charlet + + * mlib-utl.ads: Fix typo. + +2008-07-31 Robert Dewar + + * sem_ch12.adb: Minor reformatting + +2008-07-31 Sergey Rybin + + * gnat_ugn.texi: Change the description of the + Overly_Nested_Control_Structures: now the rule always requires a + positive parameter for '+R' option + +2008-07-31 Thomas Quinot + + * g-pehage.adb: Minor reformatting + +2008-07-31 Pascal Obry + + * s-finimp.ads: Minor reformatting. + +2008-07-31 Vincent Celier + + * s-regexp.ads: Minor comment fix + +2008-07-31 Arnaud Charlet + + * s-direio.adb (Reset): Replace pragma Unmodified by Warnings (Off), + so that we can compile this file successfully with -gnatc. + +2008-07-31 Hristian Kirtchev + + * exp_attr.adb (Find_Stream_Subprogram): Check the base type instead + of the type when looking for stream subprograms for type String, + Wide_String and Wide_Wide_String. + + * s-ststop.adb: Change the initialization expression of constant + Use_Block_IO. + +2008-07-31 Geert Bosch + + * arit64.c: + New file implementing __gnat_mulv64 signed integer multiplication with + overflow checking + + * fe.h (Backend_Overflow_Checks_On_Target): Define for use by Gigi + + * gcc-interface/gigi.h: + (standard_types): Add ADT_mulv64_decl + (mulv64_decl): Define subprogram declaration for __gnat_mulv64 + + * gcc-interface/utils.c: + (init_gigi_decls): Add initialization of mulv64_decl + + * gcc-interface/trans.c: + (build_unary_op_trapv): New function + (build_binary_op_trapv): New function + (gnat_to_gnu): Use the above functions instead of + build_{unary,binary}_op + + * gcc-interface/Makefile.in + (LIBGNAT_SRCS): Add arit64.c + (LIBGNAT_OBJS): Add arit64.o + +2008-07-31 Vincent Celier + + * prj-nmsc.adb (Check_Library_Attributes): Check if Linker'Switches or + Linker'Default_Switches are declared. Warn if they are declared. + +2008-07-31 Ed Schonberg + + * exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration): Use + Insert_Actions to place the pointer declaration in the code, rather + than Insert_Before_And_Analyze, so that insertions of temporaries are + kept in the proper order when transient scopes are present. + + +2008-07-31 Robert Dewar + + * einfo.adb (Spec_PPC): Now defined for generic subprograms + + * einfo.ads (Spec_PPC): Now defined for generic subprograms + + * sem_prag.adb (Check_Precondition_Postcondition): Handle generic + subprogram case + +2008-07-31 Vincent Celier + + * s-os_lib.adb: Minor comment fix + +2008-07-31 Ed Schonberg + + * sem_ch6.adb (Analyze_Generic_Subprogram_Body): After analysis, + transfer pre/postconditions from generic copy to original tree, so that + they will appear in each instance. + (Process_PPCs): Do not transform postconditions into a procedure in a + generic context, to prevent double expansion of check pragmas. + + * sem_attr.adb: In an instance, the prefix of the 'result attribute + can be the renaming of the + current instance, so check validity of the name accordingly. + +2008-07-31 Robert Dewar + + * mlib-utl.ads: Minor reformatting + +2008-07-31 Ed Schonberg + + sem_attr.adb: 'Result can have an ambiguous prefix, and is resolved + from context. This attribute must be usable in Ada95 mode. + The attribute can appear in the body of a function marked + Inline_Always, but in this case the postocondition is not enforced. + + sem_prag.adb (Check_Precondition_Postcondition): within the expansion + of an inlined call pre- and postconditions are legal + +2008-07-31 Vincent Celier + + * prj.adb, prj.ads, clean.adb, prj-nmsc.adb: Remove declarations that + were for gprmake only + +2008-07-31 Robert Dewar + + * gnat_ugn.texi: Update -gnatN documentation. + + * gnat_rm.texi: Add note about pre/postcondition + pragmas not checked in conjunction with front-end inlining. + +2008-07-31 Robert Dewar + + * g-pehage.adb, g-pehage.ads: Minor reformatting + +2008-07-31 Arnaud Charlet + + * mlib-utl.ads, prj-makr.ads: Add comments. + +2008-07-30 Aaron W. LaFramboise + + * gcc-interface/Makefile.in (EXTRA_GNATRTL_NONTASKING_OBJS) + [WINDOWS]: Add s-winext.o. + +2008-07-30 Eric Botcazou + + PR ada/36554 + * back_end.adb (Call_Back_End): Pass Standard_Boolean to gigi. + * gcc-interface/gigi.h (gigi): Take new standard_boolean parameter. + * gcc-interface/decl.c (gnat_to_gnu_entity) : + Set precision to 1 for subtype of BOOLEAN_TYPE. + (set_rm_size): Set TYPE_RM_SIZE_NUM for BOOLEAN_TYPE. + (make_type_from_size): Deal with BOOLEAN_TYPE. + * gcc-interface/misc.c (gnat_print_type): Likewise. + * gcc-interface/trans.c (gigi): Take new standard_boolean parameter. + Set boolean_type_node as its translation in the table, as well + as boolean_false_node for False and boolean_true_node for True. + * gcc-interface/utils.c (gnat_init_decl_processing): Create custom + 8-bit boolean_type_node and set its TYPE_RM_SIZE_NUM. + (create_param_decl): Deal with BOOLEAN_TYPE. + (build_vms_descriptor): Likewise. + (build_vms_descriptor64): Likewise. + (convert): Deal with BOOLEAN_TYPE like with ENUMERAL_TYPE. + +2008-07-30 Robert Dewar + + * exp_ch9.adb: Minor reformatting + + * exp_util.ads (Find_Prim_Op): Document that Program_Error is raised + if no primitive operation is found. + + * exp_util.adb: (Find_Prim_Op): Add comments for previous change + + * sem_ch8.adb: Minor reformatting + +2008-07-30 Laurent Pautet + + * g-pehage.adb: + Remove a limitation on the length of the words handled by the minimal + perfect hash function generator. + + * g-pehage.ads: + Detail the use of subprograms Insert, Initialize, Compute and Finalize. + Fix some typos. + +2008-07-30 Robert Dewar + + * gnatlink.adb: Minor reformatting + +2008-07-30 Thomas Quinot + + * rtsfind.adb (Check_RPC): Check version consistency even when not + generating RCI stubs. Provide more detailed error message in case of + mismatch. + +2008-07-30 Ed Schonberg + + * sem_ch8.adb (Analyze_Subprogram_Renaming): When renaming an attribute + as a actual in an instance, check for a missing attribute to prevent + program_error on an illegal program. + + * exp_util.adb (Find_Prim_Op): Rather than Assert (False), raise program + error if primitive is not found, so that exception can be handled + elsewhere on illegal programs. + +2008-07-30 Robert Dewar + + * uintp.adb (UI_GCD): Fix potential overflow + +2008-07-30 Hristian Kirtchev + + * einfo.adb: Flag245 is now used. + (Is_Primitive_Wrapper, Set_Is_Primitive_Wrapper): Relax the assertion + check to include functions. + (Is_Private_Primitive, Set_Is_Private_Primitive): New subprograms. + (Wrapped_Entity, Set_Wrapped_Entity): Relax the assertion check to + include functions. + (Write_Entity_Flags): Move flag Is_Primitive, add Is_Private_Primitive + to the list of displayed flags. + + * einfo.ads: Update comment on the usage of Is_Primitive_Wrapper and + Wrapped_Entity. These two flags are now present in functions. + New flag Is_Private_Primitive. + (Is_Private_Primitive, Set_Is_Private_Primitive): New subprograms. + + * exp_ch9.adb: + (Build_Wrapper_Bodies): New subprogram. + (Build_Wrapper_Body): The spec and body have been moved to in + Build_Wrapper_ Bodies. Code cleanup. + (Build_Wrapper_Spec): Moved to the spec of Exp_Ch9. Code cleanup. + Wrappers are now generated for primitives declared between the private + and full view of a concurrent type that implements an interface. + (Build_Wrapper_Specs): New subprogram. + (Expand_N_Protected_Body): Code reformatting. Replace the wrapper body + creation mechanism with a call to Build_Wrapper_Bodies. + (Expand_N_Protected_Type_Declaration): Code reformatting. Replace the + wrapper spec creation mechanism with a call to Build_Wrapper_Specs. + (Expand_N_Task_Body): Replace the wrapper body creation + mechanism with a call to Build_Wrapper_Bodies. + (Expand_N_Task_Type_Declaration): Replace the wrapper spec + creation mechanism with a call to Build_Wrapper_Specs. + (Is_Private_Primitive_Subprogram): New subprogram. + (Overriding_Possible): Code cleanup. + (Replicate_Entry_Formals): Renamed to Replicate_Formals, code cleanup. + + * exp_ch9.ads (Build_Wrapper_Spec): Moved from the body of Exp_Ch9. + + * sem_ch3.adb: Add with and use clause for Exp_Ch9. + (Process_Full_View): Build wrapper specs for all primitives + that belong to a private view completed by a concurrent type + implementing an interface. + + * sem_ch6.adb (Analyze_Subprogram_Body): When the current subprogram + is a primitive of a + concurrent type with a private view that implements an interface, try to + find the proper spec. + (Analyze_Subprogram_Declaration): Mark a subprogram as a private + primitive if the type of its first parameter is a non-generic tagged + private type. + (Analyze_Subprogram_Specification): Code reformatting. + (Disambiguate_Spec): New routine. + (Find_Corresponding_Spec): Add a flag to controll the output of errors. + (Is_Private_Concurrent_Primitive): New routine. + + * sem_ch6.ads: + (Find_Corresponding_Spec): Add a formal to control the output of errors. + +2008-07-30 Doug Rupp + + * gigi.h (build_vms_descriptor64): New function prototype. + (fill_vms_descriptor): Modified function prototype. + + * utils.c (build_vms_descriptor64): New function. + + * utils2.c (fill_vms_descriptor): Fix handling on 32bit systems. + + * trans.c (call_to_gnu): Call fill_vms_descriptor with new third + argument. + + * decl.c (gnat_to_gnu_tree): For By_Descriptor mech, build both a + 64bit and 32bit descriptor and save the 64bit version as an alternate + TREE_TYPE in the parameter. + (make_type_from_size) : Use the appropriate mode for the + thin pointer. + + * ada-tree.h (DECL_PARM_ALT, SET_DECL_PARM_ALT): New macros. + +2008-07-30 Robert Dewar + + * make.adb: Minor reformatting + + * mlib-utl.adb: Minor reformatting + + * osint.ads: Minor reformatting + +2008-07-30 Jose Ruiz + + * adaint.c + (__gnat_file_exists): Do not use __gnat_stat for RTX. + (__main for RTX in RTSS mode): Create this dummy procedure symbol to + avoid the use of this symbol from libgcc.a in RTX kernel mode. + + * cio.c + (put_int, put_int_stderr, put_char, put_char_stderr): For RTX we call + the function RtPrintf for console output. + + * argv.c Do not use the environ variable for RTX. + + * gnatlink.adb (gnatlink): The part that handles the --RTS option has + been moved before the call to Osint.Add_Default_Search_Dirs in order + to take into account the flags in system.ads (RTX_RTSS_Kernel_Module) + from the appropriate run time. + + * targparm.ads + (RTX_RTSS_Kernel_Module_On_Target): Add this flag that is set to True if + target is a RTSS module for RTX. + + * targparm.adb (Targparm_Tags, RTX_Str, Targparm_Str): Add tag RTX for + RTX_RTSS_Kernel_Module + (Get_Target_Parameters): Add processing of RTX_RTSS_Kernel_Module flag. + + * gcc-interface/Makefile.in (LIBGNAT_TARGET_PAIRS for RTX): Use gcc + exception handling mechanism for Windows and RTX in Win32 mode, but + not for RTX in kernel mode (RTSS). + (LIBGNAT_SRCS): Remove ada.h + +2008-07-30 Paolo Bonzini + + * gcc-interface/Make-lang.in (ALL_ADAFLAGS): Remove X_ADAFLAGS and + T_ADAFLAGS, replace ALL_ADA_CFLAGS with ADA_CFLAGS. + (ALL_ADA_CFLAGS): Remove, replace throughout with ADA_CFLAGS. + * gcc-interface/Makefile.in (XCFLAGS, X_CFLAGS, X_CPPFLAGS, T_CPPFLAGS, + X_ADA_CFLAGS, T_ADA_CFLAGS, X_ADAFLAGS, T_ADAFLAGS, ADA_CFLAGS, + ALL_ADA_CFLAGS): Remove. + (ALL_ADAFLAGS, MOST_ADAFLAGS): Remove X_ADAFLAGS and T_ADAFLAGS, + replace ALL_ADA_CFLAGS with ADA_CFLAGS. + (GCC_CFLAGS): Remove X_CFLAGS. + (LOOSE_CFLAGS): Remove X_CFLAGS and XCFLAGS. + (ALL_CPPFLAGS): Remove X_CPPFLAGS and T_CPPFLAGS. + (ADA_CFLAGS): Substitute. + +2008-07-30 Laurent Guerby + + PR ada/5911 + * gcc-interface/Makefile.in (MULTISUBDIR, RTSDIR): New variables. + Pass MULTISUBDIR to recursive make. Use $(RTSDIR) instead of rts. + Replace stamp-gnatlib* by stamp-gnatlib*-rts. + * gcc-interface/Make-lang.in: Replace stamp-gnatlib2 + by stamp-gnatlib2-rts. + +2008-07-30 Ralf Wildenhues + + PR documentation/15479 + * gnat-style.texi: Remove AdaCore copyright statement and GPL + statement for GNAT. Add @copying stanza, use it. Update to + GFDL 1.2. Do not list GFDL as Invariant Section, do not list + title as Front-Cover Text. + * gnat_rm.texi: Likewise. + * gnat_ugn.texi: Likewise. + +2008-07-29 Jan Hubicka + + * trans.c (process_inlined_subprograms): Remove tree_really_inline + check. + +2008-07-29 Arnaud Charlet + + * gcc-interface: New directory. + + * ada-tree.def, cuintp.c, gigi.h, Makefile.in, targtyps.c, ada.h, + utils.c, ada-tree.h, decl.c, lang.opt, Make-lang.in, trans.c, + config-lang.in, deftarg.c, lang-specs.h, misc.c, utils2.c: Moved + to gcc-interface subdirectory. + +2008-07-29 Aaron W. LaFramboise + + * Makefile.in (EXTRA_GNATRTL_NONTASKING_OBJS): Remove extra s-win32.o. + +2008-07-28 Jan Hubicka + + * misc.c (gnat_post_options): Do not set flag_no_inline. + +2008-07-28 Richard Guenther + + Merge from gimple-tuples-branch. + + 2008-07-22 Olivier Hainque + + * gigi.h (end_subprog_body): New ELAB_P argument, saying if + this is called for an elab proc to be discarded if empty. + * utils.c (end_subprog_body): Honor ELAB_P. + (build_function_stub): Adjust call to end_subprog_body. + * trans.c (Subprogram_Body_to_gnu): Likewise. + (gigi): Reorganize processing of elab procs to prevent + gimplifying twice, using the new end_subprog_body argument. + + 2008-07-19 Richard Guenther + + * Make-lang.in (trans.o): Add tree-iterator.h dependency. + (utils.o): Likewise. + * trans.c: Include tree-iterator.h. + (gnat_gimplify_expr): Adjust prototype. Fix typo. + (gnat_gimplify_stmt): Use SET_EXPR_LOCATION. + (set_expr_location_from_node): Likewise. + (gigi): Tuplify. + * ada-tree.h (union lang_tree_node): Use TREE_CHAIN instead + of GENERIC_NEXT. + * utils.c: Include tree-iterator.h. + * gigi.h (gnat_gimplify_expr): Adjust prototype. + + 2008-07-18 Aldy Hernandez + + * trans.c: Include gimple.h instead of tree-gimple.h. + * utils.c: Same. + + 2008-07-14 Aldy Hernandez + + * trans.c (gnat_gimplify_expr): Use gimplify_assign. + +2008-07-25 Jan Hubicka + + * utils.c (end_subprog_body): Remove inline trees check. + * misc.c (gnat_post_options): Do not set flag_inline_trees. + +2008-07-25 Rainer Orth + + * raise-gcc.c: Move tsystem.h before tm.h. + +2008-07-20 Arnaud Charlet + + * gnathtml.pl: New file. + +2008-07-19 Olivier Hainque + + * targtyps.c (get_target_default_allocator_alignment): Use + MALLOC_ABI_ALIGNMENT. + +2008-07-17 Olivier Hainque + + * adaint.c (__MINGW32__ section): Include ctype.h and define + a fallback ISALPHA if IN_RTS. + (__gnat_is_absolute_path): Use ISALPHA instead of isalpha. + +2008-07-17 Olivier Hainque + + * utils.c (create_var_decl_1): Relax expectations on the PUBLIC_FLAG + argument, to apply to references in addition to definitions. Prevent + setting TREE_STATIC on externals. + (gnat_pushdecl): Always clear DECL_CONTEXT on public externals. + +2008-07-14 Ralf Wildenhues + + PR documentation/15479 + * gnat_ugn.texi (@ovar): New macro, from autoconf.texi. + Replace backets around optional parameters with @ovar + where possible, use @r{[}, @r{]} otherwise. + Replace some @r, @i, and @emph with @var where appropriate. + +2008-07-02 Eric Botcazou + + * decl.c (make_type_from_size) : Fix typo and tidy up. + +2008-06-27 Kaveh R. Ghazi + + * ada-tree.h (SET_TYPE_LANG_SPECIFIC, SET_DECL_LANG_SPECIFIC): Fix + -Wc++-compat warnings. + * adaint.c (__gnat_locate_regular_file, __gnat_locate_exec, + __gnat_locate_exec_on_path): Likewise. + * decl.c (annotate_value): Likewise. + * misc.c (gnat_handle_option): Likewise. + * trans.c (gnat_to_gnu, extract_encoding, decode_name, + post_error_ne_tree): Likewise. + +2008-06-27 Eric Botcazou + + * utils.c (convert) : When converting it to a packable + version of its type, attempt to first convert its elements. + +2008-06-26 Chris Proctor + + * Makefile.in: Fix *86 kfreebsd target specific pairs. + +2008-06-25 Samuel Tardieu + + * Makefile.in: Use mlib-tgt-specific-linux.adb for sh4 as well. + +2008-06-24 Eric Botcazou + + * utils2.c (known_alignment): Derive the alignment from pointed-to + types only if it is otherwise unknown. + : Tidy. + : Likewise. + : If the alignment of the offset is unknown, use + that of the base. + +2008-06-20 John David Anglin + + PR ada/36573 + * s-osinte-hpux-dce.ads (SA_ONSTACK): Define. + +2008-06-15 Ralf Wildenhues + + * gnat_rm.texi (Implementation Defined Characteristics) + (Standard Library Routines): Use @smallexample for indented + text. Drop Indentation outside examples. + * gnat_ugn.texi: Likewise. + +2008-06-13 Olivier Hainque + + * decl.c (FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN): Define to 0 + if undefined. + (gnat_to_gnu_entity) : Request stack + realignment with force_align_arg_pointer attribute on foreign + convention subprograms if FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN. + +2008-06-13 Olivier Hainque + + * utils.c (rest_of_record_type_compilation): When computing + encodings for the components of a variable size type, early + strip conversions on the current position expression to make + sure it's shape is visible. Use remove_conversions for this + purpose. + +2008-06-12 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : In the case of a + constrained subtype of a discriminated type, discard the fields that + are beyond its limits according to its size. + +2008-06-10 Olivier Hainque + + * utils.c (create_subprog_decl): If this is for the 'main' entry + point according to the asm name, redirect main_identifier_node. + +2008-06-09 Eric Botcazou + + * decl.c (components_to_record): Adjust the packedness for the + qualified union as well. + +2008-06-09 Arnaud Charlet + + * Make-lang.in: Use -gnatwns instead of -gnatws to make sytyle + checks non fatal. + +2008-06-07 Samuel Tardieu + + * sem_res.adb (Large_Storage_Type): A type is large if it + requires as many bits as Positive to store its values and its + bounds are known at compile time. + * sem_ch13.adb (Minimum_Size): Note that this function returns + 0 if the size is not known at compile time. + +2008-06-06 Nicolas Setton + Olivier Hainque + + * ada-tree.h (DECL_PARALLEL_TYPE): New language specific + attribute, parallel descriptive type attached to another + type for debug info generation purposes. + * utils.c (add_parallel_type): New function, register + parallel type to be attached to a type. + (get_parallel_type): New function, fetch a registered + parallel type, if any. + (rest_of_record_type_compilation): Register the parallel + type we make for variable size records. + * gigi.h (add_parallel_type, get_parallel_type): Declare. + * decl.c (gnat_to_gnu_entity, maybe_pad_type): Register the + parallel debug types we make. + * trans.c (extract_encoding, decode_name): New functions. + (gigi): If the DWARF attribute extensions are available, setup + to use them. + * lang.opt: Register language specific processing request + for -gdwarf+. + * misc.c (gnat_dwarf_extensions): New global variable. How much + do we want of our DWARF extensions. 0 by default. + (gnat_handle_option) : Increment gnat_dwarf_extensions. + (gnat_post_options): Map gnat_dwarf_extensions to the + commonuse_gnu_debug_info_extensions for later processing. + +2008-06-04 Samuel Tardieu + + * einfo.ads, einfo.adb: Remove unused flag Function_Returns_With_DSP. + +2008-06-03 Ralf Wildenhues + + * Makefile.in (common_tools): Fix typos in $(exeext) extension. + * gnat_ugn.texi (Style Checking) + (Adding the Results of Compiler Checks to gnatcheck Output) + (Example of Binder Output File): Fix typos. + * ali.ads, einfo.ads, exp_ch4.adb, exp_ch6.adb, + exp_dbug.ads, exp_dist.adb, exp_smem.adb, g-socket.ads, + s-osinte-rtems.ads, s-shasto.ads, s-stausa.adb, + s-stausa.ads, sem_cat.adb, sem_ch12.adb, sem_ch3.adb, + sem_ch4.adb, sem_ch6.adb, sem_ch8.adb, sem_util.ads, + sinfo.ads, utils.c: Fix typos in comments. + * sem_ch6.adb, vms_data.ads: Fix typos in strings. + +2008-05-29 Thomas Quinot + + * sem_eval.adb: Minor reformatting + +2008-05-29 Ed Schonberg + + * sem_ch6.adb (Analyze_Subprogram_Specification): if the return type + is abstract, do not apply abstractness check on subprogram if this is + a renaming declaration. + +2008-05-29 Arnaud Charlet + + PR ada/864 + * osint.ads, osint.adb (Program_Name): New parameter "Prog" to + allow recognition of program suffix in addition to prefix. + + * gnatchop.adb (Locate_Executable): Add support for prefix. + + * make.adb, gnatcmd.adb, gnatlink.adb, prj-makr.adb, + mlib-utl.adb: Adjust calls to Program_Name. + +2008-05-29 Robert Dewar + + * sem_ch3.adb: Minor reformatting + * sem_prag.adb: Minor reformatting + * sem_res.adb: Minor reformatting + * sinput-p.ads: Minor reformatting + +2008-05-29 Javier Miranda + + * sem_util.adb: + (Abstract_Interface_List): Add missing support for full type-declaration + associated with synchronized types. + +2008-05-29 Robert Dewar + + * sem_eval.adb (Is_Same_Value): Take care of several more cases + +2008-05-28 Ed Schonberg + + * sem_ch5.adb (Analyze_Assignment): If the name is of a local anonymous + access type, wrap the expression in a conversion to force an + accessibility check. + + * sem_aggr.adb (Aggegate_Constraint_Checks): Apply conversion to force + accessibility checks even when expansion is disabled in order to + generate messages in the presence of previous errors or in + semantics-only mode. + +2008-05-28 Eric Botcazou + + * system-lynxos-ppc.ads (Always_Compatible_Rep): Set to False. + * system-lynxos-x86.ads (Always_Compatible_Rep): Set to False. + +2008-05-28 Vincent Celier + + PR ada/34446 + * gnat_ugn.texi: Document restriction introduced on 2007-04-20 in + preprocessing expressions + +2008-05-28 Vincent Celier + + * sinput-p.adb (Source_File_Is_Subunit): Allow special character used + for preprocessing + + * sinput-p.ads: Minor comment update and reformatting + +2008-05-28 Ed Schonberg + + * sem_res.adb (Valid_Conversion): An anonymous access_to_subprogram + type has a deeper level than any master only when it is the type of an + access parameter. + +2008-05-28 Javier Miranda + + * sem_ch3.adb (Derive_Progenitor_Subprograms): Add documentation. + +2008-05-28 Javier Miranda + + * sem_util.ads (Find_Overridden_Synchronized_Primitive): Removed. + * sem_util.adb (Find_Overridden_Synchronized_Primitive): Removed. + * sem_ch6.adb (Check_Synchronized_Overriding): Remove one formal. + Add code that was previously located in + Find_Overridden_Synchronized_Primitive because it is only used here. + +2008-05-28 Sergey Rybin + + * sem_prag.adb (Process_Extended_Import_Export_Subprogram_Pragma): Set + Entity field for formal_parameter_NAME in MECHANISM_ASSOCIATION. + +2008-05-28 Robert Dewar + + * restrict.ads: + Add missing restrictions, and properly label all GNAT defined ones + + * rtsfind.ads: + Add entry for Ada_Real_Time.Timing_Events.Timing_Event + Add entry for Ada.Task_Termination.Set_Specific_Handler + Add entry for Ada.Task_Termination.Specific_Handler + + * s-rident.ads: + Add missing restrictions and properly mark all gnat defined ones + + * sem_ch3.adb: + (Analyze_Object_Declaration): Check No_Local_Timing_Events restriction + + * sem_res.adb: + (Resolve_Call): Check violation of No_Specific_Termination_Handlers + + * gnat_rm.texi: Add missing restrictions, and properly label all + GNAT defined ones + +2008-05-28 Robert Dewar + + * restrict.adb: + (Check_Restriction): violation of restriction No_Finalization is + treated as a serious error to stop expansion + +2008-05-28 Robert Dewar + + * exp_util.adb: Minor reformatting + * exp_util.ads: Minor reformatting. + +2008-05-28 Arnaud Charlet + + * Make-lang.in: Remove gprmake. + + * gprmake.adb, makegpr.ads, makegpr.adb: Removed. + +2008-05-28 Ed Schonberg + + * sem_ch3.adb (Diagnose_Interface): Cleanup error messages involving + improper progenitor names, and avoid cascaded errors. + +2008-05-28 Robert Dewar + + * gnat_rm.texi: Add note on Old giving warning when applied to constant + + * sem_attr.adb (Analyze_Attribute, case Old): Give warning if prefix is + a constant + +2008-05-28 Robert Dewar + + * exp_fixd.adb (Build_Multiply): Correct one-off error in computing + size + +2008-05-28 Robert Dewar + + * exp_ch5.adb: + (Expand_Simple_Function_Return): Copy unaligned result into temporary + +2008-05-28 Javier Miranda + + * sem_ch3.adb (Derive_Progenitor_Primitives): Add missing support + for user-defined predefined primitives. + + * sem_util.adb (Matches_Prefixed_View_Profile): Ditto. + (Find_Overridden_Synchronized_Primitive): Ditto. + + * sem_ch6.adb (Check_Synchronized_Overriding): Ditto. + +2008-05-27 Arnaud Charlet + + * a-ststio.adb, s-direio.adb: + Further code clean up of previous change. + Update comments. + +2008-05-27 Vincent Celier + + * prj-nmsc.adb: Minor reformatting + +2008-05-27 Bob Duff + + * sem_ch3.adb (Build_Incomplete_Type_Declaration): In the case of an + untagged private type with a tagged full type, where the full type has + a self reference, create the corresponding class-wide type early, in + case the self reference is "access T'Class". + +2008-05-27 Ed Schonberg + + * exp_aggr.adb (Build_Array_Aggr_Code): If component type includes + tasks and context is an object declaration. create master entity before + expansion. + +2008-05-27 Robert Dewar + + * mlib-prj.adb: Minor reformatting + + * prj-part.adb: Minor reformatting + + * prj.ads: Minor reformatting + + * exp_ch3.adb: Minor reformatting. + + * sem_ch3.ads: Minor reformatting + + * sem_eval.adb: Minor reformatting + +2008-05-27 Vincent Celier + + * gnatcmd.adb: + -gnat stack spawns gnatstack, not -gnatstack + +2008-05-27 Ed Schonberg + + * exp_aggr.adb (Expand_Array_Aggregate): If the aggregate contains + tasks, create an activation chain now, before the expansion into + assignments and build-in-place calls that require the presence of an + activation chain. + (Backend_Processing_Possible): If the component type is inherently + limited, the aggregate must be expanded into individual built-in-place + assignments. + + * sem_ch6.adb (Build_Extra_Formals): Use underlying type of result to + determine whether an allocation extra parameter must be built, to + handle case of a private type whose full type is a discriminated type + with defaults. + +2008-05-27 Bob Duff + + * gnat_rm.texi: + Document the new behavior regarding trampolines. + +2008-05-27 Arnaud Charlet + + * a-direio.adb, a-sequio.adb: Replace address clause by + unrestricted_access, simpler and compatible with .NET. + +2008-05-27 Vincent Celier + + * prj-part.adb: + (Project_Path_Name_Of.Try_Path): Do not use Locate_Regular_File to find + a project file, so that symbolic links are not resolved. + +2008-05-27 Arnaud Charlet + + * a-ztexio.adb, a-textio.adb, a-witeio.adb, s-direio.adb: + Replace heavy address clause by 'Unrestricted_Access, cleaner and more + portable across GNAT targets, since this kind of address clause is not + supported by VM back-ends (.NET/JGNAT). + +2008-05-27 Arnaud Charlet + + * bindgen.adb: Update comments. + + * s-tasinf-mingw.adb: Add "with" of System.OS_Interface + +2008-05-27 Vincent Celier + + * gnatcmd.adb, prj-proc.adb, make.adb, mlib-prj.adb, prj.adb, + prj.ads, makegpr.adb, makeutl.adb, clean.adb, prj-nmsc.adb, + mlib-tgt.adb, prj-env.adb, prj-env.ads: + (Path_Information): New record type + Use component of type Path_Information when there are two paths, one in + canonical format and one in display format. + Update the project manager to these new components. + +2008-05-27 Robert Dewar + + * makeutl.adb: Minor reformatting + * prj-nmsc.adb: Minor reformatting + * s-stausa.adb: Minor reformatting + * s-stausa.ads: Minor reformatting + * sem_ch6.adb: Minor reformatting + +2008-05-27 Thomas Quinot + + * sem_res.adb: Minor comment fixes + +2008-05-27 Thomas Quinot + + * makeutl.adb: Minor code reorganization + + * exp_aggr.adb: Add ??? comment + Fix typo + + * exp_ch6.adb: Minor reformatting + +2008-05-27 Quentin Ochem + + * s-stausa.adb (Initialize): Updated result initialization, and + initialization of environment stack. + (Fill_Stack): Improved computation of the pattern zone, taking into + account already filled at the calling point. + (Get_Usage_Range): Now uses Min_Measure and Max_Measure instead of + Measure and Overflow_Guard. + (Report_Result): Fixed computation of the result using new fields of + Stack_Analyzer. + + * s-stausa.ads (Initialize_Analyzer): Replaced Size / Overflow_Guard + params by more explicit Stack_Size / Max_Pattern_Size params. + (Stack_Analyzer): Added distinct Stack_Size & Pattern_Size fields. + Added Stack_Used_When_Filling field. + (Task_Result): Replaced Measure / Overflow_Guard by more explicit + Min_Measure and Max_Measure fields. + + * s-tassta.adb (Task_Wrapper): Updated call to Initialize_Analyzer. + +2008-05-27 Vincent Celier + + * prj-nmsc.adb: + (Check_File): Make sure that a unit that replaces the same unit in a + project being extended is properly processed. + +2008-05-27 Ed Schonberg + + * sem_ch3.adb: + (Get_Discr_Value): Remove obsolete code that failed to find the value + of a discriminant for an inherited task component appearing in a type + extension. + +2008-05-27 Thomas Quinot + + (System.File_IO.{Close, Delete, Reset}): + Change File parameter from "in out AFCB_Ptr" to "access AFCB_Ptr". + + (Ada.*_IO.{Close, Delete, Reset, Set_Mode}): + Pass File parameter by reference. + +2008-05-27 Vincent Celier + + * prj-nmsc.adb: + (Process_Sources_In_Multi_Language_Mode): Check that there are not two + sources of the same project that have the same object file name. + (Find_Explicit_Sources): Always remove a source exception that was not + found. + +2008-05-27 Thomas Quinot + + * sem_ch3.adb: Minor reformatting + +2008-05-27 Ed Schonberg + + * sem_ch6.adb: + (Is_Interface_Conformant): Handle properly a primitive operation that + overrides an interface function with a controlling access result. + (Type_Conformance): If Skip_Controlling_Formals is true, when matching + inherited and overriding operations, omit as well the conformance check + on result types, to prevent spurious errors. + +2008-05-27 Vincent Celier + + * makeutl.ads, makeutl.adb: + (Set_Location): New procedure + (Get_Location): New function + (Update_Main): New procedure + +2008-05-27 Vincent Celier + + * prj-nmsc.adb: + (Check_Library): Allow standard project to be extended as a static + library project. + (Get_Mains): Do not inherit attribute Main in an extending library + project. + +2008-05-27 Eric Botcazou + + * system-darwin-ppc.ads (Always_Compatible_Rep): Set to False. + * system-darwin-x86.ads (Always_Compatible_Rep): Likewise. + * system-freebsd-x86.ads (Always_Compatible_Rep): Likewise. + * system-linux-ppc.ads (Always_Compatible_Rep): Likewise. + * system-linux-x86_64.ads (Always_Compatible_Rep): Likewise. + * system-linux-x86.ads (Always_Compatible_Rep): Likewise. + * system-mingw.ads (Always_Compatible_Rep): Likewise. + * system-solaris-sparc.ads (Always_Compatible_Rep): Likewise. + * system-solaris-sparcv9.ads (Always_Compatible_Rep): Likewise. + * system-solaris-x86.ads (Always_Compatible_Rep): Likewise. + +2008-05-27 Ed Schonberg + + * sem_attr.adb: add guard to previous patch. + +2008-05-27 Ed Schonberg + + * exp_disp.adb (Build_Dispatch_Tables): For a private type completed by + a synchronized tagged type, do not attempt to build dispatch table for + full view. The table is built for the corresponding record type, which + has its own declaration. + +2008-05-27 Gary Dismukes + + * sem_ch3.adb (Fixup_Bad_Constraint): Set the Etype on the bad subtype + to the known type entity E, rather than setting it to Any_Type. Fixes + possible blowup in function Base_Init_Proc, as called from Freeze_Entity + for objects whose type had an illegal constraint. + +2008-05-27 Vincent Celier + + * gnat_ugn.texi: + Add succinct documentation for attribute Excluded_Source_List_File + +2008-05-27 Vincent Celier + + * prj-attr.adb: Add new project level attribute Map_File_Option + + * prj-nmsc.adb (Process_Linker): Process new attribute Map_File_Option + + * prj.ads: Minor reformatting and comment update + (Project_Configuration): New component Map_File_Option + + * snames.adb: New standard name Map_File_Option + + * snames.ads: New standard name Map_File_Option + +2008-05-27 Vincent Celier + + * xsnames.adb: Remove unused variable Oname + +2008-05-27 Doug Rupp + + * exp_ch6.adb: + (Expand_N_Function_Call): Fix comments. Minor reformatting. + + * exp_vfpt.ads: + (Expand_Vax_Foreign_Return): Fix comments. + +2008-05-27 Thomas Quinot + + * exp_dist.adb: Minor reformating + +2008-05-26 Gary Dismukes + + * exp_ch3.adb (Expand_N_Object_Declaration): Remove checks for + No_Default_Initialization, which is now delayed until the freeze point + of the object. Add a comment about deferral of the check. + + * freeze.adb (Freeze_Entity): The check for No_Default_Initialization + on objects is moved here. + +2008-05-26 Eric Botcazou + + * s-casi16.adb (Uhalf): Rewrite it as integer with small alignment. + (Compare_Array_S16): Adjust for above change. + * s-casi32.adb (Uword): Likewise. + (Compare_Array_S32): Likewise. + * s-casi64.adb (Uword): Likewise. + (Compare_Array_S64): Likewise. + * s-caun16.adb (Uhalf): Likewise. + (Compare_Array_U16): Likewise. + * s-caun32.adb (Uword): Likewise. + (Compare_Array_U32): Likewise. + * s-caun64.adb (Uword): Likewise. + (Compare_Array_U64): Likewise. + +2008-05-26 Robert Dewar + + * exp_ch6.adb: Add ??? comment for previous change + + * exp_vfpt.adb: Minor reformatting + + * exp_vfpt.ads: Add ??? comment for last change + + * sem_attr.adb: Add some ??? comments for previous change + + * s-vaflop.ads: Add comments for previous change + +2008-05-26 Doug Rupp + + * s-vaflop-vms-alpha.adb: + Remove System.IO use clause, to prevent spurious ambiguities when + package is access through rtsfind. + +2008-05-26 Sergey Rybin + + * tree_io.ads (ASIS_Version_Number): Update because of the changes + made in front-end + +2008-05-26 Ed Schonberg + + * sem_attr.adb: + (Resolve_Attribute, case 'address): S (A .. B)' address can be safely + converted to S (A)'address only if A .. B is known to be a non-null + range. + +2008-05-26 Doug Rupp + + * s-vaflop.adb: + (Return_D, Return_F, Return_G): New functions. + + * s-vaflop.ads: + (Return_D, Return_F, Return_G): New functions. + + * exp_vfpt.adb: + (Expand_Vax_Foreign_Return): New procedure + + * exp_vfpt.ads: + (Expand_Vax_Foreign_Return): New procedure + + * rtsfind.ads: + (RE_Return_D, RE_Return_F, RE_Return_G): New RE_Ids + (RE_Return_D, RE_Return_F, RE_Return_G): New RE_Unit_Table elements + + * exp_ch6.adb: + Import Exp_Vfpt + (Expand_N_Function_Call): Call Expand_Vax_Foreign_Return. + + * s-vaflop-vms-alpha.adb: + (Return_D, Return_F, Return_G): New functions. + +2008-05-26 Gary Dismukes + + * exp_ch3.adb (Build_Array_Init_Proc): Only set Init_Proc to a dummy + init proc entity when there is actual default initialization associated + with the component type, to avoid spurious errors on objects of scalar + array types that are marked Is_Public when No_Default_Initialization + applies. + +2008-05-26 Thomas Quinot + + * rtsfind.ads, rtsfind.adb: + (RE_Get_RACW): New runtime library entity provided by PolyORB s-parint. + (Check_RPC): Support per-PCS-kind API versioning. + + exp_dist.ads, exp_dist.adb: + (Build_Stub_Tag, Get_Stub_Elements): New utility subprograms. + (PolyORB_Support.Add_RACW_From_Any): Offload common code to new runtime + library function Get_RACW. + (PolyORB_Support.Add_RACW_To_Any): Offload common code to new runtime + library function Get_Reference. + (PolyORB_Support.Add_RACW_Read_Attribute): Use Get_RACW instead of going + through an intermediate Any. + (PolyORB_Support.Add_RACW_Write_Attribute): Use Get_Reference instead of + going through an intermediate Any. + + * sem_dist.adb: Minor reformatting. + +2008-05-26 Javier Miranda + + * einfo.ads (Abstract_Interface_Alias): Renamed as Interface_Alias. + (Set_Abstract_Interface_Alias): Renamed as Set_Interface_Alias. + (Is_Internal): Adding documentation on internal entities that have + attribute Interface_Alias (old attribute Abstract_Interface_Alias) + + * einfo.adb (Abstract_Interface_Alias): Renamed as Interface_Alias. + (Set_Abstract_Interface_Alias): Renamed as Set_Interface_Alias. + Added assertion to force entities with this attribute to have + attribute Is_Internal set to True. + (Next_Tag_Component): Simplify assertion using attribute Is_Tag. + + * sem_ch3.adb (Derive_Interface_Subprograms): This subprogram has been + renamed as Derive_Progenitor_Subprograms. In addition, its code is + a new implementation. + (Add_Interface_Tag_Components): Remove special management of + synchronized interfaces. + (Analyze_Interface_Declaration): Minor reformating + (Build_Derived_Record_Type): Minor reformating + (Check_Abstract_Overriding): Avoid reporting error in case of abstract + predefined primitive inherited from interface type because the body of + internally generated predefined primitives of tagged types are generated + later by Freeze_Type + (Derive_Subprogram): Avoid generating an internal name if the parent + subprogram overrides an interface primitive. + (Derive_Subprograms): New implementation that keeps separate the + management of tagged types not implementing interfaces, from tagged + types that implement interfaces. + (Is_Progenitor): New implementation. + (Process_Full_View): Add documentation + (Record_Type_Declaration): Replace call to Derive_Interface_Subprograms + by call to Derive_Progenitor_Subprograms. + + * sem_ch6.ads (Is_Interface_Conformant): New subprogram. + (Check_Subtype_Conformant, Subtype_Conformant): Adding new argument + Skip_Controlling_Formals. + + * sem_ch6.adb (Is_Interface_Conformant): New subprogram. + (Check_Conventions): New implementation. Remove local subprogram + Skip_Check. Remove formal Search_From of routine Check_Convention. + (Check_Subtype_Conformant, Subtype_Conformant): Adding new argument + Skip_Controlling_Formals. + (New_Overloaded_Entity): Enable addition of predefined dispatching + operations. + + * sem_disp.ads + (Find_Primitive_Covering_Interface): New subprogram. + + * sem_disp.adb (Check_Dispatching_Operation): Disable registering + the task body procedure as a primitive of the corresponding tagged + type. + (Check_Operation_From_Private_Type): Avoid adding twice an entity + to the list of primitives. + (Find_Primitive_Covering_Interface): New subprogram. + (Override_Dispatching_Operation): Add documentation. + + * sem_type.adb (Covers): Minor reformatings + + * sem_util.ads (Collect_Abstract_Interfaces): Renamed as + Collect_Interfaces. + Rename formal. + (Has_Abstract_Interfaces): Renamed as Has_Interfaces. + (Implements_Interface): New subprogram. + (Is_Parent): Removed. + (Primitive_Names_Match): New subprogram. + (Remove_Homonym): Moved here from Derive_Interface_Subprograms. + (Ultimate_Alias): New subprogram. + + * sem_util.adb (Collect_Abstract_Interfaces): Renamed as + Collect_Interfaces. + Remove special management for synchronized types. Rename formal. Remove + internal subprograms Interface_Present_In_Parent and Add_Interface. + (Has_Abstract_Interfaces): Renamed as Has_Interfaces. Replace assertion + on non-record types by code to return false in such case. + (Implements_Interface): New subprogram. + (Is_Parent): Removed. No special management is now required for + synchronized types covering interfaces. + (Primitive_Names_Match): New subprogram. + (Remove_Homonym): Moved here from Derive_Interface_Subprograms. + (Ultimate_Alias): New subprogram. + + * exp_ch3.adb (Add_Internal_Interface_Entities): New subprogram. + Add internal entities associated with secondary dispatch tables to + the list of tagged type primitives that are not interfaces. + (Freeze_Record_Type): Add new call to Add_Internal_Interface_Entities + (Make_Predefined_Primitive_Specs): Code reorganization to improve + the management of predefined equality operator. In addition, if + the type has an equality function corresponding with a primitive + defined in an interface type, the inherited equality is abstract + as well, and no body can be created for it. + + * exp_disp.ads (Is_Predefined_Dispatching_Operation): Moved from + exp_util to exp_disp. + (Is_Predefined_Interface_Primitive): New subprogram. Returns True if + an entity corresponds with one of the predefined primitives required + to implement interfaces. + Update copyright notice. + + * exp_disp.adb (Set_All_DT_Position): Add assertion. Exclude from the + final check on abstract subprograms all the primitives associated with + interface primitives because they must be visible in the public and + private part. + (Write_DT): Use Find_Dispatching_Type to locate the name of the + interface type. This allows the use of this routine, for debugging + purposes, when the tagged type is not fully decorated. + (Is_Predefined_Dispatching_Operation): Moved from exp_util to exp_disp. + Factorize code calling new subprogram Is_Predefined_Interface_Primitive. + (Is_Predefined_Interface_Primitive): New subprogram. Returns True if an + entity corresponds with one of the predefined primitives required to + implement interfaces. + + * exp_util.adb (Find_Interface_ADT): New implementation + (Find_Interface): Removed. + + * sprint.adb (Sprint_Node_Actual): Generate missing output for the + list of interfaces associated with nodes + N_Formal_Derived_Type_Definition and N_Private_Extension_Declaration. + +2008-05-26 Thomas Quinot + + * exp_ch5.adb (Make_Tag_Ctrl_Assignment): Add missing guard on + condition for assignment to temporary. + +2008-05-26 Ed Schonberg + + * exp_ch4.adb (Expand_Concatenate_Other): Add explicit constraint + checks on the upper bound if the index type is a modular type, to + prevent wrap-around computations when size is close to upper bound of + type. + +2008-05-26 Robert Dewar + + * sem_ch3.adb: Minor reformatting + +2008-05-26 Ed Schonberg + + * sem_ch12.adb (Remove_Parent): Use specification of instance + to retrieve generic parent, + to handle properly the case where the instance is a child unit. + Add guard to handle properly wrapper packages. + Minor reformatting + +2008-05-26 Thomas Quinot + + * sinfo.ads: Minor reformatting + +2008-05-26 Hristian Kirtchev + + * exp_ch4.adb (Expand_N_Type_Conversion): Minor code reformatting. + Generate a tag check when the result subtype of a function, defined by + an access definition, designates a specific tagged type. + (Make_Tag_Check): New routine. + +2008-05-26 Arnaud Charlet + + * ceinfo.adb, csinfo.adb: Remove warnings. Update headers. + +2008-05-26 Eric Botcazou + + * gigi.h (gigi): Remove bogus ATTRIBUTE_UNUSED marker. + (builtin_decl_for): Likewise. + * trans.c (gigi): Likewise. + * utils.c (def_builtin_1): Fix formatting. + +2008-05-26 Hristian Kirtchev + + * exp_ch3.adb (Build_Init_Statements): Alphabetize local variables. + Create the statements which map a string name to protected or task + entry indix. + + * exp_ch9.adb: Add with and use clause for Stringt. + Minor code reformatting. + (Build_Entry_Names): New routine. + (Make_Initialize_Protection, Make_Task_Create_Call): Generate a value + for flag Build_Entry_Names which controls the allocation of the data + structure for the string names of entries. + + * exp_ch9.ads (Build_Entry_Names): New subprogram. + + * exp_util.adb (Entry_Names_OK): New function. + + * exp_util.ads (Entry_Names_OK): New function. + + * rtsfind.ads: Add RO_PE_Set_Entry_Name and RO_TS_Set_Entry_Name to + enumerations RE_Id and RE_Unit_Table. + + * s-taskin.adb Add with and use clause for Ada.Unchecked_Deallocation. + (Free_Entry_Names_Array): New routine. + + * s-taskin.ads: Comment reformatting. + Add types String_Access, Entry_Names_Array, Entry_Names_Array_Access. + Add component Entry_Names to record Ada_Task_Control_Block. + (Free_Entry_Names_Array): New routine. + + * s-tassta.adb (Create_Task): If flag Build_Entry_Names is set, + dynamically allocate an array + of string pointers. This structure holds string entry names. + (Free_Entry_Names): New routine. + (Free_Task, Vulnerable_Free_Task): Deallocate the entry names array. + (Set_Entry_Names): New routine. + + * s-tassta.ads: + (Create_Task): Add formal Build_Entry_Names. The flag is used to + control the allocation of the data structure which stores entry names. + (Set_Entry_Name): New routine. + + * s-tpoben.adb: + Add with and use clause for Ada.Unchecked_Conversion. + (Finalize): Deallocate the entry names array. + (Free_Entry_Names): New routine. + (Initialize_Protection_Entries): When flag Build_Entry_Names is set, + create an array of string pointers to hold the entry names. + (Set_Entry_Name): New routine. + + * s-tpoben.ads: + Add field Entry_Names to record Protection_Entries. + (Initialize_Protection_Entries): Add formal Build_Entry_Names. + (Set_Entry_Name): New routine. + +2008-05-26 Vincent Celier + + * prj-nmsc.adb: + (Process_Project_Level_Simple_Attributes): process attribute Library_GCC + + * prj.ads: + (Project_Configuration): New component Shared_Lib_Driver + +2008-05-26 Ed Schonberg + + * inline.adb: + (Cleanup_Scopes): For a protected operation, transfer finalization list + to protected body subprogram, to force cleanup actions when needed. + +2008-05-26 Robert Dewar + + * sem_cat.adb: Minor reformatting + + * gnatname.adb: Minor reformatting + + * osint.ads: Minor reformatting + + * s-carun8.ads: Minor reformatting + + * g-heasor.ads: Minor comment fix (unit is now pure) + +2008-05-26 Robert Dewar + + * exp_ch2.adb: + (Expand_Current_Value): Properly type generated integer literal + +2008-05-26 Sergey Rybin + + * gnat_ugn.texi: Add description for the new gnatcheck rule - + Separate_Numeric_Error_Handlers. + +2008-05-26 Pascal Obry + + * sem_aggr.adb: Minor reformatting. + +2008-05-26 Jose Ruiz + + * s-osinte-aix.adb: + (To_Target_Priority): Setting the time slice value to 0 or greater sets + the scheduling policy to FIFO within priorities or round-robin + respectively. + Hence, the priority must be set in this case to the one selected by the + user. + +2008-05-26 Ed Schonberg + + * sem_ch12.adb: + (Remove_Parent): If the enclosing scope is an instance whose generic + parent is declared within some parent scope of the just completed + instance, make full views of the entities in that parent visible, when + applicable. + +2008-05-26 Kai Tietz + + * mingw32.h (STD_MINGW): Set to true for target w64. + +2008-05-25 Eric Botcazou + + * trans.c (Attribute_to_gnu) : Set TREE_NO_TRAMPOLINE + instead of TREE_STATIC on the ADDR_EXPR. + +2008-05-24 Eric Botcazou + + * trans.c (gnat_to_gnu): Do not set source location info on NOP_EXPRs. + (Sloc_to_locus): Do not overwrite known GCC locations when translating + GNAT standard locations. + +2008-05-23 Eric Botcazou + + * gigi.h (mark_visited): Declare. + * decl.c (gnat_to_gnu_entity): Use mark_visited instead of marking + only the topmost node of expressions. + (elaborate_expression_1): Look deeper for read-only variables. + * trans.c (add_decl_expr): Use mark_visited instead of marking by hand. + (mark_visited): Move logic to mark_visited_r. Invoke walk_tree. + (mark_visited_r): New function. + +2008-05-23 Vincent Celier + + * snames.adb: New standard name Excluded_Source_List_File. + + * snames.ads: New standard name Excluded_Source_List_File. + + * prj-attr.adb: New project level attribute Excluded_Source_List_File. + + * prj-nmsc.adb: (Find_Excluded_Sources): New parameter Project. + Get excluded sources from + file indicated by attribute Excluded_Source_List_File, when present and + neither Excluded_Source_Files nor Locally_Removed_Files are declared. + +2008-05-23 Robert Dewar + + * exp_dist.adb: Minor reformatting + +2008-05-23 Ed Schonberg + + * sem_attr.adb (Resolve_Attribute, case 'address): If the prefix is a + slice, convert it to an indexed component, which is equivalent, more + efficient, and usable even if the slice itself is not addressable. + +2008-05-23 Olivier Hainque + + * gnat_ugn.texi (Calling Conventions): Document that the Intrinsic + convention also allows access to named compiler built-in subprograms + such as the GCC __builtin family. + +2008-05-23 Vincent Celier + + * prj-nmsc.adb (Check_Naming_Schemes): Check a file for spec, body and + sep. If there are several possibilities, choose the one with the + longer prefix. + +2008-05-23 Vincent Celier + + * gnatlink.adb (Process_Args): Do not disable scanning of ALI file for + back end switches when executable specified with --GCC= is same as + default, even if there are additional options. + + * gnat_ugn.texi: + Document when the back end switches from the ALI file are taken into + account when gnatlink is invoked with --GCC= + +2008-05-23 Thomas Quinot + + * s-os_lib.adb: + (copy_File): Do not open destination file if source file is unreadable. + +2008-05-23 Eric Botcazou + + * utils.c (handle_type_generic_attribute): Adjust to accept + fixed arguments before an elipsis. + +2008-05-21 Thomas Quinot + + * g-sothco.ads, g-sothco.adb: New files. + +2008-05-20 Thomas Quinot + + * Makefile.rtl (GNAT.Sockets.Thin_Common): New unit. + + * g-sttsne-vxworks.adb: Add missing dependency on Sockets.Constants. + Add missing "with" of Ada.Unchecked_Conversion + + * g-soccon-linux-ppc.ads, g-soccon-linux-64.ads, g-soccon-lynxos.ads, + g-soccon-linux-x86.ads, g-soccon-hpux-ia64.ads, + g-soccon-solaris-64.ads, g-soccon-tru64.ads, g-soccon-aix.ads, + g-soccon-irix.ads, g-soccon-hpux.ads, g-soccon-solaris.ads, + g-soccon-vms.ads, g-soccon-mingw.ads, g-soccon-vxworks.ads, + g-socthi-vxworks.adb, g-soccon-freebsd.ads, g-soccon.ads: + Move common code out of GNAT.Sockets.Thin implementations and into + Thin_Common. + New constant SIZEOF_fd_set + New flag Has_Sockaddr_Len + New constants SIZEOF_sockaddr_in, SIZEOF_sockaddr_in6 + + * g-stsifd-sockets.adb + (Create): Remove call to Set_Length; use Set_Family to set the family + and (on appropriate platforms) length fields in struct sockaddr. + + * g-socthi.adb, g-socthi.ads, g-socthi-vms.ads, g-socthi-vms.adb, + g-socthi-mingw.adb, g-socthi-mingw.ads, g-socthi-vxworks.adb, + g-soccon-darwin.ads, g-soccon-darwin.ads: New constant SIZEOF_fd_set + Move common code out of GNAT.Sockets.Thin implementations and into + Thin_Common. + + * g-socket.ads, g-socket.adb: + Move common code out of GNAT.Sockets.Thin implementations and into + Thin_Common. + (Connect_Socket, Accept_Socket): Provide new versions of these two + routines that operate with a user specified timeout. + (Bind_Socket, Connect_Socket, Send_Socket): Remove calls to Set_Length, + this is now handled automatically by Set_Family on platforms that + require it. + + * gen-soccon.c: + Move common code out of GNAT.Sockets.Thin implementations and into + Thin_Common. + (SIZEOF_sockaddr_in6): On platforms where IPv6 is not supported, define + this constant to 0 (not -1) because we use it to initialize an + unsigned_char value. + Align values for numeric constants only. + Handle the case of systems that do not support AF_INET6. + New constant SIZEOF_fd_set + New flag Has_Sockaddr_Len + New constants SIZEOF_sockaddr_in, SIZEOF_sockaddr_in6 + + * gsocket.h: New flag Has_Sockaddr_Len + New constants SIZEOF_sockaddr_in, SIZEOF_sockaddr_in6 + +2008-05-20 Santiago Uruena + + * i-cobol.ads: Interfaces.COBOL should be preelaborate. + +2008-05-20 Arnaud Charlet + + * s-linux-hppa.ads (atomic_lock_t): Put back proper alignment now that + the underlying issue with malloc/free has been fixed. Remove associated + comments. + Minor reformatting. + Related to PR ada/24533 + +2008-05-20 Robert Dewar + + * ali.adb: Correct casing of ASCII.NUL + + * styleg-c.adb (Check_Identifier): Handle case of names in ASCII + properly. + +2008-05-20 Robert Dewar + Gary Dismukes + + * checks.adb (Apply_Arithmetic_Overflow_Check): Avoid intermediate + overflow if result converted to wider integer type. + (Apply_Type_Conversion_Checks): Don't emit checks on conversions to + discriminated types when discriminant checks are suppressed. + +2008-05-20 Vincent Celier + + * cstand.adb (Print_Standard): Issue the correct Size clause for type + Wide_Wide_Character. + +2008-05-20 Tristan Gingold + + * decl.c: Do not emit a variable for a object that has an address + representation clause whose value is known at compile time. + When a variable has an address clause whose value is known at compile + time, refer to this variable by using directly the address instead of + dereferencing a pointer. + +2008-05-20 Robert Dewar + + PR ada/30740 + * einfo.ads, einfo.adb (Non_Binary_Modulus): Applies to all types and + subtypes, always False for non-modular types. + Shared_Var_Assign_Proc (node22) and Shared_Var_Read_Proc (node 15) + entry nodes have been replaced by Shared_Var_Procs_Instance (node22) + for Shared_Storage package. + (Is_RACW_Stub_Type): New entity flag. + + * exp_ch4.adb + (Expand_N_Op_Expon): Avoid incorrect optimization of a*(2**b) in the + case where we have a modular type with a non-binary modules. + Comments reformattings. + + * sem_intr.adb: Simplify code not that Non_Binary_Modulus applies to + all types. + +2008-05-20 Javier Miranda + + * exp_aggr.adb + (Build_Record_Aggr_Code): Fix wrong tests checking progenitors. Previous + tests did not covered the case in which the type of the aggregate has + no progenitors but some its parents has progenitors. + +2008-05-20 Gary Dismukes + Hristian Kirtchev + + * exp_ch3.adb + (Expand_N_Object_Declaration): Correct the condition which triggers the + generation of a call to Displace when initializing a class-wide object. + (Build_Dcheck_Functions): Build discriminant-checking for null variants + when Frontend_Layout_On_Target is true to ensure that they're available + for calling when a record variant size function is built in Layout. + +2008-05-20 Ed Schonberg + + * exp_ch5.adb (Expand_Assign_Record): Within an initialization + procedure for a derived type retrieve the discriminant values from the + parent using the corresponding discriminant. + (Expand_N_Assignment_Statement): Skip generation of implicit + if-statement associated with controlled types if we are + compiling with restriction No_Finalization. + +2008-05-20 Vincent Celier + + * prj.adb (Hash (Project_Id)): New function + (Project_Empty): Add new component Interfaces_Defined + + * prj.ads (Source_Data): New component Object_Linked + (Language_Config): New components Object_Generated and Objects_Linked + (Hash (Project_Id)): New function + (Source_Data): New Boolean components In_Interfaces and + Declared_In_Interfaces. + (Project_Data): New Boolean component Interfaces_Defined + + * prj-attr.adb: + New project level attribute Object_Generated and Objects_Linked + Add new project level attribute Interfaces + + * prj-dect.adb: Use functions Present and No throughout + (Parse_Variable_Declaration): If a string type is specified as a simple + name and is not found in the current project, look for it also in the + ancestors of the project. + + * prj-makr.adb: + Replace procedure Make with procedures Initialize, Process and Finalize + to implement H414-023: process different directories with different + patterns. + Use functions Present and No throughout + + * prj-makr.ads: + Replace procedure Make with procedures Initialize, Process and Finalize + + * prj-nmsc.adb + (Add_Source): Set component Object_Exists and Object_Linked accordnig to + the language configuration. + (Process_Project_Level_Array_Attributes): Process new attributes + Object_Generated and Object_Linked. + (Report_No_Sources): New Boolean parameter Continuation, defaulted to + False, to indicate that the erreor/warning is a continuation. + (Check): Call Report_No_Sources with Contnuation = True after the first + call. + (Error_Msg): Process successively contnuation character and warning + character. + (Find_Explicit_Sources): Check that all declared sources have been found + (Check_File): Indicate in hash table Source_Names when a declared source + is found. + (Check_File): Set Other_Part when found + (Find_Explicit_Sources): In multi language mode, check if all exceptions + to the naming scheme have been found. For Ada, report an error if an + exception has not been found. Otherwise, disregard the exception. + (Check_Interfaces): New procedure + (Add_Source): When Other_Part is defined, set mutual pointers in spec + and body. + (Check): In multi-language mode, call Check_Interfaces + (Process_Sources_In_Multi_Language_Mode): Set In_Interfaces to False + for an excluded source. + (Remove_Source): A source replacing a source in the interfaces is also + in the interfaces. + + * prj-pars.adb: Use function Present + + * prj-part.adb: Use functions Present and No throughout + (Parse_Single_Project): Set the parent project for child projects + (Create_Virtual_Extending_Project): Register project with no qualifier + (Parse_Single_Project): Allow an abstract project to be extend several + times. Do not allow an abstract project to extend a non abstract + project. + + * prj-pp.adb: Use functions Present and No throughout + (Print): Take into account the full associative array attribute + declarations. + + * prj-proc.adb: Use functions Present and No throughout + (Expression): Call itself with the same From_Project_Node for the + default value of an external reference. + + * prj-strt.adb: Use functions Present and No throughout + (Parse_Variable_Reference): If a variable is specified as a simple name + and is not found in the current project, look for it also in the + ancestors of the project. + + * prj-tree.ads, prj-tree.adb (Present): New function + (No): New function + Use functions Present and No throughout + (Parent_Project_Of): New function + (Set_Parent_Project_Of): New procedure + + * snames.ads, snames.adb: + Add new standard names Object_Generated and Objects_Linked + +2008-05-20 Hristian Kirtchev + + * exp_ch6.adb (Expand_Call): Add guard to ensure that both the parent + and the derived type are of the same kind. + (Expand_Call): Generate type conversions for actuals of + record or array types when the parent and the derived types differ in + size and/or packed status. + +2008-05-20 Javier Miranda + Ed Schonberg + + * exp_disp.adb (Make_DT, Make_Secondary_DT, Make_Tags): Avoid + generating dispatch tables of locally defined tagged types statically. + Remove implicit if-statement that is no longer required. + (Expand_Dispatching_Call): If this is a call to an instance of the + generic dispatching constructor, the type of the first argument may be + a subtype of Tag, so always use the base type to recognize this case. + +2008-05-20 Thomas Quinot + + * exp_dist.adb + (GARLIC_Support.Add_RACW_Read_Attribute): When a zero value is received, + and the RACW is null-excluding, raise CONSTRAINT_ERROR instead of + assigning NULL into the result, to avoid a spurious warning. + (Add_RACW_Features, case Same_Scope): Add assertion that designated type + is not frozen. + (Add_Stub_Type): Set entity flag Is_RACW_Stub_Type on generated stub + type. + (Build_From_Any_Function, Build_To_Any_Function, + Build_TypeCode_Function): For a type that has user-specified stream + attributes, use an opaque sequence of octets as the representation. + +2008-05-20 Kevin Pouget + + * exp_smem.ads, exp_smem.adb: Construction of access and assign + routines has been replaced by an instantiation of + System.Shared_Storage.Shared_Var_Procs generic package, while expanding + shared variable declaration. + Calls to access and assign routines have been replaced by calls to + Read/Write routines of System.Shared_Storage.Shared_Var_Procs + instantiated package. + + * rtsfind.ads: RE_Shared_Var_Procs entry has been added in RE_Unit_Table + It identifies the new generic package added in s-shasto. + + * s-shasto.adb, s-shasto.ads: A new generic package has been added, it + is instantiated for each shared passive variable. It provides + supporting procedures called upon each read or write access by the + expanded code. + + * sem_attr.adb: + For this runtime unit (always compiled in GNAT mode), we allow + stream attributes references for limited types for the case where + shared passive objects are implemented using stream attributes, + which is the default in GNAT's persistent storage implementation. + +2008-05-20 Ed Schonberg + + * freeze.adb + (Freeze_Enumeration_Type): For a subtype that inherits a foreign + convention from its base type, do not set the type to that of integer, + because it may inherit a size clause. + Warn on a size clause with a size different + from that of Integer, if the type has convention C. + +2008-05-20 Vincent Celier + + * gnatname.adb + (Scan_Args): Rewrite to take into account new switch --and to separate + arguments into sections. + (Gnatname): Call Prj.Makr.Initialize, then Prj.Makr.Process for each + section, then Finalize. + +2008-05-20 Tristan Gingold + + * init.c: Enable stack probing on ppc-linux. + + * tracebak.c: Add symbolic traceback for ppc-linux. + + * system-linux-ppc.ads: Enable stack probing on ppc-linux. + +2008-05-20 Arnaud Charlet + + * Makefile.in + (common-tools): New rule, to avoid parallel build failure on gnat tools. + Reenable parallel builds on this Makefile. + + * Make-lang.in: Update dependencies. + +2008-05-20 Robert Dewar + + * opt.ads (Treat_Restrictions_As_Warnings): New switch + + * sem_prag.adb, par-prag.adb, restrict.ads: Implement flag + Treat_Restrictions_As_Warnings. + + * switch-c.adb: Recognize new switch -gnatr + + * usage.adb: Add line for -gnatr + +2008-05-20 Hristian Kirtchev + + * par-ch3.adb + (P_Access_Definition): Change the error message when parsing "access + all" in Ada 95 mode. The message no longer forces the user to recompile + in 05 mode only to discover that anonymous access types are not allowed + to have "all". + +2008-05-20 Hristian Kirtchev + + * par-ch9.adb + (P_Protected): Update the error message on missing "-gnat05" switch when + using interfaces in conjunction with protected types. Remove the + incorrect error message associated with the presence of "private" after + a "with". + +2008-05-20 Ed Schonberg + + * sem_aggr.adb: Update comments. + Improve previous change for PR ada/17985 + +2008-05-20 Thomas Quinot + + * sem_cat.adb + (Set_Categorization_From_Scope): Do not set In_Remote_Types unless in + the visible part of the spec of a remote types unit. + (Validate_Remote_Access_Object_Type_Declaration): + New local subprogram Is_Valid_Remote_Object_Type, replaces + Is_Recursively_Limited_Private. + (Validate_RACW_Primitives): Enforce E.2.2(14) rules: the types of all + non-controlling formals (and the return type, even though this is not + explicit in the standard) must support external streaming. + (Validate_RCI_Subprogram_Declaration): Enforce E.2.3(14) rules: same + as above for of RAS types and RCI subprograms. (The return type is not + checked yet). + Update comments related to RACWs designating limited interfaces per + ARG ruling on AI05-060. + + * sem_util.ads, sem_util.adb + (Is_Remote_Access_To_Class_Wide_Type): Only rely on Is_Remote_Types and + Is_Remote_Call_Interface to identify RACW types in a stable and + consistent way. We used to rely in this predicate on the privateness of + the designated type and its ancestors, but depending on the currently + visible private parts, this caused false negatives. We now uniformly + rely on checks made at the point where the RACW type is declared. + (Inspect_Deferred_Constant_Completion): Moved from Sem_Ch7. + +2008-05-20 Javier Miranda + Ed Schonberg + Hristian Kirtchev + + * sem_ch3.adb + (Analyze_Object_Declaration): Fix over-conservative condition + restricting use of predefined assignment with tagged types that have + convention CPP. + (Analyze_Object_Declaration): Relax the check regarding deferred + constants declared in scopes other than packages since they can be + completed with pragma Import. + Add missing escaping of all-caps word 'CPP' in error messages. + (Build_Discriminated_Subtype): Do not inherit representation clauses + from parent type if subtype already carries them, because they are + inherited earlier during derivation and already include those that may + come from a partial view. + + * sem_ch9.adb, sem_ch5.adb, sem_ch6.adb (Analyze_Subprogram_Body): + Check the declarations of a subprogram body for proper deferred + constant completion. + + * sem_ch7.ads, sem_ch7.adb + (Inspect_Deferred_Constant_Completion): Moved to sem_util. + +2008-05-20 Ed Schonberg + Thomas Quinot + + * sem_ch4.adb + (Try_Indexed_Call): Handle properly a construct of the form F(S) where + F is a parameterless function that returns an array, and S is a subtype + mark. + (Analyze_Call): Insert dereference when the prefix is a parameterless + function that returns an access to subprogram and the call has + parameters. + Reject a non-overloaded call whose name resolves to denote + a primitive operation of the stub type generated to support a remote + access-to-class-wide type. + +2008-05-20 Ed Schonberg + + * sem_ch8.adb + (Note_Redundant_Use): Diagnose a redundant use within a subprogram body + when there is a use clause for the same entity in the context. + (Analyze_Subprogram_Renaming): A renaming_as_body is legal if it is + created for a stream attribute of an abstract type or interface type. + +2008-05-20 Thomas Quinot + + * sem_dist.ads, sem_dist.adb (Is_RACW_Stub_Type_Operation): New + subprogram. + + * sem_type.adb + (Add_One_Interp): Ignore any interpretation that is a primitive + operation of an RACW stub type (these primitives are only executed + through dispatching, never through static calls). + (Collect_Interps): When only one interpretation has been found, set N's + Entity and Etype to that interpretation, otherwise Entity and Etype may + still refer to an interpretation that was ignored by Add_One_Interp, + in which case would end up with being marked as not overloaded but with + an Entity attribute not pointing to its (unique) correct interpretation. + +2008-05-20 Ed Schonberg + + * sem_eval.adb + (Eval_Slice): Warn when a slice whose discrete range is a subtype name + denotes the whole array of its prefix. + +2008-05-20 Robert Dewar + + * sem_res.adb (Resolve_Op_Not): Warn on double negation + +2008-05-20 Ed Schonberg + + * sprint.adb + (Print_Itype): Do not modify the sloc of the component type of a + (packed) array itype, because it is an unrelated type whose source + location is independent of the point of creation of the itype itself. + +2008-05-20 Thomas Quinot + + * uintp.adb, urealp.adb: Replace calls to Increment_Last + Set with + Append. + +2008-05-20 Robert Dewar + Vincent Celier + + * vms_data.ads: Add entry for -gnatr + Put GNAT SYNC section in proper alpha order + Add VMS qualifier /DISPLAY_PROGRESS equivalent to gnatmake switch -d + + * gnat_ugn.texi: Add documentation for new gnatname switch --and + Update the style checks section + Add documentation of -gnatr + Add to the "Adding the Results of Compiler Checks to gnatcheck Output" + subsection the explanation how compiler checks should be disabled for + gnatcheck. + Update the list of Ada 95 reserved words used by in the project language + Add documentation for project qualifiers. + Document that abstract projects may be extended by different projects in + the same project tree. + Add documentation for gnatmake switch -d + + * ug_words: Add -gnatyy VMS equivalence string. + Add entry for -gnatr + +2008-05-20 Bob Duff + + * a-rttiev.adb + (Set_Handler): Remove code from both of these that implements + RM-D.15(15/2), because it causes a race condition and potential + deadlock. + (Process_Queued_Events): Add comment explaining "exception when others + => null". Add clarifying ".all", even though implicit .all is legal + here. + +2008-05-20 Arnaud Charlet + + * s-winext.ads: Replace representation clause by pragma Pack. Gives + equivalent representation, but has the advantage of allowing + compilation of this file under 64 bits platforms. + + * s-os_lib.adb (Normalize_Pathname): Mark Cur_Dir constant. + + * s-osinte-irix.ads: (Alternate_Stack_Size): Add dummy declaration. + + * adaint.c: + Don't define dummy implementation of convert_addresses on ppc-linux. + +2008-05-20 Ed Schonberg + + * exp_ch7.adb + (Expand_Ctrl_Function_Call): Do not attach result to finalization list + if expression is aggregate component. + +2008-05-20 Robert Dewar + + * g-byorma.adb, gnatlink.adb, prepcomp.adb, sinfo.ads, + sem_ch12.adb: Update comments. Minor reformatting. + + * exp_ch2.adb: Typo + + * s-unstyp.ads: Fixed some typos in comments. + +2008-05-20 Arnaud Charlet + + * s-taspri-vxworks.ads (Task_Address, Task_Address_Size): New + type/constant. + + * g-socthi-vxworks.ads: Update to latest socket changes. + + * a-caldel-vms.adb: Resync with a-caldel spec. + + * exp_ch9.ads, sem_ch8.ads, inline.adb: Minor reformatting. + Update comments. + +2008-05-17 Eric Botcazou + + * trans.c (gnat_to_gnu) : Account + for dummy types pointed to by the converted pointer types. + +2008-05-15 Eric Botcazou + + * trans.c (add_decl_expr): At toplevel, mark the TYPE_ADA_SIZE field + of records and unions. + (gnat_to_gnu) : Fix formatting. + +2008-05-14 Samuel Tardieu + Robert Dewar + + * sem_attr.adb (Analyze_Attribute, Attribute_Old case): Add + restrictions to the prefix of 'Old. + * sem_util.ads, sem_util.adb (In_Parameter_Specification): New. + * gnat_rm.texi ('Old): Note that 'Old cannot be applied to local + variables. + +2008-05-13 Eric Botcazou + + PR ada/24880 + PR ada/26635 + * utils.c (convert) : When converting an additive + expression to an integral type with lower precision, use NOP_EXPR + directly in a couple of special cases. + +2008-05-12 Samuel Tardieu + Ed Schonberg + + * sem_ch3.adb (Build_Derived_Record_Type): Accept statically matching + constraint expressions. + +2008-05-12 Tomas Bily + + * utils2.c (known_alignment, contains_save_expr_p) + (gnat_mark_addressable): Use CASE_CONVERT. + * decl.c (annotate_value): Likewise. + * trans.c (maybe_stabilize_reference): Likewise. + * utils2.c (build_binary_op): Use CONVERT_EXPR_P. + * utils.c (rest_of_record_type_compilation): Likewise. + * trans.c (protect_multiple_eval, Attribute_to_gnu) + (protect_multiple_eval): Likewise. + +2008-05-08 Andreas Schwab + + * utils.c (handle_pure_attribute, init_gigi_decls): Rename + DECL_IS_PURE to DECL_PURE_P. + +2008-05-05 Eric Botcazou + + * decl.c (maybe_pad_type): Add ??? comment. + +2008-05-03 Eric Botcazou + + * decl.c (components_to_record): Zero the alignment of the qualified + union built for the variant part upon creating it. + +2008-05-03 Eric Botcazou + + * decl.c (maybe_pad_type): Try to get a form of the type with integral + mode even if the alignment is not a factor of the original size. But + make sure to create the inner field with the original size. Reorder. + * trans.c (addressable_p) : Treat the field of a padding + record as always addressable. + * utils.c (convert): Deal specially with conversions between original + and packable versions of a record type. + * utils2.c (build_binary_op) : Be more restrictive when + recognizing an assignment between padded objects. + +2008-05-01 Eric Botcazou + + * decl.c (make_packable_type): Resize the last component to its RM size + only if it is of an aggregate type. + * trans.c (call_to_gnu): Fix nit in comment. + (gnat_to_gnu): Likewise. + +2008-04-30 Samuel Tardieu + + * Makefile.in: Adapt sh4-linux target. + +2008-04-29 Ed Schonberg + + PR ada/35792 + * sem_ch3.adb (Find_Type_Name): Refuse completion of an incomplete + tagged type by an untagged protected or task type. + +2008-04-28 Eric Botcazou + Tristan Gingold + + PR ada/36007 + * decl.c (gnat_to_gnu_entity) : Do not promote alignment + of aliased objects with an unconstrained nominal subtype. + Cap the promotion to the effective alignment of the word mode. + +2008-04-28 Ralf Wildenhues + + * Make-lang.in (ada.tags, check-acats, ada/treeprs.ads) + (ada/einfo.h, ada/sinfo.h, ada/nmake.adb, ada/nmake.ads): + Use '&&' instead of ';'. + +2008-04-24 Olivier Hainque + + * trans.c (Attribute_to_gnu) : Length computation + doesn't require signed arithmetic anymore. + +2008-04-23 Paolo Bonzini + + * trans.c (Attribute_to_gnu): Don't set TREE_INVARIANT. + (call_to_gnu): Don't set TREE_INVARIANT. + * utils2.c (gnat_build_constructor): Don't set TREE_INVARIANT. + +2008-04-22 Joel Sherrill + + * s-osinte-rtems.adb: Add sigalstack function. + * s-osinte-rtems.ads: Add SO_ONSTACK and sigalstack + function. Add Alternate_Stack and Alternate_Stack_Size. + Add missing process_shared field to pthread_condattr_t + and change ss_low_priority to int from timespec. + +2008-04-22 Samuel Tardieu + + * i-forbla.adb: Link against -llapack and -lblas by default + instead of the private -lgnalasup. + +2008-04-21 Olivier Hainque + + Access to most C builtins from Ada + * utils.c: #include "langhooks.h" and define GCC_DIAG_STYLE. + (handle_pure_attribute, handle_novops_attribute, + handle_nonnull_attribute, handle_sentinel_attribute, + handle_noreturn_attribute, handle_malloc_attribute, + handle_type_generic_attribute): New attribute handlers, from C fe. + (gnat_internal_attribute_table): Map the new handlers. + (gnat_init_decl_processing): Move call to gnat_install_builtins to ... + (init_gigi_decls): ... here. + (handle_const_attribute, handle_nothrow_attribute, builtin_decl_for): + Move to a section dedicated to builtins processing. + (build_void_list_node, builtin_type_for_size): New functions. + (def_fn_type, get_nonnull_operand): Likewise. + (install_builtin_elementary_type, install_builtin_function_types, + install_builtin_attributes): Likewise. + (fake_attribute_handler): Fake handler for attributes we don't + support in Ada. + (def_builtin_1): New function, worker for DEF_BUILTIN. + (install_builtin_functions): New function. + (gnat_install_builtins): Move to the builtins processing section. + Now calling the newly introduced installers. + +2008-04-20 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : Also promote the alignment of + constant objects, but not exceptions. + * trans.c (add_decl_expr): Use gnat_types_compatible_p for type + compatibility test. + * utils.c (create_var_decl_1): Likewise. + * utils2.c (build_binary_op) : Also use the padded view of + the type when copying to padded object and the source is a constructor. + +2008-04-18 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : When trying to promote the + alignment, reset it to zero if it would end up not being greater + than that of the type. + +2008-04-18 Eric Botcazou + + * decl.c (maybe_pad_type): Only generate the XVS parallel type if + the padded type has a variable size. + +2008-04-18 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : Use the return by + target pointer mechanism as soon as the size is not constant. + +2008-04-18 Eric Botcazou + + * gigi.h (create_var_decl_1): Declare. + (create_var_decl): Turn into a macro invoking create_var_decl_1. + (create_true_var_decl): Likewise. + * utils.c (create_var_decl_1): Make global and reorder parameters. + (create_var_decl): Delete. + (create_true_var_decl): Likewise. + +2008-04-17 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : Promote the alignment of + objects by default. + * fe.h (Debug_Flag_Dot_A): Delete. + * debug.adb (-gnatd.a): Update documentation. + +2008-04-17 Samuel Tardieu + + * g-socket.ads, g-socket.adb (Get_Address): Make Stream a + "not null" parameter. + +2008-04-17 Samuel Tardieu + + * g-socket.adb: Add a message "IPv6 not supported" to the + Socket_Error exception. + +2008-04-16 Samuel Tardieu + + PR ada/29015 + * sem_ch12.adb (Instantiate_Type): Check whether the full view of + the type is known instead of the underlying type. + +2008-04-15 Ed Schonberg + + PR ada/22387 + * exp_ch5.adb (Expand_Assign_Record): Within an initialization + procedure for a derived type retrieve the discriminant values from + the parent using the corresponding discriminant. + +2008-04-15 Samuel Tardieu + Gary Dismukes + + PR ada/28733 + * sem_ch8.adb (Analyze_Use_Package): Do not allow "use" of something + which is not an entity (and hence not a package). + (End_Use_Package): Ditto. + +2008-04-15 Ed Schonberg + + PR ada/16086 + * sem_ch12.adb (Analyze_Formal_Subprogram): The default can be any + protected operation that matches the signature, not only an entry, a + regular subprogram or a literal. + +2008-04-15 Eric Botcazou + + * ada-tree.h (DECL_BY_COMPONENT_PTR_P): Use DECL_LANG_FLAG_3. + * decl.c (gnat_to_gnu_entity) : Call maybe_pad_type only + if a size or alignment is specified. Do not take into account + alignment promotions for the computation of the object's size. + : Call maybe_pad_type only if a size or alignment is specified. + (maybe_pad_type): Really reuse the RM_Size of the original type if + requested. + * trans.c (Attribute_to_gnu): Fix a couple of nits. + * utils2.c (build_binary_op) : Merge related conditional + statements. Use the padded view of the type when copying between + padded objects of the same underlying type. + +2008-04-14 Ralf Wildenhues + + * vms_data.ads: Fix typo in constant. + * gen-soccon.c: Fix typo in error string. + * gnat_rm.texi (Pragma Optimize_Alignment, Pragma Postcondition): + Fix typos. + * a-calcon.ads, a-calend-vms.adb, a-calend.adb, a-crdlli.ads, + bcheck.adb, checks.adb, einfo.ads, errout.adb, erroutc.adb, + erroutc.ads, exp_attr.adb, exp_ch11.adb, exp_ch2.adb, + exp_ch5.adb, exp_ch9.adb, exp_ch9.ads, exp_pakd.adb, + exp_util.adb, fmap.adb, g-soccon-linux-mips.ads, + g-soccon-rtems.ads, g-timsta.adb, g-timsta.ads, lib-writ.ads, + mlib-tgt-specific-linux.adb, mlib-tgt-specific-tru64.adb, + s-interr-vxworks.adb, s-interr.adb, s-osinte-lynxos.ads, + s-rident.ads, s-taprop-solaris.adb, s-tassta.adb, s-win32.ads, + sem_aggr.adb, sem_attr.ads, sem_ch10.adb, sem_ch13.ads, + sem_ch3.adb, sem_ch6.adb, sem_ch7.adb, sem_ch8.adb, sem_ch9.adb, + sem_prag.ads, sem_res.adb, sem_util.adb, sem_util.ads, + sinfo.ads: Fix typos in comments. + +2008-04-14 Robert Dewar + + * sem_prag.adb (Analyze_Pragma, Linker_Section case): Extend error + to every non-object and change error message. + +2008-04-14 Robert Dewar + + * sem_util.ads, sem_util.adb (In_Subprogram): Remove. + * sem_attr.adb (Anayze_Attribute): Check for Current_Subprogram + directly. + +2008-04-14 Samuel Tardieu + + PR ada/18680 + * sem_prag.adb (Analyze_Pragma, Linker_Section case): Refuse to + apply pragma Linker_Section on type. + +2008-04-14 Samuel Tardieu + + PR ada/16098 + * sem_prag.adb (Error_Pragma_Ref): New. + (Process_Convention): Specialized message for non-local + subprogram renaming. Detect the problem in homonyms as well. + +2008-04-14 Samuel Tardieu + + PR ada/15915 + * sem_util.ads, sem_util.adb (Denotes_Variable): New function. + * sem_ch12.adb (Instantiate_Object): Use it. + * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Ensure that + storage pool denotes a variable as per RM 13.11(15). + +2008-04-14 Samuel Tardieu + + * sem_util.ads, sem_util.adb (In_Subprogram): New function. + * sem_attr.adb (Analyze_Attribute, Attribute_Old case): Use it. + +2008-04-14 Rolf Ebert + + PR ada/20822 + * xgnatugn.adb (Put_Line): New procedure, ensuring Unix + line endings even on non-Unix platforms. + +2008-04-14 Samuel Tardieu + + PR ada/35050 + * xref_lib.adb (Parse_Identifier_Info): Correctly parse and ignore the + renaming information. + +2008-04-13 Samuel Tardieu + + PR ada/17985 + * sem_aggr.adb (Valid_Ancestor_Type): A type is not an ancestor of + itself. + +2008-04-13 Ralf Wildenhues + + * sfn_scan.adb, sfn_scan.ads, sinfo.ads, + sinput-d.ads, sinput-l.adb, sinput-l.ads, sinput.ads, + snames.ads, sprint.adb, stand.ads, stringt.ads, + styleg.adb, styleg.ads, stylesw.adb, stylesw.ads, + switch.ads, sysdep.c, table.adb, table.ads, + targparm.ads, tb-gcc.c, tbuild.ads, tracebak.c, + trans.c, tree_io.adb, treepr.adb, types.adb, types.ads, + uintp.adb, uintp.ads, utils.c, utils2.c, validsw.ads, + vms_conv.adb, vms_conv.ads, vms_data.ads, widechar.adb, + widechar.ads, xeinfo.adb, xgnatugn.adb, xr_tabls.adb, + xr_tabls.ads, xref_lib.adb, xref_lib.ads, xsinfo.adb: + Fix comment typos. + + * sem_ch10.adb, sem_ch10.ads, + sem_ch12.adb, sem_ch12.ads, sem_ch13.adb, sem_ch13.ads, + sem_ch3.adb, sem_ch4.adb, sem_ch5.adb, sem_ch6.adb, + sem_ch6.ads, sem_ch8.adb, sem_ch8.ads, sem_ch9.adb, + sem_elab.adb, sem_elab.ads, sem_elim.ads, sem_eval.adb, + sem_eval.ads, sem_intr.adb, sem_mech.adb, sem_mech.ads, + sem_prag.adb, sem_prag.ads, sem_res.adb, sem_res.ads, + sem_type.adb, sem_util.adb, sem_util.ads, sem_warn.adb, + sem_warn.ads: Fix comment typos. + + * s-secsta.adb, s-sequio.ads, s-shasto.ads, + s-soflin.ads, s-stalib.ads, s-stausa.adb, + s-stausa.ads, s-strxdr.adb, s-taenca.adb, s-taenca.ads, + s-taprob.adb, s-taprop-hpux-dce.adb, s-taprop-irix.adb, + s-taprop-linux.adb, s-taprop-mingw.adb, s-taprop-posix.adb, + s-taprop-solaris.adb, s-taprop-tru64.adb, s-taprop-vms.adb, + s-taprop-vxworks.adb, s-taprop.ads, s-tarest.adb, + s-tarest.ads, s-tasini.adb, s-tasini.ads, s-taskin.ads, + s-tasque.ads, s-tassta.adb, s-tassta.ads, s-tasuti.ads, + s-tpoben.adb, s-tpoben.ads, s-tpobop.adb, + s-tpopsp-posix.adb, s-tpopsp-rtems.adb, s-tposen.adb, + s-tposen.ads, s-traceb-hpux.adb, s-traces.ads, + s-trafor-default.ads, s-unstyp.ads, s-utf_32.ads, + s-vaflop.adb, s-vaflop.ads, s-valrea.adb, s-valuti.adb, + s-wchstw.ads, s-wchwts.adb, s-wchwts.ads, scans.ads, + scn.adb, scng.adb, seh_init.c, sem.ads, sem_aggr.adb, + sem_attr.adb, sem_attr.ads, sem_case.adb, sem_case.ads, + sem_cat.adb, sem_cat.ads: Fix comment typos. + +2008-04-12 Joel Sherrill + + PR ada/35825 + * g-soccon-rtems.ads: Add IP_PKTINFO as unsupported. + +2008-04-12 Arnaud Charlet + + * s-linux-hppa.ads: Fix syntax errors. + +2008-04-10 Ralf Wildenhues + + * gnat_ugn.texi: Fix typos. + * raise-gcc.c, repinfo.adb, repinfo.ads, restrict.adb, + restrict.ads, rtsfind.adb, rtsfind.ads, s-arit64.ads, + s-asthan-vms-alpha.adb, s-auxdec.ads, s-casuti.ads, + s-fatflt.ads, s-fatgen.adb, s-fatlfl.ads, + s-fatllf.ads, s-fatsfl.ads, s-filofl.ads, + s-finimp.adb, s-finroo.ads, s-fishfl.ads, + s-fvadfl.ads, s-fvaffl.ads, s-fvagfl.ads, + s-hibaen.ads, s-htable.ads, s-imgcha.adb, + s-imgenu.ads, s-imgint.adb, s-imgrea.adb, + s-inmaop-dummy.adb, s-inmaop.ads, s-interr-vms.adb, + s-interr-vxworks.adb, s-interr.adb, s-interr.ads, + s-intman-vxworks.ads, s-intman.ads, s-mastop-irix.adb, + s-os_lib.adb, s-os_lib.ads, s-osinte-aix.ads, + s-osinte-darwin.ads, s-osinte-freebsd.ads, + s-osinte-hpux.ads, s-osinte-lynxos-3.adb, + s-osinte-lynxos-3.ads, s-osinte-lynxos.ads, + s-osinte-rtems.ads, s-osinte-solaris-posix.ads, + s-osprim-mingw.adb, s-osprim-vms.adb, s-parame-ae653.ads, + s-parame-hpux.ads, s-parame-vms-alpha.ads, + s-parame-vms-ia64.ads, s-parame-vms-restrict.ads, + s-parame-vxworks.ads, s-parame.ads, s-parint.adb, + s-parint.ads, s-poosiz.adb, s-proinf-irix-athread.ads, + s-proinf.ads, s-regexp.adb, s-regpat.adb, s-regpat.ads, + s-rident.ads: Fix comment typos. + +2008-04-09 Samuel Tardieu + + PR ada/28305 + * sem_ch6.adb (Build_Body_To_Inline): Do not save and restore + environment if generic instance is a top-level one. + +2008-04-09 Doug Rupp + + * decl.c (validate_size): Set minimum size for fat pointers same as + access types. Code clean ups. + + * gmem.c (xstrdup32): New macro for 32bit dup on VMS, noop otherwise + (__gnat_gmem_a2l_initialize): Dup exename into 32 bit memory on VMS + + * s-auxdec-vms_64.ads, s-auxdec.ads (Short_Address_Size): New constant + + * s-crtl.ads (malloc32) New function, alias for malloc + (realloc32) New function, alias for realloc + + * socket.c (__gnat_new_socket_set): Malloc fd_set in 32 bits on VMS + + * utils2.c (build_call_alloc_dealloc): Return call to short malloc if + allocator size is 32 and default pointer size is 64. + (find_common_type): Document assumption on t1/t2 vs lhs/rhs. Force use of + lhs type if smaller, whatever the modes. + + * gigi.h (malloc32_decl): New macro definition + + * utils.c (init_gigi_decls): New malloc32_decl + Various code clean ups. + + * s-asthan-vms-alpha.adb (Process_AST.To_Address): Unchecked convert to + Task_Address vice System.Address. + + * s-taspri-vms.ads: Import System.Aux_DEC + (Task_Address): New subtype of System.Aux_DEC.Short_Address + (Task_Address_Size): New constant size of System.Aux_DEC.Short_Address + + * s-asthan-vms-alpha.adb (Process_AST.To_Address): Unchecked convert to + Task_Address vice System.Address. + + * s-inmaop-vms.adb: Import System.Task_Primitives + (To_Address): Unchecked convert to Task_Address vice System.Address + + * s-taprop-vms.adb (Timed_Delay): Always set the timer even if delay + expires now. + (To_Task_ID) Unchecked convert from Task_Adddress vice System.Address + (To_Address) Unchecked convert to Task_Address vice System.Address + + * s-tpopde-vms.adb: Remove unnecessary warning pragmas + + * g-socthi-vms.ads: Add 32bit size clauses on socket access types. + +2008-04-08 Eric Botcazou + + * gigi.h (standard_datatypes): Add ADT_fdesc_type and ADT_null_fdesc. + (fdesc_type_node): Define. + (null_fdesc_node): Likewise. + * decl.c (gnat_to_gnu_entity) : If the target + uses descriptors for vtables and the type comes from a dispatch table, + return the descriptor type. + * trans.c (Attribute_to_gnu) : If the target + uses descriptors for vtables and the type comes from a dispatch table, + build a descriptor in the static case and copy the existing one in the + non-static case. + (gnat_to_gnu) : If the target uses descriptors for vtables and + the type is a pointer-to-subprogram coming from a dispatch table, + return the null descriptor. + : If the target uses descriptors for + vtables, the source type is the descriptor type and the target type + is a pointer type, first build the pointer. + * utils.c (init_gigi_decls): If the target uses descriptors for vtables + build the descriptor type and the null descriptor. + +2008-04-08 Eric Botcazou + + * decl.c (prepend_attributes): Fix typo. + * trans.c (Pragma_to_gnu): Likewise. + * utils.c (gnat_genericize): Likewise. + +2008-04-08 Eric Botcazou + Richard Kenner + + * ada-tree.h (TYPE_PACKED_ARRAY_TYPE_P): Only set it when bit-packed. + * decl.c (gnat_to_gnu_entity): Adjust for above change. + : Try to get a better form of the component for + packing, even if it has an integral mode. + : Likewise. + * trans.c (gnat_to_gnu): Do not require BLKmode for the special + exception suppressing the final conversion between record types. + +2008-04-08 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : If -gnatd.a and not optimizing + alignment for space, promote the alignment of non-scalar variables with + no size and alignment. + * gigi.h (gnat_types_compatible_p): Declare. + * misc.c (LANG_HOOKS_TYPES_COMPATIBLE_P): Set to above predicate. + * trans.c (gnat_to_gnu): Revert revision 129339 change. Minor cleanup. + * utils.c (gnat_types_compatible_p) : New predicate. + (convert): Use it throughout to test for cases where a mere view + conversion is sufficient. + * utils2.c (build_binary_op): Minor tweaks. + (build_unary_op): Likewise. + +2008-04-08 Eric Botcazou + + * decl.c (adjust_packed): Expand comment. + +2008-04-08 Arnaud Charlet + + * s-tasuti.ads: Use Task_Address instead of System.Address. + + * makeutl.adb (Path_Or_File_Name): New function + + * nlists.ads, itypes.ads: Update comments. + + * s-crtl.ads (malloc32, realloc32): New functions. + + * s-auxdec.ads (Short_Address_Size): New constant. + + * a-taside.adb, s-tasdeb.adb: Use Task_Address. + + * s-ststop.ads, s-ststop.adb: New file. + + * exp_tss.ads, s-taprop-lynxos.adb: Update comments. + Minor reformatting. + +2008-04-08 Pascal Obry + + * g-sercom.ads, g-sercom.adb (Data_Rate): Add B115200. + (Stop_Bits_Number): New type. + (Parity_Check): Likewise. + (Set): Add parameter to set the number of stop bits and + the parity. Parameter timeout is now a duration instead + of a plain integer. + + * g-sercom-linux.adb: + Implement the stop bits and parity support for GNU/Linux. + Fix handling of timeout, it must be given in tenth of seconds. + + * g-sercom-mingw.adb: + Implement the stop bits and parity support for Windows. + Use new s-win32.ads unit instead of declaring Win32 services + directly into this body. + Update handling of timeout as now a duration. + + * s-win32.ads, s-winext.ads: New files. + +2008-04-08 Eric Botcazou + Arnaud Charlet + + * s-osinte-linux-alpha.ads, s-osinte-linux-hppa.ads: Removed. + + s-taspri-posix-noaltstack.ads, s-linux.ads, s-linux-alpha.ads, + s-linux-hppa.ads: New files. Disable alternate stack on ia64-hpux. + + * s-osinte-lynxos-3.ads, + (Alternate_Stack): Remove when not needed. Simplify declaration + otherwise. + (Alternate_Stack_Size): New constant. + + s-osinte-mingw.ads, s-taprop-mingw.adb: Code clean up: avoid use of + 'Unrestricted_Access. + + * s-osinte-hpux.ads, s-osinte-solaris-posix.ads, s-osinte-aix.ads, + s-osinte-lynxos.ads, s-osinte-freebsd.ads s-osinte-darwin.ads, + s-osinte-tru64.ads, s-osinte-irix.ads, s-osinte-linux.ads, + s-osinte-solaris.ads, s-osinte-vms.ads + (SA_ONSTACK): New constant. + (stack_t): New record type. + (sigaltstack): New imported function. + (Alternate_Stack): New imported variable. + (Alternate_Stack_Size): New constant. + + * system-linux-x86_64.ads: (Stack_Check_Probes): Set to True. + + * s-taspri-lynxos.ads, s-taspri-solaris.ads, s-taspri-tru64.ads, + s-taspri-hpux-dce.ads, s-taspri-dummy.ads, s-taspri-posix.ads, + s-taspri-vms.ads (Task_Address): New subtype of System.Address + (Task_Address_Size): New constant size of System.Address + (Alternate_Stack_Size): New constant. + + * s-taprop-posix.adb, s-taprop-linux.adb (Get_Stack_Attributes): Delete. + (Enter_Task): Do not notify stack to System.Stack_Checking.Operations. + Establish the alternate stack if the platform makes use of n alternate + signal stack for stack overflows. + (Create_Task): Take into account the alternate stack in the stack size. + (Initialize): Save the address of the alternate stack into the ATCB for + the environment task. + (Create_Task): Fix assertions for NPTL library (vs old LinuxThreads). + + * s-parame.adb (Minimum_Stack_Size): Increase value to 16K + + * system-linux-x86.ads: (Stack_Check_Probes): Set to True. + + * s-intman-posix.adb: + (Initialize): Set SA_ONSTACK for SIGSEGV if the platform makes use of an + alternate signal stack for stack overflows. + + * init.c (__gnat_adjust_context_for_raise, Linux version): On i386 and + x86-64, adjust the saved value of the stack pointer if the signal was + raised by a stack checking probe. + (HP-UX section): Use global __gnat_alternate_stack as signal handler + stack and only for SIGSEGV. + (Linux section): Likewise on x86 and x86-64. + [VxWorks section] + (__gnat_map_signal): Now static. + (__gnat_error_handler): Not static any more. + (__gnat_adjust_context_for_raise): New function. Signal context + adjustment for PPC && !VTHREADS && !RTP, as required by the zcx + propagation circuitry. + (__gnat_error_handler): Second argument of a sigaction handler is a + pointer, not an int, and is unused. + Adjust signal context before mapping to exception. + Install signal handlers for LynxOS case. + + * s-taskin.ads (Common_ATCB): New field Task_Alternate_Stack. + (Task_Id): Set size to Task_Address_Size + (To_Task_id): Unchecked convert from Task_Address vice System.Address + (To_Address): Unchecked convert to Task_Address vice System.Address + + * s-tassta.adb (Task_Wrapper): Define the alternate stack and save its + address into the ATCB if the platform makes use of an alternate signal + stack for stack overflows. + (Free_Task): Add call to Finalize_Attributes_Link. + Add argument Relative_Deadline to pass the value specified for + the task. This is not yet used for any target. + + * s-tassta.ads (Create_Task): Add argument Relative_Deadline to pass + the value specified for the task. + +2008-04-08 Arnaud Charlet + + (s-osinte-vxworks6.ads): Removed, merged with s-osinte-vxworks.ads/.adb + (s-vxwext.ads, s-vxwext-kernel.ads, s-vxwext-rtp.ads, + s-vxwext-rtp.adb): New files. + + * s-taprop-vxworks.adb, s-osinte-vxworks.ads, s-osinte-vxworks.adb: + Minor updates to accomodate changes above. + +2008-04-08 Pascal Obry + + * a-exetim-mingw.adb, s-gloloc-mingw.adb, s-taprop-mingw.adb, + s-tasinf-mingw.ad{s,b}, s-taspri-mingw.ads: + Use new s-win32.ads unit instead of declaration + from s-osinte-mingw.ads. + + * s-osinte-mingw.ads: + Move all non tasking based interface to s-win32.ads. + + * s-osprim-mingw.adb: + Remove duplicated declarations and use s-win32.ads + unit instead. + +2008-04-08 Vincent Celier + Arnaud Charlet + + * mlib-tgt-aix.adb, mlib-tgt-darwin.adb, mlib-tgt-hpux.adb, + mlib-tgt-irix.adb, mlib-tgt-linux.adb, mlib-tgt-lynxos.adb, + mlib-tgt-solaris.adb, mlib-tgt-tru64.adb, mlib-tgt-vms.adb, + mlib-tgt-vms.ads, mlib-tgt-vms-alpha.adb, mlib-tgt-vms-ia64.adb, + mlib-tgt-vxworks.adb, mlib-tgt-mingw.adb: Renamed into... + + * mlib-tgt-specific-aix.adb, mlib-tgt-specific-darwin.adb, + mlib-tgt-specific-hpux.adb, mlib-tgt-specific-irix.adb, + mlib-tgt-specific-linux.adb, mlib-tgt-specific-lynxos.adb, + mlib-tgt-specific-solaris.adb, mlib-tgt-specific-tru64.adb, + mlib-tgt-vms_common.adb, mlib-tgt-vms_common.ads, + mlib-tgt-specific-vms-alpha.adb, mlib-tgt-specific-vms-ia64.adb, + mlib-tgt-specific-vxworks.adb, mlib-tgt-specific-xi.adb, + mlib-tgt-specific-mingw.adb: New names. + + * Makefile.in: + On VxWorks platforms use s-stchop-limit.ads for s-stchop.ads + Get rid of gnatbl. + (EXTRA_GNATRTL_NONTASKING_OBJS): Add s-win32.o + Files mlib-tgt-*.adb have been renamed mlib-tgt-specific-*.adb + Minor updates for VMS + + * gnatbl.c: Removed. + +2008-04-08 Thomas Quinot + + * g-expect-vms.adb, a-textio.adb, a-witeio.adb, exp_dbug.adb, + g-expect.adb, g-locfil.adb, gnatchop.adb, gnatdll.adb, gnatlbr.adb, + gnatmem.adb, g-regist.adb, i-vxwork.ads, mlib-utl.adb, i-vxwork-x86.ads, + a-ztexio.adb, g-enblsp-vms-alpha.adb, g-enblsp-vms-ia64.adb, + s-os_lib.adb, s-regpat.adb, s-regpat.ads: Fix incorrect casing of + ASCII.NUL throughout. + +2008-04-08 Arnaud Charlet + Matthew Heaney + + * a-cgcaso.adb, a-convec.adb: (Swap, Sift): Avoid use of complex + renaming. + + * a-cgaaso.ads, a-secain.ads, a-slcain.ads, a-shcain.ads, + a-crdlli.ads, a-coormu.ads, a-ciormu.ads: modified header to conform + to convention for non-RM specs. + Add descriptive header, and documented each operation + document each operation + +2008-04-08 Robert Dewar + Bob Duff + Gary Dismukes + Ed Schonberg + + * alloc.ads: Add entries for Obsolescent_Warnings table + + * einfo.ads, einfo.adb: Minor reformatting. + (Is_Discriminal): New subprogram. + (Is_Prival): New subprogram. + (Is_Protected_Component): New subprogram. + (Is_Protected_Private): Removed. + (Object_Ref, Set_Object_Ref): Removed. + (Prival, Set_Prival): Change assertion. + (Privals_Chain, Set_Privals_Chain): Removed. + (Prival_Link, Set_Prival_Link): New subprogram. + (Protected_Operation, Set_Protected_Operation): Removed. + (Protection_Object, Set_Protection_Object): New subprogram. + (Write_Field17_Name): Remove case for Object_Ref. + (Write_Field20_Name): Add case for Prival_Link. + (Write_Field22_Name): Remove case for Protected_Operation, + Privals_Chain. + Add case for Protection_Object. + (Can_Use_Internal_Rep): Make this into a [base type only] attribute, + so clients + (Overlays_Constant): New flag + (Is_Constant_Object): New predicate + (Is_Standard_Character_Type): New predicate + (Optimize_Alignment_Space): New flag + (Optimize_Alignment_Time): New flag + (Has_Postconditions): New flag + (Obsolescent_Warrning): Field removed + (Spec_PPC_List): New field + (Relative_Deadline_Variable, Set_Relative_Deadline_Variable): Add + subprograms to get and set the relative deadline associated to a task. + + * exp_attr.adb (May_Be_External_Call): Account for the case where the + Access attribute is part of a named parameter association. + (Expand_Access_To_Protected_Op): Test for the attribute occurring + within an init proc and use that directly as the scope rather than + traversing up to the protected operation's enclosing scope. Only apply + assertion on Is_Open_Scopes in the case the scope traversal is done. + For the init proc case use the address of the first formal (_init) as + the protected object reference. + Implement Invalid_Value attribute + (Expand_N_Attribute_Reference): Case Attribute_Unrestricted_Access. + contents of the dispatch table there is no need to duplicate the + itypes associated with record types (i.e. the implicit full view + of private types). + Implement Enum_Val attribute + (Expand_N_Attribute_Reference, case Old): Properly handle appearence + within _Postconditions procedure + (Expand_N_Attribute_Reference, case Result): Implement new attribute + + * exp_ch5.adb (Expand_N_Simple_Return_Statement): Handle case in which + a return statement calls a function that is not available in + configurable runtime. + (Analyze_If_Statement): don't optimize simple True/False cases in -O0 + (Expand_Non_Function_Return): Generate call to _Postconditions proc + (Expand_Simple_Function_Return): Ditto + + * frontend.adb: Add call to Sem_Aux.Initialize + + * sem_aux.ads, sem_aux.adb: New file. + + * par-prag.adb: Add entries for pragmas Precondition/Postcondition + Add new Pragma_Relative_Deadline. + Add support for pragmas Check and Check_Policy + + * sem_attr.ads, sem_attr.adb (Check_Not_CPP_Type): New subprogram. + (Check_Stream_Attribute): Add missing check (not allowed in CPP types) + (Analyze_Attribute): In case of attributes 'Alignment and 'size add + missing check because they are not allowed in CPP tagged types. + Add Sure parameter to Note_Possible_Modification calls + Add implementation of Invalid_Value attribute + Implement new attribute Has_Tagged_Values + Implement Enum_Val attribute + (Analyze_Attribute, case Range): Set Name_Req True for prefix of + generated attributes. + (Analyze_Attribute, case Result): If prefix of the attribute is + overloaded, it always resolves to the enclosing function. + (Analyze_Attribute, case Result): Properly deal with analysis when + Postconditions are not active. + (Resolve_Attribute, case Result): Properly deal with appearence during + preanalysis in spec. + Add processing for attribute Result + + * sem_ch6.ads, sem_ch6.adb (Check_Overriding_Indicator): Code cleanup + for operators. + (Analyze_Subprogram_Body): Install private_with_clauses when the body + acts as a spec. + (Check_Inline_Pragma): recognize an inline pragma that appears within + the subprogram body to which it applies. + (Analyze_Function_Return): Check that type of the expression of a return + statement in a function with a class-wide result is not declared at a + deeper level than the function. + (Process_PPCs): Deal with enabling/disabling, using PPC_Enabled flag + (Verify_Overriding_Indicator): Handle properly subprogram bodies for + user- defined operators. + (Install_Formals): Moved to spec to allow use from Sem_Prag for + analysis of precondition/postcondition pragmas. + (Analyze_Subprogram_Body.Last_Real_Spec_Entity): New name for + Last_Formal, along with lots of comments on what this is about + (Analyze_Subprogram_Body): Fix case where we move entities from the + spec to the body when there are no body entities (now possible with + precondition and postcondition pragmas). + (Process_PPCs): New procedure + (Analyze_Subprogram_Body): Add call to Process_PPCs + + * sem_ch8.adb (Use_One_Type): refine warning on a redundant use_type + clause. + (Pop_Scope): Restore Check_Policy_List on scope exit + (Push_Scope): Save Check_Policy_List on scope entry + Change name In_Default_Expression => In_Spec_Expression + Change name Analyze_Per_Use_Expression => Preanalyze_Spec_Expression + Change name Pre_Analyze_And_Resolve => Preanalyze_And_Resolve + (Analyze_Object_Renaming): Allow 'Reference as object + (Analyze_Pragma, case Restriction_Warnings): Call GNAT_Pragma + (Process_Restrictions_Or_Restriction_Warnings): Check for bad spelling + of restriction identifier. + Add Sure parameter to Note_Possible_Modication calls + + * sem_prag.ads, sem_prag.adb (Analyze_Pragma, case Stream_Convert): + Don't check for primitive operations when calling Rep_Item_Too_Late. + (Process_Import_Or_Interface): Do not place flag on formal + subprograms. + (Analyze_Pragma, case Export): If the entity is a deferred constant, + propagate information to full view, which is the one elaborated by the + back-end. + (Make_Inline): the pragma is effective if it applies to an internally + generated subprogram declaration for a body that carries the pragma. + (Analyze_Pragma, case Optimize_Alignment): Set new flag + Optimize_Alignment_Local. + (Analyze_PPC_In_Decl_Part): New procedure + (Get_Pragma_Arg): Moved to outer level + (Check_Precondition_Postcondition): Change to allow new visibility + rules for package spec + (Analyze_Pragma, case Check_Policy): Change placement rules to be + same as pragma Suppress/Unsuppress. + Change name In_Default_Expression => In_Spec_Expression + Change name Analyze_Per_Use_Expression => Preanalyze_Spec_Expression + Change name Pre_Analyze_And_Resolve => Preanalyze_And_Resolve + (Check_Precondition_Postcondition): Do proper visibility preanalysis + for the case of these pragmas appearing in the spec. + (Check_Enabled): New function + (Initialize): New procedure + (Tree_Read): New procedure + (Tree_Write): New procedure + (Check_Precondition_Postcondition): New procedure + Implement pragmas Check and Check_Policy + Merge Assert processing with Check + + * sem_warn.adb (Warn_On_Known_Condition): Handle pragma Check + New warning flag -gnatw.e + + * sinfo.ads, sinfo.adb (Has_Relative_Deadline_Pragma): New function + returning whether a task (or main procedure) has a pragma + Relative_Deadline. + (Set_Has_Relative_Deadline_Pragma): Procedure to indicate that a task + (or main procedure) has a pragma Relative_Deadline. + Add Next_Pragma field to N_Pragma node + (PPC_Enabled): New flag + (Next_Pragma): Now used for Pre/Postcondition processing + + * snames.h, snames.ads, snames.adb: New standard name + Inherit_Source_Path + Add entry for 'Invalid_Value attribute + Add entry for new attribute Has_Tagged_Values + Add entry for Enum_Val attribute + Add new standard names Aggregate, Configuration and Library. + Add _Postconditions + Add _Result + Add Pragma_Precondition + Add Pragma_Postcondition + Add Attribute_Result + New standard name Archive_Builder_Append_Option + (Preset_Names): Add _relative_deadline and relative_deadline definitions + There was also a missing non_preemptive_within_priorities. + (Get_Pragma_Id, Is_Pragma_Name): Add support for pragma + Relative_Deadline. + Add support for pragmas Check and Check_Policy + + * tree_gen.adb: Call Sem_Aux.Tree_Write + + * tree_in.adb: Call Sem_Aux.Tree_Read + + * exp_ch11.adb (Expand_N_Raise_Statement): New Build_Location calling + sequence + + * exp_intr.adb (Expand_Source_Info): New Build_Location calling + sequence + + * exp_prag.adb (Expand_Pragma_Relative_Deadline): New procedure. + (Expand_N_Pragma): Call the appropriate procedure for expanding pragma + Relative_Deadline. + (Expand_Pragma_Check): New procedure + + * sinput.ads, sinput.adb (Build_Location_String): Now appends to name + buffer. + + * sinfo.adb (PPC_Enabled): New flag + +2008-04-08 Robert Dewar + Gary Dismukes + Javier Miranda + Ed Schonberg + + * fe.h: Remove global Optimize_Alignment flag, no longer used + + * layout.adb: Test Optimize_Alignment flags rather than global switch + + * lib.ads, lib.adb: New OA_Setting field in library record + + * lib-load.adb: New OA_Setting field in library record + + * lib-writ.ads, lib-writ.adb (Collect_Withs, Write_With_Lines): Place + units mentioned in limited_with_ clauses in the ali file, with an + 'Y' marker. + New Ox fields in U line + + * opt.adb: New flag Optimize_Alignment_Local + (Check_Policy_List[_Config]): New flags + + * opt.ads (Invalid_Value_Used): New flag + New switch Optimize_Alignment_Local + (Warn_On_Parameter_Order): New flag + (Check_Policy_List[_Config]): New flags + + * ali.ads, ali.adb: Add indicator 'Y' to mark mark the presence of + limited_with clauses. + New data structures for Optimize_Alignment + + * bcheck.adb (Check_Consistent_Restriction_No_Default_Initialization): + New procedure + (Check_Consistent_Optimize_Alignment): Rework for new structure + (Check_Consistent_Restrictions): Fix incorrect error message + + sem_ch10.adb (Decorate_Tagged_Type): Set the Parent field of a newly + created class-wide type (to the Parent field of the specific type). + (Install_Siblings): Handle properly private_with_clauses on subprogram + bodies and on generic units. + (Analyze_With_Clause, Install_Limited_Withed_Unit): Guard against an + illegal limited_with_clause that names a non-existent package. + (Check_Body_Required): Determine whether a unit named a limited_with + clause needs a body. + (Analyze_Context): A limited_with_clause is illegal on a unit_renaming. + Capture Optimize_Alignment settings to set new OA_Setting field in + library record. + (Build_Limited_Views): Include task and protected type declarations. + + * sem_ch3.ads, sem_ch3.adb (Analyze_Object_Declaration): Handle the + case of a possible constant redeclaration where the current object is + an entry index constant. + (Analyze_Object_Declaration): Generate an error in case of CPP + class-wide object initialization. + (Analyze_Object_Declaration): Add extra information on warnings for + declaration of unconstrained objects. + (Access_Type_Declaration): Set Associated_Final_Chain to Empty, to avoid + conflicts with the setting of Stored_Constraint in the case where the + access type entity has already been created as an E_Incomplete_Type due + to a limited with clause. + Use new Is_Standard_Character_Type predicate + (Analyze_Object_Declaration): Apply access_constant check only after + expression has been resolved, given that it may be overloaded with + several access types. + (Constant_Redeclaration): Additional legality checks for deferred + constant declarations tha involve anonymous access types and/or null + exclusion indicators. + (Analyze_Type_Declaration): Set Optimize_Alignment flags + (Analyze_Subtype_Declaration): Ditto + (Analyze_Object_Declaration): Ditto + (Analyze_Object_Declaration): Don't count tasks in generics + Change name In_Default_Expression => In_Spec_Expression + Change name Analyze_Per_Use_Expression => Preanalyze_Spec_Expression + Change name Pre_Analyze_And_Resolve => Preanalyze_And_Resolve + (Process_Discriminants): Additional check for illegal use of default + expressions in access discriminant specifications in a type that is not + explicitly limited. + (Check_Abstract_Overriding): If an inherited function dispaches on an + access result, it must be overridden, even if the type is a null + extension. + (Derive_Subprogram): The formals of the derived subprogram have the + names and defaults of the parent subprogram, even if the type is + obtained from the actual subprogram. + (Derive_Subprogram): In the presence of interfaces, a formal of an + inherited operation has the derived type not only if it descends from + the type of the formal of the parent operation, but also if it + implements it. This is relevant for the renamings created for the + primitive operations of the actual for a formal derived type. + (Is_Progenitor): New predicate, to determine whether the type of a + formal in the parent operation must be replaced by the derived type. + + * sem_util.ads, sem_util.adb (Has_Overriding_Initialize): Make + predicate recursive to handle components that have a user-defined + Initialize procedure. Handle controlled derived types whose ancestor + has a user-defined Initialize procedured. + (Note_Possible_Modification): Add Sure parameter, generate warning if + sure modification of constant + Use new Is_Standard_Character_Type predicate + (Find_Parameter_Type): when determining whether a protected operation + implements an interface operation, retrieve the type of the formal from + the entity when the formal is an access parameter or an + anonymous-access-to-subprogram. + Move Copy_Parameter_List to sem_util, for use when building stubbed + subprogram bodies. + (Has_Access_Values): Tagged types now return False + (Within_HSS_Or_If): New procedure + (Set_Optimize_Alignment_Flags): New procedure + Change name In_Default_Expression => In_Spec_Expression + Change name Analyze_Per_Use_Expression => Preanalyze_Spec_Expression + Change name Pre_Analyze_And_Resolve => Preanalyze_And_Resolve + +2008-04-08 Tristan Gingold + + * s-fileio.adb: Name_Error shouldn't be raised for a tempory file. + +2008-04-08 Tristan Gingold + +PR ada/10768 + + * cuintp.c: Fix 16 bits issue for AVR. + On AVR, integer is 16 bits, so it can't be used to do math with + Base (=32768). + So use long_integer instead. + +2008-04-08 Hristian Kirtchev + + * a-calend-vms.ads, a-calend-vms.adb: Add with and use clause for + System.OS_Primitives. + Change type of various constants, parameters and local variables from + Time to representation type OS_Time. + (To_Ada_Time, To_Unix_Time): Correct sign of origin shift. + Remove the declaration of constant Mili_F from several routines. New + body for internal package Conversions_Operations. + (Time_Of): Add default parameters for several formals. + + * a-caldel.adb: Minor reformatting + + * a-calend.ads, a-calend.adb: New body for internal package + Conversions_Operations. + (Time_Of): Add default parameters for several formals. + + * Makefile.rtl: Add a-ststop + Add Ada.Calendar.Conversions to the list of runtime files. + Add g-timsta + + * a-calcon.adb, a-calcon.ads: New files. + +2008-04-08 Jose Ruiz + Tristan Gingold + + * s-interr-dummy.adb, s-interr-vms.adb, s-interr-sigaction.adb + (Install_Restricted_Handlers): New procedure + which is a simplified version of Install_Handlers that does not store + previously installed. + + * s-interr-vxworks.adb: Fix ACATS cxc3001 + On VxWorks interrupts can't be detached. + (Install_Restricted_Handlers): New procedure. + + * s-interr.ads, s-interr.adb (Install_Restricted_Handlers): New + procedure. + +2008-04-08 Olivier Hainque + + * s-intman-vxworks.ads, s-intman-vxworks.adb + (Map_And_Raise_Exception): Remove. Was an import of only part of the + required services already implemented elsewhere. + (Notify_Exception): Delete body, import __gnat_error_handler instead. + (Initialize): Add SA_SIGINFO to the sa_flags, to get the sigcontext + argument passed to the handler, which we need for ZCX propagation + purposes. + +2008-04-08 Hristian Kirtchev + + * adaint.h, adaint.c (__gnat_current_time_string): New routine. + + * g-timsta.adb, g-timsta.ads: New files. + +2008-04-08 Robert Dewar + + * a-except-2005.ads, a-except-2005.adb, a-except.ads, a-except.adb + (Raise_Exception): In accordance with AI-446, raise CE for Null_Id + (Raise_Exception_Always): Fix documentation accordingly + +2008-04-08 Robert Dewar + + * a-strbou.ads, a-strbou.adb (From_String): New procedure (for use by + Stream_Convert) + + * sem_ch13.ads (Rep_Item_Too_Late): Document that Stream_Convert sets + FOnly + +2008-04-08 Javier Miranda + Robert Dewar + Ed Schonberg + + * a-tags.adb (Register_Interface_Offset): New subprogram. + (Set_Dynamic_Offset_To_Top): New subprogram (see previous comment). + (To_Predef_Prims_Table_Ptr): Removed. + (Acc_Size): Removed. + (To_Acc_Size): Removed. + (Parent_Size): Modified to the call the subprogram returning the size of + the parent by means of the new TSD component Size_Func. + + * a-tags.ads (Offset_To_Top_Ptr): New access type declaration. + (DT_Offset_To_Top_Offset): New constant value that is used to generate + code referencing the Offset_To_Top component of the dispatch table's + prologue. + (Prim_Ptr): New declaration of access to procedure. Used to avoid the + use of 'address to initialize dispatch table slots. + (Size_Func): New component of the TSD. Used by the run-time to call the + size primitive of the tagged type. + + * checks.adb (Apply_Access_Check): Avoid check when accessing the + Offset_To_Top component of a dispatch table. + (Null_Exclusion_Static_Checks): If the non-null access type appears in a + deferred constant declaration. do not add a null expression, to prevent + spurious errors when full declaration is analyzed. + (Apply_Discriminant_Check): If both discriminant constraints share a + node which is not static but has no side effects, do not generate a + check for that discriminant. + (Generate_Index_Checks): Set Name_Req to true in call to duplicate + subexpr, since the prefix of an attribute is a name. + + * checks.ads: Fix nit in comment. + + * exp_ch3.ads, exp_ch3.adb (Freeze_Record_Type): Do not add the spec + and body of predefined primitives in case of CPP tagged type + derivations. + (Freeze_Type): Deal properly with no storage pool case + (Make_Predefined_Primitive_Specs): Generate specification of abstract + primitive Deep_Adjust if a nonlimited interface is derived from a + limited interface. + (Build_Dcheck_Functions): Create discriminant-checking functions only + for variants that have some component(s). + (Build_Slice_Assignment): In expanded code for slice assignment, handle + properly the case where the slice bounds extend to the last value of the + underlying representation. + (Get_Simple_Init_Val): New calling sequence, accomodate Invalid_Value + (Is_Variable_Size_Record): An array component has a static size if + index bounds are enumeration literals. + + * exp_disp.adb (Make_DT): Use the first subtype to determine whether + an external tag has been specified for the type. + (Building_Static_DT): Add missing support for private types. + (Make_DT): Add declaration of Parent_Typ to ensure consistent access + to the entity associated with the parent of Typ. This is done to + avoid wrong access when the parent is a private type. + (Expand_Interface_Conversion): Improve error message when the + configurable runtime has no support for dynamic interface conversion. + (Expand_Interface_Thunk): Add missing support to interface types in + configurable runtime. + (Expand_Dispatching_Call): remove obsolete code. + (Make_DT): Replace occurrences of RE_Address by RE_Prim_Ptr, and + ensure that all subtypes and aggregates associated with dispatch + tables have the attribute Is_Dispatch_Table_Entity set to true. + (Register_Primitive): Rename one variable to improve code reading. + Replace occurrences of RE_Addres by RE_Prim_Ptr. Register copy o + of the pointer to the 'size primitive in the TSD. + + * rtsfind.ads (RE_DT_Offset_To_Top_Offset): New entity. + (RE_Offset_To_Top_Ptr): New entity. + (RE_Register_Interface_Offset): New entity. + (RE_Set_Dynamic_Offset_To_Top): New entity. + (RE_Set_Offset_To_Top): Removed entity. + (RE_Prim_Ptr): New entity + (RE_Size_Func): New entity + (RE_Size_Ptr): New entity + (RTU_Id): Add Ada_Dispatching and Ada_Dispatching_EDF. + (Ada_Dispatching_Child): Define this new subrange. + (RE_Id): Add new required run-time calls (RE_Set_Deadline, RE_Clock, + RE_Time_Span, and RE_Time_Span_Zero). + (RE_Unit_Table): Add new required run-time calls + + * rtsfind.adb (Get_Unit_Name): Add processing for Ada.Dispatching + children. + + * exp_atag.ads, exp_atag.adb (Build_Offset_To_Top): New subprogram. + (Build_Set_Static_Offset_To_Top): New subprogram. Generates code that + initializes the Offset_To_Top component of a dispatch table. + (Build_Predef_Prims): Removed. + (Build_Get_Predefined_Prim_Op_Address): Replace call to Predef_Prims by + its actual code. + (Build_Set_Size_Function): New subprogram. + + * exp_ch13.adb: Do not generate storage variable for storage_size zero + (Expand): Handle setting/restoring flag Inside_Freezing_Actions + +2008-04-08 Robert Dewar + + * a-ztdeau.adb, a-tideau.adb, a-wtdeau.adb (Puts_Dec): Fix error in + computing Fore when Exp > 0 + +2008-04-08 Robert Dewar + + * back_end.adb: Remove Big_String_Ptr declarations (now in Types) + + * errout.adb: Remove Big_String_Ptr declarations (now in Types) + Change name Is_Style_Msg to Is_Style_Or_Info_Msg + + * fmap.adb: Remove Big_String declarations (now in Types) + (No_Mapping_File): New Boolean global variable + (Initialize): When mapping file cannot be read, set No_Mapping_File to + False. + (Update_Mapping_File): Do nothing if No_Mapping_File is True. If the + tables were empty before adding entries, open the mapping file + with Truncate = True, instead of delete/re-create. + + * fname-sf.adb: Remove Big_String declarations (now in Types) + + * s-strcom.adb, g-dyntab.ads, g-table.ads, s-carsi8.adb, + s-stalib.ads, s-carun8.adb: Add zero size Storage_Size clauses for + big pointer types + + * table.ads: Add for Table_Ptr'Storage_Size use 0 + + * types.ads: Add Big_String declarations + Add Size_Clause of zero for big pointer types + +2008-04-08 Vincent Celier + + * clean.adb (Parse_Cmd_Line): Recognize switch --subdirs= + (Usage): Add line for switch --subdirs= + Add new switch -eL, to follow symbolic links when processing project + files. + + * gnatcmd.adb: Process switches -eL and --subdirs= + (Non_VMS_Usage): Output "gnaampcmd" instead of "gnat", and call + Program_Name to get proper tool names when AAMP_On_Target is set. + (Gnatcmd): Call Add_Default_Search_Dirs and Get_Target_Parameters to get + AAMP_On_Target set properly for use of GNAAMP tools (this is needed by + Osint.Program_Name). + + * gnatname.adb: (Scan_Args): Recognize switches -eL and --subdirs= + (Usage): Add lines for switches -eL and --subdirs= + + * makeusg.adb: Add line for switch --subdirs= + + * prj.ads: + (Source_Data): New Boolean component Compiled, defaulted to True + (Empty_File_Name: New global variable in private part, initialized in + procedure Initialize. + (Subdirs_Option): New constant string + (Subdirs): New String_Ptr global variable + (Language_Config): New component Include_Compatible_Languages + (Project_Qualifier): New type for project qualifiers + (Project_Data): New component Qualifier + (Project_Configuration): New component Archive_Builder_Append_Option + + * prj-nmsc.adb (Get_Unit_Exceptions): When a unit is already in + another imported project indicate the name of this imported project. + (Check_File): When a unit is in two project files, indicate the project + names and the paths of the source files for each project. + (Add_Source): Set Compiled to False if compiler driver is empty. Only + set object, dependency and switches file names if Compiled is True. + (Process_Compiler): Allow the empty string for value of attribute Driver + (Get_Directories): When Subdirs is not null and Object_Dir is not + specified, locate and create if necessary the actual object dir. + (Locate_Directory): When Subdirs is not empty and Create is not the + empty string, locate and create if necessary the actual directory + as a subdirectory of directory Name. + (Check_Library_Attributes.Check_Library): Allow a project where the only + "sources" are header files of file based languages to be imported by + library projects, in multi-language mode (gprbuild). + (Check_Library_Attributes.Check_Library): In multi-language mode + (gprbuild), allow a library project to import a project with no + sources, even when this is not declared explicitly. + (Check_If_Externally_Built): A virtual project extending an externally + built project is also externally built. + (Check_Library_Attributes): For a virtual project extending a library + project, inherit the library directory. + (Process_Project_Level_Array_Attributes): Process new attribute + Inherit_Source_Path. + For projects with specified qualifiers "standard", "library" or + "abstract", check that the project conforms to the qualifier. + (Process_Project_Level_Simple_Attributes): Process new attribute + Archive_Builder_Append_Option. + + * switch-m.adb: (Scan_Make_Switches): Process switch --subdirs= + (Normalize_Compiler_Switches): Only keep compiler switches that are + passed to gnat1 by the gcc driver and that are stored in the ALI file + by gnat1. + Do not take into account switc -save-temps + + * makegpr.adb (Compile_Link_With_Gnatmake): Transmit switch -eL if + gprmake is called with -eL. + (Scan_Arg): Recognize switch -eL + (Usage): Add line for switch -eL + + * prj.adb (Initialize): Initialize Empty_File_Name + (Project_Empty): New component Qualifier + + * prj-attr.ads, prj-attr.adb: New project level attribute + Inherit_Source_Path. + New project level attribute Archive_Builder_Append_Option + + * prj-dect.adb: Replace System.Strings by GNAT.Strings. + + * prj-ext.adb (Initialize_Project_Path): In Multi_Language mode, add + /lib/gnat in the project path, after /share/gpr, for + upward compatibility. + + * prj-part.adb (Project_Path_Name_Of.Try_Path): In high verbosity, put + each Trying ..." on different lines. + (Parse_Single_Project): Recognize project qualifiers. Fail in qualifier + is "configuration" when not in configuration. Fail when in configuration + when a specified qualifier is other than "configuration". + + * prj-proc.adb (Process_Declarative_Items): Link new elements of copied + full associative array together. + (Recursive_Process): Put the project qualifier in the project data + + * prj-tree.ads, prj-tree.adb: (Project_Qualifier_Of): New function + (Set_Project_Qualifier_Of): New procedure + +2008-04-08 Robert Dewar + + * errout.ads: Update comments for new handling of info: messages + + * erroutc.adb (Matches): New procedure + (Warning_Specifically_Suppressed): Modified to handle multiple * chars + (Is_Style_Or_Info_Msg): New name for Is_Style_Msg, now set for + info messages as well as style messages. + + * erroutc.ads: Remove unneeded fields from Specific_Warning_Entry + + * sem_elab.adb (Supply_Bodies): Create actual bodies for stubbed + subprograms. + (Check_A_Call): Special "info: " warnings now have ? in the text + (Elab_Warning): Use info message in static case + +2008-04-08 Ed Schonberg + + * exp_aggr.adb (Static_Array_Aggregate): Use Max_Aggr_Size to determine + whether an array aggregate with static bounds and scalar components + should be expanded into a static constant. + +2008-04-08 Gary Dismukes + Ed Schonberg + Robert Dewar + + * sem_cat.adb (Validate_RCI_Subprogram_Declaration): Add tests of + Has_Stream_Attribute_ Definition when checking for available stream + attributes on parameters of a limited type in Ada 2005. Necessary for + proper recognition of visible stream attribute clauses. + (Has_Stream_Attribute_Definition): If the type is derived from a + private type, then use the derived type's underlying type for checking + whether it has stream attributes. + (Validate_Object_Declaration): The check for a user-defined Initialize + procedure applies also to types with controlled components or a + controlled ancestor. + Reject an object declaration in a preelaborated unit if the type is a + controlled type with an overriding Initialize procedure. + (Validate_Remote_Access_To_Class_Wide_Type): Return without further + checking when the parent of a dereference is a selected component and + the name has not been analyzed. + + * sem_ch4.adb (Analyze_Selected_Component): Add checking for selected + prefixes that are invalid explicit dereferences of remote + access-to-class-wide values, first checking whether the selected + component is a prefixed form of call to a tagged operation. + (Analyze_Call): Remove code that issues an error for limited function + calls in illegal contexts, as we now support all of the contexts that + were forbidden here. + Allow a function call that returns a task.and appears as the + prefix of a selected component. + (Analyze_Reference): Give error message if we try to make a 'Reference + for an object that is atomic/aliased without its type having the + corresponding attribute. + (Analyze_Call): Remove condition checking for attributes to allow + calls to functions with inherently limited results as prefixes of + attributes. Remove related comment about Class attributes. + (Analyze_Selected_Component): If the prefix is a remote type, check + whether this is a prefixed call before reporting an error. + (Complete_Object_Operation): If the controlling formal is an access to + variable reject an actual that is a constant or an access to one. + (Try_Object_Operation): If prefix is a tagged protected object,retrieve + primitive operations from base type. + + * exp_ch4.adb (Expand_N_Indexed_Component): Test for prefix that is a + build-in-place + function call and call Make_Build_In_Place_Call_In_Anonymous_Context. + (Expand_N_Selected_Component): Test for prefix that is a build-in-place + function call and call Make_Build_In_Place_Call_In_Anonymous_Context. + (Expand_N_Slice): Test for prefix that is a build-in-place function call + and call Make_Build_In_Place_Call_In_Anonymous_Context. + (Analyze_Call): Remove code that issues an error for limited function + calls in illegal contexts, as we now support all of the contexts that + were forbidden here. + New calling sequence for Get_Simple_Init_Val + (Expand_Boolean_Operator): Add call to Silly_Boolean_Array_Xor_Test + (Expand_N_Op_Not): Add call to Silly_Boolan_Array_Not_Test + +2008-04-08 Hristian Kirtchev + Ed Schonberg + Robert Dewar + + * exp_ch2.adb: Minor reformatting. + (Expand_Entry_Index_Parameter): Set the type of the identifier. + (Expand_Entry_Reference): Add call to Expand_Protected_Component. + (Expand_Protected_Component): New routine. + (Expand_Protected_Private): Removed. + Add Sure parameter to Note_Possible_Modification calls + + * sem_ch12.ads, sem_ch12.adb (Analyze_Subprogram_Instantiation): The + generated subprogram declaration must inherit the overriding indicator + from the instantiation node. + (Validate_Access_Type_Instance): If the designated type of the actual is + a limited view, use the available view in all cases, not only if the + type is an incomplete type. + (Instantiate_Object): Actual is illegal if the formal is null-excluding + and the actual subtype does not exclude null. + (Process_Default): Handle properly abstract formal subprograms. + (Check_Formal_Package_Instance): Handle properly defaulted formal + subprograms in a partially parameterized formal package. + Add Sure parameter to Note_Possible_Modification calls + (Validate_Derived_Type_Instance): if the formal is non-limited, the + actual cannot be limited. + (Collect_Previous_Instances): Generate instance bodies for subprograms + as well. + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause, case Small): Don't + try to set RM_Size. + Add Sure parameter to Note_Possible_Modification calls + (Analyze_At_Clause): Preserve Comes_From_Source on Rewrite call + (Analyze_Attribute_Definition_Clause, case Attribute_Address): Check for + constant overlaid by variable and issue warning. + Use new Is_Standard_Character_Type predicate + (Analyze_Record_Representation_Clause): Check that the specified + Last_Bit is not less than First_Bit - 1. + (Analyze_Attribute_Definition_Clause, case Address): Check for + self-referential address clause + + * sem_ch5.ads, sem_ch5.adb (Diagnose_Non_Variable_Lhs): Rewrite the + detection mechanism when the lhs is a prival. + (Analyze_Assignment): Call Check_Unprotected_Access to detect + assignment of a pointer to protected data, to an object declared + outside of the protected object. + (Analyze_Loop_Statement): Check for unreachable code after loop + Add Sure parameter to Note_Possible_Modication calls + Protect analysis from previous syntax error such as a scope mismatch + or a missing begin. + (Analyze_Assignment_Statement): The assignment is illegal if the + left-hand is an interface. + + * sem_res.ads, sem_res.adb (Resolve_Arithmetic_Op): For mod/rem check + violation of restriction No_Implicit_Conditionals + Add Sure parameter to Note_Possible_Modication calls + Use new Is_Standard_Character_Type predicate + (Make_Call_Into_Operator): Preserve Comes_From_Source when rewriting + call as operator. Fixes problems (e.g. validity checking) which + come from the result looking as though it does not come from source). + (Resolve_Call): Check case of name in named parameter if style checks + are enabled. + (Resolve_Call): Exclude calls to Current_Task as entry formal defaults + from the checking that such calls should not occur from an entry body. + (Resolve_Call): If the return type of an Inline_Always function + requires the secondary stack, create a transient scope for the call + if the body of the function is not available for inlining. + (Resolve_Actuals): Apply Ada2005 checks to view conversions of arrays + that are actuals for in-out formals. + (Try_Object_Operation): If prefix is a tagged protected object,retrieve + primitive operations from base type. + (Analyze_Selected_Component): If the context is a call to a protected + operation the parent may be an indexed component prior to expansion. + (Resolve_Actuals): If an actual is of a protected subtype, use its + base type to determine whether a conversion to the corresponding record + is needed. + (Resolve_Short_Circuit): Handle pragma Check + + * sem_eval.adb: Minor code reorganization (usea Is_Constant_Object) + Use new Is_Standard_Character_Type predicate + (Eval_Relational_Op): Catch more cases of string comparison + +2008-04-08 Robert Dewar + Gary Dismukes + + * s-rident.ads: Add No_Default_Initialization restriction + + * exp_tss.adb: + (Has_Non_Null_Base_Init_Proc): Handle No_Default_Initialization case + (Set_TSS): Handle No_Default_Initialization case + + * exp_ch6.adb (Expand_N_Subprogram_Body): Handle restriction + No_Default_Initialization + (Expand_N_Subprogram_Body): Remove redundant initialization of out + parameters when Normalize_Scalars is active. + (Add_Final_List_Actual_To_Build_In_Place_Call): Add formal Sel_Comp + Fix casing error in formal parameter name in call + (Register_Predefined_DT_Entry): Replace occurrences of RE_Address by + (Expand_Call, Propagate_Tag): Call Kill_Current_Values when processing a + dispatching call on VM targets. + +2008-04-08 Gary Dismukes + Thomas Quinot + + * exp_ch7.adb (Find_Final_List): Change the test for generating a + selected component from an access type's Associated_Final_Chain to + check for the presence of that field, rather than assuming it exists + for all named access types. + (Make_Clean): New formal Chained_Cleanup_Action allowing to specify a + procedure to call at the end of the generated cleanup procedure. + (Expand_Cleanup_Actions): When a new cleanup procedure is generated, and + and an At_End_Proc already exists in the handled sequence of statements + for which cleanup actions are being expanded, the original cleanup + action must be preserved. + +2008-04-08 Hristian Kirtchev + Ed Schonberg + Robert Dewar + Gary Dismukes + + * exp_ch9.ads, exp_ch9.adb (Build_Protected_Entry, + Build_Unprotected_Subprogram_Body): Generate debug info for + declarations related to the handling of private data in task and + protected types. + (Debug_Private_Data_Declarations): New subprogram. + (Install_Private_Data_Declarations): Remove all debug info flagging. + This is now done by Debug_Private_Data_Declarations at the correct + stage of expansion. + (Build_Simple_Entry_Call): If the task name is a function call, expand + the prefix into an object declaration, and make the surrounding block a + task master. + (Build_Master_Entity): An internal block is a master if it wraps a call. + Code reformatting, update comments. Code clean up. + (Make_Task_Create_Call): Use 'Unrestricted_Access instead of 'Address. + (Replicate_Entry_Formals): If the formal is an access parameter or + anonymous access to subprogram, copy the original tree to create new + entities for the formals of the subprogram. + (Expand_N_Task_Type_Declaration): Create a Relative_Deadline variable + for tasks to store the value passed using pragma Relative_Deadline. + (Make_Task_Create_Call): Add the Relative_Deadline argument to the + run-time call to create a task. + (Build_Wrapper_Spec): If the controlling argument of the interface + operation is an access parameter with a non-null indicator, use the + non-null indicator on the wrapper. + + * sem_ch9.adb (Analyze_Protected_Type): Only retrieve the full view when + present, which it may not be in the case where the type entity is an + incomplete view brought in by a limited with. + (Analyze_Task_Type): Only retrieve the full view when present, which it + may not be in the case where the type entity is an incomplete view brought + in by a limited with. + (Analyze_Protected_Definition): Set Is_Frozen on all itypes generated for + private components of a protected type, to prevent the generation of freeze + nodes for which there is no proper scope of elaboration. + + * exp_util.ads, exp_util.adb + (Remove_Side_Effects): If the expression is a function call that returns a + task, expand into a declaration to invoke the build_in_place machinery. + (Find_Protection_Object): New routine. + (Remove_Side_Effects): Also make a copy of the value + for attributes whose result is of an elementary type. + (Silly_Boolean_Array_Not_Test): New procedure + (Silly_Boolean_Array_Xor_Test): New procedure + (Is_Volatile_Reference): New function + (Remove_Side_Effects): Use Is_Volatile_Reference + (Possible_Bit_Aligned_Component): Handle slice case properly + + * exp_pakd.adb (Expand_Packed_Not): Move silly true/true or false/false + case test to Exp_Util + (Expand_Packed_Xor): Move silly true/true case test to Exp_Util + +2008-04-08 Thomas Quinot + + * exp_dist.ads, exp_dist.adb: Fix casing error in formal parameter name + in call + (Add_RACW_Features): When processing an RACW in another unit than the + main unit, set Body_Decls to No_List to indicate that the bodies of + the type's TSS must not be generated. + (GARLIC_Support.Add_RACW_Read_Attribute, + GARLIC_Support.Add_RACW_Write_Attribute): Do not generate bodies if + Body_Decls is No_List. + (PolyORB_Support.Add_RACW_Read_Attribute, + PolyORB_Support.Add_RACW_Write_Attribute, + PolyORB_Support.Add_RACW_From_Any, + PolyORB_Support.Add_RACW_To_Any, + PolyORB_Support.Add_RACW_TypeCode): Same. + (Transmit_As_Unconstrained): New function. + (Build_Ordered_Parameters_List): Use the above to order parameters. + (GARLIC_Support.Build_General_Calling_Stubs): + Use the above to determine which parameters to unmarshall using 'Input + at the point where their temporary is declared (as opposed to later on + with a 'Read call). + (PolyORB_Support.Build_General_Calling_Stubs): + Use the above to determine which parameters to unmarshall using From_Any + at the point where their temporary is declared (as opposed to later on + with an assignment). + +2008-04-08 Ed Schonberg + + * exp_strm.adb (Build_Record_Or_Elementary_Input_Function): If this is + an Input function for an access type, do not perform default + initialization on the local variable that receives the value, to + prevent spurious warnings when the type is null-excluding. + +2008-04-08 Robert Dewar + Ed Schonberg + + * freeze.adb (Freeze_Entity): Improve warnings on access types in pure + units. + (Size_Known): Generic formal scalar types have known at compile + time size, so remove check. + Fix casing error in formal parameter name in call + (Freeze_Subprogram): If the subprogram is a user-defined operator, + recheck its overriding indication. + +2008-04-08 Vincent Celier + + * gnat1drv.adb: Send all messages indicating an error to standard error + +2008-04-08 Robert Dewar + + * gnatbind.adb (Restriction_Could_Be_Set): New procedure + (List_Applicable_Restrictions): Do not list existing restrictions + +2008-04-08 Thomas Quinot + + * g-socket.ads, g-socket.adb: Improve documentation of GNAT.Sockets: + add a pointer to generic sockets literature + do not mention that the given example is "typical" usage. + Remove obsolete comment about multicast not being supported on Windows. + (Connect_Socket): Make Server mode IN rather than IN OUT + since this formal is never modified. + +2008-04-08 Robert Dewar + + * sprint.adb (Write_Itype): Handle Itypes whose Parent field points to + the declaration for some different entity. + (Sprint_Node_Actual, case N_Derived_Type_Definition): When an interface + list is precent (following the parent subtype indication), display + appropriate "and" keyword. + + * itypes.adb: Remove unnecessary calls to Init_Size_Align and Init_Esize + Remove unnecessary calls to Init_Size_Align and Init_Esize. + Add notes on use of Parent field of an Itype + +2008-04-08 Ed Schonberg + Robert Dewar + Gary Dismukes + + * lib-xref.adb (Is_On_LHS): Remove dead code + (Output_Overriden_Op): If the overridden operation is itself inherited, + list the ancestor operation, which is the one whose body or absstract + specification is actually being overridden. For source navigation + purposes. + + * sem_ch7.adb (Is_Primitive_Of): use base type to determine whether + operation is primitive for the type. + (Declare_Inherited_Private_Subprograms): If the new operation overrides + an inherited private subprogram, set properly the Overridden_Operation + attribute, for better cross-reference information. + (Analyze_Package_Specification): Do late analysis of spec PPCs + (Install_Private_Declaration, Uninstall_Declarations): Save/restore + properly the full view and underlying full views of a private type in a + child unit, whose full view is derived from a private type in a parent + unit, and whose own full view becomes visible in the child body. + + * sem_disp.adb (Check_Dispatching_Operation): When a body declares a + primitive operation after the type has been frozen, add an explicit + reference to the type and the operation, because other primitive + references have been emitted already. + (Expand_Call, Propagate_Tag): Call Kill_Current_Values when processing a + dispatching call on VM targets. + +2008-04-08 Vincent Celier + Thomas Quinot + + * make.adb: (Gnatmake_Called): Remove, no longer necessary + (Compile_Surces): Call Delete_Temp_Config_Files only if Gnatmake_Called + is True and Debug_Flag_N is False. Debug_Flag_N means "keep temp files". + (Insert_Project_Sources): Take into account index in multi-unit source + files. + After building a library project, delete all temporary files. + (Initialize): Reset current output after parsing project file. + (Collect_Arguments_And_Compile): Never insert in the queue the sources + of library projects that are externally built. + Put file name in error and inform messages if -df is used + (Display): If invoked with -d7, do not display path names, but only + file names. + + * makeutl.ads (Path_Or_File_Name): New function + (Path_Or_File_Name): New function + +2008-04-08 Arnaud Charlet + + * Make-lang.in: Disable warnings during first stage of bootstrap + Get rid of gnatbl. + Update dependencies. + +2008-04-08 Vincent Celier + + * mlib-prj.adb (Build_Library): Compare with ALI file name in canonical + case to decide if ALI object file is included in library. + (Build_Library): Never attempt to build a library if the project is + externally built. + +2008-04-08 Thomas Quinot + + * nlists.adb (Is_Non_Empty_List): Remove redundant test. First + (No_List) is defined to return Empty. + +2008-04-08 Jose Ruiz + + * osint.ads, osint.adb (Get_Libraries_From_Registry): Improve + documentation. + Update comments. + (Read_Default_Search_Dirs): Do not consider spaces as path separators + because spaces may be part of legal paths. + +2008-04-08 Robert Dewar + + * par-ch11.adb (P_Exception_Handler): Check indentation level for + handler + +2008-04-08 Ed Schonberg + + * par-ch3.adb (P_Type_Declaration) Reject the keyword "synchronized" + in a type declaration, if this is not an interface declaration or + private type extension. + +2008-04-08 Vincent Celier + + * prj-util.adb (Executable_Of): New String parameter Language. When + Ada_Main is False and Language is not empty, attempt to remove the body + suffix or the spec suffix of the language to get the base of the + executable file name. + (Put): New Boolean parameter Lower_Case, defauilted to False. When + Lower_Case is True, put the value in lower case in the name list. + (Executable_Of): If there is no executable suffix in the configuration, + then do not modify Executable_Extension_On_Target. + + * prj-util.ads (Executable_Of): New String parameter Language, + defaulted to the empty string. + (Put): New Boolean parameter Lower_Case, defauilted to False + +2008-04-08 Robert Dewar + + * scng.adb (Scan_Identifier): Handle case of identifier starting with + wide character using UTF-8 encoding. + +2008-04-08 Javier Miranda + + * sem.adb (Analyze): Consider case in which we analyze an empty node + that was generated by a call to a runtime function that is not + available under the configurable runtime. + + * sem.ads (Inside_Freezing_Actions): New flag. + (Save_Check_Policy_List): New field in scope stack entry + +2008-04-08 Ed Schonberg + Robert Dewar + + * sem_aggr.adb (Analyze_N_Extension_Aggregate): Add legality checks for + the ancestor part of an extension aggregate for a limited type. + (Resolve_Array_Aggregate): Issue warning for sliding of aggregate with + enumeration index bounds. + (Resolve_Array_Aggregate): Add circuit for diagnosing missing choices + when array is too short. + (Check_Expr_OK_In_Limited_Aggregate): Move function + Check_Non_Limited_Type from Resolve_Record_Aggregate to top level (and + change name). + (Resolve_Array_Aggregate.Resolve_Aggr_Expr): + Check_Expr_OK_In_Limited_Aggregates called to check for illegal limited + component associations. + (Check_Non_Limited_Type): Moved to outer level and renamed. + (Resolve_Record_Aggregate): In an extension aggregate, an association + with a box initialization can only designate a component of the + extension, not a component inherited from the given ancestor + + * sem_case.adb: Use new Is_Standard_Character_Type predicate + +2008-04-08 Robert Dewar + + * s-imgdec.adb (Set_Decimal_Digits): Fix error when input is zero with + negative scale + (Set_Decimal_Digits): Properly handle Aft=0 (equivalent to Aft=1) + Properly handle case where Aft > Scale and input number is less than + one. + +2008-04-08 Hristian Kirtchev + + * s-stoele.ads, s-soflin.ads: Move the location of + Dummy_Communication_Block from System.Storage_Elements to + System.Soft_Links. + + * s-tpobop.ads: Add comment on usage of Dummy_Communication_Block to + emulate Communication_Block in certain scenarios. + +2008-04-08 Hristian Kirtchev + + * s-strxdr.adb, s-stratt.ads, s-stratt.adb (Block_IO_OK): New + subprogram. + Add new subtype S_WWC, unchecked conversion routines From_WWC and + To_WWC. + (I_WWC, O_WWC): New routines for input and output of + Wide_Wide_Character. + +2008-04-08 Robert Dewar + + * stringt.adb (Write_String_Table_Entry): Handle wide characters + properly + +2008-04-08 Robert Dewar + + * styleg.adb (Check_Comment): Allow special char after -- in + non-end-of-line case + +2008-04-08 Robert Dewar + + * stylesw.adb: Implement -gnaty + - y options + (Set_GNAT_Style_Check_Options): Includ I in style check string + + * stylesw.ads: Add comments for new style switch options + +2008-04-08 Sergey Rybin + + * tree_io.ads: Increase ASIS_Version_Number because of adding Sem_Aux + to the set of the GNAT components needed by ASIS. + +2008-04-08 Bob Duff + + * types.h: Change CE_Null_Exception_Id to the correct value (8, was 9). + +2008-04-08 Tristan Gingold + + * vxaddr2line.adb: Use Unsigned_32 instead of Integer for address type. + Improve error message generation. + +2008-04-08 Vincent Celier + + * a-direct.adb (Start_Search): Check for Name_Error before checking for + Use_Error, as specified in the RM. Check if directory is open and raise + Use_Error if it is not. + +2008-04-08 Vincent Celier + Robert Dewar + + * vms_conv.adb (Output_Version): Print "GNAAMP" instead of "GNAT when + AAMP_On_Target is set. + + * vms_data.ads: Add NOxxx to style check switch list + Add entry COMPONENTS for -gnatVe + Add VMS qualifiers for -eL (/FOLLOW_LINKS_FOR_FILES) and --subdirs= + (/SUBDIRS=). + (GCC_Switches): Add /ALL_BACK_END_WARNINGS. + Add qualifiers for gnatmetric coupling options + Add note that -gnata enables all checks + Add entries [NO]PARAMETER_ORDER for -gnatw.p[P] + Fix inconsistency for VMS qualifier for the gnatpp '-rnb' option + New warning flag -gnatw.e + + * usage.adb: Add entries for -gnaty+ -gnaty- -gnatyy + Add entry for -gnatyN (forgotten before) + Line for new warning switch -gnatw.p + New warning flag -gnatw.e + + * gnat_ugn.texi: Add documentation fpr project file switch -aP + Document -gnaty - + y + Replace occurences of "package specification" with "package spec" + Define preprocessing symbols in documentation of gnatprep + Clarify reason for distinguishing overflow checking + Add documentation for project-aware tool switches -eL and --subdirs= + Complete list of configuration pragmas + Specify that, even when gnatmake switch -x is used, mains on the command + line need to be sources of project files. + Editing of gnatcheck/gnatmetric doc. + Add documentation for -gnatw.p/-gnatw.P + Add missing documentation for -fno-inline-functions. + Add documentation for -gnatw.e + + * gnat_rm.texi: Add documentation for No_Default_Initialization + Replace occurences of "package specification" with "package spec" + Document use of * in Warnings Off string + Update documentation of alignment/component clauses. + Add documentation for Invalid_Value + Document new consistency rule for Optimize_Alignment + Add documentation for Precondition and Postcondition pragmas + Add documentation for Check and Check_Policy pragmas + Document new Enum_Val attribute + Remove requirement for static string in pragma Assert + Add documentation on GNAT.Time_Stamp + + * ug_words: add entry for -gnatVe + Add entries for -gnat.p[P] /WARNINGS=[NO]PARAMETER_ORDER + Add entry for -gnatw.e + + * debug.adb: Add missing documentation for d.a flag + Document new -gnatd.a switch. + Add documentation for new gnatmake debug switch -df + +2008-04-08 Thomas Quinot + + * gen-soccon.c: Bump year in copyright notices. + + * g-soccon-vxworks.ads: Add new constant IP_PKTINFO + +2008-04-08 Eric Botcazou + + * ctrl_c.c: Improve handling of ctrl-c on LynxOS and Windows. + Minor reformatting. + +2008-04-08 Robert Dewar + Bob Duff + + * impunit.adb: Add Interfaces.Java.JNI, System.Strings.Stream_Ops, + Ada.Calendar.Conversions, Ada.Dispatching.EDF, GNAT.Time_Stamp + + * s-intman-mingw.adb: Minor comment fix -- spell 'explicitly' correctly + + * g-trasym.adb: Minor comment fix -- spell 'explicitly' correctly + + * g-trasym.ads: Minor comment improvements + + * s-stalib.adb: Minor comment fix -- spell 'explicitly' correctly + + * a-sequio.ads, a-direio.ads: improve message for tagged type + + * a-strunb.ads: Minor reformatting + + * a-tifiio.adb: Minor reformatting + + * atree.adb (Fix_Parents): Use clearer names for formals + Cleanup and simplify code + Use named notation in calls + + * exp_fixd.adb (Do_Multiply_Fixed_Universal): Use named notation in + confusing calls + + * uintp.adb: Used named notation for some confusing calls + + * bindusg.adb: Minor change in one line of output + + * cstand.adb: Minor reformatting of src representation of Standard + + * a-assert.ads: Add comment. + + * g-decstr.adb: Fix bad indentation + + * expander.ads, expander.adb: Code clean up. + + * sem_dist.ads: Minor comment improvement + + * sem_type.adb, g-dirope.ads, g-exctra.ads, s-valwch.adb, + s-wchstw.adb, targparm.ads, widechar.adb: Minor reformatting + + * i-cstrin.adb: Fix casing error in formal parameter name in call + +2008-04-08 Ed Schonberg + + * binde.adb (Gather_All_Links, Gather_Dependencies): units that are + mentioned in limited_with_clauses to do create semantic dependencies + even though they appear in the ali file. + +2008-04-08 Emmanuel Briot + + * g-comlin.ads, g-comlin.adb (Expansion): Remove unreachable return + statement. + (Get_Configuration): New subprogram. + + * prj-pp.ads, prj-pp.adb (Pretty_Print): new parameters Id and Id_Tree + These optional parameters help preserve the casing of the project's name + when pretty-printing. + +2008-04-08 Jerome Lambourg + Arnaud Charlet + + * bindgen.adb (Gen_Adainit_Ada): If the main program is a CIL function, + then use __gnat_set_exit_status to report the returned status code. + + * comperr.adb (Compiler_Abort): Convert most bug boxes into clean error + messages on .NET, since some constructs of the language are not + properly supported. + + * gnatlink.adb (Gnatlink): In case the command line is too long for the + .NET linker, gnatlink now concatenate all .il files and pass this to + ilasm. + +2008-04-07 Aurelien Jarno + Xavier Grave + + * Makefile.in: Add make ifeq define for mips/mipsel support. + * g-soccon-linux-mips.ads, system-linux-mipsel.ads, + system-linux-mips.ads: New files. + +2008-04-07 Aurelien Jarno + + * sysdep.c: add __GLIBC__ to the #ifdef preprocessor macros to + detect systems using GNU libc. + * gsocket.h: ditto. + * socket.c: ditto. + * adaint.c: ditto. + * link.c: ditto. + +2008-04-07 Aurelien Jarno + + * s-osinte-linux-kfreebsd.ads (SC_NPROCESSORS_ONLN): New + constant constant for sysconf call. + (bit_field): New packed boolean type used by cpu_set_t. + (cpu_set_t): New type corresponding to the C type with + the same name. Note that on the Ada side we use a bit + field array for the affinity mask. There is not need + for the C macro for setting individual bit. + (pthread_setaffinity_np): New imported routine. + * Makefile.in: Use s-tasinf-linux.ads and s-tasinf-linux.adb + on GNU/kFreeBSD. + +2008-04-07 Eric Botcazou + + * utils2.c (build_binary_op): Fold ARRAY_REF and ARRAY_RANGE_REF too. + +2008-04-07 Eric Botcazou + + * gigi.h (create_subprog_type): Remove returns_with_dsp parameter. + * decl.c (gnat_to_gnu_entity): Adjust for above new prototype. + * utils.c (create_subprog_type): Remove returns_with_dsp parameter. + * trans.c (gnat_to_gnu) : Remove code dealing with + Return by Depressed Stack Pointer. + +2008-04-06 Eric Botcazou + + * decl.c (is_variable_size): Do not unconditionally return false + on non-strict alignment platforms. + +2008-04-06 Eric Botcazou + + * decl.c (rest_of_type_decl_compilation_no_defer): New local function + used to process all the variants of the specified type. + (gnat_to_gnu_entity): Invoke rest_of_type_decl_compilation for enumeral + types too. Call rest_of_type_decl_compilation_no_defer if undeferring. + (rest_of_type_decl_compilation): Likewise. + * utils.c (gnat_pushdecl): Propagate the name to all variants of type. + +2008-04-03 Paolo Bonzini + + * gigi.h (insert_block): Kill. + * utils.c (insert_block): Kill. + +2008-04-02 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : For a constant object whose + type has self-referential size, get the size from the initializing + expression directly if it is also a constant whose nominal type + has self-referential size. + +2008-04-01 John David Anglin + + PR ada/33688 + * g-soccon-darwin.ads: Define new constant IP_PKTINFO. + + PR ada/33857 + * env.c: Always include crt_externs.h if __APPLE__ is defined. + (__gnat_setenv): Use setenv instead of putenv if __APPLE__ is defined. + +2008-04-01 Andreas Jaeger + + * g-soccon-linux-ppc.ads: Add new constants SO_REUSEPORT and + IP_PKTINFO. + +2008-03-31 Ralf Wildenhues + + * g-table.adb, g-tasloc.adb, g-traceb.ads, + g-trasym.adb, g-utf_32.adb, gen-soccon.c, gigi.h, gmem.c, + gnatbind.adb, gnatchop.adb, gnatcmd.adb, + gnatcmd.ads, gnatdll.adb, gnatfind.adb, + gnatlink.adb, gnatmem.adb, gprep.adb, + i-cstrea-vms.adb, i-cstrin.adb, i-pacdec.ads, + i-vxwork.ads, impunit.adb, init.c, initialize.c, inline.adb, + layout.adb, lib-writ.adb, lib-writ.ads, lib-xref.adb, + lib-xref.ads, lib.adb, link.c, live.ads, + make.adb, makegpr.adb, makeutl.adb, math_lib.adb, + mdll-utl.adb, mdll.ads, memroot.adb, memroot.ads, + misc.c, mlib-prj.adb, mlib-tgt-hpux.adb, + mlib-tgt-linux.adb, mlib-tgt-tru64.adb, mlib-tgt.ads, + namet.adb, namet.h, nlists.adb, nlists.ads, + nlists.h, opt.ads, osint-b.ads, osint-c.adb, + osint-c.ads, osint.adb, osint.ads, output.ads, + par-ch10.adb, par-ch12.adb, par-ch2.adb, par-ch3.adb, + par-ch4.adb, par-ch5.adb, par-ch6.adb, par-ch9.adb, + par-endh.adb, par-labl.adb, par-prag.adb, + par-sync.adb, par-tchk.adb, par-util.adb, + par.adb, prep.adb, prep.ads, prepcomp.adb, prj-attr.ads, + prj-dect.adb, prj-env.adb, prj-ext.adb, prj-nmsc.adb, + prj-nmsc.ads, prj-pp.adb, prj-proc.adb, + prj-strt.ads, prj-tree.ads, prj.adb, prj.ads: Fix comment typos. + +2008-03-31 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : Do not force a non-null + size if it has overflowed. + +2008-03-31 Olivier Hainque + Eric Botcazou + + * utils2.c (find_common_type): Document assumption on t1/t2 vs + lhs/rhs. Force use of lhs type if smaller, whatever the modes. + +2008-03-30 Ralf Wildenhues + + * a-textio.ads, a-witeio.ads, a-ztexio.ads, ali.ads, + einfo.ads, erroutc.adb, erroutc.ads, exp_attr.adb, + exp_imgv.adb, exp_intr.adb, exp_pakd.adb, + exp_pakd.ads, exp_prag.adb, exp_smem.adb, + exp_tss.ads, exp_util.adb, exp_util.ads, + exp_vfpt.adb, freeze.adb, freeze.ads, + frontend.adb, g-alleve.adb, g-altcon.adb, + g-altive.ads, g-alveop.ads, g-alvevi.ads, + g-arrspl.adb, g-busorg.ads, g-calend.adb, + g-calend.ads, g-casuti.ads, g-cgideb.adb, + g-comlin.adb, g-comlin.ads, g-curexc.ads, + g-debpoo.adb, g-debpoo.ads, g-decstr.adb, + g-dirope.adb, g-dirope.ads, g-dynhta.ads, + g-dyntab.adb, g-encstr.ads, g-excact.ads, + g-except.ads, g-expect.ads, g-heasor.adb, + g-hesora.adb, g-hesorg.adb, g-htable.ads, + g-locfil.ads, g-md5.adb, g-md5.ads, + g-memdum.ads, g-moreex.ads, g-os_lib.adb, + g-pehage.adb, g-pehage.ads, g-regexp.adb, + g-regexp.ads, g-regpat.adb, g-regpat.ads, + g-soccon-aix.ads, g-soccon-darwin.ads, + g-soccon-freebsd.ads, g-soccon-hpux-ia64.ads, + g-soccon-hpux.ads, g-soccon-irix.ads, + g-soccon-linux-64.ads, g-soccon-linux-ppc.ads, + g-soccon-linux-x86.ads, g-soccon-lynxos.ads, + g-soccon-mingw.ads, g-soccon-solaris-64.ads, + g-soccon-solaris.ads, g-soccon-tru64.ads, + g-soccon-vms.ads, g-soccon-vxworks.ads, + g-soccon.ads, g-socket.adb, g-socket.ads, + g-socthi-mingw.adb, g-socthi-vms.adb, + g-socthi-vxworks.adb, g-soliop-mingw.ads, + g-soliop-solaris.ads, g-soliop.ads, g-spipat.adb, + g-spipat.ads, g-string.adb, g-stsifd-sockets.adb: Fix comment + typos. + +2008-03-27 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : Also set the public flag + if the procedure is imported. + +2008-03-26 Arnaud Charlet + + * adaint.c: Fix warnings. + +2008-03-26 Arnaud Charlet + + * g-dirope.ads, g-dirope.adb: (Dir_Type_Value): Moved to spec. + +2008-03-26 Arnaud Charlet + + * a-witeio.adb: Fix problem with Current_Output (introduce Self). + Fix problem of status check for null file + +2008-03-26 Arnaud Charlet + + * s-proinf-irix-athread.ads, s-vxwork-mips.ads, + s-traces.ads, s-vxwork-arm.ads, s-vxwork-ppc.ads, s-vxwork-sparcv9.ads, + s-tasinf-mingw.ads, s-tasinf-linux.ads, s-tasdeb.ads, mlib-tgt.ads, + i-cstrin.ads, uintp.adb, g-catiio.adb, s-vmexta.ads, + s-trafor-default.ads, s-vxwork-m68k.ads: Minor reformatting. Update + comments. + +2008-03-26 Thomas Quinot + + PR ada/33688 + * g-socket.ads, g-socket.adb (Options, Set_Socket_Option, + Get_Socket_Option): Add support for Receive_Packet_Info. + + * g-soccon.ads, g-soccon-tru64.ads, g-soccon-aix.ads, + g-soccon-irix.ads, g-soccon-hpux.ads, g-soccon-solaris.ads, + g-soccon-vms.ads, g-soccon-mingw.ads, g-soccon-freebsd.ads, + g-soccon-hpux-ia64.ads, g-soccon-solaris-64.ads, g-soccon-darwin.ads, + g-soccon-lynxos.ads, g-soccon-linux-64.ads, g-soccon-linux-x86.ads: Add + new constants SO_REUSEPORT and IP_PKTINFO + +2008-03-26 Robert Dewar + + * a-taster.adb, s-shasto.adb, s-soflin.adb, s-taasde.adb, s-taenca.adb, + a-sytaco.adb, a-sytaco.ads, a-tasatt.adb, a-taside.adb, + a-intnam-lynxos.ads, a-retide.adb, a-intnam-tru64.ads, a-intnam-aix.ads, + a-intnam-irix.ads, a-intnam-hpux.ads, a-intnam-linux.ads, + a-intnam-solaris.ads, a-caldel-vms.adb, a-intnam-vms.ads, + a-excpol-abort.adb, a-intnam-mingw.ads, s-interr.adb, s-interr.ads, + s-intman.ads, s-gloloc.adb, s-osinte-lynxos-3.ads, + s-interr-sigaction.adb, s-osinte-hpux.ads, s-osinte-solaris-posix.ads, + a-intnam-freebsd.ads, s-osinte-freebsd.ads, s-osinte-lynxos.ads, + s-taspri-lynxos.ads, s-osinte-tru64.ads, s-osinte-tru64.ads, + s-taspri-tru64.ads, s-osinte-aix.ads, s-osinte-irix.ads, + s-osinte-hpux-dce.ads, s-taprop-hpux-dce.adb, s-taspri-hpux-dce.ads, + s-osinte-linux.ads, s-osinte-dummy.ads, s-taprop-dummy.adb, + s-taspri-dummy.ads, s-interr-dummy.adb, s-osinte-solaris.ads, + s-osinte-mingw.ads, s-taprop-solaris.adb, s-taspri-solaris.ads, + s-inmaop-vms.adb, s-interr-vms.adb, s-intman-vms.ads, s-osinte-vms.ads, + s-osinte-vms.ads, s-taprop-vms.adb, s-taspri-vms.ads, + s-taspri-mingw.ads, s-interr-vxworks.adb, s-inmaop-posix.adb, + s-intman-vxworks.ads, s-osinte-vxworks.ads, s-osprim-vxworks.adb, + s-taspri-vxworks.ads, s-taspri-posix.ads, a-caldel.adb, a-calend.adb, + a-elchha.adb, a-dynpri.adb, a-except.adb, a-except.ads, a-interr.ads, + a-textio.adb, a-tigeau.ads, atree.adb, s-taprob.adb, s-taprop.ads, + s-tarest.adb, s-tarest.ads, s-tasini.adb, s-taskin.adb, s-taskin.ads, + s-tasque.adb, s-tasren.adb, s-tasren.ads, s-tassta.adb, s-tassta.ads, + s-tasuti.adb, s-tataat.adb, s-tataat.ads, s-tpoben.adb, s-tpoben.ads, + s-tpobop.adb, s-tpobop.ads, s-tposen.adb, s-tposen.ads, s-valrea.adb, + s-valuti.adb, a-intnam-darwin.ads, s-osinte-darwin.ads, s-solita.adb, + a-ztinau.ads, s-osinte-linux-hppa.ads, a-except-2005.adb, + a-except-2005.ads, a-rttiev.adb, s-osinte-vxworks6.ads, s-regexp.adb, + s-tasloc.adb: Minor reformatting. + Update comments. + Remove "used for" sections from comments. + +2008-03-26 Robert Dewar + + * s-tpopsp-posix.adb, s-tpopsp-solaris.adb, s-tpopsp-posix-foreign.adb, + s-tpopsp-lynxos.adb, s-tpopde-vms.ads, s-tpopde-vms.adb, + s-tpopsp-vxworks.adb, s-casi16.adb, s-caun16.adb, s-inmaop.ads, + s-tadeca.adb, s-tadeca.ads, s-tadert.adb, s-tadert.ads, s-tpinop.adb, + s-tpinop.ads, s-tporft.adb, a-rbtgso.adb, a-crbtgo.ads, a-crbtgo.adb, + a-crbtgk.ads, a-crbtgk.adb, a-ciorse.adb, a-cihama.ads, a-cihama.adb, + a-cidlli.ads, a-cidlli.adb, a-chtgop.ads, a-chtgop.adb, a-cgcaso.ads, + a-cgcaso.adb, a-cgaaso.adb, a-ciormu.adb, a-cihase.adb, a-swuwha.ads, + a-rbtgso.ads, a-cgaaso.ads, a-cgaaso.ads, a-ciorma.adb, a-chtgke.ads, + a-chtgke.adb, a-llfzti.ads, a-ztenau.adb, a-ztenau.ads, a-stzhas.ads, + a-szbzha.ads, a-szbzha.adb, a-crdlli.ads, a-crdlli.ads, a-crdlli.adb, + i-forbla-darwin.adb, i-forbla.ads, s-regexp.adb, a-nllrar.ads, + a-nlrear.ads, a-nucoar.ads, a-nurear.ads, i-forlap.ads, s-gearop.adb, + s-gearop.ads, s-gecobl.adb, s-gecobl.ads, s-gecola.adb, s-gecola.ads, + s-gerebl.adb, s-gerela.ads, a-swuwha.adb, i-forbla-unimplemented.ads, + double spaced if it fits on one line and otherwise single spaced. + +2008-03-26 Arnaud Charlet + + * s-taprop-irix.adb, s-taprop-tru64.adb, s-taprop-lynxos.adb, + s-taprop-linux.adb, s-taprop-mingw.adb, s-taprop-vxworks.adb, + s-taprop-posix.adb (Create_Task): Do not attempt to set task priority + or task info if the thread could not be created. + +2008-03-26 Arnaud Charlet + + * gnatvsn.ads (Library_Version): Bump to 4.4. + (Current_Year): Bump to 2008. + +2008-03-26 Robert Dewar + + * ali.ads, ali.adb (Optimize_Alignment_Setting): New field in ALI record + + * bcheck.adb (Check_Consistent_Optimize_Alignment): New procedure + + * debug.adb: Add debug flags d.r and d.v + Add debug flag .T (Optimize_Alignment (Time)) + Add debug flag .S (Optimize_Alignment (Space)) + + * freeze.adb (Freeze_Record_Type): Set OK_To_Reorder_Components + depending on setting of relevant debug flags. + Replace use of Warnings_Off by Has_Warnings_Off + (Freeze_Entity): In circuit for warning on suspicious convention + actuals, do not give warning if subprogram has same entity as formal + type, or if subprogram does not come from source. + (Freeze_Entity): Don't reset Is_Packed for fully rep speced record + if Optimize_Alignment set to Space. + + * frontend.adb: Add call to Sem_Warn.Initialize + Add call to Sem_Warn.Output_Unused_Warnings_Off_Warnings + Reset Optimize_Alignment mode from debug switches .S and .T + + * layout.adb (Layout_Composite_Object): Rewritten for + Optimize_Aligment pragma. + + * lib-writ.ads, lib-writ.adb: New Ox parameter for Optimize_Alignment + mode. + + * opt.ads, opt.adb: (Optimize_Alignment): New global switch + + * par-prag.adb (N_Pragma): Chars field removed, use Chars + (Pragma_Identifier (.. instead, adjustments throughout to accomodate + this change. Add entry for pragma Optimize_Alignment + + * sem_prag.adb (N_Pragma): Chars field removed, use Chars + (Pragma_Identifier (.. + instead, adjustments throughout to accomodate this change. + (Process_Compile_Time_Warning_Or_Error): Use !! for generated msg + (Favor_Top_Level): Use new function Is_Access_Subprogram_Type + Add implementation of pragma Optimize_Alignment + +2008-03-26 Vincent Celier + + * a-szuzti.adb, a-swuwti.adb, a-suteio.adb (functions Get_Line): + Improve memory usage to avoid use of stack. + +2008-03-26 Robert Dewar + + * a-teioed.ads: Correct value of Default_Fill + + * a-teioed.adb (Image): Use Fill_Character instead of '*' to fill + +2008-03-26 Robert Dewar + + * a-ztexio.adb, a-ztexio.ads, a-witeio.ads, a-witeio.adb: Fix problem + with Current_Output (introduce Self). + +2008-03-26 Robert Dewar + + * checks.adb (Ensure_Valid): Capture valid status if possible + (eliminate checks) + +2008-03-26 Robert Dewar + + * stand.ads: Deal with reordering of package standard declarations + + * cstand.adb: Put package Standard declarations in proper order + +2008-03-26 Robert Dewar + + * einfo.ads, einfo.adb (N_Pragma): Chars field removed, use Chars + (Pragma_Identifier (.. instead. + (OK_To_Reorder_Components): New flag + (Has_Entries): Code cleanup. + (Warnings_Off_Used): New flag + (Warnings_Off_Used_Unmodified): New flag + (Warnings_Off_Used_Unreferenced): New flag + (Has_Warnings_Off): New function + (Has_Unmodified): New function + (Has_Unreferenced): New function + (Is_Trivial_Subprogram): New flag + (Is_Static_Dispatch_Table_Entity): New attribute. + Change name Access_Subprogram_Type_Kind to Access_Subprogram_Kind + (more consistent with other similar names) + (Access_Subprogram_Type): New classification function + +2008-03-26 Robert Dewar + + * errout.ads: Document new !! insertion sequence + + * errout.adb (N_Pragma): Chars field removed, use Chars + (Pragma_Identifier (.. instead. + Replace use of Warnings_Off by Has_Warnings_Off + (Error_Msg_Internal): Don't delete warning ending in !! + +2008-03-26 Robert Dewar + + * par.adb (Check_No_Right_Paren): Removed no longer used + + * par-ch10.adb (N_Pragma): Chars field removed, use Chars + (Pragma_Identifier (.. instead. + + * par-ch10.adb (P_Subunit): Improvement in error recovery and message + + * par-tchk.adb, par-ch5.adb, par-ch6.adb, par-ch3.adb, + par-ch4.adb: Minor improvements in error recovery and messages. + + * erroutc.adb (Test_Style_Warning_Serious_Msg): Treat style msgs as + non-serious + + * par-ch9.adb: Minor improvements in error recovery and messages + (P_Protected): Better error recovery for "protected type x;" + + * par-util.adb: Minor improvements in error recovery and messages + (Check_No_Right_Paren): Removed no longer used + +2008-03-26 Ed Schonberg + + * exp_aggr.adb (Replace_Type): When checking for self-reference, verify + that the prefix of an attribute is the type of the aggregate being + expanded. + +2008-03-26 Javier Miranda + Robert Dewar + + * exp_attr.adb (N_Pragma): Chars field removed. + (Expand_N_Attribute_Reference): If the designated type associated with + attribute 'Unrestricted_Access is a subprogram entity then replace it + by an E_Subprogram_Type itype. + Implement attribute Old + + * sem_attr.ads (Attribute_Class_Array): Move to snames.ads + + * sem_attr.adb (Build_Access_Subprogram_Itype): Add documentation. + Replace call to + New_Internal_Entity by call to Create_Itype to centralize calls + building itypes, ad propagate the convention of the designated + subprogram. In addition, disable the machinery cleaning constant + indications from all entities in current scope when 'Unrestricted_Access + corresponds with a node initializing a dispatch table slot. + (Analyze_Attribute): Parameterless attributes returning a string or a + type will not be called with improper arguments, so we can remove junk + code that was dealing with this case. + Implement attribute Old + + * snames.ads, snames.h, snames.adb: Add entries for attribute Old + Add entry for pragma Optimize_Alignment + New standard names Sync and Synchronize + +2008-03-26 Robert Dewar + Arnaud Charlet + + * exp_ch11.adb (Expand_At_End_Handler): Set From_At_End flag on raise + stmt. + (No_Exception_Propagation_Active): New function. + (Expand_Exception_Handlers): Use No_Exception_Propagation_Active. + Update comments, and review all uses of No_Exception_Propagation, which + are now correct and in sync with what gigi expects. + + * restrict.ads, restrict.adb (No_Exception_Propagation_Active): New + function. + (Expand_Exception_Handlers): Use No_Exception_Propagation_Active. + Update comments, and review all uses of No_Exception_Propagation, which + are now correct and in sync with what gigi expects. + +2008-03-26 Ed Schonberg + + * sem_ch3.adb (Access_Definition): If the access type is the return + result of a protected function, create an itype reference for it + because usage will be in an inner scope from the point of declaration. + (Build_Derived_Record_Type): Inherit Reverse_Bit_Order and + OK_To_Reorder_Components. + (Make_Index): If an overloaded range includes a universal integer + interpretation, resolve to Standard.Integer. + (Analyze_Subtype_Indication): Copy Convention to subtype + (Check_Abstract_Interfaces): Complete semantic checks on the legality of + limited an synchronized progenitors in type declaration and private + extension declarations. + + * exp_ch13.adb (Expand_N_Freeze_Entity): If the scope of the entity is a + protected subprogram body, determine proper scope from subprogram + declaration. + +2008-03-26 Robert Dewar + + * exp_ch4.adb (Expand_N_Op_Concat): Remove special tests for + No_Run_Time_Mode + +2008-03-26 Gary Dismukes + + * exp_ch5.adb (Expand_N_Extended_Return_Statement): Suppress generation + of a heap allocator for a limited unconstrained function return when + resstriction No_Allocators is active. + (Analyze_Allocator): The restriction No_Allocators is now only checked + on allocators that have Comes_From_Source set, as per RM-H.4(7). + + * sem_ch4.adb (Expand_N_Extended_Return_Statement): Suppress generation + of a heap allocator for a limited unconstrained function return when + resstriction No_Allocators is active. + (Analyze_Allocator): The restriction No_Allocators is now only checked + on allocators that have Comes_From_Source set, as per RM-H.4(7). + (Has_Fixed_Op): If the name in a function call is Standard."*" and the + operands are fixed-point types, the universal_fixed predefined operation + is used, regardless of whether the operand type (s) have a primitive + operation of the same name. + +2008-03-26 Javier Miranda + + * exp_disp.adb (Make_DT, Make_Secondary_DT): Set attribute + Is_Static_Dispatch_Table + (Build_Dispatch_Tables): Replace calls to Exchange_Entities() by calls + to Exchange_Declarations to exchange the private and full-view. Bug + found working in this issue. + (Expand_Dispatching_Call): Propagate the convention of the subprogram + to the subprogram pointer type. + (Make_Secondary_DT): Replace generation of Prim'Address by + Address (Prim'Unrestricted_Access) + (Make_DT): Replace generation of Prim'Address by + Address (Prim'Unrestricted_Access) + (Make_Disp_*_Bodies): When compiling for a restricted profile, use + simple call form for single entry. + (Make_DT): Handle new contents of Access_Disp_Table (access to dispatch + tables of predefined primitives). + (Make_Secondary_DT): Add support to handle access to dispatch tables of + predefined primitives. + (Make_Tags): Add entities to Access_Dispatch_Table associated with + access to dispatch tables containing predefined primitives. + + * exp_ch6.adb (N_Pragma): Chars field removed, use Chars + (Pragma_Identifier (.. instead, adjustments throughout to accomodate + this change. + (Register_Predefined_DT_Entry): Updated to handle the new contents + of attribute Access_Disp_Table (pointers to dispatch tables containing + predefined primitives). + + * exp_util.ads, exp_util.adb (Corresponding_Runtime_Package): New + subprogram. + (Find_Interface_ADT): Updated to skip the new contents of attribute + Access_Dispatch_Table (pointers to dispatch tables containing predefined + primitives). + + * sem_util.adb (Has_Abstract_Interfaces): Add missing support for + concurrent types. + (Set_Convention): Use new function Is_Access_Subprogram_Type + (Collect_Interfaces_Info): Updated to skip the new contents of attribute + Access_Dispatch_Table (pointers to dispatch tables containing predefined + primitives). + + * exp_atag.ads, exp_atag.adb (Build_Inherit_Predefined_Prims): Improve + expanded code avoiding calls to Build_Predef_Prims. + (Build_Set_Predefined_Prim_Op_Address): Improve expanded code avoiding + call to Build_Get_Predefined_Prim_Op_Address. + +2008-03-26 Javier Miranda + + * exp_ch7.adb (Make_Clean): Code cleanup using the new centralized + subprogram Corresponding_Runtime_Package to know the runtime package + that will provide support to a given protected type. + + * exp_ch9.adb (Add_Private_Declarations, + Build_Protected_Subprogram_Call, + Build_Protected_Entry, Build_Simple_Entry_Call, + Expand_N_Protected_Body, Expand_N_Protected_Type_Declaration, + Expand_N_Timed_Entry_Call, Make_Initialize_Protection): Code + cleanup using the new centralized subprogram Corresponding_Runtime + Package to know the runtime package that provides support to + a given protected type. + +2008-03-26 Ed Schonberg + + * exp_pakd.adb (Expand_Bit_Packed_Element_Set): If the component + assignment is within the initialization procedure for a packed array, + and Initialize_Scalars is enabled, compile right-hand side with checks + off, because the value is purposely out of range. + +2008-03-26 Vincent Celier + + * gnatcmd.adb: Add processing for GNAT SYNC + + * vms_conv.ads: (Command_Type): Add command Sync + + * vms_conv.adb (Initialize): Add Command_List data for new command Sync + + * vms_data.ads: Add entries for -gnatw.w + Add qualifier for gnatstub --header-file option + Add switches for GNAT SYNC + + * prj-attr.ads, prj-attr.adb: Add new package Synchronize for GNAT SYNC + (Add_Package_Name): New procedure + (Package_Name_List): New function + (Initialize): Add known package names to the list + (Register_New_Package): Add the new package name to the list + +2008-03-26 Robert Dewar + + * g-pehage.adb, g-regist.adb, g-spipat.ads, g-spipat.adb, + s-asthan.adb, s-parint.adb, s-rpc.adb, s-stchop.adb: Replace + Raise_Exception by "raise with" construct. + +2008-03-26 Pascal Obry + + * Makefile.in: Add proper GNAT.Serial_Communications implementation on + supported platforms. + + * Makefile.rtl: Add g-sercom.o. + + * impunit.adb: Add g-sercom.adb. + + * s-crtl.ads (open): New routine. + (close): Likewise. + (write): Likewise. + + * s-osinte-mingw.ads (BYTE): New type. + (CHAR): Likewise. + (OVERLAPPED): Likewise. + (GENERIC_READ): New constant. + (GENERIC_WRITE): Likewise. + (OPEN_EXISTING): Likewise. + (PSECURITY_ATTRIBUTES): Removed this type, use anonymous access + type instead. + (CreateFile): New routine. + (WriteFile): Likewise. + (ReadFile): Likewise. + (CloseHandle): Move next to the other file oriented routines. + + * g-sercom.ads: New unit. + + * g-sercom.adb: Default implementation, calls to this unit will raise + a program error exception. + + * g-sercom-mingw.adb, g-sercom-linux.adb: Windows and + GNU/Linux implementations. + +2008-03-26 Robert Dewar + + * itypes.adb (Create_Itype): Use new name Access_Subprogram_Kind + + * sem_ch13.adb (Validate_Unchecked_Conversion): Give warning for + unchecked conversion for different conventions only for subprogram + pointers or on VMS. + +2008-03-26 Vincent Celier + + * osint-c.adb (Set_Library_Info_Name): Use canonical case file names + to check if the specified object file is correct. + +2008-03-26 Thomas Quinot + + * sem_cat.adb (Validate_RACW_Primitives): Do not rely on + Comes_From_Source to exclude primitives from being checked. We want to + exclude predefined primitives only, so use the appropriate specific + predicate. Also, flag a formal parameter of an anonymous + access-to-subprogram type as illegal for a primitive operation of a + remote access to class-wide type. + +2008-03-26 Vincent Celier + + * prj-dect.adb (Parse_Package_Declaration): When a package name is not + known, check if it may be a missspelling of a known package name. In + not verbose, not mode, issue warnings only if the package name is a + possible misspelling. + In verbose mode, always issue a warning for a not known package name, + plus a warning if the name is a misspelling of a known package name. + + * prj-part.adb (Post_Parse_Context_Clause): Modify so that only non + limited withs or limited withs are parse during one call. + (Parse_Single_Project): Post parse context clause in two passes: non + limited withs before current project and limited withs after current + project. + + * prj-proc.adb (Imported_Or_Extended_Project_From): Returns an extended + project with the name With_Name, even if it is only extended indirectly. + (Recursive_Process): Process projects in order: first single withs, then + current project, then limited withs. + + * prj-tree.adb (Imported_Or_Extended_Project_Of): Returns an extended + project with the name With_Name, even if it is only extended indirectly. + +2008-03-26 Robert Dewar + + * scn.adb (Initialize_Scanner): Format messages belong on standard error + +2008-03-26 Ed Schonberg + + * sem_ch10.adb (Analyze_Compilation_Unit): if a unit in the context is + a generic subprogram that is imported, do not attempt to compile + non-existent body. + + * sem_ch12.adb (Instantiate_Subprogram_Body): if the generic is + imported, do not generate a raise_program_error for the non-existent + body. + (Pre_Analyze_Actuals): If an error is detected during pre-analysis, + perform minimal name resolution on the generic to avoid spurious + warnings. + (Find_Actual_Type): the designated type of the actual in a child unit + may be declared in a parent unit without being an actual. + +2008-03-26 Robert Dewar + + * sem_ch11.adb: Fix No_Exception_Restriction violation for SJLJ + * sinfo.ads, sinfo.adb (From_At_End): New flag + +2008-03-26 Ed Schonberg + + * sem_ch6.adb (Analyze_Subprogram_Body): Remove spurious check on + operations that have an interface parameter. + (Analyze_Subprogram_Body): Set Is_Trivial_Subprogram flag + Don't treat No_Return call as raise. + + * sem_disp.adb (Check_Dispatching_Operations): apply check for + non-primitive interface primitives to access parameters, not to all + parameters of an access type. + +2008-03-26 Ed Schonberg + + * sem_ch7.adb (Install_Parent_Private_Declarations): If the private + declarations of a parent unit are made visible when compiling a child + instance, the parent is not a hidden open scope, even though it may + contain other pending instance. + + * sem_ch8.adb (Restore_Scope_Stack): If an entry on the stack is a + hidden open scope for some child instance, it does affect the + visibility status of other stach entries. + (Analyze_Object_Renaming): Check that a class-wide object cannot be + renamed as an object of a specific type. + +2008-03-26 Robert Dewar + + * sem_res.adb (Check_Infinite_Recursion): Diagnose definite infinite + recursion and raise SE directly. + (Resolve_Actuals): Reset Never_Set_In_Source if warnings off is + set for formal type for IN mode parameter. + +2008-03-26 Robert Dewar + + * sem_warn.ads, sem_warn.adb (Warnings_Off_Pragmas): New table + (Initialize): New procedure + (Output_Warnings_Off_Warnings): New procedure + (Check_References): Suppress certain msgs if Is_Trivial_Subprogram + (Output_Non_Modifed_In_Out_Warnings): Ditto + (Warn_On_Unreferenced_Entity): Ditto + +2008-03-26 Vincent Celier + + * a-direct.adb (Start_Search): Raise Use_Error if the directory is not + readable. + +2008-03-26 Matthew Heaney + + * a-ciorse.ads, a-cidlli.ads, a-cdlili.ads, a-cihase.ads, a-cohase.ads, + a-ciorma.ads, a-coorma.ads, a-ciormu.ads, a-coormu.ads, a-coorse.ads: + Marked with clauses as private, and controlled operations as overriding + +2008-03-26 Robert Dewar + + * g-byorma.adb (Read_BOM): Reorder tests so that UTF_32 is recognized + +2008-03-26 Robert Dewar + + * back_end.adb, back_end.ads: Minor reformatting + + * bindgen.adb: Minor clarification of comments + + * fname.ads: Minor comment fixes + + * g-altive.ads, g-catiio.ads, g-trasym.ads, prj.ads, + prj-nmsc.adb, sem_aggr.adb: Minor reformatting + + * xeinfo.adb, xnmake.adb, xsinfo.adb, xtreeprs.adb, + xsnames.adb: Remove warnings off pragma no longer needed + + * a-catizo.ads, a-calari.ads, a-calfor.adb, + a-calfor.ads: Fix header. + +2008-03-26 Tristan Gingold + + * init.c: Do not adjust pc for HPARITH on alpha/vms. + +2008-03-26 Robert Dewar + + * lib-xref.adb: (OK_To_Set_Reference): New function + (Generate_Reference): Don't set referenced from occurrence in Warnings, + Unmodified, or Unreferenced pragma + +2008-03-26 Robert Dewar + + * alloc.ads: Add entries for Warnings_Off_Pragmas table + +2008-03-26 GNAT Script + + * Make-lang.in: Makefile automatically updated + +2008-03-26 Robert Dewar + + * tbuild.ads, tbuild.adb, trans.c, sprint.adb, exp_prag.adb, decl.c, + par-ch2.adb, sem_elab.adb, sem_util.ads (N_Pragma): Chars field + removed, use Chars (Pragma_Identifier (.. instead, adjustments + throughout to accomodate this change. + + * s-pooglo.ads, s-pooloc.ads: Minor comment updates + + * exp_dbug.adb: Use Sem_Util.Set_Debug_Info_Needed (not + Einfo.Set_Needs_Debug_Info) + +2008-03-26 Robert Dewar + + * gnat_ugn.texi: Add documentation for -gnatw.w/-gnatw.W + Add description for the new gnatstub option '--header-file' + clarification of -gnatwz/-gnatwZ + Add a "Irix-Specific Considerations" section to document the need to + set LD_LIBRARY_PATH when using the default shared runtime library. + Added documentation for both gcov and gprof. + + * gnat_rm.texi: Document that pragma Compile_Time_Warning generates + messages that are not suppressed when clients are compiled. + Add documentation of s-pooglo s-pooloc + Document the new GNAT.Serial_Communications API. + Add documentation for 'Old attribute + Add description of pragma Optimize_Alignment + + * ug_words: Add entries for -gnatw.w -gnatw.W + + * usage.adb: Add line for -gnatw.w (warn on warnings off) + +2008-03-25 Eric Botcazou + + Revert + 2008-03-05 Eric Botcazou + PR ada/35186 + * decl.c (maybe_pad_type): Avoid padding an integral type when + bumping its alignment is sufficient. + +2008-03-25 Arnaud Charlet + + * exp_ch6.adb, exp_disp.adb: Update copyright notice. + Fix wrong formatting (lines too long) + +2008-03-24 Ralf Wildenhues + + * 9drpc.adb, a-caldel-vms.adb, a-caldel.adb, + a-calend-vms.adb, a-calend.adb, a-calend.ads, + a-calfor.adb, a-chahan.ads, a-chtgke.adb, + a-cihama.ads, a-ciorse.adb, a-clrefi.ads, + a-cohama.ads, a-comlin.ads, a-coorse.adb, + a-crbtgk.adb, a-direct.adb, a-except-2005.adb, + a-except-2005.ads, a-except.adb, a-except.ads, + a-exexda.adb, a-exexpr-gcc.adb, a-exexpr.adb, + a-exextr.adb, a-filico.ads, a-finali.ads, + a-intnam-aix.ads, a-intnam-solaris.ads, a-ngcefu.adb, + a-ngelfu.adb, a-numaux-darwin.adb, a-numeri.ads, + a-sequio.ads, a-strbou.ads, a-strfix.adb, + checks.adb, exp_ch3.adb, exp_ch4.adb, + exp_ch4.ads, exp_ch5.adb, exp_ch6.adb, + exp_ch6.ads, exp_ch7.adb, exp_ch7.ads, + exp_ch9.adb, exp_ch9.ads, exp_dbug.adb, + exp_dbug.ads, exp_disp.adb, exp_dist.adb, + exp_dist.ads, exp_fixd.adb, exp_fixd.ads: Fix comment typos. + +2008-03-24 Robert Dewar + + * s-tpopsp-posix.adb, s-tpopsp-solaris.adb, s-tpopsp-posix-foreign.adb, + s-tpopsp-lynxos.adb, s-tpopde-vms.ads, s-tpopde-vms.adb, + s-tpopsp-vxworks.adb, s-casi16.adb, s-caun16.adb, s-inmaop.ads, + s-tadeca.adb, s-tadeca.ads, s-tadert.adb, s-tadert.ads, s-tpinop.adb, + s-tpinop.ads, s-tporft.adb, a-rbtgso.adb, a-crbtgo.ads, a-crbtgo.adb, + a-crbtgk.ads, a-crbtgk.adb, a-ciorse.adb, a-cihama.ads, a-cihama.adb, + a-cidlli.ads, a-cidlli.adb, a-chtgop.ads, a-chtgop.adb, a-cgcaso.ads, + a-cgcaso.adb, a-cgaaso.adb, a-ciormu.adb, a-cihase.adb, a-swuwha.ads, + a-rbtgso.ads, a-cgaaso.ads, a-cgaaso.ads, a-ciorma.adb, a-chtgke.ads, + a-chtgke.adb, a-llfzti.ads, a-ztenau.adb, a-ztenau.ads, a-stzhas.ads, + a-szbzha.ads, a-szbzha.adb, a-crdlli.ads, a-crdlli.ads, a-crdlli.adb, + i-forbla-darwin.adb, i-forbla.ads, s-regexp.adb, a-nllrar.ads, + a-nlrear.ads, a-nucoar.ads, a-nurear.ads, i-forlap.ads, s-gearop.adb, + s-gearop.ads, s-gecobl.adb, s-gecobl.ads, s-gecola.adb, s-gecola.ads, + s-gerebl.adb, s-gerela.ads, a-swuwha.adb, i-forbla-unimplemented.ads, + double spaced if it fits on one line and otherwise single spaced. + +2008-03-24 Ralf Wildenhues + + PR documentation/15479 + * Make-lang.in (doc/gnat_ugn.texi) Renamed from ... + (doc/gnat_ugn_unw.texi): ... this, and adjusted. + (doc/gnat_ugn.info): Renamed from ... + (doc/gnat_ugn_unw.info): ... this. + (doc/gnat_ugn.dvi): Renamed from ... + (doc/gnat_ugn_unw.dvi): ... this. + (doc/gnat_ugn.pdf): Renamed from ... + (doc/gnat_ugn_unw.pdf): ... this. + (ADA_INFOFILES, ADA_PDFFILES, ada.install-info, ada.dvi): + Adjusted. + * gnat_ugn.texi (FILE): Hard-code gnat_ugn; set filename + unconditionally to gnat_ugn.info. Fix cross references to the + GNAT Reference Manual. Convert links to the GCC, GDB, Emacs, + and GNU make manuals to be proper texinfo links. + * gnat_rm.texi: Fix cross references to the GNAT User's Guide. + +2008-03-21 Olivier Hainque + + * trans.c (Attribute_to_gnu) <'length>: Compute as (hb < lb) + ? 0 : hb - lb + 1 instead of max (hb - lb + 1, 0). + +2008-03-21 Eric Botcazou + + * trans.c (addressable_p): Add notes on addressability issues. + +2008-03-21 Olivier Hainque + Ed Schonberg + + * trans.c (addressable_p): Accept COND_EXPR when both arms + are addressable. + (gnat_gimplify_expr): Let the gimplifier handle &COND_EXPR. + (call_to_gnu): Do not use name reference in the error message + for a misaligned by_reference_parameter. The actual may be a + general expression. + +2008-03-18 Paolo Bonzini + + * misc.c (LANG_HOOKS_REDUCE_BIT_FIELD_OPERATIONS): Delete. + +2008-03-15 Ralf Wildenhues + + * gnat_rm.texi (Implementation Defined Characteristics) + (Wide_Text_IO, Wide_Wide_Text_IO): Add @var annotations where + appropriate. + * gnat_ugn.texi (Wide Character Encodings, Switches for gnatbind) + (Switches for gnatchop, Installing a library): Likewise. + +2008-03-10 Eric Botcazou + + * trans.c (emit_range_check): Do not emit the check if the base type + of the expression is the type against which its range must be checked. + +2008-03-08 Eric Botcazou + + * decl.c (maybe_pad_type): Use value_factor_p. + +2008-03-08 Eric Botcazou + + * lang.opt (nostdlib): Move around. + * misc.c (gnat_handle_option): Fix formatting. + (gnat_dwarf_name): Move around. + * trans.c (Case_Statement_to_gnu): Fix formatting. + (gnat_to_gnu): Likewise. + * utils.c (aggregate_type_contains_array_p): Likewise. + (create_subprog_decl): Likewise. + +2008-03-08 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : Do not + bother propagating the TYPE_USER_ALIGN flag when creating a JM type. + +2008-03-08 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : Do not force + BIGGEST_ALIGNMENT when capping the alignment of records with + strict alignment and size clause. + +2008-03-08 Eric Botcazou + + * lang-specs.h: Pass -gnatwa if -Wall is passed. + * misc.c (gnat_handle_option) : Expand into -Wunused + and -Wuninitialized. + (gnat_post_options): Clear warn_unused_parameter. + +2008-03-08 Eric Botcazou + + * utils.c (finish_record_type): Clear DECL_BIT_FIELD on sufficiently + aligned bit-fields, bumping the alignment of the record type if deemed + profitable. + (value_factor_p): Return false instead of 0. + +2008-03-08 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : Add support + for scalar types with small alignment. + +2008-03-08 Eric Botcazou + + * trans.c (Loop_Statement_to_gnu): Set the SLOC of the loop label + from that of the front-end's end label. + (gnat_gimplify_stmt) : Set the SLOC of the backward goto + from that of the loop label. + +2008-03-07 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : Add + comment for the packed array type case. + * utils.c (build_template): Use a loop to strip padding or + containing records for justified modular types. + +2008-03-07 Eric Botcazou + + * decl.c (gnat_to_gnu_entity): Issue a warning on suspiciously + large alignments specified for types. + (validate_alignment): Minor cleanup. + +2008-03-07 Eric Botcazou + + * decl.c (MAX_FIXED_MODE_SIZE): Define if not already defined. + (gnat_to_gnu_entity) : Try to get a smaller form of + the component for packing, if possible, as well as if a component + size clause is specified. + : For an array type used to implement a packed + array, get the component type from the original array type. + Try to get a smaller form of the component for packing, if possible, + as well as if a component size clause is specified. + (round_up_to_align): New function. + (make_packable_type): Add in_record parameter. + For a padding record, preserve the size. If not in_record and the + size is too large for an integral mode, attempt to shrink the size + by lowering the alignment. + Ditch the padding bits of the last component. + Compute sizes and mode manually, and propagate the RM size. + Return a BLKmode record type if its size has shrunk. + (maybe_pad_type): Use MAX_FIXED_MODE_SIZE instead of BIGGEST_ALIGNMENT. + Use Original_Array_Type to retrieve the type in case of an error. + Adjust call to make_packable_type. + (gnat_to_gnu_field): Likewise. + (concat_id_with_name): Minor tweak. + * trans.c (larger_record_type_p): New predicate. + (call_to_gnu): Compute the nominal type of the object only if the + parameter is by-reference. Do the conversion actual type -> nominal + type if the nominal type is a larger record. + (gnat_to_gnu): Do not require integral modes on the source type to + avoid the conversion for types with identical names. + (addressable_p): Add gnu_type parameter. If it is specified, do not + return true if the expression is not addressable in gnu_type. + Adjust recursive calls. + * utils.c (finish_record_type): Remove dead code. + +2008-03-05 Eric Botcazou + + PR ada/35186 + * decl.c (maybe_pad_type): Avoid padding an integral type when + bumping its alignment is sufficient. + +2008-03-02 Ralf Wildenhues + + * gnatfind.adb, gnatxref.adb: Fix argument parsing typos. + * s-auxdec-empty.adb, s-auxdec.adb: Fix typos in copyright + statement. + * a-ngcoar.adb, a-ngrear.adb, g-awk.adb, g-debpoo.adb, + gprep.adb, make.adb, makegpr.adb, par-ch6.adb, prj-nmsc.adb, + sem_attr.adb, sem_ch4.adb, sem_ch8.adb: Fix typos in ada source + code output strings. + * sem_type.adb, system-vms-ia64.ads, system-vms.ads, + system-vms_64.ads: Fix typos in ada source code comments. + * sinfo-cn.adb: Remove incomplete sentence. + + PR documentation/15479 + * gnat_rm.texi, gnat_ugn.texi: Avoid standalone `non' word. + +2008-02-27 Samuel Tardieu + + PR ada/22255 + * s-fileio.adb (Reset): Do not raise Use_Error if mode isn't changed. + +2008-02-27 Samuel Tardieu + + PR ada/34799 + * sem_ch13.adb (Analyze_Record_Representation_Clause): Check + that underlying type is present. + +2008-02-26 Tom Tromey + + * misc.c (internal_error_function): Remove test of + USE_MAPPED_LOCATION. + * trans.c (gigi): Remove test of USE_MAPPED_LOCATION. + (Sloc_to_locus): Remove old location code. + +2008-02-25 Ralf Wildenhues + + * gnat_rm.texi, gnat_ugn.texi: Fix spacing after `e.g.' and + `i.e.' by adding comma or `@:' as appropriate. + * gnat_rm.texi (Pragma Wide_Character_Encoding): Instead of + plain characters `C', use `@samp{C}'. + * gnat_ugn.texi (File Naming Rules, About gnatkr) + (Krunching Method): Likewise. + + * gnat_ugn.texi (Conventions): List environment variables and + metasyntactic variables. + (Compiling Programs): Fix notation of metasyntactic variables. + Add @file where appropriate. Use @file for file extensions, + @samp for strings. + * gnat_rm.texi, gnat_ugn.texi: Where appropriate, use @samp + instead of @file, @env instead of @code. + +2008-02-24 Ralf Wildenhues + + PR documentation/15479 + * gnat_rm.texi, gnat_ugn.texi: Where appropriate, replace `..' + and `...' with `@dots{}' or `@enddots{}'. + + PR documentation/15479 + * gnat_rm.texi, gnat_ugn.texi: Where appropriate, add @command, + use @command instead of @code, @option instead of @samp or @code, + @code instead of @var, @samp instead of @file. + + PR documentation/15479 + * gnat_ugn.texi (Using gnatmake in a Makefile): Do not ignore errors + in Makefile rules, by using `&&' rather than `;'. + +2008-02-17 Ralf Wildenhues + + PR documentation/15479 + * gnat_ugn.texi: In non-code, avoid space before colon. + (Regular Expressions in gnatfind and gnatxref): Fix indentation. + (Examples of gnatxref Usage): Use @command{vi} instead of + @file{vi}. + (Character Set Control): Do not use @code for UTF-8. + (Validity Checking): Fix typo "NaNs" instead of "NaN's". Do not + use @code for IEEE. + * gnat_rm.texi (Aggregates with static bounds): Fix typo in code + sample. + * gnat_rm.texi, gnat_ugn.texi: Fix typos. Bump copyright years. + +2008-02-11 Joel Sherrill + + PR ada/35143 + * env.c: Add __rtems__ to if defined. + * s-osinte-rtems.adb: Add To_Target_Priority. Fix formatting. + * s-osinte-rtems.ads: Add To_Target_Priority prototype and + PTHREAD_SCOPE_PROCESS/PTHREAD_SCOPE_SYSTEM constants. Add + pragma Convention as required. + * gsocket.h: Make compile in and out of RTS. + * Makefile.in: Add system-rtems.ads. Build DEC extensions. + Use g-soccon-rtems.ads. + * g-soccon-rtems.ads, system-rtems.ads: New files. + +2008-02-06 Kaveh R. Ghazi + + PR other/35107 + * Make-lang.in (gnat1): Add $(GMPLIBS). + +2008-01-26 Eric Botcazou + + * decl.c (components_to_record): Improve comment. + +2008-01-22 Eric Botcazou + + * decl.c (components_to_record): Do not reuse the empty union type + if there is a representation clause on the record. + * trans.c (addressable_p): Return true for INTEGER_CST. + +2008-01-21 Eric Botcazou + + * trans.c (gnat_to_gnu) : Use POINTER_PLUS_EXPR + in pointer arithmetics. + * utils2.c (build_allocator): Likewise. + +2008-01-17 Eric Botcazou + + * utils.c (build_function_stub): Properly build the call expression. + +2008-01-14 Eric Botcazou + + * decl.c (gnat_to_gnu_entity) : Process renamings + before converting the expression to the type of the object. + * trans.c (maybe_stabilize_reference) : New case. + Stabilize constructors for special wrapping types. + +2008-01-13 Eric Botcazou + + * trans.c (call_to_gnu): Invoke the addressable_p predicate only + when necessary. Merge some conditional statements. Update comments. + Rename unchecked_convert_p local variable to suppress_type_conversion. + Do not suppress conversions in the In case. + (addressable_p) : Do not take alignment issues + into account on non strict-alignment platforms. + +2008-01-12 Eric Botcazou + + * utils.c (aggregate_type_contains_array_p): New predicate. + (create_field_decl): In a packed record, force byte alignment + for fields without specified position that contain an array. + +2008-01-12 Eric Botcazou + + * utils.c (unchecked_convert): Fold the VIEW_CONVERT_EXPR expression. + +2008-01-10 John David Anglin + + PR ada/34466 + * s-osinte-linux-hppa.ads (SC_NPROCESSORS_ONLN): New constant for + sysconf call. + (bit_field): New packed boolean type used by cpu_set_t. + (cpu_set_t): New type corresponding to the C type with + the same name. Note that on the Ada side we use a bit + field array for the affinity mask. There is not need + for the C macro for setting individual bit. + (pthread_setaffinity_np): New imported routine. + +2008-01-03 Tero Koskinen + + PR ada/34647 + * adaint.c (__gnat_open_new_temp, __gnat_tmp_name): Use mkstemp() + on OpenBSD as is done on other BSD systems. + + PR ada/34645 + * sysdep.c (__gnat_ttyname, getc_immediate_nowait, + getc_immediate_common): Treat OpenBSD as FreeBSD regarding immediate + I/O. + + PR ada/34644 + * env.c (__gnat_clearenv): Treat OpenBSD as other BSD systems missing + clearenv(). + + PR ada/34646 + * init.c (__gnat_error_handler, __gnat_install_handler, + __gnat_init_float): Define for OpenBSD. + + * initialize.c (__gnat_initialize): Define for OpenBSD. + + + +Copyright (C) 2008 Free Software Foundation, Inc. + +Copying and distribution of this file, with or without modification, +are permitted in any medium without royalty provided the copyright +notice and this notice are preserved. diff --git a/gcc/ada/ChangeLog-2009 b/gcc/ada/ChangeLog-2009 new file mode 100644 index 000000000..cf22b664e --- /dev/null +++ b/gcc/ada/ChangeLog-2009 @@ -0,0 +1,12171 @@ +2009-12-10 Eric Botcazou + + * s-linux-sparc.ads: New file. + * gcc-interface/Makefile.in (SPARC/Linux): Use it. + +2009-12-04 Eric Botcazou + + * gcc-interface/trans.c (add_decl_expr): At toplevel, mark the + TYPE_ADA_SIZE field of records and unions. + + * gcc-interface/trans.c (Attribute_to_gnu) : Set the + source location of the node onto the comparison expression if it + is not cached. + +2009-12-03 Eric Botcazou + + * exp_util.adb (Make_CW_Equivalent_Type): Set the + Is_Class_Wide_Equivalent_Type flag here in lieu of... + (Make_Subtype_From_Expr): ...here. + * exp_ch3.adb (Expand_Freeze_Record_Type): Do not set + Has_Controlled_Component on class-wide equivalent types. + * freeze.adb (Freeze_Record_Type): Likewise. + * sem_ch3.adb (Record_Type_Definition): Likewise. + +2009-12-01 Pascal Obry + + * s-osprim-mingw.adb (Get_Base_Time): Make sure that the base time is + taken at a clock tick boundary. + +2009-12-01 Thomas Quinot + + * g-sechas.ads (GNAT.Secure_Hashes.H."=" on Context): Make abstract. + +2009-12-01 Matthew Gingell + + * adadecode.c: Allow compilation when building the run time in the gnat + runtime. + (__gnat_decode): Strip the .nnnn suffix from names of nested functions. + + * gcc-interface/Makefile.in: Ada adadecode to LIBGNAT_SRCS and + LIBGNAT_OBJS. + +2009-12-01 Vincent Celier + + * gnatcmd.adb (Check_Files): Quote the path names as they may include + spaces. + +2009-12-01 Ed Schonberg + + * sem_ch3.adb (Analyze_Object_Declaration): If the defining identifier + has already been declared, it may have been rewritten as a renaming + declaration. + +2009-12-01 Ed Schonberg + + * einfo.ads: Clarify use of Is_Private_Primitive. + * sem_ch6.adb (Analyze_Subprogram_Declaration): An operation is a + private primitive operation only if it is declared in the scope of the + private controlling type. + * exp_ch9.adb (Build_Wrapper_Spec): Build wrappers for private + protected operations as well. + +2009-12-01 Arnaud Charlet + + * gnat1drv.adb (Adjust_Global_Switches): Disable front-end + optimizations in CodePeer mode, to keep the tree as close to the source + code as possible, and also to avoid inconsistencies between trees when + using different optimization switches. + +2009-12-01 Thomas Quinot + + * scos.ads: Updated specification of source coverage obligation + information. + +2009-12-01 Thomas Quinot + + * g-sercom.ads, g-sercom-mingw.adb, g-sercom-linux.adb, + a-ststio.adb, s-commun.adb, s-commun.ads, g-socket.adb, + g-socket.ads (System.Communications.Last_Index): For the case where no + element has been transferred and Item'First = + Stream_Element_Offset'First, raise CONSTRAINT_ERROR. + +2009-12-01 Ed Schonberg + + * sem_ch10.adb (Install_Siblings): A private with_clause on some child + unit U in an ancestor of the current unit must be ignored if the + current unit has a regular with_clause on U. + +2009-11-30 Rainer Orth + + * s-oscons-tmplt.c [__mips && __sgi]: Only define _XOPEN5, IOV_MAX + if _XOPEN_IOV_MAX is defined. + +2009-11-30 Vasiliy Fofanov + + * vms_data.ads: Add new VMS qualifiers, + REVERSE_BIT_ORDER/NOREVERSE_BIT_ORDER, to support warnings on bit order + effects. + +2009-11-30 Thomas Quinot + + * exp_ch9.adb, exp_ch9.ads, sem_util.ads: Minor reformatting. + +2009-11-30 Gary Dismukes + + * sem_prag.adb: Fix spelling error. + +2009-11-30 Ed Schonberg + + * exp_ch9.ads (Build_Private_Protected_Declaration): For a protected + operation that is only declared in a protected body, create a + corresponding subprogram declaration. + * exp_ch9.adb (Expand_N_Protected_Body): Create protected body of + operation in all cases, including for an operation that is only + declared in the body. + * sem_ch6.adb: Call Build_Private_Protected_Declaration + * exp_ch6.adb (Expand_N_Subprogram_Declaration): For an operation + declared in a protected body, create the declaration for the + corresponding protected version of the operation. + +2009-11-30 Arnaud Charlet + + * gnat1drv.adb (Adjust_Global_Switches): Disable specific expansions + for Restrictions pragmas, to avoid tree inconsistencies between + compilations with different pragmas. + +2009-11-30 Jerome Lambourg + + * sem_prag.adb (Check_Duplicated_Export_Name): Allow entities exported + to CIL to have duplicated export name. + +2009-11-30 Robert Dewar + + * a-tiinio.adb: Remove extraneous pragma Warnings (Off). + +2009-11-30 Thomas Quinot + + * par_sco.adb: Minor reformatting + +2009-11-30 Ed Falis + + * s-vxwext.ad[s,b], system-vxworks-ppc.ads, s-stchop-vxworks.adb: + Comment update. + +2009-11-30 Ed Schonberg + + * par_sco.adb (Traverse_Handled_Statement_Sequence): Do not emit SCO's + for null statements that do not come from source. + * sinfo.ads: Clarify documentation of Comes_From_Source + +2009-11-30 Vincent Celier + + * prj-nmsc.adb (Add_Source): Use Display_Name for both projects when + displaying the paths in error message. + +2009-11-30 Emmanuel Briot + + * adaint.h, adaint.c (file_attributes): force the use of unsigned char. + On some platforms, "char" is signed, on others unsigned, so we + explicitly specify the one we expect + +2009-11-30 Matthew Heaney + + * a-coinve.adb (Insert): Move exception handler closer to point where + exception can occur. + Minor reformatting & comment additions. + +2009-11-30 Arnaud Charlet + + * freeze.adb (Freeze_Entity): Disable warning on 'Foreign caller must + pass bounds' for VM targets, not relevant. + +2009-11-30 Robert Dewar + + * sem_util.adb (Wrong_Type): Diagnose additional case of modular + missing parens. + * a-tiinio.adb, a-wtinio.adb, a-ztinio.adb: Minor reformatting + + * exp_util.adb (Kill_Dead_Code): Suppress warning for some additional + cases. + + * sem_warn.adb (Set_Warning_Flag): Clean up gnatwA list and ensure + completeness. + (Set_Dot_Warning_Flag): Ditto for -gnatw.e + (Set_Dot_Warning_Flag): Implement -gnbatw.v/w.V + * usage.adb: Add lines for -gnatw.v/w.V + +2009-11-30 Emmanuel Briot + + * make.adb (Check_Standard_Library): use Full_Source_Name instead of + direct call to Find_File. The former provides caching of the results, so + might be more efficient + (Start_Compile_If_Necessary): Add comment on possible optimization, + not done for now. + +2009-11-30 Thomas Quinot + + * g-sechas.adb: Minor reformatting + +2009-11-30 Matthew Heaney + + * a-crbtgo.adb (Delete_Fixup): Add comments explaining why predicates + were removed. + * a-cdlili.adb (Vet): Remove always-true predicates. + +2009-11-30 Thomas Quinot + + * s-sechas.adb, s-sechas.ads, s-shshco.adb, s-shshco.ads, s-shsh64.adb, + s-shsh64.ads, s-sehamd.adb, s-sehamd.ads, s-shsh32.adb, s-shsh32.ads, + s-sehash.adb, s-sehash.ads, g-sechas.adb, g-sechas.ads, g-shshco.adb, + g-shshco.ads, g-md5.ads, g-sha256.ads, g-shsh64.adb, g-shsh64.ads, + g-sehamd.adb, g-sehamd.ads, g-sha512.ads, g-sha1.ads, Makefile.rtl, + g-sha224.ads, g-shsh32.adb, g-shsh32.ads, g-sha384.ads, g-sehash.adb, + g-sehash.ads: Rename System.Secure_Hashes to GNAT.Secure_Hashes. + +2009-11-30 Robert Dewar + + * osint.ads: Minor comment update. + +2009-11-30 Thomas Quinot + + * s-sechas.adb: Fix swapping error in previous checkin. + * g-md5.ads, g-sha256.ads, g-sha512.ads, g-sha1.ads, g-sha224.ads, + g-sha384.ads: Add missing documentation. + +2009-11-30 Robert Dewar + + * g-sha256.ads, s-sehamd.ads, s-sehamd.adb, g-sha512.ads, g-sha224.ads, + g-sha384.ads: Minor reformatting + +2009-11-30 Emmanuel Briot + + * adaint.h (file_attributes): Reduce size of the structure, so that it + is less costly to store in records. + * makeutl.adb: + (Check_Source_Info_In_ALI): use Full_Source_Name instead of a direct + call to Find_File, since the former provides caching when appropriate, + which limits the number of system calls in some cases. + * osint.ads, prj.ads (Source_Data): do not store directly the timestamp, + but the file attributes since we also need access to the size of the + ALI file to parse it. This gives an opportunity for saving system calls + on Unix systems. + +2009-11-30 Robert Dewar + + * sem_prag.adb, s-sechas.ads, s-sechas.adb: Minor reformatting. + +2009-11-30 Gary Dismukes + + * sem_prag.adb (Process_Convention): Change formal E to Ent. In the + case where the pragma's entity argument is a renaming, return the + entity denoted by the renaming rather than the renamed entity. Loop + through the homonyms of the original argument entity, rather than the + homonyms of any renamed entity. Correct call to Generate_Entity to + pass the homonym. + +2009-11-30 Vincent Celier + + * impunit.adb: Add packages that were added to the GNAT library: + GNAT.SHA224, GNAT.SHA256, GNAT.SHA384 and GNAT.SHA512. + * s-sechas.adb (Fill_Buffer_Copy): Fixes incorrect slice index + +2009-11-30 Robert Dewar + + * exp_ch3.adb: Minor reformatting + * g-md5.ads, g-sha1.ads: Add comment. + +2009-11-30 Arnaud Charlet + + * gcc-interface/Makefile.in: Remove handling of libgccprefix, no longer + needed. + +2009-11-30 Pascal Obry + + * expect.c: Fix cast to avoid warnings in x86-64 Windows. + +2009-11-30 Thomas Quinot + + * gnat_rm.texi, s-sechas.adb, s-sechas.ads, s-shshco.adb, + s-shshco.ads, g-md5.adb, g-md5.ads, g-sha256.ads, s-shsh64.adb, + s-shsh64.ads, s-sehamd.adb, s-sehamd.ads, g-sha512.ads, g-sha1.adb, + g-sha1.ads, Makefile.rtl, g-sha224.ads, g-sha384.ads, s-shsh32.adb, + s-shsh32.ads, s-sehash.adb, s-sehash.ads: Reimplementation of GNAT.MD5 + and GNAT.SHA1 to factor shared code and avoid unnecessary stack copies. + Also introduce new functions SHA-{224,256,384,512} + +2009-11-30 Jerome Lambourg + + * exp_ch3.adb (Make_Predefined_Primitive_Specs): Improve comment for + the Value_Type case. + +2009-11-30 Thomas Quinot + + * a-textio.adb: Minor reformatting + +2009-11-30 Pascal Obry + + * adaint.c: Fix bug in passing parameter. + * expect.c: Include io.h to get definition of _open_osfhandle + +2009-11-30 Javier Miranda + + * exp_ch6.adb, sem_scil.adb (Adjust_SCIL_Node): Add missing management + of N_Unchecked_Type_Conversion nodes when searching for SCIL nodes. + (Expand_Call): Adjust decoration of SCIL node associated with relocated + function call. + +2009-11-30 Emmanuel Briot + + * prj-env.adb (Add_To_Source_Path): Preserve casing of directories + +2009-11-30 Vincent Celier + + * opt.ads (No_Split_Units): New flag initialized to False + +2009-11-30 Jerome Lambourg + + * exp_ch7.adb (Needs_Finalization): Add comments. + * exp_ch3.adb (Make_Predefined_Primitive_Specs): Improve handling of + CIL Value types. + +2009-11-30 Robert Dewar + + * osint.adb, a-rttiev.adb: Minor reformatting. + +2009-11-30 Robert Dewar + + * gnat_rm.texi: Remove list of warning letters, and refer instead to + using gnatmake to get a brief list. + + * debug.adb: Document -gnatd.i to disable pragma Warnings + * par-prag.adb, sem_prag.adb: Recognize -gnatd.i to disable Warnings + pragma. + * vms_data.ads: Add /NOWARNINGS_PRAGMS for -gnatd.i + +2009-11-30 Geert Bosch + + * a-ngelfu.adb (Sin): Correct spelling of sine in comment. + +2009-11-30 Vincent Celier + + * gnatls.adb: Do not call Get_Target_Parameters in Verbose_Mode, as it + is not needed and gnatls fails when called with -v -nostdinc. + +2009-11-30 Emmanuel Briot + + * osint.adb, osint.ads (File_Time_Stamp): new subprogram. + +2009-11-30 Ed Schonberg + + * gnat_rm.texi, gnat_ugn.texi: Document new syntax for pragma Annotate + +2009-11-30 Robert Dewar + + * scans.ads (Wide_Wide_Character_Found): New flag + * scn.adb (Post_Scan): Set new flag Has_Wide_Wide_Character + * scng.adb (Set_String): Set new flag Wide_Wide_Character_Found + (Set_String): Fix failure to reset Wide_Character_Found + * sinfo.adb (Has_Wide_Wide_Character): New flag in N_String_Literal + * sinfo.ads (Has_Wide_Wide_Character): New flag in N_String_Literal + * a-ngelfu.adb: Minor reformatting & code reorganization. + * usage.adb: Fix typo in -gnatw.W line + +2009-11-30 Robert Dewar + + * osint.adb, prj-nmsc.adb, sem_prag.adb, sem_util.adb: Minor + reformatting. + * csinfo.adb: Terminate run if improper use of reserved flag + * sinfo.ads, sinfo.adb (Is_Accessibility_Actual): Don't use reserved + Flag12, used Flag13 instead. + +2009-11-30 Vincent Celier + + * gnatcmd.adb (Check_Files): Recognize documented switches that have a + separate parameter. + +2009-11-30 Robert Dewar + + * sem_util.ads: Minor reformatting + * errout.adb: Minor reformatting + Minor code reorganization (use N_Subprogram_Specification to simplify) + * exp_ch7.adb: Add comment. + +2009-11-30 Thomas Quinot + + * put_scos.adb (Put_SCOs): Do not generate a SCO unit header for a unit + that has no SCOs. + * scos.ads: Minor reformatting + +2009-11-30 Ed Schonberg + + * sem_prag.adb: Second unanalyzed parameter of Annotate is optional. + +2009-11-30 Eric Botcazou + + * init.c (__gnat_adjust_context_for_raise, Linux version): Add guard + for null PC saved in the context. + +2009-11-30 Hristian Kirtchev + + * a-calend.adb (Day_Of_Week): Rewritten. The routine determines the + number of days from the Ada Epoch to the input date while ensuring that + both dates are in the same time zone. + +2009-11-30 Emmanuel Briot + + * clean.adb ("-eL"): Also set Follow_Links_For_Dirs, to match what is + done in other project-aware tools like gnatmake and gprbuild. + +2009-11-30 Jerome Lambourg + + * exp_ch3.adb (Make_Predefined_Primitive_Specs): Take care of CIL + ValueTypes. + * exp_ch7.adb (Needs_Finalization): Do not finalize CIL valuetypes. + * sem_util.adb (Is_Value_Type): Protect against invalid calls to Chars + (Is_Delegate): New method used for CIL. + * sem_util.ads (Is_Delegate): New method for CIL handling. + (Is_Value_Type): Improve documentation. + +2009-11-30 Ed Schonberg + + * errout.adb (Unwind_Internal_Type): Improve error reporting if the + type is an anonymous access to subprogram that is the type of a formal + in a subprogram spec. + +2009-11-30 Vincent Celier + + * prj-nmsc.adb (Check_Interfaces): In a Stand-Alone Library project, if + attribute Interfaces is not declared, then Library_Interface should + define the interfaces. + +2009-11-30 Ed Schonberg + + * sem_prag.adb: New semantics for Annotate. + +2009-11-30 Tristan Gingold + + * gcc-interface/Makefile.in: Do not link with -static-libgcc on Darwin. + +2009-11-30 Emmanuel Briot + + * gnat_ugn.texi: Extend doc for -eL + +2009-11-30 Vincent Celier + + * osint.adb (Executable_Name (File_Name_Type)): Put the Name in the + Name_Buffer before testing for a dot in the Name. + +2009-11-30 Vincent Celier + + * prj-part.adb (Project_Path_Name_Of): Resolve links for final result + if -eL has been specified. + +2009-11-30 Vincent Celier + + * osint.adb (Executable_Name): Test the name instead of the name buffer + to check if there is a dot in the given name. + +2009-11-30 Sergey Rybin + + * gnat_ugn.texi: Update gnatcheck doc. + +2009-11-30 Robert Dewar + + * sem_ch3.adb, sem_disp.adb, usage.adb: Minor reformatting + +2009-11-30 Vasiliy Fofanov + + * gnat_ugn.texi: Minor editing. + +2009-11-30 Emmanuel Briot + + * prj-nmsc.adb (Search_Directories): when -eL was not specified, assume + that no directory matches the naming scheme for sources. + +2009-11-30 Emmanuel Briot + + * prj.adb, prj.ads, prj-nmsc.adb (Has_Multi_Unit_Sources): New field in + project_data. + +2009-11-30 Vincent Celier + + * osint.adb (Executable_Name): Correctly decide if the executable + suffix should be added when Only_If_No_Suffix is True. + +2009-11-30 Robert Dewar + + * frontend.adb, gnatlink.adb, prj-conf.adb, prj-tree.adb, + prj-tree.ads: Minor reformatting + +2009-11-30 Vincent Celier + + * gnatlink.adb (Process_Args): Call Executable_Name on argument of -o + with Only_If_No_Suffix set to True. + * osint.adb (Executable_Name): Do not add executable suffix if there is + already a suffix and Only_If_No_Suffix is True. + * osint.ads (Executable_Name): New Boolean parameter Only_If_No_Suffix, + defaulted to False. + +2009-11-30 Javier Miranda + + * exp_atag.adb (Build_TSD): Change argument name because the actual is + now the address of a tag (instead of the tag). Update implementation + accordingly. + (Build_CW_Membership): New implementation. Converted into a procedure + because it has an additional out mode parameter. Its implementation has + been rewritten to improve the generated code but also to facilitate + referencing the relocated object node in the caller. + * exp_atag.ads (Build_CW_Membership): Update profile and documentation. + * sinfo.ads (N_SCIL_Membership_Test) New_Node. + (SCIL_Tag_Value): New field of N_SCIL_Membership_Test nodes. + (Is_Syntactic_Field): Add entry of new node. + (SCIL_Tag_Value/Set_SCIL_Tag_Value): New subprograms. + * sinfo.adb (SCIL_Related_Node, SCIL_Entity): Update assertions to + handle N_SCIL_Membership_Test nodes. + (SCIL_Tag_Value/Set_SCIL_Tag_Value): New subprograms. + * sem.adb (Analyze): Add null management for new node. + * sem_scil.adb (Find_SCIL_Node): Add null management for new node. + (Check_SCIL_Node): Add checks of N_SCIL_Membership_Test nodes. + * exp_ch4.adb (Tagged_Membership): Change profile from function to + procedure. Add generation of SCIL node associated with class-wide + membership test. + (Expand_N_In): Complete decoration of SCIL nodes. + * exp_intr.adb (Expand_Dispatching_Constructor_Call): Tune call to + Build_CW_Membership because its profile has been changed. + * exp_util.adb (Insert_Actions): Add null management for new node. + * sprint.adb (Sprint_Node_Actual): Handle new node. + * gcc-interface/trans.c Add no processing for N_SCIL_Membership_Test + nodes. + * gcc-interface/Make-lang.in: Update dependencies. + +2009-11-30 Ed Schonberg + + * opt.ads: New flags Init_Or_Norm_Scalars_Config, + Initialize_Scalars_Config, to capture the presence of the corresponding + pragmas in a configuration file. + * opt.adb (Register_, Save_, Set_, Restore_Opt_Configuration_Switches): + handle new flags so that they are restored for each compilation unit. + * frontend.adb: At the end of compilation, scan the context of the main + unit to recover occurrences of pragma Initialize_Scalars, to annotate + the ALI file accordingly. + +2009-11-30 Vincent Celier + + * prj-tree.ads: Minor comment updates + * prj-tree.adb: Minor reformatting + +2009-11-30 Ed Schonberg + + * sem_ch3.adb (Derive_Subprogram): Indicate that an inherited + predefined control operation is hidden if the parent type is not + visibly controlled. + * sem_ch6.adb (Check_Overriding_Indicator): Do not report error if + overridden operation is not visible, as may be the case with predefined + control operations. + * sem_disp.adb (Check_Dispatching_Operation): Do not emit warning on + non-overriding control operation when type is not visibly controlled, + if the subprogram has an explicit overriding indicator. + * sem_util.ads, sem_util.adb (Is_Visibly_Controlled): Moved here from + sem_disp.adb. + +2009-11-30 Emmanuel Briot + + * prj-tree.adb (Create_Attribute): Fix handling of VMS and Windows + * prj-attr.ads: Minor comment updates + +2009-11-30 Robert Dewar + + * gnat_rm.texi: Document pragma Short_Circuit + +2009-11-30 Emmanuel Briot + + * prj-conf.adb, prj-tree.adb, prj-tree.ads (Create_Attribute): Now set + the index either on the attribute or on its value, depending on the + kind of the attribute. Done to match recent changes in Prj.PP that were + not synchronized with this function. + +2009-11-30 Arnaud Charlet + + * gcc-interface/Make-lang.in: Fix typo. + Update dependencies. + +2009-11-30 Robert Dewar + + * gnat_rm.texi: Add documentation for attribute Result. + +2009-11-30 Arnaud Charlet + + * s-osinte-hpux.ads, s-osinte-aix.ads, s-osinte-solaris-posix.ads, + s-osinte-tru64.ads, s-osinte-darwin.ads, s-osinte-freebsd.ads + (Get_Page_Size): Update comment since Get_Page_Size is now required. + +2009-11-30 Jerome Lambourg + + * freeze.adb: Disable Warning on VM targets concerning C Imports, not + relevant. + +2009-11-30 Bob Duff + + * sprint.adb (Source_Dump): Minor comment fix. + (Write_Itype): When writing a string literal subtype, use Expr_Value + instead of Intval to get the low bound. + +2009-11-30 Vincent Celier + + * gnatlink.adb (Process_Args): Do not call Executable_Name on arguments + of switch -o. + +2009-11-30 Robert Dewar + + * exp_ch4.adb (Expand_N_Op_And): Implement pragma Short_Circuit_And_Or + (Expand_N_Op_Or): Implement pragma Short_Circuit_And_Or + * opt.ads (Short_Circuit_And_Or): New flag + * par-prag.adb: Add dummy entry for pragma Short_Circuit_And_Or + * sem_prag.adb: Implement pragma Short_Circuit_And_Or + * snames.ads-tmpl: Add entries for pragma Short_Circuit_And_Or + +2009-11-30 Arnaud Charlet + + * s-taprop-posix.adb: Fix casing. + * s-osinte-tru64.adb: Complete previous check-in. + +2009-11-30 Robert Dewar + + * gnat_rm.texi: Document pragma Compiler_Unit + * s-bitops.adb, s-restri.adb, g-htable.adb, s-restri.ads, + a-comlin.ads, a-strhas.ads, s-strhas.adb, s-parame.adb, + s-parame.ads, a-clrefi.adb, a-clrefi.ads, a-ioexce.ads: Supply missing + Compiler_Unit pragmas. + * freeze.adb (Freeze_Entity): Improve message for 8-bit boolean passed + to C. + +2009-11-30 Robert Dewar + + * makeutl.adb, makeutl.ads, prj-proc.adb, prj.adb, prj.ads: Minor + reformatting. + +2009-11-30 Thomas Quinot + + * osint.adb: Minor reformatting + +2009-11-30 Vincent Celier + + * makeutl.ads, makeutl.adb (Base_Name_Index_For): New function to get + the base name of a main without the extension, with an eventual source + index. + (Mains.Get_Index): New procedure to set the source index of a main + (Mains.Get_Index): New function to get the source index of a main + * prj-attr.adb: New attributes Config_Body_File_Name_Index, + Config_Spec_File_Name_Index, Multi_Unit_Object_Separator and + Multi_Unit_Switches. + * prj-nmsc.adb (Process_Compiler): Takle into account new attributes + Config_Body_File_Name_Index, Config_Spec_File_Name_Index, + Multi_Unit_Object_Separator and Multi_Unit_Switches. + Allow only one character for Multi_Unit_Object_Separator. + * prj-proc.adb (Process_Declarative_Items): Take into account the + source indexes in indexes of associative array attribute declarations. + * prj.adb (Object_Name): New function to get the object file name for + units in multi-unit sources. + * prj.ads (Language_Config): New components Multi_Unit_Switches, + Multi_Unit_Object_Separator Config_Body_Index and Config_Spec_Index. + (Object_Name): New function to get the object file name for units in + multi-unit sources. + * snames.ads-tmpl: New standard names Config_Body_File_Name_Index, + Config_Spec_File_Name_Index, Multi_Unit_Object_Separator and + Multi_Unit_Switches. + +2009-11-30 Arnaud Charlet + + * s-tassta.adb: Update comment. + +2009-11-30 Robert Dewar + + * a-ngelfu.adb: Minor code reorganization. + +2009-11-30 Robert Dewar + + * osint.ads, prj.adb, prj.ads: Minor reformatting + * s-stchop.adb, s-taprop-vxworks.adb, s-taprop-tru64.adb, + s-taprop-vms.adb, s-taprop-linux.adb, s-taprop-solaris.adb, + s-strxdr.adb, s-taprop-irix.adb, s-osinte-hpux-dce.adb, + s-osinte-tru64.adb, s-taenca.adb, s-taprop-hpux-dce.adb, s-stausa.adb, + s-taprop-posix.adb: Minor code reorganization (use conditional + expressions). + +2009-11-30 Bob Duff + + * g-sttsne-locking.adb (Copy_Service_Entry): Complete previous change. + +2009-11-30 Bob Duff + + * socket.c: Add more accessor functions for struct servent (need + setters as well as getters). + * g-sothco.ads (Servent): Declare interfaces to C setter functions for + struct servent. + * g-sttsne-locking.adb (Copy_Service_Entry): Use setter functions for + struct servent. + +2009-11-30 Robert Dewar + + * s-stchop-vxworks.adb: Add comment. + +2009-11-30 Emmanuel Briot + + * make.adb, prj.adb, prj.ads (Compute_All_Imported_Projects): Now acts + on the whole tree, to better share code with gprbuild. + (Length): New subprogram, to share code in gprbuild. + (Project_Data): Remove fields that are only needed when compiling a + project in gprbuild (where we use local variables instead) + * osint.adb, osint.ads: Added minor comment on memory management + +2009-11-30 Sergey Rybin + + * gnat_ugn.texi: Update gnatcheck doc. + +2009-11-30 Robert Dewar + + make.adb, prj-makr.adb, g-sothco.ads: Minor reformattting + * s-taprop-dummy.adb: Minor code reorganization (raise with msgs start + with lower case). + * i-vxwoio.adb, g-dirope.adb, g-sercom-linux.adb, + g-enblsp-vms-alpha.adb, g-regist.adb, s-imgcha.adb, s-tarest.adb, + s-taprop-mingw.adb, g-exctra.adb, g-expect.adb, g-comlin.adb, + g-debpoo.adb, g-expect-vms.adb, g-pehage.adb, g-trasym-vms-alpha.adb, + g-enblsp-vms-ia64.adb, s-fatgen.adb, s-fileio.adb: Minor code + reorganization (use conditional expressions). + +2009-11-30 Vincent Celier + + * prj-makr.adb (Source_Files): New hash table to keep track of source + file names. + (Finalize): Avoid putting several times the same source file name + in the source list file. + * prj-pp.adb (Print): Fix a bug in the placement of "at nn" for + associative array indexes. + +2009-11-30 Robert Dewar + + * g-dyntab.ads: Add missing pragma Compiler_Unit + +2009-11-30 Thomas Quinot + + * s-crtrun.ads, s-crtl.ads, g-stseme.adb, Makefile.rtl, s-fileio.adb + (System.CRTL.Runtime): New unit, to contain parts of s-crtl that are + used in the Ada runtime but can't be used in the compiler because of + bootstrap issues. + * socket.c, s-oscons-tmplt.c, g-sothco.ads + (System.OS_Constants.SIZEOF_struct_servent): New constant. + Use s-oscons constant instead of external variable to get size of + struct hostent. + +2009-11-30 Thomas Quinot + + * s-crtl.ads, g-stseme.adb, s-fileio.adb (System.CRTL.strerror): Change + return type to Interfaces.C.Strings.chars_ptr to eliminate need for + dubious unchecked conversion at call sites. + * s-errrep.adb, s-errrep.ads, Makefile.rtl (System.Error_Reporting): + Remove obsolete, unused runtime unit. + * gcc-interface/Make-lang.in: Update dependencies. + * gcc-interface/Makefile.in: Remove VMS specialization of s-crtl, not + required anymore. + +2009-11-30 Vincent Celier + + * gnatlink.adb: Delete an eventual existing executable file, in case it + is a symbolic link, to avoid modifying the target of the symbolic link. + +2009-11-30 Bob Duff + + * socket.c: Add accessor functions for struct servent. + * g-sothco.ads (Servent): Declare interfaces to C accessor functions + for struct servent. + * g-socket.adb (To_Service_Entry): Use accessor functions for struct + servent. + +2009-11-30 Robert Dewar + + * g-arrspl.adb: Minor reformatting + * g-dyntab.adb: Add missing pragma Compiler_Unit + +2009-11-30 Thomas Quinot + + * s-crtl.ads, s-oscons-tmplt.c: Fix support for VMS + * make.adb, g-comlin.ads, exp_ch6.adb: Minor reformatting + +2009-11-30 Robert Dewar + + * bcheck.adb, gnatlink.adb, make.adb, makeutl.adb, osint.adb, + osint.ads, prj-ext.adb, sem_case.adb: Minor reformatting + * g-alleve.adb: Minor code reorganization (use conditional expressions) + +2009-11-30 Matthew Heaney + + * a-crbtgo.adb (Delete_Fixup): Changed always-true predicates to + assertions. + +2009-11-30 Thomas Quinot + + * a-tasatt.adb, s-crtl.ads, s-taprop-dummy.adb (System.CRTL.malloc32, + System.CRTL.realloc32): Remove VMS-specific routines. + (Ada.Task_Attributes.Reference): Remove unreachable code. + (System.Task_Primitives.Operations.Initialize, dummy version): + Use plain Program_Error rather than call to + System.Error_Reporting.Shutdown. + +2009-11-30 Thomas Quinot + + * s-oscons-tmplt.c, xoscons.adb: Add new constants in preparation for + sharing s-crtl across all platforms. + +2009-11-30 Thomas Quinot + + * s-commun.adb, s-commun.ads: New internal support unit, + allowing code sharing between GNAT.Sockets and + GNAT.Serial_Communication. + * g-sercom.ads, g-sercom-mingw.adb, g-sercom-linux.adb, + g-socket.adb (GNAT.Sockets.Last_Index): Move to System.Communication. + (GNAT.Serial_Communication.Read): Handle correctly the case where no + data was read, and Buffer'First = Stream_Element_Offset'First. + * Makefile.rtl: Add entry for s-commun + * g-socthi-vms.adb, g-socthi-vms.ads, g-socthi-vxworks.adb, + g-socthi-vxworks.ads, g-stseme.adb, g-socthi-mingw.ads, + g-socthi.adb, g-socthi.ads (GNAT.Sockets.Thin.Socket_Error_Message): + Reimplement in terms of System.CRTL.strerror. + +2009-11-26 Eric Botcazou + + * gcc-interface/utils.c (copy_type): Unshare the language-specific data + and the contents of the language-specific slot if needed. + +2009-11-26 Eric Botcazou + + * gcc-interface/trans.c (gnat_to_gnu) : Set the source location + of the operator on both branches of the test in the generic case. + +2009-11-25 Eric Botcazou + + * gcc-interface/trans.c (unchecked_conversion_lhs_nop): Rename into... + (unchecked_conversion_nop): ...this. Handle actual parameters. + (gnat_to_gnu): Adjust for above renaming. + +2009-11-25 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : + Translate regular boolean types into BOOLEAN_TYPEs. + +2009-11-24 Eric Botcazou + + * sem_util.adb (Set_Debug_Info_Needed): For an E_Class_Wide_Subtype, + also set the flag on the Equivalent_Type. + * gcc-interface/utils.c (finish_record_type): Replace DO_NOT_FINALIZE + parameter with DEBUG_INFO_P. Rename FIELDLIST into FIELD_LIST. + (rest_of_record_type_compilation): Rename FIELDLIST into FIELD_LIST. + (build_vms_descriptor32): Adjust call to finish_record_type. + (build_vms_descriptor): Likewise. + (build_unc_object_type): Likewise. + * gcc-interface/decl.c (gnat_to_gnu_entity): Adjust calls to + finish_record_type and components_to_record. + (make_packable_type): Adjust call to finish_record_type. + (maybe_pad_type): Likewise. Tweak condition. + (components_to_record): Likewise. Replace DO_NOT_FINALIZE parameter + with MAYBE_UNUSED. Adjust recursive call. + (create_variant_part_from): Adjust call to finish_record_type. Do not + call rest_of_record_type_compilation on the new record types. + * gcc-interface/trans.c (gigi): Adjust call to finish_record_type. + * gcc-interface/gigi.h (finish_record_type): Adjust prototype and + comment. + (rest_of_record_type_compilation): Adjust comment. + +2009-11-24 Eric Botcazou + + * exp_util.adb (Make_CW_Equivalent_Type): Do not mark the type as + frozen for targets that do not require front-end layout. + (New_Class_Wide_Subtype): Always reset the freezing status to False. + * exp_ch8.adb: Do not 'with' Targparm. + (Expand_N_Object_Renaming_Declaration): Always freeze a class-wide + subtype that has been built from the expression. + * exp_intr.adb (Expand_Unc_Deallocation): If the designated type is + class wide, freeze the implicit type that has been built from the + expression at the dereference point. + * freeze.adb (Freeze_Entity): Adjust comment. + * gcc-interface/decl.c (Gigi_Equivalent_Type) : + Remove useless test. + * gcc-interface/trans.c (process_freeze_entity): Do not special-case + class-wide subtypes. + + * s-osinte-aix.adb (clock_gettime): Fix comment. + * s-osinte-darwin.adb (clock_gettime): Likewise. + +2009-11-23 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Pass the list + of attributes when building the corresponding variable of a constant. + * gcc-interface/utils.c (create_var_decl_1): Do not process attributes + for constants. + +2009-11-23 Laurent GUERBY + Eric Botcazou + + PR ada/42153 + * s-osinte-linux.ads (struct_timeval): Delete. + * s-osinte-hpux.ads (struct_timeval, To_Duration, To_Timeval): Delete. + * s-osinte-kfreebsd-gnu.ads: Likewise. + * s-osinte-rtems.ads: Likewise. + * s-osinte-aix.ads: Likewise. + * s-osinte-hpux-dce.ads: Likewise. + * s-osinte-darwin.ads: Likewise. + * s-osinte-solaris-posix.ads: Likewise. + * s-osinte-irix.ads: Likewise. + * s-osinte-solaris.ads: Likewise. + * s-osinte-hpux-dce.adb (To_Duration, To_Timeval): Delete. + * s-osinte-irix.adb: Likewise. + * s-osinte-solaris.adb: Likewise. + * s-osinte-rtems.adb: Likewise. Minor reformatting. + * s-osinte-aix.adb (To_Duration, To_Timeval): Delete. + (clock_gettime): Use cal.c's timeval_to_duration. + * s-osinte-darwin.adb: Likewise. + +2009-11-23 Rainer Orth + + * adaint.h: Assume large file support on IRIX only if _LFAPI. + +2009-11-21 Laurent GUERBY + Eric Botcazou + + * s-osinte-linux.ads (struct_timeval, To_Duration, To_Timeval, + gettimeofday): Delete. + * s-osinte-posix.adb (To_Duration, To_Timeval): Delete. + * s-osprim-posix.adb (struct_timezone, struct_timeval, gettimeofday): + Delete. + (Clock): Use cal.c's timeval_to_duration. + * s-taprop-linux.adb (Monotonic_Clock): Likewise. + +2009-11-12 Eric Botcazou + Laurent GUERBY + + * init.c (GNU/Linux Section): Enable for all architectures. + +2009-11-10 Eric Botcazou + + PR ada/20548 + * system-linux-alpha.ads (Stack_Check_Probes): Set to true. + * system-linux-hppa.ads (Stack_Check_Probes): Likewise. + * system-linux-sparc.ads (Stack_Check_Probes): Likewise. + * system-linux-sparcv9.ads (Stack_Check_Probes): Likewise. + +2009-11-10 Eric Botcazou + + * system-linux-alpha.ads (AAMP, Compiler_System_Version, OpenVMS, + Front_End_ZCX_Support, High_Integrity_Mode, Long_Shifts_Inlined): + Delete. + (Stack_Check_Limits, Always_Compatible_Rep): New. + * system-linux-mips.ads (AAMP, Compiler_System_Version, OpenVMS, + Front_End_ZCX_Support, High_Integrity_Mode, Long_Shifts_Inlined): + Delete. + (Stack_Check_Limits, Always_Compatible_Rep): New. + * system-linux-mips64el.ads (AAMP, Compiler_System_Version, OpenVMS, + Functions_Return_By_DSP, Front_End_ZCX_Support, High_Integrity_Mode, + Long_Shifts_Inlined): Delete. + (Stack_Check_Limits, Always_Compatible_Rep): New. + * system-linux-mipsel.ads (AAMP, Compiler_System_Version, OpenVMS, + Front_End_ZCX_Support, High_Integrity_Mode, Long_Shifts_Inlined): + Delete. + (Stack_Check_Limits, Always_Compatible_Rep): New. + * system-linux-s390.ads (AAMP, Compiler_System_Version, OpenVMS, + Front_End_ZCX_Support, High_Integrity_Mode, Long_Shifts_Inlined): + Delete. + (Stack_Check_Limits, Always_Compatible_Rep): New. + * system-linux-s390x.ads (AAMP, Compiler_System_Version, OpenVMS, + Front_End_ZCX_Support, High_Integrity_Mode, Long_Shifts_Inlined): + Delete. + (Stack_Check_Limits, Always_Compatible_Rep): New. + * system-linux-sh4.ads (Stack_Check_Limits, Always_Compatible_Rep): + New. + * system-linux-sparc.ads (AAMP, Compiler_System_Version, OpenVMS, + Front_End_ZCX_Support): Delete. + (Stack_Check_Limits, Always_Compatible_Rep): New. + * system-linux-sparcv9.ads (AAMP, Compiler_System_Version, OpenVMS, + Front_End_ZCX_Support, High_Integrity_Mode, Long_Shifts_Inlined): + Delete. + (Stack_Check_Limits, Always_Compatible_Rep): New. + * system-rtems.ads (OpenVMS): Delete. + (Stack_Check_Limits, Always_Compatible_Rep): New. + +2009-11-08 Eric Botcazou + + * gcc-interface/decl.c (make_packable_type): Fix oversight. + (gnat_to_gnu_field): Do not attempt to change the form of the type + if the field requires strict alignment. Always change the form of + the type if the specified size is smaller than its size. + +2009-11-05 Eric Botcazou + + * gcc-interface/utils.c (gnat_type_for_mode): Handle vector modes. + +2009-11-05 Eric Botcazou + + * gcc-interface/trans.c (lvalue_required_p) : + New case. + +2009-10-30 Eric Botcazou + + * gcc-interface/utils.c (MAX_FIXED_MODE_SIZE): Delete. + (create_field_decl): Update description. In a packed record, round + the size up to a byte boundary only if the field's type has BLKmode. + * gcc-interface/gigi.h (create_field_decl): Update description. + +2009-10-30 Emmanuel Briot + + * make.adb (Start_Compile_If_Possible): Compute location of resulting + ALI file in this procedure instead of after the compilation itself, + since the current directory might have changed in between when using + -j. + + * osint.ads: Addded missing alignment clause. + + * adaint.c, adaint.h, osint.adb (__gnat_reset_attributes, + __gnat_size_of_file_attributes): Rename reset_attributes and + size_of_file_attributes. + +2009-10-30 Javier Miranda + + * sem_scil.adb (Adjust_SCIL_Node): Add missing management of sequences + of statements when searching for SCIL nodes. + +2009-10-30 Tristan Gingold + + * gnatlink.adb, link.c: By default use shared libgcc on darwin. + +2009-10-30 Emmanuel Briot + + * make.adb, osint.adb (Add_Lib_Search_Dir): Do not add if dir is + already in the list. + This saves system calls when looking for ALI files + (Scan_Make_Args): The parameter to gnatmake's -D is now converted to an + absolute PATH (so that the above improvement properly occurs if both + -D and -aO are specified). + +2009-10-30 Thomas Quinot + + * a-direct.adb: Minor reformatting + +2009-10-30 Emmanuel Briot + + * make.adb, adaint.c, adaint.h, osint.adb, osint.ads, bcheck.adb + (*_attr): new subprograms. + (File_Length, File_Time_Stamp, Is_Writable_File): new subprograms + (Read_Library_Info_From_Full, Full_Library_Info_Name, + Full_Source_Name): Now benefit from a previous cache of the file + attributes, to further save on system calls. + (Smart_Find_File): now also cache the file attributes. This makes the + package File_Stamp_Hash_Table useless, and it was removed. + (Compile_Sources): create subprograms for the various steps of the main + loop, for readibility and to avoid sharing variables between the + various steps. + +2009-10-30 Emmanuel Briot + + * make.adb, osint.adb, osint.ads (Library_File_Stamp): Removed, since + unused. + (Read_Library_Info_From_Full): New subprogram. + +2009-10-30 Robert Dewar + + * a-tideio.adb: Minor reformatting + * a-wtdeio.adb, a-ztdeio.adb: Update comments, code clean up. + + * a-reatim.adb, a-tideau.adb, a-ngelfu.adb, a-ztdeau.adb, a-ngrear.adb, + a-wtedit.adb, a-ststio.adb, a-ztedit.adb: Minor code reorganization + (use conditional expressions). + +2009-10-30 Ed Schonberg + + * gnat_ugn.texi: Additional info on gnatw.i and gnatw.I + + * sem_case.adb: Improved error message. + +2009-10-30 Emmanuel Briot + + * a-direct.adb, gnatcmd.adb, gnatname.adb, makeutl.adb, opt.ads, + osint.adb, prj-ext.adb, switch-m.adb (Follow_Links_For_Dirs): Now + defaults to False, and controlled by -eL. + * a-direct.adb: Add comments. + * osint.adb (File_Stamp): Avoid unneeded duplicate system call + +2009-10-30 Robert Dewar + + * sem_res.adb (Resolve_Type_Conversion): Avoid false positive when + converting non-static subtype to "identical" static subtype. + +2009-10-30 Ed Schonberg + + * usage.adb: Add -gnatw.i switch. + +2009-10-30 Vincent Celier + + * xsnamest.adb: Update comments with regards to the template files + snames.*.tmpl + +2009-10-30 Bob Duff + + * s-fileio.adb (Errno_Message): Suppress VMS-specific warning. + +2009-10-30 Ed Schonberg + + * sem_case.adb (Check_Choices): Add explanatory message when there are + missing alternatives when the required range of alternatives is given + by the base type of the case expression or discriminant in a variant + part. + + * opt.ads: New flag Warn_On_Overlap, to enable warnings on potentially + dangerous overlap between actuals in a call, activated by -gnatw.i + * sem_warn.adb (Set_Dot_Warning_Switch): set flag. + (Warn_On_Overlapping_Actuals): use new flag. + + * gnat_ugn.texi: Document -gnatw.i, warning on overlapping actuals + +2009-10-30 Robert Dewar + + * exp_aggr.adb, exp_ch9.adb: Minor reformatting + +2009-10-29 Eric Botcazou + + * gcc-interface/decl.c (make_type_from_size) : Do not + create integer types with precision 0. + +2009-10-29 Eric Botcazou + + PR ada/41870 + * gcc-interface/decl.c (array_type_has_nonaliased_component): Swap + parameters and rewrite comments. For a derived type, return the + setting of its parent type. + (gnat_to_gnu_entity): Do an alias set copy for derived types if they + are composite. Adjust calls to above function. + +2009-10-29 Eric Botcazou + + * gcc-interface/trans.c (Attribute_to_gnu) : Do not + return the RM size for padded types. + +2009-10-28 Robert Dewar + + * sem_type.adb: Minor reformatting + +2009-10-28 Arnaud Charlet + + * exp_ch9.adb (Build_Task_Proc_Specification): Generate a different + suffix for task type bodies. + +2009-10-28 Ed Schonberg + + * exp_aggr.adb (Convert_Aggr_In_Allocator): Do not look for a + finalization list if the designated type requires no control actions, + to prevent a useless semantic dependence on ada.tags. + +2009-10-28 Bob Duff + + * s-fileio.adb: Give more information in exception messages. + +2009-10-28 Robert Dewar + + * gnat_ugn.texi: Document new -gnatyt requirement for space after right + paren if next token starts with digit or letter. + * styleg.adb (Check_Right_Paren): New rule for space after if next + character is a letter or digit. + +2009-10-28 Thomas Quinot + + * s-crtl.ads (System.CRTL.strerror): New function. + +2009-10-28 Ed Schonberg + + * sem_type.adb: Add guard to recover some type errors. + +2009-10-28 Vincent Celier + + * prj-nmsc.adb (Add_To_Or_Remove_From_List): New name of procedure + Add_If_Not_In_List to account to the fact that a directory may be + removed from the list. Only remove directory if Removed is True. + +2009-10-28 Gary Dismukes + + * a-textio.ads, a-textio.ads: Put back function EOF_Char in private + part. Put back body of function EOF_Char. + * a-tienau.adb: Remove with of Interfaces.C_Streams and change EOF back + to EOF_Char. + +2009-10-28 Emmanuel Briot + + * prj-tree.adb (Free): Fix memory leak. + +2009-10-28 Thomas Quinot + + * s-fileio.adb: Minor reformatting + +2009-10-28 Arnaud Charlet + + * gcc-interface/Make-lang.in: Update dependencies. + +2009-10-28 Robert Dewar + + * exp_attr.adb, exp_ch9.adb, prj-nmsc.adb, tbuild.adb, ali.adb, + types.ads: Minor reformatting + +2009-10-28 Tristan Gingold + + * init.c: Fix __gnat_error_handler for Darwin10 (Snow Leopard) + +2009-10-28 Thomas Quinot + + * exp_ch4.adb (Expand_N_Type_Conversion): Perform Integer promotion for + the operand of the unary minus and ABS operators. + + * sem_type.adb (Covers): A concurrent type and its corresponding record + type are compatible. + * exp_attr.adb (Expand_N_Attribute_Reference): Do not rewrite a 'Access + attribute reference for the current instance of a protected type while + analyzing an access discriminant constraint in a component definition. + Such a reference is handled in the corresponding record's init proc, + while initializing the constrained component. + * exp_ch9.adb (Expand_N_Protected_Type_Declaration): When creating the + corresponding record type, propagate components' + Has_Per_Object_Constraint flag. + * exp_ch3.adb (Build_Init_Procedure.Build_Init_Statements): + For a concurrent type, set up concurrent aspects before initializing + components with a per object constrain, because they may be controlled, + and their initialization may call entries or protected subprograms of + the enclosing concurrent object. + +2009-10-28 Emmanuel Briot + + * prj-nmsc.adb (Add_If_Not_In_List): New subprogram, for better sharing + of code. + (Find_Source_Dirs): resolve links if Opt.Follow_Links_For_Dirs when + processing the directories specified explicitly in the project file. + +2009-10-28 Robert Dewar + + * a-ztexio.adb, a-ztexio.ads, a-witeio.ads, a-witeio.adb, + a-textio.ads, a-textio.adb: Reorganize (moving specs from private part + to body). + (Initialize_Standard_Files): New procedure. + * a-tienau.adb: Minor change to make EOF directly visible + * a-tirsfi.ads, a-wrstfi.adb, a-wrstfi.ads, a-zrstfi.adb, + a-zrstfi.ads, a-tirsfi.adb: New unit, initial version. + * gnat_rm.texi: Add documentation for + Ada.[Wide_[Wide_]]Text_IO.Reset_Standard_Files. + * Makefile.rtl: Add entries for + Ada.[Wide_[Wide_]]Text_IO.Reset_Standard_Files + +2009-10-28 Thomas Quinot + + * exp_ch9.ads: Minor reformatting + * sem_ch3.adb: Minor reformatting + * sem_aggr.adb: Minor reformatting. + * sem_attr.adb: Minor reformatting + * tbuild.adb, tbuild.ads, par-ch4.adb, exp_ch4.adb (Tbuild.New_Op_Node): + New subprogram. + Minor code reorganization/factoring. + +2009-10-27 Eric Botcazou + + * gcc-interface/decl.c (purpose_member_field): New static function. + (annotate_rep): Use it instead of purpose_member. + +2009-10-27 Eric Botcazou + + * raise-gcc (db_region_for): Use _Unwind_GetIPInfo instead of + _Unwind_GetIP if HAVE_GETIPINFO is defined. + (db_action_for): Likewise. + +2009-10-27 Robert Dewar + + * s-fileio.adb, s-fileio.ads, sem_util.adb, sem_warn.adb, + sem_warn.ads: Minor reformatting + +2009-10-27 Robert Dewar + + * sem_warn.adb, sem_util.adb, sem_util.ads: Minor reformatting. Add + comments. + +2009-10-27 Robert Dewar + + * s-os_lib.ads, s-os_lib.adb, prj-err.adb, makeutl.adb: Minor + reformatting. + +2009-10-27 Ed Schonberg + + * sem.util.ads, sem_util.adb (Denotes_Same_Object, + Denotes_Same_Prefix): New functions to detect overlap between actuals + that are not by-copy in a call, when one of them is in-out. + * sem_warn.ads, sem_warn.adb (Warn_On_Overlapping_Actuals): New + procedure, called on a subprogram call to warn when an in-out actual + that is not by-copy overlaps with another actual, thus leadind to + potentially dangerous aliasing in the body of the called subprogram. + Currently the warning is under control of the -gnatX switch. + * sem_res.adb (resolve_call): call Warn_On_Overlapping_Actuals. + +2009-10-27 Thomas Quinot + + * sem_ch12.adb (Install_Formal_Packages): Do not omit installation of + visible entities when the formal package doesn't have a box. + + * checks.adb: Minor reformatting. + +2009-10-27 Vincent Celier + + * prj-part.adb (Parse): Catch exception Types.Unrecoverable_Error and + set Project to Empty_Node. + +2009-10-27 Robert Dewar + + * gnatbind.adb: Minor reformatting + +2009-10-27 Arnaud Charlet + + * exp_aggr.adb: Fix comment. + +2009-10-27 Emmanuel Briot + + * prj-err.adb (Error_Msg): take into account continuation lines when + computing whether we have a warning. + +2009-10-27 Vasiliy Fofanov + + * make.adb, s-os_lib.adb, s-os_lib.ads (Create_Temp_Output_File): New + routine that is designed to create temp file descriptor specifically + for redirecting an output stream. + +2009-10-24 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : When + processing the parent type, build the COMPONENT_REF for a discriminant + with the proper type. + +2009-10-24 Eric Botcazou + + * init.c (__gnat_adjust_context_for_raise): Mention _Unwind_GetIPInfo. + * gcc-interface/Makefile.in (GNATLIBCFLAGS_FOR_C): Add HAVE_GETIPINFO. + Pass GNATLIBCFLAGS_FOR_C to recursive invocations. + +2009-10-21 Eric Botcazou + + * gcc-interfaces/decl.c (build_subst_list): Convert the expression of + the constraint to the type of the discriminant. + +2009-10-21 Eric Botcazou + + * gcc-interfaces/decl.c (gnat_to_gnu_entity): Do not create a new + TYPE_DECL when a type is padded if there is already one and reset + TYPE_STUB_DECL in this case. + +2009-10-21 Eric Botcazou + + * gcc-interfaces/utils.c (create_subprog_decl): Do not redefine + main_identifier_node. + +2009-10-17 Eric Botcazou + + * gcc-interface/utils.c (convert): When converting to a padded type + with an inner type of self-referential size, pad the expression before + doing the unchecked conversion. + +2009-10-17 Eric Botcazou + + * gcc-interface/utils2.c (build_binary_op) : Make + sure the element type is consistent. + +2009-10-17 Eric Botcazou + + * gcc-interface/trans.c (addressable_p): Handle bitwise operations. + +2009-10-16 Eric Botcazou + + * gcc-interface/ada-tree.h (TYPE_FAT_POINTER_P): Swap with... + (TYPE_IS_FAT_POINTER_P): ...this. + (TYPE_THIN_POINTER_P): Rename into... + (TYPE_IS_THIN_POINTER_P): ...this. + (TYPE_FAT_OR_THIN_POINTER_P): Rename into... + (TYPE_IS_FAT_OR_THIN_POINTER_P): ...this. + (TYPE_IS_PADDING_P): Change definition, move old one to... + (TYPE_PADDING_P): ...this. + * gcc-interface/decl.c (gnat_to_gnu_entity): Adjust for above changes. + (get_unpadded_type): Likewise. + (gnat_to_gnu_component_type): Likewise. + (gnat_to_gnu_param): Likewise. + (relate_alias_sets): Likewise. + (make_packable_type): Likewise. + (maybe_pad_type): Likewise. + (gnat_to_gnu_field): Likewise. + (is_variable_size): Likewise. + (annotate_object): Likewise. + (validate_size): Likewise. + (set_rm_size): Likewise. + (make_type_from_size): Likewise. + (rm_size): Likewise. + * gcc-interface/misc.c (gnat_print_type): Likewise. + (gnat_get_alias_set): Likewise. + * gcc-interface/trans.c (Identifier_to_gnu): Likewise. + (Attribute_to_gnu): Likewise. + (call_to_gnu): Likewise. + (gnat_to_gnu): Likewise. + (add_decl_expr): Likewise. + (convert_with_check): Likewise. + (addressable_p): Likewise. + (maybe_implicit_deref): Likewise. + (protect_multiple_eval): Likewise. + (gnat_stabilize_reference_1): Likewise. + * gcc-interface/utils.c (gnat_pushdecl): Likewise. + (finish_record_type): Likewise. + (rest_of_record_type_compilation): Likewise. + (create_type_decl): Likewise. + (gnat_types_compatible_p): Likewise. + (build_template): Likewise. + (convert_vms_descriptor64): Likewise. + (convert_vms_descriptor32): Likewise. + (build_unc_object_type_from_ptr): Likewise. + (update_pointer_to): Likewise. + (convert_to_fat_pointer): Likewise. + (convert_to_fat_pointer): Likewise. + (convert): Likewise. + (remove_conversions): Likewise. + (maybe_unconstrained_array): Likewise. + (unchecked_convert): Likewise. + (handle_vector_type_attribute): Likewise. + * gcc-interface/utils2.c (build_binary_op): Likewise. + (build_unary_op): Likewise. + (build_allocator): Likewise. + +2009-10-16 Eric Botcazou + + * exp_dbug.ads: Adjust type names in comments. + * gcc-interface/decl.c (maybe_pad_type): Remove NAME_TRAILER parameter, + add new IS_COMPONENT_TYPE parameter. Adjust. Remove dead code. + (gnat_to_gnu_entity): Adjust for above change. + (gnat_to_gnu_component_type): Likewise. + (gnat_to_gnu_field): Likewise. + * gcc-interface/trans.c (call_to_gnu): Likewise. Do not unnecessarily + call max_size. + * gcc-interface/utils.c (finish_record_type): Remove obsolete code. + * gcc-interface/gigi.h (maybe_pad_type): Adjust prototype. + +2009-10-16 Joel Sherrill + + * s-osinte-rtems.ads: Add mutex type to pthread_mutexattr_t + * s-stchop-rtems.adb: Correct binding to rtems_stack_checker_is_blown. + +2009-10-13 Rainer Orth + + * env.c [__alpha__ && __osf__] (AES_SOURCE): Define. + +2009-10-10 Samuel Tardieu + + * sem_eval.adb: Give a more precise error message. + +2009-10-06 Samuel Tardieu + + PR ada/41383 + * a-rttiev.adb (Time_Of_Event): Return Time_First for unset event. + +2009-10-06 Samuel Tardieu + + PR ada/38333 + * sem_prag.adb (Process_Import_Or_Interface): Forbid an abstract + subprogram to be completed with a "pragma Import". + +2009-10-02 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : + Generate an XVZ variable alongside the XVS type if the size is + not constant. + (maybe_pad_type): Minor tweak. + +2009-10-02 Eric Botcazou + + * gcc-interface/decl.c (check_ok_for_atomic): Do nothing if the type + doesn't come from source. + +2009-10-02 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_component_type): Force at least + unit size for the component size of an array with aliased components. + (maybe_pad_type): Do not warn for MAX_EXPR. + +2009-09-29 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Factor out + common code processing the component type into... + : Likewise. + (gnat_to_gnu_component_type): ...this new static function. + (maybe_pad_type): Minor cleanup. + +2009-09-29 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Rewrite + the handling of constrained discriminated record subtypes. + (components_to_record): Declare the type of the variants and of the + qualified union. + (build_subst_list): Move around. + (compute_field_positions): Rename into... + (build_position_list): ...this. Return a TREE_VEC. + (annotate_rep): Adjust for above renaming. + (build_variant_list): New static function. + (create_field_decl_from): Likewise. + (get_rep_part): Likewise. + (get_variant_part): Likewise. + (create_variant_part_from): Likewise. + (copy_and_substitute_in_size): Likewise. + +2009-09-28 Olivier Hainque + + PR ada/41100 + * gcc-interface/targtyps.c (get_target_default_allocator_alignment): + Account for observable alignments out of default allocators. + +2009-09-28 Richard Henderson + + * gcc-interface/utils.c (gnat_install_builtins): Update call to + build_common_builtin_nodes. + +2009-09-26 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Filter out + negative size for the array dimensions like in the constrained case. + : Do not create an artificially non-constant high + bound if the low bound is non-constant. Minor tweaks. + + * gcc-interface/trans.c (lvalue_required_p): Add CONSTANT parameter + and turn ALIASED into a boolean parameter. Adjust calls to self. + : Return 1 for more attributes. + : Return 1 for non-constant objects. + : Return 1 for the LHS. + (Identifier_to_gnu): Adjust calls to lvalue_required_p. + (call_to_gnu): Be prepared for wrapped boolean rvalues. + +2009-09-25 Olivier Hainquqe + Eric Botcazou + + * gcc-interface/ada-tree.h (TYPE_REPRESENTATIVE_ARRAY): New language + specific node. Representative array type for VECTOR_TYPE entities. + * gcc-interface/utils.c (handle_vector_type_attribute): New handler. + Turn an ARRAY_TYPE entity into a VECTOR_TYPE. + (gnat_types_compatible_p): Handle VECTOR_TYPEs. + (convert): Likewise. Arrange to produce VECTOR_CST out of constant + array aggregates for VECTOR_TYPE entities. + (unchecked_convert): Likewise. + (maybe_vector_array): New function. If EXP has VECTOR_TYPE, return EXP + converted to the associated TYPE_REPRESENTATIVE_ARRAY. + (handle_pure_attribute, handle_sentinel_attribute, + handle_noreturn_attribute, handle_malloc_attribute, + handle_vector_size_attribute): Replace uses of qE format by qs. + Remove GCC_DIAG_STYLE definition. + * gcc-interface/trans.c (gnat_to_gnu) : Convert + vector input to representative array type on entry. + : Likewise. + * gcc-interface/gigi.h (maybe_vector_array): Declare. + (VECTOR_TYPE_P): New predicate. + * gcc-interface/misc.c (gnat_print_type): Handle VECTOR_TYPE. + +2009-09-24 Eric Botcazou + + * gcc-interface/ada.h: Fix outdated comment. + * gcc-interface/ada-tree.h (SET_TYPE_RM_VALUE): Use MARK_VISITED in + lieu of mark_visited. + * gcc-interface/gigi.h (mark_visited): Change type of parameter. + (MARK_VISITED): New macro. + (gnat_truthvalue_conversion): Delete. + * gcc-interface/decl.c (gnat_to_gnu_entity): Use MARK_VISITED in lieu + of mark_visited. + (annotate_rep): Fix formatting and tidy. + (compute_field_positions): Get rid of useless variable. + * gcc-interface/trans.c (gnat_to_gnu): Retrieve the Nkind of the GNAT + node only once. Use IN operator for the Nkind in more cases. + Remove calls to gnat_truthvalue_conversion. + (mark_visited): Change type of parameter and adjust. + (mark_visited_r): Dereference TP only once. + (add_decl_expr): Use MARK_VISITED in lieu of mark_visited. + * gcc-interface/utils2.c (gnat_truthvalue_conversion): Delete. + (build_binary_op): Remove calls to gnat_truthvalue_conversion. + (build_unary_op): Likewise. + +2009-09-24 Dave Korn + + * gcc-interface/Makefile.in (LIBGNAT_TARGET_PAIRS): Simplify test for + a-except% in target pairs list; don't (implicitly) compare whitespace. + +2009-09-24 Jakub Jelinek + + * gcc-interface/utils.c (gnat_pushdecl): Don't set + DECL_NO_STATIC_CHAIN, set DECL_STATIC_CHAIN for + nested functions. + +2009-09-21 Joel Sherrill + + * s-osinte-rtems.ad[bs]: Get_Page_Size cannot return 0. + Bind to getpagesize() in RTEMS 4.10 and newer. + +2009-09-21 Rainer Orth + + * env.c [__alpha__ && __osf__] (_BSD): Define. + * init.c [__alpha__ && __osf__] (__gnat_error_handler): Cast msg + to const char *. + +2009-09-18 Pascal Obry + + * mingw32.h: Activate Unicode support for x86-64 Windows platform. + +2009-09-18 Vadim Godunko + + * s-oscons-tmplt.c: Add circuit for handling IOV_MAX macro on IRIX. + +2009-09-18 Javier Miranda + + * exp_aggr.adb (Backend_Processing_Possible): Disable backend + processing for array aggregates in the VM backend if the array has + aliased components. + +2009-09-18 Ed Schonberg + + * sem_ch4.adb (Analyze_Indexed_Component): Emit error if the type of + the prefix indicates a previous semantic error, and this is the first + error in the program. + +2009-09-18 Bob Duff + + * gnat_ugn.texi: Minor editing. + +2009-09-18 Vincent Celier + + * prj.ads, prj.adb (Project_Data): New component + Imported_Directories_Switches. + +2009-09-18 Pascal Obry + + * mingw32.h: Include standard _mingw.h file. + Define _WIN32_WINNT only if not already defined. + +2009-09-18 Thomas Quinot + + * g-socket.adb (Is_Open): New function indicating whether a + Selector_Type object is open. + +2009-09-18 Vincent Celier + + * osint-c.adb (Create_Output_Library_Info): Make sure that the ALI file + is deleted before creating it. + +2009-09-18 Robert Dewar + + * bindgen.adb: Minor reformatting + +2009-09-18 Arnaud Charlet + + * s-taprop-tru64.adb, s-taprop-linux.adb, s-taprop-solaris.adb, + s-taprop-irix.adb, s-taprop-posix.adb (Abort_Task): Do nothing if no + signal handler is installed. + * s-tassta.adb (Finalize_Global_Tasks): Do not wait for independent + tasks if Abort_Task_Interrupt cannot be used. + +2009-09-18 Vincent Celier + + * prj-tree.ads: Minor comment update + +2009-09-17 Bob Duff + + * g-socket.ads: Document the fact that Close_Selector has no effect on + a closed selector. + * g-socket.adb: Raise an exception when a Selector that should be open + is closed. + (Check_Selector): Declare RSig as a constant rather than a renames, + less confusing. + +2009-09-17 Robert Dewar + + * exp_ch9.adb, exp_ch5.adb, exp_ch4.adb, prj-conf.adb, prj-env.ads, + prj-ext.adb, prj-ext.ads, prj-pars.adb, prj-part.adb, prj-proc.adb, + prj-tree.ads: Minor reformatting + +2009-09-17 Emmanuel Briot + + * prj-conf.adb, prj-env.adb, prj-env.ads (Create_Temp_File): Moved to + spec. + (Do_Autoconf): If the object directory does not exists, create auto.cgpr + in a temporary directory instead + +2009-09-17 Bob Duff + + * a-dynpri.adb (Set_Priority): Don't do anything if the task is already + terminated. + (Get_Priority): Correct message for "terminated" case -- it said "null". + +2009-09-17 Robert Dewar + + * exp_ch6.adb: Minor reformatting + +2009-09-17 Emmanuel Briot + + * gnatcmd.adb, make.adb, prj-part.adb, prj-ext.adb, prj-ext.ads, + switch-m.adb, switch-m.ads, clean.adb, prj-tree.ads + (Project_Node_Tree_Data.Project_Path): New field. + + * prj-conf.adb (Do_Autoconf): Remove "creating auto.cgpr" message + +2009-09-17 Emmanuel Briot + + * prj-ext.adb, prj-ext.ads, makeutl.adb (Is_External_Assignment): + Remove duplicate code. + (Prj.Ext): Fix memory leak + (Check): Now allow the syntax "-Xfoo=" to set an empty value to the + variable. This was previously allowed in the code in + Is_External_Assignment, and some tests rely on it + +2009-09-17 Bob Duff + + * gnat_rm.texi, s-oscons-tmplt.c: Minor typo + +2009-09-17 Emmanuel Briot + + * gnatcmd.adb, prj-proc.adb, make.adb, prj-ext.adb, prj-ext.ads, + makeutl.adb, makeutl.ads, clean.adb, prj-pars.adb, prj-pars.ads, + prj-conf.adb, prj-conf.ads, prj-tree.adb, prj-tree.ads, prj-proc.ads, + prj-nmsc.ads (Add, Value_Of, Reset): new parameter Tree. + Scenario variables are now specific to each project tree loaded in + memory. + Code clean ups. + +2009-09-17 Javier Miranda + + * exp_disp.adb (Make_DT): Remove wrong line of code that was + undocumented and probably added by mistake. + +2009-09-16 Eric Botcazou + + * gcc-interface/trans.c (Attribute_to_gnu) : Strip + conversions between original and packable version of types from + the expression. + +2009-09-16 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_field): Add DEBUG_INFO_P parameter. + If a padding type was made for the field, declare it. + (components_to_record): Add DEBUG_INFO_P parameter. Adjust call + to gnat_to_gnu_field and call to self. + (gnat_to_gnu_entity) : Do not redeclare padding types. + : Likewise. + Adjust calls to gnat_to_gnu_field and components_to_record. + +2009-09-16 Robert Dewar + + * prj-nmsc.adb: Minor reformatting + +2009-09-16 Ed Schonberg + + * exp_ch4.adb (Expand_N_Conditional_Expression): If the type of the + expression is a by-reference type (tagged or inherently limited) + introduce an access type to capture references to the values of each + branch of the conditional. + +2009-09-16 Emmanuel Briot + + * prj-proc.adb, prj-part.adb, prj-tree.adb, prj-tree.ads + (Project_Name_And_Node.Display_Name): new field + The display name of a project (as written in the .gpr file) is now + computed when the project file itself is parsed, not when it is + processed. + +2009-09-16 Thomas Quinot + + * freeze.adb, exp_intr.adb (Expand_Intrinsic_Call): Leave calls to + intrinsics untouched (to be expanded later on by gigi) if an external + name has been specified. + (Freeze_Entity): Do not generate a default external name for + imported subprograms with convention Intrinsic (so that the above code + can identify the case where an external name has been explicitly + provided). + + * s-oscons-tmplt.c: Quote TARGET_OS early so that it is not erroneously + replaced by something else due to an existing #define clause. + +2009-09-16 Ed Schonberg + + * sinfo.ads, sinfo.adb (Is_Accessibility_Actual): New flag on + Parameter_Association node, created for the extra actual generated for + an access parameter of a function that dispatches on result, to prevent + double generation of such actuals when the call is rewritten is a + dispatching call. + * exp_ch6.adb (Expand_Call): Set Is_Accessibility_Actual when needed. + * exp_disp.adb (Expand_Dispatching_Call): Do not transfer extra actuals + that carry this flag when rewriting the original call as a dispatching + call, after propagating the controlling tag. + +2009-09-16 Vincent Celier + + * prj-nmsc.adb (Add_Source): New parameter Source_Dir_Rank to be put + in the source data. + (Check_File): New parameter Source_Dir_Rank, to check if a duplicate + source is allowed. + (Find_Source_Dirs): New parameter Rank to be recorded with the source + directories. + (Search_Directories): Call Check_File with the rank of the directory + * prj.adb (Project_Empty): Add new component Source_Dir_Ranks + (Free): Free also Number_Lists + (Reset): Init also Number_Lists + * prj.ads (Number_List_Table): New dynamic table for lists of numbers + (Source_Data): New component Source_Dir_Rank. Remove component + Known_Order_Of_Source_Dirs, no longer needed. + (Project_Data): New component Source_Dir_Ranks + (Project_Tree_Data): New components Number_Lists + +2009-09-16 Vincent Celier + + * gprep.adb (Yes_No): New global constant + Unix_Line_Terminators: New global Boolean variable + (Process_One_File): Create the out file with a "Text_Translation=" form + that depends on the use of option -T. + (Scan_Command_Line): Add option -T + (Usage): Add line for option -T + +2009-09-16 Ed Schonberg + + * exp_disp.ads, exp_disp.adb (Is_Predefined_Internal_Operation): New + predicate that describes a proper subset of + Is_Predefined_Dispatching_Operation and excludes stream operations, + which can be overridden by the user. + * sem_ch6.adb (Create_Extra_Formals): use + Is_Predefined_Internal_Operation, so that stream operations get extra + formals. + * exp_ch6.adb (Prevent double generation of extra actuals in calls to + 'Input, which may be expanded twice, first as a function call and then + as a dispatching call. + +2009-09-16 Thomas Quinot + + * s-oscons-tmplt.c (Target_OS, Target_Name): New constants. + * g-expect.adb (Set_Up_Child_Communications): Use + System.OS_Constants.Target_OS to determine whether running on Windows. + +2009-09-14 Richard Henderson + + * gcc-interface/trans.c (Pragma_to_gnu): Use build5 for ASM_EXPR. + +2009-09-14 Eric Botcazou + + * exp_dbug.ads (Packed Array Encoding): Document the new encoding for + the unconstrained case. + * gcc-interfaces/decl.c (gnat_to_gnu_entity) : Implement + the encoding. Do not give a name to the pointer type to the XUT type. + * gcc-interfaces/utils.c (gnat_pushdecl): Propagate DECL_ORIGINAL_TYPE + for fat pointer types, if any. Make sure DECL_ARTIFICIAL is cleared + on nodes with DECL_ORIGINAL_TYPE set. + (update_pointer_to): Set DECL_ORIGINAL_TYPE to the original pointer + for fat pointer types. Make sure DECL_ARTIFICIAL is cleared. + +2009-09-14 Richard Henderson + + * gcc-interface/misc.c (gnat_init_gcc_eh): Don't call + default_init_unwind_resume_libfunc. + * gcc-interface/trans.c (Exception_Handler_to_gnu_zcx): Use + __builtin_eh_pointer. + * gcc-interface/utils.c (gnat_install_builtins): Update call + to build_common_builtin_nodes. + +2009-09-13 Richard Guenther + Rafael Avila de Espindola + + * gcc-interface/misc.c (gnat_init_gcc_eh): Do not set variables + eh_personality_libfunc and lang_eh_runtime_type. + (LANG_HOOKS_EH_PERSONALITY): Define. + (gnat_eh_personality_decl): New static variable. + (gnat_eh_personality): New static function. + Include gt-ada-misc.h. + * gcc-interface/Make-lang.in (misc.o): Add gt-ada-misc.h dependency. + * gcc-interface/config-lang.in (gtfiles): Add misc.c. + +2009-09-10 Rainer Orth + + PR ada/18302 + * gcc-interface/Make-lang.in (check-acats): Export rootme, EXPECT. + +2009-09-08 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Tidy + flow of control. + Avoid useless work when processing the Treat_As_Volatile flag. + +2009-09-08 Eric Botcazou + + * gcc-interface/targtyps.c: Reorder include directives. + +2009-09-07 Laurent GUERBY + + * gcc-interface/targtyps.c: Add missing include for tm_p.h. + * gcc-interface/Make-lang.in: Update dependencies. + +2009-09-07 Laurent GUERBY + + * make.adb: Add missing documentation for multilib handling. + +2009-09-03 Diego Novillo + + * gcc-interface/misc.c (lang_hooks): Remove const qualifier. + +2009-09-02 Richard Henderson + + * tb-gcc.c (__gnat_backtrace): Mark all arguments unused. + +2009-09-02 Olivier Hainque + + * init.c (__gnat_error_handler, AIX): Add ATTRIBUTE_UNUSED on si + and uc arguments. + +2009-09-02 Olivier Hainque + + * gcc-interface/decl.c (cannot_be_superflat_p): Handle + Signed_Integer_Type_Definition Scalar_Ranges. + +2009-09-02 Eric Botcazou + + * gcc-interface/trans.c (gnat_gimplify_expr) : Gimplify the + SAVE_EXPR built for misaligned arguments. Remove redundant stuff. + (addressable_p): Return true for more rvalues. + +2009-09-01 Jakub Jelinek + + * gcc-interface/utils2.c (maybe_wrap_malloc, maybe_wrap_free): Cast + POINTER_SIZE to HOST_WIDE_INT. + +2009-09-01 Richard Guenther + + * gcc-interface/misc.c (LANG_HOOKS_MARK_ADDRESSABLE): Remove. + +2009-08-25 Eric Botcazou + + * gcc-interface/trans.c (call_to_gnu): Tidy. + (gnat_to_gnu) : Set TYPE_ARRAY_MAX_SIZE if the slice has + non-constant size but the array itself has constant size. + * gcc-interface/utils.c (convert_vms_descriptor64): Fix type + consistency error. + (convert_vms_descriptor32): Likewise. + +2009-08-22 Aurelien Jarno + + * gcc-interface/Makefile.in: Add Ada support for + GNU/kFreeBSD x86_64. + * system-freebsd-x86_64.ads: New file based on + system-freebsd-x86.ads. + +2009-08-20 Eric Botcazou + + * gcc-interface/utils.c (convert): In the padded case, do the final + conversion as an unchecked conversion if the underlying types are + array types with variable size. + +2009-08-20 Eric Botcazou + + * gcc-interface/ada-tree.h (SET_TYPE_RM_VALUE): Mark the expression + as visited. + * gcc-interface/misc.c (gnat_get_subrange_bounds): Always return the + bounds. + * gcc-interface/trans.c (add_decl_expr): Do not mark gigi-specific + fields. + (gnat_gimplify_expr) : New case. + +2009-08-17 Aurelien Jarno + + * s-osinte-kfreebsd-gnu.ads (SA_ONSTACK): New constant. + (stack_t): New record type. + (sigaltstack): New imported function. + (Alternate_Stack): New imported variable. + (Alternate_Stack_Size): New constant. + +2009-08-17 Vasiliy Fofanov + + * a-calend-vms.adb: Fix typo. + +2009-08-17 Tristan Gingold + + * s-taprop-posix.adb: Round up the stack size to avoid failure on + Darwin. + +2009-08-17 Gary Dismukes + + * sem_cat.adb (Validate_Static_Object_Name): Update comment. + +2009-08-17 Vincent Celier + + * make.adb (Arguments_Collected): Unneeded, removed + (Change_To_Object_Directory): Use Project directly. Add pragma Assert to + ensure caller does not pass in No_Project. + (Compile): Add new parameter Project. Let procedure + Collect_Arguments_And_Compile provide the proper value. + + * switch-c.adb: Add documentation for -gnatea and -gnatez + +2009-08-17 Ben Brosgol + + * gnat_ugn.texi: Changed name of package in SAL example, to avoid + clash with Ada 2005 reserved word (interface). + +2009-08-17 Robert Dewar + + * a-crbtgk.adb, a-crdlli.adb, a-direct.adb, a-caldel-vms.adb, + a-calend-vms.adb, a-calfor.adb, a-cdlili.adb, a-chahan.adb, + a-cidlli.adb, a-coinve.adb, a-comlin.adb: Minor code reorganization + (use conditional expressions). + +2009-08-17 Robert Dewar + + * make.adb: Add ??? comment + * tbuild.adb: Minor reformatting + +2009-08-17 Thomas Quinot + + * exp_ch4.adb (Exp_Ch4.Expand_N_Slice.Make_Temporary): Rename to + Make_Temporary_For_Slice to avoid confusion with Tbuild.Make_Temporary. + Use Tbuild.Make_Temporary to create entity for the temporary. + +2009-08-17 Arnaud Charlet + + * make.adb (Process_Multilib, Scan_Make_Arg): Refine previous change + and ignore -mieee switch to avoid spawning an extra gcc in this case. + +2009-08-17 Thomas Quinot + + * tbuild.adb: Minor reformatting + +2009-08-17 Ed Schonberg + + * exp_ch3.adb (Build_Discriminant_Formals): If the discriminals already + exist, as is the case for synchronized types, use the type of the + discriminal in the parameter specification, to prevent a spurious + subtype mismatch in gigi. + +2009-08-17 Robert Dewar + + * prj-env.adb: Minor reformatting + * make.adb: Minor reformatting + Comment updates + +2009-08-17 Javier Miranda + + * exp_ch7.adb (Wrap_Transient_Expression): Update comments. + +2009-08-17 Emmanuel Briot + + * prj-part.adb, prj.adb, prj.ads, prj-nmsc.adb, prj-conf.adb + (Processing_Flags.Require_Obj_Dirs): new field, which controls whether + object directories must be present. In the case of gprclean at least, + these are optional (if they do not exist there is nothing to clean) + +2009-08-17 Robert Dewar + + * prj-env.adb: Minor reformatting + * sem_ch3.adb: Minor reformatting + +2009-08-17 Hristian Kirtchev + + * sysdep.c (__gnat_localtime_tzoff): VxWorks case - Flip the sign of + the time zone since VxWorks chose positive values to represent west + time zones and negative for east zones. + +2009-08-17 Ed Schonberg + + * sem_ch3.adb (Access_Definition): Do not create an Itype reference for + an anonymous access type whose designated type is generic. + +2009-08-17 Arnaud Charlet + + * comperr.adb (Compiler_Abort): Do not generate a bug box when in + codepeer mode, friendlier. + +2009-08-10 Laurent GUERBY + + * make.adb: Handle multilib + +2009-08-10 Vincent Celier + + * prj-env.adb (Create_Config_Pragmas_File.Write_Temp_File): Do not use + the temporary file name in the error message when the temporary file + cannot be created. + +2009-08-10 Yannick Moy + + * gnat_ugn.texi: Fix typo + +2009-08-10 Robert Dewar + + * exp_ch7.adb: Add ??? comment for last change + +2009-08-10 Vincent Celier + + * prj-env.adb (Add_To_Buffer): New procedure + (Create_Config_Pragmas_File): Write to temporary file in one shot + (Create_Mapping_File): Ditto + (Set_Ada_Paths): Ditto + +2009-08-10 Vincent Celier + + PR ada/17566 + * xref_lib.adb (Print_Xref): Make sure that there is at least one space + between a declaration name and its type. + +2009-08-07 Javier Miranda + + * exp_ch7.adb (Wrap_Transient_Expression): Add missing adjustment of + SCIL node. + +2009-08-07 Robert Dewar + + * sem_warn.adb (Warn_On_Unreferenced_Entity): Fix obvious typo. + +2009-08-07 Vincent Celier + + * gnatcmd.adb (GNATCmd): If -U is not used, one and only one main is + specified on the command line and there are switches in the Compiler + package of the project file, use these compilation switches to invoke + the tool. + +2009-08-07 Ben Brosgol + + * gnat_ugn.texi: Wordsmithing edits at beginning of gnatcheck chapter. + +2009-08-07 Ed Schonberg + + * sem_ch10.adb (Analyze_Proper_Body): Indicate name of missing subunit + even if not in main unit, to simplify debugging. + +2009-08-07 Arnaud Charlet + + * gcc-interface/Makefile.in: Fix handling of GCC_FOR_TARGET. + * gcc-interface/Make-lang.in: Update dependencies. + +2009-08-07 Robert Dewar + + * types.ads: Minor reformatting + * sem_ch12.ads (Check_Generic_Child_Unit): Add missing documentation. + * frontend.adb, sem_warn.adb, sem_warn.ads: Fix spelling of + Output_Non_Modified_In_Out_Warnings. + * sem_ch13.adb: Remove ??? comment. + +2009-08-07 Vincent Celier + + * mlib-prj.adb (Build_Library): Include binder generate object file + for SAL when library name is only one character. + +2009-08-07 Thomas Quinot + + * targparm.adb: Minor reformatting + * sem.adb: Minor reformatting + * exp_ch4.adb (Expand_N_Conditional_Expression): Add comment. + +2009-08-07 Emmanuel Briot + + * prj-conf.adb: Remove duplicate directory separator in the output when + an object directory does not exist. + +2009-08-07 Robert Dewar + + * exp_util.adb: Minor reformatting + +2009-08-07 Vincent Celier + + * mlib-prj.adb (Build_Library): Fixed bug in name of ALI file (wrong + length used). + +2009-08-07 Ed Schonberg + + * exp_ch9.adb (Expand_N_Protected_Type_Declaration): In Ravenscar mode, + detect non-static private components that will violate restriction + No_Implicit_Heap_Allocation. + +2009-08-07 Ben Brosgol + + * gnat_ugn.texi: Edited Rule Exemption section of gnatcheck chapter. + +2009-08-02 Eric Botcazou + + * gcc-interface/gigi.h (end_subprog_body): Tweak comment. + * gcc-interface/utils.c (end_subprog_body): Likewise. + * gcc-interface/trans.c (gigi): Likewise. + (gnat_to_gnu): Likewise. + +2009-07-30 Ben Brosgol + + * gnat_ugn.texi: Correct minor texi glitch. + +2009-07-30 Ed Schonberg + + * exp_util.adb (Expand_Subtype_From_Expr): If the type of the + expression has an underlying representation that is an unchecked union, + there is no subtype to build. + +2009-07-30 Robert Dewar + + * a-teioed.adb, exp_disp.adb, s-linux-hppa.ads, s-linux.ads, + s-tasini.adb, sem_ch13.adb, sem_ch3.adb, sem_ch3.ads, sem_ch6.adb, + sem_ch7.adb, adaint.c: Minor reformatting + +2009-07-29 Javier Miranda + + * sem_ch3.ads, sem_ch3.adb (Add_Internal_Interface_Entities): Routine + moved from the expander to the semantic analyzer to allow the + generation of these internal entities when compiling with no code + generation. Required by ASIS. + * sem.adb (Analyze): Add processing for N_Freeze_Entity nodes. + * sem_ch13.ads, sem_ch13.adb (Analyze_Freeze_Entity): New subprogram. + * exp_ch3.adb (Add_Internal_Interface_Entities): Moved to sem_ch3 + (Expand_Freeze_Record_Type): Remove call to + Add_Internal_Interface_Entities because this routine is now called at + early stage --when the freezing node is analyzed. + +2009-07-29 Robert Dewar + + * exp_atag.ads, exp_atag.adb, s-tasini.adb, s-soflin.ads, + exp_disp.adb, g-socket.adb: Minor reformatting + +2009-07-29 Ed Schonberg + + * sem_ch7.adb (New_Private_Type): Create class-wide type after other + attributes have been established, so that they are all inherited by the + class-wide type. + * sem_cat.adb (Validate_Remote_Access_Object_Type_Declaration): Handle + properly named subtypes of class-wide types. + +2009-07-29 Ed Schonberg + + * sem_ch6.adb (Check_Overriding_Indicator): Handle properly overriding + indicators on user-defined operators. + +2009-07-29 Vadim Godunko + + * g-socket.adb (Receive_Vector): Add comment. + +2009-07-29 Javier Miranda + + * frontend.adb (Frontend): Code cleanup. + * exp_atag.ads, exp_atag.adb (Build_Get_Predefined_Prim_Op_Address): + Rewriten as a procedure because it a new out-mode parameters to + keep up-to-date the controlling tag node in the caller. + (Build_Get_Prim_Op_Address): Rewriten as a procedure because it has a + new out-mode parameter to keep up-to-date the controlling tag node in + the caller. + * exp_ch7.adb, sem_ch5.adb, exp_util.adb, sem_util.adb, exp_ch4.adb, + exp_ch6.adb, sem_ch4.adb, exp_ch3.adb: Add new dependency on new + package Sem_SCIL. + * sem_aux.ads, sem_aux.adb (First_Non_SCIL_Node): Removed. Routine + available in new package Sem_SCIL. + (Next_Non_SCIL_Node): Ditto. + * exp_disp.adb (Adjust_SCIL_Node): Removed. Routine available in new + package Sem_SCIL. + (Expand_Dispatching_Call): Update call to modified Exp_Atags routines + plus complete decoration of SCIL dispatching node. + (Find_SCIL_Node): Removed. Routine available in new package Sem_SCIL. + * exp_disp.ads (Adjust_SCIL_Node): Removed. Routine available in new + package Sem_SCIL. + (Find_SCIL_Node): Removed. Routine available in new package Sem_SCIL. + * exp_ch3.adb (Build_Init_Procedure): Fix comment. + * sem_scil.ads, sem_scil.adb: New files. + * gcc-interface/Make-lang.in (GNAT_ADA_OBJS): Addition of sem_scil.o. + Update dependencies. + +2009-07-28 Robert Dewar + + * adaint.h, einfo.ads, prj.adb, sem_util.adb, makeutl.ads, + makeutl.adb: Minor reformatting & code reorganization + * sem_ch3.adb: Minor reformatting. + Fix spelling error (constraint for constrain) in error msg. + +2009-07-28 Emmanuel Briot + + * make.adb, makeutl.adb, makeutl.ads (Project_Tree): Duplicates the + global variable that also exists in makeutl.ads, and that some routines + in that package use already. + (Check): Moved part of the code to makeutl.adb for better sharing with + gprbuild. + +2009-07-28 Arnaud Charlet + + * gcc-interface/Make-lang.in: Update dependencies. + +2009-07-28 Emmanuel Briot + + * prj.adb, prj.ads (Compute_All_Imported_Projects): Make sure the + importing project does not end up in the list, in the case of extending + projects. + * make.adb, makeutl.adb, makeutl.ads (File_Not_A_Source_Of): Moved to + makeutl.ads, for better sharing with gprbuild. + +2009-07-28 Arnaud Charlet + + * gnat_ugn.texi: Fix typo. + +2009-07-28 Ed Schonberg + + * sem_ch3.adb (Build_Derived_Concurrent_Type): Handle properly a + derivation that renames some discriminants and constrain others. + * exp_ch9.adb (Build_Protected_Subprogram_Call): If the type of the + prefix is a derived untagged type, convert to the root type to conform + to the signature of the protected operations. + +2009-07-28 Robert Dewar + + * sinfo.ads: Update comments. + * exp_attr.adb: Minor reformatting + +2009-07-28 Ed Schonberg + + * sem_aggr.adb (Get_Value): A named association in a record aggregate + should be treated as a modification of the named component, not as a + reference. + +2009-07-28 Quentin Ochem + + * prj-tree.ads, prj-tree.adb (Free): Minor editing. + * prj.ads, prj.adb (Image): Ditto. + +2009-07-28 Arnaud Charlet + + * frontend.adb: Minor reformatting. + (Frontend): Only call Check_SCIL_Nodes if assertions are enabled, + for efficiency. + +2009-07-28 Bob Duff + + * exp_attr.adb (Expand_Access_To_Protected_Op): Use 'Access instead of + 'Address to get a pointer to the protected body wrapper. + +2009-07-28 Javier Miranda + + * gnat1drv.adb (Adjust_Global_Switches): Disable generation of SCIL + nodes if we are not generating code. + * frontend.adb (Check_SCIL_Node): New subprogram. Used to check + attribute SCIL_Related_Node of SCIL dispatching nodes. + (Check_SCIL_Nodes): New instantiation of Traverse_Proc. + * sinfo.ads (Is_SCIL_Node,Set_Is_SCIL_Node): Removed + (SCIL_Nkind,Set_SCIL_Nkind): Removed. + (SCIL_Entity): Update documentation. + (SCIL_Related_Node): Update documentation. + (SCIL_Controlling_Tag): New attribute. + (SCIL_Target_Prim): Update documentation. + (N_Null_Statement): Remove attributes associated with SCIL nodes. + (N_SCIL_Dispatch_Table_Object_Init): New node. + (N_SCIL_Dispatch_Table_Tag_Init): New node. + (N_SCIL_Dispatching_Call): New node. + (N_SCIL_Tag_Init): New node. + * sinfo.adb (Is_SCIL_Node,Set_Is_SCIL_Node): Removed + (SCIL_Nkind,Set_SCIL_Nkind): Removed. + (SCIL_Controlling_Tag/Set_SCIL_Controlling_Tag): New subprogram. + (SCIL_Entity,Set_SCIL_Entity): Applicable only to SCIL nodes. + (SCIL_Related_Node,Set_SCIL_Related_Node): Applicable only to SCIL nodes + (SCIL_Target_Prim,Set_SCIL_Target_Prim): Applicable only to + N_SCIL_Dispatching_Call nodes. + * sem.adb (Analyze): No need to analyze SCIL nodes. + * sem_aux.ads, sem_aux.adb (First_Non_SCIL_Node): New subprogram + (Next_Non_SCIL_Node): New subprogram + * sem_ch4.adb (Analyze_Type_Conversion): Adjust relocated SCIL + dispatching nodes. + * sem_ch5.adb (Analyze_Iteration_Scheme): Adjust relocated SCIL + dispatching node. + * sem_util.adb (Insert_Explicit_Dereference): Adjust relocated SCIL + dispatching node. + * exp_ch3.adb (Build_Array_Init_Proc): Skip SCIL nodes when processing + null statement nodes. + (Build_Init_Procedure): Generate new SCIL node. + * exp_ch4.adb (Expand_N_And_Then): Adjust relocated SCIL dispatching + node. + * exp_ch6.adb (Is_Null_Procedure): Skip SCIL nodes. Required because + they are currently implemented as special N_Null_Statement nodes. + * exp_ch7.adb (Wrap_Transient_Statement): If the relocated node is a + procedure call then check if some SCIL node references it and needs + readjustment. + * exp_disp.ads (SCIL_Node_Kind): Removed. + (Adjust_SCIL_Node): New subprogram. + (Find_SCIL_Node): New subprogram. + (Get_SCIL_Node_Kind): Removed. + (New_SCIL_Node): Removed. + * exp_disp.adb (Adjust_SCIL_Node): New subprogram + (Expand_Dispatching_Call): Generate new SCIL dispatching node including + decoration of its new controlling_tag attribute. + (Get_SCIL_Node_Kind): Removed. + (Find_SCIL_Node): New subprogram. + (Make_Secondary_DT): Generate new SCIL nodes. + (Make_Tags): Generate new SCIL nodes. + (New_SCIL_Node): Removed. + * exp_util.adb (Insert_Actions): Handle SCIL nodes. + (Remove_Side_Effects): Check if relocated nodes require readjustment + of some SCIL dispatching node. + * gcc-interface/trans.c (gnat_to_gnu): Do nothing with new SCIL nodes. + +2009-07-28 Robert Dewar + + * prj-nmsc.adb, g-expect.adb, prj.ads: Minor reformatting + +2009-07-28 Sergey Rybin + + * gnat_ugn.texi: Add section about gnatcheck rule exemption. + +2009-07-28 Vadim Godunko + + * s-oscons-tmplt.c: Define _XOPEN_SOURCE on Linux, otherwise IOV_MAX is + not defined by limits.h. + + * g-socket.adb (Receive_Vector): Use minimum length from user's vector + length and maximum supported length of data vector. + +2009-07-28 Gary Dismukes + + * usage.adb: Inhibit printing gcc-specific switches for AAMP target. + * make.adb: Call Get_Target_Parameters before calling Usage so that + VM_Target and AAMP_On_Target will be set. + +2009-07-28 Olivier Hainque + + * g-ssinty.ads: Remove, pointless and just confusing at this stage. + * gnat_rm.texi: Remove documentation. + * g-sse.ads: Minor reorg along the way. + * gcc-interface/Makefile.in: Remove processing for g-ssinty. + * g-ssvety.ads: Minor comment updates. + +2009-07-28 Sergey Rybin + + * gnat_ugn.texi: gnatcheck 'Format of the Report File' section - update + for the new format of the report file. + +2009-07-28 Sergey Rybin + + * gnat_ugn.texi: gnatcheck Deeply_Nested_Inlining rule: Update doc. + +2009-07-28 Pascal Obry + + * g-expect.adb: Record standard handles only on Windows. + +2009-07-27 Emmanuel Briot + + * prj.ads, prj-nmsc.adb (Override_Kind): add debug trace + Add comments. + +2009-07-27 Sergey Rybin + + * gnat_ugn.texi: gnatcheck Unconstrained_Array_Returns rule: Add to the + rule definition the paragraph that explains that generic functions and + functions from generic packages are not checked. + +2009-07-27 Gary Dismukes + + * sem_ch6.adb (New_Overloaded_Entity): Add test for an expanded null + procedure when determining whether to set the Overridden_Operation + field of a subprogram overriding an inherited subprogram. + +2009-07-27 Robert Dewar + + * a-except.adb, a-except-2005.ads: Minor reformatting + +2009-07-27 Robert Dewar + + * sem_util.adb, sem_util.ads (Kill_Current_Values): Reset Is_Known_Valid + +2009-07-27 Javier Miranda + + * exp_disp.adb (Expand_Dispatching_Call): Reverse previous patch and + add some documentation explaining why the SCIL nodes must be generated + at that point. + +2009-07-27 Olivier Hainque + + * a-except.adb: Bind to __builtin_longjmp directly. + * a-except-2005.ads: Provide direct binding to __builtin_longjmp + for sjlj variants. + * a-exexpr.adb: Use it. + * a-except-xi.adb: Likewise. + * raise.c (_gnat_builtin_longjmp): Remove and update comments. + * raise.h (_gnat_builtin_longjmp): Remove declaration. + +2009-07-27 Ed Schonberg + + * sem_eval.adb (Compile_Time_Compare): More precise handling of + Known_Valid flag, to prevent spurious range deductions when scalar + variables may be uninitialized. New predicate Is_Known_Valid_Operand. + +2009-07-27 Robert Dewar + + * gnatfind.adb, osint.ads, sem.adb, xr_tabls.adb: Minor reformatting + and code clean up. + +2009-07-27 Ed Schonberg + + * exp_ch9.adb (Expand_N_Timed_Entry_Call): Do not attempt expansion in + Ravenscar mode. Error has already been posted on specification. + + * sem.adb: Further code clean ups. + +2009-07-27 Robert Dewar + + * g-sse.ads: Minor reformatting + +2009-07-27 Arnaud Charlet + + * xref_lib.adb (Add_Xref_File_Internal, Find_ALI_Files): Add support for + alternate ali extension. + * xr_tabls.adb (ALI_File_Name, Get_File, Set_Unvisited): Take into + account Osint.ALI_Suffix. + * osint.ads (ALI_Suffix): Make visible. + * gnatfind.adb (Gnatfind): Add support for --ext= switch. + * gnat_ugn.texi: Document new gnatfind --ext= switch. + +2009-07-27 Ed Schonberg + + * sem.adb (Walk_Library_Items): If main unit is an instance body, do + its spec first. + +2009-07-27 Javier Miranda + + * exp_disp.adb (Expand_Dispatching_Call): Generate the SCIL node after + the dispatching call has is expanded. + +2009-07-27 Ed Schonberg + + * exp_attr.adb (Expand_Attribute_Reference, case 'Valid): Reset the + Is_Known_Valid flag on the temporary created for the value whose + validity is being checked. + + * sem.adb (Do_Unit_And_Dependents): Further code reorganization to + handle properly main units that are package specifications. + +2009-07-27 Geert Bosch + + * einfo.ads (Checks_May_Be_Suppressed): Fix typo in comment + * sem_aux.ads: Fix typo in comment + * sem_util.ads (Is_LHS): Adjust comment to match body + +2009-07-27 Sergey Rybin + + * gnat_ugn.texi (gnatcheck Complex_Inlined_Subprograms rule): Update + rule definition. + +2009-07-27 Olivier Hainque + + * g-sse.ads, g-ssvety.ads: Update comments. + +2009-07-27 Sergey Rybin + + * gnat_ugn.texi: Update gnatcheck doc. + +2009-07-27 Arnaud Charlet + + * lib-xref.ads: Allocate/document 'o' char for use by references to + spark 'own' variables. + +2009-07-27 Gary Dismukes + + * sem_ch6.adb (Analyze_Function_Return): Set Referenced on return + objects, since these are implicitly referenced by the return statement. + * sem_warn.adb (Warn_On_Unreferenced_Entity): No longer a need to test + Is_Return_Object in this procedure, as return objects will never make + it here since they're now marked as Referenced. + +2009-07-27 Robert Dewar + + * exp_ch2.adb, sem_util.adb, sem_util.ads: Minor reformnatting + +2009-07-27 Robert Dewar + + * exp_ch6.adb (Expand_Call): Reset Is_Known_Valid after call + + * sem_ch3.adb, sem_eval.adb, sem_aux.adb: Minor comment reformatting + +2009-07-27 Geert Bosch + + * checks.adb (Find_Check): Minor streamlining of logic. + * gnat1drv.adb(Gnat1drv): Put Check_Rep_Info in its alphabetical order. + * debug.adb: Document -gnatdX debug flag + * exp_ch2.adb(Expand_Entity_Reference): Implement new -gnatdX flag to + list information about reads from scalar entities. + Also slightly simplify condition for Expand_Current_Value. + * sem_util.ads, sem_util.adb (Is_LHS, Is_Actual_Out_Parameter): New + functions. + +2009-07-26 Dave Korn + + PR bootstrap/40578 + * adaint.h (FOPEN, STAT, FSTAT, LSTAT, STRUCT_STAT): Rename from these + (GNAT_FOPEN, GNAT_STAT, GNAT_FSTAT, GNAT_LSTAT, GNAT_STRUCT_STAT): ... + to these. + (__gnat_stat): Adjust reference to STAT in prototype. + * adaint.c (__gnat_try_lock, __gnat_fopen, __gnat_file_length, + __gnat_named_file_length, __gnat_file_time_name, __gnat_file_time_fd, + __gnat_get_libraries_from_registry, __gnat_stat, __gnat_file_exists, + __gnat_is_regular_file, __gnat_is_directory, __gnat_is_readable_file, + __gnat_is_writable_file, __gnat_is_executable_file, + __gnat_set_writable, __gnat_set_executable, __gnat_set_non_writable, + __gnat_set_readable, __gnat_set_non_readable, __gnat_is_symbolic_link, + __gnat_copy_attribs): Adjust all references to the above. + * cstreams.c (__gnat_is_regular_file_fd): Likewise. + +2009-07-23 Ed Schonberg + + * sem.adb (Do_Unit_And_Dependents): Now that specs and bodies are not + done at the same time, guard against listing a body more than once. + +2009-07-23 Robert Dewar + + * exp_ch6.adb: Minor reformatting + +2009-07-23 Ed Schonberg + + * sem_ch3.adb (Analyze_Object_Declaration): A scalar constant with a + static expression is known valid. + * sem_eval.adb (Compile_Time_Compare): Handle properly non-static + operands of a subtype with a single value. + +2009-07-23 Ed Schonberg + + * sem.adb (Do_Units_And_Dependents): Process bodies only for units that + are in the context of the main unit body. + +2009-07-23 Sergey Rybin + + * gnat_ugn.texi (Misnamed_Controlling_Parameters gnatcheck rule): Fix + misprint in rule description. + +2009-07-23 Gary Dismukes + + * exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration): Replace + test that the object declaration is within an extended return statement + with direct test of whether the declared object associated with the + build-in-place call is a return object, since the enclosing function + might not even be a build-in-place function. + +2009-07-23 Robert Dewar + + * freeze.adb, prj-nmsc.adb, errout.adb: Minor reformatting + Minor code reorganization + +2009-07-23 Arnaud Charlet + + * sem_prag.adb (Analyze_Pragma): Do not ignore pragma Pack on records + for static analysis, only packed arrays are causing troubles. + +2009-07-23 Gary Dismukes + + * sem_aggr.adb (Resolve_Extension_Aggregate): Report an error when the + ancestor part is a call to a limited function with an unconstrained + result subtype unless the aggregate has a null extension type. + * sem_ch3.adb (Is_Null_Extension): Use the base type when retrieving + the parent type declaration to avoid blowups on subtype cases. + +2009-07-23 Robert Dewar + + * par-ch4.adb (P_Aggregate_Or_Paren_Expr): Better message for missing + comma. + + * sem_util.adb (Wrong_Type): Special message for cases like A and B = 0 + + * s-regexp.adb: Minor reformatting + * scos.ads: Minor reformatting. + +2009-07-23 Arnaud Charlet + + * freeze.adb (Set_Small_Size): Remove extra space for consistency with + other similar messages. + * sem_prag.adb (Freeze_Record_Type, Freeze_Entity): Disable error + messages/implicit packing in CodePeer mode. + (Analyze_Pragma [case pragma Pack]): Ignore pragma in CodePeer mode. + * errout.adb (Special_Msg_Delete): Suppress 'size too small' message in + CodePeer mode. + +2009-07-23 Pascal Obry + + * prj-nmsc.adb: Fix spec/body naming extension on case insensitive + systems. + +2009-07-23 Robert Dewar + + * einfo.ads, g-ssvety.ads, s-regexp.adb, g-sse.ads: Update comment. + Minor reformatting. + +2009-07-23 Yannick Moy + + * s-regexp.adb (Check_Well_Formed_Pattern): Called before compiling the + pattern. + (Raise_Exception_If_No_More_Chars): Remove extra blank in exception + string. + (Raise_Exception): Ditto. + +2009-07-23 Olivier Hainque + + * g-sse.ads: Simplify comment. + +2009-07-23 Olivier Hainque + + * g-ssinty.ads: New unit. GNAT.SSE.Internal_Types. Factorize + low level internal type definitions for distinct higher level + binding development activities (user type definitions and + operations). + * gnat_rm.texi: Document it. + * g-ssvety.ads: Use it. + * gcc-interface/Makefile.in: (x86 32/64 linux, cygwin32 sections): Add + g-ssinty.o to EXTRA_GNATRTL_NONTASKING_OBJS. + * gcc-interface/utils.c (gnat_internal_attribute_table): Add entry + for the "may_alias" attribute. + +2009-07-23 Thomas Quinot + + * scos.ads: Minor typo fix + + * gcc-interface/decl.c (validate_alignment): For the case of an + implicit array base type, look for alignment clause on first subtype. + +2009-07-23 Robert Dewar + + * gcc-interface/decl.c (gnat_to_gnu_field): Don't check for overlap + with tagged parent if tagged parent is fully repped. + +2009-07-23 Ed Schonberg + + * sem.adb (Walk_Library_Units): Handle properly the case where a unit + in the context depends on the spec of the main unit, by delaying + processing of the main unit body until all other units have been + processed. + +2009-07-23 Arnaud Charlet + + * a-convec.adb: Add comments about suspicious/subtle code. + +2009-07-23 Ed Schonberg + + * einfo.ads: Document use of Alias in private overriding + +2009-07-23 Thomas Quinot + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause): For the case of + an array type, propagate alignment from first subtype to implicit base + type so that other subtypes (such as the itypes for aggregates of the + type) also receive the expected alignment. + + * g-comlin.ads: Minor documentation clarification/rewording. + * scos.ads: Minor comments update. + * lib-writ.ads: Minor reformatting + +2009-07-23 Gary Dismukes + + * exp_ch3.adb (Expand_N_Object_Declaration): For an initialized object + of a class-wide interface type that is a return object of a + build-in-place function, bypass the interface-related expansions into + renamings with displacement conversions, etc. + * exp_ch5.adb (Expand_N_Extended_Return_Statement): Add an assertion + for the case where a renaming occurs in a build-in-place context, to + assert that the bypassing of the build-in-place treatment only occurs + in the case of a renaming that is an expansion of a return expression + that is itself a build-in-place function call. + +2009-07-23 Ed Schonberg + + * sem_ch4.adb (Try_Primitive_Operation): A primitive operation is a + valid candidate interpretation in a prefixed view if it is hidden, but + overrides an inherited operation declared in the visible part. + +2009-07-23 Robert Dewar + + * exp_ch4.adb (Expand_N_Type_Conversion): Don't promote integer + division operands to 64-bit at all in any circumstances. + +2009-07-23 Robert Dewar + + * exp_ch4.adb (Analyze_N_Op_Rem): Assume operands are valid when + checking ranges for mod/rem to see if conditional jump will be + generated. + (Analyze_N_Op_Rem): Don't try to check actual lower bounds for + generating special -1 test for rem, generate it whenever both + operands can be negative (match circuit in Sem_Res). + (Analyze_N_Op_Rem): Don't go to base type, no longer needed and + destroys memory of positive range. + * sem_res.adb (Resolve_Arithmetic_Op): Assume operands are valid when + checking ranges for mod/rem to see if conditional jump will be generated + +2009-07-23 Ed Schonberg + + * exp_ch3.adb (Build_Equivalent_Record_Aggregate): If the type of a + scalar components has non-static bounds, the equivalent aggregate + cannot be built, even if the expression is static, because range checks + will be generated. + +2009-07-23 Robert Dewar + + * exp_ch4.adb (Expand_N_Type_Conversion): Don't promote integer + division operands to 64-bit inside a conversion if 64-bit division not + available. + +2009-07-23 Sergey Rybin + + * gnat_ugn.texi: Update doc on Misnamed_Identifiers rule. + +2009-07-23 Javier Miranda + + * sinfo.ads, sinfo.adb (SCIL_Entity/Set_SCIL_Entity): new subprograms + (Entity/Set_Entity): not available in N_Null_Statement nodes + (Is_Scil_Node): renamed as Is_SCIL_Node + (Scil_Nkind): renamed as SCIL_Nkind + (Scil_Related_Node): renamed as SCIL_Related_Node + (Scil_Target_Prim): renamed as SCIL_Target_Prim + (Set_Is_Scil_Node): Renamed as Set_Is_SCIL_Node + (Set_Scil_Related_Node): Renamed as Set_SCIL_Related_Node + (Set_Scil_Target_Prim): Renamed as Set_SCIL_Target_Prim + Update documentation + * exp_disp.ads (Scil_Node_Kind): Renamed as SCIL_Node_Kind + (Get_Scil_Node_Kind): Renamed as Get_SCIL_Node_Kind + (New_Scil_Node): Renamed as New_SCIL_Node + * exp_disp.adb Update all occurrences of New_Scil_Node to New_SCIL_Node. + (Get_Scil_Node_Kind): Renamed as Get_SCIL_Node_Kind + (New_Scil_Node): Renamed as New_SCIL_Node + * exp_ch3.adb Update occurrence of New_Scil_Node to New_SCIL_Node. + +2009-07-23 Robert Dewar + + * sem_prag.adb: No_Return is an Ada 2005 pragma, not a GNAT pragma + * snames.ads-tmpl: No_Return is an Ada 2005 pragma, not a GNAT pragma + * einfo.adb: Minor reformatting + +2009-07-23 Robert Dewar + + * checks.adb (Apply_Arithmetic_Overflow_Check): Add comments + cross-referencing the new related code in + Exp_Ch4.Expand_N_Type_Conversion. + * exp_ch4.adb (Expand_N_Type_Conversion): Avoid unnecessary overflows + + * exp_disp.adb, exp_disp.ads, sinfo.ads: Minor reformatting. + Add comment. + +2009-07-23 Javier Miranda + + * sinfo.ads (Is_Scil_Node, Scil_Nkind, Scil_Related_Node, + Scil_Target_Prim, N_Has_Entity): Add missing documentation. + * exp_disp.ads (Scil_Node_Kind): Ditto. + * exp_disp.adb (Make_DT, Make_Tags): Ditto. + * exp_ch3.adb (Build_Init_Procedure): Ditto. + +2009-07-23 Javier Miranda + + * einfo.adb (Component_Type): Add missing assertion. + * sem_res.adb (Resolve_Call): Ensure proper kind of entity before + reading attribute Component_Size. + * exp_ch4.adb (Is_Safe_In_Place_Array_Op): Ensure proper kind of entity + before reading attributes Component_Size and Component_Type. + * exp_ch3.adb (Build_Initialization_Call): Ensure proper kind of entity + before reading attribute Component_Type. + +2009-07-23 Olivier Hainque + + * gnat_rm.texi: Document the GNAT.SSE units. + +2009-07-23 Ed Schonberg + + * sem_ch6.adb (Analyze_Return_Type): Do not create itype reference for + not null return if it appears on a subunit. + +2009-07-23 Robert Dewar + + * exp_ch5.adb (Expand_N_Assignment_Statement): Do left-side validity + check right away so it does not get skipped for early returns, e.g. + array assignments. + (Expand_N_Assignment_Statement): Don't propagate Is_Known_Valid to + left-side unless we really know the value is valid. + + * errout.adb, exp_ch3.adb, exp_disp.ads, sinfo.ads, exp_disp.adb: Minor + reformatting. Minor code reorganization. Add comments. + +2009-07-23 Robert Dewar + + * get_scos.adb (Skip_EOL): Fix error of mishandling end of line after + complex condition. + +2009-07-23 Gary Dismukes + + * sem_ch6.adb (Check_Return_Subtype_Indication): Replace type equality + with test of coverage, to allow specific type objects in extended + returns of class-wide functions. Remove now-unnecessary special-case + tests that allowed this in certain cases of expanded extended returns. + +2009-07-23 Javier Miranda + + * sinfo.ads,sinfo.adb (Entity/Set_Entity): Attribute available in + N_Null_Statements (for SCIL nodes). + (Is_Scil_Node/Set_Is_Scil_Node): New attribute (for SCIL nodes). + (Scil_Nkind/Set_Scil_Nkind): New attribute (for SCIL nodes). + (Scil_Related_Node/Set_Scil_Related_Node): New attribute (for SCIL + nodes). + (Scil_Target_Prim/Set_Scil_Target_Prim): New attribute (for SCIL nodes). + * exp_disp.adb (Expand_Dispatching_Call): Add generation of SCIL node + associated with dispatching call. + (Get_Scil_Node_Kind): New function that returns the kind of SCIL node. + (Make_DT, Make_Tags): Add generation of SCIL nodes associated with + initialization of dispatch tables and initialization of tags. + (New_Scil_Node): New function that creates a new SCIL node. + (Build_Init_Procedure): Add generation of SCIL node associated with the + initialization of tags done in the IP subprogram. + +2009-07-23 Ed Schonberg + + * errout.adb (Error_Msg_NEL): If the entity in the initial message has + Warnings_Off, do not emit continuation messages. + + * sem_ch10.adb: Set Is_Compilation_Unit on generated child subprogram + spec. + +2009-07-23 Emmanuel Briot + + * ali.adb: Minor comment update + +2009-07-23 Vasiliy Fofanov + + * s-win32.ads (HANDLE): Define to be the same size as address type. + Fix copyright. + +2009-07-23 Olivier Hainque + + * g-sse.ads: New file. Root of the SSE facilities trees, with + general description and common declarations. + * g-ssvety.ads: New file. Expose user level SSE vector types. + * impunit.adb (Non_Imp_File_Names_95): Register new units. + * gcc-interface/Makefile.in (x86 32/64 linux, win32): Add + EXTRA_GNATRTL_NONTASKING_OBJS entries for SSE units. + +2009-07-23 Ben Brosgol + + * gnat_ugn.texi: Wordsmithing. + +2009-07-23 Arnaud Charlet + + * prj-conf.ads, prj-conf.adb: Switch to GPLv3. + +2009-07-22 Eric Botcazou + + * exp_aggr.adb (Gen_Loop): Do not qualify the bounds of the range if + they are already of the base type of the index. + +2009-07-22 Brett Porter + + * sysdep.c, init.c: Fix typo: _SPE_ should have been __SPE__. + +2009-07-22 Robert Dewar + + * vms_data.ads: Add entry for SCO_OUTPUT (-gnateS) + * gnat_ugn.texi: Add documentation for -gnateS switch + * ug_words: Add entry for -gnateS /SCO_OUTPUT + * gcc-interface/Make-lang.in: Update dependencies. + + * get_scos.adb, get_scos.ads, gnat1drv.adb, par_sco.adb, + par_sco.ads, put_scos.adb, put_scos.ads, scos.adb, scos.ads: Initial + complete information for SCO input/output. + +2009-07-22 Sergey Rybin + + * gnat_ugn.texi: Update doc for some gnatcheck rules. + +2009-07-22 Robert Dewar + + * par_sco.adb, par_sco.ads (pscos): New debug routine to output + contents of SCO tables. + * put_scos.adb, put_scos.ads, get_scos.adb, get_scos.ads, + scos.adb, scos.ads: New files. + * gcc-interface/Make-lang.in: Update dependencies. + + * lib-util.ads, gnatbind.ads, ali.ads, binderr.ads: Minor comment + fixes and reformatting. + +2009-07-22 Robert Dewar + + * g-socket.ads: Minor reformatting + +2009-07-22 Gary Dismukes + + * sem_warn.adb (Warn_On_Unreferenced_Entity): Add warning messages that + include the entity kind for following cases of unreferenced entities: + E_Label, E_Discriminant, E_Package, E_Exception, and Formal_Object_Kind. + +2009-07-22 Ed Falis + + * s-vxwext-kernel.adb, s-vxwext-kernel.ads: Replace use of taskStop + with taskSuspend. + +2009-07-22 Arnaud Charlet + + * adadecode.c: Make this file compilable outside of GCC. + +2009-07-22 Thomas Quinot + + * g-socket.adb, g-socket.ads (Check_Selector): Make sure that + (partially) default-initialized socket sets are handled properly by + clearing their Set component. + +2009-07-22 Bob Duff + + * gnat_ugn.texi: Clarify the -gnatVx (validity checking) switches. + +2009-07-22 Robert Dewar + + * gnat_ugn.texi: Minor reformatting + +2009-07-22 Ed Schonberg + + * errout.adb (Error_Msg): A style message within an instantiation + should not be labelled as an error. + +2009-07-22 Ed Schonberg + + * freeze.adb (Freeze_Entity): Do not generate extra formal for function + in initialization expression if function does not have convention Ada. + +2009-07-22 Sergey Rybin + + * gnat_ugn.texi, vms_data.ads: Add qualifier for new gnatpp option + '--separate-label' to control label layout. + +2009-07-22 Robert Dewar + + * exp_tss.ads, sem_eval.adb: Minor reformatting + +2009-07-22 Bob Duff + + * exp_dist.adb, exp_dist.ads: Update comments. + +2009-07-22 Brett Porter + + * init.c (__gnat_init_float): For SPE, set bits in SPEFSCR instead of + FPSCR. + * sysdep.c (__gnat_get_task_options): Set task option enabling SPE. + +2009-07-22 Gary Dismukes + + * exp_ch5.adb, sem_util.adb, sem_attr.adb, exp_dbug.ads, exp_ch2.adb, + exp_tss.ads, exp_ch4.adb, sem_ch4.adb: Correct spelling error. + Minor reformatting. + * sem_res.adb (Resolve_Explicit_Dereference): Reword one comment that + used poor terminology. + +2009-07-22 Robert Dewar + + * freeze.adb, sem_ch3.adb, sem_prag.adb: Minor reformatting + * sem_eval.adb, exp_tss.adb: Minor comment update. + * stylesw.adb: Code clean up. + +2009-07-22 Ed Schonberg + + * freeze.adb (Freeze_Entity): If Implicit_Packing is enabled, and the + component size is an exact number of bytes, an array type can have a + size clause that forces packing even though the array type itself is + not bit-packed. + +2009-07-22 Thomas Quinot + + * sem_ch3.adb (Analyze_Object_Declaration): For a constant declaration, + if there is a previous entity with the same name in the scope, ignore + it if it is the renaming declaration for a generic package introduced + in instances. + +2009-07-22 Nicolas Roche + + * seh_init.c: use RtlAddFunctionTable to register our SEH exception + handler on x86_64 windows. + +2009-07-22 Arnaud Charlet + + * sem_prag.adb (Analyze_Pragma): Initialize/Normalize_Scalars create + false positives in CodePeer, so ignore this pragma in this mode. + +2009-07-22 Thomas Quinot + + * sem_util.adb, sem_ch10.adb: Minor reformatting + + * g-socket.adb (Receive_Socket, recvfrom(2) variant): Apply required + special handling for the case of no data received and Item'First = + Stream_Element_Offset'First. + (Last_Index): New subprogram factoring the above special handling + over the various locations where it is required. + +2009-07-22 Arnaud Charlet + + * gnat1drv.adb (Gnat1drv): Also disable division by zero and alignment + checks in CodePeer_Mode. + * gcc-interface/Make-lang.in: Update dependencies. + +2009-07-22 Ed Schonberg + + * sem_aggr.adb: Improve error message. + + * sem_ch13.adb: If Ignore_Rep_Clauses is enabled, do a minimal analysis + of an address representation clause. + * freeze.adb (Freeze_Static_Object): An local imported object is legal + if it has an address clause. + +2009-07-22 Thomas Quinot + + * sem_elab.adb (Insert_Elab_Check): When relocating an overloaded + expression to insert an elab check using a conditional expression, be + sure to carry the original list of interpretations to the new location. + +2009-07-22 Gary Dismukes + + * gnat1drv.adb: Fix spelling error. + +2009-07-22 Javier Miranda + + * sem_type.ads, sem_type.adb (In_Generic_Actual): Leave this subprogram + at the library level and fix a hidden bug in its implementation: its + functionality for renaming objects was broken because + N_Object_Renaming_Declarations nodes are not a subclass of + N_Declaration nodes (as documented in sinfo.ads). + * sem_util.adb (Check_Dynamically_Tagged_Expression): Include in this + check nodes that are actuals of generic instantiations. + +2009-07-22 Ed Schonberg + + * sinfo.ads, sinfo.adb (Pending_Context): New flag to indicate that the + context of a compilation unit is being analyzed. Used to detect + circularities created by with_clauses that are not detected by the + loading machinery. + * sem_ch10.adb (Analyze_Compilation_Unit): Set Pending_Context before + analyzing the context of the current compilation unit, to detect + possible circularities created by with_clauses. + +2009-07-22 Thomas Quinot + + * sem_type.adb (Get_First_Interp): Fix wrong loop exit condition. + +2009-07-22 Robert Dewar + + * sem_res.adb (Check_No_Direct_Boolean_Operators): Add check for -gnatyB + * style.ads, styleg.adb, styleg.ads (Check_Boolean_Operator): New + procedure. + * usage.adb, stylesw.ads, stylesw.adb: Add handling of -gnatyB switch + * gnat_ugn.texi: Add documentation of -gnatyB + * vms_data.ads: Add entry for -gnatyB (STYLE=BOOLEAN_OPERATORS) + +2009-07-22 Robert Dewar + + * s-stchop.adb, a-direct.adb, a-ztexio.adb, gnatchop.adb, prj-proc.adb, + make.adb, s-regpat.adb, ali-util.adb, a-ngcefu.adb, prep.adb, + s-tassta.adb, a-tifiio.adb, a-textio.adb, prj.adb, uintp.adb, + s-valrea.adb, a-ngelfu.adb, prepcomp.adb, sinput-l.adb, vms_conv.adb, + errout.adb, g-alleve.adb, repinfo.adb, a-wtedit.adb, ali.adb, + a-witeio.adb, prj-dect.adb, prj-nmsc.adb, sinput-c.adb, binde.adb, + s-regexp.adb, s-imgrea.adb, a-teioed.adb, errutil.adb, prj-util.adb, + a-ztedit.adb, gnatls.adb, prj-conf.adb, bcheck.adb, s-scaval.adb, + erroutc.adb, osint.adb, a-strfix.adb, s-fileio.adb: Make sure sources + obey short-circuit style rule. + +2009-07-20 Bob Duff + + * sem_ch13.adb (Analyze_Record_Representation_Clause): Use "and then" + instead of "and", because otherwise Parent_Last_Bit is read + uninitialized in the case where it's not a tagged type, or the tagged + parent does not have a complete rep clause. + +2009-07-20 Robert Dewar + + * stylesw.ads: Minor documentation change. + + * types.ads: Minor reformatting + +2009-07-20 Javier Miranda + + * exp_disp.ads (Apply_Access_Checks): New subprogram that takes care of + generating the tag checks associated with dispatching calls. + * exp_disp.adb (Apply_Access_Checks): New subprogram. + (New_Value): This routine was previously local to expand dispatching + calls but it is now used also by Apply_Access_Checks. + (Expand_Dispatching_Calls): Cleanup code because the functionality of + tag checks is now provided by Apply_Access_Checks. + * exp_ch6.adb (Expand_Call): Incorporate generation of tag checks in + case of dispatching calls. + +2009-07-20 Arnaud Charlet + + * gnat1drv.adb (Gnat1drv): Also disable Elaboration_Check in + CodePeer_Mode. + +2009-07-20 Gary Dismukes + + * exp_prag.adb (Expand_Pragma_Import_Export_Exception): When compiling + for VMS, only rewrite the first component of the associated exception's + aggregate init (as 'V'), and eliminate the bogus rewrites of the second + and third components that were being replaced with 'M' and 'S'. + +2009-07-20 Arnaud Charlet + + * gnat1drv.adb (Gnat1drv): Suppress access checks in CodePeer mode. + Also do not generate error when parsing a spec in CodePeer mode. + +2009-07-20 Javier Miranda + + * checks.adb (Apply_Access_Check): Avoid checks on availability of + runtime function Offset_To_Top_Ptr when compiling with no tagged + types expansion. + * exp_ch3.adb (Build_Init_Procedure): Leave open the possibility of + adding code to the init proc when compiling for VM backends. + +2009-07-20 Vincent Celier + + * switch-m.ads, switch-m.adb (Normalize_Compiler_Switches): Take into + account switches -gnatw.? + +2009-07-20 Thomas Quinot + + * sem_dist.adb, exp_dist.adb: Minor reformatting + + * Make-generated.in: New file. + + * gcc-interface/Make-lang.in: Use Make-generated.in fragment. + +2009-07-20 Javier Miranda + + * sem_util.ads, sem_util.adb (Check_Dynamically_Tagged_Expression): New + subprogram. + * sem_aggr.adb (Resolve_Array_Aggregate): Check incorrect use of + dynamically tagged expression. + * sem_ch3.adb (Analyze_Object_Declaration): Call new routine that + factorizes code. + * sem_ch6.adb (Analyze_Function_Return, Process_Formals): Ditto. + * sem_ch8.adb (Analyze_Object_Renaming): Ditto. + +2009-07-20 Arnaud Charlet + + * gnat1drv.adb (Gnat1drv): Set operating mode to Generate_Code when + CodePeer_Mode is set, to benefit from full front-end expansion + (e.g. generics). + +2009-07-20 Ed Schonberg + + * sem_res.adb: Add guard. + + * exp_disp.adb, sem_disp.adb (Make_DT): Check underlying view of type + for possible attribute definition of External_Tag, in case clause + appears in the private part of a package. + +2009-07-20 Jerome Guitton + + * gcc-interface/Makefile.in: cleanup powerpc linux target pairs. + +2009-07-20 Vadim Godunko + + * a-coorma.adb: Minor reformatting. + +2009-07-20 Ed Schonberg + + * sem_ch3 (Build_Itype_Reference): Make public, for use on non-null + access return types. + * sem_ch6.adb (Analyze_Return_Type): If return is a not null subtype, + provide an itype reference to gigi to force elaboration of the subtype + at the proper point. + +2009-07-20 Tristan Gingold + + * g-expect.adb: Avoid closeing already closed handle. + +2009-07-20 Robert Dewar + + * sprint.adb (Write_Subprogram_Name): New procedure to output + subprogram name with possible preceding $ (replaces + Note_Implicit_Run_Time_Call). + +2009-07-20 Robert Dewar + + * vms_data.ads: Minor reformatting + + * einfo.ads, einfo.adb (Parent_Subtype): Now allowed on record subtype, + applies to base type. + (Parent_Subtype): Now allowed on record subtype, applies to base type + * exp_ch5.adb (Expand_Assign_Record): Handle Componentwise_Assignment + for case of fully repped tagged type. + (Make_Tag_Ctrl_Assignment): Set Componentwise_Assignment and avoid + tag save/restore for fully repped tagged type case. + * exp_util.ads, exp_util.adb (Is_Fully_Repped_Tagged_Type): New function + * fe.h (Is_Fully_Repped_Tagged_Type): New function + * sem_ch13.adb (Analyze_Recorrd_Representation_Clause): Check for + overlap of tagged type components with parent type if parent type is + fully repped. + * sinfo.ads, sinfo.adb (Componentwise_Assignment): New flag + + * sem_res.adb (Check_No_Direct_Boolean_Operators): Remove handling of + comparisons. + (Resolve_Comparison_Operators): Remove No_Direct_Boolean_Operators check + (Resolve_Equality_Op): Remove No_Direct_Boolean_Operators check + + * gnat_rm.texi: Restriction No_Direct_Boolean_Operators includes only + logical operators (AND/OR/XOR), not comparison operators. + + * sprint.ads: Minor reformatting + +2009-07-20 Ed Schonberg + + * sem_intr.adb (Check_Intrinsic_Call): For Import_Value and related + intrinsics, check that argument is a string literal, rather than + checking for staticness. + +2009-07-20 Robert Dewar + + * sem_ch13.adb: Minor reformatting + + * einfo.ads: Minor reformatting + Component_Bit_Offset is no longer considered obsolescent + +2009-07-20 Nicolas Roche + + * a-calend.adb: Redefine time_t as signed integer with same size as + Address type. + * s-os_lib.ads: Redefine OS_Time as signed integer with same size as + Address type + * adaint.h: On Windows 64bits declare OS_Time as long long instead of + long + +2009-07-20 Javier Miranda + + * exp_tss.adb (Init_Proc): Add missing support for non-default C++ + constructors that have anonymous access type formals. + + * sem_res.adb (Resolve_Actuals): Disable checks associated with Ada + class-wide arguments in case of imported C++ subprograms. + + * exp_ch3.adb (Build_Initialization_Call): Add assertion. + +2009-07-20 Sergey Rybin + + * vms_data.ads: Update qualifiers. + +2009-07-20 Robert Dewar + + * einfo.ads, switch.adb, gnatls.adb, inline.adb, sem_ch13.adb: Minor + reformatting + +2009-07-17 Richard Guenther + + PR c/40401 + * gcc-interface/utils.c (end_subprog_body): Revert to pre-tuples + state. Remove unused parameter. + (gnat_gimplify_function): Do not gimplify here. + Fold into its only caller and remove. + (gnat_builtin_function): Adjust for end_subprog_body signature change. + (gnat_write_global_declarations): Also finalize the CU. + * gcc-interface/misc.c (gnat_parse_file): Do not finalize the CU here. + * gcc-interface/trans.c (gigi): Revert to pre-tuples state. + (Subprogram_Body_to_gnu): Adjust for end_subprog_body signature + change. + * gcc-interface/gigi.h (end_subprog_body): Remove unused parameter. + +2009-07-15 Arnaud Charlet + + * gcc-interface/Make-lang.in: Update dependencies + + * gcc-interface/Makefile.in: Add target pairs for PPC/Xenomai + +2009-07-15 Robert Dewar + + * par_sco.adb (Traverse_Declarations_Or_Statements): Add processing for + N_Label. Remove SCO table entry for entry point (not used). + + * par_sco.ads: Remove SCO entry point type (not used) + + * switch.adb: Minor code clean up. + +2009-07-15 Eric Botcazou + + * exp_dbug.ads (Base Record Types): Document enhanced encoding. + +2009-07-15 Thomas Quinot + + * gnatls.adb: Minor reformatting + + * gnatcmd.adb: Minor code reorganization + +2009-07-15 Ed Schonberg + + * exp_util.adb (Component_May_Be_Bit_Aligned): Use underlying type to + determine whether a component of a private type has a composite type. + +2009-07-15 Robert Dewar + + * sem_ch10.adb: Minor reformatting throughout + Minor code reorganization (put nested subprograms in alpha order) + +2009-07-15 Ed Schonberg + + * exp_ch6.adb (Expand_Call): Prevent double attachment of the result + when compiling a call to a protected function that returns a controlled + object. + +2009-07-15 Hristian Kirtchev + + * sysdep.c (__gnat_localtime_tzoff): Consolidate the Lynx cases into + one. Add task locking and unlocking around the critical region which + mentions localtime_r and global variable timezone for various targets. + Comment reformatting. + +2009-07-15 Robert Dewar + + * gnat_rm.texi: Document s-ststop.ads + + * impunit.ad: (Map_Array): New table of alternative names + (Get_Kind_Of_Unit): Return possible suggested alternative name + + * impunit.ads (Get_Kind_Of_Unit): Return possible suggested + alternative name. + + * sem_ch10.adb (Analalyze_With_Clause): Add name of possible + alternative unit if an implementation unit is with'ed. + +2009-07-15 Robert Dewar + + * gnat_ugn.texi: Minor updates. + + * snames.ads-tmpl: Minor comment updates for Ada 2005 fully implemented + +2009-07-15 Ed Schonberg + + * sem_warn.adb (Warn_On_Constant_Condition): Handle properly constant + conditions of a derived boolean type. + Minor reformatting + +2009-07-15 Robert Dewar + + * gnat1drv.adb: Initialize SCO tables + + * par-load.adb: Call SCO_Record for main unit spec + + * par.adb: Make call to SCO_Record for main unit + + * par_sco.adb (Unit_Table): Change format to facilitate sort + (Process_Decisions): New procedure with list argument + (Traverse_Generic_Package_Declaration): New procedure + (Initialize): New procedure, replaces Init + (SCO_Output): Sort unit table before output + (SCO_Record): Avoid duplications + (SCO_Record): Handle remaining cases of units + (Traverse_Declarations_Or_Statements): Handle generics + + * par_sco.ads (Initialize): New peocedure (replaces Init) + + * sem_ch10.adb (Analyze_Proper_Body): Make call to SCO_Record for + subunit. + +2009-07-15 Arnaud Charlet + + * debug.adb: Add -gnatd.J switch for now to support scil generation in + parallel. Add missing doc for -gnatd.I and -gnatd.O + +2009-07-15 Robert Dewar + + * lib-load.adb: Minor reformatting + + * lib-writ.adb (Write_ALI): Fix handling of SCO_Output wrt Generate_SCO. + +2009-07-15 Robert Dewar + + * par.adb: Minor reformatting + Add ??? comment for possible bad comment + + * par-ch10.adb: Minor reformatting + +2009-07-15 Ed Schonberg + + * sem_warn.adb (Warn_On_Constant_Condition): if the constant condition + is a literal of a derived boolean type, it appears as an unchecked + conversion. Retrieve actual value from expression of conversion. + +2009-07-15 Robert Dewar + + * sem_ch3.adb: Minor reformatting + + * lib-xref.ads, lib-xref.adb, lib.ads, par_sco.ads, par_sco.adb, + lib-writ.ads, lib-writ.adb: Minor reformatting. + Fix problem with SCO format in ALI files + +2009-07-15 Robert Dewar + + * exp_ch7.adb, exp_util.adb, tbuild.adb, tbuild.ads, exp_ch4.adb, + exp_aggr.adb: Minor code reorganization (better calling sequence for + Make_Temporary). + +2009-07-15 Thomas Quinot + + * opt.ads: Minor comment edits + +2009-07-15 Tristan Gingold + + * gcc-interface/Makefile.in: Special rule for seh_init.o no longer + needed. + +2009-07-15 Robert Dewar + + * lib-writ.adb (Write_Unit_Information): Use SCO_Output to output SCO + information. + + * lib-writ.ads: Document addition of SCO lines to ALI file + + * par_sco.ads, par_sco.adb: New files. + + * opt.ads (Generate_SCO): New switch + + * par.adb (Par): Call SCO_Record to record SCO information + + * sem_warn.adb (Warn_On_Constant_Condition): Adjust SCO condition + + * switch-c.adb: Recognize -gnateS to generate SCO information + + * usage.adb: Add line for -gnateS + + * gcc-interface/Make-lang.in: Add dependency on par_sco.o for gnat1 + +2009-07-15 Robert Dewar + + * sinfo.ads, make.adb, par.ads, par.adb, sem_warn.adb: Minor + reformatting. + +2009-07-15 Thomas Quinot + + * g-socthi-mingw.adb: Minor comment addition + + * g-socthi-mingw.ads (WSAStartup): First argument is a WORD not an int. + +2009-07-15 Robert Dewar + + * g-htable.ads, s-htable.ads: Minor reformatting + +2009-07-15 Robert Dewar + + * switch-c.adb, sem_ch10.adb, sem_warn.adb, sem_warn.ads: Implement + new switch -gnatw.g. + (Set_GNAT_Mode_Warnings): New procedure. + + * lib-xref.adb: Minor reformatting + +2009-07-15 Robert Dewar + + * exp_aggr.adb, tbuild.ads, tbuild.adb: Minor reformatting + Minor code reorganization + +2009-07-14 Taras Glek + Rafael Espindola + + * gcc-interface/Make-lang.in (ada.install-plugin): New target for + installing plugin headers. + +2009-07-13 Ed Schonberg + + * exp_ch7.adb, exp_util.adb, tbuild.adb, tbuild.ads, exp_ch4.adb, + exp_aggr.adb (Make_Temporary): Utility to create a defining identifier + and link it to the expression whose value it captures. + +2009-07-13 Robert Dewar + + * output.adb: Minor comment addition for last change + + * sinfo.ads: Minor reformatting + +2009-07-13 Vasiliy Fofanov + + * adaint.c (__gnat_portable_no_block_spawn): on Windows, return -1 when + spawn failed like on all other targets. + +2009-07-13 Ed Schonberg + + * exp_ch7.adb: Indicate origin of temporary for transient expression. + +2009-07-13 Thomas Quinot + + * s-oscons-tmplt.c: Add comment. + +2009-07-13 Robert Dewar + + * sinfo.adb, sinfo.ads, sem_util.adb, atree.adb, atree.ads: Minor + reformatting. Minor code reorganization (add 9 argument version of + Nkind_In). + + * impunit.adb: Remove s-os_lib from list of system extensions. + + * sem_util.ads: Minor reformatting + + * output.adb: Add warnings off/on around System.OS_Lib. + +2009-07-13 Bob Duff + + * exp_dist.adb: Minor comment updates. + +2009-07-13 Gary Dismukes + + * sem_ch10.adb, sem_ch12.adb, gnat1drv.adb, exp_ch4.adb: Fix casing of + several references to CodePeer. + +2009-07-13 Bob Duff + + * exp_dist.adb (Build_From_Any_Function,Build_To_Any_Function, + Build_TypeCode_Function_All): Do not recurse if the type is the base + type. + +2009-07-13 Robert Dewar + + * exp_ch4.adb: Minor comment change + +2009-07-13 Ed Schonberg + + * sem_ch5.adb (Analyze_Iteration_Scheme): Generate dummy reference for + type of iteration, to prevent spurious warnings. + +2009-07-13 Nicolas Roche + + * s-oscons-tmplt.c: On VxWorks target ensure that vxWorks.h is always + included. + +2009-07-13 Arnaud Charlet + + * switch-c.adb, usage.adb, sem_ch9.adb, gnat_ugn.texi, rtsfind.adb, + gnat1drv.adb, opt.ads, sem_ch13.adb (Inspector_Mode): Renamed to + Generate_SCIL. + (CodePeer_Mode): New -gnatC switch. + (Adjust_Global_Switches): Adjust settings for Generate_SCIL and + CodePeer_Mode. + +2009-07-13 Eric Botcazou + + * checks.adb (Selected_Range_Checks): Do not consider that a non-static + integer bound forces the check if it is compared to its subtype range. + +2009-07-13 Robert Dewar + + * prj.ads, prj-dect.adb, prj-err.ads, prj-err.adb, prj-nmsc.adb, + prj-strt.ads: Minor reformatting + +2009-07-13 Thomas Quinot + + * exp_dist.adb (Build_From_Any_Call): For the case of a generic type, + set the type of the From_Any call to the base type. + +2009-07-13 Doug Rupp + + * symbols-processing-vms-ia64.adb (Process): Add variables and + constants to retrieve and check for symbol visibility. + +2009-07-13 Javier Miranda + + * exp_ch4.adb (Expand_N_Unchecked_Type_Conversion): If conversion is to + the identical type we remove the conversion completely because + it is useless. + +2009-07-13 Emmanuel Briot + + * prj-err.adb (Error_Msg): One more case where a message should be + considered as a warning. + + * gnatcmd.adb (GNATCmd): Fix previous change, which negated a test. + +2009-07-13 Thomas Quinot + + * exp_dist.adb (Expand_All_Calls_Remote_Subprogram_Call): Analyze + calling stubs in the (library level) scope of the RCI locator, where it + is attached, not in the caller's scope. + +2009-07-13 Javier Miranda + + * sem_ch3.adb (Analyze_Object_Declaration): In case of class-wide + interface object declarations we delay the generation of the equivalent + record type declarations until its expansion because there are cases in + which they are not required. + + * sem_util.adb (Implements_Interface): Add missing support for subtypes. + + * sem_disp.adb (Check_Controlling_Formals): Minor code cleanup plus + addition of assertion. + + * exp_util.adb (Expand_Subtype_From_Expr): Renamings of class-wide + interface types require no equivalent constrained type declarations + because the expanded code only references the tag component associated + with the interface. + (Find_Interface_Tag): Improve management of interfaces that are + ancestors of tagged types. + + * exp_ch3.adb (Expand_N_Object_Declaration): Improve the expansion of + class-wide object declarations to add missing support to statically + displace the pointer to the object to reference the tag component + associated with the interface. + + * exp_disp.adb (Make_Tags) Avoid generation of internally generated + auxiliary types associated with user-defined dispatching calls if the + type has no user-defined primitives. + +2009-07-13 Vasiliy Fofanov + + * mingw32.h: Make it explicit that we need XP or later. + + * initialize.c: Remove useless extern symbol declaration. + + * adaint.h: Ditto, also expose __gnat_win32_remove_handle to allow + code reuse in expect.c. + + * adaint.c: Changes throughout the Windows section to redesign storage + of the child process list and the process identification. + + * expect.c (__gnat_kill, __gnat_waitpid): Simplify, cleanup, use pids + for interfacing, fix errors. + (__gnat_expect_portable_execvp): use function in adaint.c + +2009-07-13 Emmanuel Briot + + * prj-proc.adb, prj-part.adb, prj-part.ads, prj-strt.adb, + prj-strt.ads, prj.adb, prj.ads, prj-makr.adb, prj-makr.ads, + prj-dect.adb, prj-dect.ads, prj-nmsc.adb, prj-pars.adb, errutil.adb, + errutil.ads, prj-conf.adb, gnatname.adb, prj-err.adb, prj-err.ads + (Prj.Nmsc.Report_Error): Removed, no longer needed. + Always use Prj.Err.Report_Message. + +2009-07-13 Robert Dewar + + * prj.adb, sem_ch4.adb, sem_res.adb, prj-nmsc.adb: Minor reformatting + & comment edits. + +2009-07-13 Robert Dewar + + * opt.ads, prj-conf.adb, prj-env.adb, prj-ext.adb, prj-nmsc.adb, + prj-proc.adb, prj-tree.adb, prj-tree.ads: Minor reformatting + +2009-07-13 Emmanuel Briot + + * prj.adb, prj.ads, prj-env.adb, prj-conf.adb, prj-tree.adb, + mlib-prj.adb (Private_Part.Ada_Prj_Objects_File_Set, + Ada_Prj_Include_File_Set): Removed, since not needed + Code clean up. + +2009-07-13 Ed Schonberg + + * sem_ch4.adb (Analyze_Set_Membership): New procedure, subsidiary of + Analyze_Membership_Op. + + * sem_res.adb (Resolve_Set_Membership): New procedure, subsidiary of + Resolve_Membership_Op. + + * exp_ch4.adb (Expand_Set_Membership): New procedure, subsidiary of + Expand_N_In. + +2009-07-13 Robert Dewar + + * clean.adb: Minor reformattting + +2009-07-13 Emmanuel Briot + + * gnatcmd.adb, prj-proc.adb, make.adb, mlib-prj.adb, prj-ext.adb, + gnat_ugn.texi, prj.adb, prj.ads, clean.adb, prj-nmsc.adb, prj-util.adb, + prj-conf.adb, gnatname.adb, prj-env.adb, prj-env.ads, prj-tree.adb, + prj-tree.ads (Prj.Tree.Create*): New subprograms to create new packages + and attributes in a project tree. + (Add_Default_GNAT_Naming_Scheme): Provide real implementation. + Remove last remaining mode-specific code (ada_only or + multi_language). This was duplicating code + (Get_Mode, Set_Mode): removed, no longer used. + (Initialize_Project_Path): all tools will now take into account both + GPR_PROJECT_PATH and ADA_PROJECT_PATH (in that order). + Remove some global variables and subprograms no longer used + Make temporary files tree-specific, to avoid interferences between + trees loaded in memory at the same time. + (Prj.Delete_Temporary_File): new subprogram + (Object_Paths, Source_Paths): fields no longer stored in the project + tree, since they are only needed locally in Set_Ada_Paths. + (Set_Mapping_File_Initial_State_To_Empty): removed, since had no + effect in practice. + (Project_Tree_Data.Ada_Path_Buffer): removed, since it can be replaced + by local variables in the appropriate subprograms + (Has_Foreign_Sources): removed. + + * gcc-interface/Makefile.in: prj-pp.o is now needed to build gnatmake + +2009-07-13 Arnaud Charlet + + * gnat1drv.adb (Adjust_Global_Switches): No longer set + Back_Annotate_Rep_Info in inspector mode. + (Gnat1Drv): Need to call the back-end in inspector mode to generate SCIL + + * opt.ads: Update comment. + +2009-07-13 Robert Dewar + + * lib.adb, prj-nmsc.adb, prj-proc.adb, prj-proc.ads, prj.adb, + prj.ads: Minor reformatting and code reorganization. + + * par-ch3.adb (Check_Restricted_Expression): New procedure + +2009-07-13 Ed Schonberg + + * exp_attr.adb (Rewrite_Stream_Proc_Call): When rewriting a stream + attribute into a call of the corresponding suprogram, create extra + formals for the subprogram, because it may be a renaming whose + analysis does not create extra formals. + +2009-07-13 Emmanuel Briot + + * gnatcmd.adb, prj-proc.adb, prj-proc.ads, make.adb, prj-part.adb, + prj.adb, prj.ads, clean.adb, prj-nmsc.adb, prj-nmsc.ads, prj-pars.adb, + prj-pars.ads, prj-conf.adb, prj-conf.ads, prj-env.adb, prj-tree.adb, + prj-tree.ads: Minor reformatting. + (Processing_Flags): new record to encapsulate the set of common + parameters to several subprograms in the project manager. + (Prj.Nmsc.Process_Naming_Scheme): renames Check, and moved to body + Remove the need for the Current_Dir parameter in subprograms. + (Look_For_Sources): minor refactoring, now that we no longer need to + share subprograms between the two Ada_Only and Multi_Language modes + (Processing_Flags): New field Error_On_Unknown_Language. + Merge tests for library project between gnatmake and gprbuild. + +2009-07-13 Arnaud Charlet + + * lib.adb, make.adb, mlib.adb, exp_dist.adb: Update comments. + Minor reformatting. + +2009-07-13 Emmanuel Briot + + * prj-env.adb (Create_Config_Pragmas_File): Iterate on sources rather + than units. + +2009-07-13 Thomas Quinot + + * sem_ch3.adb (Process_Full_View): Propagate Has_Specified_Stream_{Read, + Write,Input,Output} from private view to full view. + + * sem_type.adb, sem_type.ads: Minor reformatting + +2009-07-13 Nicolas Setton + + * exp_dbug.ads: Add documentation note on the utility of + DW_AT_GNAT_encoding for IDEs. + +2009-07-13 Robert Dewar + + * g-socthi-vxworks.adb: Minor reformatting + + * gnatcmd.adb: Minor reformatting + +2009-07-13 Thomas Quinot + + * rtsfind.ads, exp_dist.adb (RE_Allocate_Buffer): Runtime entry + removed, not used anymore. + (Exp_Dist.PolyORB_Support.Helpers.Assign_Opaque_From_Any): + New subprogram, implements copy of an Any value into a limited object. + (Exp_Dist.PolyORB_Support.Build_General_Calling_Stubs, + Exp_Dist.PolyORB_Support.Build_Subprogram_Receiving_Stubs, + Exp_Dist.PolyORB_Support.Helpers.Build_From_Any_Function): For the case + of parameters of a limited type, use the above new subprogram. + +2009-07-13 Emmanuel Briot + + * prj-nmsc.adb, prj-proc.adb, mlib.adb (Add_Source): new parameter + Location. + (Copy_ALI_Files): Avoid calls to read when pointing outside of the + allocated space. + (Error_Report): Remove global variable, replaced by parameters. + +2009-07-13 Thomas Quinot + + * g-socthi-vxworks.adb (C_Sendto): VxWorks does not support the + standard sendto(2) interface for connected sockets (passing a null + destination address). Use send(2) instead for that case. + +2009-07-13 Pascal Obry + + * adaint.c: Fix __gnat_stat() with Win32 UNC paths. + +2009-07-13 Emmanuel Briot + + * prj-proc.adb, prj-proc.ads, prj.ads, prj-nmsc.adb, prj-nmsc.ads, + prj-pars.adb, prj-conf.adb, prj-conf.ads: Remove all remaining global + variables and tables in prj-nmsc.adb. + (Tree_Processing_Data): Renames Processing_Data, some new fields added + (Project_Processing_Data): New record + Simplify/unify check for missing sources. + +2009-07-13 Emmanuel Briot + + * gnatcmd.adb, make.adb, mlib-prj.adb, prj-part.adb, mlib.adb, + prj.adb, prj.ads, clean.adb, prj-nmsc.adb, prj-nmsc.ads, prj-pars.adb, + prj-pars.ads, prj-conf.adb, prj-conf.ads, prj-tree.adb, + prj-tree.ads (Immediate_Directory_Of): Removed. + (Prj.Pars): Now parse the project simulating a default config file. + (Add_Default_GNAT_Naming_Scheme): New subprogram + (Check_Naming_Multi_Lang): Fix default value for Dot_Replacement. + Remove gnatmake-specific parsing of source files. + (Check_Illegal_Suffix): Renames Is_Illegal_Suffix, since it now raises + the error itself to provide more precise diagnostics. + (Process_Exceptions_Unit_Based): Avoid duplicate error message when + a unit belongs to several projects. + (Copy_Interface_Sources): Search the full path of files to copy in the + list of sources of the application rather than in the list of units. + (Parse_Project_And_Apply_Config): Do not reset the name of the main + project file. + (Check_File): Use htables to find out whether a source is duplicated. + (Add_Source): check whether the source or unit were already seen earlier + + * gcc-interface/Makefile.in: Update gnatmake dependencies. + +2009-07-13 Robert Dewar + + * par-ch3.adb (P_Discrete_Choice_List): Choice can only be simple + expression if extensions permitted. + + * par-ch4.adb (P_Membership_Test): New procedure (implement membership + set tests). + (P_Relation): Use P_Membership_Test + + * par.adb (P_Membership_Test): New procedure (implement membership set + tests). + + * sinfo.ads, sinfo.adb (N_In, N_Not_In) Add Alternatives field for sets. + + * sprint.adb (Sprint_Node): Handle set form for membership tests. + +2009-07-13 Thomas Quinot + + * exp_dist.adb (Add_RACW_Primitive_Declarations_And_Bodies): + Do not attempt to generate stubs for predefined primitives of + synchronized interfaces. + (Add_Stub_Type): Factor some code from the PCS-specific variants of + Build_Stub_Type. + +2009-07-13 Ed Schonberg + + * sem_disp.adb (Override_Dispatching_Operation): Functions inherit the + Controlling_Result flag from the operation they override. + +2009-07-13 Arnaud Charlet + + * gcc-interface/Make-lang.in: Update dependencies + +2009-07-13 Robert Dewar + + * gnat_ugn.texi: The gnatf switch no longer is needed to get full + details on unsupported constructs. + + * rtsfind.adb: Remove references to All_Errors_Mode, give errors + unconditionally. + + * s-trafor-default.adb: Correct some warnings + + * s-valwch.adb, a-calend.adb, freeze.adb, prj.ads, s-vmexta.adb, + sem.adb, sem_ch10.adb, sem_ch6.adb, sem_disp.adb, vxaddr2line.adb: + Minor reformatting. + + * par-ch4.adb (Conditional_Expression): Capture proper location for + conditional expression, should point to IF. + + * s-tassta.adb, a-wtdeau.adb, s-tasren.adb, s-arit64.adb, s-imgdec.adb, + s-direio.adb, s-tpobop.adb, g-socket.adb, s-tposen.adb, s-taskin.adb, + g-calend.adb, s-regpat.adb, s-scaval.adb, g-catiio.adb: Minor code + reorganization (use conditional expressions). + +2009-07-13 Ed Schonberg + + * exp_util.adb (Remove_Side_Effects): If the expression is a call to a + build-in-place function that returns an inherently limited type (not + just a task type) create proper object declaration so that extra + build-in-place actuals are properly added to the call. + +2009-07-13 Robert Dewar + + * freeze.adb (Freeze_Entity): Implement Warn_On_Suspicious_Modulus_Value + + * gnat_ugn.texi: Add documentation for -gnatw.m/.M + + * opt.ads (Warn_On_Suspicious_Modulus_Value): New flag + + * sem_warn.adb (Set_Dot_Warning_Flag): Set/reset + Warn_On_Suspicious_Modulus_Value. + + * ug_words: Add entries for -gnatw.m/-gnatw.M. + + * usage.adb: Add lines for -gnatw.m/.M switches. + + * vms_data.ads: Add [NO]SUSPICIOUS_MODULUS for -gnatw.m/w.M + +2009-07-13 Javier Miranda + + * sem_ch6.adb (Check_Synchronized_Overriding): Add missing check before + reading the Is_Interface attribute of the dispatching type. + +2009-07-13 Robert Dewar + + * a-convec.adb: Minor code reorganization (use conditional expressions) + +2009-07-13 Robert Dewar + + * freeze.adb (Check_Suspicious_Modulus): New procedure. + +2009-07-13 Robert Dewar + + * i-cobol.ads: Minor code fix (2**4 instead of 16 as modulus to avoid + warning). + + * par-ch4.adb: Minor reformatting + +2009-07-13 Ed Schonberg + + * freeze.adb, freeze.ads, exp_aggr.adb: Rename Expand_Atomic_Aggregate + => Is_Atomic_Aggregate + +2009-07-13 Emmanuel Briot + + * prj-nmsc.adb: Avoid traversing the list of source files if + we have already processed all locally removed files. + +2009-07-13 Jose Ruiz + + * gnat_ugn.texi: Fix typo. + +2009-07-13 Robert Dewar + + * freeze.adb: Minor reformatting + Minor code reorganization (use Nkind_In) + + * exp_ch6.adb, prj.adb, sem_res.adb: Minor reformatting + +2009-07-11 Eric Botcazou + + * checks.adb (Apply_Address_Clause_Check): Remove Size_Warning_Output + local variable and do not test it in Compile_Time_Bad_Alignment. + Do not issue size or alignment warnings for the X'Address form. + * sem_util.ads (Find_Overlaid_Object): Delete. + (Find_Overlaid_Entity): New procedure. + * sem_util.adb (Find_Overlaid_Object): Rename to... + (Find_Overlaid_Entity): ...this and turn into a procedure. Report + whether the address is offseted within the overlaid entity. + (Has_Compatible_Alignment): Track the offset globally instead of + passing it to Check_Offset. For an indexed component, compute the + full offset when possible. If the resulting offset is zero, only + check the prefix. + (Check_Offset): Delete. + * sem_ch13.adb (Address_Clause_Check_Record): Add Off field. + (Address_Aliased_Entity): Delete. + (Analyze_Attribute_Definition_Clause) : Call + Find_Overlaid_Entity to find the overlaid entity and the offset. + Adjust throughout for above change. + (Validate_Address_Clauses): Always use attributes of entities, not of + their type. Tweak message for warning. Call Has_Compatible_Alignment + if the address is offseted to warn about incompatible alignments. + * gcc-interface/gigi.h (annotate_object): Declare. + * gcc-interface/decl.c (gnat_to_gnu_entity) : Annotate renaming + entity. Call annotate_object instead of annotating manually objects. + (annotate_object): New function. + * gcc-interface/trans.c (Subprogram_Body_to_gnu): Annotate parameters + at the end. + +2009-07-11 Eric Botcazou + + * gcc-interface/ada-tree.h: Minor reorganization. + * gcc-interface/misc.c (gnat_print_decl): Minor tweaks. + (gnat_print_type): Likewise. + +2009-07-11 Thomas Quinot + + * sem_util.adb, sem_res.adb, sem_warn.adb: Minor comment editing: + Lvalue -> lvalue + + * exp_ch6.adb: Minor reformatting + +2009-07-11 Ed Schonberg + + * freeze.adb (Expand_Atomic_Aggregate): Clean up code, take into + account possible type qualification to determine whether aggregate + needs a target temporary to respect atomic type or object. + + * exp_aggr.adb (Expand_Record_Aggregate): Use new version of + Expand_Atomic_Aggregate. + +2009-07-11 Emmanuel Briot + + * prj.adb, prj.ads, prj-nmsc.adb (Mark_Excluded_Sources): Speed up + algorithm. + (Excluded_Sources_Htable): No longer a global table. + Change error message to indicate which files are illegal in the list + of excluded files, as opposed to only the location in the project + file. + (Find_Source): New subprogram. + +2009-07-10 Thomas Quinot + + * exp_ch7.adb: Update comments. + +2009-07-10 Arnaud Charlet + + * exp_ch13.adb (Expand_N_Record_Representation_Clause): Ignore mod + clause if -gnatI is set instead of crashing. + +2009-07-10 Ed Schonberg + + * sem_ch11.adb (Same_Expression): Null is always equal to itself. + Additional work to remove redundant successive raise statements, in + this case access checks. + +2009-07-10 Vincent Celier + + * make.adb (Compile): Always create a deep copy of the mapping file + argument (-gnatem=...) as it may be deallocate/reallocate by + Normalize_Arguments. + +2009-07-10 Javier Miranda + + * einfo.adb (Directly_Designated_Type): Add assertion. + + * sem_res.adb (Check_Fully_Declared_Prefix): Add missing check on + access types before using attribute Directly_Designated_Type. + +2009-07-10 Emmanuel Briot + + * prj.ads: Minor typo fix + +2009-07-10 Ed Schonberg + + * sem_ch6.adb (Add_Extra_Formal): Protected operations do no need + special treatment. + + * exp_ch6.adb (Expand_Protected_Subprogram_Call): If rewritten + subprogram is a function call, resolve properly, to ensure that extra + actuals are added as needed. + +2009-07-10 Thomas Quinot + + * sem_aggr.adb: Minor comments editing + + * exp_tss.adb, exp_ch3.adb: Minor reformatting + +2009-07-10 Robert Dewar + + * exp_util.adb: Minor code reorganization (use N_Short_Circuit) + + * exp_ch4.adb: Add ??? comment for conditional expressions on limited + types. + + * checks.adb (In_Declarative_Region_Of_Subprogram_Body): New procedure, + replaces Safe_To_Capture_In_Parameter_Value, and properly handles the + case of conditional expressions that may not be elaborated. + + * sem_util.adb (Safe_To_Capture_Value): Properly handle case of + conditional expression where we may not execute then then or else + branches. + +2009-07-10 Arnaud Charlet + + * i-cexten.ads (bool): New type. + +2009-07-10 Robert Dewar + + * sinfo.ads (N_Short_Circuit): New definition + + * sem_ch13.adb, sem_ch6.adb, sem_eval.adb, sem_res.adb, + treepr.adb: Minor code reorganization (use N_Short_Circuit) + +2009-07-10 Javier Miranda + + * exp_ch3.adb (Expand_Freeze_Record_Type): Handle constructors of + non-tagged record types. + + * sem_prag.adb + (Process_Import_Or_Interface): Allow the use of "pragma Import (CPP,..)" + with non-tagged types. Required to import C++ classes that have no + virtual primitives. + (Analyze_Pragma): For pragma CPP_Constructor. Allow the use of functions + returning non-tagged types. For backward compatibility, if the + constructor returns a class wide type we internally change the + returned type to the corresponding non class-wide type. + + * sem_aggr.adb + (Valid_Ancestor_Type): CPP_Constructors code cleanup. + (Resolve_Extension_Aggregate): CPP_Constructors code cleanup. + (Resolve_Aggr_Expr): CPP_Constructors code cleanup. + (Resolve_Record_Aggregate): CPP_Constructors code cleanup. + + * sem_ch3.adb + (Analyze_Object_Declaration): CPP_Constructors code cleanup. + + * sem_ch5.adb (Analyze_Assignment): CPP_Constructors code cleanup. + + * sem_util.adb (Is_CPP_Constructor_Call): Code cleanup. + + * sem_res.adb (Resolve_Allocator): CPP_Constructors code cleanup. + + * exp_ch4.adb (Expand_Allocator_Expression): CPP_Constructors code + cleanup. + + * exp_aggr.adb (Build_Record_Aggr_Code): CPP_Constructors code clean up. + + * gnat_rm.texi + (pragma CPP_Class): Document that it can be used now with non-tagged + record types. + (pragma CPP_Constructor): Document that it can be used now with + functions returning specific types. For backward compatibility + we also support functions returning class-wide types. + + * gnat_ugn.texi + (Interfacing with C++ constructors): Update the examples to incorporate + the new syntax in which the functions used to import C++ constructors + return specific types. + (Interfacing with C++ at the Class Level): Update the examples to + incorporate the new syntax in which the functions used to import + C++ constructors return specific types. + +2009-07-10 Thomas Quinot + + * exp_disp.adb (Make_Disp_Asynchronous_Select_Body, + Make_Disp_Conditional_Select_Body, + Make_Disp_Timed_Select_Body): For the case of a type that is neither an + interface nor a concurrent type, the primitive body is empty. Generate + a null statement so that it remains well formed. + +2009-07-10 Ed Schonberg + + * exp_aggr.adb (Build_Record_Aggr_Code): If the type has discriminants, + replace references to them in defaulted component expressions with + references to the values of the discriminants of the target object. + +2009-07-10 Ed Schonberg + + * sem_prag.adb (Analyze pragma, case Task_Name): Analyze argument of + pragma, to capture global references if the context is generic. + + * exp_ch2.adb (Expand_Discriminant): If a task type discriminant + appears within the initialization procedure for the corresponding + record, replace it with the proper discriminal. + +2009-07-10 Vincent Celier + + * make.adb: Do not include object directories or library ALI + directories of library projects in the object path. + +2009-07-10 Javier Miranda + + * exp_util.adb (Find_Interface_Tag): Reorder processing of incoming + Typ argument to ensure proper management of access types. + +2009-07-10 Ed Schonberg + + * exp_ch7.adb (Build_Final_List): If the list is being built for a + Taft-Amendment type, place the finalization list in the package body, + to ensure that the tree for the spec is identical whenever it is + compiled. + +2009-07-10 Javier Miranda + + * sem_ch3.adb (Build_Derived_Record_Type): Use the full-view when + inheriting attributes from a private Parent_Base. + +2009-07-10 Ed Schonberg + + * sem_ch11.adb (analyze_raise_xxx_error): Remove consecutive raise + statements with the same condition. + +2009-07-10 Robert Dewar + + * exp_ch4.adb (Raise_Accessibility_Error): New procedure + +2009-07-09 Tom Tromey + + * raise-gcc.c: Include dwarf2h (unconditionally). + +2009-07-09 Ed Schonberg + + * sem_ch10.adb (Install_Context): If the unit is a package body, + install the private with_clauses of the corresponding package + declaration. + +2009-07-09 Robert Dewar + + * checks.adb: Minor reformatting + +2009-07-09 Vasiliy Fofanov + + * ug_words, gnat_ugn.texi: Move VMS equivalents of the last check in + into ug_words. + +2009-07-09 Thomas Quinot + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause, case Address): + Do not warn for a constant overlaying any constant object + +2009-07-09 Ed Schonberg + + * sem_ch10.adb (Install_Context): If the unit is a package body, + install the private with_clauses of the corresponding package + declaration. + +2009-07-09 Robert Dewar + + * checks.adb: Minor reformatting + +2009-07-09 Vasiliy Fofanov + + * ug_words, gnat_ugn.texi: Move VMS equivalents of the last check in + into ug_words. + +2009-07-09 Thomas Quinot + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause, case Address): + Do not warn for a constant overlaying any constant object + +2009-07-09 Arnaud Charlet + + * gcc-interface/Make-lang.in: Update dependencies + +2009-07-09 Thomas Quinot + + * g-socket.adb (Check_Selector): Do not create local copies of the + socket sets on the stack. + +2009-07-09 Vasiliy Fofanov + + * gnat_ugn.texi: Add missing VMS translations. + +2009-07-09 Ed Schonberg + + * sem_prag.adb (Analyze_Pragma, case Precondition): Do not analyze the + condition, to prevent generation of visible code during expansion, + when Check is not enabled. + +2009-07-09 Gary Dismukes + + * checks.adb (Install_Static_Check): Call Possible_Local_Raise so that + the check gets registered for any available local handler + (Set_Local_Raise). + + * sem_util.adb: Add with and use of Exp_Ch11. + (Apply_Compile_Time_Constraint_Error): Call Possible_Local_Raise so + that the check gets registered for any available local handler. + + * exp_ch4.adb (Expand_N_Slice): Remove call to Enable_Range_Check + on slice ranges. + +2009-07-09 Steve Baird + + * exp_ch11.adb (Force_Static_Allocation_Of_Referenced_Objects): New + function. + (Expand_N_Exception_Declaration): Fix handling of exceptions + declared in a subprogram. + +2009-07-09 Emmanuel Briot + + * prj-nmsc.adb (Find_Sources): Avoid error messages from gprbuild from + multi-unit files. + +2009-07-09 Thomas Quinot + + * freeze.adb: Minor reformatting + + * exp_ch3.adb: Minor comment fix. + + * sinfo.ads: Minor comment fix + +2009-07-09 Ed Schonberg + + * exp_ch4.adb (Expand_N_Conditional_Expression): Set Related_Expression. + +2009-07-09 Ed Schonberg + + * freeze.adb (Freeze_Expression): If the expression is the name of a + function in a call, and the function has not been frozen yet, create + extra formals for it to ensure that the proper actuals are created + when expanding the call. + +2009-07-09 Emmanuel Briot + + * prj-pp.adb (Print): Fix handling of source index when set on a + declaration node. + +2009-07-09 Ed Schonberg + + * einfo.ads, einfo.adb: New attribute Related_Expression, used to link + a temporary to the source expression whose value it captures. + + * exp_util.adb (Remove_Side_Effects): Set Related_Expression as needed. + +2009-07-07 Manuel López-Ibáñez + + * gcc-interface/trans.c (gnat_gimplify_expr): Replace EXPR_LOCUS by + EXPR_LOCATION. + +2009-07-07 Gary Dismukes + + * exp_ch6.adb (Expand_Actuals): Call Add_Call_By_Copy_Code for in out + parameters when the subtype of the actual is not known to be a subrange + of the formal's subtype. + (Expand_Call): Generate a range check only in the E_In_parameter case + (in out parameter range checks are now handled in Expand_Actuals). + + * exp_ch4.adb (Expand_N_Slice): Restore code that calls + Enable_Range_Check. + +2009-07-07 Robert Dewar + + * a-stwise.adb, a-stzsea.adb, a-strsea.adb: Add comments + +2009-07-07 Javier Miranda + + * exp_disp.adb (Expand_Interface_Conversion): Handle access type whose + designated type comes from a limited views. + +2009-07-07 Emmanuel Briot + + * prj.ads, prj-nmsc.adb (Mark_Excluded_Sources): Fix handling of + locally removed files that are later made visible again in an importing + project. + +2009-07-07 Robert Dewar + + * gnat_rm.texi: Clarify documentation of Stream_Convert pragma + +2009-07-07 Sergey Rybin + + * gnat_ugn.texi: Add an example to the description of gnatcheck + 'Style_Checks' rule option. + +2009-07-07 Tristan Gingold + + * seh_init.c: Fix inline assembly statement in seh_init.c + +2009-07-07 Ed Schonberg + + * sem_warn.adb (Check_References): Do not emit warnings on formals of + an entry body. Only the formals of the entry declaration are traced. + +2009-07-07 Robert Dewar + + * s-osprim-mingw.adb: Minor code reorganization + +2009-07-07 Robert Dewar + + * prj-nmsc.adb: Minor reformatting + +2009-07-07 Pascal Obry + + * a-stwise.adb, a-stzsea.adb, a-strsea.adb (Index): properly handle + cases where Pattern is longer than Source. + +2009-07-07 Pascal Obry + + * s-osprim-mingw.adb (Get_Base_Time): Avoid infinite loop. + +2009-07-07 Emmanuel Briot + + * prj-nmsc.adb (Process_Naming): canonicalize file suffixes read in the + project file. + +2009-07-07 Ed Schonberg + + * exp_ch3.adb (Expand_Freeze_Record_Type): Add extra formals to + primitive operations, in case one of them is called in the + initialization procedure for the type. + +2009-07-07 Robert Dewar + + * a-calend.adb: Minor code reorganization (use conditional expressions) + + * s-stusta.ads, s-interr-hwint.adb, g-expect-vms.adb, s-secsta.ads, + prj-nmsc.adb, a-teioed.adb, output.ads, prj-attr.ads, a-textio.adb, + s-taskin.ads, scans.ads, s-osinte-vms.adb, s-taprop-solaris.adb, + s-tpopsp-posix-foreign.adb, s-trafor-default.adb, gnat1drv.adb, + s-stchop-vxworks.adb, s-tpopsp-posix.adb, prj-env.adb, prj-env.ads, + g-comlin.adb, exp_ch11.adb: Minor reformatting. + +2009-07-07 Gary Dismukes + + * checks.adb (Generate_Range_Check): Replace type conversions with + unchecked conversions to support the case of performing range checks + on Enum'Val (permits integer values to be converted to enumeration). + + * exp_attr.adb (Expand_N_Attribute_Reference, cases Attribute_Pred, + Attribute_Succ): Set Do_Range_Check to False before calling + Expand_Pred_Succ, to prevent gigi from generating any range checks. + (Expand_N_Attribute_Reference, case Attribute_Val): + Generate a range check when needed (and set Do_Range_Check to False). + + * exp_ch3.adb (Expand_N_Object_Declaration): Generate a range check on + scalar object initialization if needed. + + * exp_ch4.adb (Expand_Allocator_Expression): Generate range checks + when needed on scalar allocators. + (Expand_N_Qualified_Expression): Generate range check when needed. + (Expand_N_Slice): Remove call to Enable_Range_Check on slice ranges. + Checks on slice ranges handled in Resolve_Slice. + + * exp_ch5.adb (Expand_N_Assignment_Statement): Generate a range check, + when needed, for all scalar assignments, not just discrete. + (Expand_Simple_Function_Return): Resolve the conversion created for a + scalar function return so that the conversion will get expanded to + generate a possible constraint check. + + * exp_ch6.adb (Expand_Actuals): Call Add_Call_By_Copy_Code for out and + in out scalar actuals when subtypes don't match, to ensure generation + of return checks (and set Do_Range_Check to False). + (Expand_Call): Uncomment code to perform range checks, but make it apply + only to in and in out parameters (checks on parameter returns are + handled in Expand_Actuals). If a scalar actual for a call to a derived + subprogram is marked as needing a range check, peform it here (and set + Do_Range_Check to False). + + * sem_aggr.adb (Resolve_*_Aggregate.Resolve_Aggr_Expr): Generate a + range check on scalar component associations when needed. + + * sem_eval.adb (In_Subrange_Of): Return False when the first type has + infinities but the second type does not, as these aren't compatible + floating-point types. + + * sem_res.adb (Resolve_Slice): In the case where the prefix of the + slice is itself a slice, pick up the Etype of the prefix. This handles + the case where the prefix was an Image attribute expanded to a slice, + and ensures that we get the subtype with the slice constraint rather + than the unconstrained subbtype of the 'Image. + +2009-07-07 Ed Schonberg + + * sem_ch4.adb (Analyze_Conditional_Expression): handle properly + overloaded expressions in a conditional expressions. + + * sem_res.adb (Resolve): Handle properly overloaded conditional + expressions. + +2009-07-07 Robert Dewar + + * scng.adb: Minor reformattting + + * par-ch2.adb (Scan_Pragma_Argument_Association): Pragma argument + association allows conditional expression without parens. + + * par-ch4.adb (P_Name): Attribute arguments can be conditional + expressions without enclosing parentheses, and also as parameters, + indexing expressions etc. + (P_Conditional_Expression): New procedure + (P_Expression_If_OK): New procedure + + * par.adb (P_Conditional_Expression): New procedure + (P_Expression_If_OK): New procedure + + * sem_ch4.adb (Analyze_Conditional_Expression): Allow for two argument + form of conditional expression. + + * sem_res.adb (Resolve_Conditional_Expression): Deal with supplying + missing True argument if ELSE argument missing. + + * sinfo.adb (Is_Elsif): New flag + + * sinfo.ads (N_Conditional_Expression): This node is now a syntactic + part of the language, and the documentation is modified accordingly. + (Is_Elsif): New flag + +2009-07-06 Olivier Hainque + + * gcc-interface/trans.c (Handled_Sequence_Of_Statements_to_gnu, + setjmp_longjmp): Attach the exception propagation reraise fallback + to the sequence end label location when we have it. + +2009-07-04 Francois-Xavier Coudert + + PR ada/40608 + * init.c (APPLE): Include . + (__gnat_error_handler, APPLE): Add ATTRIBUTE_UNUSED marker. + +2009-07-04 Eric Botcazou + + * ada-tree.h (SET_TYPE_LANG_SPECIFIC): Rewrite. + (SET_DECL_LANG_SPECIFIC): Likewise. + (TYPE_RM_VALUE): New macro. + (SET_TYPE_RM_VALUE): Likewise. + (TYPE_RM_SIZE): Rewrite in terms of TYPE_RM_VALUE. + (TYPE_RM_MIN_VALUE): Likewise. + (TYPE_RM_MAX_VALUE): Likewise. + (SET_TYPE_RM_SIZE): Rewrite in terms of SET_TYPE_RM_VALUE. + (SET_TYPE_RM_MIN_VALUE): Likewise. + (SET_TYPE_RM_MAX_VALUE): Likewise. + * decl.c (gnat_to_gnu_entity) : Remove kludge. + +2009-07-04 Laurent GUERBY + + PR ada/40631 + * tracebak.c (__gnat_backtrace): Fix old-style definition. + +2009-07-02 Rainer Orth + + * tracebak.c [i386 && sun] (IS_BAD_PTR): Use -1UL in comparison. + +2009-07-01 John David Anglin + + PR ada/40609 + * init.c (__gnat_error_handler, HP-UX): Add ATTRIBUTE_UNUSED marker to + ucontext argument. + +2009-07-01 Eric Botcazou + + * init.c (__gnat_error_handler, Solaris): Add ATTRIBUTE_UNUSED marker. + +2009-06-30 Eric Botcazou + + * gcc-interface/utils2.c (build_binary_op) : Do not use + the type of the left operand if it pads a self-referential type when + the right operand is a constructor. + + * gcc-interface/lang-specs.h: Fix copyright date. + +2009-06-30 Eric Botcazou + + * gcc-interface/decl.c: Include tree-inline.h. + (annotate_value) : Try to inline the call in the expression. + * gcc-interface/utils.c (max_size) : Likewise. + * gcc-interface/utils2.c: Include tree-inline. + (known_alignment) : Likewise. + +2009-06-30 Eric Botcazou + + * raise-gcc.c: Include dwarf2.h conditionally. + +2009-06-29 Tom Tromey + + * raise-gcc.c: Include elf/dwarf2.h. + +2009-06-27 Laurent GUERBY + + * tb-gcc.c (trace_callback): Add casts to silence warning. + +2009-06-27 Eric Botcazou + + * tb-gcc.c: Fix copyright notice. + +2009-06-27 Eric Botcazou + + * init.c (__gnat_set_globals): Add prototype. + * adaint.c (__gnat_binder_supports_auto_init): Likewise. + (__gnat_sals_init_using_constructors): Likewise. + * gcc-interface/utils.c (gnat_pushlevel): Likewise. + (get_block_jmpbuf_decl): Likewise. + (gnat_poplevel): Likewise. + (merge_sizes): Rename local variable. + (copy_type): Likewise. + (build_vms_descriptor32): Likewise. + (build_vms_descriptor): Likewise. + (convert_vms_descriptor64): Likewise. + (convert_vms_descriptor32): Likewise. + (convert_to_fat_pointer): Likewise. + (maybe_unconstrained_array): Likewise. + (def_fn_type): Use promoted type with va_arg. + * gcc-interface/decl.c (gnat_to_gnu_entity): Add declaration. + (substitute_in_type): Rename local variable. + * gcc-interface/Make-lang.in (ada-warn): Use STRICT_WARN. + +2009-06-26 Laurent GUERBY + + * tb-gcc.c (trace_callback): Use char* instead of void*. + * gcc-interface/misc.c (enumerate_modes): Make loop C++ compatible. + * gcc-interface/trans.c (parm_attr): Rename to parm_attr_d. + (Attribute_to_gnu): Adjust for above change. + (Subprogram_Body_to_gnu): Likewise. + * gcc-interface/utils.c (merge_sizes): Rename local variable. + (copy_type): Likewise. + (build_vms_descriptor32): Likewise. + (build_vms_descriptor): Likewise. + (convert_vms_descriptor64): Likewise. + (convert_vms_descriptor32): Likewise. + (convert_to_fat_pointer): Likewise. + (maybe_unconstrained_array): Likewise. + * gcc-interface/decl.c (substitute_in_type): Likewise. + +2009-06-26 Eric Botcazou + + * gcc-interface/decl.c (cannot_be_superflat_p): New predicate. + (gnat_to_gnu_entity) : Use it to build the expression + of the upper bound of the index types. + +2009-06-26 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Factor + out common predicate. Use the maximum to compute the upper bound of + the index type only when it is not wider than sizetype. Perform the + comparison in the index type for the generic expression. Use real + precision to decide whether to generate special types for debugging + information. + +2009-06-26 Matthew Gingell + + * adaint.c: Do not use the dummy version of convert_addresses on LynxOS + +2009-06-26 Vincent Celier + + * prj.ads (No_Language_Config): Value of Dependency_Kind is None by + default. + +2009-06-26 Robert Dewar + + * exp_ch4.adb, gnatcmd.adb, make.adb: Minor reformatting + +2009-06-26 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Pass + correct arguments to create_field_decl. Remove redundant iteration. + Rewrite computation of the maximum size. + : Reorder and simplify handling of special cases. + Rewrite computation of the maximum size. Use consistent naming. + * gcc-interface/trans.c (Attribute_to_gnu) : Swap + comparison order for consistency. Use generic integer node to + build the operator and fold the result. + +2009-06-25 Vincent Celier + + * vms_data.ads: Minor comment change + +2009-06-25 Gary Dismukes + + * exp_ch5.adb (Expand_N_Extended_Return_Statement): Don't build an + assignment statement to targeting a caller-provided object when the + result type is an interface type. + + * exp_ch6.adb (Expand_Call): Remove redundant test of + Is_Limited_Interface (Is_Inherently_Limited is sufficient). + (Is_Build_In_Place_Function): Remove test for Is_Limited_Interface. + + * sem_aggr.adb (Check_Expr_OK_In_Limited_Aggregate): Add type in call + to OK_For_Limited_Init. + + * sem_aux.adb (Is_Inherently_Limited_Type): Revise limited type + condition so that True is returned for all limited interfaces, not + just synchronized ones. Ignore components of an interface type when + checking for limited components (such a component can be a parent + component). + + * sem_ch3.ads (OK_For_Limited_Init_In_05): Add type parameter. + (OK_For_Limited_Init): Add type parameter. + + * sem_ch3.adb (Check_Initialization): Add type in call to + OK_For_Limited_Init. + (OK_For_Limited_Init): Add new type param in call to + OK_For_Limited_Init_In_05. + (OK_For_Limited_Init_In_05): Permit arbitrary expressions of a + nonlimited type when the context type is a limited interface. Add type + on recursive calls. + + * sem_ch4.adb (Analyze_Allocator): Add type in call to + OK_For_Limited_Init. + + * sem_ch6.adb (Check_Limited_Return): Add type in call to + OK_For_Limited_Init. + + * sem_ch12.adb (Analyze_Formal_Object_Declaration): Add type in call to + OK_For_Limited_Init. + (Instantiate_Object): Add type in call to OK_For_Limited_Init. + + * sem_type.adb (Interface_Present_In_Ancestor): In the case of a + class-wide interface, get the base type before applying Etype, in order + to account for class-wide subtypes. + +2009-06-25 Emmanuel Briot + + * gnatcmd.adb, prj-proc.adb, make.adb, prj.adb, prj.ads, prj-nmsc.adb, + prj-util.adb, prj-env.adb, prj-env.ads: Merge handling of naming_data + between gnatmake and gprbuild. + (Naming_Data): Removed, no longer used + (Naming_Table, Project_Tree_Ref.Namings): Removed, since this is only + needed locally in one subprogram, no need to store forever in the + structure. + (Check_Naming_Scheme, Check_Package_Naming): Merged, since they play + a similar role. + (Body_Suffix_Of, Body_Suffix_Id_Of, Register_Default_Naming_Scheme, + Same_Naming_Scheme, Set_Body_Suffix, Set_Spec_Suffix, Spec_Suffix_Of, + Spec_Suffix_Id_Of): removed, no longer used. + +2009-06-25 Javier Miranda + + * sem_res.adb (Resolve_Allocator): Skip test requiring exact match of + types on qualified expression in calls to imported C++ constructors. + + * exp_ch4.adb (Expand_Allocator_Expression): Add missing support for + imported C++ constructors. + +2009-06-25 Sergey Rybin + + * vms_data.ads: Add qualifier for new gnatcheck '-t' option. + +2009-06-25 Vincent Celier + + * s-os_lib.adb (Normalize_Pathname.Get_Directory): If directory + provided, on Windows change all '/' to '\'. + + * fmap.ads, fmap.adb (Remove_Forbidden_File_Name): Remove, no longer + used. Minor comment changes + + * prj-nmsc.adb: Do not call Fmap.Add_Forbidden_File_Name or + Remove_Forbidden_File_Name. + +2009-06-25 Quentin Ochem + + * prj.ads (Unit_Index): Now general access type. + +2009-06-25 Pascal Obry + + * a-stwise.adb, a-stzsea.adb: Fix confusion between 'Length and 'Last. + +2009-06-25 Emmanuel Briot + + * fmap.ads, make.adb, prj.adb, prj.ads, prj-nmsc.adb, prj-env.adb, + prj-env.ads (Source_Data.Get_Object): Field removed, since it can be + computed efficiently from the other fields. + (Object_To_Global_Archive): New subprogram + (Create_Mapping): Remove unneeded call to Remove_Forbidden_File_Name. + (Override_Kind): Fix handling of separates in Ada. + (Create_Mapping_File): Remove duplicate code + (Naming_Data.Implementation_Exception, Specification_Exception): + field removed, since never used. + (Naming_Data.Specs, .Bodies): field removed, since this is only + used while processing the project and is not needed once the tree + is in memory. This brings Naming_Data and Lang_Naming_Data + closer (same content now, but different use still). + +2009-06-25 Pascal Obry + + * sem_ch4.adb: Minor reformatting. + + * a-strsea.adb: Fix confusion between 'Length and 'Last. + +2009-06-25 Ed Schonberg + + * exp_attr.adb (Expand_N_Attribute_Reference, case 'Access and + Unchecked_Access): If the context is an interface type, and the prefix + is of the corresponding class-wide type, do not insert a conversion + because the pointer displacement has already taken place, and we must + retain the class-wide type in a dispatching context. + +2009-06-25 Emmanuel Briot + + * prj-nmsc.adb, prj-env.adb (Override_Kind): Unset the unit field of + the previous source file. + (Create_Mapping): Iterate on sources rather than on units. + +2009-06-25 Emmanuel Briot + + * gnatcmd.adb, make.adb, mlib-prj.adb, prj.adb, prj.ads, prj-nmsc.adb, + prj-env.adb, prj-env.ads (Slash): removed, no longer used + (Source_Data): no longer use Path.Name to point to a locally removed + file. Instead we use the field Locally_Removed which is clearer + +2009-06-25 Arnaud Charlet + + * gcc-interface/Make-lang.in: Remove references to sem_maps.o + + * sem_maps.adb, sem_maps.ads: Removed, not used. + +2009-06-25 Ed Falis + + * s-vxwext-rtp.ads: Add missing declaration + +2009-06-25 Matthew Gingell + + * a-stwise.adb, a-stzsea.adb (Count, Index): Avoid local copy on stack, + speed up unmapped case. + +2009-06-25 Vincent Celier + + * prj-nmsc.adb (Check): Change error message for illegal abstract + projects. + +2009-06-25 Robert Dewar + + * gnat_ugn.texi: Add note on use of -gnatct for ASIS + +2009-06-25 Emmanuel Briot + + * fmap.ads: Add documentation on mapping files + +2009-06-25 Robert Dewar + + * exp_ch6.adb, g-socket.ads, g-socket.adb, sem_ch3.adb: Minor + reformatting + +2009-06-24 Robert Dewar + + * prj-nmsc.adb, prj-nmsc.ads, prj-proc.adb, prj.adb: Minor reformatting + + * a-strsea.adb (Count): Avoid local copy on stack, speed up unmapped + case. + (Index): Ditto. + +2009-06-24 Ed Schonberg + + * sem_ch4.adb (Analyze_One_Call): Check that at least one actual is + present when checking whether a call may be interpreted as an indexing + of the result of a call. + + * exp_ch9.adb (Expand_N_Subprogram_Declaration): Place the generated + body for a null procedure on the freeze actions for the procedure, so + that it will be analyzed at the proper place without premature freezing + of actuals. + + * sem_ch3.adb (Check_Completion): Code cleanup. + Do not diagnose a null procedure without a body, if previous errors + have disabled expansion. + +2009-06-24 Doug Rupp + + * init.c [VMS] Resignal C$_SIGKILL + +2009-06-24 Ed Falis + + * s-vxwext.adb, s-vxwext-kernel.adb: Add s-vxwext body for VxWorks 5 + Define ERROR in body for VxWorks 6 kernel + +2009-06-24 Pascal Obry + + * g-socket.adb, g-socket.ads: Fix possible unexpected constraint error + in [Send/Receive]_Socket. + +2009-06-24 Emmanuel Briot + + * prj-proc.adb, prj-proc.ads, prj.ads, prj-nmsc.adb, prj-nmsc.ads, + prj-conf.adb, prj-conf.ads (Allow_Duplicate_Basenames): New parameter + to several subprograms. + (Source_Data.Other_Part): Removed, since can be computed from the + language. + (Other_Part): New subprogram. + +2009-06-24 Emmanuel Briot + + * gnat_ugn.texi, prj-nmsc.adb (Suffix_Matches): A suffix can also match + the full base name of the file when the suffix doesn't start with a '.'. + +2009-06-24 Vincent Celier + + * prj-nmsc.adb (Check): A project declared abstract is legal if no + attribute Source_Dirs, Source_Files, Source_List_File or Languages is + declared. + +2009-06-24 Robert Dewar + + * clean.adb, gnatcmd.adb, make.adb, mlib-prj.adb, + prj-env.adb: Minor reformatting + +2009-06-24 Ed Falis + + * s-taprop-vxworks.adb, s-osinte-vxworks.ads, s-vxwext.ads, + s-vxwext-kernel.adb, s-vxwext-kernel.ads, s-vxwext-rtp.adb, + s-tasinf-vxworks.ads, gcc-interface/Makefile.in: Add processor affinity + support for VxWorks SMP. + + * gcc-interface/Make-lang.in: Update dependencies + +2009-06-24 Emmanuel Briot + + * gnatcmd.adb, make.adb, mlib-prj.adb, prj.adb, prj.ads, clean.adb, + prj-nmsc.adb, prj-env.adb, prj-proc.adb (Units_Table): Removed, since + no longer useful. + (Source_Data.Lang_Kind): Removed, since it duplicates information + already available through Language.Config. + (Source_Data.Compile): Removed, since information is already available + through the language. + (Is_Compilable): New subprogram. + (Source_Data.Dependency): Removed, since already available through + the language. + (Source_Data.Object_Exist, Object_Linked): Removed since available + through the language already. + (Unit_Data.File_Names): Is now also set in multi_language mode, to + bring the two modes closer in the resulting data structures. + (Source_Data.Unit): Now a direct pointer to the unit data, rather than + just the name that would point into a hash table. + (Get_Language_From_Name): New subprogram. + +2009-06-24 Javier Miranda + + * exp_ch4.adb (Expand_N_Type_Conversion): Handle entities that are + visible through limited-with context clauses. In addition, avoid an + extra tag check that is not required when the class-wide + designated types of the operand and target types are + the same entity. + (Tagged_Membership): Handle entities from the limited view. + +2009-06-24 Emmanuel Briot + + * gnatcmd.adb, make.adb, mlib-prj.adb, prj.ads, clean.adb, + prj-nmsc.adb, prj-env.adb (File_Name_Data): removed + (Spec_Or_Body): now a subtype of Source_Kind, to avoid using two + different vocabularies for similar concepts (Impl/Body_Part and + Spec/Specification). + (Unit_Data): now points directly to a Source_Id, rather than duplicating + some of the information in File_Name_Data. This also saves a bit of + memory. However, since we are now using a pointer we need to test + for null explicitly in several places of the code + +2009-06-24 Javier Miranda + + * exp_ch4.adb (Expand_N_Type_Conversion): return immediately + from processing the type conversion when the node is + replaced by an N_Raise_Program_Error node. + +2009-06-24 Hristian Kirtchev + + * sem_ch6.adb (Designates_From_With_Type): New routine. + (Process_Formals): Since anonymous access types are no longer flagged + as from with types, traverse the designated type to determine whether + it is coming from a limited view. + + * sem_res.adb: Remove with and use clauses for Sem_Ch10. + (Full_Designated_Type): Use Available_View to extract the non-limited / + full view of a type. + +2009-06-24 Robert Dewar + + * exp_ch6.adb: Minor reformatting + + * layout.adb: Minor reformatting + + * make.adb: Minor reformatting + +2009-06-24 Thomas Quinot + + * sem_ch10.adb: Minor code reorganization. + +2009-06-24 Eric Botcazou + + * ttypes.ads: Minor editing. + +2009-06-24 Robert Dewar + + * exp_ch6.adb (Expand_Actuals): Use Is_Volatile, not Treat_As_Volatile + in deciding to do call-by-copy code. + +2009-06-24 Vincent Celier + + * make.adb (Gnatmake): To decide if an executable should be rebuilt, + check if an externally built library file is more current than the + executable. + +2009-06-23 Olivier Hainque + + * gcc-interface/utils.c (handle_vector_size_attribute): Import from + c-common.c and populate in gnat_internal_attribute_table. + +2009-06-23 Ed Schonberg + + * sem_res.adb (Valid_Conversion, Full_Designated_Type): Use + Available_View only when designated type of an anonymous access type + is limited view. + +2009-06-23 Robert Dewar + + * sem_ch10.adb: Minor reformatting + + * ali.ads: Mino reformatting. + + * gnat1drv.adb (Adjust_Global_Switches): New procedure (take care of + turning off inlining if ASIS mode active). + + * switch-c.adb: Remove fiddling with Inspector_Mode and ASIS_Mode + This belongs in gnat1drv.adb after switches are scanned. + +2009-06-23 Hristian Kirtchev + + * sem_attr.adb: Add with and use clauses for Sem_Ch10. + (Check_Not_Incomplete_Type): Minor reformatting. Retrieve the root type + when dealing with class-wide types. Detect a legal shadow entity and + retrieve its non-limited view. + + * sem_ch10.adb (Has_With_Clause): Move the spec and body of the + subprogram to top package level from Intall_Limited_Withed_Unit. + (Install_Limited_Withed_Unit): Remove spec and body of Has_With_Clause. + Add check which prevents the installation of a limited view if the + non-limited view is already visible through a with clause. + (Is_Legal_Shadow_Entity_In_Body): New routine. Detect a residual, but + legal shadow entity which may occur in subprogram formals of anonymous + access type. + + * sem_ch10.ads (Is_Legal_Shadow_Entity_In_Body): New routine. + + * sem_ch3.adb (Access_Definition): Remove the propagation of flag + From_With_Type from the designated type to the generated anonymous + access type. Remove associated comment. + + * sem_res.adb Add with and use clauses for Sem_Ch10. + (Full_Designated_Type): Detect a legal shadow entity and retrieve its + non-limited view. Since the shadow entity may replace a regular + incomplete type, return the available full view. + +2009-06-23 Ed Schonberg + + * sem_ch10.adb (Remove_Limited_With_Clause): Clean up code that handles + incomplete type declarations. Previous code was potentially quadratic + in the number of visible declarations in any package appearing in a + limited_with_clause. + +2009-06-23 Robert Dewar + + * prj-conf.ads, prj-part.adb, prj-proc.adb, prj-proc.ads, sem_ch8.adb, + xref_lib.adb: Minor reformatting + +2009-06-23 Robert Dewar + + * a-stzhas.adb: Provide dummy body to avoid build problems with old + versions which did have a body for this unit. + +2009-06-23 Vincent Celier + + * prj-attr.adb: Attribute names Initial_Required_Switches and + Final_Required_Switches changed to Leading_Required_Switches and + Trailing_Required_Switches. + + * prj-nmsc.adb (Process_Compiler): Attribute names + Initial_Required_Switches and Final_Required_Switches changed to + Leading_Required_Switches and Trailing_Required_Switches. + + * prj.ads (Language_Config): Component Initial_Required_Switches and + Final_Required_Switches changed to Leading_Required_Switches and + Trailing_Required_Switches. + + * snames.ads-tmpl: Remove standard names Initial_Required_Switches and + Final_Required_Switches; add standard names Leading_Required_Switches + and Trailing_Required_Switches. + +2009-06-23 Thomas Quinot + + * prj-conf.adb: Minor reformatting + + * xref_lib.adb: Minor cleanup + +2009-06-23 Emmanuel Briot + + * prj-proc.adb, prj-proc.ads, prj-nmsc.adb, prj-nmsc.ads, prj-conf.adb, + prj-conf.ads (Check_Configuration): New parameter + Compiler_Driver_Mandatory. + +2009-06-23 Ed Schonberg + + * sem_ch10.adb (Analyze_With_Clause): If a subprogram instance in the + context of the current unit has an inline pragma, the instance is not + rewritten as the declaration of the package wrapper. Handle both + possibilities when retrieving the visible subprogram that renames the + instantiation itself. + +2009-06-23 Javier Miranda + + * exp_ch4.adb (Displace_Allocator_Pointer, Expand_N_Allocator): Handle + designated types referencing entities from the limited view. + +2009-06-23 Robert Dewar + + * s-strhas.adb, s-strhas.ads: Restrict to 32-bit modular types + + * s-imgdec.adb (Set_Decimal_Digits): Fix error of too many digits for + small values + + * prj-conf.ads: Minor reformatting + + * prj-conf.adb: Minor reformatting + +2009-06-23 Vasiliy Fofanov + + * g-debpoo.adb (Dump_Gnatmem): Output dummy timestamps for allocations + to correspond to the log format that gnatmem now expects. + +2009-06-23 Vincent Celier + + * prj-attr.adb: New attributes Initial_Required_Switches, + Final_Required_Switches and Object_File_Switches + + * prj-nmsc.adb (Process_Compiler): Process new attributes + Name_Final_Required_Switches, Name_Initial_Required_Switches and + Name_Object_File_Switches. + + * prj.ads (Language_Config): New component + Compiler_Initial_Required_Switches (replace Compiler_Required_Switches), + Compiler_Final_Required_Switches and Object_File_Switches. + + * snames.ads-tmpl: New standard names Initial_Required_Switches, + Final_Required_Switches and Object_File_Switches + +2009-06-23 Pascal Obry + + * s-strhas.adb, s-strhas.ads: Minor reformatting. + +2009-06-23 Ed Schonberg + + * sem_ch10.adb (Install_Limited_Withed_Unit): a null procedure does + not indicate that the enclosing unit needs a body. + +2009-06-23 Emmanuel Briot + + * prj-conf.ads, prj-conf.adb: New files part of the project manager. + +2009-06-23 Ed Schonberg + + * sem_ch3.adb (Derive_Subprogram): If the inherited subprogram is a + primitive equality include it with its source name even if the + operation is currently invisible, to make sure that the corresponding + slot in the dispatch table is reserved for the internal equality + subsequently generated during expansion. + +2009-06-23 Matthew Gingell + + * Makefile.rtl, a-stwiha.adb: Add a-stwiha.adb back. + +2009-06-22 Jose Ruiz + + * sysdep.c (__gnat_localtime_tzoff for RTX): + SystemTimeToTzSpecificLocalTime is not supported by RTX. Use + GetTimeZoneInformation instead. + +2009-06-22 Robert Dewar + + * sem_res.adb (Check_No_Direct_Boolean_Operators): New procedure + +2009-06-22 Ed Schonberg + + * sem_ch12.adb (Collect_Previous_Instances): Do not collect + instantiations declared in a previous generic package body. + +2009-06-22 Robert Dewar + + * gnat_rm.texi: Add doc that X=True and X=False is allowed for the + restriction No_Direct_Boolean_Operators. + +2009-06-22 Thomas Quinot + + * bindusg.adb: Minor fixes to gnatbind usage message + + * sem_eval.adb: Minor reformatting + +2009-06-22 Javier Miranda + + * sem_ch3.adb (Analyze_Object_Declaration, Freeze_Entity): Move to the + freezing point the check on the use of abstract types in object + declarations. Done to allow the declaration of C++ imported variables + or constants whose type corresponds with an imported C++ classes for + which the constructor is not imported. + +2009-06-22 Thomas Quinot + + * sem_ch6.adb: Minor reformatting + +2009-06-22 Ed Schonberg + + * exp_ch3.adb (Build_Initialization_Call): If a discriminated record + component is constrained with an expression rather than with a + discriminant of the enclosing type, use that expression when building + the call to default-initialize the component, when the call is part of + an aggregate with box initialization. + +2009-06-22 Ed Schonberg + + * sem_ch6.adb (Check_Overriding_Indicator): Clean up code, make warning + unconditional rather than a style check, because a formal name out of + order is suspicious. + +2009-06-22 Vincent Celier + + * prj-nmsc.adb (Locate_Directory): Indicate the project name when + creating a directory automatically. + +2009-06-22 Eric Botcazou + + * sem_ch3.adb (Create_Constrained_Components): For a subtype of an + untagged derived type, add a hidden component for every constrained + discriminant of the parent type to keep record layout consistent. + +2009-06-22 Thomas Quinot + + * exp_ch3.adb: Minor code reorganization (avoid an unnecessary tree + copy). + +2009-06-22 Matthew Gingell + + * a-stzhas.adb, a-stwiha.adb, impunit.adb, a-swbwha.adb, a-shcain.adb, + s-htable.adb, a-szuzha.adb, a-stunha.adb, a-stboha.adb, a-strhas.adb, + g-spitbo.adb, s-strhas.adb, a-szbzha.adb, s-strhas.ads, Makefile.rtl, + a-swuwha.adb: New unit System.String_Hash. + Refactor redundant cut and pasted hash functions with instances of a + new generic hash function. + Implement a new string hashing algorithm which appears in testing to + be move effective than to previous approach. + +2009-06-22 Ed Falis + + * sysdep.c: remove include for nfsLib.h and an NFS specific error + message for VxWorks 653 vThreads: not supported by the OS. + + * gsocket.h: disable sockets for VxWorks 653 vThreads. + +2009-06-22 Robert Dewar + + * sem_ch6.adb: Add ??? comment for bad use of Style_Check + +2009-06-22 Robert Dewar + + * sinput.adb, sinput.ads (Expr_First_Char, Expr_Last_Char): Replaced + by Sloc_Range. + + * freeze.adb: Minor comment updates + + * s-valrea.adb (Bad_Based_Value): New procedure + (Scan_Real): Raise exceptions with messages + +2009-06-22 Matthew Gingell + + * adaint.h: Complete previous change. + +2009-06-22 Thomas Quinot + + * exp_ch7.ads, exp_ch3.adb: Minor reformatting + +2009-06-22 Ed Schonberg + + * sem_ch6.adb (Check_Overriding_Indicator): When style checks are + enabled, emit warning when a non-controlling argument of the overriding + operation appears out of place vis-a-vis of the formal of the + overridden operation. + +2009-06-22 Vincent Celier + + * gnatcmd.adb (Check_Files): Close temporary files after all file names + have been written into it. + +2009-06-22 Matthew Gingell + + * adaint.c, adaint.h, cstreams.c: Call stat64 on platforms where it is + available. + +2009-06-22 Thomas Quinot + + * sem_disp.adb (Check_Direct_Call): Handle the case where the full + view of the root type is visible at the point of the call. + +2009-06-22 Pat Rogers + + * gnat_ugn.texi: Revised a sentence to correct a minor grammar error. + +2009-06-22 Jerome Lambourg + + * freeze.adb: Add comments. + +2009-06-21 Thomas Quinot + + * exp_ch3.adb, exp_prag.adb, exp_util.adb, exp_util.ads, freeze.adb, + sem_ch13.adb, sem_elab.adb (Exp_Prag.Expand_Pragma_Import_Or_Interface): + Factor out code to new subprogram... + (Exp_Util.Find_Init_Call): New shared routine to find the init proc call + for a default initialized variable. + (Freeze.Check_Address_Clause): Do not reset Has_Delayed_Freeze on an + entity that has an associated freeze node. + (Sem_Ch13.Analyze_Attribute_Definition_Clause, case Address): + If there is an init call for the object, defer it to the object freeze + point. + (Check_Elab_Call.Find_Init_Call): Rename to Check_Init_Call, to avoid + name clash with new subprogram introduced in Exp_Util. + +2009-06-21 Robert Dewar + + * einfo.ads: Minor reformatting + +2009-06-21 Ed Falis + + * env.c (__gnat_environ): return NULL for vThreads - unimplemented + +2009-06-21 Eric Botcazou + + * einfo.ads: Update comments. + +2009-06-21 Hristian Kirtchev + + * sem_disp.adb (Check_Direct_Call): New routine. Dispatching calls + where the controlling formal is of private class-wide type whose + completion is a synchronized type can be converted into direct calls. + +2009-06-21 Vincent Celier + + * gnatcmd.adb (Check_Files): When all sources of the project are to be + indicated to gnatcheck, gnatpp or gnatmetric, always specify the list + of sources using -files=, so that the distinction can be made by the + tool of a call with no source (to display the usage) from a call with + a project file that contains no source. + +2009-06-21 Jerome Lambourg + + * exp_ch3.adb (Build_Array_Init_Proc): Do not build the init proc in + case of VM convention arrays. + +2009-06-20 Robert Dewar + + * a-nudira.adb: Minor reformatting + +2009-06-20 Ed Schonberg + + * exp_ch3.adb (Build_Record_Init_Proc): When copying initial + expressions (possibly from a parent type) indicate that the scope of + the new itypes is the initialization procedure being built. + +2009-06-20 Robert Dewar + + * a-nudira.adb (Fits_In_32_Bits): New name (inverted sense) for + Needs_64, and now computed without anomolies for some dynamic types. + +2009-06-20 Thomas Quinot + + * sem_prag.adb: Minor reformatting + + * exp_disp.ads: Minor reformatting + +2009-06-20 Ed Schonberg + + * sem_ch3.adb (Is_OK_For_Limited_Init): An unchecked conversion of a + function call is a legal expression to initialize a limited object. + + * exp_ch3.adb: Rename various freeze operations that perform expansion + actions, to prevent confusion with subprograms in the freeze package. + +2009-06-20 Ed Schonberg + + * sem.adb (Walk_Library_Units): Check instantiations first. + + * sem_ch6.adb (Analyze_Subprogram_Declaration): Mark a subprogram as a + private primitive if it is a function with a controlling result that is + a type extension with progenitors. + + * exp_ch9.adb (Build_Wrapper_Spec, Build_Wrapper_Body): Handle properly + a primitive operation of a synchronized tagged type that has a + controlling result. + +2009-06-20 Thomas Quinot + + * einfo.ads: Fix typo. + +2009-06-20 Ed Falis + + * s-vxwext.ads, s-vxwext-kernel.adb: Complete previous change. + +2009-06-19 Eric Botcazou + + * gcc-interface/trans.c (emit_check): Do not wrap up the result + in a SAVE_EXPR. + (protect_multiple_eval): Always protect complex expressions. + +2009-06-19 Emmanuel Briot + + * prj-ext.adb, makeutl.adb, makeutl.ads (Executable_Prefix_Path): Now + make sure we always return a name ending with a path separator. + +2009-06-19 Javier Miranda + + * sem_ch12.adb (Instantiate_Package_Body, Instantiate_Subprogram_Body): + Save and restore the visibility of the parent when installed. + +2009-06-19 Jose Ruiz + + * s-tposen.ads (Protection_Entry): Replace fields L, Ceiling, and Owner + by Common which contains all these fields. + + * s-tposen.adb (Initialize_Protection_Entry, Lock_Entry, + Lock_Read_Only_Entry, Timed_Protected_Single_Entry_Call, Unlock_Entry): + Remove code duplication in this package by means of calling the + equivalent code in s-taprob. + +2009-06-19 Robert Dewar + + * a-einuoc.ads: Minor reformatting + +2009-06-19 Ed Falis + + * a-einuoc.ads, s-osinte-vxworks.ads, s-vxwext.ads, s-vxwext-kernel.adb, + s-vxwext-kernel.ads, s-vxwext-rtp.ads: Code clean up. + +2009-06-19 Eric Botcazou + + * einfo.ads (Handling of Type'Size Values): Fix Object_Size values. + +2009-06-19 Robert Dewar + + * a-nudira.adb (Need_64): Handle negative ranges and also dynamic + ranges + + * checks.adb (Determine_Range): Move the test for generic types later. + + * sem_eval.adb (Compile_Time_Compare): Improve circuitry to catch more + cases. + (Eval_Relational_Op): Fold more cases including string compares + + * sem_util.ads, sem_util.adb (References_Generic_Formal_Type): New + function. + +2009-06-19 Robert Dewar + + * sem_type.ads, sem_ch12.adb: Minor reformatting + + * s-wchcnv.adb (UTF_32_To_Char_Sequence): Handle invalid data properly + +2009-06-19 Ed Schonberg + + * exp_ch9.adb (Build_Wrapper_Spec): Handle properly an overridden + primitive operation of a rivate extension whose controlling argument + is an out parameter. + + * sem.adb (Walk_Library_Units): exclude generic package declarations + from check. + +2009-06-19 Thomas Quinot + + * i-vxwoio.ads: Add comments + +2009-06-19 Thomas Quinot + + * socket.c, g-socthi-vms.adb, g-socthi-vms.ads, g-socthi-vxworks.adb, + g-socthi-vxworks.ads, g-socthi-mingw.adb, g-socthi-mingw.ads, + g-socthi.adb, g-socthi.ads, g-socket.adb, g-sothco.ads + (GNAT.Sockets.Thin.C_Ioctl): Rename to Socket_Ioctl. + (GNAT.Sockets.Thin.Socket_Ioctl): Use new function + Thin_Common.Socket_Ioctl. + (GNAT.Sockets.Thin_Common.Socket_Ioctl): Binding to new C wrapper + __gnat_socket_ioctl. + (__gnat_socket_ioctl): Wrapper for ioctl(2) called with a single int* + argument after the file descriptor and request code. + +2009-06-19 Robert Dewar + + * checks.adb: Minor reformatting + +2009-06-19 Jose Ruiz + + * env.c (__gnat_environ): RTX does not support this functionality. + +2009-06-19 Ed Schonberg + + * sem.adb (Walk_Library_Items): Include bodies in the list of units to + traverse, to account for front-end inlining and instantiations in a + spec or in the main unit. + +2009-06-19 Robert Dewar + + * checks.adb (Determine_Range): Do not attempt to get range of generic + type. + +2009-06-19 Sergey Rybin + + * gnat_ugn.texi, vms_data.ads: Add the documentation for the new + gnatmetric option for generating the schema file for gnatmetric XML + output. Add corresponding VMS qualifier. + +2009-06-19 Robert Dewar + + * g-cgi.adb: Minor reformatting + +2009-06-19 Eric Botcazou + + * s-intman-solaris.adb (Notify_Exception): Do not discriminate on the + signal code for SIGFPE and raise Program_Error for SIGILL. + + * s-osinte-solaris.ads: Remove signal code constants for SIGFPE. + +2009-06-19 Ed Schonberg + + * sem_ch8.adb (Nvis_Messages): Do not list an entity declared in a + generic package if there is a visibility candidate that is declared in + a regular package. + +2009-06-18 Olivier Hainque + + * system-aix64.ads: New file. + * gcc-interface/Makefile.in (aix LIBGNAT_TARGET_PAIRS): Use the + 64bit system.ads for ppc64 multilib variants. + +2009-06-16 Robert Dewar + Olivier Hainque + + Relax constraints on Machine_Attribute argument types: + * sem_prag.adb (Check_Arg_Is_Static_Expression): Allow for + missing type. + (Analyze_Attribute, case Machine_Attribute): Allow any type for arg 3. + * gcc-interface/decl.c (prepend_attributes): Accept static + expressions of any type as attribute arguments, not only string + literals. + * gnat_rm.texi (pragma Machine_Attribute section): Adjust to reflect + the relaxation of the restriction on the Info argument type. + +2009-06-13 Aldy Hernandez + + * gcc-interface/utils.c (record_builtin_type): Pass location + argument to build_decl. + (create_type_stub_decl): Same. + (create_type_decl): Same. + (create_var_decl_1): Same. + (create_field_decl): Same. + (create_param_decl): Same. + (create_label_decl): Same. + (create_subprog_decl): Same. + * gcc-interface/decl.c (gnat_to_gnu_entity): Same. + * gcc-interface/trans.c (Case_Statement_to_gnu): Pass location + argument to create_artificial_label. + (Loop_Statement_to_gnu): Same. + (Subprogram_Body_to_gnu): Same. + (gnat_gimplify_stmt): Same. + +2009-06-11 Richard Henderson + + * gcc-interface/misc.c (gnat_handle_option): Rename OPT_gdwarf_ to + OPT_gdwarfplus. + +2009-06-11 Ed Schonberg + + * sem_attr.adb (Resolve_Attribute, case 'access): Add missing + accessibiliy check on access_to_subprogram in the context of an + anonymous access that is not an access parameter. + +2009-06-11 Eric Botcazou + + * tracebak.c (i386 section): Define IS_BAD_PTR on Solaris. + +2009-06-11 Quentin Ochem + + * sem_warn.adb, scng.adb, sfn_scan.adb, freeze.adb: Add CODEFIX + comments for message handled by GPS. + +2009-06-11 Matthew Gingell + + * adaint.c: Use fopen64 instead of fopen on platforms where we know + it's supported. + +2009-06-11 Pascal Obry + + * g-cgi.ads: Fix comment typo. + + * g-cgi.adb: Properly decode "+" in CGI parameters as spaces. + +2009-06-10 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Use + a reference to the original type for the type of the field of the + XVS type. + (maybe_pad_type): Likewise. + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Factor + common predicate and remove redundant setting of TYPE_BY_REFERENCE_P. + Pass correctly typed arguments to create_field_decl. + : Set BLKmode for tagged and limited types in the + case of contrained discriminants as well. Use the padded base type + in the other case as well. Rename temporary variable. Tweak test. + Factor common access pattern. Set GNU_SIZE only once. + +2009-06-09 Olivier Hainque + + * gcc-interface/utils2.c (build_call_alloc_dealloc_proc): New + helper for build_call_alloc_dealloc with arguments to be interpreted + identically. Process the case where a GNAT_PROC to call is provided. + (maybe_wrap_malloc): New helper for build_call_alloc_dealloc, to build + and return an allocator for DATA_SIZE bytes aimed at containing a + DATA_TYPE object, using the default __gnat_malloc allocator. Honor + DATA_TYPE alignments greater than what the latter offers. + (maybe_wrap_free): New helper for build_call_alloc_dealloc, to + release a DATA_TYPE object designated by DATA_PTR using the + __gnat_free entry point. + (build_call_alloc_dealloc): Expect object data type instead of naked + alignment constraint. Use the new helpers. + (build_allocator): Remove special processing for the super-aligned + case, now handled by build_call_alloc_dealloc. Pass data + type instead of the former alignment argument, as expected by the new + interface. + * gcc-interface/gigi.h (build_call_alloc_dealloc): Adjust prototype + and comment. + * gcc-interface/trans.c (gnat_to_gnu) : + Remove special processing for the super-aligned case, now handled + by build_call_alloc_dealloc. Pass data type instead of the former + alignment argument, as expected by the new interface. + +2009-06-08 Alexandre Oliva + + * lib-writ.adb (flag_compare_debug): Import. + (Write_ALI): Skip during -fcompare-debug-second. + +2009-06-03 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : When + adjusting the discriminant nodes in an extension, use the full view + of the parent subtype if it is of a private kind. + +2009-06-03 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Add the + _Parent field, if any, to the record before adding the other fields. + : Put the _Controller field before the other fields + except for the _Tag or _Parent fields. + (components_to_record): Likewise. Retrieve the _Parent field from the + record type. + +2009-06-03 Eric Botcazou + + * gcc-interface/decl.c (substitution_list): Rename to build_subst_list, + remove unused parameter and simplify. + (gnat_to_gnu_entity) : Do not set TYPE_FIELDS. Factor + common predicate. Rewrite loop for clarity. Use GNU_TYPE directly + as context for all discriminants. Fix formatting nits. + : Add cosmetic 'break'. Test Has_Discriminants + before Discriminant_Constraint. Adjust for above renaming. Do not + set GNU_TYPE more than once. + (elaborate_entity): Test Has_Discriminants on the entity and use + Implementation_Base_Type. + (components_to_record): Rename component_list to gnat_component_list. + Retrieve the _Parent field from the list. Fix nits in comments. + Clarify logic in loop. Pass correct arguments to create_field_decl. + +2009-06-02 Eric Botcazou + + * gcc-interface/Make-lang.in: Fix formatting. + +2009-06-01 Olivier Hainque + Eric Botcazou + + * gcc-interface/utils.c (convert) : When converting + to the packable version of the type, clear TREE_STATIC/TREE_CONSTANT + on the result if at least one of the input fields couldn't be output + as a static constant any more. + +2009-06-01 Olivier Hainque + Eric Botcazou + + * gcc-interface/utils2.c (gnat_build_constructor): Factor + out code. Use initializer_constant_valid_for_bitfield_p and + CONSTRUCTOR_BITFIELD_P for bit-fields. + +2009-05-26 Ian Lance Taylor + + * gcc-interface/Makefile.in (COMPILER): Define. + (COMPILER_FLAGS, ALL_COMPILERFLAGS): Define. + (.c.o, cio.o, init.o, initialize.o, targext.o): Use $(COMPILER). + (seh_init.o, tracebak.o): Likewise. + * gcc-interface/Make-lang.in (ada/targext.o): Likewise. + (ada/cio.o, ada/init.o, ada/initialize.o, ada/raise.o): Likewise. + (ada/tracebak.o, ada/cuintp.o, ada/decl.o, ada/misc.o): Likewise. + (ada/targtyps.o, ada/trans.o, ada/utils.o): Likewise. + (ada/utils2.o): Likewise. + +2009-05-24 Olivier Hainque + + * switch.adb (Is_Internal_GCC_Switch, Switch_Last): Bodies of ... + * switch.ads (Is_Internal_GCC_Switch, Switch_Last): New functions. + Add -auxbase variants to the list of recognized internal switches. + * back_end.adb (Scan_Back_End_Switches): Use the new functions and + adjust comments. + * lib.ads: Make comment on internal GCC switches more general. + * gcc-interface/lang-specs.h (specs for Ada): Pass -auxbase variants + as for C. + +2009-05-23 Eric Botcazou + + * gcc-interface/misc.c (gnat_get_subrange_bounds): Fix thinko. + +2009-05-23 Eric Botcazou + + * gcc-interface/decl.c (set_rm_size): Bypass the check for packed array + types. + +2009-05-23 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Do not modify the + original type because of the alignment when there is an address clause. + +2009-05-20 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : When + discriminants affect the shape of the subtype, retrieve the GCC type + directly from the original field if the GNAT types for the field and + the original field are the same. + +2009-05-15 Eric Botcazou + + * gcc-interface/ada-tree.h (TYPE_GCC_MIN_VALUE, TYPE_GCC_MAX_VALUE): + New macros. + (TYPE_RM_VALUES): Likewise. + (TYPE_RM_SIZE): Rewrite in terms of TYPE_RM_VALUES. + (SET_TYPE_RM_SIZE): New macro. + (TYPE_RM_MIN_VALUE, TYPE_RM_MAX_VALUE): Likewise. + (SET_TYPE_RM_SIZE, SET_TYPE_RM_MAX_VALUE): Likewise. + (TYPE_MIN_VALUE, TYPE_MAX_VALUE): Redefine. + * gcc-interface/gigi.h (create_range_type): Declare. + * gcc-interface/decl.c (gnat_to_gnu_entity) + Use SET_TYPE_RM_MAX_VALUE to set the upper bound on the UMT type. + : Build a regular integer type first and + then set the RM bounds. Use SET_TYPE_RM_SIZE to set the RM size. + : Build a regular floating-point type first + and then set the RM bounds. + : Use create_range_type instead of build_range_type. + : Build a regular integer type first and then set + the RM bounds for the extra subtype. + : Use create_range_type instead of + build_range_type. + : Set the RM bounds for enumeration types and the GCC bounds for + floating-point types. + (set_rm_size): Use SET_TYPE_RM_SIZE to set the RM size. + (make_type_from_size) : Use SET_TYPE_RM_{MIN,MAX}_VALUE + to set the bounds. Use SET_TYPE_RM_SIZE to set the RM size. + (substitute_in_type) : Deal with GCC bounds for domain + types and with RM bounds for subtypes. + * gcc-interface/misc.c (LANG_HOOKS_GET_SUBRANGE_BOUNDS): Define. + (gnat_print_type) : New case. + : Fall through to above case. + (gnat_get_subrange_bounds): New function. + * gcc-interface/trans.c (add_decl_expr): Mark the trees rooted as + TYPE_RM_MIN_VALUE and TYPE_RM_MAX_VALUE, if any. + * gcc-interface/utils.c (gnat_init_decl_processing): Use precision 8 + for booleans. Adjust and use SET_TYPE_RM_SIZE to set the RM size. + (create_range_type): New function. + (create_param_decl): Build a regular integer type first and then set + the RM bounds for the extra subtype. + (unchecked_convert): Remove kludge for 'Valid. + * gcc-interface/utils2.c (build_binary_op) : Convert + the index to sizetype instead of TYPE_DOMAIN. + +2009-05-14 Eric Botcazou + + * gcc-interface/decl.c (elaborate_expression_1): Remove GNAT_EXPR + parameter and move check for static expression to... + (elaborate_expression): ...here. Adjust call to above function. + (gnat_to_gnu_entity): Likewise for all calls. Use correct arguments + in calls to elaborate_expression. + (elaborate_entity): Likewise. + (substitution_list): Likewise. + (maybe_variable): Fix formatting. + (substitute_in_type) : Merge with INTEGER_TYPE case and add + missing guard. + * gcc-interface/trans.c (protect_multiple_eval): Minor cleanup. + +2009-05-07 Arnaud Charlet + + * gcc-interface/Make-lang.in: Update dependencies. + +2009-05-06 Laurent GUERBY + + * s-linux.ads, s-linux-alpha.ads, s-linux-hppa.ads, osinte-linux.ads: + Define sa_handler_pos. + * s-osinte-linux.ads: Use it. + * s-linux-mipsel.ads: New. + * system-linux-mips64el.ads: New. + * gcc-interface/Makefile.in: Multilib handling for mipsel-linux and + mips64el-linux. + +2009-05-06 Arnaud Charlet + + * exp_ch5.adb, exp_util.adb, exp_attr.adb, sem_util.adb, sem_res.adb, + targparm.adb, targparm.ads, exp_ch4.adb, exp_ch6.adb, exp_disp.adb, + opt.ads, exp_aggr.adb, exp_intr.adb, sem_disp.adb, exp_ch3.adb + (Tagged_Type_Expansion): New flag. + Replace use of VM_Target related to tagged types expansion by + Tagged_Type_Expansion, since tagged type expansion is not necessarily + linked to VM targets. + +2009-05-06 Robert Dewar + + * sem_attr.adb: Add processing for Standard'Compiler_Version + + * sinput.adb (Expr_Last_Char): Fix some copy-paste errors for paren + skipping. + (Expr_First_Char): Add ??? comment that paren skipping needs work + (Expr_Last_Char): Add ??? comment that paren skipping needs work + + * exp_attr.adb: Add processing for Compiler_Version + + * sem_attr.adb: New attribute Compiler_Version + + * snames.ads-tmpl: Add entries for Compiler_Version attribute + + * gnat_rm.texi: Document Compiler_Version attribute + +2009-05-06 Robert Dewar + + * errout.adb: Minor reformatting + + * scng.adb, sem_prag.adb, par-ch4.adb, sem_res.adb, par-ch6.adb, + sem_ch6.adb, par-prag.adb, sem_ch8.adb, sem_warn.adb, par-util.adb, + styleg.adb: Add stylized comments to error messages that are included + in the codefix circuitry of IDE's such as GPS. + +2009-05-06 Sergey Rybin + + * gnat_ugn.texi: For Misnamed_Identifiers rule all description of the + new form of the rule parameter that allows to specify the suffix for + access-to-access type names. + +2009-05-06 Robert Dewar + + * sem_warn.adb (Warn_On_Useless_Assignment): Avoid false negative for + out parameter assigned when exception handlers are present. + + * sem_ch5.adb (Analyze_Exit_Statement): Kill current value last + assignments on exit. + + * par-ch9.adb, sem_aggr.adb, par-endh.adb, sem_res.adb, par-ch6.adb, + sinput-l.adb, par-load.adb, errout.ads, sem_ch4.adb, lib-load.adb, + prj-dect.adb, par-ch12.adb, sem_ch8.adb, par-util.adb, par-ch3.adb, + par-tchk.adb, par-ch5.adb: This patch adds stylized comments to error + messages that are included in the codefix circuitry of IDE's such as + GPS. + + * sinput.ads, sinput.adb (Expr_First_Char): New function + (Expr_Last_Char): New function + +2009-05-06 Sergey Rybin + + * gnat_ugn.texi: Add subsection for Exits_From_Conditional_Loops rule + Add formal definition for extra exit point metric + +2009-05-06 Pascal Obry + + * adaint.c: Support for setting attributes on unicode filename on + Windows. + +2009-05-06 Robert Dewar + + * sem_warn.adb: Minor reformatting + +2009-05-06 Javier Miranda + + * sem_prag.adb (Process_Import_Or_Interface): Imported CPP types must + not have discriminants or components with default expressions. + (Analyze_Pragma): For pragma CPP_Class check that imported types + have no discriminants and components have no default expression. + + * sem_aggr.adb (Resolve_Aggr_Expr): Add missing check on wrong use of + class-wide types in the expression of a record component association. + +2009-05-06 Sergey Rybin + + * vms_data.ads: Add qualifier for gnatmetric extra exit points metric + + * gnat_ugn.texi: Add description for the new extra exit points metric + (gnatmetric section). + +2009-05-06 Robert Dewar + + * s-fileio.adb: Minor comment update + + * sem_ch8.adb: Minor reformatting + + * exp_ch3.adb: Update comments. + +2009-05-06 Tristan Gingold + + * init.c, s-osinte-darwin.ads: Reduce alternate stack size + +2009-05-06 Arnaud Charlet + + * gcc-interface/Makefile.in: Update LIBGNAT_TARGET_PAIRS for Xenomai. + Fix missing unit for rtp-smp runtime on both ppc and x86 vxworks + + * gcc-interface/Make-lang.in: Update dependencies + +2009-05-06 Ed Schonberg + + * sem_ch12.adb (Build_Instance_Compilation_Unit_Nodes): Revert previous + change. The context clause of a generic instance declaration must be + preserved until the end of the compilation, because it may have to be + installed/removed repeatedly. + The latest change to sem.adb ensures that the context of both spec and + body of an instance is traversed before the instance itself, making + this patch redundant. + +2009-05-06 Gary Dismukes + + * sem_aggr.adb: Fix typo. + +2009-05-06 Thomas Quinot + + * exp_ch3.adb (Expand_N_Object_Declaration): For a controlled object + declaration, do not adjust if the declaration is to be rewritten into + a renaming. + +2009-05-06 Ed Schonberg + + * sem_ch8.adb (Find_Type): Reject the use of a task type in its own + discriminant part. + +2009-05-06 Bob Duff + + * s-fileio.adb (File_IO_Clean_Up_Type): Make this type limited, since + otherwise the compiler would be allowed to optimize away the cleanup + code. + +2009-05-06 Gary Dismukes + + * gnat_ugn.texi: Fix typo. + +2009-05-06 Thomas Quinot + + * g-debuti.adb: Minor reformatting + + * exp_attr.adb: Minor reformatting + +2009-05-06 Robert Dewar + + * sem_aggr.adb: Minor reformatting. + + * g-socthi-vms.adb: Minor reformatting + +2009-05-06 Bob Duff + + * g-table.ads, g-table.adb, g-dyntab.ads, g-dyntab.adb: + (Append_All): Add Append_All to g-table and g-dyntab, similar to table. + +2009-05-06 Bob Duff + + * gnat_ugn.texi, gnat_rm.texi: Add missing documentation for warnings + flags. + +2009-05-06 Javier Miranda + + * sem_aggr.adb (Valid_Ancestor_Type): Add support for C++ constructors. + (Resolve_Extension_Aggregate): Do not reject C++ constructors in + extension aggregates. + (Resolve_Record_Aggregate): Add support for C++ constructors in + extension aggregates. + + * exp_aggr.adb (Build_Record_Aggr_Code): Add support for C++ + constructors in extension aggregates. + +2009-05-06 Robert Dewar + + * freeze.adb (Freeze_Record_Type): Improve error msg for bad size + clause. + +2009-05-06 Thomas Quinot + + * g-socthi-vms.adb (C_Recvmsg, C_Sendmsg): Convert Msg to appropriate + packed type, since on OpenVMS, struct msghdr is packed. + +2009-05-06 Ed Schonberg + + * sem_ch8.adb (Analyze_Object_Renaming): If the object is a function + call returning an unconstrained composite value, create the proper + subtype for it, as is done for object dclarations with unconstrained + nominal subtypes. Perform this transformation regarless of whether + call comes from source. + +2009-05-06 Robert Dewar + + * freeze.adb (Freeze_Record_Type): Implement Implicit_Packing for + records + + * gnat_rm.texi: + Add documentation for pragma Implicit_Packing applied to record + types. + +2009-05-06 Ed Schonberg + + * sem.adb (Walk_Library_Items): Place all with_clauses of an + instantiation on the spec, because late instance bodies may generate + with_clauses for the instance body but are inserted in the instance + spec. + +2009-05-06 Emmanuel Briot + + * prj-nmsc.adb (Locate_Directory): Remove unused parameters, and add + support for returning the directory even if it doesn't exist. This is + used for the object directory, since we are always setting it to a + non-null value, and we should set it to an absolute name rather than a + relative name for the sake of external tools that might depend on it. + (Check_Library_Attributes): When Project.Library_Dir is known, check + that the directory exists. + +2009-05-06 Ed Schonberg + + * sem_attr.adb (Check_Dereference): If the prefix of an attribute + reference is an implicit dereference, do not freeze the designated type + if within a default expression or when preanalyzing a pre/postcondtion. + +2009-05-06 Ed Schonberg + + * sem_ch8.adb (Analyze_Object_Renaming): If the object is a function + call returning an unconstrained composite value, create the proper + subtype for it, as is done for object dclarations with unconstrained + nominal subtypes + +2009-05-06 Robert Dewar + + * sem_ch13.adb (Check_Constant_Address_Clause): Minor error message + improvements + + * freeze.adb: Minor reformatting + +2009-05-06 Thomas Quinot + + * sem_ch3.adb (Access_Type_Declaration): An access type whose + designated type is a limited view from a limited with clause (flagged + From_With_Type) is not itself such a limited view. + +2009-05-06 Emmanuel Briot + + * prj-nmsc.adb: Remove unused variable. + + * clean.adb, gnatcmd.adb, makeutl.ads, prj-pars.adb, prj-pars.ads, + prj-proc.ads, prj.ads, switch-m.adb (Subdirs_Option): Moved to + makeutl.ads, since not all users of prj.ads need this. + +2009-05-06 Javier Miranda + + * exp_aggr.adb (Build_Record_Aggr_Code): Add implicit call to the C++ + constructor in case of aggregates whose type is a CPP_Class type. + +2009-05-06 Robert Dewar + + * sem_ch13.adb: Minor comment additions + + * osint.adb: Minor reformatting + +2009-05-06 Pascal Obry + + * initialize.c: On Windows, keep full pathname to expanded command + line patterns. + +2009-05-06 Ed Schonberg + + * sem_aggr.adb (Resolve_Record_Aggregate): If a defaulted component of + an aggregate with box default is of a discriminated private type, do + not build a subaggregate for it. + A proper call to the initialization procedure is generated for it. + +2009-05-06 Thomas Quinot + + * rtsfind.adb, rtsfind.ads, exp_dist.adb, exp_dist.ads + (Exp_Dist.Build_TC_Call, Build_From_Any_Call, Build_To_Any_Call): + Use PolyORB strings to represent Ada.Strings.Unbounded_String value; + use standard array code for Standard.String. + (Exp_Dist): Bump PolyORB s-parint API version to 3. + (Rtsfind): New entities TA_Std_String, Unbounded_String. + +2009-05-06 Robert Dewar + + * g-comlin.ads: Minor reformatting + + * xoscons.adb: Minor reformatting + +2009-05-06 Gary Dismukes + + * sem_aggr.adb (Resolve_Record_Aggregate): In step 5, get the + Underlying_Type before retrieving the type definition for gathering + components, to account for the case where the type is private. + +2009-05-06 Tristan Gingold + + * g-comlin.ads: Fix minor typos (Getopt instead of Get_Opt). + +2009-05-06 Thomas Quinot + + * g-socthi-vms.adb, g-socthi-vms.ads, g-socthi-vxworks.adb, + g-socthi-vxworks.ads, g-socthi-mingw.adb g-socthi-mingw.ads, + g-socthi.adb, g-stsifd-sockets.adb, g-socthi.ads, g-socket.adb + (GNAT.Sockets.Thin.C_Sendmsg, GNAT.Sockets.Thin.C_Recvmsg, + Windows versions): Fix incorrect base + address of Iovec (it's Msg_Iov, not Msg_Iov'Address). + (GNAT.Sockets.Thin.C_Sendto, GNAT.Sockets.Thin.C_Recvfrom): Use a + System.Address for the To parameter instead of a Sockaddr_In_Access, to + achieve independance from AF_INET family, and also to allow this + parameter to be retrieved from a Msghdr for the Windows case where + these routines are used to implement C_Sendmsg and C_Recvmsg. + +2009-05-06 Bob Duff + + * g-expect.adb, g-expect.ads: Minor reformatting + + * sdefault.ads: Minor comment fix + + * g-expect-vms.adb: Minor reformatting + + * table.ads, table.adb (Append_All): New convenience procedure for + appending a whole array. + + * comperr.adb (Compiler_Abort): Mention the -gnatd.n switch in the bug + box message. Call Osint.Dump_Source_File_Names to print out the file + list, instead of rummaging around in various data structures. + + * debug.adb: New switch -gnatd.n, to print source file names as they + are read. + + * alloc.ads: Add parameters for Osint.File_Name_Chars. + + * osint.ads, osint.adb (Dump_Source_File_Names): New procedure to print + out source file names during a "bug box". + (Include_Dir_Default_Prefix): Use memo-izing to avoid repeated new/free. + (Read_Source_File): Print out the file name, if requested via -gnatd.n. + If it's not part of the runtimes, store it for later printing by + Dump_Source_File_Names. + +2009-05-06 Javier Miranda + + * gnat_rm.texi (CPP_Constructor): Avoid duplication of the + documentation and add reference to the GNAT user guide for further + details. + +2009-05-06 Javier Miranda + + * gnat_ugn.texi: Complete documentation for CPP_Constructor and remove + also wrong examples that use extension aggregates. + +2009-05-06 Albert Lee + + * s-oscons-tmplt.c (System.OS_Constants): Do not use special definition + of Msg_Iovlen_T for VMS. + +2009-05-04 Laurent GUERBY + + PR ada/38874 + * make.adb (Scan_Make_Arg): Pass --param= to compiler and linker. + +2009-04-29 Ed Schonberg + + * sem_ch8.adb (Analyze_Subprogram_Renaming): Improve error message on + box-defaulted operator in an instantiation, when the type of the + operands is not directly visible. + +2009-04-29 Gary Dismukes + + * sem_aggr.adb (Valid_Limited_Ancestor): Undo previous change. + (Resolve_Extension_Aggregate): Call Check_Parameterless_Call after the + analysis of the ancestor part. Remove prohibition against limited + interpretations of the ancestor expression in the case of Ada 2005. + Revise error message in overloaded case, adding a message to cover + the Ada 2005 case. + +2009-04-29 Thomas Quinot + + * xoscons.adb: Minor reformatting + +2009-04-29 Bob Duff + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Do not ignore + attribute_definition_clauses for the following attributes when the + -gnatI switch is used: External_Tag, Input, Output, Read, Storage_Pool, + Storage_Size, Write. Otherwise, we get spurious errors (for example, + missing Read attribute on remote types). + + * gnat_ugn.texi: Document the change, and add a stern warning. + +2009-04-29 Ed Schonberg + + * sem_attr.adb (Check_Local_Access): Indicate that value tracing is + disabled not just for the current scope, but for the innermost dynamic + scope as well. + +2009-04-29 Arnaud Charlet + + * gcc-interface/Make-lang.in: Update dependencies + +2009-04-29 Vincent Celier + + * prj-part.adb: Minor comment update + +2009-04-29 Ed Schonberg + + * sem_aggr.adb (Resolve_Record_Aggregate): handle properly + box-initialized records with discriminated subcomponents that are + constrained by discriminants of enclosing components. New subsidiary + procedures Add_Discriminant_Values, Propagate_Discriminants. + +2009-04-29 Arnaud Charlet + + * g-socket.adb: Code clean up. + +2009-04-29 Gary Dismukes + + * sem_aggr.adb (Valid_Limited_Ancestor): Add test for the name of a + function entity, to cover the case of a parameterless function call + that has not been resolved. + +2009-04-29 Robert Dewar + + * err_vars.ads, prj-part.adb, scans.ads, exp_tss.adb: Minor + reformatting and comment updates. + +2009-04-29 Arnaud Charlet + + * gnat_ugn.texi: Update some documentation about interfacing with C++ + Mention -fkeep-inline-functions. + + * gnat_ugn.texi: Minor edits + +2009-04-29 Ed Schonberg + + * sem_aggr.adb (Resolve_Record_Aggregate): When building an aggregate + for a defaulted component of an enclosing aggregate, inherit the type + from the component declaration of the enclosing type. + +2009-04-29 Albert Lee + + * g-socthi-vms.ads, g-socthi-vxworks.ads, s-oscons-tmplt.c, + g-socthi-mingw.ads, g-socthi.ads, g-socket.adb, g-sothco.ads + (System.OS_Constants): New type Msg_Iovlen_T which follows whether the + msg_iovlen field in struct msghdr is 32 or 64 bits wide. + Relocate the Msghdr record type from GNAT.Sockets.Thin to + GNAT.Sockets.Common, and use System.OS_Constants.Msg_Iovlen_T as the + type for the Msg_Iovlen field. + +2009-04-29 Vincent Celier + + * sinput-l.adb (Load_File): When preprocessing, set temporarily the + Source_File_Index_Table entries for the source, to avoid crash when + reporting an error. + + * gnatcmd.adb (Test_If_Relative_Path): Use + Makeutl.Test_If_Relative_Path. + + * makeutl.adb:(Test_If_Relative_Path): Process switches --RTS= only if + Including_RTS is True. + + * makeutl.ads (Test_If_Relative_Path): New Boolean parameter + Including_RTS defaulted to False. + + * sinput.ads, scans.ads, err_vars.ads: Initialize some variables with + a default value. + +2009-04-29 Javier Miranda + + * gnat_ugn.texi: Adding documentation for non-default C++ constructors. + +2009-04-29 Javier Miranda + + * sem_ch3.adb (Analyze_Object_Declaration): Disable error message + associated with dyamically tagged expressions if the expression + initializing a tagged type corresponds with a non default CPP + constructor. + (OK_For_Limited_Init): CPP constructor calls are OK for initialization + of limited type objects. + + * sem_ch5.adb (Analyze_Assignment): Improve the error message reported + when a CPP constructor is called in an assignment. Disable also the + error message associated with dyamically tagged expressions if the + exporession initializing a tagged type corresponds with a non default + CPP constructor. + + * sem_prag.adb (Analyze_Pragma): Remove code disabling the use of + non-default C++ constructors. + + * sem_util.ads, sem_util.adb (Is_CPP_Constructor_Call): New subprogram. + + * exp_tss.ads, exp_tss.adb (Base_Init_Proc): Add support for + non-default constructors. + (Init_Proc): Add support for non-default constructors. + + * exp_disp.adb (Set_Default_Constructor): Removed. + (Set_CPP_Constructors): Code based in removed Set_Default_Constructor + but extending its functionality to handle non-default constructors. + + * exp_aggr.adb (Build_Record_Aggr_Code): Add support for non-default + constructors. Minor code cleanup removing unrequired label and goto + statement. + + * exp_ch3.adb (Build_Initialization_Call): Add support for non-default + constructors. + (Build_Init_Statements): Add support for non-default constructors. + (Expand_N_Object_Declaration): Add support for non-default constructors. + (Freeze_Record_Type): Replace call to Set_Default_Constructor by call + to Set_CPP_Constructors. + + * exp_ch5.adb (Expand_N_Assignment_Statement): Add support for + non-default constructors. + Required to handle its use in build-in-place statements. + + * gnat_rm.texi (CPP_Constructor): Document new extended use of this + pragma for non-default C++ constructors and the new compiler support + that allows the use of these constructors in record components, limited + aggregates, and extended return statements. + +2009-04-29 Vincent Celier + + * prj-part.adb (Parse_Single_Project): Do not attempt to find a + project extending an abstract project. + +2009-04-29 Eric Botcazou + + * targparm.ads: Fix oversight. + +2009-04-29 Ed Schonberg + + * lib-xref.adb (Output_Overridden_Op): Follow several levels of + derivation when necessary, to find the user-subprogram that is actally + being overridden. + +2009-04-29 Robert Dewar + + * sem_util.adb (May_Be_Lvalue): Fix cases involving indexed/selected + components + +2009-04-29 Ed Schonberg + + * exp_ch9.ads, exp_ch9.adb (Build_Wrapper_Spec): Use source line of + primitive operation, rather than source line of synchronized type, when + building the wrapper for a primitive operation that overrides an + operation inherited from a progenitor, to improve the error message on + duplicate declarations. + + * sem_ch3.adb (Process_Full_View): Use new signature of + Build_Wrapper_Spec. + +2009-04-29 Robert Dewar + + * prj-nmsc.ads: Minor reformatting + +2009-04-29 Eric Botcazou + + * exp_ch4.adb (Expand_N_Conditional_Expression): Set the SLOC of the + expression on the existing parent If statement. + +2009-04-29 Robert Dewar + + * prj-proc.adb, prj.ads: Minor reformatting + +2009-04-29 Eric Botcazou + + * exp_ch4.adb (Expand_N_Conditional_Expression): Set the SLOC of an + existing parent If statement on the newly created one. + +2009-04-29 Emmanuel Briot + + * gnatcmd.adb, prj-proc.adb, prj-proc.ads, make.adb, prj-part.adb, + prj-part.ads, prj.adb, prj.ads, clean.adb, prj-dect.adb, prj-dect.ads, + prj-nmsc.adb, prj-nmsc.ads, prj-pars.adb, prj-pars.ads, prj-makr.adb + (Set_In_Configuration, In_Configuration): Removed. + Replaced by an extra parameter Is_Config_File in several parameter to + avoid global variables to store the state of the parser. + +2009-04-29 Ed Schonberg + + * sinfo.ads, sinfo.adb: New attribute Next_Implicit_With, to chain + with_clauses generated for the same unit through rtsfind, and that + appear in the context of different units. + + * rtsfind.adb: New attribute First_Implicit_With, component of the + Unit_Record that stores information about a unit loaded through rtsfind. + +2009-04-29 Gary Dismukes + + * exp_ch3.adb (Stream_Operation_OK): Return True for limited interfaces + (other conditions permitting), so that abstract stream subprograms will + be declared for them. + +2009-04-29 Bob Duff + + * g-expect.adb (Expect_Internal): Fix check for overfull buffer. + + * g-expect.ads: Minor comment fixes. + +2009-04-29 Ed Schonberg + + * freeze.adb, lib-xref.adb (Check_Dispatching_Operation): if the + dispatching operation is a body without previous spec, update the list + of primitive operations to ensure that cross-reference information is + up-to-date. + +2009-04-29 Albert Lee + + * g-socthi-vms.adb, g-socthi-vms.ads, g-socthi-vxworks.adb, + g-socthi-vxworks.ads, g-socthi-mingw.adb, g-socthi-mingw.ads, + g-socthi.adb, g-socthi.ads, g-socket.adb, g-socket.ads + (GNAT.Sockets.Thin.C_Readv, + GNAT.Sockets.Thin.C_Writev): Remove unused subprograms. + (GNAT.Sockets.Thin.C_Recvmsg, + GNAT.Sockets.Thin.C_Sendmsg): New bindings to call recvmsg(2) and + sendmsg(2). + (GNAT.Sockets.Receive_Vector, GNAT.Sockets.Send_Vector): Use + C_Recvmsg/C_Sendmsg rather than Readv/C_Writev. + +2009-04-29 Ed Schonberg + + * sem_disp.adb (Check_Dispatching_Operation): if the dispatching + operation is a body without previous spec, update the list of + primitive operations to ensure that cross-reference information is + up-to-date. + + * sem_ch12.adb (Build_Instance_Compilation_Unit_Nodes): When creating a + new compilation unit node for the instance declaration, keep the + context items of the original unit on it, so that the context of the + instance body only holds the context inherited from the generic body. + +2009-04-29 Bob Duff + + * sem_res.adb: Minor comment fix. + +2009-04-29 Thomas Quinot + + * sem_elim.adb: Minor reformatting + +2009-04-29 Ed Schonberg + + * exp_aggr.adb (Convert_To_Positional): if the current unit is a + predefined unit, allow arbitrary number of components in static + aggregate, to ensure that the same level of constant folding applies + for Ada 95 and Ada 05 versions of the file. + +2009-04-29 Ed Schonberg + + * sem_elim.adb (Check_Eliminated): Handle new improved eliminate + information: no need for full scope check. + (Eliminate_Error): Do not emit error in a generic context. + +2009-04-29 Ed Falis + + * adaint.c (__gnat_rmdir): return error code if VTHREADS is defined. + VxWorks 653 POS does not support rmdir. + +2009-04-29 Matteo Bordin + + * s-stausa.adb, s-stausa.ads: Get_Usage_Range: changing the way + results are printed. + +2009-04-29 Arnaud Charlet + + * s-taskin.adb (Initialize): Remove pragma Warnings Off and remove + unused assignment. + +2009-04-29 Thomas Quinot + + * make.adb: Minor reformatting. + Minor code reorganization throughout. + +2009-04-29 Matteo Bordin + + * s-stausa.ads: Changed visibility of type Task_Result: moved to + public part to give application visibility over it. + This is for future improvement and to build a public API on top of it. + Changed record components name of type Task_Result to reflect the new + way of reporting. + + * s-stausa.adb: Actual_Size_Str changed to reflect the new way of + reporting Stack usage. + + * gnat_ugn.texi: Update doc of stack usage report. + + * g-tastus.ads, s-stusta.ads, s-stusta.adb: New files. + + * Makefile.rtl: Add new run-time files. + +2009-04-29 Pascal Obry + + * initialize.c: Do not expand quoted arguments. + +2009-04-29 Emmanuel Briot + + * prj-ext.adb, prj.adb, prj.ads: Fix memory leaks. + + * clean.adb (Ultimate_Extension_Of): removed, since duplicate of + Prj.Ultimate_Extending_Project_Of + +2009-04-29 Ed Schonberg + + * exp_ch7.adb (Build_Final_List): If the designated type is a Taft + Amendment type, add the with_clause for Finalization.List_Controller + only if the current context is a package body. + +2009-04-29 Thomas Quinot + + * sem_ch12.adb: Minor reformatting + + * sem_aggr.adb: Minor reformatting + + * sem_ch6.adb, sem_cat.ads: Minor reformatting + + * sem_ch10.adb, gnat1drv.adb, prj-nmsc.adb: Minor reformatting + +2009-04-29 Quentin Ochem + + * prj.ads (Source_Id): Now general pointer type. + +2009-04-29 Thomas Quinot + + * exp_ch7.adb, rtsfind.adb: Minor reformatting + + * sem_res.adb: Minor reformatting + +2009-04-29 Thomas Quinot + + * sem_res.adb (Static_Concatenation): An N_Op_Concat with static + operands is static only if it is a predefined concatenation operator. + + * sem_util.adb: Minor reformatting + + * sem_ch12.adb (Save_References): When propagating semantic information + from generic copy back to generic template, for the case of an + identifier that has been rewritten to an explicit dereference whose + prefix is either an object name or a parameterless funcion call + denoting a global object or function, properly capture the denoted + global entity: perform the corresponding rewriting in the template, + and point the rewritten identifier to the correct global entity (not + to the associated identifier in the generic copy). + +2009-04-29 Robert Dewar + + * rtsfind.adb, prj-env.adb: Minor reformatting + Minor code reorganization + +2009-04-29 Emmanuel Briot + + * make.adb: Fix comment + + * prj.adb (Ultimate_Extending_Project_Of): Fix handling when no project + is given as argument, as might happen in gnatmake. + +2009-04-29 Ed Schonberg + + * sem_ch3.adb (Check_Abstract_Overriding): Improve error message when + an abstract operation of a progenitor is not properly overridden by an + operation of a derived synchronized type. + +2009-04-29 Robert Dewar + + * mlib-prj.adb, mlib-tgt.adb, mlib-tgt.ads, prj-nmsc.adb, + prj-proc.adb: Minor reformatting + Minor code reorganization + +2009-04-29 Bob Duff + + * exp_ch7.adb (Build_Final_List): For an access type that designates a + Taft Amendment type, if the access type needs finalization, make sure + the implicit with clause for List_Controller occurs on the package spec. + + * rtsfind.adb (Text_IO_Kludge): Fine tune the creation of implicit + with's created for the pseudo-children of Text_IO and friends. In + particular, avoid cycles, such as Ada.Wide_Text_IO.Integer_IO and + Ada.Text_IO.Integer_IO both with-ing each other. + + * sem.adb (Walk_Library_Items): Suppress assertion failure in certain + oddball cases when pragma Extend_System is used. + + * sem_ch12.adb (Get_Associated_Node): Prevent direct 'with' cycles in + the case where a package spec instantiates a generic whose body with's + this package, so Walk_Library_Items won't complain about cyclic with's. + +2009-04-29 Emmanuel Briot + + * gnatcmd.adb, prj-proc.adb, make.adb, mlib-prj.adb, prj.adb, prj.ads, + prj-pp.adb, prj-pp.ads, makeutl.adb, clean.adb, prj-nmsc.adb, + mlib-tgt.adb, mlib-tgt.ads, prj-util.adb, prj-env.adb, prj-env.ads + (Project_Id): now a real pointer to Project_Data, instead of an index + into the Projects_Table. This simplifies the API significantly, avoiding + extra lookups in this table and the need to pass the Project_Tree_Ref + parameter in several cases + +2009-04-29 Nicolas Setton + + * gcc-interface/Makefile.in: Produce .dSYM files for shared libs on + darwin. + +2009-04-25 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Put + back kludge. + +2009-04-24 Robert Dewar + + * mlib-prj.adb, prj-env.adb, prj-nmsc.adb, prj-proc.adb, make.adb, + clean.adb: Minor reformatting. + Minor code reorganization and message improvement. + +2009-04-24 Emmanuel Briot + + * prj-proc.adb, prj.adb, prj.ads, prj-nmsc.adb, prj-nmsc.ads + (Alternate_Languages): now implemented as a malloc-ed list rather + than through a table. + +2009-04-24 Thomas Quinot + + * sem_res.adb (Static_Concatenation): Simplify predicate to make it + accurately handle cases such as "lit" & "lit" and + "lit" & static_string_constant + +2009-04-24 Emmanuel Briot + + * prj-proc.adb, make.adb, mlib-prj.adb, prj.adb, prj.ads, clean.adb, + prj-nmsc.adb, prj-env.adb (Project_List_Table, Project_Element): + removed. Lists of projects are now implemented via standard malloc + rather than through the table. + +2009-04-24 Thomas Quinot + + * sem_ch12.adb: Minor reformatting + + * g-trasym.adb: Minor reformatting + + * exp_ch6.adb: Minor reformatting + +2009-04-24 Robert Dewar + + * layout.adb (Layout_Type): For packed array type, copy unset + size/alignment fields from the referenced Packed_Array_Type. + +2009-04-24 Bob Duff + + * lib-load.adb (Make_Instance_Unit): Revert previous change, no + longer needed after sem_ch12 changes. + + * sem.adb (Walk_Library_Items): Include with's in some debugging + printouts. + +2009-04-24 Emmanuel Briot + + * prj.ads, prj-nmsc.adb (Unit_Project): removed, since in fact we were + only ever using the Project field. + +2009-04-24 Ed Schonberg + + * sem_ch12.adb (Build_Instance_Compilation_Unit_Nodes): Do not set + Body_Required on the generated compilation node. The new node is linked + to its body, but both share the same file, so we do not set this flag + on the new unit so as not to create a spurious dependency on a + non-existent body in the ali file for the instance. + +2009-04-24 Robert Dewar + + * make.adb: Minor reformatting + +2009-04-24 Emmanuel Briot + + * prj.adb, prj.ads, prj-nmsc.adb (Check_File, Record_Ada_Source, + Add_Source): merge some code between those. In particular change where + file normalization is done to avoid a few extra calls to + Canonicalize_File_Name. This also removes the need for passing + Current_Dir in a number of subprograms. + +2009-04-24 Bob Duff + + * lib-load.adb (Make_Instance_Unit): In the case where In_Main is + False, assign the correct unit to the Cunit field of the new table + entry. We want the spec unit, not the body unit. + + * rtsfind.adb (Make_Unit_Name, Maybe_Add_With): Simplify calling + interface for these. + (Maybe_Add_With): Check whether we're trying to a with on the current + unit, and avoid creating such directly self-referential with clauses. + (Text_IO_Kludge): Add implicit with's for the generic pseudo-children of + [[Wide_]Wide_]Text_IO. These are needed for Walk_Library_Items, + and matches existing comments in the spec. + + * sem.adb (Walk_Library_Items): Add various special cases to make the + assertions pass. + + * sem_ch12.adb (Build_Instance_Compilation_Unit_Nodes): Use Body_Cunit + instead of Parent (N), for uniformity. + +2009-04-24 Robert Dewar + + * errout.ads: Minor reformatting + +2009-04-24 Emmanuel Briot + + * gnat_ugn.texi (Library Projects): add documentation on gnatmake's + behavior when the project includes sources from multiple languages + +2009-04-24 Vincent Celier + + * prj.adb (Has_Foreign_Sources): Returns True in Ada_Only mode if there + is a language other than Ada declared. + + * makeutl.adb (Linker_Options_Switches): Call For_All_Projects with + Imported_First set to True. + +2009-04-24 Ed Schonberg + + * sem_res.adb: additional optimization to inhibit creation of + redundant transient scopes. + +2009-04-24 Bob Duff + + * rtsfind.ads: Minor comment fix + +2009-04-24 Emmanuel Briot + + * prj-proc.adb, prj-nmsc.adb (Find_Ada_Sources, + Get_Path_Name_And_Record_Ada_Sources): merged, since these were + basically doing the same work (for explicit or implicit sources). + (Find_Explicit_Sources): renamed to Find_Sources to better reflect its + role. Rewritten to share some code (testing that all explicit sources + have been found) between ada_only and multi_language modes. + +2009-04-24 Jerome Lambourg + + * sem_prag.adb (Check_Form_Of_Interface_Name): Allow space in Ext_Name + for CLI imported types. + (Analyze_Pragma): Allow CIL or Java imported functions returning + access-to-subprogram types. + +2009-04-24 Emmanuel Briot + + * make.adb, prj.adb, prj.ads, makeutl.adb, makeutl.ads: + (Project_Data.Dir_Path): field removed, since it can be computed + directly from .Directory, and is needed only once when processing the + project is buildgpr.adb or make.adb + +2009-04-24 Robert Dewar + + * prj-env.adb, prj-proc.adb, prj.adb, prj.ads, + rtsfind.adb: Minor reformatting. + Minor code reorganization + +2009-04-24 Arnaud Charlet + + * mlib-prj.adb: Use friendlier english identifier. + + * gnatcmd.adb, make.adb: Use better english identifiers. + +2009-04-24 Robert Dewar + + * clean.adb: Minor reformatting + +2009-04-24 Robert Dewar + + * einfo.adb (OK_To_Rename): New flag + + * einfo.ads (OK_To_Rename): New flag + + * exp_ch3.adb (Expand_N_Object_Declaration): Rewrite as renames if + OK_To_Rename set. + + * exp_ch4.adb (Expand_Concatenate): Mark temp variable OK_To_Rename + + * sem_ch7.adb (Uninstall_Declarations): Allow for renames from + OK_To_Rename. + +2009-04-24 Emmanuel Briot + + * prj-proc.adb, make.adb, mlib-prj.adb, prj.adb, prj.ads, makeutl.adb, + clean.adb, prj-nmsc.adb, prj-env.adb, prj-env.ads (Project_Data.Seen): + field removed. This is not a property of the + project, just a boolean used to traverse the project tree, and storing + it in the structure prevents doing multiple traversal in parallel. + (Project_Data.Checked): also removed, since it was playing the same role + as Seen when we had two nested loops, and this is no longer necessary + (For_All_Imported_Projects): removed, since in fact there was already + the equivalent in For_Every_Project_Imported. The latter was rewritten + to use a local hash table instead of Project_Data.Seen + Various loops were rewritten to use For_Every_Project_Imported, thus + removing the need for Project_Data.Seen. This avoids a lot of code + duplication + +2009-04-24 Ed Schonberg + + * sem_res.adb (Resolve_Actuals): Do not create blocks around code + statements, even though the actual of the call is a concatenation, + because the argument is static, and we want to preserve warning + messages about sequences of code statements that are not marked + volatile. + + * sem_warn.adb: remove obsolete comment about warning being obsolete + + * s-tasren.adb (Task_Do_Or_Queue): If a timed entry call is being + requeued and the delay has expired while within the accept statement + that executes the requeue, do not perform the requeue and indicate that + the timed call has been aborted. + +2009-04-24 Emmanuel Briot + + * mlib-prj.adb, prj.adb, prj.ads, prj-nmsc.adb, prj-env.adb + (Has_Ada_Sources, Has_Foreign_Sources): new subprograms + (Project_Data.Ada_Sources_Present, Foreign_Sources_Present): removed, + since they can be computed from the above. + +2009-04-24 Vincent Celier + + * gnatcmd.adb: Call Prj.Env.Initialize with the Project_Tree + + * prj-env.adb: Move all global variables to the private part of the + project tree data. + Access these new components instead of the global variables no longer + in existence. + (Add_To_Path): New Project_Tree_Ref parameter, to access the new + components that were previously global variables. + + * prj-env.ads (Initialize): New Project_Tree_Ref parameter + (Set_Mapping_File_Initial_State_To_Empty): New Project_Tree_Ref + parameter. + + * prj-nmsc.adb (Compute_Unit_Name): New Project_Tree_Ref parameter to + be able to call Set_Mapping_File_Initial_State_To_Empty with it. + + * prj.adb (Initialize): Do not call Prj.Env.Initialize + (Reset): Do not call Prj.Env.Initialize. Instead, initialize the new + components in the private part of the project tree data. + + * prj.ads (Private_Project_Tree_Data): new components moved from + Prj.Env: Current_Source_Path_File, Current_Object_Path_File, + Ada_Path_Buffer, Ada_Path_Length, Ada_Prj_Include_File_Set, + Ada_Prj_Objects_File_Set, Fill_Mapping_File. + +2009-04-24 Vincent Celier + + * opt.ads (Unchecked_Shared_Lib_Imports): New Boolean flag. + + * prj-nmsc.adb (Check_Library): No error for imports by shared library + projects, when --unchecked-shared-lib-imports is used. + +2009-04-24 Robert Dewar + + * sem_ch7.adb: Minor reformatting + +2009-04-24 Tristan Gingold + + * s-osinte-darwin.adb, s-osinte-darwin.ads: lwp_self now returns the + mach thread id. + +2009-04-24 Emmanuel Briot + + * prj-env.adb, prj-env.ads (Body_Path_Name_Of, Spec_Path_Name_Of, + Path_Name_Of_Library_Unit_Body): rEmove unused subprograms. + (For_All_Imported_Projects): new procedure + (For_All_Source_Dirs, For_All_Object_Dirs): Rewritten based on the + above rather than duplicating code. + +2009-04-24 Emmanuel Briot + + * prj-proc.adb, prj.adb, prj.ads, prj-nmsc.adb, prj-env.adb + (Source_Id, Source_Data): use a real list to store sources rather than + using an external table to store the elements. This makes code more + efficient and more readable. + +2009-04-24 Emmanuel Briot + + * prj-proc.adb, prj.adb, prj.ads, prj-nmsc.adb, prj-env.adb + (Source_Iterator): new type. + This removes the need for having the sources on three different + lists at the project tree, project and language level. They are now + on a single list. + +2009-04-24 Emmanuel Briot + + * gnatcmd.adb, prj.adb, prj.ads: Remove unused entities + +2009-04-24 Ed Schonberg + + * sem_warn.adb: Add comment on obsolete warning + +2009-04-24 Arnaud Charlet + + * s-tassta.adb (Create_Task): Fix violation of locking rule. + +2009-04-24 Emmanuel Briot + + * prj.adb, prj.ads, prj-nmsc.adb, prj-env.adb (Language_Index): renamed + to Language_Ptr to better reflect its new implementation. + (Project_Data.First_Languages_Processing): renamed to Languages now + that the field with that name is no longer used + (Project_Data.Languages): removed, no longer used, and duplicates + information already available through First_Language_Processing. + (Prj.Language_Index): now an actual pointer, instead of an index into + a table. This makes the list somewhat more obvious, but more importantly + removes the need to pass a pointer to the project_tree_data in a few + places, and makes accessing the attributes of a languages more + efficient. + +2009-04-24 Richard Kenner + Thomas Quinot + + * fe.h (Set_Identifier_Casing): Add const to second parameter. + * gcc-interface/misc.c (internal_error_function): Make copy of return + from pp_formatted_text before assigning BUFFER to it. + (gnat_init): Likewise for main_input_filename and gnat_argv. + (gnat_printable_name): Remove cast from call to Set_Identifier_Casing. + +2009-04-24 Eric Botcazou + + * ttypes.ads (Target_Double_Float_Alignment): New variable. + (Target_Double_Scalar_Alignment): Likewise. + * get_targ.ads (Get_Strict_Alignment): Adjust external name. + (Get_Double_Float_Alignment): New imported function. + (Get_Double_Scalar_Alignment): Likewise. + * layout.adb (Set_Elem_Alignment): Take into account specific caps for + the alignment of "double" floating-point types and "double" or larger + scalar types, as parameterized by Target_Double_Float_Alignment and + Target_Double_Scalar_Alignment respectively. + * gcc-interface/gigi.h (double_float_alignment): Declare. + (double_scalar_alignment): Likewise. + (is_double_float_or_array): Likewise. + (is_double_scalar_or_array): Likewise. + (get_target_double_float_alignment): Likewise. + (get_target_double_scalar_alignment): Likewise. + * gcc-interface/targtyps.c (get_strict_alignment): Rename into... + (get_target_strict_alignment): ...this. + (get_target_double_float_alignment): New function. + (get_target_double_scalar_alignment): Likewise. + * gcc-interface/decl.c (gnat_to_gnu_entity) : + Test the presence of an alignment clause for under-aligned integer + types. Take into account specific caps for the alignment of "double" + floating-point types and "double" or larger scalar types, as + parameterized by Target_Double_Float_Alignment and + Target_Double_Scalar_Alignment respectively. + (validate_alignment): Likewise. + * gcc-interface/trans.c (Attribute_to_gnu) : Likewise. + (gigi): Initialize double_float_alignment and double_scalar_alignment. + * gcc-interface/utils.c (double_float_alignment): New global variable. + (double_scalar_alignment): Likewise. + (is_double_float_or_array): New predicate. + (is_double_scalar_or_array): Likewise. + +2009-04-24 Eric Botcazou + + * gcc-interface/utils2.c (build_cond_expr): Move SAVE_EXPR ahead of + the conditional expression only if it is common to both arms. + +2009-04-24 Eric Botcazou + + * gcc-interface/gigi.h (build_call_alloc_dealloc): Update comment. + * gcc-interface/decl.c (gnat_to_gnu_entity) : Pass correct + arguments to build_allocator. + * gcc-interface/utils2.c (build_call_alloc_dealloc): Update comment. + Remove code handling special allocator and assert its uselessness. + +2009-04-24 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : If an + alignment is specified, do not promote that of the component type + beyond it. + : Likewise. + +2009-04-23 Eric Botcazou + + * einfo.ads (Is_True_Constant): Lift restriction on atomic objects. + * sinfo.ads (Object Declaration): Likewise. + (Assignment Statement): Likewise. + * freeze.adb (Expand_Atomic_Aggregate): Remove useless test. + Do not force Is_True_Constant to false on the temporary. + (Freeze_Entity): Do not force Is_True_Constant to false on names on + the RHS of object declarations. + * gcc-interface/trans.c (lvalue_required_p) : + New case. Return 1 if the object is atomic. + : Likewise. + +2009-04-23 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) + For packed array types, make the original array type a parallel type + for the modular type and its JM wrapper if the type is bit-packed. + : Likewise. Do not generate the special XA parallel + record type for packed array types. Remove kludge. + +2009-04-23 Eric Botcazou + + * gcc-interface/gigi.h (create_index_type): Adjust head comment. + * gcc-interface/decl.c (gnat_to_gnu_entity) : + Use front-end predicates to compute signedness and precision. + : Fold range type. + Make sure to set longest_float_type_node to a scalar type. + (elaborate_entity): Use consistent Constraint_Error spelling. + (substitute_in_type) : Always copy the type. + * gcc-interface/misc.c (gnat_print_type) : Use brief + output for the modulus, if any. + : Likewise for the RM size. + * gcc-interface/trans.c (gnat_to_gnu): Use consistent Constraint_Error + spelling. + * gcc-interface/utils.c (finish_record_type): Really test the alignment + of BLKmode bit-fields to compute their addressability. + (create_index_type): Adjust comments. + (create_param_decl): Create the biased subtype manually. + * gcc-interface/utils2.c (build_component_ref): Use consistent + Constraint_Error spelling. + +2009-04-23 Eric Botcazou + + * gcc-interface/cuintp.c: Clean up include directives. + * gcc-interface/targtyps.c: Likewise. + * gcc-interface/decl.c: Likewise. + * gcc-interface/misc.c: Likewise. + * gcc-interface/trans.c: Likewise. + * gcc-interface/utils.c: Likewise. + * gcc-interface/utils2.c: Likewise. + * gcc-interface/Make-lang.in: Adjust dependencies accordingly. + +2009-04-23 Eric Botcazou + + * gcc-interface/ada-tree.h (union lang_tree_node): Use standard idiom. + (SET_TYPE_LANG_SPECIFIC): Likewise. Fix formatting. + (SET_DECL_LANG_SPECIFIC): Likewise. + Reorder macros. + * gcc-interface/decl.c (gnat_to_gnu_entity) : + Update comment about use of build_range_type. + : Use consistent naming convention. + : Rework comments about TYPE_ACTUAL_BOUNDS and add + check for other cases of overloading. + * gcc-interface/trans.c (gigi): Use size_int in lieu of build_int_cst. + * gcc-interface/utils2.c (build_call_raise): Fix off-by-one error. + Use size_int in lieu of build_int_cst. + (build_call_alloc_dealloc): Use build_index_2_type in lieu of + build_range_type. + +2009-04-22 Eric Botcazou + + * gcc-interface/utils2.c (build_binary_op) : If operation's + type is an enumeral or a boolean type, change it to an integer type + with the same mode and signedness. + +2009-04-22 Eric Botcazou + + * gcc-interface/utils.c (create_var_decl_1): Do not emit debug info + for an external constant whose initializer is not absolute. + +2009-04-22 Taras Glek + + * gcc-interface/ada-tree.h: Update GTY annotations to new syntax. + * gcc-interface/trans.c: Likewise. + * gcc-interface/utils.c: Likewise. + +2009-04-22 Ed Schonberg + + * sem_res.adb: Create block around procedure call when actual is a + concatenation. + +2009-04-22 Thomas Quinot + + * s-soflin.ads: Fix typos + +2009-04-22 Vincent Celier + + * prj-env.adb: Minor comment change + + * prj-nmsc.adb (Check_Common): Add guard to avoid calling + Get_Name_String with No_File. + + * tempdir.adb (Create_Temp_File): Output diagnostic when temp file + cannot be created even when not in verbose mode. + +2009-04-22 Emmanuel Briot + + * make.adb, prj-env.adb, prj-env.ads, prj-nmsc.adb, prj.adb, + prj.ads (Create_Mapping_File): merge the two versions for Ada_Only and + Multi_Language modes, to avoid code duplication. + (Project_Data.Include_Language): Removed. + +2009-04-22 Vincent Celier + + * tempdir.adb (Create_Temp_File): Add a diagnostic in verbose mode when + the temporary file cannot be created, indicating the directory when the + creation was attempted. + +2009-04-22 Emmanuel Briot + + * prj-env.adb, prj-env.ads (Create_Mapping_File): we need to compare + the language names, not their indices. + +2009-04-22 Emmanuel Briot + + * prj.ads, prj-nmsc.adb, prj-env.adb, prj-env.ads + (Source_Data.Language_Name): Field removed. + +2009-04-22 Emmanuel Briot + + * prj.adb, prj.ads, prj-nmsc.adb (Project_Data.Unit_Based_Language_*): + Two fields removed. + +2009-04-22 Emmanuel Briot + + * prj-nmsc.adb (Check_Naming_Ada_Only): Properly initialize the + separate_suffix to the same value as the body_suffix. + +2009-04-22 Robert Dewar + + * prj.adb: Minor code reorganization + Code clean up. + + * prj-proc.adb: Minor code reorganization, clean up. + + * prj-nmsc.adb: Minor reformatting + Minor code reorganization + + * gnat_ugn.texi: Add to doc on strict aliasing + +2009-04-22 Pascal Obry + + * s-osinte-mingw.ads: Rename Reserved field in CRITICAL_SECTION to + SpinCount. + + * s-tasini.adb: Minor reformatting. + + * s-tassta.adb: Minor reformatting. + +2009-04-22 Emmanuel Briot + + * prj-proc.adb, prj-nmsc.adb (Check_Naming_Schemes): split into several + smaller subprograms. + Renamed to Check_File_Naming_Schemes to avoid confusion with the + other Check_Naming_Schemes functions that plays a totally different + role. + (Check_Unit_Based_Lang, Check_File_Based_Lang): new subprograms, + extracted from the above. These were partially rewritten to avoid + unnecessary code and temporary variables. + (Compute_Unit_Name): new subprogram, merge of Check_Unit_Based_Lang + and Get_Unit (which for now still exist since they contain mode-specific + code) + +2009-04-22 Emmanuel Briot + + * prj.ads, prj.adb, prj-nmsc.adb, prj-proc.adb (Recursive_Process): + Remove duplicated code. + (Canonical_Case_File_Name): new subprogram + (Check_And_Normalize_Unit_Names): new subprogram + (Write_Attr): new subprogram + Better sharing of code + (Check_Naming_Ada_Only, Check_Naming_Multi_Lang): new subprogram, to + split Check_Naming and help find duplicated code + (Check_Common): new subprogram, sharing code between ada_only and + multi_language mode. + (Naming_Data.Dot_Repl_Loc): field removed + +2009-04-22 Emmanuel Briot + + * prj-proc.adb, prj-nmsc.adb (Load_Naming_Exceptions): New subprogram. + Minor refactoring to reduce the size of + Process_Sources_In_Multi_Language_Mode. + Avoid extra copied of Source_Data, which we found in the past could be + quite slow. + (Mark_Excluded_Sources): new subprogram. + (Remove_Locally_Removed_Files_From_Units): merged into the above + Refactors Process_Sources_In_Multi_Language_Mode to reduce its size, + and allow better sharing of code between multi_lang and ada_only modes + (Project_Extends): removed, since exact duplicate of Prj.Is_Extending + +2009-04-22 Emmanuel Briot + + * prj-proc.adb, prj.adb, prj.ads (Project_Data.First_Referred_By): + Removed, since unused. + +2009-04-22 Vincent Celier + + * prj-attr.adb: New single project level attribute + Separate_Run_Path_Options. + + * prj-nmsc.adb (Process_Project_Level_Simple_Attributes): Process + attribute Seperate_Run_Path_Options. + + * prj.ads: (Project_Configuration): New Boolean component + Separate_Run_Path_Options, defaulted to False. + + * snames.ads-tmpl: New standard name Seperate_Run_Path_Options + +2009-04-22 Robert Dewar + + * sem_type.adb: Minor reformatting + + * mlib.adb: Minor reformatting + + * sem_aggr.adb: Minor reformatting. Defend against junk aggregate from + syntax error. + +2009-04-22 Nicolas Setton + + * link.c: Add flag __gnat_separate_run_path_options. + + * mlib.adb (Separate_Run_Path_Options): New subprogram. + + * mlib.ads (Separate_Run_Path_Options): Declare. + + * gnatcmd.adb (Process_Link): Add support for emitting one "rpath" + switch per directory, rather than one "rpath" switch listing all + directories. + + * gnatlink.adb (Process_Binder_File): Likewise. + + * make.adb (Gnatmake): Likewise. + +2009-04-22 Hristian Kirtchev + + * exp_ch6.adb (Make_Build_In_Place_Call_In_Assignment): Code cleanup. + Add a call to Move_Final_List when the target of the assignment is a + return object that needs finalization and the expression is a + controlled build-in-place function. + +2009-04-22 Vincent Celier + + * make.adb (Gnatmake, Bind_Step): call Set_Ada_Paths with + Including_Libraries set to True. + +2009-04-22 Ed Schonberg + + * lib-load.ads, lib-load.adb (Make_Child_Decl_Unit): New subprogram, to + create a unit table entry for the subprogram declaration created for a + child suprogram body that has no separate specification. + + * sem_ch10.adb (Analyze_Compilation_Unit): For a child unit that is a + subprogram body, call Make_Child_Decl_Unit. + + * lib.adb (Get_Cunit_Unit_Number): Verify that an entry not yet in the + table can only be the created specification of a child subprogram body + that is the main unit, which has not been entered in the table yet. + + * errout.adb (Output_Messages): Ignore created specification of a + child subprogram body to prevent repeated listing of error messages. + + * gnat1drv.adb (gnat1drv): The generated specification for a child + subprogram body does not generate code. + +2009-04-22 Arnaud Charlet + + * s-bitops.adb, s-bitops.ads (Raise_Error): Do not use Ada 05 syntax, + since this unit is now part of bootstrap units, so must use Ada 95 + syntax only. + +2009-04-22 Thomas Quinot + + * a-tasatt.adb: Minor reformatting + +2009-04-22 Bob Duff + + * s-stalib.ads: Remove "with System;" since we're inside System, so + it's unnecessary. + +2009-04-22 Vincent Celier + + * prj-nmsc.adb (Add_Source): Always put the dependency file name in + the source record, as there may be a dependency file even if no object + file is created. + +2009-04-22 Robert Dewar + + * lib-load.adb: Minor reformatting + + * lib-load.ads: Minor reformatting + + * sinfo.ads: Minor reformatting + +2009-04-22 Bob Duff + + * exp_pakd.adb: Minor comment fixes. + + * sinfo.ads, par-load.adb, sem_ch10.adb, lib-load.ads, lib-load.adb + sem_ch12.adb: Change the meaning of the Library_Unit attribute to + include units containing instantiations, as well as units that are + generic instantiations. + + * sem.adb: Include dependents and corresponding specs/bodies in the + unit walk. + + * gcc-interface/Make-lang.in: + sem now depends on s-bitops, because of the packed array of Booleans. + +2009-04-22 Eric Botcazou + + * gcc-interface/ada-tree.def: Fix formatting nits. + (REGION_STMT): Delete. + (HANDLER_STMT): Likewise. + * gcc-interface/ada-tree.h: Fix formatting nits. + (IS_STMT): Delete. + (REGION_STMT_BODY): Likewise. + (REGION_STMT_HANDLE): Likewise. + (REGION_STMT_BLOCK): Likewise. + (HANDLER_STMT_ARG): Likewise. + (HANDLER_STMT_LIST): Likewise. + (HANDLER_STMT_BLOCK): Likewise. + * gcc-interface/gigi.h (fp_prec_to_size): Update comment. + (fp_size_to_prec): Likewise. + (largest_move_alignment): Delete. + (gnat_compute_largest_alignment): Likewise. + Fix minor nits. + * gcc-interface/decl.c (gnat_to_gnu_entity) : + Remove redundant code. + : Remove redundant assert. + : Exit early from index computation in pathological + cases. + Rewrite conditional assignment. + (make_type_from_size): Likewise. + * gcc-interface/misc.c (largest_move_alignment): Delete. + (gnat_finish_incomplete_decl): Likewise. + (LANG_HOOKS_FINISH_INCOMPLETE_DECL): Likewise. + (asm_out_file): Likewise + (gnat_print_type) : Fall through to ENUMERAL_TYPE case. + (gnat_dwarf_name): Move around. + * gcc-interface/trans.c (Attribute_to_gnu): Fix minor nits. + (gigi): Remove call to gnat_compute_largest_alignment. + * utils.c (create_field_decl): Rewrite conditional assignment. + Fix minor nits. + +2009-04-22 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity): Compute is_type predicate + on entry. Defer common processing for types. Reorder and clean up. + Compute the equivalent GNAT node and the default size for types only. + : Directly use Esize for the type's precision. + : For an unconstrained designated type, do not pretend + that a dummy type is always made. + Fix nits in comments. + (validate_size): Fix formatting nits and comments. + (set_rm_size): Likewise. + * gcc-interface/utils.c (create_param_decl): Replace bogus argument + passed to TARGET_PROMOTE_PROTOTYPES hook. + +2009-04-22 Eric Botcazou + + * fe.h (Get_External_Name): Declare. + * gcc-interface/gigi.h (concat_id_with_name): Rename to... + (concat_name): ...this. + * gcc-interface/decl.c (gnat_to_gnu_entity): Rename gnu_entity_id to + gnu_entity_name and adjust for above renaming. + : Use create_concat_name to get the name of the various + types associated with unconstrained array types. + (make_aligning_type): Adjust for above renaming. + (maybe_pad_type): Likewise. + (components_to_record): Likewise. Use get_identifier_with_length for + the encoding of the variant. + (get_entity_name): Use get_identifier_with_length. + (create_concat_name): Likewise. Use Get_External_Name if no suffix. + Do not fiddle with Name_Buffer. + (concat_id_with_name): Rename to... + (concat_name): ...this. Use get_identifier_with_length. Do not fiddle + with Name_Buffer. + * gcc-interface/utils.c (rest_of_record_type_compilation): Adjust for + above renaming. + +2009-04-21 Joseph Myers + + * ChangeLog, ChangeLog.ptr, ChangeLog.tree-ssa: Add copyright and + license notices. + +2009-04-21 Eric Botcazou + + * gcc-interface/trans.c (gnat_to_gnu): Do not overwrite location info. + +2009-04-21 Eric Botcazou + + * gcc-interface/ada-tree.h (TYPE_RM_SIZE_NUM): Delete. + (TYPE_RM_SIZE): Access TYPE_LANG_SLOT_1 directly for integral types. + * gcc-interface/decl.c (gnat_to_gnu_entity) : + Remove useless support code for packed array types and assert its + uselessness. + : Reuse entity identifier in more places and + adjust for TYPE_RM_SIZE change. + Fix nits in comments. Use Original_Array_Type accessor instead + of Associated_Node_For_Itype accessor for packed array types. + (make_packable_type): Likewise. + (maybe_pad_type): Likewise. + (set_rm_size): Likewise. Rework conditional statement. Adjust for + TYPE_RM_SIZE change. + (make_type_from_size): Adjust for TYPE_RM_SIZE change. + (rm_size): Fix nits in comments. Rework conditional statements. + * gcc-interface/misc.c (gnat_print_type): Adjust for TYPE_RM_SIZE + change. + * gcc-interface/trans.c (Attribute_to_gnu): Fix nits in comments. + * gcc-interface/utils.c (gnat_init_decl_processing): Use more + appropriate function to initialize the size_type_node. Adjust for + TYPE_RM_SIZE change. + +2009-04-21 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity): Do not set force_global + for imported subprograms. + +2009-04-21 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Do not make + constant objects covered by 13.3(19) volatile. + +2009-04-21 Eric Botcazou + + * gcc-interface/utils.c (create_type_decl): Do not pass declarations + of dummy fat pointer types to the debug back-end. + +2009-04-20 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity): Rewrite Esize calculation. + : Set the RM size on the integer type + before wrapping it up in the record type. Do not overwrite the + Ada size of the record type with the Esize. + +2009-04-20 Eric Botcazou + + * gcc-interface/trans.c (unchecked_conversion_lhs_nop): New predicate. + (gnat_to_gnu) : Return the expression + if the conversion is on the LHS of an assignment and a no-op. + Do not convert the result to the result type if the Parent + node is such a conversion. + +2009-04-20 Eric Botcazou + + * gcc-interface/ada-tree.h (DECL_HAS_REP_P): Delete. + * gcc-interface/decl.c (gnat_to_gnu_entity): Add support for extension + of types with unknown discriminants. + (substitute_in_type): Rewrite and restrict to formal substitutions. + * gcc-interface/utils.c (create_field_decl): Do not set DECL_HAS_REP_P. + (update_pointer_to): Update comment. + +2009-04-20 Ed Schonberg + + * sem_ch8.adb (Use_One_Package): In an instance, if two + potentially_use_visible and non-overloadable homonyms are available + from the actuals of distinct formal packages, retain the current one, + which was visible in the generic, to prevent spurious visibility + errors. + (End_Use_Package): Restore use_visibility when needed. + +2009-04-20 Sergey Rybin + + * gnat_ugn.texi, vms_data.ads: Update doc. + +2009-04-20 Arnaud Charlet + + * gcc-interface/Make-lang.in: Update dependencies + + * gcc-interface/Makefile.in: Link run-time against winsock2 lib under + Windows. + +2009-04-20 Robert Dewar + + * checks.ads: Fix documentation of range check handling + +2009-04-20 Ed Schonberg + + * sem_ch8.adb (Use_One_Type): Use proper entity on warning message for + a redundant use_type clause. + +2009-04-20 Robert Dewar + + * sem_attr.adb (Eval_Attribute, case Length): Catch more cases where + this attribute can be evaluated at compile time. + (Eval_Attribute, case Range_Length): Same improvement + + * sem_eval.ads, sem_eval.adb (Compile_Time_Compare): New procedure + +2009-04-20 Ed Schonberg + + * sem_ch6.adb (Analye_Subprogram_Declaration): Code reorganization, + for better handling of null procedures. + (Check_Overriding_Indicator): Do not emit a warning on a missing + overriding indicator on an operator when the type of which the operator + is a primitive is private. + +2009-04-20 Bob Duff + + * sem.adb, gnat1drv.adb, debug.adb: Use the -gnatd.W switch to control + debugging output. + +2009-04-20 Robert Dewar + + * sem_attr.adb: Minor reformatting + + * gnatcmd.adb: Minor reformatting + +2009-04-20 Ed Schonberg + + * sem_ch4.adb (Analyze_User_Defined_Binary_Op): If left operand is + overloaded and one interpretation matches the context, label the + operand with the type of first formal. + +2009-04-20 Bob Duff + + * debug.ads: Minor comment fix. + + * debug.adb: Minor comment fixes. + +2009-04-20 Javier Miranda + + * rtsfind.ads (RE_Null_Id): New entity of package Ada.Exceptions + + * exp_ch6.adb (Expand_Inlined_Call): Undo previous patch. + + * exp_ch11.adb (Expand_N_Raise_Statement): When the raise stmt + is expanded into a call to Raise_Exception, avoid passing the + exception-name'identity in runtimes in which this argument + is not used. + +2009-04-20 Jerome Lambourg + + * impunit.adb: Add i-cil and i-cilobj packages, now needed by the + generated bindings for cil. + +2009-04-20 Ed Schonberg + + * sem_aggr.adb (Resolve_Record_Aggregate): If the type has unknown + discriminants, collect components from the Underlying_Record_View, + which will be used in the expansion of the aggregate into assignments. + + * sem_ch3.adb: Do not label derived type with unknown discriminants as + having a private declaration. + +2009-04-20 Ed Schonberg + + * exp_util.adb (Expand_Subtype_From_Expr): use the + underlying_record_view when available, to create the proper constrained + subtype for an object of a derived type with unknown discriminants. + +2009-04-20 Javier Miranda + + * exp_ch6.adb (Expand_Inlined_Call): Avoid generation of temporaries for + formals that have pragma unreferenced. + +2009-04-20 Pascal Obry + + * a-direct.adb (To_Lower_If_Case_Insensitive): Removed. + Remove all calls to To_Lower_If_Case_Insensitive to preserve + the pathname original casing. + +2009-04-20 Robert Dewar + + * g-trasym.adb: Minor reformatting + + * s-os_lib.adb: Minor reformatting + + * sem.adb: Minor reformatting + Minor code reorganization + + * sem_ch3.adb: Minor reformatting + + * sem_ch4.adb: Minor reformatting + + * sem_ch8.adb: Minor reformatting + + * sem_type.adb: Minor reformatting + +2009-04-20 Javier Miranda + + * sem_disp.adb (Find_Dispatching_Type): For subprograms internally + generated by derivations of tagged types use the aliased subprogram a + reference to locate their controlling type. + +2009-04-20 Tristan Gingold + + * g-trasym.adb: Set size of result buffer before calling + convert_address. + +2009-04-20 Ed Schonberg + + * sem_ch4.adb (Valid_Candidate): When checking whether a prefixed call + to a function returning an array can be interpreted as a call with + defaulted parameters whose result is indexed, take into account the + types of all the indices of the array result type. + +2009-04-20 Pascal Obry + + * a-direct.adb, s-os_lib.adb: Minor reformatting. + +2009-04-20 Ed Schonberg + + * sem_ch8.adb (Analyze_Object_Renaming): Proper checks on incorrect + null exclusion qualifiers for object renaming declarations. + +2009-04-20 Nicolas Roche + + * sysdep.c (__gnat_localtime_tzoff): on Windows, manipulated times are + unsigned long long. So compare local_time and utc_time before computing + the difference. + +2009-04-20 Eric Botcazou + + * sem_ch3.adb (Build_Derived_Private_Type): Insert the declaration + of the Underlying_Record_View before that of the derived type. + + * exp_ch3.adb (Expand_Record_Extension): Do not special-case types + with unknown discriminants with regard to the parent subtype. + +2009-04-20 Bob Duff + + * sem.adb (Semantics, Walk_Library_Items): Include dependents of bodies + that are not included. This is necessary if the main unit is a generic + instantiation. + + * gnat1drv.adb (Gnat1drv): Comment out the call to Check_Library_Items, + because it doesn't work if -gnatn is used. + +2009-04-20 Ed Schonberg + + * rtsfind.adb (RTE, RTE_Record_Component): In + Configurable_Run_Time_Mode, do not enable front-end inlining. + +2009-04-20 Thomas Quinot + + * g-socthi-vms.adb: Remove now unnecessary WITH clause on + System.Address_To_Access_Conversions. + +2009-04-20 Ed Schonberg + + * sem.adb: Guard against ill-formed subunits. + +2009-04-20 Bob Duff + + * output.adb (Flush_Buffer): Do not indent blank lines. + (Ignore_Output): New procedure for output suppression. + +2009-04-20 Hristian Kirtchev + + * a-calfor.adb (Image): Subtract 0.5 from the sub second component only + when it is positive. This avoids a potential constraint error raised + by the conversion to Natural. + +2009-04-20 Gary Dismukes + + * exp_ch5.adb (Expand_Assign_Array): For the case where the assignment + involves a target that has a specified address, don't set Forward_OK + and Backward_OK to False if the rhs is an aggregate, since overlap + can't occur. + +2009-04-20 Ed Schonberg + + * sem_ch8.adb (Analyze_Object_Renaming): Reject ambiguous expressions + in an object renaming declaration when the expected type is an + anonymous access type. + + * sem_type.adb (Disambiguate): Use anonymousness to resolve a potential + ambiguity when one interpretation is an anonymous access type and the + other is a named access type, and the context itself is anonymous + +2009-04-20 Thomas Quinot + + * einfo.ads: Minor comment rewording + + * sem_aggr.adb: Minor comment rewording + + * sem_ch3.adb, sem_ch6.adb: Minor reformatting + +2009-04-20 Pascal Obry + + * adaint.c (__gnat_is_readable_file): Check for file existence + when not using ACL (always the case on remote drives). + +2009-04-20 Robert Dewar + + * sinfo.ads: Minor comment fixes + + * exp_disp.adb: Minor reformatting + + * gnat1drv.adb: Minor reformatting + + * output.adb: Minor reformatting + + * s-vxwext-kernel.ads: Minor reformatting + + * sem.ads: Minor reformatting + + * sem.adb: Minor reformatting + + * sem_elim.adb: Minor reformatting + + * uname.ads: Minor reformatting + +2009-04-20 Eric Botcazou + + * init.c (__gnat_adjust_context_for_raise): On x86{-64}/Linux, add + a small dope of 4 words to the adjustment to the stack pointer. + +2009-04-20 Thomas Quinot + + * xoscons.adb: generate C header s-oscons.h in + addition to s-oscons.ads. + + * socket.c: On VMS, use s-oscons.h. + + * sem_ch3.adb: Minor reformatting + + * exp_ch9.adb: Minor reformatting + +2009-04-20 Eric Botcazou + + * gcc-interface/trans.c (check_for_eliminated_entity): Remove. + (Attribute_to_gnu): Do not call check_for_eliminated_entity. + (call_to_gnu): Likewise. + +2009-04-20 Eric Botcazou + + * gcc-interface/trans.c (gigi): Declare the name of the compilation + unit as the first global name at the very beginning. + +2009-04-20 Thomas Quinot + + * socket.c, g-socthi-vms.adb, g-socthi-vms.ads, g-socthi-vxworks.ads, + s-oscons-tmplt.c, gsocket.h, g-socthi-mingw.ads, g-socthi.ads, + g-sothco.ads (__gnat_inet_pton): Needs to be enabled for HP-UX as well, + since HP-UX supports neither inet_aton nor inet_pton (altough the + latter is part of the Single UNIX Specification!). + So reorganize code, and share C implementation based on inet_addr(3) + with VMS (instead of having a VMS specific Ada implementation in + g-socthi-vms.adb). + +2009-04-20 Gary Dismukes + + * osint-c.ads, osint-c.adb (Get_Object_Output_File_Name): New function + to return the object file name saved by Set_Object_Output_File_Name. + +2009-04-20 Emmanuel Briot + + * g-comlin.adb (Initialize_Option_Scan): Fix initialization of parsers + for the standard command line, when argc has been modified since the + start of the application. + +2009-04-20 Thomas Quinot + + * socket.c (__gnat_inet_pton, Windows case): Adjust return value. + WSAStringToAddress returns 0 for success and SOCKET_ERROR for failure. + +2009-04-20 Bob Duff + + * gnat1drv.adb (Gnat1drv): Put call to Check_Library_Items inside + pragma Debug. + +2009-04-20 Ed Schonberg + + * exp_ch9.adb (Build_Protected_Sub_Specification): Mark generated + subprogram as Eliminated when source operation is. + (Expand_N_Protected_Type_Declaration): Generate protected and + unprotected specs for the internal operations, even if the source + operation is eliminated. + +2009-04-20 Hristian Kirtchev + + * exp_ch3.adb (Make_Predefined_Primitive_Specs, + Predefined_Primitive_Bodies): Do not create the declarations and bodies + of the primitive subprograms associated with dispatching select + statements when the runtime is in configurable mode. + +2009-04-20 Ed Falis + + * s-vxwext-kernel.ads (tickGet): Use tick64Get. + +2009-04-20 Thomas Quinot + + * s-oscons-tmplt.c: Add support for generating a dummy version of + s-oscons.ads providing all possible constants. + + * g-socthi-mingw.ads: Fix calling convention for __gnat_inet_pton. + + * socket.c (__gnat_inet_pton): On Windows make sure we always use the + ANSI version (not the UNICODE version) of WSAStringToAddress. + +2009-04-20 Pascal Obry + + * adaint.c (__gnat_set_OWNER_ACL): properly free memory + allocated for the security descriptor and make sure all + handles are closed before leaving this procedure. + +2009-04-20 Javier Miranda + + * einfo.ads, einfo.adb (Is_Underlying_Record_View): New subprogram + (Set_Is_Underlying_Record_View): New subprogram + + * sem_aggr.adb (Discr_Present, Resolve_Record_Aggregate): In case of + private types with unknown discriminants use the underlying record view + if available. + + * sem_ch3.adb (Build_Derived_Private_Type): Enable construction of the + underlying record view in the full view of private types whose parent + has unknown discriminants. + (Build_Derived_Record_Type): Avoid generating the class-wide entity + associated with an underlying record view. + (Derived_Type_Declaration): Avoid deriving parent primitives in + underlying record views. + + * sem_ch6.adb (Check_Return_Subtype_Indication): Add support for + records with unknown discriminants. + + * sem_type.adb (Covers): Handle underlying record views. + (Is_Ancestor): Add support for underlying record views. + + * exp_attr.adb (Expand_Attribute): Expand attribute 'size into a + dispatching call if the type of the target object is tagged and has + unknown discriminants. + + * exp_aggr.adb (Resolve_Record_Aggregate): Add support for records with + unknown discriminants. + + * exp_disp.adb (Build_Dispatch_Tables): Avoid generating dispatch + tables for internally built underlying record views. + + * sprint.adb (sprint_node_actual): Improve output of aggregates with an + empty list of component associations. + +2009-04-20 Thomas Quinot + + * sem_ch10.adb: Minor reformatting + + * socket.c, g-socthi-vms.adb, g-socthi-vms.ads, g-socthi-vxworks.ads, + g-socthi-mingw.ads, g-socthi.ads, g-socket.adb + (GNAT.Sockets.Inet_Addr): Do not use non-portable inet_aton, instead use + standard inet_pton API (and emulate it on platforms that do not + support it). + (GNAT.Sockets.Thin.Inet_Pton, VMS case): Implement in terms of + DECC$INET_ADDR, imported in Ada. + (GNAT.Sockets.Thin.Inet_Pton, VxWorks and Windows cases): Use C + implementation provided by GNAT runtime. + (__gnat_inet_pton): C implementation of inet_pton(3) for VxWorks and + Windows. + +2009-04-20 Eric Botcazou + + * gnat_ugn.texi: Add documentation for -fno-ivopts. + +2009-04-20 Ed Schonberg + + * sem_ch10.adb (Analyze_Context): Do not analyze a unit in a + with_clause if it is the main unit. + +2009-04-20 Thomas Quinot + + * sem_type.adb, ali.adb, erroutc.adb: Minor code reorganization + (no behaviour change): Use Append instead of Increment_Last followed + by assignment. + +2009-04-20 Hristian Kirtchev + + * exp_ch3.adb (Make_Predefined_Primitive_Specs): Do not generate the + declarations of all primitives associated with dispatching asynchronous, + conditional and timed selects when dispaching calls are forbidden and + select statements are not allowed (such as in Ravenscar). + (Predefined_Primitive_Bodies): Ditto for bodies. + + * exp_disp.ad (Make_DT): Do not create and populate the + Select_Specific_Data of the dispatch table when dispatching calls are + forbidden and select statements are not allowed (such as in Ravenscar). + +2009-04-20 Robert Dewar + + * a-tifiio.adb: Minor reformatting + +2009-04-20 Thomas Quinot + + * g-socthi-vms.adb, g-socket.adb, g-socket.ads: inet_aton(3), unlike + other C library functions, report *failure* with a zero status, and + success with a non-zero status. + +2009-04-20 Bob Duff + + * sem.ads, sem.adb (Walk_Library_Items): New generic procedure. + (Semantics): After analyzing each unit, Append it to the + Comp_Unit_List, if appropriate. + + * gnat1drv.adb (Check_Library_Items): New procedure for debugging + purposes. + (Gnat1drv): Correct comment regarding Back_End_Mode. + +2009-04-20 Eric Botcazou + + * gnat_ugn.texi: Add documentation for -fno-inline-small-functions. + +2009-04-20 Thomas Quinot + + * s-taprop-irix.adb, s-taprop-tru64.adb, s-taprop-vms.adb, + output.adb, output.ads, s-taprop-hpux-dce.adb, + s-taprop-linux.adb, s-taprop-solaris.adb, s-taprop-posix.adb: Minor + reformatting. + +2009-04-20 Thomas Quinot + + * g-socket.adb, g-socket.ads, g-socthi-mingw.ads, g-socthi-vms.adb, + g-socthi-vms.ads, g-socthi-vxworks.ads, g-socthi.ads + (GNAT.Sockets.Thin.C_Inet_Addr): Remove. + (GNAT.Sockets.Thin.Inet_Aton): New function, imported from C library + except for VMS where it is reimplemented in Ada using DECC$INET_ADDR. + (GNAT.Sockets.Inet_Addr): Use inet_aton(3) instead of inet_addr(3). + + * debug.adb: Fix typo + + * gnat_rm.texi: Minor doc fix. + + * sem_ch7.adb, freeze.adb: Minor reformatting + +2009-04-20 Thomas Quinot + + * g-socket.ads: Add new constants: + Loopback_Inet_Addr + Unspecified_Group_Inet_Addr + All_Hosts_Group_Inet_Addr + All_Routers_Group_Inet_Addr + + * s-oscons-tmplt.c, g-sttsne-vxworks.adb (System.OS_Constants): Add + ERANGE (Result too large). + (GNAT.Sockets.Thin.Task_Safe_NetDB, VxWorks version): Add missing + propagation of errno to caller. + +2009-04-20 Hristian Kirtchev + + * a-calend.adb, a-calend-vms.adb: Increase the number of leap seconds + to 24. Increment Leap_Seconds_Count and add an entry to aggregate + Leap_Second_Times. + +2009-04-20 Gary Dismukes + + * sem_elim.ads (Check_For_Eliminated_Subprogram): New procedure for + checking for references to eliminated subprograms that should be + flagged. + (Eliminate_Error_Message): Update comment to say "references" rather + than "calls" (since attribute cases are handled here as well). + + * sem_elim.adb (Check_For_Eliminated_Subprogram): New procedure for + checking for references to eliminated subprograms that should be + flagged. Add with and use of Sem and Sem_Util. + + * sem_res.adb (Resolve_Call): Reject calls to eliminated subprograms. + Add with and use of Sem_Elim. + + * sem_attr.adb (Analyze_Access_Attribute): Reject access attributes + applied to eliminated subprograms. + (Analyze_Attribute): Reject 'Address and 'Code_Address applied to + eliminated subprograms. + Add with and use of Sem_Elim. + + * sem_disp.adb (Check_Dispatching_Call): Remove error check for calls + to eliminated subprograms, now handled during Resolve_Call. + Remove with and use of Sem_Elim. + + * exp_disp.adb (Make_DT): Get Ultimate_Alias of primitive before + testing Is_Eliminated, for proper handling of primitive derived from + eliminated subprograms. + +2009-04-20 Vincent Celier + + * mlib-prj.adb (Build_Library): Use the shared library linker, if one + has been declared (Library_GCC or Linker'Driver), for the driver name. + + * prj-nmsc.adb (Process_Linker): If Library_GCC is not declared and + Linker'Driver is, use Linker'Driver as the shared library linker. + (Process_Project_Level_Simple_Attributes): Issue a warning if attribute + Library_GCC is declared. + (Check_Library_Attributes): Set up the shared linker driver: either + Library_GCC or Linker'Driver. Issue a warning if Library_GCC is + declared. + +2009-04-20 Thomas Quinot + + * g-socket.ads (Send_Socket): Fix misleading comment. + +2009-04-20 Arnaud Charlet + + * switch-c.adb (Scan_Front_End_Switches): Disable inspector mode in + ASIS mode. + +2009-04-20 Geert Bosch + + * a-tifiio.adb (Put): Avoid generating too many digits for certain + fixed types with smalls that are neither integer or the reciprocal + of an integer. + +2009-04-20 Bob Duff + + * uname.ads: Minor comment fix. + + * types.ads: Minor comment fix. + +2009-04-20 Pascal Obry + + * adaint.c (__gnat_get_libraries_from_registry): Fix code to + avoid warning. At the same time fix a memory leak. + + * osint.adb (Get_Libraries_From_Registry): Properly free memory + returned by the above routine. + +2009-04-20 Robert Dewar + + * s-conca5.adb, s-conca5.ads, s-conca7.adb, s-conca7.ads, s-conca9.adb, + s-conca9.ads, rtsfind.ads, s-conca2.adb, s-conca2.ads, s-conca4.adb, + s-conca4.ads, s-conca6.adb, s-conca6.ads, s-conca8.adb, s-conca8.ads, + s-conca3.adb, s-conca3.ads (Str_Concat_Bounds_x): New functions. + + * exp_ch4.adb (Expand_Concatenate): Minor code reorganization + +2009-04-20 Pascal Obry + + * initialize.c (__gnat_initialize): Add braces to kill warning. + + * adaint.c: Minor reformatting, remove trailing spaces. + +2009-04-17 Arnaud Charlet + + * gcc-interface/Make-lang.in: Update dependencies. + +2009-04-20 Eric Botcazou + + * adaint.h (__gnat_lwp_self): Declare on Linux. + + * adaint.c (__gnat_os_filename): Add ATTRIBUTE_UNUSED on 'filename'. + +2009-04-20 Robert Dewar + + * exp_ch5.adb, usage.adb, back_end.adb, opt.ads: Implement + front-end part of -fpreserve-control-flow switch. + +2009-04-20 Bob Duff + + * rtsfind.adb: Minor comment fix + +2009-04-20 Robert Dewar + + * exp_aggr.adb: Minor reformatting + Minor code reorganization (use Nkind_In) + + * g-socket.adb: Minor reformatting + + * g-socket.ads: Minor comment fix + + * s-auxdec.ads: Minor comment and organization update. + + * s-auxdec-vms_64.ads: Minor comment and organization update. + + * sem_ch10.adb: Minor addition of ??? comment + + * sem_disp.adb: Minor reformatting + +2009-04-20 Ed Schonberg + + * inline.adb (Add_Inlined_Subprogram): Do not place on the back-end + list a caller of an inlined subprogram, if the caller itself is not + called. + +2009-04-20 Pascal Obry + + * adaint.c: Disable use of ACL on network drives. + +2009-04-20 Arnaud Charlet + + * gnat_ugn.texi: Add examples. + +2009-04-20 Thomas Quinot + + * g-socket.ads (Abort_Selector): Clarify documentation. + +2009-04-20 Arnaud Charlet + + * opt.ads (Inspector_Mode): Update documentation of this flag. + +2009-04-20 Thomas Quinot + + * g-socket.ads: Minor reformatting + + * socket.c, gsocket.h (__gnat_get_h_errno, VxWorks case): No need to + consider S_resolvLib error codes since we only use the hostLib wrappers. + +2009-04-20 Eric Botcazou + + * sem_ch3.adb (Build_Derived_Private_Type): Insert the declaration + of the Underlying_Record_View after that of the derived type. + +2009-04-20 Arnaud Charlet + + * switch-c.adb (Scan_Front_End_Switches): Disable front-end inlining + in inspector mode. + +2009-04-20 Javier Miranda + + * sem_ch6.adb (New_Overloaded_Entity): Minor reformating. + + * sem_ch6.ads (Subtype_Conformant, Type_Conformant): Add missing + documentation. + + * exp_aggr.adb (Build_Record_Aggr_Code): Code cleanup. + + * sem_disp.adb + (Check_Dispatching_Operation): Set attribute Is_Dispatching_Operation + in internally built overriding subprograms. + +2009-04-20 Doug Rupp + + * s-auxdec-vms_64.ads (Integer_{8,16,32,64}_Array): New array types. + + * s-auxdec.ads: Likewise + +2009-04-20 Ed Schonberg + + * sem_ch3.adb (Find_Type_Name): Reject the completion of a private + type by an interface. + + * exp_ch6.adb (Expand_Call): Inline To_Address unconditionally, to + minimze difference in expanded tree when compiled as spec of the main + unit, or as a spec in the context of another unit. + +2009-04-20 Hristian Kirtchev + + * a-calend.adb: Remove types char_Pointer, int, tm and tm_Pointer. + (localtime_tzoff): This routine no longer accepts an actual of type + tm_Pointer. + (UTC_Time_Offset): Remove local variable Secs_TM. + + * sysdep.c (__gnat_localtime_tzoff): This routine no longer accepts an + actual of type struct tm*. Add local variable of type struct tm for all + targets that provide localtime_r and need to invoke it. + +2009-04-20 Thomas Quinot + + * s-oscons-tmplt.c, g-socket.adb, g-socket.ads + (GNAT.Sockets.Resolve_Error): Add case of EPIPE + Add case of EAGAIN for platforms where it is not equal to EWOULDBLOCK + +2009-04-20 Robert Dewar + + * sem_ch3.adb: Minor reformatting + + * lib-load.adb: Minor reformatting + + * sem_ch4.adb: Minor reformatting + +2009-04-20 Robert Dewar + + * namet-sp.ads, namet-sp.adb (Is_Bad_Spelling_Of): Implement new spec + (equal values => False). + +2009-04-20 Ed Schonberg + + * exp_ch6.adb (Is_Null_Procedure): predicate is global, so that calls + to null procedures can be inlined unconditionally. + +2009-04-20 Eric Botcazou + + * gcc-interface/trans.c (call_to_gnu): When creating the copy for a + non-addressable parameter passed by reference, do not convert the + actual if its type is already the nominal type, unless it is of + self-referential size. + +2009-04-20 Arnaud Charlet + + * gnat_ugn.texi: Fix typos. + +2009-04-20 Robert Dewar + + * debug.adb, gnat1drv.adb, sem_ch13.adb: Add circuitry to + Validate_Unchecked_Warnings to suppress warnings about size or + alignment or extra bits if either type involved has pragma Warnings + (Off) set for the type entity. + +2009-04-19 Eric Botcazou + + * gcc-interface/trans.c (gigi): Make the special IA-64 descriptor type + a builtin type and give it a name. + +2009-04-17 Diego Novillo + + * gcc-interface/misc.c (gnat_expand_expr): Remove. + (LANG_HOOKS_EXPAND_EXPR): Remove. + +2009-04-17 Robert Dewar + + * sem_ch3.adb: Minor reformatting + +2009-04-17 Pascal Obry + + * adaint.c: Add __gnat_use_acl global variable to control use of ACL. + +2009-04-17 Ed Schonberg + + * sem_ch3.adb (Build_Derived_Enumeration_Type): Diagnose properly + illegal constraints on type derived from formal discrete types. + +2009-04-17 Thomas Quinot + + PR ada/35953 + + * g-socthi-vms.adb, g-socthi-vms.ads, g-socthi-vxworks.adb, + g-socthi-vxworks.ads, g-socthi-mingw.adb, g-socthi-mingw.ads, + g-socthi.adb, g-stsifd-sockets.adb, g-socthi.ads, g-socket.adb, + g-socket.ads (GNAT.Sockets.Thin.C_Send, + GNAT.Sockets.Thin.Syscall_Send): Remove unused subprograms. + Replace calls to send(2) with equivalent sendto(2) calls. + (GNAT.Sockets.Send_Socket): Factor common code in inlined subprogram. + (GNAT.Sockets.Write): Account for the case of hyper-empty arrays, do not + report an error in that case. Factor code common to the two versions + (datagram and stream) in common routine Stream_Write. + +2009-04-17 Robert Dewar + + * exp_disp.adb: Minor reformatting + Minor code reorganization (use Nkind_In) + + * prepcomp.adb: Minor reformatting + + * sem_ch3.adb: Minor reformatting + + * sem_res.adb: Minor comment addition + + * exp_ch5.adb (Expand_Assign_Array): Use Has_Address_Clause to test + for address clause + + * lib-xref.adb (Generate_Reference): Exclude recursive calls from + setting Is_Referenced + + * types.ads: Minor reformatting + +2009-04-17 Arnaud Charlet + + * gnat_ugn.texi: Initial documentation on binding generator. + +2009-04-17 Ed Schonberg + + * einfo.ads, einfo.adb: New attribute Underlying_Record_View, to handle + type extensions whose parent is a type with unknown discriminants. + + * exp_aggr.adb (Expand_Record_Aggregate): If the type of an extension + aggregate has unknown discriminants, use the Underlying_Record_View to + obtain the discriminants of the ancestor part. + + * exp_disp.adb (Build_Dispatch_Tables): Types that are + Underlying_Record_Views share the dispatching information of the + original record extension. + + * exp_ch3.adb (Expand_Record_Extension): If the type inherits unknown + discriminants, propagate dispach table information to the + Underlying_Record_View. + + * sem_ch3.adb (Build_Derived_Private_Type): If parent type has unknown + discriminants and declaration is not a completion, generate + Underlying_Record_View to provide proper discriminant information to + the front-end and to gigi. + +2009-04-17 Robert Dewar + + * s-conca5.adb, g-sercom.adb, s-conca5.ads, s-conca7.adb, exp_imgv.adb, + s-conca7.ads, s-crc32.adb, s-crc32.ads, s-conca9.adb, s-conca9.ads, + s-addope.adb, i-cstrin.ads, s-addope.ads, s-carun8.adb, s-carun8.ads, + g-htable.ads, g-hesora.adb, g-hesora.ads, s-htable.adb, s-htable.ads, + s-conca2.adb, s-conca2.ads, a-except.adb, s-conca4.adb, a-except.ads, + s-conca4.ads, s-except.adb, s-except.ads, s-conca6.adb, s-conca6.ads, + g-spchge.adb, g-spchge.ads, g-u3spch.adb, g-u3spch.ads, s-conca8.adb, + s-conca8.ads, g-byorma.adb, g-byorma.ads, s-memory.adb, s-memory.ads, + g-speche.adb, g-speche.ads, g-stsifd-sockets.adb, exp_dist.adb, + s-imgenu.adb, s-imgenu.ads, s-mastop.adb, s-mastop.ads, s-exctab.adb, + s-exctab.ads, s-imenne.adb, s-imenne.ads, s-casuti.adb, osint.adb, + s-assert.adb, s-casuti.ads, s-assert.ads, s-os_lib.adb, s-conca3.adb, + s-conca3.ads: Remove unneeded pragma Warnings + +2009-04-17 Robert Dewar + + * g-moreex.adb: Add comments. + + * s-auxdec.ads: Add ??? comment for uncommented pragma Warnings (Off) + + * s-auxdec-vms_64.ads: Add ??? comment for uncommented pragma + Warnings (Off) + + * prepcomp.adb: Add ??? comment + + * a-tasatt.adb: Minor reformatting + + * g-trasym-vms-alpha.adb: Add ??? comment + + * g-trasym-vms-ia64.adb: Add ??? comment + + * xoscons.adb: Minor reformatting + + * s-tassta.adb: Minor reformatting + + * s-scaval.adb: Add ??? comment + + * stand.ads: Minor code clean up (remove junk with of Namet) + + * s-strcom.adb, s-strcom.ads, s-string.adb, s-string.ads, s-sopco3.adb, + s-sopco3.ads, s-strops.adb, s-strops.ads, s-sopco5.adb, s-sopco5.ads, + s-wchcnv.adb, s-wchcnv.ads, s-ststop.adb, s-ststop.ads, s-soflin.adb, + s-soflin.ads, s-traceb.adb, s-traceb.ads, s-traent.adb, s-traent.ads, + s-secsta.adb, s-secsta.ads, s-utf_32.adb, s-utf_32.ads, s-wchcon.adb, + s-wchjis.adb, s-wchcon.ads, s-wchjis.ads, s-sopco4.adb, s-sopco4.ads, + s-stache.adb, s-stache.ads, s-stoele.adb, s-stoele.ads, s-stalib.adb, + s-stalib.ads, s-os_lib.ads, s-purexc.ads: Remove no longer needed + Warnings off pragmas. + +2009-04-17 Pascal Obry + + * initialize.c: Fix test for reallocating the arguments array. + +2009-04-17 Geert Bosch + + * exp_fixd.adb (Expand_Convert_Float_To_Fixed): Have float to fixed + conversion truncate only for decimal fixed point types. + +2009-04-17 Jerome Lambourg + + * g-comlin.adb (Initialize_Scan_Option): Make sure the sections are + reinitialized. + +2009-04-17 Robert Dewar + + * exp_ch5.adb (Expand_Assign_Array): Do not set Forwards_OK and + Backwards_OK if either operand has an address clause. + +2009-04-17 Pascal Obry + + * initialize.c: Code clean up, use realloc. + +2009-04-17 Pascal Obry + + * initialize.c: Do not get Unicode command line if Unicode support not + activated. + Add support for wildcard expansion for Unicode parameters on Win32. + + * mingw32.h: Add missing macros when Unicode support not activated. + +2009-04-17 Javier Miranda + + * sem_ch6.adb (Check_Anonymous_Return): Add missing checks to + avoid generating code that references the Current_Master + when compiling without tasks. + +2009-04-17 Vincent Celier + + * prj-attr.adb: New project level attribute Target + + * prj-nmsc.adb (Process_Project_Level_Simple_Attributes): Process + attribute Target + + * prj.ads (Project_Configuration): New component Target + +2009-04-17 Thomas Quinot + + * exp_ch7.adb (Expand_Ctrl_Function_Call): Remove incorrect special + case for the case of an aggregate component, the attach call for the + result is actually needed. + + * exp_aggr.adb (Backend_Processing_Possible): Backend processing for + an array aggregate must be disabled if the component type requires + controlled actions. + + * exp_ch3.adb: Minor reformatting + +2009-04-17 Bob Duff + + * output.ads (Indent,Outdent): New procedures for indenting the output. + (Write_Char): Correct comment -- LF _is_ allowed. + + * output.adb (Indent,Outdent): New procedures for indenting the output. + Keep track of the indentation level, and make sure it doesn't get too + high. + (Flush_Buffer): Insert spaces at the beginning of each line, if + indentation level is nonzero. + (Save_Output_Buffer,Restore_Output_Buffer): Save and restore the current + indentation level. + (Set_Standard_Error,Set_Standard_Output): Remove superfluous + "Next_Col := 1;". Flush_Buffer does that. + + * sem_ch6.adb, sem_ch7.adb (Debug_Flag_C): Reorganize the output + controlled by the -gnatdc switch. It now occurs on entry/exit to the + relevant analysis routines, and calls Indent/Outdent to make the + indentation reflect the nesting level. Add "helper" routines, since + otherwise lots of "return;" statements would skip the debugging output. + +2009-04-17 Arnaud Charlet + + * s-taprop-tru64.adb, s-taprop-vms.adb, s-taprop-linux.adb, + s-taprop-solaris.adb, s-taprop-irix.adb, s-taprop-hpux-dce.adb, + s-taprop-posix.adb (Suspend_Until_True): Protect against early wakeup. + +2009-04-17 Thomas Quinot + + * exp_aggr.adb: Minor code reorganization, no behaviour change. + +2009-04-17 Ed Schonberg + + * sem_ch8.adb (Use_One_Type): Handle properly a redundant use type + clause in a unit that is a package body or a subunit, when the previous + clause appears in a spec or a parent. + +2009-04-17 Thomas Quinot + + * sinfo.ads, exp_aggr.adb, exp_aggr.ads: Minor reformatting + + * exp_ch7.adb: Minor reformatting + +2009-04-17 Bob Duff + + * exp_ch4.adb (Expand_Allocator_Expression): In an initialized + allocator, check that the expression of the qualified expression obeys + the constraints of the subtype of the qualified expression. + +2009-04-17 Thomas Quinot + + * sprint.adb (Write_Itype): Add handling of enumeration subtypes. + +2009-04-17 Ed Schonberg + + * exp_ch4.adb (Expand_Allocator_Expression): Apply constraint check to + aggregate, using context imposed by subtype mark in allocator. + +2009-04-17 Pascal Obry + + * gnat_rm.texi: Document GNAT_CODE_PAGE environment variable + +2009-04-17 Nicolas Roche + + * initialize.c (__gnat_initialize): remove MAX_PATH limitation on each + argument length. + +2009-04-17 Gary Dismukes + + * sem_elim.adb (Eliminate_Error_Msg): Minor change to error message to + cover both calls and attribute references ("call" => "reference"). + +2009-04-17 Ed Schonberg + + * sem_ch3.adb (Analyze_Subtype_Declaration): A subtype of an access + type for which Storage_Size is set to 0 is legal in a pure unit. + +2009-04-17 Thomas Quinot + + * exp_ch7.adb: Minor reformatting + +2009-04-17 Robert Dewar + + * restrict.adb (Check_Restriction_No_Dependence): Don't check + restriction if outside main extended source unit. + + * sem_ch10.adb (Analyze_With_Clause): Check No_Dependence restriction + for parents of child units as well as the child unit itself. + +2009-04-17 Bob Duff + + * checks.ads: Minor comment fix + + * exp_aggr.ads: Minor comment fix + +2009-04-17 Nicolas Roche + + * adaint.c: Improve cross compiler detection and handling. + +2009-04-17 Eric Botcazou + + * exp_ch4.adb (Expand_Concatenation): Do not use calls at -Os. + +2009-04-17 Pascal Obry + + * mingw32.h: Add S2WSC and WS2SC macros to convert to/from + CurrentCodePage. + + * adaint.h: Encoding_Unspecified is now defined. Corresponds to the + value when no encoding form paramter is set on Text_IO services. + + * adaint.c: CurrentCodePage new variable on Windows. + Use new macros S2WSC and WS2SC instead of the UTF-8 oriented + ones. + + * mkdir.c: Use new macros S2WSC and WS2SC instead of the UTF-8 oriented + ones. + + * initialize.c: Initialize CurrentCodePage depending on GNAT_CODE_PAGE + environment variable value. Default is UTF-8. + + * s-crtl.ads: Filename_Encoding add Unspecified in the enumeration type. + fopen and freopen encoding parameter is now set to Unspecified. + The default value is in this case UTF-8 (as it was before) but + use the new macros that convert to/from the code page set + at runtime (CurrentCodePage). + + * s-fileio.adb: When no encoding specified use Unspecified value. + +2009-04-17 Ed Schonberg + + * atree.adb, atree.ads: Remove dead code. + +2009-04-17 Arnaud Charlet + + * gcc-interface/Make-lang.in: Update dependencies. + +2009-04-17 Ed Schonberg + + * sem_ch3.adb (Access_Subprogram_Definition): Additional checks on + illegal uses of incomplete types in formal parts and return types. + + * sem_ch6.adb (Process_Formals): Taft-amendment types are legal in + access to subprograms. + + * sem_ch7.adb (Uninstall_Declarations): diagnose attempts to use + Taft-amendment types as the return type of an access_to_function type. + + * freeze.adb (Freeze_Entity): Remove tests on formals of an incomplete + type for access_to_subprograms. The check is performed on package exit. + +2009-04-17 Ed Schonberg + + * atree.ads, atree.adb: Move New_Copy_Tree.to sem_util. + + * nlists.ads, nlists.adb: Move New_Copy_List to sem_util. + + * lib-load.adb: Use Copy_Separate_Tree rather than New_Copy_Tree + + * sem_util.ads, sem_util.adb: New_Copy_Tree and New_Copy_List belong in + semantic units, because the handling of itypes in the copied tree + requires semantic information that does not belong in atree. + +2009-04-17 Robert Dewar + + * par-ch6.adb: Minor reformatting + + * prj.adb: Minor reformatting + +2009-04-17 Gary Dismukes + + * par-ch6.adb (P_Subprogram): Overriding indicators should be allowed + on protected subprogram bodies, so exclude the case where Pf_Flags is + Pf_Decl_Pbod from the error check. + + * par-ch9.adb (P_Protected_Operation_Items): Permit overriding + indicators on subprograms in protected bodies, and proceed with parsing + the subprogram. + + * sem_ch6.adb (Verify_Overriding_Indicator): Exclude protected + subprograms from the check for primitiveness on subprograms with + overriding indicators. + (Check_Overriding_Indicator): Include protected subprograms in the + style check for missing overriding indicators. + +2009-04-17 Tristan Gingold + + * init.c: Fix stack checking for x86 Darwin. + +2009-04-17 Vincent Celier + + * prj-attr.adb: New project level attribute Object_File_Suffix + (). + + * prj-nmsc.adb (Add_Source): Use the object file suffix to get the + object file name + (Process_Compiler): Process attribute Object_File_Suffix + + * prj.adb (Object_Name): Use suffix Object_File_Suffix instead of + platform suffix, when specified. + + * prj.ads (Language_Config): New component Object_File_Suffix, + defaulted to No_Name. + (Object_Name): New parameter Object_File_Suffix, defaulted to No_Name + + * snames.ads-tmpl: New standard name Object_File_Suffix + +2009-04-17 Robert Dewar + + * gnat_rm.texi: Add documentation about No_Streams restriction + + * sem_attr.adb (Check_Stream_Attribute): Exclude implicit stream + attributes when checking No_Streams restriction. + +2009-04-17 Thomas Quinot + + * rtsfind.ads (RE_Request_Destroy): New PolyORB s-parint entity. + + * exp_dist.adb (PolyORB_Support.Build_General_Calling_Stubs): Add + missing calls to RE_Request_Destroy to deallocate request objects after + use. + +2009-04-17 Nicolas Setton + + * link.c: Fix support for passing a response file under Darwin. + +2009-04-17 Emmanuel Briot + + * prj.adb (Free): new subprogram. + +2009-04-17 Ed Schonberg + + * sem_ch3.adb: additional initialization on incomplete subtypes. + + * sem_ch6.adb (Process_Formals): if the subprogram is in the private + part and one of the formals is an incomplete tagged type, attach to + list of private dependends of the type for later validation. + + * sem_ch7.adb (Uninstall_Declarations): diagnose attempts to declare + primitive operations of a Taft-amendmment type. + + * freeze.adb (Freeze_Entity): Remove tests on formals of an incomplete + type. The check is performed on package exit, possibly after the + subprogram is frozen. + +2009-04-17 Vincent Celier + + * prj-nmsc.adb (Get_Directories): Get the object and exec directory + before looking for source directories, but make sure that there are nil + if they are not explicitely declared and there is explicitely no + sources in the project. + +2009-04-17 Pascal Obry + + * initialize.c: Set gnat_argv with UTF-8 encoded strings on Windows. + + * init.c: Fix minor typo and style fix. + +2009-04-17 Robert Dewar + + * a-except.adb, a-except-2005.adb: Add PE_Address_Of_Intrinsic + + * sem_attr.adb (Analyze_Attribute, case Address): Use + PE_Address_Of_Intrinsic. + + * types.ads: Add PE_Address_Of_Intrinsic + + * types.h: Add PE_Address_Of_Intrinsic + +2009-04-17 Nicolas Setton + + * gcc-interface/Makefile.in: Under darwin, build shared libraries + with install_name starting with "@rpath/". + +2009-04-17 Nicolas Setton + + * link.c: Add darwin section + +2009-04-16 Robert Dewar + + * g-pehage.adb: Minor reformatting + + * sem_ch12.adb: Minor reformatting + + * exp_dist.adb: Minor reformatting + + * bindgen.adb: Minor style fixes. + +2009-04-16 Ed Schonberg + + * sem_eval.adb (Eval_Indexed_Component): Extend constant-folding of + indexed components to the case where the prefix is a static string + literal. + +2009-04-16 Javier Miranda + + * exp_ch3.adb (Expand_N_Object_Declaration): In case of build-in-place + objects avoid any further expansion of the expression initializing the + object. + +2009-04-16 Ed Schonberg + + * sem_ch12.adb (Preanalyze_Actuals): If the instance is a child unit + that hides an outer homograph, make that homograph invisible when + analyzing the actuals, to to prevent illegal direct visibility on it. + +2009-04-16 Eric Botcazou + + * g-pehage.adb (Initialize): Fix off-by-one error. + +2009-04-16 Tristan Gingold + + * init.c: Detect real stack overflow on Darwin. + + * system-darwin-x86.ads: Use stack probing on darwin x86. + +2009-04-16 Ed Schonberg + + * sem_attr.adb (Analyze_Attribute, case 'Address): It is illegal to + take the address of an intrinsic subprogram. + +2009-04-16 Arnaud Charlet + + * gcc-interface/Makefile.in: Change g-trasym to g-trasym-unimplemented + for the targets where GNAT.Traceback.Symbolic is not supported. + +2009-04-16 Vincent Celier + + * g-trasym-unimplemented.ads, g-trasym-unimplemented.adb: New file. + + * g-trasym.ads: Update comments. + +2009-04-16 Vasiliy Fofanov + + * tracebak.c (STOP_FRAME): Verify validity of the current address + before dereferencing. + +2009-04-16 Ed Schonberg + + * sprint.adb (Write_Itype): If the itype is an array subtype, preserve + the original location of the index expressions and the index subtypes, + to prevent spurious out-of-scope references in gigi. + +2009-04-16 Tristan Gingold + + * init.c, s-osinte-darwin.ads, system-darwin-x86_64.ads: + Add support for stack checking on darwin. + +2009-04-16 Vincent Celier + + * prj-attr.adb: New attribute Runtime_Source_Dir + + * prj-nmsc.adb (Process_Project_Level_Array_Attributes): Process + attribute Runtime_Source_Dir. + (Check_Naming_Schemes): Give default values to out parameters to avoid + invalid data. + + * prj.ads (Language_Config): New component Runtime_Source_Dir + + * snames.ads-tmpl: New standard name Runtime_Source_Dir + +2009-04-16 Pascal Obry + + * adaint.h, adaint.c (__gnat_rmdir): New routine. + Simple wrapper routines used to convert to proper encoding on + Windows. + + * s-crtl.ads: Use __gnat_rmdir instead of direct call to the C library. + + * g-dirope.adb (Remove_Dir): Fix a bug, the root directory was removed + twice. + +2009-04-16 Pascal Obry + + * s-crtl.ads, s-os_lib.adb: Minor code clean-up. + +2009-04-16 Thomas Quinot + + * snames.ads-tmpl (Name_Defined): New predefined name for use by the + integrated preprocessor. + + * prep.ads, prep.adb (Setup_Hooks): New subprogram. + (Initialize): Split into two subprograms, Initialize (to be called + prior to compiler command line processing) and Setup_Hooks (to be called + later on when the first source file is loaded). + + * gprep.adb: Change call to Prep.Initialize to call to Prep.Setup_Hooks. + Add call to Prep.Initialize. + + * sinput-l.adb, prepcomp.adb: Change call to Prep.Initialize to call + to Prep.Setup_Hooks. + +2009-04-16 Pascal Obry + + * adaint.h, adaint.c (__gnat_chdir): New routine. + Simple wrapper routines used to convert to proper encoding on + Windows. + + * s-crtl.ads: Use __gnat_chdir instead of direct call to the C library. + + * a-direct.adb, g-dirope.adb: Use chdir from System.CRTL. + +2009-04-16 Quentin Ochem + + * sinput-p.adb (Clear_Source_File_Table): Use Sinput.Initialize instead + of Source.Init. + +2009-04-16 Eric Botcazou + + * a-convec.ads (Is_Empty): Mark inline. + +2009-04-16 Nicolas Roche + + * init.c (__gnat_init_float): Initialize FPU on x86_64 windows + +2009-04-16 Thomas Quinot + + * prepcomp.adb: Minor reformatting + +2009-04-16 Jerome Lambourg + + * sem_prag.adb (Process_Import_Or_Interface): With .NET, + Access_Subprogram types can also be imported. + (Check_Form_Of_Interface_Name): Accept '/' character in entity CIL + names. + +2009-04-16 Ed Schonberg + + * exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration): + preserve homonym chain when the declaration is rewritten into a + renaming declaration, in order to preserve visibility structure. + +2009-04-16 Jerome Lambourg + + * sem_prag.adb (Analyze_Pragma): Make sure that pragma pack is not + taken into account for VM targets. + +2009-04-16 Hristian Kirtchev + + * g-calend.ads, g-calend.adb (Week_In_Year): Now calls + Year_Week_In_Year. + (Year_Week_In_Year): New routine which contains the original code from + Week_In_Year. Add the missing special case for January 1st falling on + a Monday. + +2009-04-16 Thomas Quinot + + * exp_dist.adb (Build_From_Any_Call): For a subtype that is a generic + actual type, use the base type to build the To_Any function. + (Build_From_Any_Function): Remove junk, useless subtype conversion. + +2009-04-16 Thomas Quinot + + * exp_ch9.adb, exp_code.adb, tbuild.adb, sem_case.adb, + restrict.adb: Minor code reorganization (use + Add_{Char,Str}_To_Name_Buffer instead of inlining it by hand). + +2009-04-16 Bob Duff + + * exp_ch6.ads, exp_ch6.adb (Is_Build_In_Place_Function_Return): Remove, + unused. + +2009-04-16 Thomas Quinot + + * sem_ch4.adb: Minor reformatting + + * adaint.c: Remove junk duplicated code. + + * sem_ch3.adb: Minor reformatting + + * exp_dist.adb: Minor comment rewording + +2009-04-16 Robert Dewar + + * gnat_rm.texi: Document effect of Assume_No_Invalid_Values and -gnatVa + used together. + +2009-04-16 Ed Schonberg + + * sem_ch4.adb (Find_Equality_Types): Filter out types that are not + usable before calling Add_One_Interp, to resolve spurious ambiguities. + +2009-04-16 Robert Dewar + + * Make-lang.in: Add entries for s-conca?.o + + * Makefile.rtl: Add entries for s-conca? + + * debug.adb: Add debug flags -gnatd.c and -gnatd.C to control behavior + of concatenation expansion + + * exp_ch4.adb (Expand_Concatenation): Generate calls for certain + string cases instead of expanding assignments inline. + + * opt.ads (Optimize_Size): New flag + + * s-conca2.ads, s-conca2.adb, s-conca3.adb, s-conca3.ads, + s-conca4.adb, s-conca4.ads, s-conca5.adb, s-conca5.ads, s-conca6.adb, + s-conca6.ads, s-conca7.ads, s-conca7.adb, s-conca8.adb, s-conca8.ads, + s-conca9.adb, s-conca9.ads: New file. + +2009-04-16 Robert Dewar + + * exp_ch6.adb: Add comments + + * rtsfind.ads: Add entries for s-conca? routines + +2009-04-16 Arnaud Charlet + + * gcc-interface/Make-lang.in: Update dependencies. + + * gcc-interface/Makefile.in: Update translation for vms. + +2009-04-16 Ed Schonberg + + * sem_ch12.adb (Map_Formal_Package_Entities): renamed from Map_Entities + and made global, to be used when installing parents of a child + instance, to provide mappings for entities declared in formal packages + of ancestor units. Now called from Install_Formal_Packages. + +2009-04-16 Doug Rupp + + * s-taskin.adb (Initialize_ATCB): Initialize Debug_Events with others + notation for clarity. + + * s-taprop-vxworks.adb, s-taprop-tru64.adb, s-taprop-vms.adb, + s-taprop-mingw.adb, s-taprop-linux.adb, s-taprop-solaris.adb, + s-taprop-irix.adb, s-taprop-hpux-dce.adb, s-taprop-posix.adb + (Initialize): Initialize Known_Tasks with Environment task. + + * s-taskin.ads (Task_States): Move new states to end for the sake of + GDB compatibility. + + * s-tassta.adb (Task_Wrapper): Fix comment about Enter_Task. + +2009-04-16 Ed Schonberg + + * exp_ch9.adb (Expand_N_Protected_Type_Declaration): If a protected + operation has an inline pragma, propagate the flag to the internal + unprotected subprogram. + +2009-04-16 Doug Rupp + + * s-taprop-vxworks.adb, s-taprop-tru64.adb, s-taprop-mingw.adb, + s-taprop-linux.adb, s-taprop-solaris.adb, s-taprop-irix.adb, + s-taprop-hpux-dce.adb, s-taprop-posix.adb + (Enter_Task): Move Known_Tasks initialization to s-tassta.adb + + * s-taprop-vms.adb (Enter_Task): Likewise. + (Initialize): Import DBEXT, Debug_Register. Register DBGEXT callback. + + * s-tassta.adb (Activate_Tasks): After task creation set state to + Activating, vice Runnable. Initialize Known_Tasks, moved here from + s-taprop.adb (Enter_Task). Set Debug_Event_Activating for debugger. + Set state to Runnable after above. + (Task_Wrapper): Set Debug_Event_Run. In exception block set + Debug_Event_Terminated. + + * s-taskin.ads (Task_States): Add new states Activiting and + Activator_Delay_Sleep. + (Bit_Array, Debug_Event_Array): New types. + (Global_Task_Debug_Event_Set: New flag. + (Common_ATCB): New field Debug_Events. + + * s-taskin.adb (Initialize_ATCB): Initialize Debug_Events. + + * s-tasren.adb (Timed_Selective_Wait): Set Activator_Delay_Sleep vice + Activator_Sleep. + + * s-tasini.adb (Locked_Abort_To_Level): Add case alternatives for when + Activating and when Acceptor_Delay_Sleep. + + * s-tasdeb.ads: Add constants for Debug_Events. + (Debug_Event_Kind_Type): New subtype. + (Signal_Debug_Event): New subprogram. + + * s-tasdeb.adb (Signal_Debug_Event): New null subprogram. + +2009-04-16 Thomas Quinot + + * sem_elim.adb: Minor reformatting + + * freeze.adb: Minor reformatting + + * exp_ch4.adb: Minor reformatting + +2009-04-16 Emmanuel Briot + + * prj-nmsc.adb (Path_Name_Of): fix memory leak + +2009-04-16 Robert Dewar + + * sinfo.ads (Backwards_OK, Forwards_OK): Clarify documentation + +2009-04-16 Vincent Celier + + * fmap.adb (Initialize): Show the current line when the mapping file + is detected as "incorrectly formatted". + +2009-04-16 Robert Dewar + + * sem_ch12.adb: Minor reformatting + + * sem_ch5.adb: Minor comment addition + + * sem_util.adb: Minor reformatting + + * sinput-p.adb: Minor reformatting + Add missing pragma Warnings (On) + +2009-04-16 Ed Falis + + * s-vxwext-kernel.adb: (ERROR): deleted unused constant + +2009-04-16 Vincent Celier + + * ali-util.adb: Minor comment spelling error fix + +2009-04-16 Eric Botcazou + + * exp_ch5.adb (Expand_Assign_Array): For the GCC back-end, do not + generate an assignment loop in case of overlap. + +2009-04-16 Olivier Hainque + + * gnat_ugn.texi (gnatmem description): Make it explicit that + gnatmem is designed to work in association with static runtime + library only. + +2009-04-16 Thomas Quinot + + * sem_type.adb: Minor reformatting + +2009-04-16 Hristian Kirtchev + + * s-osprim-darwin.adb, s-osprim-posix.adb (Clock): Add comment + concerning return codes of gettimeofday and return value check. + +2009-04-16 Ed Falis + + * s-vxwext-kernel.ads (Int_Lock, Int_Unlock): set to convention C so + body can be renaming of imported routines. + +2009-04-16 Vasiliy Fofanov + + * s-asthan-vms-alpha.adb: Disable warnings on alignment in a more + targeted fashion. + +2009-04-15 Hristian Kirtchev + + * exp_ch9.adb: Comment improvements. + (Build_Entry_Family_Name): Add parentheses around the index of a entry + family member. + +2009-04-15 Bob Duff + + * sem_warn.adb (Check_Infinite_Loop_Warning): Catch cases like + "while X /= null loop" where X is unchanged inside the loop. We were + not warning in this case, because of the pointers -- we feared that the + loop variable could be updated via a pointer, if there are any pointers + around the place. But that is impossible in this case. + + * sem_util.adb (May_Be_Lvalue): This routine was overly pessimistic in + the case of dereferences. In X.all, X cannot be an l-value. We now + catch that case (and implicit dereferences, too). + +2009-04-15 Vincent Celier + + * sinput-p.ads, sinput-p.adb (Clear_Source_File_Table): New procedure + +2009-04-15 Ed Schonberg + + * sem_ch12.adb (Is_Actual_Of_Previous_Formal): Make fully recursive. + From code reading. + (Analyze_Package_Instantiation): If generic unit in child instance is + the same as generic unit in parent instance, look for an outer homonym + to locate the desired generic. + +2009-04-15 Bob Duff + + * sem_ch5.adb (Analyze_Loop_Statement): Don't check for infinite loop + warnings unless the loop comes from source, because checking generated + loops is a waste of time, and makes it harder to debug + Check_Infinite_Loop_Warning. + + * sem_warn.adb (Check_Infinite_Loop_Warning): If the local variable + tested in the while loop is a renaming, do not warn. Otherwise, we get + false alarms, because it's usually renaming something that we can't + deal with (an indexed component, a global variable, ...). + + * gnat_rm.texi: Fix typo + +2009-04-15 Thomas Quinot + + * sem_ch6.adb: Minor reformatting + +2009-04-15 Hristian Kirtchev + + * exp_ch7.adb (Expand_Ctrl_Function_Call): Check for the case where the + immediate parent of the controlled function call is a component + association. + +2009-04-15 Ed Schonberg + + * sem_ch8.adb (Use_One_Type): If the type is tagged, indicate that the + corresponding class-wide type is also in use. + +2009-04-15 Thomas Quinot + + * frontend.adb: Minor comment fix + +2009-04-15 Robert Dewar + + * gnatchop.adb (BOM_Length): New global variable + (Write_Unit): Add new parameter Write_BOM + (Write_Chopped_Files): Check for BOM and set Write_BOM for call + to Write_Unit + + * gnat_ugn.texi: Add note on propagation of BOM by gnatchop + +2009-04-15 Geert Bosch + + * system-mingw-x86_64.ads, system-darwin-x86_64.ads + (Backend_Overflow_Checks): Set to True. + +2009-04-15 Gary Dismukes + + * par-ch3.adb (P_Type_Declaration): Issue an error if the synchronized + keyword is given in a record extension. + +2009-04-15 Hristian Kirtchev + + * exp_ch7.adb (Expand_Ctrl_Function_Call): Procede with the expansion + of a controlled function call in the context of a record aggregate. + This does not apply to array aggregates since the call will be expanded + into assignments. + +2009-04-15 Ed Falis + + * s-osinte-vxworks-kernel.adb, s-osinte-vxworks.adb, + s-osinte-vxworks.ads s-vxwext.ads, s-vxwext-kernel.adb, + s-vxwext-kernel.ads, s-vxwext-rtp.ads, s-vxwext-rtp.adb: Reorganize + s-osinte-vxworks* and s-vxwext*. + +2009-04-15 Arnaud Charlet + + * gcc-interface/Make-lang.in: Update dependencies. + + * gcc-interface/Makefile.in: Reorganization of s-osinte-vxworks* + and s-vxwext*. + +2009-04-15 Robert Dewar + + * sem_ch13.adb (Unchecked_Conversions): Store source location instead + of node for location for warning messages. + + * gnatchop.adb: Minor reformatting + +2009-04-15 Ed Schonberg + + * exp_ch6.adb: additional guard for renaming declarations for in + parameters of an array type. + +2009-04-15 Robert Dewar + + * sem_eval.adb (Get_Static_Length): Go to origin node for array bounds + in case they were rewritten by expander (Force_Evaluation). + + * targparm.adb (Get_Target_Parameters): Correct check for + Suppress_Exception_Locations. + +2009-04-15 Ed Schonberg + + * exp_ch6.adb (Expand_Inlined_Call): If an in-parameter in a call to be + inlined is of an array type that is not bit-packed, use a renaming + declaration to capture its value, rather than a constant declaration. + +2009-04-15 Robert Dewar + + * rtsfind.adb: Minor reformatting. + +2009-04-15 Emmanuel Briot + + * prj-part.adb, prj-tree.adb, prj-tree.ads (Restore_And_Free): renames + Restore, and free the saved context. + +2009-04-15 Gary Dismukes + + * sem_ch3.adb (Analyze_Private_Extension_Declaration): Move error check + for illegal private extension from a synchronized interface parent in + front of check for illegal limited extension so that limited extension + from a synchronized interface will be rejected. + (Check_Ifaces): Check that a private extension that has a synchronized + interface as a progenitor must be explicitly declared synchronized. + Also check that a record extension cannot derive from a synchronized + interface. + +2009-04-15 Pascal Obry + + * adaint.h (__gnat_unlink): Add spec. + (__gnat_rename): Likewise. + +2009-04-15 Vincent Celier + + * prj-nmsc.adb: Minor spelling error corrections in error messages + +2009-04-15 Robert Dewar + + * sinfo.ads: Minor comment update + + * opt.ads: Minor comment updates + + * checks.adb (Enable_Overflow_Check): Do not set Do_Overflow_Check for + modular type. + +2009-04-15 Ed Schonberg + + * exp_disp.ads, exp_disp.adb (Register_Primitive): Is now a function + that generates the code needed to update a dispatch table when a + primitive operation is declared with a subprogram body without previous + spec. Insertion of the generated code is responsibility of the caller. + (Make_DT): When building static tables, append the code created by + Register_Primitive to update a secondary table after it has been + constructed. + + * exp_ch3.adb, exp_ch6.adb: use new version of Register_Primitive. + + * sem_disp.adb (Check_Dispatching_Operation): Call Register_Primitive + on an overriding operation that implements an interface operation only + if not building static dispatch tables. + +2009-04-15 Hristian Kirtchev + + * a-caldel-vms.adb (To_Duration): Declare a "safe" end of time which + does not cause overflow when converted to Duration. Use the safe value + as the maximum allowable time delay.. + +2009-04-15 Jerome Lambourg + + * g-comlin.adb (Set_Command_Line): When adding a switch with attached + parameter, specify that the delimiter is NUL, otherwise "-j2" will be + translated to "-j 2". + +2009-04-15 Bob Duff + + * rtsfind.adb (Maybe_Add_With): Split out procedure to add implicit + with_clauses, to avoid code duplication. Change this processing so we + always add a with_clause on the main unit if needed. + +2009-04-15 Pascal Obry + + Add support for Win32 native encoding for delete/rename routines. + + * adaint.c (__gnat_unlink): New routine. + (__gnat_rename): New routine. + Simple wrapper routines used to convert to proper encoding on + Windows. + + * s-os_lib.adb: Use __gnat_unlink and __gnat_rename instead of direct + call to the C library. + + * g-sercom-mingw.adb, s-win32.ads: Update Win32 binding. + +2009-04-15 Robert Dewar + + * s-tassta.adb: Minor reformatting + +2009-04-15 Robert Dewar + + * frontend.adb (Frontend): Set proper default for + Warn_On_Non_Local_Exception. + + * opt.ads (Exception_Handler_Encountered): New flag + (No_Warn_On_Non_Local_Exception): New flag + + * par-ch11.adb (P_Exception_Handler): Set Exception_Handler_Encountered + + * sem_warn.adb (Set_Warning_Switch): Set No_Warn_On_Non_Local_Exception + (Set_Dot_Warning_Switch): Set No_Warn_On_Non_Local_Exception + +2009-04-15 Cyrille Comar + + * s-tassta.adb, a-exextr.adb, a-elchha.adb + (Ada.Exception.Last_Chance_Handler): Do not print unhandled exception + message when exception traces are active since it would generate + redundant information. + (Exception_Traces.Notify_Exception): put message output by a critical + section to avoid unsynchronized output. + (Trace_Unhandled_Exception_In_Task): put message output by a critical + section to avoid unsynchronized output. + +2009-04-15 Emmanuel Briot + + * g-comlin.adb, prj-tree.adb, prj-tree.ads, prj.adb, prj.ads + (Free): New subprogram. + +2009-04-15 Hristian Kirtchev + + * a-calend.adb: Add new constant Nanos_In_Four_Years. + (Formatting_Operations.Time_Of): Change the way four year chunks of + nanoseconds are added to the intermediate result. + +2009-04-15 Nicolas Setton + + * sysdep.c: Add __APPLE__ in the list of systems where get_immediate + does not need to wait for a carriage return. + +2009-04-15 Tristan Gingold + + * bindgen.adb: Do not generate adafinal if No_Finalization restriction + is set. + +2009-04-15 Ed Schonberg + + * freeze.adb (Freeze_Entity): improve error message for improper use of + incomplete types. + Diagnose additional illegal uses of incomplete types in formal parts. + appearing in formal parts. + + * sem_ch6.adb (Process_Formals, Analyze_Return_Type): ditto. + +2009-04-15 Robert Dewar + + * exp_ch4.adb (Expand_N_Allocator): Install test for object too large. + +2009-04-15 Nicolas Roche + + * adaint.c: Add function __gnat_lwp_self that retrieves the LWP of the + current thread. + + * s-osinte-linux.ads: Import the __gnat_lwp_self function as lwp_self + + * s-taprop-linux.adb (Enter_Task): Store the LWP in the TCB + +2009-04-15 Ed Schonberg + + * sem_ch4.adb: improve error message on exponentiation. + +2009-04-15 Hristian Kirtchev + + * a-calend.adb: Move constant Epoch_Offset from package + Conversion_Operations to top level. + (Delay_Operations.To_Duration): Define a constant which represents + "end of time" and use it as a guard against very distant delay dates. + Protect the code against overflow when performing the origin shift to + Unix time. + +2009-04-15 Robert Dewar + + * sem_prag.adb: Minor reformatting. + + * sem_type.adb: Minor reformatting + +2009-04-15 Javier Miranda + + * sem_ch6.adb (Analyze_Abstract_Subprogram_Declaration): Add missing + support to check eliminated subprograms. + + * sem_elim.ads (Eliminate_Error_Msg): Update documentation. + + * sem_elim.adb (Set_Eliminated): Add support for elimination of + dispatching subprograms. + + * exp_disp.adb (Make_DT): Minor code cleanup when freezing primitive + operations. Initialize with "null" the slots of eliminated dispaching + primitives. + (Write_DT): Add output for eliminated primitives. + + * sem_disp.adb (Check_Dispatching_Call): Check eliminated primitives. + +2009-04-15 Ed Schonberg + + * sem_ch8.adb (Use_One_Type): If both clauses appear on the same unit, + the second is redundant, regardless of scopes. + +2009-04-15 Vincent Celier + + * prj-nmsc.adb (Get_Directories): Check for sources before checking + the object directory as when there are no sources, they may not be any + object directory. + + * make.adb (Gnatmake): Do not attempt to get the path name of the exec + directory, when there are no exec directory. + +2009-04-15 Ed Schonberg + + * sem_type.adb (Remove_Conversions): In order to resolve spurious + ambiguities, refine removal of universal interpretations from complex + expressions with literal arguments, when some numeric operators have + been declared abstract. + +2009-04-15 Ed Falis + + * init.c: Map SIGSEGV to Storage_Error for all targets for uniformity + and backward compatibility for targets using probing for stack overflow + +2009-04-15 Ed Schonberg + + * sem_prag.adb (Analyze_Pragma, case 'Obsolescent): Pragma is legal + after any declaration, including renaming declarations. + +2009-04-15 Arnaud Charlet + + * gcc-interface/Make-lang.in: Update dependencies. + + * gcc-interface/Makefile.in: Fix VxWorks target pairs. + Update xenomai target pairs. + +2009-04-15 Javier Miranda + + * exp_ch4.adb (Expand_N_Allocator): Code cleanup. + + * sem_ch6.adb (Check_Anonymous_Return): Add missing support for + functions returning anonymous access to class-wide limited types. Mark + also the containing scope as a task master. + + * sem_ch8.adb (Restore_Scope_Stack): Add missing management for + limited-withed packages. Required to restore their visibility after + processing packages associated with implicit with-clauses. + + * exp_ch3.adb (Build_Class_Wide_Master): Avoid marking masters + associated with return statements because this work is now done by + Check_Anonymous_Return. + (Build_Master): Code cleanup. + +2009-04-15 Thomas Quinot + + * sem_warn.ads: Minor reformatting + +2009-04-15 Ed Schonberg + + * sem_ch3.adb: better error message for illegal interfaces + + * sem_ch6.adb (Possible_Freeze): Delay freezing a subprogram if a + formal is an incomplete type from a limited_with clause. + +2009-04-15 Vincent Celier + + * prj-nmsc.adb (Locate_Directory): New Boolean parameter + Externally_Built indicating if the project is externally built. If it + is, and --subdirs is specified, but the subdir does not exist, look + for the specified directory, without the subdir. + +2009-04-15 Gary Dismukes + + * a-tasatt.adb: Fix typo, plus minor reformatting + + * sem_ch3.ads: Add missing hyphen ("class wide" => "class-wide"). + + * sem_ch10.adb: Add missing hyphen ("use visible" => "use-visible"). + +2009-04-15 Ed Schonberg + + * sem_ch3.adb (Analyze_Private_Extension_Declaration): Verify that a + private extension whose parent is a synchronized interface carries an + explicit synchronized keyword. + +2009-04-15 Thomas Quinot + + * exp_smem.adb (Make_Shared_Var_Procs): For a protected type, + instantiate generic shared object package with the corresponding + record type. + +2009-04-15 Arnaud Charlet + + * system-linux-sparc.ads: Remove obsolete entries. + +2009-04-15 Thomas Quinot + + * s-tasuti.ads: Add ??? comment + +2009-04-15 Ed Schonberg + + * sem_ch3.adb (Analyze_Type_Declaration): Create freeze node for access + type even if the designated type comes from a limited_with clause, to + ensure that the symbol for the finalization list of the access type is + created. + +2009-04-10 Robert Dewar + + * sem_warn.ads, sem_warn.adb (Check_Low_Bound_Tested): Catch more cases + for warning suppression. + +2009-04-10 Ed Schonberg + + * sem_ch8.adb (Use_One_Type): If the two use_type clauses are + identical, there is no redudancy to check. + +2009-04-10 Gary Dismukes + + * exp_ch5.adb (Expand_N_Extended_Return_Statement): Delete redundant + calls initializing SS_Allocator (which is initialized in following + code). + (Expand_Simple_Function_Return): Add comment about False value for + Comes_From_Source on secondary-stack allocator. + + * exp_ch9.adb (Build_Entry_Family_Name): Add comment. + (Build_Entry_Name): Add comment. + +2009-04-10 Robert Dewar + + * einfo.ads, einfo.adb (Low_Bound_Tested): New name for Low_Bound_Known + + * sem_prag.adb (Analyze_Pragma, case Check): Remove check for lower + bound tested, since this is now done more generally in Sem_Res. + + * sem_res.adb (Resolve_Comparison_Op): Add call to + Check_Lower_Bound_Tested. + (Resolve_Equality_Op): Add call to Check_Lower_Bound_Tested + + * sem_warn.ads, sem_warn.adb (Check_Low_Bound_Tested): New procedure + (Low_Bound_Tested): New name for Low_Bound_Known flag + + * exp_ch5.adb: Minor reformatting + + * exp_ch4.adb: + Add comments on copying the Comes_From_Source flag for allocators + + * sinfo.ads: + Add comments on copying the Comes_From_Source flag for allocators + + * exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Copy + Comes_From_Source flag from old allocator to new one. + +2009-04-10 Ed Schonberg + + * sem_ch6.ads: Address missing documentation query + +2009-04-10 Vincent Celier + + * prj-attr.adb: + Add new Linker attributes Max_Command_Line_Length, Response_File_Format + and Response_File_Switches. + + * prj-nmsc.adb (Process_Linker): Process new attributes + Max_Command_Line_Length, Response_File_Format and + Response_File_Switches. + + * prj.ads (Response_File_Format): New enumeration type + (Project_Configuration): New componants Max_Command_Line_Length, + Resp_File_Format and Resp_File_Options. + + * snames.ads-tmpl: Add new standard names for linking response files + for gprbuild: GNU, None, Object_List, Option_List, + Max_Command_Line_Length, Response_File_Format and + Response_File_Switches. + +2009-04-10 Geert Bosch + + * system-aix.ads, system-darwin-ppc.ads, system-darwin-x86.ads, + system-freebsd-x86.ads, system-hpux.ads, system-hpux-ia64.ads, + system-irix-n32.ads, system-irix-o32.ads, system-linux-alpha.ads, + system-linux-hppa.ads, system-linux-ia64.ads, system-linux-ppc.ads, + system-linux-s390.ads, system-linux-s390x.ads, system-linux-sh4.ads, + system-linux-sparc.ads, system-linux-x86_64.ads, system-linux-x86.ads, + system-mingw.ads, system-solaris-sparc.ads, system-solaris-sparcv9.ads, + system-solaris-x86.ads, system-tru64.ads, system-vms_64.ads, + system-vms.ads, system-vms-ia64.ads, system-vms-zcx.ads, + system-vxworks-arm.ads, system-vxworks-m68k.ads, + system-vxworks-mips.ads, system-vxworks-ppc.ads, + system-vxworks-sparcv9.ads, system-vxworks-x86.ads + (Backend_Overflow_Checks): Set to True. + +2009-04-10 Thomas Quinot + + * exp_attr.adb: Minor reformatting + +2009-04-10 Ed Schonberg + + * sem_prag.adb (Check_Precondition_Postcondition): Within a generic, + analyze the expression for a postcondition, even if the compiler mode + is Generate_Code. + +2009-04-10 Robert Dewar + + * sem_aux.adb: Minor reformatting + +2009-04-10 Ed Falis + + * init.c: Change VxWorks 6 stack overflow checking for kernel apps. + + * system-vxworks-ppc.ads, system-vxworks-x86.ads: Update header. + +2009-04-10 Thomas Quinot + + * sem_ch6.ads (Check_Subtype_Conformant): Add ??? comment for + undocumented formal. + Minor reformatting + + * a-direio.ads: Fix typo in comment + + * sem_ch3.adb, g-dirope.adb, sem_type.adb, sem_ch12.adb, sem_case.adb, + errout.adb, sem_ch4.adb, sem_ch11.adb, exp_dist.adb, sem_ch13.adb: + Use uniform phrasing for comment at start of subprogram body. + + * xsnamest.adb: Add note to explain why we use specific names for the + newly generated files instead of generating snames.{ads,adb,h} directly + +2009-04-10 Sergey Rybin + + * vms_data.ads: + Add qualifier for new gnatstub option '--no-exception' + + * gnat_ugn.texi: + Add the description of the new gnatstub option '--no-exception' + +2009-04-10 Robert Dewar + + * rtsfind.adb: Minor reformatting + +2009-04-10 Thomas Quinot + + * sem_disp.adb: Minor reformatting. + Add comment pointing to RM clause for the case of warning against a + (failed) attempt at declaring a primitive operation elsewhere than in a + package spec. + +2009-04-10 Ed Schonberg + + * sem_ch12.adb (Denotes_Formal_Package): Check whether the package is + an actual for a previous formal package of the current instance. + +2009-04-10 Bob Duff + + * rtsfind.adb (RTE): Put implicit with_clauses on whatever unit needs + them first, rather than on the extended main unit. + +2009-04-10 Ed Schonberg + + * sem_ch6.adb (Check_Discriminant_Conformance): If discriminant + specification of full view carries a null exclusion indicator, create + an itype for it, to check for conformance with partial view. + +2009-04-10 Bob Duff + + * rtsfind.ads: Minor code change: make RE_Unit_Table constant. + + * rtsfind.adb: Minor comment changes, and remove useless code. + + * sinfo.ads: Add ??? comment. + +2009-04-10 Vincent Celier + + * vms_data.ads: Add missing GNAT SYNC VMS qualifiers -main= and -U + +2009-04-10 Ed Schonberg + + * exp_attr.adb (Expand_N_Attribute_Reference, case 'Tag): If the tagged + type is a synchronized type, retrieve tag information from the + corresponding record, which has the dispatch table link. + +2009-04-10 Jerome Lambourg + + * g-comlin.adb (Group_Analysis): Take care of switches that might be + decomposed afterwards, but are present as-is in the command line + configuration, and thus should be kept as-is. + +2009-04-10 Robert Dewar + + * gnat_rm.texi: Document that postconditions are tested on implicit + returns. + + * sem_aux.adb: Minor reformatting + +2009-04-10 Gary Dismukes + + * itypes.adb (Create_Null_Excluding_Itype): Apply Base_Type when + setting Etype. + + * par-ch3.adb (P_Access_Type_Definition): Set new attribute + Null_Exclusion_In_Return_Present when an access-to-function type has a + result type with an explicit not null. + + * sem_ch3.adb (Access_Subprogram_Definition): If a null exclusion is + given on the result type, then create a null-excluding itype for the + function. + + * sem_ch6.adb (Analyze_Return_Type): Create a null-excluding itype in + the case where a null exclusion is imposed on a named access type. + (Analyze_Subprogram_Specification): Push and pop the scope of the + function around the call to Analyze_Return_Type in the case of no + formals, for consistency with handling when formals are present + (Process_Formals does this). Ensures that any itype created for the + return type will be associated with the proper scope. + + * sem_ch12.adb (Analyze_Generic_Subprogram_Declaration): If a null + exclusion is given on a generic function's result type, then create a + null-excluding itype for the generic function. + (Instantiate_Object): Set Null_Exclusion_Present of a constant created + for an actual for a formal in object according to the setting on the + formal. Ensures null exclusion checks are done when the association is + elaborated. + + * sinfo.ads: Add new flag Null_Exclusion_In_Return_Present on + N_Access_Function_Definition. + + * sinfo.adb: Add Get_ and Set_ operations for + Null_Exclusion_In_Return_Present. + +2009-04-10 Bob Duff + + * exp_ch5.adb, exp_ch6.adb, sem_ch6.adb: Move the code that creates a + call to the _Postconditions procedure in the case of implicit returns + from analysis to expansion. This eliminates some duplicated code. Use + the Postcondition_Proc to find the identity of this procedure during + expansion. + +2009-04-10 Robert Dewar + + * sem_ch6.adb: Minor code clean up. + + * einfo.ads, sem_attr.adb: Minor comment fixes. + +2009-04-10 Robert Dewar + + * sem_ch8.adb: Minor reformatting + +2009-04-10 Robert Dewar + + * einfo.ads, einfo.adb (Postcondition_Proc): New attribute for + procedures. + + * sem_ch6.adb: Minor code clean up. + +2009-04-10 Robert Dewar + + * mlib-tgt-specific-xi.adb: Minor reformatting + +2009-04-10 Bob Duff + + * einfo.ads: Minor comment fixes + +2009-04-10 Vincent Celier + + * snames.ads-tmpl: Remove names that are no longer used in the + Project Manager. + Mark specifically those that are used only in gprbuild + +2009-04-10 Eric Botcazou + + * init.c: Adjust EH support code on Alpha/Tru64. + +2009-04-10 Bob Duff + + * sem_ch6.adb (Process_PPCs): Add a call to the _Postconditions + procedure on every path that could return implicitly (not via a return + statement) from a procedure. + +2009-04-10 Ed Schonberg + + * exp_ch9.adb (Build_Master_Entity): An extended return statement is a + valid scope for a task declarations and therefore for a master id. + +2009-04-10 Robert Dewar + + * sem_aux.adb: Minor reformatting + +2009-04-10 Vincent Celier + + * scn.adb (Obsolescent_Check_Flag): New Boolean flag, initialized to + True. + (Obsolescent_Check): Do nothing if Obsolescent_Check_Flag is False + (Set_Obsolescent_Check): New procedure to change the value of + Obsolescent_Check_Flag. + + * scn.ads (Set_Obsolescent_Check): New procedure to control + Obsolescent_Check. + + * sinput-l.adb (Load_File): Do not check for pragma Restrictions on + obsolescent features while preprocessing. + +2009-04-10 Thomas Quinot + + * xsnamest.adb: Use XUtil to have uniform line endings (UNIX style) in + generated files on all platforms. + +2009-04-10 Robert Dewar + + * sem_aux.adb: Minor reformatting + +2009-04-10 Ed Schonberg + + * sem_ch3.adb (Access_Definition): Handle properly the case of a + protected function with formals that returns an anonymous access type. + +2009-04-10 Thomas Quinot + + * sem_disp.adb: Minor reformatting + +2009-04-10 Vasiliy Fofanov + + * seh_init.c: Do not use the 32-bit specific implementation of + __gnat_install_SEH_handler on 64-bit Windows target (64-bit specific + version TBD). + +2009-04-10 Jose Ruiz + + * mlib-tgt-specific-xi.adb (Get_Target_Prefix): Target_Name may contain + a '/' at the end so we better use the complete target name to determine + whether it is a PowerPC 55xx target. + +2009-04-10 Thomas Quinot + + * sem_eval.adb: Minor reformatting + +2009-04-10 Thomas Quinot + + * snames.h, snames.ads, snames.adb: Remove files, now generated from + templates. + + * snames.h-tmpl, snames.ads-tmpl, snames.adb-tmpl: Templates for the + above. + + * xsnamest.adb: New file. + + * gcc-interface/Make-lang.in: New target for automated generation of + snames.ads, snames.adb and snames.h + +2009-04-10 Tristan Gingold + + * gcc-interface/Makefile.in, gcc-interface/utils.c: Include "rtl.h" to + avoid compile time warnings. + Do not add gcc/config in include search list while compiling the RTS. + Pragma Thread_Local_Storage is available on any target. + +2009-04-10 Bob Duff + + * sem.ads, par.adb, sem_ch6.adb, sem_ch8.adb: Minor comment fixes. + +2009-04-10 Tristan Gingold + + * init.c: Install signal handler on Darwin. + +2009-04-10 Robert Dewar + + * sem_prag.adb: Minor reformatting + + * exp_util.adb (Make_Non_Empty_Check): New function + (Silly_Boolean_Array_Not_Test): Add call to Make_Non_Empty_Check + (Silly_Boolean_Array_Xor_Test): Use Make_Non_Empty_Check + +2009-04-10 Arnaud Charlet + + * make.adb, gnatlink.adb: Rename JGNAT toolchain. + +2009-04-10 Jose Ruiz + + * mlib-tgt-specific-xi.adb (Get_Target_Prefix): Insert the appropriate + tool prefix for AVR and PowerPC 55xx targets. + +2009-04-10 Robert Dewar + + * sem_warn.adb (Within_Postcondition): New function + (Check_Unset_Reference): Use Within_Postcondition to stop bad warning + +2009-04-10 Robert Dewar + + * sem_warn.adb: Minor reformatting + + * make.adb: Minor reformatting. + +2009-04-10 Gary Dismukes + + * exp_ch7.adb (Find_Final_List): When creating a finalization-chain + entity and the scope is a subprogram, retrieve the Sloc of the + subprogram's body rather than using the sloc of the spec, for better + line-stepping behavior in gdb. + (Wrap_Transient_Declaration): For the Sloc of nodes created with a list + controller, use the Sloc of the first declaration of the containing list + rather than that of the node that triggered creation of the list + controller. + +2009-04-10 Vincent Celier + + * prj-nmsc.adb (Check_Naming_Schemes): Initialize local variable Casing + to avoid gcc warning. + +2009-04-10 Robert Dewar + + * g-comlin.adb: Add ??? comment + +2009-04-10 Ed Schonberg + + * sem_warn.adb (Check_Unused_Withs): Do not emit message about + unreferenced entities for a package with no visible declarations. + +2009-04-10 Robert Dewar + + * exp_ch9.adb: Minor reformatting + +2009-04-10 Thomas Quinot + + * sem_prag.adb: Minor reformatting + +2009-04-10 Vincent Celier + + * prj-nmsc.adb: + (Check_Library_Attributes): For a project qualified as a library project + that is not a library project, indicate in the error message which + attributes are missing (Library_Dir and/or Library_Name). + +2009-04-10 Bob Duff + + * exp_ch5.adb, exp_ch9.adb: Avoid use of No_Position in Sloc of + generated nodes, because it might confuse various circuits in the FE. + +2009-04-10 Ed Schonberg + + * sem_prag.adb (Analyze_Pragma, case Task_Name): Do not expand argument + of pragma. It will be recopied and analyzed when used in call to + Create_Task. + + * sem_res.adb (Resolve_Call): Clarify use of secondary stack within + initialization operations and recognize use of it in procedure calls + within init_procs. + + * exp_ch9.adb (Make_Task_Create_Call): Copy full tree of Task_Name + argument, because it may have side-effects. + + * exp_ch2.adb: Remove obsolete comments on default functions + +2009-04-10 Jose Ruiz + + * adaint.c (RTX section): Do for RTX the same thing as we do for + Windows (include ctype.h and define a fallback ISALPHA if IN_RTS). + +2009-04-10 Robert Dewar + + * sem_aux.ads, sem_aux.adb (Nearest_Current_Scope): New function. + + * sem_res.adb (Resolve_Call): Fix test for + Suppress_Value_Tracking_On_Call (was wrong for the case of a call from + a non-dynamic scope). + +2009-04-10 Robert Dewar + + * make.adb: Add comment. + Minor reformatting + +2009-04-10 Nicolas Setton + + * s-osprim-darwin.adb: New file. + + * s-osinte-darwin.adb, s-osinte-darwin.ads: Fix binding to timespec. + +2009-04-10 Thomas Quinot + + * g-socket.ads: Add comment clarifying alignment requirement for Fd_Set + +2009-04-09 Nick Clifton + + * adadecode.h: Change copyright header to refer to version + 3 of the GNU General Public License with version 3.1 of the + GCC Runtime Library Exception and to point readers at the + COPYING3 and COPYING3.RUNTIME files and the FSF's license web + page. + * 9drpc.adb: Likewise. + * a-assert.adb: Likewise. + * a-astaco.adb: Likewise. + * a-calari.adb: Likewise. + * a-calcon.adb: Likewise. + * a-calcon.ads: Likewise. + * a-caldel.ads: Likewise. + * a-calend-vms.adb: Likewise. + * a-calend-vms.ads: Likewise. + * a-calend.adb: Likewise. + * a-calend.ads: Likewise. + * a-calfor.adb: Likewise. + * a-catizo.adb: Likewise. + * a-cdlili.adb: Likewise. + * a-cdlili.ads: Likewise. + * a-cgaaso.adb: Likewise. + * a-cgaaso.ads: Likewise. + * a-cgarso.adb: Likewise. + * a-cgcaso.adb: Likewise. + * a-chacon.adb: Likewise. + * a-chacon.ads: Likewise. + * a-chahan.adb: Likewise. + * a-chahan.ads: Likewise. + * a-chlat9.ads: Likewise. + * a-chtgke.adb: Likewise. + * a-chtgke.ads: Likewise. + * a-chtgop.adb: Likewise. + * a-chtgop.ads: Likewise. + * a-chzla1.ads: Likewise. + * a-chzla9.ads: Likewise. + * a-cidlli.adb: Likewise. + * a-cidlli.ads: Likewise. + * a-cihama.adb: Likewise. + * a-cihama.ads: Likewise. + * a-cihase.adb: Likewise. + * a-cihase.ads: Likewise. + * a-ciorma.adb: Likewise. + * a-ciorma.ads: Likewise. + * a-ciormu.adb: Likewise. + * a-ciormu.ads: Likewise. + * a-ciorse.adb: Likewise. + * a-ciorse.ads: Likewise. + * a-clrefi.adb: Likewise. + * a-clrefi.ads: Likewise. + * a-cohama.adb: Likewise. + * a-cohama.ads: Likewise. + * a-cohase.adb: Likewise. + * a-cohase.ads: Likewise. + * a-cohata.ads: Likewise. + * a-coinve.adb: Likewise. + * a-coinve.ads: Likewise. + * a-colien.adb: Likewise. + * a-colien.ads: Likewise. + * a-colire.adb: Likewise. + * a-colire.ads: Likewise. + * a-comlin.adb: Likewise. + * a-comlin.ads: Likewise. + * a-convec.adb: Likewise. + * a-convec.ads: Likewise. + * a-coorma.adb: Likewise. + * a-coorma.ads: Likewise. + * a-coormu.adb: Likewise. + * a-coormu.ads: Likewise. + * a-coorse.adb: Likewise. + * a-coorse.ads: Likewise. + * a-coprnu.adb: Likewise. + * a-coprnu.ads: Likewise. + * a-crbltr.ads: Likewise. + * a-crbtgk.adb: Likewise. + * a-crbtgk.ads: Likewise. + * a-crbtgo.adb: Likewise. + * a-crbtgo.ads: Likewise. + * a-crdlli.adb: Likewise. + * a-crdlli.ads: Likewise. + * a-cwila1.ads: Likewise. + * a-cwila9.ads: Likewise. + * a-decima.adb: Likewise. + * a-decima.ads: Likewise. + * a-diocst.adb: Likewise. + * a-diocst.ads: Likewise. + * a-direct.adb: Likewise. + * a-direct.ads: Likewise. + * a-direio.adb: Likewise. + * a-direio.ads: Likewise. + * a-dirval-mingw.adb: Likewise. + * a-dirval-vms.adb: Likewise. + * a-dirval.adb: Likewise. + * a-dirval.ads: Likewise. + * a-dynpri.adb: Likewise. + * a-einuoc.adb: Likewise. + * a-einuoc.ads: Likewise. + * a-elchha.adb: Likewise. + * a-elchha.ads: Likewise. + * a-envvar.adb: Likewise. + * a-excach.adb: Likewise. + * a-except-2005.adb: Likewise. + * a-except-2005.ads: Likewise. + * a-except.adb: Likewise. + * a-except.ads: Likewise. + * a-excpol-abort.adb: Likewise. + * a-excpol.adb: Likewise. + * a-exctra.adb: Likewise. + * a-exctra.ads: Likewise. + * a-exetim-mingw.adb: Likewise. + * a-exetim-mingw.ads: Likewise. + * a-exexda.adb: Likewise. + * a-exexpr-gcc.adb: Likewise. + * a-exexpr.adb: Likewise. + * a-exextr.adb: Likewise. + * a-exstat.adb: Likewise. + * a-filico.adb: Likewise. + * a-filico.ads: Likewise. + * a-finali.adb: Likewise. + * a-finali.ads: Likewise. + * a-interr.ads: Likewise. + * a-intnam-aix.ads: Likewise. + * a-intnam-darwin.ads: Likewise. + * a-intnam-dummy.ads: Likewise. + * a-intnam-freebsd.ads: Likewise. + * a-intnam-hpux.ads: Likewise. + * a-intnam-irix.ads: Likewise. + * a-intnam-linux.ads: Likewise. + * a-intnam-lynxos.ads: Likewise. + * a-intnam-mingw.ads: Likewise. + * a-intnam-rtems.ads: Likewise. + * a-intnam-solaris.ads: Likewise. + * a-intnam-tru64.ads: Likewise. + * a-intnam-vms.ads: Likewise. + * a-intnam-vxworks.ads: Likewise. + * a-intsig.adb: Likewise. + * a-intsig.ads: Likewise. + * a-ngcefu.adb: Likewise. + * a-ngcoar.adb: Likewise. + * a-ngcoty.adb: Likewise. + * a-ngcoty.ads: Likewise. + * a-ngelfu.adb: Likewise. + * a-ngrear.adb: Likewise. + * a-ngrear.ads: Likewise. + * a-nudira.adb: Likewise. + * a-nudira.ads: Likewise. + * a-nuflra.adb: Likewise. + * a-nuflra.ads: Likewise. + * a-numaux-darwin.adb: Likewise. + * a-numaux-darwin.ads: Likewise. + * a-numaux-libc-x86.ads: Likewise. + * a-numaux-vxworks.ads: Likewise. + * a-numaux-x86.adb: Likewise. + * a-numaux-x86.ads: Likewise. + * a-numaux.ads: Likewise. + * a-rbtgso.adb: Likewise. + * a-rbtgso.ads: Likewise. + * a-reatim.ads: Likewise. + * a-retide.adb: Likewise. + * a-retide.ads: Likewise. + * a-rttiev.adb: Likewise. + * a-rttiev.ads: Likewise. + * a-secain.adb: Likewise. + * a-secain.ads: Likewise. + * a-sequio.adb: Likewise. + * a-sequio.ads: Likewise. + * a-shcain.adb: Likewise. + * a-shcain.ads: Likewise. + * a-siocst.adb: Likewise. + * a-siocst.ads: Likewise. + * a-slcain.adb: Likewise. + * a-slcain.ads: Likewise. + * a-ssicst.adb: Likewise. + * a-ssicst.ads: Likewise. + * a-stboha.adb: Likewise. + * a-stmaco.ads: Likewise. + * a-storio.adb: Likewise. + * a-strbou.adb: Likewise. + * a-strbou.ads: Likewise. + * a-stream.ads: Likewise. + * a-strfix.adb: Likewise. + * a-strhas.adb: Likewise. + * a-strmap.adb: Likewise. + * a-strmap.ads: Likewise. + * a-strsea.adb: Likewise. + * a-strsea.ads: Likewise. + * a-strsup.adb: Likewise. + * a-strsup.ads: Likewise. + * a-strunb.adb: Likewise. + * a-strunb.ads: Likewise. + * a-ststio.adb: Likewise. + * a-ststio.ads: Likewise. + * a-stunau.adb: Likewise. + * a-stunau.ads: Likewise. + * a-stunha.adb: Likewise. + * a-stwibo.adb: Likewise. + * a-stwibo.ads: Likewise. + * a-stwifi.adb: Likewise. + * a-stwiha.adb: Likewise. + * a-stwima.adb: Likewise. + * a-stwima.ads: Likewise. + * a-stwise.adb: Likewise. + * a-stwise.ads: Likewise. + * a-stwisu.adb: Likewise. + * a-stwisu.ads: Likewise. + * a-stwiun.adb: Likewise. + * a-stwiun.ads: Likewise. + * a-stzbou.adb: Likewise. + * a-stzbou.ads: Likewise. + * a-stzfix.adb: Likewise. + * a-stzhas.adb: Likewise. + * a-stzmap.adb: Likewise. + * a-stzmap.ads: Likewise. + * a-stzsea.adb: Likewise. + * a-stzsea.ads: Likewise. + * a-stzsup.adb: Likewise. + * a-stzsup.ads: Likewise. + * a-stzunb.adb: Likewise. + * a-stzunb.ads: Likewise. + * a-suteio.adb: Likewise. + * a-suteio.ads: Likewise. + * a-swbwha.adb: Likewise. + * a-swmwco.ads: Likewise. + * a-swunau.adb: Likewise. + * a-swunau.ads: Likewise. + * a-swuwha.adb: Likewise. + * a-swuwti.adb: Likewise. + * a-swuwti.ads: Likewise. + * a-sytaco.adb: Likewise. + * a-sytaco.ads: Likewise. + * a-szbzha.adb: Likewise. + * a-szmzco.ads: Likewise. + * a-szunau.adb: Likewise. + * a-szunau.ads: Likewise. + * a-szuzha.adb: Likewise. + * a-szuzti.adb: Likewise. + * a-szuzti.ads: Likewise. + * a-tags.adb: Likewise. + * a-tags.ads: Likewise. + * a-tasatt.ads: Likewise. + * a-taside.adb: Likewise. + * a-taside.ads: Likewise. + * a-taster.adb: Likewise. + * a-teioed.adb: Likewise. + * a-teioed.ads: Likewise. + * a-textio.adb: Likewise. + * a-textio.ads: Likewise. + * a-tiboio.adb: Likewise. + * a-ticoau.adb: Likewise. + * a-ticoau.ads: Likewise. + * a-ticoio.adb: Likewise. + * a-ticoio.ads: Likewise. + * a-tideau.adb: Likewise. + * a-tideau.ads: Likewise. + * a-tideio.adb: Likewise. + * a-tideio.ads: Likewise. + * a-tienau.adb: Likewise. + * a-tienau.ads: Likewise. + * a-tienio.adb: Likewise. + * a-tienio.ads: Likewise. + * a-tifiio.adb: Likewise. + * a-tifiio.ads: Likewise. + * a-tiflau.adb: Likewise. + * a-tiflau.ads: Likewise. + * a-tiflio.adb: Likewise. + * a-tiflio.ads: Likewise. + * a-tigeau.adb: Likewise. + * a-tigeau.ads: Likewise. + * a-tiinau.adb: Likewise. + * a-tiinau.ads: Likewise. + * a-tiinio.adb: Likewise. + * a-tiinio.ads: Likewise. + * a-timoau.adb: Likewise. + * a-timoau.ads: Likewise. + * a-timoio.adb: Likewise. + * a-timoio.ads: Likewise. + * a-tiocst.adb: Likewise. + * a-tiocst.ads: Likewise. + * a-titest.adb: Likewise. + * a-wichun.adb: Likewise. + * a-wichun.ads: Likewise. + * a-witeio.adb: Likewise. + * a-witeio.ads: Likewise. + * a-wtcoau.adb: Likewise. + * a-wtcoau.ads: Likewise. + * a-wtcoio.adb: Likewise. + * a-wtcstr.adb: Likewise. + * a-wtcstr.ads: Likewise. + * a-wtdeau.adb: Likewise. + * a-wtdeau.ads: Likewise. + * a-wtdeio.adb: Likewise. + * a-wtdeio.ads: Likewise. + * a-wtedit.adb: Likewise. + * a-wtedit.ads: Likewise. + * a-wtenau.adb: Likewise. + * a-wtenau.ads: Likewise. + * a-wtenio.adb: Likewise. + * a-wtenio.ads: Likewise. + * a-wtfiio.adb: Likewise. + * a-wtfiio.ads: Likewise. + * a-wtflau.adb: Likewise. + * a-wtflau.ads: Likewise. + * a-wtflio.adb: Likewise. + * a-wtflio.ads: Likewise. + * a-wtgeau.adb: Likewise. + * a-wtgeau.ads: Likewise. + * a-wtinau.adb: Likewise. + * a-wtinau.ads: Likewise. + * a-wtinio.adb: Likewise. + * a-wtmoau.adb: Likewise. + * a-wtmoau.ads: Likewise. + * a-wtmoio.adb: Likewise. + * a-wtmoio.ads: Likewise. + * a-wttest.adb: Likewise. + * a-wwboio.adb: Likewise. + * a-zchuni.adb: Likewise. + * a-zchuni.ads: Likewise. + * a-ztcoau.adb: Likewise. + * a-ztcoau.ads: Likewise. + * a-ztcoio.adb: Likewise. + * a-ztcstr.adb: Likewise. + * a-ztcstr.ads: Likewise. + * a-ztdeau.adb: Likewise. + * a-ztdeau.ads: Likewise. + * a-ztdeio.adb: Likewise. + * a-ztdeio.ads: Likewise. + * a-ztedit.adb: Likewise. + * a-ztedit.ads: Likewise. + * a-ztenau.adb: Likewise. + * a-ztenau.ads: Likewise. + * a-ztenio.adb: Likewise. + * a-ztenio.ads: Likewise. + * a-ztexio.adb: Likewise. + * a-ztexio.ads: Likewise. + * a-ztfiio.adb: Likewise. + * a-ztfiio.ads: Likewise. + * a-ztflau.adb: Likewise. + * a-ztflau.ads: Likewise. + * a-ztflio.adb: Likewise. + * a-ztflio.ads: Likewise. + * a-ztgeau.adb: Likewise. + * a-ztgeau.ads: Likewise. + * a-ztinau.adb: Likewise. + * a-ztinau.ads: Likewise. + * a-ztinio.adb: Likewise. + * a-ztmoau.adb: Likewise. + * a-ztmoau.ads: Likewise. + * a-ztmoio.adb: Likewise. + * a-ztmoio.ads: Likewise. + * a-zttest.adb: Likewise. + * a-zzboio.adb: Likewise. + * adadecode.c: Likewise. + * adaint.c: Likewise. + * adaint.h: Likewise. + * alloc.ads: Likewise. + * argv.c: Likewise. + * arit64.c: Likewise. + * atree.adb: Likewise. + * atree.ads: Likewise. + * aux-io.c: Likewise. + * cal.c: Likewise. + * casing.adb: Likewise. + * casing.ads: Likewise. + * cio.c: Likewise. + * csets.adb: Likewise. + * csets.ads: Likewise. + * cstreams.c: Likewise. + * ctrl_c.c: Likewise. + * debug.adb: Likewise. + * debug.ads: Likewise. + * dec.ads: Likewise. + * einfo.adb: Likewise. + * einfo.ads: Likewise. + * elists.adb: Likewise. + * elists.ads: Likewise. + * env.c: Likewise. + * env.h: Likewise. + * errno.c: Likewise. + * exit.c: Likewise. + * fe.h: Likewise. + * final.c: Likewise. + * fname.adb: Likewise. + * fname.ads: Likewise. + * g-allein.ads: Likewise. + * g-alleve.adb: Likewise. + * g-alleve.ads: Likewise. + * g-altcon.adb: Likewise. + * g-altcon.ads: Likewise. + * g-altive.ads: Likewise. + * g-alveop.adb: Likewise. + * g-alveop.ads: Likewise. + * g-alvety.ads: Likewise. + * g-alvevi.ads: Likewise. + * g-arrspl.adb: Likewise. + * g-arrspl.ads: Likewise. + * g-calend.ads: Likewise. + * g-comlin.adb: Likewise. + * g-debpoo.adb: Likewise. + * g-debpoo.ads: Likewise. + * g-eacodu-vms.adb: Likewise. + * g-eacodu.adb: Likewise. + * g-excact.adb: Likewise. + * g-excact.ads: Likewise. + * g-locfil.adb: Likewise. + * g-os_lib.ads: Likewise. + * g-rannum.adb: Likewise. + * g-rannum.ads: Likewise. + * g-regist.adb: Likewise. + * g-regist.ads: Likewise. + * g-signal.adb: Likewise. + * g-signal.ads: Likewise. + * g-soccon.ads: Likewise. + * g-string.adb: Likewise. + * g-string.ads: Likewise. + * g-strspl.ads: Likewise. + * g-timsta.adb: Likewise. + * g-timsta.ads: Likewise. + * g-trasym-vms-alpha.adb: Likewise. + * g-trasym-vms-ia64.adb: Likewise. + * g-utf_32.adb: Likewise. + * g-utf_32.ads: Likewise. + * g-wistsp.ads: Likewise. + * g-zstspl.ads: Likewise. + * gmem.c: Likewise. + * gnatvsn.adb: Likewise. + * gnatvsn.ads: Likewise. + * gsocket.h: Likewise. + * hostparm.ads: Likewise. + * i-c.adb: Likewise. + * i-cexten.ads: Likewise. + * i-cobol.adb: Likewise. + * i-cobol.ads: Likewise. + * i-cpoint.adb: Likewise. + * i-cpoint.ads: Likewise. + * i-cpp.adb: Likewise. + * i-cpp.ads: Likewise. + * i-cstrea-vms.adb: Likewise. + * i-cstrea.adb: Likewise. + * i-cstrea.ads: Likewise. + * i-cstrin.adb: Likewise. + * i-cstrin.ads: Likewise. + * i-forbla-darwin.adb: Likewise. + * i-forbla-unimplemented.ads: Likewise. + * i-forbla.adb: Likewise. + * i-forbla.ads: Likewise. + * i-forlap.ads: Likewise. + * i-fortra.adb: Likewise. + * i-pacdec.adb: Likewise. + * i-pacdec.ads: Likewise. + * i-vxwoio.adb: Likewise. + * i-vxwoio.ads: Likewise. + * indepsw-aix.adb: Likewise. + * indepsw-gnu.adb: Likewise. + * indepsw-mingw.adb: Likewise. + * indepsw.adb: Likewise. + * indepsw.ads: Likewise. + * init.c: Likewise. + * initialize.c: Likewise. + * interfac.ads: Likewise. + * krunch.adb: Likewise. + * krunch.ads: Likewise. + * lib-list.adb: Likewise. + * lib-sort.adb: Likewise. + * lib.adb: Likewise. + * lib.ads: Likewise. + * link.c: Likewise. + * math_lib.adb: Likewise. + * memtrack.adb: Likewise. + * mingw32.h: Likewise. + * mkdir.c: Likewise. + * namet-sp.adb: Likewise. + * namet-sp.ads: Likewise. + * namet.adb: Likewise. + * namet.ads: Likewise. + * nlists.adb: Likewise. + * nlists.ads: Likewise. + * opt.adb: Likewise. + * opt.ads: Likewise. + * output.adb: Likewise. + * output.ads: Likewise. + * raise-gcc.c: Likewise. + * raise.c: Likewise. + * raise.h: Likewise. + * repinfo.adb: Likewise. + * repinfo.ads: Likewise. + * repinfo.h: Likewise. + * rident.ads: Likewise. + * s-addima.adb: Likewise. + * s-addima.ads: Likewise. + * s-addope.adb: Likewise. + * s-addope.ads: Likewise. + * s-arit64.adb: Likewise. + * s-arit64.ads: Likewise. + * s-assert.adb: Likewise. + * s-assert.ads: Likewise. + * s-asthan-vms-alpha.adb: Likewise. + * s-asthan.adb: Likewise. + * s-asthan.ads: Likewise. + * s-atacco.adb: Likewise. + * s-atacco.ads: Likewise. + * s-auxdec-empty.adb: Likewise. + * s-auxdec-empty.ads: Likewise. + * s-auxdec-vms_64.ads: Likewise. + * s-auxdec.adb: Likewise. + * s-auxdec.ads: Likewise. + * s-bitops.adb: Likewise. + * s-bitops.ads: Likewise. + * s-boarop.ads: Likewise. + * s-carsi8.adb: Likewise. + * s-carsi8.ads: Likewise. + * s-carun8.adb: Likewise. + * s-carun8.ads: Likewise. + * s-casi16.adb: Likewise. + * s-casi16.ads: Likewise. + * s-casi32.adb: Likewise. + * s-casi32.ads: Likewise. + * s-casi64.adb: Likewise. + * s-casi64.ads: Likewise. + * s-casuti.ads: Likewise. + * s-caun16.adb: Likewise. + * s-caun16.ads: Likewise. + * s-caun32.adb: Likewise. + * s-caun32.ads: Likewise. + * s-caun64.adb: Likewise. + * s-caun64.ads: Likewise. + * s-chepoo.ads: Likewise. + * s-crc32.adb: Likewise. + * s-crc32.ads: Likewise. + * s-crtl.ads: Likewise. + * s-direio.adb: Likewise. + * s-direio.ads: Likewise. + * s-dsaser.ads: Likewise. + * s-except.adb: Likewise. + * s-except.ads: Likewise. + * s-exctab.adb: Likewise. + * s-exctab.ads: Likewise. + * s-exnint.adb: Likewise. + * s-exnint.ads: Likewise. + * s-exnllf.adb: Likewise. + * s-exnllf.ads: Likewise. + * s-exnlli.adb: Likewise. + * s-exnlli.ads: Likewise. + * s-expint.adb: Likewise. + * s-expint.ads: Likewise. + * s-explli.adb: Likewise. + * s-explli.ads: Likewise. + * s-expllu.adb: Likewise. + * s-expllu.ads: Likewise. + * s-expmod.adb: Likewise. + * s-expmod.ads: Likewise. + * s-expuns.adb: Likewise. + * s-expuns.ads: Likewise. + * s-fatflt.ads: Likewise. + * s-fatgen.adb: Likewise. + * s-fatgen.ads: Likewise. + * s-fatlfl.ads: Likewise. + * s-fatllf.ads: Likewise. + * s-fatsfl.ads: Likewise. + * s-ficobl.ads: Likewise. + * s-fileio.adb: Likewise. + * s-fileio.ads: Likewise. + * s-filofl.ads: Likewise. + * s-finimp.adb: Likewise. + * s-finimp.ads: Likewise. + * s-finroo.adb: Likewise. + * s-finroo.ads: Likewise. + * s-fishfl.ads: Likewise. + * s-fore.adb: Likewise. + * s-fore.ads: Likewise. + * s-fvadfl.ads: Likewise. + * s-fvaffl.ads: Likewise. + * s-fvagfl.ads: Likewise. + * s-gearop.adb: Likewise. + * s-gearop.ads: Likewise. + * s-gecobl.adb: Likewise. + * s-gecobl.ads: Likewise. + * s-gecola.adb: Likewise. + * s-gecola.ads: Likewise. + * s-gerebl.adb: Likewise. + * s-gerebl.ads: Likewise. + * s-gerela.adb: Likewise. + * s-gerela.ads: Likewise. + * s-geveop.adb: Likewise. + * s-geveop.ads: Likewise. + * s-gloloc.adb: Likewise. + * s-gloloc.ads: Likewise. + * s-hibaen.ads: Likewise. + * s-imenne.adb: Likewise. + * s-imenne.ads: Likewise. + * s-imgbiu.adb: Likewise. + * s-imgbiu.ads: Likewise. + * s-imgboo.adb: Likewise. + * s-imgboo.ads: Likewise. + * s-imgcha.adb: Likewise. + * s-imgcha.ads: Likewise. + * s-imgdec.adb: Likewise. + * s-imgdec.ads: Likewise. + * s-imgenu.adb: Likewise. + * s-imgenu.ads: Likewise. + * s-imgint.adb: Likewise. + * s-imgint.ads: Likewise. + * s-imgllb.adb: Likewise. + * s-imgllb.ads: Likewise. + * s-imglld.adb: Likewise. + * s-imglld.ads: Likewise. + * s-imglli.adb: Likewise. + * s-imglli.ads: Likewise. + * s-imgllu.adb: Likewise. + * s-imgllu.ads: Likewise. + * s-imgllw.adb: Likewise. + * s-imgllw.ads: Likewise. + * s-imgrea.adb: Likewise. + * s-imgrea.ads: Likewise. + * s-imguns.adb: Likewise. + * s-imguns.ads: Likewise. + * s-imgwch.adb: Likewise. + * s-imgwch.ads: Likewise. + * s-imgwiu.adb: Likewise. + * s-imgwiu.ads: Likewise. + * s-inmaop-dummy.adb: Likewise. + * s-inmaop-vms.adb: Likewise. + * s-inmaop.ads: Likewise. + * s-interr-hwint.adb: Likewise. + * s-interr-sigaction.adb: Likewise. + * s-interr-vms.adb: Likewise. + * s-interr.adb: Likewise. + * s-interr.ads: Likewise. + * s-intman-dummy.adb: Likewise. + * s-intman-mingw.adb: Likewise. + * s-intman-posix.adb: Likewise. + * s-intman-solaris.adb: Likewise. + * s-intman-vms.adb: Likewise. + * s-intman-vms.ads: Likewise. + * s-intman-vxworks.adb: Likewise. + * s-intman-vxworks.ads: Likewise. + * s-intman.ads: Likewise. + * s-io.adb: Likewise. + * s-io.ads: Likewise. + * s-linux-alpha.ads: Likewise. + * s-linux-hppa.ads: Likewise. + * s-linux.ads: Likewise. + * s-maccod.ads: Likewise. + * s-mantis.adb: Likewise. + * s-mantis.ads: Likewise. + * s-mastop-irix.adb: Likewise. + * s-mastop.adb: Likewise. + * s-mastop.ads: Likewise. + * s-memcop.ads: Likewise. + * s-memory-mingw.adb: Likewise. + * s-memory.adb: Likewise. + * s-memory.ads: Likewise. + * s-os_lib.ads: Likewise. + * s-oscons-tmplt.c: Likewise. + * s-osinte-aix.adb: Likewise. + * s-osinte-darwin.adb: Likewise. + * s-osinte-freebsd.adb: Likewise. + * s-osinte-irix.adb: Likewise. + * s-osinte-lynxos-3.adb: Likewise. + * s-osinte-rtems.ads: Likewise. + * s-osinte-tru64.adb: Likewise. + * s-osinte-vxworks-kernel.adb: Likewise. + * s-osinte-vxworks.adb: Likewise. + * s-osprim-mingw.adb: Likewise. + * s-osprim-posix.adb: Likewise. + * s-osprim-solaris.adb: Likewise. + * s-osprim-unix.adb: Likewise. + * s-osprim-vms.adb: Likewise. + * s-osprim-vms.ads: Likewise. + * s-osprim-vxworks.adb: Likewise. + * s-osprim.ads: Likewise. + * s-pack03.adb: Likewise. + * s-pack03.ads: Likewise. + * s-pack05.adb: Likewise. + * s-pack05.ads: Likewise. + * s-pack06.adb: Likewise. + * s-pack06.ads: Likewise. + * s-pack07.adb: Likewise. + * s-pack07.ads: Likewise. + * s-pack09.adb: Likewise. + * s-pack09.ads: Likewise. + * s-pack10.adb: Likewise. + * s-pack10.ads: Likewise. + * s-pack11.adb: Likewise. + * s-pack11.ads: Likewise. + * s-pack12.adb: Likewise. + * s-pack12.ads: Likewise. + * s-pack13.adb: Likewise. + * s-pack13.ads: Likewise. + * s-pack14.adb: Likewise. + * s-pack14.ads: Likewise. + * s-pack15.adb: Likewise. + * s-pack15.ads: Likewise. + * s-pack17.adb: Likewise. + * s-pack17.ads: Likewise. + * s-pack18.adb: Likewise. + * s-pack18.ads: Likewise. + * s-pack19.adb: Likewise. + * s-pack19.ads: Likewise. + * s-pack20.adb: Likewise. + * s-pack20.ads: Likewise. + * s-pack21.adb: Likewise. + * s-pack21.ads: Likewise. + * s-pack22.adb: Likewise. + * s-pack22.ads: Likewise. + * s-pack23.adb: Likewise. + * s-pack23.ads: Likewise. + * s-pack24.adb: Likewise. + * s-pack24.ads: Likewise. + * s-pack25.adb: Likewise. + * s-pack25.ads: Likewise. + * s-pack26.adb: Likewise. + * s-pack26.ads: Likewise. + * s-pack27.adb: Likewise. + * s-pack27.ads: Likewise. + * s-pack28.adb: Likewise. + * s-pack28.ads: Likewise. + * s-pack29.adb: Likewise. + * s-pack29.ads: Likewise. + * s-pack30.adb: Likewise. + * s-pack30.ads: Likewise. + * s-pack31.adb: Likewise. + * s-pack31.ads: Likewise. + * s-pack33.adb: Likewise. + * s-pack33.ads: Likewise. + * s-pack34.adb: Likewise. + * s-pack34.ads: Likewise. + * s-pack35.adb: Likewise. + * s-pack35.ads: Likewise. + * s-pack36.adb: Likewise. + * s-pack36.ads: Likewise. + * s-pack37.adb: Likewise. + * s-pack37.ads: Likewise. + * s-pack38.adb: Likewise. + * s-pack38.ads: Likewise. + * s-pack39.adb: Likewise. + * s-pack39.ads: Likewise. + * s-pack40.adb: Likewise. + * s-pack40.ads: Likewise. + * s-pack41.adb: Likewise. + * s-pack41.ads: Likewise. + * s-pack42.adb: Likewise. + * s-pack42.ads: Likewise. + * s-pack43.adb: Likewise. + * s-pack43.ads: Likewise. + * s-pack44.adb: Likewise. + * s-pack44.ads: Likewise. + * s-pack45.adb: Likewise. + * s-pack45.ads: Likewise. + * s-pack46.adb: Likewise. + * s-pack46.ads: Likewise. + * s-pack47.adb: Likewise. + * s-pack47.ads: Likewise. + * s-pack48.adb: Likewise. + * s-pack48.ads: Likewise. + * s-pack49.adb: Likewise. + * s-pack49.ads: Likewise. + * s-pack50.adb: Likewise. + * s-pack50.ads: Likewise. + * s-pack51.adb: Likewise. + * s-pack51.ads: Likewise. + * s-pack52.adb: Likewise. + * s-pack52.ads: Likewise. + * s-pack53.adb: Likewise. + * s-pack53.ads: Likewise. + * s-pack54.adb: Likewise. + * s-pack54.ads: Likewise. + * s-pack55.adb: Likewise. + * s-pack55.ads: Likewise. + * s-pack56.adb: Likewise. + * s-pack56.ads: Likewise. + * s-pack57.adb: Likewise. + * s-pack57.ads: Likewise. + * s-pack58.adb: Likewise. + * s-pack58.ads: Likewise. + * s-pack59.adb: Likewise. + * s-pack59.ads: Likewise. + * s-pack60.adb: Likewise. + * s-pack60.ads: Likewise. + * s-pack61.adb: Likewise. + * s-pack61.ads: Likewise. + * s-pack62.adb: Likewise. + * s-pack62.ads: Likewise. + * s-pack63.adb: Likewise. + * s-pack63.ads: Likewise. + * s-parame-ae653.ads: Likewise. + * s-parame-hpux.ads: Likewise. + * s-parame-rtems.adb: Likewise. + * s-parame-vms-alpha.ads: Likewise. + * s-parame-vms-ia64.ads: Likewise. + * s-parame-vms-restrict.ads: Likewise. + * s-parame-vxworks.adb: Likewise. + * s-parame-vxworks.ads: Likewise. + * s-parame.adb: Likewise. + * s-parame.ads: Likewise. + * s-parint.adb: Likewise. + * s-parint.ads: Likewise. + * s-pooglo.adb: Likewise. + * s-pooglo.ads: Likewise. + * s-pooloc.adb: Likewise. + * s-pooloc.ads: Likewise. + * s-poosiz.adb: Likewise. + * s-poosiz.ads: Likewise. + * s-powtab.ads: Likewise. + * s-proinf-irix-athread.adb: Likewise. + * s-proinf-irix-athread.ads: Likewise. + * s-proinf.adb: Likewise. + * s-proinf.ads: Likewise. + * s-purexc.ads: Likewise. + * s-rannum.adb: Likewise. + * s-rannum.ads: Likewise. + * s-restri.adb: Likewise. + * s-restri.ads: Likewise. + * s-rident.ads: Likewise. + * s-rpc.adb: Likewise. + * s-rpc.ads: Likewise. + * s-scaval.adb: Likewise. + * s-scaval.ads: Likewise. + * s-secsta.adb: Likewise. + * s-secsta.ads: Likewise. + * s-sequio.adb: Likewise. + * s-sequio.ads: Likewise. + * s-shasto.adb: Likewise. + * s-shasto.ads: Likewise. + * s-soflin.adb: Likewise. + * s-soflin.ads: Likewise. + * s-solita.adb: Likewise. + * s-solita.ads: Likewise. + * s-sopco3.adb: Likewise. + * s-sopco3.ads: Likewise. + * s-sopco4.adb: Likewise. + * s-sopco4.ads: Likewise. + * s-sopco5.adb: Likewise. + * s-sopco5.ads: Likewise. + * s-stache.adb: Likewise. + * s-stache.ads: Likewise. + * s-stalib.adb: Likewise. + * s-stalib.ads: Likewise. + * s-stausa.adb: Likewise. + * s-stausa.ads: Likewise. + * s-stchop-limit.ads: Likewise. + * s-stchop-rtems.adb: Likewise. + * s-stchop-vxworks.adb: Likewise. + * s-stchop.adb: Likewise. + * s-stchop.ads: Likewise. + * s-stoele.adb: Likewise. + * s-stoele.ads: Likewise. + * s-stopoo.adb: Likewise. + * s-stopoo.ads: Likewise. + * s-stratt.adb: Likewise. + * s-stratt.ads: Likewise. + * s-strcom.adb: Likewise. + * s-strcom.ads: Likewise. + * s-string.adb: Likewise. + * s-string.ads: Likewise. + * s-strops.adb: Likewise. + * s-strops.ads: Likewise. + * s-strxdr.adb: Likewise. + * s-ststop.adb: Likewise. + * s-ststop.ads: Likewise. + * s-taasde.adb: Likewise. + * s-taasde.ads: Likewise. + * s-tadeca.adb: Likewise. + * s-tadeca.ads: Likewise. + * s-tadert.adb: Likewise. + * s-tadert.ads: Likewise. + * s-taenca.adb: Likewise. + * s-taenca.ads: Likewise. + * s-taprob.ads: Likewise. + * s-taprop-dummy.adb: Likewise. + * s-taprop-hpux-dce.adb: Likewise. + * s-taprop-irix.adb: Likewise. + * s-taprop-linux.adb: Likewise. + * s-taprop-lynxos.adb: Likewise. + * s-taprop-mingw.adb: Likewise. + * s-taprop-posix.adb: Likewise. + * s-taprop-solaris.adb: Likewise. + * s-taprop-tru64.adb: Likewise. + * s-taprop-vms.adb: Likewise. + * s-taprop-vxworks.adb: Likewise. + * s-taprop.ads: Likewise. + * s-tarest.adb: Likewise. + * s-tarest.ads: Likewise. + * s-tasdeb.adb: Likewise. + * s-tasdeb.ads: Likewise. + * s-tasinf-irix.ads: Likewise. + * s-tasinf-linux.adb: Likewise. + * s-tasinf-linux.ads: Likewise. + * s-tasinf-mingw.adb: Likewise. + * s-tasinf-mingw.ads: Likewise. + * s-tasinf-solaris.adb: Likewise. + * s-tasinf-solaris.ads: Likewise. + * s-tasinf-tru64.ads: Likewise. + * s-tasinf.adb: Likewise. + * s-tasinf.ads: Likewise. + * s-tasini.adb: Likewise. + * s-tasini.ads: Likewise. + * s-taskin.adb: Likewise. + * s-taskin.ads: Likewise. + * s-taspri-dummy.ads: Likewise. + * s-taspri-hpux-dce.ads: Likewise. + * s-taspri-mingw.ads: Likewise. + * s-taspri-solaris.ads: Likewise. + * s-taspri-tru64.ads: Likewise. + * s-taspri-vms.ads: Likewise. + * s-taspri-vxworks.ads: Likewise. + * s-tasque.adb: Likewise. + * s-tasque.ads: Likewise. + * s-tasren.adb: Likewise. + * s-tasren.ads: Likewise. + * s-tasres.ads: Likewise. + * s-tassta.adb: Likewise. + * s-tassta.ads: Likewise. + * s-tasuti.adb: Likewise. + * s-tasuti.ads: Likewise. + * s-tfsetr-default.adb: Likewise. + * s-tfsetr-vxworks.adb: Likewise. + * s-tpinop.adb: Likewise. + * s-tpinop.ads: Likewise. + * s-tpoben.adb: Likewise. + * s-tpoben.ads: Likewise. + * s-tpobop.adb: Likewise. + * s-tpobop.ads: Likewise. + * s-tpopde-vms.adb: Likewise. + * s-tpopde-vms.ads: Likewise. + * s-tpopsp-lynxos.adb: Likewise. + * s-tpopsp-posix-foreign.adb: Likewise. + * s-tpopsp-posix.adb: Likewise. + * s-tpopsp-solaris.adb: Likewise. + * s-tpopsp-vxworks.adb: Likewise. + * s-tporft.adb: Likewise. + * s-tposen.adb: Likewise. + * s-tposen.ads: Likewise. + * s-traceb.adb: Likewise. + * s-traceb.ads: Likewise. + * s-traces-default.adb: Likewise. + * s-traces.adb: Likewise. + * s-traces.ads: Likewise. + * s-traent-vms.adb: Likewise. + * s-traent-vms.ads: Likewise. + * s-traent.adb: Likewise. + * s-traent.ads: Likewise. + * s-trafor-default.adb: Likewise. + * s-trafor-default.ads: Likewise. + * s-tratas-default.adb: Likewise. + * s-tratas.adb: Likewise. + * s-tratas.ads: Likewise. + * s-unstyp.ads: Likewise. + * s-utf_32.adb: Likewise. + * s-utf_32.ads: Likewise. + * s-vaflop-vms-alpha.adb: Likewise. + * s-vaflop.adb: Likewise. + * s-vaflop.ads: Likewise. + * s-valboo.adb: Likewise. + * s-valboo.ads: Likewise. + * s-valcha.adb: Likewise. + * s-valcha.ads: Likewise. + * s-valdec.adb: Likewise. + * s-valdec.ads: Likewise. + * s-valenu.adb: Likewise. + * s-valenu.ads: Likewise. + * s-valint.adb: Likewise. + * s-valint.ads: Likewise. + * s-vallld.adb: Likewise. + * s-vallld.ads: Likewise. + * s-vallli.adb: Likewise. + * s-vallli.ads: Likewise. + * s-valllu.adb: Likewise. + * s-valllu.ads: Likewise. + * s-valrea.adb: Likewise. + * s-valrea.ads: Likewise. + * s-valuns.adb: Likewise. + * s-valuns.ads: Likewise. + * s-valuti.adb: Likewise. + * s-valuti.ads: Likewise. + * s-valwch.adb: Likewise. + * s-valwch.ads: Likewise. + * s-veboop.adb: Likewise. + * s-veboop.ads: Likewise. + * s-vector.ads: Likewise. + * s-vercon.adb: Likewise. + * s-vercon.ads: Likewise. + * s-vmexta.adb: Likewise. + * s-vmexta.ads: Likewise. + * s-vxwext-kernel.ads: Likewise. + * s-vxwext-rtp.adb: Likewise. + * s-vxwext-rtp.ads: Likewise. + * s-vxwext.ads: Likewise. + * s-vxwork-arm.ads: Likewise. + * s-vxwork-m68k.ads: Likewise. + * s-vxwork-mips.ads: Likewise. + * s-vxwork-ppc.ads: Likewise. + * s-vxwork-sparcv9.ads: Likewise. + * s-vxwork-x86.ads: Likewise. + * s-wchcnv.adb: Likewise. + * s-wchcnv.ads: Likewise. + * s-wchcon.adb: Likewise. + * s-wchcon.ads: Likewise. + * s-wchjis.adb: Likewise. + * s-wchjis.ads: Likewise. + * s-wchstw.adb: Likewise. + * s-wchstw.ads: Likewise. + * s-wchwts.adb: Likewise. + * s-wchwts.ads: Likewise. + * s-widboo.adb: Likewise. + * s-widboo.ads: Likewise. + * s-widcha.adb: Likewise. + * s-widcha.ads: Likewise. + * s-widenu.adb: Likewise. + * s-widenu.ads: Likewise. + * s-widlli.adb: Likewise. + * s-widlli.ads: Likewise. + * s-widllu.adb: Likewise. + * s-widllu.ads: Likewise. + * s-widwch.adb: Likewise. + * s-widwch.ads: Likewise. + * s-win32.ads: Likewise. + * s-winext.ads: Likewise. + * s-wwdcha.adb: Likewise. + * s-wwdcha.ads: Likewise. + * s-wwdenu.adb: Likewise. + * s-wwdenu.ads: Likewise. + * s-wwdwch.adb: Likewise. + * s-wwdwch.ads: Likewise. + * scans.adb: Likewise. + * scans.ads: Likewise. + * seh_init.c: Likewise. + * sfn_scan.adb: Likewise. + * sinfo.adb: Likewise. + * sinfo.ads: Likewise. + * sinput.adb: Likewise. + * sinput.ads: Likewise. + * snames.adb: Likewise. + * snames.ads: Likewise. + * socket.c: Likewise. + * stand.adb: Likewise. + * stand.ads: Likewise. + * stringt.adb: Likewise. + * stringt.ads: Likewise. + * sysdep.c: Likewise. + * system-aix.ads: Likewise. + * system-darwin-ppc.ads: Likewise. + * system-darwin-x86.ads: Likewise. + * system-darwin-x86_64.ads: Likewise. + * system-freebsd-x86.ads: Likewise. + * system-hpux-ia64.ads: Likewise. + * system-hpux.ads: Likewise. + * system-irix-n32.ads: Likewise. + * system-irix-n64.ads: Likewise. + * system-irix-o32.ads: Likewise. + * system-linux-alpha.ads: Likewise. + * system-linux-hppa.ads: Likewise. + * system-linux-ia64.ads: Likewise. + * system-linux-mips.ads: Likewise. + * system-linux-mipsel.ads: Likewise. + * system-linux-ppc.ads: Likewise. + * system-linux-ppc64.ads: Likewise. + * system-linux-s390.ads: Likewise. + * system-linux-s390x.ads: Likewise. + * system-linux-sh4.ads: Likewise. + * system-linux-sparc.ads: Likewise. + * system-linux-sparcv9.ads: Likewise. + * system-linux-x86.ads: Likewise. + * system-linux-x86_64.ads: Likewise. + * system-lynxos-ppc.ads: Likewise. + * system-lynxos-x86.ads: Likewise. + * system-mingw-x86_64.ads: Likewise. + * system-mingw.ads: Likewise. + * system-rtems.ads: Likewise. + * system-solaris-sparc.ads: Likewise. + * system-solaris-sparcv9.ads: Likewise. + * system-solaris-x86.ads: Likewise. + * system-solaris-x86_64.ads: Likewise. + * system-tru64.ads: Likewise. + * system-vms-ia64.ads: Likewise. + * system-vms-zcx.ads: Likewise. + * system-vms.ads: Likewise. + * system-vms_64.ads: Likewise. + * system-vxworks-arm.ads: Likewise. + * system-vxworks-m68k.ads: Likewise. + * system-vxworks-mips.ads: Likewise. + * system-vxworks-ppc.ads: Likewise. + * system-vxworks-sparcv9.ads: Likewise. + * system-vxworks-x86.ads: Likewise. + * system.ads: Likewise. + * table.adb: Likewise. + * table.ads: Likewise. + * targext.c: Likewise. + * targparm.ads: Likewise. + * tree_in.adb: Likewise. + * tree_in.ads: Likewise. + * tree_io.adb: Likewise. + * tree_io.ads: Likewise. + * types.adb: Likewise. + * types.ads: Likewise. + * uintp.adb: Likewise. + * uintp.ads: Likewise. + * uname.adb: Likewise. + * uname.ads: Likewise. + * urealp.adb: Likewise. + * urealp.ads: Likewise. + * vx_stack_info.c: Likewise. + * widechar.adb: Likewise. + * widechar.ads: Likewise. + * exp_attr.adb: Change copyright header to refer to version + 3 of the GNU General Public License and to point readers at the + COPYING3 file and the FSF's license web page. + * sem.adb: Likewise. + * sem_attr.ads: Likewise. + * freeze.adb: Likewise. + * freeze.ads: Likewise. + * errout.ads: Likewise. + * erroutc.adb: Likewise. + * exp_ch11.ads: Likewise. + +2009-04-09 Jakub Jelinek + + * config-lang.in: Change copyright header to refer to version + 3 of the GNU General Public License and to point readers at the + COPYING3 file and the FSF's license web page. + * gcc-interface/trans.c: Likewise. + * gnathtml.pl: Likewise. + * gcc-interface/ada.h: Likewise. Remove runtime exception. + * gcc-interface/gigi.h: Likewise. + * gcc-interface/misc.c: Likewise. + * gcc-interface/targtyps.c: Likewise. + +2009-04-09 Nicolas Setton + + * s-osinte-darwin.ads: Fix wrong binding to struc timeval. + + * s-osinte-darwin.adb (To_Timeval): Adapt to fixed implementation of + struct_timeval. + +2009-04-09 Bob Duff + + * exp_ch5.adb, exp_ch9.adb: Correct miscellaneous Slocs in + internally-generated nodes related to select statements to avoid + confusing the debugger. + +2009-04-09 Pascal Obry + + * make.adb: Ensure that all linker arguments are duplicated. + +2009-04-09 Robert Dewar + + * sem_ch5.adb: Minor reformatting + +2009-04-09 Vincent Celier + + * vms_data.ads: + Change GNAT CHECK qualifier /DIAGNOSIS_LIMIT to /DIAGNOSTIC_LIMIT + New qualifier /LEXPAND_SOURCE=nnn for -gnatGnnn + New qualifier /LXDEBUG=nnn for -gnatDnnn + For H820-010 + + * gnat_ugn.texi: + Update documentation for VMS qualifiers equivalent to -gnatGnn and + -gnatDnn + +2009-04-09 Nicolas Setton + + * s-osinte-darwin.ads: (Pad_Type): Make this an array of unsigned_long, + to match layout of siginfo_t in sys/signal.h. + + * gcc-interface/Makefile.in: Add section for x86_64 darwin. + +2009-04-09 Thomas Quinot + + * g-socket.ads: (Fd_Set): Use Interfaces.C.long alignment. + +2009-04-09 Nicolas Setton + + * s-oscons-tmplt.c: Allow long lines in the generated spec. + Add generation of Darwin-specific constants needed when binding to the + pthread library. + +2009-04-09 Robert Dewar + + * checks.adb: + (Insert_Valid_Check): Avoid unnecessary generation of junk declaration + when no invalid values exist, Avoid duplicate read of atomic variable. + + * cstand.adb (Build_Signed_Integer_Type): Set Is_Known_Valid + (Standard_Unsigned): Set Is_Known_Valid + + * sem_ch3.adb (Analyze_Subtype_Declaration): Copy Is_Known_Valid on + subtype declaration if no constraint. + (Set_Modular_Size): Set Is_Known_Valid if appropriate + (Build_Derived_Numeric_Type): Copy Is_Known_Valid if no constraint + +2009-04-09 Robert Dewar + + * switch-c.adb, gnat_ugn.texi, vms_data.ads, switch.adb, + switch.ads: for numeric switches, an optional equal sign is always + allowed. + +2009-04-09 Vincent Celier + + * prj-nmsc.adb (Get_Unit): Do not consider Casing on platform where + the case of file names is not significant. + +2009-04-09 Vincent Celier + + * errout.adb: Remove dependency on package Style + + * style.ads, styleg.adb, styleg.ads (RM_Column_Check): Remove function, + moved to Stylesw. + + * stylesw.ads, stylesw.adb (RM_Column_Check): New function, moved from + Styleg. + + * errutil.adb, par.adb: Import Stylesw + +2009-04-09 Arnaud Charlet + + * opt.ads: Fix typos. + +2009-04-09 Robert Dewar + + * einfo.adb: Minor reformatting + +2009-04-09 Robert Dewar + + * gcc-interface/Make-lang.in, style.ads, style.adb: Reorganize style + units. + + * styleg-c.ads, styleg-c.adb: Removed, no longer used. + +2009-04-09 Robert Dewar + + * g-comver.adb: Minor reformatting. + +2009-04-09 Thomas Quinot + + * lib-load.ads (Load_Unit): Update documentation. + +2009-04-09 Ed Schonberg + + * lib-load.adb (Load_Unit): When loading the parent of a child unit + named in a with_clause, retain the with_clause to preserve a + limited_with indication. + +2009-04-09 Robert Dewar + + * sem_ch7.adb, sem_ch10.adb, sem_prag.adb, sem_ch12.adb, sem_util.adb, + exp_ch13.adb, sem_ch6.adb, exp_disp.adb, sem_ch8.adb, sem_warn.adb, + sem_cat.adb: Code clean up: use Is_Package_Or_Generic_Package where + possible to replace an OR of two separate tests. + +2009-04-09 Robert Dewar + + * binderr.adb, errout.adb, errutil.adb: New circuitry for handling + Maximum_Messages. + + * erroutc.adb, erroutc.ads (Warnings_Suppressed): Now tests global + warning status as well. + + * opt.ads (Maximum_Messages): New name for Maximum_Errors. + + * switch-b.adb, switch-c.adb: Change name Maximum_Errors to + Maximum_Messages. + + * bindusg.adb, usage.adb: Update line for -gnatm switch + + * gnat_ugn.texi: Update documentation for -gnatmnn compiler switch and + -mnn binder switch. + +2009-04-09 Robert Dewar + + * sem_ch10.adb: Minor reformatting. + +2009-04-09 Bob Duff + + * exp_ch11.adb (Expand_Exception_Handlers, Prepend_Call_To_Handler): + Set Sloc of generated nodes for calls to Undefer_Aborts and + Save_Occurrence to No_Location, so the debugger ignores them and + therefore does not jump back and forth when single stepping. + +2009-04-09 Robert Dewar + + * switch-b.adb: Minor reformatting. + +2009-04-09 Robert Dewar + + * sem_aggr.adb, exp_ch5.adb, sem_ch3.adb, exp_atag.adb, layout.adb, + sem_dist.adb, exp_ch7.adb, sem_ch5.adb, sem_type.adb, exp_imgv.adb, + exp_util.adb, sem_aux.adb, sem_aux.ads, exp_attr.adb, exp_ch9.adb, + sem_ch7.adb, inline.adb, fe.h, sem_ch9.adb, exp_code.adb, einfo.adb, + einfo.ads, exp_pakd.adb, checks.adb, sem_ch12.adb, exp_smem.adb, + tbuild.adb, freeze.adb, sem_util.adb, sem_res.adb, sem_attr.adb, + exp_dbug.adb, sem_case.adb, exp_tss.adb, exp_ch4.adb, exp_ch6.adb, + sem_smem.adb, sem_ch4.adb, sem_mech.adb, sem_ch6.adb, exp_disp.adb, + sem_ch8.adb, exp_aggr.adb, sem_eval.adb, sem_cat.adb, exp_dist.adb, + sem_ch13.adb, exp_strm.adb, lib-xref.adb, sem_disp.adb, exp_ch3.adb: + Reorganize einfo/sem_aux, moving routines from einfo to sem_aux + +2009-04-09 Robert Dewar + + * exp_util.adb (Silly_Boolean_Array_Xor_Test): Simplify existing code. + + * atree.h: Add Elist26 + + * gnat_ugn.texi: Complete documentation deprecating -gnatN for non-gcc + backends. + +2009-04-09 Javier Miranda + + * exp_disp.adb (Export_DT): Addition of a new argument (Index); used to + retrieve from the Dispatch_Table_Wrappers list the external name. + Addition of documentation. + (Make_Secondary_DT): Addition of a new argument (Suffix_Index) that is + used to export secondary dispatch tables (in the previous version of + the frontend only primary dispatch tables were exported). Addition of + documentation. + (Import_DT): New subprogram (internal of Make_Tags). Used to import a + dispatch table of a given tagged type. + (Make_Tags): Modified to import secondary dispatch tables. + + * sem_ch3.adb (Analyze_Object_Declaration): Code cleanup. + (Constant_Redeclaration): Code cleanup. + + * einfo.ads (Dispatch_Table_Wrapper): Renamed to + Dispatch_Table_Wrappers. Update documentation. + + * einfo.adb (Dispatch_Table_Wrapper, Set_Dispatch_Table_Wrapper): + Renamed to Dispatch_Table_Wrappers. + + * sem_util.adb (Collect_Interface_Components): Improve handling of + private types. + + * atree.ads (Elist26, Set_Elist26): New subprograms + + * atree.adb (Elist26, Set_Elist26): New subprograms + +2009-04-09 Javier Miranda + + * sem_ch3.adb (Build_Derived_Record_Type): Fix typo. + (Derive_Progenitor_Subprograms): Handle interfaces in subtypes of + tagged types. + +2009-04-09 Robert Dewar + + * s-direio.adb: Minor reformatting + + * exp_ch4.adb (Expand_Concatenate): Avoid overflow checks for String + +2009-04-09 Robert Dewar + + * exp_ch4.adb (Expand_Concatenate): Improve handling of overflow cases + +2009-04-09 Pascal Obry + + * a-cihama.adb, a-cihama.ads, a-coinve.adb, a-coinve.ads, + s-tpoben.adb, s-tpoben.ads, s-finimp.adb, s-finimp.ads, + a-convec.adb, a-convec.ads, a-finali.adb, a-finali.ads, + a-filico.ads: Add some missing overriding keywords. + +2009-04-09 Pascal Obry + + * a-cihama.adb, a-cihama.ads, a-coinve.adb, a-coorma.ads, a-cihase.adb, + a-cihase.ads, a-cohama.adb, a-cohama.ads, a-coorse.adb, a-coorse.ads, + a-coormu.adb, a-coormu.ads, a-cohase.adb, a-cohase.ads: Minor + reformatting. + +2009-04-09 Ed Schonberg + + * sem_ch6.adb (Check_Overriding_Indicator): Do not generate warning on + missing overriding indicator if the new declaration is not seen as + primitive. + +2009-04-09 Thomas Quinot + + * exp_ch4.adb (Expand_Concatenate): Add circuitry to properly handle + overflows in computation of bounds. + +2009-04-09 Pascal Obry + + * a-cihama.adb, a-cgcaso.adb, a-cihase.adb, a-cohase.adb: Fix some + typos in comment. + +2009-04-09 Robert Dewar + + * sem_attr.adb (Check_Stream_Attribute): Check violation of + restriction No_Streams + + * gnat_rm.texi: Clarify No_Streams restriction + + * g-socket.adb: Minor reformatting. + +2009-04-09 Thomas Quinot + + * g-socket.ads: Mark Initialize and Finalize as obsolesent interfaces. + +2009-04-09 Geert Bosch + + * exp_fixd.adb (Build_Conversion): Accept new optional Trunc argument. + (Set_Result): Likewise. + (Expand_Convert_Float_To_Fixed): Have Set_Result truncate the + conversion, as required by RM 4.6(31). + +2009-04-08 Robert Dewar + + * checks.adb (Enable_Overflow_Check): Do not enable if overflow checks + suppressed. + + * exp_ch4.adb (Expand_Concatenate): Make sure checks are off for all + resolution steps. + +2009-04-08 Robert Dewar + + * sem_ch12.adb (Analyze_Package_Instantiation): Remove test for + No_Local_Allocators restriction preventing local instantiation. + +2009-04-08 Thomas Quinot + + * sem_eval.adb: Minor comment fix + +2009-04-08 Thomas Quinot + + * g-socket.adb, g-socket.ads (GNAT.Sockets.Sockets_Library_Controller): + New limited controlled type used to automate the initialization and + finalization of the sockets implementation. + (GNAT.Sockets.Initialize, Finalize): Make these no-ops + +2009-04-08 Vincent Celier + + * prj-attr.adb: New read-only project-level attribute Project_Dir + + * prj-proc.adb (Add_Attributes): New parameter Project_Dir, value of + read-only attribute of the same name. + (Process_Declarative_Items): Call Add_Attributes with Project_Dir + (Recursive_Process): Ditto + + * snames.adb: Add new standard name Project_Dir + + * snames.ads: Add new standard name Project_Dir + +2009-04-08 Thomas Quinot + + * checks.adb: Minor reformatting + +2009-04-08 Vincent Celier + + * vms_data.ads: Add documentation for new style keyword + OVERRIDING_INDICATORS + +2009-04-08 Robert Dewar + + * sem_ch3.adb (Check_Completion.Post_Error): Post error on spec if the + spec is in the current unit. + +2009-04-08 Ed Schonberg + + * sem_util.adb (Is_Protected_Self_Reference): Add guard to check for + presence of entity. + + * usage.adb, gnat_ugn.texi: add info on -gnatyO: overriding indicators + +2009-04-08 Vincent Celier + + * vms_data.ads: Add VMS equivalent for -gnatyO (OVERRIDING_INDICATORS) + +2009-04-08 Thomas Quinot + + * checks.ads: Minor reformatting + +2009-04-08 Robert Dewar + + * gnat_rm.texi: Update documentation of pragma Obsolescent + + * sem_prag.adb (Analyze_Pragma, case Obsolescent): Allow identifiers to + be omitted, and allow Entity parameter to be omitted. + +2009-04-08 Thomas Quinot + + * exp_util.adb: Minor comment fix + +2009-04-08 Robert Dewar + + * g-socket.ads: Fix bad syntax in pragma Obsolescent + + * par-ch2.adb (Scan_Pragma_Argument_Association): Check for error of + argument with no identifier following one that has an identifier. Was + missed in some cases. + + * sem_prag.adb (Analyze_Pragma, case Check_Policy): Allow Policy + identifier. + (Analyze_Pragma, case Obsolescent): Allow Message, Version identifiers + + * snames.adb: Add Name_Policy + + * snames.ads: Add Name_Policy + +2009-04-08 Robert Dewar + + * gnat_rm.texi: Minor reformatting + + * par-ch2.adb: Minor reformatting + +2009-04-08 Robert Dewar + + * exp_attr.adb, sem_attr.adb, sem_util.adb: Code clean up. + +2009-04-08 Robert Dewar + + * sem_cat.adb (Check_Categorization_Dependencies): Handle Preelaborate + properly in the presence of Remote_Types or Remote_Call_Interface. + + * sem_util.adb: Add comment. + +2009-04-08 Robert Dewar + + * ug_words: Add /ASSUME_VALID for -gnatB + + * vms_data.ads: Add /ASSUME_VALID for -gnatB + + * sem_cat.adb: Add clarifying commment + + * a-direio.ads (Bytes): Make sure value is non-zero + +2009-04-08 Ed Schonberg + + * sem_util.adb (Is_Variable): If the prefix is an explicit dereference + that does not come from source, check for a rewritten function call in + prefixed notation before other forms of rewriting. + +2009-04-08 Robert Dewar + + * Makefile.rtl: Remove s-strops and s-sopco? from the run time, since + these are now obsolescent units used only for bootrapping with an + older compiler. + +2009-04-08 Robert Dewar + + * gnat_rm.texi: Add documentation for pragma Thread_Local_Storage + + * sem_ch3.adb: Minor comment updates + +2009-04-08 Ed Schonberg + + * inline.adb (Back_End_Cannot_Inline): restrict warning to subprograms + that come from source. + +2009-04-08 Tristan Gingold + + * gcc-interface/gigi.h (enum attr_type): Add ATTR_THREAD_LOCAL_STORAGE. + * gcc-interface/decl.c (prepend_attributes): New case + Pragma_Thread_Local_Storage. + * gcc-interface/utils.c (process_attributes): New case + ATTR_THREAD_LOCAL_STORAGE. + +2009-04-08 Ed Schonberg + + * inline.adb (Back_End_Cannot_Inline): Do not mark a body as inlineable + by the back-end if it contains a call to a subprogram without a + previous spec that is declared in the same unit. + + * errout.ads: Update comments on uses of dirs + +2009-04-08 Robert Dewar + + * exp_ch4.adb (Expand_Concatenate): Make sure nodes are properly typed + +2009-04-08 Tristan Gingold + + * sem_prag.adb: Restrict pragma Thread_Local_Storage to library level + variables. + Set Has_Gigi_Rep_Item flag to TLS variables (to ease gigi work). + +2009-04-08 Vincent Celier + + * prj-nmsc.adb: + (Add_Source): Add the mapping of the unit name to source file name in + the Unit_Sources_HT hash table, if the unit name is not null. + + * prj.adb (Reset): Reset hash table Tree.Unit_Sources_HT + + * prj.ads (Unit_Sources_Htable): New hash table instantiation + (Project_Tree_Data): New component Unit_Sources_HT + +2009-04-08 Thomas Quinot + + * sem_ch8.adb: Minor reformatting. + Minor code reorganization. + +2009-04-08 Robert Dewar + + * snames.h, einfo.adb, einfo.ads, sem_prag.adb, snames.adb, + snames.ads, freeze.adb, par-prag.adb: Add implementation of + pragma Thread_Local_Storage, setting new flag + Has_Pragma_Thread_Local_Storage in corresponding entities. + +2009-04-08 Emmanuel Briot + + * prj.ads: Update comment on switches file + + * prj-nmsc.adb: Code clean up. Use renaming clauses. + +2009-04-08 Robert Dewar + + * exp_ch4.adb (Expand_Concatenate): Further fixes to bounds handling + +2009-04-08 Thomas Quinot + + * ali-util.adb: Minor comment fix + +2009-04-08 Ed Schonberg + + * sem_ch8.adb (Analyze_Use_Type): Improve error message when clause + appears in a context clause, and the enclosing package is mentioned in + a limited_with_clause. + (Use_One_Type): Reject clause if type is still incomplete. + +2009-04-08 Emmanuel Briot + + * prj-nmsc.adb (Check_File, Process_Sources_In_Multi_Language_Mode): + avoid copies of Source_Data variables when possible, since these + involve calls to memcpy() which are done too many times. + +2009-04-08 Robert Dewar + + * exp_ch4.adb (Expand_Concatenate): Clean up code + +2009-04-07 Thomas Quinot + + * exp_ch4.adb (Expand_Concatenate): Add missing conversion to index + type for the case of concatenating a constrained array indexed by an + enumeration type. + +2009-04-07 Ed Schonberg + + * sem_ch6.adb (Check_Conformance): when checking conformance of an + operation that overrides an abstract operation inherited from an + interface, return False if only one of the controlling formals is an + access parameter. + +2009-04-07 Ed Schonberg + + * sem_ch8.adb (Analyze_Object_Renaming): additional error messages + mandated by AI05-105. + +2009-04-07 Vincent Celier + + * prj-nmsc.adb (Get_Mains): Warn if a main is an empty string + +2009-04-07 Thomas Quinot + + * usage.adb: Minor fix in usage message. + + * sem_ch10.adb (Remove_Homonyms): Fix subtype of formal in body to + match declaration; the correct subtype is Node_Id, not Entity_Id, + because the expected node kind is an identifier, not a defining + identifier. + + * switch-c.adb: Minor reformatting. + + * uintp.adb: Minor reformatting. + +2009-04-07 Robert Dewar + + * exp_ch13.adb: Minor reformatting + +2009-04-07 Robert Dewar + + * sem_warn.adb (Check_Infinite_Loop_Warning.Test_Ref): Add defence + against missing parent. + +2009-04-07 Thomas Quinot + + * xoscons.adb: Minor reformatting + +2009-04-07 Robert Dewar + + * rtsfind.ads: Remove obsolete string concatenation entries + +2009-04-07 Robert Dewar + + * exp_ch4.adb (Expand_Concatenate): Redo handling of bounds + +2009-04-07 Ed Schonberg + + * sem_ch10.adb (Check_Body_Required): Handle properly imported + subprograms. + +2009-04-07 Gary Dismukes + + * exp_ch13.adb (Expand_N_Attribute_Definition_Clause, case + Attribute_Address): When Init_Or_Norm_Scalars is True and the object + is of a scalar or string type then suppress the setting of the + expression to Empty. + + * freeze.adb (Warn_Overlay): Also emit the warnings about default + initialization for the cases of scalar and string objects when + Init_Or_Norm_Scalars is True. + +2009-04-07 Bob Duff + + * s-secsta.ads, g-pehage.ads, s-fileio.ads: Minor comment fixes + +2009-04-07 Bob Duff + + * gnat_rm.texi, s-fileio.adb (System.File_IO.Open): New feature: A + Form parameter of Text_Translation=No allows binary mode for Text_IO + files. + + * gnat_rm.texi: Document Form parameter Text_Translation=xxx. + +2009-04-07 Javier Miranda + + * exp_ch5.adb (Expand_Assign_Array): Add implicit conversion when + processing the bounds for bit packed arrays or VM target machines. + +2009-04-07 Thomas Quinot + + * g-sothco.ads (Int_Access): Remove extraneous access type (use + anonymous access instead). + (Get_Socket_From_Set): Fix incorrectly reverted formals + Last and Socket to match the underlying C routine. + + * g-socket.adb, g-socket.ads + (Get): Use named parameter associations instead of positional ones in + call go Get_Socket_From_Set, since this routine has two formals of the + same type. + (Image): New procedure. + + * g-socthi-vms.adb, g-socthi-vms.ads, g-socthi-vxworks.adb, + g-socthi-vxworks.ads, g-socthi-mingw.ads, g-socthi.adb, g-socthi.ads: + (C_Ioctl, Syscall_Ioctl): use "access C.int" instead of "Int_Access" + for type of Arg formal. + + * sem_warn.adb: Minor reformatting + +2009-04-07 Ed Schonberg + + * sem_util.adb (Has_Tagged_Component): Fix typo in loop that iterates + over record components. + +2009-04-07 Nicolas Roche + + * gsocket.h: + Don't include resolvLib.h on VxWorks 6 (kernel and rtp). This library + has disappeared between VxWorks 6.4 and VxWorks 6.5 + In RTP mode use time.h instead of times.h + +2009-04-07 Robert Dewar + + * exp_ch4.adb (Expand_N_Op_Concat): Improve lower bound handling + +2009-04-07 Kevin Pouget + + * exp_dist.adb: Modify Build_From_Any_Fonction procedure to correct + expanded code for constrained types. + +2009-04-07 Ed Schonberg + + * sem_ch4.adb (Analyze_Overloaded_Selected_Component): implement + AI05-105: in an object renaming declaration, anonymousness is a name + resolution rule. + + * sem_ch8.adb (Analyze_Object_Renaming): Ditto. + +2009-04-07 Arnaud Charlet + + * g-comlin.adb (Expansion): Fix old regression: also return directory + names when matching. + +2009-04-07 Robert Dewar + + * exp_ch4.adb: + (Expand_N_Op_Concat): Call Expand_Concatenate for all cases + (Expand_Concatenate): New name for Expand_Concatenate_String which has + been rewritten to handle all types. + (Expand_Concatenate_Other): Remove + +2009-04-07 Ed Schonberg + + * lib-xref.adb (Generate_Reference): A default subprogram in an + instance appears within the tree for the instance, but generates an + implicit reference in the ALI. + +2009-04-07 Javier Miranda + + * sem_ch3.adb (Build_Derived_Record_Type): When processing a tagged + derived type that has discriminants, propagate the list of interfaces + to the corresponding new base type. In addition, propagate also + attribute Limited_Present (found working in this patch). + +2009-04-07 Robert Dewar + + * exp_ch4.adb: Rewrite concatenation expansion. + +2009-04-07 Ed Schonberg + + * sem_ch8.adb (Restore_Scope_Stack): First_Private_Entity is only + relevant to packages. + +2009-04-07 Robert Dewar + + * sem_attr.adb: Minor reformatting + + * sem_ch6.adb: Minor reformatting + +2009-04-07 Tristan Gingold + + * socket.c: Add more protections against S_resolvLib_ macros. + +2009-04-07 Thomas Quinot + + * sem_attr.adb: Minor reformatting + +2009-04-07 Ed Schonberg + + * sem_ch6.adb (New_Overloaded_Entity): New predicate + Is_Overriding_Alias to handle properly types that inherit two homonym + operations that have distinct dispatch table entries. + +2009-04-07 Emmanuel Briot + + * s-regexp.adb (Create_Mapping): Ignore excaped open parenthesis when + looking for the end of a parenthesis group + +2009-04-07 Tristan Gingold + + * gsocket.h Don't #include resolvLib.h if __RTP__ is defined. + + * socket.c Don't use resolvLib_ macros if not defined. + +2009-04-07 Robert Dewar + + * g-socket.adb: Minor reformatting. + + * g-socthi-mingw.adb: Minor reformatting + + * g-sothco.ads: Minor reformatting + + * exp_ch4.adb: + (Expand_Concatenate_String): Complete rewrite to generate efficient code + inline instead of relying on external library routines. + + * s-strops.ads, s-sopco5.ads, s-sopco5.adb, s-sopco4.ads, s-sopco4.adb, + s-sopco3.ads, s-sopco3.adb, s-strops.adb: Note that this unit is now + obsolescent + +2009-04-07 Ed Schonberg + + * sem_attr.adb: + (Eval_Attribute): for attributes of array objects that are not strings, + attributes are not static if nominal subtype of object is unconstrained. + +2009-04-07 Ed Schonberg + + * sem_ch6.adb (New_Overloaded_Entity): If two implicit homonym + operations for a type T in an instance do not override each other, + when T is derived from a formal private type, the corresponding + operations inherited by a type derived from T outside + of the instance do not override each other either. + +2009-04-07 Robert Dewar + + (Osint.Fail): Change calling sequence to have one string arg + (Make.Make_Failed): Same change + All callers are adjusted to use concatenation + +2009-04-07 Robert Dewar + + * exp_ch4.adb: Fix documentation typo + +2009-04-07 Robert Dewar + + * tbuild.ads: Minor reformatting + +2009-04-07 Javier Miranda + + * exp_disp.adb (Make_DT): Avoid the generation of the OSD_Table + when compiling under ZFP runtime. + +2009-04-07 Robert Dewar + + * g-comlin.adb: Minor reformatting + +2009-04-07 Thomas Quinot + + * socket.c, g-socthi-vms.adb, g-socthi-vms.ads, g-socthi-vxworks.adb, + g-socthi-vxworks.ads, g-socthi-mingw.adb, g-socthi-mingw.ads, + g-socthi.adb, g-socthi.ads, g-socket.adb, g-socket.ads, g-sothco.ads: + Remove dynamic allocation of Fd_Set in Socket_Set_Type objects. + +2009-04-07 Robert Dewar + + * gnat_ugn.texi: Document -gnatDnn/-gnatGnn + + * opt.ads (Sprint_Line_Limit): New parameter + + * sprint.adb: Usa Sprint_Line_Limit instead of Line_Limit throughout + + * switch-c.adb: Recognize -gnatDnnn and -gnatGnnn switches + + * usage.adb: Output information for -gnatGnn -gnatDnn + +2009-04-07 Robert Dewar + + * make.adb: Minor reformatting + +2009-04-07 Robert Dewar + + * mlib-tgt-specific-vms-alpha.adb: Minor reformatting + +2009-04-07 Robert Dewar + + * mlib-tgt-specific-vms-ia64.adb: Minor reformatting + +2009-04-07 Robert Dewar + + * checks.adb: + Remove Assume_Valid parameter from In_Subrange_Of calls + + * sem_eval.adb: + (Is_Subrange_Of): Remove Assume_Valid parameter, not needed + (Is_In_Range): Remove incorrect use of Assume_Valid + (Is_Out_Of_Range): Remove incorrect use of Assume_Valid + + * sem_eval.ads: + (Is_Subrange_Of): Remove Assume_Valid parameter, not needed + (Is_In_Range): Documentation cleanup + (Is_Out_Of_Range): Documentation cleanup + + * gnat_rm.texi: + Add documentation for Assume_No_Invalid_Values pragma + + * sem_ch12.adb: Minor reformatting + + * sem_ch6.adb: (Check_Conformance): Avoid cascaded errors + + * sem_prag.adb: Improve error message. + + * gnatchop.adb, osint.ads, sinput.adb, sinput.ads, styleg.adb: + LF/CR no longer recognized as line terminator + + * switch.ads: Minor documentation improvement + + * vms_data.ads: Minor reformatting + +2009-04-07 Robert Dewar + + * checks.adb (Determine_Range): Add Assume_Valid parameter + + * checks.ads (Determine_Range): Add Assume_Valid parameter + + * errout.adb (Error_Msg_NEL): Use Suppress_Loop_Warnings rather than + Is_Null_Loop to suppress warnings in a loop body. + + * exp_ch4.adb: + (Rewrite_Comparison): Major rewrite to accomodate invalid values + + * exp_ch5.adb: + (Expand_N_Loop_Statement): Delete loop known not to execute + + * opt.ads: + (Assume_No_Invalid_Values): Now set to False, and as documented, this + fully enables the proper handling of invalid values. + + * sem_attr.adb: + New calling sequence for Is_In_Range + + * sem_ch5.adb: + (Analyze_Iteration_Scheme): Accomodate possible invalid values + in determining if a loop range is null. + + * sem_eval.adb: + (Is_In_Range): Add Assume_Valid parameter + (Is_Out_Of_Range): Add Assume_Valid_Parameter + (Compile_Time_Compare): Major rewrite to accomodate invalid values and + also to do more accurate and complete range analysis, catching more + cases. + + * sem_eval.ads: + (Is_In_Range): Add Assume_Valid parameter + (Is_Out_Of_Range): Add Assume_Valid_Parameter + + * sem_util.adb: + New calling sequence for Is_In_Range + + * sinfo.adb: + (Suppress_Loop_Warnings): New flag + + * sinfo.ads: + (Is_Null_Loop): Update documentation + (Suppress_Loop_Warnings): New flag + + * gnat_ugn.texi: Document -gnatB switch + +2009-04-07 Arnaud Charlet + + * gnatvsn.ads: Bump version number. + +2009-04-07 Thomas Quinot + + * exp_ch3.adb: Minor rewording (comments) + +2009-04-07 Robert Dewar + + * exp_disp.adb: Minor reformatting + +2009-04-07 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Test the + underlying type. + * gcc-interface/trans.c (lvalue_required_p): Likewise. + +2009-04-07 Eric Botcazou + + * gcc-interface/trans.c (Attribute_to_gnu) : + Do not convert the result. Remove obsolete comment. + +2009-04-07 Eric Botcazou + + * gcc-interface/trans.c (establish_gnat_vms_condition_handler): Clear + DECL_CONTEXT. + (Subprogram_Body_to_gnu): Fix pasto. + +2009-04-07 Eric Botcazou + + * gcc-interface/gigi.h (standard_datatypes): Remove ADT_void_type_decl. + (void_type_decl_node): Remove. + (init_gigi_decls): Likewise. + (gnat_install_builtins): Declare. + (record_builtin_type): Likewise. + (create_type_stub_decl): Likewise. + * gcc-interface/decl.c (gnat_to_gnu_entity) : Use void_type. + (gnat_to_gnu_entity) : Make fat and thin pointer types + artificial. + : Use the index types, not only their name, in the + record giving the names of the bounds, if any. + For a packed array type, make it artificial only if the base type + was artificial as well. Remove redundant statement. + (gnat_to_gnu_entity) : Do not create TYPE_DECL for + dummy types. + Use create_type_stub_decl to build the TYPE_STUB_DECL of types. + (rest_of_type_decl_compilation_no_defer): Likewise. + * gcc-interface/misc.c (gnat_printable_name): Add missing guard. + * gcc-interface/utils.c (make_dummy_type): Always create TYPE_STUB_DECL + and use create_type_stub_decl to build it. + (gnat_pushdecl): Rewrite condition. + (gnat_install_builtins): Remove bogus declaration. + (record_builtin_type): New function. + (finish_record_type): Use create_type_stub_decl to build TYPE_STUB_DECL + of types. + (create_type_stub_decl): New function. + (create_type_decl): Assert that the type is not dummy. If the type + hasn't been named yet, equate the TYPE_STUB_DECL to the created node. + (build_vms_descriptor32): Do not create TYPE_DECL for the descriptor. + (build_vms_descriptor): Likewise. + (init_gigi_decls): Delete and move bulk of code to... + * gcc-interface/trans.c (gigi): ...here. Use record_builtin_type. + (emit_range_check): Add gnat_node parameter. + (emit_index_check): Likewise. + (emit_check): Likewise. + (build_unary_op_trapv): Likewise. + (build_binary_op_trapv): Likewise. + (convert_with_check): Likewise. + (Attribute_to_gnu): Adjust calls for above changes. + (call_to_gnu): Likewise. + (gnat_to_gnu): Likewise. + (assoc_to_constructor): Likewise. + (pos_to_constructor): Likewise. + (Sloc_to_locus): Set BUILTINS_LOCATION for Standard_Location nodes. + (process_type): Do not create TYPE_DECL for dummy types. + +2009-04-07 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity): Reorder local variables. + * gcc-interface/trans.c: Fix formatting throughout. Fix comments. + * gcc-interface/utils.c: Fix comments. + +2009-04-07 Eric Botcazou + + * gcc-interface/decl.c (compile_time_known_address_p): Rewrite and + move around. + (gnat_to_gnu_type): Move around. + (get_unpadded_type): Likewise. + * gcc-interface/utils.c (update_pointer_to): Use synthetic macro. + Tidy comments. + +2009-04-07 Eric Botcazou + + * gcc-interface/trans.c (check_for_eliminated_entity): New function. + (Attribute_to_gnu): Invoke it for Access- and Address-like attributes. + (call_to_gnu): Invoke it instead of manually checking. + +2009-04-04 Eric Botcazou + + * gcc-interface/utils.c (finish_record_type): Force structural equality + checks if the record type is discriminated. + +2009-03-31 Eric Botcazou + + * system-linux-alpha.ads (Functions_Return_By_DSP): Remove. + * system-linux-mips.ads (Functions_Return_By_DSP): Likewise. + * system-linux-mipsel.ads (Functions_Return_By_DSP): Likewise. + * system-linux-s390.ads (Functions_Return_By_DSP): Likewise. + * system-linux-s390x.ads (Functions_Return_By_DSP): Likewise. + * system-linux-sparc.ads (Functions_Return_By_DSP): Likewise. + * system-linux-sparcv9.ads (Functions_Return_By_DSP): Likewise. + +2009-03-30 Paolo Bonzini + + * gcc-interface/decl.c (maybe_pad_type): Use TREE_OVERFLOW instead + of TREE_CONSTANT_OVERFLOW. + +2009-03-30 Joseph Myers + + PR rtl-optimization/323 + * gcc-interface/misc.c (gnat_post_options): Set + flag_excess_precision_cmdline. Give an error for + -fexcess-precision=standard for processors where the option is + significant. + +2009-03-27 H.J. Lu + + PR c/39323 + * gcc-interface/utils.c (create_field_decl): Use "unsigned int" + on bit_align. + +2009-03-11 Olivier Hainque + + * gcc-interface/trans.c (gnat_to_gnu) : In range + checks processing, remove unintended TREE_TYPE walk on index type. + +2009-03-01 Eric Botcazou + + PR ada/39264 + * gcc-interface/decl.c (gnat_to_gnu_entity) : Do no + call make_packable_type on fat pointer types. + : Likewise. + : Call make_packable_type on all record types + except for fat pointer types. + (make_packable_type): Likewise. + (gnat_to_gnu_field): Likewise. + +2009-02-28 Eric Botcazou + + * gcc-interface/Makefile.in (cygwin/mingw): Revert accidental + EH_MECHANISM change made on 2007-12-06. + +2009-02-26 Andreas Schwab + + PR ada/39172 + * Makefile.in (srcdir): Set to @top_srcdir@ instead of @srcdir@. + * gcc-interface/Makefile.in: Change all uses of $(srcdir), + $(fsrcdir) and $(fsrcpfx) to add ada subdir. + (AWK): Substitute. + (target_cpu_default): Substitute. + +2009-02-25 Laurent GUERBY + + PR ada/39221 + * a-teioed.adb (Expand): Fix Result overflow. + +2009-02-25 Laurent GUERBY + + * gcc-interface/Makefile.in: Fix multilib handling for + sparc64-linux. + +2009-02-23 Rainer Orth + + * s-oscons-tmplt.c [__osf__ && !_SS_MAXSIZE]: Undef AF_UNIX6. + +2009-02-18 H.J. Lu + + * gcc-interface/misc.c (gnat_post_options): Turn off warn_psabi. + +2009-02-16 Eric Botcazou + + * gcc-interface/deftarg.c: Remove. + +2009-02-10 Olivier Hainque + Eric Botcazou + + * gcc-interface/decl.c (enum alias_set_op): New enumeration. + (copy_alias_set): Rename into... + (relate_alias_sets): ...this. Add third parameter OP. Retrieve the + underlying array of unconstrained arrays for the new type as well. + If the old and new alias sets don't conflict, make one a subset of + the other as per the OP parameter. + (gnat_to_gnu_entity): Adjust calls to copy_alias_set. + : Do not copy the alias set for derived types. + For all types, make the alias set of derived types a superset of + that of their parent type. + (make_aligning_type): Adjust calls to copy_alias_set. + (make_packable_type): Likewise. + * gcc-interface/trans.c (gnat_to_gnu): + Check for alias set conflict instead of strict equality to issue the + warning. + +2009-02-09 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : + Set TYPE_NONALIASED_COMPONENT on the array type only if appropriate. + (copy_alias_set): Assert that arrays have the same aliasing settings. + (substitute_in_type) : Copy TYPE_NONALIASED_COMPONENT. + +2009-02-08 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : + Set TYPE_NONALIASED_COMPONENT on the array type. + +2009-01-31 Laurent GUERBY + + * gcc-interface/Makefile.in: Fix mipsel linux handling. + +2009-01-16 Jakub Jelinek + + * gcc-interface/Makefile.in: Fix multilib handling for + powerpc64-linux. + +2009-01-12 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Really strip + only useless conversions around renamed objects. + +2009-01-11 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Put + the _Tag field before any discriminants in the field list. + (components_to_record): Remove obsolete comment. + + + +Copyright (C) 2009 Free Software Foundation, Inc. + +Copying and distribution of this file, with or without modification, +are permitted in any medium without royalty provided the copyright +notice and this notice are preserved. diff --git a/gcc/ada/ChangeLog-2010 b/gcc/ada/ChangeLog-2010 new file mode 100644 index 000000000..6c1aa5932 --- /dev/null +++ b/gcc/ada/ChangeLog-2010 @@ -0,0 +1,10088 @@ +2010-12-31 Eric Botcazou + + * gcc-interface/decl.c (substitute_in_type): Do not deal with + LANG_TYPE, METHOD_TYPE or OFFSET_TYPE. + * gcc-interface/utils.c (handle_vector_size_attribute): Do not deal + with METHOD_TYPE or OFFSET_TYPE. + +2010-12-22 Nathan Froyd + + * gcc-interface/utils.c (handle_nonnull_attribute): Use prototype_p. + (handle_sentinel_attribute): Likewise. + +2010-12-20 Ralf Wildenhues + + PR bootstrap/47027 + * a-stwiun-shared.ads: Rewrap overlong comment line. + + * projects.texi: Fix typos. + * gnat_rm.texi: Likewise. + * gnat_ugn.texi: Likewise. + * sem_util.adb: Fix typo in variable, typos in comments. + * a-btgbso.adb: Fix typos in comments. + * a-cbdlli.adb, a-cbhase.ads, a-cdlili.adb, a-cobove.adb, + a-coinve.adb, a-convec.adb, a-direct.ads, a-strunb-shared.adb, + a-strunb-shared.ads, a-stuten.ads, a-stwiun-shared.adb, + a-stwiun-shared.ads, a-stzunb-shared.adb, a-stzunb-shared.ads, + a-suenco.adb, a-suenst.adb, a-suewst.adb, a-suezst.adb, ali.ads, + aspects.ads, atree.ads, binde.adb, bindgen.adb, checks.adb, + checks.ads, einfo.ads, err_vars.ads, errout.adb, errout.ads, + exp_aggr.adb, exp_attr.adb, exp_cg.adb, exp_ch3.adb, + exp_ch4.adb, exp_ch5.adb, exp_ch6.adb, exp_ch7.adb, + exp_dbug.ads, exp_disp.adb, exp_fixd.ads, freeze.adb, + g-altive.ads, g-comlin.ads, g-excact.ads, g-mbdira.adb, + g-sechas.ads, g-sehash.ads, g-sha1.ads, g-sha224.ads, + g-sha256.ads, g-sha384.ads, g-sha512.ads, g-shsh32.ads, + g-shsh64.ads, g-socket.adb, g-socket.ads, g-sothco.ads, + gcc-interface/decl.c, gcc-interface/trans.c, + gcc-interface/utils2.c, gnat1drv.adb, init.c, inline.adb, + link.c, locales.c, make.adb, mingw32.h, namet.ads, osint.adb, + par-ch12.adb, par-ch13.adb, par-ch3.adb, par-ch4.adb, + par-prag.adb, par.adb, par_sco.adb, prepcomp.adb, + prj-conf.ads, prj-dect.adb, prj-env.adb, prj-env.ads, + prj-nmsc.adb, prj-tree.ads, prj-util.ads, prj.adb, prj.ads, + s-auxdec-vms-alpha.adb, s-auxdec-vms_64.ads, s-oscons-tmplt.c, + s-osinte-vxworks.ads, s-osprim-mingw.adb, s-regexp.adb, + s-stusta.adb, s-taprop-mingw.adb, s-taprop-solaris.adb, + scn.adb, scos.ads, sem.adb, sem_aggr.adb, sem_attr.adb, + sem_aux.adb, sem_aux.ads, sem_ch12.adb, sem_ch12.ads, + sem_ch13.adb, sem_ch13.ads, sem_ch3.adb, sem_ch4.adb, + sem_ch6.adb, sem_ch7.adb, sem_ch8.adb, sem_disp.adb, + sem_disp.ads, sem_eval.adb, sem_intr.adb, sem_prag.adb, + sem_res.adb, sem_scil.adb, sem_util.ads, sem_warn.adb, + sem_warn.ads, sinfo.ads, socket.c, styleg.adb, switch.ads, + sysdep.c, tb-alvxw.c, xoscons.adb: Likewise. + +2010-12-13 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : + Build a stub DECL for the dummy fat pointer type in the unconstrained + array case. + * gcc-interface/utils.c (update_pointer_to): Set the DECL_ORIGINAL_TYPE + for all the variants in the fat pointer case. + +2010-12-13 Eric Botcazou + + * gcc-interface/trans.c (can_be_lower_p): New predicate. + (Loop_Statement_to_gnu): Do not generate the entry condition if we know + that it will be true. + +2010-12-03 Joseph Myers + + * gcc-interface/lang.opt (k8): New option. + +2010-12-03 Alexandre Oliva + + * gnatvsn.adb (Gnat_Version_String): Don't overrun Ver_Len_Max. + * gnatvsn.ads (Ver_Len_Max): Bump up to 256. + * g-comver.adb (Ver_Len_Max): Likewise. + +2010-12-03 Laurynas Biveinis + + * gcc-interface/decl.c (struct subst_pair_d): Remove GTY tag. + (variant_desc_d): Likewise. + +2010-12-01 Joseph Myers + + * gcc-interface/misc.c (flag_compare_debug, flag_stack_check): + Undefine as macros then define as variables. + (gnat_post_options): Set variables from global_options. + +2010-11-27 Eric Botcazou + + PR ada/46574 + * gcc-interface/utils2.c (compare_elmt_bitpos): Fix typos. + +2010-11-27 Eric Botcazou + + PR ada/40777 + * gcc-interface/targtyps.c (get_target_double_scalar_alignment): Guard + use of TARGET_64BIT macro. + +2010-11-27 Eric Botcazou + + * s-osinte-linux.ads (sigset_t): Use unsigned_char subtype directly. + (unsigned_long_long_t): New modular type. + (pthread_cond_t): Add alignment clause. + +2010-11-27 Eric Botcazou + + * gnatvsn.adb (Version_String): Change type to C-like array of chars. + (Gnat_Version_String): Adjust to above change. + +2010-11-18 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Also + use return-by-invisible-reference if the return type is By_Reference. + Tidy up and skip the processing of the return type if it is void. + +2010-11-17 Joseph Myers + + * gcc-interface/misc.c (gnat_parse_file): Take no arguments. + +2010-11-17 Eric Botcazou + + * gcc-interface/trans.c (addressable_p): Rewrite obsolete paragraph in + head comment. + +2010-11-12 Joseph Myers + + * gcc-interface/Make-lang.in (ada/misc.o): Use $(OPTS_H). + * gcc-interface/misc.c (gnat_handle_option): Take location_t parameter. + +2010-11-10 Eric Botcazou + + * gcc-interface/trans.c (gigi): Don't set 'pure' flag on SJLJ routines. + * gcc-interface/utils2.c (compare_arrays): Add LOC parameter. Set it + directly on all the comparison expressions. + (build_binary_op): Pass input_location to compare_arrays. + +2010-11-10 Eric Botcazou + + * gcc-interface/trans.c (lvalue_required_p) ): Look + through it for elementary types as well. + : Adjust to above change. + : Likewise. + (gnat_to_gnu): Do not attempt to rewrite boolean literals. + +2010-11-10 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity): Do not set DECL_ARTIFICIAL + on the reused DECL node coming from a renamed object. + Set DECL_IGNORED_P on the DECL node built for renaming entities if they + don't need debug info. + +2010-11-09 Eric Botcazou + + * gcc-interface/utils.c (save_gnu_tree): Improve comments. + (get_gnu_tree): Likewise. + +2010-11-09 Eric Botcazou + + * gcc-interface/decl.c (finish_fat_pointer_type): New function. + (gnat_to_gnu_entity) : Use it to build the fat pointer + type. + : Likewise. + +2010-11-02 Eric Botcazou + + * gcc-interface/gigi.h (add_stmt_force): Declare. + (add_stmt_with_node_force): Likewise. + * gcc-interface/trans.c (Attribute_to_gnu): Don't set TREE_SIDE_EFFECTS + on the SAVE_EXPR built for cached expressions of parameter attributes. + (Subprogram_Body_to_gnu): Force evaluation of the SAVE_EXPR built for + cached expressions of parameter attributes. + (add_stmt_force): New function. + (add_stmt_with_node_force): Likewise. + +2010-10-27 Eric Botcazou + + * gcc-interface/trans.c (gigi): Fix formatting issues. + (build_raise_check): Likewise. + (gnat_to_gnu): Likewise. + * gcc-interface/utils2.c (build_call_raise_range): Likewise. + (build_call_raise_column): Likewise. + +2010-10-26 Robert Dewar + + * exp_ch5.adb, exp_prag.adb, sem_ch3.adb, exp_atag.adb, layout.adb, + sem_dist.adb, exp_ch7.adb, exp_util.adb, exp_attr.adb, exp_ch9.adb, + sem_ch10.adb, checks.adb, sem_prag.adb, par-endh.adb, sem_ch12.adb, + exp_smem.adb, sem_attr.adb, exp_ch4.adb, exp_ch6.adb, exp_ch8.adb, + sem_ch6.adb, exp_disp.adb, exp_aggr.adb, exp_dist.adb, sem_ch13.adb, + par-ch3.adb, par-ch5.adb, exp_strm.adb, exp_ch3.adb: Minor reformatting + * opt.ads: Minor comment fix. + +2010-10-26 Vincent Celier + + * gnat_ugn.texi: Document option -s for gnatlink. + +2010-10-26 Robert Dewar + + * opt.ads: Move documentation on checksum stuff here from prj-nmsc + * prj-nmsc.adb (Process_Project_Level_Array_Attributes): Move + documentation on checksum versions to opt.ads. + +2010-10-26 Vincent Celier + + * opt.ads (Checksum_Accumulate_Token_Checksum): New Boolean flag, + defaulted to True. + (Checksum_GNAT_6_3): New name of Old_Checksums + (Checksum_GNAT_5_03): New name of Old_Old_Checksums + * prj-nmsc.adb (Process_Project_Level_Array_Attributes): Adapt to new + names of Opt flags. + Set Checksum_Accumulate_Token_Checksum to False if GNAT version is 5.03 + or before. + * scng.adb (Accumulate_Token_Checksum_GNAT_6_3): New name of procedure + Accumulate_Token_Checksum_Old. + (Accumulate_Token_Checksum_GNAT_5_03): New name of procedure + Accumulate_Token_Checksum_Old_Old. + (Nlit): Call Accumulate_Token_Checksum only if + Opt.Checksum_Accumulate_Token_Checksum is True. + (Scan): Ditto + +2010-10-26 Robert Dewar + + * sem_ch13.adb (Build_Invariant_Procedure): New calling sequence. + (Build_Invariant_Procedure): Properly handle analysis of invariant + expression with proper end-of-visible-decls visibility. + * sem_ch13.ads (Build_Invariant_Procedure): Changed calling sequence. + * sem_ch3.adb (Process_Full_View): Don't build invariant procedure + (too late). + (Analyze_Private_Extension_Declaration): Propagate invariant flags. + * sem_ch7.adb (Analyze_Package_Specification): Build invariant + procedures. + +2010-10-26 Vincent Celier + + * opt.ads (Old_Checksums, Old_Old_Checksums): New Boolean flags, + defaulted to False. + * prj-nmsc.adb (Process_Project_Level_Array_Attributes): When + processing attribute Toolchain_Version ("Ada"), set Opt.Old_Checksums + and Opt.Old_Old_Checksums depending on the GNAT version. + * scng.adb (Accumulate_Token_Checksum_Old): New procedure. + (Accumulate_Token_Checksum_Old_Old): New procedure. + (Scan): For keywords, when Opt.Old_Checksums is True, call one of the + alternative procedures Accumulate_Token_Checksum_Old or + Accumulate_Token_Checksum_Old_Old, instead of Accumulate_Token_Checksum. + +2010-10-26 Richard Kenner + + * gcc-interface/utils2.c (build_compound_expr): New function. + * gcc-interface/gigi.h (build_compound_expr): Declare it. + * gcc-interface/trans.c (Attribute_to_gnu, call_to_gnu): Use it. + (gnat_to_gnu, case N_Expression_With_Actions): Likewise. + +2010-10-26 Javier Miranda + + * sem_prag.adb (Process_Import_Or_Interface): Skip primitives of + interface types when processing all the entities in the homonym chain + that are declared in the same declarative part. + +2010-10-26 Ed Schonberg + + * sem_ch3.adb (Process_Range_In_Decl): If the range is part of a + quantified expression, the insertion point for range checks will be + arbitrarily far in the tree. + * sem_ch5.adb (One_Bound): Use Insert_Actions for the declaration of + the temporary that holds the value of the bounds. + * sem_res.adb (Resolve_Quantified_Expressions): Disable expansion of + condition until the full expression is expanded. + +2010-10-26 Robert Dewar + + * opt.ads: Comment fix. + * sem_cat.adb: Treat categorization errors as warnings in GNAT Mode. + * switch-c.adb: GNAT Mode does not set + Treat_Categorization_Errors_As_Warnings. + +2010-10-26 Ed Schonberg + + * sem_ch8.adb (Analyze_Subprogram_Renaming): Improve warning when an + operator renames another one with a different name. + +2010-10-26 Thomas Quinot + + * exp_ch4.adb, exp_pakd.adb: Minor reformatting. + +2010-10-26 Bob Duff + + * namet.adb: Improve hash function. + +2010-10-26 Thomas Quinot + + * sem_disp.adb: Minor reformatting. + +2010-10-26 Robert Dewar + + * sem_ch3.adb, sem_ch4.adb, sem_disp.adb, switch-c.adb: Minor + reformatting. + * gnat_ugn.texi: Document -gnateP switch. + +2010-10-26 Robert Dewar + + * opt.ads (Treat_Categorization_Errors_As_Warnings): New flag + * sem_cat.adb (Check_Categorization_Dependencies): + Use Check_Categorization_Dependencies + * switch-c.adb: GNAT Mode sets Treat_Categorization_Errors_As_Warnings + -gnateP sets Treat_Categorization_Errors_As_Warnings + * usage.adb: Add line for -gnateP switch + +2010-10-26 Javier Miranda + + * sem_ch3.adb (Add_Internal_Interface_Entities): Handle primitives + inherited from the parent that cover interface primitives. + (Derive_Progenitor_Subprograms): Handle primitives inherited from + the parent that cover interface primitives. + * sem_disp.adb (Find_Primitive_Covering_Interface): When searching in + the list of primitives of the type extend the test to include inherited + private primitives. + * sem_ch6.ads (Is_Interface_Conformant): Add missing documentation. + * sem_ch7.adb (Declare_Inherited_Private_Subprograms): Add missing + barrier to the loop searching for explicit overriding primitives. + * sem_ch4.adb (Analyze_Indexed_Component_Form): Add missing barrier + before accessing attribute Entity. + +2010-10-26 Bob Duff + + * make.adb: Call Namet.Finalize, so we can get statistics. + +2010-10-26 Geert Bosch + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Use the subprogram_body + node to determine wether the subprogram is a rewritten parameterized + expression. + +2010-10-26 Robert Dewar + + * opt.ads: Minor code reorganization. Alphabetize Warning switches. + +2010-10-26 Robert Dewar + + * sem_res.adb, xsinfo.adb: Minor reformatting. + +2010-10-26 Bob Duff + + * namet.adb (Finalize): More cleanup of statistics printouts. + +2010-10-26 Robert Dewar + + * ceinfo.adb: Minor reformatting. + +2010-10-26 Javier Miranda + + * sem_ch6.adb (Check_Overriding_Indicator, New_Overloaded_Entity): When + setting attribute Overridden_Operation do not reference the entities + generated by Derive_Subprograms but their aliased entity (which + is the primitive inherited from the parent type). + +2010-10-26 Bob Duff + + * namet.adb, namet.ads: Minor cleanup. + +2010-10-26 Arnaud Charlet + + * gcc-interface/Make-lang.in: Update dependencies. + +2010-10-26 Robert Dewar + + * einfo.ads, einfo.adb (Is_Base_Type): New function, use it where + appropriate. + * exp_ch6.adb, exp_dbug.adb, exp_disp.adb, freeze.adb, lib-xref.adb, + sem_aux.adb, sem_ch3.adb, sem_ch7.adb, sem_ch8.adb (Is_Base_Type): Use + this new abstraction where appropriate. + +2010-10-26 Ed Schonberg + + * sem_ch12.adb: Code clean up. + +2010-10-26 Paul Hilfinger + + * exp_dbug.ads: Document effect of 'pragma Unchecked_Union' on + debugging data. + +2010-10-26 Ed Schonberg + + * sem_util.adb (Note_Possible_Modification): If the target of an + assignment is the bound variable in an iterator, the domain of + iteration, i.e. array or container, is modified as well. + +2010-10-26 Bob Duff + + * Make-generated.in: Make the relevant make targets depend on + ceinfo.adb and csinfo.adb. + * csinfo.adb, ceinfo.adb: Make sure it raises an exception on failure, + so when called from xeinfo, the failure will be noticed. + * sinfo.ads: Update comments to reflect the fact that xsinfo runs csinfo + * xsinfo.adb, xeinfo.adb: Run ceinfo to check for errors. Close files. + +2010-10-26 Ed Schonberg + + * exp_ch4.adb: Set properly parent field of operands of concatenation. + +2010-10-26 Ed Schonberg + + * sem_res.adb (Check_Infinite_Recursion): A recursive call within a + conditional expression or a case expression should not generate an + infinite recursion warning. + +2010-10-26 Javier Miranda + + * einfo.ads, einfo.adb (Is_Overriding_Operation): Removed. + (Set_Is_Overriding_Operation): Removed. + * sem_ch3.adb (Check_Abstract_Overriding): Remove redundant call to + Is_Overriding_Operation. + * exp_ch7.adb (Check_Visibly_Controlled): Remove redundant call to + Is_Overriding_Operation. + * sem_ch7.adb (Declare_Inherited_Private_Subprograms): Remove redundant + call to Set_Is_Overriding_Operation. + * sem_util.adb (Collect_Primitive_Operations): Replace test on + Is_Overriding_Operation by test on the presence of attribute + Overridden_Operation. + (Original_Corresponding_Operation): Remove redundant call to attribute + Is_Overriding_Operation. + * sem_ch6.adb (Analyze_Abstract_Subprogram_Declaration): Remove + redundant call to Is_Overriding_Operation. + (Verify_Overriding_Indicator): Replace several occurrences of test on + Is_Overriding_Operation by test on the presence of attribute + Overridden_Operation. + (Check_Convention): Replace test on Is_Overriding_Operation by test on + the presence of Overridden_Operation. + (Check_Overriding_Indicator): Add missing decoration of attribute + Overridden_Operation. Minor code cleanup. + (New_Overloaded_Entity): Replace occurrence of test on + Is_Overriding_Operation by test on the presence of attribute + Overridden_Operation. Remove redundant setting of attribute + Is_Overriding_Operation plus minor code reorganization. + Add missing decoration of attribute Overridden_Operation. + * sem_elim.adb (Set_Eliminated): Replace test on + Is_Overriding_Operation by test on the presence of Overridden_Operation. + * sem_ch8.adb (Analyze_Subprogram_Renaming): Replace test on + Is_Overriding_Operation by test on the presence of + Overridden_Operation. Remove a redundant test on attribute + Is_Overriding_Operation. + * lib-xref.adb (Generate_Reference): Replace test on + Is_Overriding_Operation by test on the presence of Overridden_Operation. + (Output_References): Replace test on Is_Overriding_Operation by test on + the presence of Overridden_Operation. + * sem_disp.adb (Override_Dispatching_Operation): Replace test on + Is_Overriding_Operation by test on the presence of Overridden_Operation. + Add missing decoration of attribute Overridden_Operation. + +2010-10-26 Robert Dewar + + * sem_ch13.adb (Adjust_Record_For_Reverse_Bit_Order): Properly check + RM 13.4.1(10). + +2010-10-26 Bob Duff + + * sem_res.adb (Resolve_Actuals): In case of certain + internally-generated type conversions (created by OK_Convert_To, so the + Conversion_OK flag is set), avoid fetching the component type when it's + not really an array type, but a private type completed by an array type. + +2010-10-26 Ed Schonberg + + * sem_ch5.adb: Adjust format of error message. + +2010-10-26 Robert Dewar + + * einfo.ads, einfo.adb (OK_To_Reference): Removed, no longer used. + * exp_util.adb (Side_Effect_Free): Put in safety barrier in code to + detect renamings to avoid problems with invariants. + * sem_ch13.adb (Replace_Type_References_Generic): New procedure + (Build_Invariant_Procedure): Use Replace_Type_Reference_Generic + (Build_Predicate_Function): Use Replace_Type_Reference_Generic + * sem_res.adb, sem_ch8.adb, sem_ch4.adb (OK_To_Reference): Remove + references, flag is no longer set. + +2010-10-26 Vincent Celier + + * prj.ads (Source_Data): New Boolean component Initialized, defaulted + to False, set to True when Source_Data is completely initialized. + * prj-env.adb: Minor comment fix. + +2010-10-26 Robert Dewar + + * sem_case.adb, sem_ch6.adb, sem_util.adb: Minor reformatting. + +2010-10-26 Ed Schonberg + + * sem_ch5.adb (Analyze_Iteration_Scheme): Diagnose attempt to use thew + form "for X in A" when A is an array object. This form is only intended + for containers. + * sem_eval.adb: Fix reference to non-existing field of type conversion + node. + * sem_case.adb (Check_Choices): Improve error reporting for overlapping + choices in case statements. + +2010-10-26 Gary Dismukes + + * exp_disp.adb (Expand_Interface_Actuals): When expanding an actual for + a class-wide interface formal that involves applying a displacement + conversion to the actual, check for the case of calling a build-in-place + function and handle generation of the implicit BIP parameters (call + Make_Build_In_Place_Call_In_Anonymous_Context). + Add with and use of Exp_Ch6. + +2010-10-26 Robert Dewar + + * sem_prag.adb, sem_cat.ads: Minor reformatting. + +2010-10-26 Sergey Rybin + + * vms_data.ads: Define VMS qualifier for gnatelim '--ignore' option + +2010-10-26 Thomas Quinot + + * sem_util.adb (Has_Preelaborable_Initialization.Check_Components): + For a discriminant, use Discriminant_Default_Value rather than + Expression (Declaration_Node (D)). + +2010-10-26 Geert Bosch + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Parameterized + expressions don't need a spec, even when style checks require + subprograms to have one. + +2010-10-26 Arnaud Charlet + + * gnatvsn.ads: Update comments. + +2010-10-26 Matthew Heaney + + * Makefile.rtl, impunit.adb: Add bounded hashed set and bounded hashed + map containers. + * a-cohata.ads: Add declaration of generic package for bounded hash + table types. + * a-chtgbo.ads, a-chtgbo.adb, a-chtgbk.ads, a-chtgbk.adb, a-cbhase.ads, + a-cbhase.adb, a-cbhama.ads, a-cbhama.adb: New files. + +2010-10-26 Ed Schonberg + + * sem_warn.adb: Improve warning message on overlapping actuals. + +2010-10-26 Thomas Quinot + + * sem_ch4.adb, exp_dist.adb: Minor reformatting. + +2010-10-26 Vincent Celier + + * makeusg.adb (Makeusg): Add lines for switches -vl, -vm and -vh. + +2010-10-26 Robert Dewar + + * exp_ch3.adb (Expand_N_Object_Declaration): Move generation of + predicate check to analyzer, since too much rewriting occurs in the + analyzer. + * sem_ch13.adb (Build_Predicate_Function): Change calling sequence, and + change the order in which things are done to fix several errors in + dealing with qualification of the type name. + (Build_Static_Predicate): Built static predicate after full analysis + of the body. This is necessary to fix several problems. + * sem_ch3.adb (Analyze_Object_Declaration): Move predicate check here + from expander, since too much expansion occurs in the analyzer to leave + it that late. + (Analyze_Object_Declaration): Change parameter Include_Null to new name + Include_Implicit in Is_Partially_Initialized_Type call. + (Analyze_Subtype_Declaration): Make sure predicates are proapagated in + some strange cases of internal subtype generation. + * sem_util.ads, sem_util.adb (Is_Partially_Initialized_Type): Change + Include_Null to Include_Implicit, now includes the case of + discriminants. + +2010-10-26 Sergey Rybin + + * gnat_rm.texi: Revise the documentation for pragma Eliminate. + +2010-10-26 Matthew Heaney + + * Makefile.rtl, impunit.adb: Added bounded list container. + * a-cbdlli.ads, a-cbdlli.adb: New file. + +2010-10-25 Eric Botcazou + + * gcc-interface/utils2.c: Include flags.h and remove prototypes. + (build_unary_op) : When not optimizing, fold the result + of the call to invert_truthvalue_loc. + * gcc-interface/Make-lang.in (utils2.o): Add $(FLAGS_H). + +2010-10-25 Eric Botcazou + + * gcc-interface/utils.c (update_pointer_to): Clear TYPE_POINTER_TO and + TYPE_REFERENCE_TO of the old type after redirecting its pointer and + reference types. + +2010-10-25 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Do not set + TREE_THIS_NOTRAP on the INDIRECT_REF node built for the template. + +2010-10-25 Jose Ruiz + + * gcc-interface/Makefile.in (LIBGNAT_TARGET_PAIRS for powerpc-linux): + Reorganize target pairs so that it works on linux and ElinOS. + +2010-10-25 Pascal Obry + + * adaint.c (__gnat_file_time_name_attr): Use GetFileAttributesEx to get + the timestamp. A bit faster than opening/closing the file. + (__gnat_stat_to_attr): Remove kludge for Windows. + (__gnat_file_exists_attr): Likewise. + The timestamp is now retreived using GetFileAttributesEx as faster. + +2010-10-25 Javier Miranda + + * sem_ch3.adb (Derive_Interface_Subprogram): New subprogram. + (Derive_Subprograms): For abstract private types transfer to the full + view entities of uncovered interface primitives. Required because if + the interface primitives are left in the private part of the package + they will be decorated as hidden when the analysis of the enclosing + package completes (and hence the interface primitive is not visible + for dispatching calls). + +2010-10-25 Matthew Heaney + + * Makefile.rtl, impunit.adb: Added bounded set and bounded map + containers. + * a-crbltr.ads: Added declaration of generic package for bounded tree + types. + * a-rbtgbo.ads, a-rbtgbo.adb, a-rbtgbk.ads, a-rbtgbk.adb, a-btgbso.ads, + a-btgbso.adb, a-cborse.ads, a-cborse.adb, a-cborma.ads, a-cborma.adb: + New. + +2010-10-25 Thomas Quinot + + * sem_util.adb: Minor reformatting. + * usage.adb: Fix usage line for -gnatwh. + +2010-10-25 Thomas Quinot + + * sem_ch12.adb (Analyze_Package_Instantiation): For an + instantiation in an RCI spec, omit package body if instantiation comes + from source, even as a nested + package. + * exp_dist.adb (Add_Calling_Stubs_To_Declarations, + *_Support.Add_Receiving_Stubs_To_Declarations): Handle the case of + nested packages, package instantiations and subprogram instantiations. + +2010-10-25 Robert Dewar + + * exp_ch5.adb (Expand_Predicated_Loop): Remove code for loop through + non-static predicate, since we agree not to allow this. + (Expand_Predicated_Loop): Properlay handle false predicate (null + list in Static_Predicate field. + * sem_ch13.adb (Build_Static_Predicate): Extensive changes to clean up + handling of more general predicate forms. + +2010-10-25 Robert Dewar + + * sem_ch4.adb, sem_util.adb: Minor reformatting. + * sem_ch8.adb (Find_Selected_Component): Allow selection from instance + of type in predicate or invariant expression. + +2010-10-25 Pascal Obry + + * adaint.c (__gnat_stat_to_attr): Can set the timestamp on Windows now. + (f2t): New routine. + (__gnat_stat): Rewrite Win32 version. + +2010-10-25 Robert Dewar + + * sem_warn.adb, einfo.ads, exp_ch4.adb: Minor comment fix + * sem_case.adb: Comment clarification for loops through false + predicates. + * sem_util.adb: Minor reformatting + (Check_Order_Dependence): Fix bad double blank in error message + +2010-10-25 Ed Schonberg + + * sem_ch4.adb (Analyze_Membership_Op): in Ada_2012 a membership + operation can have a single alternative that is a value of the type. + Rewrite operation as an equality test. + +2010-10-25 Matthew Heaney + + * Makefile.rtl, impunit.adb: Added a-cobove (bounded vector container) + to lists. + * a-contai.ads: Added declaration of Capacity_Error exception. + * a-cobove.ads, a-cobove.adb: New files. + +2010-10-25 Thomas Quinot + + * uname.adb: Revert previous change, no longer needed after change + in par-ch10.adb. + +2010-10-25 Thomas Quinot + + * scos.ads: Minor comment fix. + +2010-10-25 Ed Schonberg + + * sem_ch5.adb (Analyze_Assignment_Statement): Check dangerous order + dependence. + * sem_ch6.adb (Analyze_Procedure_Call_Statement): Ditto. + * sem_res.adb (Analyze_Actuals): Add actual to list of actuals for + current construct, for subsequent order dependence checking. + (Resolve): Check order dependence on expressions that are not + subexpressions. + * sem_util.adb (Check_Order_Dependence): Code cleanup, to correspond + to latest version of AI05-144-2. + * sem_warn.adb (Warn_On_Overlapping_Actuals): Code cleanup. + +2010-10-25 Robert Dewar + + * sem_ch13.adb (Build_Static_Predicate): Moved out of + Build_Predicate_Function. + (Build_Static_Predicate): Complet rewrite for more general predicates + +2010-10-25 Richard Kenner + Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity, case E_Function): Allow + In Out/Out parameters for functions. + * gcc-interface/trans.c (gnu_return_var_stack): New variable. + (create_init_temporary): New static function. + (Subprogram_Body_to_gnu): Handle In Out/Out parameters for functions. + (call_to_gnu): Likewise. Use create_init_temporary in order to create + temporaries for unaligned parameters and return value. If there is an + unaligned In Out or Out parameter passed by reference, push a binding + level if not already done. If a binding level has been pushed and the + call is returning a value, create the call statement. + (gnat_to_gnu) : Handle In Out/Out parameters for + functions. + +2010-10-22 Ben Brosgol + + * gnat_rm.texi: Add chapter on Ada 2012 support. + +2010-10-22 Robert Dewar + + * sem_ch12.adb: Minor reformatting. + +2010-10-22 Thomas Quinot + + * exp_dist.adb: Mark missing case of nested package when expanding + stubs. + +2010-10-22 Ed Schonberg + + * par-ch10.adb: Discard incomplete with_clause. + +2010-10-22 Robert Dewar + + * checks.adb (Enable_Range_Check): Remove code suppressing range check + if static predicate present, not needed. + * exp_attr.adb (Expand_Pred_Succ): Check Suppress_Assignment_Checks flag + * exp_ch3.adb (Expand_N_Object_Declaration): Check + Suppress_Assignment_Checks flag. + * exp_ch4.adb (Expand_N_In): Make some corrections for proper handling + of ranges when predicates are present. + * exp_ch5.adb (Expand_Predicated_Loop): New procedure + (Expand_N_Assignment_Statement): Check Suppress_Assignment_Checks flag + (Expand_N_Loop_Statement): Handle loops over predicated types + * sem_case.adb (Analyze_Choices): Remove extra blank in error message. + * sem_ch13.adb (Build_Predicate_Function.Add_Call): Suppress info + message for inheritance if within a generic instance, not useful there! + (Build_Static_Predicate): Optimize test in predicate function + based on static ranges determined. + * sem_ch5.adb (Analyze_Iteration_Scheme): Error for loop through + subtype with non-static predicate. + * sinfo.ads, sinfo.adb (Suppress_Assignment_Checks): New flag. + +2010-10-22 Thomas Quinot + + * uname.adb (Get_Unit_Name.Add_Node_Name): If encountering an error + node in the unit name, propagate Program_Error to guard against + cascaded errors. + +2010-10-22 Javier Miranda + + * sem_ch8.adb (Find_Selected_Component): Do not generate a subtype for + selected components of dispatch table wrappers. + +2010-10-22 Ed Schonberg + + * exp_ch9.adb (Make_Initialize_Protection): A protected type that + implements an interface must be treated as if it has entries, to + support dispatching select statements. + +2010-10-22 Robert Dewar + + * sem_aggr.adb, sem_ch3.adb: Minor reformatting. + +2010-10-22 Javier Miranda + + * sem_aggr.adb (Resolve_Array_Aggregate.Add): If the type of the + aggregate has a non standard representation the attributes 'Val and + 'Pos expand into function calls and the resulting expression is + considered non-safe for reevaluation by the backend. Relocate it into + a constant temporary to indicate to the backend that it is side + effects free. + +2010-10-22 Ed Schonberg + + * sem_ch3.adb (Build_Concurrent_Derived_Type): Create declaration for + derived corresponding record type only when expansion is enabled. + +2010-10-22 Robert Dewar + + * sem_case.adb, sem_attr.adb (Bad_Predicated_Subtype_Use): Change order + of parameters. + * sem_ch13.adb (Build_Predicate_Function): Don't give inheritance + messages for generic actual subtypes. + * sem_ch9.adb, sem_res.adb, sem_util.adb, sem_util.ads, sem_ch3.adb + (Bad_Predicated_Subtype_Use): Use this procedure. + +2010-10-22 Robert Dewar + + * sem_ch5.adb: Minor reformatting. + +2010-10-22 Robert Dewar + + * a-except-2005.adb (Rmsg_18): New message text. + * a-except.adb (Rmsg_18): New message text. + * atree.adb (List25): New function + (Set_List25): New procedure + * atree.ads (List25): New function + (Set_List25): New procedure + * einfo.adb (Static_Predicate): Is now a list + (OK_To_Reference): Present in all entities + * einfo.ads (Static_Predicate): Is now a list + (OK_To_Reference): Applies to all entities + * exp_ch13.adb (Build_Predicate_Function): Moved to Sem_Ch13 + * sem_attr.adb (Bad_Attribute_For_Predicate): Call + Bad_Predicated_Subtype_Use. + * sem_case.ads, sem_case.adb: Major surgery to deal with predicated + subtype case. + * sem_ch13.adb (Build_Predicate_Function): Moved from Exp_Ch13 to + Sem_Ch13. + (Build_Static_Predicate): New procedure handles static predicates. + * sem_ch3.adb (Analyze_Subtype_Declaration): Delay freeze on subtype + with no constraint if ancestor subtype has predicates. + (Analyze_Variant_Part): New calling sequence for Analyze_Choices + * sem_ch4.adb (Junk_Operand): Don't complain about OK_To_Reference + entity. + (Analyze_Case_Expression): New calling sequence for Analyze_Choices + * sem_ch5.adb (Analyze_Case_Statement): New calling sequence for + Analyze_Choices. + * sem_util.ads, sem_util.adb (Bad_Predicated_Subtype_Use): New procedure + * types.ads (PE_Bad_Predicated_Generic_Type): Replaces + PE_Bad_Attribute_For_Predicate. + * atree.h: Add definition of List25. + +2010-10-22 Jerome Lambourg + + * gnatlink.adb (Process_Binder_File): Remove CLI-specific code, now + moved to dotnet-ld. + (Gnatlink): Remove CLI-specific code, moved to dotnet-ld + * bindgen.adb (Gen_Object_Files_Options): Do not issue -L switches with + the .NET compiler, useless and unsupported. + +2010-10-22 Robert Dewar + + * sem_util.ads (Get_Num_Lit_From_Pos): Fix errors in documentation, + this returns a Node_Id for a reference to the entity, not the entity + itself! + +2010-10-22 Ed Schonberg + + * sem_ch5.adb (Analyze_Iteration_Scheme): use Insert_Actions when + bounds require a temporary. + +2010-10-22 Robert Dewar + + * sem_ch4.adb: Minor reformatting. + * sinfo.ads: Minor comment fixes for Ada 2012 syntax. + +2010-10-22 Robert Dewar + + * par-ch5.adb: Minor reformatting. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-10-22 Robert Dewar + + * a-except.adb, a-except-2005.adb: Add new Rcheck entry. + * exp_ch13.adb (Add_Call): Make sure subtype is marked with + Has_Predicates set to True if it inherits predicates. + * sem_attr.adb: Handle 'First/'Last/'Range for predicated types + * types.ads (PE_Bad_Attribute_For_Predicate): New reason code + * types.h: Add new Rcheck entry. + * einfo.ads, einfo.adb (Static_Predicate): New field. + Minor code reorganization (file float routines in proper section) + Fix bad field name in comments. + +2010-10-22 Robert Dewar + + * sem_eval.adb (Subtypes_Statically_Compatible): Check null exclusion + case. + +2010-10-22 Vincent Celier + + * prj-conf.adb (Get_Config_Switches): Detect if there is at least one + declaration of IDE'Compiler_Command for one of the language in the main + project. + (Do_Autoconf): If there were at least one Compiler_Command declared and + no target, invoke gprconfig with --target=all instead of the normalized + host name. + +2010-10-22 Robert Dewar + + * par-ch4.adb: Update syntax in comments for Ada 2012. + * sinfo.ads: Update syntax in comments for Ada 2012 + * par-ch3.adb (Check_Restricted_Expression): Remove "in Ada 2012 mode" + from msg. + +2010-10-22 Gary Dismukes + + * sem_ch3.adb (Check_Or_Process_Discriminants): In Ada 2012, allow + limited tagged types to have defaulted discriminants. Customize the + error message for the Ada 2012 case. + (Process_Discriminants): In Ada 2012, allow limited tagged types to have + defaulted discriminants. Customize the error message for the Ada 2012 + case. + * sem_ch6.adb (Create_Extra_Formals): Suppress creation of the extra + formal for out formals of discriminated types in the case where the + underlying type is a limited tagged type. + * exp_attr.adb (Expand_N_Attribute_Reference, case + Attribute_Constrained): Return True for 'Constrained when the + underlying type of the prefix is a limited tagged type. + +2010-10-22 Thomas Quinot + + * sem_ch3.adb (Complete_Private_Subtype): The full view of the subtype + may already have a rep item chain inherited from the full view of the + base type, so do not overwrite it when propagating rep items from the + partial view of the subtype. + * sem_ch3.adb: Minor code reorganization. Minor reformatting. + +2010-10-22 Sergey Rybin + + * gnat_ugn.texi (gnatmetric): Remove description of debug option. + +2010-10-22 Tristan Gingold + + * adaint.c (__gnat_number_of_cpus): Add implementation for VMS. + +2010-10-22 Ed Schonberg + + * par-ch5.adb: Set properly starting sloc of loop parameter. + +2010-10-22 Ed Schonberg + + * sem_util.adb (May_Be_Lvalue): An actual in a function call can be an + lvalue in Ada2012, if the function has in-out parameters. + +2010-10-22 Robert Dewar + + * cstand.adb, einfo.adb, exp_attr.adb, sem_prag.adb, sem_vfpt.adb, + sem_ch10.adb: Minor reformatting. + +2010-10-22 Sergey Rybin + + * gnat_ugn.texi: Remove most of the content of gnatcheck chapter. + +2010-10-22 Ed Schonberg + + * sem_attr.adb: Handle indexed P'old. + +2010-10-22 Geert Bosch + + * cstand.adb (Build_Float_Type): Set Float_Rep according to platform. + * einfo.ads (Float_Rep): New attribute. + (Float_Rep_Kind): Move from body. Add comments. + * einfo.adb (Float_Rep_Kind): Move to spec + (Float_Rep): Now a real field instead of local function. + (Set_Float_Rep): New procedure to set floating point representation + (Set_Vax_Float): Remove. + (Write_Entity_Flags): Remove Vax_Float flag. + (Write_Field10_Name): Add E_Floating_Point_Type case for Float_Rep. + * exp_attr.adb (Attribute_Valid): Use case statement for representation + specific processing. + * sem_ch3.adb (Build_Derived_Numeric_Type, + Floating_Point_Type_Declaration): Set Float_Rep instead of Vax_Float + attribute. + * sem_util.ads, sem_util.adb (Is_AAMP_Float): Remove. + * sem_vfpt.adb (Set_D_Float, Set_F_Float, Set_G_Float, Set_IEEE_Long, + Set_IEEE_Short): Set Float_Rep instead of Vax_Float attribute. + +2010-10-22 Robert Dewar + + * sprint.adb: Minor reformatting. + +2010-10-22 Robert Dewar + + * exp_ch3.adb (Expand_N_Object_Declaration): Do required predicate + checks. + * sem_ch3.adb (Complete_Private_Subtype): Propagate predicates to full + view. + * sem_ch6.adb (Invariants_Or_Predicates_Present): New name for + Invariants_Present. + (Process_PPCs): Handle predicates generating post conditions + * sem_util.adb (Is_Partially_Initialized_Type): Add + Include_Null parameter. + * sem_util.ads (Is_Partially_Initialized_Type): Add + Include_Null parameter. + +2010-10-22 Sergey Rybin + + * gnat_ugn.texi (gnatelim): Add description for '--ignore' option + +2010-10-22 Thomas Quinot + + * sem_prag.adb (Check_First_Subtype): Specialize error messages for + case where argument is not a type. + +2010-10-22 Robert Dewar + + * exp_ch5.adb, par-ch4.adb, par-ch5.adb, sem_ch5.adb, sinfo.ads: Minor + reformatting. + +2010-10-22 Arnaud Charlet + + * a-locale.adb: Minor code clean up. + +2010-10-22 Thomas Quinot + + * exp_ch4.adb: Minor code reorganization and factoring. + +2010-10-22 Thomas Quinot + + * exp_ch5.adb, sem_ch5.adb, sinfo.ads, snames.ads-tmpl, par-ch5.adb: + Minor reformatting. + +2010-10-22 Geert Bosch + + * stand.ads: Fix typo in comment. + +2010-10-22 Ed Schonberg + + * sem_ch6.adb: Enable in-out parameter for functions. + +2010-10-22 Ed Schonberg + + * sem_ch4.adb (Analyze_Quantified_Expression): Handle properly loop + iterators that are transformed into container iterators after analysis. + * exp_ch4.adb (Expand_N_Quantified_Expression): Handle properly both + iterator forms before rewriting as a loop. + +2010-10-22 Brett Porter + + * a-locale.adb, a-locale.ads, locales.c: New files. + * Makefile.rtl: Add a-locale + * gcc-interface/Makefile.in: Add locales.c + +2010-10-22 Robert Dewar + + * sem_util.ads, sem_util.adb, sem_aux.ads, sem_aux.adb + (Is_Generic_Formal): Moved from Sem_Util to Sem_Aux. + +2010-10-22 Ed Schonberg + + * exp_ch5.adb (Expand_Iterator_Loop): New subprogram, implements new + iterator forms over arrays and containers, in loops and quantified + expressions. + * exp_util.adb (Insert_Actions): include N_Iterator_Specification. + * par-ch4.adb (P_Quantified_Expression): Handle iterator specifications. + * par-ch5.adb (P_Iterator_Specification): New subprogram. Modify + P_Iteration_Scheme to handle both loop forms. + * sem.adb: Handle N_Iterator_Specification. + * sem_ch5.adb, sem_ch5.ads (Analyze_Iterator_Specification): New + subprogram. + * sinfo.adb, sinfo.ads: New node N_Iterator_Specification. + N_Iteration_Scheme can now include an Iterator_Specification. Ditto + for N_Quantified_Expression. + * snames.ads-tmpl: Add names Cursor, Element, Element_Type, No_Element, + and Previous, to support iterators over predefined containers. + * sprint.adb: Handle N_Iterator_Specification. + +2010-10-22 Thomas Quinot + + * sem_prag.adb, sem_ch12.adb, sem_util.adb, sem_util.ads + (Is_Generic_Formal): Move from body of Sem_Ch12 to Sem_Util. + (Check_Arg_Is_Local_Name): Fix check in the case of a pragma appearing + immediately after a library unit. + (Analyze_Pragma, case Preelaborable_Initialization): Pragma may apply to + a formal derived type. + +2010-10-22 Geert Bosch + + * gcc-interface/Make-lang.in: Remove ttypef.ads + * checks.adb: Use Machine_Mantissa_Value and Machine_Radix_Value instead + of Machine_Mantissa and Machine_Radix. + * cstand.adb (P_Float_Range): Directly print the Type_Low_Bound and + Type_High_Bound of the type, instead of choosing constants from Ttypef. + (Set_Float_Bounds): Compute the bounds based on Machine_Radix_Value, + Machine_Emax_Value and Machine_Mantissa_Value instead of special-casing + each type. + * einfo.ads (Machine_Emax_Value, Machine_Emin_Value, + Machine_Mantissa_Value, Machine_Radix_Value, Model_Emin_Value, + Model_Epsilon_Value, Model_Mantissa_Value, Model_Small_Value, + Safe_Emax_Value, Safe_First_Value, Safe_Last_Value): Add new + synthesized floating point attributes. + * einfo.adb (Float_Rep): Determine the kind of floating point + representation used for a given type. + (Machine_Emax_Value, Machine_Emin_Value, Machine_Mantissa_Value, + Machine_Radix_Value): Implement based on Float_Rep_Kind of a type and + the number of digits in the type. + (Model_Emin_Value, Model_Epsilon_Value, Model_Mantissa_Value, + Model_Small_Value, Safe_Emax_Value, Safe_First_Value, Safe_Last_Value): + Implement new synthesized floating point attributes based on the various + machine attributes. + * eval_fat.ads: Remove Machine_Mantissa and Machine_Radix. + * eval_fat.adb (Machine_Mantissa, Machine_Radix): Remove. Use the + Machine_Mantissa_Value and Machine_Radix_Value functions instead. + * exp_vfpt.adb (VAXFF_Digits, VAXDF_Digits, VAXFG_Digits): Define local + constants, instead of using constants from Ttypef. + * gnat_rm.texi: Reword comments referencing Ttypef. + * sem_attr.ads: Reword comment referencing Ttypef. + * sem_attr.adb (Float_Attribute_Universal_Integer, + Float_Attribute_Universal_Real): Remove. + (Attribute_Machine_Emax, Attribute_Machine_Emin, + Attribute_Machine_Mantissa, Attribute_Model_Epsilon, + Attribute_Model_Mantissa, Attribute_Model_Small, Attribute_Safe_Emax, + Attribute_Safe_First, Attribute_Safe_Last, Model_Small_Value): Use + attributes in Einfo instead of Float_Attribute_Universal_Real and + Float_Attribute_Universal_Integer and all explicit constants. + * sem_util.ads, sem_util.adb (Real_Convert): Remove. + * sem_vfpt.adb (VAXDF_Digits, VAXFF_Digits, VAXGF_Digits, IEEEL_Digits, + IEEES_Digits): New local constants, in order to remove dependency on + Ttypef. + * tbuild.ads (Make_Float_Literal): New function. + * tbuild.adb (Make_Float_Literal): New function to create a new + N_Real_Literal, constructing it as simple as possible for best + output of constants in -gnatS. + * ttypef.ads: Remove. + +2010-10-22 Robert Dewar + + * checks.adb (Apply_Predicate_Check): Remove attempt at optimization + when subtype is the same, caused legitimate checks to be missed. + * exp_ch13.adb (Build_Predicate_Function): Use Nearest_Ancestor to get + inheritance from right entity. + * freeze.adb (Freeze_Entity): Use Nearest_Ancestor to freeze in the + derived type case if the ancestor type has predicates. + * sem_aux.ads, sem_aux.adb (Nearest_Ancestor): New function. + * sem_prag.adb (Check_Enabled): Minor code reorganization. + +2010-10-22 Arnaud Charlet + + * gcc-interface/utils.c, gcc-interface/gigi.h: Minor reformatting. + +2010-10-22 Thomas Quinot + + * einfo.ads (Declaration_Node): Clarify documentation, in particular + regarding what is returned for subprogram entities. + +2010-10-22 Arnaud Charlet + + * exp_attr.adb (Make_Range_Test): Generate a Range node instead of + explicit comparisons, generates simpler expanded code. + * a-except-2005.adb (Rcheck_06_Ext): New. + * gcc-interface/trans.c (gigi, gnat_to_gnu): Handle validity checks + like range checks. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-10-22 Robert Dewar + + * sem_ch3.adb (Array_Type_Declaration): Error for subtype wi predicate + for index type + (Constrain_Index): Error of subtype wi predicate in index constraint + * sem_ch9.adb (Analyze_Entry_Declaration): Error of subtype wi + predicate in entry family. + * sem_res.adb (Resolve_Slice): Error of type wi predicate in slice. + +2010-10-22 Javier Miranda + + * sem_util.ads, sem_util.adb (Collect_Parents): New subprogram. + (Original_Corresponding_Operation): New subprogram. + (Visible_Ancestors): New subprogram. + * sem_ch6.adb (New_Overloaded_Entity): Handle new case of dispatching + operation that overrides a hidden inherited primitive. + * sem_disp.adb (Find_Hidden_Overridden_Primitive): New subprogram. + (Check_Dispatching_Operation): if the new dispatching operation + does not override a visible primtive then check if it overrides + some hidden inherited primitive. + +2010-10-22 Ed Schonberg + + * sem_ch10.adb (Analyze_With_Clause): If the parent_unit_name in a with + clause is a child unit that denotes a renaming, replace the + parent_unit_name with a reference to the renamed unit, because the + prefix is irrelevant to subsequent visibility.. + +2010-10-22 Robert Dewar + + * einfo.ads, einfo.adb (Has_Predicates): Flag is now on all entities + (simplifies code). + * exp_ch13.adb (Build_Predicate_Function): Output info msgs for + inheritance. + * sem_ch13.adb (Analyze_Aspect_Specifications): Make sure we have a + freeze node for entities for which a predicate is specified. + (Analyze_Aspect_Specifications): Avoid duplicate calls + * sem_ch3.adb (Analyze_Full_Type_Declaration): Remove attempt to avoid + duplicate calls to Analye_Aspect_Specifications. + +2010-10-22 Thomas Quinot + + * a-exextr.adb, atree.ads, freeze.adb: Minor reformatting. + +2010-10-21 Robert Dewar + + * sem_ch3.adb: Minor reformatting. + +2010-10-21 Thomas Quinot + + * einfo.ads (Next_Girder_Discriminant): Remove obsolete description for + removed routine. + +2010-10-21 Nicolas Roche + + * gnatmem.adb, memroot.adb, memroot.ads, gmem.c, + gcc-interface/Makefile.in: Remove gnatmem specific files. + +2010-10-21 Thomas Quinot + + * sem_res.adb, exp_ch13.adb: Minor reformatting. + +2010-10-21 Thomas Quinot + + * sem_ch3.adb (Check_Or_Process_Discriminant): Reject illegal attempt + to provide a tagged full view as the completion of an untagged partial + view if the partial view has a discriminant with default. + +2010-10-21 Arnaud Charlet + + * gcc-interface/Make-lang.in: Update dependencies. + +2010-10-21 Robert Dewar + + * checks.ads, checks.adb (Apply_Predicate_Check): New procedure + Minor code reorganization. + * einfo.adb (Has_Predicates): Fix assertion. + * exp_ch13.adb (Build_Predicate_Function): Move from Sem_Ch13 spec to + Exp_Ch13 body. + (Expand_N_Freeze_Entity): Call build predicate function. + * exp_ch4.adb (Expand_N_Type_Conversion): Add predicate check. + * exp_ch5.adb (Expand_N_Assignment_Statement): Add predicate check. + * exp_prag.adb (Expand_Pragma_Check): Use all lower case for name of + check. + * freeze.adb (Freeze_Entity): Move building of predicate function to + Exp_Ch13. + * sem_ch13.adb (Build_Predicate_Function): Move from Sem_Ch13 to + Exp_Ch13. + * sem_ch13.ads (Build_Predicate_Function): Move from Sem_Ch13 to + Exp_Ch13. + * sem_ch3.adb (Analyze_Declarations): Remove call to build predicate + function. + * sem_res.adb (Resolve_Actuals): Apply predicate check. + +2010-10-21 Robert Dewar + + * einfo.ads, einfo.adb: Replace Predicate_Procedure by + Predicate_Functions. + * exp_ch4.adb (Expand_N_In): Handle predicates. + * exp_util.ads, exp_util.adb (Make_Predicate_Call): New function. + (Make_Predicate_Check): New function. + * freeze.adb (Freee_Entity): Build predicate function if needed. + * sem_ch13.adb (Build_Predicate_Function): New procedure. + (Analyze_Aspect_Specifications): No third argument for Predicate pragma + built from Predicate aspect. + * sem_ch13.ads (Build_Predicate_Function): New procedure. + * sem_ch3.adb: Add handling for predicates. + * sem_eval.adb (Eval_Membership_Op): Never static if predicate + functions around. + * sem_prag.adb (Analye_Pragma, case Predicate): Does not take a third + argument. + +2010-10-21 Robert Dewar + + * einfo.ads, einfo.adb: Add handling of predicates. + Rework handling of invariants. + * exp_ch3.adb, exp_ch4.adb, exp_util.adb, sem_ch6.adb: Minor changes to + handing of invariants. + * par-prag.adb: Add dummy entry for pragma Predicate + * sem_ch13.adb (Analyze_Aspect_Specifications): Add processing for + Predicate aspects. + * sem_prag.adb: Add implementation of pragma Predicate. + * snames.ads-tmpl: Add entries for pragma Predicate. + +2010-10-21 Robert Dewar + + * elists.adb: Minor reformatting. + +2010-10-21 Geert Bosch + + * urealp.adb (UR_Write): Write hexadecimal constants with exponent 1 as + decimal constants, and write any others using the exponent notation. + Minor reformatting throughout + (Store_Ureal_Normalized): New function (minor code reorganization) + +2010-10-21 Robert Dewar + + * einfo.ads, xeinfo.adb: Minor reformatting. + * s-stalib.ads: Minor comment fixes. + +2010-10-21 Ed Schonberg + + * sem_ch6.adb (Enter_Overloaded_Entity): Refine warning message about + hiding, to remove noise warnings about hiding predefined operators. + +2010-10-21 Emmanuel Briot + + * g-comlin.adb (Add_Switch): Fix handling of switches with no separator + when the parameter has length 1. + +2010-10-21 Jose Ruiz + + * sem_prag.adb (Set_Ravenscar_Profile): Enforce the restrictions of no + dependence on Ada.Execution_Time.Timers, + Ada.Execution_Time.Group_Budget, and + System.Multiprocessors.Dispatching_Domains which are part of the + Ravenscar Profile. + * impunit.adb (Non_Imp_File_Names_05): Add the file "a-etgrbu" to the + list of Ada 2005 files for package Ada.Execution_Time.Group_Budgets. + (Non_Imp_File_Names_12): Add the file "s-mudido" to the list of Ada 2012 + files for package System.Mutiprocessors.Dispatching_Domains. + +2010-10-21 Tristan Gingold + + * ug_words, vms_data.ads: Define the VMS qualifier for -gnateE. + +2010-10-21 Thomas Quinot + + * sem_ch3.ads (Process_Discriminants): Clarify cases where this is + called for a completion. + +2010-10-21 Geert Bosch + + * uintp.ads: Expand image buffer to have enough room for 128-bit values + * urealp.ads (UR_Write): Write constants in base 16 in hexadecimal + notation; either as fixed point literal or in canonical radix 16 + floating point form. + +2010-10-21 Robert Dewar + + * a-cgaaso.ads, a-tags.ads, exp_ch3.adb, exp_attr.adb, exp_ch4.adb, + exp_ch3.ads, exp_ch7.adb, exp_ch9.adb, exp_disp.adb, exp_disp.ads, + exp_dist.adb, exp_util.adb, layout.adb, lib-xref.adb, lib.ads, + prep.adb, prj-strt.adb, s-ststop.adb, s-taskin.ads, s-tataat.ads, + sem_aggr.adb, sem_attr.adb, sem_ch12.adb, sem_ch3.adb, sem_ch4.adb, + sem_ch4.ads, sem_ch5.adb, sem_res.adb, sem_util.adb, einfo.adb, + g-sothco.ads, make.adb: Minor reformatting + +2010-10-21 Vincent Celier + + * vms_data.ads: Add new qualifiers /SRC_INFO= and + /UNCHECKED_SHARED_LIB_IMPORTS for GNAT COMPILE. + Correct qualifier /SRC_INFO= for GNAT MAKE + +2010-10-21 Ed Schonberg + + * exp_aggr.adb (Flatten): An association for a subtype may be an + expanded name. + (Safe_Left_Hand_Side): An unchecked conversion is part of a safe + left-hand side if the expression is. + (Is_Safe_Index): new predicate + * exp_ch3.adb (Expand_Freeze_Enumeration_Type): Indicate that the + generated Rep_To_Pos function is a Pure_Function. + +2010-10-21 Robert Dewar + + * gnat_rm.texi: Document Invariant pragma. + +2010-10-21 Javier Miranda + + * exp_ch5.adb: Update comment. + +2010-10-21 Robert Dewar + + * sem_ch13.adb (Build_Invariant_Procedure): Remove commented out code + for interfaces, since invariants are not allowed on interfaces in any + case. + +2010-10-21 Javier Miranda + + * sem_attr.adb (Resolve_Attribute): After replacing the range attribute + node with a range expression ensure that its evaluation will not have + side effects. + * exp_ch5.adb (Expand_Assign_Array): Propagate the Parent to the + unchecked conversion node generated to handle assignment of private + types. Required to allow climbing the subtree if Insert_Action is + invoked later. + +2010-10-21 Robert Dewar + + * par-ch3.adb (P_Interface_Type_Definition): Allow for possibility of + aspect clause presence terminating the type definition. + +2010-10-21 Robert Dewar + + * exp_ch4.adb, exp_intr.adb, par-ch4.adb, scn.adb, sem_ch4.adb, + sem_res.adb, sem_util.adb, sinfo.ads, a-except-2005.adb: Minor + reformatting. + * snames.ads-tmpl: Add note on Name_Some (not a reserved keyword). + +2010-10-21 Geert Bosch + + * ttypef.ads: Further cleanup of Safe_XXX float attributes. + +2010-10-19 Ed Schonberg + + * exp_ch4.adb, exp_ch4.ads (Expand_Quantified_Expression): New procedure + * exp_util.adb (Insert_Actions): Include Quantified_Expression. + * expander.adb: Call Expand_Qualified_Expression. + * par.adb: New procedure P_Quantified_Expression. Make + P_Loop_Parameter_Specification global for use in quantified expressions. + * par-ch3.adb (P_Subtype_Mark_Resync): Allow "some" as an identifier if + version < Ada2012. + * par-ch4.adb: New procedure P_Quantified_Expression. + * par-ch5.adb: P_Loop_Parameter_Specification is now global. + * scans.adb, scans.ads: Introduce token Some. For now leave as + unreserved. + * scn.adb (Scan_Reserved_Identifier): For earlier versions of Ada, + treat Some as a regular identifier. + * sem.adb: Call Analyze_Quantified_Expression. + * sem_ch4.adb, sem_ch4.ads: New procedure Analyze_Quantified_Expression. + * sem_ch5.adb, sem_ch5.ads: Analyze_Iteration_Scheme is public, for use + in quantified expressions. + * sem_res.adb: New procedure Resolve_Qualified_Expression. + * sinfo.adb, sinfo.ads: New node N_Quantified_Expression + * snames.ads-tmpl: New name Some. + * sprint.adb: Output quantified_expression. + +2010-10-19 Robert Dewar + + * a-exexda.adb: Minor reformatting + Minor code reorganization. + +2010-10-19 Robert Dewar + + * sem_eval.adb: Minor reformatting. + +2010-10-19 Tristan Gingold + + * exp_ch4.adb (Expand_N_And_Op, Expand_N_Or_Op, Expand_N_Xor_Op): Call + Expand_Intrinsic_Call if the function is intrinsic. + * exp_intr_adb (Expand_Binary_Operator): Handle VMS case for logical + binary operator on the unsigned_quadword record. + * exp_intr.ads (Expand_Intrinsic_Call): Update comments. + +2010-10-19 Geert Bosch + + * gnat_rm.texi (pragma Float_Representation): Fix typo. + +2010-10-19 Arnaud Charlet + + * switch-c.adb (Scan_Front_End_Switches): Add handling of -gnateE. + * fe.h (Exception_Extra_Info): Declare. + * usage.adb (usage): Add -gnateE doc. + * checks.adb (Install_Null_Excluding_Check): Use better sloc. + * sem_util.adb (Insert_Explicit_Dereference): Ditto. + * gnat_ugn.texi: Document -gnateE switch. + * a-except.adb (Set_Exception_C_Msg): New parameter Column. + * a-except-2005.adb (Set_Exception_C_Msg): New parameter Column. + (Raise_Constraint_Error_Msg): Ditto. + (Image): New helper function. + (Rcheck_00_Ext, Rcheck_05_Ext, Rcheck_12_Ext): New procedure with more + detailed exception information. + Adjust calls to Set_Exception_C_Msg and Raise_Constraint_Error_Msg. + * a-exexda.adb (Set_Exception_C_Msg): New parameter Column. + * opt.ads (Exception_Extra_Info): New flag. + * gcc-interface/utils.c (gnat_raise_decls_ext): New. + * gcc-interface/utils2.c (build_call_raise_range, + build_call_raise_column): New functions. + * gcc-interface/gigi.h (exception_info_kind, gnat_raise_decls_ext, + build_call_raise_range, build_call_raise_column): Declare. + gcc-interface/trans.c (build_raise_check): New function. + (gigi): Initialize gnat_raise_decls_ext. + (gnat_to_gnu): Add initial support for -gnateE switch. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-10-19 Geert Bosch + + * ttypef.ads: Change VAXDF_Last to be -VAXDF_First, as type is + symmetric. + +2010-10-19 Robert Dewar + + * atree.h (Field29): Fix incorrect definition. + * einfo.adb (Invariant_Procedure): New attribute + (Has_Invariants): New flag + (Has_Inheritable_Invariants): New flag + (OK_To_Reference): New flag + Minor code reorganization (use Next_Rep_Item function) + * einfo.ads (Invariant_Procedure): New attribute + (Has_Invariants): New flag + (Has_Inheritable_Invariants): New flag + (OK_To_Reference): New flag + * exp_ch3.adb (Expand_N_Object_Declaration): Add check for invariant + * exp_ch4.adb (Expand_N_Type_Conversion): Check invariant on type + conversion. Minor reformatting. + * exp_util.ads, exp_util.adb (Make_Invariant_Call): New procedure. + * opt.ads (List_Inherited_Aspects): New name for List_Inherited_Pre_Post + * par-prag.adb: Add dummy entry for pragma Invariant. + * sem_ch13.adb (Build_Invariant_Procedure): New procedure + (Analyze_Aspect_Specification): Add support for Invariant aspect + * sem_ch13.ads (Build_Invariant_Procedure): New procedure + * sem_ch3.adb (Build_Derived_Type): Propagate invariant information + (Process_Full_View): Deal with invariants, building invariant procedure + Minor reformatting + * sem_ch6.adb (Process_PPCs): Add processing of invariants + * sem_ch7.adb (Analyze_Package_Specification): Build invariant + procedures. + * sem_prag.adb: Implement pragma Invariant. + * sem_res.adb (Resolve_Entity_Name): Allow type reference if + OK_To_Reference set. + * sem_warn.adb (List_Inherited_Aspects): New name for + List_Inherited_Pre_Post. + * snames.ads-tmpl: Add entries for pragma Invariant. + * treepr.adb (Print_Entity_Information): Add handling of Field29. + * usage.adb: Warning .l/.L applies to invariant as well as pre/post. + +2010-10-19 Javier Miranda + + * par-ch4.adb: Update documentation of Ada 2012 syntax rules for + membership test. + +2010-10-19 Bob Duff + + * sem_attr.adb (Eval_Attribute): Implement Max_Alignment_For_Allocation + attribute. + * exp_attr.adb (Expand_N_Attribute_Reference): Add + Attribute_Max_Alignment_For_Allocation to the case statement. + * snames.ads-tmpl (Name_Max_Alignment_For_Allocation, + Attribute_Max_Alignment_For_Allocation): New attribute name. + +2010-10-19 Ed Schonberg + + * sem_ch3.adb (OK_For_Limited_Init_In_05): a call to an access to + parameterless function appears syntactically as an explicit dereference. + +2010-10-19 Thomas Quinot + + * sem_ch8.adb, sem_ch12.adb, opt.ads, sem_ch6.adb, sem_res.adb, + i-cexten.ads, exp_disp.adb, exp_ch4.adb, exp_ch9.adb: Minor reformatting + +2010-10-19 Thomas Quinot + + * sem_util.adb (Collect_Primitive_Operations): A function with an + anonymous access result designating T is a primitive operation of T. + +2010-10-19 Tristan Gingold + + * init.c: On Alpha/VMS, only adjust PC for HPARITH. + +2010-10-19 Tristan Gingold + + * sem_attr.adb (Eval_Attribute): Handle Attribute_Ref, which can be + evaluated on VMS. + +2010-10-19 Ed Schonberg + + * sem_ch12.adb (Check_Generic_Child_Unit): Handle properly the case of + an instantiation of a renaming of the implicit generic child that + appears within an instance of its parent. + +2010-10-19 Thomas Quinot + + * exp_ch9.adb: Minor reformatting. + * einfo.adb, einfo.ads, atree.adb, atree.ads, exp_dist.adb, atree.h: + (Referenced_Object): Remove unused entity attribute. + (Direct_Primitive_Operations): Move to Elist10, this is set for all + tagged types, including synchronous ones, so can't use field15 which is + used as Storage_Size_Variable for task types and Entry_Bodies_Array for + protected types. + (Add_RACW_Primitive_Declarations_And_Bodies): Remove bogus guard + against Concurrent_Types (we must handle the case of a RACW designating + a class-wide private synchronous type). + Use Direct_Primitive_Operations, not Primitive_Operations, since we + really want the former. + +2010-10-19 Bob Duff + + * sem_ch8.adb (Pop_Scope): Change "return;" to "raise Program_Error;". + +2010-10-19 Javier Miranda + + * exp_ch4.adb (Expand_Set_Membership.Make_Cond): Add missing support + for N_Range nodes. + +2010-10-19 Thomas Quinot + + * einfo.ads, atree.ads: Minor comment fixes. + +2010-10-18 Bob Duff + + * sinfo.ads, sinfo.adb: Modify comment about adding fields to be more + correct, and to be in a more convenient order. + (Default_Storage_Pool): New field of N_Compilation_Unit_Aux, for + recording the Default_Storage_Pool for a parent library unit. + * einfo.ads (Etype): Document the case in which Etype can be Empty. + * sem_prag.adb (Pragma_Default_Storage_Pool): Analyze the new + Default_Storage_Pool pragma. + * sem.ads (Save_Default_Storage_Pool): Save area for push/pop scopes. + * gnat_ugn.texi: Document Default_Storage_Pool as a new configuration + pragma. + * freeze.adb (Freeze_Entity): When freezing an access type, take into + account any Default_Storage_Pool pragma that applies. We have to do + this at the freezing point, because up until that point, a Storage_Pool + or Storage_Size clause could occur, which should override the + Default_Storage_Pool. + * par-prag.adb: Add this pragma to the list of pragmas handled entirely + during semantics. + * sem_ch8.adb (Push_Scope, Pop_Scope): Save and restore the + Default_Storage_Pool information. + * opt.ads (Default_Pool, Default_Pool_Config): New globals for recording + currently-applicable Default_Storage_Pool pragmas. + * opt.adb: Save/restore the globals as appropriate. + * snames.ads-tmpl (Name_Default_Storage_Pool, + Pragma_Default_Storage_Pool): New pragma name. + +2010-10-18 Vincent Celier + + * make.adb (Switches_Of): Put the spec and body suffix in canonical + case. + +2010-10-18 Ed Schonberg + + * sem_ch13.adb (Analyze_Aspect_Specifications): If subprogram is at the + library level, the pre/postconditions must be treated as global + declarations, i.e. placed on the Aux_Decl nodes of the compilation unit. + * freeze.adb (Freeze_Expression): If the expression is at library level + there is no enclosing record to check. + +2010-10-18 Javier Miranda + + * sem_ch3.ads (Find_Type_Name): Add documentation. + * sem_ch3.adb (Analyze_Full_Type_Declaration): Code cleanup because the + propagation of the class-wide entity is now done by routine + Find_Type_Name to factorize this code. + (Analyze_Private_Extension_Declaration): Handle private type that + completes an incomplete type. + (Tag_Mismatch): Add error message for tag mismatch in a private type + declaration that completes an incomplete type. + (Find_Type_Name): Handle completion of incomplete type by means of + a private declaration. Generate an error if a tagged incomplete type + is completed by an untagged private type. + * sem_ch7.adb (New_Private_Type): Handle private type that completes an + incomplete type. + * einfo.ads (Full_View): Add documentation. + +2010-10-18 Ed Schonberg + + * sem_ch12.adb (Analyze_Formal_Package_Declaration): If the package is + a renaming, generate a reference for it before analyzing the renamed + entity, to prevent spurious warnings. + +2010-10-18 Jose Ruiz + + * adaint.c (__gnat_pthread_setaffinity_np, + __gnat_pthread_attr_setaffinity_np): Remove wrappers, no longer needed. + * s-osinte-linux.ads (pthread_setaffinity_np, + pthread_attr_setaffinity_np): Remove use of wrappers. + * s-taprop-linux.adb (Create_Task, Initialize): Restore check to verify + whether the affinity functionality is available in the OS. + * gcc-interface/utils.c: Set TREE_STATIC on functions only when there + are defined. + +2010-10-18 Robert Dewar + + * einfo.ads, einfo.adb: Minor reformatting. + * gnat_ugn.texi, ug_words: Add missing entries, fix typos. + +2010-10-18 Emmanuel Briot + + * g-comlin.adb (Is_In_Config): When the switch accepts either a space + or equal, we output an equal every time. + +2010-10-18 Ed Schonberg + + * sem_res.adb (Resolve_Entry_Call): Handle call to an entry family + member when pre/post conditions are present. + * exp_ch9.adb (Build_PPC_Wrapper): The PPC_Wrapper for an entry family + includes an index parameter, and the name of the enclosed entry call is + an indexed component. + +2010-10-18 Robert Dewar + + * einfo.ads, einfo.adb: Minor reformatting. + +2010-10-18 Jose Ruiz + + * adaint.c (__gnat_pthread_setaffinity_np, + __gnat_pthread_attr_setaffinity_np): Add these wrappers which check the + availability of the underlying OS functionality before calling. + * s-osinte-linux.ads (pthread_setaffinity_np, + pthread_attr_setaffinity_np): Call a wrapper instead of the OS function + to perform a check of its availability. + * s-taprop-linux.adb (Create_Task): Remove the check to verify whether + the affinity functionality is available in the OS. Now done in a wrapper + * gcc-interface/Makefile.in: Remove vmshandler.asm, unused. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-10-18 Robert Dewar + + * sinfo.ads, sinfo.adb: Change Has_Pragma_CPU to Flag14 (Flag10 is + standard field). + +2010-10-18 Robert Dewar + + * s-stausa.adb, s-taprop-linux.adb, s-taprop-mingw.adb, s-tassta.ads: + Minor reformatting. + +2010-10-18 Robert Dewar + + * exp_strm.adb (Build_Elementary_Input_Call): Check + No_Default_Stream_Attributes. + (Build_Elementary_Write_Call): Check No_Default_Stream_Attributes + * s-rident.ads: Add restriction No_Default_Stream_Attributes + Put restriction No_Allocators_After_Elaboration in alpha order + +2010-10-18 Jose Ruiz + + * exp_ch9.adb (Expand_N_Task_Type_Declaration): Add field corresponding + to the affinity when expanding the task declaration. + (Make_Task_Create_Call): Add the affinity parameter to the call to + create task. + * sem_prag.adb (Analyze_Pragma): Add the analysis for pragma CPU, + taking into account the case when it applies to a subprogram (only for + main and with static expression) or to a task. + * par_prag.adb:(Prag): Make pragma CPU a valid one. + * snames.ads-tmpl (Name_uCPU, Name_CPU): Add these new name identifiers + used by the expander for handling the affinity parameter when creating + a task. + (Pragma_Id): Add Pragma_CPU as a valid one. + * rtsfind.ads (RTU_Id): Make System_Multiprocessors accesible. + (RE_Id, RE_Unit_Table): Make the entities RE_CPU_Range and + RE_Unspecified_CPU visible. + * sinfo.ads, sinfo.adb (Has_Pragma_CPU, Set_Has_Pragma_CPU): Add these + two subprograms to set/get the flag indicating whether there is a + pragma CPU which applies to the entity. + * lib.ads, lib.adb (Unit_Record, Default_Main_CPU, Main_CPU, + Set_Main_CPU): Add the field Main_CPU to Unit_Record to store the value + of the affinity associated to the main subprogram (if any). + Default_Main_CPU is used when no affinity is set. Subprograms + Set_Main_CPU and Main_CPU are added to set/get the affinity of the main + subprogram. + * ali.ads, ali.adb (ALIs_Record): Add field Main_CPU to contain the + value of the affinity of the main subprogram. + (Scan_ALI): Get the affinity of the main subprogram (encoded as C=XX in + the M line). + * lib-writ.ads, lib-writ.adb (M_Parameters): Encode the affinity of the + main subprogram in the M (main) line using C=XX. + * lib-load.adb (Create_Dummy_Package_Unit, Load_Main_Source, + Load_Unit): Add new field Main_CPU. + * bindgen.adb (Gen_Adainit_Ada, Gen_Adainit_C): Add the code to pass + the affinity of the main subprogram to the run time. + * s-taskin.ads (Common_ATCB): Add the field Base_CPU to store the + affinity. + (Unspecified_CPU): Add this constant to identify the case when no + affinity is set for tasks. + * s-taskin.adb (Initialize_ATCB): Store the value coming from pragma + CPU in the common part of the ATCB. + (Initialize): Store the value coming from pragma CPU (for the + environment task) in the common part of the ATCB. + * s-tassta.ads, s-tassta.adb (Create_Task): Add the affinity specified + by pragma CPU to the ATCB. + * s-tarest.ads, s-tarest.adb (Create_Restricted_Task): Add the affinity + specified by pragma CPU to the ATCB. + * s-tporft.adb (Register_Foreign_Thread): Add the new affinity + parameter to the call to Initialize_ATCB. + * s-taprop-linux.adb (Create_Task): Change the attributes of the thread + to include the task affinity before creation. Additionally, the + affinity selected with Task_Info is also enforced changing the + attributes at task creation time, instead of changing it after creation. + (Initialize): Change the affinity of the environment task if required + by a pragma CPU. + * s-osinte-linux.ads (pthread_setaffinity_np): Instead of using a + wrapper to check whether the function is available or not, use a weak + symbol. + (pthread_attr_setaffinity_np): Add the import of this function which is + used to change the affinity in the attributes used to create a thread. + * adaint.c (__gnat_pthread_attr_setaffinity_np): Remove this wrapper. + It was used to check whether the pthread function was available or not, + but the use of a weak symbol handles this situation in a cleaner way. + * s-taprop-mingw.adb (Create_Task, Initialize): Change the affinity of + tasks (including the environment task) if required by a pragma CPU. + * s-taprop-solaris.adb (Enter_Task): Change the affinity of tasks + (including the environment task) if required by a pragma CPU. + * s-taprop-vxworks.adb (Create_Task, Initialize): Change the affinity + of tasks (including the environment task) if required by a pragma CPU. + * init.c (__gl_main_cpu): Make this value visible to the run time. It + will pass the affinity of the environment task. + +2010-10-18 Javier Miranda + + * einfo.adb (Direct_Primitive_Operations): Complete assertion. + +2010-10-18 Vincent Celier + + * prj.ads (Source_Data): New Boolean flag In_The_Queue. + +2010-10-18 Tristan Gingold + + * s-stausa.ads: Add the Top parameter to Initialize_Analyzer. + * s-stausa.adb: Use the top parameter. In Fill_Stack, use the + stack top if known. + * s-tassta.adb (Task_Wrapper): Call Initialize_Analyzer after Enter_Task + so that Pri_Stack_Info.Limit can be set and used. + +2010-10-18 Robert Dewar + + * einfo.ads: Minor reformatting. + * sem_res.adb (Resolve_Allocator): Add test for violating + No_Anonymous_Allocators. + +2010-10-18 Robert Dewar + + * prj-nmsc.adb, prj.adb, sem_res.adb: Minor reformatting. + +2010-10-18 Ed Schonberg + + * sem_util.adb (Insert_Explicit_Dereference): If operand is a selected + component, we generate a reference to the ultimate prefix when it is an + entity name. We must place the reference on the identifier for that + prefix, and not on the operand itself, to prevent spurious extra + references in the ali file. + +2010-10-18 Vincent Celier + + * projects.texi: Add documentation for attribute Ignore_Source_Sub_Dirs + +2010-10-18 Ed Schonberg + + * einfo.ads, einfo.adb: New attribute PPC_Wrapper for entries and entry + families. Denotes a procedure that performs pre/postcondition checks + and then performs the entry call. + * sem_res.adb (Resolve_Entry_Call): If the entry has + pre/postconditions, replace call with a call to the PPC_Wrapper of the + entry. + * exp_ch9.adb (Build_PPC_Wrapper): new procedure. + (Expand_N_Entry_Declaration, Expand_N_Protected_Type_Declaration): call + Build_PPC_Wrapper for all entries in task and protected definitions. + +2010-10-18 Tristan Gingold + + * init.c: Add __gnat_set_stack_guard_page and __gnat_set_stack_limit. + Implement stack limitation on VMS. + Minor reformatting. + +2010-10-18 Vincent Celier + + * prj.adb (Is_Compilable): Do not modify Source.Compilable until the + source record has been initialized. + +2010-10-18 Robert Dewar + + * einfo.adb: Minor code reorganization (Primitive_Operations is a + synthesized attribute routine and was in the wrong place). + +2010-10-18 Tristan Gingold + + * init.c: Indentation, and minor changes to more closely follow GNU + style rules. Make more variable statics. + +2010-10-18 Vincent Celier + + * prj.adb (Is_Compilable): On first call for a source, cache value in + component Compilable. + * prj.ads (Source_Data): New component Compilable, to cache the value + returned by function Is_Compilable. + +2010-10-18 Vincent Celier + + * prj-attr.adb: New project level attribute Ignore_Source_Sub_Dirs. + * prj-nmsc.adb (Expand_Subdirectory_Pattern): New string list parameter + Ignore. + (Recursive_Find_Dirs): Do not consider subdirectories listed in Ignore. + (Get_Directories): Call Find_Source_Dirs with the string list + indicated by attribute Ignore_Source_Sub_Dirs. + * snames.ads-tmpl: New standard name Ignore_Source_Sub_Dirs. + +2010-10-18 Javier Miranda + + * einfo.ads, einfo.adb (Primitive_Operations): New synthesized + attribute. + (Direct_Primitive_Operations): Renaming of old Primitive_Operations. + (Set_Direct_Primitive_Operations): Renaming of old + Set_Primitive_Operations. Update documentation + * sem_ch3.adb, exp_util.adb, sem_ch7.adb, sem_ch8.adb, exp_ch3.adb: + Replace occurrences of Set_Primitive_Operations by + Set_Direct_Primitive_Operations. + * sem_cat.adb (Validate_RACW_Primitives): No action needed for tagged + concurrent types. + * exp_dist.adb (Add_RACW_Primitive_Declarations_And_Bodies): Do not + process primitives of concurrent types. + * lib-xref.adb (Generate_Prim_Op_References): Minor code cleanup. + +2010-10-18 Eric Botcazou + + * exp_ch6.adb (Expand_N_Subprogram_Declaration): Use Freeze_Before. + (Expand_Protected_Object_Reference): Likewise. + * sem_attr.adb (Resolve_Attribute): Likewise. + * sem_ch3.adb (Analyze_Subtype_Declaration): Likewise. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Likewise. + +2010-10-18 Arnaud Charlet + + * g-comlin.adb (Get_Switches): Prevent dereferencing null Config. + +2010-10-18 Robert Dewar + + * aspects.ads, aspects.adb: Add entries for aspects + Read/Write/Input/Output. + * sem_ch13.adb (Analyze_Aspect_Specifications): Add processing for + handling aspects Read/Write/Input/Output. + +2010-10-18 Robert Dewar + + * sem_util.adb (Note_Possible_Modification): Do not give warning for + use of pragma Unmodified unless we are sure this is a modification. + +2010-10-18 Tristan Gingold + + * sysdep.c: Add __gnat_get_stack_bounds. + * s-taprop-mingw.adb Call __gnat_get_stack_bounds to set Pri_Stack_Info. + +2010-10-18 Robert Dewar + + * a-assert.ads: Fix bad name in header. + * sem_ch4.adb, sem_ch6.adb, sem_ch7.adb, sem_ch10.adb: Minor + reformatting. + * exp_aggr.adb: Fix typo in comment. + +2010-10-18 Javier Miranda + + * exp_util.adb (Side_Effect_Free): Code clean up. + +2010-10-18 Ed Schonberg + + * sem_ch8.adb (Is_Primitive_Operator_In_Use): Renamed from + Is_Primitive_Operator. When ending the scope of a use package scope, a + primitive operator remains in use if the base type has a current use + (type) clause. + +2010-10-18 Javier Miranda + + * einfo.ads (Is_Dynamic_Support): Add missing support for limited + private types whose full-view is a task type. + * sem_util.adb (Enclosing_Subprogram): Add missing support for limited + private types whose full-view is a task type. + * exp_ch7.adb (Find_Final_List): Minor code cleanup replacing code by + function Nearest_Dynamic_Scope which provides the needed functionality. + +2010-10-18 Arnaud Charlet + + * sem_prag.adb (Set_Exported): Do not generate error when exporting a + variable with an address clause in codepeer mode. + +2010-10-18 Robert Dewar + + * g-trasym-vms-ia64.adb: Minor reformatting. + +2010-10-18 Thomas Quinot + + * sem_type.adb (Covers): If either argument is Standard_Void_Type and + the other isn't, return False early. + +2010-10-18 Ed Falis + + * s-vxwext-rtp.ads, s-vxext-rtp.adb: Adapt for missing APIs for RTPs in + VxWorks Cert. + +2010-10-18 Robert Dewar + + * sem_disp.ads: Minor comment update. + +2010-10-18 Robert Dewar + + * einfo.ads, einfo.adb (Spec_PPC_List): Is now present in Entries + * sem_ch3.adb (Analyze_Declarations): Add processing for delaying + visibility analysis of precondition and postcondition pragmas (and + Pre/Post aspects). + * sem_ch6.adb (Process_PPCs): Add handling of inherited Pre'Class + aspects. + * sem_ch7.adb (Analyze_Package_Specification): Remove special handling + of pre/post conditions (no longer needed). + * sem_disp.adb (Inherit_Subprograms): Deal with interface case. + * sem_prag.adb (Analyze_PPC_In_Decl_Part): Remove analysis of message + argument, since this is now done in the main processing for + pre/postcondition pragmas when they are first seen. + (Chain_PPC): Pre'Class and Post'Class now handled properly + (Chain_PPC): Handle Pre/Post aspects for entries + (Check_Precondition_Postcondition): Handle entry declaration case + (Check_Precondition_Postcondition): Handle delay of visibility analysis + (Check_Precondition_Postcondition): Preanalyze message argument if + present. + +2010-10-18 Robert Dewar + + * g-trasym-vms-ia64.adb, prj-nmsc.adb, prj.ads: Minor reformatting. + +2010-10-14 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Set + TREE_THIS_NOTRAP on the INDIRECT_REF node built for the template. + * gcc-interface/trans.c (Identifier_to_gnu): Set TREE_THIS_NOTRAP on + the INDIRECT_REF node built for objects used by reference. + * gcc-interface/utils2.c (build_binary_op): Add short-circuit for + constant result. Set TREE_THIS_NOTRAP on ARRAY_REF and ARRAY_RANGE_REF. + (gnat_stabilize_reference_1): Propagate the TREE_THIS_NOTRAP flag. + +2010-10-13 Richard Henderson + + * gcc-interface/misc.c (gnat_eh_personality): Update call to + build_personality_function. + * raise-gcc.c (PERSONALITY_FUNCTION): Change to match other languages; + use__gnat_personality_{v,sj}0. + +2010-10-12 Vincent Celier + + * prj-nmsc.adb (Add_Source): Put source in hash table Source_Files_HT + (Process_Exceptions_File_Based): Use hash table Source_Files_HT instead + of iterating through all sources of the project. + * prj.adb (Free): Reset hash table Source_Files_HT + (Reset): Reset hash table Source_Files_HT + * prj.ads (Source_Data): New component Next_With_File_Name + (Source_Files_Htable): New hash table + (Project_Tree_Data): New component Source_Files_HT + +2010-10-12 Tristan Gingold + + * g-trasym-vms-ia64.adb: Use the documented API. + * gcc-interface/Makefile.in: Always set NO_REORDER_ADAFLAGS. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-10-12 Thomas Quinot + + * rtsfind.ads, exp_dist.adb, exp_dist.ads (Build_General_Calling_Stubs, + PolyORB case): Request is now a controlled type: we can declare the + request on the stack, and we do not need explicit cleanup actions + anymore. + +2010-10-12 Bob Duff + + * s-rident.ads (Profile_Info): This variable is now constant. + +2010-10-12 Emmanuel Briot + + * g-comlin.adb, g-comlin.ads (Define_Switch): Put back (unused) + parameter Separator for backward compatibility. + +2010-10-12 Robert Dewar + + * sem_ch9.adb, par-ch9.adb, impunit.adb: Minor reformatting. + +2010-10-12 Vincent Celier + + * debug.adb: Put detailed documentation for gnatmake switch -dm. + +2010-10-12 Vincent Celier + + * gnat1drv.adb: When the compiler is invoked for a spec that needs aw + body, do not generate an ALI file if neither -gnatc nor -gnatQ is used. + +2010-10-12 Arnaud Charlet + + * g-comlin.adb (Foreach_Switch): Make this procedure generic to avoid + using 'Access. + +2010-10-12 Robert Dewar + + * debug.adb: Add comment. + * gnatcmd.adb, sem_ch6.adb, switch-m.adb: Minor reformatting. + +2010-10-12 Javier Miranda + + * exp_util.adb (Side_Effect_Free): Return true for object renaming + declarations that were previously generated by Remove_Side_Effects. + +2010-10-12 Emmanuel Briot + + * xref_lib.adb (Get_Full_Type): Display "private variable" instead of + "???" when an entity is defined as "*" in the ALI file. + * g-comlin.ads, g-comlin.adb: Fix handling of null parameters. + Minor reformatting. + +2010-10-12 Emmanuel Briot + + * g-comlin.adb, g-comlin.ads (Display_Help, Getopt, Current_Section, + Set_Usage): New subprograms. + (Define_Switch): Change profile to add support for help messages and + long switches. + +2010-10-12 Javier Miranda + + * sem_ch6.adb (New_Overloaded_Entity): Add missing decoration of + attribute Overridden_Operation in predefined dispatching primitives. + +2010-10-12 Emmanuel Briot + + * g-comlin.adb, g-comlin.ads (Add_Switch): Raise an exception when a + command line configuration exists and we specify an invalid section. + +2010-10-12 Robert Dewar + + * sem_ch6.adb (Process_PPCs): Fix error in inheriting Pre'Class when no + exception messages are generated. + (Process_PPCs): Fix error in inheriting Pre'Class. + +2010-10-12 Jose Ruiz + + * gnatcmd.adb: Use response file for GNATstack. + (Check_Files): Pass the list of ci files for GNATstack using a response + file to avoid problems with command line length. + Factor out the code handling response file into a new procedure named + Add_To_Response_File. + +2010-10-12 Vincent Celier + + * debug.adb: For gnatmake, document the meaning of -dm + * make.adb (Gnatmake): If -dm is used, indicate the maximum number of + simultaneous compilations. + * switch-m.adb (Scan_Make_Switches): Allow -j0, meaning as many + simultaneous compilations as the number of processors. + +2010-10-12 Joseph Myers + + * gcc-interface/Make-lang.in (ada/misc.o): Use $(OPTIONS_H) + instead of options.h. + +2010-10-12 Robert Dewar + + * gnat_rm.texi: Clarify that 'Old can be used in preconditions and + postcondition pragmas. + +2010-10-12 Robert Dewar + + * errout.ads, erroutc.adb: The # insertion now handles from in place of + at. + * exp_prag.adb (Expand_Pragma_Check): Suppress generated default + message if new switch Exception_Locations_Suppressed is set. + (Expand_Pragma_Check): Revised wording for default message for case + of precondition or postcondition. + * namet.ads, namet.adb (Build_Location_String): New procedure. + * opt.ads (List_Inherited_Pre_Post): New flag. + * sem_ch12.adb (Analyze_Generic_Subprogram_Declaration): Add call to + list inherited pre/post aspects. + * sem_ch13.adb (Analyze_Aspect_Specification): Improve generation of + messages for precondition/postcondition cases. + * sem_ch6.adb (Process_PPCs): General cleanup, and list inherited PPC's + if flag List_Inherited_Pre_Post is set True. + (Process_PPCs): Add initial handling for inherited preconditions + (List_Inherited_Pre_Post_Aspects): New procedure + * sem_ch6.ads (List_Inherited_Pre_Post_Aspects): New procedure + * sem_disp.adb (Inherited_Subprograms): New function + * sem_disp.ads (Inherited_Subprograms): New function + * sem_prag.adb (Check_Duplicate_Pragma): Clean up handling of + pre/postcondition. + (Check_Precondition_Postcondition): Check for inherited aspects + * sem_warn.adb: Process -gnatw.l/w.L setting List_Inherited_Pre_Post + * sinfo.ads, sinfo.adb (Split_PPC): New flag. + * sinput.ads, sinput.adb (Build_Location_String): New function. + * usage.adb: Add line for -gnatw.l/-gnatw.L + +2010-10-12 Javier Miranda + + * exp_util.adb (Remove_Side_Effects): Remove wrong code. + +2010-10-12 Arnaud Charlet + + * xref_lib.adb: Add handling of j/J letters. + +2010-10-12 Pascal Obry + + * adaint.c (__gnat_number_of_cpus): Add implementation for Windows. + +2010-10-12 Arnaud Charlet + + * make.adb (Globalize): New procedure. + (Compile): Set Do_Codepeer_Globalize_Step when -gnatC is used. + (Gnatmake): Call Globalize when needed. + (Process_Restrictions_Or_Restriction_Warnings): Ignore Restrictions + pragmas in CodePeer mode. + (Adjust_Global_Switches): Set No_Initialize_Scalars in CodePeer mode, + to generate simpler and consistent code. + +2010-10-12 Bob Duff + + * exp_util.adb (Remove_Side_Effects): Disable previous change, + can cause side effects to be duplicated. + +2010-10-12 Robert Dewar + + * sem_ch6.adb (Process_PPCs): Handle inherited postconditions. + +2010-10-12 Arnaud Charlet + + * exp_disp.adb (Set_All_DT_Position): Disable emit error message on + abstract inherited private operation in CodePeer mode. + +2010-10-12 Thomas Quinot + + * a-exetim.ads: Minor reformatting. + * g-socket.ads (Port_Type): Better definition corresponding to the + actual standard range. + * exp_ch5.adb: Add comment. + * sem_aux.adb: Minor reformatting. + +2010-10-12 Ed Schonberg + + * sem_ch12.adb (Copy_Generic_Node): If node is a string literal, remove + string_literal_subtype so that a new one can be constructed in the + scope of the instance. + +2010-10-12 Robert Dewar + + * exp_ch9.adb (Has_Pragma_Priority): New name for Has_Priority_Pragma + * gnat_rm.texi (pragma Suppress_All): Document new placement rules + * par-prag.adb (P_Pragma, case Suppress_All): Set + Has_Pragma_Suppress_All flag. + * sem_prag.adb (Has_Pragma_Priority): New name for Has_Priority_Pragma + (Analyze_Pragma, case Suppress_All): Remove placement check + (Process_Compilation_Unit_Pragmas): Use Has_Pragma_Suppress_All flag + * sem_prag.ads (Process_Compilation_Unit_Pragmas): Update documentation + * sinfo.adb (Has_Pragma_Suppress_All): New flag + (Has_Pragma_Priority): New name for Has_Priority_Pragma + * sinfo.ads (Has_Pragma_Suppress_All): New flag + (Has_Pragma_Priority): New name for Has_Priority_Pragma + +2010-10-12 Arnaud Charlet + + * lib-xref.ads: Mark j/J as reserved for C++ classes. + +2010-10-12 Jose Ruiz + + * a-exetim-default.ads, a-exetim-posix.adb: New. + * gcc-interface/Makefile.in (LIBGNAT_TARGET_PAIRS for linux): Use the + POSIX Realtime support to implement CPU clocks. + (EXTRA_GNATRTL_TASKING_OBJS for linux): Add the a-exetim.o object + to the tasking library. + (THREADSLIB): Make the POSIX.1b Realtime Extensions library (librt) + available for shared libraries. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-10-12 Robert Dewar + + * sem_ch13.adb (Analyze_Aspect_Specifications): For Pre/Post, break + apart expressions with AND THEN clauses into separate pragmas. + * sinput.ads, sinput.adab (Get_Logical_Line_Number_Img): New function. + +2010-10-12 Robert Dewar + + * par-ch13.adb (P_Aspect_Specifications): Fix handling of 'Class + aspects. + * sem_ch13.adb (Analyze_Aspect_Specifications): Fix bad Sloc on aspects + * sem_prag.adb (Fix_Error): Only change pragma names for pragmas from + aspects. + (Check_Optional_Identifier): Handle case of direct arguments + (Chain_PPC): Test for abstract case, giving appropriate messages + * sinfo.ads, sinfo.adb (Class_Present): Allowed on N_Pragma node + +2010-10-12 Robert Dewar + + * par-endh.adb (Check_End): Don't swallow semicolon or aspects after + END RECORD. + * sem_attr.adb (Eval_Attribute): Code clean up. + +2010-10-12 Robert Dewar + + * par-ch12.adb (P_Formal_Private_Type_Definition): Improve error + messages and recovery for case of out of order Abstract/Tagged/Private + keywords. + * par-ch3.adb (P_Type_Declaration): Improve error messages and recovery + for case of out of order Abstract/Tagged/Private keywords. + +2010-10-12 Ed Schonberg + + * inline.adb (Analyze_Inlined_Bodies): Restrict previous change to case + where child unit is main unit of compilation. + +2010-10-12 Robert Dewar + + * aspects.ads, aspects.adb (Move_Aspects): New procedure. + * atree.ads, atree.adb: (New_Copy): Does not copy aspect specifications + * sinfo.ads, par-ch3.adb, par-ch6.adb, par-ch7.adb, par-ch9.adb, + par-endh.adb, par-ch13.adb, par-ch12.adb: Modify grammar to include + aspect specifications. + Recognize aspect specifications for all cases + * par.adb: Recognize aspect specifications for all cases + * sem_ch12.ads, sem_ch12.adb (Copy_Generic_Node): Copies aspect + specifications. + * sem_ch3.adb (Analyze_Subtype_Declaration): Improve patch to freeze + generic actual types (was missing some guards before). + * sem_ch9.adb (Analyze_Single_Protected_Declaration): Copy aspects to + generated object + (Analyze_Single_Task_Declaration): Copy aspects to generated object + +2010-10-12 Eric Botcazou + + * usage.adb (usage): Adjust line for -gnatn switch. + +2010-10-12 Robert Dewar + + * sem_attr.adb (Eval_Attribute): Only leave change active for aspect + spec case. + +2010-10-12 Ed Schonberg + + * sem_ch6.adb (Analyze_Subprogram_Declaration): If this is a + declaration of a null procedure resolve the types of the profile of the + generated null body now. + +2010-10-11 Robert Dewar + + * debug.adb: Remove d.A flag to delay address clause (not needed any + more). Add d.A flag to enable tree read/write of aspect spec hash table + * sem_ch13.adb (Analyze_Aspect_Specifications): Properly delay address + clause. + (Rep_Item_Too_Late): No need for special processing for delayed rep + items (and it caused difficulties in the address case). + * tree_gen.adb: Only write aspect spec hash table if -gnatd.A is set + * tree_in.adb: Only write aspect spec hash table if -gnatd.A is set + +2010-10-11 Pat Rogers + + * gnat_ugn.texi: Minor editing. + +2010-10-11 Nathan Froyd + + * gcc-interface/utils2.c (gnat_build_constructor): Use VEC_qsort. + +2010-10-11 Robert Dewar + + * g-htable.ads (Get_First): New procedural version for Simple_HTable + (Get_Next): New procedural version for Simple_HTable + * s-htable.adb (Get_First): New procedural version for Simple_HTable + (Get_Next): New procedural version for Simple_HTable + * s-htable.ads (Get_First): New procedural version for Simple_HTable + (Get_Next): New procedural version for Simple_HTable + +2010-10-11 Ed Schonberg + + * sem_aggr.adb (Propagate_Discriminants): To gather the components of a + variant part, use the association list of the subaggregate, which + already includes the values of the needed discriminants. + +2010-10-11 Robert Dewar + + * aspects.ads, aspects.adb: Changes to accomodate aspect delay + (Tree_Write): New procedure. + * atree.ads, atree.adb: Flag3 is now Has_Aspects and applies to all + nodes. + * atree.h: Flag3 is now Has_Aspects and applies to all nodes + * debug.adb: Add debug flag gnatd.A + * einfo.adb (Has_Delayed_Aspects): New flag + (Get_Rep_Item_For_Entity): New function + * einfo.ads (Has_Delayed_Aspects): New flag + (Get_Rep_Item_For_Entity): New function + * exp_ch13.adb (Expand_N_Freeze_Entity): Insert delayed aspects into + tree. + * exp_ch3.adb, exp_ch6.adb, exp_ch9.adb, exp_disp.adb: New calling + sequence for Freeze_Entity. + * freeze.ads, freeze.adb (Freeze_Entity): Takes node rather than source + ptr. All calls are changed to this new interface. + (Freeze_And_Append): Same change + (Freeze_Entity): Evaluate deferred aspects + * sem_attr.adb: New calling sequence for Freeze_Entity + (Eval_Attribute): Don't try to evaluate attributes of unfrozen types + when we are in spec expression preanalysis mode. + * sem_ch10.adb: New calling sequence for Freeze_Entity + * sem_ch11.adb: Simplify analysis of aspect specifications now that the + flag Has_Aspects applies to all nodes (no need to save aspects). + * sem_ch12.adb: Simplify analysis of aspect specifications now that the + flag Has_Aspects applies to all nodes (no need to save aspects). + * sem_ch13.adb (Analyze_Aspect_Specifications): Major rewrite to + accomodate delaying aspect evaluation to the freeze point. + (Duplicate_Clause): Simplify using Get_Rep_Item_For_Entity, and also + accomodate delayed aspects. + (Rep_Item_Too_Late): Deal with delayed aspects case + * sem_ch13.ads (Rep_Item_Too_Late): Document handling of delayed + aspects. + * sem_ch3.adb (Analyze_Subtype_Declaration): Make sure that generic + actual types are properly frozen (this is needed because of the new + check in Eval_Attribute that declines to evaluate attributes + for unfrozen types). + Simplify analysis of aspect specifications now that the flag + Has_Aspects applies to all nodes (no need to save aspects). + * sem_ch3.ads (Preanalyze_Spec_Expression): Note use for delayed + aspects. + * sem_ch5.adb: Simplify analysis of aspect specifications now that the + flag Has_Aspects applies to all nodes (no need to save aspects). + New calling sequence for Freeze_Entity. + * sem_ch9.adb, sem_ch7.adb, sem_ch6.adb: Simplify analysis of aspect + specifications now that the flag Has_Aspects applies to all nodes + (no need to save aspects). + New calling sequence for Freeze_Entity + * sem_prag.adb (Check_Duplicate_Pragma): Simplify using + Get_Rep_Item_For_Entity + (Get_Pragma_Arg): Moved to Sinfo + * sinfo.ads, sinfo.adb (Aspect_Rep_Item_: New field + (Is_Delayed_Aspect): New flag + (Next_Rep_Item): Document use for aspects + (Get_Pragma_Arg): Moved here from Sem_Prag + * sprint.adb (Sprint_Aspect_Specifications): Now called after semicolon + is output and removes semicolon (simplifies interface). + (Sprint_Node_Actual): Simplify handling of aspects now that Has_Aspects + applies to any node. + * tree_gen.adb: Write contents of Aspect_Specifications hash table + * tree_in.adb: Read and initialize Aspect_Specifications hash table + * treepr.adb (Print_Node): Print Has_Aspects flag + (Print_Node): Print Aspect_Specifications in Has_Aspects set + * xtreeprs.adb: Remove obsolete references to Flag1,2,3 + +2010-10-11 Robert Dewar + + * aspects.ads, aspects.adb: Major revision of this package for 2nd + stage of aspects implementation. + * gcc-interface/Make-lang.in: Add entry for aspects.o + * gcc-interface/Makefile.in: Add aspects.o to GNATMAKE_OBJS + * par-ch13.adb (Aspect_Specifications_Present): New function + (P_Aspect_Specifications): New procedure + * par-ch3.adb (P_Type_Declaration): Handle aspect specifications + (P_Derived_Type_Def_Or_Private_Ext_Decl): Handle aspect specifications + (P_Identifier_Declarations): Handle aspect specifications + (P_Component_Items): Handle aspect specifications + (P_Subtype_Declaration): Handle aspect specifications + * par-ch6.adb (P_Subprogram): Handle aspect specifications + * par-ch9.adb (P_Entry_Declaration): Handle aspect specifications + * par.adb (Aspect_Specifications_Present): New function + (P_Aspect_Specifications): New procedure + * sem.adb (Analyze_Full_Type_Declaration): New name for + Analyze_Type_Declaration. + (Analyze_Formal_Package_Declaration): New name (add _Declaration) + (Analyze_Formal_Subprogram_Declaration): New name (add _Declaration) + (Analyze_Protected_Type_Declaration): New name (add _Declaration) + (Analyze_Single_Protected_Declaration): New name (add _Declaration) + (Analyze_Single_Task_Declaration): New name (add _Declaration) + (Analyze_Task_Type_Declaration): New name (add _Declaration) + * sem_cat.adb (Analyze_Full_Type_Declaration): New name for + Analyze_Type_Declaration. + * sem_ch11.adb (Analyze_Exception_Declaration): Analyze aspect + specifications. + * sem_ch12.adb (Analyze_Formal_Object_Declaration): Handle aspect + specifications. + (Analyze_Formal_Package_Declaration): New name (add _Declaration) + (Analyze_Formal_Package_Declaration): Handle aspect specifications + (Analyze_Formal_Subprogram_Declaration): New name (add _Declaration) + (Analyze_Formal_Subprogram_Declaration): Handle aspect specifications + (Analyze_Formal_Type_Declaration): Handle aspect specifications + (Analyze_Generic_Package_Declaration): Handle aspect specifications + (Analyze_Generic_Subprogram_Declaration): Handle aspect specifications + (Analyze_Package_Instantiation): Handle aspect specifications + (Analyze_Subprogram_Instantiation): Handle aspect specifications + * sem_ch12.ads (Analyze_Formal_Package_Declaration): New name (add + _Declaration). + (Analyze_Formal_Subprogram_Declaration): New name (add _Declaration) + * sem_ch13.adb (Analyze_Aspect_Specifications): New procedure + (Duplicate_Clause): New function, calls to this function are added to + processing for all aspects. + * sem_ch13.ads (Analyze_Aspect_Specifications): New procedure + * sem_ch3.adb (Analyze_Full_Type_Declaration): New name for + Analyze_Type_Declaration. + * sem_ch3.ads (Analyze_Full_Type_Declaration): New name for + Analyze_Type_Declaration. + * sem_ch6.adb (Analyze_Abstract_Subprogram_Declaration): Analyze aspect + specifications. + (Analyze_Subprogram_Declaration): Analyze aspect specifications + * sem_ch7.adb (Analyze_Package_Declaration): Analyze aspect + specifications. + (Analyze_Private_Type_Declaration): Analyze aspect specifications + * sem_ch9.adb (Analyze_Protected_Type_Declaration): Analyze aspect + specifications. + (Analyze_Protected_Type_Declaration): New name (add _Declaration) + (Analyze_Single_Protected_Declaration): Analyze aspect specifications + (Analyze_Single_Protected_Declaration): New name (add _Declaration) + (Analyze_Single_Task_Declaration): Analyze aspect specifications + (Analyze_Single_Task_Declaration): New name (add _Declaration) + (Analyze_Task_Type_Declaration): Analyze aspect specifications + (Analyze_Task_Type_Declaration): New name (add _Declaration) + * sem_ch9.ads (Analyze_Protected_Type_Declaration): New name (add + _Declaration). + (Analyze_Single_Protected_Declaration): New name (add _Declaration) + (Analyze_Single_Task_Declaration): New name (add _Declaration) + (Analyze_Task_Type_Declaration): New name (add _Declaration) + * sem_prag.adb: Use Get_Pragma_Arg systematically so that we do not + have to generate unnecessary pragma argument associations (this matches + the doc). + Throughout do changes to accomodate aspect specifications, including + specializing messages, handling the case of not going through all + homonyms, and allowing for cancellation. + * sinfo.ads, sinfo.adb: Clean up obsolete documentation for Flag1,2,3 + (Aspect_Cancel): New flag + (From_Aspect_Specification): New flag + (First_Aspect): Removed flag + (Last_Aspect): Removed flag + * sprint.adb (Sprint_Aspect_Specifications): New procedure + (Sprint_Node_Actual): Add calls to Sprint_Aspect_Specifications + +2010-10-11 Bob Duff + + * sem_res.adb (Resolve_Actuals): Minor change to warning messages so + they match in Ada 95, 2005, and 2012 modes, in the case where the + language didn't change. Same thing for the run-time exception message. + +2010-10-11 Javier Miranda + + * debug.adb Document that switch -gnatd.p enables the CIL verifier. + +2010-10-11 Robert Dewar + + * s-htable.adb: Minor reformatting. + +2010-10-11 Javier Miranda + + * debug.adb: Update comment. + +2010-10-11 Vincent Celier + + * gnatcmd.adb (GNATCmd): Set Opt.Unchecked_Shared_Lib_Imports to True + unconditionally as for "gnat make" the projects are not processed in + the GNAT driver. + +2010-10-11 Ed Schonberg + + * sem_ch10.ads, sem_ch10.adb (Load_Needed_Body): Add parameter to + suppress semantic analysis of the body when inlining, prior to + verifying that the body does not have a with_clause on a descendant + unit. + * inline.adb (Analyze_Inlined_Bodies): Do not inline a body if it has a + with_clause on a descendant. + (Scope_In_Main_Unit): Simplify. + +2010-10-11 Robert Dewar + + * exp_ch6.adb, freeze.adb: Minor reformatting. + +2010-10-11 Vincent Celier + + * gnatcmd.adb (GNATCmd): For all tools other than gnatmake, allow + shared library projects to import projects that are not shared library + projects. + +2010-10-11 Javier Miranda + + * debug.adb: Document that switch -gnatd.o generates the CIL listing. + +2010-10-11 Arnaud Charlet + + * sem_prag.adb (Process_Suppress_Unsuppress): Only ignore + Suppress/Unsuppress pragmas in codepeer mode on user code. + +2010-10-11 Javier Miranda + + * exp_ch6.adb (Expand_Call): For VM platforms, add missing expansion of + tag check in case of dispatching call through "=". + +2010-10-11 Ed Schonberg + + * sem_ch3.adb (Access_Subprogram_Declaration): In Ada2012 an incomplete + type is legal in the profile of any basic declaration. + * sem_ch6.adb (Analyze_Return_Type, Process_Formals): In Ada2012 an + incomplete type, including a limited view of a type, is legal in the + profile of any subprogram declaration. + If the type is tagged, its use is also legal in a body. + * sem_ch10.adb (Install_Limited_With_Clause): Do not process context + item if misplaced. + (Install_Limited_Withed_Unit): Refine legality checks when both the + limited and the non-limited view of a package are visible in the + context of a unit. + If this is not an error case, the limited view is ignored. + freeze.adb (Freeze_Entity): In Ada2012, an incomplete type is legal in + access to subprogram declarations + +2010-10-11 Robert Dewar + + * exp_ch6.adb: Code clean up. + * exp_util.adb: Minor reformatting. + +2010-10-11 Arnaud Charlet + + * sem_ch3.adb, exp_ch6.adb + (Make_Build_In_Place_Call_In_Anonymous_Context, + Make_Build_In_Place_Call_In_Assignment, + Make_Build_In_Place_Call_In_Object_Declaration): Fix calls to + Add_Task_Actuals_To_Build_In_Place_Call in case of No_Task_Hierarchy + restriction. + (Access_Definition): Add missing handling of No_Task_Hierarchy. + +2010-10-11 Javier Miranda + + * exp_util.adb (Remove_Side_Effects): No action needed for renamings of + class-wide expressions. + +2010-10-11 Arnaud Charlet + + * xr_tabls.adb, sem_res.adb: Minor reformatting + +2010-10-11 Arnaud Charlet + + * gnat_rm.texi, exp_attr.adb, sem_attr.adb, sem_attr.ads, + snames.ads-tmpl (Analyze_Attribute, Expand_N_Attribute_Reference): Add + handling of Attribute_Ref. Add missing blanks in some error messages. + (Attribute_Ref, Name_Ref): Declare. + Document 'Ref attribute. + +2010-10-11 Robert Dewar + + * sem_attr.adb: Minor reformatting. + +2010-10-11 Javier Miranda + + * sem_ch8.adb (Attribute_Renaming): Add missing check to avoid loading + package System.Aux_Dec in VM platforms. + +2010-10-11 Arnaud Charlet + + * sem_prag.adb (Process_Suppress_Unsuppress): Ignore + Suppress/Unsuppress pragmas in codepeer mode. + (Analyze_Pragma [Pragma_Suppress_All]): Do not generate error message + in codepeer mode. + * einfo.ads: Fix typo. + +2010-10-11 Emmanuel Briot + + * sinfo.adb: Use GNAT.HTable rather than System.HTable. + * prj-nmsc.adb: Minor reformatting. + +2010-10-11 Thomas Quinot + + * sem_attr.adb (Type_Key): Code simplification. + +2010-10-11 Tristan Gingold + + * gcc-interface/utils2.c (maybe_wrap_malloc): Fix crash when allocating + very large object on VMS. + +2010-10-11 Javier Miranda + + * sem_ch10.adb (Analyze_With_Clause): Add missing test to ensure + availability of attribute Instance_Spec. + +2010-10-11 Arnaud Charlet + + * gnat1drv.adb (Adjust_Global_Switches): Disable codepeer mode if + checking syntax only or in ASIS mode. + +2010-10-11 Ed Schonberg + + * sem_ch6.adb (Check_Delayed_Subprogram): Abstract subprograms may also + need a freeze node if some type in the profile has one. + * gcc-interface/trans.c (case N_Abstract_Subprogram_Declaration): If + entity has a freeze node, defer elaboration. + +2010-10-11 Emmanuel Briot + + * prj-nmsc.adb (Check_Aggregate_Project): Add support for finding all + aggregated projects. + +2010-10-11 Ed Schonberg + + * sem_res.adb (Resolve_Entry_Call): Generate 's' reference for entry + call. + * sem_ch6.adb: Diagnose additional error condition. + +2010-10-11 Bob Duff + + * par.adb (Par): Clarify wording of certain error messages. + +2010-10-11 Gary Dismukes + + * sem_disp.adb (Check_Dispatching_Operation): Revise test for warning + about nondispatching subprograms to use In_Same_List (reducing use of + Parent links). + +2010-10-11 Ed Schonberg + + * xr_tabls.adb, sem_res.adb, lib-xref.adb, lib-xref.ads: Use s for + reference in a static call. + +2010-10-11 Steve Baird + + * exp_attr.adb (Expand_N_Attribute_Reference, case Type_Key): Type_Key + attribute should always be transformed into a string literal in + Analyze_Attribute. + * par-ch4.adb: Type_Key attribute's type is String; update value of + Is_Parameterless_Attribute constant to reflect this. + * sem_attr.adb (Analyze_Attribute): Recognize Type_Key attribute and + rewrite it as a string literal (attribute value is always known + statically). + * snames.ads-tmpl: Add entries for Type_Key attribute. + +2010-10-11 Ed Schonberg + + * lib-xref.adb (Output_References): Common handling for objects and + formals of an anonymous access type. + +2010-10-11 Eric Botcazou + + * make.adb (Scan_Make_Arg): Also pass -O to both compiler and linker. + +2010-10-11 Ed Schonberg + + * sem_ch6.adb: Fix check for illegal equality declaration in Ada2012 + +2010-10-11 Gary Dismukes + + * sem_disp.adb (Check_Dispatching_Operation): When testing for issuing + a warning about subprograms of a tagged type not being dispatching, + limit this to cases where the tagged type and the subprogram are + declared within the same declaration list. + +2010-10-11 Jerome Lambourg + + * projects.texi, prj-attr.adb: Add new attribute documentation_dir. + +2010-10-11 Bob Duff + + * par-ch9.adb, sem_aggr.adb, exp_ch5.adb, sem_ch3.adb, impunit.adb, + impunit.ads, sem_ch5.adb, sem_type.adb, exp_imgv.adb, exp_util.adb, + switch-c.adb, exp_attr.adb, exp_ch9.adb, par-ch11.adb, usage.adb, + sem_ch9.adb, sem_ch10.adb, scng.adb, checks.adb, sem_prag.adb, + sem_ch12.adb, par-ch2.adb, freeze.adb, par-ch4.adb, sem_util.adb, + sem_res.adb, sem_attr.adb, par-ch6.adb, exp_ch4.adb, exp_ch6.adb, + sem_ch4.adb, exp_ch8.adb, par-ch10.adb, sem_ch6.adb, par-prag.adb, + exp_disp.adb, par-ch12.adb, sem_ch8.adb, snames.adb-tmpl, opt.ads, + exp_aggr.adb, sem_cat.adb, sem_ch13.adb, par-ch3.adb, exp_strm.adb, + exp_cg.adb, lib-xref.adb, sem_disp.adb, exp_ch3.adb: Use Ada_2005 + instead of Ada_05 (Ada_Version_Type). + +2010-10-11 Bob Duff + + * sem_aggr.adb, impunit.adb, impunit.ads, switch-c.adb, usage.adb, + sem_ch10.adb, sem_prag.adb, sem_ch12.adb, par-ch4.adb, par-ch6.adb, + par-ch8.adb, exp_ch4.adb, sem_ch4.adb, sem_ch6.adb, par-prag.adb, + opt.ads, par-ch3.adb, lib-xref.adb: Use Ada_2012 instead of Ada_12 + (Ada_Version_Type). + +2010-10-11 Javier Miranda + + * exp_util.adb (Safe_Prefixed_Reference): If the prefix is an explicit + dereference then do not exclude dereferences of access-to-constant + types to handle them as constant view of variables (and hence remove + side effects when required). + * sem_res.adb (Resolve_Slice): Ensure that side effects in the bounds + are properly handled. + +2010-10-11 Robert Dewar + + * sem_prag.adb, sem_aggr.adb, sprint.adb: Minor reformatting. + +2010-10-11 Javier Miranda + + * exp_ch5.ads, exp_ch6.ads (Expand_N_Extended_Return_Statement): Moved + to exp_ch6. + (Expand_N_Simple_Return_Statement): Moved to exp_ch6. + * exp_ch5.adb, exp_ch6.adb (Expand_Non_Function_Return): Moved to + exp_ch6. + (Expand_Simple_Function_Return): Move to exp_ch6. + (Expand_N_Extended_Return_Statement): Moved to exp_ch6. + (Expand_N_Simple_Return_Statement): Moved to exp_ch6. + +2010-10-11 Robert Dewar + + * snames.ads-tmpl: Add names for aspects. + * aspects.ads, aspects.adb: New. + * gcc-interface/Make-lang.in: Update dependencies. +2010-10-11 Ed Schonberg + + * exp_ch6.adb (Expand_Actuals): If an actual is the current instance of + a task type, it must be replaced with a reference to Self. + +2010-10-11 Vincent Celier + + * adaint.h: Add prototype for function __gnat_create_output_file_new. + +2010-10-11 Javier Miranda + + * sem_aggr.adb (Collect_Aggr_Bounds): Remove side effects of collected + aggregate bounds. + +2010-10-11 Arnaud Charlet + + * sem_prag.adb (Check_Interrupt_Or_Attach_Handler): Do not emit error + for AI05-0033 in CodePeer mode. + +2010-10-11 Robert Dewar + + * atree.h, atree.ads, atree.adb (Flag3): New flag (replaces Unused_1) + * csinfo.adb: Aspect_Specifications is a new special field + * einfo.adb (Flag3): New unused flag + * exp_util.adb (Insert_Actions): Add processing for + N_Aspect_Specification. + * sem.adb: Add entry for N_Aspect_Specification. + * sinfo.ads, sinfo.adb (N_Aspect_Specification): New node + (Has_Aspect_Specifications): New flag + (Permits_Aspect_Specifications): New function + (Aspect_Specifications): New function + (Set_Aspect_Specifications): New procedure + * sprint.adb (Sprint_Node): Put N_At_Clause in proper alpha order + (Sprint_Node): Add dummy entry for N_Aspect_Specification + * treepr.adb (Flag3): New flag to be listed + +2010-10-11 Vincent Celier + + * adaint.c: Minor reformatting. + +2010-10-11 Robert Dewar + + * sem_ch6.adb, s-htable.ads: Minor reformatting. + +2010-10-11 Ed Schonberg + + * sem_ch4.adb (Analyze_Selected_Component): If the selector is + invisible in an instantiation, and both the formal and the actual are + private extensions of the same type, look for the desired component in + the proper view of the parent type. + +2010-10-11 Vincent Celier + + * adaint.c (__gnat_number_of_cpus): Add implementation for Solaris, + AIX, Tru64, Darwin, IRIX and HP-UX. + +2010-10-11 Robert Dewar + + * a-textio.adb: Minor reformatting + +2010-10-11 Robert Dewar + + * a-suesen.ads, a-suenst.ads, + a-suesen.adb, a-suenst.adb, + a-suewse.adb, a-suewst.adb, + a-suewse.ads, a-suewst.ads, + a-suezse.ads, a-suezst.ads, + a-suezse.adb, a-suezst.adb: New name for string encoding packages. + * impunit.adb: New names for string encoding units + * Makefile.rtl: New names for string encoding units + * rtsfind.ads: Minor code reorganization. + +2010-10-11 Ed Schonberg + + * exp_ch5.adb: Code clean up. + +2010-10-11 Ed Schonberg + + * sem_ch6.adb (Check_Limited_Return): Specialize warning on limited + returns when in a generic context. + (Analyze_Function_Return): ditto. + +2010-10-11 Robert Dewar + + * s-multip.ads: Fix header. + * sem_ch3.adb, s-multip.adb, a-tigeli.adb: Minor reformatting. + +2010-10-11 Vincent Celier + + * Makefile.rtl: Add s-multip. + * adaint.c: New function __gnat_number_of_cpus, implemented for Linux, + defaulting to 1 for other platforms. + * adaint.h: New function __gnat_number_of_cpus. + * impunit.adb (Non_Imp_File_Names_12): New file list for Ada 2012, + with a single component "s-multip". + * impunit.ads (Kind_Of_Unit): New enumerated value Ada_12_Unit for Ada + 2012. + * rtsfind.ads (RTU_Id): New enumerated value System_Multiprocessors + * s-multip.ads, s-multip.adb: New Ada 2012 package. + * sem_ch10.adb (Analyze_With_Clause): Check also Ada 2012 units. + +2010-10-11 Javier Miranda + + * a-textio.adb: Move new implementation of Get_Line to a subunit. + * a-tigeli.adb: New subunit containing the implementation of Get_Line. + +2010-10-11 Ed Schonberg + + * sem_aux.adb: Code clean up. + +2010-10-11 Robert Dewar + + * sem_ch3.adb, sem_aux.adb, sem_ch6.adb: Minor reformatting + +2010-10-11 Robert Dewar + + * einfo.adb, atree.h, atree.ads, atree.adb: Define seven new flags + Flag248-Flag254. Define new field Field29. + +2010-10-10 Olivier Hainque + Eric Botcazou + + * gcc-interface/lang.opt (gdwarf+): Remove. + * gcc-interface/gigi.h (get_parallel_type): Likewise + * gcc-interface/misc.c (gnat_dwarf_extensions): Likewise. + (gnat_handle_option): Remove OPT_gdwarfplus case. + (gnat_post_options): Remove setting of use_gnu_debug_info_extensions + from gnat_dwarf_extensions. + * gcc-interface/trans.c (gigi): Remove -gdwarf+ initializations. + * gcc-interface/utils.c (get_parallel_type): Remove. + +2010-10-10 Eric Botcazou + + * gcc-interface/trans.c (gnat_to_gnu) : Use + invert_truthvalue_loc instead of invert_truthvalue. + * gcc-interface/utils2.c (build_binary_op) : Likewise. + (build_unary_op) : Likewise. + +2010-10-10 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Add + assertion on the types of the parameters. Use KIND local variable. + : Likewise. + +2010-10-10 Eric Botcazou + + * gcc-interface/ada-tree.h (DECL_BY_DOUBLE_REF_P): New macro. + * gcc-interface/gigi.h (annotate_object): Add BY_DOUBLE_REF parameter. + * gcc-interface/decl.c (annotate_object): Likewise and handle it. + (gnat_to_gnu_entity): Adjust calls to annotate_object. + (gnat_to_gnu_param): If fat pointer types are passed by reference on + the target, pass them by explicit reference. + * gcc-interface/misc.c (default_pass_by_ref): Fix type of constant. + * gcc-interface/trans.c (Identifier_to_gnu): Do DECL_BY_DOUBLE_REF_P. + (Subprogram_Body_to_gnu): Adjust call to annotate_object. + (call_to_gnu): Handle DECL_BY_DOUBLE_REF_P. + * gcc-interface/utils.c (convert_vms_descriptor): Add BY_REF parameter + and handle it. + (build_function_stub): Iterate on the parameters of the subprogram in + lieu of on the argument types. Adjust call to convert_vms_descriptor. + +2010-10-09 Eric Botcazou + + * gcc-interface/misc.c: Delete prototypes. + (gnat_init_options): Use local variable. + (lang_hooks): Move to the end of the file. + +2010-10-08 Joseph Myers + + * gcc-interface/misc.c (gnat_init_options_struct): New. Split out + from gnat_init_options. + (LANG_HOOKS_INIT_OPTIONS_STRUCT): Define. + +2010-10-08 Ed Schonberg + + * sem_aux.adb: Cleanup Is_Immutably_Limited_Type. + +2010-10-08 Robert Dewar + + * exp_ch3.adb: Minor reformatting. + * exp_ch5.adb: Add comment. + +2010-10-08 Robert Dewar + + * sem_prag.adb (Check_Duplicate_Pragma): Check for entity match + * gcc-interface/Make-lang.in: Update dependencies. + * einfo.ads: Minor reformatting. + +2010-10-08 Ed Schonberg + + * exp_ch5.adb, sem_ch3.adb, exp_ch7.adb, exp_util.adb, sem_aux.adb, + sem_aux.ads, exp_ch4.adb, exp_ch6.adb, sem_ch6.adb, exp_aggr.adb, + exp_ch3.adb: Change Is_Inherently_Limited_Type to + Is_Immutably_Limited_Type to accord with new RM terminology. + * sem_aux.adb (Is_Immutably_Limited_Type): A type that is a descendant + of a formal limited private type is not immutably limited in a generic + body. + +2010-10-08 Robert Dewar + + * sem_prag.adb (Check_Duplicate_Pragma): New procedure + Add calls to this new procedure where appropriate + +2010-10-08 Vincent Celier + + * a-textio.adb (Get_Chunk): Code clean up. + +2010-10-08 Robert Dewar + + * a-strbou.ads, a-strfix.adb, a-strfix.ads, a-strsea.adb, a-strsea.ads, + a-strsup.adb, a-strsup.ads, a-strunb-shared.adb, a-strunb-shared.ads, + a-strunb.adb, a-strunb.ads, a-stwibo.ads, a-stwifi.adb, a-stwifi.ads, + a-stwise.adb, a-stwise.ads, a-stwisu.adb, a-stwisu.ads, + a-stwiun-shared.adb, a-stwiun-shared.ads, a-stwiun.adb, a-stwiun.ads, + a-stzbou.ads, a-stzfix.adb, a-stzfix.ads, a-stzsea.adb, a-stzsea.ads, + a-stzsup.adb, a-stzsup.ads, a-stzunb-shared.adb, a-stzunb-shared.ads, + a-stzunb.adb, a-stzunb.ads (Find_Token): New version with From + parameter. + +2010-10-08 Robert Dewar + + * sem_cat.adb (Check_Categorization_Dependencies): Remote types + packages can depend on preleborated packages. + +2010-10-08 Robert Dewar + + * sem_prag.adb (Check_Interrupt_Or_Attach_Handler): Pragmas + Interrupt_Handler and Attach_Handler not allowed in generics. + +2010-10-08 Robert Dewar + + * ali.adb: Set Allocator_In_Body if AB parameter present on M line + * ali.ads (Allocator_In_Body): New flag + * bcheck.adb (Check_Consistent_Restrictions): Handle case of main + program violating No_Allocators_After_Elaboration restriction. + * gnatbind.adb (No_Restriction_List): Add entries for + No_Anonymous_Allocators, and No_Allocators_After_Elaboration. + * lib-load.adb: Initialize Has_Allocator flag + * lib-writ.adb: Initialize Has_Allocator flag + (M_Parameters): Set AB switch if Has_Allocator flag set + * lib-writ.ads: Document AB flag on M line + * lib.adb (Has_Allocator): New function + (Set_Has_Allocator): New procedure + * lib.ads (Has_Allocator): New function + (Set_Has_Allocator): New procedure + (Has_Allocator): New flag in Unit_Record + * sem_ch4.adb (Analyze_Allocator): Add processing for + No_Allocators_After_Elaboration. + +2010-10-08 Geert Bosch + + * a-textio.adb (Get_Line): Rewrite to use fgets instead of fgetc. + +2010-10-08 Javier Miranda + + * sem_prag.adb (Analyze_Pragma): Relax semantic rule of + Java_Constructors because in the JRE library we generate occurrences + in which the "this" parameter is not the first formal. + +2010-10-08 Robert Dewar + + * par-ch3.adb: Minor reformatting. + +2010-10-08 Javier Miranda + + * exp_disp.adb (Make_DT): Do not generate dispatch tables for CIL/Java + types. + +2010-10-08 Robert Dewar + + * par-ch8.adb (P_Use_Type_Clause): Recognize ALL keyword in Ada 2012 + mode. + * sinfo.adb (Use_Type_Clause): Add All_Present flag. + * sinfo.ads (Use_Type_Clause): Add All_Present flag. + * s-rident.ads: Add entry for No_Allocators_After_Elaboration, + No_Anonymous_Allocators. + +2010-10-08 Vincent Celier + + * bindgen.adb (Gen_Restrictions_Ada): No new line after last + restriction, so that the last comma is always replaced with a left + parenthesis. + +2010-10-08 Javier Miranda + + * sem_prag.adb (Analyze_Pragma): Add specific check on the type of the + first formal of delegates. + +2010-10-08 Robert Dewar + + * sem_aggr.adb: Minor reformatting. + +2010-10-08 Robert Dewar + + * exp_imgv.adb (Expand_Image_Attribute): Handle special calling + sequence for soft hyphen for Character'Image case. + * rtsfind.ads (Image_Character_05): New entry + * s-imgcha.adb (Image_Character_05): New procedurew + * s-imgcha.ads (Image_Character_05): New procedure + * s-imgwch.adb (Image_Wide_Character): Deal with Ada 2005 soft hyphen + case. + * s-valcha.adb (Value_Character): Recognize SOFT_HYPHEN for 16#AD# + * sem_attr.adb (Eval_Attribute, case Width): Handle soft_hyphen name + properly. + +2010-10-08 Robert Dewar + + * sem_attr.adb (Eval_Attribute, case Width): Avoid ludicrous long loop + for case of Wide_[Wide_]Character. + +2010-10-08 Robert Dewar + + * exp_ch3.adb: Minor reformating + Minor code reorganization. + +2010-10-08 Javier Miranda + + * sem_prag.adb (Analyze_Pragma): Add missing checks on wrong use of + pragmas CIL_Constructor and Java_Constructor. + * exp_ch3.adb (Expand_Freeze_Record_Type): Do not generate the + predefined primitives for CIL/Java tagged types. + +2010-10-08 Robert Dewar + + * sem_ch6.adb: Minor reformatting. + +2010-10-08 Robert Dewar + + * gnat1drv.adb: Add call to Validate_Independence. + * par-prag.adb: Add dummy entries for Independent, + Independent_Componentsa. + * sem_ch13.adb (Validate_Independence): New procedure + (Initialize): Initialize address clause and independence check tables + * sem_ch13.ads (Independence_Checks): New table + (Validate_Independence): New procedure + * sem_prag.adb: Add processing for pragma Independent[_Components] + * snames.ads-tmpl: Add entries for pragma Independent[_Components] + +2010-10-08 Ed Schonberg + + * sem_aggr.adb (Propagate_Discriminants): When expanding an aggregate + component with box initialization, if the component is a variant record + use the values of the discriminants to select the proper variant for + further box initialization. + +2010-10-08 Thomas Quinot + + * xsnames.adb: Remove obsolete file. + * make.adb, sem_ch8.adb, einfo.ads: Minor reformatting. + +2010-10-08 Ed Schonberg + + * exp_aggr.adb: Complete previous change. + +2010-10-08 Ed Schonberg + + * sem_ch6.adb (Check_Return_Subtype): The subtype indication in an + extended return must match statically the return subtype of the + enclosing function if the type is an elementary type or if it is + constrained. + +2010-10-08 Vincent Celier + + * prj-nmsc.adb (Add_Source): Report all duplicate units and source file + names. Do not report the same duplicate unit several times. + * prj.ads (Source_Data): New Boolean component Duplicate_Unit, + defaulted to False, to avoid reporting the same unit as duplicate + several times. + +2010-10-08 Ed Schonberg + + * sem_aggr.adb (Resolve_Array_Aggregate): If the expression in an + others choice is a literal, analyze it to enable later optimizations. + * exp_aggr.adb (Expand_Record_Aggregate): An aggregate with static size + and components can be handled by the backend even if it is of a limited + type. + +2010-10-08 Arnaud Charlet + + * a-rttiev.adb (task Timer): Since this package may be elaborated + before System.Interrupt, we need to call Setup_Interrupt_Mask + explicitly to ensure that this task has the proper signal mask. + +2010-10-08 Robert Dewar + + * freeze.adb (Freeze_Entity): For array case, move some processing for + pragma Pack, Component_Size clause and atomic/volatile components here + instead of trying to do the job in Sem_Ch13 and Freeze. + * layout.adb: Use new Addressable function + * sem_ch13.adb (Analyze_Attribute_Representation_Clause, case + Component_Size): Move some handling to freeze point in + Freeze.Freeze_Entity. + * sem_prag.adb (Analyze_pragma, case Pack): Move some handling to + freeze point in Freese.Freeze_Entity. + * sem_util.ads, sem_util.adb (Addressable): New function. + +2010-10-08 Robert Dewar + + * sprint.adb: Minor reformatting. + +2010-10-08 Javier Miranda + + * exp_ch4.adb (Real_Range_Check): Declare temporary as constant. + +2010-10-08 Robert Dewar + + * sem_ch3.adb: Minor reformatting. + +2010-10-08 Vincent Celier + + * ali-util.adb (Get_File_Checksum): Make sure that external_as_list is + not a reserved word. + * prj-proc.adb (Expression): Process string list external references. + * prj-strt.adb (External_Reference): Parse external_as_list external + references. + * prj-tree.ads (Expression_Kind_Of): Allowed for N_External_Value nodes + (Set_Expression_Kind_Of): Ditto + * prj.adb (Initialize): Set external_as_list as a reserved word + * projects.texi: Document new string external reference + external_as_list. + * scans.ads (Token_Type): New token Tok_External_As_List + * snames.ads-tmpl: New standard name Name_External_As_List + +2010-10-08 Thomas Quinot + + * sem_prag.adb: Minor reformatting. + +2010-10-08 Ed Schonberg + + * sem_ch3.adb (Derived_Type_Declaration): In the private part of an + instance, it is legal to derive from a non-limited actual when the + formal type is untagged limited. + * sem_ch12.adb (Instantiate_Type): For a formal private type, use + analyzed formal as Generic_Parent_Type, to simplify later checks. + +2010-10-08 Ed Schonberg + + * sem_res.adb (Insert_Default): If default value is already a + raise_constraint_error do not rewrite it as new raise node, to prevent + infinite loops in the warning removal machinery. + +2010-10-08 Robert Dewar + + * sem_util.adb, sem_prag.adb: Minor reformatting + +2010-10-08 Hristian Kirtchev + + * gnat_rm.texi: Remove the section on pragma Implemented_By_Entry. + Add section on pragma Implemented. + +2010-10-08 Ed Schonberg + + * sem_ch3.adb (Derive_Subprogram): If an abstract extension has a + concrete parent with a concrete constructor, the inherited constructor + is abstract even if the derived type is a null extension. + +2010-10-08 Thomas Quinot + + * sem_ch4.adb: Minor reformatting. + +2010-10-08 Hristian Kirtchev + + * einfo.adb: Flag 232 (formerly Implemented_By_Entry) is now unused. + (Implemented_By_Entry): Removed. + (Set_Implemented_By_Entry): Removed. + (Write_Entity_Flags): Remove the output for Implemented_By_Entry. + * einfo.ads: Remove Implemented_By_Entry and its usage in entities. + (Implemented_By_Entry): Removed along with its associated pragma. + (Set_Implemented_By_Entry): Removed along with its associated pragma. + * exp_ch9.adb: Alphabetize with and use clauses of Exp_Ch9. + (Build_Dispatching_Call_Equivalent): New routine. + (Build_Dispatching_Requeue): New routine. + (Build_Dispatching_Requeue_To_Any): New routine. + (Build_Normal_Requeue): New routine. + (Build_Skip_Statement): New routine. + (Expand_N_Requeue_Statement): Rewritten. The logic has been split into + several subroutines. + * par-prag.adb: Replace Pragma_Implemented_By_Entry by + Pragma_Implemented. + * sem_ch3.adb (Check_Abstract_Overriding): Perform checks concerning + pragma Implemented. + (Check_Pragma_Implemented): New routines. + (Inherit_Pragma_Implemented): New routine. + * sem_ch9.adb (Analyze_Requeue): Update the predicate which detects a + dispatching requeue. + * sem_prag.adb: Update array Sig_Flags by removing Implemented_By_Entry + and adding Implemented. + (Ada_2012_Pragma): New routine. + (Analyze_Pragma, case Implemented): Perform all necessary checks + concerning pragma Implemented and register the pragma as a + representation item with the procedure_LOCAL_NAME. + (Analyze_Pragma, case Implemented_By_Entry): Removed. + * sem_util.adb (Implementation_Kind): New routine. + * sem_util.ads (Implementation_Kind): New routine. + * snames.ads-tmpl: Remove Name_Implemented_By_Entry and add + Name_Implemented. Remove pragma name Pragma_Implemented_By_Entry and + add Pragma_Implemented. Add special names By_Any, By_Entry and + By_Protected_Procedure. + +2010-10-08 Javier Miranda + + * exp_ch3.adb (Expand_Freeeze_Record_Type): Code cleanup: remove local + variable Has_Static_DT by invocation of function Building_Static_DT. + +2010-10-08 Vincent Celier + + * g-dirope.adb (Remove_Dir): Do not change the current directory when + doing a recursive remove of a subdirectory. + +2010-10-08 Javier Miranda + + * exp_ch6.ad (Freeze_Subprogram): Factorize code. + * exp_disp.adb (Make_Secondary_DT): Factorize code. + (Make_DT): Factorize code. + +2010-10-08 Robert Dewar + + * sem_ch4.adb: Minor reformatting. + +2010-10-08 Robert Dewar + + * sem_ch6.adb (Check_Conformance): Check null exclusion match for full + conformance. + +2010-10-08 Thomas Quinot + + * sem_ch12.adb (Instantiate_Object): Rename Formal_Id to Gen_Obj, for + consistency with Gen_T in Instantiate_Type. + Introduce constant A_Gen_Obj to avoid repeated queries for + Defining_Identifier (Analyzed_Formal). + +2010-10-08 Vincent Celier + + * prj-nmsc.adb: Minor comment fix. + +2010-10-07 Robert Dewar + + * sem_prag.adb, sem_ch13.adb: Implement AI05-0012-1/02. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-10-07 Ed Schonberg + + * sem_ch12.ad: (Instantiate_Object): For an in-out formal of a child + unit, if the type of the formal is declared in a parent unit and is not + a formal itself, the actual must be located from an enclosing parent + instance by normal visibility. + +2010-10-07 Ed Schonberg + + * sem_ch4.adb (Analyze_Allocator): In Ada 2012, a null_exclusion + indicator is illegal for an uninitialized allocator. + +2010-10-07 Robert Dewar + + * sem_prag.adb (Analyze_Attribute_Definition_Clause, case + Component_Size): Complete previous change. + +2010-10-07 Vincent Celier + + * scng.adb (Scan): Call Accumulate_Token_Checksum for Tok_Identifier, + even for keywords, to avoid having the checksum to depend on the Ada + version. + +2010-10-07 Gary Dismukes + + * sem_aggr.adb, sem_ch12.adb, sem_ch6.adb, par-ch5.adb, + exp_ch3.adb: Minor reformatting. + +2010-10-07 Robert Dewar + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause, case + Component_Size): It is now illegal to give an incorrect component size + clause in the case of aliased or atomic components. + * sem_prag.adb (Analyze_Pragma, case Pack): It is now illegal to give + an effective pragma Pack in the case of aliased or atomic components. + +2010-10-07 Steve Baird + + * exp_ch4.adb (Expand_N_Allocator): Do not bypass expansion + in the case of a violation of an active No_Task_Hierarchy restriction. + +2010-10-07 Ed Schonberg + + * sem_ch12.adb (Validate_Derived_Type_Instance): If a formal derived + type is non-limited, an actual for it cannot be limited. + +2010-10-07 Robert Dewar + + * einfo.ads (No_Pool_Assigned): Update documentation. + * sem_ch13.adb (Analyze_Attribute_Definition_Clause, case + Storage_Size): We only set No_Pool_Assigned if the expression is a + static constant and zero. + * sem_res.adb (Resolve_Allocator): Allocation from empty storage pool + should be an error not a warning. + +2010-10-07 Ed Schonberg + + * exp_aggr.adb (Expand_Array_Aggregate): Recognize additional cases + where an aggregate in an assignment can be built directly into the + target, and does not require the creation of a temporary that may + overflow the stack. + +2010-10-07 Ed Schonberg + + * sem_aggr.adb (Analyze_Record_Aggregate): In Ada2012, a choice list + in a record aggregate can correspond to several components of + anonymous access types, as long as the designated subtypes match. + +2010-10-07 Robert Dewar + + * gnat_rm.texi, exp_util.adb, sinfo.adb, sinfo.ads, sem_ch12.adb, + sem.adb, gnat_ugn.texi, sem_util.ads, par-ch6.adb, targparm.ads, + restrict.adb, sem_ch6.adb, sem_ch6.ads, sprint.adb, i-c.ads: Change + spelling parametrize(d) => parameterize(d). + +2010-10-07 Robert Dewar + + * sem_ch12.adb: Add comment. + * sem_ch6.adb: Minor reformatting. + +2010-10-07 Robert Dewar + + * par-ch3.adb, par-ch6.adb, par-ch7.adb, par-ch9.adb, par-ch10.adb: Add + Pexp to Pf_Rec constants + (P_Subprogram): Expression is always enclosed in parentheses + * par.adb (Pf_Rec): add Pexp flag for parametrized expression + * sinfo.ads (N_Parametrized_Expression): Expression must be in parens + +2010-10-07 Ed Schonberg + + * sem_ch6.adb (Analyze_Subprogram_Specification): Implement Ada2012 + checks on functions that return an abstract type or have a controlling + result whose designated type is an abstract type. + (Check_Private_Overriding): Implement Ada2012 checks on functions + declared in the private part, if an abstract type is involved. + * sem_ch12.adb (Analyze_Generic_Subprogram_Declaration): In Ada2012, + reject a generic function that returns an abstract type. + * exp_ch5.adb (Expand_Simple_Function_Return): in Ada2012, if a + function has a controlling access result, check that the tag of the + return value matches the designated type of the return expression. + +2010-10-07 Robert Dewar + + * par-ch6.adb: Fix error in handling of parametrized expressions. + * par-ch4.adb (P_Name): Allow qualified expression as name in Ada 2012 + mode. + (P_Simple_Expression): Better message for qualified expression prefix + * s-crc32.adb: Minor reformatting. + * exp_intr.adb (Expand_Unc_Deallocation): Remove test for empty + storage pool (this test is moved to Sem_Intr). + * sem_intr.adb (Check_Intrinsic_Call): Add check for deallocation from + empty storage pool, moved here from Exp_Intr and made into error. + (Check_Intrinsic_Call): Remove assumption in generating not-null free + warning that the name of the instantiation is Free. + * sinput.adb (Tree_Read): Document use of illegal free call allowed in + GNAT mode. + * types.ads: Remove storage size clauses from big types (since we may + need to do deallocations, which are now illegal for empty pools). + +2010-10-07 Sergey Rybin + + * gnat_ugn.texi: Add missing word. + +2010-10-07 Robert Dewar + + * exp_util.adb (Insert_Actions): Add handling of + N_Parametrized_Expression. + * par-ch6.adb (P_Subprogram): Add parsing of parametrized expression + * sem.adb: Add entry for N_Parametrized_Expression + * sem_ch6.adb (Analyze_Parametrized_Expression): New procedure + * sem_ch6.ads (Analyze_Parametrized_Expression): New procedure + * sinfo.ads, sinfo.adb: Add N_Parametrized_Expression + * sprint.adb (Sprint_Node): Add handling for N_Parametrized_Expression + * par-ch4.adb: Minor reformatting. + +2010-10-07 Robert Dewar + + * scng.adb (Skip_Other_Format_Characters): New procedure + (Start_Of_Wide_Character): New procedure + (Scan): Use Start_Of_Wide_Character where appropriate + (Scan): Improve error message for other_format chars in identifier + (Scan): Allow other_format chars between tokens + +2010-10-07 Javier Miranda + + * exp_util.adb (Safe_Prefixed_Reference): When removing side effects, + Add missing support for explicit dereferences. + +2010-10-07 Robert Dewar + + * par-ch10.adb, par-ch3.adb, par.adb: Minor reformatting. + +2010-10-07 Robert Dewar + + * exp_disp.adb, exp_dist.adb, exp_util.ads, exp_util.adb, + exp_ch11.adb: Rename Full_Qualified_Name to Fully_Qualified_Name_String + * sem_util.adb, sem_util.ads (Full_Qualified_Name): Moved to + Exp_Util.Fully_Qualified_Name_String. + +2010-10-07 Robert Dewar + + * rtsfind.ads: Add entry for Ada.Real_Time.Timing_Events.Set_Handler + * sem_res.adb (Resolve_Call): A call to + Ada.Real_Time.Timing_Events.Set_Handler violates restriction + No_Relative_Delay (AI-0211). + +2010-10-07 Ed Schonberg + + * sem_ch10.adb: Small change in error message. + +2010-10-07 Robert Dewar + + * tbuild.ads: Minor reformatting. + +2010-10-07 Robert Dewar + + * gnatcmd.adb, make.adb, prj-nmsc.adb, sem_elab.adb: Minor reformatting + +2010-10-07 Arnaud Charlet + + * exp_ch11.adb (Expand_N_Exception_Declaration): Update comments. + +2010-10-07 Robert Dewar + + * sem_res.adb: Minor reformatting + +2010-10-07 Olivier Ramonat + + * gnat_ugn.texi: Minor editing. + * opt.ads: Document that scripts rely on specific formats in opt.ads + +2010-10-07 Robert Dewar + + * a-wichun.ads, a-wichun.adb (To_Lower_Case): New function + (To_Upper_Case): Fix to be inverse of To_Lower_Case + * a-zchuni.ads, a-zchuni.adb (To_Lower_Case): New function + (To_Upper_Case): Fix to be inverse of To_Lower_Case + +2010-10-07 Robert Dewar + + * a-wichha.adb, a-wichha.ads, a-zchhan.adb, a-zchhan.ads: New file. + * impunit.adb: Add entries for a-wichha/a-zchhan + * Makefile.rtl: Add entries for a-wichha/a-zchhan + +2010-10-07 Vincent Celier + + * make.adb (Check): Call Check_Source_Info_In_ALI with Project_Tree + * makeutl.adb (Check_Source_Info_In_ALI): If there is at least one + replaced source, check that none of the replaced sources are in the + dependencies. + * makeutl.ads (Check_Source_Info_In_ALI): New parameter Tree + * prj-nmsc.adb (Remove_Source): New parameter Tree. If the source is + replaced with a source with a different file name, put it in the hash + table Replaced_Sources. + (Add_Source): Call Remove_Source with Data.Tree. If there is at least + one replaced source, check if it has the same file name as the current + source; if it has, remove it from the hash table Replaced_Sources. + * prj.adb (Reset): Reset hash table Tree.Replaced_Sources + * prj.ads (Replaced_Source_HTable): New hash table + (Project_Tree_Data): New components Replaced_Sources and + Replaced_Source_Number. + +2010-10-07 Ed Schonberg + + * sem_elab.adb (Check_A_Call): After inserting elaboration check, set + proper flag to prevent a double elaboration check on the same call. + * exp_util.adb (Insert_Actions): If the enclosing node is an + Expression_With_Actions and it has been analyzed already, find + insertion point further up in the tree. + +2010-10-07 Hristian Kirtchev + + * sem_ch13.adb (Analyze_Record_Representation_Clause): Alphabetize all + local variables. Remove the general restriction which prohibits the + application of record rep clauses to Unchecked_Union types. Add Ada + 2012 check to detect improper naming of an Unchecked_Union + discriminant in record rep clause. + * sem_prag.adb: Add with and use clause for Exp_Ch7. + (Analyze_Pragma): Unchecked_Union case: Propagate the Unchecked_Union + type to all invocations of Check_Component and Check_Variant. + (Check_Component): Add formal parameters UU_Typ and In_Variant_Part. + Rewritten. Add Ada 2012 check to detect improper use of formal + private types and private extensions as component types of an + Unchecked_Union declared inside a generic body. + (Check_Variant): Add formal parameter UU_Typ. Propagate the + Unchecked_Union type to all calls of Check_Component. Signal that the + current component comes from the variant part of an Unchecked_Union + type. + (Inside_Generic_Body): New routine. + +2010-10-07 Ed Schonberg + + * exp_ch4.adb (Expand_Composite_Equality): When looking for a primitive + equality operation for a record component, verify that both formals + have the same type, and the result type is boolean. + +2010-10-07 Vincent Celier + + * gnatcmd.adb (Check_Files): When looking for the .ci file for a + binder generated file, look for both b~xxx and b__xxx as gprbuild + always uses b__ as the prefix of such files. + +2010-10-07 Thomas Quinot + + * sem_res.adb: Minor reformatting. + +2010-10-07 Arnaud Charlet + + * debug.adb: Update -gnatd.J documentation. + +2010-10-07 Robert Dewar + + * gnat_rm.texi: Document handling of invalid values + * s-utf_32.ads, s-utf_32.adb (UTF_To_Lower_Case): Fix implementation + to match new spec. + (UTF_To_Upper_Case): New function. + +2010-10-07 Robert Dewar + + * sem_attr.adb: Minor reformatting. + * einfo.ads, einfo.adb (Is_Ada_2012_Only): New flag + * itypes.adb (Create_Null_Excluding_Itype): Set Is_Ada_2012_Only flag + properly. + * lib-xref.adb (Generate_Reference): Warn on use of Ada 2012 entity in + non-Ada 2012 mode. + * opt.ads (Warn_On_Ada_2012_Compatibility): New flag + * sem_ch3.adb (Analye_Subtype_Declaration): Inherit Is_Ada_2012_Only + * sem_ch7.adb (Preserve_Full_Attributes): Preserve Is_Ada_2012_Only + flag. + * sem_prag.adb (Analyze_Pragma, case Ada_12/Ada_2012): Allow form with + argument. + * sem_type.adb (Disambiguate): Deal with Is_Ada_2012_Only. + * sem_warn.adb (Warn_On_Ada_2012_Compatibility): New flag, treated + same as 2005 flag. + +2010-10-07 Javier Miranda + + * a-tags.ads: Use new support for pragma Ada_2012 with function + Type_Is_Abstract. + +2010-10-07 Ed Schonberg + + * par-ch5.adb (P_Sequence_Of_Statements): In Ada2012 a label can end a + sequence of statements. + +2010-10-07 Vincent Celier + + * gnatcmd.adb (Check_Files): Only add a .ci files if it exists + +2010-10-07 Javier Miranda + + * a-tags.ads, a-tags.adb (Type_Is_Abstract): New subprogram. + * rtsfind.ads (RE_Type_Is_Abstract): New entity. + * exp_disp.adb (Make_DT): Initialize TSD component Type_Is_Abstract. + +2010-10-07 Arnaud Charlet + + * sem_ch12.adb (Mark_Context): Removed, no longer needed. + (Analyze_Package_Instantiation): No longer analyze systematically a + generic body in CodePeer mode. + * freeze.adb, sem_attr.adb: Update comments. + +2010-10-05 Robert Dewar + + * par-ch5.adb (Test_Statement_Required): Allow all pragmas in Ada 2012 + mode. + +2010-10-05 Pascal Obry + + * gnat_rm.texi: Fix typo. + +2010-10-05 Arnaud Charlet + + * gnat_ugn.texi: Add note about identifiers with same name and + -fdump-ada-spec. + +2010-10-05 Robert Dewar + + * sem_ch4.adb: Minor reformatting. + * a-direct.ads: Minor comment update. + +2010-10-05 Javier Miranda + + * sem_ch3.adb (Add_Internal_Interface_Entities): Removing code that is + no longer required after change in New_Overloaded_Entity. + * sem_ch6.adb (New_Overloaded_Entity): Code reorganization to isolate + the fragment of code that handles derivations of interface primitives. + Add missing dependence on global variable Inside_Freezing_Actions to + ensure the correct management of internal interface entities. + * sem_ch13.adb (Analyze_Freeze_Entity): Add missing increase/decrease + of the global variable Inside_Freezing_Actions to ensure that internal + interface entities are well handled by New_Overloaded_Entity. + * sem_disp.adb (Find_Primitive_Covering_Interface): Add documentation + and complete the algorithm to catch hidden primitives derived of + private type that covers the interface. + * sem_disp.ads (Find_Primitive_Covering_Interface): Add missing + documentation. + +2010-10-05 Robert Dewar + + * prj-util.adb, prj-util.ads, prj.ads, s-vxwext-rtp.adb, sem_ch4.adb, + sem_ch7.adb, sem_res.adb, sem_type.adb: Minor reformatting. + Minor code reorganization (use Nkind_In). + +2010-10-05 Ed Schonberg + + * sem_ch10.adb (Analyze_Task_Body_Stub): Diagnose duplicate stub for + task. + +2010-10-05 Vincent Celier + + * gnatbind.adb: If the main library file is not for a suitable main + program, change the error message. + +2010-10-05 Vincent Celier + + * a-direct.ads: Minor spelling error fixes in comments. + * gnat_rm.texi: Add three entries in "Implementation Defined + Characteristics" for the interpretations of the Form parameters in + Ada.Directories. + +2010-10-05 Robert Dewar + + * exp_ch3.adb, exp_ch5.adb, exp_disp.adb, exp_dist.adb, gnatlink.adb, + makeutl.adb, par-ch6.adb, prj-dect.adb, prj-env.adb, prj-env.ads, + prj-ext.adb, prj-nmsc.adb, prj-part.adb, prj-pp.ads: Minor code + reorganization. + Minor reformatting. + +2010-10-05 Ed Schonberg + + * sem_res.adb (Check_Parameterless_Call): If the prefix of 'Address is + an explicit dereference of an access to function, the prefix is not + interpreted as a parameterless call. + +2010-10-05 Ed Schonberg + + * exp_attr.adb: For 'Read and 'Write, use full view of base type if + private. + +2010-10-05 Vincent Celier + + * make.adb (Switches_Of): Allow wild cards in index of attributes + Switches. + * prj-util.adb (Value_Of): When Allow_Wildcards is True, use the index + of the associative array as a glob regular expression. + * prj-util.ads (Value_Of (Index, In_Array)): New Boolean parameter + Allow_Wildcards, defaulted to False. + (Value_Of (Name, Attribute_Or_Array_Name)): Ditto + * projects.texi: Document that attribute Switches () may + use wild cards in the index. + +2010-10-05 Robert Dewar + + * a-direct.adb, a-direct.ads, back_end.adb, checks.adb, + einfo.adb: Minor reformatting. + * debug.adb: Remove obsolete documentation for d.Z flag. + +2010-10-05 Vincent Celier + + * vms_data.ads: Add VMS qualifier /SRC_INFO= corresponding to gnatmake + switch --create-info-file=. + * gnat_ugn.texi: Add documentation for new gnatmake switch + --source-info= + +2010-10-05 Ed Schonberg + + * sem_ch3.adb: Do not elaborate type definition if syntax error. + +2010-10-05 Javier Miranda + + * sprint.adb (Sprint_Node_Actual): Improve output of subprogram bodies + to generate the full-qualified names of its corresponding spec. + This facilitates locating the corresponing body when reading + the DG output. + +2010-10-05 Thomas Quinot + + * exp_dist.adb (Make_Helper_Function_Name): For a tagged type, use + canonical name without serial number only if the helper is becoming a + primitive of the type. + +2010-10-05 Javier Miranda + + * exp_disp.adb (Make_DT): Minor code reorganization. + +2010-10-05 Ed Schonberg + + * par-ch6.adb: improve recovery with extra paren in function spec. + +2010-10-05 Quentin Ochem + + * prj-tree.ads: Project_Path is now aliased. + +2010-10-05 Thomas Quinot + + * checks.adb: Minor reformatting. + +2010-10-05 Eric Botcazou + + * mlib-tgt-specific-mingw.adb (No_Argument_List): Delete. + (Shared_Libgcc): New aliased variable. + (Shared_Libgcc_Switch): New constant. + (Build_Dynamic_Library): Pass Shared_Libgcc_Switch to the compiler + * gcc-interface/Makefile.in (gnatlib-shared-win32): Pass -shared-libgcc + to the compiler. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-10-05 Vincent Celier + + * prj-part.adb (Parse_Simple_Project): When checking if a child project + imports its parent project, also look in projects being extended by + imported projects. + +2010-10-05 Eric Botcazou + + * gnat_ugn.texi: Adjust instructions in G.10 Building DLLs with GNAT. + +2010-10-05 Javier Miranda + + * exp_cg.adb (Slot_Number): Add support to handle aliased entities. + (Generate_CG_Output): Switch -gnatd.Z is no longer needed to + activate this output. + +2010-10-05 Arnaud Charlet + + * back_end.adb (Call_Back_End): Generate an error message when scil + generation is enabled, and no scil back-end (by default) is available. + +2010-10-05 Javier Miranda + + * debug.adb: Update documentation since -gnatd.Z is no longer required + to generate the call-graph information. + +2010-10-05 Javier Miranda + + * exp_ch5.adb (Expand_Simple_Function_Return): Rewrite expansion of a + runtime access check by an equivalent expansion that causes + no problems in the VM backend. The original expansion was + not good for the VM backends because when Tagged_Type_Expansion + is disabled the attribute Access_Disp_Table is not available. + +2010-10-05 Ed Schonberg + + * sem_type.adb (Covers): In a dispatching context, T1 covers T2 if T2 + is class-wide and T1 is its specific type. + +2010-10-05 Ed Schonberg + + * einfo.adb: Add guard to Is_String_Type to prevent cascaded errors. + +2010-10-05 Vincent Celier + + * back_end.ads: Minor spelling error correction. + +2010-10-05 Arnaud Charlet + + * switch-c.adb, gnat1drv.adb (Scan_Front_End_Switches): Disable + warnings when -gnatC is specified here so that warnings can be + re-enabled explicitly. + (Adjust_Global_Switches): No longer suppress warnings. + +2010-10-05 Vincent Celier + + * makeutl.adb: Minor reformatting. + +2010-10-05 Ed Schonberg + + * sem_ch4.adb: add guard in Analyze_One_Call to prevent crash when a + non-discrete type appears as an actual in a call. + +2010-10-05 Vincent Celier + + * make.adb (Scan_Make_Arg): Take into account new switch + --source-info=file. + * makeusg.adb: Add line for new switch --source-info=file. + * makeutl.ads (Source_Info_Option): New constant String for new builder + switch. + * prj-conf.adb: Put subprograms in alphabetical order + (Process_Project_And_Apply_Config): Read/write an eventual source info + file, if necessary. + * prj-nmsc.adb (Look_For_Sources.Get_Sources_From_Source_Info): New + procedure. + (Look_For_Sources): If a source info file was successfully read, get + the source data from the data read from the source info file. + * prj-util.adb (Source_Info_Table): New table + (Source_Info_Project_HTable): New hash table + (Create): New procedure + (Put (File), Put_Line): New procedures + (Write_Source_Info_File): New procedure + (Read_Source_Info_File): New procedure + (Initialize): New procedure + (Source_Info_Of): New procedure + (Next): New procedure + (Close): When file is an out file, fail if the buffer cannot be written + or if the file cannot be close successfully. + (Get_Line): Fail if file is an out file + * prj-util.ads (Create): New procedure + (Put (File), Put_Line): New procedures + (Write_Source_Info_File): New procedure + (Read_Source_Info_File): New procedure + (Source_Info_Data): New record type + (Source_Info_Iterator): New private type + (Initialize): New procedure + (Source_Info_Of): New procedure + (Next): New procedure + * prj.ads (Project_Tree_Data): New components Source_Info_File_Name and + Source_Info_File_Exists. + +2010-10-05 Ed Schonberg + + * exp_ch4.adb: Fix typo. + +2010-10-05 Thomas Quinot + + * lib-writ.adb: Minor reformatting. + +2010-10-05 Javier Miranda + + * sem_ch3.adb (Access_Definition): Remove useless code. + +2010-10-05 Emmanuel Briot + + * prj-env.adb, prj-env.ads (Set_Path): New subprogram. + (Deep_Copy): Removed, not used. + +2010-10-05 Javier Miranda + + * sem_ch3.adb (Add_Internal_Interface_Entities): Code reorganization: + move code that searches in the list of primitives of a tagged type for + the entity that will be overridden by user-defined routines. + * sem_disp.adb (Find_Primitive_Covering_Interface): Move here code + previously located in routine Add_Internal_Interface_Entities. + * sem_disp.ads (Find_Primitive_Covering_Interface): Update docs. + * sem_ch6.adb (New_Overloaded_Entity): Add missing check on + availability of attribute Alias. + +2010-10-05 Ed Falis + + * s-taprop-vxworks.adb, s-osinte-vxworks.adb, s-osinte-vxworks.ads, + s-vxwext.ads, s-vxwext-kernel.ads, s-vxwext-rtp.adb, s-vxwext-rtp.ads: + Move definition of intContext to System.OS_Interface. + Add necessary variants in System.VxWorks.Extensions. + +2010-10-05 Doug Rupp + + * s-asthan-vms-alpha.adb: On VMS, a task using + pragma AST_Entry exhibits a memory leak when the task terminates + because the vector allocated for the AST interface is not freed. Fixed + by making the vector a controlled type. + +2010-10-05 Emmanuel Briot + + * prj-nmsc.adb (Expand_Subdirectory_Pattern): Check that the prefix in + a "**" pattern properly exists, and report an error otherwise. + +2010-10-05 Emmanuel Briot + + * prj-env.ads: Use GNAT.OS_Lib rather than System.OS_Lib. + +2010-10-05 Emmanuel Briot + + * prj-nmsc.adb, prj-err.adb (Expand_Subdirectory_Pattern): New + subprogram. + Extract some code from Get_Directories, to share with the handling + of aggregate projects (for the Project_Files attributes) + +2010-10-05 Emmanuel Briot + + * gnatcmd.adb, prj-proc.adb, prj-part.adb, prj-ext.adb, prj-ext.ads, + switch-m.adb, clean.adb, prj-nmsc.adb, prj-nmsc.ads, prj-env.adb, + prj-env.ads, prj-tree.adb, prj-tree.ads (Project_Search_Path): New + type. + +2010-10-05 Eric Botcazou + + * exp_ch5.adb (Make_Field_Expr): Revert previous change (removed). + +2010-10-05 Emmanuel Briot + + * prj-dect.adb, prj-nmsc.adb, prj-attr.adb, snames.ads-tmpl + (Aggregate projects): added support for parsing aggregate projects. + In particular, check the presence and value of the new attributes + related to aggregate projects, ie Project_Files, Project_Path + and External. + (Check_Attribute_Allowed, Check_Package_Allowed, + Rename_Obsolescent_Attributes): new subprogram, extracting code + from existing subprogram to keep their sizes smaller. + (Check_Aggregate_Project, Check_Abstract_Project, + Check_Missing_Sources): new subprograms + (Check): remove comments that duplicated either the name of the + following subprogram call, or the comment on that subprogram. + * prj-part.adb (Check_Extending_All_Imports): New subprogram, extracted + from Parse_Single_Project. + (Check_Aggregate_Imports): new subprogram. + +2010-10-05 Vincent Celier + + * make.adb (Check): When compiling with -gnatc, recompile if the ALI + file has not been generated for the current source, for example if it + has been generated for the spec, but we are compiling the body. + +2010-10-05 Bob Duff + + * xgnatugn.adb: Remove unused procedure. + +2010-10-04 Vincent Celier + + * a-direct.adb (Copy_File): Interpret the Form parameter and call + System.OS_Lib.Copy_File to do the work accordingly. Raise Use_Error if + the Form parameter contains an incorrect value for field preserve= or + mode=. + * a-direct.ads (Create_Directory, Create_Path): Indicate that the Form + parameter is ignored. + (Copy_File): Indicate the interpretation of the Form parameter. + +2010-10-04 Vincent Celier + + * make.adb (Gnatmake): When there are no foreign languages declared and + a main in attribute Main of the main project does not exist or is a + source of another project, fail immediately before attempting + compilation. + +2010-10-04 Javier Miranda + + * exp_disp.ads (Convert_Tag_To_Interface): New function which must be + used to convert a node referencing a tag to a class-wide interface + type. + * exp_disp.adb (Convert_Tag_To_Interface): New function. + (Expand_Interface_Conversion): Replace invocation of + Unchecked_Conversion by new function Convert_Tag_To_Interface. + (Write_DT): Add support for null primitives. + * exp_ch3.adb (Expand_N_Object_Declaration): For tagged type objects, + cleanup code that handles interface conversions and avoid unchecked + conversion of referenced tag components. + * exp_ch5.adb (Expand_N_Assignment_Statement): Code cleanup. Avoid + unrequired conversions when generating a dispatching call to _assign. + * sprint.adb (Write_Itype): Fix wrong output of not null access itypes. + +2010-10-04 Ed Schonberg + + * exp_ch4.adb (Expand_N_Op_Not): Handle properly both operands when the + parent is a binary boolean operation and the operand is an unpacked + array. + (Build_Boolean_Array_Proc_Call): If the operands are both negations, + the operands of the rewritten node are the operands of the negations, + not the negations themselves. + +2010-10-04 Robert Dewar + + * sem_ch13.adb (Set_Biased): New procedure, now used throughout, adds + name of entity to biased warning msg. + (Analyze_Enumeration_Representation_Clause): Remove attempt to use + biased rep (wrong and never worked anyway). + +2010-10-04 Arnaud Charlet + + * sem_elab.adb: Minor reformatting. + +2010-10-04 Ed Schonberg + + * exp_ch4.adb (Expand_N_Null): Handle properly the case of a subtype of + an access_to_protected subprogram type, and convert null value into + corresponding aggregate. + +2010-10-04 Eric Botcazou + + * gnat_ugn.texi: Clarify first point of 7.1.5 about pragma Inline. + +2010-10-04 Eric Botcazou + + * make.adb (Scan_Make_Arg): Pass -Oxxx switches to the linker as well. + * gnatlink.adb (Gnatlink): Filter out -Oxxx switches for CLI, RTX and + AAMP. + +2010-10-04 Eric Botcazou + + * sem_ch4.adb (Analyze_Indexed_Component_Form): Remove redundant test + for N_Operator_Symbol. + (Indicate_Name_And_Type): Likewise. + * sem_ch8.adb (Analyze_Subprogram_Renaming): Likewise. + * sem_res.adb (Resolve): Likewise. + * sem_type.adb (Add_One_Interp): Likewise. + (Disambiguate): Likewise. + +2010-10-04 Vincent Celier + + * osint.adb (Read_Library_Info_From_Full): If object timestamp is less + than ALI file timestamp, return null. + +2010-10-04 Vincent Celier + + * prj-makr.adb (Finalize): Invoke Pretty_Print with Max_Length of 79. + * prj-pp.adb (Pretty_Print): New parameter Max_Line_Length, that + replaces global constant with the same name. When a line is too long, + indent properly the next continuation line. + * prj-pp.ads (Pretty_Print): New parameter Max_Line_Length with a range + from 50 to 255, defaulted to 255, to indicate the maximum length of + lines in the project file. + +2010-10-04 Eric Botcazou + + * sem_ch7.adb (Analyze_Package_Body_Helper) : New + Check_Subprogram_Ref function and Check_Subprogram_Refs instantiation + of Traverse_Func on it to look for subprogram references in a body. + Call Check_Subprogram_Refs on the body of inlined subprograms at the + outer level and keep clearing the Is_Public flag of subprograms as long + as it returns OK. Do not look at anything else than subprograms once + an inlined subprogram has been seen. + +2010-10-04 Javier Miranda + + * exp_cg.adb (Expand_N_Assignment_Statement): Restore tag check when + the target object is an interface. + * sem_disp.adb (Propagate_Tag): If the controlling argument is an + interface type then we generate an implicit conversion to force + displacement of the pointer to the object to reference the secondary + dispatch table associated with the interface. + +2010-10-04 Robert Dewar + + * sem_ch13.adb (Analyze_Enumeration_Representation_Clause): Set + Enumeration_Rep_Expr to point to the literal, not the identifier. + (Analyze_Enumeration_Representation_Clause): Improve error message for + size too small for enum rep value + (Analyze_Enumeration_Representation_Clause): Fix size test to use + proper size (RM_Size, not Esize). + +2010-10-04 Robert Dewar + + * s-taprop-vxworks.adb, sem_res.adb: Minor reformatting. + +2010-10-04 Javier Miranda + + * exp_cg.adb (Write_Call_Info): Code clean up. + +2010-10-04 Arnaud Charlet + + * s-taprop-mingw.adb (Create_Task): Initialize Thread_Id field to 0. + +2010-10-04 Robert Dewar + + * exp_cg.adb: Minor code reorganization + Minor reformatting. + * exp_ch5.adb, prj-nmsc.adb: Minor reformatting. + +2010-10-04 Bob Duff + + * sem_res.adb (Resolve_Type_Conversion): If a type conversion is needed + to make a qualified expression into a name (syntax-wise), then do not + consider it redundant. + +2010-10-04 Thomas Quinot + + * sem_warn.ads: Fix typo. + +2010-10-04 Javier Miranda + + * exp_cg.adb (Is_Predefined_Dispatching_Operation): Handle suffix in + TSS names. + (Write_Call_Info): Add missing support for renamed primitives. + +2010-10-04 Thomas Quinot + + * exp_ch5.adb (Make_Field_Expr): New subprogram, to factor duplicated + code between Make_Component_List_Assign and Make_Field_Assign. + +2010-10-04 Vincent Celier + + * prj-nmsc.adb (Get_Directories): For non extending projects that + declare that they have no sources, do not create a non existing object + or exec directory if builder switch -p is used. + +2010-10-04 Sergey Rybin + + * gnat_ugn.texi (gnatcheck): Change the description of the report file + format. + +2010-10-04 Ed Falis + + * s-taprop-vxworks.adb (Is_Task_Context): Import VxWorks intContext to + determine whether Set_True is called from a task or an ISR. + (Set_True): test for being in a task context before trying to + dereference Defer_Abort or Undefer_Abort. + +2010-10-04 Robert Dewar + + * sem_res.adb, sinput-l.adb: Minor reformatting. + +2010-10-04 Hristian Kirtchev + + * exp_ch5.adb (Expand_N_Assignment_Statement): Do not generate a tag + check when the target object is an interface since the expression of + the right hand side must only cover the interface. + +2010-10-04 Vincent Celier + + * frontend.adb: Set Lib.Parsing_Main_Extended_Source to True before + loading the main source, so that if it is preprocessed and -gnateG is + used, the preprocessed file is written. + * lib.ads (Analysing_Subunit_Of_Main): New global variable to indicate + if a subunit is from the main unit when it is loaded. + * sem_ch10.adb (Analyze_Proper_Body): Set Lib.Analysing_Subunit_Of_Main + to True before loading a subunit. + * sem_ch12.adb (Copy_Generic_Node): Set Lib.Analysing_Subunit_Of_Main + to True when the main is a generic unit before loading one of its + subunits. + * sinput-l.adb (Load_File): If -gnateG is used, write the preprocessed + file only for the main unit (spec, body and subunits). + +2010-10-04 Vincent Celier + + * sinput-l.adb (Load_File): Do not fail when switch -gnateG is + specified and the processed file cannot be written. Just issue a + warning and continue. + +2010-10-04 Thomas Quinot + + * sem_res.adb: Minor reformatting. + +2010-10-04 Ed Schonberg + + * sem_ch8.adb (Analyze_Subprogram_Renaming): If the renamed operation + is an overridden inherited operation, the desired operation is the + overriding one, which is the alias of the visible one. + +2010-10-04 Ed Schonberg + + * sem_ch6.adb (Find_Corresponding_Spec): Check that the wrapper body is + present before deleting from the tree, when an inherited function with + a controlling result that returns a null extension is overridden by a + later declaration or body. + +2010-10-04 Gary Dismukes + + * checks.adb: Update comment. + +2010-09-30 Joseph Myers + + * gcc-interface/misc.c (optimize, optimize_size): Undefine as macros + and define as variables. + (gnat_post_options): Set optimize and optimize_size variables. + +2010-09-29 Joel Sherrill + + * g-socket.adb: Move pragma to disable warnings in case multiple errnos + are not defined by target. + +2010-09-29 Eric Botcazou + + * gcc-interface/utils.c (handle_leaf_attribute): Fix long line. + +2010-09-28 Richard Henderson + + * gcc-interface/misc.c (gnat_eh_personality): Use + targetm.except_unwind_info. + +2010-09-28 Jan Hubicka + + * gcc-interface/utils.c (handle_leaf_attribute): New function. + (gnat_internal_attribute_tables): Add leaf. + +2010-09-22 Joseph Myers + + * gcc-interface/lang.opt (-all-warnings, -include-barrier, + -include-directory, -include-directory=, -no-standard-includes, + -no-standard-libraries): New. + +2010-09-20 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity): Replace calls to + build_array_type with calls to build_nonshared_array_type. + (substitute_in_type): Likewise. + * gcc-interface/misc.c (LANG_HOOKS_HASH_TYPES): Delete. + (LANG_HOOKS_TYPE_HASH_EQ): Define. + (gnat_post_options): Add 'static' keyword. + (gnat_type_hash_eq): New static function. + * gcc-interface/utils.c (fntype_same_flags_p): New function. + (create_subprog_type): Call it. + (create_index_type): Call build_nonshared_range_type and tidy up. + (create_range_type): Likewise. + * gcc-interface/gigi.h (fntype_same_flags_p): Declare. + +2010-09-19 Eric Botcazou + + * gcc-interface/trans.c (gnat_pushdecl): Do not do anything special + for PARM_DECLs. + (end_subprog_body): If the body is a BIND_EXPR, make its associated + block the top-level one. + (build_function_stub): Build a statement group for the whole function. + * gcc-interface/utils.c (Subprogram_Body_to_gnu): If copy-in/copy-out + is used, create the enclosing block early and process first the OUT + parameters. + +2010-09-19 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Do + not generate debug info for individual enumerators. + +2010-09-19 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Use record + type instead of enumeral type as the dummy type built for the template + type of fat pointers. + +2010-09-19 Eric Botcazou + + * gcc-interface/gigi.h (get_elaboration_procedure): Declare. + (gnat_zaplevel): Likewise. + * gcc-interface/decl.c (gnat_to_gnu_entity): Do not force global + binding level for an external constant. + : Force the local context and create a fake scope before + translating the defining expression of an external constant. + : Treat external constants at the global level explicitly for + renaming declarations. + (elaborate_expression_1): Force the variable to be static if the + expression is global. + * gcc-interface/trans.c (get_elaboration_procedure): New function. + (call_to_gnu): Use it. + (gnat_to_gnu): Likewise. + : Do not test Is_Public to force the creation of + an initialization variable. + (add_decl_expr): Discard the statement if the declaration is external. + * gcc-interface/utils.c (gnat_pushdecl): Do not put the declaration in + the current block if it is external. + (create_var_decl_1): Do not test Is_Public to set TREE_STATIC. + (gnat_zaplevel): New global function. + +2010-09-19 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity): Explicitly test _LEVEL + variables against zero in all cases. + (rest_of_type_decl_compilation): Likewise. + * gcc-interface/trans.c (gigi): Pass properly typed constants to + create_var_decl. + (call_to_gnu): Fix formatting. + (Handled_Sequence_Of_Statements_to_gnu): Likewise. + (Exception_Handler_to_gnu_zcx): Likewise. + (gnat_to_gnu) : Short-circuit handling of + constant + expressions in presence of a freeze node. + +2010-09-19 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Look into + expressions for external constants that are aggregates. + * gcc-interface/utils2.c (build_simple_component_ref): If the field + is an inherited component in an extension, look through the extension. + +2010-09-10 Vincent Celier + + * projects.texi: Add documentation for package extensions + Add some documentation for attributes Leading_Library_Options and + Linker'Leading_Switches. + +2010-09-10 Ed Schonberg + + * exp_util.adb (Expand_Subtype_From_Expression): When expansion is + disabled, compute subtype for all string types. + +2010-09-10 Robert Dewar + + * gnat_ugn.texi: Add documentation for -gnatw.s/S + * sem_ch13.adb (Analyze_Attribute_Definition_Clause, case + Component_Size): Implement warning on overriden size clause. + (Analyze_Record_Representation_Clause): Implement warning on overriden + size clause. + * sem_warn.ads, sem_warn.adb (Warn_On_Overridden_Size): New flag + (-gnatw.s/S). + * ug_words: Add entries for -gnatw.s/S. + * vms_data.ads, usage.adb: Add line for -gnatw.s/-gnatw.S. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-09-10 Vincent Celier + + * prj-dect.adb (Parse_Package_Declaration): Allow a package to extend + a package with the same name from an imported or extended project. + * prj-proc.adb (Process_Declarative_Items): Process package extensions + +2010-09-10 Bob Duff + + * exp_ch6.adb (Expand_Call): Do not perform a null_exclusion check on + 'out' parameters. + +2010-09-10 Robert Dewar + + * sem.adb: Minor reformatting. + +2010-09-10 Bob Duff + + * s-os_lib.ads, g-expect.ads: Add comments. + +2010-09-10 Robert Dewar + + * exp_ch5.adb: Minor reformatting. + +2010-09-10 Thomas Quinot + + * scos.ads: Add comments. + +2010-09-10 Vincent Celier + + * gnatcmd.adb (Get_Closure): Remove useless invocation of Close. + +2010-09-10 Hristian Kirtchev + + * exp_ch7.adb, exp_ch6.adb (Expand_Call): Establish a transient scope + for a controlled build-in-place function call which appears in an + anonymous context. The transient scope ensures that the intermediate + function result is cleaned up after the master is left. + (Make_Build_In_Place_Call_In_Anonymous_Context): Remove the creation + of the transient scope. This is now done in Exand_Call which covers + additional cases other than secondary stack release. + +2010-09-10 Arnaud Charlet + + * sem.adb (Do_Unit_And_Dependents): Add guard. + +2010-09-10 Robert Dewar + + * exp_ch5.adb: Update comments. + * exp_dist.adb: Minor reformatting. + +2010-09-10 Robert Dewar + + * sem_ch13.adb (Check_Record_Representation_Clause): Implement record + gap warnings. + * sem_warn.ads, sem_warn.adb (Warn_On_Record_Holes): New warning flag. + * usage.adb: Add lines for -gnatw.h/H + * gnat_ugn.texi: Add documentation for J519-010 + Warn on record holes/gaps + * ug_words: Add entries for -gnatw.h/-gnatw.H + * vms_data.ads: Add entries for [NO]AVOIDGAPS + +2010-09-10 Gary Dismukes + + * sem_ch6.adb: Update comment. + +2010-09-10 Ed Schonberg + + * sem_ch3.adb (Build_Derived_Private_Type): Mark generated declaration + of full view analyzed after analyzing the corresponding record + declaration, to prevent spurious name conflicts with original + declaration. + +2010-09-10 Jerome Lambourg + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause): In the VM case, + just issue a warning, but continue with the normal processing. + +2010-09-10 Robert Dewar + + * exp_attr.adb, prj-nmsc.adb, sem_ch4.adb, sem_res.adb: Minor + reformatting. + +2010-09-10 Thomas Quinot + + * exp_dist.adb (Build_From_Any_Call, Build_To_Any_Call, + Build_TypeCode_Call): For a subtype inserted for the expansion of a + generic actual type, go to the underlying type of the original actual + type. + +2010-09-10 Ed Schonberg + + * exp_ch5.adb (Expand_Assign_Array_Loop): In CodePeer mode, place a + guard around the increment statement, to prevent an off-by-one-value + on the last iteration. + +2010-09-10 Vincent Celier + + * sem_aggr.adb, exp_prag.adb, sem_ch3.adb, exp_attr.adb, + sem_res.adb, sem_attr.adb, sem_elab.adb, sem_ch4.adb, exp_disp.adb, + exp_aggr.adb, exp_dist.adb: Change all mentions of "at run-time" to + "at run time" in comments and error/warning messages. + +2010-09-10 Ed Schonberg + + * exp_cg.adb: Handle properly bodies without specs. + +2010-09-10 Emmanuel Briot + + * prj-nmsc.adb (Find_Source_Dirs): When a source directory is not + present, and the user requested to either ignore this or display a + warning (as opposed to an error), we still need to register the + directory. + +2010-09-10 Robert Dewar + + * errout.adb: Remove tests of Parsing_Main_Subunit, since this test is + now done in In_Extended_Main_Source_Unit. + * errout.ads (Compiler_State[_Type]): Moved from Errout to Lib + (Parsing_Main_Subunit): Moved from Errout to Lib and renamed + as Parsing_Main_Extended_Source. + * frontend.adb: Set Parsing_Main_Extended_Source True for parsing main + unit. + * lib-load.adb (Load_Unit): Add PMES parameter + Set PMES appropriately in all calls to Load_Unit + * lib-load.ads (Load_Unit): Add PMES parameter + * lib.adb (In_Extended_Main_Source_Unit): When called with + Compiler_State set to Parsing, test new flag + Compiling_Main_Extended_Source. + * lib.ads (Compiler_State[_Type]): Moved from Errout to Lib + (Parsing_Main_Subunit): Moved from Errout to Lib and renamed + as Parsing_Main_Extended_Source + * par-load.adb (Load): Set PMES properly in call to Load_Unit + +2010-09-10 Ed Schonberg + + * exp_cg.adb: Use proper entity to handle overloads. + * sem_res.adb (Check_Parameterless_Call): An operator node without + actuals cannot be a call, and must be treated as a string. + +2010-09-10 Robert Dewar + + * frontend.adb: Minor reformatting. + +2010-09-10 Robert Dewar + + * par-ch4.adb (P_Conditional_Expression): Use P_Condition for condition + * par-ch5.adb (P_Condition): Move from body to spec + * par.adb (Ch5.P_Condition): Move from body to spec + +2010-09-10 Ed Schonberg + + * exp_cg.adb (Write_Call_Info): If a type that has been registered in + the call table is private, use its full view to generate information + on its operations. + +2010-09-10 Jose Ruiz + + * exp_cg.adb (Is_Predefined_Dispatching_Operation): When trying the + pattern matching to detect predefined primitive operations take into + account that there can be an extra suffix related to body-nested + package entities. + +2010-09-10 Ed Schonberg + + * s-pooglo.ads: Add overriding indicators. + +2010-09-10 Vincent Celier + + * vms_data.ads: Add new GNAT BIND qualifiers /32_MALLOC (for -H32) and + /64_MALLOC (for -H64). + +2010-09-10 Robert Dewar + + * errout.adb (Error_Msg_Internal): Test Parsing_Main_Subunit flag + (Error_Msg_NW): Test Parsing_Main_Subunit flag + * errout.ads (Parsing_Main_Subunit): New flag + * lib-load.adb (Load_Unit): Set Parsing_Main_Subunit flag + * par-ch6.adb: Minor style fix (remove redandant parentheses) + * par-ch9.adb: Minor style fix (remove redundant parens) + * par-load.adb: (Load): Deal with setting Parsing_Main_Subunit + +2010-09-10 Vincent Celier + + * make.adb (Create_Binder_Mapping_File): Remove procedure. Replaced by + function of the same name in Makeutl. + (Gnatmake): Call function Create_Binder_Mapping_File in Makeutl, instead + of removed procedure when creating a binder mapping file. + * makeutl.adb (Create_Binder_Mapping_File): New function. Was a + procedure in Make. + * makeutl.ads (Create_Binder_Mapping_File): New function + +2010-09-10 Jose Ruiz + + * exp_cg.adb (Is_Predefined_Dispatching_Operation): Add the "__" scope + separator when trying the pattern matching to detect predefined + primitive operations. + +2010-09-10 Robert Dewar + + * bindgen.adb, atree.adb: Minor reformatting. + +2010-09-10 Ben Brosgol + + * ug_words, gnat_ugn.texi: Revised "Transitioning to 64-Bit GNAT for + OpenVMS" section. + +2010-09-10 Doug Rupp + + * bindgen.adb: Minor comment fix for -H switch. + +2010-09-10 Ed Schonberg + + * exp_cg.adb (Register_CG_Node): Determine enclosing subprogram or + library unit now, by traversing tree before context is expanded. + (Write_Call_Info): Use enclosing unit name directly. + * exp_ch9.adb (Expand_N_Accept_Statement): Attach generated block to + tree earlier, to ensure that subsequent declarations are analyzed in a + connected structure. + * exp_intr.adb (Expand_Unc_Deallocation): Ditto for generated statement + list. + +2010-09-10 Robert Dewar + + * symbols-processing-vms-alpha.adb: Minor reformatting. + +2010-09-10 Jerome Lambourg + + * bindgen.adb (Gen_Adainit_Ada): In .NET, don't call + __gnat_install_handler in case the binder is called with -n. + +2010-09-10 Ed Schonberg + + * exp_ch6.adb (Make_Build_In_Place_In_Object_Declaration): Use proper + sloc for renaming declaration and set Comes_From_Source properly to + ensure that references are properly generated for an object declaration + that is built in place. + +2010-09-10 Tristan Gingold + + * symbols-processing-vms-alpha.adb: Allow gnatsym to work as a cross + tool. + * gcc-interface/Make-lang.in: Install gnatsym when cross compiling. + * gcc-interface/Makefile.in: gnat.hlp is now generated by + Make-generated.in + +2010-09-10 Bob Duff + + * exp_pakd.adb (Expand_Bit_Packed_Element_Set): For things like ""X(J) + := ...;", remove side effects from the right-hand side, because they + might affect the value of the left-hand side, but the left-hand side is + first READ (so we can do shifting and masking) and then written back, + which would cause the side effects to be incorrectly overwritten. + +2010-09-10 Robert Dewar + + * sem_ch4.adb: Minor reformatting. + * exp_ch6.adb: Add comment on testing limited on full type + * gnat_rm.texi: Add documentation on Pure_Function. + +2010-09-10 Vincent Celier + + * prj-nmsc.adb (Add_Source): Allow an Ada source to have the same name + as a source of another project and of another language. + +2010-09-10 Robert Dewar + + * exp_ch3.adb (Expand_N_Object_Declaration): Defend against previous + errors. + * freeze.adb (Check_Unsigned_Type): Ditto. + * sem_aggr.adb (Resolve_Aggr_Expr): Ditto. + * sem_ch3.adb (Convert_Scalar_Bounds): Ditto. + (Set_Scalar_Range_For_Subtype): Ditto. + * sem_eval.adb (Subtypes_Statically_Match): Ditto. + +2010-09-10 Robert Dewar + + * repinfo.adb (List_Type_Info): List Small and Range for fixed-point + types. + * sprint.adb (Write_Ureal_With_Col_Check_Sloc): Use square brackets + rather than parens for fixed constants. + * sprint.ads: Use square brackets rather than parens for fixed constants + * urealp.adb (UR_Write): Use square brackets rather than parens + (UR_Write): Add Brackets argument + (UR_Write): Add many more special cases to output literals + * urealp.ads (UR_Write): Use square brackets rather than parens + (UR_Write): Add Brackets argument + +2010-09-10 Robert Dewar + + * sem_ch4.adb: Minor reformatting. + +2010-09-10 Richard Guenther + + * gcc-interface/utils.c (create_index_type): Use build_range_type. + +2010-09-10 Arnaud Charlet + + * vms_cmds.ads: New. + +2010-09-10 Eric Botcazou + + * exp_dbug.ads: Mention enhanced encoding for array types. + +2010-09-10 Jerome Lambourg + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Size clause are + unsupported in VM targets. Display a warning in this case. + +2010-09-10 Ed Schonberg + + * sprint.adb (Sprint_Node_Actual, case N_Derived_Type_Definition): Do + not reset Sloc when printing keyword "new". + +2010-09-10 Vincent Celier + + * gnatcmd.adb (GNATCmd): Put the command line in environment variable + GNAT_DRIVER_COMMAND_LINE. + +2010-09-10 Ed Schonberg + + * sem.adb (Do_Unit_And_Dependents): if Withed_Body is set on a context + clause, process the body at once. + +2010-09-10 Ed Schonberg + + * sem_res.adb (Resolve_Type_Conversion): Do not warn on a redundant + conversion is the expression is a qualified expression used to + disambiguate a function call. + +2010-09-10 Vincent Celier + + * prj-nmsc.adb (Add_Source): Allow an Ada source to have the same name + as a source of another project and of another language. + +2010-09-10 Robert Dewar + + * prj-util.adb: Minor reformatting. + +2010-09-10 Eric Botcazou + + * exp_disp.adb: Minor reformatting. + +2010-09-10 Arnaud Charlet + + * sem_prag.adb (Analyze_Pragma): Ignore Inline_Always pragma in + CodePeer mode. + +2010-09-10 Thomas Quinot + + * sem_res.adb: Minor reformatting. + * exp_ch9.adb, rtsfind.ads, exp_ch4.adb, exp_ch3.adb: Do not hardcode + magic constants for task master levels (instead, reference + named numbers from System.Tasking). + +2010-09-10 Eric Botcazou + + * gnatvsn.ads (Ver_Prefix): New constant string. + * bindgen.adb (Gen_Output_File_Ada): Use it in lieu of hardcoded value. + (Gen_Output_File_C): Likewise. + * g-comver.adb (Ver_Prefix): Add cross-reference to Gnatvsn.Ver_Prefix + in comment. + +2010-09-10 Ed Schonberg + + * sem.adb (Walk_Library_Items): Do not traverse children of the main + unit, to prevent spurious circularities in the walk order. + (Depends_On_Main): Use elsewhere to prevent circularities when the body + of an ancestor of the main unit depends on a child of the main unit. + +2010-09-10 Robert Dewar + + * gnatlink.adb, prj-ext.adb, prj-util.adb, s-tporft.adb, + sem_ch3.adb: Minor reformatting. + +2010-09-10 Ed Schonberg + + * sem_ch3.adb (Derive_Subprograms): An interface primitive operation + that is a renaming must be derived like any other primitive operation, + the renamed operation is not relevant to the derivation. + +2010-09-10 Robert Dewar + + * sem_aux.ads: Add comment for Is_Inherently_Limited_Type. + * checks.adb: Minor reformatting. + +2010-09-10 Robert Dewar + + * gnat_ugn.texi: Add section on intent of style checking options. + +2010-09-10 Arnaud Charlet + + * xref_lib.adb (Get_Full_Type): Fix handling of 'a' char. + +2010-09-10 Ed Schonberg + + * sem_ch3.adb: Improve error message on derivation from class-wide type + +2010-09-10 Steve Baird + + * gnat1drv.adb (Adjust_Global_Switches): Enable Expression_With_Actions + generation when Generate_SCIL is True. + +2010-09-10 Geert Bosch + + * gnatlink.adb (Check_ Existing_Executable): New procedure for checking + validity of executable name and removing any existing executable + (Gnatlink): Call Check_Existing_Executable. + +2010-09-10 Arnaud Charlet + + * s-tporft.adb, s-taskin.ads (Register_Foreign_Thread): Move + initialization of Task_Alternate_Stack here, cleaner since in case of + ranvescar, Restricted_Ada_Task_Control_Block is not initialized + implicitly. + +2010-09-10 Thomas Quinot + + * s-fileio.adb, a-dirval.adb: Minor reformatting. + +2010-09-10 Emmanuel Briot + + * prj-util.adb (Executable_Of): Fix CE when the project does not + contain a Builder package. + +2010-09-10 Vincent Celier + + * prj-ext.adb (Initialize_Project_Path): Add /lib/gpr/ + to the project path, if Prefix and Target_Name are defined. + * prj-tree.ads (Project_Node_Tree_Data): New component Target_Name + +2010-09-10 Ed Schonberg + + * checks.adb (Ensure_Valid): If the expression is a boolean expression + or short-circuit operation, do no emit a validity check: only the + elementary operands of the expression need checking. + +2010-09-10 Ben Brosgol + + * gnat_rm.texi: Document Short_Descriptors. + +2010-09-10 Arnaud Charlet + + * s-taprop-linux.adb, s-taskin.ads (Task_Alternate_Stack): Default + initialize to Null_Address. + (Enter_Task): Do not set up an alternate stack for foreign threads. + +2010-09-10 Robert Dewar + + * opt.adb (Short_Descriptors): New flag + (Short_Descriptors_Config): New flag + * opt.ads (Short_Descriptors): New flag + (Short_Descriptors_Config): New flag + * par-prag.adb: Add dummy entry for Short_Descriptors pragma + * sem_prag.adb (Set_Mechanism_Value): Deal with Short_Descriptors. + (Analyze_Pragma): Implement Short_Descriptors pragma + * snames.ads-tmpl: Add entry for Short_Descriptors pragma + +2010-09-10 Emmanuel Briot + + * prj-util.adb, prj-util.ads (Executable_Of): Take into account the + project's Executable_Suffix. + +2010-09-10 Robert Dewar + + * g-pehage.ads: Minor reformatting + + * gnat_ugn.texi: Clarifying comment on -gnatyc + * exp_ch6.adb (Expand_N_Subprogram_Body): Reset Is_Pure if limited + arguments. + +2010-09-10 Tristan Gingold + + * Make-generated.in (gnat.hlp): New rule. + +2010-09-10 Emmanuel Briot + + * prj-util.adb, prj-util.ads (Executable_Of): New parameter + Include_Suffix. + +2010-09-10 Robert Dewar + + * einfo.adb: Minor code cleanup: Add assertion to + Set_Corresponding_Protected_Entry. + +2010-09-10 Bob Duff + + * g-pehage.ads, g-pehage.adb (Produce): Add a new flag to allow sending + the output to standard output. + +2010-09-09 Vincent Celier + + * gnat_ugn.texi: Add documentation for new gnatmake switch + --create-map-file. + * make.adb (Map_File): New global variable to store the value of switch + --create-map-file. + (Gnatmake): Add switch -M to gnatlink if switch --create-map-file has + been specified. + (Scan_Make_Arg): Recognize switch --create-map-file + * makeutl.ads (Create_Map_File_Switch): New constant string for new + gnatmake and gprbuild switch --create-map-file. + +2010-09-09 Robert Dewar + + * sinput-p.ads: Minor comment update. + +2010-09-09 Arnaud Charlet + + * s-tpobop.adb, s-taenca.adb (Wait_For_Completion_With_Timeout): Reset + Entry_Call.State if needed so that the call is marked as cancelled by + Check_Pending_Actions_For_Entry_Call. + (Timed_Protected_Entry_Call): Adjust calls to Defer/Under_Abort, since + this procedure may be called from a controlled operation + (Initialize/Finalize). + +2010-09-09 Vadim Godunko + + * impunit.adb: Correct spelling of package's name in the comment. + +2010-09-09 Robert Dewar + + * gnatcmd.adb, gnatlink.adb, sem_ch12.adb, sem_eval.adb, sinput-p.adb: + Minor reformatting + +2010-09-09 Robert Dewar + + * impunit.adb: Add entry for a-izteio. + * checks.adb: Add comment. + * debug.adb, exp_disp.adb: Minor reformatting. + * exp_dbug.ads: Minor reformatting throughout (pack block comments). + +2010-09-09 Ed Schonberg + + * sem_eval.adb (Is_Same_Value): Two occurrences of the same + discriminant cannot be assumed to be the same value because they may + refer to bounds of a component of two different instances of a + discriminated type. + +2010-09-09 Gary Dismukes + + * checks.adb (Apply_Arithmetic_Overflow_Check): When converting the + operands of an operator to the type of an enclosing conversion, rewrite + the operator so the conversion can't be flagged as redundant. + Remove useless assignments to Typ and Rtyp. + +2010-09-09 Eric Botcazou + + * gnat_ugn.texi: Fix another long line. + +2010-09-09 Bob Duff + + * sem_warn.adb (Output_Reference_Error): Don't warn for renames read + but never assigned. + +2010-09-09 Matthew Heaney + + * a-convec.adb, a-coinve.adb (Clear, Delete, Delete_Last, Finalize, + Merge, Insert, Insert_Space, Move, Reserve_Capacity, Generic_Sorting, + Replace_Element, Reverse_Elements, Swap): Change exception message to + correctly indicate kind of tampering (cursor or element). + * a-cdlili.adb, a-cidlli.adb (Clear, Delete, Delete_First, Delete_Last, + Merge, Generic_Sorting, Insert, Move, Reverse_Elements, Splice, + Swap_Links, Replace_Element, Swap): Ditto. + * a-coorse.adb, a-ciorse.adb (Include, Replace, Replace_Element): Ditto + * a-coorma.adb, a-ciorma.adb (Include, Replace, Replace_Element): Ditto + * a-coormu.adb, a-ciormu.adb (Replace_Element): Ditto + * a-chtgke.adb (Delete_Key_Sans_Free, Generic_Conditional_Insert, + Generic_Replace_Element): Ditto + * a-chtgop.adb (Clear, Move, Reserve_Capacity): Ditto + * a-cohama.adb, a-cihama.adb (Delete, Include, Replace, + Replace_Element): Ditto. + * a-cohase.adb, a-cihase.adb (Delete, Difference, Intersection, + Symmetric_Difference, Union, Include, Replace): Ditto + +2010-09-09 Ed Schonberg + + * sprint.adb (Write_Id): If the parent node is an expanded name, check + that its entity_or_associated_node is an entity before writing it out. + * exp_disp.adb (Make_Tags); if a type is declared in C++ and has no + constructors, there is no need for a dispatch table pointer because the + table is fully inherited from the C++ code. + +2010-09-09 Thomas Quinot + + * projects.texi: Fix wrong identifiers on package end lines in project + files examples. + * exp_ch6.adb: Minor reformatting. + +2010-09-09 Tristan Gingold + + * gnatcmd.adb, vms_conv.ads: Extract Command_Type. + +2010-09-09 Eric Botcazou + + * gnat_ugn.texi: Fix description of -O3 optimization level. + +2010-09-09 Yannick Moy + + * a-cihama.adb, a-cohama.adb: Fix comments. + +2010-09-09 Arnaud Charlet + + * i-cexten.ads: Add comments. + (Signed_128): New type, used by some C bindings. + * debug.adb: Update comment. + +2010-09-09 Sergey Rybin + + * gnat_ugn.texi: For ASIS tools (gnatpp, gnatcheck, gnatelim, + gnatmetric and gnatstub) add a note that '-gnat05' should be used if + the tool should process Ada 2005 sources. + +2010-09-09 Ed Schonberg + + * sem_ch12.adb (Remove_Parent): If the scope containing the child + instance is a block, examine the enclosing scope to determine if it is + a parent instance. + +2010-09-09 Doug Rupp + + * sem_prag.adb (pragma Ident): Pass --identification= vice + IDENTIFICATION= + * gnatlink.adb (Linker_Options): Look for --identification= vice + IDENTIFICATION= + +2010-09-09 Gary Dismukes + + * exp_attr.adb (Expand_N_Attribute_Reference, case Attribute_Old): When + inserting and analyzing the object declaration for the temporary object + created to hold a 'Old value, push the scope for the subprogram where + the object is inserted, so that its Scope (and that of related objects) + will be set properly. + +2010-09-09 Vincent Celier + + * prj.adb (Get_Object_Directory): Return object directory display name + * adaint.c (__gnat_get_file_names_case_sensitive): When environment + variable GNAT_FILE_NAME_CASE_SENSITIVE has a value of "0" or "1", + return this value, otherwise return the default for the platform. + +2010-09-09 Arnaud Charlet + + * gcc-interface/Makefile.in, gcc-interface/Make-lang.in: Update + dependencies. Remove handling of gnatlbr. + Do not remove s-stratt-xdr for the run-time when installing. + +2010-09-09 Robert Dewar + + * sem_attr.adb: Minor reformatting. + +2010-09-09 Thomas Quinot + + * socket.c (__gnat_socket_ioctl): On Darwin, the req parameter is an + unsigned long, not an int. + +2010-09-09 Vincent Celier + + * make.adb, mlib-prj.adb, prj.adb, prj-nmsc.adb, mlib-tgt.adb, + prj-conf.adb, prj-env.adb: Use Display_Name instead of Name whenever + we are not checking for equality of path or file names. + +2010-09-09 Ed Schonberg + + * exp_util.adb (Remove_Side_Effects): If the expression is a packed + array reference, reset the Analyzed flag so that it is properly + expanded when the resulting object declaration is analyzed. + +2010-09-09 Vincent Celier + + * sinput-p.adb (Source_File_Is_Subunit): Return False if X is + No_Source_File. + +2010-09-09 Ramon Fernandez + + * sysdep.c: The wrSbc8548 BSP in MILS doesn't know anything about the + VX_SPE_TASK option, so disable it. + +2010-09-09 Ed Schonberg + + * sem.adb (Walk_Library_Items): Traverse context of subunits of the + main unit. + (Is_Subunit_Of_Main): Handle null nodes properly. + +2010-09-09 Robert Dewar + + * par-ch2.adb: Update comments. + +2010-09-09 Ben Brosgol + + * gnat_rm.texi: Minor wordsmithing of section on pragma Ordered. + +2010-09-09 Arnaud Charlet + + * par-ch2.adb (Scan_Pragma_Argument_Association): In CodePeer mode, + do not generate an error for compatibility with legacy code. + ignored when generating SCIL. + * sem_attr.adb (Resolve_Attribute): Ignore AI-229 in CodePeer mode. + +2010-09-09 Thomas Quinot + + * s-strxdr.adb, gnat_rm.texi, s-stratt-xdr.adb, s-stratt.ads: Rename + s-strxdr.adb to s-stratt-xdr.adb + +2010-09-09 Robert Dewar + + * ali-util.adb (Obsolescent_Check): Removed. + * gprep.adb (Obsolescent_Check): Removed. + Remove Obsolescent_Check parameter in Scng instantiation + * prj-err.adb (Obsolescent_Check): Removed. + * prj-err.ads (Obsolescent_Check): Removed. + Remove Obsolescent_Check parameter in Scng instantiation + * scans.ads (Based_Literal_Uses_Colon): New flag + * scn.adb (Obsolscent_Check_Flag): Removed + (Obsolscent_Check): Removed + (Set_Obsolescent_Check): Removed + (Post_Scan): Add handling for obsolescent features + * scn.ads (Obsolscent_Check): Removed + (Set_Obsolescent_Check): Removed + (Post_Scan): Can no longer be inlined + Remove Obsolescent_Check from instantiation of Scng + * scng.adb (Nlit): Set Based_Literal_Uses_Colon + (Nlit): Remove handling of obsolescent check + (Scan, case '%'): Remove handling of obsolescent check + (Scan, case '|'): Call Post_Scan + (Scan, case '!'): Remove handling of obsolescent check, call Post_Scan + * scng.ads Remove Obsolescent_Check argument from Scng generic + (Post_Scan): Now called for Tok_Vertical_Bar + * sinput-l.adb: Remove calls to Set_Obsolescent_Check + +2010-09-09 Doug Rupp + + * gnatlbr.adb: Removed. + * gnat_rm.texi, ug_words, gnat_ugn.texi: Remove mention of gnatlbr. + +2010-09-09 Robert Dewar + + * sem_res.adb (Resolve_Type_Conversion): Catch more cases of redundant + conversions. + +2010-09-09 Vincent Celier + + * gnatlbr.adb: Remove redundant conversions. + +2010-09-09 Vincent Celier + + * prj-proc.adb: Minor comment spelling error fix. + * osint.ads (Env_Vars_Case_Sensitive): Use function + Get_Env_Vars_Case_Sensitive, not Get_File_Names_Case_Sensitive to + compute value. + +2010-09-09 Ed Schonberg + + * sem_res.adb (Resolve_Equality_Op): Implement Ada2012 rule for + resolution of conditional expressions whose dependent expressions are + anonymous access types. + +2010-09-09 Robert Dewar + + * a-ststio.adb: Minor code reorganization. + * s-direio.adb, prj.adb, prj-nmsc.adb, sem_type.adb: Remove redundant + conversion. + * types.ads: Minor reformatting. + * binde.adb, vms_conv.adb, gnatls.adb, s-strxdr.adb, uintp.adb: Remove + redundant conversions. + * output.adb: Minor reformatting. + * sem_ch8.adb (Find_Type): Test for redundant base applies to user + types. + * opt.ads: Add pragma Ordered for Verbosity_Level. + * prj.ads: Add pragma Ordered for type Verbosity. + +2010-09-09 Vincent Celier + + * osint.adb (Canonical_Case_File_Name): Use procedure To_Lower in + System.Case_Util + (Canonical_Case_Env_Var_Name): Ditto + +2010-09-09 Bob Duff + + * g-pehage.adb (Allocate): Initialize the allocated elements of IT. + +2010-09-09 Robert Dewar + + * cstand.adb: Mark Boolean and Character types as Ordered + * einfo.adb (Has_Pragma_Ordered): New flag + * einfo.ads (Has_Pragma_Ordered): New flag + * g-calend.ads: Mark Day_Name as Ordered + * opt.ads: Mark Ada_Version_Type as Ordered + (Warn_On_Unordered_Enumeration_Type): New flag + * par-prag.adb: Add procdessing for pragma Ordered + * s-ficobl.ads (Read_File_Mode): New subtype + * s-fileio.adb: Use Read_File_Mode instead of explicit ranges + * s-taskin.ads: Mark Entry_Call_State as ordered + * sem_ch3.adb (Build_Derived_Enumeration_Type): Inherit + Has_Pragma_Ordered. + * sem_ch6.ads: Mark Conformance_Type as Ordered + * sem_prag.adb: Implement pragma Ordered + * sem_res.adb (Bad_Unordered_Enumeration_Reference): New function + (Resolve_Comparison_Op): Diagnose unordered comparison + (Resolve_Range): Diagnose unordered range + * sem_warn.adb (Warn_On_Unordered_Enumeration_Type): New flag (from + -gnatw.u/U) + * snames.ads-tmpl: Add entry for pragma Ordered + * style.ads (Check_Enumeration_Subrange): Removed + * styleg.adb (Check_Enumeration_Subrange): Removed + * styleg.ads (Check_Enumeration_Subrange): Removed + * stylesw.adb: Remove handling of -gnatyE switch + * stylesw.ads: (Style_Check_Enumeration_Subranges): Removed + * vms_data.ads: Remove -gnatyE entries + Add -gnatw.u entries + * ug_words: Entries for -gnatw.u and -gnatw.U + * gnat_ugn.texi: Document -gnatw.u/-gnatw.U switches + * gnat_rm.texi: Document pragma Ordered. + * s-tasren.adb: Avoid unnecessary comparison on unordered enumeration. + * s-tpobop.adb: Remove comparison on unordered enumeration type. + +2010-09-09 Vincent Celier + + * adaint.c: New function __gnat_get_env_vars_case_sensitive, returns 0 + for VMS and Windows, and 1 for all other platforms. + * adaint.h: New function __gnat_get_env_vars_case_sensitive + * osint.ads, osint.adb (Canonical_Case_Env_Var_Name): New procedure. + * prj-ext.adb (Add): Call Canonical_Case_Env_Var_Name instead of + Canonical_Case_File_Name, as we are dealing with environment variables, + not files. + +2010-09-09 Robert Dewar + + * sem_util.adb: Minor reformatting + +2010-09-09 Vincent Celier + + * vms_data.ads: Add documentation for S_Make_Single. + +2010-09-09 Ed Schonberg + + * sem_util.adb (Same_Object): include formal parameters. + +2010-09-09 Vincent Celier + + * make.adb (Queue): New package implementing a new impementation of the + queue, taking into account the new switch --single-compile-per-obj-dir. + * makeutl.ads (Single_Compile_Per_Obj_Dir_Switch): New constant String + for gnatmake and gprbuild new switch --single-compile-per-obj-dir. + * opt.ads (One_Compilation_Per_Obj_Dir): New Boolean flag, defauted to + False. + * switch-m.adb (Scan_Make_Switches): Take into account new gnatmake + switch --single-compile-per-obj-dir. + * vms_data.ads: Add qualifier SINGLE_COMPILE_PER_OBJ_DIR for gnatmake + switch --single-compile-per-obj-dir. + * gnat_ugn.texi: Add documentation for new gnatmake switch + --single-compile-per-obj-dir. + +2010-09-09 Ed Schonberg + + * einfo.adb, einfo.ads: Clarify use of Corresponding_Protected_Entry. + +2010-09-09 Javier Miranda + + * sem_ch3.adb (Is_Progenitor): Relocated to sem_type. + (Replace_Type): Code cleanup. + * sem_type.ads, sem_type.adb (Is_Progenitor): Relocated from sem_ch3 + +2010-09-09 Thomas Quinot + + * exp_ch8.adb: Minor reformatting. + +2010-09-09 Ed Schonberg + + * exp_ch9.adb, einfo.adb, einfo.ads: New attribute + Corresponding_Protected_Entry. + +2010-09-09 Ed Schonberg + + * exp_ch3.adb (Build_Untagged_Equality): Do not set alias of implicit + inequality, it is always rewritten as the negation of the corresponding + equality operation. + * exp_ch8.adb (Expand_N_Subprogram_Renaming): If the subprogram renames + the predefined equality of an untagged record, create a body at the + point of the renaming, to capture the current meaning of equality for + the type. + +2010-09-09 Robert Dewar + + * sem.adb, sem_warn.adb: Minor reformatting. + +2010-09-09 Ed Schonberg + + * sem_ch6.adb: Improve error message on untagged equality. + * sem.adb (Semantics): Include subprogram bodies that act as spec. + +2010-09-09 Javier Miranda + + * sem_ch13.adb, exp_ch13.adb: Undo previous change, unneeded. + +2010-09-09 Robert Dewar + + * sem_ch13.adb, sem_ch6.adb, exp_ch3.adb: Minor reformatting. + +2010-09-09 Robert Dewar + + * einfo.adb (Is_Aggregate_Type): New function. + * einfo.ads (Aggregate_Kind): New enumeration subtype + (Is_Aggregate_Type): New function. + * sem_type.adb (Is_Array_Class_Record_Type): Removed, replaced by + Is_Aggregate_Typea. + +2010-09-09 Robert Dewar + + * exp_ch11.adb, frontend.adb, sem_attr.adb, sem_ch10.adb, sem_ch3.adb, + sem_ch4.adb, sem_ch9.adb, sem_res.adb: Use Restriction_Check_Needed + where appropriate. + * restrict.ads, restrict.adb: Ditto. + (Restriction_Check_Needed): New function + +2010-09-09 Ed Schonberg + + * exp_ch9.ads (Find_Master_Scope): New function, extracted from + Build_Master_Entity, to find the proper scope for the master entity of + a type that may contain tasks, in the presence of transient scopes. + * exp_ch9.adb (Build_Master_Entity) Use new function. + * exp_ch3.adb (Build_Class_Wide_Master): ditto. + +2010-09-09 Vincent Celier + + * prj-attr.adb: Add new attributes Leading_Library_Options and + Linker'Leading_Switches. + * snames.ads-tmpl: Add new standard names Leading_Library_Options and + Leading_Switches. + +2010-09-09 Javier Miranda + + * sem_ch3.adb (Derive_Subprogram): The code that checks if a + dispatching primitive covers some interface primitive is incomplete. + Replace such code by the invocation of a new subprogram that provides + this functionality. + * sem_ch6.ads (Is_Interface_Conformant): Add missing documentation. + * sem_ch6.adb (Check_Missing_Return): Minor reformating + (Check_Convention): Complete if-statement conditition when reporting + errors (to avoid assertion failure). + * sem_ch13.adb (Make_Null_Procedure_Specs): This routine was previously + located in exp_ch3. Relocated inside Analyze_Freeze_Entity. + (Analyze_Freeze_Entity): Invoke routine that adds the spec of non + overridden null interface primitives. + * sem_type.adb (Is_Ancestor): If the parent of the partial view of a + private type is an interface then use the parent of its full view to + climb to its ancestor type. + * sem_disp.ads, sem_disp.adb (Covers_Some_Interface): New subprogram. + (Check_Dispatching_Operation): Extend assertion to handle wrappers of + null interface primitives. + (Is_Null_Interface_Primitive): New subprogram. + * exp_ch3.adb (Make_Null_Procedure_Specs): Removed. + (Expand_Freeze_Record_Type): Do not generate specs of null interface + subprograms because they are now generated by Analyze_Freeze_Entity. + +2010-09-09 Robert Dewar + + * a-calfor.adb, sem_ch3.adb: Minor reformatting. + +2010-09-09 Robert Dewar + + * bindgen.adb (Gen_Restrictions_Ada): Avoid explicit enumeration ranges + (Gen_Restrictions_C): Avoid explicit enumeration ranges + (Set_String_Replace): New procedure + * casing.ads (Known_Casing): New subtype declaration + * prj-attr.ads (All_Case_Insensitive_Associative_Array): New subtype + declaration + * prj-dect.adb (Parse_Attribute_Declaration): Avoid enumeration range + * prj-nmsc.adb (Check_Naming): Avoid unnecessary enumeration range + * prj-strt.adb (Attribute_Reference): Avoid enumeration range test + * prj.adb (Known_Casing): Moved to Casing spec (avoid enum range) + * sem_ch13.adb (Adjust_Record_For_Reverse_Bit_Order): Avoid enumeration + ranges. + * sem_res.adb (Resolve_Range): Check for enumeration subrange style + rule. + * sem_type.adb (Is_Array_Class_Record_Type): New. + * style.ads (Check_Enumeration_Subrange): New procedure + * styleg.adb (Check_Enumeration_Subrange): New procedure + * styleg.ads (Check_Enumeration_Subrange): New procedure + * stylesw.adb Add handling for Style_Check_Enumeration_Subranges + * stylesw.ads (Style_Check_Enumeration_Subranges): New flag + * usage.adb: Add line for -gnatyE + * vms_data.ads: Add entries for [NO]ENUMERATION_RANGES + Add missing entry for NOBOOLEAN_OPERATORS + * gnat_ugn.texi: Add documentation for -gnatyE + +2010-09-09 Robert Dewar + + * namet.adb (Initialize): Is now a dummy procedure + (Reinitialize): New procedure + Call Reinitialize from package initialization + * namet.ads (Initialize): Is now a dummy procedure + (Reinitialize): New procedure + * clean.adb, gnat1drv.adb, gnatbind.adb, gnatcmd.adb, gnatlink.adb, + gnatls.adb, gprep.adb, make.adb, prj-makr.adb: Remove obsolete call to + Namet.Initialize. + +2010-09-09 Bob Duff + + * sem_elab.adb, s-os_lib.ads: Minor comment fixes. + +2010-09-09 Robert Dewar + + * s-bitops.adb (Raise_Error): Add exception message + +2010-09-09 Robert Dewar + + * par-ch5.adb (Test_Statement_Required): Deal with Ada 2012 allowing no + null statement after label. + * sinfo.ads: Minor comment updates. + +2010-09-09 Robert Dewar + + * nlists.ads, nlists.adb (In_Same_List): New function. + Use Node_Or_Entity_Id where appropriate. + * par-labl.adb, sem_ch6.adb, sem_type.adb: Use In_Same_List. + +2010-09-09 Robert Dewar + + * restrict.ads, restrict.adb (Check_Wide_Character_Restriction): New + procedure. + * sem_ch3.adb: Use Check_Wide_Character_Restriction + (Enumeration_Type_Declaration): Check violation of No_Wide_Characters + * sem_ch8.adb (Find_Direct_Name): Check violation of No_Wide_Characters + (Find_Expanded_Name): Check violation of No_Wide_Characters + +2010-09-09 Robert Dewar + + * par-ch5.adb: Minor reformatting. + +2010-09-09 Robert Dewar + + * prj-env.adb: Minor code reorganization. + * par-ch3.adb: Minor reformatting. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-09-09 Ed Schonberg + + * exp_ch9.adb (Build_Activation_Chain_Entity): The construct enclosing + a task declaration can be an entry body. + +2010-09-09 Javier Miranda + + * exp_disp.adb (Make_DT): Decorate as "static" variables containing + tags of library level tagged types. + (Make_Tags): Disable backend optimizations about aliasing for + declarations of access to dispatch tables. + +2010-09-09 Ed Schonberg + + * sem_ch12.adb (Reset_Entity): If the entity is an itype created as a + subtype for a null-excluding access type, recover the original + subtype_mark to get the proper visibility on the original name. + +2010-09-09 Ed Schonberg + + * exp_ch3.adb (Build_Untagged_Equality): For Ada2012, new procedure to + create the primitive equality operation for an untagged record. The + operation is the predefined equality if no record component has a + user-defined equality, or if there is a user-defined equality for the + type as a whole, or when the type is derived and it has an inherited + equality. Otherwise the body of the operations is built as for tagged + types. + (Expand_Freeze_Record_Type): Call Build_Untagged_Equality when needed. + (Make_Eq_Body): New function to create the expanded body of the + equality operation for tagged and untagged records. In both cases the + operation composes, and the primitive operation of each record + component is used to generate the equality function for the type. + * exp_ch4.adb (Expand_Composite_Equality): In Ada2012, if a component + has an abstract equality defined, replace its call with a + Raise_Program_Error. + * sem_ch6.adb (New_Overloaded_Entity): if Ada2012, verify that a + user-defined equality operator for an untagged record type does not + happen after type is frozen, and appears in the visible part if partial + view of type is not limited. + +2010-09-09 Tristan Gingold + + * gnatlbr.adb: Make Create_Directory more portable: use __gnat_mkdir. + +2010-09-09 Bob Duff + + * gnat_ugn.texi: Remove incorrect statement about -E being the default. + +2010-09-09 Pascal Obry + + * gnat_ugn.texi: Update doc on windows related topics. + +2010-09-09 Geert Bosch + + * s-fatgen.adb: Update comments. + +2010-09-09 Robert Dewar + + * par-ch4.adb (Box_Error): New procedure. + +2010-09-09 Thomas Quinot + + * sem.adb: Minor reformatting. + +2010-09-09 Pascal Obry + + * prj-env.adb: Style fix, use /and then/ and /or else/. + * gnat_ugn.texi: Fix typos. + +2010-09-03 Joseph Myers + + PR ada/45499 + * gcc-interface/misc.c (gnat_init_options): Allow options with + empty canonical form. Generate a single save_argv element from -I + options. + +2010-08-30 Eric Botcazou + + * gcc-interface/utils.c (gnat_pushdecl): Remove test for PARM_DECLs. + Attach fake PARM_DECLs to the topmost block of the function. + +2010-08-30 Eric Botcazou + + * gcc-interface/trans.c (call_to_gnu): Also force the return slot opt + for the call to a function whose return type was unconstrained. + +2010-08-30 Olivier Hainque + + * gcc-interface/decl.c (FOREIGN_FORCE_REALIGN_STACK): New macro, + replacement for FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN. + (gnat_to_gnu_entity) : Use it. + +2010-08-21 Eric Botcazou + + * tracebak.c: Fix typo in comment. + +2010-08-20 Nathan Froyd + + * gcc-interface/decl.c: Use FOR_EACH_VEC_ELT. + * gcc-interface/trans.c: Likewise. + * gcc-interface/utils.c: Likewise. + +2010-08-18 Eric Botcazou + + * tracebak.c (i386): Use GCC unwinder on Linux with GCC > 4.5. + +2010-08-10 Robert Dewar + + * sem_ch8.adb, sem_ch8.ads: Change name Write_Scopes to ws. + * sem_util.adb: Minor reformatting. + +2010-08-10 Javier Miranda + + * sem_aggr.adb (Resolve_Extension_Aggregate): Warn on the use of C++ + constructors that leave the object partially initialized. + * exp_atag.ads, exp_atags.adb (Build_Inherit_CPP_Prims): New subprogram + that copies from parent of Typ the dispatch table slots of inherited + C++ primitives. It handles primary and secondary dispatch tables. + * einfo.adb (Related_Type): Moved from Node26 to Node27. Required to + use this attribute with E_Variable entities. + (Set_Is_Tag): Relax assertion to allow its use with variables that + store tags. + (Set_Related_Type): Relax assertion to allow its use with variables + that store the tag of a C++ class. + (Write_26_Field_Name): Remove Related_Type. + (Write_27_Field_Name): Add Related_Type. + * einfo.ads (Related_Type): Moved from Node26 to Node27. Available also + with E_Variable entities. + * sem_prag.adb (CPP_Constructor): Warn on duplicated occurrence of this + pragma. + * sem_util.adb (Search_Tag): Add missing support for CPP types. + (Enclosing_CPP_Parent): New subprogram. + (Has_Suffix): New subprogram. + * sem_util.ads (Enclosing_CPP_Parent): New subprogram that returns the + closest ancestor of a type that is a C++ type. + (Has_Suffix): New subprogram. Used in assertions to check the suffix of + internal entities. + * sem_attr.adb (Analyze_Access_Attribute): Check wrong use of current + instance in derivations of C++ types. + * exp_tss.adb (CPP_Init_Proc): New subprogram. + (Is_CPP_Init_Proc): New subprogram. + (Set_TSS): Handle new C++ init routines. + * exp_tss.ads (TSS_CPP_Init): New TSS name. For initialization of C++ + dispatch tables. + (CPP_Init_Proc): New subprogram. + (Is_CPP_Init_Proc): New subprogram. + * exp_disp.adb (CPP_Num_Prims): New subprogram. + (Has_CPP_Constructors): New subprogram. + (Make_Secondary_DT, Make_DT): For derivations of CPP types, do not + initialize slots located in the C++ part of the dispatch table. + (Make_Tags): For CPP types declare variables used by the IP routine to + store the C++ tag values after the first invocation of the C++ + constructor. + (Build_CPP_Init_DT): New subprogram. + (Set_CPP_Constructors): New implementation that builds an IP for each + CPP constructor. These IP are wrappers of the C++ constructors that, + after the first invocation of the constructor, read the C++ tags from + the object and save them locally. These copies of the C++ tags are used + by the IC routines to initialize tables of Ada derivations of CPP + types. + (Write_DT): Indicate what primitives are imported from C++ + * exp_disp.ads (CPP_Num_Prims): New subprogram. + (Has_CPP_Constructors): New subprogram. + * exp_aggr.adb (Build_Record_Aggr_Code): For derivations of C++ types + invoke the IC routine to inherit the slots of the parents. + * sem_ch13.adb (Analyze_Freeze_Entity): Add new warnings on CPP types. + * exp_ch3.adb (Is_Variable_Size_Array): New subprogram. + (Is_Variable_Size_Record): Factorize code calling + Is_Variable_Size_Array. + (Build_CPP_Init_Procedure): New subprogram that builds the tree + corresponding to the procedure that initializes the C++ part of the + dispatch table of an Ada tagged type that is a derivation of a CPP + type. + (Build_Init_Procedure): Adding documentation plus code reorganization + to leave more clear the construction of the IP with C++ types. + (Expand_Freeze_Record_Type): Delay call to Set_CPP_Constructors because + it cannot be called after Make_Tags has been invoked. + (Inherit_CPP_Tag): Removed. + (Init_Secondary_Tags): For derivations of CPP types, warn on tags + located at variable offset. + * freeze.ads: Minor reformating. + * sem_ch8.adb (Write_Scopes): Add pragma export. Required to have it + available in gdb. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-08-10 Robert Dewar + + * a-chahan.ads: Add comments on handling of obsolescent entries. + * opt.ads: Add Ada_2005 and Ada_2012 renamings for versions. + * restrict.adb (Check_Obsolescent_2005_Entity): New procedure. + * restrict.ads (Check_Obsolescent_2005_Entity): New procedure. + * sem_attr.adb (Analyze_Access_Attribute): Call + Check_Obsolescent_2005_Entity to check for access to obsolescent + Ada.Characters.Handling subprogram. + (Analyze_Attribute, case Class): Applying Class to untagged incomplete + type is obsolescent in Ada 2005. + (Analyze_Attribute, case Constrained): Better placement of flag when + flagged as obsolescent feature. + (Analyze_Attribute, case Storage_Size): Use with tasks is obsolescent + * sem_ch10.adb (Analyze_With_Clause): With of renamings such as Text_IO + is an obsolescent feature. + * sem_ch11.adb (Analyze_Raise_Statement): Numeric_Error is obsolescent + feature. + * sem_ch8.adb (Analyze_Subprogram_Renaming): Call + Check_Obsolescent_2005_Entity to check for renaming obsolete + Ada.Characters.Handling subprogram. + * sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings): Check + for obsolescent restrictions in Ada 2005. + (Analyze_Pragma, case Suppress): Entity arg is obsolescent in Ada 2005 + (Analyze_Pragma, case Interface): Interface is obsolescent in Ada 2005 + * sem_res.adb (Resolve_Call): Call Check_Obsolescent_2005_Entity to + check for obsolescent references to Ada.Characters.Handling subprograms + +2010-08-10 Robert Dewar + + * einfo.adb, einfo.ads: Fix bad -gnatdt output for incomplete type. + +2010-08-10 Robert Dewar + + * errout.ads: Add VMS table entries for 2005, 12, 2012 switches + * par-ch4.adb: Change wording of Ada 2012 messages + * vms_data.ads: Add VMS entries for /2005, /12, /2012 + +2010-08-10 Robert Dewar + + * a-suenco.adb (Convert): Fix bug in UTF-16 to UTF-8 conversion for + codes in the range 16#80#..16#7FF#. + * sem_ch10.adb: Minor reformatting. + +2010-08-10 Arnaud Charlet + + * gnat1drv.adb (Scan_Front_End_Switches): Always perform semantics and + generate ali files in CodePeer mode, so that a gnatmake -c -k will + proceed further when possible + * freeze.adb (Freeze_Static_Object): Fix thinko. Do not generate error + messages when ignoring representation clauses (-gnatI). + +2010-08-10 Ed Schonberg + + * exp_ch4.adb (Expand_N_Selected_Component): Do not attempt to + constant-fold discriminant reference if the constraint is an object + with non-static expression. Expression may contain volatile references + in the presence of renamings. + +2010-08-10 Vincent Celier + + * prj-proc.adb (Get_Attribute_Index): If Index is All_Other_Names, + returns Index. + * prj-strt.adb (Attribute_Reference): Recognize 'others' as a valid + index for an associative array where it is allowed. + +2010-08-10 Thomas Quinot + + * exp_attr.adb: Add comments. + +2010-08-10 Jerome Lambourg + + * adaint.c (__gnat_get_file_names_case_sensitive): return 0 on darwin. + +2010-08-09 Nathan Froyd + + * gcc-interface/utils.c (gnat_poplevel): Use blocks_nreverse. + +2010-08-09 Eric Botcazou + + * gcc-interface/utils.c (build_vms_descriptor32): Fix formatting. + (build_vms_descriptor): Likewise. + +2010-08-08 Nathan Froyd + + * gcc-interface/utils.c (make_descriptor_field): Add tree parameter. + (build_vms_descriptor32): Adjust calls to it for new parameter. + (build_vms_descriptor): Likewise. + +2010-08-08 Nathan Froyd + + * gcc-interface/decl.c (rec_variant): Declare. Declare a VEC of it. + (build_variant_list): Take and return a VEC instead of a tree. + (create_variant_part_from): Take a VEC instead of a tree for + variant_list. Adjust accordingly. + (gnat_to_gnu_entity): Adjust for changes to previous functions. + +2010-08-07 Nathan Froyd + + * gcc-interface/decl.c (gnat_to_gnu_entity): Use XALLOCAVEC instead + of alloca. + (components_to_record): Likewise. + * gcc-interface/trans.c (gnat_to_gnu): Likewise. + * gcc-interface/utils.c (max_size): Likewise. + (build_vms_descriptor32): Likewise. + (build_vms_descriptor): Likewise. + +2010-08-07 Nathan Froyd + + * gcc-interface/decl.c (subst_pair): Declare. Declare a VEC of it. + (build_subst_list): Return a VEC instead of a tree. + (build_variant_list): Take a VEC for subst_list. Adjust + accordingly. + (create_field_decl_from): Likewise. + (create_variant_part_from): Likewise. + (copy_and_substitute_in_size): Likewise. + (gnat_to_gnu_entity): Adjust for new interface to build_subst_list. + Free the built vector. + +2010-08-06 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Do not build an + allocator for large imported objects. + +2010-08-05 Robert Dewar + + * gnat1drv.adb: Minor reformatting. + +2010-08-05 Ed Schonberg + + * sem.adb (Do_Unit_And_Dependents): If some parent unit is an + instantiation, process its body before the spec of the main unit, + because it may contain subprograms invoked in the spec of main. + * einfo.ads: Add documention of delayed freeze. + +2010-08-05 Vincent Celier + + * prj-nmsc.adb (Process_Linker): Take into account new values for + attribute Response_File_Format. + * prj.ads (Response_File_Format): New enumeration values GCC_GNU, + GCC_Object_List and GCC_Option_List. + +2010-08-05 Ed Schonberg + + * exp_ch4.adb (Expand_N_Selected_Component): Do not constant-fold a + selected component that denotes a discriminant if it is the + discriminant of a component of an unconstrained record type. + +2010-08-05 Ed Schonberg + + * exp_util.adb (Insert_Actions): If the action appears within a + conditional expression that is already analyzed, insert action further + out. + +2010-08-05 Robert Dewar + + * exp_ch4.adb: Minor reformatting. + +2010-08-05 Thomas Quinot + + * exp_ch4.adb: Minor reformatting + * gnat1drv.adb: Minor reformatting. + Minor code reorganization (use Nkind_In). + +2010-08-05 Ed Schonberg + + * exp_util.ads, exp_util.adb (Needs_Constant_Address): New predicate to + determine whether the expression in an address clause for an + initialized object must be constant. Code moved from freeze.adb. + (Remove_Side_Effects): When the temporary is initialized with a + reference, indicate that the temporary is a constant as done in all + other cases. + * freeze.adb (Check_Address_Clause): use Needs_Constant_Address. + * exp_ch13.adb (Expand_N_Attribute_Definition_Clause, case 'Address): + If object does not need a constant address, remove side effects from + address expression, so it is elaborated at the point of the address + clause and not at the freeze point of the object, so that elaboration + order is respected. + +2010-08-05 Vincent Celier + + * prj.adb (Is_Compilable): Return False for header files of non Ada + languages. + +2010-08-05 Emmanuel Briot + + * prj-nmsc.adb: The Missing_Source_Files flag also considers a missing + exec directory as a warning rather than an error. + +2010-08-05 Thomas Quinot + + * sem_ch6.adb, gnat1drv.adb, exp_ch6.adb, sem_eval.adb: Minor + reformatting. + +2010-08-05 Steve Baird + + * exp_util.adb (Remove_Side_Effects): An access value which designates + a volatile object of a nonvolatile type is prohibited. + Do not call Make_Reference to construct a reference to such an object. + +2010-08-05 Robert Dewar + + * a-suezse.adb, a-suezse.ads, a-suezen.adb, a-suezen.ads: Removed. + * a-suewse.adb, a-suewse.ads, a-suesen.adb, a-suesen.ads, + a-suewen.adb, a-suewen.ads: New files. + * Makefile.rtl, impunit.adb: Update implementation of Ada 2012 string + encoding packages. + * sem_elab.adb: Minor reformatting. + +2010-08-05 Arnaud Charlet + + * sem_ch8.adb (Use_One_Type): Protect against empty scopes. + * exp_util.adb (Component_May_Be_Bit_Aligned): Prevent assert failure + in case of null Comp. + +2010-08-05 Robert Dewar + + * errout.adb, a-suewen.adb, a-suezen.adb: Minor reformatting. + +2010-08-05 Gary Dismukes + + * sem_ch4.adb (Analyze_Allocator): Flag errors on allocators of a + nested access type whose designated type has tasks or is a protected + object when the restrictions No_Task_Hierarchy or + No_Local_Protected_Objects apply. Add ??? comment. + * sem_ch9.adb (Analyze_Protected_Type): Give a warning when a protected + type is not a library-level type and No_Local_Protected_Objects applies. + (Analyze_Task_Type): Give a warning when a task type is not a + library-level type and No_Task_Hierarchy applies. + +2010-08-05 Arnaud Charlet + + * sem.adb: Minor reformatting + * sem_ch4.adb (Analyze_Reference): Disable error message in CodePeer + mode, not useful. + +2010-08-04 Eric Botcazou + + * gcc-interface/decl.c: Do not undefine IN_GCC_FRONTEND and do not + include expr.h. + (gnat_to_gnu_entity) : Force address of -1 at the tree level + for the debug-only entity. + * gcc-interface/Make-lang.in (ada/decl.o): Adjust dependencies. + +2010-08-03 Joseph Myers + + * gcc-interface/lang-specs.h: Don't pass -a options. + +2010-07-28 Joseph Myers + + * gcc-interface/misc.c (gnat_init_options): Ignore erroneous + options. Check canonical_option_num_elements on options copied. + +2010-07-27 Joseph Myers + + * gcc-interface/misc.c (gnat_handle_option): Update prototype and + return value type. Don't check for missing arguments here. + +2010-07-27 Joseph Myers + + * gcc-interface/misc.c (gnat_option_lang_mask): New. + (gnat_init_options): Update prototype. Reconstruct argv array + from decoded options. + +2010-07-23 Eric Botcazou + + * gcc-interface/utils.c (update_pointer_to): In the unconstrained array + case, merge the alias set of the old pointer type. + +2010-07-23 Eric Botcazou + + * gcc-interface/utils.c (gnat_types_compatible_p): Revert latest change + and recurse only for multidimensional array types instead. + +2010-07-22 Eric Botcazou + + PR ada/44892 + * gcc-interface/utils.c (convert): Fix thinko in test. + (unchecked_convert): When converting from a scalar type to a type with + a different size, pad to have the same size on both sides. + +2010-07-22 Eric Botcazou + + * gcc-interface/utils.c (gnat_types_compatible_p): Don't require strict + equality for the component type of array types. + +2010-07-15 Nathan Froyd + + * gcc-interface/decl.c: Carefully replace TREE_CHAIN with DECL_CHAIN. + * gcc-interface/trans.c: Likewise. + * gcc-interface/utils.c: Likewise. + * gcc-interface/utils2.c: Likewise. + +2010-07-13 Laurent GUERBY + + PR bootstrap/44458 + * gcc-interface/targtyps.c: Include tm_p.h. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-07-09 Eric Botcazou + + * gcc-interface/trans.c (gnat_gimplify_expr) : Deal with + CALL_EXPR. + +2010-07-08 Manuel López-Ibáñez + + * gcc-interface/utils.c: Include diagnostic-core.h in every file + that includes toplev.h. + +2010-07-03 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : + Branch to common code handling the alignment of discrete types. + : Likewise. + : Likewise. + +2010-07-02 Eric Botcazou + + * gcc-interface/misc.c (gnat_handle_option): Do not populate gnat_argv. + (gnat_handle_option): Allocate only one element for gnat_argv. + (gnat_init): Do not populate gnat_argv. + +2010-06-30 Manuel López-Ibáñez + + * gcc-interface/trans.c: Do not include tree-flow.h. + * gcc-interface/Make-lang.in: Adjust dependencies. + +2010-06-29 Nathan Froyd + + * gcc-interface/gigi.h (gnat_build_constructor): Take a VEC instead + of a TREE_LIST. Update comment. + * gcc-interface/trans.c (gigi): Build a VEC instead of a TREE_LIST. + Adjust call to gnat_build_constructor. + (Attribute_to_gnu): Likewise. + (gnat_to_gnu): Likewise. + (pos_to_constructor): Likewise. + (extract_values): Likewise. + * gcc-interface/utils.c (build_template): Likewise. + (convert_vms_descriptor64): Likewise. + (convert_vms_descriptor32): Likewise. + (convert_to_fat_pointer): Likewise. + (convert): Likewise. + (unchecked_convert): Likewise. + * gcc-interface/decl.c (gnat_to_gnu_entity): Likewise. + * gcc-interface/utils2.c (build_allocator): Likewise. + (fill_vms_descriptor): Likewise. + (gnat_build_constructor): Take a VEC instead of a TREE_LIST. + (compare_elmt_bitpos): Adjust for parameters being constructor_elts + instead of TREE_LISTs. + +2010-06-28 Steven Bosscher + + * gcc-interface/misc.c: Do not include except.h. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-27 Eric Botcazou + + * gcc-interface/trans.c: Include tree-flow.h. + (gnu_switch_label_stack): Delete. + (Case_Statement_to_gnu): Do not emit the goto at the end of a case if + its associated block cannot fall through. Do not emit the final label + if no cases branch to it. + * gcc-interface/Make-lang.in (ada/trans.o): Add $(TREE_FLOW_H). + +2010-06-23 Thomas Quinot + + * exp_attr.adb (Expand_Access_To_Protected_Op): When rewriting a + reference to a protected subprogram outside of the protected's scope, + ensure the corresponding external subprogram is frozen before the + reference. + +2010-06-23 Ed Schonberg + + * sem_prag.adb: Fix typo in error message. + * sem.adb: Refine previous change. + +2010-06-23 Robert Dewar + + * impunit.adb, a-suewen.adb, a-suewen.ads, a-suenco.adb, a-suenco.ads, + a-suezen.adb, a-suezen.ads, a-stuten.adb, a-stuten.ads, Makefile.rtl: + Implement Ada 2012 string encoding packages. + +2010-06-23 Arnaud Charlet + + * a-stwiun-shared.adb, a-stwiun-shared.ads, a-stzunb-shared.adb, + a-stzunb-shared.ads, a-swunau-shared.adb, a-swuwti-shared.adb, + a-szunau-shared.adb, a-szuzti-shared.adb, a-strunb-shared.adb, + a-strunb-shared.ads, a-stunau-shared.adb, a-suteio-shared.adb: New + files. + * gcc-interface/Makefile.in: Enable use of above files. + +2010-06-23 Ed Schonberg + + * sem_ch13.adb (Check_Constant_Address_Clauses): Do not check legality + of address clauses if if Ignore_Rep_Clauses is active. + * freeze.adb (Check_Address_Clause): If Ignore_Rep_Clauses is active, + remove address clause from tree so that it does not reach the backend. + +2010-06-23 Arnaud Charlet + + * exp_attr.adb (Expand_N_Attribute_Reference [Attribute_Valid]): Do not + expand 'Valid from user code in CodePeer mode, will be handled by the + back-end directly. + +2010-06-23 Bob Duff + + * g-comlin.ads: Minor comment improvements. + +2010-06-23 Ed Schonberg + + * sem_res.adb (Uses_SS): The expression that initializes a controlled + component of a record type may be a user-defined operator that is + rewritten as a function call. + +2010-06-23 Bob Duff + + * g-comlin.ads, sem_ch13.adb: Minor comment fix. + +2010-06-23 Eric Botcazou + + * exp_ch11.adb (Expand_Local_Exception_Handlers): Propagate the end + label to the new sequence of statements. Set the sloc of the raise + statement onto the new goto statements. + +2010-06-23 Robert Dewar + + * a-stuten.ads, a-stuten.adb: New files. + * impunit.adb: Add engtry for Ada.Strings.UTF_Encoding (a-stuten.ads) + * Makefile.rtl: Add entry for a-stuten (Ada.Strings.UTF_Encoding) + +2010-06-23 Robert Dewar + + * gnat_ugn.texi: Add documentation of -gnat12 switch + Add documentation of -gnatX switch. + +2010-06-23 Ed Schonberg + + * inline.ads: Include the current Ada_Version in the info for pending + instance bodies, so that declaration and body are compiled with the + same Ada_Version. + * inline.adb: Move with_clause for Opt to spec. + * sem_ch12.adb (Analyze_Package_Instantiation, + Analyze_Subprogram_Instantiation): Save current Ada_Version in + Pending_Instantiation information. + (Instantiate_Package_Body, Instantiate_Subprogram_Body, + Inline_Package_Body): Use the Ada_Version present in the body + information. + +2010-06-23 Robert Dewar + + * usage.adb: Add documentation for -gnat12 switch. + * errout.ads: Add VMS alias entry for -gnat12 switch + * gnat_rm.texi: Add documentation for pragma Ada_12 and Ada_2012 + Add documentation for pragma Extensions_Allowed. + * opt.ads: Add entry for Ada 2012 mode. + * sem_ch4.adb, par-ch3.adb, par-ch4.adb: Use new Ada 2012 mode for 2012 + features. + * sem_prag.adb, par-prag.adb: Add processing for pragma Ada_12 and + Ada_2012. + * sem_ch13.adb: Add handling for Ada 2012 mode. + * snames.ads-tmpl: Add entries for pragma Ada_2012 and Ada_12. + * switch-c.adb: Add handling for -gnat12 switch. + Implement -gnat2005 and -gnat2012. + * usage.adb: Add documentation for -gnat12 switch. + * vms_data.ads: Add /12 switch for Ada 2012 mode. + +2010-06-23 Arnaud Charlet + + * exp_ch4.adb (Expand_N_Allocator): Fix potential crash when using + No_Task_Hierarchy restriction. Add comment. + * exp_ch9.adb, exp_ch3.adb: Update comments. + +2010-06-23 Robert Dewar + + * sem_ch5.adb (Process_Bounds): Remove some junk initializations. + * sem_res.adb: Add comments. + * sem_util.adb: Minor reformatting. Add comments. + Change increment on Actuals_In_Call table. + * opt.ads: Minor: add 'constant'. + +2010-06-23 Javier Miranda + + * exp_disp.adb (Make_DT): Initialize the Size_Func component of the + TSD to Null_Address if No_Dispatching_Calls is active. + +2010-06-23 Vincent Celier + + * a-comlin.ads: Indicate that use of this package is not supported + during the elaboration of an auto-initialized Stand-Alone Library. + +2010-06-23 Ed Schonberg + + * exp_util.adb (Is_Possibly_Misaligned_Object): Do not rely on an + alignment clause on a record type to determine if a component may be + misaligned. The decision must be taken in the back-end where target + alignment information is known. + +2010-06-23 Arnaud Charlet + + * gnat1drv.adb (Adjust_Global_Switches): Enable some restrictions + systematically in CodePeer mode to simplify generated code. + * restrict.adb (Check_Restriction): Do nothing in CodePeer mode. + * exp_ch4.adb (Expand_N_Allocator): Generate proper code when + No_Task_Hierarchy is set instead of crasshing. + +2010-06-23 Thomas Quinot + + * sem_util.adb: Minor code cleanup: test for proper entity instead of + testing just Chars attribute when checking whether a given scope is + System. + * exp_ch4.adb, einfo.adb: Minor reformatting. + +2010-06-23 Vincent Celier + + PR ada/44633 + * switch-m.adb (Normalize_Compiler_Switches): Take into account + switches -gnatB, -gnatD=nn, -gnatG (incuding -gnatG=nn), -gnatI, + -gnatl=file, -gnatS, -gnatjnn, -gnateI=nn and -gnatWx. + +2010-06-23 Ed Schonberg + + * sem_res.adb (Resolve_Membership_Op): If left operand is a mixed mode + operation with a universal real operand, and the right operand is a + range with universal bounds, find unique fixed point that may be + candidate, and warn appropriately. + +2010-06-23 Ed Schonberg + + * sem_res.adb (Resolve_Intrinsic_Operator): Add guards to handle + properly the rare cases where VMS operators are visible through + Extend_System, but the default System is being used and Address is a + private type. + * sem_util.adb: Widen predicate Is_VMS_Operator. + +2010-06-23 Vincent Celier + + * switch-m.adb (Normalize_Compiler_Switches): Take into account -gnatC + and -gnateS. + +2010-06-23 Olivier Hainque + + * einfo.adb (Has_Foreign_Convention): Consider Intrinsic with + Interface_Name as foreign. These are GCC builtin imports for + which Ada specific processing doesn't apply. + +2010-06-23 Thomas Quinot + + * sem_ch12.adb: Minor reformatting. + +2010-06-23 Ed Schonberg + + * sem_util.adb (Is_VMS_Operator): Use scope of system extension to + determine whether an intrinsic subprogram is VMS specific. + +2010-06-23 Hristian Kirtchev + + * treepr.adb (Print_Entity_Info): Output the contents of Field28 if it + is present in the entity. + +2010-06-23 Arnaud Charlet + + * xr_tabls.adb, xref_lib.adb: Update to latest lib-xref.ads + Fix handling of parameters. + Add protection against unexpected cases. + * sem_ch6.adb (Create_Extra_Formals): Use suffix "L" instead of "A" for + access level, since "A" suffix is already used elsewhere. Similarly, + use suffix "O" instead of "C" for 'Constrained since "C" suffix is used + for xxx'Class. + +2010-06-23 Thomas Quinot + + * sem_util.adb, sem_util.ads: Minor reformatting. + +2010-06-23 Vincent Celier + + * prj.ads (Gprclean_Flags.Missing_Source_Files): Set to Error to keep + the previous behavior of gprclean when there are missing files. + +2010-06-23 Ed Schonberg + + * sem_ch12.adb (Load_Body_Of_Generic): In CodePeer mode, a missing + generic body is not a fatal error. + (Mark_Context): Handle properly names of child units. + * sem.adb (Walk_Library_Items.Do_Action): Remove assertion on + instantiations. + +2010-06-23 Vincent Celier + + * ali.adb (Scan_ALI): When ignoring R lines, do not skip the next + non-empty line. + +2010-06-23 Bob Duff + + * g-pehage.ads, g-pehage.adb: Switch default optimization mode to + Memory_Space, because CPU_Time doesn't seem to provide any significant + speed advantage in practice. Cleanup: Get rid of constant + Default_Optimization; doesn't seem to add anything. Use case + statements instead of if statements; seems cleaner. + +2010-06-23 Olivier Hainque + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Use + Wshadow instead of Wextra to guard warning on absence of internal + builtin decl for an import. Fix use of quote in warning text. + (intrin_arglists_compatible_p): Remove processing of integer trailing + args on the Ada side. Fix use of literal > in warning text. + (intrin_return_compatible_p): Never warn on "function imported as + procedure". Defer the void/void case to the common type compatibility + check. + (gnat_to_gnu_param): Use void_ptr GCC type for System.Address argument + of GCC builtin imports. + +2010-06-23 Olivier Hainque + + * gcc-interface/decl.c (intrin_types_incompatible_p): New function, + helper for ... + (intrin_arglists_compatible_p, intrin_return_compatible_p): New + functions, helpers for ... + (intrin_profiles_compatible_p): New function, replacement for ... + (compatible_signatures_p): Removed. + (gnat_to_gnu_entity) : If -Wextra, warn on + attempt to bind an unregistered builtin function. When we have + one, use it and warn on profile incompatibilities. + +2010-06-23 Arnaud Charlet + + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-23 Ed Schonberg + + * sem_util.adb (Mark_Coextensions): If the expression in the allocator + for a coextension in an object declaration is a concatenation, treat + coextension as dynamic. + +2010-06-23 Javier Miranda + + * sem_ch3.adb (Add_Internal_Interface_Entities): Ensure that the + internal entities are added to the scope of the tagged type. + (Derive_Subprograms): Do not stop derivation when we find the first + internal entity that has attribute Interface_Alias. After the change + done to Override_Dispatching_Operations it is no longer true that + these primirives are always located at the end of the list of + primitives. + * einfo.ads (Primitive_Operations): Add documentation. + * exp_disp.adb (Write_DT): Improve output adding to the name of the + primitive a prefix indicating its corresponding tagged type. + * sem_disp.adb (Override_Dispatching_Operations): If the overridden + entity covers the primitive of an interface that is not an ancestor of + this tagged type then the new primitive is added at the end of the list + of primitives. Required to fulfill the C++ ABI. + +2010-06-23 Javier Miranda + + * atree.ads (Set_Reporting_Proc): New subprogram. + * atree.adb: Remove dependency on packages Opt and SCIL_LL. + (Allocate_Initialize_Node, Replace, Rewrite): Replace direct calls + to routines of package Scil_ll by indirect call to the registered + subprogram. + (Set_Reporting_Proc): New subprogram. Used to register a subprogram + that is invoked when a node is allocated, replaced or rewritten. + * scil_ll.adb (Copy_SCIL_Node): New routine that takes care of copying + the SCIL node. Used as argument for Set_Reporting_Proc. + (Initialize): Register Copy_SCIL_Node as the reporting routine that + is invoked by atree. + +2010-06-23 Thomas Quinot + + * sem_ch3.ads: Minor reformatting. + +2010-06-23 Ed Schonberg + + * sem_ch12.adb (Analyze_Package_Instantiation): In CodePeer mode, + always analyze the generic body and instance, because it may be needed + downstream. + (Mark_Context): Prepend the with clauses for needed generic units, so + they appear in a better order for CodePeer. + * sem_util.adb, sem_util.ads: Prototype code for AI05-0144. + +2010-06-23 Emmanuel Briot + + * prj.ads, prj-nmsc.adb (Error_Or_Warning): New subprogram. + +2010-06-23 Robert Dewar + + * g-pehage.adb, exp_ch13.adb: Minor reformatting. + +2010-06-23 Thomas Quinot + + * a-tags.ads: Fix description of TSD structure. + +2010-06-23 Ed Schonberg + + * sem_ch12.adb (Mark_Context): When indicating that the body of a + generic unit is needed prior to the unit containing an instantiation, + search recursively the context of the generic to add other generic + bodies that may be instantiated indirectly through the current instance. + +2010-06-23 Robert Dewar + + * freeze.adb: Minor reformatting. + +2010-06-23 Bob Duff + + * g-pehage.adb (Trim_Trailing_Nuls): Fix the code to match the comment. + +2010-06-23 Vincent Celier + + * make.adb (Compile_Sources): Complete previous change. + +2010-06-23 Ed Schonberg + + * sem_ch6.adb (Add_Extra_Formal): Use suffix "C" in the name of the + Constrained extra formal. + +2010-06-23 Ed Schonberg + + * exp_ch13.adb (Expand_Freeze_Actions): If validity checks and + Initialize_Scalars are enabled, compile the generated equality function + for a composite type with full checks enabled, so that validity checks + are performed on individual components. + +2010-06-23 Emmanuel Briot + + * prj.adb, prj.ads, prj-nmsc.adb (Processing_Flags): New flag + Missing_Source_Files. + +2010-06-23 Robert Dewar + + * exp_ch3.adb, exp_util.adb: Minor reformatting. + +2010-06-23 Jose Ruiz + + * a-reatim.adb, a-retide.adb: Move the initialization of the tasking + run time from Ada.Real_Time.Delays to Ada.Real_Time. This way, calls to + Clock (without delays) use a run time which is properly initialized. + +2010-06-23 Vincent Celier + + * make.adb: Do not set Check_Readonly_Files when setting Must_Compile, + when -f -u and a main is specified on the command line. However, + attempt to compile even when the ALI file is read-only when + Must_Compile is True. + +2010-06-23 Thomas Quinot + + * checks.adb, g-pehage.adb, cstand.adb: Minor code factorization. + +2010-06-23 Javier Miranda + + * sem_ch3.adb (Add_Internal_Interface_Entities): Generate internal + entities for parent types that are interfaces. Needed in generics to + handle formals that implement interfaces. + (Derive_Subprograms): Add assertion for derivation of tagged types that + do not cover interfaces. For generics, complete code that handles + derivation of type that covers interfaces because the previous + condition was weak (it required only name consistency; arguments were + not checked). Add new code to locate primitives covering interfaces + defined in generic units or instantiatons. + * sem_util.adb (Has_Interfaces): Add missing support for derived types. + * sem_ch6.adb (Check_Overriding_Indicator): Minor code cleanups. + * exp_disp.adb (Make_Select_Specific_Data_Table): Skip primitives of + interfaces that are parents of the type because they share the primary + dispatch table. + (Register_Primitive): Do not register primitives of interfaces that + are parents of the type. + * sem_ch13.adb (Analyze_Freeze_Entity): Add documentation. + * exp_cg.adb (Write_Type_Info): When displaying overriding of interface + primitives skip primitives of interfaces that are parents of the type. + +2010-06-23 Ed Schonberg + + * sem_attr.adb (Eval_Attribute): If the prefix is an array, the + attribute cannot be constant-folded if an index type is a formal type, + or is derived from one. + * checks.adb (Determine_Range): ditto. + +2010-06-23 Arnaud Charlet + + * gnat_ugn.texi, gnatxref.adb: Add support for --ext switch. + +2010-06-23 Bob Duff + + * g-pehage.ads, g-pehage.adb (Put): Fix off-by-one bug. + (Insert): Disallow nul characters. + (misc output routines): Assert no nul characters. + +2010-06-23 Ed Schonberg + + * exp_ch4.adb: Use predefined unsigned type in all cases. + +2010-06-23 Bob Duff + + * s-rannum.adb (Reset): Avoid overflow in calculation of Initiator. + * g-pehage.ads: Minor comment fixes. + * g-pehage.adb: Minor: Add some additional debugging printouts under + Verbose flag. + +2010-06-23 Robert Dewar + + * binde.adb (Better_Choice): Always prefer Pure/Preelab. + (Worse_Choice): Always prefer Pure/Preelab. + +2010-06-23 Vincent Celier + + * a-reatim.adb: Call System.OS_Primitives.Initialize during elaboration + +2010-06-23 Robert Dewar + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Properly handle + checking returns in generic case. + (Check_Missing_Return): New procedure. + +2010-06-23 Robert Dewar + + * bindgen.adb, switch-b.adb: Minor reformatting. + +2010-06-23 Javier Miranda + + * frontend.adb (Frontend): Add call to initialize the new package + SCIL_LL. + * exp_ch7.adb (Wrap_Transient_Expression): Remove call to + Adjust_SCIL_Node. + (Wrap_Transient_Statement): Remove call to Adjust_SCIL_Node. + * sem_ch5.adb (Analyze_Iteration_Scheme.Process_Bounds): Remove call to + Adjust_SCIL_Node. + * exp_util.adb (Insert_Actions): Remove code for + N_SCIL_Dispatch_Table_Object_Init and N_SCIL_Tag_Init nodes. + (Remove_Side_Effects): Remove calls to Adjust_SCIL_Node. + * sinfo.adb (SCIL_Entity, SCIL_Tag_Value): Remove checks on + N_SCIL_Tag_Init and N_SCIL_Dispatch_Table_Object_Init in the assertion. + (SCIL_Related_Node, Set_SCIL_Related_Node): Removed. + * sinfo.ads (SCIL_Related_Node): Field removed. + (N_SCIL_Dispatch_Table_Object_Init): Node removed. + (N_SCIL_Tag_Init): Node removed. + * sem_scil.ads, sem_scil.adb (Adjust_SCIL_Node): Removed. + (Check_SCIL_Node): New implementation. + (Find_SCIL_Node): Removed. + * sem.adb (Analyze): Remove management of + N_SCIL_Dispatch_Table_Object_Init and N_SCIL_Tag_Init nodes. + * sem_util.adb (Insert_Explicit_Dereference): Remove call to + Adjust_SCIL_Node. + * exp_ch4.adb (Expand_N_In): Code cleanup: remove call to + Set_SCIL_Related_Node and avoid adding the SCIL node before the + referenced node using Insert_Action because this is not longer + required. + (Expand_Short_Circuit_Operator): Remove call to SCIL node. + * exp_ch6.adb (Expand_Call): Remove call to Adjust_SCIL_Node. + * sem_ch4.adb (Analyze_Type_Conversion): Remove call to + Adjust_SCIL_Node. + * exp_disp.adb (Expand_Dispatching_Call): Minor code reorganization + because we no longer require to generate the SCIL node before the call. + (Make_DT): Remove generation of SCI_Dispatch_Table_Object_Init node. + Remove calls to Set_SCIL_Related_Node and avoid adding the SCIL + nodes before the referenced node using Insert_Action because this + is not longer required. + * atree.adb (Allocate_Initialize_Node, Replace, Rewrite): Add call to + update the SCIL_Node field. + * sprint.adb (Sprint_Node_Actual): Remove code for + N_SCIL_Dispatch_Table_Object_Init and N_SCIL_Tag_Init nodes. + * treepr.adb (Print_Node): Print the SCIL node field (if available). + * exp_ch3.adb (Build_Init_Procedure): Remove generation of + SCIL_Tag_Init nodes. + * scil_ll.ads, scil_ll.adb: New files. + * gcc-interface/Makefile.in, gcc-interface/Make-lang.in: Update + dependencies. + +2010-06-23 Robert Dewar + + * sem_ch6.adb: Minor reformatting. + +2010-06-23 Doug Rupp + + * bindusg.adb (Display): Write -Hnn line. + * bindgen.adb (Gen_Adainit_Ada): Write Heap_Size to binder file as + necessary. + * init.c (__gl_heap_size): Rename from __gl_no_malloc_64 and change + valid values to 32 and 64. + (GNAT$NO_MALLOC_64): Recognize TRUE, 1, FALSE, and 0 in addition to + ENABLE, DISABLE as valid settings. + * switch-b.adb (Scan_Binder_Switches): Process -Hnn switch. + * opt.ads (Heap_Size): New global variable. + * gcc-interface/utils2.c (maybe_wrap_malloc): Remove mostly redundant + TARGET_MALLOC64 check. Fix comment. + +2010-06-23 Robert Dewar + + * sem_ch6.adb, exp_ch4.adb, s-rannum.ads, sem.adb, sem_ch12.adb: Minor + reformatting. Add comments. + * errout.adb (Finalize): Properly adjust warning count when deleting + continuations. + +2010-06-22 Robert Dewar + + * errout.adb (Finalize): Set Prev pointers. + (Finalize): Delete continuations for deletion by warnings off(str). + * erroutc.ads: Add Prev pointer to error message structure. + +2010-06-22 Ed Schonberg + + * sem.adb (Do_Unit_And_Dependents): If the spec of the main unit is a + child unit, examine context of parent units to locate instantiated + generics whose bodies may be needed. + * sem_ch12.adb: (Mark_Context): if the enclosing unit does not have a + with_clause for the instantiated generic, examine the context of its + parents, to set Withed_Body flag, so that it can be visited earlier. + * exp_ch4.adb (Expand_N_Op_Not): If this is a VMS operator applied to + an unsigned type, use a type of the proper size for the intermediate + value, to prevent alignment problems on unchecked conversion. + +2010-06-22 Geert Bosch + + * s-rannum.ads Change Generator type to be self-referential to allow + Random to update its argument. Use "in" mode for the generator in the + Reset procedures to allow them to be called from the Ada.Numerics + packages without tricks. + * s-rannum.adb: Use the self-referencing argument to get write access + to the internal state of the random generator. + * a-nudira.ads: Make Generator a derived type of + System.Random_Numbers.Generator. + * a-nudira.adb: Remove use of 'Unrestricted_Access. + Put subprograms in alpha order and add headers. + * g-mbdira.ads: Change Generator type to be self-referential. + * g-mbdira.adb: Remove use of 'Unrestricted_Access. + +2010-06-22 Robert Dewar + + * freeze.adb: Minor reformatting + Minor code reorganization (use Nkind_In and Ekind_In). + +2010-06-22 Bob Duff + + * gnat1drv.adb (Gnat1drv): Remove the messages that recommend using + -gnatc when a file is compiled that we cannot generate code for, not + helpful and confusing. + +2010-06-22 Vincent Celier + + * switch-m.adb (Normalize_Compiler_Switches): Process correctly + switches -gnatknn. + +2010-06-22 Paul Hilfinger + + * s-rannum.adb: Replace constants with commented symbols. + * s-rannum.ads: Explain significance of the initial value of the data + structure. + +2010-06-22 Ed Schonberg + + * a-ngcoty.adb: Clarify comment. + +2010-06-22 Gary Dismukes + + * exp_pakd.adb (Expand_Bit_Packed_Element_Set): Return without + expansion for indexing packed arrays with small power-of-2 component + sizes when the target is AAMP. + (Expand_Packed_Element_Reference): Return without expansion for + indexing packed arrays with small power-of-2 component sizes when the + target is AAMP. + +2010-06-22 Geert Bosch + + * exp_ch4.adb (Expand_N_In): Do not substitute a valid check for X in + Float'Range. + +2010-06-22 Robert Dewar + + * g-mbdira.adb, g-mbflra.adb, a-nuflra.adb, a-nudira.adb: Minor comment + updates. + +2010-06-22 Doug Rupp + + * system-vms.ads, system-vms-zcx.ads: Remove old unused VMS system + packages. + * system-vms_64.ads, system-vms-ia64.ads: Minor reformatting. + (pragma Ident): Add a default ident string in the private part. + +2010-06-22 Robert Dewar + + * cstand.adb: Minor reformatting. + +2010-06-22 Ed Schonberg + + * freeze.adb (Build_And_Analyze_Renamed_Body): For expansion purposes, + recognize the Shift and Rotation intrinsics that are known to the + compiler but have no interface name. + +2010-06-22 Geert Bosch + + * a-ngcoty.adb ("*"): Rewrite complex multiplication to use proper + scaling in case of overflow or NaN results. + +2010-06-22 Robert Dewar + + * cstand.adb: Complete previous change. + * g-dirope.ads: Add comment. + * s-stchop.adb, sfn_scan.adb: Minor reformatting. + +2010-06-22 Ed Schonberg + + * cstand.adb: Add tree nodes for pragma Pack on string types. + +2010-06-22 Javier Miranda + + * einfo.ads, einfo.adb (Last_Formal): New synthesized attribute. + * exp_util.adb (Find_Prim_Op): Use new attribute to locate the last + formal of a primitive. + * exp_disp.adb (Is_Predefined_Dispatching_Operation, + Is_Predefined_Dispatching_Alias): Use new attribute to locate the last + formal of a primitive. + * exp_cg.adb (Is_Predefined_Dispatching_Operation): Use new attribute + to obtain the last formal of a primitive. + +2010-06-22 Geert Bosch + + * sysdep.c, init.c, adaint.c, cstreams.c: Remove conditional code + depending on __EMX__ or MSDOS being defined. + * i-cstrea.ads, gnat_rm.texi: Remove mentions of OS/2, DOS and Xenix. + * a-excpol-abort.adb: Update comment indicating users of the file. + * xref_lib.adb, sfn_scan.adb: Remove mention of OS/2, replace NT by + Windows. + * env.c: Remove empty conditional for MSDOS. + * s-stchop.adb, g-dirope.ads, s-fileio.adb, osint.ads: Remove mention + of OS/2 in comment. + +2010-06-22 Robert Dewar + + * s-rannum.adb: Minor reformatting. + +2010-06-22 Javier Miranda + + * sem_aux.adb, sem_aux.ads, sem_util.adb, sem_util.ads, sem_elim.adb, + exp_cg.adb: Minor code reorganization: Move routine Ultimate_Alias from + package Sem_Util to package Sem_Aux. + +2010-06-22 Javier Miranda + + * exp_disp.adb (Make_Secondary_DT, Make_DT): Minor code cleanup: + remove useless restriction on imported routines when building the + dispatch tables. + +2010-06-22 Robert Dewar + + * cstand.adb (Create_Standard): Set Has_Pragma_Pack for standard string + types. + +2010-06-22 Javier Miranda + + * sem_ch4.adb (Collect_Generic_Type_Ops): Protect code that handles + generic subprogram declarations to ensure proper context. Add missing + support for generic actuals. + (Try_Primitive_Operation): Add missing support for concurrent types + that have no Corresponding_Record_Type. Required to diagnose errors + compiling + generics or when compiling with no code generation (-gnatc). + * sem_ch9.adb (Analyze_Protected_Type, Analyze_Task_Type): Do not build + the corresponding record type. + * sem_disp.ads, sem_disp.adb (Check_Dispatching_Operation): Complete + documentation. Do minimum decoration when processing a primitive of a + concurrent tagged type that covers interfaces. Required to diagnose + errors in the Object.Operation notation compiling generics or under + -gnatc. + * exp_ch9.ads, exp_ch9.adb (Build_Corresponding_Record): Add missing + propagation of attribute Interface_List to the corresponding record. + (Expand_N_Task_Type_Declaration): Code cleanup. + (Expand_N_Protected_Type_Declaration): Code cleanup. + +2010-06-22 Matthew Heaney + + * a-convec.adb, a-coinve.adb: Removed 64-bit types Int and UInt. + +2010-06-22 Paul Hilfinger + + * s-rannum.adb (Random_Float_Template): Replace with unbiased version + that is able to produce all representable floating-point numbers in the + unit interval. Remove template parameter Shift_Right, no longer used. + * gnat_rm.texi: Document the period of the pseudo-random number + generator under the description of its algorithm. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-22 Thomas Quinot + + * exp_aggr.adb (Rewrite_Discriminant): Fix predicate used to identify + reference to discriminant (can be an expanded name as well as an + identifier). + +2010-06-22 Ed Schonberg + + * exp_ch6.adb: Clarify comment. + +2010-06-22 Geert Bosch + + * exp_imgv.adb (Expand_Image_Attribute): Treat ordinary fixed point + with decimal small as decimal types, avoiding FP arithmetic. + (Has_Decimal_Small): New function. + * einfo.ads, einfo.adb (Aft_Value): New synthesized attributed for + fixed point types. + * sem_attr.adb (Eval_Attribute): Remove Aft_Value function and update + callers to call the new function in Einfo that takes the entity as + parameter. + +2010-06-22 Robert Dewar + + * sem_ch3.adb, sem_ch8.adb: Minor reformatting. + +2010-06-22 Thomas Quinot + + * sem_elab.adb: Minor reformatting. + +2010-06-22 Vincent Celier + + * gnatsym.adb: Put the object files in the table in increasing + aphabetical order of base names. + +2010-06-22 Ed Schonberg + + * sem_ch8.adb (Set_Entity_Or_Discriminal): New procedure used by + Find_Direct_Name and Find_Expanded_Name, to replace a discriminant with + the corresponding discriminal within a record declaration. + +2010-06-22 Thomas Quinot + + * exp_aggr.adb (Rewrite_Discriminant): Rewriting must occur only for an + expression referring to a discriminal of the type of the aggregate (not + a discriminal of some other unrelated type), and the prefix in the + generated selected component must come from Lhs, not Obj. + +2010-06-22 Thomas Quinot + + * sem_ch3.adb (Build_Derived_Record_Type): Fix predicate determining + when to freeze the parent type. + +2010-06-22 Robert Dewar + + * s-rannum.adb, a-nudira.adb, types.ads, freeze.adb, sem_aggr.adb, + exp_aggr.adb: Minor reformatting. + * gnat_rm.texi: Document GNAT.MBBS_Discrete_Random and + GNAT.MBSS_Float_Random. + * g-mbdira.adb, g-mbflra.adb, g-mbdira.ads, g-mbflra.ads: Fix header. + +2010-06-22 Paul Hilfinger + + * a-nudira.adb, a-nudira.ads, a-nuflra.adb, a-nuflra.ads, + gnat_rm.texi, impunit.adb, Makefile.rtl, s-rannum.adb + (Random_Float_Template, Random): New method of creating + uniform floating-point variables that allow the creation of all machine + values in [0 .. 1). + + * g-mbdira.adb, g-mbflra.adb, g-mbdira.ads, g-mbflra.ads: New file. + +2010-06-22 Gary Dismukes + + * sem_ch5.adb (Analyze_Assignment): Revise test for illegal assignment + to abstract targets to check that the type is tagged and comes from + source, rather than only testing for targets of interface types. Remove + premature return. + +2010-06-22 Vincent Celier + + * vms_data.ads: Modify the declarations of qualifiers + /UNCHECKED_SHARED_LIB_IMPORTS to allow the generation of gnat.hlp + without error. + +2010-06-22 Ed Schonberg + + * exp_ch6.adb (Is_Build_In_Place_Function): Predicate is false if + expansion is disabled. + +2010-06-22 Robert Dewar + + * makeusg.adb: Minor reformatting. + +2010-06-22 Robert Dewar + + * types.ads: (Dint): Removed, no longer used anywhere. + * uintp.adb (UI_From_CC): Use UI_From_Int, range is sufficient. + (UI_Mul): Avoid use of UI_From_Dint. + (UI_From_Dint): Removed, not used. + * uintp.ads (UI_From_Dint): Removed, not used. + (Uint_Min/Max_Simple_Mul): New constants. + +2010-06-22 Vincent Celier + + * clean.adb (Parse_Cmd_Line): Recognize switch + --unchecked-shared-lib-imports. + (Usage): Add line for switch --unchecked-shared-lib-imports + * makeusg.adb: Add line for switch --unchecked-shared-lib-imports + * makeutl.ads: (Unchecked_Shared_Lib_Imports): New constant string + moved from GPR_Util. + * switch-m.adb (Scan_Make_Switches): Recognize switch + --unchecked-shared-lib-imports. + * vms_data.ads: Add VMS qualifiers /UNCHECKED_SHARED_LIB_IMPORTS. + * gnat_ugn.texi: Add documentation for new switch + --unchecked-shared-lib-imports. Add also documentation for --subdirs. + +2010-06-22 Javier Miranda + + * sem_prag.adb, sem_util.adb, sem_util.ads, sem_attr.adb, exp_ch6.adb, + exp_disp.adb, sem_eval.adb, exp_dist.adb lib-xref.adb: Code cleanup, + this patch replaces duplication of code that traverses the chain of + aliased primitives by a call to routine Ultimate_Alias that + provides this functionality. + +2010-06-22 Arnaud Charlet + + * fmap.adb, opt.ads, osint.adb, osint.ads, output.ads, scng.adb, + sinput-c.adb, switch-m.ads, tree_io.ads: Use simpler form of + Warnings Off/On. + +2010-06-22 Thomas Quinot + + * einfo.ads: Minor reformatting. + +2010-06-22 Javier Miranda + + * exp_disp.adb (Expand_Interface_Thunk): Do not generate thunk of + eliminated primitives. + (Make_DT): Avoid referencing eliminated primitives. + (Register_Primitive): Do not register eliminated primitives in the + dispatch table. Required to add this functionality when the program is + compiled without static dispatch tables (-gnatd.t) + +2010-06-22 Emmanuel Briot + + * fmap.adb, scng.adb, switch-m.ads, sinput-c.adb, opt.ads, output.ads, + tree_io.ads, osint.adb, osint.ads: Use configuration pragmas to prevent + warnings on use of internal GNAT units. + +2010-06-22 Jose Ruiz + + * s-taprop-vxworks.adb (Set_Priority): Update comments. + +2010-06-22 Paul Hilfinger + + * s-rannum.adb: Make stylistic change to remove mystery constant in + Extract_Value. Image_Numeral_Length: new symbolic constant. + +2010-06-22 Ed Schonberg + + * einfo.ads, einfo.adb: Make Is_Protected_Interface, + Is_Synchronized_Interface, Is_Task_Interface into computable + predicates, to free three flags in entity nodes. + * sem_ch3.adb: Remove setting of these flags. + +2010-06-22 Robert Dewar + + * uintp.adb, osint.adb, prj-conf.adb, prj-part.adb, prj.adb: Minor + reformatting. + * s-taprop-vxworks.adb: Add comment for Set_Priority. + * impunit.adb (Map_Array): Add entries for s-htable.ads and s-crc32.ads + * projects.texi: Move @cindex to the left margin, since otherwise we + are missing entries in the index. + +2010-06-22 Emmanuel Briot + + * prj-part.adb, prj.adb, tempdir.ads, makeutl.adb: Use + packages from the GNAT hierarchy instead of System when possible. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-22 Jose Ruiz + + * s-taprop-vxworks.adb (Set_Priority): Remove the code that was + previously in place to reorder the ready queue when a task drops its + priority due to the loss of inherited priority. + +2010-06-22 Vincent Celier + + * projects.texi: Minor spelling error fixes. + Minor reformatting. + +2010-06-22 Emmanuel Briot + + * prj-part.adb, prj-ext.adb, prj.adb, makeutl.adb, prj-conf.adb: Remove + warnings for some with clauses. + +2010-06-22 Robert Dewar + + * errout.adb (Unwind_Internal_Type): Improve handling of First_Subtype + test to catch more cases where first subtype is the results we want. + * sem_res.adb (Make_Call_Into_Operator): Don't go to First_Subtype in + error case, since Errout will now handle this correctly. + * gcc-interface/Make-lang.in: Add Sem_Aux to list of GNATBIND objects. + Update dependencies. + +2010-06-22 Arnaud Charlet + + * exp_ch4.adb (Expand_Allocator_Expression): Set Related_Node properly + when calling Make_Temporary. + +2010-06-22 Ed Schonberg + + * sem_ch3.adb (Access_Subprogram_Declaration): An anonymous access to + subprogram can be associated with an entry body. + +2010-06-22 Robert Dewar + + * scos.ads: Add note on membership test handling. + +2010-06-22 Vincent Celier + + * projects.texi: Minor spelling fixes. + Minor reformatting. + +2010-06-22 Paul Hilfinger + + * s-rannum.adb: Correct off-by-one error in Extract_Value. + +2010-06-22 Vincent Celier + + * mlib-prj.adb (Display): In non verbose mode, truncate after fourth + argument. + * mlib-utl.adb (Gcc): In non verbose mode, truncate the display of the + gcc command if it is too long. + +2010-06-22 Robert Dewar + + * errout.adb (Set_Msg_Node): Fix incorrect reference to node. + +2010-06-22 Arnaud Charlet + + * exp_ch6.adb (Expand_Actuals): Use Actual as the related node when + calling Make_Temporary. + +2010-06-22 Robert Dewar + + * sem_res.adb, sem_aux.adb, errout.adb: Minor reformatting. + +2010-06-22 Ed Schonberg + + * sem_res.adb: Additional special-case for VMS. + +2010-06-22 Vincent Celier + + * gnatsym.adb: Minor comment fix. + +2010-06-22 Vincent Celier + + * prj-nmsc.adb (Process_Naming_Scheme): Initialize Lib_Data_Table. + +2010-06-22 Robert Dewar + + * par-ch4.adb (P_Name): Recognize 'Mod attribute in Ada 95 mode + * sem_attr.adb (Attribute_05): Add Name_Mod so that 'Mod recognized in + Ada 95 mode as an implementation defined attribute. + +2010-06-22 Vincent Celier + + * bindusg.adb (Display): Update line for -R + * switch-b.adb (Scan_Binder_Switches): Allow generation of the binder + generated files when -R is used. + +2010-06-22 Vincent Celier + + * prj-nmsc.adb (Lib_Data_Table): New table. + (Check_Library_Attributes): Check if the same library name is used in + two different projects that do not extend each other. + +2010-06-22 Robert Dewar + + * lib-writ.ads, errout.adb, einfo.adb, einfo.ads: Minor reformatting. + +2010-06-22 Vincent Celier + + * adaint.c (__gnat_locate_regular_file): If a directory in the path is + empty, make it the current working directory. + +2010-06-22 Thomas Quinot + + * sem_ch3.adb (Build_Derived_Record_Type): When deriving a tagged + private type with discriminants, make sure the parent type is frozen. + +2010-06-22 Eric Botcazou + + * exp_attr.adb (Expand_N_Attribute_Reference) : Deal + with packed array references specially. + * exp_ch4.adb (Expand_N_Indexed_Component): Do not convert a reference + to a component of a bit packed array if it is the prefix of 'Bit. + * exp_pakd.ads (Expand_Packed_Bit_Reference): Declare. + * exp_pakd.adb (Expand_Packed_Bit_Reference): New procedure. Expand a + 'Bit reference, where the prefix involves a packed array reference. + (Get_Base_And_Bit_Offset): New helper, extracted from... + (Expand_Packed_Address_Reference): ...here. Call above procedure to + get the outer object and offset expression. + +2010-06-22 Thomas Quinot + + * exp_attr.adb, lib-writ.ads, bindgen.adb: Minor reformatting. + * einfo.adb (Related_Expression, Set_Related_Expression): Add + assertions. + +2010-06-22 Javier Miranda + + * sem_ch3.adb (Add_Internal_Interface_Entities): Minor code + reorganization to properly check if the operation has been inherited as + an abstract operation. + +2010-06-22 Ed Falis + + * s-osinte-vxworks.ads: Complete previous change. + +2010-06-22 Thomas Quinot + + * sem_res.adb: Add comment. + * projects.texi, gnat_ugn.texi: Remove macro. + +2010-06-22 Vincent Celier + + * prj-attr.adb: Remove project level attribute Main_Language. + +2010-06-22 Robert Dewar + + * switch-b.adb, osint-b.adb: Minor reformatting. + +2010-06-22 Pascal Obry + + * g-socthi-mingw.adb (C_Sendmsg): Do not attempt to send data from a + vector if previous send was not fully successful. If only part of + the vector data was sent, we exit the loop. + +2010-06-22 Thomas Quinot + + * sem_res.adb (Make_Call_Into_Operator): Use First_Subtype for better + error reporting with generic types. + +2010-06-22 Thomas Quinot + + * bindgen.adb, bindusg.adb, gnatbind.adb, gnat_ugn.texi, opt.ads, + osint-b.adb, osint-b.ads, output.adb, output.ads, switch-b.adb, + vms_data.ads: Add a new command line switch -A to gnatbind to output + the list of all ALI files for the partition. + +2010-06-22 Arnaud Charlet + + * s-osinte-vxworks.ads: Fix casing. + * s-vxwext-kernel.ads, s-vxwext-rtp.ads: Complete previous + change: Interfaces.C does not provide a long_long type. + +2010-06-22 Emmanuel Briot + + * gnat_ugn.texi, projects.texi: Preprocess projects.texi for VMS and + native user's guide, since this document contains the two versions. + * gcc-interface/Make-lang.in: Update doc dependencies. + +2010-06-22 Robert Dewar + + * sem_ch3.adb: Minor reformatting. Minor code reorganization. + +2010-06-22 Emmanuel Briot + + * gnat_ugn.texi, projects.texi: Remove toplevel menu, since we should + not build this file on its own (only through gnat_ugn.texi). + Remove macro definitions and insert simpler version in gnat_ugn.texi. + +2010-06-22 Robert Dewar + + * ali-util.ads: Minor comment update. + * g-socthi-mingw.adb: Minor reformatting. + +2010-06-22 Ed Falis + + * s-osinte-vxworks.ads: Take sigset_t definition of System.VxWorks.Ext. + * s-vxwext.ads, s-vxwext-kernel.ads, s-vxwext-rtp.ads: Define sigset_t + for specific versions of VxWorks. + +2010-06-22 Emmanuel Briot + + * gnat_rm.texi, gnat_ugn.texi, projects.texi: Remove all project files + related sections from user's guide and reference manual, since they + have now been merged together into a separate document (projects.texi). + This removes a lot of duplication where attributes where described + in several places. + The grammar for the project files is now in each of the sections + (packages,expressions,...) instead of being duplicates in two other + sections (one in the user's guide that contained the full grammar, + and various sections in the rm that contained extracts of the same + grammar). + Added the full list of all supported attributes, since existing lists + were incomplete + Rename "associative array" into "indexed attribute" + Remove sections that were duplicates ("External References in + Project Files" and "External Values", and "Project Extensions" + for instance). The list of valid packages in project files is now in + a single place. + +2010-06-22 Ed Schonberg + + * sem_ch3.adb (Add_Internal_Interface_Entities): If + Find_Primitive_Covering_Interface does not find the operation, it may + be because of a name conflict between the inherited operation and a + local non-overloadable name. In that case look for the operation among + the primitive operations of the type. This search must succeed + regardless of visibility. + +2010-06-22 Pascal Obry + + * g-socthi-mingw.adb: Properly honor MSG_WAITALL in recvmsg. + (C_Recvmsg): Propely honor the MSG_WAITALL flag in Windows + recvmsg emulation. + +2010-06-22 Robert Dewar + + * sem_ch4.adb (Analyze_Conditional_Expression): Defend against + malformed tree. + * sprint.adb (Sprint_Node_Actual, case N_Conditional_Expression): + Ditto. + +2010-06-22 Arnaud Charlet + + * s-intman-vxworks.ads: Code clean up. + +2010-06-22 Thomas Quinot + + * sem_res.adb (Resolve_Slice): When the prefix is an explicit + dereference, construct actual subtype of designated object to generate + proper bounds checks. + +2010-06-22 Thomas Quinot + + * ali-util.adb, ali-util.ads, gnatbind.adb (Read_ALI): Rename to + Read_Withed_ALIs, which is more descriptive. + +2010-06-22 Pascal Obry + + * g-sothco.ads: Minor reformatting. + * g-socthi-mingw.adb: Remove part of work on the C_Recvmsg and + C_Sendmsg implementation. + (C_Sendmsg): Do not use lock (not needed). + (C_Recvmsg): Likewise and also do not wait for incoming data. + +2010-06-22 Ed Schonberg + + * uintp.adb: Fix scope error in operator call. + +2010-06-22 Vincent Celier + + * makeutl.adb (Executable_Prefix_Path): on VMS, return "/gnu/". + * prj-conf.adb (Get_Or_Create_Configuration_File): On VMS, if + autoconfiguration is needed, fail indicating that no config project + file can be found, as there is no autoconfiguration on VMS. + +2010-06-22 Ed Schonberg + + * sem_res.adb (Make_Call_Into_Operator): Diagnose an incorrect scope + for an operator in a functional notation, when operands are universal. + +2010-06-22 Arnaud Charlet + + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-22 Robert Dewar + + * sem_aggr.adb (Resolve_Record_Aggregate): Do style check on component + name. + * sem_ch10.adb (Analyze_Subunit): Do style check on parent unit name. + * sem_ch8.adb (Find_Direct_Name): For non-overloadable entities, do + style check. + * sem_res.adb (Resolve_Entity_Name): Do style check for enumeration + literals. + +2010-06-22 Vincent Celier + + * make.adb (Scan_Make_Arg): No longer pass -nostdlib to the compiler as + it has no effect. Always pass -nostdlib to gnatlink, even on VMS. + +2010-06-22 Pascal Obry + + * g-socthi-mingw.adb: Fix implementation of the vectored sockets on + Windows. + (C_Recvmsg): Make sure the routine is atomic. Also fully + fill vectors in the proper order. + (C_Sendmsg): Make sure the routine is atomic. + +2010-06-22 Robert Dewar + + * sem_ch8.adb: Update comment. + * sem_res.adb: Minor code reorganization (use Ekind_In). + +2010-06-22 Ed Schonberg + + * sem_ch8.adb (Add_Implicit_Operator): If the context of the expanded + name is a call, use the number of actuals to determine whether this is + a binary or unary operator, rather than relying on later information + to resolve the overload. + +2010-06-22 Robert Dewar + + * sem_ch10.adb, sem_aggr.adb: Minor reformatting. + +2010-06-22 Robert Dewar + + * sem_ch3.adb, sem_disp.adb: Minor code fixes. + * sem_eval.adb: Minor reformatting. + +2010-06-22 Vincent Celier + + * make.adb (Scan_Make_Arg): When invoked with -nostdlib, pass -nostdlib + to gnatlink, except on Open VMS. + * osint.adb (Add_Default_Search_Dirs): Do not suppress the default + object directories if -nostdlib is used. + +2010-06-22 Robert Dewar + + * sem_util.adb (Is_Delegate): Put in proper alpha order. + * sem_eval.adb: Minor reformatting. + +2010-06-22 Robert Dewar + + * g-expect-vms.adb, sem_res.adb: Minor reformatting. + * exp_aggr.adb: Minor comment changes and reformatting. + * sem_eval.adb (Find_Universal_Operator_Type): Put in proper alpha + order. + * sem_util.ads: Add some missing pragma Inline's. + +2010-06-22 Thomas Quinot + + * sem_util.adb (Build_Actual_Subtype): Record original expression in + Related_Expression attribute of the constructed subtype. + * einfo.adb, einfo.ads (Underlying_View): Move to Node28 to free up + Node24 on types for... + (Related_Expression): Make attribute available on types as well. + +2010-06-22 Gary Dismukes + + * exp_util.adb (Find_Interface_ADT): Retrieve Designated_Type instead + of Directly_Designated_Type when the type argument is an access type. + (Find_Interface_Tag): Retrieve Designated_Type instead of + Directly_Designated_Type when the type argument is an access type. + (Has_Controlled_Coextensions): Retrieve Designated_Type instead of + Directly_Designated_Type of each access discriminant. + * sem_res.adb (Resolve_Type_Conversion): Retrieve Designated_Type + instead of Directly_Designated_Type when the operand and target types + are access types. + +2010-06-22 Thomas Quinot + + * exp_aggr.adb (Flatten): Return False if one choice is statically + known to be out of bounds. + +2010-06-22 Ed Schonberg + + * sem_res.adb (Resolve_Call): If the call is rewritten as an indexed of + a parameterless function call, preserve parentheses of original + expression, for proper handling by pretty printer. + * sem_attr.adb (Analyze_Attribute, case 'Old): Add guard to Process + procedure, to handle quietly identifiers that have no entity names. + * exp_util.adb (Get_Current_Value_Condition): If the parent of an + elsif_part is missing, it has been rewritten as a nested if, and there + is no useful information on the current value of the variable. + +2010-06-22 Gary Dismukes + + * sem_ch3.adb (Build_Discriminal): Set default scopes for newly created + discriminals to the current scope. + * sem_util.adb (Find_Body_Discriminal): Remove setting of discriminal's + scope, which could overwrite a different already set value. + +2010-06-22 Ed Schonberg + + * sem_res.adb (Valid_Conversion): If expression is a predefined + operator, use sloc of type of interpretation to improve error message + when operand is of some derived type. + * sem_eval.adb (Is_Mixed_Mode_Operand): New function, use it. + +2010-06-22 Emmanuel Briot + + * g-expect-vms.adb (Expect_Internal): No longer raises an exception, so + that it can set out parameters as well. When a process has died, reset + its Input_Fd to Invalid_Fd, so that when using multiple processes we + can find out which process has died. + +2010-06-22 Thomas Quinot + + * sem_eval.adb (Find_Universal_Operator_Type): New + subprogram to identify the operand type of an operator on universal + operands, when an explicit scope indication is present. Diagnose the + case where such a call is ambiguous. + (Eval_Arithmetic_Op, Eval_Relational_Op, Eval_Unary_Op): + Use the above to identify the operand type so it can be properly + frozen. + * sem_res.adb (Make_Call_Into_Operator): Remove bogus freeze of operand + type, done in an arbitrary, possibly incorrect type (the presence of + some numeric type in the scope is checked for legality, but when more + than one such type is in the scope, we just pick a random one, not + necessarily the expected one). + * sem_utils.ads, sem_utils.adb (Is_Universal_Numeric_Type): New utility + subprogram. + +2010-06-22 Robert Dewar + + * sem_eval.adb: Minor reformatting. + +2010-06-22 Robert Dewar + + * exp_ch4.adb (Expand_N_Conditional_Expression): Use + Expression_With_Actions to clean up the code generated when folding + constant expressions. + +2010-06-22 Vincent Celier + + * g-expect-vms.adb: Add new subprograms Free, First_Dead_Process and + Has_Process. + +2010-06-22 Vincent Celier + + * prj-nmsc.adb (Find_Sources): When a source from a multi-unit file is + found, check if it's path has aready been found, whatever its index. + +2010-06-22 Robert Dewar + + * atree.adb, gnatbind.adb: Minor reformatting. + Minor code reorganization. + +2010-06-21 Robert Dewar + + * exp_ch4.adb (Expand_N_Conditional_Expression): Fold if condition + known at compile time. + +2010-06-21 Gary Dismukes + + * atree.adb: Fix comment typo. + +2010-06-21 Ed Schonberg + + * sem_eval.adb (Test_Ambiguous_Operator): New procedure to check + whether a universal arithmetic expression in a conversion, which is + rewritten from a function call with an expanded name, is ambiguous. + +2010-06-21 Vincent Celier + + * prj-nmsc.adb (Name_Location): New Boolean component Listed, to record + source files in specified list of sources. + (Check_Package_Naming): Remove out parameters Bodies and Specs, as they + are never used. + (Add_Source): Set the Location of the new source + (Process_Exceptions_File_Based): Call Add_Source with the Location + (Get_Sources_From_File): If an exception is found, set its Listed to + True + (Find_Sources): When Source_Files is specified, if an exception is + found, set its Listed to True. Remove any exception that is not in a + specified list of sources. + * prj.ads (Source_Data): New component Location + +2010-06-21 Vincent Celier + + * gnatbind.adb (Closure_Sources): Global table, moved from block. + +2010-06-21 Thomas Quinot + + * sem_res.adb: Minor reformatting. + * atree.adb: New debugging hook "rr" for node rewrites. + +2010-06-21 Robert Dewar + + * g-expect.ads, g-expect.adb: Minor reformatting. + +2010-06-21 Emmanuel Briot + + * s-regpat.adb (Next_Pointer_Bytes): New named constant. Code clean up. + +2010-06-21 Arnaud Charlet + + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-21 Thomas Quinot + + * bindgen.ads: Update comments. + +2010-06-21 Vincent Celier + + * gnatbind.adb: Suppress dupicates when listing the sources in the + closure (switch -R). + +2010-06-21 Emmanuel Briot + + * s-regpat.adb (Link_Tail): Fix error when size of the pattern matcher + is too small. + +2010-06-21 Emmanuel Briot + + * g-expect.adb, g-expect.ads (First_Dead_Process, Free, Has_Process): + New subprograms. + (Expect_Internal): No longer raises an exception, so that it can set + out parameters as well. When a process has died, reset its Input_Fd + to Invalid_Fd, so that when using multiple processes we can find out + which process has died. + +2010-06-21 Robert Dewar + + * s-regpat.adb, s-tpoben.adb, sem_attr.adb, sem_util.adb, sem_util.ads, + checks.adb, sem_res.adb: Minor reformatting. Add comments. + +2010-06-21 Ed Schonberg + + * sem_ch6.adb (New_Overloaded_Entity): If the new entity is a + rederivation associated with a full declaration in a private part, and + there is a partial view that derives the same parent subprogram, the + new entity does not become visible. This check must be applied to + interface operations as well. + +2010-06-21 Thomas Quinot + + * checks.adb: Add comments. + * prj-nmsc.adb: Minor reformatting. + +2010-06-21 Thomas Quinot + + * sem_ch9.adb, checks.adb, sem_util.adb, sem_util.ads, sem_res.adb, + sem_attr.adb (Get_E_First_Or_Last): Use attribute references on E to + extract bounds, to ensure that we get the proper captured values, + rather than an expression that may have changed value since the point + where the subtype was elaborated. + (Find_Body_Discriminal): New utility subprogram to share code + between... + (Eval_Attribute): For the case of a subtype bound that references a + discriminant of the current concurrent type, insert appropriate + discriminal reference. + (Resolve_Entry.Actual_Index_Type.Actual_Discriminant_Ref): For a + requeue to an entry in a family in the current task, use corresponding + body discriminal. + (Analyze_Accept_Statement): Rely on expansion of attribute references + to insert proper discriminal references in range check for entry in + family. + +2010-06-21 Emmanuel Briot + + * s-regpat.adb (Compile): Fix handling of big patterns. + +2010-06-21 Robert Dewar + + * a-tifiio.adb: Minor reformatting. + +2010-06-21 Pascal Obry + + * prj-nmsc.adb (Search_Directories): Use the non-translated directory + path to open it. + +2010-06-21 Javier Miranda + + * exp_cg.adb (Write_Call_Info): Fill the component sourcename using the + external name. + +2010-06-21 Ed Schonberg + + * exp_ch4.adb (Expand_Concatenate): If an object declaration is created + to hold the result, indicate that the target of the declaration does + not need an initialization, to prevent spurious errors when + Initialize_Scalars is enabled. + +2010-06-21 Ed Schonberg + + * a-tifiio.adb (Put): In the procedure that performs I/O on a String, + Fore is not bound by line length. The Fore parameter of the internal + procedure that performs the operation is an integer. + +2010-06-21 Thomas Quinot + + * sem_res.adb, checks.adb: Minor reformatting. + +2010-06-21 Emmanuel Briot + + * s-regpat.adb (Next_Instruction, Get_Next_Offset): Removed, merged + into Get_Next. + (Insert_Operator_Before): New subprogram, avoids duplicated code + (Compile): Avoid doing two compilations when the pattern matcher ends + up being small. + +2010-06-21 Emmanuel Briot + + * s-regpat.adb: Improve debug traces + (Dump): Change output format to keep it smaller. + +2010-06-21 Javier Miranda + + * exp_cg.adb (Generate_CG_Output): Disable redirection of standard + output to the output file when this routine completes its work. + +2010-06-20 Eric Botcazou + + * gcc-interface/trans.c (Subprogram_Body_to_gnu): Use while instead of + for loop. Call build_constructor_from_list directly in the CICO case. + +2010-06-18 Ed Schonberg + + * freeze.adb (Build_And_Analyze_Renamed_Body): If the renaming + declaration appears in the same unit and ealier than the renamed + entity, retain generated body to prevent order-of-elaboration issues in + gigi. + +2010-06-18 Arnaud Charlet + + * s-tpoben.adb: Update comments. + +2010-06-18 Robert Dewar + + * debug.adb: Minor comment change. + +2010-06-18 Javier Miranda + + * exp_cg.adb: Code clean up. + * debug.adb: Complete documentation of switch -gnatd.Z. + * gcc-interface/misc.c (callgraph_info_file): Declare. + +2010-06-18 Javier Miranda + + * exp_cg.adb (Homonym_Suffix_Length): Minor code reorganization. + +2010-06-18 Thomas Quinot + + * sprint.ads: Minor reformatting. + * output.ads: Update obsolete comment. + +2010-06-18 Ed Schonberg + + * freeze.adb (Build_And_Analyze_Renamed_Body): if the renamed entity is + an external intrinsic operation (e.g. a GCC numeric function) indicate + that the renaming entity has the same characteristics, so a call to it + is properly expanded. + +2010-06-18 Javier Miranda + + * exp_cg.adb, exp_cg.ads, exp_disp.adb, gnat1drv.adb: Add initial + support for dispatch table/callgraph info generation. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-18 Robert Dewar + + * exp_ch6.adb: Minor reformatting. + * gnatname.adb: Add comment. + +2010-06-18 Vincent Celier + + * gnatname.adb (Scan_Args): When --and is used, make sure that the + dynamic tables in the newly allocated Argument_Data are properly + initialized. + +2010-06-18 Eric Botcazou + + * gnat1drv.adb: Fix comment. + +2010-06-18 Ed Schonberg + + * exp_ch6.adb (Expand_Inlined_Call): If the inlined subprogram is a + renaming, re-expand the call with the renamed subprogram if that one + is marked inlined as well. + +2010-06-18 Gary Dismukes + + * gnat1drv.adb (Adjust_Global_Switches): Enable + Use_Expression_With_Actions for AAMP and VM targets. + +2010-06-18 Vincent Celier + + * prj-nmsc.adb (Process_Linker): Recognize response file format GCC. + +2010-06-18 Thomas Quinot + + * exp_ch4.adb: Minor reformatting. + +2010-06-18 Javier Miranda + + * debug.ads Add documentation on -gnatd.Z. + +2010-06-18 Ed Schonberg + + * sem_elim.adb: Proper error message on improperly eliminated instances + +2010-06-18 Vincent Celier + + * prj.ads (Response_File_Format): New value GCC. + +2010-06-18 Thomas Quinot + + * gnat1drv.adb: Minor reformatting. + +2010-06-18 Robert Dewar + + * make.adb, sem_cat.adb: Minor reformatting. + * sem_eval.adb: Fix typos. + +2010-06-18 Pascal Obry + + * prj-nmsc.adb: Fix source filenames casing in debug output. + +2010-06-18 Robert Dewar + + * gnatcmd.adb: Minor reformatting. + +2010-06-18 Robert Dewar + + * sem_eval.adb (Eval_Conditional_Expression): Result is static if + condition and both sub-expressions are static (and result is selected + expression). + +2010-06-18 Robert Dewar + + * g-pehage.adb: Minor reformatting + +2010-06-18 Pascal Obry + + * prj-nmsc.adb (Search_Directories): Insert canonical filenames into + source hash table. + +2010-06-18 Arnaud Charlet + + * gcc-interface/Makefile.in, gcc-interface/Make-lang.in: Update + dependencies. Fix target pairs on darwin. + (gnatlib-sjlj, gnatlib-zcx): Pass THREAD_KIND. + +2010-06-18 Pascal Obry + + * make.adb, prj-nmsc.adb: Fix source filenames casing in debug output. + +2010-06-18 Vincent Celier + + * gnatcmd.adb: For gnatcheck, add -gnatec= switch for a global + configuration pragmas file and, if -U is not used, for a local one. + +2010-06-18 Ed Schonberg + + * sem_elim.adb (Check_Eliminated): Use full information on entity name + when it is given in the pragma by a selected component. + (Check_For_Eliminated_Subprogram): Do no emit error if within a + instance body that is itself within a generic unit. + * sem_ch12.adb (Analyze_Subprogram_Instance): If the subprogram is + eliminated, mark as well the anonymous subprogram that is its alias + and appears within the wrapper package. + +2010-06-18 Bob Duff + + * g-pehage.ads, g-pehage.adb (Produce): Clean up some of the code. + Raise an exception if the output file cannot be opened. Add comments. + +2010-06-18 Thomas Quinot + + * sem_cat.adb (Validate_Object_Declaration): A variable declaration is + not illegal per E.2.2(7) if it occurs in the private part of a + Remote_Types unit. + +2010-06-18 Arnaud Charlet + + * par-ch9.adb, sem_aggr.adb, sem_ch3.adb, layout.adb, sem_ch4.adb, + sem_ch5.adb, sem_mech.adb, exp_util.adb, par-ch10.adb, sem_ch6.adb, + par-ch11.adb, sem_ch7.adb, par-prag.adb, exp_disp.adb, par-ch12.adb, + sem_ch8.adb, style.adb, sem_ch9.adb, sem_ch10.adb, prep.adb, + sem_warn.adb, par-util.adb, scng.adb, sem_eval.adb, checks.adb, + sem_prag.adb, sem_ch12.adb, styleg.adb, sem_ch13.adb, par-ch3.adb, + par-tchk.adb, freeze.adb, sfn_scan.adb, par-ch4.adb, sem_util.adb, + sem_res.adb, par-ch5.adb, lib-xref.adb, sem_attr.adb, par-ch6.adb, + sem_disp.adb, prepcomp.adb, par-ch7.adb, sem_elab.adb, exp_ch4.adb, + errout.ads: Update comments. Minor reformatting. + + * g-spipat.adb, a-swunau.adb, a-swunau.ads, g-spitbo.adb, + a-szunau.adb, a-szunau.ads, a-stunau.adb, a-stunau.ads, + a-strunb.adb (Big_String. Big_String_Access): New type. + + * par-labl.adb, restrict.adb, s-osinte-hpux-dce.ads, sem_ch11.adb, + exp_pakd.adb, s-filofl.ads, par-endh.adb, exp_intr.adb, sem_cat.adb, + sem_case.adb, exp_ch11.adb, s-osinte-linux.ads: Fix copyright notices. + +2010-06-18 Geert Bosch + + * i-forbla-darwin.adb: Include -lgnala and -lm in linker options for + Darwin. + +2010-06-18 Robert Dewar + + * gnat1drv.adb (Adjust_Global_Switches): Set Use_Expression_With_Actions + true for gcc. + +2010-06-18 Robert Dewar + + * sprint.adb: Minor format change for N_Expression_With_Actions. + * repinfo.adb: Minor reformatting. + +2010-06-18 Ed Schonberg + + * sem_elim.adb (Check_Eliminated): If within a subunit, use + Defining_Entity to obtain the name of the entity in the proper body, to + properly handle both separate packages and subprograms. + +2010-06-18 Emmanuel Briot + + * prj-nmsc.adb (Check_File): New parameter Display_Path. + +2010-06-18 Thomas Quinot + + * g-socket.adb, g-socket.ads (Null_Selector): New object. + +2010-06-18 Pascal Obry + + * gnat_ugn.texi: Minor clarification. + +2010-06-18 Emmanuel Briot + + * prj-nmsc.adb (Find_Source_Dirs): Minor refactoring to avoid duplicate + code when using the project dir as the source dir. + (Search_Directories): use the normalized name for the source directory, + where symbolic names have potentially been resolved. + +2010-06-18 Robert Dewar + + * exp_ch4.adb (Expand_N_Conditional_Expression): Clear Actions field + when we create N_Expression_With_Actions node. + (Expand_Short_Circuit): Ditto. + +2010-06-18 Robert Dewar + + * exp_util.adb: Minor reformatting. + +2010-06-18 Thomas Quinot + + * types.ads: Clean up obsolete comments + * tbuild.adb: Minor reformatting. + * exp_ch5.adb, sem_intr.adb, sem_ch10.adb, rtsfind.adb, s-shasto.adb, + exp_strm.adb, aa_drive.adb: Minor reformatting. + * sem_res.adb (Is_Predefined_Operator): An operator that is an imported + intrinsic with an Interface_Name denotes an imported back-end builtin, + and must be rewritten into a call, not left in the tree as an operator, + so return False in that case. + +2010-06-18 Eric Botcazou + + * exp_util.adb (Remove_Side_Effects): Make a copy for an allocator. + +2010-06-18 Robert Dewar + + * scos.ads: Add proposed output for case expression + +2010-06-18 Jose Ruiz + + * gnat_ugn.texi: Document that, when using the RTX compiler to generate + RTSS modules, we need to use the Microsoft linker. + +2010-06-18 Robert Dewar + + * checks.adb (Safe_To_Capture_In_Parameter_Value): Deal with case + expression (cannot count on a particular branch being executed). + * exp_ch4.adb (Expand_N_Case_Expression): New procedure. + * exp_ch4.ads (Expand_N_Case_Expression): New procedure. + * exp_util.adb (Insert_Actions): Deal with proper insertion of actions + within case expression. + * expander.adb (Expand): Add call to Expand_N_Case_Expression + * par-ch4.adb Add calls to P_Case_Expression at appropriate points + (P_Case_Expression): New procedure + (P_Case_Expression_Alternative): New procedure + * par.adb (P_Case_Expression): New procedure + * par_sco.adb (Process_Decisions): Add dummy place holder entry for + N_Case_Expression. + * sem.adb (Analyze): Add call to Analyze_Case_Expression + * sem_case.ads (Analyze_Choices): Also used for case expressions now, + this is a documentation change only. + * sem_ch4.ads, sem_ch4.adb (Analyze_Case_Expression): New procedure. + * sem_ch6.adb (Fully_Conformant_Expressions): Add handling of case + expressions. + * sem_eval.ads, sem_eval.adb (Eval_Case_Expression): New procedure. + * sem_res.adb (Resolve_Case_Expression): New procedure. + * sem_scil.adb (Find_SCIL_Node): Add processing for + N_Case_Expression_Alternative. + * sinfo.ads, sinfo.adb (N_Case_Expression): New node. + (N_Case_Expression_Alternative): New node. + * sprint.adb (Sprint_Node_Actual): Add processing for new nodes + N_Case_Expression and N_Case_Expression_Alternative. + +2010-06-18 Robert Dewar + + * par-ch7.adb, sem_warn.adb, types.ads, par-ch3.adb: Minor + reformatting. + * gnat1drv.adb: Fix typo. + +2010-06-18 Robert Dewar + + * par-prag.adb (Prag, case Style_Checks): All_Checks sets gnat style + for -gnatg. + * sem_prag.adb (Analyze_Pragma, case Style_Checks): All_Checks sets + gnat style for -gnatg. + * gnat_rm.texi: Add documentation for ALL_CHECKS in GNAT mode. + +2010-06-18 Thomas Quinot + + * sem_eval.adb (Test_In_Range): New subprogram, factoring duplicated + code between... + (Is_In_Range, Is_Out_Of_Range): Reimplement in terms of call to + Test_In_Range. + +2010-06-18 Robert Dewar + + * sprint.adb: Minor change in output format for expression wi actions. + * par-ch3.adb: Minor code reorganization. Minor reformatting. + * sem_ch5.adb: Minor comment fix. + +2010-06-18 Robert Dewar + + * debug.adb: New debug flag -gnatd.L to control + Back_End_Handles_Limited_Types. + * exp_ch4.adb (Expand_N_Conditional_Expression): Let back end handle + limited case if Back_End_Handles_Limited_Types is True. + (Expand_N_Conditional_Expression): Use N_Expression_With_Actions to + simplify expansion if Use_Expression_With_Actions is True. + * gnat1drv.adb (Adjust_Global_Switches): Set + Back_End_Handles_Limited_Types. + * opt.ads (Back_End_Handles_Limited_Types): New flag. + +2010-06-18 Ed Schonberg + + * sem_res.adb (Rewrite_Operator_As_Call): Do not rewrite user-defined + intrinsic operator if expansion is not enabled, because in an + instantiation the original operator must be present to verify the + legality of the operation. + +2010-06-18 Robert Dewar + + * exp_disp.adb, sem_ch12.adb: Minor reformatting + +2010-06-18 Ed Schonberg + + * exp_util.adb (Make_Subtype_From_Expr): If the unconstrained type is + the class-wide type for a private extension, and the completion is a + subtype, set the type of the class-wide type to the base type of the + full view. + +2010-06-18 Robert Dewar + + * g-socket.ads, sem_aggr.adb, einfo.ads, sem_elim.adb, + sem_intr.adb, sem_eval.adb: Minor reformatting + +2010-06-18 Ed Schonberg + + * sem_type.adb (Is_Ancestor): If either type is private, examine full + view. + +2010-06-18 Thomas Quinot + + * g-socket.adb, g-socket.ads (Check_Selector): Make Selector an IN + parameter rather than IN OUT. + +2010-06-18 Ed Schonberg + + * exp_ch6.adb: Add extra guard. + +2010-06-18 Gary Dismukes + + * sem_util.adb (Object_Access_Level): For Ada 2005, determine the + accessibility level of a function call from the level of the innermost + enclosing dynamic scope. + (Innermost_Master_Scope_Depth): New function to find the depth of the + nearest dynamic scope enclosing a node. + +2010-06-18 Tristan Gingold + + * adaint.c: Make ATTR_UNSET static as it is not used outside this file. + +2010-06-18 Thomas Quinot + + * g-socket.ads: Minor reformatting. + +2010-06-18 Vincent Celier + + * make.adb (Must_Compile): New Boolean global variable + (Main_On_Command_Line): New Boolean global variable + (Collect_Arguments_And_Compile): Do compile if Must_Compile is True, + even when the project is externally built. + (Start_Compile_If_Possible): Compile in -aL directories if + Check_Readonly_Files is True. Do compile if Must_Compile is True, even + when the project is externally built. + (Gnatmake): Set Must_Compile and Check_Readonly_Files to True when + invoked with -f -u and one or several mains on the command line. + (Scan_Make_Arg): Set Main_On_Command_Line to True when at least one + main is specified on the command line. + +2010-06-18 Ed Schonberg + + * sem_ch6.adb (Build_Body_For_Inline): Handle + extended_return_statements. + * exp_ch6.adb (Expand_Inlined_Call): when possible, inline a body + containing extented_return statements. + * exp_util.adb (Make_CW_Equivalent_Type): If the root type is already + constrained, do not build subtype declaration. + +2010-06-18 Robert Dewar + + * sem_res.adb (Analyze_Indexed_Component, Analyze_Selected_Component): + Warn on assigning to packed atomic component. + +2010-06-18 Robert Dewar + + * sem_util.ads: Minor reformatting + * einfo.ads, einfo.adb: Minor doc clarification (scope of decls in + Expression_With_Actions). + * snames.ads-tmpl: Minor comment fix + +2010-06-18 Robert Dewar + + * sem_prag.adb (Diagnose_Multiple_Pragmas): New procedure + (Set_Imported): Use Import_Interface_Present to control message output + * sinfo.ads, sinfo.adb (Import_Interface_Present): New flag + * gnat_rm.texi: Document that we can have pragma Import and pragma + Interface for the same subprogram. + +2010-06-18 Robert Dewar + + * lib-xref.adb (Generate_Reference): Fix bad reference to + Has_Pragma_Unreferenced (clients should always use Has_Unreferenced). + +2010-06-17 Eric Botcazou + + * gcc-interface/trans.c (set_gnu_expr_location_from_node): New static + function. + (gnat_to_gnu) : New case. + Use set_gnu_expr_location_from_node to set location information on the + result. + +2010-06-17 Arnaud Charlet + + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-17 Ed Schonberg + + * sem_util.adb (Is_Atomic_Object): Predicate does not apply to + subprograms. + +2010-06-17 Robert Dewar + + * gnat_rm.texi, gnat_ugn.texi: Clean up documentation on warning and + style check messages. + * sem_res.adb (Resolve_Call): Don't call + Check_For_Eliminated_Subprogram if we are analyzing within a spec + expression. + +2010-06-17 Robert Dewar + + * debug.adb: Add documentation for debug flags .X and .Y + * exp_ch4.adb (Expand_Short_Circuit_Operator): Use + Use_Expression_With_Actions. + * gnat1drv.adb (Adjust_Global_Switches): Set + Use_Expression_With_Actions. + * opt.ads (Use_Expression_With_Actions): New switch. + +2010-06-17 Robert Dewar + + * exp_intr.adb: Minor code reorganization (use UI_Max) + * sem_intr.adb: use underlying type to check legality. + * einfo.adb (Known_Static_Esize): False for generic types + (Known_Static_RM_Size): False for generic types + * einfo.ads (Known_Static_Esize): False for generic types + (Known_Static_RM_Size): False for generic types + +2010-06-17 Robert Dewar + + * exp_ch4.ads: Minor code reorganization (specs in alpha order). + +2010-06-17 Robert Dewar + + * debug.adb: New debug flag -gnatd.X to use Expression_With_Actions + node when expanding short circuit form with actions present for right + opnd. + * exp_ch4.adb: Minor reformatting + (Expand_Short_Circuit_Operator): Use new Expression_With_Actions node + if right opeand has actions present, and debug flag -gnatd.X is set. + * exp_util.adb (Insert_Actions): Handle case of Expression_With_Actions + node. + * nlists.adb (Prepend_List): New procedure + (Prepend_List_To): New procedure + * nlists.ads (Prepend_List): New procedure + (Prepend_List_To): New procedure + * sem.adb: Add processing for Expression_With_Actions + * sem_ch4.adb (Analyze_Expression_With_Actions): New procedure + * sem_ch4.ads (Analyze_Expression_With_Actions): New procedure + * sem_res.adb: Add processing for Expression_With_Actions. + * sem_scil.adb: Add processing for Expression_With_Actions + * sinfo.ads, sinfo.adb (N_Expression_With_Actions): New node. + * sprint.ads, sprint.adb: Add processing for Expression_With_Actions + +2010-06-17 Doug Rupp + + * sem_intr.adb (Check_Intrinsic_Operator): Check that the types + involved both have underlying integer types. + * exp_intr.adb (Expand_Binary_Operator) New subprogram to expand a call + to an intrinsic operator when the operand types or sizes are not + identical. + * s-auxdec-vms_64.ads: Revert "+" "-" ops back to Address now that + 64/32 Address/Integer works. + +2010-06-17 Ed Schonberg + + * sem_ch12.adb (Mark_Context): Refine placement of Withed_Body flag, so + that it marks a unit as needed by a spec only if the corresponding + instantiation appears in that spec (and not in the corresponding body). + * sem_elim.adb (Check_Eliminated): If we are within a subunit, the name + in the pragma Eliminate has been parsed as a child unit, but the + current compilation unit is in fact the parent in which the subunit is + embedded. + +2010-06-17 Vincent Celier + + * gnat_rm.texi: Fix typo + +2010-06-17 Robert Dewar + + * sem_util.adb: Minor reformatting + +2010-06-17 Ed Schonberg + + * sem.adb (Do_Withed_Unit): if the unit in the with_clause is a generic + instance, the clause now denotes the instance body. Traverse the + corresponding spec because there may be no other dependence that will + force the traversal of its own context. + +2010-06-17 Ed Schonberg + + * sem_ch10.adb (Is_Ancestor_Unit): Subsidiary to + Install_Limited_Context_Clauses, to determine whether a limited_with in + some parent of the current unit designates some other parent, in which + case the limited_with clause must not be installed. + (In_Context): Refine test. + +2010-06-17 Gary Dismukes + + * sem_util.adb (Collect_Primitive_Operations): In the of an untagged + type with a dispatching equality operator that is overridden (for a + tagged full type), don't include the overridden equality in the list of + primitives. The overridden equality is detected by testing for an + Aliased field that references the overriding equality. + +2010-06-17 Robert Dewar + + * freeze.adb: Minor reformatting. + +2010-06-17 Joel Brobecker + + * gnat_ugn.texi: Add a section introducing gdbserver. + +2010-06-17 Thomas Quinot + + * sem_res.adb, sem_ch4.adb, s-stoele.adb, par-labl.adb: Minor + reformatting. + +2010-06-17 Ed Schonberg + + * sem_aggr.adb (Valid_Ancestor_Type): handle properly the case of a + constrained discriminated parent that is a private type. + (Analyze_Record_Aggregate): when collecting inherited discriminants, + handle properly an ancestor type that is a constrained private type. + +2010-06-17 Ed Schonberg + + * sem_util.adb (Enclosing_Subprogram): If the called subprogram is + protected, use the protected_subprogram_body only if the original + subprogram has not been eliminated. + +2010-06-17 Ed Schonberg + + * freeze.adb (Freeze_Expression): The designated type of an + access_to_suprogram type can only be frozen if all types in its profile + are fully defined. + +2010-06-17 Robert Dewar + + * par.adb: Minor comment fix + * sem_aggr.adb, sem_ch3.adb: Minor reformatting + +2010-06-17 Doug Rupp + + * s-auxdec-vms_64.ads: Revert Integer to Long_Integer change, instead + change Address to Short_Address in functions where both must be the + same size for intrinsics to work. + +2010-06-17 Thomas Quinot + + * sem_ch4.adb (Analyze_Selected_Component): A selected component may + not denote a (private) component of a protected object. + +2010-06-17 Bob Duff + + * par-labl.adb (Try_Loop): Test whether the label and the goto are in + the same list. + +2010-06-17 Joel Brobecker + + * gnat_ugn.texi: Update the documentation about GDB re: exception + catchpoints. + +2010-06-17 Arnaud Charlet + + * gnatvsn.ads: Bump to 4.6 version. + +2010-06-17 Ed Schonberg + + * exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration): The + designated type of the generated pointer is the type of the original + expression, not that of the function call itself, because the return + type may be an untagged derived type and the function may be an + inherited operation. + +2010-06-17 Robert Dewar + + * exp_ch4.adb: Minor reformatting. + +2010-06-17 Ed Schonberg + + * sinfo.ads, sinfo.adb (Inherited_Discriminant): New flag on + N_Component_Association nodes, to indicate that a component association + of an extension aggregate denotes the value of a discriminant of an + ancestor type that has been constrained by the derivation. + * sem_aggr.adb (Discr_Present): use Inherited_Discriminant to prevent a + double expansion of the aggregate appearing in a context that delays + expansion, to prevent double insertion of discriminant values when the + aggregate is reanalyzed. + +2010-06-17 Arnaud Charlet + + * exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Do not use + Allocator as the Related_Node of Return_Obj_Access in call to + Make_Temporary below as this would create a sort of infinite + "recursion". + +2010-06-17 Ben Brosgol + + * gnat_ugn.texi: Update gnatcheck doc. + +2010-06-17 Ed Schonberg + + * sem_ch3.adb (Build_Incomplete_Type_Declaration): If there is an + incomplete view of the type that is not tagged, and the full type is a + tagged extension, create class_wide type now, and warn that the + incomplete view should be tagged as well. + +2010-06-17 Vincent Celier + + * gnatcmd.adb (Non_VMS_Usage): Do not issue usage for gnat sync. + Update the last line of the usage, indicating what commands do not + accept project file switches. + * vms_conv.adb: Do not issue usage line for GNAT SYNC + * vms_data.ads: Fix errors in the qualifiers /LOGFILE and /MAIN of + GNAT ELIM. + * gnat_ugn.texi: Document the relaxed rules for library directories in + externally built library projects. + +2010-06-17 Doug Rupp + + * s-auxdec-vms_64.ads: Make boolean and arithmetic operations intrinsic + where possible. + * s-auxdec-vms-alpha.adb: Remove kludges for aforemention. + * gcc-interface/Makefile.in: Update VMS target pairs. + +2010-06-17 Vasiliy Fofanov + + * adaint.c: Reorganized in order to avoid use of GetProcessId to stay + compatible with Windows NT 4.0 which doesn't provide this function. + +2010-06-17 Vincent Celier + + * ali-util.adb (Time_Stamp_Mismatch): In Verbose mode, if there is + different timestamps but the checksum is the same, issue a short + message saying so. + +2010-06-17 Arnaud Charlet + + * s-interr.adb (Finalize): If the Abort_Task signal is set to system, + it means that we cannot reset interrupt handlers since this would + require potentially sending the abort signal to the Server_Task. + +2010-06-17 Ed Schonberg + + * exp_ch4.adb: expand NOT for VMS types. + * sem_util.adb: Use OpenVMS_On_Target for IS_VMS_Operator. + +2010-06-17 Sergey Rybin + + * vms_data.ads: Add qualifier for '--no-elim-dispatch' gnatelim option. + * gnat_ugn.texi (gnatelim): add description for --no-elim-dispatch + option. + +2010-06-17 Ed Schonberg + + * exp_ch6.adb (Expand_Call): Do not expand a call to an internal + protected operation if the subprogram has been eliminated. + +2010-06-17 Vincent Celier + + * prj-nmsc.adb (Check_Library_Attributes): Allow the different + directories associated with a library to be any directory when the + library project is externally built. + +2010-06-17 Vincent Celier + + * make.adb (Check): If switch -m is used, deallocate the memory that + may be allocated when computing the checksum. + +2010-06-17 Eric Botcazou + + * g-socthi-mingw.adb (C_Recvmsg): Add 'use type' clause for C.size_t; + (C_Sendmsg): Likewise. + +2010-06-17 Thomas Quinot + + * sem_res.adb: Update comments. + +2010-06-17 Vincent Celier + + * back_end.adb (Scan_Compiler_Arguments): Process last argument + +2010-06-17 Robert Dewar + + * exp_ch3.adb, exp_ch6.adb, exp_smem.adb, exp_util.adb: Use Ekind_In. + * layout.adb, freeze.adb: Use Make_Temporary. + +2010-06-17 Jerome Lambourg + + * exp_ch11.adb (Expand_N_Raise_Statement): Expand raise statements in + .NET/JVM normally as this is now perfectly supported by the backend. + +2010-06-17 Pascal Obry + + * gnat_rm.texi: Fix minor typo, remove duplicate blank lines. + +2010-06-17 Vincent Celier + + * make.adb (Collect_Arguments_And_Compile): Create include path file + only when -x is specified. + (Gnatmake): Ditto + * opt.ads (Use_Include_Path_File): New Boolean flag, initialized to + False. + * prj-env.adb (Set_Ada_Paths): New Boolean parameters Include_Path and + Objects_Path, defaulted to True. Only create include path file if + Include_Path is True, only create objects path file if Objects_Path is + True. + * prj-env.ads (Set_Ada_Paths): New Boolean parameters Include_Path and + Objects_Path, defaulted to True. + * switch-m.adb (Scan_Make_Switches): Set Use_Include_Path_File to True + when -x is used. + +2010-06-17 Ed Schonberg + + * exp_disp.adb (Build_Interface_Thunk): Use base type of formal to + determine whether it has the controlling type, when the formal is an + access parameter. + +2010-06-17 Eric Botcazou + + * s-crtl.ads (ssize_t): New type. + (read): Fix signature. + (write): Likewise. + * g-socthi.ads: Add 'with System.CRTL' clause. Remove ssize_t and + 'use type' directive for C.size_t, add one for System.CRTL.ssize_t. + (C_Recvmsg): Replace ssize_t with System.CRTL.ssize_t. + (C_Sendmsg): Likewise. + * g-socthi.adb (Syscall_Recvmsg): Likewise. + (Syscall_Sendmsg): Likewise. + (C_Recvmsg): Likewise. + (C_Sendmsg): Likewise. + * g-socthi-mingw.ads: Add 'with System.CRTL' clause. Remove ssize_t + and 'use type' directive for C.size_t, add one for System.CRTL.ssize_t. + (C_Recvmsg): Replace ssize_t with System.CRTL.ssize_t. + (C_Sendmsg): Likewise. + * g-socthi-mingw.adb (C_Recvmsg): Likewise. + (C_Sendmsg): Likewise. + * g-socthi-vms.ads: Add 'with System.CRTL' clause. Remove ssize_t and + 'use type' directive for C.size_t, add one for System.CRTL.ssize_t. + (C_Recvmsg): Replace ssize_t with System.CRTL.ssize_t. + (C_Sendmsg): Likewise. + * g-socthi-vms.adb (C_Recvmsg): Likewise. + (C_Sendmsg): Likewise. + * g-socthi-vxworks.ads Add 'with System.CRTL' clause. Remove ssize_t + and 'use type' directive for C.size_t, add one for System.CRTL.ssize_t. + (C_Recvmsg): Replace ssize_t with System.CRTL.ssize_t. + (C_Sendmsg): Likewise. + * g-socthi-vxworks.adb (C_Recvmsg): Likewise. + (C_Sendmsg): Likewise. + * g-sercom-linux.adb (Read): Use correct types to call 'read'. + (Write): Likewise to call 'write'. + * s-os_lib.adb (Read): Use correct type to call System.CRTL.read. + (Write): Use correct type to call System.CRTL.write. + * s-tasdeb.adb (Write): Likewise. + +2010-06-17 Vincent Celier + + * prj-proc.adb (Copy_Package_Declarations): Change argument name + Naming_Restricted to Restricted. If Restricted is True, do not copy the + value of attribute Linker_Options. + +2010-06-17 Eric Botcazou + + * gcc-interface/trans.c (push_stack, pop_stack): Delete. + (Case_Statement_to_gnu): Adjust. + (Loop_Statement_to_gnu): Likewise. + (Subprogram_Body_to_gnu): Likewise. + (Handled_Sequence_Of_Statements_to_gnu): Likewise. + (Compilation_Unit_to_gnu): Likewise. + +2010-06-17 Robert Dewar + + * exp_fixd.adb, exp_imgv.adb, exp_intr.adb, exp_pakd.adb, exp_prag.adb, + exp_sel.adb, exp_util.adb, sem_ch10.adb, sem_ch12.adb, sem_ch13.adb, + sem_ch3.adb, sem_ch4.adb, sem_ch5.adb, sem_ch8.adb, sem_ch9.adb, + sem_dist.adb, sem_util.adb: Use Make_Temporary + * itypes.ads, tbuild.ads: Minor comment update + * exp_ch9.adb, exp_dist.adb: Minor reformatting + +2010-06-17 Thomas Quinot + + * exp_imgv.adb, exp_ch7.ads: Minor reformatting. + +2010-06-17 Robert Dewar + + * exp_ch9.adb, exp_disp.adb, exp_dist.adb: Use Make_Temporary. + +2010-06-17 Thomas Quinot + + * sprint.adb (pg): Set Dump_Freeze_Null, to be consistent with -gnatdg. + +2010-06-17 Robert Dewar + + * exp_ch6.adb, exp_ch7.adb, exp_ch5.adb: Use Make_Temporary + * tbuild.ads (Make_Temporary): More comment updates + * tbuild.adb: Minor reformatting + +2010-06-17 Robert Dewar + + * checks.adb, exp_aggr.adb, exp_atag.adb, exp_attr.adb, exp_ch11.adb, + exp_ch3.adb, exp_ch4.adb: Minor code reorganization. + Use Make_Temporary. + * tbuild.ads, tbuild.adb (Make_Temporary): Clean up, use Entity_Id + instead of Node_Id. + (Make_Temporary): Add more extensive documentation + +2010-06-17 Robert Dewar + + * sem_intr.adb, sem_prag.adb, sem_res.adb, sem_type.adb, sem_util.adb, + sem_warn.adb, sem_eval.adb: Minor reformatting. Use Ekind_In. + (Set_Slice_Subtype): Explicitly freeze the slice's itype at the point + where the slice's actions are inserted. + (Decompose_Expr): Account for possible rewriting of slice bounds + resulting from side effects suppression caused by the above freezing, + so that folding of bounds is preserved by such rewriting. + +2010-06-17 Robert Dewar + + * einfo.ads, einfo.adb (Get_Record_Representation_Clause): New + function. + * freeze.adb (Freeze_Record_Type): Add call to + Check_Record_Representation_Clause. + * sem_ch13.adb (Check_Record_Representation_Clause): New function + (Analyze_Record_Representation_Clause): Split out overlap code into + this new function. + (Check_Component_Overlap): Moved inside + Check_Record_Representation_Clause. + * sem_ch13.ads (Check_Record_Representation_Clause): New function. + +2010-06-17 Robert Dewar + + * back_end.adb, sem_res.adb, switch-c.adb, sem_scil.adb: Minor + reformatting. + * sem_attr.adb, sem_cat.adb, sem_disp.adb, sem_elab.adb, sem_elim.adb, + sem_eval.adb: Use Ekind_In + +2010-06-17 Ed Schonberg + + * sem_ch8.adb: better error message for illegal inherited discriminant + +2010-06-17 Vincent Celier + + * bindusg.adb: Remove lines for -A and -C + * gnat_ugn.texi: Remove all documentation and examples of switches -A + and -C for gnatbind and gnatlink. + * gnatlink.adb (Usage): Remove lines for -A and -C + * switch-b.adb (Scan_Binder_Switches): Issue warning when switch -C is + specified. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-17 Vincent Celier + + * back_end.adb (Scan_Compiler_Arguments): Put all arguments in new + local Argument_List variable Args. + * switch-c.adb (Scan_Front_End_Switches): New Argument_List argument + Args. + (Switch_Subsequently_Cancelled): New Argument_List argument Args. Look + for subsequent switches in Args. + * switch-c.ads (Scan_Front_End_Switches): New Argument_List argument + Args. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-17 Robert Dewar + + * einfo.adb: Minor code fix, allow E_Class_Wide_Type for + Equivalent_Type to match documentation. + +2010-06-17 Robert Dewar + + * sem_ch6.adb, sem_ch7.adb: Minor reformatting. + * sem_ch3.adb, sem_ch5.adb, sem_ch9.adb, sem_ch10.adb, sem_ch12.adb, + sem_ch4.adb, sem_ch8.adb, sem_ch13.adb: Make use of Ekind_In. + +2010-06-17 Thomas Quinot + + * sem_res.adb (Set_Slice_Subtype): Always freeze the slice's itype. + +2010-06-17 Thomas Quinot + + * freeze.adb (Freeze_Expression): Short circuit operators are valid + freeze node insertion points. + +2010-06-17 Robert Dewar + + * switch-c.ads, switch-c.adb, sem_ch13.adb: Minor reformatting. + * sem_ch12.adb: Add pragmas Assert and Check to previous change. + +2010-06-17 Gary Dismukes + + * layout.adb (Layout_Type): Broaden test for setting an array type's + Component_Size to include all scalar types, not just discrete types + (components of real types were missed). + * sem_ch3.adb (Constrain_Index): Add missing setting of First_Literal + on the itype created for an index (consistent with Make_Index and + avoids possible Assert_Failures). + +2010-06-17 Robert Dewar + + * atree.ads, atree.adb: Add 6-parameter version of Ekind_In + * einfo.adb: Minor code reformatting (use Ekind_In) + +2010-06-17 Robert Dewar + + * sem_warn.adb (Test_Ref): Abandon scan if access subprogram parameter + found. + +2010-06-17 Vincent Celier + + * back_end.adb: Minor comment updates + * switch-c.adb: Remove dependencies on gcc C sources + * gcc-interface/Make-lang.in: Add a-comlin.o to the object file list + for the compiler. + +2010-06-17 Ed Schonberg + + * sem_ch12.adb: propagate Pragma_Enabled flag to generic. + * get_scos.adb: Set C2 flag in decision entry of pragma to 'e'. + * par_sco.ads, par_sco.adb (Set_SCO_Pragma_Enabled): New procedure + Remove use of Node field in SCOs table + (Output_Header): Set 'd' to initially disable pragma entry + * put_scos.adb (Put_SCOs): New flag indicating if pragma is enabled + * scos.ads, scos.adb: Remove Node field from internal SCOs table. + Use C2 field of pragma decision header to indicate enabled. + * sem_prag.adb: Add calls to Set_SCO_Pragma_Enabled. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-17 Vincent Celier + + * back_end.adb (Next_Arg): Moved to procedure Scan_Compiler_Arguments + (Scan_Compiler_Arguments): Call Scan_Front_End_Switches with Next_Arg + (Switch_Subsequently_Cancelled): Function moved to the body of Switch.C + * back_end.ads (Scan_Front_End_Switches): Function moved to the body of + Switch.C. + * switch-c.adb: Copied a number of global declarations from + back_end.adb. + (Len_Arg): New function copied from back_end.adb + (Switch_Subsequently_Cancelled): New function moved from back_end.adb + (Scan_Front_End_Switches): New parameter Arg_Rank used to call + Switch_Subsequently_Cancelled. + * switch-c.ads (Scan_Front_End_Switches): New parameter Arg_Rank. + * gcc-interface/Makefile.in: Add line so that shared libgnat is linked + with -lexc on Tru64. + +2010-06-17 Robert Dewar + + * prj.ads, prj.adb: Minor reformatting + +2010-06-17 Thomas Quinot + + * put_scos.adb: Do not generate a blank line in SCOs when omitting the + CP line for a disabled pragma. + +2010-06-17 Emmanuel Briot + + * prj-proc.adb, prj.adb, prj.ads (Check_Or_Set_Typed_Variable): New + subprogram. + (Process_Declarative_Item): An invalid value in an typed variable + declaration is no longer always fatal. + +2010-06-16 Arnaud Charlet + + * get_scos.adb, par_sco.adb, par_sco.ads, put_scos.adb, scos.adb, + scos.ads, exp_ch4.adb, sem_warn.adb: Code clean up, update + documentation. + +2010-06-16 Javier Miranda + + * exp_disp.adb (Expand_Dispatching_Call): Adjust the decoration of the + node referenced by the SCIL node of dispatching "=" to skip the tags + comparison. + +2010-06-16 Ed Schonberg + + * sem_ch5.adb (Analyze_Exit_Statement): Return if no enclosing loop, + to prevent cascaded errors and compilation aborts. + +2010-06-16 Robert Dewar + + * back_end.adb (Switch_Subsequently_Cancelled): New function + Move declarations to package body level to support this change + * back_end.ads (Switch_Subsequently_Cancelled): New function + * gnat_ugn.texi: Document -gnat-p switch + * switch-c.adb (Scan_Front_End_Switches): Implement -gnat-p switch + * ug_words: Add entry for -gnat-p (UNSUPPRESS_ALL) + * usage.adb: Add line for -gnat-p switch + * vms_data.ads: Add entry for UNSUPPRESS_ALL (-gnat-p) + +2010-06-16 Robert Dewar + + * sem_warn.adb (Check_Infinite_Loop_Warning): Declaration counts as + modification. + +2010-06-16 Robert Dewar + + * exp_disp.adb: Minor reformatting + +2010-06-16 Ed Schonberg + + * sem_ch3.adb (Complete_Private_Subtype): Inherit class_wide type from + base type only if it was not previously created for the partial view. + +2010-06-16 Thomas Quinot + + * tbuild.ads: Minor comment fix + +2010-06-15 Nathan Froyd + + * gcc-interface/trans.c (gnu_stack_free_list): Delete. + (gnu_except_ptr_stack): Change type to VEC. Update comment. + (gnu_elab_proc_stack): Likewise. + (gnu_return_label_stack): Likewise. + (gnu_loop_label_stack): Likewise. + (gnu_switch_label_stack): Likewise. + (gnu_constraint_label_stack): Likewise. + (gnu_storage_error_label_stack): Likewise. + (gnu_program_error_label_stack): Likewise. + (push_exception_label_stack): Take a VEC ** instead of a tree *. + (push_stack): Likewise. Remove unused second parameter. Update + callers. + (pop_stack): Take a VEC * instead of a tree *. Update callers. + (gigi): Initialize stacks as VECs. + (Identifier_to_gnu): Use VEC_last instead of TREE_VALUE. + (Case_Statement_to_gnu): Likewise. + (Subprogram_Body_to_gnu): Likewise. + (call_to_gnu): Likewise. + (Exception_Handler_to_gnu_sjlj): Likewise. + (gnat_to_gnu): Likewise. + (get_exception_label): Likewise. + +2010-06-14 Ed Schonberg + + * sem_ch3.adb (Build_Derived_Record_Type): if derived type is an + anonymous base generated when the parent is a constrained discriminated + type, propagate interface list to first subtype because it may appear + in a current instance within the extension part of the derived type + declaration, and its own subtype declaration has not been elaborated + yet. + * exp_disp.adb (Build_Interface_Thunk): Use base type of formal to + determine whether it has the controlling type. + +2010-06-14 Jerome Lambourg + + * exp_ch11.adb (Expand_N_Raise_Statement): Make sure that the explicit + raise of CE, SE and PE have the reason correctly set and are properly + expanded before stopping the expansions of .NET/JVM exceptions. + +2010-06-14 Robert Dewar + + * opt.ads (Check_Policy_List): Add some clarifying comments + * sem_prag.adb (Analyze_Pragma, case Check): Set Pragma_Enabled flag + on rewritten Assert pragma. + +2010-06-14 Gary Dismukes + + * sem_ch6.adb (Check_Overriding_Indicator): Add a special check for + controlled operations, so that they will be treated as overriding even + if the overridden subprogram is marked Is_Hidden, as long as the + overridden subprogram's parent subprogram is not hidden. + +2010-06-14 Robert Dewar + + * debug.adb: Entry for gnatw.d no longer specific for while loops + * einfo.adb (First_Exit_Statement): New attribute for E_Loop + * einfo.ads (First_Exit_Statement): New attribute for E_Loop + * sem_ch5.adb (Analyze_Loop_Statement): Check_Infinite_Loop_Warning has + new calling sequence to include test for EXIT WHEN. + (Analyze_Exit_Statement): Chain EXIT statement into exit statement + chain + * sem_warn.ads, sem_warn.adb (Check_Infinite_Loop_Warning): Now handles + EXIT WHEN case. + * sinfo.adb (Next_Exit_Statement): New attribute of N_Exit_Statement + node. + * sinfo.ads (N_Pragma): Correct comment on Sloc field (points to + PRAGMA, not to pragma identifier). + (Next_Exit_Statement): New attribute of N_Exit_Statement node + +2010-06-14 Robert Dewar + + * sem_res.adb (Resolve_Short_Circuit): Fix sloc of "assertion/check + would fail" msg. + +2010-06-14 Robert Dewar + + * par-ch2.adb (Scan_Pragma_Argument_Association): Clarify message for + missing pragma argument identifier. + +2010-06-14 Robert Dewar + + * atree.ads, atree.adb (Ekind_In): New functions. + +2010-06-14 Robert Dewar + + * exp_ch4.adb (Expand_N_Op_Expon): Optimize 2**N in stand alone context + +2010-06-14 Robert Dewar + + * usage.adb (Usage): Redo documentation of -gnatwa. + +2010-06-14 Ed Schonberg + + * sem_ch8.adb (Find_Type): The attribute 'class cannot be applied to + an untagged incomplete type that is a limited view. + +2010-06-14 Sergey Rybin + + * gnat_ugn.texi: Add description of '-cargs gcc_switches' to gnatstub + and gnatppa. + +2010-06-14 Thomas Quinot + + * exp_ch4.adb (Expand_Short_Circuit_Operator): New subprogram, + factoring duplicated code between... + (Expand_N_And_Than, Expand_N_Or_Else): Remove duplicated code. + * a-envvar.ads: Minor reformatting + +2010-06-14 Arnaud Charlet + + * ali.adb, ali.ads, lib-xref.ads: Document new '+' letter for C/C++ + static entities. + (Scan_ALI): Take into account new Visibility field. + (Visibility_Kind): New type. + (Xref_Entity_Record): Replace Lib field by Visibility. + + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-14 Pascal Obry + + * raise.h: Remove unused defintions. + +2010-06-14 Bob Duff + + * par-ch10.adb (P_Subunit): If the next token after "separate(X)" is + Tok_Not or Tok_Overriding, call P_Subprogram. We had previously given + the incorrect error "proper body expected". + * par-ch6.adb (P_Subprogram): Suppress "overriding indicator not + allowed here" error in case of subunits, which was triggered by the + above change to P_Subunit. + +2010-06-14 Sergey Rybin + + * gnat_ugn.texi, vms_data.ads: Update gnatelim doc. + +2010-06-14 Thomas Quinot + + * lib-util.adb: Minor code reorganization. + +2010-06-14 Robert Dewar + + * ali.adb (Scan_ALI): Implement reading and storing of N lines + (Known_ALI_Lines): Add entry for 'N' (notes) + * ali.ads (Notes): New table to store Notes information + * alloc.ads: Add entries for Notes table + * lib-util.adb (Write_Info_Int): New procedure + (Write_Info_Slit): New procedure + (Write_Info_Uint): New procedure + * lib-util.ads (Write_Info_Int): New procedure + (Write_Info_Slit): New procedure + (Write_Info_Uint): New procedure + * lib-writ.adb (Write_Unit_Information): Output N (notes) lines + * lib-writ.ads: Update documentation for N (Notes) lines + * lib.adb (Store_Note): New procedure + * lib.ads (Notes): New table + (Store_Note): New procedure + * sem_prag.adb: Call Store_Note for affected pragmas + +2010-06-14 Thomas Quinot + + * socket.c: Fix wrong condition in #ifdef + * g-socket.adb, g-sothco.ads: Functions imported from socket.c that + take or return char* values can't use Interfaces.C.Strings.chars_ptr, + because on VMS this type is a 32-bit pointer which is not compatible + with the default for C pointers for code compiled with gcc on that + platform. + +2010-06-14 Ed Schonberg + + * sem_util (Is_VMS_Operator): New predicate to determine whether an + operator is an intrinsic operator declared in the DEC system extension. + * sem_res.adb (Resolve_Logical_Op): operation is legal on signed types + if the operator is a VMS intrinsic. + * sem_eval.adb (Eval_Logical_Op): Operation is legal and be + constant-folded if the operands are signed and the operator is a VMS + intrinsic. + +2010-06-14 Robert Dewar + + * g-socket.adb, gnatcmd.adb: Minor reformatting. + +2010-06-14 Pascal Obry + + * s-finimp.adb: Fix typo. + * raise.h: Remove duplicate blank line. + +2010-06-14 Vincent Celier + + * prj-nmsc.adb (Add_Sources): Always set the object file and the + switches file names, as the configuration of the language may change + in an extending project. + (Process_Naming_Scheme): For sources of projects that are extended, set + the configuration of the language from the highest extending project + where the language is declared. + +2010-06-14 Gary Dismukes + + * sem_res.adb (Resolve_Call): For infinite recursion check, test + whether the called subprogram is inherited from a containing + subprogram. + (Same_Or_Aliased_Subprograms): New function + +2010-06-14 Ed Schonberg + + * sem_ch8.adb (End_Use_Type): Before indicating that an operator is not + use-visible, check whether it is a primitive for more than one type. + +2010-06-14 Robert Dewar + + * sem_ch3.adb (Copy_And_Swap): Copy Has_Pragma_Unmodified flag. + + * sem_ch7.adb (Preserve_Full_Attributes): Preserve + Has_Pragma_Unmodified flag. + +2010-06-14 Thomas Quinot + + * g-sttsne-locking.adb, g-sttsne-locking.ads, g-sttsne.ads, + g-sttsne-vxworks.adb, g-sttsne-dummy.ads: Removed. Mutual exclusion is + now done in GNAT.Sockets if necessary. + * gsocket.h, g-socket.adb, g-sothco.ads (GNAT.Sockets.Get_XXX_By_YYY): + Ensure mutual exclusion for netdb operations if the target platform + requires it. + (GNAT.Sockets.Thin_Common): New binding for getXXXbyYYY, treating + struct hostent as an opaque type to improve portability. + * s-oscons-tmplt.c, socket.c: For the case of Vxworks, emulate + gethostbyYYY using proprietary VxWorks API so that a uniform interface + is available for the Ada side. + * gcc-interface/Makefile.in: Remove g-sttsne-* + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-14 Vincent Celier + + * gnatcmd.adb (Mapping_File): New function. + +2010-06-14 Javier Miranda + + * sem_ch3.adb (Derive_Subprograms): Remove over-restrictive assertion. + +2010-06-14 Arnaud Charlet + + * ali.adb: Fix typo. + * s-auxdec-vms-alpha.adb, scng.ads: Minor reformatting. + +2010-06-14 Ed Schonberg + + * sem_ch12.adb: Make Mark_Context transitive, and apply to subprogram + instances. + + * sem_ch8.adb (Find_Expanded_Name): If a candidate compilation unit in + the context does not have a homonym of the selector, emit default + error message. + +2010-06-14 Robert Dewar + + * sem.adb, sem_ch12.adb, sem_util.adb: Minor reformatting and + comment addition. + +2010-06-14 Arnaud Charlet + + * lib-xref.ads: Doc updates: + - Allocate 'Q' for #include entity kind + - Free 'Z' + - Allocate 'g' for regular macros + - Allocate 'G' for function-like macros + +2010-06-14 Ed Schonberg + + * sinfo.ads, sinfo.adb (Withed_Body): New attribute of a with_clause. + Indicates that there is an instantiation in the current unit that + loaded the body of the unit denoted by the with_clause. + * sem_ch12.adb (Mark_Context): When instanting a generic body, check + whether a with_clause in the current context denotes the unit that + holds the generic declaration, and mark the with_clause accordingly. + (Instantiate_Package_Body): call Mark_Context. + * sem.adb (Process_Bodies_In_Context): Use Withed_Body to determine + whether a given body should be traversed before the spec of the main + unit. + +2010-06-14 Ed Falis + + * sysdep.c: Fix 653 build against vThreads headers. + +2010-06-14 Robert Dewar + + * sinfo.ads: Minor reformatting. + +2010-06-14 Ed Schonberg + + * sem_ch6.adb (Analyze_Subprogram_Body): Do not check conformance when + the spec has been generated for a body without spec that carries an + Inline_Always pragma. + +2010-06-14 Arnaud Charlet + + * lib-xref.ads: Documentation change: allocate 'Z' letter to C/C++ + macro. + +2010-06-14 Jerome Lambourg + + * exp_dbug.adb (Debug_Renaming_Declaration): Do not output any debug + declaration for VMs, as those are useless and might lead to duplicated + local variable names in the generated code. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-14 Robert Dewar + + * opt.ads, sem.adb, sem_elab.adb: Minor reformatting + +2010-06-14 Robert Dewar + + * exp_aggr.adb (Has_Address_Clause): Moved to Exp_Util, and there it + is renamed as Has_Following_Address_Clause. + * exp_ch3.adb (Needs_Simple_Initialization): Add Consider_IS argument + to allow the caller to avoid Initialize_Scalars having an effect. + (Expand_N_Object_Declaration): Do not do Initialize_Scalars stuff for + scalars with an address clause specified. + * exp_ch3.ads (Needs_Simple_Initialization): Add Consider_IS argument + to allow the caller to avoid Initialize_Scalars having an effect. + * exp_util.adb (Has_Following_Address_Clause): Moved here from Exp_Aggr + (where it was called Has_Address_Clause). + * exp_util.ads (Has_Following_Address_Clause): Moved here from Exp_Aggr + (where it was called Has_Address_Clause). + * freeze.adb (Warn_Overlay): Suppress message about overlaying causing + problems for Initialize_Scalars (since we no longer initialize objects + with an address clause. + +2010-06-14 Robert Dewar + + * exp_prag.adb (Expand_Pragma_Check): Set Loc of generated code from + condition. + +2010-06-14 Gary Dismukes + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Set Debug_Info_Needed + on the entity of an implicitly generated postcondition procedure. + +2010-06-14 Thomas Quinot + + * sem_ch7.adb (Preserve_Full_Attributes): Propagate + Discriminant_Constraint elist from full view to private view. + +2010-06-14 Robert Dewar + + * sem_res.adb: Minor reformatting. + +2010-06-14 Ed Schonberg + + * sem.adb: New version of unit traversal. + + * sem_elab.adb (Check_Internal_Call): Do not place a call appearing + within a generic unit in the table of delayed calls. + +2010-06-14 Robert Dewar + + * gnatcmd.adb, sem_util.adb, exp_ch3.adb: Minor reformatting + +2010-06-14 Ed Schonberg + + * sem_ch12.adb (Save_References): If an identifier has been rewritten + during analysis as an explicit dereference, keep the reference implicit + in the generic, but preserve the entity if global. This prevents + malformed generic trees in the presence of some nested generics. + +2010-06-14 Sergey Rybin + + * gnat_ugn.texi: For the GNAT driver, clarify the effect of calling the + tool with '-files=' option. Also fix some small errors (wrong brackets) + +2010-06-14 Vincent Celier + + * gnatbind.adb: Call Scan_ALI with Directly_Scanned set to True for all + the ALI files on the command line. + + * ali.adb (Scan_ALI): Set component Directly_Scanned of the unit(s) to + the same value as the parameter of the same name. + * ali.ads (Scan_ALI): New Boolean parameter Directly_Scanned, defaulted + to False. + * bindgen.adb (Gen_Versions_Ada): Never emit version symbols for + Stand-Alone Library interfaces. When binding Stand-Alone Libraries, + emit version symbols only for the units of the library. + (Gen_Versions_C): Ditto. + +2010-06-14 Gary Dismukes + + * sem_ch4.adb: Fix typo. + +2010-06-14 Vasiliy Fofanov + + * s-oscons-tmplt.c (IOV_MAX): redefine on Tru64 and VMS since the + vector IO doesn't work at default value properly. + +2010-06-14 Doug Rupp + + * s-stoele.adb: Remove unnecessary qualification of To_Address for VMS. + +2010-06-14 Vincent Celier + + * gnatcmd.adb (Check_Files): Do not invoke the tool with all the + sources of the project if a switch -files= is used. + +2010-06-14 Thomas Quinot + + * exp_attr.adb: Minor reformatting. + +2010-06-14 Gary Dismukes + + * gnat_ugn.texi: Minor typo fixes and wording changes. + +2010-06-14 Ed Schonberg + + * sem_ch4.adb (Analyze_One_Call): If the call has been rewritten from a + prefixed form, do not re-analyze first actual, which may need an + implicit dereference. + * sem_ch6.adb (Analyze_Procedure_Call): If the call is given in + prefixed notation, the analysis will rewrite the node, and possible + errors appear in the rewritten name of the node. + * sem_res.adb: If a call is ambiguous because its first parameter is + an overloaded call, report list of candidates, to clarify ambiguity of + enclosing call. + +2010-06-14 Doug Rupp + + * s-auxdec-vms-alpha.adb: New package body implementing legacy + VAX instructions with Asm insertions. + * s-auxdec-vms_64.ads: Inline VAX queue functions + * s-stoele.adb: Resolve some ambiguities in To_Addresss with s-suxdec + that show up only on VMS. + * gcc-interface/Makefile.in: Provide translation for + s-auxdec-vms-alpha.adb. + +2010-06-14 Olivier Hainque + + * initialize.c (VxWorks section): Update comments. + +2010-06-14 Robert Dewar + + * a-convec.adb, sem_prag.adb, checks.adb: Minor reformatting. + +2010-06-14 Eric Botcazou + + * init.c: Code clean up. + +2010-06-14 Ed Schonberg + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause, case Address): Do + not insert address clause in table for later validation if type of + entity is generic, to prevent possible spurious errors. + + * sem_ch8.adb: Code clean up. + +2010-06-14 Ben Brosgol + + * gnat_ugn.texi: Expanded @ovar macro inline to solve problem with + texi2pdf and texi2html. + Document how to change scheduling properties on HP-UX. + +2010-06-14 Thomas Quinot + + * g-socket.ads: Remove misleading comments. + +2010-06-14 Jerome Lambourg + + * sem_prag.adb (Check_Duplicated_Export_Name): Remove check for + CLI_Target as this prevents proper detection of exported names + duplicates when the exported language is different to CIL. + (Process_Interface_Name): Add check for CIL convention exports, + replacing the old one from Check_Duplicated_Export_Name. + +2010-06-14 Matthew Heaney + + * a-coinve.adb, a-convec.adb (operator "&"): Check both that new length + and new last satisfy constraints. + (Delete_Last): prevent overflow for subtraction of index values + (To_Vector): prevent overflow for addition of index values + +2010-06-14 Ed Schonberg + + * sem_ch4.adb (Complete_Object_Operation): After analyzing the + rewritten call, preserve the resulting type to prevent spurious errors, + when the call is implicitly dereferenced in the context of an in-out + actual. + + * checks.adb (Apply_Discriminant_Check): If the target of the + assignment is a renaming of a heap object, create constrained type for + it to apply check. + +2010-06-14 Pascal Obry + + * prj-proc.adb: Fix copy of object directory for extending projects. + +2010-06-14 Jose Ruiz + + * init.c (__gnat_alternate_stack): Define this space for PowerPC linux + (__gnat_install_handler, PowerPC linux): Activate the alternative + signal stack. + +2010-06-13 Gerald Pfeifer + + * gnat_rm.texi: Move to GFDL version 1.3. + * gnat-style.texi: Ditto. + * gnat_ugn.texi: Ditto. + +2010-06-12 Kai Tietz + + PR ada/43731 + * gcc-interface/Makefile.in: Add rules for multilib x86/x64 + mingw targets. + +2010-06-11 Alexandre Oliva + + * gcc-interface/utils.c (update_pointer_to): Initialize last. + +2010-06-09 Eric Botcazou + + * gcc-interface/ada-tree.h: Fix formatting nits. + +2010-06-08 Laurynas Biveinis + + * gcc-interface/utils.c (init_gnat_to_gnu): Use typed GC + allocation. + (init_dummy_type): Likewise. + (gnat_pushlevel): Likewise. + + * gcc-interface/trans.c (Attribute_to_gnu): Likewise. + (Subprogram_Body_to_gnu): Likewise. + (Compilation_Unit_to_gnu): Likewise. + (start_stmt_group): Likewise. + (extract_encoding): Likewise. + (decode_name): Likewise. + + * gcc-interface/misc.c (gnat_printable_name): Likewise. + + * gcc-interface/decl.c (annotate_value): Likewise. + + * gcc-interface/ada-tree.h (struct lang_type): Add variable_size + GTY option. + (struct lang_decl): Likewise. + (SET_TYPE_LANG_SPECIFIC): Use typed GC allocation. + (SET_DECL_LANG_SPECIFIC): Likewise. + +2010-06-04 Eric Botcazou + + * gnatlink.adb (gnatlink): Remove support for -fsjlj switch. + * gcc-interface/lang-specs.h: Likewise. + +2010-06-03 H.J. Lu + + PR c++/44294 + * gcc-interface/decl.c (MAX_FIXED_MODE_SIZE): Removed. + +2010-06-01 Arnaud Charlet + + * gnat_ugn.texi: Improve doc on -fdump-ada-spec, mention limitations. + +2010-05-30 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Reuse the + TYPE_DECL of the equivalent type instead of building a new one. + +2010-05-30 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity): Adjust warning message. + Fix nits in comments. + * gcc-interface/misc.c (gnat_init_gcc_eh): Likewise. + * gcc-interface/trans.c (gigi): Likewise. + (Attribute_to_gnu): Likewise. + (Case_Statement_to_gnu): Likewise. + (gnat_to_gnu): Adjust warning message. + * gcc-interface/utils.c (create_var_decl_1): Fix nits in comments. + (build_vms_descriptor32): Likewise. + +2010-05-27 Steven Bosscher + + * gcc-interface/decl.c: Pretend to be a backend file by undefining + IN_GCC_FRONTEND (still need rtl.h here). + +2010-05-26 Steven Bosscher + + * gcc-interface/trans.c: Do not include rtl.h, insclude libfuncs.h. + (gigi): Adjust call to set_stack_check_libfunc. + +2010-05-26 Steven Bosscher + + * gcc-interface/utils.c: Do not include rtl.h. + +2010-05-25 Steven Bosscher + + * gcc-interface/utils.c: Do not include function.h, pointer-set.h, + and gimple.h. Explain why rtl.h has to be included. + (handle_vector_size_attribute): Call reconstruct_complex_type directly. + * gcc-interface/targtyps.c: Do not include tm_p.h + * gcc-interface/utils2.c: Do not include flags.h. + * gcc-interface/trans.c: Do not include expr.h. Include rtl.h instead, + and explain why it has to be included. + * gcc-interface/misc.c: Do not include expr.h, libfuncs.h, cgraph.h, + and optabs.h. + Include function.h and explain why. Explain why except.h is included. + (enumerate_modes): Remove unused function. + * gcc-interface/gigi.h (enumerate_modes): Remove prototype. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-05-25 Joseph Myers + + * gcc-interface/misc.c (internal_error_function): Add context + parameter. Use it to access show_column flag and instead of using + global_dc. Call warn_if_plugins. + * gcc-interface/Make-lang.in (ada/misc.o): Update dependencies. + +2010-05-19 Eric Botcazou + + * gcc-interface/misc.c (LANG_HOOKS_DEEP_UNSHARING): Redefine. + * gcc-interface/trans.c (unshare_save_expr): Delete. + (gigi): Do not unshare trees under SAVE_EXPRs here. + +2010-05-18 Nathan Froyd + + * gcc-interface/trans.c (call_to_gnu): Use build_call_vec instead of + build_call_list. + * gcc-interface/utils.c (build_function_stub): Likewise. + +2010-05-16 Manuel López-Ibáñez + + * gcc-interface/misc.c (gnat_handle_option): Remove special logic + for Wuninitialized without -O. + +2010-05-16 Eric Botcazou + + * gcc-interface/gigi.h (enum standard_datatypes): Add new value + ADT_exception_data_name_id. + (exception_data_name_id): New define. + * gcc-interface/trans.c (gigi): Initialize it. + * gcc-interface/decl.c (gnat_to_gnu_entity) : Use the standard + exception type for standard exception definitions. Do not make them + volatile. + : Equate fields of types associated with an exception + definition to those of the standard exception type. + +2010-05-13 Andreas Schwab + + * tracebak.c (__gnat_backtrace): Mark top_stack with ATTRIBUTE_UNUSED. + +2010-05-12 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Tidy up + code, improve comments and fix formatting nits. + +2010-05-12 Eric Botcazou + + * gcc-interface/utils.c (update_pointer_to): Return early if the old + pointer already points to the new type. Chain the old pointer and its + variants at the end of new pointer's chain after updating them. + +2010-05-10 Eric Botcazou + + * exp_disp.adb (Make_Tags): Mark the imported view of dispatch tables + built for interfaces. + * gcc-interface/decl.c (gnat_to_gnu_entity) : Use + imported_p instead of Is_Imported when considering constants. + Do not promote alignment of exported objects. + : Strip all suffixes for dispatch table entities. + +2010-05-08 Eric Botcazou + + * exp_disp.adb (Make_Tags): Mark the imported view of dispatch tables. + * gcc-interface/decl.c (gnat_to_gnu_entity) : Make imported + constants really constant. + : Strip the suffix for dispatch table entities. + +2010-05-08 Eric Botcazou + + * gcc-interface/decl.c (make_aligning_type): Declare the type. + +2010-05-08 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity): Create variables for size + expressions of variant part of record types declared at library level. + +2010-05-08 Eric Botcazou + + * gcc-interface/gigi.h (create_field_decl): Move PACKED parameter. + * gcc-interface/utils.c (create_field_decl): Move PACKED parameter. + (rest_of_record_type_compilation): Adjust call to create_field_decl. + (make_descriptor_field): Likewise and pass correctly typed constants. + (build_unc_object_type): Likewise. + (unchecked_convert): Likewise. + * gcc-interface/decl.c (elaborate_expression_2): New static function. + (gnat_to_gnu_entity): Use it to make alignment factors explicit. + Adjust call to create_field_decl. + (make_aligning_type): Likewise. + (make_packable_type): Likewise. + (maybe_pad_type): Likewise. + (gnat_to_gnu_field): Likewise. + (components_to_record): Likewise. + (create_field_decl_from): Likewise. + (create_variant_part_from): Remove superfluous test. + * gcc-interface/trans.c (gigi): Adjust call to create_field_decl. + +2010-05-08 Eric Botcazou + + * gcc-interface/gigi.h (build_unc_object_type): Add DEBUG_INFO_P param. + (build_unc_object_type_from_ptr): Likewise. + * gcc-interface/utils.c (build_unc_object_type): Add DEBUG_INFO_P param + and pass it to create_type_decl. Declare the type. Simplify. + (build_unc_object_type_from_ptr): Add DEBUG_INFO_P parameter and pass + it to build_unc_object_type. + * gcc-interface/decl.c (gnat_to_gnu_entity): Adjust to above change. + * gcc-interface/trans.c (Attribute_to_gnu): Likewise. + (gnat_to_gnu): Likewise. + * gcc-interface/utils2.c (build_allocator): Likewise. + +2010-05-07 Eric Botcazou + + PR 40989 + * gcc-interface/misc.c (gnat_handle_option): Fix long line. + +2010-05-06 Rainer Orth + + * gcc-interface/Makefile.in: Removed mips-sgi-irix5* support. + +2010-05-06 Manuel López-Ibáñez + + PR 40989 + * gcc-interface/misc.c (gnat_handle_option): Add argument kind. + +2010-05-02 Giuseppe Scrivano + + * gnathtml.pl: Use 755 as mask for new directories. + +2010-04-28 Eric Botcazou + + * gcc-interface/trans.c (gnat_gimplify_expr) : Uniquize + constant constructors before taking their address. + +2010-04-25 Eric Botcazou + + * exp_dbug.ads: Fix outdated description. Mention link between XVS + and XVZ objects. + * gcc-interface/decl.c (gnat_to_gnu_entity) : Set + XVZ variable as unit size of XVS type. + (maybe_pad_type): Likewise. + +2010-04-25 Eric Botcazou + + * gcc-interface/trans.c (gnat_to_gnu) : Do not + use memmove if the array type is bit-packed. + +2010-04-18 Eric Botcazou + + * gcc-interface/misc.c (gnat_init): Remove second argument in call to + build_common_tree_nodes. + +2010-04-18 Ozkan Sezer + + * gsocket.h: Make sure that winsock2.h is included before windows.h. + +2010-04-17 Eric Botcazou + + * gcc-interface/utils2.c (build_unary_op) : Do not + issue warning. + +2010-04-17 Eric Botcazou + + * uintp.h (UI_Lt): Declare. + * gcc-interface/decl.c (gnat_to_gnu_entity) : Do the size + computation in sizetype. + : Use unified handling for all index types. Do not + generate MAX_EXPR-based expressions, only COND_EXPR-based ones. Add + bypass for PATs. + (annotate_value): Change test for negative values. + (validate_size): Apply test for negative values on GNAT nodes. + (set_rm_size): Likewise. + * gcc-interface/misc.c (gnat_init): Set unsigned types for sizetypes. + * gcc-interface/utils.c (rest_of_record_type_compilation): Change test + for negative values. + (max_size) : Do not reassociate a COND_EXPR on the LHS. + (builtin_type_for_size): Adjust definition of signed_size_type_node. + * gcc-interface/utils2.c (compare_arrays): Optimize comparison of + lengths against zero. + +2010-04-17 Eric Botcazou + + * back-end.adb (Call_Back_End): Pass Standard_Character to gigi. + * gcc-interface/gigi.h (gigi): Add standard_character parameter. + (CHAR_TYPE_SIZE, SHORT_TYPE_SIZE, INT_TYPE_SIZE, LONG_TYPE_SIZE, + LONG_LONG_TYPE_SIZE, FLOAT_TYPE_SIZE, DOUBLE_TYPE_SIZE, + LONG_DOUBLE_TYPE_SIZE, SIZE_TYPE): Delete. + * gcc-interface/decl.c (gnat_to_gnu_entity) : Call + rm_size. + * gcc-interface/misc.c (gnat_init): Set signedness of char as per + flag_signed_char. Tag sizetype with "size_type" moniker. + * gcc-interface/trans.c (gigi): Add standard_character parameter. + Remove useless built-in types. Equate unsigned_char_type_node to + Standard.Character. Use it instead of char_type_node throughout. + (Attribute_to_gnu): Likewise. + (gnat_to_gnu): Likewise. + * gcc-interface/utils2.c (build_call_raise): Likewise. + +2010-04-17 Eric Botcazou + + * gcc-interface/gigi.h (enum standard_datatypes): Add new values + ADT_sbitsize_one_node and ADT_sbitsize_unit_node. + (sbitsize_one_node): New macro. + (sbitsize_unit_node): Likewise. + * gcc-interface/decl.c (gnat_to_gnu_entity) : Fix + latent bug in the computation of subrange_p. Fold wider_p predicate. + (cannot_be_superflat_p): Use an explicitly signed 64-bit type to do + the final comparison. + (make_aligning_type): Build real negation and use sizetype throughout + the offset computation. + (maybe_pad_type): Do not issue the warning when the new size expression + is too complex. + (annotate_value) : Simplify code handling negative values. + * gcc-interface/misc.c (gnat_init): Initialize sbitsize_one_node and + sbitsize_unit_node. + * gcc-interface/trans.c (Attribute_to_gnu) : Fold + double negation. + (gnat_to_gnu) : Likewise. + * gcc-interface/utils.c (convert): Use sbitsize_unit_node. + * gcc-interface/utils2.c (compare_arrays): Compute real lengths and use + constants in sizetype. Remove dead code and tweak comments. Generate + equality instead of inequality comparisons for zero length tests. + +2010-04-16 Eric Botcazou + + * gcc-interface/gigi.h (gnat_init_decl_processing): Delete. + * gcc-interface/decl.c (gnat_to_gnu_entity): Constify a few variables. + : Do not create the fake PARM_DECL if no debug info is needed. + Do not create the corresponding VAR_DECL of a CONST_DECL for debugging + purposes if no debug info is needed. + Fix formatting. Reorder and add comments. + * gcc-interface/trans.c (gnat_to_gnu) : Constify + variable and remove obsolete comment. + * gcc-interface/utils.c (convert_vms_descriptor64): Tweak comment. + (convert_vms_descriptor32): Likewise. + (convert): Remove dead code. + : Pass the field instead of its name to build + the reference to the P_ARRAY pointer. + : Likewise. + (maybe_unconstrained_array) : Likewise. + (gnat_init_decl_processing): Delete, move contents to... + * gcc-interface/misc.c (gnat_init): ...here. + +2010-04-16 Eric Botcazou + + * gcc-interface/trans.c (unchecked_conversion_nop): Handle function + calls. Return true for conversion from a record subtype to its type. + +2010-04-16 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity): Use boolean_type_node in + lieu of integer_type_node for boolean operations. + (choices_to_gnu): Likewise. + * gcc-interface/trans.c (Attribute_to_gnu): Likewise. + (Loop_Statement_to_gnu): Likewise. + (establish_gnat_vms_condition_handler): Likewise. + (Exception_Handler_to_gnu_sjlj): Likewise. + (gnat_to_gnu): Likewise. + (build_unary_op_trapv): Likewise. + (build_binary_op_trapv): Likewise. + (emit_range_check): Likewise. + (emit_index_check): Likewise. + (convert_with_check): Likewise. + * gcc-interface/utils.c (convert_vms_descriptor64): Likewise. + (convert_vms_descriptor32): Likewise. + (convert_vms_descriptor): Likewise. + * gcc-interface/utils2.c (nonbinary_modular_operation): Likewise. + (compare_arrays): Use boolean instead of integer constants. + (build_binary_op) : New case. Check that the result type + is a boolean type. + : Remove obsolete assertion. + : Check that the result type is a boolean type. + : Delete. + : Check that the result type is a boolean type. + (build_unary_op): Use boolean_type_node in lieu of integer_type_node + for boolean operations. + (fill_vms_descriptor): Likewise. Fix formatting nits. + +2010-04-16 Eric Botcazou + + * gcc-interface/ada-tree.def (LOOP_STMT): Change to 4-operand nodes. + * gcc-interface/ada-tree.h (LOOP_STMT_TOP_COND, LOOP_STMT_BOT_COND): + Merge into... + (LOOP_STMT_COND): ...this. + (LOOP_STMT_BOTTOM_COND_P): New flag. + (LOOP_STMT_TOP_UPDATE_P): Likewise. + * gcc-interface/trans.c (can_equal_min_or_max_val_p): New function. + (can_equal_min_val_p): New static inline function. + (can_equal_max_val_p): Likewise. + (Loop_Statement_to_gnu): Use build4 in lieu of build5 and adjust to + new LOOP_STMT semantics. Use two different strategies depending on + whether optimization is enabled to translate the loop. + (gnat_gimplify_stmt) : Adjust to new LOOP_STMT semantics. + +2010-04-16 Eric Botcazou + + * uintp.adb (UI_From_Dint): Remove useless code. + (UI_From_Int): Likewise. + * uintp.h: Reorder declarations. + (UI_From_gnu): Declare. + (UI_Base): Likewise. + (Vector_Template): Likewise. + (Vector_To_Uint): Likewise. + (Uint_0): Remove. + (Uint_1): Likewise. + * gcc-interface/gigi.h: Tweak comments. + * gcc-interface/cuintp.c (UI_From_gnu): New global function. + * gcc-interface/decl.c (maybe_pad_type): Do not warn if either size + overflows. + (annotate_value) : Call UI_From_gnu. + * gcc-interface/trans.c (post_error_ne_num): Call post_error_ne. + (post_error_ne_tree): Call UI_From_gnu and post_error_ne. + * gcc-interface/utils.c (max_size) : Do not special-case + TYPE_MAX_VALUE. + +2010-04-16 Eric Botcazou + + * gcc-interface/decl.c (make_type_from_size) : Just copy + TYPE_NAME. + * gcc-interface/trans.c (smaller_packable_type_p): Rename into... + (smaller_form_type_p): ...this. Change parameter and variable names. + (call_to_gnu): Use the nominal type of the parameter to create the + temporary if it's a smaller form of the actual type. + (addressable_p): Return false if the actual type is integral and its + size is greater than that of the expected type. + +2010-04-15 Eric Botcazou + + * gcc-interface/cuintp.c (UI_To_gnu): Fix long line. + * gcc-interface/gigi.h (MARK_VISITED): Skip objects of constant class. + (process_attributes): Delete. + (post_error_ne_num): Change parameter name. + * gcc-interface/decl.c (gnat_to_gnu_entity): Do not force debug info + with -g3. Remove a couple of obsolete lines. Minor tweaks. + If type annotating mode, operate on trees to compute the adjustment to + the sizes of tagged types. Fix long line. + (cannot_be_superflat_p): Tweak head comment. + (annotate_value): Fold local constant. + (set_rm_size): Fix long line. + * gcc-interface/trans.c (Identifier_to_gnu): Rework comments. + (Attribute_to_gnu): Fix long line. + : Remove useless assertion. + Reorder statements. Use size_binop routine. + (Loop_Statement_to_gnu): Use build5 in lieu of build_nt. + Create local variables for the label and the test. Tweak comments. + (Subprogram_Body_to_gnu): Reset cfun to NULL. + (Compilation_Unit_to_gnu): Use the Sloc of the Unit node. + (process_inlined_subprograms): Integrate into... + (Compilation_Unit_to_gnu): ...this. + (gnat_to_gnu): Fix long line. + (post_error_ne_num): Change parameter name. + * gcc-interface/utils.c (process_attributes): Static-ify. + : Set input_location before proceeding. + (create_type_decl): Add comment. + (create_var_decl_1): Process the attributes after adding the VAR_DECL + to the current binding level. + (create_subprog_decl): Likewise for the FUNCTION_DECL. + (end_subprog_body): Do not reset cfun to NULL. + (build_vms_descriptor32): Fix long line. + (build_vms_descriptor): Likewise. + (handle_nonnull_attribute): Likewise. + (convert_vms_descriptor64): Likewise. + * gcc-interface/utils2.c (fill_vms_descriptor): Fix long line. + (gnat_protect_expr): Fix thinko. + +2010-04-15 Eric Botcazou + + * gcc-interface/trans.c (gigi): Set DECL_IGNORED_P on EH functions. + (gnat_to_gnu) : Restore the value of input_location + before translating the top-level node. + (lvalue_required_p) : Return 1 if !constant. + : Likewise. + : Likewise. + : Likewise. + (call_to_gnu): Remove kludge. + (gnat_to_gnu) : When not optimizing, force labels + associated with user returns to be preserved. + (gnat_to_gnu): Add special code to deal with boolean rvalues. + * gcc-interface/utils2.c (compare_arrays): Set input_location on all + comparisons. + (build_unary_op) : Call build_fold_addr_expr. + : Call build_fold_indirect_ref. + +2010-04-15 Joel Sherrill + + * g-socket.adb: A target can have multiple missing errno's. This + will result in multiple errno's being defined as -1. Because of this + we can not use a case but must use a series of if's to avoid + a duplicate case error in GNAT.Sockets.Resolve_Error. + +2010-04-15 Eric Botcazou + + * gcc-interface/trans.c (call_to_gnu): Open a nesting level if this is + a statement. Otherwise, if at top-level, push the processing of the + elaboration routine. In the misaligned case, issue the error messages + again on entry and create the temporary explicitly. Do not issue them + for CONSTRUCTORs. + For a function call, emit the range check if necessary. + In the copy-in copy-out case, create the temporary for the return + value explicitly. + Do not unnecessarily convert by-ref parameters to the formal's type. + Remove obsolete guards in conditions. + (gnat_to_gnu) : For a function call, pass the + target to call_to_gnu in all cases. + (gnat_gimplify_expr) : Remove handling of SAVE_EXPR. + (addressable_p) : Return false if not static. + : New case. + * gcc-interface/utils2.c (build_unary_op) : Fold a compound + expression if it has unconstrained array type. + (gnat_mark_addressable) : New case. + (gnat_stabilize_reference) : Stabilize operands on an + individual basis. + +2010-04-15 Eric Botcazou + + * gcc-interface/trans.c (gigi): Do not start statement group. + (Compilation_Unit_to_gnu): Set current_function_decl to NULL. + Start statement group and push binding level here... + (gnat_to_gnu) : ...and not here. + Do not push fake contexts at top level. Remove redundant code. + (call_to_gnu): Rename a local variable and constify another. + * gcc-interface/utils.c (gnat_pushlevel): Fix formatting nits. + (set_current_block_context): Set it as the group's block. + (gnat_init_decl_processing): Delete unrelated init code. + (end_subprog_body): Use NULL_TREE. + +2010-04-15 Eric Botcazou + + * gcc-interface/trans.c (call_to_gnu): Do not unnecessarily force + side-effects of actual parameters before the call. + +2010-04-15 Eric Botcazou + + * gcc-interface/decl.c (validate_size): Reorder, remove obsolete test + and warning. + (set_rm_size): Reorder and remove obsolete test. + +2010-04-14 Eric Botcazou + + * gcc-interface/gigi.h: Reorder declarations and tweak comments. + (gigi): Adjust ATTRIBUTE_UNUSED markers. + * gcc-interface/gadaint.h: New file. + * gcc-interface/trans.c: Include it in lieu of adaint.h. Reorder. + (__gnat_to_canonical_file_spec): Remove declaration. + (number_names): Delete. + (number_files): Likewise. + (gigi): Adjust. + * gcc-interface/Make-lang.in (ada/trans.o): Adjust dependencies to + above change. + +2010-04-14 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Fix + comment. + * gcc-interface/trans.c (process_freeze_entity): Use local copy of + Ekind. Return early for class-wide types. Do not compute initializer + unless necessary. Reuse the tree for an associated class-wide type + only if processing its root type. + +2010-04-13 Joel Sherrill + + * gsocket.h: Run-time can no longer be built without network + OS headers available. Changing RTEMS GNAT build procedure to + reflect this and letting run-time build use network .h files. + +2010-04-13 Duncan Sands + + * gcc-interface/misc.c (gnat_eh_type_covers): Remove. + * gcc-interface/trans.c (Exception_Handler_to_gnu_zcx): Update comment. + +2010-04-13 Eric Botcazou + + * gcc-interface/gigi.h (standard_datatypes): Add ADT_parent_name_id. + (parent_name_id): New macro. + * gcc-interface/decl.c (gnat_to_gnu_entity) : Use it. + * gcc-interface/trans.c (gigi): Initialize it. + (lvalue_required_p) : New case. + : Likewise. + : Likewise. + * gcc-interface/utils.c (convert): Try to properly upcast tagged types. + +2010-04-13 Eric Botcazou + + * gcc-interface/ada-tree.h (TYPE_BY_REFERENCE_P): Delete. + (DECL_CONST_ADDRESS_P): New macro. + (SET_DECL_ORIGINAL_FIELD_TO_FIELD): Likewise. + (SAME_FIELD_P): Likewise. + * gcc-interface/decl.c (constructor_address_p): New static function. + (gnat_to_gnu_entity) : Set DECL_CONST_ADDRESS_P according to + the return value of above function. + (gnat_to_gnu_entity) : Force BLKmode for all types + passed by reference. + : Likewise. + Set TREE_ADDRESSABLE on the type if it passed by reference. + (make_packable_type): Use SET_DECL_ORIGINAL_FIELD_TO_FIELD. + (create_field_decl_from): Likewise. + (substitute_in_type): Likewise. + (purpose_member_field): Use SAME_FIELD_P. + * gcc-interface/misc.c (must_pass_by_ref): Test TREE_ADDRESSABLE. + * gcc-interface/trans.c (lvalue_required_p): Add ADDRESS_OF_CONSTANT + parameter and adjust recursive calls. + : New case. + : Return 1 if the object is of a class-wide type. + Adjust calls to lvalue_required_p. Do not return the initializer of a + DECL_CONST_ADDRESS_P constant if an lvalue is required for it. + (call_to_gnu): Delay issuing error message for a misaligned actual and + avoid the associated back-end assertion. Test TREE_ADDRESSABLE. + (gnat_gimplify_expr) : Handle non-static constructors. + * gcc-interface/utils.c (make_dummy_type): Set TREE_ADDRESSABLE if the + type is passed by reference. + (convert) : Convert in-place in more cases. + * gcc-interface/utils2.c (build_cond_expr): Drop TYPE_BY_REFERENCE_P. + (build_simple_component_ref): Use SAME_FIELD_P. + +2010-04-12 Eric Botcazou + + * gcc-interface/trans.c (Identifier_to_gnu): Use boolean variable. + (call_to_gnu): Test gigi's flag TYPE_BY_REFERENCE_P instead of calling + front-end's predicate Is_By_Reference_Type. Use consistent order and + remove ??? comment. Use original conversion in all cases, if any. + * gcc-interface/utils.c (make_dummy_type): Minor tweak. + (convert): Use local copy in more cases. + : Remove deactivated code. + (unchecked_convert): Use a couple of local copies. + +2010-04-11 Eric Botcazou + + * gcc-interface/trans.c (lvalue_required_for_attribute_p): New static + function. + (lvalue_required_p) : Call it. + (gnat_to_gnu) : Prevent build_component_ref from + folding the result only if lvalue_required_for_attribute_p is true. + * gcc-interface/utils.c (maybe_unconstrained_array): Pass correctly + typed constant to build_component_ref. + (unchecked_convert): Likewise. + * gcc-interface/utils2.c (maybe_wrap_malloc): Likewise. + (build_allocator): Likewise. + +2010-04-11 Eric Botcazou + + * gcc-interface/utils2.c (build_cond_expr): Take the address and + dereference if the result type is passed by reference. + +2010-04-11 Eric Botcazou + + * gcc-interface/trans.c (Case_Statement_to_gnu): Bool-ify variable. + (gnat_to_gnu) : When not optimizing, generate a + goto to the next statement. + +2010-04-09 Eric Botcazou + + * gcc-interface/gigi.h (maybe_variable): Delete. + (protect_multiple_eval): Likewise. + (maybe_stabilize_reference): Likewise. + (gnat_save_expr): Declare. + (gnat_protect_expr): Likewise. + (gnat_stabilize_reference): Likewise. + * gcc-interface/decl.c (gnat_to_gnu_entity) : Use + gnat_stabilize_reference. + (maybe_variable): Delete. + (elaborate_expression_1): Use gnat_save_expr. + * gcc-interface/trans.c (Attribute_to_gnu): Use gnat_protect_expr. + (call_to_gnu): Pass NULL to gnat_stabilize_reference. + (gnat_to_gnu) : Use gnat_save_expr. + : Use gnat_protect_exp. + : Pass NULL to gnat_stabilize_reference. + : Use gnat_protect_expr. + Pass NULL to gnat_stabilize_reference. + (build_unary_op_trapv): Use gnat_protect_expr. + (build_binary_op_trapv): Likewise. + (emit_range_check): Likewise. + (emit_index_check): Likewise. + (convert_with_check): Likewise. + (protect_multiple_eval): Move to utils2.c file. + (maybe_stabilize_reference): Merge into... + (gnat_stabilize_reference): ...this. Move to utils2.c file. + (gnat_stabilize_reference_1): Likewise. + * gcc-interface/utils.c (convert_to_fat_pointer): Use gnat_protect_expr + instead of protect_multiple_eval. + * gcc-interface/utils2.c (compare_arrays): Likewise. + (nonbinary_modular_operation): Likewise. + (maybe_wrap_malloc): Likewise. + (build_allocator): Likewise. + (gnat_save_expr): New function. + (gnat_protect_expr): Rename from protect_multiple_eval. Early return + in common cases. Propagate TREE_READONLY onto dereferences. + (gnat_stabilize_reference_1): Move from trans.c file. + (gnat_stabilize_reference): Likewise. + +2010-04-09 Eric Botcazou + + * gcc-interface/gigi.h (gnat_mark_addressable): Rename parameter. + * gcc-interface/decl.c (maybe_variable): Do not set TREE_STATIC on _REF + node. Use the type of the operand to set TREE_READONLY. + * gcc-interface/trans.c (Identifier_to_gnu): Do not set TREE_STATIC on + _REF node. Do not overwrite TREE_READONLY. + (call_to_gnu): Rename local variable and fix various nits. In the + copy-in/copy-out case, build the SAVE_EXPR manually. + (convert_with_check): Call protect_multiple_eval in lieu of save_expr + and fold the computations. + (protect_multiple_eval): Always save entire fat pointers. + (maybe_stabilize_reference): Minor tweaks. + (gnat_stabilize_reference_1): Likewise. Do not deal with tcc_constant, + tcc_type and tcc_statement. + * gcc-interface/utils.c (convert_to_fat_pointer): Call + protect_multiple_eval in lieu of save_expr. + (convert): Minor tweaks. + (maybe_unconstrained_array): Do not set TREE_STATIC on _REF node. + (builtin_type_for_size): Call gnat_type_for_size directly. + * gcc-interface/utils2.c (contains_save_expr_p): Delete. + (contains_null_expr): Likewise + (gnat_build_constructor): Do not call it. + (compare_arrays): Deal with all side-effects, use protect_multiple_eval + instead of gnat_stabilize_reference to protect the operands. + (nonbinary_modular_operation): Call protect_multiple_eval in lieu of + save_expr. + (maybe_wrap_malloc): Likewise. + (build_allocator): Likewise. + (build_unary_op) : Do not set TREE_STATIC on _REF node. + (gnat_mark_addressable): Rename parameter. + +2010-04-08 Eric Botcazou + + * gcc-interface/ada-tree.h (TYPE_RETURNS_UNCONSTRAINED_P): Rename into. + (TYPE_RETURN_UNCONSTRAINED_P): ...this. + (TYPE_RETURNS_BY_REF_P): Rename into. + (TYPE_RETURN_BY_DIRECT_REF_P): ...this. + (TYPE_RETURNS_BY_TARGET_PTR_P): Delete. + * gcc-interface/gigi.h (create_subprog_type): Adjust parameter names. + (build_return_expr): Likewise. + * gcc-interface/decl.c (gnat_to_gnu_entity) : + Rename local variables. If the return Mechanism is By_Reference, pass + return_by_invisible_ref_p to create_subprog_type instead of toggling + TREE_ADDRESSABLE. Test return_by_invisible_ref_p in order to annotate + the mechanism. Use regular return for contrained types with non-static + size and return by invisible reference for unconstrained return types + with default discriminants. Update comment. + * gcc-interface/trans.c (Subprogram_Body_to_gnu): If the function + returns by invisible reference, turn the RESULT_DECL into a pointer. + Do not handle DECL_BY_REF_P in the CICO case here. + (call_to_gnu): Remove code handling return by target pointer. For a + function call, if the return type has non-constant size, generate the + assignment with an INIT_EXPR. + (gnat_to_gnu) : Remove dead code in the CICO case. + If the function returns by invisible reference, build the copy return + operation manually. + (add_decl_expr): Initialize the variable with an INIT_EXPR. + * gcc-interface/utils.c (create_subprog_type): Adjust parameter names. + Adjust for renaming of macros. Copy the node only when necessary. + (create_subprog_decl): Do not toggle TREE_ADDRESSABLE on the return + type, only change DECL_BY_REFERENCE on the RETURN_DECL. + (convert_from_reference): Delete. + (is_byref_result): Likewise. + (gnat_genericize_r): Likewise. + (gnat_genericize): Likewise. + (end_subprog_body): Do not call gnat_genericize. + * gcc-interface/utils2.c (build_binary_op) : New case. + (build_return_expr): Adjust parameter names, logic and comment. + +2010-04-07 Eric Botcazou + + * exp_pakd.adb (Create_Packed_Array_Type): Always use a modular type + if the size is small enough. Propagate the alignment if there is an + alignment clause on the original array type. + * gcc-interface/decl.c (gnat_to_gnu_entity) + Deal with under-aligned packed array types. Copy the size onto the + justified modular type and don't lay it out again. Likewise for the + padding type built for other under-aligned subtypes. + * gcc-interface/utils.c (finish_record_type): Do not set a default mode + on the type. + +2010-04-07 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Set default + alignment on the RETURN type built for the Copy-In Copy-Out mechanism. + +2010-04-07 Eric Botcazou + + * gcc-interface/trans.c (call_to_gnu): In the return-by-target-ptr case + do not set the result type if there is a specified target and do not + convert the result in any cases. + (protect_multiple_eval): Make direct SAVE_EXPR for CALL_EXPR. + (maybe_stabilize_reference) : Merge with CALL_EXPR. + +2010-03-10 Eric Botcazou + + * gcc-interface/Makefile.in (SPARC/Solaris): Use sparcv8plus. + +2010-02-27 Eric Botcazou + + PR ada/42253 + * gcc-interface/utils2.c (build_binary_op) : Assert that fat + pointer base types are variant of each other. Apply special treatment + for null to fat pointer types in all cases. + +2010-01-28 Pascal Obry + + * s-win32.ads: Add some missing constants. + +2010-01-28 Vincent Celier + + * prj-attr-pm.adb (Add_Attribute): Do nothing if To_Package is + Unknown_Package. + +2010-01-28 Robert Dewar + + * gnat_rm.texi: Minor correction + +2010-01-27 Pascal Obry + + * g-awk.adb: ensure that an AWK session is reusable. + +2010-01-27 Vasiliy Fofanov + + * g-regist.adb (For_Every_Key): Fix previous change. + Minor reformatting. + +2010-01-27 Thomas Quinot + + * lib-writ.ads: Current version of spec for new N (note) ALI lines + +2010-01-27 Yannick Moy + + * a-cdlili.adb (Insert): Correct exception message when cursor + designates wrong list. + +2010-01-27 Vincent Celier + + * gnatcmd.adb: When there is only one main specified, the package + support Switches (
) and attribute Switches is specified for the + main, use these switches, instead of Default_Switches ("Ada"). + +2010-01-27 Robert Dewar + + * sem_prag.adb, par-prag.adb, snames.ads-tmpl: pragma Dimension initial + implementation. + * exp_disp.adb: Minor reformatting + +2010-01-27 Tristan Gingold + + * seh_init.c: Use __ImageBase instead of _ImageBase. + +2010-01-27 Javier Miranda + + * exp_disp.ads, exp_disp.adb (Expand_Interface_Thunk): Modify the + profile of interface thunks. The type of the controlling formal is now + the covered interface type (instead of the target tagged type). + +2010-01-27 Sergey Rybin + + * gnat_rm.texi, gnat_ugn.texi: Update gnatcheck doc. + +2010-01-27 Robert Dewar + + * sinput.ads, sinput.adb (Sloc_Range): Applies to all nodes, formal + changed from Expr to N. + +2010-01-26 Thomas Quinot + + * gnat_ugn.texi: Adjust documentation of -gnatz switches. + * usage.adb: Replace line for -gnatz with two lines for -gnatzc and + -gnatzr. + +2010-01-26 Vincent Celier + + * prj-attr.adb: Add new attribute Library_Install_Name_Option + Replace attribute Run_Path_Origin_Supported with Run_Path_Origin + * prj-nmsc.adb (Process_Project_Level_Simple_Attributes): Process + attributes Run_Path_Option and Library_Install_Name_Option. + * prj.ads (Project_Configuration): Replace component + Run_Path_Origin_Supported with component Run_Path_Origin. Add new + component Library_Install_Name_Option. + * snames.ads-tmpl: Add new standard name Library_Install_Name_Option + Replace Run_Path_Origin_Supported with Run_Path_Origin + +2010-01-26 Ed Schonberg + + * sem_ch8.adb (Use_One_Package): Within an instance, an actual package + is not hidden by a homograph declared in another actual package. + +2010-01-26 Robert Dewar + + * par_sco.adb (Traverse_Declarations_Or_Statements): Only generate + decisions for pragmas Assert, Check, Precondition, Postcondition if + -gnata set. + * scos.ads: Update comments. + * get_scos.adb, put_scos.adb: Minor fix to code reading statement SCOs. + Also remove obsolete code for CT (exit point) SCOs. + +2010-01-26 Thomas Quinot + + * switch-c.adb: Fix handling of -gnatz* + +2010-01-26 Robert Dewar + + * par_sco.adb (Traverse_Declarations_Or_Statements): Separate F/W + qualifiers for FOR/WHILE loops + * scos.ads: Use separate type letters F/W for for/while loops + +2010-01-26 Robert Dewar + + * get_scos.adb (Get_SCOs): Implement new form of CS entries (multiple + entries per line, one for each statement in the sequence). + * par_sco.adb (Traverse_Declarations_Or_Statements): Increase array + size from 100 to 10_000 for SC_Array to avoid any real possibility of + overflow. Output decisions in for loops. + Exclude labels from CS lines. + * scos.ads: Clarify that label is not included in the entry point + +2010-01-26 Robert Dewar + + * par_sco.adb (Traverse_Declarations_Or_Statments): Implement new + format of statement sequence SCO entries (one location/statement). + * put_scos.adb (Put_SCOs): Implement new format of CS lines + * scos.ads: Update comments. + * sem_eval.adb: Minor reformatting. + +2010-01-26 Robert Dewar + + * par_sco.ads, par_sco.adb (Set_Statement_Entry): New handling of exits + (Extend_Statement_Sequence): New procedures + (Traverse_Declarations_Or_Statements): New handling for exits. + +2010-01-26 Robert Dewar + + * par_sco.adb (Traverse_Declarations_Or_Statements): Add processing for + Case. + +2010-01-26 Robert Dewar + + * par_sco.adb (Is_Logical_Operator): Exclude AND/OR/XOR + * scos.ads: Clarify handling of logical operators + +2010-01-26 Arnaud Charlet + + * s-tpoben.adb: Update comments. + +2010-01-26 Robert Dewar + + * freeze.adb (Set_Small_Size): Don't set size if alignment clause + present. + +2010-01-26 Robert Dewar + + * scos.ads: Clean up documentation, remove obsolete XOR references +2010-01-26 Vincent Celier + + * gnat_ugn.texi: Complete documentation on the restrictions for + combined options in -gnatxxx switches. + Fix typo. + +2010-01-26 Arnaud Charlet + + * s-tpoben.adb (Initialize_Protection_Entries): If a PO is created from + a controlled operation, abort is already deferred at this point, so we + need to use Defer_Abort_Nestable. + +2010-01-26 Vincent Celier + + * prj-conf.adb (Get_Config_Switches): Check for a default language for + a project extending a project with no languages. + +2010-01-26 Vincent Celier + + * switch-c.adb (Scan_Front_End_Switches): Take into account options + that follow -gnatef. + Allow -gnateG to be followed by other options. + +2010-01-26 Robert Dewar + + * s-commun.ads, s-osprim-mingw.adb, s-stchop-vxworks.adb, sem_aggr.adb, + s-vxwext.adb, sem_ch10.adb, sem_eval.adb, sem_prag.adb: Minor + reformatting. + +2010-01-26 Vasiliy Fofanov + + * g-regist.adb, g-regist.ads (For_Every_Key): New generic procedure + that allows to iterate over all subkeys of a key. + +2010-01-26 Ed Falis + + * sysdep.c: enable NFS for VxWorks MILS + * env.c: enable __gnat_environ for VxWorks MILS + * gcc-interface/Makefile.in: Add VxWorks MILS target pairs. + +2010-01-25 Bob Duff + + * sem_aggr.adb (Resolve_Array_Aggregate): Check for the case where this + is an internally-generated positional aggregate, and the bounds are + already correctly set. We don't want to overwrite those bounds with + bounds determined by context. + +2010-01-25 Robert Dewar + + * g-sercom.ads, gnatcmd.adb, gnatlink.adb, a-ststio.adb, exp_ch6.adb, + exp_ch9.adb, g-sechas.ads: Minor reformatting. + +2010-01-25 Thomas Quinot + + * s-commun.adb (Last_Index): Count must be converted to SEO (a signed + integer type) before subtracting 1, otherwise the computation may wrap + (because size_t is modular) and cause the conversion to fail. + +2010-01-25 Ed Falis + + * sysdep.c, init.c: Adapt to support full run-time on VxWorks MILS. + +2010-01-25 Vincent Celier + + * prj-attr.adb: New attribute Run_Path_Origin_Required + * prj-nmsc.adb (Process_Project_Level_Simple_Attributes): Process new + attribute Run_Path_Origin_Required. + * prj.ads (Project_Configuration): New component + Run_Path_Origin_Supported. + * snames.ads-tmpl: New standard name Run_Path_Origin_Required + +2010-01-25 Ed Schonberg + + * sem_aggr.adb (Resolve_Array_Aggregate): If the bounds in a choice + have errors, do not continue resolution of the aggregate. + * sem_eval.adb (Eval_Indexed_Component): Do not attempt to evaluate if + the array type indicates an error. + +2010-01-25 Bob Duff + + * sinfo.ads: Minor comment fixes. + +2010-01-25 Bob Duff + + * exp_ch4.adb, exp_aggr.adb: Minor comment fixes and code clean up. + +2010-01-25 Arnaud Charlet + + * gnatvsn.ads (Current_Year): Update. + +2010-01-25 Florian Villoing + + * gnat_ugn.texi: Fix typo. + +2010-01-25 Thomas Quinot + + * scos.ads: Update specification. + +2010-01-25 Ed Schonberg + + * sem_ch6.adb (Process_PPCs): If a postcondition is present and the + enclosing subprogram has no previous spec, attach postcondition + procedure to the defining entity for the body. + +2010-01-25 Ed Schonberg + + * exp_aggr.adb (Build_Record_Aggr_Code); Do not generate call to + initialization procedure of the ancestor part of an extension aggregate + if it is an interface type. + +2010-01-25 Vincent Celier + + * gnatlink.adb (Process_Binder_File): The directory for the shared + version of libgcc in the run path options is found in the subdirectory + indicated by __gnat_default_libgcc_subdir. + * link.c: Declare new const char * __gnat_default_libgcc_subdir for + each platform. + +2010-01-25 Ed Schonberg + + * sem_prag.adb: More flexible pragma Annotate. + +2010-01-22 Eric Botcazou + + * system-linux-armel.ads (Stack_Check_Probes): Set to True. + * system-linux-armeb.ads (Stack_Check_Probes): Likewise. + +2010-01-18 Eric Botcazou + + * gcc-interface/utils.c (create_var_decl_1): Fix formatting nits. + +2010-01-18 Jan Hubicka + + PR middle-end/42068 + * gcc-interface/utils.c (create_var_decl_1): Do not set COMMON flag for + unit local variables. + +2010-01-17 Laurent GUERBY + + * gcc-interface/Makefile.in: Fix typo in arm*-*-linux-gnueabi. + +2010-01-11 Mikael Pettersson + + * gcc-interface/Makefile.in: Add arm*-*-linux-gnueabi. + * system-linux-armeb.ads, system-linux-armel.ads: New files. + +2010-01-09 Simon Wright + + PR ada/42626 + * gcc-interface/Makefile.in (gnatlib-shared-darwin): Add missing + end-quote. + + + +Copyright (C) 2010 Free Software Foundation, Inc. + +Copying and distribution of this file, with or without modification, +are permitted in any medium without royalty provided the copyright +notice and this notice are preserved. diff --git a/gcc/ada/ChangeLog.ptr b/gcc/ada/ChangeLog.ptr new file mode 100644 index 000000000..109522dbf --- /dev/null +++ b/gcc/ada/ChangeLog.ptr @@ -0,0 +1,27 @@ +2007-06-14 Andrew Pinski + + * trans.c (Attribute_to_gnu): Use fold_build1 instead + of build1 for NEGATE_EXPR. + (gnat_to_gnu): Likewise. + +2007-05-12 Andrew Pinski + + * trans.c (Attribute_to_gnu): When subtracting an + offset from a pointer, use POINTER_PLUS_EXPR with + NEGATE_EXPR instead of MINUS_EXPR. + (gnat_to_gnu): Likewise. + * utils.c (convert): When converting between + thin pointers, use POINTER_PLUS_EXPR and sizetype + for the offset. + * utils2.c (known_alignment): POINTER_PLUS_EXPR + have the same semantics as PLUS_EXPR for alignment. + (build_binary_op): Add support for the semantics of + POINTER_PLUS_EXPR's operands. + When adding an offset to a pointer, use POINTER_PLUS_EXPR. + + +Copyright (C) 2007 Free Software Foundation, Inc. + +Copying and distribution of this file, with or without modification, +are permitted in any medium without royalty provided the copyright +notice and this notice are preserved. diff --git a/gcc/ada/ChangeLog.tree-ssa b/gcc/ada/ChangeLog.tree-ssa new file mode 100644 index 000000000..030ea55ac --- /dev/null +++ b/gcc/ada/ChangeLog.tree-ssa @@ -0,0 +1,36 @@ +2004-05-05 Richard Henderson + + * utils.c (unchecked_convert): Use OEP_ONLY_CONST. + +2004-03-25 Diego Novillo + + * config-lang.in: Disable Ada by default. + +2004-02-16 Richard Henderson + + * utils.c (max_size): Add static chain op for call_expr. + +2003-09-25 Jason Merrill + + * trans.c, utils.c: Revert 2003-01-15 change. + +2003-01-15 Jeff Law + + * trans.c (tree_transform): Use annotate_with_file_line to add + file/line information to nodes. + (build_unit_elab): Use TREE_FILENAME and TREE_LINENO to + retrieve file/line information from a node. + * utils.c (create_label_decl): Use annotate_with_file_line to + add file/line information to nodes. + +Local Variables: +mode: change-log +change-log-default-name: "ChangeLog.tree-ssa" +End: + + +Copyright (C) 2003, 2004 Free Software Foundation, Inc. + +Copying and distribution of this file, with or without modification, +are permitted in any medium without royalty provided the copyright +notice and this notice are preserved. diff --git a/gcc/ada/Make-generated.in b/gcc/ada/Make-generated.in new file mode 100644 index 000000000..ac52e491e --- /dev/null +++ b/gcc/ada/Make-generated.in @@ -0,0 +1,103 @@ +# Dependencies for compiler sources that are generated at build time + +# Note: can't use ?= here, not supported by older versions of GNU Make + +ifeq ($(origin ADA_GEN_SUBDIR), undefined) +ADA_GEN_SUBDIR=ada +endif + +ifeq ($(origin CP), undefined) +CP=cp +endif + +ifeq ($(origin MKDIR), undefined) +MKDIR=mkdir -p +endif + +ifeq ($(origin MOVE_IF_CHANGE), undefined) +MOVE_IF_CHANGE=mv -f +endif + +ada_extra_files : $(ADA_GEN_SUBDIR)/treeprs.ads $(ADA_GEN_SUBDIR)/einfo.h $(ADA_GEN_SUBDIR)/sinfo.h $(ADA_GEN_SUBDIR)/nmake.adb \ + $(ADA_GEN_SUBDIR)/nmake.ads $(ADA_GEN_SUBDIR)/snames.ads $(ADA_GEN_SUBDIR)/snames.adb $(ADA_GEN_SUBDIR)/snames.h + +# We delete the files before copying, below, in case they are read-only. + +$(ADA_GEN_SUBDIR)/treeprs.ads : $(ADA_GEN_SUBDIR)/treeprs.adt $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/xtreeprs.adb + -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/treeprs + $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/treeprs/,$(notdir $^)) + $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/treeprs + (cd $(ADA_GEN_SUBDIR)/bldtools/treeprs; gnatmake -q xtreeprs ; ./xtreeprs ../../treeprs.ads ) + +$(ADA_GEN_SUBDIR)/einfo.h : $(ADA_GEN_SUBDIR)/einfo.ads $(ADA_GEN_SUBDIR)/einfo.adb $(ADA_GEN_SUBDIR)/xeinfo.adb $(ADA_GEN_SUBDIR)/ceinfo.adb + -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/einfo + $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/einfo/,$(notdir $^)) + $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/einfo + (cd $(ADA_GEN_SUBDIR)/bldtools/einfo; gnatmake -q xeinfo ; ./xeinfo ../../einfo.h ) + +$(ADA_GEN_SUBDIR)/sinfo.h : $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/sinfo.adb $(ADA_GEN_SUBDIR)/xsinfo.adb $(ADA_GEN_SUBDIR)/csinfo.adb + -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/sinfo + $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/sinfo/,$(notdir $^)) + $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/sinfo + (cd $(ADA_GEN_SUBDIR)/bldtools/sinfo; gnatmake -q xsinfo ; ./xsinfo ../../sinfo.h ) + +$(ADA_GEN_SUBDIR)/snames.h $(ADA_GEN_SUBDIR)/snames.ads $(ADA_GEN_SUBDIR)/snames.adb : $(ADA_GEN_SUBDIR)/stamp-snames ; @true +$(ADA_GEN_SUBDIR)/stamp-snames : $(ADA_GEN_SUBDIR)/snames.ads-tmpl $(ADA_GEN_SUBDIR)/snames.adb-tmpl $(ADA_GEN_SUBDIR)/snames.h-tmpl $(ADA_GEN_SUBDIR)/xsnamest.adb $(ADA_GEN_SUBDIR)/xutil.ads $(ADA_GEN_SUBDIR)/xutil.adb + -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/snamest + $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/snamest/,$(notdir $^)) + $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/snamest + (cd $(ADA_GEN_SUBDIR)/bldtools/snamest; gnatmake -q xsnamest ; ./xsnamest ) + $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/snamest/snames.ns $(ADA_GEN_SUBDIR)/snames.ads + $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/snamest/snames.nb $(ADA_GEN_SUBDIR)/snames.adb + $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/snamest/snames.nh $(ADA_GEN_SUBDIR)/snames.h + touch $(ADA_GEN_SUBDIR)/stamp-snames + +$(ADA_GEN_SUBDIR)/nmake.adb : $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/nmake.adt $(ADA_GEN_SUBDIR)/xnmake.adb $(ADA_GEN_SUBDIR)/xutil.ads $(ADA_GEN_SUBDIR)/xutil.adb + -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/nmake_b + $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/nmake_b/,$(notdir $^)) + $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/nmake_b + (cd $(ADA_GEN_SUBDIR)/bldtools/nmake_b; gnatmake -q xnmake ; ./xnmake -b ../../nmake.adb ) + +$(ADA_GEN_SUBDIR)/nmake.ads : $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/nmake.adt $(ADA_GEN_SUBDIR)/xnmake.adb $(ADA_GEN_SUBDIR)/nmake.adb $(ADA_GEN_SUBDIR)/xutil.ads $(ADA_GEN_SUBDIR)/xutil.adb + -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/nmake_s + $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/nmake_s/,$(notdir $^)) + $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/nmake_s + (cd $(ADA_GEN_SUBDIR)/bldtools/nmake_s; gnatmake -q xnmake ; ./xnmake -s ../../nmake.ads ) + +$(ADA_GEN_SUBDIR)/sdefault.adb: $(ADA_GEN_SUBDIR)/stamp-sdefault ; @true +$(ADA_GEN_SUBDIR)/stamp-sdefault : $(srcdir)/version.c Makefile + $(ECHO) "pragma Style_Checks (Off);" >tmp-sdefault.adb + $(ECHO) "with Osint; use Osint;" >>tmp-sdefault.adb + $(ECHO) "package body Sdefault is" >>tmp-sdefault.adb + $(ECHO) " S0 : constant String := \"$(prefix)/\";" >>tmp-sdefault.adb + $(ECHO) " S1 : constant String := \"$(ADA_INCLUDE_DIR)/\";" >>tmp-sdefault.adb + $(ECHO) " S2 : constant String := \"$(ADA_RTL_OBJ_DIR)/\";" >>tmp-sdefault.adb + $(ECHO) " S3 : constant String := \"$(target)/\";" >>tmp-sdefault.adb + $(ECHO) " S4 : constant String := \"$(libsubdir)/\";" >>tmp-sdefault.adb + $(ECHO) " function Include_Dir_Default_Name return String_Ptr is" >>tmp-sdefault.adb + $(ECHO) " begin" >>tmp-sdefault.adb + $(ECHO) " return Relocate_Path (S0, S1);" >>tmp-sdefault.adb + $(ECHO) " end Include_Dir_Default_Name;" >>tmp-sdefault.adb + $(ECHO) " function Object_Dir_Default_Name return String_Ptr is" >>tmp-sdefault.adb + $(ECHO) " begin" >>tmp-sdefault.adb + $(ECHO) " return Relocate_Path (S0, S2);" >>tmp-sdefault.adb + $(ECHO) " end Object_Dir_Default_Name;" >>tmp-sdefault.adb + $(ECHO) " function Target_Name return String_Ptr is" >>tmp-sdefault.adb + $(ECHO) " begin" >>tmp-sdefault.adb + $(ECHO) " return new String'(S3);" >>tmp-sdefault.adb + $(ECHO) " end Target_Name;" >>tmp-sdefault.adb + $(ECHO) " function Search_Dir_Prefix return String_Ptr is" >>tmp-sdefault.adb + $(ECHO) " begin" >>tmp-sdefault.adb + $(ECHO) " return Relocate_Path (S0, S4);" >>tmp-sdefault.adb + $(ECHO) " end Search_Dir_Prefix;" >>tmp-sdefault.adb + $(ECHO) "end Sdefault;" >> tmp-sdefault.adb + $(MOVE_IF_CHANGE) tmp-sdefault.adb $(ADA_GEN_SUBDIR)/sdefault.adb + touch $(ADA_GEN_SUBDIR)/stamp-sdefault + +$(ADA_GEN_SUBDIR)/gnat.hlp : $(ADA_GEN_SUBDIR)/vms_help.adb $(ADA_GEN_SUBDIR)/vms_cmds.ads $(ADA_GEN_SUBDIR)/gnat.help_in $(ADA_GEN_SUBDIR)/vms_data.ads + -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/gnat_hlp + $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/gnat_hlp/,$(notdir $^)) + $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/gnat_hlp + (cd $(ADA_GEN_SUBDIR)/bldtools/gnat_hlp; \ + gnatmake -q vms_help; \ + ./vms_help$(build_exeext) gnat.help_in vms_data.ads ../../gnat.hlp) diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in new file mode 100644 index 000000000..a662b2047 --- /dev/null +++ b/gcc/ada/Makefile.in @@ -0,0 +1,5 @@ +# All makefile fragments assume that $(srcdir) points to the gcc +# directory, not the language subdir +srcdir = @top_srcdir@ +-include ./gcc-interface/Makefile +-include ../gcc-interface/Makefile diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl new file mode 100644 index 000000000..78f585536 --- /dev/null +++ b/gcc/ada/Makefile.rtl @@ -0,0 +1,650 @@ +# Makefile.rtl for GNU Ada Compiler (GNAT). +# Copyright (C) 2003-2010, Free Software Foundation, Inc. + +#This file is part of GCC. + +#GCC is free software; you can redistribute it and/or modify +#it under the terms of the GNU General Public License as published by +#the Free Software Foundation; either version 3, or (at your option) +#any later version. + +#GCC is distributed in the hope that it will be useful, +#but WITHOUT ANY WARRANTY; without even the implied warranty of +#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +#GNU General Public License for more details. + +#You should have received a copy of the GNU General Public License +#along with GCC; see the file COPYING3. If not see +#. + +# This makefile fragment is included in the ada Makefile (both Unix +# and NT and VMS versions). + +# Its purpose is to allow the separate maintainence of the list of +# GNATRTL objects, which frequently changes. + +# Objects needed only for tasking +GNATRTL_TASKING_OBJS= \ + a-dispat$(objext) \ + a-dynpri$(objext) \ + a-interr$(objext) \ + a-intsig$(objext) \ + a-intnam$(objext) \ + a-reatim$(objext) \ + a-retide$(objext) \ + a-rttiev$(objext) \ + a-sytaco$(objext) \ + a-tasatt$(objext) \ + a-taside$(objext) \ + a-taster$(objext) \ + g-boubuf$(objext) \ + g-boumai$(objext) \ + g-semaph$(objext) \ + g-signal$(objext) \ + g-tastus$(objext) \ + g-thread$(objext) \ + s-asthan$(objext) \ + s-inmaop$(objext) \ + s-interr$(objext) \ + s-intman$(objext) \ + s-oscons$(objext) \ + s-osinte$(objext) \ + s-proinf$(objext) \ + s-solita$(objext) \ + s-stusta$(objext) \ + s-taenca$(objext) \ + s-taprob$(objext) \ + s-taprop$(objext) \ + s-tarest$(objext) \ + s-tasdeb$(objext) \ + s-tasinf$(objext) \ + s-tasini$(objext) \ + s-taskin$(objext) \ + s-taspri$(objext) \ + s-tasque$(objext) \ + s-tasres$(objext) \ + s-tasren$(objext) \ + s-tassta$(objext) \ + s-tasuti$(objext) \ + s-taasde$(objext) \ + s-tadeca$(objext) \ + s-tadert$(objext) \ + s-tataat$(objext) \ + s-tpinop$(objext) \ + s-tpoben$(objext) \ + s-tpobop$(objext) \ + s-tposen$(objext) \ + s-tratas$(objext) $(EXTRA_GNATRTL_TASKING_OBJS) + +# Objects needed for non-tasking. +GNATRTL_NONTASKING_OBJS= \ + a-assert$(objext) \ + a-btgbso$(objext) \ + a-calari$(objext) \ + a-calcon$(objext) \ + a-caldel$(objext) \ + a-calend$(objext) \ + a-calfor$(objext) \ + a-catizo$(objext) \ + a-cbhama$(objext) \ + a-cbhase$(objext) \ + a-cborse$(objext) \ + a-cbdlli$(objext) \ + a-cborma$(objext) \ + a-cdlili$(objext) \ + a-cgaaso$(objext) \ + a-cgarso$(objext) \ + a-cgcaso$(objext) \ + a-chacon$(objext) \ + a-chahan$(objext) \ + a-charac$(objext) \ + a-chlat1$(objext) \ + a-chlat9$(objext) \ + a-chtgbo$(objext) \ + a-chtgbk$(objext) \ + a-chtgke$(objext) \ + a-chtgop$(objext) \ + a-chzla1$(objext) \ + a-chzla9$(objext) \ + a-cidlli$(objext) \ + a-cihama$(objext) \ + a-cihase$(objext) \ + a-ciorma$(objext) \ + a-ciormu$(objext) \ + a-ciorse$(objext) \ + a-clrefi$(objext) \ + a-cohama$(objext) \ + a-cohase$(objext) \ + a-cohata$(objext) \ + a-coinve$(objext) \ + a-colien$(objext) \ + a-colire$(objext) \ + a-comlin$(objext) \ + a-contai$(objext) \ + a-convec$(objext) \ + a-cobove$(objext) \ + a-coorma$(objext) \ + a-coormu$(objext) \ + a-coorse$(objext) \ + a-coprnu$(objext) \ + a-coteio$(objext) \ + a-crbltr$(objext) \ + a-crbtgk$(objext) \ + a-crbtgo$(objext) \ + a-crdlli$(objext) \ + a-cwila1$(objext) \ + a-cwila9$(objext) \ + a-decima$(objext) \ + a-diocst$(objext) \ + a-direct$(objext) \ + a-direio$(objext) \ + a-dirval$(objext) \ + a-einuoc$(objext) \ + a-elchha$(objext) \ + a-envvar$(objext) \ + a-except$(objext) \ + a-exctra$(objext) \ + a-filico$(objext) \ + a-finali$(objext) \ + a-flteio$(objext) \ + a-fwteio$(objext) \ + a-fzteio$(objext) \ + a-inteio$(objext) \ + a-ioexce$(objext) \ + a-iwteio$(objext) \ + a-izteio$(objext) \ + a-lcteio$(objext) \ + a-lfteio$(objext) \ + a-lfwtio$(objext) \ + a-lfztio$(objext) \ + a-liteio$(objext) \ + a-liwtio$(objext) \ + a-liztio$(objext) \ + a-llctio$(objext) \ + a-llftio$(objext) \ + a-llfwti$(objext) \ + a-llfzti$(objext) \ + a-llitio$(objext) \ + a-lliwti$(objext) \ + a-llizti$(objext) \ + a-locale$(objext) \ + a-ncelfu$(objext) \ + a-ngcefu$(objext) \ + a-ngcoty$(objext) \ + a-ngelfu$(objext) \ + a-ngrear$(objext) \ + a-nlcefu$(objext) \ + a-nlcoty$(objext) \ + a-nlelfu$(objext) \ + a-nllcef$(objext) \ + a-nllcty$(objext) \ + a-nllefu$(objext) \ + a-nscefu$(objext) \ + a-nscoty$(objext) \ + a-nselfu$(objext) \ + a-nucoty$(objext) \ + a-nudira$(objext) \ + a-nuelfu$(objext) \ + a-nuflra$(objext) \ + a-numaux$(objext) \ + a-numeri$(objext) \ + a-rbtgbo$(objext) \ + a-rbtgbk$(objext) \ + a-rbtgso$(objext) \ + a-scteio$(objext) \ + a-secain$(objext) \ + a-sequio$(objext) \ + a-sfteio$(objext) \ + a-sfwtio$(objext) \ + a-sfztio$(objext) \ + a-shcain$(objext) \ + a-siocst$(objext) \ + a-siteio$(objext) \ + a-siwtio$(objext) \ + a-siztio$(objext) \ + a-slcain$(objext) \ + a-ssicst$(objext) \ + a-ssitio$(objext) \ + a-ssiwti$(objext) \ + a-ssizti$(objext) \ + a-stboha$(objext) \ + a-stfiha$(objext) \ + a-stmaco$(objext) \ + a-storio$(objext) \ + a-strbou$(objext) \ + a-stream$(objext) \ + a-strfix$(objext) \ + a-strhas$(objext) \ + a-string$(objext) \ + a-strmap$(objext) \ + a-strsea$(objext) \ + a-strsup$(objext) \ + a-strunb$(objext) \ + a-ststio$(objext) \ + a-stunau$(objext) \ + a-stunha$(objext) \ + a-stuten$(objext) \ + a-stwibo$(objext) \ + a-stwifi$(objext) \ + a-stwiha$(objext) \ + a-stwima$(objext) \ + a-stwise$(objext) \ + a-stwisu$(objext) \ + a-stwiun$(objext) \ + a-stzbou$(objext) \ + a-stzfix$(objext) \ + a-stzhas$(objext) \ + a-stzmap$(objext) \ + a-stzsea$(objext) \ + a-stzsup$(objext) \ + a-stzunb$(objext) \ + a-suenco$(objext) \ + a-suenst$(objext) \ + a-suewst$(objext) \ + a-suezst$(objext) \ + a-suteio$(objext) \ + a-swbwha$(objext) \ + a-swfwha$(objext) \ + a-swmwco$(objext) \ + a-swunau$(objext) \ + a-swuwha$(objext) \ + a-swuwti$(objext) \ + a-szbzha$(objext) \ + a-szfzha$(objext) \ + a-szmzco$(objext) \ + a-szunau$(objext) \ + a-szuzha$(objext) \ + a-szuzti$(objext) \ + a-tags$(objext) \ + a-teioed$(objext) \ + a-textio$(objext) \ + a-tgdico$(objext) \ + a-tiboio$(objext) \ + a-ticoau$(objext) \ + a-ticoio$(objext) \ + a-tideau$(objext) \ + a-tideio$(objext) \ + a-tienau$(objext) \ + a-tienio$(objext) \ + a-tifiio$(objext) \ + a-tiflau$(objext) \ + a-tiflio$(objext) \ + a-tigeau$(objext) \ + a-tiinau$(objext) \ + a-tiinio$(objext) \ + a-timoau$(objext) \ + a-timoio$(objext) \ + a-tiocst$(objext) \ + a-tirsfi$(objext) \ + a-titest$(objext) \ + a-tiunio$(objext) \ + a-unccon$(objext) \ + a-uncdea$(objext) \ + a-wichha$(objext) \ + a-wichun$(objext) \ + a-widcha$(objext) \ + a-witeio$(objext) \ + a-wrstfi$(objext) \ + a-wtcoau$(objext) \ + a-wtcoio$(objext) \ + a-wtcstr$(objext) \ + a-wtdeau$(objext) \ + a-wtdeio$(objext) \ + a-wtedit$(objext) \ + a-wtenau$(objext) \ + a-wtenio$(objext) \ + a-wtfiio$(objext) \ + a-wtflau$(objext) \ + a-wtflio$(objext) \ + a-wtgeau$(objext) \ + a-wtinau$(objext) \ + a-wtinio$(objext) \ + a-wtmoau$(objext) \ + a-wtmoio$(objext) \ + a-wttest$(objext) \ + a-wwboio$(objext) \ + a-wwunio$(objext) \ + a-zchara$(objext) \ + a-zchhan$(objext) \ + a-zchuni$(objext) \ + a-zrstfi$(objext) \ + a-ztcoau$(objext) \ + a-ztcoio$(objext) \ + a-ztcstr$(objext) \ + a-ztdeau$(objext) \ + a-ztdeio$(objext) \ + a-ztedit$(objext) \ + a-ztenau$(objext) \ + a-ztenio$(objext) \ + a-ztexio$(objext) \ + a-ztfiio$(objext) \ + a-ztflau$(objext) \ + a-ztflio$(objext) \ + a-ztgeau$(objext) \ + a-ztinau$(objext) \ + a-ztinio$(objext) \ + a-ztmoau$(objext) \ + a-ztmoio$(objext) \ + a-zttest$(objext) \ + a-zzboio$(objext) \ + a-zzunio$(objext) \ + ada$(objext) \ + calendar$(objext) \ + directio$(objext) \ + g-allein$(objext) \ + g-alleve$(objext) \ + g-altcon$(objext) \ + g-altive$(objext) \ + g-alveop$(objext) \ + g-alvety$(objext) \ + g-alvevi$(objext) \ + g-arrspl$(objext) \ + g-awk$(objext) \ + g-bubsor$(objext) \ + g-busora$(objext) \ + g-busorg$(objext) \ + g-byorma$(objext) \ + g-bytswa$(objext) \ + g-calend$(objext) \ + g-casuti$(objext) \ + g-catiio$(objext) \ + g-cgi$(objext) \ + g-cgicoo$(objext) \ + g-cgideb$(objext) \ + g-comlin$(objext) \ + g-comver$(objext) \ + g-crc32$(objext) \ + g-ctrl_c$(objext) \ + g-curexc$(objext) \ + g-debpoo$(objext) \ + g-debuti$(objext) \ + g-decstr$(objext) \ + g-deutst$(objext) \ + g-diopit$(objext) \ + g-dirope$(objext) \ + g-dynhta$(objext) \ + g-dyntab$(objext) \ + g-encstr$(objext) \ + g-enutst$(objext) \ + g-excact$(objext) \ + g-except$(objext) \ + g-exctra$(objext) \ + g-expect$(objext) \ + g-flocon$(objext) \ + g-heasor$(objext) \ + g-hesora$(objext) \ + g-hesorg$(objext) \ + g-htable$(objext) \ + g-io$(objext) \ + g-io_aux$(objext) \ + g-locfil$(objext) \ + g-mbdira$(objext) \ + g-mbflra$(objext) \ + g-md5$(objext) \ + g-memdum$(objext) \ + g-moreex$(objext) \ + g-os_lib$(objext) \ + g-pehage$(objext) \ + g-rannum$(objext) \ + g-regexp$(objext) \ + g-regpat$(objext) \ + g-sechas$(objext) \ + g-sehamd$(objext) \ + g-sehash$(objext) \ + g-sercom$(objext) \ + g-sestin$(objext) \ + g-sha1$(objext) \ + g-sha224$(objext) \ + g-sha256$(objext) \ + g-sha384$(objext) \ + g-sha512$(objext) \ + g-shsh32$(objext) \ + g-shsh64$(objext) \ + g-shshco$(objext) \ + g-souinf$(objext) \ + g-spchge$(objext) \ + g-speche$(objext) \ + g-spipat$(objext) \ + g-spitbo$(objext) \ + g-sptabo$(objext) \ + g-sptain$(objext) \ + g-sptavs$(objext) \ + g-string$(objext) \ + g-strspl$(objext) \ + g-table$(objext) \ + g-tasloc$(objext) \ + g-timsta$(objext) \ + g-traceb$(objext) \ + g-u3spch$(objext) \ + g-utf_32$(objext) \ + g-wispch$(objext) \ + g-wistsp$(objext) \ + g-zspche$(objext) \ + g-zstspl$(objext) \ + gnat$(objext) \ + i-c$(objext) \ + i-cexten$(objext) \ + i-cobol$(objext) \ + i-cpoint$(objext) \ + i-cpp$(objext) \ + i-cstrea$(objext) \ + i-cstrin$(objext) \ + i-fortra$(objext) \ + i-pacdec$(objext) \ + interfac$(objext) \ + ioexcept$(objext) \ + machcode$(objext) \ + s-addima$(objext) \ + s-addope$(objext) \ + s-arit64$(objext) \ + s-assert$(objext) \ + s-atacco$(objext) \ + s-auxdec$(objext) \ + s-bitops$(objext) \ + s-boarop$(objext) \ + s-carsi8$(objext) \ + s-carun8$(objext) \ + s-casi16$(objext) \ + s-casi32$(objext) \ + s-casi64$(objext) \ + s-casuti$(objext) \ + s-caun16$(objext) \ + s-caun32$(objext) \ + s-caun64$(objext) \ + s-chepoo$(objext) \ + s-commun$(objext) \ + s-conca2$(objext) \ + s-conca3$(objext) \ + s-conca4$(objext) \ + s-conca5$(objext) \ + s-conca6$(objext) \ + s-conca7$(objext) \ + s-conca8$(objext) \ + s-conca9$(objext) \ + s-crc32$(objext) \ + s-crtl$(objext) \ + s-crtrun$(objext) \ + s-direio$(objext) \ + s-dsaser$(objext) \ + s-except$(objext) \ + s-exctab$(objext) \ + s-exnint$(objext) \ + s-exnllf$(objext) \ + s-exnlli$(objext) \ + s-expint$(objext) \ + s-explli$(objext) \ + s-expllu$(objext) \ + s-expmod$(objext) \ + s-expuns$(objext) \ + s-fatflt$(objext) \ + s-fatgen$(objext) \ + s-fatlfl$(objext) \ + s-fatllf$(objext) \ + s-fatsfl$(objext) \ + s-ficobl$(objext) \ + s-fileio$(objext) \ + s-filofl$(objext) \ + s-finimp$(objext) \ + s-finroo$(objext) \ + s-fishfl$(objext) \ + s-fore$(objext) \ + s-fvadfl$(objext) \ + s-fvaffl$(objext) \ + s-fvagfl$(objext) \ + s-geveop$(objext) \ + s-gloloc$(objext) \ + s-htable$(objext) \ + s-imenne$(objext) \ + s-imgbiu$(objext) \ + s-imgboo$(objext) \ + s-imgcha$(objext) \ + s-imgdec$(objext) \ + s-imgenu$(objext) \ + s-imgint$(objext) \ + s-imgllb$(objext) \ + s-imglld$(objext) \ + s-imglli$(objext) \ + s-imgllu$(objext) \ + s-imgllw$(objext) \ + s-imgrea$(objext) \ + s-imguns$(objext) \ + s-imgwch$(objext) \ + s-imgwiu$(objext) \ + s-io$(objext) \ + s-maccod$(objext) \ + s-mantis$(objext) \ + s-mastop$(objext) \ + s-memcop$(objext) \ + s-memory$(objext) \ + s-multip$(objext) \ + s-os_lib$(objext) \ + s-osprim$(objext) \ + s-pack03$(objext) \ + s-pack05$(objext) \ + s-pack06$(objext) \ + s-pack07$(objext) \ + s-pack09$(objext) \ + s-pack10$(objext) \ + s-pack11$(objext) \ + s-pack12$(objext) \ + s-pack13$(objext) \ + s-pack14$(objext) \ + s-pack15$(objext) \ + s-pack17$(objext) \ + s-pack18$(objext) \ + s-pack19$(objext) \ + s-pack20$(objext) \ + s-pack21$(objext) \ + s-pack22$(objext) \ + s-pack23$(objext) \ + s-pack24$(objext) \ + s-pack25$(objext) \ + s-pack26$(objext) \ + s-pack27$(objext) \ + s-pack28$(objext) \ + s-pack29$(objext) \ + s-pack30$(objext) \ + s-pack31$(objext) \ + s-pack33$(objext) \ + s-pack34$(objext) \ + s-pack35$(objext) \ + s-pack36$(objext) \ + s-pack37$(objext) \ + s-pack38$(objext) \ + s-pack39$(objext) \ + s-pack40$(objext) \ + s-pack41$(objext) \ + s-pack42$(objext) \ + s-pack43$(objext) \ + s-pack44$(objext) \ + s-pack45$(objext) \ + s-pack46$(objext) \ + s-pack47$(objext) \ + s-pack48$(objext) \ + s-pack49$(objext) \ + s-pack50$(objext) \ + s-pack51$(objext) \ + s-pack52$(objext) \ + s-pack53$(objext) \ + s-pack54$(objext) \ + s-pack55$(objext) \ + s-pack56$(objext) \ + s-pack57$(objext) \ + s-pack58$(objext) \ + s-pack59$(objext) \ + s-pack60$(objext) \ + s-pack61$(objext) \ + s-pack62$(objext) \ + s-pack63$(objext) \ + s-parame$(objext) \ + s-parint$(objext) \ + s-pooglo$(objext) \ + s-pooloc$(objext) \ + s-poosiz$(objext) \ + s-powtab$(objext) \ + s-purexc$(objext) \ + s-rannum$(objext) \ + s-regexp$(objext) \ + s-regpat$(objext) \ + s-restri$(objext) \ + s-rident$(objext) \ + s-rpc$(objext) \ + s-scaval$(objext) \ + s-secsta$(objext) \ + s-sequio$(objext) \ + s-shasto$(objext) \ + s-soflin$(objext) \ + s-stache$(objext) \ + s-stalib$(objext) \ + s-stausa$(objext) \ + s-stchop$(objext) \ + s-stoele$(objext) \ + s-stopoo$(objext) \ + s-stratt$(objext) \ + s-strhas$(objext) \ + s-string$(objext) \ + s-ststop$(objext) \ + s-tasloc$(objext) \ + s-traceb$(objext) \ + s-traces$(objext) \ + s-traent$(objext) \ + s-unstyp$(objext) \ + s-utf_32$(objext) \ + s-vaflop$(objext) \ + s-valboo$(objext) \ + s-valcha$(objext) \ + s-valdec$(objext) \ + s-valenu$(objext) \ + s-valint$(objext) \ + s-vallld$(objext) \ + s-vallli$(objext) \ + s-valllu$(objext) \ + s-valrea$(objext) \ + s-valuns$(objext) \ + s-valuti$(objext) \ + s-valwch$(objext) \ + s-veboop$(objext) \ + s-vector$(objext) \ + s-vercon$(objext) \ + s-vmexta$(objext) \ + s-wchcnv$(objext) \ + s-wchcon$(objext) \ + s-wchjis$(objext) \ + s-wchstw$(objext) \ + s-wchwts$(objext) \ + s-widboo$(objext) \ + s-widcha$(objext) \ + s-widenu$(objext) \ + s-widlli$(objext) \ + s-widllu$(objext) \ + s-widwch$(objext) \ + s-wwdcha$(objext) \ + s-wwdenu$(objext) \ + s-wwdwch$(objext) \ + sequenio$(objext) \ + system$(objext) \ + text_io$(objext) \ + unchconv$(objext) \ + unchdeal$(objext) \ + $(GNATRTL_SOCKETS_OBJS) \ + $(EXTRA_GNATRTL_NONTASKING_OBJS) diff --git a/gcc/ada/a-assert.adb b/gcc/ada/a-assert.adb new file mode 100755 index 000000000..11c65d9eb --- /dev/null +++ b/gcc/ada/a-assert.adb @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . A S S E R T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 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 new file mode 100755 index 000000000..232201b15 --- /dev/null +++ b/gcc/ada/a-assert.ads @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . A S S E R T I O N S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 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); + + procedure Assert (Check : Boolean; Message : String); + +end Ada.Assertions; diff --git a/gcc/ada/a-astaco.adb b/gcc/ada/a-astaco.adb new file mode 100644 index 000000000..3e4f36259 --- /dev/null +++ b/gcc/ada/a-astaco.adb @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . A S Y N C H R O N O U S _ T A S K _ 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a dummy body, which will not normally be compiled when used with +-- standard versions of GNAT, which do not support this package. See comments +-- in spec for further details. + +package body Ada.Asynchronous_Task_Control is + + -------------- + -- Continue -- + -------------- + + procedure Continue (T : Ada.Task_Identification.Task_Id) is + begin + null; + end Continue; + + ---------- + -- Hold -- + ---------- + + procedure Hold (T : Ada.Task_Identification.Task_Id) is + begin + raise Program_Error; + end Hold; + + ------------- + -- Is_Held -- + ------------- + + function Is_Held (T : Ada.Task_Identification.Task_Id) return Boolean is + begin + return False; + end Is_Held; + +end Ada.Asynchronous_Task_Control; diff --git a/gcc/ada/a-astaco.ads b/gcc/ada/a-astaco.ads new file mode 100644 index 000000000..3200c7ecd --- /dev/null +++ b/gcc/ada/a-astaco.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . A S Y N C H R O N O U S _ T A S K _ C O N T R O L -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit is not implemented in typical GNAT implementations that lie on +-- top of operating systems, because it is infeasible to implement in such +-- environments. The RM anticipates this situation (RM D.11(10)), and permits +-- an implementation to leave this unimplemented even if the Real-Time Systems +-- annex is fully supported. + +-- If a target environment provides appropriate support for this package, then +-- the Unimplemented_Unit pragma should be removed from this spec, and an +-- appropriate body provided. The framework for such a body is included in the +-- distributed sources. + +with Ada.Task_Identification; + +package Ada.Asynchronous_Task_Control is + pragma Preelaborate_05; + -- In accordance with Ada 2005 AI-362 + + pragma Unimplemented_Unit; + + procedure Hold (T : Ada.Task_Identification.Task_Id); + + procedure Continue (T : Ada.Task_Identification.Task_Id); + + function Is_Held (T : Ada.Task_Identification.Task_Id) return Boolean; + +end Ada.Asynchronous_Task_Control; diff --git a/gcc/ada/a-btgbso.adb b/gcc/ada/a-btgbso.adb new file mode 100644 index 000000000..bd4dad4b8 --- /dev/null +++ b/gcc/ada/a-btgbso.adb @@ -0,0 +1,605 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_SET_OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +with System; use type System.Address; + +package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is + + ----------------------- + -- 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; + + begin + if Target'Address = Source'Address then + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Tree_Operations.Clear_Tree (Target); + return; + end if; + + if Source.Length = 0 then + return; + end if; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Tgt := Target.First; + Src := Source.First; + loop + if Tgt = 0 then + return; + end if; + + if Src = 0 then + return; + end if; + + if Is_Less (TN (Tgt), SN (Src)) then + Tgt := Tree_Operations.Next (Target, Tgt); + + elsif Is_Less (SN (Src), TN (Tgt)) 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 + L_Node : Count_Type; + R_Node : Count_Type; + + Dst_Node : Count_Type; + pragma Warnings (Off, Dst_Node); + + 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 + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = 0 then + return; + 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; + + return; + 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 return; + end Set_Difference; + + ------------------ + -- Intersection -- + ------------------ + + procedure Set_Intersection + (Target : in out Set_Type; + Source : Set_Type) + is + Tgt : Count_Type; + Src : Count_Type; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + 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 + if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) 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 Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) 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 + L_Node : Count_Type; + R_Node : Count_Type; + + Dst_Node : Count_Type; + pragma Warnings (Off, Dst_Node); + + begin + if Left'Address = Right'Address then + return Copy (Left); + end if; + + return Result : Set_Type (Count_Type'Min (Left.Length, Right.Length)) do + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = 0 then + return; + end if; + + if R_Node = 0 then + return; + 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 return; + end Set_Intersection; + + --------------- + -- Is_Subset -- + --------------- + + function Set_Subset + (Subset : Set_Type; + Of_Set : Set_Type) return Boolean + is + Subset_Node : Count_Type; + Set_Node : Count_Type; + + 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 := 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 Set_Subset; + + ------------- + -- Overlap -- + ------------- + + function Set_Overlap (Left, Right : Set_Type) return Boolean is + L_Node : Count_Type; + R_Node : Count_Type; + + begin + if Left'Address = Right'Address then + return Left.Length /= 0; + end if; + + 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 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); + + begin + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + 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; + + if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then + Tgt := Tree_Operations.Next (Target, Tgt); + + elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) 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 + L_Node : Count_Type; + R_Node : Count_Type; + + Dst_Node : Count_Type; + pragma Warnings (Off, Dst_Node); + + 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 + 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; + + return; + 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; + + return; + 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 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; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + -- 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 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 + 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 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 new file mode 100644 index 000000000..06b58297e --- /dev/null +++ b/gcc/ada/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-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. -- +------------------------------------------------------------------------------ + +-- 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; + + 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 new file mode 100644 index 000000000..1166b4349 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..64ebc623b --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..7d58969cd --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 new file mode 100644 index 000000000..e478d5088 --- /dev/null +++ b/gcc/ada/a-calcon.ads @@ -0,0 +1,114 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 100 nanoseconds on VMS and nanoseconds on + -- all other 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-vms.adb b/gcc/ada/a-caldel-vms.adb new file mode 100644 index 000000000..128918a9a --- /dev/null +++ b/gcc/ada/a-caldel-vms.adb @@ -0,0 +1,107 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Alpha/VMS version + +with System.OS_Primitives; +with System.Soft_Links; + +package body Ada.Calendar.Delays is + + package OSP renames System.OS_Primitives; + package TSL renames System.Soft_Links; + + use type TSL.Timed_Delay_Call; + + ----------------------- + -- 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 + TSL.Timed_Delay.all + (Duration'Min (D, OSP.Max_Sensible_Delay), OSP.Relative); + end Delay_For; + + ----------------- + -- Delay_Until -- + ----------------- + + procedure Delay_Until (T : Time) is + begin + TSL.Timed_Delay.all (To_Duration (T), OSP.Absolute_Calendar); + end Delay_Until; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (T : Time) return Duration is + Safe_Ada_High : constant Time := Time_Of (2250, 1, 1, 0.0); + -- A value distant enough to emulate "end of time" but which does not + -- cause overflow. + + Safe_T : constant Time := + (if T > Safe_Ada_High then Safe_Ada_High else T); + + begin + return OSP.To_Duration (OSP.OS_Time (Safe_T), OSP.Absolute_Calendar); + end To_Duration; + + -------------------- + -- Timed_Delay_NT -- + -------------------- + + procedure Timed_Delay_NT (Time : Duration; Mode : Integer) is + begin + OSP.Timed_Delay (Time, Mode); + end Timed_Delay_NT; + +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 TSL.Timed_Delay = null then + TSL.Timed_Delay := Timed_Delay_NT'Access; + end if; +end Ada.Calendar.Delays; diff --git a/gcc/ada/a-caldel.adb b/gcc/ada/a-caldel.adb new file mode 100644 index 000000000..17b399777 --- /dev/null +++ b/gcc/ada/a-caldel.adb @@ -0,0 +1,132 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.OS_Primitives; +with System.Soft_Links; +with System.Traces; +with System.Parameters; + +package body Ada.Calendar.Delays is + + package OSP renames System.OS_Primitives; + package SSL renames System.Soft_Links; + + use type SSL.Timed_Delay_Call; + + use System.Traces; + + -- 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 + if System.Parameters.Runtime_Traces then + Send_Trace_Info (W_Delay, D); + end if; + + SSL.Timed_Delay.all (Duration'Min (D, OSP.Max_Sensible_Delay), + OSP.Relative); + + if System.Parameters.Runtime_Traces then + Send_Trace_Info (M_Delay, D); + end if; + end Delay_For; + + ----------------- + -- Delay_Until -- + ----------------- + + procedure Delay_Until (T : Time) is + D : constant Duration := To_Duration (T); + + begin + if System.Parameters.Runtime_Traces then + Send_Trace_Info (WU_Delay, D); + end if; + + SSL.Timed_Delay.all (D, OSP.Absolute_Calendar); + + if System.Parameters.Runtime_Traces then + Send_Trace_Info (M_Delay, D); + end if; + 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 new file mode 100644 index 000000000..d52c4e202 --- /dev/null +++ b/gcc/ada/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-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 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 + +end Ada.Calendar.Delays; diff --git a/gcc/ada/a-calend-vms.adb b/gcc/ada/a-calend-vms.adb new file mode 100644 index 000000000..788ff28a4 --- /dev/null +++ b/gcc/ada/a-calend-vms.adb @@ -0,0 +1,1296 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C A L E N D 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Alpha/VMS version + +with Ada.Unchecked_Conversion; + +with System.Aux_DEC; use System.Aux_DEC; +with System.OS_Primitives; use System.OS_Primitives; + +package body Ada.Calendar is + + -------------------------- + -- Implementation Notes -- + -------------------------- + + -- Variables of type Ada.Calendar.Time have suffix _S or _M to denote + -- units of seconds or milis. + + -- 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 behaviour 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 (a-calfor, a-calfor-vms, a-calfor-vxwors, etc). + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Check_Within_Time_Bounds (T : OS_Time); + -- 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 : OS_Time; + End_Date : OS_Time; + Elapsed_Leaps : out Natural; + Next_Leap_Sec : out OS_Time); + -- 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 To_Duration (T : Time) return Duration; + function To_Relative_Time (D : Duration) return Time; + -- It is important to note that duration's fractional part denotes nano + -- seconds while the units of Time are 100 nanoseconds. If a regular + -- Unchecked_Conversion was employed, the resulting values would be off + -- by 100. + + -------------------------- + -- 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 the + -- support. + + Leap_Support : constant Boolean := Flag = 1; + -- The above flag controls the usage of leap seconds in all Ada.Calendar + -- routines. + + Leap_Seconds_Count : constant Natural := 24; + + --------------------- + -- Local Constants -- + --------------------- + + -- The range of Ada time expressed as milis since the VMS Epoch + + Ada_Low : constant OS_Time := (10 * 366 + 32 * 365 + 45) * Milis_In_Day; + Ada_High : constant OS_Time := (131 * 366 + 410 * 365 + 45) * Milis_In_Day; + + -- Even though the upper bound of time is 2399-12-31 23:59:59.9999999 + -- UTC, it must be increased to include all leap seconds. + + Ada_High_And_Leaps : constant OS_Time := + Ada_High + OS_Time (Leap_Seconds_Count) * Mili; + + -- 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 OS_Time := Ada_High + OS_Time (3) * Milis_In_Day; + Start_Of_Time : constant OS_Time := Ada_Low - OS_Time (3) * Milis_In_Day; + + -- The following table contains the hard time values of all existing leap + -- seconds. The values are produced by the utility program xleaps.adb. + + Leap_Second_Times : constant array (1 .. Leap_Seconds_Count) of OS_Time := + (35855136000000000, + 36014112010000000, + 36329472020000000, + 36644832030000000, + 36960192040000000, + 37276416050000000, + 37591776060000000, + 37907136070000000, + 38222496080000000, + 38695104090000000, + 39010464100000000, + 39325824110000000, + 39957408120000000, + 40747104130000000, + 41378688140000000, + 41694048150000000, + 42166656160000000, + 42482016170000000, + 42797376180000000, + 43271712190000000, + 43744320200000000, + 44218656210000000, + 46427904220000000, + 47374848230000000); + + --------- + -- "+" -- + --------- + + function "+" (Left : Time; Right : Duration) return Time is + pragma Unsuppress (Overflow_Check); + begin + return Left + To_Relative_Time (Right); + exception + when Constraint_Error => + raise Time_Error; + end "+"; + + function "+" (Left : Duration; Right : Time) return Time is + pragma Unsuppress (Overflow_Check); + begin + return Right + Left; + exception + when Constraint_Error => + raise Time_Error; + end "+"; + + --------- + -- "-" -- + --------- + + function "-" (Left : Time; Right : Duration) return Time is + pragma Unsuppress (Overflow_Check); + begin + return Left - To_Relative_Time (Right); + exception + when Constraint_Error => + raise Time_Error; + end "-"; + + function "-" (Left : Time; Right : Time) return Duration is + pragma Unsuppress (Overflow_Check); + + -- The bound of type Duration expressed as time + + Dur_High : constant OS_Time := + OS_Time (To_Relative_Time (Duration'Last)); + Dur_Low : constant OS_Time := + OS_Time (To_Relative_Time (Duration'First)); + + Res_M : OS_Time; + + begin + Res_M := OS_Time (Left) - OS_Time (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_M < Dur_Low + or else Res_M >= Dur_High + then + raise Time_Error; + + -- Normal case, result fits + + else + return To_Duration (Time (Res_M)); + end if; + + exception + when Constraint_Error => + raise Time_Error; + end "-"; + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Time) return Boolean is + begin + return OS_Time (Left) < OS_Time (Right); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" (Left, Right : Time) return Boolean is + begin + return OS_Time (Left) <= OS_Time (Right); + end "<="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Time) return Boolean is + begin + return OS_Time (Left) > OS_Time (Right); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" (Left, Right : Time) return Boolean is + begin + return OS_Time (Left) >= OS_Time (Right); + end ">="; + + ------------------------------ + -- Check_Within_Time_Bounds -- + ------------------------------ + + procedure Check_Within_Time_Bounds (T : OS_Time) 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_M : OS_Time; + Res_M : constant OS_Time := OS_Clock; + + begin + -- Note that on other targets a soft-link is used to get a different + -- clock depending whether tasking is used or not. On VMS this isn't + -- needed since all clock calls end up using SYS$GETTIM, so call the + -- OS_Primitives version for efficiency. + + -- 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_M, Elapsed_Leaps, Next_Leap_M); + + -- The system clock may fall exactly on a leap second + + if Res_M >= Next_Leap_M then + Elapsed_Leaps := Elapsed_Leaps + 1; + end if; + + -- The target does not support leap seconds + + else + Elapsed_Leaps := 0; + end if; + + return Time (Res_M + OS_Time (Elapsed_Leaps) * Mili); + end Clock; + + ----------------------------- + -- Cumulative_Leap_Seconds -- + ----------------------------- + + procedure Cumulative_Leap_Seconds + (Start_Date : OS_Time; + End_Date : OS_Time; + Elapsed_Leaps : out Natural; + Next_Leap_Sec : out OS_Time) + is + End_Index : Positive; + End_T : OS_Time := End_Date; + Start_Index : Positive; + Start_T : OS_Time := Start_Date; + + begin + pragma Assert (Leap_Support and then End_Date >= Start_Date); + + Next_Leap_Sec := 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 Mili); + End_T := End_T - (End_T mod Mili); + + -- 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_Sec := Leap_Second_Times (1); + return; + + elsif Start_T > Leap_Second_Times (Leap_Seconds_Count) then + Elapsed_Leaps := 0; + Next_Leap_Sec := 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_Sec := 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 + Y : Year_Number; + M : Month_Number; + D : Day_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; + + begin + -- Use UTC as the local time zone on VMS, the status of flag Is_Ada_05 + -- is irrelevant in this case. + + 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, + Is_Ada_05 => False, + 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 + 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; + + -- Use UTC as the local time zone on VMS, the status of flag Is_Ada_05 + -- is irrelevant in this case. + + 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, + Is_Ada_05 => False, + Time_Zone => 0); + end Time_Of; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (T : Time) return Duration is + function Time_To_Duration is + new Ada.Unchecked_Conversion (Time, Duration); + begin + return Time_To_Duration (T * 100); + end To_Duration; + + ---------------------- + -- To_Relative_Time -- + ---------------------- + + function To_Relative_Time (D : Duration) return Time is + function Duration_To_Time is + new Ada.Unchecked_Conversion (Duration, Time); + begin + return Duration_To_Time (D / 100.0); + end To_Relative_Time; + + ---------- + -- 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 Long_Integer, the units + -- are 100 nanoseconds and the starting point in the VMS Epoch. + + --------------------------- + -- Arithmetic_Operations -- + --------------------------- + + package body Arithmetic_Operations is + + --------- + -- Add -- + --------- + + function Add (Date : Time; Days : Long_Integer) return Time is + pragma Unsuppress (Overflow_Check); + Date_M : constant OS_Time := OS_Time (Date); + begin + return Time (Date_M + OS_Time (Days) * Milis_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 + Diff_M : OS_Time; + Diff_S : OS_Time; + Earlier : OS_Time; + Elapsed_Leaps : Natural; + Later : OS_Time; + Negate : Boolean := False; + Next_Leap : OS_Time; + Sub_Seconds : Duration; + + begin + -- This classification is necessary in order to avoid a Time_Error + -- being raised by the arithmetic operators in Ada.Calendar. + + if Left >= Right then + Later := OS_Time (Left); + Earlier := OS_Time (Right); + else + Later := OS_Time (Right); + Earlier := OS_Time (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); + + if Later >= Next_Leap then + Elapsed_Leaps := Elapsed_Leaps + 1; + end if; + + -- The target does not support leap seconds + + else + Elapsed_Leaps := 0; + end if; + + Diff_M := Later - Earlier - OS_Time (Elapsed_Leaps) * Mili; + + -- Sub second processing + + Sub_Seconds := Duration (Diff_M mod Mili) / Mili_F; + + -- Convert to seconds. Note that his action eliminates the sub + -- seconds automatically. + + Diff_S := Diff_M / Mili; + + Days := Long_Integer (Diff_S / Secs_In_Day); + Seconds := Duration (Diff_S mod Secs_In_Day) + Sub_Seconds; + 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_M : constant OS_Time := OS_Time (Date); + begin + return Time (Date_M - OS_Time (Days) * Milis_In_Day); + exception + when Constraint_Error => + raise Time_Error; + end Subtract; + end Arithmetic_Operations; + + --------------------------- + -- Conversion_Operations -- + --------------------------- + + package body Conversion_Operations is + + Epoch_Offset : constant OS_Time := 35067168000000000; + -- The difference between 1970-1-1 UTC and 1858-11-17 UTC expressed in + -- 100 nanoseconds. + + ----------------- + -- To_Ada_Time -- + ----------------- + + function To_Ada_Time (Unix_Time : Long_Integer) return Time is + pragma Unsuppress (Overflow_Check); + Unix_Rep : constant OS_Time := OS_Time (Unix_Time) * Mili; + 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_Shift : constant Integer := 1900; + Month_Shift : constant Integer := 1; + + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Second : Integer; + Leap : Boolean; + Result : OS_Time; + + begin + -- Input processing + + Year := Year_Number (Year_Shift + tm_year); + Month := Month_Number (Month_Shift + 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 := + OS_Time + (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 + Is_Ada_05 => True, -- Force usage of explicit time zone + Time_Zone => 0)); -- Place the value in UTC + -- Step 4: Daylight Savings Time + + if tm_isdst = 1 then + Result := Result + OS_Time (3_600) * Mili; + 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) / Mili_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); + + -- 100 Nanoseconds extraction + + Nano_Secs := D - Duration (tv_sec); + tv_nsec := Long_Integer (Nano_Secs * Mili); + 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 + (T, Year, Month, tm_day, Day_Secs, + tm_hour, tm_min, Second, Sub_Sec, Leap_Sec, True, 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_OS_Time : constant OS_Time := OS_Time (Ada_Time); + begin + return Long_Integer ((Ada_OS_Time - Epoch_Offset) / Mili); + exception + when Constraint_Error => + raise Time_Error; + end To_Unix_Time; + end Conversion_Operations; + + --------------------------- + -- Formatting_Operations -- + --------------------------- + + package body Formatting_Operations is + + ----------------- + -- Day_Of_Week -- + ----------------- + + function Day_Of_Week (Date : Time) return Integer is + Y : Year_Number; + M : Month_Number; + D : Day_Number; + S : Day_Duration; + + Day_Count : Long_Integer; + Midday_Date_S : Time; + + begin + Split (Date, Y, M, D, S); + + -- Build a time value in the middle of the same day and convert the + -- time value to seconds. + + Midday_Date_S := Time_Of (Y, M, D, 43_200.0) / Mili; + + -- Count the number of days since the start of VMS time. 1858-11-17 + -- was a Wednesday. + + Day_Count := Long_Integer (Midday_Date_S / Secs_In_Day) + 2; + + 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; + Is_Ada_05 : Boolean; + Time_Zone : Long_Integer) + is + -- The flag Is_Ada_05 is present for interfacing purposes + + pragma Unreferenced (Is_Ada_05); + + procedure Numtim + (Status : out Unsigned_Longword; + Timbuf : out Unsigned_Word_Array; + Timadr : Time); + + pragma Interface (External, Numtim); + + pragma Import_Valued_Procedure + (Numtim, "SYS$NUMTIM", + (Unsigned_Longword, Unsigned_Word_Array, Time), + (Value, Reference, Reference)); + + Status : Unsigned_Longword; + Timbuf : Unsigned_Word_Array (1 .. 7); + + Ada_Min_Year : constant := 1901; + Ada_Max_Year : constant := 2399; + + Date_M : OS_Time; + Elapsed_Leaps : Natural; + Next_Leap_M : OS_Time; + + begin + Date_M := OS_Time (Date); + + -- Step 1: Leap seconds processing + + if Leap_Support then + Cumulative_Leap_Seconds + (Start_Of_Time, Date_M, Elapsed_Leaps, Next_Leap_M); + + Leap_Sec := Date_M >= Next_Leap_M; + + 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_M := Date_M - OS_Time (Elapsed_Leaps) * Mili; + + -- Step 2: Time zone processing + + if Time_Zone /= 0 then + Date_M := Date_M + OS_Time (Time_Zone) * 60 * Mili; + end if; + + -- After the leap seconds and time zone have been accounted for, + -- the date should be within the bounds of Ada time. + + if Date_M < Ada_Low + or else Date_M > Ada_High + then + raise Time_Error; + end if; + + -- Step 3: Sub second processing + + Sub_Sec := Duration (Date_M mod Mili) / Mili_F; + + -- Drop the sub seconds + + Date_M := Date_M - (Date_M mod Mili); + + -- Step 4: VMS system call + + Numtim (Status, Timbuf, Time (Date_M)); + + if Status mod 2 /= 1 + or else Timbuf (1) not in Ada_Min_Year .. Ada_Max_Year + then + raise Time_Error; + end if; + + -- Step 5: Time components processing + + Year := Year_Number (Timbuf (1)); + Month := Month_Number (Timbuf (2)); + Day := Day_Number (Timbuf (3)); + Hour := Integer (Timbuf (4)); + Minute := Integer (Timbuf (5)); + Second := Integer (Timbuf (6)); + + Day_Secs := Day_Duration (Hour * 3_600) + + Day_Duration (Minute * 60) + + Day_Duration (Second) + + Sub_Sec; + 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 := False; + Use_Day_Secs : Boolean := False; + Is_Ada_05 : Boolean := False; + Time_Zone : Long_Integer := 0) return Time + is + procedure Cvt_Vectim + (Status : out Unsigned_Longword; + Input_Time : Unsigned_Word_Array; + Resultant_Time : out Time); + + pragma Interface (External, Cvt_Vectim); + + pragma Import_Valued_Procedure + (Cvt_Vectim, "LIB$CVT_VECTIM", + (Unsigned_Longword, Unsigned_Word_Array, Time), + (Value, Reference, Reference)); + + Status : Unsigned_Longword; + Timbuf : Unsigned_Word_Array (1 .. 7); + + Y : Year_Number := Year; + Mo : Month_Number := Month; + D : Day_Number := Day; + H : Integer := Hour; + Mi : Integer := Minute; + Se : Integer := Second; + Su : Duration := Sub_Sec; + + Elapsed_Leaps : Natural; + Int_Day_Secs : Integer; + Next_Leap_M : OS_Time; + Res : Time; + Res_M : OS_Time; + Rounded_Res_M : OS_Time; + + begin + -- No validity checks are performed on the input values since it is + -- assumed that the called has already performed them. + + -- Step 1: Hour, minute, second and sub second processing + + if Use_Day_Secs then + + -- A day seconds value of 86_400 designates a new day + + if Day_Secs = 86_400.0 then + declare + Adj_Year : Year_Number := Year; + Adj_Month : Month_Number := Month; + Adj_Day : Day_Number := Day; + + begin + if Day < Days_In_Month (Month) + or else (Month = 2 + and then Is_Leap (Year)) + then + Adj_Day := Day + 1; + + -- The day adjustment moves the date to a new month + + else + Adj_Day := 1; + + if Month < 12 then + Adj_Month := Month + 1; + + -- The month adjustment moves the date to a new year + + else + Adj_Month := 1; + Adj_Year := Year + 1; + end if; + end if; + + Y := Adj_Year; + Mo := Adj_Month; + D := Adj_Day; + H := 0; + Mi := 0; + Se := 0; + Su := 0.0; + end; + + -- Normal case (not exactly one day) + + else + -- Sub second extraction + + Int_Day_Secs := + (if Day_Secs > 0.0 + then Integer (Day_Secs - 0.5) + else Integer (Day_Secs)); + + H := Int_Day_Secs / 3_600; + Mi := (Int_Day_Secs / 60) mod 60; + Se := Int_Day_Secs mod 60; + Su := Day_Secs - Duration (Int_Day_Secs); + end if; + end if; + + -- Step 2: System call to VMS + + Timbuf (1) := Unsigned_Word (Y); + Timbuf (2) := Unsigned_Word (Mo); + Timbuf (3) := Unsigned_Word (D); + Timbuf (4) := Unsigned_Word (H); + Timbuf (5) := Unsigned_Word (Mi); + Timbuf (6) := Unsigned_Word (Se); + Timbuf (7) := 0; + + Cvt_Vectim (Status, Timbuf, Res); + + if Status mod 2 /= 1 then + raise Time_Error; + end if; + + -- Step 3: Sub second adjustment + + Res_M := OS_Time (Res) + OS_Time (Su * Mili_F); + + -- Step 4: Bounds check + + Check_Within_Time_Bounds (Res_M); + + -- Step 5: Time zone processing + + if Time_Zone /= 0 then + Res_M := Res_M - OS_Time (Time_Zone) * 60 * Mili; + end if; + + -- Step 6: Leap seconds processing + + if Leap_Support then + Cumulative_Leap_Seconds + (Start_Of_Time, Res_M, Elapsed_Leaps, Next_Leap_M); + + Res_M := Res_M + OS_Time (Elapsed_Leaps) * Mili; + + -- 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_M >= Next_Leap_M + then + Res_M := Res_M + OS_Time (1) * Mili; + end if; + + -- Leap second validity check + + Rounded_Res_M := Res_M - (Res_M mod Mili); + + if Is_Ada_05 + and then Leap_Sec + and then Rounded_Res_M /= Next_Leap_M + then + raise Time_Error; + end if; + end if; + + return Time (Res_M); + 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 + -- Formal parameter Date is here for interfacing, but is never + -- actually used. + + pragma Unreferenced (Date); + + function get_gmtoff return Long_Integer; + pragma Import (C, get_gmtoff, "get_gmtoff"); + + begin + -- VMS is not capable of determining the time zone in some past or + -- future point in time denoted by Date, thus the current time zone + -- is retrieved. + + return get_gmtoff; + end UTC_Time_Offset; + end Time_Zones_Operations; +end Ada.Calendar; diff --git a/gcc/ada/a-calend-vms.ads b/gcc/ada/a-calend-vms.ads new file mode 100644 index 000000000..56c98697b --- /dev/null +++ b/gcc/ada/a-calend-vms.ads @@ -0,0 +1,270 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C A L E N D A R -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Alpha/VMS version + +with System.OS_Primitives; + +package Ada.Calendar is + + package OSP renames System.OS_Primitives; + + 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; + + subtype Day_Duration is Duration range 0.0 .. 86_400.0; + + function Clock return Time; + + 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); + + function Time_Of + (Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Seconds : Day_Duration := 0.0) return Time; + + 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; + + 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 + pragma Inline (Clock); + + pragma Inline (Year); + pragma Inline (Month); + pragma Inline (Day); + + pragma Inline ("+"); + pragma Inline ("-"); + + pragma Inline ("<"); + pragma Inline ("<="); + pragma Inline (">"); + pragma Inline (">="); + + -- Although the units are 100 nanoseconds, for the purpose of better + -- readability, this unit will be called "mili". + + Mili : constant := 10_000_000; + Mili_F : constant := 10_000_000.0; + Milis_In_Day : constant := 864_000_000_000; + Secs_In_Day : constant := 86_400; + + -- Time is represented as the number of 100-nanosecond (ns) units from the + -- system base date and time 1858-11-17 0.0 (the Smithsonian base date and + -- time for the astronomic calendar). + + -- The time value stored is typically a UTC value, as provided in standard + -- Unix environments. If this is the case then Split and Time_Of perform + -- required conversions to and from local times. + + -- Notwithstanding this definition, Time is not quite the same as OS_Time. + -- Relative Time is positive, whereas relative OS_Time is negative, + -- but this declaration makes for easier conversion. + + type Time is new OSP.OS_Time; + + Days_In_Month : constant array (Month_Number) of Day_Number := + (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); + + 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 + + -- The following packages provide a target independent interface to the + -- children of Calendar - Arithmetic, Formatting and Time_Zones. + + -- NOTE: Delays does not need a target independent interface because + -- VMS already has a target specific file for that package. + + --------------------------- + -- 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; + + --------------------------- + -- 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; + Is_Ada_05 : Boolean; + Time_Zone : Long_Integer); + -- Split a time value into its components. Set Is_Ada_05 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 := False; + Use_Day_Secs : Boolean := False; + Is_Ada_05 : Boolean := False; + Time_Zone : Long_Integer := 0) return Time; + -- 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. Set Is_Ada_05 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 the offset in seconds from UTC + + end Time_Zones_Operations; + +end Ada.Calendar; diff --git a/gcc/ada/a-calend.adb b/gcc/ada/a-calend.adb new file mode 100644 index 000000000..dd500f436 --- /dev/null +++ b/gcc/ada/a-calend.adb @@ -0,0 +1,1523 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C A L E N D 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 Ada.Unchecked_Conversion; + +with System.OS_Primitives; + +package body Ada.Calendar 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 behaviour 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 (a-calfor, a-calfor-vms, a-calfor-vxwors, etc). + + ----------------------- + -- 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 + + ----------------- + -- 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 the + -- support. + + Leap_Support : constant Boolean := Flag = 1; + -- The above flag controls the usage of leap seconds in all Ada.Calendar + -- routines. + + Leap_Seconds_Count : constant Natural := 24; + + --------------------- + -- 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; + + 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. + + 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); + + --------- + -- "+" -- + --------- + + 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); + + -- The bounds of type Duration expressed as time representations + + Dur_Low : constant Time_Rep := Duration_To_Time_Rep (Duration'First); + Dur_High : constant Time_Rep := Duration_To_Time_Rep (Duration'Last); + + 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 Is_Ada_05 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, + Is_Ada_05 => False, + 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 Is_Ada_05 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, + Is_Ada_05 => False, + Time_Zone => 0); + end Time_Of; + + ---------- + -- 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 + Is_Ada_05 => True, -- Force usage of explicit time zone + 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 + (T, Year, Month, tm_day, Day_Secs, + tm_hour, tm_min, Second, Sub_Sec, Leap_Sec, True, 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 := + Time_Zones_Operations.UTC_Time_Offset (Date); + + 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; + Is_Ada_05 : 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. + + if Is_Ada_05 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 := + Time_Zones_Operations.UTC_Time_Offset (Time (Date_N)); + 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; + 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 := False; + Use_Day_Secs : Boolean := False; + Is_Ada_05 : Boolean := False; + Time_Zone : Long_Integer := 0) 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 Is_Ada_05 then + if Time_Zone /= 0 then + Res_N := Res_N - Time_Rep (Time_Zone) * 60 * Nano; + end if; + + -- Ada 83 and 95 + + else + declare + Current_Off : constant Long_Integer := + Time_Zones_Operations.UTC_Time_Offset + (Time (Res_N)); + Current_Res_N : constant Time_Rep := + Res_N - Time_Rep (Current_Off) * Nano; + Off : constant Long_Integer := + Time_Zones_Operations.UTC_Time_Offset + (Time (Current_Res_N)); + 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 Is_Ada_05 + 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 + + -- The Unix time bounds in nanoseconds: 1970/1/1 .. 2037/1/1 + + Unix_Min : constant Time_Rep := Ada_Low + + Time_Rep (17 * 366 + 52 * 365) * Nanos_In_Day; + + Unix_Max : constant Time_Rep := Ada_Low + + Time_Rep (34 * 366 + 102 * 365) * Nanos_In_Day + + Time_Rep (Leap_Seconds_Count) * Nano; + + -- 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; + + subtype long is Long_Integer; + type long_Pointer is access all 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; + off : long_Pointer); + pragma Import (C, localtime_tzoff, "__gnat_localtime_tzoff"); + -- This is a lightweight wrapper around the system library function + -- localtime_r. Parameter 'off' captures the UTC offset which is either + -- retrieved from the tm struct or calculated from the 'timezone' extern + -- and the tm_isdst flag in the tm struct. + + --------------------- + -- UTC_Time_Offset -- + --------------------- + + function UTC_Time_Offset (Date : Time) return Long_Integer is + Adj_Cent : Integer; + Date_N : Time_Rep; + Offset : aliased long; + Secs_T : aliased time_t; + + 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); + + localtime_tzoff + (Secs_T'Unchecked_Access, + Offset'Unchecked_Access); + + return Offset; + 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 new file mode 100644 index 000000000..428caef2f --- /dev/null +++ b/gcc/ada/a-calend.ads @@ -0,0 +1,358 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C A L E N D A R -- +-- -- +-- 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.Calendar 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; + -- 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 + 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. + + -- 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. + + type Time_Rep is range -2 ** 63 .. +2 ** 63 - 1; + type Time is new Time_Rep; + + Days_In_Month : constant array (Month_Number) of Day_Number := + (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); + + 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 + + -- 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; + Is_Ada_05 : Boolean; + Time_Zone : Long_Integer); + -- Split a time value into its components. Set Is_Ada_05 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 := False; + Use_Day_Secs : Boolean := False; + Is_Ada_05 : Boolean := False; + Time_Zone : Long_Integer := 0) return Time; + -- 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. Set Is_Ada_05 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 the offset in seconds from UTC + + end Time_Zones_Operations; + +end Ada.Calendar; diff --git a/gcc/ada/a-calfor.adb b/gcc/ada/a-calfor.adb new file mode 100644 index 000000000..39c3c0a2f --- /dev/null +++ b/gcc/ada/a-calfor.adb @@ -0,0 +1,944 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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; 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 + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Duration; + SS_Nat : Natural; + + Low : Integer; + High : Integer; + + Result : String := "-00:00:00.00"; + + begin + Split (abs (Elapsed_Time), Hour, Minute, Second, Sub_Second); + + -- Determine the two slice bounds for the result string depending on + -- whether the input is negative and whether fractions are requested. + + Low := (if Elapsed_Time < 0.0 then 1 else 2); + High := (if Include_Time_Fraction then 12 else 9); + + -- Prevent rounding when converting to natural + + Sub_Second := Sub_Second * 100.0; + + if Sub_Second > 0.0 then + Sub_Second := Sub_Second - 0.5; + end if; + + SS_Nat := Natural (Sub_Second); + + declare + Hour_Str : constant String := Hour_Number'Image (Hour); + Minute_Str : constant String := Minute_Number'Image (Minute); + Second_Str : constant String := Second_Number'Image (Second); + SS_Str : constant String := Natural'Image (SS_Nat); + + begin + -- Hour processing, positions 2 and 3 + + if Hour < 10 then + Result (3) := Hour_Str (2); + else + Result (2) := Hour_Str (2); + Result (3) := Hour_Str (3); + end if; + + -- Minute processing, positions 5 and 6 + + if Minute < 10 then + Result (6) := Minute_Str (2); + else + Result (5) := Minute_Str (2); + Result (6) := Minute_Str (3); + end if; + + -- Second processing, positions 8 and 9 + + if Second < 10 then + Result (9) := Second_Str (2); + else + Result (8) := Second_Str (2); + Result (9) := Second_Str (3); + end if; + + -- Optional sub second processing, positions 11 and 12 + + if Include_Time_Fraction then + if SS_Nat < 10 then + Result (12) := SS_Str (2); + else + Result (11) := SS_Str (2); + Result (12) := SS_Str (3); + end if; + end if; + + return Result (Low .. High); + end; + end Image; + + ----------- + -- Image -- + ----------- + + function Image + (Date : Time; + Include_Time_Fraction : Boolean := False; + Time_Zone : Time_Zones.Time_Offset := 0) return String + is + 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; + + Result : String := "0000-00-00 00:00:00.00"; + + begin + Split (Date, Year, Month, Day, + Hour, Minute, Second, Sub_Second, Leap_Second, Time_Zone); + + -- Prevent rounding when converting to natural + + Sub_Second := Sub_Second * 100.0; + + if Sub_Second > 0.0 then + Sub_Second := Sub_Second - 0.5; + end if; + + SS_Nat := Natural (Sub_Second); + + declare + Year_Str : constant String := Year_Number'Image (Year); + Month_Str : constant String := Month_Number'Image (Month); + Day_Str : constant String := Day_Number'Image (Day); + Hour_Str : constant String := Hour_Number'Image (Hour); + Minute_Str : constant String := Minute_Number'Image (Minute); + Second_Str : constant String := Second_Number'Image (Second); + SS_Str : constant String := Natural'Image (SS_Nat); + + begin + -- Year processing, positions 1, 2, 3 and 4 + + Result (1) := Year_Str (2); + Result (2) := Year_Str (3); + Result (3) := Year_Str (4); + Result (4) := Year_Str (5); + + -- Month processing, positions 6 and 7 + + if Month < 10 then + Result (7) := Month_Str (2); + else + Result (6) := Month_Str (2); + Result (7) := Month_Str (3); + end if; + + -- Day processing, positions 9 and 10 + + if Day < 10 then + Result (10) := Day_Str (2); + else + Result (9) := Day_Str (2); + Result (10) := Day_Str (3); + end if; + + -- Hour processing, positions 12 and 13 + + if Hour < 10 then + Result (13) := Hour_Str (2); + else + Result (12) := Hour_Str (2); + Result (13) := Hour_Str (3); + end if; + + -- Minute processing, positions 15 and 16 + + if Minute < 10 then + Result (16) := Minute_Str (2); + else + Result (15) := Minute_Str (2); + Result (16) := Minute_Str (3); + end if; + + -- Second processing, positions 18 and 19 + + if Second < 10 then + Result (19) := Second_Str (2); + else + Result (18) := Second_Str (2); + Result (19) := Second_Str (3); + end if; + + -- Optional sub second processing, positions 21 and 22 + + if Include_Time_Fraction then + if SS_Nat < 10 then + Result (22) := SS_Str (2); + else + Result (21) := SS_Str (2); + Result (22) := SS_Str (3); + end if; + + return Result; + else + return Result (1 .. 19); + end if; + end; + 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, + Time_Zone => Tz, + Is_Ada_05 => True); + + -- 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, + Time_Zone => Tz, + Is_Ada_05 => True); + + -- 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, + Time_Zone => Tz, + Is_Ada_05 => True); + + -- 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, + Is_Ada_05 => 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, + Is_Ada_05 => 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 new file mode 100644 index 000000000..d5cc934b9 --- /dev/null +++ b/gcc/ada/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-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 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 new file mode 100644 index 000000000..559918b0b --- /dev/null +++ b/gcc/ada/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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Calendar.Time_Zones is + + -------------------------- + -- Implementation Notes -- + -------------------------- + + -- All operations in this package are target and time representation + -- independent, thus only one source file is needed for multiple targets. + + --------------------- + -- UTC_Time_Offset -- + --------------------- + + function UTC_Time_Offset (Date : Time := Clock) return Time_Offset is + Offset_L : constant Long_Integer := + Time_Zones_Operations.UTC_Time_Offset (Date); + Offset : Time_Offset; + + begin + if Offset_L = Invalid_Time_Zone_Offset then + raise Unknown_Zone_Error; + end if; + + -- The offset returned by Time_Zones_Operations.UTC_Time_Offset is in + -- seconds, the returned value needs to be in minutes. + + Offset := Time_Offset (Offset_L / 60); + + -- Validity checks + + if not Offset'Valid then + raise Unknown_Zone_Error; + end if; + + return Offset; + end UTC_Time_Offset; + +end Ada.Calendar.Time_Zones; diff --git a/gcc/ada/a-catizo.ads b/gcc/ada/a-catizo.ads new file mode 100644 index 000000000..755325f75 --- /dev/null +++ b/gcc/ada/a-catizo.ads @@ -0,0 +1,34 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C A L E N D A R . T I M E _ Z O N E S -- +-- -- +-- S p e c -- +-- -- +-- 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 routines to determine the offset of dates to GMT. +-- It is defined in the Ada 2005 RM (9.6.1). + +package Ada.Calendar.Time_Zones is + + -- Time zone manipulation + + type Time_Offset is range -(28 * 60) .. 28 * 60; + + Unknown_Zone_Error : exception; + + function UTC_Time_Offset (Date : Time := Clock) return Time_Offset; + -- Returns (in minutes), the difference between the implementation-defined + -- time zone of Calendar, and UTC time, at the time Date. If the time zone + -- of the Calendar implementation is unknown, raises Unknown_Zone_Error. + +end Ada.Calendar.Time_Zones; diff --git a/gcc/ada/a-cbdlli.adb b/gcc/ada/a-cbdlli.adb new file mode 100644 index 000000000..2dd8a5c87 --- /dev/null +++ b/gcc/ada/a-cbdlli.adb @@ -0,0 +1,2005 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.BOUNDED_DOUBLY_LINKED_LISTS -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +with System; use type System.Address; + +package body Ada.Containers.Bounded_Doubly_Linked_Lists is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Allocate + (Container : in out List; + New_Item : Element_Type; + New_Node : out Count_Type); + + procedure Allocate + (Container : in out List; + New_Node : out Count_Type); + + procedure Allocate + (Container : in out List; + Stream : not null access Root_Stream_Type'Class; + New_Node : out Count_Type); + + procedure Free + (Container : in out List; + X : Count_Type); + + procedure Insert_Internal + (Container : in out List; + Before : Count_Type; + New_Node : Count_Type); + + 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, RI : Count_Type; + + begin + if Left'Address = Right'Address then + return True; + end if; + + if Left.Length /= Right.Length then + return False; + end if; + + LI := Left.First; + RI := Right.First; + 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; + New_Item : Element_Type; + New_Node : out Count_Type) + is + N : Node_Array renames Container.Nodes; + + begin + if Container.Free >= 0 then + New_Node := Container.Free; + + -- We always perform the assignment first, before we + -- change container state, in order to defend against + -- exceptions duration assignment. + + N (New_Node).Element := New_Item; + Container.Free := N (New_Node).Next; + + else + -- A negative free store value means that the links of the nodes + -- in the free store have not been initialized. In this case, the + -- nodes are physically contiguous in the array, starting at the + -- index that is the absolute value of the Container.Free, and + -- continuing until the end of the array (Nodes'Last). + + New_Node := abs Container.Free; + + -- As above, we perform this assignment first, before modifying + -- any container state. + + N (New_Node).Element := New_Item; + Container.Free := Container.Free - 1; + end if; + end Allocate; + + procedure Allocate + (Container : in out List; + Stream : not null access Root_Stream_Type'Class; + New_Node : out Count_Type) + is + N : Node_Array renames Container.Nodes; + + begin + if Container.Free >= 0 then + New_Node := Container.Free; + + -- We always perform the assignment first, before we + -- change container state, in order to defend against + -- exceptions duration assignment. + + Element_Type'Read (Stream, N (New_Node).Element); + Container.Free := N (New_Node).Next; + + else + -- A negative free store value means that the links of the nodes + -- in the free store have not been initialized. In this case, the + -- nodes are physically contiguous in the array, starting at the + -- index that is the absolute value of the Container.Free, and + -- continuing until the end of the array (Nodes'Last). + + New_Node := abs Container.Free; + + -- As above, we perform this assignment first, before modifying + -- any container state. + + Element_Type'Read (Stream, N (New_Node).Element); + Container.Free := Container.Free - 1; + end if; + end Allocate; + + procedure Allocate + (Container : in out List; + New_Node : out Count_Type) + is + N : Node_Array renames Container.Nodes; + + begin + if Container.Free >= 0 then + New_Node := Container.Free; + Container.Free := N (New_Node).Next; + + else + -- As explained above, a negative free store value means that the + -- links for the nodes in the free store have not been initialized. + + New_Node := abs Container.Free; + Container.Free := Container.Free - 1; + end if; + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, No_Element, New_Item, Count); + end Append; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out List; Source : List) is + SN : Node_Array renames Source.Nodes; + J : Count_Type; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Capacity < Source.Length then + raise Capacity_Error -- ??? + with "Target capacity is less than Source length"; + end if; + + Target.Clear; + + J := Source.First; + while J /= 0 loop + Target.Append (SN (J).Element); + J := SN (J).Next; + end loop; + end Assign; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out List) is + N : Node_Array renames Container.Nodes; + X : Count_Type; + + begin + if Container.Length = 0 then + pragma Assert (Container.First = 0); + pragma Assert (Container.Last = 0); + pragma Assert (Container.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 with + "attempt to tamper with cursors (list is busy)"; + end if; + + while Container.Length > 1 loop + X := Container.First; + pragma Assert (N (N (X).Next).Prev = Container.First); + + Container.First := N (X).Next; + N (Container.First).Prev := 0; + + Container.Length := Container.Length - 1; + + Free (Container, X); + end loop; + + X := Container.First; + pragma Assert (X = Container.Last); + + Container.First := 0; + Container.Last := 0; + Container.Length := 0; + + Free (Container, X); + end Clear; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : List; + Item : Element_Type) return Boolean + is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : List; Capacity : Count_Type := 0) return List is + C : Count_Type; + + begin + if Capacity = 0 then + C := Source.Length; + + elsif Capacity >= Source.Length then + C := Capacity; + + else + raise Capacity_Error with "Capacity value too small"; + end if; + + return Target : List (Capacity => C) do + Assign (Target => Target, Source => Source); + end return; + end Copy; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type := 1) + is + N : Node_Array renames Container.Nodes; + X : Count_Type; + + begin + if Position.Node = 0 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), "bad cursor in Delete"); + pragma Assert (Container.First >= 1); + pragma Assert (Container.Last >= 1); + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + if Position.Node = Container.First then + Delete_First (Container, Count); + Position := No_Element; + return; + end if; + + if Count = 0 then + Position := No_Element; + return; + end if; + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + end if; + + for Index in 1 .. Count loop + pragma Assert (Container.Length >= 2); + + X := Position.Node; + Container.Length := Container.Length - 1; + + if X = Container.Last then + Position := No_Element; + + Container.Last := N (X).Prev; + N (Container.Last).Next := 0; + + Free (Container, X); + return; + end if; + + Position.Node := N (X).Next; + + 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 with + "attempt to tamper with cursors (list is busy)"; + 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 with + "attempt to tamper with cursors (list is busy)"; + 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 with + "Position cursor has no element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Element"); + + return Position.Container.Nodes (Position.Node).Element; + end Element; + + ---------- + -- 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 with + "Position cursor designates wrong container"; + 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 + begin + if Container.First = 0 then + raise Constraint_Error with "list is empty"; + end if; + + return Container.Nodes (Container.First).Element; + end First_Element; + + ---------- + -- Free -- + ---------- + + procedure Free + (Container : in out List; + X : Count_Type) + is + pragma Assert (X > 0); + pragma Assert (X <= Container.Capacity); + + N : Node_Array renames Container.Nodes; + pragma Assert (N (X).Prev >= 0); -- node is active + + begin + -- The list container actually contains two lists: one for the "active" + -- nodes that contain elements that have been inserted onto the list, + -- and another for the "inactive" nodes for the free store. + -- + -- We desire that merely declaring an object should have only minimal + -- cost; specially, we want to avoid having to initialize the free + -- store (to fill in the links), especially if the capacity is large. + -- + -- The head of the free list is indicated by Container.Free. If its + -- value is non-negative, then the free store has been initialized + -- in the "normal" way: Container.Free points to the head of the list + -- of free (inactive) nodes, and the value 0 means the free list is + -- empty. Each node on the free list has been initialized to point + -- to the next free node (via its Next component), and the value 0 + -- means that this is the last free node. + -- + -- If Container.Free is negative, then the links on the free store + -- have not been initialized. In this case the link values are + -- implied: the free store comprises the components of the node array + -- started with the absolute value of Container.Free, and continuing + -- until the end of the array (Nodes'Last). + -- + -- If the list container is manipulated on one end only (for example + -- if the container were being used as a stack), then there is no + -- need to initialize the free store, since the inactive nodes are + -- physically contiguous (in fact, they lie immediately beyond the + -- logical end being manipulated). The only time we need to actually + -- initialize the nodes in the free store is if the node that becomes + -- inactive is not at the end of the list. The free store would then + -- be discontiguous and so its nodes would need to be linked in the + -- traditional way. + -- + -- ??? + -- It might be possible to perform an optimization here. Suppose that + -- the free store can be represented as having two parts: one + -- comprising the non-contiguous inactive nodes linked together + -- in the normal way, and the other comprising the contiguous + -- inactive nodes (that are not linked together, at the end of the + -- nodes array). This would allow us to never have to initialize + -- the free store, except in a lazy way as nodes become inactive. + + -- When an element is deleted from the list container, its node + -- becomes inactive, and so we set its Prev component to a negative + -- value, to indicate that it is now inactive. This provides a useful + -- way to detect a dangling cursor reference. + + N (X).Prev := -1; -- Node is deallocated (not on active list) + + if Container.Free >= 0 then + -- The free store has previously been initialized. All we need to + -- do here is link the newly-free'd node onto the free list. + + N (X).Next := Container.Free; + Container.Free := X; + + elsif X + 1 = abs Container.Free then + -- The free store has not been initialized, and the node becoming + -- inactive immediately precedes the start of the free store. All + -- we need to do is move the start of the free store back by one. + + N (X).Next := 0; -- 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 as the absolute value of + -- that index value. + + Container.Free := abs Container.Free; + + if Container.Free > Container.Capacity then + Container.Free := 0; + + else + for I in Container.Free .. Container.Capacity - 1 loop + N (I).Next := I + 1; + end loop; + + N (Container.Capacity).Next := 0; + end if; + + N (X).Next := Container.Free; + Container.Free := X; + end if; + end Free; + + --------------------- + -- Generic_Sorting -- + --------------------- + + package body Generic_Sorting is + + --------------- + -- Is_Sorted -- + --------------- + + function Is_Sorted (Container : List) return Boolean is + 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; + + ----------- + -- Merge -- + ----------- + + procedure Merge + (Target : in out List; + Source : in out List) + is + LN : Node_Array renames Target.Nodes; + RN : Node_Array renames Source.Nodes; + LI, RI : Cursor; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Target (list is busy)"; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Source (list is busy)"; + end if; + + LI := First (Target); + RI := First (Source); + while RI.Node /= 0 loop + pragma Assert (RN (RI.Node).Next = 0 + or else not (RN (RN (RI.Node).Next).Element < + RN (RI.Node).Element)); + + if LI.Node = 0 then + Splice (Target, No_Element, Source); + return; + end if; + + pragma Assert (LN (LI.Node).Next = 0 + or else not (LN (LN (LI.Node).Next).Element < + LN (LI.Node).Element)); + + if RN (RI.Node).Element < LN (LI.Node).Element then + declare + RJ : Cursor := RI; + pragma Warnings (Off, RJ); + begin + RI.Node := RN (RI.Node).Next; + Splice (Target, LI, Source, RJ); + end; + + else + LI.Node := LN (LI.Node).Next; + end if; + end loop; + end Merge; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Container : in out List) is + N : Node_Array renames Container.Nodes; + + procedure Partition (Pivot, 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 with + "attempt to tamper with cursors (list is busy)"; + 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 + New_Node : Count_Type; + + begin + if Before.Container /= null then + if 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 Container.Length > Container.Capacity - Count then + raise Constraint_Error with "new length exceeds capacity"; + end if; + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + end if; + + Allocate (Container, New_Item, New_Node); + Insert_Internal (Container, Before.Node, New_Node => New_Node); + Position := Cursor'(Container'Unchecked_Access, Node => New_Node); + + for Index in Count_Type'(2) .. Count loop + Allocate (Container, New_Item, New_Node => New_Node); + Insert_Internal (Container, Before.Node, New_Node => New_Node); + end loop; + 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_Node : Count_Type; + + begin + if Before.Container /= null then + if 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 Container.Length > Container.Capacity - Count then + raise Constraint_Error with "new length exceeds capacity"; + end if; + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + end if; + + Allocate (Container, New_Node => New_Node); + Insert_Internal (Container, Before.Node, New_Node); + Position := Cursor'(Container'Unchecked_Access, New_Node); + + for Index in Count_Type'(2) .. Count loop + Allocate (Container, New_Node => New_Node); + Insert_Internal (Container, Before.Node, New_Node); + end loop; + end Insert; + + --------------------- + -- Insert_Internal -- + --------------------- + + procedure Insert_Internal + (Container : in out List; + Before : Count_Type; + New_Node : Count_Type) + is + N : Node_Array renames Container.Nodes; + + begin + if Container.Length = 0 then + pragma Assert (Before = 0); + pragma Assert (Container.First = 0); + pragma Assert (Container.Last = 0); + + Container.First := New_Node; + N (Container.First).Prev := 0; + + Container.Last := New_Node; + N (Container.Last).Next := 0; + + elsif Before = 0 then -- means append + 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 -- means prepend + 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; + B : Natural renames C.Busy; + + Node : Count_Type := Container.First; + + begin + B := B + 1; + + begin + while Node /= 0 loop + Process (Cursor'(Container'Unrestricted_Access, Node)); + Node := Container.Nodes (Node).Next; + end loop; + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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 + begin + if Container.Last = 0 then + raise Constraint_Error with "list is empty"; + end if; + + return Container.Nodes (Container.Last).Element; + end Last_Element; + + ------------ + -- Length -- + ------------ + + function Length (Container : List) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move + (Target : in out List; + Source : in out List) + is + N : Node_Array renames Source.Nodes; + X : Count_Type; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Capacity < Source.Length then + raise Capacity_Error with "Source length exceeds Target capacity"; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Source (list is busy)"; + end if; + + Clear (Target); + + while Source.Length > 0 loop + X := Source.First; + Append (Target, N (X).Element); + + Source.First := N (X).Next; + N (Source.First).Prev := 0; + + Source.Length := Source.Length - 1; + Free (Source, X); + end loop; + end Move; + + ---------- + -- Next -- + ---------- + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position.Node = 0 then + return No_Element; + end if; + + pragma Assert (Vet (Position), "bad cursor in Next"); + + declare + Nodes : Node_Array renames Position.Container.Nodes; + Node : constant Count_Type := Nodes (Position.Node).Next; + begin + if Node = 0 then + return No_Element; + 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 with + "Position cursor has no element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Query_Element"); + + declare + C : List renames Position.Container.all'Unrestricted_Access.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + + begin + B := B + 1; + L := L + 1; + + declare + N : Node_Type renames C.Nodes (Position.Node); + begin + Process (N.Element); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out List) + is + N : Count_Type'Base; + X : Count_Type; + + begin + Clear (Item); + Count_Type'Base'Read (Stream, N); + + if N < 0 then + raise Program_Error with "bad list length (corrupt stream)"; + end if; + + if N = 0 then + return; + end if; + + if N > Item.Capacity then + raise Constraint_Error with "length exceeds capacity"; + end if; + + for Idx in 1 .. N loop + Allocate (Item, Stream, New_Node => X); + Insert_Internal (Item, Before => 0, New_Node => X); + end loop; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream list cursor"; + end Read; + + --------------------- + -- 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 with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unchecked_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (list is locked)"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + + Container.Nodes (Position.Node).Element := New_Item; + end Replace_Element; + + ---------------------- + -- Reverse_Elements -- + ---------------------- + + procedure Reverse_Elements (Container : in out List) is + N : Node_Array renames Container.Nodes; + I : Count_Type := Container.First; + J : Count_Type := Container.Last; + + procedure Swap (L, R : Count_Type); + + ---------- + -- Swap -- + ---------- + + procedure Swap (L, R : Count_Type) is + LN : constant Count_Type := N (L).Next; + LP : constant Count_Type := N (L).Prev; + + RN : constant Count_Type := N (R).Next; + RP : constant Count_Type := N (R).Prev; + + begin + if LP /= 0 then + N (LP).Next := R; + end if; + + if RN /= 0 then + N (RN).Prev := L; + end if; + + N (L).Next := RN; + N (R).Prev := LP; + + if LN = R then + pragma Assert (RP = L); + + N (L).Prev := R; + N (R).Next := L; + + else + N (L).Prev := RP; + N (RP).Next := L; + + N (R).Next := LN; + N (LN).Prev := R; + end if; + end Swap; + + -- Start of processing for Reverse_Elements + + begin + if Container.Length <= 1 then + return; + end if; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + 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 + Node : Count_Type := Position.Node; + + begin + if Node = 0 then + Node := Container.Last; + + else + if 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; + + while Node /= 0 loop + if Container.Nodes (Node).Element = Item then + return Cursor'(Container'Unrestricted_Access, Node); + end if; + + Node := Container.Nodes (Node).Prev; + end loop; + + return No_Element; + end Reverse_Find; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)) + is + C : List renames Container'Unrestricted_Access.all; + B : Natural renames C.Busy; + + Node : Count_Type := Container.Last; + + begin + B := B + 1; + + begin + while Node /= 0 loop + Process (Cursor'(Container'Unrestricted_Access, Node)); + Node := Container.Nodes (Node).Prev; + end loop; + + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Reverse_Iterate; + + ------------ + -- Splice -- + ------------ + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List) + is + begin + if Before.Container /= null then + if 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; + + pragma Assert (Source.Nodes (Source.First).Prev = 0); + pragma Assert (Source.Nodes (Source.Last).Next = 0); + + if Target.Length > Count_Type'Last - Source.Length then + raise Constraint_Error with "new length exceeds maximum"; + end if; + + if Target.Length + Source.Length > Target.Capacity then + raise Capacity_Error with "new length exceeds target capacity"; + end if; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Target (list is busy)"; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Source (list is busy)"; + end if; + + loop + Insert (Target, Before, Source.Nodes (Source.Last).Element); + Delete_Last (Source); + exit when Is_Empty (Source); + end loop; + end Splice; + + procedure Splice + (Container : in out List; + Before : Cursor; + Position : Cursor) + is + N : Node_Array renames Container.Nodes; + + begin + if Before.Container /= null then + if 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 Position.Node = 0 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), "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 with + "attempt to tamper with cursors (list is busy)"; + 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; + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List; + Position : in out Cursor) + is + Target_Position : Cursor; + + begin + if Target'Address = Source'Address then + Splice (Target, Before, Position); + return; + end if; + + if Before.Container /= null then + if 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 Position.Node = 0 then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if 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 Target.Length >= Target.Capacity then + raise Capacity_Error with "Target is full"; + end if; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Target (list is busy)"; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Source (list is busy)"; + end if; + + Insert + (Container => Target, + Before => Before, + New_Item => Source.Nodes (Position.Node).Element, + Position => Target_Position); + + Delete (Source, Position); + Position := Target_Position; + end Splice; + + ---------- + -- Swap -- + ---------- + + procedure Swap + (Container : in out List; + I, J : Cursor) + is + begin + if I.Node = 0 then + raise Constraint_Error with "I cursor has no element"; + end if; + + if J.Node = 0 then + raise Constraint_Error with "J cursor has no element"; + end if; + + if I.Container /= Container'Unchecked_Access then + raise Program_Error with "I cursor designates wrong container"; + end if; + + if 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; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (list is locked)"; + end if; + + pragma Assert (Vet (I), "bad I cursor in Swap"); + pragma Assert (Vet (J), "bad J cursor in Swap"); + + declare + EI : Element_Type renames Container.Nodes (I.Node).Element; + EJ : Element_Type renames Container.Nodes (J.Node).Element; + + EI_Copy : constant Element_Type := EI; + + begin + EI := EJ; + EJ := EI_Copy; + end; + end Swap; + + ---------------- + -- Swap_Links -- + ---------------- + + procedure Swap_Links + (Container : in out List; + I, J : Cursor) + is + begin + if I.Node = 0 then + raise Constraint_Error with "I cursor has no element"; + end if; + + if J.Node = 0 then + raise Constraint_Error with "J cursor has no element"; + end if; + + if I.Container /= Container'Unrestricted_Access then + raise Program_Error with "I cursor designates wrong container"; + end if; + + if 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; + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + 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); + + 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 Position.Node = 0 then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if 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 + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; + + begin + B := B + 1; + L := L + 1; + + declare + N : Node_Type renames Container.Nodes (Position.Node); + begin + Process (N.Element); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; + end Update_Element; + + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = 0 then + return Position.Container = null; + end if; + + if Position.Container = null then + return False; + end if; + + declare + L : List renames Position.Container.all; + N : Node_Array renames L.Nodes; + begin + if L.Length = 0 then + return False; + end if; + + if L.First = 0 + or L.First > L.Capacity + then + return False; + end if; + + if L.Last = 0 + or L.Last > L.Capacity + then + return False; + end if; + + if N (L.First).Prev /= 0 then + return False; + end if; + + if N (L.Last).Next /= 0 then + return False; + end if; + + if Position.Node > L.Capacity then + return False; + end if; + + if N (Position.Node).Prev < 0 then -- see Free + return False; + end if; + + if N (Position.Node).Prev > L.Capacity then + return False; + end if; + + if N (Position.Node).Next = Position.Node then + return False; + end if; + + if N (Position.Node).Prev = Position.Node then + return False; + end if; + + if N (Position.Node).Prev = 0 + and then Position.Node /= L.First + then + return False; + end if; + + -- If we get here, we know that this disjunction is true: + -- N (Position.Node).Prev /= 0 or else Position.Node = L.First + + if N (Position.Node).Next = 0 + and then Position.Node /= L.Last + then + return False; + end if; + + -- If we get here, we know that this disjunction is true: + -- N (Position.Node).Next /= 0 or else Position.Node = L.Last + + if L.Length = 1 then + return L.First = L.Last; + end if; + + if L.First = L.Last then + return False; + end if; + + if N (L.First).Next = 0 then + return False; + end if; + + if N (L.Last).Prev = 0 then + return False; + end if; + + if N (N (L.First).Next).Prev /= L.First then + return False; + end if; + + if N (N (L.Last).Prev).Next /= L.Last then + return False; + end if; + + if L.Length = 2 then + if N (L.First).Next /= L.Last then + return False; + end if; + + if N (L.Last).Prev /= L.First then + return False; + end if; + + return True; + end if; + + if N (L.First).Next = L.Last then + return False; + end if; + + if N (L.Last).Prev = L.First then + return False; + end if; + + if Position.Node = L.First then -- eliminates earlier disjunct + return True; + end if; + + -- If we get here, we know, per disjunctive syllogism (modus + -- tollendo ponens), that this predicate is true: + -- N (Position.Node).Prev /= 0 + + if Position.Node = L.Last then -- eliminates earlier disjunct + return True; + end if; + + -- If we get here, we know, per disjunctive syllogism (modus + -- tollendo ponens), that this predicate is true: + -- N (Position.Node).Next /= 0 + + if N (N (Position.Node).Next).Prev /= Position.Node then + return False; + end if; + + if N (N (Position.Node).Prev).Next /= Position.Node then + return False; + end if; + + if L.Length = 3 then + if N (L.First).Next /= Position.Node then + return False; + end if; + + if N (L.Last).Prev /= Position.Node then + return False; + end if; + end if; + + return True; + end; + end Vet; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : List) + is + Node : Count_Type; + + begin + Count_Type'Base'Write (Stream, Item.Length); + + Node := Item.First; + while Node /= 0 loop + Element_Type'Write (Stream, Item.Nodes (Node).Element); + Node := Item.Nodes (Node).Next; + end loop; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream list cursor"; + end Write; + +end Ada.Containers.Bounded_Doubly_Linked_Lists; diff --git a/gcc/ada/a-cbdlli.ads b/gcc/ada/a-cbdlli.ads new file mode 100644 index 000000000..2e5d96cd5 --- /dev/null +++ b/gcc/ada/a-cbdlli.ads @@ -0,0 +1,270 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.BOUNDED_DOUBLY_LINKED_LISTS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-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 -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +private with Ada.Streams; + +generic + type Element_Type is private; + + with function "=" (Left, Right : Element_Type) + return Boolean is <>; + +package Ada.Containers.Bounded_Doubly_Linked_Lists is + pragma Pure; + pragma Remote_Types; + + type List (Capacity : Count_Type) is tagged private; + pragma Preelaborable_Initialization (List); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_List : constant List; + + No_Element : constant Cursor; + + 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)); + + 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); + + 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; + + function Has_Element (Position : Cursor) 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); + + type Node_Type is 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 record + Nodes : Node_Array (1 .. Capacity) := (others => <>); + Free : Count_Type'Base := -1; + First : Count_Type := 0; + Last : Count_Type := 0; + Length : Count_Type := 0; + Busy : Natural := 0; + Lock : Natural := 0; + end record; + + use Ada.Streams; + + 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; + + Empty_List : constant List := (Capacity => 0, others => <>); + + No_Element : constant Cursor := Cursor'(null, 0); + +end Ada.Containers.Bounded_Doubly_Linked_Lists; diff --git a/gcc/ada/a-cbhama.adb b/gcc/ada/a-cbhama.adb new file mode 100644 index 000000000..942007cde --- /dev/null +++ b/gcc/ada/a-cbhama.adb @@ -0,0 +1,1068 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Hash_Tables.Generic_Bounded_Operations; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations); + +with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); + +with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; +with System; use type System.Address; + +package body Ada.Containers.Bounded_Hashed_Maps is + + ----------------------- + -- 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 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; + + -------------- + -- 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; + + else + 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 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 Position.Node = 0 then + raise Constraint_Error with + "Position cursor of Delete equals No_Element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor of Delete designates wrong map"; + end if; + + if Container.Busy > 0 then + raise Program_Error with + "Delete attempted to tamper with cursors (map is busy)"; + end if; + + 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, Key); + + begin + if Node = 0 then + raise Constraint_Error with + "no element available because key not in map"; + end if; + + return Container.Nodes (Node).Element; + end Element; + + function Element (Position : Cursor) return Element_Type is + begin + if 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 Left.Node = 0 then + raise Constraint_Error with + "Left cursor of Equivalent_Keys equals No_Element"; + end if; + + if 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 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 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; + + ---------- + -- Find -- + ---------- + + function Find (Container : Map; Key : Key_Type) return Cursor is + Node : constant Count_Type := Key_Ops.Find (Container, Key); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Map) return Cursor is + Node : constant Count_Type := HT_Ops.First (Container); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end First; + + ----------------- + -- 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 + if Container.Lock > 0 then + raise Program_Error with + "Include attempted to tamper with elements (map is locked)"; + end if; + + 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 + 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 + -- ??? + -- if HT_Ops.Capacity (HT) = 0 then + -- HT_Ops.Reserve_Capacity (HT, 1); + -- end if; + + Local_Insert (Container, Key, Position.Node, Inserted); + + -- ??? + -- if Inserted + -- and then HT.Length > HT_Ops.Capacity (HT) + -- then + -- HT_Ops.Reserve_Capacity (HT, HT.Length); + -- end if; + + Position.Container := Container'Unchecked_Access; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + 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 + -- ?? + -- if HT_Ops.Capacity (HT) = 0 then + -- HT_Ops.Reserve_Capacity (HT, 1); + -- end if; + + Local_Insert (Container, Key, Position.Node, Inserted); + + -- ??? + -- if Inserted + -- and then HT.Length > HT_Ops.Capacity (HT) + -- then + -- HT_Ops.Reserve_Capacity (HT, HT.Length); + -- end if; + + Position.Container := Container'Unchecked_Access; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + pragma Unreferenced (Position); + + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if 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; + + B : Natural renames Container'Unrestricted_Access.Busy; + + -- Start of processing for Iterate + + begin + B := B + 1; + + begin + Local_Iterate (Container); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Iterate; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + if 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; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Assign (Target => Target, Source => Source); + 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; + end if; + + return Cursor'(Position.Container, Node); + end; + end Next; + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : Element_Type)) + is + begin + if 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); + B : Natural renames M.Busy; + L : Natural renames M.Lock; + + begin + B := B + 1; + L := L + 1; + + declare + + begin + Process (N.Key, N.Element); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + 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; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Count_Type := Key_Ops.Find (Container, Key); + + begin + if Node = 0 then + raise Constraint_Error with + "attempt to replace key not in map"; + end if; + + if Container.Lock > 0 then + raise Program_Error with + "Replace attempted to tamper with elements (map is locked)"; + end if; + + declare + N : Node_Type renames Container.Nodes (Node); + + begin + N.Key := Key; + N.Element := New_Item; + end; + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Position.Node = 0 then + raise Constraint_Error with + "Position cursor of Replace_Element equals No_Element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor of Replace_Element designates wrong map"; + end if; + + if Position.Container.Lock > 0 then + raise Program_Error with + "Replace_Element attempted to tamper with elements (map is locked)"; + end if; + + 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 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 Position.Node = 0 then + raise Constraint_Error with + "Position cursor of Update_Element equals No_Element"; + end if; + + if 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); + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (N.Key, N.Element); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + 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.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; + +end Ada.Containers.Bounded_Hashed_Maps; diff --git a/gcc/ada/a-cbhama.ads b/gcc/ada/a-cbhama.ads new file mode 100644 index 000000000..042cc0fa1 --- /dev/null +++ b/gcc/ada/a-cbhama.ads @@ -0,0 +1,343 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +private with Ada.Containers.Hash_Tables; +private with Ada.Streams; + +generic + type Key_Type is private; + type Element_Type is private; + + with function Hash (Key : Key_Type) return Hash_Type; + with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Bounded_Hashed_Maps is + pragma Pure; + pragma Remote_Types; + + type Map (Capacity : Count_Type; Modulus : Hash_Type) is tagged private; + 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 "=" (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. + + 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 then 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 Has_Element (Position : Cursor) return Boolean; + -- Equivalent to Position /= No_Element + + 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 + +private + -- pragma Inline ("="); + pragma Inline (Length); + pragma Inline (Is_Empty); + pragma Inline (Clear); + pragma Inline (Key); + pragma Inline (Element); + pragma Inline (Move); + pragma Inline (Contains); + pragma Inline (Capacity); + pragma Inline (Reserve_Capacity); + pragma Inline (Has_Element); + pragma Inline (Equivalent_Keys); + pragma Inline (Next); + + type Node_Type is record + Key : Key_Type; + Element : 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; + 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; + 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; + + No_Element : constant Cursor := (Container => null, Node => 0); + + Empty_Map : constant Map := + (Hash_Table_Type with Capacity => 0, Modulus => 0); + +end Ada.Containers.Bounded_Hashed_Maps; diff --git a/gcc/ada/a-cbhase.adb b/gcc/ada/a-cbhase.adb new file mode 100644 index 000000000..e477690d9 --- /dev/null +++ b/gcc/ada/a-cbhase.adb @@ -0,0 +1,1737 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Hash_Tables.Generic_Bounded_Operations; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations); + +with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); + +with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; + +with System; use type System.Address; + +package body Ada.Containers.Bounded_Hashed_Sets is + + ----------------------- + -- 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 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; + + -------------- + -- 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; + + else + 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 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 Position.Node = 0 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; + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (set is busy)"; + end if; + + 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; + + 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; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (set is busy)"; + end if; + + 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 (Source, 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 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 := HT_Ops.Next (R_HT, R_Node); + end loop; + end Find_Equivalent_Key; + + -- Start of processing for Equivalent_Sets + + begin + return Is_Equivalent (Left, Right); + end Equivalent_Sets; + + ------------------------- + -- Equivalent_Elements -- + ------------------------- + + function Equivalent_Elements (Left, Right : Cursor) + return Boolean is + begin + if Left.Node = 0 then + raise Constraint_Error with + "Left cursor of Equivalent_Elements equals No_Element"; + end if; + + if 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"); + + 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 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 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; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Set; + Item : Element_Type) return Cursor + is + Node : constant Count_Type := Element_Keys.Find (Container, Item); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Set) return Cursor is + Node : constant Count_Type := HT_Ops.First (Container); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end First; + + ----------------- + -- 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 + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + 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 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 + -- ??? + -- if HT_Ops.Capacity (HT) = 0 then + -- HT_Ops.Reserve_Capacity (HT, 1); + -- end if; + + Local_Insert (Container, 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 + 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; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (set is busy)"; + end if; + + 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, 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, 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; + + B : Natural renames Container'Unrestricted_Access.Busy; + + -- Start of processing for Iterate + + begin + B := B + 1; + + begin + Iterate (Container); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Assign (Target => Target, Source => Source); + 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; + + ------------- + -- 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, Left_Node); + end loop; + + return False; + end Overlap; + + ------------------- + -- 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 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; + B : Natural renames S.Busy; + L : Natural renames S.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (S.Nodes (Position.Node).Element); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + 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; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Set; + New_Item : Element_Type) + is + Node : constant Count_Type := + Element_Keys.Find (Container, New_Item); + + begin + if Node = 0 then + raise Constraint_Error with + "attempt to replace element not in set"; + end if; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + Container.Nodes (Node).Element := New_Item; + end Replace; + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Position.Node = 0 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 (Position), "bad cursor in Replace_Element"); + + Replace_Element (Container, Position.Node, New_Item); + end Replace_Element; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Set; + Capacity : Count_Type) + is + begin + if Capacity > Container.Capacity then + raise 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; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (set is busy)"; + end if; + + 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 Left.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; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (set is busy)"; + end if; + + -- ??? + -- 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.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; + + 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); + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Set; + Key : Key_Type) return Boolean + is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out Set; + Key : Key_Type) + is + X : Count_Type; + + begin + Key_Keys.Delete_Key_Sans_Free (Container, Key, X); + + if X = 0 then + raise Constraint_Error with "attempt to delete key not in set"; + end if; + + 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, Key); + + begin + if Node = 0 then + raise Constraint_Error with "key not in map"; + end if; + + return Container.Nodes (Node).Element; + end Element; + + ------------------------- + -- Equivalent_Key_Node -- + ------------------------- + + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Type) return Boolean + is + begin + return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element)); + end Equivalent_Key_Node; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude + (Container : in out Set; + Key : Key_Type) + is + X : Count_Type; + begin + Key_Keys.Delete_Key_Sans_Free (Container, Key, X); + HT_Ops.Free (Container, X); + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Set; + Key : Key_Type) return Cursor + is + Node : constant Count_Type := + Key_Keys.Find (Container, Key); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Find; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + if 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; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Count_Type := + Key_Keys.Find (Container, Key); + + begin + if Node = 0 then + raise Constraint_Error with + "attempt to replace key not in set"; + end if; + + Replace_Element (Container, Node, New_Item); + end Replace; + + ----------------------------------- + -- 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 Position.Node = 0 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; + + -- ??? + -- 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"); + + -- Record bucket now, in case key is changed. + Indx := HT_Ops.Index (Container.Buckets, N (Position.Node)); + + declare + E : Element_Type renames N (Position.Node).Element; + K : constant Key_Type := Key (E); + + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + + if Equivalent_Keys (K, Key (E)) then + pragma Assert (Hash (K) = Hash (E)); + 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 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; + + end Generic_Keys; + +end Ada.Containers.Bounded_Hashed_Sets; diff --git a/gcc/ada/a-cbhase.ads b/gcc/ada/a-cbhase.ads new file mode 100644 index 000000000..9618ff308 --- /dev/null +++ b/gcc/ada/a-cbhase.ads @@ -0,0 +1,466 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +private with Ada.Containers.Hash_Tables; +private with Ada.Streams; + +generic + type Element_Type is private; + + with function Hash (Element : Element_Type) return Hash_Type; + + with function Equivalent_Elements + (Left, Right : Element_Type) return Boolean; + + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Bounded_Hashed_Sets is + pragma Pure; + pragma Remote_Types; + + type Set (Capacity : Count_Type; Modulus : Hash_Type) is tagged private; + 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 "=" (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 + -- designed by the cursor. + + 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 then 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 Has_Element (Position : Cursor) return Boolean; + -- Equivalent to Position /= 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 + + 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. + + end Generic_Keys; + +private + + pragma Inline (Next); + + type Node_Type is record + Element : 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; + use Ada.Streams; + + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + type Cursor is record + Container : Set_Access; + Node : Count_Type; + 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 := (Container => null, Node => 0); + + 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; + + Empty_Set : constant Set := + (Hash_Table_Type with Capacity => 0, Modulus => 0); + +end Ada.Containers.Bounded_Hashed_Sets; diff --git a/gcc/ada/a-cborma.adb b/gcc/ada/a-cborma.adb new file mode 100644 index 000000000..64c248f7b --- /dev/null +++ b/gcc/ada/a-cborma.adb @@ -0,0 +1,1348 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +------------------------------------------------------------------------------ + +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 + + ----------------------------- + -- 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 Left.Node = 0 then + raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; + end if; + + if 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 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 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 Left.Node = 0 then + raise Constraint_Error with "Left cursor of "">"" equals No_Element"; + end if; + + if 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 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 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 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; + + -------------- + -- 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; + + else + 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 Position.Node = 0 then + raise Constraint_Error with + "Position cursor of Delete equals No_Element"; + end if; + + if 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 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 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 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; + + ---------- + -- Find -- + ---------- + + function Find (Container : Map; Key : Key_Type) return Cursor is + Node : constant Count_Type := Key_Ops.Find (Container, Key); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Map) 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 : Map) return Element_Type is + begin + if 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 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; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Floor; + + ----------------- + -- 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 + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (map is locked)"; + end if; + + 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 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 + 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; + + -------------- + -- 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 + -- k > node same as node < k + + return Right.Key < Left; + end Is_Greater_Key_Node; + + ---------------------- + -- Is_Less_Key_Node -- + ---------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean + is + begin + return Left < Right.Key; + end Is_Less_Key_Node; + + ------------- + -- 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; + + B : Natural renames Container'Unrestricted_Access.all.Busy; + + -- Start of processing for Iterate + + begin + B := B + 1; + + begin + Local_Iterate (Container); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Iterate; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + if 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; + end if; + + return Cursor'(Container'Unrestricted_Access, Container.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Map) return Element_Type is + begin + if 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 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; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Assign (Target => Target, Source => Source); + 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; + + ------------ + -- 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; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : Element_Type)) + is + begin + if 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); + + B : Natural renames M.Busy; + L : Natural renames M.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (N.Key, N.Element); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + 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; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Count_Type := Key_Ops.Find (Container, Key); + + begin + if Node = 0 then + raise Constraint_Error with "key not in map"; + end if; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (map is locked)"; + end if; + + declare + N : Node_Type renames Container.Nodes (Node); + + begin + N.Key := Key; + N.Element := New_Item; + end; + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Position.Node = 0 then + raise Constraint_Error with + "Position cursor of Replace_Element equals No_Element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor of Replace_Element designates wrong map"; + end if; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (map is locked)"; + end if; + + pragma Assert (Vet (Container, Position.Node), + "Position cursor of Replace_Element is bad"); + + Container.Nodes (Position.Node).Element := New_Item; + end Replace_Element; + + --------------------- + -- 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; + + B : Natural renames Container'Unrestricted_Access.all.Busy; + + -- Start of processing for Reverse_Iterate + + begin + B := B + 1; + + begin + Local_Reverse_Iterate (Container); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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 Position.Node = 0 then + raise Constraint_Error with + "Position cursor of Update_Element equals No_Element"; + end if; + + if 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); + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (N.Key, N.Element); + + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + 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; + +end Ada.Containers.Bounded_Ordered_Maps; diff --git a/gcc/ada/a-cborma.ads b/gcc/ada/a-cborma.ads new file mode 100644 index 000000000..74dac9851 --- /dev/null +++ b/gcc/ada/a-cborma.ads @@ -0,0 +1,244 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +private with Ada.Containers.Red_Black_Trees; +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.Bounded_Ordered_Maps is + pragma Pure; + pragma Remote_Types; + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + + type Map (Capacity : Count_Type) is tagged private; + pragma Preelaborable_Initialization (Map); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Map : constant Map; + + No_Element : constant Cursor; + + 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)); + + 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 Has_Element (Position : Cursor) 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)); + +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; + Key : Key_Type; + Element : 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; + + type Map_Access is access all Map; + for Map_Access'Storage_Size use 0; + + use Red_Black_Trees; + use Tree_Types; + use Ada.Streams; + + type Cursor is record + Container : Map_Access; + Node : Count_Type; + 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, 0); + + 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; + + Empty_Map : constant Map := Map'(Tree_Type with Capacity => 0); + +end Ada.Containers.Bounded_Ordered_Maps; diff --git a/gcc/ada/a-cborse.adb b/gcc/ada/a-cborse.adb new file mode 100644 index 000000000..12d253c64 --- /dev/null +++ b/gcc/ada/a-cborse.adb @@ -0,0 +1,1718 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +------------------------------------------------------------------------------ + +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 + + ------------------------------ + -- 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 Left.Node = 0 then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + if 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 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 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 Left.Node = 0 then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + if 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 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 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 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 + if Node = 0 then + return No_Element; + end if; + + return 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; + + -------------- + -- 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; + + else + 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 Position.Node = 0 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, 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 + if X = 0 then + raise Constraint_Error with "attempt to delete element not in set"; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Container, X); + 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 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 + if Left < Right + or else Right < Left + then + return False; + else + return True; + end if; + end Equivalent_Elements; + + --------------------- + -- Equivalent_Sets -- + --------------------- + + function Equivalent_Sets (Left, Right : Set) return Boolean is + function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean; + pragma Inline (Is_Equivalent_Node_Node); + + function Is_Equivalent is + new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); + + ----------------------------- + -- Is_Equivalent_Node_Node -- + ----------------------------- + + function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean is + begin + if L.Element < R.Element then + return False; + elsif R.Element < L.Element then + return False; + else + return True; + end if; + end Is_Equivalent_Node_Node; + + -- Start of processing for Equivalent_Sets + + begin + return Is_Equivalent (Left, Right); + end Equivalent_Sets; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Item : Element_Type) is + X : constant Count_Type := Element_Keys.Find (Container, Item); + + begin + if X /= 0 then + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Tree_Operations.Free (Container, X); + end if; + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Item : Element_Type) return Cursor is + Node : constant Count_Type := Element_Keys.Find (Container, Item); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Set) 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 : Set) return Element_Type is + begin + if 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 + if Node = 0 then + return No_Element; + end if; + + return 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 + if Node = 0 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 + X : constant Count_Type := Key_Keys.Find (Container, Key); + + begin + if X = 0 then + raise Constraint_Error with "attempt to delete key not in set"; + end if; + + 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 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 + if Left < Right + or else Right < Left + then + return False; + else + return True; + end if; + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Key : Key_Type) is + X : constant Count_Type := Key_Keys.Find (Container, Key); + + begin + if X /= 0 then + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Tree_Operations.Free (Container, X); + end if; + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Key : Key_Type) return Cursor is + Node : constant Count_Type := Key_Keys.Find (Container, Key); + + begin + if Node = 0 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 Count_Type := Key_Keys.Floor (Container, Key); + + begin + if Node = 0 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_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 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; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Count_Type := Key_Keys.Find (Container, Key); + + begin + if Node = 0 then + raise Constraint_Error with + "attempt to replace key not in set"; + end if; + + Replace_Element (Container, Node, New_Item); + end Replace; + + ----------------------------------- + -- 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 Position.Node = 0 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, Position.Node), + "bad cursor in Update_Element_Preserving_Key"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + E : Element_Type renames N.Element; + K : constant Key_Type := Key (E); + + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + + 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; + + end Generic_Keys; + + ----------------- + -- 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 + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + 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 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 + 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; + B : Natural renames S.Busy; + + -- Start of processing for Iterate + + begin + B := B + 1; + + begin + Local_Iterate (S); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : Set) 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 : Set) return Element_Type is + begin + if 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; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Assign (Target => Target, Source => Source); + 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; + + ------------- + -- 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 + if Node = 0 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; + + ------------------- + -- 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 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; + + B : Natural renames S.Busy; + L : Natural renames S.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (S.Nodes (Position.Node).Element); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + 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; + + ------------- + -- Replace -- + ------------- + + procedure Replace (Container : in out Set; New_Item : Element_Type) is + Node : constant Count_Type := Element_Keys.Find (Container, New_Item); + + begin + if Node = 0 then + raise Constraint_Error with + "attempt to replace element not in set"; + end if; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + 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; + + -- Start of processing for Replace_Element + + begin + if Item < Node.Element + or else Node.Element < Item + then + null; + + else + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + Node.Element := Item; + return; + end if; + + Hint := Element_Keys.Ceiling (Container, Item); + + if Hint = 0 then + null; + + elsif Item < Nodes (Hint).Element then + if Hint = Index then + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + Node.Element := Item; + return; + end if; + + else + pragma Assert (not (Nodes (Hint).Element < Item)); + raise Program_Error with "attempt to replace existing element"; + end if; + + 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 Position.Node = 0 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, 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; + B : Natural renames S.Busy; + + -- Start of processing for Reverse_Iterate + + begin + B := B + 1; + + begin + Local_Reverse_Iterate (S); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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; + +end Ada.Containers.Bounded_Ordered_Sets; diff --git a/gcc/ada/a-cborse.ads b/gcc/ada/a-cborse.ads new file mode 100644 index 000000000..f9719dcdb --- /dev/null +++ b/gcc/ada/a-cborse.ads @@ -0,0 +1,294 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +private with Ada.Containers.Red_Black_Trees; +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.Bounded_Ordered_Sets is + pragma Pure; + pragma Remote_Types; + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean; + + type Set (Capacity : Count_Type) is tagged private; + pragma Preelaborable_Initialization (Set); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Set : constant Set; + + No_Element : constant Cursor; + + 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)); + + 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 Has_Element (Position : Cursor) 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)); + + 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)); + + 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 : 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; + + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + type Cursor is record + Container : Set_Access; + Node : Count_Type; + end record; + + use Tree_Types; + use Ada.Streams; + + 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, 0); + + 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; + + Empty_Set : constant Set := Set'(Tree_Type with Capacity => 0); + +end Ada.Containers.Bounded_Ordered_Sets; diff --git a/gcc/ada/a-cdlili.adb b/gcc/ada/a-cdlili.adb new file mode 100644 index 000000000..cbac8fd4a --- /dev/null +++ b/gcc/ada/a-cdlili.adb @@ -0,0 +1,1835 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +------------------------------------------------------------------------------ + +with System; use type System.Address; + +with Ada.Unchecked_Deallocation; + +package body Ada.Containers.Doubly_Linked_Lists is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Free (X : in out Node_Access); + + procedure Insert_Internal + (Container : in out List; + Before : Node_Access; + New_Node : Node_Access); + + function Vet (Position : Cursor) return Boolean; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : List) return Boolean is + L : Node_Access := Left.First; + R : Node_Access := 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 L.Element /= R.Element then + return False; + end if; + + L := L.Next; + R := R.Next; + end loop; + + return True; + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out List) is + Src : Node_Access := Container.First; + + begin + if Src = null then + pragma Assert (Container.Last = null); + pragma Assert (Container.Length = 0); + pragma Assert (Container.Busy = 0); + pragma Assert (Container.Lock = 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; + Container.Busy := 0; + Container.Lock := 0; + + 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; + + ----------- + -- 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.Busy = 0); + pragma Assert (Container.Lock = 0); + return; + end if; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + end if; + + 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; + + -------------- + -- 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 + X : Node_Access; + + begin + if Position.Node = 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), "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; + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + end if; + + 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; + + 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; + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + end if; + + for I 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; + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + end if; + + for I 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 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; + + ---------- + -- 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 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; + + while Node /= null loop + if Node.Element = Item then + return Cursor'(Container'Unchecked_Access, Node); + end if; + + Node := Node.Next; + end loop; + + return No_Element; + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : List) return Cursor is + begin + if Container.First = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Container.First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : List) return Element_Type is + begin + if 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 + 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 + Node : Node_Access := Container.First; + + begin + for I 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 + LI, RI : Cursor; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Target (list is busy)"; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Source (list is busy)"; + end if; + + LI := First (Target); + RI := First (Source); + while RI.Node /= null loop + pragma Assert (RI.Node.Next = null + or else not (RI.Node.Next.Element < + RI.Node.Element)); + + if LI.Node = null then + Splice (Target, No_Element, Source); + return; + end if; + + pragma Assert (LI.Node.Next = null + or else not (LI.Node.Next.Element < + LI.Node.Element)); + + if RI.Node.Element < LI.Node.Element then + declare + RJ : Cursor := RI; + pragma Warnings (Off, RJ); + begin + RI.Node := RI.Node.Next; + Splice (Target, LI, Source, RJ); + end; + + else + LI.Node := LI.Node.Next; + end if; + end loop; + 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 := Pivot.Next; + + begin + 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); + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + end if; + + Sort (Front => null, Back => null); + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + 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 /= 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 + New_Node : Node_Access; + + begin + if Before.Container /= null then + if 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 Container.Length > Count_Type'Last - Count then + raise Constraint_Error with "new length exceeds maximum"; + end if; + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + end if; + + New_Node := new Node_Type'(New_Item, null, null); + Insert_Internal (Container, Before.Node, New_Node); + + Position := Cursor'(Container'Unchecked_Access, New_Node); + + for J in Count_Type'(2) .. Count loop + New_Node := new Node_Type'(New_Item, null, null); + Insert_Internal (Container, Before.Node, New_Node); + end loop; + 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_Node : Node_Access; + + begin + if Before.Container /= null then + if 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 Container.Length > Count_Type'Last - Count then + raise Constraint_Error with "new length exceeds maximum"; + end if; + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + end if; + + New_Node := new Node_Type; + Insert_Internal (Container, Before.Node, New_Node); + + Position := Cursor'(Container'Unchecked_Access, New_Node); + + for J in Count_Type'(2) .. Count loop + New_Node := new Node_Type; + Insert_Internal (Container, Before.Node, New_Node); + end loop; + 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 + C : List renames Container'Unrestricted_Access.all; + B : Natural renames C.Busy; + + Node : Node_Access := Container.First; + + begin + B := B + 1; + + begin + while Node /= null loop + Process (Cursor'(Container'Unchecked_Access, Node)); + Node := Node.Next; + end loop; + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : List) return Cursor is + begin + if Container.Last = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Container.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : List) return Element_Type is + begin + if 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; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Source (list is busy)"; + end if; + + 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; + end if; + + 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; + end if; + + return Cursor'(Position.Container, Next_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 = null then + return No_Element; + end if; + + 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; + end if; + + return Cursor'(Position.Container, Prev_Node); + end; + 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 has no element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Query_Element"); + + declare + C : List renames Position.Container.all'Unrestricted_Access.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (Position.Node.Element); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + 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; + + --------------------- + -- 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 with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unchecked_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (list is locked)"; + end if; + + 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); + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + end if; + + 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 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; + + while Node /= null loop + if Node.Element = Item then + return Cursor'(Container'Unchecked_Access, Node); + end if; + + Node := 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; + B : Natural renames C.Busy; + + Node : Node_Access := Container.Last; + + begin + B := B + 1; + + begin + while Node /= null loop + Process (Cursor'(Container'Unchecked_Access, Node)); + Node := Node.Prev; + end loop; + + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Reverse_Iterate; + + ------------ + -- Splice -- + ------------ + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List) + is + begin + if Before.Container /= null then + if 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; + + pragma Assert (Source.First.Prev = null); + pragma Assert (Source.Last.Next = null); + + if Target.Length > Count_Type'Last - Source.Length then + raise Constraint_Error with "new length exceeds maximum"; + end if; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Target (list is busy)"; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Source (list is busy)"; + end if; + + if Target.Length = 0 then + pragma Assert (Target.First = null); + pragma Assert (Target.Last = null); + pragma Assert (Before = No_Element); + + Target.First := Source.First; + Target.Last := Source.Last; + + elsif Before.Node = null then + pragma Assert (Target.Last.Next = null); + + Target.Last.Next := Source.First; + Source.First.Prev := Target.Last; + + Target.Last := Source.Last; + + elsif Before.Node = 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.Node.Prev.Next := Source.First; + Source.First.Prev := Before.Node.Prev; + + Before.Node.Prev := Source.Last; + Source.Last.Next := Before.Node; + end if; + + Source.First := null; + Source.Last := null; + + Target.Length := Target.Length + Source.Length; + Source.Length := 0; + end Splice; + + procedure Splice + (Container : in out List; + Before : Cursor; + Position : Cursor) + is + begin + if Before.Container /= null then + if 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 Position.Node = 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), "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); + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + end if; + + 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 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 Position.Node = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if 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 Target.Length = Count_Type'Last then + raise Constraint_Error with "Target is full"; + end if; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Target (list is busy)"; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Source (list is busy)"; + end if; + + if Position.Node = Source.First then + Source.First := Position.Node.Next; + + if Position.Node = 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.Node = Source.Last then + pragma Assert (Source.Length >= 2); + Source.Last := Position.Node.Prev; + Source.Last.Next := null; + + else + pragma Assert (Source.Length >= 3); + Position.Node.Prev.Next := Position.Node.Next; + Position.Node.Next.Prev := Position.Node.Prev; + end if; + + if Target.Length = 0 then + pragma Assert (Target.First = null); + pragma Assert (Target.Last = null); + pragma Assert (Before = No_Element); + + Target.First := Position.Node; + Target.Last := Position.Node; + + Target.First.Prev := null; + Target.Last.Next := null; + + elsif Before.Node = null then + pragma Assert (Target.Last.Next = null); + Target.Last.Next := Position.Node; + Position.Node.Prev := Target.Last; + + Target.Last := Position.Node; + Target.Last.Next := null; + + elsif Before.Node = Target.First then + pragma Assert (Target.First.Prev = null); + Target.First.Prev := Position.Node; + Position.Node.Next := Target.First; + + Target.First := Position.Node; + Target.First.Prev := null; + + else + pragma Assert (Target.Length >= 2); + Before.Node.Prev.Next := Position.Node; + Position.Node.Prev := Before.Node.Prev; + + Before.Node.Prev := Position.Node; + Position.Node.Next := Before.Node; + end if; + + Target.Length := Target.Length + 1; + Source.Length := Source.Length - 1; + + Position.Container := Target'Unchecked_Access; + end Splice; + + ---------- + -- Swap -- + ---------- + + procedure Swap + (Container : in out List; + I, J : Cursor) + is + begin + if I.Node = null then + raise Constraint_Error with "I cursor has no element"; + end if; + + if J.Node = null then + raise Constraint_Error with "J cursor has no element"; + end if; + + if I.Container /= Container'Unchecked_Access then + raise Program_Error with "I cursor designates wrong container"; + end if; + + if 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; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (list is locked)"; + end if; + + 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 I.Node = null then + raise Constraint_Error with "I cursor has no element"; + end if; + + if J.Node = 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 designates wrong container"; + end if; + + if 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; + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + 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); + + 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 Position.Node = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if 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 + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (Position.Node.Element); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; + end Update_Element; + + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = null then + return Position.Container = null; + end if; + + if Position.Container = null then + return False; + end if; + + if Position.Node.Next = Position.Node then + return False; + end if; + + if Position.Node.Prev = Position.Node then + return False; + end if; + + 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 we get here, we know that this disjunction is true: + -- 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; + + -- If we get here, we know that this disjunction is true: + -- 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; + 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 -- eliminates earlier disjunct + return True; + end if; + + -- If we get here, we know, per disjunctive syllogism (modus + -- tollendo ponens), that this predicate is true: + -- Position.Node.Prev /= null + + if Position.Node = L.Last then -- eliminates earlier disjunct + return True; + end if; + + -- If we get here, we know, per disjunctive syllogism (modus + -- tollendo ponens), that this predicate is true: + -- 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; + 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'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; + +end Ada.Containers.Doubly_Linked_Lists; diff --git a/gcc/ada/a-cdlili.ads b/gcc/ada/a-cdlili.ads new file mode 100644 index 000000000..3cefaceec --- /dev/null +++ b/gcc/ada/a-cdlili.ads @@ -0,0 +1,276 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +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 Preelaborate; + pragma Remote_Types; + + type List is tagged private; + pragma Preelaborable_Initialization (List); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_List : constant List; + + No_Element : constant Cursor; + + 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)); + + 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); + + 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; + + function Has_Element (Position : Cursor) 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); + + type Node_Type; + type Node_Access is access Node_Type; + + type Node_Type is + limited record + Element : Element_Type; + Next : Node_Access; + Prev : Node_Access; + end record; + + use Ada.Finalization; + + type List is + new Controlled with record + First : Node_Access; + Last : Node_Access; + Length : Count_Type := 0; + Busy : Natural := 0; + Lock : Natural := 0; + end record; + + overriding + procedure Adjust (Container : in out List); + + overriding + procedure Finalize (Container : in out List) renames Clear; + + use Ada.Streams; + + 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 constant 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; + + Empty_List : constant List := (Controlled with null, null, 0, 0, 0); + + No_Element : constant Cursor := Cursor'(null, null); + +end Ada.Containers.Doubly_Linked_Lists; diff --git a/gcc/ada/a-cgaaso.adb b/gcc/ada/a-cgaaso.adb new file mode 100644 index 000000000..abb8631d5 --- /dev/null +++ b/gcc/ada/a-cgaaso.adb @@ -0,0 +1,129 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.GENERIC_ANONYMOUS_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 (see g-heasor.ad[sb]) + +with System; + +procedure Ada.Containers.Generic_Anonymous_Array_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 Less (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_Anonymous_Array_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_Anonymous_Array_Sort; diff --git a/gcc/ada/a-cgaaso.ads b/gcc/ada/a-cgaaso.ads new file mode 100644 index 000000000..f44c2207a --- /dev/null +++ b/gcc/ada/a-cgaaso.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 new file mode 100644 index 000000000..094774737 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Generic_Constrained_Array_Sort; + +procedure Ada.Containers.Generic_Array_Sort + (Container : in out Array_Type) +is + subtype Index_Subtype is + Index_Type range Container'First .. Container'Last; + + subtype Array_Subtype is + Array_Type (Index_Subtype); + + procedure Sort is + new Generic_Constrained_Array_Sort + (Index_Type => Index_Subtype, + Element_Type => Element_Type, + Array_Type => Array_Subtype, + "<" => "<"); + +begin + Sort (Container); +end Ada.Containers.Generic_Array_Sort; diff --git a/gcc/ada/a-cgarso.ads b/gcc/ada/a-cgarso.ads new file mode 100644 index 000000000..77281b5ef --- /dev/null +++ b/gcc/ada/a-cgarso.ads @@ -0,0 +1,26 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . G E N E R I C _ A R R A Y _ S O R T -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Index_Type is (<>); + type Element_Type is private; + type Array_Type is array (Index_Type range <>) of Element_Type; + + with function "<" (Left, Right : Element_Type) + return Boolean is <>; + +procedure Ada.Containers.Generic_Array_Sort (Container : in out Array_Type); + +pragma Pure (Ada.Containers.Generic_Array_Sort); diff --git a/gcc/ada/a-cgcaso.adb b/gcc/ada/a-cgcaso.adb new file mode 100644 index 000000000..646137719 --- /dev/null +++ b/gcc/ada/a-cgcaso.adb @@ -0,0 +1,121 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.GENERIC_CONSTRAINED_ARRAY_SORT -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- This algorithm was adapted from GNAT.Heap_Sort_G (see g-hesorg.ad[sb]) + +with System; + +procedure Ada.Containers.Generic_Constrained_Array_Sort + (Container : in out Array_Type) +is + type T is range System.Min_Int .. System.Max_Int; + + function To_Index (J : T) return Index_Type; + pragma Inline (To_Index); + + procedure Sift (S : T); + + A : Array_Type renames Container; + + -------------- + -- To_Index -- + -------------- + + function To_Index (J : T) return Index_Type is + K : constant T'Base := Index_Type'Pos (A'First) + J - T'(1); + begin + return Index_Type'Val (K); + end To_Index; + + Max : T := A'Length; + Temp : Element_Type; + + ---------- + -- Sift -- + ---------- + + procedure Sift (S : T) is + C : T := S; + Son : T; + + begin + loop + Son := 2 * C; + + exit when Son > Max; + + declare + Son_Index : Index_Type := To_Index (Son); + + begin + if Son < Max then + if A (Son_Index) < A (Index_Type'Succ (Son_Index)) then + Son := Son + 1; + Son_Index := Index_Type'Succ (Son_Index); + end if; + end if; + + A (To_Index (C)) := A (Son_Index); -- Move (Son, C); + end; + + C := Son; + end loop; + + while C /= S loop + declare + Father : constant T := C / 2; + begin + if A (To_Index (Father)) < Temp then -- Lt (Father, 0) + A (To_Index (C)) := A (To_Index (Father)); -- Move (Father, C) + C := Father; + else + exit; + end if; + end; + end loop; + + A (To_Index (C)) := Temp; -- Move (0, C); + end Sift; + +-- Start of processing for Generic_Constrained_Array_Sort + +begin + for J in reverse 1 .. Max / 2 loop + Temp := Container (To_Index (J)); -- Move (J, 0); + Sift (J); + end loop; + + while Max > 1 loop + Temp := A (To_Index (Max)); -- Move (Max, 0); + A (To_Index (Max)) := A (A'First); -- Move (1, Max); + + Max := Max - 1; + Sift (1); + end loop; +end Ada.Containers.Generic_Constrained_Array_Sort; diff --git a/gcc/ada/a-cgcaso.ads b/gcc/ada/a-cgcaso.ads new file mode 100644 index 000000000..39ebee61b --- /dev/null +++ b/gcc/ada/a-cgcaso.ads @@ -0,0 +1,27 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.GENERIC_CONSTRAINED_ARRAY_SORT -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Index_Type is (<>); + type Element_Type is private; + type Array_Type is array (Index_Type) of Element_Type; + + with function "<" (Left, Right : Element_Type) + return Boolean is <>; + +procedure Ada.Containers.Generic_Constrained_Array_Sort + (Container : in out Array_Type); + +pragma Pure (Ada.Containers.Generic_Constrained_Array_Sort); diff --git a/gcc/ada/a-chacon.adb b/gcc/ada/a-chacon.adb new file mode 100755 index 000000000..18b0264dc --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100755 index 000000000..30e6c5db4 --- /dev/null +++ b/gcc/ada/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-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.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 new file mode 100644 index 000000000..61419b090 --- /dev/null +++ b/gcc/ada/a-chahan.adb @@ -0,0 +1,568 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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; + + 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, + VT => Control, + FF => Control, + CR => Control, + 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, + 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_Lower -- + -------------- + + function Is_Lower (Item : Character) return Boolean is + begin + return (Char_Map (Item) and Lower) /= 0; + end Is_Lower; + + ---------------- + -- 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 + Result : String (1 .. Item'Length); + + begin + for J in Item'Range loop + Result (J - (Item'First - 1)) := Value (Basic_Map, Item (J)); + end loop; + + return Result; + 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 + Result : String (1 .. Item'Length); + + begin + for J in Item'Range loop + Result (J - (Item'First - 1)) := Value (Lower_Case_Map, Item (J)); + end loop; + + return Result; + 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 + Result : String (1 .. Item'Length); + + begin + for J in Item'Range loop + Result (J - (Item'First - 1)) := Value (Upper_Case_Map, Item (J)); + end loop; + + return Result; + 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 new file mode 100644 index 000000000..98f69ba29 --- /dev/null +++ b/gcc/ada/a-chahan.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Characters.Handling is + pragma Preelaborate; + pragma Pure_05; + -- 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; + + --------------------------------------------------- + -- 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_Control); + pragma Inline (Is_Graphic); + pragma Inline (Is_Letter); + pragma Inline (Is_Lower); + pragma Inline (Is_Upper); + pragma Inline (Is_Basic); + pragma Inline (Is_Digit); + pragma Inline (Is_Hexadecimal_Digit); + pragma Inline (Is_Alphanumeric); + pragma Inline (Is_Special); + pragma Inline (To_Lower); + pragma Inline (To_Upper); + pragma Inline (To_Basic); + pragma Inline (Is_ISO_646); + pragma Inline (Is_Character); + pragma Inline (To_Character); + pragma Inline (To_Wide_Character); + +end Ada.Characters.Handling; diff --git a/gcc/ada/a-charac.ads b/gcc/ada/a-charac.ads new file mode 100644 index 000000000..8355f5418 --- /dev/null +++ b/gcc/ada/a-charac.ads @@ -0,0 +1,18 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C H A R A C T E R S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Characters is + pragma Pure; +end Ada.Characters; diff --git a/gcc/ada/a-chlat1.ads b/gcc/ada/a-chlat1.ads new file mode 100644 index 000000000..056c881a9 --- /dev/null +++ b/gcc/ada/a-chlat1.ads @@ -0,0 +1,298 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C H A R A C T E R S . L A T I N _ 1 -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +pragma Warnings (Off); +pragma Compiler_Unit; +pragma Warnings (On); + +package Ada.Characters.Latin_1 is + pragma Pure; + + ------------------------ + -- Control Characters -- + ------------------------ + + NUL : constant Character := Character'Val (0); + SOH : constant Character := Character'Val (1); + STX : constant Character := Character'Val (2); + ETX : constant Character := Character'Val (3); + EOT : constant Character := Character'Val (4); + ENQ : constant Character := Character'Val (5); + ACK : constant Character := Character'Val (6); + BEL : constant Character := Character'Val (7); + BS : constant Character := Character'Val (8); + HT : constant Character := Character'Val (9); + LF : constant Character := Character'Val (10); + VT : constant Character := Character'Val (11); + FF : constant Character := Character'Val (12); + CR : constant Character := Character'Val (13); + SO : constant Character := Character'Val (14); + SI : constant Character := Character'Val (15); + + DLE : constant Character := Character'Val (16); + DC1 : constant Character := Character'Val (17); + DC2 : constant Character := Character'Val (18); + DC3 : constant Character := Character'Val (19); + DC4 : constant Character := Character'Val (20); + NAK : constant Character := Character'Val (21); + SYN : constant Character := Character'Val (22); + ETB : constant Character := Character'Val (23); + CAN : constant Character := Character'Val (24); + EM : constant Character := Character'Val (25); + SUB : constant Character := Character'Val (26); + ESC : constant Character := Character'Val (27); + FS : constant Character := Character'Val (28); + GS : constant Character := Character'Val (29); + RS : constant Character := Character'Val (30); + US : constant Character := Character'Val (31); + + -------------------------------- + -- ISO 646 Graphic Characters -- + -------------------------------- + + Space : constant Character := ' '; -- Character'Val(32) + Exclamation : constant Character := '!'; -- Character'Val(33) + Quotation : constant Character := '"'; -- Character'Val(34) + Number_Sign : constant Character := '#'; -- Character'Val(35) + Dollar_Sign : constant Character := '$'; -- Character'Val(36) + Percent_Sign : constant Character := '%'; -- Character'Val(37) + Ampersand : constant Character := '&'; -- Character'Val(38) + Apostrophe : constant Character := '''; -- Character'Val(39) + Left_Parenthesis : constant Character := '('; -- Character'Val(40) + Right_Parenthesis : constant Character := ')'; -- Character'Val(41) + Asterisk : constant Character := '*'; -- Character'Val(42) + Plus_Sign : constant Character := '+'; -- Character'Val(43) + Comma : constant Character := ','; -- Character'Val(44) + Hyphen : constant Character := '-'; -- Character'Val(45) + Minus_Sign : Character renames Hyphen; + Full_Stop : constant Character := '.'; -- Character'Val(46) + Solidus : constant Character := '/'; -- Character'Val(47) + + -- Decimal digits '0' though '9' are at positions 48 through 57 + + Colon : constant Character := ':'; -- Character'Val(58) + Semicolon : constant Character := ';'; -- Character'Val(59) + Less_Than_Sign : constant Character := '<'; -- Character'Val(60) + Equals_Sign : constant Character := '='; -- Character'Val(61) + Greater_Than_Sign : constant Character := '>'; -- Character'Val(62) + Question : constant Character := '?'; -- Character'Val(63) + Commercial_At : constant Character := '@'; -- Character'Val(64) + + -- Letters 'A' through 'Z' are at positions 65 through 90 + + Left_Square_Bracket : constant Character := '['; -- Character'Val (91) + Reverse_Solidus : constant Character := '\'; -- Character'Val (92) + Right_Square_Bracket : constant Character := ']'; -- Character'Val (93) + Circumflex : constant Character := '^'; -- Character'Val (94) + Low_Line : constant Character := '_'; -- Character'Val (95) + + Grave : constant Character := '`'; -- Character'Val (96) + LC_A : constant Character := 'a'; -- Character'Val (97) + LC_B : constant Character := 'b'; -- Character'Val (98) + LC_C : constant Character := 'c'; -- Character'Val (99) + LC_D : constant Character := 'd'; -- Character'Val (100) + LC_E : constant Character := 'e'; -- Character'Val (101) + LC_F : constant Character := 'f'; -- Character'Val (102) + LC_G : constant Character := 'g'; -- Character'Val (103) + LC_H : constant Character := 'h'; -- Character'Val (104) + LC_I : constant Character := 'i'; -- Character'Val (105) + LC_J : constant Character := 'j'; -- Character'Val (106) + LC_K : constant Character := 'k'; -- Character'Val (107) + LC_L : constant Character := 'l'; -- Character'Val (108) + LC_M : constant Character := 'm'; -- Character'Val (109) + LC_N : constant Character := 'n'; -- Character'Val (110) + LC_O : constant Character := 'o'; -- Character'Val (111) + LC_P : constant Character := 'p'; -- Character'Val (112) + LC_Q : constant Character := 'q'; -- Character'Val (113) + LC_R : constant Character := 'r'; -- Character'Val (114) + LC_S : constant Character := 's'; -- Character'Val (115) + LC_T : constant Character := 't'; -- Character'Val (116) + LC_U : constant Character := 'u'; -- Character'Val (117) + LC_V : constant Character := 'v'; -- Character'Val (118) + LC_W : constant Character := 'w'; -- Character'Val (119) + LC_X : constant Character := 'x'; -- Character'Val (120) + LC_Y : constant Character := 'y'; -- Character'Val (121) + LC_Z : constant Character := 'z'; -- Character'Val (122) + Left_Curly_Bracket : constant Character := '{'; -- Character'Val (123) + Vertical_Line : constant Character := '|'; -- Character'Val (124) + Right_Curly_Bracket : constant Character := '}'; -- Character'Val (125) + Tilde : constant Character := '~'; -- Character'Val (126) + DEL : constant Character := Character'Val (127); + + --------------------------------- + -- ISO 6429 Control Characters -- + --------------------------------- + + IS4 : Character renames FS; + IS3 : Character renames GS; + IS2 : Character renames RS; + IS1 : Character renames US; + + Reserved_128 : constant Character := Character'Val (128); + Reserved_129 : constant Character := Character'Val (129); + BPH : constant Character := Character'Val (130); + NBH : constant Character := Character'Val (131); + Reserved_132 : constant Character := Character'Val (132); + NEL : constant Character := Character'Val (133); + SSA : constant Character := Character'Val (134); + ESA : constant Character := Character'Val (135); + HTS : constant Character := Character'Val (136); + HTJ : constant Character := Character'Val (137); + VTS : constant Character := Character'Val (138); + PLD : constant Character := Character'Val (139); + PLU : constant Character := Character'Val (140); + RI : constant Character := Character'Val (141); + SS2 : constant Character := Character'Val (142); + SS3 : constant Character := Character'Val (143); + + DCS : constant Character := Character'Val (144); + PU1 : constant Character := Character'Val (145); + PU2 : constant Character := Character'Val (146); + STS : constant Character := Character'Val (147); + CCH : constant Character := Character'Val (148); + MW : constant Character := Character'Val (149); + SPA : constant Character := Character'Val (150); + EPA : constant Character := Character'Val (151); + + SOS : constant Character := Character'Val (152); + Reserved_153 : constant Character := Character'Val (153); + SCI : constant Character := Character'Val (154); + CSI : constant Character := Character'Val (155); + ST : constant Character := Character'Val (156); + OSC : constant Character := Character'Val (157); + PM : constant Character := Character'Val (158); + APC : constant Character := Character'Val (159); + + ------------------------------ + -- Other Graphic Characters -- + ------------------------------ + + -- Character positions 160 (16#A0#) .. 175 (16#AF#) + + No_Break_Space : constant Character := Character'Val (160); + NBSP : Character renames No_Break_Space; + Inverted_Exclamation : constant Character := Character'Val (161); + Cent_Sign : constant Character := Character'Val (162); + Pound_Sign : constant Character := Character'Val (163); + Currency_Sign : constant Character := Character'Val (164); + Yen_Sign : constant Character := Character'Val (165); + Broken_Bar : constant Character := Character'Val (166); + Section_Sign : constant Character := Character'Val (167); + Diaeresis : constant Character := Character'Val (168); + Copyright_Sign : constant Character := Character'Val (169); + Feminine_Ordinal_Indicator : constant Character := Character'Val (170); + Left_Angle_Quotation : constant Character := Character'Val (171); + Not_Sign : constant Character := Character'Val (172); + Soft_Hyphen : constant Character := Character'Val (173); + Registered_Trade_Mark_Sign : constant Character := Character'Val (174); + Macron : constant Character := Character'Val (175); + + -- Character positions 176 (16#B0#) .. 191 (16#BF#) + + Degree_Sign : constant Character := Character'Val (176); + Ring_Above : Character renames Degree_Sign; + Plus_Minus_Sign : constant Character := Character'Val (177); + Superscript_Two : constant Character := Character'Val (178); + Superscript_Three : constant Character := Character'Val (179); + Acute : constant Character := Character'Val (180); + Micro_Sign : constant Character := Character'Val (181); + Pilcrow_Sign : constant Character := Character'Val (182); + Paragraph_Sign : Character renames Pilcrow_Sign; + Middle_Dot : constant Character := Character'Val (183); + Cedilla : constant Character := Character'Val (184); + Superscript_One : constant Character := Character'Val (185); + Masculine_Ordinal_Indicator : constant Character := Character'Val (186); + Right_Angle_Quotation : constant Character := Character'Val (187); + Fraction_One_Quarter : constant Character := Character'Val (188); + Fraction_One_Half : constant Character := Character'Val (189); + Fraction_Three_Quarters : constant Character := Character'Val (190); + Inverted_Question : constant Character := Character'Val (191); + + -- Character positions 192 (16#C0#) .. 207 (16#CF#) + + UC_A_Grave : constant Character := Character'Val (192); + UC_A_Acute : constant Character := Character'Val (193); + UC_A_Circumflex : constant Character := Character'Val (194); + UC_A_Tilde : constant Character := Character'Val (195); + UC_A_Diaeresis : constant Character := Character'Val (196); + UC_A_Ring : constant Character := Character'Val (197); + UC_AE_Diphthong : constant Character := Character'Val (198); + UC_C_Cedilla : constant Character := Character'Val (199); + UC_E_Grave : constant Character := Character'Val (200); + UC_E_Acute : constant Character := Character'Val (201); + UC_E_Circumflex : constant Character := Character'Val (202); + UC_E_Diaeresis : constant Character := Character'Val (203); + UC_I_Grave : constant Character := Character'Val (204); + UC_I_Acute : constant Character := Character'Val (205); + UC_I_Circumflex : constant Character := Character'Val (206); + UC_I_Diaeresis : constant Character := Character'Val (207); + + -- Character positions 208 (16#D0#) .. 223 (16#DF#) + + UC_Icelandic_Eth : constant Character := Character'Val (208); + UC_N_Tilde : constant Character := Character'Val (209); + UC_O_Grave : constant Character := Character'Val (210); + UC_O_Acute : constant Character := Character'Val (211); + UC_O_Circumflex : constant Character := Character'Val (212); + UC_O_Tilde : constant Character := Character'Val (213); + UC_O_Diaeresis : constant Character := Character'Val (214); + Multiplication_Sign : constant Character := Character'Val (215); + UC_O_Oblique_Stroke : constant Character := Character'Val (216); + UC_U_Grave : constant Character := Character'Val (217); + UC_U_Acute : constant Character := Character'Val (218); + UC_U_Circumflex : constant Character := Character'Val (219); + UC_U_Diaeresis : constant Character := Character'Val (220); + UC_Y_Acute : constant Character := Character'Val (221); + UC_Icelandic_Thorn : constant Character := Character'Val (222); + LC_German_Sharp_S : constant Character := Character'Val (223); + + -- Character positions 224 (16#E0#) .. 239 (16#EF#) + + LC_A_Grave : constant Character := Character'Val (224); + LC_A_Acute : constant Character := Character'Val (225); + LC_A_Circumflex : constant Character := Character'Val (226); + LC_A_Tilde : constant Character := Character'Val (227); + LC_A_Diaeresis : constant Character := Character'Val (228); + LC_A_Ring : constant Character := Character'Val (229); + LC_AE_Diphthong : constant Character := Character'Val (230); + LC_C_Cedilla : constant Character := Character'Val (231); + LC_E_Grave : constant Character := Character'Val (232); + LC_E_Acute : constant Character := Character'Val (233); + LC_E_Circumflex : constant Character := Character'Val (234); + LC_E_Diaeresis : constant Character := Character'Val (235); + LC_I_Grave : constant Character := Character'Val (236); + LC_I_Acute : constant Character := Character'Val (237); + LC_I_Circumflex : constant Character := Character'Val (238); + LC_I_Diaeresis : constant Character := Character'Val (239); + + -- Character positions 240 (16#F0#) .. 255 (16#FF) + LC_Icelandic_Eth : constant Character := Character'Val (240); + LC_N_Tilde : constant Character := Character'Val (241); + LC_O_Grave : constant Character := Character'Val (242); + LC_O_Acute : constant Character := Character'Val (243); + LC_O_Circumflex : constant Character := Character'Val (244); + LC_O_Tilde : constant Character := Character'Val (245); + LC_O_Diaeresis : constant Character := Character'Val (246); + Division_Sign : constant Character := Character'Val (247); + LC_O_Oblique_Stroke : constant Character := Character'Val (248); + LC_U_Grave : constant Character := Character'Val (249); + LC_U_Acute : constant Character := Character'Val (250); + LC_U_Circumflex : constant Character := Character'Val (251); + LC_U_Diaeresis : constant Character := Character'Val (252); + LC_Y_Acute : constant Character := Character'Val (253); + LC_Icelandic_Thorn : constant Character := Character'Val (254); + LC_Y_Diaeresis : constant Character := Character'Val (255); + +end Ada.Characters.Latin_1; diff --git a/gcc/ada/a-chlat9.ads b/gcc/ada/a-chlat9.ads new file mode 100644 index 000000000..82821ccb2 --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..211e921c6 --- /dev/null +++ b/gcc/ada/a-chtgbk.adb @@ -0,0 +1,322 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_KEYS -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is + + -------------------------- + -- 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; + + Indx := Index (HT, Key); + X := HT.Buckets (Indx); + + if X = 0 then + return; + end if; + + if Equivalent_Keys (Key, HT.Nodes (X)) then + if HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + 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 Equivalent_Keys (Key, HT.Nodes (X)) then + if HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + 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 := Index (HT, Key); + + Node := HT.Buckets (Indx); + while Node /= 0 loop + if Equivalent_Keys (Key, HT.Nodes (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 : constant Hash_Type := Index (HT, Key); + B : Count_Type renames HT.Buckets (Indx); + + begin + if B = 0 then + if HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + if 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; + + B := Node; + HT.Length := HT.Length + 1; + + return; + end if; + + Node := B; + loop + if Equivalent_Keys (Key, HT.Nodes (Node)) then + Inserted := False; + return; + end if; + + Node := Next (HT.Nodes (Node)); + + exit when Node = 0; + end loop; + + if HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + if 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 => B); + + Inserted := True; + + B := Node; + HT.Length := HT.Length + 1; + end Generic_Conditional_Insert; + + ----------- + -- 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; + + ----------------------------- + -- 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_Hash : constant Hash_Type := Hash (NN (Node)); + Old_Indx : constant Hash_Type := BB'First + Old_Hash mod BB'Length; + + New_Hash : constant Hash_Type := Hash (Key); + New_Indx : constant Hash_Type := BB'First + New_Hash mod BB'Length; + + New_Bucket : Count_Type renames BB (New_Indx); + N, M : Count_Type; + + begin + -- 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 Equivalent_Keys (Key, NN (Node)) then + pragma Assert (New_Hash = Old_Hash); + + if HT.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (container is locked)"; + end if; + + -- The new Key value is mapped to this same Node, so Node + -- stays in the same bucket. + + Assign (NN (Node), Key); + pragma Assert (Hash (NN (Node)) = New_Hash); + pragma Assert (Equivalent_Keys (Key, NN (Node))); + 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 Equivalent_Keys (Key, NN (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. + + if HT.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (container is locked)"; + end if; + + Assign (NN (Node), Key); + pragma Assert (Hash (NN (Node)) = New_Hash); + pragma Assert (Equivalent_Keys (Key, NN (Node))); + return; + end if; + + -- The node is a bucket different from the bucket implied by Key + + if HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + -- 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); + pragma Assert (Hash (NN (Node)) = New_Hash); + pragma Assert (Equivalent_Keys (Key, NN (Node))); + + -- 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; + +end Ada.Containers.Hash_Tables.Generic_Bounded_Keys; diff --git a/gcc/ada/a-chtgbk.ads b/gcc/ada/a-chtgbk.ads new file mode 100644 index 000000000..4257c251e --- /dev/null +++ b/gcc/ada/a-chtgbk.ads @@ -0,0 +1,106 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_KEYS -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +-- 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; + + 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 + + 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 new file mode 100644 index 000000000..700ca2ebd --- /dev/null +++ b/gcc/ada/a-chtgbo.adb @@ -0,0 +1,473 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +with System; use type System.Address; + +package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is + + ----------- + -- Clear -- + ----------- + + procedure Clear (HT : in out Hash_Table_Type'Class) is + begin + if HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + HT.Length := 0; + -- HT.Busy := 0; + -- HT.Lock := 0; + HT.Free := -1; + HT.Buckets := (others => 0); -- optimize this somehow ??? + end Clear; + + --------------------------- + -- 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 HT.Length = 0 then + raise Program_Error with + "attempt to delete node from empty hashed container"; + end if; + + Indx := Index (HT, HT.Nodes (X)); + Prev := HT.Buckets (Indx); + + if 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, Prev); + HT.Length := HT.Length - 1; + return; + end if; + + if HT.Length = 1 then + raise Program_Error with + "attempt to delete node not in its proper hash bucket"; + end if; + + loop + Curr := Next (HT, Prev); + + if 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, 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 + pragma Assert (X > 0); + pragma Assert (X <= HT.Capacity); + + N : Nodes_Type renames HT.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 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 + 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 := 0; + 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, 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, 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 N < 0 then + raise Program_Error with "stream appears to be corrupt"; + end if; + + if N = 0 then + return; + end if; + + if 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 := Index (HT, HT.Nodes (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 := Next (HT.Nodes (Node)); + + begin + 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. + + for Indx in Index (HT, HT.Nodes (Node)) + 1 .. 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 new file mode 100644 index 000000000..8eca9e6a5 --- /dev/null +++ b/gcc/ada/a-chtgbo.ads @@ -0,0 +1,140 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +-- 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; + + 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. + + 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_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 new file mode 100644 index 000000000..89649f33a --- /dev/null +++ b/gcc/ada/a-chtgke.adb @@ -0,0 +1,313 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_KEYS -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Hash_Tables.Generic_Keys is + + -------------------------- + -- 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; + + Indx := Index (HT, Key); + X := HT.Buckets (Indx); + + if X = null then + return; + end if; + + if Equivalent_Keys (Key, X) then + if HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + 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 Equivalent_Keys (Key, X) then + if HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + 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 : 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 := Index (HT, Key); + + Node := HT.Buckets (Indx); + while Node /= null loop + if Equivalent_Keys (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 : constant Hash_Type := Index (HT, Key); + B : Node_Access renames HT.Buckets (Indx); + + begin + if B = null then + if HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + if HT.Length = Count_Type'Last then + raise Constraint_Error; + end if; + + Node := New_Node (Next => null); + Inserted := True; + + B := Node; + HT.Length := HT.Length + 1; + + return; + end if; + + Node := B; + loop + if Equivalent_Keys (Key, Node) then + Inserted := False; + return; + end if; + + Node := Next (Node); + + exit when Node = null; + end loop; + + if HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + if HT.Length = Count_Type'Last then + raise Constraint_Error; + end if; + + Node := New_Node (Next => B); + Inserted := True; + + B := Node; + HT.Length := HT.Length + 1; + end Generic_Conditional_Insert; + + ----------- + -- Index -- + ----------- + + function Index + (HT : Hash_Table_Type; + Key : Key_Type) return Hash_Type is + begin + return Hash (Key) mod HT.Buckets'Length; + end Index; + + ----------------------------- + -- 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_Hash : constant Hash_Type := Hash (Node); + Old_Indx : constant Hash_Type := Old_Hash mod HT.Buckets'Length; + + New_Hash : constant Hash_Type := Hash (Key); + New_Indx : constant Hash_Type := New_Hash mod HT.Buckets'Length; + + New_Bucket : Node_Access renames HT.Buckets (New_Indx); + N, M : Node_Access; + + begin + if Equivalent_Keys (Key, Node) then + pragma Assert (New_Hash = Old_Hash); + + if HT.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (container is locked)"; + end if; + + -- 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); + pragma Assert (Hash (Node) = New_Hash); + pragma Assert (Equivalent_Keys (Key, Node)); + 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 Equivalent_Keys (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. + + if HT.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (container is locked)"; + end if; + + Assign (Node, Key); + pragma Assert (Hash (Node) = New_Hash); + pragma Assert (Equivalent_Keys (Key, Node)); + return; + end if; + + -- The node is a bucket different from the bucket implied by Key + + if HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + -- 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); + pragma Assert (Hash (Node) = New_Hash); + pragma Assert (Equivalent_Keys (Key, Node)); + + -- 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; + +end Ada.Containers.Hash_Tables.Generic_Keys; diff --git a/gcc/ada/a-chtgke.ads b/gcc/ada/a-chtgke.ads new file mode 100644 index 000000000..ccdee2f6b --- /dev/null +++ b/gcc/ada/a-chtgke.ads @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_KEYS -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +-- 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; + + 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 + + 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 : Hash_Table_Type; Key : Key_Type) return Node_Access; + -- Returns the node (if any) corresponding to the given key + + generic + with function New_Node (Next : Node_Access) return Node_Access; + procedure Generic_Conditional_Insert + (HT : in out Hash_Table_Type; + Key : Key_Type; + Node : out Node_Access; + Inserted : out Boolean); + -- Attempts to insert a new node with the given key into the hash table. + -- If a node with that key already exists in the table, then that node + -- is returned and Inserted returns False. Otherwise New_Node is called + -- to allocate a new node, and Inserted returns True. Program_Error is + -- raised if the hash table is busy. + + generic + with function Hash (Node : Node_Access) return Hash_Type; + with procedure Assign (Node : Node_Access; Key : Key_Type); + procedure Generic_Replace_Element + (HT : in out Hash_Table_Type; + Node : Node_Access; + Key : Key_Type); + -- Assigns Key to Node, possibly changing its equivalence class. If Node + -- is in the same equivalence class as Key (that is, it's already in the + -- bucket implied by Key), then if the hash table is locked then + -- Program_Error is raised; otherwise Assign is called to assign Key to + -- Node. If Node is in a different bucket from Key, then Program_Error is + -- raised if the hash table is busy. Otherwise it Assigns Key to Node and + -- moves the Node from its current bucket to the bucket implied by Key. + -- Note that it is never proper to assign to Node a key value already + -- in the map, and so if Key is equivalent to some other node then + -- Program_Error is raised. + +end Ada.Containers.Hash_Tables.Generic_Keys; diff --git a/gcc/ada/a-chtgop.adb b/gcc/ada/a-chtgop.adb new file mode 100644 index 000000000..d014dc17c --- /dev/null +++ b/gcc/ada/a-chtgop.adb @@ -0,0 +1,703 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Prime_Numbers; +with Ada.Unchecked_Deallocation; + +with System; use type System.Address; + +package body Ada.Containers.Hash_Tables.Generic_Operations is + + type Buckets_Allocation is access all Buckets_Type; + -- Used for allocation and deallocation (see New_Buckets and Free_Buckets). + -- This is necessary because Buckets_Access has an empty storage pool. + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (HT : in out Hash_Table_Type) is + Src_Buckets : constant Buckets_Access := HT.Buckets; + N : constant Count_Type := HT.Length; + Src_Node : Node_Access; + Dst_Prev : Node_Access; + + begin + HT.Buckets := null; + HT.Length := 0; + + if N = 0 then + return; + end if; + + -- Technically it isn't necessary to allocate the exact same length + -- buckets array, because our only requirement is that following + -- assignment the source and target containers compare equal (that is, + -- operator "=" returns True). We can satisfy this requirement with any + -- hash table length, but we decide here to match the length of the + -- source table. This has the benefit that when iterating, elements of + -- the target are delivered in the exact same order as for the source. + + HT.Buckets := New_Buckets (Length => Src_Buckets'Length); + + for Src_Index in Src_Buckets'Range loop + Src_Node := Src_Buckets (Src_Index); + + if Src_Node /= null then + declare + Dst_Node : constant Node_Access := Copy_Node (Src_Node); + + -- See note above + + pragma Assert (Index (HT, Dst_Node) = Src_Index); + + begin + HT.Buckets (Src_Index) := Dst_Node; + HT.Length := HT.Length + 1; + + Dst_Prev := Dst_Node; + end; + + Src_Node := Next (Src_Node); + while Src_Node /= null loop + declare + Dst_Node : constant Node_Access := Copy_Node (Src_Node); + + -- See note above + + pragma Assert (Index (HT, Dst_Node) = Src_Index); + + begin + Set_Next (Node => Dst_Prev, Next => Dst_Node); + HT.Length := HT.Length + 1; + + Dst_Prev := Dst_Node; + end; + + Src_Node := Next (Src_Node); + end loop; + end if; + end loop; + + pragma Assert (HT.Length = N); + end Adjust; + + -------------- + -- Capacity -- + -------------- + + function Capacity (HT : Hash_Table_Type) return Count_Type is + begin + if HT.Buckets = null then + return 0; + end if; + + return HT.Buckets'Length; + end Capacity; + + ----------- + -- Clear -- + ----------- + + procedure Clear (HT : in out Hash_Table_Type) is + Index : Hash_Type := 0; + Node : Node_Access; + + begin + if HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + while HT.Length > 0 loop + while HT.Buckets (Index) = null loop + Index := Index + 1; + end loop; + + declare + Bucket : Node_Access renames HT.Buckets (Index); + begin + loop + Node := Bucket; + Bucket := Next (Bucket); + HT.Length := HT.Length - 1; + Free (Node); + exit when Bucket = null; + end loop; + end; + end loop; + end Clear; + + --------------------------- + -- Delete_Node_Sans_Free -- + --------------------------- + + procedure Delete_Node_Sans_Free + (HT : in out Hash_Table_Type; + X : Node_Access) + is + pragma Assert (X /= null); + + Indx : Hash_Type; + Prev : Node_Access; + Curr : Node_Access; + + begin + if HT.Length = 0 then + raise Program_Error with + "attempt to delete node from empty hashed container"; + end if; + + Indx := Index (HT, X); + Prev := HT.Buckets (Indx); + + if Prev = null then + raise Program_Error with + "attempt to delete node from empty hash bucket"; + end if; + + if Prev = X then + HT.Buckets (Indx) := Next (Prev); + HT.Length := HT.Length - 1; + return; + end if; + + if HT.Length = 1 then + raise Program_Error with + "attempt to delete node not in its proper hash bucket"; + end if; + + loop + Curr := Next (Prev); + + if Curr = null then + raise Program_Error with + "attempt to delete node not in its proper hash bucket"; + end if; + + if Curr = X then + Set_Next (Node => Prev, Next => Next (Curr)); + HT.Length := HT.Length - 1; + return; + end if; + + Prev := Curr; + end loop; + end Delete_Node_Sans_Free; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (HT : in out Hash_Table_Type) is + begin + Clear (HT); + Free_Buckets (HT.Buckets); + end Finalize; + + ----------- + -- First -- + ----------- + + function First (HT : Hash_Table_Type) return Node_Access is + Indx : Hash_Type; + + begin + if HT.Length = 0 then + return null; + end if; + + Indx := HT.Buckets'First; + loop + if HT.Buckets (Indx) /= null then + return HT.Buckets (Indx); + end if; + + Indx := Indx + 1; + end loop; + end First; + + ------------------ + -- Free_Buckets -- + ------------------ + + procedure Free_Buckets (Buckets : in out Buckets_Access) is + procedure Free is + new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Allocation); + + begin + -- Buckets must have been created by New_Buckets. Here, we convert back + -- to the Buckets_Allocation type, and do the free on that. + + Free (Buckets_Allocation (Buckets)); + end Free_Buckets; + + --------------------- + -- Free_Hash_Table -- + --------------------- + + procedure Free_Hash_Table (Buckets : in out Buckets_Access) is + Node : Node_Access; + + begin + if Buckets = null then + return; + end if; + + for J in Buckets'Range loop + while Buckets (J) /= null loop + Node := Buckets (J); + Buckets (J) := Next (Node); + Free (Node); + end loop; + end loop; + + Free_Buckets (Buckets); + end Free_Hash_Table; + + ------------------- + -- Generic_Equal -- + ------------------- + + function Generic_Equal + (L, R : Hash_Table_Type) return Boolean + is + L_Index : Hash_Type; + L_Node : Node_Access; + + 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 := 0; + loop + L_Node := L.Buckets (L_Index); + exit when L_Node /= null; + L_Index := L_Index + 1; + end loop; + + -- For each node of hash table L, search for an equivalent node in hash + -- table R. + + N := L.Length; + loop + if not Find (HT => R, Key => L_Node) then + return False; + end if; + + N := N - 1; + + L_Node := Next (L_Node); + + if L_Node = null then + -- We have exhausted the nodes in this bucket + + if N = 0 then + return True; + end if; + + -- Find the next bucket + + loop + L_Index := L_Index + 1; + L_Node := L.Buckets (L_Index); + exit when L_Node /= null; + end loop; + end if; + end loop; + end Generic_Equal; + + ----------------------- + -- Generic_Iteration -- + ----------------------- + + procedure Generic_Iteration (HT : Hash_Table_Type) is + Node : Node_Access; + + begin + if HT.Length = 0 then + return; + end if; + + for Indx in HT.Buckets'Range loop + Node := HT.Buckets (Indx); + while Node /= null loop + Process (Node); + Node := Next (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) + is + N : Count_Type'Base; + NN : Hash_Type; + + begin + Clear (HT); + + Count_Type'Base'Read (Stream, N); + + if N < 0 then + raise Program_Error with "stream appears to be corrupt"; + end if; + + if N = 0 then + return; + end if; + + -- The RM does not specify whether or how the capacity changes when a + -- hash table is streamed in. Therefore we decide here to allocate a new + -- buckets array only when it's necessary to preserve representation + -- invariants. + + if HT.Buckets = null + or else HT.Buckets'Length < N + then + Free_Buckets (HT.Buckets); + NN := Prime_Numbers.To_Prime (N); + HT.Buckets := New_Buckets (Length => NN); + end if; + + for J in 1 .. N loop + declare + Node : constant Node_Access := New_Node (Stream); + Indx : constant Hash_Type := Index (HT, Node); + B : Node_Access renames HT.Buckets (Indx); + begin + Set_Next (Node => Node, Next => B); + B := Node; + end; + + HT.Length := HT.Length + 1; + end loop; + end Generic_Read; + + ------------------- + -- Generic_Write -- + ------------------- + + procedure Generic_Write + (Stream : not null access Root_Stream_Type'Class; + HT : Hash_Table_Type) + is + procedure Write (Node : Node_Access); + pragma Inline (Write); + + procedure Write is new Generic_Iteration (Write); + + ----------- + -- Write -- + ----------- + + procedure Write (Node : Node_Access) is + begin + Write (Stream, Node); + end Write; + + begin + -- See Generic_Read for an explanation of why we do not stream out the + -- buckets array length too. + + Count_Type'Base'Write (Stream, HT.Length); + Write (HT); + end Generic_Write; + + ----------- + -- Index -- + ----------- + + function Index + (Buckets : Buckets_Type; + Node : Node_Access) return Hash_Type is + begin + return Hash_Node (Node) mod Buckets'Length; + end Index; + + function Index + (Hash_Table : Hash_Table_Type; + Node : Node_Access) return Hash_Type is + begin + return Index (Hash_Table.Buckets.all, Node); + end Index; + + ---------- + -- Move -- + ---------- + + procedure Move (Target, Source : in out Hash_Table_Type) is + begin + if Target'Address = Source'Address then + return; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Clear (Target); + + declare + Buckets : constant Buckets_Access := Target.Buckets; + begin + Target.Buckets := Source.Buckets; + Source.Buckets := Buckets; + end; + + Target.Length := Source.Length; + Source.Length := 0; + end Move; + + ----------------- + -- New_Buckets -- + ----------------- + + function New_Buckets (Length : Hash_Type) return Buckets_Access is + subtype Rng is Hash_Type range 0 .. Length - 1; + + begin + -- Allocate in Buckets_Allocation'Storage_Pool, then convert to + -- Buckets_Access. + + return Buckets_Access (Buckets_Allocation'(new Buckets_Type (Rng))); + end New_Buckets; + + ---------- + -- Next -- + ---------- + + function Next + (HT : Hash_Table_Type; + Node : Node_Access) return Node_Access + is + Result : Node_Access := Next (Node); + + begin + if Result /= null then + return Result; + end if; + + for Indx in Index (HT, Node) + 1 .. HT.Buckets'Last loop + Result := HT.Buckets (Indx); + + if Result /= null then + return Result; + end if; + end loop; + + return null; + end Next; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (HT : in out Hash_Table_Type; + N : Count_Type) + is + NN : Hash_Type; + + begin + if HT.Buckets = null then + if N > 0 then + NN := Prime_Numbers.To_Prime (N); + HT.Buckets := New_Buckets (Length => NN); + end if; + + return; + end if; + + if HT.Length = 0 then + + -- This is the easy case. There are no nodes, so no rehashing is + -- necessary. All we need to do is allocate a new buckets array + -- having a length implied by the specified capacity. (We say + -- "implied by" because bucket arrays are always allocated with a + -- length that corresponds to a prime number.) + + if N = 0 then + Free_Buckets (HT.Buckets); + return; + end if; + + if N = HT.Buckets'Length then + return; + end if; + + NN := Prime_Numbers.To_Prime (N); + + if NN = HT.Buckets'Length then + return; + end if; + + declare + X : Buckets_Access := HT.Buckets; + pragma Warnings (Off, X); + begin + HT.Buckets := New_Buckets (Length => NN); + Free_Buckets (X); + end; + + return; + end if; + + if N = HT.Buckets'Length then + return; + end if; + + if N < HT.Buckets'Length then + + -- This is a request to contract the buckets array. The amount of + -- contraction is bounded in order to preserve the invariant that the + -- buckets array length is never smaller than the number of elements + -- (the load factor is 1). + + if HT.Length >= HT.Buckets'Length then + return; + end if; + + NN := Prime_Numbers.To_Prime (HT.Length); + + if NN >= HT.Buckets'Length then + return; + end if; + + else + NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length)); + + if NN = HT.Buckets'Length then -- can't expand any more + return; + end if; + end if; + + if HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Rehash : declare + Dst_Buckets : Buckets_Access := New_Buckets (Length => NN); + Src_Buckets : Buckets_Access := HT.Buckets; + pragma Warnings (Off, Src_Buckets); + + L : Count_Type renames HT.Length; + LL : constant Count_Type := L; + + Src_Index : Hash_Type := Src_Buckets'First; + + begin + while L > 0 loop + declare + Src_Bucket : Node_Access renames Src_Buckets (Src_Index); + + begin + while Src_Bucket /= null loop + declare + Src_Node : constant Node_Access := Src_Bucket; + + Dst_Index : constant Hash_Type := + Index (Dst_Buckets.all, Src_Node); + + Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index); + + begin + Src_Bucket := Next (Src_Node); + + Set_Next (Src_Node, Dst_Bucket); + + Dst_Bucket := Src_Node; + end; + + pragma Assert (L > 0); + L := L - 1; + end loop; + exception + when others => + -- If there's an error computing a hash value during a + -- rehash, then AI-302 says the nodes "become lost." The + -- issue is whether to actually deallocate these lost nodes, + -- since they might be designated by extant cursors. Here + -- we decide to deallocate the nodes, since it's better to + -- solve real problems (storage consumption) rather than + -- imaginary ones (the user might, or might not, dereference + -- a cursor designating a node that has been deallocated), + -- and because we have a way to vet a dangling cursor + -- reference anyway, and hence can actually detect the + -- problem. + + for Dst_Index in Dst_Buckets'Range loop + declare + B : Node_Access renames Dst_Buckets (Dst_Index); + X : Node_Access; + begin + while B /= null loop + X := B; + B := Next (X); + Free (X); + end loop; + end; + end loop; + + Free_Buckets (Dst_Buckets); + raise Program_Error with + "hash function raised exception during rehash"; + end; + + Src_Index := Src_Index + 1; + end loop; + + HT.Buckets := Dst_Buckets; + HT.Length := LL; + + Free_Buckets (Src_Buckets); + end Rehash; + end Reserve_Capacity; + +end Ada.Containers.Hash_Tables.Generic_Operations; diff --git a/gcc/ada/a-chtgop.ads b/gcc/ada/a-chtgop.ads new file mode 100644 index 000000000..b6ffd0709 --- /dev/null +++ b/gcc/ada/a-chtgop.ads @@ -0,0 +1,174 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +-- Hash_Table_Type is used to implement hashed containers. This package +-- declares hash-table operations that do not depend on keys. + +with Ada.Streams; + +generic + + with package HT_Types is + new Generic_Hash_Table_Types (<>); + + use HT_Types; + + with function Hash_Node (Node : Node_Access) return Hash_Type; + + with function Next (Node : Node_Access) return Node_Access; + + with procedure Set_Next + (Node : Node_Access; + Next : Node_Access); + + with function Copy_Node (Source : Node_Access) return Node_Access; + + with procedure Free (X : in out Node_Access); + +package Ada.Containers.Hash_Tables.Generic_Operations is + pragma Preelaborate; + + procedure Free_Hash_Table (Buckets : in out Buckets_Access); + -- First frees the nodes in all non-null buckets of Buckets, and then frees + -- the Buckets array itself. + + function Index + (Buckets : Buckets_Type; + Node : Node_Access) return Hash_Type; + pragma Inline (Index); + -- Uses the hash value of Node to compute its Buckets array index + + function Index + (Hash_Table : Hash_Table_Type; + Node : Node_Access) return Hash_Type; + pragma Inline (Index); + -- Uses the hash value of Node to compute its Hash_Table buckets array + -- index. + + procedure Adjust (HT : in out Hash_Table_Type); + -- Used to implement controlled Adjust. It is assumed that HT has the value + -- of the bit-wise copy that immediately follows controlled Finalize. + -- Adjust first allocates a new buckets array for HT (having the same + -- length as the source), and then allocates a copy of each node of source. + + procedure Finalize (HT : in out Hash_Table_Type); + -- Used to implement controlled Finalize. It first calls Clear to + -- deallocate any remaining nodes, and then deallocates the buckets array. + + generic + with function Find + (HT : Hash_Table_Type; + Key : Node_Access) return Boolean; + function Generic_Equal + (L, R : Hash_Table_Type) return Boolean; + -- Used to implement hashed container equality. For each node in hash table + -- L, it calls Find to search for an equivalent item in hash table R. If + -- Find returns False for any node then Generic_Equal terminates + -- immediately and returns False. Otherwise if Find returns True for every + -- node then Generic_Equal returns True. + + procedure Clear (HT : in out Hash_Table_Type); + -- Deallocates each node in hash table HT. (Note that it only deallocates + -- the nodes, not the buckets array.) Program_Error is raised if the hash + -- table is busy. + + procedure Move (Target, Source : in out Hash_Table_Type); + -- Moves (not copies) the buckets array and nodes from Source to + -- Target. Program_Error is raised if Source is busy. The Target is first + -- cleared to deallocate its nodes (implying that Program_Error is also + -- raised if Target is busy). Source is empty following the move. + + function Capacity (HT : Hash_Table_Type) return Count_Type; + -- Returns the length of the buckets array + + procedure Reserve_Capacity + (HT : in out Hash_Table_Type; + N : Count_Type); + -- If N is greater than the current capacity, then it expands the buckets + -- array to at least the value N. If N is less than the current capacity, + -- then it contracts the buckets array. In either case existing nodes are + -- rehashed onto the new buckets array, and the old buckets array is + -- deallocated. Program_Error is raised if the hash table is busy. + + procedure Delete_Node_Sans_Free + (HT : in out Hash_Table_Type; + X : Node_Access); + -- Removes node X from the hash table without deallocating the node + + function First (HT : Hash_Table_Type) return Node_Access; + -- Returns the head of the list in the first (lowest-index) non-empty + -- bucket. + + function Next + (HT : Hash_Table_Type; + Node : Node_Access) return Node_Access; + -- Returns the node that immediately follows Node. This corresponds to + -- either the next node in the same bucket, or (if Node is the last node in + -- its bucket) the head of the list in the first non-empty bucket that + -- follows. + + generic + with procedure Process (Node : Node_Access); + procedure Generic_Iteration (HT : Hash_Table_Type); + -- Calls Process for each node in hash table HT + + generic + use Ada.Streams; + with procedure Write + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access); + procedure Generic_Write + (Stream : not null access Root_Stream_Type'Class; + HT : Hash_Table_Type); + -- Used to implement the streaming attribute for hashed containers. It + -- calls Write for each node to write its value into Stream. + + generic + use Ada.Streams; + with function New_Node (Stream : not null access Root_Stream_Type'Class) + return Node_Access; + procedure Generic_Read + (Stream : not null access Root_Stream_Type'Class; + HT : out Hash_Table_Type); + -- Used to implement the streaming attribute for hashed containers. It + -- first clears hash table HT, then populates the hash table by calling + -- New_Node for each item in Stream. + + function New_Buckets (Length : Hash_Type) return Buckets_Access; + pragma Inline (New_Buckets); + -- Allocate a new Buckets_Type array with bounds 0..Length-1 + + procedure Free_Buckets (Buckets : in out Buckets_Access); + pragma Inline (Free_Buckets); + -- Unchecked_Deallocate Buckets + + -- Note: New_Buckets and Free_Buckets are needed because Buckets_Access has + -- an empty pool. + +end Ada.Containers.Hash_Tables.Generic_Operations; diff --git a/gcc/ada/a-chzla1.ads b/gcc/ada/a-chzla1.ads new file mode 100644 index 000000000..cd360d4cb --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..89a7d6346 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..8d1f8e364 --- /dev/null +++ b/gcc/ada/a-cidlli.adb @@ -0,0 +1,1910 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_DOUBLY_LINKED_LISTS -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +with System; use type System.Address; +with Ada.Unchecked_Deallocation; + +package body Ada.Containers.Indefinite_Doubly_Linked_Lists is + + 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); + + function Vet (Position : Cursor) return Boolean; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : List) return Boolean is + L : Node_Access; + R : Node_Access; + + begin + if Left'Address = Right'Address then + return True; + end if; + + if Left.Length /= Right.Length then + return False; + end if; + + L := Left.First; + R := Right.First; + 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; + + return True; + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out List) is + Src : Node_Access := Container.First; + Dst : Node_Access; + + begin + if Src = null then + pragma Assert (Container.Last = null); + pragma Assert (Container.Length = 0); + pragma Assert (Container.Busy = 0); + pragma Assert (Container.Lock = 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; + Container.Busy := 0; + Container.Lock := 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; + + ----------- + -- 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.Busy = 0); + pragma Assert (Container.Lock = 0); + return; + end if; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + end if; + + 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; + + -------------- + -- 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 + X : Node_Access; + + begin + if Position.Node = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Position.Node.Element = null then + raise Program_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), "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; + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + end if; + + 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; + + 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; + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + end if; + + for I 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; + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + end if; + + for I 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 Position.Node = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if 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; + + ---------- + -- 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 Node.Element = null then + raise Program_Error; + end if; + + if 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; + + while Node /= null loop + if Node.Element.all = Item then + return Cursor'(Container'Unchecked_Access, Node); + end if; + + Node := Node.Next; + end loop; + + return No_Element; + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : List) return Cursor is + begin + if Container.First = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Container.First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : List) return Element_Type is + begin + if 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 + 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 + Node : Node_Access := Container.First; + + begin + for I 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 + LI, RI : Cursor; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Target (list is busy)"; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Source (list is busy)"; + end if; + + LI := First (Target); + RI := First (Source); + while RI.Node /= null loop + pragma Assert (RI.Node.Next = null + or else not (RI.Node.Next.Element.all < + RI.Node.Element.all)); + + if LI.Node = null then + Splice (Target, No_Element, Source); + return; + end if; + + pragma Assert (LI.Node.Next = null + or else not (LI.Node.Next.Element.all < + LI.Node.Element.all)); + + if RI.Node.Element.all < LI.Node.Element.all then + declare + RJ : Cursor := RI; + pragma Warnings (Off, RJ); + begin + RI.Node := RI.Node.Next; + Splice (Target, LI, Source, RJ); + end; + + else + LI.Node := LI.Node.Next; + end if; + end loop; + 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 := Pivot.Next; + + begin + 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); + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + end if; + + Sort (Front => null, Back => null); + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + 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 /= 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 + New_Node : Node_Access; + + begin + if Before.Container /= null then + if Before.Container /= Container'Unrestricted_Access then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + end if; + + if 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 Container.Length > Count_Type'Last - Count then + raise Constraint_Error with "new length exceeds maximum"; + end if; + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + end if; + + 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); + Position := Cursor'(Container'Unchecked_Access, New_Node); + + for J in Count_Type'(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; + 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 + C : List renames Container'Unrestricted_Access.all; + B : Natural renames C.Busy; + + Node : Node_Access := Container.First; + + begin + B := B + 1; + + begin + while Node /= null loop + Process (Cursor'(Container'Unchecked_Access, Node)); + Node := Node.Next; + end loop; + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : List) return Cursor is + begin + if Container.Last = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Container.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : List) return Element_Type is + begin + if 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; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Source (list is busy)"; + end if; + + 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; + end if; + + 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; + end if; + + return Cursor'(Position.Container, Next_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 = null then + return No_Element; + end if; + + 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; + end if; + + return Cursor'(Position.Container, Prev_Node); + end; + 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 has no element"; + end if; + + if 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 + C : List renames Position.Container.all'Unrestricted_Access.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (Position.Node.Element.all); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + 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; + + --------------------- + -- 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 with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unchecked_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (list is locked)"; + end if; + + if 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 + 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); + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + end if; + + 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 Node.Element = null then + raise Program_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), "bad cursor in Reverse_Find"); + end if; + + while Node /= null loop + if Node.Element.all = Item then + return Cursor'(Container'Unchecked_Access, Node); + end if; + + Node := 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; + B : Natural renames C.Busy; + + Node : Node_Access := Container.Last; + + begin + B := B + 1; + + begin + while Node /= null loop + Process (Cursor'(Container'Unchecked_Access, Node)); + Node := Node.Prev; + end loop; + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Reverse_Iterate; + + ------------ + -- Splice -- + ------------ + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List) + is + begin + if Before.Container /= null then + if Before.Container /= Target'Unrestricted_Access then + raise Program_Error with + "Before cursor designates wrong container"; + end if; + + if 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; + + pragma Assert (Source.First.Prev = null); + pragma Assert (Source.Last.Next = null); + + if Target.Length > Count_Type'Last - Source.Length then + raise Constraint_Error with "new length exceeds maximum"; + end if; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Target (list is busy)"; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Source (list is busy)"; + end if; + + if Target.Length = 0 then + pragma Assert (Before = No_Element); + pragma Assert (Target.First = null); + pragma Assert (Target.Last = null); + + Target.First := Source.First; + Target.Last := Source.Last; + + elsif Before.Node = null then + pragma Assert (Target.Last.Next = null); + + Target.Last.Next := Source.First; + Source.First.Prev := Target.Last; + + Target.Last := Source.Last; + + elsif Before.Node = 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.Node.Prev.Next := Source.First; + Source.First.Prev := Before.Node.Prev; + + Before.Node.Prev := Source.Last; + Source.Last.Next := Before.Node; + end if; + + Source.First := null; + Source.Last := null; + + Target.Length := Target.Length + Source.Length; + Source.Length := 0; + end Splice; + + procedure Splice + (Container : in out List; + Before : Cursor; + Position : Cursor) + is + begin + if Before.Container /= null then + if Before.Container /= Container'Unchecked_Access then + raise Program_Error with + "Before cursor designates wrong container"; + end if; + + if 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 Position.Node = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Node.Element = null then + raise Program_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), "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); + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + end if; + + 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 Before.Container /= Target'Unrestricted_Access then + raise Program_Error with + "Before cursor designates wrong container"; + end if; + + if 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 Position.Node = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Node.Element = null then + raise Program_Error with + "Position cursor has no element"; + end if; + + if 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 Target.Length = Count_Type'Last then + raise Constraint_Error with "Target is full"; + end if; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Target (list is busy)"; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Source (list is busy)"; + end if; + + if Position.Node = Source.First then + Source.First := Position.Node.Next; + + if Position.Node = 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.Node = Source.Last then + pragma Assert (Source.Length >= 2); + Source.Last := Position.Node.Prev; + Source.Last.Next := null; + + else + pragma Assert (Source.Length >= 3); + Position.Node.Prev.Next := Position.Node.Next; + Position.Node.Next.Prev := Position.Node.Prev; + end if; + + if Target.Length = 0 then + pragma Assert (Before = No_Element); + pragma Assert (Target.First = null); + pragma Assert (Target.Last = null); + + Target.First := Position.Node; + Target.Last := Position.Node; + + Target.First.Prev := null; + Target.Last.Next := null; + + elsif Before.Node = null then + pragma Assert (Target.Last.Next = null); + Target.Last.Next := Position.Node; + Position.Node.Prev := Target.Last; + + Target.Last := Position.Node; + Target.Last.Next := null; + + elsif Before.Node = Target.First then + pragma Assert (Target.First.Prev = null); + Target.First.Prev := Position.Node; + Position.Node.Next := Target.First; + + Target.First := Position.Node; + Target.First.Prev := null; + + else + pragma Assert (Target.Length >= 2); + Before.Node.Prev.Next := Position.Node; + Position.Node.Prev := Before.Node.Prev; + + Before.Node.Prev := Position.Node; + Position.Node.Next := Before.Node; + end if; + + Target.Length := Target.Length + 1; + Source.Length := Source.Length - 1; + + Position.Container := Target'Unchecked_Access; + end Splice; + + ---------- + -- Swap -- + ---------- + + procedure Swap + (Container : in out List; + I, J : Cursor) + is + begin + if I.Node = null then + raise Constraint_Error with "I cursor has no element"; + end if; + + if J.Node = null then + raise Constraint_Error with "J cursor has no element"; + end if; + + if I.Container /= Container'Unchecked_Access then + raise Program_Error with "I cursor designates wrong container"; + end if; + + if 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; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (list is locked)"; + end if; + + 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 I.Node = null then + raise Constraint_Error with "I cursor has no element"; + end if; + + if J.Node = 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 designates wrong container"; + end if; + + if 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; + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is busy)"; + 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); + + 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 Position.Node = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Node.Element = null then + raise Program_Error with + "Position cursor has no element"; + end if; + + if 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 + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (Position.Node.Element.all); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; + end Update_Element; + + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = null then + return Position.Container = null; + end if; + + if Position.Container = null then + return False; + end if; + + if Position.Node.Next = Position.Node then + return False; + end if; + + if Position.Node.Prev = Position.Node then + return False; + end if; + + if Position.Node.Element = null then + return False; + end if; + + 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; + +end Ada.Containers.Indefinite_Doubly_Linked_Lists; diff --git a/gcc/ada/a-cidlli.ads b/gcc/ada/a-cidlli.ads new file mode 100644 index 000000000..4f12a64ec --- /dev/null +++ b/gcc/ada/a-cidlli.ads @@ -0,0 +1,268 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_DOUBLY_LINKED_LISTS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-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 -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +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 Preelaborate; + pragma Remote_Types; + + type List is tagged private; + pragma Preelaborable_Initialization (List); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_List : constant List; + + No_Element : constant Cursor; + + 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)); + + 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; + + function Has_Element (Position : Cursor) 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); + + type Node_Type; + type Node_Access is access Node_Type; + + type Element_Access is access Element_Type; + + type Node_Type is + limited record + Element : Element_Access; + Next : Node_Access; + Prev : Node_Access; + end record; + + use Ada.Finalization; + + type List is + new Controlled with record + First : Node_Access; + Last : Node_Access; + Length : Count_Type := 0; + Busy : Natural := 0; + Lock : Natural := 0; + end record; + + overriding + procedure Adjust (Container : in out List); + + overriding + procedure Finalize (Container : in out List) renames Clear; + + use Ada.Streams; + + 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 constant 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; + + Empty_List : constant List := List'(Controlled with null, null, 0, 0, 0); + + No_Element : constant Cursor := Cursor'(null, null); + +end Ada.Containers.Indefinite_Doubly_Linked_Lists; diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb new file mode 100644 index 000000000..b487394b3 --- /dev/null +++ b/gcc/ada/a-cihama.adb @@ -0,0 +1,1080 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_HASHED_MAPS -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +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.Unchecked_Deallocation; + +package body Ada.Containers.Indefinite_Hashed_Maps is + + procedure Free_Key is + new Ada.Unchecked_Deallocation (Key_Type, Key_Access); + + procedure Free_Element is + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Copy_Node (Node : Node_Access) return Node_Access; + pragma Inline (Copy_Node); + + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Access) return Boolean; + pragma Inline (Equivalent_Key_Node); + + function Find_Equal_Key + (R_HT : Hash_Table_Type; + L_Node : Node_Access) return Boolean; + + procedure Free (X : in out Node_Access); + -- pragma Inline (Free); + + function Hash_Node (Node : Node_Access) return Hash_Type; + pragma Inline (Hash_Node); + + function Next (Node : Node_Access) return Node_Access; + pragma Inline (Next); + + function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Node_Access; + + procedure Set_Next (Node : Node_Access; Next : Node_Access); + pragma Inline (Set_Next); + + function Vet (Position : Cursor) return Boolean; + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package HT_Ops is new Ada.Containers.Hash_Tables.Generic_Operations + (HT_Types => HT_Types, + Hash_Node => Hash_Node, + Next => Next, + Set_Next => Set_Next, + Copy_Node => Copy_Node, + Free => Free); + + package Key_Ops is new Hash_Tables.Generic_Keys + (HT_Types => HT_Types, + Next => Next, + Set_Next => Set_Next, + Key_Type => Key_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Key_Node); + + --------- + -- "=" -- + --------- + + function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key); + + overriding function "=" (Left, Right : Map) return Boolean is + begin + return Is_Equal (Left.HT, Right.HT); + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Map) is + begin + HT_Ops.Adjust (Container.HT); + end Adjust; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Map) return Count_Type is + begin + return HT_Ops.Capacity (Container.HT); + end Capacity; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Map) is + begin + HT_Ops.Clear (Container.HT); + end Clear; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Map; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + --------------- + -- Copy_Node -- + --------------- + + function Copy_Node (Node : Node_Access) return Node_Access is + K : Key_Access := new Key_Type'(Node.Key.all); + E : Element_Access; + + begin + E := new Element_Type'(Node.Element.all); + return new Node_Type'(K, E, null); + + exception + when others => + Free_Key (K); + Free_Element (E); + raise; + end Copy_Node; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Map; Key : Key_Type) is + X : Node_Access; + + begin + Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); + + if X = null then + raise Constraint_Error with "attempt to delete key not in map"; + end if; + + Free (X); + end Delete; + + procedure Delete (Container : in out Map; Position : in out Cursor) is + begin + if Position.Node = null then + raise Constraint_Error with + "Position cursor of Delete equals No_Element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor of Delete designates wrong map"; + end if; + + if Container.HT.Busy > 0 then + raise Program_Error with + "Delete attempted to tamper with cursors (map is busy)"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Delete"); + + HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node); + + Free (Position.Node); + Position.Container := null; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element (Container : Map; Key : Key_Type) return Element_Type is + Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); + + begin + if Node = null then + raise Constraint_Error with + "no element available because key not in map"; + end if; + + return Node.Element.all; + end Element; + + function Element (Position : Cursor) return Element_Type is + begin + if Position.Node = null then + raise Constraint_Error with + "Position cursor of function Element equals No_Element"; + end if; + + if Position.Node.Element = null then + raise Program_Error with + "Position cursor of function Element is bad"; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Element"); + + return Position.Node.Element.all; + end Element; + + ------------------------- + -- Equivalent_Key_Node -- + ------------------------- + + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Access) return Boolean + is + begin + return Equivalent_Keys (Key, Node.Key.all); + end Equivalent_Key_Node; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Left, Right : Cursor) return Boolean is + begin + if Left.Node = null then + raise Constraint_Error with + "Left cursor of Equivalent_Keys equals No_Element"; + end if; + + if Right.Node = null then + raise Constraint_Error with + "Right cursor of Equivalent_Keys equals No_Element"; + end if; + + if Left.Node.Key = null then + raise Program_Error with + "Left cursor of Equivalent_Keys is bad"; + end if; + + if Right.Node.Key = null then + raise Program_Error with + "Right cursor of Equivalent_Keys is bad"; + end if; + + pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys"); + pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys"); + + return Equivalent_Keys (Left.Node.Key.all, Right.Node.Key.all); + end Equivalent_Keys; + + function Equivalent_Keys + (Left : Cursor; + Right : Key_Type) return Boolean + is + begin + if Left.Node = null then + raise Constraint_Error with + "Left cursor of Equivalent_Keys equals No_Element"; + end if; + + if Left.Node.Key = null then + raise Program_Error with + "Left cursor of Equivalent_Keys is bad"; + end if; + + pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys"); + + return Equivalent_Keys (Left.Node.Key.all, Right); + end Equivalent_Keys; + + function Equivalent_Keys + (Left : Key_Type; + Right : Cursor) return Boolean + is + begin + if Right.Node = null then + raise Constraint_Error with + "Right cursor of Equivalent_Keys equals No_Element"; + end if; + + if Right.Node.Key = null then + raise Program_Error with + "Right cursor of Equivalent_Keys is bad"; + end if; + + pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys"); + + return Equivalent_Keys (Left, Right.Node.Key.all); + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Map; Key : Key_Type) is + X : Node_Access; + begin + Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); + Free (X); + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Container : in out Map) is + begin + HT_Ops.Finalize (Container.HT); + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find (Container : Map; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_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 := Key_Ops.Index (R_HT, L_Node.Key.all); + R_Node : Node_Access := R_HT.Buckets (R_Index); + + begin + while R_Node /= null loop + if Equivalent_Keys (L_Node.Key.all, R_Node.Key.all) then + return L_Node.Element.all = R_Node.Element.all; + end if; + + R_Node := R_Node.Next; + end loop; + + return False; + end Find_Equal_Key; + + ----------- + -- First -- + ----------- + + function First (Container : Map) return Cursor is + Node : constant Node_Access := HT_Ops.First (Container.HT); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end First; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + begin + if X = null then + return; + end if; + + X.Next := X; -- detect mischief (in Vet) + + begin + Free_Key (X.Key); + exception + when others => + X.Key := null; + + begin + Free_Element (X.Element); + exception + when others => + X.Element := null; + end; + + Deallocate (X); + raise; + end; + + begin + Free_Element (X.Element); + exception + when others => + X.Element := null; + + Deallocate (X); + raise; + end; + + Deallocate (X); + end Free; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + pragma Assert (Vet (Position), "bad cursor in Has_Element"); + return Position.Node /= null; + end Has_Element; + + --------------- + -- Hash_Node -- + --------------- + + function Hash_Node (Node : Node_Access) return Hash_Type is + begin + return Hash (Node.Key.all); + end Hash_Node; + + ------------- + -- Include -- + ------------- + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + K : Key_Access; + E : Element_Access; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + if Container.HT.Lock > 0 then + raise Program_Error with + "Include attempted to tamper with elements (map is locked)"; + end if; + + K := Position.Node.Key; + E := Position.Node.Element; + + Position.Node.Key := new Key_Type'(Key); + + begin + Position.Node.Element := new Element_Type'(New_Item); + exception + when others => + Free_Key (K); + raise; + end; + + Free_Key (K); + Free_Element (E); + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + function New_Node (Next : Node_Access) return Node_Access; + + procedure Local_Insert is + new Key_Ops.Generic_Conditional_Insert (New_Node); + + -------------- + -- New_Node -- + -------------- + + function New_Node (Next : Node_Access) return Node_Access is + K : Key_Access := new Key_Type'(Key); + E : Element_Access; + + begin + E := new Element_Type'(New_Item); + return new Node_Type'(K, E, Next); + exception + when others => + Free_Key (K); + Free_Element (E); + raise; + end New_Node; + + HT : Hash_Table_Type renames Container.HT; + + -- Start of processing for Insert + + begin + if HT_Ops.Capacity (HT) = 0 then + HT_Ops.Reserve_Capacity (HT, 1); + end if; + + Local_Insert (HT, Key, Position.Node, Inserted); + + if Inserted + and then HT.Length > HT_Ops.Capacity (HT) + then + HT_Ops.Reserve_Capacity (HT, HT.Length); + end if; + + Position.Container := Container'Unchecked_Access; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + pragma Unreferenced (Position); + + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error with + "attempt to insert key already in map"; + end if; + end Insert; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Map) return Boolean is + begin + return Container.HT.Length = 0; + end Is_Empty; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new HT_Ops.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + B : Natural renames Container'Unrestricted_Access.HT.Busy; + + -- Start of processing Iterate + + begin + B := B + 1; + + begin + Local_Iterate (Container.HT); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Iterate; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + if Position.Node = null then + raise Constraint_Error with + "Position cursor of function Key equals No_Element"; + end if; + + if Position.Node.Key = null then + raise Program_Error with + "Position cursor of function Key is bad"; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Key"); + + return Position.Node.Key.all; + end Key; + + ------------ + -- Length -- + ------------ + + function Length (Container : Map) return Count_Type is + begin + return Container.HT.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move + (Target : in out Map; + Source : in out Map) + is + begin + HT_Ops.Move (Target => Target.HT, Source => Source.HT); + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Node : Node_Access) return Node_Access is + begin + return Node.Next; + end Next; + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position.Node = null then + return No_Element; + end if; + + if Position.Node.Key = null + or else Position.Node.Element = null + then + raise Program_Error with "Position cursor of Next is bad"; + end if; + + pragma Assert (Vet (Position), "Position cursor of Next is bad"); + + declare + HT : Hash_Table_Type renames Position.Container.HT; + Node : constant Node_Access := HT_Ops.Next (HT, Position.Node); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Next; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : Element_Type)) + is + begin + if Position.Node = null then + raise Constraint_Error with + "Position cursor of Query_Element equals No_Element"; + end if; + + if Position.Node.Key = null + or else Position.Node.Element = null + then + raise Program_Error with + "Position cursor of Query_Element is bad"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Query_Element"); + + declare + M : Map renames Position.Container.all; + HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + + begin + B := B + 1; + L := L + 1; + + declare + K : Key_Type renames Position.Node.Key.all; + E : Element_Type renames Position.Node.Element.all; + + begin + Process (K, E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node); + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Map) + is + begin + Read_Nodes (Stream, Container.HT); + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream map cursor"; + end Read; + + --------------- + -- Read_Node -- + --------------- + + function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Node_Access + is + Node : Node_Access := new Node_Type; + + begin + begin + Node.Key := new Key_Type'(Key_Type'Input (Stream)); + exception + when others => + Free (Node); + raise; + end; + + begin + Node.Element := new Element_Type'(Element_Type'Input (Stream)); + exception + when others => + Free_Key (Node.Key); + Free (Node); + raise; + end; + + return Node; + end Read_Node; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); + + K : Key_Access; + E : Element_Access; + + begin + if Node = null then + raise Constraint_Error with + "attempt to replace key not in map"; + end if; + + if Container.HT.Lock > 0 then + raise Program_Error with + "Replace attempted to tamper with elements (map is locked)"; + end if; + + K := Node.Key; + E := Node.Element; + + Node.Key := new Key_Type'(Key); + + 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 Position.Node = null then + raise Constraint_Error with + "Position cursor of Replace_Element equals No_Element"; + end if; + + if 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 Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor of Replace_Element designates wrong map"; + end if; + + if Position.Container.HT.Lock > 0 then + raise Program_Error with + "Replace_Element attempted to tamper with elements (map is locked)"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + + declare + X : Element_Access := Position.Node.Element; + + begin + Position.Node.Element := new Element_Type'(New_Item); + Free_Element (X); + end; + end Replace_Element; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Map; + Capacity : Count_Type) + is + begin + HT_Ops.Reserve_Capacity (Container.HT, Capacity); + end Reserve_Capacity; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (Node : Node_Access; Next : Node_Access) is + begin + Node.Next := Next; + end Set_Next; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Map; + Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)) + is + begin + if Position.Node = null then + raise Constraint_Error with + "Position cursor of Update_Element equals No_Element"; + end if; + + if 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 Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor of Update_Element designates wrong map"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Update_Element"); + + declare + HT : Hash_Table_Type renames Container.HT; + + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + + begin + B := B + 1; + L := L + 1; + + declare + K : Key_Type renames Position.Node.Key.all; + E : Element_Type renames Position.Node.Element.all; + + begin + Process (K, E); + + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; + end Update_Element; + + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = null then + return Position.Container = null; + end if; + + if Position.Container = null then + return False; + end if; + + if Position.Node.Next = Position.Node then + return False; + end if; + + if Position.Node.Key = null then + return False; + end if; + + if Position.Node.Element = null then + return False; + end if; + + declare + HT : Hash_Table_Type renames Position.Container.HT; + X : Node_Access; + + begin + if HT.Length = 0 then + return False; + end if; + + if HT.Buckets = null + or else HT.Buckets'Length = 0 + then + return False; + end if; + + X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key.all)); + + for J in 1 .. HT.Length loop + if X = Position.Node then + return True; + end if; + + if X = null then + return False; + end if; + + if X = X.Next then -- to prevent unnecessary looping + return False; + end if; + + X := X.Next; + end loop; + + return False; + end; + end Vet; + + ----------- + -- Write -- + ----------- + + procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node); + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Map) + is + begin + Write_Nodes (Stream, Container.HT); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream map cursor"; + end Write; + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access) + is + begin + Key_Type'Output (Stream, Node.Key.all); + Element_Type'Output (Stream, Node.Element.all); + end Write_Node; + +end Ada.Containers.Indefinite_Hashed_Maps; diff --git a/gcc/ada/a-cihama.ads b/gcc/ada/a-cihama.ads new file mode 100644 index 000000000..7b9e94e53 --- /dev/null +++ b/gcc/ada/a-cihama.ads @@ -0,0 +1,332 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_HASHED_MAPS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-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 -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +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.Indefinite_Hashed_Maps is + pragma Preelaborate; + pragma Remote_Types; + + type Map is tagged private; + 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. + + overriding function "=" (Left, Right : Map) return Boolean; + -- For each key/element pair in Left, equality attempts to find the key in + -- Right; if a search fails the equality returns False. The search works by + -- calling Hash to find the bucket in the Right map that corresponds to the + -- Left key. If bucket is non-empty, then equality calls Equivalent_Keys + -- to compare the key (in Left) to the key of each node in the bucket (in + -- Right); if the keys are equivalent, then the equality test for this + -- key/element pair (in Left) completes by calling the element equality + -- operator to compare the element (in Left) to the element of the node + -- (in Right) whose key matched. + + function Capacity (Container : Map) return Count_Type; + -- Returns the current capacity of the map. Capacity is the maximum length + -- before which rehashing in guaranteed not to occur. + + procedure Reserve_Capacity (Container : in out Map; Capacity : Count_Type); + -- Adjusts the current capacity, by allocating a new buckets array. If the + -- requested capacity is less than the current capacity, then the capacity + -- is contracted (to a value not less than the current length). If the + -- requested capacity is greater than the current capacity, then the + -- capacity is expanded (to a value not less than what is requested). In + -- either case, the nodes are rehashed from the old buckets array onto the + -- new buckets array (Hash is called once for each existing key in order to + -- compute the new index), and then the old buckets array is deallocated. + + function Length (Container : Map) return Count_Type; + -- Returns the number of items in the map + + function Is_Empty (Container : Map) return Boolean; + -- Equivalent to Length (Container) = 0 + + procedure Clear (Container : in out Map); + -- Removes all of the items from the map + + function Key (Position : Cursor) return Key_Type; + -- Returns the key of the node designated by the cursor + + function Element (Position : Cursor) return Element_Type; + -- Returns the element of the node designated by the cursor + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type); + -- Assigns the value New_Item to the element designated by the cursor + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : Element_Type)); + -- Calls Process with the key and element (both having only a constant + -- view) of the node designed by the cursor. + + procedure Update_Element + (Container : in out Map; + Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)); + -- Calls Process with the key (with only a constant view) and element (with + -- a variable view) of the node designed by the cursor. + + procedure Move (Target : in out Map; Source : in out Map); + -- Clears Target (if it's not empty), and then moves (not copies) the + -- buckets array and nodes from Source to Target. + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + -- Conditionally inserts New_Item into the map. If Key is already in the + -- map, then Inserted returns False and Position designates the node + -- containing the existing key/element pair (neither of which is modified). + -- If Key is not already in the map, the Inserted returns True and Position + -- designates the newly-inserted node container Key and New_Item. The + -- search for the key works as follows. Hash is called to determine Key's + -- bucket; if the bucket is non-empty, then Equivalent_Keys is called to + -- compare Key to each node in that bucket. If the bucket is empty, or + -- there were no matching keys in the bucket, the search "fails" and the + -- key/item pair is inserted in the map (and Inserted returns True); + -- otherwise, the search "succeeds" (and Inserted returns False). + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + -- Attempts to insert Key into the map, performing the usual search (which + -- involves calling both Hash and Equivalent_Keys); if the search succeeds + -- (because Key is already in the map), then it raises Constraint_Error. + -- (This version of Insert is similar to Replace, but having the opposite + -- exception behavior. It is intended for use when you want to assert that + -- Key is not already in the map.) + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + -- Attempts to insert Key into the map. If Key is already in the map, then + -- both the existing key and element are assigned the values of Key and + -- New_Item, respectively. (This version of Insert only raises an exception + -- if cursor tampering occurs. It is intended for use when you want to + -- insert the key/element pair in the map, and you don't care whether Key + -- is already present.) + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + -- Searches for Key in the map; if the search fails (because Key was not in + -- the map), then it raises Constraint_Error. Otherwise, both the existing + -- key and element are assigned the values of Key and New_Item rsp. (This + -- is similar to Insert, but with the opposite exception behavior. It is + -- intended for use when you want to assert that Key is already in the + -- map.) + + procedure Exclude (Container : in out Map; Key : Key_Type); + -- Searches for Key in the map, and if found, removes its node from the map + -- and then deallocates it. The search works as follows. The operation + -- calls Hash to determine the key's bucket; if the bucket is not empty, it + -- calls Equivalent_Keys to compare Key to each key in the bucket. (This is + -- the deletion analog of Include. It is intended for use when you want to + -- remove the item from the map, but don't care whether the key is already + -- in the map.) + + procedure Delete (Container : in out Map; Key : Key_Type); + -- Searches for Key in the map (which involves calling both Hash and + -- Equivalent_Keys). If the search fails, then the operation raises + -- Constraint_Error. Otherwise it removes the node from the map and then + -- deallocates it. (This is the deletion analog of non-conditional + -- Insert. It is intended for use when you want to assert that the item is + -- already in the map.) + + procedure Delete (Container : in out Map; Position : in out Cursor); + -- Removes the node designated by Position from the map, and then + -- deallocates the node. The operation calls Hash to determine the bucket, + -- and then compares Position to each node in the bucket until there's a + -- match (it does not call Equivalent_Keys). + + function First (Container : Map) return Cursor; + -- Returns a cursor that designates the first non-empty bucket, by + -- searching from the beginning of the buckets array. + + function Next (Position : Cursor) return Cursor; + -- Returns a cursor that designates the node that follows the current one + -- designated by Position. If Position designates the last node in its + -- bucket, the operation calls Hash to compute the index of this bucket, + -- and searches the buckets array for the first non-empty bucket, starting + -- from that index; otherwise, it simply follows the link to the next node + -- in the same bucket. + + procedure Next (Position : in out Cursor); + -- Equivalent to Position := Next (Position) + + function Find (Container : Map; Key : Key_Type) return Cursor; + -- Searches for Key in the map. Find calls Hash to determine the key's + -- bucket; if the bucket is not empty, it calls Equivalent_Keys to compare + -- Key to each key in the bucket. If the search succeeds, Find returns a + -- cursor designating the matching node; otherwise, it returns No_Element. + + function Contains (Container : Map; Key : Key_Type) return Boolean; + -- Equivalent to Find (Container, Key) /= No_Element + + function Element (Container : Map; Key : Key_Type) return Element_Type; + -- Equivalent to Element (Find (Container, Key)) + + function Has_Element (Position : Cursor) return Boolean; + -- Equivalent to Position /= No_Element + + 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 + +private + pragma Inline ("="); + pragma Inline (Length); + pragma Inline (Is_Empty); + pragma Inline (Clear); + pragma Inline (Key); + pragma Inline (Element); + pragma Inline (Move); + pragma Inline (Contains); + pragma Inline (Capacity); + pragma Inline (Reserve_Capacity); + pragma Inline (Has_Element); + pragma Inline (Equivalent_Keys); + pragma Inline (Next); + + type Node_Type; + type Node_Access is access Node_Type; + + type Key_Access is access Key_Type; + type Element_Access is access Element_Type; + + type Node_Type is limited record + Key : Key_Access; + Element : Element_Access; + Next : Node_Access; + end record; + + package HT_Types is + new Hash_Tables.Generic_Hash_Table_Types (Node_Type, Node_Access); + + type Map is new Ada.Finalization.Controlled with record + HT : HT_Types.Hash_Table_Type; + end record; + + use HT_Types; + use Ada.Finalization; + use Ada.Streams; + + overriding + procedure Adjust (Container : in out Map); + + overriding + procedure Finalize (Container : in out Map); + + type Map_Access is access constant 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; + + No_Element : constant Cursor := + (Container => null, + Node => null); + + 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; + + Empty_Map : constant Map := (Controlled with HT => (null, 0, 0, 0)); + +end Ada.Containers.Indefinite_Hashed_Maps; diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb new file mode 100644 index 000000000..0a42fb239 --- /dev/null +++ b/gcc/ada/a-cihase.adb @@ -0,0 +1,2022 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_HASHED_SETS -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +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.Prime_Numbers; + +with System; use type System.Address; + +package body Ada.Containers.Indefinite_Hashed_Sets is + + ----------------------- + -- 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 : 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; + begin + Node.Element := new Element_Type'(Item); + Free_Element (X); + 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; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Item : Element_Type) return Boolean is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + --------------- + -- 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 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 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; + + if Container.HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (set is busy)"; + end if; + + 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 + Tgt_Node : Node_Access; + + begin + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + if Source.HT.Length = 0 then + return; + end if; + + if Target.HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (set is busy)"; + end if; + + if Source.HT.Length < Target.HT.Length then + declare + Src_Node : Node_Access; + + begin + Src_Node := HT_Ops.First (Source.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 (Source.HT, Src_Node); + end loop; + end; + + else + Tgt_Node := HT_Ops.First (Target.HT); + while Tgt_Node /= null loop + if Is_In (Source.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 + 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 + Src : Element_Type renames L_Node.Element.all; + Indx : constant Hash_Type := Hash (Src) mod Buckets'Length; + Bucket : Node_Access renames Buckets (Indx); + 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, 0, 0)); + end Difference; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if Position.Node = null then + raise Constraint_Error with "Position cursor of equals No_Element"; + end if; + + if 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 Left.Node = null then + raise Constraint_Error with + "Left cursor of Equivalent_Elements equals No_Element"; + end if; + + if Right.Node = null then + raise Constraint_Error with + "Right cursor of Equivalent_Elements equals No_Element"; + end if; + + if Left.Node.Element = null then + raise Program_Error with + "Left cursor of Equivalent_Elements is bad"; + end if; + + if 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"); + + 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 Left.Node = null then + raise Constraint_Error with + "Left cursor of Equivalent_Elements equals No_Element"; + end if; + + if 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 Right.Node = null then + raise Constraint_Error with + "Right cursor of Equivalent_Elements equals No_Element"; + end if; + + if 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; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Set; + Item : Element_Type) return Cursor + is + Node : constant Node_Access := Element_Keys.Find (Container.HT, Item); + + begin + if Node = null then + return No_Element; + end if; + + return 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 + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + 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; + + ----------------- + -- 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 + if Container.HT.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + X := Position.Node.Element; + + Position.Node.Element := new Element_Type'(New_Item); + + 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 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 + 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 + Tgt_Node : Node_Access; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Source.Length = 0 then + Clear (Target); + return; + end if; + + if Target.HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (set is busy)"; + end if; + + Tgt_Node := HT_Ops.First (Target.HT); + while Tgt_Node /= null loop + if Is_In (Source.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 + 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 + Src : Element_Type renames L_Node.Element.all; + + Indx : constant Hash_Type := Hash (Src) mod Buckets'Length; + + Bucket : Node_Access renames Buckets (Indx); + + 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, 0, 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 : 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_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; + + B : Natural renames Container'Unrestricted_Access.HT.Busy; + + -- Start of processing for Iterate + + begin + B := B + 1; + + begin + Iterate (Container.HT); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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 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 + 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; + + ------------- + -- Overlap -- + ------------- + + function Overlap (Left, Right : Set) return Boolean is + 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; + + ------------------- + -- 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 of Query_Element equals No_Element"; + end if; + + if 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; + + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (Position.Node.Element.all); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + 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; + + --------------- + -- 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 Node = null then + raise Constraint_Error with + "attempt to replace element not in set"; + end if; + + if Container.HT.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + X := Node.Element; + + Node.Element := new Element_Type'(New_Item); + + Free_Element (X); + end Replace; + + --------------------- + -- 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 "bad cursor in Replace_Element"; + end if; + + if 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 + begin + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + if Target.HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (set is busy)"; + end if; + + 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; + + 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 Target.HT.Buckets.all; + J : constant Hash_Type := Hash (E) mod B'Length; + N : Count_Type renames Target.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; + + -- Start of processing for Iterate_Source_When_Empty_Target + + begin + Iterate (Source.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 Target.HT.Buckets.all; + J : constant Hash_Type := Hash (E) mod B'Length; + N : Count_Type renames Target.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; + + -- Start of processing for Iterate_Source + + begin + Iterate (Source.HT); + end Iterate_Source; + end if; + end Symmetric_Difference; + + function Symmetric_Difference (Left, Right : Set) return Set is + 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; + J : constant Hash_Type := Hash (E) mod Buckets'Length; + + 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; + J : constant Hash_Type := Hash (E) mod Buckets'Length; + + 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, 0, 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; + + if Target.HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (set is busy)"; + end if; + + 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 + 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; + + -- Start of processing for Process + + 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; + + -- 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, 0, 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.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; + + ---------------- + -- 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); + + -------------- + -- 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 X = null then + raise Constraint_Error with "key not in map"; + end if; + + Free (X); + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Container : Set; + Key : Key_Type) return Element_Type + is + Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); + + begin + if Node = null then + raise Constraint_Error with "key not in map"; + 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; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Set; + Key : Key_Type) return Cursor + is + Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Find; + + --------- + -- 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), "bad cursor in function 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.HT, Key); + + begin + if 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; + + 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 Position.Node = null then + raise Constraint_Error with + "Position cursor equals No_Element"; + end if; + + if Position.Node.Element = null + or else Position.Node.Next = Position.Node + 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; + + if 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"); + + Indx := HT_Ops.Index (HT, Position.Node); + + declare + E : Element_Type renames Position.Node.Element.all; + K : constant Key_Type := Key (E); + + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + + if Equivalent_Keys (K, Key (E)) then + pragma Assert (Hash (K) = Hash (E)); + 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 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; + + end Generic_Keys; + +end Ada.Containers.Indefinite_Hashed_Sets; diff --git a/gcc/ada/a-cihase.ads b/gcc/ada/a-cihase.ads new file mode 100644 index 000000000..a174c7d98 --- /dev/null +++ b/gcc/ada/a-cihase.ads @@ -0,0 +1,461 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_HASHED_SETS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-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 -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +private with Ada.Containers.Hash_Tables; +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 Preelaborate; + pragma Remote_Types; + + type Set is tagged private; + 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 "=" (Left, Right : Set) return Boolean; + -- For each element in Left, set equality attempts to find the equal + -- element in Right; if a search fails, then set equality immediately + -- returns False. The search works by calling Hash to find the bucket in + -- the Right set that corresponds to the Left element. If the bucket is + -- non-empty, the search calls the generic formal element equality operator + -- to compare the element (in Left) to the element of each node in the + -- bucket (in Right); the search terminates when a matching node in the + -- bucket is found, or the nodes in the bucket are exhausted. (Note that + -- element equality is called here, not Equivalent_Elements. Set equality + -- is the only operation in which element equality is used. Compare set + -- equality to Equivalent_Sets, which does call Equivalent_Elements.) + + function Equivalent_Sets (Left, Right : Set) return Boolean; + -- Similar to set equality, with the difference that the element in Left is + -- compared to the elements in Right using the generic formal + -- Equivalent_Elements operation instead of element equality. + + function To_Set (New_Item : Element_Type) return Set; + -- Constructs a singleton set comprising New_Element. To_Set calls Hash to + -- determine the bucket for New_Item. + + function Capacity (Container : Set) return Count_Type; + -- Returns the current capacity of the set. Capacity is the maximum length + -- before which rehashing in guaranteed not to occur. + + procedure Reserve_Capacity (Container : in out Set; Capacity : Count_Type); + -- Adjusts the current capacity, by allocating a new buckets array. If the + -- requested capacity is less than the current capacity, then the capacity + -- is contracted (to a value not less than the current length). If the + -- requested capacity is greater than the current capacity, then the + -- capacity is expanded (to a value not less than what is requested). In + -- either case, the nodes are rehashed from the old buckets array onto the + -- new buckets array (Hash is called once for each existing element in + -- order to compute the new index), and then the old buckets array is + -- deallocated. + + function Length (Container : Set) return Count_Type; + -- Returns the number of items in the set + + function Is_Empty (Container : Set) return Boolean; + -- Equivalent to Length (Container) = 0 + + procedure Clear (Container : in out Set); + -- Removes all of the items from the set + + function Element (Position : Cursor) return Element_Type; + -- Returns the element of the node designated by the cursor + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type); + -- If New_Item is equivalent (as determined by calling Equivalent_Elements) + -- to the element of the node designated by Position, then New_Element is + -- assigned to that element. Otherwise, it calls Hash to determine the + -- bucket for New_Item. If the bucket is not empty, then it calls + -- Equivalent_Elements for each node in that bucket to determine whether + -- New_Item is equivalent to an element in that bucket. If + -- Equivalent_Elements returns True then Program_Error is raised (because + -- an element may appear only once in the set); otherwise, New_Item is + -- assigned to the node designated by Position, and the node is moved to + -- its new bucket. + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + -- Calls Process with the element (having only a constant view) of the node + -- designed by the cursor. + + 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 Has_Element (Position : Cursor) return Boolean; + -- Equivalent to Position /= 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 + + 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. + + end Generic_Keys; + +private + + pragma Inline (Next); + + type Node_Type; + type Node_Access is access Node_Type; + + type Element_Access is access 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; + use Ada.Finalization; + use Ada.Streams; + + 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; + + No_Element : constant Cursor := (Container => null, Node => 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; + + Empty_Set : constant Set := (Controlled with HT => (null, 0, 0, 0)); + +end Ada.Containers.Indefinite_Hashed_Sets; diff --git a/gcc/ada/a-ciorma.adb b/gcc/ada/a-ciorma.adb new file mode 100644 index 000000000..9cfcd3f5a --- /dev/null +++ b/gcc/ada/a-ciorma.adb @@ -0,0 +1,1362 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +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); + +package body Ada.Containers.Indefinite_Ordered_Maps is + + ----------------------------- + -- Node Access Subprograms -- + ----------------------------- + + -- These subprograms provide a functional interface to access fields + -- of a node, and a procedural interface for modifying these values. + + function Color (Node : Node_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 Left.Node = null then + raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; + end if; + + if Right.Node = null then + raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; + end if; + + if Left.Node.Key = null then + raise Program_Error with "Left cursor in ""<"" is bad"; + end if; + + if 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 Left.Node = null then + raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; + end if; + + if 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 Right.Node = null then + raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; + end if; + + if 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 Left.Node = null then + raise Constraint_Error with "Left cursor of "">"" equals No_Element"; + end if; + + if Right.Node = null then + raise Constraint_Error with "Right cursor of "">"" equals No_Element"; + end if; + + if Left.Node.Key = null then + raise Program_Error with "Left cursor in ""<"" is bad"; + end if; + + if 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 Left.Node = null then + raise Constraint_Error with "Left cursor of "">"" equals No_Element"; + end if; + + if 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 Right.Node = null then + raise Constraint_Error with "Right cursor of "">"" equals No_Element"; + end if; + + if 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; + + ------------- + -- 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; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Map; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + --------------- + -- 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 Position.Node = null then + raise Constraint_Error with + "Position cursor of Delete equals No_Element"; + end if; + + if Position.Node.Key = null + or else Position.Node.Element = null + then + raise Program_Error with "Position cursor of Delete is bad"; + end if; + + if 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 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 Position.Node = null then + raise Constraint_Error with + "Position cursor of function Element equals No_Element"; + end if; + + if 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 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 + 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; + + ---------- + -- Find -- + ---------- + + function Find (Container : Map; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return 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; + end if; + + return Cursor'(Container'Unrestricted_Access, T.First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Map) return Element_Type is + T : Tree_Type renames Container.Tree; + + begin + if 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 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 + 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_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; + + ----------------- + -- 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 + if Container.Tree.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (map is locked)"; + end if; + + K := Position.Node.Key; + E := Position.Node.Element; + + Position.Node.Key := new Key_Type'(Key); + + 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; + + 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 + + Free (Node); -- Note that Free deallocates key and elem too + 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 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 + if L.Key.all < R.Key.all then + return False; + + elsif R.Key.all < L.Key.all then + return False; + + else + return L.Element.all = R.Element.all; + 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 + -- 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; + + B : Natural renames Container.Tree'Unrestricted_Access.all.Busy; + + -- Start of processing for Iterate + + begin + B := B + 1; + + begin + Local_Iterate (Container.Tree); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Iterate; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + if Position.Node = null then + raise Constraint_Error with + "Position cursor of function Key equals No_Element"; + end if; + + if 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 + if T.Last = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, T.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Map) return Element_Type is + T : Tree_Type renames Container.Tree; + + begin + if 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 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 + if Node = null 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; + + ------------ + -- 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 + 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; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : Element_Type)) + is + begin + if Position.Node = null then + raise Constraint_Error with + "Position cursor of Query_Element equals No_Element"; + end if; + + if 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; + + B : Natural renames T.Busy; + L : Natural renames T.Lock; + + begin + B := B + 1; + L := L + 1; + + declare + K : Key_Type renames Position.Node.Key.all; + E : Element_Type renames Position.Node.Element.all; + + begin + Process (K, E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + 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; + + ------------- + -- 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 Node = null then + raise Constraint_Error with "key not in map"; + end if; + + if Container.Tree.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (map is locked)"; + end if; + + K := Node.Key; + E := Node.Element; + + Node.Key := new Key_Type'(Key); + + 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 Position.Node = null then + raise Constraint_Error with + "Position cursor of Replace_Element equals No_Element"; + end if; + + if 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 Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor of Replace_Element designates wrong map"; + end if; + + if Container.Tree.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (map is locked)"; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "Position cursor of Replace_Element is bad"); + + declare + X : Element_Access := Position.Node.Element; + + 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; + + B : Natural renames Container.Tree'Unrestricted_Access.all.Busy; + + -- Start of processing for Reverse_Iterate + + begin + B := B + 1; + + begin + Local_Reverse_Iterate (Container.Tree); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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 Position.Node = null then + raise Constraint_Error with + "Position cursor of Update_Element equals No_Element"; + end if; + + if 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 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; + + B : Natural renames T.Busy; + L : Natural renames T.Lock; + + begin + B := B + 1; + L := L + 1; + + declare + K : Key_Type renames Position.Node.Key.all; + E : Element_Type renames Position.Node.Element.all; + + begin + Process (K, E); + + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + 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; + +end Ada.Containers.Indefinite_Ordered_Maps; diff --git a/gcc/ada/a-ciorma.ads b/gcc/ada/a-ciorma.ads new file mode 100644 index 000000000..1ef581554 --- /dev/null +++ b/gcc/ada/a-ciorma.ads @@ -0,0 +1,256 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-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 -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +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 Preelaborate; + pragma Remote_Types; + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + + type Map is tagged private; + pragma Preelaborable_Initialization (Map); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Map : constant Map; + + No_Element : constant Cursor; + + 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)); + + 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 Has_Element (Position : Cursor) 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)); + +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 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; + use Ada.Finalization; + use Ada.Streams; + + 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; + + No_Element : constant Cursor := Cursor'(null, null); + + 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; + + Empty_Map : constant Map := + (Controlled with Tree => (First => null, + Last => null, + Root => null, + Length => 0, + Busy => 0, + Lock => 0)); + +end Ada.Containers.Indefinite_Ordered_Maps; diff --git a/gcc/ada/a-ciormu.adb b/gcc/ada/a-ciormu.adb new file mode 100644 index 000000000..8c7055b2f --- /dev/null +++ b/gcc/ada/a-ciormu.adb @@ -0,0 +1,1861 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +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); + +package body Ada.Containers.Indefinite_Ordered_Multisets is + + ----------------------------- + -- Node Access Subprograms -- + ----------------------------- + + -- These subprograms provide a functional interface to access fields + -- of a node, and a procedural interface for modifying these values. + + function Color (Node : Node_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; + + ------------- + -- 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; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Item : Element_Type) return Boolean is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + --------------- + -- 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; + + ----------- + -- 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; + + ------------------- + -- 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; + B : Natural renames T.Busy; + + -- Start of processing for Iterate + + begin + B := B + 1; + + begin + Local_Iterate (T, Key); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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; + B : Natural renames T.Busy; + + -- Start of processing for Reverse_Iterate + + begin + B := B + 1; + + begin + Local_Reverse_Iterate (T, Key); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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); + + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + + 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 + 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; + B : Natural renames T.Busy; + + -- Start of processing for Iterate + + begin + B := B + 1; + + begin + Local_Iterate (T, Item); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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; + B : Natural renames T.Busy; + + -- Start of processing for Iterate + + begin + B := B + 1; + + begin + Local_Iterate (T); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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; + + ------------------ + -- 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; + + ------------- + -- 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; + + ------------------- + -- 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; + + B : Natural renames T.Busy; + L : Natural renames T.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (Position.Node.Element.all); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + 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; + + --------------------- + -- 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 + if Tree.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + declare + X : Element_Access := Node.Element; + 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 + 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; + B : Natural renames T.Busy; + + -- Start of processing for Reverse_Iterate + + begin + B := B + 1; + + begin + Local_Reverse_Iterate (T, Item); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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; + B : Natural renames T.Busy; + + -- Start of processing for Reverse_Iterate + + begin + B := B + 1; + + begin + Local_Reverse_Iterate (T); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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; + +end Ada.Containers.Indefinite_Ordered_Multisets; diff --git a/gcc/ada/a-ciormu.ads b/gcc/ada/a-ciormu.ads new file mode 100644 index 000000000..5636a3320 --- /dev/null +++ b/gcc/ada/a-ciormu.ads @@ -0,0 +1,493 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +-- 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; + +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 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; + 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 "=" (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. + + 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 Has_Element (Position : Cursor) return Boolean; + -- Equivalent to Position /= 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). + + 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; + use Ada.Finalization; + use Ada.Streams; + + 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; + + 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; + + Empty_Set : constant Set := + (Controlled with Tree => (First => null, + Last => null, + Root => null, + Length => 0, + Busy => 0, + Lock => 0)); + +end Ada.Containers.Indefinite_Ordered_Multisets; diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb new file mode 100644 index 000000000..7153c6dd2 --- /dev/null +++ b/gcc/ada/a-ciorse.adb @@ -0,0 +1,1761 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_ORDERED_SETS -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +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; + +package body Ada.Containers.Indefinite_Ordered_Sets is + + ----------------------- + -- 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 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 + + 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 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; + + ------------- + -- 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; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Item : Element_Type) return Boolean is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + --------------- + -- 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 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; + + procedure Delete (Container : in out Set; Item : Element_Type) is + X : Node_Access := + Element_Keys.Find (Container.Tree, Item); + + begin + if 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 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 + 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; + + ---------- + -- 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; + + ------------------- + -- 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.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_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 + X : Node_Access := Key_Keys.Find (Container.Tree, Key); + + begin + if 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 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; + + ---------- + -- 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; + + --------- + -- 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; + + ------------- + -- 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 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 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 Update_Element_Preserving_Key"); + + declare + E : Element_Type renames Position.Node.Element.all; + K : constant Key_Type := Key (E); + + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + + 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; + + end Generic_Keys; + + ----------------- + -- 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 + if Container.Tree.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + X := Position.Node.Element; + Position.Node.Element := new Element_Type'(New_Item); + 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_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 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 + 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.Tree'Unrestricted_Access.all; + B : Natural renames T.Busy; + + -- Start of processing for Iterate + + begin + B := B + 1; + + begin + Local_Iterate (T); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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; + + ------------------ + -- 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.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 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 + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + 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 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 + if Node = null 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 = 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; + + B : Natural renames T.Busy; + L : Natural renames T.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (Position.Node.Element.all); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + 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; + + ------------- + -- 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 Node = null then + raise Constraint_Error with "attempt to replace element not in set"; + end if; + + if Container.Tree.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + X := Node.Element; + Node.Element := new Element_Type'(New_Item); + Free_Element (X); + 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 + 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; + + X : Element_Access := Node.Element; + + -- Start of processing for Replace_Element + + begin + if Item < Node.Element.all + or else Node.Element.all < Item + then + null; + + else + if Tree.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + Node.Element := new Element_Type'(Item); + Free_Element (X); + + return; + end if; + + Hint := Element_Keys.Ceiling (Tree, Item); + + if Hint = null then + null; + + elsif Item < Hint.Element.all then + if Hint = Node then + if Tree.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + Node.Element := new Element_Type'(Item); + Free_Element (X); + + return; + end if; + + else + pragma Assert (not (Hint.Element.all < Item)); + raise Program_Error with "attempt to replace existing element"; + end if; + + 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 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; + 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; + B : Natural renames T.Busy; + + -- Start of processing for Reverse_Iterate + + begin + B := B + 1; + + begin + Local_Reverse_Iterate (T); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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; + +end Ada.Containers.Indefinite_Ordered_Sets; diff --git a/gcc/ada/a-ciorse.ads b/gcc/ada/a-ciorse.ads new file mode 100644 index 000000000..5e7335165 --- /dev/null +++ b/gcc/ada/a-ciorse.ads @@ -0,0 +1,320 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_ORDERED_SETS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-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 -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +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 Preelaborate; + pragma Remote_Types; + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean; + + type Set is tagged private; + pragma Preelaborable_Initialization (Set); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Set : constant Set; + + No_Element : constant Cursor; + + 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)); + + 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 Has_Element (Position : Cursor) 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)); + + 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)); + + 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; + use Ada.Finalization; + use Ada.Streams; + + 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; + + 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; + + Empty_Set : constant Set := + (Controlled with Tree => (First => null, + Last => null, + Root => null, + Length => 0, + Busy => 0, + Lock => 0)); + +end Ada.Containers.Indefinite_Ordered_Sets; diff --git a/gcc/ada/a-clrefi.adb b/gcc/ada/a-clrefi.adb new file mode 100644 index 000000000..938ea18fb --- /dev/null +++ b/gcc/ada/a-clrefi.adb @@ -0,0 +1,528 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C O M M A N D _ L I N E . R E S P O N S E _ F I L E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +with Ada.Unchecked_Deallocation; + +with System.OS_Lib; use System.OS_Lib; + +package body Ada.Command_Line.Response_File is + + type File_Rec; + type File_Ptr is access File_Rec; + type File_Rec is record + Name : String_Access; + Next : File_Ptr; + Prev : File_Ptr; + end record; + -- To build a stack of response file names + + procedure Free is new Ada.Unchecked_Deallocation (File_Rec, File_Ptr); + + type Argument_List_Access is access Argument_List; + procedure Free is new Ada.Unchecked_Deallocation + (Argument_List, Argument_List_Access); + -- Free only the allocated Argument_List, not allocated String components + + -------------------- + -- Arguments_From -- + -------------------- + + function Arguments_From + (Response_File_Name : String; + Recursive : Boolean := False; + Ignore_Non_Existing_Files : Boolean := False) + return Argument_List + is + First_File : File_Ptr := null; + Last_File : File_Ptr := null; + -- The stack of response files + + Arguments : Argument_List_Access := new Argument_List (1 .. 4); + Last_Arg : Natural := 0; + + procedure Add_Argument (Arg : String); + -- Add argument Arg to argument list Arguments, increasing Arguments + -- if necessary. + + procedure Recurse (File_Name : String); + -- Get the arguments from the file and call itself recursively if one of + -- the argument starts with character '@'. + + ------------------ + -- Add_Argument -- + ------------------ + + procedure Add_Argument (Arg : String) is + begin + if Last_Arg = Arguments'Last then + declare + New_Arguments : constant Argument_List_Access := + new Argument_List (1 .. Arguments'Last * 2); + begin + New_Arguments (Arguments'Range) := Arguments.all; + Arguments.all := (others => null); + Free (Arguments); + Arguments := New_Arguments; + end; + end if; + + Last_Arg := Last_Arg + 1; + Arguments (Last_Arg) := new String'(Arg); + end Add_Argument; + + ------------- + -- Recurse -- + ------------- + + procedure Recurse (File_Name : String) is + FD : File_Descriptor; + + Buffer_Size : constant := 1500; + Buffer : String (1 .. Buffer_Size); + + Buffer_Length : Natural; + + Buffer_Cursor : Natural; + + End_Of_File_Reached : Boolean; + + Line : String (1 .. Max_Line_Length + 1); + Last : Natural; + + First_Char : Positive; + -- Index of the first character of an argument in Line + + Last_Char : Natural; + -- Index of the last character of an argument in Line + + In_String : Boolean; + -- True when inside a quoted string + + Arg : Positive; + + function End_Of_File return Boolean; + -- True when the end of the response file has been reached + + procedure Get_Buffer; + -- Read one buffer from the response file + + procedure Get_Line; + -- Get one line from the response file + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File return Boolean is + begin + return End_Of_File_Reached and then Buffer_Cursor > Buffer_Length; + end End_Of_File; + + ---------------- + -- Get_Buffer -- + ---------------- + + procedure Get_Buffer is + begin + Buffer_Length := Read (FD, Buffer (1)'Address, Buffer'Length); + End_Of_File_Reached := Buffer_Length < Buffer'Length; + Buffer_Cursor := 1; + end Get_Buffer; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line is + Ch : Character; + + begin + Last := 0; + + if End_Of_File then + return; + end if; + + loop + Ch := Buffer (Buffer_Cursor); + + exit when Ch = ASCII.CR or else + Ch = ASCII.LF or else + Ch = ASCII.FF; + + Last := Last + 1; + Line (Last) := Ch; + + if Last = Line'Last then + return; + end if; + + Buffer_Cursor := Buffer_Cursor + 1; + + if Buffer_Cursor > Buffer_Length then + Get_Buffer; + + if End_Of_File then + return; + end if; + end if; + end loop; + + loop + Ch := Buffer (Buffer_Cursor); + + exit when Ch /= ASCII.HT and then + Ch /= ASCII.LF and then + Ch /= ASCII.FF; + + Buffer_Cursor := Buffer_Cursor + 1; + + if Buffer_Cursor > Buffer_Length then + Get_Buffer; + + if End_Of_File then + return; + end if; + end if; + end loop; + end Get_Line; + + -- Start or Recurse + + begin + Last_Arg := 0; + + -- Open the response file. If not found, fail or report a warning, + -- depending on the value of Ignore_Non_Existing_Files. + + FD := Open_Read (File_Name, Text); + + if FD = Invalid_FD then + if Ignore_Non_Existing_Files then + return; + else + raise File_Does_Not_Exist; + end if; + end if; + + -- Put the response file name on the stack + + if First_File = null then + First_File := + new File_Rec' + (Name => new String'(File_Name), + Next => null, + Prev => null); + Last_File := First_File; + + else + declare + Current : File_Ptr := First_File; + + begin + loop + if Current.Name.all = File_Name then + raise Circularity_Detected; + end if; + + Current := Current.Next; + exit when Current = null; + end loop; + + Last_File.Next := + new File_Rec' + (Name => new String'(File_Name), + Next => null, + Prev => Last_File); + Last_File := Last_File.Next; + end; + end if; + + End_Of_File_Reached := False; + Get_Buffer; + + -- Read the response file line by line + + Line_Loop : + while not End_Of_File loop + Get_Line; + + if Last = Line'Last then + raise Line_Too_Long; + end if; + + First_Char := 1; + + -- Get each argument on the line + + Arg_Loop : + loop + -- First, skip any white space + + while First_Char <= Last loop + exit when Line (First_Char) /= ' ' and then + Line (First_Char) /= ASCII.HT; + First_Char := First_Char + 1; + end loop; + + exit Arg_Loop when First_Char > Last; + + Last_Char := First_Char; + In_String := False; + + -- Get the character one by one + + Character_Loop : + while Last_Char <= Last loop + + -- Inside a string, check only for '"' + + if In_String then + if Line (Last_Char) = '"' then + + -- Remove the '"' + + Line (Last_Char .. Last - 1) := + Line (Last_Char + 1 .. Last); + Last := Last - 1; + + -- End of string is end of argument + + if Last_Char > Last or else + Line (Last_Char) = ' ' or else + Line (Last_Char) = ASCII.HT + then + In_String := False; + + Last_Char := Last_Char - 1; + exit Character_Loop; + + else + -- If there are two consecutive '"', the quoted + -- string is not closed + + In_String := Line (Last_Char) = '"'; + + if In_String then + Last_Char := Last_Char + 1; + end if; + end if; + + else + Last_Char := Last_Char + 1; + end if; + + elsif Last_Char = Last then + + -- An opening '"' at the end of the line is an error + + if Line (Last) = '"' then + raise No_Closing_Quote; + + else + -- The argument ends with the line + + exit Character_Loop; + end if; + + elsif Line (Last_Char) = '"' then + + -- Entering a quoted string: remove the '"' + + In_String := True; + Line (Last_Char .. Last - 1) := + Line (Last_Char + 1 .. Last); + Last := Last - 1; + + else + -- Outside quoted strings, white space ends the argument + + exit Character_Loop + when Line (Last_Char + 1) = ' ' or else + Line (Last_Char + 1) = ASCII.HT; + + Last_Char := Last_Char + 1; + end if; + end loop Character_Loop; + + -- It is an error to not close a quoted string before the end + -- of the line. + + if In_String then + raise No_Closing_Quote; + end if; + + -- Add the argument to the list + + declare + Arg : String (1 .. Last_Char - First_Char + 1); + begin + Arg := Line (First_Char .. Last_Char); + Add_Argument (Arg); + end; + + -- Next argument, if line is not finished + + First_Char := Last_Char + 1; + end loop Arg_Loop; + end loop Line_Loop; + + Close (FD); + + -- If Recursive is True, check for any argument starting with '@' + + if Recursive then + Arg := 1; + while Arg <= Last_Arg loop + + if Arguments (Arg)'Length > 0 and then + Arguments (Arg) (1) = '@' + then + -- Ignore argument "@" with no file name + + if Arguments (Arg)'Length = 1 then + Arguments (Arg .. Last_Arg - 1) := + Arguments (Arg + 1 .. Last_Arg); + Last_Arg := Last_Arg - 1; + + else + -- Save the current arguments and get those in the new + -- response file. + + declare + Inc_File_Name : constant String := + Arguments (Arg) + (2 .. Arguments (Arg)'Last); + Current_Arguments : constant Argument_List := + Arguments (1 .. Last_Arg); + begin + Recurse (Inc_File_Name); + + -- Insert the new arguments where the new response + -- file was imported. + + declare + New_Arguments : constant Argument_List := + Arguments (1 .. Last_Arg); + New_Last_Arg : constant Positive := + Current_Arguments'Length + + New_Arguments'Length - 1; + + begin + -- Grow Arguments if it is not large enough + + if Arguments'Last < New_Last_Arg then + Last_Arg := Arguments'Last; + Free (Arguments); + + while Last_Arg < New_Last_Arg loop + Last_Arg := Last_Arg * 2; + end loop; + + Arguments := new Argument_List (1 .. Last_Arg); + end if; + + Last_Arg := New_Last_Arg; + + Arguments (1 .. Last_Arg) := + Current_Arguments (1 .. Arg - 1) & + New_Arguments & + Current_Arguments + (Arg + 1 .. Current_Arguments'Last); + + Arg := Arg + New_Arguments'Length; + end; + end; + end if; + + else + Arg := Arg + 1; + end if; + end loop; + end if; + + -- Remove the response file name from the stack + + if First_File = Last_File then + System.Strings.Free (First_File.Name); + Free (First_File); + First_File := null; + Last_File := null; + + else + System.Strings.Free (Last_File.Name); + Last_File := Last_File.Prev; + Free (Last_File.Next); + end if; + + exception + when others => + Close (FD); + + raise; + end Recurse; + + -- Start of Arguments_From + + begin + -- The job is done by procedure Recurse + + Recurse (Response_File_Name); + + -- Free Arguments before returning the result + + declare + Result : constant Argument_List := Arguments (1 .. Last_Arg); + begin + Free (Arguments); + return Result; + end; + + exception + when others => + + -- When an exception occurs, deallocate everything + + Free (Arguments); + + while First_File /= null loop + Last_File := First_File.Next; + System.Strings.Free (First_File.Name); + Free (First_File); + First_File := Last_File; + end loop; + + raise; + end Arguments_From; + +end Ada.Command_Line.Response_File; diff --git a/gcc/ada/a-clrefi.ads b/gcc/ada/a-clrefi.ads new file mode 100644 index 000000000..fdefafccc --- /dev/null +++ b/gcc/ada/a-clrefi.ads @@ -0,0 +1,100 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C O M M A N D _ L I N E . R E S P O N S E _ F I L E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 getting command line arguments +-- from a text file, called a "response file". +-- +-- Using a response file allow passing a set of arguments to an executable +-- longer than the maximum allowed by the system on the command line. + +pragma Compiler_Unit; + +with System.Strings; + +package Ada.Command_Line.Response_File is + + subtype String_Access is System.Strings.String_Access; + -- type String_Access is access all String; + + procedure Free (S : in out String_Access) renames System.Strings.Free; + -- To deallocate a String + + subtype Argument_List is System.Strings.String_List; + -- type String_List is array (Positive range <>) of String_Access; + + Max_Line_Length : constant := 4096; + -- The maximum length of lines in a response file + + File_Does_Not_Exist : exception; + -- Raise by Arguments_From when a response file cannot be found + + Line_Too_Long : exception; + -- Raise by Arguments_From when a line in the response file is longer than + -- Max_Line_Length. + + No_Closing_Quote : exception; + -- Raise by Arguments_From when a quoted string does not end before the + -- end of the line. + + Circularity_Detected : exception; + -- Raise by Arguments_From when Recursive is True and the same response + -- file is reading itself, either directly or indirectly. + + function Arguments_From + (Response_File_Name : String; + Recursive : Boolean := False; + Ignore_Non_Existing_Files : Boolean := False) + return Argument_List; + -- Read response file with name Response_File_Name and return the argument + -- it contains as an Argument_List. It is the responsibility of the caller + -- to deallocate the strings in the Argument_List if desired. When + -- Recursive is True, any argument of the form @file_name indicates the + -- name of another response file and is replaced by the arguments in this + -- response file. + -- + -- Each non empty line of the response file contains one or several + -- arguments separated by white space. Empty lines or lines containing only + -- white space are ignored. Arguments containing white space or a double + -- quote ('"')must be quoted. A double quote inside a quote string is + -- indicated by two consecutive double quotes. Example: "-Idir with quote + -- "" and spaces" Non white space characters immediately before or after a + -- quoted string are part of the same argument. Example -Idir" with "spaces + -- + -- When a response file cannot be found, exception File_Does_Not_Exist is + -- raised if Ignore_Non_Existing_Files is False, otherwise the response + -- file is ignored. Exception Line_Too_Long is raised when a line of a + -- response file is longer than Max_Line_Length. Exception No_Closing_Quote + -- is raised when a quoted argument is not closed before the end of the + -- line. Exception Circularity_Detected is raised when a Recursive is True + -- and a response file is reading itself, either directly or indirectly. + +end Ada.Command_Line.Response_File; diff --git a/gcc/ada/a-cobove.adb b/gcc/ada/a-cobove.adb new file mode 100644 index 000000000..759bab445 --- /dev/null +++ b/gcc/ada/a-cobove.adb @@ -0,0 +1,2439 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Generic_Array_Sort; +with System; use type System.Address; + +package body Ada.Containers.Bounded_Vectors is + + ----------------------- + -- 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 LN > Count_Type'Last - RN then + raise Constraint_Error with "new length is out of range"; + end if; + + -- It is now safe 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 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 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 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 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 LN = Count_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; + + if 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 RN = Count_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; + + if 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 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'Address = Right'Address then + return True; + end if; + + if Left.Last /= Right.Last then + return False; + end if; + + for J in Count_Type range 1 .. Left.Length loop + if Left.Elements (J) /= Right.Elements (J) then + return False; + end if; + end loop; + + return True; + end "="; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Vector; Source : Vector) is + begin + if Target'Address = Source'Address then + return; + end if; + + if 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 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 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 + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + Container.Last := No_Index; + end Clear; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Vector; + Item : Element_Type) return Boolean + is + begin + return Find_Index (Container, Item) /= No_Index; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Vector; + Capacity : Count_Type := 0) return Vector + is + C : Count_Type; + + begin + if Capacity = 0 then + C := Source.Length; + + elsif Capacity >= Source.Length then + C := Capacity; + + else + 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 Index < Index_Type'First then + raise Constraint_Error with "Index is out of range (too small)"; + end if; + + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows the + -- corner case of deleting no items from the back end of the vector to + -- be treated as a no-op. (It is assumed that specifying an index value + -- greater than Last + 1 indicates some deeper flaw in the caller's + -- algorithm, so that case is treated as a proper error.) + + if Index > Old_Last then + if Index > Old_Last + 1 then + raise Constraint_Error with "Index is out of range (too large)"; + end if; + + return; + end if; + + -- 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. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + -- We first calculate what's available for deletion starting at + -- Index. Here and elsewhere we use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate values. (See function + -- Length for more information.) + + if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then + Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; + + else + Count2 := Count_Type'Base (Old_Last - Index + 1); + end if; + + -- If more elements are requested (Count) for deletion than are + -- available (Count2) for deletion beginning at Index, then everything + -- from Index is deleted. There are no elements to slide down, and so + -- all we need to do is set the value of Container.Last. + + if Count >= Count2 then + Container.Last := Index - 1; + return; + end if; + + -- There are some elements aren't being deleted (the requested count was + -- less than the available count), so we must slide them down to + -- Index. We first calculate the index values of the respective array + -- slices, using the wider of Index_Type'Base and Count_Type'Base as the + -- type for intermediate calculations. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Off := Count_Type'Base (Index - Index_Type'First); + New_Last := Old_Last - Index_Type'Base (Count); + + else + Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First); + New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); + end if; + + -- The array index values for each slice have already been determined, + -- so we just slide down to Index the elements that weren't deleted. + + declare + EA : 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 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 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; + end if; + + if Count >= Length (Container) then + Clear (Container); + return; + end if; + + Delete (Container, Index_Type'First, Count); + 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. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + -- There is no restriction on how large Count can be when deleting + -- items. If it is equal or greater than the current length, then this + -- is equivalent to clearing the vector. (In particular, there's no need + -- for us to actually calculate the new value for Last.) + + -- If the requested count is less than the current length, then we must + -- calculate the new value for Last. For the type we use the widest of + -- Index_Type'Base and Count_Type'Base for the intermediate values of + -- our calculation. (See the comments in Length for more information.) + + if Count >= 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 Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + return Container.Elements (To_Array_Index (Index)); + end Element; + + function Element (Position : Cursor) return Element_Type is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + return Position.Container.Element (Position.Index); + end Element; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + begin + if 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; + + for J in Position.Index .. Container.Last loop + if Container.Elements (To_Array_Index (J)) = Item then + return (Container'Unrestricted_Access, J); + end if; + end loop; + + return No_Element; + end Find; + + ---------------- + -- Find_Index -- + ---------------- + + function Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'First) return Extended_Index + is + 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; + end if; + + return (Container'Unrestricted_Access, Index_Type'First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Vector) return Element_Type is + begin + if 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; + + declare + 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; + end; + + return True; + end Is_Sorted; + + ----------- + -- Merge -- + ----------- + + procedure Merge (Target, Source : in out Vector) is + I, J : Count_Type; + + begin + if Target.Is_Empty then + Target.Assign (Source); + return; + end if; + + if Target'Address = Source'Address then + return; + end if; + + if Source.Is_Empty then + return; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + I := Target.Length; + Target.Set_Length (I + Source.Length); + + declare + TA : Elements_Array renames Target.Elements; + SA : Elements_Array renames Source.Elements; + + 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; + return; + 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; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is locked)"; + end if; + + Sort (Container.Elements (1 .. Container.Length)); + end Sort; + + end Generic_Sorting; + + ----------------- + -- 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 Before < Index_Type'First then + raise Constraint_Error with + "Before index is out of range (too small)"; + end if; + + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for the + -- case of appending items to the back end of the vector. (It is assumed + -- that specifying an index value greater than Last + 1 indicates some + -- deeper flaw in the caller's algorithm, so that case is treated as a + -- proper error.) + + if Before > Container.Last + and then Before > 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 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). + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + elsif Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is less + -- than 0, so it is safe to compute the following sum without fear of + -- overflow. + + J := Count_Type'Base (No_Index) + Count_Type'Last; + + if J <= Count_Type'Base (Index_Type'Last) then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the maximum + -- number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- 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. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + if 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 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 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 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 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 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 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 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 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 Before < Index_Type'First then + raise Constraint_Error with + "Before index is out of range (too small)"; + end if; + + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for the + -- case of appending items to the back end of the vector. (It is assumed + -- that specifying an index value greater than Last + 1 indicates some + -- deeper flaw in the caller's algorithm, so that case is treated as a + -- proper error.) + + if Before > Container.Last + and then Before > 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 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). + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + elsif Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is less + -- than 0, so it is safe to compute the following sum without fear of + -- overflow. + + J := Count_Type'Base (No_Index) + Count_Type'Last; + + if J <= Count_Type'Base (Index_Type'Last) then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the maximum + -- number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- 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. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + -- An internal array has already been allocated, so we need to check + -- whether there is enough unused storage for the new items. + + if 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 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 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 + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; + + begin + B := B + 1; + + begin + for Indx in Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unrestricted_Access, Indx)); + end loop; + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Vector) return Element_Type is + begin + if 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 Target.Capacity < Source.Length then + raise Capacity_Error -- ??? + with "Target capacity is less than Source length"; + end if; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (Target is busy)"; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (Source is busy)"; + end if; + + -- 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; + end if; + + if Position.Index < Position.Container.Last then + return (Position.Container, Position.Index + 1); + end if; + + return No_Element; + end Next; + + ---------- + -- Next -- + ---------- + + procedure Next (Position : in out Cursor) is + begin + if Position.Container = null then + return; + end if; + + if 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; + end if; + + if 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; + end if; + + if Position.Index > Index_Type'First then + return (Position.Container, Position.Index - 1); + end if; + + return No_Element; + end Previous; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Container : Vector; + Index : Index_Type; + Process : not null access procedure (Element : Element_Type)) + is + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; + L : Natural renames V.Lock; + + begin + if Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + B := B + 1; + L := L + 1; + + begin + Process (V.Elements (To_Array_Index (Index))); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end Query_Element; + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if 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; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Vector; + Index : Index_Type; + New_Item : Element_Type) + is + begin + if Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is locked)"; + end if; + + 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 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; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is locked)"; + end if; + + 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 Capacity > Container.Capacity then + raise Constraint_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, Jdx : Count_Type; + + begin + if Container.Length <= 1 then + return; + end if; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is locked)"; + end if; + + 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 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); + + for Indx in reverse Index_Type'First .. Last loop + if Container.Elements (To_Array_Index (Indx)) = Item then + return (Container'Unrestricted_Access, Indx); + end if; + end loop; + + return No_Element; + 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 + 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 + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; + + begin + B := B + 1; + + begin + for Indx in reverse Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unrestricted_Access, Indx)); + end loop; + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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 then 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 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 I > Container.Last then + raise Constraint_Error with "I index is out of range"; + end if; + + if J > Container.Last then + raise Constraint_Error with "J index is out of range"; + end if; + + if I = J then + return; + end if; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is locked)"; + end if; + + 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 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; + + 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 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 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 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 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 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 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 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 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 + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; + + begin + if Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + B := B + 1; + L := L + 1; + + begin + Process (Container.Elements (To_Array_Index (Index))); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + 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 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; + + 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; + +end Ada.Containers.Bounded_Vectors; diff --git a/gcc/ada/a-cobove.ads b/gcc/ada/a-cobove.ads new file mode 100644 index 000000000..30dc9aabf --- /dev/null +++ b/gcc/ada/a-cobove.ads @@ -0,0 +1,369 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +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.Bounded_Vectors is + 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; + pragma Preelaborable_Initialization (Vector); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Vector : constant Vector; + + No_Element : constant Cursor; + + 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)); + + 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; + + function Has_Element (Position : Cursor) 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)); + + 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); + + type Elements_Array is array (Count_Type range <>) of Element_Type; + function "=" (L, R : Elements_Array) return Boolean is abstract; + + type Vector (Capacity : Count_Type) is tagged record + Elements : Elements_Array (1 .. Capacity); + Last : Extended_Index := No_Index; + Busy : Natural := 0; + Lock : Natural := 0; + end record; + + use Ada.Streams; + + 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; + + Empty_Vector : constant Vector := (Capacity => 0, others => <>); + + No_Element : constant Cursor := Cursor'(null, Index_Type'First); + +end Ada.Containers.Bounded_Vectors; diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb new file mode 100644 index 000000000..652472419 --- /dev/null +++ b/gcc/ada/a-cohama.adb @@ -0,0 +1,955 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . H A S H E D _ M A P S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-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. -- +------------------------------------------------------------------------------ + +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); + +package body Ada.Containers.Hashed_Maps is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Copy_Node + (Source : Node_Access) return Node_Access; + pragma Inline (Copy_Node); + + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Access) return Boolean; + pragma Inline (Equivalent_Key_Node); + + procedure Free (X : in out Node_Access); + + function Find_Equal_Key + (R_HT : Hash_Table_Type; + L_Node : Node_Access) return Boolean; + + function Hash_Node (Node : Node_Access) return Hash_Type; + pragma Inline (Hash_Node); + + function Next (Node : Node_Access) return Node_Access; + pragma Inline (Next); + + function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Node_Access; + pragma Inline (Read_Node); + + procedure Set_Next (Node : Node_Access; Next : Node_Access); + pragma Inline (Set_Next); + + function Vet (Position : Cursor) return Boolean; + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access); + pragma Inline (Write_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package HT_Ops is new Hash_Tables.Generic_Operations + (HT_Types => HT_Types, + Hash_Node => Hash_Node, + Next => Next, + Set_Next => Set_Next, + Copy_Node => Copy_Node, + Free => Free); + + package Key_Ops is new Hash_Tables.Generic_Keys + (HT_Types => HT_Types, + Next => Next, + Set_Next => Set_Next, + Key_Type => Key_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Key_Node); + + function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key); + + procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node); + procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Map) return Boolean is + begin + return Is_Equal (Left.HT, Right.HT); + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Map) is + begin + HT_Ops.Adjust (Container.HT); + end Adjust; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Map) return Count_Type is + begin + return HT_Ops.Capacity (Container.HT); + end Capacity; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Map) is + begin + HT_Ops.Clear (Container.HT); + end Clear; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Map; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + --------------- + -- Copy_Node -- + --------------- + + function Copy_Node + (Source : Node_Access) return Node_Access + is + Target : constant Node_Access := + new Node_Type'(Key => Source.Key, + Element => Source.Element, + Next => null); + begin + return Target; + end Copy_Node; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Map; Key : Key_Type) is + X : Node_Access; + + begin + Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); + + if X = null then + raise Constraint_Error with "attempt to delete key not in map"; + end if; + + Free (X); + end Delete; + + procedure Delete (Container : in out Map; Position : in out Cursor) is + begin + if Position.Node = null then + raise Constraint_Error with + "Position cursor of Delete equals No_Element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor of Delete designates wrong map"; + end if; + + if Container.HT.Busy > 0 then + raise Program_Error with + "Delete attempted to tamper with cursors (map is busy)"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Delete"); + + HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node); + + Free (Position.Node); + Position.Container := null; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element (Container : Map; Key : Key_Type) return Element_Type is + Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); + + begin + if Node = null then + raise Constraint_Error with + "no element available because key not in map"; + end if; + + return Node.Element; + end Element; + + function Element (Position : Cursor) return Element_Type is + begin + if Position.Node = null then + raise Constraint_Error with + "Position cursor of function Element equals No_Element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Element"); + + return Position.Node.Element; + end Element; + + ------------------------- + -- Equivalent_Key_Node -- + ------------------------- + + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Access) return Boolean is + begin + return Equivalent_Keys (Key, Node.Key); + end Equivalent_Key_Node; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Left, Right : Cursor) + return Boolean is + begin + if Left.Node = null then + raise Constraint_Error with + "Left cursor of Equivalent_Keys equals No_Element"; + end if; + + if Right.Node = null then + raise Constraint_Error with + "Right cursor of Equivalent_Keys equals No_Element"; + end if; + + pragma Assert (Vet (Left), "Left cursor of Equivalent_Keys is bad"); + pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad"); + + return Equivalent_Keys (Left.Node.Key, Right.Node.Key); + end Equivalent_Keys; + + function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is + begin + if Left.Node = null then + raise Constraint_Error with + "Left cursor of Equivalent_Keys equals No_Element"; + end if; + + pragma Assert (Vet (Left), "Left cursor in Equivalent_Keys is bad"); + + return Equivalent_Keys (Left.Node.Key, Right); + end Equivalent_Keys; + + function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is + begin + if Right.Node = null then + raise Constraint_Error with + "Right cursor of Equivalent_Keys equals No_Element"; + end if; + + pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad"); + + return Equivalent_Keys (Left, Right.Node.Key); + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Map; Key : Key_Type) is + X : Node_Access; + begin + Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); + Free (X); + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Container : in out Map) is + begin + HT_Ops.Finalize (Container.HT); + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find (Container : Map; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_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 := Key_Ops.Index (R_HT, L_Node.Key); + R_Node : Node_Access := R_HT.Buckets (R_Index); + + begin + while R_Node /= null loop + if Equivalent_Keys (L_Node.Key, R_Node.Key) then + return L_Node.Element = R_Node.Element; + end if; + + R_Node := R_Node.Next; + end loop; + + return False; + end Find_Equal_Key; + + ----------- + -- First -- + ----------- + + function First (Container : Map) return Cursor is + Node : constant Node_Access := HT_Ops.First (Container.HT); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end First; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + begin + if X /= null then + X.Next := X; -- detect mischief (in Vet) + Deallocate (X); + end if; + end Free; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + pragma Assert (Vet (Position), "bad cursor in Has_Element"); + return Position.Node /= null; + end Has_Element; + + --------------- + -- Hash_Node -- + --------------- + + function Hash_Node (Node : Node_Access) return Hash_Type is + begin + return Hash (Node.Key); + end Hash_Node; + + ------------- + -- Include -- + ------------- + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + if Container.HT.Lock > 0 then + raise Program_Error with + "Include attempted to tamper with elements (map is locked)"; + end if; + + Position.Node.Key := Key; + Position.Node.Element := New_Item; + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Map; + Key : Key_Type; + Position : out Cursor; + Inserted : out Boolean) + is + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); + + procedure Local_Insert is + new Key_Ops.Generic_Conditional_Insert (New_Node); + + -------------- + -- New_Node -- + -------------- + + function New_Node (Next : Node_Access) return Node_Access is + begin + return new Node_Type'(Key => Key, + Element => <>, + Next => Next); + end New_Node; + + HT : Hash_Table_Type renames Container.HT; + + -- Start of processing for Insert + + begin + if HT_Ops.Capacity (HT) = 0 then + HT_Ops.Reserve_Capacity (HT, 1); + end if; + + Local_Insert (HT, Key, Position.Node, Inserted); + + if Inserted + and then HT.Length > HT_Ops.Capacity (HT) + then + HT_Ops.Reserve_Capacity (HT, HT.Length); + end if; + + Position.Container := Container'Unchecked_Access; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); + + procedure Local_Insert is + new Key_Ops.Generic_Conditional_Insert (New_Node); + + -------------- + -- New_Node -- + -------------- + + function New_Node (Next : Node_Access) return Node_Access is + begin + return new Node_Type'(Key, New_Item, Next); + end New_Node; + + HT : Hash_Table_Type renames Container.HT; + + -- Start of processing for Insert + + begin + if HT_Ops.Capacity (HT) = 0 then + HT_Ops.Reserve_Capacity (HT, 1); + end if; + + Local_Insert (HT, Key, Position.Node, Inserted); + + if Inserted + and then HT.Length > HT_Ops.Capacity (HT) + then + HT_Ops.Reserve_Capacity (HT, HT.Length); + end if; + + Position.Container := Container'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 not Inserted then + raise Constraint_Error with + "attempt to insert key already in map"; + end if; + end Insert; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Map) return Boolean is + begin + return Container.HT.Length = 0; + end Is_Empty; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + B : Natural renames Container'Unrestricted_Access.HT.Busy; + + -- Start of processing for Iterate + + begin + B := B + 1; + + begin + Local_Iterate (Container.HT); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Iterate; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + if Position.Node = null then + raise Constraint_Error with + "Position cursor of function Key equals No_Element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Key"); + + return Position.Node.Key; + end Key; + + ------------ + -- Length -- + ------------ + + function Length (Container : Map) return Count_Type is + begin + return Container.HT.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move + (Target : in out Map; + Source : in out Map) + is + begin + HT_Ops.Move (Target => Target.HT, Source => Source.HT); + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Node : Node_Access) return Node_Access is + begin + return Node.Next; + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position.Node = null then + return No_Element; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Next"); + + declare + HT : Hash_Table_Type renames Position.Container.HT; + Node : constant Node_Access := HT_Ops.Next (HT, 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; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : Element_Type)) + is + begin + if Position.Node = null then + raise Constraint_Error with + "Position cursor of Query_Element equals No_Element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Query_Element"); + + declare + M : Map renames Position.Container.all; + HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + + begin + B := B + 1; + L := L + 1; + + declare + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; + + begin + Process (K, E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Map) + is + begin + Read_Nodes (Stream, Container.HT); + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream map cursor"; + end Read; + + --------------- + -- Read_Node -- + --------------- + + function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Node_Access + is + Node : Node_Access := new Node_Type; + + begin + Key_Type'Read (Stream, Node.Key); + Element_Type'Read (Stream, Node.Element); + return Node; + + exception + when others => + Free (Node); + raise; + end Read_Node; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); + + begin + if Node = null then + raise Constraint_Error with + "attempt to replace key not in map"; + end if; + + if Container.HT.Lock > 0 then + raise Program_Error with + "Replace attempted to tamper with elements (map is locked)"; + end if; + + 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 Position.Node = null then + raise Constraint_Error with + "Position cursor of Replace_Element equals No_Element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor of Replace_Element designates wrong map"; + end if; + + if Position.Container.HT.Lock > 0 then + raise Program_Error with + "Replace_Element attempted to tamper with elements (map is locked)"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + + Position.Node.Element := New_Item; + end Replace_Element; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Map; + Capacity : Count_Type) + is + begin + HT_Ops.Reserve_Capacity (Container.HT, Capacity); + end Reserve_Capacity; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (Node : Node_Access; Next : Node_Access) is + begin + Node.Next := Next; + end Set_Next; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Map; + Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)) + is + begin + if Position.Node = null then + raise Constraint_Error with + "Position cursor of Update_Element equals No_Element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor of Update_Element designates wrong map"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Update_Element"); + + declare + HT : Hash_Table_Type renames Container.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + + begin + B := B + 1; + L := L + 1; + + declare + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; + + begin + Process (K, E); + + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; + end Update_Element; + + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = null then + return Position.Container = null; + end if; + + if Position.Container = null then + return False; + end if; + + if Position.Node.Next = Position.Node then + return False; + end if; + + declare + HT : Hash_Table_Type renames Position.Container.HT; + X : Node_Access; + + begin + if HT.Length = 0 then + return False; + end if; + + if HT.Buckets = null + or else HT.Buckets'Length = 0 + then + return False; + end if; + + X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key)); + + for J in 1 .. HT.Length loop + if X = Position.Node then + return True; + end if; + + if X = null then + return False; + end if; + + if X = X.Next then -- to prevent unnecessary looping + return False; + end if; + + X := X.Next; + end loop; + + return False; + end; + end Vet; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Map) + is + begin + Write_Nodes (Stream, Container.HT); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream map cursor"; + end Write; + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access) + is + begin + Key_Type'Write (Stream, Node.Key); + Element_Type'Write (Stream, Node.Element); + end Write_Node; + +end Ada.Containers.Hashed_Maps; diff --git a/gcc/ada/a-cohama.ads b/gcc/ada/a-cohama.ads new file mode 100644 index 000000000..4c1010e38 --- /dev/null +++ b/gcc/ada/a-cohama.ads @@ -0,0 +1,336 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . H A S H E D _ M A P S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-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 -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +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.Hashed_Maps is + pragma Preelaborate; + pragma Remote_Types; + + type Map is tagged private; + 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 "=" (Left, Right : Map) return Boolean; + -- For each key/element pair in Left, equality attempts to find the key in + -- Right; if a search fails the equality returns False. The search works by + -- calling Hash to find the bucket in the Right map that corresponds to the + -- Left key. If bucket is non-empty, then equality calls Equivalent_Keys + -- to compare the key (in Left) to the key of each node in the bucket (in + -- Right); if the keys are equivalent, then the equality test for this + -- key/element pair (in Left) completes by calling the element equality + -- operator to compare the element (in Left) to the element of the node + -- (in Right) whose key matched. + + function Capacity (Container : Map) return Count_Type; + -- Returns the current capacity of the map. Capacity is the maximum length + -- before which rehashing in guaranteed not to occur. + + procedure Reserve_Capacity (Container : in out Map; Capacity : Count_Type); + -- Adjusts the current capacity, by allocating a new buckets array. If the + -- requested capacity is less than the current capacity, then the capacity + -- is contracted (to a value not less than the current length). If the + -- requested capacity is greater than the current capacity, then the + -- capacity is expanded (to a value not less than what is requested). In + -- either case, the nodes are rehashed from the old buckets array onto the + -- new buckets array (Hash is called once for each existing key in order to + -- compute the new index), and then the old buckets array is deallocated. + + function Length (Container : Map) return Count_Type; + -- Returns the number of items in the map + + function Is_Empty (Container : Map) return Boolean; + -- Equivalent to Length (Container) = 0 + + procedure Clear (Container : in out Map); + -- Removes all of the items from the map + + function Key (Position : Cursor) return Key_Type; + -- Returns the key of the node designated by the cursor + + function Element (Position : Cursor) return Element_Type; + -- Returns the element of the node designated by the cursor + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type); + -- Assigns the value New_Item to the element designated by the cursor + + procedure Query_Element + (Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : Element_Type)); + -- Calls Process with the key and element (both having only a constant + -- view) of the node designed by the cursor. + + procedure Update_Element + (Container : in out Map; + Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : in out Element_Type)); + -- Calls Process with the key (with only a constant view) and element (with + -- a variable view) of the node designed by the cursor. + + 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 Has_Element (Position : Cursor) return Boolean; + -- Equivalent to Position /= No_Element + + 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 + +private + pragma Inline ("="); + pragma Inline (Length); + pragma Inline (Is_Empty); + pragma Inline (Clear); + pragma Inline (Key); + pragma Inline (Element); + pragma Inline (Move); + pragma Inline (Contains); + pragma Inline (Capacity); + pragma Inline (Reserve_Capacity); + pragma Inline (Has_Element); + pragma Inline (Equivalent_Keys); + pragma Inline (Next); + + type Node_Type; + type Node_Access is access Node_Type; + + type Node_Type is limited record + Key : Key_Type; + Element : Element_Type; + Next : Node_Access; + end record; + + package HT_Types is + new Hash_Tables.Generic_Hash_Table_Types (Node_Type, Node_Access); + + type Map is new Ada.Finalization.Controlled with record + HT : HT_Types.Hash_Table_Type; + end record; + + use HT_Types; + use Ada.Finalization; + + overriding + procedure Adjust (Container : in out Map); + + overriding + procedure Finalize (Container : in out Map); + + 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 constant Map; + for Map_Access'Storage_Size use 0; + + type Cursor is record + Container : Map_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; + + Empty_Map : constant Map := (Controlled with HT => (null, 0, 0, 0)); + + No_Element : constant Cursor := (Container => null, Node => null); + +end Ada.Containers.Hashed_Maps; diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb new file mode 100644 index 000000000..643dde5d9 --- /dev/null +++ b/gcc/ada/a-cohase.adb @@ -0,0 +1,1850 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . H A S H E D _ S E T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-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. -- +------------------------------------------------------------------------------ + +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.Prime_Numbers; + +with System; use type System.Address; + +package body Ada.Containers.Hashed_Sets is + + ----------------------- + -- 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 : Hash_Table_Type; + Key : Node_Access) return Boolean; + pragma Inline (Is_In); + + function Next (Node : Node_Access) return Node_Access; + pragma Inline (Next); + + function Read_Node (Stream : not null access Root_Stream_Type'Class) + return Node_Access; + pragma Inline (Read_Node); + + procedure Set_Next (Node : Node_Access; Next : Node_Access); + pragma Inline (Set_Next); + + function Vet (Position : Cursor) return Boolean; + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access); + pragma Inline (Write_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package HT_Ops is new Hash_Tables.Generic_Operations + (HT_Types => HT_Types, + Hash_Node => Hash_Node, + Next => Next, + Set_Next => Set_Next, + Copy_Node => Copy_Node, + Free => Free); + + package Element_Keys is new Hash_Tables.Generic_Keys + (HT_Types => HT_Types, + Next => Next, + Set_Next => Set_Next, + Key_Type => Element_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Keys); + + function Is_Equal is + new HT_Ops.Generic_Equal (Find_Equal_Key); + + function Is_Equivalent is + new HT_Ops.Generic_Equal (Find_Equivalent_Key); + + procedure Read_Nodes is + new HT_Ops.Generic_Read (Read_Node); + + procedure Replace_Element is + new Element_Keys.Generic_Replace_Element (Hash_Node, Assign); + + procedure Write_Nodes is + new HT_Ops.Generic_Write (Write_Node); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Set) return Boolean is + begin + return Is_Equal (Left.HT, Right.HT); + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Set) is + begin + HT_Ops.Adjust (Container.HT); + end Adjust; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Node : Node_Access; Item : Element_Type) is + begin + Node.Element := Item; + end Assign; + + -------------- + -- 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; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Item : Element_Type) return Boolean is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + --------------- + -- Copy_Node -- + --------------- + + function Copy_Node (Source : Node_Access) return Node_Access is + begin + return new Node_Type'(Element => Source.Element, Next => null); + end Copy_Node; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out Set; + Item : Element_Type) + is + X : Node_Access; + + begin + Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); + + if 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 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; + + if Container.HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (set is busy)"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Delete"); + + HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node); + + Free (Position.Node); + Position.Container := null; + end Delete; + + ---------------- + -- Difference -- + ---------------- + + procedure Difference + (Target : in out Set; + Source : Set) + is + Tgt_Node : Node_Access; + + begin + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + if Source.HT.Length = 0 then + return; + end if; + + if Target.HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (set is busy)"; + end if; + + if Source.HT.Length < Target.HT.Length then + declare + Src_Node : Node_Access; + + begin + Src_Node := HT_Ops.First (Source.HT); + while Src_Node /= null loop + Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element); + + if Tgt_Node /= null then + HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node); + Free (Tgt_Node); + end if; + + Src_Node := HT_Ops.Next (Source.HT, Src_Node); + end loop; + end; + + else + Tgt_Node := HT_Ops.First (Target.HT); + while Tgt_Node /= null loop + if Is_In (Source.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 + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; + + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; + + if Left.HT.Length = 0 then + return Empty_Set; + end if; + + if Right.HT.Length = 0 then + return Left; + end if; + + declare + Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length); + begin + Buckets := HT_Ops.New_Buckets (Length => Size); + end; + + Length := 0; + + Iterate_Left : declare + procedure Process (L_Node : Node_Access); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (L_Node : Node_Access) is + begin + if not Is_In (Right.HT, L_Node) then + declare + J : constant Hash_Type := + Hash (L_Node.Element) mod Buckets'Length; + + Bucket : Node_Access renames Buckets (J); + + begin + Bucket := new Node_Type'(L_Node.Element, Bucket); + end; + + Length := Length + 1; + end if; + end Process; + + -- Start of processing for Iterate_Left + + begin + Iterate (Left.HT); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end Iterate_Left; + + return (Controlled with HT => (Buckets, Length, 0, 0)); + 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), "bad cursor in function Element"); + + return Position.Node.Element; + end Element; + + --------------------- + -- Equivalent_Sets -- + --------------------- + + function Equivalent_Sets (Left, Right : Set) return Boolean is + begin + return Is_Equivalent (Left.HT, Right.HT); + end Equivalent_Sets; + + ------------------------- + -- Equivalent_Elements -- + ------------------------- + + function Equivalent_Elements (Left, Right : Cursor) + return Boolean is + begin + if Left.Node = null then + raise Constraint_Error with + "Left cursor of Equivalent_Elements equals No_Element"; + end if; + + if Right.Node = null then + raise Constraint_Error with + "Right cursor of Equivalent_Elements equals No_Element"; + end if; + + pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements"); + pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements"); + + return Equivalent_Elements (Left.Node.Element, Right.Node.Element); + end Equivalent_Elements; + + function Equivalent_Elements (Left : Cursor; Right : Element_Type) + return Boolean is + begin + if Left.Node = null then + raise Constraint_Error with + "Left cursor of Equivalent_Elements equals No_Element"; + end if; + + pragma Assert (Vet (Left), "Left cursor in Equivalent_Elements is bad"); + + return Equivalent_Elements (Left.Node.Element, Right); + end Equivalent_Elements; + + function Equivalent_Elements (Left : Element_Type; Right : Cursor) + return Boolean is + begin + if Right.Node = null then + raise Constraint_Error with + "Right cursor of Equivalent_Elements equals No_Element"; + end if; + + pragma Assert + (Vet (Right), + "Right cursor of Equivalent_Elements is bad"); + + return Equivalent_Elements (Left, Right.Node.Element); + end Equivalent_Elements; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Key : Element_Type; Node : Node_Access) + return Boolean is + begin + return Equivalent_Elements (Key, Node.Element); + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude + (Container : in out Set; + Item : Element_Type) + is + X : Node_Access; + begin + Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); + Free (X); + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Container : in out Set) is + begin + HT_Ops.Finalize (Container.HT); + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Set; + Item : Element_Type) return Cursor + is + Node : constant Node_Access := Element_Keys.Find (Container.HT, Item); + + begin + if Node = null then + return No_Element; + end if; + + return 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); + + R_Node : Node_Access := R_HT.Buckets (R_Index); + + begin + loop + if R_Node = null then + return False; + end if; + + if L_Node.Element = R_Node.Element then + return True; + end if; + + R_Node := Next (R_Node); + end loop; + end Find_Equal_Key; + + ------------------------- + -- Find_Equivalent_Key -- + ------------------------- + + function Find_Equivalent_Key + (R_HT : Hash_Table_Type; + L_Node : Node_Access) return Boolean + is + R_Index : constant Hash_Type := + Element_Keys.Index (R_HT, L_Node.Element); + + R_Node : Node_Access := R_HT.Buckets (R_Index); + + begin + loop + if R_Node = null then + return False; + end if; + + if Equivalent_Elements (L_Node.Element, R_Node.Element) then + return True; + end if; + + R_Node := Next (R_Node); + end loop; + end Find_Equivalent_Key; + + ----------- + -- First -- + ----------- + + function First (Container : Set) return Cursor is + Node : constant Node_Access := HT_Ops.First (Container.HT); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end First; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + begin + if X /= null then + X.Next := X; -- detect mischief (in Vet) + Deallocate (X); + end if; + end Free; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + pragma Assert (Vet (Position), "bad cursor in Has_Element"); + return Position.Node /= null; + end Has_Element; + + --------------- + -- Hash_Node -- + --------------- + + function Hash_Node (Node : Node_Access) return Hash_Type is + begin + return Hash (Node.Element); + end Hash_Node; + + ------------- + -- Include -- + ------------- + + procedure Include + (Container : in out Set; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + if Container.HT.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + Position.Node.Element := New_Item; + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + begin + Insert (Container.HT, New_Item, Position.Node, Inserted); + Position.Container := Container'Unchecked_Access; + end Insert; + + procedure Insert + (Container : in out Set; + New_Item : Element_Type) + is + Position : Cursor; + pragma Unreferenced (Position); + + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error with + "attempt to insert element already in set"; + end if; + end Insert; + + procedure Insert + (HT : in out Hash_Table_Type; + New_Item : Element_Type; + Node : out Node_Access; + Inserted : out Boolean) + is + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); + + procedure Local_Insert is + new Element_Keys.Generic_Conditional_Insert (New_Node); + + -------------- + -- New_Node -- + -------------- + + function New_Node (Next : Node_Access) return Node_Access is + begin + return new Node_Type'(New_Item, Next); + end New_Node; + + -- Start of processing for Insert + + begin + if HT_Ops.Capacity (HT) = 0 then + HT_Ops.Reserve_Capacity (HT, 1); + end if; + + 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 + Tgt_Node : Node_Access; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Source.HT.Length = 0 then + Clear (Target); + return; + end if; + + if Target.HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (set is busy)"; + end if; + + Tgt_Node := HT_Ops.First (Target.HT); + while Tgt_Node /= null loop + if Is_In (Source.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 + 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 + J : constant Hash_Type := + Hash (L_Node.Element) mod Buckets'Length; + + Bucket : Node_Access renames Buckets (J); + + begin + Bucket := new Node_Type'(L_Node.Element, Bucket); + end; + + Length := Length + 1; + end if; + end Process; + + -- Start of processing for Iterate_Left + + begin + Iterate (Left.HT); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end Iterate_Left; + + return (Controlled with HT => (Buckets, Length, 0, 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 : Hash_Table_Type; Key : Node_Access) return Boolean is + begin + return Element_Keys.Find (HT, Key.Element) /= null; + end Is_In; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is + Subset_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; + + B : Natural renames Container'Unrestricted_Access.HT.Busy; + + -- Start of processing for Iterate + + begin + B := B + 1; + + begin + Iterate (Container.HT); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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; + + 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 + 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; + + ------------- + -- Overlap -- + ------------- + + function Overlap (Left, Right : Set) return Boolean is + 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; + + ------------------- + -- 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 of Query_Element equals No_Element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Query_Element"); + + declare + HT : Hash_Table_Type renames Position.Container.HT; + + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (Position.Node.Element); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + 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; + + --------------- + -- Read_Node -- + --------------- + + function Read_Node (Stream : not null access Root_Stream_Type'Class) + return Node_Access + is + Node : Node_Access := new Node_Type; + + begin + Element_Type'Read (Stream, Node.Element); + return Node; + exception + when others => + Free (Node); + raise; + end Read_Node; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Set; + New_Item : Element_Type) + is + Node : constant Node_Access := + Element_Keys.Find (Container.HT, New_Item); + + begin + if Node = null then + raise Constraint_Error with + "attempt to replace element not in set"; + end if; + + if Container.HT.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + Node.Element := New_Item; + end Replace; + + 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 (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 + begin + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + if Target.HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (set is busy)"; + end if; + + 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; + + if Target.Length = 0 then + Iterate_Source_When_Empty_Target : declare + procedure Process (Src_Node : Node_Access); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Src_Node : Node_Access) is + E : Element_Type renames Src_Node.Element; + B : Buckets_Type renames Target.HT.Buckets.all; + J : constant Hash_Type := Hash (E) mod B'Length; + N : Count_Type renames Target.HT.Length; + + begin + B (J) := new Node_Type'(E, B (J)); + N := N + 1; + end Process; + + -- Start of processing for Iterate_Source_When_Empty_Target + + begin + Iterate (Source.HT); + end Iterate_Source_When_Empty_Target; + + else + Iterate_Source : declare + procedure Process (Src_Node : Node_Access); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Src_Node : Node_Access) is + E : Element_Type renames Src_Node.Element; + B : Buckets_Type renames Target.HT.Buckets.all; + J : constant Hash_Type := Hash (E) mod B'Length; + N : Count_Type renames Target.HT.Length; + + begin + if B (J) = null then + B (J) := new Node_Type'(E, null); + N := N + 1; + + elsif Equivalent_Elements (E, B (J).Element) then + declare + X : Node_Access := B (J); + begin + B (J) := B (J).Next; + N := N - 1; + Free (X); + end; + + else + declare + Prev : Node_Access := B (J); + Curr : Node_Access := Prev.Next; + + begin + while Curr /= null loop + if Equivalent_Elements (E, Curr.Element) then + Prev.Next := Curr.Next; + N := N - 1; + Free (Curr); + return; + end if; + + Prev := Curr; + Curr := Prev.Next; + end loop; + + B (J) := new Node_Type'(E, B (J)); + N := N + 1; + end; + end if; + end Process; + + -- Start of processing for Iterate_Source + + begin + Iterate (Source.HT); + end Iterate_Source; + end if; + end Symmetric_Difference; + + function Symmetric_Difference (Left, Right : Set) return Set is + 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; + J : constant Hash_Type := Hash (E) mod Buckets'Length; + + begin + Buckets (J) := new Node_Type'(E, Buckets (J)); + Length := Length + 1; + end; + end if; + end Process; + + -- Start of processing for Iterate_Left + + begin + Iterate (Left.HT); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end Iterate_Left; + + Iterate_Right : declare + procedure Process (R_Node : Node_Access); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (R_Node : Node_Access) is + begin + if not Is_In (Left.HT, R_Node) then + declare + E : Element_Type renames R_Node.Element; + J : constant Hash_Type := Hash (E) mod Buckets'Length; + + begin + Buckets (J) := new Node_Type'(E, Buckets (J)); + Length := Length + 1; + end; + end if; + end Process; + + -- Start of processing for Iterate_Right + + begin + Iterate (Right.HT); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end Iterate_Right; + + return (Controlled with HT => (Buckets, Length, 0, 0)); + end Symmetric_Difference; + + ------------ + -- To_Set -- + ------------ + + function To_Set (New_Item : Element_Type) return Set is + HT : Hash_Table_Type; + + Node : Node_Access; + Inserted : Boolean; + pragma Unreferenced (Node, Inserted); + + begin + Insert (HT, New_Item, Node, Inserted); + return Set'(Controlled with HT); + end To_Set; + + ----------- + -- Union -- + ----------- + + procedure Union + (Target : in out Set; + Source : Set) + is + procedure Process (Src_Node : Node_Access); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Src_Node : Node_Access) is + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); + + procedure Insert is + new Element_Keys.Generic_Conditional_Insert (New_Node); + + -------------- + -- New_Node -- + -------------- + + function New_Node (Next : Node_Access) return Node_Access is + Node : constant Node_Access := + new Node_Type'(Src_Node.Element, Next); + begin + return Node; + end New_Node; + + Tgt_Node : Node_Access; + Success : Boolean; + pragma Unreferenced (Tgt_Node, Success); + + -- Start of processing for Process + + begin + Insert (Target.HT, Src_Node.Element, Tgt_Node, Success); + end Process; + + -- Start of processing for Union + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (set is busy)"; + end if; + + 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 + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; + + begin + if Left'Address = Right'Address then + return Left; + end if; + + if Right.Length = 0 then + return Left; + end if; + + if Left.Length = 0 then + return Right; + end if; + + declare + Size : constant Hash_Type := + Prime_Numbers.To_Prime (Left.Length + Right.Length); + begin + Buckets := HT_Ops.New_Buckets (Length => Size); + end; + + Iterate_Left : declare + procedure Process (L_Node : Node_Access); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (L_Node : Node_Access) is + J : constant Hash_Type := + Hash (L_Node.Element) mod Buckets'Length; + + begin + Buckets (J) := new Node_Type'(L_Node.Element, Buckets (J)); + end Process; + + -- Start of processing for Iterate_Left + + begin + Iterate (Left.HT); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end Iterate_Left; + + Length := Left.Length; + + Iterate_Right : declare + procedure Process (Src_Node : Node_Access); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Src_Node : Node_Access) is + J : constant Hash_Type := + Hash (Src_Node.Element) mod Buckets'Length; + + Tgt_Node : Node_Access := Buckets (J); + + begin + while Tgt_Node /= null loop + if Equivalent_Elements (Src_Node.Element, Tgt_Node.Element) then + return; + end if; + + Tgt_Node := Next (Tgt_Node); + end loop; + + Buckets (J) := new Node_Type'(Src_Node.Element, Buckets (J)); + Length := Length + 1; + end Process; + + -- 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, 0, 0)); + end Union; + + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = null then + return Position.Container = null; + end if; + + if Position.Container = null then + return False; + end if; + + if Position.Node.Next = Position.Node then + return False; + end if; + + declare + HT : Hash_Table_Type renames Position.Container.HT; + X : Node_Access; + + begin + if HT.Length = 0 then + return False; + end if; + + if HT.Buckets = null + or else HT.Buckets'Length = 0 + then + return False; + end if; + + X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element)); + + for J in 1 .. HT.Length loop + if X = Position.Node then + return True; + end if; + + if X = null then + return False; + end if; + + if X = X.Next then -- to prevent unnecessary looping + return False; + end if; + + X := X.Next; + end loop; + + return False; + end; + end Vet; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Set) + is + begin + Write_Nodes (Stream, Container.HT); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Write; + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access) + is + begin + Element_Type'Write (Stream, Node.Element); + end Write_Node; + + package body Generic_Keys is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Access) return Boolean; + pragma Inline (Equivalent_Key_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Key_Keys is + new Hash_Tables.Generic_Keys + (HT_Types => HT_Types, + Next => Next, + Set_Next => Set_Next, + Key_Type => Key_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Key_Node); + + -------------- + -- 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 X = null then + raise Constraint_Error with "attempt to delete key not in set"; + end if; + + Free (X); + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Container : Set; + Key : Key_Type) return Element_Type + is + Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); + + begin + if Node = null then + raise Constraint_Error with "key not in map"; + end if; + + return Node.Element; + end Element; + + ------------------------- + -- Equivalent_Key_Node -- + ------------------------- + + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Access) return Boolean + is + begin + return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element)); + end Equivalent_Key_Node; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude + (Container : in out Set; + Key : Key_Type) + is + X : Node_Access; + begin + Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); + Free (X); + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Set; + Key : Key_Type) return Cursor + is + Node : constant Node_Access := + Key_Keys.Find (Container.HT, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Find; + + --------- + -- 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), "bad cursor in function Key"); + + return Key (Position.Node.Element); + 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.HT, Key); + + begin + if 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 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; + + 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"); + + Indx := HT_Ops.Index (HT, Position.Node); + + declare + E : Element_Type renames Position.Node.Element; + K : constant Key_Type := Key (E); + + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + + if Equivalent_Keys (K, Key (E)) then + pragma Assert (Hash (K) = Hash (E)); + 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 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; + + end Generic_Keys; + +end Ada.Containers.Hashed_Sets; diff --git a/gcc/ada/a-cohase.ads b/gcc/ada/a-cohase.ads new file mode 100644 index 000000000..a6d1308af --- /dev/null +++ b/gcc/ada/a-cohase.ads @@ -0,0 +1,461 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . H A S H E D _ S E T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-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 -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +private with Ada.Containers.Hash_Tables; +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.Hashed_Sets is + pragma Preelaborate; + pragma Remote_Types; + + type Set is tagged private; + 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 "=" (Left, Right : Set) return Boolean; + -- For each element in Left, set equality attempts to find the equal + -- element in Right; if a search fails, then set equality immediately + -- returns False. The search works by calling Hash to find the bucket in + -- the Right set that corresponds to the Left element. If the bucket is + -- non-empty, the search calls the generic formal element equality operator + -- to compare the element (in Left) to the element of each node in the + -- bucket (in Right); the search terminates when a matching node in the + -- bucket is found, or the nodes in the bucket are exhausted. (Note that + -- element equality is called here, not Equivalent_Elements. Set equality + -- is the only operation in which element equality is used. Compare set + -- equality to Equivalent_Sets, which does call Equivalent_Elements.) + + function Equivalent_Sets (Left, Right : Set) return Boolean; + -- Similar to set equality, with the difference that the element in Left is + -- compared to the elements in Right using the generic formal + -- Equivalent_Elements operation instead of element equality. + + function To_Set (New_Item : Element_Type) return Set; + -- Constructs a singleton set comprising New_Element. To_Set calls Hash to + -- determine the bucket for New_Item. + + function Capacity (Container : Set) return Count_Type; + -- Returns the current capacity of the set. Capacity is the maximum length + -- before which rehashing in guaranteed not to occur. + + procedure Reserve_Capacity (Container : in out Set; Capacity : Count_Type); + -- Adjusts the current capacity, by allocating a new buckets array. If the + -- requested capacity is less than the current capacity, then the capacity + -- is contracted (to a value not less than the current length). If the + -- requested capacity is greater than the current capacity, then the + -- capacity is expanded (to a value not less than what is requested). In + -- either case, the nodes are rehashed from the old buckets array onto the + -- new buckets array (Hash is called once for each existing element in + -- order to compute the new index), and then the old buckets array is + -- deallocated. + + function Length (Container : Set) return Count_Type; + -- Returns the number of items in the set + + function Is_Empty (Container : Set) return Boolean; + -- Equivalent to Length (Container) = 0 + + procedure Clear (Container : in out Set); + -- Removes all of the items from the set + + function Element (Position : Cursor) return Element_Type; + -- Returns the element of the node designated by the cursor + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type); + -- If New_Item is equivalent (as determined by calling Equivalent_Elements) + -- to the element of the node designated by Position, then New_Element is + -- assigned to that element. Otherwise, it calls Hash to determine the + -- bucket for New_Item. If the bucket is not empty, then it calls + -- Equivalent_Elements for each node in that bucket to determine whether + -- New_Item is equivalent to an element in that bucket. If + -- Equivalent_Elements returns True then Program_Error is raised (because + -- an element may appear only once in the set); otherwise, New_Item is + -- assigned to the node designated by Position, and the node is moved to + -- its new bucket. + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + -- Calls Process with the element (having only a constant view) of the node + -- designed by the cursor. + + 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 Has_Element (Position : Cursor) return Boolean; + -- Equivalent to Position /= 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 + + 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. + + end Generic_Keys; + +private + + pragma Inline (Next); + + type Node_Type; + type Node_Access is access Node_Type; + + type Node_Type is limited record + Element : Element_Type; + Next : Node_Access; + end record; + + package HT_Types is + new Hash_Tables.Generic_Hash_Table_Types (Node_Type, Node_Access); + + type Set is new Ada.Finalization.Controlled with record + HT : HT_Types.Hash_Table_Type; + end record; + + overriding + procedure Adjust (Container : in out Set); + + overriding + procedure Finalize (Container : in out Set); + + use HT_Types; + use Ada.Finalization; + use Ada.Streams; + + 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; + + No_Element : constant Cursor := (Container => null, Node => 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; + + Empty_Set : constant Set := (Controlled with HT => (null, 0, 0, 0)); + +end Ada.Containers.Hashed_Sets; diff --git a/gcc/ada/a-cohata.ads b/gcc/ada/a-cohata.ads new file mode 100644 index 000000000..d935447b2 --- /dev/null +++ b/gcc/ada/a-cohata.ads @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +------------------------------------------------------------------------------ + +-- This package declares the hash-table type used to implement hashed +-- containers. + +package Ada.Containers.Hash_Tables is + pragma 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; -- so this package can be Pure + + type Hash_Table_Type is tagged record + Buckets : Buckets_Access; + Length : Count_Type := 0; + Busy : Natural := 0; + Lock : Natural := 0; + end record; + 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; + Busy : Natural := 0; + Lock : Natural := 0; + Free : Count_Type'Base := -1; + Nodes : Nodes_Type (1 .. Capacity); + Buckets : Buckets_Type (1 .. Modulus) := (others => 0); + end record; + end Generic_Bounded_Hash_Table_Types; + +end Ada.Containers.Hash_Tables; diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb new file mode 100644 index 000000000..c6f8cb263 --- /dev/null +++ b/gcc/ada/a-coinve.adb @@ -0,0 +1,3582 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Generic_Array_Sort; +with Ada.Unchecked_Deallocation; +with System; use type System.Address; + +package body Ada.Containers.Indefinite_Vectors is + + procedure Free is + new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); + + procedure Free is + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + + --------- + -- "&" -- + --------- + + 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 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; + + declare + RE : Elements_Array renames + Right.Elements.EA (Index_Type'First .. Right.Last); + + Elements : Elements_Access := + new Elements_Type (Right.Last); + + begin + -- Elements of an indefinite vector are allocated, so we cannot + -- use simple slice assignment to give a value to our result. + -- Hence we must walk the array of the Right vector, and copy + -- each source element individually. + + for I in Elements.EA'Range loop + begin + if RE (I) /= null then + Elements.EA (I) := new Element_Type'(RE (I).all); + end if; + + exception + when others => + for J in Index_Type'First .. I - 1 loop + Free (Elements.EA (J)); + end loop; + + Free (Elements); + raise; + end; + end loop; + + return (Controlled with Elements, Right.Last, 0, 0); + end; + + end if; + + if RN = 0 then + declare + LE : Elements_Array renames + Left.Elements.EA (Index_Type'First .. Left.Last); + + Elements : Elements_Access := + new Elements_Type (Left.Last); + + begin + -- Elements of an indefinite vector are allocated, so we cannot + -- use simple slice assignment to give a value to our result. + -- Hence we must walk the array of the Left vector, and copy + -- each source element individually. + + for I in Elements.EA'Range loop + begin + if LE (I) /= null then + Elements.EA (I) := new Element_Type'(LE (I).all); + end if; + + exception + when others => + for J in Index_Type'First .. I - 1 loop + Free (Elements.EA (J)); + end loop; + + Free (Elements); + raise; + end; + end loop; + + return (Controlled with Elements, Left.Last, 0, 0); + end; + end if; + + -- Neither of the vector parameters is empty, so we 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 LN > Count_Type'Last - RN then + raise Constraint_Error with "new length is out of range"; + end if; + + -- It is now safe compute the length of the new vector. + + 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 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 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 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 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.EA (Index_Type'First .. Left.Last); + + RE : Elements_Array renames + Right.Elements.EA (Index_Type'First .. Right.Last); + + Elements : Elements_Access := new Elements_Type (Last); + + I : Index_Type'Base := No_Index; + + begin + -- Elements of an indefinite vector are allocated, so we cannot use + -- simple slice assignment to give a value to our result. Hence we + -- must walk the array of each vector parameter, and copy each source + -- element individually. + + for LI in LE'Range loop + I := I + 1; + + begin + if LE (LI) /= null then + Elements.EA (I) := new Element_Type'(LE (LI).all); + end if; + + exception + when others => + for J in Index_Type'First .. I - 1 loop + Free (Elements.EA (J)); + end loop; + + Free (Elements); + raise; + end; + end loop; + + for RI in RE'Range loop + I := I + 1; + + begin + if RE (RI) /= null then + Elements.EA (I) := new Element_Type'(RE (RI).all); + end if; + + exception + when others => + for J in Index_Type'First .. I - 1 loop + Free (Elements.EA (J)); + end loop; + + Free (Elements); + raise; + end; + end loop; + + return (Controlled with Elements, Last, 0, 0); + end; + end "&"; + + function "&" (Left : Vector; 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. + + -- Here we handle the easy case first, when the vector parameter (Left) + -- is empty. + + if Left.Is_Empty then + declare + Elements : Elements_Access := new Elements_Type (Index_Type'First); + + begin + begin + Elements.EA (Index_Type'First) := new Element_Type'(Right); + exception + when others => + Free (Elements); + raise; + end; + + return (Controlled with Elements, Index_Type'First, 0, 0); + end; + end if; + + -- The vector parameter is not empty, so 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 Left.Length = Count_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; + + if Left.Last >= Index_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; + + declare + Last : constant Index_Type := Left.Last + 1; + + LE : Elements_Array renames + Left.Elements.EA (Index_Type'First .. Left.Last); + + Elements : Elements_Access := + new Elements_Type (Last); + + begin + for I in LE'Range loop + begin + if LE (I) /= null then + Elements.EA (I) := new Element_Type'(LE (I).all); + end if; + + exception + when others => + for J in Index_Type'First .. I - 1 loop + Free (Elements.EA (J)); + end loop; + + Free (Elements); + raise; + end; + end loop; + + begin + Elements.EA (Last) := new Element_Type'(Right); + + 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, 0, 0); + end; + end "&"; + + function "&" (Left : Element_Type; Right : Vector) 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. + + -- Here we handle the easy case first, when the vector parameter (Right) + -- is empty. + + if Right.Is_Empty then + declare + Elements : Elements_Access := new Elements_Type (Index_Type'First); + + begin + begin + Elements.EA (Index_Type'First) := new Element_Type'(Left); + exception + when others => + Free (Elements); + raise; + end; + + return (Controlled with Elements, Index_Type'First, 0, 0); + end; + end if; + + -- The vector parameter is not empty, so 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 Right.Length = Count_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; + + if Right.Last >= Index_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; + + declare + Last : constant Index_Type := Right.Last + 1; + + RE : Elements_Array renames + Right.Elements.EA (Index_Type'First .. Right.Last); + + Elements : Elements_Access := + new Elements_Type (Last); + + I : Index_Type'Base := Index_Type'First; + + begin + begin + Elements.EA (I) := new Element_Type'(Left); + exception + when others => + Free (Elements); + raise; + end; + + for RI in RE'Range loop + I := I + 1; + + begin + if RE (RI) /= null then + Elements.EA (I) := new Element_Type'(RE (RI).all); + end if; + + exception + when others => + for J in Index_Type'First .. I - 1 loop + Free (Elements.EA (J)); + end loop; + + Free (Elements); + raise; + end; + end loop; + + return (Controlled with Elements, Last, 0, 0); + end; + 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 Index_Type'First >= Index_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; + + declare + Last : constant Index_Type := Index_Type'First + 1; + Elements : Elements_Access := new Elements_Type (Last); + + begin + begin + Elements.EA (Index_Type'First) := new Element_Type'(Left); + exception + when others => + Free (Elements); + raise; + end; + + begin + Elements.EA (Last) := new Element_Type'(Right); + exception + when others => + Free (Elements.EA (Index_Type'First)); + Free (Elements); + raise; + end; + + return (Controlled with Elements, Last, 0, 0); + end; + end "&"; + + --------- + -- "=" -- + --------- + + overriding function "=" (Left, Right : Vector) return Boolean is + begin + if Left'Address = Right'Address then + return True; + end if; + + if Left.Last /= Right.Last then + return False; + end if; + + for J in 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; + + return True; + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Vector) is + begin + 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.Busy := 0; + Container.Lock := 0; + + Container.Elements := new Elements_Type (L); + + for I in E'Range loop + if E (I) /= null then + Container.Elements.EA (I) := new Element_Type'(E (I).all); + end if; + + Container.Last := I; + end loop; + end; + end Adjust; + + ------------ + -- Append -- + ------------ + + procedure Append (Container : in out Vector; New_Item : Vector) is + begin + if Is_Empty (New_Item) then + return; + end if; + + if Container.Last = Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; + end if; + + Insert + (Container, + Container.Last + 1, + New_Item); + end Append; + + procedure Append + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + if Count = 0 then + return; + end if; + + if Container.Last = Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; + end if; + + Insert + (Container, + Container.Last + 1, + New_Item, + Count); + end Append; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Vector) return Count_Type is + begin + if Container.Elements = null then + return 0; + end if; + + return Container.Elements.EA'Length; + end Capacity; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Vector) is + begin + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + 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; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Vector; + Item : Element_Type) return Boolean + is + begin + return Find_Index (Container, Item) /= No_Index; + end Contains; + + ------------ + -- 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 Index < Index_Type'First then + raise Constraint_Error with "Index is out of range (too small)"; + end if; + + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows the + -- corner case of deleting no items from the back end of the vector to + -- be treated as a no-op. (It is assumed that specifying an index value + -- greater than Last + 1 indicates some deeper flaw in the caller's + -- algorithm, so that case is treated as a proper error.) + + if Index > Old_Last then + if Index > Old_Last + 1 then + raise Constraint_Error with "Index is out of range (too large)"; + end if; + + return; + end if; + + -- 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. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + -- We first calculate what's available for deletion starting at + -- Index. Here and elsewhere we use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate values. (See function + -- Length for more information.) + + if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then + Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; + + else + Count2 := Count_Type'Base (Old_Last - Index + 1); + end if; + + -- If 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'Pos (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 + pragma Warnings (Off, Position); + + 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 denotes wrong container"; + end if; + + if 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; + end if; + + if Count >= Length (Container) then + Clear (Container); + return; + end if; + + Delete (Container, Index_Type'First, Count); + 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. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + -- 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 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 EA = null then + raise Constraint_Error with "element is empty"; + end if; + + return EA.all; + end; + end Element; + + function Element (Position : Cursor) return Element_Type is + begin + 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; + + declare + EA : constant Element_Access := + Position.Container.Elements.EA (Position.Index); + + begin + if EA = null then + raise Constraint_Error with "element is empty"; + end if; + + return EA.all; + 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; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + begin + if 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; + + for J in Position.Index .. Container.Last loop + if Container.Elements.EA (J) /= null + and then Container.Elements.EA (J).all = Item + then + return (Container'Unchecked_Access, J); + end if; + end loop; + + return No_Element; + end Find; + + ---------------- + -- Find_Index -- + ---------------- + + function Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'First) return Extended_Index + is + begin + for Indx in Index .. Container.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 Find_Index; + + ----------- + -- First -- + ----------- + + function First (Container : Vector) return Cursor is + begin + if Is_Empty (Container) then + return No_Element; + end if; + + return (Container'Unchecked_Access, Index_Type'First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Vector) return Element_Type is + begin + if 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 EA = null then + raise Constraint_Error with "first element is empty"; + end if; + + return EA.all; + 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; + + declare + E : Elements_Array renames Container.Elements.EA; + begin + for I in Index_Type'First .. Container.Last - 1 loop + if Is_Less (E (I + 1), E (I)) then + return False; + end if; + end loop; + end; + + return True; + end Is_Sorted; + + ----------- + -- Merge -- + ----------- + + procedure Merge (Target, Source : in out Vector) is + I, J : Index_Type'Base; + + begin + if Target.Last < Index_Type'First then + Move (Target => Target, Source => Source); + return; + end if; + + if Target'Address = Source'Address then + return; + end if; + + if Source.Last < Index_Type'First then + return; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + I := Target.Last; -- original value (before Set_Length) + Target.Set_Length (Length (Target) + Length (Source)); + + 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 + (Source.Elements.EA (Source.Last), + Source.Elements.EA (Source.Last - 1)))); + + if I < Index_Type'First then + declare + Src : Elements_Array renames + Source.Elements.EA (Index_Type'First .. Source.Last); + + begin + Target.Elements.EA (Index_Type'First .. J) := Src; + Src := (others => null); + end; + + Source.Last := No_Index; + return; + end if; + + pragma Assert + (I <= Index_Type'First + or else not (Is_Less + (Target.Elements.EA (I), + Target.Elements.EA (I - 1)))); + + declare + Src : Element_Access renames Source.Elements.EA (Source.Last); + Tgt : Element_Access renames Target.Elements.EA (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 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; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is locked)"; + end if; + + Sort (Container.Elements.EA (Index_Type'First .. Container.Last)); + end Sort; + + end Generic_Sorting; + + ----------------- + -- 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 + 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 + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying where the new + -- items should be inserted, so we must manually check. (That the user + -- is allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + + if Before < Index_Type'First then + raise Constraint_Error with + "Before index is out of range (too small)"; + end if; + + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for the + -- case of appending items to the back end of the vector. (It is assumed + -- that specifying an index value greater than Last + 1 indicates some + -- deeper flaw in the caller's algorithm, so that case is treated as a + -- proper error.) + + if Before > Container.Last + and then Before > 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 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). + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + elsif Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is less + -- than 0, so it is safe to compute the following sum without fear of + -- overflow. + + J := Count_Type'Base (No_Index) + Count_Type'Last; + + if J <= Count_Type'Base (Index_Type'Last) then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the maximum + -- number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- 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 + 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). + + Container.Elements.EA (Idx) := new Element_Type'(New_Item); + + -- 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. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + 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). + + E (Idx) := new Element_Type'(New_Item); + + -- 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'Pos (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; + 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'Pos (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). + + Dst.EA (Idx) := new Element_Type'(New_Item); + + -- 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'Pos (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. We now 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. + + Dst.EA (Idx) := new Element_Type'(New_Item); + 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 + -- that we want to avoid computing J, if J is greater than + -- Index_Type'Base'Last, in order to avoid overflow. 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. + + if Index_Type'Base'Last >= Count_Type'Pos (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'Pos (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 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 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 Before.Container /= null + and then Before.Container /= Vector_Access'(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 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 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 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 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 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'Unchecked_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 + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying where the new + -- items should be inserted, so we must manually check. (That the user + -- is allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + + if Before < Index_Type'First then + raise Constraint_Error with + "Before index is out of range (too small)"; + end if; + + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for the + -- case of appending items to the back end of the vector. (It is assumed + -- that specifying an index value greater than Last + 1 indicates some + -- deeper flaw in the caller's algorithm, so that case is treated as a + -- proper error.) + + if Before > Container.Last + and then Before > 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 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). + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + elsif Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is less + -- than 0, so it is safe to compute the following sum without fear of + -- overflow. + + J := Count_Type'Base (No_Index) + Count_Type'Last; + + if J <= Count_Type'Base (Index_Type'Last) then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the maximum + -- number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- 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 + 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. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + 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; + + 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'Pos (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'Pos (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'Pos (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 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 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 := 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 + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; + + begin + B := B + 1; + + begin + for Indx in Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unchecked_Access, Indx)); + end loop; + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : Vector) return Cursor is + begin + if Is_Empty (Container) then + return No_Element; + end if; + + return (Container'Unchecked_Access, Container.Last); + end Last; + + ----------------- + -- Last_Element -- + ------------------ + + function Last_Element (Container : Vector) return Element_Type is + begin + if 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 EA = null then + raise Constraint_Error with "last element is empty"; + end if; + + return EA.all; + 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; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (Source is busy)"; + end if; + + 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; + end if; + + if Position.Index < Position.Container.Last then + return (Position.Container, Position.Index + 1); + end if; + + return No_Element; + end Next; + + ---------- + -- Next -- + ---------- + + procedure Next (Position : in out Cursor) is + begin + if Position.Container = null then + return; + end if; + + if 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; + end if; + + if 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; + end if; + + if Position.Index > Index_Type'First then + return (Position.Container, Position.Index - 1); + end if; + + return No_Element; + end Previous; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Container : Vector; + Index : Index_Type; + Process : not null access procedure (Element : Element_Type)) + is + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; + L : Natural renames V.Lock; + + begin + if Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + if V.Elements.EA (Index) = null then + raise Constraint_Error with "element is null"; + end if; + + B := B + 1; + L := L + 1; + + begin + Process (V.Elements.EA (Index).all); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end Query_Element; + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if 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 := 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; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Vector; + Index : Index_Type; + New_Item : Element_Type) + is + begin + if Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is locked)"; + end if; + + declare + X : Element_Access := Container.Elements.EA (Index); + 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 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; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is locked)"; + end if; + + declare + X : Element_Access := Container.Elements.EA (Position.Index); + 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). + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + 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'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 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 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 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 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'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. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + 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. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + -- 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; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is locked)"; + end if; + + 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 Position.Container /= null + and then Position.Container /= Container'Unchecked_Access + then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + if Position.Container = null + or else Position.Index > Container.Last + then + Last := Container.Last; + else + Last := Position.Index; + end if; + + 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 (Container'Unchecked_Access, Indx); + end if; + end loop; + + return No_Element; + 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 + Last : constant Index_Type'Base := + (if Index > Container.Last then Container.Last else 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 + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; + + begin + B := B + 1; + + begin + for Indx in reverse Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unchecked_Access, Indx)); + end loop; + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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 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 I > Container.Last then + raise Constraint_Error with "I index is out of range"; + end if; + + if J > Container.Last then + raise Constraint_Error with "J index is out of range"; + end if; + + if I = J then + return; + end if; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is locked)"; + end if; + + 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 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; + + 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'Unchecked_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; + 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'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 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 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 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 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, 0, 0); + 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'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 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 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 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 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; + + 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, 0, 0); + 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 + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; + + begin + if Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + if Container.Elements.EA (Index) = null then + raise Constraint_Error with "element is null"; + end if; + + B := B + 1; + L := L + 1; + + begin + Process (Container.Elements.EA (Index).all); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + 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 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; + + 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; + +end Ada.Containers.Indefinite_Vectors; diff --git a/gcc/ada/a-coinve.ads b/gcc/ada/a-coinve.ads new file mode 100644 index 000000000..187c42034 --- /dev/null +++ b/gcc/ada/a-coinve.ads @@ -0,0 +1,370 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +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 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; + pragma Preelaborable_Initialization (Vector); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Vector : constant Vector; + + No_Element : constant Cursor; + + 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)); + + 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; + + function Has_Element (Position : Cursor) 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)); + + 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 (Contains); + pragma Inline (Next); + pragma Inline (Previous); + + 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 : Index_Type) is limited record + EA : Elements_Array (Index_Type'First .. Last); + end record; + + type Elements_Access is access Elements_Type; + + use Ada.Finalization; + + type Vector is new Controlled with record + Elements : Elements_Access; + Last : Extended_Index := No_Index; + Busy : Natural := 0; + Lock : Natural := 0; + end record; + + overriding + procedure Adjust (Container : in out Vector); + + overriding + procedure Finalize (Container : in out Vector); + + use Ada.Streams; + + 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 constant 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; + + Empty_Vector : constant Vector := (Controlled with null, No_Index, 0, 0); + + No_Element : constant Cursor := Cursor'(null, Index_Type'First); + +end Ada.Containers.Indefinite_Vectors; diff --git a/gcc/ada/a-colien.adb b/gcc/ada/a-colien.adb new file mode 100644 index 000000000..bd2f9d25c --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..224e70e8d --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..31a285591 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..a45450925 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is intended to be used in conjunction with its parent unit, +-- Ada.Command_Line. It provides facilities for logically removing arguments +-- from the command line, so that subsequent calls to Argument_Count and +-- Argument will reflect the removals. + +-- For example, if the original command line has three arguments A B C, so +-- that Argument_Count is initially three, then after removing B, the second +-- argument, Argument_Count will be 2, and Argument (2) will return C. + +package Ada.Command_Line.Remove is + pragma Preelaborate; + + procedure Remove_Argument (Number : Positive); + -- Removes the argument identified by Number, which must be in the + -- range 1 .. Argument_Count (i.e. an in range argument number which + -- reflects removals). If Number is out of range Constraint_Error + -- will be raised. + -- + -- Note: the numbering of arguments greater than Number is affected + -- by the call. If you need a loop through the arguments, removing + -- some as you go, run the loop in reverse to avoid confusion from + -- this renumbering: + -- + -- for J in reverse 1 .. Argument_Count loop + -- if Should_Remove (Arguments (J)) then + -- Remove_Argument (J); + -- end if; + -- end loop; + -- + -- Reversing the loop in this manner avoids the confusion. + + procedure Remove_Arguments (From : Positive; To : Natural); + -- Removes arguments in the given From..To range. From must be in the + -- range 1 .. Argument_Count and To in the range 0 .. Argument_Count. + -- Constraint_Error is raised if either argument is out of range. If + -- To is less than From, then the call has no effect. + + procedure Remove_Argument (Argument : String); + -- Removes the argument which matches the given string Argument. Has + -- no effect if no argument matches the string. If more than one + -- argument matches the string, all are removed. + + procedure Remove_Arguments (Argument_Prefix : String); + -- Removes all arguments whose prefix matches Argument_Prefix. Has + -- no effect if no argument matches the string. For example a call + -- to Remove_Arguments ("--") removes all arguments starting with --. + +end Ada.Command_Line.Remove; diff --git a/gcc/ada/a-comlin.adb b/gcc/ada/a-comlin.adb new file mode 100644 index 000000000..b29693638 --- /dev/null +++ b/gcc/ada/a-comlin.adb @@ -0,0 +1,131 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C O M M A N D _ L I N E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +with System; use System; + +package body Ada.Command_Line is + + function Arg_Count return Natural; + pragma Import (C, Arg_Count, "__gnat_arg_count"); + + procedure Fill_Arg (A : System.Address; Arg_Num : Integer); + pragma Import (C, Fill_Arg, "__gnat_fill_arg"); + + function Len_Arg (Arg_Num : Integer) return Integer; + pragma Import (C, Len_Arg, "__gnat_len_arg"); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Initialized return Boolean; + -- Checks to ensure that gnat_argc and gnat_argv have been properly + -- initialized. Returns false if not, or if argv / argc are + -- unsupported on the target (e.g. VxWorks). + + -------------- + -- Argument -- + -------------- + + function Argument (Number : Positive) return String is + Num : Positive; + + begin + if Number > Argument_Count then + raise Constraint_Error; + end if; + + if Remove_Args = null then + Num := Number; + else + Num := Remove_Args (Number); + end if; + + declare + Arg : aliased String (1 .. Len_Arg (Num)); + begin + Fill_Arg (Arg'Address, Num); + return Arg; + end; + end Argument; + + -------------------- + -- Argument_Count -- + -------------------- + + function Argument_Count return Natural is + begin + if not Initialized then + -- RM A.15 (11) + return 0; + end if; + + if Remove_Args = null then + return Arg_Count - 1; + else + return Remove_Count; + end if; + end Argument_Count; + + ----------------- + -- Initialized -- + ----------------- + + function Initialized return Boolean is + gnat_argv : System.Address; + pragma Import (C, gnat_argv, "gnat_argv"); + + begin + return gnat_argv /= System.Null_Address; + end Initialized; + + ------------------ + -- Command_Name -- + ------------------ + + function Command_Name return String is + begin + if not Initialized then + return ""; + end if; + + declare + Arg : aliased String (1 .. Len_Arg (0)); + + begin + Fill_Arg (Arg'Address, 0); + return Arg; + end; + end Command_Name; + +end Ada.Command_Line; diff --git a/gcc/ada/a-comlin.ads b/gcc/ada/a-comlin.ads new file mode 100644 index 000000000..55d0a5005 --- /dev/null +++ b/gcc/ada/a-comlin.ads @@ -0,0 +1,139 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C O M M A N D _ L I N E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit; + +package Ada.Command_Line is + pragma Preelaborate; + + function Argument_Count return Natural; + -- If the external execution environment supports passing arguments to a + -- program, then Argument_Count returns the number of arguments passed to + -- the program invoking the function. Otherwise it return 0. + -- + -- In GNAT: Corresponds to (argc - 1) in C. + + function Argument (Number : Positive) return String; + -- If the external execution environment supports passing arguments to + -- a program, then Argument returns an implementation-defined value + -- corresponding to the argument at relative position Number. If Number + -- is outside the range 1 .. Argument_Count, then Constraint_Error is + -- propagated. + -- + -- in GNAT: Corresponds to argv [n] (for n > 0) in C. + + function Command_Name return String; + -- If the external execution environment supports passing arguments to + -- a program, then Command_Name returns an implementation-defined value + -- corresponding to the name of the command invoking the program. + -- Otherwise Command_Name returns the null string. + -- + -- in GNAT: Corresponds to argv [0] in C. + + type Exit_Status is new Integer; + + Success : constant Exit_Status; + Failure : constant Exit_Status; + + procedure Set_Exit_Status (Code : Exit_Status); + + ------------------------------------ + -- Note on Interface Requirements -- + ------------------------------------ + + -- Services in this package are not supported during the elaboration of an + -- auto-initialized Stand-Alone Library. + + -- If the main program is in Ada, this package works as specified without + -- any other work than the normal steps of WITH'ing the package and then + -- calling the desired routines. + + -- If the main program is not in Ada, then the information must be made + -- available for this package to work correctly. In particular, it is + -- required that the global variable "gnat_argc" contain the number of + -- arguments, and that the global variable "gnat_argv" points to an + -- array of null-terminated strings, the first entry being the command + -- name, and the remaining entries being the command arguments. + + -- These correspond to the normal argc/argv variables passed to a C + -- main program, and the following is an example of a complete C main + -- program that stores the required information: + + -- main(int argc, char **argv, char **envp) + -- { + -- extern int gnat_argc; + -- extern char **gnat_argv; + -- extern char **gnat_envp; + -- gnat_argc = argc; + -- gnat_argv = argv; + -- gnat_envp = envp; + + -- adainit(); + -- adamain(); + -- adafinal(); + -- } + + -- The assignment statements ensure that the necessary information is + -- available for finding the command name and command line arguments. + +private + Success : constant Exit_Status := 0; + Failure : constant Exit_Status := 1; + + -- The following locations support the operation of the package + -- Ada.Command_Line.Remove, which provides facilities for logically + -- removing arguments from the command line. If one of the remove + -- procedures is called in this unit, then Remove_Args/Remove_Count + -- are set to indicate which arguments are removed. If no such calls + -- have been made, then Remove_Args is null. + + Remove_Count : Natural; + -- Number of arguments reflecting removals. Not defined unless + -- Remove_Args is non-null. + + type Arg_Nums is array (Positive range <>) of Positive; + type Arg_Nums_Ptr is access Arg_Nums; + -- An array that maps logical argument numbers (reflecting removal) + -- to physical argument numbers (e.g. if the first argument has been + -- removed, but not the second, then Arg_Nums (1) will be set to 2. + + Remove_Args : Arg_Nums_Ptr := null; + -- Left set to null if no remove calls have been made, otherwise set + -- to point to an appropriate mapping array. Only the first Remove_Count + -- elements are relevant. + + pragma Import (C, Set_Exit_Status, "__gnat_set_exit_status"); + +end Ada.Command_Line; diff --git a/gcc/ada/a-contai.ads b/gcc/ada/a-contai.ads new file mode 100644 index 000000000..be8a80874 --- /dev/null +++ b/gcc/ada/a-contai.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Containers is + pragma Pure; + + type Hash_Type is mod 2**32; + type Count_Type is range 0 .. 2**31 - 1; + + Capacity_Error : exception; + +end Ada.Containers; diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb new file mode 100644 index 000000000..6a3d186a2 --- /dev/null +++ b/gcc/ada/a-convec.adb @@ -0,0 +1,3120 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Generic_Array_Sort; +with Ada.Unchecked_Deallocation; + +with System; use type System.Address; + +package body Ada.Containers.Vectors is + + procedure Free is + new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); + + --------- + -- "&" -- + --------- + + 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; + + declare + RE : Elements_Array renames + Right.Elements.EA (Index_Type'First .. Right.Last); + + Elements : constant Elements_Access := + new Elements_Type'(Right.Last, RE); + + begin + return (Controlled with Elements, Right.Last, 0, 0); + end; + end if; + + if RN = 0 then + declare + LE : Elements_Array renames + Left.Elements.EA (Index_Type'First .. Left.Last); + + Elements : constant Elements_Access := + new Elements_Type'(Left.Last, LE); + + begin + return (Controlled with Elements, Left.Last, 0, 0); + end; + + 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 LN > Count_Type'Last - RN then + raise Constraint_Error with "new length is out of range"; + end if; + + -- It is now safe 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 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 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 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 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.EA (Index_Type'First .. Left.Last); + + RE : Elements_Array renames + Right.Elements.EA (Index_Type'First .. Right.Last); + + Elements : constant Elements_Access := + new Elements_Type'(Last, LE & RE); + + begin + return (Controlled with Elements, Last, 0, 0); + end; + end "&"; + + function "&" (Left : Vector; 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. + + -- Here we handle the easy case first, when the vector parameter (Left) + -- is empty. + + if Left.Is_Empty then + declare + Elements : constant Elements_Access := + new Elements_Type' + (Last => Index_Type'First, + EA => (others => Right)); + + begin + return (Controlled with Elements, Index_Type'First, 0, 0); + end; + end if; + + -- The vector parameter is not empty, so 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 Left.Length = Count_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; + + if Left.Last >= Index_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; + + declare + Last : constant Index_Type := Left.Last + 1; + + LE : Elements_Array renames + Left.Elements.EA (Index_Type'First .. Left.Last); + + Elements : constant Elements_Access := + new Elements_Type' + (Last => Last, + EA => LE & Right); + + begin + return (Controlled with Elements, Last, 0, 0); + end; + end "&"; + + function "&" (Left : Element_Type; Right : Vector) 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. + + -- Here we handle the easy case first, when the vector parameter (Right) + -- is empty. + + if Right.Is_Empty then + declare + Elements : constant Elements_Access := + new Elements_Type' + (Last => Index_Type'First, + EA => (others => Left)); + + begin + return (Controlled with Elements, Index_Type'First, 0, 0); + end; + end if; + + -- The vector parameter is not empty, so 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 Right.Length = Count_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; + + if Right.Last >= Index_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; + + declare + Last : constant Index_Type := Right.Last + 1; + + RE : Elements_Array renames + Right.Elements.EA (Index_Type'First .. Right.Last); + + Elements : constant Elements_Access := + new Elements_Type' + (Last => Last, + EA => Left & RE); + + begin + return (Controlled with Elements, Last, 0, 0); + end; + 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 Index_Type'First >= Index_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; + + declare + Last : constant Index_Type := Index_Type'First + 1; + + Elements : constant Elements_Access := + new Elements_Type' + (Last => Last, + EA => (Left, Right)); + + begin + return (Controlled with Elements, Last, 0, 0); + end; + end "&"; + + --------- + -- "=" -- + --------- + + overriding function "=" (Left, Right : Vector) return Boolean is + begin + if Left'Address = Right'Address then + return True; + end if; + + if Left.Last /= Right.Last then + return False; + end if; + + 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; + + return True; + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Vector) is + begin + 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; + Container.Busy := 0; + Container.Lock := 0; + + -- 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; + end if; + + if Container.Last = Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; + end if; + + Insert + (Container, + Container.Last + 1, + New_Item); + end Append; + + procedure Append + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + if Count = 0 then + return; + end if; + + if Container.Last = Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; + end if; + + Insert + (Container, + Container.Last + 1, + New_Item, + Count); + end Append; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Vector) return Count_Type is + begin + if Container.Elements = null then + return 0; + end if; + + return Container.Elements.EA'Length; + end Capacity; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Vector) is + begin + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + Container.Last := No_Index; + end Clear; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Vector; + Item : Element_Type) return Boolean + is + begin + return Find_Index (Container, Item) /= No_Index; + end Contains; + + ------------ + -- 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 Index < Index_Type'First then + raise Constraint_Error with "Index is out of range (too small)"; + end if; + + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows the + -- corner case of deleting no items from the back end of the vector to + -- be treated as a no-op. (It is assumed that specifying an index value + -- greater than Last + 1 indicates some deeper flaw in the caller's + -- algorithm, so that case is treated as a proper error.) + + if Index > Old_Last then + if Index > Old_Last + 1 then + raise Constraint_Error with "Index is out of range (too large)"; + end if; + + return; + end if; + + -- 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. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + -- We first calculate what's available for deletion starting at + -- Index. Here and elsewhere we use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate values. (See function + -- Length for more information.) + + if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then + Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; + + else + Count2 := Count_Type'Base (Old_Last - Index + 1); + end if; + + -- If more elements are requested (Count) for deletion than are + -- available (Count2) for deletion beginning at Index, then everything + -- from Index is deleted. There are no elements to slide down, and so + -- all we need to do is set the value of Container.Last. + + if Count >= Count2 then + Container.Last := Index - 1; + return; + end if; + + -- There are some elements aren't being deleted (the requested count was + -- less than the available count), so we must slide them down to + -- Index. We first calculate the index values of the respective array + -- slices, using the wider of Index_Type'Base and Count_Type'Base as the + -- type for intermediate calculations. 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'Pos (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 + pragma Warnings (Off, Position); + + 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 denotes wrong container"; + end if; + + if 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; + end if; + + if Count >= Length (Container) then + Clear (Container); + return; + end if; + + Delete (Container, Index_Type'First, Count); + 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. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + -- There is no restriction on how large Count can be when deleting + -- items. If it is equal or greater than the current length, then this + -- is equivalent to clearing the vector. (In particular, there's no need + -- for us to actually calculate the new value for Last.) + + -- If the requested count is less than the current length, then we must + -- calculate the new value for Last. For the type we use the widest of + -- Index_Type'Base and Count_Type'Base for the intermediate values of + -- our calculation. (See the comments in Length for more information.) + + if Count >= 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 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 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; + + return Position.Container.Elements.EA (Position.Index); + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Container : in out Vector) is + X : Elements_Access := Container.Elements; + + begin + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + Container.Elements := null; + Container.Last := No_Index; + Free (X); + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + begin + if 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; + + for J in Position.Index .. Container.Last loop + if Container.Elements.EA (J) = Item then + return (Container'Unchecked_Access, J); + end if; + end loop; + + return No_Element; + end Find; + + ---------------- + -- Find_Index -- + ---------------- + + function Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'First) return Extended_Index + is + 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'Unchecked_Access, Index_Type'First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Vector) return Element_Type is + begin + if Container.Last = No_Index then + raise Constraint_Error with "Container is empty"; + end if; + + return Container.Elements.EA (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; + + declare + EA : Elements_Array renames Container.Elements.EA; + begin + for I in Index_Type'First .. Container.Last - 1 loop + if EA (I + 1) < EA (I) then + return False; + end if; + end loop; + end; + + return True; + end Is_Sorted; + + ----------- + -- Merge -- + ----------- + + procedure Merge (Target, Source : in out Vector) is + I : Index_Type'Base := Target.Last; + J : Index_Type'Base; + + begin + if Target.Last < Index_Type'First then + Move (Target => Target, Source => Source); + return; + end if; + + if Target'Address = Source'Address then + return; + end if; + + if Source.Last < Index_Type'First then + return; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + Target.Set_Length (Length (Target) + Length (Source)); + + declare + TA : Elements_Array renames Target.Elements.EA; + SA : Elements_Array renames Source.Elements.EA; + + 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; + return; + 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; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is locked)"; + end if; + + Sort (Container.Elements.EA (Index_Type'First .. Container.Last)); + end Sort; + + end Generic_Sorting; + + ----------------- + -- 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 + 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 + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying where the new + -- items should be inserted, so we must manually check. (That the user + -- is allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + + if Before < Index_Type'First then + raise Constraint_Error with + "Before index is out of range (too small)"; + end if; + + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for the + -- case of appending items to the back end of the vector. (It is assumed + -- that specifying an index value greater than Last + 1 indicates some + -- deeper flaw in the caller's algorithm, so that case is treated as a + -- proper error.) + + if Before > Container.Last + and then Before > 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 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). + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + elsif Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is less + -- than 0, so it is safe to compute the following sum without fear of + -- overflow. + + J := Count_Type'Base (No_Index) + Count_Type'Last; + + if J <= Count_Type'Base (Index_Type'Last) then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the maximum + -- number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- 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 + 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. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + -- 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'Pos (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; + 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'Pos (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'Pos (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'Pos (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'Pos (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'Pos (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 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 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 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 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 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 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 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 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 + 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 + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying where the new + -- items should be inserted, so we must manually check. (That the user + -- is allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + + if Before < Index_Type'First then + raise Constraint_Error with + "Before index is out of range (too small)"; + end if; + + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for the + -- case of appending items to the back end of the vector. (It is assumed + -- that specifying an index value greater than Last + 1 indicates some + -- deeper flaw in the caller's algorithm, so that case is treated as a + -- proper error.) + + if Before > Container.Last + and then Before > 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 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). + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + elsif Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is less + -- than 0, so it is safe to compute the following sum without fear of + -- overflow. + + J := Count_Type'Base (No_Index) + Count_Type'Last; + + if J <= Count_Type'Base (Index_Type'Last) then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the maximum + -- number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- 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 + 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. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + -- 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'Pos (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'Pos (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'Pos (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 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 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 + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; + + begin + B := B + 1; + + begin + for Indx in Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unchecked_Access, Indx)); + end loop; + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : Vector) return Cursor is + begin + if Is_Empty (Container) then + return No_Element; + end if; + + return (Container'Unchecked_Access, Container.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Vector) return Element_Type is + begin + if Container.Last = No_Index then + raise Constraint_Error with "Container is empty"; + end if; + + return Container.Elements.EA (Container.Last); + 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 Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (Target is busy)"; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (Source is busy)"; + end if; + + 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; + end if; + + if Position.Index < Position.Container.Last then + return (Position.Container, Position.Index + 1); + end if; + + return No_Element; + end Next; + + ---------- + -- Next -- + ---------- + + procedure Next (Position : in out Cursor) is + begin + if Position.Container = null then + return; + end if; + + if 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; + end if; + + if 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; + end if; + + if Position.Index > Index_Type'First then + return (Position.Container, Position.Index - 1); + end if; + + return No_Element; + end Previous; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Container : Vector; + Index : Index_Type; + Process : not null access procedure (Element : Element_Type)) + is + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; + L : Natural renames V.Lock; + + begin + if Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + B := B + 1; + L := L + 1; + + begin + Process (V.Elements.EA (Index)); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end Query_Element; + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if 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); + + 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; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Vector; + Index : Index_Type; + New_Item : Element_Type) + is + begin + if Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is locked)"; + end if; + + 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 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; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is locked)"; + end if; + + 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). + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + 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'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 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 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 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 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. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + 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. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (vector is busy)"; + end if; + + -- 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; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is locked)"; + end if; + + declare + I, J : Index_Type; + E : Elements_Type renames Container.Elements.all; + + begin + I := Index_Type'First; + J := Container.Last; + while I < J loop + declare + EI : constant Element_Type := E.EA (I); + + begin + E.EA (I) := E.EA (J); + E.EA (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 Position.Container /= null + and then Position.Container /= Container'Unchecked_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); + + for Indx in reverse Index_Type'First .. Last loop + if Container.Elements.EA (Indx) = Item then + return (Container'Unchecked_Access, Indx); + end if; + end loop; + + return No_Element; + 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 + 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 + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; + + begin + B := B + 1; + + begin + for Indx in reverse Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unchecked_Access, Indx)); + end loop; + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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 then 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 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 I > Container.Last then + raise Constraint_Error with "I index is out of range"; + end if; + + if J > Container.Last then + raise Constraint_Error with "J index is out of range"; + end if; + + if I = J then + return; + end if; + + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is locked)"; + end if; + + 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 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; + + 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'Unchecked_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; + 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'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 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 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 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 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, 0, 0); + 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'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 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 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 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 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 Vector'(Controlled with Elements, Last, 0, 0); + 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 + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; + + begin + if Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + B := B + 1; + L := L + 1; + + begin + Process (Container.Elements.EA (Index)); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + 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 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; + + 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; + +end Ada.Containers.Vectors; diff --git a/gcc/ada/a-convec.ads b/gcc/ada/a-convec.ads new file mode 100644 index 000000000..4b7096599 --- /dev/null +++ b/gcc/ada/a-convec.ads @@ -0,0 +1,380 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +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 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; + pragma Preelaborable_Initialization (Vector); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Vector : constant Vector; + + No_Element : constant Cursor; + + 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)); + + 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; + + function Has_Element (Position : Cursor) 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)); + + 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); + + type Elements_Array is array (Index_Type range <>) of Element_Type; + function "=" (L, R : Elements_Array) return Boolean is abstract; + + type Elements_Type (Last : Index_Type) is limited record + EA : Elements_Array (Index_Type'First .. Last); + end record; + + type Elements_Access is access Elements_Type; + + use Ada.Finalization; + + type Vector is new Controlled with record + Elements : Elements_Access; + Last : Extended_Index := No_Index; + Busy : Natural := 0; + Lock : Natural := 0; + end record; + + overriding + procedure Adjust (Container : in out Vector); + + overriding + procedure Finalize (Container : in out Vector); + + use Ada.Streams; + + 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 constant 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; + + Empty_Vector : constant Vector := (Controlled with null, No_Index, 0, 0); + + No_Element : constant Cursor := Cursor'(null, Index_Type'First); + +end Ada.Containers.Vectors; diff --git a/gcc/ada/a-coorma.adb b/gcc/ada/a-coorma.adb new file mode 100644 index 000000000..ba865202d --- /dev/null +++ b/gcc/ada/a-coorma.adb @@ -0,0 +1,1244 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +------------------------------------------------------------------------------ + +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); + +package body Ada.Containers.Ordered_Maps is + + ----------------------------- + -- Node Access Subprograms -- + ----------------------------- + + -- These subprograms provide a functional interface to access fields + -- of a node, and a procedural interface for modifying these values. + + function Color (Node : Node_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 Left.Node = null then + raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; + end if; + + if 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 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 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 Left.Node = null then + raise Constraint_Error with "Left cursor of "">"" equals No_Element"; + end if; + + if 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 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 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; + + ------------- + -- 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; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Map; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + --------------- + -- 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 Position.Node = null then + raise Constraint_Error with + "Position cursor of Delete equals No_Element"; + end if; + + if 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 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 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 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; + + ---------- + -- Find -- + ---------- + + function Find (Container : Map; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return 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; + end if; + + return Cursor'(Container'Unrestricted_Access, T.First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Map) return Element_Type is + T : Tree_Type renames Container.Tree; + + begin + if 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 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; + 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; + + Deallocate (X); + end Free; + + ----------------- + -- 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 + if Container.Tree.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (map is locked)"; + end if; + + 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 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 + -- k > node same as node < k + + return Right.Key < Left; + end Is_Greater_Key_Node; + + ---------------------- + -- Is_Less_Key_Node -- + ---------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_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; + + B : Natural renames Container.Tree'Unrestricted_Access.all.Busy; + + -- Start of processing for Iterate + + begin + B := B + 1; + + begin + Local_Iterate (Container.Tree); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Iterate; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + if 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; + end if; + + return Cursor'(Container'Unrestricted_Access, T.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Map) return Element_Type is + T : Tree_Type renames Container.Tree; + + begin + if 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 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; + + ------------ + -- 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; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : Element_Type)) + is + begin + if 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; + + B : Natural renames T.Busy; + L : Natural renames T.Lock; + + begin + B := B + 1; + L := L + 1; + + declare + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; + + begin + Process (K, E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + 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; + + ------------- + -- 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 Node = null then + raise Constraint_Error with "key not in map"; + end if; + + if Container.Tree.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (map is locked)"; + end if; + + 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 Position.Node = null then + raise Constraint_Error with + "Position cursor of Replace_Element equals No_Element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor of Replace_Element designates wrong map"; + end if; + + if Container.Tree.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (map is locked)"; + end if; + + 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; + + B : Natural renames Container.Tree'Unrestricted_Access.all.Busy; + + -- Start of processing for Reverse_Iterate + + begin + B := B + 1; + + begin + Local_Reverse_Iterate (Container.Tree); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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 Position.Node = null then + raise Constraint_Error with + "Position cursor of Update_Element equals No_Element"; + end if; + + if 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; + + B : Natural renames T.Busy; + L : Natural renames T.Lock; + + begin + B := B + 1; + L := L + 1; + + declare + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; + + begin + Process (K, E); + + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + 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; + +end Ada.Containers.Ordered_Maps; diff --git a/gcc/ada/a-coorma.ads b/gcc/ada/a-coorma.ads new file mode 100644 index 000000000..9d404c29d --- /dev/null +++ b/gcc/ada/a-coorma.ads @@ -0,0 +1,258 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +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 Preelaborate; + pragma Remote_Types; + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + + type Map is tagged private; + pragma Preelaborable_Initialization (Map); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Map : constant Map; + + No_Element : constant Cursor; + + 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)); + + 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 Has_Element (Position : Cursor) 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)); + +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 : 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; + use Ada.Finalization; + use Ada.Streams; + + 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; + + No_Element : constant Cursor := Cursor'(null, null); + + 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; + + Empty_Map : constant Map := + (Controlled with Tree => (First => null, + Last => null, + Root => null, + Length => 0, + Busy => 0, + Lock => 0)); + +end Ada.Containers.Ordered_Maps; diff --git a/gcc/ada/a-coormu.adb b/gcc/ada/a-coormu.adb new file mode 100644 index 000000000..b59f6f554 --- /dev/null +++ b/gcc/ada/a-coormu.adb @@ -0,0 +1,1767 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +------------------------------------------------------------------------------ + +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); + +package body Ada.Containers.Ordered_Multisets is + + ----------------------------- + -- Node Access Subprograms -- + ----------------------------- + + -- These subprograms provide a functional interface to access fields + -- of a node, and a procedural interface for modifying these values. + + function Color (Node : Node_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; + + ------------- + -- 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; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Item : Element_Type) return Boolean is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + --------------- + -- 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; + + ---------- + -- 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; + + ------------------- + -- 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; + B : Natural renames T.Busy; + + -- Start of processing for Iterate + + begin + B := B + 1; + + begin + Local_Iterate (T, Key); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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; + B : Natural renames T.Busy; + + -- Start of processing for Reverse_Iterate + + begin + B := B + 1; + + begin + Local_Reverse_Iterate (T, Key); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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); + + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + + 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; + B : Natural renames T.Busy; + + -- Start of processing for Iterate + + begin + B := B + 1; + + begin + Local_Iterate (T); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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; + B : Natural renames T.Busy; + + -- Start of processing for Iterate + + begin + B := B + 1; + + begin + Local_Iterate (T, Item); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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; + + ------------------ + -- 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; + + ------------- + -- 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 + if Node = null 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 = 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; + + B : Natural renames T.Busy; + L : Natural renames T.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (Position.Node.Element); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + 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; + + --------------------- + -- 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 + if Tree.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + 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; + B : Natural renames T.Busy; + + -- Start of processing for Reverse_Iterate + + begin + B := B + 1; + + begin + Local_Reverse_Iterate (T); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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; + B : Natural renames T.Busy; + + -- Start of processing for Reverse_Iterate + + begin + B := B + 1; + + begin + Local_Reverse_Iterate (T, Item); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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; + +end Ada.Containers.Ordered_Multisets; diff --git a/gcc/ada/a-coormu.ads b/gcc/ada/a-coormu.ads new file mode 100644 index 000000000..5f5285b88 --- /dev/null +++ b/gcc/ada/a-coormu.ads @@ -0,0 +1,497 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception 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; + +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 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; + 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 "=" (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. + + 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 Has_Element (Position : Cursor) return Boolean; + -- Equivalent to Position /= 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). + + 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; + use Ada.Finalization; + use Ada.Streams; + + 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; + + 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; + + Empty_Set : constant Set := + (Controlled with Tree => (First => null, + Last => null, + Root => null, + Length => 0, + Busy => 0, + Lock => 0)); + +end Ada.Containers.Ordered_Multisets; diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb new file mode 100644 index 000000000..d4e73029b --- /dev/null +++ b/gcc/ada/a-coorse.adb @@ -0,0 +1,1657 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +------------------------------------------------------------------------------ + +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); + +package body Ada.Containers.Ordered_Sets is + + ------------------------------ + -- 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 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 : 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 ">"; + + 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 ">"; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust is new Tree_Operations.Generic_Adjust (Copy_Tree); + + procedure Adjust (Container : in out Set) is + begin + Adjust (Container.Tree); + end Adjust; + + ------------- + -- 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; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Set; + Item : Element_Type) return Boolean + is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + --------------- + -- 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 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"); + + 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 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 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 + 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; + + ---------- + -- 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; + + ------------------- + -- 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 + X : Node_Access := Key_Keys.Find (Container.Tree, Key); + + begin + if 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 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 + 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; + + ---------- + -- 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; + + --------- + -- 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; + + ------------- + -- 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 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 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 Update_Element_Preserving_Key"); + + declare + E : Element_Type renames Position.Node.Element; + K : constant Key_Type := Key (E); + + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + + 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; + + end Generic_Keys; + + ----------------- + -- 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 + if Container.Tree.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + 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 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.Tree'Unrestricted_Access.all; + B : Natural renames T.Busy; + + -- Start of processing for Iterate + + begin + B := B + 1; + + begin + Local_Iterate (T); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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; + + ------------------ + -- 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 -- + ---------- + + 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; + + ------------- + -- 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; + + ------------------- + -- 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; + + B : Natural renames T.Busy; + L : Natural renames T.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (Position.Node.Element); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + 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; + + ------------- + -- 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 Node = null then + raise Constraint_Error with + "attempt to replace element not in set"; + end if; + + if Container.Tree.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + 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; + + -- Start of processing for Replace_Element + + begin + if Item < Node.Element + or else Node.Element < Item + then + null; + + else + if Tree.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + Node.Element := Item; + return; + end if; + + Hint := Element_Keys.Ceiling (Tree, Item); + + if Hint = null then + null; + + elsif Item < Hint.Element then + if Hint = Node then + if Tree.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (set is locked)"; + end if; + + Node.Element := Item; + return; + end if; + + else + pragma Assert (not (Hint.Element < Item)); + raise Program_Error with "attempt to replace existing element"; + end if; + + 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); + 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; + B : Natural renames T.Busy; + + -- Start of processing for Reverse_Iterate + + begin + B := B + 1; + + begin + Local_Reverse_Iterate (T); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + 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; + +end Ada.Containers.Ordered_Sets; diff --git a/gcc/ada/a-coorse.ads b/gcc/ada/a-coorse.ads new file mode 100644 index 000000000..1022fd655 --- /dev/null +++ b/gcc/ada/a-coorse.ads @@ -0,0 +1,309 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +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 Preelaborate; + pragma Remote_Types; + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean; + + type Set is tagged private; + pragma Preelaborable_Initialization (Set); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Set : constant Set; + + No_Element : constant Cursor; + + 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)); + + 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 Has_Element (Position : Cursor) 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)); + + 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)); + + 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; + use Ada.Finalization; + use Ada.Streams; + + 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; + + 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; + + Empty_Set : constant Set := + (Controlled with Tree => (First => null, + Last => null, + Root => null, + Length => 0, + Busy => 0, + Lock => 0)); + +end Ada.Containers.Ordered_Sets; diff --git a/gcc/ada/a-coprnu.adb b/gcc/ada/a-coprnu.adb new file mode 100644 index 000000000..95eff8bb5 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception 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 new file mode 100644 index 000000000..33af3e191 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- This package declares the prime numbers array used to implement hashed +-- containers. Bucket arrays are always allocated with a prime-number +-- length (computed using To_Prime below), as this produces better scatter +-- when hash values are folded. + +package Ada.Containers.Prime_Numbers is + pragma Pure; + + type Primes_Type is array (Positive range <>) of Hash_Type; + + Primes : constant Primes_Type := + (53, 97, 193, 389, 769, + 1543, 3079, 6151, 12289, 24593, + 49157, 98317, 196613, 393241, 786433, + 1572869, 3145739, 6291469, 12582917, 25165843, + 50331653, 100663319, 201326611, 402653189, 805306457, + 1610612741, 3221225473, 4294967291); + + function To_Prime (Length : Count_Type) return Hash_Type; + -- Returns the smallest value in Primes not less than Length + +end Ada.Containers.Prime_Numbers; diff --git a/gcc/ada/a-coteio.ads b/gcc/ada/a-coteio.ads new file mode 100755 index 000000000..abba889ec --- /dev/null +++ b/gcc/ada/a-coteio.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C O M P L E X _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Ada 2005 AI-328 + +with Ada.Text_IO.Complex_IO; +with Ada.Numerics.Complex_Types; + +pragma Elaborate_All (Ada.Text_IO.Complex_IO); + +package Ada.Complex_Text_IO is + new Ada.Text_IO.Complex_IO (Ada.Numerics.Complex_Types); diff --git a/gcc/ada/a-crbltr.ads b/gcc/ada/a-crbltr.ads new file mode 100644 index 000000000..30ceff71c --- /dev/null +++ b/gcc/ada/a-crbltr.ads @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +------------------------------------------------------------------------------ + +-- This package declares the tree type used to implement ordered containers + +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; + Last : Node_Access; + Root : Node_Access; + Length : Count_Type := 0; + Busy : Natural := 0; + Lock : Natural := 0; + end record; + 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; + + 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; + Busy : Natural := 0; + Lock : Natural := 0; + Free : Count_Type'Base := -1; + Nodes : Nodes_Type (1 .. Capacity); + end record; + 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 new file mode 100644 index 000000000..59d25be45 --- /dev/null +++ b/gcc/ada/a-crbtgk.adb @@ -0,0 +1,563 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_KEYS -- +-- -- +-- 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.Red_Black_Trees.Generic_Keys is + + package Ops renames Tree_Operations; + + ------------- + -- Ceiling -- + ------------- + + -- AKA Lower_Bound + + function Ceiling (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_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 + Y : Node_Access; + X : Node_Access; + + begin + 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 then + return null; + end if; + + if Is_Less_Key_Node (Key, Y) then + return null; + end if; + + return Y; + end Find; + + ----------- + -- Floor -- + ----------- + + function Floor (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 + 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 + Y : Node_Access := null; + X : Node_Access := Tree.Root; + + begin + 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; + + -- If Inserted is True, then this means either that Tree is + -- empty, or there was a least one node (strictly) greater than + -- Key. Otherwise, it means that Key is equal to or greater than + -- every node. + + if Inserted then + if Y = Tree.First then + Insert_Post (Tree, Y, True, Node); + return; + end if; + + Node := Ops.Previous (Y); + + else + Node := Y; + end if; + + -- Here Node has a value that is less than or equal to Key. We + -- now have to resolve whether Key is equal to or greater than + -- Node, which determines whether the insertion succeeds. + + if Is_Greater_Key_Node (Key, Node) then + Insert_Post (Tree, Y, Inserted, Node); + Inserted := True; + return; + end if; + + 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 + 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 null, 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 = null then -- largest + if Tree.Last = null + or else Is_Greater_Key_Node (Key, 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, Position) then + declare + Before : constant Node_Access := Ops.Previous (Position); + + begin + if Before = null then + Insert_Post (Tree, Tree.First, True, Node); + Inserted := True; + + elsif Is_Greater_Key_Node (Key, Before) then + if Ops.Right (Before) = null 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, Position) then + declare + After : constant Node_Access := Ops.Next (Position); + + begin + if After = null then + Insert_Post (Tree, Tree.Last, False, Node); + Inserted := True; + + elsif Is_Less_Key_Node (Key, After) then + if Ops.Right (Position) = null 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; + Y : Node_Access; + Before : Boolean; + Z : out Node_Access) + is + begin + if Tree.Length = Count_Type'Last then + raise Constraint_Error with "too many elements"; + end if; + + if Tree.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + 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 new file mode 100644 index 000000000..b2c21cdb0 --- /dev/null +++ b/gcc/ada/a-crbtgk.ads @@ -0,0 +1,192 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_KEYS -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +-- 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; + + type Key_Type (<>) is limited private; + + with function Is_Less_Key_Node + (L : Key_Type; + R : Node_Access) return Boolean; + + with function Is_Greater_Key_Node + (L : Key_Type; + R : Node_Access) return Boolean; + +package Ada.Containers.Red_Black_Trees.Generic_Keys is + pragma Pure; + + generic + with function New_Node return Node_Access; + procedure Generic_Insert_Post + (Tree : in out Tree_Type; + Y : Node_Access; + Before : Boolean; + Z : out Node_Access); + -- Completes an insertion after the insertion position has been + -- determined. On output Z contains a pointer to the newly inserted + -- node, allocated using New_Node. If Tree is busy then + -- Program_Error is raised. If Y is null, then Tree must be empty. + -- Otherwise Y denotes the insertion position, and Before specifies + -- whether the new node is Y's left (True) or right (False) child. + + generic + with procedure Insert_Post + (T : in out Tree_Type; + Y : Node_Access; + B : Boolean; + Z : out Node_Access); + + procedure Generic_Conditional_Insert + (Tree : in out Tree_Type; + Key : Key_Type; + Node : out Node_Access; + Inserted : out Boolean); + -- Inserts a new node in Tree, but only if the tree does not already + -- contain Key. Generic_Conditional_Insert first searches for a key + -- equivalent to Key in Tree. If an equivalent key is found, then on + -- output Node designates the node with that key and Inserted is + -- False; there is no allocation and Tree is not modified. Otherwise + -- Node designates a new node allocated using Insert_Post, and + -- Inserted is True. + + generic + with procedure Insert_Post + (T : in out Tree_Type; + Y : Node_Access; + B : Boolean; + Z : out Node_Access); + + procedure Generic_Unconditional_Insert + (Tree : in out Tree_Type; + Key : Key_Type; + Node : out Node_Access); + -- Inserts a new node in Tree. On output Node designates the new + -- node, which is allocated using Insert_Post. The node is inserted + -- immediately after already-existing equivalent keys. + + generic + with procedure Insert_Post + (T : in out Tree_Type; + Y : Node_Access; + B : Boolean; + Z : out Node_Access); + + with procedure Unconditional_Insert_Sans_Hint + (Tree : in out Tree_Type; + Key : Key_Type; + Node : out Node_Access); + + procedure Generic_Unconditional_Insert_With_Hint + (Tree : in out Tree_Type; + Hint : Node_Access; + Key : Key_Type; + Node : out Node_Access); + -- Inserts a new node in Tree near position Hint, to avoid having to + -- search from the root for the insertion position. If Hint is null + -- then Generic_Unconditional_Insert_With_Hint attempts to insert + -- the new node after Tree.Last. If Hint is non-null then if Key is + -- less than Hint, it attempts to insert the new node immediately + -- prior to Hint. Otherwise it attempts to insert the node + -- immediately following Hint. We say "attempts" above to emphasize + -- that insertions always preserve invariants with respect to key + -- order, even when there's a hint. So if Key can't be inserted + -- immediately near Hint, then the new node is inserted in the + -- normal way, by searching for the correct position starting from + -- the root. + + generic + with procedure Insert_Post + (T : in out Tree_Type; + Y : Node_Access; + B : Boolean; + Z : out Node_Access); + + with procedure Conditional_Insert_Sans_Hint + (Tree : in out Tree_Type; + Key : Key_Type; + Node : out Node_Access; + Inserted : out Boolean); + + procedure Generic_Conditional_Insert_With_Hint + (Tree : in out Tree_Type; + Position : Node_Access; -- the hint + Key : Key_Type; + Node : out Node_Access; + Inserted : out Boolean); + -- Inserts a new node in Tree if the tree does not already contain + -- Key, using Position as a hint about where to insert the new node. + -- See Generic_Unconditional_Insert_With_Hint for more details about + -- hint semantics. + + function Find + (Tree : Tree_Type; + Key : Key_Type) return Node_Access; + -- Searches Tree for the smallest node equivalent to Key + + function Ceiling + (Tree : Tree_Type; + Key : Key_Type) return Node_Access; + -- Searches Tree for the smallest node equal to or greater than Key + + function Floor + (Tree : Tree_Type; + Key : Key_Type) return Node_Access; + -- Searches Tree for the largest node less than or equal to Key + + function Upper_Bound + (Tree : Tree_Type; + Key : Key_Type) return Node_Access; + -- Searches Tree for the smallest node greater than Key + + generic + with procedure Process (Node : Node_Access); + procedure Generic_Iteration + (Tree : Tree_Type; + Key : Key_Type); + -- Calls Process for each node in Tree equivalent to Key, in order + -- from earliest in range to latest. + + generic + with procedure Process (Node : Node_Access); + procedure Generic_Reverse_Iteration + (Tree : Tree_Type; + Key : Key_Type); + -- Calls Process for each node in Tree equivalent to Key, but in + -- order from largest in range to earliest. + +end Ada.Containers.Red_Black_Trees.Generic_Keys; diff --git a/gcc/ada/a-crbtgo.adb b/gcc/ada/a-crbtgo.adb new file mode 100644 index 000000000..c8ddcff02 --- /dev/null +++ b/gcc/ada/a-crbtgo.adb @@ -0,0 +1,1155 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_OPERATIONS -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +-- The references below to "CLR" refer to the following book, from which +-- several of the algorithms here were adapted: +-- Introduction to Algorithms +-- by Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest +-- Publisher: The MIT Press (June 18, 1990) +-- ISBN: 0262031418 + +with System; use type System.Address; + +package body Ada.Containers.Red_Black_Trees.Generic_Operations is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access); + + procedure Delete_Swap (Tree : in out Tree_Type; Z, Y : Node_Access); + + procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access); + procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access); + +-- Why is all the following code commented out ??? + +-- --------------------- +-- -- Check_Invariant -- +-- --------------------- + +-- procedure Check_Invariant (Tree : Tree_Type) is +-- Root : constant Node_Access := Tree.Root; +-- +-- function Check (Node : Node_Access) return Natural; +-- +-- ----------- +-- -- Check -- +-- ----------- +-- +-- function Check (Node : Node_Access) return Natural is +-- begin +-- if Node = null then +-- return 0; +-- end if; +-- +-- if Color (Node) = Red then +-- declare +-- L : constant Node_Access := Left (Node); +-- begin +-- pragma Assert (L = null or else Color (L) = Black); +-- null; +-- end; +-- +-- declare +-- R : constant Node_Access := Right (Node); +-- begin +-- pragma Assert (R = null or else Color (R) = Black); +-- null; +-- end; +-- +-- declare +-- NL : constant Natural := Check (Left (Node)); +-- NR : constant Natural := Check (Right (Node)); +-- begin +-- pragma Assert (NL = NR); +-- return NL; +-- end; +-- end if; +-- +-- declare +-- NL : constant Natural := Check (Left (Node)); +-- NR : constant Natural := Check (Right (Node)); +-- begin +-- pragma Assert (NL = NR); +-- return NL + 1; +-- end; +-- end Check; +-- +-- -- Start of processing for Check_Invariant +-- +-- begin +-- if Root = null then +-- pragma Assert (Tree.First = null); +-- pragma Assert (Tree.Last = null); +-- pragma Assert (Tree.Length = 0); +-- null; +-- +-- else +-- pragma Assert (Color (Root) = Black); +-- pragma Assert (Tree.Length > 0); +-- pragma Assert (Tree.Root /= null); +-- pragma Assert (Tree.First /= null); +-- pragma Assert (Tree.Last /= null); +-- pragma Assert (Parent (Tree.Root) = null); +-- pragma Assert ((Tree.Length > 1) +-- or else (Tree.First = Tree.Last +-- and Tree.First = Tree.Root)); +-- pragma Assert (Left (Tree.First) = null); +-- pragma Assert (Right (Tree.Last) = null); +-- +-- declare +-- L : constant Node_Access := Left (Root); +-- R : constant Node_Access := Right (Root); +-- NL : constant Natural := Check (L); +-- NR : constant Natural := Check (R); +-- begin +-- pragma Assert (NL = NR); +-- null; +-- end; +-- end if; +-- end Check_Invariant; + + ------------------ + -- Delete_Fixup -- + ------------------ + + procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access) is + + -- CLR p274 + + X : Node_Access := Node; + W : Node_Access; + + begin + while X /= Tree.Root + and then Color (X) = Black + loop + if X = Left (Parent (X)) then + W := Right (Parent (X)); + + if Color (W) = Red then + Set_Color (W, Black); + Set_Color (Parent (X), Red); + Left_Rotate (Tree, Parent (X)); + W := Right (Parent (X)); + end if; + + if (Left (W) = null or else Color (Left (W)) = Black) + and then + (Right (W) = null or else Color (Right (W)) = Black) + then + Set_Color (W, Red); + X := Parent (X); + + else + if Right (W) = null + or else Color (Right (W)) = Black + then + -- As a condition for setting the color of the left child to + -- black, the left child access value must be non-null. A + -- truth table analysis shows that if we arrive here, that + -- condition holds, so there's no need for an explicit test. + -- The assertion is here to document what we know is true. + + pragma Assert (Left (W) /= null); + Set_Color (Left (W), Black); + + Set_Color (W, Red); + Right_Rotate (Tree, W); + W := Right (Parent (X)); + end if; + + Set_Color (W, Color (Parent (X))); + Set_Color (Parent (X), Black); + Set_Color (Right (W), Black); + Left_Rotate (Tree, Parent (X)); + X := Tree.Root; + end if; + + else + pragma Assert (X = Right (Parent (X))); + + W := Left (Parent (X)); + + if Color (W) = Red then + Set_Color (W, Black); + Set_Color (Parent (X), Red); + Right_Rotate (Tree, Parent (X)); + W := Left (Parent (X)); + end if; + + if (Left (W) = null or else Color (Left (W)) = Black) + and then + (Right (W) = null or else Color (Right (W)) = Black) + then + Set_Color (W, Red); + X := Parent (X); + + else + if Left (W) = null or else Color (Left (W)) = Black then + + -- As a condition for setting the color of the right child + -- to black, the right child access value must be non-null. + -- A truth table analysis shows that if we arrive here, that + -- condition holds, so there's no need for an explicit test. + -- The assertion is here to document what we know is true. + + pragma Assert (Right (W) /= null); + Set_Color (Right (W), Black); + + Set_Color (W, Red); + Left_Rotate (Tree, W); + W := Left (Parent (X)); + end if; + + Set_Color (W, Color (Parent (X))); + Set_Color (Parent (X), Black); + Set_Color (Left (W), Black); + Right_Rotate (Tree, Parent (X)); + X := Tree.Root; + end if; + end if; + end loop; + + Set_Color (X, Black); + end Delete_Fixup; + + --------------------------- + -- Delete_Node_Sans_Free -- + --------------------------- + + procedure Delete_Node_Sans_Free + (Tree : in out Tree_Type; + Node : Node_Access) + is + -- CLR p273 + + X, Y : Node_Access; + + Z : constant Node_Access := Node; + pragma Assert (Z /= null); + + begin + if Tree.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + -- Why are these all commented out ??? + +-- pragma Assert (Tree.Length > 0); +-- pragma Assert (Tree.Root /= null); +-- pragma Assert (Tree.First /= null); +-- pragma Assert (Tree.Last /= null); +-- pragma Assert (Parent (Tree.Root) = null); +-- pragma Assert ((Tree.Length > 1) +-- or else (Tree.First = Tree.Last +-- and then Tree.First = Tree.Root)); +-- pragma Assert ((Left (Node) = null) +-- or else (Parent (Left (Node)) = Node)); +-- pragma Assert ((Right (Node) = null) +-- or else (Parent (Right (Node)) = Node)); +-- pragma Assert (((Parent (Node) = null) and then (Tree.Root = Node)) +-- or else ((Parent (Node) /= null) and then +-- ((Left (Parent (Node)) = Node) +-- or else (Right (Parent (Node)) = Node)))); + + if Left (Z) = null then + if Right (Z) = null then + if Z = Tree.First then + Tree.First := Parent (Z); + end if; + + if Z = Tree.Last then + Tree.Last := Parent (Z); + end if; + + if Color (Z) = Black then + Delete_Fixup (Tree, Z); + end if; + + pragma Assert (Left (Z) = null); + pragma Assert (Right (Z) = null); + + if Z = Tree.Root then + pragma Assert (Tree.Length = 1); + pragma Assert (Parent (Z) = null); + Tree.Root := null; + elsif Z = Left (Parent (Z)) then + Set_Left (Parent (Z), null); + else + pragma Assert (Z = Right (Parent (Z))); + Set_Right (Parent (Z), null); + end if; + + else + pragma Assert (Z /= Tree.Last); + + X := Right (Z); + + if Z = Tree.First then + Tree.First := Min (X); + end if; + + if Z = Tree.Root then + Tree.Root := X; + elsif Z = Left (Parent (Z)) then + Set_Left (Parent (Z), X); + else + pragma Assert (Z = Right (Parent (Z))); + Set_Right (Parent (Z), X); + end if; + + Set_Parent (X, Parent (Z)); + + if Color (Z) = Black then + Delete_Fixup (Tree, X); + end if; + end if; + + elsif Right (Z) = null then + pragma Assert (Z /= Tree.First); + + X := Left (Z); + + if Z = Tree.Last then + Tree.Last := Max (X); + end if; + + if Z = Tree.Root then + Tree.Root := X; + elsif Z = Left (Parent (Z)) then + Set_Left (Parent (Z), X); + else + pragma Assert (Z = Right (Parent (Z))); + Set_Right (Parent (Z), X); + end if; + + Set_Parent (X, Parent (Z)); + + if Color (Z) = Black then + Delete_Fixup (Tree, X); + end if; + + else + pragma Assert (Z /= Tree.First); + pragma Assert (Z /= Tree.Last); + + Y := Next (Z); + pragma Assert (Left (Y) = null); + + X := Right (Y); + + if X = null then + if Y = Left (Parent (Y)) then + pragma Assert (Parent (Y) /= Z); + Delete_Swap (Tree, Z, Y); + Set_Left (Parent (Z), Z); + + else + pragma Assert (Y = Right (Parent (Y))); + pragma Assert (Parent (Y) = Z); + Set_Parent (Y, Parent (Z)); + + if Z = Tree.Root then + Tree.Root := Y; + elsif Z = Left (Parent (Z)) then + Set_Left (Parent (Z), Y); + else + pragma Assert (Z = Right (Parent (Z))); + Set_Right (Parent (Z), Y); + end if; + + Set_Left (Y, Left (Z)); + Set_Parent (Left (Y), Y); + Set_Right (Y, Z); + Set_Parent (Z, Y); + Set_Left (Z, null); + Set_Right (Z, null); + + declare + Y_Color : constant Color_Type := Color (Y); + begin + Set_Color (Y, Color (Z)); + Set_Color (Z, Y_Color); + end; + end if; + + if Color (Z) = Black then + Delete_Fixup (Tree, Z); + end if; + + pragma Assert (Left (Z) = null); + pragma Assert (Right (Z) = null); + + if Z = Right (Parent (Z)) then + Set_Right (Parent (Z), null); + else + pragma Assert (Z = Left (Parent (Z))); + Set_Left (Parent (Z), null); + end if; + + else + if Y = Left (Parent (Y)) then + pragma Assert (Parent (Y) /= Z); + + Delete_Swap (Tree, Z, Y); + + Set_Left (Parent (Z), X); + Set_Parent (X, Parent (Z)); + + else + pragma Assert (Y = Right (Parent (Y))); + pragma Assert (Parent (Y) = Z); + + Set_Parent (Y, Parent (Z)); + + if Z = Tree.Root then + Tree.Root := Y; + elsif Z = Left (Parent (Z)) then + Set_Left (Parent (Z), Y); + else + pragma Assert (Z = Right (Parent (Z))); + Set_Right (Parent (Z), Y); + end if; + + Set_Left (Y, Left (Z)); + Set_Parent (Left (Y), Y); + + declare + Y_Color : constant Color_Type := Color (Y); + begin + Set_Color (Y, Color (Z)); + Set_Color (Z, Y_Color); + end; + end if; + + if Color (Z) = Black then + Delete_Fixup (Tree, X); + end if; + end if; + end if; + + Tree.Length := Tree.Length - 1; + end Delete_Node_Sans_Free; + + ----------------- + -- Delete_Swap -- + ----------------- + + procedure Delete_Swap + (Tree : in out Tree_Type; + Z, Y : Node_Access) + is + pragma Assert (Z /= Y); + pragma Assert (Parent (Y) /= Z); + + Y_Parent : constant Node_Access := Parent (Y); + Y_Color : constant Color_Type := Color (Y); + + begin + Set_Parent (Y, Parent (Z)); + Set_Left (Y, Left (Z)); + Set_Right (Y, Right (Z)); + Set_Color (Y, Color (Z)); + + if Tree.Root = Z then + Tree.Root := Y; + elsif Right (Parent (Y)) = Z then + Set_Right (Parent (Y), Y); + else + pragma Assert (Left (Parent (Y)) = Z); + Set_Left (Parent (Y), Y); + end if; + + if Right (Y) /= null then + Set_Parent (Right (Y), Y); + end if; + + if Left (Y) /= null then + Set_Parent (Left (Y), Y); + end if; + + Set_Parent (Z, Y_Parent); + Set_Color (Z, Y_Color); + Set_Left (Z, null); + Set_Right (Z, null); + end Delete_Swap; + + -------------------- + -- Generic_Adjust -- + -------------------- + + procedure Generic_Adjust (Tree : in out Tree_Type) is + N : constant Count_Type := Tree.Length; + Root : constant Node_Access := Tree.Root; + + begin + if N = 0 then + pragma Assert (Root = null); + pragma Assert (Tree.Busy = 0); + pragma Assert (Tree.Lock = 0); + return; + end if; + + Tree.Root := null; + Tree.First := null; + Tree.Last := null; + Tree.Length := 0; + + Tree.Root := Copy_Tree (Root); + Tree.First := Min (Tree.Root); + Tree.Last := Max (Tree.Root); + Tree.Length := N; + end Generic_Adjust; + + ------------------- + -- Generic_Clear -- + ------------------- + + procedure Generic_Clear (Tree : in out Tree_Type) is + Root : Node_Access := Tree.Root; + begin + if Tree.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Tree := (First => null, + Last => null, + Root => null, + Length => 0, + Busy => 0, + Lock => 0); + + Delete_Tree (Root); + end Generic_Clear; + + ----------------------- + -- Generic_Copy_Tree -- + ----------------------- + + function Generic_Copy_Tree (Source_Root : Node_Access) return Node_Access is + Target_Root : Node_Access := Copy_Node (Source_Root); + P, X : Node_Access; + + begin + if Right (Source_Root) /= null then + Set_Right + (Node => Target_Root, + Right => Generic_Copy_Tree (Right (Source_Root))); + + Set_Parent + (Node => Right (Target_Root), + Parent => Target_Root); + end if; + + P := Target_Root; + + X := Left (Source_Root); + while X /= null loop + declare + Y : constant Node_Access := Copy_Node (X); + begin + Set_Left (Node => P, Left => Y); + Set_Parent (Node => Y, Parent => P); + + if Right (X) /= null then + Set_Right + (Node => Y, + Right => Generic_Copy_Tree (Right (X))); + + Set_Parent + (Node => Right (Y), + Parent => Y); + end if; + + P := Y; + X := Left (X); + end; + end loop; + + return Target_Root; + exception + when others => + Delete_Tree (Target_Root); + raise; + end Generic_Copy_Tree; + + ------------------------- + -- Generic_Delete_Tree -- + ------------------------- + + procedure Generic_Delete_Tree (X : in out Node_Access) is + Y : Node_Access; + pragma Warnings (Off, Y); + begin + while X /= null loop + Y := Right (X); + Generic_Delete_Tree (Y); + Y := Left (X); + Free (X); + X := Y; + end loop; + end Generic_Delete_Tree; + + ------------------- + -- Generic_Equal -- + ------------------- + + function Generic_Equal (Left, Right : Tree_Type) return Boolean is + L_Node : Node_Access; + R_Node : Node_Access; + + begin + if Left'Address = Right'Address then + return True; + end if; + + if Left.Length /= Right.Length then + return False; + end if; + + L_Node := Left.First; + R_Node := Right.First; + while L_Node /= null loop + if not Is_Equal (L_Node, R_Node) then + return False; + end if; + + L_Node := Next (L_Node); + R_Node := Next (R_Node); + end loop; + + return True; + end Generic_Equal; + + ----------------------- + -- Generic_Iteration -- + ----------------------- + + procedure Generic_Iteration (Tree : Tree_Type) is + procedure Iterate (P : Node_Access); + + ------------- + -- Iterate -- + ------------- + + procedure Iterate (P : Node_Access) is + X : Node_Access := P; + begin + while X /= null loop + Iterate (Left (X)); + Process (X); + X := Right (X); + end loop; + end Iterate; + + -- Start of processing for Generic_Iteration + + begin + Iterate (Tree.Root); + end Generic_Iteration; + + ------------------ + -- Generic_Move -- + ------------------ + + procedure Generic_Move (Target, Source : in out Tree_Type) is + begin + if Target'Address = Source'Address then + return; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Clear (Target); + + Target := Source; + + Source := (First => null, + Last => null, + Root => null, + Length => 0, + Busy => 0, + Lock => 0); + end Generic_Move; + + ------------------ + -- Generic_Read -- + ------------------ + + procedure Generic_Read + (Stream : not null access Root_Stream_Type'Class; + Tree : in out Tree_Type) + is + N : Count_Type'Base; + + Node, Last_Node : Node_Access; + + begin + Clear (Tree); + + Count_Type'Base'Read (Stream, N); + pragma Assert (N >= 0); + + if N = 0 then + return; + end if; + + Node := Read_Node (Stream); + pragma Assert (Node /= null); + pragma Assert (Color (Node) = Red); + + Set_Color (Node, Black); + + Tree.Root := Node; + Tree.First := Node; + Tree.Last := Node; + + Tree.Length := 1; + + for J in Count_Type range 2 .. N loop + Last_Node := Node; + pragma Assert (Last_Node = Tree.Last); + + Node := Read_Node (Stream); + pragma Assert (Node /= null); + pragma Assert (Color (Node) = Red); + + Set_Right (Node => Last_Node, Right => Node); + Tree.Last := Node; + Set_Parent (Node => Node, Parent => Last_Node); + Rebalance_For_Insert (Tree, Node); + Tree.Length := Tree.Length + 1; + end loop; + end Generic_Read; + + ------------------------------- + -- Generic_Reverse_Iteration -- + ------------------------------- + + procedure Generic_Reverse_Iteration (Tree : Tree_Type) + is + procedure Iterate (P : Node_Access); + + ------------- + -- Iterate -- + ------------- + + procedure Iterate (P : Node_Access) is + X : Node_Access := P; + begin + while X /= null loop + Iterate (Right (X)); + Process (X); + X := Left (X); + end loop; + end Iterate; + + -- Start of processing for Generic_Reverse_Iteration + + begin + Iterate (Tree.Root); + end Generic_Reverse_Iteration; + + ------------------- + -- Generic_Write -- + ------------------- + + procedure Generic_Write + (Stream : not null access Root_Stream_Type'Class; + Tree : Tree_Type) + is + procedure Process (Node : Node_Access); + pragma Inline (Process); + + procedure Iterate is + new Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Node_Access) is + begin + Write_Node (Stream, Node); + end Process; + + -- Start of processing for Generic_Write + + begin + Count_Type'Base'Write (Stream, Tree.Length); + Iterate (Tree); + end Generic_Write; + + ----------------- + -- Left_Rotate -- + ----------------- + + procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is + + -- CLR p266 + + Y : constant Node_Access := Right (X); + pragma Assert (Y /= null); + + begin + Set_Right (X, Left (Y)); + + if Left (Y) /= null then + Set_Parent (Left (Y), X); + end if; + + Set_Parent (Y, Parent (X)); + + if X = Tree.Root then + Tree.Root := Y; + elsif X = Left (Parent (X)) then + Set_Left (Parent (X), Y); + else + pragma Assert (X = Right (Parent (X))); + Set_Right (Parent (X), Y); + end if; + + Set_Left (Y, X); + Set_Parent (X, Y); + end Left_Rotate; + + --------- + -- Max -- + --------- + + function Max (Node : Node_Access) return Node_Access is + + -- CLR p248 + + X : Node_Access := Node; + Y : Node_Access; + + begin + loop + Y := Right (X); + + if Y = null then + return X; + end if; + + X := Y; + end loop; + end Max; + + --------- + -- Min -- + --------- + + function Min (Node : Node_Access) return Node_Access is + + -- CLR p248 + + X : Node_Access := Node; + Y : Node_Access; + + begin + loop + Y := Left (X); + + if Y = null then + return X; + end if; + + X := Y; + end loop; + end Min; + + ---------- + -- Next -- + ---------- + + function Next (Node : Node_Access) return Node_Access is + begin + -- CLR p249 + + if Node = null then + return null; + end if; + + if Right (Node) /= null then + return Min (Right (Node)); + end if; + + declare + X : Node_Access := Node; + Y : Node_Access := Parent (Node); + + begin + while Y /= null + and then X = Right (Y) + loop + X := Y; + Y := Parent (Y); + end loop; + + return Y; + end; + end Next; + + -------------- + -- Previous -- + -------------- + + function Previous (Node : Node_Access) return Node_Access is + begin + if Node = null then + return null; + end if; + + if Left (Node) /= null then + return Max (Left (Node)); + end if; + + declare + X : Node_Access := Node; + Y : Node_Access := Parent (Node); + + begin + while Y /= null + and then X = Left (Y) + loop + X := Y; + Y := Parent (Y); + end loop; + + return Y; + end; + end Previous; + + -------------------------- + -- Rebalance_For_Insert -- + -------------------------- + + procedure Rebalance_For_Insert + (Tree : in out Tree_Type; + Node : Node_Access) + is + -- CLR p.268 + + X : Node_Access := Node; + pragma Assert (X /= null); + pragma Assert (Color (X) = Red); + + Y : Node_Access; + + begin + while X /= Tree.Root and then Color (Parent (X)) = Red loop + if Parent (X) = Left (Parent (Parent (X))) then + Y := Right (Parent (Parent (X))); + + if Y /= null and then Color (Y) = Red then + Set_Color (Parent (X), Black); + Set_Color (Y, Black); + Set_Color (Parent (Parent (X)), Red); + X := Parent (Parent (X)); + + else + if X = Right (Parent (X)) then + X := Parent (X); + Left_Rotate (Tree, X); + end if; + + Set_Color (Parent (X), Black); + Set_Color (Parent (Parent (X)), Red); + Right_Rotate (Tree, Parent (Parent (X))); + end if; + + else + pragma Assert (Parent (X) = Right (Parent (Parent (X)))); + + Y := Left (Parent (Parent (X))); + + if Y /= null and then Color (Y) = Red then + Set_Color (Parent (X), Black); + Set_Color (Y, Black); + Set_Color (Parent (Parent (X)), Red); + X := Parent (Parent (X)); + + else + if X = Left (Parent (X)) then + X := Parent (X); + Right_Rotate (Tree, X); + end if; + + Set_Color (Parent (X), Black); + Set_Color (Parent (Parent (X)), Red); + Left_Rotate (Tree, Parent (Parent (X))); + end if; + end if; + end loop; + + Set_Color (Tree.Root, Black); + end Rebalance_For_Insert; + + ------------------ + -- Right_Rotate -- + ------------------ + + procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access) is + X : constant Node_Access := Left (Y); + pragma Assert (X /= null); + + begin + Set_Left (Y, Right (X)); + + if Right (X) /= null then + Set_Parent (Right (X), Y); + end if; + + Set_Parent (X, Parent (Y)); + + if Y = Tree.Root then + Tree.Root := X; + elsif Y = Left (Parent (Y)) then + Set_Left (Parent (Y), X); + else + pragma Assert (Y = Right (Parent (Y))); + Set_Right (Parent (Y), X); + end if; + + Set_Right (X, Y); + Set_Parent (Y, X); + end Right_Rotate; + + --------- + -- Vet -- + --------- + + function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean is + begin + if Node = null then + return True; + end if; + + if Parent (Node) = Node + or else Left (Node) = Node + or else Right (Node) = Node + then + return False; + end if; + + if Tree.Length = 0 + or else Tree.Root = null + or else Tree.First = null + or else Tree.Last = null + then + return False; + end if; + + if Parent (Tree.Root) /= null then + return False; + end if; + + if Left (Tree.First) /= null then + return False; + end if; + + if Right (Tree.Last) /= null then + return False; + end if; + + if Tree.Length = 1 then + if Tree.First /= Tree.Last + or else Tree.First /= Tree.Root + then + return False; + end if; + + if Node /= Tree.First then + return False; + end if; + + if Parent (Node) /= null + or else Left (Node) /= null + or else Right (Node) /= null + then + return False; + end if; + + return True; + end if; + + if Tree.First = Tree.Last then + return False; + end if; + + if Tree.Length = 2 then + if Tree.First /= Tree.Root + and then Tree.Last /= Tree.Root + then + return False; + end if; + + if Tree.First /= Node + and then Tree.Last /= Node + then + return False; + end if; + end if; + + if Left (Node) /= null + and then Parent (Left (Node)) /= Node + then + return False; + end if; + + if Right (Node) /= null + and then Parent (Right (Node)) /= Node + then + return False; + end if; + + if Parent (Node) = null then + if Tree.Root /= Node then + return False; + end if; + + elsif Left (Parent (Node)) /= Node + and then Right (Parent (Node)) /= Node + then + return False; + end if; + + return True; + end Vet; + +end Ada.Containers.Red_Black_Trees.Generic_Operations; diff --git a/gcc/ada/a-crbtgo.ads b/gcc/ada/a-crbtgo.ads new file mode 100644 index 000000000..f2787f608 --- /dev/null +++ b/gcc/ada/a-crbtgo.ads @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_OPERATIONS -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +-- 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; + + 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 new file mode 100644 index 000000000..137290b11 --- /dev/null +++ b/gcc/ada/a-crdlli.adb @@ -0,0 +1,1500 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RESTRICTED_DOUBLY_LINKED_LISTS -- +-- -- +-- 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; 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 + J : 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 => J); + Insert_Internal (Container, Before.Node, New_Node => J); + Position := Cursor'(Container'Unrestricted_Access, Node => J); + + for Index in 2 .. Count loop + Allocate (Container, New_Item, New_Node => J); + Insert_Internal (Container, Before.Node, New_Node => J); + end loop; + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + 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 new file mode 100644 index 000000000..f2b586567 --- /dev/null +++ b/gcc/ada/a-crdlli.ads @@ -0,0 +1,337 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RESTRICTED_DOUBLY_LINKED_LISTS -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +-- 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; + + Empty_List : constant List := (0, others => <>); + + 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; + + No_Element : constant Cursor := (null, 0); + +end Ada.Containers.Restricted_Doubly_Linked_Lists; diff --git a/gcc/ada/a-cwila1.ads b/gcc/ada/a-cwila1.ads new file mode 100644 index 000000000..48c28b3e2 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..7170c157f --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..b9a9fe549 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..f8e47a8a6 --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..d685dc2f7 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 new file mode 100644 index 000000000..c4fa5e14c --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface between Ada.Direct_IO and the +-- C streams. This allows sharing of a stream between Ada and C or C++, +-- as well as allowing the Ada program to operate directly on the stream. + +with Interfaces.C_Streams; + +generic +package Ada.Direct_IO.C_Streams is + + package ICS renames Interfaces.C_Streams; + + function C_Stream (F : File_Type) return ICS.FILEs; + -- Obtain stream from existing open file + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + C_Stream : ICS.FILEs; + Form : String := ""; + Name : String := ""); + -- Create new file from existing stream + +end Ada.Direct_IO.C_Streams; diff --git a/gcc/ada/a-direct.adb b/gcc/ada/a-direct.adb new file mode 100644 index 000000000..e4a2697e0 --- /dev/null +++ b/gcc/ada/a-direct.adb @@ -0,0 +1,1303 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I R E C T O R I E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-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; use Ada.Calendar; +with Ada.Calendar.Formatting; use Ada.Calendar.Formatting; +with Ada.Directories.Validity; use Ada.Directories.Validity; +with Ada.Strings.Maps; +with Ada.Strings.Fixed; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with Ada.Characters.Handling; use Ada.Characters.Handling; + +with System.CRTL; use System.CRTL; +with System.OS_Lib; use System.OS_Lib; +with System.Regexp; use System.Regexp; +with System.File_IO; use System.File_IO; +with System; + +package body Ada.Directories is + + Filename_Max : constant Integer := 1024; + -- 1024 is the value of FILENAME_MAX in stdio.h + + type Dir_Type_Value is new System.Address; + -- This is the low-level address directory structure as returned by the C + -- opendir routine. + + No_Dir : constant Dir_Type_Value := Dir_Type_Value (System.Null_Address); + + Dir_Separator : constant Character; + pragma Import (C, Dir_Separator, "__gnat_dir_separator"); + -- Running system default directory separator + + Dir_Seps : constant Ada.Strings.Maps.Character_Set := + Ada.Strings.Maps.To_Set ("/\"); + -- UNIX and DOS style directory separators + + Max_Path : Integer; + pragma Import (C, Max_Path, "__gnat_max_path_len"); + -- The maximum length of a path + + type Search_Data is record + Is_Valid : Boolean := False; + Name : Unbounded_String; + Pattern : Regexp; + Filter : Filter_Type; + Dir : Dir_Type_Value := No_Dir; + Entry_Fetched : Boolean := False; + Dir_Entry : Directory_Entry_Type; + end record; + -- The current state of a search + + Empty_String : constant String := (1 .. 0 => ASCII.NUL); + -- Empty string, returned by function Extension when there is no extension + + procedure Free is new Ada.Unchecked_Deallocation (Search_Data, Search_Ptr); + + procedure Close (Dir : Dir_Type_Value); + + function File_Exists (Name : String) return Boolean; + -- Returns True if the named file exists + + procedure Fetch_Next_Entry (Search : Search_Type); + -- Get the next entry in a directory, setting Entry_Fetched if successful + -- or resetting Is_Valid if not. + + --------------- + -- Base_Name -- + --------------- + + function Base_Name (Name : String) return String is + Simple : constant String := Simple_Name (Name); + -- Simple'First is guaranteed to be 1 + + begin + -- Look for the last dot in the file name and return the part of the + -- file name preceding this last dot. If the first dot is the first + -- character of the file name, the base name is the empty string. + + for Pos in reverse Simple'Range loop + if Simple (Pos) = '.' then + return Simple (1 .. Pos - 1); + end if; + end loop; + + -- If there is no dot, return the complete file name + + return Simple; + end Base_Name; + + ----------- + -- Close -- + ----------- + + procedure Close (Dir : Dir_Type_Value) is + Discard : Integer; + pragma Warnings (Off, Discard); + + function closedir (directory : DIRs) return Integer; + pragma Import (C, closedir, "__gnat_closedir"); + + begin + Discard := closedir (DIRs (Dir)); + end Close; + + ------------- + -- Compose -- + ------------- + + function Compose + (Containing_Directory : String := ""; + Name : String; + Extension : String := "") return String + is + Result : String (1 .. Containing_Directory'Length + + Name'Length + Extension'Length + 2); + Last : Natural; + + begin + -- First, deal with the invalid cases + + if Containing_Directory /= "" + and then not Is_Valid_Path_Name (Containing_Directory) + then + raise Name_Error with + "invalid directory path name """ & Containing_Directory & '"'; + + elsif + Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name)) + then + raise Name_Error with + "invalid simple name """ & Name & '"'; + + elsif Extension'Length /= 0 + and then not Is_Valid_Simple_Name (Name & '.' & Extension) + then + raise Name_Error with + "invalid file name """ & Name & '.' & Extension & '"'; + + -- This is not an invalid case so build the path name + + else + Last := Containing_Directory'Length; + Result (1 .. Last) := Containing_Directory; + + -- Add a directory separator if needed + + if Last /= 0 and then Result (Last) /= Dir_Separator then + Last := Last + 1; + Result (Last) := Dir_Separator; + end if; + + -- Add the file name + + Result (Last + 1 .. Last + Name'Length) := Name; + Last := Last + Name'Length; + + -- If extension was specified, add dot followed by this extension + + if Extension'Length /= 0 then + Last := Last + 1; + Result (Last) := '.'; + Result (Last + 1 .. Last + Extension'Length) := Extension; + Last := Last + Extension'Length; + end if; + + return Result (1 .. Last); + end if; + end Compose; + + -------------------------- + -- Containing_Directory -- + -------------------------- + + function Containing_Directory (Name : String) return String is + begin + -- First, the invalid case + + if not Is_Valid_Path_Name (Name) then + raise Name_Error with "invalid path name """ & Name & '"'; + + else + declare + -- We need to resolve links because of A.16(47), since we must not + -- return alternative names for files. + + Norm : constant String := Normalize_Pathname (Name); + Last_DS : constant Natural := + Strings.Fixed.Index + (Name, Dir_Seps, Going => Strings.Backward); + + begin + if Last_DS = 0 then + + -- There is no directory separator, returns current working + -- directory. + + return Current_Directory; + + -- If Name indicates a root directory, raise Use_Error, because + -- it has no containing directory. + + elsif Norm = "/" + or else + (Windows + and then + (Norm = "\" + or else + (Norm'Length = 3 + and then Norm (Norm'Last - 1 .. Norm'Last) = ":\" + and then (Norm (Norm'First) in 'a' .. 'z' + or else Norm (Norm'First) in 'A' .. 'Z')))) + then + raise Use_Error with + "directory """ & Name & """ has no containing directory"; + + else + declare + Last : Positive := Last_DS - Name'First + 1; + Result : String (1 .. Last); + + begin + Result := Name (Name'First .. Last_DS); + + -- Remove any trailing directory separator, except as the + -- first character or the first character following a drive + -- number on Windows. + + while Last > 1 loop + exit when + Result (Last) /= '/' + and then + Result (Last) /= Directory_Separator; + + exit when Windows + and then Last = 3 + and then Result (2) = ':' + and then + (Result (1) in 'A' .. 'Z' + or else + Result (1) in 'a' .. 'z'); + + Last := Last - 1; + end loop; + + -- Special case of current directory, identified by "." + + if Last = 1 and then Result (1) = '.' then + return Current_Directory; + + -- Special case of "..": the current directory may be a root + -- directory. + + elsif Last = 2 and then Result (1 .. 2) = ".." then + return Containing_Directory (Current_Directory); + + else + return Result (1 .. Last); + end if; + end; + end if; + end; + end if; + end Containing_Directory; + + --------------- + -- Copy_File -- + --------------- + + procedure Copy_File + (Source_Name : String; + Target_Name : String; + Form : String := "") + is + Success : Boolean; + Mode : Copy_Mode := Overwrite; + Preserve : Attribute := None; + + begin + -- First, the invalid cases + + if not Is_Valid_Path_Name (Source_Name) then + raise Name_Error with + "invalid source path name """ & Source_Name & '"'; + + elsif not Is_Valid_Path_Name (Target_Name) then + raise Name_Error with + "invalid target path name """ & Target_Name & '"'; + + elsif not Is_Regular_File (Source_Name) then + raise Name_Error with '"' & Source_Name & """ is not a file"; + + elsif Is_Directory (Target_Name) then + raise Use_Error with "target """ & Target_Name & """ is a directory"; + + else + if Form'Length > 0 then + declare + Formstr : String (1 .. Form'Length + 1); + V1, V2 : Natural; + + begin + -- Acquire form string, setting required NUL terminator + + Formstr (1 .. Form'Length) := Form; + Formstr (Formstr'Last) := ASCII.NUL; + + -- Convert form string to lower case + + for J in Formstr'Range loop + if Formstr (J) in 'A' .. 'Z' then + Formstr (J) := + Character'Val (Character'Pos (Formstr (J)) + 32); + end if; + end loop; + + -- Check Form + + Form_Parameter (Formstr, "mode", V1, V2); + + if V1 = 0 then + Mode := Overwrite; + + elsif Formstr (V1 .. V2) = "copy" then + Mode := Copy; + + elsif Formstr (V1 .. V2) = "overwrite" then + Mode := Overwrite; + + elsif Formstr (V1 .. V2) = "append" then + Mode := Append; + + else + raise Use_Error with "invalid Form"; + end if; + + Form_Parameter (Formstr, "preserve", V1, V2); + + if V1 = 0 then + Preserve := None; + + elsif Formstr (V1 .. V2) = "timestamps" then + Preserve := Time_Stamps; + + elsif Formstr (V1 .. V2) = "all_attributes" then + Preserve := Full; + + elsif Formstr (V1 .. V2) = "no_attributes" then + Preserve := None; + + else + raise Use_Error with "invalid Form"; + end if; + end; + end if; + + -- The implementation uses System.OS_Lib.Copy_File + + Copy_File (Source_Name, Target_Name, Success, Mode, Preserve); + + if not Success then + raise Use_Error with "copy of """ & Source_Name & """ failed"; + end if; + end if; + end Copy_File; + + ---------------------- + -- Create_Directory -- + ---------------------- + + procedure Create_Directory + (New_Directory : String; + Form : String := "") + is + pragma Unreferenced (Form); + + C_Dir_Name : constant String := New_Directory & ASCII.NUL; + + function mkdir (Dir_Name : String) return Integer; + pragma Import (C, mkdir, "__gnat_mkdir"); + + begin + -- First, the invalid case + + if not Is_Valid_Path_Name (New_Directory) then + raise Name_Error with + "invalid new directory path name """ & New_Directory & '"'; + + else + if mkdir (C_Dir_Name) /= 0 then + raise Use_Error with + "creation of new directory """ & New_Directory & """ failed"; + end if; + end if; + end Create_Directory; + + ----------------- + -- Create_Path -- + ----------------- + + procedure Create_Path + (New_Directory : String; + Form : String := "") + is + pragma Unreferenced (Form); + + New_Dir : String (1 .. New_Directory'Length + 1); + Last : Positive := 1; + + begin + -- First, the invalid case + + if not Is_Valid_Path_Name (New_Directory) then + raise Name_Error with + "invalid new directory path name """ & New_Directory & '"'; + + else + -- Build New_Dir with a directory separator at the end, so that the + -- complete path will be found in the loop below. + + New_Dir (1 .. New_Directory'Length) := New_Directory; + New_Dir (New_Dir'Last) := Directory_Separator; + + -- Create, if necessary, each directory in the path + + for J in 2 .. New_Dir'Last loop + + -- Look for the end of an intermediate directory + + if New_Dir (J) /= Dir_Separator and then + New_Dir (J) /= '/' + then + Last := J; + + -- We have found a new intermediate directory each time we find + -- a first directory separator. + + elsif New_Dir (J - 1) /= Dir_Separator and then + New_Dir (J - 1) /= '/' + then + + -- No need to create the directory if it already exists + + if Is_Directory (New_Dir (1 .. Last)) then + null; + + -- It is an error if a file with such a name already exists + + elsif Is_Regular_File (New_Dir (1 .. Last)) then + raise Use_Error with + "file """ & New_Dir (1 .. Last) & """ already exists"; + + else + Create_Directory (New_Directory => New_Dir (1 .. Last)); + end if; + end if; + end loop; + end if; + end Create_Path; + + ----------------------- + -- Current_Directory -- + ----------------------- + + function Current_Directory return String is + Path_Len : Natural := Max_Path; + Buffer : String (1 .. 1 + Max_Path + 1); + + procedure Local_Get_Current_Dir + (Dir : System.Address; + Length : System.Address); + pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir"); + + begin + Local_Get_Current_Dir (Buffer'Address, Path_Len'Address); + + declare + -- We need to resolve links because of A.16(47), since we must not + -- return alternative names for files + Cur : constant String := Normalize_Pathname (Buffer (1 .. Path_Len)); + + begin + if Cur'Length > 1 and then Cur (Cur'Last) = Dir_Separator then + return Cur (1 .. Cur'Last - 1); + else + return Cur; + end if; + end; + end Current_Directory; + + ---------------------- + -- Delete_Directory -- + ---------------------- + + procedure Delete_Directory (Directory : String) is + begin + -- First, the invalid cases + + if not Is_Valid_Path_Name (Directory) then + raise Name_Error with + "invalid directory path name """ & Directory & '"'; + + elsif not Is_Directory (Directory) then + raise Name_Error with '"' & Directory & """ not a directory"; + + else + declare + C_Dir_Name : constant String := Directory & ASCII.NUL; + + begin + if rmdir (C_Dir_Name) /= 0 then + raise Use_Error with + "deletion of directory """ & Directory & """ failed"; + end if; + end; + end if; + end Delete_Directory; + + ----------------- + -- Delete_File -- + ----------------- + + procedure Delete_File (Name : String) is + Success : Boolean; + + begin + -- First, the invalid cases + + if not Is_Valid_Path_Name (Name) then + raise Name_Error with "invalid path name """ & Name & '"'; + + elsif not Is_Regular_File (Name) then + raise Name_Error with "file """ & Name & """ does not exist"; + + else + -- The implementation uses System.OS_Lib.Delete_File + + Delete_File (Name, Success); + + if not Success then + raise Use_Error with "file """ & Name & """ could not be deleted"; + end if; + end if; + end Delete_File; + + ----------------- + -- Delete_Tree -- + ----------------- + + procedure Delete_Tree (Directory : String) is + Current_Dir : constant String := Current_Directory; + Search : Search_Type; + Dir_Ent : Directory_Entry_Type; + begin + -- First, the invalid cases + + if not Is_Valid_Path_Name (Directory) then + raise Name_Error with + "invalid directory path name """ & Directory & '"'; + + elsif not Is_Directory (Directory) then + raise Name_Error with '"' & Directory & """ not a directory"; + + else + Set_Directory (Directory); + Start_Search (Search, Directory => ".", Pattern => ""); + + while More_Entries (Search) loop + Get_Next_Entry (Search, Dir_Ent); + + declare + File_Name : constant String := Simple_Name (Dir_Ent); + + begin + if System.OS_Lib.Is_Directory (File_Name) then + if File_Name /= "." and then File_Name /= ".." then + Delete_Tree (File_Name); + end if; + + else + Delete_File (File_Name); + end if; + end; + end loop; + + Set_Directory (Current_Dir); + End_Search (Search); + + declare + C_Dir_Name : constant String := Directory & ASCII.NUL; + + begin + if rmdir (C_Dir_Name) /= 0 then + raise Use_Error with + "directory tree rooted at """ & + Directory & """ could not be deleted"; + end if; + end; + end if; + end Delete_Tree; + + ------------ + -- Exists -- + ------------ + + function Exists (Name : String) return Boolean is + begin + -- First, the invalid case + + if not Is_Valid_Path_Name (Name) then + raise Name_Error with "invalid path name """ & Name & '"'; + + else + -- The implementation is in File_Exists + + return File_Exists (Name); + end if; + end Exists; + + --------------- + -- Extension -- + --------------- + + function Extension (Name : String) return String is + begin + -- First, the invalid case + + if not Is_Valid_Path_Name (Name) then + raise Name_Error with "invalid path name """ & Name & '"'; + + else + -- Look for first dot that is not followed by a directory separator + + for Pos in reverse Name'Range loop + + -- If a directory separator is found before a dot, there is no + -- extension. + + if Name (Pos) = Dir_Separator then + return Empty_String; + + elsif Name (Pos) = '.' then + + -- We found a dot, build the return value with lower bound 1 + + declare + subtype Result_Type is String (1 .. Name'Last - Pos); + begin + return Result_Type (Name (Pos + 1 .. Name'Last)); + end; + end if; + end loop; + + -- No dot were found, there is no extension + + return Empty_String; + end if; + end Extension; + + ---------------------- + -- Fetch_Next_Entry -- + ---------------------- + + procedure Fetch_Next_Entry (Search : Search_Type) is + Name : String (1 .. 255); + Last : Natural; + + Kind : File_Kind := Ordinary_File; + -- Initialized to avoid a compilation warning + + Filename_Addr : System.Address; + Filename_Len : aliased Integer; + + Buffer : array (0 .. Filename_Max + 12) of Character; + -- 12 is the size of the dirent structure (see dirent.h), without the + -- field for the filename. + + function readdir_gnat + (Directory : System.Address; + Buffer : System.Address; + Last : not null access Integer) return System.Address; + pragma Import (C, readdir_gnat, "__gnat_readdir"); + + use System; + + begin + -- Search.Value.Is_Valid is always True when Fetch_Next_Entry is called + + loop + Filename_Addr := + readdir_gnat + (System.Address (Search.Value.Dir), + Buffer'Address, + Filename_Len'Access); + + -- If no matching entry is found, set Is_Valid to False + + if Filename_Addr = System.Null_Address then + Search.Value.Is_Valid := False; + exit; + end if; + + declare + subtype Path_String is String (1 .. Filename_Len); + type Path_String_Access is access Path_String; + + function Address_To_Access is new + Ada.Unchecked_Conversion + (Source => Address, + Target => Path_String_Access); + + Path_Access : constant Path_String_Access := + Address_To_Access (Filename_Addr); + + begin + Last := Filename_Len; + Name (1 .. Last) := Path_Access.all; + end; + + -- Check if the entry matches the pattern + + if Match (Name (1 .. Last), Search.Value.Pattern) then + declare + Full_Name : constant String := + Compose + (To_String + (Search.Value.Name), Name (1 .. Last)); + Found : Boolean := False; + + begin + if File_Exists (Full_Name) then + + -- Now check if the file kind matches the filter + + if Is_Regular_File (Full_Name) then + if Search.Value.Filter (Ordinary_File) then + Kind := Ordinary_File; + Found := True; + end if; + + elsif Is_Directory (Full_Name) then + if Search.Value.Filter (Directory) then + Kind := Directory; + Found := True; + end if; + + elsif Search.Value.Filter (Special_File) then + Kind := Special_File; + Found := True; + end if; + + -- If it does, update Search and return + + if Found then + Search.Value.Entry_Fetched := True; + Search.Value.Dir_Entry := + (Is_Valid => True, + Simple => To_Unbounded_String (Name (1 .. Last)), + Full => To_Unbounded_String (Full_Name), + Kind => Kind); + exit; + end if; + end if; + end; + end if; + end loop; + end Fetch_Next_Entry; + + ----------------- + -- File_Exists -- + ----------------- + + function File_Exists (Name : String) return Boolean is + function C_File_Exists (A : System.Address) return Integer; + pragma Import (C, C_File_Exists, "__gnat_file_exists"); + + C_Name : String (1 .. Name'Length + 1); + + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return C_File_Exists (C_Name (1)'Address) = 1; + end File_Exists; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Search : in out Search_Type) is + begin + if Search.Value /= null then + + -- Close the directory, if one is open + + if Search.Value.Dir /= No_Dir then + Close (Search.Value.Dir); + end if; + + Free (Search.Value); + end if; + end Finalize; + + --------------- + -- Full_Name -- + --------------- + + function Full_Name (Name : String) return String is + begin + -- First, the invalid case + + if not Is_Valid_Path_Name (Name) then + raise Name_Error with "invalid path name """ & Name & '"'; + + else + -- Build the return value with lower bound 1 + + -- Use System.OS_Lib.Normalize_Pathname + + declare + -- We need to resolve links because of A.16(47), since we must not + -- return alternative names for files + Value : constant String := Normalize_Pathname (Name); + subtype Result is String (1 .. Value'Length); + begin + return Result (Value); + end; + end if; + end Full_Name; + + function Full_Name (Directory_Entry : Directory_Entry_Type) return String is + begin + -- First, the invalid case + + if not Directory_Entry.Is_Valid then + raise Status_Error with "invalid directory entry"; + + else + -- The value to return has already been computed + + return To_String (Directory_Entry.Full); + end if; + end Full_Name; + + -------------------- + -- Get_Next_Entry -- + -------------------- + + procedure Get_Next_Entry + (Search : in out Search_Type; + Directory_Entry : out Directory_Entry_Type) + is + begin + -- First, the invalid case + + if Search.Value = null or else not Search.Value.Is_Valid then + raise Status_Error with "invalid search"; + end if; + + -- Fetch the next entry, if needed + + if not Search.Value.Entry_Fetched then + Fetch_Next_Entry (Search); + end if; + + -- It is an error if no valid entry is found + + if not Search.Value.Is_Valid then + raise Status_Error with "no next entry"; + + else + -- Reset Entry_Fetched and return the entry + + Search.Value.Entry_Fetched := False; + Directory_Entry := Search.Value.Dir_Entry; + end if; + end Get_Next_Entry; + + ---------- + -- Kind -- + ---------- + + function Kind (Name : String) return File_Kind is + begin + -- First, the invalid case + + if not File_Exists (Name) then + raise Name_Error with "file """ & Name & """ does not exist"; + + elsif Is_Regular_File (Name) then + return Ordinary_File; + + elsif Is_Directory (Name) then + return Directory; + + else + return Special_File; + end if; + end Kind; + + function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind is + begin + -- First, the invalid case + + if not Directory_Entry.Is_Valid then + raise Status_Error with "invalid directory entry"; + + else + -- The value to return has already be computed + + return Directory_Entry.Kind; + end if; + end Kind; + + ----------------------- + -- Modification_Time -- + ----------------------- + + function Modification_Time (Name : String) return Time is + Date : OS_Time; + Year : Year_Type; + Month : Month_Type; + Day : Day_Type; + Hour : Hour_Type; + Minute : Minute_Type; + Second : Second_Type; + Result : Time; + + begin + -- First, the invalid cases + + if not (Is_Regular_File (Name) or else Is_Directory (Name)) then + raise Name_Error with '"' & Name & """ not a file or directory"; + + else + Date := File_Time_Stamp (Name); + + -- Break down the time stamp into its constituents relative to GMT. + -- This version of Split does not recognize leap seconds or buffer + -- space for time zone processing. + + GM_Split (Date, Year, Month, Day, Hour, Minute, Second); + + -- On OpenVMS, the resulting time value must be in the local time + -- zone. Ada.Calendar.Time_Of is exactly what we need. Note that + -- in both cases, the sub seconds are set to zero (0.0) because the + -- time stamp does not store them in its value. + + if OpenVMS then + Result := + Ada.Calendar.Time_Of + (Year, Month, Day, Seconds_Of (Hour, Minute, Second, 0.0)); + + -- On Unix and Windows, the result must be in GMT. Ada.Calendar. + -- Formatting.Time_Of with default time zone of zero (0) is the + -- routine of choice. + + else + Result := Time_Of (Year, Month, Day, Hour, Minute, Second, 0.0); + end if; + + return Result; + end if; + end Modification_Time; + + function Modification_Time + (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time + is + begin + -- First, the invalid case + + if not Directory_Entry.Is_Valid then + raise Status_Error with "invalid directory entry"; + + else + -- The value to return has already be computed + + return Modification_Time (To_String (Directory_Entry.Full)); + end if; + end Modification_Time; + + ------------------ + -- More_Entries -- + ------------------ + + function More_Entries (Search : Search_Type) return Boolean is + begin + if Search.Value = null then + return False; + + elsif Search.Value.Is_Valid then + + -- Fetch the next entry, if needed + + if not Search.Value.Entry_Fetched then + Fetch_Next_Entry (Search); + end if; + end if; + + return Search.Value.Is_Valid; + end More_Entries; + + ------------ + -- Rename -- + ------------ + + procedure Rename (Old_Name, New_Name : String) is + Success : Boolean; + + begin + -- First, the invalid cases + + if not Is_Valid_Path_Name (Old_Name) then + raise Name_Error with "invalid old path name """ & Old_Name & '"'; + + elsif not Is_Valid_Path_Name (New_Name) then + raise Name_Error with "invalid new path name """ & New_Name & '"'; + + elsif not Is_Regular_File (Old_Name) + and then not Is_Directory (Old_Name) + then + raise Name_Error with "old file """ & Old_Name & """ does not exist"; + + elsif Is_Regular_File (New_Name) or else Is_Directory (New_Name) then + raise Use_Error with + "new name """ & New_Name + & """ designates a file that already exists"; + + else + -- The implementation uses System.OS_Lib.Rename_File + + Rename_File (Old_Name, New_Name, Success); + + if not Success then + raise Use_Error with + "file """ & Old_Name & """ could not be renamed"; + end if; + end if; + end Rename; + + ------------ + -- Search -- + ------------ + + procedure Search + (Directory : String; + Pattern : String; + Filter : Filter_Type := (others => True); + Process : not null access procedure + (Directory_Entry : Directory_Entry_Type)) + is + Srch : Search_Type; + Directory_Entry : Directory_Entry_Type; + + begin + Start_Search (Srch, Directory, Pattern, Filter); + + while More_Entries (Srch) loop + Get_Next_Entry (Srch, Directory_Entry); + Process (Directory_Entry); + end loop; + + End_Search (Srch); + end Search; + + ------------------- + -- Set_Directory -- + ------------------- + + procedure Set_Directory (Directory : String) is + C_Dir_Name : constant String := Directory & ASCII.NUL; + begin + if not Is_Valid_Path_Name (Directory) then + raise Name_Error with + "invalid directory path name & """ & Directory & '"'; + + elsif not Is_Directory (Directory) then + raise Name_Error with + "directory """ & Directory & """ does not exist"; + + elsif chdir (C_Dir_Name) /= 0 then + raise Name_Error with + "could not set to designated directory """ & Directory & '"'; + end if; + end Set_Directory; + + ----------------- + -- Simple_Name -- + ----------------- + + function Simple_Name (Name : String) return String is + + function Simple_Name_Internal (Path : String) return String; + -- This function does the job + + -------------------------- + -- Simple_Name_Internal -- + -------------------------- + + function Simple_Name_Internal (Path : String) return String is + Cut_Start : Natural := + Strings.Fixed.Index + (Path, Dir_Seps, Going => Strings.Backward); + Cut_End : Natural; + + begin + -- Cut_Start pointS to the first simple name character + + Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1); + + -- Cut_End point to the last simple name character + + Cut_End := Path'Last; + + Check_For_Standard_Dirs : declare + BN : constant String := Path (Cut_Start .. Cut_End); + Has_Drive_Letter : constant Boolean := + System.OS_Lib.Path_Separator /= ':'; + -- If Path separator is not ':' then we are on a DOS based OS + -- where this character is used as a drive letter separator. + + begin + if BN = "." or else BN = ".." then + return ""; + + elsif Has_Drive_Letter + and then BN'Length > 2 + and then Characters.Handling.Is_Letter (BN (BN'First)) + and then BN (BN'First + 1) = ':' + then + -- We have a DOS drive letter prefix, remove it + + return BN (BN'First + 2 .. BN'Last); + + else + return BN; + end if; + end Check_For_Standard_Dirs; + end Simple_Name_Internal; + + -- Start of processing for Simple_Name + + begin + -- First, the invalid case + + if not Is_Valid_Path_Name (Name) then + raise Name_Error with "invalid path name """ & Name & '"'; + + else + -- Build the value to return with lower bound 1 + + declare + Value : constant String := Simple_Name_Internal (Name); + subtype Result is String (1 .. Value'Length); + begin + return Result (Value); + end; + end if; + end Simple_Name; + + function Simple_Name + (Directory_Entry : Directory_Entry_Type) return String is + begin + -- First, the invalid case + + if not Directory_Entry.Is_Valid then + raise Status_Error with "invalid directory entry"; + + else + -- The value to return has already be computed + + return To_String (Directory_Entry.Simple); + end if; + end Simple_Name; + + ---------- + -- Size -- + ---------- + + function Size (Name : String) return File_Size is + C_Name : String (1 .. Name'Length + 1); + + function C_Size (Name : System.Address) return Long_Integer; + pragma Import (C, C_Size, "__gnat_named_file_length"); + + begin + -- First, the invalid case + + if not Is_Regular_File (Name) then + raise Name_Error with "file """ & Name & """ does not exist"; + + else + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return File_Size (C_Size (C_Name'Address)); + end if; + end Size; + + function Size (Directory_Entry : Directory_Entry_Type) return File_Size is + begin + -- First, the invalid case + + if not Directory_Entry.Is_Valid then + raise Status_Error with "invalid directory entry"; + + else + -- The value to return has already be computed + + return Size (To_String (Directory_Entry.Full)); + end if; + end Size; + + ------------------ + -- Start_Search -- + ------------------ + + procedure Start_Search + (Search : in out Search_Type; + Directory : String; + Pattern : String; + Filter : Filter_Type := (others => True)) + is + function opendir (file_name : String) return DIRs; + pragma Import (C, opendir, "__gnat_opendir"); + + C_File_Name : constant String := Directory & ASCII.NUL; + Pat : Regexp; + Dir : Dir_Type_Value; + + begin + -- First, the invalid case Name_Error + + if not Is_Directory (Directory) then + raise Name_Error with + "unknown directory """ & Simple_Name (Directory) & '"'; + end if; + + -- Check the pattern + + begin + Pat := Compile + (Pattern, + Glob => True, + Case_Sensitive => Is_Path_Name_Case_Sensitive); + exception + when Error_In_Regexp => + Free (Search.Value); + raise Name_Error with "invalid pattern """ & Pattern & '"'; + end; + + Dir := Dir_Type_Value (opendir (C_File_Name)); + + if Dir = No_Dir then + raise Use_Error with + "unreadable directory """ & Simple_Name (Directory) & '"'; + end if; + + -- If needed, finalize Search + + Finalize (Search); + + -- Allocate the default data + + Search.Value := new Search_Data; + + -- Initialize some Search components + + Search.Value.Filter := Filter; + Search.Value.Name := To_Unbounded_String (Full_Name (Directory)); + Search.Value.Pattern := Pat; + Search.Value.Dir := Dir; + Search.Value.Is_Valid := True; + end Start_Search; + +end Ada.Directories; diff --git a/gcc/ada/a-direct.ads b/gcc/ada/a-direct.ads new file mode 100644 index 000000000..9e2f880c4 --- /dev/null +++ b/gcc/ada/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-2010, 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 shall be suitable for a future call to Set_Directory. + -- The exception Use_Error is propagated if a default directory is not + -- supported by the external environment. + + procedure Set_Directory (Directory : String); + -- Sets the current default directory. The exception Name_Error is + -- propagated if the string given as Directory does not identify an + -- existing directory. The exception Use_Error is propagated if the + -- external environment does not support making Directory (in the absence + -- of Name_Error) a default directory. + + procedure Create_Directory + (New_Directory : String; + Form : String := ""); + -- Creates a directory with name New_Directory. The Form parameter can be + -- used to give system-dependent characteristics of the directory; the + -- interpretation of the Form parameter is implementation-defined. A null + -- string for Form specifies the use of the default options of the + -- implementation of the new directory. The exception Name_Error is + -- propagated if the string given as New_Directory does not allow the + -- identification of a directory. The exception Use_Error is propagated if + -- the external environment does not support the creation of a directory + -- with the given name (in the absence of Name_Error) and form. + -- + -- The Form parameter is ignored + + procedure Delete_Directory (Directory : String); + -- Deletes an existing empty directory with name Directory. The exception + -- Name_Error is propagated if the string given as Directory does not + -- identify an existing directory. The exception Use_Error is propagated + -- if the external environment does not support the deletion of the + -- directory (or some portion of its contents) with the given name (in the + -- absence of Name_Error). + + procedure Create_Path + (New_Directory : String; + Form : String := ""); + -- Creates zero or more directories with name New_Directory. Each + -- non-existent directory named by New_Directory is created. For example, + -- on a typical Unix system, Create_Path ("/usr/me/my"); would create + -- directory "me" in directory "usr", then create directory "my" in + -- directory "me". The Form can be used to give system-dependent + -- characteristics of the directory; the interpretation of the Form + -- parameter is implementation-defined. A null string for Form specifies + -- the use of the default options of the implementation of the new + -- directory. The exception Name_Error is propagated if the string given + -- as New_Directory does not allow the identification of any directory. + -- The exception Use_Error is propagated if the external environment does + -- not support the creation of any directories with the given name (in the + -- absence of Name_Error) and form. + -- + -- The Form parameter is ignored + + procedure Delete_Tree (Directory : String); + -- Deletes an existing directory with name Directory. The directory and + -- all of its contents (possibly including other directories) are deleted. + -- The exception Name_Error is propagated if the string given as Directory + -- does not identify an existing directory. The exception Use_Error is + -- propagated if the external environment does not support the deletion of + -- the directory or some portion of its contents with the given name (in + -- the absence of Name_Error). If Use_Error is propagated, it is + -- unspecified if a portion of the contents of the directory are deleted. + + procedure Delete_File (Name : String); + -- Deletes an existing ordinary or special file with Name. The exception + -- Name_Error is propagated if the string given as Name does not identify + -- an existing ordinary or special external file. The exception Use_Error + -- is propagated if the external environment does not support the deletion + -- of the file with the given name (in the absence of Name_Error). + + procedure Rename (Old_Name, New_Name : String); + -- Renames an existing external file (including directories) with Old_Name + -- to New_Name. The exception Name_Error is propagated if the string given + -- as Old_Name does not identify an existing external file. The exception + -- Use_Error is propagated if the external environment does not support the + -- renaming of the file with the given name (in the absence of Name_Error). + -- In particular, Use_Error is propagated if a file or directory already + -- exists with New_Name. + + procedure Copy_File + (Source_Name : String; + Target_Name : String; + Form : String := ""); + -- Copies the contents of the existing external file with Source_Name to + -- Target_Name. The resulting external file is a duplicate of the source + -- external file. The Form argument can be used to give system-dependent + -- characteristics of the resulting external file; the interpretation of + -- the Form parameter is implementation-defined. Exception Name_Error is + -- propagated if the string given as Source_Name does not identify an + -- existing external ordinary or special file or if the string given as + -- Target_Name does not allow the identification of an external file. The + -- exception Use_Error is propagated if the external environment does not + -- support the creating of the file with the name given by Target_Name and + -- form given by Form, or copying of the file with the name given by + -- Source_Name (in the absence of Name_Error). + -- + -- Interpretation of the Form parameter: + -- + -- The Form parameter is case-insensitive + -- + -- Two fields are recognized in the Form parameter: + -- preserve= + -- mode= + -- + -- starts immediately after the character '=' and ends with the + -- character immediately preceding the next comma (',') or with the + -- last character of the parameter. + -- + -- The allowed values for preserve= are: + -- + -- no_attributes: Do not try to preserve any file attributes. This + -- is the default if no preserve= is found in Form. + -- + -- all_attributes: Try to preserve all file attributes (timestamps, + -- access rights). + -- + -- timestamps: Preserve the timestamp of the copied file, but not + -- the other file attributes. + -- + -- The allowed values for mode= are: + -- + -- copy: Only copy if the destination file does not already + -- exist. If it already exists, Copy_File will fail. + -- + -- overwrite: Copy the file in all cases. Overwrite an already + -- existing destination file. This is the default if + -- no mode= is found in Form. + -- + -- append: Append the original file to the destination file. + -- If the destination file does not exist, the + -- destination file is a copy of the source file. + -- When mode=append, the field preserve=, if it + -- exists, is not taken into account. + -- + -- If the Form parameter includes one or both of the fields and the value + -- or values are incorrect, Copy_File fails with Use_Error. + -- + -- Examples of correct Forms: + -- Form => "preserve=no_attributes,mode=overwrite" (the default) + -- Form => "mode=append" + -- Form => "mode=copy,preserve=all_attributes" + -- + -- Examples of incorrect Forms: + -- Form => "preserve=junk" + -- Form => "mode=internal,preserve=timestamps" + + ---------------------------------------- + -- File and directory name operations -- + ---------------------------------------- + + function Full_Name (Name : String) return String; + -- Returns the full name corresponding to the file name specified by Name. + -- The exception Name_Error is propagated if the string given as Name does + -- not allow the identification of an external file (including directories + -- and special files). + + function Simple_Name (Name : String) return String; + -- Returns the simple name portion of the file name specified by Name. The + -- exception Name_Error is propagated if the string given as Name does not + -- allow the identification of an external file (including directories and + -- special files). + + function Containing_Directory (Name : String) return String; + -- Returns the name of the containing directory of the external file + -- (including directories) identified by Name. If more than one directory + -- can contain Name, the directory name returned is implementation-defined. + -- The exception Name_Error is propagated if the string given as Name does + -- not allow the identification of an external file. The exception + -- Use_Error is propagated if the external file does not have a containing + -- directory. + + function Extension (Name : String) return String; + -- Returns the extension name corresponding to Name. The extension name is + -- a portion of a simple name (not including any separator characters), + -- typically used to identify the file class. If the external environment + -- does not have extension names, then the null string is returned. + -- The exception Name_Error is propagated if the string given as Name does + -- not allow the identification of an external file. + + function Base_Name (Name : String) return String; + -- Returns the base name corresponding to Name. The base name is the + -- remainder of a simple name after removing any extension and extension + -- separators. The exception Name_Error is propagated if the string given + -- as Name does not allow the identification of an external file + -- (including directories and special files). + + function Compose + (Containing_Directory : String := ""; + Name : String; + Extension : String := "") return String; + -- Returns the name of the external file with the specified + -- Containing_Directory, Name, and Extension. If Extension is the null + -- string, then Name is interpreted as a simple name; otherwise Name is + -- interpreted as a base name. The exception Name_Error is propagated if + -- the string given as Containing_Directory is not null and does not allow + -- the identification of a directory, or if the string given as Extension + -- is not null and is not a possible extension, or if the string given as + -- Name is not a possible simple name (if Extension is null) or base name + -- (if Extension is non-null). + + -------------------------------- + -- File and directory queries -- + -------------------------------- + + type File_Kind is (Directory, Ordinary_File, Special_File); + -- The type File_Kind represents the kind of file represented by an + -- external file or directory. + + type File_Size is range 0 .. Long_Long_Integer'Last; + -- The type File_Size represents the size of an external file + + function Exists (Name : String) return Boolean; + -- Returns True if external file represented by Name exists, and False + -- otherwise. The exception Name_Error is propagated if the string given as + -- Name does not allow the identification of an external file (including + -- directories and special files). + + function Kind (Name : String) return File_Kind; + -- Returns the kind of external file represented by Name. The exception + -- Name_Error is propagated if the string given as Name does not allow the + -- identification of an existing external file. + + function Size (Name : String) return File_Size; + -- Returns the size of the external file represented by Name. The size of + -- an external file is the number of stream elements contained in the file. + -- If the external file is discontiguous (not all elements exist), the + -- result is implementation-defined. If the external file is not an + -- ordinary file, the result is implementation-defined. The exception + -- Name_Error is propagated if the string given as Name does not allow the + -- identification of an existing external file. The exception + -- Constraint_Error is propagated if the file size is not a value of type + -- File_Size. + + function Modification_Time (Name : String) return Ada.Calendar.Time; + -- Returns the time that the external file represented by Name was most + -- recently modified. If the external file is not an ordinary file, the + -- result is implementation-defined. The exception Name_Error is propagated + -- if the string given as Name does not allow the identification of an + -- existing external file. The exception Use_Error is propagated if the + -- external environment does not support the reading the modification time + -- of the file with the name given by Name (in the absence of Name_Error). + + ------------------------- + -- Directory Searching -- + ------------------------- + + type Directory_Entry_Type is limited private; + -- The type Directory_Entry_Type represents a single item in a directory. + -- These items can only be created by the Get_Next_Entry procedure in this + -- package. Information about the item can be obtained from the functions + -- declared in this package. A default initialized object of this type is + -- invalid; objects returned from Get_Next_Entry are valid. + + type Filter_Type is array (File_Kind) of Boolean; + -- The type Filter_Type specifies which directory entries are provided from + -- a search operation. If the Directory component is True, directory + -- entries representing directories are provided. If the Ordinary_File + -- component is True, directory entries representing ordinary files are + -- provided. If the Special_File component is True, directory entries + -- representing special files are provided. + + type Search_Type is limited private; + -- The type Search_Type contains the state of a directory search. A + -- default-initialized Search_Type object has no entries available + -- (More_Entries returns False). + + procedure Start_Search + (Search : in out Search_Type; + Directory : String; + Pattern : String; + Filter : Filter_Type := (others => True)); + -- Starts a search in the directory entry in the directory named by + -- Directory for entries matching Pattern. Pattern represents a file name + -- matching pattern. If Pattern is null, all items in the directory are + -- matched; otherwise, the interpretation of Pattern is implementation- + -- defined. Only items which match Filter will be returned. After a + -- successful call on Start_Search, the object Search may have entries + -- available, but it may have no entries available if no files or + -- directories match Pattern and Filter. The exception Name_Error is + -- propagated if the string given by Directory does not identify an + -- existing directory, or if Pattern does not allow the identification of + -- any possible external file or directory. The exception Use_Error is + -- propagated if the external environment does not support the searching + -- of the directory with the given name (in the absence of Name_Error). + + procedure End_Search (Search : in out Search_Type); + -- Ends the search represented by Search. After a successful call on + -- End_Search, the object Search will have no entries available. Note + -- that it is not necessary to call End_Search if the call to Start_Search + -- was unsuccessful and raised an exception (but it is harmless to make + -- the call in this case). + + function More_Entries (Search : Search_Type) return Boolean; + -- Returns True if more entries are available to be returned by a call + -- to Get_Next_Entry for the specified search object, and False otherwise. + + procedure Get_Next_Entry + (Search : in out Search_Type; + Directory_Entry : out Directory_Entry_Type); + -- Returns the next Directory_Entry for the search described by Search that + -- matches the pattern and filter. If no further matches are available, + -- Status_Error is raised. It is implementation-defined as to whether the + -- results returned by this routine are altered if the contents of the + -- directory are altered while the Search object is valid (for example, by + -- another program). The exception Use_Error is propagated if the external + -- environment does not support continued searching of the directory + -- represented by Search. + + procedure Search + (Directory : String; + Pattern : String; + Filter : Filter_Type := (others => True); + Process : not null access procedure + (Directory_Entry : Directory_Entry_Type)); + -- Searches in the directory named by Directory for entries matching + -- Pattern. The subprogram designated by Process is called with each + -- matching entry in turn. Pattern represents a pattern for matching file + -- names. If Pattern is null, all items in the directory are matched; + -- otherwise, the interpretation of Pattern is implementation-defined. + -- Only items that match Filter will be returned. The exception Name_Error + -- is propagated if the string given by Directory does not identify + -- an existing directory, or if Pattern does not allow the identification + -- of any possible external file or directory. The exception Use_Error is + -- propagated if the external environment does not support the searching + -- of the directory with the given name (in the absence of Name_Error). + + ------------------------------------- + -- Operations on Directory Entries -- + ------------------------------------- + + function Simple_Name (Directory_Entry : Directory_Entry_Type) return String; + -- Returns the simple external name of the external file (including + -- directories) represented by Directory_Entry. The format of the name + -- returned is implementation-defined. The exception Status_Error is + -- propagated if Directory_Entry is invalid. + + function Full_Name (Directory_Entry : Directory_Entry_Type) return String; + -- Returns the full external name of the external file (including + -- directories) represented by Directory_Entry. The format of the name + -- returned is implementation-defined. The exception Status_Error is + -- propagated if Directory_Entry is invalid. + + function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind; + -- Returns the kind of external file represented by Directory_Entry. The + -- exception Status_Error is propagated if Directory_Entry is invalid. + + function Size (Directory_Entry : Directory_Entry_Type) return File_Size; + -- Returns the size of the external file represented by Directory_Entry. + -- The size of an external file is the number of stream elements contained + -- in the file. If the external file is discontiguous (not all elements + -- exist), the result is implementation-defined. If the external file + -- represented by Directory_Entry is not an ordinary file, the result is + -- implementation-defined. The exception Status_Error is propagated if + -- Directory_Entry is invalid. The exception Constraint_Error is propagated + -- if the file size is not a value of type File_Size. + + function Modification_Time + (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time; + -- Returns the time that the external file represented by Directory_Entry + -- was most recently modified. If the external file represented by + -- Directory_Entry is not an ordinary file, the result is + -- implementation-defined. The exception Status_Error is propagated if + -- Directory_Entry is invalid. The exception Use_Error is propagated if + -- the external environment does not support the reading the modification + -- time of the file represented by Directory_Entry. + + ---------------- + -- Exceptions -- + ---------------- + + Status_Error : exception renames Ada.IO_Exceptions.Status_Error; + Name_Error : exception renames Ada.IO_Exceptions.Name_Error; + Use_Error : exception renames Ada.IO_Exceptions.Use_Error; + Device_Error : exception renames Ada.IO_Exceptions.Device_Error; + +private + type Directory_Entry_Type is record + Is_Valid : Boolean := False; + Simple : Ada.Strings.Unbounded.Unbounded_String; + Full : Ada.Strings.Unbounded.Unbounded_String; + Kind : File_Kind := Ordinary_File; + end record; + + -- The type Search_Data is defined in the body, so that the spec does not + -- depend on packages of the GNAT hierarchy. + + type Search_Data; + type Search_Ptr is access Search_Data; + + -- Search_Type need to be a controlled type, because it includes component + -- of type Dir_Type (in GNAT.Directory_Operations) that need to be closed + -- (if opened) during finalization. The component need to be an access + -- value, because Search_Data is not fully defined in the spec. + + type Search_Type is new Ada.Finalization.Controlled with record + Value : Search_Ptr; + end record; + + procedure Finalize (Search : in out Search_Type); + -- Close the directory, if opened, and deallocate Value + + procedure End_Search (Search : in out Search_Type) renames Finalize; + +end Ada.Directories; diff --git a/gcc/ada/a-direio.adb b/gcc/ada/a-direio.adb new file mode 100644 index 000000000..7a5e5c8e5 --- /dev/null +++ b/gcc/ada/a-direio.adb @@ -0,0 +1,283 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I R E C 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the generic template for Direct_IO, i.e. the code that gets +-- duplicated. We absolutely minimize this code by either calling routines +-- in System.File_IO (for common file functions), or in System.Direct_IO +-- (for specialized Direct_IO functions) + +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System; use System; +with System.CRTL; +with System.File_Control_Block; +with System.File_IO; +with System.Direct_IO; +with System.Storage_Elements; +with Ada.Unchecked_Conversion; + +use type System.Direct_IO.Count; + +package body Ada.Direct_IO is + + Zeroes : constant System.Storage_Elements.Storage_Array := + (1 .. System.Storage_Elements.Storage_Offset (Bytes) => 0); + -- Buffer used to fill out partial records + + package FCB renames System.File_Control_Block; + package FIO renames System.File_IO; + package DIO renames System.Direct_IO; + + SU : constant := System.Storage_Unit; + + subtype AP is FCB.AFCB_Ptr; + subtype FP is DIO.File_Type; + subtype DPCount is DIO.Positive_Count; + + function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); + function To_DIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode); + + use type System.CRTL.size_t; + + ----------- + -- Close -- + ----------- + + procedure Close (File : in out File_Type) is + begin + FIO.Close (AP (File)'Unrestricted_Access); + end Close; + + ------------ + -- Create -- + ------------ + + procedure Create + (File : in out File_Type; + Mode : File_Mode := Inout_File; + Name : String := ""; + Form : String := "") + is + begin + DIO.Create (FP (File), To_FCB (Mode), Name, Form); + File.Bytes := Bytes; + end Create; + + ------------ + -- Delete -- + ------------ + + procedure Delete (File : in out File_Type) is + begin + FIO.Delete (AP (File)'Unrestricted_Access); + end Delete; + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File (File : File_Type) return Boolean is + begin + return DIO.End_Of_File (FP (File)); + end End_Of_File; + + ---------- + -- Form -- + ---------- + + function Form (File : File_Type) return String is + begin + return FIO.Form (AP (File)); + end Form; + + ----------- + -- Index -- + ----------- + + function Index (File : File_Type) return Positive_Count is + begin + return Positive_Count (DIO.Index (FP (File))); + end Index; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (File : File_Type) return Boolean is + begin + return FIO.Is_Open (AP (File)); + end Is_Open; + + ---------- + -- Mode -- + ---------- + + function Mode (File : File_Type) return File_Mode is + begin + return To_DIO (FIO.Mode (AP (File))); + end Mode; + + ---------- + -- Name -- + ---------- + + function Name (File : File_Type) return String is + begin + return FIO.Name (AP (File)); + end Name; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + Name : String; + Form : String := "") + is + begin + DIO.Open (FP (File), To_FCB (Mode), Name, Form); + File.Bytes := Bytes; + end Open; + + ---------- + -- Read -- + ---------- + + procedure Read + (File : File_Type; + Item : out Element_Type; + From : Positive_Count) + is + begin + -- For a non-constrained variant record type, we read into an + -- intermediate buffer, since we may have the case of discriminated + -- records where a discriminant check is required, and we may need + -- to assign only part of the record buffer originally written. + + -- Note: we have to turn warnings on/off because this use of + -- the Constrained attribute is an obsolescent feature. + + pragma Warnings (Off); + if not Element_Type'Constrained then + pragma Warnings (On); + + declare + Buf : Element_Type; + + begin + DIO.Read (FP (File), Buf'Address, Bytes, DPCount (From)); + Item := Buf; + end; + + -- In the normal case, we can read straight into the buffer + + else + DIO.Read (FP (File), Item'Address, Bytes, DPCount (From)); + end if; + end Read; + + procedure Read (File : File_Type; Item : out Element_Type) is + begin + -- Same processing for unconstrained case as above + + -- Note: we have to turn warnings on/off because this use of + -- the Constrained attribute is an obsolescent feature. + + pragma Warnings (Off); + if not Element_Type'Constrained then + pragma Warnings (On); + + declare + Buf : Element_Type; + + begin + DIO.Read (FP (File), Buf'Address, Bytes); + Item := Buf; + end; + + else + DIO.Read (FP (File), Item'Address, Bytes); + end if; + end Read; + + ----------- + -- Reset -- + ----------- + + procedure Reset (File : in out File_Type; Mode : File_Mode) is + begin + DIO.Reset (FP (File), To_FCB (Mode)); + end Reset; + + procedure Reset (File : in out File_Type) is + begin + DIO.Reset (FP (File)); + end Reset; + + --------------- + -- Set_Index -- + --------------- + + procedure Set_Index (File : File_Type; To : Positive_Count) is + begin + DIO.Set_Index (FP (File), DPCount (To)); + end Set_Index; + + ---------- + -- Size -- + ---------- + + function Size (File : File_Type) return Count is + begin + return Count (DIO.Size (FP (File))); + end Size; + + ----------- + -- Write -- + ----------- + + procedure Write + (File : File_Type; + Item : Element_Type; + To : Positive_Count) + is + begin + DIO.Set_Index (FP (File), DPCount (To)); + DIO.Write (FP (File), Item'Address, Item'Size / SU, Zeroes); + end Write; + + procedure Write (File : File_Type; Item : Element_Type) is + begin + DIO.Write (FP (File), Item'Address, Item'Size / SU, Zeroes); + end Write; + +end Ada.Direct_IO; diff --git a/gcc/ada/a-direio.ads b/gcc/ada/a-direio.ads new file mode 100644 index 000000000..1244b2dbf --- /dev/null +++ b/gcc/ada/a-direio.ads @@ -0,0 +1,191 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I R E C T _ 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.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; + + --------------------------------- + -- 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-diroro.ads b/gcc/ada/a-diroro.ads new file mode 100644 index 000000000..2cdaeb1f2 --- /dev/null +++ b/gcc/ada/a-diroro.ads @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I S P A T C H I N G . R O U N D _ R O B I N -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with System; +with Ada.Real_Time; + +package Ada.Dispatching.Round_Robin is + + pragma Unimplemented_Unit; + + Default_Quantum : constant Ada.Real_Time.Time_Span := + Ada.Real_Time.Milliseconds (10); + + procedure Set_Quantum + (Pri : System.Priority; + Quantum : Ada.Real_Time.Time_Span); + + procedure Set_Quantum + (Low, High : System.Priority; + Quantum : Ada.Real_Time.Time_Span); + + function Actual_Quantum + (Pri : System.Priority) return Ada.Real_Time.Time_Span; + + function Is_Round_Robin (Pri : System.Priority) return Boolean; + +end Ada.Dispatching.Round_Robin; diff --git a/gcc/ada/a-dirval-mingw.adb b/gcc/ada/a-dirval-mingw.adb new file mode 100644 index 000000000..d73f56840 --- /dev/null +++ b/gcc/ada/a-dirval-mingw.adb @@ -0,0 +1,182 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I R E C T O R I E S . V A L I D I T Y -- +-- -- +-- B o d y -- +-- (Windows Version) -- +-- -- +-- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Windows version of this package + +with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; + +package body Ada.Directories.Validity is + + Invalid_Character : constant array (Character) of Boolean := + (NUL .. US | '\' => True, + '/' | ':' | '*' | '?' => True, + '"' | '<' | '>' | '|' => True, + DEL .. NBSP => True, + others => False); + + --------------------------------- + -- Is_Path_Name_Case_Sensitive -- + --------------------------------- + + function Is_Path_Name_Case_Sensitive return Boolean is + begin + return False; + end Is_Path_Name_Case_Sensitive; + + ------------------------ + -- Is_Valid_Path_Name -- + ------------------------ + + function Is_Valid_Path_Name (Name : String) return Boolean is + Start : Positive := Name'First; + Last : Natural; + + begin + -- A path name cannot be empty, cannot contain more than 256 characters, + -- cannot contain invalid characters and each directory/file name need + -- to be valid. + + if Name'Length = 0 or else Name'Length > 256 then + return False; + + else + -- A drive letter may be specified at the beginning + + if Name'Length >= 2 + and then Name (Start + 1) = ':' + and then + (Name (Start) in 'A' .. 'Z' or else + Name (Start) in 'a' .. 'z') + then + Start := Start + 2; + + -- A drive letter followed by a colon and followed by nothing or + -- by a relative path is an ambiguous path name on Windows, so we + -- don't accept it. + + if Start > Name'Last + or else (Name (Start) /= '/' and then Name (Start) /= '\') + then + return False; + end if; + end if; + + loop + -- Look for the start of the next directory or file name + + while Start <= Name'Last and then + (Name (Start) = '\' or Name (Start) = '/') + loop + Start := Start + 1; + end loop; + + -- If all directories/file names are OK, return True + + exit when Start > Name'Last; + + Last := Start; + + -- Look for the end of the directory/file name + + while Last < Name'Last loop + exit when Name (Last + 1) = '\' or Name (Last + 1) = '/'; + Last := Last + 1; + end loop; + + -- Check if the directory/file name is valid + + if not Is_Valid_Simple_Name (Name (Start .. Last)) then + return False; + end if; + + -- Move to the next name + + Start := Last + 1; + end loop; + end if; + + -- If Name follows the rules, it is valid + + return True; + end Is_Valid_Path_Name; + + -------------------------- + -- Is_Valid_Simple_Name -- + -------------------------- + + function Is_Valid_Simple_Name (Name : String) return Boolean is + Only_Spaces : Boolean; + + begin + -- A file name cannot be empty, cannot contain more than 256 characters, + -- and cannot contain invalid characters. + + if Name'Length = 0 or else Name'Length > 256 then + return False; + + -- Name length is OK + + else + Only_Spaces := True; + for J in Name'Range loop + if Invalid_Character (Name (J)) then + return False; + elsif Name (J) /= ' ' then + Only_Spaces := False; + end if; + end loop; + + -- If no invalid chars, and not all spaces, file name is valid + + return not Only_Spaces; + end if; + end Is_Valid_Simple_Name; + + ------------- + -- OpenVMS -- + ------------- + + function OpenVMS return Boolean is + begin + return False; + end OpenVMS; + + ------------- + -- Windows -- + ------------- + + function Windows return Boolean is + begin + return True; + end Windows; + +end Ada.Directories.Validity; diff --git a/gcc/ada/a-dirval-vms.adb b/gcc/ada/a-dirval-vms.adb new file mode 100644 index 000000000..34032b233 --- /dev/null +++ b/gcc/ada/a-dirval-vms.adb @@ -0,0 +1,200 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- (VMS Version) -- +-- -- +-- 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 is the OpenVMS version of this package + +package body Ada.Directories.Validity is + + Max_Number_Of_Characters : constant := 39; + Max_Path_Length : constant := 1_024; + + Invalid_Character : constant array (Character) of Boolean := + ('a' .. 'z' => False, + 'A' .. 'Z' => False, + '0' .. '9' => False, + '_' | '$' | '-' | '.' => False, + others => True); + + --------------------------------- + -- Is_Path_Name_Case_Sensitive -- + --------------------------------- + + function Is_Path_Name_Case_Sensitive return Boolean is + begin + return False; + end Is_Path_Name_Case_Sensitive; + + ------------------------ + -- Is_Valid_Path_Name -- + ------------------------ + + function Is_Valid_Path_Name (Name : String) return Boolean is + First : Positive := Name'First; + Last : Positive; + Dot_Found : Boolean := False; + + begin + -- A valid path (directory) name cannot be empty, and cannot contain + -- more than 1024 characters. Directories can be ".", ".." or be simple + -- name without extensions. + + if Name'Length = 0 or else Name'Length > Max_Path_Length then + return False; + + else + loop + -- Look for the start of the next directory or file name + + while First <= Name'Last and then Name (First) = '/' loop + First := First + 1; + end loop; + + -- If all directories/file names are OK, return True + + exit when First > Name'Last; + + Last := First; + Dot_Found := False; + + -- Look for the end of the directory/file name + + while Last < Name'Last loop + exit when Name (Last + 1) = '/'; + Last := Last + 1; + + if Name (Last) = '.' then + Dot_Found := True; + end if; + end loop; + + -- If name include a dot, it can only be ".", ".." or the last + -- file name. + + if Dot_Found then + if Name (First .. Last) /= "." and then + Name (First .. Last) /= ".." + then + return Last = Name'Last + and then Is_Valid_Simple_Name (Name (First .. Last)); + + end if; + + -- Check if the directory/file name is valid + + elsif not Is_Valid_Simple_Name (Name (First .. Last)) then + return False; + end if; + + -- Move to the next name + + First := Last + 1; + end loop; + end if; + + -- If Name follows the rules, then it is valid + + return True; + end Is_Valid_Path_Name; + + -------------------------- + -- Is_Valid_Simple_Name -- + -------------------------- + + function Is_Valid_Simple_Name (Name : String) return Boolean is + In_Extension : Boolean := False; + Number_Of_Characters : Natural := 0; + + begin + -- A file name cannot be empty, and cannot have more than 39 characters + -- before or after a single '.'. + + if Name'Length = 0 then + return False; + + else + -- Check each character for validity + + for J in Name'Range loop + if Invalid_Character (Name (J)) then + return False; + + elsif Name (J) = '.' then + + -- Name cannot contain several dots + + if In_Extension then + return False; + + else + -- Reset the number of characters to count the characters + -- of the extension. + + In_Extension := True; + Number_Of_Characters := 0; + end if; + + else + -- Check that the number of character is not too large + + Number_Of_Characters := Number_Of_Characters + 1; + + if Number_Of_Characters > Max_Number_Of_Characters then + return False; + end if; + end if; + end loop; + end if; + + -- If the rules are followed, then it is valid + + return True; + end Is_Valid_Simple_Name; + + ------------- + -- OpenVMS -- + ------------- + + function OpenVMS return Boolean is + begin + return True; + end OpenVMS; + + ------------- + -- Windows -- + ------------- + + function Windows return Boolean is + begin + return False; + end Windows; + +end Ada.Directories.Validity; diff --git a/gcc/ada/a-dirval.adb b/gcc/ada/a-dirval.adb new file mode 100644 index 000000000..c3da2efd4 --- /dev/null +++ b/gcc/ada/a-dirval.adb @@ -0,0 +1,113 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + ------------- + -- OpenVMS -- + ------------- + + function OpenVMS return Boolean is + begin + return False; + end OpenVMS; + + ------------- + -- 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 new file mode 100644 index 000000000..f7b2bb672 --- /dev/null +++ b/gcc/ada/a-dirval.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 OpenVMS return Boolean; + -- Return True when OS is OpenVMS + + function Windows return Boolean; + -- Return True when OS is Windows + +end Ada.Directories.Validity; diff --git a/gcc/ada/a-disedf.ads b/gcc/ada/a-disedf.ads new file mode 100644 index 000000000..f1a5f3c50 --- /dev/null +++ b/gcc/ada/a-disedf.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I S P A T C H I N G . E D F -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit is not implemented in typical GNAT implementations that lie on +-- top of operating systems, because it is infeasible to implement in such +-- environments. + +-- If a target environment provides appropriate support for this package, +-- then the Unimplemented_Unit pragma should be removed from this spec and +-- an appropriate body provided. + +with Ada.Real_Time; +with Ada.Task_Identification; + +package Ada.Dispatching.EDF is + pragma Preelaborate; + + pragma Unimplemented_Unit; + + subtype Deadline is Ada.Real_Time.Time; + + Default_Deadline : constant Deadline := Ada.Real_Time.Time_Last; + + procedure Set_Deadline + (D : Deadline; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task); + + procedure Delay_Until_And_Set_Deadline + (Delay_Until_Time : Ada.Real_Time.Time; + Deadline_Offset : Ada.Real_Time.Time_Span); + + function Get_Deadline + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + return Deadline; + +end Ada.Dispatching.EDF; diff --git a/gcc/ada/a-dispat.ads b/gcc/ada/a-dispat.ads new file mode 100644 index 000000000..b350ae0eb --- /dev/null +++ b/gcc/ada/a-dispat.ads @@ -0,0 +1,20 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I S P A T C H I N G -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Dispatching is + pragma Pure (Dispatching); + + Dispatching_Policy_Error : exception; +end Ada.Dispatching; diff --git a/gcc/ada/a-dynpri.adb b/gcc/ada/a-dynpri.adb new file mode 100644 index 000000000..9116a5739 --- /dev/null +++ b/gcc/ada/a-dynpri.adb @@ -0,0 +1,164 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . D Y N A M I C _ P R I O R I T I E S -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Task_Primitives.Operations; +with System.Tasking; +with System.Parameters; +with System.Soft_Links; + +with Ada.Unchecked_Conversion; + +package body Ada.Dynamic_Priorities is + + package STPO renames System.Task_Primitives.Operations; + package SSL renames System.Soft_Links; + + use System.Parameters; + use System.Tasking; + + function Convert_Ids is new + Ada.Unchecked_Conversion + (Task_Identification.Task_Id, System.Tasking.Task_Id); + + ------------------ + -- Get_Priority -- + ------------------ + + -- Inquire base priority of a task + + function Get_Priority + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) return System.Any_Priority + is + Target : constant Task_Id := Convert_Ids (T); + Error_Message : constant String := "Trying to get the priority of a "; + + begin + if Target = Convert_Ids (Ada.Task_Identification.Null_Task_Id) then + raise Program_Error with Error_Message & "null task"; + end if; + + if Task_Identification.Is_Terminated (T) then + raise Tasking_Error with Error_Message & "terminated task"; + end if; + + return Target.Common.Base_Priority; + end Get_Priority; + + ------------------ + -- Set_Priority -- + ------------------ + + -- Change base priority of a task dynamically + + procedure Set_Priority + (Priority : System.Any_Priority; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + is + Target : constant Task_Id := Convert_Ids (T); + Error_Message : constant String := "Trying to set the priority of a "; + Yield_Needed : Boolean; + + begin + if Target = Convert_Ids (Ada.Task_Identification.Null_Task_Id) then + raise Program_Error with Error_Message & "null task"; + end if; + + -- Setting the priority of an already-terminated task doesn't do + -- anything (see RM-D.5.1(7)). Note that Get_Priority is different in + -- this regard. + + if Task_Identification.Is_Terminated (T) then + return; + end if; + + SSL.Abort_Defer.all; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Target); + + Target.Common.Base_Priority := Priority; + + if Target.Common.Call /= null + and then + Target.Common.Call.Acceptor_Prev_Priority /= Priority_Not_Boosted + then + -- Target is within a rendezvous, so ensure the correct priority + -- will be reset when finishing the rendezvous, and only change the + -- priority immediately if the new priority is greater than the + -- current (inherited) priority. + + Target.Common.Call.Acceptor_Prev_Priority := Priority; + + if Priority >= Target.Common.Current_Priority then + Yield_Needed := True; + STPO.Set_Priority (Target, Priority); + else + Yield_Needed := False; + end if; + + else + Yield_Needed := True; + STPO.Set_Priority (Target, Priority); + + if Target.Common.State = Entry_Caller_Sleep then + Target.Pending_Priority_Change := True; + STPO.Wakeup (Target, Target.Common.State); + end if; + end if; + + STPO.Unlock (Target); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + if STPO.Self = Target and then Yield_Needed then + + -- Yield is needed to enforce FIFO task dispatching + + -- LL Set_Priority is made while holding the RTS lock so that it is + -- inheriting high priority until it release all the RTS locks. + + -- If this is used in a system where Ceiling Locking is not enforced + -- we may end up getting two Yield effects. + + STPO.Yield; + end if; + + SSL.Abort_Undefer.all; + end Set_Priority; + +end Ada.Dynamic_Priorities; diff --git a/gcc/ada/a-dynpri.ads b/gcc/ada/a-dynpri.ads new file mode 100644 index 000000000..03e02d635 --- /dev/null +++ b/gcc/ada/a-dynpri.ads @@ -0,0 +1,33 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D Y N A M I C _ P R I O R I T I E S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with System; +with Ada.Task_Identification; + +package Ada.Dynamic_Priorities is + pragma Preelaborate_05; + -- In accordance with Ada 2005 AI-362 + + procedure Set_Priority + (Priority : System.Any_Priority; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task); + + function Get_Priority + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + return System.Any_Priority; + +end Ada.Dynamic_Priorities; diff --git a/gcc/ada/a-einuoc.adb b/gcc/ada/a-einuoc.adb new file mode 100644 index 000000000..f70eff0ed --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..8d772b01f --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 new file mode 100644 index 000000000..087e22f4f --- /dev/null +++ b/gcc/ada/a-elchha.adb @@ -0,0 +1,138 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 Warnings (Off); +pragma Compiler_Unit; +pragma Warnings (On); + +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_Exception_Information + (X : Exception_Occurrence; Info : in out String; Ptr : in out Natural); + pragma Import + (Ada, Append_Info_Exception_Information, "__gnat_append_info_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_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 new file mode 100644 index 000000000..8cbba63ee --- /dev/null +++ b/gcc/ada/a-elchha.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 Warnings (Off); +pragma Compiler_Unit; +pragma Warnings (On); + +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 new file mode 100755 index 000000000..cb57ca194 --- /dev/null +++ b/gcc/ada/a-envvar.adb @@ -0,0 +1,226 @@ +------------------------------------------------------------------------------ +-- -- +-- 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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 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; + + procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); + pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv"); + + procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); + pragma Import (C, Strncpy, "strncpy"); + + 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, Env_Value_Length); + return Result; + end; + else + return ""; + end if; + end Value; + +end Ada.Environment_Variables; diff --git a/gcc/ada/a-envvar.ads b/gcc/ada/a-envvar.ads new file mode 100755 index 000000000..9769c9bb1 --- /dev/null +++ b/gcc/ada/a-envvar.ads @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E N V I R O N M E N T _ V A R I A B L E S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Environment_Variables is + pragma Preelaborate (Environment_Variables); + + function Value (Name : String) return String; + -- If the external execution environment supports environment variables, + -- then Value returns the value of the environment variable with the given + -- name. If no environment variable with the given name exists, then + -- Constraint_Error is propagated. If the execution environment does not + -- support environment variables, then Program_Error is propagated. + + function Exists (Name : String) return Boolean; + -- If the external execution environment supports environment variables and + -- an environment variable with the given name currently exists, then + -- Exists returns True; otherwise it returns False. + + procedure Set (Name : String; Value : String); + -- If the external execution environment supports environment variables, + -- then Set first clears any existing environment variable with the given + -- name, and then defines a single new environment variable with the given + -- name and value. Otherwise Program_Error is propagated. + -- If implementation-defined circumstances prohibit the definition of an + -- environment variable with the given name and value, then + -- Constraint_Error is propagated. + -- It is implementation defined whether there exist values for which the + -- call Set (Name, Value) has the same effect as Clear (Name). + + procedure Clear (Name : String); + -- If the external execution environment supports environment variables, + -- then Clear deletes all existing environment variables with the given + -- name. Otherwise Program_Error is propagated. + + procedure Clear; + -- If the external execution environment supports environment variables, + -- then Clear deletes all existing environment variables. Otherwise + -- Program_Error is propagated. + + procedure Iterate + (Process : not null access procedure (Name, Value : String)); + -- If the external execution environment supports environment variables, + -- then Iterate calls the subprogram designated by Process for each + -- existing environment variable, passing the name and value of that + -- environment variable. Otherwise Program_Error is propagated. + +end Ada.Environment_Variables; diff --git a/gcc/ada/a-etgrbu.ads b/gcc/ada/a-etgrbu.ads new file mode 100644 index 000000000..1c86cee79 --- /dev/null +++ b/gcc/ada/a-etgrbu.ads @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X E C U T I O N _ T I M E . G R O U P _ B U D G E T S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit is not implemented in typical GNAT implementations that lie on +-- top of operating systems, because it is infeasible to implement in such +-- environments. + +-- If a target environment provides appropriate support for this package, +-- then the Unimplemented_Unit pragma should be removed from this spec and +-- an appropriate body provided. + +with System; + +package Ada.Execution_Time.Group_Budgets is + pragma Preelaborate; + + pragma Unimplemented_Unit; + + type Group_Budget is tagged limited private; + + type Group_Budget_Handler is access + protected procedure (GB : in out Group_Budget); + + type Task_Array is + array (Positive range <>) of Ada.Task_Identification.Task_Id; + + Min_Handler_Ceiling : constant System.Any_Priority := + System.Any_Priority'First; + -- Initial value is an arbitrary choice ??? + + procedure Add_Task + (GB : in out Group_Budget; + T : Ada.Task_Identification.Task_Id); + + procedure Remove_Task + (GB : in out Group_Budget; + T : Ada.Task_Identification.Task_Id); + + function Is_Member + (GB : Group_Budget; + T : Ada.Task_Identification.Task_Id) return Boolean; + + function Is_A_Group_Member + (T : Ada.Task_Identification.Task_Id) return Boolean; + + function Members (GB : Group_Budget) return Task_Array; + + procedure Replenish + (GB : in out Group_Budget; + To : Ada.Real_Time.Time_Span); + + procedure Add + (GB : in out Group_Budget; + Interval : Ada.Real_Time.Time_Span); + + function Budget_Has_Expired (GB : Group_Budget) return Boolean; + + function Budget_Remaining + (GB : Group_Budget) return Ada.Real_Time.Time_Span; + + procedure Set_Handler + (GB : in out Group_Budget; + Handler : Group_Budget_Handler); + + function Current_Handler (GB : Group_Budget) return Group_Budget_Handler; + + procedure Cancel_Handler + (GB : in out Group_Budget; + Cancelled : out Boolean); + + Group_Budget_Error : exception; + +private + type Group_Budget is tagged limited null record; +end Ada.Execution_Time.Group_Budgets; diff --git a/gcc/ada/a-excach.adb b/gcc/ada/a-excach.adb new file mode 100644 index 000000000..6a33601fb --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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'Address, + 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-2005.adb b/gcc/ada/a-except-2005.adb new file mode 100644 index 000000000..cbf1e4deb --- /dev/null +++ b/gcc/ada/a-except-2005.adb @@ -0,0 +1,1514 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This version of Ada.Exceptions fully supports both Ada 95 and Ada 2005. +-- It is used in all situations except for the build of the compiler and +-- other basic tools. For these latter builds, we use an Ada 95-only version. + +-- The reason for this splitting off of a separate version is that bootstrap +-- compilers often will be used that do not support Ada 2005 features, and +-- Ada.Exceptions is part of the compiler sources. + +pragma Style_Checks (All_Checks); +-- No subprogram ordering check, due to logical grouping + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we get +-- elaboration circularities with System.Exception_Tables. + +with System; use System; +with System.Exceptions; use System.Exceptions; +with System.Standard_Library; use System.Standard_Library; +with System.Soft_Links; use System.Soft_Links; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_StW; use System.WCh_StW; + +package body Ada.Exceptions is + + pragma Suppress (All_Checks); + -- We definitely do not want exceptions occurring within this unit, or + -- we are in big trouble. If an exceptional situation does occur, better + -- that it not be raised, since raising it can cause confusing chaos. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + -- Note: the exported subprograms in this package body are called directly + -- from C clients using the given external name, even though they are not + -- technically visible in the Ada sense. + + function Code_Address_For_AAA return System.Address; + function Code_Address_For_ZZZ return System.Address; + -- Return start and end of procedures in this package + -- + -- These procedures are used to provide exclusion bounds in + -- calls to Call_Chain at exception raise points from this unit. The + -- purpose is to arrange for the exception tracebacks not to include + -- frames from routines involved in the raise process, as these are + -- meaningless from the user's standpoint. + -- + -- For these bounds to be meaningful, we need to ensure that the object + -- code for the routines involved in processing a raise is located after + -- the object code Code_Address_For_AAA and before the object code + -- Code_Address_For_ZZZ. This will indeed be the case as long as the + -- following rules are respected: + -- + -- 1) The bodies of the subprograms involved in processing a raise + -- are located after the body of Code_Address_For_AAA and before the + -- body of Code_Address_For_ZZZ. + -- + -- 2) No pragma Inline applies to any of these subprograms, as this + -- could delay the corresponding assembly output until the end of + -- the unit. + + procedure Call_Chain (Excep : EOA); + -- Store up to Max_Tracebacks in Excep, corresponding to the current + -- call chain. + + function Image (Index : Integer) return String; + -- Return string image corresponding to Index + + procedure To_Stderr (S : String); + pragma Export (Ada, To_Stderr, "__gnat_to_stderr"); + -- Little routine to output string to stderr that is also used + -- in the tasking run time. + + procedure To_Stderr (C : Character); + pragma Inline (To_Stderr); + pragma Export (Ada, To_Stderr, "__gnat_to_stderr_char"); + -- Little routine to output a character to stderr, used by some of + -- the separate units below. + + package Exception_Data is + + --------------------------------- + -- Exception messages routines -- + --------------------------------- + + procedure Set_Exception_C_Msg + (Id : Exception_Id; + Msg1 : System.Address; + Line : Integer := 0; + Column : Integer := 0; + Msg2 : System.Address := System.Null_Address); + -- This routine is called to setup the exception referenced by the + -- Current_Excep field in the TSD to contain the indicated Id value + -- and message. Msg1 is a null terminated string which is generated + -- as the exception message. If line is non-zero, then a colon and + -- the decimal representation of this integer is appended to the + -- message. Ditto for Column. When Msg2 is non-null, a space and this + -- additional null terminated string is added to the message. + + procedure Set_Exception_Msg + (Id : Exception_Id; + Message : String); + -- This routine is called to setup the exception referenced by the + -- Current_Excep field in the TSD to contain the indicated Id value + -- and message. Message is a string which is generated as the + -- exception message. + + -------------------------------------- + -- Exception information subprogram -- + -------------------------------------- + + function Exception_Information (X : Exception_Occurrence) return String; + -- The format of the exception information is as follows: + -- + -- Exception_Name: (as in Exception_Name) + -- Message: (only if Exception_Message is empty) + -- PID=nnnn (only if != 0) + -- Call stack traceback locations: (only if at least one location) + -- <0xyyyyyyyy 0xyyyyyyyy ...> (is recorded) + -- + -- The lines are separated by a ASCII.LF character. + -- The nnnn is the partition Id given as decimal digits. + -- The 0x... line represents traceback program counter locations, in + -- execution order with the first one being the exception location. It + -- is present only + -- + -- The Exception_Name and Message lines are omitted in the abort + -- signal case, since this is not really an exception. + + -- !! If the format of the generated string is changed, please note + -- !! that an equivalent modification to the routine String_To_EO must + -- !! be made to preserve proper functioning of the stream attributes. + + --------------------------------------- + -- Exception backtracing subprograms -- + --------------------------------------- + + -- What is automatically output when exception tracing is on is the + -- usual exception information with the call chain backtrace possibly + -- tailored by a backtrace decorator. Modifying Exception_Information + -- itself is not a good idea because the decorated output is completely + -- out of control and would break all our code related to the streaming + -- of exceptions. We then provide an alternative function to compute + -- the possibly tailored output, which is equivalent if no decorator is + -- currently set: + + function Tailored_Exception_Information + (X : Exception_Occurrence) return String; + -- Exception information to be output in the case of automatic tracing + -- requested through GNAT.Exception_Traces. + -- + -- This is the same as Exception_Information if no backtrace decorator + -- is currently in place. Otherwise, this is Exception_Information with + -- the call chain raw addresses replaced by the result of a call to the + -- current decorator provided with the call chain addresses. + + pragma Export + (Ada, Tailored_Exception_Information, + "__gnat_tailored_exception_information"); + -- This is currently used by System.Tasking.Stages + + end Exception_Data; + + package Exception_Traces is + + use Exception_Data; + -- Imports Tailored_Exception_Information + + ---------------------------------------------- + -- Run-Time Exception Notification Routines -- + ---------------------------------------------- + + -- These subprograms provide a common run-time interface to trigger the + -- actions required when an exception is about to be propagated (e.g. + -- user specified actions or output of exception information). They are + -- exported to be usable by the Ada exception handling personality + -- routine when the GCC 3 mechanism is used. + + procedure Notify_Handled_Exception; + pragma Export + (C, Notify_Handled_Exception, "__gnat_notify_handled_exception"); + -- This routine is called for a handled occurrence is about to be + -- propagated. + + procedure Notify_Unhandled_Exception; + pragma Export + (C, Notify_Unhandled_Exception, "__gnat_notify_unhandled_exception"); + -- This routine is called when an unhandled occurrence is about to be + -- propagated. + + procedure Unhandled_Exception_Terminate; + pragma No_Return (Unhandled_Exception_Terminate); + -- This procedure is called to terminate execution following an + -- unhandled exception. The exception information, including + -- traceback if available is output, and execution is then + -- terminated. Note that at the point where this routine is + -- called, the stack has typically been destroyed. + + end Exception_Traces; + + package Exception_Propagation is + + use Exception_Traces; + -- Imports Notify_Unhandled_Exception and + -- Unhandled_Exception_Terminate + + ------------------------------------ + -- Exception propagation routines -- + ------------------------------------ + + procedure Setup_Exception + (Excep : EOA; + Current : EOA; + Reraised : Boolean := False); + -- Perform the necessary operations to prepare the propagation of Excep + -- in a task where Current is the current occurrence. Excep is assumed + -- to be a valid (non null) pointer. + -- + -- This should be called before any (re-)setting of the current + -- occurrence. Any such (re-)setting shall take care *not* to clobber + -- the Private_Data component. + -- + -- Having Current provided as an argument (instead of retrieving it via + -- Get_Current_Excep internally) is required to allow one task to setup + -- an exception for another task, which is used by Transfer_Occurrence. + + procedure Propagate_Exception + (E : Exception_Id; + From_Signal_Handler : Boolean); + pragma No_Return (Propagate_Exception); + -- This procedure propagates the exception represented by the occurrence + -- referenced by Current_Excep in the TSD for the current task. + + end Exception_Propagation; + + package Stream_Attributes is + + -------------------------------- + -- Stream attributes routines -- + -------------------------------- + + function EId_To_String (X : Exception_Id) return String; + function String_To_EId (S : String) return Exception_Id; + -- Functions for implementing Exception_Id stream attributes + + function EO_To_String (X : Exception_Occurrence) return String; + function String_To_EO (S : String) return Exception_Occurrence; + -- Functions for implementing Exception_Occurrence stream + -- attributes + + end Stream_Attributes; + + procedure Raise_Current_Excep (E : Exception_Id); + pragma No_Return (Raise_Current_Excep); + pragma Export (C, Raise_Current_Excep, "__gnat_raise_nodefer_with_msg"); + -- This is a simple wrapper to Exception_Propagation.Propagate_Exception + -- setting the From_Signal_Handler argument to False. + -- + -- This external name for Raise_Current_Excep is historical, and probably + -- should be changed but for now we keep it, because gdb and gigi know + -- about it. + + procedure Raise_Exception_No_Defer + (E : Exception_Id; Message : String := ""); + pragma Export + (Ada, Raise_Exception_No_Defer, + "ada__exceptions__raise_exception_no_defer"); + pragma No_Return (Raise_Exception_No_Defer); + -- Similar to Raise_Exception, but with no abort deferral + + procedure Raise_With_Msg (E : Exception_Id); + pragma No_Return (Raise_With_Msg); + pragma Export (C, Raise_With_Msg, "__gnat_raise_with_msg"); + -- Raises an exception with given exception id value. A message + -- is associated with the raise, and has already been stored in the + -- exception occurrence referenced by the Current_Excep in the TSD. + -- Abort is deferred before the raise call. + + procedure Raise_With_Location_And_Msg + (E : Exception_Id; + F : System.Address; + L : Integer; + C : Integer := 0; + M : System.Address := System.Null_Address); + pragma No_Return (Raise_With_Location_And_Msg); + -- Raise an exception with given exception id value. A filename and line + -- number is associated with the raise and is stored in the exception + -- occurrence and in addition a column and a string message M may be + -- appended to this (if not null/0). + + procedure Raise_Constraint_Error + (File : System.Address; + Line : Integer); + pragma No_Return (Raise_Constraint_Error); + pragma Export + (C, Raise_Constraint_Error, "__gnat_raise_constraint_error"); + -- Raise constraint error with file:line information + + procedure Raise_Constraint_Error_Msg + (File : System.Address; + Line : Integer; + Column : Integer; + Msg : System.Address); + pragma No_Return (Raise_Constraint_Error_Msg); + pragma Export + (C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg"); + -- Raise constraint error with file:line:col + msg information + + procedure Raise_Program_Error + (File : System.Address; + Line : Integer); + pragma No_Return (Raise_Program_Error); + pragma Export + (C, Raise_Program_Error, "__gnat_raise_program_error"); + -- Raise program error with file:line information + + procedure Raise_Program_Error_Msg + (File : System.Address; + Line : Integer; + Msg : System.Address); + pragma No_Return (Raise_Program_Error_Msg); + pragma Export + (C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg"); + -- Raise program error with file:line + msg information + + procedure Raise_Storage_Error + (File : System.Address; + Line : Integer); + pragma No_Return (Raise_Storage_Error); + pragma Export + (C, Raise_Storage_Error, "__gnat_raise_storage_error"); + -- Raise storage error with file:line information + + procedure Raise_Storage_Error_Msg + (File : System.Address; + Line : Integer; + Msg : System.Address); + pragma No_Return (Raise_Storage_Error_Msg); + pragma Export + (C, Raise_Storage_Error_Msg, "__gnat_raise_storage_error_msg"); + -- Raise storage error with file:line + reason msg information + + -- The exception raising process and the automatic tracing mechanism rely + -- on some careful use of flags attached to the exception occurrence. The + -- graph below illustrates the relations between the Raise_ subprograms + -- and identifies the points where basic flags such as Exception_Raised + -- are initialized. + -- + -- (i) signs indicate the flags initialization points. R stands for Raise, + -- W for With, and E for Exception. + -- + -- R_No_Msg R_E R_Pe R_Ce R_Se + -- | | | | | + -- +--+ +--+ +---+ | +---+ + -- | | | | | + -- R_E_No_Defer(i) R_W_Msg(i) R_W_Loc + -- | | | | + -- +------------+ | +-----------+ +--+ + -- | | | | + -- | | | Set_E_C_Msg(i) + -- | | | + -- Raise_Current_Excep + + procedure Reraise; + pragma No_Return (Reraise); + pragma Export (C, Reraise, "__gnat_reraise"); + -- Reraises the exception referenced by the Current_Excep field of + -- the TSD (all fields of this exception occurrence are set). Abort + -- is deferred before the reraise operation. + + -- Save_Occurrence variations: As the management of the private data + -- attached to occurrences is delicate, whether or not pointers to such + -- data has to be copied in various situations is better made explicit. + -- The following procedures provide an internal interface to help making + -- this explicit. + + procedure Save_Occurrence_No_Private + (Target : out Exception_Occurrence; + Source : Exception_Occurrence); + -- Copy all the components of Source to Target, except the + -- Private_Data pointer. + + procedure Transfer_Occurrence + (Target : Exception_Occurrence_Access; + Source : Exception_Occurrence); + pragma Export (C, Transfer_Occurrence, "__gnat_transfer_occurrence"); + -- Called from System.Tasking.RendezVous.Exceptional_Complete_RendezVous + -- to setup Target from Source as an exception to be propagated in the + -- caller task. Target is expected to be a pointer to the fixed TSD + -- occurrence for this task. + + ----------------------------- + -- Run-Time Check Routines -- + ----------------------------- + + -- These routines raise a specific exception with a reason message + -- attached. The parameters are the file name and line number in each + -- case. The names are keyed to the codes defined in types.ads and + -- a-types.h (for example, the name Rcheck_05 refers to the Reason + -- RT_Exception_Code'Val (5)). + + procedure Rcheck_00 (File : System.Address; Line : Integer); + procedure Rcheck_01 (File : System.Address; Line : Integer); + procedure Rcheck_02 (File : System.Address; Line : Integer); + procedure Rcheck_03 (File : System.Address; Line : Integer); + procedure Rcheck_04 (File : System.Address; Line : Integer); + procedure Rcheck_05 (File : System.Address; Line : Integer); + procedure Rcheck_06 (File : System.Address; Line : Integer); + procedure Rcheck_07 (File : System.Address; Line : Integer); + procedure Rcheck_08 (File : System.Address; Line : Integer); + procedure Rcheck_09 (File : System.Address; Line : Integer); + procedure Rcheck_10 (File : System.Address; Line : Integer); + procedure Rcheck_11 (File : System.Address; Line : Integer); + procedure Rcheck_12 (File : System.Address; Line : Integer); + procedure Rcheck_13 (File : System.Address; Line : Integer); + procedure Rcheck_14 (File : System.Address; Line : Integer); + procedure Rcheck_15 (File : System.Address; Line : Integer); + procedure Rcheck_16 (File : System.Address; Line : Integer); + procedure Rcheck_17 (File : System.Address; Line : Integer); + procedure Rcheck_18 (File : System.Address; Line : Integer); + procedure Rcheck_19 (File : System.Address; Line : Integer); + procedure Rcheck_20 (File : System.Address; Line : Integer); + procedure Rcheck_21 (File : System.Address; Line : Integer); + procedure Rcheck_22 (File : System.Address; Line : Integer); + procedure Rcheck_23 (File : System.Address; Line : Integer); + procedure Rcheck_24 (File : System.Address; Line : Integer); + procedure Rcheck_25 (File : System.Address; Line : Integer); + procedure Rcheck_26 (File : System.Address; Line : Integer); + procedure Rcheck_27 (File : System.Address; Line : Integer); + procedure Rcheck_28 (File : System.Address; Line : Integer); + procedure Rcheck_29 (File : System.Address; Line : Integer); + procedure Rcheck_30 (File : System.Address; Line : Integer); + procedure Rcheck_31 (File : System.Address; Line : Integer); + procedure Rcheck_32 (File : System.Address; Line : Integer); + procedure Rcheck_33 (File : System.Address; Line : Integer); + procedure Rcheck_34 (File : System.Address; Line : Integer); + + procedure Rcheck_00_Ext + (File : System.Address; Line, Column : Integer); + procedure Rcheck_05_Ext + (File : System.Address; Line, Column, Index, First, Last : Integer); + procedure Rcheck_06_Ext + (File : System.Address; Line, Column, Index, First, Last : Integer); + procedure Rcheck_12_Ext + (File : System.Address; Line, Column, Index, First, Last : Integer); + + pragma Export (C, Rcheck_00, "__gnat_rcheck_00"); + pragma Export (C, Rcheck_01, "__gnat_rcheck_01"); + pragma Export (C, Rcheck_02, "__gnat_rcheck_02"); + pragma Export (C, Rcheck_03, "__gnat_rcheck_03"); + pragma Export (C, Rcheck_04, "__gnat_rcheck_04"); + pragma Export (C, Rcheck_05, "__gnat_rcheck_05"); + pragma Export (C, Rcheck_06, "__gnat_rcheck_06"); + pragma Export (C, Rcheck_07, "__gnat_rcheck_07"); + pragma Export (C, Rcheck_08, "__gnat_rcheck_08"); + pragma Export (C, Rcheck_09, "__gnat_rcheck_09"); + pragma Export (C, Rcheck_10, "__gnat_rcheck_10"); + pragma Export (C, Rcheck_11, "__gnat_rcheck_11"); + pragma Export (C, Rcheck_12, "__gnat_rcheck_12"); + pragma Export (C, Rcheck_13, "__gnat_rcheck_13"); + pragma Export (C, Rcheck_14, "__gnat_rcheck_14"); + pragma Export (C, Rcheck_15, "__gnat_rcheck_15"); + pragma Export (C, Rcheck_16, "__gnat_rcheck_16"); + pragma Export (C, Rcheck_17, "__gnat_rcheck_17"); + pragma Export (C, Rcheck_18, "__gnat_rcheck_18"); + pragma Export (C, Rcheck_19, "__gnat_rcheck_19"); + pragma Export (C, Rcheck_20, "__gnat_rcheck_20"); + pragma Export (C, Rcheck_21, "__gnat_rcheck_21"); + pragma Export (C, Rcheck_22, "__gnat_rcheck_22"); + pragma Export (C, Rcheck_23, "__gnat_rcheck_23"); + pragma Export (C, Rcheck_24, "__gnat_rcheck_24"); + pragma Export (C, Rcheck_25, "__gnat_rcheck_25"); + pragma Export (C, Rcheck_26, "__gnat_rcheck_26"); + pragma Export (C, Rcheck_27, "__gnat_rcheck_27"); + pragma Export (C, Rcheck_28, "__gnat_rcheck_28"); + pragma Export (C, Rcheck_29, "__gnat_rcheck_29"); + pragma Export (C, Rcheck_30, "__gnat_rcheck_30"); + pragma Export (C, Rcheck_31, "__gnat_rcheck_31"); + pragma Export (C, Rcheck_32, "__gnat_rcheck_32"); + pragma Export (C, Rcheck_33, "__gnat_rcheck_33"); + pragma Export (C, Rcheck_34, "__gnat_rcheck_34"); + + pragma Export (C, Rcheck_00_Ext, "__gnat_rcheck_00_ext"); + pragma Export (C, Rcheck_05_Ext, "__gnat_rcheck_05_ext"); + pragma Export (C, Rcheck_06_Ext, "__gnat_rcheck_06_ext"); + pragma Export (C, Rcheck_12_Ext, "__gnat_rcheck_12_ext"); + + -- None of these procedures ever returns (they raise an exception!). By + -- using pragma No_Return, we ensure that any junk code after the call, + -- such as normal return epilog stuff, can be eliminated). + + pragma No_Return (Rcheck_00); + pragma No_Return (Rcheck_01); + pragma No_Return (Rcheck_02); + pragma No_Return (Rcheck_03); + pragma No_Return (Rcheck_04); + pragma No_Return (Rcheck_05); + pragma No_Return (Rcheck_06); + pragma No_Return (Rcheck_07); + pragma No_Return (Rcheck_08); + pragma No_Return (Rcheck_09); + pragma No_Return (Rcheck_10); + pragma No_Return (Rcheck_11); + pragma No_Return (Rcheck_12); + pragma No_Return (Rcheck_13); + pragma No_Return (Rcheck_14); + pragma No_Return (Rcheck_15); + pragma No_Return (Rcheck_16); + pragma No_Return (Rcheck_17); + pragma No_Return (Rcheck_18); + pragma No_Return (Rcheck_19); + pragma No_Return (Rcheck_20); + pragma No_Return (Rcheck_21); + pragma No_Return (Rcheck_22); + pragma No_Return (Rcheck_23); + pragma No_Return (Rcheck_24); + pragma No_Return (Rcheck_25); + pragma No_Return (Rcheck_26); + pragma No_Return (Rcheck_27); + pragma No_Return (Rcheck_28); + pragma No_Return (Rcheck_29); + pragma No_Return (Rcheck_30); + pragma No_Return (Rcheck_32); + pragma No_Return (Rcheck_33); + pragma No_Return (Rcheck_34); + + pragma No_Return (Rcheck_00_Ext); + pragma No_Return (Rcheck_05_Ext); + pragma No_Return (Rcheck_06_Ext); + pragma No_Return (Rcheck_12_Ext); + + --------------------------------------------- + -- Reason Strings for Run-Time Check Calls -- + --------------------------------------------- + + -- These strings are null-terminated and are used by Rcheck_nn. The + -- strings correspond to the definitions for Types.RT_Exception_Code. + + use ASCII; + + Rmsg_00 : constant String := "access check failed" & NUL; + Rmsg_01 : constant String := "access parameter is null" & NUL; + Rmsg_02 : constant String := "discriminant check failed" & NUL; + Rmsg_03 : constant String := "divide by zero" & NUL; + Rmsg_04 : constant String := "explicit raise" & NUL; + Rmsg_05 : constant String := "index check failed" & NUL; + Rmsg_06 : constant String := "invalid data" & NUL; + Rmsg_07 : constant String := "length check failed" & NUL; + Rmsg_08 : constant String := "null Exception_Id" & NUL; + Rmsg_09 : constant String := "null-exclusion check failed" & NUL; + Rmsg_10 : constant String := "overflow check failed" & NUL; + Rmsg_11 : constant String := "partition check failed" & NUL; + Rmsg_12 : constant String := "range check failed" & NUL; + Rmsg_13 : constant String := "tag check failed" & NUL; + Rmsg_14 : constant String := "access before elaboration" & NUL; + Rmsg_15 : constant String := "accessibility check failed" & NUL; + Rmsg_16 : constant String := "attempt to take address of" & + " intrinsic subprogram" & NUL; + Rmsg_17 : constant String := "all guards closed" & NUL; + Rmsg_18 : constant String := "improper use of generic subtype" & + " with predicate" & NUL; + Rmsg_19 : constant String := "Current_Task referenced in entry" & + " body" & NUL; + Rmsg_20 : constant String := "duplicated entry address" & NUL; + Rmsg_21 : constant String := "explicit raise" & NUL; + Rmsg_22 : constant String := "finalize/adjust raised exception" & NUL; + Rmsg_23 : constant String := "implicit return with No_Return" & NUL; + Rmsg_24 : constant String := "misaligned address value" & NUL; + Rmsg_25 : constant String := "missing return" & NUL; + Rmsg_26 : constant String := "overlaid controlled object" & NUL; + Rmsg_27 : constant String := "potentially blocking operation" & NUL; + Rmsg_28 : constant String := "stubbed subprogram called" & NUL; + Rmsg_29 : constant String := "unchecked union restriction" & NUL; + Rmsg_30 : constant String := "actual/returned class-wide" & + " value not transportable" & NUL; + Rmsg_31 : constant String := "empty storage pool" & NUL; + Rmsg_32 : constant String := "explicit raise" & NUL; + Rmsg_33 : constant String := "infinite recursion" & NUL; + Rmsg_34 : constant String := "object too large" & NUL; + + ----------------------- + -- Polling Interface -- + ----------------------- + + type Unsigned is mod 2 ** 32; + + Counter : Unsigned := 0; + pragma Warnings (Off, Counter); + -- This counter is provided for convenience. It can be used in Poll to + -- perform periodic but not systematic operations. + + procedure Poll is separate; + -- The actual polling routine is separate, so that it can easily + -- be replaced with a target dependent version. + + -------------------------- + -- Code_Address_For_AAA -- + -------------------------- + + -- This function gives us the start of the PC range for addresses + -- within the exception unit itself. We hope that gigi/gcc keep all the + -- procedures in their original order! + + function Code_Address_For_AAA return System.Address is + begin + -- We are using a label instead of merely using + -- Code_Address_For_AAA'Address because on some platforms the latter + -- does not yield the address we want, but the address of a stub or of + -- a descriptor instead. This is the case at least on Alpha-VMS and + -- PA-HPUX. + + <> + return Start_Of_AAA'Address; + end Code_Address_For_AAA; + + ---------------- + -- Call_Chain -- + ---------------- + + procedure Call_Chain (Excep : EOA) is separate; + -- The actual Call_Chain routine is separate, so that it can easily + -- be dummied out when no exception traceback information is needed. + + ------------------------------ + -- Current_Target_Exception -- + ------------------------------ + + function Current_Target_Exception return Exception_Occurrence is + begin + return Null_Occurrence; + end Current_Target_Exception; + + ------------------- + -- EId_To_String -- + ------------------- + + function EId_To_String (X : Exception_Id) return String + renames Stream_Attributes.EId_To_String; + + ------------------ + -- EO_To_String -- + ------------------ + + -- We use the null string to represent the null occurrence, otherwise + -- we output the Exception_Information string for the occurrence. + + function EO_To_String (X : Exception_Occurrence) return String + renames Stream_Attributes.EO_To_String; + + ------------------------ + -- Exception_Identity -- + ------------------------ + + function Exception_Identity + (X : Exception_Occurrence) return Exception_Id + is + begin + -- Note that the following test used to be here for the original + -- Ada 95 semantics, but these were modified by AI-241 to require + -- returning Null_Id instead of raising Constraint_Error. + + -- if X.Id = Null_Id then + -- raise Constraint_Error; + -- end if; + + return X.Id; + end Exception_Identity; + + --------------------------- + -- Exception_Information -- + --------------------------- + + function Exception_Information (X : Exception_Occurrence) return String is + begin + if X.Id = Null_Id then + raise Constraint_Error; + end if; + + return Exception_Data.Exception_Information (X); + end Exception_Information; + + ----------------------- + -- Exception_Message -- + ----------------------- + + function Exception_Message (X : Exception_Occurrence) return String is + begin + if X.Id = Null_Id then + raise Constraint_Error; + end if; + + return X.Msg (1 .. X.Msg_Length); + end Exception_Message; + + -------------------- + -- Exception_Name -- + -------------------- + + function Exception_Name (Id : Exception_Id) return String is + begin + if Id = null then + raise Constraint_Error; + end if; + + return To_Ptr (Id.Full_Name) (1 .. Id.Name_Length - 1); + end Exception_Name; + + function Exception_Name (X : Exception_Occurrence) return String is + begin + return Exception_Name (X.Id); + end Exception_Name; + + --------------------------- + -- Exception_Name_Simple -- + --------------------------- + + function Exception_Name_Simple (X : Exception_Occurrence) return String is + Name : constant String := Exception_Name (X); + P : Natural; + + begin + P := Name'Length; + while P > 1 loop + exit when Name (P - 1) = '.'; + P := P - 1; + end loop; + + -- Return result making sure lower bound is 1 + + declare + subtype Rname is String (1 .. Name'Length - P + 1); + begin + return Rname (Name (P .. Name'Length)); + end; + end Exception_Name_Simple; + + -------------------- + -- Exception_Data -- + -------------------- + + package body Exception_Data is separate; + -- This package can be easily dummied out if we do not want the + -- basic support for exception messages (such as in Ada 83). + + --------------------------- + -- Exception_Propagation -- + --------------------------- + + package body Exception_Propagation is separate; + -- Depending on the actual exception mechanism used (front-end or + -- back-end based), the implementation will differ, which is why this + -- package is separated. + + ---------------------- + -- Exception_Traces -- + ---------------------- + + package body Exception_Traces is separate; + -- Depending on the underlying support for IO the implementation + -- will differ. Moreover we would like to dummy out this package + -- in case we do not want any exception tracing support. This is + -- why this package is separated. + + ----------------------- + -- Stream Attributes -- + ----------------------- + + package body Stream_Attributes is separate; + -- This package can be easily dummied out if we do not want the + -- support for streaming Exception_Ids and Exception_Occurrences. + + ---------------------------- + -- Raise_Constraint_Error -- + ---------------------------- + + procedure Raise_Constraint_Error (File : System.Address; Line : Integer) is + begin + Raise_With_Location_And_Msg (Constraint_Error_Def'Access, File, Line); + end Raise_Constraint_Error; + + -------------------------------- + -- Raise_Constraint_Error_Msg -- + -------------------------------- + + procedure Raise_Constraint_Error_Msg + (File : System.Address; + Line : Integer; + Column : Integer; + Msg : System.Address) + is + begin + Raise_With_Location_And_Msg + (Constraint_Error_Def'Access, File, Line, Column, Msg); + end Raise_Constraint_Error_Msg; + + ------------------------- + -- Raise_Current_Excep -- + ------------------------- + + procedure Raise_Current_Excep (E : Exception_Id) is + + pragma Inspection_Point (E); + -- This is so the debugger can reliably inspect the parameter when + -- inserting a breakpoint at the start of this procedure. + + -- To provide support for breakpoints on unhandled exceptions, the + -- debugger will also need to be able to inspect the value of E from + -- inner frames so we need to make sure that its value is also spilled + -- on stack. We take the address and dereference using volatile local + -- objects for this purpose. + + -- The pragma Warnings (Off) are needed because the compiler knows that + -- these locals are not referenced and that this use of pragma Volatile + -- is peculiar! + + type EID_Access is access Exception_Id; + + Access_To_E : EID_Access := E'Unrestricted_Access; + pragma Volatile (Access_To_E); + pragma Warnings (Off, Access_To_E); + + Id : Exception_Id := Access_To_E.all; + pragma Volatile (Id); + pragma Warnings (Off, Id); + + begin + Debug_Raise_Exception (E => SSL.Exception_Data_Ptr (E)); + Exception_Propagation.Propagate_Exception + (E => E, From_Signal_Handler => False); + end Raise_Current_Excep; + + --------------------- + -- Raise_Exception -- + --------------------- + + procedure Raise_Exception + (E : Exception_Id; + Message : String := "") + is + EF : Exception_Id := E; + + begin + -- Raise CE if E = Null_ID (AI-446) + + if E = null then + EF := Constraint_Error'Identity; + end if; + + -- Go ahead and raise appropriate exception + + Exception_Data.Set_Exception_Msg (EF, Message); + Abort_Defer.all; + Raise_Current_Excep (EF); + end Raise_Exception; + + ---------------------------- + -- Raise_Exception_Always -- + ---------------------------- + + procedure Raise_Exception_Always + (E : Exception_Id; + Message : String := "") + is + begin + Exception_Data.Set_Exception_Msg (E, Message); + Abort_Defer.all; + Raise_Current_Excep (E); + end Raise_Exception_Always; + + ------------------------------------- + -- Raise_From_Controlled_Operation -- + ------------------------------------- + + procedure Raise_From_Controlled_Operation + (X : Ada.Exceptions.Exception_Occurrence) + is + Prefix : constant String := "adjust/finalize raised "; + Orig_Msg : constant String := Exception_Message (X); + New_Msg : constant String := Prefix & Exception_Name (X); + + begin + if Orig_Msg'Length >= Prefix'Length + and then + Orig_Msg (Orig_Msg'First .. Orig_Msg'First + Prefix'Length - 1) = + Prefix + then + -- Message already has proper prefix, just re-reraise PROGRAM_ERROR + + Raise_Exception_No_Defer + (E => Program_Error'Identity, + Message => Orig_Msg); + + elsif Orig_Msg = "" then + + -- No message present: just provide our own + + Raise_Exception_No_Defer + (E => Program_Error'Identity, + Message => New_Msg); + + else + -- Message present, add informational prefix + + Raise_Exception_No_Defer + (E => Program_Error'Identity, + Message => New_Msg & ": " & Orig_Msg); + end if; + end Raise_From_Controlled_Operation; + + ------------------------------- + -- Raise_From_Signal_Handler -- + ------------------------------- + + procedure Raise_From_Signal_Handler + (E : Exception_Id; + M : System.Address) + is + begin + Exception_Data.Set_Exception_C_Msg (E, M); + Abort_Defer.all; + Exception_Propagation.Propagate_Exception + (E => E, From_Signal_Handler => True); + end Raise_From_Signal_Handler; + + ------------------------- + -- Raise_Program_Error -- + ------------------------- + + procedure Raise_Program_Error + (File : System.Address; + Line : Integer) + is + begin + Raise_With_Location_And_Msg (Program_Error_Def'Access, File, Line); + end Raise_Program_Error; + + ----------------------------- + -- Raise_Program_Error_Msg -- + ----------------------------- + + procedure Raise_Program_Error_Msg + (File : System.Address; + Line : Integer; + Msg : System.Address) + is + begin + Raise_With_Location_And_Msg + (Program_Error_Def'Access, File, Line, M => Msg); + end Raise_Program_Error_Msg; + + ------------------------- + -- Raise_Storage_Error -- + ------------------------- + + procedure Raise_Storage_Error + (File : System.Address; + Line : Integer) + is + begin + Raise_With_Location_And_Msg (Storage_Error_Def'Access, File, Line); + end Raise_Storage_Error; + + ----------------------------- + -- Raise_Storage_Error_Msg -- + ----------------------------- + + procedure Raise_Storage_Error_Msg + (File : System.Address; + Line : Integer; + Msg : System.Address) + is + begin + Raise_With_Location_And_Msg + (Storage_Error_Def'Access, File, Line, M => Msg); + end Raise_Storage_Error_Msg; + + --------------------------------- + -- Raise_With_Location_And_Msg -- + --------------------------------- + + procedure Raise_With_Location_And_Msg + (E : Exception_Id; + F : System.Address; + L : Integer; + C : Integer := 0; + M : System.Address := System.Null_Address) + is + begin + Exception_Data.Set_Exception_C_Msg (E, F, L, C, M); + Abort_Defer.all; + Raise_Current_Excep (E); + end Raise_With_Location_And_Msg; + + -------------------- + -- Raise_With_Msg -- + -------------------- + + procedure Raise_With_Msg (E : Exception_Id) is + Excep : constant EOA := Get_Current_Excep.all; + + begin + Exception_Propagation.Setup_Exception (Excep, Excep); + + Excep.Exception_Raised := False; + Excep.Id := E; + Excep.Num_Tracebacks := 0; + Excep.Cleanup_Flag := False; + Excep.Pid := Local_Partition_ID; + Abort_Defer.all; + Raise_Current_Excep (E); + end Raise_With_Msg; + + ----------- + -- Image -- + ----------- + + function Image (Index : Integer) return String is + Result : constant String := Integer'Image (Index); + begin + if Result (1) = ' ' then + return Result (2 .. Result'Last); + else + return Result; + end if; + end Image; + + -------------------------------------- + -- Calls to Run-Time Check Routines -- + -------------------------------------- + + procedure Rcheck_00 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_00'Address); + end Rcheck_00; + + procedure Rcheck_01 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_01'Address); + end Rcheck_01; + + procedure Rcheck_02 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_02'Address); + end Rcheck_02; + + procedure Rcheck_03 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_03'Address); + end Rcheck_03; + + procedure Rcheck_04 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_04'Address); + end Rcheck_04; + + procedure Rcheck_05 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_05'Address); + end Rcheck_05; + + procedure Rcheck_06 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_06'Address); + end Rcheck_06; + + procedure Rcheck_07 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_07'Address); + end Rcheck_07; + + procedure Rcheck_08 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_08'Address); + end Rcheck_08; + + procedure Rcheck_09 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_09'Address); + end Rcheck_09; + + procedure Rcheck_10 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_10'Address); + end Rcheck_10; + + procedure Rcheck_11 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_11'Address); + end Rcheck_11; + + procedure Rcheck_12 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_12'Address); + end Rcheck_12; + + procedure Rcheck_13 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_13'Address); + end Rcheck_13; + + procedure Rcheck_14 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_14'Address); + end Rcheck_14; + + procedure Rcheck_15 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_15'Address); + end Rcheck_15; + + procedure Rcheck_16 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_16'Address); + end Rcheck_16; + + procedure Rcheck_17 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_17'Address); + end Rcheck_17; + + procedure Rcheck_18 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_18'Address); + end Rcheck_18; + + procedure Rcheck_19 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_19'Address); + end Rcheck_19; + + procedure Rcheck_20 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_20'Address); + end Rcheck_20; + + procedure Rcheck_21 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_21'Address); + end Rcheck_21; + + procedure Rcheck_22 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_22'Address); + end Rcheck_22; + + procedure Rcheck_23 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_23'Address); + end Rcheck_23; + + procedure Rcheck_24 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_24'Address); + end Rcheck_24; + + procedure Rcheck_25 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_25'Address); + end Rcheck_25; + + procedure Rcheck_26 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_26'Address); + end Rcheck_26; + + procedure Rcheck_27 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_27'Address); + end Rcheck_27; + + procedure Rcheck_28 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_28'Address); + end Rcheck_28; + + procedure Rcheck_29 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_29'Address); + end Rcheck_29; + + procedure Rcheck_30 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_30'Address); + end Rcheck_30; + + procedure Rcheck_31 (File : System.Address; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, Rmsg_31'Address); + end Rcheck_31; + + procedure Rcheck_32 (File : System.Address; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, Rmsg_32'Address); + end Rcheck_32; + + procedure Rcheck_33 (File : System.Address; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, Rmsg_33'Address); + end Rcheck_33; + + procedure Rcheck_34 (File : System.Address; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, Rmsg_34'Address); + end Rcheck_34; + + procedure Rcheck_00_Ext (File : System.Address; Line, Column : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, Column, Rmsg_00'Address); + end Rcheck_00_Ext; + + procedure Rcheck_05_Ext + (File : System.Address; Line, Column, Index, First, Last : Integer) + is + Msg : constant String := + Rmsg_05 (Rmsg_05'First .. Rmsg_05'Last - 1) & ASCII.LF & + "index " & Image (Index) & " not in " & Image (First) & + ".." & Image (Last) & ASCII.NUL; + begin + Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); + end Rcheck_05_Ext; + + procedure Rcheck_06_Ext + (File : System.Address; Line, Column, Index, First, Last : Integer) + is + Msg : constant String := + Rmsg_06 (Rmsg_06'First .. Rmsg_06'Last - 1) & ASCII.LF & + "value " & Image (Index) & " not in " & Image (First) & + ".." & Image (Last) & ASCII.NUL; + begin + Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); + end Rcheck_06_Ext; + + procedure Rcheck_12_Ext + (File : System.Address; Line, Column, Index, First, Last : Integer) + is + Msg : constant String := + Rmsg_12 (Rmsg_12'First .. Rmsg_12'Last - 1) & ASCII.LF & + "value " & Image (Index) & " not in " & Image (First) & + ".." & Image (Last) & ASCII.NUL; + begin + Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); + end Rcheck_12_Ext; + + ------------- + -- Reraise -- + ------------- + + procedure Reraise is + Excep : constant EOA := Get_Current_Excep.all; + begin + Abort_Defer.all; + Exception_Propagation.Setup_Exception (Excep, Excep, Reraised => True); + Raise_Current_Excep (Excep.Id); + end Reraise; + + ------------------------ + -- Reraise_Occurrence -- + ------------------------ + + procedure Reraise_Occurrence (X : Exception_Occurrence) is + begin + if X.Id /= null then + Abort_Defer.all; + Exception_Propagation.Setup_Exception + (X'Unrestricted_Access, Get_Current_Excep.all, Reraised => True); + Save_Occurrence_No_Private (Get_Current_Excep.all.all, X); + Raise_Current_Excep (X.Id); + end if; + end Reraise_Occurrence; + + ------------------------------- + -- Reraise_Occurrence_Always -- + ------------------------------- + + procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is + begin + Abort_Defer.all; + Exception_Propagation.Setup_Exception + (X'Unrestricted_Access, Get_Current_Excep.all, Reraised => True); + Save_Occurrence_No_Private (Get_Current_Excep.all.all, X); + Raise_Current_Excep (X.Id); + end Reraise_Occurrence_Always; + + --------------------------------- + -- Reraise_Occurrence_No_Defer -- + --------------------------------- + + procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is + begin + Exception_Propagation.Setup_Exception + (X'Unrestricted_Access, Get_Current_Excep.all, Reraised => True); + Save_Occurrence_No_Private (Get_Current_Excep.all.all, X); + Raise_Current_Excep (X.Id); + end Reraise_Occurrence_No_Defer; + + --------------------- + -- Save_Occurrence -- + --------------------- + + procedure Save_Occurrence + (Target : out Exception_Occurrence; + Source : Exception_Occurrence) + is + begin + Save_Occurrence_No_Private (Target, Source); + end Save_Occurrence; + + function Save_Occurrence (Source : Exception_Occurrence) return EOA is + Target : constant EOA := new Exception_Occurrence; + begin + Save_Occurrence (Target.all, Source); + return Target; + end Save_Occurrence; + + -------------------------------- + -- Save_Occurrence_No_Private -- + -------------------------------- + + procedure Save_Occurrence_No_Private + (Target : out Exception_Occurrence; + Source : Exception_Occurrence) + is + begin + Target.Id := Source.Id; + Target.Msg_Length := Source.Msg_Length; + Target.Num_Tracebacks := Source.Num_Tracebacks; + Target.Pid := Source.Pid; + Target.Cleanup_Flag := Source.Cleanup_Flag; + + Target.Msg (1 .. Target.Msg_Length) := + Source.Msg (1 .. Target.Msg_Length); + + Target.Tracebacks (1 .. Target.Num_Tracebacks) := + Source.Tracebacks (1 .. Target.Num_Tracebacks); + end Save_Occurrence_No_Private; + + ------------------------- + -- Transfer_Occurrence -- + ------------------------- + + procedure Transfer_Occurrence + (Target : Exception_Occurrence_Access; + Source : Exception_Occurrence) + is + begin + -- Setup Target as an exception to be propagated in the calling task + -- (rendezvous-wise), taking care not to clobber the associated private + -- data. Target is expected to be a pointer to the calling task's + -- fixed TSD occurrence, which is very different from Get_Current_Excep + -- here because this subprogram is called from the called task. + + Exception_Propagation.Setup_Exception (Target, Target); + Save_Occurrence_No_Private (Target.all, Source); + end Transfer_Occurrence; + + ------------------- + -- String_To_EId -- + ------------------- + + function String_To_EId (S : String) return Exception_Id + renames Stream_Attributes.String_To_EId; + + ------------------ + -- String_To_EO -- + ------------------ + + function String_To_EO (S : String) return Exception_Occurrence + renames Stream_Attributes.String_To_EO; + + ------------------------------ + -- Raise_Exception_No_Defer -- + ------------------------------ + + procedure Raise_Exception_No_Defer + (E : Exception_Id; + Message : String := "") + is + begin + Exception_Data.Set_Exception_Msg (E, Message); + + -- Do not call Abort_Defer.all, as specified by the spec + + Raise_Current_Excep (E); + end Raise_Exception_No_Defer; + + --------------- + -- To_Stderr -- + --------------- + + procedure To_Stderr (C : Character) is + type int is new Integer; + + procedure put_char_stderr (C : int); + pragma Import (C, put_char_stderr, "put_char_stderr"); + + begin + put_char_stderr (Character'Pos (C)); + end To_Stderr; + + procedure To_Stderr (S : String) is + begin + for J in S'Range loop + if S (J) /= ASCII.CR then + To_Stderr (S (J)); + end if; + end loop; + end To_Stderr; + + ------------------------- + -- Wide_Exception_Name -- + ------------------------- + + WC_Encoding : Character; + pragma Import (C, WC_Encoding, "__gl_wc_encoding"); + -- Encoding method for source, as exported by binder + + function Wide_Exception_Name + (Id : Exception_Id) return Wide_String + is + S : constant String := Exception_Name (Id); + W : Wide_String (1 .. S'Length); + L : Natural; + begin + String_To_Wide_String + (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); + return W (1 .. L); + end Wide_Exception_Name; + + function Wide_Exception_Name + (X : Exception_Occurrence) return Wide_String + is + S : constant String := Exception_Name (X); + W : Wide_String (1 .. S'Length); + L : Natural; + begin + String_To_Wide_String + (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); + return W (1 .. L); + end Wide_Exception_Name; + + ---------------------------- + -- Wide_Wide_Exception_Name -- + ----------------------------- + + function Wide_Wide_Exception_Name + (Id : Exception_Id) return Wide_Wide_String + is + S : constant String := Exception_Name (Id); + W : Wide_Wide_String (1 .. S'Length); + L : Natural; + begin + String_To_Wide_Wide_String + (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); + return W (1 .. L); + end Wide_Wide_Exception_Name; + + function Wide_Wide_Exception_Name + (X : Exception_Occurrence) return Wide_Wide_String + is + S : constant String := Exception_Name (X); + W : Wide_Wide_String (1 .. S'Length); + L : Natural; + begin + String_To_Wide_Wide_String + (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); + return W (1 .. L); + end Wide_Wide_Exception_Name; + + -------------------------- + -- Code_Address_For_ZZZ -- + -------------------------- + + -- This function gives us the end of the PC range for addresses + -- within the exception unit itself. We hope that gigi/gcc keeps all the + -- procedures in their original order! + + function Code_Address_For_ZZZ return System.Address is + begin + <> + return Start_Of_ZZZ'Address; + end Code_Address_For_ZZZ; + +end Ada.Exceptions; diff --git a/gcc/ada/a-except-2005.ads b/gcc/ada/a-except-2005.ads new file mode 100644 index 000000000..033244dcd --- /dev/null +++ b/gcc/ada/a-except-2005.ads @@ -0,0 +1,370 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This version of Ada.Exceptions fully supports both Ada 95 and Ada 2005. +-- It is used in all situations except for the build of the compiler and +-- other basic tools. For these latter builds, we use an Ada 95-only version. + +-- The reason for this splitting off of a separate version is that bootstrap +-- compilers often will be used that do not support Ada 2005 features, and +-- Ada.Exceptions is part of the compiler sources. + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we get +-- elaboration circularities with ourself. + +with System; +with System.Parameters; +with System.Standard_Library; +with System.Traceback_Entries; + +with Ada.Unchecked_Conversion; + +package Ada.Exceptions is + pragma Warnings (Off); + pragma Preelaborate_05; + pragma Warnings (On); + -- In accordance with Ada 2005 AI-362. The warnings pragmas are so that we + -- can compile this using older compiler versions, which will ignore the + -- pragma, which is fine for the bootstrap. + + type Exception_Id is private; + pragma Preelaborable_Initialization (Exception_Id); + + Null_Id : constant Exception_Id; + + type Exception_Occurrence is limited private; + pragma Preelaborable_Initialization (Exception_Occurrence); + + type Exception_Occurrence_Access is access all Exception_Occurrence; + + Null_Occurrence : constant Exception_Occurrence; + + function Exception_Name (Id : Exception_Id) return String; + + function Exception_Name (X : Exception_Occurrence) return String; + + function Wide_Exception_Name + (Id : Exception_Id) return Wide_String; + pragma Ada_05 (Wide_Exception_Name); + + function Wide_Exception_Name + (X : Exception_Occurrence) return Wide_String; + pragma Ada_05 (Wide_Exception_Name); + + function Wide_Wide_Exception_Name + (Id : Exception_Id) return Wide_Wide_String; + pragma Ada_05 (Wide_Wide_Exception_Name); + + function Wide_Wide_Exception_Name + (X : Exception_Occurrence) return Wide_Wide_String; + pragma Ada_05 (Wide_Wide_Exception_Name); + + procedure Raise_Exception (E : Exception_Id; Message : String := ""); + pragma No_Return (Raise_Exception); + -- Note: In accordance with AI-466, CE is raised if E = Null_Id + + function Exception_Message (X : Exception_Occurrence) return String; + + procedure Reraise_Occurrence (X : Exception_Occurrence); + -- Note: it would be really nice to give a pragma No_Return for this + -- procedure, but it would be wrong, since Reraise_Occurrence does return + -- if the argument is the null exception occurrence. See also procedure + -- Reraise_Occurrence_Always in the private part of this package. + + function Exception_Identity (X : Exception_Occurrence) return Exception_Id; + + function Exception_Information (X : Exception_Occurrence) return String; + -- The format of the exception information is as follows: + -- + -- exception name (as in Exception_Name) + -- message (or a null line if no message) + -- PID=nnnn + -- 0xyyyyyyyy 0xyyyyyyyy ... + -- + -- The lines are separated by a ASCII.LF character + -- + -- The nnnn is the partition Id given as decimal digits + -- + -- The 0x... line represents traceback program counter locations, + -- in order with the first one being the exception location. + + -- Note on ordering: the compiler uses the Save_Occurrence procedure, but + -- not the function from Rtsfind, so it is important that the procedure + -- come first, since Rtsfind finds the first matching entity. + + procedure Save_Occurrence + (Target : out Exception_Occurrence; + Source : Exception_Occurrence); + + function Save_Occurrence + (Source : Exception_Occurrence) + return Exception_Occurrence_Access; + + -- Ada 2005 (AI-438): The language revision introduces the following + -- subprograms and attribute definitions. We do not provide them + -- explicitly. instead, the corresponding stream attributes are made + -- available through a pragma Stream_Convert in the private part. + + -- procedure Read_Exception_Occurrence + -- (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + -- Item : out Exception_Occurrence); + + -- procedure Write_Exception_Occurrence + -- (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + -- Item : Exception_Occurrence); + + -- for Exception_Occurrence'Read use Read_Exception_Occurrence; + -- for Exception_Occurrence'Write use Write_Exception_Occurrence; + +private + package SSL renames System.Standard_Library; + package SP renames System.Parameters; + + subtype EOA is Exception_Occurrence_Access; + + Exception_Msg_Max_Length : constant := SP.Default_Exception_Msg_Max_Length; + + ------------------ + -- Exception_Id -- + ------------------ + + subtype Code_Loc is System.Address; + -- Code location used in building exception tables and for call addresses + -- when propagating an exception. Values of this type are created by using + -- Label'Address or extracted from machine states using Get_Code_Loc. + + Null_Loc : constant Code_Loc := System.Null_Address; + -- Null code location, used to flag outer level frame + + type Exception_Id is new SSL.Exception_Data_Ptr; + + function EId_To_String (X : Exception_Id) return String; + function String_To_EId (S : String) return Exception_Id; + pragma Stream_Convert (Exception_Id, String_To_EId, EId_To_String); + -- Functions for implementing Exception_Id stream attributes + + Null_Id : constant Exception_Id := null; + + ------------------------- + -- Private Subprograms -- + ------------------------- + + function Current_Target_Exception return Exception_Occurrence; + pragma Export + (Ada, Current_Target_Exception, + "__gnat_current_target_exception"); + -- This routine should return the current raised exception on targets which + -- have built-in exception handling such as the Java Virtual Machine. For + -- other targets this routine is simply ignored. Currently, only JGNAT + -- uses this. See 4jexcept.ads for details. The pragma Export allows this + -- routine to be accessed elsewhere in the run-time, even though it is in + -- the private part of this package (it is not allowed to be in the visible + -- part, since this is set by the reference manual). + + function Exception_Name_Simple (X : Exception_Occurrence) return String; + -- Like Exception_Name, but returns the simple non-qualified name of the + -- exception. This is used to implement the Exception_Name function in + -- Current_Exceptions (the DEC compatible unit). It is called from the + -- compiler generated code (using Rtsfind, which does not respect the + -- private barrier, so we can place this function in the private part + -- where the compiler can find it, but the spec is unchanged.) + + procedure Raise_Exception_Always (E : Exception_Id; Message : String := ""); + pragma No_Return (Raise_Exception_Always); + pragma Export (Ada, Raise_Exception_Always, "__gnat_raise_exception"); + -- This differs from Raise_Exception only in that the caller has determined + -- that for sure the parameter E is not null, and that therefore no check + -- for Null_Id is required. The expander converts Raise_Exception calls to + -- Raise_Exception_Always if it can determine this is the case. The Export + -- allows this routine to be accessed from Pure units. + + procedure Raise_From_Signal_Handler + (E : Exception_Id; + M : System.Address); + pragma Export + (Ada, Raise_From_Signal_Handler, + "ada__exceptions__raise_from_signal_handler"); + pragma No_Return (Raise_From_Signal_Handler); + -- This routine is used to raise an exception from a signal handler. The + -- signal handler has already stored the machine state (i.e. the state that + -- corresponds to the location at which the signal was raised). E is the + -- Exception_Id specifying what exception is being raised, and M is a + -- pointer to a null-terminated string which is the message to be raised. + -- Note that this routine never returns, so it is permissible to simply + -- jump to this routine, rather than call it. This may be appropriate for + -- systems where the right way to get out of signal handler is to alter the + -- PC value in the machine state or in some other way ask the operating + -- system to return here rather than to the original location. + + procedure Raise_From_Controlled_Operation + (X : Ada.Exceptions.Exception_Occurrence); + pragma No_Return (Raise_From_Controlled_Operation); + -- Raise Program_Error, providing information about X (an exception raised + -- during a controlled operation) in the exception message. + + procedure Reraise_Occurrence_Always (X : Exception_Occurrence); + pragma No_Return (Reraise_Occurrence_Always); + -- This differs from Raise_Occurrence only in that the caller guarantees + -- that for sure the parameter X is not the null occurrence, and that + -- therefore this procedure cannot return. The expander uses this routine + -- in the translation of a raise statement with no parameter (reraise). + + procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence); + pragma No_Return (Reraise_Occurrence_No_Defer); + -- Exactly like Reraise_Occurrence, except that abort is not deferred + -- before the call and the parameter X is known not to be the null + -- occurrence. This is used in generated code when it is known that abort + -- is already deferred. + + ----------------------- + -- Polling Interface -- + ----------------------- + + -- The GNAT compiler has an option to generate polling calls to the Poll + -- routine in this package. Specifying the -gnatP option for a compilation + -- causes a call to Ada.Exceptions.Poll to be generated on every subprogram + -- entry and on every iteration of a loop, thus avoiding the possibility of + -- a case of unbounded time between calls. + + -- This polling interface may be used for instrumentation or debugging + -- purposes (e.g. implementing watchpoints in software or in the debugger). + + -- In the GNAT technology itself, this interface is used to implement + -- immediate asynchronous transfer of control and immediate abort on + -- targets which do not provide for one thread interrupting another. + + -- Note: this used to be in a separate unit called System.Poll, but that + -- caused horrible circular elaboration problems between System.Poll and + -- Ada.Exceptions. One way of solving such circularities is unification! + + procedure Poll; + -- Check for asynchronous abort. Note that we do not inline the body. + -- This makes the interface more useful for debugging purposes. + + -------------------------- + -- Exception_Occurrence -- + -------------------------- + + package TBE renames System.Traceback_Entries; + + Max_Tracebacks : constant := 50; + -- Maximum number of trace backs stored in exception occurrence + + type Tracebacks_Array is array (1 .. Max_Tracebacks) of TBE.Traceback_Entry; + -- Traceback array stored in exception occurrence + + type Exception_Occurrence is record + Id : Exception_Id; + -- Exception_Identity for this exception occurrence + -- + -- WARNING System.System.Finalization_Implementation.Finalize_List + -- relies on the fact that this field is always first in the exception + -- occurrence + + Msg_Length : Natural := 0; + -- Length of message (zero = no message) + + Msg : String (1 .. Exception_Msg_Max_Length); + -- Characters of message + + Cleanup_Flag : Boolean := False; + -- The cleanup flag is normally False, it is set True for an exception + -- occurrence passed to a cleanup routine, and will still be set True + -- when the cleanup routine does a Reraise_Occurrence call using this + -- exception occurrence. This is used to avoid recording a bogus trace + -- back entry from this reraise call. + + Exception_Raised : Boolean := False; + -- Set to true to indicate that this exception occurrence has actually + -- been raised. When an exception occurrence is first created, this is + -- set to False, then when it is processed by Raise_Current_Exception, + -- it is set to True. If Raise_Current_Exception is used to raise an + -- exception for which this flag is already True, then it knows that + -- it is dealing with the reraise case (which is useful to distinguish + -- for exception tracing purposes). + + Pid : Natural := 0; + -- Partition_Id for partition raising exception + + Num_Tracebacks : Natural range 0 .. Max_Tracebacks := 0; + -- Number of traceback entries stored + + Tracebacks : Tracebacks_Array; + -- Stored tracebacks (in Tracebacks (1 .. Num_Tracebacks)) + + Private_Data : System.Address := System.Null_Address; + -- Field used by low level exception mechanism to store specific data. + -- Currently used by the GCC exception mechanism to store a pointer to + -- a GNAT_GCC_Exception. + end record; + + function "=" (Left, Right : Exception_Occurrence) return Boolean + is abstract; + -- Don't allow comparison on exception occurrences, we should not need + -- this, and it would not work right, because of the Msg and Tracebacks + -- fields which have unused entries not copied by Save_Occurrence. + + function EO_To_String (X : Exception_Occurrence) return String; + function String_To_EO (S : String) return Exception_Occurrence; + pragma Stream_Convert (Exception_Occurrence, String_To_EO, EO_To_String); + -- Functions for implementing Exception_Occurrence stream attributes + + Null_Occurrence : constant Exception_Occurrence := ( + Id => null, + Msg_Length => 0, + Msg => (others => ' '), + Cleanup_Flag => False, + Exception_Raised => False, + Pid => 0, + Num_Tracebacks => 0, + Tracebacks => (others => TBE.Null_TB_Entry), + Private_Data => System.Null_Address); + + -- Common binding to __builtin_longjmp for sjlj variants. + + -- The builtin expects a pointer type for the jmpbuf address argument, and + -- System.Address doesn't work because this is really an integer type. + + type Jmpbuf_Address is access Character; + + function To_Jmpbuf_Address is new + Ada.Unchecked_Conversion (System.Address, Jmpbuf_Address); + + procedure builtin_longjmp (buffer : Jmpbuf_Address; Flag : Integer); + pragma No_Return (builtin_longjmp); + pragma Import (Intrinsic, builtin_longjmp, "__builtin_longjmp"); + +end Ada.Exceptions; diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb new file mode 100644 index 000000000..e80e264fe --- /dev/null +++ b/gcc/ada/a-except.adb @@ -0,0 +1,1326 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This version of Ada.Exceptions is a full Ada 95 version, and Ada 2005 +-- features such as the additional definitions of Exception_Name returning +-- Wide_[Wide_]String. + +-- It is used for building the compiler and the basic tools, since these +-- builds may be done with bootstrap compilers that cannot handle these +-- additions. The full version of Ada.Exceptions can be found in the files +-- a-except-2005.ads/adb, and is used for all other builds where full Ada +-- 2005 functionality is required. In particular, it is used for building +-- run times on all targets. + +pragma Compiler_Unit; + +pragma Style_Checks (All_Checks); +-- No subprogram ordering check, due to logical grouping + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we get +-- elaboration circularities with System.Exception_Tables. + +with System; use System; +with System.Exceptions; use System.Exceptions; +with System.Standard_Library; use System.Standard_Library; +with System.Soft_Links; use System.Soft_Links; + +package body Ada.Exceptions is + + pragma Suppress (All_Checks); + -- We definitely do not want exceptions occurring within this unit, or we + -- are in big trouble. If an exceptional situation does occur, better that + -- it not be raised, since raising it can cause confusing chaos. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + -- Note: the exported subprograms in this package body are called directly + -- from C clients using the given external name, even though they are not + -- technically visible in the Ada sense. + + procedure Process_Raise_Exception (E : Exception_Id); + pragma No_Return (Process_Raise_Exception); + -- This is the lowest level raise routine. It raises the exception + -- referenced by Current_Excep.all in the TSD, without deferring abort + -- (the caller must ensure that abort is deferred on entry). + + procedure To_Stderr (S : String); + pragma Export (Ada, To_Stderr, "__gnat_to_stderr"); + -- Little routine to output string to stderr that is also used in the + -- tasking run time. + + procedure To_Stderr (C : Character); + pragma Inline (To_Stderr); + pragma Export (Ada, To_Stderr, "__gnat_to_stderr_char"); + -- Little routine to output a character to stderr, used by some of the + -- separate units below. + + package Exception_Data is + + --------------------------------- + -- Exception messages routines -- + --------------------------------- + + procedure Set_Exception_C_Msg + (Id : Exception_Id; + Msg1 : System.Address; + Line : Integer := 0; + Column : Integer := 0; + Msg2 : System.Address := System.Null_Address); + -- This routine is called to setup the exception referenced by the + -- Current_Excep field in the TSD to contain the indicated Id value + -- and message. Msg1 is a null terminated string which is generated + -- as the exception message. If line is non-zero, then a colon and + -- the decimal representation of this integer is appended to the + -- message. Ditto for Column. When Msg2 is non-null, a space and this + -- additional null terminated string is added to the message. + + procedure Set_Exception_Msg + (Id : Exception_Id; + Message : String); + -- This routine is called to setup the exception referenced by the + -- Current_Excep field in the TSD to contain the indicated Id value and + -- message. Message is a string which is generated as the exception + -- message. + + -------------------------------------- + -- Exception information subprogram -- + -------------------------------------- + + function Exception_Information (X : Exception_Occurrence) return String; + -- The format of the exception information is as follows: + -- + -- Exception_Name: (as in Exception_Name) + -- Message: (only if Exception_Message is empty) + -- PID=nnnn (only if != 0) + -- Call stack traceback locations: (only if at least one location) + -- <0xyyyyyyyy 0xyyyyyyyy ...> (is recorded) + -- + -- The lines are separated by a ASCII.LF character + -- + -- The nnnn is the partition Id given as decimal digits + -- + -- The 0x... line represents traceback program counter locations, in + -- execution order with the first one being the exception location. It + -- is present only + -- + -- The Exception_Name and Message lines are omitted in the abort signal + -- case, since this is not really an exception. + + -- Note: If the format of the generated string is changed, please note + -- that an equivalent modification to the routine String_To_EO must be + -- made to preserve proper functioning of the stream attributes. + + --------------------------------------- + -- Exception backtracing subprograms -- + --------------------------------------- + + -- What is automatically output when exception tracing is on is the + -- usual exception information with the call chain backtrace possibly + -- tailored by a backtrace decorator. Modifying Exception_Information + -- itself is not a good idea because the decorated output is completely + -- out of control and would break all our code related to the streaming + -- of exceptions. We then provide an alternative function to compute + -- the possibly tailored output, which is equivalent if no decorator is + -- currently set: + + function Tailored_Exception_Information + (X : Exception_Occurrence) return String; + -- Exception information to be output in the case of automatic tracing + -- requested through GNAT.Exception_Traces. + -- + -- This is the same as Exception_Information if no backtrace decorator + -- is currently in place. Otherwise, this is Exception_Information with + -- the call chain raw addresses replaced by the result of a call to the + -- current decorator provided with the call chain addresses. + + pragma Export + (Ada, Tailored_Exception_Information, + "__gnat_tailored_exception_information"); + -- This is currently used by System.Tasking.Stages + + end Exception_Data; + + package Exception_Traces is + + use Exception_Data; + -- Imports Tailored_Exception_Information + + ---------------------------------------------- + -- Run-Time Exception Notification Routines -- + ---------------------------------------------- + + -- These subprograms provide a common run-time interface to trigger the + -- actions required when an exception is about to be propagated (e.g. + -- user specified actions or output of exception information). They are + -- exported to be usable by the Ada exception handling personality + -- routine when the GCC 3 mechanism is used. + + procedure Notify_Handled_Exception; + pragma Export + (C, Notify_Handled_Exception, "__gnat_notify_handled_exception"); + -- This routine is called for a handled occurrence is about to be + -- propagated. + + procedure Notify_Unhandled_Exception; + pragma Export + (C, Notify_Unhandled_Exception, "__gnat_notify_unhandled_exception"); + -- This routine is called when an unhandled occurrence is about to be + -- propagated. + + procedure Unhandled_Exception_Terminate; + pragma No_Return (Unhandled_Exception_Terminate); + -- This procedure is called to terminate program execution following an + -- unhandled exception. The exception information, including traceback + -- if available is output, and execution is then terminated. Note that + -- at the point where this routine is called, the stack has typically + -- been destroyed. + + end Exception_Traces; + + package Exception_Propagation is + + procedure Setup_Exception + (Excep : EOA; + Current : EOA; + Reraised : Boolean := False); + -- Dummy routine used to share a-exexda.adb, do nothing + + end Exception_Propagation; + + package Stream_Attributes is + + -------------------------------- + -- Stream attributes routines -- + -------------------------------- + + function EId_To_String (X : Exception_Id) return String; + function String_To_EId (S : String) return Exception_Id; + -- Functions for implementing Exception_Id stream attributes + + function EO_To_String (X : Exception_Occurrence) return String; + function String_To_EO (S : String) return Exception_Occurrence; + -- Functions for implementing Exception_Occurrence stream + -- attributes + + end Stream_Attributes; + + procedure Raise_Current_Excep (E : Exception_Id); + pragma No_Return (Raise_Current_Excep); + pragma Export (C, Raise_Current_Excep, "__gnat_raise_nodefer_with_msg"); + -- This is a simple wrapper to Process_Raise_Exception. + -- + -- This external name for Raise_Current_Excep is historical, and probably + -- should be changed but for now we keep it, because gdb and gigi know + -- about it. + + procedure Raise_Exception_No_Defer + (E : Exception_Id; Message : String := ""); + pragma Export + (Ada, Raise_Exception_No_Defer, + "ada__exceptions__raise_exception_no_defer"); + pragma No_Return (Raise_Exception_No_Defer); + -- Similar to Raise_Exception, but with no abort deferral + + procedure Raise_With_Msg (E : Exception_Id); + pragma No_Return (Raise_With_Msg); + pragma Export (C, Raise_With_Msg, "__gnat_raise_with_msg"); + -- Raises an exception with given exception id value. A message is + -- associated with the raise, and has already been stored in the exception + -- occurrence referenced by the Current_Excep in the TSD. Abort is deferred + -- before the raise call. + + procedure Raise_With_Location_And_Msg + (E : Exception_Id; + F : System.Address; + L : Integer; + M : System.Address := System.Null_Address); + pragma No_Return (Raise_With_Location_And_Msg); + -- Raise an exception with given exception id value. A filename and line + -- number is associated with the raise and is stored in the exception + -- occurrence and in addition a string message M is appended to this + -- if M is not null. + + procedure Raise_Constraint_Error + (File : System.Address; + Line : Integer); + pragma No_Return (Raise_Constraint_Error); + pragma Export + (C, Raise_Constraint_Error, "__gnat_raise_constraint_error"); + -- Raise constraint error with file:line information + + procedure Raise_Constraint_Error_Msg + (File : System.Address; + Line : Integer; + Msg : System.Address); + pragma No_Return (Raise_Constraint_Error_Msg); + pragma Export + (C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg"); + -- Raise constraint error with file:line + msg information + + procedure Raise_Program_Error + (File : System.Address; + Line : Integer); + pragma No_Return (Raise_Program_Error); + pragma Export + (C, Raise_Program_Error, "__gnat_raise_program_error"); + -- Raise program error with file:line information + + procedure Raise_Program_Error_Msg + (File : System.Address; + Line : Integer; + Msg : System.Address); + pragma No_Return (Raise_Program_Error_Msg); + pragma Export + (C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg"); + -- Raise program error with file:line + msg information + + procedure Raise_Storage_Error + (File : System.Address; + Line : Integer); + pragma No_Return (Raise_Storage_Error); + pragma Export + (C, Raise_Storage_Error, "__gnat_raise_storage_error"); + -- Raise storage error with file:line information + + procedure Raise_Storage_Error_Msg + (File : System.Address; + Line : Integer; + Msg : System.Address); + pragma No_Return (Raise_Storage_Error_Msg); + pragma Export + (C, Raise_Storage_Error_Msg, "__gnat_raise_storage_error_msg"); + -- Raise storage error with file:line + reason msg information + + -- The exception raising process and the automatic tracing mechanism rely + -- on some careful use of flags attached to the exception occurrence. The + -- graph below illustrates the relations between the Raise_ subprograms + -- and identifies the points where basic flags such as Exception_Raised + -- are initialized. + -- + -- (i) signs indicate the flags initialization points. R stands for Raise, + -- W for With, and E for Exception. + -- + -- R_No_Msg R_E R_Pe R_Ce R_Se + -- | | | | | + -- +--+ +--+ +---+ | +---+ + -- | | | | | + -- R_E_No_Defer(i) R_W_Msg(i) R_W_Loc + -- | | | | + -- +------------+ | +-----------+ +--+ + -- | | | | + -- | | | Set_E_C_Msg(i) + -- | | | + -- Raise_Current_Excep + + procedure Reraise; + pragma No_Return (Reraise); + pragma Export (C, Reraise, "__gnat_reraise"); + -- Reraises the exception referenced by the Current_Excep field of the TSD + -- (all fields of this exception occurrence are set). Abort is deferred + -- before the reraise operation. + + -- Save_Occurrence variations: As the management of the private data + -- attached to occurrences is delicate, whether or not pointers to such + -- data has to be copied in various situations is better made explicit. + -- The following procedures provide an internal interface to help making + -- this explicit. + + procedure Save_Occurrence_No_Private + (Target : out Exception_Occurrence; + Source : Exception_Occurrence); + -- Copy all the components of Source to Target, except the + -- Private_Data pointer. + + procedure Transfer_Occurrence + (Target : Exception_Occurrence_Access; + Source : Exception_Occurrence); + pragma Export (C, Transfer_Occurrence, "__gnat_transfer_occurrence"); + -- Called from System.Tasking.RendezVous.Exceptional_Complete_RendezVous + -- to setup Target from Source as an exception to be propagated in the + -- caller task. Target is expected to be a pointer to the fixed TSD + -- occurrence for this task. + + ----------------------------- + -- Run-Time Check Routines -- + ----------------------------- + + -- Routines to a specific exception with a reason message attached. The + -- parameters are the file name and line number in each case. The names are + -- keyed to the codes defined in types.ads and a-types.h (for example, the + -- name Rcheck_05 refers to the Reason RT_Exception_Code'Val (5)). + + procedure Rcheck_00 (File : System.Address; Line : Integer); + procedure Rcheck_01 (File : System.Address; Line : Integer); + procedure Rcheck_02 (File : System.Address; Line : Integer); + procedure Rcheck_03 (File : System.Address; Line : Integer); + procedure Rcheck_04 (File : System.Address; Line : Integer); + procedure Rcheck_05 (File : System.Address; Line : Integer); + procedure Rcheck_06 (File : System.Address; Line : Integer); + procedure Rcheck_07 (File : System.Address; Line : Integer); + procedure Rcheck_08 (File : System.Address; Line : Integer); + procedure Rcheck_09 (File : System.Address; Line : Integer); + procedure Rcheck_10 (File : System.Address; Line : Integer); + procedure Rcheck_11 (File : System.Address; Line : Integer); + procedure Rcheck_12 (File : System.Address; Line : Integer); + procedure Rcheck_13 (File : System.Address; Line : Integer); + procedure Rcheck_14 (File : System.Address; Line : Integer); + procedure Rcheck_15 (File : System.Address; Line : Integer); + procedure Rcheck_16 (File : System.Address; Line : Integer); + procedure Rcheck_17 (File : System.Address; Line : Integer); + procedure Rcheck_18 (File : System.Address; Line : Integer); + procedure Rcheck_19 (File : System.Address; Line : Integer); + procedure Rcheck_20 (File : System.Address; Line : Integer); + procedure Rcheck_21 (File : System.Address; Line : Integer); + procedure Rcheck_22 (File : System.Address; Line : Integer); + procedure Rcheck_23 (File : System.Address; Line : Integer); + procedure Rcheck_24 (File : System.Address; Line : Integer); + procedure Rcheck_25 (File : System.Address; Line : Integer); + procedure Rcheck_26 (File : System.Address; Line : Integer); + procedure Rcheck_27 (File : System.Address; Line : Integer); + procedure Rcheck_28 (File : System.Address; Line : Integer); + procedure Rcheck_29 (File : System.Address; Line : Integer); + procedure Rcheck_30 (File : System.Address; Line : Integer); + procedure Rcheck_31 (File : System.Address; Line : Integer); + procedure Rcheck_32 (File : System.Address; Line : Integer); + procedure Rcheck_33 (File : System.Address; Line : Integer); + procedure Rcheck_34 (File : System.Address; Line : Integer); + + pragma Export (C, Rcheck_00, "__gnat_rcheck_00"); + pragma Export (C, Rcheck_01, "__gnat_rcheck_01"); + pragma Export (C, Rcheck_02, "__gnat_rcheck_02"); + pragma Export (C, Rcheck_03, "__gnat_rcheck_03"); + pragma Export (C, Rcheck_04, "__gnat_rcheck_04"); + pragma Export (C, Rcheck_05, "__gnat_rcheck_05"); + pragma Export (C, Rcheck_06, "__gnat_rcheck_06"); + pragma Export (C, Rcheck_07, "__gnat_rcheck_07"); + pragma Export (C, Rcheck_08, "__gnat_rcheck_08"); + pragma Export (C, Rcheck_09, "__gnat_rcheck_09"); + pragma Export (C, Rcheck_10, "__gnat_rcheck_10"); + pragma Export (C, Rcheck_11, "__gnat_rcheck_11"); + pragma Export (C, Rcheck_12, "__gnat_rcheck_12"); + pragma Export (C, Rcheck_13, "__gnat_rcheck_13"); + pragma Export (C, Rcheck_14, "__gnat_rcheck_14"); + pragma Export (C, Rcheck_15, "__gnat_rcheck_15"); + pragma Export (C, Rcheck_16, "__gnat_rcheck_16"); + pragma Export (C, Rcheck_17, "__gnat_rcheck_17"); + pragma Export (C, Rcheck_18, "__gnat_rcheck_18"); + pragma Export (C, Rcheck_19, "__gnat_rcheck_19"); + pragma Export (C, Rcheck_20, "__gnat_rcheck_20"); + pragma Export (C, Rcheck_21, "__gnat_rcheck_21"); + pragma Export (C, Rcheck_22, "__gnat_rcheck_22"); + pragma Export (C, Rcheck_23, "__gnat_rcheck_23"); + pragma Export (C, Rcheck_24, "__gnat_rcheck_24"); + pragma Export (C, Rcheck_25, "__gnat_rcheck_25"); + pragma Export (C, Rcheck_26, "__gnat_rcheck_26"); + pragma Export (C, Rcheck_27, "__gnat_rcheck_27"); + pragma Export (C, Rcheck_28, "__gnat_rcheck_28"); + pragma Export (C, Rcheck_29, "__gnat_rcheck_29"); + pragma Export (C, Rcheck_30, "__gnat_rcheck_30"); + pragma Export (C, Rcheck_31, "__gnat_rcheck_31"); + pragma Export (C, Rcheck_32, "__gnat_rcheck_32"); + pragma Export (C, Rcheck_33, "__gnat_rcheck_33"); + pragma Export (C, Rcheck_34, "__gnat_rcheck_34"); + + -- None of these procedures ever returns (they raise an exception!). By + -- using pragma No_Return, we ensure that any junk code after the call, + -- such as normal return epilog stuff, can be eliminated). + + pragma No_Return (Rcheck_00); + pragma No_Return (Rcheck_01); + pragma No_Return (Rcheck_02); + pragma No_Return (Rcheck_03); + pragma No_Return (Rcheck_04); + pragma No_Return (Rcheck_05); + pragma No_Return (Rcheck_06); + pragma No_Return (Rcheck_07); + pragma No_Return (Rcheck_08); + pragma No_Return (Rcheck_09); + pragma No_Return (Rcheck_10); + pragma No_Return (Rcheck_11); + pragma No_Return (Rcheck_12); + pragma No_Return (Rcheck_13); + pragma No_Return (Rcheck_14); + pragma No_Return (Rcheck_15); + pragma No_Return (Rcheck_16); + pragma No_Return (Rcheck_17); + pragma No_Return (Rcheck_18); + pragma No_Return (Rcheck_19); + pragma No_Return (Rcheck_20); + pragma No_Return (Rcheck_21); + pragma No_Return (Rcheck_22); + pragma No_Return (Rcheck_23); + pragma No_Return (Rcheck_24); + pragma No_Return (Rcheck_25); + pragma No_Return (Rcheck_26); + pragma No_Return (Rcheck_27); + pragma No_Return (Rcheck_28); + pragma No_Return (Rcheck_29); + pragma No_Return (Rcheck_30); + pragma No_Return (Rcheck_32); + pragma No_Return (Rcheck_33); + pragma No_Return (Rcheck_34); + + --------------------------------------------- + -- Reason Strings for Run-Time Check Calls -- + --------------------------------------------- + + -- These strings are null-terminated and are used by Rcheck_nn. The + -- strings correspond to the definitions for Types.RT_Exception_Code. + + use ASCII; + + Rmsg_00 : constant String := "access check failed" & NUL; + Rmsg_01 : constant String := "access parameter is null" & NUL; + Rmsg_02 : constant String := "discriminant check failed" & NUL; + Rmsg_03 : constant String := "divide by zero" & NUL; + Rmsg_04 : constant String := "explicit raise" & NUL; + Rmsg_05 : constant String := "index check failed" & NUL; + Rmsg_06 : constant String := "invalid data" & NUL; + Rmsg_07 : constant String := "length check failed" & NUL; + Rmsg_08 : constant String := "null Exception_Id" & NUL; + Rmsg_09 : constant String := "null-exclusion check failed" & NUL; + Rmsg_10 : constant String := "overflow check failed" & NUL; + Rmsg_11 : constant String := "partition check failed" & NUL; + Rmsg_12 : constant String := "range check failed" & NUL; + Rmsg_13 : constant String := "tag check failed" & NUL; + Rmsg_14 : constant String := "access before elaboration" & NUL; + Rmsg_15 : constant String := "accessibility check failed" & NUL; + Rmsg_16 : constant String := "attempt to take address of" & + " intrinsic subprogram" & NUL; + Rmsg_17 : constant String := "all guards closed" & NUL; + Rmsg_18 : constant String := "improper use of generic subtype" & + " with predicate" & NUL; + Rmsg_19 : constant String := "Current_Task referenced in entry" & + " body" & NUL; + Rmsg_20 : constant String := "duplicated entry address" & NUL; + Rmsg_21 : constant String := "explicit raise" & NUL; + Rmsg_22 : constant String := "finalize/adjust raised exception" & NUL; + Rmsg_23 : constant String := "implicit return with No_Return" & NUL; + Rmsg_24 : constant String := "misaligned address value" & NUL; + Rmsg_25 : constant String := "missing return" & NUL; + Rmsg_26 : constant String := "overlaid controlled object" & NUL; + Rmsg_27 : constant String := "potentially blocking operation" & NUL; + Rmsg_28 : constant String := "stubbed subprogram called" & NUL; + Rmsg_29 : constant String := "unchecked union restriction" & NUL; + Rmsg_30 : constant String := "actual/returned class-wide" & + " value not transportable" & NUL; + Rmsg_31 : constant String := "empty storage pool" & NUL; + Rmsg_32 : constant String := "explicit raise" & NUL; + Rmsg_33 : constant String := "infinite recursion" & NUL; + Rmsg_34 : constant String := "object too large" & NUL; + + ----------------------- + -- Polling Interface -- + ----------------------- + + type Unsigned is mod 2 ** 32; + + Counter : Unsigned := 0; + pragma Warnings (Off, Counter); + -- This counter is provided for convenience. It can be used in Poll to + -- perform periodic but not systematic operations. + + procedure Poll is separate; + -- The actual polling routine is separate, so that it can easily be + -- replaced with a target dependent version. + + ------------------------------ + -- Current_Target_Exception -- + ------------------------------ + + function Current_Target_Exception return Exception_Occurrence is + begin + return Null_Occurrence; + end Current_Target_Exception; + + ------------------- + -- EId_To_String -- + ------------------- + + function EId_To_String (X : Exception_Id) return String + renames Stream_Attributes.EId_To_String; + + ------------------ + -- EO_To_String -- + ------------------ + + -- We use the null string to represent the null occurrence, otherwise we + -- output the Exception_Information string for the occurrence. + + function EO_To_String (X : Exception_Occurrence) return String + renames Stream_Attributes.EO_To_String; + + ------------------------ + -- Exception_Identity -- + ------------------------ + + function Exception_Identity + (X : Exception_Occurrence) return Exception_Id + is + begin + -- Note that the following test used to be here for the original Ada 95 + -- semantics, but these were modified by AI-241 to require returning + -- Null_Id instead of raising Constraint_Error. + + -- if X.Id = Null_Id then + -- raise Constraint_Error; + -- end if; + + return X.Id; + end Exception_Identity; + + --------------------------- + -- Exception_Information -- + --------------------------- + + function Exception_Information (X : Exception_Occurrence) return String is + begin + if X.Id = Null_Id then + raise Constraint_Error; + end if; + + return Exception_Data.Exception_Information (X); + end Exception_Information; + + ----------------------- + -- Exception_Message -- + ----------------------- + + function Exception_Message (X : Exception_Occurrence) return String is + begin + if X.Id = Null_Id then + raise Constraint_Error; + end if; + + return X.Msg (1 .. X.Msg_Length); + end Exception_Message; + + -------------------- + -- Exception_Name -- + -------------------- + + function Exception_Name (Id : Exception_Id) return String is + begin + if Id = null then + raise Constraint_Error; + end if; + + return To_Ptr (Id.Full_Name) (1 .. Id.Name_Length - 1); + end Exception_Name; + + function Exception_Name (X : Exception_Occurrence) return String is + begin + return Exception_Name (X.Id); + end Exception_Name; + + --------------------------- + -- Exception_Name_Simple -- + --------------------------- + + function Exception_Name_Simple (X : Exception_Occurrence) return String is + Name : constant String := Exception_Name (X); + P : Natural; + + begin + P := Name'Length; + while P > 1 loop + exit when Name (P - 1) = '.'; + P := P - 1; + end loop; + + -- Return result making sure lower bound is 1 + + declare + subtype Rname is String (1 .. Name'Length - P + 1); + begin + return Rname (Name (P .. Name'Length)); + end; + end Exception_Name_Simple; + + -------------------- + -- Exception_Data -- + -------------------- + + package body Exception_Data is separate; + -- This package can be easily dummied out if we do not want the basic + -- support for exception messages (such as in Ada 83). + + package body Exception_Propagation is + + procedure Setup_Exception + (Excep : EOA; + Current : EOA; + Reraised : Boolean := False) + is + pragma Warnings (Off, Excep); + pragma Warnings (Off, Current); + pragma Warnings (Off, Reraised); + begin + null; + end Setup_Exception; + + end Exception_Propagation; + + ---------------------- + -- Exception_Traces -- + ---------------------- + + package body Exception_Traces is separate; + -- Depending on the underlying support for IO the implementation will + -- differ. Moreover we would like to dummy out this package in case we do + -- not want any exception tracing support. This is why this package is + -- separated. + + ----------------------- + -- Stream Attributes -- + ----------------------- + + package body Stream_Attributes is separate; + -- This package can be easily dummied out if we do not want the + -- support for streaming Exception_Ids and Exception_Occurrences. + + ----------------------------- + -- Process_Raise_Exception -- + ----------------------------- + + procedure Process_Raise_Exception (E : Exception_Id) is + pragma Inspection_Point (E); + -- This is so the debugger can reliably inspect the parameter + + Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all; + Excep : constant EOA := Get_Current_Excep.all; + + procedure builtin_longjmp (buffer : Address; Flag : Integer); + pragma No_Return (builtin_longjmp); + pragma Import (C, builtin_longjmp, "_gnat_builtin_longjmp"); + + begin + -- WARNING: There should be no exception handler for this body because + -- this would cause gigi to prepend a setup for a new jmpbuf to the + -- sequence of statements in case of built-in sjljl. We would then + -- always get this new buf in Jumpbuf_Ptr instead of the one for the + -- exception we are handling, which would completely break the whole + -- design of this procedure. + + -- If the jump buffer pointer is non-null, transfer control using it. + -- Otherwise announce an unhandled exception (note that this means that + -- we have no finalizations to do other than at the outer level). + -- Perform the necessary notification tasks in both cases. + + if Jumpbuf_Ptr /= Null_Address then + if not Excep.Exception_Raised then + Excep.Exception_Raised := True; + Exception_Traces.Notify_Handled_Exception; + end if; + + builtin_longjmp (Jumpbuf_Ptr, 1); + + else + Exception_Traces.Notify_Unhandled_Exception; + Exception_Traces.Unhandled_Exception_Terminate; + end if; + end Process_Raise_Exception; + + ---------------------------- + -- Raise_Constraint_Error -- + ---------------------------- + + procedure Raise_Constraint_Error + (File : System.Address; + Line : Integer) + is + begin + Raise_With_Location_And_Msg + (Constraint_Error_Def'Access, File, Line); + end Raise_Constraint_Error; + + -------------------------------- + -- Raise_Constraint_Error_Msg -- + -------------------------------- + + procedure Raise_Constraint_Error_Msg + (File : System.Address; + Line : Integer; + Msg : System.Address) + is + begin + Raise_With_Location_And_Msg + (Constraint_Error_Def'Access, File, Line, Msg); + end Raise_Constraint_Error_Msg; + + ------------------------- + -- Raise_Current_Excep -- + ------------------------- + + procedure Raise_Current_Excep (E : Exception_Id) is + + pragma Inspection_Point (E); + -- This is so the debugger can reliably inspect the parameter when + -- inserting a breakpoint at the start of this procedure. + + Id : Exception_Id := E; + pragma Volatile (Id); + pragma Warnings (Off, Id); + -- In order to provide support for breakpoints on unhandled exceptions, + -- the debugger will also need to be able to inspect the value of E from + -- another (inner) frame. So we need to make sure that if E is passed in + -- a register, its value is also spilled on stack. For this, we store + -- the parameter value in a local variable, and add a pragma Volatile to + -- make sure it is spilled. The pragma Warnings (Off) is needed because + -- the compiler knows that Id is not referenced and that this use of + -- pragma Volatile is peculiar! + + begin + Debug_Raise_Exception (E => SSL.Exception_Data_Ptr (E)); + Process_Raise_Exception (E); + end Raise_Current_Excep; + + --------------------- + -- Raise_Exception -- + --------------------- + + procedure Raise_Exception + (E : Exception_Id; + Message : String := "") + is + EF : Exception_Id := E; + + begin + -- Raise CE if E = Null_ID (AI-446) + + if E = null then + EF := Constraint_Error'Identity; + end if; + + -- Go ahead and raise appropriate exception + + Exception_Data.Set_Exception_Msg (EF, Message); + Abort_Defer.all; + Raise_Current_Excep (EF); + end Raise_Exception; + + ---------------------------- + -- Raise_Exception_Always -- + ---------------------------- + + procedure Raise_Exception_Always + (E : Exception_Id; + Message : String := "") + is + begin + Exception_Data.Set_Exception_Msg (E, Message); + Abort_Defer.all; + Raise_Current_Excep (E); + end Raise_Exception_Always; + + ------------------------------------- + -- Raise_From_Controlled_Operation -- + ------------------------------------- + + procedure Raise_From_Controlled_Operation + (X : Ada.Exceptions.Exception_Occurrence) + is + Prefix : constant String := "adjust/finalize raised "; + Orig_Msg : constant String := Exception_Message (X); + New_Msg : constant String := Prefix & Exception_Name (X); + + begin + if Orig_Msg'Length >= Prefix'Length + and then + Orig_Msg (Orig_Msg'First .. Orig_Msg'First + Prefix'Length - 1) = + Prefix + then + -- Message already has proper prefix, just re-reraise PROGRAM_ERROR + + Raise_Exception_No_Defer + (E => Program_Error'Identity, + Message => Orig_Msg); + + elsif Orig_Msg = "" then + + -- No message present: just provide our own + + Raise_Exception_No_Defer + (E => Program_Error'Identity, + Message => New_Msg); + + else + -- Message present, add informational prefix + + Raise_Exception_No_Defer + (E => Program_Error'Identity, + Message => New_Msg & ": " & Orig_Msg); + end if; + end Raise_From_Controlled_Operation; + + ------------------------------- + -- Raise_From_Signal_Handler -- + ------------------------------- + + procedure Raise_From_Signal_Handler + (E : Exception_Id; + M : System.Address) + is + begin + Exception_Data.Set_Exception_C_Msg (E, M); + Abort_Defer.all; + Process_Raise_Exception (E); + end Raise_From_Signal_Handler; + + ------------------------- + -- Raise_Program_Error -- + ------------------------- + + procedure Raise_Program_Error + (File : System.Address; + Line : Integer) + is + begin + Raise_With_Location_And_Msg + (Program_Error_Def'Access, File, Line); + end Raise_Program_Error; + + ----------------------------- + -- Raise_Program_Error_Msg -- + ----------------------------- + + procedure Raise_Program_Error_Msg + (File : System.Address; + Line : Integer; + Msg : System.Address) + is + begin + Raise_With_Location_And_Msg + (Program_Error_Def'Access, File, Line, Msg); + end Raise_Program_Error_Msg; + + ------------------------- + -- Raise_Storage_Error -- + ------------------------- + + procedure Raise_Storage_Error + (File : System.Address; + Line : Integer) + is + begin + Raise_With_Location_And_Msg + (Storage_Error_Def'Access, File, Line); + end Raise_Storage_Error; + + ----------------------------- + -- Raise_Storage_Error_Msg -- + ----------------------------- + + procedure Raise_Storage_Error_Msg + (File : System.Address; + Line : Integer; + Msg : System.Address) + is + begin + Raise_With_Location_And_Msg + (Storage_Error_Def'Access, File, Line, Msg); + end Raise_Storage_Error_Msg; + + --------------------------------- + -- Raise_With_Location_And_Msg -- + --------------------------------- + + procedure Raise_With_Location_And_Msg + (E : Exception_Id; + F : System.Address; + L : Integer; + M : System.Address := System.Null_Address) + is + begin + Exception_Data.Set_Exception_C_Msg (E, F, L, Msg2 => M); + Abort_Defer.all; + Raise_Current_Excep (E); + end Raise_With_Location_And_Msg; + + -------------------- + -- Raise_With_Msg -- + -------------------- + + procedure Raise_With_Msg (E : Exception_Id) is + Excep : constant EOA := Get_Current_Excep.all; + + begin + Excep.Exception_Raised := False; + Excep.Id := E; + Excep.Num_Tracebacks := 0; + Excep.Cleanup_Flag := False; + Excep.Pid := Local_Partition_ID; + Abort_Defer.all; + Raise_Current_Excep (E); + end Raise_With_Msg; + + -------------------------------------- + -- Calls to Run-Time Check Routines -- + -------------------------------------- + + procedure Rcheck_00 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, Rmsg_00'Address); + end Rcheck_00; + + procedure Rcheck_01 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, Rmsg_01'Address); + end Rcheck_01; + + procedure Rcheck_02 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, Rmsg_02'Address); + end Rcheck_02; + + procedure Rcheck_03 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, Rmsg_03'Address); + end Rcheck_03; + + procedure Rcheck_04 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, Rmsg_04'Address); + end Rcheck_04; + + procedure Rcheck_05 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, Rmsg_05'Address); + end Rcheck_05; + + procedure Rcheck_06 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, Rmsg_06'Address); + end Rcheck_06; + + procedure Rcheck_07 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, Rmsg_07'Address); + end Rcheck_07; + + procedure Rcheck_08 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, Rmsg_08'Address); + end Rcheck_08; + + procedure Rcheck_09 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, Rmsg_09'Address); + end Rcheck_09; + + procedure Rcheck_10 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, Rmsg_10'Address); + end Rcheck_10; + + procedure Rcheck_11 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, Rmsg_11'Address); + end Rcheck_11; + + procedure Rcheck_12 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, Rmsg_12'Address); + end Rcheck_12; + + procedure Rcheck_13 (File : System.Address; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, Rmsg_13'Address); + end Rcheck_13; + + procedure Rcheck_14 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_14'Address); + end Rcheck_14; + + procedure Rcheck_15 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_15'Address); + end Rcheck_15; + + procedure Rcheck_16 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_16'Address); + end Rcheck_16; + + procedure Rcheck_17 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_17'Address); + end Rcheck_17; + + procedure Rcheck_18 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_18'Address); + end Rcheck_18; + + procedure Rcheck_19 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_19'Address); + end Rcheck_19; + + procedure Rcheck_20 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_20'Address); + end Rcheck_20; + + procedure Rcheck_21 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_21'Address); + end Rcheck_21; + + procedure Rcheck_22 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_22'Address); + end Rcheck_22; + + procedure Rcheck_23 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_23'Address); + end Rcheck_23; + + procedure Rcheck_24 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_24'Address); + end Rcheck_24; + + procedure Rcheck_25 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_25'Address); + end Rcheck_25; + + procedure Rcheck_26 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_26'Address); + end Rcheck_26; + + procedure Rcheck_27 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_27'Address); + end Rcheck_27; + + procedure Rcheck_28 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_28'Address); + end Rcheck_28; + + procedure Rcheck_29 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_29'Address); + end Rcheck_29; + + procedure Rcheck_30 (File : System.Address; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_30'Address); + end Rcheck_30; + + procedure Rcheck_31 (File : System.Address; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, Rmsg_31'Address); + end Rcheck_31; + + procedure Rcheck_32 (File : System.Address; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, Rmsg_32'Address); + end Rcheck_32; + + procedure Rcheck_33 (File : System.Address; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, Rmsg_33'Address); + end Rcheck_33; + + procedure Rcheck_34 (File : System.Address; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, Rmsg_34'Address); + end Rcheck_34; + + ------------- + -- Reraise -- + ------------- + + procedure Reraise is + Excep : constant EOA := Get_Current_Excep.all; + + begin + Abort_Defer.all; + Raise_Current_Excep (Excep.Id); + end Reraise; + + ------------------------ + -- Reraise_Occurrence -- + ------------------------ + + procedure Reraise_Occurrence (X : Exception_Occurrence) is + begin + if X.Id /= null then + Abort_Defer.all; + Save_Occurrence_No_Private (Get_Current_Excep.all.all, X); + Raise_Current_Excep (X.Id); + end if; + end Reraise_Occurrence; + + ------------------------------- + -- Reraise_Occurrence_Always -- + ------------------------------- + + procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is + begin + Abort_Defer.all; + Save_Occurrence_No_Private (Get_Current_Excep.all.all, X); + Raise_Current_Excep (X.Id); + end Reraise_Occurrence_Always; + + --------------------------------- + -- Reraise_Occurrence_No_Defer -- + --------------------------------- + + procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is + begin + Save_Occurrence_No_Private (Get_Current_Excep.all.all, X); + Raise_Current_Excep (X.Id); + end Reraise_Occurrence_No_Defer; + + --------------------- + -- Save_Occurrence -- + --------------------- + + procedure Save_Occurrence + (Target : out Exception_Occurrence; + Source : Exception_Occurrence) + is + begin + Save_Occurrence_No_Private (Target, Source); + end Save_Occurrence; + + function Save_Occurrence (Source : Exception_Occurrence) return EOA is + Target : constant EOA := new Exception_Occurrence; + begin + Save_Occurrence (Target.all, Source); + return Target; + end Save_Occurrence; + + -------------------------------- + -- Save_Occurrence_No_Private -- + -------------------------------- + + procedure Save_Occurrence_No_Private + (Target : out Exception_Occurrence; + Source : Exception_Occurrence) + is + begin + Target.Id := Source.Id; + Target.Msg_Length := Source.Msg_Length; + Target.Num_Tracebacks := Source.Num_Tracebacks; + Target.Pid := Source.Pid; + Target.Cleanup_Flag := Source.Cleanup_Flag; + + Target.Msg (1 .. Target.Msg_Length) := + Source.Msg (1 .. Target.Msg_Length); + + Target.Tracebacks (1 .. Target.Num_Tracebacks) := + Source.Tracebacks (1 .. Target.Num_Tracebacks); + end Save_Occurrence_No_Private; + + ------------------------- + -- Transfer_Occurrence -- + ------------------------- + + procedure Transfer_Occurrence + (Target : Exception_Occurrence_Access; + Source : Exception_Occurrence) + is + begin + -- Setup Target as an exception to be propagated in the calling task + -- (rendezvous-wise), taking care not to clobber the associated private + -- data. Target is expected to be a pointer to the calling task's fixed + -- TSD occurrence, which is very different from Get_Current_Excep here + -- because this subprogram is called from the called task. + + Save_Occurrence_No_Private (Target.all, Source); + end Transfer_Occurrence; + + ------------------- + -- String_To_EId -- + ------------------- + + function String_To_EId (S : String) return Exception_Id + renames Stream_Attributes.String_To_EId; + + ------------------ + -- String_To_EO -- + ------------------ + + function String_To_EO (S : String) return Exception_Occurrence + renames Stream_Attributes.String_To_EO; + + ------------------------------ + -- Raise_Exception_No_Defer -- + ------------------------------ + + procedure Raise_Exception_No_Defer + (E : Exception_Id; + Message : String := "") + is + begin + Exception_Data.Set_Exception_Msg (E, Message); + + -- Do not call Abort_Defer.all, as specified by the spec + + Raise_Current_Excep (E); + end Raise_Exception_No_Defer; + + --------------- + -- To_Stderr -- + --------------- + + procedure To_Stderr (C : Character) is + type int is new Integer; + + procedure put_char_stderr (C : int); + pragma Import (C, put_char_stderr, "put_char_stderr"); + + begin + put_char_stderr (Character'Pos (C)); + end To_Stderr; + + procedure To_Stderr (S : String) is + begin + for J in S'Range loop + if S (J) /= ASCII.CR then + To_Stderr (S (J)); + end if; + end loop; + end To_Stderr; + +end Ada.Exceptions; diff --git a/gcc/ada/a-except.ads b/gcc/ada/a-except.ads new file mode 100644 index 000000000..14aea1dd3 --- /dev/null +++ b/gcc/ada/a-except.ads @@ -0,0 +1,324 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This version of Ada.Exceptions is a full Ada 95 version. It omits Ada 2005 +-- features such as the additional definitions of Exception_Name returning +-- Wide_[Wide_]String. + +-- It is used for building the compiler and the basic tools, since these +-- builds may be done with bootstrap compilers that cannot handle these +-- additions. The full version of Ada.Exceptions can be found in the files +-- a-except-2005.ads/adb, and is used for all other builds where full Ada +-- 2005 functionality is required. In particular, it is used for building +-- run times on all targets. + +pragma Compiler_Unit; + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we get +-- elaboration circularities with ourself. + +with System; +with System.Parameters; +with System.Standard_Library; +with System.Traceback_Entries; + +package Ada.Exceptions is + pragma Warnings (Off); + pragma Preelaborate_05; + pragma Warnings (On); + -- We make this preelaborable in Ada 2005 mode. If we did not do this, then + -- run time units used by the compiler (e.g. s-soflin.ads) would run + -- into trouble. Conformance is not an issue, since this version is used + -- only by the compiler. + + type Exception_Id is private; + + Null_Id : constant Exception_Id; + + type Exception_Occurrence is limited private; + + type Exception_Occurrence_Access is access all Exception_Occurrence; + + Null_Occurrence : constant Exception_Occurrence; + + function Exception_Name (X : Exception_Occurrence) return String; + -- Same as Exception_Name (Exception_Identity (X)) + + function Exception_Name (Id : Exception_Id) return String; + + procedure Raise_Exception (E : Exception_Id; Message : String := ""); + pragma No_Return (Raise_Exception); + -- Note: In accordance with AI-466, CE is raised if E = Null_Id + + function Exception_Message (X : Exception_Occurrence) return String; + + procedure Reraise_Occurrence (X : Exception_Occurrence); + -- Note: it would be really nice to give a pragma No_Return for this + -- procedure, but it would be wrong, since Reraise_Occurrence does return + -- if the argument is the null exception occurrence. See also procedure + -- Reraise_Occurrence_Always in the private part of this package. + + function Exception_Identity (X : Exception_Occurrence) return Exception_Id; + + function Exception_Information (X : Exception_Occurrence) return String; + -- The format of the exception information is as follows: + -- + -- exception name (as in Exception_Name) + -- message (or a null line if no message) + -- PID=nnnn + -- 0xyyyyyyyy 0xyyyyyyyy ... + -- + -- The lines are separated by a ASCII.LF character + -- The nnnn is the partition Id given as decimal digits. + -- The 0x... line represents traceback program counter locations, + -- in order with the first one being the exception location. + + -- Note on ordering: the compiler uses the Save_Occurrence procedure, but + -- not the function from Rtsfind, so it is important that the procedure + -- come first, since Rtsfind finds the first matching entity. + + procedure Save_Occurrence + (Target : out Exception_Occurrence; + Source : Exception_Occurrence); + + function Save_Occurrence + (Source : Exception_Occurrence) + return Exception_Occurrence_Access; + +private + package SSL renames System.Standard_Library; + package SP renames System.Parameters; + + subtype EOA is Exception_Occurrence_Access; + + Exception_Msg_Max_Length : constant := SP.Default_Exception_Msg_Max_Length; + + ------------------ + -- Exception_Id -- + ------------------ + + subtype Code_Loc is System.Address; + -- Code location used in building exception tables and for call addresses + -- when propagating an exception. Values of this type are created by using + -- Label'Address or extracted from machine states using Get_Code_Loc. + + Null_Loc : constant Code_Loc := System.Null_Address; + -- Null code location, used to flag outer level frame + + type Exception_Id is new SSL.Exception_Data_Ptr; + + function EId_To_String (X : Exception_Id) return String; + function String_To_EId (S : String) return Exception_Id; + pragma Stream_Convert (Exception_Id, String_To_EId, EId_To_String); + -- Functions for implementing Exception_Id stream attributes + + Null_Id : constant Exception_Id := null; + + ------------------------- + -- Private Subprograms -- + ------------------------- + + function Current_Target_Exception return Exception_Occurrence; + pragma Export + (Ada, Current_Target_Exception, + "__gnat_current_target_exception"); + -- This routine should return the current raised exception on targets + -- which have built-in exception handling such as the Java Virtual + -- Machine. For other targets this routine is simply ignored. Currently, + -- only JGNAT uses this. See 4jexcept.ads for details. The pragma Export + -- allows this routine to be accessed elsewhere in the run-time, even + -- though it is in the private part of this package (it is not allowed + -- to be in the visible part, since this is set by the reference manual). + + function Exception_Name_Simple (X : Exception_Occurrence) return String; + -- Like Exception_Name, but returns the simple non-qualified name of the + -- exception. This is used to implement the Exception_Name function in + -- Current_Exceptions (the DEC compatible unit). It is called from the + -- compiler generated code (using Rtsfind, which does not respect the + -- private barrier, so we can place this function in the private part + -- where the compiler can find it, but the spec is unchanged.) + + procedure Raise_Exception_Always (E : Exception_Id; Message : String := ""); + pragma No_Return (Raise_Exception_Always); + pragma Export (Ada, Raise_Exception_Always, "__gnat_raise_exception"); + -- This differs from Raise_Exception only in that the caller has determined + -- that for sure the parameter E is not null, and that therefore no check + -- for Null_Id is required. The expander converts Raise_Exception calls to + -- Raise_Exception_Always if it can determine this is the case. The Export + -- allows this routine to be accessed from Pure units. + + procedure Raise_From_Signal_Handler + (E : Exception_Id; + M : System.Address); + pragma Export + (Ada, Raise_From_Signal_Handler, + "ada__exceptions__raise_from_signal_handler"); + pragma No_Return (Raise_From_Signal_Handler); + -- This routine is used to raise an exception from a signal handler. The + -- signal handler has already stored the machine state (i.e. the state that + -- corresponds to the location at which the signal was raised). E is the + -- Exception_Id specifying what exception is being raised, and M is a + -- pointer to a null-terminated string which is the message to be raised. + -- Note that this routine never returns, so it is permissible to simply + -- jump to this routine, rather than call it. This may be appropriate for + -- systems where the right way to get out of signal handler is to alter the + -- PC value in the machine state or in some other way ask the operating + -- system to return here rather than to the original location. + + procedure Raise_From_Controlled_Operation + (X : Ada.Exceptions.Exception_Occurrence); + pragma No_Return (Raise_From_Controlled_Operation); + -- Raise Program_Error, providing information about X (an exception + -- raised during a controlled operation) in the exception message. + + procedure Reraise_Occurrence_Always (X : Exception_Occurrence); + pragma No_Return (Reraise_Occurrence_Always); + -- This differs from Raise_Occurrence only in that the caller guarantees + -- that for sure the parameter X is not the null occurrence, and that + -- therefore this procedure cannot return. The expander uses this routine + -- in the translation of a raise statement with no parameter (reraise). + + procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence); + pragma No_Return (Reraise_Occurrence_No_Defer); + -- Exactly like Reraise_Occurrence, except that abort is not deferred + -- before the call and the parameter X is known not to be the null + -- occurrence. This is used in generated code when it is known that + -- abort is already deferred. + + ----------------------- + -- Polling Interface -- + ----------------------- + + -- The GNAT compiler has an option to generate polling calls to the Poll + -- routine in this package. Specifying the -gnatP option for a compilation + -- causes a call to Ada.Exceptions.Poll to be generated on every subprogram + -- entry and on every iteration of a loop, thus avoiding the possibility of + -- a case of unbounded time between calls. + + -- This polling interface may be used for instrumentation or debugging + -- purposes (e.g. implementing watchpoints in software or in the debugger). + + -- In the GNAT technology itself, this interface is used to implement + -- immediate asynchronous transfer of control and immediate abort on + -- targets which do not provide for one thread interrupting another. + + -- Note: this used to be in a separate unit called System.Poll, but that + -- caused horrible circular elaboration problems between System.Poll and + -- Ada.Exceptions. One way of solving such circularities is unification! + + procedure Poll; + -- Check for asynchronous abort. Note that we do not inline the body. + -- This makes the interface more useful for debugging purposes. + + -------------------------- + -- Exception_Occurrence -- + -------------------------- + + package TBE renames System.Traceback_Entries; + + Max_Tracebacks : constant := 50; + -- Maximum number of trace backs stored in exception occurrence + + type Tracebacks_Array is array (1 .. Max_Tracebacks) of TBE.Traceback_Entry; + -- Traceback array stored in exception occurrence + + type Exception_Occurrence is record + Id : Exception_Id; + -- Exception_Identity for this exception occurrence + -- WARNING System.System.Finalization_Implementation.Finalize_List + -- relies on the fact that this field is always first in the exception + -- occurrence + + Msg_Length : Natural := 0; + -- Length of message (zero = no message) + + Msg : String (1 .. Exception_Msg_Max_Length); + -- Characters of message + + Cleanup_Flag : Boolean := False; + -- The cleanup flag is normally False, it is set True for an exception + -- occurrence passed to a cleanup routine, and will still be set True + -- when the cleanup routine does a Reraise_Occurrence call using this + -- exception occurrence. This is used to avoid recording a bogus trace + -- back entry from this reraise call. + + Exception_Raised : Boolean := False; + -- Set to true to indicate that this exception occurrence has actually + -- been raised. When an exception occurrence is first created, this is + -- set to False, then when it is processed by Raise_Current_Exception, + -- it is set to True. If Raise_Current_Exception is used to raise an + -- exception for which this flag is already True, then it knows that + -- it is dealing with the reraise case (which is useful to distinguish + -- for exception tracing purposes). + + Pid : Natural := 0; + -- Partition_Id for partition raising exception + + Num_Tracebacks : Natural range 0 .. Max_Tracebacks := 0; + -- Number of traceback entries stored + + Tracebacks : Tracebacks_Array; + -- Stored tracebacks (in Tracebacks (1 .. Num_Tracebacks)) + + Private_Data : System.Address := System.Null_Address; + -- Field used by low level exception mechanism to store specific data. + -- Currently used by the GCC exception mechanism to store a pointer to + -- a GNAT_GCC_Exception. + end record; + + function "=" (Left, Right : Exception_Occurrence) return Boolean + is abstract; + -- Don't allow comparison on exception occurrences, we should not need + -- this, and it would not work right, because of the Msg and Tracebacks + -- fields which have unused entries not copied by Save_Occurrence. + + function EO_To_String (X : Exception_Occurrence) return String; + function String_To_EO (S : String) return Exception_Occurrence; + pragma Stream_Convert (Exception_Occurrence, String_To_EO, EO_To_String); + -- Functions for implementing Exception_Occurrence stream attributes + + Null_Occurrence : constant Exception_Occurrence := ( + Id => null, + Msg_Length => 0, + Msg => (others => ' '), + Cleanup_Flag => False, + Exception_Raised => False, + Pid => 0, + Num_Tracebacks => 0, + Tracebacks => (others => TBE.Null_TB_Entry), + Private_Data => System.Null_Address); + +end Ada.Exceptions; diff --git a/gcc/ada/a-excpol-abort.adb b/gcc/ada/a-excpol-abort.adb new file mode 100644 index 000000000..94acae6a1 --- /dev/null +++ b/gcc/ada/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-2010, 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, HPUX 10 and VMS 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 new file mode 100644 index 000000000..07a6e6123 --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..03e464249 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..8bb956248 --- /dev/null +++ b/gcc/ada/a-exctra.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is part of the support for tracebacks on exceptions + +with System.Traceback_Entries; + +package Ada.Exceptions.Traceback is + + package TBE renames System.Traceback_Entries; + + subtype Code_Loc is System.Address; + -- Code location in executing program + + type Tracebacks_Array is array (Positive range <>) of TBE.Traceback_Entry; + -- 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. + +end Ada.Exceptions.Traceback; diff --git a/gcc/ada/a-exetim-default.ads b/gcc/ada/a-exetim-default.ads new file mode 100644 index 000000000..edc6f19a2 --- /dev/null +++ b/gcc/ada/a-exetim-default.ads @@ -0,0 +1,98 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X E C U T I O N _ T I M E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007-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.Task_Identification; +with Ada.Real_Time; + +package Ada.Execution_Time is + + type CPU_Time is private; + + CPU_Time_First : constant CPU_Time; + CPU_Time_Last : constant CPU_Time; + CPU_Time_Unit : constant := Ada.Real_Time.Time_Unit; + CPU_Tick : constant Ada.Real_Time.Time_Span; + + function Clock + (T : Ada.Task_Identification.Task_Id + := Ada.Task_Identification.Current_Task) + return CPU_Time; + + function "+" + (Left : CPU_Time; + Right : Ada.Real_Time.Time_Span) return CPU_Time; + + function "+" + (Left : Ada.Real_Time.Time_Span; + Right : CPU_Time) return CPU_Time; + + function "-" + (Left : CPU_Time; + Right : Ada.Real_Time.Time_Span) return CPU_Time; + + function "-" + (Left : CPU_Time; + Right : CPU_Time) return Ada.Real_Time.Time_Span; + + function "<" (Left, Right : CPU_Time) return Boolean; + function "<=" (Left, Right : CPU_Time) return Boolean; + function ">" (Left, Right : CPU_Time) return Boolean; + function ">=" (Left, Right : CPU_Time) return Boolean; + + procedure Split + (T : CPU_Time; + SC : out Ada.Real_Time.Seconds_Count; + TS : out Ada.Real_Time.Time_Span); + + function Time_Of + (SC : Ada.Real_Time.Seconds_Count; + TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero) + return CPU_Time; + +private + + type CPU_Time is new Ada.Real_Time.Time; + + CPU_Time_First : constant CPU_Time := CPU_Time (Ada.Real_Time.Time_First); + CPU_Time_Last : constant CPU_Time := CPU_Time (Ada.Real_Time.Time_Last); + + CPU_Tick : constant Ada.Real_Time.Time_Span := Ada.Real_Time.Tick; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + +end Ada.Execution_Time; diff --git a/gcc/ada/a-exetim-mingw.adb b/gcc/ada/a-exetim-mingw.adb new file mode 100755 index 000000000..973817c0b --- /dev/null +++ b/gcc/ada/a-exetim-mingw.adb @@ -0,0 +1,159 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X E C U T I O N _ T I M E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 native version of this package + +with Ada.Task_Identification; use Ada.Task_Identification; +with Ada.Unchecked_Conversion; + +with System.OS_Interface; use System.OS_Interface; +with System.Task_Primitives.Operations; use System.Task_Primitives.Operations; +with System.Tasking; use System.Tasking; +with System.Win32; use System.Win32; + +package body Ada.Execution_Time is + + --------- + -- "+" -- + --------- + + function "+" + (Left : CPU_Time; + Right : Ada.Real_Time.Time_Span) return CPU_Time + is + use type Ada.Real_Time.Time; + begin + return CPU_Time (Ada.Real_Time.Time (Left) + Right); + end "+"; + + function "+" + (Left : Ada.Real_Time.Time_Span; + Right : CPU_Time) return CPU_Time + is + use type Ada.Real_Time.Time; + begin + return CPU_Time (Left + Ada.Real_Time.Time (Right)); + end "+"; + + --------- + -- "-" -- + --------- + + function "-" + (Left : CPU_Time; + Right : Ada.Real_Time.Time_Span) return CPU_Time + is + use type Ada.Real_Time.Time; + begin + return CPU_Time (Ada.Real_Time.Time (Left) - Right); + end "-"; + + function "-" + (Left : CPU_Time; + Right : CPU_Time) return Ada.Real_Time.Time_Span + is + use type Ada.Real_Time.Time; + begin + return (Ada.Real_Time.Time (Left) - Ada.Real_Time.Time (Right)); + end "-"; + + ----------- + -- Clock -- + ----------- + + function Clock + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) return CPU_Time + is + Hundreds_Nano_In_Sec : constant Long_Long_Float := 1.0E7; + + function To_Time is new Ada.Unchecked_Conversion + (Duration, Ada.Real_Time.Time); + + function To_Task_Id is new Ada.Unchecked_Conversion + (Ada.Task_Identification.Task_Id, System.Tasking.Task_Id); + + C_Time : aliased Long_Long_Integer; + E_Time : aliased Long_Long_Integer; + K_Time : aliased Long_Long_Integer; + U_Time : aliased Long_Long_Integer; + Res : BOOL; + + begin + if T = Ada.Task_Identification.Null_Task_Id then + raise Program_Error; + end if; + + Res := + GetThreadTimes + (HANDLE (Get_Thread_Id (To_Task_Id (T))), + C_Time'Access, E_Time'Access, K_Time'Access, U_Time'Access); + + if Res = System.Win32.FALSE then + raise Program_Error; + end if; + + return + CPU_Time + (To_Time + (Duration + ((Long_Long_Float (K_Time) / Hundreds_Nano_In_Sec) + + (Long_Long_Float (U_Time) / Hundreds_Nano_In_Sec)))); + end Clock; + + ----------- + -- Split -- + ----------- + + procedure Split + (T : CPU_Time; + SC : out Ada.Real_Time.Seconds_Count; + TS : out Ada.Real_Time.Time_Span) + is + use type Ada.Real_Time.Time; + begin + Ada.Real_Time.Split (Ada.Real_Time.Time (T), SC, TS); + end Split; + + ------------- + -- Time_Of -- + ------------- + + function Time_Of + (SC : Ada.Real_Time.Seconds_Count; + TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero) + return CPU_Time + is + begin + return CPU_Time (Ada.Real_Time.Time_Of (SC, TS)); + end Time_Of; + +end Ada.Execution_Time; diff --git a/gcc/ada/a-exetim-mingw.ads b/gcc/ada/a-exetim-mingw.ads new file mode 100755 index 000000000..374e066ab --- /dev/null +++ b/gcc/ada/a-exetim-mingw.ads @@ -0,0 +1,98 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X E C U T I O N _ T I M E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 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. -- +------------------------------------------------------------------------------ + +-- This is the Windows native version of this package + +with Ada.Task_Identification; +with Ada.Real_Time; + +package Ada.Execution_Time is + + type CPU_Time is private; + + CPU_Time_First : constant CPU_Time; + CPU_Time_Last : constant CPU_Time; + CPU_Time_Unit : constant := 0.000001; + CPU_Tick : constant Ada.Real_Time.Time_Span; + + function Clock + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) return CPU_Time; + + function "+" + (Left : CPU_Time; + Right : Ada.Real_Time.Time_Span) return CPU_Time; + + function "+" + (Left : Ada.Real_Time.Time_Span; + Right : CPU_Time) return CPU_Time; + + function "-" + (Left : CPU_Time; + Right : Ada.Real_Time.Time_Span) return CPU_Time; + + function "-" + (Left : CPU_Time; + Right : CPU_Time) return Ada.Real_Time.Time_Span; + + function "<" (Left, Right : CPU_Time) return Boolean; + function "<=" (Left, Right : CPU_Time) return Boolean; + function ">" (Left, Right : CPU_Time) return Boolean; + function ">=" (Left, Right : CPU_Time) return Boolean; + + procedure Split + (T : CPU_Time; + SC : out Ada.Real_Time.Seconds_Count; + TS : out Ada.Real_Time.Time_Span); + + function Time_Of + (SC : Ada.Real_Time.Seconds_Count; + TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero) + return CPU_Time; + +private + + type CPU_Time is new Ada.Real_Time.Time; + + CPU_Time_First : constant CPU_Time := CPU_Time (Ada.Real_Time.Time_First); + CPU_Time_Last : constant CPU_Time := CPU_Time (Ada.Real_Time.Time_Last); + + CPU_Tick : constant Ada.Real_Time.Time_Span := Ada.Real_Time.Tick; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + +end Ada.Execution_Time; diff --git a/gcc/ada/a-exetim-posix.adb b/gcc/ada/a-exetim-posix.adb new file mode 100644 index 000000000..fe00abe55 --- /dev/null +++ b/gcc/ada/a-exetim-posix.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X E C U T I O N _ T I M E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the POSIX (Realtime Extension) version of this package + +with Ada.Task_Identification; use Ada.Task_Identification; +with Ada.Unchecked_Conversion; + +with System.OS_Interface; use System.OS_Interface; + +with Interfaces.C; use Interfaces.C; + +package body Ada.Execution_Time is + + pragma Linker_Options ("-lrt"); + -- POSIX.1b Realtime Extensions library. Needed to have access to function + -- clock_gettime. + + --------- + -- "+" -- + --------- + + function "+" + (Left : CPU_Time; + Right : Ada.Real_Time.Time_Span) return CPU_Time + is + use type Ada.Real_Time.Time; + begin + return CPU_Time (Ada.Real_Time.Time (Left) + Right); + end "+"; + + function "+" + (Left : Ada.Real_Time.Time_Span; + Right : CPU_Time) return CPU_Time + is + use type Ada.Real_Time.Time; + begin + return CPU_Time (Left + Ada.Real_Time.Time (Right)); + end "+"; + + --------- + -- "-" -- + --------- + + function "-" + (Left : CPU_Time; + Right : Ada.Real_Time.Time_Span) return CPU_Time + is + use type Ada.Real_Time.Time; + begin + return CPU_Time (Ada.Real_Time.Time (Left) - Right); + end "-"; + + function "-" + (Left : CPU_Time; + Right : CPU_Time) return Ada.Real_Time.Time_Span + is + use type Ada.Real_Time.Time; + begin + return (Ada.Real_Time.Time (Left) - Ada.Real_Time.Time (Right)); + end "-"; + + ----------- + -- Clock -- + ----------- + + function Clock + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + return CPU_Time + is + TS : aliased timespec; + Result : Interfaces.C.int; + + function To_CPU_Time is + new Ada.Unchecked_Conversion (Duration, CPU_Time); + -- Time is equal to Duration (although it is a private type) and + -- CPU_Time is equal to Time. + + function clock_gettime + (clock_id : Interfaces.C.int; + tp : access timespec) + return int; + pragma Import (C, clock_gettime, "clock_gettime"); + -- Function from the POSIX.1b Realtime Extensions library + + CLOCK_THREAD_CPUTIME_ID : constant := 3; + -- Identifier for the clock returning per-task CPU time + + begin + if T = Ada.Task_Identification.Null_Task_Id then + raise Program_Error; + end if; + + Result := clock_gettime + (clock_id => CLOCK_THREAD_CPUTIME_ID, tp => TS'Unchecked_Access); + pragma Assert (Result = 0); + + return To_CPU_Time (To_Duration (TS)); + end Clock; + + ----------- + -- Split -- + ----------- + + procedure Split + (T : CPU_Time; + SC : out Ada.Real_Time.Seconds_Count; + TS : out Ada.Real_Time.Time_Span) + is + use type Ada.Real_Time.Time; + begin + Ada.Real_Time.Split (Ada.Real_Time.Time (T), SC, TS); + end Split; + + ------------- + -- Time_Of -- + ------------- + + function Time_Of + (SC : Ada.Real_Time.Seconds_Count; + TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero) + return CPU_Time + is + begin + return CPU_Time (Ada.Real_Time.Time_Of (SC, TS)); + end Time_Of; + +end Ada.Execution_Time; diff --git a/gcc/ada/a-exetim.ads b/gcc/ada/a-exetim.ads new file mode 100644 index 000000000..c4b8ba2eb --- /dev/null +++ b/gcc/ada/a-exetim.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X E C U T I O N _ T I M E -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit is not implemented in typical GNAT implementations that lie on +-- top of operating systems, because it is infeasible to implement in such +-- environments. + +-- If a target environment provides appropriate support for this package +-- then the Unimplemented_Unit pragma should be removed from this spec and +-- an appropriate body provided. + +with Ada.Task_Identification; +with Ada.Real_Time; + +package Ada.Execution_Time is + pragma Preelaborate; + + pragma Unimplemented_Unit; + + type CPU_Time is private; + + CPU_Time_First : constant CPU_Time; + CPU_Time_Last : constant CPU_Time; + CPU_Time_Unit : constant := 0.000001; + CPU_Tick : constant Ada.Real_Time.Time_Span; + + function Clock + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + return CPU_Time; + + function "+" + (Left : CPU_Time; + Right : Ada.Real_Time.Time_Span) return CPU_Time; + + function "+" + (Left : Ada.Real_Time.Time_Span; + Right : CPU_Time) return CPU_Time; + + function "-" + (Left : CPU_Time; + Right : Ada.Real_Time.Time_Span) return CPU_Time; + + function "-" + (Left : CPU_Time; + Right : CPU_Time) return Ada.Real_Time.Time_Span; + + function "<" (Left, Right : CPU_Time) return Boolean; + function "<=" (Left, Right : CPU_Time) return Boolean; + function ">" (Left, Right : CPU_Time) return Boolean; + function ">=" (Left, Right : CPU_Time) return Boolean; + + procedure Split + (T : CPU_Time; + SC : out Ada.Real_Time.Seconds_Count; + TS : out Ada.Real_Time.Time_Span); + + function Time_Of + (SC : Ada.Real_Time.Seconds_Count; + TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero) + return CPU_Time; + +private + + type CPU_Time is new Ada.Real_Time.Time; + + CPU_Time_First : constant CPU_Time := CPU_Time (Ada.Real_Time.Time_First); + CPU_Time_Last : constant CPU_Time := CPU_Time (Ada.Real_Time.Time_Last); + + CPU_Tick : constant Ada.Real_Time.Time_Span := Ada.Real_Time.Tick; + +end Ada.Execution_Time; diff --git a/gcc/ada/a-exexda.adb b/gcc/ada/a-exexda.adb new file mode 100644 index 000000000..63ab461a9 --- /dev/null +++ b/gcc/ada/a-exexda.adb @@ -0,0 +1,728 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- ADA.EXCEPTIONS.EXCEPTION_DATA -- +-- -- +-- 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 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. + + -- There are common parts between the contents of Exception_Information + -- (the regular Ada interface) and Tailored_Exception_Information (what + -- the automatic backtracing output includes). The overall structure is + -- sketched below: + + -- + -- Exception_Information + -- | + -- +-------+--------+ + -- | | + -- Basic_Exc_Info & Basic_Exc_Tback + -- (B_E_I) (B_E_TB) + + -- o-- + -- (B_E_I) | Exception_Name: (as in Exception_Name) + -- | Message: (or a null line if no message) + -- | PID=nnnn (if != 0) + -- o-- + -- (B_E_TB) | Call stack traceback locations: + -- | <0xyyyyyyyy 0xyyyyyyyy ...> + -- o-- + + -- Tailored_Exception_Information + -- | + -- +----------+----------+ + -- | | + -- Basic_Exc_Info & Tailored_Exc_Tback + -- | + -- +-----------+------------+ + -- | | + -- Basic_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 e.g. Basic_Exception_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_Basic_Exception_Traceback + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural); + + procedure Append_Info_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 Basic_Exception_Tback_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 Basic_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 binary 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_Exception_Information, "__gnat_append_info_e_info"); + + pragma Export + (Ada, Exception_Message_Length, "__gnat_exception_msg_len"); + + ------------------------- + -- 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_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_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_Basic_Exception_Information -- + --------------------------------------------- + + -- To ease the maximum length computation, we define and pull out a couple + -- of string constants: + + BEI_Name_Header : constant String := "Exception name: "; + BEI_Msg_Header : constant String := "Message: "; + 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); + Append_Info_NL (Info, Ptr); + + if Exception_Message_Length (X) /= 0 then + Append_Info_String (BEI_Msg_Header, Info, Ptr); + Append_Info_Exception_Message (X, Info, Ptr); + Append_Info_NL (Info, Ptr); + end if; + end if; + + -- Output PID line if non-zero + + 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; + + ------------------------------------------- + -- 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) + 1 + + BEI_Msg_Header'Length + Exception_Message_Length (X) + 1 + + BEI_PID_Header'Length + 15; + end Basic_Exception_Info_Maxlength; + + ------------------------------------------- + -- Append_Info_Basic_Exception_Traceback -- + ------------------------------------------- + + -- As for Basic_Exception_Information: + + BETB_Header : constant String := "Call stack traceback locations:"; + + procedure Append_Info_Basic_Exception_Traceback + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural) + is + begin + if X.Num_Tracebacks = 0 then + return; + end if; + + 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_Basic_Exception_Traceback; + + ----------------------------------------- + -- Basic_Exception_Traceback_Maxlength -- + ----------------------------------------- + + function Basic_Exception_Tback_Maxlength + (X : Exception_Occurrence) return Natural + is + Space_Per_Traceback : constant := 2 + 16 + 1; + -- Space for "0x" + HHHHHHHHHHHHHHHH + " " + begin + return BETB_Header'Length + 1 + + X.Num_Tracebacks * Space_Per_Traceback + 1; + end Basic_Exception_Tback_Maxlength; + + --------------------------------------- + -- Append_Info_Exception_Information -- + --------------------------------------- + + procedure Append_Info_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_Basic_Exception_Traceback (X, Info, Ptr); + end Append_Info_Exception_Information; + + ------------------------------ + -- Exception_Info_Maxlength -- + ------------------------------ + + function Exception_Info_Maxlength + (X : Exception_Occurrence) return Natural is + begin + return + Basic_Exception_Info_Maxlength (X) + + Basic_Exception_Tback_Maxlength (X); + end Exception_Info_Maxlength; + + ----------------------------------- + -- 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_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; + + ------------------------------ + -- Exception_Message_Length -- + ------------------------------ + + function Exception_Message_Length + (X : Exception_Occurrence) return Natural is + begin + return X.Msg_Length; + end Exception_Message_Length; + + ------------------------------- + -- Basic_Exception_Traceback -- + ------------------------------- + + function Basic_Exception_Traceback + (X : Exception_Occurrence) return String + is + Info : aliased String (1 .. Basic_Exception_Tback_Maxlength (X)); + Ptr : Natural := Info'First - 1; + + begin + Append_Info_Basic_Exception_Traceback (X, Info, Ptr); + return Info (Info'First .. Ptr); + end Basic_Exception_Traceback; + + --------------------------- + -- Exception_Information -- + --------------------------- + + function Exception_Information + (X : Exception_Occurrence) return String + is + Info : String (1 .. Exception_Info_Maxlength (X)); + Ptr : Natural := Info'First - 1; + + begin + Append_Info_Exception_Information (X, Info, Ptr); + return Info (Info'First .. Ptr); + end Exception_Information; + + ------------------------- + -- Set_Exception_C_Msg -- + ------------------------- + + procedure Set_Exception_C_Msg + (Id : Exception_Id; + Msg1 : System.Address; + Line : Integer := 0; + Column : Integer := 0; + Msg2 : System.Address := System.Null_Address) + is + Excep : constant EOA := Get_Current_Excep.all; + 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 + Exception_Propagation.Setup_Exception (Excep, Excep); + Excep.Exception_Raised := False; + Excep.Id := Id; + Excep.Num_Tracebacks := 0; + Excep.Pid := Local_Partition_ID; + Excep.Msg_Length := 0; + Excep.Cleanup_Flag := False; + + 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 + (Id : Exception_Id; + Message : String) + is + Len : constant Natural := + Natural'Min (Message'Length, Exception_Msg_Max_Length); + First : constant Integer := Message'First; + Excep : constant EOA := Get_Current_Excep.all; + + begin + Exception_Propagation.Setup_Exception (Excep, Excep); + 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; + Excep.Cleanup_Flag := False; + + 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 Basic_Exception_Traceback (X); + else + return Wrapper.all (X.Tracebacks'Address, X.Num_Tracebacks); + end if; + end Tailored_Exception_Traceback; + + ------------------------------------ + -- Tailored_Exception_Information -- + ------------------------------------ + + function Tailored_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 Tailored_Exception_Information; + +end Exception_Data; diff --git a/gcc/ada/a-exexpr-gcc.adb b/gcc/ada/a-exexpr-gcc.adb new file mode 100644 index 000000000..358f6fa2f --- /dev/null +++ b/gcc/ada/a-exexpr-gcc.adb @@ -0,0 +1,729 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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; + +separate (Ada.Exceptions) +package body Exception_Propagation is + + ------------------------------------------------ + -- Entities to interface with the GCC runtime -- + ------------------------------------------------ + + -- These come from "C++ ABI for Itanium: Exception handling", which is + -- the reference for GCC. They are used only when we are relying on + -- back-end tables for exception propagation, which in turn is currently + -- only the case for Zero_Cost_Exceptions in GNAT5. + + -- Return codes from the GCC runtime functions used to propagate + -- an exception. + + type Unwind_Reason_Code is + (URC_NO_REASON, + URC_FOREIGN_EXCEPTION_CAUGHT, + URC_PHASE2_ERROR, + URC_PHASE1_ERROR, + URC_NORMAL_STOP, + URC_END_OF_STACK, + URC_HANDLER_FOUND, + URC_INSTALL_CONTEXT, + URC_CONTINUE_UNWIND); + + pragma Unreferenced + (URC_FOREIGN_EXCEPTION_CAUGHT, + URC_PHASE2_ERROR, + URC_PHASE1_ERROR, + URC_NORMAL_STOP, + URC_END_OF_STACK, + URC_HANDLER_FOUND, + URC_INSTALL_CONTEXT, + URC_CONTINUE_UNWIND); + + pragma Convention (C, Unwind_Reason_Code); + + -- Phase identifiers + + type Unwind_Action is + (UA_SEARCH_PHASE, + UA_CLEANUP_PHASE, + UA_HANDLER_FRAME, + UA_FORCE_UNWIND); + + for Unwind_Action use + (UA_SEARCH_PHASE => 1, + UA_CLEANUP_PHASE => 2, + UA_HANDLER_FRAME => 4, + UA_FORCE_UNWIND => 8); + + pragma Convention (C, Unwind_Action); + + -- Mandatory common header for any exception object handled by the + -- GCC unwinding runtime. + + type Exception_Class is mod 2 ** 64; + + GNAT_Exception_Class : constant Exception_Class := 16#474e552d41646100#; + -- "GNU-Ada\0" + + type Unwind_Word is mod 2 ** System.Word_Size; + for Unwind_Word'Size use System.Word_Size; + -- Map the corresponding C type used in Unwind_Exception below + + type Unwind_Exception is record + Class : Exception_Class := GNAT_Exception_Class; + Cleanup : System.Address := System.Null_Address; + Private1 : Unwind_Word; + Private2 : Unwind_Word; + end record; + -- Map the GCC struct used for exception handling + + for Unwind_Exception'Alignment use Standard'Maximum_Alignment; + -- The C++ ABI mandates the common exception header to be at least + -- doubleword aligned, and the libGCC implementation actually makes it + -- maximally aligned (see unwind.h). See additional comments on the + -- alignment below. + + -------------------------------------------------------------- + -- GNAT Specific Entities To Deal With The GCC EH Circuitry -- + -------------------------------------------------------------- + + -- A GNAT exception object to be dealt with by the personality routine + -- called by the GCC unwinding runtime. + + type GNAT_GCC_Exception is record + Header : Unwind_Exception; + -- ABI Exception header first + + Id : Exception_Id; + -- GNAT Exception identifier. This is filled by Propagate_Exception + -- and then used by the personality routine to determine if the context + -- it examines contains a handler for the exception being propagated. + + N_Cleanups_To_Trigger : Integer; + -- Number of cleanup only frames encountered in SEARCH phase. This is + -- initialized to 0 by Propagate_Exception and maintained by the + -- personality routine to control a forced unwinding phase triggering + -- all the cleanups before calling Unhandled_Exception_Terminate when + -- an exception is not handled. + + Next_Exception : EOA; + -- Used to create a linked list of exception occurrences + end record; + + pragma Convention (C, GNAT_GCC_Exception); + + -- There is a subtle issue with the common header alignment, since the C + -- version is aligned on BIGGEST_ALIGNMENT, the Ada version is aligned on + -- Standard'Maximum_Alignment, and those two values don't quite represent + -- the same concepts and so may be decoupled someday. One typical reason + -- is that BIGGEST_ALIGNMENT may be larger than what the underlying system + -- allocator guarantees, and there are extra costs involved in allocating + -- objects aligned to such factors. + + -- To deal with the potential alignment differences between the C and Ada + -- representations, the Ada part of the whole structure is only accessed + -- by the personality routine through the accessors declared below. Ada + -- specific fields are thus always accessed through consistent layout, and + -- we expect the actual alignment to always be large enough to avoid traps + -- from the C accesses to the common header. Besides, accessors alleviate + -- the need for a C struct whole counterpart, both painful and error-prone + -- to maintain anyway. + + type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception; + + function To_GNAT_GCC_Exception is new + Unchecked_Conversion (System.Address, GNAT_GCC_Exception_Access); + + procedure Free is new Unchecked_Deallocation + (GNAT_GCC_Exception, GNAT_GCC_Exception_Access); + + procedure Free is new Unchecked_Deallocation + (Exception_Occurrence, EOA); + + function CleanupUnwind_Handler + (UW_Version : Integer; + UW_Phases : Unwind_Action; + UW_Eclass : Exception_Class; + UW_Exception : not null access GNAT_GCC_Exception; + UW_Context : System.Address; + UW_Argument : System.Address) return Unwind_Reason_Code; + -- 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 access GNAT_GCC_Exception); + pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException"); + + procedure Unwind_ForcedUnwind + (UW_Exception : not null access GNAT_GCC_Exception; + UW_Handler : System.Address; + UW_Argument : System.Address); + pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind"); + + ------------------------------------------------------------------ + -- Occurrence Stack Management Facilities for the GCC-EH Scheme -- + ------------------------------------------------------------------ + + function Remove + (Top : EOA; + Excep : GNAT_GCC_Exception_Access) return Boolean; + -- Remove Excep from the stack starting at Top. + -- Return True if Excep was found and removed, false otherwise. + + -- 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 : GNAT_GCC_Exception_Access); + pragma Export (C, Begin_Handler, "__gnat_begin_handler"); + + procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access); + pragma Export (C, End_Handler, "__gnat_end_handler"); + + Setup_Key : constant := 16#DEAD#; + -- To handle the case of a task "transferring" an exception occurrence to + -- another task, for instance via Exceptional_Complete_Rendezvous, we need + -- to be able to identify occurrences which have been Setup and not yet + -- Propagated. We hijack one of the common header fields for that purpose, + -- setting it to a special key value during the setup process, clearing it + -- at the very beginning of the propagation phase, and expecting it never + -- to be reset to the special value later on. A 16-bit value is used rather + -- than a 32-bit value for static compatibility with 16-bit targets such as + -- AAMP (where type Unwind_Word will be 16 bits). + + function Is_Setup_And_Not_Propagated (E : EOA) return Boolean; + + procedure Set_Setup_And_Not_Propagated (E : EOA); + procedure Clear_Setup_And_Not_Propagated (E : EOA); + + procedure Save_Occurrence_And_Private + (Target : out Exception_Occurrence; + Source : Exception_Occurrence); + -- Copy all the components of Source to Target as well as the + -- Private_Data pointer. + + -------------------------------------------------------------------- + -- 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 Import_Code_For (E : Exception_Data_Ptr) return Exception_Code; + pragma Export (C, Import_Code_For, "__gnat_import_code_for"); + + function EID_For (GNAT_Exception : GNAT_GCC_Exception_Access) + return Exception_Id; + pragma Export (C, EID_For, "__gnat_eid_for"); + + procedure Adjust_N_Cleanups_For + (GNAT_Exception : GNAT_GCC_Exception_Access; + Adjustment : Integer); + pragma Export (C, Adjust_N_Cleanups_For, "__gnat_adjust_n_cleanups_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. In any case + -- the types should match what gigi and the personality routine expect. + -- The initial value is an arbitrary value that will not exceed the range + -- of Integer on 16-bit targets (such as AAMP). + + Others_Value : constant Integer := 16#7FFF#; + pragma Export (C, Others_Value, "__gnat_others_value"); + + All_Others_Value : constant Integer := 16#7FFF#; + pragma Export (C, All_Others_Value, "__gnat_all_others_value"); + + ------------ + -- Remove -- + ------------ + + function Remove + (Top : EOA; + Excep : GNAT_GCC_Exception_Access) return Boolean + is + Prev : GNAT_GCC_Exception_Access := null; + Iter : EOA := Top; + GCC_Exception : GNAT_GCC_Exception_Access; + + begin + -- Pop stack + + loop + pragma Assert (Iter.Private_Data /= System.Null_Address); + + GCC_Exception := To_GNAT_GCC_Exception (Iter.Private_Data); + + if GCC_Exception = Excep then + if Prev = null then + + -- Special case for the top of the stack: shift the contents + -- of the next item to the top, since top is at a fixed + -- location and can't be changed. + + Iter := GCC_Exception.Next_Exception; + + if Iter = null then + + -- Stack is now empty + + Top.Private_Data := System.Null_Address; + + else + Save_Occurrence_And_Private (Top.all, Iter.all); + Free (Iter); + end if; + + else + Prev.Next_Exception := GCC_Exception.Next_Exception; + Free (Iter); + end if; + + Free (GCC_Exception); + + return True; + end if; + + exit when GCC_Exception.Next_Exception = null; + + Prev := GCC_Exception; + Iter := GCC_Exception.Next_Exception; + end loop; + + return False; + end Remove; + + --------------------------- + -- CleanupUnwind_Handler -- + --------------------------- + + function CleanupUnwind_Handler + (UW_Version : Integer; + UW_Phases : Unwind_Action; + UW_Eclass : Exception_Class; + UW_Exception : not null access GNAT_GCC_Exception; + UW_Context : System.Address; + UW_Argument : System.Address) return Unwind_Reason_Code + is + pragma Unreferenced + (UW_Version, UW_Phases, UW_Eclass, UW_Context, UW_Argument); + + begin + -- Terminate as soon as we know there is nothing more to run. The + -- count is maintained by the personality routine. + + if UW_Exception.N_Cleanups_To_Trigger = 0 then + Unhandled_Exception_Terminate; + end if; + + -- We know there is at least one cleanup further up. Return so that it + -- is searched and entered, after which Unwind_Resume will be called + -- and this hook will gain control (with an updated count) again. + + return URC_NO_REASON; + end CleanupUnwind_Handler; + + --------------------------------- + -- Is_Setup_And_Not_Propagated -- + --------------------------------- + + function Is_Setup_And_Not_Propagated (E : EOA) return Boolean is + GCC_E : constant GNAT_GCC_Exception_Access := + To_GNAT_GCC_Exception (E.Private_Data); + begin + return GCC_E /= null and then GCC_E.Header.Private1 = Setup_Key; + end Is_Setup_And_Not_Propagated; + + ------------------------------------ + -- Clear_Setup_And_Not_Propagated -- + ------------------------------------ + + procedure Clear_Setup_And_Not_Propagated (E : EOA) is + GCC_E : constant GNAT_GCC_Exception_Access := + To_GNAT_GCC_Exception (E.Private_Data); + begin + pragma Assert (GCC_E /= null); + GCC_E.Header.Private1 := 0; + end Clear_Setup_And_Not_Propagated; + + ---------------------------------- + -- Set_Setup_And_Not_Propagated -- + ---------------------------------- + + procedure Set_Setup_And_Not_Propagated (E : EOA) is + GCC_E : constant GNAT_GCC_Exception_Access := + To_GNAT_GCC_Exception (E.Private_Data); + begin + pragma Assert (GCC_E /= null); + GCC_E.Header.Private1 := Setup_Key; + end Set_Setup_And_Not_Propagated; + + -------------------------------- + -- Save_Occurrence_And_Private -- + -------------------------------- + + procedure Save_Occurrence_And_Private + (Target : out Exception_Occurrence; + Source : Exception_Occurrence) + is + begin + Save_Occurrence_No_Private (Target, Source); + Target.Private_Data := Source.Private_Data; + end Save_Occurrence_And_Private; + + --------------------- + -- Setup_Exception -- + --------------------- + + -- In the GCC-EH implementation of the propagation scheme, this + -- subprogram should be understood as: Setup the exception occurrence + -- stack headed at Current for a forthcoming raise of Excep. + + procedure Setup_Exception + (Excep : EOA; + Current : EOA; + Reraised : Boolean := False) + is + Top : constant EOA := Current; + Next : EOA; + GCC_Exception : GNAT_GCC_Exception_Access; + + begin + -- The exception Excep is soon to be propagated, and the + -- storage used for that will be the occurrence statically allocated + -- for the current thread. This storage might currently be used for a + -- still active occurrence, so we need to push it on the thread's + -- occurrence stack (headed at that static occurrence) before it gets + -- clobbered. + + -- What we do here is to trigger this push when need be, and allocate a + -- Private_Data block for the forthcoming Propagation. + + -- Some tasking rendez-vous attempts lead to an occurrence transfer + -- from the server to the client (see Exceptional_Complete_Rendezvous). + -- In those cases Setup is called twice for the very same occurrence + -- before it gets propagated: once from the server, because this is + -- where the occurrence contents is elaborated and known, and then + -- once from the client when it detects the case and actually raises + -- the exception in its own context. + + -- The Is_Setup_And_Not_Propagated predicate tells us when we are in + -- the second call to Setup for a Transferred occurrence, and there is + -- nothing to be done here in this situation. This predicate cannot be + -- True if we are dealing with a Reraise, and we may even be called + -- with a raw uninitialized Excep occurrence in this case so we should + -- not check anyway. Observe the front-end expansion for a "raise;" to + -- see that happening. We get a local occurrence and a direct call to + -- Save_Occurrence without the intermediate init-proc call. + + if not Reraised and then Is_Setup_And_Not_Propagated (Excep) then + return; + end if; + + -- Allocate what will be the Private_Data block for the exception + -- to be propagated. + + GCC_Exception := new GNAT_GCC_Exception; + + -- If the Top of the occurrence stack is not currently used for an + -- active exception (the stack is empty) we just need to setup the + -- Private_Data pointer. + + -- Otherwise, we also need to shift the contents of the Top of the + -- stack in a freshly allocated entry and link everything together. + + if Top.Private_Data /= System.Null_Address then + Next := new Exception_Occurrence; + Save_Occurrence_And_Private (Next.all, Top.all); + + GCC_Exception.Next_Exception := Next; + Top.Private_Data := GCC_Exception.all'Address; + end if; + + Top.Private_Data := GCC_Exception.all'Address; + + Set_Setup_And_Not_Propagated (Top); + end Setup_Exception; + + ------------------- + -- Begin_Handler -- + ------------------- + + procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access) is + pragma Unreferenced (GCC_Exception); + + begin + -- Every necessary operation related to the occurrence stack has + -- already been performed by Propagate_Exception. This hook remains for + -- potential future necessity in optimizing the overall scheme, as well + -- a useful debugging tool. + + null; + end Begin_Handler; + + ----------------- + -- End_Handler -- + ----------------- + + procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access) is + Removed : Boolean; + begin + Removed := Remove (Get_Current_Excep.all, GCC_Exception); + pragma Assert (Removed); + end End_Handler; + + ------------------------- + -- Propagate_Exception -- + ------------------------- + + -- Build an object suitable for the libgcc processing and call + -- Unwind_RaiseException to actually throw, taking care of handling + -- the two phase scheme it implements. + + procedure Propagate_Exception + (E : Exception_Id; + From_Signal_Handler : Boolean) + is + pragma Inspection_Point (E); + pragma Unreferenced (From_Signal_Handler); + + Excep : constant EOA := Get_Current_Excep.all; + GCC_Exception : GNAT_GCC_Exception_Access; + + begin + pragma Assert (Excep.Private_Data /= System.Null_Address); + + -- Retrieve the Private_Data for this occurrence and set the useful + -- flags for the personality routine, which will be called for each + -- frame via Unwind_RaiseException below. + + GCC_Exception := To_GNAT_GCC_Exception (Excep.Private_Data); + + Clear_Setup_And_Not_Propagated (Excep); + + GCC_Exception.Id := Excep.Id; + GCC_Exception.N_Cleanups_To_Trigger := 0; + + -- Compute the backtrace for this occurrence if the corresponding + -- binder option has been set. Call_Chain takes care of the reraise + -- case. + + -- ??? Using Call_Chain here means we are going to walk up the stack + -- once only for backtracing purposes before doing it again for the + -- propagation per se. + + -- The first inspection is much lighter, though, as it only requires + -- partial unwinding of each frame. Additionally, although we could use + -- the personality routine to record the addresses while propagating, + -- this method has two drawbacks: + + -- 1) the trace is incomplete if the exception is handled since we + -- don't walk past the frame with the handler, + + -- and + + -- 2) we would miss the frames for which our personality routine is not + -- called, e.g. if C or C++ calls are on the way. + + Call_Chain (Excep); + + -- 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, control will get back to after the + -- call, with N_Cleanups_To_Trigger set to the number of frames with + -- cleanups found on the way up, and none of these already run. + + 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. + + Notify_Unhandled_Exception; + + -- Now, if cleanups have been found, run a forced unwind to trigger + -- them. Control should not resume there, as the unwinding hook calls + -- Unhandled_Exception_Terminate as soon as the last cleanup has been + -- triggered. + + if GCC_Exception.N_Cleanups_To_Trigger /= 0 then + Unwind_ForcedUnwind (GCC_Exception, + CleanupUnwind_Handler'Address, + System.Null_Address); + end if; + + -- We get here when there is no handler or cleanup to be run at all. + -- The debugger has been notified before the second step above. + + Unhandled_Exception_Terminate; + end Propagate_Exception; + + --------------------------- + -- Adjust_N_Cleanups_For -- + --------------------------- + + procedure Adjust_N_Cleanups_For + (GNAT_Exception : GNAT_GCC_Exception_Access; + Adjustment : Integer) + is + begin + GNAT_Exception.N_Cleanups_To_Trigger := + GNAT_Exception.N_Cleanups_To_Trigger + Adjustment; + end Adjust_N_Cleanups_For; + + ------------- + -- EID_For -- + ------------- + + function EID_For + (GNAT_Exception : GNAT_GCC_Exception_Access) return Exception_Id + is + begin + return GNAT_Exception.Id; + end EID_For; + + --------------------- + -- Import_Code_For -- + --------------------- + + function Import_Code_For + (E : SSL.Exception_Data_Ptr) return Exception_Code + is + begin + return E.all.Import_Code; + end Import_Code_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; + + ----------- + -- Notes -- + ----------- + + -- The current model implemented for the stack of occurrences is a + -- simplification of previous attempts, which all proved to be flawed or + -- would have needed significant additional circuitry to be made to work + -- correctly. + + -- We now represent every propagation by a new entry on the stack, which + -- means that an exception occurrence may appear more than once (e.g. when + -- it is reraised during the course of its own handler). + + -- This may seem overcostly compared to the C++ model as implemented in + -- the g++ v3 libstd. This is actually understandable when one considers + -- the extra variations of possible run-time configurations induced by the + -- freedom offered by the Save_Occurrence/Reraise_Occurrence public + -- interface. + + -- The basic point is that arranging for an occurrence to always appear at + -- most once on the stack requires a way to determine if a given occurrence + -- is already there, which is not as easy as it might seem. + + -- An attempt was made to use the Private_Data pointer for this purpose. + -- It did not work because: + + -- 1) The Private_Data has to be saved by Save_Occurrence to be usable + -- as a key in case of a later reraise, + + -- 2) There is no easy way to synchronize End_Handler for an occurrence + -- and the data attached to potential copies, so these copies may end + -- up pointing to stale data. Moreover ... + + -- 3) The same address may be reused for different occurrences, which + -- defeats the idea of using it as a key. + + -- The example below illustrates: + + -- Saved_CE : Exception_Occurrence; + + -- begin + -- raise Constraint_Error; + -- exception + -- when CE: others => + -- Save_Occurrence (Saved_CE, CE); <= Saved_CE.PDA = CE.PDA + -- end; + + -- <= Saved_CE.PDA is stale (!) + + -- begin + -- raise Program_Error; <= Saved_CE.PDA = PE.PDA (!!) + -- exception + -- when others => + -- Reraise_Occurrence (Saved_CE); + -- end; + + -- Not releasing the Private_Data via End_Handler could be an option, + -- but making this to work while still avoiding memory leaks is far + -- from trivial. + + -- The current scheme has the advantage of being simple, and induces + -- extra costs only in reraise cases which is acceptable. + +end Exception_Propagation; diff --git a/gcc/ada/a-exexpr.adb b/gcc/ada/a-exexpr.adb new file mode 100644 index 000000000..e3ae5b01c --- /dev/null +++ b/gcc/ada/a-exexpr.adb @@ -0,0 +1,121 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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, using the __builtin_setjmp/longjmp EH +-- mechanism. + +with System.Storage_Elements; use System.Storage_Elements; + +pragma Warnings (Off); +-- Since several constructs give warnings in 3.14a1, including unreferenced +-- variables and pragma Unreferenced itself. + +separate (Ada.Exceptions) +package body Exception_Propagation is + + --------------------- + -- Setup_Exception -- + --------------------- + + procedure Setup_Exception + (Excep : EOA; + Current : EOA; + Reraised : Boolean := False) + is + pragma Unreferenced (Excep, Current, Reraised); + begin + -- In the GNAT-SJLJ case this "stack" only exists implicitly, by way of + -- local occurrence declarations together with save/restore operations + -- generated by the front-end, and this routine has nothing to do. + + null; + end Setup_Exception; + + ------------------------- + -- Propagate_Exception -- + ------------------------- + + procedure Propagate_Exception + (E : Exception_Id; + From_Signal_Handler : Boolean) + is + pragma Inspection_Point (E); + + Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all; + Excep : constant EOA := Get_Current_Excep.all; + begin + -- Compute the backtrace for this occurrence if corresponding binder + -- option has been set. Call_Chain takes care of the reraise case. + + Call_Chain (Excep); + + -- Note on above call to Call_Chain: + + -- We used to only do this if From_Signal_Handler was not set, + -- based on the assumption that backtracing from a signal handler + -- would not work due to stack layout oddities. However, since + + -- 1. The flag is never set in tasking programs (Notify_Exception + -- performs regular raise statements), and + + -- 2. No problem has shown up in tasking programs around here so + -- far, this turned out to be too strong an assumption. + + -- As, in addition, the test was + + -- 1. preventing the production of backtraces in non-tasking + -- programs, and + + -- 2. introducing a behavior inconsistency between + -- the tasking and non-tasking cases, + + -- we have simply removed it + + -- If the jump buffer pointer is non-null, transfer control using + -- it. Otherwise announce an unhandled exception (note that this + -- means that we have no finalizations to do other than at the outer + -- level). Perform the necessary notification tasks in both cases. + + if Jumpbuf_Ptr /= Null_Address then + if not Excep.Exception_Raised then + Excep.Exception_Raised := True; + Exception_Traces.Notify_Handled_Exception; + end if; + + builtin_longjmp (To_Jmpbuf_Address (Jumpbuf_Ptr), 1); + + else + Exception_Traces.Notify_Unhandled_Exception; + Exception_Traces.Unhandled_Exception_Terminate; + end if; + end Propagate_Exception; + +end Exception_Propagation; diff --git a/gcc/ada/a-exextr.adb b/gcc/ada/a-exextr.adb new file mode 100644 index 000000000..26567b3a4 --- /dev/null +++ b/gcc/ada/a-exextr.adb @@ -0,0 +1,216 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- ADA.EXCEPTIONS.EXCEPTION_TRACES -- +-- -- +-- 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.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. + + -------------------------------- + -- Import Run-Time C Routines -- + -------------------------------- + + -- The purpose of the following pragma Import is to ensure that we + -- generate appropriate subprogram descriptors for all C routines in + -- the standard GNAT library that can raise exceptions. This ensures + -- that the exception propagation can properly find these routines + + pragma Propagate_Exceptions; + + ---------------------- + -- 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. + + -- ??? In the Front-End ZCX case, the traceback entries we have at this + -- point only include the ones we stored while walking up the stack *up + -- to the handler*. All the frames above the subprogram in which the + -- handler is found are missing. + + if not Excep.Id.Not_Handled_By_Others + and then + (Exception_Trace = Every_Raise + or else (Exception_Trace = Unhandled_Raise and then Is_Unhandled)) + 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 Is_Unhandled then + To_Stderr ("Unhandled "); + end if; + + To_Stderr ("Exception raised"); + To_Stderr (Nline); + To_Stderr (Tailored_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 is + begin + Notify_Exception (Get_Current_Excep.all, Is_Unhandled => False); + end Notify_Handled_Exception; + + -------------------------------- + -- Notify_Unhandled_Exception -- + -------------------------------- + + procedure Notify_Unhandled_Exception is + Excep : constant EOA := Get_Current_Excep.all; + + 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 is + Excep : constant EOA := Save_Occurrence (Get_Current_Excep.all.all); + -- 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). + + begin + Last_Chance_Handler (Excep.all); + 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 dragging dependencies against 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. + + -- It currently outputs the information about unhandled exceptions twice + -- in the environment thread, once in the notification routine and once in + -- the termination routine. Avoiding the second output is possible but so + -- far has been considered undesirable. It would mean changing the order + -- of outputs between the two runs with or without exception traces, while + -- it seems preferable to only have additional outputs in the former + -- case. + +end Exception_Traces; diff --git a/gcc/ada/a-exstat.adb b/gcc/ada/a-exstat.adb new file mode 100644 index 000000000..79ab57862 --- /dev/null +++ b/gcc/ada/a-exstat.adb @@ -0,0 +1,260 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- ADA.EXCEPTIONS.STREAM_ATTRIBUTES -- +-- -- +-- 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 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 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_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 function, 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; + + else + X.Cleanup_Flag := False; + + To := S'First - 2; + Next_String; + + if S (From .. From + 15) /= "Exception name: " then + Bad_EO; + end if; + + X.Id := Exception_Id (Internal_Exception (S (From + 16 .. To))); + + Next_String; + + if From <= To and then S (From) = 'M' then + if S (From .. From + 8) /= "Message: " then + Bad_EO; + end if; + + X.Msg_Length := To - From - 8; + X.Msg (1 .. X.Msg_Length) := S (From + 9 .. To); + Next_String; + + else + X.Msg_Length := 0; + end if; + + 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 if; + end String_To_EO; + +end Stream_Attributes; diff --git a/gcc/ada/a-extiti.ads b/gcc/ada/a-extiti.ads new file mode 100644 index 000000000..411371dec --- /dev/null +++ b/gcc/ada/a-extiti.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X E C U T I O N _ T I M E . T I M E R S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit is not implemented in typical GNAT implementations that lie on +-- top of operating systems, because it is infeasible to implement in such +-- environments. + +-- If a target environment provides appropriate support for this package, +-- then the Unimplemented_Unit pragma should be removed from this spec and +-- an appropriate body provided. + +with System; + +package Ada.Execution_Time.Timers is + pragma Preelaborate; + + pragma Unimplemented_Unit; + + type Timer (T : not null access constant Ada.Task_Identification.Task_Id) is + tagged limited private; + + type Timer_Handler is access protected procedure (TM : in out Timer); + + Min_Handler_Ceiling : constant System.Any_Priority := System.Priority'Last; + + procedure Set_Handler + (TM : in out Timer; + In_Time : Ada.Real_Time.Time_Span; + Handler : Timer_Handler); + + procedure Set_Handler + (TM : in out Timer; + At_Time : CPU_Time; + Handler : Timer_Handler); + + function Current_Handler (TM : Timer) return Timer_Handler; + + procedure Cancel_Handler + (TM : in out Timer; + Cancelled : out Boolean); + + function Time_Remaining (TM : Timer) return Ada.Real_Time.Time_Span; + + Timer_Resource_Error : exception; + +private + type Timer (T : access Ada.Task_Identification.Task_Id) is + tagged limited null record; +end Ada.Execution_Time.Timers; diff --git a/gcc/ada/a-filico.adb b/gcc/ada/a-filico.adb new file mode 100644 index 000000000..f6bd78dd2 --- /dev/null +++ b/gcc/ada/a-filico.adb @@ -0,0 +1,80 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A D A . F I N A L I Z A T I O N . L I S T _ C O N T R O L L E 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 System.Finalization_Implementation; +package body Ada.Finalization.List_Controller is + + package SFI renames System.Finalization_Implementation; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out List_Controller) is + use type SFR.Finalizable_Ptr; + + Last_Ptr : constant SFR.Finalizable_Ptr := Object.Last'Unchecked_Access; + + begin + -- First take note of the fact that finalization of this collection has + -- started. + + Object.F := SFI.Collection_Finalization_Started; + + -- Then finalize all the objects. Note that finalization can call + -- Unchecked_Deallocation on other objects in the same collection, + -- which will cause them to be removed from the list if we have not + -- gotten to them yet. However, allocation in the collection will raise + -- Program_Error, due to the above Collection_Finalization_Started. + + while Object.First.Next /= Last_Ptr loop + SFI.Finalize_One (Object.First.Next.all); + end loop; + end Finalize; + + procedure Finalize (Object : in out Simple_List_Controller) is + begin + SFI.Finalize_List (Object.F); + Object.F := null; + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out List_Controller) is + begin + Object.F := Object.First'Unchecked_Access; + Object.First.Next := Object.Last 'Unchecked_Access; + Object.Last.Prev := Object.First'Unchecked_Access; + end Initialize; + +end Ada.Finalization.List_Controller; diff --git a/gcc/ada/a-filico.ads b/gcc/ada/a-filico.ads new file mode 100644 index 000000000..566d0dfd1 --- /dev/null +++ b/gcc/ada/a-filico.ads @@ -0,0 +1,102 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A D A . F I N A L I Z A T I O N . L I S T _ C O N T R O L L E 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Finalization_Root; + +package Ada.Finalization.List_Controller is + pragma Elaborate_Body; + + package SFR renames System.Finalization_Root; + + ---------------------------- + -- Simple_List_Controller -- + ---------------------------- + + type Simple_List_Controller is new Ada.Finalization.Limited_Controlled + with record + F : SFR.Finalizable_Ptr; + end record; + -- Used by the compiler to carry a list of temporary objects that + -- needs to be finalized after having being used. This list is + -- embedded in a controlled type so that if an exception is raised + -- while those temporaries are still in use, they will be reclaimed + -- by the normal finalization mechanism. + + overriding procedure Finalize (Object : in out Simple_List_Controller); + + --------------------- + -- List_Controller -- + --------------------- + + -- Management of a bidirectional linked heterogeneous list of + -- dynamically Allocated objects. To simplify the management of the + -- linked list, the First and Last elements are statically part of the + -- original List controller: + -- + -- +------------+ + -- | --|-->-- + -- +------------+ + -- |--<-- | record with ctrl components + -- |------------| +----------+ + -- +--|-- L | | | + -- | |------------| | | + -- | |+--------+ | +--------+ |+--------+| + -- +->|| prev | F|---<---|-- |----<---||-- ||--<--+ + -- ||--------| i| |--------| ||--------|| | + -- || next | r|--->---| --|---->---|| --||--------+ + -- |+--------+ s| |--------| ||--------|| | | + -- | t| | ctrl | || || | | + -- | | : : |+--------+| | | + -- | | : object : |rec | | | + -- | | : : |controller| | | + -- | | | | | | | v + -- |+--------+ | +--------+ +----------+ | | + -- || prev -|-L|--------------------->--------------------+ | + -- ||--------| a| | + -- || next | s|-------------------<-------------------------+ + -- |+--------+ t| + -- | | + -- +------------+ + + type List_Controller is new Ada.Finalization.Limited_Controlled + with record + F : SFR.Finalizable_Ptr; + First, + Last : aliased SFR.Root_Controlled; + end record; + -- Controls the chains of dynamically allocated controlled + -- objects makes sure that they get finalized upon exit from + -- the access type that defined them + + overriding procedure Initialize (Object : in out List_Controller); + overriding procedure Finalize (Object : in out List_Controller); + +end Ada.Finalization.List_Controller; diff --git a/gcc/ada/a-finali.adb b/gcc/ada/a-finali.adb new file mode 100644 index 000000000..5dae78e12 --- /dev/null +++ b/gcc/ada/a-finali.adb @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Finalization_Root; use System.Finalization_Root; + +package body Ada.Finalization is + + --------- + -- "=" -- + --------- + + overriding function "=" (A, B : Controlled) return Boolean is + begin + return Empty_Root_Controlled (A) = Empty_Root_Controlled (B); + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Controlled) is + pragma Warnings (Off, Object); + begin + null; + end Adjust; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Controlled) is + pragma Warnings (Off, Object); + begin + null; + end Finalize; + + procedure Finalize (Object : in out Limited_Controlled) is + pragma Warnings (Off, Object); + begin + null; + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Controlled) is + pragma Warnings (Off, Object); + begin + null; + end Initialize; + + procedure Initialize (Object : in out Limited_Controlled) is + pragma Warnings (Off, Object); + begin + null; + end Initialize; + +end Ada.Finalization; diff --git a/gcc/ada/a-finali.ads b/gcc/ada/a-finali.ads new file mode 100644 index 000000000..9e81722bc --- /dev/null +++ b/gcc/ada/a-finali.ads @@ -0,0 +1,71 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Warnings (Off); +-- System.Finalization_Root does not have category Remote_Types, but we +-- allow it anyway. +with System.Finalization_Root; +pragma Warnings (On); + +package Ada.Finalization is + pragma Preelaborate; + pragma Remote_Types; + + type Controlled is abstract tagged private; + pragma Preelaborable_Initialization (Controlled); + + procedure Initialize (Object : in out Controlled); + procedure Adjust (Object : in out Controlled); + procedure Finalize (Object : in out Controlled); + + type Limited_Controlled is abstract tagged limited private; + pragma Preelaborable_Initialization (Limited_Controlled); + + procedure Initialize (Object : in out Limited_Controlled); + procedure Finalize (Object : in out Limited_Controlled); + +private + package SFR renames System.Finalization_Root; + + type Controlled is abstract new SFR.Root_Controlled with null record; + + overriding function "=" (A, B : Controlled) return Boolean; + -- Need to be defined explicitly because we don't want to compare the + -- hidden pointers. + + type Limited_Controlled is + abstract new SFR.Root_Controlled with null record; + +end Ada.Finalization; diff --git a/gcc/ada/a-flteio.ads b/gcc/ada/a-flteio.ads new file mode 100644 index 000000000..caf4e9b75 --- /dev/null +++ b/gcc/ada/a-flteio.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . F L O A T _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +pragma Elaborate_All (Ada.Text_IO); + +package Ada.Float_Text_IO is + new Ada.Text_IO.Float_IO (Float); diff --git a/gcc/ada/a-fwteio.ads b/gcc/ada/a-fwteio.ads new file mode 100644 index 000000000..e87e08a9c --- /dev/null +++ b/gcc/ada/a-fwteio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . F L O A T _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Float_Wide_Text_IO is + new Ada.Wide_Text_IO.Float_IO (Float); diff --git a/gcc/ada/a-fzteio.ads b/gcc/ada/a-fzteio.ads new file mode 100755 index 000000000..81bf7b20e --- /dev/null +++ b/gcc/ada/a-fzteio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . F L O A T _ W I D E _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Float_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Float_IO (Float); diff --git a/gcc/ada/a-inteio.ads b/gcc/ada/a-inteio.ads new file mode 100644 index 000000000..b2b3867a5 --- /dev/null +++ b/gcc/ada/a-inteio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . I N T E G E R _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Integer_Text_IO is + new Ada.Text_IO.Integer_IO (Integer); diff --git a/gcc/ada/a-interr.adb b/gcc/ada/a-interr.adb new file mode 100644 index 000000000..e011f2cfc --- /dev/null +++ b/gcc/ada/a-interr.adb @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2007, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +package body Ada.Interrupts is + + package SI renames System.Interrupts; + + function To_System is new Ada.Unchecked_Conversion + (Parameterless_Handler, SI.Parameterless_Handler); + + function To_Ada is new Ada.Unchecked_Conversion + (SI.Parameterless_Handler, Parameterless_Handler); + + -------------------- + -- Attach_Handler -- + -------------------- + + procedure Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID) + is + begin + SI.Attach_Handler + (To_System (New_Handler), SI.Interrupt_ID (Interrupt), False); + end Attach_Handler; + + --------------------- + -- Current_Handler -- + --------------------- + + function Current_Handler + (Interrupt : Interrupt_ID) return Parameterless_Handler + is + begin + return To_Ada (SI.Current_Handler (SI.Interrupt_ID (Interrupt))); + end Current_Handler; + + -------------------- + -- Detach_Handler -- + -------------------- + + procedure Detach_Handler (Interrupt : Interrupt_ID) is + begin + SI.Detach_Handler (SI.Interrupt_ID (Interrupt), False); + end Detach_Handler; + + ---------------------- + -- Exchange_Handler -- + ---------------------- + + procedure Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID) + is + H : SI.Parameterless_Handler; + + begin + SI.Exchange_Handler + (H, To_System (New_Handler), + SI.Interrupt_ID (Interrupt), False); + Old_Handler := To_Ada (H); + end Exchange_Handler; + + ----------------- + -- Is_Attached -- + ----------------- + + function Is_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + return SI.Is_Handler_Attached (SI.Interrupt_ID (Interrupt)); + end Is_Attached; + + ----------------- + -- Is_Reserved -- + ----------------- + + function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is + begin + return SI.Is_Reserved (SI.Interrupt_ID (Interrupt)); + end Is_Reserved; + + --------------- + -- Reference -- + --------------- + + function Reference (Interrupt : Interrupt_ID) return System.Address is + begin + return SI.Reference (SI.Interrupt_ID (Interrupt)); + end Reference; + +end Ada.Interrupts; diff --git a/gcc/ada/a-interr.ads b/gcc/ada/a-interr.ads new file mode 100644 index 000000000..fede3bd85 --- /dev/null +++ b/gcc/ada/a-interr.ads @@ -0,0 +1,71 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . I N T E R R U P 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 System.Interrupts; + +package Ada.Interrupts is + + type Interrupt_ID is new System.Interrupts.Ada_Interrupt_ID; + + type Parameterless_Handler is access protected procedure; + + function Is_Reserved (Interrupt : Interrupt_ID) return Boolean; + + function Is_Attached (Interrupt : Interrupt_ID) return Boolean; + + function Current_Handler + (Interrupt : Interrupt_ID) return Parameterless_Handler; + + procedure Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID); + + procedure Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID); + + procedure Detach_Handler (Interrupt : Interrupt_ID); + + function Reference (Interrupt : Interrupt_ID) return System.Address; + +private + pragma Inline (Is_Reserved); + pragma Inline (Is_Attached); + pragma Inline (Current_Handler); + pragma Inline (Attach_Handler); + pragma Inline (Detach_Handler); + pragma Inline (Exchange_Handler); +end Ada.Interrupts; diff --git a/gcc/ada/a-intnam-aix.ads b/gcc/ada/a-intnam-aix.ads new file mode 100644 index 000000000..8597c3b8f --- /dev/null +++ b/gcc/ada/a-intnam-aix.ads @@ -0,0 +1,197 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a AIX version of this package + +-- The following signals are reserved by the run time (native threads): + +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT, SIGTRAP, SIGINT, SIGEMT +-- SIGSTOP, SIGKILL + +-- The following signals are reserved by the run time (FSU threads): + +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT, SIGTRAP, SIGINT, SIGALRM, +-- SIGWAITING, SIGSTOP, SIGKILL + +-- The pragma Unreserve_All_Interrupts affects the following signal(s): + +-- SIGINT: made available for Ada handler + +-- This target-dependent package spec contains names of interrupts +-- supported by the local system. + +with System.OS_Interface; + +package Ada.Interrupts.Names is + + -- Beware that the mapping of names to signals may be many-to-one. There + -- may be aliases. Also, for all signal names that are not supported on + -- the current system the value of the corresponding constant will be zero. + + SIGHUP : constant Interrupt_ID := + System.OS_Interface.SIGHUP; -- hangup + + SIGINT : constant Interrupt_ID := + System.OS_Interface.SIGINT; -- interrupt (rubout) + + SIGQUIT : constant Interrupt_ID := + System.OS_Interface.SIGQUIT; -- quit (ASCD FS) + + SIGILL : constant Interrupt_ID := + System.OS_Interface.SIGILL; -- illegal instruction (not reset) + + SIGTRAP : constant Interrupt_ID := + System.OS_Interface.SIGTRAP; -- trace trap (not reset) + + SIGIOT : constant Interrupt_ID := + System.OS_Interface.SIGIOT; -- IOT instruction + + SIGABRT : constant Interrupt_ID := -- used by abort, + System.OS_Interface.SIGABRT; -- replace SIGIOT in the future + + SIGEMT : constant Interrupt_ID := + System.OS_Interface.SIGEMT; -- EMT instruction + + SIGFPE : constant Interrupt_ID := + System.OS_Interface.SIGFPE; -- floating point exception + + SIGKILL : constant Interrupt_ID := + System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) + + SIGBUS : constant Interrupt_ID := + System.OS_Interface.SIGBUS; -- bus error + + SIGSEGV : constant Interrupt_ID := + System.OS_Interface.SIGSEGV; -- segmentation violation + + SIGSYS : constant Interrupt_ID := + System.OS_Interface.SIGSYS; -- bad argument to system call + + SIGPIPE : constant Interrupt_ID := -- write on a pipe with + System.OS_Interface.SIGPIPE; -- no one to read it + + SIGALRM : constant Interrupt_ID := + System.OS_Interface.SIGALRM; -- alarm clock + + SIGTERM : constant Interrupt_ID := + System.OS_Interface.SIGTERM; -- software termination signal from kill + + SIGUSR1 : constant Interrupt_ID := + System.OS_Interface.SIGUSR1; -- user defined signal 1 + + SIGUSR2 : constant Interrupt_ID := + System.OS_Interface.SIGUSR2; -- user defined signal 2 + + SIGCLD : constant Interrupt_ID := + System.OS_Interface.SIGCLD; -- child status change + + SIGCHLD : constant Interrupt_ID := + System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD + + SIGPWR : constant Interrupt_ID := + System.OS_Interface.SIGPWR; -- power-fail restart + + SIGWINCH : constant Interrupt_ID := + System.OS_Interface.SIGWINCH; -- window size change + + SIGURG : constant Interrupt_ID := + System.OS_Interface.SIGURG; -- urgent condition on IO channel + + SIGPOLL : constant Interrupt_ID := + System.OS_Interface.SIGPOLL; -- pollable event occurred + + SIGIO : constant Interrupt_ID := -- input/output possible, + System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) + + SIGSTOP : constant Interrupt_ID := + System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) + + SIGTSTP : constant Interrupt_ID := + System.OS_Interface.SIGTSTP; -- user stop requested from tty + + SIGCONT : constant Interrupt_ID := + System.OS_Interface.SIGCONT; -- stopped process has been continued + + SIGTTIN : constant Interrupt_ID := + System.OS_Interface.SIGTTIN; -- background tty read attempted + + SIGTTOU : constant Interrupt_ID := + System.OS_Interface.SIGTTOU; -- background tty write attempted + + SIGVTALRM : constant Interrupt_ID := + System.OS_Interface.SIGVTALRM; -- virtual timer expired + + SIGPROF : constant Interrupt_ID := + System.OS_Interface.SIGPROF; -- profiling timer expired + + SIGXCPU : constant Interrupt_ID := + System.OS_Interface.SIGXCPU; -- CPU time limit exceeded + + SIGXFSZ : constant Interrupt_ID := + System.OS_Interface.SIGXFSZ; -- filesize limit exceeded + + SIGMSG : constant Interrupt_ID := + System.OS_Interface.SIGMSG; -- input data is in the ring buffer + + SIGDANGER : constant Interrupt_ID := + System.OS_Interface.SIGDANGER; -- system crash imminent; + + SIGMIGRATE : constant Interrupt_ID := + System.OS_Interface.SIGMIGRATE; -- migrate process + + SIGPRE : constant Interrupt_ID := + System.OS_Interface.SIGPRE; -- programming exception + + SIGVIRT : constant Interrupt_ID := + System.OS_Interface.SIGVIRT; -- AIX virtual time alarm + + SIGALRM1 : constant Interrupt_ID := + System.OS_Interface.SIGALRM1; -- m:n condition variables + + SIGWAITING : constant Interrupt_ID := + System.OS_Interface.SIGWAITING; -- m:n scheduling + + SIGKAP : constant Interrupt_ID := + System.OS_Interface.SIGKAP; -- keep alive poll from native keyboard + + SIGGRANT : constant Interrupt_ID := + System.OS_Interface.SIGGRANT; -- monitor mode granted + + SIGRETRACT : constant Interrupt_ID := + System.OS_Interface.SIGRETRACT; -- monitor mode should be relinquished + + SIGSOUND : constant Interrupt_ID := + System.OS_Interface.SIGSOUND; -- sound control has completed + + SIGSAK : constant Interrupt_ID := + System.OS_Interface.SIGSAK; -- secure attention key + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-darwin.ads b/gcc/ada/a-intnam-darwin.ads new file mode 100644 index 000000000..c2b6b1008 --- /dev/null +++ b/gcc/ada/a-intnam-darwin.ads @@ -0,0 +1,149 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Darwin version of this package + +-- The following signals are reserved by the run time: + +-- SIGSTOP, SIGKILL + +-- The pragma Unreserve_All_Interrupts affects the following signal(s): + +-- SIGINT: made available for Ada handler + +-- This target-dependent package spec contains names of interrupts +-- supported by the local system. + +with System.OS_Interface; + +package Ada.Interrupts.Names is + + -- Beware that the mapping of names to signals may be many-to-one. There + -- may be aliases. Also, for all signal names that are not supported on the + -- current system the value of the corresponding constant will be zero. + + SIGHUP : constant Interrupt_ID := + System.OS_Interface.SIGHUP; -- hangup + + SIGINT : constant Interrupt_ID := + System.OS_Interface.SIGINT; -- interrupt (rubout) + + SIGQUIT : constant Interrupt_ID := + System.OS_Interface.SIGQUIT; -- quit (ASCD FS) + + SIGILL : constant Interrupt_ID := + System.OS_Interface.SIGILL; -- illegal instruction (not reset) + + SIGTRAP : constant Interrupt_ID := + System.OS_Interface.SIGTRAP; -- trace trap (not reset) + + SIGIOT : constant Interrupt_ID := + System.OS_Interface.SIGIOT; -- IOT instruction + + SIGABRT : constant Interrupt_ID := -- used by abort, + System.OS_Interface.SIGABRT; -- replace SIGIOT in the future + + SIGEMT : constant Interrupt_ID := + System.OS_Interface.SIGEMT; -- EMT instruction + + SIGFPE : constant Interrupt_ID := + System.OS_Interface.SIGFPE; -- floating point exception + + SIGKILL : constant Interrupt_ID := + System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) + + SIGBUS : constant Interrupt_ID := + System.OS_Interface.SIGBUS; -- bus error + + SIGSEGV : constant Interrupt_ID := + System.OS_Interface.SIGSEGV; -- segmentation violation + + SIGSYS : constant Interrupt_ID := + System.OS_Interface.SIGSYS; -- bad argument to system call + + SIGPIPE : constant Interrupt_ID := -- write on a pipe with + System.OS_Interface.SIGPIPE; -- no one to read it + + SIGALRM : constant Interrupt_ID := + System.OS_Interface.SIGALRM; -- alarm clock + + SIGTERM : constant Interrupt_ID := + System.OS_Interface.SIGTERM; -- software termination signal from kill + + SIGURG : constant Interrupt_ID := + System.OS_Interface.SIGURG; -- urgent condition on IO channel + + SIGSTOP : constant Interrupt_ID := + System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) + + SIGTSTP : constant Interrupt_ID := + System.OS_Interface.SIGTSTP; -- user stop requested from tty + + SIGCONT : constant Interrupt_ID := + System.OS_Interface.SIGCONT; -- stopped process has been continued + + SIGCHLD : constant Interrupt_ID := + System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD + + SIGTTIN : constant Interrupt_ID := + System.OS_Interface.SIGTTIN; -- background tty read attempted + + SIGTTOU : constant Interrupt_ID := + System.OS_Interface.SIGTTOU; -- background tty write attempted + + SIGIO : constant Interrupt_ID := -- input/output possible, + System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) + + SIGXCPU : constant Interrupt_ID := + System.OS_Interface.SIGXCPU; -- CPU time limit exceeded + + SIGXFSZ : constant Interrupt_ID := + System.OS_Interface.SIGXFSZ; -- filesize limit exceeded + + SIGVTALRM : constant Interrupt_ID := + System.OS_Interface.SIGVTALRM; -- virtual timer expired + + SIGPROF : constant Interrupt_ID := + System.OS_Interface.SIGPROF; -- profiling timer expired + + SIGWINCH : constant Interrupt_ID := + System.OS_Interface.SIGWINCH; -- window size change + + SIGINFO : constant Interrupt_ID := + System.OS_Interface.SIGINFO; -- information request + + SIGUSR1 : constant Interrupt_ID := + System.OS_Interface.SIGUSR1; -- user defined signal 1 + + SIGUSR2 : constant Interrupt_ID := + System.OS_Interface.SIGUSR2; -- user defined signal 2 + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-dummy.ads b/gcc/ada/a-intnam-dummy.ads new file mode 100644 index 000000000..02602b3c6 --- /dev/null +++ b/gcc/ada/a-intnam-dummy.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- (No Tasking Version) -- +-- -- +-- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- The standard implementation of this spec contains only dummy interrupt +-- names. These dummy entries permit checking out code for correctness of +-- semantics, even if interrupts are not supported. + +-- For specific implementations that fully support interrupts, this package +-- spec is replaced by an implementation dependent version that defines the +-- interrupts available on the system. + +package Ada.Interrupts.Names is + + DUMMY_INTERRUPT_1 : constant Interrupt_ID := 1; + DUMMY_INTERRUPT_2 : constant Interrupt_ID := 2; + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-freebsd.ads b/gcc/ada/a-intnam-freebsd.ads new file mode 100644 index 000000000..dd432acf7 --- /dev/null +++ b/gcc/ada/a-intnam-freebsd.ads @@ -0,0 +1,132 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the FreeBSD THREADS version of this package + +with System.OS_Interface; + +package Ada.Interrupts.Names is + + -- Beware that the mapping of names to signals may be many-to-one. There + -- may be aliases. Also, for all signal names that are not supported on + -- the current system the value of the corresponding constant will be zero. + + SIGHUP : constant Interrupt_ID := + System.OS_Interface.SIGHUP; -- hangup + + SIGINT : constant Interrupt_ID := + System.OS_Interface.SIGINT; -- interrupt (rubout) + + SIGQUIT : constant Interrupt_ID := + System.OS_Interface.SIGQUIT; -- quit (ASCD FS) + + SIGILL : constant Interrupt_ID := + System.OS_Interface.SIGILL; -- illegal instruction (not reset) + + SIGTRAP : constant Interrupt_ID := + System.OS_Interface.SIGTRAP; -- trace trap (not reset) + + SIGIOT : constant Interrupt_ID := + System.OS_Interface.SIGIOT; -- IOT instruction + + SIGABRT : constant Interrupt_ID := -- used by abort, + System.OS_Interface.SIGABRT; -- replace SIGIOT in the future + + SIGFPE : constant Interrupt_ID := + System.OS_Interface.SIGFPE; -- floating point exception + + SIGKILL : constant Interrupt_ID := + System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) + + SIGBUS : constant Interrupt_ID := + System.OS_Interface.SIGBUS; -- bus error + + SIGSEGV : constant Interrupt_ID := + System.OS_Interface.SIGSEGV; -- segmentation violation + + SIGPIPE : constant Interrupt_ID := -- write on a pipe with + System.OS_Interface.SIGPIPE; -- no one to read it + + SIGALRM : constant Interrupt_ID := + System.OS_Interface.SIGALRM; -- alarm clock + + SIGTERM : constant Interrupt_ID := + System.OS_Interface.SIGTERM; -- software termination signal from kill + + SIGURG : constant Interrupt_ID := + System.OS_Interface.SIGURG; -- urgent condition on IO channel + + SIGSTOP : constant Interrupt_ID := + System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) + + SIGTSTP : constant Interrupt_ID := + System.OS_Interface.SIGTSTP; -- user stop requested from tty + + SIGCONT : constant Interrupt_ID := + System.OS_Interface.SIGCONT; -- stopped process has been continued + + SIGCHLD : constant Interrupt_ID := + System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD + + SIGCLD : constant Interrupt_ID := + System.OS_Interface.SIGCLD; -- child status change + + SIGTTIN : constant Interrupt_ID := + System.OS_Interface.SIGTTIN; -- background tty read attempted + + SIGTTOU : constant Interrupt_ID := + System.OS_Interface.SIGTTOU; -- background tty write attempted + + SIGIO : constant Interrupt_ID := -- input/output possible, + System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) + + SIGXCPU : constant Interrupt_ID := + System.OS_Interface.SIGXCPU; -- CPU time limit exceeded + + SIGXFSZ : constant Interrupt_ID := + System.OS_Interface.SIGXFSZ; -- filesize limit exceeded + + SIGVTALRM : constant Interrupt_ID := + System.OS_Interface.SIGVTALRM; -- virtual timer expired + + SIGPROF : constant Interrupt_ID := + System.OS_Interface.SIGPROF; -- profiling timer expired + + SIGWINCH : constant Interrupt_ID := + System.OS_Interface.SIGWINCH; -- window size change + + SIGUSR1 : constant Interrupt_ID := + System.OS_Interface.SIGUSR1; -- user defined signal 1 + + SIGUSR2 : constant Interrupt_ID := + System.OS_Interface.SIGUSR2; -- user defined signal 2 + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-hpux.ads b/gcc/ada/a-intnam-hpux.ads new file mode 100644 index 000000000..366a2404c --- /dev/null +++ b/gcc/ada/a-intnam-hpux.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a HP-UX version of this package + +-- The following signals are reserved by the run time: + +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGTERM, SIGABRT, SIGINT, +-- SIGALRM, SIGSTOP, SIGKILL + +-- The pragma Unreserve_All_Interrupts affects the following signal(s): + +-- SIGINT: made available for Ada handler + +-- This target-dependent package spec contains names of interrupts +-- supported by the local system. + +with System.OS_Interface; + +package Ada.Interrupts.Names is + + -- Beware that the mapping of names to signals may be many-to-one. There + -- may be aliases. Also, for all signal names that are not supported on + -- the current system the value of the corresponding constant will be zero. + + SIGHUP : constant Interrupt_ID := + System.OS_Interface.SIGHUP; -- hangup + + SIGINT : constant Interrupt_ID := + System.OS_Interface.SIGINT; -- interrupt (rubout) + + SIGQUIT : constant Interrupt_ID := + System.OS_Interface.SIGQUIT; -- quit (ASCD FS) + + SIGILL : constant Interrupt_ID := + System.OS_Interface.SIGILL; -- illegal instruction (not reset) + + SIGTRAP : constant Interrupt_ID := + System.OS_Interface.SIGTRAP; -- trace trap (not reset) + + SIGIOT : constant Interrupt_ID := + System.OS_Interface.SIGIOT; -- IOT instruction + + SIGABRT : constant Interrupt_ID := -- used by abort, + System.OS_Interface.SIGABRT; -- replace SIGIOT in the future + + SIGEMT : constant Interrupt_ID := + System.OS_Interface.SIGEMT; -- EMT instruction + + SIGFPE : constant Interrupt_ID := + System.OS_Interface.SIGFPE; -- floating point exception + + SIGKILL : constant Interrupt_ID := + System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) + + SIGBUS : constant Interrupt_ID := + System.OS_Interface.SIGBUS; -- bus error + + SIGSEGV : constant Interrupt_ID := + System.OS_Interface.SIGSEGV; -- segmentation violation + + SIGSYS : constant Interrupt_ID := + System.OS_Interface.SIGSYS; -- bad argument to system call + + SIGPIPE : constant Interrupt_ID := -- write on a pipe with + System.OS_Interface.SIGPIPE; -- no one to read it + + SIGALRM : constant Interrupt_ID := + System.OS_Interface.SIGALRM; -- alarm clock + + SIGTERM : constant Interrupt_ID := + System.OS_Interface.SIGTERM; -- software termination signal from kill + + SIGUSR1 : constant Interrupt_ID := + System.OS_Interface.SIGUSR1; -- user defined signal 1 + + SIGUSR2 : constant Interrupt_ID := + System.OS_Interface.SIGUSR2; -- user defined signal 2 + + SIGCLD : constant Interrupt_ID := + System.OS_Interface.SIGCLD; -- child status change + + SIGCHLD : constant Interrupt_ID := + System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD + + SIGWINCH : constant Interrupt_ID := + System.OS_Interface.SIGWINCH; -- window size change + + SIGURG : constant Interrupt_ID := + System.OS_Interface.SIGURG; -- urgent condition on IO channel + + SIGPOLL : constant Interrupt_ID := + System.OS_Interface.SIGPOLL; -- pollable event occurred + + SIGIO : constant Interrupt_ID := -- input/output possible, + System.OS_Interface.SIGIO; -- SIGPOLL alias + + SIGSTOP : constant Interrupt_ID := + System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) + + SIGTSTP : constant Interrupt_ID := + System.OS_Interface.SIGTSTP; -- user stop requested from tty + + SIGCONT : constant Interrupt_ID := + System.OS_Interface.SIGCONT; -- stopped process has been continued + + SIGTTIN : constant Interrupt_ID := + System.OS_Interface.SIGTTIN; -- background tty read attempted + + SIGTTOU : constant Interrupt_ID := + System.OS_Interface.SIGTTOU; -- background tty write attempted + + SIGVTALRM : constant Interrupt_ID := + System.OS_Interface.SIGVTALRM; -- virtual timer expired + + SIGPROF : constant Interrupt_ID := + System.OS_Interface.SIGPROF; -- profiling timer expired + + SIGPWR : constant Interrupt_ID := + System.OS_Interface.SIGPWR; -- power-fail restart + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-irix.ads b/gcc/ada/a-intnam-irix.ads new file mode 100644 index 000000000..9c1cd0280 --- /dev/null +++ b/gcc/ada/a-intnam-irix.ads @@ -0,0 +1,191 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Irix version of this package + +-- The following signals are reserved by the run time (Athread library): + +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGSTOP, SIGKILL + +-- The following signals are reserved by the run time (Pthread library): + +-- SIGTSTP, SIGILL, SIGTRAP, SIGEMT, SIGFPE, SIGBUS, SIGSTOP, SIGKILL, +-- SIGSEGV, SIGSYS, SIGXCPU, SIGXFSZ, SIGPROF, SIGPTINTR, SIGPTRESCHED, +-- SIGABRT, SIGINT + +-- The pragma Unreserve_All_Interrupts affects the following signal +-- (Pthread library): + +-- SIGINT: made available for Ada handler + +-- This target-dependent package spec contains names of interrupts +-- supported by the local system. + +with System.OS_Interface; + +package Ada.Interrupts.Names is + + -- Beware that the mapping of names to signals may be many-to-one. There + -- may be aliases. Also, for all signal names that are not supported on + -- the current system the value of the corresponding constant will be zero. + + SIGHUP : constant Interrupt_ID := + System.OS_Interface.SIGHUP; -- hangup + + SIGINT : constant Interrupt_ID := + System.OS_Interface.SIGINT; -- interrupt (rubout) + + SIGQUIT : constant Interrupt_ID := + System.OS_Interface.SIGQUIT; -- quit (ASCD FS) + + SIGILL : constant Interrupt_ID := + System.OS_Interface.SIGILL; -- illegal instruction (not reset) + + SIGTRAP : constant Interrupt_ID := + System.OS_Interface.SIGTRAP; -- trace trap (not reset) + + SIGIOT : constant Interrupt_ID := + System.OS_Interface.SIGIOT; -- IOT instruction + + SIGABRT : constant Interrupt_ID := + System.OS_Interface.SIGABRT; -- used by abort, replace SIGIOT in the + -- future + + SIGEMT : constant Interrupt_ID := + System.OS_Interface.SIGEMT; -- EMT instruction + + SIGFPE : constant Interrupt_ID := + System.OS_Interface.SIGFPE; -- floating point exception + + SIGKILL : constant Interrupt_ID := + System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) + + SIGBUS : constant Interrupt_ID := + System.OS_Interface.SIGBUS; -- bus error + + SIGSEGV : constant Interrupt_ID := + System.OS_Interface.SIGSEGV; -- segmentation violation + + SIGSYS : constant Interrupt_ID := + System.OS_Interface.SIGSYS; -- bad argument to system call + + SIGPIPE : constant Interrupt_ID := + System.OS_Interface.SIGPIPE; -- write on pipe with no one to read it + + SIGALRM : constant Interrupt_ID := + System.OS_Interface.SIGALRM; -- alarm clock + + SIGTERM : constant Interrupt_ID := + System.OS_Interface.SIGTERM; -- software termination signal from kill + + SIGUSR1 : constant Interrupt_ID := + System.OS_Interface.SIGUSR1; -- user defined signal 1 + + SIGUSR2 : constant Interrupt_ID := + System.OS_Interface.SIGUSR2; -- user defined signal 2 + + SIGCLD : constant Interrupt_ID := + System.OS_Interface.SIGCLD; -- alias for SIGCHLD + + SIGCHLD : constant Interrupt_ID := + System.OS_Interface.SIGCHLD; -- child status change + + SIGPWR : constant Interrupt_ID := + System.OS_Interface.SIGPWR; -- power-fail restart + + SIGWINCH : constant Interrupt_ID := + System.OS_Interface.SIGWINCH; -- window size change + + SIGURG : constant Interrupt_ID := + System.OS_Interface.SIGURG; -- urgent condition on IO channel + + SIGPOLL : constant Interrupt_ID := + System.OS_Interface.SIGPOLL; -- pollable event occurred + + SIGIO : constant Interrupt_ID := + System.OS_Interface.SIGIO; -- I/O possible (Solaris SIGPOLL alias) + + SIGSTOP : constant Interrupt_ID := + System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) + + SIGTSTP : constant Interrupt_ID := + System.OS_Interface.SIGTSTP; -- user stop requested from tty + + SIGCONT : constant Interrupt_ID := + System.OS_Interface.SIGCONT; -- stopped process has been continued + + SIGTTIN : constant Interrupt_ID := + System.OS_Interface.SIGTTIN; -- background tty read attempted + + SIGTTOU : constant Interrupt_ID := + System.OS_Interface.SIGTTOU; -- background tty write attempted + + SIGVTALRM : constant Interrupt_ID := + System.OS_Interface.SIGVTALRM; -- virtual timer expired + + SIGPROF : constant Interrupt_ID := + System.OS_Interface.SIGPROF; -- profiling timer expired + + SIGXCPU : constant Interrupt_ID := + System.OS_Interface.SIGXCPU; -- CPU time limit exceeded + + SIGXFSZ : constant Interrupt_ID := + System.OS_Interface.SIGXFSZ; -- filesize limit exceeded + + SIGK32 : constant Interrupt_ID := + System.OS_Interface.SIGK32; -- reserved for kernel (IRIX) + + SIGCKPT : constant Interrupt_ID := + System.OS_Interface.SIGCKPT; -- Checkpoint warning + + SIGRESTART : constant Interrupt_ID := + System.OS_Interface.SIGRESTART; -- Restart warning + + SIGUME : constant Interrupt_ID := + System.OS_Interface.SIGUME; -- Uncorrectable memory error + + -- Signals defined for Posix 1003.1c + + SIGPTINTR : constant Interrupt_ID := + System.OS_Interface.SIGPTINTR; -- Pthread Interrupt Signal + + SIGPTRESCHED : constant Interrupt_ID := + System.OS_Interface.SIGPTRESCHED; -- Pthread Rescheduling Signal + + -- Posix 1003.1b signals + + SIGRTMIN : constant Interrupt_ID := + System.OS_Interface.SIGRTMIN; -- Posix 1003.1b signals + + SIGRTMAX : constant Interrupt_ID := + System.OS_Interface.SIGRTMAX; -- Posix 1003.1b signals + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-linux.ads b/gcc/ada/a-intnam-linux.ads new file mode 100644 index 000000000..0b33efe81 --- /dev/null +++ b/gcc/ada/a-intnam-linux.ads @@ -0,0 +1,164 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a GNU/Linux version of this package + +-- The following signals are reserved by the run time (FSU threads): + +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, +-- SIGALRM, SIGVTALRM, SIGUNUSED, SIGSTOP, SIGKILL + +-- The following signals are reserved by the run time (LinuxThreads): + +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, +-- SIGUSR1, SIGUSR2, SIGVTALRM, SIGUNUSED, SIGSTOP, SIGKILL + +-- The pragma Unreserve_All_Interrupts affects the following signal(s): + +-- SIGINT: made available for Ada handler + +-- This target-dependent package spec contains names of interrupts +-- supported by the local system. + +with System.OS_Interface; + +package Ada.Interrupts.Names is + + -- Beware that the mapping of names to signals may be many-to-one. There + -- may be aliases. Also, for all signal names that are not supported on the + -- current system the value of the corresponding constant will be zero. + + SIGHUP : constant Interrupt_ID := + System.OS_Interface.SIGHUP; -- hangup + + SIGINT : constant Interrupt_ID := + System.OS_Interface.SIGINT; -- interrupt (rubout) + + SIGQUIT : constant Interrupt_ID := + System.OS_Interface.SIGQUIT; -- quit (ASCD FS) + + SIGILL : constant Interrupt_ID := + System.OS_Interface.SIGILL; -- illegal instruction (not reset) + + SIGTRAP : constant Interrupt_ID := + System.OS_Interface.SIGTRAP; -- trace trap (not reset) + + SIGIOT : constant Interrupt_ID := + System.OS_Interface.SIGIOT; -- IOT instruction + + SIGABRT : constant Interrupt_ID := -- used by abort, + System.OS_Interface.SIGABRT; -- replace SIGIOT in the future + + SIGFPE : constant Interrupt_ID := + System.OS_Interface.SIGFPE; -- floating point exception + + SIGKILL : constant Interrupt_ID := + System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) + + SIGBUS : constant Interrupt_ID := + System.OS_Interface.SIGBUS; -- bus error + + SIGSEGV : constant Interrupt_ID := + System.OS_Interface.SIGSEGV; -- segmentation violation + + SIGPIPE : constant Interrupt_ID := -- write on a pipe with + System.OS_Interface.SIGPIPE; -- no one to read it + + SIGALRM : constant Interrupt_ID := + System.OS_Interface.SIGALRM; -- alarm clock + + SIGTERM : constant Interrupt_ID := + System.OS_Interface.SIGTERM; -- software termination signal from kill + + SIGUSR1 : constant Interrupt_ID := + System.OS_Interface.SIGUSR1; -- user defined signal 1 + + SIGUSR2 : constant Interrupt_ID := + System.OS_Interface.SIGUSR2; -- user defined signal 2 + + SIGCLD : constant Interrupt_ID := + System.OS_Interface.SIGCLD; -- child status change + + SIGCHLD : constant Interrupt_ID := + System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD + + SIGWINCH : constant Interrupt_ID := + System.OS_Interface.SIGWINCH; -- window size change + + SIGURG : constant Interrupt_ID := + System.OS_Interface.SIGURG; -- urgent condition on IO channel + + SIGPOLL : constant Interrupt_ID := + System.OS_Interface.SIGPOLL; -- pollable event occurred + + SIGIO : constant Interrupt_ID := -- input/output possible, + System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) + + SIGSTOP : constant Interrupt_ID := + System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) + + SIGTSTP : constant Interrupt_ID := + System.OS_Interface.SIGTSTP; -- user stop requested from tty + + SIGCONT : constant Interrupt_ID := + System.OS_Interface.SIGCONT; -- stopped process has been continued + + SIGTTIN : constant Interrupt_ID := + System.OS_Interface.SIGTTIN; -- background tty read attempted + + SIGTTOU : constant Interrupt_ID := + System.OS_Interface.SIGTTOU; -- background tty write attempted + + SIGVTALRM : constant Interrupt_ID := + System.OS_Interface.SIGVTALRM; -- virtual timer expired + + SIGPROF : constant Interrupt_ID := + System.OS_Interface.SIGPROF; -- profiling timer expired + + SIGXCPU : constant Interrupt_ID := + System.OS_Interface.SIGXCPU; -- CPU time limit exceeded + + SIGXFSZ : constant Interrupt_ID := + System.OS_Interface.SIGXFSZ; -- filesize limit exceeded + + SIGUNUSED : constant Interrupt_ID := + System.OS_Interface.SIGUNUSED; -- unused signal + + SIGSTKFLT : constant Interrupt_ID := + System.OS_Interface.SIGSTKFLT; -- stack fault on coprocessor + + SIGLOST : constant Interrupt_ID := + System.OS_Interface.SIGLOST; -- Linux alias for SIGIO + + SIGPWR : constant Interrupt_ID := + System.OS_Interface.SIGPWR; -- Power failure + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-lynxos.ads b/gcc/ada/a-intnam-lynxos.ads new file mode 100644 index 000000000..13509e53f --- /dev/null +++ b/gcc/ada/a-intnam-lynxos.ads @@ -0,0 +1,162 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a LynxOS version of this package + +-- The following signals are reserved by the run time: + +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, +-- SIGWAITING, SIGLWP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF, SIGSTOP, SIGKILL + +-- The pragma Unreserve_All_Interrupts affects the following signal(s): + +-- SIGINT: made available for Ada handler + +with System.OS_Interface; + +package Ada.Interrupts.Names is + + -- Beware that the mapping of names to signals may be many-to-one. There + -- may be aliases. + + SIGHUP : constant Interrupt_ID := + System.OS_Interface.SIGHUP; -- hangup + + SIGINT : constant Interrupt_ID := + System.OS_Interface.SIGINT; -- interrupt (rubout) + + SIGQUIT : constant Interrupt_ID := + System.OS_Interface.SIGQUIT; -- quit (ASCD FS) + + SIGILL : constant Interrupt_ID := + System.OS_Interface.SIGILL; -- illegal instruction (not reset) + + SIGTRAP : constant Interrupt_ID := + System.OS_Interface.SIGTRAP; -- trace trap (not reset) + + SIGBRK : constant Interrupt_ID := + System.OS_Interface.SIGBRK; -- break + + SIGIOT : constant Interrupt_ID := + System.OS_Interface.SIGIOT; -- IOT instruction + + SIGABRT : constant Interrupt_ID := -- used by abort, + System.OS_Interface.SIGABRT; -- replace SIGIOT in the future + + SIGCORE : constant Interrupt_ID := + System.OS_Interface.SIGCORE; -- kill with core dump + + SIGEMT : constant Interrupt_ID := + System.OS_Interface.SIGEMT; -- EMT instruction + + SIGFPE : constant Interrupt_ID := + System.OS_Interface.SIGFPE; -- floating point exception + + SIGKILL : constant Interrupt_ID := + System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) + + SIGBUS : constant Interrupt_ID := + System.OS_Interface.SIGBUS; -- bus error + + SIGSEGV : constant Interrupt_ID := + System.OS_Interface.SIGSEGV; -- segmentation violation + + SIGSYS : constant Interrupt_ID := + System.OS_Interface.SIGSYS; -- bad argument to system call + + SIGPIPE : constant Interrupt_ID := -- write on a pipe with + System.OS_Interface.SIGPIPE; -- no one to read it + + SIGALRM : constant Interrupt_ID := + System.OS_Interface.SIGALRM; -- alarm clock + + SIGTERM : constant Interrupt_ID := + System.OS_Interface.SIGTERM; -- software termination signal from kill + + SIGURG : constant Interrupt_ID := + System.OS_Interface.SIGURG; -- urgent condition on IO channel + + SIGSTOP : constant Interrupt_ID := + System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) + + SIGTSTP : constant Interrupt_ID := + System.OS_Interface.SIGTSTP; -- user stop requested from tty + + SIGCONT : constant Interrupt_ID := + System.OS_Interface.SIGCONT; -- stopped process has been continued + + SIGCLD : constant Interrupt_ID := + System.OS_Interface.SIGCLD; -- child status change + + SIGCHLD : constant Interrupt_ID := + System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD + + SIGTTIN : constant Interrupt_ID := + System.OS_Interface.SIGTTIN; -- background tty read attempted + + SIGTTOU : constant Interrupt_ID := + System.OS_Interface.SIGTTOU; -- background tty write attempted + + SIGPOLL : constant Interrupt_ID := + System.OS_Interface.SIGPOLL; -- pollable event occurred + + SIGIO : constant Interrupt_ID := -- input/output possible, + System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) + + SIGXCPU : constant Interrupt_ID := + System.OS_Interface.SIGXCPU; -- CPU time limit exceeded + + SIGXFSZ : constant Interrupt_ID := + System.OS_Interface.SIGXFSZ; -- filesize limit exceeded + + SIGVTALRM : constant Interrupt_ID := + System.OS_Interface.SIGVTALRM; -- virtual timer expired + + SIGPROF : constant Interrupt_ID := + System.OS_Interface.SIGPROF; -- profiling timer expired + + SIGWINCH : constant Interrupt_ID := + System.OS_Interface.SIGWINCH; -- window size change + + SIGLOST : constant Interrupt_ID := + System.OS_Interface.SIGLOST; -- SUN 4.1 compatibility + + SIGUSR1 : constant Interrupt_ID := + System.OS_Interface.SIGUSR1; -- user defined signal 1 + + SIGUSR2 : constant Interrupt_ID := + System.OS_Interface.SIGUSR2; -- user defined signal 2 + + SIGPRIO : constant Interrupt_ID := + System.OS_Interface.SIGPRIO; + -- sent to a process with its priority + -- or group is changed +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-mingw.ads b/gcc/ada/a-intnam-mingw.ads new file mode 100644 index 000000000..7b790a6b1 --- /dev/null +++ b/gcc/ada/a-intnam-mingw.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a NT (native) version of this package + +-- This target-dependent package spec contains names of interrupts supported +-- by the local system. + +with System.OS_Interface; + +package Ada.Interrupts.Names is + + -- Beware that the mapping of names to signals may be many-to-one. There + -- may be aliases. Also, for all signal names that are not supported on the + -- current system the value of the corresponding constant will be zero. + + SIGINT : constant Interrupt_ID := -- interrupt (rubout) + System.OS_Interface.SIGINT; + + SIGILL : constant Interrupt_ID := -- illegal instruction (not reset) + System.OS_Interface.SIGILL; + + SIGABRT : constant Interrupt_ID := -- used by abort (use SIGIOT in future) + System.OS_Interface.SIGABRT; + + SIGFPE : constant Interrupt_ID := -- floating point exception + System.OS_Interface.SIGFPE; + + SIGSEGV : constant Interrupt_ID := -- segmentation violation + System.OS_Interface.SIGSEGV; + + SIGTERM : constant Interrupt_ID := -- software termination signal from kill + System.OS_Interface.SIGTERM; + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-rtems.ads b/gcc/ada/a-intnam-rtems.ads new file mode 100644 index 000000000..43a5281c3 --- /dev/null +++ b/gcc/ada/a-intnam-rtems.ads @@ -0,0 +1,114 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2009 Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +-- The GNARL files that were developed for RTEMS are maintained by On-Line -- +-- Applications Research Corporation (http://www.oarcorp.com) in coopera- -- +-- tion with Ada Core Technologies Inc. and Florida State University. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a RTEMS version of this package +-- +-- The following signals are reserved by the run time: +-- +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, +-- SIGALRM, SIGEMT, SIGKILL +-- +-- The pragma Unreserve_All_Interrupts affects the following signal(s): +-- +-- SIGINT: made available for Ada handlers + +-- This target-dependent package spec contains names of interrupts +-- supported by the local system. + +with System.OS_Interface; +-- used for names of interrupts + +package Ada.Interrupts.Names is + + -- Beware that the mapping of names to signals may be + -- many-to-one. There may be aliases. Also, for all + -- signal names that are not supported on the current system + -- the value of the corresponding constant will be zero. + + SIGHUP : constant Interrupt_ID := + System.OS_Interface.SIGHUP; -- hangup + + SIGINT : constant Interrupt_ID := + System.OS_Interface.SIGINT; -- interrupt (rubout) + + SIGQUIT : constant Interrupt_ID := + System.OS_Interface.SIGQUIT; -- quit (ASCD FS) + + SIGILL : constant Interrupt_ID := + System.OS_Interface.SIGILL; -- illegal instruction (not reset) + + SIGTRAP : constant Interrupt_ID := + System.OS_Interface.SIGTRAP; -- trace trap (not reset) + + SIGIOT : constant Interrupt_ID := + System.OS_Interface.SIGIOT; -- IOT instruction + + SIGABRT : constant Interrupt_ID := -- used by abort, + System.OS_Interface.SIGABRT; -- replace SIGIOT in the future + + SIGEMT : constant Interrupt_ID := + System.OS_Interface.SIGEMT; -- EMT instruction + + SIGFPE : constant Interrupt_ID := + System.OS_Interface.SIGFPE; -- floating point exception + + SIGKILL : constant Interrupt_ID := + System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) + + SIGBUS : constant Interrupt_ID := + System.OS_Interface.SIGBUS; -- bus error + + SIGSEGV : constant Interrupt_ID := + System.OS_Interface.SIGSEGV; -- segmentation violation + + SIGSYS : constant Interrupt_ID := + System.OS_Interface.SIGSYS; -- bad argument to system call + + SIGPIPE : constant Interrupt_ID := -- write on a pipe with + System.OS_Interface.SIGPIPE; -- no one to read it + + SIGALRM : constant Interrupt_ID := + System.OS_Interface.SIGALRM; -- alarm clock + + SIGTERM : constant Interrupt_ID := + System.OS_Interface.SIGTERM; -- software termination signal from kill + + SIGUSR1 : constant Interrupt_ID := + System.OS_Interface.SIGUSR1; -- user defined signal 1 + + SIGUSR2 : constant Interrupt_ID := + System.OS_Interface.SIGUSR2; -- user defined signal 2 + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-solaris.ads b/gcc/ada/a-intnam-solaris.ads new file mode 100644 index 000000000..88d4e2721 --- /dev/null +++ b/gcc/ada/a-intnam-solaris.ads @@ -0,0 +1,175 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a Solaris version of this package + +-- The following signals are reserved by the run time (native threads): + +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, +-- SIGLWP, SIGWAITING, SIGCANCEL, SIGSTOP, SIGKILL + +-- The following signals are reserved by the run time (FSU threads): + +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGTERM, SIGABRT, SIGINT, +-- SIGLWP, SIGALRM, SIGVTALRM, SIGWAITING, SIGSTOP, SIGKILL + +-- The pragma Unreserve_All_Interrupts affects the following signal(s): + +-- SIGINT: made available for Ada handlers + +with System.OS_Interface; + +package Ada.Interrupts.Names is + + -- Beware that the mapping of names to signals may be many-to-one. There + -- may be aliases. Also, for all signal names that are not supported on the + -- current system the value of the corresponding constant will be zero. + + SIGHUP : constant Interrupt_ID := + System.OS_Interface.SIGHUP; -- hangup + + SIGINT : constant Interrupt_ID := + System.OS_Interface.SIGINT; -- interrupt (rubout) + + SIGQUIT : constant Interrupt_ID := + System.OS_Interface.SIGQUIT; -- quit (ASCD FS) + + SIGILL : constant Interrupt_ID := + System.OS_Interface.SIGILL; -- illegal instruction (not reset) + + SIGTRAP : constant Interrupt_ID := + System.OS_Interface.SIGTRAP; -- trace trap (not reset) + + SIGIOT : constant Interrupt_ID := + System.OS_Interface.SIGIOT; -- IOT instruction + + SIGABRT : constant Interrupt_ID := -- used by abort, + System.OS_Interface.SIGABRT; -- replace SIGIOT in the future + + SIGEMT : constant Interrupt_ID := + System.OS_Interface.SIGEMT; -- EMT instruction + + SIGFPE : constant Interrupt_ID := + System.OS_Interface.SIGFPE; -- floating point exception + + SIGKILL : constant Interrupt_ID := + System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) + + SIGBUS : constant Interrupt_ID := + System.OS_Interface.SIGBUS; -- bus error + + SIGSEGV : constant Interrupt_ID := + System.OS_Interface.SIGSEGV; -- segmentation violation + + SIGSYS : constant Interrupt_ID := + System.OS_Interface.SIGSYS; -- bad argument to system call + + SIGPIPE : constant Interrupt_ID := -- write on a pipe with + System.OS_Interface.SIGPIPE; -- no one to read it + + SIGALRM : constant Interrupt_ID := + System.OS_Interface.SIGALRM; -- alarm clock + + SIGTERM : constant Interrupt_ID := + System.OS_Interface.SIGTERM; -- software termination signal from kill + + SIGUSR1 : constant Interrupt_ID := + System.OS_Interface.SIGUSR1; -- user defined signal 1 + + SIGUSR2 : constant Interrupt_ID := + System.OS_Interface.SIGUSR2; -- user defined signal 2 + + SIGCLD : constant Interrupt_ID := + System.OS_Interface.SIGCLD; -- child status change + + SIGCHLD : constant Interrupt_ID := + System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD + + SIGWINCH : constant Interrupt_ID := + System.OS_Interface.SIGWINCH; -- window size change + + SIGURG : constant Interrupt_ID := + System.OS_Interface.SIGURG; -- urgent condition on IO channel + + SIGPOLL : constant Interrupt_ID := + System.OS_Interface.SIGPOLL; -- pollable event occurred + + SIGIO : constant Interrupt_ID := -- input/output possible, + System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) + + SIGSTOP : constant Interrupt_ID := + System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) + + SIGTSTP : constant Interrupt_ID := + System.OS_Interface.SIGTSTP; -- user stop requested from tty + + SIGCONT : constant Interrupt_ID := + System.OS_Interface.SIGCONT; -- stopped process has been continued + + SIGTTIN : constant Interrupt_ID := + System.OS_Interface.SIGTTIN; -- background tty read attempted + + SIGTTOU : constant Interrupt_ID := + System.OS_Interface.SIGTTOU; -- background tty write attempted + + SIGVTALRM : constant Interrupt_ID := + System.OS_Interface.SIGVTALRM; -- virtual timer expired + + SIGPROF : constant Interrupt_ID := + System.OS_Interface.SIGPROF; -- profiling timer expired + + SIGXCPU : constant Interrupt_ID := + System.OS_Interface.SIGXCPU; -- CPU time limit exceeded + + SIGXFSZ : constant Interrupt_ID := + System.OS_Interface.SIGXFSZ; -- filesize limit exceeded + + SIGPWR : constant Interrupt_ID := + System.OS_Interface.SIGPWR; -- power-fail restart + + SIGWAITING : constant Interrupt_ID := + System.OS_Interface.SIGWAITING; -- process's lwps blocked (Solaris) + + SIGLWP : constant Interrupt_ID := + System.OS_Interface.SIGLWP; -- used by thread library (Solaris) + + SIGFREEZE : constant Interrupt_ID := + System.OS_Interface.SIGFREEZE; -- used by CPR (Solaris) + +-- what is CPR???? + + SIGTHAW : constant Interrupt_ID := + System.OS_Interface.SIGTHAW; -- used by CPR (Solaris) + + SIGCANCEL : constant Interrupt_ID := + System.OS_Interface.SIGCANCEL; -- used for thread cancel (Solaris) + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-tru64.ads b/gcc/ada/a-intnam-tru64.ads new file mode 100644 index 000000000..281260b5d --- /dev/null +++ b/gcc/ada/a-intnam-tru64.ads @@ -0,0 +1,147 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the DEC Unix 4.0 version of this package + +-- The following signals are reserved by the run time: + +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT, SIGTRAP, SIGINT, SIGALRM, +-- SIGSTOP, SIGKILL + +-- The pragma Unreserve_All_Interrupts affects the following signal(s): + +-- SIGINT: made available for Ada handler + +with System.OS_Interface; + +package Ada.Interrupts.Names is + + -- Beware that the mapping of names to signals may be many-to-one. There + -- may be aliases. Also, for all signal names that are not supported on the + -- current system the value of the corresponding constant will be zero. + + SIGHUP : constant Interrupt_ID := + System.OS_Interface.SIGHUP; -- hangup + + SIGINT : constant Interrupt_ID := + System.OS_Interface.SIGINT; -- interrupt (rubout) + + SIGQUIT : constant Interrupt_ID := + System.OS_Interface.SIGQUIT; -- quit (ASCD FS) + + SIGILL : constant Interrupt_ID := + System.OS_Interface.SIGILL; -- illegal instruction (not reset) + + SIGTRAP : constant Interrupt_ID := + System.OS_Interface.SIGTRAP; -- trace trap (not reset) + + SIGIOT : constant Interrupt_ID := + System.OS_Interface.SIGIOT; -- IOT instruction + + SIGABRT : constant Interrupt_ID := -- used by abort, + System.OS_Interface.SIGABRT; -- replace SIGIOT in the future + + SIGEMT : constant Interrupt_ID := + System.OS_Interface.SIGEMT; -- EMT instruction + + SIGFPE : constant Interrupt_ID := + System.OS_Interface.SIGFPE; -- floating point exception + + SIGKILL : constant Interrupt_ID := + System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) + + SIGBUS : constant Interrupt_ID := + System.OS_Interface.SIGBUS; -- bus error + + SIGSEGV : constant Interrupt_ID := + System.OS_Interface.SIGSEGV; -- segmentation violation + + SIGSYS : constant Interrupt_ID := + System.OS_Interface.SIGSYS; -- bad argument to system call + + SIGPIPE : constant Interrupt_ID := -- write on a pipe with + System.OS_Interface.SIGPIPE; -- no one to read it + + SIGALRM : constant Interrupt_ID := + System.OS_Interface.SIGALRM; -- alarm clock + + SIGTERM : constant Interrupt_ID := + System.OS_Interface.SIGTERM; -- software termination signal from kill + + SIGUSR1 : constant Interrupt_ID := + System.OS_Interface.SIGUSR1; -- user defined signal 1 + + SIGUSR2 : constant Interrupt_ID := + System.OS_Interface.SIGUSR2; -- user defined signal 2 + + SIGCHLD : constant Interrupt_ID := + System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD + + SIGWINCH : constant Interrupt_ID := + System.OS_Interface.SIGWINCH; -- window size change + + SIGURG : constant Interrupt_ID := + System.OS_Interface.SIGURG; -- urgent condition on IO channel + + SIGPOLL : constant Interrupt_ID := + System.OS_Interface.SIGPOLL; -- pollable event occurred + + SIGIO : constant Interrupt_ID := -- input/output possible, + System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) + + SIGSTOP : constant Interrupt_ID := + System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) + + SIGTSTP : constant Interrupt_ID := + System.OS_Interface.SIGTSTP; -- user stop requested from tty + + SIGCONT : constant Interrupt_ID := + System.OS_Interface.SIGCONT; -- stopped process has been continued + + SIGTTIN : constant Interrupt_ID := + System.OS_Interface.SIGTTIN; -- background tty read attempted + + SIGTTOU : constant Interrupt_ID := + System.OS_Interface.SIGTTOU; -- background tty write attempted + + SIGVTALRM : constant Interrupt_ID := + System.OS_Interface.SIGVTALRM; -- virtual timer expired + + SIGPROF : constant Interrupt_ID := + System.OS_Interface.SIGPROF; -- profiling timer expired + + SIGXCPU : constant Interrupt_ID := + System.OS_Interface.SIGXCPU; -- CPU time limit exceeded + + SIGXFSZ : constant Interrupt_ID := + System.OS_Interface.SIGXFSZ; -- filesize limit exceeded + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-vms.ads b/gcc/ada/a-intnam-vms.ads new file mode 100644 index 000000000..f9086cce8 --- /dev/null +++ b/gcc/ada/a-intnam-vms.ads @@ -0,0 +1,76 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a OpenVMS/Alpha version of this package + +-- This target-dependent package spec contains names of interrupts +-- supported by the local system. + +with System.OS_Interface; + +package Ada.Interrupts.Names is + + package OS renames System.OS_Interface; + + Interrupt_ID_0 : constant Interrupt_ID := OS.Interrupt_ID_0; + Interrupt_ID_1 : constant Interrupt_ID := OS.Interrupt_ID_1; + Interrupt_ID_2 : constant Interrupt_ID := OS.Interrupt_ID_2; + Interrupt_ID_3 : constant Interrupt_ID := OS.Interrupt_ID_3; + Interrupt_ID_4 : constant Interrupt_ID := OS.Interrupt_ID_4; + Interrupt_ID_5 : constant Interrupt_ID := OS.Interrupt_ID_5; + Interrupt_ID_6 : constant Interrupt_ID := OS.Interrupt_ID_6; + Interrupt_ID_7 : constant Interrupt_ID := OS.Interrupt_ID_7; + Interrupt_ID_8 : constant Interrupt_ID := OS.Interrupt_ID_8; + Interrupt_ID_9 : constant Interrupt_ID := OS.Interrupt_ID_9; + Interrupt_ID_10 : constant Interrupt_ID := OS.Interrupt_ID_10; + Interrupt_ID_11 : constant Interrupt_ID := OS.Interrupt_ID_11; + Interrupt_ID_12 : constant Interrupt_ID := OS.Interrupt_ID_12; + Interrupt_ID_13 : constant Interrupt_ID := OS.Interrupt_ID_13; + Interrupt_ID_14 : constant Interrupt_ID := OS.Interrupt_ID_14; + Interrupt_ID_15 : constant Interrupt_ID := OS.Interrupt_ID_15; + Interrupt_ID_16 : constant Interrupt_ID := OS.Interrupt_ID_16; + Interrupt_ID_17 : constant Interrupt_ID := OS.Interrupt_ID_17; + Interrupt_ID_18 : constant Interrupt_ID := OS.Interrupt_ID_18; + Interrupt_ID_19 : constant Interrupt_ID := OS.Interrupt_ID_19; + Interrupt_ID_20 : constant Interrupt_ID := OS.Interrupt_ID_20; + Interrupt_ID_21 : constant Interrupt_ID := OS.Interrupt_ID_21; + Interrupt_ID_22 : constant Interrupt_ID := OS.Interrupt_ID_22; + Interrupt_ID_23 : constant Interrupt_ID := OS.Interrupt_ID_23; + Interrupt_ID_24 : constant Interrupt_ID := OS.Interrupt_ID_24; + Interrupt_ID_25 : constant Interrupt_ID := OS.Interrupt_ID_25; + Interrupt_ID_26 : constant Interrupt_ID := OS.Interrupt_ID_26; + Interrupt_ID_27 : constant Interrupt_ID := OS.Interrupt_ID_27; + Interrupt_ID_28 : constant Interrupt_ID := OS.Interrupt_ID_28; + Interrupt_ID_29 : constant Interrupt_ID := OS.Interrupt_ID_29; + Interrupt_ID_30 : constant Interrupt_ID := OS.Interrupt_ID_30; + Interrupt_ID_31 : constant Interrupt_ID := OS.Interrupt_ID_31; + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-vxworks.ads b/gcc/ada/a-intnam-vxworks.ads new file mode 100644 index 000000000..7a6e364a7 --- /dev/null +++ b/gcc/ada/a-intnam-vxworks.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VxWorks version of this package + +with System.OS_Interface; + +package Ada.Interrupts.Names is + + subtype Hardware_Interrupts is Interrupt_ID + range Interrupt_ID'First .. System.OS_Interface.Max_HW_Interrupt; + -- Range of values that can be used for hardware interrupts + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam.ads b/gcc/ada/a-intnam.ads new file mode 100644 index 000000000..e055d6aa1 --- /dev/null +++ b/gcc/ada/a-intnam.ads @@ -0,0 +1,29 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- The standard implementation of this spec contains only dummy interrupt +-- names. These dummy entries permit checking out code for correctness of +-- semantics, even if interrupts are not supported. + +-- For specific implementations that fully support interrupts, this package +-- spec is replaced by an implementation dependent version that defines the +-- interrupts available on the system. + +package Ada.Interrupts.Names is + + DUMMY_INTERRUPT_1 : constant Interrupt_ID := 1; + DUMMY_INTERRUPT_2 : constant Interrupt_ID := 2; + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intsig.adb b/gcc/ada/a-intsig.adb new file mode 100644 index 000000000..9470128b6 --- /dev/null +++ b/gcc/ada/a-intsig.adb @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . S I G N A L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2000-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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Interrupt_Management.Operations; + +package body Ada.Interrupts.Signal is + + ------------------------ + -- Generate_Interrupt -- + ------------------------ + + procedure Generate_Interrupt (Interrupt : Interrupt_ID) is + begin + System.Interrupt_Management.Operations.Interrupt_Self_Process + (System.Interrupt_Management.Interrupt_ID (Interrupt)); + end Generate_Interrupt; + +end Ada.Interrupts.Signal; diff --git a/gcc/ada/a-intsig.ads b/gcc/ada/a-intsig.ads new file mode 100644 index 000000000..9d98f9de3 --- /dev/null +++ b/gcc/ada/a-intsig.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . S I G N A L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-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 encapsulates the procedures for generating interrupts +-- by user programs and avoids importing low level children of System +-- (e.g. System.Interrupt_Management.Operations), or defining an interface +-- to complex system calls. + +package Ada.Interrupts.Signal is + + procedure Generate_Interrupt (Interrupt : Interrupt_ID); + -- Generate interrupt at the process level + +end Ada.Interrupts.Signal; diff --git a/gcc/ada/a-ioexce.ads b/gcc/ada/a-ioexce.ads new file mode 100644 index 000000000..44865ab66 --- /dev/null +++ b/gcc/ada/a-ioexce.ads @@ -0,0 +1,30 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . I O _ E X C E P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit; + +package Ada.IO_Exceptions is + pragma Pure; + + Status_Error : exception; + Mode_Error : exception; + Name_Error : exception; + Use_Error : exception; + Device_Error : exception; + End_Error : exception; + Data_Error : exception; + Layout_Error : exception; + +end Ada.IO_Exceptions; diff --git a/gcc/ada/a-iwteio.ads b/gcc/ada/a-iwteio.ads new file mode 100644 index 000000000..dc53046ea --- /dev/null +++ b/gcc/ada/a-iwteio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . I N T E G E R _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Integer_Wide_Text_IO is + new Ada.Wide_Text_IO.Integer_IO (Integer); diff --git a/gcc/ada/a-izteio.ads b/gcc/ada/a-izteio.ads new file mode 100755 index 000000000..8eb5466d8 --- /dev/null +++ b/gcc/ada/a-izteio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . I N T E G E R _ W I D E _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Integer_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Integer_IO (Integer); diff --git a/gcc/ada/a-lcteio.ads b/gcc/ada/a-lcteio.ads new file mode 100755 index 000000000..f9da97c8d --- /dev/null +++ b/gcc/ada/a-lcteio.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ C O M P L E X _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Ada 2005 AI-328 + +with Ada.Text_IO.Complex_IO; +with Ada.Numerics.Long_Complex_Types; + +pragma Elaborate_All (Ada.Text_IO.Complex_IO); + +package Ada.Long_Complex_Text_IO is + new Ada.Text_IO.Complex_IO (Ada.Numerics.Long_Complex_Types); diff --git a/gcc/ada/a-lfteio.ads b/gcc/ada/a-lfteio.ads new file mode 100644 index 000000000..1477047e3 --- /dev/null +++ b/gcc/ada/a-lfteio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ F L O A T _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Long_Float_Text_IO is + new Ada.Text_IO.Float_IO (Long_Float); diff --git a/gcc/ada/a-lfwtio.ads b/gcc/ada/a-lfwtio.ads new file mode 100644 index 000000000..86361414e --- /dev/null +++ b/gcc/ada/a-lfwtio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ F L O A T _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Long_Float_Wide_Text_IO is + new Ada.Wide_Text_IO.Float_IO (Long_Float); diff --git a/gcc/ada/a-lfztio.ads b/gcc/ada/a-lfztio.ads new file mode 100644 index 000000000..f1719b148 --- /dev/null +++ b/gcc/ada/a-lfztio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ F L O A T _ W I D E _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Long_Float_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Float_IO (Long_Float); diff --git a/gcc/ada/a-liteio.ads b/gcc/ada/a-liteio.ads new file mode 100644 index 000000000..535f6b0d5 --- /dev/null +++ b/gcc/ada/a-liteio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ I N T E G E R _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Long_Integer_Text_IO is + new Ada.Text_IO.Integer_IO (Long_Integer); diff --git a/gcc/ada/a-liwtio.ads b/gcc/ada/a-liwtio.ads new file mode 100644 index 000000000..56fad9a67 --- /dev/null +++ b/gcc/ada/a-liwtio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ I N T E G E R _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Long_Integer_Wide_Text_IO is + new Ada.Wide_Text_IO.Integer_IO (Long_Integer); diff --git a/gcc/ada/a-liztio.ads b/gcc/ada/a-liztio.ads new file mode 100644 index 000000000..100ef0a6a --- /dev/null +++ b/gcc/ada/a-liztio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ I N T E G E R _ W I D E _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Long_Integer_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Integer_IO (Long_Integer); diff --git a/gcc/ada/a-llctio.ads b/gcc/ada/a-llctio.ads new file mode 100755 index 000000000..3b53bf7c7 --- /dev/null +++ b/gcc/ada/a-llctio.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ L O N G _ C O M P L E X _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Ada 2005 AI-328 + +with Ada.Text_IO.Complex_IO; +with Ada.Numerics.Long_Long_Complex_Types; + +pragma Elaborate_All (Ada.Text_IO.Complex_IO); + +package Ada.Long_Long_Complex_Text_IO is + new Ada.Text_IO.Complex_IO (Ada.Numerics.Long_Long_Complex_Types); diff --git a/gcc/ada/a-llftio.ads b/gcc/ada/a-llftio.ads new file mode 100644 index 000000000..589232d02 --- /dev/null +++ b/gcc/ada/a-llftio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ L O N G _ F L O A T _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Long_Long_Float_Text_IO is + new Ada.Text_IO.Float_IO (Long_Long_Float); diff --git a/gcc/ada/a-llfwti.ads b/gcc/ada/a-llfwti.ads new file mode 100644 index 000000000..b26aecdb9 --- /dev/null +++ b/gcc/ada/a-llfwti.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ L O N G _ F L O A T _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Long_Long_Float_Wide_Text_IO is + new Ada.Wide_Text_IO.Float_IO (Long_Long_Float); diff --git a/gcc/ada/a-llfzti.ads b/gcc/ada/a-llfzti.ads new file mode 100644 index 000000000..6bc9792f3 --- /dev/null +++ b/gcc/ada/a-llfzti.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.LONG_LONG_FLOAT_WIDE_WIDE_TEXT_IO -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Long_Long_Float_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Float_IO (Long_Long_Float); diff --git a/gcc/ada/a-llitio.ads b/gcc/ada/a-llitio.ads new file mode 100644 index 000000000..e1537276d --- /dev/null +++ b/gcc/ada/a-llitio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ L O N G _ I N T E G E R _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Long_Long_Integer_Text_IO is + new Ada.Text_IO.Integer_IO (Long_Long_Integer); diff --git a/gcc/ada/a-lliwti.ads b/gcc/ada/a-lliwti.ads new file mode 100644 index 000000000..13a0f2143 --- /dev/null +++ b/gcc/ada/a-lliwti.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ L O N G _ I N T E G E R _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Long_Long_Integer_Wide_Text_IO is + new Ada.Wide_Text_IO.Integer_IO (Long_Long_Integer); diff --git a/gcc/ada/a-llizti.ads b/gcc/ada/a-llizti.ads new file mode 100644 index 000000000..09d3219f3 --- /dev/null +++ b/gcc/ada/a-llizti.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ L O N G _ I N T E G E R _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Long_Long_Integer_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Integer_IO (Long_Long_Integer); diff --git a/gcc/ada/a-locale.adb b/gcc/ada/a-locale.adb new file mode 100644 index 000000000..d56970c86 --- /dev/null +++ b/gcc/ada/a-locale.adb @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O C A L E S -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; + +package body Ada.Locales is + + type Lower_4 is array (1 .. 4) of Character range 'a' .. 'z'; + type Upper_4 is array (1 .. 4) of Character range 'A' .. 'Z'; + + -------------- + -- Language -- + -------------- + + function Language return Language_Code is + procedure C_Get_Language_Code (P : Address); + pragma Import (C, C_Get_Language_Code); + F : Lower_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 : Upper_4; + begin + C_Get_Country_Code (F'Address); + return Country_Code (F (1 .. 2)); + end Country; + +end Ada.Locales; diff --git a/gcc/ada/a-locale.ads b/gcc/ada/a-locale.ads new file mode 100644 index 000000000..629f367bb --- /dev/null +++ b/gcc/ada/a-locale.ads @@ -0,0 +1,31 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O C A L E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2010, 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.Locales is + pragma Preelaborate (Locales); + pragma Remote_Types (Locales); + + type Language_Code is array (1 .. 3) of Character range 'a' .. 'z'; + type Country_Code is array (1 .. 2) of Character range 'A' .. 'Z'; + + Language_Unknown : constant Language_Code := "und"; + Country_Unknown : constant Country_Code := "ZZ"; + + function Language return Language_Code; + function Country return Country_Code; + +end Ada.Locales; diff --git a/gcc/ada/a-ncelfu.ads b/gcc/ada/a-ncelfu.ads new file mode 100644 index 000000000..e81730f08 --- /dev/null +++ b/gcc/ada/a-ncelfu.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.GENERIC_COMPLEX.ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Complex_Types; +with Ada.Numerics.Generic_Complex_Elementary_Functions; + +package Ada.Numerics.Complex_Elementary_Functions is + new Ada.Numerics.Generic_Complex_Elementary_Functions + (Ada.Numerics.Complex_Types); + +pragma Pure (Ada.Numerics.Complex_Elementary_Functions); diff --git a/gcc/ada/a-ngcefu.adb b/gcc/ada/a-ngcefu.adb new file mode 100644 index 000000000..edcdb5a72 --- /dev/null +++ b/gcc/ada/a-ngcefu.adb @@ -0,0 +1,708 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.GENERIC_COMPLEX_ELEMENTARY_FUNCTIONS -- +-- -- +-- 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.Numerics.Generic_Elementary_Functions; + +package body Ada.Numerics.Generic_Complex_Elementary_Functions is + + package Elementary_Functions is new + Ada.Numerics.Generic_Elementary_Functions (Real'Base); + use Elementary_Functions; + + PI : constant := 3.14159_26535_89793_23846_26433_83279_50288_41971; + PI_2 : constant := PI / 2.0; + Sqrt_Two : constant := 1.41421_35623_73095_04880_16887_24209_69807_85696; + Log_Two : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755; + + subtype T is Real'Base; + + Epsilon : constant T := 2.0 ** (1 - T'Model_Mantissa); + Square_Root_Epsilon : constant T := Sqrt_Two ** (1 - T'Model_Mantissa); + Inv_Square_Root_Epsilon : constant T := Sqrt_Two ** (T'Model_Mantissa - 1); + Root_Root_Epsilon : constant T := Sqrt_Two ** + ((1 - T'Model_Mantissa) / 2); + Log_Inverse_Epsilon_2 : constant T := T (T'Model_Mantissa - 1) / 2.0; + + Complex_Zero : constant Complex := (0.0, 0.0); + Complex_One : constant Complex := (1.0, 0.0); + Complex_I : constant Complex := (0.0, 1.0); + Half_Pi : constant Complex := (PI_2, 0.0); + + -------- + -- ** -- + -------- + + function "**" (Left : Complex; Right : Complex) return Complex is + begin + if Re (Right) = 0.0 + and then Im (Right) = 0.0 + and then Re (Left) = 0.0 + and then Im (Left) = 0.0 + then + raise Argument_Error; + + elsif Re (Left) = 0.0 + and then Im (Left) = 0.0 + and then Re (Right) < 0.0 + then + raise Constraint_Error; + + elsif Re (Left) = 0.0 and then Im (Left) = 0.0 then + return Left; + + elsif Right = (0.0, 0.0) then + return Complex_One; + + elsif Re (Right) = 0.0 and then Im (Right) = 0.0 then + return 1.0 + Right; + + elsif Re (Right) = 1.0 and then Im (Right) = 0.0 then + return Left; + + else + return Exp (Right * Log (Left)); + end if; + end "**"; + + function "**" (Left : Real'Base; Right : Complex) return Complex is + begin + if Re (Right) = 0.0 and then Im (Right) = 0.0 and then Left = 0.0 then + raise Argument_Error; + + elsif Left = 0.0 and then Re (Right) < 0.0 then + raise Constraint_Error; + + elsif Left = 0.0 then + return Compose_From_Cartesian (Left, 0.0); + + elsif Re (Right) = 0.0 and then Im (Right) = 0.0 then + return Complex_One; + + elsif Re (Right) = 1.0 and then Im (Right) = 0.0 then + return Compose_From_Cartesian (Left, 0.0); + + else + return Exp (Log (Left) * Right); + end if; + end "**"; + + function "**" (Left : Complex; Right : Real'Base) return Complex is + begin + if Right = 0.0 + and then Re (Left) = 0.0 + and then Im (Left) = 0.0 + then + raise Argument_Error; + + elsif Re (Left) = 0.0 + and then Im (Left) = 0.0 + and then Right < 0.0 + then + raise Constraint_Error; + + elsif Re (Left) = 0.0 and then Im (Left) = 0.0 then + return Left; + + elsif Right = 0.0 then + return Complex_One; + + elsif Right = 1.0 then + return Left; + + else + return Exp (Right * Log (Left)); + end if; + end "**"; + + ------------ + -- Arccos -- + ------------ + + function Arccos (X : Complex) return Complex is + Result : Complex; + + begin + if X = Complex_One then + return Complex_Zero; + + elsif abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return Half_Pi - X; + + elsif abs Re (X) > Inv_Square_Root_Epsilon or else + abs Im (X) > Inv_Square_Root_Epsilon + then + return -2.0 * Complex_I * Log (Sqrt ((1.0 + X) / 2.0) + + Complex_I * Sqrt ((1.0 - X) / 2.0)); + end if; + + Result := -Complex_I * Log (X + Complex_I * Sqrt (1.0 - X * X)); + + if Im (X) = 0.0 + and then abs Re (X) <= 1.00 + then + Set_Im (Result, Im (X)); + end if; + + return Result; + end Arccos; + + ------------- + -- Arccosh -- + ------------- + + function Arccosh (X : Complex) return Complex is + Result : Complex; + + begin + if X = Complex_One then + return Complex_Zero; + + elsif abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + Result := Compose_From_Cartesian (-Im (X), -PI_2 + Re (X)); + + elsif abs Re (X) > Inv_Square_Root_Epsilon or else + abs Im (X) > Inv_Square_Root_Epsilon + then + Result := Log_Two + Log (X); + + else + Result := 2.0 * Log (Sqrt ((1.0 + X) / 2.0) + + Sqrt ((X - 1.0) / 2.0)); + end if; + + if Re (Result) <= 0.0 then + Result := -Result; + end if; + + return Result; + end Arccosh; + + ------------ + -- Arccot -- + ------------ + + function Arccot (X : Complex) return Complex is + Xt : Complex; + + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return Half_Pi - X; + + elsif abs Re (X) > 1.0 / Epsilon or else + abs Im (X) > 1.0 / Epsilon + then + Xt := Complex_One / X; + + if Re (X) < 0.0 then + Set_Re (Xt, PI - Re (Xt)); + return Xt; + else + return Xt; + end if; + end if; + + Xt := Complex_I * Log ((X - Complex_I) / (X + Complex_I)) / 2.0; + + if Re (Xt) < 0.0 then + Xt := PI + Xt; + end if; + + return Xt; + end Arccot; + + -------------- + -- Arccoth -- + -------------- + + function Arccoth (X : Complex) return Complex is + R : Complex; + + begin + if X = (0.0, 0.0) then + return Compose_From_Cartesian (0.0, PI_2); + + elsif abs Re (X) < Square_Root_Epsilon + and then abs Im (X) < Square_Root_Epsilon + then + return PI_2 * Complex_I + X; + + elsif abs Re (X) > 1.0 / Epsilon or else + abs Im (X) > 1.0 / Epsilon + then + if Im (X) > 0.0 then + return (0.0, 0.0); + else + return PI * Complex_I; + end if; + + elsif Im (X) = 0.0 and then Re (X) = 1.0 then + raise Constraint_Error; + + elsif Im (X) = 0.0 and then Re (X) = -1.0 then + raise Constraint_Error; + end if; + + begin + R := Log ((1.0 + X) / (X - 1.0)) / 2.0; + + exception + when Constraint_Error => + R := (Log (1.0 + X) - Log (X - 1.0)) / 2.0; + end; + + if Im (R) < 0.0 then + Set_Im (R, PI + Im (R)); + end if; + + if Re (X) = 0.0 then + Set_Re (R, Re (X)); + end if; + + return R; + end Arccoth; + + ------------ + -- Arcsin -- + ------------ + + function Arcsin (X : Complex) return Complex is + Result : Complex; + + begin + -- For very small argument, sin (x) = x + + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return X; + + elsif abs Re (X) > Inv_Square_Root_Epsilon or else + abs Im (X) > Inv_Square_Root_Epsilon + then + Result := -Complex_I * (Log (Complex_I * X) + Log (2.0 * Complex_I)); + + if Im (Result) > PI_2 then + Set_Im (Result, PI - Im (X)); + + elsif Im (Result) < -PI_2 then + Set_Im (Result, -(PI + Im (X))); + end if; + + return Result; + end if; + + Result := -Complex_I * Log (Complex_I * X + Sqrt (1.0 - X * X)); + + if Re (X) = 0.0 then + Set_Re (Result, Re (X)); + + elsif Im (X) = 0.0 + and then abs Re (X) <= 1.00 + then + Set_Im (Result, Im (X)); + end if; + + return Result; + end Arcsin; + + ------------- + -- Arcsinh -- + ------------- + + function Arcsinh (X : Complex) return Complex is + Result : Complex; + + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return X; + + elsif abs Re (X) > Inv_Square_Root_Epsilon or else + abs Im (X) > Inv_Square_Root_Epsilon + then + Result := Log_Two + Log (X); -- may have wrong sign + + if (Re (X) < 0.0 and then Re (Result) > 0.0) + or else (Re (X) > 0.0 and then Re (Result) < 0.0) + then + Set_Re (Result, -Re (Result)); + end if; + + return Result; + end if; + + Result := Log (X + Sqrt (1.0 + X * X)); + + if Re (X) = 0.0 then + Set_Re (Result, Re (X)); + elsif Im (X) = 0.0 then + Set_Im (Result, Im (X)); + end if; + + return Result; + end Arcsinh; + + ------------ + -- Arctan -- + ------------ + + function Arctan (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return X; + + else + return -Complex_I * (Log (1.0 + Complex_I * X) + - Log (1.0 - Complex_I * X)) / 2.0; + end if; + end Arctan; + + ------------- + -- Arctanh -- + ------------- + + function Arctanh (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return X; + else + return (Log (1.0 + X) - Log (1.0 - X)) / 2.0; + end if; + end Arctanh; + + --------- + -- Cos -- + --------- + + function Cos (X : Complex) return Complex is + begin + return + Compose_From_Cartesian + (Cos (Re (X)) * Cosh (Im (X)), + -(Sin (Re (X)) * Sinh (Im (X)))); + end Cos; + + ---------- + -- Cosh -- + ---------- + + function Cosh (X : Complex) return Complex is + begin + return + Compose_From_Cartesian + (Cosh (Re (X)) * Cos (Im (X)), + Sinh (Re (X)) * Sin (Im (X))); + end Cosh; + + --------- + -- Cot -- + --------- + + function Cot (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return Complex_One / X; + + elsif Im (X) > Log_Inverse_Epsilon_2 then + return -Complex_I; + + elsif Im (X) < -Log_Inverse_Epsilon_2 then + return Complex_I; + end if; + + return Cos (X) / Sin (X); + end Cot; + + ---------- + -- Coth -- + ---------- + + function Coth (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return Complex_One / X; + + elsif Re (X) > Log_Inverse_Epsilon_2 then + return Complex_One; + + elsif Re (X) < -Log_Inverse_Epsilon_2 then + return -Complex_One; + + else + return Cosh (X) / Sinh (X); + end if; + end Coth; + + --------- + -- Exp -- + --------- + + function Exp (X : Complex) return Complex is + EXP_RE_X : constant Real'Base := Exp (Re (X)); + + begin + return Compose_From_Cartesian (EXP_RE_X * Cos (Im (X)), + EXP_RE_X * Sin (Im (X))); + end Exp; + + function Exp (X : Imaginary) return Complex is + ImX : constant Real'Base := Im (X); + + begin + return Compose_From_Cartesian (Cos (ImX), Sin (ImX)); + end Exp; + + --------- + -- Log -- + --------- + + function Log (X : Complex) return Complex is + ReX : Real'Base; + ImX : Real'Base; + Z : Complex; + + begin + if Re (X) = 0.0 and then Im (X) = 0.0 then + raise Constraint_Error; + + elsif abs (1.0 - Re (X)) < Root_Root_Epsilon + and then abs Im (X) < Root_Root_Epsilon + then + Z := X; + Set_Re (Z, Re (Z) - 1.0); + + return (1.0 - (1.0 / 2.0 - + (1.0 / 3.0 - (1.0 / 4.0) * Z) * Z) * Z) * Z; + end if; + + begin + ReX := Log (Modulus (X)); + + exception + when Constraint_Error => + ReX := Log (Modulus (X / 2.0)) - Log_Two; + end; + + ImX := Arctan (Im (X), Re (X)); + + if ImX > PI then + ImX := ImX - 2.0 * PI; + end if; + + return Compose_From_Cartesian (ReX, ImX); + end Log; + + --------- + -- Sin -- + --------- + + function Sin (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon then + return X; + end if; + + return + Compose_From_Cartesian + (Sin (Re (X)) * Cosh (Im (X)), + Cos (Re (X)) * Sinh (Im (X))); + end Sin; + + ---------- + -- Sinh -- + ---------- + + function Sinh (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return X; + + else + return Compose_From_Cartesian (Sinh (Re (X)) * Cos (Im (X)), + Cosh (Re (X)) * Sin (Im (X))); + end if; + end Sinh; + + ---------- + -- Sqrt -- + ---------- + + function Sqrt (X : Complex) return Complex is + ReX : constant Real'Base := Re (X); + ImX : constant Real'Base := Im (X); + XR : constant Real'Base := abs Re (X); + YR : constant Real'Base := abs Im (X); + R : Real'Base; + R_X : Real'Base; + R_Y : Real'Base; + + begin + -- Deal with pure real case, see (RM G.1.2(39)) + + if ImX = 0.0 then + if ReX > 0.0 then + return + Compose_From_Cartesian + (Sqrt (ReX), 0.0); + + elsif ReX = 0.0 then + return X; + + else + return + Compose_From_Cartesian + (0.0, Real'Copy_Sign (Sqrt (-ReX), ImX)); + end if; + + elsif ReX = 0.0 then + R_X := Sqrt (YR / 2.0); + + if ImX > 0.0 then + return Compose_From_Cartesian (R_X, R_X); + else + return Compose_From_Cartesian (R_X, -R_X); + end if; + + else + R := Sqrt (XR ** 2 + YR ** 2); + + -- If the square of the modulus overflows, try rescaling the + -- real and imaginary parts. We cannot depend on an exception + -- being raised on all targets. + + if R > Real'Base'Last then + raise Constraint_Error; + end if; + + -- We are solving the system + + -- XR = R_X ** 2 - Y_R ** 2 (1) + -- YR = 2.0 * R_X * R_Y (2) + -- + -- The symmetric solution involves square roots for both R_X and + -- R_Y, but it is more accurate to use the square root with the + -- larger argument for either R_X or R_Y, and equation (2) for the + -- other. + + if ReX < 0.0 then + R_Y := Sqrt (0.5 * (R - ReX)); + R_X := YR / (2.0 * R_Y); + + else + R_X := Sqrt (0.5 * (R + ReX)); + R_Y := YR / (2.0 * R_X); + end if; + end if; + + if Im (X) < 0.0 then -- halve angle, Sqrt of magnitude + R_Y := -R_Y; + end if; + return Compose_From_Cartesian (R_X, R_Y); + + exception + when Constraint_Error => + + -- Rescale and try again + + R := Modulus (Compose_From_Cartesian (Re (X / 4.0), Im (X / 4.0))); + R_X := 2.0 * Sqrt (0.5 * R + 0.5 * Re (X / 4.0)); + R_Y := 2.0 * Sqrt (0.5 * R - 0.5 * Re (X / 4.0)); + + if Im (X) < 0.0 then -- halve angle, Sqrt of magnitude + R_Y := -R_Y; + end if; + + return Compose_From_Cartesian (R_X, R_Y); + end Sqrt; + + --------- + -- Tan -- + --------- + + function Tan (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return X; + + elsif Im (X) > Log_Inverse_Epsilon_2 then + return Complex_I; + + elsif Im (X) < -Log_Inverse_Epsilon_2 then + return -Complex_I; + + else + return Sin (X) / Cos (X); + end if; + end Tan; + + ---------- + -- Tanh -- + ---------- + + function Tanh (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return X; + + elsif Re (X) > Log_Inverse_Epsilon_2 then + return Complex_One; + + elsif Re (X) < -Log_Inverse_Epsilon_2 then + return -Complex_One; + + else + return Sinh (X) / Cosh (X); + end if; + end Tanh; + +end Ada.Numerics.Generic_Complex_Elementary_Functions; diff --git a/gcc/ada/a-ngcefu.ads b/gcc/ada/a-ngcefu.ads new file mode 100644 index 000000000..576c84ab2 --- /dev/null +++ b/gcc/ada/a-ngcefu.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.GENERIC_COMPLEX_ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; +generic + with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (<>); + use Complex_Types; + +package Ada.Numerics.Generic_Complex_Elementary_Functions is + pragma Pure; + + function Sqrt (X : Complex) return Complex; + + function Log (X : Complex) return Complex; + + function Exp (X : Complex) return Complex; + function Exp (X : Imaginary) return Complex; + + function "**" (Left : Complex; Right : Complex) return Complex; + function "**" (Left : Complex; Right : Real'Base) return Complex; + function "**" (Left : Real'Base; Right : Complex) return Complex; + + function Sin (X : Complex) return Complex; + function Cos (X : Complex) return Complex; + function Tan (X : Complex) return Complex; + function Cot (X : Complex) return Complex; + + function Arcsin (X : Complex) return Complex; + function Arccos (X : Complex) return Complex; + function Arctan (X : Complex) return Complex; + function Arccot (X : Complex) return Complex; + + function Sinh (X : Complex) return Complex; + function Cosh (X : Complex) return Complex; + function Tanh (X : Complex) return Complex; + function Coth (X : Complex) return Complex; + + function Arcsinh (X : Complex) return Complex; + function Arccosh (X : Complex) return Complex; + function Arctanh (X : Complex) return Complex; + function Arccoth (X : Complex) return Complex; + +end Ada.Numerics.Generic_Complex_Elementary_Functions; diff --git a/gcc/ada/a-ngcoar.adb b/gcc/ada/a-ngcoar.adb new file mode 100644 index 000000000..9979d6bae --- /dev/null +++ b/gcc/ada/a-ngcoar.adb @@ -0,0 +1,1502 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- ADA.NUMERICS.GENERIC_COMPLEX_ARRAYS -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Generic_Array_Operations; use System.Generic_Array_Operations; +with System.Generic_Complex_BLAS; +with System.Generic_Complex_LAPACK; + +package body Ada.Numerics.Generic_Complex_Arrays is + + -- Operations involving inner products use BLAS library implementations. + -- This allows larger matrices and vectors to be computed efficiently, + -- taking into account memory hierarchy issues and vector instructions + -- that vary widely between machines. + + -- 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. + + -- Operations for solving linear systems and computing determinant, + -- eigenvalues, eigensystem and inverse, are implemented using the + -- LAPACK library. + + type BLAS_Real_Vector is array (Integer range <>) of Real; + + package BLAS is new System.Generic_Complex_BLAS + (Real => Real, + Complex_Types => Complex_Types, + Complex_Vector => Complex_Vector, + Complex_Matrix => Complex_Matrix); + + package LAPACK is new System.Generic_Complex_LAPACK + (Real => Real, + Real_Vector => BLAS_Real_Vector, + Complex_Types => Complex_Types, + Complex_Vector => Complex_Vector, + Complex_Matrix => Complex_Matrix); + + subtype Real is Real_Arrays.Real; + -- Work around visibility bug ??? + + use BLAS, LAPACK; + + -- Procedure versions of functions returning unconstrained values. + -- This allows for inlining the function wrapper. + + procedure Eigenvalues + (A : Complex_Matrix; + Values : out Real_Vector); + + procedure Inverse + (A : Complex_Matrix; + R : out Complex_Matrix); + + procedure Solve + (A : Complex_Matrix; + X : Complex_Vector; + B : out Complex_Vector); + + procedure Solve + (A : Complex_Matrix; + X : Complex_Matrix; + B : out Complex_Matrix); + + procedure Transpose is new System.Generic_Array_Operations.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); + + -- 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 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 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 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 => "/"); + + -------------- + -- 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); + + ----------------- + -- 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 + is + begin + if Left'Length /= Right'Length then + raise Constraint_Error with + "vectors are of different length in inner product"; + end if; + + return dot (Left'Length, X => Left, Y => Right); + end "*"; + + 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 + is + R : Complex_Matrix (Left'Range (1), Right'Range (2)); + + begin + if Left'Length (2) /= Right'Length (1) then + raise Constraint_Error with + "incompatible dimensions in matrix-matrix multiplication"; + end if; + + gemm (Trans_A => No_Trans'Access, + Trans_B => No_Trans'Access, + M => Right'Length (2), + N => Left'Length (1), + K => Right'Length (1), + A => Right, + Ld_A => Right'Length (2), + B => Left, + Ld_B => Left'Length (2), + C => R, + Ld_C => R'Length (2)); + + return R; + end "*"; + + function "*" + (Left : Complex_Vector; + Right : Complex_Vector) return Complex_Matrix + renames Instantiations."*"; + + function "*" + (Left : Complex_Vector; + Right : Complex_Matrix) return Complex_Vector + is + R : Complex_Vector (Right'Range (2)); + + begin + if Left'Length /= Right'Length (1) then + raise Constraint_Error with + "incompatible dimensions in vector-matrix multiplication"; + end if; + + gemv (Trans => No_Trans'Access, + M => Right'Length (2), + N => Right'Length (1), + A => Right, + Ld_A => Right'Length (2), + X => Left, + Y => R); + + return R; + end "*"; + + function "*" + (Left : Complex_Matrix; + Right : Complex_Vector) return Complex_Vector + is + R : Complex_Vector (Left'Range (1)); + + begin + if Left'Length (2) /= Right'Length then + raise Constraint_Error with + "incompatible dimensions in matrix-vector multiplication"; + end if; + + gemv (Trans => Trans'Access, + M => Left'Length (2), + N => Left'Length (1), + A => Left, + Ld_A => Left'Length (2), + X => Right, + Y => R); + + return R; + end "*"; + + 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 Complex is + begin + return (nrm2 (Right'Length, Right), 0.0); + end "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 + N : constant Integer := Length (A); + LU : Complex_Matrix (1 .. N, 1 .. N) := A; + Piv : Integer_Vector (1 .. N); + Info : aliased Integer := -1; + Neg : Boolean; + Det : Complex; + + begin + if N = 0 then + return (0.0, 0.0); + end if; + + getrf (N, N, LU, N, Piv, Info'Access); + + if Info /= 0 then + raise Constraint_Error with "ill-conditioned matrix"; + end if; + + Det := LU (1, 1); + Neg := Piv (1) /= 1; + + for J in 2 .. N loop + Det := Det * LU (J, J); + Neg := Neg xor (Piv (J) /= J); + end loop; + + if Neg then + return -Det; + + else + return Det; + end if; + end Determinant; + + ----------------- + -- Eigensystem -- + ----------------- + + procedure Eigensystem + (A : Complex_Matrix; + Values : out Real_Vector; + Vectors : out Complex_Matrix) + is + Job_Z : aliased Character := 'V'; + Rng : aliased Character := 'A'; + Uplo : aliased Character := 'U'; + + N : constant Natural := Length (A); + W : BLAS_Real_Vector (Values'Range); + M : Integer; + B : Complex_Matrix (1 .. N, 1 .. N); + L_Work : Complex_Vector (1 .. 1); + LR_Work : BLAS_Real_Vector (1 .. 1); + LI_Work : Integer_Vector (1 .. 1); + I_Supp_Z : Integer_Vector (1 .. 2 * N); + Info : aliased Integer; + + begin + if Values'Length /= N then + raise Constraint_Error with "wrong length for output vector"; + end if; + + if Vectors'First (1) /= A'First (1) + or else Vectors'Last (1) /= A'Last (1) + or else Vectors'First (2) /= A'First (2) + or else Vectors'Last (2) /= A'Last (2) + then + raise Constraint_Error with "wrong dimensions for output matrix"; + end if; + + if N = 0 then + return; + end if; + + -- Check for hermitian matrix ??? + -- Copy only required triangle ??? + + B := A; + + -- Find size of work area + + heevr + (Job_Z'Access, Rng'Access, Uplo'Access, N, B, N, + M => M, + W => W, + Z => Vectors, + Ld_Z => N, + I_Supp_Z => I_Supp_Z, + Work => L_Work, + L_Work => -1, + R_Work => LR_Work, + LR_Work => -1, + I_Work => LI_Work, + LI_Work => -1, + Info => Info'Access); + + if Info /= 0 then + raise Constraint_Error; + end if; + + declare + Work : Complex_Vector (1 .. Integer (L_Work (1).Re)); + R_Work : BLAS_Real_Vector (1 .. Integer (LR_Work (1))); + I_Work : Integer_Vector (1 .. LI_Work (1)); + + begin + heevr + (Job_Z'Access, Rng'Access, Uplo'Access, N, B, N, + M => M, + W => W, + Z => Vectors, + Ld_Z => N, + I_Supp_Z => I_Supp_Z, + Work => Work, + L_Work => Work'Length, + R_Work => R_Work, + LR_Work => LR_Work'Length, + I_Work => I_Work, + LI_Work => LI_Work'Length, + Info => Info'Access); + + if Info /= 0 then + raise Constraint_Error with "inverting non-Hermitian matrix"; + end if; + + for J in Values'Range loop + Values (J) := W (J); + end loop; + end; + end Eigensystem; + + ----------------- + -- Eigenvalues -- + ----------------- + + procedure Eigenvalues + (A : Complex_Matrix; + Values : out Real_Vector) + is + Job_Z : aliased Character := 'N'; + Rng : aliased Character := 'A'; + Uplo : aliased Character := 'U'; + N : constant Natural := Length (A); + B : Complex_Matrix (1 .. N, 1 .. N) := A; + Z : Complex_Matrix (1 .. 1, 1 .. 1); + W : BLAS_Real_Vector (Values'Range); + L_Work : Complex_Vector (1 .. 1); + LR_Work : BLAS_Real_Vector (1 .. 1); + LI_Work : Integer_Vector (1 .. 1); + I_Supp_Z : Integer_Vector (1 .. 2 * N); + M : Integer; + Info : aliased Integer; + + begin + if Values'Length /= N then + raise Constraint_Error with "wrong length for output vector"; + end if; + + if N = 0 then + return; + end if; + + -- Check for hermitian matrix ??? + + -- Find size of work area + + heevr (Job_Z'Access, Rng'Access, Uplo'Access, N, B, N, + M => M, + W => W, + Z => Z, + Ld_Z => 1, + I_Supp_Z => I_Supp_Z, + Work => L_Work, L_Work => -1, + R_Work => LR_Work, LR_Work => -1, + I_Work => LI_Work, LI_Work => -1, + Info => Info'Access); + + if Info /= 0 then + raise Constraint_Error; + end if; + + declare + Work : Complex_Vector (1 .. Integer (L_Work (1).Re)); + R_Work : BLAS_Real_Vector (1 .. Integer (LR_Work (1))); + I_Work : Integer_Vector (1 .. LI_Work (1)); + begin + heevr (Job_Z'Access, Rng'Access, Uplo'Access, N, B, N, + M => M, + W => W, + Z => Z, + Ld_Z => 1, + I_Supp_Z => I_Supp_Z, + Work => Work, L_Work => Work'Length, + R_Work => R_Work, LR_Work => R_Work'Length, + I_Work => I_Work, LI_Work => I_Work'Length, + Info => Info'Access); + + if Info /= 0 then + raise Constraint_Error with "inverting singular matrix"; + end if; + + for J in Values'Range loop + Values (J) := W (J); + end loop; + end; + end Eigenvalues; + + function Eigenvalues (A : Complex_Matrix) return Real_Vector is + R : Real_Vector (A'Range (1)); + begin + Eigenvalues (A, R); + 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 -- + ------------- + + procedure Inverse (A : Complex_Matrix; R : out Complex_Matrix) is + N : constant Integer := Length (A); + Piv : Integer_Vector (1 .. N); + L_Work : Complex_Vector (1 .. 1); + Info : aliased Integer := -1; + + begin + -- All computations are done using column-major order, but this works + -- out fine, because Transpose (Inverse (Transpose (A))) = Inverse (A). + + R := A; + + -- Compute LU decomposition + + getrf (M => N, + N => N, + A => R, + Ld_A => N, + I_Piv => Piv, + Info => Info'Access); + + if Info /= 0 then + raise Constraint_Error with "inverting singular matrix"; + end if; + + -- Determine size of work area + + getri (N => N, + A => R, + Ld_A => N, + I_Piv => Piv, + Work => L_Work, + L_Work => -1, + Info => Info'Access); + + if Info /= 0 then + raise Constraint_Error; + end if; + + declare + Work : Complex_Vector (1 .. Integer (L_Work (1).Re)); + + begin + -- Compute inverse from LU decomposition + + getri (N => N, + A => R, + Ld_A => N, + I_Piv => Piv, + Work => Work, + L_Work => Work'Length, + Info => Info'Access); + + if Info /= 0 then + raise Constraint_Error with "inverting singular matrix"; + end if; + + -- ??? Should iterate with gerfs, based on implementation advice + end; + end Inverse; + + function Inverse (A : Complex_Matrix) return Complex_Matrix is + R : Complex_Matrix (A'Range (2), A'Range (1)); + begin + Inverse (A, R); + return R; + end Inverse; + + ------------- + -- 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 -- + ----------- + + procedure Solve + (A : Complex_Matrix; + X : Complex_Vector; + B : out Complex_Vector) + is + begin + if Length (A) /= X'Length then + raise Constraint_Error with + "incompatible matrix and vector dimensions"; + end if; + + -- ??? Should solve directly, is faster and more accurate + + B := Inverse (A) * X; + end Solve; + + procedure Solve + (A : Complex_Matrix; + X : Complex_Matrix; + B : out Complex_Matrix) + is + begin + if Length (A) /= X'Length (1) then + raise Constraint_Error with "incompatible matrix dimensions"; + end if; + + -- ??? Should solve directly, is faster and more accurate + + B := Inverse (A) * X; + end Solve; + + function Solve + (A : Complex_Matrix; + X : Complex_Vector) return Complex_Vector + is + B : Complex_Vector (A'Range (2)); + begin + Solve (A, X, B); + return B; + end Solve; + + function Solve (A, X : Complex_Matrix) return Complex_Matrix is + B : Complex_Matrix (A'Range (2), X'Range (2)); + begin + Solve (A, X, B); + return B; + end Solve; + + --------------- + -- Transpose -- + --------------- + + function Transpose + (X : Complex_Matrix) return Complex_Matrix + is + R : Complex_Matrix (X'Range (2), X'Range (1)); + begin + Transpose (X, R); + return R; + end Transpose; + + ----------------- + -- Unit_Matrix -- + ----------------- + + function Unit_Matrix + (Order : Positive; + First_1 : Integer := 1; + First_2 : Integer := 1) return Complex_Matrix + renames Instantiations.Unit_Matrix; + + ----------------- + -- Unit_Vector -- + ----------------- + + function Unit_Vector + (Index : Integer; + Order : Positive; + First : Integer := 1) return Complex_Vector + renames Instantiations.Unit_Vector; + +end Ada.Numerics.Generic_Complex_Arrays; diff --git a/gcc/ada/a-ngcoar.ads b/gcc/ada/a-ngcoar.ads new file mode 100644 index 000000000..abffbd1b6 --- /dev/null +++ b/gcc/ada/a-ngcoar.ads @@ -0,0 +1,281 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.GENERIC_COMPLEX_ARRAYS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Real_Arrays, Ada.Numerics.Generic_Complex_Types; + +generic + with package Real_Arrays is new Ada.Numerics.Generic_Real_Arrays (<>); + use Real_Arrays; + with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (Real); + use Complex_Types; +package Ada.Numerics.Generic_Complex_Arrays is + pragma Pure (Generic_Complex_Arrays); + + -- Types + + type Complex_Vector is array (Integer range <>) of Complex; + type Complex_Matrix is + array (Integer range <>, Integer range <>) of Complex; + + -- Subprograms for Complex_Vector types + -- Complex_Vector selection, conversion and composition operations + + function Re (X : Complex_Vector) return Real_Vector; + function Im (X : Complex_Vector) return Real_Vector; + + procedure Set_Re (X : in out Complex_Vector; Re : Real_Vector); + procedure Set_Im (X : in out Complex_Vector; Im : Real_Vector); + + function Compose_From_Cartesian + (Re : Real_Vector) return Complex_Vector; + function Compose_From_Cartesian + (Re, Im : Real_Vector) return Complex_Vector; + + function Modulus (X : Complex_Vector) return Real_Vector; + function "abs" (Right : Complex_Vector) return Real_Vector renames Modulus; + function Argument (X : Complex_Vector) return Real_Vector; + + function Argument + (X : Complex_Vector; + Cycle : Real'Base) return Real_Vector; + + function Compose_From_Polar + (Modulus, Argument : Real_Vector) return Complex_Vector; + + function Compose_From_Polar + (Modulus, Argument : Real_Vector; + Cycle : Real'Base) return Complex_Vector; + + -- Complex_Vector arithmetic operations + + function "+" (Right : Complex_Vector) return Complex_Vector; + function "-" (Right : Complex_Vector) return Complex_Vector; + function Conjugate (X : Complex_Vector) return Complex_Vector; + function "+" (Left, Right : Complex_Vector) return Complex_Vector; + function "-" (Left, Right : Complex_Vector) return Complex_Vector; + function "*" (Left, Right : Complex_Vector) return Complex; + function "abs" (Right : Complex_Vector) return Complex; + + -- Mixed Real_Vector and Complex_Vector arithmetic operations + + function "+" + (Left : Real_Vector; + Right : Complex_Vector) return Complex_Vector; + + function "+" + (Left : Complex_Vector; + Right : Real_Vector) return Complex_Vector; + + function "-" + (Left : Real_Vector; + Right : Complex_Vector) return Complex_Vector; + + function "-" + (Left : Complex_Vector; + Right : Real_Vector) return Complex_Vector; + + function "*" (Left : Real_Vector; Right : Complex_Vector) return Complex; + function "*" (Left : Complex_Vector; Right : Real_Vector) return Complex; + + -- Complex_Vector scaling operations + + function "*" + (Left : Complex; + Right : Complex_Vector) return Complex_Vector; + + function "*" + (Left : Complex_Vector; + Right : Complex) return Complex_Vector; + + function "/" + (Left : Complex_Vector; + Right : Complex) return Complex_Vector; + + function "*" + (Left : Real'Base; + Right : Complex_Vector) return Complex_Vector; + + function "*" + (Left : Complex_Vector; + Right : Real'Base) return Complex_Vector; + + function "/" + (Left : Complex_Vector; + Right : Real'Base) return Complex_Vector; + + -- Other Complex_Vector operations + + function Unit_Vector + (Index : Integer; + Order : Positive; + First : Integer := 1) return Complex_Vector; + + -- Subprograms for Complex_Matrix types + + -- Complex_Matrix selection, conversion and composition operations + + function Re (X : Complex_Matrix) return Real_Matrix; + function Im (X : Complex_Matrix) return Real_Matrix; + + procedure Set_Re (X : in out Complex_Matrix; Re : Real_Matrix); + procedure Set_Im (X : in out Complex_Matrix; Im : Real_Matrix); + + function Compose_From_Cartesian (Re : Real_Matrix) return Complex_Matrix; + + function Compose_From_Cartesian + (Re, Im : Real_Matrix) return Complex_Matrix; + + function Modulus (X : Complex_Matrix) return Real_Matrix; + function "abs" (Right : Complex_Matrix) return Real_Matrix renames Modulus; + + function Argument (X : Complex_Matrix) return Real_Matrix; + + function Argument + (X : Complex_Matrix; + Cycle : Real'Base) return Real_Matrix; + + function Compose_From_Polar + (Modulus, Argument : Real_Matrix) return Complex_Matrix; + + function Compose_From_Polar + (Modulus : Real_Matrix; + Argument : Real_Matrix; + Cycle : Real'Base) return Complex_Matrix; + + -- Complex_Matrix arithmetic operations + + function "+" (Right : Complex_Matrix) return Complex_Matrix; + function "-" (Right : Complex_Matrix) return Complex_Matrix; + + function Conjugate (X : Complex_Matrix) return Complex_Matrix; + function Transpose (X : Complex_Matrix) return Complex_Matrix; + + function "+" (Left, Right : Complex_Matrix) return Complex_Matrix; + function "-" (Left, Right : Complex_Matrix) return Complex_Matrix; + function "*" (Left, Right : Complex_Matrix) return Complex_Matrix; + function "*" (Left, Right : Complex_Vector) return Complex_Matrix; + + function "*" + (Left : Complex_Vector; + Right : Complex_Matrix) return Complex_Vector; + + function "*" + (Left : Complex_Matrix; + Right : Complex_Vector) return Complex_Vector; + + -- Mixed Real_Matrix and Complex_Matrix arithmetic operations + + function "+" + (Left : Real_Matrix; + Right : Complex_Matrix) return Complex_Matrix; + + function "+" + (Left : Complex_Matrix; + Right : Real_Matrix) return Complex_Matrix; + + function "-" + (Left : Real_Matrix; + Right : Complex_Matrix) return Complex_Matrix; + + function "-" + (Left : Complex_Matrix; + Right : Real_Matrix) return Complex_Matrix; + + function "*" + (Left : Real_Matrix; + Right : Complex_Matrix) return Complex_Matrix; + + function "*" + (Left : Complex_Matrix; + Right : Real_Matrix) return Complex_Matrix; + + function "*" + (Left : Real_Vector; + Right : Complex_Vector) return Complex_Matrix; + + function "*" + (Left : Complex_Vector; + Right : Real_Vector) return Complex_Matrix; + + function "*" + (Left : Real_Vector; + Right : Complex_Matrix) return Complex_Vector; + + function "*" + (Left : Complex_Vector; + Right : Real_Matrix) return Complex_Vector; + + function "*" + (Left : Real_Matrix; + Right : Complex_Vector) return Complex_Vector; + + function "*" + (Left : Complex_Matrix; + Right : Real_Vector) return Complex_Vector; + + -- Complex_Matrix scaling operations + + function "*" + (Left : Complex; + Right : Complex_Matrix) return Complex_Matrix; + + function "*" + (Left : Complex_Matrix; + Right : Complex) return Complex_Matrix; + + function "/" + (Left : Complex_Matrix; + Right : Complex) return Complex_Matrix; + + function "*" + (Left : Real'Base; + Right : Complex_Matrix) return Complex_Matrix; + + function "*" + (Left : Complex_Matrix; + Right : Real'Base) return Complex_Matrix; + + function "/" + (Left : Complex_Matrix; + Right : Real'Base) return Complex_Matrix; + + -- Complex_Matrix inversion and related operations + + function Solve + (A : Complex_Matrix; + X : Complex_Vector) return Complex_Vector; + + function Solve (A, X : Complex_Matrix) return Complex_Matrix; + + function Inverse (A : Complex_Matrix) return Complex_Matrix; + + function Determinant (A : Complex_Matrix) return Complex; + + -- Eigenvalues and vectors of a Hermitian matrix + + function Eigenvalues (A : Complex_Matrix) return Real_Vector; + + procedure Eigensystem + (A : Complex_Matrix; + Values : out Real_Vector; + Vectors : out Complex_Matrix); + + -- Other Complex_Matrix operations + + function Unit_Matrix + (Order : Positive; + First_1, First_2 : Integer := 1) return Complex_Matrix; + +end Ada.Numerics.Generic_Complex_Arrays; diff --git a/gcc/ada/a-ngcoty.adb b/gcc/ada/a-ngcoty.adb new file mode 100644 index 000000000..7cf48713a --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..0b011e1ef --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..b615f9da9 --- /dev/null +++ b/gcc/ada/a-ngelfu.adb @@ -0,0 +1,999 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.GENERIC_ELEMENTARY_FUNCTIONS -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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. This is not a "strict" implementation, but takes full +-- advantage of the C functions, e.g. in providing interface to hardware +-- provided versions of the elementary functions. + +-- 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 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 X = 0.0 then + return 1.0; + + elsif 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; + + elsif abs X = Pi / 2.0 then + raise Constraint_Error; + end if; + + return Float_Type'Base (Aux.Tan (Double (X))); + end Tan; + + -- Arbitrary cycle + + function Tan (X, Cycle : Float_Type'Base) return Float_Type'Base is + T : Float_Type'Base; + + begin + if Cycle <= 0.0 then + raise Argument_Error; + + elsif X = 0.0 then + return X; + end if; + + T := Float_Type'Base'Remainder (X, Cycle); + + if abs T = 0.25 * Cycle then + raise Constraint_Error; + + elsif abs T = 0.5 * Cycle then + return 0.0; + + else + T := T / Cycle * Two_Pi; + return Sin (T) / Cos (T); + end if; + + end Tan; + + ---------- + -- Tanh -- + ---------- + + function Tanh (X : Float_Type'Base) return Float_Type'Base is + P0 : constant Float_Type'Base := -0.16134_11902_39962_28053E+4; + P1 : constant Float_Type'Base := -0.99225_92967_22360_83313E+2; + P2 : constant Float_Type'Base := -0.96437_49277_72254_69787E+0; + + Q0 : constant Float_Type'Base := 0.48402_35707_19886_88686E+4; + Q1 : constant Float_Type'Base := 0.22337_72071_89623_12926E+4; + Q2 : constant Float_Type'Base := 0.11274_47438_05349_49335E+3; + Q3 : constant Float_Type'Base := 0.10000_00000_00000_00000E+1; + + Half_Ln3 : constant Float_Type'Base := 0.54930_61443_34054_84570; + + P, Q, R : Float_Type'Base; + Y : constant Float_Type'Base := abs X; + G : constant Float_Type'Base := Y * Y; + + Float_Type_Digits_15_Or_More : constant Boolean := + Float_Type'Digits > 14; + + begin + if X < Half_Log_Epsilon then + return -1.0; + + elsif X > -Half_Log_Epsilon then + return 1.0; + + elsif Y < Sqrt_Epsilon then + return X; + + elsif Y < Half_Ln3 + and then Float_Type_Digits_15_Or_More + then + P := (P2 * G + P1) * G + P0; + Q := ((Q3 * G + Q2) * G + Q1) * G + Q0; + R := G * (P / Q); + return X + X * R; + + else + return Float_Type'Base (Aux.Tanh (Double (X))); + end if; + end Tanh; + +end Ada.Numerics.Generic_Elementary_Functions; diff --git a/gcc/ada/a-ngelfu.ads b/gcc/ada/a-ngelfu.ads new file mode 100644 index 000000000..d84828a7c --- /dev/null +++ b/gcc/ada/a-ngelfu.ads @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.GENERIC_ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Float_Type is digits <>; + +package Ada.Numerics.Generic_Elementary_Functions is + pragma Pure; + + function Sqrt (X : Float_Type'Base) return Float_Type'Base; + function Log (X : Float_Type'Base) return Float_Type'Base; + function Log (X, Base : Float_Type'Base) return Float_Type'Base; + function Exp (X : Float_Type'Base) return Float_Type'Base; + function "**" (Left, Right : Float_Type'Base) return Float_Type'Base; + + function Sin (X : Float_Type'Base) return Float_Type'Base; + function Sin (X, Cycle : Float_Type'Base) return Float_Type'Base; + function Cos (X : Float_Type'Base) return Float_Type'Base; + function Cos (X, Cycle : Float_Type'Base) return Float_Type'Base; + function Tan (X : Float_Type'Base) return Float_Type'Base; + function Tan (X, Cycle : Float_Type'Base) return Float_Type'Base; + function Cot (X : Float_Type'Base) return Float_Type'Base; + function Cot (X, Cycle : Float_Type'Base) return Float_Type'Base; + + function Arcsin (X : Float_Type'Base) return Float_Type'Base; + function Arcsin (X, Cycle : Float_Type'Base) return Float_Type'Base; + function Arccos (X : Float_Type'Base) return Float_Type'Base; + function Arccos (X, Cycle : Float_Type'Base) return Float_Type'Base; + + function Arctan + (Y : Float_Type'Base; + X : Float_Type'Base := 1.0) + return Float_Type'Base; + + function Arctan + (Y : Float_Type'Base; + X : Float_Type'Base := 1.0; + Cycle : Float_Type'Base) + return Float_Type'Base; + + function Arccot + (X : Float_Type'Base; + Y : Float_Type'Base := 1.0) + return Float_Type'Base; + + function Arccot + (X : Float_Type'Base; + Y : Float_Type'Base := 1.0; + Cycle : Float_Type'Base) + return Float_Type'Base; + + function Sinh (X : Float_Type'Base) return Float_Type'Base; + function Cosh (X : Float_Type'Base) return Float_Type'Base; + function Tanh (X : Float_Type'Base) return Float_Type'Base; + function Coth (X : Float_Type'Base) return Float_Type'Base; + function Arcsinh (X : Float_Type'Base) return Float_Type'Base; + function Arccosh (X : Float_Type'Base) return Float_Type'Base; + function Arctanh (X : Float_Type'Base) return Float_Type'Base; + function Arccoth (X : Float_Type'Base) return Float_Type'Base; + +end Ada.Numerics.Generic_Elementary_Functions; diff --git a/gcc/ada/a-ngrear.adb b/gcc/ada/a-ngrear.adb new file mode 100644 index 000000000..5c8a00924 --- /dev/null +++ b/gcc/ada/a-ngrear.adb @@ -0,0 +1,784 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.GENERIC_REAL_ARRAYS -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; +with System.Generic_Real_BLAS; +with System.Generic_Real_LAPACK; +with System.Generic_Array_Operations; use System.Generic_Array_Operations; + +package body Ada.Numerics.Generic_Real_Arrays is + + -- Operations involving inner products use BLAS library implementations. + -- This allows larger matrices and vectors to be computed efficiently, + -- taking into account memory hierarchy issues and vector instructions + -- that vary widely between machines. + + -- 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. + + -- Operations for solving linear systems and computing determinant, + -- eigenvalues, eigensystem and inverse, are implemented using the + -- LAPACK library. + + package BLAS is + new Generic_Real_BLAS (Real'Base, Real_Vector, Real_Matrix); + + package LAPACK is + new Generic_Real_LAPACK (Real'Base, Real_Vector, Real_Matrix); + + use BLAS, LAPACK; + + -- Procedure versions of functions returning unconstrained values. + -- This allows for inlining the function wrapper. + + procedure Eigenvalues (A : Real_Matrix; Values : out Real_Vector); + procedure Inverse (A : Real_Matrix; R : out Real_Matrix); + procedure Solve (A : Real_Matrix; X : Real_Vector; B : out Real_Vector); + procedure Solve (A : Real_Matrix; X : Real_Matrix; B : out Real_Matrix); + + procedure Transpose is new + Generic_Array_Operations.Transpose + (Scalar => Real'Base, + Matrix => Real_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 (Real'Base, Real_Matrix); + + -- 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 + 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 + 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 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 is + begin + if Left'Length /= Right'Length then + raise Constraint_Error with + "vectors are of different length in inner product"; + end if; + + return dot (Left'Length, X => Left, Y => Right); + end "*"; + + function "*" (Left, Right : Real_Vector) return Real_Matrix + renames Instantiations."*"; + + function "*" + (Left : Real_Vector; + Right : Real_Matrix) return Real_Vector + is + R : Real_Vector (Right'Range (2)); + + begin + if Left'Length /= Right'Length (1) then + raise Constraint_Error with + "incompatible dimensions in vector-matrix multiplication"; + end if; + + gemv (Trans => No_Trans'Access, + M => Right'Length (2), + N => Right'Length (1), + A => Right, + Ld_A => Right'Length (2), + X => Left, + Y => R); + + return R; + end "*"; + + function "*" + (Left : Real_Matrix; + Right : Real_Vector) return Real_Vector + is + R : Real_Vector (Left'Range (1)); + + begin + if Left'Length (2) /= Right'Length then + raise Constraint_Error with + "incompatible dimensions in matrix-vector multiplication"; + end if; + + gemv (Trans => Trans'Access, + M => Left'Length (2), + N => Left'Length (1), + A => Left, + Ld_A => Left'Length (2), + X => Right, + Y => R); + + return R; + end "*"; + + -- Matrix Multiplication + + function "*" (Left, Right : Real_Matrix) return Real_Matrix is + R : Real_Matrix (Left'Range (1), Right'Range (2)); + + begin + if Left'Length (2) /= Right'Length (1) then + raise Constraint_Error with + "incompatible dimensions in matrix-matrix multiplication"; + end if; + + gemm (Trans_A => No_Trans'Access, + Trans_B => No_Trans'Access, + M => Right'Length (2), + N => Left'Length (1), + K => Right'Length (1), + A => Right, + Ld_A => Right'Length (2), + B => Left, + Ld_B => Left'Length (2), + C => R, + Ld_C => R'Length (2)); + + return R; + end "*"; + + --------- + -- "/" -- + --------- + + 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 is + begin + return nrm2 (Right'Length, Right); + end "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 + N : constant Integer := Length (A); + LU : Real_Matrix (1 .. N, 1 .. N) := A; + Piv : Integer_Vector (1 .. N); + Info : aliased Integer := -1; + Det : Real := 1.0; + + begin + getrf (M => N, + N => N, + A => LU, + Ld_A => N, + I_Piv => Piv, + Info => Info'Access); + + if Info /= 0 then + raise Constraint_Error with "ill-conditioned matrix"; + end if; + + for J in 1 .. N loop + Det := (if Piv (J) /= J then -Det * LU (J, J) else Det * LU (J, J)); + end loop; + + return Det; + end Determinant; + + ----------------- + -- Eigensystem -- + ----------------- + + procedure Eigensystem + (A : Real_Matrix; + Values : out Real_Vector; + Vectors : out Real_Matrix) + is + N : constant Natural := Length (A); + Tau : Real_Vector (1 .. N); + L_Work : Real_Vector (1 .. 1); + Info : aliased Integer; + + E : Real_Vector (1 .. N); + pragma Warnings (Off, E); + + begin + if Values'Length /= N then + raise Constraint_Error with "wrong length for output vector"; + end if; + + if N = 0 then + return; + end if; + + -- Initialize working matrix and check for symmetric input matrix + + Transpose (A, Vectors); + + if A /= Vectors then + raise Argument_Error with "matrix not symmetric"; + end if; + + -- Compute size of additional working space + + sytrd (Uplo => Lower'Access, + N => N, + A => Vectors, + Ld_A => N, + D => Values, + E => E, + Tau => Tau, + Work => L_Work, + L_Work => -1, + Info => Info'Access); + + declare + Work : Real_Vector (1 .. Integer'Max (Integer (L_Work (1)), 2 * N)); + pragma Warnings (Off, Work); + + Comp_Z : aliased constant Character := 'V'; + + begin + -- Reduce matrix to tridiagonal form + + sytrd (Uplo => Lower'Access, + N => N, + A => Vectors, + Ld_A => A'Length (1), + D => Values, + E => E, + Tau => Tau, + Work => Work, + L_Work => Work'Length, + Info => Info'Access); + + if Info /= 0 then + raise Program_Error; + end if; + + -- Generate the real orthogonal matrix determined by sytrd + + orgtr (Uplo => Lower'Access, + N => N, + A => Vectors, + Ld_A => N, + Tau => Tau, + Work => Work, + L_Work => Work'Length, + Info => Info'Access); + + if Info /= 0 then + raise Program_Error; + end if; + + -- Compute all eigenvalues and eigenvectors using QR algorithm + + steqr (Comp_Z => Comp_Z'Access, + N => N, + D => Values, + E => E, + Z => Vectors, + Ld_Z => N, + Work => Work, + Info => Info'Access); + + if Info /= 0 then + raise Constraint_Error with + "eigensystem computation failed to converge"; + end if; + end; + end Eigensystem; + + ----------------- + -- Eigenvalues -- + ----------------- + + procedure Eigenvalues + (A : Real_Matrix; + Values : out Real_Vector) + is + N : constant Natural := Length (A); + L_Work : Real_Vector (1 .. 1); + Info : aliased Integer; + + B : Real_Matrix (1 .. N, 1 .. N); + Tau : Real_Vector (1 .. N); + E : Real_Vector (1 .. N); + pragma Warnings (Off, B); + pragma Warnings (Off, Tau); + pragma Warnings (Off, E); + + begin + if Values'Length /= N then + raise Constraint_Error with "wrong length for output vector"; + end if; + + if N = 0 then + return; + end if; + + -- Initialize working matrix and check for symmetric input matrix + + Transpose (A, B); + + if A /= B then + raise Argument_Error with "matrix not symmetric"; + end if; + + -- Find size of work area + + sytrd (Uplo => Lower'Access, + N => N, + A => B, + Ld_A => N, + D => Values, + E => E, + Tau => Tau, + Work => L_Work, + L_Work => -1, + Info => Info'Access); + + declare + Work : Real_Vector (1 .. Integer'Min (Integer (L_Work (1)), 4 * N)); + pragma Warnings (Off, Work); + + begin + -- Reduce matrix to tridiagonal form + + sytrd (Uplo => Lower'Access, + N => N, + A => B, + Ld_A => A'Length (1), + D => Values, + E => E, + Tau => Tau, + Work => Work, + L_Work => Work'Length, + Info => Info'Access); + + if Info /= 0 then + raise Constraint_Error; + end if; + + -- Compute all eigenvalues using QR algorithm + + sterf (N => N, + D => Values, + E => E, + Info => Info'Access); + + if Info /= 0 then + raise Constraint_Error with + "eigenvalues computation failed to converge"; + end if; + end; + end Eigenvalues; + + function Eigenvalues (A : Real_Matrix) return Real_Vector is + R : Real_Vector (A'Range (1)); + begin + Eigenvalues (A, R); + return R; + end Eigenvalues; + + ------------- + -- Inverse -- + ------------- + + procedure Inverse (A : Real_Matrix; R : out Real_Matrix) is + N : constant Integer := Length (A); + Piv : Integer_Vector (1 .. N); + L_Work : Real_Vector (1 .. 1); + Info : aliased Integer := -1; + + begin + -- All computations are done using column-major order, but this works + -- out fine, because Transpose (Inverse (Transpose (A))) = Inverse (A). + + R := A; + + -- Compute LU decomposition + + getrf (M => N, + N => N, + A => R, + Ld_A => N, + I_Piv => Piv, + Info => Info'Access); + + if Info /= 0 then + raise Constraint_Error with "inverting singular matrix"; + end if; + + -- Determine size of work area + + getri (N => N, + A => R, + Ld_A => N, + I_Piv => Piv, + Work => L_Work, + L_Work => -1, + Info => Info'Access); + + if Info /= 0 then + raise Constraint_Error; + end if; + + declare + Work : Real_Vector (1 .. Integer (L_Work (1))); + pragma Warnings (Off, Work); + + begin + -- Compute inverse from LU decomposition + + getri (N => N, + A => R, + Ld_A => N, + I_Piv => Piv, + Work => Work, + L_Work => Work'Length, + Info => Info'Access); + + if Info /= 0 then + raise Constraint_Error with "inverting singular matrix"; + end if; + + -- ??? Should iterate with gerfs, based on implementation advice + end; + end Inverse; + + function Inverse (A : Real_Matrix) return Real_Matrix is + R : Real_Matrix (A'Range (2), A'Range (1)); + begin + Inverse (A, R); + return R; + end Inverse; + + ----------- + -- Solve -- + ----------- + + procedure Solve (A : Real_Matrix; X : Real_Vector; B : out Real_Vector) is + begin + if Length (A) /= X'Length then + raise Constraint_Error with + "incompatible matrix and vector dimensions"; + end if; + + -- ??? Should solve directly, is faster and more accurate + + B := Inverse (A) * X; + end Solve; + + procedure Solve (A : Real_Matrix; X : Real_Matrix; B : out Real_Matrix) is + begin + if Length (A) /= X'Length (1) then + raise Constraint_Error with "incompatible matrix dimensions"; + end if; + + -- ??? Should solve directly, is faster and more accurate + + B := Inverse (A) * X; + end Solve; + + function Solve (A : Real_Matrix; X : Real_Vector) return Real_Vector is + B : Real_Vector (A'Range (2)); + begin + Solve (A, X, B); + return B; + end Solve; + + function Solve (A, X : Real_Matrix) return Real_Matrix is + B : Real_Matrix (A'Range (2), X'Range (2)); + begin + Solve (A, X, B); + return B; + end Solve; + + --------------- + -- Transpose -- + --------------- + + function Transpose (X : Real_Matrix) return Real_Matrix is + R : Real_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 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 new file mode 100644 index 000000000..f244d6519 --- /dev/null +++ b/gcc/ada/a-ngrear.ads @@ -0,0 +1,139 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.GENERIC_REAL_ARRAYS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 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_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 always inline these, the expense of the unconstrained returns + -- can be avoided. + + pragma Inline_Always ("+"); + pragma Inline_Always ("-"); + pragma Inline_Always ("*"); + pragma Inline_Always ("/"); + pragma Inline_Always ("abs"); + pragma Inline_Always (Eigenvalues); + pragma Inline_Always (Inverse); + pragma Inline_Always (Solve); + pragma Inline_Always (Transpose); + pragma Inline_Always (Unit_Matrix); + pragma Inline_Always (Unit_Vector); +end Ada.Numerics.Generic_Real_Arrays; diff --git a/gcc/ada/a-nlcefu.ads b/gcc/ada/a-nlcefu.ads new file mode 100644 index 000000000..9e985dfca --- /dev/null +++ b/gcc/ada/a-nlcefu.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.LONG_COMPLEX.ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Long_Complex_Types; +with Ada.Numerics.Generic_Complex_Elementary_Functions; + +package Ada.Numerics.Long_Complex_Elementary_Functions is + new Ada.Numerics.Generic_Complex_Elementary_Functions + (Ada.Numerics.Long_Complex_Types); diff --git a/gcc/ada/a-nlcoar.ads b/gcc/ada/a-nlcoar.ads new file mode 100644 index 000000000..35e97a5ce --- /dev/null +++ b/gcc/ada/a-nlcoar.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.LONG_COMPLEX_ARRAYS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Arrays; +with Ada.Numerics.Long_Real_Arrays; +with Ada.Numerics.Long_Complex_Types; + +package Ada.Numerics.Long_Complex_Arrays is new + Ada.Numerics.Generic_Complex_Arrays (Long_Real_Arrays, Long_Complex_Types); + +pragma Pure (Long_Complex_Arrays); diff --git a/gcc/ada/a-nlcoty.ads b/gcc/ada/a-nlcoty.ads new file mode 100644 index 000000000..6eb4fc3b9 --- /dev/null +++ b/gcc/ada/a-nlcoty.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . L O N G _ C O M P L E X _ T Y P E S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; + +package Ada.Numerics.Long_Complex_Types is + new Ada.Numerics.Generic_Complex_Types (Long_Float); + +pragma Pure (Long_Complex_Types); diff --git a/gcc/ada/a-nlelfu.ads b/gcc/ada/a-nlelfu.ads new file mode 100644 index 000000000..10b33e9cb --- /dev/null +++ b/gcc/ada/a-nlelfu.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.LONG_ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Elementary_Functions; + +package Ada.Numerics.Long_Elementary_Functions is + new Ada.Numerics.Generic_Elementary_Functions (Long_Float); + +pragma Pure (Long_Elementary_Functions); diff --git a/gcc/ada/a-nllcar.ads b/gcc/ada/a-nllcar.ads new file mode 100644 index 000000000..48fd91ab9 --- /dev/null +++ b/gcc/ada/a-nllcar.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.LONG_LONG_COMPLEX_ARRAYS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Arrays; +with Ada.Numerics.Long_Long_Real_Arrays; +with Ada.Numerics.Long_Long_Complex_Types; + +package Ada.Numerics.Long_Long_Complex_Arrays is + new Ada.Numerics.Generic_Complex_Arrays (Long_Long_Real_Arrays, + Long_Long_Complex_Types); + +pragma Pure (Long_Long_Complex_Arrays); diff --git a/gcc/ada/a-nllcef.ads b/gcc/ada/a-nllcef.ads new file mode 100644 index 000000000..2867e1dbb --- /dev/null +++ b/gcc/ada/a-nllcef.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.LONG_LONG_COMPLEX.ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Long_Long_Complex_Types; +with Ada.Numerics.Generic_Complex_Elementary_Functions; + +package Ada.Numerics.Long_Long_Complex_Elementary_Functions is + new Ada.Numerics.Generic_Complex_Elementary_Functions + (Ada.Numerics.Long_Long_Complex_Types); diff --git a/gcc/ada/a-nllcty.ads b/gcc/ada/a-nllcty.ads new file mode 100644 index 000000000..a6081c28b --- /dev/null +++ b/gcc/ada/a-nllcty.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . L O N G _ L O N G _ C O M P L E X _ T Y P E S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; + +package Ada.Numerics.Long_Long_Complex_Types is + new Ada.Numerics.Generic_Complex_Types (Long_Long_Float); + +pragma Pure (Long_Long_Complex_Types); diff --git a/gcc/ada/a-nllefu.ads b/gcc/ada/a-nllefu.ads new file mode 100644 index 000000000..7089fc3ef --- /dev/null +++ b/gcc/ada/a-nllefu.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.LONG_LONG_ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Elementary_Functions; + +package Ada.Numerics.Long_Long_Elementary_Functions is + new Ada.Numerics.Generic_Elementary_Functions (Long_Long_Float); + +pragma Pure (Long_Long_Elementary_Functions); diff --git a/gcc/ada/a-nllrar.ads b/gcc/ada/a-nllrar.ads new file mode 100644 index 000000000..62a24570e --- /dev/null +++ b/gcc/ada/a-nllrar.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . L O N G _ L O N G _R E A L _ A R R A Y S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Real_Arrays; + +package Ada.Numerics.Long_Long_Real_Arrays is + new Ada.Numerics.Generic_Real_Arrays (Long_Long_Float); + +pragma Pure (Long_Long_Real_Arrays); diff --git a/gcc/ada/a-nlrear.ads b/gcc/ada/a-nlrear.ads new file mode 100644 index 000000000..990c39b1a --- /dev/null +++ b/gcc/ada/a-nlrear.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . L O N G _ R E A L _ A R R A Y S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Real_Arrays; + +package Ada.Numerics.Long_Real_Arrays is + new Ada.Numerics.Generic_Real_Arrays (Long_Float); + +pragma Pure (Long_Real_Arrays); diff --git a/gcc/ada/a-nscefu.ads b/gcc/ada/a-nscefu.ads new file mode 100644 index 000000000..ac89d051c --- /dev/null +++ b/gcc/ada/a-nscefu.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.SHORT.COMPLEX.ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Short_Complex_Types; +with Ada.Numerics.Generic_Complex_Elementary_Functions; + +package Ada.Numerics.Short_Complex_Elementary_Functions is + new Ada.Numerics.Generic_Complex_Elementary_Functions + (Ada.Numerics.Short_Complex_Types); diff --git a/gcc/ada/a-nscoty.ads b/gcc/ada/a-nscoty.ads new file mode 100644 index 000000000..e58b0b56e --- /dev/null +++ b/gcc/ada/a-nscoty.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . S H O R T _ C O M P L E X _ T Y P E S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; + +package Ada.Numerics.Short_Complex_Types is + new Ada.Numerics.Generic_Complex_Types (Short_Float); + +pragma Pure (Short_Complex_Types); diff --git a/gcc/ada/a-nselfu.ads b/gcc/ada/a-nselfu.ads new file mode 100644 index 000000000..10b04acde --- /dev/null +++ b/gcc/ada/a-nselfu.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.SHORT_ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Elementary_Functions; + +package Ada.Numerics.Short_Elementary_Functions is + new Ada.Numerics.Generic_Elementary_Functions (Short_Float); + +pragma Pure (Short_Elementary_Functions); diff --git a/gcc/ada/a-nucoar.ads b/gcc/ada/a-nucoar.ads new file mode 100644 index 000000000..665d02d6a --- /dev/null +++ b/gcc/ada/a-nucoar.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . C O M P L E X _ A R R A Y S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Arrays; +with Ada.Numerics.Real_Arrays; +with Ada.Numerics.Complex_Types; + +package Ada.Numerics.Complex_Arrays is + new Ada.Numerics.Generic_Complex_Arrays (Real_Arrays, Complex_Types); + +pragma Pure (Complex_Arrays); diff --git a/gcc/ada/a-nucoty.ads b/gcc/ada/a-nucoty.ads new file mode 100644 index 000000000..3b04a2712 --- /dev/null +++ b/gcc/ada/a-nucoty.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . C O M P L E X _ T Y P E S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; + +package Ada.Numerics.Complex_Types is + new Ada.Numerics.Generic_Complex_Types (Float); + +pragma Pure (Complex_Types); diff --git a/gcc/ada/a-nudira.adb b/gcc/ada/a-nudira.adb new file mode 100644 index 000000000..ca81ba518 --- /dev/null +++ b/gcc/ada/a-nudira.adb @@ -0,0 +1,94 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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.Numerics.Discrete_Random 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 new file mode 100644 index 000000000..385f33619 --- /dev/null +++ b/gcc/ada/a-nudira.ads @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 is + + -- Basic facilities + + type Generator is limited private; + + function Random (Gen : Generator) return Result_Subtype; + + procedure Reset (Gen : Generator; Initiator : Integer); + procedure Reset (Gen : Generator); + + -- Advanced facilities + + type State is private; + + procedure Save (Gen : Generator; To_State : out State); + procedure Reset (Gen : Generator; From_State : State); + + Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width; + + function Image (Of_State : State) return String; + function Value (Coded_State : String) return State; + +private + + type Generator is new System.Random_Numbers.Generator; + + type State is new System.Random_Numbers.State; + +end Ada.Numerics.Discrete_Random; diff --git a/gcc/ada/a-nuelfu.ads b/gcc/ada/a-nuelfu.ads new file mode 100644 index 000000000..149939bab --- /dev/null +++ b/gcc/ada/a-nuelfu.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . E L E M E N T A R Y _ F U N C T I O N S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Elementary_Functions; + +package Ada.Numerics.Elementary_Functions is + new Ada.Numerics.Generic_Elementary_Functions (Float); + +pragma Pure (Elementary_Functions); diff --git a/gcc/ada/a-nuflra.adb b/gcc/ada/a-nuflra.adb new file mode 100644 index 000000000..2c6fbc47f --- /dev/null +++ b/gcc/ada/a-nuflra.adb @@ -0,0 +1,102 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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.Numerics.Float_Random 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 new file mode 100644 index 000000000..5a448a781 --- /dev/null +++ b/gcc/ada/a-nuflra.ads @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 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 new file mode 100644 index 000000000..1444603d6 --- /dev/null +++ b/gcc/ada/a-numaux-darwin.adb @@ -0,0 +1,185 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- File a-numaux.adb <- a-numaux-darwin.adb + +package body Ada.Numerics.Aux is + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Reduce (X : in out Double; Q : out Natural); + -- Implements 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. + + -- The following three 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); + + 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; + + 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; + + ------------ + -- 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; + + 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 K /= K then + raise Constraint_Error; + end if; + + K := Double'Rounding (K); + Q := Integer (K) mod 4; + 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 new file mode 100644 index 000000000..1f0eea907 --- /dev/null +++ b/gcc/ada/a-numaux-darwin.ads @@ -0,0 +1,107 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 with normal Unix math functions, except for +-- sine/cosine which have been implemented directly in Ada to get +-- the required accuracy in OS X. Alternative packages are used +-- on OpenVMS (different import names), VxWorks (no need for the +-- -lm Linker_Options), and on the x86 (where we have two +-- versions one using inline ASM, and one importing from the C long +-- routines that take 80-bit arguments). + +package Ada.Numerics.Aux is + pragma Pure; + + pragma Linker_Options ("-lm"); + + type Double is digits 15; + -- 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 new file mode 100644 index 000000000..2a48d8a81 --- /dev/null +++ b/gcc/ada/a-numaux-libc-x86.ads @@ -0,0 +1,106 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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. + +-- Note: there are two versions of this package. One using the 80-bit x86 +-- long double format (which is this version), and one using 64-bit IEEE +-- double (see file a-numaux.ads). + +package Ada.Numerics.Aux is + pragma Pure; + + pragma Linker_Options ("-lm"); + + type Double is digits 18; + + -- 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 new file mode 100644 index 000000000..1b6d68e07 --- /dev/null +++ b/gcc/ada/a-numaux-vxworks.ads @@ -0,0 +1,108 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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. + +-- Note: there are two versions of this package. One using the normal IEEE +-- 64-bit double format (which is this version), and one using 80-bit x86 +-- long double (see file 4onumaux.ads). + +package Ada.Numerics.Aux is + pragma Pure; + + -- This version omits the pragma linker_options ("-lm") since there is + -- no libm.a library for VxWorks. + + type Double is digits 15; + -- 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 new file mode 100644 index 000000000..811485d85 --- /dev/null +++ b/gcc/ada/a-numaux-x86.adb @@ -0,0 +1,569 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- File a-numaux.adb <- 86numaux.adb + +-- This version of Numerics.Aux is for the IEEE Double Extended floating +-- point format on x86. + +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); + -- Implements 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. + + 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 not (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 := X * Two_Over_Pi; + begin + -- For X < 2.0**32, 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). + + 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 /= K then + + -- K is not a number, because X was not finite + + raise Constraint_Error; + end if; + + K := Double'Rounding (K); + Q := Integer (K) mod 4; + 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 new file mode 100644 index 000000000..c0f8b40c3 --- /dev/null +++ b/gcc/ada/a-numaux-x86.ads @@ -0,0 +1,82 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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. This implementation is based on the glibc assembly +-- sources for the x86 glibc math library. + +-- Note: there are two versions of this package. One using the 80-bit x86 +-- long double format (which is this version), and one using 64-bit IEEE +-- double (see file a-numaux.ads). The latter version imports the C +-- routines directly. + +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 new file mode 100644 index 000000000..31281218b --- /dev/null +++ b/gcc/ada/a-numaux.ads @@ -0,0 +1,109 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 is for use with normal Unix math functions. Alternative +-- packages are used on OpenVMS (different import names), VxWorks (no +-- need for the -lm Linker_Options), and on the x86 (where we have two +-- versions one using inline ASM, and one importing from the C long +-- routines that take 80-bit arguments). + +package Ada.Numerics.Aux is + pragma Pure; + + pragma Linker_Options ("-lm"); + + type Double is digits 15; + -- Type Double is the type used to call the C routines + + -- We import these functions directly from C. Note that we label them + -- all as pure functions, because indeed all of them are in fact pure! + + function Sin (X : Double) return Double; + pragma Import (C, Sin, "sin"); + pragma Pure_Function (Sin); + + function Cos (X : Double) return Double; + pragma Import (C, Cos, "cos"); + pragma Pure_Function (Cos); + + function Tan (X : Double) return Double; + pragma Import (C, Tan, "tan"); + pragma Pure_Function (Tan); + + function Exp (X : Double) return Double; + pragma Import (C, Exp, "exp"); + pragma Pure_Function (Exp); + + function Sqrt (X : Double) return Double; + pragma Import (C, Sqrt, "sqrt"); + pragma Pure_Function (Sqrt); + + function Log (X : Double) return Double; + pragma Import (C, Log, "log"); + pragma Pure_Function (Log); + + function Acos (X : Double) return Double; + pragma Import (C, Acos, "acos"); + pragma Pure_Function (Acos); + + function Asin (X : Double) return Double; + pragma Import (C, Asin, "asin"); + pragma Pure_Function (Asin); + + function Atan (X : Double) return Double; + pragma Import (C, Atan, "atan"); + pragma Pure_Function (Atan); + + function Sinh (X : Double) return Double; + pragma Import (C, Sinh, "sinh"); + pragma Pure_Function (Sinh); + + function Cosh (X : Double) return Double; + pragma Import (C, Cosh, "cosh"); + pragma Pure_Function (Cosh); + + function Tanh (X : Double) return Double; + pragma Import (C, Tanh, "tanh"); + pragma Pure_Function (Tanh); + + function Pow (X, Y : Double) return Double; + pragma Import (C, Pow, "pow"); + pragma Pure_Function (Pow); + +end Ada.Numerics.Aux; diff --git a/gcc/ada/a-numeri.ads b/gcc/ada/a-numeri.ads new file mode 100644 index 000000000..805fa5670 --- /dev/null +++ b/gcc/ada/a-numeri.ads @@ -0,0 +1,32 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Numerics is + pragma Pure; + + Argument_Error : exception; + + Pi : constant := + 3.14159_26535_89793_23846_26433_83279_50288_41971_69399_37511; + + ["03C0"] : constant := Pi; + -- This is the Greek letter Pi (for Ada 2005 AI-388). Note that it is + -- conforming to have this constant present even in Ada 95 mode, as there + -- is no way for a normal mode Ada 95 program to reference this identifier. + + e : constant := + 2.71828_18284_59045_23536_02874_71352_66249_77572_47093_69996; + +end Ada.Numerics; diff --git a/gcc/ada/a-nurear.ads b/gcc/ada/a-nurear.ads new file mode 100644 index 000000000..019759917 --- /dev/null +++ b/gcc/ada/a-nurear.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . R E A L _ A R R A Y S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Real_Arrays; + +package Ada.Numerics.Real_Arrays is + new Ada.Numerics.Generic_Real_Arrays (Float); + +pragma Pure (Real_Arrays); diff --git a/gcc/ada/a-rbtgbk.adb b/gcc/ada/a-rbtgbk.adb new file mode 100644 index 000000000..b12ae8410 --- /dev/null +++ b/gcc/ada/a-rbtgbk.adb @@ -0,0 +1,599 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_KEYS -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +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 + 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 is True, then this means either that Tree is + -- empty, or there was a least one node (strictly) greater than + -- Key. Otherwise, it means that Key is equal to or greater than + -- every node. + + if Inserted then + if Y = Tree.First then + Insert_Post (Tree, Y, True, Node); + return; + end if; + + Node := Ops.Previous (Tree, Y); + + else + Node := Y; + end if; + + -- Here Node has a value that is less than or equal to Key. We + -- now have to resolve whether Key is equal to or greater than + -- Node, which determines whether the insertion succeeds. + + if Is_Greater_Key_Node (Key, N (Node)) then + Insert_Post (Tree, Y, Inserted, Node); + Inserted := True; + return; + end if; + + 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 + if Tree.Length >= Tree.Capacity then + raise Capacity_Error with "not enough capacity to insert new item"; + end if; + + if Tree.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + 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 new file mode 100644 index 000000000..a96ef28cf --- /dev/null +++ b/gcc/ada/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-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. -- +------------------------------------------------------------------------------ + +-- 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; + + 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 new file mode 100644 index 000000000..88743b3ce --- /dev/null +++ b/gcc/ada/a-rbtgbo.adb @@ -0,0 +1,1118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +-- The references below to "CLR" refer to the following book, from which +-- several of the algorithms here were adapted: +-- Introduction to Algorithms +-- by Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest +-- Publisher: The MIT Press (June 18, 1990) +-- ISBN: 0262031418 + +with System; use type System.Address; + +package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is + + ----------------------- + -- 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 + if Tree.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Tree.First := 0; + Tree.Last := 0; + Tree.Root := 0; + Tree.Length := 0; + -- Tree.Busy + -- Tree.Lock + Tree.Free := -1; + end Clear_Tree; + + ------------------ + -- Delete_Fixup -- + ------------------ + + procedure Delete_Fixup + (Tree : in out Tree_Type'Class; + Node : Count_Type) + is + + -- CLR p274 + + 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 p273 + + X, Y : Count_Type; + + Z : constant Count_Type := Node; + pragma Assert (Z /= 0); + + N : Nodes_Type renames Tree.Nodes; + + begin + if Tree.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + 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), 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; + end Generic_Allocate; + + ------------------- + -- Generic_Equal -- + ------------------- + + function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean is + 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; + + 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 Len < 0 then + raise Program_Error with "bad container length (corrupt stream)"; + end if; + + if Len = 0 then + return; + end if; + + if 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 p266 + + 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 p248 + + 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 p248 + + 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 p249 + + 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 new file mode 100644 index 000000000..b6aae737f --- /dev/null +++ b/gcc/ada/a-rbtgbo.ads @@ -0,0 +1,155 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_OPERATIONS -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +-- 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; + + 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 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 new file mode 100644 index 000000000..2b9b54024 --- /dev/null +++ b/gcc/ada/a-rbtgso.adb @@ -0,0 +1,630 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_SET_OPERATIONS -- +-- -- +-- 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; use type System.Address; + +package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is + + ----------------------- + -- 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 + pragma Assert (Tree.Busy = 0); + pragma Assert (Tree.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 := Target.First; + Src : Node_Access := Source.First; + + begin + if Target'Address = Source'Address then + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Clear (Target); + return; + end if; + + if Source.Length = 0 then + return; + end if; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + loop + if Tgt = null then + return; + end if; + + if Src = null then + return; + end if; + + if Is_Less (Tgt, Src) then + Tgt := Tree_Operations.Next (Tgt); + + elsif Is_Less (Src, Tgt) 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 + Tree : Tree_Type; + + L_Node : Node_Access := Left.First; + R_Node : Node_Access := Right.First; + + Dst_Node : Node_Access; + pragma Warnings (Off, Dst_Node); + + begin + if Left'Address = Right'Address then + return Tree; -- Empty set + end if; + + if Left.Length = 0 then + return Tree; -- Empty set + end if; + + if Right.Length = 0 then + return Copy (Left); + end if; + + loop + if L_Node = null then + return Tree; + 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; + + return Tree; + 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; + + exception + when others => + Delete_Tree (Tree.Root); + raise; + end Difference; + + ------------------ + -- Intersection -- + ------------------ + + procedure Intersection + (Target : in out Tree_Type; + Source : Tree_Type) + is + Tgt : Node_Access := Target.First; + Src : Node_Access := Source.First; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + if Source.Length = 0 then + Clear (Target); + return; + end if; + + while Tgt /= null + and then Src /= null + loop + if Is_Less (Tgt, Src) then + declare + X : Node_Access := Tgt; + begin + Tgt := Tree_Operations.Next (Tgt); + Tree_Operations.Delete_Node_Sans_Free (Target, X); + Free (X); + end; + + elsif Is_Less (Src, Tgt) 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 + Tree : Tree_Type; + + L_Node : Node_Access := Left.First; + R_Node : Node_Access := Right.First; + + Dst_Node : Node_Access; + pragma Warnings (Off, Dst_Node); + + begin + if Left'Address = Right'Address then + return Copy (Left); + end if; + + loop + if L_Node = null then + return Tree; + end if; + + if R_Node = null then + return Tree; + 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; + + exception + when others => + Delete_Tree (Tree.Root); + raise; + 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; + + declare + Subset_Node : Node_Access := Subset.First; + Set_Node : Node_Access := Of_Set.First; + + begin + 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 + L_Node : Node_Access := Left.First; + R_Node : Node_Access := Right.First; + + begin + if Left'Address = Right'Address then + return Left.Length /= 0; + end if; + + 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 Overlap; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Symmetric_Difference + (Target : in out Tree_Type; + Source : Tree_Type) + is + Tgt : Node_Access := Target.First; + Src : Node_Access := Source.First; + + New_Tgt_Node : Node_Access; + pragma Warnings (Off, New_Tgt_Node); + + begin + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + 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; + + if Is_Less (Tgt, Src) then + Tgt := Tree_Operations.Next (Tgt); + + elsif Is_Less (Src, Tgt) 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 + Tree : Tree_Type; + + L_Node : Node_Access := Left.First; + R_Node : Node_Access := Right.First; + + Dst_Node : Node_Access; + pragma Warnings (Off, Dst_Node); + + begin + if Left'Address = Right'Address then + return Tree; -- Empty set + end if; + + if Right.Length = 0 then + return Copy (Left); + end if; + + if Left.Length = 0 then + return Copy (Right); + end if; + + 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; + + return Tree; + 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; + + return Tree; + 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; + + exception + when others => + Delete_Tree (Tree.Root); + raise; + 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, + Src_Node => Node, + Dst_Node => Hint); + end Process; + + -- Start of processing for Union + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Iterate (Source); + 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 + 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, + 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 new file mode 100644 index 000000000..26ff8fb84 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception 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; + + 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-reatim.adb b/gcc/ada/a-reatim.adb new file mode 100644 index 000000000..026c28941 --- /dev/null +++ b/gcc/ada/a-reatim.adb @@ -0,0 +1,253 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . R E A L _ T I M E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2010, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Tasking; + +package body Ada.Real_Time is + + --------- + -- "*" -- + --------- + + -- Note that Constraint_Error may be propagated + + function "*" (Left : Time_Span; Right : Integer) return Time_Span is + pragma Unsuppress (Overflow_Check); + begin + return Time_Span (Duration (Left) * Right); + end "*"; + + function "*" (Left : Integer; Right : Time_Span) return Time_Span is + pragma Unsuppress (Overflow_Check); + begin + return Time_Span (Left * Duration (Right)); + end "*"; + + --------- + -- "+" -- + --------- + + -- Note that Constraint_Error may be propagated + + function "+" (Left : Time; Right : Time_Span) return Time is + pragma Unsuppress (Overflow_Check); + begin + return Time (Duration (Left) + Duration (Right)); + end "+"; + + function "+" (Left : Time_Span; Right : Time) return Time is + pragma Unsuppress (Overflow_Check); + begin + return Time (Duration (Left) + Duration (Right)); + end "+"; + + function "+" (Left, Right : Time_Span) return Time_Span is + pragma Unsuppress (Overflow_Check); + begin + return Time_Span (Duration (Left) + Duration (Right)); + end "+"; + + --------- + -- "-" -- + --------- + + -- Note that Constraint_Error may be propagated + + function "-" (Left : Time; Right : Time_Span) return Time is + pragma Unsuppress (Overflow_Check); + begin + return Time (Duration (Left) - Duration (Right)); + end "-"; + + function "-" (Left, Right : Time) return Time_Span is + pragma Unsuppress (Overflow_Check); + begin + return Time_Span (Duration (Left) - Duration (Right)); + end "-"; + + function "-" (Left, Right : Time_Span) return Time_Span is + pragma Unsuppress (Overflow_Check); + begin + return Time_Span (Duration (Left) - Duration (Right)); + end "-"; + + function "-" (Right : Time_Span) return Time_Span is + pragma Unsuppress (Overflow_Check); + begin + return Time_Span_Zero - Right; + end "-"; + + --------- + -- "/" -- + --------- + + -- Note that Constraint_Error may be propagated + + function "/" (Left, Right : Time_Span) return Integer is + pragma Unsuppress (Overflow_Check); + begin + return Integer (Duration (Left) / Duration (Right)); + end "/"; + + function "/" (Left : Time_Span; Right : Integer) return Time_Span is + pragma Unsuppress (Overflow_Check); + begin + return Time_Span (Duration (Left) / Right); + end "/"; + + ----------- + -- Clock -- + ----------- + + function Clock return Time is + begin + return Time (System.Task_Primitives.Operations.Monotonic_Clock); + end Clock; + + ------------------ + -- Microseconds -- + ------------------ + + function Microseconds (US : Integer) return Time_Span is + begin + return Time_Span_Unit * US * 1_000; + end Microseconds; + + ------------------ + -- Milliseconds -- + ------------------ + + function Milliseconds (MS : Integer) return Time_Span is + begin + return Time_Span_Unit * MS * 1_000_000; + end Milliseconds; + + ------------- + -- Minutes -- + ------------- + + function Minutes (M : Integer) return Time_Span is + begin + return Milliseconds (M) * Integer'(60_000); + end Minutes; + + ----------------- + -- Nanoseconds -- + ----------------- + + function Nanoseconds (NS : Integer) return Time_Span is + begin + return Time_Span_Unit * NS; + end Nanoseconds; + + ------------- + -- Seconds -- + ------------- + + function Seconds (S : Integer) return Time_Span is + begin + return Milliseconds (S) * Integer'(1000); + end Seconds; + + ----------- + -- Split -- + ----------- + + procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span) is + T_Val : Time; + + begin + -- Special-case for Time_First, whose absolute value is anomalous, + -- courtesy of two's complement. + + T_Val := (if T = Time_First then abs (Time_Last) else abs (T)); + + -- Extract the integer part of T, truncating towards zero + + SC := + (if T_Val < 0.5 then 0 else Seconds_Count (Time_Span'(T_Val - 0.5))); + + if T < 0.0 then + SC := -SC; + end if; + + -- If original time is negative, need to truncate towards negative + -- infinity, to make TS non-negative, as per ARM. + + if Time (SC) > T then + SC := SC - 1; + end if; + + TS := Time_Span (Duration (T) - Duration (SC)); + end Split; + + ------------- + -- Time_Of -- + ------------- + + function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time is + begin + return Time (SC) + TS; + end Time_Of; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : Time_Span) return Duration is + begin + return Duration (TS); + end To_Duration; + + ------------------ + -- To_Time_Span -- + ------------------ + + function To_Time_Span (D : Duration) return Time_Span is + begin + -- Note regarding AI-00432 requiring range checking on this conversion. + -- In almost all versions of GNAT (and all to which this version of the + -- Ada.Real_Time package apply), the range of Time_Span and Duration are + -- the same, so there is no issue of overflow. + + return Time_Span (D); + end To_Time_Span; + +begin + -- Ensure that the tasking run time is initialized when using clock and/or + -- delay operations. The initialization routine has the required machinery + -- to prevent multiple calls to Initialize. + + System.Tasking.Initialize; +end Ada.Real_Time; diff --git a/gcc/ada/a-reatim.ads b/gcc/ada/a-reatim.ads new file mode 100644 index 000000000..2c86289a6 --- /dev/null +++ b/gcc/ada/a-reatim.ads @@ -0,0 +1,139 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . R E A L _ T I M E -- +-- -- +-- 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 System.Task_Primitives.Operations; +pragma Elaborate_All (System.Task_Primitives.Operations); + +package Ada.Real_Time is + + type Time is private; + Time_First : constant Time; + Time_Last : constant Time; + Time_Unit : constant := 10#1.0#E-9; + + type Time_Span is private; + Time_Span_First : constant Time_Span; + Time_Span_Last : constant Time_Span; + Time_Span_Zero : constant Time_Span; + Time_Span_Unit : constant Time_Span; + + Tick : constant Time_Span; + function Clock return Time; + + function "+" (Left : Time; Right : Time_Span) return Time; + function "+" (Left : Time_Span; Right : Time) return Time; + function "-" (Left : Time; Right : Time_Span) return Time; + function "-" (Left : Time; Right : Time) return Time_Span; + + function "<" (Left, Right : Time) return Boolean; + function "<=" (Left, Right : Time) return Boolean; + function ">" (Left, Right : Time) return Boolean; + function ">=" (Left, Right : Time) return Boolean; + + function "+" (Left, Right : Time_Span) return Time_Span; + function "-" (Left, Right : Time_Span) return Time_Span; + function "-" (Right : Time_Span) return Time_Span; + function "*" (Left : Time_Span; Right : Integer) return Time_Span; + function "*" (Left : Integer; Right : Time_Span) return Time_Span; + function "/" (Left, Right : Time_Span) return Integer; + function "/" (Left : Time_Span; Right : Integer) return Time_Span; + + function "abs" (Right : Time_Span) return Time_Span; + + function "<" (Left, Right : Time_Span) return Boolean; + function "<=" (Left, Right : Time_Span) return Boolean; + function ">" (Left, Right : Time_Span) return Boolean; + function ">=" (Left, Right : Time_Span) return Boolean; + + function To_Duration (TS : Time_Span) return Duration; + function To_Time_Span (D : Duration) return Time_Span; + + function Nanoseconds (NS : Integer) return Time_Span; + function Microseconds (US : Integer) return Time_Span; + function Milliseconds (MS : Integer) return Time_Span; + + function Seconds (S : Integer) return Time_Span; + pragma Ada_05 (Seconds); + + function Minutes (M : Integer) return Time_Span; + pragma Ada_05 (Minutes); + + -- Seconds_Count needs 64 bits, since Time has the full range of + -- Duration. The delta of Duration is 10 ** (-9), so the maximum + -- number of seconds is 2**63/10**9 = 8*10**9 which does not quite + -- fit in 32 bits. + + type Seconds_Count is range -2 ** 63 .. 2 ** 63 - 1; + + procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span); + function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time; + +private + type Time is new Duration; + + Time_First : constant Time := Time'First; + + Time_Last : constant Time := Time'Last; + + type Time_Span is new Duration; + + Time_Span_First : constant Time_Span := Time_Span'First; + + Time_Span_Last : constant Time_Span := Time_Span'Last; + + Time_Span_Zero : constant Time_Span := 0.0; + + Time_Span_Unit : constant Time_Span := 10#1.0#E-9; + + Tick : constant Time_Span := + Time_Span (System.Task_Primitives.Operations.RT_Resolution); + + -- Time and Time_Span are represented in 64-bit Duration value in + -- in nanoseconds. For example, 1 second and 1 nanosecond is + -- represented as the stored integer 1_000_000_001. + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "abs"); + + pragma Inline (Microseconds); + pragma Inline (Milliseconds); + pragma Inline (Nanoseconds); + pragma Inline (Seconds); + pragma Inline (Minutes); + +end Ada.Real_Time; diff --git a/gcc/ada/a-retide.adb b/gcc/ada/a-retide.adb new file mode 100644 index 000000000..ecc61f691 --- /dev/null +++ b/gcc/ada/a-retide.adb @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . R E A L _ T I M E . D E L A Y S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, 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 Ada.Exceptions; + +with System.Tasking; +with System.Task_Primitives.Operations; + +package body Ada.Real_Time.Delays is + + package STPO renames System.Task_Primitives.Operations; + + ---------------- + -- Local Data -- + ---------------- + + Absolute_RT : constant := 2; + + ----------------- + -- Delay_Until -- + ----------------- + + procedure Delay_Until (T : Time) is + Self_Id : constant System.Tasking.Task_Id := STPO.Self; + + begin + -- If pragma Detect_Blocking is active, Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if System.Tasking.Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + else + STPO.Timed_Delay (Self_Id, To_Duration (T), Absolute_RT); + end if; + end Delay_Until; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (T : Time) return Duration is + begin + return To_Duration (Time_Span (T)); + end To_Duration; + +end Ada.Real_Time.Delays; diff --git a/gcc/ada/a-retide.ads b/gcc/ada/a-retide.ads new file mode 100644 index 000000000..25880c67a --- /dev/null +++ b/gcc/ada/a-retide.ads @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . R E A L _ T I M E . D E L A Y S -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Implements Real_Time.Time absolute delays + +-- Note: the compiler generates direct calls to this interface, in the +-- processing of time types. + +package Ada.Real_Time.Delays is + + function To_Duration (T : Real_Time.Time) return Duration; + -- Convert Time to Duration + + 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. + +end Ada.Real_Time.Delays; diff --git a/gcc/ada/a-rttiev.adb b/gcc/ada/a-rttiev.adb new file mode 100644 index 000000000..1c1fe859d --- /dev/null +++ b/gcc/ada/a-rttiev.adb @@ -0,0 +1,372 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . R E A L _ T I M E . T I M I N G _ E V E N T S -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Task_Primitives.Operations; +with System.Tasking.Utilities; +with System.Soft_Links; +with System.Interrupt_Management.Operations; + +with Ada.Containers.Doubly_Linked_Lists; +pragma Elaborate_All (Ada.Containers.Doubly_Linked_Lists); + +--------------------------------- +-- Ada.Real_Time.Timing_Events -- +--------------------------------- + +package body Ada.Real_Time.Timing_Events is + + use System.Task_Primitives.Operations; + + package SSL renames System.Soft_Links; + + type Any_Timing_Event is access all Timing_Event'Class; + -- We must also handle user-defined types derived from Timing_Event + + ------------ + -- Events -- + ------------ + + package Events is new Ada.Containers.Doubly_Linked_Lists (Any_Timing_Event); + -- Provides the type for the container holding pointers to events + + All_Events : Events.List; + -- The queue of pending events, ordered by increasing timeout value, that + -- have been "set" by the user via Set_Handler. + + Event_Queue_Lock : aliased System.Task_Primitives.RTS_Lock; + -- Used for mutually exclusive access to All_Events + + procedure Process_Queued_Events; + -- Examine the queue of pending events for any that have timed out. For + -- those that have timed out, remove them from the queue and invoke their + -- handler (unless the user has cancelled the event by setting the handler + -- pointer to null). Mutually exclusive access is held via Event_Queue_Lock + -- during part of the processing. + + procedure Insert_Into_Queue (This : Any_Timing_Event); + -- Insert the specified event pointer into the queue of pending events + -- with mutually exclusive access via Event_Queue_Lock. + + procedure Remove_From_Queue (This : Any_Timing_Event); + -- Remove the specified event pointer from the queue of pending events with + -- mutually exclusive access via Event_Queue_Lock. This procedure is used + -- by the client-side routines (Set_Handler, etc.). + + ----------- + -- Timer -- + ----------- + + task Timer is + pragma Priority (System.Priority'Last); + entry Start; + end Timer; + + task body Timer is + Period : constant Time_Span := Milliseconds (100); + -- This is a "chiming" clock timer that fires periodically. The period + -- selected is arbitrary and could be changed to suit the application + -- requirements. Obviously a shorter period would give better resolution + -- at the cost of more overhead. + + begin + System.Tasking.Utilities.Make_Independent; + + -- Since this package may be elaborated before System.Interrupt, + -- we need to call Setup_Interrupt_Mask explicitly to ensure that + -- this task has the proper signal mask. + + System.Interrupt_Management.Operations.Setup_Interrupt_Mask; + + -- We await the call to Start to ensure that Event_Queue_Lock has been + -- initialized by the package executable part prior to accessing it in + -- the loop. The task is activated before the first statement of the + -- executable part so it would otherwise be possible for the task to + -- call EnterCriticalSection in Process_Queued_Events before the + -- initialization. + + -- We don't simply put the initialization here, prior to the loop, + -- because other application tasks could call the visible routines that + -- also call Enter/LeaveCriticalSection prior to this task doing the + -- initialization. + + accept Start; + + loop + Process_Queued_Events; + delay until Clock + Period; + end loop; + end Timer; + + --------------------------- + -- Process_Queued_Events -- + --------------------------- + + procedure Process_Queued_Events is + Next_Event : Any_Timing_Event; + + begin + loop + SSL.Abort_Defer.all; + + Write_Lock (Event_Queue_Lock'Access); + + if All_Events.Is_Empty then + Unlock (Event_Queue_Lock'Access); + SSL.Abort_Undefer.all; + return; + else + Next_Event := All_Events.First_Element; + end if; + + if Next_Event.Timeout > Clock then + + -- We found one that has not yet timed out. The queue is in + -- ascending order by Timeout so there is no need to continue + -- processing (and indeed we must not continue since we always + -- delete the first element). + + Unlock (Event_Queue_Lock'Access); + SSL.Abort_Undefer.all; + return; + end if; + + -- We have an event that has timed out so we will process it. It must + -- be the first in the queue so no search is needed. + + All_Events.Delete_First; + + -- A fundamental issue is that the invocation of the event's handler + -- might call Set_Handler on itself to re-insert itself back into the + -- queue of future events. Thus we cannot hold the lock on the queue + -- while invoking the event's handler. + + Unlock (Event_Queue_Lock'Access); + + SSL.Abort_Undefer.all; + + -- There is no race condition with the user changing the handler + -- pointer while we are processing because we are executing at the + -- highest possible application task priority and are not doing + -- anything to block prior to invoking their handler. + + declare + Handler : constant Timing_Event_Handler := Next_Event.Handler; + + begin + -- The first act is to clear the event, per D.15(13/2). Besides, + -- we cannot clear the handler pointer *after* invoking the + -- handler because the handler may have re-inserted the event via + -- Set_Event. Thus we take a copy and then clear the component. + + Next_Event.Handler := null; + + if Handler /= null then + Handler.all (Timing_Event (Next_Event.all)); + end if; + + -- Ignore exceptions propagated by Handler.all, as required by + -- RM D.15(21/2). + + exception + when others => + null; + end; + end loop; + end Process_Queued_Events; + + ----------------------- + -- Insert_Into_Queue -- + ----------------------- + + procedure Insert_Into_Queue (This : Any_Timing_Event) is + + function Sooner (Left, Right : Any_Timing_Event) return Boolean; + -- Compares events in terms of timeout values + + package By_Timeout is new Events.Generic_Sorting (Sooner); + -- Used to keep the events in ascending order by timeout value + + ------------ + -- Sooner -- + ------------ + + function Sooner (Left, Right : Any_Timing_Event) return Boolean is + begin + return Left.Timeout < Right.Timeout; + end Sooner; + + -- Start of processing for Insert_Into_Queue + + begin + SSL.Abort_Defer.all; + + Write_Lock (Event_Queue_Lock'Access); + + All_Events.Append (This); + + -- A critical property of the implementation of this package is that + -- all occurrences are in ascending order by Timeout. Thus the first + -- event in the queue always has the "next" value for the Timer task + -- to use in its delay statement. + + By_Timeout.Sort (All_Events); + + Unlock (Event_Queue_Lock'Access); + + SSL.Abort_Undefer.all; + end Insert_Into_Queue; + + ----------------------- + -- Remove_From_Queue -- + ----------------------- + + procedure Remove_From_Queue (This : Any_Timing_Event) is + use Events; + Location : Cursor; + + begin + SSL.Abort_Defer.all; + + Write_Lock (Event_Queue_Lock'Access); + + Location := All_Events.Find (This); + + if Location /= No_Element then + All_Events.Delete (Location); + end if; + + Unlock (Event_Queue_Lock'Access); + + SSL.Abort_Undefer.all; + end Remove_From_Queue; + + ----------------- + -- Set_Handler -- + ----------------- + + procedure Set_Handler + (Event : in out Timing_Event; + At_Time : Time; + Handler : Timing_Event_Handler) + is + begin + Remove_From_Queue (Event'Unchecked_Access); + Event.Handler := null; + + -- RM D.15(15/2) requires that at this point, we check whether the time + -- has already passed, and if so, call Handler.all directly from here + -- instead of doing the enqueuing below. However, this causes a nasty + -- race condition and potential deadlock. If the current task has + -- already locked the protected object of Handler.all, and the time has + -- passed, deadlock would occur. Therefore, we ignore the requirement. + -- The same comment applies to the other Set_Handler below. + + if Handler /= null then + Event.Timeout := At_Time; + Event.Handler := Handler; + Insert_Into_Queue (Event'Unchecked_Access); + end if; + end Set_Handler; + + ----------------- + -- Set_Handler -- + ----------------- + + procedure Set_Handler + (Event : in out Timing_Event; + In_Time : Time_Span; + Handler : Timing_Event_Handler) + is + begin + Remove_From_Queue (Event'Unchecked_Access); + Event.Handler := null; + + -- See comment in the other Set_Handler above + + if Handler /= null then + Event.Timeout := Clock + In_Time; + Event.Handler := Handler; + Insert_Into_Queue (Event'Unchecked_Access); + end if; + end Set_Handler; + + --------------------- + -- Current_Handler -- + --------------------- + + function Current_Handler + (Event : Timing_Event) return Timing_Event_Handler + is + begin + return Event.Handler; + end Current_Handler; + + -------------------- + -- Cancel_Handler -- + -------------------- + + procedure Cancel_Handler + (Event : in out Timing_Event; + Cancelled : out Boolean) + is + begin + Remove_From_Queue (Event'Unchecked_Access); + Cancelled := Event.Handler /= null; + Event.Handler := null; + end Cancel_Handler; + + ------------------- + -- Time_Of_Event -- + ------------------- + + function Time_Of_Event (Event : Timing_Event) return Time is + begin + -- RM D.15(18/2): Time_First must be returned in the event is not set + + return (if Event.Handler = null then Time_First else Event.Timeout); + end Time_Of_Event; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (This : in out Timing_Event) is + begin + -- D.15 (19/2) says finalization clears the event + + This.Handler := null; + Remove_From_Queue (This'Unchecked_Access); + end Finalize; + +begin + Initialize_Lock (Event_Queue_Lock'Access, Level => PO_Level); + Timer.Start; +end Ada.Real_Time.Timing_Events; diff --git a/gcc/ada/a-rttiev.ads b/gcc/ada/a-rttiev.ads new file mode 100644 index 000000000..25f58ca51 --- /dev/null +++ b/gcc/ada/a-rttiev.ads @@ -0,0 +1,81 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . R E A L _ T I M E . T I M I N G _ E V E N T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2005-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.Real_Time.Timing_Events is + + type Timing_Event is tagged limited private; + + type Timing_Event_Handler + is access protected procedure (Event : in out Timing_Event); + + procedure Set_Handler + (Event : in out Timing_Event; + At_Time : Time; + Handler : Timing_Event_Handler); + + procedure Set_Handler + (Event : in out Timing_Event; + In_Time : Time_Span; + Handler : Timing_Event_Handler); + + function Current_Handler + (Event : Timing_Event) return Timing_Event_Handler; + + procedure Cancel_Handler + (Event : in out Timing_Event; + Cancelled : out Boolean); + + function Time_Of_Event (Event : Timing_Event) return Time; + +private + + type Timing_Event is new Ada.Finalization.Limited_Controlled with record + Timeout : Time := Time_First; + -- The time at which the user's handler should be invoked when the + -- event is "set" (i.e., when Handler is not null). + + Handler : Timing_Event_Handler; + -- An access value designating the protected procedure to be invoked + -- at the Timeout time in the future. When this value is null the event + -- is said to be "cleared" and no timeout is processed. + end record; + + overriding procedure Finalize (This : in out Timing_Event); + -- Finalization procedure is required to satisfy (RM D.15 (19/2)), which + -- says that the object must be cleared on finalization. + +end Ada.Real_Time.Timing_Events; diff --git a/gcc/ada/a-scteio.ads b/gcc/ada/a-scteio.ads new file mode 100755 index 000000000..d9ceb2f9c --- /dev/null +++ b/gcc/ada/a-scteio.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ C O M P L E X _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Ada 2005 AI-328 + +with Ada.Text_IO.Complex_IO; +with Ada.Numerics.Short_Complex_Types; + +pragma Elaborate_All (Ada.Text_IO.Complex_IO); + +package Ada.Short_Complex_Text_IO is + new Ada.Text_IO.Complex_IO (Ada.Numerics.Short_Complex_Types); diff --git a/gcc/ada/a-secain.adb b/gcc/ada/a-secain.adb new file mode 100644 index 000000000..e77198ead --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along 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 new file mode 100644 index 000000000..c5e747b13 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception 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 new file mode 100644 index 000000000..f0a51417a --- /dev/null +++ b/gcc/ada/a-sequio.adb @@ -0,0 +1,271 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 Interfaces.C_Streams; use Interfaces.C_Streams; +with System; +with System.CRTL; +with System.File_Control_Block; +with System.File_IO; +with System.Storage_Elements; +with Ada.Unchecked_Conversion; + +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.CRTL.size_t; + + ----------- + -- Close -- + ----------- + + procedure Close (File : in out File_Type) is + begin + FIO.Close (AP (File)'Unrestricted_Access); + end Close; + + ------------ + -- Create -- + ------------ + + procedure Create + (File : in out File_Type; + Mode : File_Mode := 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; + + ---------- + -- 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); + + -- For a type with discriminants, we have to read into a temporary + -- buffer if Item is constrained, to check that the discriminants + -- are correct. + + pragma Extensions_Allowed (On); + -- Needed to allow Constrained reference here + + 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; + + 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 + FIO.Write_Buf + (AP (File), 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 new file mode 100644 index 000000000..a728c5403 --- /dev/null +++ b/gcc/ada/a-sequio.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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.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; + + --------------------------------- + -- 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-sfteio.ads b/gcc/ada/a-sfteio.ads new file mode 100644 index 000000000..a1f18cd85 --- /dev/null +++ b/gcc/ada/a-sfteio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ F L O A T _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Short_Float_Text_IO is + new Ada.Text_IO.Float_IO (Short_Float); diff --git a/gcc/ada/a-sfwtio.ads b/gcc/ada/a-sfwtio.ads new file mode 100644 index 000000000..3ac134e93 --- /dev/null +++ b/gcc/ada/a-sfwtio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ F L O A T _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Short_Float_Wide_Text_IO is + new Ada.Wide_Text_IO.Float_IO (Short_Float); diff --git a/gcc/ada/a-sfztio.ads b/gcc/ada/a-sfztio.ads new file mode 100644 index 000000000..bc34e5d5a --- /dev/null +++ b/gcc/ada/a-sfztio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ F L O A T _ W I D E _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Short_Float_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Float_IO (Short_Float); diff --git a/gcc/ada/a-shcain.adb b/gcc/ada/a-shcain.adb new file mode 100644 index 000000000..8c7ccbef4 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along 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 new file mode 100644 index 000000000..fa3123c96 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along 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 new file mode 100644 index 000000000..cfffa3080 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 new file mode 100644 index 000000000..85063b4fb --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface between Ada.Sequential_IO and the +-- C streams. This allows sharing of a stream between Ada and C or C++, +-- as well as allowing the Ada program to operate directly on the stream. + +with Interfaces.C_Streams; + +generic +package Ada.Sequential_IO.C_Streams is + + package ICS renames Interfaces.C_Streams; + + function C_Stream (F : File_Type) return ICS.FILEs; + -- Obtain stream from existing open file + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + C_Stream : ICS.FILEs; + Form : String := ""; + Name : String := ""); + -- Create new file from existing stream + +end Ada.Sequential_IO.C_Streams; diff --git a/gcc/ada/a-siteio.ads b/gcc/ada/a-siteio.ads new file mode 100644 index 000000000..de45c22cc --- /dev/null +++ b/gcc/ada/a-siteio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ I N T E G E R _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Short_Integer_Text_IO is + new Ada.Text_IO.Integer_IO (Short_Integer); diff --git a/gcc/ada/a-siwtio.ads b/gcc/ada/a-siwtio.ads new file mode 100644 index 000000000..aa1a2d456 --- /dev/null +++ b/gcc/ada/a-siwtio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ I N T E G E R _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Short_Integer_Wide_Text_IO is + new Ada.Wide_Text_IO.Integer_IO (Short_Integer); diff --git a/gcc/ada/a-siztio.ads b/gcc/ada/a-siztio.ads new file mode 100644 index 000000000..3d6f5cdf1 --- /dev/null +++ b/gcc/ada/a-siztio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ I N T E G E R _ W I D E _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Short_Integer_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Integer_IO (Short_Integer); diff --git a/gcc/ada/a-slcain.adb b/gcc/ada/a-slcain.adb new file mode 100644 index 000000000..5e3fd6b0c --- /dev/null +++ b/gcc/ada/a-slcain.adb @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 new file mode 100644 index 000000000..1327c30dd --- /dev/null +++ b/gcc/ada/a-slcain.ads @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.LESS_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +function Ada.Strings.Less_Case_Insensitive + (Left, Right : String) return Boolean; +pragma Pure (Ada.Strings.Less_Case_Insensitive); +-- Performs a case-insensitive lexicographic comparison of Left and +-- Right. This is useful as the generic actual less-than operator when +-- instantiating an ordered container package with type String as the key, +-- allowing case-insensitive equivalence tests. diff --git a/gcc/ada/a-ssicst.adb b/gcc/ada/a-ssicst.adb new file mode 100644 index 000000000..4cf49f29c --- /dev/null +++ b/gcc/ada/a-ssicst.adb @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R E A M S . S T R E A M _ I O . C _ S T R E A M S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System.File_IO; +with System.File_Control_Block; +with Ada.Unchecked_Conversion; + +package body Ada.Streams.Stream_IO.C_Streams is + + package FIO renames System.File_IO; + package FCB renames System.File_Control_Block; + + subtype AP is FCB.AFCB_Ptr; + + function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); + + -------------- + -- C_Stream -- + -------------- + + function C_Stream (F : File_Type) return FILEs is + begin + FIO.Check_File_Open (AP (F)); + return F.Stream; + end C_Stream; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + C_Stream : FILEs; + Form : String := ""; + Name : String := "") + is + Dummy_File_Control_Block : Stream_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'S', + Creat => False, + Text => False, + C_Stream => C_Stream); + end Open; + +end Ada.Streams.Stream_IO.C_Streams; diff --git a/gcc/ada/a-ssicst.ads b/gcc/ada/a-ssicst.ads new file mode 100644 index 000000000..733f54e91 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface between Ada.Stream_IO and the +-- C streams. This allows sharing of a stream between Ada and C or C++, +-- as well as allowing the Ada program to operate directly on the stream. + +with Interfaces.C_Streams; + +package Ada.Streams.Stream_IO.C_Streams is + + package ICS renames Interfaces.C_Streams; + + function C_Stream (F : File_Type) return ICS.FILEs; + -- Obtain stream from existing open file + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + C_Stream : ICS.FILEs; + Form : String := ""; + Name : String := ""); + -- Create new file from existing stream + +end Ada.Streams.Stream_IO.C_Streams; diff --git a/gcc/ada/a-ssitio.ads b/gcc/ada/a-ssitio.ads new file mode 100644 index 000000000..98b054088 --- /dev/null +++ b/gcc/ada/a-ssitio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ S H O R T _ I N T E G E R _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Short_Short_Integer_Text_IO is + new Ada.Text_IO.Integer_IO (Short_Short_Integer); diff --git a/gcc/ada/a-ssiwti.ads b/gcc/ada/a-ssiwti.ads new file mode 100644 index 000000000..5f6934ba6 --- /dev/null +++ b/gcc/ada/a-ssiwti.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ S H O R T _ I N T E G E R _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Short_Short_Integer_Wide_Text_IO is + new Ada.Wide_Text_IO.Integer_IO (Short_Short_Integer); diff --git a/gcc/ada/a-ssizti.ads b/gcc/ada/a-ssizti.ads new file mode 100644 index 000000000..13bfda846 --- /dev/null +++ b/gcc/ada/a-ssizti.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ S H O R T _ I N T E G E R _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Short_Short_Integer_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Integer_IO (Short_Short_Integer); diff --git a/gcc/ada/a-stboha.adb b/gcc/ada/a-stboha.adb new file mode 100644 index 000000000..97ae52666 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System.String_Hash; + +function Ada.Strings.Bounded.Hash (Key : Bounded.Bounded_String) + return Containers.Hash_Type +is + use Ada.Containers; + function Hash_Fun is new System.String_Hash.Hash + (Character, String, Hash_Type); +begin + return Hash_Fun (Bounded.To_String (Key)); +end Ada.Strings.Bounded.Hash; diff --git a/gcc/ada/a-stboha.ads b/gcc/ada/a-stboha.ads new file mode 100644 index 000000000..876af2a5d --- /dev/null +++ b/gcc/ada/a-stboha.ads @@ -0,0 +1,25 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . B O U N D E D . H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers; + +generic + with package Bounded is + new Ada.Strings.Bounded.Generic_Bounded_Length (<>); + +function Ada.Strings.Bounded.Hash (Key : Bounded.Bounded_String) + return Containers.Hash_Type; + +pragma Preelaborate (Ada.Strings.Bounded.Hash); diff --git a/gcc/ada/a-stfiha.ads b/gcc/ada/a-stfiha.ads new file mode 100644 index 000000000..aba42e7c6 --- /dev/null +++ b/gcc/ada/a-stfiha.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . F I X E D . H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers, Ada.Strings.Hash; + +function Ada.Strings.Fixed.Hash (Key : String) return Containers.Hash_Type + renames Ada.Strings.Hash; + +pragma Pure (Ada.Strings.Fixed.Hash); diff --git a/gcc/ada/a-stmaco.ads b/gcc/ada/a-stmaco.ads new file mode 100644 index 000000000..733dfc66d --- /dev/null +++ b/gcc/ada/a-stmaco.ads @@ -0,0 +1,916 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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.Latin_1; + +package Ada.Strings.Maps.Constants is + pragma Preelaborate; + pragma Pure_05; + -- 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 new file mode 100644 index 000000000..50b7665b7 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +package body Ada.Storage_IO is + + type Buffer_Ptr is access all Buffer_Type; + type Elmt_Ptr is access all Element_Type; + + function To_Buffer_Ptr is + new Ada.Unchecked_Conversion (Elmt_Ptr, Buffer_Ptr); + + ---------- + -- Read -- + ---------- + + procedure Read (Buffer : Buffer_Type; Item : out Element_Type) is + begin + To_Buffer_Ptr (Item'Unrestricted_Access).all := Buffer; + end Read; + + ----------- + -- Write -- + ----------- + + procedure Write (Buffer : out Buffer_Type; Item : Element_Type) is + begin + Buffer := To_Buffer_Ptr (Item'Unrestricted_Access).all; + end Write; + +end Ada.Storage_IO; diff --git a/gcc/ada/a-storio.ads b/gcc/ada/a-storio.ads new file mode 100644 index 000000000..db0a70bbe --- /dev/null +++ b/gcc/ada/a-storio.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T O R A G E _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.IO_Exceptions; +with System.Storage_Elements; + +generic + type Element_Type is private; + +package Ada.Storage_IO is + pragma Preelaborate; + + Buffer_Size : constant System.Storage_Elements.Storage_Count := + System.Storage_Elements.Storage_Count + ((Element_Type'Size + System.Storage_Unit - 1) / + System.Storage_Unit); + + subtype Buffer_Type is + System.Storage_Elements.Storage_Array (1 .. Buffer_Size); + + --------------------------------- + -- Input and Output Operations -- + --------------------------------- + + procedure Read (Buffer : Buffer_Type; Item : out Element_Type); + + procedure Write (Buffer : out Buffer_Type; Item : Element_Type); + + ---------------- + -- Exceptions -- + ---------------- + + Data_Error : exception renames IO_Exceptions.Data_Error; + +end Ada.Storage_IO; diff --git a/gcc/ada/a-strbou.adb b/gcc/ada/a-strbou.adb new file mode 100644 index 000000000..370371fd5 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..ddc8c3376 --- /dev/null +++ b/gcc/ada/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-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.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; + + 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.ads b/gcc/ada/a-stream.ads new file mode 100644 index 000000000..a9bb7cdc4 --- /dev/null +++ b/gcc/ada/a-stream.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R E A M 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. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Streams is + pragma Pure; + + type Root_Stream_Type is abstract tagged limited private; + pragma Preelaborable_Initialization (Root_Stream_Type); + + type Stream_Element is mod 2 ** Standard'Storage_Unit; + + type Stream_Element_Offset is range + -(2 ** (Standard'Address_Size - 1)) .. + +(2 ** (Standard'Address_Size - 1)) - 1; + + subtype Stream_Element_Count is + Stream_Element_Offset range 0 .. Stream_Element_Offset'Last; + + type Stream_Element_Array is + array (Stream_Element_Offset range <>) of aliased Stream_Element; + + procedure Read + (Stream : in out Root_Stream_Type; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset) + is abstract; + + procedure Write + (Stream : in out Root_Stream_Type; + Item : Stream_Element_Array) + is abstract; + +private + + type Root_Stream_Type is abstract tagged limited null record; + +end Ada.Streams; diff --git a/gcc/ada/a-strfix.adb b/gcc/ada/a-strfix.adb new file mode 100644 index 000000000..6bb0229c7 --- /dev/null +++ b/gcc/ada/a-strfix.adb @@ -0,0 +1,738 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . F I X E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: This code is derived from the ADAR.CSH public domain Ada 83 versions +-- of the Appendix C string handling packages. One change is to avoid the use +-- of Is_In, so that we are not dependent on inlining. Note that the search +-- function implementations are to be found in the auxiliary package +-- Ada.Strings.Search. Also the Move procedure is directly incorporated (ADAR +-- used a subunit for this procedure). The number of errors having to do with +-- bounds of function return results were also fixed, and use of & removed for +-- efficiency reasons. + +with Ada.Strings.Maps; use Ada.Strings.Maps; +with Ada.Strings.Search; + +package body Ada.Strings.Fixed is + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + renames Ada.Strings.Search.Index; + + function Index + (Source : String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural + renames Ada.Strings.Search.Index; + + function Index + (Source : String; + Set : Maps.Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + renames Ada.Strings.Search.Index; + + function Index + (Source : String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + renames Ada.Strings.Search.Index; + + function Index + (Source : String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural + renames Ada.Strings.Search.Index; + + function Index + (Source : String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + renames Ada.Strings.Search.Index; + + function Index_Non_Blank + (Source : String; + Going : Direction := Forward) return Natural + renames Ada.Strings.Search.Index_Non_Blank; + + function Index_Non_Blank + (Source : String; + From : Positive; + Going : Direction := Forward) return Natural + renames Ada.Strings.Search.Index_Non_Blank; + + function Count + (Source : String; + Pattern : String; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + renames Ada.Strings.Search.Count; + + function Count + (Source : String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function) return Natural + renames Ada.Strings.Search.Count; + + function Count + (Source : String; + Set : Maps.Character_Set) return Natural + renames Ada.Strings.Search.Count; + + procedure Find_Token + (Source : String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural) + renames Ada.Strings.Search.Find_Token; + + procedure Find_Token + (Source : String; + Set : Maps.Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural) + renames Ada.Strings.Search.Find_Token; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Character) return String + is + Result : String (1 .. Left); + + begin + for J in Result'Range loop + Result (J) := Right; + end loop; + + return Result; + end "*"; + + function "*" + (Left : Natural; + Right : String) return String + is + Result : String (1 .. Left * Right'Length); + Ptr : Integer := 1; + + begin + for J in 1 .. Left loop + Result (Ptr .. Ptr + Right'Length - 1) := Right; + Ptr := Ptr + Right'Length; + end loop; + + return Result; + end "*"; + + ------------ + -- Delete -- + ------------ + + function Delete + (Source : String; + From : Positive; + Through : Natural) return String + is + begin + if From > Through then + declare + subtype Result_Type is String (1 .. Source'Length); + + begin + return Result_Type (Source); + end; + + elsif From not in Source'Range + or else Through > Source'Last + then + raise Index_Error; + + else + declare + Front : constant Integer := From - Source'First; + Result : String (1 .. Source'Length - (Through - From + 1)); + + begin + Result (1 .. Front) := + Source (Source'First .. From - 1); + Result (Front + 1 .. Result'Last) := + Source (Through + 1 .. Source'Last); + + return Result; + end; + end if; + end Delete; + + procedure Delete + (Source : in out String; + From : Positive; + Through : Natural; + Justify : Alignment := Left; + Pad : Character := Space) + is + begin + Move (Source => Delete (Source, From, Through), + Target => Source, + Justify => Justify, + Pad => Pad); + end Delete; + + ---------- + -- Head -- + ---------- + + function Head + (Source : String; + Count : Natural; + Pad : Character := Space) return String + is + subtype Result_Type is String (1 .. Count); + + begin + if Count < Source'Length then + return + Result_Type (Source (Source'First .. Source'First + Count - 1)); + + else + declare + Result : Result_Type; + + begin + Result (1 .. Source'Length) := Source; + + for J in Source'Length + 1 .. Count loop + Result (J) := Pad; + end loop; + + return Result; + end; + end if; + end Head; + + procedure Head + (Source : in out String; + Count : Natural; + Justify : Alignment := Left; + Pad : Character := Space) + is + begin + Move (Source => Head (Source, Count, Pad), + Target => Source, + Drop => Error, + Justify => Justify, + Pad => Pad); + end Head; + + ------------ + -- Insert -- + ------------ + + function Insert + (Source : String; + Before : Positive; + New_Item : String) return String + is + Result : String (1 .. Source'Length + New_Item'Length); + Front : constant Integer := Before - Source'First; + + begin + if Before not in Source'First .. Source'Last + 1 then + raise Index_Error; + end if; + + Result (1 .. Front) := + Source (Source'First .. Before - 1); + Result (Front + 1 .. Front + New_Item'Length) := + New_Item; + Result (Front + New_Item'Length + 1 .. Result'Last) := + Source (Before .. Source'Last); + + return Result; + end Insert; + + procedure Insert + (Source : in out String; + Before : Positive; + New_Item : String; + Drop : Truncation := Error) + is + begin + Move (Source => Insert (Source, Before, New_Item), + Target => Source, + Drop => Drop); + end Insert; + + ---------- + -- Move -- + ---------- + + procedure Move + (Source : String; + Target : out String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Character := Space) + is + Sfirst : constant Integer := Source'First; + Slast : constant Integer := Source'Last; + Slength : constant Integer := Source'Length; + + Tfirst : constant Integer := Target'First; + Tlast : constant Integer := Target'Last; + Tlength : constant Integer := Target'Length; + + function Is_Padding (Item : String) return Boolean; + -- Check if Item is all Pad characters, return True if so, False if not + + function Is_Padding (Item : String) return Boolean is + begin + for J in Item'Range loop + if Item (J) /= Pad then + return False; + end if; + end loop; + + return True; + end Is_Padding; + + -- Start of processing for Move + + begin + if Slength = Tlength then + Target := Source; + + elsif Slength > Tlength then + + case Drop is + when Left => + Target := Source (Slast - Tlength + 1 .. Slast); + + when Right => + Target := Source (Sfirst .. Sfirst + Tlength - 1); + + when Error => + case Justify is + when Left => + if Is_Padding (Source (Sfirst + Tlength .. Slast)) then + Target := + Source (Sfirst .. Sfirst + Target'Length - 1); + else + raise Length_Error; + end if; + + when Right => + if Is_Padding (Source (Sfirst .. Slast - Tlength)) then + Target := Source (Slast - Tlength + 1 .. Slast); + else + raise Length_Error; + end if; + + when Center => + raise Length_Error; + end case; + + end case; + + -- Source'Length < Target'Length + + else + case Justify is + when Left => + Target (Tfirst .. Tfirst + Slength - 1) := Source; + + for I in Tfirst + Slength .. Tlast loop + Target (I) := Pad; + end loop; + + when Right => + for I in Tfirst .. Tlast - Slength loop + Target (I) := Pad; + end loop; + + Target (Tlast - Slength + 1 .. Tlast) := Source; + + when Center => + declare + Front_Pad : constant Integer := (Tlength - Slength) / 2; + Tfirst_Fpad : constant Integer := Tfirst + Front_Pad; + + begin + for I in Tfirst .. Tfirst_Fpad - 1 loop + Target (I) := Pad; + end loop; + + Target (Tfirst_Fpad .. Tfirst_Fpad + Slength - 1) := Source; + + for I in Tfirst_Fpad + Slength .. Tlast loop + Target (I) := Pad; + end loop; + end; + end case; + end if; + end Move; + + --------------- + -- Overwrite -- + --------------- + + function Overwrite + (Source : String; + Position : Positive; + New_Item : String) return String + is + begin + if Position not in Source'First .. Source'Last + 1 then + raise Index_Error; + end if; + + declare + Result_Length : constant Natural := + Integer'Max + (Source'Length, + Position - Source'First + New_Item'Length); + + Result : String (1 .. Result_Length); + Front : constant Integer := Position - Source'First; + + begin + Result (1 .. Front) := + Source (Source'First .. Position - 1); + Result (Front + 1 .. Front + New_Item'Length) := + New_Item; + Result (Front + New_Item'Length + 1 .. Result'Length) := + Source (Position + New_Item'Length .. Source'Last); + return Result; + end; + end Overwrite; + + procedure Overwrite + (Source : in out String; + Position : Positive; + New_Item : String; + Drop : Truncation := Right) + is + begin + Move (Source => Overwrite (Source, Position, New_Item), + Target => Source, + Drop => Drop); + end Overwrite; + + ------------------- + -- Replace_Slice -- + ------------------- + + function Replace_Slice + (Source : String; + Low : Positive; + High : Natural; + By : String) return String + is + begin + if Low > Source'Last + 1 or else High < Source'First - 1 then + raise Index_Error; + end if; + + if High >= Low then + declare + Front_Len : constant Integer := + Integer'Max (0, Low - Source'First); + -- Length of prefix of Source copied to result + + Back_Len : constant Integer := + Integer'Max (0, Source'Last - High); + -- Length of suffix of Source copied to result + + Result_Length : constant Integer := + Front_Len + By'Length + Back_Len; + -- Length of result + + Result : String (1 .. Result_Length); + + begin + Result (1 .. Front_Len) := + Source (Source'First .. Low - 1); + Result (Front_Len + 1 .. Front_Len + By'Length) := + By; + Result (Front_Len + By'Length + 1 .. Result'Length) := + Source (High + 1 .. Source'Last); + + return Result; + end; + + else + return Insert (Source, Before => Low, New_Item => By); + end if; + end Replace_Slice; + + procedure Replace_Slice + (Source : in out String; + Low : Positive; + High : Natural; + By : String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Character := Space) + is + begin + Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad); + end Replace_Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : String; + Count : Natural; + Pad : Character := Space) return String + is + subtype Result_Type is String (1 .. Count); + + begin + if Count < Source'Length then + return Result_Type (Source (Source'Last - Count + 1 .. Source'Last)); + + -- Pad on left + + else + declare + Result : Result_Type; + + begin + for J in 1 .. Count - Source'Length loop + Result (J) := Pad; + end loop; + + Result (Count - Source'Length + 1 .. Count) := Source; + return Result; + end; + end if; + end Tail; + + procedure Tail + (Source : in out String; + Count : Natural; + Justify : Alignment := Left; + Pad : Character := Space) + is + begin + Move (Source => Tail (Source, Count, Pad), + Target => Source, + Drop => Error, + Justify => Justify, + Pad => Pad); + end Tail; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : String; + Mapping : Maps.Character_Mapping) return String + is + Result : String (1 .. Source'Length); + + begin + for J in Source'Range loop + Result (J - (Source'First - 1)) := Value (Mapping, Source (J)); + end loop; + + return Result; + end Translate; + + procedure Translate + (Source : in out String; + Mapping : Maps.Character_Mapping) + is + begin + for J in Source'Range loop + Source (J) := Value (Mapping, Source (J)); + end loop; + end Translate; + + function Translate + (Source : String; + Mapping : Maps.Character_Mapping_Function) return String + is + Result : String (1 .. Source'Length); + pragma Unsuppress (Access_Check); + + begin + for J in Source'Range loop + Result (J - (Source'First - 1)) := Mapping.all (Source (J)); + end loop; + + return Result; + end Translate; + + procedure Translate + (Source : in out String; + Mapping : Maps.Character_Mapping_Function) + is + pragma Unsuppress (Access_Check); + begin + for J in Source'Range loop + Source (J) := Mapping.all (Source (J)); + end loop; + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : String; + Side : Trim_End) return String + is + Low, High : Integer; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks case + + if Low = 0 then + return ""; + + -- At least one non-blank + + else + High := Index_Non_Blank (Source, Backward); + + case Side is + when Strings.Left => + declare + subtype Result_Type is String (1 .. Source'Last - Low + 1); + + begin + return Result_Type (Source (Low .. Source'Last)); + end; + + when Strings.Right => + declare + subtype Result_Type is String (1 .. High - Source'First + 1); + + begin + return Result_Type (Source (Source'First .. High)); + end; + + when Strings.Both => + declare + subtype Result_Type is String (1 .. High - Low + 1); + + begin + return Result_Type (Source (Low .. High)); + end; + end case; + end if; + end Trim; + + procedure Trim + (Source : in out String; + Side : Trim_End; + Justify : Alignment := Left; + Pad : Character := Space) + is + begin + Move (Trim (Source, Side), + Source, + Justify => Justify, + Pad => Pad); + end Trim; + + function Trim + (Source : String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) return String + is + High, Low : Integer; + + begin + Low := Index (Source, Set => Left, Test => Outside, Going => Forward); + + -- Case where source comprises only characters in Left + + if Low = 0 then + return ""; + end if; + + High := + Index (Source, Set => Right, Test => Outside, Going => Backward); + + -- Case where source comprises only characters in Right + + if High = 0 then + return ""; + end if; + + declare + subtype Result_Type is String (1 .. High - Low + 1); + + begin + return Result_Type (Source (Low .. High)); + end; + end Trim; + + procedure Trim + (Source : in out String; + Left : Maps.Character_Set; + Right : Maps.Character_Set; + Justify : Alignment := Strings.Left; + Pad : Character := Space) + is + begin + Move (Source => Trim (Source, Left, Right), + Target => Source, + Justify => Justify, + Pad => Pad); + end Trim; + +end Ada.Strings.Fixed; diff --git a/gcc/ada/a-strfix.ads b/gcc/ada/a-strfix.ads new file mode 100644 index 000000000..56db8bc94 --- /dev/null +++ b/gcc/ada/a-strfix.ads @@ -0,0 +1,251 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . F I X E D -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Maps; + +package Ada.Strings.Fixed is + pragma Preelaborate; + + -------------------------------------------------------------- + -- Copy Procedure for Strings of Possibly Different Lengths -- + -------------------------------------------------------------- + + procedure Move + (Source : String; + Target : out String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Character := Space); + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Index + (Source : String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Index + (Source : String; + Set : Maps.Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : String; + Pattern : String; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Count + (Source : String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Count + (Source : String; + Set : Maps.Character_Set) return Natural; + + procedure Find_Token + (Source : String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + pragma Ada_2012 (Find_Token); + + procedure Find_Token + (Source : String; + Set : Maps.Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Translate + (Source : String; + Mapping : Maps.Character_Mapping) return String; + + procedure Translate + (Source : in out String; + Mapping : Maps.Character_Mapping); + + function Translate + (Source : String; + Mapping : Maps.Character_Mapping_Function) return String; + + procedure Translate + (Source : in out String; + Mapping : Maps.Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : String; + Low : Positive; + High : Natural; + By : String) return String; + + procedure Replace_Slice + (Source : in out String; + Low : Positive; + High : Natural; + By : String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Character := Space); + + function Insert + (Source : String; + Before : Positive; + New_Item : String) return String; + + procedure Insert + (Source : in out String; + Before : Positive; + New_Item : String; + Drop : Truncation := Error); + + function Overwrite + (Source : String; + Position : Positive; + New_Item : String) return String; + + procedure Overwrite + (Source : in out String; + Position : Positive; + New_Item : String; + Drop : Truncation := Right); + + function Delete + (Source : String; + From : Positive; + Through : Natural) return String; + + procedure Delete + (Source : in out String; + From : Positive; + Through : Natural; + Justify : Alignment := Left; + Pad : Character := Space); + + --------------------------------- + -- String Selector Subprograms -- + --------------------------------- + + function Trim + (Source : String; + Side : Trim_End) return String; + + procedure Trim + (Source : in out String; + Side : Trim_End; + Justify : Alignment := Left; + Pad : Character := Space); + + function Trim + (Source : String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) return String; + + procedure Trim + (Source : in out String; + Left : Maps.Character_Set; + Right : Maps.Character_Set; + Justify : Alignment := Strings.Left; + Pad : Character := Space); + + function Head + (Source : String; + Count : Natural; + Pad : Character := Space) return String; + + procedure Head + (Source : in out String; + Count : Natural; + Justify : Alignment := Left; + Pad : Character := Space); + + function Tail + (Source : String; + Count : Natural; + Pad : Character := Space) return String; + + procedure Tail + (Source : in out String; + Count : Natural; + Justify : Alignment := Left; + Pad : Character := Space); + + ---------------------------------- + -- String Constructor Functions -- + ---------------------------------- + + function "*" + (Left : Natural; + Right : Character) return String; + + function "*" + (Left : Natural; + Right : String) return String; + +end Ada.Strings.Fixed; diff --git a/gcc/ada/a-strhas.adb b/gcc/ada/a-strhas.adb new file mode 100644 index 000000000..f0ee0602f --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System.String_Hash; + +function Ada.Strings.Hash (Key : String) return Containers.Hash_Type is + use Ada.Containers; + function Hash is new System.String_Hash.Hash + (Character, String, Hash_Type); +begin + return Hash (Key); +end Ada.Strings.Hash; diff --git a/gcc/ada/a-strhas.ads b/gcc/ada/a-strhas.ads new file mode 100644 index 000000000..c2574d1e9 --- /dev/null +++ b/gcc/ada/a-strhas.ads @@ -0,0 +1,22 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit; + +with Ada.Containers; + +function Ada.Strings.Hash (Key : String) return Containers.Hash_Type; + +pragma Pure (Ada.Strings.Hash); diff --git a/gcc/ada/a-string.ads b/gcc/ada/a-string.ads new file mode 100644 index 000000000..51ca10247 --- /dev/null +++ b/gcc/ada/a-string.ads @@ -0,0 +1,35 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Strings is + pragma Pure; + + Space : constant Character := ' '; + Wide_Space : constant Wide_Character := ' '; + + -- The following declaration is for Ada 2005 (AI-285) + + Wide_Wide_Space : constant Wide_Wide_Character := ' '; + pragma Ada_05 (Wide_Wide_Space); + + Length_Error, Pattern_Error, Index_Error, Translation_Error : exception; + + type Alignment is (Left, Right, Center); + type Truncation is (Left, Right, Error); + type Membership is (Inside, Outside); + type Direction is (Forward, Backward); + type Trim_End is (Left, Right, Both); + +end Ada.Strings; diff --git a/gcc/ada/a-strmap.adb b/gcc/ada/a-strmap.adb new file mode 100644 index 000000000..071c02a68 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..2a6908ff3 --- /dev/null +++ b/gcc/ada/a-strmap.ads @@ -0,0 +1,412 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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.Latin_1; + +package Ada.Strings.Maps is + pragma Preelaborate; + pragma Pure_05; + -- 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 new file mode 100644 index 000000000..6f458ff23 --- /dev/null +++ b/gcc/ada/a-strsea.adb @@ -0,0 +1,607 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 + 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 : 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 + + First := Source'First; + Last := 0; + 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 + 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 : String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.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 : String; + Set : Maps.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 : String; + Going : Direction := Forward) return Natural + is + begin + if Going = Forward then + for J in Source'Range loop + if Source (J) /= ' ' then + return J; + end if; + end loop; + + else -- Going = Backward + for J in reverse Source'Range loop + if Source (J) /= ' ' then + return J; + end if; + end loop; + end if; + + -- Fall through if no match + + return 0; + end Index_Non_Blank; + + function Index_Non_Blank + (Source : String; + From : Positive; + Going : Direction := Forward) return Natural + is + begin + if Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return + Index_Non_Blank (Source (From .. Source'Last), Forward); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return + Index_Non_Blank (Source (Source'First .. From), Backward); + end if; + end Index_Non_Blank; + +end Ada.Strings.Search; diff --git a/gcc/ada/a-strsea.ads b/gcc/ada/a-strsea.ads new file mode 100644 index 000000000..bf8686815 --- /dev/null +++ b/gcc/ada/a-strsea.ads @@ -0,0 +1,121 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . S E A R C H -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the search functions from Ada.Strings.Fixed. They +-- are separated out because they are shared by Ada.Strings.Bounded and +-- Ada.Strings.Unbounded, and we don't want to drag other irrelevant stuff +-- from Ada.Strings.Fixed when using the other two packages. We make this +-- a private package, since user programs should access these subprograms +-- via one of the standard string packages. + +with Ada.Strings.Maps; + +private package Ada.Strings.Search is + pragma Preelaborate; + + function Index + (Source : String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Index + (Source : String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Index + (Source : String; + Set : Maps.Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Index + (Source : String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Index + (Source : String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : String; + From : Positive; + Going : Direction := Forward) return Natural; + + function Count + (Source : String; + Pattern : String; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Count + (Source : String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Count + (Source : String; + Set : Maps.Character_Set) return Natural; + + procedure Find_Token + (Source : String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + + procedure Find_Token + (Source : String; + Set : Maps.Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + +end Ada.Strings.Search; diff --git a/gcc/ada/a-strsup.adb b/gcc/ada/a-strsup.adb new file mode 100644 index 000000000..707d9ec70 --- /dev/null +++ b/gcc/ada/a-strsup.adb @@ -0,0 +1,1917 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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.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 + Result : Super_String (Left.Max_Length); + 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; + + return Result; + end Concat; + + function Concat + (Left : Super_String; + Right : String) return Super_String + is + Result : Super_String (Left.Max_Length); + 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; + return Result; + end Concat; + + function Concat + (Left : String; + Right : Super_String) return Super_String + is + Result : Super_String (Right.Max_Length); + 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; + + return Result; + end Concat; + + function Concat + (Left : Super_String; + Right : Character) return Super_String + is + Result : Super_String (Left.Max_Length); + 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; + + return Result; + end Concat; + + function Concat + (Left : Character; + Right : Super_String) return Super_String + is + Result : Super_String (Right.Max_Length); + 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; + + return Result; + 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 + + if Low > Source.Current_Length + 1 + or else High > Source.Current_Length + then + raise Index_Error; + else + return Source.Data (Low .. High); + end if; + end Super_Slice; + + function Super_Slice + (Source : Super_String; + Low : Positive; + High : Natural) return Super_String + is + Result : Super_String (Source.Max_Length); + + begin + 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; + + return Result; + 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 : 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 Source.Data (1 .. Source.Current_Length); + 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.Data := (others => ASCII.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 : 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); + + for J in Source.Current_Length + 1 .. + Source.Max_Length + loop + Source.Data (J) := ASCII.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 : 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.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 : 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 new file mode 100644 index 000000000..c88c563d3 --- /dev/null +++ b/gcc/ada/a-strsup.ads @@ -0,0 +1,488 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 Super_String (Max_Length : Positive) is record + Current_Length : Natural := 0; + Data : String (1 .. Max_Length) := (others => ASCII.NUL); + end record; + -- Type Bounded_String in Ada.Strings.Bounded.Generic_Bounded_Length is + -- derived from this type, with the constraint of the maximum length. + + -- 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 new file mode 100644 index 000000000..a85e66969 --- /dev/null +++ b/gcc/ada/a-strunb-shared.adb @@ -0,0 +1,2099 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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.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. + + procedure Sync_Add_And_Fetch + (Ptr : access Interfaces.Unsigned_32; + Value : Interfaces.Unsigned_32); + pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); + + function Sync_Sub_And_Fetch + (Ptr : access Interfaces.Unsigned_32; + Value : Interfaces.Unsigned_32) return Interfaces.Unsigned_32; + pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4"); + + 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 (LR.Last + RR.Last); + 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 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 : Shared_String_Access; + Length : Natural) return Boolean + is + use Interfaces; + begin + return + Item.Counter = 1 + 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 Shared_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_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 then 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 then requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less the 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 + Sync_Add_And_Fetch (Item.Counter'Access, 1); + 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 - High - 1; + + -- 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 - High - 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); + + -- 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 : constant Shared_String_Access := Allocate (Source'Length); + begin + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + return (AF.Controlled with Reference => DR); + end To_Unbounded_String; + + function To_Unbounded_String (Length : Natural) return Unbounded_String is + DR : constant Shared_String_Access := Allocate (Length); + begin + DR.Last := Length; + 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 + use Interfaces; + + procedure Free is + new Ada.Unchecked_Deallocation (Shared_String, Shared_String_Access); + + Aux : Shared_String_Access := Item; + + begin + if Sync_Sub_And_Fetch (Aux.Counter'Access, 1) = 0 then + + -- Reference counter of Empty_Shared_String must never reach zero + + pragma Assert (Aux /= Empty_Shared_String'Access); + + Free (Aux); + end if; + end Unreference; + +end Ada.Strings.Unbounded; diff --git a/gcc/ada/a-strunb-shared.ads b/gcc/ada/a-strunb-shared.ads new file mode 100644 index 000000000..70ba549fd --- /dev/null +++ b/gcc/ada/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-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides 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_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 then 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 to + -- safely share internal data between Ada tasks. Nevertheless, this doesn't + -- make objects of Unbounded_String thread-safe: each instance can't be + -- accessed by several tasks simultaneously. + +with Ada.Strings.Maps; +private with Ada.Finalization; +private with Interfaces; + +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 : aliased Interfaces.Unsigned_32 := 1; + -- 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 : 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 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 : 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 new file mode 100644 index 000000000..eae34bee8 --- /dev/null +++ b/gcc/ada/a-strunb.adb @@ -0,0 +1,1074 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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.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 new file mode 100644 index 000000000..af063f0c9 --- /dev/null +++ b/gcc/ada/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-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.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 new file mode 100644 index 000000000..c5da57149 --- /dev/null +++ b/gcc/ada/a-ststio.adb @@ -0,0 +1,481 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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.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 + File.Index := Count (ftell (File.Stream)) + 1; + end if; + + File.Last_Op := Op_Other; + end Set_Mode; + + ------------------ + -- Set_Position -- + ------------------ + + procedure Set_Position (File : File_Type) is + use type System.CRTL.long; + begin + if fseek (File.Stream, + System.CRTL.long (File.Index) - 1, SEEK_SET) /= 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 fseek (File.Stream, 0, SEEK_END) /= 0 then + raise Device_Error; + end if; + + File.File_Size := Stream_Element_Offset (ftell (File.Stream)); + 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 new file mode 100644 index 000000000..63a5e8000 --- /dev/null +++ b/gcc/ada/a-ststio.ads @@ -0,0 +1,221 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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.IO_Exceptions; +with System.File_Control_Block; + +package Ada.Streams.Stream_IO is + + 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; + + function AFCB_Allocate (Control_Block : Stream_AFCB) return FCB.AFCB_Ptr; + + procedure AFCB_Close (File : not null access Stream_AFCB); + procedure AFCB_Free (File : not null access Stream_AFCB); + + 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 + + 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 new file mode 100644 index 000000000..6ca416243 --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..c6d2bc43a --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..8cff44f71 --- /dev/null +++ b/gcc/ada/a-stunau.ads @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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); + type Big_String_Access is access all Big_String; + + 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 : out Unbounded_String; S : String) + renames Set_Unbounded_String; + -- This function is simply a renaming of the new Ada 2005 function as shown + -- above. It is provided for historical reasons, but should be removed at + -- this stage??? + + 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 new file mode 100644 index 000000000..064a34294 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System.String_Hash; + +function Ada.Strings.Unbounded.Hash + (Key : Unbounded_String) return Containers.Hash_Type +is + use Ada.Containers; + function Hash is new System.String_Hash.Hash + (Character, String, Hash_Type); +begin + return Hash (To_String (Key)); +end Ada.Strings.Unbounded.Hash; diff --git a/gcc/ada/a-stunha.ads b/gcc/ada/a-stunha.ads new file mode 100644 index 000000000..1e45bdb5a --- /dev/null +++ b/gcc/ada/a-stunha.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D . H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers; + +function Ada.Strings.Unbounded.Hash + (Key : Unbounded_String) return Containers.Hash_Type; + +pragma Preelaborate (Ada.Strings.Unbounded.Hash); diff --git a/gcc/ada/a-stuten.adb b/gcc/ada/a-stuten.adb new file mode 100644 index 000000000..fc669b56e --- /dev/null +++ b/gcc/ada/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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.UTF_Encoding is + use Interfaces; + + -------------- + -- Encoding -- + -------------- + + function Encoding + (Item : UTF_String; + Default : Encoding_Scheme := UTF_8) return Encoding_Scheme + is + begin + if Item'Length >= 2 then + if Item (Item'First .. Item'First + 1) = BOM_16BE then + return UTF_16BE; + + elsif Item (Item'First .. Item'First + 1) = BOM_16LE then + return UTF_16LE; + + elsif Item'Length >= 3 + and then Item (Item'First .. Item'First + 2) = BOM_8 + then + return UTF_8; + end if; + end if; + + return Default; + end Encoding; + + ----------------- + -- From_UTF_16 -- + ----------------- + + function From_UTF_16 + (Item : UTF_16_Wide_String; + Output_Scheme : UTF_XE_Encoding; + Output_BOM : Boolean := False) return UTF_String + is + BSpace : constant Natural := 2 * Boolean'Pos (Output_BOM); + Result : UTF_String (1 .. 2 * Item'Length + BSpace); + Len : Natural; + C : Unsigned_16; + Iptr : Natural; + + begin + if Output_BOM then + Result (1 .. 2) := + (if Output_Scheme = UTF_16BE then BOM_16BE else BOM_16LE); + Len := 2; + else + Len := 0; + end if; + + -- Skip input BOM + + Iptr := Item'First; + + if Iptr <= Item'Last and then Item (Iptr) = BOM_16 (1) then + Iptr := Iptr + 1; + end if; + + -- UTF-16BE case + + if Output_Scheme = UTF_16BE then + while Iptr <= Item'Last loop + C := To_Unsigned_16 (Item (Iptr)); + Result (Len + 1) := Character'Val (Shift_Right (C, 8)); + Result (Len + 2) := Character'Val (C and 16#00_FF#); + Len := Len + 2; + Iptr := Iptr + 1; + end loop; + + -- UTF-16LE case + + else + while Iptr <= Item'Last loop + C := To_Unsigned_16 (Item (Iptr)); + Result (Len + 1) := Character'Val (C and 16#00_FF#); + Result (Len + 2) := Character'Val (Shift_Right (C, 8)); + Len := Len + 2; + Iptr := Iptr + 1; + end loop; + end if; + + return Result (1 .. Len); + end From_UTF_16; + + -------------------------- + -- Raise_Encoding_Error -- + -------------------------- + + procedure Raise_Encoding_Error (Index : Natural) is + Val : constant String := Index'Img; + begin + raise Encoding_Error with + "bad input at Item (" & Val (Val'First + 1 .. Val'Last) & ')'; + end Raise_Encoding_Error; + + --------------- + -- To_UTF_16 -- + --------------- + + function To_UTF_16 + (Item : UTF_String; + Input_Scheme : UTF_XE_Encoding; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + Result : UTF_16_Wide_String (1 .. Item'Length / 2 + 1); + Len : Natural; + Iptr : Natural; + + begin + if Item'Length mod 2 /= 0 then + raise Encoding_Error with "UTF-16BE/LE string has odd length"; + end if; + + -- Deal with input BOM, skip if OK, error if bad BOM + + Iptr := Item'First; + + if Item'Length >= 2 then + if Item (Iptr .. Iptr + 1) = BOM_16BE then + if Input_Scheme = UTF_16BE then + Iptr := Iptr + 2; + else + Raise_Encoding_Error (Iptr); + end if; + + elsif Item (Iptr .. Iptr + 1) = BOM_16LE then + if Input_Scheme = UTF_16LE then + Iptr := Iptr + 2; + else + Raise_Encoding_Error (Iptr); + end if; + + elsif Item'Length >= 3 and then Item (Iptr .. Iptr + 2) = BOM_8 then + Raise_Encoding_Error (Iptr); + end if; + end if; + + -- Output BOM if specified + + if Output_BOM then + Result (1) := BOM_16 (1); + Len := 1; + else + Len := 0; + end if; + + -- UTF-16BE case + + if Input_Scheme = UTF_16BE then + while Iptr < Item'Last loop + Len := Len + 1; + Result (Len) := + Wide_Character'Val + (Character'Pos (Item (Iptr)) * 256 + + Character'Pos (Item (Iptr + 1))); + Iptr := Iptr + 2; + end loop; + + -- UTF-16LE case + + else + while Iptr < Item'Last loop + Len := Len + 1; + Result (Len) := + Wide_Character'Val + (Character'Pos (Item (Iptr)) + + Character'Pos (Item (Iptr + 1)) * 256); + Iptr := Iptr + 2; + end loop; + end if; + + return Result (1 .. Len); + end To_UTF_16; + +end Ada.Strings.UTF_Encoding; diff --git a/gcc/ada/a-stuten.ads b/gcc/ada/a-stuten.ads new file mode 100644 index 000000000..b8c09a631 --- /dev/null +++ b/gcc/ada/a-stuten.ads @@ -0,0 +1,146 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U T F _ E N C O D I N G -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is one of the Ada 2012 package defined in AI05-0137-1. It is a parent +-- package that contains declarations used in the child packages for handling +-- UTF encoded strings. Note: this package is consistent with Ada 95, and may +-- be used in Ada 95 or Ada 2005 mode. + +with Interfaces; +with Unchecked_Conversion; + +package Ada.Strings.UTF_Encoding is + pragma Pure (UTF_Encoding); + + subtype UTF_String is String; + -- Used to represent a string of 8-bit values containing a sequence of + -- values encoded in one of three ways (UTF-8, UTF-16BE, or UTF-16LE). + -- Typically used in connection with a Scheme parameter indicating which + -- of the encodings applies. This is not strictly a String value in the + -- sense defined in the Ada RM, but in practice type String accommodates + -- all possible 256 codes, and can be used to hold any sequence of 8-bit + -- codes. We use String directly rather than create a new type so that + -- all existing facilities for manipulating type String (e.g. the child + -- packages of Ada.Strings) are available for manipulation of UTF_Strings. + + type Encoding_Scheme is (UTF_8, UTF_16BE, UTF_16LE); + -- Used to specify which of three possible encodings apply to a UTF_String + + subtype UTF_8_String is String; + -- Similar to UTF_String but specifically represents a UTF-8 encoded string + + subtype UTF_16_Wide_String is Wide_String; + -- This is similar to UTF_8_String but is used to represent a Wide_String + -- value which is a sequence of 16-bit values encoded using UTF-16. Again + -- this is not strictly a Wide_String in the sense of the Ada RM, but the + -- type Wide_String can be used to represent a sequence of arbitrary 16-bit + -- values, and it is more convenient to use Wide_String than a new type. + + Encoding_Error : exception; + -- This exception is raised in the following situations: + -- a) A UTF encoded string contains an invalid encoding sequence + -- b) A UTF-16BE or UTF-16LE input string has an odd length + -- c) An incorrect character value is present in the Input string + -- d) The result for a Wide_Character output exceeds 16#FFFF# + -- The exception message has the index value where the error occurred. + + -- The BOM (BYTE_ORDER_MARK) values defined here are used at the start of + -- a string to indicate the encoding. The convention in this package is + -- that on input a correct BOM is ignored and an incorrect BOM causes an + -- Encoding_Error exception. On output, the output string may or may not + -- include a BOM depending on the setting of Output_BOM. + + BOM_8 : constant UTF_8_String := + Character'Val (16#EF#) & + Character'Val (16#BB#) & + Character'Val (16#BF#); + + BOM_16BE : constant UTF_String := + Character'Val (16#FE#) & + Character'Val (16#FF#); + + BOM_16LE : constant UTF_String := + Character'Val (16#FF#) & + Character'Val (16#FE#); + + BOM_16 : constant UTF_16_Wide_String := + (1 => Wide_Character'Val (16#FEFF#)); + + function Encoding + (Item : UTF_String; + Default : Encoding_Scheme := UTF_8) return Encoding_Scheme; + -- This function inspects a UTF_String value to determine whether it + -- starts with a BOM for UTF-8, UTF-16BE, or UTF_16LE. If so, the result + -- is the scheme corresponding to the BOM. If no valid BOM is present + -- then the result is the specified Default value. + +private + function To_Unsigned_8 is new + Unchecked_Conversion (Character, Interfaces.Unsigned_8); + + function To_Unsigned_16 is new + Unchecked_Conversion (Wide_Character, Interfaces.Unsigned_16); + + function To_Unsigned_32 is new + Unchecked_Conversion (Wide_Wide_Character, Interfaces.Unsigned_32); + + subtype UTF_XE_Encoding is Encoding_Scheme range UTF_16BE .. UTF_16LE; + -- Subtype containing only UTF_16BE and UTF_16LE entries + + -- Utility routines for converting between UTF-16 and UTF-16LE/BE + + function From_UTF_16 + (Item : UTF_16_Wide_String; + Output_Scheme : UTF_XE_Encoding; + Output_BOM : Boolean := False) return UTF_String; + -- The input string Item is encoded in UTF-16. The output is encoded using + -- Output_Scheme (which is either UTF-16LE or UTF-16BE). There are no error + -- cases. The output starts with BOM_16BE/LE if Output_BOM is True. + + function To_UTF_16 + (Item : UTF_String; + Input_Scheme : UTF_XE_Encoding; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- The input string Item is encoded using Input_Scheme which is either + -- UTF-16LE or UTF-16BE. The output is the corresponding UTF_16 wide + -- string. Encoding error is raised if the length of the input is odd. + -- The output starts with BOM_16 if Output_BOM is True. + + procedure Raise_Encoding_Error (Index : Natural); + pragma No_Return (Raise_Encoding_Error); + -- Raise Encoding_Error exception for bad encoding in input item. The + -- parameter Index is the index of the location in Item for the error. + +end Ada.Strings.UTF_Encoding; diff --git a/gcc/ada/a-stwibo.adb b/gcc/ada/a-stwibo.adb new file mode 100644 index 000000000..3f784f64b --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..c5a54d14b --- /dev/null +++ b/gcc/ada/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-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.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; + + 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 new file mode 100644 index 000000000..c42290624 --- /dev/null +++ b/gcc/ada/a-stwifi.adb @@ -0,0 +1,684 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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.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 + Result_Length : Natural; + + begin + if Low > Source'Last + 1 or else High < Source'First - 1 then + raise Index_Error; + else + Result_Length := + Source'Length - Natural'Max (High - Low + 1, 0) + By'Length; + + declare + Result : Wide_String (1 .. Result_Length); + + begin + if High >= Low then + Result := + Source (Source'First .. Low - 1) & By & + Source (High + 1 .. Source'Last); + else + Result := Source (Source'First .. Low - 1) & By & + Source (Low .. Source'Last); + end if; + + return Result; + end; + end if; + end Replace_Slice; + + procedure Replace_Slice + (Source : in out Wide_String; + Low : Positive; + High : Natural; + By : Wide_String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Wide_Character := Wide_Space) + is + begin + Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad); + end Replace_Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Wide_String + is + Result : Wide_String (1 .. Count); + + begin + if Count < Source'Length then + Result := Source (Source'Last - Count + 1 .. Source'Last); + + -- Pad on left + + else + for J in 1 .. Count - Source'Length loop + Result (J) := Pad; + end loop; + + Result (Count - Source'Length + 1 .. Count) := Source; + end if; + + return Result; + end Tail; + + procedure Tail + (Source : in out Wide_String; + Count : Natural; + Justify : Alignment := Left; + Pad : Wide_Character := Ada.Strings.Wide_Space) + is + begin + Move (Source => Tail (Source, Count, Pad), + Target => Source, + Drop => Error, + Justify => Justify, + Pad => Pad); + end Tail; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) return Wide_String + is + Result : Wide_String (1 .. Source'Length); + + begin + for J in Source'Range loop + Result (J - (Source'First - 1)) := Value (Mapping, Source (J)); + end loop; + + return Result; + end Translate; + + procedure Translate + (Source : in out Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) + is + begin + for J in Source'Range loop + Source (J) := Value (Mapping, Source (J)); + end loop; + end Translate; + + function Translate + (Source : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Wide_String + is + Result : Wide_String (1 .. Source'Length); + + begin + for J in Source'Range loop + Result (J - (Source'First - 1)) := Mapping (Source (J)); + end loop; + + return Result; + end Translate; + + procedure Translate + (Source : in out Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + is + begin + for J in Source'Range loop + Source (J) := Mapping (Source (J)); + end loop; + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : Wide_String; + Side : Trim_End) return Wide_String + is + Low : Natural := Source'First; + High : Natural := Source'Last; + + begin + if Side = Left or else Side = Both then + while Low <= High and then Source (Low) = Wide_Space loop + Low := Low + 1; + end loop; + end if; + + if Side = Right or else Side = Both then + while High >= Low and then Source (High) = Wide_Space loop + High := High - 1; + end loop; + end if; + + -- All blanks case + + if Low > High then + return ""; + + -- At least one non-blank + + else + declare + Result : constant Wide_String (1 .. High - Low + 1) := + Source (Low .. High); + + begin + return Result; + end; + end if; + end Trim; + + procedure Trim + (Source : in out Wide_String; + Side : Trim_End; + Justify : Alignment := Left; + Pad : Wide_Character := Wide_Space) + is + begin + Move (Source => Trim (Source, Side), + Target => Source, + Justify => Justify, + Pad => Pad); + end Trim; + + function Trim + (Source : Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) return Wide_String + is + Low : Natural := Source'First; + High : Natural := Source'Last; + + begin + while Low <= High and then Is_In (Source (Low), Left) loop + Low := Low + 1; + end loop; + + while High >= Low and then Is_In (Source (High), Right) loop + High := High - 1; + end loop; + + -- Case where source comprises only characters in the sets + + if Low > High then + return ""; + else + declare + subtype WS is Wide_String (1 .. High - Low + 1); + + begin + return WS (Source (Low .. High)); + end; + end if; + end Trim; + + procedure Trim + (Source : in out Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set; + Justify : Alignment := Strings.Left; + Pad : Wide_Character := Wide_Space) + is + begin + Move (Source => Trim (Source, Left, Right), + Target => Source, + Justify => Justify, + Pad => Pad); + end Trim; + +end Ada.Strings.Wide_Fixed; diff --git a/gcc/ada/a-stwifi.ads b/gcc/ada/a-stwifi.ads new file mode 100644 index 000000000..75de811cf --- /dev/null +++ b/gcc/ada/a-stwifi.ads @@ -0,0 +1,254 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ F I X E D -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Maps; + +package Ada.Strings.Wide_Fixed is + pragma Preelaborate; + + ------------------------------------------------------------------- + -- Copy Procedure for Wide_Strings of Possibly Different Lengths -- + ------------------------------------------------------------------- + + procedure Move + (Source : Wide_String; + Target : out Wide_String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Wide_Character := Ada.Strings.Wide_Space); + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Index + (Source : Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Index + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Count + (Source : Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Count + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + pragma Ada_2012 (Find_Token); + + procedure Find_Token + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ----------------------------------------- + -- Wide_String Translation Subprograms -- + ----------------------------------------- + + function Translate + (Source : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) return Wide_String; + + procedure Translate + (Source : in out Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping); + + function Translate + (Source : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Wide_String; + + procedure Translate + (Source : in out Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function); + + -------------------------------------------- + -- Wide_String Transformation Subprograms -- + -------------------------------------------- + + function Replace_Slice + (Source : Wide_String; + Low : Positive; + High : Natural; + By : Wide_String) return Wide_String; + + procedure Replace_Slice + (Source : in out Wide_String; + Low : Positive; + High : Natural; + By : Wide_String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Wide_Character := Ada.Strings.Wide_Space); + + function Insert + (Source : Wide_String; + Before : Positive; + New_Item : Wide_String) return Wide_String; + + procedure Insert + (Source : in out Wide_String; + Before : Positive; + New_Item : Wide_String; + Drop : Truncation := Error); + + function Overwrite + (Source : Wide_String; + Position : Positive; + New_Item : Wide_String) return Wide_String; + + procedure Overwrite + (Source : in out Wide_String; + Position : Positive; + New_Item : Wide_String; + Drop : Truncation := Right); + + function Delete + (Source : Wide_String; + From : Positive; + Through : Natural) return Wide_String; + + procedure Delete + (Source : in out Wide_String; + From : Positive; + Through : Natural; + Justify : Alignment := Left; + Pad : Wide_Character := Ada.Strings.Wide_Space); + + -------------------------------------- + -- Wide_String Selector Subprograms -- + -------------------------------------- + + function Trim + (Source : Wide_String; + Side : Trim_End) return Wide_String; + + procedure Trim + (Source : in out Wide_String; + Side : Trim_End; + Justify : Alignment := Left; + Pad : Wide_Character := Wide_Space); + + function Trim + (Source : Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) return Wide_String; + + procedure Trim + (Source : in out Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set; + Justify : Alignment := Ada.Strings.Left; + Pad : Wide_Character := Ada.Strings.Wide_Space); + + function Head + (Source : Wide_String; + Count : Natural; + Pad : Wide_Character := Ada.Strings.Wide_Space) return Wide_String; + + procedure Head + (Source : in out Wide_String; + Count : Natural; + Justify : Alignment := Left; + Pad : Wide_Character := Ada.Strings.Wide_Space); + + function Tail + (Source : Wide_String; + Count : Natural; + Pad : Wide_Character := Ada.Strings.Wide_Space) return Wide_String; + + procedure Tail + (Source : in out Wide_String; + Count : Natural; + Justify : Alignment := Left; + Pad : Wide_Character := Ada.Strings.Wide_Space); + + --------------------------------------- + -- Wide_String Constructor Functions -- + --------------------------------------- + + function "*" + (Left : Natural; + Right : Wide_Character) return Wide_String; + + function "*" + (Left : Natural; + Right : Wide_String) return Wide_String; + +end Ada.Strings.Wide_Fixed; diff --git a/gcc/ada/a-stwiha.adb b/gcc/ada/a-stwiha.adb new file mode 100644 index 000000000..4c2b15d3f --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System.String_Hash; + +function Ada.Strings.Wide_Hash + (Key : Wide_String) return Containers.Hash_Type +is + use Ada.Containers; + function Hash_Fun is new System.String_Hash.Hash + (Wide_Character, Wide_String, Hash_Type); +begin + return Hash_Fun (Key); +end Ada.Strings.Wide_Hash; diff --git a/gcc/ada/a-stwiha.ads b/gcc/ada/a-stwiha.ads new file mode 100644 index 000000000..f8f0b52fb --- /dev/null +++ b/gcc/ada/a-stwiha.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers; + +function Ada.Strings.Wide_Hash + (Key : Wide_String) return Containers.Hash_Type; + +pragma Pure (Ada.Strings.Wide_Hash); diff --git a/gcc/ada/a-stwima.adb b/gcc/ada/a-stwima.adb new file mode 100644 index 000000000..5937c7d9e --- /dev/null +++ b/gcc/ada/a-stwima.adb @@ -0,0 +1,737 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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; + + Result : Wide_String (Positive range 1 .. 2 ** 16); + N : Natural := 0; + + begin + 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; + + return Result (1 .. N); + 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 new file mode 100644 index 000000000..b22a59311 --- /dev/null +++ b/gcc/ada/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-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_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. + + procedure Initialize (Object : in out Wide_Character_Set); + procedure Adjust (Object : in out Wide_Character_Set); + 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. + + procedure Initialize (Object : in out Wide_Character_Mapping); + procedure Adjust (Object : in out Wide_Character_Mapping); + 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 new file mode 100644 index 000000000..adc8e5f62 --- /dev/null +++ b/gcc/ada/a-stwise.adb @@ -0,0 +1,604 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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.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 + + First := Source'First; + Last := 0; + end Find_Token; + + ----------- + -- Index -- + ----------- + + function Index + (Source : Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + PL1 : constant Integer := Pattern'Length - 1; + Cur : Natural; + + Ind : Integer; + -- Index for start of match check. This can be negative if the pattern + -- length is greater than the string length, which is why this variable + -- is Integer instead of Natural. In this case, the search loops do not + -- execute at all, so this Ind value is never used. + + begin + if Pattern = "" then + raise Pattern_Error; + end if; + + -- Forwards case + + if Going = Forward then + Ind := Source'First; + + -- Unmapped forward case + + if Mapping'Address = Wide_Maps.Identity'Address then + for J in 1 .. Source'Length - PL1 loop + if Pattern = Source (Ind .. Ind + PL1) then + return Ind; + else + Ind := Ind + 1; + end if; + end loop; + + -- Mapped forward case + + else + for J in 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Value (Mapping, Source (Cur)) then + goto Cont1; + else + Cur := Cur + 1; + end if; + end loop; + + return Ind; + + <> + Ind := Ind + 1; + end loop; + end if; + + -- Backwards case + + else + -- Unmapped backward case + + Ind := Source'Last - PL1; + + if Mapping'Address = Wide_Maps.Identity'Address then + for J in reverse 1 .. Source'Length - PL1 loop + if Pattern = Source (Ind .. Ind + PL1) then + return Ind; + else + Ind := Ind - 1; + end if; + end loop; + + -- Mapped backward case + + else + for J in reverse 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Value (Mapping, Source (Cur)) then + goto Cont2; + else + Cur := Cur + 1; + end if; + end loop; + + return Ind; + + <> + Ind := Ind - 1; + end loop; + end if; + end if; + + -- Fall through if no match found. Note that the loops are skipped + -- completely in the case of the pattern being longer than the source. + + return 0; + end Index; + + function Index + (Source : Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + PL1 : constant Integer := Pattern'Length - 1; + Ind : Natural; + Cur : Natural; + + begin + if Pattern = "" then + raise Pattern_Error; + end if; + + -- Check for null pointer in case checks are off + + if Mapping = null then + raise Constraint_Error; + end if; + + -- If Pattern longer than Source it can't be found + + if Pattern'Length > Source'Length then + return 0; + end if; + + -- Forwards case + + if Going = Forward then + Ind := Source'First; + for J in 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Mapping.all (Source (Cur)) then + goto Cont1; + else + Cur := Cur + 1; + end if; + end loop; + + return Ind; + + <> + Ind := Ind + 1; + end loop; + + -- Backwards case + + else + Ind := Source'Last - PL1; + for J in reverse 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Mapping.all (Source (Cur)) then + goto Cont2; + else + Cur := Cur + 1; + end if; + end loop; + + return Ind; + + <> + Ind := Ind - 1; + end loop; + end if; + + -- Fall through if no match found. Note that the loops are skipped + -- completely in the case of the pattern being longer than the source. + + return 0; + end Index; + + function Index + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + begin + -- Forwards case + + if Going = Forward then + for J in Source'Range loop + if Belongs (Source (J), Set, Test) then + return J; + end if; + end loop; + + -- Backwards case + + else + for J in reverse Source'Range loop + if Belongs (Source (J), Set, Test) then + return J; + end if; + end loop; + end if; + + -- Fall through if no match + + return 0; + end Index; + + function Index + (Source : Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + begin + if Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return + Index (Source (From .. Source'Last), Pattern, Forward, Mapping); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return + Index (Source (Source'First .. From), Pattern, Backward, Mapping); + end if; + end Index; + + function Index + (Source : Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + begin + if Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return Index + (Source (From .. Source'Last), Pattern, Forward, Mapping); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return Index + (Source (Source'First .. From), Pattern, Backward, Mapping); + end if; + end Index; + + function Index + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + begin + if Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return + Index (Source (From .. Source'Last), Set, Test, Forward); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return + Index (Source (Source'First .. From), Set, Test, Backward); + end if; + end Index; + + --------------------- + -- Index_Non_Blank -- + --------------------- + + function Index_Non_Blank + (Source : Wide_String; + Going : Direction := Forward) return Natural + is + begin + if Going = Forward then + for J in Source'Range loop + if Source (J) /= Wide_Space then + return J; + end if; + end loop; + + else -- Going = Backward + for J in reverse Source'Range loop + if Source (J) /= Wide_Space then + return J; + end if; + end loop; + end if; + + -- Fall through if no match + + return 0; + end Index_Non_Blank; + + function Index_Non_Blank + (Source : Wide_String; + From : Positive; + Going : Direction := Forward) return Natural + is + begin + if Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return + Index_Non_Blank (Source (From .. Source'Last), Forward); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return + Index_Non_Blank (Source (Source'First .. From), Backward); + end if; + end Index_Non_Blank; + +end Ada.Strings.Wide_Search; diff --git a/gcc/ada/a-stwise.ads b/gcc/ada/a-stwise.ads new file mode 100644 index 000000000..fa06c5b15 --- /dev/null +++ b/gcc/ada/a-stwise.ads @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ S E A R C H -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the search functions from Ada.Strings.Wide_Fixed. +-- They are separated out because they are shared by Ada.Strings.Wide_Bounded +-- and Ada.Strings.Wide_Unbounded, and we don't want to drag other irrelevant +-- stuff from Ada.Strings.Wide_Fixed when using the other two packages. We +-- make this a private package, since user programs should access these +-- subprograms via one of the standard string packages. + +with Ada.Strings.Wide_Maps; + +private package Ada.Strings.Wide_Search is + pragma Preelaborate; + + function Index + (Source : Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := + Wide_Maps.Identity) return Natural; + + function Index + (Source : Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Index + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Index + (Source : Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Index + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + + function Count + (Source : Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Count + (Source : Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Count + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + pragma Ada_2012 (Find_Token); + + procedure Find_Token + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + +end Ada.Strings.Wide_Search; diff --git a/gcc/ada/a-stwisu.adb b/gcc/ada/a-stwisu.adb new file mode 100644 index 000000000..2ffae8146 --- /dev/null +++ b/gcc/ada/a-stwisu.adb @@ -0,0 +1,1920 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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.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 + Result : Super_String (Left.Max_Length); + 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; + + return Result; + end Concat; + + function Concat + (Left : Super_String; + Right : Wide_String) return Super_String + is + Result : Super_String (Left.Max_Length); + 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; + return Result; + end Concat; + + function Concat + (Left : Wide_String; + Right : Super_String) return Super_String + is + Result : Super_String (Right.Max_Length); + 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; + + return Result; + end Concat; + + function Concat + (Left : Super_String; + Right : Wide_Character) return Super_String + is + Result : Super_String (Left.Max_Length); + 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; + + return Result; + end Concat; + + function Concat + (Left : Wide_Character; + Right : Super_String) return Super_String + is + Result : Super_String (Right.Max_Length); + 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; + + return Result; + 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 + + if Low > Source.Current_Length + 1 + or else High > Source.Current_Length + then + raise Index_Error; + else + return Source.Data (Low .. High); + end if; + end Super_Slice; + + function Super_Slice + (Source : Super_String; + Low : Positive; + High : Natural) return Super_String + is + Result : Super_String (Source.Max_Length); + + begin + 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; + + return Result; + 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 Source.Data (1 .. Source.Current_Length); + 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 new file mode 100644 index 000000000..0390031f3 --- /dev/null +++ b/gcc/ada/a-stwisu.ads @@ -0,0 +1,494 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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); + + type Super_String (Max_Length : Positive) is record + Current_Length : Natural := 0; + Data : Wide_String (1 .. Max_Length) := (others => Wide_NUL); + end record; + -- Ada.Strings.Wide_Bounded.Generic_Bounded_Length.Wide_Bounded_String is + -- derived from this type, with the constraint of the maximum length. + + -- 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 new file mode 100644 index 000000000..6a9f7a60a --- /dev/null +++ b/gcc/ada/a-stwiun-shared.adb @@ -0,0 +1,2119 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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.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. + + procedure Sync_Add_And_Fetch + (Ptr : access Interfaces.Unsigned_32; + Value : Interfaces.Unsigned_32); + pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); + + function Sync_Sub_And_Fetch + (Ptr : access Interfaces.Unsigned_32; + Value : Interfaces.Unsigned_32) return Interfaces.Unsigned_32; + pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4"); + + 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 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 (LR.Last + RR.Last); + 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 + use Interfaces; + begin + return + Item.Counter = 1 + 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 then 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 then requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less the 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 + Sync_Add_And_Fetch (Item.Counter'Access, 1); + 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 - High - 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; + + -- 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 - High - 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); + + -- 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 : constant Shared_Wide_String_Access := Allocate (Source'Length); + begin + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + return (AF.Controlled with Reference => DR); + end To_Unbounded_Wide_String; + + function To_Unbounded_Wide_String + (Length : Natural) return Unbounded_Wide_String + is + DR : constant Shared_Wide_String_Access := Allocate (Length); + begin + DR.Last := Length; + 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 + use Interfaces; + + procedure Free is + new Ada.Unchecked_Deallocation + (Shared_Wide_String, Shared_Wide_String_Access); + + Aux : Shared_Wide_String_Access := Item; + + begin + if Sync_Sub_And_Fetch (Aux.Counter'Access, 1) = 0 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 new file mode 100644 index 000000000..ba4cbce34 --- /dev/null +++ b/gcc/ada/a-stwiun-shared.ads @@ -0,0 +1,492 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is supported on: +-- - all Alpha platforms +-- - all ia64 platforms +-- - all PowerPC platforms +-- - all SPARC V9 platforms +-- - all x86_64 platforms + +with Ada.Strings.Wide_Maps; +private with Ada.Finalization; +private with Interfaces; + +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 : aliased Interfaces.Unsigned_32 := 1; + -- 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 indices are just an extra room. + 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 reference 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 then 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 to + -- safely share internal data between Ada tasks. Nevertheless, this not + -- make objects of Unbounded_Wide_String thread-safe, so each instance + -- can't 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 new file mode 100644 index 000000000..77e427f92 --- /dev/null +++ b/gcc/ada/a-stwiun.adb @@ -0,0 +1,1098 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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.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 new file mode 100644 index 000000000..dcec88977 --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..76e7292e6 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..9574802f2 --- /dev/null +++ b/gcc/ada/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-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.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; + + 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 new file mode 100644 index 000000000..077a65c0e --- /dev/null +++ b/gcc/ada/a-stzfix.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-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.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 + Result_Length : Natural; + + begin + if Low > Source'Last + 1 or else High < Source'First - 1 then + raise Index_Error; + else + Result_Length := + Source'Length - Natural'Max (High - Low + 1, 0) + By'Length; + + declare + Result : Wide_Wide_String (1 .. Result_Length); + + begin + if High >= Low then + Result := + Source (Source'First .. Low - 1) & By & + Source (High + 1 .. Source'Last); + else + Result := Source (Source'First .. Low - 1) & By & + Source (Low .. Source'Last); + end if; + + return Result; + end; + end if; + end Replace_Slice; + + procedure Replace_Slice + (Source : in out Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + begin + Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad); + end Replace_Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) return Wide_Wide_String + is + Result : Wide_Wide_String (1 .. Count); + + begin + if Count < Source'Length then + Result := Source (Source'Last - Count + 1 .. Source'Last); + + -- Pad on left + + else + for J in 1 .. Count - Source'Length loop + Result (J) := Pad; + end loop; + + Result (Count - Source'Length + 1 .. Count) := Source; + end if; + + return Result; + end Tail; + + procedure Tail + (Source : in out Wide_Wide_String; + Count : Natural; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space) + is + begin + Move (Source => Tail (Source, Count, Pad), + Target => Source, + Drop => Error, + Justify => Justify, + Pad => Pad); + end Tail; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Wide_Wide_String + is + Result : Wide_Wide_String (1 .. Source'Length); + + begin + for J in Source'Range loop + Result (J - (Source'First - 1)) := Value (Mapping, Source (J)); + end loop; + + return Result; + end Translate; + + procedure Translate + (Source : in out Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + is + begin + for J in Source'Range loop + Source (J) := Value (Mapping, Source (J)); + end loop; + end Translate; + + function Translate + (Source : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Wide_Wide_String + is + Result : Wide_Wide_String (1 .. Source'Length); + + begin + for J in Source'Range loop + Result (J - (Source'First - 1)) := Mapping (Source (J)); + end loop; + + return Result; + end Translate; + + procedure Translate + (Source : in out Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + is + begin + for J in Source'Range loop + Source (J) := Mapping (Source (J)); + end loop; + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : Wide_Wide_String; + Side : Trim_End) return Wide_Wide_String + is + Low : Natural := Source'First; + High : Natural := Source'Last; + + begin + if Side = Left or else Side = Both then + while Low <= High and then Source (Low) = Wide_Wide_Space loop + Low := Low + 1; + end loop; + end if; + + if Side = Right or else Side = Both then + while High >= Low and then Source (High) = Wide_Wide_Space loop + High := High - 1; + end loop; + end if; + + -- All blanks case + + if Low > High then + return ""; + + -- At least one non-blank + + else + declare + Result : constant Wide_Wide_String (1 .. High - Low + 1) := + Source (Low .. High); + + begin + return Result; + end; + end if; + end Trim; + + procedure Trim + (Source : in out Wide_Wide_String; + Side : Trim_End; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + begin + Move (Source => Trim (Source, Side), + Target => Source, + Justify => Justify, + Pad => Pad); + end Trim; + + function Trim + (Source : Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) return Wide_Wide_String + is + Low : Natural := Source'First; + High : Natural := Source'Last; + + begin + while Low <= High and then Is_In (Source (Low), Left) loop + Low := Low + 1; + end loop; + + while High >= Low and then Is_In (Source (High), Right) loop + High := High - 1; + end loop; + + -- Case where source comprises only characters in the sets + + if Low > High then + return ""; + else + declare + subtype WS is Wide_Wide_String (1 .. High - Low + 1); + + begin + return WS (Source (Low .. High)); + end; + end if; + end Trim; + + procedure Trim + (Source : in out Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set; + Justify : Alignment := Strings.Left; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + begin + Move (Source => Trim (Source, Left, Right), + Target => Source, + Justify => Justify, + Pad => Pad); + end Trim; + +end Ada.Strings.Wide_Wide_Fixed; diff --git a/gcc/ada/a-stzfix.ads b/gcc/ada/a-stzfix.ads new file mode 100644 index 000000000..bee765825 --- /dev/null +++ b/gcc/ada/a-stzfix.ads @@ -0,0 +1,264 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ F I X E D -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Wide_Maps; + +package Ada.Strings.Wide_Wide_Fixed is + pragma Preelaborate; + + ------------------------------------------------------------------------ + -- Copy Procedure for Wide_Wide_Strings of Possibly Different Lengths -- + ------------------------------------------------------------------------ + + procedure Move + (Source : Wide_Wide_String; + Target : out Wide_Wide_String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) return Natural; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Index + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Wide_Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Count + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Count + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + pragma Ada_2012 (Find_Token); + + procedure Find_Token + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ---------------------------------------------- + -- Wide_Wide_String Translation Subprograms -- + ---------------------------------------------- + + function Translate + (Source : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Wide_Wide_String; + + procedure Translate + (Source : in out Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping); + + function Translate + (Source : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Wide_Wide_String; + + procedure Translate + (Source : in out Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function); + + ------------------------------------------------- + -- Wide_Wide_String Transformation Subprograms -- + ------------------------------------------------- + + function Replace_Slice + (Source : Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) return Wide_Wide_String; + + procedure Replace_Slice + (Source : in out Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); + + function Insert + (Source : Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) return Wide_Wide_String; + + procedure Insert + (Source : in out Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error); + + function Overwrite + (Source : Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) return Wide_Wide_String; + + procedure Overwrite + (Source : in out Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Right); + + function Delete + (Source : Wide_Wide_String; + From : Positive; + Through : Natural) return Wide_Wide_String; + + procedure Delete + (Source : in out Wide_Wide_String; + From : Positive; + Through : Natural; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); + + ------------------------------------------- + -- Wide_Wide_String Selector Subprograms -- + ------------------------------------------- + + function Trim + (Source : Wide_Wide_String; + Side : Trim_End) return Wide_Wide_String; + + procedure Trim + (Source : in out Wide_Wide_String; + Side : Trim_End; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Wide_Wide_Space); + + function Trim + (Source : Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + return Wide_Wide_String; + + procedure Trim + (Source : in out Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set; + Justify : Alignment := Ada.Strings.Left; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); + + function Head + (Source : Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space) + return Wide_Wide_String; + + procedure Head + (Source : in out Wide_Wide_String; + Count : Natural; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); + + function Tail + (Source : Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space) + return Wide_Wide_String; + + procedure Tail + (Source : in out Wide_Wide_String; + Count : Natural; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); + + -------------------------------------------- + -- Wide_Wide_String Constructor Functions -- + -------------------------------------------- + + function "*" + (Left : Natural; + Right : Wide_Wide_Character) return Wide_Wide_String; + + function "*" + (Left : Natural; + Right : Wide_Wide_String) return Wide_Wide_String; + +end Ada.Strings.Wide_Wide_Fixed; diff --git a/gcc/ada/a-stzhas.adb b/gcc/ada/a-stzhas.adb new file mode 100644 index 000000000..a48fd0346 --- /dev/null +++ b/gcc/ada/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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. + +pragma No_Body; diff --git a/gcc/ada/a-stzhas.ads b/gcc/ada/a-stzhas.ads new file mode 100644 index 000000000..0c87672b5 --- /dev/null +++ b/gcc/ada/a-stzhas.ads @@ -0,0 +1,25 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Is this really an RM unit? Doc needed??? + +with Ada.Containers; +with System.String_Hash; + +function Ada.Strings.Wide_Wide_Hash +is new System.String_Hash.Hash + (Wide_Wide_Character, Wide_Wide_String, Containers.Hash_Type); + +pragma Pure (Ada.Strings.Wide_Wide_Hash); diff --git a/gcc/ada/a-stzmap.adb b/gcc/ada/a-stzmap.adb new file mode 100644 index 000000000..08cae19bd --- /dev/null +++ b/gcc/ada/a-stzmap.adb @@ -0,0 +1,742 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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; + + Result : Wide_Wide_String (Positive range 1 .. 2 ** 16); + N : Natural := 0; + + begin + 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; + + return Result (1 .. N); + 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 new file mode 100644 index 000000000..bd63fdd82 --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..e745091f6 --- /dev/null +++ b/gcc/ada/a-stzsea.adb @@ -0,0 +1,610 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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.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 + + First := Source'First; + Last := 0; + end Find_Token; + + ----------- + -- Index -- + ----------- + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + is + PL1 : constant Integer := Pattern'Length - 1; + Cur : Natural; + + Ind : Integer; + -- Index for start of match check. This can be negative if the pattern + -- length is greater than the string length, which is why this variable + -- is Integer instead of Natural. In this case, the search loops do not + -- execute at all, so this Ind value is never used. + + begin + if Pattern = "" then + raise Pattern_Error; + end if; + + -- Forwards case + + if Going = Forward then + Ind := Source'First; + + -- Unmapped forward case + + if Mapping'Address = Wide_Wide_Maps.Identity'Address then + for J in 1 .. Source'Length - PL1 loop + if Pattern = Source (Ind .. Ind + PL1) then + return Ind; + else + Ind := Ind + 1; + end if; + end loop; + + -- Mapped forward case + + else + for J in 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Value (Mapping, Source (Cur)) then + goto Cont1; + else + Cur := Cur + 1; + end if; + end loop; + + return Ind; + + <> + Ind := Ind + 1; + end loop; + end if; + + -- Backwards case + + else + -- Unmapped backward case + + Ind := Source'Last - PL1; + + if Mapping'Address = Wide_Wide_Maps.Identity'Address then + for J in reverse 1 .. Source'Length - PL1 loop + if Pattern = Source (Ind .. Ind + PL1) then + return Ind; + else + Ind := Ind - 1; + end if; + end loop; + + -- Mapped backward case + + else + for J in reverse 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Value (Mapping, Source (Cur)) then + goto Cont2; + else + Cur := Cur + 1; + end if; + end loop; + + return Ind; + + <> + Ind := Ind - 1; + end loop; + end if; + end if; + + -- Fall through if no match found. Note that the loops are skipped + -- completely in the case of the pattern being longer than the source. + + return 0; + end Index; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + PL1 : constant Integer := Pattern'Length - 1; + Ind : Natural; + Cur : Natural; + + begin + if Pattern = "" then + raise Pattern_Error; + end if; + + -- Check for null pointer in case checks are off + + if Mapping = null then + raise Constraint_Error; + end if; + + -- If Pattern longer than Source it can't be found + + if Pattern'Length > Source'Length then + return 0; + end if; + + -- Forwards case + + if Going = Forward then + Ind := Source'First; + for J in 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Mapping.all (Source (Cur)) then + goto Cont1; + else + Cur := Cur + 1; + end if; + end loop; + + return Ind; + + <> + Ind := Ind + 1; + end loop; + + -- Backwards case + + else + Ind := Source'Last - PL1; + for J in reverse 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Mapping.all (Source (Cur)) then + goto Cont2; + else + Cur := Cur + 1; + end if; + end loop; + + return Ind; + + <> + Ind := Ind - 1; + end loop; + end if; + + -- Fall through if no match found. Note that the loops are skipped + -- completely in the case of the pattern being longer than the source. + + return 0; + end Index; + + function Index + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + begin + -- Forwards case + + if Going = Forward then + for J in Source'Range loop + if Belongs (Source (J), Set, Test) then + return J; + end if; + end loop; + + -- Backwards case + + else + for J in reverse Source'Range loop + if Belongs (Source (J), Set, Test) then + return J; + end if; + end loop; + end if; + + -- Fall through if no match + + return 0; + end Index; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + is + begin + if Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return + Index (Source (From .. Source'Last), Pattern, Forward, Mapping); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return + Index (Source (Source'First .. From), Pattern, Backward, Mapping); + end if; + end Index; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + begin + if Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return Index + (Source (From .. Source'Last), Pattern, Forward, Mapping); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return Index + (Source (Source'First .. From), Pattern, Backward, Mapping); + end if; + end Index; + + function Index + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + begin + if Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return + Index (Source (From .. Source'Last), Set, Test, Forward); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return + Index (Source (Source'First .. From), Set, Test, Backward); + end if; + end Index; + + --------------------- + -- Index_Non_Blank -- + --------------------- + + function Index_Non_Blank + (Source : Wide_Wide_String; + Going : Direction := Forward) return Natural + is + begin + if Going = Forward then + for J in Source'Range loop + if Source (J) /= Wide_Wide_Space then + return J; + end if; + end loop; + + else -- Going = Backward + for J in reverse Source'Range loop + if Source (J) /= Wide_Wide_Space then + return J; + end if; + end loop; + end if; + + -- Fall through if no match + + return 0; + end Index_Non_Blank; + + function Index_Non_Blank + (Source : Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural + is + begin + if Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return + Index_Non_Blank (Source (From .. Source'Last), Forward); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return + Index_Non_Blank (Source (Source'First .. From), Backward); + end if; + end Index_Non_Blank; + +end Ada.Strings.Wide_Wide_Search; diff --git a/gcc/ada/a-stzsea.ads b/gcc/ada/a-stzsea.ads new file mode 100644 index 000000000..b8e39d25a --- /dev/null +++ b/gcc/ada/a-stzsea.ads @@ -0,0 +1,130 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ S E A R C H -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains search functions from Ada.Strings.Wide_Wide_Fixed. +-- They are separated because Ada.Strings.Wide_Wide_Bounded shares these +-- search functions with Ada.Strings.Wide_Wide_Unbounded, and we don't want +-- to drag other irrelevant stuff from Ada.Strings.Wide_Wide_Fixed when using +-- the other two packages. We make this a private package, since user +-- programs should access these subprograms via one of the standard string +-- packages. + +with Ada.Strings.Wide_Wide_Maps; + +private package Ada.Strings.Wide_Wide_Search is + pragma Preelaborate; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) return Natural; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Index + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Index + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Wide_Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + + function Count + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Count + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Count + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + + procedure Find_Token + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + +end Ada.Strings.Wide_Wide_Search; diff --git a/gcc/ada/a-stzsup.adb b/gcc/ada/a-stzsup.adb new file mode 100644 index 000000000..efad7b0f8 --- /dev/null +++ b/gcc/ada/a-stzsup.adb @@ -0,0 +1,1931 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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.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 + Result : Super_String (Left.Max_Length); + 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; + + return Result; + end Concat; + + function Concat + (Left : Super_String; + Right : Wide_Wide_String) return Super_String + is + Result : Super_String (Left.Max_Length); + 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; + return Result; + end Concat; + + function Concat + (Left : Wide_Wide_String; + Right : Super_String) return Super_String + is + Result : Super_String (Right.Max_Length); + 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; + + return Result; + end Concat; + + function Concat + (Left : Super_String; + Right : Wide_Wide_Character) return Super_String + is + Result : Super_String (Left.Max_Length); + 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; + + return Result; + end Concat; + + function Concat + (Left : Wide_Wide_Character; + Right : Super_String) return Super_String + is + Result : Super_String (Right.Max_Length); + 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; + + return Result; + 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 + + if Low > Source.Current_Length + 1 + or else High > Source.Current_Length + then + raise Index_Error; + else + return Source.Data (Low .. High); + end if; + end Super_Slice; + + function Super_Slice + (Source : Super_String; + Low : Positive; + High : Natural) return Super_String + is + Result : Super_String (Source.Max_Length); + + begin + 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; + + return Result; + 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 Source.Data (1 .. Source.Current_Length); + 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 new file mode 100644 index 000000000..7e67f53ba --- /dev/null +++ b/gcc/ada/a-stzsup.ads @@ -0,0 +1,504 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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); + + type Super_String (Max_Length : Positive) is record + Current_Length : Natural := 0; + Data : Wide_Wide_String (1 .. Max_Length) := + (others => Wide_Wide_NUL); + end record; + -- Wide_Wide_Bounded.Generic_Bounded_Length.Wide_Wide_Bounded_String is + -- derived from this type, with the constraint of the maximum length. + + -- 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 new file mode 100644 index 000000000..bed79790a --- /dev/null +++ b/gcc/ada/a-stzunb-shared.adb @@ -0,0 +1,2132 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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.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. + + procedure Sync_Add_And_Fetch + (Ptr : access Interfaces.Unsigned_32; + Value : Interfaces.Unsigned_32); + pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); + + function Sync_Sub_And_Fetch + (Ptr : access Interfaces.Unsigned_32; + Value : Interfaces.Unsigned_32) return Interfaces.Unsigned_32; + pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4"); + + 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 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 (LR.Last + RR.Last); + 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 + use Interfaces; + begin + return + Item.Counter = 1 + 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 then 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 then requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less the 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 + Sync_Add_And_Fetch (Item.Counter'Access, 1); + 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 - High - 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; + + -- 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 - High - 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); + + -- 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 : constant Shared_Wide_Wide_String_Access := Allocate (Source'Length); + begin + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + 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 : constant Shared_Wide_Wide_String_Access := Allocate (Length); + begin + DR.Last := Length; + 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 + use Interfaces; + + 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 Sync_Sub_And_Fetch (Aux.Counter'Access, 1) = 0 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 new file mode 100644 index 000000000..bea5169c8 --- /dev/null +++ b/gcc/ada/a-stzunb-shared.ads @@ -0,0 +1,510 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is supported on: +-- - all Alpha platforms +-- - all ia64 platforms +-- - all PowerPC platforms +-- - all SPARC V9 platforms +-- - all x86_64 platforms + +with Ada.Strings.Wide_Wide_Maps; +private with Ada.Finalization; +private with Interfaces; + +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 : aliased Interfaces.Unsigned_32 := 1; + -- 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 indices are just an extra room. + 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 then 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 to + -- safely share internal data between Ada tasks. Nevertheless, this not + -- make objects of Unbounded_Wide_Wide_String thread-safe, so each instance + -- can't 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 new file mode 100644 index 000000000..82dae6f88 --- /dev/null +++ b/gcc/ada/a-stzunb.adb @@ -0,0 +1,1111 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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.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 new file mode 100644 index 000000000..fa7bc17d9 --- /dev/null +++ b/gcc/ada/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-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-suenco.adb b/gcc/ada/a-suenco.adb new file mode 100755 index 000000000..00df4ab14 --- /dev/null +++ b/gcc/ada/a-suenco.adb @@ -0,0 +1,390 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.CONVERSIONS -- +-- -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package 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 + + if Input_Scheme = Output_Scheme then + return Item; + + -- For remaining cases, one or other of the operands is UTF-16BE/LE + -- encoded, so 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#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 + + R := R - 2#0000_1_0000#; + + -- R now has zzzzyyyy (zzzz minus one for the output) + + Get_Continuation; + + -- R now has zzzzyyyyyyyyxx + + 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); + + -- Any other code is an error + + else + Raise_Encoding_Error (Iptr - 1); + end if; + end loop; + + return Result (1 .. Len); + end Convert; + + -- Convert from UTF-16 to UTF-8/UTF-16-BE/LE + + function Convert + (Item : UTF_16_Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String + is + begin + if Output_Scheme = UTF_8 then + return Convert (Item, Output_BOM); + else + return From_UTF_16 (Item, Output_Scheme, Output_BOM); + end if; + end Convert; + + -- Convert from UTF-16 to UTF-8 + + function Convert + (Item : UTF_16_Wide_String; + Output_BOM : Boolean := False) return UTF_8_String + is + Result : UTF_8_String (1 .. 3 * Item'Length + 3); + -- Worst case is 3 output codes for each input code + BOM space + + Len : Natural; + -- Number of result codes stored + + Iptr : Natural; + -- Pointer to next input character + + C1, C2 : Unsigned_16; + + zzzzz : Unsigned_16; + yyyyyyyy : Unsigned_16; + xxxxxxxx : Unsigned_16; + -- Components of double length case + + begin + Iptr := Item'First; + + -- Skip BOM at start of input + + if Item'Length > 0 and then Item (Iptr) = BOM_16 (1) then + Iptr := Iptr + 1; + end if; + + -- Generate output BOM if required + + if Output_BOM then + Result (1 .. 3) := BOM_8; + Len := 3; + else + Len := 0; + end if; + + -- Loop through input + + while Iptr <= Item'Last loop + C1 := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#0000# - 16#007F# + -- UTF-16: 000000000xxxxxxx + -- UTF-8: 0xxxxxxx + + if C1 <= 16#007F# then + Result (Len + 1) := Character'Val (C1); + Len := Len + 1; + + -- Codes in the range 16#80# - 16#7FF# + -- UTF-16: 00000yyyxxxxxxxx + -- UTF-8: 110yyyxx 10xxxxxx + + elsif C1 <= 16#07FF# then + Result (Len + 1) := + Character'Val + (2#110_00000# or Shift_Right (C1, 6)); + Result (Len + 2) := + Character'Val + (2#10_000000# or (C1 and 2#00_111111#)); + Len := Len + 2; + + -- Codes in the range 16#800# - 16#D7FF# or 16#E000# - 16#FFFF# + -- UTF-16: yyyyyyyyxxxxxxxx + -- UTF-8: 1110yyyy 10yyyyxx 10xxxxxx + + elsif C1 <= 16#D7FF# or else C1 >= 16#E000# then + Result (Len + 1) := + Character'Val + (2#1110_0000# or Shift_Right (C1, 12)); + Result (Len + 2) := + Character'Val + (2#10_000000# or (Shift_Right (C1, 6) and 2#00_111111#)); + Result (Len + 3) := + Character'Val + (2#10_000000# or (C1 and 2#00_111111#)); + Len := Len + 3; + + -- Codes in the range 16#10000# - 16#10FFFF# + -- UTF-16: 110110zzzzyyyyyy 110111yyxxxxxxxx + -- UTF-8: 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + -- Note: zzzzz in the output is input zzzz + 1 + + elsif C1 <= 2#110110_11_11111111# then + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + else + C2 := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + end if; + + if (C2 and 2#111111_00_00000000#) /= 2#110111_00_00000000# then + Raise_Encoding_Error (Iptr - 1); + end if; + + zzzzz := (Shift_Right (C1, 6) and 2#1111#) + 1; + yyyyyyyy := ((Shift_Left (C1, 2) and 2#111111_00#) + or + (Shift_Right (C2, 8) and 2#000000_11#)); + xxxxxxxx := C2 and 2#11111111#; + + Result (Len + 1) := + Character'Val + (2#11110_000# or (Shift_Right (zzzzz, 2))); + Result (Len + 2) := + Character'Val + (2#10_000000# or Shift_Left (zzzzz and 2#11#, 4) + or Shift_Right (yyyyyyyy, 4)); + Result (Len + 3) := + Character'Val + (2#10_000000# or Shift_Left (yyyyyyyy and 2#1111#, 4) + or Shift_Right (xxxxxxxx, 6)); + Result (Len + 4) := + Character'Val + (2#10_000000# or (xxxxxxxx and 2#00_111111#)); + Len := Len + 4; + + -- Error if input in 16#DC00# - 16#DFFF# (2nd surrogate with no 1st) + + else + Raise_Encoding_Error (Iptr - 2); + end if; + end loop; + + return Result (1 .. Len); + end Convert; + +end Ada.Strings.UTF_Encoding.Conversions; diff --git a/gcc/ada/a-suenco.ads b/gcc/ada/a-suenco.ads new file mode 100755 index 000000000..0aa4f88b2 --- /dev/null +++ b/gcc/ada/a-suenco.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.CONVERSIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an Ada 2012 package defined in AI05-0137-1. It provides conversions +-- from one UTF encoding method to another. Note: this package is consistent +-- with Ada 95, and may be used in Ada 95 or Ada 2005 mode. + +package Ada.Strings.UTF_Encoding.Conversions is + pragma Pure (Conversions); + + -- In the following conversion routines, a BOM in the input that matches + -- the encoding scheme is ignored, an incorrect BOM causes Encoding_Error + -- to be raised. A BOM is present in the output if the Output_BOM parameter + -- is set to True. + + function Convert + (Item : UTF_String; + Input_Scheme : Encoding_Scheme; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String; + -- Convert from input encoded in UTF-8, UTF-16LE, or UTF-16BE as specified + -- by the Input_Scheme argument, and generate an output encoded in one of + -- these three schemes as specified by the Output_Scheme argument. + + function Convert + (Item : UTF_String; + Input_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- Convert from input encoded in UTF-8, UTF-16LE, or UTF-16BE as specified + -- by the Input_Scheme argument, and generate an output encoded in UTF-16. + + function Convert + (Item : UTF_8_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- Convert from UTF-8 to UTF-16 + + function Convert + (Item : UTF_16_Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String; + -- Convert from UTF-16 to UTF-8, UTF-16LE, or UTF-16BE as specified by + -- the Output_Scheme argument. + + function Convert + (Item : UTF_16_Wide_String; + Output_BOM : Boolean := False) return UTF_8_String; + -- Convert from UTF-16 to UTF-8 + +end Ada.Strings.UTF_Encoding.Conversions; diff --git a/gcc/ada/a-suenst.adb b/gcc/ada/a-suenst.adb new file mode 100755 index 000000000..af057f16b --- /dev/null +++ b/gcc/ada/a-suenst.adb @@ -0,0 +1,341 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.STRINGS -- +-- -- +-- 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.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; + Result (Len) := Character'Val (R); + end loop; + + return Result (1 .. Len); + end Decode; + + -- Decode UTF-16 input to String + + function Decode (Item : UTF_16_Wide_String) return String is + Result : String (1 .. Item'Length); + -- Result is same length as input (possibly minus 1 if BOM present) + + Len : Natural := 0; + -- Length of result + + Iptr : Natural; + -- Index of next Item element + + C : Unsigned_16; + + begin + -- Skip UTF-16 BOM at start + + Iptr := Item'First; + + if Item'Length > 0 and then Item (Iptr) = BOM_16 (1) then + Iptr := Iptr + 1; + end if; + + -- Loop through input characters + + while Iptr <= Item'Last loop + C := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#0000#..16#00FF# represent their own value + + if C <= 16#00FF# then + Len := Len + 1; + Result (Len) := Character'Val (C); + + -- All other codes are invalid, either they are invalid UTF-16 + -- encoding sequences, or they represent values that are out of + -- range for type Character. + + else + Raise_Encoding_Error (Iptr - 1); + end if; + end loop; + + return Result (1 .. Len); + end Decode; + + ------------ + -- Encode -- + ------------ + + -- Encode String in UTF-8, UTF-16BE or UTF-16LE + + function Encode + (Item : String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String + is + begin + -- Case of UTF_8 + + if Output_Scheme = UTF_8 then + return Encode (Item, Output_BOM); + + -- Case of UTF_16LE or UTF_16BE, use UTF-16 intermediary + + else + return From_UTF_16 (UTF_16_Wide_String'(Encode (Item)), + Output_Scheme, Output_BOM); + end if; + end Encode; + + -- Encode String in UTF-8 + + function Encode + (Item : String; + Output_BOM : Boolean := False) return UTF_8_String + is + Result : UTF_8_String (1 .. 3 * Item'Length + 3); + -- Worst case is three bytes per input byte + space for BOM + + Len : Natural; + -- Number of output codes stored in Result + + C : Unsigned_8; + -- Single input character + + procedure Store (C : Unsigned_8); + pragma Inline (Store); + -- Store one output code, C is in the range 0 .. 255 + + ----------- + -- Store -- + ----------- + + procedure Store (C : Unsigned_8) is + begin + Len := Len + 1; + Result (Len) := Character'Val (C); + end Store; + + -- Start of processing for UTF8_Encode + + begin + -- Output BOM if required + + if Output_BOM then + Result (1 .. 3) := BOM_8; + Len := 3; + else + Len := 0; + end if; + + -- Loop through characters of input + + for J in Item'Range loop + C := To_Unsigned_8 (Item (J)); + + -- Codes in the range 16#00# - 16#7F# are represented as + -- 0xxxxxxx + + if C <= 16#7F# then + Store (C); + + -- Codes in the range 16#80# - 16#7FF# are represented as + -- 110yyyxx 10xxxxxx + + -- For type character of course, the limit is 16#FF# in any case + + else + Store (2#110_00000# or Shift_Right (C, 6)); + Store (2#10_000000# or (C and 2#00_111111#)); + end if; + end loop; + + return Result (1 .. Len); + end Encode; + + -- Encode String in UTF-16 + + function Encode + (Item : String; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + Result : UTF_16_Wide_String + (1 .. Item'Length + Boolean'Pos (Output_BOM)); + -- Output is same length as input + possible BOM + + Len : Integer; + -- Length of output string + + C : Unsigned_8; + + begin + -- Output BOM if required + + if Output_BOM then + Result (1) := BOM_16 (1); + Len := 1; + else + Len := 0; + end if; + + -- Loop through input characters encoding them + + for Iptr in Item'Range loop + C := To_Unsigned_8 (Item (Iptr)); + + -- Codes in the range 16#0000#..16#00FF# are output unchanged. This + -- includes all possible cases of Character values. + + Len := Len + 1; + Result (Len) := Wide_Character'Val (C); + end loop; + + return Result; + end Encode; + +end Ada.Strings.UTF_Encoding.Strings; diff --git a/gcc/ada/a-suenst.ads b/gcc/ada/a-suenst.ads new file mode 100755 index 000000000..1706cd665 --- /dev/null +++ b/gcc/ada/a-suenst.ads @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.STRINGS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an Ada 2012 package defined in AI05-0137-1. It is used for encoding +-- and decoding String values using UTF encodings. Note: this package is +-- consistent with Ada 95, and may be included in Ada 95 implementations. + +package Ada.Strings.UTF_Encoding.Strings is + pragma Pure (Strings); + + -- The encoding routines take a String as input and encode the result + -- using the specified UTF encoding method. The result includes a BOM if + -- the Output_BOM argument is set to True. All 256 values of type Character + -- are valid, so Encoding_Error cannot be raised for string input data. + + function Encode + (Item : String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String; + -- Encode String using UTF-8, UTF-16LE or UTF-16BE encoding as specified by + -- the Output_Scheme parameter. + + function Encode + (Item : String; + Output_BOM : Boolean := False) return UTF_8_String; + -- Encode String using UTF-8 encoding + + function Encode + (Item : String; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- Encode String using UTF_16 encoding + + -- The decoding routines take a UTF String as input, and return a decoded + -- Wide_String. If the UTF String starts with a BOM that matches the + -- encoding method, it is ignored. An incorrect BOM raises Encoding_Error, + -- as does a code out of range of type Character. + + function Decode + (Item : UTF_String; + Input_Scheme : Encoding_Scheme) return String; + -- The input is encoded in UTF_8, UTF_16LE or UTF_16BE as specified by the + -- Input_Scheme parameter. It is decoded and returned as a String value. + -- Note: a convenient form for scheme may be Encoding (UTF_String). + + function Decode + (Item : UTF_8_String) return String; + -- The input is encoded in UTF-8 and returned as a String value + + function Decode + (Item : UTF_16_Wide_String) return String; + -- The input is encoded in UTF-16 and returned as a String value + +end Ada.Strings.UTF_Encoding.Strings; diff --git a/gcc/ada/a-suewst.adb b/gcc/ada/a-suewst.adb new file mode 100755 index 000000000..67f39ec2d --- /dev/null +++ b/gcc/ada/a-suewst.adb @@ -0,0 +1,370 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.WIDE_STRINGS -- +-- -- +-- 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.Wide_Strings is + use Interfaces; + + ------------ + -- Decode -- + ------------ + + -- Decode UTF-8/UTF-16BE/UTF-16LE input to Wide_String + + function Decode + (Item : UTF_String; + Input_Scheme : Encoding_Scheme) return Wide_String + is + begin + if Input_Scheme = UTF_8 then + return Decode (Item); + else + return Decode (To_UTF_16 (Item, Input_Scheme)); + end if; + end Decode; + + -- Decode UTF-8 input to Wide_String + + function Decode (Item : UTF_8_String) return Wide_String is + Result : Wide_String (1 .. Item'Length); + -- Result string (worst case is same length as input) + + Len : Natural := 0; + -- Length of result stored so far + + Iptr : Natural; + -- Input Item pointer + + C : Unsigned_8; + R : Unsigned_16; + + procedure Get_Continuation; + -- Reads a continuation byte of the form 10xxxxxx, shifts R left + -- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On + -- return Ptr is incremented. Raises exception if continuation + -- byte does not exist or is invalid. + + ---------------------- + -- Get_Continuation -- + ---------------------- + + procedure Get_Continuation is + begin + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + + else + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + if C not in 2#10_000000# .. 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + else + R := Shift_Left (R, 6) or Unsigned_16 (C and 2#00_111111#); + end if; + end if; + end Get_Continuation; + + -- Start of processing for Decode + + begin + Iptr := Item'First; + + -- Skip BOM at start + + if Item'Length >= 3 + and then Item (Iptr .. Iptr + 2) = BOM_8 + then + Iptr := Iptr + 3; + + -- Error if bad BOM + + elsif Item'Length >= 2 + and then (Item (Iptr .. Iptr + 1) = BOM_16BE + or else + Item (Iptr .. Iptr + 1) = BOM_16LE) + then + Raise_Encoding_Error (Iptr); + end if; + + while Iptr <= Item'Last loop + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#00# - 16#7F# are represented as + -- 0xxxxxxx + + if C <= 16#7F# then + R := Unsigned_16 (C); + + -- No initial code can be of the form 10xxxxxx. Such codes are used + -- only for continuations. + + elsif C <= 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + + -- Codes in the range 16#80# - 16#7FF# are represented as + -- 110yyyxx 10xxxxxx + + elsif C <= 2#110_11111# then + R := Unsigned_16 (C and 2#000_11111#); + Get_Continuation; + + -- Codes in the range 16#800# - 16#FFFF# are represented as + -- 1110yyyy 10yyyyxx 10xxxxxx + + elsif C <= 2#1110_1111# then + R := Unsigned_16 (C and 2#0000_1111#); + Get_Continuation; + Get_Continuation; + + -- Codes in the range 16#10000# - 16#10FFFF# are represented as + -- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + + -- Such codes are out of range for Wide_String output + + else + Raise_Encoding_Error (Iptr - 1); + end if; + + Len := Len + 1; + Result (Len) := Wide_Character'Val (R); + end loop; + + return Result (1 .. Len); + end Decode; + + -- Decode UTF-16 input to Wide_String + + function Decode (Item : UTF_16_Wide_String) return Wide_String is + Result : Wide_String (1 .. Item'Length); + -- Result is same length as input (possibly minus 1 if BOM present) + + Len : Natural := 0; + -- Length of result + + Iptr : Natural; + -- Index of next Item element + + C : Unsigned_16; + + begin + -- Skip UTF-16 BOM at start + + Iptr := Item'First; + + if Item'Length > 0 and then Item (Iptr) = BOM_16 (1) then + Iptr := Iptr + 1; + end if; + + -- Loop through input characters + + while Iptr <= Item'Last loop + C := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#0000#..16#D7FF# or 16#E000#..16#FFFD# + -- represent their own value. + + if C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then + Len := Len + 1; + Result (Len) := Wide_Character'Val (C); + + -- Codes in the range 16#D800#..16#DBFF# represent the first of the + -- two surrogates used to encode the range 16#01_000#..16#10_FFFF". + -- Such codes are out of range for 16-bit output. + + -- The case of input in the range 16#DC00#..16#DFFF# must never + -- occur, since it means we have a second surrogate character with + -- no corresponding first surrogate. + + -- Codes in the range 16#FFFE# .. 16#FFFF# are also invalid since + -- they conflict with codes used for BOM values. + + -- Thus all remaining codes are invalid + + else + Raise_Encoding_Error (Iptr - 1); + end if; + end loop; + + return Result (1 .. Len); + end Decode; + + ------------ + -- Encode -- + ------------ + + -- Encode Wide_String in UTF-8, UTF-16BE or UTF-16LE + + function Encode + (Item : Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String + is + begin + -- Case of UTF_8 + + if Output_Scheme = UTF_8 then + return Encode (Item, Output_BOM); + + -- Case of UTF_16LE or UTF_16BE, use UTF-16 intermediary + + else + return From_UTF_16 (UTF_16_Wide_String'(Encode (Item)), + Output_Scheme, Output_BOM); + end if; + end Encode; + + -- Encode Wide_String in UTF-8 + + function Encode + (Item : Wide_String; + Output_BOM : Boolean := False) return UTF_8_String + is + Result : UTF_8_String (1 .. 3 * Item'Length + 3); + -- Worst case is three bytes per input byte + space for BOM + + Len : Natural; + -- Number of output codes stored in Result + + C : Unsigned_16; + -- Single input character + + procedure Store (C : Unsigned_16); + pragma Inline (Store); + -- Store one output code, C is in the range 0 .. 255 + + ----------- + -- Store -- + ----------- + + procedure Store (C : Unsigned_16) is + begin + Len := Len + 1; + Result (Len) := Character'Val (C); + end Store; + + -- Start of processing for UTF8_Encode + + begin + -- Output BOM if required + + if Output_BOM then + Result (1 .. 3) := BOM_8; + Len := 3; + else + Len := 0; + end if; + + -- Loop through characters of input + + for J in Item'Range loop + C := To_Unsigned_16 (Item (J)); + + -- Codes in the range 16#00# - 16#7F# are represented as + -- 0xxxxxxx + + if C <= 16#7F# then + Store (C); + + -- Codes in the range 16#80# - 16#7FF# are represented as + -- 110yyyxx 10xxxxxx + + elsif C <= 16#7FF# then + Store (2#110_00000# or Shift_Right (C, 6)); + Store (2#10_000000# or (C and 2#00_111111#)); + + -- Codes in the range 16#800# - 16#FFFF# are represented as + -- 1110yyyy 10yyyyxx 10xxxxxx + + else + Store (2#1110_0000# or Shift_Right (C, 12)); + Store (2#10_000000# or + Shift_Right (C and 2#111111_000000#, 6)); + Store (2#10_000000# or (C and 2#00_111111#)); + end if; + end loop; + + return Result (1 .. Len); + end Encode; + + -- Encode Wide_String in UTF-16 + + function Encode + (Item : Wide_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + Result : UTF_16_Wide_String + (1 .. Item'Length + Boolean'Pos (Output_BOM)); + -- Output is same length as input + possible BOM + + Len : Integer; + -- Length of output string + + C : Unsigned_16; + + begin + -- Output BOM if required + + if Output_BOM then + Result (1) := BOM_16 (1); + Len := 1; + else + Len := 0; + end if; + + -- Loop through input characters encoding them + + for Iptr in Item'Range loop + C := To_Unsigned_16 (Item (Iptr)); + + -- Codes in the range 16#0000#..16#D7FF# or 16#E000#..16#FFFD# are + -- output unchanged. + + if C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then + Len := Len + 1; + Result (Len) := Wide_Character'Val (C); + + -- Codes in the range 16#D800#..16#DFFF# should never appear in the + -- input, since no valid Unicode characters are in this range (which + -- would conflict with the UTF-16 surrogate encodings). Similarly + -- codes in the range 16#FFFE#..16#FFFF conflict with BOM codes. + -- Thus all remaining codes are illegal. + + else + Raise_Encoding_Error (Iptr); + end if; + end loop; + + return Result; + end Encode; + +end Ada.Strings.UTF_Encoding.Wide_Strings; diff --git a/gcc/ada/a-suewst.ads b/gcc/ada/a-suewst.ads new file mode 100755 index 000000000..e0f8d4cf5 --- /dev/null +++ b/gcc/ada/a-suewst.ads @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.WIDE_STRINGS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an Ada 2012 package defined in AI05-0137-1. It is used for encoding +-- and decoding Wide_String values using UTF encodings. Note: this package is +-- consistent with Ada 95, and may be included in Ada 95 implementations. + +package Ada.Strings.UTF_Encoding.Wide_Strings is + pragma Pure (Wide_Strings); + + -- The encoding routines take a Wide_String as input and encode the result + -- using the specified UTF encoding method. The result includes a BOM if + -- the Output_BOM argument is set to True. Encoding_Error is raised if an + -- invalid character appears in the input. In particular the characters + -- in the range 16#D800# .. 16#DFFF# are invalid because they conflict + -- with UTF-16 surrogate encodings, and the characters 16#FFFE# and + -- 16#FFFF# are also invalid because they conflict with BOM codes. + + function Encode + (Item : Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String; + -- Encode Wide_String using UTF-8, UTF-16LE or UTF-16BE encoding as + -- specified by the Output_Scheme parameter. + + function Encode + (Item : Wide_String; + Output_BOM : Boolean := False) return UTF_8_String; + -- Encode Wide_String using UTF-8 encoding + + function Encode + (Item : Wide_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- Encode Wide_String using UTF_16 encoding + + -- The decoding routines take a UTF String as input, and return a decoded + -- Wide_String. If the UTF String starts with a BOM that matches the + -- encoding method, it is ignored. An incorrect BOM raises Encoding_Error. + + function Decode + (Item : UTF_String; + Input_Scheme : Encoding_Scheme) return Wide_String; + -- The input is encoded in UTF_8, UTF_16LE or UTF_16BE as specified by the + -- Input_Scheme parameter. It is decoded and returned as a Wide_String + -- value. Note: a convenient form for scheme may be Encoding (UTF_String). + + function Decode + (Item : UTF_8_String) return Wide_String; + -- The input is encoded in UTF-8 and returned as a Wide_String value + + function Decode + (Item : UTF_16_Wide_String) return Wide_String; + -- The input is encoded in UTF-16 and returned as a Wide_String value + +end Ada.Strings.UTF_Encoding.Wide_Strings; diff --git a/gcc/ada/a-suezst.adb b/gcc/ada/a-suezst.adb new file mode 100755 index 000000000..40266fb92 --- /dev/null +++ b/gcc/ada/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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.UTF_Encoding.Wide_Wide_Strings is + use Interfaces; + + ------------ + -- Decode -- + ------------ + + -- Decode UTF-8/UTF-16BE/UTF-16LE input to Wide_Wide_String + + function Decode + (Item : UTF_String; + Input_Scheme : Encoding_Scheme) return Wide_Wide_String + is + begin + if Input_Scheme = UTF_8 then + return Decode (Item); + else + return Decode (To_UTF_16 (Item, Input_Scheme)); + end if; + end Decode; + + -- Decode UTF-8 input to Wide_Wide_String + + function Decode (Item : UTF_8_String) return Wide_Wide_String is + Result : Wide_Wide_String (1 .. Item'Length); + -- Result string (worst case is same length as input) + + Len : Natural := 0; + -- Length of result stored so far + + Iptr : Natural; + -- Input string pointer + + C : Unsigned_8; + R : Unsigned_32; + + procedure Get_Continuation; + -- Reads a continuation byte of the form 10xxxxxx, shifts R left + -- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On + -- return Ptr is incremented. Raises exception if continuation + -- byte does not exist or is invalid. + + ---------------------- + -- Get_Continuation -- + ---------------------- + + procedure Get_Continuation is + begin + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + + else + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + if C not in 2#10_000000# .. 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + else + R := Shift_Left (R, 6) or Unsigned_32 (C and 2#00_111111#); + end if; + end if; + end Get_Continuation; + + -- Start of processing for Decode + + begin + Iptr := Item'First; + + -- Skip BOM at start + + if Item'Length >= 3 + and then Item (Iptr .. Iptr + 2) = BOM_8 + then + Iptr := Iptr + 3; + + -- Error if bad BOM + + elsif Item'Length >= 2 + and then (Item (Iptr .. Iptr + 1) = BOM_16BE + or else + Item (Iptr .. Iptr + 1) = BOM_16LE) + then + Raise_Encoding_Error (Iptr); + end if; + + -- Loop through input characters + + while Iptr <= Item'Last loop + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#00# - 16#7F# are represented as + -- 0xxxxxxx + + if C <= 16#7F# then + R := Unsigned_32 (C); + + -- No initial code can be of the form 10xxxxxx. Such codes are used + -- only for continuations. + + elsif C <= 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + + -- Codes in the range 16#80# - 16#7FF# are represented as + -- 110yyyxx 10xxxxxx + + elsif C <= 2#110_11111# then + R := Unsigned_32 (C and 2#000_11111#); + Get_Continuation; + + -- Codes in the range 16#800# - 16#FFFF# are represented as + -- 1110yyyy 10yyyyxx 10xxxxxx + + elsif C <= 2#1110_1111# then + R := Unsigned_32 (C and 2#0000_1111#); + Get_Continuation; + Get_Continuation; + + -- Codes in the range 16#10000# - 16#10FFFF# are represented as + -- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + + elsif C <= 2#11110_111# then + R := Unsigned_32 (C and 2#00000_111#); + Get_Continuation; + Get_Continuation; + Get_Continuation; + + -- Any other code is an error + + else + Raise_Encoding_Error (Iptr - 1); + end if; + + Len := Len + 1; + Result (Len) := Wide_Wide_Character'Val (R); + end loop; + + return Result (1 .. Len); + end Decode; + + -- Decode UTF-16 input to Wide_Wide_String + + function Decode (Item : UTF_16_Wide_String) return Wide_Wide_String is + Result : Wide_Wide_String (1 .. Item'Length); + -- Result cannot be longer than the input string + + Len : Natural := 0; + -- Length of result + + Iptr : Natural; + -- Pointer to next element in Item + + C : Unsigned_16; + R : Unsigned_32; + + begin + -- Skip UTF-16 BOM at start + + Iptr := Item'First; + + if Iptr <= Item'Last and then Item (Iptr) = BOM_16 (1) then + Iptr := Iptr + 1; + end if; + + -- Loop through input characters + + while Iptr <= Item'Last loop + C := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#0000#..16#D7FF# or 16#E000#..16#FFFD# + -- represent their own value. + + if C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then + Len := Len + 1; + Result (Len) := Wide_Wide_Character'Val (C); + + -- Codes in the range 16#D800#..16#DBFF# represent the first of the + -- two surrogates used to encode the range 16#01_000#..16#10_FFFF". + -- The first surrogate provides 10 high order bits of the result. + + elsif C <= 16#DBFF# then + R := Shift_Left ((Unsigned_32 (C) - 16#D800#), 10); + + -- Error if at end of string + + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + + -- Otherwise next character must be valid low order surrogate + -- which provides the low 10 order bits of the result. + + else + C := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + + if C not in 16#DC00# .. 16#DFFF# then + Raise_Encoding_Error (Iptr - 1); + + else + R := R or (Unsigned_32 (C) mod 2 ** 10); + + -- The final adjustment is to add 16#01_0000 to get the + -- result back in the required 21 bit range. + + R := R + 16#01_0000#; + Len := Len + 1; + Result (Len) := Wide_Wide_Character'Val (R); + end if; + end if; + + -- Remaining codes are invalid + + else + Raise_Encoding_Error (Iptr - 1); + end if; + end loop; + + return Result (1 .. Len); + end Decode; + + ------------ + -- Encode -- + ------------ + + -- Encode Wide_Wide_String in UTF-8, UTF-16BE or UTF-16LE + + function Encode + (Item : Wide_Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String + is + begin + if Output_Scheme = UTF_8 then + return Encode (Item, Output_BOM); + else + return From_UTF_16 (Encode (Item), Output_Scheme, Output_BOM); + end if; + end Encode; + + -- Encode Wide_Wide_String in UTF-8 + + function Encode + (Item : Wide_Wide_String; + Output_BOM : Boolean := False) return UTF_8_String + is + Result : String (1 .. 4 * Item'Length + 3); + -- Worst case is four bytes per input byte + space for BOM + + Len : Natural; + -- Number of output codes stored in Result + + C : Unsigned_32; + -- Single input character + + procedure Store (C : Unsigned_32); + pragma Inline (Store); + -- Store one output code (input is in range 0 .. 255) + + ----------- + -- Store -- + ----------- + + procedure Store (C : Unsigned_32) is + begin + Len := Len + 1; + Result (Len) := Character'Val (C); + end Store; + + -- Start of processing for Encode + + begin + -- Output BOM if required + + if Output_BOM then + Result (1 .. 3) := BOM_8; + Len := 3; + else + Len := 0; + end if; + + -- Loop through characters of input + + for Iptr in Item'Range loop + C := To_Unsigned_32 (Item (Iptr)); + + -- Codes in the range 16#00#..16#7F# are represented as + -- 0xxxxxxx + + if C <= 16#7F# then + Store (C); + + -- Codes in the range 16#80#..16#7FF# are represented as + -- 110yyyxx 10xxxxxx + + elsif C <= 16#7FF# then + Store (2#110_00000# or Shift_Right (C, 6)); + Store (2#10_000000# or (C and 2#00_111111#)); + + -- Codes in the range 16#800#..16#D7FF# or 16#E000#..16#FFFD# are + -- represented as + -- 1110yyyy 10yyyyxx 10xxxxxx + + elsif C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then + Store (2#1110_0000# or Shift_Right (C, 12)); + Store (2#10_000000# or + Shift_Right (C and 2#111111_000000#, 6)); + Store (2#10_000000# or (C and 2#00_111111#)); + + -- Codes in the range 16#10000# - 16#10FFFF# are represented as + -- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + + elsif C in 16#1_0000# .. 16#10_FFFF# then + Store (2#11110_000# or + Shift_Right (C, 18)); + Store (2#10_000000# or + Shift_Right (C and 2#111111_000000_000000#, 12)); + Store (2#10_000000# or + Shift_Right (C and 2#111111_000000#, 6)); + Store (2#10_000000# or + (C and 2#00_111111#)); + + -- All other codes are invalid + + else + Raise_Encoding_Error (Iptr); + end if; + end loop; + + return Result (1 .. Len); + end Encode; + + -- Encode Wide_Wide_String in UTF-16 + + function Encode + (Item : Wide_Wide_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + Result : UTF_16_Wide_String (1 .. 2 * Item'Length + 1); + -- Worst case is each input character generates two output characters + -- plus one for possible BOM. + + Len : Integer; + -- Length of output string + + C : Unsigned_32; + + begin + -- Output BOM if needed + + if Output_BOM then + Result (1) := BOM_16 (1); + Len := 1; + else + Len := 0; + end if; + + -- Loop through input characters encoding them + + for Iptr in Item'Range loop + C := To_Unsigned_32 (Item (Iptr)); + + -- Codes in the range 16#00_0000#..16#00_D7FF# or 16#E000#..16#FFFD# + -- are output unchanged + + if C <= 16#00_D7FF# or else C in 16#E000# .. 16#FFFD# then + Len := Len + 1; + Result (Len) := Wide_Character'Val (C); + + -- Codes in the range 16#01_0000#..16#10_FFFF# are output using two + -- surrogate characters. First 16#1_0000# is subtracted from the code + -- point to give a 20-bit value. This is then split into two separate + -- 10-bit values each of which is represented as a surrogate with the + -- most significant half placed in the first surrogate. The ranges of + -- values used for the two surrogates are 16#D800#-16#DBFF# for the + -- first, most significant surrogate and 16#DC00#-16#DFFF# for the + -- second, least significant surrogate. + + elsif C in 16#1_0000# .. 16#10_FFFF# then + C := C - 16#1_0000#; + + Len := Len + 1; + Result (Len) := Wide_Character'Val (16#D800# + C / 2 ** 10); + + Len := Len + 1; + Result (Len) := Wide_Character'Val (16#DC00# + C mod 2 ** 10); + + -- All other codes are invalid + + else + Raise_Encoding_Error (Iptr); + end if; + end loop; + + return Result (1 .. Len); + end Encode; + +end Ada.Strings.UTF_Encoding.Wide_Wide_Strings; diff --git a/gcc/ada/a-suezst.ads b/gcc/ada/a-suezst.ads new file mode 100755 index 000000000..86d344d25 --- /dev/null +++ b/gcc/ada/a-suezst.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.WIDE_WIDE_STRINGS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an Ada 2012 package defined in AI05-0137-1. It is used for encoding +-- and decoding Wide_String values using UTF encodings. Note: this package is +-- consistent with Ada 2005, and may be used in Ada 2005 mode, but cannot be +-- used in Ada 95 mode, since Wide_Wide_Character is an Ada 2005 feature. + +package Ada.Strings.UTF_Encoding.Wide_Wide_Strings is + pragma Pure (Wide_Wide_Strings); + + -- The encoding routines take a Wide_Wide_String as input and encode the + -- result using the specified UTF encoding method. The result includes a + -- BOM if the Output_BOM parameter is set to True. + + function Encode + (Item : Wide_Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String; + -- Encode Wide_Wide_String using UTF-8, UTF-16LE or UTF-16BE encoding as + -- specified by the Output_Scheme parameter. + + function Encode + (Item : Wide_Wide_String; + Output_BOM : Boolean := False) return UTF_8_String; + -- Encode Wide_Wide_String using UTF-8 encoding + + function Encode + (Item : Wide_Wide_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- Encode Wide_Wide_String using UTF_16 encoding + + -- The decoding routines take a UTF String as input, and return a decoded + -- Wide_String. If the UTF String starts with a BOM that matches the + -- encoding method, it is ignored. An incorrect BOM raises Encoding_Error. + + function Decode + (Item : UTF_String; + Input_Scheme : Encoding_Scheme) return Wide_Wide_String; + -- The input is encoded in UTF_8, UTF_16LE or UTF_16BE as specified by the + -- Input_Scheme parameter. It is decoded and returned as a Wide_Wide_String + -- value. Note: a convenient form for Scheme may be Encoding (UTF_String). + + function Decode + (Item : UTF_8_String) return Wide_Wide_String; + -- The input is encoded in UTF-8 and returned as a Wide_Wide_String value + + function Decode + (Item : UTF_16_Wide_String) return Wide_Wide_String; + -- The input is encoded in UTF-16 and returned as a Wide_String value + +end Ada.Strings.UTF_Encoding.Wide_Wide_Strings; diff --git a/gcc/ada/a-suteio-shared.adb b/gcc/ada/a-suteio-shared.adb new file mode 100644 index 000000000..d50ed7767 --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..0a67067dc --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..2b4840710 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 new file mode 100644 index 000000000..643b5b0e6 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System.String_Hash; + +function Ada.Strings.Wide_Bounded.Wide_Hash + (Key : Bounded.Bounded_Wide_String) + return Containers.Hash_Type +is + use Ada.Containers; + function Hash is new System.String_Hash.Hash + (Wide_Character, Wide_String, Hash_Type); +begin + return Hash (Bounded.To_Wide_String (Key)); +end Ada.Strings.Wide_Bounded.Wide_Hash; diff --git a/gcc/ada/a-swbwha.ads b/gcc/ada/a-swbwha.ads new file mode 100644 index 000000000..6a4fba76f --- /dev/null +++ b/gcc/ada/a-swbwha.ads @@ -0,0 +1,25 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ B O U N D E D . W I D E _ H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers; + +generic + with package Bounded is + new Ada.Strings.Wide_Bounded.Generic_Bounded_Length (<>); + +function Ada.Strings.Wide_Bounded.Wide_Hash (Key : Bounded.Bounded_Wide_String) + return Containers.Hash_Type; + +pragma Preelaborate (Ada.Strings.Wide_Bounded.Wide_Hash); diff --git a/gcc/ada/a-swfwha.ads b/gcc/ada/a-swfwha.ads new file mode 100644 index 000000000..c42d54cd5 --- /dev/null +++ b/gcc/ada/a-swfwha.ads @@ -0,0 +1,22 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ F I X E D . W I D E _ H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers, Ada.Strings.Wide_Hash; + +function Ada.Strings.Wide_Fixed.Wide_Hash + (Key : Wide_String) return Containers.Hash_Type + renames Ada.Strings.Wide_Hash; + +pragma Pure (Ada.Strings.Wide_Fixed.Wide_Hash); diff --git a/gcc/ada/a-swmwco.ads b/gcc/ada/a-swmwco.ads new file mode 100644 index 000000000..af46e34a6 --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..ad397b8c5 --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..004a5d4ac --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..78fa5dbb8 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 new file mode 100644 index 000000000..e36744783 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System.String_Hash; + +function Ada.Strings.Wide_Unbounded.Wide_Hash + (Key : Unbounded_Wide_String) return Containers.Hash_Type +is + use Ada.Containers; + function Hash is new System.String_Hash.Hash + (Wide_Character, Wide_String, Hash_Type); +begin + return Hash (To_Wide_String (Key)); +end Ada.Strings.Wide_Unbounded.Wide_Hash; diff --git a/gcc/ada/a-swuwha.ads b/gcc/ada/a-swuwha.ads new file mode 100644 index 000000000..8da567aae --- /dev/null +++ b/gcc/ada/a-swuwha.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . W I D E _ H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Is this really an RM unit? Doc needed ??? + +with Ada.Containers; + +function Ada.Strings.Wide_Unbounded.Wide_Hash + (Key : Unbounded_Wide_String) return Containers.Hash_Type; + +pragma Preelaborate (Ada.Strings.Wide_Unbounded.Wide_Hash); diff --git a/gcc/ada/a-swuwti-shared.adb b/gcc/ada/a-swuwti-shared.adb new file mode 100644 index 000000000..9cf7c0ad5 --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..65f26cd8b --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..a3b742eec --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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-sytaco.adb b/gcc/ada/a-sytaco.adb new file mode 100644 index 000000000..62bced2ad --- /dev/null +++ b/gcc/ada/a-sytaco.adb @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S Y N C H R O N O U S _ T A S K _ 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 Ada.Exceptions; + +with System.Tasking; +with System.Task_Primitives.Operations; + +package body Ada.Synchronous_Task_Control is + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (S : in out Suspension_Object) is + begin + System.Task_Primitives.Operations.Initialize (S.SO); + end Initialize; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (S : in out Suspension_Object) is + begin + System.Task_Primitives.Operations.Finalize (S.SO); + end Finalize; + + ------------------- + -- Current_State -- + ------------------- + + function Current_State (S : Suspension_Object) return Boolean is + begin + return System.Task_Primitives.Operations.Current_State (S.SO); + end Current_State; + + --------------- + -- Set_False -- + --------------- + + procedure Set_False (S : in out Suspension_Object) is + begin + System.Task_Primitives.Operations.Set_False (S.SO); + end Set_False; + + -------------- + -- Set_True -- + -------------- + + procedure Set_True (S : in out Suspension_Object) is + begin + System.Task_Primitives.Operations.Set_True (S.SO); + end Set_True; + + ------------------------ + -- Suspend_Until_True -- + ------------------------ + + procedure Suspend_Until_True (S : in out Suspension_Object) is + begin + -- This is a potentially blocking (see ARM D.10, par. 10), so that + -- if pragma Detect_Blocking is active then Program_Error must be + -- raised if this operation is called from a protected action. + + if System.Tasking.Detect_Blocking + and then System.Tasking.Self.Common.Protected_Action_Nesting > 0 + then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + end if; + + System.Task_Primitives.Operations.Suspend_Until_True (S.SO); + end Suspend_Until_True; + +end Ada.Synchronous_Task_Control; diff --git a/gcc/ada/a-sytaco.ads b/gcc/ada/a-sytaco.ads new file mode 100644 index 000000000..02ba6ae1a --- /dev/null +++ b/gcc/ada/a-sytaco.ads @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S Y N C H R O N O U S _ T A S K _ C O N T R O 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Task_Primitives; + +with Ada.Finalization; + +package Ada.Synchronous_Task_Control is + pragma Preelaborate_05; + -- In accordance with Ada 2005 AI-362 + + type Suspension_Object is limited private; + + procedure Set_True (S : in out Suspension_Object); + + procedure Set_False (S : in out Suspension_Object); + + function Current_State (S : Suspension_Object) return Boolean; + + procedure Suspend_Until_True (S : in out Suspension_Object); + +private + + procedure Initialize (S : in out Suspension_Object); + -- Initialization for Suspension_Object + + procedure Finalize (S : in out Suspension_Object); + -- Finalization for Suspension_Object + + type Suspension_Object is + new Ada.Finalization.Limited_Controlled with + record + SO : System.Task_Primitives.Suspension_Object; + -- Use low-level suspension objects so that the synchronization + -- functionality provided by this object can be achieved using + -- efficient operating system primitives. + end record; + + pragma Inline (Set_True); + pragma Inline (Set_False); + pragma Inline (Current_State); + pragma Inline (Suspend_Until_True); + pragma Inline (Initialize); + pragma Inline (Finalize); + +end Ada.Synchronous_Task_Control; diff --git a/gcc/ada/a-szbzha.adb b/gcc/ada/a-szbzha.adb new file mode 100644 index 000000000..9ee1e9137 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System.String_Hash; + +function Ada.Strings.Wide_Wide_Bounded.Wide_Wide_Hash + (Key : Bounded.Bounded_Wide_Wide_String) + return Containers.Hash_Type +is + use Ada.Containers; + function Hash is new System.String_Hash.Hash + (Wide_Wide_Character, Wide_Wide_String, Hash_Type); +begin + return Hash (Bounded.To_Wide_Wide_String (Key)); +end Ada.Strings.Wide_Wide_Bounded.Wide_Wide_Hash; diff --git a/gcc/ada/a-szbzha.ads b/gcc/ada/a-szbzha.ads new file mode 100644 index 000000000..d7911defb --- /dev/null +++ b/gcc/ada/a-szbzha.ads @@ -0,0 +1,28 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_WIDE_BOUNDED.WIDE_WIDE_HASH -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Is this really an RM unit? doc needed ??? + +with Ada.Containers; + +generic + with package Bounded is + new Ada.Strings.Wide_Wide_Bounded.Generic_Bounded_Length (<>); + +function Ada.Strings.Wide_Wide_Bounded.Wide_Wide_Hash + (Key : Bounded.Bounded_Wide_Wide_String) + return Containers.Hash_Type; + +pragma Preelaborate (Ada.Strings.Wide_Wide_Bounded.Wide_Wide_Hash); diff --git a/gcc/ada/a-szfzha.ads b/gcc/ada/a-szfzha.ads new file mode 100644 index 000000000..5deb5d7c3 --- /dev/null +++ b/gcc/ada/a-szfzha.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ F I X E D . -- +-- W I D E _ W I D E _ H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers; +with Ada.Strings.Wide_Wide_Hash; + +function Ada.Strings.Wide_Wide_Fixed.Wide_Wide_Hash + (Key : Wide_Wide_String) return Containers.Hash_Type + renames Ada.Strings.Wide_Wide_Hash; + +pragma Pure (Ada.Strings.Wide_Wide_Fixed.Wide_Wide_Hash); diff --git a/gcc/ada/a-szmzco.ads b/gcc/ada/a-szmzco.ads new file mode 100644 index 000000000..f54746dc7 --- /dev/null +++ b/gcc/ada/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-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_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 new file mode 100644 index 000000000..87b2cb40d --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..7ab9cc5ac --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..6115330d9 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 new file mode 100644 index 000000000..13cb19b7d --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System.String_Hash; + +function Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash + (Key : Unbounded_Wide_Wide_String) return Containers.Hash_Type +is + use Ada.Containers; + function Hash is new System.String_Hash.Hash + (Wide_Wide_Character, Wide_Wide_String, Hash_Type); +begin + return Hash (To_Wide_Wide_String (Key)); +end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash; diff --git a/gcc/ada/a-szuzha.ads b/gcc/ada/a-szuzha.ads new file mode 100644 index 000000000..94bed28eb --- /dev/null +++ b/gcc/ada/a-szuzha.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . W I D E _ H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers; + +function Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash + (Key : Unbounded_Wide_Wide_String) return Containers.Hash_Type; + +pragma Preelaborate (Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash); diff --git a/gcc/ada/a-szuzti-shared.adb b/gcc/ada/a-szuzti-shared.adb new file mode 100644 index 000000000..247ccb2bc --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..25feb202f --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..f84a34ed0 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This child package of Ada.Strings.Wide_Wide_Unbounded provides specialized +-- Wide_Wide_Text_IO routines that work directly with unbounded wide wide +-- strings, avoiding the inefficiencies of access via the standard interface, +-- and also taking direct advantage of the variable length semantics of these +-- strings. + +with Ada.Wide_Wide_Text_IO; + +package Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO is + + function Get_Line + return Unbounded_Wide_Wide_String; + function Get_Line + (File : Ada.Wide_Wide_Text_IO.File_Type) + return Unbounded_Wide_Wide_String; + -- Reads up to the end of the current line, returning the result + -- as an unbounded string of appropriate length. If no File parameter + -- is present, input is from Current_Input. + + procedure Get_Line + (File : Ada.Wide_Wide_Text_IO.File_Type; + Item : out Unbounded_Wide_Wide_String); + procedure Get_Line (Item : out Unbounded_Wide_Wide_String); + -- Similar to the above, but in procedure form with an out parameter + + procedure Put + (U : Unbounded_Wide_Wide_String); + procedure Put + (File : Ada.Wide_Wide_Text_IO.File_Type; + U : Unbounded_Wide_Wide_String); + procedure Put_Line + (U : Unbounded_Wide_Wide_String); + procedure Put_Line + (File : Ada.Wide_Wide_Text_IO.File_Type; + U : Unbounded_Wide_Wide_String); + -- These are equivalent to the standard Wide_Wide_Text_IO routines passed + -- the value To_Wide_Wide_String (U), but operate more efficiently, + -- because the extra copy of the argument is avoided. + +end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO; diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb new file mode 100644 index 000000000..6f6a8aa02 --- /dev/null +++ b/gcc/ada/a-tags.adb @@ -0,0 +1,1002 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T A G 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.Exceptions; +with Ada.Unchecked_Conversion; +with System.HTable; +with System.Storage_Elements; use System.Storage_Elements; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_StW; use System.WCh_StW; + +pragma Elaborate_All (System.HTable); + +package body Ada.Tags is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean; + -- Given the tag of an object and the tag associated to a type, return + -- true if Obj is in Typ'Class. + + function Get_External_Tag (T : Tag) return System.Address; + -- Returns address of a null terminated string containing the external name + + function Is_Primary_DT (T : Tag) return Boolean; + -- Given a tag returns True if it has the signature of a primary dispatch + -- table. This is Inline_Always since it is called from other Inline_ + -- Always subprograms where we want no out of line code to be generated. + + function Length (Str : Cstring_Ptr) return Natural; + -- Length of string represented by the given pointer (treating the string + -- as a C-style string, which is Nul terminated). + + function OSD (T : Tag) return Object_Specific_Data_Ptr; + -- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table, + -- retrieve the address of the record containing the Object Specific + -- Data table. + + function SSD (T : Tag) return Select_Specific_Data_Ptr; + -- Ada 2005 (AI-251): Given a pointer T to a dispatch Table, retrieves the + -- address of the record containing the Select Specific Data in T's TSD. + + pragma Inline_Always (CW_Membership); + pragma Inline_Always (Get_External_Tag); + pragma Inline_Always (Is_Primary_DT); + pragma Inline_Always (OSD); + pragma Inline_Always (SSD); + + -- Unchecked conversions + + function To_Address is + new Unchecked_Conversion (Cstring_Ptr, System.Address); + + function To_Cstring_Ptr is + new Unchecked_Conversion (System.Address, Cstring_Ptr); + + -- Disable warnings on possible aliasing problem + + function To_Tag is + new Unchecked_Conversion (Integer_Address, Tag); + + function To_Addr_Ptr is + new Ada.Unchecked_Conversion (System.Address, Addr_Ptr); + + function To_Address is + new Ada.Unchecked_Conversion (Tag, System.Address); + + function To_Dispatch_Table_Ptr is + new Ada.Unchecked_Conversion (Tag, Dispatch_Table_Ptr); + + function To_Dispatch_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Dispatch_Table_Ptr); + + function To_Object_Specific_Data_Ptr is + new Ada.Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr); + + function To_Tag_Ptr is + new Ada.Unchecked_Conversion (System.Address, Tag_Ptr); + + function To_Type_Specific_Data_Ptr is + new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr); + + ------------------------------- + -- Inline_Always Subprograms -- + ------------------------------- + + -- Inline_always subprograms must be placed before their first call to + -- avoid defeating the frontend inlining mechanism and thus ensure the + -- generation of their correct debug info. + + ------------------- + -- CW_Membership -- + ------------------- + + -- Canonical implementation of Classwide Membership corresponding to: + + -- Obj in Typ'Class + + -- Each dispatch table contains a reference to a table of ancestors (stored + -- in the first part of the Tags_Table) and a count of the level of + -- inheritance "Idepth". + + -- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are + -- contained in the dispatch table referenced by Obj'Tag . Knowing the + -- level of inheritance of both types, this can be computed in constant + -- time by the formula: + + -- TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth) + -- = Typ'tag + + function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is + Obj_TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (Obj_Tag) - DT_Typeinfo_Ptr_Size); + Typ_TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (Typ_Tag) - DT_Typeinfo_Ptr_Size); + Obj_TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (Obj_TSD_Ptr.all); + Typ_TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (Typ_TSD_Ptr.all); + Pos : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth; + begin + return Pos >= 0 and then Obj_TSD.Tags_Table (Pos) = Typ_Tag; + end CW_Membership; + + ---------------------- + -- Get_External_Tag -- + ---------------------- + + function Get_External_Tag (T : Tag) return System.Address is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + begin + return To_Address (TSD.External_Tag); + end Get_External_Tag; + + ------------------- + -- Is_Primary_DT -- + ------------------- + + function Is_Primary_DT (T : Tag) return Boolean is + begin + return DT (T).Signature = Primary_DT; + end Is_Primary_DT; + + --------- + -- OSD -- + --------- + + function OSD (T : Tag) return Object_Specific_Data_Ptr is + OSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + begin + return To_Object_Specific_Data_Ptr (OSD_Ptr.all); + end OSD; + + --------- + -- SSD -- + --------- + + function SSD (T : Tag) return Select_Specific_Data_Ptr is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + begin + return TSD.SSD; + end SSD; + + ------------------------- + -- External_Tag_HTable -- + ------------------------- + + type HTable_Headers is range 1 .. 64; + + -- The following internal package defines the routines used for the + -- instantiation of a new System.HTable.Static_HTable (see below). See + -- spec in g-htable.ads for details of usage. + + package HTable_Subprograms is + procedure Set_HT_Link (T : Tag; Next : Tag); + function Get_HT_Link (T : Tag) return Tag; + function Hash (F : System.Address) return HTable_Headers; + function Equal (A, B : System.Address) return Boolean; + end HTable_Subprograms; + + package External_Tag_HTable is new System.HTable.Static_HTable ( + Header_Num => HTable_Headers, + Element => Dispatch_Table, + Elmt_Ptr => Tag, + Null_Ptr => null, + Set_Next => HTable_Subprograms.Set_HT_Link, + Next => HTable_Subprograms.Get_HT_Link, + Key => System.Address, + Get_Key => Get_External_Tag, + Hash => HTable_Subprograms.Hash, + Equal => HTable_Subprograms.Equal); + + ------------------------ + -- HTable_Subprograms -- + ------------------------ + + -- Bodies of routines for hash table instantiation + + package body HTable_Subprograms is + + ----------- + -- Equal -- + ----------- + + function Equal (A, B : System.Address) return Boolean is + Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A); + Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B); + J : Integer := 1; + begin + loop + if Str1 (J) /= Str2 (J) then + return False; + elsif Str1 (J) = ASCII.NUL then + return True; + else + J := J + 1; + end if; + end loop; + end Equal; + + ----------------- + -- Get_HT_Link -- + ----------------- + + function Get_HT_Link (T : Tag) return Tag is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + begin + return TSD.HT_Link.all; + end Get_HT_Link; + + ---------- + -- Hash -- + ---------- + + function Hash (F : System.Address) return HTable_Headers is + function H is new System.HTable.Hash (HTable_Headers); + Str : constant Cstring_Ptr := To_Cstring_Ptr (F); + Res : constant HTable_Headers := H (Str (1 .. Length (Str))); + begin + return Res; + end Hash; + + ----------------- + -- Set_HT_Link -- + ----------------- + + procedure Set_HT_Link (T : Tag; Next : Tag) is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + begin + TSD.HT_Link.all := Next; + end Set_HT_Link; + + end HTable_Subprograms; + + ------------------ + -- Base_Address -- + ------------------ + + function Base_Address (This : System.Address) return System.Address is + begin + return This - Offset_To_Top (This); + end Base_Address; + + -------------------- + -- Descendant_Tag -- + -------------------- + + function Descendant_Tag (External : String; Ancestor : Tag) return Tag is + Int_Tag : constant Tag := Internal_Tag (External); + + begin + if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then + raise Tag_Error; + end if; + + return Int_Tag; + end Descendant_Tag; + + -------------- + -- Displace -- + -------------- + + function Displace + (This : System.Address; + T : Tag) return System.Address + is + Iface_Table : Interface_Data_Ptr; + Obj_Base : System.Address; + Obj_DT : Dispatch_Table_Ptr; + Obj_DT_Tag : Tag; + + begin + if System."=" (This, System.Null_Address) then + return System.Null_Address; + end if; + + Obj_Base := Base_Address (This); + Obj_DT_Tag := To_Tag_Ptr (Obj_Base).all; + Obj_DT := DT (To_Tag_Ptr (Obj_Base).all); + Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table; + + if Iface_Table /= null then + for Id in 1 .. Iface_Table.Nb_Ifaces loop + if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then + + -- Case of Static value of Offset_To_Top + + if Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top then + Obj_Base := Obj_Base + + Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value; + + -- Otherwise call the function generated by the expander to + -- provide the value. + + else + Obj_Base := Obj_Base + + Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func.all + (Obj_Base); + end if; + + return Obj_Base; + end if; + end loop; + end if; + + -- Check if T is an immediate ancestor. This is required to handle + -- conversion of class-wide interfaces to tagged types. + + if CW_Membership (Obj_DT_Tag, T) then + return Obj_Base; + end if; + + -- If the object does not implement the interface we must raise CE + + raise Constraint_Error with "invalid interface conversion"; + end Displace; + + -------- + -- DT -- + -------- + + function DT (T : Tag) return Dispatch_Table_Ptr is + Offset : constant SSE.Storage_Offset := + To_Dispatch_Table_Ptr (T).Prims_Ptr'Position; + begin + return To_Dispatch_Table_Ptr (To_Address (T) - Offset); + end DT; + + ------------------- + -- IW_Membership -- + ------------------- + + -- Canonical implementation of Classwide Membership corresponding to: + + -- Obj in Iface'Class + + -- Each dispatch table contains a table with the tags of all the + -- implemented interfaces. + + -- Obj is in Iface'Class if Iface'Tag is found in the table of interfaces + -- that are contained in the dispatch table referenced by Obj'Tag. + + function IW_Membership (This : System.Address; T : Tag) return Boolean is + Iface_Table : Interface_Data_Ptr; + Obj_Base : System.Address; + Obj_DT : Dispatch_Table_Ptr; + Obj_TSD : Type_Specific_Data_Ptr; + + begin + Obj_Base := Base_Address (This); + Obj_DT := DT (To_Tag_Ptr (Obj_Base).all); + Obj_TSD := To_Type_Specific_Data_Ptr (Obj_DT.TSD); + Iface_Table := Obj_TSD.Interfaces_Table; + + if Iface_Table /= null then + for Id in 1 .. Iface_Table.Nb_Ifaces loop + if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then + return True; + end if; + end loop; + end if; + + -- Look for the tag in the ancestor tags table. This is required for: + -- Iface_CW in Typ'Class + + for Id in 0 .. Obj_TSD.Idepth loop + if Obj_TSD.Tags_Table (Id) = T then + return True; + end if; + end loop; + + return False; + end IW_Membership; + + ------------------- + -- Expanded_Name -- + ------------------- + + function Expanded_Name (T : Tag) return String is + Result : Cstring_Ptr; + TSD_Ptr : Addr_Ptr; + TSD : Type_Specific_Data_Ptr; + + begin + if T = No_Tag then + raise Tag_Error; + end if; + + TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); + Result := TSD.Expanded_Name; + return Result (1 .. Length (Result)); + end Expanded_Name; + + ------------------ + -- External_Tag -- + ------------------ + + function External_Tag (T : Tag) return String is + Result : Cstring_Ptr; + TSD_Ptr : Addr_Ptr; + TSD : Type_Specific_Data_Ptr; + + begin + if T = No_Tag then + raise Tag_Error; + end if; + + TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); + Result := TSD.External_Tag; + return Result (1 .. Length (Result)); + end External_Tag; + + --------------------- + -- Get_Entry_Index -- + --------------------- + + function Get_Entry_Index (T : Tag; Position : Positive) return Positive is + begin + return SSD (T).SSD_Table (Position).Index; + end Get_Entry_Index; + + ---------------------- + -- Get_Prim_Op_Kind -- + ---------------------- + + function Get_Prim_Op_Kind + (T : Tag; + Position : Positive) return Prim_Op_Kind + is + begin + return SSD (T).SSD_Table (Position).Kind; + end Get_Prim_Op_Kind; + + ---------------------- + -- Get_Offset_Index -- + ---------------------- + + function Get_Offset_Index + (T : Tag; + Position : Positive) return Positive + is + begin + if Is_Primary_DT (T) then + return Position; + else + return OSD (T).OSD_Table (Position); + end if; + end Get_Offset_Index; + + ------------------- + -- Get_RC_Offset -- + ------------------- + + function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + begin + return TSD.RC_Offset; + end Get_RC_Offset; + + --------------------- + -- Get_Tagged_Kind -- + --------------------- + + function Get_Tagged_Kind (T : Tag) return Tagged_Kind is + begin + return DT (T).Tag_Kind; + end Get_Tagged_Kind; + + ----------------------------- + -- Interface_Ancestor_Tags -- + ----------------------------- + + function Interface_Ancestor_Tags (T : Tag) return Tag_Array is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + Iface_Table : constant Interface_Data_Ptr := TSD.Interfaces_Table; + + begin + if Iface_Table = null then + declare + Table : Tag_Array (1 .. 0); + begin + return Table; + end; + else + declare + Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces); + begin + for J in 1 .. Iface_Table.Nb_Ifaces loop + Table (J) := Iface_Table.Ifaces_Table (J).Iface_Tag; + end loop; + + return Table; + end; + end if; + end Interface_Ancestor_Tags; + + ------------------ + -- Internal_Tag -- + ------------------ + + -- Internal tags have the following format: + -- "Internal tag at 16#ADDRESS#: " + + Internal_Tag_Header : constant String := "Internal tag at "; + Header_Separator : constant Character := '#'; + + function Internal_Tag (External : String) return Tag is + Ext_Copy : aliased String (External'First .. External'Last + 1); + Res : Tag := null; + + begin + -- Handle locally defined tagged types + + if External'Length > Internal_Tag_Header'Length + and then + External (External'First .. + External'First + Internal_Tag_Header'Length - 1) + = Internal_Tag_Header + then + declare + Addr_First : constant Natural := + External'First + Internal_Tag_Header'Length; + Addr_Last : Natural; + Addr : Integer_Address; + + begin + -- Search the second separator (#) to identify the address + + Addr_Last := Addr_First; + + for J in 1 .. 2 loop + while Addr_Last <= External'Last + and then External (Addr_Last) /= Header_Separator + loop + Addr_Last := Addr_Last + 1; + end loop; + + -- Skip the first separator + + if J = 1 then + Addr_Last := Addr_Last + 1; + end if; + end loop; + + if Addr_Last <= External'Last then + + -- Protect the run-time against wrong internal tags. We + -- cannot use exception handlers here because it would + -- disable the use of this run-time compiling with + -- restriction No_Exception_Handler. + + declare + C : Character; + Wrong_Tag : Boolean := False; + + begin + if External (Addr_First) /= '1' + or else External (Addr_First + 1) /= '6' + or else External (Addr_First + 2) /= '#' + then + Wrong_Tag := True; + + else + for J in Addr_First + 3 .. Addr_Last - 1 loop + C := External (J); + + if not (C in '0' .. '9') + and then not (C in 'A' .. 'F') + and then not (C in 'a' .. 'f') + then + Wrong_Tag := True; + exit; + end if; + end loop; + end if; + + -- Convert the numeric value into a tag + + if not Wrong_Tag then + Addr := Integer_Address'Value + (External (Addr_First .. Addr_Last)); + + -- Internal tags never have value 0 + + if Addr /= 0 then + return To_Tag (Addr); + end if; + end if; + end; + end if; + end; + + -- Handle library-level tagged types + + else + -- Make NUL-terminated copy of external tag string + + Ext_Copy (External'Range) := External; + Ext_Copy (Ext_Copy'Last) := ASCII.NUL; + Res := External_Tag_HTable.Get (Ext_Copy'Address); + end if; + + if Res = null then + declare + Msg1 : constant String := "unknown tagged type: "; + Msg2 : String (1 .. Msg1'Length + External'Length); + + begin + Msg2 (1 .. Msg1'Length) := Msg1; + Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) := + External; + Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2); + end; + end if; + + return Res; + end Internal_Tag; + + --------------------------------- + -- Is_Descendant_At_Same_Level -- + --------------------------------- + + function Is_Descendant_At_Same_Level + (Descendant : Tag; + Ancestor : Tag) return Boolean + is + D_TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (Descendant) + - DT_Typeinfo_Ptr_Size); + A_TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (Ancestor) - DT_Typeinfo_Ptr_Size); + D_TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (D_TSD_Ptr.all); + A_TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (A_TSD_Ptr.all); + + begin + return CW_Membership (Descendant, Ancestor) + and then D_TSD.Access_Level = A_TSD.Access_Level; + end Is_Descendant_At_Same_Level; + + ------------ + -- Length -- + ------------ + + function Length (Str : Cstring_Ptr) return Natural is + Len : Integer; + + begin + Len := 1; + while Str (Len) /= ASCII.NUL loop + Len := Len + 1; + end loop; + + return Len - 1; + end Length; + + ------------------- + -- Offset_To_Top -- + ------------------- + + function Offset_To_Top + (This : System.Address) return SSE.Storage_Offset + is + Tag_Size : constant SSE.Storage_Count := + SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); + + type Storage_Offset_Ptr is access SSE.Storage_Offset; + function To_Storage_Offset_Ptr is + new Unchecked_Conversion (System.Address, Storage_Offset_Ptr); + + Curr_DT : Dispatch_Table_Ptr; + + begin + Curr_DT := DT (To_Tag_Ptr (This).all); + + if Curr_DT.Offset_To_Top = SSE.Storage_Offset'Last then + return To_Storage_Offset_Ptr (This + Tag_Size).all; + else + return Curr_DT.Offset_To_Top; + end if; + end Offset_To_Top; + + ----------------- + -- Parent_Size -- + ----------------- + + function Parent_Size + (Obj : System.Address; + T : Tag) return SSE.Storage_Count + is + Parent_Slot : constant Positive := 1; + -- The tag of the parent is always in the first slot of the table of + -- ancestor tags. + + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + -- Pointer to the TSD + + Parent_Tag : constant Tag := TSD.Tags_Table (Parent_Slot); + Parent_TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (Parent_Tag) + - DT_Typeinfo_Ptr_Size); + Parent_TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (Parent_TSD_Ptr.all); + + begin + -- Here we compute the size of the _parent field of the object + + return SSE.Storage_Count (Parent_TSD.Size_Func.all (Obj)); + end Parent_Size; + + ---------------- + -- Parent_Tag -- + ---------------- + + function Parent_Tag (T : Tag) return Tag is + TSD_Ptr : Addr_Ptr; + TSD : Type_Specific_Data_Ptr; + + begin + if T = No_Tag then + raise Tag_Error; + end if; + + TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); + + -- The Parent_Tag of a root-level tagged type is defined to be No_Tag. + -- The first entry in the Ancestors_Tags array will be null for such + -- a type, but it's better to be explicit about returning No_Tag in + -- this case. + + if TSD.Idepth = 0 then + return No_Tag; + else + return TSD.Tags_Table (1); + end if; + end Parent_Tag; + + ------------------------------- + -- Register_Interface_Offset -- + ------------------------------- + + procedure Register_Interface_Offset + (This : System.Address; + Interface_T : Tag; + Is_Static : Boolean; + Offset_Value : SSE.Storage_Offset; + Offset_Func : Offset_To_Top_Function_Ptr) + is + Prim_DT : Dispatch_Table_Ptr; + Iface_Table : Interface_Data_Ptr; + + begin + -- "This" points to the primary DT and we must save Offset_Value in + -- the Offset_To_Top field of the corresponding dispatch table. + + Prim_DT := DT (To_Tag_Ptr (This).all); + Iface_Table := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table; + + -- Save Offset_Value in the table of interfaces of the primary DT. + -- This data will be used by the subprogram "Displace" to give support + -- to backward abstract interface type conversions. + + -- Register the offset in the table of interfaces + + if Iface_Table /= null then + for Id in 1 .. Iface_Table.Nb_Ifaces loop + if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then + if Is_Static or else Offset_Value = 0 then + Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := True; + Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value := + Offset_Value; + else + Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := False; + Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func := + Offset_Func; + end if; + + return; + end if; + end loop; + end if; + + -- If we arrive here there is some error in the run-time data structure + + raise Program_Error; + end Register_Interface_Offset; + + ------------------ + -- Register_Tag -- + ------------------ + + procedure Register_Tag (T : Tag) is + begin + External_Tag_HTable.Set (T); + end Register_Tag; + + ------------------- + -- Secondary_Tag -- + ------------------- + + function Secondary_Tag (T, Iface : Tag) return Tag is + Iface_Table : Interface_Data_Ptr; + Obj_DT : Dispatch_Table_Ptr; + + begin + if not Is_Primary_DT (T) then + raise Program_Error; + end if; + + Obj_DT := DT (T); + Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table; + + if Iface_Table /= null then + for Id in 1 .. Iface_Table.Nb_Ifaces loop + if Iface_Table.Ifaces_Table (Id).Iface_Tag = Iface then + return Iface_Table.Ifaces_Table (Id).Secondary_DT; + end if; + end loop; + end if; + + -- If the object does not implement the interface we must raise CE + + raise Constraint_Error with "invalid interface conversion"; + end Secondary_Tag; + + --------------------- + -- Set_Entry_Index -- + --------------------- + + procedure Set_Entry_Index + (T : Tag; + Position : Positive; + Value : Positive) + is + begin + SSD (T).SSD_Table (Position).Index := Value; + end Set_Entry_Index; + + ----------------------- + -- Set_Offset_To_Top -- + ----------------------- + + procedure Set_Dynamic_Offset_To_Top + (This : System.Address; + Interface_T : Tag; + Offset_Value : SSE.Storage_Offset; + Offset_Func : Offset_To_Top_Function_Ptr) + is + Sec_Base : System.Address; + Sec_DT : Dispatch_Table_Ptr; + begin + -- Save the offset to top field in the secondary dispatch table + + if Offset_Value /= 0 then + Sec_Base := This + Offset_Value; + Sec_DT := DT (To_Tag_Ptr (Sec_Base).all); + Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last; + end if; + + Register_Interface_Offset + (This, Interface_T, False, Offset_Value, Offset_Func); + end Set_Dynamic_Offset_To_Top; + + ---------------------- + -- Set_Prim_Op_Kind -- + ---------------------- + + procedure Set_Prim_Op_Kind + (T : Tag; + Position : Positive; + Value : Prim_Op_Kind) + is + begin + SSD (T).SSD_Table (Position).Kind := Value; + end Set_Prim_Op_Kind; + + ---------------------- + -- Type_Is_Abstract -- + ---------------------- + + function Type_Is_Abstract (T : Tag) return Boolean is + TSD_Ptr : Addr_Ptr; + TSD : Type_Specific_Data_Ptr; + + begin + if T = No_Tag then + raise Tag_Error; + end if; + + TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); + return TSD.Type_Is_Abstract; + end Type_Is_Abstract; + + ------------------------ + -- Wide_Expanded_Name -- + ------------------------ + + WC_Encoding : Character; + pragma Import (C, WC_Encoding, "__gl_wc_encoding"); + -- Encoding method for source, as exported by binder + + function Wide_Expanded_Name (T : Tag) return Wide_String is + S : constant String := Expanded_Name (T); + W : Wide_String (1 .. S'Length); + L : Natural; + begin + String_To_Wide_String + (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); + return W (1 .. L); + end Wide_Expanded_Name; + + ----------------------------- + -- Wide_Wide_Expanded_Name -- + ----------------------------- + + function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String is + S : constant String := Expanded_Name (T); + W : Wide_Wide_String (1 .. S'Length); + L : Natural; + begin + String_To_Wide_Wide_String + (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); + return W (1 .. L); + end Wide_Wide_Expanded_Name; + +end Ada.Tags; diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads new file mode 100644 index 000000000..42063e26e --- /dev/null +++ b/gcc/ada/a-tags.ads @@ -0,0 +1,577 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T A G S -- +-- -- +-- 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 System; +with System.Storage_Elements; + +package Ada.Tags is + pragma Preelaborate_05; + -- In accordance with Ada 2005 AI-362 + + type Tag is private; + pragma Preelaborable_Initialization (Tag); + + No_Tag : constant Tag; + + function Expanded_Name (T : Tag) return String; + + function Wide_Expanded_Name (T : Tag) return Wide_String; + pragma Ada_05 (Wide_Expanded_Name); + + function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String; + pragma Ada_05 (Wide_Wide_Expanded_Name); + + function External_Tag (T : Tag) return String; + + function Internal_Tag (External : String) return Tag; + + function Descendant_Tag + (External : String; + Ancestor : Tag) return Tag; + pragma Ada_05 (Descendant_Tag); + + function Is_Descendant_At_Same_Level + (Descendant : Tag; + Ancestor : Tag) return Boolean; + pragma Ada_05 (Is_Descendant_At_Same_Level); + + function Parent_Tag (T : Tag) return Tag; + pragma Ada_05 (Parent_Tag); + + type Tag_Array is array (Positive range <>) of Tag; + + function Interface_Ancestor_Tags (T : Tag) return Tag_Array; + pragma Ada_05 (Interface_Ancestor_Tags); + + function Type_Is_Abstract (T : Tag) return Boolean; + pragma Ada_2012 (Type_Is_Abstract); + + Tag_Error : exception; + +private + -- Structure of the GNAT Primary Dispatch Table + + -- +--------------------+ + -- | Signature | + -- +--------------------+ + -- | Tagged_Kind | + -- +--------------------+ Predef Prims + -- | Predef_Prims -----------------------------> +------------+ + -- +--------------------+ | table of | + -- | Offset_To_Top | | predefined | + -- +--------------------+ | primitives | + -- |Typeinfo_Ptr/TSD_Ptr---> Type Specific Data +------------+ + -- Tag ---> +--------------------+ +-------------------+ + -- | table of | | inheritance depth | + -- : primitive ops : +-------------------+ + -- | pointers | | access level | + -- +--------------------+ +-------------------+ + -- | expanded name | + -- +-------------------+ + -- | external tag | + -- +-------------------+ + -- | hash table link | + -- +-------------------+ + -- | transportable | + -- +-------------------+ + -- | type_is_abstract | + -- +-------------------+ + -- | rec ctrler offset | + -- +-------------------+ + -- | Ifaces_Table ---> Interface Data + -- +-------------------+ +------------+ + -- Select Specific Data <---- SSD | | Nb_Ifaces | + -- +------------------+ +-------------------+ +------------+ + -- |table of primitive| | table of | | table | + -- : operation : : ancestor : : of : + -- | kinds | | tags | | interfaces | + -- +------------------+ +-------------------+ +------------+ + -- |table of | + -- : entry : + -- | indexes | + -- +------------------+ + + -- Structure of the GNAT Secondary Dispatch Table + + -- +--------------------+ + -- | Signature | + -- +--------------------+ + -- | Tagged_Kind | + -- +--------------------+ Predef Prims + -- | Predef_Prims -----------------------------> +------------+ + -- +--------------------+ | table of | + -- | Offset_To_Top | | predefined | + -- +--------------------+ | primitives | + -- | OSD_Ptr |---> Object Specific Data | thunks | + -- Tag ---> +--------------------+ +---------------+ +------------+ + -- | table of | | num prim ops | + -- : primitive op : +---------------+ + -- | thunk pointers | | table of | + -- +--------------------+ + primitive | + -- | op offsets | + -- +---------------+ + + -- The runtime information kept for each tagged type is separated into two + -- objects: the Dispatch Table and the Type Specific Data record. + + package SSE renames System.Storage_Elements; + + subtype Cstring is String (Positive); + type Cstring_Ptr is access all Cstring; + pragma No_Strict_Aliasing (Cstring_Ptr); + + -- Declarations for the table of interfaces + + type Offset_To_Top_Function_Ptr is + access function (This : System.Address) return SSE.Storage_Offset; + -- Type definition used to call the function that is generated by the + -- expander in case of tagged types with discriminants that have secondary + -- dispatch tables. This function provides the Offset_To_Top value in this + -- specific case. + + type Interface_Data_Element is record + Iface_Tag : Tag; + Static_Offset_To_Top : Boolean; + Offset_To_Top_Value : SSE.Storage_Offset; + Offset_To_Top_Func : Offset_To_Top_Function_Ptr; + Secondary_DT : Tag; + end record; + -- If some ancestor of the tagged type has discriminants the field + -- Static_Offset_To_Top is False and the field Offset_To_Top_Func + -- is used to store the access to the function generated by the + -- expander which provides this value; otherwise Static_Offset_To_Top + -- is True and such value is stored in the Offset_To_Top_Value field. + -- Secondary_DT references a secondary dispatch table whose contents + -- are pointers to the primitives of the tagged type that cover the + -- interface primitives. Secondary_DT gives support to dispatching + -- calls through interface types associated with Generic Dispatching + -- Constructors. + + type Interfaces_Array is array (Natural range <>) of Interface_Data_Element; + + type Interface_Data (Nb_Ifaces : Positive) is record + Ifaces_Table : Interfaces_Array (1 .. Nb_Ifaces); + end record; + + type Interface_Data_Ptr is access all Interface_Data; + -- Table of abstract interfaces used to give support to backward interface + -- conversions and also to IW_Membership. + + -- Primitive operation kinds. These values differentiate the kinds of + -- callable entities stored in the dispatch table. Certain kinds may + -- not be used, but are added for completeness. + + type Prim_Op_Kind is + (POK_Function, + POK_Procedure, + POK_Protected_Entry, + POK_Protected_Function, + POK_Protected_Procedure, + POK_Task_Entry, + POK_Task_Function, + POK_Task_Procedure); + + -- Select specific data types + + type Select_Specific_Data_Element is record + Index : Positive; + Kind : Prim_Op_Kind; + end record; + + type Select_Specific_Data_Array is + array (Positive range <>) of Select_Specific_Data_Element; + + type Select_Specific_Data (Nb_Prim : Positive) is record + SSD_Table : Select_Specific_Data_Array (1 .. Nb_Prim); + -- NOTE: Nb_Prim is the number of non-predefined primitive operations + end record; + + type Select_Specific_Data_Ptr is access all Select_Specific_Data; + -- A table used to store the primitive operation kind and entry index of + -- primitive subprograms of a type that implements a limited interface. + -- The Select Specific Data table resides in the Type Specific Data of a + -- type. This construct is used in the handling of dispatching triggers + -- in select statements. + + type Prim_Ptr is access procedure; + type Address_Array is array (Positive range <>) of Prim_Ptr; + + subtype Dispatch_Table is Address_Array (1 .. 1); + -- Used by GDB to identify the _tags and traverse the run-time structure + -- associated with tagged types. For compatibility with older versions of + -- gdb, its name must not be changed. + + type Tag is access all Dispatch_Table; + pragma No_Strict_Aliasing (Tag); + + type Interface_Tag is access all Dispatch_Table; + + No_Tag : constant Tag := null; + + -- The expander ensures that Tag objects reference the Prims_Ptr component + -- of the wrapper. + + type Tag_Ptr is access all Tag; + pragma No_Strict_Aliasing (Tag_Ptr); + + type Offset_To_Top_Ptr is access all SSE.Storage_Offset; + pragma No_Strict_Aliasing (Offset_To_Top_Ptr); + + type Tag_Table is array (Natural range <>) of Tag; + + type Size_Ptr is + access function (A : System.Address) return Long_Long_Integer; + + type Type_Specific_Data (Idepth : Natural) is record + -- The discriminant Idepth is the Inheritance Depth Level: Used to + -- implement the membership test associated with single inheritance of + -- tagged types in constant-time. It also indicates the size of the + -- Tags_Table component. + + Access_Level : Natural; + -- Accessibility level required to give support to Ada 2005 nested type + -- extensions. This feature allows safe nested type extensions by + -- shifting the accessibility checks to certain operations, rather than + -- being enforced at the type declaration. In particular, by performing + -- run-time accessibility checks on class-wide allocators, class-wide + -- function return, and class-wide stream I/O, the danger of objects + -- outliving their type declaration can be eliminated (Ada 2005: AI-344) + + Expanded_Name : Cstring_Ptr; + External_Tag : Cstring_Ptr; + HT_Link : Tag_Ptr; + -- Components used to support to the Ada.Tags subprograms in RM 3.9 + + -- Note: Expanded_Name is referenced by GDB to determine the actual name + -- of the tagged type. Its requirements are: 1) it must have this exact + -- name, and 2) its contents must point to a C-style Nul terminated + -- string containing its expanded name. GDB has no requirement on a + -- given position inside the record. + + Transportable : Boolean; + -- Used to check RM E.4(18), set for types that satisfy the requirements + -- for being used in remote calls as actuals for classwide formals or as + -- return values for classwide functions. + + Type_Is_Abstract : Boolean; + -- True if the type is abstract (Ada 2012: AI05-0173) + + RC_Offset : SSE.Storage_Offset; + -- Controller Offset: Used to give support to tagged controlled objects + -- (see Get_Deep_Controller at s-finimp) + + Size_Func : Size_Ptr; + -- Pointer to the subprogram computing the _size of the object. Used by + -- the run-time whenever a call to the 'size primitive is required. We + -- cannot assume that the contents of dispatch tables are addresses + -- because in some architectures the ABI allows descriptors. + + Interfaces_Table : Interface_Data_Ptr; + -- Pointer to the table of interface tags. It is used to implement the + -- membership test associated with interfaces and also for backward + -- abstract interface type conversions (Ada 2005:AI-251) + + SSD : Select_Specific_Data_Ptr; + -- Pointer to a table of records used in dispatching selects. This + -- field has a meaningful value for all tagged types that implement + -- a limited, protected, synchronized or task interfaces and have + -- non-predefined primitive operations. + + Tags_Table : Tag_Table (0 .. Idepth); + -- Table of ancestor tags. Its size actually depends on the inheritance + -- depth level of the tagged type. + end record; + + type Type_Specific_Data_Ptr is access all Type_Specific_Data; + pragma No_Strict_Aliasing (Type_Specific_Data_Ptr); + + -- Declarations for the dispatch table record + + type Signature_Kind is + (Unknown, + Primary_DT, + Secondary_DT); + + -- Tagged type kinds with respect to concurrency and limitedness + + type Tagged_Kind is + (TK_Abstract_Limited_Tagged, + TK_Abstract_Tagged, + TK_Limited_Tagged, + TK_Protected, + TK_Tagged, + TK_Task); + + type Dispatch_Table_Wrapper (Num_Prims : Natural) is record + Signature : Signature_Kind; + Tag_Kind : Tagged_Kind; + Predef_Prims : System.Address; + -- Pointer to the dispatch table of predefined Ada primitives + + -- According to the C++ ABI the components Offset_To_Top and TSD are + -- stored just "before" the dispatch table, and they are referenced with + -- negative offsets referring to the base of the dispatch table. The + -- _Tag (or the VTable_Ptr in C++ terminology) must point to the base + -- of the virtual table, just after these components, to point to the + -- Prims_Ptr table. + + Offset_To_Top : SSE.Storage_Offset; + TSD : System.Address; + + Prims_Ptr : aliased Address_Array (1 .. Num_Prims); + -- The size of the Prims_Ptr array actually depends on the tagged type + -- to which it applies. For each tagged type, the expander computes the + -- actual array size, allocates the Dispatch_Table record accordingly. + end record; + + type Dispatch_Table_Ptr is access all Dispatch_Table_Wrapper; + pragma No_Strict_Aliasing (Dispatch_Table_Ptr); + + -- The following type declaration is used by the compiler when the program + -- is compiled with restriction No_Dispatching_Calls. It is also used with + -- interface types to generate the tag and run-time information associated + -- with them. + + type No_Dispatch_Table_Wrapper is record + NDT_TSD : System.Address; + NDT_Prims_Ptr : Natural; + end record; + + DT_Predef_Prims_Size : constant SSE.Storage_Count := + SSE.Storage_Count + (1 * (Standard'Address_Size / + System.Storage_Unit)); + -- Size of the Predef_Prims field of the Dispatch_Table + + DT_Offset_To_Top_Size : constant SSE.Storage_Count := + SSE.Storage_Count + (1 * (Standard'Address_Size / + System.Storage_Unit)); + -- Size of the Offset_To_Top field of the Dispatch Table + + DT_Typeinfo_Ptr_Size : constant SSE.Storage_Count := + SSE.Storage_Count + (1 * (Standard'Address_Size / + System.Storage_Unit)); + -- Size of the Typeinfo_Ptr field of the Dispatch Table + + use type System.Storage_Elements.Storage_Offset; + + DT_Offset_To_Top_Offset : constant SSE.Storage_Count := + DT_Typeinfo_Ptr_Size + + DT_Offset_To_Top_Size; + + DT_Predef_Prims_Offset : constant SSE.Storage_Count := + DT_Typeinfo_Ptr_Size + + DT_Offset_To_Top_Size + + DT_Predef_Prims_Size; + -- Offset from Prims_Ptr to Predef_Prims component + + -- Object Specific Data record of secondary dispatch tables + + type Object_Specific_Data_Array is array (Positive range <>) of Positive; + + type Object_Specific_Data (OSD_Num_Prims : Positive) is record + OSD_Table : Object_Specific_Data_Array (1 .. OSD_Num_Prims); + -- Table used in secondary DT to reference their counterpart in the + -- select specific data (in the TSD of the primary DT). This construct + -- is used in the handling of dispatching triggers in select statements. + -- Nb_Prim is the number of non-predefined primitive operations. + end record; + + type Object_Specific_Data_Ptr is access all Object_Specific_Data; + pragma No_Strict_Aliasing (Object_Specific_Data_Ptr); + + -- The following subprogram specifications are placed here instead of + -- the package body to see them from the frontend through rtsfind. + + function Base_Address (This : System.Address) return System.Address; + -- Ada 2005 (AI-251): Displace "This" to point to the base address of + -- the object (that is, the address of the primary tag of the object). + + function Displace (This : System.Address; T : Tag) return System.Address; + -- Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch + -- table of T. + + function Secondary_Tag (T, Iface : Tag) return Tag; + -- Ada 2005 (AI-251): Given a primary tag T associated with a tagged type + -- Typ, search for the secondary tag of the interface type Iface covered + -- by Typ. + + function DT (T : Tag) return Dispatch_Table_Ptr; + -- Return the pointer to the TSD record associated with T + + function Get_Entry_Index (T : Tag; Position : Positive) return Positive; + -- Ada 2005 (AI-251): Return a primitive operation's entry index (if entry) + -- given a dispatch table T and a position of a primitive operation in T. + + function Get_Offset_Index + (T : Tag; + Position : Positive) return Positive; + -- Ada 2005 (AI-251): Given a pointer to a secondary dispatch table (T) and + -- a position of an operation in the DT, retrieve the corresponding + -- operation's position in the primary dispatch table from the Offset + -- Specific Data table of T. + + function Get_Prim_Op_Kind + (T : Tag; + Position : Positive) return Prim_Op_Kind; + -- Ada 2005 (AI-251): Return a primitive operation's kind given a dispatch + -- table T and a position of a primitive operation in T. + + function Get_RC_Offset (T : Tag) return SSE.Storage_Offset; + -- Return the Offset of the implicit record controller when the object + -- has controlled components, returns zero if no controlled components. + + pragma Export (Ada, Get_RC_Offset, "ada__tags__get_rc_offset"); + -- This procedure is used in s-finimp to compute the deep routines + -- it is exported manually in order to avoid changing completely the + -- organization of the run time. + + function Get_Tagged_Kind (T : Tag) return Tagged_Kind; + -- Ada 2005 (AI-345): Given a pointer to either a primary or a secondary + -- dispatch table, return the tagged kind of a type in the context of + -- concurrency and limitedness. + + function IW_Membership (This : System.Address; T : Tag) return Boolean; + -- Ada 2005 (AI-251): General routine that checks if a given object + -- implements a tagged type. Its common usage is to check if Obj is in + -- Iface'Class, but it is also used to check if a class-wide interface + -- implements a given type (Iface_CW_Typ in T'Class). For example: + -- + -- type I is interface; + -- type T is tagged ... + -- + -- function Test (O : I'Class) is + -- begin + -- return O in T'Class. + -- end Test; + + function Offset_To_Top + (This : System.Address) return SSE.Storage_Offset; + -- Ada 2005 (AI-251): Returns the current value of the offset_to_top + -- component available in the prologue of the dispatch table. If the parent + -- of the tagged type has discriminants this value is stored in a record + -- component just immediately after the tag component. + + function Parent_Size + (Obj : System.Address; + T : Tag) return SSE.Storage_Count; + -- Computes the size the ancestor part of a tagged extension object whose + -- address is 'obj' by calling indirectly the ancestor _size function. The + -- ancestor is the parent of the type represented by tag T. This function + -- assumes that _size is always in slot one of the dispatch table. + + pragma Export (Ada, Parent_Size, "ada__tags__parent_size"); + -- This procedure is used in s-finimp and is thus exported manually + + procedure Register_Interface_Offset + (This : System.Address; + Interface_T : Tag; + Is_Static : Boolean; + Offset_Value : SSE.Storage_Offset; + Offset_Func : Offset_To_Top_Function_Ptr); + -- Register in the table of interfaces of the tagged type associated with + -- "This" object the offset of the record component associated with the + -- progenitor Interface_T (that is, the distance from "This" to the object + -- component containing the tag of the secondary dispatch table). In case + -- of constant offset, Is_Static is true and Offset_Value has such value. + -- In case of variable offset, Is_Static is false and Offset_Func is an + -- access to function that must be called to evaluate the offset. + + procedure Register_Tag (T : Tag); + -- Insert the Tag and its associated external_tag in a table for the + -- sake of Internal_Tag + + procedure Set_Dynamic_Offset_To_Top + (This : System.Address; + Interface_T : Tag; + Offset_Value : SSE.Storage_Offset; + Offset_Func : Offset_To_Top_Function_Ptr); + -- Ada 2005 (AI-251): The compiler generates calls to this routine only + -- when initializing the Offset_To_Top field of dispatch tables associated + -- with tagged type whose parent has variable size components. "This" is + -- the object whose dispatch table is being initialized. Interface_T is the + -- interface for which the secondary dispatch table is being initialized, + -- and Offset_Value is the distance from "This" to the object component + -- containing the tag of the secondary dispatch table (a zero value means + -- that this interface shares the primary dispatch table). Offset_Func + -- references a function that must be called to evaluate the offset at + -- runtime. This routine also takes care of registering these values in + -- the table of interfaces of the type. + + procedure Set_Entry_Index (T : Tag; Position : Positive; Value : Positive); + -- Ada 2005 (AI-345): Set the entry index of a primitive operation in T's + -- TSD table indexed by Position. + + procedure Set_Prim_Op_Kind + (T : Tag; + Position : Positive; + Value : Prim_Op_Kind); + -- Ada 2005 (AI-251): Set the kind of a primitive operation in T's TSD + -- table indexed by Position. + + Max_Predef_Prims : constant Positive := 16; + -- Number of reserved slots for the following predefined ada primitives: + -- + -- 1. Size + -- 2. Alignment, + -- 3. Read + -- 4. Write + -- 5. Input + -- 6. Output + -- 7. "=" + -- 8. assignment + -- 9. deep adjust + -- 10. deep finalize + -- 11. async select + -- 12. conditional select + -- 13. prim_op kind + -- 14. task_id + -- 15. dispatching requeue + -- 16. timed select + -- + -- The compiler checks that the value here is correct + + subtype Predef_Prims_Table is Address_Array (1 .. Max_Predef_Prims); + type Predef_Prims_Table_Ptr is access Predef_Prims_Table; + pragma No_Strict_Aliasing (Predef_Prims_Table_Ptr); + + type Addr_Ptr is access System.Address; + pragma No_Strict_Aliasing (Addr_Ptr); + -- This type is used by the frontend to generate the code that handles + -- dispatch table slots of types declared at the local level. + +end Ada.Tags; diff --git a/gcc/ada/a-tasatt.adb b/gcc/ada/a-tasatt.adb new file mode 100644 index 000000000..cb9fbab6e --- /dev/null +++ b/gcc/ada/a-tasatt.adb @@ -0,0 +1,764 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T A S K _ A T T R I B U T E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2009, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- The following notes are provided in case someone decides the implementation +-- of this package is too complicated, or too slow. Please read this before +-- making any "simplifications". + +-- Correct implementation of this package is more difficult than one might +-- expect. After considering (and coding) several alternatives, we settled on +-- the present compromise. Things we do not like about this implementation +-- include: + +-- - It is vulnerable to bad Task_Id values, to the extent of possibly +-- trashing memory and crashing the runtime system. + +-- - It requires dynamic storage allocation for each new attribute value, +-- except for types that happen to be the same size as System.Address, or +-- shorter. + +-- - Instantiations at other than the library level rely on being able to +-- do down-level calls to a procedure declared in the generic package body. +-- This makes it potentially vulnerable to compiler changes. + +-- The main implementation issue here is that the connection from task to +-- attribute is a potential source of dangling references. + +-- When a task goes away, we want to be able to recover all the storage +-- associated with its attributes. The Ada mechanism for this is finalization, +-- via controlled attribute types. For this reason, the ARM requires +-- finalization of attribute values when the associated task terminates. + +-- This finalization must be triggered by the tasking runtime system, during +-- termination of the task. Given the active set of instantiations of +-- Ada.Task_Attributes is dynamic, the number and types of attributes +-- belonging to a task will not be known until the task actually terminates. +-- Some of these types may be controlled and some may not. The RTS must find +-- some way to determine which of these attributes need finalization, and +-- invoke the appropriate finalization on them. + +-- One way this might be done is to create a special finalization chain for +-- each task, similar to the finalization chain that is used for controlled +-- objects within the task. This would differ from the usual finalization +-- chain in that it would not have a LIFO structure, since attributes may be +-- added to a task at any time during its lifetime. This might be the right +-- way to go for the longer term, but at present this approach is not open, +-- since GNAT does not provide such special finalization support. + +-- Lacking special compiler support, the RTS is limited to the normal ways an +-- application invokes finalization, i.e. + +-- a) Explicit call to the procedure Finalize, if we know the type has this +-- operation defined on it. This is not sufficient, since we have no way +-- of determining whether a given generic formal Attribute type is +-- controlled, and no visibility of the associated Finalize procedure, in +-- the generic body. + +-- b) Leaving the scope of a local object of a controlled type. This does not +-- help, since the lifetime of an instantiation of Ada.Task_Attributes +-- does not correspond to the lifetimes of the various tasks which may +-- have that attribute. + +-- c) Assignment of another value to the object. This would not help, since +-- we then have to finalize the new value of the object. + +-- d) Unchecked deallocation of an object of a controlled type. This seems to +-- be the only mechanism available to the runtime system for finalization +-- of task attributes. + +-- We considered two ways of using unchecked deallocation, both based on a +-- linked list of that would hang from the task control block. + +-- In the first approach the objects on the attribute list are all derived +-- from one controlled type, say T, and are linked using an access type to +-- T'Class. The runtime system has an Ada.Unchecked_Deallocation for T'Class +-- with access type T'Class, and uses this to deallocate and finalize all the +-- items in the list. The limitation of this approach is that each +-- instantiation of the package Ada.Task_Attributes derives a new record +-- extension of T, and since T is controlled (RM 3.9.1 (3)), instantiation is +-- only allowed at the library level. + +-- In the second approach the objects on the attribute list are of unrelated +-- but structurally similar types. Unchecked conversion is used to circument +-- Ada type checking. Each attribute-storage node contains not only the +-- attribute value and a link for chaining, but also a pointer to descriptor +-- for the corresponding instantiation of Task_Attributes. The instantiation +-- descriptor contains pointer to a procedure that can do the correct +-- deallocation and finalization for that type of attribute. On task +-- termination, the runtime system uses the pointer to call the appropriate +-- deallocator. + +-- While this gets around the limitation that instantations be at the library +-- level, it relies on an implementation feature that may not always be safe, +-- i.e. that it is safe to call the Deallocate procedure for an instantiation +-- of Ada.Task_Attributes that no longer exists. In general, it seems this +-- might result in dangling references. + +-- Another problem with instantiations deeper than the library level is that +-- there is risk of storage leakage, or dangling references to reused storage. +-- That is, if an instantiation of Ada.Task_Attributes is made within a +-- procedure, what happens to the storage allocated for attributes, when the +-- procedure call returns? Apparently (RM 7.6.1 (4)) any such objects must be +-- finalized, since they will no longer be accessible, and in general one +-- would expect that the storage they occupy would be recovered for later +-- reuse. (If not, we would have a case of storage leakage.) Assuming the +-- storage is recovered and later reused, we have potentially dangerous +-- dangling references. When the procedure containing the instantiation of +-- Ada.Task_Attributes returns, there may still be unterminated tasks with +-- associated attribute values for that instantiation. When such tasks +-- eventually terminate, the RTS will attempt to call the Deallocate procedure +-- on them. If the corresponding storage has already been deallocated, when +-- the master of the access type was left, we have a potential disaster. This +-- disaster is compounded since the pointer to Deallocate is probably through +-- a "trampoline" which will also have been destroyed. + +-- For this reason, we arrange to remove all dangling references before +-- leaving the scope of an instantiation. This is ugly, since it requires +-- traversing the list of all tasks, but it is no more ugly than a similar +-- traversal that we must do at the point of instantiation in order to +-- initialize the attributes of all tasks. At least we only need to do these +-- traversals if the type is controlled. + +-- We chose to defer allocation of storage for attributes until the Reference +-- function is called or the attribute is first set to a value different from +-- the default initial one. This allows a potential savings in allocation, +-- for attributes that are not used by all tasks. + +-- For efficiency, we reserve space in the TCB for a fixed number of direct- +-- access attributes. These are required to be of a size that fits in the +-- space of an object of type System.Address. Because we must use unchecked +-- bitwise copy operations on these values, they cannot be of a controlled +-- type, but that is covered automatically since controlled objects are too +-- large to fit in the spaces. + +-- We originally deferred initialization of these direct-access attributes, +-- just as we do for the indirect-access attributes, and used a per-task bit +-- vector to keep track of which attributes were currently defined for that +-- task. We found that the overhead of maintaining this bit-vector seriously +-- slowed down access to the attributes, and made the fetch operation non- +-- atomic, so that even to read an attribute value required locking the TCB. +-- Therefore, we now initialize such attributes for all existing tasks at the +-- time of the attribute instantiation, and initialize existing attributes for +-- each new task at the time it is created. + +-- The latter initialization requires a list of all the instantiation +-- descriptors. Updates to this list, as well as the bit-vector that is used +-- to reserve slots for attributes in the TCB, require mutual exclusion. That +-- is provided by the Lock/Unlock_RTS. + +-- One special problem that added complexity to the design is that the per- +-- task list of indirect attributes contains objects of different types. We +-- use unchecked pointer conversion to link these nodes together and access +-- them, but the records may not have identical internal structure. Initially, +-- we thought it would be enough to allocate all the common components of +-- the records at the front of each record, so that their positions would +-- correspond. Unfortunately, GNAT adds "dope" information at the front +-- of a record, if the record contains any controlled-type components. +-- +-- This means that the offset of the fields we use to link the nodes is at +-- different positions on nodes of different types. To get around this, each +-- attribute storage record consists of a core node and wrapper. The core +-- nodes are all of the same type, and it is these that are linked together +-- and generally "seen" by the RTS. Each core node contains a pointer to its +-- own wrapper, which is a record that contains the core node along with an +-- attribute value, approximately as follows: + +-- type Node; +-- type Node_Access is access all Node; +-- type Wrapper; +-- type Access_Wrapper is access all Wrapper; +-- type Node is record +-- Next : Node_Access; +-- ... +-- Wrapper : Access_Wrapper; +-- end record; +-- type Wrapper is record +-- Dummy_Node : aliased Node; +-- Value : aliased Attribute; -- the generic formal type +-- end record; + +-- Another interesting problem is with the initialization of the instantiation +-- descriptors. Originally, we did this all via the Initialize procedure of +-- the descriptor type and code in the package body. It turned out that the +-- Initialize procedure needed quite a bit of information, including the size +-- of the attribute type, the initial value of the attribute (if it fits in +-- the TCB), and a pointer to the deallocator procedure. These needed to be +-- "passed" in via access discriminants. GNAT was having trouble with access +-- discriminants, so all this work was moved to the package body. + +-- Note that references to objects declared in this package body must in +-- general use 'Unchecked_Access instead of 'Access as the package can be +-- instantiated from within a local context. + +with System.Storage_Elements; +with System.Task_Primitives.Operations; +with System.Tasking; +with System.Tasking.Initialization; +with System.Tasking.Task_Attributes; + +with Ada.Exceptions; +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +pragma Elaborate_All (System.Tasking.Task_Attributes); +-- To ensure the initialization of object Local (below) will work + +package body Ada.Task_Attributes is + + use System.Tasking.Initialization, + System.Tasking, + System.Tasking.Task_Attributes, + Ada.Exceptions; + + package POP renames System.Task_Primitives.Operations; + + --------------------------- + -- Unchecked Conversions -- + --------------------------- + + -- The following type corresponds to Dummy_Wrapper, declared in + -- System.Tasking.Task_Attributes. + + type Wrapper; + type Access_Wrapper is access all Wrapper; + + pragma Warnings (Off); + -- We turn warnings off for the following To_Attribute_Handle conversions, + -- since these are used only for small attributes where we know that there + -- are no problems with alignment, but the compiler will generate warnings + -- for the occurrences in the large attribute case, even though they will + -- not actually be used. + + function To_Attribute_Handle is new Ada.Unchecked_Conversion + (System.Address, Attribute_Handle); + function To_Direct_Attribute_Element is new Ada.Unchecked_Conversion + (System.Address, Direct_Attribute_Element); + -- For reference to directly addressed task attributes + + type Access_Integer_Address is access all + System.Storage_Elements.Integer_Address; + + function To_Attribute_Handle is new Ada.Unchecked_Conversion + (Access_Integer_Address, Attribute_Handle); + -- For reference to directly addressed task attributes + + pragma Warnings (On); + -- End warnings off region for directly addressed attribute conversions + + function To_Access_Address is new Ada.Unchecked_Conversion + (Access_Node, Access_Address); + -- To store pointer to list of indirect attributes + + pragma Warnings (Off); + function To_Access_Wrapper is new Ada.Unchecked_Conversion + (Access_Dummy_Wrapper, Access_Wrapper); + pragma Warnings (On); + -- To fetch pointer to actual wrapper of attribute node. We turn off + -- warnings since this may generate an alignment warning. The warning can + -- be ignored since Dummy_Wrapper is only a non-generic standin for the + -- real wrapper type (we never actually allocate objects of type + -- Dummy_Wrapper). + + function To_Access_Dummy_Wrapper is new Ada.Unchecked_Conversion + (Access_Wrapper, Access_Dummy_Wrapper); + -- To store pointer to actual wrapper of attribute node + + function To_Task_Id is new Ada.Unchecked_Conversion + (Task_Identification.Task_Id, Task_Id); + -- To access TCB of identified task + + type Local_Deallocator is access procedure (P : in out Access_Node); + + function To_Lib_Level_Deallocator is new Ada.Unchecked_Conversion + (Local_Deallocator, Deallocator); + -- To defeat accessibility check + + ------------------------ + -- Storage Management -- + ------------------------ + + procedure Deallocate (P : in out Access_Node); + -- Passed to the RTS via unchecked conversion of a pointer to permit + -- finalization and deallocation of attribute storage nodes. + + -------------------------- + -- Instantiation Record -- + -------------------------- + + Local : aliased Instance; + -- Initialized in package body + + type Wrapper is record + Dummy_Node : aliased Node; + + Value : aliased Attribute := Initial_Value; + -- The generic formal type, may be controlled + end record; + + -- A number of unchecked conversions involving Wrapper_Access sources are + -- performed in this unit. We have to ensure that the designated object is + -- always strictly enough aligned. + + for Wrapper'Alignment use Standard'Maximum_Alignment; + + procedure Free is + new Ada.Unchecked_Deallocation (Wrapper, Access_Wrapper); + + procedure Deallocate (P : in out Access_Node) is + T : Access_Wrapper := To_Access_Wrapper (P.Wrapper); + begin + Free (T); + end Deallocate; + + --------------- + -- Reference -- + --------------- + + function Reference + (T : Task_Identification.Task_Id := Task_Identification.Current_Task) + return Attribute_Handle + is + TT : constant Task_Id := To_Task_Id (T); + Error_Message : constant String := "Trying to get the reference of a "; + + begin + if TT = null then + Raise_Exception (Program_Error'Identity, Error_Message & "null task"); + end if; + + if TT.Common.State = Terminated then + Raise_Exception (Tasking_Error'Identity, + Error_Message & "terminated task"); + end if; + + -- Directly addressed case + + if Local.Index /= 0 then + + -- Return the attribute handle. Warnings off because this return + -- statement generates alignment warnings for large attributes + -- (but will never be executed in this case anyway). + + pragma Warnings (Off); + return + To_Attribute_Handle (TT.Direct_Attributes (Local.Index)'Address); + pragma Warnings (On); + + -- Not directly addressed + + else + declare + P : Access_Node := To_Access_Node (TT.Indirect_Attributes); + W : Access_Wrapper; + Self_Id : constant Task_Id := POP.Self; + + begin + Defer_Abort (Self_Id); + POP.Lock_RTS; + + while P /= null loop + if P.Instance = Access_Instance'(Local'Unchecked_Access) then + POP.Unlock_RTS; + Undefer_Abort (Self_Id); + return To_Access_Wrapper (P.Wrapper).Value'Access; + end if; + + P := P.Next; + end loop; + + -- Unlock the RTS here to follow the lock ordering rule that + -- prevent us from using new (i.e the Global_Lock) while holding + -- any other lock. + + POP.Unlock_RTS; + W := new Wrapper' + ((null, Local'Unchecked_Access, null), Initial_Value); + POP.Lock_RTS; + + P := W.Dummy_Node'Unchecked_Access; + P.Wrapper := To_Access_Dummy_Wrapper (W); + P.Next := To_Access_Node (TT.Indirect_Attributes); + TT.Indirect_Attributes := To_Access_Address (P); + POP.Unlock_RTS; + Undefer_Abort (Self_Id); + return W.Value'Access; + + exception + when others => + POP.Unlock_RTS; + Undefer_Abort (Self_Id); + raise; + end; + end if; + + exception + when Tasking_Error | Program_Error => + raise; + + when others => + raise Program_Error; + end Reference; + + ------------------ + -- Reinitialize -- + ------------------ + + procedure Reinitialize + (T : Task_Identification.Task_Id := Task_Identification.Current_Task) + is + TT : constant Task_Id := To_Task_Id (T); + Error_Message : constant String := "Trying to Reinitialize a "; + + begin + if TT = null then + Raise_Exception (Program_Error'Identity, Error_Message & "null task"); + end if; + + if TT.Common.State = Terminated then + Raise_Exception (Tasking_Error'Identity, + Error_Message & "terminated task"); + end if; + + if Local.Index /= 0 then + Set_Value (Initial_Value, T); + else + declare + P, Q : Access_Node; + W : Access_Wrapper; + Self_Id : constant Task_Id := POP.Self; + + begin + Defer_Abort (Self_Id); + POP.Lock_RTS; + Q := To_Access_Node (TT.Indirect_Attributes); + + while Q /= null loop + if Q.Instance = Access_Instance'(Local'Unchecked_Access) then + if P = null then + TT.Indirect_Attributes := To_Access_Address (Q.Next); + else + P.Next := Q.Next; + end if; + + W := To_Access_Wrapper (Q.Wrapper); + Free (W); + POP.Unlock_RTS; + Undefer_Abort (Self_Id); + return; + end if; + + P := Q; + Q := Q.Next; + end loop; + + POP.Unlock_RTS; + Undefer_Abort (Self_Id); + + exception + when others => + POP.Unlock_RTS; + Undefer_Abort (Self_Id); + raise; + end; + end if; + + exception + when Tasking_Error | Program_Error => + raise; + + when others => + raise Program_Error; + end Reinitialize; + + --------------- + -- Set_Value -- + --------------- + + procedure Set_Value + (Val : Attribute; + T : Task_Identification.Task_Id := Task_Identification.Current_Task) + is + TT : constant Task_Id := To_Task_Id (T); + Error_Message : constant String := "Trying to Set the Value of a "; + + begin + if TT = null then + Raise_Exception (Program_Error'Identity, Error_Message & "null task"); + end if; + + if TT.Common.State = Terminated then + Raise_Exception (Tasking_Error'Identity, + Error_Message & "terminated task"); + end if; + + -- Directly addressed case + + if Local.Index /= 0 then + + -- Set attribute handle, warnings off, because this code can generate + -- alignment warnings with large attributes (but of course will not + -- be executed in this case, since we never have direct addressing in + -- such cases). + + pragma Warnings (Off); + To_Attribute_Handle + (TT.Direct_Attributes (Local.Index)'Address).all := Val; + pragma Warnings (On); + return; + end if; + + -- Not directly addressed + + declare + P : Access_Node := To_Access_Node (TT.Indirect_Attributes); + W : Access_Wrapper; + Self_Id : constant Task_Id := POP.Self; + + begin + Defer_Abort (Self_Id); + POP.Lock_RTS; + + while P /= null loop + + if P.Instance = Access_Instance'(Local'Unchecked_Access) then + To_Access_Wrapper (P.Wrapper).Value := Val; + POP.Unlock_RTS; + Undefer_Abort (Self_Id); + return; + end if; + + P := P.Next; + end loop; + + -- Unlock RTS here to follow the lock ordering rule that prevent us + -- from using new (i.e the Global_Lock) while holding any other lock. + + POP.Unlock_RTS; + W := new Wrapper'((null, Local'Unchecked_Access, null), Val); + POP.Lock_RTS; + P := W.Dummy_Node'Unchecked_Access; + P.Wrapper := To_Access_Dummy_Wrapper (W); + P.Next := To_Access_Node (TT.Indirect_Attributes); + TT.Indirect_Attributes := To_Access_Address (P); + + POP.Unlock_RTS; + Undefer_Abort (Self_Id); + + exception + when others => + POP.Unlock_RTS; + Undefer_Abort (Self_Id); + raise; + end; + + exception + when Tasking_Error | Program_Error => + raise; + + when others => + raise Program_Error; + end Set_Value; + + ----------- + -- Value -- + ----------- + + function Value + (T : Task_Identification.Task_Id := Task_Identification.Current_Task) + return Attribute + is + TT : constant Task_Id := To_Task_Id (T); + Error_Message : constant String := "Trying to get the Value of a "; + + begin + if TT = null then + Raise_Exception (Program_Error'Identity, Error_Message & "null task"); + end if; + + if TT.Common.State = Terminated then + Raise_Exception + (Program_Error'Identity, Error_Message & "terminated task"); + end if; + + -- Directly addressed case + + if Local.Index /= 0 then + + -- Get value of attribute. We turn Warnings off, because for large + -- attributes, this code can generate alignment warnings. But of + -- course large attributes are never directly addressed so in fact + -- we will never execute the code in this case. + + pragma Warnings (Off); + return To_Attribute_Handle + (TT.Direct_Attributes (Local.Index)'Address).all; + pragma Warnings (On); + end if; + + -- Not directly addressed + + declare + P : Access_Node; + Result : Attribute; + Self_Id : constant Task_Id := POP.Self; + + begin + Defer_Abort (Self_Id); + POP.Lock_RTS; + P := To_Access_Node (TT.Indirect_Attributes); + + while P /= null loop + if P.Instance = Access_Instance'(Local'Unchecked_Access) then + Result := To_Access_Wrapper (P.Wrapper).Value; + POP.Unlock_RTS; + Undefer_Abort (Self_Id); + return Result; + end if; + + P := P.Next; + end loop; + + POP.Unlock_RTS; + Undefer_Abort (Self_Id); + return Initial_Value; + + exception + when others => + POP.Unlock_RTS; + Undefer_Abort (Self_Id); + raise; + end; + + exception + when Tasking_Error | Program_Error => + raise; + + when others => + raise Program_Error; + end Value; + +-- Start of elaboration code for package Ada.Task_Attributes + +begin + -- This unchecked conversion can give warnings when alignments are + -- incorrect, but they will not be used in such cases anyway, so the + -- warnings can be safely ignored. + + pragma Warnings (Off); + Local.Deallocate := To_Lib_Level_Deallocator (Deallocate'Access); + pragma Warnings (On); + + declare + Two_To_J : Direct_Index_Vector; + Self_Id : constant Task_Id := POP.Self; + begin + Defer_Abort (Self_Id); + + -- Need protection for updating links to per-task initialization and + -- finalization routines, in case some task is being created or + -- terminated concurrently. + + POP.Lock_RTS; + + -- Add this instantiation to the list of all instantiations + + Local.Next := System.Tasking.Task_Attributes.All_Attributes; + System.Tasking.Task_Attributes.All_Attributes := + Local'Unchecked_Access; + + -- Try to find space for the attribute in the TCB + + Local.Index := 0; + Two_To_J := 1; + + if Attribute'Size <= System.Address'Size then + for J in Direct_Index_Range loop + if (Two_To_J and In_Use) = 0 then + + -- Reserve location J for this attribute + + In_Use := In_Use or Two_To_J; + Local.Index := J; + + -- This unchecked conversion can give a warning when the + -- alignment is incorrect, but it will not be used in such + -- a case anyway, so the warning can be safely ignored. + + pragma Warnings (Off); + To_Attribute_Handle (Local.Initial_Value'Access).all := + Initial_Value; + pragma Warnings (On); + + exit; + end if; + + Two_To_J := Two_To_J * 2; + end loop; + end if; + + -- Attribute goes directly in the TCB + + if Local.Index /= 0 then + -- Replace stub for initialization routine that is called at task + -- creation. + + Initialization.Initialize_Attributes_Link := + System.Tasking.Task_Attributes.Initialize_Attributes'Access; + + -- Initialize the attribute, for all tasks + + declare + C : System.Tasking.Task_Id := System.Tasking.All_Tasks_List; + begin + while C /= null loop + C.Direct_Attributes (Local.Index) := + To_Direct_Attribute_Element + (System.Storage_Elements.To_Address (Local.Initial_Value)); + C := C.Common.All_Tasks_Link; + end loop; + end; + + -- Attribute goes into a node onto a linked list + + else + -- Replace stub for finalization routine called at task termination + + Initialization.Finalize_Attributes_Link := + System.Tasking.Task_Attributes.Finalize_Attributes'Access; + end if; + + POP.Unlock_RTS; + Undefer_Abort (Self_Id); + end; +end Ada.Task_Attributes; diff --git a/gcc/ada/a-tasatt.ads b/gcc/ada/a-tasatt.ads new file mode 100644 index 000000000..ebcf253a4 --- /dev/null +++ b/gcc/ada/a-tasatt.ads @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T A S K _ A T T R I B U T 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Task_Identification; + +generic + type Attribute is private; + Initial_Value : Attribute; + +package Ada.Task_Attributes is + + type Attribute_Handle is access all Attribute; + + function Value + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) return Attribute; + + function Reference + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) return Attribute_Handle; + + procedure Set_Value + (Val : Attribute; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task); + + procedure Reinitialize + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task); + +private + pragma Inline (Value); + pragma Inline (Set_Value); + pragma Inline (Reinitialize); + +end Ada.Task_Attributes; diff --git a/gcc/ada/a-taside.adb b/gcc/ada/a-taside.adb new file mode 100644 index 000000000..4c7eb0a8c --- /dev/null +++ b/gcc/ada/a-taside.adb @@ -0,0 +1,194 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T A S K _ I D E N T I F I C A T I O 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Address_Image; +with System.Parameters; +with System.Soft_Links; +with System.Task_Primitives; +with System.Task_Primitives.Operations; +with Ada.Unchecked_Conversion; + +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.Tasking.Utilities; + +pragma Warnings (On); + +package body Ada.Task_Identification is + + use System.Parameters; + + package STPO renames System.Task_Primitives.Operations; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Convert_Ids (T : Task_Id) return System.Tasking.Task_Id; + function Convert_Ids (T : System.Tasking.Task_Id) return Task_Id; + pragma Inline (Convert_Ids); + -- Conversion functions between different forms of Task_Id + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Task_Id) return Boolean is + begin + return System.Tasking."=" (Convert_Ids (Left), Convert_Ids (Right)); + end "="; + + ----------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_Id) is + begin + if T = Null_Task_Id then + raise Program_Error; + else + System.Tasking.Utilities.Abort_Tasks + (System.Tasking.Task_List'(1 => Convert_Ids (T))); + end if; + end Abort_Task; + + ----------------- + -- Convert_Ids -- + ----------------- + + function Convert_Ids (T : Task_Id) return System.Tasking.Task_Id is + begin + return System.Tasking.Task_Id (T); + end Convert_Ids; + + function Convert_Ids (T : System.Tasking.Task_Id) return Task_Id is + begin + return Task_Id (T); + end Convert_Ids; + + ------------------ + -- Current_Task -- + ------------------ + + function Current_Task return Task_Id is + begin + return Convert_Ids (System.Task_Primitives.Operations.Self); + end Current_Task; + + ----------- + -- Image -- + ----------- + + function Image (T : Task_Id) return String is + function To_Address is new + Ada.Unchecked_Conversion + (Task_Id, System.Task_Primitives.Task_Address); + + begin + if T = Null_Task_Id then + return ""; + + elsif T.Common.Task_Image_Len = 0 then + return System.Address_Image (To_Address (T)); + + else + return T.Common.Task_Image (1 .. T.Common.Task_Image_Len) + & "_" & System.Address_Image (To_Address (T)); + end if; + end Image; + + ----------------- + -- Is_Callable -- + ----------------- + + function Is_Callable (T : Task_Id) return Boolean is + Result : Boolean; + Id : constant System.Tasking.Task_Id := Convert_Ids (T); + begin + if T = Null_Task_Id then + raise Program_Error; + else + System.Soft_Links.Abort_Defer.all; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Id); + Result := Id.Callable; + STPO.Unlock (Id); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + System.Soft_Links.Abort_Undefer.all; + return Result; + end if; + end Is_Callable; + + ------------------- + -- Is_Terminated -- + ------------------- + + function Is_Terminated (T : Task_Id) return Boolean is + Result : Boolean; + Id : constant System.Tasking.Task_Id := Convert_Ids (T); + + use System.Tasking; + + begin + if T = Null_Task_Id then + raise Program_Error; + else + System.Soft_Links.Abort_Defer.all; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Id); + Result := Id.Common.State = Terminated; + STPO.Unlock (Id); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + System.Soft_Links.Abort_Undefer.all; + return Result; + end if; + end Is_Terminated; + +end Ada.Task_Identification; diff --git a/gcc/ada/a-taside.ads b/gcc/ada/a-taside.ads new file mode 100644 index 000000000..7466f964d --- /dev/null +++ b/gcc/ada/a-taside.ads @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T A S K _ I D E N T I F I C A T I O N -- +-- -- +-- 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 System; +with System.Tasking; + +package Ada.Task_Identification is + pragma Preelaborate_05; + -- In accordance with Ada 2005 AI-362 + + type Task_Id is private; + pragma Preelaborable_Initialization (Task_Id); + + Null_Task_Id : constant Task_Id; + + function "=" (Left, Right : Task_Id) return Boolean; + pragma Inline ("="); + + function Image (T : Task_Id) return String; + + function Current_Task return Task_Id; + pragma Inline (Current_Task); + + procedure Abort_Task (T : Task_Id); + pragma Inline (Abort_Task); + -- Note: parameter is mode IN, not IN OUT, per AI-00101 + + function Is_Terminated (T : Task_Id) return Boolean; + pragma Inline (Is_Terminated); + + function Is_Callable (T : Task_Id) return Boolean; + pragma Inline (Is_Callable); + +private + + type Task_Id is new System.Tasking.Task_Id; + + Null_Task_Id : constant Task_Id := null; + +end Ada.Task_Identification; diff --git a/gcc/ada/a-taster.adb b/gcc/ada/a-taster.adb new file mode 100644 index 000000000..c4b4aaa81 --- /dev/null +++ b/gcc/ada/a-taster.adb @@ -0,0 +1,191 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T A S K _ T E R M I N A T I O N -- +-- -- +-- 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 System.Tasking; +with System.Task_Primitives.Operations; +with System.Parameters; +with System.Soft_Links; + +with Ada.Unchecked_Conversion; + +package body Ada.Task_Termination is + + use type Ada.Task_Identification.Task_Id; + + package STPO renames System.Task_Primitives.Operations; + package SSL renames System.Soft_Links; + + use System.Parameters; + + ----------------------- + -- Local subprograms -- + ----------------------- + + function To_TT is new Ada.Unchecked_Conversion + (System.Tasking.Termination_Handler, Termination_Handler); + + function To_ST is new Ada.Unchecked_Conversion + (Termination_Handler, System.Tasking.Termination_Handler); + + function To_Task_Id is new Ada.Unchecked_Conversion + (Ada.Task_Identification.Task_Id, System.Tasking.Task_Id); + + ----------------------------------- + -- Current_Task_Fallback_Handler -- + ----------------------------------- + + function Current_Task_Fallback_Handler return Termination_Handler is + begin + -- There is no need for explicit protection against race conditions + -- for this function because this function can only be executed by + -- Self, and the Fall_Back_Handler can only be modified by Self. + + return To_TT (STPO.Self.Common.Fall_Back_Handler); + end Current_Task_Fallback_Handler; + + ------------------------------------- + -- Set_Dependents_Fallback_Handler -- + ------------------------------------- + + procedure Set_Dependents_Fallback_Handler + (Handler : Termination_Handler) + is + Self : constant System.Tasking.Task_Id := STPO.Self; + + begin + SSL.Abort_Defer.all; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Self); + + Self.Common.Fall_Back_Handler := To_ST (Handler); + + STPO.Unlock (Self); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + SSL.Abort_Undefer.all; + end Set_Dependents_Fallback_Handler; + + -------------------------- + -- Set_Specific_Handler -- + -------------------------- + + procedure Set_Specific_Handler + (T : Ada.Task_Identification.Task_Id; + Handler : Termination_Handler) + is + begin + -- Tasking_Error is raised if the task identified by T has already + -- terminated. Program_Error is raised if the value of T is + -- Null_Task_Id. + + if T = Ada.Task_Identification.Null_Task_Id then + raise Program_Error; + elsif Ada.Task_Identification.Is_Terminated (T) then + raise Tasking_Error; + else + declare + Target : constant System.Tasking.Task_Id := To_Task_Id (T); + + begin + SSL.Abort_Defer.all; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Target); + + Target.Common.Specific_Handler := To_ST (Handler); + + STPO.Unlock (Target); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + SSL.Abort_Undefer.all; + end; + end if; + end Set_Specific_Handler; + + ---------------------- + -- Specific_Handler -- + ---------------------- + + function Specific_Handler + (T : Ada.Task_Identification.Task_Id) return Termination_Handler + is + begin + -- Tasking_Error is raised if the task identified by T has already + -- terminated. Program_Error is raised if the value of T is + -- Null_Task_Id. + + if T = Ada.Task_Identification.Null_Task_Id then + raise Program_Error; + elsif Ada.Task_Identification.Is_Terminated (T) then + raise Tasking_Error; + else + declare + Target : constant System.Tasking.Task_Id := To_Task_Id (T); + TH : Termination_Handler; + + begin + SSL.Abort_Defer.all; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Target); + + TH := To_TT (Target.Common.Specific_Handler); + + STPO.Unlock (Target); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + SSL.Abort_Undefer.all; + + return TH; + end; + end if; + end Specific_Handler; + +end Ada.Task_Termination; diff --git a/gcc/ada/a-taster.ads b/gcc/ada/a-taster.ads new file mode 100644 index 000000000..5a496a83e --- /dev/null +++ b/gcc/ada/a-taster.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T A S K _ T E R M I N A T I O N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2005, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Task_Identification; +with Ada.Exceptions; + +package Ada.Task_Termination is + pragma Preelaborate (Task_Termination); + + type Cause_Of_Termination is (Normal, Abnormal, Unhandled_Exception); + + type Termination_Handler is access protected procedure + (Cause : Cause_Of_Termination; + T : Ada.Task_Identification.Task_Id; + X : Ada.Exceptions.Exception_Occurrence); + + procedure Set_Dependents_Fallback_Handler + (Handler : Termination_Handler); + function Current_Task_Fallback_Handler return Termination_Handler; + + procedure Set_Specific_Handler + (T : Ada.Task_Identification.Task_Id; + Handler : Termination_Handler); + function Specific_Handler + (T : Ada.Task_Identification.Task_Id) return Termination_Handler; + +end Ada.Task_Termination; diff --git a/gcc/ada/a-teioed.adb b/gcc/ada/a-teioed.adb new file mode 100644 index 000000000..cfe64c3b6 --- /dev/null +++ b/gcc/ada/a-teioed.adb @@ -0,0 +1,2910 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 + -- indicies--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 new file mode 100644 index 000000000..bc2842abd --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Text_IO.Editing is + + type Picture is private; + + function Valid + (Pic_String : String; + Blank_When_Zero : Boolean := False) return Boolean; + + function To_Picture + (Pic_String : String; + Blank_When_Zero : Boolean := False) return Picture; + + function Pic_String (Pic : Picture) return String; + function Blank_When_Zero (Pic : Picture) return Boolean; + + Max_Picture_Length : constant := 64; + + Picture_Error : exception; + + Default_Currency : constant String := "$"; + Default_Fill : constant Character := '*'; + Default_Separator : constant Character := ','; + Default_Radix_Mark : constant Character := '.'; + + generic + type Num is delta <> digits <>; + Default_Currency : String := Editing.Default_Currency; + Default_Fill : Character := Editing.Default_Fill; + Default_Separator : Character := Editing.Default_Separator; + Default_Radix_Mark : Character := Editing.Default_Radix_Mark; + + package Decimal_Output is + + function Length + (Pic : Picture; + Currency : String := Default_Currency) return Natural; + + function Valid + (Item : Num; + Pic : Picture; + Currency : String := Default_Currency) return Boolean; + + function Image + (Item : Num; + Pic : Picture; + Currency : String := Default_Currency; + Fill : Character := Default_Fill; + Separator : Character := Default_Separator; + Radix_Mark : Character := Default_Radix_Mark) return String; + + procedure Put + (File : Ada.Text_IO.File_Type; + Item : Num; + Pic : Picture; + Currency : String := Default_Currency; + Fill : Character := Default_Fill; + Separator : Character := Default_Separator; + Radix_Mark : Character := Default_Radix_Mark); + + procedure Put + (Item : Num; + Pic : Picture; + Currency : String := Default_Currency; + Fill : Character := Default_Fill; + Separator : Character := Default_Separator; + Radix_Mark : Character := Default_Radix_Mark); + + procedure Put + (To : out String; + Item : Num; + Pic : Picture; + Currency : String := Default_Currency; + Fill : Character := Default_Fill; + Separator : Character := Default_Separator; + Radix_Mark : Character := Default_Radix_Mark); + + end Decimal_Output; + +private + + MAX_PICSIZE : constant := 50; + MAX_MONEYSIZE : constant := 10; + Invalid_Position : constant := -1; + + subtype Pic_Index is Natural range 0 .. MAX_PICSIZE; + + type Picture_Record (Length : Pic_Index := 0) is record + Expanded : String (1 .. Length); + end record; + + type Format_Record is record + Picture : Picture_Record; + -- Read only + + Blank_When_Zero : Boolean; + -- Read/write + + Original_BWZ : Boolean; + + -- The following components get written + + Star_Fill : Boolean := False; + + Radix_Position : Integer := Invalid_Position; + + Sign_Position, + Second_Sign : Integer := Invalid_Position; + + Start_Float, + End_Float : Integer := Invalid_Position; + + Start_Currency, + End_Currency : Integer := Invalid_Position; + + Max_Leading_Digits : Integer := 0; + + Max_Trailing_Digits : Integer := 0; + + Max_Currency_Digits : Integer := 0; + + Floater : Character := '!'; + -- Initialized to illegal value + + end record; + + type Picture is record + Contents : Format_Record; + end record; + + type Number_Attributes is record + Negative : Boolean := False; + + Has_Fraction : Boolean := False; + + Start_Of_Int, + End_Of_Int, + Start_Of_Fraction, + End_Of_Fraction : Integer := Invalid_Position; -- invalid value + end record; + + function Parse_Number_String (Str : String) return Number_Attributes; + -- Assumed format is 'IMAGE or Fixed_IO.Put format (depends on no + -- trailing blanks...) + + procedure Precalculate (Pic : in out Format_Record); + -- Precalculates fields from the user supplied data + + function Format_Number + (Pic : Format_Record; + Number : String; + Currency_Symbol : String; + Fill_Character : Character; + Separator_Character : Character; + Radix_Point : Character) return String; + -- Formats number according to Pic + + function Expand (Picture : String) return String; + +end Ada.Text_IO.Editing; diff --git a/gcc/ada/a-textio.adb b/gcc/ada/a-textio.adb new file mode 100644 index 000000000..721deca03 --- /dev/null +++ b/gcc/ada/a-textio.adb @@ -0,0 +1,2205 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O -- +-- -- +-- 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.Streams; use Ada.Streams; +with Interfaces.C_Streams; use Interfaces.C_Streams; + +with System.File_IO; +with System.CRTL; +with System.WCh_Cnv; use System.WCh_Cnv; +with System.WCh_Con; use System.WCh_Con; + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +pragma Elaborate_All (System.File_IO); +-- Needed because of calls to Chain_File in package body elaboration + +package body Ada.Text_IO is + + package FIO renames System.File_IO; + + subtype AP is FCB.AFCB_Ptr; + + function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); + function To_TIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode); + use type FCB.File_Mode; + + use type System.CRTL.size_t; + + WC_Encoding : Character; + pragma Import (C, WC_Encoding, "__gl_wc_encoding"); + -- Default wide character encoding + + Err_Name : aliased String := "*stderr" & ASCII.NUL; + In_Name : aliased String := "*stdin" & ASCII.NUL; + Out_Name : aliased String := "*stdout" & ASCII.NUL; + -- Names of standard files + -- + -- Use "preallocated" strings to avoid calling "new" during the elaboration + -- of the run time. This is needed in the tasking case to avoid calling + -- Task_Lock too early. A filename is expected to end with a null character + -- in the runtime, here the null characters are added just to have a + -- correct filename length. + -- + -- Note: the names for these files are bogus, and probably it would be + -- better for these files to have no names, but the ACVC tests insist! + -- We use names that are bound to fail in open etc. + + Null_Str : aliased constant String := ""; + -- Used as form string for standard files + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Get_Upper_Half_Char + (C : Character; + File : File_Type) return Character; + -- This function is shared by Get and Get_Immediate to extract an encoded + -- upper half character value from the given File. The first byte has + -- already been read and is passed in C. The character value is returned as + -- the result, and the file pointer is bumped past the character. + -- Constraint_Error is raised if the encoded value is outside the bounds of + -- type Character. + + function Get_Upper_Half_Char_Immed + (C : Character; + File : File_Type) return Character; + -- This routine is identical to Get_Upper_Half_Char, except that the reads + -- are done in Get_Immediate mode (i.e. without waiting for a line return). + + function Getc (File : File_Type) return int; + -- Gets next character from file, which has already been checked for being + -- in read status, and returns the character read if no error occurs. The + -- result is EOF if the end of file was read. + + function Getc_Immed (File : File_Type) return int; + -- This routine is identical to Getc, except that the read is done in + -- Get_Immediate mode (i.e. without waiting for a line return). + + function Has_Upper_Half_Character (Item : String) return Boolean; + -- Returns True if any of the characters is in the range 16#80#-16#FF# + + function Nextc (File : File_Type) return int; + -- Returns next character from file without skipping past it (i.e. it is a + -- combination of Getc followed by an Ungetc). + + procedure Put_Encoded (File : File_Type; Char : Character); + -- Called to output a character Char to the given File, when the encoding + -- method for the file is other than brackets, and Char is upper half. + + procedure Putc (ch : int; File : File_Type); + -- Outputs the given character to the file, which has already been checked + -- for being in output status. Device_Error is raised if the character + -- cannot be written. + + procedure Set_WCEM (File : in out File_Type); + -- Called by Open and Create to set the wide character encoding method for + -- the file, processing a WCEM form parameter if one is present. File is + -- IN OUT because it may be closed in case of an error. + + procedure Terminate_Line (File : File_Type); + -- If the file is in Write_File or Append_File mode, and the current line + -- is not terminated, then a line terminator is written using New_Line. + -- Note that there is no Terminate_Page routine, because the page mark at + -- the end of the file is implied if necessary. + + procedure Ungetc (ch : int; File : File_Type); + -- Pushes back character into stream, using ungetc. The caller has checked + -- that the file is in read status. Device_Error is raised if the character + -- cannot be pushed back. An attempt to push back and end of file character + -- (EOF) is ignored. + + ------------------- + -- AFCB_Allocate -- + ------------------- + + function AFCB_Allocate (Control_Block : Text_AFCB) return FCB.AFCB_Ptr is + pragma Unreferenced (Control_Block); + begin + return new Text_AFCB; + end AFCB_Allocate; + + ---------------- + -- AFCB_Close -- + ---------------- + + procedure AFCB_Close (File : not null access Text_AFCB) is + begin + -- If the file being closed is one of the current files, then close + -- the corresponding current file. It is not clear that this action + -- is required (RM A.10.3(23)) but it seems reasonable, and besides + -- ACVC test CE3208A expects this behavior. + + if File_Type (File) = Current_In then + Current_In := null; + elsif File_Type (File) = Current_Out then + Current_Out := null; + elsif File_Type (File) = Current_Err then + Current_Err := null; + end if; + + Terminate_Line (File_Type (File)); + end AFCB_Close; + + --------------- + -- AFCB_Free -- + --------------- + + procedure AFCB_Free (File : not null access Text_AFCB) is + type FCB_Ptr is access all Text_AFCB; + FT : FCB_Ptr := FCB_Ptr (File); + + procedure Free is new Ada.Unchecked_Deallocation (Text_AFCB, FCB_Ptr); + + begin + Free (FT); + end AFCB_Free; + + ----------- + -- Close -- + ----------- + + procedure Close (File : in out File_Type) is + begin + FIO.Close (AP (File)'Unrestricted_Access); + end Close; + + --------- + -- Col -- + --------- + + -- Note: we assume that it is impossible in practice for the column + -- to exceed the value of Count'Last, i.e. no check is required for + -- overflow raising layout error. + + function Col (File : File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return File.Col; + end Col; + + function Col return Positive_Count is + begin + return Col (Current_Out); + end Col; + + ------------ + -- Create -- + ------------ + + procedure Create + (File : in out File_Type; + Mode : File_Mode := Out_File; + Name : String := ""; + Form : String := "") + is + Dummy_File_Control_Block : Text_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'T', + Creat => True, + Text => True); + + File.Self := File; + Set_WCEM (File); + end Create; + + ------------------- + -- Current_Error -- + ------------------- + + function Current_Error return File_Type is + begin + return Current_Err; + end Current_Error; + + function Current_Error return File_Access is + begin + return Current_Err.Self'Access; + end Current_Error; + + ------------------- + -- Current_Input -- + ------------------- + + function Current_Input return File_Type is + begin + return Current_In; + end Current_Input; + + function Current_Input return File_Access is + begin + return Current_In.Self'Access; + end Current_Input; + + -------------------- + -- Current_Output -- + -------------------- + + function Current_Output return File_Type is + begin + return Current_Out; + end Current_Output; + + function Current_Output return File_Access is + begin + return Current_Out.Self'Access; + end Current_Output; + + ------------ + -- Delete -- + ------------ + + procedure Delete (File : in out File_Type) is + begin + FIO.Delete (AP (File)'Unrestricted_Access); + end Delete; + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File (File : File_Type) return Boolean is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Upper_Half_Character then + return False; + + elsif File.Before_LM then + if File.Before_LM_PM then + return Nextc (File) = EOF; + end if; + + else + ch := Getc (File); + + if ch = EOF then + return True; + + elsif ch /= LM then + Ungetc (ch, File); + return False; + + else -- ch = LM + File.Before_LM := True; + end if; + end if; + + -- Here we are just past the line mark with Before_LM set so that we + -- do not have to try to back up past the LM, thus avoiding the need + -- to back up more than one character. + + ch := Getc (File); + + if ch = EOF then + return True; + + elsif ch = PM and then File.Is_Regular_File then + File.Before_LM_PM := True; + return Nextc (File) = EOF; + + -- Here if neither EOF nor PM followed end of line + + else + Ungetc (ch, File); + return False; + end if; + + end End_Of_File; + + function End_Of_File return Boolean is + begin + return End_Of_File (Current_In); + end End_Of_File; + + ----------------- + -- End_Of_Line -- + ----------------- + + function End_Of_Line (File : File_Type) return Boolean is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Upper_Half_Character then + return False; + + elsif File.Before_LM then + return True; + + else + ch := Getc (File); + + if ch = EOF then + return True; + + else + Ungetc (ch, File); + return (ch = LM); + end if; + end if; + end End_Of_Line; + + function End_Of_Line return Boolean is + begin + return End_Of_Line (Current_In); + end End_Of_Line; + + ----------------- + -- End_Of_Page -- + ----------------- + + function End_Of_Page (File : File_Type) return Boolean is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if not File.Is_Regular_File then + return False; + + elsif File.Before_Upper_Half_Character then + return False; + + elsif File.Before_LM then + if File.Before_LM_PM then + return True; + end if; + + else + ch := Getc (File); + + if ch = EOF then + return True; + + elsif ch /= LM then + Ungetc (ch, File); + return False; + + else -- ch = LM + File.Before_LM := True; + end if; + end if; + + -- Here we are just past the line mark with Before_LM set so that we + -- do not have to try to back up past the LM, thus avoiding the need + -- to back up more than one character. + + ch := Nextc (File); + + return ch = PM or else ch = EOF; + end End_Of_Page; + + function End_Of_Page return Boolean is + begin + return End_Of_Page (Current_In); + end End_Of_Page; + + -------------- + -- EOF_Char -- + -------------- + + function EOF_Char return Integer is + begin + return EOF; + end EOF_Char; + + ----------- + -- Flush -- + ----------- + + procedure Flush (File : File_Type) is + begin + FIO.Flush (AP (File)); + end Flush; + + procedure Flush is + begin + Flush (Current_Out); + end Flush; + + ---------- + -- Form -- + ---------- + + function Form (File : File_Type) return String is + begin + return FIO.Form (AP (File)); + end Form; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Character) + is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Upper_Half_Character then + File.Before_Upper_Half_Character := False; + Item := File.Saved_Upper_Half_Character; + + elsif File.Before_LM then + File.Before_LM := False; + File.Col := 1; + + if File.Before_LM_PM then + File.Line := 1; + File.Page := File.Page + 1; + File.Before_LM_PM := False; + else + File.Line := File.Line + 1; + end if; + end if; + + loop + ch := Getc (File); + + if ch = EOF then + raise End_Error; + + elsif ch = LM then + File.Line := File.Line + 1; + File.Col := 1; + + elsif ch = PM and then File.Is_Regular_File then + File.Page := File.Page + 1; + File.Line := 1; + + else + Item := Character'Val (ch); + File.Col := File.Col + 1; + return; + end if; + end loop; + end Get; + + procedure Get (Item : out Character) is + begin + Get (Current_In, Item); + end Get; + + procedure Get + (File : File_Type; + Item : out String) + is + ch : int; + J : Natural; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + File.Col := 1; + + if File.Before_LM_PM then + File.Line := 1; + File.Page := File.Page + 1; + File.Before_LM_PM := False; + + else + File.Line := File.Line + 1; + end if; + end if; + + J := Item'First; + while J <= Item'Last loop + ch := Getc (File); + + if ch = EOF then + raise End_Error; + + elsif ch = LM then + File.Line := File.Line + 1; + File.Col := 1; + + elsif ch = PM and then File.Is_Regular_File then + File.Page := File.Page + 1; + File.Line := 1; + + else + Item (J) := Character'Val (ch); + J := J + 1; + File.Col := File.Col + 1; + end if; + end loop; + end Get; + + procedure Get (Item : out String) is + begin + Get (Current_In, Item); + end Get; + + ------------------- + -- Get_Immediate -- + ------------------- + + procedure Get_Immediate + (File : File_Type; + Item : out Character) + is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Upper_Half_Character then + File.Before_Upper_Half_Character := False; + Item := File.Saved_Upper_Half_Character; + + elsif File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + Item := Character'Val (LM); + + else + ch := Getc_Immed (File); + + if ch = EOF then + raise End_Error; + else + Item := + (if not Is_Start_Of_Encoding (Character'Val (ch), File.WC_Method) + then Character'Val (ch) + else Get_Upper_Half_Char_Immed (Character'Val (ch), File)); + end if; + end if; + end Get_Immediate; + + procedure Get_Immediate + (Item : out Character) + is + begin + Get_Immediate (Current_In, Item); + end Get_Immediate; + + procedure Get_Immediate + (File : File_Type; + Item : out Character; + Available : out Boolean) + is + ch : int; + end_of_file : int; + avail : int; + + procedure getc_immediate_nowait + (stream : FILEs; + ch : out int; + end_of_file : out int; + avail : out int); + pragma Import (C, getc_immediate_nowait, "getc_immediate_nowait"); + + begin + FIO.Check_Read_Status (AP (File)); + Available := True; + + if File.Before_Upper_Half_Character then + File.Before_Upper_Half_Character := False; + Item := File.Saved_Upper_Half_Character; + + elsif File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + Item := Character'Val (LM); + + else + getc_immediate_nowait (File.Stream, ch, end_of_file, avail); + + if ferror (File.Stream) /= 0 then + raise Device_Error; + + elsif end_of_file /= 0 then + raise End_Error; + + elsif avail = 0 then + Available := False; + Item := ASCII.NUL; + + else + Available := True; + + Item := + (if Is_Start_Of_Encoding (Character'Val (ch), File.WC_Method) + then Character'Val (ch) + else Get_Upper_Half_Char_Immed (Character'Val (ch), File)); + end if; + end if; + + end Get_Immediate; + + procedure Get_Immediate + (Item : out Character; + Available : out Boolean) + is + begin + Get_Immediate (Current_In, Item, Available); + end Get_Immediate; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line + (File : File_Type; + Item : out String; + Last : out Natural) is separate; + -- The implementation of Ada.Text_IO.Get_Line is split into a subunit so + -- that different implementations can be used on different systems. In + -- particular the standard implementation uses low level stuff that is + -- not appropriate for the JVM and .NET implementations. + + procedure Get_Line + (Item : out String; + Last : out Natural) + is + begin + Get_Line (Current_In, Item, Last); + end Get_Line; + + function Get_Line (File : File_Type) return String is + Buffer : String (1 .. 500); + Last : Natural; + + function Get_Rest (S : String) return String; + -- This is a recursive function that reads the rest of the line and + -- returns it. S is the part read so far. + + -------------- + -- Get_Rest -- + -------------- + + function Get_Rest (S : String) return String is + + -- Each time we allocate a buffer the same size as what we have + -- read so far. This limits us to a logarithmic number of calls + -- to Get_Rest and also ensures only a linear use of stack space. + + Buffer : String (1 .. S'Length); + Last : Natural; + + begin + Get_Line (File, Buffer, Last); + + declare + R : constant String := S & Buffer (1 .. Last); + begin + if Last < Buffer'Last then + return R; + else + return Get_Rest (R); + end if; + end; + end Get_Rest; + + -- Start of processing for Get_Line + + begin + Get_Line (File, Buffer, Last); + + if Last < Buffer'Last then + return Buffer (1 .. Last); + else + return Get_Rest (Buffer (1 .. Last)); + end if; + end Get_Line; + + function Get_Line return String is + begin + return Get_Line (Current_In); + end Get_Line; + + ------------------------- + -- Get_Upper_Half_Char -- + ------------------------- + + function Get_Upper_Half_Char + (C : Character; + File : File_Type) return Character + is + Result : Wide_Character; + + function In_Char return Character; + -- Function used to obtain additional characters it the wide character + -- sequence is more than one character long. + + function WC_In is new Char_Sequence_To_Wide_Char (In_Char); + + ------------- + -- In_Char -- + ------------- + + function In_Char return Character is + ch : constant Integer := Getc (File); + begin + if ch = EOF then + raise End_Error; + else + return Character'Val (ch); + end if; + end In_Char; + + -- Start of processing for Get_Upper_Half_Char + + begin + Result := WC_In (C, File.WC_Method); + + if Wide_Character'Pos (Result) > 16#FF# then + raise Constraint_Error with + "invalid wide character in Text_'I'O input"; + else + return Character'Val (Wide_Character'Pos (Result)); + end if; + end Get_Upper_Half_Char; + + ------------------------------- + -- Get_Upper_Half_Char_Immed -- + ------------------------------- + + function Get_Upper_Half_Char_Immed + (C : Character; + File : File_Type) return Character + is + Result : Wide_Character; + + function In_Char return Character; + -- Function used to obtain additional characters it the wide character + -- sequence is more than one character long. + + function WC_In is new Char_Sequence_To_Wide_Char (In_Char); + + ------------- + -- In_Char -- + ------------- + + function In_Char return Character is + ch : constant Integer := Getc_Immed (File); + begin + if ch = EOF then + raise End_Error; + else + return Character'Val (ch); + end if; + end In_Char; + + -- Start of processing for Get_Upper_Half_Char_Immed + + begin + Result := WC_In (C, File.WC_Method); + + if Wide_Character'Pos (Result) > 16#FF# then + raise Constraint_Error with + "invalid wide character in Text_'I'O input"; + else + return Character'Val (Wide_Character'Pos (Result)); + end if; + end Get_Upper_Half_Char_Immed; + + ---------- + -- Getc -- + ---------- + + function Getc (File : File_Type) return int is + ch : int; + + begin + ch := fgetc (File.Stream); + + if ch = EOF and then ferror (File.Stream) /= 0 then + raise Device_Error; + else + return ch; + end if; + end Getc; + + ---------------- + -- Getc_Immed -- + ---------------- + + function Getc_Immed (File : File_Type) return int is + ch : int; + end_of_file : int; + + procedure getc_immediate + (stream : FILEs; ch : out int; end_of_file : out int); + pragma Import (C, getc_immediate, "getc_immediate"); + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + ch := LM; + + else + getc_immediate (File.Stream, ch, end_of_file); + + if ferror (File.Stream) /= 0 then + raise Device_Error; + elsif end_of_file /= 0 then + return EOF; + end if; + end if; + + return ch; + end Getc_Immed; + + ------------------------------ + -- Has_Upper_Half_Character -- + ------------------------------ + + function Has_Upper_Half_Character (Item : String) return Boolean is + begin + for J in Item'Range loop + if Character'Pos (Item (J)) >= 16#80# then + return True; + end if; + end loop; + + return False; + end Has_Upper_Half_Character; + + ------------------------------- + -- Initialize_Standard_Files -- + ------------------------------- + + procedure Initialize_Standard_Files is + begin + Standard_Err.Stream := stderr; + Standard_Err.Name := Err_Name'Access; + Standard_Err.Form := Null_Str'Unrestricted_Access; + Standard_Err.Mode := FCB.Out_File; + Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0; + Standard_Err.Is_Temporary_File := False; + Standard_Err.Is_System_File := True; + Standard_Err.Is_Text_File := True; + Standard_Err.Access_Method := 'T'; + Standard_Err.Self := Standard_Err; + Standard_Err.WC_Method := Default_WCEM; + + Standard_In.Stream := stdin; + Standard_In.Name := In_Name'Access; + Standard_In.Form := Null_Str'Unrestricted_Access; + Standard_In.Mode := FCB.In_File; + Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; + Standard_In.Is_Temporary_File := False; + Standard_In.Is_System_File := True; + Standard_In.Is_Text_File := True; + Standard_In.Access_Method := 'T'; + Standard_In.Self := Standard_In; + Standard_In.WC_Method := Default_WCEM; + + Standard_Out.Stream := stdout; + Standard_Out.Name := Out_Name'Access; + Standard_Out.Form := Null_Str'Unrestricted_Access; + Standard_Out.Mode := FCB.Out_File; + Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; + Standard_Out.Is_Temporary_File := False; + Standard_Out.Is_System_File := True; + Standard_Out.Is_Text_File := True; + Standard_Out.Access_Method := 'T'; + Standard_Out.Self := Standard_Out; + Standard_Out.WC_Method := Default_WCEM; + + FIO.Make_Unbuffered (AP (Standard_Out)); + FIO.Make_Unbuffered (AP (Standard_Err)); + end Initialize_Standard_Files; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (File : File_Type) return Boolean is + begin + return FIO.Is_Open (AP (File)); + end Is_Open; + + ---------- + -- Line -- + ---------- + + -- Note: we assume that it is impossible in practice for the line + -- to exceed the value of Count'Last, i.e. no check is required for + -- overflow raising layout error. + + function Line (File : File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return File.Line; + end Line; + + function Line return Positive_Count is + begin + return Line (Current_Out); + end Line; + + ----------------- + -- Line_Length -- + ----------------- + + function Line_Length (File : File_Type) return Count is + begin + FIO.Check_Write_Status (AP (File)); + return File.Line_Length; + end Line_Length; + + function Line_Length return Count is + begin + return Line_Length (Current_Out); + end Line_Length; + + ---------------- + -- Look_Ahead -- + ---------------- + + procedure Look_Ahead + (File : File_Type; + Item : out Character; + End_Of_Line : out Boolean) + is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + -- If we are logically before a line mark, we can return immediately + + if File.Before_LM then + End_Of_Line := True; + Item := ASCII.NUL; + + -- If we are before an upper half character just return it (this can + -- happen if there are two calls to Look_Ahead in a row). + + elsif File.Before_Upper_Half_Character then + End_Of_Line := False; + Item := File.Saved_Upper_Half_Character; + + -- Otherwise we must read a character from the input stream + + else + ch := Getc (File); + + if ch = LM + or else ch = EOF + or else (ch = PM and then File.Is_Regular_File) + then + End_Of_Line := True; + Ungetc (ch, File); + Item := ASCII.NUL; + + -- Case where character obtained does not represent the start of an + -- encoded sequence so it stands for itself and we can unget it with + -- no difficulty. + + elsif not Is_Start_Of_Encoding + (Character'Val (ch), File.WC_Method) + then + End_Of_Line := False; + Ungetc (ch, File); + Item := Character'Val (ch); + + -- For the start of an encoding, we read the character using the + -- Get_Upper_Half_Char routine. It will occupy more than one byte + -- so we can't put it back with ungetc. Instead we save it in the + -- control block, setting a flag that everyone interested in reading + -- characters must test before reading the stream. + + else + Item := Get_Upper_Half_Char (Character'Val (ch), File); + End_Of_Line := False; + File.Saved_Upper_Half_Character := Item; + File.Before_Upper_Half_Character := True; + end if; + end if; + end Look_Ahead; + + procedure Look_Ahead + (Item : out Character; + End_Of_Line : out Boolean) + is + begin + Look_Ahead (Current_In, Item, End_Of_Line); + end Look_Ahead; + + ---------- + -- Mode -- + ---------- + + function Mode (File : File_Type) return File_Mode is + begin + return To_TIO (FIO.Mode (AP (File))); + end Mode; + + ---------- + -- Name -- + ---------- + + function Name (File : File_Type) return String is + begin + return FIO.Name (AP (File)); + end Name; + + -------------- + -- New_Line -- + -------------- + + procedure New_Line + (File : File_Type; + Spacing : Positive_Count := 1) + is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not Spacing'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Write_Status (AP (File)); + + for K in 1 .. Spacing loop + Putc (LM, File); + File.Line := File.Line + 1; + + if File.Page_Length /= 0 + and then File.Line > File.Page_Length + then + Putc (PM, File); + File.Line := 1; + File.Page := File.Page + 1; + end if; + end loop; + + File.Col := 1; + end New_Line; + + procedure New_Line (Spacing : Positive_Count := 1) is + begin + New_Line (Current_Out, Spacing); + end New_Line; + + -------------- + -- New_Page -- + -------------- + + procedure New_Page (File : File_Type) is + begin + FIO.Check_Write_Status (AP (File)); + + if File.Col /= 1 or else File.Line = 1 then + Putc (LM, File); + end if; + + Putc (PM, File); + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + end New_Page; + + procedure New_Page is + begin + New_Page (Current_Out); + end New_Page; + + ----------- + -- Nextc -- + ----------- + + function Nextc (File : File_Type) return int is + ch : int; + + begin + ch := fgetc (File.Stream); + + if ch = EOF then + if ferror (File.Stream) /= 0 then + raise Device_Error; + end if; + + else + if ungetc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end if; + + return ch; + end Nextc; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + Name : String; + Form : String := "") + is + Dummy_File_Control_Block : Text_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'T', + Creat => False, + Text => True); + + File.Self := File; + Set_WCEM (File); + end Open; + + ---------- + -- Page -- + ---------- + + -- Note: we assume that it is impossible in practice for the page + -- to exceed the value of Count'Last, i.e. no check is required for + -- overflow raising layout error. + + function Page (File : File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return File.Page; + end Page; + + function Page return Positive_Count is + begin + return Page (Current_Out); + end Page; + + ----------------- + -- Page_Length -- + ----------------- + + function Page_Length (File : File_Type) return Count is + begin + FIO.Check_Write_Status (AP (File)); + return File.Page_Length; + end Page_Length; + + function Page_Length return Count is + begin + return Page_Length (Current_Out); + end Page_Length; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Character) + is + begin + FIO.Check_Write_Status (AP (File)); + + if File.Line_Length /= 0 and then File.Col > File.Line_Length then + New_Line (File); + end if; + + -- If lower half character, or brackets encoding, output directly + + if Character'Pos (Item) < 16#80# + or else File.WC_Method = WCEM_Brackets + then + if fputc (Character'Pos (Item), File.Stream) = EOF then + raise Device_Error; + end if; + + -- Case of upper half character with non-brackets encoding + + else + Put_Encoded (File, Item); + end if; + + File.Col := File.Col + 1; + end Put; + + procedure Put (Item : Character) is + begin + FIO.Check_Write_Status (AP (Current_Out)); + + if Current_Out.Line_Length /= 0 + and then Current_Out.Col > Current_Out.Line_Length + then + New_Line (Current_Out); + end if; + + -- If lower half character, or brackets encoding, output directly + + if Character'Pos (Item) < 16#80# + or else Default_WCEM = WCEM_Brackets + then + if fputc (Character'Pos (Item), Current_Out.Stream) = EOF then + raise Device_Error; + end if; + + -- Case of upper half character with non-brackets encoding + + else + Put_Encoded (Current_Out, Item); + end if; + + Current_Out.Col := Current_Out.Col + 1; + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : String) + is + begin + FIO.Check_Write_Status (AP (File)); + + -- Only have something to do if string is non-null + + if Item'Length > 0 then + + -- If we have bounded lines, or if the file encoding is other than + -- Brackets and the string has at least one upper half character, + -- then output the string character by character. + + if File.Line_Length /= 0 + or else (File.WC_Method /= WCEM_Brackets + and then Has_Upper_Half_Character (Item)) + then + for J in Item'Range loop + Put (File, Item (J)); + end loop; + + -- Otherwise we can output the entire string at once. Note that if + -- there are LF or FF characters in the string, we do not bother to + -- count them as line or page terminators. + + else + FIO.Write_Buf (AP (File), Item'Address, Item'Length); + File.Col := File.Col + Item'Length; + end if; + end if; + end Put; + + procedure Put (Item : String) is + begin + Put (Current_Out, Item); + end Put; + + ----------------- + -- Put_Encoded -- + ----------------- + + procedure Put_Encoded (File : File_Type; Char : Character) is + procedure Out_Char (C : Character); + -- Procedure to output one character of an upper half encoded sequence + + procedure WC_Out is new Wide_Char_To_Char_Sequence (Out_Char); + + -------------- + -- Out_Char -- + -------------- + + procedure Out_Char (C : Character) is + begin + Putc (Character'Pos (C), File); + end Out_Char; + + -- Start of processing for Put_Encoded + + begin + WC_Out (Wide_Character'Val (Character'Pos (Char)), File.WC_Method); + end Put_Encoded; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line + (File : File_Type; + Item : String) + is + Ilen : Natural := Item'Length; + Istart : Natural := Item'First; + + begin + FIO.Check_Write_Status (AP (File)); + + -- If we have bounded lines, or if the file encoding is other than + -- Brackets and the string has at least one upper half character, then + -- output the string character by character. + + if File.Line_Length /= 0 + or else (File.WC_Method /= WCEM_Brackets + and then Has_Upper_Half_Character (Item)) + then + for J in Item'Range loop + Put (File, Item (J)); + end loop; + + New_Line (File); + return; + end if; + + -- Normal case where we do not need to output character by character + + -- We setup a single string that has the necessary terminators and + -- then write it with a single call. The reason for doing this is + -- that it gives better behavior for the use of Put_Line in multi- + -- tasking programs, since often the OS will treat the entire put + -- operation as an atomic operation. + + -- We only do this if the message is 512 characters or less in length, + -- since otherwise Put_Line would use an unbounded amount of stack + -- space and could cause undetected stack overflow. If we have a + -- longer string, then output the first part separately to avoid this. + + if Ilen > 512 then + FIO.Write_Buf (AP (File), Item'Address, size_t (Ilen - 512)); + Istart := Istart + Ilen - 512; + Ilen := 512; + end if; + + -- Now prepare the string with its terminator + + declare + Buffer : String (1 .. Ilen + 2); + Plen : size_t; + + begin + Buffer (1 .. Ilen) := Item (Istart .. Item'Last); + Buffer (Ilen + 1) := Character'Val (LM); + + if File.Page_Length /= 0 + and then File.Line > File.Page_Length + then + Buffer (Ilen + 2) := Character'Val (PM); + Plen := size_t (Ilen) + 2; + File.Line := 1; + File.Page := File.Page + 1; + + else + Plen := size_t (Ilen) + 1; + File.Line := File.Line + 1; + end if; + + FIO.Write_Buf (AP (File), Buffer'Address, Plen); + + File.Col := 1; + end; + end Put_Line; + + procedure Put_Line (Item : String) is + begin + Put_Line (Current_Out, Item); + end Put_Line; + + ---------- + -- Putc -- + ---------- + + procedure Putc (ch : int; File : File_Type) is + begin + if fputc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end Putc; + + ---------- + -- Read -- + ---------- + + -- This is the primitive Stream Read routine, used when a Text_IO file + -- is treated directly as a stream using Text_IO.Streams.Stream. + + procedure Read + (File : in out Text_AFCB; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset) + is + Discard_ch : int; + pragma Warnings (Off, Discard_ch); + + begin + -- Need to deal with Before_Upper_Half_Character ??? + + if File.Mode /= FCB.In_File then + raise Mode_Error; + end if; + + -- Deal with case where our logical and physical position do not match + -- because of being after an LM or LM-PM sequence when in fact we are + -- logically positioned before it. + + if File.Before_LM then + + -- If we are before a PM, then it is possible for a stream read + -- to leave us after the LM and before the PM, which is a bit + -- odd. The easiest way to deal with this is to unget the PM, + -- so we are indeed positioned between the characters. This way + -- further stream read operations will work correctly, and the + -- effect on text processing is a little weird, but what can + -- be expected if stream and text input are mixed this way? + + if File.Before_LM_PM then + Discard_ch := ungetc (PM, File.Stream); + File.Before_LM_PM := False; + end if; + + File.Before_LM := False; + + Item (Item'First) := Stream_Element (Character'Pos (ASCII.LF)); + + if Item'Length = 1 then + Last := Item'Last; + + else + Last := + Item'First + + Stream_Element_Offset + (fread (buffer => Item'Address, + index => size_t (Item'First + 1), + size => 1, + count => Item'Length - 1, + stream => File.Stream)); + end if; + + return; + end if; + + -- Now we do the read. Since this is a text file, it is normally in + -- text mode, but stream data must be read in binary mode, so we + -- temporarily set binary mode for the read, resetting it after. + -- These calls have no effect in a system (like Unix) where there is + -- no distinction between text and binary files. + + set_binary_mode (fileno (File.Stream)); + + Last := + Item'First + + Stream_Element_Offset + (fread (Item'Address, 1, Item'Length, File.Stream)) - 1; + + if Last < Item'Last then + if ferror (File.Stream) /= 0 then + raise Device_Error; + end if; + end if; + + set_text_mode (fileno (File.Stream)); + end Read; + + ----------- + -- Reset -- + ----------- + + procedure Reset + (File : in out File_Type; + Mode : File_Mode) + is + begin + -- Don't allow change of mode for current file (RM A.10.2(5)) + + if (File = Current_In or else + File = Current_Out or else + File = Current_Error) + and then To_FCB (Mode) /= File.Mode + then + raise Mode_Error; + end if; + + Terminate_Line (File); + FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); + File.Page := 1; + File.Line := 1; + File.Col := 1; + File.Line_Length := 0; + File.Page_Length := 0; + File.Before_LM := False; + File.Before_LM_PM := False; + end Reset; + + procedure Reset (File : in out File_Type) is + begin + Terminate_Line (File); + FIO.Reset (AP (File)'Unrestricted_Access); + File.Page := 1; + File.Line := 1; + File.Col := 1; + File.Line_Length := 0; + File.Page_Length := 0; + File.Before_LM := False; + File.Before_LM_PM := False; + end Reset; + + ------------- + -- Set_Col -- + ------------- + + procedure Set_Col + (File : File_Type; + To : Positive_Count) + is + ch : int; + + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_File_Open (AP (File)); + + -- Output case + + if Mode (File) >= Out_File then + + -- Error if we attempt to set Col to a value greater than the + -- maximum permissible line length. + + if File.Line_Length /= 0 and then To > File.Line_Length then + raise Layout_Error; + end if; + + -- If we are behind current position, then go to start of new line + + if To < File.Col then + New_Line (File); + end if; + + -- Loop to output blanks till we are at the required column + + while File.Col < To loop + Put (File, ' '); + end loop; + + -- Input case + + else + -- If we are logically before a LM, but physically after it, the + -- file position still reflects the position before the LM, so eat + -- it now and adjust the file position appropriately. + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + File.Line := File.Line + 1; + File.Col := 1; + end if; + + -- Loop reading characters till we get one at the required Col value + + loop + -- Read next character. The reason we have to read ahead is to + -- skip formatting characters, the effect of Set_Col is to set + -- us to a real character with the right Col value, and format + -- characters don't count. + + ch := Getc (File); + + -- Error if we hit an end of file + + if ch = EOF then + raise End_Error; + + -- If line mark, eat it and adjust file position + + elsif ch = LM then + File.Line := File.Line + 1; + File.Col := 1; + + -- If recognized page mark, eat it, and adjust file position + + elsif ch = PM and then File.Is_Regular_File then + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + + -- Otherwise this is the character we are looking for, so put it + -- back in the input stream (we have not adjusted the file + -- position yet, so everything is set right after this ungetc). + + elsif To = File.Col then + Ungetc (ch, File); + return; + + -- Keep skipping characters if we are not there yet, updating the + -- file position past the skipped character. + + else + File.Col := File.Col + 1; + end if; + end loop; + end if; + end Set_Col; + + procedure Set_Col (To : Positive_Count) is + begin + Set_Col (Current_Out, To); + end Set_Col; + + --------------- + -- Set_Error -- + --------------- + + procedure Set_Error (File : File_Type) is + begin + FIO.Check_Write_Status (AP (File)); + Current_Err := File; + end Set_Error; + + --------------- + -- Set_Input -- + --------------- + + procedure Set_Input (File : File_Type) is + begin + FIO.Check_Read_Status (AP (File)); + Current_In := File; + end Set_Input; + + -------------- + -- Set_Line -- + -------------- + + procedure Set_Line + (File : File_Type; + To : Positive_Count) + is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_File_Open (AP (File)); + + if To = File.Line then + return; + end if; + + if Mode (File) >= Out_File then + if File.Page_Length /= 0 and then To > File.Page_Length then + raise Layout_Error; + end if; + + if To < File.Line then + New_Page (File); + end if; + + while File.Line < To loop + New_Line (File); + end loop; + + else + while To /= File.Line loop + Skip_Line (File); + end loop; + end if; + end Set_Line; + + procedure Set_Line (To : Positive_Count) is + begin + Set_Line (Current_Out, To); + end Set_Line; + + --------------------- + -- Set_Line_Length -- + --------------------- + + procedure Set_Line_Length (File : File_Type; To : Count) is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Write_Status (AP (File)); + File.Line_Length := To; + end Set_Line_Length; + + procedure Set_Line_Length (To : Count) is + begin + Set_Line_Length (Current_Out, To); + end Set_Line_Length; + + ---------------- + -- Set_Output -- + ---------------- + + procedure Set_Output (File : File_Type) is + begin + FIO.Check_Write_Status (AP (File)); + Current_Out := File; + end Set_Output; + + --------------------- + -- Set_Page_Length -- + --------------------- + + procedure Set_Page_Length (File : File_Type; To : Count) is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Write_Status (AP (File)); + File.Page_Length := To; + end Set_Page_Length; + + procedure Set_Page_Length (To : Count) is + begin + Set_Page_Length (Current_Out, To); + end Set_Page_Length; + + -------------- + -- Set_WCEM -- + -------------- + + procedure Set_WCEM (File : in out File_Type) is + Start : Natural; + Stop : Natural; + + begin + File.WC_Method := WCEM_Brackets; + FIO.Form_Parameter (File.Form.all, "wcem", Start, Stop); + + if Start = 0 then + File.WC_Method := WCEM_Brackets; + + else + if Stop = Start then + for J in WC_Encoding_Letters'Range loop + if File.Form (Start) = WC_Encoding_Letters (J) then + File.WC_Method := J; + return; + end if; + end loop; + end if; + + Close (File); + raise Use_Error with "invalid WCEM form parameter"; + end if; + end Set_WCEM; + + --------------- + -- Skip_Line -- + --------------- + + procedure Skip_Line + (File : File_Type; + Spacing : Positive_Count := 1) + is + ch : int; + + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not Spacing'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Read_Status (AP (File)); + + for L in 1 .. Spacing loop + if File.Before_LM then + File.Before_LM := False; + + -- Note that if File.Before_LM_PM is currently set, we also have + -- to reset it (because it makes sense for Before_LM_PM to be set + -- only when Before_LM is also set). This is done later on in this + -- subprogram, as soon as Before_LM_PM has been taken into account + -- for the purpose of page and line counts. + + else + ch := Getc (File); + + -- If at end of file now, then immediately raise End_Error. Note + -- that we can never be positioned between a line mark and a page + -- mark, so if we are at the end of file, we cannot logically be + -- before the implicit page mark that is at the end of the file. + + -- For the same reason, we do not need an explicit check for a + -- page mark. If there is a FF in the middle of a line, the file + -- is not in canonical format and we do not care about the page + -- numbers for files other than ones in canonical format. + + if ch = EOF then + raise End_Error; + end if; + + -- If not at end of file, then loop till we get to an LM or EOF. + -- The latter case happens only in non-canonical files where the + -- last line is not terminated by LM, but we don't want to blow + -- up for such files, so we assume an implicit LM in this case. + + loop + exit when ch = LM or else ch = EOF; + ch := Getc (File); + end loop; + end if; + + -- We have got past a line mark, now, for a regular file only, + -- see if a page mark immediately follows this line mark and + -- if so, skip past the page mark as well. We do not do this + -- for non-regular files, since it would cause an undesirable + -- wait for an additional character. + + File.Col := 1; + File.Line := File.Line + 1; + + if File.Before_LM_PM then + File.Page := File.Page + 1; + File.Line := 1; + File.Before_LM_PM := False; + + elsif File.Is_Regular_File then + ch := Getc (File); + + -- Page mark can be explicit, or implied at the end of the file + + if (ch = PM or else ch = EOF) + and then File.Is_Regular_File + then + File.Page := File.Page + 1; + File.Line := 1; + else + Ungetc (ch, File); + end if; + end if; + end loop; + + File.Before_Upper_Half_Character := False; + end Skip_Line; + + procedure Skip_Line (Spacing : Positive_Count := 1) is + begin + Skip_Line (Current_In, Spacing); + end Skip_Line; + + --------------- + -- Skip_Page -- + --------------- + + procedure Skip_Page (File : File_Type) is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + -- If at page mark already, just skip it + + if File.Before_LM_PM then + File.Before_LM := False; + File.Before_LM_PM := False; + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + return; + end if; + + -- This is a bit tricky, if we are logically before an LM then + -- it is not an error if we are at an end of file now, since we + -- are not really at it. + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + ch := Getc (File); + + -- Otherwise we do raise End_Error if we are at the end of file now + + else + ch := Getc (File); + + if ch = EOF then + raise End_Error; + end if; + end if; + + -- Now we can just rumble along to the next page mark, or to the + -- end of file, if that comes first. The latter case happens when + -- the page mark is implied at the end of file. + + loop + exit when ch = EOF + or else (ch = PM and then File.Is_Regular_File); + ch := Getc (File); + end loop; + + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + File.Before_Upper_Half_Character := False; + end Skip_Page; + + procedure Skip_Page is + begin + Skip_Page (Current_In); + end Skip_Page; + + -------------------- + -- Standard_Error -- + -------------------- + + function Standard_Error return File_Type is + begin + return Standard_Err; + end Standard_Error; + + function Standard_Error return File_Access is + begin + return Standard_Err'Access; + end Standard_Error; + + -------------------- + -- Standard_Input -- + -------------------- + + function Standard_Input return File_Type is + begin + return Standard_In; + end Standard_Input; + + function Standard_Input return File_Access is + begin + return Standard_In'Access; + end Standard_Input; + + --------------------- + -- Standard_Output -- + --------------------- + + function Standard_Output return File_Type is + begin + return Standard_Out; + end Standard_Output; + + function Standard_Output return File_Access is + begin + return Standard_Out'Access; + end Standard_Output; + + -------------------- + -- Terminate_Line -- + -------------------- + + procedure Terminate_Line (File : File_Type) is + begin + FIO.Check_File_Open (AP (File)); + + -- For file other than In_File, test for needing to terminate last line + + if Mode (File) /= In_File then + + -- If not at start of line definition need new line + + if File.Col /= 1 then + New_Line (File); + + -- For files other than standard error and standard output, we + -- make sure that an empty file has a single line feed, so that + -- it is properly formatted. We avoid this for the standard files + -- because it is too much of a nuisance to have these odd line + -- feeds when nothing has been written to the file. + + -- We also avoid this for files opened in append mode, in + -- accordance with (RM A.8.2(10)) + + elsif (File /= Standard_Err and then File /= Standard_Out) + and then (File.Line = 1 and then File.Page = 1) + and then Mode (File) = Out_File + then + New_Line (File); + end if; + end if; + end Terminate_Line; + + ------------ + -- Ungetc -- + ------------ + + procedure Ungetc (ch : int; File : File_Type) is + begin + if ch /= EOF then + if ungetc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end if; + end Ungetc; + + ----------- + -- Write -- + ----------- + + -- This is the primitive Stream Write routine, used when a Text_IO file + -- is treated directly as a stream using Text_IO.Streams.Stream. + + procedure Write + (File : in out Text_AFCB; + Item : Stream_Element_Array) + is + pragma Warnings (Off, File); + -- Because in this implementation we don't need IN OUT, we only read + + function Has_Translated_Characters return Boolean; + -- return True if Item array contains a character which will be + -- translated under the text file mode. There is only one such + -- character under DOS based systems which is character 10. + + text_translation_required : Boolean; + for text_translation_required'Size use Character'Size; + pragma Import (C, text_translation_required, + "__gnat_text_translation_required"); + + Siz : constant size_t := Item'Length; + + ------------------------------- + -- Has_Translated_Characters -- + ------------------------------- + + function Has_Translated_Characters return Boolean is + begin + for K in Item'Range loop + if Item (K) = 10 then + return True; + end if; + end loop; + return False; + end Has_Translated_Characters; + + Needs_Binary_Write : constant Boolean := + text_translation_required + and then Has_Translated_Characters; + + -- Start of processing for Write + + begin + if File.Mode = FCB.In_File then + raise Mode_Error; + end if; + + -- Now we do the write. Since this is a text file, it is normally in + -- text mode, but stream data must be written in binary mode, so we + -- temporarily set binary mode for the write, resetting it after. This + -- is done only if needed (i.e. there is some characters in Item which + -- needs to be written using the binary mode). + -- These calls have no effect in a system (like Unix) where there is + -- no distinction between text and binary files. + + -- Since the character translation is done at the time the buffer is + -- written (this is true under Windows) we first flush current buffer + -- with text mode if needed. + + if Needs_Binary_Write then + if fflush (File.Stream) = -1 then + raise Device_Error; + end if; + + set_binary_mode (fileno (File.Stream)); + end if; + + if fwrite (Item'Address, 1, Siz, File.Stream) /= Siz then + raise Device_Error; + end if; + + -- At this point we need to flush the buffer using the binary mode then + -- we reset to text mode. + + if Needs_Binary_Write then + if fflush (File.Stream) = -1 then + raise Device_Error; + end if; + + set_text_mode (fileno (File.Stream)); + end if; + end Write; + +begin + -- Initialize Standard Files + + for J in WC_Encoding_Method loop + if WC_Encoding = WC_Encoding_Letters (J) then + Default_WCEM := J; + end if; + end loop; + + Initialize_Standard_Files; + + FIO.Chain_File (AP (Standard_In)); + FIO.Chain_File (AP (Standard_Out)); + FIO.Chain_File (AP (Standard_Err)); + +end Ada.Text_IO; diff --git a/gcc/ada/a-textio.ads b/gcc/ada/a-textio.ads new file mode 100644 index 000000000..d22b2f9c6 --- /dev/null +++ b/gcc/ada/a-textio.ads @@ -0,0 +1,472 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 + -- enough so that the assumption that the Line, Column and Page + -- counts can never exceed this value is a valid assumption. + + 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 bit of a kludge, but it works! + + Before_LM_PM : Boolean := False; + -- This flag similarly handles the case of being physically positioned + -- after a LM-PM sequence when logically we are before the LM-PM. This + -- flag can only be set if Before_LM is also set. + + WC_Method : System.WCh_Con.WC_Encoding_Method := Default_WCEM; + -- Encoding method to be used for this file. Text_IO does not deal with + -- wide characters, but it does deal with upper half characters in the + -- range 16#80#-16#FF# which may need encoding, e.g. in UTF-8 mode. + + Before_Upper_Half_Character : Boolean := False; + -- This flag is set to indicate that an encoded upper half character has + -- been read by Text_IO.Look_Ahead. If it is set to True, then it means + -- that the stream is logically positioned before the character but is + -- physically positioned after it. The character involved must be in + -- the range 16#80#-16#FF#, i.e. if the flag is set, then we know the + -- next character has a code greater than 16#7F#, and the value of this + -- character is saved in Saved_Upper_Half_Character. + + Saved_Upper_Half_Character : Character; + -- This field is valid only if Before_Upper_Half_Character is set. It + -- contains an upper-half character read by Look_Ahead. If Look_Ahead + -- reads a character in the range 16#00# to 16#7F#, then it can use + -- ungetc to put it back, but ungetc cannot be called more than once, + -- so for characters above this range, we don't try to back up the + -- file. Instead we save the character in this field and set the flag + -- Before_Upper_Half_Character to True to indicate that we are logically + -- positioned before this character even though the stream is physically + -- positioned after it. + + end record; + + function AFCB_Allocate (Control_Block : Text_AFCB) return FCB.AFCB_Ptr; + + procedure AFCB_Close (File : not null access Text_AFCB); + procedure AFCB_Free (File : not null access Text_AFCB); + + procedure Read + (File : in out Text_AFCB; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + -- Read operation used when Text_IO file is treated directly as Stream + + procedure Write + (File : in out Text_AFCB; + Item : Ada.Streams.Stream_Element_Array); + -- Write operation used when Text_IO file is treated directly as Stream + + ------------------------ + -- The Standard Files -- + ------------------------ + + Standard_In_AFCB : aliased Text_AFCB; + Standard_Out_AFCB : aliased Text_AFCB; + Standard_Err_AFCB : aliased Text_AFCB; + + Standard_In : aliased File_Type := Standard_In_AFCB'Access; + Standard_Out : aliased File_Type := Standard_Out_AFCB'Access; + Standard_Err : aliased File_Type := Standard_Err_AFCB'Access; + -- Standard files + + Current_In : aliased File_Type := Standard_In; + Current_Out : aliased File_Type := Standard_Out; + Current_Err : aliased File_Type := Standard_Err; + -- Current files + + function EOF_Char return Integer; + -- Returns the system-specific character indicating the end of a text file. + -- This is exported for use by child packages such as Enumeration_Aux to + -- eliminate their needing to depend directly on Interfaces.C_Streams, + -- which is not available in certain target environments (such as AAMP). + + procedure Initialize_Standard_Files; + -- Initializes the file control blocks for the standard files. Called from + -- the elaboration routine for this package, and from Reset_Standard_Files + -- in package Ada.Text_IO.Reset_Standard_Files. + +end Ada.Text_IO; diff --git a/gcc/ada/a-tgdico.ads b/gcc/ada/a-tgdico.ads new file mode 100644 index 000000000..d1150fd59 --- /dev/null +++ b/gcc/ada/a-tgdico.ads @@ -0,0 +1,33 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- ADA.TAGS.GENERIC_DISPATCHING_CONSTRUCTOR -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +pragma Warnings (Off); +-- Turn of categorization warnings + +generic + type T (<>) is abstract tagged limited private; + type Parameters (<>) is limited private; + with function Constructor (Params : not null access Parameters) return T + is abstract; + +function Ada.Tags.Generic_Dispatching_Constructor + (The_Tag : Tag; + Params : not null access Parameters) return T'Class; +pragma Preelaborate_05 (Generic_Dispatching_Constructor); +pragma Import (Intrinsic, Generic_Dispatching_Constructor); +-- Note: the reason that we use Preelaborate_05 here is so that this will +-- compile fine during the normal build procedures. In Ada 2005 mode (which +-- is required for this package anyway), this will be treated as Preelaborate +-- so everything will be fine. diff --git a/gcc/ada/a-tiboio.adb b/gcc/ada/a-tiboio.adb new file mode 100644 index 000000000..dcc91be86 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Unchecked_Deallocation; + +package body Ada.Text_IO.Bounded_IO is + + type String_Access is access all String; + + procedure Free (SA : in out String_Access); + -- Perform an unchecked deallocation of a non-null string + + ---------- + -- Free -- + ---------- + + procedure Free (SA : in out String_Access) is + Null_String : constant String := ""; + + procedure Deallocate is + new Ada.Unchecked_Deallocation (String, String_Access); + + begin + -- Do not try to free statically allocated null string + + if SA.all /= Null_String then + Deallocate (SA); + end if; + end Free; + + -------------- + -- Get_Line -- + -------------- + + function Get_Line return Bounded.Bounded_String is + begin + return Bounded.To_Bounded_String (Get_Line); + end Get_Line; + + -------------- + -- Get_Line -- + -------------- + + function Get_Line + (File : File_Type) return Bounded.Bounded_String + is + begin + return Bounded.To_Bounded_String (Get_Line (File)); + end Get_Line; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line + (Item : out Bounded.Bounded_String) + is + Buffer : String (1 .. 1000); + Last : Natural; + Str1 : String_Access; + Str2 : String_Access; + + begin + Get_Line (Buffer, Last); + Str1 := new String'(Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Str2 := new String'(Str1.all & Buffer (1 .. Last)); + Free (Str1); + Str1 := Str2; + end loop; + + Item := Bounded.To_Bounded_String (Str1.all); + end Get_Line; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line + (File : File_Type; + Item : out Bounded.Bounded_String) + is + Buffer : String (1 .. 1000); + Last : Natural; + Str1 : String_Access; + Str2 : String_Access; + + begin + Get_Line (File, Buffer, Last); + Str1 := new String'(Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Str2 := new String'(Str1.all & Buffer (1 .. Last)); + Free (Str1); + Str1 := Str2; + end loop; + + Item := Bounded.To_Bounded_String (Str1.all); + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put + (Item : Bounded.Bounded_String) + is + begin + Put (Bounded.To_String (Item)); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Bounded.Bounded_String) + is + begin + Put (File, Bounded.To_String (Item)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line + (Item : Bounded.Bounded_String) + is + begin + Put_Line (Bounded.To_String (Item)); + end Put_Line; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line + (File : File_Type; + Item : Bounded.Bounded_String) + is + begin + Put_Line (File, Bounded.To_String (Item)); + end Put_Line; + +end Ada.Text_IO.Bounded_IO; diff --git a/gcc/ada/a-tiboio.ads b/gcc/ada/a-tiboio.ads new file mode 100644 index 000000000..1824c1d2c --- /dev/null +++ b/gcc/ada/a-tiboio.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . B O U N D E D _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Bounded; + +generic + with package Bounded is + new Ada.Strings.Bounded.Generic_Bounded_Length (<>); + +package Ada.Text_IO.Bounded_IO is + + function Get_Line return Bounded.Bounded_String; + + function Get_Line + (File : File_Type) return Bounded.Bounded_String; + + procedure Get_Line + (Item : out Bounded.Bounded_String); + + procedure Get_Line + (File : File_Type; + Item : out Bounded.Bounded_String); + + procedure Put + (Item : Bounded.Bounded_String); + + procedure Put + (File : File_Type; + Item : Bounded.Bounded_String); + + procedure Put_Line + (Item : Bounded.Bounded_String); + + procedure Put_Line + (File : File_Type; + Item : Bounded.Bounded_String); + +end Ada.Text_IO.Bounded_IO; diff --git a/gcc/ada/a-ticoau.adb b/gcc/ada/a-ticoau.adb new file mode 100644 index 000000000..0601ef064 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..b8fe9dfac --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..f06f84778 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..9b71b97de --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..2790bed68 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..ae75fc11b --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..5dceb128f --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..8bb81590b --- /dev/null +++ b/gcc/ada/a-tideio.ads @@ -0,0 +1,88 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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.Text_IO_Kludge 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 new file mode 100644 index 000000000..f0c1800f9 --- /dev/null +++ b/gcc/ada/a-tienau.adb @@ -0,0 +1,260 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 + 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; + + else + Put_Item (File, Item); + end if; + + 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 new file mode 100644 index 000000000..525c22336 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..6e1868ab3 --- /dev/null +++ b/gcc/ada/a-tienio.adb @@ -0,0 +1,121 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 + Image : constant String := Enum'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_Out, Item, Width, Set); + end Put; + + procedure Put + (To : out String; + Item : Enum; + Set : Type_Set := Default_Setting) + is + Image : constant String := Enum'Image (Item); + begin + Aux.Puts (To, Image, Set); + end Put; + +end Ada.Text_IO.Enumeration_IO; diff --git a/gcc/ada/a-tienio.ads b/gcc/ada/a-tienio.ads new file mode 100644 index 000000000..4c7a9b52c --- /dev/null +++ b/gcc/ada/a-tienio.ads @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . E N U M E R A T I O N _ I O -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Text_IO.Enumeration_IO is a subpackage of +-- Text_IO. This is for compatibility with Ada 83. In GNAT we make it a +-- child package to avoid loading the necessary code if Enumeration_IO is +-- not instantiated. See routine Rtsfind.Text_IO_Kludge for a description +-- of how we patch up the difference in semantics so that it is invisible +-- to the Ada programmer. + +private generic + type Enum is (<>); + +package Ada.Text_IO.Enumeration_IO is + + Default_Width : Field := 0; + Default_Setting : Type_Set := Upper_Case; + + procedure Get (File : File_Type; Item : out Enum); + procedure Get (Item : out Enum); + + procedure Put + (File : File_Type; + Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting); + + procedure Put + (Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting); + + procedure Get + (From : String; + Item : out Enum; + Last : out Positive); + + procedure Put + (To : out String; + Item : Enum; + Set : Type_Set := Default_Setting); + +end Ada.Text_IO.Enumeration_IO; diff --git a/gcc/ada/a-tifiio.adb b/gcc/ada/a-tifiio.adb new file mode 100644 index 000000000..82aeb8a83 --- /dev/null +++ b/gcc/ada/a-tifiio.adb @@ -0,0 +1,717 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- Fixed point I/O +-- --------------- + +-- The following documents implementation details of the fixed point +-- input/output routines in the GNAT run time. The first part describes +-- general properties of fixed point types as defined by the Ada 95 standard, +-- including the Information Systems Annex. + +-- Subsequently these are reduced to implementation constraints and the impact +-- of these constraints on a few possible approaches to I/O are given. +-- Based on this analysis, a specific implementation is selected for use in +-- the GNAT run time. Finally, the chosen algorithm is analyzed numerically in +-- order to provide user-level documentation on limits for range and precision +-- of fixed point types as well as accuracy of input/output conversions. + +-- ------------------------------------------- +-- - General Properties of Fixed Point Types - +-- ------------------------------------------- + +-- Operations on fixed point values, other than input and output, are not +-- important for the purposes of this document. Only the set of values that a +-- fixed point type can represent and the input and output operations are +-- significant. + +-- Values +-- ------ + +-- Set set of values of a fixed point type comprise the integral +-- multiples of a number called the small of the type. The small can +-- either be a power of ten, a power of two or (if the implementation +-- allows) an arbitrary strictly positive real value. + +-- Implementations need to support fixed-point types with a precision +-- of at least 24 bits, and (in order to comply with the Information +-- Systems Annex) decimal types need to support at least digits 18. +-- For the rest, however, no requirements exist for the minimal small +-- and range that need to be supported. + +-- Operations +-- ---------- + +-- 'Image and 'Wide_Image (see RM 3.5(34)) + +-- These attributes return a decimal real literal best approximating +-- the value (rounded away from zero if halfway between) with a +-- single leading character that is either a minus sign or a space, +-- one or more digits before the decimal point (with no redundant +-- leading zeros), a decimal point, and N digits after the decimal +-- point. For a subtype S, the value of N is S'Aft, the smallest +-- positive integer such that (10**N)*S'Delta is greater or equal to +-- one, see RM 3.5.10(5). + +-- For an arbitrary small, this means large number arithmetic needs +-- to be performed. + +-- Put (see RM A.10.9(22-26)) + +-- The requirements for Put add no extra constraints over the image +-- attributes, although it would be nice to be able to output more +-- than S'Aft digits after the decimal point for values of subtype S. + +-- 'Value and 'Wide_Value attribute (RM 3.5(40-55)) + +-- Since the input can be given in any base in the range 2..16, +-- accurate conversion to a fixed point number may require +-- arbitrary precision arithmetic if there is no limit on the +-- magnitude of the small of the fixed point type. + +-- Get (see RM A.10.9(12-21)) + +-- The requirements for Get are identical to those of the Value +-- attribute. + +-- ------------------------------ +-- - Implementation Constraints - +-- ------------------------------ + +-- The requirements listed above for the input/output operations lead to +-- significant complexity, if no constraints are put on supported smalls. + +-- Implementation Strategies +-- ------------------------- + +-- * Float arithmetic +-- * Arbitrary-precision integer arithmetic +-- * Fixed-precision integer arithmetic + +-- Although it seems convenient to convert fixed point numbers to floating- +-- point and then print them, this leads to a number of restrictions. +-- The first one is precision. The widest floating-point type generally +-- available has 53 bits of mantissa. This means that Fine_Delta cannot +-- be less than 2.0**(-53). + +-- In GNAT, Fine_Delta is 2.0**(-63), and Duration for example is a +-- 64-bit type. It would still be possible to use multi-precision +-- floating-point to perform calculations using longer mantissas, +-- but this is a much harder approach. + +-- The base conversions needed for input and output of (non-decimal) +-- fixed point types can be seen as pairs of integer multiplications +-- and divisions. + +-- Arbitrary-precision integer arithmetic would be suitable for the job +-- at hand, but has the draw-back that it is very heavy implementation-wise. +-- Especially in embedded systems, where fixed point types are often used, +-- it may not be desirable to require large amounts of storage and time +-- for fixed I/O operations. + +-- Fixed-precision integer arithmetic has the advantage of simplicity and +-- speed. For the most common fixed point types this would be a perfect +-- solution. The downside however may be a too limited set of acceptable +-- fixed point types. + +-- Extra Precision +-- --------------- + +-- Using a scaled divide which truncates and returns a remainder R, +-- another E trailing digits can be calculated by computing the value +-- (R * (10.0**E)) / Z using another scaled divide. This procedure +-- can be repeated to compute an arbitrary number of digits in linear +-- time and storage. The last scaled divide should be rounded, with +-- a possible carry propagating to the more significant digits, to +-- ensure correct rounding of the unit in the last place. + +-- An extension of this technique is to limit the value of Q to 9 decimal +-- digits, since 32-bit integers can be much more efficient than 64-bit +-- integers to output. + +with Interfaces; use Interfaces; +with System.Arith_64; use System.Arith_64; +with System.Img_Real; use System.Img_Real; +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Text_IO.Float_Aux; +with Ada.Text_IO.Generic_Aux; + +package body Ada.Text_IO.Fixed_IO is + + -- Note: we still use the floating-point I/O routines for input of + -- ordinary fixed-point and output using exponent format. This will + -- result in inaccuracies for fixed point types with a small that is + -- not a power of two, and for types that require more precision than + -- is available in Long_Long_Float. + + package Aux renames Ada.Text_IO.Float_Aux; + + Extra_Layout_Space : constant Field := 5 + Num'Fore; + -- Extra space that may be needed for output of sign, decimal point, + -- exponent indication and mandatory decimals after and before the + -- decimal point. A string with length + + -- Fore + Aft + Exp + Extra_Layout_Space + + -- is always long enough for formatting any fixed point number + + -- Implementation of Put routines + + -- The following section describes a specific implementation choice for + -- performing base conversions needed for output of values of a fixed + -- point type T with small T'Small. The goal is to be able to output + -- all values of types with a precision of 64 bits and a delta of at + -- least 2.0**(-63), as these are current GNAT limitations already. + + -- The chosen algorithm uses fixed precision integer arithmetic for + -- reasons of simplicity and efficiency. It is important to understand + -- in what ways the most simple and accurate approach to fixed point I/O + -- is limiting, before considering more complicated schemes. + + -- Without loss of generality assume T has a range (-2.0**63) * T'Small + -- .. (2.0**63 - 1) * T'Small, and is output with Aft digits after the + -- decimal point and T'Fore - 1 before. If T'Small is integer, or + -- 1.0 / T'Small is integer, let S = T'Small and E = 0. For other T'Small, + -- let S and E be integers such that S / 10**E best approximates T'Small + -- and S is in the range 10**17 .. 10**18 - 1. The extra decimal scaling + -- factor 10**E can be trivially handled during final output, by adjusting + -- the decimal point or exponent. + + -- Convert a value X * S of type T to a 64-bit integer value Q equal + -- to 10.0**D * (X * S) rounded to the nearest integer. + -- This conversion is a scaled integer divide of the form + + -- Q := (X * Y) / Z, + + -- where all variables are 64-bit signed integers using 2's complement, + -- and both the multiplication and division are done using full + -- intermediate precision. The final decimal value to be output is + + -- Q * 10**(E-D) + + -- This value can be written to the output file or to the result string + -- according to the format described in RM A.3.10. The details of this + -- operation are omitted here. + + -- A 64-bit value can contain all integers with 18 decimal digits, but + -- not all with 19 decimal digits. If the total number of requested output + -- digits (Fore - 1) + Aft is greater than 18, for purposes of the + -- conversion Aft is adjusted to 18 - (Fore - 1). In that case, or + -- when Fore > 19, trailing zeros can complete the output after writing + -- the first 18 significant digits, or the technique described in the + -- next section can be used. + + -- The final expression for D is + + -- D := Integer'Max (-18, Integer'Min (Aft, 18 - (Fore - 1))); + + -- For Y and Z the following expressions can be derived: + + -- Q / (10.0**D) = X * S + + -- Q = X * S * (10.0**D) = (X * Y) / Z + + -- S * 10.0**D = Y / Z; + + -- If S is an integer greater than or equal to one, then Fore must be at + -- least 20 in order to print T'First, which is at most -2.0**63. + -- This means D < 0, so use + + -- (1) Y = -S and Z = -10**(-D) + + -- If 1.0 / S is an integer greater than one, use + + -- (2) Y = -10**D and Z = -(1.0 / S), for D >= 0 + + -- or + + -- (3) Y = 1 and Z = (1.0 / S) * 10**(-D), for D < 0 + + -- Negative values are used for nominator Y and denominator Z, so that S + -- can have a maximum value of 2.0**63 and a minimum of 2.0**(-63). + -- For Z in -1 .. -9, Fore will still be 20, and D will be negative, as + -- (-2.0**63) / -9 is greater than 10**18. In these cases there is room + -- in the denominator for the extra decimal scaling required, so case (3) + -- will not overflow. + + pragma Assert (System.Fine_Delta >= 2.0**(-63)); + pragma Assert (Num'Small in 2.0**(-63) .. 2.0**63); + pragma Assert (Num'Fore <= 37); + -- These assertions need to be relaxed to allow for a Small of + -- 2.0**(-64) at least, since there is an ACATS test for this ??? + + Max_Digits : constant := 18; + -- Maximum number of decimal digits that can be represented in a + -- 64-bit signed number, see above + + -- The constants E0 .. E5 implement a binary search for the appropriate + -- power of ten to scale the small so that it has one digit before the + -- decimal point. + + subtype Int is Integer; + E0 : constant Int := -(20 * Boolean'Pos (Num'Small >= 1.0E1)); + E1 : constant Int := E0 + 10 * Boolean'Pos (Num'Small * 10.0**E0 < 1.0E-10); + E2 : constant Int := E1 + 5 * Boolean'Pos (Num'Small * 10.0**E1 < 1.0E-5); + E3 : constant Int := E2 + 3 * Boolean'Pos (Num'Small * 10.0**E2 < 1.0E-3); + E4 : constant Int := E3 + 2 * Boolean'Pos (Num'Small * 10.0**E3 < 1.0E-1); + E5 : constant Int := E4 + 1 * Boolean'Pos (Num'Small * 10.0**E4 < 1.0E-0); + + Scale : constant Integer := E5; + + pragma Assert (Num'Small * 10.0**Scale >= 1.0 + and then Num'Small * 10.0**Scale < 10.0); + + Exact : constant Boolean := + Float'Floor (Num'Small) = Float'Ceiling (Num'Small) + or else Float'Floor (1.0 / Num'Small) = + Float'Ceiling (1.0 / Num'Small) + or else Num'Small >= 10.0**Max_Digits; + -- True iff a numerator and denominator can be calculated such that + -- their ratio exactly represents the small of Num. + + procedure Put + (To : out String; + Last : out Natural; + Item : Num; + Fore : Integer; + Aft : Field; + Exp : Field); + -- Actual output function, used internally by all other Put routines. + -- The formal Fore is an Integer, not a Field, because the routine is + -- also called from the version of Put that performs I/O to a string, + -- where the starting position depends on the size of the String, and + -- bears no relation to the bounds of Field. + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + pragma Unsuppress (Range_Check); + begin + Aux.Get (File, Long_Long_Float (Item), Width); + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + pragma Unsuppress (Range_Check); + begin + Aux.Get (Current_In, Long_Long_Float (Item), Width); + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (From : String; + Item : out Num; + Last : out Positive) + is + pragma Unsuppress (Range_Check); + begin + Aux.Gets (From, Long_Long_Float (Item), Last); + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (1 .. Fore + Aft + Exp + Extra_Layout_Space); + Last : Natural; + begin + Put (S, Last, Item, Fore, Aft, Exp); + Generic_Aux.Put_Item (File, S (1 .. Last)); + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (1 .. Fore + Aft + Exp + Extra_Layout_Space); + Last : Natural; + begin + Put (S, Last, Item, Fore, Aft, Exp); + Generic_Aux.Put_Item (Text_IO.Current_Out, S (1 .. Last)); + end Put; + + procedure Put + (To : out String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + Fore : constant Integer := + To'Length + - 1 -- Decimal point + - Field'Max (1, Aft) -- Decimal part + - Boolean'Pos (Exp /= 0) -- Exponent indicator + - Exp; -- Exponent + + Last : Natural; + + begin + if Fore - Boolean'Pos (Item < 0.0) < 1 then + raise Layout_Error; + end if; + + Put (To, Last, Item, Fore, Aft, Exp); + + if Last /= To'Last then + raise Layout_Error; + end if; + end Put; + + procedure Put + (To : out String; + Last : out Natural; + Item : Num; + Fore : Integer; + Aft : Field; + Exp : Field) + is + subtype Digit is Int64 range 0 .. 9; + + X : constant Int64 := Int64'Integer_Value (Item); + A : constant Field := Field'Max (Aft, 1); + Neg : constant Boolean := (Item < 0.0); + Pos : Integer := 0; -- Next digit X has value X * 10.0**Pos; + + procedure Put_Character (C : Character); + pragma Inline (Put_Character); + -- Add C to the output string To, updating Last + + procedure Put_Digit (X : Digit); + -- Add digit X to the output string (going from left to right), updating + -- Last and Pos, and inserting the sign, leading zeros or a decimal + -- point when necessary. After outputting the first digit, Pos must not + -- be changed outside Put_Digit anymore. + + procedure Put_Int64 (X : Int64; Scale : Integer); + -- Output the decimal number abs X * 10**Scale + + procedure Put_Scaled + (X, Y, Z : Int64; + A : Field; + E : Integer); + -- Output the decimal number (X * Y / Z) * 10**E, producing A digits + -- after the decimal point and rounding the final digit. The value + -- X * Y / Z is computed with full precision, but must be in the + -- range of Int64. + + ------------------- + -- Put_Character -- + ------------------- + + procedure Put_Character (C : Character) is + begin + Last := Last + 1; + + -- Never put a character outside of string To. Exception Layout_Error + -- will be raised later if Last is greater than To'Last. + + if Last <= To'Last then + To (Last) := C; + end if; + end Put_Character; + + --------------- + -- Put_Digit -- + --------------- + + procedure Put_Digit (X : Digit) is + Digs : constant array (Digit) of Character := "0123456789"; + + begin + if Last = To'First - 1 then + if X /= 0 or else Pos <= 0 then + + -- Before outputting first digit, include leading space, + -- possible minus sign and, if the first digit is fractional, + -- decimal seperator and leading zeros. + + -- The Fore part has Pos + 1 + Boolean'Pos (Neg) characters, + -- if Pos >= 0 and otherwise has a single zero digit plus minus + -- sign if negative. Add leading space if necessary. + + for J in Integer'Max (0, Pos) + 2 + Boolean'Pos (Neg) .. Fore + loop + Put_Character (' '); + end loop; + + -- Output minus sign, if number is negative + + if Neg then + Put_Character ('-'); + end if; + + -- If starting with fractional digit, output leading zeros + + if Pos < 0 then + Put_Character ('0'); + Put_Character ('.'); + + for J in Pos .. -2 loop + Put_Character ('0'); + end loop; + end if; + + Put_Character (Digs (X)); + end if; + + else + -- This is not the first digit to be output, so the only + -- special handling is that for the decimal point + + if Pos = -1 then + Put_Character ('.'); + end if; + + Put_Character (Digs (X)); + end if; + + Pos := Pos - 1; + end Put_Digit; + + --------------- + -- Put_Int64 -- + --------------- + + procedure Put_Int64 (X : Int64; Scale : Integer) is + begin + if X = 0 then + return; + end if; + + if X not in -9 .. 9 then + Put_Int64 (X / 10, Scale + 1); + end if; + + -- Use Put_Digit to advance Pos. This fixes a case where the second + -- or later Scaled_Divide would omit leading zeroes, resulting in + -- too few digits produced and a Layout_Error as result. + + while Pos > Scale loop + Put_Digit (0); + end loop; + + -- If and only if more than one digit is output before the decimal + -- point, pos will be unequal to scale when outputting the first + -- digit. + + pragma Assert (Pos = Scale or else Last = To'First - 1); + + Pos := Scale; + + Put_Digit (abs (X rem 10)); + end Put_Int64; + + ---------------- + -- Put_Scaled -- + ---------------- + + procedure Put_Scaled + (X, Y, Z : Int64; + A : Field; + E : Integer) + is + pragma Assert (E >= -Max_Digits); + AA : constant Field := E + A; + N : constant Natural := (AA + Max_Digits - 1) / Max_Digits + 1; + + Q : array (0 .. N - 1) of Int64 := (others => 0); + -- Each element of Q has Max_Digits decimal digits, except the + -- last, which has eAA rem Max_Digits. Only Q (Q'First) may have an + -- absolute value equal to or larger than 10**Max_Digits. Only the + -- absolute value of the elements is not significant, not the sign. + + XX : Int64 := X; + YY : Int64 := Y; + + begin + for J in Q'Range loop + exit when XX = 0; + + if J > 0 then + YY := 10**(Integer'Min (Max_Digits, AA - (J - 1) * Max_Digits)); + end if; + + Scaled_Divide (XX, YY, Z, Q (J), R => XX, Round => False); + end loop; + + if -E > A then + pragma Assert (N = 1); + + Discard_Extra_Digits : declare + Factor : constant Int64 := 10**(-E - A); + + begin + -- The scaling factors were such that the first division + -- produced more digits than requested. So divide away extra + -- digits and compute new remainder for later rounding. + + if abs (Q (0) rem Factor) >= Factor / 2 then + Q (0) := abs (Q (0) / Factor) + 1; + else + Q (0) := Q (0) / Factor; + end if; + + XX := 0; + end Discard_Extra_Digits; + end if; + + -- At this point XX is a remainder and we need to determine if the + -- quotient in Q must be rounded away from zero. + + -- As XX is less than the divisor, it is safe to take its absolute + -- without chance of overflow. The check to see if XX is at least + -- half the absolute value of the divisor must be done carefully to + -- avoid overflow or lose precision. + + XX := abs XX; + + if XX >= 2**62 + or else (Z < 0 and then (-XX) * 2 <= Z) + or else (Z >= 0 and then XX * 2 >= Z) + then + -- OK, rounding is necessary. As the sign is not significant, + -- take advantage of the fact that an extra negative value will + -- always be available when propagating the carry. + + Q (Q'Last) := -abs Q (Q'Last) - 1; + + Propagate_Carry : + for J in reverse 1 .. Q'Last loop + if Q (J) = YY or else Q (J) = -YY then + Q (J) := 0; + Q (J - 1) := -abs Q (J - 1) - 1; + + else + exit Propagate_Carry; + end if; + end loop Propagate_Carry; + end if; + + for J in Q'First .. Q'Last - 1 loop + Put_Int64 (Q (J), E - J * Max_Digits); + end loop; + + Put_Int64 (Q (Q'Last), -A); + end Put_Scaled; + + -- Start of processing for Put + + begin + Last := To'First - 1; + + if Exp /= 0 then + + -- With the Exp format, it is not known how many output digits to + -- generate, as leading zeros must be ignored. Computing too many + -- digits and then truncating the output will not give the closest + -- output, it is necessary to round at the correct digit. + + -- The general approach is as follows: as long as no digits have + -- been generated, compute the Aft next digits (without rounding). + -- Once a non-zero digit is generated, determine the exact number + -- of digits remaining and compute them with rounding. + + -- Since a large number of iterations might be necessary in case + -- of Aft = 1, the following optimization would be desirable. + + -- Count the number Z of leading zero bits in the integer + -- representation of X, and start with producing Aft + Z * 1000 / + -- 3322 digits in the first scaled division. + + -- However, the floating-point routines are still used now ??? + + System.Img_Real.Set_Image_Real (Long_Long_Float (Item), To, Last, + Fore, Aft, Exp); + return; + end if; + + if Exact then + declare + D : constant Integer := Integer'Min (A, Max_Digits + - (Num'Fore - 1)); + Y : constant Int64 := Int64'Min (Int64 (-Num'Small), -1) + * 10**Integer'Max (0, D); + Z : constant Int64 := Int64'Min (Int64 (-(1.0 / Num'Small)), -1) + * 10**Integer'Max (0, -D); + begin + Put_Scaled (X, Y, Z, A, -D); + end; + + else -- not Exact + declare + E : constant Integer := Max_Digits - 1 + Scale; + D : constant Integer := Scale - 1; + Y : constant Int64 := Int64 (-Num'Small * 10.0**E); + Z : constant Int64 := -10**Max_Digits; + begin + Put_Scaled (X, Y, Z, A, -D); + end; + end if; + + -- If only zero digits encountered, unit digit has not been output yet + + if Last < To'First then + Pos := 0; + + elsif Last > To'Last then + raise Layout_Error; -- Not enough room in the output variable + end if; + + -- Always output digits up to the first one after the decimal point + + while Pos >= -A loop + Put_Digit (0); + end loop; + end Put; + +end Ada.Text_IO.Fixed_IO; diff --git a/gcc/ada/a-tifiio.ads b/gcc/ada/a-tifiio.ads new file mode 100644 index 000000000..6225d0084 --- /dev/null +++ b/gcc/ada/a-tifiio.ads @@ -0,0 +1,88 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . F I X E D _ 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. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Text_IO.Fixed_IO is a subpackage of Text_IO. +-- This is for compatibility with Ada 83. In GNAT we make it a child package +-- to avoid loading the necessary code if Fixed_IO is not instantiated. See +-- routine Rtsfind.Text_IO_Kludge for a description of how we patch up the +-- difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is delta <>; + +package Ada.Text_IO.Fixed_IO is + + Default_Fore : Field := Num'Fore; + Default_Aft : Field := Num'Aft; + Default_Exp : Field := 0; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +private + pragma Inline (Get); + pragma Inline (Put); + +end Ada.Text_IO.Fixed_IO; diff --git a/gcc/ada/a-tiflau.adb b/gcc/ada/a-tiflau.adb new file mode 100644 index 000000000..1f8f58b20 --- /dev/null +++ b/gcc/ada/a-tiflau.adb @@ -0,0 +1,234 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 + + 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 new file mode 100644 index 000000000..4be17586c --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..af0f1ab7c --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..0df8e53b3 --- /dev/null +++ b/gcc/ada/a-tiflio.ads @@ -0,0 +1,88 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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.Text_IO_Kludge 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 new file mode 100644 index 000000000..24d753b04 --- /dev/null +++ b/gcc/ada/a-tigeau.adb @@ -0,0 +1,474 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 + 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 new file mode 100644 index 000000000..4de4739dc --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains a set of auxiliary routines used by the Text_IO +-- generic children, including for reading and writing numeric strings. + +private package Ada.Text_IO.Generic_Aux is + + -- Note: for all the Load routines, File indicates the file to be read, + -- Buf is the string into which data is stored, Ptr is the index of the + -- last character stored so far, and is updated if additional characters + -- are stored. Data_Error is raised if the input overflows Buf. The only + -- Load routines that do a file status check are Load_Skip and Load_Width + -- so one of these two routines must be called first. + + procedure Check_End_Of_Field + (Buf : String; + Stop : Integer; + Ptr : Integer; + Width : Field); + -- This routine is used after doing a get operations on a numeric value. + -- Buf is the string being scanned, and Stop is the last character of + -- the field being scanned. Ptr is as set by the call to the scan routine + -- that scanned out the numeric value, i.e. it points one past the last + -- character scanned, and Width is the width parameter from the Get call. + -- + -- There are two cases, if Width is non-zero, then a check is made that + -- the remainder of the field is all blanks. If Width is zero, then it + -- means that the scan routine scanned out only part of the field. We + -- have already scanned out the field that the ACVC tests seem to expect + -- us to read (even if it does not follow the syntax of the type being + -- scanned, e.g. allowing negative exponents in integers, and underscores + -- at the end of the string), so we just raise Data_Error. + + procedure Check_On_One_Line (File : File_Type; Length : Integer); + -- Check to see if item of length Integer characters can fit on + -- current line. Call New_Line if not, first checking that the + -- line length can accommodate Length characters, raise Layout_Error + -- if item is too large for a single line. + + function Getc (File : File_Type) return Integer; + -- Gets next character from file, which has already been checked for + -- being in read status, and returns the character read if no error + -- occurs. The result is EOF if the end of file was read. Note that + -- the Col value is not bumped, so it is the caller's responsibility + -- to bump it if necessary. + + function Is_Blank (C : Character) return Boolean; + -- Determines if C is a blank (space or tab) + + procedure Load_Width + (File : File_Type; + Width : Field; + Buf : out String; + Ptr : in out Integer); + -- Loads exactly Width characters, unless a line mark is encountered first + + procedure Load_Skip (File : File_Type); + -- Skips leading blanks and line and page marks, if the end of file is + -- read without finding a non-blank character, then End_Error is raised. + -- Note: a blank is defined as a space or horizontal tab (RM A.10.6(5)). + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char : Character; + Loaded : out Boolean); + -- If next character is Char, loads it, otherwise no characters are loaded + -- Loaded is set to indicate whether or not the character was found. + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char : Character); + -- Same as above, but no indication if character is loaded + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char1 : Character; + Char2 : Character; + Loaded : out Boolean); + -- If next character is Char1 or Char2, loads it, otherwise no characters + -- are loaded. Loaded is set to indicate whether or not one of the two + -- characters was found. + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char1 : Character; + Char2 : Character); + -- Same as above, but no indication if character is loaded + + procedure Load_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Loaded : out Boolean); + -- Loads a sequence of zero or more decimal digits. Loaded is set if + -- at least one digit is loaded. + + procedure Load_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer); + -- Same as above, but no indication if character is loaded + + procedure Load_Extended_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Loaded : out Boolean); + -- Like Load_Digits, but also allows extended digits a-f and A-F + + procedure Load_Extended_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer); + -- Same as above, but no indication if character is loaded + + function Nextc (File : File_Type) return Integer; + -- Like Getc, but includes a call to Ungetc, so that the file + -- pointer is not moved by the call. + + procedure Put_Item (File : File_Type; Str : String); + -- This routine is like Text_IO.Put, except that it checks for overflow + -- of bounded lines, as described in (RM A.10.6(8)). It is used for + -- all output of numeric values and of enumeration values. + + procedure Store_Char + (File : File_Type; + ch : Integer; + Buf : in out String; + Ptr : in out Integer); + -- Store a single character in buffer, checking for overflow and + -- adjusting the column number in the file to reflect the fact + -- that a character has been acquired from the input stream. If + -- the character will not fit in the buffer it is stored in the + -- last character position of the buffer and Ptr is unchanged. + -- No exception is raised in this case, it is the caller's job + -- to raise Data_Error if the buffer fills up, so typically the + -- caller will make the buffer one character longer than needed. + + procedure String_Skip (Str : String; Ptr : out Integer); + -- Used in the Get from string procedures to skip leading blanks in the + -- string. Ptr is set to the index of the first non-blank. If the string + -- is all blanks, then the exception End_Error is raised, Note that blank + -- is defined as a space or horizontal tab (RM A.10.6(5)). + + procedure Ungetc (ch : Integer; File : File_Type); + -- Pushes back character into stream, using ungetc. The caller has + -- checked that the file is in read status. Device_Error is raised + -- if the character cannot be pushed back. An attempt to push back + -- an end of file (EOF) is ignored. + +private + pragma Inline (Is_Blank); + +end Ada.Text_IO.Generic_Aux; diff --git a/gcc/ada/a-tigeli.adb b/gcc/ada/a-tigeli.adb new file mode 100644 index 000000000..c23cd3478 --- /dev/null +++ b/gcc/ada/a-tigeli.adb @@ -0,0 +1,227 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . G E T _ L I N E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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. -- +-- -- +------------------------------------------------------------------------------ + +-- The implementation of Ada.Text_IO.Get_Line is split into a subunit so that +-- different implementations can be used on different systems. This is the +-- standard implementation (it uses low level features not suitable for use +-- in the JVM or .NET implementations). + +with System; use System; +with System.Storage_Elements; use System.Storage_Elements; + +separate (Ada.Text_IO) +procedure Get_Line + (File : File_Type; + Item : out String; + Last : out Natural) +is + Chunk_Size : constant := 80; + -- We read into a fixed size auxiliary buffer. Because this buffer + -- needs to be pre-initialized, there is a trade-off between size and + -- speed. Experiments find returns are diminishing after 50 and this + -- size allows most lines to be processed with a single read. + + ch : int; + N : Natural; + + procedure memcpy (s1, s2 : chars; n : size_t); + pragma Import (C, memcpy); + + function memchr (s : chars; ch : int; n : size_t) return chars; + pragma Import (C, memchr); + + procedure memset (b : chars; ch : int; n : size_t); + pragma Import (C, memset); + + function Get_Chunk (N : Positive) return Natural; + -- Reads at most N - 1 characters into Item (Last + 1 .. Item'Last), + -- updating Last. Raises End_Error if nothing was read (End_Of_File). + -- Returns number of characters still to read (either 0 or 1) in + -- case of success. + + --------------- + -- Get_Chunk -- + --------------- + + function Get_Chunk (N : Positive) return Natural is + Buf : String (1 .. Chunk_Size); + S : constant chars := Buf (1)'Address; + P : chars; + + begin + if N = 1 then + return N; + end if; + + memset (S, 10, size_t (N)); + + if fgets (S, N, File.Stream) = Null_Address then + if ferror (File.Stream) /= 0 then + raise Device_Error; + + -- If incomplete last line, pretend we found a LM + + elsif Last >= Item'First then + return 0; + + else + raise End_Error; + end if; + end if; + + P := memchr (S, LM, size_t (N)); + + -- If no LM is found, the buffer got filled without reading a new + -- line. Otherwise, the LM is either one from the input, or else one + -- from the initialization, which means an incomplete end-of-line was + -- encountered. Only in first case the LM will be followed by a 0. + + if P = Null_Address then + pragma Assert (Buf (N) = ASCII.NUL); + memcpy (Item (Last + 1)'Address, + Buf (1)'Address, size_t (N - 1)); + Last := Last + N - 1; + + return 1; + + else + -- P points to the LM character. Set K so Buf (K) is the character + -- right before. + + declare + K : Natural := Natural (P - S); + + begin + -- Now Buf (K + 2) should be 0, or otherwise Buf (K) is the 0 + -- put in by fgets, so compensate. + + if K + 2 > Buf'Last or else Buf (K + 2) /= ASCII.NUL then + + -- Incomplete last line, so remove the extra 0 + + pragma Assert (Buf (K) = ASCII.NUL); + K := K - 1; + end if; + + memcpy (Item (Last + 1)'Address, + Buf (1)'Address, size_t (K)); + Last := Last + K; + end; + + return 0; + end if; + end Get_Chunk; + +-- Start of processing for Get_Line + +begin + FIO.Check_Read_Status (AP (File)); + + -- Immediate exit for null string, this is a case in which we do not + -- need to test for end of file and we do not skip a line mark under + -- any circumstances. + + if Item'First > Item'Last then + return; + end if; + + N := Item'Last - Item'First + 1; + + Last := Item'First - 1; + + -- Here we have at least one character, if we are immediately before + -- a line mark, then we will just skip past it storing no characters. + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + + -- Otherwise we need to read some characters + + else + while N >= Chunk_Size loop + if Get_Chunk (Chunk_Size) = 0 then + N := 0; + else + N := N - Chunk_Size + 1; + end if; + end loop; + + if N > 1 then + N := Get_Chunk (N); + end if; + + -- Almost there, only a little bit more to read + + if N = 1 then + ch := Getc (File); + + -- If we get EOF after already reading data, this is an incomplete + -- last line, in which case no End_Error should be raised. + + if ch = EOF and then Last < Item'First then + raise End_Error; + + elsif ch /= LM then + + -- Buffer really is full without having seen LM, update col + + Last := Last + 1; + Item (Last) := Character'Val (ch); + File.Col := File.Col + Count (Last - Item'First + 1); + return; + end if; + end if; + end if; + + -- We have skipped past, but not stored, a line mark. Skip following + -- page mark if one follows, but do not do this for a non-regular file + -- (since otherwise we get annoying wait for an extra character) + + File.Line := File.Line + 1; + File.Col := 1; + + if File.Before_LM_PM then + File.Line := 1; + File.Before_LM_PM := False; + File.Page := File.Page + 1; + + elsif File.Is_Regular_File then + ch := Getc (File); + + if ch = PM and then File.Is_Regular_File then + File.Line := 1; + File.Page := File.Page + 1; + else + Ungetc (ch, File); + end if; + end if; +end Get_Line; diff --git a/gcc/ada/a-tiinau.adb b/gcc/ada/a-tiinau.adb new file mode 100644 index 000000000..58ba09182 --- /dev/null +++ b/gcc/ada/a-tiinau.adb @@ -0,0 +1,296 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 (note : is ok replacement for #) + + 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 new file mode 100644 index 000000000..ee2ca23e6 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..f477dbf77 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..9d659f33e --- /dev/null +++ b/gcc/ada/a-tiinio.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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.Text_IO_Kludge 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 new file mode 100644 index 000000000..7b204c85d --- /dev/null +++ b/gcc/ada/a-timoau.adb @@ -0,0 +1,301 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 + 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 new file mode 100644 index 000000000..200184f25 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..b000cd517 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..90b84fffb --- /dev/null +++ b/gcc/ada/a-timoio.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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.Text_IO_Kludge 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 new file mode 100644 index 000000000..3015f31a0 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 new file mode 100644 index 000000000..bb6c5b118 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100755 index 000000000..791c066ba --- /dev/null +++ b/gcc/ada/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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100755 index 000000000..b3d4ab0af --- /dev/null +++ b/gcc/ada/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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..3b8f9ce6d --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.File_IO; + +package body Ada.Text_IO.Text_Streams is + + ------------ + -- Stream -- + ------------ + + function Stream (File : File_Type) return Stream_Access is + begin + System.File_IO.Check_File_Open (FCB.AFCB_Ptr (File)); + return Stream_Access (File); + end Stream; + +end Ada.Text_IO.Text_Streams; diff --git a/gcc/ada/a-titest.ads b/gcc/ada/a-titest.ads new file mode 100644 index 000000000..93cf47aad --- /dev/null +++ b/gcc/ada/a-titest.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . T E X T _ S T R E A M S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Streams; +package Ada.Text_IO.Text_Streams is + + type Stream_Access is access all Streams.Root_Stream_Type'Class; + + function Stream (File : File_Type) return Stream_Access; + +end Ada.Text_IO.Text_Streams; diff --git a/gcc/ada/a-tiunio.ads b/gcc/ada/a-tiunio.ads new file mode 100644 index 000000000..ea5caecf5 --- /dev/null +++ b/gcc/ada/a-tiunio.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . U N B O U N D E D _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: historically GNAT provided these subprograms as a child of the +-- package Ada.Strings.Unbounded. So we implement this new Ada 2005 package +-- by renaming the subprograms in that child. This is a more straightforward +-- implementation anyway, since we need access to the internal representation +-- of Ada.Strings.Unbounded.Unbounded_String. + +with Ada.Strings.Unbounded; +with Ada.Strings.Unbounded.Text_IO; + +package Ada.Text_IO.Unbounded_IO is + + procedure Put + (File : File_Type; + Item : Strings.Unbounded.Unbounded_String) + renames Ada.Strings.Unbounded.Text_IO.Put; + + procedure Put + (Item : Strings.Unbounded.Unbounded_String) + renames Ada.Strings.Unbounded.Text_IO.Put; + + procedure Put_Line + (File : Text_IO.File_Type; + Item : Strings.Unbounded.Unbounded_String) + renames Ada.Strings.Unbounded.Text_IO.Put_Line; + + procedure Put_Line + (Item : Strings.Unbounded.Unbounded_String) + renames Ada.Strings.Unbounded.Text_IO.Put_Line; + + function Get_Line + (File : File_Type) return Strings.Unbounded.Unbounded_String + renames Ada.Strings.Unbounded.Text_IO.Get_Line; + + function Get_Line return Strings.Unbounded.Unbounded_String + renames Ada.Strings.Unbounded.Text_IO.Get_Line; + + procedure Get_Line + (File : File_Type; + Item : out Strings.Unbounded.Unbounded_String) + renames Ada.Strings.Unbounded.Text_IO.Get_Line; + + procedure Get_Line + (Item : out Strings.Unbounded.Unbounded_String) + renames Ada.Strings.Unbounded.Text_IO.Get_Line; + +end Ada.Text_IO.Unbounded_IO; diff --git a/gcc/ada/a-unccon.ads b/gcc/ada/a-unccon.ads new file mode 100644 index 000000000..ffa84d9fa --- /dev/null +++ b/gcc/ada/a-unccon.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A D A . U N C H E C K E D _ C O N V E R S I O N -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Source (<>) is limited private; + type Target (<>) is limited private; + +function Ada.Unchecked_Conversion (S : Source) return Target; + +pragma Pure (Unchecked_Conversion); +pragma Import (Intrinsic, Unchecked_Conversion); diff --git a/gcc/ada/a-uncdea.ads b/gcc/ada/a-uncdea.ads new file mode 100644 index 000000000..d566b4b34 --- /dev/null +++ b/gcc/ada/a-uncdea.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A D A . U N C H E C K E D _ D E A L L O C A T I O N -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Object (<>) is limited private; + type Name is access Object; + +procedure Ada.Unchecked_Deallocation (X : in out Name); +pragma Preelaborate (Unchecked_Deallocation); + +pragma Import (Intrinsic, Unchecked_Deallocation); diff --git a/gcc/ada/a-wichha.adb b/gcc/ada/a-wichha.adb new file mode 100755 index 000000000..2dad375a4 --- /dev/null +++ b/gcc/ada/a-wichha.adb @@ -0,0 +1,186 @@ +------------------------------------------------------------------------------ +-- -- +-- 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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 + + --------------------- + -- 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 -- + -------------- + + function Is_Other (Item : Wide_Character) return Boolean + renames Ada.Wide_Characters.Unicode.Is_Other; + + -------------------- + -- Is_Punctuation -- + -------------------- + + function Is_Punctuation (Item : Wide_Character) return Boolean + renames Ada.Wide_Characters.Unicode.Is_Punctuation; + + -------------- + -- Is_Space -- + -------------- + + function Is_Space (Item : Wide_Character) return Boolean + renames Ada.Wide_Characters.Unicode.Is_Space; + + ---------------- + -- Is_Special -- + ---------------- + + function Is_Special (Item : Wide_Character) return Boolean is + begin + return Is_Graphic (Item) and then not Is_Alphanumeric (Item); + end Is_Special; + + -------------- + -- Is_Upper -- + -------------- + + function Is_Upper (Item : Wide_Character) return Boolean is + begin + return Get_Category (Item) = Lu; + end Is_Upper; + + -------------- + -- To_Lower -- + -------------- + + function To_Lower (Item : Wide_Character) return Wide_Character + renames Ada.Wide_Characters.Unicode.To_Lower_Case; + + function To_Lower (Item : Wide_String) return Wide_String is + Result : Wide_String (Item'Range); + + begin + for J in Result'Range loop + Result (J) := To_Lower (Item (J)); + end loop; + + return Result; + end To_Lower; + + -------------- + -- To_Upper -- + -------------- + + function To_Upper (Item : Wide_Character) return Wide_Character + renames Ada.Wide_Characters.Unicode.To_Upper_Case; + + function To_Upper (Item : Wide_String) return Wide_String is + Result : Wide_String (Item'Range); + + begin + for J in Result'Range loop + Result (J) := To_Upper (Item (J)); + end loop; + + return Result; + end To_Upper; + +end Ada.Wide_Characters.Handling; diff --git a/gcc/ada/a-wichha.ads b/gcc/ada/a-wichha.ads new file mode 100755 index 000000000..50c3ff8ed --- /dev/null +++ b/gcc/ada/a-wichha.ads @@ -0,0 +1,120 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ C H A R A C T E R S . H A N D L I N G -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Wide_Characters.Handling is + + function Is_Control (Item : Wide_Character) return Boolean; + pragma Inline (Is_Control); + -- Returns True if the Wide_Character designated by Item is categorized as + -- other_control, otherwise returns false. + + function Is_Letter (Item : Wide_Character) return Boolean; + pragma Inline (Is_Letter); + -- Returns True if the Wide_Character designated by Item is categorized as + -- letter_uppercase, letter_lowercase, letter_titlecase, letter_modifier, + -- letter_other, or number_letter. Otherwise returns false. + + function Is_Lower (Item : Wide_Character) return Boolean; + pragma Inline (Is_Lower); + -- Returns True if the Wide_Character designated by Item is categorized as + -- letter_lowercase, otherwise returns false. + + function Is_Upper (Item : Wide_Character) return Boolean; + pragma Inline (Is_Upper); + -- Returns True if the Wide_Character designated by Item is categorized as + -- letter_uppercase, otherwise returns false. + + function Is_Digit (Item : Wide_Character) return Boolean; + pragma Inline (Is_Digit); + -- Returns True if the Wide_Character designated by Item is categorized as + -- number_decimal, otherwise returns false. + + function Is_Decimal_Digit (Item : Wide_Character) return Boolean + renames Is_Digit; + + function Is_Hexadecimal_Digit (Item : Wide_Character) return Boolean; + -- Returns True if the Wide_Character designated by Item is categorized as + -- number_decimal, or is in the range 'A' .. 'F' or 'a' .. 'f', otherwise + -- returns false. + + function Is_Alphanumeric (Item : Wide_Character) return Boolean; + pragma Inline (Is_Alphanumeric); + -- Returns True if the Wide_Character designated by Item is categorized as + -- number_decimal, or is in the range 'A' .. 'F' or 'a' .. 'f', otherwise + -- returns false. + + function Is_Special (Item : Wide_Character) return Boolean; + pragma Inline (Is_Special); + -- Returns True if the Wide_Character designated by Item is categorized + -- as graphic_character, but not categorized as letter_uppercase, + -- letter_lowercase, letter_titlecase, letter_modifier, letter_other, + -- number_letter, or number_decimal. Otherwise returns false. + + function Is_Line_Terminator (Item : Wide_Character) return Boolean; + pragma Inline (Is_Line_Terminator); + -- Returns True if the Wide_Character designated by Item is categorized as + -- separator_line or separator_paragraph, or if Item is a conventional line + -- terminator character (CR, LF, VT, or FF). Otherwise returns false. + + function Is_Mark (Item : Wide_Character) return Boolean; + pragma Inline (Is_Mark); + -- Returns True if the Wide_Character designated by Item is categorized as + -- mark_non_spacing or mark_spacing_combining, otherwise returns false. + + function Is_Other (Item : Wide_Character) return Boolean; + pragma Inline (Is_Other); + -- Returns True if the Wide_Character designated by Item is categorized as + -- other_format, otherwise returns false. + + function Is_Punctuation (Item : Wide_Character) return Boolean; + pragma Inline (Is_Punctuation); + -- Returns True if the Wide_Character designated by Item is categorized as + -- punctuation_connector, otherwise returns false. + + function Is_Space (Item : Wide_Character) return Boolean; + pragma Inline (Is_Space); + -- Returns True if the Wide_Character designated by Item is categorized as + -- separator_space, otherwise returns false. + + function Is_Graphic (Item : Wide_Character) return Boolean; + pragma Inline (Is_Graphic); + -- Returns True if the Wide_Character designated by Item is categorized as + -- graphic_character, otherwise returns false. + + function To_Lower (Item : Wide_Character) return Wide_Character; + pragma Inline (To_Lower); + -- Returns the Simple Lowercase Mapping of the Wide_Character designated by + -- Item. If the Simple Lowercase Mapping does not exist for the + -- Wide_Character designated by Item, then the value of Item is returned. + + function To_Lower (Item : Wide_String) return Wide_String; + -- Returns the result of applying the To_Lower Wide_Character to + -- Wide_Character conversion to each element of the Wide_String designated + -- by Item. The result is the null Wide_String if the value of the formal + -- parameter is the null Wide_String. + + function To_Upper (Item : Wide_Character) return Wide_Character; + pragma Inline (To_Upper); + -- Returns the Simple Uppercase Mapping of the Wide_Character designated by + -- Item. If the Simple Uppercase Mapping does not exist for the + -- Wide_Character designated by Item, then the value of Item is returned. + + function To_Upper (Item : Wide_String) return Wide_String; + -- Returns the result of applying the To_Upper Wide_Character to + -- Wide_Character conversion to each element of the Wide_String designated + -- by Item. The result is the null Wide_String if the value of the formal + -- parameter is the null Wide_String. + +end Ada.Wide_Characters.Handling; diff --git a/gcc/ada/a-wichun.adb b/gcc/ada/a-wichun.adb new file mode 100644 index 000000000..b36d4a435 --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..08ac83d6f --- /dev/null +++ b/gcc/ada/a-wichun.ads @@ -0,0 +1,196 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 + + -- The following type defines the categories from the unicode definitions. + -- The one addition we make is Fe, which represents the characters FFFE + -- and FFFF in any of the planes. + + type Category is new System.UTF_32.Category; + -- Cc Other, Control + -- Cf Other, Format + -- Cn Other, Not Assigned + -- Co Other, Private Use + -- Cs Other, Surrogate + -- Ll Letter, Lowercase + -- Lm Letter, Modifier + -- Lo Letter, Other + -- Lt Letter, Titlecase + -- Lu Letter, Uppercase + -- Mc Mark, Spacing Combining + -- Me Mark, Enclosing + -- Mn Mark, Nonspacing + -- Nd Number, Decimal Digit + -- Nl Number, Letter + -- No Number, Other + -- Pc Punctuation, Connector + -- Pd Punctuation, Dash + -- Pe Punctuation, Close + -- Pf Punctuation, Final quote + -- Pi Punctuation, Initial quote + -- Po Punctuation, Other + -- Ps Punctuation, Open + -- Sc Symbol, Currency + -- Sk Symbol, Modifier + -- Sm Symbol, Math + -- So Symbol, Other + -- Zl Separator, Line + -- Zp Separator, Paragraph + -- Zs Separator, Space + -- Fe relative position FFFE/FFFF in plane + + function Get_Category (U : Wide_Character) return Category; + pragma Inline (Get_Category); + -- Given a Wide_Character, returns corresponding Category, or Cn if the + -- code does not have an assigned unicode category. + + -- The following functions perform category tests corresponding to lexical + -- classes defined in the Ada standard. There are two interfaces for each + -- function. The second takes a Category (e.g. returned by Get_Category). + -- The first takes a Wide_Character. The form taking the Wide_Character is + -- typically more efficient than calling Get_Category, but if several + -- different tests are to be performed on the same code, it is more + -- efficient to use Get_Category to get the category, then test the + -- resulting category. + + function Is_Letter (U : Wide_Character) return Boolean; + function Is_Letter (C : Category) return Boolean; + pragma Inline (Is_Letter); + -- Returns true iff U is a letter that can be used to start an identifier, + -- or if C is one of the corresponding categories, which are the following: + -- Letter, Uppercase (Lu) + -- Letter, Lowercase (Ll) + -- Letter, Titlecase (Lt) + -- Letter, Modifier (Lm) + -- Letter, Other (Lo) + -- Number, Letter (Nl) + + function Is_Digit (U : Wide_Character) return Boolean; + function Is_Digit (C : Category) return Boolean; + pragma Inline (Is_Digit); + -- Returns true iff U is a digit that can be used to extend an identifer, + -- or if C is one of the corresponding categories, which are the following: + -- Number, Decimal_Digit (Nd) + + function Is_Line_Terminator (U : Wide_Character) return Boolean; + pragma Inline (Is_Line_Terminator); + -- Returns true iff U is an allowed line terminator for source programs, + -- if U is in the category Zp (Separator, Paragaph), or Zs (Separator, + -- Line), or if U is a conventional line terminator (CR, LF, VT, FF). + -- There is no category version for this function, since the set of + -- characters does not correspond to a set of Unicode categories. + + function Is_Mark (U : Wide_Character) return Boolean; + function Is_Mark (C : Category) return Boolean; + pragma Inline (Is_Mark); + -- Returns true iff U is a mark character which can be used to extend an + -- identifier, or if C is one of the corresponding categories, which are + -- the following: + -- Mark, Non-Spacing (Mn) + -- Mark, Spacing Combining (Mc) + + function Is_Other (U : Wide_Character) return Boolean; + function Is_Other (C : Category) return Boolean; + pragma Inline (Is_Other); + -- Returns true iff U is an other format character, which means that it + -- can be used to extend an identifier, but is ignored for the purposes of + -- matching of identiers, or if C is one of the corresponding categories, + -- which are the following: + -- Other, Format (Cf) + + function Is_Punctuation (U : Wide_Character) return Boolean; + function Is_Punctuation (C : Category) return Boolean; + pragma Inline (Is_Punctuation); + -- Returns true iff U is a punctuation character that can be used to + -- separate pices of an identifier, or if C is one of the corresponding + -- categories, which are the following: + -- Punctuation, Connector (Pc) + + function Is_Space (U : Wide_Character) return Boolean; + function Is_Space (C : Category) return Boolean; + pragma Inline (Is_Space); + -- Returns true iff U is considered a space to be ignored, or if C is one + -- of the corresponding categories, which are the following: + -- Separator, Space (Zs) + + function Is_Non_Graphic (U : Wide_Character) return Boolean; + function Is_Non_Graphic (C : Category) return Boolean; + pragma Inline (Is_Non_Graphic); + -- Returns true iff U is considered to be a non-graphic character, or if C + -- is one of the corresponding categories, which are the following: + -- Other, Control (Cc) + -- Other, Private Use (Co) + -- Other, Surrogate (Cs) + -- Separator, Line (Zl) + -- Separator, Paragraph (Zp) + -- FFFE or FFFF positions in any plane (Fe) + -- + -- Note that the Ada category format effector is subsumed by the above + -- list of Unicode categories. + -- + -- Note that Other, Unassiged (Cn) is quite deliberately not included + -- in the list of categories above. This means that should any of these + -- code positions be defined in future with graphic characters they will + -- be allowed without a need to change implementations or the standard. + -- + -- Note that Other, Format (Cf) is also quite deliberately not included + -- in the list of categories above. This means that these characters can + -- be included in character and string literals. + + -- The following function is used to fold to upper case, as required by + -- the Ada 2005 standard rules for identifier case folding. Two + -- identifiers are equivalent if they are identical after folding all + -- letters to upper case using this routine. A corresponding function to + -- fold to lower case is also provided. + + function To_Lower_Case (U : Wide_Character) return Wide_Character; + pragma Inline (To_Lower_Case); + -- If U represents an upper case letter, returns the corresponding lower + -- case letter, otherwise U is returned unchanged. The folding is locale + -- independent as defined by documents referenced in the note in section + -- 1 of ISO/IEC 10646:2003 + + function To_Upper_Case (U : Wide_Character) return Wide_Character; + pragma Inline (To_Upper_Case); + -- If U represents a lower case letter, returns the corresponding upper + -- case letter, otherwise U is returned unchanged. The folding is locale + -- independent as defined by documents referenced in the note in section + -- 1 of ISO/IEC 10646:2003 + +end Ada.Wide_Characters.Unicode; diff --git a/gcc/ada/a-widcha.ads b/gcc/ada/a-widcha.ads new file mode 100644 index 000000000..a5dde73f4 --- /dev/null +++ b/gcc/ada/a-widcha.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ C H A R A C T E R S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: strictly this is an Ada 2005 package, but we make it freely +-- available in Ada 95 mode, since it deals only with wide characters. + +package Ada.Wide_Characters is + pragma Pure; +end Ada.Wide_Characters; diff --git a/gcc/ada/a-witeio.adb b/gcc/ada/a-witeio.adb new file mode 100644 index 000000000..efd502184 --- /dev/null +++ b/gcc/ada/a-witeio.adb @@ -0,0 +1,1940 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X 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.Streams; use Ada.Streams; +with Interfaces.C_Streams; use Interfaces.C_Streams; + +with System.CRTL; +with System.File_IO; +with System.WCh_Cnv; use System.WCh_Cnv; +with System.WCh_Con; use System.WCh_Con; + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +pragma Elaborate_All (System.File_IO); +-- Needed because of calls to Chain_File in package body elaboration + +package body Ada.Wide_Text_IO is + + package FIO renames System.File_IO; + + subtype AP is FCB.AFCB_Ptr; + + function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); + function To_TIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode); + use type FCB.File_Mode; + + use type System.CRTL.size_t; + + WC_Encoding : Character; + pragma Import (C, WC_Encoding, "__gl_wc_encoding"); + -- Default wide character encoding + + Err_Name : aliased String := "*stderr" & ASCII.NUL; + In_Name : aliased String := "*stdin" & ASCII.NUL; + Out_Name : aliased String := "*stdout" & ASCII.NUL; + -- Names of standard files + -- + -- Use "preallocated" strings to avoid calling "new" during the elaboration + -- of the run time. This is needed in the tasking case to avoid calling + -- Task_Lock too early. A filename is expected to end with a null character + -- in the runtime, here the null characters are added just to have a + -- correct filename length. + -- + -- Note: the names for these files are bogus, and probably it would be + -- better for these files to have no names, but the ACVC tests insist! + -- We use names that are bound to fail in open etc. + + Null_Str : aliased constant String := ""; + -- Used as form string for standard files + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Get_Wide_Char_Immed + (C : Character; + File : File_Type) return Wide_Character; + -- This routine is identical to Get_Wide_Char, except that the reads are + -- done in Get_Immediate mode (i.e. without waiting for a line return). + + function Getc_Immed (File : File_Type) return int; + -- This routine is identical to Getc, except that the read is done in + -- Get_Immediate mode (i.e. without waiting for a line return). + + procedure Putc (ch : int; File : File_Type); + -- Outputs the given character to the file, which has already been checked + -- for being in output status. Device_Error is raised if the character + -- cannot be written. + + procedure Set_WCEM (File : in out File_Type); + -- Called by Open and Create to set the wide character encoding method for + -- the file, processing a WCEM form parameter if one is present. File is + -- IN OUT because it may be closed in case of an error. + + procedure Terminate_Line (File : File_Type); + -- If the file is in Write_File or Append_File mode, and the current line + -- is not terminated, then a line terminator is written using New_Line. + -- Note that there is no Terminate_Page routine, because the page mark at + -- the end of the file is implied if necessary. + + procedure Ungetc (ch : int; File : File_Type); + -- Pushes back character into stream, using ungetc. The caller has checked + -- that the file is in read status. Device_Error is raised if the character + -- cannot be pushed back. An attempt to push back and end of file character + -- (EOF) is ignored. + + ------------------- + -- AFCB_Allocate -- + ------------------- + + function AFCB_Allocate + (Control_Block : Wide_Text_AFCB) return FCB.AFCB_Ptr + is + pragma Unreferenced (Control_Block); + begin + return new Wide_Text_AFCB; + end AFCB_Allocate; + + ---------------- + -- AFCB_Close -- + ---------------- + + procedure AFCB_Close (File : not null access Wide_Text_AFCB) is + begin + -- If the file being closed is one of the current files, then close + -- the corresponding current file. It is not clear that this action + -- is required (RM A.10.3(23)) but it seems reasonable, and besides + -- ACVC test CE3208A expects this behavior. + + if File_Type (File) = Current_In then + Current_In := null; + elsif File_Type (File) = Current_Out then + Current_Out := null; + elsif File_Type (File) = Current_Err then + Current_Err := null; + end if; + + Terminate_Line (File_Type (File)); + end AFCB_Close; + + --------------- + -- AFCB_Free -- + --------------- + + procedure AFCB_Free (File : not null access Wide_Text_AFCB) is + type FCB_Ptr is access all Wide_Text_AFCB; + FT : FCB_Ptr := FCB_Ptr (File); + + procedure Free is + new Ada.Unchecked_Deallocation (Wide_Text_AFCB, FCB_Ptr); + + begin + Free (FT); + end AFCB_Free; + + ----------- + -- Close -- + ----------- + + procedure Close (File : in out File_Type) is + begin + FIO.Close (AP (File)'Unrestricted_Access); + end Close; + + --------- + -- Col -- + --------- + + -- Note: we assume that it is impossible in practice for the column + -- to exceed the value of Count'Last, i.e. no check is required for + -- overflow raising layout error. + + function Col (File : File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return File.Col; + end Col; + + function Col return Positive_Count is + begin + return Col (Current_Out); + end Col; + + ------------ + -- Create -- + ------------ + + procedure Create + (File : in out File_Type; + Mode : File_Mode := Out_File; + Name : String := ""; + Form : String := "") + is + Dummy_File_Control_Block : Wide_Text_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'W', + Creat => True, + Text => True); + + File.Self := File; + Set_WCEM (File); + end Create; + + ------------------- + -- Current_Error -- + ------------------- + + function Current_Error return File_Type is + begin + return Current_Err; + end Current_Error; + + function Current_Error return File_Access is + begin + return Current_Err.Self'Access; + end Current_Error; + + ------------------- + -- Current_Input -- + ------------------- + + function Current_Input return File_Type is + begin + return Current_In; + end Current_Input; + + function Current_Input return File_Access is + begin + return Current_In.Self'Access; + end Current_Input; + + -------------------- + -- Current_Output -- + -------------------- + + function Current_Output return File_Type is + begin + return Current_Out; + end Current_Output; + + function Current_Output return File_Access is + begin + return Current_Out.Self'Access; + end Current_Output; + + ------------ + -- Delete -- + ------------ + + procedure Delete (File : in out File_Type) is + begin + FIO.Delete (AP (File)'Unrestricted_Access); + end Delete; + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File (File : File_Type) return Boolean is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Wide_Character then + return False; + + elsif File.Before_LM then + if File.Before_LM_PM then + return Nextc (File) = EOF; + end if; + + else + ch := Getc (File); + + if ch = EOF then + return True; + + elsif ch /= LM then + Ungetc (ch, File); + return False; + + else -- ch = LM + File.Before_LM := True; + end if; + end if; + + -- Here we are just past the line mark with Before_LM set so that we + -- do not have to try to back up past the LM, thus avoiding the need + -- to back up more than one character. + + ch := Getc (File); + + if ch = EOF then + return True; + + elsif ch = PM and then File.Is_Regular_File then + File.Before_LM_PM := True; + return Nextc (File) = EOF; + + -- Here if neither EOF nor PM followed end of line + + else + Ungetc (ch, File); + return False; + end if; + + end End_Of_File; + + function End_Of_File return Boolean is + begin + return End_Of_File (Current_In); + end End_Of_File; + + ----------------- + -- End_Of_Line -- + ----------------- + + function End_Of_Line (File : File_Type) return Boolean is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Wide_Character then + return False; + + elsif File.Before_LM then + return True; + + else + ch := Getc (File); + + if ch = EOF then + return True; + + else + Ungetc (ch, File); + return (ch = LM); + end if; + end if; + end End_Of_Line; + + function End_Of_Line return Boolean is + begin + return End_Of_Line (Current_In); + end End_Of_Line; + + ----------------- + -- End_Of_Page -- + ----------------- + + function End_Of_Page (File : File_Type) return Boolean is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if not File.Is_Regular_File then + return False; + + elsif File.Before_Wide_Character then + return False; + + elsif File.Before_LM then + if File.Before_LM_PM then + return True; + end if; + + else + ch := Getc (File); + + if ch = EOF then + return True; + + elsif ch /= LM then + Ungetc (ch, File); + return False; + + else -- ch = LM + File.Before_LM := True; + end if; + end if; + + -- Here we are just past the line mark with Before_LM set so that we + -- do not have to try to back up past the LM, thus avoiding the need + -- to back up more than one character. + + ch := Nextc (File); + + return ch = PM or else ch = EOF; + end End_Of_Page; + + function End_Of_Page return Boolean is + begin + return End_Of_Page (Current_In); + end End_Of_Page; + + ----------- + -- Flush -- + ----------- + + procedure Flush (File : File_Type) is + begin + FIO.Flush (AP (File)); + end Flush; + + procedure Flush is + begin + Flush (Current_Out); + end Flush; + + ---------- + -- Form -- + ---------- + + function Form (File : File_Type) return String is + begin + return FIO.Form (AP (File)); + end Form; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Wide_Character) + is + C : Character; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Wide_Character then + File.Before_Wide_Character := False; + Item := File.Saved_Wide_Character; + + -- Ada.Text_IO checks Before_LM_PM here, shouldn't we do the same??? + + else + Get_Character (File, C); + Item := Get_Wide_Char (C, File); + end if; + end Get; + + procedure Get (Item : out Wide_Character) is + begin + Get (Current_In, Item); + end Get; + + procedure Get + (File : File_Type; + Item : out Wide_String) + is + begin + for J in Item'Range loop + Get (File, Item (J)); + end loop; + end Get; + + procedure Get (Item : out Wide_String) is + begin + Get (Current_In, Item); + end Get; + + ------------------- + -- Get_Character -- + ------------------- + + procedure Get_Character + (File : File_Type; + Item : out Character) + is + ch : int; + + begin + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + File.Col := 1; + + if File.Before_LM_PM then + File.Line := 1; + File.Page := File.Page + 1; + File.Before_LM_PM := False; + + else + File.Line := File.Line + 1; + end if; + end if; + + loop + ch := Getc (File); + + if ch = EOF then + raise End_Error; + + elsif ch = LM then + File.Line := File.Line + 1; + File.Col := 1; + + elsif ch = PM and then File.Is_Regular_File then + File.Page := File.Page + 1; + File.Line := 1; + + else + Item := Character'Val (ch); + File.Col := File.Col + 1; + return; + end if; + end loop; + end Get_Character; + + ------------------- + -- Get_Immediate -- + ------------------- + + procedure Get_Immediate + (File : File_Type; + Item : out Wide_Character) + is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Wide_Character then + File.Before_Wide_Character := False; + Item := File.Saved_Wide_Character; + + elsif File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + Item := Wide_Character'Val (LM); + + else + ch := Getc_Immed (File); + + if ch = EOF then + raise End_Error; + else + Item := Get_Wide_Char_Immed (Character'Val (ch), File); + end if; + end if; + end Get_Immediate; + + procedure Get_Immediate + (Item : out Wide_Character) + is + begin + Get_Immediate (Current_In, Item); + end Get_Immediate; + + procedure Get_Immediate + (File : File_Type; + Item : out Wide_Character; + Available : out Boolean) + is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + Available := True; + + if File.Before_Wide_Character then + File.Before_Wide_Character := False; + Item := File.Saved_Wide_Character; + + elsif File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + Item := Wide_Character'Val (LM); + + else + -- Shouldn't we use getc_immediate_nowait here, like Text_IO??? + + ch := Getc_Immed (File); + + if ch = EOF then + raise End_Error; + else + Item := Get_Wide_Char_Immed (Character'Val (ch), File); + end if; + end if; + end Get_Immediate; + + procedure Get_Immediate + (Item : out Wide_Character; + Available : out Boolean) + is + begin + Get_Immediate (Current_In, Item, Available); + end Get_Immediate; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line + (File : File_Type; + Item : out Wide_String; + Last : out Natural) + is + begin + FIO.Check_Read_Status (AP (File)); + Last := Item'First - 1; + + -- Immediate exit for null string, this is a case in which we do not + -- need to test for end of file and we do not skip a line mark under + -- any circumstances. + + if Last >= Item'Last then + return; + end if; + + -- Here we have at least one character, if we are immediately before + -- a line mark, then we will just skip past it storing no characters. + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + + -- Otherwise we need to read some characters + + else + -- If we are at the end of file now, it means we are trying to + -- skip a file terminator and we raise End_Error (RM A.10.7(20)) + + if Nextc (File) = EOF then + raise End_Error; + end if; + + -- Loop through characters in string + + loop + -- Exit the loop if read is terminated by encountering line mark + -- Note that the use of Skip_Line here ensures we properly deal + -- with setting the page and line numbers. + + if End_Of_Line (File) then + Skip_Line (File); + return; + end if; + + -- Otherwise store the character, note that we know that ch is + -- something other than LM or EOF. It could possibly be a page + -- mark if there is a stray page mark in the middle of a line, + -- but this is not an official page mark in any case, since + -- official page marks can only follow a line mark. The whole + -- page business is pretty much nonsense anyway, so we do not + -- want to waste time trying to make sense out of non-standard + -- page marks in the file! This means that the behavior of + -- Get_Line is different from repeated Get of a character, but + -- that's too bad. We only promise that page numbers etc make + -- sense if the file is formatted in a standard manner. + + -- Note: we do not adjust the column number because it is quicker + -- to adjust it once at the end of the operation than incrementing + -- it each time around the loop. + + Last := Last + 1; + Get (File, Item (Last)); + + -- All done if the string is full, this is the case in which + -- we do not skip the following line mark. We need to adjust + -- the column number in this case. + + if Last = Item'Last then + File.Col := File.Col + Count (Item'Length); + return; + end if; + + -- Exit from the loop if we are at the end of file. This happens + -- if we have a last line that is not terminated with a line mark. + -- In this case we consider that there is an implied line mark; + -- this is a non-standard file, but we will treat it nicely. + + exit when Nextc (File) = EOF; + end loop; + end if; + end Get_Line; + + procedure Get_Line + (Item : out Wide_String; + Last : out Natural) + is + begin + Get_Line (Current_In, Item, Last); + end Get_Line; + + function Get_Line (File : File_Type) return Wide_String is + Buffer : Wide_String (1 .. 500); + Last : Natural; + + function Get_Rest (S : Wide_String) return Wide_String; + -- This is a recursive function that reads the rest of the line and + -- returns it. S is the part read so far. + + -------------- + -- Get_Rest -- + -------------- + + function Get_Rest (S : Wide_String) return Wide_String is + + -- Each time we allocate a buffer the same size as what we have + -- read so far. This limits us to a logarithmic number of calls + -- to Get_Rest and also ensures only a linear use of stack space. + + Buffer : Wide_String (1 .. S'Length); + Last : Natural; + + begin + Get_Line (File, Buffer, Last); + + declare + R : constant Wide_String := S & Buffer (1 .. Last); + begin + if Last < Buffer'Last then + return R; + else + return Get_Rest (R); + end if; + end; + end Get_Rest; + + -- Start of processing for Get_Line + + begin + Get_Line (File, Buffer, Last); + + if Last < Buffer'Last then + return Buffer (1 .. Last); + else + return Get_Rest (Buffer (1 .. Last)); + end if; + end Get_Line; + + function Get_Line return Wide_String is + begin + return Get_Line (Current_In); + end Get_Line; + + ------------------- + -- Get_Wide_Char -- + ------------------- + + function Get_Wide_Char + (C : Character; + File : File_Type) return Wide_Character + is + function In_Char return Character; + -- Function used to obtain additional characters it the wide character + -- sequence is more than one character long. + + function WC_In is new Char_Sequence_To_Wide_Char (In_Char); + + ------------- + -- In_Char -- + ------------- + + function In_Char return Character is + ch : constant Integer := Getc (File); + begin + if ch = EOF then + raise End_Error; + else + return Character'Val (ch); + end if; + end In_Char; + + -- Start of processing for Get_Wide_Char + + begin + FIO.Check_Read_Status (AP (File)); + return WC_In (C, File.WC_Method); + end Get_Wide_Char; + + ------------------------- + -- Get_Wide_Char_Immed -- + ------------------------- + + function Get_Wide_Char_Immed + (C : Character; + File : File_Type) return Wide_Character + is + function In_Char return Character; + -- Function used to obtain additional characters it the wide character + -- sequence is more than one character long. + + function WC_In is new Char_Sequence_To_Wide_Char (In_Char); + + ------------- + -- In_Char -- + ------------- + + function In_Char return Character is + ch : constant Integer := Getc_Immed (File); + begin + if ch = EOF then + raise End_Error; + else + return Character'Val (ch); + end if; + end In_Char; + + -- Start of processing for Get_Wide_Char_Immed + + begin + FIO.Check_Read_Status (AP (File)); + return WC_In (C, File.WC_Method); + end Get_Wide_Char_Immed; + + ---------- + -- Getc -- + ---------- + + function Getc (File : File_Type) return int is + ch : int; + + begin + ch := fgetc (File.Stream); + + if ch = EOF and then ferror (File.Stream) /= 0 then + raise Device_Error; + else + return ch; + end if; + end Getc; + + ---------------- + -- Getc_Immed -- + ---------------- + + function Getc_Immed (File : File_Type) return int is + ch : int; + end_of_file : int; + + procedure getc_immediate + (stream : FILEs; ch : out int; end_of_file : out int); + pragma Import (C, getc_immediate, "getc_immediate"); + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + ch := LM; + + else + getc_immediate (File.Stream, ch, end_of_file); + + if ferror (File.Stream) /= 0 then + raise Device_Error; + elsif end_of_file /= 0 then + return EOF; + end if; + end if; + + return ch; + end Getc_Immed; + + ------------------------------- + -- Initialize_Standard_Files -- + ------------------------------- + + procedure Initialize_Standard_Files is + begin + Standard_Err.Stream := stderr; + Standard_Err.Name := Err_Name'Access; + Standard_Err.Form := Null_Str'Unrestricted_Access; + Standard_Err.Mode := FCB.Out_File; + Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0; + Standard_Err.Is_Temporary_File := False; + Standard_Err.Is_System_File := True; + Standard_Err.Is_Text_File := True; + Standard_Err.Access_Method := 'T'; + Standard_Err.Self := Standard_Err; + Standard_Err.WC_Method := Default_WCEM; + + Standard_In.Stream := stdin; + Standard_In.Name := In_Name'Access; + Standard_In.Form := Null_Str'Unrestricted_Access; + Standard_In.Mode := FCB.In_File; + Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; + Standard_In.Is_Temporary_File := False; + Standard_In.Is_System_File := True; + Standard_In.Is_Text_File := True; + Standard_In.Access_Method := 'T'; + Standard_In.Self := Standard_In; + Standard_In.WC_Method := Default_WCEM; + + Standard_Out.Stream := stdout; + Standard_Out.Name := Out_Name'Access; + Standard_Out.Form := Null_Str'Unrestricted_Access; + Standard_Out.Mode := FCB.Out_File; + Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; + Standard_Out.Is_Temporary_File := False; + Standard_Out.Is_System_File := True; + Standard_Out.Is_Text_File := True; + Standard_Out.Access_Method := 'T'; + Standard_Out.Self := Standard_Out; + Standard_Out.WC_Method := Default_WCEM; + + FIO.Make_Unbuffered (AP (Standard_Out)); + FIO.Make_Unbuffered (AP (Standard_Err)); + end Initialize_Standard_Files; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (File : File_Type) return Boolean is + begin + return FIO.Is_Open (AP (File)); + end Is_Open; + + ---------- + -- Line -- + ---------- + + -- Note: we assume that it is impossible in practice for the line to exceed + -- the value of Count'Last, i.e. no check is required for overflow raising + -- layout error. + + function Line (File : File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return File.Line; + end Line; + + function Line return Positive_Count is + begin + return Line (Current_Out); + end Line; + + ----------------- + -- Line_Length -- + ----------------- + + function Line_Length (File : File_Type) return Count is + begin + FIO.Check_Write_Status (AP (File)); + return File.Line_Length; + end Line_Length; + + function Line_Length return Count is + begin + return Line_Length (Current_Out); + end Line_Length; + + ---------------- + -- Look_Ahead -- + ---------------- + + procedure Look_Ahead + (File : File_Type; + Item : out Wide_Character; + End_Of_Line : out Boolean) + is + ch : int; + + -- Start of processing for Look_Ahead + + begin + FIO.Check_Read_Status (AP (File)); + + -- If we are logically before a line mark, we can return immediately + + if File.Before_LM then + End_Of_Line := True; + Item := Wide_Character'Val (0); + + -- If we are before a wide character, just return it (this can happen + -- if there are two calls to Look_Ahead in a row). + + elsif File.Before_Wide_Character then + End_Of_Line := False; + Item := File.Saved_Wide_Character; + + -- otherwise we must read a character from the input stream + + else + ch := Getc (File); + + if ch = LM + or else ch = EOF + or else (ch = EOF and then File.Is_Regular_File) + then + End_Of_Line := True; + Ungetc (ch, File); + Item := Wide_Character'Val (0); + + -- Case where character obtained does not represent the start of an + -- encoded sequence so it stands for itself and we can unget it with + -- no difficulty. + + elsif not Is_Start_Of_Encoding + (Character'Val (ch), File.WC_Method) + then + End_Of_Line := False; + Ungetc (ch, File); + Item := Wide_Character'Val (ch); + + -- For the start of an encoding, we read the character using the + -- Get_Wide_Char routine. It will occupy more than one byte so we + -- can't put it back with ungetc. Instead we save it in the control + -- block, setting a flag that everyone interested in reading + -- characters must test before reading the stream. + + else + Item := Get_Wide_Char (Character'Val (ch), File); + End_Of_Line := False; + File.Saved_Wide_Character := Item; + File.Before_Wide_Character := True; + end if; + end if; + end Look_Ahead; + + procedure Look_Ahead + (Item : out Wide_Character; + End_Of_Line : out Boolean) + is + begin + Look_Ahead (Current_In, Item, End_Of_Line); + end Look_Ahead; + + ---------- + -- Mode -- + ---------- + + function Mode (File : File_Type) return File_Mode is + begin + return To_TIO (FIO.Mode (AP (File))); + end Mode; + + ---------- + -- Name -- + ---------- + + function Name (File : File_Type) return String is + begin + return FIO.Name (AP (File)); + end Name; + + -------------- + -- New_Line -- + -------------- + + procedure New_Line + (File : File_Type; + Spacing : Positive_Count := 1) + is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not Spacing'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Write_Status (AP (File)); + + for K in 1 .. Spacing loop + Putc (LM, File); + File.Line := File.Line + 1; + + if File.Page_Length /= 0 + and then File.Line > File.Page_Length + then + Putc (PM, File); + File.Line := 1; + File.Page := File.Page + 1; + end if; + end loop; + + File.Col := 1; + end New_Line; + + procedure New_Line (Spacing : Positive_Count := 1) is + begin + New_Line (Current_Out, Spacing); + end New_Line; + + -------------- + -- New_Page -- + -------------- + + procedure New_Page (File : File_Type) is + begin + FIO.Check_Write_Status (AP (File)); + + if File.Col /= 1 or else File.Line = 1 then + Putc (LM, File); + end if; + + Putc (PM, File); + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + end New_Page; + + procedure New_Page is + begin + New_Page (Current_Out); + end New_Page; + + ----------- + -- Nextc -- + ----------- + + function Nextc (File : File_Type) return int is + ch : int; + + begin + ch := fgetc (File.Stream); + + if ch = EOF then + if ferror (File.Stream) /= 0 then + raise Device_Error; + end if; + + else + if ungetc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end if; + + return ch; + end Nextc; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + Name : String; + Form : String := "") + is + Dummy_File_Control_Block : Wide_Text_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'W', + Creat => False, + Text => True); + + File.Self := File; + Set_WCEM (File); + end Open; + + ---------- + -- Page -- + ---------- + + -- Note: we assume that it is impossible in practice for the page + -- to exceed the value of Count'Last, i.e. no check is required for + -- overflow raising layout error. + + function Page (File : File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return File.Page; + end Page; + + function Page return Positive_Count is + begin + return Page (Current_Out); + end Page; + + ----------------- + -- Page_Length -- + ----------------- + + function Page_Length (File : File_Type) return Count is + begin + FIO.Check_Write_Status (AP (File)); + return File.Page_Length; + end Page_Length; + + function Page_Length return Count is + begin + return Page_Length (Current_Out); + end Page_Length; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Wide_Character) + is + procedure Out_Char (C : Character); + -- Procedure to output one character of a wide character sequence + + procedure WC_Out is new Wide_Char_To_Char_Sequence (Out_Char); + + -------------- + -- Out_Char -- + -------------- + + procedure Out_Char (C : Character) is + begin + Putc (Character'Pos (C), File); + end Out_Char; + + -- Start of processing for Put + + begin + FIO.Check_Write_Status (AP (File)); + WC_Out (Item, File.WC_Method); + File.Col := File.Col + 1; + end Put; + + procedure Put (Item : Wide_Character) is + begin + Put (Current_Out, Item); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Wide_String) + is + begin + for J in Item'Range loop + Put (File, Item (J)); + end loop; + end Put; + + procedure Put (Item : Wide_String) is + begin + Put (Current_Out, Item); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line + (File : File_Type; + Item : Wide_String) + is + begin + Put (File, Item); + New_Line (File); + end Put_Line; + + procedure Put_Line (Item : Wide_String) is + begin + Put (Current_Out, Item); + New_Line (Current_Out); + end Put_Line; + + ---------- + -- Putc -- + ---------- + + procedure Putc (ch : int; File : File_Type) is + begin + if fputc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end Putc; + + ---------- + -- Read -- + ---------- + + -- This is the primitive Stream Read routine, used when a Text_IO file + -- is treated directly as a stream using Text_IO.Streams.Stream. + + procedure Read + (File : in out Wide_Text_AFCB; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset) + is + Discard_ch : int; + pragma Unreferenced (Discard_ch); + + begin + -- Need to deal with Before_Wide_Character ??? + + if File.Mode /= FCB.In_File then + raise Mode_Error; + end if; + + -- Deal with case where our logical and physical position do not match + -- because of being after an LM or LM-PM sequence when in fact we are + -- logically positioned before it. + + if File.Before_LM then + + -- If we are before a PM, then it is possible for a stream read + -- to leave us after the LM and before the PM, which is a bit + -- odd. The easiest way to deal with this is to unget the PM, + -- so we are indeed positioned between the characters. This way + -- further stream read operations will work correctly, and the + -- effect on text processing is a little weird, but what can + -- be expected if stream and text input are mixed this way? + + if File.Before_LM_PM then + Discard_ch := ungetc (PM, File.Stream); + File.Before_LM_PM := False; + end if; + + File.Before_LM := False; + + Item (Item'First) := Stream_Element (Character'Pos (ASCII.LF)); + + if Item'Length = 1 then + Last := Item'Last; + + else + Last := + Item'First + + Stream_Element_Offset + (fread (buffer => Item'Address, + index => size_t (Item'First + 1), + size => 1, + count => Item'Length - 1, + stream => File.Stream)); + end if; + + return; + end if; + + -- Now we do the read. Since this is a text file, it is normally in + -- text mode, but stream data must be read in binary mode, so we + -- temporarily set binary mode for the read, resetting it after. + -- These calls have no effect in a system (like Unix) where there is + -- no distinction between text and binary files. + + set_binary_mode (fileno (File.Stream)); + + Last := + Item'First + + Stream_Element_Offset + (fread (Item'Address, 1, Item'Length, File.Stream)) - 1; + + if Last < Item'Last then + if ferror (File.Stream) /= 0 then + raise Device_Error; + end if; + end if; + + set_text_mode (fileno (File.Stream)); + end Read; + + ----------- + -- Reset -- + ----------- + + procedure Reset + (File : in out File_Type; + Mode : File_Mode) + is + begin + -- Don't allow change of mode for current file (RM A.10.2(5)) + + if (File = Current_In or else + File = Current_Out or else + File = Current_Error) + and then To_FCB (Mode) /= File.Mode + then + raise Mode_Error; + end if; + + Terminate_Line (File); + FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); + File.Page := 1; + File.Line := 1; + File.Col := 1; + File.Line_Length := 0; + File.Page_Length := 0; + File.Before_LM := False; + File.Before_LM_PM := False; + end Reset; + + procedure Reset (File : in out File_Type) is + begin + Terminate_Line (File); + FIO.Reset (AP (File)'Unrestricted_Access); + File.Page := 1; + File.Line := 1; + File.Col := 1; + File.Line_Length := 0; + File.Page_Length := 0; + File.Before_LM := False; + File.Before_LM_PM := False; + end Reset; + + ------------- + -- Set_Col -- + ------------- + + procedure Set_Col + (File : File_Type; + To : Positive_Count) + is + ch : int; + + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_File_Open (AP (File)); + + if To = File.Col then + return; + end if; + + if Mode (File) >= Out_File then + if File.Line_Length /= 0 and then To > File.Line_Length then + raise Layout_Error; + end if; + + if To < File.Col then + New_Line (File); + end if; + + while File.Col < To loop + Put (File, ' '); + end loop; + + else + loop + ch := Getc (File); + + if ch = EOF then + raise End_Error; + + elsif ch = LM then + File.Line := File.Line + 1; + File.Col := 1; + + elsif ch = PM and then File.Is_Regular_File then + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + + elsif To = File.Col then + Ungetc (ch, File); + return; + + else + File.Col := File.Col + 1; + end if; + end loop; + end if; + end Set_Col; + + procedure Set_Col (To : Positive_Count) is + begin + Set_Col (Current_Out, To); + end Set_Col; + + --------------- + -- Set_Error -- + --------------- + + procedure Set_Error (File : File_Type) is + begin + FIO.Check_Write_Status (AP (File)); + Current_Err := File; + end Set_Error; + + --------------- + -- Set_Input -- + --------------- + + procedure Set_Input (File : File_Type) is + begin + FIO.Check_Read_Status (AP (File)); + Current_In := File; + end Set_Input; + + -------------- + -- Set_Line -- + -------------- + + procedure Set_Line + (File : File_Type; + To : Positive_Count) + is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_File_Open (AP (File)); + + if To = File.Line then + return; + end if; + + if Mode (File) >= Out_File then + if File.Page_Length /= 0 and then To > File.Page_Length then + raise Layout_Error; + end if; + + if To < File.Line then + New_Page (File); + end if; + + while File.Line < To loop + New_Line (File); + end loop; + + else + while To /= File.Line loop + Skip_Line (File); + end loop; + end if; + end Set_Line; + + procedure Set_Line (To : Positive_Count) is + begin + Set_Line (Current_Out, To); + end Set_Line; + + --------------------- + -- Set_Line_Length -- + --------------------- + + procedure Set_Line_Length (File : File_Type; To : Count) is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Write_Status (AP (File)); + File.Line_Length := To; + end Set_Line_Length; + + procedure Set_Line_Length (To : Count) is + begin + Set_Line_Length (Current_Out, To); + end Set_Line_Length; + + ---------------- + -- Set_Output -- + ---------------- + + procedure Set_Output (File : File_Type) is + begin + FIO.Check_Write_Status (AP (File)); + Current_Out := File; + end Set_Output; + + --------------------- + -- Set_Page_Length -- + --------------------- + + procedure Set_Page_Length (File : File_Type; To : Count) is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Write_Status (AP (File)); + File.Page_Length := To; + end Set_Page_Length; + + procedure Set_Page_Length (To : Count) is + begin + Set_Page_Length (Current_Out, To); + end Set_Page_Length; + + -------------- + -- Set_WCEM -- + -------------- + + procedure Set_WCEM (File : in out File_Type) is + Start : Natural; + Stop : Natural; + + begin + File.WC_Method := WCEM_Brackets; + FIO.Form_Parameter (File.Form.all, "wcem", Start, Stop); + + if Start = 0 then + File.WC_Method := WCEM_Brackets; + + else + if Stop = Start then + for J in WC_Encoding_Letters'Range loop + if File.Form (Start) = WC_Encoding_Letters (J) then + File.WC_Method := J; + return; + end if; + end loop; + end if; + + Close (File); + raise Use_Error with "invalid WCEM form parameter"; + end if; + end Set_WCEM; + + --------------- + -- Skip_Line -- + --------------- + + procedure Skip_Line + (File : File_Type; + Spacing : Positive_Count := 1) + is + ch : int; + + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not Spacing'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Read_Status (AP (File)); + + for L in 1 .. Spacing loop + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + + else + ch := Getc (File); + + -- If at end of file now, then immediately raise End_Error. Note + -- that we can never be positioned between a line mark and a page + -- mark, so if we are at the end of file, we cannot logically be + -- before the implicit page mark that is at the end of the file. + + -- For the same reason, we do not need an explicit check for a + -- page mark. If there is a FF in the middle of a line, the file + -- is not in canonical format and we do not care about the page + -- numbers for files other than ones in canonical format. + + if ch = EOF then + raise End_Error; + end if; + + -- If not at end of file, then loop till we get to an LM or EOF. + -- The latter case happens only in non-canonical files where the + -- last line is not terminated by LM, but we don't want to blow + -- up for such files, so we assume an implicit LM in this case. + + loop + exit when ch = LM or else ch = EOF; + ch := Getc (File); + end loop; + end if; + + -- We have got past a line mark, now, for a regular file only, + -- see if a page mark immediately follows this line mark and + -- if so, skip past the page mark as well. We do not do this + -- for non-regular files, since it would cause an undesirable + -- wait for an additional character. + + File.Col := 1; + File.Line := File.Line + 1; + + if File.Before_LM_PM then + File.Page := File.Page + 1; + File.Line := 1; + File.Before_LM_PM := False; + + elsif File.Is_Regular_File then + ch := Getc (File); + + -- Page mark can be explicit, or implied at the end of the file + + if (ch = PM or else ch = EOF) + and then File.Is_Regular_File + then + File.Page := File.Page + 1; + File.Line := 1; + else + Ungetc (ch, File); + end if; + end if; + end loop; + + File.Before_Wide_Character := False; + end Skip_Line; + + procedure Skip_Line (Spacing : Positive_Count := 1) is + begin + Skip_Line (Current_In, Spacing); + end Skip_Line; + + --------------- + -- Skip_Page -- + --------------- + + procedure Skip_Page (File : File_Type) is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + -- If at page mark already, just skip it + + if File.Before_LM_PM then + File.Before_LM := False; + File.Before_LM_PM := False; + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + return; + end if; + + -- This is a bit tricky, if we are logically before an LM then + -- it is not an error if we are at an end of file now, since we + -- are not really at it. + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + ch := Getc (File); + + -- Otherwise we do raise End_Error if we are at the end of file now + + else + ch := Getc (File); + + if ch = EOF then + raise End_Error; + end if; + end if; + + -- Now we can just rumble along to the next page mark, or to the + -- end of file, if that comes first. The latter case happens when + -- the page mark is implied at the end of file. + + loop + exit when ch = EOF + or else (ch = PM and then File.Is_Regular_File); + ch := Getc (File); + end loop; + + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + File.Before_Wide_Character := False; + end Skip_Page; + + procedure Skip_Page is + begin + Skip_Page (Current_In); + end Skip_Page; + + -------------------- + -- Standard_Error -- + -------------------- + + function Standard_Error return File_Type is + begin + return Standard_Err; + end Standard_Error; + + function Standard_Error return File_Access is + begin + return Standard_Err'Access; + end Standard_Error; + + -------------------- + -- Standard_Input -- + -------------------- + + function Standard_Input return File_Type is + begin + return Standard_In; + end Standard_Input; + + function Standard_Input return File_Access is + begin + return Standard_In'Access; + end Standard_Input; + + --------------------- + -- Standard_Output -- + --------------------- + + function Standard_Output return File_Type is + begin + return Standard_Out; + end Standard_Output; + + function Standard_Output return File_Access is + begin + return Standard_Out'Access; + end Standard_Output; + + -------------------- + -- Terminate_Line -- + -------------------- + + procedure Terminate_Line (File : File_Type) is + begin + FIO.Check_File_Open (AP (File)); + + -- For file other than In_File, test for needing to terminate last line + + if Mode (File) /= In_File then + + -- If not at start of line definition need new line + + if File.Col /= 1 then + New_Line (File); + + -- For files other than standard error and standard output, we + -- make sure that an empty file has a single line feed, so that + -- it is properly formatted. We avoid this for the standard files + -- because it is too much of a nuisance to have these odd line + -- feeds when nothing has been written to the file. + + elsif (File /= Standard_Err and then File /= Standard_Out) + and then (File.Line = 1 and then File.Page = 1) + then + New_Line (File); + end if; + end if; + end Terminate_Line; + + ------------ + -- Ungetc -- + ------------ + + procedure Ungetc (ch : int; File : File_Type) is + begin + if ch /= EOF then + if ungetc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end if; + end Ungetc; + + ----------- + -- Write -- + ----------- + + -- This is the primitive Stream Write routine, used when a Text_IO file + -- is treated directly as a stream using Text_IO.Streams.Stream. + + procedure Write + (File : in out Wide_Text_AFCB; + Item : Stream_Element_Array) + is + pragma Warnings (Off, File); + -- Because in this implementation we don't need IN OUT, we only read + + Siz : constant size_t := Item'Length; + + begin + if File.Mode = FCB.In_File then + raise Mode_Error; + end if; + + -- Now we do the write. Since this is a text file, it is normally in + -- text mode, but stream data must be written in binary mode, so we + -- temporarily set binary mode for the write, resetting it after. + -- These calls have no effect in a system (like Unix) where there is + -- no distinction between text and binary files. + + set_binary_mode (fileno (File.Stream)); + + if fwrite (Item'Address, 1, Siz, File.Stream) /= Siz then + raise Device_Error; + end if; + + set_text_mode (fileno (File.Stream)); + end Write; + +begin + -- Initialize Standard Files + + for J in WC_Encoding_Method loop + if WC_Encoding = WC_Encoding_Letters (J) then + Default_WCEM := J; + end if; + end loop; + + Initialize_Standard_Files; + + FIO.Chain_File (AP (Standard_In)); + FIO.Chain_File (AP (Standard_Out)); + FIO.Chain_File (AP (Standard_Err)); + +end Ada.Wide_Text_IO; diff --git a/gcc/ada/a-witeio.ads b/gcc/ada/a-witeio.ads new file mode 100644 index 000000000..2cf02b69b --- /dev/null +++ b/gcc/ada/a-witeio.ads @@ -0,0 +1,496 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 + -- enough so that the assumption that the Line, Column and Page + -- counts can never exceed this value is a valid assumption. + + 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 of a kludge, 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 new file mode 100644 index 000000000..6b3f656b6 --- /dev/null +++ b/gcc/ada/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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..5d6548ead --- /dev/null +++ b/gcc/ada/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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..5a7f438bf --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..f5fa1e2c6 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..06f5da54e --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Complex_Aux; + +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +with Ada.Unchecked_Conversion; + +package body Ada.Wide_Text_IO.Complex_IO is + + package Aux renames Ada.Wide_Text_IO.Complex_Aux; + + subtype LLF is Long_Long_Float; + -- Type used for calls to routines in Aux + + function TFT is new + Ada.Unchecked_Conversion (File_Type, Ada.Wide_Text_IO.File_Type); + -- This unchecked conversion is to get around a visibility bug in + -- GNAT version 2.04w. It should be possible to simply use the + -- subtype declared above and do normal checked conversions. + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Complex; + Width : Field := 0) + is + Real_Item : Real'Base; + Imag_Item : Real'Base; + + begin + Aux.Get (TFT (File), LLF (Real_Item), LLF (Imag_Item), Width); + Item := (Real_Item, Imag_Item); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Get -- + --------- + + procedure Get + (Item : out Complex; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + --------- + -- Get -- + --------- + + procedure Get + (From : Wide_String; + Item : out Complex; + Last : out Positive) + is + Real_Item : Real'Base; + Imag_Item : Real'Base; + + S : constant String := Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + Aux.Gets (S, LLF (Real_Item), LLF (Imag_Item), Last); + Item := (Real_Item, Imag_Item); + + exception + when Data_Error => raise Constraint_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Aux.Put (TFT (File), LLF (Re (Item)), LLF (Im (Item)), Fore, Aft, Exp); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (Item : Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Output, Item, Fore, Aft, Exp); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (To : out Wide_String; + Item : Complex; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (To'First .. To'Last); + + begin + Aux.Puts (S, LLF (Re (Item)), LLF (Im (Item)), Aft, Exp); + + for J in S'Range loop + To (J) := Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Text_IO.Complex_IO; diff --git a/gcc/ada/a-wtcoio.ads b/gcc/ada/a-wtcoio.ads new file mode 100644 index 000000000..31fab2b6f --- /dev/null +++ b/gcc/ada/a-wtcoio.ads @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ IO . C O M P L E X _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; + +generic + with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (<>); + +package Ada.Wide_Text_IO.Complex_IO is + + use Complex_Types; + + Default_Fore : Field := 2; + Default_Aft : Field := Real'Digits - 1; + Default_Exp : Field := 3; + + procedure Get + (File : File_Type; + Item : out Complex; + Width : Field := 0); + + procedure Get + (Item : out Complex; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : Wide_String; + Item : out Complex; + Last : out Positive); + + procedure Put + (To : out Wide_String; + Item : Complex; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +end Ada.Wide_Text_IO.Complex_IO; diff --git a/gcc/ada/a-wtcstr.adb b/gcc/ada/a-wtcstr.adb new file mode 100644 index 000000000..4be744a2a --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 new file mode 100644 index 000000000..af2d37a61 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..78b10299b --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..430888930 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Wide_Text_IO.Decimal_IO +-- that are shared among separate instantiations of this package. The +-- routines in the package are identical semantically to those declared +-- in Wide_Text_IO, except that default values have been supplied by the +-- generic, and the Num parameter has been replaced by Integer or +-- Long_Long_Integer, with an additional Scale parameter giving the +-- value of Num'Scale. In addition the Get routines return the value +-- rather than store it in an Out parameter. + +private package Ada.Wide_Text_IO.Decimal_Aux is + + function Get_Dec + (File : File_Type; + Width : Field; + Scale : Integer) return Integer; + + function Get_LLD + (File : File_Type; + Width : Field; + Scale : Integer) return Long_Long_Integer; + + function Gets_Dec + (From : String; + Last : not null access Positive; + Scale : Integer) return Integer; + + function Gets_LLD + (From : String; + Last : not null access Positive; + Scale : Integer) return Long_Long_Integer; + + procedure Put_Dec + (File : File_Type; + Item : Integer; + Fore : Field; + Aft : Field; + Exp : Field; + Scale : Integer); + + procedure Put_LLD + (File : File_Type; + Item : Long_Long_Integer; + Fore : Field; + Aft : Field; + Exp : Field; + Scale : Integer); + + procedure Puts_Dec + (To : out String; + Item : Integer; + Aft : Field; + Exp : Field; + Scale : Integer); + + procedure Puts_LLD + (To : out String; + Item : Long_Long_Integer; + Aft : Field; + Exp : Field; + Scale : Integer); + +end Ada.Wide_Text_IO.Decimal_Aux; diff --git a/gcc/ada/a-wtdeio.adb b/gcc/ada/a-wtdeio.adb new file mode 100644 index 000000000..598b72a94 --- /dev/null +++ b/gcc/ada/a-wtdeio.adb @@ -0,0 +1,164 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . D E C I M A L _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Decimal_Aux; + +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Text_IO.Decimal_IO is + + subtype TFT is Ada.Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Text_IO.Decimal_Aux; + + Scale : constant Integer := Num'Scale; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + if Num'Size > Integer'Size then + Item := Num'Fixed_Value (Aux.Get_LLD (TFT (File), Width, Scale)); + else + Item := Num'Fixed_Value (Aux.Get_Dec (TFT (File), Width, Scale)); + end if; + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + if Num'Size > Integer'Size then + -- Item := Num'Fixed_Value + -- should write above, but gets assert error ??? + Item := Num + (Aux.Gets_LLD (S, Last'Unrestricted_Access, Scale)); + else + -- Item := Num'Fixed_Value + -- should write above, but gets assert error ??? + Item := Num + (Aux.Gets_Dec (S, Last'Unrestricted_Access, Scale)); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + if Num'Size > Integer'Size then + Aux.Put_LLD +-- (TFT (File), Long_Long_Integer'Integer_Value (Item), +-- ??? + (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_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_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Text_IO.Decimal_IO; diff --git a/gcc/ada/a-wtdeio.ads b/gcc/ada/a-wtdeio.ads new file mode 100644 index 000000000..23f74f036 --- /dev/null +++ b/gcc/ada/a-wtdeio.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . D E C I M A L _ I O -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Text_IO.Decimal_IO is a subpackage of +-- Wide_Text_IO. In GNAT we make it a child package to avoid loading the +-- necessary code if Decimal_IO is not instantiated. See the routine +-- Rtsfind.Text_IO_Kludge for a description of how we patch up the +-- difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is delta <> digits <>; + +package Ada.Wide_Text_IO.Decimal_IO is + + Default_Fore : Field := 2; + Default_Aft : Field := Num'Digits - 1; + Default_Exp : Field := 3; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +end Ada.Wide_Text_IO.Decimal_IO; diff --git a/gcc/ada/a-wtedit.adb b/gcc/ada/a-wtedit.adb new file mode 100644 index 000000000..cc41dc1cd --- /dev/null +++ b/gcc/ada/a-wtedit.adb @@ -0,0 +1,2766 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 + -- indicies--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 new file mode 100644 index 000000000..edc17c558 --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..44658bc74 --- /dev/null +++ b/gcc/ada/a-wtenau.adb @@ -0,0 +1,351 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 + 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 new file mode 100644 index 000000000..05fc9d7ff --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..c5dea39da --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Enumeration_Aux; + +package body Ada.Wide_Text_IO.Enumeration_IO is + + package Aux renames Ada.Wide_Text_IO.Enumeration_Aux; + + --------- + -- Get -- + --------- + + procedure Get (File : File_Type; Item : out Enum) is + Buf : Wide_String (1 .. Enum'Width); + Buflen : Natural; + begin + Aux.Get_Enum_Lit (File, Buf, Buflen); + Item := Enum'Wide_Value (Buf (1 .. Buflen)); + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get (Item : out Enum) is + begin + Get (Current_Input, Item); + end Get; + + procedure Get + (From : Wide_String; + Item : out Enum; + Last : out Positive) + is + Start : Natural; + begin + Aux.Scan_Enum_Lit (From, Start, Last); + Item := Enum'Wide_Value (From (Start .. Last)); + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting) + is + Image : constant Wide_String := Enum'Wide_Image (Item); + begin + Aux.Put (File, Image, Width, Set); + end Put; + + procedure Put + (Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting) + is + begin + Put (Current_Output, Item, Width, Set); + end Put; + + procedure Put + (To : out Wide_String; + Item : Enum; + Set : Type_Set := Default_Setting) + is + Image : constant Wide_String := Enum'Wide_Image (Item); + begin + Aux.Puts (To, Image, Set); + end Put; + +end Ada.Wide_Text_IO.Enumeration_IO; diff --git a/gcc/ada/a-wtenio.ads b/gcc/ada/a-wtenio.ads new file mode 100644 index 000000000..3b6818450 --- /dev/null +++ b/gcc/ada/a-wtenio.ads @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . E N U M E R A T I O N _ I O -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Text_IO.Enumeration_IO is a subpackage +-- of Wide_Text_IO. In GNAT we make it a child package to avoid loading the +-- necessary code if Enumeration_IO is not instantiated. See the routine +-- Rtsfind.Text_IO_Kludge for a description of how we patch up the difference +-- in semantics so that it is invisible to the Ada programmer. + +private generic + type Enum is (<>); + +package Ada.Wide_Text_IO.Enumeration_IO is + + Default_Width : Field := 0; + Default_Setting : Type_Set := Upper_Case; + + procedure Get (File : File_Type; Item : out Enum); + procedure Get (Item : out Enum); + + procedure Put + (File : File_Type; + Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting); + + procedure Put + (Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting); + + procedure Get + (From : Wide_String; + Item : out Enum; + Last : out Positive); + + procedure Put + (To : out Wide_String; + Item : Enum; + Set : Type_Set := Default_Setting); + +end Ada.Wide_Text_IO.Enumeration_IO; diff --git a/gcc/ada/a-wtfiio.adb b/gcc/ada/a-wtfiio.adb new file mode 100644 index 000000000..c8f5473c4 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Float_Aux; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Text_IO.Fixed_IO is + + subtype TFT is Ada.Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Text_IO.Float_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + Aux.Get (TFT (File), Long_Long_Float (Item), Width); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + Aux.Gets (S, Long_Long_Float (Item), Last); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Aux.Put (TFT (File), Long_Long_Float (Item), Fore, Aft, Exp); + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Output, Item, Fore, Aft, Exp); + end Put; + + procedure Put + (To : out Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (To'First .. To'Last); + + begin + Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); + + for J in S'Range loop + To (J) := Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Text_IO.Fixed_IO; diff --git a/gcc/ada/a-wtfiio.ads b/gcc/ada/a-wtfiio.ads new file mode 100644 index 000000000..39f85416e --- /dev/null +++ b/gcc/ada/a-wtfiio.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . F I X E D _ I O -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Text_IO.Fixed_IO is a subpackage of +-- Wide_Text_IO. In GNAT we make it a child package to avoid loading +-- the necessary code if Fixed_IO is not instantiated. See the routine +-- Rtsfind.Text_IO_Kludge for a description of how we patch up the +-- difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is delta <>; + +package Ada.Wide_Text_IO.Fixed_IO is + + Default_Fore : Field := Num'Fore; + Default_Aft : Field := Num'Aft; + Default_Exp : Field := 0; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +end Ada.Wide_Text_IO.Fixed_IO; diff --git a/gcc/ada/a-wtflau.adb b/gcc/ada/a-wtflau.adb new file mode 100644 index 000000000..419ea7066 --- /dev/null +++ b/gcc/ada/a-wtflau.adb @@ -0,0 +1,234 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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; + + -- Based cases + + 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 new file mode 100644 index 000000000..96d03d375 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..af34e9465 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Float_Aux; + +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Text_IO.Float_IO is + + subtype TFT is Ada.Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Text_IO.Float_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + Aux.Get (TFT (File), Long_Long_Float (Item), Width); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + Aux.Gets (S, Long_Long_Float (Item), Last); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Aux.Put (TFT (File), Long_Long_Float (Item), Fore, Aft, Exp); + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Output, Item, Fore, Aft, Exp); + end Put; + + procedure Put + (To : out Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (To'First .. To'Last); + + begin + Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); + + for J in S'Range loop + To (J) := Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Text_IO.Float_IO; diff --git a/gcc/ada/a-wtflio.ads b/gcc/ada/a-wtflio.ads new file mode 100644 index 000000000..8b6265de1 --- /dev/null +++ b/gcc/ada/a-wtflio.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . F L O A T _ I O -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Text_IO.Float_IO is a subpackage +-- of Wide_Text_IO. In GNAT we make it a child package to avoid loading +-- the necessary code if Float_IO is not instantiated. See the routine +-- Rtsfind.Text_IO_Kludge for a description of how we patch up the +-- difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is digits <>; + +package Ada.Wide_Text_IO.Float_IO is + + Default_Fore : Field := 2; + Default_Aft : Field := Num'Digits - 1; + Default_Exp : Field := 3; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +end Ada.Wide_Text_IO.Float_IO; diff --git a/gcc/ada/a-wtgeau.adb b/gcc/ada/a-wtgeau.adb new file mode 100644 index 000000000..f8c02755e --- /dev/null +++ b/gcc/ada/a-wtgeau.adb @@ -0,0 +1,515 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 + 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 new file mode 100644 index 000000000..fabd543fd --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..411638506 --- /dev/null +++ b/gcc/ada/a-wtinau.adb @@ -0,0 +1,291 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 + 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 new file mode 100644 index 000000000..7c7927db0 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..507145f98 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Integer_Aux; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Text_IO.Integer_IO is + + Need_LLI : constant Boolean := Num'Base'Size > Integer'Size; + -- Throughout this generic body, we distinguish between the case where type + -- Integer is acceptable, and where a Long_Long_Integer is needed. This + -- Boolean is used to test for these cases and since it is a constant, only + -- code for the relevant case will be included in the instance. + + subtype TFT is Ada.Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Text_IO.Integer_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + if Need_LLI then + Aux.Get_LLI (TFT (File), Long_Long_Integer (Item), Width); + else + Aux.Get_Int (TFT (File), Integer (Item), Width); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + if Need_LLI then + Aux.Gets_LLI (S, Long_Long_Integer (Item), Last); + else + Aux.Gets_Int (S, Integer (Item), Last); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + if Need_LLI then + Aux.Put_LLI (TFT (File), Long_Long_Integer (Item), Width, Base); + else + Aux.Put_Int (TFT (File), Integer (Item), Width, Base); + end if; + end Put; + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + Put (Current_Output, Item, Width, Base); + end Put; + + procedure Put + (To : out Wide_String; + Item : Num; + Base : Number_Base := Default_Base) + is + S : String (To'First .. To'Last); + + begin + if Need_LLI then + Aux.Puts_LLI (S, Long_Long_Integer (Item), Base); + else + Aux.Puts_Int (S, Integer (Item), Base); + end if; + + for J in S'Range loop + To (J) := Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Text_IO.Integer_IO; diff --git a/gcc/ada/a-wtinio.ads b/gcc/ada/a-wtinio.ads new file mode 100644 index 000000000..b078ee379 --- /dev/null +++ b/gcc/ada/a-wtinio.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . I N T E G E R _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Text_IO.Integer_IO is a subpackage +-- of Wide_Text_IO. In GNAT we make it a child package to avoid loading +-- the necessary code if Integer_IO is not instantiated. See the routine +-- Rtsfind.Text_IO_Kludge for a description of how we patch up the +-- difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is range <>; + +package Ada.Wide_Text_IO.Integer_IO is + + Default_Width : Field := Num'Width; + Default_Base : Number_Base := 10; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Get + (From : Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_String; + Item : Num; + Base : Number_Base := Default_Base); + +end Ada.Wide_Text_IO.Integer_IO; diff --git a/gcc/ada/a-wtmoau.adb b/gcc/ada/a-wtmoau.adb new file mode 100644 index 000000000..0bc22a329 --- /dev/null +++ b/gcc/ada/a-wtmoau.adb @@ -0,0 +1,301 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 + 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 new file mode 100644 index 000000000..a9c2bdcfd --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..ce31ed5e2 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..6e85c2bb7 --- /dev/null +++ b/gcc/ada/a-wtmoio.ads @@ -0,0 +1,80 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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.Text_IO_Kludge 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 new file mode 100644 index 000000000..ed64bdd5f --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.File_IO; + +package body Ada.Wide_Text_IO.Text_Streams is + + ------------ + -- Stream -- + ------------ + + function Stream (File : File_Type) return Stream_Access is + begin + System.File_IO.Check_File_Open (FCB.AFCB_Ptr (File)); + return Stream_Access (File); + end Stream; + +end Ada.Wide_Text_IO.Text_Streams; diff --git a/gcc/ada/a-wttest.ads b/gcc/ada/a-wttest.ads new file mode 100644 index 000000000..7c180ff18 --- /dev/null +++ b/gcc/ada/a-wttest.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . T E X T _ S T R E A M S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Streams; + +package Ada.Wide_Text_IO.Text_Streams is + + type Stream_Access is access all Streams.Root_Stream_Type'Class; + + function Stream (File : File_Type) return Stream_Access; + +end Ada.Wide_Text_IO.Text_Streams; diff --git a/gcc/ada/a-wwboio.adb b/gcc/ada/a-wwboio.adb new file mode 100644 index 000000000..37a101def --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; use Ada.Wide_Text_IO; +with Ada.Unchecked_Deallocation; + +package body Ada.Wide_Text_IO.Wide_Bounded_IO is + + type Wide_String_Access is access all Wide_String; + + procedure Free (WSA : in out Wide_String_Access); + -- Perform an unchecked deallocation of a non-null string + + ---------- + -- Free -- + ---------- + + procedure Free (WSA : in out Wide_String_Access) is + Null_Wide_String : constant Wide_String := ""; + + procedure Deallocate is + new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Access); + + begin + -- Do not try to free statically allocated null string + + if WSA.all /= Null_Wide_String then + Deallocate (WSA); + end if; + end Free; + + -------------- + -- Get_Line -- + -------------- + + function Get_Line return Wide_Bounded.Bounded_Wide_String is + begin + return Wide_Bounded.To_Bounded_Wide_String (Get_Line); + end Get_Line; + + -------------- + -- Get_Line -- + -------------- + + function Get_Line + (File : File_Type) return Wide_Bounded.Bounded_Wide_String + is + begin + return Wide_Bounded.To_Bounded_Wide_String (Get_Line (File)); + end Get_Line; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line + (Item : out Wide_Bounded.Bounded_Wide_String) + is + Buffer : Wide_String (1 .. 1000); + Last : Natural; + Str1 : Wide_String_Access; + Str2 : Wide_String_Access; + + begin + Get_Line (Buffer, Last); + Str1 := new Wide_String'(Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Str2 := new Wide_String'(Str1.all & Buffer (1 .. Last)); + Free (Str1); + Str1 := Str2; + end loop; + + Item := Wide_Bounded.To_Bounded_Wide_String (Str1.all); + end Get_Line; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line + (File : File_Type; + Item : out Wide_Bounded.Bounded_Wide_String) + is + Buffer : Wide_String (1 .. 1000); + Last : Natural; + Str1 : Wide_String_Access; + Str2 : Wide_String_Access; + + begin + Get_Line (File, Buffer, Last); + Str1 := new Wide_String'(Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Str2 := new Wide_String'(Str1.all & Buffer (1 .. Last)); + Free (Str1); + Str1 := Str2; + end loop; + + Item := Wide_Bounded.To_Bounded_Wide_String (Str1.all); + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put + (Item : Wide_Bounded.Bounded_Wide_String) + is + begin + Put (Wide_Bounded.To_Wide_String (Item)); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Wide_Bounded.Bounded_Wide_String) + is + begin + Put (File, Wide_Bounded.To_Wide_String (Item)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line + (Item : Wide_Bounded.Bounded_Wide_String) + is + begin + Put_Line (Wide_Bounded.To_Wide_String (Item)); + end Put_Line; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line + (File : File_Type; + Item : Wide_Bounded.Bounded_Wide_String) + is + begin + Put_Line (File, Wide_Bounded.To_Wide_String (Item)); + end Put_Line; + +end Ada.Wide_Text_IO.Wide_Bounded_IO; diff --git a/gcc/ada/a-wwboio.ads b/gcc/ada/a-wwboio.ads new file mode 100644 index 000000000..2b8dd2a16 --- /dev/null +++ b/gcc/ada/a-wwboio.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . W I D E _ B O U N D E D _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Bounded; + +generic + with package Wide_Bounded is + new Ada.Strings.Wide_Bounded.Generic_Bounded_Length (<>); + +package Ada.Wide_Text_IO.Wide_Bounded_IO is + + function Get_Line return Wide_Bounded.Bounded_Wide_String; + + function Get_Line + (File : File_Type) return Wide_Bounded.Bounded_Wide_String; + + procedure Get_Line + (Item : out Wide_Bounded.Bounded_Wide_String); + + procedure Get_Line + (File : File_Type; + Item : out Wide_Bounded.Bounded_Wide_String); + + procedure Put + (Item : Wide_Bounded.Bounded_Wide_String); + + procedure Put + (File : File_Type; + Item : Wide_Bounded.Bounded_Wide_String); + + procedure Put_Line + (Item : Wide_Bounded.Bounded_Wide_String); + + procedure Put_Line + (File : File_Type; + Item : Wide_Bounded.Bounded_Wide_String); + +end Ada.Wide_Text_IO.Wide_Bounded_IO; diff --git a/gcc/ada/a-wwunio.ads b/gcc/ada/a-wwunio.ads new file mode 100644 index 000000000..de044c580 --- /dev/null +++ b/gcc/ada/a-wwunio.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . W I D E _ U N B O U N D E D _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: historically GNAT provided these subprograms as a child of the +-- package Ada.Strings.Wide_Unbounded. So we implement this new Ada 2005 +-- package by renaming the subprograms in that child. This is a more +-- straightforward implementation anyway, since we need access to the +-- internal representation of Unbounded_Wide_String. + +with Ada.Strings.Wide_Unbounded; +with Ada.Strings.Wide_Unbounded.Wide_Text_IO; + +package Ada.Wide_Text_IO.Wide_Unbounded_IO is + + procedure Put + (File : File_Type; + Item : Strings.Wide_Unbounded.Unbounded_Wide_String) + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Put; + + procedure Put + (Item : Strings.Wide_Unbounded.Unbounded_Wide_String) + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Put; + + procedure Put_Line + (File : Wide_Text_IO.File_Type; + Item : Strings.Wide_Unbounded.Unbounded_Wide_String) + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Put_Line; + + procedure Put_Line + (Item : Strings.Wide_Unbounded.Unbounded_Wide_String) + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Put_Line; + + function Get_Line + (File : File_Type) return Strings.Wide_Unbounded.Unbounded_Wide_String + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Get_Line; + + function Get_Line return Strings.Wide_Unbounded.Unbounded_Wide_String + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Get_Line; + + procedure Get_Line + (File : File_Type; + Item : out Strings.Wide_Unbounded.Unbounded_Wide_String) + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Get_Line; + + procedure Get_Line + (Item : out Strings.Wide_Unbounded.Unbounded_Wide_String) + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Get_Line; + +end Ada.Wide_Text_IO.Wide_Unbounded_IO; diff --git a/gcc/ada/a-zchara.ads b/gcc/ada/a-zchara.ads new file mode 100755 index 000000000..d8d5f9f50 --- /dev/null +++ b/gcc/ada/a-zchara.ads @@ -0,0 +1,18 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ C H A R A C T E R S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Wide_Wide_Characters is + pragma Pure; +end Ada.Wide_Wide_Characters; diff --git a/gcc/ada/a-zchhan.adb b/gcc/ada/a-zchhan.adb new file mode 100755 index 000000000..836d334eb --- /dev/null +++ b/gcc/ada/a-zchhan.adb @@ -0,0 +1,186 @@ +------------------------------------------------------------------------------ +-- -- +-- 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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 -- + -------------- + + function Is_Other (Item : Wide_Wide_Character) return Boolean + renames Ada.Wide_Wide_Characters.Unicode.Is_Other; + + -------------------- + -- Is_Punctuation -- + -------------------- + + function Is_Punctuation (Item : Wide_Wide_Character) return Boolean + renames Ada.Wide_Wide_Characters.Unicode.Is_Punctuation; + + -------------- + -- Is_Space -- + -------------- + + function Is_Space (Item : Wide_Wide_Character) return Boolean + renames Ada.Wide_Wide_Characters.Unicode.Is_Space; + + ---------------- + -- Is_Special -- + ---------------- + + function Is_Special (Item : Wide_Wide_Character) return Boolean is + begin + return Is_Graphic (Item) and then not Is_Alphanumeric (Item); + end Is_Special; + + -------------- + -- Is_Upper -- + -------------- + + function Is_Upper (Item : Wide_Wide_Character) return Boolean is + begin + return Get_Category (Item) = Lu; + end Is_Upper; + + -------------- + -- To_Lower -- + -------------- + + function To_Lower (Item : Wide_Wide_Character) return Wide_Wide_Character + renames Ada.Wide_Wide_Characters.Unicode.To_Lower_Case; + + function To_Lower (Item : Wide_Wide_String) return Wide_Wide_String is + Result : Wide_Wide_String (Item'Range); + + begin + for J in Result'Range loop + Result (J) := To_Lower (Item (J)); + end loop; + + return Result; + end To_Lower; + + -------------- + -- To_Upper -- + -------------- + + function To_Upper (Item : Wide_Wide_Character) return Wide_Wide_Character + renames Ada.Wide_Wide_Characters.Unicode.To_Upper_Case; + + function To_Upper (Item : Wide_Wide_String) return Wide_Wide_String is + Result : Wide_Wide_String (Item'Range); + + begin + for J in Result'Range loop + Result (J) := To_Upper (Item (J)); + end loop; + + return Result; + end To_Upper; + +end Ada.Wide_Wide_Characters.Handling; diff --git a/gcc/ada/a-zchhan.ads b/gcc/ada/a-zchhan.ads new file mode 100755 index 000000000..973a7803d --- /dev/null +++ b/gcc/ada/a-zchhan.ads @@ -0,0 +1,126 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ C H A R A C T E R S . H A N D L I N G -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Wide_Wide_Characters.Handling is + + function Is_Control (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Control); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as other_control, otherwise returns false. + + function Is_Letter (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Letter); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as letter_uppercase, letter_lowercase, letter_titlecase, + -- letter_modifier, letter_other, or number_letter. Otherwise returns + -- false. + + function Is_Lower (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Lower); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as letter_lowercase, otherwise returns false. + + function Is_Upper (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Upper); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as letter_uppercase, otherwise returns false. + + function Is_Digit (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Digit); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as number_decimal, otherwise returns false. + + function Is_Decimal_Digit (Item : Wide_Wide_Character) return Boolean + renames Is_Digit; + + function Is_Hexadecimal_Digit (Item : Wide_Wide_Character) return Boolean; + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as number_decimal, or is in the range 'A' .. 'F' or + -- 'a' .. 'f', otherwise returns false. + + function Is_Alphanumeric (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Alphanumeric); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as letter_uppercase, letter_lowercase, letter_titlecase, + -- letter_modifier, letter_other, number_letter, or number_decimal. + -- Otherwise returns false. + + function Is_Special (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Special); + -- Returns True if the Wide_Wide_Character designated by Item + -- is categorized as graphic_character, but not categorized as + -- letter_uppercase, letter_lowercase, letter_titlecase, letter_modifier, + -- letter_other, number_letter, or number_decimal. Otherwise returns false. + + function Is_Line_Terminator (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Line_Terminator); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as separator_line or separator_paragraph, or if Item is a + -- conventional line terminator character (CR, LF, VT, or FF). Otherwise + -- returns false. + + function Is_Mark (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Mark); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as mark_non_spacing or mark_spacing_combining, otherwise + -- returns false. + + function Is_Other (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Other); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as other_format, otherwise returns false. + + function Is_Punctuation (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Punctuation); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as punctuation_connector, otherwise returns false. + + function Is_Space (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Space); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as separator_space, otherwise returns false. + + function Is_Graphic (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Graphic); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as graphic_character, otherwise returns false. + + function To_Lower (Item : Wide_Wide_Character) return Wide_Wide_Character; + pragma Inline (To_Lower); + -- Returns the Simple Lowercase Mapping of the Wide_Wide_Character + -- designated by Item. If the Simple Lowercase Mapping does not exist for + -- the Wide_Wide_Character designated by Item, then the value of Item is + -- returned. + + function To_Lower (Item : Wide_Wide_String) return Wide_Wide_String; + -- Returns the result of applying the To_Lower Wide_Wide_Character to + -- Wide_Wide_Character conversion to each element of the Wide_Wide_String + -- designated by Item. The result is the null Wide_Wide_String if the value + -- of the formal parameter is the null Wide_Wide_String. + + function To_Upper (Item : Wide_Wide_Character) return Wide_Wide_Character; + pragma Inline (To_Upper); + -- Returns the Simple Uppercase Mapping of the Wide_Wide_Character + -- designated by Item. If the Simple Uppercase Mapping does not exist for + -- the Wide_Wide_Character designated by Item, then the value of Item is + -- returned. + + function To_Upper (Item : Wide_Wide_String) return Wide_Wide_String; + -- Returns the result of applying the To_Upper Wide_Wide_Character to + -- Wide_Wide_Character conversion to each element of the Wide_Wide_String + -- designated by Item. The result is the null Wide_Wide_String if the value + -- of the formal parameter is the null Wide_Wide_String. + +end Ada.Wide_Wide_Characters.Handling; diff --git a/gcc/ada/a-zchuni.adb b/gcc/ada/a-zchuni.adb new file mode 100755 index 000000000..5e0b1cbdc --- /dev/null +++ b/gcc/ada/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-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_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 new file mode 100755 index 000000000..10506957a --- /dev/null +++ b/gcc/ada/a-zchuni.ads @@ -0,0 +1,195 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- Unicode categorization routines for Wide_Wide_Character + +with System.UTF_32; + +package Ada.Wide_Wide_Characters.Unicode is + + -- 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 new file mode 100755 index 000000000..e0a7f64b6 --- /dev/null +++ b/gcc/ada/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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100755 index 000000000..80f2b1f2c --- /dev/null +++ b/gcc/ada/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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..d9c365c45 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; +with Ada.Wide_Wide_Text_IO.Float_Aux; + +with System.Img_Real; use System.Img_Real; + +package body Ada.Wide_Wide_Text_IO.Complex_Aux is + + package Aux renames Ada.Wide_Wide_Text_IO.Float_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + ItemR : out Long_Long_Float; + ItemI : out Long_Long_Float; + Width : Field) + is + Buf : String (1 .. Field'Last); + Stop : Integer := 0; + Ptr : aliased Integer; + Paren : Boolean := False; + + begin + -- General note for following code, exceptions from the calls + -- to Get for components of the complex value are propagated. + + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + Gets (Buf (1 .. Stop), ItemR, ItemI, Ptr); + + for J in Ptr + 1 .. Stop loop + if not Is_Blank (Buf (J)) then + raise Data_Error; + end if; + end loop; + + -- Case of width = 0 + + else + Load_Skip (File); + Ptr := 0; + Load (File, Buf, Ptr, '(', Paren); + Aux.Get (File, ItemR, 0); + Load_Skip (File); + Load (File, Buf, Ptr, ','); + Aux.Get (File, ItemI, 0); + + if Paren then + Load_Skip (File); + Load (File, Buf, Ptr, ')', Paren); + + if not Paren then + raise Data_Error; + end if; + end if; + end if; + end Get; + + ---------- + -- Gets -- + ---------- + + procedure Gets + (From : String; + ItemR : out Long_Long_Float; + ItemI : out Long_Long_Float; + Last : out Positive) + is + Paren : Boolean; + Pos : Integer; + + begin + String_Skip (From, Pos); + + if From (Pos) = '(' then + Pos := Pos + 1; + Paren := True; + else + Paren := False; + end if; + + Aux.Gets (From (Pos .. From'Last), ItemR, Pos); + + String_Skip (From (Pos + 1 .. From'Last), Pos); + + if From (Pos) = ',' then + Pos := Pos + 1; + end if; + + Aux.Gets (From (Pos .. From'Last), ItemI, Pos); + + if Paren then + String_Skip (From (Pos + 1 .. From'Last), Pos); + + if From (Pos) /= ')' then + raise Data_Error; + end if; + end if; + + Last := Pos; + end Gets; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + ItemR : Long_Long_Float; + ItemI : Long_Long_Float; + Fore : Field; + Aft : Field; + Exp : Field) + is + begin + Put (File, '('); + Aux.Put (File, ItemR, Fore, Aft, Exp); + Put (File, ','); + Aux.Put (File, ItemI, Fore, Aft, Exp); + Put (File, ')'); + end Put; + + ---------- + -- Puts -- + ---------- + + procedure Puts + (To : out String; + ItemR : Long_Long_Float; + ItemI : Long_Long_Float; + Aft : Field; + Exp : Field) + is + I_String : String (1 .. 3 * Field'Last); + R_String : String (1 .. 3 * Field'Last); + + Iptr : Natural; + Rptr : Natural; + + begin + -- Both parts are initially converted with a Fore of 0 + + Rptr := 0; + Set_Image_Real (ItemR, R_String, Rptr, 0, Aft, Exp); + Iptr := 0; + Set_Image_Real (ItemI, I_String, Iptr, 0, Aft, Exp); + + -- Check room for both parts plus parens plus comma (RM G.1.3(34)) + + if Rptr + Iptr + 3 > To'Length then + raise Layout_Error; + end if; + + -- If there is room, layout result according to (RM G.1.3(31-33)) + + To (To'First) := '('; + To (To'First + 1 .. To'First + Rptr) := R_String (1 .. Rptr); + To (To'First + Rptr + 1) := ','; + + To (To'Last) := ')'; + + To (To'Last - Iptr .. To'Last - 1) := I_String (1 .. Iptr); + + for J in To'First + Rptr + 2 .. To'Last - Iptr - 1 loop + To (J) := ' '; + end loop; + end Puts; + +end Ada.Wide_Wide_Text_IO.Complex_Aux; diff --git a/gcc/ada/a-ztcoau.ads b/gcc/ada/a-ztcoau.ads new file mode 100644 index 000000000..42322401f --- /dev/null +++ b/gcc/ada/a-ztcoau.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . C O M P L E X _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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.Complex_IO +-- that are shared among separate instantiations of this package. The routines +-- in this package are identical semantically to those in Complex_IO itself, +-- except that the generic parameter Complex has been replaced by separate +-- real and imaginary values of type Long_Long_Float, and default parameters +-- have been removed because they are supplied explicitly by the calls from +-- within the generic template. + +package Ada.Wide_Wide_Text_IO.Complex_Aux is + + procedure Get + (File : File_Type; + ItemR : out Long_Long_Float; + ItemI : out Long_Long_Float; + Width : Field); + + procedure Gets + (From : String; + ItemR : out Long_Long_Float; + ItemI : out Long_Long_Float; + Last : out Positive); + + procedure Put + (File : File_Type; + ItemR : Long_Long_Float; + ItemI : Long_Long_Float; + Fore : Field; + Aft : Field; + Exp : Field); + + procedure Puts + (To : out String; + ItemR : Long_Long_Float; + ItemI : Long_Long_Float; + Aft : Field; + Exp : Field); + +end Ada.Wide_Wide_Text_IO.Complex_Aux; diff --git a/gcc/ada/a-ztcoio.adb b/gcc/ada/a-ztcoio.adb new file mode 100644 index 000000000..c5d21a1a2 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Complex_Aux; + +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +with Ada.Unchecked_Conversion; + +package body Ada.Wide_Wide_Text_IO.Complex_IO is + + package Aux renames Ada.Wide_Wide_Text_IO.Complex_Aux; + + subtype LLF is Long_Long_Float; + -- Type used for calls to routines in Aux + + function TFT is new + Ada.Unchecked_Conversion (File_Type, Ada.Wide_Wide_Text_IO.File_Type); + -- This unchecked conversion is to get around a visibility bug in + -- GNAT version 2.04w. It should be possible to simply use the + -- subtype declared above and do normal checked conversions. + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Complex; + Width : Field := 0) + is + Real_Item : Real'Base; + Imag_Item : Real'Base; + + begin + Aux.Get (TFT (File), LLF (Real_Item), LLF (Imag_Item), Width); + Item := (Real_Item, Imag_Item); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Get -- + --------- + + procedure Get + (Item : out Complex; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + --------- + -- Get -- + --------- + + procedure Get + (From : Wide_Wide_String; + Item : out Complex; + Last : out Positive) + is + Real_Item : Real'Base; + Imag_Item : Real'Base; + + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + Aux.Gets (S, LLF (Real_Item), LLF (Imag_Item), Last); + Item := (Real_Item, Imag_Item); + + exception + when Data_Error => raise Constraint_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Aux.Put (TFT (File), LLF (Re (Item)), LLF (Im (Item)), Fore, Aft, Exp); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (Item : Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Output, Item, Fore, Aft, Exp); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (To : out Wide_Wide_String; + Item : Complex; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (To'First .. To'Last); + + begin + Aux.Puts (S, LLF (Re (Item)), LLF (Im (Item)), Aft, Exp); + + for J in S'Range loop + To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Wide_Text_IO.Complex_IO; diff --git a/gcc/ada/a-ztcoio.ads b/gcc/ada/a-ztcoio.ads new file mode 100644 index 000000000..866fd879c --- /dev/null +++ b/gcc/ada/a-ztcoio.ads @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ IO . C O M P L E X _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; + +generic + with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (<>); + +package Ada.Wide_Wide_Text_IO.Complex_IO is + + use Complex_Types; + + Default_Fore : Field := 2; + Default_Aft : Field := Real'Digits - 1; + Default_Exp : Field := 3; + + procedure Get + (File : File_Type; + Item : out Complex; + Width : Field := 0); + + procedure Get + (Item : out Complex; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : Wide_Wide_String; + Item : out Complex; + Last : out Positive); + + procedure Put + (To : out Wide_Wide_String; + Item : Complex; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +end Ada.Wide_Wide_Text_IO.Complex_IO; diff --git a/gcc/ada/a-ztcstr.adb b/gcc/ada/a-ztcstr.adb new file mode 100644 index 000000000..7d61d717e --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 new file mode 100644 index 000000000..75dc89bce --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..38450fcb0 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..96725929b --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..52f8820a7 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Decimal_Aux; + +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Wide_Text_IO.Decimal_IO is + + subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Wide_Text_IO.Decimal_Aux; + + Scale : constant Integer := Num'Scale; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + if Num'Size > Integer'Size then + Item := Num'Fixed_Value (Aux.Get_LLD (TFT (File), Width, Scale)); + else + Item := Num'Fixed_Value (Aux.Get_Dec (TFT (File), Width, Scale)); + end if; + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + if Num'Size > Integer'Size then + -- Item := Num'Fixed_Value + -- should write above, but gets assert error ??? + Item := Num + (Aux.Gets_LLD (S, Last'Unrestricted_Access, Scale)); + else + -- Item := Num'Fixed_Value + -- should write above, but gets assert error ??? + Item := Num + (Aux.Gets_Dec (S, Last'Unrestricted_Access, Scale)); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + if Num'Size > Integer'Size then + Aux.Put_LLD +-- (TFT (File), Long_Long_Integer'Integer_Value (Item), +-- ??? + (TFT (File), Long_Long_Integer (Item), + Fore, Aft, Exp, Scale); + else + Aux.Put_Dec +-- (TFT (File), Integer'Integer_Value (Item), Fore, Aft, Exp, Scale); +-- ??? + (TFT (File), Integer (Item), Fore, Aft, Exp, Scale); + + end if; + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Output, Item, Fore, Aft, Exp); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (To'First .. To'Last); + + begin + if Num'Size > Integer'Size then +-- Aux.Puts_LLD +-- (S, Long_Long_Integer'Integer_Value (Item), Aft, Exp, Scale); +-- ??? + Aux.Puts_LLD + (S, Long_Long_Integer (Item), Aft, Exp, Scale); + else +-- Aux.Puts_Dec (S, Integer'Integer_Value (Item), Aft, Exp, Scale); +-- ??? + Aux.Puts_Dec (S, Integer (Item), Aft, Exp, Scale); + end if; + + for J in S'Range loop + To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Wide_Text_IO.Decimal_IO; diff --git a/gcc/ada/a-ztdeio.ads b/gcc/ada/a-ztdeio.ads new file mode 100644 index 000000000..00ea5d742 --- /dev/null +++ b/gcc/ada/a-ztdeio.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . D E C I M A L _ I O -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Decimal_IO is a subpackage of +-- Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading the +-- necessary code if Decimal_IO is not instantiated. See the routine +-- Rtsfind.Text_IO_Kludge for a description of how we patch up the difference +-- in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is delta <> digits <>; + +package Ada.Wide_Wide_Text_IO.Decimal_IO is + + Default_Fore : Field := 2; + Default_Aft : Field := Num'Digits - 1; + Default_Exp : Field := 3; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +end Ada.Wide_Wide_Text_IO.Decimal_IO; diff --git a/gcc/ada/a-ztedit.adb b/gcc/ada/a-ztedit.adb new file mode 100644 index 000000000..9b5036a4d --- /dev/null +++ b/gcc/ada/a-ztedit.adb @@ -0,0 +1,2765 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 + -- indicies--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 new file mode 100644 index 000000000..db840d04d --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..c5776366b --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..5e127122f --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..74b0ec932 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Enumeration_Aux; + +package body Ada.Wide_Wide_Text_IO.Enumeration_IO is + + package Aux renames Ada.Wide_Wide_Text_IO.Enumeration_Aux; + + --------- + -- Get -- + --------- + + procedure Get (File : File_Type; Item : out Enum) is + Buf : Wide_Wide_String (1 .. Enum'Width); + Buflen : Natural; + begin + Aux.Get_Enum_Lit (File, Buf, Buflen); + Item := Enum'Wide_Wide_Value (Buf (1 .. Buflen)); + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get (Item : out Enum) is + begin + Get (Current_Input, Item); + end Get; + + procedure Get + (From : Wide_Wide_String; + Item : out Enum; + Last : out Positive) + is + Start : Natural; + begin + Aux.Scan_Enum_Lit (From, Start, Last); + Item := Enum'Wide_Wide_Value (From (Start .. Last)); + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting) + is + Image : constant Wide_Wide_String := Enum'Wide_Wide_Image (Item); + begin + Aux.Put (File, Image, Width, Set); + end Put; + + procedure Put + (Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting) + is + begin + Put (Current_Output, Item, Width, Set); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Enum; + Set : Type_Set := Default_Setting) + is + Image : constant Wide_Wide_String := Enum'Wide_Wide_Image (Item); + begin + Aux.Puts (To, Image, Set); + end Put; + +end Ada.Wide_Wide_Text_IO.Enumeration_IO; diff --git a/gcc/ada/a-ztenio.ads b/gcc/ada/a-ztenio.ads new file mode 100644 index 000000000..6c81d6f9e --- /dev/null +++ b/gcc/ada/a-ztenio.ads @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . E N U M E R A T I O N _ I O -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Enumeration_IO is a +-- subpackage of Wide_Wide_Text_IO. In GNAT we make it a child package to +-- avoid loading the necessary code if Enumeration_IO is not instantiated. +-- See the routine Rtsfind.Text_IO_Kludge for a description of how we patch +-- up the difference in semantics so that it is invisible to the Ada +-- programmer. + +private generic + type Enum is (<>); + +package Ada.Wide_Wide_Text_IO.Enumeration_IO is + + Default_Width : Field := 0; + Default_Setting : Type_Set := Upper_Case; + + procedure Get (File : File_Type; Item : out Enum); + procedure Get (Item : out Enum); + + procedure Put + (File : File_Type; + Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting); + + procedure Put + (Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting); + + procedure Get + (From : Wide_Wide_String; + Item : out Enum; + Last : out Positive); + + procedure Put + (To : out Wide_Wide_String; + Item : Enum; + Set : Type_Set := Default_Setting); + +end Ada.Wide_Wide_Text_IO.Enumeration_IO; diff --git a/gcc/ada/a-ztexio.adb b/gcc/ada/a-ztexio.adb new file mode 100644 index 000000000..8be8a91d9 --- /dev/null +++ b/gcc/ada/a-ztexio.adb @@ -0,0 +1,1940 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Streams; use Ada.Streams; +with Interfaces.C_Streams; use Interfaces.C_Streams; + +with System.CRTL; +with System.File_IO; +with System.WCh_Cnv; use System.WCh_Cnv; +with System.WCh_Con; use System.WCh_Con; + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +pragma Elaborate_All (System.File_IO); +-- Needed because of calls to Chain_File in package body elaboration + +package body Ada.Wide_Wide_Text_IO is + + package FIO renames System.File_IO; + + subtype AP is FCB.AFCB_Ptr; + + function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); + function To_TIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode); + use type FCB.File_Mode; + + use type System.CRTL.size_t; + + WC_Encoding : Character; + pragma Import (C, WC_Encoding, "__gl_wc_encoding"); + -- Default wide character encoding + + Err_Name : aliased String := "*stderr" & ASCII.NUL; + In_Name : aliased String := "*stdin" & ASCII.NUL; + Out_Name : aliased String := "*stdout" & ASCII.NUL; + -- Names of standard files + -- + -- Use "preallocated" strings to avoid calling "new" during the elaboration + -- of the run time. This is needed in the tasking case to avoid calling + -- Task_Lock too early. A filename is expected to end with a null character + -- in the runtime, here the null characters are added just to have a + -- correct filename length. + -- + -- Note: the names for these files are bogus, and probably it would be + -- better for these files to have no names, but the ACVC tests insist! + -- We use names that are bound to fail in open etc. + + Null_Str : aliased constant String := ""; + -- Used as form string for standard files + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Get_Wide_Wide_Char_Immed + (C : Character; + File : File_Type) return Wide_Wide_Character; + -- This routine is identical to Get_Wide_Wide_Char, except that the reads + -- are done in Get_Immediate mode (i.e. without waiting for a line return). + + function Getc_Immed (File : File_Type) return int; + -- This routine is identical to Getc, except that the read is done in + -- Get_Immediate mode (i.e. without waiting for a line return). + + procedure Putc (ch : int; File : File_Type); + -- Outputs the given character to the file, which has already been checked + -- for being in output status. Device_Error is raised if the character + -- cannot be written. + + procedure Set_WCEM (File : in out File_Type); + -- Called by Open and Create to set the wide character encoding method for + -- the file, processing a WCEM form parameter if one is present. File is + -- IN OUT because it may be closed in case of an error. + + procedure Terminate_Line (File : File_Type); + -- If the file is in Write_File or Append_File mode, and the current line + -- is not terminated, then a line terminator is written using New_Line. + -- Note that there is no Terminate_Page routine, because the page mark at + -- the end of the file is implied if necessary. + + procedure Ungetc (ch : int; File : File_Type); + -- Pushes back character into stream, using ungetc. The caller has checked + -- that the file is in read status. Device_Error is raised if the character + -- cannot be pushed back. An attempt to push back and end of file character + -- (EOF) is ignored. + + ------------------- + -- AFCB_Allocate -- + ------------------- + + function AFCB_Allocate + (Control_Block : Wide_Wide_Text_AFCB) return FCB.AFCB_Ptr + is + pragma Unreferenced (Control_Block); + begin + return new Wide_Wide_Text_AFCB; + end AFCB_Allocate; + + ---------------- + -- AFCB_Close -- + ---------------- + + procedure AFCB_Close (File : not null access Wide_Wide_Text_AFCB) is + begin + -- If the file being closed is one of the current files, then close + -- the corresponding current file. It is not clear that this action + -- is required (RM A.10.3(23)) but it seems reasonable, and besides + -- ACVC test CE3208A expects this behavior. + + if File_Type (File) = Current_In then + Current_In := null; + elsif File_Type (File) = Current_Out then + Current_Out := null; + elsif File_Type (File) = Current_Err then + Current_Err := null; + end if; + + Terminate_Line (File_Type (File)); + end AFCB_Close; + + --------------- + -- AFCB_Free -- + --------------- + + procedure AFCB_Free (File : not null access Wide_Wide_Text_AFCB) is + type FCB_Ptr is access all Wide_Wide_Text_AFCB; + FT : FCB_Ptr := FCB_Ptr (File); + + procedure Free is new + Ada.Unchecked_Deallocation (Wide_Wide_Text_AFCB, FCB_Ptr); + + begin + Free (FT); + end AFCB_Free; + + ----------- + -- Close -- + ----------- + + procedure Close (File : in out File_Type) is + begin + FIO.Close (AP (File)'Unrestricted_Access); + end Close; + + --------- + -- Col -- + --------- + + -- Note: we assume that it is impossible in practice for the column + -- to exceed the value of Count'Last, i.e. no check is required for + -- overflow raising layout error. + + function Col (File : File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return File.Col; + end Col; + + function Col return Positive_Count is + begin + return Col (Current_Out); + end Col; + + ------------ + -- Create -- + ------------ + + procedure Create + (File : in out File_Type; + Mode : File_Mode := Out_File; + Name : String := ""; + Form : String := "") + is + Dummy_File_Control_Block : Wide_Wide_Text_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'W', + Creat => True, + Text => True); + + File.Self := File; + Set_WCEM (File); + end Create; + + ------------------- + -- Current_Error -- + ------------------- + + function Current_Error return File_Type is + begin + return Current_Err; + end Current_Error; + + function Current_Error return File_Access is + begin + return Current_Err.Self'Access; + end Current_Error; + + ------------------- + -- Current_Input -- + ------------------- + + function Current_Input return File_Type is + begin + return Current_In; + end Current_Input; + + function Current_Input return File_Access is + begin + return Current_In.Self'Access; + end Current_Input; + + -------------------- + -- Current_Output -- + -------------------- + + function Current_Output return File_Type is + begin + return Current_Out; + end Current_Output; + + function Current_Output return File_Access is + begin + return Current_Out.Self'Access; + end Current_Output; + + ------------ + -- Delete -- + ------------ + + procedure Delete (File : in out File_Type) is + begin + FIO.Delete (AP (File)'Unrestricted_Access); + end Delete; + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File (File : File_Type) return Boolean is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Wide_Wide_Character then + return False; + + elsif File.Before_LM then + if File.Before_LM_PM then + return Nextc (File) = EOF; + end if; + + else + ch := Getc (File); + + if ch = EOF then + return True; + + elsif ch /= LM then + Ungetc (ch, File); + return False; + + else -- ch = LM + File.Before_LM := True; + end if; + end if; + + -- Here we are just past the line mark with Before_LM set so that we + -- do not have to try to back up past the LM, thus avoiding the need + -- to back up more than one character. + + ch := Getc (File); + + if ch = EOF then + return True; + + elsif ch = PM and then File.Is_Regular_File then + File.Before_LM_PM := True; + return Nextc (File) = EOF; + + -- Here if neither EOF nor PM followed end of line + + else + Ungetc (ch, File); + return False; + end if; + + end End_Of_File; + + function End_Of_File return Boolean is + begin + return End_Of_File (Current_In); + end End_Of_File; + + ----------------- + -- End_Of_Line -- + ----------------- + + function End_Of_Line (File : File_Type) return Boolean is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Wide_Wide_Character then + return False; + + elsif File.Before_LM then + return True; + + else + ch := Getc (File); + + if ch = EOF then + return True; + + else + Ungetc (ch, File); + return (ch = LM); + end if; + end if; + end End_Of_Line; + + function End_Of_Line return Boolean is + begin + return End_Of_Line (Current_In); + end End_Of_Line; + + ----------------- + -- End_Of_Page -- + ----------------- + + function End_Of_Page (File : File_Type) return Boolean is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if not File.Is_Regular_File then + return False; + + elsif File.Before_Wide_Wide_Character then + return False; + + elsif File.Before_LM then + if File.Before_LM_PM then + return True; + end if; + + else + ch := Getc (File); + + if ch = EOF then + return True; + + elsif ch /= LM then + Ungetc (ch, File); + return False; + + else -- ch = LM + File.Before_LM := True; + end if; + end if; + + -- Here we are just past the line mark with Before_LM set so that we + -- do not have to try to back up past the LM, thus avoiding the need + -- to back up more than one character. + + ch := Nextc (File); + + return ch = PM or else ch = EOF; + end End_Of_Page; + + function End_Of_Page return Boolean is + begin + return End_Of_Page (Current_In); + end End_Of_Page; + + ----------- + -- Flush -- + ----------- + + procedure Flush (File : File_Type) is + begin + FIO.Flush (AP (File)); + end Flush; + + procedure Flush is + begin + Flush (Current_Out); + end Flush; + + ---------- + -- Form -- + ---------- + + function Form (File : File_Type) return String is + begin + return FIO.Form (AP (File)); + end Form; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Wide_Wide_Character) + is + C : Character; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Wide_Wide_Character then + File.Before_Wide_Wide_Character := False; + Item := File.Saved_Wide_Wide_Character; + + -- Ada.Text_IO checks Before_LM_PM here, shouldn't we do the same??? + + else + Get_Character (File, C); + Item := Get_Wide_Wide_Char (C, File); + end if; + end Get; + + procedure Get (Item : out Wide_Wide_Character) is + begin + Get (Current_In, Item); + end Get; + + procedure Get + (File : File_Type; + Item : out Wide_Wide_String) + is + begin + for J in Item'Range loop + Get (File, Item (J)); + end loop; + end Get; + + procedure Get (Item : out Wide_Wide_String) is + begin + Get (Current_In, Item); + end Get; + + ------------------- + -- Get_Character -- + ------------------- + + procedure Get_Character + (File : File_Type; + Item : out Character) + is + ch : int; + + begin + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + File.Col := 1; + + if File.Before_LM_PM then + File.Line := 1; + File.Page := File.Page + 1; + File.Before_LM_PM := False; + + else + File.Line := File.Line + 1; + end if; + end if; + + loop + ch := Getc (File); + + if ch = EOF then + raise End_Error; + + elsif ch = LM then + File.Line := File.Line + 1; + File.Col := 1; + + elsif ch = PM and then File.Is_Regular_File then + File.Page := File.Page + 1; + File.Line := 1; + + else + Item := Character'Val (ch); + File.Col := File.Col + 1; + return; + end if; + end loop; + end Get_Character; + + ------------------- + -- Get_Immediate -- + ------------------- + + procedure Get_Immediate + (File : File_Type; + Item : out Wide_Wide_Character) + is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Wide_Wide_Character then + File.Before_Wide_Wide_Character := False; + Item := File.Saved_Wide_Wide_Character; + + elsif File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + Item := Wide_Wide_Character'Val (LM); + + else + ch := Getc_Immed (File); + + if ch = EOF then + raise End_Error; + else + Item := Get_Wide_Wide_Char_Immed (Character'Val (ch), File); + end if; + end if; + end Get_Immediate; + + procedure Get_Immediate + (Item : out Wide_Wide_Character) + is + begin + Get_Immediate (Current_In, Item); + end Get_Immediate; + + procedure Get_Immediate + (File : File_Type; + Item : out Wide_Wide_Character; + Available : out Boolean) + is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + Available := True; + + if File.Before_Wide_Wide_Character then + File.Before_Wide_Wide_Character := False; + Item := File.Saved_Wide_Wide_Character; + + elsif File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + Item := Wide_Wide_Character'Val (LM); + + else + -- Shouldn't we use getc_immediate_nowait here, like Text_IO??? + + ch := Getc_Immed (File); + + if ch = EOF then + raise End_Error; + else + Item := Get_Wide_Wide_Char_Immed (Character'Val (ch), File); + end if; + end if; + end Get_Immediate; + + procedure Get_Immediate + (Item : out Wide_Wide_Character; + Available : out Boolean) + is + begin + Get_Immediate (Current_In, Item, Available); + end Get_Immediate; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line + (File : File_Type; + Item : out Wide_Wide_String; + Last : out Natural) + is + begin + FIO.Check_Read_Status (AP (File)); + Last := Item'First - 1; + + -- Immediate exit for null string, this is a case in which we do not + -- need to test for end of file and we do not skip a line mark under + -- any circumstances. + + if Last >= Item'Last then + return; + end if; + + -- Here we have at least one character, if we are immediately before + -- a line mark, then we will just skip past it storing no characters. + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + + -- Otherwise we need to read some characters + + else + -- If we are at the end of file now, it means we are trying to + -- skip a file terminator and we raise End_Error (RM A.10.7(20)) + + if Nextc (File) = EOF then + raise End_Error; + end if; + + -- Loop through characters in string + + loop + -- Exit the loop if read is terminated by encountering line mark + -- Note that the use of Skip_Line here ensures we properly deal + -- with setting the page and line numbers. + + if End_Of_Line (File) then + Skip_Line (File); + return; + end if; + + -- Otherwise store the character, note that we know that ch is + -- something other than LM or EOF. It could possibly be a page + -- mark if there is a stray page mark in the middle of a line, + -- but this is not an official page mark in any case, since + -- official page marks can only follow a line mark. The whole + -- page business is pretty much nonsense anyway, so we do not + -- want to waste time trying to make sense out of non-standard + -- page marks in the file! This means that the behavior of + -- Get_Line is different from repeated Get of a character, but + -- that's too bad. We only promise that page numbers etc make + -- sense if the file is formatted in a standard manner. + + -- Note: we do not adjust the column number because it is quicker + -- to adjust it once at the end of the operation than incrementing + -- it each time around the loop. + + Last := Last + 1; + Get (File, Item (Last)); + + -- All done if the string is full, this is the case in which + -- we do not skip the following line mark. We need to adjust + -- the column number in this case. + + if Last = Item'Last then + File.Col := File.Col + Count (Item'Length); + return; + end if; + + -- Exit from the loop if we are at the end of file. This happens + -- if we have a last line that is not terminated with a line mark. + -- In this case we consider that there is an implied line mark; + -- this is a non-standard file, but we will treat it nicely. + + exit when Nextc (File) = EOF; + end loop; + end if; + end Get_Line; + + procedure Get_Line + (Item : out Wide_Wide_String; + Last : out Natural) + is + begin + Get_Line (Current_In, Item, Last); + end Get_Line; + + function Get_Line (File : File_Type) return Wide_Wide_String is + Buffer : Wide_Wide_String (1 .. 500); + Last : Natural; + + function Get_Rest (S : Wide_Wide_String) return Wide_Wide_String; + -- This is a recursive function that reads the rest of the line and + -- returns it. S is the part read so far. + + -------------- + -- Get_Rest -- + -------------- + + function Get_Rest (S : Wide_Wide_String) return Wide_Wide_String is + + -- Each time we allocate a buffer the same size as what we have + -- read so far. This limits us to a logarithmic number of calls + -- to Get_Rest and also ensures only a linear use of stack space. + + Buffer : Wide_Wide_String (1 .. S'Length); + Last : Natural; + + begin + Get_Line (File, Buffer, Last); + + declare + R : constant Wide_Wide_String := S & Buffer (1 .. Last); + begin + if Last < Buffer'Last then + return R; + else + return Get_Rest (R); + end if; + end; + end Get_Rest; + + -- Start of processing for Get_Line + + begin + Get_Line (File, Buffer, Last); + + if Last < Buffer'Last then + return Buffer (1 .. Last); + else + return Get_Rest (Buffer (1 .. Last)); + end if; + end Get_Line; + + function Get_Line return Wide_Wide_String is + begin + return Get_Line (Current_In); + end Get_Line; + + ------------------------ + -- Get_Wide_Wide_Char -- + ------------------------ + + function Get_Wide_Wide_Char + (C : Character; + File : File_Type) return Wide_Wide_Character + is + function In_Char return Character; + -- Function used to obtain additional characters it the wide character + -- sequence is more than one character long. + + function WC_In is new Char_Sequence_To_UTF_32 (In_Char); + + ------------- + -- In_Char -- + ------------- + + function In_Char return Character is + ch : constant Integer := Getc (File); + begin + if ch = EOF then + raise End_Error; + else + return Character'Val (ch); + end if; + end In_Char; + + -- Start of processing for Get_Wide_Wide_Char + + begin + FIO.Check_Read_Status (AP (File)); + return Wide_Wide_Character'Val (WC_In (C, File.WC_Method)); + end Get_Wide_Wide_Char; + + ------------------------------ + -- Get_Wide_Wide_Char_Immed -- + ------------------------------ + + function Get_Wide_Wide_Char_Immed + (C : Character; + File : File_Type) return Wide_Wide_Character + is + function In_Char return Character; + -- Function used to obtain additional characters it the wide character + -- sequence is more than one character long. + + function WC_In is new Char_Sequence_To_UTF_32 (In_Char); + + ------------- + -- In_Char -- + ------------- + + function In_Char return Character is + ch : constant Integer := Getc_Immed (File); + begin + if ch = EOF then + raise End_Error; + else + return Character'Val (ch); + end if; + end In_Char; + + -- Start of processing for Get_Wide_Wide_Char_Immed + + begin + FIO.Check_Read_Status (AP (File)); + return Wide_Wide_Character'Val (WC_In (C, File.WC_Method)); + end Get_Wide_Wide_Char_Immed; + + ---------- + -- Getc -- + ---------- + + function Getc (File : File_Type) return int is + ch : int; + + begin + ch := fgetc (File.Stream); + + if ch = EOF and then ferror (File.Stream) /= 0 then + raise Device_Error; + else + return ch; + end if; + end Getc; + + ---------------- + -- Getc_Immed -- + ---------------- + + function Getc_Immed (File : File_Type) return int is + ch : int; + end_of_file : int; + + procedure getc_immediate + (stream : FILEs; ch : out int; end_of_file : out int); + pragma Import (C, getc_immediate, "getc_immediate"); + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + ch := LM; + + else + getc_immediate (File.Stream, ch, end_of_file); + + if ferror (File.Stream) /= 0 then + raise Device_Error; + elsif end_of_file /= 0 then + return EOF; + end if; + end if; + + return ch; + end Getc_Immed; + + ------------------------------- + -- Initialize_Standard_Files -- + ------------------------------- + + procedure Initialize_Standard_Files is + begin + Standard_Err.Stream := stderr; + Standard_Err.Name := Err_Name'Access; + Standard_Err.Form := Null_Str'Unrestricted_Access; + Standard_Err.Mode := FCB.Out_File; + Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0; + Standard_Err.Is_Temporary_File := False; + Standard_Err.Is_System_File := True; + Standard_Err.Is_Text_File := True; + Standard_Err.Access_Method := 'T'; + Standard_Err.Self := Standard_Err; + Standard_Err.WC_Method := Default_WCEM; + + Standard_In.Stream := stdin; + Standard_In.Name := In_Name'Access; + Standard_In.Form := Null_Str'Unrestricted_Access; + Standard_In.Mode := FCB.In_File; + Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; + Standard_In.Is_Temporary_File := False; + Standard_In.Is_System_File := True; + Standard_In.Is_Text_File := True; + Standard_In.Access_Method := 'T'; + Standard_In.Self := Standard_In; + Standard_In.WC_Method := Default_WCEM; + + Standard_Out.Stream := stdout; + Standard_Out.Name := Out_Name'Access; + Standard_Out.Form := Null_Str'Unrestricted_Access; + Standard_Out.Mode := FCB.Out_File; + Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; + Standard_Out.Is_Temporary_File := False; + Standard_Out.Is_System_File := True; + Standard_Out.Is_Text_File := True; + Standard_Out.Access_Method := 'T'; + Standard_Out.Self := Standard_Out; + Standard_Out.WC_Method := Default_WCEM; + + FIO.Make_Unbuffered (AP (Standard_Out)); + FIO.Make_Unbuffered (AP (Standard_Err)); + end Initialize_Standard_Files; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (File : File_Type) return Boolean is + begin + return FIO.Is_Open (AP (File)); + end Is_Open; + + ---------- + -- Line -- + ---------- + + -- Note: we assume that it is impossible in practice for the line + -- to exceed the value of Count'Last, i.e. no check is required for + -- overflow raising layout error. + + function Line (File : File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return File.Line; + end Line; + + function Line return Positive_Count is + begin + return Line (Current_Out); + end Line; + + ----------------- + -- Line_Length -- + ----------------- + + function Line_Length (File : File_Type) return Count is + begin + FIO.Check_Write_Status (AP (File)); + return File.Line_Length; + end Line_Length; + + function Line_Length return Count is + begin + return Line_Length (Current_Out); + end Line_Length; + + ---------------- + -- Look_Ahead -- + ---------------- + + procedure Look_Ahead + (File : File_Type; + Item : out Wide_Wide_Character; + End_Of_Line : out Boolean) + is + ch : int; + + -- Start of processing for Look_Ahead + + begin + FIO.Check_Read_Status (AP (File)); + + -- If we are logically before a line mark, we can return immediately + + if File.Before_LM then + End_Of_Line := True; + Item := Wide_Wide_Character'Val (0); + + -- If we are before a wide character, just return it (this can happen + -- if there are two calls to Look_Ahead in a row). + + elsif File.Before_Wide_Wide_Character then + End_Of_Line := False; + Item := File.Saved_Wide_Wide_Character; + + -- otherwise we must read a character from the input stream + + else + ch := Getc (File); + + if ch = LM + or else ch = EOF + or else (ch = EOF and then File.Is_Regular_File) + then + End_Of_Line := True; + Ungetc (ch, File); + Item := Wide_Wide_Character'Val (0); + + -- Case where character obtained does not represent the start of an + -- encoded sequence so it stands for itself and we can unget it with + -- no difficulty. + + elsif not Is_Start_Of_Encoding + (Character'Val (ch), File.WC_Method) + then + End_Of_Line := False; + Ungetc (ch, File); + Item := Wide_Wide_Character'Val (ch); + + -- For the start of an encoding, we read the character using the + -- Get_Wide_Wide_Char routine. It will occupy more than one byte so + -- we can't put it back with ungetc. Instead we save it in the + -- control block, setting a flag that everyone interested in reading + -- characters must test before reading the stream. + + else + Item := Get_Wide_Wide_Char (Character'Val (ch), File); + End_Of_Line := False; + File.Saved_Wide_Wide_Character := Item; + File.Before_Wide_Wide_Character := True; + end if; + end if; + end Look_Ahead; + + procedure Look_Ahead + (Item : out Wide_Wide_Character; + End_Of_Line : out Boolean) + is + begin + Look_Ahead (Current_In, Item, End_Of_Line); + end Look_Ahead; + + ---------- + -- Mode -- + ---------- + + function Mode (File : File_Type) return File_Mode is + begin + return To_TIO (FIO.Mode (AP (File))); + end Mode; + + ---------- + -- Name -- + ---------- + + function Name (File : File_Type) return String is + begin + return FIO.Name (AP (File)); + end Name; + + -------------- + -- New_Line -- + -------------- + + procedure New_Line + (File : File_Type; + Spacing : Positive_Count := 1) + is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not Spacing'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Write_Status (AP (File)); + + for K in 1 .. Spacing loop + Putc (LM, File); + File.Line := File.Line + 1; + + if File.Page_Length /= 0 + and then File.Line > File.Page_Length + then + Putc (PM, File); + File.Line := 1; + File.Page := File.Page + 1; + end if; + end loop; + + File.Col := 1; + end New_Line; + + procedure New_Line (Spacing : Positive_Count := 1) is + begin + New_Line (Current_Out, Spacing); + end New_Line; + + -------------- + -- New_Page -- + -------------- + + procedure New_Page (File : File_Type) is + begin + FIO.Check_Write_Status (AP (File)); + + if File.Col /= 1 or else File.Line = 1 then + Putc (LM, File); + end if; + + Putc (PM, File); + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + end New_Page; + + procedure New_Page is + begin + New_Page (Current_Out); + end New_Page; + + ----------- + -- Nextc -- + ----------- + + function Nextc (File : File_Type) return int is + ch : int; + + begin + ch := fgetc (File.Stream); + + if ch = EOF then + if ferror (File.Stream) /= 0 then + raise Device_Error; + end if; + + else + if ungetc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end if; + + return ch; + end Nextc; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + Name : String; + Form : String := "") + is + Dummy_File_Control_Block : Wide_Wide_Text_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'W', + Creat => False, + Text => True); + + File.Self := File; + Set_WCEM (File); + end Open; + + ---------- + -- Page -- + ---------- + + -- Note: we assume that it is impossible in practice for the page + -- to exceed the value of Count'Last, i.e. no check is required for + -- overflow raising layout error. + + function Page (File : File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return File.Page; + end Page; + + function Page return Positive_Count is + begin + return Page (Current_Out); + end Page; + + ----------------- + -- Page_Length -- + ----------------- + + function Page_Length (File : File_Type) return Count is + begin + FIO.Check_Write_Status (AP (File)); + return File.Page_Length; + end Page_Length; + + function Page_Length return Count is + begin + return Page_Length (Current_Out); + end Page_Length; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Wide_Wide_Character) + is + procedure Out_Char (C : Character); + -- Procedure to output one character of a wide character sequence + + procedure WC_Out is new UTF_32_To_Char_Sequence (Out_Char); + + -------------- + -- Out_Char -- + -------------- + + procedure Out_Char (C : Character) is + begin + Putc (Character'Pos (C), File); + end Out_Char; + + -- Start of processing for Put + + begin + FIO.Check_Write_Status (AP (File)); + WC_Out (Wide_Wide_Character'Pos (Item), File.WC_Method); + File.Col := File.Col + 1; + end Put; + + procedure Put (Item : Wide_Wide_Character) is + begin + Put (Current_Out, Item); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Wide_Wide_String) + is + begin + for J in Item'Range loop + Put (File, Item (J)); + end loop; + end Put; + + procedure Put (Item : Wide_Wide_String) is + begin + Put (Current_Out, Item); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line + (File : File_Type; + Item : Wide_Wide_String) + is + begin + Put (File, Item); + New_Line (File); + end Put_Line; + + procedure Put_Line (Item : Wide_Wide_String) is + begin + Put (Current_Out, Item); + New_Line (Current_Out); + end Put_Line; + + ---------- + -- Putc -- + ---------- + + procedure Putc (ch : int; File : File_Type) is + begin + if fputc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end Putc; + + ---------- + -- Read -- + ---------- + + -- This is the primitive Stream Read routine, used when a Text_IO file + -- is treated directly as a stream using Text_IO.Streams.Stream. + + procedure Read + (File : in out Wide_Wide_Text_AFCB; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset) + is + Discard_ch : int; + pragma Unreferenced (Discard_ch); + + begin + -- Need to deal with Before_Wide_Wide_Character ??? + + if File.Mode /= FCB.In_File then + raise Mode_Error; + end if; + + -- Deal with case where our logical and physical position do not match + -- because of being after an LM or LM-PM sequence when in fact we are + -- logically positioned before it. + + if File.Before_LM then + + -- If we are before a PM, then it is possible for a stream read + -- to leave us after the LM and before the PM, which is a bit + -- odd. The easiest way to deal with this is to unget the PM, + -- so we are indeed positioned between the characters. This way + -- further stream read operations will work correctly, and the + -- effect on text processing is a little weird, but what can + -- be expected if stream and text input are mixed this way? + + if File.Before_LM_PM then + Discard_ch := ungetc (PM, File.Stream); + File.Before_LM_PM := False; + end if; + + File.Before_LM := False; + + Item (Item'First) := Stream_Element (Character'Pos (ASCII.LF)); + + if Item'Length = 1 then + Last := Item'Last; + + else + Last := + Item'First + + Stream_Element_Offset + (fread (buffer => Item'Address, + index => size_t (Item'First + 1), + size => 1, + count => Item'Length - 1, + stream => File.Stream)); + end if; + + return; + end if; + + -- Now we do the read. Since this is a text file, it is normally in + -- text mode, but stream data must be read in binary mode, so we + -- temporarily set binary mode for the read, resetting it after. + -- These calls have no effect in a system (like Unix) where there is + -- no distinction between text and binary files. + + set_binary_mode (fileno (File.Stream)); + + Last := + Item'First + + Stream_Element_Offset + (fread (Item'Address, 1, Item'Length, File.Stream)) - 1; + + if Last < Item'Last then + if ferror (File.Stream) /= 0 then + raise Device_Error; + end if; + end if; + + set_text_mode (fileno (File.Stream)); + end Read; + + ----------- + -- Reset -- + ----------- + + procedure Reset + (File : in out File_Type; + Mode : File_Mode) + is + begin + -- Don't allow change of mode for current file (RM A.10.2(5)) + + if (File = Current_In or else + File = Current_Out or else + File = Current_Error) + and then To_FCB (Mode) /= File.Mode + then + raise Mode_Error; + end if; + + Terminate_Line (File); + FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); + File.Page := 1; + File.Line := 1; + File.Col := 1; + File.Line_Length := 0; + File.Page_Length := 0; + File.Before_LM := False; + File.Before_LM_PM := False; + end Reset; + + procedure Reset (File : in out File_Type) is + begin + Terminate_Line (File); + FIO.Reset (AP (File)'Unrestricted_Access); + File.Page := 1; + File.Line := 1; + File.Col := 1; + File.Line_Length := 0; + File.Page_Length := 0; + File.Before_LM := False; + File.Before_LM_PM := False; + end Reset; + + ------------- + -- Set_Col -- + ------------- + + procedure Set_Col + (File : File_Type; + To : Positive_Count) + is + ch : int; + + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_File_Open (AP (File)); + + if To = File.Col then + return; + end if; + + if Mode (File) >= Out_File then + if File.Line_Length /= 0 and then To > File.Line_Length then + raise Layout_Error; + end if; + + if To < File.Col then + New_Line (File); + end if; + + while File.Col < To loop + Put (File, ' '); + end loop; + + else + loop + ch := Getc (File); + + if ch = EOF then + raise End_Error; + + elsif ch = LM then + File.Line := File.Line + 1; + File.Col := 1; + + elsif ch = PM and then File.Is_Regular_File then + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + + elsif To = File.Col then + Ungetc (ch, File); + return; + + else + File.Col := File.Col + 1; + end if; + end loop; + end if; + end Set_Col; + + procedure Set_Col (To : Positive_Count) is + begin + Set_Col (Current_Out, To); + end Set_Col; + + --------------- + -- Set_Error -- + --------------- + + procedure Set_Error (File : File_Type) is + begin + FIO.Check_Write_Status (AP (File)); + Current_Err := File; + end Set_Error; + + --------------- + -- Set_Input -- + --------------- + + procedure Set_Input (File : File_Type) is + begin + FIO.Check_Read_Status (AP (File)); + Current_In := File; + end Set_Input; + + -------------- + -- Set_Line -- + -------------- + + procedure Set_Line + (File : File_Type; + To : Positive_Count) + is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_File_Open (AP (File)); + + if To = File.Line then + return; + end if; + + if Mode (File) >= Out_File then + if File.Page_Length /= 0 and then To > File.Page_Length then + raise Layout_Error; + end if; + + if To < File.Line then + New_Page (File); + end if; + + while File.Line < To loop + New_Line (File); + end loop; + + else + while To /= File.Line loop + Skip_Line (File); + end loop; + end if; + end Set_Line; + + procedure Set_Line (To : Positive_Count) is + begin + Set_Line (Current_Out, To); + end Set_Line; + + --------------------- + -- Set_Line_Length -- + --------------------- + + procedure Set_Line_Length (File : File_Type; To : Count) is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Write_Status (AP (File)); + File.Line_Length := To; + end Set_Line_Length; + + procedure Set_Line_Length (To : Count) is + begin + Set_Line_Length (Current_Out, To); + end Set_Line_Length; + + ---------------- + -- Set_Output -- + ---------------- + + procedure Set_Output (File : File_Type) is + begin + FIO.Check_Write_Status (AP (File)); + Current_Out := File; + end Set_Output; + + --------------------- + -- Set_Page_Length -- + --------------------- + + procedure Set_Page_Length (File : File_Type; To : Count) is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Write_Status (AP (File)); + File.Page_Length := To; + end Set_Page_Length; + + procedure Set_Page_Length (To : Count) is + begin + Set_Page_Length (Current_Out, To); + end Set_Page_Length; + + -------------- + -- Set_WCEM -- + -------------- + + procedure Set_WCEM (File : in out File_Type) is + Start : Natural; + Stop : Natural; + + begin + File.WC_Method := WCEM_Brackets; + FIO.Form_Parameter (File.Form.all, "wcem", Start, Stop); + + if Start = 0 then + File.WC_Method := WCEM_Brackets; + + else + if Stop = Start then + for J in WC_Encoding_Letters'Range loop + if File.Form (Start) = WC_Encoding_Letters (J) then + File.WC_Method := J; + return; + end if; + end loop; + end if; + + Close (File); + raise Use_Error with "invalid WCEM form parameter"; + end if; + end Set_WCEM; + + --------------- + -- Skip_Line -- + --------------- + + procedure Skip_Line + (File : File_Type; + Spacing : Positive_Count := 1) + is + ch : int; + + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not Spacing'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Read_Status (AP (File)); + + for L in 1 .. Spacing loop + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + + else + ch := Getc (File); + + -- If at end of file now, then immediately raise End_Error. Note + -- that we can never be positioned between a line mark and a page + -- mark, so if we are at the end of file, we cannot logically be + -- before the implicit page mark that is at the end of the file. + + -- For the same reason, we do not need an explicit check for a + -- page mark. If there is a FF in the middle of a line, the file + -- is not in canonical format and we do not care about the page + -- numbers for files other than ones in canonical format. + + if ch = EOF then + raise End_Error; + end if; + + -- If not at end of file, then loop till we get to an LM or EOF. + -- The latter case happens only in non-canonical files where the + -- last line is not terminated by LM, but we don't want to blow + -- up for such files, so we assume an implicit LM in this case. + + loop + exit when ch = LM or else ch = EOF; + ch := Getc (File); + end loop; + end if; + + -- We have got past a line mark, now, for a regular file only, + -- see if a page mark immediately follows this line mark and + -- if so, skip past the page mark as well. We do not do this + -- for non-regular files, since it would cause an undesirable + -- wait for an additional character. + + File.Col := 1; + File.Line := File.Line + 1; + + if File.Before_LM_PM then + File.Page := File.Page + 1; + File.Line := 1; + File.Before_LM_PM := False; + + elsif File.Is_Regular_File then + ch := Getc (File); + + -- Page mark can be explicit, or implied at the end of the file + + if (ch = PM or else ch = EOF) + and then File.Is_Regular_File + then + File.Page := File.Page + 1; + File.Line := 1; + else + Ungetc (ch, File); + end if; + end if; + end loop; + + File.Before_Wide_Wide_Character := False; + end Skip_Line; + + procedure Skip_Line (Spacing : Positive_Count := 1) is + begin + Skip_Line (Current_In, Spacing); + end Skip_Line; + + --------------- + -- Skip_Page -- + --------------- + + procedure Skip_Page (File : File_Type) is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + -- If at page mark already, just skip it + + if File.Before_LM_PM then + File.Before_LM := False; + File.Before_LM_PM := False; + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + return; + end if; + + -- This is a bit tricky, if we are logically before an LM then + -- it is not an error if we are at an end of file now, since we + -- are not really at it. + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + ch := Getc (File); + + -- Otherwise we do raise End_Error if we are at the end of file now + + else + ch := Getc (File); + + if ch = EOF then + raise End_Error; + end if; + end if; + + -- Now we can just rumble along to the next page mark, or to the + -- end of file, if that comes first. The latter case happens when + -- the page mark is implied at the end of file. + + loop + exit when ch = EOF + or else (ch = PM and then File.Is_Regular_File); + ch := Getc (File); + end loop; + + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + File.Before_Wide_Wide_Character := False; + end Skip_Page; + + procedure Skip_Page is + begin + Skip_Page (Current_In); + end Skip_Page; + + -------------------- + -- Standard_Error -- + -------------------- + + function Standard_Error return File_Type is + begin + return Standard_Err; + end Standard_Error; + + function Standard_Error return File_Access is + begin + return Standard_Err'Access; + end Standard_Error; + + -------------------- + -- Standard_Input -- + -------------------- + + function Standard_Input return File_Type is + begin + return Standard_In; + end Standard_Input; + + function Standard_Input return File_Access is + begin + return Standard_In'Access; + end Standard_Input; + + --------------------- + -- Standard_Output -- + --------------------- + + function Standard_Output return File_Type is + begin + return Standard_Out; + end Standard_Output; + + function Standard_Output return File_Access is + begin + return Standard_Out'Access; + end Standard_Output; + + -------------------- + -- Terminate_Line -- + -------------------- + + procedure Terminate_Line (File : File_Type) is + begin + FIO.Check_File_Open (AP (File)); + + -- For file other than In_File, test for needing to terminate last line + + if Mode (File) /= In_File then + + -- If not at start of line definition need new line + + if File.Col /= 1 then + New_Line (File); + + -- For files other than standard error and standard output, we + -- make sure that an empty file has a single line feed, so that + -- it is properly formatted. We avoid this for the standard files + -- because it is too much of a nuisance to have these odd line + -- feeds when nothing has been written to the file. + + elsif (File /= Standard_Err and then File /= Standard_Out) + and then (File.Line = 1 and then File.Page = 1) + then + New_Line (File); + end if; + end if; + end Terminate_Line; + + ------------ + -- Ungetc -- + ------------ + + procedure Ungetc (ch : int; File : File_Type) is + begin + if ch /= EOF then + if ungetc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end if; + end Ungetc; + + ----------- + -- Write -- + ----------- + + -- This is the primitive Stream Write routine, used when a Text_IO file + -- is treated directly as a stream using Text_IO.Streams.Stream. + + procedure Write + (File : in out Wide_Wide_Text_AFCB; + Item : Stream_Element_Array) + is + pragma Warnings (Off, File); + -- Because in this implementation we don't need IN OUT, we only read + + Siz : constant size_t := Item'Length; + + begin + if File.Mode = FCB.In_File then + raise Mode_Error; + end if; + + -- Now we do the write. Since this is a text file, it is normally in + -- text mode, but stream data must be written in binary mode, so we + -- temporarily set binary mode for the write, resetting it after. + -- These calls have no effect in a system (like Unix) where there is + -- no distinction between text and binary files. + + set_binary_mode (fileno (File.Stream)); + + if fwrite (Item'Address, 1, Siz, File.Stream) /= Siz then + raise Device_Error; + end if; + + set_text_mode (fileno (File.Stream)); + end Write; + +begin + -- Initialize Standard Files + + for J in WC_Encoding_Method loop + if WC_Encoding = WC_Encoding_Letters (J) then + Default_WCEM := J; + end if; + end loop; + + Initialize_Standard_Files; + + FIO.Chain_File (AP (Standard_In)); + FIO.Chain_File (AP (Standard_Out)); + FIO.Chain_File (AP (Standard_Err)); + +end Ada.Wide_Wide_Text_IO; diff --git a/gcc/ada/a-ztexio.ads b/gcc/ada/a-ztexio.ads new file mode 100644 index 000000000..6c75acd19 --- /dev/null +++ b/gcc/ada/a-ztexio.ads @@ -0,0 +1,498 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 + -- enough so that the assumption that the Line, Column and Page + -- counts can never exceed this value is a valid assumption. + + 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 of a kludge, 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 new file mode 100644 index 000000000..a4eaed969 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Float_Aux; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Wide_Text_IO.Fixed_IO is + + subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Wide_Text_IO.Float_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + Aux.Get (TFT (File), Long_Long_Float (Item), Width); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + Aux.Gets (S, Long_Long_Float (Item), Last); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Aux.Put (TFT (File), Long_Long_Float (Item), Fore, Aft, Exp); + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Output, Item, Fore, Aft, Exp); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (To'First .. To'Last); + + begin + Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); + + for J in S'Range loop + To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Wide_Text_IO.Fixed_IO; diff --git a/gcc/ada/a-ztfiio.ads b/gcc/ada/a-ztfiio.ads new file mode 100644 index 000000000..cd72fc6ac --- /dev/null +++ b/gcc/ada/a-ztfiio.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . F I X E D _ I O -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Fixed_IO is a subpackage of +-- Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading +-- the necessary code if Fixed_IO is not instantiated. See the routine +-- Rtsfind.Text_IO_Kludge for a description of how we patch up the +-- difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is delta <>; + +package Ada.Wide_Wide_Text_IO.Fixed_IO is + + Default_Fore : Field := Num'Fore; + Default_Aft : Field := Num'Aft; + Default_Exp : Field := 0; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +end Ada.Wide_Wide_Text_IO.Fixed_IO; diff --git a/gcc/ada/a-ztflau.adb b/gcc/ada/a-ztflau.adb new file mode 100644 index 000000000..5e91a9c1b --- /dev/null +++ b/gcc/ada/a-ztflau.adb @@ -0,0 +1,234 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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; + + -- Based cases + + 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 new file mode 100644 index 000000000..4323c49c2 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..1530bcba6 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Float_Aux; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Wide_Text_IO.Float_IO is + + subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Wide_Text_IO.Float_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + Aux.Get (TFT (File), Long_Long_Float (Item), Width); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + Aux.Gets (S, Long_Long_Float (Item), Last); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Aux.Put (TFT (File), Long_Long_Float (Item), Fore, Aft, Exp); + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Output, Item, Fore, Aft, Exp); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (To'First .. To'Last); + + begin + Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); + + for J in S'Range loop + To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Wide_Text_IO.Float_IO; diff --git a/gcc/ada/a-ztflio.ads b/gcc/ada/a-ztflio.ads new file mode 100644 index 000000000..00b0b05bc --- /dev/null +++ b/gcc/ada/a-ztflio.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . F L O A T _ I O -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Float_IO is a subpackage +-- of Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading +-- the necessary code if Float_IO is not instantiated. See the routine +-- Rtsfind.Text_IO_Kludge for a description of how we patch up the +-- difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is digits <>; + +package Ada.Wide_Wide_Text_IO.Float_IO is + + Default_Fore : Field := 2; + Default_Aft : Field := Num'Digits - 1; + Default_Exp : Field := 3; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +end Ada.Wide_Wide_Text_IO.Float_IO; diff --git a/gcc/ada/a-ztgeau.adb b/gcc/ada/a-ztgeau.adb new file mode 100644 index 000000000..27de665b1 --- /dev/null +++ b/gcc/ada/a-ztgeau.adb @@ -0,0 +1,515 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 + 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 new file mode 100644 index 000000000..26ca68e9a --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..743e5590d --- /dev/null +++ b/gcc/ada/a-ztinau.adb @@ -0,0 +1,291 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 + 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 new file mode 100644 index 000000000..8c041bfc3 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..93e4d2809 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Integer_Aux; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Wide_Text_IO.Integer_IO is + + Need_LLI : constant Boolean := Num'Base'Size > Integer'Size; + -- Throughout this generic body, we distinguish between the case where type + -- Integer is acceptable, and where a Long_Long_Integer is needed. This + -- Boolean is used to test for these cases and since it is a constant, only + -- code for the relevant case will be included in the instance. + + subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Wide_Text_IO.Integer_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + if Need_LLI then + Aux.Get_LLI (TFT (File), Long_Long_Integer (Item), Width); + else + Aux.Get_Int (TFT (File), Integer (Item), Width); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + if Need_LLI then + Aux.Gets_LLI (S, Long_Long_Integer (Item), Last); + else + Aux.Gets_Int (S, Integer (Item), Last); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + if Need_LLI then + Aux.Put_LLI (TFT (File), Long_Long_Integer (Item), Width, Base); + else + Aux.Put_Int (TFT (File), Integer (Item), Width, Base); + end if; + end Put; + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + Put (Current_Output, Item, Width, Base); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Base : Number_Base := Default_Base) + is + S : String (To'First .. To'Last); + + begin + if Need_LLI then + Aux.Puts_LLI (S, Long_Long_Integer (Item), Base); + else + Aux.Puts_Int (S, Integer (Item), Base); + end if; + + for J in S'Range loop + To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Wide_Text_IO.Integer_IO; diff --git a/gcc/ada/a-ztinio.ads b/gcc/ada/a-ztinio.ads new file mode 100644 index 000000000..4358e7b1e --- /dev/null +++ b/gcc/ada/a-ztinio.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Integer_IO is a subpackage +-- of Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading +-- the necessary code if Integer_IO is not instantiated. See the routine +-- Rtsfind.Text_IO_Kludge for a description of how we patch up the +-- difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is range <>; + +package Ada.Wide_Wide_Text_IO.Integer_IO is + + Default_Width : Field := Num'Width; + Default_Base : Number_Base := 10; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Base : Number_Base := Default_Base); + +end Ada.Wide_Wide_Text_IO.Integer_IO; diff --git a/gcc/ada/a-ztmoau.adb b/gcc/ada/a-ztmoau.adb new file mode 100644 index 000000000..4ade58997 --- /dev/null +++ b/gcc/ada/a-ztmoau.adb @@ -0,0 +1,301 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 + 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 new file mode 100644 index 000000000..0caffa0d4 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..041f8dc7c --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Modular_Aux; + +with System.Unsigned_Types; use System.Unsigned_Types; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Wide_Text_IO.Modular_IO is + + subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Wide_Text_IO.Modular_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + if Num'Size > Unsigned'Size then + Aux.Get_LLU (TFT (File), Long_Long_Unsigned (Item), Width); + else + Aux.Get_Uns (TFT (File), Unsigned (Item), Width); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + if Num'Size > Unsigned'Size then + Aux.Gets_LLU (S, Long_Long_Unsigned (Item), Last); + else + Aux.Gets_Uns (S, Unsigned (Item), Last); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + if Num'Size > Unsigned'Size then + Aux.Put_LLU (TFT (File), Long_Long_Unsigned (Item), Width, Base); + else + Aux.Put_Uns (TFT (File), Unsigned (Item), Width, Base); + end if; + end Put; + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + Put (Current_Output, Item, Width, Base); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Base : Number_Base := Default_Base) + is + S : String (To'First .. To'Last); + + begin + if Num'Size > Unsigned'Size then + Aux.Puts_LLU (S, Long_Long_Unsigned (Item), Base); + else + Aux.Puts_Uns (S, Unsigned (Item), Base); + end if; + + for J in S'Range loop + To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Wide_Text_IO.Modular_IO; diff --git a/gcc/ada/a-ztmoio.ads b/gcc/ada/a-ztmoio.ads new file mode 100644 index 000000000..27dec484d --- /dev/null +++ b/gcc/ada/a-ztmoio.ads @@ -0,0 +1,80 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . M O D U L A R _ I O -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Modular_IO is a subpackage of +-- Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading the +-- necessary code if Modular_IO is not instantiated. See the routine +-- Rtsfind.Text_IO_Kludge for a description of how we patch up the +-- difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is mod <>; + +package Ada.Wide_Wide_Text_IO.Modular_IO is + + Default_Width : Field := Num'Width; + Default_Base : Number_Base := 10; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Base : Number_Base := Default_Base); + +end Ada.Wide_Wide_Text_IO.Modular_IO; diff --git a/gcc/ada/a-zttest.adb b/gcc/ada/a-zttest.adb new file mode 100644 index 000000000..c4626a89f --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.File_IO; + +package body Ada.Wide_Wide_Text_IO.Text_Streams is + + ------------ + -- Stream -- + ------------ + + function Stream (File : File_Type) return Stream_Access is + begin + System.File_IO.Check_File_Open (FCB.AFCB_Ptr (File)); + return Stream_Access (File); + end Stream; + +end Ada.Wide_Wide_Text_IO.Text_Streams; diff --git a/gcc/ada/a-zttest.ads b/gcc/ada/a-zttest.ads new file mode 100644 index 000000000..1599253d2 --- /dev/null +++ b/gcc/ada/a-zttest.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . T E X T _ S T R E A M S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Streams; + +package Ada.Wide_Wide_Text_IO.Text_Streams is + + type Stream_Access is access all Streams.Root_Stream_Type'Class; + + function Stream (File : File_Type) return Stream_Access; + +end Ada.Wide_Wide_Text_IO.Text_Streams; diff --git a/gcc/ada/a-zzboio.adb b/gcc/ada/a-zzboio.adb new file mode 100644 index 000000000..c1efb2f79 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; use Ada.Wide_Wide_Text_IO; +with Ada.Unchecked_Deallocation; + +package body Ada.Wide_Wide_Text_IO.Wide_Wide_Bounded_IO is + + type Wide_Wide_String_Access is access all Wide_Wide_String; + + procedure Free (WWSA : in out Wide_Wide_String_Access); + -- Perform an unchecked deallocation of a non-null string + + ---------- + -- Free -- + ---------- + + procedure Free (WWSA : in out Wide_Wide_String_Access) is + Null_Wide_Wide_String : constant Wide_Wide_String := ""; + + procedure Deallocate is + new Ada.Unchecked_Deallocation ( + Wide_Wide_String, Wide_Wide_String_Access); + + begin + -- Do not try to free statically allocated null string + + if WWSA.all /= Null_Wide_Wide_String then + Deallocate (WWSA); + end if; + end Free; + + -------------- + -- Get_Line -- + -------------- + + function Get_Line return Wide_Wide_Bounded.Bounded_Wide_Wide_String is + begin + return Wide_Wide_Bounded.To_Bounded_Wide_Wide_String (Get_Line); + end Get_Line; + + -------------- + -- Get_Line -- + -------------- + + function Get_Line + (File : File_Type) return Wide_Wide_Bounded.Bounded_Wide_Wide_String + is + begin + return Wide_Wide_Bounded.To_Bounded_Wide_Wide_String (Get_Line (File)); + end Get_Line; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line + (Item : out Wide_Wide_Bounded.Bounded_Wide_Wide_String) + is + Buffer : Wide_Wide_String (1 .. 1000); + Last : Natural; + Str1 : Wide_Wide_String_Access; + Str2 : Wide_Wide_String_Access; + + begin + Get_Line (Buffer, Last); + Str1 := new Wide_Wide_String'(Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Str2 := new Wide_Wide_String'(Str1.all & Buffer (1 .. Last)); + Free (Str1); + Str1 := Str2; + end loop; + + Item := Wide_Wide_Bounded.To_Bounded_Wide_Wide_String (Str1.all); + end Get_Line; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line + (File : File_Type; + Item : out Wide_Wide_Bounded.Bounded_Wide_Wide_String) + is + Buffer : Wide_Wide_String (1 .. 1000); + Last : Natural; + Str1 : Wide_Wide_String_Access; + Str2 : Wide_Wide_String_Access; + + begin + Get_Line (File, Buffer, Last); + Str1 := new Wide_Wide_String'(Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Str2 := new Wide_Wide_String'(Str1.all & Buffer (1 .. Last)); + Free (Str1); + Str1 := Str2; + end loop; + + Item := Wide_Wide_Bounded.To_Bounded_Wide_Wide_String (Str1.all); + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put + (Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String) + is + begin + Put (Wide_Wide_Bounded.To_Wide_Wide_String (Item)); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String) + is + begin + Put (File, Wide_Wide_Bounded.To_Wide_Wide_String (Item)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line + (Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String) + is + begin + Put_Line (Wide_Wide_Bounded.To_Wide_Wide_String (Item)); + end Put_Line; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line + (File : File_Type; + Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String) + is + begin + Put_Line (File, Wide_Wide_Bounded.To_Wide_Wide_String (Item)); + end Put_Line; + +end Ada.Wide_Wide_Text_IO.Wide_Wide_Bounded_IO; diff --git a/gcc/ada/a-zzboio.ads b/gcc/ada/a-zzboio.ads new file mode 100644 index 000000000..68157e965 --- /dev/null +++ b/gcc/ada/a-zzboio.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.WIDE_WIDE_TEXT_IO.WIDE_WIDE_BOUNDED_IO -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Wide_Bounded; + +generic + with package Wide_Wide_Bounded is + new Ada.Strings.Wide_Wide_Bounded.Generic_Bounded_Length (<>); + +package Ada.Wide_Wide_Text_IO.Wide_Wide_Bounded_IO is + + function Get_Line return Wide_Wide_Bounded.Bounded_Wide_Wide_String; + + function Get_Line + (File : File_Type) return Wide_Wide_Bounded.Bounded_Wide_Wide_String; + + procedure Get_Line + (Item : out Wide_Wide_Bounded.Bounded_Wide_Wide_String); + + procedure Get_Line + (File : File_Type; + Item : out Wide_Wide_Bounded.Bounded_Wide_Wide_String); + + procedure Put + (Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String); + + procedure Put + (File : File_Type; + Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String); + + procedure Put_Line + (Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String); + + procedure Put_Line + (File : File_Type; + Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String); + +end Ada.Wide_Wide_Text_IO.Wide_Wide_Bounded_IO; diff --git a/gcc/ada/a-zzunio.ads b/gcc/ada/a-zzunio.ads new file mode 100644 index 000000000..1695b0629 --- /dev/null +++ b/gcc/ada/a-zzunio.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.WIDE_WIDE_TEXT_IO.WIDE_WIDE_UNBOUNDED_IO -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: historically GNAT provided these subprograms as a child of the +-- package Ada.Strings.Wide_Wide_Unbounded. So we implement this new Ada 2005 +-- package by renaming the subprograms in that child. This is a more +-- straightforward implementation anyway, since we need access to the +-- internal representation of Unbounded_Wide_Wide_String. + +with Ada.Strings.Wide_Wide_Unbounded; +with Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO; + +package Ada.Wide_Wide_Text_IO.Wide_Wide_Unbounded_IO is + + procedure Put + (File : File_Type; + Item : Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Put; + + procedure Put + (Item : Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Put; + + procedure Put_Line + (File : Wide_Wide_Text_IO.File_Type; + Item : Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Put_Line; + + procedure Put_Line + (Item : Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Put_Line; + + function Get_Line + (File : File_Type) + return Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Get_Line; + + function Get_Line + return Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Get_Line; + + procedure Get_Line + (File : File_Type; + Item : out Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Get_Line; + + procedure Get_Line + (Item : out Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Get_Line; + +end Ada.Wide_Wide_Text_IO.Wide_Wide_Unbounded_IO; diff --git a/gcc/ada/ada.ads b/gcc/ada/ada.ads new file mode 100644 index 000000000..8c860110f --- /dev/null +++ b/gcc/ada/ada.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 Pure; + +end Ada; diff --git a/gcc/ada/adadecode.c b/gcc/ada/adadecode.c new file mode 100644 index 000000000..43f14f127 --- /dev/null +++ b/gcc/ada/adadecode.c @@ -0,0 +1,404 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * A D A D E C O D E * + * * + * C Implementation File * + * * + * 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. * + * * + ****************************************************************************/ + + +#if defined(IN_RTS) +#include "tconfig.h" +#include "tsystem.h" +#elif defined(IN_GCC) +#include "config.h" +#include "system.h" +#endif + +#include +#include +#include + +#include "adaint.h" + +#ifndef ISDIGIT +#define ISDIGIT(c) isdigit(c) +#endif + +#ifndef PARMS +#define PARMS(ARGS) ARGS +#endif + +#include "adadecode.h" + +static void add_verbose (const char *, char *); +static int has_prefix (const char *, const char *); +static int has_suffix (const char *, const char *); + +/* This is a safe version of strcpy that can be used with overlapped + pointers. Does nothing if s2 <= s1. */ +static void ostrcpy (char *s1, char *s2); + +/* Set to nonzero if we have written any verbose info. */ +static int verbose_info; + +/* Add TEXT to end of ADA_NAME, putting a leading " (" or ", ", depending + on VERBOSE_INFO. */ + +static void add_verbose (const char *text, char *ada_name) +{ + strcat (ada_name, verbose_info ? ", " : " ("); + strcat (ada_name, text); + + verbose_info = 1; +} + +/* Returns 1 if NAME starts with PREFIX. */ + +static int +has_prefix (const char *name, const char *prefix) +{ + return strncmp (name, prefix, strlen (prefix)) == 0; +} + +/* Returns 1 if NAME ends with SUFFIX. */ + +static int +has_suffix (const char *name, const char *suffix) +{ + int nlen = strlen (name); + int slen = strlen (suffix); + + return nlen > slen && strncmp (name + nlen - slen, suffix, slen) == 0; +} + +/* Safe overlapped pointers version of strcpy. */ + +static void +ostrcpy (char *s1, char *s2) +{ + if (s2 > s1) + { + while (*s2) *s1++ = *s2++; + *s1 = '\0'; + } +} + +/* This function will return the Ada name from the encoded form. + The Ada coding is done in exp_dbug.ads and this is the inverse function. + see exp_dbug.ads for full encoding rules, a short description is added + below. Right now only objects and routines are handled. Ada types are + stripped of their encodings. + + CODED_NAME is the encoded entity name. + + ADA_NAME is a pointer to a buffer, it will receive the Ada name. A safe + size for this buffer is: strlen (coded_name) * 2 + 60. (60 is for the + verbose information). + + VERBOSE is nonzero if more information about the entity is to be + added at the end of the Ada name and surrounded by ( and ). + + Coded name Ada name verbose info + --------------------------------------------------------------------- + _ada_xyz xyz library level + x__y__z x.y.z + x__yTKB x.y task body + x__yB x.y task body + x__yX x.y body nested + x__yXb x.y body nested + xTK__y x.y in task + x__y$2 x.y overloaded + x__y__3 x.y overloaded + x__Oabs "abs" + x__Oand "and" + x__Omod "mod" + x__Onot "not" + x__Oor "or" + x__Orem "rem" + x__Oxor "xor" + x__Oeq "=" + x__One "/=" + x__Olt "<" + x__Ole "<=" + x__Ogt ">" + x__Oge ">=" + x__Oadd "+" + x__Osubtract "-" + x__Oconcat "&" + x__Omultiply "*" + x__Odivide "/" + x__Oexpon "**" */ + +void +__gnat_decode (const char *coded_name, char *ada_name, int verbose) +{ + int lib_subprog = 0; + int overloaded = 0; + int task_body = 0; + int in_task = 0; + int body_nested = 0; + + /* Check for library level subprogram. */ + if (has_prefix (coded_name, "_ada_")) + { + strcpy (ada_name, coded_name + 5); + lib_subprog = 1; + } + else + strcpy (ada_name, coded_name); + + /* Check for the first triple underscore in the name. This indicates + that the name represents a type with encodings; in this case, we + need to strip the encodings. */ + { + char *encodings; + + if ((encodings = (char *) strstr (ada_name, "___")) != NULL) + { + *encodings = '\0'; + } + } + + /* Check for task body. */ + if (has_suffix (ada_name, "TKB")) + { + ada_name[strlen (ada_name) - 3] = '\0'; + task_body = 1; + } + + if (has_suffix (ada_name, "B")) + { + ada_name[strlen (ada_name) - 1] = '\0'; + task_body = 1; + } + + /* Check for body-nested entity: X[bn] */ + if (has_suffix (ada_name, "X")) + { + ada_name[strlen (ada_name) - 1] = '\0'; + body_nested = 1; + } + + if (has_suffix (ada_name, "Xb")) + { + ada_name[strlen (ada_name) - 2] = '\0'; + body_nested = 1; + } + + if (has_suffix (ada_name, "Xn")) + { + ada_name[strlen (ada_name) - 2] = '\0'; + body_nested = 1; + } + + /* Change instance of TK__ (object declared inside a task) to __. */ + { + char *tktoken; + + while ((tktoken = (char *) strstr (ada_name, "TK__")) != NULL) + { + ostrcpy (tktoken, tktoken + 2); + in_task = 1; + } + } + + /* Check for overloading: name terminated by $nn or __nn. */ + { + int len = strlen (ada_name); + int n_digits = 0; + + if (len > 1) + while (ISDIGIT ((int) ada_name[(int) len - 1 - n_digits])) + n_digits++; + + /* Check if we have $ or __ before digits. */ + if (ada_name[len - 1 - n_digits] == '$') + { + ada_name[len - 1 - n_digits] = '\0'; + overloaded = 1; + } + else if (ada_name[len - 1 - n_digits] == '_' + && ada_name[len - 1 - n_digits - 1] == '_') + { + ada_name[len - 1 - n_digits - 1] = '\0'; + overloaded = 1; + } + } + + /* Check for nested subprogram ending in .nnnn and strip suffix. */ + { + int last = strlen (ada_name) - 1; + + while (ISDIGIT (ada_name[last]) && last > 0) + { + last--; + } + + if (ada_name[last] == '.') + { + ada_name[last] = (char) 0; + } + } + + /* Change all "__" to ".". */ + { + int len = strlen (ada_name); + int k = 0; + + while (k < len) + { + if (ada_name[k] == '_' && ada_name[k+1] == '_') + { + ada_name[k] = '.'; + ostrcpy (ada_name + k + 1, ada_name + k + 2); + len = len - 1; + } + k++; + } + } + + /* Checks for operator name. */ + { + const char *trans_table[][2] + = {{"Oabs", "\"abs\""}, {"Oand", "\"and\""}, {"Omod", "\"mod\""}, + {"Onot", "\"not\""}, {"Oor", "\"or\""}, {"Orem", "\"rem\""}, + {"Oxor", "\"xor\""}, {"Oeq", "\"=\""}, {"One", "\"/=\""}, + {"Olt", "\"<\""}, {"Ole", "\"<=\""}, {"Ogt", "\">\""}, + {"Oge", "\">=\""}, {"Oadd", "\"+\""}, {"Osubtract", "\"-\""}, + {"Oconcat", "\"&\""}, {"Omultiply", "\"*\""}, {"Odivide", "\"/\""}, + {"Oexpon", "\"**\""}, {NULL, NULL} }; + int k = 0; + + while (1) + { + char *optoken; + + if ((optoken = (char *) strstr (ada_name, trans_table[k][0])) != NULL) + { + int codedlen = strlen (trans_table[k][0]); + int oplen = strlen (trans_table[k][1]); + + if (codedlen > oplen) + /* We shrink the space. */ + ostrcpy (optoken, optoken + codedlen - oplen); + else if (oplen > codedlen) + { + /* We need more space. */ + int len = strlen (ada_name); + int space = oplen - codedlen; + int num_to_move = &ada_name[len] - optoken; + int t; + + for (t = 0; t < num_to_move; t++) + ada_name[len + space - t - 1] = ada_name[len - t - 1]; + } + + /* Write symbol in the space. */ + strncpy (optoken, trans_table[k][1], oplen); + } + else + k++; + + /* Check for table's ending. */ + if (trans_table[k][0] == NULL) + break; + } + } + + /* If verbose mode is on, we add some information to the Ada name. */ + if (verbose) + { + if (overloaded) + add_verbose ("overloaded", ada_name); + + if (lib_subprog) + add_verbose ("library level", ada_name); + + if (body_nested) + add_verbose ("body nested", ada_name); + + if (in_task) + add_verbose ("in task", ada_name); + + if (task_body) + add_verbose ("task body", ada_name); + + if (verbose_info == 1) + strcat (ada_name, ")"); + } +} + +#ifdef IN_GCC +char * +ada_demangle (const char *coded_name) +{ + char ada_name[2048]; + + __gnat_decode (coded_name, ada_name, 0); + return xstrdup (ada_name); +} +#endif + +void +get_encoding (const char *coded_name, char *encoding) +{ + char * dest_index = encoding; + const char *p; + int found = 0; + int count = 0; + + /* The heuristics is the following: we assume that the first triple + underscore in an encoded name indicates the beginning of the + first encoding, and that subsequent triple underscores indicate + the next encodings. We assume that the encodings are always at the + end of encoded names. */ + + for (p = coded_name; *p != '\0'; p++) + { + if (*p != '_') + count = 0; + else + if (++count == 3) + { + count = 0; + + if (found) + { + dest_index = dest_index - 2; + *dest_index++ = ':'; + } + + p++; + found = 1; + } + + if (found) + *dest_index++ = *p; + } + + *dest_index = '\0'; +} diff --git a/gcc/ada/adadecode.h b/gcc/ada/adadecode.h new file mode 100644 index 000000000..8ae890726 --- /dev/null +++ b/gcc/ada/adadecode.h @@ -0,0 +1,53 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * A D A D E C O D E * + * * + * C Header File * + * * + * 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 function will return the Ada name from the encoded form. + The Ada coding is done in exp_dbug.ads and this is the inverse function. + see exp_dbug.ads for full encoding rules, a short description is added + below. Objects and routines are fully handled; types are stripped of their + encodings. + + CODED_NAME is the encoded entity name. + ADA_NAME is a pointer to a buffer, it will receive the Ada name. A safe + size for this buffer is: strlen (coded_name) * 2 + 60. (60 is for the + verbose information). + VERBOSE is nonzero if more information about the entity is to be + added at the end of the Ada name and surrounded by ( and ). */ +extern void __gnat_decode (const char *, char *, int); + +/* This function will return the GNAT encodings, in a colon-separated list, + from the encoded form. The Ada encodings are described in exp_dbug.ads. */ +extern void get_encoding (const char *, char *); + +/* ada_demangle is added for COMPATIBILITY ONLY. It has the name of the + function used in the binutils and GDB. Always consider using __gnat_decode + instead of ada_demangle. Caller must free the pointer returned. */ +extern char *ada_demangle (const char *); diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c new file mode 100644 index 000000000..855ce3489 --- /dev/null +++ b/gcc/ada/adaint.c @@ -0,0 +1,3688 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * A D A I N T * + * * + * C Implementation File * + * * + * 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. * + * * + ****************************************************************************/ + +/* This file contains those routines named by Import pragmas in + packages in the GNAT hierarchy (especially GNAT.OS_Lib) and in + package Osint. Many of the subprograms in OS_Lib import standard + library calls directly. This file contains all other routines. */ + +#ifdef __vxworks + +/* No need to redefine exit here. */ +#undef exit + +/* We want to use the POSIX variants of include files. */ +#define POSIX +#include "vxWorks.h" + +#if defined (__mips_vxworks) +#include "cacheLib.h" +#endif /* __mips_vxworks */ + +#endif /* VxWorks */ + +#if (defined (__mips) && defined (__sgi)) || defined (__APPLE__) +#include +#endif + +#if defined (__hpux__) +#include +#include +#endif + +#ifdef VMS +#define _POSIX_EXIT 1 +#define HOST_EXECUTABLE_SUFFIX ".exe" +#define HOST_OBJECT_SUFFIX ".obj" +#endif + +#ifdef IN_RTS +#include "tconfig.h" +#include "tsystem.h" + +#include +#include +#include +#ifdef VMS +#include +#endif + +/* We don't have libiberty, so use malloc. */ +#define xmalloc(S) malloc (S) +#define xrealloc(V,S) realloc (V,S) +#else +#include "config.h" +#include "system.h" +#include "version.h" +#endif + +#if defined (__MINGW32__) + +#if defined (RTX) +#include +#include +#else +#include "mingw32.h" + +/* Current code page to use, set in initialize.c. */ +UINT CurrentCodePage; +#endif + +#include + +/* For isalpha-like tests in the compiler, we're expected to resort to + safe-ctype.h/ISALPHA. This isn't available for the runtime library + build, so we fallback on ctype.h/isalpha there. */ + +#ifdef IN_RTS +#include +#define ISALPHA isalpha +#endif + +#elif defined (__Lynx__) + +/* Lynx utime.h only defines the entities of interest to us if + defined (VMOS_DEV), so ... */ +#define VMOS_DEV +#include +#undef VMOS_DEV + +#elif !defined (VMS) +#include +#endif + +/* wait.h processing */ +#ifdef __MINGW32__ +#if OLD_MINGW +#include +#endif +#elif defined (__vxworks) && defined (__RTP__) +#include +#elif defined (__Lynx__) +/* ??? We really need wait.h and it includes resource.h on Lynx. GCC + has a resource.h header as well, included instead of the lynx + version in our setup, causing lots of errors. We don't really need + the lynx contents of this file, so just workaround the issue by + preventing the inclusion of the GCC header from doing anything. */ +#define GCC_RESOURCE_H +#include +#elif defined (__nucleus__) +/* No wait() or waitpid() calls available */ +#else +/* Default case */ +#include +#endif + +#if defined (_WIN32) +#elif defined (VMS) + +/* Header files and definitions for __gnat_set_file_time_name. */ + +#define __NEW_STARLET 1 +#include +#include +#include +#include +#include +#include +#include +#include +#include + +/* Use native 64-bit arithmetic. */ +#define unix_time_to_vms(X,Y) \ + { unsigned long long reftime, tmptime = (X); \ + $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \ + SYS$BINTIM (&unixtime, &reftime); \ + Y = tmptime * 10000000 + reftime; } + +/* descrip.h doesn't have everything ... */ +typedef struct fibdef* __fibdef_ptr32 __attribute__ (( mode (SI) )); +struct dsc$descriptor_fib +{ + unsigned int fib$l_len; + __fibdef_ptr32 fib$l_addr; +}; + +/* I/O Status Block. */ +struct IOSB +{ + unsigned short status, count; + unsigned int devdep; +}; + +static char *tryfile; + +/* Variable length string. */ +struct vstring +{ + short length; + char string[NAM$C_MAXRSS+1]; +}; + +#define SYI$_ACTIVECPU_CNT 0x111e +extern int LIB$GETSYI (int *, unsigned int *); + +#else +#include +#endif + +#if defined (_WIN32) +#include +#endif + +#if defined (_WIN32) + +#include +#include +#include +#include +#undef DIR_SEPARATOR +#define DIR_SEPARATOR '\\' +#endif + +#include "adaint.h" + +/* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not + defined in the current system. On DOS-like systems these flags control + whether the file is opened/created in text-translation mode (CR/LF in + external file mapped to LF in internal file), but in Unix-like systems, + no text translation is required, so these flags have no effect. */ + +#ifndef O_BINARY +#define O_BINARY 0 +#endif + +#ifndef O_TEXT +#define O_TEXT 0 +#endif + +#ifndef HOST_EXECUTABLE_SUFFIX +#define HOST_EXECUTABLE_SUFFIX "" +#endif + +#ifndef HOST_OBJECT_SUFFIX +#define HOST_OBJECT_SUFFIX ".o" +#endif + +#ifndef PATH_SEPARATOR +#define PATH_SEPARATOR ':' +#endif + +#ifndef DIR_SEPARATOR +#define DIR_SEPARATOR '/' +#endif + +/* Check for cross-compilation */ +#if defined (CROSS_COMPILE) || defined (CROSS_DIRECTORY_STRUCTURE) +#define IS_CROSS 1 +int __gnat_is_cross_compiler = 1; +#else +#undef IS_CROSS +int __gnat_is_cross_compiler = 0; +#endif + +char __gnat_dir_separator = DIR_SEPARATOR; + +char __gnat_path_separator = PATH_SEPARATOR; + +/* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define + the base filenames that libraries specified with -lsomelib options + may have. This is used by GNATMAKE to check whether an executable + is up-to-date or not. The syntax is + + library_template ::= { pattern ; } pattern NUL + pattern ::= [ prefix ] * [ postfix ] + + These should only specify names of static libraries as it makes + no sense to determine at link time if dynamic-link libraries are + up to date or not. Any libraries that are not found are supposed + to be up-to-date: + + * if they are needed but not present, the link + will fail, + + * otherwise they are libraries in the system paths and so + they are considered part of the system and not checked + for that reason. + + ??? This should be part of a GNAT host-specific compiler + file instead of being included in all user applications + as well. This is only a temporary work-around for 3.11b. */ + +#ifndef GNAT_LIBRARY_TEMPLATE +#if defined (VMS) +#define GNAT_LIBRARY_TEMPLATE "*.olb" +#else +#define GNAT_LIBRARY_TEMPLATE "lib*.a" +#endif +#endif + +const char *__gnat_library_template = GNAT_LIBRARY_TEMPLATE; + +/* This variable is used in hostparm.ads to say whether the host is a VMS + system. */ +#ifdef VMS +const int __gnat_vmsp = 1; +#else +const int __gnat_vmsp = 0; +#endif + +#if defined (VMS) +#define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */ + +#elif defined (__vxworks) || defined (__OPENNT) || defined(__nucleus__) +#define GNAT_MAX_PATH_LEN PATH_MAX + +#else + +#if defined (__MINGW32__) +#include "mingw32.h" + +#if OLD_MINGW +#include +#endif + +#else +#include +#endif + +#ifdef MAXPATHLEN +#define GNAT_MAX_PATH_LEN MAXPATHLEN +#else +#define GNAT_MAX_PATH_LEN 256 +#endif + +#endif + +/* Used for Ada bindings */ +const int __gnat_size_of_file_attributes = sizeof (struct file_attributes); + +/* Reset the file attributes as if no system call had been performed */ +void __gnat_stat_to_attr (int fd, char* name, struct file_attributes* attr); + +/* The __gnat_max_path_len variable is used to export the maximum + length of a path name to Ada code. max_path_len is also provided + for compatibility with older GNAT versions, please do not use + it. */ + +int __gnat_max_path_len = GNAT_MAX_PATH_LEN; +int max_path_len = GNAT_MAX_PATH_LEN; + +/* Control whether we can use ACL on Windows. */ + +int __gnat_use_acl = 1; + +/* The following macro HAVE_READDIR_R should be defined if the + system provides the routine readdir_r. */ +#undef HAVE_READDIR_R + +#if defined(VMS) && defined (__LONG_POINTERS) + +/* Return a 32 bit pointer to an array of 32 bit pointers + given a 64 bit pointer to an array of 64 bit pointers */ + +typedef __char_ptr32 *__char_ptr_char_ptr32 __attribute__ ((mode (SI))); + +static __char_ptr_char_ptr32 +to_ptr32 (char **ptr64) +{ + int argc; + __char_ptr_char_ptr32 short_argv; + + for (argc=0; ptr64[argc]; argc++); + + /* Reallocate argv with 32 bit pointers. */ + short_argv = (__char_ptr_char_ptr32) decc$malloc + (sizeof (__char_ptr32) * (argc + 1)); + + for (argc=0; ptr64[argc]; argc++) + short_argv[argc] = (__char_ptr32) decc$strdup (ptr64[argc]); + + short_argv[argc] = (__char_ptr32) 0; + return short_argv; + +} +#define MAYBE_TO_PTR32(argv) to_ptr32 (argv) +#else +#define MAYBE_TO_PTR32(argv) argv +#endif + +static const char ATTR_UNSET = 127; + +void +__gnat_reset_attributes + (struct file_attributes* attr) +{ + attr->exists = ATTR_UNSET; + + attr->writable = ATTR_UNSET; + attr->readable = ATTR_UNSET; + attr->executable = ATTR_UNSET; + + attr->regular = ATTR_UNSET; + attr->symbolic_link = ATTR_UNSET; + attr->directory = ATTR_UNSET; + + attr->timestamp = (OS_Time)-2; + attr->file_length = -1; +} + +OS_Time +__gnat_current_time + (void) +{ + time_t res = time (NULL); + return (OS_Time) res; +} + +/* Return the current local time as a string in the ISO 8601 format of + "YYYY-MM-DD HH:MM:SS.SS". The returned string is 22 + 1 (NULL) characters + long. */ + +void +__gnat_current_time_string + (char *result) +{ + const char *format = "%Y-%m-%d %H:%M:%S"; + /* Format string necessary to describe the ISO 8601 format */ + + const time_t t_val = time (NULL); + + strftime (result, 22, format, localtime (&t_val)); + /* Convert the local time into a string following the ISO format, copying + at most 22 characters into the result string. */ + + result [19] = '.'; + result [20] = '0'; + result [21] = '0'; + /* The sub-seconds are manually set to zero since type time_t lacks the + precision necessary for nanoseconds. */ +} + +void +__gnat_to_gm_time + (OS_Time *p_time, + int *p_year, + int *p_month, + int *p_day, + int *p_hours, + int *p_mins, + int *p_secs) +{ + struct tm *res; + time_t time = (time_t) *p_time; + +#ifdef _WIN32 + /* On Windows systems, the time is sometimes rounded up to the nearest + even second, so if the number of seconds is odd, increment it. */ + if (time & 1) + time++; +#endif + +#ifdef VMS + res = localtime (&time); +#else + res = gmtime (&time); +#endif + + if (res) + { + *p_year = res->tm_year; + *p_month = res->tm_mon; + *p_day = res->tm_mday; + *p_hours = res->tm_hour; + *p_mins = res->tm_min; + *p_secs = res->tm_sec; + } + else + *p_year = *p_month = *p_day = *p_hours = *p_mins = *p_secs = 0; +} + +/* Place the contents of the symbolic link named PATH in the buffer BUF, + which has size BUFSIZ. If PATH is a symbolic link, then return the number + of characters of its content in BUF. Otherwise, return -1. + For systems not supporting symbolic links, always return -1. */ + +int +__gnat_readlink (char *path ATTRIBUTE_UNUSED, + char *buf ATTRIBUTE_UNUSED, + size_t bufsiz ATTRIBUTE_UNUSED) +{ +#if defined (_WIN32) || defined (VMS) \ + || defined(__vxworks) || defined (__nucleus__) + return -1; +#else + return readlink (path, buf, bufsiz); +#endif +} + +/* Creates a symbolic link named NEWPATH which contains the string OLDPATH. + If NEWPATH exists it will NOT be overwritten. + For systems not supporting symbolic links, always return -1. */ + +int +__gnat_symlink (char *oldpath ATTRIBUTE_UNUSED, + char *newpath ATTRIBUTE_UNUSED) +{ +#if defined (_WIN32) || defined (VMS) \ + || defined(__vxworks) || defined (__nucleus__) + return -1; +#else + return symlink (oldpath, newpath); +#endif +} + +/* Try to lock a file, return 1 if success. */ + +#if defined (__vxworks) || defined (__nucleus__) \ + || defined (_WIN32) || defined (VMS) + +/* Version that does not use link. */ + +int +__gnat_try_lock (char *dir, char *file) +{ + int fd; +#ifdef __MINGW32__ + TCHAR wfull_path[GNAT_MAX_PATH_LEN]; + TCHAR wfile[GNAT_MAX_PATH_LEN]; + TCHAR wdir[GNAT_MAX_PATH_LEN]; + + S2WSC (wdir, dir, GNAT_MAX_PATH_LEN); + S2WSC (wfile, file, GNAT_MAX_PATH_LEN); + + _stprintf (wfull_path, _T("%s%c%s"), wdir, _T(DIR_SEPARATOR), wfile); + fd = _topen (wfull_path, O_CREAT | O_EXCL, 0600); +#else + char full_path[256]; + + sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file); + fd = open (full_path, O_CREAT | O_EXCL, 0600); +#endif + + if (fd < 0) + return 0; + + close (fd); + return 1; +} + +#else + +/* Version using link(), more secure over NFS. */ +/* See TN 6913-016 for discussion ??? */ + +int +__gnat_try_lock (char *dir, char *file) +{ + char full_path[256]; + char temp_file[256]; + GNAT_STRUCT_STAT stat_result; + int fd; + + sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file); + sprintf (temp_file, "%s%cTMP-%ld-%ld", + dir, DIR_SEPARATOR, (long)getpid(), (long)getppid ()); + + /* Create the temporary file and write the process number. */ + fd = open (temp_file, O_CREAT | O_WRONLY, 0600); + if (fd < 0) + return 0; + + close (fd); + + /* Link it with the new file. */ + link (temp_file, full_path); + + /* Count the references on the old one. If we have a count of two, then + the link did succeed. Remove the temporary file before returning. */ + __gnat_stat (temp_file, &stat_result); + unlink (temp_file); + return stat_result.st_nlink == 2; +} +#endif + +/* Return the maximum file name length. */ + +int +__gnat_get_maximum_file_name_length (void) +{ +#if defined (VMS) + if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS")) + return -1; + else + return 39; +#else + return -1; +#endif +} + +/* Return nonzero if file names are case sensitive. */ + +int +__gnat_get_file_names_case_sensitive (void) +{ + const char *sensitive = getenv ("GNAT_FILE_NAME_CASE_SENSITIVE"); + + if (sensitive != NULL + && (sensitive[0] == '0' || sensitive[0] == '1') + && sensitive[1] == '\0') + return sensitive[0] - '0'; + else +#if defined (VMS) || defined (WINNT) || defined (__APPLE__) + return 0; +#else + return 1; +#endif +} + +/* Return nonzero if environment variables are case sensitive. */ + +int +__gnat_get_env_vars_case_sensitive (void) +{ +#if defined (VMS) || defined (WINNT) + return 0; +#else + return 1; +#endif +} + +char +__gnat_get_default_identifier_character_set (void) +{ + return '1'; +} + +/* Return the current working directory. */ + +void +__gnat_get_current_dir (char *dir, int *length) +{ +#if defined (__MINGW32__) + TCHAR wdir[GNAT_MAX_PATH_LEN]; + + _tgetcwd (wdir, *length); + + WS2SC (dir, wdir, GNAT_MAX_PATH_LEN); + +#elif defined (VMS) + /* Force Unix style, which is what GNAT uses internally. */ + getcwd (dir, *length, 0); +#else + getcwd (dir, *length); +#endif + + *length = strlen (dir); + + if (dir [*length - 1] != DIR_SEPARATOR) + { + dir [*length] = DIR_SEPARATOR; + ++(*length); + } + dir[*length] = '\0'; +} + +/* Return the suffix for object files. */ + +void +__gnat_get_object_suffix_ptr (int *len, const char **value) +{ + *value = HOST_OBJECT_SUFFIX; + + if (*value == 0) + *len = 0; + else + *len = strlen (*value); + + return; +} + +/* Return the suffix for executable files. */ + +void +__gnat_get_executable_suffix_ptr (int *len, const char **value) +{ + *value = HOST_EXECUTABLE_SUFFIX; + if (!*value) + *len = 0; + else + *len = strlen (*value); + + return; +} + +/* Return the suffix for debuggable files. Usually this is the same as the + executable extension. */ + +void +__gnat_get_debuggable_suffix_ptr (int *len, const char **value) +{ + *value = HOST_EXECUTABLE_SUFFIX; + + if (*value == 0) + *len = 0; + else + *len = strlen (*value); + + return; +} + +/* Returns the OS filename and corresponding encoding. */ + +void +__gnat_os_filename (char *filename ATTRIBUTE_UNUSED, + char *w_filename ATTRIBUTE_UNUSED, + char *os_name, int *o_length, + char *encoding ATTRIBUTE_UNUSED, int *e_length) +{ +#if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS) + WS2SC (os_name, (TCHAR *)w_filename, (DWORD)*o_length); + *o_length = strlen (os_name); + strcpy (encoding, "encoding=utf8"); + *e_length = strlen (encoding); +#else + strcpy (os_name, filename); + *o_length = strlen (filename); + *e_length = 0; +#endif +} + +/* Delete a file. */ + +int +__gnat_unlink (char *path) +{ +#if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS) + { + TCHAR wpath[GNAT_MAX_PATH_LEN]; + + S2WSC (wpath, path, GNAT_MAX_PATH_LEN); + return _tunlink (wpath); + } +#else + return unlink (path); +#endif +} + +/* Rename a file. */ + +int +__gnat_rename (char *from, char *to) +{ +#if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS) + { + TCHAR wfrom[GNAT_MAX_PATH_LEN], wto[GNAT_MAX_PATH_LEN]; + + S2WSC (wfrom, from, GNAT_MAX_PATH_LEN); + S2WSC (wto, to, GNAT_MAX_PATH_LEN); + return _trename (wfrom, wto); + } +#else + return rename (from, to); +#endif +} + +/* Changing directory. */ + +int +__gnat_chdir (char *path) +{ +#if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS) + { + TCHAR wpath[GNAT_MAX_PATH_LEN]; + + S2WSC (wpath, path, GNAT_MAX_PATH_LEN); + return _tchdir (wpath); + } +#else + return chdir (path); +#endif +} + +/* Removing a directory. */ + +int +__gnat_rmdir (char *path) +{ +#if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS) + { + TCHAR wpath[GNAT_MAX_PATH_LEN]; + + S2WSC (wpath, path, GNAT_MAX_PATH_LEN); + return _trmdir (wpath); + } +#elif defined (VTHREADS) + /* rmdir not available */ + return -1; +#else + return rmdir (path); +#endif +} + +FILE * +__gnat_fopen (char *path, char *mode, int encoding ATTRIBUTE_UNUSED) +{ +#if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS) + TCHAR wpath[GNAT_MAX_PATH_LEN]; + TCHAR wmode[10]; + + S2WS (wmode, mode, 10); + + if (encoding == Encoding_Unspecified) + S2WSC (wpath, path, GNAT_MAX_PATH_LEN); + else if (encoding == Encoding_UTF8) + S2WSU (wpath, path, GNAT_MAX_PATH_LEN); + else + S2WS (wpath, path, GNAT_MAX_PATH_LEN); + + return _tfopen (wpath, wmode); +#elif defined (VMS) + return decc$fopen (path, mode); +#else + return GNAT_FOPEN (path, mode); +#endif +} + +FILE * +__gnat_freopen (char *path, + char *mode, + FILE *stream, + int encoding ATTRIBUTE_UNUSED) +{ +#if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS) + TCHAR wpath[GNAT_MAX_PATH_LEN]; + TCHAR wmode[10]; + + S2WS (wmode, mode, 10); + + if (encoding == Encoding_Unspecified) + S2WSC (wpath, path, GNAT_MAX_PATH_LEN); + else if (encoding == Encoding_UTF8) + S2WSU (wpath, path, GNAT_MAX_PATH_LEN); + else + S2WS (wpath, path, GNAT_MAX_PATH_LEN); + + return _tfreopen (wpath, wmode, stream); +#elif defined (VMS) + return decc$freopen (path, mode, stream); +#else + return freopen (path, mode, stream); +#endif +} + +int +__gnat_open_read (char *path, int fmode) +{ + int fd; + int o_fmode = O_BINARY; + + if (fmode) + o_fmode = O_TEXT; + +#if defined (VMS) + /* Optional arguments mbc,deq,fop increase read performance. */ + fd = open (path, O_RDONLY | o_fmode, 0444, + "mbc=16", "deq=64", "fop=tef"); +#elif defined (__vxworks) + fd = open (path, O_RDONLY | o_fmode, 0444); +#elif defined (__MINGW32__) + { + TCHAR wpath[GNAT_MAX_PATH_LEN]; + + S2WSC (wpath, path, GNAT_MAX_PATH_LEN); + fd = _topen (wpath, O_RDONLY | o_fmode, 0444); + } +#else + fd = open (path, O_RDONLY | o_fmode); +#endif + + return fd < 0 ? -1 : fd; +} + +#if defined (__MINGW32__) +#define PERM (S_IREAD | S_IWRITE) +#elif defined (VMS) +/* Excerpt from DECC C RTL Reference Manual: + To create files with OpenVMS RMS default protections using the UNIX + system-call functions umask, mkdir, creat, and open, call mkdir, creat, + and open with a file-protection mode argument of 0777 in a program + that never specifically calls umask. These default protections include + correctly establishing protections based on ACLs, previous versions of + files, and so on. */ +#define PERM 0777 +#else +#define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH) +#endif + +int +__gnat_open_rw (char *path, int fmode) +{ + int fd; + int o_fmode = O_BINARY; + + if (fmode) + o_fmode = O_TEXT; + +#if defined (VMS) + fd = open (path, O_RDWR | o_fmode, PERM, + "mbc=16", "deq=64", "fop=tef"); +#elif defined (__MINGW32__) + { + TCHAR wpath[GNAT_MAX_PATH_LEN]; + + S2WSC (wpath, path, GNAT_MAX_PATH_LEN); + fd = _topen (wpath, O_RDWR | o_fmode, PERM); + } +#else + fd = open (path, O_RDWR | o_fmode, PERM); +#endif + + return fd < 0 ? -1 : fd; +} + +int +__gnat_open_create (char *path, int fmode) +{ + int fd; + int o_fmode = O_BINARY; + + if (fmode) + o_fmode = O_TEXT; + +#if defined (VMS) + fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM, + "mbc=16", "deq=64", "fop=tef"); +#elif defined (__MINGW32__) + { + TCHAR wpath[GNAT_MAX_PATH_LEN]; + + S2WSC (wpath, path, GNAT_MAX_PATH_LEN); + fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM); + } +#else + fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM); +#endif + + return fd < 0 ? -1 : fd; +} + +int +__gnat_create_output_file (char *path) +{ + int fd; +#if defined (VMS) + fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM, + "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk", + "shr=del,get,put,upd"); +#elif defined (__MINGW32__) + { + TCHAR wpath[GNAT_MAX_PATH_LEN]; + + S2WSC (wpath, path, GNAT_MAX_PATH_LEN); + fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM); + } +#else + fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM); +#endif + + return fd < 0 ? -1 : fd; +} + +int +__gnat_create_output_file_new (char *path) +{ + int fd; +#if defined (VMS) + fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT | O_EXCL, PERM, + "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk", + "shr=del,get,put,upd"); +#elif defined (__MINGW32__) + { + TCHAR wpath[GNAT_MAX_PATH_LEN]; + + S2WSC (wpath, path, GNAT_MAX_PATH_LEN); + fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT | O_EXCL, PERM); + } +#else + fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT | O_EXCL, PERM); +#endif + + return fd < 0 ? -1 : fd; +} + +int +__gnat_open_append (char *path, int fmode) +{ + int fd; + int o_fmode = O_BINARY; + + if (fmode) + o_fmode = O_TEXT; + +#if defined (VMS) + fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM, + "mbc=16", "deq=64", "fop=tef"); +#elif defined (__MINGW32__) + { + TCHAR wpath[GNAT_MAX_PATH_LEN]; + + S2WSC (wpath, path, GNAT_MAX_PATH_LEN); + fd = _topen (wpath, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM); + } +#else + fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM); +#endif + + return fd < 0 ? -1 : fd; +} + +/* Open a new file. Return error (-1) if the file already exists. */ + +int +__gnat_open_new (char *path, int fmode) +{ + int fd; + int o_fmode = O_BINARY; + + if (fmode) + o_fmode = O_TEXT; + +#if defined (VMS) + fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM, + "mbc=16", "deq=64", "fop=tef"); +#elif defined (__MINGW32__) + { + TCHAR wpath[GNAT_MAX_PATH_LEN]; + + S2WSC (wpath, path, GNAT_MAX_PATH_LEN); + fd = _topen (wpath, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM); + } +#else + fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM); +#endif + + return fd < 0 ? -1 : fd; +} + +/* Open a new temp file. Return error (-1) if the file already exists. + Special options for VMS allow the file to be shared between parent and child + processes, however they really slow down output. Used in gnatchop. */ + +int +__gnat_open_new_temp (char *path, int fmode) +{ + int fd; + int o_fmode = O_BINARY; + + strcpy (path, "GNAT-XXXXXX"); + +#if (defined (__FreeBSD__) || defined (__NetBSD__) || defined (__OpenBSD__) \ + || defined (linux) || defined(__GLIBC__)) && !defined (__vxworks) + return mkstemp (path); +#elif defined (__Lynx__) + mktemp (path); +#elif defined (__nucleus__) + return -1; +#else + if (mktemp (path) == NULL) + return -1; +#endif + + if (fmode) + o_fmode = O_TEXT; + +#if defined (VMS) + fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM, + "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd", + "mbc=16", "deq=64", "fop=tef"); +#else + fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM); +#endif + + return fd < 0 ? -1 : fd; +} + +/**************************************************************** + ** Perform a call to GNAT_STAT or GNAT_FSTAT, and extract as much information + ** as possible from it, storing the result in a cache for later reuse + ****************************************************************/ + +void +__gnat_stat_to_attr (int fd, char* name, struct file_attributes* attr) +{ + GNAT_STRUCT_STAT statbuf; + int ret; + + if (fd != -1) + ret = GNAT_FSTAT (fd, &statbuf); + else + ret = __gnat_stat (name, &statbuf); + + attr->regular = (!ret && S_ISREG (statbuf.st_mode)); + attr->directory = (!ret && S_ISDIR (statbuf.st_mode)); + + if (!attr->regular) + attr->file_length = 0; + else + /* st_size may be 32 bits, or 64 bits which is converted to long. We + don't return a useful value for files larger than 2 gigabytes in + either case. */ + attr->file_length = statbuf.st_size; /* all systems */ + + attr->exists = !ret; + +#if !defined (_WIN32) || defined (RTX) + /* on Windows requires extra system call, see __gnat_is_readable_file_attr */ + attr->readable = (!ret && (statbuf.st_mode & S_IRUSR)); + attr->writable = (!ret && (statbuf.st_mode & S_IWUSR)); + attr->executable = (!ret && (statbuf.st_mode & S_IXUSR)); +#endif + + if (ret != 0) { + attr->timestamp = (OS_Time)-1; + } else { +#ifdef VMS + /* VMS has file versioning. */ + attr->timestamp = (OS_Time)statbuf.st_ctime; +#else + attr->timestamp = (OS_Time)statbuf.st_mtime; +#endif + } +} + +/**************************************************************** + ** Return the number of bytes in the specified file + ****************************************************************/ + +long +__gnat_file_length_attr (int fd, char* name, struct file_attributes* attr) +{ + if (attr->file_length == -1) { + __gnat_stat_to_attr (fd, name, attr); + } + + return attr->file_length; +} + +long +__gnat_file_length (int fd) +{ + struct file_attributes attr; + __gnat_reset_attributes (&attr); + return __gnat_file_length_attr (fd, NULL, &attr); +} + +long +__gnat_named_file_length (char *name) +{ + struct file_attributes attr; + __gnat_reset_attributes (&attr); + return __gnat_file_length_attr (-1, name, &attr); +} + +/* Create a temporary filename and put it in string pointed to by + TMP_FILENAME. */ + +void +__gnat_tmp_name (char *tmp_filename) +{ +#ifdef RTX + /* Variable used to create a series of unique names */ + static int counter = 0; + + /* RTX in RTSS mode does not support tempnam nor tmpnam so we emulate it */ + strcpy (tmp_filename, "c:\\WINDOWS\\Temp\\gnat-"); + sprintf (&tmp_filename[strlen (tmp_filename)], "%d\0", counter++); + +#elif defined (__MINGW32__) + { + char *pname; + + /* tempnam tries to create a temporary file in directory pointed to by + TMP environment variable, in c:\temp if TMP is not set, and in + directory specified by P_tmpdir in stdio.h if c:\temp does not + exist. The filename will be created with the prefix "gnat-". */ + + pname = (char *) tempnam ("c:\\temp", "gnat-"); + + /* if pname is NULL, the file was not created properly, the disk is full + or there is no more free temporary files */ + + if (pname == NULL) + *tmp_filename = '\0'; + + /* If pname start with a back slash and not path information it means that + the filename is valid for the current working directory. */ + + else if (pname[0] == '\\') + { + strcpy (tmp_filename, ".\\"); + strcat (tmp_filename, pname+1); + } + else + strcpy (tmp_filename, pname); + + free (pname); + } + +#elif defined (linux) || defined (__FreeBSD__) || defined (__NetBSD__) \ + || defined (__OpenBSD__) || defined(__GLIBC__) +#define MAX_SAFE_PATH 1000 + char *tmpdir = getenv ("TMPDIR"); + + /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid + a buffer overflow. */ + if (tmpdir == NULL || strlen (tmpdir) > MAX_SAFE_PATH) + strcpy (tmp_filename, "/tmp/gnat-XXXXXX"); + else + sprintf (tmp_filename, "%s/gnat-XXXXXX", tmpdir); + + close (mkstemp(tmp_filename)); +#else + tmpnam (tmp_filename); +#endif +} + +/* Open directory and returns a DIR pointer. */ + +DIR* __gnat_opendir (char *name) +{ +#if defined (RTX) + /* Not supported in RTX */ + + return NULL; + +#elif defined (__MINGW32__) + TCHAR wname[GNAT_MAX_PATH_LEN]; + + S2WSC (wname, name, GNAT_MAX_PATH_LEN); + return (DIR*)_topendir (wname); + +#else + return opendir (name); +#endif +} + +/* Read the next entry in a directory. The returned string points somewhere + in the buffer. */ + +char * +__gnat_readdir (DIR *dirp, char *buffer, int *len) +{ +#if defined (RTX) + /* Not supported in RTX */ + + return NULL; + +#elif defined (__MINGW32__) + struct _tdirent *dirent = _treaddir ((_TDIR*)dirp); + + if (dirent != NULL) + { + WS2SC (buffer, dirent->d_name, GNAT_MAX_PATH_LEN); + *len = strlen (buffer); + + return buffer; + } + else + return NULL; + +#elif defined (HAVE_READDIR_R) + /* If possible, try to use the thread-safe version. */ + if (readdir_r (dirp, buffer) != NULL) + { + *len = strlen (((struct dirent*) buffer)->d_name); + return ((struct dirent*) buffer)->d_name; + } + else + return NULL; + +#else + struct dirent *dirent = (struct dirent *) readdir (dirp); + + if (dirent != NULL) + { + strcpy (buffer, dirent->d_name); + *len = strlen (buffer); + return buffer; + } + else + return NULL; + +#endif +} + +/* Close a directory entry. */ + +int __gnat_closedir (DIR *dirp) +{ +#if defined (RTX) + /* Not supported in RTX */ + + return 0; + +#elif defined (__MINGW32__) + return _tclosedir ((_TDIR*)dirp); + +#else + return closedir (dirp); +#endif +} + +/* Returns 1 if readdir is thread safe, 0 otherwise. */ + +int +__gnat_readdir_is_thread_safe (void) +{ +#ifdef HAVE_READDIR_R + return 1; +#else + return 0; +#endif +} + +#if defined (_WIN32) && !defined (RTX) +/* Number of seconds between and . */ +static const unsigned long long w32_epoch_offset = 11644473600ULL; + +/* Returns the file modification timestamp using Win32 routines which are + immune against daylight saving time change. It is in fact not possible to + use fstat for this purpose as the DST modify the st_mtime field of the + stat structure. */ + +static time_t +win32_filetime (HANDLE h) +{ + union + { + FILETIME ft_time; + unsigned long long ull_time; + } t_write; + + /* GetFileTime returns FILETIME data which are the number of 100 nanosecs + since . This function must return the number of seconds + since . */ + + if (GetFileTime (h, NULL, NULL, &t_write.ft_time)) + return (time_t) (t_write.ull_time / 10000000ULL - w32_epoch_offset); + return (time_t) 0; +} + +/* As above but starting from a FILETIME. */ +static void +f2t (const FILETIME *ft, time_t *t) +{ + union + { + FILETIME ft_time; + unsigned long long ull_time; + } t_write; + + t_write.ft_time = *ft; + *t = (time_t) (t_write.ull_time / 10000000ULL - w32_epoch_offset); +} +#endif + +/* Return a GNAT time stamp given a file name. */ + +OS_Time +__gnat_file_time_name_attr (char* name, struct file_attributes* attr) +{ + if (attr->timestamp == (OS_Time)-2) { +#if defined (_WIN32) && !defined (RTX) + BOOL res; + WIN32_FILE_ATTRIBUTE_DATA fad; + time_t ret = -1; + TCHAR wname[GNAT_MAX_PATH_LEN]; + S2WSC (wname, name, GNAT_MAX_PATH_LEN); + + if (res = GetFileAttributesEx (wname, GetFileExInfoStandard, &fad)) + f2t (&fad.ftLastWriteTime, &ret); + attr->timestamp = (OS_Time) ret; +#else + __gnat_stat_to_attr (-1, name, attr); +#endif + } + return attr->timestamp; +} + +OS_Time +__gnat_file_time_name (char *name) +{ + struct file_attributes attr; + __gnat_reset_attributes (&attr); + return __gnat_file_time_name_attr (name, &attr); +} + +/* Return a GNAT time stamp given a file descriptor. */ + +OS_Time +__gnat_file_time_fd_attr (int fd, struct file_attributes* attr) +{ + if (attr->timestamp == (OS_Time)-2) { +#if defined (_WIN32) && !defined (RTX) + HANDLE h = (HANDLE) _get_osfhandle (fd); + time_t ret = win32_filetime (h); + attr->timestamp = (OS_Time) ret; + +#else + __gnat_stat_to_attr (fd, NULL, attr); +#endif + } + + return attr->timestamp; +} + +OS_Time +__gnat_file_time_fd (int fd) +{ + struct file_attributes attr; + __gnat_reset_attributes (&attr); + return __gnat_file_time_fd_attr (fd, &attr); +} + +/* Set the file time stamp. */ + +void +__gnat_set_file_time_name (char *name, time_t time_stamp) +{ +#if defined (__vxworks) + +/* Code to implement __gnat_set_file_time_name for these systems. */ + +#elif defined (_WIN32) && !defined (RTX) + union + { + FILETIME ft_time; + unsigned long long ull_time; + } t_write; + TCHAR wname[GNAT_MAX_PATH_LEN]; + + S2WSC (wname, name, GNAT_MAX_PATH_LEN); + + HANDLE h = CreateFile + (wname, GENERIC_WRITE, FILE_SHARE_WRITE, NULL, + OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, + NULL); + if (h == INVALID_HANDLE_VALUE) + return; + /* Add number of seconds between and */ + t_write.ull_time = ((unsigned long long)time_stamp + w32_epoch_offset); + /* Convert to 100 nanosecond units */ + t_write.ull_time *= 10000000ULL; + + SetFileTime(h, NULL, NULL, &t_write.ft_time); + CloseHandle (h); + return; + +#elif defined (VMS) + struct FAB fab; + struct NAM nam; + + struct + { + unsigned long long backup, create, expire, revise; + unsigned int uic; + union + { + unsigned short value; + struct + { + unsigned system : 4; + unsigned owner : 4; + unsigned group : 4; + unsigned world : 4; + } bits; + } prot; + } Fat = { 0, 0, 0, 0, 0, { 0 }}; + + ATRDEF atrlst[] + = { + { ATR$S_CREDATE, ATR$C_CREDATE, &Fat.create }, + { ATR$S_REVDATE, ATR$C_REVDATE, &Fat.revise }, + { ATR$S_EXPDATE, ATR$C_EXPDATE, &Fat.expire }, + { ATR$S_BAKDATE, ATR$C_BAKDATE, &Fat.backup }, + { ATR$S_FPRO, ATR$C_FPRO, &Fat.prot }, + { ATR$S_UIC, ATR$C_UIC, &Fat.uic }, + { 0, 0, 0} + }; + + FIBDEF fib; + struct dsc$descriptor_fib fibdsc = {sizeof (fib), (void *) &fib}; + + struct IOSB iosb; + + unsigned long long newtime; + unsigned long long revtime; + long status; + short chan; + + struct vstring file; + struct dsc$descriptor_s filedsc + = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) file.string}; + struct vstring device; + struct dsc$descriptor_s devicedsc + = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) device.string}; + struct vstring timev; + struct dsc$descriptor_s timedsc + = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) timev.string}; + struct vstring result; + struct dsc$descriptor_s resultdsc + = {NAM$C_MAXRSS, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, (void *) result.string}; + + /* Convert parameter name (a file spec) to host file form. Note that this + is needed on VMS to prepare for subsequent calls to VMS RMS library + routines. Note that it would not work to call __gnat_to_host_dir_spec + as was done in a previous version, since this fails silently unless + the feature logical DECC$EFS_CHARSET is enabled, in which case a DNF + (directory not found) condition is signalled. */ + tryfile = (char *) __gnat_to_host_file_spec (name); + + /* Allocate and initialize a FAB and NAM structures. */ + fab = cc$rms_fab; + nam = cc$rms_nam; + + nam.nam$l_esa = file.string; + nam.nam$b_ess = NAM$C_MAXRSS; + nam.nam$l_rsa = result.string; + nam.nam$b_rss = NAM$C_MAXRSS; + fab.fab$l_fna = tryfile; + fab.fab$b_fns = strlen (tryfile); + fab.fab$l_nam = &nam; + + /* Validate filespec syntax and device existence. */ + status = SYS$PARSE (&fab, 0, 0); + if ((status & 1) != 1) + LIB$SIGNAL (status); + + file.string[nam.nam$b_esl] = 0; + + /* Find matching filespec. */ + status = SYS$SEARCH (&fab, 0, 0); + if ((status & 1) != 1) + LIB$SIGNAL (status); + + file.string[nam.nam$b_esl] = 0; + result.string[result.length=nam.nam$b_rsl] = 0; + + /* Get the device name and assign an IO channel. */ + strncpy (device.string, nam.nam$l_dev, nam.nam$b_dev); + devicedsc.dsc$w_length = nam.nam$b_dev; + chan = 0; + status = SYS$ASSIGN (&devicedsc, &chan, 0, 0, 0); + if ((status & 1) != 1) + LIB$SIGNAL (status); + + /* Initialize the FIB and fill in the directory id field. */ + memset (&fib, 0, sizeof (fib)); + fib.fib$w_did[0] = nam.nam$w_did[0]; + fib.fib$w_did[1] = nam.nam$w_did[1]; + fib.fib$w_did[2] = nam.nam$w_did[2]; + fib.fib$l_acctl = 0; + fib.fib$l_wcc = 0; + strcpy (file.string, (strrchr (result.string, ']') + 1)); + filedsc.dsc$w_length = strlen (file.string); + result.string[result.length = 0] = 0; + + /* Open and close the file to fill in the attributes. */ + status + = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0, + &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0); + if ((status & 1) != 1) + LIB$SIGNAL (status); + if ((iosb.status & 1) != 1) + LIB$SIGNAL (iosb.status); + + result.string[result.length] = 0; + status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0, &fibdsc, 0, 0, 0, + &atrlst, 0); + if ((status & 1) != 1) + LIB$SIGNAL (status); + if ((iosb.status & 1) != 1) + LIB$SIGNAL (iosb.status); + + { + time_t t; + + /* Set creation time to requested time. */ + unix_time_to_vms (time_stamp, newtime); + + t = time ((time_t) 0); + + /* Set revision time to now in local time. */ + unix_time_to_vms (t, revtime); + } + + /* Reopen the file, modify the times and then close. */ + fib.fib$l_acctl = FIB$M_WRITE; + status + = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0, + &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0); + if ((status & 1) != 1) + LIB$SIGNAL (status); + if ((iosb.status & 1) != 1) + LIB$SIGNAL (iosb.status); + + Fat.create = newtime; + Fat.revise = revtime; + + status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0, + &fibdsc, 0, 0, 0, &atrlst, 0); + if ((status & 1) != 1) + LIB$SIGNAL (status); + if ((iosb.status & 1) != 1) + LIB$SIGNAL (iosb.status); + + /* Deassign the channel and exit. */ + status = SYS$DASSGN (chan); + if ((status & 1) != 1) + LIB$SIGNAL (status); +#else + struct utimbuf utimbuf; + time_t t; + + /* Set modification time to requested time. */ + utimbuf.modtime = time_stamp; + + /* Set access time to now in local time. */ + t = time ((time_t) 0); + utimbuf.actime = mktime (localtime (&t)); + + utime (name, &utimbuf); +#endif +} + +/* Get the list of installed standard libraries from the + HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries + key. */ + +char * +__gnat_get_libraries_from_registry (void) +{ + char *result = (char *) xmalloc (1); + + result[0] = '\0'; + +#if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS) \ + && ! defined (RTX) + + HKEY reg_key; + DWORD name_size, value_size; + char name[256]; + char value[256]; + DWORD type; + DWORD index; + LONG res; + + /* First open the key. */ + res = RegOpenKeyExA (HKEY_LOCAL_MACHINE, "SOFTWARE", 0, KEY_READ, ®_key); + + if (res == ERROR_SUCCESS) + res = RegOpenKeyExA (reg_key, "Ada Core Technologies", 0, + KEY_READ, ®_key); + + if (res == ERROR_SUCCESS) + res = RegOpenKeyExA (reg_key, "GNAT", 0, KEY_READ, ®_key); + + if (res == ERROR_SUCCESS) + res = RegOpenKeyExA (reg_key, "Standard Libraries", 0, KEY_READ, ®_key); + + /* If the key exists, read out all the values in it and concatenate them + into a path. */ + for (index = 0; res == ERROR_SUCCESS; index++) + { + value_size = name_size = 256; + res = RegEnumValueA (reg_key, index, name, &name_size, 0, + &type, (LPBYTE)value, &value_size); + + if (res == ERROR_SUCCESS && type == REG_SZ) + { + char *old_result = result; + + result = (char *) xmalloc (strlen (old_result) + value_size + 2); + strcpy (result, old_result); + strcat (result, value); + strcat (result, ";"); + free (old_result); + } + } + + /* Remove the trailing ";". */ + if (result[0] != 0) + result[strlen (result) - 1] = 0; + +#endif + return result; +} + +int +__gnat_stat (char *name, GNAT_STRUCT_STAT *statbuf) +{ +#ifdef __MINGW32__ + WIN32_FILE_ATTRIBUTE_DATA fad; + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + int name_len; + BOOL res; + + S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); + name_len = _tcslen (wname); + + if (name_len > GNAT_MAX_PATH_LEN) + return -1; + + ZeroMemory (statbuf, sizeof(GNAT_STRUCT_STAT)); + + res = GetFileAttributesEx (wname, GetFileExInfoStandard, &fad); + + if (res == FALSE) + switch (GetLastError()) { + case ERROR_ACCESS_DENIED: + case ERROR_SHARING_VIOLATION: + case ERROR_LOCK_VIOLATION: + case ERROR_SHARING_BUFFER_EXCEEDED: + return EACCES; + case ERROR_BUFFER_OVERFLOW: + return ENAMETOOLONG; + case ERROR_NOT_ENOUGH_MEMORY: + return ENOMEM; + default: + return ENOENT; + } + + f2t (&fad.ftCreationTime, &statbuf->st_ctime); + f2t (&fad.ftLastWriteTime, &statbuf->st_mtime); + f2t (&fad.ftLastAccessTime, &statbuf->st_atime); + + statbuf->st_size = (off_t)fad.nFileSizeLow; + + /* We do not have the S_IEXEC attribute, but this is not used on GNAT. */ + statbuf->st_mode = S_IREAD; + + if (fad.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) + statbuf->st_mode |= S_IFDIR; + else + statbuf->st_mode |= S_IFREG; + + if (!(fad.dwFileAttributes & FILE_ATTRIBUTE_READONLY)) + statbuf->st_mode |= S_IWRITE; + + return 0; + +#else + return GNAT_STAT (name, statbuf); +#endif +} + +/************************************************************************* + ** Check whether a file exists + *************************************************************************/ + +int +__gnat_file_exists_attr (char* name, struct file_attributes* attr) +{ + if (attr->exists == ATTR_UNSET) { + __gnat_stat_to_attr (-1, name, attr); + } + + return attr->exists; +} + +int +__gnat_file_exists (char *name) +{ + struct file_attributes attr; + __gnat_reset_attributes (&attr); + return __gnat_file_exists_attr (name, &attr); +} + +/********************************************************************** + ** Whether name is an absolute path + **********************************************************************/ + +int +__gnat_is_absolute_path (char *name, int length) +{ +#ifdef __vxworks + /* On VxWorks systems, an absolute path can be represented (depending on + the host platform) as either /dir/file, or device:/dir/file, or + device:drive_letter:/dir/file. */ + + int index; + + if (name[0] == '/') + return 1; + + for (index = 0; index < length; index++) + { + if (name[index] == ':' && + ((name[index + 1] == '/') || + (isalpha (name[index + 1]) && index + 2 <= length && + name[index + 2] == '/'))) + return 1; + + else if (name[index] == '/') + return 0; + } + return 0; +#else + return (length != 0) && + (*name == '/' || *name == DIR_SEPARATOR +#if defined (WINNT) + || (length > 1 && ISALPHA (name[0]) && name[1] == ':') +#endif + ); +#endif +} + +int +__gnat_is_regular_file_attr (char* name, struct file_attributes* attr) +{ + if (attr->regular == ATTR_UNSET) { + __gnat_stat_to_attr (-1, name, attr); + } + + return attr->regular; +} + +int +__gnat_is_regular_file (char *name) +{ + struct file_attributes attr; + __gnat_reset_attributes (&attr); + return __gnat_is_regular_file_attr (name, &attr); +} + +int +__gnat_is_directory_attr (char* name, struct file_attributes* attr) +{ + if (attr->directory == ATTR_UNSET) { + __gnat_stat_to_attr (-1, name, attr); + } + + return attr->directory; +} + +int +__gnat_is_directory (char *name) +{ + struct file_attributes attr; + __gnat_reset_attributes (&attr); + return __gnat_is_directory_attr (name, &attr); +} + +#if defined (_WIN32) && !defined (RTX) + +/* Returns the same constant as GetDriveType but takes a pathname as + argument. */ + +static UINT +GetDriveTypeFromPath (TCHAR *wfullpath) +{ + TCHAR wdrv[MAX_PATH]; + TCHAR wpath[MAX_PATH]; + TCHAR wfilename[MAX_PATH]; + TCHAR wext[MAX_PATH]; + + _tsplitpath (wfullpath, wdrv, wpath, wfilename, wext); + + if (_tcslen (wdrv) != 0) + { + /* we have a drive specified. */ + _tcscat (wdrv, _T("\\")); + return GetDriveType (wdrv); + } + else + { + /* No drive specified. */ + + /* Is this a relative path, if so get current drive type. */ + if (wpath[0] != _T('\\') || + (_tcslen (wpath) > 2 && wpath[0] == _T('\\') && wpath[1] != _T('\\'))) + return GetDriveType (NULL); + + UINT result = GetDriveType (wpath); + + /* Cannot guess the drive type, is this \\.\ ? */ + + if (result == DRIVE_NO_ROOT_DIR && + _tcslen (wpath) >= 4 && wpath[0] == _T('\\') && wpath[1] == _T('\\') + && wpath[2] == _T('.') && wpath[3] == _T('\\')) + { + if (_tcslen (wpath) == 4) + _tcscat (wpath, wfilename); + + LPTSTR p = &wpath[4]; + LPTSTR b = _tcschr (p, _T('\\')); + + if (b != NULL) + { /* logical drive \\.\c\dir\file */ + *b++ = _T(':'); + *b++ = _T('\\'); + *b = _T('\0'); + } + else + _tcscat (p, _T(":\\")); + + return GetDriveType (p); + } + + return result; + } +} + +/* This MingW section contains code to work with ACL. */ +static int +__gnat_check_OWNER_ACL +(TCHAR *wname, + DWORD CheckAccessDesired, + GENERIC_MAPPING CheckGenericMapping) +{ + DWORD dwAccessDesired, dwAccessAllowed; + PRIVILEGE_SET PrivilegeSet; + DWORD dwPrivSetSize = sizeof (PRIVILEGE_SET); + BOOL fAccessGranted = FALSE; + HANDLE hToken = NULL; + DWORD nLength = 0; + SECURITY_DESCRIPTOR* pSD = NULL; + + GetFileSecurity + (wname, OWNER_SECURITY_INFORMATION | + GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION, + NULL, 0, &nLength); + + if ((pSD = (PSECURITY_DESCRIPTOR) HeapAlloc + (GetProcessHeap (), HEAP_ZERO_MEMORY, nLength)) == NULL) + return 0; + + /* Obtain the security descriptor. */ + + if (!GetFileSecurity + (wname, OWNER_SECURITY_INFORMATION | + GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION, + pSD, nLength, &nLength)) + goto error; + + if (!ImpersonateSelf (SecurityImpersonation)) + goto error; + + if (!OpenThreadToken + (GetCurrentThread(), TOKEN_DUPLICATE | TOKEN_QUERY, FALSE, &hToken)) + goto error; + + /* Undoes the effect of ImpersonateSelf. */ + + RevertToSelf (); + + /* We want to test for write permissions. */ + + dwAccessDesired = CheckAccessDesired; + + MapGenericMask (&dwAccessDesired, &CheckGenericMapping); + + if (!AccessCheck + (pSD , /* security descriptor to check */ + hToken, /* impersonation token */ + dwAccessDesired, /* requested access rights */ + &CheckGenericMapping, /* pointer to GENERIC_MAPPING */ + &PrivilegeSet, /* receives privileges used in check */ + &dwPrivSetSize, /* size of PrivilegeSet buffer */ + &dwAccessAllowed, /* receives mask of allowed access rights */ + &fAccessGranted)) + goto error; + + CloseHandle (hToken); + HeapFree (GetProcessHeap (), 0, pSD); + return fAccessGranted; + + error: + if (hToken) + CloseHandle (hToken); + HeapFree (GetProcessHeap (), 0, pSD); + return 0; +} + +static void +__gnat_set_OWNER_ACL +(TCHAR *wname, + DWORD AccessMode, + DWORD AccessPermissions) +{ + PACL pOldDACL = NULL; + PACL pNewDACL = NULL; + PSECURITY_DESCRIPTOR pSD = NULL; + EXPLICIT_ACCESS ea; + TCHAR username [100]; + DWORD unsize = 100; + + /* Get current user, he will act as the owner */ + + if (!GetUserName (username, &unsize)) + return; + + if (GetNamedSecurityInfo + (wname, + SE_FILE_OBJECT, + DACL_SECURITY_INFORMATION, + NULL, NULL, &pOldDACL, NULL, &pSD) != ERROR_SUCCESS) + return; + + BuildExplicitAccessWithName + (&ea, username, AccessPermissions, AccessMode, NO_INHERITANCE); + + if (AccessMode == SET_ACCESS) + { + /* SET_ACCESS, we want to set an explicte set of permissions, do not + merge with current DACL. */ + if (SetEntriesInAcl (1, &ea, NULL, &pNewDACL) != ERROR_SUCCESS) + return; + } + else + if (SetEntriesInAcl (1, &ea, pOldDACL, &pNewDACL) != ERROR_SUCCESS) + return; + + if (SetNamedSecurityInfo + (wname, SE_FILE_OBJECT, + DACL_SECURITY_INFORMATION, NULL, NULL, pNewDACL, NULL) != ERROR_SUCCESS) + return; + + LocalFree (pSD); + LocalFree (pNewDACL); +} + +/* Check if it is possible to use ACL for wname, the file must not be on a + network drive. */ + +static int +__gnat_can_use_acl (TCHAR *wname) +{ + return __gnat_use_acl && GetDriveTypeFromPath (wname) != DRIVE_REMOTE; +} + +#endif /* defined (_WIN32) && !defined (RTX) */ + +int +__gnat_is_readable_file_attr (char* name, struct file_attributes* attr) +{ + if (attr->readable == ATTR_UNSET) { +#if defined (_WIN32) && !defined (RTX) + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + GENERIC_MAPPING GenericMapping; + + S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); + + if (__gnat_can_use_acl (wname)) + { + ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING)); + GenericMapping.GenericRead = GENERIC_READ; + attr->readable = + __gnat_check_OWNER_ACL (wname, FILE_READ_DATA, GenericMapping); + } + else + attr->readable = GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES; +#else + __gnat_stat_to_attr (-1, name, attr); +#endif + } + + return attr->readable; +} + +int +__gnat_is_readable_file (char *name) +{ + struct file_attributes attr; + __gnat_reset_attributes (&attr); + return __gnat_is_readable_file_attr (name, &attr); +} + +int +__gnat_is_writable_file_attr (char* name, struct file_attributes* attr) +{ + if (attr->writable == ATTR_UNSET) { +#if defined (_WIN32) && !defined (RTX) + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + GENERIC_MAPPING GenericMapping; + + S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); + + if (__gnat_can_use_acl (wname)) + { + ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING)); + GenericMapping.GenericWrite = GENERIC_WRITE; + + attr->writable = __gnat_check_OWNER_ACL + (wname, FILE_WRITE_DATA | FILE_APPEND_DATA, GenericMapping) + && !(GetFileAttributes (wname) & FILE_ATTRIBUTE_READONLY); + } + else + attr->writable = !(GetFileAttributes (wname) & FILE_ATTRIBUTE_READONLY); + +#else + __gnat_stat_to_attr (-1, name, attr); +#endif + } + + return attr->writable; +} + +int +__gnat_is_writable_file (char *name) +{ + struct file_attributes attr; + __gnat_reset_attributes (&attr); + return __gnat_is_writable_file_attr (name, &attr); +} + +int +__gnat_is_executable_file_attr (char* name, struct file_attributes* attr) +{ + if (attr->executable == ATTR_UNSET) { +#if defined (_WIN32) && !defined (RTX) + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + GENERIC_MAPPING GenericMapping; + + S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); + + if (__gnat_can_use_acl (wname)) + { + ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING)); + GenericMapping.GenericExecute = GENERIC_EXECUTE; + + attr->executable = + __gnat_check_OWNER_ACL (wname, FILE_EXECUTE, GenericMapping); + } + else + attr->executable = GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES + && _tcsstr (wname, _T(".exe")) - wname == (int) (_tcslen (wname) - 4); +#else + __gnat_stat_to_attr (-1, name, attr); +#endif + } + + return attr->executable; +} + +int +__gnat_is_executable_file (char *name) +{ + struct file_attributes attr; + __gnat_reset_attributes (&attr); + return __gnat_is_executable_file_attr (name, &attr); +} + +void +__gnat_set_writable (char *name) +{ +#if defined (_WIN32) && !defined (RTX) + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + + S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); + + if (__gnat_can_use_acl (wname)) + __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_WRITE); + + SetFileAttributes + (wname, GetFileAttributes (wname) & ~FILE_ATTRIBUTE_READONLY); +#elif ! defined (__vxworks) && ! defined(__nucleus__) + GNAT_STRUCT_STAT statbuf; + + if (GNAT_STAT (name, &statbuf) == 0) + { + statbuf.st_mode = statbuf.st_mode | S_IWUSR; + chmod (name, statbuf.st_mode); + } +#endif +} + +void +__gnat_set_executable (char *name) +{ +#if defined (_WIN32) && !defined (RTX) + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + + S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); + + if (__gnat_can_use_acl (wname)) + __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_EXECUTE); + +#elif ! defined (__vxworks) && ! defined(__nucleus__) + GNAT_STRUCT_STAT statbuf; + + if (GNAT_STAT (name, &statbuf) == 0) + { + statbuf.st_mode = statbuf.st_mode | S_IXUSR; + chmod (name, statbuf.st_mode); + } +#endif +} + +void +__gnat_set_non_writable (char *name) +{ +#if defined (_WIN32) && !defined (RTX) + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + + S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); + + if (__gnat_can_use_acl (wname)) + __gnat_set_OWNER_ACL + (wname, DENY_ACCESS, + FILE_WRITE_DATA | FILE_APPEND_DATA | + FILE_WRITE_EA | FILE_WRITE_ATTRIBUTES); + + SetFileAttributes + (wname, GetFileAttributes (wname) | FILE_ATTRIBUTE_READONLY); +#elif ! defined (__vxworks) && ! defined(__nucleus__) + GNAT_STRUCT_STAT statbuf; + + if (GNAT_STAT (name, &statbuf) == 0) + { + statbuf.st_mode = statbuf.st_mode & 07577; + chmod (name, statbuf.st_mode); + } +#endif +} + +void +__gnat_set_readable (char *name) +{ +#if defined (_WIN32) && !defined (RTX) + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + + S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); + + if (__gnat_can_use_acl (wname)) + __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_READ); + +#elif ! defined (__vxworks) && ! defined(__nucleus__) + GNAT_STRUCT_STAT statbuf; + + if (GNAT_STAT (name, &statbuf) == 0) + { + chmod (name, statbuf.st_mode | S_IREAD); + } +#endif +} + +void +__gnat_set_non_readable (char *name) +{ +#if defined (_WIN32) && !defined (RTX) + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + + S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); + + if (__gnat_can_use_acl (wname)) + __gnat_set_OWNER_ACL (wname, DENY_ACCESS, FILE_GENERIC_READ); + +#elif ! defined (__vxworks) && ! defined(__nucleus__) + GNAT_STRUCT_STAT statbuf; + + if (GNAT_STAT (name, &statbuf) == 0) + { + chmod (name, statbuf.st_mode & (~S_IREAD)); + } +#endif +} + +int +__gnat_is_symbolic_link_attr (char* name, struct file_attributes* attr) +{ + if (attr->symbolic_link == ATTR_UNSET) { +#if defined (__vxworks) || defined (__nucleus__) + attr->symbolic_link = 0; + +#elif defined (_AIX) || defined (__APPLE__) || defined (__unix__) + int ret; + GNAT_STRUCT_STAT statbuf; + ret = GNAT_LSTAT (name, &statbuf); + attr->symbolic_link = (!ret && S_ISLNK (statbuf.st_mode)); +#else + attr->symbolic_link = 0; +#endif + } + return attr->symbolic_link; +} + +int +__gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED) +{ + struct file_attributes attr; + __gnat_reset_attributes (&attr); + return __gnat_is_symbolic_link_attr (name, &attr); + +} + +#if defined (sun) && defined (__SVR4) +/* Using fork on Solaris will duplicate all the threads. fork1, which + duplicates only the active thread, must be used instead, or spawning + subprocess from a program with tasking will lead into numerous problems. */ +#define fork fork1 +#endif + +int +__gnat_portable_spawn (char *args[]) +{ + int status = 0; + int finished ATTRIBUTE_UNUSED; + int pid ATTRIBUTE_UNUSED; + +#if defined (__vxworks) || defined(__nucleus__) || defined(RTX) + return -1; + +#elif defined (_WIN32) + /* args[0] must be quotes as it could contain a full pathname with spaces */ + char *args_0 = args[0]; + args[0] = (char *)xmalloc (strlen (args_0) + 3); + strcpy (args[0], "\""); + strcat (args[0], args_0); + strcat (args[0], "\""); + + status = spawnvp (P_WAIT, args_0, (const char* const*)args); + + /* restore previous value */ + free (args[0]); + args[0] = (char *)args_0; + + if (status < 0) + return -1; + else + return status; + +#else + + pid = fork (); + if (pid < 0) + return -1; + + if (pid == 0) + { + /* The child. */ + if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0) +#if defined (VMS) + return -1; /* execv is in parent context on VMS. */ +#else + _exit (1); +#endif + } + + /* The parent. */ + finished = waitpid (pid, &status, 0); + + if (finished != pid || WIFEXITED (status) == 0) + return -1; + + return WEXITSTATUS (status); +#endif + + return 0; +} + +/* Create a copy of the given file descriptor. + Return -1 if an error occurred. */ + +int +__gnat_dup (int oldfd) +{ +#if defined (__vxworks) && !defined (__RTP__) + /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using + RTPs. */ + return -1; +#else + return dup (oldfd); +#endif +} + +/* Make newfd be the copy of oldfd, closing newfd first if necessary. + Return -1 if an error occurred. */ + +int +__gnat_dup2 (int oldfd, int newfd) +{ +#if defined (__vxworks) && !defined (__RTP__) + /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using + RTPs. */ + return -1; +#else + return dup2 (oldfd, newfd); +#endif +} + +int +__gnat_number_of_cpus (void) +{ + int cores = 1; + +#if defined (linux) || defined (sun) || defined (AIX) \ + || (defined (__alpha__) && defined (_osf_)) || defined (__APPLE__) + cores = (int) sysconf (_SC_NPROCESSORS_ONLN); + +#elif (defined (__mips) && defined (__sgi)) + cores = (int) sysconf (_SC_NPROC_ONLN); + +#elif defined (__hpux__) + struct pst_dynamic psd; + if (pstat_getdynamic (&psd, sizeof (psd), 1, 0) != -1) + cores = (int) psd.psd_proc_cnt; + +#elif defined (_WIN32) + SYSTEM_INFO sysinfo; + GetSystemInfo (&sysinfo); + cores = (int) sysinfo.dwNumberOfProcessors; + +#elif defined (VMS) + int code = SYI$_ACTIVECPU_CNT; + unsigned int res; + int status; + + status = LIB$GETSYI (&code, &res); + if ((status & 1) != 0) + cores = res; +#endif + + return cores; +} + +/* WIN32 code to implement a wait call that wait for any child process. */ + +#if defined (_WIN32) && !defined (RTX) + +/* Synchronization code, to be thread safe. */ + +#ifdef CERT + +/* For the Cert run times on native Windows we use dummy functions + for locking and unlocking tasks since we do not support multiple + threads on this configuration (Cert run time on native Windows). */ + +void dummy (void) {} + +void (*Lock_Task) () = &dummy; +void (*Unlock_Task) () = &dummy; + +#else + +#define Lock_Task system__soft_links__lock_task +extern void (*Lock_Task) (void); + +#define Unlock_Task system__soft_links__unlock_task +extern void (*Unlock_Task) (void); + +#endif + +static HANDLE *HANDLES_LIST = NULL; +static int *PID_LIST = NULL, plist_length = 0, plist_max_length = 0; + +static void +add_handle (HANDLE h, int pid) +{ + + /* -------------------- critical section -------------------- */ + (*Lock_Task) (); + + if (plist_length == plist_max_length) + { + plist_max_length += 1000; + HANDLES_LIST = + xrealloc (HANDLES_LIST, sizeof (HANDLE) * plist_max_length); + PID_LIST = + xrealloc (PID_LIST, sizeof (int) * plist_max_length); + } + + HANDLES_LIST[plist_length] = h; + PID_LIST[plist_length] = pid; + ++plist_length; + + (*Unlock_Task) (); + /* -------------------- critical section -------------------- */ +} + +void +__gnat_win32_remove_handle (HANDLE h, int pid) +{ + int j; + + /* -------------------- critical section -------------------- */ + (*Lock_Task) (); + + for (j = 0; j < plist_length; j++) + { + if ((HANDLES_LIST[j] == h) || (PID_LIST[j] == pid)) + { + CloseHandle (h); + --plist_length; + HANDLES_LIST[j] = HANDLES_LIST[plist_length]; + PID_LIST[j] = PID_LIST[plist_length]; + break; + } + } + + (*Unlock_Task) (); + /* -------------------- critical section -------------------- */ +} + +static void +win32_no_block_spawn (char *command, char *args[], HANDLE *h, int *pid) +{ + BOOL result; + STARTUPINFO SI; + PROCESS_INFORMATION PI; + SECURITY_ATTRIBUTES SA; + int csize = 1; + char *full_command; + int k; + + /* compute the total command line length */ + k = 0; + while (args[k]) + { + csize += strlen (args[k]) + 1; + k++; + } + + full_command = (char *) xmalloc (csize); + + /* Startup info. */ + SI.cb = sizeof (STARTUPINFO); + SI.lpReserved = NULL; + SI.lpReserved2 = NULL; + SI.lpDesktop = NULL; + SI.cbReserved2 = 0; + SI.lpTitle = NULL; + SI.dwFlags = 0; + SI.wShowWindow = SW_HIDE; + + /* Security attributes. */ + SA.nLength = sizeof (SECURITY_ATTRIBUTES); + SA.bInheritHandle = TRUE; + SA.lpSecurityDescriptor = NULL; + + /* Prepare the command string. */ + strcpy (full_command, command); + strcat (full_command, " "); + + k = 1; + while (args[k]) + { + strcat (full_command, args[k]); + strcat (full_command, " "); + k++; + } + + { + int wsize = csize * 2; + TCHAR *wcommand = (TCHAR *) xmalloc (wsize); + + S2WSC (wcommand, full_command, wsize); + + free (full_command); + + result = CreateProcess + (NULL, wcommand, &SA, NULL, TRUE, + GetPriorityClass (GetCurrentProcess()), NULL, NULL, &SI, &PI); + + free (wcommand); + } + + if (result == TRUE) + { + CloseHandle (PI.hThread); + *h = PI.hProcess; + *pid = PI.dwProcessId; + } + else + { + *h = NULL; + *pid = 0; + } +} + +static int +win32_wait (int *status) +{ + DWORD exitcode, pid; + HANDLE *hl; + HANDLE h; + DWORD res; + int k; + int hl_len; + + if (plist_length == 0) + { + errno = ECHILD; + return -1; + } + + k = 0; + + /* -------------------- critical section -------------------- */ + (*Lock_Task) (); + + hl_len = plist_length; + + hl = (HANDLE *) xmalloc (sizeof (HANDLE) * hl_len); + + memmove (hl, HANDLES_LIST, sizeof (HANDLE) * hl_len); + + (*Unlock_Task) (); + /* -------------------- critical section -------------------- */ + + res = WaitForMultipleObjects (hl_len, hl, FALSE, INFINITE); + h = hl[res - WAIT_OBJECT_0]; + + GetExitCodeProcess (h, &exitcode); + pid = PID_LIST [res - WAIT_OBJECT_0]; + __gnat_win32_remove_handle (h, -1); + + free (hl); + + *status = (int) exitcode; + return (int) pid; +} + +#endif + +int +__gnat_portable_no_block_spawn (char *args[]) +{ + +#if defined (__vxworks) || defined (__nucleus__) || defined (RTX) + return -1; + +#elif defined (_WIN32) + + HANDLE h = NULL; + int pid; + + win32_no_block_spawn (args[0], args, &h, &pid); + if (h != NULL) + { + add_handle (h, pid); + return pid; + } + else + return -1; + +#else + + int pid = fork (); + + if (pid == 0) + { + /* The child. */ + if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0) +#if defined (VMS) + return -1; /* execv is in parent context on VMS. */ +#else + _exit (1); +#endif + } + + return pid; + + #endif +} + +int +__gnat_portable_wait (int *process_status) +{ + int status = 0; + int pid = 0; + +#if defined (__vxworks) || defined (__nucleus__) || defined (RTX) + /* Not sure what to do here, so do nothing but return zero. */ + +#elif defined (_WIN32) + + pid = win32_wait (&status); + +#else + + pid = waitpid (-1, &status, 0); + status = status & 0xffff; +#endif + + *process_status = status; + return pid; +} + +void +__gnat_os_exit (int status) +{ + exit (status); +} + +/* Locate a regular file, give a Path value. */ + +char * +__gnat_locate_regular_file (char *file_name, char *path_val) +{ + char *ptr; + char *file_path = (char *) alloca (strlen (file_name) + 1); + int absolute; + + /* Return immediately if file_name is empty */ + + if (*file_name == '\0') + return 0; + + /* Remove quotes around file_name if present */ + + ptr = file_name; + if (*ptr == '"') + ptr++; + + strcpy (file_path, ptr); + + ptr = file_path + strlen (file_path) - 1; + + if (*ptr == '"') + *ptr = '\0'; + + /* Handle absolute pathnames. */ + + absolute = __gnat_is_absolute_path (file_path, strlen (file_name)); + + if (absolute) + { + if (__gnat_is_regular_file (file_path)) + return xstrdup (file_path); + + return 0; + } + + /* If file_name include directory separator(s), try it first as + a path name relative to the current directory */ + for (ptr = file_name; *ptr && *ptr != '/' && *ptr != DIR_SEPARATOR; ptr++) + ; + + if (*ptr != 0) + { + if (__gnat_is_regular_file (file_name)) + return xstrdup (file_name); + } + + if (path_val == 0) + return 0; + + { + /* The result has to be smaller than path_val + file_name. */ + char *file_path = + (char *) alloca (strlen (path_val) + strlen (file_name) + 2); + + for (;;) + { + /* Skip the starting quote */ + + if (*path_val == '"') + path_val++; + + for (ptr = file_path; *path_val && *path_val != PATH_SEPARATOR; ) + *ptr++ = *path_val++; + + /* If directory is empty, it is the current directory*/ + + if (ptr == file_path) + { + *ptr = '.'; + } + else + ptr--; + + /* Skip the ending quote */ + + if (*ptr == '"') + ptr--; + + if (*ptr != '/' && *ptr != DIR_SEPARATOR) + *++ptr = DIR_SEPARATOR; + + strcpy (++ptr, file_name); + + if (__gnat_is_regular_file (file_path)) + return xstrdup (file_path); + + if (*path_val == 0) + return 0; + + /* Skip path separator */ + + path_val++; + } + } + + return 0; +} + +/* Locate an executable given a Path argument. This routine is only used by + gnatbl and should not be used otherwise. Use locate_exec_on_path + instead. */ + +char * +__gnat_locate_exec (char *exec_name, char *path_val) +{ + char *ptr; + if (!strstr (exec_name, HOST_EXECUTABLE_SUFFIX)) + { + char *full_exec_name = + (char *) alloca + (strlen (exec_name) + strlen (HOST_EXECUTABLE_SUFFIX) + 1); + + strcpy (full_exec_name, exec_name); + strcat (full_exec_name, HOST_EXECUTABLE_SUFFIX); + ptr = __gnat_locate_regular_file (full_exec_name, path_val); + + if (ptr == 0) + return __gnat_locate_regular_file (exec_name, path_val); + return ptr; + } + else + return __gnat_locate_regular_file (exec_name, path_val); +} + +/* Locate an executable using the Systems default PATH. */ + +char * +__gnat_locate_exec_on_path (char *exec_name) +{ + char *apath_val; + +#if defined (_WIN32) && !defined (RTX) + TCHAR *wpath_val = _tgetenv (_T("PATH")); + TCHAR *wapath_val; + /* In Win32 systems we expand the PATH as for XP environment + variables are not automatically expanded. We also prepend the + ".;" to the path to match normal NT path search semantics */ + + #define EXPAND_BUFFER_SIZE 32767 + + wapath_val = alloca (EXPAND_BUFFER_SIZE); + + wapath_val [0] = '.'; + wapath_val [1] = ';'; + + DWORD res = ExpandEnvironmentStrings + (wpath_val, &wapath_val[2], EXPAND_BUFFER_SIZE - 2); + + if (!res) wapath_val [0] = _T('\0'); + + apath_val = alloca (EXPAND_BUFFER_SIZE); + + WS2SC (apath_val, wapath_val, EXPAND_BUFFER_SIZE); + return __gnat_locate_exec (exec_name, apath_val); + +#else + +#ifdef VMS + char *path_val = "/VAXC$PATH"; +#else + char *path_val = getenv ("PATH"); +#endif + if (path_val == NULL) return NULL; + apath_val = (char *) alloca (strlen (path_val) + 1); + strcpy (apath_val, path_val); + return __gnat_locate_exec (exec_name, apath_val); +#endif +} + +#ifdef VMS + +/* These functions are used to translate to and from VMS and Unix syntax + file, directory and path specifications. */ + +#define MAXPATH 256 +#define MAXNAMES 256 +#define NEW_CANONICAL_FILELIST_INCREMENT 64 + +static char new_canonical_dirspec [MAXPATH]; +static char new_canonical_filespec [MAXPATH]; +static char new_canonical_pathspec [MAXNAMES*MAXPATH]; +static unsigned new_canonical_filelist_index; +static unsigned new_canonical_filelist_in_use; +static unsigned new_canonical_filelist_allocated; +static char **new_canonical_filelist; +static char new_host_pathspec [MAXNAMES*MAXPATH]; +static char new_host_dirspec [MAXPATH]; +static char new_host_filespec [MAXPATH]; + +/* Routine is called repeatedly by decc$from_vms via + __gnat_to_canonical_file_list_init until it returns 0 or the expansion + runs out. */ + +static int +wildcard_translate_unix (char *name) +{ + char *ver; + char buff [MAXPATH]; + + strncpy (buff, name, MAXPATH); + buff [MAXPATH - 1] = (char) 0; + ver = strrchr (buff, '.'); + + /* Chop off the version. */ + if (ver) + *ver = 0; + + /* Dynamically extend the allocation by the increment. */ + if (new_canonical_filelist_in_use == new_canonical_filelist_allocated) + { + new_canonical_filelist_allocated += NEW_CANONICAL_FILELIST_INCREMENT; + new_canonical_filelist = (char **) xrealloc + (new_canonical_filelist, + new_canonical_filelist_allocated * sizeof (char *)); + } + + new_canonical_filelist[new_canonical_filelist_in_use++] = xstrdup (buff); + + return 1; +} + +/* Translate a wildcard VMS file spec into a list of Unix file specs. First do + full translation and copy the results into a list (_init), then return them + one at a time (_next). If onlydirs set, only expand directory files. */ + +int +__gnat_to_canonical_file_list_init (char *filespec, int onlydirs) +{ + int len; + char buff [MAXPATH]; + + len = strlen (filespec); + strncpy (buff, filespec, MAXPATH); + + /* Only look for directories */ + if (onlydirs && !strstr (&buff [len-5], "*.dir")) + strncat (buff, "*.dir", MAXPATH); + + buff [MAXPATH - 1] = (char) 0; + + decc$from_vms (buff, wildcard_translate_unix, 1); + + /* Remove the .dir extension. */ + if (onlydirs) + { + int i; + char *ext; + + for (i = 0; i < new_canonical_filelist_in_use; i++) + { + ext = strstr (new_canonical_filelist[i], ".dir"); + if (ext) + *ext = 0; + } + } + + return new_canonical_filelist_in_use; +} + +/* Return the next filespec in the list. */ + +char * +__gnat_to_canonical_file_list_next () +{ + return new_canonical_filelist[new_canonical_filelist_index++]; +} + +/* Free storage used in the wildcard expansion. */ + +void +__gnat_to_canonical_file_list_free () +{ + int i; + + for (i = 0; i < new_canonical_filelist_in_use; i++) + free (new_canonical_filelist[i]); + + free (new_canonical_filelist); + + new_canonical_filelist_in_use = 0; + new_canonical_filelist_allocated = 0; + new_canonical_filelist_index = 0; + new_canonical_filelist = 0; +} + +/* The functional equivalent of decc$translate_vms routine. + Designed to produce the same output, but is protected against + malformed paths (original version ACCVIOs in this case) and + does not require VMS-specific DECC RTL */ + +#define NAM$C_MAXRSS 1024 + +char * +__gnat_translate_vms (char *src) +{ + static char retbuf [NAM$C_MAXRSS+1]; + char *srcendpos, *pos1, *pos2, *retpos; + int disp, path_present = 0; + + if (!src) return NULL; + + srcendpos = strchr (src, '\0'); + retpos = retbuf; + + /* Look for the node and/or device in front of the path */ + pos1 = src; + pos2 = strchr (pos1, ':'); + + if (pos2 && (pos2 < srcendpos) && (*(pos2 + 1) == ':')) { + /* There is a node name. "node_name::" becomes "node_name!" */ + disp = pos2 - pos1; + strncpy (retbuf, pos1, disp); + retpos [disp] = '!'; + retpos = retpos + disp + 1; + pos1 = pos2 + 2; + pos2 = strchr (pos1, ':'); + } + + if (pos2) { + /* There is a device name. "dev_name:" becomes "/dev_name/" */ + *(retpos++) = '/'; + disp = pos2 - pos1; + strncpy (retpos, pos1, disp); + retpos = retpos + disp; + pos1 = pos2 + 1; + *(retpos++) = '/'; + } + else + /* No explicit device; we must look ahead and prepend /sys$disk/ if + the path is absolute */ + if ((*pos1 == '[' || *pos1 == '<') && (pos1 < srcendpos) + && !strchr (".-]>", *(pos1 + 1))) { + strncpy (retpos, "/sys$disk/", 10); + retpos += 10; + } + + /* Process the path part */ + while (*pos1 == '[' || *pos1 == '<') { + path_present++; + pos1++; + if (*pos1 == ']' || *pos1 == '>') { + /* Special case, [] translates to '.' */ + *(retpos++) = '.'; + pos1++; + } + else { + /* '[000000' means root dir. It can be present in the middle of + the path due to expansion of logical devices, in which case + we skip it */ + if (!strncmp (pos1, "000000", 6) && path_present > 1 && + (*(pos1 + 6) == ']' || *(pos1 + 6) == '>' || *(pos1 + 6) == '.')) { + pos1 += 6; + if (*pos1 == '.') pos1++; + } + else if (*pos1 == '.') { + /* Relative path */ + *(retpos++) = '.'; + } + + /* There is a qualified path */ + while (*pos1 && *pos1 != ']' && *pos1 != '>') { + switch (*pos1) { + case '.': + /* '.' is used to separate directories. Replace it with '/' but + only if there isn't already '/' just before */ + if (*(retpos - 1) != '/') *(retpos++) = '/'; + pos1++; + if (pos1 + 1 < srcendpos && *pos1 == '.' && *(pos1 + 1) == '.') { + /* ellipsis refers to entire subtree; replace with '**' */ + *(retpos++) = '*'; *(retpos++) = '*'; *(retpos++) = '/'; + pos1 += 2; + } + break; + case '-' : + /* When after '.' '[' '<' is equivalent to Unix ".." but there + may be several in a row */ + if (*(pos1 - 1) == '.' || *(pos1 - 1) == '[' || + *(pos1 - 1) == '<') { + while (*pos1 == '-') { + pos1++; + *(retpos++) = '.'; *(retpos++) = '.'; *(retpos++) = '/'; + } + retpos--; + break; + } + /* otherwise fall through to default */ + default: + *(retpos++) = *(pos1++); + } + } + pos1++; + } + } + + if (pos1 < srcendpos) { + /* Now add the actual file name, until the version suffix if any */ + if (path_present) *(retpos++) = '/'; + pos2 = strchr (pos1, ';'); + disp = pos2? (pos2 - pos1) : (srcendpos - pos1); + strncpy (retpos, pos1, disp); + retpos += disp; + if (pos2 && pos2 < srcendpos) { + /* There is a non-empty version suffix. ";" becomes "." */ + *retpos++ = '.'; + disp = srcendpos - pos2 - 1; + strncpy (retpos, pos2 + 1, disp); + retpos += disp; + } + } + + *retpos = '\0'; + + return retbuf; + +} + +/* Translate a VMS syntax directory specification in to Unix syntax. If + PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax + found, return input string. Also translate a dirname that contains no + slashes, in case it's a logical name. */ + +char * +__gnat_to_canonical_dir_spec (char *dirspec, int prefixflag) +{ + int len; + + strcpy (new_canonical_dirspec, ""); + if (strlen (dirspec)) + { + char *dirspec1; + + if (strchr (dirspec, ']') || strchr (dirspec, ':')) + { + strncpy (new_canonical_dirspec, + __gnat_translate_vms (dirspec), + MAXPATH); + } + else if (!strchr (dirspec, '/') && (dirspec1 = getenv (dirspec)) != 0) + { + strncpy (new_canonical_dirspec, + __gnat_translate_vms (dirspec1), + MAXPATH); + } + else + { + strncpy (new_canonical_dirspec, dirspec, MAXPATH); + } + } + + len = strlen (new_canonical_dirspec); + if (prefixflag && new_canonical_dirspec [len-1] != '/') + strncat (new_canonical_dirspec, "/", MAXPATH); + + new_canonical_dirspec [MAXPATH - 1] = (char) 0; + + return new_canonical_dirspec; + +} + +/* Translate a VMS syntax file specification into Unix syntax. + If no indicators of VMS syntax found, check if it's an uppercase + alphanumeric_ name and if so try it out as an environment + variable (logical name). If all else fails return the + input string. */ + +char * +__gnat_to_canonical_file_spec (char *filespec) +{ + char *filespec1; + + strncpy (new_canonical_filespec, "", MAXPATH); + + if (strchr (filespec, ']') || strchr (filespec, ':')) + { + char *tspec = (char *) __gnat_translate_vms (filespec); + + if (tspec != (char *) -1) + strncpy (new_canonical_filespec, tspec, MAXPATH); + } + else if ((strlen (filespec) == strspn (filespec, + "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_")) + && (filespec1 = getenv (filespec))) + { + char *tspec = (char *) __gnat_translate_vms (filespec1); + + if (tspec != (char *) -1) + strncpy (new_canonical_filespec, tspec, MAXPATH); + } + else + { + strncpy (new_canonical_filespec, filespec, MAXPATH); + } + + new_canonical_filespec [MAXPATH - 1] = (char) 0; + + return new_canonical_filespec; +} + +/* Translate a VMS syntax path specification into Unix syntax. + If no indicators of VMS syntax found, return input string. */ + +char * +__gnat_to_canonical_path_spec (char *pathspec) +{ + char *curr, *next, buff [MAXPATH]; + + if (pathspec == 0) + return pathspec; + + /* If there are /'s, assume it's a Unix path spec and return. */ + if (strchr (pathspec, '/')) + return pathspec; + + new_canonical_pathspec[0] = 0; + curr = pathspec; + + for (;;) + { + next = strchr (curr, ','); + if (next == 0) + next = strchr (curr, 0); + + strncpy (buff, curr, next - curr); + buff[next - curr] = 0; + + /* Check for wildcards and expand if present. */ + if (strchr (buff, '*') || strchr (buff, '%') || strstr (buff, "...")) + { + int i, dirs; + + dirs = __gnat_to_canonical_file_list_init (buff, 1); + for (i = 0; i < dirs; i++) + { + char *next_dir; + + next_dir = __gnat_to_canonical_file_list_next (); + strncat (new_canonical_pathspec, next_dir, MAXPATH); + + /* Don't append the separator after the last expansion. */ + if (i+1 < dirs) + strncat (new_canonical_pathspec, ":", MAXPATH); + } + + __gnat_to_canonical_file_list_free (); + } + else + strncat (new_canonical_pathspec, + __gnat_to_canonical_dir_spec (buff, 0), MAXPATH); + + if (*next == 0) + break; + + strncat (new_canonical_pathspec, ":", MAXPATH); + curr = next + 1; + } + + new_canonical_pathspec [MAXPATH - 1] = (char) 0; + + return new_canonical_pathspec; +} + +static char filename_buff [MAXPATH]; + +static int +translate_unix (char *name, int type) +{ + strncpy (filename_buff, name, MAXPATH); + filename_buff [MAXPATH - 1] = (char) 0; + return 0; +} + +/* Translate a Unix syntax path spec into a VMS style (comma separated list of + directories. */ + +static char * +to_host_path_spec (char *pathspec) +{ + char *curr, *next, buff [MAXPATH]; + + if (pathspec == 0) + return pathspec; + + /* Can't very well test for colons, since that's the Unix separator! */ + if (strchr (pathspec, ']') || strchr (pathspec, ',')) + return pathspec; + + new_host_pathspec[0] = 0; + curr = pathspec; + + for (;;) + { + next = strchr (curr, ':'); + if (next == 0) + next = strchr (curr, 0); + + strncpy (buff, curr, next - curr); + buff[next - curr] = 0; + + strncat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0), MAXPATH); + if (*next == 0) + break; + strncat (new_host_pathspec, ",", MAXPATH); + curr = next + 1; + } + + new_host_pathspec [MAXPATH - 1] = (char) 0; + + return new_host_pathspec; +} + +/* Translate a Unix syntax directory specification into VMS syntax. The + PREFIXFLAG has no effect, but is kept for symmetry with + to_canonical_dir_spec. If indicators of VMS syntax found, return input + string. */ + +char * +__gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED) +{ + int len = strlen (dirspec); + + strncpy (new_host_dirspec, dirspec, MAXPATH); + new_host_dirspec [MAXPATH - 1] = (char) 0; + + if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':')) + return new_host_dirspec; + + while (len > 1 && new_host_dirspec[len - 1] == '/') + { + new_host_dirspec[len - 1] = 0; + len--; + } + + decc$to_vms (new_host_dirspec, translate_unix, 1, 2); + strncpy (new_host_dirspec, filename_buff, MAXPATH); + new_host_dirspec [MAXPATH - 1] = (char) 0; + + return new_host_dirspec; +} + +/* Translate a Unix syntax file specification into VMS syntax. + If indicators of VMS syntax found, return input string. */ + +char * +__gnat_to_host_file_spec (char *filespec) +{ + strncpy (new_host_filespec, "", MAXPATH); + if (strchr (filespec, ']') || strchr (filespec, ':')) + { + strncpy (new_host_filespec, filespec, MAXPATH); + } + else + { + decc$to_vms (filespec, translate_unix, 1, 1); + strncpy (new_host_filespec, filename_buff, MAXPATH); + } + + new_host_filespec [MAXPATH - 1] = (char) 0; + + return new_host_filespec; +} + +void +__gnat_adjust_os_resource_limits () +{ + SYS$ADJWSL (131072, 0); +} + +#else /* VMS */ + +/* Dummy functions for Osint import for non-VMS systems. */ + +int +__gnat_to_canonical_file_list_init + (char *dirspec ATTRIBUTE_UNUSED, int onlydirs ATTRIBUTE_UNUSED) +{ + return 0; +} + +char * +__gnat_to_canonical_file_list_next (void) +{ + static char *empty = ""; + return empty; +} + +void +__gnat_to_canonical_file_list_free (void) +{ +} + +char * +__gnat_to_canonical_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED) +{ + return dirspec; +} + +char * +__gnat_to_canonical_file_spec (char *filespec) +{ + return filespec; +} + +char * +__gnat_to_canonical_path_spec (char *pathspec) +{ + return pathspec; +} + +char * +__gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED) +{ + return dirspec; +} + +char * +__gnat_to_host_file_spec (char *filespec) +{ + return filespec; +} + +void +__gnat_adjust_os_resource_limits (void) +{ +} + +#endif + +#if defined (__mips_vxworks) +int +_flush_cache() +{ + CACHE_USER_FLUSH (0, ENTIRE_CACHE); +} +#endif + +#if defined (IS_CROSS) \ + || (! ((defined (sparc) || defined (i386)) && defined (sun) \ + && defined (__SVR4)) \ + && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \ + && ! (defined (linux) && defined (__ia64__)) \ + && ! (defined (linux) && defined (powerpc)) \ + && ! defined (__FreeBSD__) \ + && ! defined (__Lynx__) \ + && ! defined (__hpux__) \ + && ! defined (__APPLE__) \ + && ! defined (_AIX) \ + && ! (defined (__alpha__) && defined (__osf__)) \ + && ! defined (VMS) \ + && ! defined (__MINGW32__) \ + && ! (defined (__mips) && defined (__sgi))) + +/* Dummy function to satisfy g-trasym.o. See the preprocessor conditional + just above for a list of native platforms that provide a non-dummy + version of this procedure in libaddr2line.a. */ + +void +convert_addresses (const char *file_name ATTRIBUTE_UNUSED, + void *addrs ATTRIBUTE_UNUSED, + int n_addr ATTRIBUTE_UNUSED, + void *buf ATTRIBUTE_UNUSED, + int *len ATTRIBUTE_UNUSED) +{ + *len = 0; +} +#endif + +#if defined (_WIN32) +int __gnat_argument_needs_quote = 1; +#else +int __gnat_argument_needs_quote = 0; +#endif + +/* This option is used to enable/disable object files handling from the + binder file by the GNAT Project module. For example, this is disabled on + Windows (prior to GCC 3.4) as it is already done by the mdll module. + Stating with GCC 3.4 the shared libraries are not based on mdll + anymore as it uses the GCC's -shared option */ +#if defined (_WIN32) \ + && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4))) +int __gnat_prj_add_obj_files = 0; +#else +int __gnat_prj_add_obj_files = 1; +#endif + +/* char used as prefix/suffix for environment variables */ +#if defined (_WIN32) +char __gnat_environment_char = '%'; +#else +char __gnat_environment_char = '$'; +#endif + +/* This functions copy the file attributes from a source file to a + destination file. + + mode = 0 : In this mode copy only the file time stamps (last access and + last modification time stamps). + + mode = 1 : In this mode, time stamps and read/write/execute attributes are + copied. + + Returns 0 if operation was successful and -1 in case of error. */ + +int +__gnat_copy_attribs (char *from, char *to, int mode) +{ +#if defined (VMS) || defined (__vxworks) || defined (__nucleus__) + return -1; + +#elif defined (_WIN32) && !defined (RTX) + TCHAR wfrom [GNAT_MAX_PATH_LEN + 2]; + TCHAR wto [GNAT_MAX_PATH_LEN + 2]; + BOOL res; + FILETIME fct, flat, flwt; + HANDLE hfrom, hto; + + S2WSC (wfrom, from, GNAT_MAX_PATH_LEN + 2); + S2WSC (wto, to, GNAT_MAX_PATH_LEN + 2); + + /* retrieve from times */ + + hfrom = CreateFile + (wfrom, GENERIC_READ, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); + + if (hfrom == INVALID_HANDLE_VALUE) + return -1; + + res = GetFileTime (hfrom, &fct, &flat, &flwt); + + CloseHandle (hfrom); + + if (res == 0) + return -1; + + /* retrieve from times */ + + hto = CreateFile + (wto, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); + + if (hto == INVALID_HANDLE_VALUE) + return -1; + + res = SetFileTime (hto, NULL, &flat, &flwt); + + CloseHandle (hto); + + if (res == 0) + return -1; + + /* Set file attributes in full mode. */ + + if (mode == 1) + { + DWORD attribs = GetFileAttributes (wfrom); + + if (attribs == INVALID_FILE_ATTRIBUTES) + return -1; + + res = SetFileAttributes (wto, attribs); + if (res == 0) + return -1; + } + + return 0; + +#else + GNAT_STRUCT_STAT fbuf; + struct utimbuf tbuf; + + if (GNAT_STAT (from, &fbuf) == -1) + { + return -1; + } + + tbuf.actime = fbuf.st_atime; + tbuf.modtime = fbuf.st_mtime; + + if (utime (to, &tbuf) == -1) + { + return -1; + } + + if (mode == 1) + { + if (chmod (to, fbuf.st_mode) == -1) + { + return -1; + } + } + + return 0; +#endif +} + +int +__gnat_lseek (int fd, long offset, int whence) +{ + return (int) lseek (fd, offset, whence); +} + +/* This function returns the major version number of GCC being used. */ +int +get_gcc_version (void) +{ +#ifdef IN_RTS + return __GNUC__; +#else + return (int) (version_string[0] - '0'); +#endif +} + +int +__gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED, + int close_on_exec_p ATTRIBUTE_UNUSED) +{ +#if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks) + int flags = fcntl (fd, F_GETFD, 0); + if (flags < 0) + return flags; + if (close_on_exec_p) + flags |= FD_CLOEXEC; + else + flags &= ~FD_CLOEXEC; + return fcntl (fd, F_SETFD, flags | FD_CLOEXEC); +#elif defined(_WIN32) + HANDLE h = (HANDLE) _get_osfhandle (fd); + if (h == (HANDLE) -1) + return -1; + if (close_on_exec_p) + return ! SetHandleInformation (h, HANDLE_FLAG_INHERIT, 0); + return ! SetHandleInformation (h, HANDLE_FLAG_INHERIT, + HANDLE_FLAG_INHERIT); +#else + /* TODO: Unimplemented. */ + return -1; +#endif +} + +/* Indicates if platforms supports automatic initialization through the + constructor mechanism */ +int +__gnat_binder_supports_auto_init (void) +{ +#ifdef VMS + return 0; +#else + return 1; +#endif +} + +/* Indicates that Stand-Alone Libraries are automatically initialized through + the constructor mechanism */ +int +__gnat_sals_init_using_constructors (void) +{ +#if defined (__vxworks) || defined (__Lynx__) || defined (VMS) + return 0; +#else + return 1; +#endif +} + +#ifdef RTX + +/* In RTX mode, the procedure to get the time (as file time) is different + in RTSS mode and Win32 mode. In order to avoid duplicating an Ada file, + we introduce an intermediate procedure to link against the corresponding + one in each situation. */ + +extern void GetTimeAsFileTime(LPFILETIME pTime); + +void GetTimeAsFileTime(LPFILETIME pTime) +{ +#ifdef RTSS + RtGetRtssTimeAsFileTime (pTime); /* RTSS interface */ +#else + GetSystemTimeAsFileTime (pTime); /* w32 interface */ +#endif +} + +#ifdef RTSS +/* Add symbol that is required to link. It would otherwise be taken from + libgcc.a and it would try to use the gcc constructors that are not + supported by Microsoft linker. */ + +extern void __main (void); + +void __main (void) {} +#endif +#endif + +#if defined (linux) +/* There is no function in the glibc to retrieve the LWP of the current + thread. We need to do a system call in order to retrieve this + information. */ +#include +void *__gnat_lwp_self (void) +{ + return (void *) syscall (__NR_gettid); +} +#endif diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h new file mode 100644 index 000000000..e9ef42c6b --- /dev/null +++ b/gcc/ada/adaint.h @@ -0,0 +1,264 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * A D A I N T * + * * + * C Header File * + * * + * 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. * + * * + ****************************************************************************/ + +#include +#include + +#ifdef _WIN32 +#include "mingw32.h" +#endif + +#include + +/* Constants used for the form parameter encoding values */ +#define Encoding_UTF8 0 /* UTF-8 */ +#define Encoding_8bits 1 /* Standard 8bits, CP_ACP on Windows. */ +#define Encoding_Unspecified 2 /* Based on GNAT_CODE_PAGE env variable. */ + +/* Large file support. It is unclear what portable mechanism we can use to + determine at compile time what support the system offers for large files. + For now we just list the platforms we have manually tested. */ + +#if defined (__GLIBC__) || defined (sun) || (defined (__sgi) && defined(_LFAPI)) +#define GNAT_FOPEN fopen64 +#define GNAT_STAT stat64 +#define GNAT_FSTAT fstat64 +#define GNAT_LSTAT lstat64 +#define GNAT_STRUCT_STAT struct stat64 +#else +#define GNAT_FOPEN fopen +#define GNAT_STAT stat +#define GNAT_FSTAT fstat +#define GNAT_LSTAT lstat +#define GNAT_STRUCT_STAT struct stat +#endif + +/* Type corresponding to GNAT.OS_Lib.OS_Time */ +#if defined (_WIN64) +typedef long long OS_Time; +#else +typedef long OS_Time; +#endif + +/* A lazy cache for the attributes of a file. On some systems, a single call to + stat() will give all this information, so it is better than doing a system + call every time. On other systems this require several system calls. +*/ + +struct file_attributes { + unsigned char exists; + + unsigned char writable; + unsigned char readable; + unsigned char executable; + + unsigned char symbolic_link; + unsigned char regular; + unsigned char directory; + + OS_Time timestamp; + long file_length; +}; +/* WARNING: changing the size here might require changing the constant + * File_Attributes_Size in osint.ads (which should be big enough to + * fit the above struct on any system) + */ + +extern int __gnat_max_path_len; +extern OS_Time __gnat_current_time (void); +extern void __gnat_current_time_string (char *); +extern void __gnat_to_gm_time (OS_Time *, int *, int *, + int *, int *, + int *, int *); +extern int __gnat_get_maximum_file_name_length (void); +extern int __gnat_get_switches_case_sensitive (void); +extern int __gnat_get_file_names_case_sensitive (void); +extern int __gnat_get_env_vars_case_sensitive (void); +extern char __gnat_get_default_identifier_character_set (void); +extern void __gnat_get_current_dir (char *, int *); +extern void __gnat_get_object_suffix_ptr (int *, + const char **); +extern void __gnat_get_executable_suffix_ptr (int *, + const char **); +extern void __gnat_get_debuggable_suffix_ptr (int *, + const char **); +extern int __gnat_readlink (char *, char *, + size_t); +extern int __gnat_symlink (char *, char *); +extern int __gnat_try_lock (char *, char *); +extern int __gnat_open_new (char *, int); +extern int __gnat_open_new_temp (char *, int); +extern int __gnat_mkdir (char *); +extern int __gnat_stat (char *, + GNAT_STRUCT_STAT *); +extern int __gnat_unlink (char *); +extern int __gnat_rename (char *, char *); +extern int __gnat_chdir (char *); +extern int __gnat_rmdir (char *); + +extern FILE *__gnat_fopen (char *, char *, int); +extern FILE *__gnat_freopen (char *, char *, FILE *, + int); +extern int __gnat_open_read (char *, int); +extern int __gnat_open_rw (char *, int); +extern int __gnat_open_create (char *, int); +extern int __gnat_create_output_file (char *); +extern int __gnat_create_output_file_new (char *); + +extern int __gnat_open_append (char *, int); +extern long __gnat_file_length (int); +extern long __gnat_named_file_length (char *); +extern void __gnat_tmp_name (char *); +extern DIR *__gnat_opendir (char *); +extern char *__gnat_readdir (DIR *, char *, int *); +extern int __gnat_closedir (DIR *); +extern int __gnat_readdir_is_thread_safe (void); + +extern OS_Time __gnat_file_time_name (char *); +extern OS_Time __gnat_file_time_fd (int); +/* return -1 in case of error */ + +extern void __gnat_set_file_time_name (char *, time_t); + +extern int __gnat_dup (int); +extern int __gnat_dup2 (int, int); +extern int __gnat_file_exists (char *); +extern int __gnat_is_regular_file (char *); +extern int __gnat_is_absolute_path (char *,int); +extern int __gnat_is_directory (char *); +extern int __gnat_is_writable_file (char *); +extern int __gnat_is_readable_file (char *name); +extern int __gnat_is_executable_file (char *name); + +extern void __gnat_reset_attributes (struct file_attributes* attr); +extern long __gnat_file_length_attr (int, char *, struct file_attributes *); +extern OS_Time __gnat_file_time_name_attr (char *, struct file_attributes *); +extern OS_Time __gnat_file_time_fd_attr (int, struct file_attributes *); +extern int __gnat_file_exists_attr (char *, struct file_attributes *); +extern int __gnat_is_regular_file_attr (char *, struct file_attributes *); +extern int __gnat_is_directory_attr (char *, struct file_attributes *); +extern int __gnat_is_readable_file_attr (char *, struct file_attributes *); +extern int __gnat_is_writable_file_attr (char *, struct file_attributes *); +extern int __gnat_is_executable_file_attr (char *, struct file_attributes *); +extern int __gnat_is_symbolic_link_attr (char *, struct file_attributes *); + +extern void __gnat_set_non_writable (char *name); +extern void __gnat_set_writable (char *name); +extern void __gnat_set_executable (char *name); +extern void __gnat_set_readable (char *name); +extern void __gnat_set_non_readable (char *name); +extern int __gnat_is_symbolic_link (char *name); +extern int __gnat_portable_spawn (char *[]); +extern int __gnat_portable_no_block_spawn (char *[]); +extern int __gnat_portable_wait (int *); +extern char *__gnat_locate_exec (char *, char *); +extern char *__gnat_locate_exec_on_path (char *); +extern char *__gnat_locate_regular_file (char *, char *); +extern void __gnat_maybe_glob_args (int *, char ***); +extern void __gnat_os_exit (int); +extern char *__gnat_get_libraries_from_registry (void); +extern int __gnat_to_canonical_file_list_init (char *, int); +extern char *__gnat_to_canonical_file_list_next (void); +extern void __gnat_to_canonical_file_list_free (void); +extern char *__gnat_to_canonical_dir_spec (char *, int); +extern char *__gnat_to_canonical_file_spec (char *); +extern char *__gnat_to_host_dir_spec (char *, int); +extern char *__gnat_to_host_file_spec (char *); +extern char *__gnat_to_canonical_path_spec (char *); +extern void __gnat_adjust_os_resource_limits (void); +extern void convert_addresses (const char *, void *, int, + void *, int *); +extern int __gnat_copy_attribs (char *, char *, int); +extern int __gnat_feof (FILE *); +extern int __gnat_ferror (FILE *); +extern int __gnat_fileno (FILE *); +extern int __gnat_is_regular_file_fd (int); +extern FILE *__gnat_constant_stderr (void); +extern FILE *__gnat_constant_stdin (void); +extern FILE *__gnat_constant_stdout (void); +extern char *__gnat_full_name (char *, char *); + +extern int __gnat_arg_count (void); +extern int __gnat_len_arg (int); +extern void __gnat_fill_arg (char *, int); +extern int __gnat_env_count (void); +extern int __gnat_len_env (int); +extern void __gnat_fill_env (char *, int); + +/* Routines for interface to scanf and printf functions for integer values */ + +extern int get_int (void); +extern void put_int (int); +extern void put_int_stderr (int); +extern int get_char (void); +extern void put_char (int); +extern void put_char_stderr (int); +extern char *mktemp (char *); + +extern void __gnat_set_exit_status (int); + +extern int __gnat_expect_fork (void); +extern void __gnat_expect_portable_execvp (char *, char *[]); +extern int __gnat_pipe (int *); +extern int __gnat_expect_poll (int *, int, int, int *); +extern void __gnat_set_binary_mode (int); +extern void __gnat_set_text_mode (int); +extern char *__gnat_ttyname (int); +extern int __gnat_lseek (int, long, int); +extern int __gnat_set_close_on_exec (int, int); +extern int __gnat_dup (int); +extern int __gnat_dup2 (int, int); + +extern int __gnat_number_of_cpus (void); + +extern void __gnat_os_filename (char *, char *, char *, + int *, char *, int *); +#if defined (linux) +extern void *__gnat_lwp_self (void); +#endif + +#if defined (_WIN32) +/* Interface to delete a handle from internally maintained list of child + process handles on Windows */ +extern void +__gnat_win32_remove_handle (HANDLE h, int pid); +#endif + +#ifdef IN_RTS +/* Portable definition of strdup, which is not available on all systems. */ +#define xstrdup(S) strcpy ((char *) malloc (strlen (S) + 1), S) +#endif + +/* This function returns the version of GCC being used. Here it's GCC 3. */ +extern int get_gcc_version (void); + +extern int __gnat_binder_supports_auto_init (void); +extern int __gnat_sals_init_using_constructors (void); diff --git a/gcc/ada/ali-util.adb b/gcc/ada/ali-util.adb new file mode 100644 index 000000000..a040d30fa --- /dev/null +++ b/gcc/ada/ali-util.adb @@ -0,0 +1,514 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A L I . U T I L -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Debug; use Debug; +with Binderr; use Binderr; +with Opt; use Opt; +with Output; use Output; +with Osint; use Osint; +with Scans; use Scans; +with Scng; +with Sinput.C; +with Snames; use Snames; +with Styleg; + +package body ALI.Util is + + -- Empty procedures needed to instantiate Scng. Error procedures are + -- empty, because we don't want to report any errors when computing + -- a source checksum. + + procedure Post_Scan; + + procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr); + + procedure Error_Msg_S (Msg : String); + + procedure Error_Msg_SC (Msg : String); + + procedure Error_Msg_SP (Msg : String); + + -- Instantiation of Styleg, needed to instantiate Scng + + package Style is new Styleg + (Error_Msg, Error_Msg_S, Error_Msg_SC, Error_Msg_SP); + + -- A Scanner is needed to get checksum of a source (procedure + -- Get_File_Checksum). + + package Scanner is new Scng + (Post_Scan, Error_Msg, Error_Msg_S, Error_Msg_SC, Error_Msg_SP, Style); + + type Header_Num is range 0 .. 1_000; + + function Hash (F : File_Name_Type) return Header_Num; + -- Function used to compute hash of ALI file name + + package Interfaces is new Simple_HTable ( + Header_Num => Header_Num, + Element => Boolean, + No_Element => False, + Key => File_Name_Type, + Hash => Hash, + Equal => "="); + + --------------------- + -- Checksums_Match -- + --------------------- + + function Checksums_Match (Checksum1, Checksum2 : Word) return Boolean is + begin + return Checksum1 = Checksum2 and then Checksum1 /= Checksum_Error; + end Checksums_Match; + + --------------- + -- Error_Msg -- + --------------- + + procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is + pragma Warnings (Off, Msg); + pragma Warnings (Off, Flag_Location); + begin + null; + end Error_Msg; + + ----------------- + -- Error_Msg_S -- + ----------------- + + procedure Error_Msg_S (Msg : String) is + pragma Warnings (Off, Msg); + begin + null; + end Error_Msg_S; + + ------------------ + -- Error_Msg_SC -- + ------------------ + + procedure Error_Msg_SC (Msg : String) is + pragma Warnings (Off, Msg); + begin + null; + end Error_Msg_SC; + + ------------------ + -- Error_Msg_SP -- + ------------------ + + procedure Error_Msg_SP (Msg : String) is + pragma Warnings (Off, Msg); + begin + null; + end Error_Msg_SP; + + ----------------------- + -- Get_File_Checksum -- + ----------------------- + + function Get_File_Checksum (Fname : File_Name_Type) return Word is + Full_Name : File_Name_Type; + Source_Index : Source_File_Index; + + begin + Full_Name := Find_File (Fname, Osint.Source); + + -- If we cannot find the file, then return an impossible checksum, + -- impossible because checksums have the high order bit zero, so + -- that checksums do not match. + + if Full_Name = No_File then + return Checksum_Error; + end if; + + Source_Index := Sinput.C.Load_File (Get_Name_String (Full_Name)); + + if Source_Index = No_Source_File then + return Checksum_Error; + end if; + + Scanner.Initialize_Scanner (Source_Index); + + -- Make sure that the project language reserved words are not + -- recognized as reserved words, but as identifiers. The byte info for + -- those names have been set if we are in gnatmake. + + Set_Name_Table_Byte (Name_Project, 0); + Set_Name_Table_Byte (Name_Extends, 0); + Set_Name_Table_Byte (Name_External, 0); + Set_Name_Table_Byte (Name_External_As_List, 0); + + -- Scan the complete file to compute its checksum + + loop + Scanner.Scan; + exit when Token = Tok_EOF; + end loop; + + return Scans.Checksum; + end Get_File_Checksum; + + ---------- + -- Hash -- + ---------- + + function Hash (F : File_Name_Type) return Header_Num is + begin + return Header_Num (Int (F) rem Header_Num'Range_Length); + end Hash; + + --------------------------- + -- Initialize_ALI_Source -- + --------------------------- + + procedure Initialize_ALI_Source is + begin + -- When (re)initializing ALI data structures the ALI user expects to + -- get a fresh set of data structures. Thus we first need to erase the + -- marks put in the name table by the previous set of ALI routine calls. + -- This loop is empty and harmless the first time in. + + for J in Source.First .. Source.Last loop + Set_Name_Table_Info (Source.Table (J).Sfile, 0); + Source.Table (J).Source_Found := False; + end loop; + + Source.Init; + Interfaces.Reset; + end Initialize_ALI_Source; + + --------------- + -- Post_Scan -- + --------------- + + procedure Post_Scan is + begin + null; + end Post_Scan; + + ---------------------- + -- Read_Withed_ALIs -- + ---------------------- + + procedure Read_Withed_ALIs (Id : ALI_Id) is + Afile : File_Name_Type; + Text : Text_Buffer_Ptr; + Idread : ALI_Id; + + begin + -- Process all dependent units + + for U in ALIs.Table (Id).First_Unit .. ALIs.Table (Id).Last_Unit loop + for + W in Units.Table (U).First_With .. Units.Table (U).Last_With + loop + Afile := Withs.Table (W).Afile; + + -- Only process if not a generic (Afile /= No_File) and if + -- file has not been processed already. + + if Afile /= No_File + and then Get_Name_Table_Info (Afile) = 0 + then + Text := Read_Library_Info (Afile); + + -- Return with an error if source cannot be found. We used to + -- skip this check when we did not compile library generics + -- separately, but we now always do, so there is no special + -- case here anymore. + + if Text = null then + Error_Msg_File_1 := Afile; + Error_Msg_File_2 := Withs.Table (W).Sfile; + Error_Msg ("{ not found, { must be compiled"); + Set_Name_Table_Info (Afile, Int (No_Unit_Id)); + return; + end if; + + -- Enter in ALIs table + + Idread := + Scan_ALI + (F => Afile, + T => Text, + Ignore_ED => False, + Err => False); + + Free (Text); + + if ALIs.Table (Idread).Compile_Errors then + Error_Msg_File_1 := Withs.Table (W).Sfile; + Error_Msg ("{ had errors, must be fixed, and recompiled"); + Set_Name_Table_Info (Afile, Int (No_Unit_Id)); + + elsif ALIs.Table (Idread).No_Object then + Error_Msg_File_1 := Withs.Table (W).Sfile; + Error_Msg ("{ must be recompiled"); + Set_Name_Table_Info (Afile, Int (No_Unit_Id)); + end if; + + -- If the Unit is an Interface to a Stand-Alone Library, + -- set the Interface flag in the Withs table, so that its + -- dependant are not considered for elaboration order. + + if ALIs.Table (Idread).SAL_Interface then + Withs.Table (W).SAL_Interface := True; + Interface_Library_Unit := True; + + -- Set the entry in the Interfaces hash table, so that other + -- units that import this unit will set the flag in their + -- entry in the Withs table. + + Interfaces.Set (Afile, True); + + else + -- Otherwise, recurse to get new dependents + + Read_Withed_ALIs (Idread); + end if; + + -- If the ALI file has already been processed and is an interface, + -- set the flag in the entry of the Withs table. + + elsif Interface_Library_Unit and then Interfaces.Get (Afile) then + Withs.Table (W).SAL_Interface := True; + end if; + end loop; + end loop; + end Read_Withed_ALIs; + + ---------------------- + -- Set_Source_Table -- + ---------------------- + + procedure Set_Source_Table (A : ALI_Id) is + F : File_Name_Type; + S : Source_Id; + Stamp : Time_Stamp_Type; + + begin + Sdep_Loop : for D in + ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep + loop + F := Sdep.Table (D).Sfile; + + if F /= No_File then + + -- If this is the first time we are seeing this source file, + -- then make a new entry in the source table. + + if Get_Name_Table_Info (F) = 0 then + Source.Increment_Last; + S := Source.Last; + Set_Name_Table_Info (F, Int (S)); + Source.Table (S).Sfile := F; + Source.Table (S).All_Timestamps_Match := True; + + -- Initialize checksum fields + + Source.Table (S).Checksum := Sdep.Table (D).Checksum; + Source.Table (S).All_Checksums_Match := True; + + -- In check source files mode, try to get time stamp from file + + if Opt.Check_Source_Files then + Stamp := Source_File_Stamp (F); + + -- If we got the stamp, then set the stamp in the source + -- table entry and mark it as set from the source so that + -- it does not get subsequently changed. + + if Stamp (Stamp'First) /= ' ' then + Source.Table (S).Stamp := Stamp; + Source.Table (S).Source_Found := True; + + -- If we could not find the file, then the stamp is set + -- from the dependency table entry (to be possibly reset + -- if we find a later stamp in subsequent processing) + + else + Source.Table (S).Stamp := Sdep.Table (D).Stamp; + Source.Table (S).Source_Found := False; + + -- In All_Sources mode, flag error of file not found + + if Opt.All_Sources then + Error_Msg_File_1 := F; + Error_Msg ("cannot locate {"); + end if; + end if; + + -- First time for this source file, but Check_Source_Files + -- is off, so simply initialize the stamp from the Sdep entry + + else + Source.Table (S).Source_Found := False; + Source.Table (S).Stamp := Sdep.Table (D).Stamp; + end if; + + -- Here if this is not the first time for this source file, + -- so that the source table entry is already constructed. + + else + S := Source_Id (Get_Name_Table_Info (F)); + + -- Update checksum flag + + if not Checksums_Match + (Sdep.Table (D).Checksum, Source.Table (S).Checksum) + then + Source.Table (S).All_Checksums_Match := False; + end if; + + -- Check for time stamp mismatch + + if Sdep.Table (D).Stamp /= Source.Table (S).Stamp then + Source.Table (S).All_Timestamps_Match := False; + + -- When we have a time stamp mismatch, we go look for the + -- source file even if Check_Source_Files is false, since + -- if we find it, then we can use it to resolve which of the + -- two timestamps in the ALI files is likely to be correct. + + if not Check_Source_Files then + Stamp := Source_File_Stamp (F); + + if Stamp (Stamp'First) /= ' ' then + Source.Table (S).Stamp := Stamp; + Source.Table (S).Source_Found := True; + end if; + end if; + + -- If the stamp in the source table entry was set from the + -- source file, then we do not change it (the stamp in the + -- source file is always taken as the "right" one). + + if Source.Table (S).Source_Found then + null; + + -- Otherwise, we have no source file available, so we guess + -- that the later of the two timestamps is the right one. + -- Note that this guess only affects which error messages + -- are issued later on, not correct functionality. + + else + if Sdep.Table (D).Stamp > Source.Table (S).Stamp then + Source.Table (S).Stamp := Sdep.Table (D).Stamp; + end if; + end if; + end if; + end if; + + -- Set the checksum value in the source table + + S := Source_Id (Get_Name_Table_Info (F)); + Source.Table (S).Checksum := Sdep.Table (D).Checksum; + end if; + + end loop Sdep_Loop; + end Set_Source_Table; + + ---------------------- + -- Set_Source_Table -- + ---------------------- + + procedure Set_Source_Table is + begin + for A in ALIs.First .. ALIs.Last loop + Set_Source_Table (A); + end loop; + end Set_Source_Table; + + ------------------------- + -- Time_Stamp_Mismatch -- + ------------------------- + + function Time_Stamp_Mismatch + (A : ALI_Id; + Read_Only : Boolean := False) return File_Name_Type + is + Src : Source_Id; + -- Source file Id for the current Sdep entry + + begin + for D in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop + Src := Source_Id (Get_Name_Table_Info (Sdep.Table (D).Sfile)); + + if Opt.Minimal_Recompilation + and then Sdep.Table (D).Stamp /= Source.Table (Src).Stamp + then + -- If minimal recompilation is in action, replace the stamp + -- of the source file in the table if checksums match. + + -- ??? It is probably worth updating the ALI file with a new + -- field to avoid recomputing it each time. + + if Checksums_Match + (Get_File_Checksum (Sdep.Table (D).Sfile), + Source.Table (Src).Checksum) + then + if Verbose_Mode then + Write_Str (" "); + Write_Str (Get_Name_String (Sdep.Table (D).Sfile)); + Write_Str (": up to date, different timestamps " & + "but same checksum"); + Write_Eol; + end if; + + Sdep.Table (D).Stamp := Source.Table (Src).Stamp; + end if; + + end if; + + if (not Read_Only) or else Source.Table (Src).Source_Found then + if not Source.Table (Src).Source_Found + or else Sdep.Table (D).Stamp /= Source.Table (Src).Stamp + then + -- If -dt debug flag set, output time stamp found/expected + + if Source.Table (Src).Source_Found and then Debug_Flag_T then + Write_Str ("Source: """); + Get_Name_String (Sdep.Table (D).Sfile); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Line (""""); + + Write_Str (" time stamp expected: "); + Write_Line (String (Sdep.Table (D).Stamp)); + + Write_Str (" time stamp found: "); + Write_Line (String (Source.Table (Src).Stamp)); + end if; + + -- Return the source file + + return Source.Table (Src).Sfile; + end if; + end if; + end loop; + + return No_File; + end Time_Stamp_Mismatch; + +end ALI.Util; diff --git a/gcc/ada/ali-util.ads b/gcc/ada/ali-util.ads new file mode 100644 index 000000000..cbdb14f70 --- /dev/null +++ b/gcc/ada/ali-util.ads @@ -0,0 +1,154 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A L I . U T I L -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This child unit provides utility data structures and procedures used +-- for manipulation of ALI data by the gnatbind and gnatmake. + +package ALI.Util is + + ----------------------- + -- Source File Table -- + ----------------------- + + -- A table entry is built for every source file that is in the source + -- dependency table of any ALI file that is part of the current program. + + No_Source_Id : constant Source_Id := Source_Id'First; + -- Special value indicating no Source table entry + + First_Source_Entry : constant Source_Id := No_Source_Id + 1; + -- Id of first actual entry in table + + type Source_Record is record + + Sfile : File_Name_Type; + -- Name of source file + + Stamp : Time_Stamp_Type; + -- Time stamp value. If Check_Source_Files is set and the source + -- file is located, then Stamp is set from the source file. Otherwise + -- Stamp is set from the latest stamp value found in any of the + -- ALI files for the current program. + + Source_Found : Boolean; + -- This flag is set to True if the corresponding source file was + -- located and the Stamp value was set from the actual source file. + -- It is always false if Check_Source_Files is not set. + + All_Timestamps_Match : Boolean; + -- This flag is set only if all files referencing this source file + -- have a matching time stamp, and also, if Source_Found is True, + -- then the stamp of the source file also matches. If this flag is + -- True, then checksums for this file are never referenced. We only + -- use checksums if there are time stamp mismatches. + + All_Checksums_Match : Boolean; + -- This flag is set only if all files referencing this source file + -- have checksums, and if all these checksums match. If this flag + -- is set to True, then the binder will ignore a timestamp mismatch. + -- An absent checksum causes this flag to be set False, and a mismatch + -- of checksums also causes it to be set False. The checksum of the + -- actual source file (if Source_Found is True) is included only if + -- All_Timestamps_Match is False (since checksums are only interesting + -- if we have time stamp mismatches, and we want to avoid computing the + -- checksum of the source file if it is not needed.) + + Checksum : Word; + -- If no dependency line has a checksum for this source file (i.e. the + -- corresponding entries in the source dependency records all have the + -- Checksum_Present flag set False), then this field is undefined. If + -- at least one dependency entry has a checksum present, then this + -- field contains one of the possible checksum values that has been + -- seen. This is used to set All_Checksums_Match properly. + + end record; + + package Source is new Table.Table ( + Table_Component_Type => Source_Record, + Table_Index_Type => Source_Id, + Table_Low_Bound => First_Source_Entry, + Table_Initial => 1000, + Table_Increment => 200, + Table_Name => "Source"); + + procedure Initialize_ALI_Source; + -- Initialize Source table + + -------------------------------------------------- + -- Subprograms for Manipulating ALI Information -- + -------------------------------------------------- + + procedure Read_Withed_ALIs (Id : ALI_Id); + -- Process an ALI file which has been read and scanned by looping through + -- all withed units in the ALI file, checking if they have been processed. + -- Each unit that has not yet been processed will be read, scanned, and + -- processed recursively. + + procedure Set_Source_Table (A : ALI_Id); + -- Build source table entry corresponding to the ALI file whose id is A + + procedure Set_Source_Table; + -- Build the entire source table + + function Time_Stamp_Mismatch + (A : ALI_Id; + Read_Only : Boolean := False) return File_Name_Type; + -- Looks in the Source_Table and checks time stamp mismatches between + -- the sources there and the sources in the Sdep section of ali file whose + -- id is A. If no time stamp mismatches are found No_File is returned. + -- Otherwise return the first file for which there is a mismatch. + -- Note that in check source files mode (Check_Source_Files = True), the + -- time stamp in the Source_Table should be the actual time stamp of the + -- source files. In minimal recompilation mode (Minimal_Recompilation set + -- to True, no mismatch is found if the file's timestamp has not changed. + -- If Read_Only is True, missing sources are not considered. + + -------------------------------------------- + -- Subprograms for manipulating checksums -- + -------------------------------------------- + + Checksum_Error : constant Word := 16#FFFF_FFFF#; + -- This value is used to indicate an error in computing the checksum. + -- When comparing checksums for smart recompilation, the CRC_Error + -- value is never considered to match. This could possibly result + -- in a false negative, but that is never harmful, it just means + -- that in unusual cases an unnecessary recompilation occurs. + + function Get_File_Checksum (Fname : File_Name_Type) return Word; + -- Compute checksum for the given file. As far as possible, this circuit + -- computes exactly the same value computed by the compiler, but it does + -- not matter if it gets it wrong in marginal cases, since the only result + -- is to miss some smart recompilation cases, correct functioning is not + -- affected by a miscomputation. Returns Checksum_Error if the file is + -- missing or has an error. + + function Checksums_Match (Checksum1, Checksum2 : Word) return Boolean; + pragma Inline (Checksums_Match); + -- Returns True if Checksum1 and Checksum2 have the same value and are + -- not equal to Checksum_Error, returns False in all other cases. This + -- routine must always be used to compare for checksum equality, to + -- ensure that the case of Checksum_Error is handled properly. + +end ALI.Util; diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb new file mode 100644 index 000000000..4ea38e2ef --- /dev/null +++ b/gcc/ada/ali.adb @@ -0,0 +1,2475 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A L I -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Butil; use Butil; +with Debug; use Debug; +with Fname; use Fname; +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; + +package body ALI is + + use ASCII; + -- Make control characters visible + + -- The following variable records which characters currently are + -- used as line type markers in the ALI file. This is used in + -- Scan_ALI to detect (or skip) invalid lines. + + Known_ALI_Lines : constant array (Character range 'A' .. 'Z') of Boolean := + ('V' => True, -- version + 'M' => True, -- main program + 'A' => True, -- argument + 'P' => True, -- program + 'R' => True, -- restriction + 'I' => True, -- interrupt + 'U' => True, -- unit + 'W' => True, -- with + 'L' => True, -- linker option + 'N' => True, -- notes + 'E' => True, -- external + 'D' => True, -- dependency + 'X' => True, -- xref + 'S' => True, -- specific dispatching + 'Y' => True, -- limited_with + others => False); + + -------------------- + -- Initialize_ALI -- + -------------------- + + procedure Initialize_ALI is + begin + -- When (re)initializing ALI data structures the ALI user expects to + -- get a fresh set of data structures. Thus we first need to erase the + -- marks put in the name table by the previous set of ALI routine calls. + -- These two loops are empty and harmless the first time in. + + for J in ALIs.First .. ALIs.Last loop + Set_Name_Table_Info (ALIs.Table (J).Afile, 0); + end loop; + + for J in Units.First .. Units.Last loop + Set_Name_Table_Info (Units.Table (J).Uname, 0); + end loop; + + -- Free argument table strings + + for J in Args.First .. Args.Last loop + Free (Args.Table (J)); + end loop; + + -- Initialize all tables + + ALIs.Init; + No_Deps.Init; + Units.Init; + Withs.Init; + Sdep.Init; + Linker_Options.Init; + Notes.Init; + Xref_Section.Init; + Xref_Entity.Init; + Xref.Init; + Version_Ref.Reset; + + -- Add dummy zero'th item in Linker_Options and Notes for sort calls + + Linker_Options.Increment_Last; + Notes.Increment_Last; + + -- Initialize global variables recording cumulative options in all + -- ALI files that are read for a given processing run in gnatbind. + + Dynamic_Elaboration_Checks_Specified := False; + Float_Format_Specified := ' '; + Locking_Policy_Specified := ' '; + No_Normalize_Scalars_Specified := False; + No_Object_Specified := False; + Normalize_Scalars_Specified := False; + Queuing_Policy_Specified := ' '; + Static_Elaboration_Model_Used := False; + Task_Dispatching_Policy_Specified := ' '; + Unreserve_All_Interrupts_Specified := False; + Zero_Cost_Exceptions_Specified := False; + end Initialize_ALI; + + -------------- + -- Scan_ALI -- + -------------- + + function Scan_ALI + (F : File_Name_Type; + T : Text_Buffer_Ptr; + Ignore_ED : Boolean; + Err : Boolean; + Read_Xref : Boolean := False; + Read_Lines : String := ""; + Ignore_Lines : String := "X"; + Ignore_Errors : Boolean := False; + Directly_Scanned : Boolean := False) return ALI_Id + is + P : Text_Ptr := T'First; + Line : Logical_Line_Number := 1; + Id : ALI_Id; + C : Character; + NS_Found : Boolean; + First_Arg : Arg_Id; + + Ignore : array (Character range 'A' .. 'Z') of Boolean; + -- Ignore (X) is set to True if lines starting with X are to + -- be ignored by Scan_ALI and skipped, and False if the lines + -- are to be read and processed. + + Bad_ALI_Format : exception; + -- Exception raised by Fatal_Error if Err is True + + function At_Eol return Boolean; + -- Test if at end of line + + function At_End_Of_Field return Boolean; + -- Test if at end of line, or if at blank or horizontal tab + + procedure Check_At_End_Of_Field; + -- Check if we are at end of field, fatal error if not + + procedure Checkc (C : Character); + -- Check next character is C. If so bump past it, if not fatal error + + procedure Check_Unknown_Line; + -- If Ignore_Errors mode, then checks C to make sure that it is not + -- an unknown ALI line type characters, and if so, skips lines + -- until the first character of the line is one of these characters, + -- at which point it does a Getc to put that character in C. The + -- call has no effect if C is already an appropriate character. + -- If not in Ignore_Errors mode, a fatal error is signalled if the + -- line is unknown. Note that if C is an EOL on entry, the line is + -- skipped (it is assumed that blank lines are never significant). + -- If C is EOF on entry, the call has no effect (it is assumed that + -- the caller will properly handle this case). + + procedure Fatal_Error; + -- Generate fatal error message for badly formatted ALI file if + -- Err is false, or raise Bad_ALI_Format if Err is True. + + procedure Fatal_Error_Ignore; + pragma Inline (Fatal_Error_Ignore); + -- In Ignore_Errors mode, has no effect, otherwise same as Fatal_Error + + function Getc return Character; + -- Get next character, bumping P past the character obtained + + function Get_File_Name (Lower : Boolean := False) return File_Name_Type; + -- Skip blanks, then scan out a file name (name is left in Name_Buffer + -- with length in Name_Len, as well as returning a File_Name_Type value. + -- If lower is false, the case is unchanged, if Lower is True then the + -- result is forced to all lower case for systems where file names are + -- not case sensitive. This ensures that gnatbind works correctly + -- regardless of the case of the file name on all systems. The scan + -- is terminated by a end of line, space or horizontal tab. Any other + -- special characters are included in the returned name. + + function Get_Name + (Ignore_Spaces : Boolean := False; + Ignore_Special : Boolean := False) return Name_Id; + -- Skip blanks, then scan out a name (name is left in Name_Buffer with + -- length in Name_Len, as well as being returned in Name_Id form). + -- If Lower is set to True then the Name_Buffer will be converted to + -- all lower case, for systems where file names are not case sensitive. + -- This ensures that gnatbind works correctly regardless of the case + -- of the file name on all systems. The termination condition depends + -- on the settings of Ignore_Spaces and Ignore_Special: + -- + -- If Ignore_Spaces is False (normal case), then scan is terminated + -- by the normal end of field condition (EOL, space, horizontal tab) + -- + -- If Ignore_Special is False (normal case), the scan is terminated by + -- a typeref bracket or an equal sign except for the special case of + -- an operator name starting with a double quote which is terminated + -- by another double quote. + -- + -- It is an error to set both Ignore_Spaces and Ignore_Special to True. + -- This function handles wide characters properly. + + function Get_Nat return Nat; + -- Skip blanks, then scan out an unsigned integer value in Nat range + -- raises ALI_Reading_Error if the encoutered type is not natural. + + function Get_Stamp return Time_Stamp_Type; + -- Skip blanks, then scan out a time stamp + + function Get_Unit_Name return Unit_Name_Type; + -- Skip blanks, then scan out a file name (name is left in Name_Buffer + -- with length in Name_Len, as well as returning a Unit_Name_Type value. + -- The case is unchanged and terminated by a normal end of field. + + function Nextc return Character; + -- Return current character without modifying pointer P + + procedure Get_Typeref + (Current_File_Num : Sdep_Id; + Ref : out Tref_Kind; + File_Num : out Sdep_Id; + Line : out Nat; + Ref_Type : out Character; + Col : out Nat; + Standard_Entity : out Name_Id); + -- Parse the definition of a typeref (<...>, {...} or (...)) + + procedure Skip_Eol; + -- Skip past spaces, then skip past end of line (fatal error if not + -- at end of line). Also skips past any following blank lines. + + procedure Skip_Line; + -- Skip rest of current line and any following blank lines + + procedure Skip_Space; + -- Skip past white space (blanks or horizontal tab) + + procedure Skipc; + -- Skip past next character, does not affect value in C. This call + -- is like calling Getc and ignoring the returned result. + + --------------------- + -- At_End_Of_Field -- + --------------------- + + function At_End_Of_Field return Boolean is + begin + return Nextc <= ' '; + end At_End_Of_Field; + + ------------ + -- At_Eol -- + ------------ + + function At_Eol return Boolean is + begin + return Nextc = EOF or else Nextc = CR or else Nextc = LF; + end At_Eol; + + --------------------------- + -- Check_At_End_Of_Field -- + --------------------------- + + procedure Check_At_End_Of_Field is + begin + if not At_End_Of_Field then + if Ignore_Errors then + while Nextc > ' ' loop + P := P + 1; + end loop; + else + Fatal_Error; + end if; + end if; + end Check_At_End_Of_Field; + + ------------------------ + -- Check_Unknown_Line -- + ------------------------ + + procedure Check_Unknown_Line is + begin + while C not in 'A' .. 'Z' + or else not Known_ALI_Lines (C) + loop + if C = CR or else C = LF then + Skip_Line; + C := Nextc; + + elsif C = EOF then + return; + + elsif Ignore_Errors then + Skip_Line; + C := Getc; + + else + Fatal_Error; + end if; + end loop; + end Check_Unknown_Line; + + ------------ + -- Checkc -- + ------------ + + procedure Checkc (C : Character) is + begin + if Nextc = C then + P := P + 1; + elsif Ignore_Errors then + P := P + 1; + else + Fatal_Error; + end if; + end Checkc; + + ----------------- + -- Fatal_Error -- + ----------------- + + procedure Fatal_Error is + Ptr1 : Text_Ptr; + Ptr2 : Text_Ptr; + Col : Int; + + procedure Wchar (C : Character); + -- Write a single character, replacing horizontal tab by spaces + + procedure Wchar (C : Character) is + begin + if C = HT then + loop + Wchar (' '); + exit when Col mod 8 = 0; + end loop; + + else + Write_Char (C); + Col := Col + 1; + end if; + end Wchar; + + -- Start of processing for Fatal_Error + + begin + if Err then + raise Bad_ALI_Format; + end if; + + Set_Standard_Error; + Write_Str ("fatal error: file "); + Write_Name (F); + Write_Str (" is incorrectly formatted"); + Write_Eol; + + Write_Str ("make sure you are using consistent versions " & + + -- Split the following line so that it can easily be transformed for + -- e.g. JVM/.NET back-ends where the compiler has a different name. + + "of gcc/gnatbind"); + + Write_Eol; + + -- Find start of line + + Ptr1 := P; + while Ptr1 > T'First + and then T (Ptr1 - 1) /= CR + and then T (Ptr1 - 1) /= LF + loop + Ptr1 := Ptr1 - 1; + end loop; + + Write_Int (Int (Line)); + Write_Str (". "); + + if Line < 100 then + Write_Char (' '); + end if; + + if Line < 10 then + Write_Char (' '); + end if; + + Col := 0; + Ptr2 := Ptr1; + + while Ptr2 < T'Last + and then T (Ptr2) /= CR + and then T (Ptr2) /= LF + loop + Wchar (T (Ptr2)); + Ptr2 := Ptr2 + 1; + end loop; + + Write_Eol; + + Write_Str (" "); + Col := 0; + + while Ptr1 < P loop + if T (Ptr1) = HT then + Wchar (HT); + else + Wchar (' '); + end if; + + Ptr1 := Ptr1 + 1; + end loop; + + Wchar ('|'); + Write_Eol; + + Exit_Program (E_Fatal); + end Fatal_Error; + + ------------------------ + -- Fatal_Error_Ignore -- + ------------------------ + + procedure Fatal_Error_Ignore is + begin + if not Ignore_Errors then + Fatal_Error; + end if; + end Fatal_Error_Ignore; + + ------------------- + -- Get_File_Name -- + ------------------- + + function Get_File_Name + (Lower : Boolean := False) return File_Name_Type + is + F : Name_Id; + + begin + F := Get_Name (Ignore_Special => True); + + -- Convert file name to all lower case if file names are not case + -- sensitive. This ensures that we handle names in the canonical + -- lower case format, regardless of the actual case. + + if Lower and not File_Names_Case_Sensitive then + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + return Name_Find; + else + return File_Name_Type (F); + end if; + end Get_File_Name; + + -------------- + -- Get_Name -- + -------------- + + function Get_Name + (Ignore_Spaces : Boolean := False; + Ignore_Special : Boolean := False) return Name_Id + is + begin + Name_Len := 0; + Skip_Space; + + if At_Eol then + if Ignore_Errors then + return Error_Name; + else + Fatal_Error; + end if; + end if; + + loop + Add_Char_To_Name_Buffer (Getc); + + exit when At_End_Of_Field and then not Ignore_Spaces; + + if not Ignore_Special then + if Name_Buffer (1) = '"' then + exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"'; + + else + -- Terminate on parens or angle brackets or equal sign + + exit when Nextc = '(' or else Nextc = ')' + or else Nextc = '{' or else Nextc = '}' + or else Nextc = '<' or else Nextc = '>' + or else Nextc = '='; + + -- Terminate if left bracket not part of wide char sequence + -- Note that we only recognize brackets notation so far ??? + + exit when Nextc = '[' and then T (P + 1) /= '"'; + + -- Terminate if right bracket not part of wide char sequence + + exit when Nextc = ']' and then T (P - 1) /= '"'; + end if; + end if; + end loop; + + return Name_Find; + end Get_Name; + + ------------------- + -- Get_Unit_Name -- + ------------------- + + function Get_Unit_Name return Unit_Name_Type is + begin + return Unit_Name_Type (Get_Name); + end Get_Unit_Name; + + ------------- + -- Get_Nat -- + ------------- + + function Get_Nat return Nat is + V : Nat; + + begin + Skip_Space; + + -- Check if we are on a number. In the case of bad ALI files, this + -- may not be true. + + if not (Nextc in '0' .. '9') then + Fatal_Error; + end if; + + V := 0; + loop + V := V * 10 + (Character'Pos (Getc) - Character'Pos ('0')); + + exit when At_End_Of_Field; + exit when Nextc < '0' or else Nextc > '9'; + end loop; + + return V; + end Get_Nat; + + --------------- + -- Get_Stamp -- + --------------- + + function Get_Stamp return Time_Stamp_Type is + T : Time_Stamp_Type; + Start : Integer; + + begin + Skip_Space; + + if At_Eol then + if Ignore_Errors then + return Dummy_Time_Stamp; + else + Fatal_Error; + end if; + end if; + + -- Following reads old style time stamp missing first two digits + + if Nextc in '7' .. '9' then + T (1) := '1'; + T (2) := '9'; + Start := 3; + + -- Normal case of full year in time stamp + + else + Start := 1; + end if; + + for J in Start .. T'Last loop + T (J) := Getc; + end loop; + + return T; + end Get_Stamp; + + ----------------- + -- Get_Typeref -- + ----------------- + + procedure Get_Typeref + (Current_File_Num : Sdep_Id; + Ref : out Tref_Kind; + File_Num : out Sdep_Id; + Line : out Nat; + Ref_Type : out Character; + Col : out Nat; + Standard_Entity : out Name_Id) + is + N : Nat; + begin + case Nextc is + when '<' => Ref := Tref_Derived; + when '(' => Ref := Tref_Access; + when '{' => Ref := Tref_Type; + when others => Ref := Tref_None; + end case; + + -- Case of typeref field present + + if Ref /= Tref_None then + P := P + 1; -- skip opening bracket + + if Nextc in 'a' .. 'z' then + File_Num := No_Sdep_Id; + Line := 0; + Ref_Type := ' '; + Col := 0; + Standard_Entity := Get_Name (Ignore_Spaces => True); + else + N := Get_Nat; + + if Nextc = '|' then + File_Num := Sdep_Id (N + Nat (First_Sdep_Entry) - 1); + P := P + 1; + N := Get_Nat; + else + File_Num := Current_File_Num; + end if; + + Line := N; + Ref_Type := Getc; + Col := Get_Nat; + Standard_Entity := No_Name; + end if; + + -- ??? Temporary workaround for nested generics case: + -- 4i4 Directories{1|4I9[4|6[3|3]]} + -- See C918-002 + + declare + Nested_Brackets : Natural := 0; + + begin + loop + case Nextc is + when '[' => + Nested_Brackets := Nested_Brackets + 1; + when ']' => + Nested_Brackets := Nested_Brackets - 1; + when others => + if Nested_Brackets = 0 then + exit; + end if; + end case; + + Skipc; + end loop; + end; + + P := P + 1; -- skip closing bracket + Skip_Space; + + -- No typeref entry present + + else + File_Num := No_Sdep_Id; + Line := 0; + Ref_Type := ' '; + Col := 0; + Standard_Entity := No_Name; + end if; + end Get_Typeref; + + ---------- + -- Getc -- + ---------- + + function Getc return Character is + begin + if P = T'Last then + return EOF; + else + P := P + 1; + return T (P - 1); + end if; + end Getc; + + ----------- + -- Nextc -- + ----------- + + function Nextc return Character is + begin + return T (P); + end Nextc; + + -------------- + -- Skip_Eol -- + -------------- + + procedure Skip_Eol is + begin + Skip_Space; + + if not At_Eol then + if Ignore_Errors then + while not At_Eol loop + P := P + 1; + end loop; + else + Fatal_Error; + end if; + end if; + + -- Loop to skip past blank lines (first time through skips this EOL) + + while Nextc < ' ' and then Nextc /= EOF loop + if Nextc = LF then + Line := Line + 1; + end if; + + P := P + 1; + end loop; + end Skip_Eol; + + --------------- + -- Skip_Line -- + --------------- + + procedure Skip_Line is + begin + while not At_Eol loop + P := P + 1; + end loop; + + Skip_Eol; + end Skip_Line; + + ---------------- + -- Skip_Space -- + ---------------- + + procedure Skip_Space is + begin + while Nextc = ' ' or else Nextc = HT loop + P := P + 1; + end loop; + end Skip_Space; + + ----------- + -- Skipc -- + ----------- + + procedure Skipc is + begin + if P /= T'Last then + P := P + 1; + end if; + end Skipc; + + -- Start of processing for Scan_ALI + + begin + First_Sdep_Entry := Sdep.Last + 1; + + -- Acquire lines to be ignored + + if Read_Xref then + Ignore := ('U' | 'W' | 'Y' | 'D' | 'X' => False, others => True); + + -- Read_Lines parameter given + + elsif Read_Lines /= "" then + Ignore := ('U' => False, others => True); + + for J in Read_Lines'Range loop + Ignore (Read_Lines (J)) := False; + end loop; + + -- Process Ignore_Lines parameter + + else + Ignore := (others => False); + + for J in Ignore_Lines'Range loop + pragma Assert (Ignore_Lines (J) /= 'U'); + Ignore (Ignore_Lines (J)) := True; + end loop; + end if; + + -- Setup ALI Table entry with appropriate defaults + + ALIs.Increment_Last; + Id := ALIs.Last; + Set_Name_Table_Info (F, Int (Id)); + + ALIs.Table (Id) := ( + Afile => F, + Compile_Errors => False, + First_Interrupt_State => Interrupt_States.Last + 1, + First_Sdep => No_Sdep_Id, + First_Specific_Dispatching => Specific_Dispatching.Last + 1, + First_Unit => No_Unit_Id, + Float_Format => 'I', + Last_Interrupt_State => Interrupt_States.Last, + Last_Sdep => No_Sdep_Id, + Last_Specific_Dispatching => Specific_Dispatching.Last, + Last_Unit => No_Unit_Id, + Locking_Policy => ' ', + Main_Priority => -1, + Main_CPU => -1, + Main_Program => None, + No_Object => False, + Normalize_Scalars => False, + Ofile_Full_Name => Full_Object_File_Name, + Queuing_Policy => ' ', + Restrictions => No_Restrictions, + SAL_Interface => False, + Sfile => No_File, + Task_Dispatching_Policy => ' ', + Time_Slice_Value => -1, + Allocator_In_Body => False, + WC_Encoding => 'b', + Unit_Exception_Table => False, + Ver => (others => ' '), + Ver_Len => 0, + Zero_Cost_Exceptions => False); + + -- Now we acquire the input lines from the ALI file. Note that the + -- convention in the following code is that as we enter each section, + -- C is set to contain the first character of the following line. + + C := Getc; + Check_Unknown_Line; + + -- Acquire library version + + if C /= 'V' then + + -- The V line missing really indicates trouble, most likely it + -- means we don't have an ALI file at all, so here we give a + -- fatal error even if we are in Ignore_Errors mode. + + Fatal_Error; + + elsif Ignore ('V') then + Skip_Line; + + else + Checkc (' '); + Skip_Space; + Checkc ('"'); + + for J in 1 .. Ver_Len_Max loop + C := Getc; + exit when C = '"'; + ALIs.Table (Id).Ver (J) := C; + ALIs.Table (Id).Ver_Len := J; + end loop; + + Skip_Eol; + end if; + + C := Getc; + Check_Unknown_Line; + + -- Acquire main program line if present + + if C = 'M' then + if Ignore ('M') then + Skip_Line; + + else + Checkc (' '); + Skip_Space; + + C := Getc; + + if C = 'F' then + ALIs.Table (Id).Main_Program := Func; + elsif C = 'P' then + ALIs.Table (Id).Main_Program := Proc; + else + P := P - 1; + Fatal_Error; + end if; + + Skip_Space; + + if not At_Eol then + if Nextc < 'A' then + ALIs.Table (Id).Main_Priority := Get_Nat; + end if; + + Skip_Space; + + if Nextc = 'T' then + P := P + 1; + Checkc ('='); + ALIs.Table (Id).Time_Slice_Value := Get_Nat; + end if; + + Skip_Space; + + if Nextc = 'A' then + P := P + 1; + Checkc ('B'); + ALIs.Table (Id).Allocator_In_Body := True; + end if; + + Skip_Space; + + if Nextc = 'C' then + P := P + 1; + Checkc ('='); + ALIs.Table (Id).Main_CPU := Get_Nat; + end if; + + Skip_Space; + + Checkc ('W'); + Checkc ('='); + ALIs.Table (Id).WC_Encoding := Getc; + end if; + + Skip_Eol; + end if; + + C := Getc; + end if; + + -- Acquire argument lines + + First_Arg := Args.Last + 1; + + A_Loop : loop + Check_Unknown_Line; + exit A_Loop when C /= 'A'; + + if Ignore ('A') then + Skip_Line; + + else + Checkc (' '); + + -- Scan out argument + + Name_Len := 0; + while not At_Eol loop + Add_Char_To_Name_Buffer (Getc); + end loop; + + -- If -fstack-check, record that it occurred + + if Name_Buffer (1 .. Name_Len) = "-fstack-check" then + Stack_Check_Switch_Set := True; + end if; + + -- Store the argument + + Args.Increment_Last; + Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len)); + + Skip_Eol; + end if; + + C := Getc; + end loop A_Loop; + + -- Acquire P line + + Check_Unknown_Line; + + while C /= 'P' loop + if Ignore_Errors then + if C = EOF then + Fatal_Error; + else + Skip_Line; + C := Nextc; + end if; + else + Fatal_Error; + end if; + end loop; + + if Ignore ('P') then + Skip_Line; + + -- Process P line + + else + NS_Found := False; + + while not At_Eol loop + Checkc (' '); + Skip_Space; + C := Getc; + + -- Processing for CE + + if C = 'C' then + Checkc ('E'); + ALIs.Table (Id).Compile_Errors := True; + + -- Processing for DB + + elsif C = 'D' then + Checkc ('B'); + Detect_Blocking := True; + + -- Processing for FD/FG/FI + + elsif C = 'F' then + Float_Format_Specified := Getc; + ALIs.Table (Id).Float_Format := Float_Format_Specified; + + -- Processing for Lx + + elsif C = 'L' then + Locking_Policy_Specified := Getc; + ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified; + + -- Processing for flags starting with N + + elsif C = 'N' then + C := Getc; + + -- Processing for NO + + if C = 'O' then + ALIs.Table (Id).No_Object := True; + No_Object_Specified := True; + + -- Processing for NR + + elsif C = 'R' then + No_Run_Time_Mode := True; + Configurable_Run_Time_Mode := True; + + -- Processing for NS + + elsif C = 'S' then + ALIs.Table (Id).Normalize_Scalars := True; + Normalize_Scalars_Specified := True; + NS_Found := True; + + -- Invalid switch starting with N + + else + Fatal_Error_Ignore; + end if; + + -- Processing for Qx + + elsif C = 'Q' then + Queuing_Policy_Specified := Getc; + ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified; + + -- Processing for flags starting with S + + elsif C = 'S' then + C := Getc; + + -- Processing for SL + + if C = 'L' then + ALIs.Table (Id).SAL_Interface := True; + + -- Processing for SS + + elsif C = 'S' then + Opt.Sec_Stack_Used := True; + + -- Invalid switch starting with S + + else + Fatal_Error_Ignore; + end if; + + -- Processing for Tx + + elsif C = 'T' then + Task_Dispatching_Policy_Specified := Getc; + ALIs.Table (Id).Task_Dispatching_Policy := + Task_Dispatching_Policy_Specified; + + -- Processing for switch starting with U + + elsif C = 'U' then + C := Getc; + + -- Processing for UA + + if C = 'A' then + Unreserve_All_Interrupts_Specified := True; + + -- Processing for UX + + elsif C = 'X' then + ALIs.Table (Id).Unit_Exception_Table := True; + + -- Invalid switches starting with U + + else + Fatal_Error_Ignore; + end if; + + -- Processing for ZX + + elsif C = 'Z' then + C := Getc; + + if C = 'X' then + ALIs.Table (Id).Zero_Cost_Exceptions := True; + Zero_Cost_Exceptions_Specified := True; + else + Fatal_Error_Ignore; + end if; + + -- Invalid parameter + + else + C := Getc; + Fatal_Error_Ignore; + end if; + end loop; + + if not NS_Found then + No_Normalize_Scalars_Specified := True; + end if; + + Skip_Eol; + end if; + + C := Getc; + Check_Unknown_Line; + + -- Acquire first restrictions line + + while C /= 'R' loop + if Ignore_Errors then + if C = EOF then + Fatal_Error; + else + Skip_Line; + C := Nextc; + end if; + else + Fatal_Error; + end if; + end loop; + + if Ignore ('R') then + Skip_Line; + + -- Process restrictions line + + else + Scan_Restrictions : declare + Save_R : constant Restrictions_Info := Cumulative_Restrictions; + -- Save cumulative restrictions in case we have a fatal error + + Bad_R_Line : exception; + -- Signal bad restrictions line (raised on unexpected character) + + begin + Checkc (' '); + Skip_Space; + + -- Acquire information for boolean restrictions + + for R in All_Boolean_Restrictions loop + C := Getc; + + case C is + when 'v' => + ALIs.Table (Id).Restrictions.Violated (R) := True; + Cumulative_Restrictions.Violated (R) := True; + + when 'r' => + ALIs.Table (Id).Restrictions.Set (R) := True; + Cumulative_Restrictions.Set (R) := True; + + when 'n' => + null; + + when others => + raise Bad_R_Line; + end case; + end loop; + + -- Acquire information for parameter restrictions + + for RP in All_Parameter_Restrictions loop + + -- Acquire restrictions pragma information + + case Getc is + when 'n' => + null; + + when 'r' => + ALIs.Table (Id).Restrictions.Set (RP) := True; + + declare + N : constant Integer := Integer (Get_Nat); + begin + ALIs.Table (Id).Restrictions.Value (RP) := N; + + if Cumulative_Restrictions.Set (RP) then + Cumulative_Restrictions.Value (RP) := + Integer'Min + (Cumulative_Restrictions.Value (RP), N); + else + Cumulative_Restrictions.Set (RP) := True; + Cumulative_Restrictions.Value (RP) := N; + end if; + end; + + when others => + raise Bad_R_Line; + end case; + + -- Acquire restrictions violations information + + case Getc is + when 'n' => + null; + + when 'v' => + ALIs.Table (Id).Restrictions.Violated (RP) := True; + Cumulative_Restrictions.Violated (RP) := True; + + declare + N : constant Integer := Integer (Get_Nat); + pragma Unsuppress (Overflow_Check); + + begin + ALIs.Table (Id).Restrictions.Count (RP) := N; + + if RP in Checked_Max_Parameter_Restrictions then + Cumulative_Restrictions.Count (RP) := + Integer'Max + (Cumulative_Restrictions.Count (RP), N); + else + Cumulative_Restrictions.Count (RP) := + Cumulative_Restrictions.Count (RP) + N; + end if; + + exception + when Constraint_Error => + + -- A constraint error comes from the addition in + -- the else branch. We reset to the maximum and + -- indicate that the real value is now unknown. + + Cumulative_Restrictions.Value (RP) := Integer'Last; + Cumulative_Restrictions.Unknown (RP) := True; + end; + + if Nextc = '+' then + Skipc; + ALIs.Table (Id).Restrictions.Unknown (RP) := True; + Cumulative_Restrictions.Unknown (RP) := True; + end if; + + when others => + raise Bad_R_Line; + end case; + end loop; + + Skip_Eol; + + -- Here if error during scanning of restrictions line + + exception + when Bad_R_Line => + + -- In Ignore_Errors mode, undo any changes to restrictions + -- from this unit, and continue on. + + if Ignore_Errors then + Cumulative_Restrictions := Save_R; + ALIs.Table (Id).Restrictions := No_Restrictions; + Skip_Eol; + + -- In normal mode, this is a fatal error + + else + Fatal_Error; + end if; + + end Scan_Restrictions; + end if; + + -- Acquire additional restrictions (No_Dependence) lines if present + + C := Getc; + while C = 'R' loop + if Ignore ('R') then + Skip_Line; + else + Skip_Space; + No_Deps.Append ((Id, Get_Name)); + Skip_Eol; + end if; + + C := Getc; + end loop; + + -- Acquire 'I' lines if present + + Check_Unknown_Line; + + while C = 'I' loop + if Ignore ('I') then + Skip_Line; + + else + declare + Int_Num : Nat; + I_State : Character; + Line_No : Nat; + + begin + Int_Num := Get_Nat; + Skip_Space; + I_State := Getc; + Line_No := Get_Nat; + + Interrupt_States.Append ( + (Interrupt_Id => Int_Num, + Interrupt_State => I_State, + IS_Pragma_Line => Line_No)); + + ALIs.Table (Id).Last_Interrupt_State := Interrupt_States.Last; + Skip_Eol; + end; + end if; + + C := Getc; + end loop; + + -- Acquire 'S' lines if present + + Check_Unknown_Line; + + while C = 'S' loop + if Ignore ('S') then + Skip_Line; + + else + declare + Policy : Character; + First_Prio : Nat; + Last_Prio : Nat; + Line_No : Nat; + + begin + Checkc (' '); + Skip_Space; + + Policy := Getc; + Skip_Space; + First_Prio := Get_Nat; + Last_Prio := Get_Nat; + Line_No := Get_Nat; + + Specific_Dispatching.Append ( + (Dispatching_Policy => Policy, + First_Priority => First_Prio, + Last_Priority => Last_Prio, + PSD_Pragma_Line => Line_No)); + + ALIs.Table (Id).Last_Specific_Dispatching := + Specific_Dispatching.Last; + + Skip_Eol; + end; + end if; + + C := Getc; + end loop; + + -- Loop to acquire unit entries + + U_Loop : loop + Check_Unknown_Line; + exit U_Loop when C /= 'U'; + + -- Note: as per spec, we never ignore U lines + + Checkc (' '); + Skip_Space; + Units.Increment_Last; + + if ALIs.Table (Id).First_Unit = No_Unit_Id then + ALIs.Table (Id).First_Unit := Units.Last; + end if; + + declare + UL : Unit_Record renames Units.Table (Units.Last); + + begin + UL.Uname := Get_Unit_Name; + UL.Predefined := Is_Predefined_Unit; + UL.Internal := Is_Internal_Unit; + UL.My_ALI := Id; + UL.Sfile := Get_File_Name (Lower => True); + UL.Pure := False; + UL.Preelab := False; + UL.No_Elab := False; + UL.Shared_Passive := False; + UL.RCI := False; + UL.Remote_Types := False; + UL.Has_RACW := False; + UL.Init_Scalars := False; + UL.Is_Generic := False; + UL.Icasing := Mixed_Case; + UL.Kcasing := All_Lower_Case; + UL.Dynamic_Elab := False; + UL.Elaborate_Body := False; + UL.Set_Elab_Entity := False; + UL.Version := "00000000"; + UL.First_With := Withs.Last + 1; + UL.First_Arg := First_Arg; + UL.Elab_Position := 0; + UL.SAL_Interface := ALIs.Table (Id).SAL_Interface; + UL.Directly_Scanned := Directly_Scanned; + UL.Body_Needed_For_SAL := False; + UL.Elaborate_Body_Desirable := False; + UL.Optimize_Alignment := 'O'; + + if Debug_Flag_U then + Write_Str (" ----> reading unit "); + Write_Int (Int (Units.Last)); + Write_Str (" "); + Write_Unit_Name (UL.Uname); + Write_Str (" from file "); + Write_Name (UL.Sfile); + Write_Eol; + end if; + end; + + -- Check for duplicated unit in different files + + declare + Info : constant Int := Get_Name_Table_Info + (Units.Table (Units.Last).Uname); + begin + if Info /= 0 + and then Units.Table (Units.Last).Sfile /= + Units.Table (Unit_Id (Info)).Sfile + then + -- If Err is set then ignore duplicate unit name. This is the + -- case of a call from gnatmake, where the situation can arise + -- from substitution of source files. In such situations, the + -- processing in gnatmake will always result in any required + -- recompilations in any case, and if we consider this to be + -- an error we get strange cases (for example when a generic + -- instantiation is replaced by a normal package) where we + -- read the old ali file, decide to recompile, and then decide + -- that the old and new ali files are incompatible. + + if Err then + null; + + -- If Err is not set, then this is a fatal error. This is + -- the case of being called from the binder, where we must + -- definitely diagnose this as an error. + + else + Set_Standard_Error; + Write_Str ("error: duplicate unit name: "); + Write_Eol; + + Write_Str ("error: unit """); + Write_Unit_Name (Units.Table (Units.Last).Uname); + Write_Str (""" found in file """); + Write_Name_Decoded (Units.Table (Units.Last).Sfile); + Write_Char ('"'); + Write_Eol; + + Write_Str ("error: unit """); + Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname); + Write_Str (""" found in file """); + Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile); + Write_Char ('"'); + Write_Eol; + + Exit_Program (E_Fatal); + end if; + end if; + end; + + Set_Name_Table_Info + (Units.Table (Units.Last).Uname, Int (Units.Last)); + + -- Scan out possible version and other parameters + + loop + Skip_Space; + exit when At_Eol; + C := Getc; + + -- Version field + + if C in '0' .. '9' or else C in 'a' .. 'f' then + Units.Table (Units.Last).Version (1) := C; + + for J in 2 .. 8 loop + C := Getc; + Units.Table (Units.Last).Version (J) := C; + end loop; + + -- BD/BN parameters + + elsif C = 'B' then + C := Getc; + + if C = 'D' then + Check_At_End_Of_Field; + Units.Table (Units.Last).Elaborate_Body_Desirable := True; + + elsif C = 'N' then + Check_At_End_Of_Field; + Units.Table (Units.Last).Body_Needed_For_SAL := True; + + else + Fatal_Error_Ignore; + end if; + + -- DE parameter (Dynamic elaboration checks) + + elsif C = 'D' then + C := Getc; + + if C = 'E' then + Check_At_End_Of_Field; + Units.Table (Units.Last).Dynamic_Elab := True; + Dynamic_Elaboration_Checks_Specified := True; + else + Fatal_Error_Ignore; + end if; + + -- EB/EE parameters + + elsif C = 'E' then + C := Getc; + + if C = 'B' then + Units.Table (Units.Last).Elaborate_Body := True; + elsif C = 'E' then + Units.Table (Units.Last).Set_Elab_Entity := True; + else + Fatal_Error_Ignore; + end if; + + Check_At_End_Of_Field; + + -- GE parameter (generic) + + elsif C = 'G' then + C := Getc; + + if C = 'E' then + Check_At_End_Of_Field; + Units.Table (Units.Last).Is_Generic := True; + else + Fatal_Error_Ignore; + end if; + + -- IL/IS/IU parameters + + elsif C = 'I' then + C := Getc; + + if C = 'L' then + Units.Table (Units.Last).Icasing := All_Lower_Case; + elsif C = 'S' then + Units.Table (Units.Last).Init_Scalars := True; + Initialize_Scalars_Used := True; + elsif C = 'U' then + Units.Table (Units.Last).Icasing := All_Upper_Case; + else + Fatal_Error_Ignore; + end if; + + Check_At_End_Of_Field; + + -- KM/KU parameters + + elsif C = 'K' then + C := Getc; + + if C = 'M' then + Units.Table (Units.Last).Kcasing := Mixed_Case; + elsif C = 'U' then + Units.Table (Units.Last).Kcasing := All_Upper_Case; + else + Fatal_Error_Ignore; + end if; + + Check_At_End_Of_Field; + + -- NE parameter + + elsif C = 'N' then + C := Getc; + + if C = 'E' then + Units.Table (Units.Last).No_Elab := True; + Check_At_End_Of_Field; + else + Fatal_Error_Ignore; + end if; + + -- PR/PU/PK parameters + + elsif C = 'P' then + C := Getc; + + if C = 'R' then + Units.Table (Units.Last).Preelab := True; + elsif C = 'U' then + Units.Table (Units.Last).Pure := True; + elsif C = 'K' then + Units.Table (Units.Last).Unit_Kind := 'p'; + else + Fatal_Error_Ignore; + end if; + + Check_At_End_Of_Field; + + -- OL/OO/OS/OT parameters + + elsif C = 'O' then + C := Getc; + + if C = 'L' or else C = 'O' or else C = 'S' or else C = 'T' then + Units.Table (Units.Last).Optimize_Alignment := C; + else + Fatal_Error_Ignore; + end if; + + Check_At_End_Of_Field; + + -- RC/RT parameters + + elsif C = 'R' then + C := Getc; + + if C = 'C' then + Units.Table (Units.Last).RCI := True; + elsif C = 'T' then + Units.Table (Units.Last).Remote_Types := True; + elsif C = 'A' then + Units.Table (Units.Last).Has_RACW := True; + else + Fatal_Error_Ignore; + end if; + + Check_At_End_Of_Field; + + elsif C = 'S' then + C := Getc; + + if C = 'P' then + Units.Table (Units.Last).Shared_Passive := True; + elsif C = 'U' then + Units.Table (Units.Last).Unit_Kind := 's'; + else + Fatal_Error_Ignore; + end if; + + Check_At_End_Of_Field; + + else + C := Getc; + Fatal_Error_Ignore; + end if; + end loop; + + Skip_Eol; + + -- Check if static elaboration model used + + if not Units.Table (Units.Last).Dynamic_Elab + and then not Units.Table (Units.Last).Internal + then + Static_Elaboration_Model_Used := True; + end if; + + C := Getc; + + -- Scan out With lines for this unit + + With_Loop : loop + Check_Unknown_Line; + exit With_Loop when C /= 'W' and then C /= 'Y'; + + if Ignore ('W') then + Skip_Line; + + else + Checkc (' '); + Skip_Space; + Withs.Increment_Last; + Withs.Table (Withs.Last).Uname := Get_Unit_Name; + Withs.Table (Withs.Last).Elaborate := False; + Withs.Table (Withs.Last).Elaborate_All := False; + Withs.Table (Withs.Last).Elab_Desirable := False; + Withs.Table (Withs.Last).Elab_All_Desirable := False; + Withs.Table (Withs.Last).SAL_Interface := False; + Withs.Table (Withs.Last).Limited_With := (C = 'Y'); + + -- Generic case with no object file available + + if At_Eol then + Withs.Table (Withs.Last).Sfile := No_File; + Withs.Table (Withs.Last).Afile := No_File; + + -- Normal case + + else + Withs.Table (Withs.Last).Sfile := Get_File_Name + (Lower => True); + Withs.Table (Withs.Last).Afile := Get_File_Name + (Lower => True); + + -- Scan out possible E, EA, ED, and AD parameters + + while not At_Eol loop + Skip_Space; + + if Nextc = 'A' then + P := P + 1; + Checkc ('D'); + Check_At_End_Of_Field; + + -- Store AD indication unless ignore required + + if not Ignore_ED then + Withs.Table (Withs.Last).Elab_All_Desirable := + True; + end if; + + elsif Nextc = 'E' then + P := P + 1; + + if At_End_Of_Field then + Withs.Table (Withs.Last).Elaborate := True; + + elsif Nextc = 'A' then + P := P + 1; + Check_At_End_Of_Field; + Withs.Table (Withs.Last).Elaborate_All := True; + + else + Checkc ('D'); + Check_At_End_Of_Field; + + -- Store ED indication unless ignore required + + if not Ignore_ED then + Withs.Table (Withs.Last).Elab_Desirable := + True; + end if; + end if; + + else + Fatal_Error; + end if; + end loop; + end if; + + Skip_Eol; + end if; + + C := Getc; + end loop With_Loop; + + Units.Table (Units.Last).Last_With := Withs.Last; + Units.Table (Units.Last).Last_Arg := Args.Last; + + -- If there are linker options lines present, scan them + + Name_Len := 0; + + Linker_Options_Loop : loop + Check_Unknown_Line; + exit Linker_Options_Loop when C /= 'L'; + + if Ignore ('L') then + Skip_Line; + + else + Checkc (' '); + Skip_Space; + Checkc ('"'); + + loop + C := Getc; + + if C < Character'Val (16#20#) + or else C > Character'Val (16#7E#) + then + Fatal_Error_Ignore; + + elsif C = '{' then + C := Character'Val (0); + + declare + V : Natural; + + begin + V := 0; + for J in 1 .. 2 loop + C := Getc; + + if C in '0' .. '9' then + V := V * 16 + + Character'Pos (C) - + Character'Pos ('0'); + + elsif C in 'A' .. 'F' then + V := V * 16 + + Character'Pos (C) - + Character'Pos ('A') + + 10; + + else + Fatal_Error_Ignore; + end if; + end loop; + + Checkc ('}'); + Add_Char_To_Name_Buffer (Character'Val (V)); + end; + + else + if C = '"' then + exit when Nextc /= '"'; + C := Getc; + end if; + + Add_Char_To_Name_Buffer (C); + end if; + end loop; + + Add_Char_To_Name_Buffer (NUL); + Skip_Eol; + end if; + + C := Getc; + end loop Linker_Options_Loop; + + -- Store the linker options entry if one was found + + if Name_Len /= 0 then + Linker_Options.Increment_Last; + + Linker_Options.Table (Linker_Options.Last).Name := + Name_Enter; + + Linker_Options.Table (Linker_Options.Last).Unit := + Units.Last; + + Linker_Options.Table (Linker_Options.Last).Internal_File := + Is_Internal_File_Name (F); + + Linker_Options.Table (Linker_Options.Last).Original_Pos := + Linker_Options.Last; + end if; + + -- If there are notes present, scan them + + Notes_Loop : loop + Check_Unknown_Line; + exit Notes_Loop when C /= 'N'; + + if Ignore ('N') then + Skip_Line; + + else + Checkc (' '); + + Notes.Increment_Last; + Notes.Table (Notes.Last).Pragma_Type := Getc; + Notes.Table (Notes.Last).Pragma_Line := Get_Nat; + Checkc (':'); + Notes.Table (Notes.Last).Pragma_Col := Get_Nat; + Notes.Table (Notes.Last).Unit := Units.Last; + + if At_Eol then + Notes.Table (Notes.Last).Pragma_Args := No_Name; + + else + Checkc (' '); + + Name_Len := 0; + while not At_Eol loop + Add_Char_To_Name_Buffer (Getc); + end loop; + + Notes.Table (Notes.Last).Pragma_Args := Name_Enter; + end if; + + Skip_Eol; + end if; + + C := Getc; + end loop Notes_Loop; + end loop U_Loop; + + -- End loop through units for one ALI file + + ALIs.Table (Id).Last_Unit := Units.Last; + ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile; + + -- Set types of the units (there can be at most 2 of them) + + if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then + Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body; + Units.Table (ALIs.Table (Id).Last_Unit).Utype := Is_Spec; + + else + -- Deal with body only and spec only cases, note that the reason we + -- do our own checking of the name (rather than using Is_Body_Name) + -- is that Uname drags in far too much compiler junk! + + Get_Name_String (Units.Table (Units.Last).Uname); + + if Name_Buffer (Name_Len) = 'b' then + Units.Table (Units.Last).Utype := Is_Body_Only; + else + Units.Table (Units.Last).Utype := Is_Spec_Only; + end if; + end if; + + -- Scan out external version references and put in hash table + + E_Loop : loop + Check_Unknown_Line; + exit E_Loop when C /= 'E'; + + if Ignore ('E') then + Skip_Line; + + else + Checkc (' '); + Skip_Space; + + Name_Len := 0; + Name_Len := 0; + loop + C := Getc; + + if C < ' ' then + Fatal_Error; + end if; + + exit when At_End_Of_Field; + Add_Char_To_Name_Buffer (C); + end loop; + + Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True); + Skip_Eol; + end if; + + C := Getc; + end loop E_Loop; + + -- Scan out source dependency lines for this ALI file + + ALIs.Table (Id).First_Sdep := Sdep.Last + 1; + + D_Loop : loop + Check_Unknown_Line; + exit D_Loop when C /= 'D'; + + if Ignore ('D') then + Skip_Line; + + else + Checkc (' '); + Skip_Space; + Sdep.Increment_Last; + + -- In the following call, Lower is not set to True, this is either + -- a bug, or it deserves a special comment as to why this is so??? + + Sdep.Table (Sdep.Last).Sfile := Get_File_Name; + + Sdep.Table (Sdep.Last).Stamp := Get_Stamp; + Sdep.Table (Sdep.Last).Dummy_Entry := + (Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp); + + -- Acquire checksum value + + Skip_Space; + + declare + Ctr : Natural; + Chk : Word; + + begin + Ctr := 0; + Chk := 0; + + loop + exit when At_Eol or else Ctr = 8; + + if Nextc in '0' .. '9' then + Chk := Chk * 16 + + Character'Pos (Nextc) - Character'Pos ('0'); + + elsif Nextc in 'a' .. 'f' then + Chk := Chk * 16 + + Character'Pos (Nextc) - Character'Pos ('a') + 10; + + else + exit; + end if; + + Ctr := Ctr + 1; + P := P + 1; + end loop; + + if Ctr = 8 and then At_End_Of_Field then + Sdep.Table (Sdep.Last).Checksum := Chk; + else + Fatal_Error; + end if; + end; + + -- Acquire subunit and reference file name entries + + Sdep.Table (Sdep.Last).Subunit_Name := No_Name; + Sdep.Table (Sdep.Last).Rfile := + Sdep.Table (Sdep.Last).Sfile; + Sdep.Table (Sdep.Last).Start_Line := 1; + + if not At_Eol then + Skip_Space; + + -- Here for subunit name + + if Nextc not in '0' .. '9' then + Name_Len := 0; + while not At_End_Of_Field loop + Add_Char_To_Name_Buffer (Getc); + end loop; + + -- Set the subunit name. Note that we use Name_Find rather + -- than Name_Enter here as the subunit name may already + -- have been put in the name table by the Project Manager. + + Sdep.Table (Sdep.Last).Subunit_Name := Name_Find; + + Skip_Space; + end if; + + -- Here for reference file name entry + + if Nextc in '0' .. '9' then + Sdep.Table (Sdep.Last).Start_Line := Get_Nat; + Checkc (':'); + + Name_Len := 0; + + while not At_End_Of_Field loop + Add_Char_To_Name_Buffer (Getc); + end loop; + + Sdep.Table (Sdep.Last).Rfile := Name_Enter; + end if; + end if; + + Skip_Eol; + end if; + + C := Getc; + end loop D_Loop; + + ALIs.Table (Id).Last_Sdep := Sdep.Last; + + -- We must at this stage be at an Xref line or the end of file + + if C = EOF then + return Id; + end if; + + Check_Unknown_Line; + + if C /= 'X' then + Fatal_Error; + end if; + + -- If we are ignoring Xref sections we are done (we ignore all + -- remaining lines since only xref related lines follow X). + + if Ignore ('X') and then not Debug_Flag_X then + return Id; + end if; + + -- Loop through Xref sections + + X_Loop : loop + Check_Unknown_Line; + exit X_Loop when C /= 'X'; + + -- Make new entry in section table + + Xref_Section.Increment_Last; + + Read_Refs_For_One_File : declare + XS : Xref_Section_Record renames + Xref_Section.Table (Xref_Section.Last); + + Current_File_Num : Sdep_Id; + -- Keeps track of the current file number (changed by nn|) + + begin + XS.File_Num := Sdep_Id (Get_Nat + Nat (First_Sdep_Entry) - 1); + XS.File_Name := Get_File_Name; + XS.First_Entity := Xref_Entity.Last + 1; + + Current_File_Num := XS.File_Num; + + Skip_Space; + + Skip_Eol; + C := Nextc; + + -- Loop through Xref entities + + while C /= 'X' and then C /= EOF loop + Xref_Entity.Increment_Last; + + Read_Refs_For_One_Entity : declare + XE : Xref_Entity_Record renames + Xref_Entity.Table (Xref_Entity.Last); + N : Nat; + + procedure Read_Instantiation_Reference; + -- Acquire instantiation reference. Caller has checked + -- that current character is '[' and on return the cursor + -- is skipped past the corresponding closing ']'. + + ---------------------------------- + -- Read_Instantiation_Reference -- + ---------------------------------- + + procedure Read_Instantiation_Reference is + Local_File_Num : Sdep_Id := Current_File_Num; + + begin + Xref.Increment_Last; + + declare + XR : Xref_Record renames Xref.Table (Xref.Last); + + begin + P := P + 1; -- skip [ + N := Get_Nat; + + if Nextc = '|' then + XR.File_Num := + Sdep_Id (N + Nat (First_Sdep_Entry) - 1); + Local_File_Num := XR.File_Num; + P := P + 1; + N := Get_Nat; + + else + XR.File_Num := Local_File_Num; + end if; + + XR.Line := N; + XR.Rtype := ' '; + XR.Col := 0; + + -- Recursive call for next reference + + if Nextc = '[' then + pragma Warnings (Off); -- kill recursion warning + Read_Instantiation_Reference; + pragma Warnings (On); + end if; + + -- Skip closing bracket after recursive call + + P := P + 1; + end; + end Read_Instantiation_Reference; + + -- Start of processing for Read_Refs_For_One_Entity + + begin + XE.Line := Get_Nat; + XE.Etype := Getc; + XE.Col := Get_Nat; + + case Getc is + when '*' => + XE.Visibility := Global; + when '+' => + XE.Visibility := Static; + when others => + XE.Visibility := Other; + end case; + + XE.Entity := Get_Name; + + -- Handle the information about generic instantiations + + if Nextc = '[' then + Skipc; -- Opening '[' + N := Get_Nat; + + if Nextc /= '|' then + XE.Iref_File_Num := Current_File_Num; + XE.Iref_Line := N; + else + XE.Iref_File_Num := + Sdep_Id (N + Nat (First_Sdep_Entry) - 1); + Skipc; + XE.Iref_Line := Get_Nat; + end if; + + if Getc /= ']' then + Fatal_Error; + end if; + + else + XE.Iref_File_Num := No_Sdep_Id; + XE.Iref_Line := 0; + end if; + + Current_File_Num := XS.File_Num; + + -- Renaming reference is present + + if Nextc = '=' then + P := P + 1; + XE.Rref_Line := Get_Nat; + + if Getc /= ':' then + Fatal_Error; + end if; + + XE.Rref_Col := Get_Nat; + + -- No renaming reference present + + else + XE.Rref_Line := 0; + XE.Rref_Col := 0; + end if; + + Skip_Space; + + XE.Oref_File_Num := No_Sdep_Id; + XE.Tref_File_Num := No_Sdep_Id; + XE.Tref := Tref_None; + XE.First_Xref := Xref.Last + 1; + + -- Loop to check for additional info present + + loop + declare + Ref : Tref_Kind; + File : Sdep_Id; + Line : Nat; + Typ : Character; + Col : Nat; + Std : Name_Id; + + begin + Get_Typeref + (Current_File_Num, Ref, File, Line, Typ, Col, Std); + exit when Ref = Tref_None; + + -- Do we have an overriding procedure? + + if Ref = Tref_Derived and then Typ = 'p' then + XE.Oref_File_Num := File; + XE.Oref_Line := Line; + XE.Oref_Col := Col; + + -- Arrays never override anything, and <> points to + -- the index types instead + + elsif Ref = Tref_Derived and then XE.Etype = 'A' then + + -- Index types are stored in the list of references + + Xref.Increment_Last; + + declare + XR : Xref_Record renames Xref.Table (Xref.Last); + begin + XR.File_Num := File; + XR.Line := Line; + XR.Rtype := Array_Index_Reference; + XR.Col := Col; + XR.Name := Std; + end; + + -- Interfaces are stored in the list of references, + -- although the parent type itself is stored in XE. + -- The first interface (when there are only + -- interfaces) is stored in XE.Tref*) + + elsif Ref = Tref_Derived + and then Typ = 'R' + and then XE.Tref_File_Num /= No_Sdep_Id + then + Xref.Increment_Last; + + declare + XR : Xref_Record renames Xref.Table (Xref.Last); + begin + XR.File_Num := File; + XR.Line := Line; + XR.Rtype := Interface_Reference; + XR.Col := Col; + XR.Name := Std; + end; + + else + XE.Tref := Ref; + XE.Tref_File_Num := File; + XE.Tref_Line := Line; + XE.Tref_Type := Typ; + XE.Tref_Col := Col; + XE.Tref_Standard_Entity := Std; + end if; + end; + end loop; + + -- Loop through cross-references for this entity + + loop + Skip_Space; + + if At_Eol then + Skip_Eol; + exit when Nextc /= '.'; + P := P + 1; + end if; + + Xref.Increment_Last; + + declare + XR : Xref_Record renames Xref.Table (Xref.Last); + + begin + N := Get_Nat; + + if Nextc = '|' then + XR.File_Num := + Sdep_Id (N + Nat (First_Sdep_Entry) - 1); + Current_File_Num := XR.File_Num; + P := P + 1; + N := Get_Nat; + else + XR.File_Num := Current_File_Num; + end if; + + XR.Line := N; + XR.Rtype := Getc; + + -- Imported entities reference as in: + -- 494b25 + -- ??? Simply skipped for now + + if Nextc = '<' then + while Getc /= '>' loop + null; + end loop; + end if; + + XR.Col := Get_Nat; + + if Nextc = '[' then + Read_Instantiation_Reference; + end if; + end; + end loop; + + -- Record last cross-reference + + XE.Last_Xref := Xref.Last; + C := Nextc; + + exception + when Bad_ALI_Format => + + -- If ignoring errors, then we skip a line with an + -- unexpected error, and try to continue subsequent + -- xref lines. + + if Ignore_Errors then + Xref_Entity.Decrement_Last; + Skip_Line; + C := Nextc; + + -- Otherwise, we reraise the fatal exception + + else + raise; + end if; + end Read_Refs_For_One_Entity; + end loop; + + -- Record last entity + + XS.Last_Entity := Xref_Entity.Last; + + end Read_Refs_For_One_File; + + C := Getc; + end loop X_Loop; + + -- Here after dealing with xref sections + + if C /= EOF and then C /= 'X' then + Fatal_Error; + end if; + + return Id; + + exception + when Bad_ALI_Format => + return No_ALI_Id; + end Scan_ALI; + + --------- + -- SEq -- + --------- + + function SEq (F1, F2 : String_Ptr) return Boolean is + begin + return F1.all = F2.all; + end SEq; + + ----------- + -- SHash -- + ----------- + + function SHash (S : String_Ptr) return Vindex is + H : Word; + + begin + H := 0; + for J in S.all'Range loop + H := H * 2 + Character'Pos (S (J)); + end loop; + + return Vindex (Vindex'First + Vindex (H mod Vindex'Range_Length)); + end SHash; + +end ALI; diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads new file mode 100644 index 000000000..ab15ca11f --- /dev/null +++ b/gcc/ada/ali.ads @@ -0,0 +1,1054 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A L I -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 internal data structures used for representation +-- of Ada Library Information (ALI) acquired from the ALI files generated +-- by the front end. + +with Casing; use Casing; +with Gnatvsn; use Gnatvsn; +with Namet; use Namet; +with Rident; use Rident; +with Table; +with Types; use Types; + +with GNAT.HTable; use GNAT.HTable; + +package ALI is + + -------------- + -- Id Types -- + -------------- + + -- The various entries are stored in tables with distinct subscript ranges. + -- The following type definitions show the ranges used for the subscripts + -- (Id values) for the various tables. + + type ALI_Id is range 0 .. 999_999; + -- Id values used for ALIs table entries + + type Unit_Id is range 1_000_000 .. 1_999_999; + -- Id values used for Unit table entries + + type With_Id is range 2_000_000 .. 2_999_999; + -- Id values used for Withs table entries + + type Arg_Id is range 3_000_000 .. 3_999_999; + -- Id values used for argument table entries + + type Sdep_Id is range 4_000_000 .. 4_999_999; + -- Id values used for Sdep table entries + + type Source_Id is range 5_000_000 .. 5_999_999; + -- Id values used for Source table entries + + type Interrupt_State_Id is range 6_000_000 .. 6_999_999; + -- Id values used for Interrupt_State table entries + + type Priority_Specific_Dispatching_Id is range 7_000_000 .. 7_999_999; + -- Id values used for Priority_Specific_Dispatching table entries + + -------------------- + -- ALI File Table -- + -------------------- + + -- Each ALI file read generates an entry in the ALIs table + + No_ALI_Id : constant ALI_Id := ALI_Id'First; + -- Special value indicating no ALI entry + + First_ALI_Entry : constant ALI_Id := No_ALI_Id + 1; + -- Id of first actual entry in table + + type Main_Program_Type is (None, Proc, Func); + -- Indicator of whether unit can be used as main program + + type ALIs_Record is record + + Afile : File_Name_Type; + -- Name of ALI file + + Ofile_Full_Name : File_Name_Type; + -- Full name of object file corresponding to the ALI file + + Sfile : File_Name_Type; + -- Name of source file that generates this ALI file (which is equal + -- to the name of the source file in the first unit table entry for + -- this ALI file, since the body if present is always first). + + Ver : String (1 .. Ver_Len_Max); + -- Value of library version (V line in ALI file). Not set if + -- V lines are ignored as a result of the Ignore_Lines parameter. + + Ver_Len : Natural; + -- Length of characters stored in Ver. Not set if V lines are ignored as + -- a result of the Ignore_Lines parameter. + + SAL_Interface : Boolean; + -- Set True when this is an interface to a standalone library + + First_Unit : Unit_Id; + -- Id of first Unit table entry for this file + + Last_Unit : Unit_Id; + -- Id of last Unit table entry for this file + + First_Sdep : Sdep_Id; + -- Id of first Sdep table entry for this file + + Last_Sdep : Sdep_Id; + -- Id of last Sdep table entry for this file + + Main_Program : Main_Program_Type; + -- Indicator of whether first unit can be used as main program. Not set + -- if 'M' appears in Ignore_Lines. + + Main_Priority : Int; + -- Indicates priority value if Main_Program field indicates that this + -- can be a main program. A value of -1 (No_Main_Priority) indicates + -- that no parameter was found, or no M line was present. Not set if + -- 'M' appears in Ignore_Lines. + + Main_CPU : Int; + -- Indicates processor if Main_Program field indicates that this can + -- be a main program. A value of -1 (No_Main_CPU) indicates that no C + -- parameter was found, or no M line was present. Not set if 'M' appears + -- in Ignore_Lines. + + Time_Slice_Value : Int; + -- Indicates value of time slice parameter from T=xxx on main program + -- line. A value of -1 indicates that no T=xxx parameter was found, or + -- no M line was present. Not set if 'M' appears in Ignore_Lines. + + Allocator_In_Body : Boolean; + -- Set True if an AB switch appears on the main program line. False + -- if no M line, or AB not present, or 'M appears in Ignore_Lines. + + WC_Encoding : Character; + -- Wide character encoding if main procedure. Otherwise not relevant. + -- Not set if 'M' appears in Ignore_Lines. + + Locking_Policy : Character; + -- Indicates locking policy for units in this file. Space means tasking + -- was not used, or that no Locking_Policy pragma was present or that + -- this is a language defined unit. Otherwise set to first character + -- (upper case) of policy name. Not set if 'P' appears in Ignore_Lines. + + Queuing_Policy : Character; + -- Indicates queuing policy for units in this file. Space means tasking + -- was not used, or that no Queuing_Policy pragma was present or that + -- this is a language defined unit. Otherwise set to first character + -- (upper case) of policy name. Not set if 'P' appears in Ignore_Lines. + + Task_Dispatching_Policy : Character; + -- Indicates task dispatching policy for units in this file. Space means + -- tasking was not used, or that no Task_Dispatching_Policy pragma was + -- present or that this is a language defined unit. Otherwise set to + -- first character (upper case) of policy name. Not set if 'P' appears + -- in Ignore_Lines. + + Compile_Errors : Boolean; + -- Set to True if compile errors for unit. Note that No_Object will + -- always be set as well in this case. Not set if 'P' appears in + -- Ignore_Lines. + + Float_Format : Character; + -- Set to float format (set to I if no float-format given). Not set if + -- 'P' appears in Ignore_Lines. + + No_Object : Boolean; + -- Set to True if no object file generated. Not set if 'P' appears in + -- Ignore_Lines. + + Normalize_Scalars : Boolean; + -- Set to True if file was compiled with Normalize_Scalars. Not set if + -- 'P' appears in Ignore_Lines. + + Unit_Exception_Table : Boolean; + -- Set to True if unit exception table pointer generated. Not set if 'P' + -- appears in Ignore_Lines. + + Zero_Cost_Exceptions : Boolean; + -- Set to True if file was compiled with zero cost exceptions. Not set + -- if 'P' appears in Ignore_Lines. + + Restrictions : Restrictions_Info; + -- Restrictions information reconstructed from R lines + + First_Interrupt_State : Interrupt_State_Id; + Last_Interrupt_State : Interrupt_State_Id'Base; + -- These point to the first and last entries in the interrupt state + -- table for this unit. If no entries, then Last_Interrupt_State = + -- First_Interrupt_State - 1 (that's why the 'Base reference is there, + -- it can be one less than the lower bound of the subtype). Not set if + -- 'I' appears in Ignore_Lines + + First_Specific_Dispatching : Priority_Specific_Dispatching_Id; + Last_Specific_Dispatching : Priority_Specific_Dispatching_Id'Base; + -- These point to the first and last entries in the priority specific + -- dispatching table for this unit. If there are no entries, then + -- Last_Specific_Dispatching = First_Specific_Dispatching - 1. That + -- is why the 'Base reference is there, it can be one less than the + -- lower bound of the subtype. Not set if 'S' appears in Ignore_Lines. + + end record; + + No_Main_Priority : constant Int := -1; + -- Code for no main priority set + + No_Main_CPU : constant Int := -1; + -- Code for no main cpu set + + package ALIs is new Table.Table ( + Table_Component_Type => ALIs_Record, + Table_Index_Type => ALI_Id, + Table_Low_Bound => First_ALI_Entry, + Table_Initial => 500, + Table_Increment => 200, + Table_Name => "ALIs"); + + ---------------- + -- Unit Table -- + ---------------- + + -- Each unit within an ALI file generates an entry in the unit table + + No_Unit_Id : constant Unit_Id := Unit_Id'First; + -- Special value indicating no unit table entry + + First_Unit_Entry : constant Unit_Id := No_Unit_Id + 1; + -- Id of first actual entry in table + + type Unit_Type is (Is_Spec, Is_Body, Is_Spec_Only, Is_Body_Only); + -- Indicates type of entry, if both body and spec appear in the ALI file, + -- then the first unit is marked Is_Body, and the second is marked Is_Spec. + -- If only a spec appears, then it is marked as Is_Spec_Only, and if only + -- a body appears, then it is marked Is_Body_Only). + + subtype Version_String is String (1 .. 8); + -- Version string, taken from unit record + + type Unit_Record is record + + My_ALI : ALI_Id; + -- Corresponding ALI entry + + Uname : Unit_Name_Type; + -- Name of Unit + + Sfile : File_Name_Type; + -- Name of source file + + Preelab : Boolean; + -- Indicates presence of PR parameter for a preelaborated package + + No_Elab : Boolean; + -- Indicates presence of NE parameter for a unit that has does not + -- have an elaboration routine (since it has no elaboration code). + + Pure : Boolean; + -- Indicates presence of PU parameter for a package having pragma Pure + + Dynamic_Elab : Boolean; + -- Set to True if the unit was compiled with dynamic elaboration checks + -- (i.e. either -gnatE or pragma Elaboration_Checks (RM) was used to + -- compile the unit). + + Elaborate_Body : Boolean; + -- Indicates presence of EB parameter for a package which has a pragma + -- Elaborate_Body, and also for generic package instantiations. + + Set_Elab_Entity : Boolean; + -- Indicates presence of EE parameter for a unit which has an + -- elaboration entity which must be set true as part of the + -- elaboration of the entity. + + Has_RACW : Boolean; + -- Indicates presence of RA parameter for a package that declares at + -- least one Remote Access to Class_Wide (RACW) object. + + Remote_Types : Boolean; + -- Indicates presence of RT parameter for a package which has a + -- pragma Remote_Types. + + Shared_Passive : Boolean; + -- Indicates presence of SP parameter for a package which has a pragma + -- Shared_Passive. + + RCI : Boolean; + -- Indicates presence of RC parameter for a package which has a pragma + -- Remote_Call_Interface. + + Predefined : Boolean; + -- Indicates if unit is language predefined (or a child of such a unit) + + Internal : Boolean; + -- Indicates if unit is an internal unit (or a child of such a unit) + + First_With : With_Id; + -- Id of first withs table entry for this file + + Last_With : With_Id; + -- Id of last withs table entry for this file + + First_Arg : Arg_Id; + -- Id of first args table entry for this file + + Last_Arg : Arg_Id; + -- Id of last args table entry for this file + + Utype : Unit_Type; + -- Type of entry + + Is_Generic : Boolean; + -- True for generic unit (i.e. a generic declaration, or a generic + -- body). False for a non-generic unit. + + Unit_Kind : Character; + -- Indicates the nature of the unit. 'p' for Packages and 's' for + -- subprograms. + + Version : Version_String; + -- Version of unit + + Icasing : Casing_Type; + -- Indicates casing of identifiers in source file for this unit. This + -- is used for informational output, and also for constructing the main + -- unit if it is being built in Ada. + + Kcasing : Casing_Type; + -- Indicates casing of keywords in source file for this unit. This is + -- used for informational output, and also for constructing the main + -- unit if it is being built in Ada. + + Elab_Position : aliased Natural; + -- Initialized to zero. Set non-zero when a unit is chosen and + -- placed in the elaboration order. The value represents the + -- ordinal position in the elaboration order. + + Init_Scalars : Boolean; + -- Set True if IS qualifier appears in ALI file, indicating that + -- an Initialize_Scalars pragma applies to the unit. + + SAL_Interface : Boolean; + -- Set True when this is an interface to a standalone library + + Directly_Scanned : Boolean; + -- True iff it is a unit from an ALI file specified to gnatbind + + Body_Needed_For_SAL : Boolean; + -- Indicates that the source for the body of the unit (subprogram, + -- package, or generic unit) must be included in a standalone library. + + Elaborate_Body_Desirable : Boolean; + -- Indicates that the front end elaboration circuitry decided that it + -- would be a good idea if this package had Elaborate_Body. The binder + -- will attempt, but does not promise, to place the elaboration call + -- for the body right after the call for the spec, or at least as close + -- together as possible. + + Optimize_Alignment : Character; + -- Optimize_Alignment setting. Set to L/S/T/O for OL/OS/OT/OO present + + end record; + + package Units is new Table.Table ( + Table_Component_Type => Unit_Record, + Table_Index_Type => Unit_Id, + Table_Low_Bound => First_Unit_Entry, + Table_Initial => 100, + Table_Increment => 200, + Table_Name => "Unit"); + + --------------------------- + -- Interrupt State Table -- + --------------------------- + + -- An entry is made in this table for each I (interrupt state) line + -- encountered in the input ALI file. The First/Last_Interrupt_Id + -- fields of the ALI file entry show the range of entries defined + -- within a particular ALI file. + + type Interrupt_State_Record is record + Interrupt_Id : Nat; + -- Id from interrupt state entry + + Interrupt_State : Character; + -- State from interrupt state entry ('u'/'r'/'s') + + IS_Pragma_Line : Nat; + -- Line number of Interrupt_State pragma + end record; + + package Interrupt_States is new Table.Table ( + Table_Component_Type => Interrupt_State_Record, + Table_Index_Type => Interrupt_State_Id'Base, + Table_Low_Bound => Interrupt_State_Id'First, + Table_Initial => 100, + Table_Increment => 200, + Table_Name => "Interrupt_States"); + + ----------------------------------------- + -- Priority Specific Dispatching Table -- + ----------------------------------------- + + -- An entry is made in this table for each S (priority specific + -- dispatching) line encountered in the input ALI file. The + -- First/Last_Specific_Dispatching_Id fields of the ALI file + -- entry show the range of entries defined within a particular + -- ALI file. + + type Specific_Dispatching_Record is record + Dispatching_Policy : Character; + -- First character (upper case) of the corresponding policy name + + First_Priority : Nat; + -- Lower bound of the priority range to which the specified dispatching + -- policy applies. + + Last_Priority : Nat; + -- Upper bound of the priority range to which the specified dispatching + -- policy applies. + + PSD_Pragma_Line : Nat; + -- Line number of Priority_Specific_Dispatching pragma + end record; + + package Specific_Dispatching is new Table.Table ( + Table_Component_Type => Specific_Dispatching_Record, + Table_Index_Type => Priority_Specific_Dispatching_Id'Base, + Table_Low_Bound => Priority_Specific_Dispatching_Id'First, + Table_Initial => 100, + Table_Increment => 200, + Table_Name => "Priority_Specific_Dispatching"); + + -------------- + -- Switches -- + -------------- + + -- These switches record status information about ali files that + -- have been read, for quick reference without searching tables. + + -- Note: a switch will be left set at its default value if the line + -- which might otherwise set it is ignored (from Ignore_Lines). + + Dynamic_Elaboration_Checks_Specified : Boolean := False; + -- Set to False by Initialize_ALI. Set to True if Scan_ALI reads + -- a unit for which dynamic elaboration checking is enabled. + + Float_Format_Specified : Character := ' '; + -- Set to blank by Initialize_ALI. Set to appropriate float format + -- character (V or I, see Opt.Float_Format) if an ali file that + -- is read contains an F line setting the floating point format. + + Initialize_Scalars_Used : Boolean := False; + -- Set True if an ali file contains the Initialize_Scalars flag + + Locking_Policy_Specified : Character := ' '; + -- Set to blank by Initialize_ALI. Set to the appropriate locking policy + -- character if an ali file contains a P line setting the locking policy. + + No_Normalize_Scalars_Specified : Boolean := False; + -- Set to False by Initialize_ALI. Set to True if an ali file indicates + -- that the file was compiled without normalize scalars. + + No_Object_Specified : Boolean := False; + -- Set to False by Initialize_ALI. Set to True if an ali file contains + -- the No_Object flag. + + Normalize_Scalars_Specified : Boolean := False; + -- Set to False by Initialize_ALI. Set to True if an ali file indicates + -- that the file was compiled in Normalize_Scalars mode. + + Queuing_Policy_Specified : Character := ' '; + -- Set to blank by Initialize_ALI. Set to the appropriate queuing policy + -- character if an ali file contains a P line setting the queuing policy. + + Cumulative_Restrictions : Restrictions_Info := No_Restrictions; + -- This variable records the cumulative contributions of R lines in all + -- ali files, showing whether a restriction pragma exists anywhere, and + -- accumulating the aggregate knowledge of violations. + + Stack_Check_Switch_Set : Boolean := False; + -- Set to True if at least one ALI file contains '-fstack-check' in its + -- argument list. + + Static_Elaboration_Model_Used : Boolean := False; + -- Set to False by Initialize_ALI. Set to True if any ALI file for a + -- non-internal unit compiled with the static elaboration model is + -- encountered. + + Task_Dispatching_Policy_Specified : Character := ' '; + -- Set to blank by Initialize_ALI. Set to the appropriate task dispatching + -- policy character if an ali file contains a P line setting the + -- task dispatching policy. + + Unreserve_All_Interrupts_Specified : Boolean := False; + -- Set to False by Initialize_ALI. Set to True if an ali file is read that + -- has P line specifying unreserve all interrupts mode. + + Zero_Cost_Exceptions_Specified : Boolean := False; + -- Set to False by Initialize_ALI. Set to True if an ali file is read that + -- has a P line specifying the generation of zero cost exceptions. + + ----------------- + -- Withs Table -- + ----------------- + + -- Each With line (W line) in an ALI file generates a Withs table entry + + -- Note: there will be no entries in this table if 'W' lines are ignored + + No_With_Id : constant With_Id := With_Id'First; + -- Special value indicating no withs table entry + + First_With_Entry : constant With_Id := No_With_Id + 1; + -- Id of first actual entry in table + + type With_Record is record + + Uname : Unit_Name_Type; + -- Name of Unit + + Sfile : File_Name_Type; + -- Name of source file, set to No_File in generic case + + Afile : File_Name_Type; + -- Name of ALI file, set to No_File in generic case + + Elaborate : Boolean; + -- Indicates presence of E parameter + + Elaborate_All : Boolean; + -- Indicates presence of EA parameter + + Elab_All_Desirable : Boolean; + -- Indicates presence of AD parameter + + Elab_Desirable : Boolean; + -- Indicates presence of ED parameter + + SAL_Interface : Boolean := False; + -- True if the Unit is an Interface of a Stand-Alone Library + + Limited_With : Boolean := False; + -- True if unit is named in a limited_with_clause + end record; + + package Withs is new Table.Table ( + Table_Component_Type => With_Record, + Table_Index_Type => With_Id, + Table_Low_Bound => First_With_Entry, + Table_Initial => 5000, + Table_Increment => 200, + Table_Name => "Withs"); + + --------------------- + -- Arguments Table -- + --------------------- + + -- Each Arg line (A line) in an ALI file generates an Args table entry + + -- Note: there will be no entries in this table if 'A' lines are ignored + + No_Arg_Id : constant Arg_Id := Arg_Id'First; + -- Special value indicating no args table entry + + First_Arg_Entry : constant Arg_Id := No_Arg_Id + 1; + -- Id of first actual entry in table + + package Args is new Table.Table ( + Table_Component_Type => String_Ptr, + Table_Index_Type => Arg_Id, + Table_Low_Bound => First_Arg_Entry, + Table_Initial => 1000, + Table_Increment => 100, + Table_Name => "Args"); + + -------------------------- + -- Linker_Options Table -- + -------------------------- + + -- If an ALI file has one of more Linker_Options lines, then a single + -- entry is made in this table. If more than one Linker_Options lines + -- appears in a given ALI file, then the arguments are concatenated + -- to form the entry in this table, using a NUL character as the + -- separator, and a final NUL character is appended to the end. + + -- Note: there will be no entries in this table if 'L' lines are ignored + + type Linker_Option_Record is record + Name : Name_Id; + -- Name entry containing concatenated list of Linker_Options + -- arguments separated by NUL and ended by NUL as described above. + + Unit : Unit_Id; + -- Unit_Id for the entry + + Internal_File : Boolean; + -- Set True if the linker options are from an internal file. This is + -- used to insert certain standard entries after all the user entries + -- but before the entries from the run-time. + + Original_Pos : Positive; + -- Keep track of original position in the linker options table. This + -- is used to implement a stable sort when we sort the linker options + -- table. + end record; + + -- The indexes of active entries in this table range from 1 to the + -- value of Linker_Options.Last. The zero'th element is for sort call. + + package Linker_Options is new Table.Table ( + Table_Component_Type => Linker_Option_Record, + Table_Index_Type => Integer, + Table_Low_Bound => 0, + Table_Initial => 200, + Table_Increment => 400, + Table_Name => "Linker_Options"); + + ----------------- + -- Notes Table -- + ----------------- + + -- The notes table records entries from N lines + + type Notes_Record is record + Pragma_Type : Character; + -- 'A', 'C', 'I', 'S', 'T' for Annotate/Comment/Ident/Subtitle/Title + + Pragma_Line : Nat; + -- Line number of pragma + + Pragma_Col : Nat; + -- Column number of pragma + + Unit : Unit_Id; + -- Unit_Id for the entry + + Pragma_Args : Name_Id; + -- Pragma arguments. No_Name if no arguments, otherwise a single + -- name table entry consisting of all the characters on the notes + -- line from the first non-blank character following the source + -- location to the last character on the line. + end record; + + -- The indexes of active entries in this table range from 1 to the + -- value of Linker_Options.Last. The zero'th element is for convenience + -- if the table needs to be sorted. + + package Notes is new Table.Table ( + Table_Component_Type => Notes_Record, + Table_Index_Type => Integer, + Table_Low_Bound => 0, + Table_Initial => 200, + Table_Increment => 400, + Table_Name => "Notes"); + + ------------------------------------------- + -- External Version Reference Hash Table -- + ------------------------------------------- + + -- This hash table keeps track of external version reference strings + -- as read from E lines in the ali file. The stored values do not + -- include the terminating quote characters. + + -- Note: there will be no entries in this table if 'E' lines are ignored + + type Vindex is range 0 .. 98; + -- Type to define range of headers + + function SHash (S : String_Ptr) return Vindex; + -- Hash function for this table + + function SEq (F1, F2 : String_Ptr) return Boolean; + -- Equality function for this table + + package Version_Ref is new Simple_HTable ( + Header_Num => Vindex, + Element => Boolean, + No_Element => False, + Key => String_Ptr, + Hash => SHash, + Equal => SEq); + + ------------------------- + -- No_Dependency Table -- + ------------------------- + + -- Each R line for a No_Dependency Restriction generates an entry in + -- this No_Dependency table. + + type No_Dep_Record is record + ALI_File : ALI_Id; + -- ALI File containing the entry + + No_Dep_Unit : Name_Id; + -- Id for names table entry including entire name, including periods + end record; + + package No_Deps is new Table.Table ( + Table_Component_Type => No_Dep_Record, + Table_Index_Type => Integer, + Table_Low_Bound => 0, + Table_Initial => 200, + Table_Increment => 400, + Table_Name => "No_Deps"); + + ------------------------------------ + -- Sdep (Source Dependency) Table -- + ------------------------------------ + + -- Each source dependency (D line) in an ALI file generates an entry in the + -- Sdep table. + + -- Note: there will be no entries in this table if 'D' lines are ignored + + No_Sdep_Id : constant Sdep_Id := Sdep_Id'First; + -- Special value indicating no Sdep table entry + + First_Sdep_Entry : Sdep_Id := No_Sdep_Id + 1; + -- Id of first Sdep entry for current ali file. This is initialized to the + -- first Sdep entry in the table, and then incremented appropriately as + -- successive ALI files are scanned. + + type Sdep_Record is record + + Sfile : File_Name_Type; + -- Name of source file + + Stamp : Time_Stamp_Type; + -- Time stamp value. Note that this will be all zero characters for the + -- dummy entries for missing or non-dependent files. + + Checksum : Word; + -- Checksum value. Note that this will be all zero characters for the + -- dummy entries for missing or non-dependent files + + Dummy_Entry : Boolean; + -- Set True for dummy entries that correspond to missing files or files + -- where no dependency relationship exists. + + Subunit_Name : Name_Id; + -- Name_Id for subunit name if present, else No_Name + + Rfile : File_Name_Type; + -- Reference file name. Same as Sfile unless a Source_Reference pragma + -- was used, in which case it reflects the name used in the pragma. + + Start_Line : Nat; + -- Starting line number in file. Always 1, unless a Source_Reference + -- pragma was used, in which case it reflects the line number value + -- given in the pragma. + + end record; + + package Sdep is new Table.Table ( + Table_Component_Type => Sdep_Record, + Table_Index_Type => Sdep_Id, + Table_Low_Bound => First_Sdep_Entry, + Table_Initial => 5000, + Table_Increment => 200, + Table_Name => "Sdep"); + + ---------------------------- + -- Use of Name Table Info -- + ---------------------------- + + -- All unit names and file names are entered into the Names table. The Info + -- fields of these entries are used as follows: + + -- Unit name Info field has Unit_Id of unit table entry + -- ALI file name Info field has ALI_Id of ALI table entry + -- Source file name Info field has Source_Id of source table entry + + -------------------------- + -- Cross-Reference Data -- + -------------------------- + + -- The following table records cross-reference sections, there is one entry + -- for each X header line in the ALI file for an xref section. + + -- Note: there will be no entries in this table if 'X' lines are ignored + + type Xref_Section_Record is record + File_Num : Sdep_Id; + -- Dependency number for file (entry in Sdep.Table) + + File_Name : File_Name_Type; + -- Name of file + + First_Entity : Nat; + -- First entry in Xref_Entity table + + Last_Entity : Nat; + -- Last entry in Xref_Entity table + end record; + + package Xref_Section is new Table.Table ( + Table_Component_Type => Xref_Section_Record, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 300, + Table_Name => "Xref_Section"); + + -- The following is used to indicate whether a typeref field is present + -- for the entity, and if so what kind of typeref field. + + type Tref_Kind is ( + Tref_None, -- No typeref present + Tref_Access, -- Access type typeref (points to designated type) + Tref_Derived, -- Derived type typeref (points to parent type) + Tref_Type); -- All other cases + + type Visibility_Kind is + (Global, -- Library level entity + Static, -- Static C/C++ entity + Other); -- Local and other entity + + -- The following table records entities for which xrefs are recorded + + type Xref_Entity_Record is record + Line : Pos; + -- Line number of definition + + Etype : Character; + -- Set to the identification character for the entity. See section + -- "Cross-Reference Entity Identifiers" in lib-xref.ads for details. + + Col : Pos; + -- Column number of definition + + Visibility : Visibility_Kind; + -- Visibility of entity + + Entity : Name_Id; + -- Name of entity + + Iref_File_Num : Sdep_Id; + -- This field is set to the dependency reference for the file containing + -- the generic entity that this one instantiates, or to No_Sdep_Id if + -- the current entity is not an instantiation + + Iref_Line : Nat; + -- This field is set to the line number in Iref_File_Num of the generic + -- entity that this one instantiates, or to zero if the current entity + -- is not an instantiation. + + Rref_Line : Nat; + -- This field is set to the line number of a renaming reference if + -- one is present, or to zero if no renaming reference is present + + Rref_Col : Nat; + -- This field is set to the column number of a renaming reference + -- if one is present, or to zero if no renaming reference is present. + + Tref : Tref_Kind; + -- Indicates if a typeref is present, and if so what kind. Set to + -- Tref_None if no typeref field is present. + + Tref_File_Num : Sdep_Id; + -- This field is set to No_Sdep_Id if no typeref is present, or + -- if the typeref refers to an entity in standard. Otherwise it + -- it is the dependency reference for the file containing the + -- declaration of the typeref entity. + + Tref_Line : Nat; + -- This field is set to zero if no typeref is present, or if the + -- typeref refers to an entity in standard. Otherwise it contains + -- the line number of the declaration of the typeref entity. + + Tref_Type : Character; + -- This field is set to blank if no typeref is present, or if the + -- typeref refers to an entity in standard. Otherwise it contains + -- the identification character for the typeref entity. See section + -- "Cross-Reference Entity Identifiers" in lib-xref.ads for details. + + Tref_Col : Nat; + -- This field is set to zero if no typeref is present, or if the + -- typeref refers to an entity in standard. Otherwise it contains + -- the column number of the declaration of the parent type. + + Tref_Standard_Entity : Name_Id; + -- This field is set to No_Name if no typeref is present or if the + -- typeref refers to a declared entity rather than an entity in + -- package Standard. If there is a typeref that references an + -- entity in package Standard, then this field is a Name_Id + -- reference for the entity name. + + Oref_File_Num : Sdep_Id; + -- This field is set to No_Sdep_Id if the entity doesn't override any + -- other entity, or to the dependency reference for the overridden + -- entity. + + Oref_Line : Nat; + Oref_Col : Nat; + -- These two fields are set to the line and column of the overridden + -- entity. + + First_Xref : Nat; + -- Index into Xref table of first cross-reference + + Last_Xref : Nat; + -- Index into Xref table of last cross-reference. The value in + -- Last_Xref can be less than the First_Xref value to indicate + -- that no entries are present in the Xref Table. + end record; + + package Xref_Entity is new Table.Table ( + Table_Component_Type => Xref_Entity_Record, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 500, + Table_Increment => 300, + Table_Name => "Xref_Entity"); + + Array_Index_Reference : constant Character := '*'; + Interface_Reference : constant Character := 'I'; + -- Some special types of references. In the ALI file itself, these + -- are output as attributes of the entity, not as references, but + -- there is no provision in Xref_Entity_Record for storing multiple + -- such references. + + -- The following table records actual cross-references + + type Xref_Record is record + File_Num : Sdep_Id; + -- Set to the file dependency number for the cross-reference. Note + -- that if no file entry is present explicitly, this is just a copy + -- of the reference for the current cross-reference section. + + Line : Nat; + -- Line number for the reference. This is zero when referencing a + -- predefined entity, but in this case Name is set. + + Rtype : Character; + -- Indicates type of reference, using code used in ALI file: + -- r = reference + -- m = modification + -- b = body entity + -- c = completion of private or incomplete type + -- x = type extension + -- i = implicit reference + -- Array_Index_Reference = reference to the index of an array + -- Interface_Reference = reference to an interface implemented + -- by the type + -- See description in lib-xref.ads for further details + + Col : Nat; + -- Column number for the reference + + Name : Name_Id := No_Name; + -- This is only used when referencing a predefined entity. Currently, + -- this only occurs for array indexes. + + -- Note: for instantiation references, Rtype is set to ' ', and Col is + -- set to zero. One or more such entries can follow any other reference. + -- When there is more than one such entry, this is to be read as: + -- e.g. ref1 ref2 ref3 + -- ref1 is a reference to an entity that was instantied at ref2. + -- ref2 itself is also the result of an instantiation, that took + -- place at ref3 + end record; + + package Xref is new Table.Table ( + Table_Component_Type => Xref_Record, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 2000, + Table_Increment => 300, + Table_Name => "Xref"); + + -------------------------------------- + -- Subprograms for Reading ALI File -- + -------------------------------------- + + procedure Initialize_ALI; + -- Initialize the ALI tables. Also resets all switch values to defaults + + function Scan_ALI + (F : File_Name_Type; + T : Text_Buffer_Ptr; + Ignore_ED : Boolean; + Err : Boolean; + Read_Xref : Boolean := False; + Read_Lines : String := ""; + Ignore_Lines : String := "X"; + Ignore_Errors : Boolean := False; + Directly_Scanned : Boolean := False) return ALI_Id; + -- Given the text, T, of an ALI file, F, scan and store the information + -- from the file, and return the Id of the resulting entry in the ALI + -- table. Switch settings may be modified as described above in the + -- switch description settings. + -- + -- Ignore_ED is normally False. If set to True, it indicates that + -- all AD/ED (elaboration desirable) indications in the ALI file are + -- to be ignored. This parameter is obsolete now that the -f switch + -- is removed from gnatbind, and should be removed ??? + -- + -- Err determines the action taken on an incorrectly formatted file. + -- If Err is False, then an error message is output, and the program + -- is terminated. If Err is True, then no error message is output, + -- and No_ALI_Id is returned. + -- + -- Ignore_Lines requests that Scan_ALI ignore any lines that start + -- with any given key character. The default value of X causes all + -- Xref lines to be ignored. The corresponding data in the ALI + -- tables will not be filled in this case. It is not possible + -- to ignore U (unit) lines, they are always read. + -- + -- Read_Lines requests that Scan_ALI process only lines that start + -- with one of the given characters. The corresponding data in the + -- ALI file for any characters not given in the list will not be + -- set. The default value of the null string indicates that all + -- lines should be read (unless Ignore_Lines is specified). U + -- (unit) lines are always read regardless of the value of this + -- parameter. + -- + -- Note: either Ignore_Lines or Read_Lines should be non-null, but not + -- both. If both are provided then only the Read_Lines value is used, + -- and the Ignore_Lines parameter is ignored. + -- + -- Read_XREF is set True to read and acquire the cross-reference + -- information. If Read_XREF is set to True, then the effect is to ignore + -- all lines other than U, W, D and X lines and the Ignore_Lines and + -- Read_Lines parameters are ignored (i.e. the use of True for Read_XREF + -- is equivalent to specifying an argument of "UWDX" for Read_Lines. + -- + -- Ignore_Errors is normally False. If it is set True, then Scan_ALI + -- will do its best to scan through a file and extract all information + -- it can, even if there are errors. In this case Err is only set if + -- Scan_ALI was completely unable to process the file (e.g. it did not + -- look like an ALI file at all). Ignore_Errors is intended to improve + -- the downward compatibility of new compilers with old tools. + -- + -- Directly_Scanned is normally False. If it is set to True, then the + -- units (spec and/or body) corresponding to the ALI file are marked as + -- such. It is used to decide for what units gnatbind should generate + -- the symbols corresponding to 'Version or 'Body_Version in + -- Stand-Alone Libraries. + +end ALI; diff --git a/gcc/ada/alloc.ads b/gcc/ada/alloc.ads new file mode 100644 index 000000000..c5cad7296 --- /dev/null +++ b/gcc/ada/alloc.ads @@ -0,0 +1,160 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A L L O 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains definitions for initial sizes and growth increments +-- for the various dynamic arrays used for principle compiler data strcutures. +-- The indicated initial size is allocated for the start of each file, and +-- the increment factor is a percentage used to increase the table size when +-- it needs expanding (e.g. a value of 100 = 100% increase = double) + +-- Note: the initial values here are multiplied by Table_Factor, as set +-- by the -gnatTnn switch. This variable is defined in Opt, as is the +-- default value for the table factor. + +package Alloc is + + -- The comment shows the unit in which the table is defined + + All_Interp_Initial : constant := 1_000; -- Sem_Type + All_Interp_Increment : constant := 100; + + Branches_Initial : constant := 1_000; -- Sem_Warn + Branches_Increment : constant := 100; + + Conditionals_Initial : constant := 1_000; -- Sem_Warn + Conditionals_Increment : constant := 100; + + Conditional_Stack_Initial : constant := 50; -- Sem_Warn + Conditional_Stack_Increment : constant := 100; + + Elists_Initial : constant := 200; -- Elists + Elists_Increment : constant := 100; + + Elmts_Initial : constant := 1_200; -- Elists + Elmts_Increment : constant := 100; + + File_Name_Chars_Initial : constant := 10_000; -- Osint + File_Name_Chars_Increment : constant := 100; + + Inlined_Bodies_Initial : constant := 50; -- Inline + Inlined_Bodies_Increment : constant := 200; + + Inlined_Initial : constant := 100; -- Inline + Inlined_Increment : constant := 100; + + In_Out_Warnings_Initial : constant := 100; -- Sem_Warn + In_Out_Warnings_Increment : constant := 100; + + Interp_Map_Initial : constant := 200; -- Sem_Type + Interp_Map_Increment : constant := 100; + + Lines_Initial : constant := 500; -- Sinput + Lines_Increment : constant := 150; + + Linker_Option_Lines_Initial : constant := 5; -- Lib + Linker_Option_Lines_Increment : constant := 200; + + Lists_Initial : constant := 4_000; -- Nlists + Lists_Increment : constant := 200; + + Load_Stack_Initial : constant := 10; -- Lib + Load_Stack_Increment : constant := 100; + + Name_Chars_Initial : constant := 50_000; -- Namet + Name_Chars_Increment : constant := 100; + + Name_Qualify_Units_Initial : constant := 200; -- Exp_Dbug + Name_Qualify_Units_Increment : constant := 300; + + Names_Initial : constant := 6_000; -- Namet + Names_Increment : constant := 100; + + Nodes_Initial : constant := 50_000; -- Atree + Nodes_Increment : constant := 100; + + Notes_Initial : constant := 100; -- Lib + Notes_Increment : constant := 200; + + Obsolescent_Warnings_Initial : constant := 50; -- Sem_Prag + Obsolescent_Warnings_Increment : constant := 200; + + Orig_Nodes_Initial : constant := 50_000; -- Atree + Orig_Nodes_Increment : constant := 100; + + Pending_Instantiations_Initial : constant := 10; -- Inline + Pending_Instantiations_Increment : constant := 100; + + Rep_Table_Initial : constant := 1000; -- Repinfo + Rep_Table_Increment : constant := 200; + + Scope_Stack_Initial : constant := 10; -- Sem + Scope_Stack_Increment : constant := 200; + + SFN_Table_Initial : constant := 10; -- Fname + SFN_Table_Increment : constant := 200; + + Source_File_Initial : constant := 10; -- Sinput + Source_File_Increment : constant := 200; + + String_Chars_Initial : constant := 2_500; -- Stringt + String_Chars_Increment : constant := 150; + + Strings_Initial : constant := 5_00; -- Stringt + Strings_Increment : constant := 150; + + Successors_Initial : constant := 2_00; -- Inline + Successors_Increment : constant := 100; + + Udigits_Initial : constant := 10_000; -- Uintp + Udigits_Increment : constant := 100; + + Uints_Initial : constant := 5_000; -- Uintp + Uints_Increment : constant := 100; + + Units_Initial : constant := 30; -- Lib + Units_Increment : constant := 100; + + Ureals_Initial : constant := 200; -- Urealp + Ureals_Increment : constant := 100; + + Unreferenced_Entities_Initial : constant := 1_000; -- Sem_Warn + Unreferenced_Entities_Increment : constant := 100; + + Warnings_Off_Pragmas_Initial : constant := 500; -- Sem_Warn + Warnings_Off_Pragmas_Increment : constant := 100; + + With_List_Initial : constant := 10; -- Features + With_List_Increment : constant := 300; + + Xrefs_Initial : constant := 5_000; -- Cross-refs + Xrefs_Increment : constant := 300; + +end Alloc; diff --git a/gcc/ada/argv.c b/gcc/ada/argv.c new file mode 100644 index 000000000..b827b030f --- /dev/null +++ b/gcc/ada/argv.c @@ -0,0 +1,118 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * A R G V * + * * + * C Implementation File * + * * + * Copyright (C) 1992-2009, Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. * + * * + * As a special exception under Section 7 of GPL version 3, you are granted * + * additional permissions described in the GCC Runtime Library Exception, * + * version 3.1, as published by the Free Software Foundation. * + * * + * You should have received a copy of the GNU General Public License and * + * a copy of the GCC Runtime Library Exception along with this program; * + * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* Routines for accessing command line arguments from both the runtime + library and from the compiler itself. In the former case, gnat_argc + and gnat_argv are the original argc and argv values as stored by the + binder generated main program, and these routines are accessed from + the Ada.Command_Line package. In the compiler case, gnat_argc and + gnat_argv are the values as modified by toplev, and these routines + are accessed from the Osint package. */ + +/* Also routines for accessing the environment from the runtime library. + Gnat_envp is the original envp value as stored by the binder generated + main program, and these routines are accessed from the + Ada.Command_Line.Environment package. */ + +#ifdef IN_RTS +#include "tconfig.h" +#include "tsystem.h" +#include +#else +#include "config.h" +#include "system.h" +#endif + +#include "adaint.h" + +/* argc and argv of the main program are saved under gnat_argc and gnat_argv, + envp of the main program is saved under gnat_envp. */ + +int gnat_argc = 0; +const char **gnat_argv = (const char **) 0; +const char **gnat_envp = (const char **) 0; + +#if defined (_WIN32) && !defined (RTX) +/* Note that on Windows environment the environ point to a buffer that could + be reallocated if needed. It means that gnat_envp needs to be updated + before using gnat_envp to point to the right environment space */ +#include +/* for the environ variable definition */ +#define gnat_envp (environ) +#endif + +int +__gnat_arg_count (void) +{ + return gnat_argc; +} + +int +__gnat_len_arg (int arg_num) +{ + if (gnat_argv != NULL) + return strlen (gnat_argv[arg_num]); + else + return 0; +} + +void +__gnat_fill_arg (char *a, int i) +{ + if (gnat_argv != NULL) + strncpy (a, gnat_argv[i], strlen(gnat_argv[i])); +} + +int +__gnat_env_count (void) +{ + int i; + + for (i = 0; gnat_envp[i]; i++) + ; + return i; +} + +int +__gnat_len_env (int env_num) +{ + if (gnat_envp != NULL) + return strlen (gnat_envp[env_num]); + else + return 0; +} + +void +__gnat_fill_env (char *a, int i) +{ + if (gnat_envp != NULL) + strncpy (a, gnat_envp[i], strlen (gnat_envp[i])); +} diff --git a/gcc/ada/arit64.c b/gcc/ada/arit64.c new file mode 100644 index 000000000..0ad03960b --- /dev/null +++ b/gcc/ada/arit64.c @@ -0,0 +1,57 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * A R I T 6 4 . C * + * * + * C Implementation File * + * * + * 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. * + * * + ****************************************************************************/ + +extern void __gnat_rcheck_10(char *file, int line) + __attribute__ ((__noreturn__)); + +long long int __gnat_mulv64 (long long int x, long long int y) +{ + unsigned neg = (x >= 0) ^ (y >= 0); + long long unsigned xa = x >= 0 ? (long long unsigned) x + : -(long long unsigned) x; + long long unsigned ya = y >= 0 ? (long long unsigned) y + : -(long long unsigned) y; + unsigned xhi = (unsigned) (xa >> 32); + unsigned yhi = (unsigned) (ya >> 32); + unsigned xlo = (unsigned) xa; + unsigned ylo = (unsigned) ya; + long long unsigned mid + = xhi ? (long long unsigned) xhi * (long long unsigned) ylo + : (long long unsigned) yhi * (long long unsigned) xlo; + long long unsigned low = (long long unsigned) xlo * (long long unsigned) ylo; + + if ((xhi && yhi) || mid + (low >> 32) > 0x7fffffff + neg) + __gnat_rcheck_10 (__FILE__, __LINE__); + + low += ((long long unsigned) (unsigned) mid) << 32; + + return (long long int) (neg ? -low : low); +} diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb new file mode 100755 index 000000000..faf50cd86 --- /dev/null +++ b/gcc/ada/aspects.adb @@ -0,0 +1,272 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A S P E C T S -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Nlists; use Nlists; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Tree_IO; use Tree_IO; + +with GNAT.HTable; use GNAT.HTable; + +package body Aspects is + + ------------------------------------------ + -- Hash Table for Aspect Specifications -- + ------------------------------------------ + + type AS_Hash_Range is range 0 .. 510; + -- Size of hash table headers + + function AS_Hash (F : Node_Id) return AS_Hash_Range; + -- Hash function for hash table + + function AS_Hash (F : Node_Id) return AS_Hash_Range is + begin + return AS_Hash_Range (F mod 511); + end AS_Hash; + + package Aspect_Specifications_Hash_Table is new + GNAT.HTable.Simple_HTable + (Header_Num => AS_Hash_Range, + Element => List_Id, + No_Element => No_List, + Key => Node_Id, + Hash => AS_Hash, + Equal => "="); + + ----------------------------------------- + -- Table Linking Names and Aspect_Id's -- + ----------------------------------------- + + type Aspect_Entry is record + Nam : Name_Id; + Asp : Aspect_Id; + end record; + + Aspect_Names : constant array (Integer range <>) of Aspect_Entry := ( + (Name_Ada_2005, Aspect_Ada_2005), + (Name_Ada_2012, Aspect_Ada_2012), + (Name_Address, Aspect_Address), + (Name_Alignment, Aspect_Alignment), + (Name_Atomic, Aspect_Atomic), + (Name_Atomic_Components, Aspect_Atomic_Components), + (Name_Bit_Order, Aspect_Bit_Order), + (Name_Component_Size, Aspect_Component_Size), + (Name_Discard_Names, Aspect_Discard_Names), + (Name_External_Tag, Aspect_External_Tag), + (Name_Favor_Top_Level, Aspect_Favor_Top_Level), + (Name_Inline, Aspect_Inline), + (Name_Inline_Always, Aspect_Inline_Always), + (Name_Input, Aspect_Input), + (Name_Invariant, Aspect_Invariant), + (Name_Machine_Radix, Aspect_Machine_Radix), + (Name_Object_Size, Aspect_Object_Size), + (Name_Output, Aspect_Output), + (Name_Pack, Aspect_Pack), + (Name_Persistent_BSS, Aspect_Persistent_BSS), + (Name_Post, Aspect_Post), + (Name_Pre, Aspect_Pre), + (Name_Predicate, Aspect_Predicate), + (Name_Preelaborable_Initialization, Aspect_Preelaborable_Initialization), + (Name_Pure_Function, Aspect_Pure_Function), + (Name_Read, Aspect_Read), + (Name_Shared, Aspect_Shared), + (Name_Size, Aspect_Size), + (Name_Storage_Pool, Aspect_Storage_Pool), + (Name_Storage_Size, Aspect_Storage_Size), + (Name_Stream_Size, Aspect_Stream_Size), + (Name_Suppress, Aspect_Suppress), + (Name_Suppress_Debug_Info, Aspect_Suppress_Debug_Info), + (Name_Unchecked_Union, Aspect_Unchecked_Union), + (Name_Universal_Aliasing, Aspect_Universal_Aliasing), + (Name_Unmodified, Aspect_Unmodified), + (Name_Unreferenced, Aspect_Unreferenced), + (Name_Unreferenced_Objects, Aspect_Unreferenced_Objects), + (Name_Unsuppress, Aspect_Unsuppress), + (Name_Value_Size, Aspect_Value_Size), + (Name_Volatile, Aspect_Volatile), + (Name_Volatile_Components, Aspect_Volatile_Components), + (Name_Warnings, Aspect_Warnings), + (Name_Write, Aspect_Write)); + + ------------------------------------- + -- Hash Table for Aspect Id Values -- + ------------------------------------- + + type AI_Hash_Range is range 0 .. 112; + -- Size of hash table headers + + function AI_Hash (F : Name_Id) return AI_Hash_Range; + -- Hash function for hash table + + function AI_Hash (F : Name_Id) return AI_Hash_Range is + begin + return AI_Hash_Range (F mod 113); + end AI_Hash; + + package Aspect_Id_Hash_Table is new + GNAT.HTable.Simple_HTable + (Header_Num => AI_Hash_Range, + Element => Aspect_Id, + No_Element => No_Aspect, + Key => Name_Id, + Hash => AI_Hash, + Equal => "="); + + ------------------- + -- Get_Aspect_Id -- + ------------------- + + function Get_Aspect_Id (Name : Name_Id) return Aspect_Id is + begin + return Aspect_Id_Hash_Table.Get (Name); + end Get_Aspect_Id; + + --------------------------- + -- Aspect_Specifications -- + --------------------------- + + function Aspect_Specifications (N : Node_Id) return List_Id is + begin + if Has_Aspects (N) then + return Aspect_Specifications_Hash_Table.Get (N); + else + return No_List; + end if; + end Aspect_Specifications; + + ------------------ + -- Move_Aspects -- + ------------------ + + procedure Move_Aspects (From : Node_Id; To : Node_Id) is + pragma Assert (not Has_Aspects (To)); + begin + if Has_Aspects (From) then + Set_Aspect_Specifications (To, Aspect_Specifications (From)); + Aspect_Specifications_Hash_Table.Remove (From); + Set_Has_Aspects (From, False); + end if; + end Move_Aspects; + + ----------------------------------- + -- Permits_Aspect_Specifications -- + ----------------------------------- + + Has_Aspect_Specifications_Flag : constant array (Node_Kind) of Boolean := + (N_Abstract_Subprogram_Declaration => True, + N_Component_Declaration => True, + N_Entry_Declaration => True, + N_Exception_Declaration => True, + N_Formal_Abstract_Subprogram_Declaration => True, + N_Formal_Concrete_Subprogram_Declaration => True, + N_Formal_Object_Declaration => True, + N_Formal_Package_Declaration => True, + N_Formal_Type_Declaration => True, + N_Full_Type_Declaration => True, + N_Function_Instantiation => True, + N_Generic_Package_Declaration => True, + N_Generic_Subprogram_Declaration => True, + N_Object_Declaration => True, + N_Package_Declaration => True, + N_Package_Instantiation => True, + N_Private_Extension_Declaration => True, + N_Private_Type_Declaration => True, + N_Procedure_Instantiation => True, + N_Protected_Type_Declaration => True, + N_Single_Protected_Declaration => True, + N_Single_Task_Declaration => True, + N_Subprogram_Declaration => True, + N_Subtype_Declaration => True, + N_Task_Type_Declaration => True, + others => False); + + function Permits_Aspect_Specifications (N : Node_Id) return Boolean is + begin + return Has_Aspect_Specifications_Flag (Nkind (N)); + end Permits_Aspect_Specifications; + + ------------------------------- + -- Set_Aspect_Specifications -- + ------------------------------- + + procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id) is + begin + pragma Assert (Permits_Aspect_Specifications (N)); + pragma Assert (not Has_Aspects (N)); + pragma Assert (L /= No_List); + + Set_Has_Aspects (N); + Set_Parent (L, N); + Aspect_Specifications_Hash_Table.Set (N, L); + end Set_Aspect_Specifications; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + Node : Node_Id; + List : List_Id; + begin + loop + Tree_Read_Int (Int (Node)); + Tree_Read_Int (Int (List)); + exit when List = No_List; + Set_Aspect_Specifications (Node, List); + end loop; + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + Node : Node_Id := Empty; + List : List_Id; + begin + Aspect_Specifications_Hash_Table.Get_First (Node, List); + loop + Tree_Write_Int (Int (Node)); + Tree_Write_Int (Int (List)); + exit when List = No_List; + Aspect_Specifications_Hash_Table.Get_Next (Node, List); + end loop; + end Tree_Write; + +-- Package initialization sets up Aspect Id hash table + +begin + for J in Aspect_Names'Range loop + Aspect_Id_Hash_Table.Set (Aspect_Names (J).Nam, Aspect_Names (J).Asp); + end loop; +end Aspects; diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads new file mode 100755 index 000000000..9f44197dd --- /dev/null +++ b/gcc/ada/aspects.ads @@ -0,0 +1,218 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A S P E C T S -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package defines the aspects that are recognized by GNAT in aspect +-- specifications. It also contains the subprograms for storing/retrieving +-- aspect specifications from the tree. The semantic processing for aspect +-- specifications is found in Sem_Ch13.Analyze_Aspect_Specifications. + +with Namet; use Namet; +with Types; use Types; + +package Aspects is + + -- Type defining recognized aspects + + type Aspect_Id is + (No_Aspect, -- Dummy entry for no aspect + Aspect_Ada_2005, -- GNAT + Aspect_Ada_2012, -- GNAT + Aspect_Address, + Aspect_Alignment, + Aspect_Atomic, + Aspect_Atomic_Components, + Aspect_Bit_Order, + Aspect_Component_Size, + Aspect_Discard_Names, + Aspect_External_Tag, + Aspect_Favor_Top_Level, -- GNAT + Aspect_Inline, + Aspect_Inline_Always, -- GNAT + Aspect_Input, + Aspect_Invariant, + Aspect_Machine_Radix, + Aspect_No_Return, + Aspect_Object_Size, -- GNAT + Aspect_Output, + Aspect_Pack, + Aspect_Persistent_BSS, -- GNAT + Aspect_Post, + Aspect_Pre, + Aspect_Predicate, -- GNAT??? + Aspect_Preelaborable_Initialization, + Aspect_Pure_Function, -- GNAT + Aspect_Read, + Aspect_Shared, -- GNAT (equivalent to Atomic) + Aspect_Size, + Aspect_Storage_Pool, + Aspect_Storage_Size, + Aspect_Stream_Size, + Aspect_Suppress, + Aspect_Suppress_Debug_Info, -- GNAT + Aspect_Unchecked_Union, + Aspect_Universal_Aliasing, -- GNAT + Aspect_Unmodified, -- GNAT + Aspect_Unreferenced, -- GNAT + Aspect_Unreferenced_Objects, -- GNAT + Aspect_Unsuppress, + Aspect_Value_Size, -- GNAT + Aspect_Volatile, + Aspect_Volatile_Components, + Aspect_Warnings, + Aspect_Write); -- GNAT + + -- The following array indicates aspects that accept 'Class + + Class_Aspect_OK : constant array (Aspect_Id) of Boolean := + (Aspect_Invariant => True, + Aspect_Pre => True, + Aspect_Predicate => True, + Aspect_Post => True, + others => False); + + -- The following type is used for indicating allowed expression forms + + type Aspect_Expression is + (Optional, -- Optional boolean expression + Expression, -- Required non-boolean expression + Name); -- Required name + + -- The following array indicates what argument type is required + + Aspect_Argument : constant array (Aspect_Id) of Aspect_Expression := + (No_Aspect => Optional, + Aspect_Ada_2005 => Optional, + Aspect_Ada_2012 => Optional, + Aspect_Address => Expression, + Aspect_Alignment => Expression, + Aspect_Atomic => Optional, + Aspect_Atomic_Components => Optional, + Aspect_Bit_Order => Expression, + Aspect_Component_Size => Expression, + Aspect_Discard_Names => Optional, + Aspect_External_Tag => Expression, + Aspect_Favor_Top_Level => Optional, + Aspect_Inline => Optional, + Aspect_Inline_Always => Optional, + Aspect_Input => Name, + Aspect_Invariant => Expression, + Aspect_Machine_Radix => Expression, + Aspect_No_Return => Optional, + Aspect_Object_Size => Expression, + Aspect_Output => Name, + Aspect_Persistent_BSS => Optional, + Aspect_Pack => Optional, + Aspect_Post => Expression, + Aspect_Pre => Expression, + Aspect_Predicate => Expression, + Aspect_Preelaborable_Initialization => Optional, + Aspect_Pure_Function => Optional, + Aspect_Read => Name, + Aspect_Shared => Optional, + Aspect_Size => Expression, + Aspect_Storage_Pool => Name, + Aspect_Storage_Size => Expression, + Aspect_Stream_Size => Expression, + Aspect_Suppress => Name, + Aspect_Suppress_Debug_Info => Optional, + Aspect_Unchecked_Union => Optional, + Aspect_Universal_Aliasing => Optional, + Aspect_Unmodified => Optional, + Aspect_Unreferenced => Optional, + Aspect_Unreferenced_Objects => Optional, + Aspect_Unsuppress => Name, + Aspect_Value_Size => Expression, + Aspect_Volatile => Optional, + Aspect_Volatile_Components => Optional, + Aspect_Warnings => Name, + Aspect_Write => Name); + + function Get_Aspect_Id (Name : Name_Id) return Aspect_Id; + pragma Inline (Get_Aspect_Id); + -- Given a name Nam, returns the corresponding aspect id value. If the name + -- does not match any aspect, then No_Aspect is returned as the result. + + --------------------------------------------------- + -- Handling of Aspect Specifications in the Tree -- + --------------------------------------------------- + + -- Several kinds of declaration node permit aspect specifications in Ada + -- 2012 mode. If there was room in all the corresponding declaration nodes, + -- we could just have a field Aspect_Specifications pointing to a list of + -- nodes for the aspects (N_Aspect_Specification nodes). But there isn't + -- room, so we adopt a different approach. + + -- The following subprograms provide access to a specialized interface + -- implemented internally with a hash table in the body, that provides + -- access to aspect specifications. + + function Permits_Aspect_Specifications (N : Node_Id) return Boolean; + -- Returns True if the node N is a declaration node that permits aspect + -- specifications in the grammar. It is possible for other nodes to have + -- aspect specifications as a result of Rewrite or Replace calls. + + function Aspect_Specifications (N : Node_Id) return List_Id; + -- Given a node N, returns the list of N_Aspect_Specification nodes that + -- are attached to this declaration node. If the node is in the class of + -- declaration nodes that permit aspect specifications, as defined by the + -- predicate above, and if their Has_Aspects flag is set to True, then this + -- will always be a non-empty list. If this flag is set to False, then + -- No_List is returned. Normally, the only nodes that have Has_Aspects set + -- True are the nodes for which Permits_Aspect_Specifications would return + -- True (i.e. the declaration nodes defined in the RM as permitting the + -- presence of Aspect_Specifications). However, it is possible for the + -- flag Has_Aspects to be set on other nodes as a result of Rewrite and + -- Replace calls, and this function may be used to retrieve the aspect + -- specifications for the original rewritten node in such cases. + + procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id); + -- The node N must be in the class of declaration nodes that permit aspect + -- specifications and the Has_Aspects flag must be False on entry. L must + -- be a non-empty list of N_Aspect_Specification nodes. This procedure sets + -- the Has_Aspects flag to True, and makes an entry that can be retrieved + -- by a subsequent Aspect_Specifications call. It is an error to call this + -- procedure with a node that does not permit aspect specifications, or a + -- node that has its Has_Aspects flag set True on entry, or with L being an + -- empty list or No_List. + + procedure Move_Aspects (From : Node_Id; To : Node_Id); + -- Moves aspects from 'From' node to 'To' node. Has_Aspects (To) must be + -- False on entry. If Has_Aspects (From) is False, the call has no effect. + -- Otherwise the aspects are moved and on return Has_Aspects (To) is True, + -- and Has_Aspects (From) is False. + + procedure Tree_Write; + -- Writes contents of Aspect_Specifications hash table to the tree file + + procedure Tree_Read; + -- Reads contents of Aspect_Specifications hash table from the tree file + +end Aspects; diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb new file mode 100644 index 000000000..5426fab7d --- /dev/null +++ b/gcc/ada/atree.adb @@ -0,0 +1,6784 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A T R E E -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram ordering check for this package + +-- WARNING: There is a C version of this package. Any changes to this source +-- file must be properly reflected in the file atree.h which is a C header +-- file containing equivalent definitions for use by gigi. + +with Aspects; use Aspects; +with Debug; use Debug; +with Nlists; use Nlists; +with Output; use Output; +with Sinput; use Sinput; +with Tree_IO; use Tree_IO; + +package body Atree is + + Reporting_Proc : Report_Proc := null; + -- Record argument to last call to Set_Reporting_Proc + + --------------- + -- Debugging -- + --------------- + + -- Suppose you find that node 12345 is messed up. You might want to find + -- the code that created that node. There are two ways to do this: + + -- One way is to set a conditional breakpoint on New_Node_Debugging_Output + -- (nickname "nnd"): + -- break nnd if n = 12345 + -- and run gnat1 again from the beginning. + + -- The other way is to set a breakpoint near the beginning (e.g. on + -- gnat1drv), and run. Then set Watch_Node (nickname "ww") to 12345 in gdb: + -- ww := 12345 + -- and set a breakpoint on New_Node_Breakpoint (nickname "nn"). Continue. + + -- Either way, gnat1 will stop when node 12345 is created + + -- The second method is much faster + + -- Similarly, rr and rrd allow breaking on rewriting of a given node + + ww : Node_Id'Base := Node_Id'First - 1; + pragma Export (Ada, ww); -- trick the optimizer + Watch_Node : Node_Id'Base renames ww; + -- Node to "watch"; that is, whenever a node is created, we check if it + -- is equal to Watch_Node, and if so, call New_Node_Breakpoint. You have + -- presumably set a breakpoint on New_Node_Breakpoint. Note that the + -- initial value of Node_Id'First - 1 ensures that by default, no node + -- will be equal to Watch_Node. + + procedure nn; + pragma Export (Ada, nn); + procedure New_Node_Breakpoint renames nn; + -- This doesn't do anything interesting; it's just for setting breakpoint + -- on as explained above. + + procedure nnd (N : Node_Id); + pragma Export (Ada, nnd); + procedure New_Node_Debugging_Output (N : Node_Id) renames nnd; + -- For debugging. If debugging is turned on, New_Node and New_Entity call + -- this. If debug flag N is turned on, this prints out the new node. + -- + -- If Node = Watch_Node, this prints out the new node and calls + -- New_Node_Breakpoint. Otherwise, does nothing. + + procedure rr; + pragma Export (Ada, rr); + procedure Rewrite_Breakpoint renames rr; + -- This doesn't do anything interesting; it's just for setting breakpoint + -- on as explained above. + + procedure rrd (Old_Node, New_Node : Node_Id); + pragma Export (Ada, rrd); + procedure Rewrite_Debugging_Output + (Old_Node, New_Node : Node_Id) renames rrd; + -- For debugging. If debugging is turned on, Rewrite calls this. If debug + -- flag N is turned on, this prints out the new node. + -- + -- If Old_Node = Watch_Node, this prints out the old and new nodes and + -- calls Rewrite_Breakpoint. Otherwise, does nothing. + + procedure Node_Debug_Output (Op : String; N : Node_Id); + -- Common code for nnd and rrd, writes Op followed by information about N + + ----------------------------- + -- Local Objects and Types -- + ----------------------------- + + Node_Count : Nat; + -- Count allocated nodes for Num_Nodes function + + use Unchecked_Access; + -- We are allowed to see these from within our own body! + + use Atree_Private_Part; + -- We are also allowed to see our private data structures! + + -- Functions used to store Entity_Kind value in Nkind field + + -- The following declarations are used to store flags 65-72 in the + -- Nkind field of the third component of an extended (entity) node. + + type Flag_Byte is record + Flag65 : Boolean; + Flag66 : Boolean; + Flag67 : Boolean; + Flag68 : Boolean; + Flag69 : Boolean; + Flag70 : Boolean; + Flag71 : Boolean; + Flag72 : Boolean; + end record; + + pragma Pack (Flag_Byte); + for Flag_Byte'Size use 8; + + type Flag_Byte_Ptr is access all Flag_Byte; + type Node_Kind_Ptr is access all Node_Kind; + + function To_Flag_Byte is new + Unchecked_Conversion (Node_Kind, Flag_Byte); + + function To_Flag_Byte_Ptr is new + Unchecked_Conversion (Node_Kind_Ptr, Flag_Byte_Ptr); + + -- The following declarations are used to store flags 239-246 in the + -- Nkind field of the fourth component of an extended (entity) node. + + type Flag_Byte2 is record + Flag239 : Boolean; + Flag240 : Boolean; + Flag241 : Boolean; + Flag242 : Boolean; + Flag243 : Boolean; + Flag244 : Boolean; + Flag245 : Boolean; + Flag246 : Boolean; + end record; + + pragma Pack (Flag_Byte2); + for Flag_Byte2'Size use 8; + + type Flag_Byte2_Ptr is access all Flag_Byte2; + + function To_Flag_Byte2 is new + Unchecked_Conversion (Node_Kind, Flag_Byte2); + + function To_Flag_Byte2_Ptr is new + Unchecked_Conversion (Node_Kind_Ptr, Flag_Byte2_Ptr); + + -- The following declarations are used to store flags 247-254 in the + -- Nkind field of the fifth component of an extended (entity) node. + + type Flag_Byte3 is record + Flag247 : Boolean; + Flag248 : Boolean; + Flag249 : Boolean; + Flag250 : Boolean; + Flag251 : Boolean; + Flag252 : Boolean; + Flag253 : Boolean; + Flag254 : Boolean; + end record; + + pragma Pack (Flag_Byte3); + for Flag_Byte3'Size use 8; + + type Flag_Byte3_Ptr is access all Flag_Byte3; + + function To_Flag_Byte3 is new + Unchecked_Conversion (Node_Kind, Flag_Byte3); + + function To_Flag_Byte3_Ptr is new + Unchecked_Conversion (Node_Kind_Ptr, Flag_Byte3_Ptr); + + -- The following declarations are used to store flags 73-96 and the + -- Convention field in the Field12 field of the third component of an + -- extended (Entity) node. + + type Flag_Word is record + Flag73 : Boolean; + Flag74 : Boolean; + Flag75 : Boolean; + Flag76 : Boolean; + Flag77 : Boolean; + Flag78 : Boolean; + Flag79 : Boolean; + Flag80 : Boolean; + + Flag81 : Boolean; + Flag82 : Boolean; + Flag83 : Boolean; + Flag84 : Boolean; + Flag85 : Boolean; + Flag86 : Boolean; + Flag87 : Boolean; + Flag88 : Boolean; + + Flag89 : Boolean; + Flag90 : Boolean; + Flag91 : Boolean; + Flag92 : Boolean; + Flag93 : Boolean; + Flag94 : Boolean; + Flag95 : Boolean; + Flag96 : Boolean; + + Convention : Convention_Id; + end record; + + pragma Pack (Flag_Word); + for Flag_Word'Size use 32; + for Flag_Word'Alignment use 4; + + type Flag_Word_Ptr is access all Flag_Word; + type Union_Id_Ptr is access all Union_Id; + + function To_Flag_Word is new + Unchecked_Conversion (Union_Id, Flag_Word); + + function To_Flag_Word_Ptr is new + Unchecked_Conversion (Union_Id_Ptr, Flag_Word_Ptr); + + -- The following declarations are used to store flags 97-128 in the + -- Field12 field of the fourth component of an extended (entity) node. + + type Flag_Word2 is record + Flag97 : Boolean; + Flag98 : Boolean; + Flag99 : Boolean; + Flag100 : Boolean; + Flag101 : Boolean; + Flag102 : Boolean; + Flag103 : Boolean; + Flag104 : Boolean; + + Flag105 : Boolean; + Flag106 : Boolean; + Flag107 : Boolean; + Flag108 : Boolean; + Flag109 : Boolean; + Flag110 : Boolean; + Flag111 : Boolean; + Flag112 : Boolean; + + Flag113 : Boolean; + Flag114 : Boolean; + Flag115 : Boolean; + Flag116 : Boolean; + Flag117 : Boolean; + Flag118 : Boolean; + Flag119 : Boolean; + Flag120 : Boolean; + + Flag121 : Boolean; + Flag122 : Boolean; + Flag123 : Boolean; + Flag124 : Boolean; + Flag125 : Boolean; + Flag126 : Boolean; + Flag127 : Boolean; + Flag128 : Boolean; + end record; + + pragma Pack (Flag_Word2); + for Flag_Word2'Size use 32; + for Flag_Word2'Alignment use 4; + + type Flag_Word2_Ptr is access all Flag_Word2; + + function To_Flag_Word2 is new + Unchecked_Conversion (Union_Id, Flag_Word2); + + function To_Flag_Word2_Ptr is new + Unchecked_Conversion (Union_Id_Ptr, Flag_Word2_Ptr); + + -- The following declarations are used to store flags 152-183 in the + -- Field11 field of the fourth component of an extended (entity) node. + + type Flag_Word3 is record + Flag152 : Boolean; + Flag153 : Boolean; + Flag154 : Boolean; + Flag155 : Boolean; + Flag156 : Boolean; + Flag157 : Boolean; + Flag158 : Boolean; + Flag159 : Boolean; + + Flag160 : Boolean; + Flag161 : Boolean; + Flag162 : Boolean; + Flag163 : Boolean; + Flag164 : Boolean; + Flag165 : Boolean; + Flag166 : Boolean; + Flag167 : Boolean; + + Flag168 : Boolean; + Flag169 : Boolean; + Flag170 : Boolean; + Flag171 : Boolean; + Flag172 : Boolean; + Flag173 : Boolean; + Flag174 : Boolean; + Flag175 : Boolean; + + Flag176 : Boolean; + Flag177 : Boolean; + Flag178 : Boolean; + Flag179 : Boolean; + Flag180 : Boolean; + Flag181 : Boolean; + Flag182 : Boolean; + Flag183 : Boolean; + end record; + + pragma Pack (Flag_Word3); + for Flag_Word3'Size use 32; + for Flag_Word3'Alignment use 4; + + type Flag_Word3_Ptr is access all Flag_Word3; + + function To_Flag_Word3 is new + Unchecked_Conversion (Union_Id, Flag_Word3); + + function To_Flag_Word3_Ptr is new + Unchecked_Conversion (Union_Id_Ptr, Flag_Word3_Ptr); + + -- The following declarations are used to store flags 184-215 in the + -- Field12 field of the fifth component of an extended (entity) node. + + type Flag_Word4 is record + Flag184 : Boolean; + Flag185 : Boolean; + Flag186 : Boolean; + Flag187 : Boolean; + Flag188 : Boolean; + Flag189 : Boolean; + Flag190 : Boolean; + Flag191 : Boolean; + + Flag192 : Boolean; + Flag193 : Boolean; + Flag194 : Boolean; + Flag195 : Boolean; + Flag196 : Boolean; + Flag197 : Boolean; + Flag198 : Boolean; + Flag199 : Boolean; + + Flag200 : Boolean; + Flag201 : Boolean; + Flag202 : Boolean; + Flag203 : Boolean; + Flag204 : Boolean; + Flag205 : Boolean; + Flag206 : Boolean; + Flag207 : Boolean; + + Flag208 : Boolean; + Flag209 : Boolean; + Flag210 : Boolean; + Flag211 : Boolean; + Flag212 : Boolean; + Flag213 : Boolean; + Flag214 : Boolean; + Flag215 : Boolean; + end record; + + pragma Pack (Flag_Word4); + for Flag_Word4'Size use 32; + for Flag_Word4'Alignment use 4; + + type Flag_Word4_Ptr is access all Flag_Word4; + + function To_Flag_Word4 is new + Unchecked_Conversion (Union_Id, Flag_Word4); + + function To_Flag_Word4_Ptr is new + Unchecked_Conversion (Union_Id_Ptr, Flag_Word4_Ptr); + + -------------------------------------------------- + -- Implementation of Tree Substitution Routines -- + -------------------------------------------------- + + -- A separate table keeps track of the mapping between rewritten nodes + -- and their corresponding original tree nodes. Rewrite makes an entry + -- in this table for use by Original_Node. By default, if no call is + -- Rewrite, the entry in this table points to the original unwritten node. + + -- Note: eventually, this should be a field in the Node directly, but + -- for now we do not want to disturb the efficiency of a power of 2 + -- for the node size + + package Orig_Nodes is new Table.Table ( + Table_Component_Type => Node_Id, + Table_Index_Type => Node_Id'Base, + Table_Low_Bound => First_Node_Id, + Table_Initial => Alloc.Orig_Nodes_Initial, + Table_Increment => Alloc.Orig_Nodes_Increment, + Table_Name => "Orig_Nodes"); + + -------------------------- + -- Paren_Count Handling -- + -------------------------- + + -- As noted in the spec, the paren count in a sub-expression node has + -- four possible values 0,1,2, and 3. The value 3 really means 3 or more, + -- and we use an auxiliary serially scanned table to record the actual + -- count. A serial search is fine, only pathological programs will use + -- entries in this table. Normal programs won't use it at all. + + type Paren_Count_Entry is record + Nod : Node_Id; + -- The node to which this count applies + + Count : Nat range 3 .. Nat'Last; + -- The count of parentheses, which will be in the indicated range + end record; + + package Paren_Counts is new Table.Table ( + Table_Component_Type => Paren_Count_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 200, + Table_Name => "Paren_Counts"); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Fix_Parents (Ref_Node, Fix_Node : Node_Id); + -- Fixup parent pointers for the syntactic children of Fix_Node after + -- a copy, setting them to Fix_Node when they pointed to Ref_Node. + + function Allocate_Initialize_Node + (Src : Node_Id; + With_Extension : Boolean) return Node_Id; + -- Allocate a new node or node extension. If Src is not empty, + -- the information for the newly-allocated node is copied from it. + + ------------------------------ + -- Allocate_Initialize_Node -- + ------------------------------ + + function Allocate_Initialize_Node + (Src : Node_Id; + With_Extension : Boolean) return Node_Id + is + New_Id : Node_Id := Src; + Nod : Node_Record := Default_Node; + Ext1 : Node_Record := Default_Node_Extension; + Ext2 : Node_Record := Default_Node_Extension; + Ext3 : Node_Record := Default_Node_Extension; + Ext4 : Node_Record := Default_Node_Extension; + + begin + if Present (Src) then + Nod := Nodes.Table (Src); + + if Has_Extension (Src) then + Ext1 := Nodes.Table (Src + 1); + Ext2 := Nodes.Table (Src + 2); + Ext3 := Nodes.Table (Src + 3); + Ext4 := Nodes.Table (Src + 4); + end if; + end if; + + if not (Present (Src) + and then not Has_Extension (Src) + and then With_Extension + and then Src = Nodes.Last) + then + -- We are allocating a new node, or extending a node + -- other than Nodes.Last. + + Nodes.Append (Nod); + New_Id := Nodes.Last; + Orig_Nodes.Append (New_Id); + Node_Count := Node_Count + 1; + end if; + + -- Specifically copy Paren_Count to deal with creating new table entry + -- if the parentheses count is at the maximum possible value already. + + if Present (Src) and then Nkind (Src) in N_Subexpr then + Set_Paren_Count (New_Id, Paren_Count (Src)); + end if; + + -- Set extension nodes if required + + if With_Extension then + Nodes.Append (Ext1); + Nodes.Append (Ext2); + Nodes.Append (Ext3); + Nodes.Append (Ext4); + end if; + + Orig_Nodes.Set_Last (Nodes.Last); + Allocate_List_Tables (Nodes.Last); + + -- Invoke the reporting procedure (if available) + + if Reporting_Proc /= null then + Reporting_Proc.all (Target => New_Id, Source => Src); + end if; + + return New_Id; + end Allocate_Initialize_Node; + + -------------- + -- Analyzed -- + -------------- + + function Analyzed (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Analyzed; + end Analyzed; + + -------------------------- + -- Basic_Set_Convention -- + -------------------------- + + procedure Basic_Set_Convention (E : Entity_Id; Val : Convention_Id) is + begin + pragma Assert (Nkind (E) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (E + 2).Field12'Unrestricted_Access)).Convention := Val; + end Basic_Set_Convention; + + ----------------- + -- Change_Node -- + ----------------- + + procedure Change_Node (N : Node_Id; New_Node_Kind : Node_Kind) is + Save_Sloc : constant Source_Ptr := Sloc (N); + Save_In_List : constant Boolean := Nodes.Table (N).In_List; + Save_Link : constant Union_Id := Nodes.Table (N).Link; + Save_CFS : constant Boolean := Nodes.Table (N).Comes_From_Source; + Save_Posted : constant Boolean := Nodes.Table (N).Error_Posted; + Par_Count : Nat := 0; + + begin + if Nkind (N) in N_Subexpr then + Par_Count := Paren_Count (N); + end if; + + Nodes.Table (N) := Default_Node; + Nodes.Table (N).Sloc := Save_Sloc; + Nodes.Table (N).In_List := Save_In_List; + Nodes.Table (N).Link := Save_Link; + Nodes.Table (N).Comes_From_Source := Save_CFS; + Nodes.Table (N).Nkind := New_Node_Kind; + Nodes.Table (N).Error_Posted := Save_Posted; + + if New_Node_Kind in N_Subexpr then + Set_Paren_Count (N, Par_Count); + end if; + end Change_Node; + + ----------------------- + -- Comes_From_Source -- + ----------------------- + + function Comes_From_Source (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Comes_From_Source; + end Comes_From_Source; + + ---------------- + -- Convention -- + ---------------- + + function Convention (E : Entity_Id) return Convention_Id is + begin + pragma Assert (Nkind (E) in N_Entity); + return To_Flag_Word (Nodes.Table (E + 2).Field12).Convention; + end Convention; + + --------------- + -- Copy_Node -- + --------------- + + procedure Copy_Node (Source : Node_Id; Destination : Node_Id) is + Save_In_List : constant Boolean := Nodes.Table (Destination).In_List; + Save_Link : constant Union_Id := Nodes.Table (Destination).Link; + + begin + Nodes.Table (Destination) := Nodes.Table (Source); + Nodes.Table (Destination).In_List := Save_In_List; + Nodes.Table (Destination).Link := Save_Link; + + -- Specifically set Paren_Count to make sure auxiliary table entry + -- gets correctly made if the parentheses count is at the max value. + + if Nkind (Destination) in N_Subexpr then + Set_Paren_Count (Destination, Paren_Count (Source)); + end if; + + -- Deal with copying extension nodes if present + + if Has_Extension (Source) then + pragma Assert (Has_Extension (Destination)); + Nodes.Table (Destination + 1) := Nodes.Table (Source + 1); + Nodes.Table (Destination + 2) := Nodes.Table (Source + 2); + Nodes.Table (Destination + 3) := Nodes.Table (Source + 3); + Nodes.Table (Destination + 4) := Nodes.Table (Source + 4); + + else + pragma Assert (not Has_Extension (Source)); + null; + end if; + end Copy_Node; + + ------------------------ + -- Copy_Separate_Tree -- + ------------------------ + + function Copy_Separate_Tree (Source : Node_Id) return Node_Id is + New_Id : Node_Id; + + function Copy_Entity (E : Entity_Id) return Entity_Id; + -- Copy Entity, copying only the Ekind and Chars fields + + function Copy_List (List : List_Id) return List_Id; + -- Copy list + + function Possible_Copy (Field : Union_Id) return Union_Id; + -- Given a field, returns a copy of the node or list if its parent + -- is the current source node, and otherwise returns the input + + ----------------- + -- Copy_Entity -- + ----------------- + + function Copy_Entity (E : Entity_Id) return Entity_Id is + New_Ent : Entity_Id; + + begin + case N_Entity (Nkind (E)) is + when N_Defining_Identifier => + New_Ent := New_Entity (N_Defining_Identifier, Sloc (E)); + + when N_Defining_Character_Literal => + New_Ent := New_Entity (N_Defining_Character_Literal, Sloc (E)); + + when N_Defining_Operator_Symbol => + New_Ent := New_Entity (N_Defining_Operator_Symbol, Sloc (E)); + end case; + + Set_Chars (New_Ent, Chars (E)); + return New_Ent; + end Copy_Entity; + + --------------- + -- Copy_List -- + --------------- + + function Copy_List (List : List_Id) return List_Id is + NL : List_Id; + E : Node_Id; + + begin + if List = No_List then + return No_List; + + else + NL := New_List; + + E := First (List); + while Present (E) loop + if Has_Extension (E) then + Append (Copy_Entity (E), NL); + else + Append (Copy_Separate_Tree (E), NL); + end if; + + Next (E); + end loop; + + return NL; + end if; + end Copy_List; + + ------------------- + -- Possible_Copy -- + ------------------- + + function Possible_Copy (Field : Union_Id) return Union_Id is + New_N : Union_Id; + + begin + if Field in Node_Range then + New_N := Union_Id (Copy_Separate_Tree (Node_Id (Field))); + + if Parent (Node_Id (Field)) = Source then + Set_Parent (Node_Id (New_N), New_Id); + end if; + + return New_N; + + elsif Field in List_Range then + New_N := Union_Id (Copy_List (List_Id (Field))); + + if Parent (List_Id (Field)) = Source then + Set_Parent (List_Id (New_N), New_Id); + end if; + + return New_N; + + else + return Field; + end if; + end Possible_Copy; + + -- Start of processing for Copy_Separate_Tree + + begin + if Source <= Empty_Or_Error then + return Source; + + elsif Has_Extension (Source) then + return Copy_Entity (Source); + + else + New_Id := New_Copy (Source); + + -- Recursively copy descendents + + Set_Field1 (New_Id, Possible_Copy (Field1 (New_Id))); + Set_Field2 (New_Id, Possible_Copy (Field2 (New_Id))); + Set_Field3 (New_Id, Possible_Copy (Field3 (New_Id))); + Set_Field4 (New_Id, Possible_Copy (Field4 (New_Id))); + Set_Field5 (New_Id, Possible_Copy (Field5 (New_Id))); + + -- Set Entity field to Empty + -- Why is this done??? and why is it always right to do it??? + + if Nkind (New_Id) in N_Has_Entity + or else Nkind (New_Id) = N_Freeze_Entity + then + Set_Entity (New_Id, Empty); + end if; + + -- All done, return copied node + + return New_Id; + end if; + end Copy_Separate_Tree; + + ----------- + -- Ekind -- + ----------- + + function Ekind (E : Entity_Id) return Entity_Kind is + begin + pragma Assert (Nkind (E) in N_Entity); + return N_To_E (Nodes.Table (E + 1).Nkind); + end Ekind; + + -------------- + -- Ekind_In -- + -------------- + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind) return Boolean + is + begin + return T = V1 or else + T = V2; + end Ekind_In; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3; + end Ekind_In; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4; + end Ekind_In; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4 or else + T = V5; + end Ekind_In; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind; + V6 : Entity_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4 or else + T = V5 or else + T = V6; + end Ekind_In; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind) return Boolean + is + begin + return Ekind_In (Ekind (E), V1, V2); + end Ekind_In; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind) return Boolean + is + begin + return Ekind_In (Ekind (E), V1, V2, V3); + end Ekind_In; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind) return Boolean + is + begin + return Ekind_In (Ekind (E), V1, V2, V3, V4); + end Ekind_In; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind) return Boolean + is + begin + return Ekind_In (Ekind (E), V1, V2, V3, V4, V5); + end Ekind_In; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind; + V6 : Entity_Kind) return Boolean + is + begin + return Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6); + end Ekind_In; + + ------------------------ + -- Set_Reporting_Proc -- + ------------------------ + + procedure Set_Reporting_Proc (P : Report_Proc) is + begin + pragma Assert (Reporting_Proc = null); + Reporting_Proc := P; + end Set_Reporting_Proc; + + ------------------ + -- Error_Posted -- + ------------------ + + function Error_Posted (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Error_Posted; + end Error_Posted; + + ----------------------- + -- Exchange_Entities -- + ----------------------- + + procedure Exchange_Entities (E1 : Entity_Id; E2 : Entity_Id) is + Temp_Ent : Node_Record; + + begin + pragma Assert (Has_Extension (E1) + and then Has_Extension (E2) + and then not Nodes.Table (E1).In_List + and then not Nodes.Table (E2).In_List); + + -- Exchange the contents of the two entities + + Temp_Ent := Nodes.Table (E1); + Nodes.Table (E1) := Nodes.Table (E2); + Nodes.Table (E2) := Temp_Ent; + Temp_Ent := Nodes.Table (E1 + 1); + Nodes.Table (E1 + 1) := Nodes.Table (E2 + 1); + Nodes.Table (E2 + 1) := Temp_Ent; + Temp_Ent := Nodes.Table (E1 + 2); + Nodes.Table (E1 + 2) := Nodes.Table (E2 + 2); + Nodes.Table (E2 + 2) := Temp_Ent; + Temp_Ent := Nodes.Table (E1 + 3); + Nodes.Table (E1 + 3) := Nodes.Table (E2 + 3); + Nodes.Table (E2 + 3) := Temp_Ent; + Temp_Ent := Nodes.Table (E1 + 4); + Nodes.Table (E1 + 4) := Nodes.Table (E2 + 4); + Nodes.Table (E2 + 4) := Temp_Ent; + + -- That exchange exchanged the parent pointers as well, which is what + -- we want, but we need to patch up the defining identifier pointers + -- in the parent nodes (the child pointers) to match this switch + -- unless for Implicit types entities which have no parent, in which + -- case we don't do anything otherwise we won't be able to revert back + -- to the original situation. + + -- Shouldn't this use Is_Itype instead of the Parent test + + if Present (Parent (E1)) and then Present (Parent (E2)) then + Set_Defining_Identifier (Parent (E1), E1); + Set_Defining_Identifier (Parent (E2), E2); + end if; + end Exchange_Entities; + + ----------------- + -- Extend_Node -- + ----------------- + + function Extend_Node (Node : Node_Id) return Entity_Id is + Result : Entity_Id; + + procedure Debug_Extend_Node; + pragma Inline (Debug_Extend_Node); + -- Debug routine for debug flag N + + ----------------------- + -- Debug_Extend_Node -- + ----------------------- + + procedure Debug_Extend_Node is + begin + if Debug_Flag_N then + Write_Str ("Extend node "); + Write_Int (Int (Node)); + + if Result = Node then + Write_Str (" in place"); + else + Write_Str (" copied to "); + Write_Int (Int (Result)); + end if; + + -- Write_Eol; + end if; + end Debug_Extend_Node; + + -- Start of processing for Extend_Node + + begin + pragma Assert (not (Has_Extension (Node))); + Result := Allocate_Initialize_Node (Node, With_Extension => True); + pragma Debug (Debug_Extend_Node); + return Result; + end Extend_Node; + + ----------------- + -- Fix_Parents -- + ----------------- + + procedure Fix_Parents (Ref_Node, Fix_Node : Node_Id) is + + procedure Fix_Parent (Field : Union_Id); + -- Fixup one parent pointer. Field is checked to see if it points to + -- a node, list, or element list that has a parent that points to + -- Ref_Node. If so, the parent is reset to point to Fix_Node. + + ---------------- + -- Fix_Parent -- + ---------------- + + procedure Fix_Parent (Field : Union_Id) is + begin + -- Fix parent of node that is referenced by Field. Note that we must + -- exclude the case where the node is a member of a list, because in + -- this case the parent is the parent of the list. + + if Field in Node_Range + and then Present (Node_Id (Field)) + and then not Nodes.Table (Node_Id (Field)).In_List + and then Parent (Node_Id (Field)) = Ref_Node + then + Set_Parent (Node_Id (Field), Fix_Node); + + -- Fix parent of list that is referenced by Field + + elsif Field in List_Range + and then Present (List_Id (Field)) + and then Parent (List_Id (Field)) = Ref_Node + then + Set_Parent (List_Id (Field), Fix_Node); + end if; + end Fix_Parent; + + -- Start of processing for Fix_Parents + + begin + Fix_Parent (Field1 (Fix_Node)); + Fix_Parent (Field2 (Fix_Node)); + Fix_Parent (Field3 (Fix_Node)); + Fix_Parent (Field4 (Fix_Node)); + Fix_Parent (Field5 (Fix_Node)); + end Fix_Parents; + + ----------------------------------- + -- Get_Comes_From_Source_Default -- + ----------------------------------- + + function Get_Comes_From_Source_Default return Boolean is + begin + return Default_Node.Comes_From_Source; + end Get_Comes_From_Source_Default; + + ----------------- + -- Has_Aspects -- + ----------------- + + function Has_Aspects (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Has_Aspects; + end Has_Aspects; + + ------------------- + -- Has_Extension -- + ------------------- + + function Has_Extension (N : Node_Id) return Boolean is + begin + return N < Nodes.Last and then Nodes.Table (N + 1).Is_Extension; + end Has_Extension; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + Dummy : Node_Id; + pragma Warnings (Off, Dummy); + + begin + Node_Count := 0; + Atree_Private_Part.Nodes.Init; + Orig_Nodes.Init; + Paren_Counts.Init; + + -- Allocate Empty node + + Dummy := New_Node (N_Empty, No_Location); + Set_Name1 (Empty, No_Name); + + -- Allocate Error node, and set Error_Posted, since we certainly + -- only generate an Error node if we do post some kind of error! + + Dummy := New_Node (N_Error, No_Location); + Set_Name1 (Error, Error_Name); + Set_Error_Posted (Error, True); + end Initialize; + + -------------------------- + -- Is_Rewrite_Insertion -- + -------------------------- + + function Is_Rewrite_Insertion (Node : Node_Id) return Boolean is + begin + return Nodes.Table (Node).Rewrite_Ins; + end Is_Rewrite_Insertion; + + ----------------------------- + -- Is_Rewrite_Substitution -- + ----------------------------- + + function Is_Rewrite_Substitution (Node : Node_Id) return Boolean is + begin + return Orig_Nodes.Table (Node) /= Node; + end Is_Rewrite_Substitution; + + ------------------ + -- Last_Node_Id -- + ------------------ + + function Last_Node_Id return Node_Id is + begin + return Nodes.Last; + end Last_Node_Id; + + ---------- + -- Lock -- + ---------- + + procedure Lock is + begin + Nodes.Locked := True; + Orig_Nodes.Locked := True; + Nodes.Release; + Orig_Nodes.Release; + end Lock; + + ---------------------------- + -- Mark_Rewrite_Insertion -- + ---------------------------- + + procedure Mark_Rewrite_Insertion (New_Node : Node_Id) is + begin + Nodes.Table (New_Node).Rewrite_Ins := True; + end Mark_Rewrite_Insertion; + + -------------- + -- New_Copy -- + -------------- + + function New_Copy (Source : Node_Id) return Node_Id is + New_Id : Node_Id := Source; + + begin + if Source > Empty_Or_Error then + New_Id := Allocate_Initialize_Node (Source, Has_Extension (Source)); + + Nodes.Table (New_Id).Link := Empty_List_Or_Node; + Nodes.Table (New_Id).In_List := False; + + -- If the original is marked as a rewrite insertion, then unmark + -- the copy, since we inserted the original, not the copy. + + Nodes.Table (New_Id).Rewrite_Ins := False; + pragma Debug (New_Node_Debugging_Output (New_Id)); + + -- Always clear Has_Aspects, the caller must take care of copying + -- aspects if this is required for the particular situation. + + Set_Has_Aspects (New_Id, False); + end if; + + return New_Id; + end New_Copy; + + ---------------- + -- New_Entity -- + ---------------- + + function New_Entity + (New_Node_Kind : Node_Kind; + New_Sloc : Source_Ptr) return Entity_Id + is + Ent : Entity_Id; + + begin + pragma Assert (New_Node_Kind in N_Entity); + + Ent := Allocate_Initialize_Node (Empty, With_Extension => True); + + -- If this is a node with a real location and we are generating + -- source nodes, then reset Current_Error_Node. This is useful + -- if we bomb during parsing to get a error location for the bomb. + + if Default_Node.Comes_From_Source and then New_Sloc > No_Location then + Current_Error_Node := Ent; + end if; + + Nodes.Table (Ent).Nkind := New_Node_Kind; + Nodes.Table (Ent).Sloc := New_Sloc; + pragma Debug (New_Node_Debugging_Output (Ent)); + + return Ent; + end New_Entity; + + -------------- + -- New_Node -- + -------------- + + function New_Node + (New_Node_Kind : Node_Kind; + New_Sloc : Source_Ptr) return Node_Id + is + Nod : Node_Id; + + begin + pragma Assert (New_Node_Kind not in N_Entity); + Nod := Allocate_Initialize_Node (Empty, With_Extension => False); + Nodes.Table (Nod).Nkind := New_Node_Kind; + Nodes.Table (Nod).Sloc := New_Sloc; + pragma Debug (New_Node_Debugging_Output (Nod)); + + -- If this is a node with a real location and we are generating source + -- nodes, then reset Current_Error_Node. This is useful if we bomb + -- during parsing to get an error location for the bomb. + + if Default_Node.Comes_From_Source and then New_Sloc > No_Location then + Current_Error_Node := Nod; + end if; + + return Nod; + end New_Node; + + ------------------------- + -- New_Node_Breakpoint -- + ------------------------- + + procedure nn is + begin + Write_Str ("Watched node "); + Write_Int (Int (Watch_Node)); + Write_Str (" created"); + Write_Eol; + end nn; + + ------------------------------- + -- New_Node_Debugging_Output -- + ------------------------------- + + procedure nnd (N : Node_Id) is + Node_Is_Watched : constant Boolean := N = Watch_Node; + + begin + if Debug_Flag_N or else Node_Is_Watched then + Node_Debug_Output ("Allocate", N); + + if Node_Is_Watched then + New_Node_Breakpoint; + end if; + end if; + end nnd; + + ----------- + -- Nkind -- + ----------- + + function Nkind (N : Node_Id) return Node_Kind is + begin + return Nodes.Table (N).Nkind; + end Nkind; + + -------------- + -- Nkind_In -- + -------------- + + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind) return Boolean + is + begin + return Nkind_In (Nkind (N), V1, V2); + end Nkind_In; + + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind) return Boolean + is + begin + return Nkind_In (Nkind (N), V1, V2, V3); + end Nkind_In; + + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind) return Boolean + is + begin + return Nkind_In (Nkind (N), V1, V2, V3, V4); + end Nkind_In; + + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind) return Boolean + is + begin + return Nkind_In (Nkind (N), V1, V2, V3, V4, V5); + end Nkind_In; + + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind) return Boolean + is + begin + return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6); + end Nkind_In; + + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind; + V7 : Node_Kind) return Boolean + is + begin + return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7); + end Nkind_In; + + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind; + V7 : Node_Kind; + V8 : Node_Kind) return Boolean + is + begin + return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7, V8); + end Nkind_In; + + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind; + V7 : Node_Kind; + V8 : Node_Kind; + V9 : Node_Kind) return Boolean + is + begin + return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7, V8, V9); + end Nkind_In; + + -------- + -- No -- + -------- + + function No (N : Node_Id) return Boolean is + begin + return N = Empty; + end No; + + ----------------------- + -- Node_Debug_Output -- + ----------------------- + + procedure Node_Debug_Output (Op : String; N : Node_Id) is + begin + Write_Str (Op); + + if Nkind (N) in N_Entity then + Write_Str (" entity"); + else + Write_Str (" node"); + end if; + + Write_Str (" Id = "); + Write_Int (Int (N)); + Write_Str (" "); + Write_Location (Sloc (N)); + Write_Str (" "); + Write_Str (Node_Kind'Image (Nkind (N))); + Write_Eol; + end Node_Debug_Output; + + ------------------- + -- Nodes_Address -- + ------------------- + + function Nodes_Address return System.Address is + begin + return Nodes.Table (First_Node_Id)'Address; + end Nodes_Address; + + --------------- + -- Num_Nodes -- + --------------- + + function Num_Nodes return Nat is + begin + return Node_Count; + end Num_Nodes; + + ------------------- + -- Original_Node -- + ------------------- + + function Original_Node (Node : Node_Id) return Node_Id is + begin + return Orig_Nodes.Table (Node); + end Original_Node; + + ----------------- + -- Paren_Count -- + ----------------- + + function Paren_Count (N : Node_Id) return Nat is + C : Nat := 0; + + begin + pragma Assert (N <= Nodes.Last); + + if Nodes.Table (N).Pflag1 then + C := C + 1; + end if; + + if Nodes.Table (N).Pflag2 then + C := C + 2; + end if; + + -- Value of 0,1,2 returned as is + + if C <= 2 then + return C; + + -- Value of 3 means we search the table, and we must find an entry + + else + for J in Paren_Counts.First .. Paren_Counts.Last loop + if N = Paren_Counts.Table (J).Nod then + return Paren_Counts.Table (J).Count; + end if; + end loop; + + raise Program_Error; + end if; + end Paren_Count; + + ------------ + -- Parent -- + ------------ + + function Parent (N : Node_Id) return Node_Id is + begin + if Is_List_Member (N) then + return Parent (List_Containing (N)); + else + return Node_Id (Nodes.Table (N).Link); + end if; + end Parent; + + ------------- + -- Present -- + ------------- + + function Present (N : Node_Id) return Boolean is + begin + return N /= Empty; + end Present; + + -------------------------------- + -- Preserve_Comes_From_Source -- + -------------------------------- + + procedure Preserve_Comes_From_Source (NewN, OldN : Node_Id) is + begin + Nodes.Table (NewN).Comes_From_Source := + Nodes.Table (OldN).Comes_From_Source; + end Preserve_Comes_From_Source; + + ------------------- + -- Relocate_Node -- + ------------------- + + function Relocate_Node (Source : Node_Id) return Node_Id is + New_Node : Node_Id; + + begin + if No (Source) then + return Empty; + end if; + + New_Node := New_Copy (Source); + Fix_Parents (Ref_Node => Source, Fix_Node => New_Node); + + -- We now set the parent of the new node to be the same as the + -- parent of the source. Almost always this parent will be + -- replaced by a new value when the relocated node is reattached + -- to the tree, but by doing it now, we ensure that this node is + -- not even temporarily disconnected from the tree. Note that this + -- does not happen free, because in the list case, the parent does + -- not get set. + + Set_Parent (New_Node, Parent (Source)); + + -- If the node being relocated was a rewriting of some original + -- node, then the relocated node has the same original node. + + if Orig_Nodes.Table (Source) /= Source then + Orig_Nodes.Table (New_Node) := Orig_Nodes.Table (Source); + end if; + + return New_Node; + end Relocate_Node; + + ------------- + -- Replace -- + ------------- + + procedure Replace (Old_Node, New_Node : Node_Id) is + Old_Post : constant Boolean := Nodes.Table (Old_Node).Error_Posted; + Old_HasA : constant Boolean := Nodes.Table (Old_Node).Has_Aspects; + Old_CFS : constant Boolean := Nodes.Table (Old_Node).Comes_From_Source; + + begin + pragma Assert + (not Has_Extension (Old_Node) + and not Has_Extension (New_Node) + and not Nodes.Table (New_Node).In_List); + + -- Do copy, preserving link and in list status and required flags + + Copy_Node (Source => New_Node, Destination => Old_Node); + Nodes.Table (Old_Node).Comes_From_Source := Old_CFS; + Nodes.Table (Old_Node).Error_Posted := Old_Post; + Nodes.Table (Old_Node).Has_Aspects := Old_HasA; + + -- Fix parents of substituted node, since it has changed identity + + Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node); + + -- Since we are doing a replace, we assume that the original node + -- is intended to become the new replaced node. The call would be + -- to Rewrite if there were an intention to save the original node. + + Orig_Nodes.Table (Old_Node) := Old_Node; + + -- Invoke the reporting procedure (if available) + + if Reporting_Proc /= null then + Reporting_Proc.all (Target => Old_Node, Source => New_Node); + end if; + end Replace; + + ------------- + -- Rewrite -- + ------------- + + procedure Rewrite (Old_Node, New_Node : Node_Id) is + Old_Error_P : constant Boolean := Nodes.Table (Old_Node).Error_Posted; + -- This field is always preserved in the new node + + Old_Has_Aspects : constant Boolean := Nodes.Table (Old_Node).Has_Aspects; + -- This field is always preserved in the new node + + Old_Paren_Count : Nat; + Old_Must_Not_Freeze : Boolean; + -- These fields are preserved in the new node only if the new node + -- and the old node are both subexpression nodes. + + -- Note: it is a violation of abstraction levels for Must_Not_Freeze + -- to be referenced like this. ??? + + Sav_Node : Node_Id; + + begin + pragma Assert + (not Has_Extension (Old_Node) + and not Has_Extension (New_Node) + and not Nodes.Table (New_Node).In_List); + pragma Debug (Rewrite_Debugging_Output (Old_Node, New_Node)); + + if Nkind (Old_Node) in N_Subexpr then + Old_Paren_Count := Paren_Count (Old_Node); + Old_Must_Not_Freeze := Must_Not_Freeze (Old_Node); + else + Old_Paren_Count := 0; + Old_Must_Not_Freeze := False; + end if; + + -- Allocate a new node, to be used to preserve the original contents + -- of the Old_Node, for possible later retrival by Original_Node and + -- make an entry in the Orig_Nodes table. This is only done if we have + -- not already rewritten the node, as indicated by an Orig_Nodes entry + -- that does not reference the Old_Node. + + if Orig_Nodes.Table (Old_Node) = Old_Node then + Sav_Node := New_Copy (Old_Node); + Orig_Nodes.Table (Sav_Node) := Sav_Node; + Orig_Nodes.Table (Old_Node) := Sav_Node; + + -- Both the old and new copies of the node will share the same list + -- of aspect specifications if aspect specifications are present. + + if Has_Aspects (Sav_Node) then + Set_Has_Aspects (Sav_Node, False); + Set_Aspect_Specifications + (Sav_Node, Aspect_Specifications (Old_Node)); + end if; + end if; + + -- Copy substitute node into place, preserving old fields as required + + Copy_Node (Source => New_Node, Destination => Old_Node); + Nodes.Table (Old_Node).Error_Posted := Old_Error_P; + Nodes.Table (Old_Node).Has_Aspects := Old_Has_Aspects; + + if Nkind (New_Node) in N_Subexpr then + Set_Paren_Count (Old_Node, Old_Paren_Count); + Set_Must_Not_Freeze (Old_Node, Old_Must_Not_Freeze); + end if; + + Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node); + + -- Invoke the reporting procedure (if available) + + if Reporting_Proc /= null then + Reporting_Proc.all (Target => Old_Node, Source => New_Node); + end if; + end Rewrite; + + ------------------------- + -- Rewrite_Breakpoint -- + ------------------------- + + procedure rr is + begin + Write_Str ("Watched node "); + Write_Int (Int (Watch_Node)); + Write_Str (" rewritten"); + Write_Eol; + end rr; + + ------------------------------ + -- Rewrite_Debugging_Output -- + ------------------------------ + + procedure rrd (Old_Node, New_Node : Node_Id) is + Node_Is_Watched : constant Boolean := Old_Node = Watch_Node; + + begin + if Debug_Flag_N or else Node_Is_Watched then + Node_Debug_Output ("Rewrite", Old_Node); + Node_Debug_Output ("into", New_Node); + + if Node_Is_Watched then + Rewrite_Breakpoint; + end if; + end if; + end rrd; + + ------------------ + -- Set_Analyzed -- + ------------------ + + procedure Set_Analyzed (N : Node_Id; Val : Boolean := True) is + begin + Nodes.Table (N).Analyzed := Val; + end Set_Analyzed; + + --------------------------- + -- Set_Comes_From_Source -- + --------------------------- + + procedure Set_Comes_From_Source (N : Node_Id; Val : Boolean) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Comes_From_Source := Val; + end Set_Comes_From_Source; + + ----------------------------------- + -- Set_Comes_From_Source_Default -- + ----------------------------------- + + procedure Set_Comes_From_Source_Default (Default : Boolean) is + begin + Default_Node.Comes_From_Source := Default; + end Set_Comes_From_Source_Default; + + --------------- + -- Set_Ekind -- + --------------- + + procedure Set_Ekind (E : Entity_Id; Val : Entity_Kind) is + begin + pragma Assert (Nkind (E) in N_Entity); + Nodes.Table (E + 1).Nkind := E_To_N (Val); + end Set_Ekind; + + ---------------------- + -- Set_Error_Posted -- + ---------------------- + + procedure Set_Error_Posted (N : Node_Id; Val : Boolean := True) is + begin + Nodes.Table (N).Error_Posted := Val; + end Set_Error_Posted; + + --------------------- + -- Set_Has_Aspects -- + --------------------- + + procedure Set_Has_Aspects (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Has_Aspects := Val; + end Set_Has_Aspects; + + --------------------- + -- Set_Paren_Count -- + --------------------- + + procedure Set_Paren_Count (N : Node_Id; Val : Nat) is + begin + pragma Assert (Nkind (N) in N_Subexpr); + + -- Value of 0,1,2 stored as is + + if Val <= 2 then + Nodes.Table (N).Pflag1 := (Val mod 2 /= 0); + Nodes.Table (N).Pflag2 := (Val = 2); + + -- Value of 3 or greater stores 3 in node and makes table entry + + else + Nodes.Table (N).Pflag1 := True; + Nodes.Table (N).Pflag2 := True; + + for J in Paren_Counts.First .. Paren_Counts.Last loop + if N = Paren_Counts.Table (J).Nod then + Paren_Counts.Table (J).Count := Val; + return; + end if; + end loop; + + Paren_Counts.Append ((Nod => N, Count => Val)); + end if; + end Set_Paren_Count; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (not Nodes.Table (N).In_List); + Nodes.Table (N).Link := Union_Id (Val); + end Set_Parent; + + -------------- + -- Set_Sloc -- + -------------- + + procedure Set_Sloc (N : Node_Id; Val : Source_Ptr) is + begin + Nodes.Table (N).Sloc := Val; + end Set_Sloc; + + ---------- + -- Sloc -- + ---------- + + function Sloc (N : Node_Id) return Source_Ptr is + begin + return Nodes.Table (N).Sloc; + end Sloc; + + ------------------- + -- Traverse_Func -- + ------------------- + + function Traverse_Func (Node : Node_Id) return Traverse_Final_Result is + + function Traverse_Field + (Nod : Node_Id; + Fld : Union_Id; + FN : Field_Num) return Traverse_Final_Result; + -- Fld is one of the fields of Nod. If the field points to syntactic + -- node or list, then this node or list is traversed, and the result is + -- the result of this traversal. Otherwise a value of True is returned + -- with no processing. FN is the number of the field (1 .. 5). + + -------------------- + -- Traverse_Field -- + -------------------- + + function Traverse_Field + (Nod : Node_Id; + Fld : Union_Id; + FN : Field_Num) return Traverse_Final_Result + is + begin + if Fld = Union_Id (Empty) then + return OK; + + -- Descendent is a node + + elsif Fld in Node_Range then + + -- Traverse descendent that is syntactic subtree node + + if Is_Syntactic_Field (Nkind (Nod), FN) then + return Traverse_Func (Node_Id (Fld)); + + -- Node that is not a syntactic subtree + + else + return OK; + end if; + + -- Descendent is a list + + elsif Fld in List_Range then + + -- Traverse descendent that is a syntactic subtree list + + if Is_Syntactic_Field (Nkind (Nod), FN) then + declare + Elmt : Node_Id := First (List_Id (Fld)); + begin + while Present (Elmt) loop + if Traverse_Func (Elmt) = Abandon then + return Abandon; + else + Next (Elmt); + end if; + end loop; + + return OK; + end; + + -- List that is not a syntactic subtree + + else + return OK; + end if; + + -- Field was not a node or a list + + else + return OK; + end if; + end Traverse_Field; + + Cur_Node : Node_Id := Node; + + -- Start of processing for Traverse_Func + + begin + -- We walk Field2 last, and if it is a node, we eliminate the tail + -- recursion by jumping back to this label. This is because Field2 is + -- where the Left_Opnd field of N_Op_Concat is stored, and in practice + -- concatenations are sometimes deeply nested, as in X1&X2&...&XN. This + -- trick prevents us from running out of memory in that case. We don't + -- bother eliminating the tail recursion if Field2 is a list. + + <> + + case Process (Cur_Node) is + when Abandon => + return Abandon; + + when Skip => + return OK; + + when OK => + null; + + when OK_Orig => + Cur_Node := Original_Node (Cur_Node); + end case; + + if Traverse_Field (Cur_Node, Field1 (Cur_Node), 1) = Abandon + or else -- skip Field2 here + Traverse_Field (Cur_Node, Field3 (Cur_Node), 3) = Abandon + or else + Traverse_Field (Cur_Node, Field4 (Cur_Node), 4) = Abandon + or else + Traverse_Field (Cur_Node, Field5 (Cur_Node), 5) = Abandon + then + return Abandon; + end if; + + if Field2 (Cur_Node) not in Node_Range then + return Traverse_Field (Cur_Node, Field2 (Cur_Node), 2); + + elsif Is_Syntactic_Field (Nkind (Cur_Node), 2) + and then Field2 (Cur_Node) /= Empty_List_Or_Node + then + -- Here is the tail recursion step, we reset Cur_Node and jump back + -- to the start of the procedure, which has the same semantic effect + -- as a call. + + Cur_Node := Node_Id (Field2 (Cur_Node)); + goto Tail_Recurse; + end if; + + return OK; + end Traverse_Func; + + ------------------- + -- Traverse_Proc -- + ------------------- + + procedure Traverse_Proc (Node : Node_Id) is + function Traverse is new Traverse_Func (Process); + Discard : Traverse_Final_Result; + pragma Warnings (Off, Discard); + begin + Discard := Traverse (Node); + end Traverse_Proc; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + begin + Tree_Read_Int (Node_Count); + Nodes.Tree_Read; + Orig_Nodes.Tree_Read; + Paren_Counts.Tree_Read; + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + begin + Tree_Write_Int (Node_Count); + Nodes.Tree_Write; + Orig_Nodes.Tree_Write; + Paren_Counts.Tree_Write; + end Tree_Write; + + ------------------------------ + -- Unchecked Access Package -- + ------------------------------ + + package body Unchecked_Access is + + function Field1 (N : Node_Id) return Union_Id is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Field1; + end Field1; + + function Field2 (N : Node_Id) return Union_Id is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Field2; + end Field2; + + function Field3 (N : Node_Id) return Union_Id is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Field3; + end Field3; + + function Field4 (N : Node_Id) return Union_Id is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Field4; + end Field4; + + function Field5 (N : Node_Id) return Union_Id is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Field5; + end Field5; + + function Field6 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Field6; + end Field6; + + function Field7 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Field7; + end Field7; + + function Field8 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Field8; + end Field8; + + function Field9 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Field9; + end Field9; + + function Field10 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Field10; + end Field10; + + function Field11 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Field11; + end Field11; + + function Field12 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Field12; + end Field12; + + function Field13 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Field6; + end Field13; + + function Field14 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Field7; + end Field14; + + function Field15 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Field8; + end Field15; + + function Field16 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Field9; + end Field16; + + function Field17 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Field10; + end Field17; + + function Field18 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Field11; + end Field18; + + function Field19 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Field6; + end Field19; + + function Field20 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Field7; + end Field20; + + function Field21 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Field8; + end Field21; + + function Field22 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Field9; + end Field22; + + function Field23 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Field10; + end Field23; + + function Field24 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Field6; + end Field24; + + function Field25 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Field7; + end Field25; + + function Field26 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Field8; + end Field26; + + function Field27 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Field9; + end Field27; + + function Field28 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Field10; + end Field28; + + function Field29 (N : Node_Id) return Union_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Field11; + end Field29; + + function Node1 (N : Node_Id) return Node_Id is + begin + pragma Assert (N <= Nodes.Last); + return Node_Id (Nodes.Table (N).Field1); + end Node1; + + function Node2 (N : Node_Id) return Node_Id is + begin + pragma Assert (N <= Nodes.Last); + return Node_Id (Nodes.Table (N).Field2); + end Node2; + + function Node3 (N : Node_Id) return Node_Id is + begin + pragma Assert (N <= Nodes.Last); + return Node_Id (Nodes.Table (N).Field3); + end Node3; + + function Node4 (N : Node_Id) return Node_Id is + begin + pragma Assert (N <= Nodes.Last); + return Node_Id (Nodes.Table (N).Field4); + end Node4; + + function Node5 (N : Node_Id) return Node_Id is + begin + pragma Assert (N <= Nodes.Last); + return Node_Id (Nodes.Table (N).Field5); + end Node5; + + function Node6 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 1).Field6); + end Node6; + + function Node7 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 1).Field7); + end Node7; + + function Node8 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 1).Field8); + end Node8; + + function Node9 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 1).Field9); + end Node9; + + function Node10 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 1).Field10); + end Node10; + + function Node11 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 1).Field11); + end Node11; + + function Node12 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 1).Field12); + end Node12; + + function Node13 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 2).Field6); + end Node13; + + function Node14 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 2).Field7); + end Node14; + + function Node15 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 2).Field8); + end Node15; + + function Node16 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 2).Field9); + end Node16; + + function Node17 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 2).Field10); + end Node17; + + function Node18 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 2).Field11); + end Node18; + + function Node19 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 3).Field6); + end Node19; + + function Node20 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 3).Field7); + end Node20; + + function Node21 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 3).Field8); + end Node21; + + function Node22 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 3).Field9); + end Node22; + + function Node23 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 3).Field10); + end Node23; + + function Node24 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 4).Field6); + end Node24; + + function Node25 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 4).Field7); + end Node25; + + function Node26 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 4).Field8); + end Node26; + + function Node27 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 4).Field9); + end Node27; + + function Node28 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 4).Field10); + end Node28; + + function Node29 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 4).Field11); + end Node29; + + function List1 (N : Node_Id) return List_Id is + begin + pragma Assert (N <= Nodes.Last); + return List_Id (Nodes.Table (N).Field1); + end List1; + + function List2 (N : Node_Id) return List_Id is + begin + pragma Assert (N <= Nodes.Last); + return List_Id (Nodes.Table (N).Field2); + end List2; + + function List3 (N : Node_Id) return List_Id is + begin + pragma Assert (N <= Nodes.Last); + return List_Id (Nodes.Table (N).Field3); + end List3; + + function List4 (N : Node_Id) return List_Id is + begin + pragma Assert (N <= Nodes.Last); + return List_Id (Nodes.Table (N).Field4); + end List4; + + function List5 (N : Node_Id) return List_Id is + begin + pragma Assert (N <= Nodes.Last); + return List_Id (Nodes.Table (N).Field5); + end List5; + + function List10 (N : Node_Id) return List_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return List_Id (Nodes.Table (N + 1).Field10); + end List10; + + function List14 (N : Node_Id) return List_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return List_Id (Nodes.Table (N + 2).Field7); + end List14; + + function List25 (N : Node_Id) return List_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return List_Id (Nodes.Table (N + 4).Field7); + end List25; + + function Elist1 (N : Node_Id) return Elist_Id is + pragma Assert (N <= Nodes.Last); + Value : constant Union_Id := Nodes.Table (N).Field1; + begin + if Value = 0 then + return No_Elist; + else + return Elist_Id (Value); + end if; + end Elist1; + + function Elist2 (N : Node_Id) return Elist_Id is + pragma Assert (N <= Nodes.Last); + Value : constant Union_Id := Nodes.Table (N).Field2; + begin + if Value = 0 then + return No_Elist; + else + return Elist_Id (Value); + end if; + end Elist2; + + function Elist3 (N : Node_Id) return Elist_Id is + pragma Assert (N <= Nodes.Last); + Value : constant Union_Id := Nodes.Table (N).Field3; + begin + if Value = 0 then + return No_Elist; + else + return Elist_Id (Value); + end if; + end Elist3; + + function Elist4 (N : Node_Id) return Elist_Id is + pragma Assert (N <= Nodes.Last); + Value : constant Union_Id := Nodes.Table (N).Field4; + begin + if Value = 0 then + return No_Elist; + else + return Elist_Id (Value); + end if; + end Elist4; + + function Elist8 (N : Node_Id) return Elist_Id is + pragma Assert (Nkind (N) in N_Entity); + Value : constant Union_Id := Nodes.Table (N + 1).Field8; + begin + if Value = 0 then + return No_Elist; + else + return Elist_Id (Value); + end if; + end Elist8; + + function Elist10 (N : Node_Id) return Elist_Id is + pragma Assert (Nkind (N) in N_Entity); + Value : constant Union_Id := Nodes.Table (N + 1).Field10; + begin + if Value = 0 then + return No_Elist; + else + return Elist_Id (Value); + end if; + end Elist10; + + function Elist13 (N : Node_Id) return Elist_Id is + pragma Assert (Nkind (N) in N_Entity); + Value : constant Union_Id := Nodes.Table (N + 2).Field6; + begin + if Value = 0 then + return No_Elist; + else + return Elist_Id (Value); + end if; + end Elist13; + + function Elist15 (N : Node_Id) return Elist_Id is + pragma Assert (Nkind (N) in N_Entity); + Value : constant Union_Id := Nodes.Table (N + 2).Field8; + begin + if Value = 0 then + return No_Elist; + else + return Elist_Id (Value); + end if; + end Elist15; + + function Elist16 (N : Node_Id) return Elist_Id is + pragma Assert (Nkind (N) in N_Entity); + Value : constant Union_Id := Nodes.Table (N + 2).Field9; + begin + if Value = 0 then + return No_Elist; + else + return Elist_Id (Value); + end if; + end Elist16; + + function Elist18 (N : Node_Id) return Elist_Id is + pragma Assert (Nkind (N) in N_Entity); + Value : constant Union_Id := Nodes.Table (N + 2).Field11; + begin + if Value = 0 then + return No_Elist; + else + return Elist_Id (Value); + end if; + end Elist18; + + function Elist21 (N : Node_Id) return Elist_Id is + pragma Assert (Nkind (N) in N_Entity); + Value : constant Union_Id := Nodes.Table (N + 3).Field8; + begin + if Value = 0 then + return No_Elist; + else + return Elist_Id (Value); + end if; + end Elist21; + + function Elist23 (N : Node_Id) return Elist_Id is + pragma Assert (Nkind (N) in N_Entity); + Value : constant Union_Id := Nodes.Table (N + 3).Field10; + begin + if Value = 0 then + return No_Elist; + else + return Elist_Id (Value); + end if; + end Elist23; + + function Elist25 (N : Node_Id) return Elist_Id is + pragma Assert (Nkind (N) in N_Entity); + Value : constant Union_Id := Nodes.Table (N + 4).Field7; + begin + if Value = 0 then + return No_Elist; + else + return Elist_Id (Value); + end if; + end Elist25; + + function Elist26 (N : Node_Id) return Elist_Id is + pragma Assert (Nkind (N) in N_Entity); + Value : constant Union_Id := Nodes.Table (N + 4).Field8; + begin + if Value = 0 then + return No_Elist; + else + return Elist_Id (Value); + end if; + end Elist26; + + function Name1 (N : Node_Id) return Name_Id is + begin + pragma Assert (N <= Nodes.Last); + return Name_Id (Nodes.Table (N).Field1); + end Name1; + + function Name2 (N : Node_Id) return Name_Id is + begin + pragma Assert (N <= Nodes.Last); + return Name_Id (Nodes.Table (N).Field2); + end Name2; + + function Str3 (N : Node_Id) return String_Id is + begin + pragma Assert (N <= Nodes.Last); + return String_Id (Nodes.Table (N).Field3); + end Str3; + + function Uint2 (N : Node_Id) return Uint is + pragma Assert (N <= Nodes.Last); + U : constant Union_Id := Nodes.Table (N).Field2; + begin + if U = 0 then + return Uint_0; + else + return From_Union (U); + end if; + end Uint2; + + function Uint3 (N : Node_Id) return Uint is + pragma Assert (N <= Nodes.Last); + U : constant Union_Id := Nodes.Table (N).Field3; + begin + if U = 0 then + return Uint_0; + else + return From_Union (U); + end if; + end Uint3; + + function Uint4 (N : Node_Id) return Uint is + pragma Assert (N <= Nodes.Last); + U : constant Union_Id := Nodes.Table (N).Field4; + begin + if U = 0 then + return Uint_0; + else + return From_Union (U); + end if; + end Uint4; + + function Uint5 (N : Node_Id) return Uint is + pragma Assert (N <= Nodes.Last); + U : constant Union_Id := Nodes.Table (N).Field5; + begin + if U = 0 then + return Uint_0; + else + return From_Union (U); + end if; + end Uint5; + + function Uint8 (N : Node_Id) return Uint is + pragma Assert (Nkind (N) in N_Entity); + U : constant Union_Id := Nodes.Table (N + 1).Field8; + begin + if U = 0 then + return Uint_0; + else + return From_Union (U); + end if; + end Uint8; + + function Uint9 (N : Node_Id) return Uint is + pragma Assert (Nkind (N) in N_Entity); + U : constant Union_Id := Nodes.Table (N + 1).Field9; + begin + if U = 0 then + return Uint_0; + else + return From_Union (U); + end if; + end Uint9; + + function Uint10 (N : Node_Id) return Uint is + pragma Assert (Nkind (N) in N_Entity); + U : constant Union_Id := Nodes.Table (N + 1).Field10; + begin + if U = 0 then + return Uint_0; + else + return From_Union (U); + end if; + end Uint10; + + function Uint11 (N : Node_Id) return Uint is + pragma Assert (Nkind (N) in N_Entity); + U : constant Union_Id := Nodes.Table (N + 1).Field11; + begin + if U = 0 then + return Uint_0; + else + return From_Union (U); + end if; + end Uint11; + + function Uint12 (N : Node_Id) return Uint is + pragma Assert (Nkind (N) in N_Entity); + U : constant Union_Id := Nodes.Table (N + 1).Field12; + begin + if U = 0 then + return Uint_0; + else + return From_Union (U); + end if; + end Uint12; + + function Uint13 (N : Node_Id) return Uint is + pragma Assert (Nkind (N) in N_Entity); + U : constant Union_Id := Nodes.Table (N + 2).Field6; + begin + if U = 0 then + return Uint_0; + else + return From_Union (U); + end if; + end Uint13; + + function Uint14 (N : Node_Id) return Uint is + pragma Assert (Nkind (N) in N_Entity); + U : constant Union_Id := Nodes.Table (N + 2).Field7; + begin + if U = 0 then + return Uint_0; + else + return From_Union (U); + end if; + end Uint14; + + function Uint15 (N : Node_Id) return Uint is + pragma Assert (Nkind (N) in N_Entity); + U : constant Union_Id := Nodes.Table (N + 2).Field8; + begin + if U = 0 then + return Uint_0; + else + return From_Union (U); + end if; + end Uint15; + + function Uint16 (N : Node_Id) return Uint is + pragma Assert (Nkind (N) in N_Entity); + U : constant Union_Id := Nodes.Table (N + 2).Field9; + begin + if U = 0 then + return Uint_0; + else + return From_Union (U); + end if; + end Uint16; + + function Uint17 (N : Node_Id) return Uint is + pragma Assert (Nkind (N) in N_Entity); + U : constant Union_Id := Nodes.Table (N + 2).Field10; + begin + if U = 0 then + return Uint_0; + else + return From_Union (U); + end if; + end Uint17; + + function Uint22 (N : Node_Id) return Uint is + pragma Assert (Nkind (N) in N_Entity); + U : constant Union_Id := Nodes.Table (N + 3).Field9; + begin + if U = 0 then + return Uint_0; + else + return From_Union (U); + end if; + end Uint22; + + function Ureal3 (N : Node_Id) return Ureal is + begin + pragma Assert (N <= Nodes.Last); + return From_Union (Nodes.Table (N).Field3); + end Ureal3; + + function Ureal18 (N : Node_Id) return Ureal is + begin + pragma Assert (Nkind (N) in N_Entity); + return From_Union (Nodes.Table (N + 2).Field11); + end Ureal18; + + function Ureal21 (N : Node_Id) return Ureal is + begin + pragma Assert (Nkind (N) in N_Entity); + return From_Union (Nodes.Table (N + 3).Field8); + end Ureal21; + + function Flag4 (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Flag4; + end Flag4; + + function Flag5 (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Flag5; + end Flag5; + + function Flag6 (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Flag6; + end Flag6; + + function Flag7 (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Flag7; + end Flag7; + + function Flag8 (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Flag8; + end Flag8; + + function Flag9 (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Flag9; + end Flag9; + + function Flag10 (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Flag10; + end Flag10; + + function Flag11 (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Flag11; + end Flag11; + + function Flag12 (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Flag12; + end Flag12; + + function Flag13 (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Flag13; + end Flag13; + + function Flag14 (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Flag14; + end Flag14; + + function Flag15 (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Flag15; + end Flag15; + + function Flag16 (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Flag16; + end Flag16; + + function Flag17 (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Flag17; + end Flag17; + + function Flag18 (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Flag18; + end Flag18; + + function Flag19 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).In_List; + end Flag19; + + function Flag20 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Has_Aspects; + end Flag20; + + function Flag21 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Rewrite_Ins; + end Flag21; + + function Flag22 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Analyzed; + end Flag22; + + function Flag23 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Comes_From_Source; + end Flag23; + + function Flag24 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Error_Posted; + end Flag24; + + function Flag25 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Flag4; + end Flag25; + + function Flag26 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Flag5; + end Flag26; + + function Flag27 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Flag6; + end Flag27; + + function Flag28 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Flag7; + end Flag28; + + function Flag29 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Flag8; + end Flag29; + + function Flag30 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Flag9; + end Flag30; + + function Flag31 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Flag10; + end Flag31; + + function Flag32 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Flag11; + end Flag32; + + function Flag33 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Flag12; + end Flag33; + + function Flag34 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Flag13; + end Flag34; + + function Flag35 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Flag14; + end Flag35; + + function Flag36 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Flag15; + end Flag36; + + function Flag37 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Flag16; + end Flag37; + + function Flag38 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Flag17; + end Flag38; + + function Flag39 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Flag18; + end Flag39; + + function Flag40 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).In_List; + end Flag40; + + function Flag41 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Has_Aspects; + end Flag41; + + function Flag42 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Rewrite_Ins; + end Flag42; + + function Flag43 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Analyzed; + end Flag43; + + function Flag44 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Comes_From_Source; + end Flag44; + + function Flag45 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Error_Posted; + end Flag45; + + function Flag46 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Flag4; + end Flag46; + + function Flag47 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Flag5; + end Flag47; + + function Flag48 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Flag6; + end Flag48; + + function Flag49 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Flag7; + end Flag49; + + function Flag50 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Flag8; + end Flag50; + + function Flag51 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Flag9; + end Flag51; + + function Flag52 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Flag10; + end Flag52; + + function Flag53 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Flag11; + end Flag53; + + function Flag54 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Flag12; + end Flag54; + + function Flag55 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Flag13; + end Flag55; + + function Flag56 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Flag14; + end Flag56; + + function Flag57 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Flag15; + end Flag57; + + function Flag58 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Flag16; + end Flag58; + + function Flag59 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Flag17; + end Flag59; + + function Flag60 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Flag18; + end Flag60; + + function Flag61 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Pflag1; + end Flag61; + + function Flag62 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 1).Pflag2; + end Flag62; + + function Flag63 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Pflag1; + end Flag63; + + function Flag64 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 2).Pflag2; + end Flag64; + + function Flag65 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag65; + end Flag65; + + function Flag66 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag66; + end Flag66; + + function Flag67 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag67; + end Flag67; + + function Flag68 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag68; + end Flag68; + + function Flag69 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag69; + end Flag69; + + function Flag70 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag70; + end Flag70; + + function Flag71 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag71; + end Flag71; + + function Flag72 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag72; + end Flag72; + + function Flag73 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag73; + end Flag73; + + function Flag74 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag74; + end Flag74; + + function Flag75 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag75; + end Flag75; + + function Flag76 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag76; + end Flag76; + + function Flag77 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag77; + end Flag77; + + function Flag78 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag78; + end Flag78; + + function Flag79 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag79; + end Flag79; + + function Flag80 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag80; + end Flag80; + + function Flag81 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag81; + end Flag81; + + function Flag82 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag82; + end Flag82; + + function Flag83 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag83; + end Flag83; + + function Flag84 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag84; + end Flag84; + + function Flag85 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag85; + end Flag85; + + function Flag86 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag86; + end Flag86; + + function Flag87 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag87; + end Flag87; + + function Flag88 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag88; + end Flag88; + + function Flag89 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag89; + end Flag89; + + function Flag90 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag90; + end Flag90; + + function Flag91 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag91; + end Flag91; + + function Flag92 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag92; + end Flag92; + + function Flag93 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag93; + end Flag93; + + function Flag94 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag94; + end Flag94; + + function Flag95 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag95; + end Flag95; + + function Flag96 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag96; + end Flag96; + + function Flag97 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag97; + end Flag97; + + function Flag98 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag98; + end Flag98; + + function Flag99 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag99; + end Flag99; + + function Flag100 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag100; + end Flag100; + + function Flag101 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag101; + end Flag101; + + function Flag102 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag102; + end Flag102; + + function Flag103 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag103; + end Flag103; + + function Flag104 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag104; + end Flag104; + + function Flag105 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag105; + end Flag105; + + function Flag106 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag106; + end Flag106; + + function Flag107 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag107; + end Flag107; + + function Flag108 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag108; + end Flag108; + + function Flag109 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag109; + end Flag109; + + function Flag110 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag110; + end Flag110; + + function Flag111 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag111; + end Flag111; + + function Flag112 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag112; + end Flag112; + + function Flag113 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag113; + end Flag113; + + function Flag114 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag114; + end Flag114; + + function Flag115 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag115; + end Flag115; + + function Flag116 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag116; + end Flag116; + + function Flag117 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag117; + end Flag117; + + function Flag118 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag118; + end Flag118; + + function Flag119 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag119; + end Flag119; + + function Flag120 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag120; + end Flag120; + + function Flag121 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag121; + end Flag121; + + function Flag122 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag122; + end Flag122; + + function Flag123 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag123; + end Flag123; + + function Flag124 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag124; + end Flag124; + + function Flag125 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag125; + end Flag125; + + function Flag126 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag126; + end Flag126; + + function Flag127 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag127; + end Flag127; + + function Flag128 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag128; + end Flag128; + + function Flag129 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).In_List; + end Flag129; + + function Flag130 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Has_Aspects; + end Flag130; + + function Flag131 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Rewrite_Ins; + end Flag131; + + function Flag132 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Analyzed; + end Flag132; + + function Flag133 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Comes_From_Source; + end Flag133; + + function Flag134 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Error_Posted; + end Flag134; + + function Flag135 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Flag4; + end Flag135; + + function Flag136 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Flag5; + end Flag136; + + function Flag137 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Flag6; + end Flag137; + + function Flag138 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Flag7; + end Flag138; + + function Flag139 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Flag8; + end Flag139; + + function Flag140 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Flag9; + end Flag140; + + function Flag141 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Flag10; + end Flag141; + + function Flag142 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Flag11; + end Flag142; + + function Flag143 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Flag12; + end Flag143; + + function Flag144 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Flag13; + end Flag144; + + function Flag145 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Flag14; + end Flag145; + + function Flag146 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Flag15; + end Flag146; + + function Flag147 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Flag16; + end Flag147; + + function Flag148 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Flag17; + end Flag148; + + function Flag149 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Flag18; + end Flag149; + + function Flag150 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Pflag1; + end Flag150; + + function Flag151 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 3).Pflag2; + end Flag151; + + function Flag152 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag152; + end Flag152; + + function Flag153 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag153; + end Flag153; + + function Flag154 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag154; + end Flag154; + + function Flag155 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag155; + end Flag155; + + function Flag156 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag156; + end Flag156; + + function Flag157 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag157; + end Flag157; + + function Flag158 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag158; + end Flag158; + + function Flag159 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag159; + end Flag159; + + function Flag160 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag160; + end Flag160; + + function Flag161 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag161; + end Flag161; + + function Flag162 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag162; + end Flag162; + + function Flag163 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag163; + end Flag163; + + function Flag164 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag164; + end Flag164; + + function Flag165 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag165; + end Flag165; + + function Flag166 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag166; + end Flag166; + + function Flag167 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag167; + end Flag167; + + function Flag168 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag168; + end Flag168; + + function Flag169 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag169; + end Flag169; + + function Flag170 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag170; + end Flag170; + + function Flag171 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag171; + end Flag171; + + function Flag172 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag172; + end Flag172; + + function Flag173 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag173; + end Flag173; + + function Flag174 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag174; + end Flag174; + + function Flag175 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag175; + end Flag175; + + function Flag176 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag176; + end Flag176; + + function Flag177 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag177; + end Flag177; + + function Flag178 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag178; + end Flag178; + + function Flag179 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag179; + end Flag179; + + function Flag180 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag180; + end Flag180; + + function Flag181 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag181; + end Flag181; + + function Flag182 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag182; + end Flag182; + + function Flag183 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag183; + end Flag183; + + function Flag184 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag184; + end Flag184; + + function Flag185 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag185; + end Flag185; + + function Flag186 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag186; + end Flag186; + + function Flag187 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag187; + end Flag187; + + function Flag188 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag188; + end Flag188; + + function Flag189 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag189; + end Flag189; + + function Flag190 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag190; + end Flag190; + + function Flag191 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag191; + end Flag191; + + function Flag192 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag192; + end Flag192; + + function Flag193 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag193; + end Flag193; + + function Flag194 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag194; + end Flag194; + + function Flag195 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag195; + end Flag195; + + function Flag196 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag196; + end Flag196; + + function Flag197 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag197; + end Flag197; + + function Flag198 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag198; + end Flag198; + + function Flag199 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag199; + end Flag199; + + function Flag200 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag200; + end Flag200; + + function Flag201 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag201; + end Flag201; + + function Flag202 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag202; + end Flag202; + + function Flag203 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag203; + end Flag203; + + function Flag204 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag204; + end Flag204; + + function Flag205 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag205; + end Flag205; + + function Flag206 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag206; + end Flag206; + + function Flag207 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag207; + end Flag207; + + function Flag208 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag208; + end Flag208; + + function Flag209 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag209; + end Flag209; + + function Flag210 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag210; + end Flag210; + + function Flag211 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag211; + end Flag211; + + function Flag212 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag212; + end Flag212; + + function Flag213 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag213; + end Flag213; + + function Flag214 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag214; + end Flag214; + + function Flag215 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag215; + end Flag215; + + function Flag216 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).In_List; + end Flag216; + + function Flag217 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Has_Aspects; + end Flag217; + + function Flag218 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Rewrite_Ins; + end Flag218; + + function Flag219 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Analyzed; + end Flag219; + + function Flag220 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Comes_From_Source; + end Flag220; + + function Flag221 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Error_Posted; + end Flag221; + + function Flag222 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Flag4; + end Flag222; + + function Flag223 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Flag5; + end Flag223; + + function Flag224 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Flag6; + end Flag224; + + function Flag225 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Flag7; + end Flag225; + + function Flag226 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Flag8; + end Flag226; + + function Flag227 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Flag9; + end Flag227; + + function Flag228 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Flag10; + end Flag228; + + function Flag229 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Flag11; + end Flag229; + + function Flag230 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Flag12; + end Flag230; + + function Flag231 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Flag13; + end Flag231; + + function Flag232 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Flag14; + end Flag232; + + function Flag233 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Flag15; + end Flag233; + + function Flag234 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Flag16; + end Flag234; + + function Flag235 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Flag17; + end Flag235; + + function Flag236 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Flag18; + end Flag236; + + function Flag237 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Pflag1; + end Flag237; + + function Flag238 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return Nodes.Table (N + 4).Pflag2; + end Flag238; + + function Flag239 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte2 (Nodes.Table (N + 3).Nkind).Flag239; + end Flag239; + + function Flag240 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte2 (Nodes.Table (N + 3).Nkind).Flag240; + end Flag240; + + function Flag241 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte2 (Nodes.Table (N + 3).Nkind).Flag241; + end Flag241; + + function Flag242 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte2 (Nodes.Table (N + 3).Nkind).Flag242; + end Flag242; + + function Flag243 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte2 (Nodes.Table (N + 3).Nkind).Flag243; + end Flag243; + + function Flag244 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte2 (Nodes.Table (N + 3).Nkind).Flag244; + end Flag244; + + function Flag245 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte2 (Nodes.Table (N + 3).Nkind).Flag245; + end Flag245; + + function Flag246 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte2 (Nodes.Table (N + 3).Nkind).Flag246; + end Flag246; + + function Flag247 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte3 (Nodes.Table (N + 4).Nkind).Flag247; + end Flag247; + + function Flag248 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte3 (Nodes.Table (N + 4).Nkind).Flag248; + end Flag248; + + function Flag249 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte3 (Nodes.Table (N + 4).Nkind).Flag249; + end Flag249; + + function Flag250 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte3 (Nodes.Table (N + 4).Nkind).Flag250; + end Flag250; + + function Flag251 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte3 (Nodes.Table (N + 4).Nkind).Flag251; + end Flag251; + + function Flag252 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte3 (Nodes.Table (N + 4).Nkind).Flag252; + end Flag252; + + function Flag253 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte3 (Nodes.Table (N + 4).Nkind).Flag253; + end Flag253; + + function Flag254 (N : Node_Id) return Boolean is + begin + pragma Assert (Nkind (N) in N_Entity); + return To_Flag_Byte3 (Nodes.Table (N + 4).Nkind).Flag254; + end Flag254; + + procedure Set_Nkind (N : Node_Id; Val : Node_Kind) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Nkind := Val; + end Set_Nkind; + + procedure Set_Field1 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Field1 := Val; + end Set_Field1; + + procedure Set_Field2 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Field2 := Val; + end Set_Field2; + + procedure Set_Field3 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Field3 := Val; + end Set_Field3; + + procedure Set_Field4 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Field4 := Val; + end Set_Field4; + + procedure Set_Field5 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Field5 := Val; + end Set_Field5; + + procedure Set_Field6 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Field6 := Val; + end Set_Field6; + + procedure Set_Field7 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Field7 := Val; + end Set_Field7; + + procedure Set_Field8 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Field8 := Val; + end Set_Field8; + + procedure Set_Field9 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Field9 := Val; + end Set_Field9; + + procedure Set_Field10 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Field10 := Val; + end Set_Field10; + + procedure Set_Field11 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Field11 := Val; + end Set_Field11; + + procedure Set_Field12 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Field12 := Val; + end Set_Field12; + + procedure Set_Field13 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Field6 := Val; + end Set_Field13; + + procedure Set_Field14 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Field7 := Val; + end Set_Field14; + + procedure Set_Field15 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Field8 := Val; + end Set_Field15; + + procedure Set_Field16 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Field9 := Val; + end Set_Field16; + + procedure Set_Field17 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Field10 := Val; + end Set_Field17; + + procedure Set_Field18 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Field11 := Val; + end Set_Field18; + + procedure Set_Field19 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Field6 := Val; + end Set_Field19; + + procedure Set_Field20 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Field7 := Val; + end Set_Field20; + + procedure Set_Field21 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Field8 := Val; + end Set_Field21; + + procedure Set_Field22 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Field9 := Val; + end Set_Field22; + + procedure Set_Field23 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Field10 := Val; + end Set_Field23; + + procedure Set_Field24 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Field6 := Val; + end Set_Field24; + + procedure Set_Field25 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Field7 := Val; + end Set_Field25; + + procedure Set_Field26 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Field8 := Val; + end Set_Field26; + + procedure Set_Field27 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Field9 := Val; + end Set_Field27; + + procedure Set_Field28 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Field10 := Val; + end Set_Field28; + + procedure Set_Field29 (N : Node_Id; Val : Union_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Field11 := Val; + end Set_Field29; + + procedure Set_Node1 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Field1 := Union_Id (Val); + end Set_Node1; + + procedure Set_Node2 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Field2 := Union_Id (Val); + end Set_Node2; + + procedure Set_Node3 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Field3 := Union_Id (Val); + end Set_Node3; + + procedure Set_Node4 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Field4 := Union_Id (Val); + end Set_Node4; + + procedure Set_Node5 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Field5 := Union_Id (Val); + end Set_Node5; + + procedure Set_Node6 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Field6 := Union_Id (Val); + end Set_Node6; + + procedure Set_Node7 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Field7 := Union_Id (Val); + end Set_Node7; + + procedure Set_Node8 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Field8 := Union_Id (Val); + end Set_Node8; + + procedure Set_Node9 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Field9 := Union_Id (Val); + end Set_Node9; + + procedure Set_Node10 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Field10 := Union_Id (Val); + end Set_Node10; + + procedure Set_Node11 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Field11 := Union_Id (Val); + end Set_Node11; + + procedure Set_Node12 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Field12 := Union_Id (Val); + end Set_Node12; + + procedure Set_Node13 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Field6 := Union_Id (Val); + end Set_Node13; + + procedure Set_Node14 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Field7 := Union_Id (Val); + end Set_Node14; + + procedure Set_Node15 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Field8 := Union_Id (Val); + end Set_Node15; + + procedure Set_Node16 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Field9 := Union_Id (Val); + end Set_Node16; + + procedure Set_Node17 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Field10 := Union_Id (Val); + end Set_Node17; + + procedure Set_Node18 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Field11 := Union_Id (Val); + end Set_Node18; + + procedure Set_Node19 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Field6 := Union_Id (Val); + end Set_Node19; + + procedure Set_Node20 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Field7 := Union_Id (Val); + end Set_Node20; + + procedure Set_Node21 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Field8 := Union_Id (Val); + end Set_Node21; + + procedure Set_Node22 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Field9 := Union_Id (Val); + end Set_Node22; + + procedure Set_Node23 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Field10 := Union_Id (Val); + end Set_Node23; + + procedure Set_Node24 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Field6 := Union_Id (Val); + end Set_Node24; + + procedure Set_Node25 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Field7 := Union_Id (Val); + end Set_Node25; + + procedure Set_Node26 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Field8 := Union_Id (Val); + end Set_Node26; + + procedure Set_Node27 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Field9 := Union_Id (Val); + end Set_Node27; + + procedure Set_Node28 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Field10 := Union_Id (Val); + end Set_Node28; + + procedure Set_Node29 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Field11 := Union_Id (Val); + end Set_Node29; + + procedure Set_List1 (N : Node_Id; Val : List_Id) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Field1 := Union_Id (Val); + end Set_List1; + + procedure Set_List2 (N : Node_Id; Val : List_Id) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Field2 := Union_Id (Val); + end Set_List2; + + procedure Set_List3 (N : Node_Id; Val : List_Id) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Field3 := Union_Id (Val); + end Set_List3; + + procedure Set_List4 (N : Node_Id; Val : List_Id) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Field4 := Union_Id (Val); + end Set_List4; + + procedure Set_List5 (N : Node_Id; Val : List_Id) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Field5 := Union_Id (Val); + end Set_List5; + + procedure Set_List10 (N : Node_Id; Val : List_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Field10 := Union_Id (Val); + end Set_List10; + + procedure Set_List14 (N : Node_Id; Val : List_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Field7 := Union_Id (Val); + end Set_List14; + + procedure Set_List25 (N : Node_Id; Val : List_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Field7 := Union_Id (Val); + end Set_List25; + + procedure Set_Elist1 (N : Node_Id; Val : Elist_Id) is + begin + Nodes.Table (N).Field1 := Union_Id (Val); + end Set_Elist1; + + procedure Set_Elist2 (N : Node_Id; Val : Elist_Id) is + begin + Nodes.Table (N).Field2 := Union_Id (Val); + end Set_Elist2; + + procedure Set_Elist3 (N : Node_Id; Val : Elist_Id) is + begin + Nodes.Table (N).Field3 := Union_Id (Val); + end Set_Elist3; + + procedure Set_Elist4 (N : Node_Id; Val : Elist_Id) is + begin + Nodes.Table (N).Field4 := Union_Id (Val); + end Set_Elist4; + + procedure Set_Elist8 (N : Node_Id; Val : Elist_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Field8 := Union_Id (Val); + end Set_Elist8; + + procedure Set_Elist10 (N : Node_Id; Val : Elist_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Field10 := Union_Id (Val); + end Set_Elist10; + + procedure Set_Elist13 (N : Node_Id; Val : Elist_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Field6 := Union_Id (Val); + end Set_Elist13; + + procedure Set_Elist15 (N : Node_Id; Val : Elist_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Field8 := Union_Id (Val); + end Set_Elist15; + + procedure Set_Elist16 (N : Node_Id; Val : Elist_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Field9 := Union_Id (Val); + end Set_Elist16; + + procedure Set_Elist18 (N : Node_Id; Val : Elist_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Field11 := Union_Id (Val); + end Set_Elist18; + + procedure Set_Elist21 (N : Node_Id; Val : Elist_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Field8 := Union_Id (Val); + end Set_Elist21; + + procedure Set_Elist23 (N : Node_Id; Val : Elist_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Field10 := Union_Id (Val); + end Set_Elist23; + + procedure Set_Elist25 (N : Node_Id; Val : Elist_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Field7 := Union_Id (Val); + end Set_Elist25; + + procedure Set_Elist26 (N : Node_Id; Val : Elist_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Field8 := Union_Id (Val); + end Set_Elist26; + + procedure Set_Name1 (N : Node_Id; Val : Name_Id) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Field1 := Union_Id (Val); + end Set_Name1; + + procedure Set_Name2 (N : Node_Id; Val : Name_Id) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Field2 := Union_Id (Val); + end Set_Name2; + + procedure Set_Str3 (N : Node_Id; Val : String_Id) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Field3 := Union_Id (Val); + end Set_Str3; + + procedure Set_Uint2 (N : Node_Id; Val : Uint) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Field2 := To_Union (Val); + end Set_Uint2; + + procedure Set_Uint3 (N : Node_Id; Val : Uint) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Field3 := To_Union (Val); + end Set_Uint3; + + procedure Set_Uint4 (N : Node_Id; Val : Uint) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Field4 := To_Union (Val); + end Set_Uint4; + + procedure Set_Uint5 (N : Node_Id; Val : Uint) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Field5 := To_Union (Val); + end Set_Uint5; + + procedure Set_Uint8 (N : Node_Id; Val : Uint) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Field8 := To_Union (Val); + end Set_Uint8; + + procedure Set_Uint9 (N : Node_Id; Val : Uint) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Field9 := To_Union (Val); + end Set_Uint9; + + procedure Set_Uint10 (N : Node_Id; Val : Uint) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Field10 := To_Union (Val); + end Set_Uint10; + + procedure Set_Uint11 (N : Node_Id; Val : Uint) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Field11 := To_Union (Val); + end Set_Uint11; + + procedure Set_Uint12 (N : Node_Id; Val : Uint) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Field12 := To_Union (Val); + end Set_Uint12; + + procedure Set_Uint13 (N : Node_Id; Val : Uint) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Field6 := To_Union (Val); + end Set_Uint13; + + procedure Set_Uint14 (N : Node_Id; Val : Uint) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Field7 := To_Union (Val); + end Set_Uint14; + + procedure Set_Uint15 (N : Node_Id; Val : Uint) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Field8 := To_Union (Val); + end Set_Uint15; + + procedure Set_Uint16 (N : Node_Id; Val : Uint) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Field9 := To_Union (Val); + end Set_Uint16; + + procedure Set_Uint17 (N : Node_Id; Val : Uint) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Field10 := To_Union (Val); + end Set_Uint17; + + procedure Set_Uint22 (N : Node_Id; Val : Uint) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Field9 := To_Union (Val); + end Set_Uint22; + + procedure Set_Ureal3 (N : Node_Id; Val : Ureal) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Field3 := To_Union (Val); + end Set_Ureal3; + + procedure Set_Ureal18 (N : Node_Id; Val : Ureal) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Field11 := To_Union (Val); + end Set_Ureal18; + + procedure Set_Ureal21 (N : Node_Id; Val : Ureal) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Field8 := To_Union (Val); + end Set_Ureal21; + + procedure Set_Flag4 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Flag4 := Val; + end Set_Flag4; + + procedure Set_Flag5 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Flag5 := Val; + end Set_Flag5; + + procedure Set_Flag6 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Flag6 := Val; + end Set_Flag6; + + procedure Set_Flag7 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Flag7 := Val; + end Set_Flag7; + + procedure Set_Flag8 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Flag8 := Val; + end Set_Flag8; + + procedure Set_Flag9 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Flag9 := Val; + end Set_Flag9; + + procedure Set_Flag10 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Flag10 := Val; + end Set_Flag10; + + procedure Set_Flag11 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Flag11 := Val; + end Set_Flag11; + + procedure Set_Flag12 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Flag12 := Val; + end Set_Flag12; + + procedure Set_Flag13 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Flag13 := Val; + end Set_Flag13; + + procedure Set_Flag14 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Flag14 := Val; + end Set_Flag14; + + procedure Set_Flag15 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Flag15 := Val; + end Set_Flag15; + + procedure Set_Flag16 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Flag16 := Val; + end Set_Flag16; + + procedure Set_Flag17 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Flag17 := Val; + end Set_Flag17; + + procedure Set_Flag18 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Flag18 := Val; + end Set_Flag18; + + procedure Set_Flag19 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).In_List := Val; + end Set_Flag19; + + procedure Set_Flag20 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Has_Aspects := Val; + end Set_Flag20; + + procedure Set_Flag21 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Rewrite_Ins := Val; + end Set_Flag21; + + procedure Set_Flag22 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Analyzed := Val; + end Set_Flag22; + + procedure Set_Flag23 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Comes_From_Source := Val; + end Set_Flag23; + + procedure Set_Flag24 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Error_Posted := Val; + end Set_Flag24; + + procedure Set_Flag25 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Flag4 := Val; + end Set_Flag25; + + procedure Set_Flag26 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Flag5 := Val; + end Set_Flag26; + + procedure Set_Flag27 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Flag6 := Val; + end Set_Flag27; + + procedure Set_Flag28 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Flag7 := Val; + end Set_Flag28; + + procedure Set_Flag29 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Flag8 := Val; + end Set_Flag29; + + procedure Set_Flag30 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Flag9 := Val; + end Set_Flag30; + + procedure Set_Flag31 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Flag10 := Val; + end Set_Flag31; + + procedure Set_Flag32 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Flag11 := Val; + end Set_Flag32; + + procedure Set_Flag33 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Flag12 := Val; + end Set_Flag33; + + procedure Set_Flag34 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Flag13 := Val; + end Set_Flag34; + + procedure Set_Flag35 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Flag14 := Val; + end Set_Flag35; + + procedure Set_Flag36 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Flag15 := Val; + end Set_Flag36; + + procedure Set_Flag37 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Flag16 := Val; + end Set_Flag37; + + procedure Set_Flag38 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Flag17 := Val; + end Set_Flag38; + + procedure Set_Flag39 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Flag18 := Val; + end Set_Flag39; + + procedure Set_Flag40 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).In_List := Val; + end Set_Flag40; + + procedure Set_Flag41 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Has_Aspects := Val; + end Set_Flag41; + + procedure Set_Flag42 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Rewrite_Ins := Val; + end Set_Flag42; + + procedure Set_Flag43 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Analyzed := Val; + end Set_Flag43; + + procedure Set_Flag44 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Comes_From_Source := Val; + end Set_Flag44; + + procedure Set_Flag45 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Error_Posted := Val; + end Set_Flag45; + + procedure Set_Flag46 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Flag4 := Val; + end Set_Flag46; + + procedure Set_Flag47 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Flag5 := Val; + end Set_Flag47; + + procedure Set_Flag48 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Flag6 := Val; + end Set_Flag48; + + procedure Set_Flag49 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Flag7 := Val; + end Set_Flag49; + + procedure Set_Flag50 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Flag8 := Val; + end Set_Flag50; + + procedure Set_Flag51 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Flag9 := Val; + end Set_Flag51; + + procedure Set_Flag52 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Flag10 := Val; + end Set_Flag52; + + procedure Set_Flag53 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Flag11 := Val; + end Set_Flag53; + + procedure Set_Flag54 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Flag12 := Val; + end Set_Flag54; + + procedure Set_Flag55 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Flag13 := Val; + end Set_Flag55; + + procedure Set_Flag56 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Flag14 := Val; + end Set_Flag56; + + procedure Set_Flag57 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Flag15 := Val; + end Set_Flag57; + + procedure Set_Flag58 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Flag16 := Val; + end Set_Flag58; + + procedure Set_Flag59 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Flag17 := Val; + end Set_Flag59; + + procedure Set_Flag60 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Flag18 := Val; + end Set_Flag60; + + procedure Set_Flag61 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Pflag1 := Val; + end Set_Flag61; + + procedure Set_Flag62 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 1).Pflag2 := Val; + end Set_Flag62; + + procedure Set_Flag63 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Pflag1 := Val; + end Set_Flag63; + + procedure Set_Flag64 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 2).Pflag2 := Val; + end Set_Flag64; + + procedure Set_Flag65 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag65 := Val; + end Set_Flag65; + + procedure Set_Flag66 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag66 := Val; + end Set_Flag66; + + procedure Set_Flag67 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag67 := Val; + end Set_Flag67; + + procedure Set_Flag68 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag68 := Val; + end Set_Flag68; + + procedure Set_Flag69 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag69 := Val; + end Set_Flag69; + + procedure Set_Flag70 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag70 := Val; + end Set_Flag70; + + procedure Set_Flag71 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag71 := Val; + end Set_Flag71; + + procedure Set_Flag72 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag72 := Val; + end Set_Flag72; + + procedure Set_Flag73 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag73 := Val; + end Set_Flag73; + + procedure Set_Flag74 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag74 := Val; + end Set_Flag74; + + procedure Set_Flag75 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag75 := Val; + end Set_Flag75; + + procedure Set_Flag76 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag76 := Val; + end Set_Flag76; + + procedure Set_Flag77 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag77 := Val; + end Set_Flag77; + + procedure Set_Flag78 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag78 := Val; + end Set_Flag78; + + procedure Set_Flag79 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag79 := Val; + end Set_Flag79; + + procedure Set_Flag80 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag80 := Val; + end Set_Flag80; + + procedure Set_Flag81 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag81 := Val; + end Set_Flag81; + + procedure Set_Flag82 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag82 := Val; + end Set_Flag82; + + procedure Set_Flag83 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag83 := Val; + end Set_Flag83; + + procedure Set_Flag84 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag84 := Val; + end Set_Flag84; + + procedure Set_Flag85 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag85 := Val; + end Set_Flag85; + + procedure Set_Flag86 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag86 := Val; + end Set_Flag86; + + procedure Set_Flag87 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag87 := Val; + end Set_Flag87; + + procedure Set_Flag88 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag88 := Val; + end Set_Flag88; + + procedure Set_Flag89 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag89 := Val; + end Set_Flag89; + + procedure Set_Flag90 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag90 := Val; + end Set_Flag90; + + procedure Set_Flag91 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag91 := Val; + end Set_Flag91; + + procedure Set_Flag92 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag92 := Val; + end Set_Flag92; + + procedure Set_Flag93 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag93 := Val; + end Set_Flag93; + + procedure Set_Flag94 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag94 := Val; + end Set_Flag94; + + procedure Set_Flag95 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag95 := Val; + end Set_Flag95; + + procedure Set_Flag96 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag96 := Val; + end Set_Flag96; + + procedure Set_Flag97 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag97 := Val; + end Set_Flag97; + + procedure Set_Flag98 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag98 := Val; + end Set_Flag98; + + procedure Set_Flag99 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag99 := Val; + end Set_Flag99; + + procedure Set_Flag100 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag100 := Val; + end Set_Flag100; + + procedure Set_Flag101 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag101 := Val; + end Set_Flag101; + + procedure Set_Flag102 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag102 := Val; + end Set_Flag102; + + procedure Set_Flag103 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag103 := Val; + end Set_Flag103; + + procedure Set_Flag104 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag104 := Val; + end Set_Flag104; + + procedure Set_Flag105 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag105 := Val; + end Set_Flag105; + + procedure Set_Flag106 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag106 := Val; + end Set_Flag106; + + procedure Set_Flag107 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag107 := Val; + end Set_Flag107; + + procedure Set_Flag108 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag108 := Val; + end Set_Flag108; + + procedure Set_Flag109 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag109 := Val; + end Set_Flag109; + + procedure Set_Flag110 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag110 := Val; + end Set_Flag110; + + procedure Set_Flag111 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag111 := Val; + end Set_Flag111; + + procedure Set_Flag112 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag112 := Val; + end Set_Flag112; + + procedure Set_Flag113 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag113 := Val; + end Set_Flag113; + + procedure Set_Flag114 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag114 := Val; + end Set_Flag114; + + procedure Set_Flag115 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag115 := Val; + end Set_Flag115; + + procedure Set_Flag116 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag116 := Val; + end Set_Flag116; + + procedure Set_Flag117 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag117 := Val; + end Set_Flag117; + + procedure Set_Flag118 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag118 := Val; + end Set_Flag118; + + procedure Set_Flag119 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag119 := Val; + end Set_Flag119; + + procedure Set_Flag120 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag120 := Val; + end Set_Flag120; + + procedure Set_Flag121 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag121 := Val; + end Set_Flag121; + + procedure Set_Flag122 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag122 := Val; + end Set_Flag122; + + procedure Set_Flag123 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag123 := Val; + end Set_Flag123; + + procedure Set_Flag124 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag124 := Val; + end Set_Flag124; + + procedure Set_Flag125 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag125 := Val; + end Set_Flag125; + + procedure Set_Flag126 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag126 := Val; + end Set_Flag126; + + procedure Set_Flag127 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag127 := Val; + end Set_Flag127; + + procedure Set_Flag128 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word2_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag128 := Val; + end Set_Flag128; + + procedure Set_Flag129 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).In_List := Val; + end Set_Flag129; + + procedure Set_Flag130 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Has_Aspects := Val; + end Set_Flag130; + + procedure Set_Flag131 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Rewrite_Ins := Val; + end Set_Flag131; + + procedure Set_Flag132 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Analyzed := Val; + end Set_Flag132; + + procedure Set_Flag133 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Comes_From_Source := Val; + end Set_Flag133; + + procedure Set_Flag134 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Error_Posted := Val; + end Set_Flag134; + + procedure Set_Flag135 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Flag4 := Val; + end Set_Flag135; + + procedure Set_Flag136 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Flag5 := Val; + end Set_Flag136; + + procedure Set_Flag137 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Flag6 := Val; + end Set_Flag137; + + procedure Set_Flag138 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Flag7 := Val; + end Set_Flag138; + + procedure Set_Flag139 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Flag8 := Val; + end Set_Flag139; + + procedure Set_Flag140 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Flag9 := Val; + end Set_Flag140; + + procedure Set_Flag141 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Flag10 := Val; + end Set_Flag141; + + procedure Set_Flag142 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Flag11 := Val; + end Set_Flag142; + + procedure Set_Flag143 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Flag12 := Val; + end Set_Flag143; + + procedure Set_Flag144 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Flag13 := Val; + end Set_Flag144; + + procedure Set_Flag145 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Flag14 := Val; + end Set_Flag145; + + procedure Set_Flag146 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Flag15 := Val; + end Set_Flag146; + + procedure Set_Flag147 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Flag16 := Val; + end Set_Flag147; + + procedure Set_Flag148 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Flag17 := Val; + end Set_Flag148; + + procedure Set_Flag149 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Flag18 := Val; + end Set_Flag149; + + procedure Set_Flag150 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Pflag1 := Val; + end Set_Flag150; + + procedure Set_Flag151 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 3).Pflag2 := Val; + end Set_Flag151; + + procedure Set_Flag152 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag152 := Val; + end Set_Flag152; + + procedure Set_Flag153 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag153 := Val; + end Set_Flag153; + + procedure Set_Flag154 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag154 := Val; + end Set_Flag154; + + procedure Set_Flag155 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag155 := Val; + end Set_Flag155; + + procedure Set_Flag156 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag156 := Val; + end Set_Flag156; + + procedure Set_Flag157 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag157 := Val; + end Set_Flag157; + + procedure Set_Flag158 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag158 := Val; + end Set_Flag158; + + procedure Set_Flag159 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag159 := Val; + end Set_Flag159; + + procedure Set_Flag160 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag160 := Val; + end Set_Flag160; + + procedure Set_Flag161 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag161 := Val; + end Set_Flag161; + + procedure Set_Flag162 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag162 := Val; + end Set_Flag162; + + procedure Set_Flag163 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag163 := Val; + end Set_Flag163; + + procedure Set_Flag164 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag164 := Val; + end Set_Flag164; + + procedure Set_Flag165 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag165 := Val; + end Set_Flag165; + + procedure Set_Flag166 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag166 := Val; + end Set_Flag166; + + procedure Set_Flag167 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag167 := Val; + end Set_Flag167; + + procedure Set_Flag168 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag168 := Val; + end Set_Flag168; + + procedure Set_Flag169 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag169 := Val; + end Set_Flag169; + + procedure Set_Flag170 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag170 := Val; + end Set_Flag170; + + procedure Set_Flag171 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag171 := Val; + end Set_Flag171; + + procedure Set_Flag172 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag172 := Val; + end Set_Flag172; + + procedure Set_Flag173 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag173 := Val; + end Set_Flag173; + + procedure Set_Flag174 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag174 := Val; + end Set_Flag174; + + procedure Set_Flag175 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag175 := Val; + end Set_Flag175; + + procedure Set_Flag176 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag176 := Val; + end Set_Flag176; + + procedure Set_Flag177 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag177 := Val; + end Set_Flag177; + + procedure Set_Flag178 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag178 := Val; + end Set_Flag178; + + procedure Set_Flag179 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag179 := Val; + end Set_Flag179; + + procedure Set_Flag180 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag180 := Val; + end Set_Flag180; + + procedure Set_Flag181 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag181 := Val; + end Set_Flag181; + + procedure Set_Flag182 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag182 := Val; + end Set_Flag182; + + procedure Set_Flag183 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word3_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag183 := Val; + end Set_Flag183; + + procedure Set_Flag184 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag184 := Val; + end Set_Flag184; + + procedure Set_Flag185 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag185 := Val; + end Set_Flag185; + + procedure Set_Flag186 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag186 := Val; + end Set_Flag186; + + procedure Set_Flag187 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag187 := Val; + end Set_Flag187; + + procedure Set_Flag188 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag188 := Val; + end Set_Flag188; + + procedure Set_Flag189 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag189 := Val; + end Set_Flag189; + + procedure Set_Flag190 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag190 := Val; + end Set_Flag190; + + procedure Set_Flag191 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag191 := Val; + end Set_Flag191; + + procedure Set_Flag192 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag192 := Val; + end Set_Flag192; + + procedure Set_Flag193 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag193 := Val; + end Set_Flag193; + + procedure Set_Flag194 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag194 := Val; + end Set_Flag194; + + procedure Set_Flag195 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag195 := Val; + end Set_Flag195; + + procedure Set_Flag196 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag196 := Val; + end Set_Flag196; + + procedure Set_Flag197 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag197 := Val; + end Set_Flag197; + + procedure Set_Flag198 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag198 := Val; + end Set_Flag198; + + procedure Set_Flag199 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag199 := Val; + end Set_Flag199; + + procedure Set_Flag200 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag200 := Val; + end Set_Flag200; + + procedure Set_Flag201 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag201 := Val; + end Set_Flag201; + + procedure Set_Flag202 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag202 := Val; + end Set_Flag202; + + procedure Set_Flag203 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag203 := Val; + end Set_Flag203; + + procedure Set_Flag204 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag204 := Val; + end Set_Flag204; + + procedure Set_Flag205 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag205 := Val; + end Set_Flag205; + + procedure Set_Flag206 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag206 := Val; + end Set_Flag206; + + procedure Set_Flag207 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag207 := Val; + end Set_Flag207; + + procedure Set_Flag208 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag208 := Val; + end Set_Flag208; + + procedure Set_Flag209 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag209 := Val; + end Set_Flag209; + + procedure Set_Flag210 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag210 := Val; + end Set_Flag210; + + procedure Set_Flag211 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag211 := Val; + end Set_Flag211; + + procedure Set_Flag212 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag212 := Val; + end Set_Flag212; + + procedure Set_Flag213 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag213 := Val; + end Set_Flag213; + + procedure Set_Flag214 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag214 := Val; + end Set_Flag214; + + procedure Set_Flag215 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Word4_Ptr + (Union_Id_Ptr' + (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag215 := Val; + end Set_Flag215; + + procedure Set_Flag216 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).In_List := Val; + end Set_Flag216; + + procedure Set_Flag217 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Has_Aspects := Val; + end Set_Flag217; + + procedure Set_Flag218 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Rewrite_Ins := Val; + end Set_Flag218; + + procedure Set_Flag219 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Analyzed := Val; + end Set_Flag219; + + procedure Set_Flag220 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Comes_From_Source := Val; + end Set_Flag220; + + procedure Set_Flag221 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Error_Posted := Val; + end Set_Flag221; + + procedure Set_Flag222 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Flag4 := Val; + end Set_Flag222; + + procedure Set_Flag223 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Flag5 := Val; + end Set_Flag223; + + procedure Set_Flag224 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Flag6 := Val; + end Set_Flag224; + + procedure Set_Flag225 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Flag7 := Val; + end Set_Flag225; + + procedure Set_Flag226 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Flag8 := Val; + end Set_Flag226; + + procedure Set_Flag227 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Flag9 := Val; + end Set_Flag227; + + procedure Set_Flag228 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Flag10 := Val; + end Set_Flag228; + + procedure Set_Flag229 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Flag11 := Val; + end Set_Flag229; + + procedure Set_Flag230 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Flag12 := Val; + end Set_Flag230; + + procedure Set_Flag231 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Flag13 := Val; + end Set_Flag231; + + procedure Set_Flag232 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Flag14 := Val; + end Set_Flag232; + + procedure Set_Flag233 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Flag15 := Val; + end Set_Flag233; + + procedure Set_Flag234 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Flag16 := Val; + end Set_Flag234; + + procedure Set_Flag235 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Flag17 := Val; + end Set_Flag235; + + procedure Set_Flag236 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Flag18 := Val; + end Set_Flag236; + + procedure Set_Flag237 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Pflag1 := Val; + end Set_Flag237; + + procedure Set_Flag238 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Pflag2 := Val; + end Set_Flag238; + + procedure Set_Flag239 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte2_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 3).Nkind'Unrestricted_Access)).Flag239 := Val; + end Set_Flag239; + + procedure Set_Flag240 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte2_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 3).Nkind'Unrestricted_Access)).Flag240 := Val; + end Set_Flag240; + + procedure Set_Flag241 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte2_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 3).Nkind'Unrestricted_Access)).Flag241 := Val; + end Set_Flag241; + + procedure Set_Flag242 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte2_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 3).Nkind'Unrestricted_Access)).Flag242 := Val; + end Set_Flag242; + + procedure Set_Flag243 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte2_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 3).Nkind'Unrestricted_Access)).Flag243 := Val; + end Set_Flag243; + + procedure Set_Flag244 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte2_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 3).Nkind'Unrestricted_Access)).Flag244 := Val; + end Set_Flag244; + + procedure Set_Flag245 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte2_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 3).Nkind'Unrestricted_Access)).Flag245 := Val; + end Set_Flag245; + + procedure Set_Flag246 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte2_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 3).Nkind'Unrestricted_Access)).Flag246 := Val; + end Set_Flag246; + + procedure Set_Flag247 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte3_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 4).Nkind'Unrestricted_Access)).Flag247 := Val; + end Set_Flag247; + + procedure Set_Flag248 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte3_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 4).Nkind'Unrestricted_Access)).Flag248 := Val; + end Set_Flag248; + + procedure Set_Flag249 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte3_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 4).Nkind'Unrestricted_Access)).Flag249 := Val; + end Set_Flag249; + + procedure Set_Flag250 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte3_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 4).Nkind'Unrestricted_Access)).Flag250 := Val; + end Set_Flag250; + + procedure Set_Flag251 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte3_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 4).Nkind'Unrestricted_Access)).Flag251 := Val; + end Set_Flag251; + + procedure Set_Flag252 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte3_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 4).Nkind'Unrestricted_Access)).Flag252 := Val; + end Set_Flag252; + + procedure Set_Flag253 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte3_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 4).Nkind'Unrestricted_Access)).Flag253 := Val; + end Set_Flag253; + + procedure Set_Flag254 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (Nkind (N) in N_Entity); + To_Flag_Byte3_Ptr + (Node_Kind_Ptr' + (Nodes.Table (N + 4).Nkind'Unrestricted_Access)).Flag254 := Val; + end Set_Flag254; + + procedure Set_Node1_With_Parent (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (N <= Nodes.Last); + + if Val > Error then + Set_Parent (N => Val, Val => N); + end if; + + Set_Node1 (N, Val); + end Set_Node1_With_Parent; + + procedure Set_Node2_With_Parent (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (N <= Nodes.Last); + + if Val > Error then + Set_Parent (N => Val, Val => N); + end if; + + Set_Node2 (N, Val); + end Set_Node2_With_Parent; + + procedure Set_Node3_With_Parent (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (N <= Nodes.Last); + + if Val > Error then + Set_Parent (N => Val, Val => N); + end if; + + Set_Node3 (N, Val); + end Set_Node3_With_Parent; + + procedure Set_Node4_With_Parent (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (N <= Nodes.Last); + + if Val > Error then + Set_Parent (N => Val, Val => N); + end if; + + Set_Node4 (N, Val); + end Set_Node4_With_Parent; + + procedure Set_Node5_With_Parent (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (N <= Nodes.Last); + + if Val > Error then + Set_Parent (N => Val, Val => N); + end if; + + Set_Node5 (N, Val); + end Set_Node5_With_Parent; + + procedure Set_List1_With_Parent (N : Node_Id; Val : List_Id) is + begin + pragma Assert (N <= Nodes.Last); + if Val /= No_List and then Val /= Error_List then + Set_Parent (Val, N); + end if; + Set_List1 (N, Val); + end Set_List1_With_Parent; + + procedure Set_List2_With_Parent (N : Node_Id; Val : List_Id) is + begin + pragma Assert (N <= Nodes.Last); + if Val /= No_List and then Val /= Error_List then + Set_Parent (Val, N); + end if; + Set_List2 (N, Val); + end Set_List2_With_Parent; + + procedure Set_List3_With_Parent (N : Node_Id; Val : List_Id) is + begin + pragma Assert (N <= Nodes.Last); + if Val /= No_List and then Val /= Error_List then + Set_Parent (Val, N); + end if; + Set_List3 (N, Val); + end Set_List3_With_Parent; + + procedure Set_List4_With_Parent (N : Node_Id; Val : List_Id) is + begin + pragma Assert (N <= Nodes.Last); + if Val /= No_List and then Val /= Error_List then + Set_Parent (Val, N); + end if; + Set_List4 (N, Val); + end Set_List4_With_Parent; + + procedure Set_List5_With_Parent (N : Node_Id; Val : List_Id) is + begin + pragma Assert (N <= Nodes.Last); + if Val /= No_List and then Val /= Error_List then + Set_Parent (Val, N); + end if; + Set_List5 (N, Val); + end Set_List5_With_Parent; + + end Unchecked_Access; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock is + begin + Nodes.Locked := False; + Orig_Nodes.Locked := False; + end Unlock; + +end Atree; diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads new file mode 100644 index 000000000..cf8573f0b --- /dev/null +++ b/gcc/ada/atree.ads @@ -0,0 +1,3353 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A T R E E -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with Alloc; +with Sinfo; use Sinfo; +with Einfo; use Einfo; +with Namet; use Namet; +with Types; use Types; +with Snames; use Snames; +with System; use System; +with Table; +with Uintp; use Uintp; +with Urealp; use Urealp; +with Unchecked_Conversion; + +package Atree is + +-- This package defines the format of the tree used to represent the Ada +-- program internally. Syntactic and semantic information is combined in +-- this tree. There is no separate symbol table structure. + +-- WARNING: There is a C version of this package. Any changes to this +-- source file must be properly reflected in the C header file atree.h + +-- Package Atree defines the basic structure of the tree and its nodes and +-- provides the basic abstract interface for manipulating the tree. Two +-- other packages use this interface to define the representation of Ada +-- programs using this tree format. The package Sinfo defines the basic +-- representation of the syntactic structure of the program, as output +-- by the parser. The package Entity_Info defines the semantic information +-- which is added to the tree nodes that represent declared entities (i.e. +-- the information which might typically be described in a separate symbol +-- table structure). + +-- The front end of the compiler first parses the program and generates a +-- tree that is simply a syntactic representation of the program in abstract +-- syntax tree format. Subsequent processing in the front end traverses the +-- tree, transforming it in various ways and adding semantic information. + + ---------------------------------------- + -- Definitions of Fields in Tree Node -- + ---------------------------------------- + + -- The representation of the tree is completely hidden, using a functional + -- interface for accessing and modifying the contents of nodes. Logically + -- a node contains a number of fields, much as though the nodes were + -- defined as a record type. The fields in a node are as follows: + + -- Nkind Indicates the kind of the node. This field is present + -- in all nodes. The type is Node_Kind, which is declared + -- in the package Sinfo. + + -- Sloc Location (Source_Ptr) of the corresponding token + -- in the Source buffer. The individual node definitions + -- show which token is referenced by this pointer. + + -- In_List A flag used to indicate if the node is a member + -- of a node list. + + -- Rewrite_Ins A flag set if a node is marked as a rewrite inserted + -- node as a result of a call to Mark_Rewrite_Insertion. + + -- Paren_Count A 2-bit count used in sub-expression nodes to indicate + -- the level of parentheses. The settings are 0,1,2 and + -- 3 for many. If the value is 3, then an auxiliary table + -- is used to indicate the real value. Set to zero for + -- non-subexpression nodes. + + -- Comes_From_Source + -- This flag is present in all nodes. It is set if the + -- node is built by the scanner or parser, and clear if + -- the node is built by the analyzer or expander. It + -- indicates that the node corresponds to a construct + -- that appears in the original source program. + + -- Analyzed This flag is present in all nodes. It is set when + -- a node is analyzed, and is used to avoid analyzing + -- the same node twice. Analysis includes expansion if + -- expansion is active, so in this case if the flag is + -- set it means the node has been analyzed and expanded. + + -- Error_Posted This flag is present in all nodes. It is set when + -- an error message is posted which is associated with + -- the flagged node. This is used to avoid posting more + -- than one message on the same node. + + -- Field1 + -- Field2 + -- Field3 + -- Field4 + -- Field5 Five fields holding Union_Id values + + -- ElistN Synonym for FieldN typed as Elist_Id (Empty = No_Elist) + -- ListN Synonym for FieldN typed as List_Id + -- NameN Synonym for FieldN typed as Name_Id + -- NodeN Synonym for FieldN typed as Node_Id + -- StrN Synonym for FieldN typed as String_Id + -- UintN Synonym for FieldN typed as Uint (Empty = Uint_0) + -- UrealN Synonym for FieldN typed as Ureal + + -- Note: in the case of ElistN and UintN fields, it is common that we + -- end up with a value of Union_Id'(0) as the default value. This value + -- is meaningless as a Uint or Elist_Id value. We have two choices here. + -- We could require that all Uint and Elist fields be initialized to an + -- appropriate value, but that's error prone, since it would be easy to + -- miss an initialization. So instead we have the retrieval functions + -- generate an appropriate default value (Uint_0 or No_Elist). Probably + -- it would be cleaner to generate No_Uint in the Uint case but we got + -- stuck with representing an "unset" size value as zero early on, and + -- it will take a bit of fiddling to change that ??? + + -- Note: the actual usage of FieldN (i.e. whether it contains a Elist_Id, + -- List_Id, Name_Id, Node_Id, String_Id, Uint or Ureal) depends on the + -- value in Nkind. Generally the access to this field is always via the + -- functional interface, so the field names ElistN, ListN, NameN, NodeN, + -- StrN, UintN and UrealN are used only in the bodies of the access + -- functions (i.e. in the bodies of Sinfo and Einfo). These access + -- functions contain debugging code that checks that the use is + -- consistent with Nkind and Ekind values. + + -- However, in specialized circumstances (examples are the circuit in + -- generic instantiation to copy trees, and in the tree dump routine), + -- it is useful to be able to do untyped traversals, and an internal + -- package in Atree allows for direct untyped accesses in such cases. + + -- Flag4 Sixteen Boolean flags (use depends on Nkind and + -- Flag5 Ekind, as described for FieldN). Again the access + -- Flag6 is usually via subprograms in Sinfo and Einfo which + -- Flag7 provide high-level synonyms for these flags, and + -- Flag8 contain debugging code that checks that the values + -- Flag9 in Nkind and Ekind are appropriate for the access. + -- Flag10 + -- Flag11 Note that Flag1-2 are missing from this list. For + -- Flag12 historical reasons, these flag names are unused. + -- Flag13 + -- Flag14 + -- Flag15 + -- Flag16 + -- Flag17 + -- Flag18 + + -- Link For a node, points to the Parent. For a list, points + -- to the list header. Note that in the latter case, a + -- client cannot modify the link field. This field is + -- private to the Atree package (but is also modified + -- by the Nlists package). + + -- The following additional fields are present in extended nodes used + -- for entities (Nkind in N_Entity). + + -- Ekind Entity type. This field indicates the type of the + -- entity, it is of type Entity_Kind which is defined + -- in package Einfo. + + -- Flag19 235 additional flags + -- ... + -- Flag254 + + -- Convention Entity convention (Convention_Id value) + + -- Field6 Additional Union_Id value stored in tree + + -- Node6 Synonym for Field6 typed as Node_Id + -- Elist6 Synonym for Field6 typed as Elist_Id (Empty = No_Elist) + -- Uint6 Synonym for Field6 typed as Uint (Empty = Uint_0) + + -- Similar definitions for Field7 to Field28 (and Node7-Node28, + -- Elist7-Elist28, Uint7-Uint28, Ureal7-Ureal28). Note that not all these + -- functions are defined, only the ones that are actually used. + + function Last_Node_Id return Node_Id; + pragma Inline (Last_Node_Id); + -- Returns Id of last allocated node Id + + function Nodes_Address return System.Address; + -- Return address of Nodes table (used in Back_End for Gigi call) + + function Num_Nodes return Nat; + -- Total number of nodes allocated, where an entity counts as a single + -- node. This count is incremented every time a node or entity is + -- allocated, and decremented every time a node or entity is deleted. + -- This value is used by Xref and by Treepr to allocate hash tables of + -- suitable size for hashing Node_Id values. + + ----------------------- + -- Use of Empty Node -- + ----------------------- + + -- The special Node_Id Empty is used to mark missing fields. Whenever the + -- syntax has an optional component, then the corresponding field will be + -- set to Empty if the component is missing. + + -- Note: Empty is not used to describe an empty list. Instead in this + -- case the node field contains a list which is empty, and these cases + -- should be distinguished (essentially from a type point of view, Empty + -- is a Node, and is thus not a list). + + -- Note: Empty does in fact correspond to an allocated node. Only the + -- Nkind field of this node may be referenced. It contains N_Empty, which + -- uniquely identifies the empty case. This allows the Nkind field to be + -- dereferenced before the check for Empty which is sometimes useful. + + ----------------------- + -- Use of Error Node -- + ----------------------- + + -- The Error node is used during syntactic and semantic analysis to + -- indicate that the corresponding piece of syntactic structure or + -- semantic meaning cannot properly be represented in the tree because + -- of an illegality in the program. + + -- If an Error node is encountered, then you know that a previous + -- illegality has been detected. The proper reaction should be to + -- avoid posting related cascaded error messages, and to propagate + -- the error node if necessary. + + ------------------------ + -- Current_Error_Node -- + ------------------------ + + -- The current error node is a global location indicating the current + -- node that is being processed for the purposes of placing a compiler + -- abort message. This is not necessarily perfectly accurate, it is + -- just a reasonably accurate best guess. It is used to output the + -- source location in the abort message by Comperr, and also to + -- implement the d3 debugging flag. This is also used by Rtsfind + -- to generate error messages for high integrity mode. + + -- There are two ways this gets set. During parsing, when new source + -- nodes are being constructed by calls to New_Node and New_Entity, + -- either one of these calls sets Current_Error_Node to the newly + -- created node. During semantic analysis, this mechanism is not + -- used, and instead Current_Error_Node is set by the subprograms in + -- Debug_A that mark the start and end of analysis/expansion of a + -- node in the tree. + + Current_Error_Node : Node_Id; + -- Node to place error messages + + ------------------------------- + -- Default Setting of Fields -- + ------------------------------- + + -- Nkind is set to N_Unused_At_Start + + -- Ekind is set to E_Void + + -- Sloc is always set, there is no default value + + -- Field1-5 fields are set to Empty + + -- Field6-29 fields in extended nodes are set to Empty + + -- Parent is set to Empty + + -- All Boolean flag fields are set to False + + -- Note: the value Empty is used in Field1-Field17 to indicate a null node. + -- The usage varies. The common uses are to indicate absence of an + -- optional clause or a completely unused Field1-17 field. + + ------------------------------------- + -- Use of Synonyms for Node Fields -- + ------------------------------------- + + -- A subpackage Atree.Unchecked_Access provides routines for reading and + -- writing the fields defined above (Field1-27, Node1-27, Flag4-254 etc). + -- These unchecked access routines can be used for untyped traversals. + -- In addition they are used in the implementations of the Sinfo and + -- Einfo packages. These packages both provide logical synonyms for + -- the generic fields, together with an appropriate set of access routines. + -- Normally access to information within tree nodes uses these synonyms, + -- providing a high level typed interface to the tree information. + + -------------------------------------------------- + -- Node Allocation and Modification Subprograms -- + -------------------------------------------------- + + -- Generally the parser builds the tree and then it is further decorated + -- (e.g. by setting the entity fields), but not fundamentally modified. + -- However, there are cases in which the tree must be restructured by + -- adding and rearranging nodes, as a result of disambiguating cases + -- which the parser could not parse correctly, and adding additional + -- semantic information (e.g. making constraint checks explicit). The + -- following subprograms are used for constructing the tree in the first + -- place, and then for subsequent modifications as required. + + procedure Initialize; + -- Called at the start of compilation to initialize the allocation of + -- the node and list tables and make the standard entries for Empty, + -- Error and Error_List. Note that Initialize must not be called if + -- Tree_Read is used. + + procedure Lock; + -- Called before the back end is invoked to lock the nodes table + -- Also called after Unlock to relock??? + + procedure Unlock; + -- Unlocks nodes table, in cases where the back end needs to modify it + + procedure Tree_Read; + -- Initializes internal tables from current tree file using the relevant + -- Table.Tree_Read routines. Note that Initialize should not be called if + -- Tree_Read is used. Tree_Read includes all necessary initialization. + + procedure Tree_Write; + -- Writes out internal tables to current tree file using the relevant + -- Table.Tree_Write routines. + + function New_Node + (New_Node_Kind : Node_Kind; + New_Sloc : Source_Ptr) return Node_Id; + -- Allocates a completely new node with the given node type and source + -- location values. All other fields are set to their standard defaults: + -- + -- Empty for all FieldN fields + -- False for all FlagN fields + -- + -- The usual approach is to build a new node using this function and + -- then, using the value returned, use the Set_xxx functions to set + -- fields of the node as required. New_Node can only be used for + -- non-entity nodes, i.e. it never generates an extended node. + -- + -- If we are currently parsing, as indicated by a previous call to + -- Set_Comes_From_Source_Default (True), then this call also resets + -- the value of Current_Error_Node. + + function New_Entity + (New_Node_Kind : Node_Kind; + New_Sloc : Source_Ptr) return Entity_Id; + -- Similar to New_Node, except that it is used only for entity nodes + -- and returns an extended node. + + procedure Set_Comes_From_Source_Default (Default : Boolean); + -- Sets value of Comes_From_Source flag to be used in all subsequent + -- New_Node and New_Entity calls until another call to this procedure + -- changes the default. This value is set True during parsing and + -- False during semantic analysis. This is also used to determine + -- if New_Node and New_Entity should set Current_Error_Node. + + function Get_Comes_From_Source_Default return Boolean; + pragma Inline (Get_Comes_From_Source_Default); + -- Gets the current value of the Comes_From_Source flag + + procedure Preserve_Comes_From_Source (NewN, OldN : Node_Id); + pragma Inline (Preserve_Comes_From_Source); + -- When a node is rewritten, it is sometimes appropriate to preserve the + -- original comes from source indication. This is true when the rewrite + -- essentially corresponds to a transformation corresponding exactly to + -- semantics in the reference manual. This procedure copies the setting + -- of Comes_From_Source from OldN to NewN. + + function Has_Extension (N : Node_Id) return Boolean; + pragma Inline (Has_Extension); + -- Returns True if the given node has an extension (i.e. was created by + -- a call to New_Entity rather than New_Node, and Nkind is in N_Entity) + + procedure Change_Node (N : Node_Id; New_Node_Kind : Node_Kind); + -- This procedure replaces the given node by setting its Nkind field to + -- the indicated value and resetting all other fields to their default + -- values except for Sloc, which is unchanged, and the Parent pointer + -- and list links, which are also unchanged. All other information in + -- the original node is lost. The new node has an extension if the + -- original node had an extension. + + procedure Copy_Node (Source : Node_Id; Destination : Node_Id); + -- Copy the entire contents of the source node to the destination node. + -- The contents of the source node is not affected. If the source node + -- has an extension, then the destination must have an extension also. + -- The parent pointer of the destination and its list link, if any, are + -- not affected by the copy. Note that parent pointers of descendents + -- are not adjusted, so the descendents of the destination node after + -- the Copy_Node is completed have dubious parent pointers. Note that + -- this routine does NOT copy aspect specifications, the Has_Aspects + -- flag in the returned node will always be False. The caller must deal + -- with copying aspect specifications where this is required. + + function New_Copy (Source : Node_Id) return Node_Id; + -- This function allocates a completely new node, and then initializes + -- it by copying the contents of the source node into it. The contents + -- of the source node is not affected. The target node is always marked + -- as not being in a list (even if the source is a list member). The + -- new node will have an extension if the source has an extension. + -- New_Copy (Empty) returns Empty and New_Copy (Error) returns Error. + -- Note that, unlike New_Copy_Tree, New_Copy does not recursively copy any + -- descendents, so in general parent pointers are not set correctly for + -- the descendents of the copied node. Both normal and extended nodes + -- (entities) may be copied using New_Copy. + + function Relocate_Node (Source : Node_Id) return Node_Id; + -- Source is a non-entity node that is to be relocated. A new node is + -- allocated and the contents of Source are copied to this node using + -- Copy_Node. The parent pointers of descendents of the node are then + -- adjusted to point to the relocated copy. The original node is not + -- modified, but the parent pointers of its descendents are no longer + -- valid. This routine is used in conjunction with the tree rewrite + -- routines (see descriptions of Replace/Rewrite). + -- + -- Note that the resulting node has the same parent as the source + -- node, and is thus still attached to the tree. It is valid for + -- Source to be Empty, in which case Relocate_Node simply returns + -- Empty as the result. + + function Copy_Separate_Tree (Source : Node_Id) return Node_Id; + -- Given a node that is the root of a subtree, Copy_Separate_Tree copies + -- the entire syntactic subtree, including recursively any descendants + -- whose parent field references a copied node (descendants not linked to + -- a copied node by the parent field are also copied.) The parent pointers + -- in the copy are properly set. Copy_Separate_Tree (Empty/Error) returns + -- Empty/Error. The semantic fields are not copied and the new subtree + -- does not share any entity with source subtree. + -- But the code *does* copy semantic fields, and the description above + -- is in any case unclear on this point ??? (RBKD) + + procedure Exchange_Entities (E1 : Entity_Id; E2 : Entity_Id); + -- Exchange the contents of two entities. The parent pointers are switched + -- as well as the Defining_Identifier fields in the parents, so that the + -- entities point correctly to their original parents. The effect is thus + -- to leave the tree completely unchanged in structure, except that the + -- entity ID values of the two entities are interchanged. Neither of the + -- two entities may be list members. + + function Extend_Node (Node : Node_Id) return Entity_Id; + -- This function returns a copy of its input node with an extension + -- added. The fields of the extension are set to Empty. Due to the way + -- extensions are handled (as four consecutive array elements), it may + -- be necessary to reallocate the node, so that the returned value is + -- not the same as the input value, but where possible the returned + -- value will be the same as the input value (i.e. the extension will + -- occur in place). It is the caller's responsibility to ensure that + -- any pointers to the original node are appropriately updated. This + -- function is used only by Sinfo.CN to change nodes into their + -- corresponding entities. + + type Report_Proc is access procedure (Target : Node_Id; Source : Node_Id); + + procedure Set_Reporting_Proc (P : Report_Proc); + -- Register a procedure that is invoked when a node is allocated, replaced + -- or rewritten. + + type Traverse_Result is (Abandon, OK, OK_Orig, Skip); + -- This is the type of the result returned by the Process function passed + -- to Traverse_Func and Traverse_Proc. See below for details. + + subtype Traverse_Final_Result is Traverse_Result range Abandon .. OK; + -- This is the type of the final result returned Traverse_Func, based on + -- the results of Process calls. See below for details. + + generic + with function Process (N : Node_Id) return Traverse_Result is <>; + function Traverse_Func (Node : Node_Id) return Traverse_Final_Result; + -- This is a generic function that, given the parent node for a subtree, + -- traverses all syntactic nodes of this tree, calling the given function + -- Process on each one, in pre order (i.e. top-down). The order of + -- traversing subtrees is arbitrary. The traversal is controlled as follows + -- by the result returned by Process: + + -- OK The traversal continues normally with the syntactic + -- children of the node just processed. + + -- OK_Orig The traversal continues normally with the syntactic + -- children of the original node of the node just processed. + + -- Skip The children of the node just processed are skipped and + -- excluded from the traversal, but otherwise processing + -- continues elsewhere in the tree. + + -- Abandon The entire traversal is immediately abandoned, and the + -- original call to Traverse returns Abandon. + + -- The result returned by Traverse is Abandon if processing was terminated + -- by a call to Process returning Abandon, otherwise it is OK (meaning that + -- all calls to process returned either OK, OK_Orig, or Skip). + + generic + with function Process (N : Node_Id) return Traverse_Result is <>; + procedure Traverse_Proc (Node : Node_Id); + pragma Inline (Traverse_Proc); + -- This is the same as Traverse_Func except that no result is returned, + -- i.e. Traverse_Func is called and the result is simply discarded. + + --------------------------- + -- Node Access Functions -- + --------------------------- + + -- The following functions return the contents of the indicated field of + -- the node referenced by the argument, which is a Node_Id. + + function Nkind (N : Node_Id) return Node_Kind; + pragma Inline (Nkind); + + function Analyzed (N : Node_Id) return Boolean; + pragma Inline (Analyzed); + + function Has_Aspects (N : Node_Id) return Boolean; + pragma Inline (Has_Aspects); + + function Comes_From_Source (N : Node_Id) return Boolean; + pragma Inline (Comes_From_Source); + + function Error_Posted (N : Node_Id) return Boolean; + pragma Inline (Error_Posted); + + function Sloc (N : Node_Id) return Source_Ptr; + pragma Inline (Sloc); + + function Paren_Count (N : Node_Id) return Nat; + pragma Inline (Paren_Count); + + function Parent (N : Node_Id) return Node_Id; + pragma Inline (Parent); + -- Returns the parent of a node if the node is not a list member, or else + -- the parent of the list containing the node if the node is a list member. + + function No (N : Node_Id) return Boolean; + pragma Inline (No); + -- Tests given Id for equality with the Empty node. This allows notations + -- like "if No (Variant_Part)" as opposed to "if Variant_Part = Empty". + + function Present (N : Node_Id) return Boolean; + pragma Inline (Present); + -- Tests given Id for inequality with the Empty node. This allows notations + -- like "if Present (Statement)" as opposed to "if Statement /= Empty". + + --------------------- + -- Node_Kind Tests -- + --------------------- + + -- These are like the functions in Sinfo, but the first argument is a + -- Node_Id, and the tested field is Nkind (N). + + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind) return Boolean; + + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind) return Boolean; + + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind) return Boolean; + + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind) return Boolean; + + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind) return Boolean; + + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind; + V7 : Node_Kind) return Boolean; + + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind; + V7 : Node_Kind; + V8 : Node_Kind) return Boolean; + + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind; + V7 : Node_Kind; + V8 : Node_Kind; + V9 : Node_Kind) return Boolean; + + pragma Inline (Nkind_In); + -- Inline all above functions + + ----------------------- + -- Entity_Kind_Tests -- + ----------------------- + + -- Utility functions to test whether an Entity_Kind value, either given + -- directly as the first argument, or the Ekind field of an Entity give + -- as the first argument, matches any of the given list of Entity_Kind + -- values. Return True if any match, False if no match. + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind) return Boolean; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind) return Boolean; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind) return Boolean; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind) return Boolean; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind; + V6 : Entity_Kind) return Boolean; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind) return Boolean; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind) return Boolean; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind) return Boolean; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind) return Boolean; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind; + V6 : Entity_Kind) return Boolean; + + pragma Inline (Ekind_In); + -- Inline all above functions + + ----------------------------- + -- Entity Access Functions -- + ----------------------------- + + -- The following functions apply only to Entity_Id values, i.e. + -- to extended nodes. + + function Ekind (E : Entity_Id) return Entity_Kind; + pragma Inline (Ekind); + + function Convention (E : Entity_Id) return Convention_Id; + pragma Inline (Convention); + + ---------------------------- + -- Node Update Procedures -- + ---------------------------- + + -- The following functions set a specified field in the node whose Id is + -- passed as the first argument. The second parameter is the new value + -- to be set in the specified field. Note that Set_Nkind is in the next + -- section, since its use is restricted. + + procedure Set_Sloc (N : Node_Id; Val : Source_Ptr); + pragma Inline (Set_Sloc); + + procedure Set_Paren_Count (N : Node_Id; Val : Nat); + pragma Inline (Set_Paren_Count); + + procedure Set_Parent (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Parent); + + procedure Set_Analyzed (N : Node_Id; Val : Boolean := True); + pragma Inline (Set_Analyzed); + + procedure Set_Error_Posted (N : Node_Id; Val : Boolean := True); + pragma Inline (Set_Error_Posted); + + procedure Set_Comes_From_Source (N : Node_Id; Val : Boolean); + pragma Inline (Set_Comes_From_Source); + -- Note that this routine is very rarely used, since usually the + -- default mechanism provided sets the right value, but in some + -- unusual cases, the value needs to be reset (e.g. when a source + -- node is copied, and the copy must not have Comes_From_Source set. + + procedure Set_Has_Aspects (N : Node_Id; Val : Boolean := True); + pragma Inline (Set_Has_Aspects); + + ------------------------------ + -- Entity Update Procedures -- + ------------------------------ + + -- The following procedures apply only to Entity_Id values, i.e. + -- to extended nodes. + + procedure Basic_Set_Convention (E : Entity_Id; Val : Convention_Id); + pragma Inline (Basic_Set_Convention); + -- Clients should use Sem_Util.Set_Convention rather than calling this + -- routine directly, as Set_Convention also deals with the special + -- processing required for access types. + + procedure Set_Ekind (E : Entity_Id; Val : Entity_Kind); + pragma Inline (Set_Ekind); + + --------------------------- + -- Tree Rewrite Routines -- + --------------------------- + + -- During the compilation process it is necessary in a number of situations + -- to rewrite the tree. In some cases, such rewrites do not affect the + -- structure of the tree, for example, when an indexed component node is + -- replaced by the corresponding call node (the parser cannot distinguish + -- between these two cases). + + -- In other situations, the rewrite does affect the structure of the + -- tree. Examples are the replacement of a generic instantiation by the + -- instantiated spec and body, and the static evaluation of expressions. + + -- If such structural modifications are done by the expander, there are + -- no difficulties, since the form of the tree after the expander has no + -- special significance, except as input to the backend of the compiler. + -- However, if these modifications are done by the semantic phase, then + -- it is important that they be done in a manner which allows the original + -- tree to be preserved. This is because tools like pretty printers need + -- to have this original tree structure available. + + -- The subprograms in this section allow rewriting of the tree by either + -- insertion of new nodes in an existing list, or complete replacement of + -- a subtree. The resulting tree for most purposes looks as though it has + -- been really changed, and there is no trace of the original. However, + -- special subprograms, also defined in this section, allow the original + -- tree to be reconstructed if necessary. + + -- For tree modifications done in the expander, it is permissible to + -- destroy the original tree, although it is also allowable to use the + -- tree rewrite routines where it is convenient to do so. + + procedure Mark_Rewrite_Insertion (New_Node : Node_Id); + pragma Inline (Mark_Rewrite_Insertion); + -- This procedure marks the given node as an insertion made during a tree + -- rewriting operation. Only the root needs to be marked. The call does + -- not do the actual insertion, which must be done using one of the normal + -- list insertion routines. The node is treated normally in all respects + -- except for its response to Is_Rewrite_Insertion. The function of these + -- calls is to be able to get an accurate original tree. This helps the + -- accuracy of Sprint.Sprint_Node, and in particular, when stubs are being + -- generated, it is essential that the original tree be accurate. + + function Is_Rewrite_Insertion (Node : Node_Id) return Boolean; + pragma Inline (Is_Rewrite_Insertion); + -- Tests whether the given node was marked using Set_Rewrite_Insert. This + -- is used in reconstructing the original tree (where such nodes are to + -- be eliminated from the reconstructed tree). + + procedure Rewrite (Old_Node, New_Node : Node_Id); + -- This is used when a complete subtree is to be replaced. Old_Node is the + -- root of the old subtree to be replaced, and New_Node is the root of the + -- newly constructed replacement subtree. The actual mechanism is to swap + -- the contents of these two nodes fixing up the parent pointers of the + -- replaced node (we do not attempt to preserve parent pointers for the + -- original node). Neither Old_Node nor New_Node can be extended nodes. + -- + -- Note: New_Node may not contain references to Old_Node, for example as + -- descendents, since the rewrite would make such references invalid. If + -- New_Node does need to reference Old_Node, then these references should + -- be to a relocated copy of Old_Node (see Relocate_Node procedure). + -- + -- Note: The Original_Node function applied to Old_Node (which has now + -- been replaced by the contents of New_Node), can be used to obtain the + -- original node, i.e. the old contents of Old_Node. + + procedure Replace (Old_Node, New_Node : Node_Id); + -- This is similar to Rewrite, except that the old value of Old_Node is + -- not saved, and the New_Node is deleted after the replace, since it + -- is assumed that it can no longer be legitimately needed. The flag + -- Is_Rewrite_Substitution will be False for the resulting node, unless + -- it was already true on entry, and Original_Node will not return the + -- original contents of the Old_Node, but rather the New_Node value (unless + -- Old_Node had already been rewritten using Rewrite). Replace also + -- preserves the setting of Comes_From_Source. + -- + -- Note, New_Node may not contain references to Old_Node, for example as + -- descendents, since the rewrite would make such references invalid. If + -- New_Node does need to reference Old_Node, then these references should + -- be to a relocated copy of Old_Node (see Relocate_Node procedure). + -- + -- Replace is used in certain circumstances where it is desirable to + -- suppress any history of the rewriting operation. Notably, it is used + -- when the parser has mis-classified a node (e.g. a task entry call + -- that the parser has parsed as a procedure call). + + function Is_Rewrite_Substitution (Node : Node_Id) return Boolean; + pragma Inline (Is_Rewrite_Substitution); + -- Return True iff Node has been rewritten (i.e. if Node is the root + -- of a subtree which was installed using Rewrite). + + function Original_Node (Node : Node_Id) return Node_Id; + pragma Inline (Original_Node); + -- If Node has not been rewritten, then returns its input argument + -- unchanged, else returns the Node for the original subtree. + -- + -- Note: Parents are not preserved in original tree nodes that are + -- retrieved in this way (i.e. their children may have children whose + -- pointers which reference some other node). + + -- Note: there is no direct mechanism for deleting an original node (in + -- a manner that can be reversed later). One possible approach is to use + -- Rewrite to substitute a null statement for the node to be deleted. + + ----------------------------------- + -- Generic Field Access Routines -- + ----------------------------------- + + -- This subpackage provides the functions for accessing and procedures for + -- setting fields that are normally referenced by their logical synonyms + -- defined in packages Sinfo and Einfo. The implementations of these + -- packages use the package Atree.Unchecked_Access. + + package Unchecked_Access is + + -- Functions to allow interpretation of Union_Id values as Uint + -- and Ureal values + + function To_Union is new Unchecked_Conversion (Uint, Union_Id); + function To_Union is new Unchecked_Conversion (Ureal, Union_Id); + + function From_Union is new Unchecked_Conversion (Union_Id, Uint); + function From_Union is new Unchecked_Conversion (Union_Id, Ureal); + + -- Functions to fetch contents of indicated field. It is an error + -- to attempt to read the value of a field which is not present. + + function Field1 (N : Node_Id) return Union_Id; + pragma Inline (Field1); + + function Field2 (N : Node_Id) return Union_Id; + pragma Inline (Field2); + + function Field3 (N : Node_Id) return Union_Id; + pragma Inline (Field3); + + function Field4 (N : Node_Id) return Union_Id; + pragma Inline (Field4); + + function Field5 (N : Node_Id) return Union_Id; + pragma Inline (Field5); + + function Field6 (N : Node_Id) return Union_Id; + pragma Inline (Field6); + + function Field7 (N : Node_Id) return Union_Id; + pragma Inline (Field7); + + function Field8 (N : Node_Id) return Union_Id; + pragma Inline (Field8); + + function Field9 (N : Node_Id) return Union_Id; + pragma Inline (Field9); + + function Field10 (N : Node_Id) return Union_Id; + pragma Inline (Field10); + + function Field11 (N : Node_Id) return Union_Id; + pragma Inline (Field11); + + function Field12 (N : Node_Id) return Union_Id; + pragma Inline (Field12); + + function Field13 (N : Node_Id) return Union_Id; + pragma Inline (Field13); + + function Field14 (N : Node_Id) return Union_Id; + pragma Inline (Field14); + + function Field15 (N : Node_Id) return Union_Id; + pragma Inline (Field15); + + function Field16 (N : Node_Id) return Union_Id; + pragma Inline (Field16); + + function Field17 (N : Node_Id) return Union_Id; + pragma Inline (Field17); + + function Field18 (N : Node_Id) return Union_Id; + pragma Inline (Field18); + + function Field19 (N : Node_Id) return Union_Id; + pragma Inline (Field19); + + function Field20 (N : Node_Id) return Union_Id; + pragma Inline (Field20); + + function Field21 (N : Node_Id) return Union_Id; + pragma Inline (Field21); + + function Field22 (N : Node_Id) return Union_Id; + pragma Inline (Field22); + + function Field23 (N : Node_Id) return Union_Id; + pragma Inline (Field23); + + function Field24 (N : Node_Id) return Union_Id; + pragma Inline (Field24); + + function Field25 (N : Node_Id) return Union_Id; + pragma Inline (Field25); + + function Field26 (N : Node_Id) return Union_Id; + pragma Inline (Field26); + + function Field27 (N : Node_Id) return Union_Id; + pragma Inline (Field27); + + function Field28 (N : Node_Id) return Union_Id; + pragma Inline (Field28); + + function Field29 (N : Node_Id) return Union_Id; + pragma Inline (Field29); + + function Node1 (N : Node_Id) return Node_Id; + pragma Inline (Node1); + + function Node2 (N : Node_Id) return Node_Id; + pragma Inline (Node2); + + function Node3 (N : Node_Id) return Node_Id; + pragma Inline (Node3); + + function Node4 (N : Node_Id) return Node_Id; + pragma Inline (Node4); + + function Node5 (N : Node_Id) return Node_Id; + pragma Inline (Node5); + + function Node6 (N : Node_Id) return Node_Id; + pragma Inline (Node6); + + function Node7 (N : Node_Id) return Node_Id; + pragma Inline (Node7); + + function Node8 (N : Node_Id) return Node_Id; + pragma Inline (Node8); + + function Node9 (N : Node_Id) return Node_Id; + pragma Inline (Node9); + + function Node10 (N : Node_Id) return Node_Id; + pragma Inline (Node10); + + function Node11 (N : Node_Id) return Node_Id; + pragma Inline (Node11); + + function Node12 (N : Node_Id) return Node_Id; + pragma Inline (Node12); + + function Node13 (N : Node_Id) return Node_Id; + pragma Inline (Node13); + + function Node14 (N : Node_Id) return Node_Id; + pragma Inline (Node14); + + function Node15 (N : Node_Id) return Node_Id; + pragma Inline (Node15); + + function Node16 (N : Node_Id) return Node_Id; + pragma Inline (Node16); + + function Node17 (N : Node_Id) return Node_Id; + pragma Inline (Node17); + + function Node18 (N : Node_Id) return Node_Id; + pragma Inline (Node18); + + function Node19 (N : Node_Id) return Node_Id; + pragma Inline (Node19); + + function Node20 (N : Node_Id) return Node_Id; + pragma Inline (Node20); + + function Node21 (N : Node_Id) return Node_Id; + pragma Inline (Node21); + + function Node22 (N : Node_Id) return Node_Id; + pragma Inline (Node22); + + function Node23 (N : Node_Id) return Node_Id; + pragma Inline (Node23); + + function Node24 (N : Node_Id) return Node_Id; + pragma Inline (Node24); + + function Node25 (N : Node_Id) return Node_Id; + pragma Inline (Node25); + + function Node26 (N : Node_Id) return Node_Id; + pragma Inline (Node26); + + function Node27 (N : Node_Id) return Node_Id; + pragma Inline (Node27); + + function Node28 (N : Node_Id) return Node_Id; + pragma Inline (Node28); + + function Node29 (N : Node_Id) return Node_Id; + pragma Inline (Node29); + + function List1 (N : Node_Id) return List_Id; + pragma Inline (List1); + + function List2 (N : Node_Id) return List_Id; + pragma Inline (List2); + + function List3 (N : Node_Id) return List_Id; + pragma Inline (List3); + + function List4 (N : Node_Id) return List_Id; + pragma Inline (List4); + + function List5 (N : Node_Id) return List_Id; + pragma Inline (List5); + + function List10 (N : Node_Id) return List_Id; + pragma Inline (List10); + + function List14 (N : Node_Id) return List_Id; + pragma Inline (List14); + + function List25 (N : Node_Id) return List_Id; + pragma Inline (List25); + + function Elist1 (N : Node_Id) return Elist_Id; + pragma Inline (Elist1); + + function Elist2 (N : Node_Id) return Elist_Id; + pragma Inline (Elist2); + + function Elist3 (N : Node_Id) return Elist_Id; + pragma Inline (Elist3); + + function Elist4 (N : Node_Id) return Elist_Id; + pragma Inline (Elist4); + + function Elist8 (N : Node_Id) return Elist_Id; + pragma Inline (Elist8); + + function Elist10 (N : Node_Id) return Elist_Id; + pragma Inline (Elist10); + + function Elist13 (N : Node_Id) return Elist_Id; + pragma Inline (Elist13); + + function Elist15 (N : Node_Id) return Elist_Id; + pragma Inline (Elist15); + + function Elist16 (N : Node_Id) return Elist_Id; + pragma Inline (Elist16); + + function Elist18 (N : Node_Id) return Elist_Id; + pragma Inline (Elist18); + + function Elist21 (N : Node_Id) return Elist_Id; + pragma Inline (Elist21); + + function Elist23 (N : Node_Id) return Elist_Id; + pragma Inline (Elist23); + + function Elist25 (N : Node_Id) return Elist_Id; + pragma Inline (Elist25); + + function Elist26 (N : Node_Id) return Elist_Id; + pragma Inline (Elist26); + + function Name1 (N : Node_Id) return Name_Id; + pragma Inline (Name1); + + function Name2 (N : Node_Id) return Name_Id; + pragma Inline (Name2); + + function Str3 (N : Node_Id) return String_Id; + pragma Inline (Str3); + + -- Note: the following Uintnn functions have a special test for + -- the Field value being Empty. If an Empty value is found then + -- Uint_0 is returned. This avoids the rather tricky requirement + -- of initializing all Uint fields in nodes and entities. + + function Uint2 (N : Node_Id) return Uint; + pragma Inline (Uint2); + + function Uint3 (N : Node_Id) return Uint; + pragma Inline (Uint3); + + function Uint4 (N : Node_Id) return Uint; + pragma Inline (Uint4); + + function Uint5 (N : Node_Id) return Uint; + pragma Inline (Uint5); + + function Uint8 (N : Node_Id) return Uint; + pragma Inline (Uint8); + + function Uint9 (N : Node_Id) return Uint; + pragma Inline (Uint9); + + function Uint10 (N : Node_Id) return Uint; + pragma Inline (Uint10); + + function Uint11 (N : Node_Id) return Uint; + pragma Inline (Uint11); + + function Uint12 (N : Node_Id) return Uint; + pragma Inline (Uint12); + + function Uint13 (N : Node_Id) return Uint; + pragma Inline (Uint13); + + function Uint14 (N : Node_Id) return Uint; + pragma Inline (Uint14); + + function Uint15 (N : Node_Id) return Uint; + pragma Inline (Uint15); + + function Uint16 (N : Node_Id) return Uint; + pragma Inline (Uint16); + + function Uint17 (N : Node_Id) return Uint; + pragma Inline (Uint17); + + function Uint22 (N : Node_Id) return Uint; + pragma Inline (Uint22); + + function Ureal3 (N : Node_Id) return Ureal; + pragma Inline (Ureal3); + + function Ureal18 (N : Node_Id) return Ureal; + pragma Inline (Ureal18); + + function Ureal21 (N : Node_Id) return Ureal; + pragma Inline (Ureal21); + + function Flag4 (N : Node_Id) return Boolean; + pragma Inline (Flag4); + + function Flag5 (N : Node_Id) return Boolean; + pragma Inline (Flag5); + + function Flag6 (N : Node_Id) return Boolean; + pragma Inline (Flag6); + + function Flag7 (N : Node_Id) return Boolean; + pragma Inline (Flag7); + + function Flag8 (N : Node_Id) return Boolean; + pragma Inline (Flag8); + + function Flag9 (N : Node_Id) return Boolean; + pragma Inline (Flag9); + + function Flag10 (N : Node_Id) return Boolean; + pragma Inline (Flag10); + + function Flag11 (N : Node_Id) return Boolean; + pragma Inline (Flag11); + + function Flag12 (N : Node_Id) return Boolean; + pragma Inline (Flag12); + + function Flag13 (N : Node_Id) return Boolean; + pragma Inline (Flag13); + + function Flag14 (N : Node_Id) return Boolean; + pragma Inline (Flag14); + + function Flag15 (N : Node_Id) return Boolean; + pragma Inline (Flag15); + + function Flag16 (N : Node_Id) return Boolean; + pragma Inline (Flag16); + + function Flag17 (N : Node_Id) return Boolean; + pragma Inline (Flag17); + + function Flag18 (N : Node_Id) return Boolean; + pragma Inline (Flag18); + + function Flag19 (N : Node_Id) return Boolean; + pragma Inline (Flag19); + + function Flag20 (N : Node_Id) return Boolean; + pragma Inline (Flag20); + + function Flag21 (N : Node_Id) return Boolean; + pragma Inline (Flag21); + + function Flag22 (N : Node_Id) return Boolean; + pragma Inline (Flag22); + + function Flag23 (N : Node_Id) return Boolean; + pragma Inline (Flag23); + + function Flag24 (N : Node_Id) return Boolean; + pragma Inline (Flag24); + + function Flag25 (N : Node_Id) return Boolean; + pragma Inline (Flag25); + + function Flag26 (N : Node_Id) return Boolean; + pragma Inline (Flag26); + + function Flag27 (N : Node_Id) return Boolean; + pragma Inline (Flag27); + + function Flag28 (N : Node_Id) return Boolean; + pragma Inline (Flag28); + + function Flag29 (N : Node_Id) return Boolean; + pragma Inline (Flag29); + + function Flag30 (N : Node_Id) return Boolean; + pragma Inline (Flag30); + + function Flag31 (N : Node_Id) return Boolean; + pragma Inline (Flag31); + + function Flag32 (N : Node_Id) return Boolean; + pragma Inline (Flag32); + + function Flag33 (N : Node_Id) return Boolean; + pragma Inline (Flag33); + + function Flag34 (N : Node_Id) return Boolean; + pragma Inline (Flag34); + + function Flag35 (N : Node_Id) return Boolean; + pragma Inline (Flag35); + + function Flag36 (N : Node_Id) return Boolean; + pragma Inline (Flag36); + + function Flag37 (N : Node_Id) return Boolean; + pragma Inline (Flag37); + + function Flag38 (N : Node_Id) return Boolean; + pragma Inline (Flag38); + + function Flag39 (N : Node_Id) return Boolean; + pragma Inline (Flag39); + + function Flag40 (N : Node_Id) return Boolean; + pragma Inline (Flag40); + + function Flag41 (N : Node_Id) return Boolean; + pragma Inline (Flag41); + + function Flag42 (N : Node_Id) return Boolean; + pragma Inline (Flag42); + + function Flag43 (N : Node_Id) return Boolean; + pragma Inline (Flag43); + + function Flag44 (N : Node_Id) return Boolean; + pragma Inline (Flag44); + + function Flag45 (N : Node_Id) return Boolean; + pragma Inline (Flag45); + + function Flag46 (N : Node_Id) return Boolean; + pragma Inline (Flag46); + + function Flag47 (N : Node_Id) return Boolean; + pragma Inline (Flag47); + + function Flag48 (N : Node_Id) return Boolean; + pragma Inline (Flag48); + + function Flag49 (N : Node_Id) return Boolean; + pragma Inline (Flag49); + + function Flag50 (N : Node_Id) return Boolean; + pragma Inline (Flag50); + + function Flag51 (N : Node_Id) return Boolean; + pragma Inline (Flag51); + + function Flag52 (N : Node_Id) return Boolean; + pragma Inline (Flag52); + + function Flag53 (N : Node_Id) return Boolean; + pragma Inline (Flag53); + + function Flag54 (N : Node_Id) return Boolean; + pragma Inline (Flag54); + + function Flag55 (N : Node_Id) return Boolean; + pragma Inline (Flag55); + + function Flag56 (N : Node_Id) return Boolean; + pragma Inline (Flag56); + + function Flag57 (N : Node_Id) return Boolean; + pragma Inline (Flag57); + + function Flag58 (N : Node_Id) return Boolean; + pragma Inline (Flag58); + + function Flag59 (N : Node_Id) return Boolean; + pragma Inline (Flag59); + + function Flag60 (N : Node_Id) return Boolean; + pragma Inline (Flag60); + + function Flag61 (N : Node_Id) return Boolean; + pragma Inline (Flag61); + + function Flag62 (N : Node_Id) return Boolean; + pragma Inline (Flag62); + + function Flag63 (N : Node_Id) return Boolean; + pragma Inline (Flag63); + + function Flag64 (N : Node_Id) return Boolean; + pragma Inline (Flag64); + + function Flag65 (N : Node_Id) return Boolean; + pragma Inline (Flag65); + + function Flag66 (N : Node_Id) return Boolean; + pragma Inline (Flag66); + + function Flag67 (N : Node_Id) return Boolean; + pragma Inline (Flag67); + + function Flag68 (N : Node_Id) return Boolean; + pragma Inline (Flag68); + + function Flag69 (N : Node_Id) return Boolean; + pragma Inline (Flag69); + + function Flag70 (N : Node_Id) return Boolean; + pragma Inline (Flag70); + + function Flag71 (N : Node_Id) return Boolean; + pragma Inline (Flag71); + + function Flag72 (N : Node_Id) return Boolean; + pragma Inline (Flag72); + + function Flag73 (N : Node_Id) return Boolean; + pragma Inline (Flag73); + + function Flag74 (N : Node_Id) return Boolean; + pragma Inline (Flag74); + + function Flag75 (N : Node_Id) return Boolean; + pragma Inline (Flag75); + + function Flag76 (N : Node_Id) return Boolean; + pragma Inline (Flag76); + + function Flag77 (N : Node_Id) return Boolean; + pragma Inline (Flag77); + + function Flag78 (N : Node_Id) return Boolean; + pragma Inline (Flag78); + + function Flag79 (N : Node_Id) return Boolean; + pragma Inline (Flag79); + + function Flag80 (N : Node_Id) return Boolean; + pragma Inline (Flag80); + + function Flag81 (N : Node_Id) return Boolean; + pragma Inline (Flag81); + + function Flag82 (N : Node_Id) return Boolean; + pragma Inline (Flag82); + + function Flag83 (N : Node_Id) return Boolean; + pragma Inline (Flag83); + + function Flag84 (N : Node_Id) return Boolean; + pragma Inline (Flag84); + + function Flag85 (N : Node_Id) return Boolean; + pragma Inline (Flag85); + + function Flag86 (N : Node_Id) return Boolean; + pragma Inline (Flag86); + + function Flag87 (N : Node_Id) return Boolean; + pragma Inline (Flag87); + + function Flag88 (N : Node_Id) return Boolean; + pragma Inline (Flag88); + + function Flag89 (N : Node_Id) return Boolean; + pragma Inline (Flag89); + + function Flag90 (N : Node_Id) return Boolean; + pragma Inline (Flag90); + + function Flag91 (N : Node_Id) return Boolean; + pragma Inline (Flag91); + + function Flag92 (N : Node_Id) return Boolean; + pragma Inline (Flag92); + + function Flag93 (N : Node_Id) return Boolean; + pragma Inline (Flag93); + + function Flag94 (N : Node_Id) return Boolean; + pragma Inline (Flag94); + + function Flag95 (N : Node_Id) return Boolean; + pragma Inline (Flag95); + + function Flag96 (N : Node_Id) return Boolean; + pragma Inline (Flag96); + + function Flag97 (N : Node_Id) return Boolean; + pragma Inline (Flag97); + + function Flag98 (N : Node_Id) return Boolean; + pragma Inline (Flag98); + + function Flag99 (N : Node_Id) return Boolean; + pragma Inline (Flag99); + + function Flag100 (N : Node_Id) return Boolean; + pragma Inline (Flag100); + + function Flag101 (N : Node_Id) return Boolean; + pragma Inline (Flag101); + + function Flag102 (N : Node_Id) return Boolean; + pragma Inline (Flag102); + + function Flag103 (N : Node_Id) return Boolean; + pragma Inline (Flag103); + + function Flag104 (N : Node_Id) return Boolean; + pragma Inline (Flag104); + + function Flag105 (N : Node_Id) return Boolean; + pragma Inline (Flag105); + + function Flag106 (N : Node_Id) return Boolean; + pragma Inline (Flag106); + + function Flag107 (N : Node_Id) return Boolean; + pragma Inline (Flag107); + + function Flag108 (N : Node_Id) return Boolean; + pragma Inline (Flag108); + + function Flag109 (N : Node_Id) return Boolean; + pragma Inline (Flag109); + + function Flag110 (N : Node_Id) return Boolean; + pragma Inline (Flag110); + + function Flag111 (N : Node_Id) return Boolean; + pragma Inline (Flag111); + + function Flag112 (N : Node_Id) return Boolean; + pragma Inline (Flag112); + + function Flag113 (N : Node_Id) return Boolean; + pragma Inline (Flag113); + + function Flag114 (N : Node_Id) return Boolean; + pragma Inline (Flag114); + + function Flag115 (N : Node_Id) return Boolean; + pragma Inline (Flag115); + + function Flag116 (N : Node_Id) return Boolean; + pragma Inline (Flag116); + + function Flag117 (N : Node_Id) return Boolean; + pragma Inline (Flag117); + + function Flag118 (N : Node_Id) return Boolean; + pragma Inline (Flag118); + + function Flag119 (N : Node_Id) return Boolean; + pragma Inline (Flag119); + + function Flag120 (N : Node_Id) return Boolean; + pragma Inline (Flag120); + + function Flag121 (N : Node_Id) return Boolean; + pragma Inline (Flag121); + + function Flag122 (N : Node_Id) return Boolean; + pragma Inline (Flag122); + + function Flag123 (N : Node_Id) return Boolean; + pragma Inline (Flag123); + + function Flag124 (N : Node_Id) return Boolean; + pragma Inline (Flag124); + + function Flag125 (N : Node_Id) return Boolean; + pragma Inline (Flag125); + + function Flag126 (N : Node_Id) return Boolean; + pragma Inline (Flag126); + + function Flag127 (N : Node_Id) return Boolean; + pragma Inline (Flag127); + + function Flag128 (N : Node_Id) return Boolean; + pragma Inline (Flag128); + + function Flag129 (N : Node_Id) return Boolean; + pragma Inline (Flag129); + + function Flag130 (N : Node_Id) return Boolean; + pragma Inline (Flag130); + + function Flag131 (N : Node_Id) return Boolean; + pragma Inline (Flag131); + + function Flag132 (N : Node_Id) return Boolean; + pragma Inline (Flag132); + + function Flag133 (N : Node_Id) return Boolean; + pragma Inline (Flag133); + + function Flag134 (N : Node_Id) return Boolean; + pragma Inline (Flag134); + + function Flag135 (N : Node_Id) return Boolean; + pragma Inline (Flag135); + + function Flag136 (N : Node_Id) return Boolean; + pragma Inline (Flag136); + + function Flag137 (N : Node_Id) return Boolean; + pragma Inline (Flag137); + + function Flag138 (N : Node_Id) return Boolean; + pragma Inline (Flag138); + + function Flag139 (N : Node_Id) return Boolean; + pragma Inline (Flag139); + + function Flag140 (N : Node_Id) return Boolean; + pragma Inline (Flag140); + + function Flag141 (N : Node_Id) return Boolean; + pragma Inline (Flag141); + + function Flag142 (N : Node_Id) return Boolean; + pragma Inline (Flag142); + + function Flag143 (N : Node_Id) return Boolean; + pragma Inline (Flag143); + + function Flag144 (N : Node_Id) return Boolean; + pragma Inline (Flag144); + + function Flag145 (N : Node_Id) return Boolean; + pragma Inline (Flag145); + + function Flag146 (N : Node_Id) return Boolean; + pragma Inline (Flag146); + + function Flag147 (N : Node_Id) return Boolean; + pragma Inline (Flag147); + + function Flag148 (N : Node_Id) return Boolean; + pragma Inline (Flag148); + + function Flag149 (N : Node_Id) return Boolean; + pragma Inline (Flag149); + + function Flag150 (N : Node_Id) return Boolean; + pragma Inline (Flag150); + + function Flag151 (N : Node_Id) return Boolean; + pragma Inline (Flag151); + + function Flag152 (N : Node_Id) return Boolean; + pragma Inline (Flag152); + + function Flag153 (N : Node_Id) return Boolean; + pragma Inline (Flag153); + + function Flag154 (N : Node_Id) return Boolean; + pragma Inline (Flag154); + + function Flag155 (N : Node_Id) return Boolean; + pragma Inline (Flag155); + + function Flag156 (N : Node_Id) return Boolean; + pragma Inline (Flag156); + + function Flag157 (N : Node_Id) return Boolean; + pragma Inline (Flag157); + + function Flag158 (N : Node_Id) return Boolean; + pragma Inline (Flag158); + + function Flag159 (N : Node_Id) return Boolean; + pragma Inline (Flag159); + + function Flag160 (N : Node_Id) return Boolean; + pragma Inline (Flag160); + + function Flag161 (N : Node_Id) return Boolean; + pragma Inline (Flag161); + + function Flag162 (N : Node_Id) return Boolean; + pragma Inline (Flag162); + + function Flag163 (N : Node_Id) return Boolean; + pragma Inline (Flag163); + + function Flag164 (N : Node_Id) return Boolean; + pragma Inline (Flag164); + + function Flag165 (N : Node_Id) return Boolean; + pragma Inline (Flag165); + + function Flag166 (N : Node_Id) return Boolean; + pragma Inline (Flag166); + + function Flag167 (N : Node_Id) return Boolean; + pragma Inline (Flag167); + + function Flag168 (N : Node_Id) return Boolean; + pragma Inline (Flag168); + + function Flag169 (N : Node_Id) return Boolean; + pragma Inline (Flag169); + + function Flag170 (N : Node_Id) return Boolean; + pragma Inline (Flag170); + + function Flag171 (N : Node_Id) return Boolean; + pragma Inline (Flag171); + + function Flag172 (N : Node_Id) return Boolean; + pragma Inline (Flag172); + + function Flag173 (N : Node_Id) return Boolean; + pragma Inline (Flag173); + + function Flag174 (N : Node_Id) return Boolean; + pragma Inline (Flag174); + + function Flag175 (N : Node_Id) return Boolean; + pragma Inline (Flag175); + + function Flag176 (N : Node_Id) return Boolean; + pragma Inline (Flag176); + + function Flag177 (N : Node_Id) return Boolean; + pragma Inline (Flag177); + + function Flag178 (N : Node_Id) return Boolean; + pragma Inline (Flag178); + + function Flag179 (N : Node_Id) return Boolean; + pragma Inline (Flag179); + + function Flag180 (N : Node_Id) return Boolean; + pragma Inline (Flag180); + + function Flag181 (N : Node_Id) return Boolean; + pragma Inline (Flag181); + + function Flag182 (N : Node_Id) return Boolean; + pragma Inline (Flag182); + + function Flag183 (N : Node_Id) return Boolean; + pragma Inline (Flag183); + + function Flag184 (N : Node_Id) return Boolean; + pragma Inline (Flag184); + + function Flag185 (N : Node_Id) return Boolean; + pragma Inline (Flag185); + + function Flag186 (N : Node_Id) return Boolean; + pragma Inline (Flag186); + + function Flag187 (N : Node_Id) return Boolean; + pragma Inline (Flag187); + + function Flag188 (N : Node_Id) return Boolean; + pragma Inline (Flag188); + + function Flag189 (N : Node_Id) return Boolean; + pragma Inline (Flag189); + + function Flag190 (N : Node_Id) return Boolean; + pragma Inline (Flag190); + + function Flag191 (N : Node_Id) return Boolean; + pragma Inline (Flag191); + + function Flag192 (N : Node_Id) return Boolean; + pragma Inline (Flag192); + + function Flag193 (N : Node_Id) return Boolean; + pragma Inline (Flag193); + + function Flag194 (N : Node_Id) return Boolean; + pragma Inline (Flag194); + + function Flag195 (N : Node_Id) return Boolean; + pragma Inline (Flag195); + + function Flag196 (N : Node_Id) return Boolean; + pragma Inline (Flag196); + + function Flag197 (N : Node_Id) return Boolean; + pragma Inline (Flag197); + + function Flag198 (N : Node_Id) return Boolean; + pragma Inline (Flag198); + + function Flag199 (N : Node_Id) return Boolean; + pragma Inline (Flag199); + + function Flag200 (N : Node_Id) return Boolean; + pragma Inline (Flag200); + + function Flag201 (N : Node_Id) return Boolean; + pragma Inline (Flag201); + + function Flag202 (N : Node_Id) return Boolean; + pragma Inline (Flag202); + + function Flag203 (N : Node_Id) return Boolean; + pragma Inline (Flag203); + + function Flag204 (N : Node_Id) return Boolean; + pragma Inline (Flag204); + + function Flag205 (N : Node_Id) return Boolean; + pragma Inline (Flag205); + + function Flag206 (N : Node_Id) return Boolean; + pragma Inline (Flag206); + + function Flag207 (N : Node_Id) return Boolean; + pragma Inline (Flag207); + + function Flag208 (N : Node_Id) return Boolean; + pragma Inline (Flag208); + + function Flag209 (N : Node_Id) return Boolean; + pragma Inline (Flag209); + + function Flag210 (N : Node_Id) return Boolean; + pragma Inline (Flag210); + + function Flag211 (N : Node_Id) return Boolean; + pragma Inline (Flag211); + + function Flag212 (N : Node_Id) return Boolean; + pragma Inline (Flag212); + + function Flag213 (N : Node_Id) return Boolean; + pragma Inline (Flag213); + + function Flag214 (N : Node_Id) return Boolean; + pragma Inline (Flag214); + + function Flag215 (N : Node_Id) return Boolean; + pragma Inline (Flag215); + + function Flag216 (N : Node_Id) return Boolean; + pragma Inline (Flag216); + + function Flag217 (N : Node_Id) return Boolean; + pragma Inline (Flag217); + + function Flag218 (N : Node_Id) return Boolean; + pragma Inline (Flag218); + + function Flag219 (N : Node_Id) return Boolean; + pragma Inline (Flag219); + + function Flag220 (N : Node_Id) return Boolean; + pragma Inline (Flag220); + + function Flag221 (N : Node_Id) return Boolean; + pragma Inline (Flag221); + + function Flag222 (N : Node_Id) return Boolean; + pragma Inline (Flag222); + + function Flag223 (N : Node_Id) return Boolean; + pragma Inline (Flag223); + + function Flag224 (N : Node_Id) return Boolean; + pragma Inline (Flag224); + + function Flag225 (N : Node_Id) return Boolean; + pragma Inline (Flag225); + + function Flag226 (N : Node_Id) return Boolean; + pragma Inline (Flag226); + + function Flag227 (N : Node_Id) return Boolean; + pragma Inline (Flag227); + + function Flag228 (N : Node_Id) return Boolean; + pragma Inline (Flag228); + + function Flag229 (N : Node_Id) return Boolean; + pragma Inline (Flag229); + + function Flag230 (N : Node_Id) return Boolean; + pragma Inline (Flag230); + + function Flag231 (N : Node_Id) return Boolean; + pragma Inline (Flag231); + + function Flag232 (N : Node_Id) return Boolean; + pragma Inline (Flag232); + + function Flag233 (N : Node_Id) return Boolean; + pragma Inline (Flag233); + + function Flag234 (N : Node_Id) return Boolean; + pragma Inline (Flag234); + + function Flag235 (N : Node_Id) return Boolean; + pragma Inline (Flag235); + + function Flag236 (N : Node_Id) return Boolean; + pragma Inline (Flag236); + + function Flag237 (N : Node_Id) return Boolean; + pragma Inline (Flag237); + + function Flag238 (N : Node_Id) return Boolean; + pragma Inline (Flag238); + + function Flag239 (N : Node_Id) return Boolean; + pragma Inline (Flag239); + + function Flag240 (N : Node_Id) return Boolean; + pragma Inline (Flag240); + + function Flag241 (N : Node_Id) return Boolean; + pragma Inline (Flag241); + + function Flag242 (N : Node_Id) return Boolean; + pragma Inline (Flag242); + + function Flag243 (N : Node_Id) return Boolean; + pragma Inline (Flag243); + + function Flag244 (N : Node_Id) return Boolean; + pragma Inline (Flag244); + + function Flag245 (N : Node_Id) return Boolean; + pragma Inline (Flag245); + + function Flag246 (N : Node_Id) return Boolean; + pragma Inline (Flag246); + + function Flag247 (N : Node_Id) return Boolean; + pragma Inline (Flag247); + + function Flag248 (N : Node_Id) return Boolean; + pragma Inline (Flag248); + + function Flag249 (N : Node_Id) return Boolean; + pragma Inline (Flag249); + + function Flag250 (N : Node_Id) return Boolean; + pragma Inline (Flag250); + + function Flag251 (N : Node_Id) return Boolean; + pragma Inline (Flag251); + + function Flag252 (N : Node_Id) return Boolean; + pragma Inline (Flag252); + + function Flag253 (N : Node_Id) return Boolean; + pragma Inline (Flag253); + + function Flag254 (N : Node_Id) return Boolean; + pragma Inline (Flag254); + + -- Procedures to set value of indicated field + + procedure Set_Nkind (N : Node_Id; Val : Node_Kind); + pragma Inline (Set_Nkind); + + procedure Set_Field1 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field1); + + procedure Set_Field2 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field2); + + procedure Set_Field3 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field3); + + procedure Set_Field4 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field4); + + procedure Set_Field5 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field5); + + procedure Set_Field6 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field6); + + procedure Set_Field7 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field7); + + procedure Set_Field8 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field8); + + procedure Set_Field9 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field9); + + procedure Set_Field10 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field10); + + procedure Set_Field11 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field11); + + procedure Set_Field12 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field12); + + procedure Set_Field13 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field13); + + procedure Set_Field14 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field14); + + procedure Set_Field15 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field15); + + procedure Set_Field16 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field16); + + procedure Set_Field17 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field17); + + procedure Set_Field18 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field18); + + procedure Set_Field19 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field19); + + procedure Set_Field20 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field20); + + procedure Set_Field21 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field21); + + procedure Set_Field22 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field22); + + procedure Set_Field23 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field23); + + procedure Set_Field24 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field24); + + procedure Set_Field25 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field25); + + procedure Set_Field26 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field26); + + procedure Set_Field27 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field27); + + procedure Set_Field28 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field28); + + procedure Set_Field29 (N : Node_Id; Val : Union_Id); + pragma Inline (Set_Field29); + + procedure Set_Node1 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node1); + + procedure Set_Node2 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node2); + + procedure Set_Node3 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node3); + + procedure Set_Node4 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node4); + + procedure Set_Node5 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node5); + + procedure Set_Node6 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node6); + + procedure Set_Node7 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node7); + + procedure Set_Node8 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node8); + + procedure Set_Node9 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node9); + + procedure Set_Node10 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node10); + + procedure Set_Node11 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node11); + + procedure Set_Node12 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node12); + + procedure Set_Node13 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node13); + + procedure Set_Node14 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node14); + + procedure Set_Node15 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node15); + + procedure Set_Node16 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node16); + + procedure Set_Node17 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node17); + + procedure Set_Node18 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node18); + + procedure Set_Node19 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node19); + + procedure Set_Node20 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node20); + + procedure Set_Node21 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node21); + + procedure Set_Node22 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node22); + + procedure Set_Node23 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node23); + + procedure Set_Node24 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node24); + + procedure Set_Node25 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node25); + + procedure Set_Node26 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node26); + + procedure Set_Node27 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node27); + + procedure Set_Node28 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node28); + + procedure Set_Node29 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node29); + + procedure Set_List1 (N : Node_Id; Val : List_Id); + pragma Inline (Set_List1); + + procedure Set_List2 (N : Node_Id; Val : List_Id); + pragma Inline (Set_List2); + + procedure Set_List3 (N : Node_Id; Val : List_Id); + pragma Inline (Set_List3); + + procedure Set_List4 (N : Node_Id; Val : List_Id); + pragma Inline (Set_List4); + + procedure Set_List5 (N : Node_Id; Val : List_Id); + pragma Inline (Set_List5); + + procedure Set_List10 (N : Node_Id; Val : List_Id); + pragma Inline (Set_List10); + + procedure Set_List14 (N : Node_Id; Val : List_Id); + pragma Inline (Set_List14); + + procedure Set_List25 (N : Node_Id; Val : List_Id); + pragma Inline (Set_List25); + + procedure Set_Elist1 (N : Node_Id; Val : Elist_Id); + pragma Inline (Set_Elist1); + + procedure Set_Elist2 (N : Node_Id; Val : Elist_Id); + pragma Inline (Set_Elist2); + + procedure Set_Elist3 (N : Node_Id; Val : Elist_Id); + pragma Inline (Set_Elist3); + + procedure Set_Elist4 (N : Node_Id; Val : Elist_Id); + pragma Inline (Set_Elist4); + + procedure Set_Elist8 (N : Node_Id; Val : Elist_Id); + pragma Inline (Set_Elist8); + + procedure Set_Elist10 (N : Node_Id; Val : Elist_Id); + pragma Inline (Set_Elist10); + + procedure Set_Elist13 (N : Node_Id; Val : Elist_Id); + pragma Inline (Set_Elist13); + + procedure Set_Elist15 (N : Node_Id; Val : Elist_Id); + pragma Inline (Set_Elist15); + + procedure Set_Elist16 (N : Node_Id; Val : Elist_Id); + pragma Inline (Set_Elist16); + + procedure Set_Elist18 (N : Node_Id; Val : Elist_Id); + pragma Inline (Set_Elist18); + + procedure Set_Elist21 (N : Node_Id; Val : Elist_Id); + pragma Inline (Set_Elist21); + + procedure Set_Elist23 (N : Node_Id; Val : Elist_Id); + pragma Inline (Set_Elist23); + + procedure Set_Elist25 (N : Node_Id; Val : Elist_Id); + pragma Inline (Set_Elist25); + + procedure Set_Elist26 (N : Node_Id; Val : Elist_Id); + pragma Inline (Set_Elist26); + + procedure Set_Name1 (N : Node_Id; Val : Name_Id); + pragma Inline (Set_Name1); + + procedure Set_Name2 (N : Node_Id; Val : Name_Id); + pragma Inline (Set_Name2); + + procedure Set_Str3 (N : Node_Id; Val : String_Id); + pragma Inline (Set_Str3); + + procedure Set_Uint2 (N : Node_Id; Val : Uint); + pragma Inline (Set_Uint2); + + procedure Set_Uint3 (N : Node_Id; Val : Uint); + pragma Inline (Set_Uint3); + + procedure Set_Uint4 (N : Node_Id; Val : Uint); + pragma Inline (Set_Uint4); + + procedure Set_Uint5 (N : Node_Id; Val : Uint); + pragma Inline (Set_Uint5); + + procedure Set_Uint8 (N : Node_Id; Val : Uint); + pragma Inline (Set_Uint8); + + procedure Set_Uint9 (N : Node_Id; Val : Uint); + pragma Inline (Set_Uint9); + + procedure Set_Uint10 (N : Node_Id; Val : Uint); + pragma Inline (Set_Uint10); + + procedure Set_Uint11 (N : Node_Id; Val : Uint); + pragma Inline (Set_Uint11); + + procedure Set_Uint12 (N : Node_Id; Val : Uint); + pragma Inline (Set_Uint12); + + procedure Set_Uint13 (N : Node_Id; Val : Uint); + pragma Inline (Set_Uint13); + + procedure Set_Uint14 (N : Node_Id; Val : Uint); + pragma Inline (Set_Uint14); + + procedure Set_Uint15 (N : Node_Id; Val : Uint); + pragma Inline (Set_Uint15); + + procedure Set_Uint16 (N : Node_Id; Val : Uint); + pragma Inline (Set_Uint16); + + procedure Set_Uint17 (N : Node_Id; Val : Uint); + pragma Inline (Set_Uint17); + + procedure Set_Uint22 (N : Node_Id; Val : Uint); + pragma Inline (Set_Uint22); + + procedure Set_Ureal3 (N : Node_Id; Val : Ureal); + pragma Inline (Set_Ureal3); + + procedure Set_Ureal18 (N : Node_Id; Val : Ureal); + pragma Inline (Set_Ureal18); + + procedure Set_Ureal21 (N : Node_Id; Val : Ureal); + pragma Inline (Set_Ureal21); + + procedure Set_Flag4 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag4); + + procedure Set_Flag5 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag5); + + procedure Set_Flag6 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag6); + + procedure Set_Flag7 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag7); + + procedure Set_Flag8 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag8); + + procedure Set_Flag9 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag9); + + procedure Set_Flag10 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag10); + + procedure Set_Flag11 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag11); + + procedure Set_Flag12 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag12); + + procedure Set_Flag13 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag13); + + procedure Set_Flag14 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag14); + + procedure Set_Flag15 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag15); + + procedure Set_Flag16 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag16); + + procedure Set_Flag17 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag17); + + procedure Set_Flag18 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag18); + + procedure Set_Flag19 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag19); + + procedure Set_Flag20 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag20); + + procedure Set_Flag21 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag21); + + procedure Set_Flag22 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag22); + + procedure Set_Flag23 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag23); + + procedure Set_Flag24 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag24); + + procedure Set_Flag25 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag25); + + procedure Set_Flag26 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag26); + + procedure Set_Flag27 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag27); + + procedure Set_Flag28 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag28); + + procedure Set_Flag29 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag29); + + procedure Set_Flag30 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag30); + + procedure Set_Flag31 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag31); + + procedure Set_Flag32 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag32); + + procedure Set_Flag33 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag33); + + procedure Set_Flag34 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag34); + + procedure Set_Flag35 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag35); + + procedure Set_Flag36 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag36); + + procedure Set_Flag37 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag37); + + procedure Set_Flag38 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag38); + + procedure Set_Flag39 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag39); + + procedure Set_Flag40 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag40); + + procedure Set_Flag41 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag41); + + procedure Set_Flag42 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag42); + + procedure Set_Flag43 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag43); + + procedure Set_Flag44 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag44); + + procedure Set_Flag45 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag45); + + procedure Set_Flag46 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag46); + + procedure Set_Flag47 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag47); + + procedure Set_Flag48 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag48); + + procedure Set_Flag49 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag49); + + procedure Set_Flag50 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag50); + + procedure Set_Flag51 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag51); + + procedure Set_Flag52 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag52); + + procedure Set_Flag53 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag53); + + procedure Set_Flag54 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag54); + + procedure Set_Flag55 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag55); + + procedure Set_Flag56 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag56); + + procedure Set_Flag57 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag57); + + procedure Set_Flag58 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag58); + + procedure Set_Flag59 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag59); + + procedure Set_Flag60 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag60); + + procedure Set_Flag61 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag61); + + procedure Set_Flag62 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag62); + + procedure Set_Flag63 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag63); + + procedure Set_Flag64 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag64); + + procedure Set_Flag65 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag65); + + procedure Set_Flag66 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag66); + + procedure Set_Flag67 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag67); + + procedure Set_Flag68 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag68); + + procedure Set_Flag69 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag69); + + procedure Set_Flag70 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag70); + + procedure Set_Flag71 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag71); + + procedure Set_Flag72 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag72); + + procedure Set_Flag73 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag73); + + procedure Set_Flag74 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag74); + + procedure Set_Flag75 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag75); + + procedure Set_Flag76 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag76); + + procedure Set_Flag77 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag77); + + procedure Set_Flag78 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag78); + + procedure Set_Flag79 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag79); + + procedure Set_Flag80 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag80); + + procedure Set_Flag81 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag81); + + procedure Set_Flag82 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag82); + + procedure Set_Flag83 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag83); + + procedure Set_Flag84 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag84); + + procedure Set_Flag85 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag85); + + procedure Set_Flag86 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag86); + + procedure Set_Flag87 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag87); + + procedure Set_Flag88 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag88); + + procedure Set_Flag89 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag89); + + procedure Set_Flag90 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag90); + + procedure Set_Flag91 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag91); + + procedure Set_Flag92 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag92); + + procedure Set_Flag93 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag93); + + procedure Set_Flag94 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag94); + + procedure Set_Flag95 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag95); + + procedure Set_Flag96 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag96); + + procedure Set_Flag97 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag97); + + procedure Set_Flag98 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag98); + + procedure Set_Flag99 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag99); + + procedure Set_Flag100 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag100); + + procedure Set_Flag101 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag101); + + procedure Set_Flag102 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag102); + + procedure Set_Flag103 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag103); + + procedure Set_Flag104 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag104); + + procedure Set_Flag105 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag105); + + procedure Set_Flag106 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag106); + + procedure Set_Flag107 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag107); + + procedure Set_Flag108 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag108); + + procedure Set_Flag109 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag109); + + procedure Set_Flag110 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag110); + + procedure Set_Flag111 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag111); + + procedure Set_Flag112 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag112); + + procedure Set_Flag113 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag113); + + procedure Set_Flag114 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag114); + + procedure Set_Flag115 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag115); + + procedure Set_Flag116 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag116); + + procedure Set_Flag117 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag117); + + procedure Set_Flag118 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag118); + + procedure Set_Flag119 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag119); + + procedure Set_Flag120 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag120); + + procedure Set_Flag121 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag121); + + procedure Set_Flag122 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag122); + + procedure Set_Flag123 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag123); + + procedure Set_Flag124 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag124); + + procedure Set_Flag125 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag125); + + procedure Set_Flag126 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag126); + + procedure Set_Flag127 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag127); + + procedure Set_Flag128 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag128); + + procedure Set_Flag129 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag129); + + procedure Set_Flag130 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag130); + + procedure Set_Flag131 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag131); + + procedure Set_Flag132 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag132); + + procedure Set_Flag133 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag133); + + procedure Set_Flag134 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag134); + + procedure Set_Flag135 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag135); + + procedure Set_Flag136 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag136); + + procedure Set_Flag137 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag137); + + procedure Set_Flag138 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag138); + + procedure Set_Flag139 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag139); + + procedure Set_Flag140 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag140); + + procedure Set_Flag141 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag141); + + procedure Set_Flag142 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag142); + + procedure Set_Flag143 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag143); + + procedure Set_Flag144 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag144); + + procedure Set_Flag145 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag145); + + procedure Set_Flag146 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag146); + + procedure Set_Flag147 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag147); + + procedure Set_Flag148 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag148); + + procedure Set_Flag149 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag149); + + procedure Set_Flag150 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag150); + + procedure Set_Flag151 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag151); + + procedure Set_Flag152 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag152); + + procedure Set_Flag153 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag153); + + procedure Set_Flag154 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag154); + + procedure Set_Flag155 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag155); + + procedure Set_Flag156 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag156); + + procedure Set_Flag157 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag157); + + procedure Set_Flag158 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag158); + + procedure Set_Flag159 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag159); + + procedure Set_Flag160 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag160); + + procedure Set_Flag161 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag161); + + procedure Set_Flag162 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag162); + + procedure Set_Flag163 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag163); + + procedure Set_Flag164 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag164); + + procedure Set_Flag165 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag165); + + procedure Set_Flag166 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag166); + + procedure Set_Flag167 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag167); + + procedure Set_Flag168 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag168); + + procedure Set_Flag169 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag169); + + procedure Set_Flag170 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag170); + + procedure Set_Flag171 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag171); + + procedure Set_Flag172 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag172); + + procedure Set_Flag173 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag173); + + procedure Set_Flag174 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag174); + + procedure Set_Flag175 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag175); + + procedure Set_Flag176 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag176); + + procedure Set_Flag177 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag177); + + procedure Set_Flag178 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag178); + + procedure Set_Flag179 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag179); + + procedure Set_Flag180 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag180); + + procedure Set_Flag181 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag181); + + procedure Set_Flag182 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag182); + + procedure Set_Flag183 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag183); + + procedure Set_Flag184 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag184); + + procedure Set_Flag185 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag185); + + procedure Set_Flag186 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag186); + + procedure Set_Flag187 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag187); + + procedure Set_Flag188 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag188); + + procedure Set_Flag189 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag189); + + procedure Set_Flag190 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag190); + + procedure Set_Flag191 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag191); + + procedure Set_Flag192 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag192); + + procedure Set_Flag193 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag193); + + procedure Set_Flag194 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag194); + + procedure Set_Flag195 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag195); + + procedure Set_Flag196 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag196); + + procedure Set_Flag197 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag197); + + procedure Set_Flag198 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag198); + + procedure Set_Flag199 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag199); + + procedure Set_Flag200 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag200); + + procedure Set_Flag201 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag201); + + procedure Set_Flag202 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag202); + + procedure Set_Flag203 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag203); + + procedure Set_Flag204 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag204); + + procedure Set_Flag205 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag205); + + procedure Set_Flag206 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag206); + + procedure Set_Flag207 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag207); + + procedure Set_Flag208 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag208); + + procedure Set_Flag209 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag209); + + procedure Set_Flag210 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag210); + + procedure Set_Flag211 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag211); + + procedure Set_Flag212 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag212); + + procedure Set_Flag213 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag213); + + procedure Set_Flag214 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag214); + + procedure Set_Flag215 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag215); + + procedure Set_Flag216 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag216); + + procedure Set_Flag217 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag217); + + procedure Set_Flag218 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag218); + + procedure Set_Flag219 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag219); + + procedure Set_Flag220 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag220); + + procedure Set_Flag221 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag221); + + procedure Set_Flag222 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag222); + + procedure Set_Flag223 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag223); + + procedure Set_Flag224 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag224); + + procedure Set_Flag225 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag225); + + procedure Set_Flag226 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag226); + + procedure Set_Flag227 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag227); + + procedure Set_Flag228 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag228); + + procedure Set_Flag229 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag229); + + procedure Set_Flag230 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag230); + + procedure Set_Flag231 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag231); + + procedure Set_Flag232 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag232); + + procedure Set_Flag233 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag233); + + procedure Set_Flag234 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag234); + + procedure Set_Flag235 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag235); + + procedure Set_Flag236 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag236); + + procedure Set_Flag237 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag237); + + procedure Set_Flag238 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag238); + + procedure Set_Flag239 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag239); + + procedure Set_Flag240 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag240); + + procedure Set_Flag241 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag241); + + procedure Set_Flag242 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag242); + + procedure Set_Flag243 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag243); + + procedure Set_Flag244 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag244); + + procedure Set_Flag245 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag245); + + procedure Set_Flag246 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag246); + + procedure Set_Flag247 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag247); + + procedure Set_Flag248 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag248); + + procedure Set_Flag249 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag249); + + procedure Set_Flag250 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag250); + + procedure Set_Flag251 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag251); + + procedure Set_Flag252 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag252); + + procedure Set_Flag253 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag253); + + procedure Set_Flag254 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag254); + + -- The following versions of Set_Noden also set the parent + -- pointer of the referenced node if it is non_Empty + + procedure Set_Node1_With_Parent (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node1_With_Parent); + + procedure Set_Node2_With_Parent (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node2_With_Parent); + + procedure Set_Node3_With_Parent (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node3_With_Parent); + + procedure Set_Node4_With_Parent (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node4_With_Parent); + + procedure Set_Node5_With_Parent (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node5_With_Parent); + + -- The following versions of Set_Listn also set the parent pointer of + -- the referenced node if it is non_Empty. The procedures for List6 + -- to List12 can only be applied to nodes which have an extension. + + procedure Set_List1_With_Parent (N : Node_Id; Val : List_Id); + pragma Inline (Set_List1_With_Parent); + + procedure Set_List2_With_Parent (N : Node_Id; Val : List_Id); + pragma Inline (Set_List2_With_Parent); + + procedure Set_List3_With_Parent (N : Node_Id; Val : List_Id); + pragma Inline (Set_List3_With_Parent); + + procedure Set_List4_With_Parent (N : Node_Id; Val : List_Id); + pragma Inline (Set_List4_With_Parent); + + procedure Set_List5_With_Parent (N : Node_Id; Val : List_Id); + pragma Inline (Set_List5_With_Parent); + + end Unchecked_Access; + + ----------------------------- + -- Private Part Subpackage -- + ----------------------------- + + -- The following package contains the definition of the data structure + -- used by the implementation of the Atree package. Logically it really + -- corresponds to the private part, hence the name. The reason that it + -- is defined as a sub-package is to allow special access from clients + -- that need to see the internals of the data structures. + + package Atree_Private_Part is + + ------------------------- + -- Tree Representation -- + ------------------------- + + -- The nodes of the tree are stored in a table (i.e. an array). In the + -- case of extended nodes five consecutive components in the array are + -- used. There are thus two formats for array components. One is used + -- for non-extended nodes, and for the first component of extended + -- nodes. The other is used for the extension parts (second, third, + -- fourth and fifth components) of an extended node. A variant record + -- structure is used to distinguish the two formats. + + type Node_Record (Is_Extension : Boolean := False) is record + + -- Logically, the only field in the common part is the above + -- Is_Extension discriminant (a single bit). However, Gigi cannot + -- yet handle such a structure, so we fill out the common part of + -- the record with fields that are used in different ways for + -- normal nodes and node extensions. + + Pflag1, Pflag2 : Boolean; + -- The Paren_Count field is represented using two boolean flags, + -- where Pflag1 is worth 1, and Pflag2 is worth 2. This is done + -- because we need to be easily able to reuse this field for + -- extra flags in the extended node case. + + In_List : Boolean; + -- Flag used to indicate if node is a member of a list. + -- This field is considered private to the Atree package. + + Has_Aspects : Boolean; + -- Flag used to indicate that a node has aspect specifications that + -- are associated with the node. See Aspects package for details. + + Rewrite_Ins : Boolean; + -- Flag set by Mark_Rewrite_Insertion procedure. + -- This field is considered private to the Atree package. + + Analyzed : Boolean; + -- Flag to indicate the node has been analyzed (and expanded) + + Comes_From_Source : Boolean; + -- Flag to indicate that node comes from the source program (i.e. + -- was built by the parser or scanner, not the analyzer or expander). + + Error_Posted : Boolean; + -- Flag to indicate that an error message has been posted on the + -- node (to avoid duplicate flags on the same node) + + Flag4 : Boolean; + Flag5 : Boolean; + Flag6 : Boolean; + Flag7 : Boolean; + Flag8 : Boolean; + Flag9 : Boolean; + Flag10 : Boolean; + Flag11 : Boolean; + Flag12 : Boolean; + Flag13 : Boolean; + Flag14 : Boolean; + Flag15 : Boolean; + Flag16 : Boolean; + Flag17 : Boolean; + Flag18 : Boolean; + -- The eighteen flags for a normal node + + -- The above fields are used as follows in components 2-5 of + -- an extended node entry. + + -- In_List used as Flag19, Flag40, Flag129, Flag216 + -- Has_Aspects used as Flag20, Flag41, Flag130, Flag217 + -- Rewrite_Ins used as Flag21, Flag42, Flag131, Flag218 + -- Analyzed used as Flag22, Flag43, Flag132, Flag219 + -- Comes_From_Source used as Flag23, Flag44, Flag133, Flag220 + -- Error_Posted used as Flag24, Flag45, Flag134, Flag221 + -- Flag4 used as Flag25, Flag46, Flag135, Flag222 + -- Flag5 used as Flag26, Flag47, Flag136, Flag223 + -- Flag6 used as Flag27, Flag48, Flag137, Flag224 + -- Flag7 used as Flag28, Flag49, Flag138, Flag225 + -- Flag8 used as Flag29, Flag50, Flag139, Flag226 + -- Flag9 used as Flag30, Flag51, Flag140, Flag227 + -- Flag10 used as Flag31, Flag52, Flag141, Flag228 + -- Flag11 used as Flag32, Flag53, Flag142, Flag229 + -- Flag12 used as Flag33, Flag54, Flag143, Flag230 + -- Flag13 used as Flag34, Flag55, Flag144, Flag231 + -- Flag14 used as Flag35, Flag56, Flag145, Flag232 + -- Flag15 used as Flag36, Flag57, Flag146, Flag233 + -- Flag16 used as Flag37, Flag58, Flag147, Flag234 + -- Flag17 used as Flag38, Flag59, Flag148, Flag235 + -- Flag18 used as Flag39, Flag60, Flag149, Flag236 + -- Pflag1 used as Flag61, Flag62, Flag150, Flag237 + -- Pflag2 used as Flag63, Flag64, Flag151, Flag238 + + Nkind : Node_Kind; + -- For a non-extended node, or the initial section of an extended + -- node, this field holds the Node_Kind value. For an extended node, + -- The Nkind field is used as follows: + -- + -- Second entry: holds the Ekind field of the entity + -- Third entry: holds 8 additional flags (Flag65-Flag72) + -- Fourth entry: holds 8 additional flags (Flag239-246) + -- Fifth entry: holds 8 additional flags (Flag247-254) + + -- Now finally (on an 32-bit boundary!) comes the variant part + + case Is_Extension is + + -- Non-extended node, or first component of extended node + + when False => + + Sloc : Source_Ptr; + -- Source location for this node + + Link : Union_Id; + -- This field is used either as the Parent pointer (if In_List + -- is False), or to point to the list header (if In_List is + -- True). This field is considered private and can be modified + -- only by Atree or by Nlists. + + Field1 : Union_Id; + Field2 : Union_Id; + Field3 : Union_Id; + Field4 : Union_Id; + Field5 : Union_Id; + -- Five general use fields, which can contain Node_Id, List_Id, + -- Elist_Id, String_Id, or Name_Id values depending on the + -- values in Nkind and (for extended nodes), in Ekind. See + -- packages Sinfo and Einfo for details of their use. + + -- Extension (second component) of extended node + + when True => + + Field6 : Union_Id; + Field7 : Union_Id; + Field8 : Union_Id; + Field9 : Union_Id; + Field10 : Union_Id; + Field11 : Union_Id; + Field12 : Union_Id; + -- Seven additional general fields available only for entities + -- See package Einfo for details of their use (which depends + -- on the value in the Ekind field). + + -- In the third component, the extension format as described + -- above is used to hold additional general fields and flags + -- as follows: + + -- Field6-11 Holds Field13-Field18 + -- Field12 Holds Flag73-Flag96 and Convention + + -- In the fourth component, the extension format as described + -- above is used to hold additional general fields and flags + -- as follows: + + -- Field6-10 Holds Field19-Field23 + -- Field11 Holds Flag152-Flag183 + -- Field12 Holds Flag97-Flag128 + + -- In the fifth component, the extension format as described + -- above is used to hold additional general fields and flags + -- as follows: + + -- Field6-11 Holds Field24-Field29 + -- Field12 Holds Flag184-Flag215 + + end case; + end record; + + pragma Pack (Node_Record); + for Node_Record'Size use 8*32; + for Node_Record'Alignment use 4; + + function E_To_N is new Unchecked_Conversion (Entity_Kind, Node_Kind); + function N_To_E is new Unchecked_Conversion (Node_Kind, Entity_Kind); + + -- Default value used to initialize default nodes. Note that some of the + -- fields get overwritten, and in particular, Nkind always gets reset. + + Default_Node : Node_Record := ( + Is_Extension => False, + Pflag1 => False, + Pflag2 => False, + In_List => False, + Has_Aspects => False, + Rewrite_Ins => False, + Analyzed => False, + Comes_From_Source => False, + -- modified by Set_Comes_From_Source_Default + Error_Posted => False, + Flag4 => False, + + Flag5 => False, + Flag6 => False, + Flag7 => False, + Flag8 => False, + Flag9 => False, + Flag10 => False, + Flag11 => False, + Flag12 => False, + + Flag13 => False, + Flag14 => False, + Flag15 => False, + Flag16 => False, + Flag17 => False, + Flag18 => False, + + Nkind => N_Unused_At_Start, + + Sloc => No_Location, + Link => Empty_List_Or_Node, + Field1 => Empty_List_Or_Node, + Field2 => Empty_List_Or_Node, + Field3 => Empty_List_Or_Node, + Field4 => Empty_List_Or_Node, + Field5 => Empty_List_Or_Node); + + -- Default value used to initialize node extensions (i.e. the second + -- and third and fourth components of an extended node). Note we are + -- cheating a bit here when it comes to Node12, which really holds + -- flags an (for the third component), the convention. But it works + -- because Empty, False, Convention_Ada, all happen to be all zero bits. + + Default_Node_Extension : constant Node_Record := ( + Is_Extension => True, + Pflag1 => False, + Pflag2 => False, + In_List => False, + Has_Aspects => False, + Rewrite_Ins => False, + Analyzed => False, + Comes_From_Source => False, + Error_Posted => False, + Flag4 => False, + + Flag5 => False, + Flag6 => False, + Flag7 => False, + Flag8 => False, + Flag9 => False, + Flag10 => False, + Flag11 => False, + Flag12 => False, + + Flag13 => False, + Flag14 => False, + Flag15 => False, + Flag16 => False, + Flag17 => False, + Flag18 => False, + + Nkind => E_To_N (E_Void), + + Field6 => Empty_List_Or_Node, + Field7 => Empty_List_Or_Node, + Field8 => Empty_List_Or_Node, + Field9 => Empty_List_Or_Node, + Field10 => Empty_List_Or_Node, + Field11 => Empty_List_Or_Node, + Field12 => Empty_List_Or_Node); + + -- The following defines the extendable array used for the nodes table + -- Nodes with extensions use five consecutive entries in the array + + package Nodes is new Table.Table ( + Table_Component_Type => Node_Record, + Table_Index_Type => Node_Id'Base, + Table_Low_Bound => First_Node_Id, + Table_Initial => Alloc.Nodes_Initial, + Table_Increment => Alloc.Nodes_Increment, + Table_Name => "Nodes"); + + end Atree_Private_Part; + +end Atree; diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h new file mode 100644 index 000000000..4cef407eb --- /dev/null +++ b/gcc/ada/atree.h @@ -0,0 +1,736 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * A T R E E * + * * + * C Header File * + * * + * 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. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING3. If not, go to * + * http://www.gnu.org/licenses for a complete copy of the license. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* This is the C header corresponding to the Ada package specification for + Atree. It also contains the implementations of inlined functions from the + package body for Atree. It was generated manually from atree.ads and + atree.adb and must be kept synchronized with changes in these files. + + Note that only routines for reading the tree are included, since the tree + transformer is not supposed to modify the tree in any way. */ + +/* Structure used for the first part of the node in the case where we have + an Nkind. */ + +struct NFK +{ + Boolean is_extension : 1; + Boolean pflag1 : 1; + Boolean pflag2 : 1; + Boolean in_list : 1; + Boolean has_aspects : 1; + Boolean rewrite_ins : 1; + Boolean analyzed : 1; + Boolean c_f_s : 1; + Boolean error_posted : 1; + + Boolean flag4 : 1; + Boolean flag5 : 1; + Boolean flag6 : 1; + Boolean flag7 : 1; + Boolean flag8 : 1; + Boolean flag9 : 1; + Boolean flag10 : 1; + + Boolean flag11 : 1; + Boolean flag12 : 1; + Boolean flag13 : 1; + Boolean flag14 : 1; + Boolean flag15 : 1; + Boolean flag16 : 1; + Boolean flag17 : 1; + Boolean flag18 : 1; + + unsigned char kind; +}; + +/* Structure for the first part of a node when Nkind is not present by + extra flag bits are. */ + +struct NFNK +{ + Boolean is_extension : 1; + Boolean pflag1 : 1; + Boolean pflag2 : 1; + Boolean in_list : 1; + Boolean has_aspects : 1; + Boolean rewrite_ins : 1; + Boolean analyzed : 1; + Boolean c_f_s : 1; + Boolean error_posted : 1; + + Boolean flag4 : 1; + Boolean flag5 : 1; + Boolean flag6 : 1; + Boolean flag7 : 1; + Boolean flag8 : 1; + Boolean flag9 : 1; + Boolean flag10 : 1; + + Boolean flag11 : 1; + Boolean flag12 : 1; + Boolean flag13 : 1; + Boolean flag14 : 1; + Boolean flag15 : 1; + Boolean flag16 : 1; + Boolean flag17 : 1; + Boolean flag18 : 1; + + Boolean flag65 : 1; + Boolean flag66 : 1; + Boolean flag67 : 1; + Boolean flag68 : 1; + Boolean flag69 : 1; + Boolean flag70 : 1; + Boolean flag71 : 1; + Boolean flag72 : 1; +}; + +/* Structure used for extra flags in third component overlaying Field12 */ +struct Flag_Word +{ + Boolean flag73 : 1; + Boolean flag74 : 1; + Boolean flag75 : 1; + Boolean flag76 : 1; + Boolean flag77 : 1; + Boolean flag78 : 1; + Boolean flag79 : 1; + Boolean flag80 : 1; + Boolean flag81 : 1; + Boolean flag82 : 1; + Boolean flag83 : 1; + Boolean flag84 : 1; + Boolean flag85 : 1; + Boolean flag86 : 1; + Boolean flag87 : 1; + Boolean flag88 : 1; + Boolean flag89 : 1; + Boolean flag90 : 1; + Boolean flag91 : 1; + Boolean flag92 : 1; + Boolean flag93 : 1; + Boolean flag94 : 1; + Boolean flag95 : 1; + Boolean flag96 : 1; + Short convention : 8; +}; + +/* Structure used for extra flags in fourth component overlaying Field12 */ +struct Flag_Word2 +{ + Boolean flag97 : 1; + Boolean flag98 : 1; + Boolean flag99 : 1; + Boolean flag100 : 1; + Boolean flag101 : 1; + Boolean flag102 : 1; + Boolean flag103 : 1; + Boolean flag104 : 1; + Boolean flag105 : 1; + Boolean flag106 : 1; + Boolean flag107 : 1; + Boolean flag108 : 1; + Boolean flag109 : 1; + Boolean flag110 : 1; + Boolean flag111 : 1; + Boolean flag112 : 1; + Boolean flag113 : 1; + Boolean flag114 : 1; + Boolean flag115 : 1; + Boolean flag116 : 1; + Boolean flag117 : 1; + Boolean flag118 : 1; + Boolean flag119 : 1; + Boolean flag120 : 1; + Boolean flag121 : 1; + Boolean flag122 : 1; + Boolean flag123 : 1; + Boolean flag124 : 1; + Boolean flag125 : 1; + Boolean flag126 : 1; + Boolean flag127 : 1; + Boolean flag128 : 1; +}; + +/* Structure used for extra flags in fourth component overlaying Field11 */ +struct Flag_Word3 +{ + Boolean flag152 : 1; + Boolean flag153 : 1; + Boolean flag154 : 1; + Boolean flag155 : 1; + Boolean flag156 : 1; + Boolean flag157 : 1; + Boolean flag158 : 1; + Boolean flag159 : 1; + + Boolean flag160 : 1; + Boolean flag161 : 1; + Boolean flag162 : 1; + Boolean flag163 : 1; + Boolean flag164 : 1; + Boolean flag165 : 1; + Boolean flag166 : 1; + Boolean flag167 : 1; + + Boolean flag168 : 1; + Boolean flag169 : 1; + Boolean flag170 : 1; + Boolean flag171 : 1; + Boolean flag172 : 1; + Boolean flag173 : 1; + Boolean flag174 : 1; + Boolean flag175 : 1; + + Boolean flag176 : 1; + Boolean flag177 : 1; + Boolean flag178 : 1; + Boolean flag179 : 1; + Boolean flag180 : 1; + Boolean flag181 : 1; + Boolean flag182 : 1; + Boolean flag183 : 1; +}; + +/* Structure used for extra flags in fifth component overlaying Field12 */ +struct Flag_Word4 +{ + Boolean flag184 : 1; + Boolean flag185 : 1; + Boolean flag186 : 1; + Boolean flag187 : 1; + Boolean flag188 : 1; + Boolean flag189 : 1; + Boolean flag190 : 1; + Boolean flag191 : 1; + + Boolean flag192 : 1; + Boolean flag193 : 1; + Boolean flag194 : 1; + Boolean flag195 : 1; + Boolean flag196 : 1; + Boolean flag197 : 1; + Boolean flag198 : 1; + Boolean flag199 : 1; + + Boolean flag200 : 1; + Boolean flag201 : 1; + Boolean flag202 : 1; + Boolean flag203 : 1; + Boolean flag204 : 1; + Boolean flag205 : 1; + Boolean flag206 : 1; + Boolean flag207 : 1; + + Boolean flag208 : 1; + Boolean flag209 : 1; + Boolean flag210 : 1; + Boolean flag211 : 1; + Boolean flag212 : 1; + Boolean flag213 : 1; + Boolean flag214 : 1; + Boolean flag215 : 1; +}; + +struct Non_Extended +{ + Source_Ptr sloc; + Int link; + Int field1; + Int field2; + Int field3; + Int field4; + Int field5; +}; + +/* The Following structure corresponds to variant with is_extension = True. */ +struct Extended +{ + Int field6; + Int field7; + Int field8; + Int field9; + Int field10; + union + { + Int field11; + struct Flag_Word3 fw3; + } X; + + union + { + Int field12; + struct Flag_Word fw; + struct Flag_Word2 fw2; + struct Flag_Word4 fw4; + } U; +}; + +/* A tree node itself. */ + +struct Node +{ + union kind + { + struct NFK K; + struct NFNK NK; + } U; + + union variant + { + struct Non_Extended NX; + struct Extended EX; + } V; +}; + +/* The actual tree is an array of nodes. The pointer to this array is passed + as a parameter to the tree transformer procedure and stored in the global + variable Nodes_Ptr after adjusting it by subtracting Node_First_Entry, so + that Node_Id values can be used as subscripts. */ +extern struct Node *Nodes_Ptr; + +#define Parent atree__parent +extern Node_Id Parent (Node_Id); + +/* Overloaded Functions: + + These functions are overloaded in the original Ada source, but there is + only one corresponding C function, which works as described below. */ + +/* Type used for union of Node_Id, List_Id, Elist_Id. */ +typedef Int Tree_Id; + +/* These two functions can only be used for Node_Id and List_Id values and + they work in the C version because Empty = No_List = 0. */ + +static Boolean No (Tree_Id); +static Boolean Present (Tree_Id); + +INLINE Boolean +No (Tree_Id N) +{ + return N == Empty; +} + +INLINE Boolean +Present (Tree_Id N) +{ + return N != Empty; +} + +extern Node_Id Parent (Tree_Id); + +#define Current_Error_Node atree__current_error_node +extern Node_Id Current_Error_Node; + +/* Node Access Functions: */ + +#define Nkind(N) ((Node_Kind) (Nodes_Ptr[(N) - First_Node_Id].U.K.kind)) +#define Ekind(N) ((Entity_Kind) (Nodes_Ptr[N + 1].U.K.kind)) +#define Sloc(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.sloc) +#define Paren_Count(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.pflag1 \ + + 2 * Nodes_Ptr[(N) - First_Node_Id].U.K.pflag2) + +#define Field1(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field1) +#define Field2(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field2) +#define Field3(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field3) +#define Field4(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field4) +#define Field5(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field5) +#define Field6(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field6) +#define Field7(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field7) +#define Field8(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field8) +#define Field9(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field9) +#define Field10(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field10) +#define Field11(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.X.field11) +#define Field12(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.U.field12) +#define Field13(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field6) +#define Field14(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field7) +#define Field15(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field8) +#define Field16(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field9) +#define Field17(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field10) +#define Field18(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.X.field11) +#define Field19(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field6) +#define Field20(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field7) +#define Field21(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field8) +#define Field22(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field9) +#define Field23(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field10) +#define Field24(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field6) +#define Field25(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field7) +#define Field26(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field8) +#define Field27(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field9) +#define Field28(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field10) +#define Field29(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.X.field11) + +#define Node1(N) Field1 (N) +#define Node2(N) Field2 (N) +#define Node3(N) Field3 (N) +#define Node4(N) Field4 (N) +#define Node5(N) Field5 (N) +#define Node6(N) Field6 (N) +#define Node7(N) Field7 (N) +#define Node8(N) Field8 (N) +#define Node9(N) Field9 (N) +#define Node10(N) Field10 (N) +#define Node11(N) Field11 (N) +#define Node12(N) Field12 (N) +#define Node13(N) Field13 (N) +#define Node14(N) Field14 (N) +#define Node15(N) Field15 (N) +#define Node16(N) Field16 (N) +#define Node17(N) Field17 (N) +#define Node18(N) Field18 (N) +#define Node19(N) Field19 (N) +#define Node20(N) Field20 (N) +#define Node21(N) Field21 (N) +#define Node22(N) Field22 (N) +#define Node23(N) Field23 (N) +#define Node24(N) Field24 (N) +#define Node25(N) Field25 (N) +#define Node26(N) Field26 (N) +#define Node27(N) Field27 (N) +#define Node28(N) Field28 (N) +#define Node29(N) Field29 (N) + +#define List1(N) Field1 (N) +#define List2(N) Field2 (N) +#define List3(N) Field3 (N) +#define List4(N) Field4 (N) +#define List5(N) Field5 (N) +#define List10(N) Field10 (N) +#define List14(N) Field14 (N) +#define List25(N) Field25 (N) + +#define Elist1(N) Field1 (N) +#define Elist2(N) Field2 (N) +#define Elist3(N) Field3 (N) +#define Elist4(N) Field4 (N) +#define Elist8(N) Field8 (N) +#define Elist10(N) Field10 (N) +#define Elist13(N) Field13 (N) +#define Elist15(N) Field15 (N) +#define Elist16(N) Field16 (N) +#define Elist18(N) Field18 (N) +#define Elist21(N) Field21 (N) +#define Elist23(N) Field23 (N) +#define Elist25(N) Field25 (N) +#define Elist26(N) Field26 (N) + +#define Name1(N) Field1 (N) +#define Name2(N) Field2 (N) + +#define Char_Code2(N) (Field2 (N) - Char_Code_Bias) + +#define Str3(N) Field3 (N) + +#define Uint2(N) ((Field2 (N) == 0) ? Uint_0 : Field2 (N)) +#define Uint3(N) ((Field3 (N) == 0) ? Uint_0 : Field3 (N)) +#define Uint4(N) ((Field4 (N) == 0) ? Uint_0 : Field4 (N)) +#define Uint5(N) ((Field5 (N) == 0) ? Uint_0 : Field5 (N)) +#define Uint8(N) ((Field8 (N) == 0) ? Uint_0 : Field8 (N)) +#define Uint9(N) ((Field9 (N) == 0) ? Uint_0 : Field9 (N)) +#define Uint10(N) ((Field10 (N) == 0) ? Uint_0 : Field10 (N)) +#define Uint11(N) ((Field11 (N) == 0) ? Uint_0 : Field11 (N)) +#define Uint12(N) ((Field12 (N) == 0) ? Uint_0 : Field12 (N)) +#define Uint13(N) ((Field13 (N) == 0) ? Uint_0 : Field13 (N)) +#define Uint14(N) ((Field14 (N) == 0) ? Uint_0 : Field14 (N)) +#define Uint15(N) ((Field15 (N) == 0) ? Uint_0 : Field15 (N)) +#define Uint16(N) ((Field16 (N) == 0) ? Uint_0 : Field16 (N)) +#define Uint17(N) ((Field17 (N) == 0) ? Uint_0 : Field17 (N)) +#define Uint22(N) ((Field22 (N) == 0) ? Uint_0 : Field22 (N)) + +#define Ureal3(N) Field3 (N) +#define Ureal18(N) Field18 (N) +#define Ureal21(N) Field21 (N) + +#define Analyzed(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.analyzed) +#define Comes_From_Source(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.c_f_s) +#define Error_Posted(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.error_posted) +#define Has_Aspects(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.has_aspects) +#define Convention(N) \ + (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.convention) + +#define Flag4(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag4) +#define Flag5(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag5) +#define Flag6(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag6) +#define Flag7(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag7) +#define Flag8(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag8) +#define Flag9(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag9) +#define Flag10(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag10) +#define Flag11(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag11) +#define Flag12(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag12) +#define Flag13(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag13) +#define Flag14(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag14) +#define Flag15(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag15) +#define Flag16(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag16) +#define Flag17(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag17) +#define Flag18(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag18) + +#define Flag19(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.in_list) +#define Flag20(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.has_aspects) +#define Flag21(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.rewrite_ins) +#define Flag22(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.analyzed) +#define Flag23(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.c_f_s) +#define Flag24(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.error_posted) +#define Flag25(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag4) +#define Flag26(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag5) +#define Flag27(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag6) +#define Flag28(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag7) +#define Flag29(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag8) +#define Flag30(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag9) +#define Flag31(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag10) +#define Flag32(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag11) +#define Flag33(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag12) +#define Flag34(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag13) +#define Flag35(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag14) +#define Flag36(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag15) +#define Flag37(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag16) +#define Flag38(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag17) +#define Flag39(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag18) + +#define Flag40(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.in_list) +#define Flag41(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.has_aspects) +#define Flag42(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.rewrite_ins) +#define Flag43(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.analyzed) +#define Flag44(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.c_f_s) +#define Flag45(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.error_posted) +#define Flag46(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag4) +#define Flag47(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag5) +#define Flag48(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag6) +#define Flag49(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag7) +#define Flag50(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag8) +#define Flag51(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag9) +#define Flag52(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag10) +#define Flag53(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag11) +#define Flag54(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag12) +#define Flag55(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag13) +#define Flag56(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag14) +#define Flag57(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag15) +#define Flag58(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag16) +#define Flag59(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag17) +#define Flag60(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag18) +#define Flag61(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.pflag1) +#define Flag62(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.pflag2) +#define Flag63(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.pflag1) +#define Flag64(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.pflag2) + +#define Flag65(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag65) +#define Flag66(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag66) +#define Flag67(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag67) +#define Flag68(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag68) +#define Flag69(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag69) +#define Flag70(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag70) +#define Flag71(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag71) +#define Flag72(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag72) + +#define Flag73(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag73) +#define Flag74(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag74) +#define Flag75(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag75) +#define Flag76(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag76) +#define Flag77(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag77) +#define Flag78(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag78) +#define Flag79(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag79) +#define Flag80(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag80) +#define Flag81(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag81) +#define Flag82(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag82) +#define Flag83(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag83) +#define Flag84(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag84) +#define Flag85(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag85) +#define Flag86(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag86) +#define Flag87(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag87) +#define Flag88(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag88) +#define Flag89(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag89) +#define Flag90(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag90) +#define Flag91(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag91) +#define Flag92(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag92) +#define Flag93(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag93) +#define Flag94(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag94) +#define Flag95(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag95) +#define Flag96(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag96) +#define Flag97(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag97) +#define Flag98(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag98) +#define Flag99(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag99) +#define Flag100(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag100) +#define Flag101(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag101) +#define Flag102(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag102) +#define Flag103(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag103) +#define Flag104(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag104) +#define Flag105(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag105) +#define Flag106(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag106) +#define Flag107(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag107) +#define Flag108(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag108) +#define Flag109(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag109) +#define Flag110(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag110) +#define Flag111(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag111) +#define Flag112(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag112) +#define Flag113(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag113) +#define Flag114(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag114) +#define Flag115(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag115) +#define Flag116(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag116) +#define Flag117(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag117) +#define Flag118(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag118) +#define Flag119(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag119) +#define Flag120(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag120) +#define Flag121(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag121) +#define Flag122(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag122) +#define Flag123(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag123) +#define Flag124(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag124) +#define Flag125(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag125) +#define Flag126(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag126) +#define Flag127(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag127) +#define Flag128(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag128) + +#define Flag129(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.in_list) +#define Flag130(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.has_aspects) +#define Flag131(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.rewrite_ins) +#define Flag132(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.analyzed) +#define Flag133(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.c_f_s) +#define Flag134(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.error_posted) +#define Flag135(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag4) +#define Flag136(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag5) +#define Flag137(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag6) +#define Flag138(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag7) +#define Flag139(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag8) +#define Flag140(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag9) +#define Flag141(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag10) +#define Flag142(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag11) +#define Flag143(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag12) +#define Flag144(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag13) +#define Flag145(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag14) +#define Flag146(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag15) +#define Flag147(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag16) +#define Flag148(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag17) +#define Flag149(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag18) +#define Flag150(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.pflag1) +#define Flag151(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.pflag2) + +#define Flag152(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag152) +#define Flag153(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag153) +#define Flag154(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag154) +#define Flag155(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag155) +#define Flag156(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag156) +#define Flag157(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag157) +#define Flag158(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag158) +#define Flag159(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag159) +#define Flag160(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag160) +#define Flag161(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag161) +#define Flag162(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag162) +#define Flag163(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag163) +#define Flag164(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag164) +#define Flag165(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag165) +#define Flag166(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag166) +#define Flag167(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag167) +#define Flag168(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag168) +#define Flag169(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag169) +#define Flag170(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag170) +#define Flag171(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag171) +#define Flag172(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag172) +#define Flag173(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag173) +#define Flag174(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag174) +#define Flag175(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag175) +#define Flag176(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag176) +#define Flag177(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag177) +#define Flag178(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag178) +#define Flag179(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag179) +#define Flag180(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag180) +#define Flag181(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag181) +#define Flag182(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag182) +#define Flag183(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag183) + +#define Flag184(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag184) +#define Flag185(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag185) +#define Flag186(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag186) +#define Flag187(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag187) +#define Flag188(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag188) +#define Flag189(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag189) +#define Flag190(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag190) +#define Flag191(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag191) +#define Flag192(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag192) +#define Flag193(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag193) +#define Flag194(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag194) +#define Flag195(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag195) +#define Flag196(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag196) +#define Flag197(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag197) +#define Flag198(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag198) +#define Flag199(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag199) +#define Flag200(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag200) +#define Flag201(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag201) +#define Flag202(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag202) +#define Flag203(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag203) +#define Flag204(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag204) +#define Flag205(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag205) +#define Flag206(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag206) +#define Flag207(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag207) +#define Flag208(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag208) +#define Flag209(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag209) +#define Flag210(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag210) +#define Flag211(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag211) +#define Flag212(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag212) +#define Flag213(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag213) +#define Flag214(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag214) +#define Flag215(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag215) + +#define Flag216(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.in_list) +#define Flag217(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.has_aspects) +#define Flag218(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.rewrite_ins) +#define Flag219(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.analyzed) +#define Flag220(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.c_f_s) +#define Flag221(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.error_posted) +#define Flag222(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag4) +#define Flag223(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag5) +#define Flag224(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag6) +#define Flag225(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag7) +#define Flag226(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag8) +#define Flag227(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag9) +#define Flag228(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag10) +#define Flag229(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag11) +#define Flag230(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag12) +#define Flag231(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag13) +#define Flag232(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag14) +#define Flag233(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag15) +#define Flag234(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag16) +#define Flag235(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag17) +#define Flag236(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag18) +#define Flag237(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.pflag1) +#define Flag238(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.pflag2) + +#define Flag239(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag65) +#define Flag240(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag66) +#define Flag241(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag67) +#define Flag242(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag68) +#define Flag243(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag69) +#define Flag244(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag70) +#define Flag245(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag71) +#define Flag246(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag72) + +#define Flag247(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag65) +#define Flag248(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag66) +#define Flag249(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag67) +#define Flag250(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag68) +#define Flag251(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag69) +#define Flag252(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag70) +#define Flag253(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag71) +#define Flag254(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag72) + diff --git a/gcc/ada/aux-io.c b/gcc/ada/aux-io.c new file mode 100644 index 000000000..a7ab20b87 --- /dev/null +++ b/gcc/ada/aux-io.c @@ -0,0 +1,98 @@ +/**************************************************************************** + * * + * GNAT RUN-TIME COMPONENTS * + * * + * A - T R A N S * + * * + * C Implementation File * + * * + * Copyright (C) 1992-2009 Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. * + * * + * As a special exception under Section 7 of GPL version 3, you are granted * + * additional permissions described in the GCC Runtime Library Exception, * + * version 3.1, as published by the Free Software Foundation. * + * * + * You should have received a copy of the GNU General Public License and * + * a copy of the GCC Runtime Library Exception along with this program; * + * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +#include + +#ifdef IN_RTS +#include "tconfig.h" +#include "tsystem.h" +#else +#include "config.h" +#include "system.h" +#endif + +/* Function wrappers are needed to access the values from Ada which are + defined as C macros. */ + +FILE *c_stdin (void); +FILE *c_stdout (void); +FILE *c_stderr (void); +int seek_set_function (void); +int seek_end_function (void); +void *null_function (void); +int c_fileno (FILE *); + +FILE * +c_stdin (void) +{ + return stdin; +} + +FILE * +c_stdout (void) +{ + return stdout; +} + +FILE * +c_stderr (void) +{ + return stderr; +} + +#ifndef SEEK_SET /* Symbolic constants for the "fseek" function: */ +#define SEEK_SET 0 /* Set file pointer to offset */ +#define SEEK_CUR 1 /* Set file pointer to its current value plus offset */ +#define SEEK_END 2 /* Set file pointer to the size of the file plus offset */ +#endif + +int +seek_set_function (void) +{ + return SEEK_SET; +} + +int +seek_end_function (void) +{ + return SEEK_END; +} + +void *null_function (void) +{ + return NULL; +} + +int +c_fileno (FILE *s) +{ + return fileno (s); +} diff --git a/gcc/ada/back_end.adb b/gcc/ada/back_end.adb new file mode 100644 index 000000000..7172696b5 --- /dev/null +++ b/gcc/ada/back_end.adb @@ -0,0 +1,328 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B A C K _ E N D -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Debug; use Debug; +with Elists; use Elists; +with Errout; use Errout; +with Lib; use Lib; +with Osint; use Osint; +with Opt; use Opt; +with Osint.C; use Osint.C; +with Namet; use Namet; +with Nlists; use Nlists; +with Stand; use Stand; +with Sinput; use Sinput; +with Stringt; use Stringt; +with Switch; use Switch; +with Switch.C; use Switch.C; +with System; use System; +with Types; use Types; + +with System.OS_Lib; use System.OS_Lib; + +package body Back_End is + + type Arg_Array is array (Nat) of Big_String_Ptr; + type Arg_Array_Ptr is access Arg_Array; + -- Types to access compiler arguments + + flag_stack_check : Int; + pragma Import (C, flag_stack_check); + -- Indicates if stack checking is enabled, imported from decl.c + + save_argc : Nat; + pragma Import (C, save_argc); + -- Saved value of argc (number of arguments), imported from misc.c + + save_argv : Arg_Array_Ptr; + pragma Import (C, save_argv); + -- Saved value of argv (argument pointers), imported from misc.c + + function Len_Arg (Arg : Pos) return Nat; + -- Determine length of argument number Arg on original gnat1 command line + + ------------------- + -- Call_Back_End -- + ------------------- + + procedure Call_Back_End (Mode : Back_End_Mode_Type) is + + -- The Source_File_Record type has a lot of components that are + -- meaningless to the back end, so a new record type is created + -- here to contain the needed information for each file. + + type File_Info_Type is record + File_Name : File_Name_Type; + Num_Source_Lines : Nat; + end record; + + File_Info_Array : array (1 .. Last_Source_File) of File_Info_Type; + + procedure gigi + (gnat_root : Int; + max_gnat_node : Int; + number_name : Nat; + nodes_ptr : Address; + + next_node_ptr : Address; + prev_node_ptr : Address; + elists_ptr : Address; + elmts_ptr : Address; + + strings_ptr : Address; + string_chars_ptr : Address; + list_headers_ptr : Address; + number_file : Nat; + + file_info_ptr : Address; + gigi_standard_boolean : Entity_Id; + gigi_standard_integer : Entity_Id; + gigi_standard_character : Entity_Id; + gigi_standard_long_long_float : Entity_Id; + gigi_standard_exception_type : Entity_Id; + gigi_operating_mode : Back_End_Mode_Type); + + pragma Import (C, gigi); + + begin + -- Skip call if in -gnatdH mode + + if Debug_Flag_HH then + return; + end if; + + for J in 1 .. Last_Source_File loop + File_Info_Array (J).File_Name := Full_Debug_Name (J); + File_Info_Array (J).Num_Source_Lines := Num_Source_Lines (J); + end loop; + + if Generate_SCIL then + Error_Msg_N ("'S'C'I'L generation not available", Cunit (Main_Unit)); + + if CodePeer_Mode + or else (Mode /= Generate_Object + and then not Back_Annotate_Rep_Info) + then + return; + end if; + end if; + + gigi + (gnat_root => Int (Cunit (Main_Unit)), + max_gnat_node => Int (Last_Node_Id - First_Node_Id + 1), + number_name => Name_Entries_Count, + nodes_ptr => Nodes_Address, + + next_node_ptr => Next_Node_Address, + prev_node_ptr => Prev_Node_Address, + elists_ptr => Elists_Address, + elmts_ptr => Elmts_Address, + + strings_ptr => Strings_Address, + string_chars_ptr => String_Chars_Address, + list_headers_ptr => Lists_Address, + number_file => Num_Source_Files, + + file_info_ptr => File_Info_Array'Address, + gigi_standard_boolean => Standard_Boolean, + gigi_standard_integer => Standard_Integer, + gigi_standard_character => Standard_Character, + gigi_standard_long_long_float => Standard_Long_Long_Float, + gigi_standard_exception_type => Standard_Exception_Type, + gigi_operating_mode => Mode); + end Call_Back_End; + + ------------- + -- Len_Arg -- + ------------- + + function Len_Arg (Arg : Pos) return Nat is + begin + for J in 1 .. Nat'Last loop + if save_argv (Arg).all (Natural (J)) = ASCII.NUL then + return J - 1; + end if; + end loop; + + raise Program_Error; + end Len_Arg; + + ----------------------------- + -- Scan_Compiler_Arguments -- + ----------------------------- + + procedure Scan_Compiler_Arguments is + + Next_Arg : Positive; + -- Next argument to be scanned + + Output_File_Name_Seen : Boolean := False; + -- Set to True after having scanned file_name for switch "-gnatO file" + + procedure Scan_Back_End_Switches (Switch_Chars : String); + -- Procedure to scan out switches stored in Switch_Chars. The first + -- character is known to be a valid switch character, and there are no + -- blanks or other switch terminator characters in the string, so the + -- entire string should consist of valid switch characters, except that + -- an optional terminating NUL character is allowed. + -- + -- Back end switches have already been checked and processed by GCC in + -- toplev.c, so no errors can occur and control will always return. The + -- switches must still be scanned to skip "-o" or internal GCC switches + -- with their argument. + + ---------------------------- + -- Scan_Back_End_Switches -- + ---------------------------- + + procedure Scan_Back_End_Switches (Switch_Chars : String) is + First : constant Positive := Switch_Chars'First + 1; + Last : constant Natural := Switch_Last (Switch_Chars); + + begin + -- Skip -o or internal GCC switches together with their argument + + if Switch_Chars (First .. Last) = "o" + or else Is_Internal_GCC_Switch (Switch_Chars) + then + Next_Arg := Next_Arg + 1; + + -- Do not record -quiet switch + + elsif Switch_Chars (First .. Last) = "quiet" then + null; + + -- Store any other GCC switches + + else + Store_Compilation_Switch (Switch_Chars); + + -- Special check, the back end switch -fno-inline also sets the + -- front end flag to entirely inhibit all inlining. + + if Switch_Chars (First .. Last) = "fno-inline" then + Opt.Suppress_All_Inlining := True; + + -- Another special check, the switch -fpreserve-control-flow + -- which is also a back end switch sets the front end flag + -- that inhibits improper control flow transformations. + + elsif Switch_Chars (First .. Last) = "fpreserve-control-flow" then + Opt.Suppress_Control_Flow_Optimizations := True; + end if; + end if; + end Scan_Back_End_Switches; + + -- Local variables + + Arg_Count : constant Natural := Natural (save_argc - 1); + Args : Argument_List (1 .. Arg_Count); + + -- Start of processing for Scan_Compiler_Arguments + + begin + -- Acquire stack checking mode directly from GCC + + Opt.Stack_Checking_Enabled := (flag_stack_check /= 0); + + -- Put the arguments in Args + + for Arg in Pos range 1 .. save_argc - 1 loop + declare + Argv_Ptr : constant Big_String_Ptr := save_argv (Arg); + Argv_Len : constant Nat := Len_Arg (Arg); + Argv : constant String := + Argv_Ptr (1 .. Natural (Argv_Len)); + begin + Args (Positive (Arg)) := new String'(Argv); + end; + end loop; + + -- Loop through command line arguments, storing them for later access + + Next_Arg := 1; + while Next_Arg <= Args'Last loop + Look_At_Arg : declare + Argv : constant String := Args (Next_Arg).all; + + begin + -- If the previous switch has set the Output_File_Name_Present + -- flag (that is we have seen a -gnatO), then the next argument + -- is the name of the output object file. + + if Output_File_Name_Present + and then not Output_File_Name_Seen + then + if Is_Switch (Argv) then + Fail ("Object file name missing after -gnatO"); + + else + Set_Output_Object_File_Name (Argv); + Output_File_Name_Seen := True; + end if; + + -- If the previous switch has set the Search_Directory_Present + -- flag (that is if we have just seen -I), then the next argument + -- is a search directory path. + + elsif Search_Directory_Present then + if Is_Switch (Argv) then + Fail ("search directory missing after -I"); + else + Add_Src_Search_Dir (Argv); + Search_Directory_Present := False; + end if; + + elsif not Is_Switch (Argv) then -- must be a file name + Add_File (Argv); + + -- We must recognize -nostdinc to suppress visibility on the + -- standard GNAT RTL sources. This is also a gcc switch. + + elsif Argv (Argv'First + 1 .. Argv'Last) = "nostdinc" then + Opt.No_Stdinc := True; + Scan_Back_End_Switches (Argv); + + -- We must recognize -nostdlib to suppress visibility on the + -- standard GNAT RTL objects. + + elsif Argv (Argv'First + 1 .. Argv'Last) = "nostdlib" then + Opt.No_Stdlib := True; + + elsif Is_Front_End_Switch (Argv) then + Scan_Front_End_Switches (Argv, Args, Next_Arg); + + -- All non-front-end switches are back-end switches + + else + Scan_Back_End_Switches (Argv); + end if; + end Look_At_Arg; + + Next_Arg := Next_Arg + 1; + end loop; + end Scan_Compiler_Arguments; +end Back_End; diff --git a/gcc/ada/back_end.ads b/gcc/ada/back_end.ads new file mode 100644 index 000000000..93e1ba643 --- /dev/null +++ b/gcc/ada/back_end.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B A C K _ E N D -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Call the back end with all the information needed. Also contains other +-- back-end specific interfaces required by the front end. + +package Back_End is + + type Back_End_Mode_Type is ( + Generate_Object, + -- Full back end operation with object file generation + + Declarations_Only, + -- Partial back end operation with no object file generation. In this + -- mode the only useful action performed by gigi is to process all + -- declarations issuing any error messages (in particular those to + -- do with rep clauses), and to back annotate representation info. + + Skip); + -- Back end call is skipped (syntax only, or errors found) + + pragma Convention (C, Back_End_Mode_Type); + for Back_End_Mode_Type use (0, 1, 2); + + procedure Call_Back_End (Mode : Back_End_Mode_Type); + -- Call back end, i.e. make call to driver traversing the tree and + -- outputting code. This call is made with all tables locked. + -- The back end is responsible for unlocking any tables it may need + -- to change, and locking them again before returning. + + procedure Scan_Compiler_Arguments; + -- Acquires command-line parameters passed to the compiler and processes + -- them. Calls Scan_Front_End_Switches for any front-end switches found. + -- + -- The processing of arguments is private to the back end, since the way + -- of acquiring the arguments as well as the set of allowable back end + -- switches is different depending on the particular back end being used. + -- + -- Any processed switches that influence the result of a compilation must + -- be added to the Compilation_Arguments table. + +end Back_End; diff --git a/gcc/ada/bcheck.adb b/gcc/ada/bcheck.adb new file mode 100644 index 000000000..796627e0d --- /dev/null +++ b/gcc/ada/bcheck.adb @@ -0,0 +1,1185 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B C H E C K -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with ALI; use ALI; +with ALI.Util; use ALI.Util; +with Binderr; use Binderr; +with Butil; use Butil; +with Casing; use Casing; +with Fname; use Fname; +with Namet; use Namet; +with Opt; use Opt; +with Osint; +with Output; use Output; +with Rident; use Rident; +with Types; use Types; + +package body Bcheck is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + -- The following checking subprograms make up the parts of the + -- configuration consistency check. See bodies for details of checks. + + procedure Check_Consistent_Dispatching_Policy; + procedure Check_Consistent_Dynamic_Elaboration_Checking; + procedure Check_Consistent_Floating_Point_Format; + procedure Check_Consistent_Interrupt_States; + procedure Check_Consistent_Locking_Policy; + procedure Check_Consistent_Normalize_Scalars; + procedure Check_Consistent_Optimize_Alignment; + procedure Check_Consistent_Queuing_Policy; + procedure Check_Consistent_Restrictions; + procedure Check_Consistent_Restriction_No_Default_Initialization; + procedure Check_Consistent_Zero_Cost_Exception_Handling; + + procedure Consistency_Error_Msg (Msg : String); + -- Produce an error or a warning message, depending on whether an + -- inconsistent configuration is permitted or not. + + function Same_Unit (U1 : Unit_Name_Type; U2 : Name_Id) return Boolean; + -- Used to compare two unit names for No_Dependence checks. U1 is in + -- standard unit name format, and U2 is in literal form with periods. + + ------------------------------------- + -- Check_Configuration_Consistency -- + ------------------------------------- + + procedure Check_Configuration_Consistency is + begin + if Float_Format_Specified /= ' ' then + Check_Consistent_Floating_Point_Format; + end if; + + if Queuing_Policy_Specified /= ' ' then + Check_Consistent_Queuing_Policy; + end if; + + if Locking_Policy_Specified /= ' ' then + Check_Consistent_Locking_Policy; + end if; + + if Zero_Cost_Exceptions_Specified then + Check_Consistent_Zero_Cost_Exception_Handling; + end if; + + Check_Consistent_Normalize_Scalars; + Check_Consistent_Optimize_Alignment; + Check_Consistent_Dynamic_Elaboration_Checking; + Check_Consistent_Restrictions; + Check_Consistent_Restriction_No_Default_Initialization; + Check_Consistent_Interrupt_States; + Check_Consistent_Dispatching_Policy; + end Check_Configuration_Consistency; + + ----------------------- + -- Check_Consistency -- + ----------------------- + + procedure Check_Consistency is + Src : Source_Id; + -- Source file Id for this Sdep entry + + ALI_Path_Id : File_Name_Type; + + begin + -- First, we go through the source table to see if there are any cases + -- in which we should go after source files and compute checksums of + -- the source files. We need to do this for any file for which we have + -- mismatching time stamps and (so far) matching checksums. + + for S in Source.First .. Source.Last loop + + -- If all time stamps for a file match, then there is nothing to + -- do, since we will not be checking checksums in that case anyway + + if Source.Table (S).All_Timestamps_Match then + null; + + -- If we did not find the source file, then we can't compute its + -- checksum anyway. Note that when we have a time stamp mismatch, + -- we try to find the source file unconditionally (i.e. if + -- Check_Source_Files is False). + + elsif not Source.Table (S).Source_Found then + null; + + -- If we already have non-matching or missing checksums, then no + -- need to try going after source file, since we won't trust the + -- checksums in any case. + + elsif not Source.Table (S).All_Checksums_Match then + null; + + -- Now we have the case where we have time stamp mismatches, and + -- the source file is around, but so far all checksums match. This + -- is the case where we need to compute the checksum from the source + -- file, since otherwise we would ignore the time stamp mismatches, + -- and that is wrong if the checksum of the source does not agree + -- with the checksums in the ALI files. + + elsif Check_Source_Files then + if not Checksums_Match + (Source.Table (S).Checksum, + Get_File_Checksum (Source.Table (S).Sfile)) + then + Source.Table (S).All_Checksums_Match := False; + end if; + end if; + end loop; + + -- Loop through ALI files + + ALIs_Loop : for A in ALIs.First .. ALIs.Last loop + + -- Loop through Sdep entries in one ALI file + + Sdep_Loop : for D in + ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep + loop + if Sdep.Table (D).Dummy_Entry then + goto Continue; + end if; + + Src := Source_Id (Get_Name_Table_Info (Sdep.Table (D).Sfile)); + + -- If the time stamps match, or all checksums match, then we + -- are OK, otherwise we have a definite error. + + if Sdep.Table (D).Stamp /= Source.Table (Src).Stamp + and then not Source.Table (Src).All_Checksums_Match + then + Error_Msg_File_1 := ALIs.Table (A).Sfile; + Error_Msg_File_2 := Sdep.Table (D).Sfile; + + -- Two styles of message, depending on whether or not + -- the updated file is the one that must be recompiled + + if Error_Msg_File_1 = Error_Msg_File_2 then + if Tolerate_Consistency_Errors then + Error_Msg + ("?{ has been modified and should be recompiled"); + else + Error_Msg + ("{ has been modified and must be recompiled"); + end if; + + else + ALI_Path_Id := + Osint.Full_Lib_File_Name (ALIs.Table (A).Afile); + + if Osint.Is_Readonly_Library (ALI_Path_Id) then + if Tolerate_Consistency_Errors then + Error_Msg ("?{ should be recompiled"); + Error_Msg_File_1 := ALI_Path_Id; + Error_Msg ("?({ is obsolete and read-only)"); + else + Error_Msg ("{ must be compiled"); + Error_Msg_File_1 := ALI_Path_Id; + Error_Msg ("({ is obsolete and read-only)"); + end if; + + elsif Tolerate_Consistency_Errors then + Error_Msg + ("?{ should be recompiled ({ has been modified)"); + + else + Error_Msg ("{ must be recompiled ({ has been modified)"); + end if; + end if; + + if (not Tolerate_Consistency_Errors) and Verbose_Mode then + Error_Msg_File_1 := Sdep.Table (D).Sfile; + Error_Msg + ("{ time stamp " & String (Source.Table (Src).Stamp)); + + Error_Msg_File_1 := Sdep.Table (D).Sfile; + -- Something wrong here, should be different file ??? + + Error_Msg + (" conflicts with { timestamp " & + String (Sdep.Table (D).Stamp)); + end if; + + -- Exit from the loop through Sdep entries once we find one + -- that does not match. + + exit Sdep_Loop; + end if; + + <> + null; + end loop Sdep_Loop; + end loop ALIs_Loop; + end Check_Consistency; + + ----------------------------------------- + -- Check_Consistent_Dispatching_Policy -- + ----------------------------------------- + + -- The rule is that all files for which the dispatching policy is + -- significant must meet the following rules: + + -- 1. All files for which a task dispatching policy is significant must + -- be compiled with the same setting. + + -- 2. If a partition contains one or more Priority_Specific_Dispatching + -- pragmas it cannot contain a Task_Dispatching_Policy pragma. + + -- 3. No overlap is allowed in the priority ranges specified in + -- Priority_Specific_Dispatching pragmas within the same partition. + + -- 4. If a partition contains one or more Priority_Specific_Dispatching + -- pragmas then the Ceiling_Locking policy is the only one allowed for + -- the partition. + + procedure Check_Consistent_Dispatching_Policy is + Max_Prio : Nat := 0; + -- Maximum priority value for which a Priority_Specific_Dispatching + -- pragma has been specified. + + TDP_Pragma_Afile : ALI_Id := No_ALI_Id; + -- ALI file where a Task_Dispatching_Policy pragma appears + + begin + -- Consistency checks in units specifying a Task_Dispatching_Policy + + if Task_Dispatching_Policy_Specified /= ' ' then + Find_Policy : for A1 in ALIs.First .. ALIs.Last loop + if ALIs.Table (A1).Task_Dispatching_Policy /= ' ' then + + -- Store the place where the first task dispatching pragma + -- appears. We may need this value for issuing consistency + -- errors if Priority_Specific_Dispatching pragmas are used. + + TDP_Pragma_Afile := A1; + + Check_Policy : declare + Policy : constant Character := + ALIs.Table (A1).Task_Dispatching_Policy; + + begin + for A2 in A1 + 1 .. ALIs.Last loop + if ALIs.Table (A2).Task_Dispatching_Policy /= ' ' + and then + ALIs.Table (A2).Task_Dispatching_Policy /= Policy + then + Error_Msg_File_1 := ALIs.Table (A1).Sfile; + Error_Msg_File_2 := ALIs.Table (A2).Sfile; + + Consistency_Error_Msg + ("{ and { compiled with different task" & + " dispatching policies"); + exit Find_Policy; + end if; + end loop; + end Check_Policy; + + exit Find_Policy; + end if; + end loop Find_Policy; + end if; + + -- If no Priority_Specific_Dispatching entries, nothing else to do + + if Specific_Dispatching.Last >= Specific_Dispatching.First then + + -- Find out the maximum priority value for which one of the + -- Priority_Specific_Dispatching pragmas applies. + + Max_Prio := 0; + for J in Specific_Dispatching.First .. Specific_Dispatching.Last loop + if Specific_Dispatching.Table (J).Last_Priority > Max_Prio then + Max_Prio := Specific_Dispatching.Table (J).Last_Priority; + end if; + end loop; + + -- Now establish tables to be used for consistency checking + + declare + -- The following record type is used to record locations of the + -- Priority_Specific_Dispatching pragmas applying to the Priority. + + type Specific_Dispatching_Entry is record + Dispatching_Policy : Character := ' '; + -- First character (upper case) of corresponding policy name + + Afile : ALI_Id := No_ALI_Id; + -- ALI file that generated Priority Specific Dispatching + -- entry for consistency message. + + Loc : Nat := 0; + -- Line numbers from Priority_Specific_Dispatching pragma + end record; + + PSD_Table : array (0 .. Max_Prio) of Specific_Dispatching_Entry := + (others => Specific_Dispatching_Entry' + (Dispatching_Policy => ' ', + Afile => No_ALI_Id, + Loc => 0)); + -- Array containing an entry per priority containing the location + -- where there is a Priority_Specific_Dispatching pragma that + -- applies to the priority. + + begin + for F in ALIs.First .. ALIs.Last loop + for K in ALIs.Table (F).First_Specific_Dispatching .. + ALIs.Table (F).Last_Specific_Dispatching + loop + declare + DTK : Specific_Dispatching_Record + renames Specific_Dispatching.Table (K); + begin + -- Check whether pragma Task_Dispatching_Policy and + -- pragma Priority_Specific_Dispatching are used in the + -- same partition. + + if Task_Dispatching_Policy_Specified /= ' ' then + Error_Msg_File_1 := ALIs.Table (F).Sfile; + Error_Msg_File_2 := + ALIs.Table (TDP_Pragma_Afile).Sfile; + + Error_Msg_Nat_1 := DTK.PSD_Pragma_Line; + + Consistency_Error_Msg + ("Priority_Specific_Dispatching at {:#" & + " incompatible with Task_Dispatching_Policy at {"); + end if; + + -- Ceiling_Locking must also be specified for a partition + -- with at least one Priority_Specific_Dispatching + -- pragma. + + if Locking_Policy_Specified /= ' ' + and then Locking_Policy_Specified /= 'C' + then + for A in ALIs.First .. ALIs.Last loop + if ALIs.Table (A).Locking_Policy /= ' ' + and then ALIs.Table (A).Locking_Policy /= 'C' + then + Error_Msg_File_1 := ALIs.Table (F).Sfile; + Error_Msg_File_2 := ALIs.Table (A).Sfile; + + Error_Msg_Nat_1 := DTK.PSD_Pragma_Line; + + Consistency_Error_Msg + ("Priority_Specific_Dispatching at {:#" & + " incompatible with Locking_Policy at {"); + end if; + end loop; + end if; + + -- Check overlapping priority ranges + + Find_Overlapping : for Prio in + DTK.First_Priority .. DTK.Last_Priority + loop + if PSD_Table (Prio).Afile = No_ALI_Id then + PSD_Table (Prio) := + (Dispatching_Policy => DTK.Dispatching_Policy, + Afile => F, Loc => DTK.PSD_Pragma_Line); + + elsif PSD_Table (Prio).Dispatching_Policy /= + DTK.Dispatching_Policy + + then + Error_Msg_File_1 := + ALIs.Table (PSD_Table (Prio).Afile).Sfile; + Error_Msg_File_2 := ALIs.Table (F).Sfile; + Error_Msg_Nat_1 := PSD_Table (Prio).Loc; + Error_Msg_Nat_2 := DTK.PSD_Pragma_Line; + + Consistency_Error_Msg + ("overlapping priority ranges at {:# and {:#"); + + exit Find_Overlapping; + end if; + end loop Find_Overlapping; + end; + end loop; + end loop; + end; + end if; + end Check_Consistent_Dispatching_Policy; + + --------------------------------------------------- + -- Check_Consistent_Dynamic_Elaboration_Checking -- + --------------------------------------------------- + + -- The rule here is that if a unit has dynamic elaboration checks, + -- then any unit it withs must meeting one of the following criteria: + + -- 1. There is a pragma Elaborate_All for the with'ed unit + -- 2. The with'ed unit was compiled with dynamic elaboration checks + -- 3. The with'ed unit has pragma Preelaborate or Pure + -- 4. It is an internal GNAT unit (including children of GNAT) + + procedure Check_Consistent_Dynamic_Elaboration_Checking is + begin + if Dynamic_Elaboration_Checks_Specified then + for U in First_Unit_Entry .. Units.Last loop + declare + UR : Unit_Record renames Units.Table (U); + + begin + if UR.Dynamic_Elab then + for W in UR.First_With .. UR.Last_With loop + declare + WR : With_Record renames Withs.Table (W); + + begin + if Get_Name_Table_Info (WR.Uname) /= 0 then + declare + WU : Unit_Record renames + Units.Table + (Unit_Id + (Get_Name_Table_Info (WR.Uname))); + + begin + -- Case 1. Elaborate_All for with'ed unit + + if WR.Elaborate_All then + null; + + -- Case 2. With'ed unit has dynamic elab checks + + elsif WU.Dynamic_Elab then + null; + + -- Case 3. With'ed unit is Preelaborate or Pure + + elsif WU.Preelab or else WU.Pure then + null; + + -- Case 4. With'ed unit is internal file + + elsif Is_Internal_File_Name (WU.Sfile) then + null; + + -- Issue warning, not one of the safe cases + + else + Error_Msg_File_1 := UR.Sfile; + Error_Msg + ("?{ has dynamic elaboration checks " & + "and with's"); + + Error_Msg_File_1 := WU.Sfile; + Error_Msg + ("? { which has static elaboration " & + "checks"); + + Warnings_Detected := Warnings_Detected - 1; + end if; + end; + end if; + end; + end loop; + end if; + end; + end loop; + end if; + end Check_Consistent_Dynamic_Elaboration_Checking; + + -------------------------------------------- + -- Check_Consistent_Floating_Point_Format -- + -------------------------------------------- + + -- The rule is that all files must be compiled with the same setting + -- for the floating-point format. + + procedure Check_Consistent_Floating_Point_Format is + begin + -- First search for a unit specifying a floating-point format and then + -- check all remaining units against it. + + Find_Format : for A1 in ALIs.First .. ALIs.Last loop + if ALIs.Table (A1).Float_Format /= ' ' then + Check_Format : declare + Format : constant Character := ALIs.Table (A1).Float_Format; + begin + for A2 in A1 + 1 .. ALIs.Last loop + if ALIs.Table (A2).Float_Format /= Format then + Error_Msg_File_1 := ALIs.Table (A1).Sfile; + Error_Msg_File_2 := ALIs.Table (A2).Sfile; + + Consistency_Error_Msg + ("{ and { compiled with different " & + "floating-point representations"); + exit Find_Format; + end if; + end loop; + end Check_Format; + + exit Find_Format; + end if; + end loop Find_Format; + end Check_Consistent_Floating_Point_Format; + + --------------------------------------- + -- Check_Consistent_Interrupt_States -- + --------------------------------------- + + -- The rule is that if the state of a given interrupt is specified + -- in more than one unit, it must be specified with a consistent state. + + procedure Check_Consistent_Interrupt_States is + Max_Intrup : Nat; + + begin + -- If no Interrupt_State entries, nothing to do + + if Interrupt_States.Last < Interrupt_States.First then + return; + end if; + + -- First find out the maximum interrupt value + + Max_Intrup := 0; + for J in Interrupt_States.First .. Interrupt_States.Last loop + if Interrupt_States.Table (J).Interrupt_Id > Max_Intrup then + Max_Intrup := Interrupt_States.Table (J).Interrupt_Id; + end if; + end loop; + + -- Now establish tables to be used for consistency checking + + declare + Istate : array (0 .. Max_Intrup) of Character := (others => 'n'); + -- Interrupt state entries, 'u'/'s'/'r' or 'n' to indicate an + -- entry that has not been set. + + Afile : array (0 .. Max_Intrup) of ALI_Id; + -- ALI file that generated Istate entry for consistency message + + Loc : array (0 .. Max_Intrup) of Nat; + -- Line numbers from IS pragma generating Istate entry + + Inum : Nat; + -- Interrupt number from entry being tested + + Stat : Character; + -- Interrupt state from entry being tested + + Lnum : Nat; + -- Line number from entry being tested + + begin + for F in ALIs.First .. ALIs.Last loop + for K in ALIs.Table (F).First_Interrupt_State .. + ALIs.Table (F).Last_Interrupt_State + loop + Inum := Interrupt_States.Table (K).Interrupt_Id; + Stat := Interrupt_States.Table (K).Interrupt_State; + Lnum := Interrupt_States.Table (K).IS_Pragma_Line; + + if Istate (Inum) = 'n' then + Istate (Inum) := Stat; + Afile (Inum) := F; + Loc (Inum) := Lnum; + + elsif Istate (Inum) /= Stat then + Error_Msg_File_1 := ALIs.Table (Afile (Inum)).Sfile; + Error_Msg_File_2 := ALIs.Table (F).Sfile; + Error_Msg_Nat_1 := Loc (Inum); + Error_Msg_Nat_2 := Lnum; + + Consistency_Error_Msg + ("inconsistent interrupt states at {:# and {:#"); + end if; + end loop; + end loop; + end; + end Check_Consistent_Interrupt_States; + + ------------------------------------- + -- Check_Consistent_Locking_Policy -- + ------------------------------------- + + -- The rule is that all files for which the locking policy is + -- significant must be compiled with the same setting. + + procedure Check_Consistent_Locking_Policy is + begin + -- First search for a unit specifying a policy and then + -- check all remaining units against it. + + Find_Policy : for A1 in ALIs.First .. ALIs.Last loop + if ALIs.Table (A1).Locking_Policy /= ' ' then + Check_Policy : declare + Policy : constant Character := ALIs.Table (A1).Locking_Policy; + + begin + for A2 in A1 + 1 .. ALIs.Last loop + if ALIs.Table (A2).Locking_Policy /= ' ' + and then + ALIs.Table (A2).Locking_Policy /= Policy + then + Error_Msg_File_1 := ALIs.Table (A1).Sfile; + Error_Msg_File_2 := ALIs.Table (A2).Sfile; + + Consistency_Error_Msg + ("{ and { compiled with different locking policies"); + exit Find_Policy; + end if; + end loop; + end Check_Policy; + + exit Find_Policy; + end if; + end loop Find_Policy; + end Check_Consistent_Locking_Policy; + + ---------------------------------------- + -- Check_Consistent_Normalize_Scalars -- + ---------------------------------------- + + -- The rule is that if any unit is compiled with Normalized_Scalars, + -- then all other units in the partition must also be compiled with + -- Normalized_Scalars in effect. + + -- There is some issue as to whether this consistency check is desirable, + -- it is certainly required at the moment by the RM. We should keep a watch + -- on the ARG and HRG deliberations here. GNAT no longer depends on this + -- consistency (it used to do so, but that is no longer the case, since + -- pragma Initialize_Scalars pragma does not require consistency.) + + procedure Check_Consistent_Normalize_Scalars is + begin + if Normalize_Scalars_Specified and No_Normalize_Scalars_Specified then + Consistency_Error_Msg + ("some but not all files compiled with Normalize_Scalars"); + + Write_Eol; + Write_Str ("files compiled with Normalize_Scalars"); + Write_Eol; + + for A1 in ALIs.First .. ALIs.Last loop + if ALIs.Table (A1).Normalize_Scalars then + Write_Str (" "); + Write_Name (ALIs.Table (A1).Sfile); + Write_Eol; + end if; + end loop; + + Write_Eol; + Write_Str ("files compiled without Normalize_Scalars"); + Write_Eol; + + for A1 in ALIs.First .. ALIs.Last loop + if not ALIs.Table (A1).Normalize_Scalars then + Write_Str (" "); + Write_Name (ALIs.Table (A1).Sfile); + Write_Eol; + end if; + end loop; + end if; + end Check_Consistent_Normalize_Scalars; + + ----------------------------------------- + -- Check_Consistent_Optimize_Alignment -- + ----------------------------------------- + + -- The rule is that all units which depend on the global default setting + -- of Optimize_Alignment must be compiled with the same setting for this + -- default. Units which specify an explicit local value for this setting + -- are exempt from the consistency rule (this includes all internal units). + + procedure Check_Consistent_Optimize_Alignment is + OA_Setting : Character := ' '; + -- Reset when we find a unit that depends on the default and does + -- not have a local specification of the Optimize_Alignment setting. + + OA_Unit : Unit_Id; + -- Id of unit from which OA_Setting was set + + C : Character; + + begin + for U in First_Unit_Entry .. Units.Last loop + C := Units.Table (U).Optimize_Alignment; + + if C /= 'L' then + if OA_Setting = ' ' then + OA_Setting := C; + OA_Unit := U; + + elsif OA_Setting = C then + null; + + else + Error_Msg_Unit_1 := Units.Table (OA_Unit).Uname; + Error_Msg_Unit_2 := Units.Table (U).Uname; + + Consistency_Error_Msg + ("$ and $ compiled with different " + & "default Optimize_Alignment settings"); + return; + end if; + end if; + end loop; + end Check_Consistent_Optimize_Alignment; + + ------------------------------------- + -- Check_Consistent_Queuing_Policy -- + ------------------------------------- + + -- The rule is that all files for which the queuing policy is + -- significant must be compiled with the same setting. + + procedure Check_Consistent_Queuing_Policy is + begin + -- First search for a unit specifying a policy and then + -- check all remaining units against it. + + Find_Policy : for A1 in ALIs.First .. ALIs.Last loop + if ALIs.Table (A1).Queuing_Policy /= ' ' then + Check_Policy : declare + Policy : constant Character := ALIs.Table (A1).Queuing_Policy; + begin + for A2 in A1 + 1 .. ALIs.Last loop + if ALIs.Table (A2).Queuing_Policy /= ' ' + and then + ALIs.Table (A2).Queuing_Policy /= Policy + then + Error_Msg_File_1 := ALIs.Table (A1).Sfile; + Error_Msg_File_2 := ALIs.Table (A2).Sfile; + + Consistency_Error_Msg + ("{ and { compiled with different queuing policies"); + exit Find_Policy; + end if; + end loop; + end Check_Policy; + + exit Find_Policy; + end if; + end loop Find_Policy; + end Check_Consistent_Queuing_Policy; + + ----------------------------------- + -- Check_Consistent_Restrictions -- + ----------------------------------- + + -- The rule is that if a restriction is specified in any unit, then all + -- units must obey the restriction. The check applies only to restrictions + -- which require partition wide consistency, and not to internal units. + + procedure Check_Consistent_Restrictions is + Restriction_File_Output : Boolean; + -- Shows if we have output header messages for restriction violation + + procedure Print_Restriction_File (R : All_Restrictions); + -- Print header line for R if not printed yet + + ---------------------------- + -- Print_Restriction_File -- + ---------------------------- + + procedure Print_Restriction_File (R : All_Restrictions) is + begin + if not Restriction_File_Output then + Restriction_File_Output := True; + + -- Find an ali file specifying the restriction + + for A in ALIs.First .. ALIs.Last loop + if ALIs.Table (A).Restrictions.Set (R) + and then (R in All_Boolean_Restrictions + or else ALIs.Table (A).Restrictions.Value (R) = + Cumulative_Restrictions.Value (R)) + then + -- We have found that ALI file A specifies the restriction + -- that is being violated (the minimum value is specified + -- in the case of a parameter restriction). + + declare + M1 : constant String := "{ has restriction "; + S : constant String := Restriction_Id'Image (R); + M2 : String (1 .. 2000); -- big enough! + P : Integer; + + begin + Name_Buffer (1 .. S'Length) := S; + Name_Len := S'Length; + Set_Casing (Mixed_Case); + + M2 (M1'Range) := M1; + P := M1'Length + 1; + M2 (P .. P + S'Length - 1) := Name_Buffer (1 .. S'Length); + P := P + S'Length; + + if R in All_Parameter_Restrictions then + M2 (P .. P + 4) := " => #"; + Error_Msg_Nat_1 := + Int (Cumulative_Restrictions.Value (R)); + P := P + 5; + end if; + + Error_Msg_File_1 := ALIs.Table (A).Sfile; + Consistency_Error_Msg (M2 (1 .. P - 1)); + Consistency_Error_Msg + ("but the following files violate this restriction:"); + return; + end; + end if; + end loop; + end if; + end Print_Restriction_File; + + -- Start of processing for Check_Consistent_Restrictions + + begin + -- A special test, if we have a main program, then if it has an + -- allocator in the body, this is considered to be a violation of + -- the restriction No_Allocators_After_Elaboration. We just mark + -- this restriction and then the normal circuit will flag it. + + if Bind_Main_Program + and then ALIs.Table (ALIs.First).Main_Program /= None + and then not No_Main_Subprogram + and then ALIs.Table (ALIs.First).Allocator_In_Body + then + Cumulative_Restrictions.Violated + (No_Allocators_After_Elaboration) := True; + ALIs.Table (ALIs.First).Restrictions.Violated + (No_Allocators_After_Elaboration) := True; + end if; + + -- Loop through all restriction violations + + for R in All_Restrictions loop + + -- Check for violation of this restriction + + if Cumulative_Restrictions.Set (R) + and then Cumulative_Restrictions.Violated (R) + and then (R in Partition_Boolean_Restrictions + or else (R in All_Parameter_Restrictions + and then + Cumulative_Restrictions.Count (R) > + Cumulative_Restrictions.Value (R))) + then + Restriction_File_Output := False; + + -- Loop through files looking for violators + + for A2 in ALIs.First .. ALIs.Last loop + declare + T : ALIs_Record renames ALIs.Table (A2); + + begin + if T.Restrictions.Violated (R) then + + -- We exclude predefined files from the list of + -- violators. This should be rethought. It is not + -- clear that this is the right thing to do, that + -- is particularly the case for restricted runtimes. + + if not Is_Internal_File_Name (T.Sfile) then + + -- Case of Boolean restriction, just print file name + + if R in All_Boolean_Restrictions then + Print_Restriction_File (R); + Error_Msg_File_1 := T.Sfile; + Consistency_Error_Msg (" {"); + + -- Case of Parameter restriction where violation + -- count exceeds restriction value, print file + -- name and count, adding "at least" if the + -- exact count is not known. + + elsif R in Checked_Add_Parameter_Restrictions + or else T.Restrictions.Count (R) > + Cumulative_Restrictions.Value (R) + then + Print_Restriction_File (R); + Error_Msg_File_1 := T.Sfile; + Error_Msg_Nat_1 := Int (T.Restrictions.Count (R)); + + if T.Restrictions.Unknown (R) then + Consistency_Error_Msg + (" { (count = at least #)"); + else + Consistency_Error_Msg + (" { (count = #)"); + end if; + end if; + end if; + end if; + end; + end loop; + end if; + end loop; + + -- Now deal with No_Dependence indications. Note that we put the loop + -- through entries in the no dependency table first, since this loop + -- is most often empty (no such pragma Restrictions in use). + + for ND in No_Deps.First .. No_Deps.Last loop + declare + ND_Unit : constant Name_Id := + No_Deps.Table (ND).No_Dep_Unit; + + begin + for J in ALIs.First .. ALIs.Last loop + declare + A : ALIs_Record renames ALIs.Table (J); + + begin + for K in A.First_Unit .. A.Last_Unit loop + declare + U : Unit_Record renames Units.Table (K); + begin + for L in U.First_With .. U.Last_With loop + if Same_Unit + (Withs.Table (L).Uname, ND_Unit) + then + Error_Msg_File_1 := U.Sfile; + Error_Msg_Name_1 := ND_Unit; + Consistency_Error_Msg + ("file { violates restriction " & + "No_Dependence => %"); + end if; + end loop; + end; + end loop; + end; + end loop; + end; + end loop; + end Check_Consistent_Restrictions; + + ------------------------------------------------------------ + -- Check_Consistent_Restriction_No_Default_Initialization -- + ------------------------------------------------------------ + + -- The Restriction (No_Default_Initialization) has special consistency + -- rules. The rule is that no unit compiled without this restriction + -- that violates the restriction can WITH a unit that is compiled with + -- the restriction. + + procedure Check_Consistent_Restriction_No_Default_Initialization is + begin + -- Nothing to do if no one set this restriction + + if not Cumulative_Restrictions.Set (No_Default_Initialization) then + return; + end if; + + -- Nothing to do if no one violates the restriction + + if not Cumulative_Restrictions.Violated (No_Default_Initialization) then + return; + end if; + + -- Otherwise we go into a full scan to find possible problems + + for U in Units.First .. Units.Last loop + declare + UTE : Unit_Record renames Units.Table (U); + ATE : ALIs_Record renames ALIs.Table (UTE.My_ALI); + + begin + if ATE.Restrictions.Violated (No_Default_Initialization) then + for W in UTE.First_With .. UTE.Last_With loop + declare + AFN : constant File_Name_Type := Withs.Table (W).Afile; + + begin + -- The file name may not be present for withs of certain + -- generic run-time files. The test can be safely left + -- out in such cases anyway. + + if AFN /= No_File then + declare + WAI : constant ALI_Id := + ALI_Id (Get_Name_Table_Info (AFN)); + WTE : ALIs_Record renames ALIs.Table (WAI); + + begin + if WTE.Restrictions.Set + (No_Default_Initialization) + then + Error_Msg_Unit_1 := UTE.Uname; + Consistency_Error_Msg + ("unit $ compiled without restriction " + & "No_Default_Initialization"); + Error_Msg_Unit_1 := Withs.Table (W).Uname; + Consistency_Error_Msg + ("withs unit $, compiled with restriction " + & "No_Default_Initialization"); + end if; + end; + end if; + end; + end loop; + end if; + end; + end loop; + end Check_Consistent_Restriction_No_Default_Initialization; + + --------------------------------------------------- + -- Check_Consistent_Zero_Cost_Exception_Handling -- + --------------------------------------------------- + + -- Check consistent zero cost exception handling. The rule is that + -- all units must have the same exception handling mechanism. + + procedure Check_Consistent_Zero_Cost_Exception_Handling is + begin + Check_Mechanism : for A1 in ALIs.First + 1 .. ALIs.Last loop + if ALIs.Table (A1).Zero_Cost_Exceptions /= + ALIs.Table (ALIs.First).Zero_Cost_Exceptions + then + Error_Msg_File_1 := ALIs.Table (A1).Sfile; + Error_Msg_File_2 := ALIs.Table (ALIs.First).Sfile; + + Consistency_Error_Msg ("{ and { compiled with different " + & "exception handling mechanisms"); + end if; + end loop Check_Mechanism; + end Check_Consistent_Zero_Cost_Exception_Handling; + + ------------------------------- + -- Check_Duplicated_Subunits -- + ------------------------------- + + procedure Check_Duplicated_Subunits is + begin + for J in Sdep.First .. Sdep.Last loop + if Sdep.Table (J).Subunit_Name /= No_Name then + Get_Decoded_Name_String (Sdep.Table (J).Subunit_Name); + Name_Len := Name_Len + 2; + Name_Buffer (Name_Len - 1) := '%'; + + -- See if there is a body or spec with the same name + + for K in Boolean loop + if K then + Name_Buffer (Name_Len) := 'b'; + else + Name_Buffer (Name_Len) := 's'; + end if; + + declare + Unit : constant Unit_Name_Type := Name_Find; + Info : constant Int := Get_Name_Table_Info (Unit); + + begin + if Info /= 0 then + Set_Standard_Error; + Write_Str ("error: subunit """); + Write_Name_Decoded (Sdep.Table (J).Subunit_Name); + Write_Str (""" in file """); + Write_Name_Decoded (Sdep.Table (J).Sfile); + Write_Char ('"'); + Write_Eol; + Write_Str (" has same name as unit """); + Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname); + Write_Str (""" found in file """); + Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile); + Write_Char ('"'); + Write_Eol; + Write_Str (" this is not allowed within a single " + & "partition (RM 10.2(19))"); + Write_Eol; + Osint.Exit_Program (Osint.E_Fatal); + end if; + end; + end loop; + end if; + end loop; + end Check_Duplicated_Subunits; + + -------------------- + -- Check_Versions -- + -------------------- + + procedure Check_Versions is + VL : constant Natural := ALIs.Table (ALIs.First).Ver_Len; + + begin + for A in ALIs.First .. ALIs.Last loop + if ALIs.Table (A).Ver_Len /= VL + or else ALIs.Table (A).Ver (1 .. VL) /= + ALIs.Table (ALIs.First).Ver (1 .. VL) + then + Error_Msg_File_1 := ALIs.Table (A).Sfile; + Error_Msg_File_2 := ALIs.Table (ALIs.First).Sfile; + + Consistency_Error_Msg + ("{ and { compiled with different GNAT versions"); + end if; + end loop; + end Check_Versions; + + --------------------------- + -- Consistency_Error_Msg -- + --------------------------- + + procedure Consistency_Error_Msg (Msg : String) is + begin + if Tolerate_Consistency_Errors then + + -- If consistency errors are tolerated, + -- output the message as a warning. + + Error_Msg ('?' & Msg); + + -- Otherwise the consistency error is a true error + + else + Error_Msg (Msg); + end if; + end Consistency_Error_Msg; + + --------------- + -- Same_Unit -- + --------------- + + function Same_Unit (U1 : Unit_Name_Type; U2 : Name_Id) return Boolean is + begin + -- Note, the string U1 has a terminating %s or %b, U2 does not + + if Length_Of_Name (U1) - 2 = Length_Of_Name (U2) then + Get_Name_String (U1); + + declare + U1_Str : constant String := Name_Buffer (1 .. Name_Len - 2); + begin + Get_Name_String (U2); + return U1_Str = Name_Buffer (1 .. Name_Len); + end; + + else + return False; + end if; + end Same_Unit; + +end Bcheck; diff --git a/gcc/ada/bcheck.ads b/gcc/ada/bcheck.ads new file mode 100644 index 000000000..95345e0dc --- /dev/null +++ b/gcc/ada/bcheck.ads @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B C H E C K -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Bcheck is + +-- This package contains the routines to perform binder consistency checks + + procedure Check_Duplicated_Subunits; + -- Check that no subunit names duplicate names of other packages in + -- the partition (check required by RM 10.2(19)). + + procedure Check_Versions; + -- Check correct library and standard versions used + + procedure Check_Consistency; + -- This procedure performs checks that the ALI files are consistent + -- with the corresponding source files and with one another. At the + -- time this is called, the Source table has been completely built and + -- contains either the time stamp from the actual source file if the + -- Check_Source_Files mode is set, or the latest stamp found in any of + -- the ALI files in the program. + + procedure Check_Configuration_Consistency; + -- This procedure performs a similar check that configuration pragma + -- set items that are required to be consistent are in fact consistent + +end Bcheck; diff --git a/gcc/ada/binde.adb b/gcc/ada/binde.adb new file mode 100644 index 000000000..46dc6d2a5 --- /dev/null +++ b/gcc/ada/binde.adb @@ -0,0 +1,1707 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D E -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Binderr; use Binderr; +with Butil; use Butil; +with Debug; use Debug; +with Fname; use Fname; +with Namet; use Namet; +with Opt; use Opt; +with Osint; +with Output; use Output; +with Targparm; use Targparm; + +with System.Case_Util; use System.Case_Util; + +package body Binde is + + -- The following data structures are used to represent the graph that is + -- used to determine the elaboration order (using a topological sort). + + -- The following structures are used to record successors. If A is a + -- successor of B in this table, it means that A must be elaborated + -- before B is elaborated. + + type Successor_Id is new Nat; + -- Identification of single successor entry + + No_Successor : constant Successor_Id := 0; + -- Used to indicate end of list of successors + + type Elab_All_Id is new Nat; + -- Identification of Elab_All entry link + + No_Elab_All_Link : constant Elab_All_Id := 0; + -- Used to indicate end of list + + -- Succ_Reason indicates the reason for a particular elaboration link + + type Succ_Reason is + (Withed, + -- After directly with's Before, so the spec of Before must be + -- elaborated before After is elaborated. + + Elab, + -- After directly mentions Before in a pragma Elaborate, so the + -- body of Before must be elaborate before After is elaborated. + + Elab_All, + -- After either mentions Before directly in a pragma Elaborate_All, + -- or mentions a third unit, X, which itself requires that Before be + -- elaborated before unit X is elaborated. The Elab_All_Link list + -- traces the dependencies in the latter case. + + Elab_All_Desirable, + -- This is just like Elab_All, except that the elaborate all was not + -- explicitly present in the source, but rather was created by the + -- front end, which decided that it was "desirable". + + Elab_Desirable, + -- This is just like Elab, except that the elaborate was not + -- explicitly present in the source, but rather was created by the + -- front end, which decided that it was "desirable". + + Spec_First); + -- After is a body, and Before is the corresponding spec + + -- Successor_Link contains the information for one link + + type Successor_Link is record + Before : Unit_Id; + -- Predecessor unit + + After : Unit_Id; + -- Successor unit + + Next : Successor_Id; + -- Next successor on this list + + Reason : Succ_Reason; + -- Reason for this link + + Elab_Body : Boolean; + -- Set True if this link is needed for the special Elaborate_Body + -- processing described below. + + Reason_Unit : Unit_Id; + -- For Reason = Elab, or Elab_All or Elab_Desirable, records the unit + -- containing the pragma leading to the link. + + Elab_All_Link : Elab_All_Id; + -- If Reason = Elab_All or Elab_Desirable, then this points to the + -- first elment in a list of Elab_All entries that record the with + -- chain leading resulting in this particular dependency. + + end record; + + -- Note on handling of Elaborate_Body. Basically, if we have a pragma + -- Elaborate_Body in a unit, it means that the spec and body have to + -- be handled as a single entity from the point of view of determining + -- an elaboration order. What we do is to essentially remove the body + -- from consideration completely, and transfer all its links (other + -- than the spec link) to the spec. Then when then the spec gets chosen, + -- we choose the body right afterwards. We mark the links that get moved + -- from the body to the spec by setting their Elab_Body flag True, so + -- that we can understand what is going on! + + Succ_First : constant := 1; + + package Succ is new Table.Table ( + Table_Component_Type => Successor_Link, + Table_Index_Type => Successor_Id, + Table_Low_Bound => Succ_First, + Table_Initial => 500, + Table_Increment => 200, + Table_Name => "Succ"); + + -- For the case of Elaborate_All, the following table is used to record + -- chains of with relationships that lead to the Elab_All link. These + -- are used solely for diagnostic purposes + + type Elab_All_Entry is record + Needed_By : Unit_Name_Type; + -- Name of unit from which referencing unit was with'ed or otherwise + -- needed as a result of Elaborate_All or Elaborate_Desirable. + + Next_Elab : Elab_All_Id; + -- Link to next entry on chain (No_Elab_All_Link marks end of list) + end record; + + package Elab_All_Entries is new Table.Table ( + Table_Component_Type => Elab_All_Entry, + Table_Index_Type => Elab_All_Id, + Table_Low_Bound => 1, + Table_Initial => 2000, + Table_Increment => 200, + Table_Name => "Elab_All_Entries"); + + -- A Unit_Node record is built for each active unit + + type Unit_Node_Record is record + + Successors : Successor_Id; + -- Pointer to list of links for successor nodes + + Num_Pred : Int; + -- Number of predecessors for this unit. Normally non-negative, but + -- can go negative in the case of units chosen by the diagnose error + -- procedure (when cycles are being removed from the graph). + + Nextnp : Unit_Id; + -- Forward pointer for list of units with no predecessors + + Elab_Order : Nat; + -- Position in elaboration order (zero = not placed yet) + + Visited : Boolean; + -- Used in computing transitive closure for elaborate all and + -- also in locating cycles and paths in the diagnose routines. + + Elab_Position : Natural; + -- Initialized to zero. Set non-zero when a unit is chosen and + -- placed in the elaboration order. The value represents the + -- ordinal position in the elaboration order. + + end record; + + package UNR is new Table.Table ( + Table_Component_Type => Unit_Node_Record, + Table_Index_Type => Unit_Id, + Table_Low_Bound => First_Unit_Entry, + Table_Initial => 500, + Table_Increment => 200, + Table_Name => "UNR"); + + No_Pred : Unit_Id; + -- Head of list of items with no predecessors + + Num_Left : Int; + -- Number of entries not yet dealt with + + Cur_Unit : Unit_Id; + -- Current unit, set by Gather_Dependencies, and picked up in Build_Link + -- to set the Reason_Unit field of the created dependency link. + + Num_Chosen : Natural := 0; + -- Number of units chosen in the elaboration order so far + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Better_Choice (U1, U2 : Unit_Id) return Boolean; + -- U1 and U2 are both permitted candidates for selection as the next unit + -- to be elaborated. This function determines whether U1 is a better choice + -- than U2, i.e. should be elaborated in preference to U2, based on a set + -- of heuristics that establish a friendly and predictable order (see body + -- for details). The result is True if U1 is a better choice than U2, and + -- False if it is a worse choice, or there is no preference between them. + + procedure Build_Link + (Before : Unit_Id; + After : Unit_Id; + R : Succ_Reason; + Ea_Id : Elab_All_Id := No_Elab_All_Link); + -- Establish a successor link, Before must be elaborated before After, and + -- the reason for the link is R. Ea_Id is the contents to be placed in the + -- Elab_All_Link of the entry. + + procedure Choose (Chosen : Unit_Id); + -- Chosen is the next entry chosen in the elaboration order. This procedure + -- updates all data structures appropriately. + + function Corresponding_Body (U : Unit_Id) return Unit_Id; + pragma Inline (Corresponding_Body); + -- Given a unit which is a spec for which there is a separate body, return + -- the unit id of the body. It is an error to call this routine with a unit + -- that is not a spec, or which does not have a separate body. + + function Corresponding_Spec (U : Unit_Id) return Unit_Id; + pragma Inline (Corresponding_Spec); + -- Given a unit which is a body for which there is a separate spec, return + -- the unit id of the spec. It is an error to call this routine with a unit + -- that is not a body, or which does not have a separate spec. + + procedure Diagnose_Elaboration_Problem; + -- Called when no elaboration order can be found. Outputs an appropriate + -- diagnosis of the problem, and then abandons the bind. + + procedure Elab_All_Links + (Before : Unit_Id; + After : Unit_Id; + Reason : Succ_Reason; + Link : Elab_All_Id); + -- Used to compute the transitive closure of elaboration links for an + -- Elaborate_All pragma (Reason = Elab_All) or for an indication of + -- Elaborate_All_Desirable (Reason = Elab_All_Desirable). Unit After has + -- a pragma Elaborate_All or the front end has determined that a reference + -- probably requires Elaborate_All is required, and unit Before must be + -- previously elaborated. First a link is built making sure that unit + -- Before is elaborated before After, then a recursive call ensures that + -- we also build links for any units needed by Before (i.e. these units + -- must/should also be elaborated before After). Link is used to build + -- a chain of Elab_All_Entries to explain the reason for a link. The + -- value passed is the chain so far. + + procedure Elab_Error_Msg (S : Successor_Id); + -- Given a successor link, outputs an error message of the form + -- "$ must be elaborated before $ ..." where ... is the reason. + + procedure Gather_Dependencies; + -- Compute dependencies, building the Succ and UNR tables + + function Is_Body_Unit (U : Unit_Id) return Boolean; + pragma Inline (Is_Body_Unit); + -- Determines if given unit is a body + + function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean; + -- Returns True if corresponding unit is Pure or Preelaborate. Includes + -- dealing with testing flags on spec if it is given a body. + + function Is_Waiting_Body (U : Unit_Id) return Boolean; + pragma Inline (Is_Waiting_Body); + -- Determines if U is a waiting body, defined as a body which has + -- not been elaborated, but whose spec has been elaborated. + + function Make_Elab_Entry + (Unam : Unit_Name_Type; + Link : Elab_All_Id) return Elab_All_Id; + -- Make an Elab_All_Entries table entry with the given Unam and Link + + function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean; + -- This is like Better_Choice, and has the same interface, but returns + -- true if U1 is a worse choice than U2 in the sense of the -p (pessimistic + -- elaboration order) switch. We still have to obey Ada rules, so it is + -- not quite the direct inverse of Better_Choice. + + function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id; + -- This function uses the Info field set in the names table to obtain + -- the unit Id of a unit, given its name id value. + + procedure Write_Dependencies; + -- Write out dependencies (called only if appropriate option is set) + + procedure Write_Elab_All_Chain (S : Successor_Id); + -- If the reason for the link S is Elaborate_All or Elaborate_Desirable, + -- then this routine will output the "needed by" explanation chain. + + ------------------- + -- Better_Choice -- + ------------------- + + function Better_Choice (U1, U2 : Unit_Id) return Boolean is + UT1 : Unit_Record renames Units.Table (U1); + UT2 : Unit_Record renames Units.Table (U2); + + begin + if Debug_Flag_B then + Write_Str ("Better_Choice ("); + Write_Unit_Name (UT1.Uname); + Write_Str (", "); + Write_Unit_Name (UT2.Uname); + Write_Line (")"); + end if; + + -- Note: the checks here are applied in sequence, and the ordering is + -- significant (i.e. the more important criteria are applied first). + + -- Prefer a waiting body to one that is not a waiting body + + if Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then + if Debug_Flag_B then + Write_Line (" True: u1 is waiting body, u2 is not"); + end if; + + return True; + + elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then + if Debug_Flag_B then + Write_Line (" False: u2 is waiting body, u1 is not"); + end if; + + return False; + + -- Prefer a predefined unit to a non-predefined unit + + elsif UT1.Predefined and then not UT2.Predefined then + if Debug_Flag_B then + Write_Line (" True: u1 is predefined, u2 is not"); + end if; + + return True; + + elsif UT2.Predefined and then not UT1.Predefined then + if Debug_Flag_B then + Write_Line (" False: u2 is predefined, u1 is not"); + end if; + + return False; + + -- Prefer an internal unit to a non-internal unit + + elsif UT1.Internal and then not UT2.Internal then + if Debug_Flag_B then + Write_Line (" True: u1 is internal, u2 is not"); + end if; + return True; + + elsif UT2.Internal and then not UT1.Internal then + if Debug_Flag_B then + Write_Line (" False: u2 is internal, u1 is not"); + end if; + + return False; + + -- Prefer a pure or preelaborable unit to one that is not + + elsif Is_Pure_Or_Preelab_Unit (U1) + and then not + Is_Pure_Or_Preelab_Unit (U2) + then + if Debug_Flag_B then + Write_Line (" True: u1 is pure/preelab, u2 is not"); + end if; + + return True; + + elsif Is_Pure_Or_Preelab_Unit (U2) + and then not + Is_Pure_Or_Preelab_Unit (U1) + then + if Debug_Flag_B then + Write_Line (" False: u2 is pure/preelab, u1 is not"); + end if; + + return False; + + -- Prefer a body to a spec + + elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then + if Debug_Flag_B then + Write_Line (" True: u1 is body, u2 is not"); + end if; + + return True; + + elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then + if Debug_Flag_B then + Write_Line (" False: u2 is body, u1 is not"); + end if; + + return False; + + -- If both are waiting bodies, then prefer the one whose spec is + -- more recently elaborated. Consider the following: + + -- spec of A + -- spec of B + -- body of A or B? + + -- The normal waiting body preference would have placed the body of + -- A before the spec of B if it could. Since it could not, there it + -- must be the case that A depends on B. It is therefore a good idea + -- to put the body of B first. + + elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then + declare + Result : constant Boolean := + UNR.Table (Corresponding_Spec (U1)).Elab_Position > + UNR.Table (Corresponding_Spec (U2)).Elab_Position; + begin + if Debug_Flag_B then + if Result then + Write_Line (" True: based on waiting body elab positions"); + else + Write_Line (" False: based on waiting body elab positions"); + end if; + end if; + + return Result; + end; + end if; + + -- Remaining choice rules are disabled by Debug flag -do + + if not Debug_Flag_O then + + -- The following deal with the case of specs which have been marked + -- as Elaborate_Body_Desirable. We generally want to delay these + -- specs as long as possible, so that the bodies have a better chance + -- of being elaborated closer to the specs. + + -- If we have two units, one of which is a spec for which this flag + -- is set, and the other is not, we prefer to delay the spec for + -- which the flag is set. + + if not UT1.Elaborate_Body_Desirable + and then UT2.Elaborate_Body_Desirable + then + if Debug_Flag_B then + Write_Line (" True: u1 is elab body desirable, u2 is not"); + end if; + + return True; + + elsif not UT2.Elaborate_Body_Desirable + and then UT1.Elaborate_Body_Desirable + then + if Debug_Flag_B then + Write_Line (" False: u1 is elab body desirable, u2 is not"); + end if; + + return False; + + -- If we have two specs that are both marked as Elaborate_Body + -- desirable, we prefer the one whose body is nearer to being able + -- to be elaborated, based on the Num_Pred count. This helps to + -- ensure bodies are as close to specs as possible. + + elsif UT1.Elaborate_Body_Desirable + and then UT2.Elaborate_Body_Desirable + then + declare + Result : constant Boolean := + UNR.Table (Corresponding_Body (U1)).Num_Pred < + UNR.Table (Corresponding_Body (U2)).Num_Pred; + begin + if Debug_Flag_B then + if Result then + Write_Line (" True based on Num_Pred compare"); + else + Write_Line (" False based on Num_Pred compare"); + end if; + end if; + + return Result; + end; + end if; + end if; + + -- If we fall through, it means that no preference rule applies, so we + -- use alphabetical order to at least give a deterministic result. + + if Debug_Flag_B then + Write_Line (" choose on alpha order"); + end if; + + return Uname_Less (UT1.Uname, UT2.Uname); + end Better_Choice; + + ---------------- + -- Build_Link -- + ---------------- + + procedure Build_Link + (Before : Unit_Id; + After : Unit_Id; + R : Succ_Reason; + Ea_Id : Elab_All_Id := No_Elab_All_Link) + is + Cspec : Unit_Id; + + begin + Succ.Increment_Last; + Succ.Table (Succ.Last).Before := Before; + Succ.Table (Succ.Last).Next := UNR.Table (Before).Successors; + UNR.Table (Before).Successors := Succ.Last; + Succ.Table (Succ.Last).Reason := R; + Succ.Table (Succ.Last).Reason_Unit := Cur_Unit; + Succ.Table (Succ.Last).Elab_All_Link := Ea_Id; + + -- Deal with special Elab_Body case. If the After of this link is + -- a body whose spec has Elaborate_All set, and this is not the link + -- directly from the body to the spec, then we make the After of the + -- link reference its spec instead, marking the link appropriately. + + if Units.Table (After).Utype = Is_Body then + Cspec := Corresponding_Spec (After); + + if Units.Table (Cspec).Elaborate_Body + and then Cspec /= Before + then + Succ.Table (Succ.Last).After := Cspec; + Succ.Table (Succ.Last).Elab_Body := True; + UNR.Table (Cspec).Num_Pred := UNR.Table (Cspec).Num_Pred + 1; + return; + end if; + end if; + + -- Fall through on normal case + + Succ.Table (Succ.Last).After := After; + Succ.Table (Succ.Last).Elab_Body := False; + UNR.Table (After).Num_Pred := UNR.Table (After).Num_Pred + 1; + end Build_Link; + + ------------ + -- Choose -- + ------------ + + procedure Choose (Chosen : Unit_Id) is + S : Successor_Id; + U : Unit_Id; + + begin + if Debug_Flag_C then + Write_Str ("Choosing Unit "); + Write_Unit_Name (Units.Table (Chosen).Uname); + Write_Eol; + end if; + + -- Add to elaboration order. Note that units having no elaboration + -- code are not treated specially yet. The special casing of this + -- is in Bindgen, where Gen_Elab_Calls skips over them. Meanwhile + -- we need them here, because the object file list is also driven + -- by the contents of the Elab_Order table. + + Elab_Order.Increment_Last; + Elab_Order.Table (Elab_Order.Last) := Chosen; + + -- Remove from No_Pred list. This is a little inefficient and may + -- be we should doubly link the list, but it will do for now! + + if No_Pred = Chosen then + No_Pred := UNR.Table (Chosen).Nextnp; + + else + -- Note that we just ignore the situation where it does not + -- appear in the No_Pred list, this happens in calls from the + -- Diagnose_Elaboration_Problem routine, where cycles are being + -- removed arbitrarily from the graph. + + U := No_Pred; + while U /= No_Unit_Id loop + if UNR.Table (U).Nextnp = Chosen then + UNR.Table (U).Nextnp := UNR.Table (Chosen).Nextnp; + exit; + end if; + + U := UNR.Table (U).Nextnp; + end loop; + end if; + + -- For all successors, decrement the number of predecessors, and + -- if it becomes zero, then add to no predecessor list. + + S := UNR.Table (Chosen).Successors; + while S /= No_Successor loop + U := Succ.Table (S).After; + UNR.Table (U).Num_Pred := UNR.Table (U).Num_Pred - 1; + + if Debug_Flag_N then + Write_Str (" decrementing Num_Pred for unit "); + Write_Unit_Name (Units.Table (U).Uname); + Write_Str (" new value = "); + Write_Int (UNR.Table (U).Num_Pred); + Write_Eol; + end if; + + if UNR.Table (U).Num_Pred = 0 then + UNR.Table (U).Nextnp := No_Pred; + No_Pred := U; + end if; + + S := Succ.Table (S).Next; + end loop; + + -- All done, adjust number of units left count and set elaboration pos + + Num_Left := Num_Left - 1; + Num_Chosen := Num_Chosen + 1; + UNR.Table (Chosen).Elab_Position := Num_Chosen; + Units.Table (Chosen).Elab_Position := Num_Chosen; + + -- If we just chose a spec with Elaborate_Body set, then we + -- must immediately elaborate the body, before any other units. + + if Units.Table (Chosen).Elaborate_Body then + + -- If the unit is a spec only, then there is no body. This is a bit + -- odd given that Elaborate_Body is here, but it is valid in an + -- RCI unit, where we only have the interface in the stub bind. + + if Units.Table (Chosen).Utype = Is_Spec_Only + and then Units.Table (Chosen).RCI + then + null; + else + Choose (Corresponding_Body (Chosen)); + end if; + end if; + end Choose; + + ------------------------ + -- Corresponding_Body -- + ------------------------ + + -- Currently if the body and spec are separate, then they appear as + -- two separate units in the same ALI file, with the body appearing + -- first and the spec appearing second. + + function Corresponding_Body (U : Unit_Id) return Unit_Id is + begin + pragma Assert (Units.Table (U).Utype = Is_Spec); + return U - 1; + end Corresponding_Body; + + ------------------------ + -- Corresponding_Spec -- + ------------------------ + + -- Currently if the body and spec are separate, then they appear as + -- two separate units in the same ALI file, with the body appearing + -- first and the spec appearing second. + + function Corresponding_Spec (U : Unit_Id) return Unit_Id is + begin + pragma Assert (Units.Table (U).Utype = Is_Body); + return U + 1; + end Corresponding_Spec; + + ---------------------------------- + -- Diagnose_Elaboration_Problem -- + ---------------------------------- + + procedure Diagnose_Elaboration_Problem is + + function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean; + -- Recursive routine used to find a path from node Ufrom to node Uto. + -- If a path exists, returns True and outputs an appropriate set of + -- error messages giving the path. Also calls Choose for each of the + -- nodes so that they get removed from the remaining set. There are + -- two cases of calls, either Ufrom = Uto for an attempt to find a + -- cycle, or Ufrom is a spec and Uto the corresponding body for the + -- case of an unsatisfiable Elaborate_Body pragma. ML is the minimum + -- acceptable length for a path. + + --------------- + -- Find_Path -- + --------------- + + function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean is + + function Find_Link (U : Unit_Id; PL : Nat) return Boolean; + -- This is the inner recursive routine, it determines if a path + -- exists from U to Uto, and if so returns True and outputs the + -- appropriate set of error messages. PL is the path length + + --------------- + -- Find_Link -- + --------------- + + function Find_Link (U : Unit_Id; PL : Nat) return Boolean is + S : Successor_Id; + + begin + -- Recursion ends if we are at terminating node and the path + -- is sufficiently long, generate error message and return True. + + if U = Uto and then PL >= ML then + Choose (U); + return True; + + -- All done if already visited, otherwise mark as visited + + elsif UNR.Table (U).Visited then + return False; + + -- Otherwise mark as visited and look at all successors + + else + UNR.Table (U).Visited := True; + + S := UNR.Table (U).Successors; + while S /= No_Successor loop + if Find_Link (Succ.Table (S).After, PL + 1) then + Elab_Error_Msg (S); + Choose (U); + return True; + end if; + + S := Succ.Table (S).Next; + end loop; + + -- Falling through means this does not lead to a path + + return False; + end if; + end Find_Link; + + -- Start of processing for Find_Path + + begin + -- Initialize all non-chosen nodes to not visisted yet + + for U in Units.First .. Units.Last loop + UNR.Table (U).Visited := UNR.Table (U).Elab_Position /= 0; + end loop; + + -- Now try to find the path + + return Find_Link (Ufrom, 0); + end Find_Path; + + -- Start of processing for Diagnose_Elaboration_Error + + begin + Set_Standard_Error; + + -- Output state of things if debug flag N set + + if Debug_Flag_N then + declare + NP : Int; + + begin + Write_Eol; + Write_Eol; + Write_Str ("Diagnose_Elaboration_Problem called"); + Write_Eol; + Write_Str ("List of remaining unchosen units and predecessors"); + Write_Eol; + + for U in Units.First .. Units.Last loop + if UNR.Table (U).Elab_Position = 0 then + NP := UNR.Table (U).Num_Pred; + Write_Eol; + Write_Str (" Unchosen unit: #"); + Write_Int (Int (U)); + Write_Str (" "); + Write_Unit_Name (Units.Table (U).Uname); + Write_Str (" (Num_Pred = "); + Write_Int (NP); + Write_Char (')'); + Write_Eol; + + if NP = 0 then + if Units.Table (U).Elaborate_Body then + Write_Str + (" (not chosen because of Elaborate_Body)"); + Write_Eol; + else + Write_Str (" ****************** why not chosen?"); + Write_Eol; + end if; + end if; + + -- Search links list to find unchosen predecessors + + for S in Succ.First .. Succ.Last loop + declare + SL : Successor_Link renames Succ.Table (S); + + begin + if SL.After = U + and then UNR.Table (SL.Before).Elab_Position = 0 + then + Write_Str (" unchosen predecessor: #"); + Write_Int (Int (SL.Before)); + Write_Str (" "); + Write_Unit_Name (Units.Table (SL.Before).Uname); + Write_Eol; + NP := NP - 1; + end if; + end; + end loop; + + if NP /= 0 then + Write_Str (" **************** Num_Pred value wrong!"); + Write_Eol; + end if; + end if; + end loop; + end; + end if; + + -- Output the header for the error, and manually increment the + -- error count. We are using Error_Msg_Output rather than Error_Msg + -- here for two reasons: + + -- This is really only one error, not one for each line + -- We want this output on standard output since it is voluminous + + -- But we do need to deal with the error count manually in this case + + Errors_Detected := Errors_Detected + 1; + Error_Msg_Output ("elaboration circularity detected", Info => False); + + -- Try to find cycles starting with any of the remaining nodes that have + -- not yet been chosen. There must be at least one (there is some reason + -- we are being called!) + + for U in Units.First .. Units.Last loop + if UNR.Table (U).Elab_Position = 0 then + if Find_Path (U, U, 1) then + raise Unrecoverable_Error; + end if; + end if; + end loop; + + -- We should never get here, since we were called for some reason, + -- and we should have found and eliminated at least one bad path. + + raise Program_Error; + end Diagnose_Elaboration_Problem; + + -------------------- + -- Elab_All_Links -- + -------------------- + + procedure Elab_All_Links + (Before : Unit_Id; + After : Unit_Id; + Reason : Succ_Reason; + Link : Elab_All_Id) + is + begin + if UNR.Table (Before).Visited then + return; + end if; + + -- Build the direct link for Before + + UNR.Table (Before).Visited := True; + Build_Link (Before, After, Reason, Link); + + -- Process all units with'ed by Before recursively + + for W in + Units.Table (Before).First_With .. Units.Table (Before).Last_With + loop + -- Skip if this with is an interface to a stand-alone library. + -- Skip also if no ALI file for this WITH, happens for language + -- defined generics while bootstrapping the compiler (see body of + -- Lib.Writ.Write_With_Lines). Finally, skip if it is a limited + -- with clause, which does not impose an elaboration link. + + if not Withs.Table (W).SAL_Interface + and then Withs.Table (W).Afile /= No_File + and then not Withs.Table (W).Limited_With + then + declare + Info : constant Int := + Get_Name_Table_Info + (Withs.Table (W).Uname); + + begin + -- If the unit is unknown, for some unknown reason, fail + -- graciously explaining that the unit is unknown. Without + -- this check, gnatbind will crash in Unit_Id_Of. + + if Info = 0 or else Unit_Id (Info) = No_Unit_Id then + declare + Withed : String := + Get_Name_String (Withs.Table (W).Uname); + Last_Withed : Natural := Withed'Last; + Withing : String := + Get_Name_String + (Units.Table (Before).Uname); + Last_Withing : Natural := Withing'Last; + Spec_Body : String := " (Spec)"; + + begin + To_Mixed (Withed); + To_Mixed (Withing); + + if Last_Withed > 2 and then + Withed (Last_Withed - 1) = '%' + then + Last_Withed := Last_Withed - 2; + end if; + + if Last_Withing > 2 and then + Withing (Last_Withing - 1) = '%' + then + Last_Withing := Last_Withing - 2; + end if; + + if Units.Table (Before).Utype = Is_Body or else + Units.Table (Before).Utype = Is_Body_Only + then + Spec_Body := " (Body)"; + end if; + + Osint.Fail + ("could not find unit " + & Withed (Withed'First .. Last_Withed) & " needed by " + & Withing (Withing'First .. Last_Withing) & Spec_Body); + end; + end if; + + Elab_All_Links + (Unit_Id_Of (Withs.Table (W).Uname), + After, + Reason, + Make_Elab_Entry (Withs.Table (W).Uname, Link)); + end; + end if; + end loop; + + -- Process corresponding body, if there is one + + if Units.Table (Before).Utype = Is_Spec then + Elab_All_Links + (Corresponding_Body (Before), + After, Reason, + Make_Elab_Entry + (Units.Table (Corresponding_Body (Before)).Uname, Link)); + end if; + end Elab_All_Links; + + -------------------- + -- Elab_Error_Msg -- + -------------------- + + procedure Elab_Error_Msg (S : Successor_Id) is + SL : Successor_Link renames Succ.Table (S); + + begin + -- Nothing to do if internal unit involved and no -da flag + + if not Debug_Flag_A + and then + (Is_Internal_File_Name (Units.Table (SL.Before).Sfile) + or else + Is_Internal_File_Name (Units.Table (SL.After).Sfile)) + then + return; + end if; + + -- Here we want to generate output + + Error_Msg_Unit_1 := Units.Table (SL.Before).Uname; + + if SL.Elab_Body then + Error_Msg_Unit_2 := Units.Table (Corresponding_Body (SL.After)).Uname; + else + Error_Msg_Unit_2 := Units.Table (SL.After).Uname; + end if; + + Error_Msg_Output (" $ must be elaborated before $", Info => True); + + Error_Msg_Unit_1 := Units.Table (SL.Reason_Unit).Uname; + + case SL.Reason is + when Withed => + Error_Msg_Output + (" reason: with clause", + Info => True); + + when Elab => + Error_Msg_Output + (" reason: pragma Elaborate in unit $", + Info => True); + + when Elab_All => + Error_Msg_Output + (" reason: pragma Elaborate_All in unit $", + Info => True); + + when Elab_All_Desirable => + Error_Msg_Output + (" reason: implicit Elaborate_All in unit $", + Info => True); + + Error_Msg_Output + (" recompile $ with -gnatwl for full details", + Info => True); + + when Elab_Desirable => + Error_Msg_Output + (" reason: implicit Elaborate in unit $", + Info => True); + + Error_Msg_Output + (" recompile $ with -gnatwl for full details", + Info => True); + + when Spec_First => + Error_Msg_Output + (" reason: spec always elaborated before body", + Info => True); + end case; + + Write_Elab_All_Chain (S); + + if SL.Elab_Body then + Error_Msg_Unit_1 := Units.Table (SL.Before).Uname; + Error_Msg_Unit_2 := Units.Table (SL.After).Uname; + Error_Msg_Output + (" $ must therefore be elaborated before $", + True); + + Error_Msg_Unit_1 := Units.Table (SL.After).Uname; + Error_Msg_Output + (" (because $ has a pragma Elaborate_Body)", + True); + end if; + + if not Zero_Formatting then + Write_Eol; + end if; + end Elab_Error_Msg; + + --------------------- + -- Find_Elab_Order -- + --------------------- + + procedure Find_Elab_Order is + U : Unit_Id; + Best_So_Far : Unit_Id; + + begin + Succ.Init; + Num_Left := Int (Units.Last - Units.First + 1); + + -- Initialize unit table for elaboration control + + for U in Units.First .. Units.Last loop + UNR.Increment_Last; + UNR.Table (UNR.Last).Successors := No_Successor; + UNR.Table (UNR.Last).Num_Pred := 0; + UNR.Table (UNR.Last).Nextnp := No_Unit_Id; + UNR.Table (UNR.Last).Elab_Order := 0; + UNR.Table (UNR.Last).Elab_Position := 0; + end loop; + + -- Output warning if -p used with no -gnatE units + + if Pessimistic_Elab_Order + and not Dynamic_Elaboration_Checks_Specified + then + if OpenVMS_On_Target then + Error_Msg ("?use of /PESSIMISTIC_ELABORATION questionable"); + else + Error_Msg ("?use of -p switch questionable"); + end if; + + Error_Msg ("?since all units compiled with static elaboration model"); + end if; + + -- Gather dependencies and output them if option set + + Gather_Dependencies; + + -- Output elaboration dependencies if option is set + + if Elab_Dependency_Output or Debug_Flag_E then + Write_Dependencies; + end if; + + -- Initialize the no predecessor list + + No_Pred := No_Unit_Id; + + for U in UNR.First .. UNR.Last loop + if UNR.Table (U).Num_Pred = 0 then + UNR.Table (U).Nextnp := No_Pred; + No_Pred := U; + end if; + end loop; + + -- OK, now we determine the elaboration order proper. All we do is to + -- select the best choice from the no predecessor list until all the + -- nodes have been chosen. + + Outer : loop + + -- If there are no nodes with predecessors, then either we are + -- done, as indicated by Num_Left being set to zero, or we have + -- a circularity. In the latter case, diagnose the circularity, + -- removing it from the graph and continue + + Get_No_Pred : while No_Pred = No_Unit_Id loop + exit Outer when Num_Left < 1; + Diagnose_Elaboration_Problem; + end loop Get_No_Pred; + + U := No_Pred; + Best_So_Far := No_Unit_Id; + + -- Loop to choose best entry in No_Pred list + + No_Pred_Search : loop + if Debug_Flag_N then + Write_Str (" considering choice of "); + Write_Unit_Name (Units.Table (U).Uname); + Write_Eol; + + if Units.Table (U).Elaborate_Body then + Write_Str + (" Elaborate_Body = True, Num_Pred for body = "); + Write_Int + (UNR.Table (Corresponding_Body (U)).Num_Pred); + else + Write_Str + (" Elaborate_Body = False"); + end if; + + Write_Eol; + end if; + + -- This is a candididate to be considered for choice + + if Best_So_Far = No_Unit_Id + or else ((not Pessimistic_Elab_Order) + and then Better_Choice (U, Best_So_Far)) + or else (Pessimistic_Elab_Order + and then Pessimistic_Better_Choice (U, Best_So_Far)) + then + if Debug_Flag_N then + Write_Str (" tentatively chosen (best so far)"); + Write_Eol; + end if; + + Best_So_Far := U; + end if; + + U := UNR.Table (U).Nextnp; + exit No_Pred_Search when U = No_Unit_Id; + end loop No_Pred_Search; + + -- If no candididate chosen, it means that no unit has No_Pred = 0, + -- but there are units left, hence we have a circular dependency, + -- which we will get Diagnose_Elaboration_Problem to diagnose it. + + if Best_So_Far = No_Unit_Id then + Diagnose_Elaboration_Problem; + + -- Otherwise choose the best candidate found + + else + Choose (Best_So_Far); + end if; + end loop Outer; + end Find_Elab_Order; + + ------------------------- + -- Gather_Dependencies -- + ------------------------- + + procedure Gather_Dependencies is + Withed_Unit : Unit_Id; + + begin + -- Loop through all units + + for U in Units.First .. Units.Last loop + Cur_Unit := U; + + -- If this is not an interface to a stand-alone library and + -- there is a body and a spec, then spec must be elaborated first + -- Note that the corresponding spec immediately follows the body + + if not Units.Table (U).SAL_Interface + and then Units.Table (U).Utype = Is_Body + then + Build_Link (Corresponding_Spec (U), U, Spec_First); + end if; + + -- If this unit is not an interface to a stand-alone library, + -- process WITH references for this unit ignoring generic units and + -- interfaces to stand-alone libraries. + + if not Units.Table (U).SAL_Interface then + for + W in Units.Table (U).First_With .. Units.Table (U).Last_With + loop + if Withs.Table (W).Sfile /= No_File + and then (not Withs.Table (W).SAL_Interface) + then + -- Check for special case of withing a unit that does not + -- exist any more. If the unit was completely missing we + -- would already have detected this, but a nasty case arises + -- when we have a subprogram body with no spec, and some + -- obsolete unit with's a previous (now disappeared) spec. + + if Get_Name_Table_Info (Withs.Table (W).Uname) = 0 then + Error_Msg_File_1 := Units.Table (U).Sfile; + Error_Msg_Unit_1 := Withs.Table (W).Uname; + Error_Msg ("{ depends on $ which no longer exists"); + goto Next_With; + end if; + + Withed_Unit := Unit_Id_Of (Withs.Table (W).Uname); + + -- Pragma Elaborate_All case, for this we use the recursive + -- Elab_All_Links procedure to establish the links. + + if Withs.Table (W).Elaborate_All then + + -- Reset flags used to stop multiple visits to a given + -- node. + + for Uref in UNR.First .. UNR.Last loop + UNR.Table (Uref).Visited := False; + end loop; + + -- Now establish all the links we need + + Elab_All_Links + (Withed_Unit, U, Elab_All, + Make_Elab_Entry + (Withs.Table (W).Uname, No_Elab_All_Link)); + + -- Elaborate_All_Desirable case, for this we establish the + -- same links as above, but with a different reason. + + elsif Withs.Table (W).Elab_All_Desirable then + + -- Reset flags used to stop multiple visits to a given + -- node. + + for Uref in UNR.First .. UNR.Last loop + UNR.Table (Uref).Visited := False; + end loop; + + -- Now establish all the links we need + + Elab_All_Links + (Withed_Unit, U, Elab_All_Desirable, + Make_Elab_Entry + (Withs.Table (W).Uname, No_Elab_All_Link)); + + -- Pragma Elaborate case. We must build a link for the + -- withed unit itself, and also the corresponding body if + -- there is one. + + -- However, skip this processing if there is no ALI file for + -- the WITH entry, because this means it is a generic (even + -- when we fix the generics so that an ALI file is present, + -- we probably still will have no ALI file for unchecked and + -- other special cases). + + elsif Withs.Table (W).Elaborate + and then Withs.Table (W).Afile /= No_File + then + Build_Link (Withed_Unit, U, Withed); + + if Units.Table (Withed_Unit).Utype = Is_Spec then + Build_Link + (Corresponding_Body (Withed_Unit), U, Elab); + end if; + + -- Elaborate_Desirable case, for this we establish + -- the same links as above, but with a different reason. + + elsif Withs.Table (W).Elab_Desirable then + Build_Link (Withed_Unit, U, Withed); + + if Units.Table (Withed_Unit).Utype = Is_Spec then + Build_Link + (Corresponding_Body (Withed_Unit), + U, Elab_Desirable); + end if; + + -- A limited_with does not establish an elaboration + -- dependence (that's the whole point!). + + elsif Withs.Table (W).Limited_With then + null; + + -- Case of normal WITH with no elaboration pragmas, just + -- build the single link to the directly referenced unit + + else + Build_Link (Withed_Unit, U, Withed); + end if; + end if; + + <> + null; + end loop; + end if; + end loop; + end Gather_Dependencies; + + ------------------ + -- Is_Body_Unit -- + ------------------ + + function Is_Body_Unit (U : Unit_Id) return Boolean is + begin + return Units.Table (U).Utype = Is_Body + or else Units.Table (U).Utype = Is_Body_Only; + end Is_Body_Unit; + + ----------------------------- + -- Is_Pure_Or_Preelab_Unit -- + ----------------------------- + + function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean is + begin + -- If we have a body with separate spec, test flags on the spec + + if Units.Table (U).Utype = Is_Body then + return Units.Table (U + 1).Preelab + or else + Units.Table (U + 1).Pure; + + -- Otherwise we have a spec or body acting as spec, test flags on unit + + else + return Units.Table (U).Preelab + or else + Units.Table (U).Pure; + end if; + end Is_Pure_Or_Preelab_Unit; + + --------------------- + -- Is_Waiting_Body -- + --------------------- + + function Is_Waiting_Body (U : Unit_Id) return Boolean is + begin + return Units.Table (U).Utype = Is_Body + and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0; + end Is_Waiting_Body; + + --------------------- + -- Make_Elab_Entry -- + --------------------- + + function Make_Elab_Entry + (Unam : Unit_Name_Type; + Link : Elab_All_Id) return Elab_All_Id + is + begin + Elab_All_Entries.Increment_Last; + Elab_All_Entries.Table (Elab_All_Entries.Last).Needed_By := Unam; + Elab_All_Entries.Table (Elab_All_Entries.Last).Next_Elab := Link; + return Elab_All_Entries.Last; + end Make_Elab_Entry; + + ------------------------------- + -- Pessimistic_Better_Choice -- + ------------------------------- + + function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean is + UT1 : Unit_Record renames Units.Table (U1); + UT2 : Unit_Record renames Units.Table (U2); + + begin + if Debug_Flag_B then + Write_Str ("Pessimistic_Better_Choice ("); + Write_Unit_Name (UT1.Uname); + Write_Str (", "); + Write_Unit_Name (UT2.Uname); + Write_Line (")"); + end if; + + -- Note: the checks here are applied in sequence, and the ordering is + -- significant (i.e. the more important criteria are applied first). + + -- If either unit is predefined or internal, then we use the normal + -- Better_Choice rule, since we don't want to disturb the elaboration + -- rules of the language with -p, same treatment for Pure/Preelab. + + -- Prefer a predefined unit to a non-predefined unit + + if UT1.Predefined and then not UT2.Predefined then + if Debug_Flag_B then + Write_Line (" True: u1 is predefined, u2 is not"); + end if; + + return True; + + elsif UT2.Predefined and then not UT1.Predefined then + if Debug_Flag_B then + Write_Line (" False: u2 is predefined, u1 is not"); + end if; + + return False; + + -- Prefer an internal unit to a non-internal unit + + elsif UT1.Internal and then not UT2.Internal then + if Debug_Flag_B then + Write_Line (" True: u1 is internal, u2 is not"); + end if; + + return True; + + elsif UT2.Internal and then not UT1.Internal then + if Debug_Flag_B then + Write_Line (" False: u2 is internal, u1 is not"); + end if; + + return False; + + -- Prefer a pure or preelaborable unit to one that is not + + elsif Is_Pure_Or_Preelab_Unit (U1) + and then not + Is_Pure_Or_Preelab_Unit (U2) + then + if Debug_Flag_B then + Write_Line (" True: u1 is pure/preelab, u2 is not"); + end if; + + return True; + + elsif Is_Pure_Or_Preelab_Unit (U2) + and then not + Is_Pure_Or_Preelab_Unit (U1) + then + if Debug_Flag_B then + Write_Line (" False: u2 is pure/preelab, u1 is not"); + end if; + + return False; + + -- Prefer anything else to a waiting body. We want to make bodies wait + -- as long as possible, till we are forced to choose them! + + elsif Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then + if Debug_Flag_B then + Write_Line (" False: u1 is waiting body, u2 is not"); + end if; + + return False; + + elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then + if Debug_Flag_B then + Write_Line (" True: u2 is waiting body, u1 is not"); + end if; + + return True; + + -- Prefer a spec to a body (!) + + elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then + if Debug_Flag_B then + Write_Line (" False: u1 is body, u2 is not"); + end if; + + return False; + + elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then + if Debug_Flag_B then + Write_Line (" True: u2 is body, u1 is not"); + end if; + + return True; + + -- If both are waiting bodies, then prefer the one whose spec is + -- less recently elaborated. Consider the following: + + -- spec of A + -- spec of B + -- body of A or B? + + -- The normal waiting body preference would have placed the body of + -- A before the spec of B if it could. Since it could not, there it + -- must be the case that A depends on B. It is therefore a good idea + -- to put the body of B last so that if there is an elaboration order + -- problem, we will find it (that's what pessimistic order is about) + + elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then + declare + Result : constant Boolean := + UNR.Table (Corresponding_Spec (U1)).Elab_Position < + UNR.Table (Corresponding_Spec (U2)).Elab_Position; + begin + if Debug_Flag_B then + if Result then + Write_Line (" True: based on waiting body elab positions"); + else + Write_Line (" False: based on waiting body elab positions"); + end if; + end if; + + return Result; + end; + end if; + + -- Remaining choice rules are disabled by Debug flag -do + + if not Debug_Flag_O then + + -- The following deal with the case of specs which have been marked + -- as Elaborate_Body_Desirable. In the normal case, we generally want + -- to delay the elaboration of these specs as long as possible, so + -- that bodies have better chance of being elaborated closer to the + -- specs. Pessimistic_Better_Choice as usual wants to do the opposite + -- and elaborate such specs as early as possible. + + -- If we have two units, one of which is a spec for which this flag + -- is set, and the other is not, we normally prefer to delay the spec + -- for which the flag is set, so again Pessimistic_Better_Choice does + -- the opposite. + + if not UT1.Elaborate_Body_Desirable + and then UT2.Elaborate_Body_Desirable + then + if Debug_Flag_B then + Write_Line (" False: u1 is elab body desirable, u2 is not"); + end if; + + return False; + + elsif not UT2.Elaborate_Body_Desirable + and then UT1.Elaborate_Body_Desirable + then + if Debug_Flag_B then + Write_Line (" True: u1 is elab body desirable, u2 is not"); + end if; + + return True; + + -- If we have two specs that are both marked as Elaborate_Body + -- desirable, we normally prefer the one whose body is nearer to + -- being able to be elaborated, based on the Num_Pred count. This + -- helps to ensure bodies are as close to specs as possible. As + -- usual, Pessimistic_Better_Choice does the opposite. + + elsif UT1.Elaborate_Body_Desirable + and then UT2.Elaborate_Body_Desirable + then + declare + Result : constant Boolean := + UNR.Table (Corresponding_Body (U1)).Num_Pred >= + UNR.Table (Corresponding_Body (U2)).Num_Pred; + begin + if Debug_Flag_B then + if Result then + Write_Line (" True based on Num_Pred compare"); + else + Write_Line (" False based on Num_Pred compare"); + end if; + end if; + + return Result; + end; + end if; + end if; + + -- If we fall through, it means that no preference rule applies, so we + -- use alphabetical order to at least give a deterministic result. Since + -- Pessimistic_Better_Choice is in the business of stirring up the + -- order, we will use reverse alphabetical ordering. + + if Debug_Flag_B then + Write_Line (" choose on reverse alpha order"); + end if; + + return Uname_Less (UT2.Uname, UT1.Uname); + end Pessimistic_Better_Choice; + + ---------------- + -- Unit_Id_Of -- + ---------------- + + function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is + Info : constant Int := Get_Name_Table_Info (Uname); + begin + pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id); + return Unit_Id (Info); + end Unit_Id_Of; + + ------------------------ + -- Write_Dependencies -- + ------------------------ + + procedure Write_Dependencies is + begin + if not Zero_Formatting then + Write_Eol; + Write_Str (" ELABORATION ORDER DEPENDENCIES"); + Write_Eol; + Write_Eol; + end if; + + Info_Prefix_Suppress := True; + + for S in Succ_First .. Succ.Last loop + Elab_Error_Msg (S); + end loop; + + Info_Prefix_Suppress := False; + + if not Zero_Formatting then + Write_Eol; + end if; + end Write_Dependencies; + + -------------------------- + -- Write_Elab_All_Chain -- + -------------------------- + + procedure Write_Elab_All_Chain (S : Successor_Id) is + ST : constant Successor_Link := Succ.Table (S); + After : constant Unit_Name_Type := Units.Table (ST.After).Uname; + + L : Elab_All_Id; + Nam : Unit_Name_Type; + + First_Name : Boolean := True; + + begin + if ST.Reason in Elab_All .. Elab_All_Desirable then + L := ST.Elab_All_Link; + while L /= No_Elab_All_Link loop + Nam := Elab_All_Entries.Table (L).Needed_By; + Error_Msg_Unit_1 := Nam; + Error_Msg_Output (" $", Info => True); + + Get_Name_String (Nam); + + if Name_Buffer (Name_Len) = 'b' then + if First_Name then + Error_Msg_Output + (" must be elaborated along with its spec:", + Info => True); + + else + Error_Msg_Output + (" which must be elaborated " & + "along with its spec:", + Info => True); + end if; + + else + if First_Name then + Error_Msg_Output + (" is withed by:", + Info => True); + + else + Error_Msg_Output + (" which is withed by:", + Info => True); + end if; + end if; + + First_Name := False; + + L := Elab_All_Entries.Table (L).Next_Elab; + end loop; + + Error_Msg_Unit_1 := After; + Error_Msg_Output (" $", Info => True); + end if; + end Write_Elab_All_Chain; + +end Binde; diff --git a/gcc/ada/binde.ads b/gcc/ada/binde.ads new file mode 100644 index 000000000..7ffa13fb6 --- /dev/null +++ b/gcc/ada/binde.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 to determine elaboration order + +with ALI; use ALI; +with Table; +with Types; use Types; + +package Binde is + + -- The following table records the chosen elaboration order. It is used + -- by Gen_Elab_Call to generate the sequence of elaboration calls. Note + -- that units are included in this table even if they have no elaboration + -- routine, since the table is also used to drive the generation of object + -- files in the binder output. Gen_Elab_Call skips any units that have no + -- elaboration routine. + + package Elab_Order is new Table.Table ( + Table_Component_Type => Unit_Id, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 500, + Table_Increment => 200, + Table_Name => "Elab_Order"); + + procedure Find_Elab_Order; + -- Determine elaboration order + +end Binde; diff --git a/gcc/ada/binderr.adb b/gcc/ada/binderr.adb new file mode 100644 index 000000000..830a2f177 --- /dev/null +++ b/gcc/ada/binderr.adb @@ -0,0 +1,233 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D E R R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Butil; use Butil; +with Opt; use Opt; +with Output; use Output; + +package body Binderr is + + --------------- + -- Error_Msg -- + --------------- + + procedure Error_Msg (Msg : String) is + begin + if Msg (Msg'First) = '?' then + if Warning_Mode = Suppress then + return; + end if; + + if Warning_Mode = Treat_As_Error then + Errors_Detected := Errors_Detected + 1; + else + Warnings_Detected := Warnings_Detected + 1; + end if; + + else + Errors_Detected := Errors_Detected + 1; + end if; + + if Brief_Output or else (not Verbose_Mode) then + Set_Standard_Error; + Error_Msg_Output (Msg, Info => False); + Set_Standard_Output; + end if; + + if Verbose_Mode then + if Errors_Detected + Warnings_Detected = 0 then + Write_Eol; + end if; + + Error_Msg_Output (Msg, Info => False); + end if; + + -- If too many warnings print message and then turn off warnings + + if Warnings_Detected = Maximum_Messages then + Set_Standard_Error; + Write_Line ("maximum number of warnings reached"); + Write_Line ("further warnings will be suppressed"); + Set_Standard_Output; + Warning_Mode := Suppress; + end if; + + -- If too many errors print message and give fatal error + + if Errors_Detected = Maximum_Messages then + Set_Standard_Error; + Write_Line ("fatal error: maximum number of errors exceeded"); + Set_Standard_Output; + raise Unrecoverable_Error; + end if; + end Error_Msg; + + -------------------- + -- Error_Msg_Info -- + -------------------- + + procedure Error_Msg_Info (Msg : String) is + begin + if Brief_Output or else (not Verbose_Mode) then + Set_Standard_Error; + Error_Msg_Output (Msg, Info => True); + Set_Standard_Output; + end if; + + if Verbose_Mode then + Error_Msg_Output (Msg, Info => True); + end if; + + end Error_Msg_Info; + + ---------------------- + -- Error_Msg_Output -- + ---------------------- + + procedure Error_Msg_Output (Msg : String; Info : Boolean) is + Use_Second_File : Boolean := False; + Use_Second_Unit : Boolean := False; + Use_Second_Nat : Boolean := False; + Warning : Boolean := False; + + begin + if Warnings_Detected + Errors_Detected > Maximum_Messages then + Write_Str ("error: maximum errors exceeded"); + Write_Eol; + return; + end if; + + -- First, check for warnings + + for J in Msg'Range loop + if Msg (J) = '?' then + Warning := True; + exit; + end if; + end loop; + + if Warning then + Write_Str ("warning: "); + elsif Info then + if not Info_Prefix_Suppress then + Write_Str ("info: "); + end if; + else + Write_Str ("error: "); + end if; + + for J in Msg'Range loop + if Msg (J) = '%' then + Get_Name_String (Error_Msg_Name_1); + Write_Char ('"'); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Char ('"'); + + elsif Msg (J) = '{' then + if Use_Second_File then + Get_Name_String (Error_Msg_File_2); + else + Use_Second_File := True; + Get_Name_String (Error_Msg_File_1); + end if; + + Write_Char ('"'); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Char ('"'); + + elsif Msg (J) = '$' then + Write_Char ('"'); + + if Use_Second_Unit then + Write_Unit_Name (Error_Msg_Unit_2); + else + Use_Second_Unit := True; + Write_Unit_Name (Error_Msg_Unit_1); + end if; + + Write_Char ('"'); + + elsif Msg (J) = '#' then + if Use_Second_Nat then + Write_Int (Error_Msg_Nat_2); + else + Use_Second_Nat := True; + Write_Int (Error_Msg_Nat_1); + end if; + + elsif Msg (J) /= '?' then + Write_Char (Msg (J)); + end if; + end loop; + + Write_Eol; + end Error_Msg_Output; + + ---------------------- + -- Finalize_Binderr -- + ---------------------- + + procedure Finalize_Binderr is + begin + -- Message giving number of errors detected (verbose mode only) + + if Verbose_Mode then + Write_Eol; + + if Errors_Detected = 0 then + Write_Str ("No errors"); + + elsif Errors_Detected = 1 then + Write_Str ("1 error"); + + else + Write_Int (Errors_Detected); + Write_Str (" errors"); + end if; + + if Warnings_Detected = 1 then + Write_Str (", 1 warning"); + + elsif Warnings_Detected > 1 then + Write_Str (", "); + Write_Int (Warnings_Detected); + Write_Str (" warnings"); + end if; + + Write_Eol; + end if; + end Finalize_Binderr; + + ------------------------ + -- Initialize_Binderr -- + ------------------------ + + procedure Initialize_Binderr is + begin + Errors_Detected := 0; + Warnings_Detected := 0; + end Initialize_Binderr; + +end Binderr; diff --git a/gcc/ada/binderr.ads b/gcc/ada/binderr.ads new file mode 100644 index 000000000..3a419d5d6 --- /dev/null +++ b/gcc/ada/binderr.ads @@ -0,0 +1,132 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D E R 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 to output error messages for the binder +-- and also the routines for handling fatal error conditions in the binder. + +with Namet; use Namet; +with Types; use Types; + +package Binderr is + + Errors_Detected : Int; + -- Number of errors detected so far + + Warnings_Detected : Int; + -- Number of warnings detected + + Info_Prefix_Suppress : Boolean := False; + -- If set to True, the normal "info: " header before messages generated + -- by Error_Msg_Info will be omitted. + + --------------------------------------------------------- + -- Error Message Text and Message Insertion Characters -- + --------------------------------------------------------- + + -- Error message text strings are composed of letters, digits and the + -- special characters space, comma, period, colon and semicolon, + -- apostrophe and parentheses. Special insertion characters can also + -- appear which cause the error message circuit to modify the given + -- string as follows: + + -- Insertion character { (Left brace: insert file name from Names table) + -- The character { is replaced by the text for the file name specified + -- by the File_Name_Type value stored in Error_Msg_File_1. The name is + -- always enclosed in quotes. A second { may appear in a single message + -- in which case it is similarly replaced by the name which is + -- specified by the File_Name_Type value stored in Error_Msg_File_2. + + -- Insertion character $ (Dollar: insert unit name from Names table) + -- The character & is replaced by the text for the unit name specified + -- by the Name_Id value stored in Error_Msg_Unit_1. The name is always + -- enclosed in quotes. A second $ may appear in a single message in + -- which case it is similarly replaced by the name which is specified + -- by the Name_Id value stored in Error_Msg_Unit_2. + + -- Insertion character # (Pound: insert non-negative number in decimal) + -- The character # is replaced by the contents of Error_Msg_Nat_1 + -- converted into an unsigned decimal string. A second # may appear + -- in a single message, in which case it is similarly replaced by + -- the value stored in Error_Msg_Nat_2. + + -- Insertion character ? (Question mark: warning message) + -- The character ?, which must be the first character in the message + -- string, signals a warning message instead of an error message. + + ----------------------------------------------------- + -- Global Values Used for Error Message Insertions -- + ----------------------------------------------------- + + -- The following global variables are essentially additional parameters + -- passed to the error message routine for insertion sequences described + -- above. The reason these are passed globally is that the insertion + -- mechanism is essentially an untyped one in which the appropriate + -- variables are set depending on the specific insertion characters used. + + Error_Msg_Name_1 : Name_Id; + -- Name_Id value for % insertion characters in message + + Error_Msg_File_1 : File_Name_Type; + Error_Msg_File_2 : File_Name_Type; + -- Name_Id values for { insertion characters in message + + Error_Msg_Unit_1 : Unit_Name_Type; + Error_Msg_Unit_2 : Unit_Name_Type; + -- Name_Id values for $ insertion characters in message + + Error_Msg_Nat_1 : Nat; + Error_Msg_Nat_2 : Nat; + -- Integer values for # insertion characters in message + + ------------------------------ + -- Error Output Subprograms -- + ------------------------------ + + procedure Error_Msg (Msg : String); + -- Output specified error message to standard error or standard output + -- as governed by the brief and verbose switches, and update error + -- counts appropriately + + procedure Error_Msg_Info (Msg : String); + -- Output information line. Indentical in effect to Error_Msg, except + -- that the prefix is info: instead of error: and the error count is + -- not incremented. The prefix may be suppressed by setting the global + -- variable Info_Prefix_Suppress to True. + + procedure Error_Msg_Output (Msg : String; Info : Boolean); + -- Output given message, with insertions, to current message output file. + -- The second argument is True for an info message, false for a normal + -- warning or error message. Normally this is not called directly, but + -- rather only by Error_Msg or Error_Msg_Info. It is called directly + -- when the caller must control whether the output goes to stderr or + -- stdout (Error_Msg_Output always goes to the current output file). + + procedure Finalize_Binderr; + -- Finalize error output for one file + + procedure Initialize_Binderr; + -- Initialize error output for one file + +end Binderr; diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb new file mode 100644 index 000000000..b17d7b9a1 --- /dev/null +++ b/gcc/ada/bindgen.adb @@ -0,0 +1,3583 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D G E N -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with ALI; use ALI; +with Binde; use Binde; +with Casing; use Casing; +with Fname; use Fname; +with Gnatvsn; use Gnatvsn; +with Hostparm; +with Namet; use Namet; +with Opt; use Opt; +with Osint; use Osint; +with Osint.B; use Osint.B; +with Output; use Output; +with Rident; use Rident; +with Table; use Table; +with Targparm; use Targparm; +with Types; use Types; + +with System.OS_Lib; use System.OS_Lib; +with System.WCh_Con; use System.WCh_Con; + +with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A; + +package body Bindgen is + + Statement_Buffer : String (1 .. 1000); + -- Buffer used for constructing output statements + + Last : Natural := 0; + -- Last location in Statement_Buffer currently set + + With_DECGNAT : Boolean := False; + -- Flag which indicates whether the program uses the DECGNAT library + -- (presence of the unit DEC). + + With_GNARL : Boolean := False; + -- Flag which indicates whether the program uses the GNARL library + -- (presence of the unit System.OS_Interface) + + Num_Elab_Calls : Nat := 0; + -- Number of generated calls to elaboration routines + + System_Restrictions_Used : Boolean; + -- Flag indicating whether the unit System.Restrictions is in the closure + -- of the partition. This is set by Check_System_Restrictions_Used, and + -- is used to determine whether or not to initialize the restrictions + -- information in the body of the binder generated file (we do not want + -- to do this unconditionally, since it drags in the System.Restrictions + -- unit unconditionally, which is unpleasand, especially for ZFP etc.) + + ---------------------------------- + -- Interface_State Pragma Table -- + ---------------------------------- + + -- This table assembles the interface state pragma information from + -- all the units in the partition. Note that Bcheck has already checked + -- that the information is consistent across units. The entries + -- in this table are n/u/r/s for not set/user/runtime/system. + + package IS_Pragma_Settings is new Table.Table ( + Table_Component_Type => Character, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 100, + Table_Increment => 200, + Table_Name => "IS_Pragma_Settings"); + + -- This table assembles the Priority_Specific_Dispatching pragma + -- information from all the units in the partition. Note that Bcheck has + -- already checked that the information is consistent across units. + -- The entries in this table are the upper case first character of the + -- policy name, e.g. 'F' for FIFO_Within_Priorities. + + package PSD_Pragma_Settings is new Table.Table ( + Table_Component_Type => Character, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 100, + Table_Increment => 200, + Table_Name => "PSD_Pragma_Settings"); + + ---------------------- + -- Run-Time Globals -- + ---------------------- + + -- This section documents the global variables that set from the + -- generated binder file. + + -- Main_Priority : Integer; + -- Time_Slice_Value : Integer; + -- Heap_Size : Natural; + -- WC_Encoding : Character; + -- Locking_Policy : Character; + -- Queuing_Policy : Character; + -- Task_Dispatching_Policy : Character; + -- Priority_Specific_Dispatching : System.Address; + -- Num_Specific_Dispatching : Integer; + -- Restrictions : System.Address; + -- Interrupt_States : System.Address; + -- Num_Interrupt_States : Integer; + -- Unreserve_All_Interrupts : Integer; + -- Exception_Tracebacks : Integer; + -- Zero_Cost_Exceptions : Integer; + -- Detect_Blocking : Integer; + -- Default_Stack_Size : Integer; + -- Leap_Seconds_Support : Integer; + -- Main_CPU : Integer; + + -- Main_Priority is the priority value set by pragma Priority in the main + -- program. If no such pragma is present, the value is -1. + + -- Time_Slice_Value is the time slice value set by pragma Time_Slice in the + -- main program, or by the use of a -Tnnn parameter for the binder (if both + -- are present, the binder value overrides). The value is in milliseconds. + -- A value of zero indicates that time slicing should be suppressed. If no + -- pragma is present, and no -T switch was used, the value is -1. + + -- Heap_Size is the heap to use for memory allocations set by use of a + -- -Hnn parameter for the binder or by the GNAT$NO_MALLOC_64 logical. + -- Valid values are 32 and 64. This switch is only effective on VMS. + + -- WC_Encoding shows the wide character encoding method used for the main + -- program. This is one of the encoding letters defined in + -- System.WCh_Con.WC_Encoding_Letters. + + -- Locking_Policy is a space if no locking policy was specified for the + -- partition. If a locking policy was specified, the value is the upper + -- case first character of the locking policy name, for example, 'C' for + -- Ceiling_Locking. + + -- Queuing_Policy is a space if no queuing policy was specified for the + -- partition. If a queuing policy was specified, the value is the upper + -- case first character of the queuing policy name for example, 'F' for + -- FIFO_Queuing. + + -- Task_Dispatching_Policy is a space if no task dispatching policy was + -- specified for the partition. If a task dispatching policy was specified, + -- the value is the upper case first character of the policy name, e.g. 'F' + -- for FIFO_Within_Priorities. + + -- Priority_Specific_Dispatching is the address of a string used to store + -- the task dispatching policy specified for the different priorities in + -- the partition. The length of this string is determined by the last + -- priority for which such a pragma applies (the string will be a null + -- string if no specific dispatching policies were used). If pragma were + -- present, the entries apply to the priorities in sequence from the first + -- priority. The value stored is the upper case first character of the + -- policy name, or 'F' (for FIFO_Within_Priorities) as the default value + -- for those priority ranges not specified. + + -- Num_Specific_Dispatching is the length of the + -- Priority_Specific_Dispatching string. It will be set to zero if no + -- Priority_Specific_Dispatching pragmas are present. + + -- Restrictions is the address of a null-terminated string specifying the + -- restrictions information for the partition. The format is identical to + -- that of the parameter string found on R lines in ali files (see Lib.Writ + -- spec in lib-writ.ads for full details). The difference is that in this + -- context the values are the cumulative ones for the entire partition. + + -- Interrupt_States is the address of a string used to specify the + -- cumulative results of Interrupt_State pragmas used in the partition. + -- The length of this string is determined by the last interrupt for which + -- such a pragma is given (the string will be a null string if no pragmas + -- were used). If pragma were present the entries apply to the interrupts + -- in sequence from the first interrupt, and are set to one of four + -- possible settings: 'n' for not specified, 'u' for user, 'r' for run + -- time, 's' for system, see description of Interrupt_State pragma for + -- further details. + + -- Num_Interrupt_States is the length of the Interrupt_States string. It + -- will be set to zero if no Interrupt_State pragmas are present. + + -- Unreserve_All_Interrupts is set to one if at least one unit in the + -- partition had a pragma Unreserve_All_Interrupts, and zero otherwise. + + -- Exception_Tracebacks is set to one if the -E parameter was present + -- in the bind and to zero otherwise. Note that on some targets exception + -- tracebacks are provided by default, so a value of zero for this + -- parameter does not necessarily mean no trace backs are available. + + -- Zero_Cost_Exceptions is set to one if zero cost exceptions are used for + -- this partition, and to zero if longjmp/setjmp exceptions are used. + + -- Detect_Blocking indicates whether pragma Detect_Blocking is active or + -- not. A value of zero indicates that the pragma is not present, while a + -- value of 1 signals its presence in the partition. + + -- Default_Stack_Size is the default stack size used when creating an Ada + -- task with no explicit Storage_Size clause. + + -- Leap_Seconds_Support denotes whether leap seconds have been enabled or + -- disabled. A value of zero indicates that leap seconds are turned "off", + -- while a value of one signifies "on" status. + + -- Main_CPU is the processor set by pragma CPU in the main program. If no + -- such pragma is present, the value is -1. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure WBI (Info : String) renames Osint.B.Write_Binder_Info; + -- Convenient shorthand used throughout + + procedure Check_System_Restrictions_Used; + -- Sets flag System_Restrictions_Used (Set to True if and only if the unit + -- System.Restrictions is present in the partition, otherwise False). + + procedure Gen_Adainit_Ada; + -- Generates the Adainit procedure (Ada code case) + + procedure Gen_Adainit_C; + -- Generates the Adainit procedure (C code case) + + procedure Gen_Adafinal_Ada; + -- Generate the Adafinal procedure (Ada code case) + + procedure Gen_Adafinal_C; + -- Generate the Adafinal procedure (C code case) + + procedure Gen_Elab_Calls_Ada; + -- Generate sequence of elaboration calls (Ada code case) + + procedure Gen_Elab_Calls_C; + -- Generate sequence of elaboration calls (C code case) + + procedure Gen_Elab_Order_Ada; + -- Generate comments showing elaboration order chosen (Ada case) + + procedure Gen_Elab_Order_C; + -- Generate comments showing elaboration order chosen (C case) + + procedure Gen_Elab_Defs_C; + -- Generate sequence of definitions for elaboration routines (C code case) + + procedure Gen_Main_Ada; + -- Generate procedure main (Ada code case) + + procedure Gen_Main_C; + -- Generate main() procedure (C code case) + + procedure Gen_Object_Files_Options; + -- Output comments containing a list of the full names of the object + -- files to be linked and the list of linker options supplied by + -- Linker_Options pragmas in the source. (C and Ada code case) + + procedure Gen_Output_File_Ada (Filename : String); + -- Generate output file (Ada code case) + + procedure Gen_Output_File_C (Filename : String); + -- Generate output file (C code case) + + procedure Gen_Restrictions_Ada; + -- Generate initialization of restrictions variable (Ada code case) + + procedure Gen_Restrictions_C; + -- Generate initialization of restrictions variable (C code case) + + procedure Gen_Versions_Ada; + -- Output series of definitions for unit versions (Ada code case) + + procedure Gen_Versions_C; + -- Output series of definitions for unit versions (C code case) + + function Get_Ada_Main_Name return String; + -- This function is used in the Ada main output case to compute a usable + -- name for the generated main program. The normal main program name is + -- Ada_Main, but this won't work if the user has a unit with this name. + -- This function tries Ada_Main first, and if there is such a clash, then + -- it tries Ada_Name_01, Ada_Name_02 ... Ada_Name_99 in sequence. + + function Get_Main_Unit_Name (S : String) return String; + -- Return the main unit name corresponding to S by replacing '.' with '_' + + function Get_Main_Name return String; + -- This function is used in the Ada main output case to compute the + -- correct external main program. It is "main" by default, unless the + -- flag Use_Ada_Main_Program_Name_On_Target is set, in which case it + -- is the name of the Ada main name without the "_ada". This default + -- can be overridden explicitly using the -Mname binder switch. + + function Get_WC_Encoding return Character; + -- Return wide character encoding method to set as WC_Encoding in output. + -- If -W has been used, returns the specified encoding, otherwise returns + -- the encoding method used for the main program source. If there is no + -- main program source (-z switch used), returns brackets ('b'). + + function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean; + -- Compare linker options, when sorting, first according to + -- Is_Internal_File (internal files come later) and then by + -- elaboration order position (latest to earliest). + + procedure Move_Linker_Option (From : Natural; To : Natural); + -- Move routine for sorting linker options + + procedure Resolve_Binder_Options; + -- Set the value of With_GNARL and With_DECGNAT. The latter only on VMS + -- since it tests for a package named "dec" which might cause a conflict + -- on non-VMS systems. + + procedure Set_Char (C : Character); + -- Set given character in Statement_Buffer at the Last + 1 position + -- and increment Last by one to reflect the stored character. + + procedure Set_Int (N : Int); + -- Set given value in decimal in Statement_Buffer with no spaces + -- starting at the Last + 1 position, and updating Last past the value. + -- A minus sign is output for a negative value. + + procedure Set_Boolean (B : Boolean); + -- Set given boolean value in Statement_Buffer at the Last + 1 position + -- and update Last past the value. + + procedure Set_IS_Pragma_Table; + -- Initializes contents of IS_Pragma_Settings table from ALI table + + procedure Set_Main_Program_Name; + -- Given the main program name in Name_Buffer (length in Name_Len) + -- generate the name of the routine to be used in the call. The name + -- is generated starting at Last + 1, and Last is updated past it. + + procedure Set_Name_Buffer; + -- Set the value stored in positions 1 .. Name_Len of the Name_Buffer + + procedure Set_PSD_Pragma_Table; + -- Initializes contents of PSD_Pragma_Settings table from ALI table + + procedure Set_String (S : String); + -- Sets characters of given string in Statement_Buffer, starting at the + -- Last + 1 position, and updating last past the string value. + + procedure Set_String_Replace (S : String); + -- Replaces the last S'Length characters in the Statement_Buffer with + -- the characters of S. The caller must ensure that these characters do + -- in fact exist in the Statement_Buffer. + + procedure Set_Unit_Name; + -- Given a unit name in the Name_Buffer, copies it to Statement_Buffer, + -- starting at the Last + 1 position, and updating last past the value. + -- changing periods to double underscores, and updating Last appropriately. + + procedure Set_Unit_Number (U : Unit_Id); + -- Sets unit number (first unit is 1, leading zeroes output to line + -- up all output unit numbers nicely as required by the value, and + -- by the total number of units. + + procedure Write_Info_Ada_C (Ada : String; C : String; Common : String); + -- For C code case, write C & Common, for Ada case write Ada & Common + -- to current binder output file using Write_Binder_Info. + + procedure Write_Statement_Buffer; + -- Write out contents of statement buffer up to Last, and reset Last to 0 + + procedure Write_Statement_Buffer (S : String); + -- First writes its argument (using Set_String (S)), then writes out the + -- contents of statement buffer up to Last, and reset Last to 0 + + ------------------------------------ + -- Check_System_Restrictions_Used -- + ------------------------------------ + + procedure Check_System_Restrictions_Used is + begin + for J in Units.First .. Units.Last loop + if Get_Name_String (Units.Table (J).Sfile) = "s-restri.ads" then + System_Restrictions_Used := True; + return; + end if; + end loop; + + System_Restrictions_Used := False; + end Check_System_Restrictions_Used; + + ---------------------- + -- Gen_Adafinal_Ada -- + ---------------------- + + procedure Gen_Adafinal_Ada is + begin + WBI (""); + WBI (" procedure " & Ada_Final_Name.all & " is"); + WBI (" begin"); + + -- If compiling for the JVM, we directly call Adafinal because + -- we don't import it via Do_Finalize (see Gen_Output_File_Ada). + + if VM_Target /= No_VM then + WBI (" System.Standard_Library.Adafinal;"); + + -- If there is no finalization, there is nothing to do + + elsif Cumulative_Restrictions.Set (No_Finalization) then + WBI (" null;"); + else + WBI (" Do_Finalize;"); + end if; + + WBI (" end " & Ada_Final_Name.all & ";"); + end Gen_Adafinal_Ada; + + -------------------- + -- Gen_Adafinal_C -- + -------------------- + + procedure Gen_Adafinal_C is + begin + WBI ("void " & Ada_Final_Name.all & " (void) {"); + WBI (" system__standard_library__adafinal ();"); + WBI ("}"); + WBI (""); + end Gen_Adafinal_C; + + --------------------- + -- Gen_Adainit_Ada -- + --------------------- + + procedure Gen_Adainit_Ada is + Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority; + Main_CPU : Int renames ALIs.Table (ALIs.First).Main_CPU; + + begin + WBI (" procedure " & Ada_Init_Name.all & " is"); + + -- Generate externals for elaboration entities + + for E in Elab_Order.First .. Elab_Order.Last loop + declare + Unum : constant Unit_Id := Elab_Order.Table (E); + U : Unit_Record renames Units.Table (Unum); + + begin + -- Check for Elab_Entity to be set for this unit + + if U.Set_Elab_Entity + + -- Don't generate reference for stand alone library + + and then not U.SAL_Interface + + -- Don't generate reference for predefined file in No_Run_Time + -- mode, since we don't include the object files in this case + + and then not + (No_Run_Time_Mode + and then Is_Predefined_File_Name (U.Sfile)) + then + Set_String (" "); + Set_String ("E"); + Set_Unit_Number (Unum); + + case VM_Target is + when No_VM | JVM_Target => + Set_String (" : Boolean; pragma Import (Ada, "); + when CLI_Target => + Set_String (" : Boolean; pragma Import (CIL, "); + end case; + + Set_String ("E"); + Set_Unit_Number (Unum); + Set_String (", """); + Get_Name_String (U.Uname); + + -- In the case of JGNAT we need to emit an Import name that + -- includes the class name (using '$' separators in the case + -- of a child unit name). + + if VM_Target /= No_VM then + for J in 1 .. Name_Len - 2 loop + if VM_Target = CLI_Target + or else Name_Buffer (J) /= '.' + then + Set_Char (Name_Buffer (J)); + else + Set_String ("$"); + end if; + end loop; + + if VM_Target /= CLI_Target or else U.Unit_Kind = 's' then + Set_String ("."); + else + Set_String ("_pkg."); + end if; + + -- If the unit name is very long, then split the + -- Import link name across lines using "&" (occurs + -- in some C2 tests). + + if 2 * Name_Len + 60 > Hostparm.Max_Line_Length then + Set_String (""" &"); + Write_Statement_Buffer; + Set_String (" """); + end if; + end if; + + Set_Unit_Name; + Set_String ("_E"");"); + Write_Statement_Buffer; + end if; + end; + end loop; + + Write_Statement_Buffer; + + -- If the standard library is suppressed, then the only global variables + -- that might be needed (by the Ravenscar profile) are the priority and + -- the processor for the environment task. + + if Suppress_Standard_Library_On_Target then + if Main_Priority /= No_Main_Priority then + WBI (" Main_Priority : Integer;"); + WBI (" pragma Import (C, Main_Priority," & + " ""__gl_main_priority"");"); + WBI (""); + end if; + + if Main_CPU /= No_Main_CPU then + WBI (" Main_CPU : Integer;"); + WBI (" pragma Import (C, Main_CPU," & + " ""__gl_main_cpu"");"); + WBI (""); + end if; + + WBI (" begin"); + + if Main_Priority /= No_Main_Priority then + Set_String (" Main_Priority := "); + Set_Int (Main_Priority); + Set_Char (';'); + Write_Statement_Buffer; + end if; + + if Main_CPU /= No_Main_CPU then + Set_String (" Main_CPU := "); + Set_Int (Main_CPU); + Set_Char (';'); + Write_Statement_Buffer; + end if; + + if Main_Priority = No_Main_Priority + and then Main_CPU = No_Main_CPU + then + WBI (" null;"); + end if; + + -- Normal case (standard library not suppressed). Set all global values + -- used by the run time. + + else + WBI (" Main_Priority : Integer;"); + WBI (" pragma Import (C, Main_Priority, " & + """__gl_main_priority"");"); + WBI (" Time_Slice_Value : Integer;"); + WBI (" pragma Import (C, Time_Slice_Value, " & + """__gl_time_slice_val"");"); + WBI (" WC_Encoding : Character;"); + WBI (" pragma Import (C, WC_Encoding, ""__gl_wc_encoding"");"); + WBI (" Locking_Policy : Character;"); + WBI (" pragma Import (C, Locking_Policy, " & + """__gl_locking_policy"");"); + WBI (" Queuing_Policy : Character;"); + WBI (" pragma Import (C, Queuing_Policy, " & + """__gl_queuing_policy"");"); + WBI (" Task_Dispatching_Policy : Character;"); + WBI (" pragma Import (C, Task_Dispatching_Policy, " & + """__gl_task_dispatching_policy"");"); + WBI (" Priority_Specific_Dispatching : System.Address;"); + WBI (" pragma Import (C, Priority_Specific_Dispatching, " & + """__gl_priority_specific_dispatching"");"); + WBI (" Num_Specific_Dispatching : Integer;"); + WBI (" pragma Import (C, Num_Specific_Dispatching, " & + """__gl_num_specific_dispatching"");"); + WBI (" Main_CPU : Integer;"); + WBI (" pragma Import (C, Main_CPU, " & + """__gl_main_cpu"");"); + + WBI (" Interrupt_States : System.Address;"); + WBI (" pragma Import (C, Interrupt_States, " & + """__gl_interrupt_states"");"); + WBI (" Num_Interrupt_States : Integer;"); + WBI (" pragma Import (C, Num_Interrupt_States, " & + """__gl_num_interrupt_states"");"); + WBI (" Unreserve_All_Interrupts : Integer;"); + WBI (" pragma Import (C, Unreserve_All_Interrupts, " & + """__gl_unreserve_all_interrupts"");"); + + if Exception_Tracebacks then + WBI (" Exception_Tracebacks : Integer;"); + WBI (" pragma Import (C, Exception_Tracebacks, " & + """__gl_exception_tracebacks"");"); + end if; + + WBI (" Zero_Cost_Exceptions : Integer;"); + WBI (" pragma Import (C, Zero_Cost_Exceptions, " & + """__gl_zero_cost_exceptions"");"); + WBI (" Detect_Blocking : Integer;"); + WBI (" pragma Import (C, Detect_Blocking, " & + """__gl_detect_blocking"");"); + WBI (" Default_Stack_Size : Integer;"); + WBI (" pragma Import (C, Default_Stack_Size, " & + """__gl_default_stack_size"");"); + WBI (" Leap_Seconds_Support : Integer;"); + WBI (" pragma Import (C, Leap_Seconds_Support, " & + """__gl_leap_seconds_support"");"); + + -- Import entry point for elaboration time signal handler + -- installation, and indication of if it's been called previously. + + WBI (""); + WBI (" procedure Install_Handler;"); + WBI (" pragma Import (C, Install_Handler, " & + """__gnat_install_handler"");"); + WBI (""); + WBI (" Handler_Installed : Integer;"); + WBI (" pragma Import (C, Handler_Installed, " & + """__gnat_handler_installed"");"); + + -- Import entry point for environment feature enable/disable + -- routine, and indication that it's been called previously. + + if OpenVMS_On_Target then + WBI (""); + WBI (" procedure Set_Features;"); + WBI (" pragma Import (C, Set_Features, " & + """__gnat_set_features"");"); + WBI (""); + WBI (" Features_Set : Integer;"); + WBI (" pragma Import (C, Features_Set, " & + """__gnat_features_set"");"); + + if Opt.Heap_Size /= 0 then + WBI (""); + WBI (" Heap_Size : Integer;"); + WBI (" pragma Import (C, Heap_Size, " & + """__gl_heap_size"");"); + + Write_Statement_Buffer; + end if; + end if; + + -- Initialize stack limit variable of the environment task if the + -- stack check method is stack limit and stack check is enabled. + + if Stack_Check_Limits_On_Target + and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set) + then + WBI (""); + WBI (" procedure Initialize_Stack_Limit;"); + WBI (" pragma Import (C, Initialize_Stack_Limit, " & + """__gnat_initialize_stack_limit"");"); + end if; + + -- Special processing when main program is CIL function/procedure + + if VM_Target = CLI_Target + and then Bind_Main_Program + and then not No_Main_Subprogram + then + WBI (""); + + -- Function case, use Set_Exit_Status to report the returned + -- status code, since that is the only mechanism available. + + if ALIs.Table (ALIs.First).Main_Program = Func then + WBI (" Result : Integer;"); + WBI (" procedure Set_Exit_Status (Code : Integer);"); + WBI (" pragma Import (C, Set_Exit_Status, " & + """__gnat_set_exit_status"");"); + WBI (""); + WBI (" function Ada_Main_Program return Integer;"); + + -- Procedure case + + else + WBI (" procedure Ada_Main_Program;"); + end if; + + Get_Name_String (Units.Table (First_Unit_Entry).Uname); + Name_Len := Name_Len - 2; + WBI (" pragma Import (CIL, Ada_Main_Program, """ + & Name_Buffer (1 .. Name_Len) & "." + & Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len)) & """);"); + end if; + + WBI (" begin"); + + Set_String (" Main_Priority := "); + Set_Int (Main_Priority); + Set_Char (';'); + Write_Statement_Buffer; + + Set_String (" Time_Slice_Value := "); + + if Task_Dispatching_Policy_Specified = 'F' + and then ALIs.Table (ALIs.First).Time_Slice_Value = -1 + then + Set_Int (0); + else + Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value); + end if; + + Set_Char (';'); + Write_Statement_Buffer; + + Set_String (" WC_Encoding := '"); + Set_Char (Get_WC_Encoding); + + Set_String ("';"); + Write_Statement_Buffer; + + Set_String (" Locking_Policy := '"); + Set_Char (Locking_Policy_Specified); + Set_String ("';"); + Write_Statement_Buffer; + + Set_String (" Queuing_Policy := '"); + Set_Char (Queuing_Policy_Specified); + Set_String ("';"); + Write_Statement_Buffer; + + Set_String (" Task_Dispatching_Policy := '"); + Set_Char (Task_Dispatching_Policy_Specified); + Set_String ("';"); + Write_Statement_Buffer; + + Gen_Restrictions_Ada; + + WBI (" Priority_Specific_Dispatching :="); + WBI (" Local_Priority_Specific_Dispatching'Address;"); + + Set_String (" Num_Specific_Dispatching := "); + Set_Int (PSD_Pragma_Settings.Last + 1); + Set_Char (';'); + Write_Statement_Buffer; + + Set_String (" Main_CPU := "); + Set_Int (Main_CPU); + Set_Char (';'); + Write_Statement_Buffer; + + WBI (" Interrupt_States := Local_Interrupt_States'Address;"); + + Set_String (" Num_Interrupt_States := "); + Set_Int (IS_Pragma_Settings.Last + 1); + Set_Char (';'); + Write_Statement_Buffer; + + Set_String (" Unreserve_All_Interrupts := "); + + if Unreserve_All_Interrupts_Specified then + Set_String ("1"); + else + Set_String ("0"); + end if; + + Set_Char (';'); + Write_Statement_Buffer; + + if Exception_Tracebacks then + WBI (" Exception_Tracebacks := 1;"); + end if; + + Set_String (" Zero_Cost_Exceptions := "); + + if Zero_Cost_Exceptions_Specified then + Set_String ("1"); + else + Set_String ("0"); + end if; + + Set_String (";"); + Write_Statement_Buffer; + + Set_String (" Detect_Blocking := "); + + if Detect_Blocking then + Set_Int (1); + else + Set_Int (0); + end if; + + Set_String (";"); + Write_Statement_Buffer; + + Set_String (" Default_Stack_Size := "); + Set_Int (Default_Stack_Size); + Set_String (";"); + Write_Statement_Buffer; + + Set_String (" Leap_Seconds_Support := "); + + if Leap_Seconds_Support then + Set_Int (1); + else + Set_Int (0); + end if; + + Set_String (";"); + Write_Statement_Buffer; + + -- Generate call to Install_Handler + + -- In .NET, when binding with -z, we don't install the signal handler + -- to let the caller handle the last exception handler. + + if VM_Target /= CLI_Target + or else Bind_Main_Program + then + WBI (""); + WBI (" if Handler_Installed = 0 then"); + WBI (" Install_Handler;"); + WBI (" end if;"); + end if; + + -- Generate call to Set_Features + + if OpenVMS_On_Target then + WBI (""); + WBI (" if Features_Set = 0 then"); + WBI (" Set_Features;"); + WBI (" end if;"); + + -- Features_Set may twiddle the heap size according to a logical + -- name, but the binder switch must override. + + if Opt.Heap_Size /= 0 then + Set_String (" Heap_Size := "); + Set_Int (Opt.Heap_Size); + Set_Char (';'); + Write_Statement_Buffer; + end if; + end if; + end if; + + -- Generate call to set Initialize_Scalar values if active + + if Initialize_Scalars_Used then + WBI (""); + Set_String (" System.Scalar_Values.Initialize ('"); + Set_Char (Initialize_Scalars_Mode1); + Set_String ("', '"); + Set_Char (Initialize_Scalars_Mode2); + Set_String ("');"); + Write_Statement_Buffer; + end if; + + -- Generate assignment of default secondary stack size if set + + if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then + WBI (""); + Set_String (" System.Secondary_Stack."); + Set_String ("Default_Secondary_Stack_Size := "); + Set_Int (Opt.Default_Sec_Stack_Size); + Set_Char (';'); + Write_Statement_Buffer; + end if; + + -- Initialize stack limit variable of the environment task if the + -- stack check method is stack limit and stack check is enabled. + + if Stack_Check_Limits_On_Target + and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set) + then + WBI (""); + WBI (" Initialize_Stack_Limit;"); + end if; + + -- Generate elaboration calls + + WBI (""); + Gen_Elab_Calls_Ada; + + -- Case of main program is CIL function or procedure + + if VM_Target = CLI_Target + and then Bind_Main_Program + and then not No_Main_Subprogram + then + -- For function case, use Set_Exit_Status to set result + + if ALIs.Table (ALIs.First).Main_Program = Func then + WBI (" Result := Ada_Main_Program;"); + WBI (" Set_Exit_Status (Result);"); + + -- Procedure case + + else + WBI (" Ada_Main_Program;"); + end if; + end if; + + WBI (" end " & Ada_Init_Name.all & ";"); + end Gen_Adainit_Ada; + + ------------------- + -- Gen_Adainit_C -- + -------------------- + + procedure Gen_Adainit_C is + Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority; + Main_CPU : Int renames ALIs.Table (ALIs.First).Main_CPU; + + begin + WBI ("void " & Ada_Init_Name.all & " (void)"); + WBI ("{"); + + -- Generate externals for elaboration entities + + for E in Elab_Order.First .. Elab_Order.Last loop + declare + Unum : constant Unit_Id := Elab_Order.Table (E); + U : Unit_Record renames Units.Table (Unum); + + begin + -- Check for Elab entity to be set for this unit + + if U.Set_Elab_Entity + + -- Don't generate reference for stand alone library + + and then not U.SAL_Interface + + -- Don't generate reference for predefined file in No_Run_Time + -- mode, since we don't include the object files in this case + + and then not + (No_Run_Time_Mode + and then Is_Predefined_File_Name (U.Sfile)) + then + Set_String (" extern char "); + Get_Name_String (U.Uname); + Set_Unit_Name; + Set_String ("_E;"); + Write_Statement_Buffer; + end if; + end; + end loop; + + Write_Statement_Buffer; + + -- Standard library suppressed + + if Suppress_Standard_Library_On_Target then + + -- Case of High_Integrity_Mode mode. Set __gl_main_priority and + -- __gl_main_cpu if needed for the Ravenscar profile. + + if Main_Priority /= No_Main_Priority then + WBI (" extern int __gl_main_priority;"); + Set_String (" __gl_main_priority = "); + Set_Int (Main_Priority); + Set_Char (';'); + Write_Statement_Buffer; + end if; + + if Main_CPU /= No_Main_CPU then + WBI (" extern int __gl_main_cpu;"); + Set_String (" __gl_main_cpu = "); + Set_Int (Main_CPU); + Set_Char (';'); + Write_Statement_Buffer; + end if; + + -- Normal case (standard library not suppressed) + + else + -- Generate definition for interrupt states string + + Set_String (" static const char *local_interrupt_states = """); + + for J in 0 .. IS_Pragma_Settings.Last loop + Set_Char (IS_Pragma_Settings.Table (J)); + end loop; + + Set_String (""";"); + Write_Statement_Buffer; + + -- Generate definition for priority specific dispatching string + + Set_String + (" static const char *local_priority_specific_dispatching = """); + + for J in 0 .. PSD_Pragma_Settings.Last loop + Set_Char (PSD_Pragma_Settings.Table (J)); + end loop; + + Set_String (""";"); + Write_Statement_Buffer; + + -- Generate declaration for secondary stack default if needed + + if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then + WBI (" extern int system__secondary_stack__" & + "default_secondary_stack_size;"); + end if; + + WBI (""); + + -- Code for normal case (standard library not suppressed) + + -- We call the routine from inside adainit() because this works for + -- both programs with and without binder generated "main" functions. + + WBI (" extern int __gl_main_priority;"); + Set_String (" __gl_main_priority = "); + Set_Int (Main_Priority); + Set_Char (';'); + Write_Statement_Buffer; + + WBI (" extern int __gl_time_slice_val;"); + Set_String (" __gl_time_slice_val = "); + + if Task_Dispatching_Policy = 'F' + and then ALIs.Table (ALIs.First).Time_Slice_Value = -1 + then + Set_Int (0); + else + Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value); + end if; + + Set_Char (';'); + Write_Statement_Buffer; + + WBI (" extern char __gl_wc_encoding;"); + Set_String (" __gl_wc_encoding = '"); + Set_Char (Get_WC_Encoding); + + Set_String ("';"); + Write_Statement_Buffer; + + WBI (" extern char __gl_locking_policy;"); + Set_String (" __gl_locking_policy = '"); + Set_Char (Locking_Policy_Specified); + Set_String ("';"); + Write_Statement_Buffer; + + WBI (" extern char __gl_queuing_policy;"); + Set_String (" __gl_queuing_policy = '"); + Set_Char (Queuing_Policy_Specified); + Set_String ("';"); + Write_Statement_Buffer; + + WBI (" extern char __gl_task_dispatching_policy;"); + Set_String (" __gl_task_dispatching_policy = '"); + Set_Char (Task_Dispatching_Policy_Specified); + Set_String ("';"); + Write_Statement_Buffer; + + WBI (" extern int __gl_main_cpu;"); + Set_String (" __gl_main_cpu = "); + Set_Int (Main_CPU); + Set_Char (';'); + Write_Statement_Buffer; + + Gen_Restrictions_C; + + WBI (" extern const void *__gl_interrupt_states;"); + WBI (" __gl_interrupt_states = local_interrupt_states;"); + + WBI (" extern int __gl_num_interrupt_states;"); + Set_String (" __gl_num_interrupt_states = "); + Set_Int (IS_Pragma_Settings.Last + 1); + Set_String (";"); + Write_Statement_Buffer; + + WBI (" extern const void *__gl_priority_specific_dispatching;"); + WBI (" __gl_priority_specific_dispatching =" & + " local_priority_specific_dispatching;"); + + WBI (" extern int __gl_num_specific_dispatching;"); + Set_String (" __gl_num_specific_dispatching = "); + Set_Int (PSD_Pragma_Settings.Last + 1); + Set_String (";"); + Write_Statement_Buffer; + + WBI (" extern int __gl_unreserve_all_interrupts;"); + Set_String (" __gl_unreserve_all_interrupts = "); + Set_Int (Boolean'Pos (Unreserve_All_Interrupts_Specified)); + Set_String (";"); + Write_Statement_Buffer; + + if Exception_Tracebacks then + WBI (" extern int __gl_exception_tracebacks;"); + WBI (" __gl_exception_tracebacks = 1;"); + end if; + + WBI (" extern int __gl_zero_cost_exceptions;"); + Set_String (" __gl_zero_cost_exceptions = "); + Set_Int (Boolean'Pos (Zero_Cost_Exceptions_Specified)); + Set_String (";"); + Write_Statement_Buffer; + + WBI (" extern int __gl_detect_blocking;"); + Set_String (" __gl_detect_blocking = "); + + if Detect_Blocking then + Set_Int (1); + else + Set_Int (0); + end if; + + Set_String (";"); + Write_Statement_Buffer; + + WBI (" extern int __gl_default_stack_size;"); + Set_String (" __gl_default_stack_size = "); + Set_Int (Default_Stack_Size); + Set_String (";"); + Write_Statement_Buffer; + + WBI (" extern int __gl_leap_seconds_support;"); + Set_String (" __gl_leap_seconds_support = "); + + if Leap_Seconds_Support then + Set_Int (1); + else + Set_Int (0); + end if; + + Set_String (";"); + Write_Statement_Buffer; + + WBI (""); + + -- Install elaboration time signal handler + + WBI (" if (__gnat_handler_installed == 0)"); + WBI (" {"); + WBI (" __gnat_install_handler ();"); + WBI (" }"); + + -- Call feature enable/disable routine + + if OpenVMS_On_Target then + WBI (" if (__gnat_features_set == 0)"); + WBI (" {"); + WBI (" __gnat_set_features ();"); + WBI (" }"); + end if; + end if; + + -- Initialize stack limit for the environment task if the stack + -- check method is stack limit and stack check is enabled. + + if Stack_Check_Limits_On_Target + and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set) + then + WBI (""); + WBI (" __gnat_initialize_stack_limit ();"); + end if; + + -- Generate call to set Initialize_Scalar values if needed + + if Initialize_Scalars_Used then + WBI (""); + Set_String (" system__scalar_values__initialize('"); + Set_Char (Initialize_Scalars_Mode1); + Set_String ("', '"); + Set_Char (Initialize_Scalars_Mode2); + Set_String ("');"); + Write_Statement_Buffer; + end if; + + -- Generate assignment of default secondary stack size if set + + if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then + WBI (""); + Set_String (" system__secondary_stack__"); + Set_String ("default_secondary_stack_size = "); + Set_Int (Opt.Default_Sec_Stack_Size); + Set_Char (';'); + Write_Statement_Buffer; + end if; + + -- Generate elaboration calls + + WBI (""); + Gen_Elab_Calls_C; + WBI ("}"); + end Gen_Adainit_C; + + ------------------------ + -- Gen_Elab_Calls_Ada -- + ------------------------ + + procedure Gen_Elab_Calls_Ada is + begin + for E in Elab_Order.First .. Elab_Order.Last loop + declare + Unum : constant Unit_Id := Elab_Order.Table (E); + U : Unit_Record renames Units.Table (Unum); + + Unum_Spec : Unit_Id; + -- This is the unit number of the spec that corresponds to + -- this entry. It is the same as Unum except when the body + -- and spec are different and we are currently processing + -- the body, in which case it is the spec (Unum + 1). + + begin + if U.Utype = Is_Body then + Unum_Spec := Unum + 1; + else + Unum_Spec := Unum; + end if; + + -- Nothing to do if predefined unit in no run time mode + + if No_Run_Time_Mode and then Is_Predefined_File_Name (U.Sfile) then + null; + + -- Case of no elaboration code + + elsif U.No_Elab then + + -- The only case in which we have to do something is if + -- this is a body, with a separate spec, where the separate + -- spec has an elaboration entity defined. + + -- In that case, this is where we set the elaboration entity + -- to True, we do not need to test if this has already been + -- done, since it is quicker to set the flag than to test it. + + if not U.SAL_Interface and then U.Utype = Is_Body + and then Units.Table (Unum_Spec).Set_Elab_Entity + then + Set_String (" E"); + Set_Unit_Number (Unum_Spec); + Set_String (" := True;"); + Write_Statement_Buffer; + end if; + + -- Here if elaboration code is present. If binding a library + -- or if there is a non-Ada main subprogram then we generate: + + -- if not uname_E then + -- uname'elab_[spec|body]; + -- uname_E := True; + -- end if; + + -- Otherwise, elaboration routines are called unconditionally: + + -- uname'elab_[spec|body]; + -- uname_E := True; + + -- The uname_E assignment is skipped if this is a separate spec, + -- since the assignment will be done when we process the body. + + elsif not U.SAL_Interface then + if Force_Checking_Of_Elaboration_Flags or + Interface_Library_Unit or + (not Bind_Main_Program) + then + Set_String (" if not E"); + Set_Unit_Number (Unum_Spec); + Set_String (" then"); + Write_Statement_Buffer; + Set_String (" "); + end if; + + Set_String (" "); + Get_Decoded_Name_String_With_Brackets (U.Uname); + + if VM_Target = CLI_Target and then U.Unit_Kind /= 's' then + if Name_Buffer (Name_Len) = 's' then + Name_Buffer (Name_Len - 1 .. Name_Len + 12) := + "_pkg'elab_spec"; + else + Name_Buffer (Name_Len - 1 .. Name_Len + 12) := + "_pkg'elab_body"; + end if; + + Name_Len := Name_Len + 12; + + else + if Name_Buffer (Name_Len) = 's' then + Name_Buffer (Name_Len - 1 .. Name_Len + 8) := + "'elab_spec"; + else + Name_Buffer (Name_Len - 1 .. Name_Len + 8) := + "'elab_body"; + end if; + + Name_Len := Name_Len + 8; + end if; + + Set_Casing (U.Icasing); + Set_Name_Buffer; + Set_Char (';'); + Write_Statement_Buffer; + + if U.Utype /= Is_Spec then + if Force_Checking_Of_Elaboration_Flags or + Interface_Library_Unit or + (not Bind_Main_Program) + then + Set_String (" "); + end if; + + Set_String (" E"); + Set_Unit_Number (Unum_Spec); + Set_String (" := True;"); + Write_Statement_Buffer; + end if; + + if Force_Checking_Of_Elaboration_Flags or + Interface_Library_Unit or + (not Bind_Main_Program) + then + WBI (" end if;"); + end if; + end if; + end; + end loop; + end Gen_Elab_Calls_Ada; + + ---------------------- + -- Gen_Elab_Calls_C -- + ---------------------- + + procedure Gen_Elab_Calls_C is + begin + for E in Elab_Order.First .. Elab_Order.Last loop + declare + Unum : constant Unit_Id := Elab_Order.Table (E); + U : Unit_Record renames Units.Table (Unum); + + Unum_Spec : Unit_Id; + -- This is the unit number of the spec that corresponds to + -- this entry. It is the same as Unum except when the body + -- and spec are different and we are currently processing + -- the body, in which case it is the spec (Unum + 1). + + begin + if U.Utype = Is_Body then + Unum_Spec := Unum + 1; + else + Unum_Spec := Unum; + end if; + + -- Nothing to do if predefined unit in no run time mode + + if No_Run_Time_Mode and then Is_Predefined_File_Name (U.Sfile) then + null; + + -- Case of no elaboration code + + elsif U.No_Elab then + + -- The only case in which we have to do something is if + -- this is a body, with a separate spec, where the separate + -- spec has an elaboration entity defined. + + -- In that case, this is where we set the elaboration entity + -- to True, we do not need to test if this has already been + -- done, since it is quicker to set the flag than to test it. + + if not U.SAL_Interface and then U.Utype = Is_Body + and then Units.Table (Unum_Spec).Set_Elab_Entity + then + Set_String (" "); + Get_Name_String (U.Uname); + Set_Unit_Name; + Set_String ("_E = 1;"); + Write_Statement_Buffer; + end if; + + -- Here if elaboration code is present. If binding a library + -- or if there is a non-Ada main subprogram then we generate: + + -- if (uname_E == 0) { + -- uname__elab[s|b] (); + -- uname_E++; + -- } + + -- The uname_E assignment is skipped if this is a separate spec, + -- since the assignment will be done when we process the body. + + elsif not U.SAL_Interface then + Get_Name_String (U.Uname); + + if Force_Checking_Of_Elaboration_Flags or + Interface_Library_Unit or + (not Bind_Main_Program) + then + Set_String (" if ("); + Set_Unit_Name; + Set_String ("_E == 0) {"); + Write_Statement_Buffer; + Set_String (" "); + end if; + + Set_String (" "); + Set_Unit_Name; + Set_String ("___elab"); + Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body + Set_String (" ();"); + Write_Statement_Buffer; + + if U.Utype /= Is_Spec then + if Force_Checking_Of_Elaboration_Flags or + Interface_Library_Unit or + (not Bind_Main_Program) + then + Set_String (" "); + end if; + + Set_String (" "); + Set_Unit_Name; + Set_String ("_E++;"); + Write_Statement_Buffer; + end if; + + if Force_Checking_Of_Elaboration_Flags or + Interface_Library_Unit or + (not Bind_Main_Program) + then + WBI (" }"); + end if; + end if; + end; + end loop; + + end Gen_Elab_Calls_C; + + ---------------------- + -- Gen_Elab_Defs_C -- + ---------------------- + + procedure Gen_Elab_Defs_C is + begin + for E in Elab_Order.First .. Elab_Order.Last loop + + -- Generate declaration of elaboration procedure if elaboration + -- needed. Note that passive units are always excluded. + + if not Units.Table (Elab_Order.Table (E)).No_Elab then + Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname); + Set_String ("extern void "); + Set_Unit_Name; + Set_String ("___elab"); + Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body + Set_String (" (void);"); + Write_Statement_Buffer; + end if; + + end loop; + + WBI (""); + end Gen_Elab_Defs_C; + + ------------------------ + -- Gen_Elab_Order_Ada -- + ------------------------ + + procedure Gen_Elab_Order_Ada is + begin + WBI (""); + WBI (" -- BEGIN ELABORATION ORDER"); + + for J in Elab_Order.First .. Elab_Order.Last loop + Set_String (" -- "); + Get_Name_String (Units.Table (Elab_Order.Table (J)).Uname); + Set_Name_Buffer; + Write_Statement_Buffer; + end loop; + + WBI (" -- END ELABORATION ORDER"); + end Gen_Elab_Order_Ada; + + ---------------------- + -- Gen_Elab_Order_C -- + ---------------------- + + procedure Gen_Elab_Order_C is + begin + WBI (""); + WBI ("/* BEGIN ELABORATION ORDER"); + + for J in Elab_Order.First .. Elab_Order.Last loop + Get_Name_String (Units.Table (Elab_Order.Table (J)).Uname); + Set_Name_Buffer; + Write_Statement_Buffer; + end loop; + + WBI (" END ELABORATION ORDER */"); + end Gen_Elab_Order_C; + + ------------------ + -- Gen_Main_Ada -- + ------------------ + + procedure Gen_Main_Ada is + begin + WBI (""); + + if Exit_Status_Supported_On_Target then + Set_String (" function "); + else + Set_String (" procedure "); + end if; + + Set_String (Get_Main_Name); + + if Command_Line_Args_On_Target then + Write_Statement_Buffer; + WBI (" (argc : Integer;"); + WBI (" argv : System.Address;"); + WBI (" envp : System.Address)"); + + if Exit_Status_Supported_On_Target then + WBI (" return Integer"); + end if; + + WBI (" is"); + + else + if Exit_Status_Supported_On_Target then + Set_String (" return Integer is"); + else + Set_String (" is"); + end if; + + Write_Statement_Buffer; + end if; + + if Opt.Default_Exit_Status /= 0 + and then Bind_Main_Program + and then not Configurable_Run_Time_Mode + then + WBI (" procedure Set_Exit_Status (Status : Integer);"); + WBI (" pragma Import (C, Set_Exit_Status, " & + """__gnat_set_exit_status"");"); + WBI (""); + end if; + + -- Initialize and Finalize + + if not Cumulative_Restrictions.Set (No_Finalization) then + WBI (" procedure initialize (Addr : System.Address);"); + WBI (" pragma Import (C, initialize, ""__gnat_initialize"");"); + WBI (""); + WBI (" procedure finalize;"); + WBI (" pragma Import (C, finalize, ""__gnat_finalize"");"); + end if; + + -- If we want to analyze the stack, we have to import corresponding + -- symbols + + if Dynamic_Stack_Measurement then + WBI (""); + WBI (" procedure Output_Results;"); + WBI (" pragma Import (C, Output_Results, " & + """__gnat_stack_usage_output_results"");"); + + WBI (""); + WBI (" " & + "procedure Initialize_Stack_Analysis (Buffer_Size : Natural);"); + WBI (" pragma Import (C, Initialize_Stack_Analysis, " & + """__gnat_stack_usage_initialize"");"); + end if; + + -- Deal with declarations for main program case + + if not No_Main_Subprogram then + + -- To call the main program, we declare it using a pragma Import + -- Ada with the right link name. + + -- It might seem more obvious to "with" the main program, and call + -- it in the normal Ada manner. We do not do this for three reasons: + + -- 1. It is more efficient not to recompile the main program + -- 2. We are not entitled to assume the source is accessible + -- 3. We don't know what options to use to compile it + + -- It is really reason 3 that is most critical (indeed we used + -- to generate the "with", but several regression tests failed). + + WBI (""); + + if ALIs.Table (ALIs.First).Main_Program = Func then + WBI (" Result : Integer;"); + WBI (""); + WBI (" function Ada_Main_Program return Integer;"); + + else + WBI (" procedure Ada_Main_Program;"); + end if; + + Set_String (" pragma Import (Ada, Ada_Main_Program, """); + Get_Name_String (Units.Table (First_Unit_Entry).Uname); + Set_Main_Program_Name; + Set_String (""");"); + + Write_Statement_Buffer; + WBI (""); + + if Bind_Main_Program + and then not Suppress_Standard_Library_On_Target + then + WBI (" SEH : aliased array (1 .. 2) of Integer;"); + WBI (""); + end if; + end if; + + -- Generate a reference to Ada_Main_Program_Name. This symbol is + -- not referenced elsewhere in the generated program, but is needed + -- by the debugger (that's why it is generated in the first place). + -- The reference stops Ada_Main_Program_Name from being optimized + -- away by smart linkers, such as the AiX linker. + + -- Because this variable is unused, we make this variable "aliased" + -- with a pragma Volatile in order to tell the compiler to preserve + -- this variable at any level of optimization. + + if Bind_Main_Program then + WBI + (" Ensure_Reference : aliased System.Address := " & + "Ada_Main_Program_Name'Address;"); + WBI (" pragma Volatile (Ensure_Reference);"); + WBI (""); + end if; + + WBI (" begin"); + + -- Acquire command line arguments if present on target + + if Command_Line_Args_On_Target then + WBI (" gnat_argc := argc;"); + WBI (" gnat_argv := argv;"); + WBI (" gnat_envp := envp;"); + WBI (""); + + -- If configurable run time and no command line args, then nothing + -- needs to be done since the gnat_argc/argv/envp variables are + -- suppressed in this case. + + elsif Configurable_Run_Time_On_Target then + null; + + -- Otherwise set dummy values (to be filled in by some other unit?) + + else + WBI (" gnat_argc := 0;"); + WBI (" gnat_argv := System.Null_Address;"); + WBI (" gnat_envp := System.Null_Address;"); + end if; + + if Opt.Default_Exit_Status /= 0 + and then Bind_Main_Program + and then not Configurable_Run_Time_Mode + then + Set_String (" Set_Exit_Status ("); + Set_Int (Opt.Default_Exit_Status); + Set_String (");"); + Write_Statement_Buffer; + end if; + + if Dynamic_Stack_Measurement then + Set_String (" Initialize_Stack_Analysis ("); + Set_Int (Dynamic_Stack_Measurement_Array_Size); + Set_String (");"); + Write_Statement_Buffer; + end if; + + if not Cumulative_Restrictions.Set (No_Finalization) then + if not No_Main_Subprogram + and then Bind_Main_Program + and then not Suppress_Standard_Library_On_Target + then + WBI (" Initialize (SEH'Address);"); + else + WBI (" Initialize (System.Null_Address);"); + end if; + end if; + + WBI (" " & Ada_Init_Name.all & ";"); + + if not No_Main_Subprogram then + WBI (" Break_Start;"); + + if ALIs.Table (ALIs.First).Main_Program = Proc then + WBI (" Ada_Main_Program;"); + else + WBI (" Result := Ada_Main_Program;"); + end if; + end if; + + -- Adafinal call is skipped if no finalization + + if not Cumulative_Restrictions.Set (No_Finalization) then + + -- If compiling for the JVM, we directly call Adafinal because + -- we don't import it via Do_Finalize (see Gen_Output_File_Ada). + + if VM_Target = No_VM then + WBI (" Do_Finalize;"); + else + WBI (" System.Standard_Library.Adafinal;"); + end if; + end if; + + -- Prints the result of static stack analysis + + if Dynamic_Stack_Measurement then + WBI (" Output_Results;"); + end if; + + -- Finalize is only called if we have a run time + + if not Cumulative_Restrictions.Set (No_Finalization) then + WBI (" Finalize;"); + end if; + + -- Return result + + if Exit_Status_Supported_On_Target then + if No_Main_Subprogram + or else ALIs.Table (ALIs.First).Main_Program = Proc + then + WBI (" return (gnat_exit_status);"); + else + WBI (" return (Result);"); + end if; + end if; + + WBI (" end;"); + end Gen_Main_Ada; + + ---------------- + -- Gen_Main_C -- + ---------------- + + procedure Gen_Main_C is + begin + if Exit_Status_Supported_On_Target then + WBI ("#include "); + Set_String ("int "); + else + Set_String ("void "); + end if; + + Set_String (Get_Main_Name); + + -- Generate command line args in prototype if present on target + + if Command_Line_Args_On_Target then + Write_Statement_Buffer (" (int argc, char **argv, char **envp)"); + + -- Case of no command line arguments on target + + else + Write_Statement_Buffer (" (void)"); + end if; + + WBI ("{"); + + -- Generate a reference to __gnat_ada_main_program_name. This symbol + -- is not referenced elsewhere in the generated program, but is + -- needed by the debugger (that's why it is generated in the first + -- place). The reference stops Ada_Main_Program_Name from being + -- optimized away by smart linkers, such as the AiX linker. + + -- Because this variable is unused, we declare this variable as + -- volatile in order to tell the compiler to preserve it at any + -- level of optimization. + + if Bind_Main_Program then + WBI (" char * volatile ensure_reference " & + "__attribute__ ((__unused__)) = " & + "__gnat_ada_main_program_name;"); + WBI (""); + + if not Suppress_Standard_Library_On_Target + and then not No_Main_Subprogram + then + WBI (" int SEH [2];"); + WBI (""); + end if; + end if; + + -- If main program is a function, generate result variable + + if ALIs.Table (ALIs.First).Main_Program = Func then + WBI (" int result;"); + end if; + + -- Set command line argument values from parameters if command line + -- arguments are present on target + + if Command_Line_Args_On_Target then + WBI (" gnat_argc = argc;"); + WBI (" gnat_argv = argv;"); + WBI (" gnat_envp = envp;"); + WBI (" "); + + -- If configurable run-time, then nothing to do, since in this case + -- the gnat_argc/argv/envp variables are entirely suppressed. + + elsif Configurable_Run_Time_On_Target then + null; + + -- if no command line arguments on target, set dummy values + + else + WBI (" gnat_argc = 0;"); + WBI (" gnat_argv = 0;"); + WBI (" gnat_envp = 0;"); + end if; + + if Opt.Default_Exit_Status /= 0 + and then Bind_Main_Program + and then not Configurable_Run_Time_Mode + then + Set_String (" __gnat_set_exit_status ("); + Set_Int (Opt.Default_Exit_Status); + Set_String (");"); + Write_Statement_Buffer; + end if; + + -- Initializes dynamic stack measurement if needed + + if Dynamic_Stack_Measurement then + Set_String (" __gnat_stack_usage_initialize ("); + Set_Int (Dynamic_Stack_Measurement_Array_Size); + Set_String (");"); + Write_Statement_Buffer; + end if; + + -- The __gnat_initialize routine is used only if we have a run-time + + if not Suppress_Standard_Library_On_Target then + if not No_Main_Subprogram and then Bind_Main_Program then + WBI (" __gnat_initialize ((void *)SEH);"); + else + WBI (" __gnat_initialize ((void *)0);"); + end if; + end if; + + WBI (" " & Ada_Init_Name.all & " ();"); + + if not No_Main_Subprogram then + WBI (" __gnat_break_start ();"); + WBI (" "); + + -- Output main program name + + Get_Name_String (Units.Table (First_Unit_Entry).Uname); + + -- Main program is procedure case + + if ALIs.Table (ALIs.First).Main_Program = Proc then + Set_String (" "); + Set_Main_Program_Name; + Set_String (" ();"); + Write_Statement_Buffer; + + -- Main program is function case + + else -- ALIs.Table (ALIs_First).Main_Program = Func + Set_String (" result = "); + Set_Main_Program_Name; + Set_String (" ();"); + Write_Statement_Buffer; + end if; + + end if; + + -- Call adafinal if finalization active + + if not Cumulative_Restrictions.Set (No_Finalization) then + WBI (" "); + WBI (" system__standard_library__adafinal ();"); + end if; + + -- Outputs the dynamic stack measurement if needed + + if Dynamic_Stack_Measurement then + WBI (" __gnat_stack_usage_output_results ();"); + end if; + + -- The finalize routine is used only if we have a run-time + + if not Suppress_Standard_Library_On_Target then + WBI (" __gnat_finalize ();"); + end if; + + -- Case of main program is a function, so the value it returns + -- is the exit status in this case. + + if ALIs.Table (ALIs.First).Main_Program = Func then + if Exit_Status_Supported_On_Target then + + -- VMS must use Posix exit routine in order to get the effect + -- of a Unix compatible setting of the program exit status. + -- For all other systems, we use the standard exit routine. + + if OpenVMS_On_Target then + WBI (" decc$__posix_exit (result);"); + else + WBI (" exit (result);"); + end if; + end if; + + -- Case of main program is a procedure, in which case the exit + -- status is whatever was set by a Set_Exit call most recently + + else + if Exit_Status_Supported_On_Target then + + -- VMS must use Posix exit routine in order to get the effect + -- of a Unix compatible setting of the program exit status. + -- For all other systems, we use the standard exit routine. + + if OpenVMS_On_Target then + WBI (" decc$__posix_exit (gnat_exit_status);"); + else + WBI (" exit (gnat_exit_status);"); + end if; + end if; + end if; + + WBI ("}"); + end Gen_Main_C; + + ------------------------------ + -- Gen_Object_Files_Options -- + ------------------------------ + + procedure Gen_Object_Files_Options is + Lgnat : Natural; + -- This keeps track of the position in the sorted set of entries + -- in the Linker_Options table of where the first entry from an + -- internal file appears. + + Linker_Option_List_Started : Boolean := False; + -- Set to True when "LINKER OPTION LIST" is displayed + + procedure Write_Linker_Option; + -- Write binder info linker option + + ------------------------- + -- Write_Linker_Option -- + ------------------------- + + procedure Write_Linker_Option is + Start : Natural; + Stop : Natural; + + begin + -- Loop through string, breaking at null's + + Start := 1; + while Start < Name_Len loop + + -- Find null ending this section + + Stop := Start + 1; + while Name_Buffer (Stop) /= ASCII.NUL + and then Stop <= Name_Len loop + Stop := Stop + 1; + end loop; + + -- Process section if non-null + + if Stop > Start then + if Output_Linker_Option_List then + if not Zero_Formatting then + if not Linker_Option_List_Started then + Linker_Option_List_Started := True; + Write_Eol; + Write_Str (" LINKER OPTION LIST"); + Write_Eol; + Write_Eol; + end if; + + Write_Str (" "); + end if; + + Write_Str (Name_Buffer (Start .. Stop - 1)); + Write_Eol; + end if; + Write_Info_Ada_C + (" -- ", "", Name_Buffer (Start .. Stop - 1)); + end if; + + Start := Stop + 1; + end loop; + end Write_Linker_Option; + + -- Start of processing for Gen_Object_Files_Options + + begin + WBI (""); + Write_Info_Ada_C ("-- ", "/* ", " BEGIN Object file/option list"); + + if Object_List_Filename /= null then + Set_List_File (Object_List_Filename.all); + end if; + + for E in Elab_Order.First .. Elab_Order.Last loop + + -- If not spec that has an associated body, then generate a comment + -- giving the name of the corresponding object file. + + if (not Units.Table (Elab_Order.Table (E)).SAL_Interface) + and then Units.Table (Elab_Order.Table (E)).Utype /= Is_Spec + then + Get_Name_String + (ALIs.Table + (Units.Table (Elab_Order.Table (E)).My_ALI).Ofile_Full_Name); + + -- If the presence of an object file is necessary or if it exists, + -- then use it. + + if not Hostparm.Exclude_Missing_Objects + or else + System.OS_Lib.Is_Regular_File (Name_Buffer (1 .. Name_Len)) + then + Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len)); + + if Output_Object_List then + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Eol; + end if; + + -- Don't link with the shared library on VMS if an internal + -- filename object is seen. Multiply defined symbols will + -- result. + + if OpenVMS_On_Target + and then Is_Internal_File_Name + (ALIs.Table + (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile) + then + -- Special case for g-trasym.obj (not included in libgnat) + + Get_Name_String (ALIs.Table + (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile); + + if Name_Buffer (1 .. 8) /= "g-trasym" then + Opt.Shared_Libgnat := False; + end if; + end if; + end if; + end if; + end loop; + + if Object_List_Filename /= null then + Close_List_File; + end if; + + -- Add a "-Ldir" for each directory in the object path + if VM_Target /= CLI_Target then + for J in 1 .. Nb_Dir_In_Obj_Search_Path loop + declare + Dir : constant String_Ptr := Dir_In_Obj_Search_Path (J); + begin + Name_Len := 0; + Add_Str_To_Name_Buffer ("-L"); + Add_Str_To_Name_Buffer (Dir.all); + Write_Linker_Option; + end; + end loop; + end if; + + -- Sort linker options + + -- This sort accomplishes two important purposes: + + -- a) All application files are sorted to the front, and all GNAT + -- internal files are sorted to the end. This results in a well + -- defined dividing line between the two sets of files, for the + -- purpose of inserting certain standard library references into + -- the linker arguments list. + + -- b) Given two different units, we sort the linker options so that + -- those from a unit earlier in the elaboration order comes later + -- in the list. This is a heuristic designed to create a more + -- friendly order of linker options when the operations appear in + -- separate units. The idea is that if unit A must be elaborated + -- before unit B, then it is more likely that B references + -- libraries included by A, than vice versa, so we want libraries + -- included by A to come after libraries included by B. + + -- These two criteria are implemented by function Lt_Linker_Option. Note + -- that a special case of b) is that specs are elaborated before bodies, + -- so linker options from specs come after linker options for bodies, + -- and again, the assumption is that libraries used by the body are more + -- likely to reference libraries used by the spec, than vice versa. + + Sort + (Linker_Options.Last, + Move_Linker_Option'Access, + Lt_Linker_Option'Access); + + -- Write user linker options, i.e. the set of linker options that come + -- from all files other than GNAT internal files, Lgnat is left set to + -- point to the first entry from a GNAT internal file, or past the end + -- of the entries if there are no internal files. + + Lgnat := Linker_Options.Last + 1; + + for J in 1 .. Linker_Options.Last loop + if not Linker_Options.Table (J).Internal_File then + Get_Name_String (Linker_Options.Table (J).Name); + Write_Linker_Option; + else + Lgnat := J; + exit; + end if; + end loop; + + -- Now we insert standard linker options that must appear after the + -- entries from user files, and before the entries from GNAT run-time + -- files. The reason for this decision is that libraries referenced + -- by internal routines may reference these standard library entries. + + -- Note that we do not insert anything when pragma No_Run_Time has been + -- specified or when the standard libraries are not to be used, + -- otherwise on some platforms, such as VMS, we may get duplicate + -- symbols when linking. + + if not (Opt.No_Run_Time_Mode or else Opt.No_Stdlib) then + Name_Len := 0; + + if Opt.Shared_Libgnat then + Add_Str_To_Name_Buffer ("-shared"); + else + Add_Str_To_Name_Buffer ("-static"); + end if; + + -- Write directly to avoid -K output (why???) + + Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len)); + + if With_DECGNAT then + Name_Len := 0; + + if Opt.Shared_Libgnat then + Add_Str_To_Name_Buffer (Shared_Lib ("decgnat")); + else + Add_Str_To_Name_Buffer ("-ldecgnat"); + end if; + + Write_Linker_Option; + end if; + + if With_GNARL then + Name_Len := 0; + + if Opt.Shared_Libgnat then + Add_Str_To_Name_Buffer (Shared_Lib ("gnarl")); + else + Add_Str_To_Name_Buffer ("-lgnarl"); + end if; + + Write_Linker_Option; + end if; + + Name_Len := 0; + + if Opt.Shared_Libgnat then + Add_Str_To_Name_Buffer (Shared_Lib ("gnat")); + else + Add_Str_To_Name_Buffer ("-lgnat"); + end if; + + Write_Linker_Option; + end if; + + -- Write linker options from all internal files + + for J in Lgnat .. Linker_Options.Last loop + Get_Name_String (Linker_Options.Table (J).Name); + Write_Linker_Option; + end loop; + + if Output_Linker_Option_List and then not Zero_Formatting then + Write_Eol; + end if; + + if Ada_Bind_File then + WBI ("-- END Object file/option list "); + else + WBI (" END Object file/option list */"); + end if; + end Gen_Object_Files_Options; + + --------------------- + -- Gen_Output_File -- + --------------------- + + procedure Gen_Output_File (Filename : String) is + begin + -- Acquire settings for Interrupt_State pragmas + + Set_IS_Pragma_Table; + + -- Acquire settings for Priority_Specific_Dispatching pragma + + Set_PSD_Pragma_Table; + + -- Override Ada_Bind_File and Bind_Main_Program for VMs since JGNAT only + -- supports Ada code, and the main program is already generated by the + -- compiler. + + if VM_Target /= No_VM then + Ada_Bind_File := True; + + if VM_Target = JVM_Target then + Bind_Main_Program := False; + end if; + end if; + + -- Override time slice value if -T switch is set + + if Time_Slice_Set then + ALIs.Table (ALIs.First).Time_Slice_Value := Opt.Time_Slice_Value; + end if; + + -- Count number of elaboration calls + + for E in Elab_Order.First .. Elab_Order.Last loop + if Units.Table (Elab_Order.Table (E)).No_Elab then + null; + else + Num_Elab_Calls := Num_Elab_Calls + 1; + end if; + end loop; + + -- Generate output file in appropriate language + + Check_System_Restrictions_Used; + + if Ada_Bind_File then + Gen_Output_File_Ada (Filename); + else + Gen_Output_File_C (Filename); + end if; + end Gen_Output_File; + + ------------------------- + -- Gen_Output_File_Ada -- + ------------------------- + + procedure Gen_Output_File_Ada (Filename : String) is + + Bfiles : Name_Id; + -- Name of generated bind file (spec) + + Bfileb : Name_Id; + -- Name of generated bind file (body) + + Ada_Main : constant String := Get_Ada_Main_Name; + -- Name to be used for generated Ada main program. See the body of + -- function Get_Ada_Main_Name for details on the form of the name. + + begin + -- Create spec first + + Create_Binder_Output (Filename, 's', Bfiles); + + -- We always compile the binder file in Ada 95 mode so that we properly + -- handle use of Ada 2005 keywords as identifiers in Ada 95 mode. None + -- of the Ada 2005 constructs are needed by the binder file. + + WBI ("pragma Ada_95;"); + + -- If we are operating in Restrictions (No_Exception_Handlers) mode, + -- then we need to make sure that the binder program is compiled with + -- the same restriction, so that no exception tables are generated. + + if Cumulative_Restrictions.Set (No_Exception_Handlers) then + WBI ("pragma Restrictions (No_Exception_Handlers);"); + end if; + + -- Same processing for Restrictions (No_Exception_Propagation) + + if Cumulative_Restrictions.Set (No_Exception_Propagation) then + WBI ("pragma Restrictions (No_Exception_Propagation);"); + end if; + + -- Same processing for pragma No_Run_Time + + if No_Run_Time_Mode then + WBI ("pragma No_Run_Time;"); + end if; + + -- Generate with of System so we can reference System.Address + + WBI ("with System;"); + + -- Generate with of System.Initialize_Scalars if active + + if Initialize_Scalars_Used then + WBI ("with System.Scalar_Values;"); + end if; + + -- Generate with of System.Secondary_Stack if active + + if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then + WBI ("with System.Secondary_Stack;"); + end if; + + Resolve_Binder_Options; + + if VM_Target /= No_VM then + if not Suppress_Standard_Library_On_Target then + + -- Usually, adafinal is called using a pragma Import C. Since + -- Import C doesn't have the same semantics for JGNAT, we use + -- standard Ada. + + WBI ("with System.Standard_Library;"); + end if; + end if; + + WBI ("package " & Ada_Main & " is"); + WBI (" pragma Warnings (Off);"); + + -- Main program case + + if Bind_Main_Program then + if VM_Target = No_VM then + + -- Generate argc/argv stuff unless suppressed + + if Command_Line_Args_On_Target + or not Configurable_Run_Time_On_Target + then + WBI (""); + WBI (" gnat_argc : Integer;"); + WBI (" gnat_argv : System.Address;"); + WBI (" gnat_envp : System.Address;"); + + -- If the standard library is not suppressed, these variables + -- are in the run-time data area for easy run time access. + + if not Suppress_Standard_Library_On_Target then + WBI (""); + WBI (" pragma Import (C, gnat_argc);"); + WBI (" pragma Import (C, gnat_argv);"); + WBI (" pragma Import (C, gnat_envp);"); + end if; + end if; + + -- Define exit status. Again in normal mode, this is in the + -- run-time library, and is initialized there, but in the + -- configurable runtime case, the variable is declared and + -- initialized in this file. + + WBI (""); + + if Configurable_Run_Time_Mode then + if Exit_Status_Supported_On_Target then + WBI (" gnat_exit_status : Integer := 0;"); + end if; + + else + WBI (" gnat_exit_status : Integer;"); + WBI (" pragma Import (C, gnat_exit_status);"); + end if; + end if; + + -- Generate the GNAT_Version and Ada_Main_Program_Name info only for + -- the main program. Otherwise, it can lead under some circumstances + -- to a symbol duplication during the link (for instance when a C + -- program uses two Ada libraries). Also zero terminate the string + -- so that its end can be found reliably at run time. + + WBI (""); + WBI (" GNAT_Version : constant String :="); + WBI (" """ & Ver_Prefix & + Gnat_Version_String & + """ & ASCII.NUL;"); + WBI (" pragma Export (C, GNAT_Version, ""__gnat_version"");"); + + WBI (""); + Set_String (" Ada_Main_Program_Name : constant String := """); + Get_Name_String (Units.Table (First_Unit_Entry).Uname); + + if VM_Target = No_VM then + Set_Main_Program_Name; + Set_String (""" & ASCII.NUL;"); + else + Set_String (Name_Buffer (1 .. Name_Len - 2) & """;"); + end if; + + Write_Statement_Buffer; + + WBI + (" pragma Export (C, Ada_Main_Program_Name, " & + """__gnat_ada_main_program_name"");"); + end if; + + if not Cumulative_Restrictions.Set (No_Finalization) then + WBI (""); + WBI (" procedure " & Ada_Final_Name.all & ";"); + WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ & + Ada_Final_Name.all & """);"); + end if; + + WBI (""); + WBI (" procedure " & Ada_Init_Name.all & ";"); + WBI (" pragma Export (C, " & Ada_Init_Name.all & ", """ & + Ada_Init_Name.all & """);"); + + -- If -a has been specified use pragma Linker_Constructor for the init + -- procedure. No need to use a similar pragma for the final procedure as + -- global finalization will occur when the executable finishes execution + -- and for plugins (shared stand-alone libraries that can be + -- "unloaded"), finalization should not occur automatically, otherwise + -- the main executable may not continue to work properly. + + if Use_Pragma_Linker_Constructor then + WBI (" pragma Linker_Constructor (" & Ada_Init_Name.all & ");"); + end if; + + if Bind_Main_Program and then VM_Target = No_VM then + + -- If we have the standard library, then Break_Start is defined + -- there, but when the standard library is suppressed, Break_Start + -- is defined here. + + WBI (""); + WBI (" procedure Break_Start;"); + + if Suppress_Standard_Library_On_Target then + WBI (" pragma Export (C, Break_Start, ""__gnat_break_start"");"); + else + WBI (" pragma Import (C, Break_Start, ""__gnat_break_start"");"); + end if; + + WBI (""); + + if Exit_Status_Supported_On_Target then + Set_String (" function "); + else + Set_String (" procedure "); + end if; + + Set_String (Get_Main_Name); + + -- Generate argument list if present + + if Command_Line_Args_On_Target then + Write_Statement_Buffer; + WBI (" (argc : Integer;"); + WBI (" argv : System.Address;"); + Set_String + (" envp : System.Address)"); + + if Exit_Status_Supported_On_Target then + Write_Statement_Buffer; + WBI (" return Integer;"); + else + Write_Statement_Buffer (";"); + end if; + + else + if Exit_Status_Supported_On_Target then + Write_Statement_Buffer (" return Integer;"); + else + Write_Statement_Buffer (";"); + end if; + end if; + + WBI (" pragma Export (C, " & Get_Main_Name & ", """ & + Get_Main_Name & """);"); + end if; + + Gen_Versions_Ada; + Gen_Elab_Order_Ada; + + -- Spec is complete + + WBI (""); + WBI ("end " & Ada_Main & ";"); + Close_Binder_Output; + + -- Prepare to write body + + Create_Binder_Output (Filename, 'b', Bfileb); + + -- We always compile the binder file in Ada 95 mode so that we properly + -- handle use of Ada 2005 keywords as identifiers in Ada 95 mode. None + -- of the Ada 2005 constructs are needed by the binder file. + + WBI ("pragma Ada_95;"); + + -- Output Source_File_Name pragmas which look like + + -- pragma Source_File_Name (Ada_Main, Spec_File_Name => "sss"); + -- pragma Source_File_Name (Ada_Main, Body_File_Name => "bbb"); + + -- where sss/bbb are the spec/body file names respectively + + Get_Name_String (Bfiles); + Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);"; + + WBI ("pragma Source_File_Name (" & + Ada_Main & + ", Spec_File_Name => """ & + Name_Buffer (1 .. Name_Len + 3)); + + Get_Name_String (Bfileb); + Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);"; + + WBI ("pragma Source_File_Name (" & + Ada_Main & + ", Body_File_Name => """ & + Name_Buffer (1 .. Name_Len + 3)); + + -- Generate with of System.Restrictions to initialize + -- Run_Time_Restrictions. + + if System_Restrictions_Used + and not Suppress_Standard_Library_On_Target + then + WBI (""); + WBI ("with System.Restrictions;"); + end if; + + WBI (""); + WBI ("package body " & Ada_Main & " is"); + WBI (" pragma Warnings (Off);"); + + -- Import the finalization procedure only if finalization active + + if not Cumulative_Restrictions.Set (No_Finalization) then + + -- In the Java case, pragma Import C cannot be used, so the standard + -- Ada constructs will be used instead. + + if VM_Target = No_VM then + WBI (""); + WBI (" procedure Do_Finalize;"); + WBI + (" pragma Import (C, Do_Finalize, " & + """system__standard_library__adafinal"");"); + WBI (""); + end if; + end if; + + if not Suppress_Standard_Library_On_Target then + + -- Generate Priority_Specific_Dispatching pragma string + + Set_String + (" Local_Priority_Specific_Dispatching : constant String := """); + + for J in 0 .. PSD_Pragma_Settings.Last loop + Set_Char (PSD_Pragma_Settings.Table (J)); + end loop; + + Set_String (""";"); + Write_Statement_Buffer; + + -- Generate Interrupt_State pragma string + + Set_String (" Local_Interrupt_States : constant String := """); + + for J in 0 .. IS_Pragma_Settings.Last loop + Set_Char (IS_Pragma_Settings.Table (J)); + end loop; + + Set_String (""";"); + Write_Statement_Buffer; + WBI (""); + end if; + + Gen_Adainit_Ada; + + -- Generate the adafinal routine unless there is no finalization to do + + if not Cumulative_Restrictions.Set (No_Finalization) then + Gen_Adafinal_Ada; + end if; + + if Bind_Main_Program and then VM_Target = No_VM then + + -- When suppressing the standard library then generate dummy body + -- for Break_Start + + if Suppress_Standard_Library_On_Target then + WBI (""); + WBI (" procedure Break_Start is"); + WBI (" begin"); + WBI (" null;"); + WBI (" end;"); + end if; + + Gen_Main_Ada; + end if; + + -- Output object file list and the Ada body is complete + + Gen_Object_Files_Options; + + WBI (""); + WBI ("end " & Ada_Main & ";"); + + Close_Binder_Output; + end Gen_Output_File_Ada; + + ----------------------- + -- Gen_Output_File_C -- + ----------------------- + + procedure Gen_Output_File_C (Filename : String) is + Bfile : Name_Id; + pragma Warnings (Off, Bfile); + -- Name of generated bind file (not referenced) + + begin + Create_Binder_Output (Filename, 'c', Bfile); + + Resolve_Binder_Options; + + WBI ("extern void " & Ada_Final_Name.all & " (void);"); + + -- If -a has been specified use __attribute__((constructor)) for the + -- init procedure. No need to use a similar featute for the final + -- procedure as global finalization will occur when the executable + -- finishes execution and for plugins (shared stand-alone libraries that + -- can be "unloaded"), finalization should not occur automatically, + -- otherwise the main executable may not continue to work properly. + + if Use_Pragma_Linker_Constructor then + WBI ("extern void " & Ada_Init_Name.all & + " (void) __attribute__((constructor));"); + else + WBI ("extern void " & Ada_Init_Name.all & " (void);"); + end if; + + WBI ("extern void system__standard_library__adafinal (void);"); + + if not No_Main_Subprogram then + Set_String ("extern "); + + if Exit_Status_Supported_On_Target then + Set_String ("int"); + else + Set_String ("void"); + end if; + + Set_String (" main "); + + if Command_Line_Args_On_Target then + Write_Statement_Buffer ("(int, char **, char **);"); + else + Write_Statement_Buffer ("(void);"); + end if; + + if OpenVMS_On_Target then + WBI ("extern void decc$__posix_exit (int);"); + else + WBI ("extern void exit (int);"); + end if; + + WBI ("extern void __gnat_break_start (void);"); + Set_String ("extern "); + + if ALIs.Table (ALIs.First).Main_Program = Proc then + Set_String ("void "); + else + Set_String ("int "); + end if; + + Get_Name_String (Units.Table (First_Unit_Entry).Uname); + Set_Main_Program_Name; + Set_String (" (void);"); + Write_Statement_Buffer; + end if; + + if not Suppress_Standard_Library_On_Target then + WBI ("extern void __gnat_initialize (void *);"); + WBI ("extern void __gnat_finalize (void);"); + WBI ("extern void __gnat_install_handler (void);"); + end if; + + if Dynamic_Stack_Measurement then + WBI (""); + WBI ("extern void __gnat_stack_usage_output_results (void);"); + WBI ("extern void __gnat_stack_usage_initialize (int size);"); + end if; + + -- Initialize stack limit for the environment task if the stack check + -- method is stack limit and stack check is enabled. + + if Stack_Check_Limits_On_Target + and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set) + then + WBI (""); + WBI ("extern void __gnat_initialize_stack_limit (void);"); + end if; + + WBI (""); + + Gen_Elab_Defs_C; + + -- Imported variables used only when we have a runtime + + if not Suppress_Standard_Library_On_Target then + + -- Track elaboration/finalization phase + + WBI ("extern int __gnat_handler_installed;"); + WBI (""); + + -- Track feature enable/disable on VMS + + if OpenVMS_On_Target then + WBI ("extern int __gnat_features_set;"); + WBI (""); + end if; + end if; + + -- Write argv/argc exit status stuff if main program case + + if Bind_Main_Program then + + -- First deal with argc/argv/envp. In the normal case they are in the + -- run-time library. + + if not Configurable_Run_Time_On_Target then + WBI ("extern int gnat_argc;"); + WBI ("extern char **gnat_argv;"); + WBI ("extern char **gnat_envp;"); + + -- If configurable run time and no command line args, then the + -- generation of these variables is entirely suppressed. + + elsif not Command_Line_Args_On_Target then + null; + + -- Otherwise, in the configurable run-time case they are right in the + -- binder file. + + else + WBI ("int gnat_argc;"); + WBI ("char **gnat_argv;"); + WBI ("char **gnat_envp;"); + end if; + + -- Similarly deal with exit status + + if not Configurable_Run_Time_On_Target then + WBI ("extern int gnat_exit_status;"); + + -- If configurable run time and no exit status on target, then the + -- generation of this variables is entirely suppressed. + + elsif not Exit_Status_Supported_On_Target then + null; + + -- Otherwise, in the configurable run-time case this variable is + -- right in the binder file, and initialized to zero there. + + else + WBI ("int gnat_exit_status = 0;"); + end if; + + WBI (""); + end if; + + -- When suppressing the standard library, the __gnat_break_start routine + -- (for the debugger to get initial control) is defined in this file. + + if Suppress_Standard_Library_On_Target then + WBI (""); + WBI ("void __gnat_break_start (void) {}"); + end if; + + -- Generate the __gnat_version and __gnat_ada_main_program_name info + -- only for the main program. Otherwise, it can lead under some + -- circumstances to a symbol duplication during the link (for instance + -- when a C program uses 2 Ada libraries) + + if Bind_Main_Program then + WBI (""); + WBI ("char __gnat_version[] = """ & Ver_Prefix & + Gnat_Version_String & """;"); + + Set_String ("char __gnat_ada_main_program_name[] = """); + Get_Name_String (Units.Table (First_Unit_Entry).Uname); + Set_Main_Program_Name; + Set_String (""";"); + Write_Statement_Buffer; + end if; + + -- Generate the adafinal routine. In no runtime mode, this is not + -- needed, since there is no finalization to do. + + if not Cumulative_Restrictions.Set (No_Finalization) then + Gen_Adafinal_C; + end if; + + Gen_Adainit_C; + + -- Main is only present for Ada main case + + if Bind_Main_Program then + Gen_Main_C; + end if; + + -- Generate versions, elaboration order, list of object files + + Gen_Versions_C; + Gen_Elab_Order_C; + Gen_Object_Files_Options; + + -- C binder output is complete + + Close_Binder_Output; + end Gen_Output_File_C; + + -------------------------- + -- Gen_Restrictions_Ada -- + -------------------------- + + procedure Gen_Restrictions_Ada is + Count : Integer; + + begin + if Suppress_Standard_Library_On_Target + or not System_Restrictions_Used + then + return; + end if; + + WBI (" System.Restrictions.Run_Time_Restrictions :="); + WBI (" (Set =>"); + Set_String (" ("); + + Count := 0; + + for J in Cumulative_Restrictions.Set'Range loop + Set_Boolean (Cumulative_Restrictions.Set (J)); + Set_String (", "); + Count := Count + 1; + + if J /= Cumulative_Restrictions.Set'Last and then Count = 8 then + Write_Statement_Buffer; + Set_String (" "); + Count := 0; + end if; + end loop; + + Set_String_Replace ("),"); + Write_Statement_Buffer; + Set_String (" Value => ("); + + for J in Cumulative_Restrictions.Value'Range loop + Set_Int (Int (Cumulative_Restrictions.Value (J))); + Set_String (", "); + end loop; + + Set_String_Replace ("),"); + Write_Statement_Buffer; + WBI (" Violated =>"); + Set_String (" ("); + Count := 0; + + for J in Cumulative_Restrictions.Violated'Range loop + Set_Boolean (Cumulative_Restrictions.Violated (J)); + Set_String (", "); + Count := Count + 1; + + if J /= Cumulative_Restrictions.Set'Last and then Count = 8 then + Write_Statement_Buffer; + Set_String (" "); + Count := 0; + end if; + end loop; + + Set_String_Replace ("),"); + Write_Statement_Buffer; + Set_String (" Count => ("); + + for J in Cumulative_Restrictions.Count'Range loop + Set_Int (Int (Cumulative_Restrictions.Count (J))); + Set_String (", "); + end loop; + + Set_String_Replace ("),"); + Write_Statement_Buffer; + Set_String (" Unknown => ("); + + for J in Cumulative_Restrictions.Unknown'Range loop + Set_Boolean (Cumulative_Restrictions.Unknown (J)); + Set_String (", "); + end loop; + + Set_String_Replace ("))"); + Set_String (";"); + Write_Statement_Buffer; + end Gen_Restrictions_Ada; + + ------------------------ + -- Gen_Restrictions_C -- + ------------------------ + + procedure Gen_Restrictions_C is + begin + if Suppress_Standard_Library_On_Target + or not System_Restrictions_Used + then + return; + end if; + + WBI (" typedef struct {"); + Set_String (" char set ["); + Set_Int (Cumulative_Restrictions.Set'Length); + Set_String ("];"); + Write_Statement_Buffer; + + Set_String (" int value ["); + Set_Int (Cumulative_Restrictions.Value'Length); + Set_String ("];"); + Write_Statement_Buffer; + + Set_String (" char violated ["); + Set_Int (Cumulative_Restrictions.Violated'Length); + Set_String ("];"); + Write_Statement_Buffer; + + Set_String (" int count ["); + Set_Int (Cumulative_Restrictions.Count'Length); + Set_String ("];"); + Write_Statement_Buffer; + + Set_String (" char unknown ["); + Set_Int (Cumulative_Restrictions.Unknown'Length); + Set_String ("];"); + Write_Statement_Buffer; + WBI (" } restrictions;"); + WBI (" extern restrictions " & + "system__restrictions__run_time_restrictions;"); + WBI (" restrictions r = {"); + Set_String (" {"); + + for J in Cumulative_Restrictions.Set'Range loop + Set_Int (Boolean'Pos (Cumulative_Restrictions.Set (J))); + Set_String (", "); + end loop; + + Set_String_Replace ("},"); + Write_Statement_Buffer; + Set_String (" {"); + + for J in Cumulative_Restrictions.Value'Range loop + Set_Int (Int (Cumulative_Restrictions.Value (J))); + Set_String (", "); + end loop; + + Set_String_Replace ("},"); + Write_Statement_Buffer; + Set_String (" {"); + + for J in Cumulative_Restrictions.Violated'Range loop + Set_Int (Boolean'Pos (Cumulative_Restrictions.Violated (J))); + Set_String (", "); + end loop; + + Set_String_Replace ("},"); + Write_Statement_Buffer; + Set_String (" {"); + + for J in Cumulative_Restrictions.Count'Range loop + Set_Int (Int (Cumulative_Restrictions.Count (J))); + Set_String (", "); + end loop; + + Set_String_Replace ("},"); + Write_Statement_Buffer; + Set_String (" {"); + + for J in Cumulative_Restrictions.Unknown'Range loop + Set_Int (Boolean'Pos (Cumulative_Restrictions.Unknown (J))); + Set_String (", "); + end loop; + + Set_String_Replace ("}}"); + Set_String (";"); + Write_Statement_Buffer; + WBI (" system__restrictions__run_time_restrictions = r;"); + end Gen_Restrictions_C; + + ---------------------- + -- Gen_Versions_Ada -- + ---------------------- + + -- This routine generates lines such as: + + -- unnnnn : constant Integer := 16#hhhhhhhh#; + -- pragma Export (C, unnnnn, unam); + + -- for each unit, where unam is the unit name suffixed by either B or S for + -- body or spec, with dots replaced by double underscores, and hhhhhhhh is + -- the version number, and nnnnn is a 5-digits serial number. + + procedure Gen_Versions_Ada is + Ubuf : String (1 .. 6) := "u00000"; + + procedure Increment_Ubuf; + -- Little procedure to increment the serial number + + procedure Increment_Ubuf is + begin + for J in reverse Ubuf'Range loop + Ubuf (J) := Character'Succ (Ubuf (J)); + exit when Ubuf (J) <= '9'; + Ubuf (J) := '0'; + end loop; + end Increment_Ubuf; + + -- Start of processing for Gen_Versions_Ada + + begin + WBI (""); + + WBI (" type Version_32 is mod 2 ** 32;"); + for U in Units.First .. Units.Last loop + if not Units.Table (U).SAL_Interface and then + ((not Bind_For_Library) or else Units.Table (U).Directly_Scanned) + then + Increment_Ubuf; + WBI (" " & Ubuf & " : constant Version_32 := 16#" & + Units.Table (U).Version & "#;"); + Set_String (" pragma Export (C, "); + Set_String (Ubuf); + Set_String (", """); + + Get_Name_String (Units.Table (U).Uname); + + for K in 1 .. Name_Len loop + if Name_Buffer (K) = '.' then + Set_Char ('_'); + Set_Char ('_'); + + elsif Name_Buffer (K) = '%' then + exit; + + else + Set_Char (Name_Buffer (K)); + end if; + end loop; + + if Name_Buffer (Name_Len) = 's' then + Set_Char ('S'); + else + Set_Char ('B'); + end if; + + Set_String (""");"); + Write_Statement_Buffer; + end if; + end loop; + + end Gen_Versions_Ada; + + -------------------- + -- Gen_Versions_C -- + -------------------- + + -- This routine generates a line of the form: + + -- unsigned unam = 0xhhhhhhhh; + + -- for each unit, where unam is the unit name suffixed by either B or S for + -- body or spec, with dots replaced by double underscores. + + procedure Gen_Versions_C is + begin + for U in Units.First .. Units.Last loop + if not Units.Table (U).SAL_Interface and then + ((not Bind_For_Library) or else Units.Table (U).Directly_Scanned) + then + Set_String ("unsigned "); + + Get_Name_String (Units.Table (U).Uname); + + for K in 1 .. Name_Len loop + if Name_Buffer (K) = '.' then + Set_String ("__"); + + elsif Name_Buffer (K) = '%' then + exit; + + else + Set_Char (Name_Buffer (K)); + end if; + end loop; + + if Name_Buffer (Name_Len) = 's' then + Set_Char ('S'); + else + Set_Char ('B'); + end if; + + Set_String (" = 0x"); + Set_String (Units.Table (U).Version); + Set_Char (';'); + Write_Statement_Buffer; + end if; + end loop; + + end Gen_Versions_C; + + ------------------------ + -- Get_Main_Unit_Name -- + ------------------------ + + function Get_Main_Unit_Name (S : String) return String is + Result : String := S; + + begin + for J in S'Range loop + if Result (J) = '.' then + Result (J) := '_'; + end if; + end loop; + + return Result; + end Get_Main_Unit_Name; + + ----------------------- + -- Get_Ada_Main_Name -- + ----------------------- + + function Get_Ada_Main_Name return String is + Suffix : constant String := "_00"; + Name : String (1 .. Opt.Ada_Main_Name.all'Length + Suffix'Length) := + Opt.Ada_Main_Name.all & Suffix; + Nlen : Natural; + + begin + -- The main program generated by JGNAT expects a package called + -- ada_
. + + if VM_Target /= No_VM then + Get_Name_String (Units.Table (First_Unit_Entry).Uname); + return "ada_" & Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len - 2)); + end if; + + -- This loop tries the following possibilities in order + -- + -- _01 + -- _02 + -- .. + -- _99 + -- where is equal to Opt.Ada_Main_Name. By default, + -- it is set to 'ada_main'. + + for J in 0 .. 99 loop + if J = 0 then + Nlen := Name'Length - Suffix'Length; + else + Nlen := Name'Length; + Name (Name'Last) := Character'Val (J mod 10 + Character'Pos ('0')); + Name (Name'Last - 1) := + Character'Val (J / 10 + Character'Pos ('0')); + end if; + + for K in ALIs.First .. ALIs.Last loop + for L in ALIs.Table (K).First_Unit .. ALIs.Table (K).Last_Unit loop + + -- Get unit name, removing %b or %e at end + + Get_Name_String (Units.Table (L).Uname); + Name_Len := Name_Len - 2; + + if Name_Buffer (1 .. Name_Len) = Name (1 .. Nlen) then + goto Continue; + end if; + end loop; + end loop; + + return Name (1 .. Nlen); + + <> + null; + end loop; + + -- If we fall through, just use a peculiar unlikely name + + return ("Qwertyuiop"); + end Get_Ada_Main_Name; + + ------------------- + -- Get_Main_Name -- + ------------------- + + function Get_Main_Name return String is + begin + -- Explicit name given with -M switch + + if Bind_Alternate_Main_Name then + return Alternate_Main_Name.all; + + -- Case of main program name to be used directly + + elsif Use_Ada_Main_Program_Name_On_Target then + + -- Get main program name + + Get_Name_String (Units.Table (First_Unit_Entry).Uname); + + -- If this is a child name, return only the name of the child, since + -- we can't have dots in a nested program name. Note that we do not + -- include the %b at the end of the unit name. + + for J in reverse 1 .. Name_Len - 2 loop + if J = 1 or else Name_Buffer (J - 1) = '.' then + return Name_Buffer (J .. Name_Len - 2); + end if; + end loop; + + raise Program_Error; -- impossible exit + + -- Case where "main" is to be used as default + + else + return "main"; + end if; + end Get_Main_Name; + + --------------------- + -- Get_WC_Encoding -- + --------------------- + + function Get_WC_Encoding return Character is + begin + -- If encoding method specified by -W switch, then return it + + if Wide_Character_Encoding_Method_Specified then + return WC_Encoding_Letters (Wide_Character_Encoding_Method); + + -- If no main program, and not specified, set brackets, we really have + -- no better choice. If some other encoding is required when there is + -- no main, it must be set explicitly using -Wx. + + -- Note: if the ALI file always passed the wide character encoding of + -- every file, then we could use the encoding of the initial specified + -- file, but this information is passed only for potential main + -- programs. We could fix this sometime, but it is a very minor point + -- (wide character default encoding for [Wide_[Wide_]Text_IO when there + -- is no main program). + + elsif No_Main_Subprogram then + return 'b'; + + -- Otherwise if there is a main program, take encoding from it + + else + return ALIs.Table (ALIs.First).WC_Encoding; + end if; + end Get_WC_Encoding; + + ---------------------- + -- Lt_Linker_Option -- + ---------------------- + + function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean is + begin + -- Sort internal files last + + if Linker_Options.Table (Op1).Internal_File + /= + Linker_Options.Table (Op2).Internal_File + then + -- Note: following test uses False < True + + return Linker_Options.Table (Op1).Internal_File + < + Linker_Options.Table (Op2).Internal_File; + + -- If both internal or both non-internal, sort according to the + -- elaboration position. A unit that is elaborated later should come + -- earlier in the linker options list. + + else + return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position + > + Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position; + + end if; + end Lt_Linker_Option; + + ------------------------ + -- Move_Linker_Option -- + ------------------------ + + procedure Move_Linker_Option (From : Natural; To : Natural) is + begin + Linker_Options.Table (To) := Linker_Options.Table (From); + end Move_Linker_Option; + + ---------------------------- + -- Resolve_Binder_Options -- + ---------------------------- + + procedure Resolve_Binder_Options is + begin + for E in Elab_Order.First .. Elab_Order.Last loop + Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname); + + -- This is not a perfect approach, but is the current protocol + -- between the run-time and the binder to indicate that tasking is + -- used: system.os_interface should always be used by any tasking + -- application. + + if Name_Buffer (1 .. 19) = "system.os_interface" then + With_GNARL := True; + end if; + + -- Ditto for declib and the "dec" package + + if OpenVMS_On_Target and then Name_Buffer (1 .. 5) = "dec%s" then + With_DECGNAT := True; + end if; + end loop; + end Resolve_Binder_Options; + + ----------------- + -- Set_Boolean -- + ----------------- + + procedure Set_Boolean (B : Boolean) is + True_Str : constant String := "True"; + False_Str : constant String := "False"; + begin + if B then + Statement_Buffer (Last + 1 .. Last + True_Str'Length) := True_Str; + Last := Last + True_Str'Length; + else + Statement_Buffer (Last + 1 .. Last + False_Str'Length) := False_Str; + Last := Last + False_Str'Length; + end if; + end Set_Boolean; + + -------------- + -- Set_Char -- + -------------- + + procedure Set_Char (C : Character) is + begin + Last := Last + 1; + Statement_Buffer (Last) := C; + end Set_Char; + + ------------- + -- Set_Int -- + ------------- + + procedure Set_Int (N : Int) is + begin + if N < 0 then + Set_String ("-"); + Set_Int (-N); + + else + if N > 9 then + Set_Int (N / 10); + end if; + + Last := Last + 1; + Statement_Buffer (Last) := + Character'Val (N mod 10 + Character'Pos ('0')); + end if; + end Set_Int; + + ------------------------- + -- Set_IS_Pragma_Table -- + ------------------------- + + procedure Set_IS_Pragma_Table is + begin + for F in ALIs.First .. ALIs.Last loop + for K in ALIs.Table (F).First_Interrupt_State .. + ALIs.Table (F).Last_Interrupt_State + loop + declare + Inum : constant Int := + Interrupt_States.Table (K).Interrupt_Id; + Stat : constant Character := + Interrupt_States.Table (K).Interrupt_State; + + begin + while IS_Pragma_Settings.Last < Inum loop + IS_Pragma_Settings.Append ('n'); + end loop; + + IS_Pragma_Settings.Table (Inum) := Stat; + end; + end loop; + end loop; + end Set_IS_Pragma_Table; + + --------------------------- + -- Set_Main_Program_Name -- + --------------------------- + + procedure Set_Main_Program_Name is + begin + -- Note that name has %b on the end which we ignore + + -- First we output the initial _ada_ since we know that the main + -- program is a library level subprogram. + + Set_String ("_ada_"); + + -- Copy name, changing dots to double underscores + + for J in 1 .. Name_Len - 2 loop + if Name_Buffer (J) = '.' then + Set_String ("__"); + else + Set_Char (Name_Buffer (J)); + end if; + end loop; + end Set_Main_Program_Name; + + --------------------- + -- Set_Name_Buffer -- + --------------------- + + procedure Set_Name_Buffer is + begin + for J in 1 .. Name_Len loop + Set_Char (Name_Buffer (J)); + end loop; + end Set_Name_Buffer; + + ------------------------- + -- Set_PSD_Pragma_Table -- + ------------------------- + + procedure Set_PSD_Pragma_Table is + begin + for F in ALIs.First .. ALIs.Last loop + for K in ALIs.Table (F).First_Specific_Dispatching .. + ALIs.Table (F).Last_Specific_Dispatching + loop + declare + DTK : Specific_Dispatching_Record + renames Specific_Dispatching.Table (K); + + begin + while PSD_Pragma_Settings.Last < DTK.Last_Priority loop + PSD_Pragma_Settings.Append ('F'); + end loop; + + for Prio in DTK.First_Priority .. DTK.Last_Priority loop + PSD_Pragma_Settings.Table (Prio) := DTK.Dispatching_Policy; + end loop; + end; + end loop; + end loop; + end Set_PSD_Pragma_Table; + + ---------------- + -- Set_String -- + ---------------- + + procedure Set_String (S : String) is + begin + Statement_Buffer (Last + 1 .. Last + S'Length) := S; + Last := Last + S'Length; + end Set_String; + + ------------------------ + -- Set_String_Replace -- + ------------------------ + + procedure Set_String_Replace (S : String) is + begin + Statement_Buffer (Last - S'Length + 1 .. Last) := S; + end Set_String_Replace; + + ------------------- + -- Set_Unit_Name -- + ------------------- + + procedure Set_Unit_Name is + begin + for J in 1 .. Name_Len - 2 loop + if Name_Buffer (J) /= '.' then + Set_Char (Name_Buffer (J)); + else + Set_String ("__"); + end if; + end loop; + end Set_Unit_Name; + + --------------------- + -- Set_Unit_Number -- + --------------------- + + procedure Set_Unit_Number (U : Unit_Id) is + Num_Units : constant Nat := Nat (Units.Last) - Nat (Unit_Id'First); + Unum : constant Nat := Nat (U) - Nat (Unit_Id'First); + + begin + if Num_Units >= 10 and then Unum < 10 then + Set_Char ('0'); + end if; + + if Num_Units >= 100 and then Unum < 100 then + Set_Char ('0'); + end if; + + Set_Int (Unum); + end Set_Unit_Number; + + ---------------------- + -- Write_Info_Ada_C -- + ---------------------- + + procedure Write_Info_Ada_C (Ada : String; C : String; Common : String) is + begin + if Ada_Bind_File then + declare + S : String (1 .. Ada'Length + Common'Length); + begin + S (1 .. Ada'Length) := Ada; + S (Ada'Length + 1 .. S'Length) := Common; + WBI (S); + end; + + else + declare + S : String (1 .. C'Length + Common'Length); + begin + S (1 .. C'Length) := C; + S (C'Length + 1 .. S'Length) := Common; + WBI (S); + end; + end if; + end Write_Info_Ada_C; + + ---------------------------- + -- Write_Statement_Buffer -- + ---------------------------- + + procedure Write_Statement_Buffer is + begin + WBI (Statement_Buffer (1 .. Last)); + Last := 0; + end Write_Statement_Buffer; + + procedure Write_Statement_Buffer (S : String) is + begin + Set_String (S); + Write_Statement_Buffer; + end Write_Statement_Buffer; + +end Bindgen; diff --git a/gcc/ada/bindgen.ads b/gcc/ada/bindgen.ads new file mode 100644 index 000000000..96d2e3068 --- /dev/null +++ b/gcc/ada/bindgen.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D G E N -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 to output the binder file. This is +-- an Ada or C program which contains the following: + +-- initialization for main program case +-- sequence of calls to elaboration routines in appropriate order +-- call to main program for main program case + +-- See the body for exact details of the file that is generated + +package Bindgen is + + procedure Gen_Output_File (Filename : String); + -- Filename is the full path name of the binder output file + +end Bindgen; diff --git a/gcc/ada/bindusg.adb b/gcc/ada/bindusg.adb new file mode 100644 index 000000000..06fa354d4 --- /dev/null +++ b/gcc/ada/bindusg.adb @@ -0,0 +1,283 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D U S G -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Osint; use Osint; +with Output; use Output; + +with System.WCh_Con; use System.WCh_Con; + +package body Bindusg is + + Already_Displayed : Boolean := False; + -- Set True if Display called, used to avoid showing usage information + -- more than once. + + ------------- + -- Display -- + ------------- + + procedure Display is + begin + if Already_Displayed then + return; + else + Already_Displayed := True; + end if; + + -- Usage line + + Write_Str ("Usage: "); + Write_Program_Name; + Write_Char (' '); + Write_Str ("switches lfile"); + Write_Eol; + Write_Eol; + + -- Line for @response_file + + Write_Line (" @ Get arguments from response file"); + Write_Eol; + + -- Line for -aO switch + + Write_Line (" -aOdir Specify library files search path"); + + -- Line for -aI switch + + Write_Line (" -aIdir Specify source files search path"); + + -- Line for a switch + + Write_Line (" -a Automatically initialize elaboration " & + "procedure"); + + -- Line for -A switch + + Write_Line (" -A Give list of ALI files in partition"); + + -- Line for -b switch + + Write_Line (" -b Generate brief messages to stderr " & + "even if verbose mode set"); + + -- Line for -c switch + + Write_Line (" -c Check only, no generation of " & + "binder output file"); + + -- Line for -d switch + + Write_Line (" -dnn[k|m] Default primary stack " & + "size = nn [kilo|mega] bytes"); + + -- Line for D switch + + Write_Line (" -Dnn[k|m] Default secondary stack " & + "size = nn [kilo|mega] bytes"); + + -- Line for -e switch + + Write_Line (" -e Output complete list of elaboration " & + "order dependencies"); + + -- Line for -E switch + + Write_Line (" -E Store tracebacks in exception occurrences"); + + -- The -f switch is voluntarily omitted, because it is obsolete + + -- Line for -F switch + + Write_Line (" -F Force checking of elaboration Flags"); + + -- Line for -h switch + + Write_Line (" -h Output this usage (help) information"); + + -- Line for -H switch + + Write_Line (" -Hnn Use nn bit heap where nn is 32 or 64 " & + "(VMS Only)"); + + -- Lines for -I switch + + Write_Line (" -Idir Specify library and source files search path"); + Write_Line (" -I- Don't look for sources & library files " & + "in default directory"); + + -- Line for -K switch + + Write_Line (" -K Give list of linker options specified " & + "for link"); + + -- Line for -l switch + + Write_Line (" -l Output chosen elaboration order"); + + -- Line of -L switch + + Write_Line (" -Lxyz Library build: adainit/final " & + "renamed to xyzinit/final, implies -n"); + + -- Line for -m switch + + Write_Line (" -mnnn Limit number of detected errors/warnings " & + "to nnn (1-999999)"); + + -- Line for -M switch + + Write_Line (" -Mxyz Rename generated main program from " & + "main to xyz"); + + -- Line for -n switch + + Write_Line (" -n No Ada main program (foreign main routine)"); + + -- Line for -nostdinc + + Write_Line (" -nostdinc Don't look for source files " & + "in the system default directory"); + + -- Line for -nostdlib + + Write_Line (" -nostdlib Don't look for library files " & + "in the system default directory"); + + -- Line for -o switch + + Write_Line (" -o file Give the output file name " & + "(default is b~xxx.adb)"); + + -- Line for -O switch + + Write_Line (" -O Give list of objects required for link"); + + -- Line for -p switch + + Write_Line (" -p Pessimistic (worst-case) elaboration order"); + + -- Line for -r switch + + Write_Line (" -r List restrictions that could be applied " & + "to this partition"); + + -- Line for -R switch + + Write_Line + (" -R List sources referenced in closure"); + + -- Line for -s switch + + Write_Line (" -s Require all source files to be present"); + + -- Line for -S?? switch + + Write_Line (" -S?? Sin/lo/hi/xx/ev Initialize_Scalars " & + "invalid/low/high/hex/env var"); + + -- Line for -static + + Write_Line (" -static Link against a static GNAT run time"); + + -- Line for -shared + + Write_Line (" -shared Link against a shared GNAT run time"); + + -- Line for -t switch + + Write_Line (" -t Tolerate time stamp and other " & + "consistency errors"); + + -- Line for -T switch + + Write_Line (" -Tn Set time slice value to n " & + "milliseconds (n >= 0)"); + + -- Line for -u switch + + Write_Line (" -un Enable dynamic stack analysis, with " & + "n results stored"); + + -- Line for -v switch + + Write_Line (" -v Verbose mode. Error messages, " & + "header, summary output to stdout"); + + -- Line for -w switch + + Write_Line (" -wx Warning mode. (x=s/e for " & + "suppress/treat as error)"); + + -- Line for -W switch + + Write_Str (" -W? Wide character encoding method ("); + + for J in WC_Encoding_Method loop + Write_Char (WC_Encoding_Letters (J)); + + if J = WC_Encoding_Method'Last then + Write_Char (')'); + else + Write_Char ('/'); + end if; + end loop; + + Write_Eol; + + -- Line for -x switch + + Write_Line (" -x Exclude source files (check object " & + "consistency only)"); + + -- Line for -X switch + + Write_Line (" -Xnnn Default exit status value = nnn"); + + -- Line for -y switch + + Write_Line (" -y Enable leap seconds"); + + -- Line for -z switch + + Write_Line (" -z No main subprogram (zero main)"); + + -- Line for --RTS + + -- Line for -Z switch + + Write_Line (" -Z " & + "Zero formatting in auxiliary outputs (-e, -K, -l, -R)"); + + -- Line for --RTS + + Write_Line (" --RTS=dir Specify the default source and " & + "object search path"); + + -- Line for sfile + + Write_Line (" lfile Library file names"); + end Display; + +end Bindusg; diff --git a/gcc/ada/bindusg.ads b/gcc/ada/bindusg.ads new file mode 100644 index 000000000..e0d61a278 --- /dev/null +++ b/gcc/ada/bindusg.ads @@ -0,0 +1,33 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D U S G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Procedure to generate screen of usage information if no file name present + +package Bindusg is + + procedure Display; + -- Display binder usage if not already displayed + +end Bindusg; diff --git a/gcc/ada/butil.adb b/gcc/ada/butil.adb new file mode 100644 index 000000000..4d0f4420d --- /dev/null +++ b/gcc/ada/butil.adb @@ -0,0 +1,164 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B U T I L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Output; use Output; +with Targparm; use Targparm; + +package body Butil is + + ---------------------- + -- Is_Internal_Unit -- + ---------------------- + + -- Note: the reason we do not use the Fname package for this function + -- is that it would drag too much junk into the binder. + + function Is_Internal_Unit return Boolean is + begin + return Is_Predefined_Unit + or else (Name_Len > 4 + and then (Name_Buffer (1 .. 5) = "gnat%" + or else + Name_Buffer (1 .. 5) = "gnat.")) + or else + (OpenVMS_On_Target + and then Name_Len > 3 + and then (Name_Buffer (1 .. 4) = "dec%" + or else + Name_Buffer (1 .. 4) = "dec.")); + + end Is_Internal_Unit; + + ------------------------ + -- Is_Predefined_Unit -- + ------------------------ + + -- Note: the reason we do not use the Fname package for this function + -- is that it would drag too much junk into the binder. + + function Is_Predefined_Unit return Boolean is + begin + return (Name_Len > 3 + and then Name_Buffer (1 .. 4) = "ada.") + + or else (Name_Len > 6 + and then Name_Buffer (1 .. 7) = "system.") + + or else (Name_Len > 10 + and then Name_Buffer (1 .. 11) = "interfaces.") + + or else (Name_Len > 3 + and then Name_Buffer (1 .. 4) = "ada%") + + or else (Name_Len > 8 + and then Name_Buffer (1 .. 9) = "calendar%") + + or else (Name_Len > 9 + and then Name_Buffer (1 .. 10) = "direct_io%") + + or else (Name_Len > 10 + and then Name_Buffer (1 .. 11) = "interfaces%") + + or else (Name_Len > 13 + and then Name_Buffer (1 .. 14) = "io_exceptions%") + + or else (Name_Len > 12 + and then Name_Buffer (1 .. 13) = "machine_code%") + + or else (Name_Len > 13 + and then Name_Buffer (1 .. 14) = "sequential_io%") + + or else (Name_Len > 6 + and then Name_Buffer (1 .. 7) = "system%") + + or else (Name_Len > 7 + and then Name_Buffer (1 .. 8) = "text_io%") + + or else (Name_Len > 20 + and then Name_Buffer (1 .. 21) = "unchecked_conversion%") + + or else (Name_Len > 22 + and then Name_Buffer (1 .. 23) = "unchecked_deallocation%") + + or else (Name_Len > 4 + and then Name_Buffer (1 .. 5) = "gnat%") + + or else (Name_Len > 4 + and then Name_Buffer (1 .. 5) = "gnat."); + end Is_Predefined_Unit; + + ---------------- + -- Uname_Less -- + ---------------- + + function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean is + begin + Get_Name_String (U1); + + declare + U1_Name : constant String (1 .. Name_Len) := + Name_Buffer (1 .. Name_Len); + Min_Length : Natural; + + begin + Get_Name_String (U2); + + if Name_Len < U1_Name'Last then + Min_Length := Name_Len; + else + Min_Length := U1_Name'Last; + end if; + + for I in 1 .. Min_Length loop + if U1_Name (I) > Name_Buffer (I) then + return False; + elsif U1_Name (I) < Name_Buffer (I) then + return True; + end if; + end loop; + + return U1_Name'Last < Name_Len; + end; + end Uname_Less; + + --------------------- + -- Write_Unit_Name -- + --------------------- + + procedure Write_Unit_Name (U : Unit_Name_Type) is + begin + Get_Name_String (U); + Write_Str (Name_Buffer (1 .. Name_Len - 2)); + + if Name_Buffer (Name_Len) = 's' then + Write_Str (" (spec)"); + else + Write_Str (" (body)"); + end if; + + Name_Len := Name_Len + 5; + end Write_Unit_Name; + +end Butil; diff --git a/gcc/ada/butil.ads b/gcc/ada/butil.ads new file mode 100644 index 000000000..72fffc059 --- /dev/null +++ b/gcc/ada/butil.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B U T I L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Namet; use Namet; + +package Butil is + +-- This package contains utility routines for the binder + + function Is_Predefined_Unit return Boolean; + -- Given a unit name stored in Name_Buffer with length in Name_Len, + -- returns True if this is the name of a predefined unit or a child of + -- a predefined unit (including the obsolescent renamings). This is used + -- in the preference selection (see Better_Choice in body of Binde). + + function Is_Internal_Unit return Boolean; + -- Given a unit name stored in Name_Buffer with length in Name_Len, + -- returns True if this is the name of an internal unit or a child of + -- an internal. Similar in usage to Is_Predefined_Unit. + + -- Note: the following functions duplicate functionality in Uname, but + -- we want to avoid bringing Uname into the binder since it generates + -- to many unnecessary dependencies, and makes the binder too large. + + function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean; + -- Determines if the unit name U1 is alphabetically before U2 + + procedure Write_Unit_Name (U : Unit_Name_Type); + -- Output unit name with (body) or (spec) after as required. On return + -- Name_Len is set to the number of characters which were output. + +end Butil; diff --git a/gcc/ada/cal.c b/gcc/ada/cal.c new file mode 100644 index 000000000..6eb176915 --- /dev/null +++ b/gcc/ada/cal.c @@ -0,0 +1,109 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * C A L * + * * + * C Implementation File * + * * + * Copyright (C) 1992-2009, Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. * + * * + * As a special exception under Section 7 of GPL version 3, you are granted * + * additional permissions described in the GCC Runtime Library Exception, * + * version 3.1, as published by the Free Software Foundation. * + * * + * You should have received a copy of the GNU General Public License and * + * a copy of the GCC Runtime Library Exception along with this program; * + * see the files COPYING3 and COPYING.RUNTIME respectively. If 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 contains those routines named by Import pragmas in package */ +/* GNAT.Calendar. It is used to do Duration to timeval conversion. */ +/* These are simple wrappers function to abstract the fact that the C */ +/* struct timeval fields type are not normalized (they are generally */ +/* defined as int or long values). */ + +#if defined(VMS) || defined(__nucleus__) + +/* this is temporary code to avoid build failure under VMS */ + +void +__gnat_timeval_to_duration (void *t, long *sec, long *usec) +{ +} + +void +__gnat_duration_to_timeval (long sec, long usec, void *t) +{ +} + +#else + +#if defined (__vxworks) +#ifdef __RTP__ +#include +#include +#if (_WRS_VXWORKS_MINOR != 0) +#include +#endif +#else +#include +#endif +#elif defined (__nucleus__) +#include +#else +#include +#endif + +#ifdef __MINGW32__ +#include "mingw32.h" +#if STD_MINGW +#include +#endif +#endif + +void +__gnat_timeval_to_duration (struct timeval *t, long *sec, long *usec) +{ + *sec = (long) t->tv_sec; + *usec = (long) t->tv_usec; +} + +void +__gnat_duration_to_timeval (long sec, long usec, struct timeval *t) +{ + /* here we are doing implicit conversion from a long to the struct timeval + fields types. */ + + t->tv_sec = sec; + t->tv_usec = usec; +} +#endif + +#ifdef __alpha_vxworks +#include "vxWorks.h" +#elif defined (__vxworks) +#include +#endif + +/* Return the value of the "time" C library function. We always return + a long and do it this way to avoid problems with not knowing + what time_t is on the target. */ + +long +gnat_time (void) +{ + return time (0); +} diff --git a/gcc/ada/calendar.ads b/gcc/ada/calendar.ads new file mode 100644 index 000000000..7b13a6f23 --- /dev/null +++ b/gcc/ada/calendar.ads @@ -0,0 +1,18 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- C A L E N D A R -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Calendar; + +package Calendar renames Ada.Calendar; diff --git a/gcc/ada/casing.adb b/gcc/ada/casing.adb new file mode 100644 index 000000000..4a0d855e1 --- /dev/null +++ b/gcc/ada/casing.adb @@ -0,0 +1,200 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C A S I N G -- +-- -- +-- 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 Csets; use Csets; +with Namet; use Namet; +with Opt; use Opt; +with Widechar; use Widechar; + +package body Casing is + + ---------------------- + -- Determine_Casing -- + ---------------------- + + function Determine_Casing (Ident : Text_Buffer) return Casing_Type is + + All_Lower : Boolean := True; + -- Set False if upper case letter found + + All_Upper : Boolean := True; + -- Set False if lower case letter found + + Mixed : Boolean := True; + -- Set False if exception to mixed case rule found (lower case letter + -- at start or after underline, or upper case letter elsewhere). + + Decisive : Boolean := False; + -- Set True if at least one instance of letter not after underline + + After_Und : Boolean := True; + -- True at start of string, and after an underline character + + begin + for S in Ident'Range loop + if Ident (S) = '_' or else Ident (S) = '.' then + After_Und := True; + + elsif Is_Lower_Case_Letter (Ident (S)) then + All_Upper := False; + + if not After_Und then + Decisive := True; + else + After_Und := False; + Mixed := False; + end if; + + elsif Is_Upper_Case_Letter (Ident (S)) then + All_Lower := False; + + if not After_Und then + Decisive := True; + Mixed := False; + else + After_Und := False; + end if; + end if; + end loop; + + -- Now we can figure out the result from the flags we set in that loop + + if All_Lower then + return All_Lower_Case; + + elsif not Decisive then + return Unknown; + + elsif All_Upper then + return All_Upper_Case; + + elsif Mixed then + return Mixed_Case; + + else + return Unknown; + end if; + end Determine_Casing; + + ------------------------ + -- Set_All_Upper_Case -- + ------------------------ + + procedure Set_All_Upper_Case is + begin + Set_Casing (All_Upper_Case); + end Set_All_Upper_Case; + + ---------------- + -- Set_Casing -- + ---------------- + + procedure Set_Casing (C : Casing_Type; D : Casing_Type := Mixed_Case) is + Ptr : Natural; + + Actual_Casing : Casing_Type; + -- Set from C or D as appropriate + + After_Und : Boolean := True; + -- True at start of string, and after an underline character or after + -- any other special character that is not a normal identifier char). + + begin + if C /= Unknown then + Actual_Casing := C; + else + Actual_Casing := D; + end if; + + Ptr := 1; + + while Ptr <= Name_Len loop + + -- Wide character. Note that we do nothing with casing in this case. + -- In Ada 2005 mode, required folding of lower case letters happened + -- as the identifier was scanned, and we do not attempt any further + -- messing with case (note that in any case we do not know how to + -- fold upper case to lower case in wide character mode). We also + -- do not bother with recognizing punctuation as equivalent to an + -- underscore. There is nothing functional at this stage in doing + -- the requested casing operation, beyond folding to upper case + -- when it is mandatory, which does not involve underscores. + + if Name_Buffer (Ptr) = ASCII.ESC + or else Name_Buffer (Ptr) = '[' + or else (Upper_Half_Encoding + and then Name_Buffer (Ptr) in Upper_Half_Character) + then + Skip_Wide (Name_Buffer, Ptr); + After_Und := False; + + -- Underscore, or non-identifer character (error case) + + elsif Name_Buffer (Ptr) = '_' + or else not Identifier_Char (Name_Buffer (Ptr)) + then + After_Und := True; + Ptr := Ptr + 1; + + -- Lower case letter + + elsif Is_Lower_Case_Letter (Name_Buffer (Ptr)) then + if Actual_Casing = All_Upper_Case + or else (After_Und and then Actual_Casing = Mixed_Case) + then + Name_Buffer (Ptr) := Fold_Upper (Name_Buffer (Ptr)); + end if; + + After_Und := False; + Ptr := Ptr + 1; + + -- Upper case letter + + elsif Is_Upper_Case_Letter (Name_Buffer (Ptr)) then + if Actual_Casing = All_Lower_Case + or else (not After_Und and then Actual_Casing = Mixed_Case) + then + Name_Buffer (Ptr) := Fold_Lower (Name_Buffer (Ptr)); + end if; + + After_Und := False; + Ptr := Ptr + 1; + + -- Other identifier character (must be digit) + + else + After_Und := False; + Ptr := Ptr + 1; + end if; + end loop; + end Set_Casing; + +end Casing; diff --git a/gcc/ada/casing.ads b/gcc/ada/casing.ads new file mode 100644 index 000000000..8d169fbd3 --- /dev/null +++ b/gcc/ada/casing.ads @@ -0,0 +1,89 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C A S I N G -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with Types; use Types; + +package Casing is + + -- This package contains data and subprograms to support the feature that + -- recognizes the letter case styles used in the source program being + -- compiled, and uses this information for error message formatting, and + -- for recognizing reserved words that are misused as identifiers. + + ------------------------------- + -- Case Control Declarations -- + ------------------------------- + + -- Declaration of type for describing casing convention + + type Casing_Type is ( + + All_Upper_Case, + -- All letters are upper case + + All_Lower_Case, + -- All letters are lower case + + Mixed_Case, + -- The initial letter, and any letters after underlines are upper case. + -- All other letters are lower case + + Unknown + -- Used if an identifier does not distinguish between the above cases, + -- (e.g. X, Y_3, M4, A_B, or if it is inconsistent ABC_def). + ); + + subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case; + -- Exclude Unknown casing + + ------------------------------ + -- Case Control Subprograms -- + ------------------------------ + + procedure Set_Casing (C : Casing_Type; D : Casing_Type := Mixed_Case); + -- Takes the name stored in the first Name_Len positions of Name_Buffer + -- and modifies it to be consistent with the casing given by C, or if + -- C = Unknown, then with the casing given by D. The name is basically + -- treated as an identifier, except that special separator characters + -- other than underline are permitted and treated like underlines (this + -- handles cases like minus and period in unit names, apostrophes in error + -- messages, angle brackets in names like , etc). + + procedure Set_All_Upper_Case; + pragma Inline (Set_All_Upper_Case); + -- This procedure is called with an identifier name stored in Name_Buffer. + -- On return, the identifier is converted to all upper case. The call is + -- equivalent to Set_Casing (All_Upper_Case). + + function Determine_Casing (Ident : Text_Buffer) return Casing_Type; + -- Determines the casing of the identifier/keyword string Ident + +end Casing; diff --git a/gcc/ada/ceinfo.adb b/gcc/ada/ceinfo.adb new file mode 100644 index 000000000..44e7c67db --- /dev/null +++ b/gcc/ada/ceinfo.adb @@ -0,0 +1,219 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT SYSTEM UTILITIES -- +-- -- +-- C E I N F O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Check consistency of einfo.ads and einfo.adb. Checks that field name usage +-- is consistent, including comments mentioning fields. + +-- Note that this is used both as a standalone program, and as a procedure +-- called by XEinfo. This raises an unhandled exception if it finds any +-- errors; we don't attempt any sophisticated error recovery. + +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.Spitbol; use GNAT.Spitbol; +with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; +with GNAT.Spitbol.Table_VString; + +procedure CEinfo is + + package TV renames GNAT.Spitbol.Table_VString; + use TV; + + Infil : File_Type; + Lineno : Natural := 0; + + Err : exception; + -- Raised on error + + Fieldnm : VString; + Accessfunc : VString; + Line : VString; + + Fields : GNAT.Spitbol.Table_VString.Table (500); + -- Maps field names to underlying field access name + + UC : constant Pattern := Any ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); + + Fnam : constant Pattern := (UC & Break (' ')) * Fieldnm; + + Field_Def : constant Pattern := + "-- " & Fnam & " (" & Break (')') * Accessfunc; + + Field_Ref : constant Pattern := + " -- " & Fnam & Break ('(') & Len (1) & + Break (')') * Accessfunc; + + Field_Com : constant Pattern := " -- " & Fnam & Span (' ') & + (Break (' ') or Rest) * Accessfunc; + + Func_Hedr : constant Pattern := " function " & Fnam; + + Func_Retn : constant Pattern := " return " & Break (' ') * Accessfunc; + + Proc_Hedr : constant Pattern := " procedure " & Fnam; + + Proc_Setf : constant Pattern := " Set_" & Break (' ') * Accessfunc; + + procedure Next_Line; + -- Read next line trimmed from Infil into Line and bump Lineno + + procedure Next_Line is + begin + Line := Get_Line (Infil); + Trim (Line); + Lineno := Lineno + 1; + end Next_Line; + +-- Start of processing for CEinfo + +begin + Anchored_Mode := True; + New_Line; + Open (Infil, In_File, "einfo.ads"); + + Put_Line ("Acquiring field names from spec"); + + loop + Next_Line; + exit when Match (Line, " -- Access Kinds --"); + + if Match (Line, Field_Def) then + Set (Fields, Fieldnm, Accessfunc); + end if; + end loop; + + Put_Line ("Checking consistent references in spec"); + + loop + Next_Line; + exit when Match (Line, " -- Description of Defined"); + end loop; + + loop + Next_Line; + exit when Match (Line, " -- Component_Alignment Control"); + + if Match (Line, Field_Ref) then + if Accessfunc /= "synth" + and then + Accessfunc /= "special" + and then + Accessfunc /= Get (Fields, Fieldnm) + then + if Present (Fields, Fieldnm) then + Put_Line ("*** field name incorrect at line " & Lineno); + Put_Line (" found field " & Accessfunc); + Put_Line (" expecting field " & Get (Fields, Fieldnm)); + + else + Put_Line + ("*** unknown field name " & Fieldnm & " at line " & Lineno); + end if; + + raise Err; + end if; + end if; + end loop; + + Close (Infil); + Open (Infil, In_File, "einfo.adb"); + Lineno := 0; + + Put_Line ("Check listing of fields in body"); + + loop + Next_Line; + exit when Match (Line, " -- Attribute Access Functions --"); + + if Match (Line, Field_Com) + and then Fieldnm /= "(unused)" + and then Accessfunc /= Get (Fields, Fieldnm) + then + if Present (Fields, Fieldnm) then + Put_Line ("*** field name incorrect at line " & Lineno); + Put_Line (" found field " & Accessfunc); + Put_Line (" expecting field " & Get (Fields, Fieldnm)); + + else + Put_Line + ("*** unknown field name " & Fieldnm & " at line " & Lineno); + end if; + + raise Err; + end if; + end loop; + + Put_Line ("Check references in access routines in body"); + + loop + Next_Line; + exit when Match (Line, " -- Classification Functions --"); + + if Match (Line, Func_Hedr) then + null; + + elsif Match (Line, Func_Retn) + and then Accessfunc /= Get (Fields, Fieldnm) + and then Fieldnm /= "Mechanism" + then + Put_Line ("*** incorrect field at line " & Lineno); + Put_Line (" found field " & Accessfunc); + Put_Line (" expecting field " & Get (Fields, Fieldnm)); + raise Err; + end if; + end loop; + + Put_Line ("Check references in set routines in body"); + + loop + Next_Line; + exit when Match (Line, " -- Attribute Set Procedures"); + end loop; + + loop + Next_Line; + exit when Match (Line, " ------------"); + + if Match (Line, Proc_Hedr) then + null; + + elsif Match (Line, Proc_Setf) + and then Accessfunc /= Get (Fields, Fieldnm) + and then Fieldnm /= "Mechanism" + then + Put_Line ("*** incorrect field at line " & Lineno); + Put_Line (" found field " & Accessfunc); + Put_Line (" expecting field " & Get (Fields, Fieldnm)); + raise Err; + end if; + end loop; + + Close (Infil); + + Put_Line ("All tests completed successfully, no errors detected"); + +end CEinfo; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb new file mode 100644 index 000000000..46a966827 --- /dev/null +++ b/gcc/ada/checks.adb @@ -0,0 +1,7181 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C H E C K 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Debug; use Debug; +with Einfo; use Einfo; +with Errout; use Errout; +with Exp_Ch2; use Exp_Ch2; +with Exp_Ch4; use Exp_Ch4; +with Exp_Ch11; use Exp_Ch11; +with Exp_Pakd; use Exp_Pakd; +with Exp_Util; use Exp_Util; +with Elists; use Elists; +with Eval_Fat; use Eval_Fat; +with Freeze; use Freeze; +with Lib; use Lib; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Output; use Output; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Eval; use Sem_Eval; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch8; use Sem_Ch8; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with Sprint; use Sprint; +with Stand; use Stand; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Urealp; use Urealp; +with Validsw; use Validsw; + +package body Checks is + + -- General note: many of these routines are concerned with generating + -- checking code to make sure that constraint error is raised at runtime. + -- Clearly this code is only needed if the expander is active, since + -- otherwise we will not be generating code or going into the runtime + -- execution anyway. + + -- We therefore disconnect most of these checks if the expander is + -- inactive. This has the additional benefit that we do not need to + -- worry about the tree being messed up by previous errors (since errors + -- turn off expansion anyway). + + -- There are a few exceptions to the above rule. For instance routines + -- such as Apply_Scalar_Range_Check that do not insert any code can be + -- safely called even when the Expander is inactive (but Errors_Detected + -- is 0). The benefit of executing this code when expansion is off, is + -- the ability to emit constraint error warning for static expressions + -- even when we are not generating code. + + ------------------------------------- + -- Suppression of Redundant Checks -- + ------------------------------------- + + -- This unit implements a limited circuit for removal of redundant + -- checks. The processing is based on a tracing of simple sequential + -- flow. For any sequence of statements, we save expressions that are + -- marked to be checked, and then if the same expression appears later + -- with the same check, then under certain circumstances, the second + -- check can be suppressed. + + -- Basically, we can suppress the check if we know for certain that + -- the previous expression has been elaborated (together with its + -- check), and we know that the exception frame is the same, and that + -- nothing has happened to change the result of the exception. + + -- Let us examine each of these three conditions in turn to describe + -- how we ensure that this condition is met. + + -- First, we need to know for certain that the previous expression has + -- been executed. This is done principally by the mechanism of calling + -- Conditional_Statements_Begin at the start of any statement sequence + -- and Conditional_Statements_End at the end. The End call causes all + -- checks remembered since the Begin call to be discarded. This does + -- miss a few cases, notably the case of a nested BEGIN-END block with + -- no exception handlers. But the important thing is to be conservative. + -- The other protection is that all checks are discarded if a label + -- is encountered, since then the assumption of sequential execution + -- is violated, and we don't know enough about the flow. + + -- Second, we need to know that the exception frame is the same. We + -- do this by killing all remembered checks when we enter a new frame. + -- Again, that's over-conservative, but generally the cases we can help + -- with are pretty local anyway (like the body of a loop for example). + + -- Third, we must be sure to forget any checks which are no longer valid. + -- This is done by two mechanisms, first the Kill_Checks_Variable call is + -- used to note any changes to local variables. We only attempt to deal + -- with checks involving local variables, so we do not need to worry + -- about global variables. Second, a call to any non-global procedure + -- causes us to abandon all stored checks, since such a all may affect + -- the values of any local variables. + + -- The following define the data structures used to deal with remembering + -- checks so that redundant checks can be eliminated as described above. + + -- Right now, the only expressions that we deal with are of the form of + -- simple local objects (either declared locally, or IN parameters) or + -- such objects plus/minus a compile time known constant. We can do + -- more later on if it seems worthwhile, but this catches many simple + -- cases in practice. + + -- The following record type reflects a single saved check. An entry + -- is made in the stack of saved checks if and only if the expression + -- has been elaborated with the indicated checks. + + type Saved_Check is record + Killed : Boolean; + -- Set True if entry is killed by Kill_Checks + + Entity : Entity_Id; + -- The entity involved in the expression that is checked + + Offset : Uint; + -- A compile time value indicating the result of adding or + -- subtracting a compile time value. This value is to be + -- added to the value of the Entity. A value of zero is + -- used for the case of a simple entity reference. + + Check_Type : Character; + -- This is set to 'R' for a range check (in which case Target_Type + -- is set to the target type for the range check) or to 'O' for an + -- overflow check (in which case Target_Type is set to Empty). + + Target_Type : Entity_Id; + -- Used only if Do_Range_Check is set. Records the target type for + -- the check. We need this, because a check is a duplicate only if + -- it has the same target type (or more accurately one with a + -- range that is smaller or equal to the stored target type of a + -- saved check). + end record; + + -- The following table keeps track of saved checks. Rather than use an + -- extensible table. We just use a table of fixed size, and we discard + -- any saved checks that do not fit. That's very unlikely to happen and + -- this is only an optimization in any case. + + Saved_Checks : array (Int range 1 .. 200) of Saved_Check; + -- Array of saved checks + + Num_Saved_Checks : Nat := 0; + -- Number of saved checks + + -- The following stack keeps track of statement ranges. It is treated + -- as a stack. When Conditional_Statements_Begin is called, an entry + -- is pushed onto this stack containing the value of Num_Saved_Checks + -- at the time of the call. Then when Conditional_Statements_End is + -- called, this value is popped off and used to reset Num_Saved_Checks. + + -- Note: again, this is a fixed length stack with a size that should + -- always be fine. If the value of the stack pointer goes above the + -- limit, then we just forget all saved checks. + + Saved_Checks_Stack : array (Int range 1 .. 100) of Nat; + Saved_Checks_TOS : Nat := 0; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Apply_Float_Conversion_Check + (Ck_Node : Node_Id; + Target_Typ : Entity_Id); + -- The checks on a conversion from a floating-point type to an integer + -- type are delicate. They have to be performed before conversion, they + -- have to raise an exception when the operand is a NaN, and rounding must + -- be taken into account to determine the safe bounds of the operand. + + procedure Apply_Selected_Length_Checks + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id; + Do_Static : Boolean); + -- This is the subprogram that does all the work for Apply_Length_Check + -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as + -- described for the above routines. The Do_Static flag indicates that + -- only a static check is to be done. + + procedure Apply_Selected_Range_Checks + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id; + Do_Static : Boolean); + -- This is the subprogram that does all the work for Apply_Range_Check. + -- Expr, Target_Typ and Source_Typ are as described for the above + -- routine. The Do_Static flag indicates that only a static check is + -- to be done. + + type Check_Type is new Check_Id range Access_Check .. Division_Check; + function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean; + -- This function is used to see if an access or division by zero check is + -- needed. The check is to be applied to a single variable appearing in the + -- source, and N is the node for the reference. If N is not of this form, + -- True is returned with no further processing. If N is of the right form, + -- then further processing determines if the given Check is needed. + -- + -- The particular circuit is to see if we have the case of a check that is + -- not needed because it appears in the right operand of a short circuited + -- conditional where the left operand guards the check. For example: + -- + -- if Var = 0 or else Q / Var > 12 then + -- ... + -- end if; + -- + -- In this example, the division check is not required. At the same time + -- we can issue warnings for suspicious use of non-short-circuited forms, + -- such as: + -- + -- if Var = 0 or Q / Var > 12 then + -- ... + -- end if; + + procedure Find_Check + (Expr : Node_Id; + Check_Type : Character; + Target_Type : Entity_Id; + Entry_OK : out Boolean; + Check_Num : out Nat; + Ent : out Entity_Id; + Ofs : out Uint); + -- This routine is used by Enable_Range_Check and Enable_Overflow_Check + -- to see if a check is of the form for optimization, and if so, to see + -- if it has already been performed. Expr is the expression to check, + -- and Check_Type is 'R' for a range check, 'O' for an overflow check. + -- Target_Type is the target type for a range check, and Empty for an + -- overflow check. If the entry is not of the form for optimization, + -- then Entry_OK is set to False, and the remaining out parameters + -- are undefined. If the entry is OK, then Ent/Ofs are set to the + -- entity and offset from the expression. Check_Num is the number of + -- a matching saved entry in Saved_Checks, or zero if no such entry + -- is located. + + function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id; + -- If a discriminal is used in constraining a prival, Return reference + -- to the discriminal of the protected body (which renames the parameter + -- of the enclosing protected operation). This clumsy transformation is + -- needed because privals are created too late and their actual subtypes + -- are not available when analysing the bodies of the protected operations. + -- This function is called whenever the bound is an entity and the scope + -- indicates a protected operation. If the bound is an in-parameter of + -- a protected operation that is not a prival, the function returns the + -- bound itself. + -- To be cleaned up??? + + function Guard_Access + (Cond : Node_Id; + Loc : Source_Ptr; + Ck_Node : Node_Id) return Node_Id; + -- In the access type case, guard the test with a test to ensure + -- that the access value is non-null, since the checks do not + -- not apply to null access values. + + procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr); + -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the + -- Constraint_Error node. + + function Range_Or_Validity_Checks_Suppressed + (Expr : Node_Id) return Boolean; + -- Returns True if either range or validity checks or both are suppressed + -- for the type of the given expression, or, if the expression is the name + -- of an entity, if these checks are suppressed for the entity. + + function Selected_Length_Checks + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id; + Warn_Node : Node_Id) return Check_Result; + -- Like Apply_Selected_Length_Checks, except it doesn't modify + -- anything, just returns a list of nodes as described in the spec of + -- this package for the Range_Check function. + + function Selected_Range_Checks + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id; + Warn_Node : Node_Id) return Check_Result; + -- Like Apply_Selected_Range_Checks, except it doesn't modify anything, + -- just returns a list of nodes as described in the spec of this package + -- for the Range_Check function. + + ------------------------------ + -- Access_Checks_Suppressed -- + ------------------------------ + + function Access_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + if Present (E) and then Checks_May_Be_Suppressed (E) then + return Is_Check_Suppressed (E, Access_Check); + else + return Scope_Suppress (Access_Check); + end if; + end Access_Checks_Suppressed; + + ------------------------------------- + -- Accessibility_Checks_Suppressed -- + ------------------------------------- + + function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + if Present (E) and then Checks_May_Be_Suppressed (E) then + return Is_Check_Suppressed (E, Accessibility_Check); + else + return Scope_Suppress (Accessibility_Check); + end if; + end Accessibility_Checks_Suppressed; + + ----------------------------- + -- Activate_Division_Check -- + ----------------------------- + + procedure Activate_Division_Check (N : Node_Id) is + begin + Set_Do_Division_Check (N, True); + Possible_Local_Raise (N, Standard_Constraint_Error); + end Activate_Division_Check; + + ----------------------------- + -- Activate_Overflow_Check -- + ----------------------------- + + procedure Activate_Overflow_Check (N : Node_Id) is + begin + Set_Do_Overflow_Check (N, True); + Possible_Local_Raise (N, Standard_Constraint_Error); + end Activate_Overflow_Check; + + -------------------------- + -- Activate_Range_Check -- + -------------------------- + + procedure Activate_Range_Check (N : Node_Id) is + begin + Set_Do_Range_Check (N, True); + Possible_Local_Raise (N, Standard_Constraint_Error); + end Activate_Range_Check; + + --------------------------------- + -- Alignment_Checks_Suppressed -- + --------------------------------- + + function Alignment_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + if Present (E) and then Checks_May_Be_Suppressed (E) then + return Is_Check_Suppressed (E, Alignment_Check); + else + return Scope_Suppress (Alignment_Check); + end if; + end Alignment_Checks_Suppressed; + + ------------------------- + -- Append_Range_Checks -- + ------------------------- + + procedure Append_Range_Checks + (Checks : Check_Result; + Stmts : List_Id; + Suppress_Typ : Entity_Id; + Static_Sloc : Source_Ptr; + Flag_Node : Node_Id) + is + Internal_Flag_Node : constant Node_Id := Flag_Node; + Internal_Static_Sloc : constant Source_Ptr := Static_Sloc; + + Checks_On : constant Boolean := + (not Index_Checks_Suppressed (Suppress_Typ)) + or else + (not Range_Checks_Suppressed (Suppress_Typ)); + + begin + -- For now we just return if Checks_On is false, however this should + -- be enhanced to check for an always True value in the condition + -- and to generate a compilation warning??? + + if not Checks_On then + return; + end if; + + for J in 1 .. 2 loop + exit when No (Checks (J)); + + if Nkind (Checks (J)) = N_Raise_Constraint_Error + and then Present (Condition (Checks (J))) + then + if not Has_Dynamic_Range_Check (Internal_Flag_Node) then + Append_To (Stmts, Checks (J)); + Set_Has_Dynamic_Range_Check (Internal_Flag_Node); + end if; + + else + Append_To + (Stmts, + Make_Raise_Constraint_Error (Internal_Static_Sloc, + Reason => CE_Range_Check_Failed)); + end if; + end loop; + end Append_Range_Checks; + + ------------------------ + -- Apply_Access_Check -- + ------------------------ + + procedure Apply_Access_Check (N : Node_Id) is + P : constant Node_Id := Prefix (N); + + begin + -- We do not need checks if we are not generating code (i.e. the + -- expander is not active). This is not just an optimization, there + -- are cases (e.g. with pragma Debug) where generating the checks + -- can cause real trouble). + + if not Expander_Active then + return; + end if; + + -- No check if short circuiting makes check unnecessary + + if not Check_Needed (P, Access_Check) then + return; + end if; + + -- No check if accessing the Offset_To_Top component of a dispatch + -- table. They are safe by construction. + + if Tagged_Type_Expansion + and then Present (Etype (P)) + and then RTU_Loaded (Ada_Tags) + and then RTE_Available (RE_Offset_To_Top_Ptr) + and then Etype (P) = RTE (RE_Offset_To_Top_Ptr) + then + return; + end if; + + -- Otherwise go ahead and install the check + + Install_Null_Excluding_Check (P); + end Apply_Access_Check; + + ------------------------------- + -- Apply_Accessibility_Check -- + ------------------------------- + + procedure Apply_Accessibility_Check + (N : Node_Id; + Typ : Entity_Id; + Insert_Node : Node_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Param_Ent : constant Entity_Id := Param_Entity (N); + Param_Level : Node_Id; + Type_Level : Node_Id; + + begin + if Inside_A_Generic then + return; + + -- Only apply the run-time check if the access parameter has an + -- associated extra access level parameter and when the level of the + -- type is less deep than the level of the access parameter, and + -- accessibility checks are not suppressed. + + elsif Present (Param_Ent) + and then Present (Extra_Accessibility (Param_Ent)) + and then UI_Gt (Object_Access_Level (N), Type_Access_Level (Typ)) + and then not Accessibility_Checks_Suppressed (Param_Ent) + and then not Accessibility_Checks_Suppressed (Typ) + then + Param_Level := + New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc); + + Type_Level := + Make_Integer_Literal (Loc, Type_Access_Level (Typ)); + + -- Raise Program_Error if the accessibility level of the access + -- parameter is deeper than the level of the target access type. + + Insert_Action (Insert_Node, + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => Param_Level, + Right_Opnd => Type_Level), + Reason => PE_Accessibility_Check_Failed)); + + Analyze_And_Resolve (N); + end if; + end Apply_Accessibility_Check; + + -------------------------------- + -- Apply_Address_Clause_Check -- + -------------------------------- + + procedure Apply_Address_Clause_Check (E : Entity_Id; N : Node_Id) is + AC : constant Node_Id := Address_Clause (E); + Loc : constant Source_Ptr := Sloc (AC); + Typ : constant Entity_Id := Etype (E); + Aexp : constant Node_Id := Expression (AC); + + Expr : Node_Id; + -- Address expression (not necessarily the same as Aexp, for example + -- when Aexp is a reference to a constant, in which case Expr gets + -- reset to reference the value expression of the constant. + + procedure Compile_Time_Bad_Alignment; + -- Post error warnings when alignment is known to be incompatible. Note + -- that we do not go as far as inserting a raise of Program_Error since + -- this is an erroneous case, and it may happen that we are lucky and an + -- underaligned address turns out to be OK after all. + + -------------------------------- + -- Compile_Time_Bad_Alignment -- + -------------------------------- + + procedure Compile_Time_Bad_Alignment is + begin + if Address_Clause_Overlay_Warnings then + Error_Msg_FE + ("?specified address for& may be inconsistent with alignment ", + Aexp, E); + Error_Msg_FE + ("\?program execution may be erroneous (RM 13.3(27))", + Aexp, E); + Set_Address_Warning_Posted (AC); + end if; + end Compile_Time_Bad_Alignment; + + -- Start of processing for Apply_Address_Clause_Check + + begin + -- See if alignment check needed. Note that we never need a check if the + -- maximum alignment is one, since the check will always succeed. + + -- Note: we do not check for checks suppressed here, since that check + -- was done in Sem_Ch13 when the address clause was processed. We are + -- only called if checks were not suppressed. The reason for this is + -- that we have to delay the call to Apply_Alignment_Check till freeze + -- time (so that all types etc are elaborated), but we have to check + -- the status of check suppressing at the point of the address clause. + + if No (AC) + or else not Check_Address_Alignment (AC) + or else Maximum_Alignment = 1 + then + return; + end if; + + -- Obtain expression from address clause + + Expr := Expression (AC); + + -- The following loop digs for the real expression to use in the check + + loop + -- For constant, get constant expression + + if Is_Entity_Name (Expr) + and then Ekind (Entity (Expr)) = E_Constant + then + Expr := Constant_Value (Entity (Expr)); + + -- For unchecked conversion, get result to convert + + elsif Nkind (Expr) = N_Unchecked_Type_Conversion then + Expr := Expression (Expr); + + -- For (common case) of To_Address call, get argument + + elsif Nkind (Expr) = N_Function_Call + and then Is_Entity_Name (Name (Expr)) + and then Is_RTE (Entity (Name (Expr)), RE_To_Address) + then + Expr := First (Parameter_Associations (Expr)); + + if Nkind (Expr) = N_Parameter_Association then + Expr := Explicit_Actual_Parameter (Expr); + end if; + + -- We finally have the real expression + + else + exit; + end if; + end loop; + + -- See if we know that Expr has a bad alignment at compile time + + if Compile_Time_Known_Value (Expr) + and then (Known_Alignment (E) or else Known_Alignment (Typ)) + then + declare + AL : Uint := Alignment (Typ); + + begin + -- The object alignment might be more restrictive than the + -- type alignment. + + if Known_Alignment (E) then + AL := Alignment (E); + end if; + + if Expr_Value (Expr) mod AL /= 0 then + Compile_Time_Bad_Alignment; + else + return; + end if; + end; + + -- If the expression has the form X'Address, then we can find out if + -- the object X has an alignment that is compatible with the object E. + -- If it hasn't or we don't know, we defer issuing the warning until + -- the end of the compilation to take into account back end annotations. + + elsif Nkind (Expr) = N_Attribute_Reference + and then Attribute_Name (Expr) = Name_Address + and then Has_Compatible_Alignment (E, Prefix (Expr)) = Known_Compatible + then + return; + end if; + + -- Here we do not know if the value is acceptable. Strictly we don't + -- have to do anything, since if the alignment is bad, we have an + -- erroneous program. However we are allowed to check for erroneous + -- conditions and we decide to do this by default if the check is not + -- suppressed. + + -- However, don't do the check if elaboration code is unwanted + + if Restriction_Active (No_Elaboration_Code) then + return; + + -- Generate a check to raise PE if alignment may be inappropriate + + else + -- If the original expression is a non-static constant, use the + -- name of the constant itself rather than duplicating its + -- defining expression, which was extracted above. + + -- Note: Expr is empty if the address-clause is applied to in-mode + -- actuals (allowed by 13.1(22)). + + if not Present (Expr) + or else + (Is_Entity_Name (Expression (AC)) + and then Ekind (Entity (Expression (AC))) = E_Constant + and then Nkind (Parent (Entity (Expression (AC)))) + = N_Object_Declaration) + then + Expr := New_Copy_Tree (Expression (AC)); + else + Remove_Side_Effects (Expr); + end if; + + Insert_After_And_Analyze (N, + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => + Make_Op_Mod (Loc, + Left_Opnd => + Unchecked_Convert_To + (RTE (RE_Integer_Address), Expr), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (E, Loc), + Attribute_Name => Name_Alignment)), + Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), + Reason => PE_Misaligned_Address_Value), + Suppress => All_Checks); + return; + end if; + + exception + -- If we have some missing run time component in configurable run time + -- mode then just skip the check (it is not required in any case). + + when RE_Not_Available => + return; + end Apply_Address_Clause_Check; + + ------------------------------------- + -- Apply_Arithmetic_Overflow_Check -- + ------------------------------------- + + -- This routine is called only if the type is an integer type, and a + -- software arithmetic overflow check may be needed for op (add, subtract, + -- or multiply). This check is performed only if Software_Overflow_Checking + -- is enabled and Do_Overflow_Check is set. In this case we expand the + -- operation into a more complex sequence of tests that ensures that + -- overflow is properly caught. + + procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Rtyp : constant Entity_Id := Root_Type (Typ); + + begin + -- An interesting special case. If the arithmetic operation appears as + -- the operand of a type conversion: + + -- type1 (x op y) + + -- and all the following conditions apply: + + -- arithmetic operation is for a signed integer type + -- target type type1 is a static integer subtype + -- range of x and y are both included in the range of type1 + -- range of x op y is included in the range of type1 + -- size of type1 is at least twice the result size of op + + -- then we don't do an overflow check in any case, instead we transform + -- the operation so that we end up with: + + -- type1 (type1 (x) op type1 (y)) + + -- This avoids intermediate overflow before the conversion. It is + -- explicitly permitted by RM 3.5.4(24): + + -- For the execution of a predefined operation of a signed integer + -- type, the implementation need not raise Constraint_Error if the + -- result is outside the base range of the type, so long as the + -- correct result is produced. + + -- It's hard to imagine that any programmer counts on the exception + -- being raised in this case, and in any case it's wrong coding to + -- have this expectation, given the RM permission. Furthermore, other + -- Ada compilers do allow such out of range results. + + -- Note that we do this transformation even if overflow checking is + -- off, since this is precisely about giving the "right" result and + -- avoiding the need for an overflow check. + + -- Note: this circuit is partially redundant with respect to the similar + -- processing in Exp_Ch4.Expand_N_Type_Conversion, but the latter deals + -- with cases that do not come through here. We still need the following + -- processing even with the Exp_Ch4 code in place, since we want to be + -- sure not to generate the arithmetic overflow check in these cases + -- (Exp_Ch4 would have a hard time removing them once generated). + + if Is_Signed_Integer_Type (Typ) + and then Nkind (Parent (N)) = N_Type_Conversion + then + declare + Target_Type : constant Entity_Id := + Base_Type (Entity (Subtype_Mark (Parent (N)))); + + Llo, Lhi : Uint; + Rlo, Rhi : Uint; + LOK, ROK : Boolean; + + Vlo : Uint; + Vhi : Uint; + VOK : Boolean; + + Tlo : Uint; + Thi : Uint; + + begin + if Is_Integer_Type (Target_Type) + and then RM_Size (Root_Type (Target_Type)) >= 2 * RM_Size (Rtyp) + then + Tlo := Expr_Value (Type_Low_Bound (Target_Type)); + Thi := Expr_Value (Type_High_Bound (Target_Type)); + + Determine_Range + (Left_Opnd (N), LOK, Llo, Lhi, Assume_Valid => True); + Determine_Range + (Right_Opnd (N), ROK, Rlo, Rhi, Assume_Valid => True); + + if (LOK and ROK) + and then Tlo <= Llo and then Lhi <= Thi + and then Tlo <= Rlo and then Rhi <= Thi + then + Determine_Range (N, VOK, Vlo, Vhi, Assume_Valid => True); + + if VOK and then Tlo <= Vlo and then Vhi <= Thi then + Rewrite (Left_Opnd (N), + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), + Expression => Relocate_Node (Left_Opnd (N)))); + + Rewrite (Right_Opnd (N), + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), + Expression => Relocate_Node (Right_Opnd (N)))); + + -- Rewrite the conversion operand so that the original + -- node is retained, in order to avoid the warning for + -- redundant conversions in Resolve_Type_Conversion. + + Rewrite (N, Relocate_Node (N)); + + Set_Etype (N, Target_Type); + + Analyze_And_Resolve (Left_Opnd (N), Target_Type); + Analyze_And_Resolve (Right_Opnd (N), Target_Type); + + -- Given that the target type is twice the size of the + -- source type, overflow is now impossible, so we can + -- safely kill the overflow check and return. + + Set_Do_Overflow_Check (N, False); + return; + end if; + end if; + end if; + end; + end if; + + -- Now see if an overflow check is required + + declare + Siz : constant Int := UI_To_Int (Esize (Rtyp)); + Dsiz : constant Int := Siz * 2; + Opnod : Node_Id; + Ctyp : Entity_Id; + Opnd : Node_Id; + Cent : RE_Id; + + begin + -- Skip check if back end does overflow checks, or the overflow flag + -- is not set anyway, or we are not doing code expansion, or the + -- parent node is a type conversion whose operand is an arithmetic + -- operation on signed integers on which the expander can promote + -- later the operands to type Integer (see Expand_N_Type_Conversion). + + -- Special case CLI target, where arithmetic overflow checks can be + -- performed for integer and long_integer + + if Backend_Overflow_Checks_On_Target + or else not Do_Overflow_Check (N) + or else not Expander_Active + or else (Present (Parent (N)) + and then Nkind (Parent (N)) = N_Type_Conversion + and then Integer_Promotion_Possible (Parent (N))) + or else + (VM_Target = CLI_Target and then Siz >= Standard_Integer_Size) + then + return; + end if; + + -- Otherwise, generate the full general code for front end overflow + -- detection, which works by doing arithmetic in a larger type: + + -- x op y + + -- is expanded into + + -- Typ (Checktyp (x) op Checktyp (y)); + + -- where Typ is the type of the original expression, and Checktyp is + -- an integer type of sufficient length to hold the largest possible + -- result. + + -- If the size of check type exceeds the size of Long_Long_Integer, + -- we use a different approach, expanding to: + + -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y))) + + -- where xxx is Add, Multiply or Subtract as appropriate + + -- Find check type if one exists + + if Dsiz <= Standard_Integer_Size then + Ctyp := Standard_Integer; + + elsif Dsiz <= Standard_Long_Long_Integer_Size then + Ctyp := Standard_Long_Long_Integer; + + -- No check type exists, use runtime call + + else + if Nkind (N) = N_Op_Add then + Cent := RE_Add_With_Ovflo_Check; + + elsif Nkind (N) = N_Op_Multiply then + Cent := RE_Multiply_With_Ovflo_Check; + + else + pragma Assert (Nkind (N) = N_Op_Subtract); + Cent := RE_Subtract_With_Ovflo_Check; + end if; + + Rewrite (N, + OK_Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (Cent), Loc), + Parameter_Associations => New_List ( + OK_Convert_To (RTE (RE_Integer_64), Left_Opnd (N)), + OK_Convert_To (RTE (RE_Integer_64), Right_Opnd (N)))))); + + Analyze_And_Resolve (N, Typ); + return; + end if; + + -- If we fall through, we have the case where we do the arithmetic + -- in the next higher type and get the check by conversion. In these + -- cases Ctyp is set to the type to be used as the check type. + + Opnod := Relocate_Node (N); + + Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod)); + + Analyze (Opnd); + Set_Etype (Opnd, Ctyp); + Set_Analyzed (Opnd, True); + Set_Left_Opnd (Opnod, Opnd); + + Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod)); + + Analyze (Opnd); + Set_Etype (Opnd, Ctyp); + Set_Analyzed (Opnd, True); + Set_Right_Opnd (Opnod, Opnd); + + -- The type of the operation changes to the base type of the check + -- type, and we reset the overflow check indication, since clearly no + -- overflow is possible now that we are using a double length type. + -- We also set the Analyzed flag to avoid a recursive attempt to + -- expand the node. + + Set_Etype (Opnod, Base_Type (Ctyp)); + Set_Do_Overflow_Check (Opnod, False); + Set_Analyzed (Opnod, True); + + -- Now build the outer conversion + + Opnd := OK_Convert_To (Typ, Opnod); + Analyze (Opnd); + Set_Etype (Opnd, Typ); + + -- In the discrete type case, we directly generate the range check + -- for the outer operand. This range check will implement the + -- required overflow check. + + if Is_Discrete_Type (Typ) then + Rewrite (N, Opnd); + Generate_Range_Check + (Expression (N), Typ, CE_Overflow_Check_Failed); + + -- For other types, we enable overflow checking on the conversion, + -- after setting the node as analyzed to prevent recursive attempts + -- to expand the conversion node. + + else + Set_Analyzed (Opnd, True); + Enable_Overflow_Check (Opnd); + Rewrite (N, Opnd); + end if; + + exception + when RE_Not_Available => + return; + end; + end Apply_Arithmetic_Overflow_Check; + + ---------------------------- + -- Apply_Constraint_Check -- + ---------------------------- + + procedure Apply_Constraint_Check + (N : Node_Id; + Typ : Entity_Id; + No_Sliding : Boolean := False) + is + Desig_Typ : Entity_Id; + + begin + -- No checks inside a generic (check the instantiations) + + if Inside_A_Generic then + return; + end if; + + -- Apply required constraint checks + + if Is_Scalar_Type (Typ) then + Apply_Scalar_Range_Check (N, Typ); + + elsif Is_Array_Type (Typ) then + + -- A useful optimization: an aggregate with only an others clause + -- always has the right bounds. + + if Nkind (N) = N_Aggregate + and then No (Expressions (N)) + and then Nkind + (First (Choices (First (Component_Associations (N))))) + = N_Others_Choice + then + return; + end if; + + if Is_Constrained (Typ) then + Apply_Length_Check (N, Typ); + + if No_Sliding then + Apply_Range_Check (N, Typ); + end if; + else + Apply_Range_Check (N, Typ); + end if; + + elsif (Is_Record_Type (Typ) + or else Is_Private_Type (Typ)) + and then Has_Discriminants (Base_Type (Typ)) + and then Is_Constrained (Typ) + then + Apply_Discriminant_Check (N, Typ); + + elsif Is_Access_Type (Typ) then + + Desig_Typ := Designated_Type (Typ); + + -- No checks necessary if expression statically null + + if Known_Null (N) then + if Can_Never_Be_Null (Typ) then + Install_Null_Excluding_Check (N); + end if; + + -- No sliding possible on access to arrays + + elsif Is_Array_Type (Desig_Typ) then + if Is_Constrained (Desig_Typ) then + Apply_Length_Check (N, Typ); + end if; + + Apply_Range_Check (N, Typ); + + elsif Has_Discriminants (Base_Type (Desig_Typ)) + and then Is_Constrained (Desig_Typ) + then + Apply_Discriminant_Check (N, Typ); + end if; + + -- Apply the 2005 Null_Excluding check. Note that we do not apply + -- this check if the constraint node is illegal, as shown by having + -- an error posted. This additional guard prevents cascaded errors + -- and compiler aborts on illegal programs involving Ada 2005 checks. + + if Can_Never_Be_Null (Typ) + and then not Can_Never_Be_Null (Etype (N)) + and then not Error_Posted (N) + then + Install_Null_Excluding_Check (N); + end if; + end if; + end Apply_Constraint_Check; + + ------------------------------ + -- Apply_Discriminant_Check -- + ------------------------------ + + procedure Apply_Discriminant_Check + (N : Node_Id; + Typ : Entity_Id; + Lhs : Node_Id := Empty) + is + Loc : constant Source_Ptr := Sloc (N); + Do_Access : constant Boolean := Is_Access_Type (Typ); + S_Typ : Entity_Id := Etype (N); + Cond : Node_Id; + T_Typ : Entity_Id; + + function Denotes_Explicit_Dereference (Obj : Node_Id) return Boolean; + -- A heap object with an indefinite subtype is constrained by its + -- initial value, and assigning to it requires a constraint_check. + -- The target may be an explicit dereference, or a renaming of one. + + function Is_Aliased_Unconstrained_Component return Boolean; + -- It is possible for an aliased component to have a nominal + -- unconstrained subtype (through instantiation). If this is a + -- discriminated component assigned in the expansion of an aggregate + -- in an initialization, the check must be suppressed. This unusual + -- situation requires a predicate of its own. + + ---------------------------------- + -- Denotes_Explicit_Dereference -- + ---------------------------------- + + function Denotes_Explicit_Dereference (Obj : Node_Id) return Boolean is + begin + return + Nkind (Obj) = N_Explicit_Dereference + or else + (Is_Entity_Name (Obj) + and then Present (Renamed_Object (Entity (Obj))) + and then Nkind (Renamed_Object (Entity (Obj))) = + N_Explicit_Dereference); + end Denotes_Explicit_Dereference; + + ---------------------------------------- + -- Is_Aliased_Unconstrained_Component -- + ---------------------------------------- + + function Is_Aliased_Unconstrained_Component return Boolean is + Comp : Entity_Id; + Pref : Node_Id; + + begin + if Nkind (Lhs) /= N_Selected_Component then + return False; + else + Comp := Entity (Selector_Name (Lhs)); + Pref := Prefix (Lhs); + end if; + + if Ekind (Comp) /= E_Component + or else not Is_Aliased (Comp) + then + return False; + end if; + + return not Comes_From_Source (Pref) + and then In_Instance + and then not Is_Constrained (Etype (Comp)); + end Is_Aliased_Unconstrained_Component; + + -- Start of processing for Apply_Discriminant_Check + + begin + if Do_Access then + T_Typ := Designated_Type (Typ); + else + T_Typ := Typ; + end if; + + -- Nothing to do if discriminant checks are suppressed or else no code + -- is to be generated + + if not Expander_Active + or else Discriminant_Checks_Suppressed (T_Typ) + then + return; + end if; + + -- No discriminant checks necessary for an access when expression is + -- statically Null. This is not only an optimization, it is fundamental + -- because otherwise discriminant checks may be generated in init procs + -- for types containing an access to a not-yet-frozen record, causing a + -- deadly forward reference. + + -- Also, if the expression is of an access type whose designated type is + -- incomplete, then the access value must be null and we suppress the + -- check. + + if Known_Null (N) then + return; + + elsif Is_Access_Type (S_Typ) then + S_Typ := Designated_Type (S_Typ); + + if Ekind (S_Typ) = E_Incomplete_Type then + return; + end if; + end if; + + -- If an assignment target is present, then we need to generate the + -- actual subtype if the target is a parameter or aliased object with + -- an unconstrained nominal subtype. + + -- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual + -- subtype to the parameter and dereference cases, since other aliased + -- objects are unconstrained (unless the nominal subtype is explicitly + -- constrained). + + if Present (Lhs) + and then (Present (Param_Entity (Lhs)) + or else (Ada_Version < Ada_2005 + and then not Is_Constrained (T_Typ) + and then Is_Aliased_View (Lhs) + and then not Is_Aliased_Unconstrained_Component) + or else (Ada_Version >= Ada_2005 + and then not Is_Constrained (T_Typ) + and then Denotes_Explicit_Dereference (Lhs) + and then Nkind (Original_Node (Lhs)) /= + N_Function_Call)) + then + T_Typ := Get_Actual_Subtype (Lhs); + end if; + + -- Nothing to do if the type is unconstrained (this is the case where + -- the actual subtype in the RM sense of N is unconstrained and no check + -- is required). + + if not Is_Constrained (T_Typ) then + return; + + -- Ada 2005: nothing to do if the type is one for which there is a + -- partial view that is constrained. + + elsif Ada_Version >= Ada_2005 + and then Has_Constrained_Partial_View (Base_Type (T_Typ)) + then + return; + end if; + + -- Nothing to do if the type is an Unchecked_Union + + if Is_Unchecked_Union (Base_Type (T_Typ)) then + return; + end if; + + -- Suppress checks if the subtypes are the same. the check must be + -- preserved in an assignment to a formal, because the constraint is + -- given by the actual. + + if Nkind (Original_Node (N)) /= N_Allocator + and then (No (Lhs) + or else not Is_Entity_Name (Lhs) + or else No (Param_Entity (Lhs))) + then + if (Etype (N) = Typ + or else (Do_Access and then Designated_Type (Typ) = S_Typ)) + and then not Is_Aliased_View (Lhs) + then + return; + end if; + + -- We can also eliminate checks on allocators with a subtype mark that + -- coincides with the context type. The context type may be a subtype + -- without a constraint (common case, a generic actual). + + elsif Nkind (Original_Node (N)) = N_Allocator + and then Is_Entity_Name (Expression (Original_Node (N))) + then + declare + Alloc_Typ : constant Entity_Id := + Entity (Expression (Original_Node (N))); + + begin + if Alloc_Typ = T_Typ + or else (Nkind (Parent (T_Typ)) = N_Subtype_Declaration + and then Is_Entity_Name ( + Subtype_Indication (Parent (T_Typ))) + and then Alloc_Typ = Base_Type (T_Typ)) + + then + return; + end if; + end; + end if; + + -- See if we have a case where the types are both constrained, and all + -- the constraints are constants. In this case, we can do the check + -- successfully at compile time. + + -- We skip this check for the case where the node is a rewritten` + -- allocator, because it already carries the context subtype, and + -- extracting the discriminants from the aggregate is messy. + + if Is_Constrained (S_Typ) + and then Nkind (Original_Node (N)) /= N_Allocator + then + declare + DconT : Elmt_Id; + Discr : Entity_Id; + DconS : Elmt_Id; + ItemS : Node_Id; + ItemT : Node_Id; + + begin + -- S_Typ may not have discriminants in the case where it is a + -- private type completed by a default discriminated type. In that + -- case, we need to get the constraints from the underlying_type. + -- If the underlying type is unconstrained (i.e. has no default + -- discriminants) no check is needed. + + if Has_Discriminants (S_Typ) then + Discr := First_Discriminant (S_Typ); + DconS := First_Elmt (Discriminant_Constraint (S_Typ)); + + else + Discr := First_Discriminant (Underlying_Type (S_Typ)); + DconS := + First_Elmt + (Discriminant_Constraint (Underlying_Type (S_Typ))); + + if No (DconS) then + return; + end if; + + -- A further optimization: if T_Typ is derived from S_Typ + -- without imposing a constraint, no check is needed. + + if Nkind (Original_Node (Parent (T_Typ))) = + N_Full_Type_Declaration + then + declare + Type_Def : constant Node_Id := + Type_Definition + (Original_Node (Parent (T_Typ))); + begin + if Nkind (Type_Def) = N_Derived_Type_Definition + and then Is_Entity_Name (Subtype_Indication (Type_Def)) + and then Entity (Subtype_Indication (Type_Def)) = S_Typ + then + return; + end if; + end; + end if; + end if; + + DconT := First_Elmt (Discriminant_Constraint (T_Typ)); + + while Present (Discr) loop + ItemS := Node (DconS); + ItemT := Node (DconT); + + -- For a discriminated component type constrained by the + -- current instance of an enclosing type, there is no + -- applicable discriminant check. + + if Nkind (ItemT) = N_Attribute_Reference + and then Is_Access_Type (Etype (ItemT)) + and then Is_Entity_Name (Prefix (ItemT)) + and then Is_Type (Entity (Prefix (ItemT))) + then + return; + end if; + + -- If the expressions for the discriminants are identical + -- and it is side-effect free (for now just an entity), + -- this may be a shared constraint, e.g. from a subtype + -- without a constraint introduced as a generic actual. + -- Examine other discriminants if any. + + if ItemS = ItemT + and then Is_Entity_Name (ItemS) + then + null; + + elsif not Is_OK_Static_Expression (ItemS) + or else not Is_OK_Static_Expression (ItemT) + then + exit; + + elsif Expr_Value (ItemS) /= Expr_Value (ItemT) then + if Do_Access then -- needs run-time check. + exit; + else + Apply_Compile_Time_Constraint_Error + (N, "incorrect value for discriminant&?", + CE_Discriminant_Check_Failed, Ent => Discr); + return; + end if; + end if; + + Next_Elmt (DconS); + Next_Elmt (DconT); + Next_Discriminant (Discr); + end loop; + + if No (Discr) then + return; + end if; + end; + end if; + + -- Here we need a discriminant check. First build the expression + -- for the comparisons of the discriminants: + + -- (n.disc1 /= typ.disc1) or else + -- (n.disc2 /= typ.disc2) or else + -- ... + -- (n.discn /= typ.discn) + + Cond := Build_Discriminant_Checks (N, T_Typ); + + -- If Lhs is set and is a parameter, then the condition is + -- guarded by: lhs'constrained and then (condition built above) + + if Present (Param_Entity (Lhs)) then + Cond := + Make_And_Then (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Param_Entity (Lhs), Loc), + Attribute_Name => Name_Constrained), + Right_Opnd => Cond); + end if; + + if Do_Access then + Cond := Guard_Access (Cond, Loc, N); + end if; + + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => Cond, + Reason => CE_Discriminant_Check_Failed)); + end Apply_Discriminant_Check; + + ------------------------ + -- Apply_Divide_Check -- + ------------------------ + + procedure Apply_Divide_Check (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + + LLB : Uint; + Llo : Uint; + Lhi : Uint; + LOK : Boolean; + Rlo : Uint; + Rhi : Uint; + ROK : Boolean; + + pragma Warnings (Off, Lhi); + -- Don't actually use this value + + begin + if Expander_Active + and then not Backend_Divide_Checks_On_Target + and then Check_Needed (Right, Division_Check) + then + Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True); + + -- See if division by zero possible, and if so generate test. This + -- part of the test is not controlled by the -gnato switch. + + if Do_Division_Check (N) then + if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => Duplicate_Subexpr_Move_Checks (Right), + Right_Opnd => Make_Integer_Literal (Loc, 0)), + Reason => CE_Divide_By_Zero)); + end if; + end if; + + -- Test for extremely annoying case of xxx'First divided by -1 + + if Do_Overflow_Check (N) then + if Nkind (N) = N_Op_Divide + and then Is_Signed_Integer_Type (Typ) + then + Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True); + LLB := Expr_Value (Type_Low_Bound (Base_Type (Typ))); + + if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi)) + and then + ((not LOK) or else (Llo = LLB)) + then + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_And_Then (Loc, + + Make_Op_Eq (Loc, + Left_Opnd => + Duplicate_Subexpr_Move_Checks (Left), + Right_Opnd => Make_Integer_Literal (Loc, LLB)), + + Make_Op_Eq (Loc, + Left_Opnd => + Duplicate_Subexpr (Right), + Right_Opnd => + Make_Integer_Literal (Loc, -1))), + Reason => CE_Overflow_Check_Failed)); + end if; + end if; + end if; + end if; + end Apply_Divide_Check; + + ---------------------------------- + -- Apply_Float_Conversion_Check -- + ---------------------------------- + + -- Let F and I be the source and target types of the conversion. The RM + -- specifies that a floating-point value X is rounded to the nearest + -- integer, with halfway cases being rounded away from zero. The rounded + -- value of X is checked against I'Range. + + -- The catch in the above paragraph is that there is no good way to know + -- whether the round-to-integer operation resulted in overflow. A remedy is + -- to perform a range check in the floating-point domain instead, however: + + -- (1) The bounds may not be known at compile time + -- (2) The check must take into account rounding or truncation. + -- (3) The range of type I may not be exactly representable in F. + -- (4) For the rounding case, The end-points I'First - 0.5 and + -- I'Last + 0.5 may or may not be in range, depending on the + -- sign of I'First and I'Last. + -- (5) X may be a NaN, which will fail any comparison + + -- The following steps correctly convert X with rounding: + + -- (1) If either I'First or I'Last is not known at compile time, use + -- I'Base instead of I in the next three steps and perform a + -- regular range check against I'Range after conversion. + -- (2) If I'First - 0.5 is representable in F then let Lo be that + -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be + -- F'Machine (I'First) and let Lo_OK be (Lo >= I'First). + -- In other words, take one of the closest floating-point numbers + -- (which is an integer value) to I'First, and see if it is in + -- range or not. + -- (3) If I'Last + 0.5 is representable in F then let Hi be that value + -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be + -- F'Machine (I'Last) and let Hi_OK be (Hi <= I'Last). + -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo) + -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi) + + -- For the truncating case, replace steps (2) and (3) as follows: + -- (2) If I'First > 0, then let Lo be F'Pred (I'First) and let Lo_OK + -- be False. Otherwise, let Lo be F'Succ (I'First - 1) and let + -- Lo_OK be True. + -- (3) If I'Last < 0, then let Hi be F'Succ (I'Last) and let Hi_OK + -- be False. Otherwise let Hi be F'Pred (I'Last + 1) and let + -- Hi_OK be False + + procedure Apply_Float_Conversion_Check + (Ck_Node : Node_Id; + Target_Typ : Entity_Id) + is + LB : constant Node_Id := Type_Low_Bound (Target_Typ); + HB : constant Node_Id := Type_High_Bound (Target_Typ); + Loc : constant Source_Ptr := Sloc (Ck_Node); + Expr_Type : constant Entity_Id := Base_Type (Etype (Ck_Node)); + Target_Base : constant Entity_Id := + Implementation_Base_Type (Target_Typ); + + Par : constant Node_Id := Parent (Ck_Node); + pragma Assert (Nkind (Par) = N_Type_Conversion); + -- Parent of check node, must be a type conversion + + Truncate : constant Boolean := Float_Truncate (Par); + Max_Bound : constant Uint := + UI_Expon + (Machine_Radix_Value (Expr_Type), + Machine_Mantissa_Value (Expr_Type) - 1) - 1; + + -- Largest bound, so bound plus or minus half is a machine number of F + + Ifirst, Ilast : Uint; + -- Bounds of integer type + + Lo, Hi : Ureal; + -- Bounds to check in floating-point domain + + Lo_OK, Hi_OK : Boolean; + -- True iff Lo resp. Hi belongs to I'Range + + Lo_Chk, Hi_Chk : Node_Id; + -- Expressions that are False iff check fails + + Reason : RT_Exception_Code; + + begin + if not Compile_Time_Known_Value (LB) + or not Compile_Time_Known_Value (HB) + then + declare + -- First check that the value falls in the range of the base type, + -- to prevent overflow during conversion and then perform a + -- regular range check against the (dynamic) bounds. + + pragma Assert (Target_Base /= Target_Typ); + + Temp : constant Entity_Id := Make_Temporary (Loc, 'T', Par); + + begin + Apply_Float_Conversion_Check (Ck_Node, Target_Base); + Set_Etype (Temp, Target_Base); + + Insert_Action (Parent (Par), + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Occurrence_Of (Target_Typ, Loc), + Expression => New_Copy_Tree (Par)), + Suppress => All_Checks); + + Insert_Action (Par, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Not_In (Loc, + Left_Opnd => New_Occurrence_Of (Temp, Loc), + Right_Opnd => New_Occurrence_Of (Target_Typ, Loc)), + Reason => CE_Range_Check_Failed)); + Rewrite (Par, New_Occurrence_Of (Temp, Loc)); + + return; + end; + end if; + + -- Get the (static) bounds of the target type + + Ifirst := Expr_Value (LB); + Ilast := Expr_Value (HB); + + -- A simple optimization: if the expression is a universal literal, + -- we can do the comparison with the bounds and the conversion to + -- an integer type statically. The range checks are unchanged. + + if Nkind (Ck_Node) = N_Real_Literal + and then Etype (Ck_Node) = Universal_Real + and then Is_Integer_Type (Target_Typ) + and then Nkind (Parent (Ck_Node)) = N_Type_Conversion + then + declare + Int_Val : constant Uint := UR_To_Uint (Realval (Ck_Node)); + + begin + if Int_Val <= Ilast and then Int_Val >= Ifirst then + + -- Conversion is safe + + Rewrite (Parent (Ck_Node), + Make_Integer_Literal (Loc, UI_To_Int (Int_Val))); + Analyze_And_Resolve (Parent (Ck_Node), Target_Typ); + return; + end if; + end; + end if; + + -- Check against lower bound + + if Truncate and then Ifirst > 0 then + Lo := Pred (Expr_Type, UR_From_Uint (Ifirst)); + Lo_OK := False; + + elsif Truncate then + Lo := Succ (Expr_Type, UR_From_Uint (Ifirst - 1)); + Lo_OK := True; + + elsif abs (Ifirst) < Max_Bound then + Lo := UR_From_Uint (Ifirst) - Ureal_Half; + Lo_OK := (Ifirst > 0); + + else + Lo := Machine (Expr_Type, UR_From_Uint (Ifirst), Round_Even, Ck_Node); + Lo_OK := (Lo >= UR_From_Uint (Ifirst)); + end if; + + if Lo_OK then + + -- Lo_Chk := (X >= Lo) + + Lo_Chk := Make_Op_Ge (Loc, + Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node), + Right_Opnd => Make_Real_Literal (Loc, Lo)); + + else + -- Lo_Chk := (X > Lo) + + Lo_Chk := Make_Op_Gt (Loc, + Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node), + Right_Opnd => Make_Real_Literal (Loc, Lo)); + end if; + + -- Check against higher bound + + if Truncate and then Ilast < 0 then + Hi := Succ (Expr_Type, UR_From_Uint (Ilast)); + Lo_OK := False; + + elsif Truncate then + Hi := Pred (Expr_Type, UR_From_Uint (Ilast + 1)); + Hi_OK := True; + + elsif abs (Ilast) < Max_Bound then + Hi := UR_From_Uint (Ilast) + Ureal_Half; + Hi_OK := (Ilast < 0); + else + Hi := Machine (Expr_Type, UR_From_Uint (Ilast), Round_Even, Ck_Node); + Hi_OK := (Hi <= UR_From_Uint (Ilast)); + end if; + + if Hi_OK then + + -- Hi_Chk := (X <= Hi) + + Hi_Chk := Make_Op_Le (Loc, + Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node), + Right_Opnd => Make_Real_Literal (Loc, Hi)); + + else + -- Hi_Chk := (X < Hi) + + Hi_Chk := Make_Op_Lt (Loc, + Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node), + Right_Opnd => Make_Real_Literal (Loc, Hi)); + end if; + + -- If the bounds of the target type are the same as those of the base + -- type, the check is an overflow check as a range check is not + -- performed in these cases. + + if Expr_Value (Type_Low_Bound (Target_Base)) = Ifirst + and then Expr_Value (Type_High_Bound (Target_Base)) = Ilast + then + Reason := CE_Overflow_Check_Failed; + else + Reason := CE_Range_Check_Failed; + end if; + + -- Raise CE if either conditions does not hold + + Insert_Action (Ck_Node, + Make_Raise_Constraint_Error (Loc, + Condition => Make_Op_Not (Loc, Make_And_Then (Loc, Lo_Chk, Hi_Chk)), + Reason => Reason)); + end Apply_Float_Conversion_Check; + + ------------------------ + -- Apply_Length_Check -- + ------------------------ + + procedure Apply_Length_Check + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty) + is + begin + Apply_Selected_Length_Checks + (Ck_Node, Target_Typ, Source_Typ, Do_Static => False); + end Apply_Length_Check; + + --------------------------- + -- Apply_Predicate_Check -- + --------------------------- + + procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id) is + begin + if Present (Predicate_Function (Typ)) then + Insert_Action (N, + Make_Predicate_Check (Typ, Duplicate_Subexpr (N))); + end if; + end Apply_Predicate_Check; + + ----------------------- + -- Apply_Range_Check -- + ----------------------- + + procedure Apply_Range_Check + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty) + is + begin + Apply_Selected_Range_Checks + (Ck_Node, Target_Typ, Source_Typ, Do_Static => False); + end Apply_Range_Check; + + ------------------------------ + -- Apply_Scalar_Range_Check -- + ------------------------------ + + -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check flag + -- off if it is already set on. + + procedure Apply_Scalar_Range_Check + (Expr : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty; + Fixed_Int : Boolean := False) + is + Parnt : constant Node_Id := Parent (Expr); + S_Typ : Entity_Id; + Arr : Node_Id := Empty; -- initialize to prevent warning + Arr_Typ : Entity_Id := Empty; -- initialize to prevent warning + OK : Boolean; + + Is_Subscr_Ref : Boolean; + -- Set true if Expr is a subscript + + Is_Unconstrained_Subscr_Ref : Boolean; + -- Set true if Expr is a subscript of an unconstrained array. In this + -- case we do not attempt to do an analysis of the value against the + -- range of the subscript, since we don't know the actual subtype. + + Int_Real : Boolean; + -- Set to True if Expr should be regarded as a real value even though + -- the type of Expr might be discrete. + + procedure Bad_Value; + -- Procedure called if value is determined to be out of range + + --------------- + -- Bad_Value -- + --------------- + + procedure Bad_Value is + begin + Apply_Compile_Time_Constraint_Error + (Expr, "value not in range of}?", CE_Range_Check_Failed, + Ent => Target_Typ, + Typ => Target_Typ); + end Bad_Value; + + -- Start of processing for Apply_Scalar_Range_Check + + begin + -- Return if check obviously not needed + + if + -- Not needed inside generic + + Inside_A_Generic + + -- Not needed if previous error + + or else Target_Typ = Any_Type + or else Nkind (Expr) = N_Error + + -- Not needed for non-scalar type + + or else not Is_Scalar_Type (Target_Typ) + + -- Not needed if we know node raises CE already + + or else Raises_Constraint_Error (Expr) + then + return; + end if; + + -- Now, see if checks are suppressed + + Is_Subscr_Ref := + Is_List_Member (Expr) and then Nkind (Parnt) = N_Indexed_Component; + + if Is_Subscr_Ref then + Arr := Prefix (Parnt); + Arr_Typ := Get_Actual_Subtype_If_Available (Arr); + end if; + + if not Do_Range_Check (Expr) then + + -- Subscript reference. Check for Index_Checks suppressed + + if Is_Subscr_Ref then + + -- Check array type and its base type + + if Index_Checks_Suppressed (Arr_Typ) + or else Index_Checks_Suppressed (Base_Type (Arr_Typ)) + then + return; + + -- Check array itself if it is an entity name + + elsif Is_Entity_Name (Arr) + and then Index_Checks_Suppressed (Entity (Arr)) + then + return; + + -- Check expression itself if it is an entity name + + elsif Is_Entity_Name (Expr) + and then Index_Checks_Suppressed (Entity (Expr)) + then + return; + end if; + + -- All other cases, check for Range_Checks suppressed + + else + -- Check target type and its base type + + if Range_Checks_Suppressed (Target_Typ) + or else Range_Checks_Suppressed (Base_Type (Target_Typ)) + then + return; + + -- Check expression itself if it is an entity name + + elsif Is_Entity_Name (Expr) + and then Range_Checks_Suppressed (Entity (Expr)) + then + return; + + -- If Expr is part of an assignment statement, then check left + -- side of assignment if it is an entity name. + + elsif Nkind (Parnt) = N_Assignment_Statement + and then Is_Entity_Name (Name (Parnt)) + and then Range_Checks_Suppressed (Entity (Name (Parnt))) + then + return; + end if; + end if; + end if; + + -- Do not set range checks if they are killed + + if Nkind (Expr) = N_Unchecked_Type_Conversion + and then Kill_Range_Check (Expr) + then + return; + end if; + + -- Do not set range checks for any values from System.Scalar_Values + -- since the whole idea of such values is to avoid checking them! + + if Is_Entity_Name (Expr) + and then Is_RTU (Scope (Entity (Expr)), System_Scalar_Values) + then + return; + end if; + + -- Now see if we need a check + + if No (Source_Typ) then + S_Typ := Etype (Expr); + else + S_Typ := Source_Typ; + end if; + + if not Is_Scalar_Type (S_Typ) or else S_Typ = Any_Type then + return; + end if; + + Is_Unconstrained_Subscr_Ref := + Is_Subscr_Ref and then not Is_Constrained (Arr_Typ); + + -- Always do a range check if the source type includes infinities and + -- the target type does not include infinities. We do not do this if + -- range checks are killed. + + if Is_Floating_Point_Type (S_Typ) + and then Has_Infinities (S_Typ) + and then not Has_Infinities (Target_Typ) + then + Enable_Range_Check (Expr); + end if; + + -- Return if we know expression is definitely in the range of the target + -- type as determined by Determine_Range. Right now we only do this for + -- discrete types, and not fixed-point or floating-point types. + + -- The additional less-precise tests below catch these cases + + -- Note: skip this if we are given a source_typ, since the point of + -- supplying a Source_Typ is to stop us looking at the expression. + -- We could sharpen this test to be out parameters only ??? + + if Is_Discrete_Type (Target_Typ) + and then Is_Discrete_Type (Etype (Expr)) + and then not Is_Unconstrained_Subscr_Ref + and then No (Source_Typ) + then + declare + Tlo : constant Node_Id := Type_Low_Bound (Target_Typ); + Thi : constant Node_Id := Type_High_Bound (Target_Typ); + Lo : Uint; + Hi : Uint; + + begin + if Compile_Time_Known_Value (Tlo) + and then Compile_Time_Known_Value (Thi) + then + declare + Lov : constant Uint := Expr_Value (Tlo); + Hiv : constant Uint := Expr_Value (Thi); + + begin + -- If range is null, we for sure have a constraint error + -- (we don't even need to look at the value involved, + -- since all possible values will raise CE). + + if Lov > Hiv then + Bad_Value; + return; + end if; + + -- Otherwise determine range of value + + Determine_Range (Expr, OK, Lo, Hi, Assume_Valid => True); + + if OK then + + -- If definitely in range, all OK + + if Lo >= Lov and then Hi <= Hiv then + return; + + -- If definitely not in range, warn + + elsif Lov > Hi or else Hiv < Lo then + Bad_Value; + return; + + -- Otherwise we don't know + + else + null; + end if; + end if; + end; + end if; + end; + end if; + + Int_Real := + Is_Floating_Point_Type (S_Typ) + or else (Is_Fixed_Point_Type (S_Typ) and then not Fixed_Int); + + -- Check if we can determine at compile time whether Expr is in the + -- range of the target type. Note that if S_Typ is within the bounds + -- of Target_Typ then this must be the case. This check is meaningful + -- only if this is not a conversion between integer and real types. + + if not Is_Unconstrained_Subscr_Ref + and then + Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ) + and then + (In_Subrange_Of (S_Typ, Target_Typ, Fixed_Int) + or else + Is_In_Range (Expr, Target_Typ, + Assume_Valid => True, + Fixed_Int => Fixed_Int, + Int_Real => Int_Real)) + then + return; + + elsif Is_Out_Of_Range (Expr, Target_Typ, + Assume_Valid => True, + Fixed_Int => Fixed_Int, + Int_Real => Int_Real) + then + Bad_Value; + return; + + -- In the floating-point case, we only do range checks if the type is + -- constrained. We definitely do NOT want range checks for unconstrained + -- types, since we want to have infinities + + elsif Is_Floating_Point_Type (S_Typ) then + if Is_Constrained (S_Typ) then + Enable_Range_Check (Expr); + end if; + + -- For all other cases we enable a range check unconditionally + + else + Enable_Range_Check (Expr); + return; + end if; + end Apply_Scalar_Range_Check; + + ---------------------------------- + -- Apply_Selected_Length_Checks -- + ---------------------------------- + + procedure Apply_Selected_Length_Checks + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id; + Do_Static : Boolean) + is + Cond : Node_Id; + R_Result : Check_Result; + R_Cno : Node_Id; + + Loc : constant Source_Ptr := Sloc (Ck_Node); + Checks_On : constant Boolean := + (not Index_Checks_Suppressed (Target_Typ)) + or else + (not Length_Checks_Suppressed (Target_Typ)); + + begin + if not Expander_Active then + return; + end if; + + R_Result := + Selected_Length_Checks (Ck_Node, Target_Typ, Source_Typ, Empty); + + for J in 1 .. 2 loop + R_Cno := R_Result (J); + exit when No (R_Cno); + + -- A length check may mention an Itype which is attached to a + -- subsequent node. At the top level in a package this can cause + -- an order-of-elaboration problem, so we make sure that the itype + -- is referenced now. + + if Ekind (Current_Scope) = E_Package + and then Is_Compilation_Unit (Current_Scope) + then + Ensure_Defined (Target_Typ, Ck_Node); + + if Present (Source_Typ) then + Ensure_Defined (Source_Typ, Ck_Node); + + elsif Is_Itype (Etype (Ck_Node)) then + Ensure_Defined (Etype (Ck_Node), Ck_Node); + end if; + end if; + + -- If the item is a conditional raise of constraint error, then have + -- a look at what check is being performed and ??? + + if Nkind (R_Cno) = N_Raise_Constraint_Error + and then Present (Condition (R_Cno)) + then + Cond := Condition (R_Cno); + + -- Case where node does not now have a dynamic check + + if not Has_Dynamic_Length_Check (Ck_Node) then + + -- If checks are on, just insert the check + + if Checks_On then + Insert_Action (Ck_Node, R_Cno); + + if not Do_Static then + Set_Has_Dynamic_Length_Check (Ck_Node); + end if; + + -- If checks are off, then analyze the length check after + -- temporarily attaching it to the tree in case the relevant + -- condition can be evaluated at compile time. We still want a + -- compile time warning in this case. + + else + Set_Parent (R_Cno, Ck_Node); + Analyze (R_Cno); + end if; + end if; + + -- Output a warning if the condition is known to be True + + if Is_Entity_Name (Cond) + and then Entity (Cond) = Standard_True + then + Apply_Compile_Time_Constraint_Error + (Ck_Node, "wrong length for array of}?", + CE_Length_Check_Failed, + Ent => Target_Typ, + Typ => Target_Typ); + + -- If we were only doing a static check, or if checks are not + -- on, then we want to delete the check, since it is not needed. + -- We do this by replacing the if statement by a null statement + + elsif Do_Static or else not Checks_On then + Remove_Warning_Messages (R_Cno); + Rewrite (R_Cno, Make_Null_Statement (Loc)); + end if; + + else + Install_Static_Check (R_Cno, Loc); + end if; + end loop; + end Apply_Selected_Length_Checks; + + --------------------------------- + -- Apply_Selected_Range_Checks -- + --------------------------------- + + procedure Apply_Selected_Range_Checks + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id; + Do_Static : Boolean) + is + Cond : Node_Id; + R_Result : Check_Result; + R_Cno : Node_Id; + + Loc : constant Source_Ptr := Sloc (Ck_Node); + Checks_On : constant Boolean := + (not Index_Checks_Suppressed (Target_Typ)) + or else + (not Range_Checks_Suppressed (Target_Typ)); + + begin + if not Expander_Active or else not Checks_On then + return; + end if; + + R_Result := + Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Empty); + + for J in 1 .. 2 loop + + R_Cno := R_Result (J); + exit when No (R_Cno); + + -- If the item is a conditional raise of constraint error, then have + -- a look at what check is being performed and ??? + + if Nkind (R_Cno) = N_Raise_Constraint_Error + and then Present (Condition (R_Cno)) + then + Cond := Condition (R_Cno); + + if not Has_Dynamic_Range_Check (Ck_Node) then + Insert_Action (Ck_Node, R_Cno); + + if not Do_Static then + Set_Has_Dynamic_Range_Check (Ck_Node); + end if; + end if; + + -- Output a warning if the condition is known to be True + + if Is_Entity_Name (Cond) + and then Entity (Cond) = Standard_True + then + -- Since an N_Range is technically not an expression, we have + -- to set one of the bounds to C_E and then just flag the + -- N_Range. The warning message will point to the lower bound + -- and complain about a range, which seems OK. + + if Nkind (Ck_Node) = N_Range then + Apply_Compile_Time_Constraint_Error + (Low_Bound (Ck_Node), "static range out of bounds of}?", + CE_Range_Check_Failed, + Ent => Target_Typ, + Typ => Target_Typ); + + Set_Raises_Constraint_Error (Ck_Node); + + else + Apply_Compile_Time_Constraint_Error + (Ck_Node, "static value out of range of}?", + CE_Range_Check_Failed, + Ent => Target_Typ, + Typ => Target_Typ); + end if; + + -- If we were only doing a static check, or if checks are not + -- on, then we want to delete the check, since it is not needed. + -- We do this by replacing the if statement by a null statement + + elsif Do_Static or else not Checks_On then + Remove_Warning_Messages (R_Cno); + Rewrite (R_Cno, Make_Null_Statement (Loc)); + end if; + + else + Install_Static_Check (R_Cno, Loc); + end if; + end loop; + end Apply_Selected_Range_Checks; + + ------------------------------- + -- Apply_Static_Length_Check -- + ------------------------------- + + procedure Apply_Static_Length_Check + (Expr : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty) + is + begin + Apply_Selected_Length_Checks + (Expr, Target_Typ, Source_Typ, Do_Static => True); + end Apply_Static_Length_Check; + + ------------------------------------- + -- Apply_Subscript_Validity_Checks -- + ------------------------------------- + + procedure Apply_Subscript_Validity_Checks (Expr : Node_Id) is + Sub : Node_Id; + + begin + pragma Assert (Nkind (Expr) = N_Indexed_Component); + + -- Loop through subscripts + + Sub := First (Expressions (Expr)); + while Present (Sub) loop + + -- Check one subscript. Note that we do not worry about enumeration + -- type with holes, since we will convert the value to a Pos value + -- for the subscript, and that convert will do the necessary validity + -- check. + + Ensure_Valid (Sub, Holes_OK => True); + + -- Move to next subscript + + Sub := Next (Sub); + end loop; + end Apply_Subscript_Validity_Checks; + + ---------------------------------- + -- Apply_Type_Conversion_Checks -- + ---------------------------------- + + procedure Apply_Type_Conversion_Checks (N : Node_Id) is + Target_Type : constant Entity_Id := Etype (N); + Target_Base : constant Entity_Id := Base_Type (Target_Type); + Expr : constant Node_Id := Expression (N); + Expr_Type : constant Entity_Id := Etype (Expr); + + begin + if Inside_A_Generic then + return; + + -- Skip these checks if serious errors detected, there are some nasty + -- situations of incomplete trees that blow things up. + + elsif Serious_Errors_Detected > 0 then + return; + + -- Scalar type conversions of the form Target_Type (Expr) require a + -- range check if we cannot be sure that Expr is in the base type of + -- Target_Typ and also that Expr is in the range of Target_Typ. These + -- are not quite the same condition from an implementation point of + -- view, but clearly the second includes the first. + + elsif Is_Scalar_Type (Target_Type) then + declare + Conv_OK : constant Boolean := Conversion_OK (N); + -- If the Conversion_OK flag on the type conversion is set and no + -- floating point type is involved in the type conversion then + -- fixed point values must be read as integral values. + + Float_To_Int : constant Boolean := + Is_Floating_Point_Type (Expr_Type) + and then Is_Integer_Type (Target_Type); + + begin + if not Overflow_Checks_Suppressed (Target_Base) + and then not + In_Subrange_Of (Expr_Type, Target_Base, Fixed_Int => Conv_OK) + and then not Float_To_Int + then + Activate_Overflow_Check (N); + end if; + + if not Range_Checks_Suppressed (Target_Type) + and then not Range_Checks_Suppressed (Expr_Type) + then + if Float_To_Int then + Apply_Float_Conversion_Check (Expr, Target_Type); + else + Apply_Scalar_Range_Check + (Expr, Target_Type, Fixed_Int => Conv_OK); + end if; + end if; + end; + + elsif Comes_From_Source (N) + and then not Discriminant_Checks_Suppressed (Target_Type) + and then Is_Record_Type (Target_Type) + and then Is_Derived_Type (Target_Type) + and then not Is_Tagged_Type (Target_Type) + and then not Is_Constrained (Target_Type) + and then Present (Stored_Constraint (Target_Type)) + then + -- An unconstrained derived type may have inherited discriminant + -- Build an actual discriminant constraint list using the stored + -- constraint, to verify that the expression of the parent type + -- satisfies the constraints imposed by the (unconstrained!) + -- derived type. This applies to value conversions, not to view + -- conversions of tagged types. + + declare + Loc : constant Source_Ptr := Sloc (N); + Cond : Node_Id; + Constraint : Elmt_Id; + Discr_Value : Node_Id; + Discr : Entity_Id; + + New_Constraints : constant Elist_Id := New_Elmt_List; + Old_Constraints : constant Elist_Id := + Discriminant_Constraint (Expr_Type); + + begin + Constraint := First_Elmt (Stored_Constraint (Target_Type)); + while Present (Constraint) loop + Discr_Value := Node (Constraint); + + if Is_Entity_Name (Discr_Value) + and then Ekind (Entity (Discr_Value)) = E_Discriminant + then + Discr := Corresponding_Discriminant (Entity (Discr_Value)); + + if Present (Discr) + and then Scope (Discr) = Base_Type (Expr_Type) + then + -- Parent is constrained by new discriminant. Obtain + -- Value of original discriminant in expression. If the + -- new discriminant has been used to constrain more than + -- one of the stored discriminants, this will provide the + -- required consistency check. + + Append_Elmt + (Make_Selected_Component (Loc, + Prefix => + Duplicate_Subexpr_No_Checks + (Expr, Name_Req => True), + Selector_Name => + Make_Identifier (Loc, Chars (Discr))), + New_Constraints); + + else + -- Discriminant of more remote ancestor ??? + + return; + end if; + + -- Derived type definition has an explicit value for this + -- stored discriminant. + + else + Append_Elmt + (Duplicate_Subexpr_No_Checks (Discr_Value), + New_Constraints); + end if; + + Next_Elmt (Constraint); + end loop; + + -- Use the unconstrained expression type to retrieve the + -- discriminants of the parent, and apply momentarily the + -- discriminant constraint synthesized above. + + Set_Discriminant_Constraint (Expr_Type, New_Constraints); + Cond := Build_Discriminant_Checks (Expr, Expr_Type); + Set_Discriminant_Constraint (Expr_Type, Old_Constraints); + + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => Cond, + Reason => CE_Discriminant_Check_Failed)); + end; + + -- For arrays, conversions are applied during expansion, to take into + -- accounts changes of representation. The checks become range checks on + -- the base type or length checks on the subtype, depending on whether + -- the target type is unconstrained or constrained. + + else + null; + end if; + end Apply_Type_Conversion_Checks; + + ---------------------------------------------- + -- Apply_Universal_Integer_Attribute_Checks -- + ---------------------------------------------- + + procedure Apply_Universal_Integer_Attribute_Checks (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + + begin + if Inside_A_Generic then + return; + + -- Nothing to do if checks are suppressed + + elsif Range_Checks_Suppressed (Typ) + and then Overflow_Checks_Suppressed (Typ) + then + return; + + -- Nothing to do if the attribute does not come from source. The + -- internal attributes we generate of this type do not need checks, + -- and furthermore the attempt to check them causes some circular + -- elaboration orders when dealing with packed types. + + elsif not Comes_From_Source (N) then + return; + + -- If the prefix is a selected component that depends on a discriminant + -- the check may improperly expose a discriminant instead of using + -- the bounds of the object itself. Set the type of the attribute to + -- the base type of the context, so that a check will be imposed when + -- needed (e.g. if the node appears as an index). + + elsif Nkind (Prefix (N)) = N_Selected_Component + and then Ekind (Typ) = E_Signed_Integer_Subtype + and then Depends_On_Discriminant (Scalar_Range (Typ)) + then + Set_Etype (N, Base_Type (Typ)); + + -- Otherwise, replace the attribute node with a type conversion node + -- whose expression is the attribute, retyped to universal integer, and + -- whose subtype mark is the target type. The call to analyze this + -- conversion will set range and overflow checks as required for proper + -- detection of an out of range value. + + else + Set_Etype (N, Universal_Integer); + Set_Analyzed (N, True); + + Rewrite (N, + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (N))); + + Analyze_And_Resolve (N, Typ); + return; + end if; + end Apply_Universal_Integer_Attribute_Checks; + + ------------------------------- + -- Build_Discriminant_Checks -- + ------------------------------- + + function Build_Discriminant_Checks + (N : Node_Id; + T_Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Cond : Node_Id; + Disc : Elmt_Id; + Disc_Ent : Entity_Id; + Dref : Node_Id; + Dval : Node_Id; + + function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id; + + ---------------------------------- + -- Aggregate_Discriminant_Value -- + ---------------------------------- + + function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id is + Assoc : Node_Id; + + begin + -- The aggregate has been normalized with named associations. We use + -- the Chars field to locate the discriminant to take into account + -- discriminants in derived types, which carry the same name as those + -- in the parent. + + Assoc := First (Component_Associations (N)); + while Present (Assoc) loop + if Chars (First (Choices (Assoc))) = Chars (Disc) then + return Expression (Assoc); + else + Next (Assoc); + end if; + end loop; + + -- Discriminant must have been found in the loop above + + raise Program_Error; + end Aggregate_Discriminant_Val; + + -- Start of processing for Build_Discriminant_Checks + + begin + -- Loop through discriminants evolving the condition + + Cond := Empty; + Disc := First_Elmt (Discriminant_Constraint (T_Typ)); + + -- For a fully private type, use the discriminants of the parent type + + if Is_Private_Type (T_Typ) + and then No (Full_View (T_Typ)) + then + Disc_Ent := First_Discriminant (Etype (Base_Type (T_Typ))); + else + Disc_Ent := First_Discriminant (T_Typ); + end if; + + while Present (Disc) loop + Dval := Node (Disc); + + if Nkind (Dval) = N_Identifier + and then Ekind (Entity (Dval)) = E_Discriminant + then + Dval := New_Occurrence_Of (Discriminal (Entity (Dval)), Loc); + else + Dval := Duplicate_Subexpr_No_Checks (Dval); + end if; + + -- If we have an Unchecked_Union node, we can infer the discriminants + -- of the node. + + if Is_Unchecked_Union (Base_Type (T_Typ)) then + Dref := New_Copy ( + Get_Discriminant_Value ( + First_Discriminant (T_Typ), + T_Typ, + Stored_Constraint (T_Typ))); + + elsif Nkind (N) = N_Aggregate then + Dref := + Duplicate_Subexpr_No_Checks + (Aggregate_Discriminant_Val (Disc_Ent)); + + else + Dref := + Make_Selected_Component (Loc, + Prefix => + Duplicate_Subexpr_No_Checks (N, Name_Req => True), + Selector_Name => + Make_Identifier (Loc, Chars (Disc_Ent))); + + Set_Is_In_Discriminant_Check (Dref); + end if; + + Evolve_Or_Else (Cond, + Make_Op_Ne (Loc, + Left_Opnd => Dref, + Right_Opnd => Dval)); + + Next_Elmt (Disc); + Next_Discriminant (Disc_Ent); + end loop; + + return Cond; + end Build_Discriminant_Checks; + + ------------------ + -- Check_Needed -- + ------------------ + + function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean is + N : Node_Id; + P : Node_Id; + K : Node_Kind; + L : Node_Id; + R : Node_Id; + + begin + -- Always check if not simple entity + + if Nkind (Nod) not in N_Has_Entity + or else not Comes_From_Source (Nod) + then + return True; + end if; + + -- Look up tree for short circuit + + N := Nod; + loop + P := Parent (N); + K := Nkind (P); + + -- Done if out of subexpression (note that we allow generated stuff + -- such as itype declarations in this context, to keep the loop going + -- since we may well have generated such stuff in complex situations. + -- Also done if no parent (probably an error condition, but no point + -- in behaving nasty if we find it!) + + if No (P) + or else (K not in N_Subexpr and then Comes_From_Source (P)) + then + return True; + + -- Or/Or Else case, where test is part of the right operand, or is + -- part of one of the actions associated with the right operand, and + -- the left operand is an equality test. + + elsif K = N_Op_Or then + exit when N = Right_Opnd (P) + and then Nkind (Left_Opnd (P)) = N_Op_Eq; + + elsif K = N_Or_Else then + exit when (N = Right_Opnd (P) + or else + (Is_List_Member (N) + and then List_Containing (N) = Actions (P))) + and then Nkind (Left_Opnd (P)) = N_Op_Eq; + + -- Similar test for the And/And then case, where the left operand + -- is an inequality test. + + elsif K = N_Op_And then + exit when N = Right_Opnd (P) + and then Nkind (Left_Opnd (P)) = N_Op_Ne; + + elsif K = N_And_Then then + exit when (N = Right_Opnd (P) + or else + (Is_List_Member (N) + and then List_Containing (N) = Actions (P))) + and then Nkind (Left_Opnd (P)) = N_Op_Ne; + end if; + + N := P; + end loop; + + -- If we fall through the loop, then we have a conditional with an + -- appropriate test as its left operand. So test further. + + L := Left_Opnd (P); + R := Right_Opnd (L); + L := Left_Opnd (L); + + -- Left operand of test must match original variable + + if Nkind (L) not in N_Has_Entity + or else Entity (L) /= Entity (Nod) + then + return True; + end if; + + -- Right operand of test must be key value (zero or null) + + case Check is + when Access_Check => + if not Known_Null (R) then + return True; + end if; + + when Division_Check => + if not Compile_Time_Known_Value (R) + or else Expr_Value (R) /= Uint_0 + then + return True; + end if; + + when others => + raise Program_Error; + end case; + + -- Here we have the optimizable case, warn if not short-circuited + + if K = N_Op_And or else K = N_Op_Or then + case Check is + when Access_Check => + Error_Msg_N + ("Constraint_Error may be raised (access check)?", + Parent (Nod)); + when Division_Check => + Error_Msg_N + ("Constraint_Error may be raised (zero divide)?", + Parent (Nod)); + + when others => + raise Program_Error; + end case; + + if K = N_Op_And then + Error_Msg_N -- CODEFIX + ("use `AND THEN` instead of AND?", P); + else + Error_Msg_N -- CODEFIX + ("use `OR ELSE` instead of OR?", P); + end if; + + -- If not short-circuited, we need the check + + return True; + + -- If short-circuited, we can omit the check + + else + return False; + end if; + end Check_Needed; + + ----------------------------------- + -- Check_Valid_Lvalue_Subscripts -- + ----------------------------------- + + procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id) is + begin + -- Skip this if range checks are suppressed + + if Range_Checks_Suppressed (Etype (Expr)) then + return; + + -- Only do this check for expressions that come from source. We assume + -- that expander generated assignments explicitly include any necessary + -- checks. Note that this is not just an optimization, it avoids + -- infinite recursions! + + elsif not Comes_From_Source (Expr) then + return; + + -- For a selected component, check the prefix + + elsif Nkind (Expr) = N_Selected_Component then + Check_Valid_Lvalue_Subscripts (Prefix (Expr)); + return; + + -- Case of indexed component + + elsif Nkind (Expr) = N_Indexed_Component then + Apply_Subscript_Validity_Checks (Expr); + + -- Prefix may itself be or contain an indexed component, and these + -- subscripts need checking as well. + + Check_Valid_Lvalue_Subscripts (Prefix (Expr)); + end if; + end Check_Valid_Lvalue_Subscripts; + + ---------------------------------- + -- Null_Exclusion_Static_Checks -- + ---------------------------------- + + procedure Null_Exclusion_Static_Checks (N : Node_Id) is + Error_Node : Node_Id; + Expr : Node_Id; + Has_Null : constant Boolean := Has_Null_Exclusion (N); + K : constant Node_Kind := Nkind (N); + Typ : Entity_Id; + + begin + pragma Assert + (K = N_Component_Declaration + or else K = N_Discriminant_Specification + or else K = N_Function_Specification + or else K = N_Object_Declaration + or else K = N_Parameter_Specification); + + if K = N_Function_Specification then + Typ := Etype (Defining_Entity (N)); + else + Typ := Etype (Defining_Identifier (N)); + end if; + + case K is + when N_Component_Declaration => + if Present (Access_Definition (Component_Definition (N))) then + Error_Node := Component_Definition (N); + else + Error_Node := Subtype_Indication (Component_Definition (N)); + end if; + + when N_Discriminant_Specification => + Error_Node := Discriminant_Type (N); + + when N_Function_Specification => + Error_Node := Result_Definition (N); + + when N_Object_Declaration => + Error_Node := Object_Definition (N); + + when N_Parameter_Specification => + Error_Node := Parameter_Type (N); + + when others => + raise Program_Error; + end case; + + if Has_Null then + + -- Enforce legality rule 3.10 (13): A null exclusion can only be + -- applied to an access [sub]type. + + if not Is_Access_Type (Typ) then + Error_Msg_N + ("`NOT NULL` allowed only for an access type", Error_Node); + + -- Enforce legality rule RM 3.10(14/1): A null exclusion can only + -- be applied to a [sub]type that does not exclude null already. + + elsif Can_Never_Be_Null (Typ) + and then Comes_From_Source (Typ) + then + Error_Msg_NE + ("`NOT NULL` not allowed (& already excludes null)", + Error_Node, Typ); + end if; + end if; + + -- Check that null-excluding objects are always initialized, except for + -- deferred constants, for which the expression will appear in the full + -- declaration. + + if K = N_Object_Declaration + and then No (Expression (N)) + and then not Constant_Present (N) + and then not No_Initialization (N) + then + -- Add an expression that assigns null. This node is needed by + -- Apply_Compile_Time_Constraint_Error, which will replace this with + -- a Constraint_Error node. + + Set_Expression (N, Make_Null (Sloc (N))); + Set_Etype (Expression (N), Etype (Defining_Identifier (N))); + + Apply_Compile_Time_Constraint_Error + (N => Expression (N), + Msg => "(Ada 2005) null-excluding objects must be initialized?", + Reason => CE_Null_Not_Allowed); + end if; + + -- Check that a null-excluding component, formal or object is not being + -- assigned a null value. Otherwise generate a warning message and + -- replace Expression (N) by an N_Constraint_Error node. + + if K /= N_Function_Specification then + Expr := Expression (N); + + if Present (Expr) and then Known_Null (Expr) then + case K is + when N_Component_Declaration | + N_Discriminant_Specification => + Apply_Compile_Time_Constraint_Error + (N => Expr, + Msg => "(Ada 2005) null not allowed " & + "in null-excluding components?", + Reason => CE_Null_Not_Allowed); + + when N_Object_Declaration => + Apply_Compile_Time_Constraint_Error + (N => Expr, + Msg => "(Ada 2005) null not allowed " & + "in null-excluding objects?", + Reason => CE_Null_Not_Allowed); + + when N_Parameter_Specification => + Apply_Compile_Time_Constraint_Error + (N => Expr, + Msg => "(Ada 2005) null not allowed " & + "in null-excluding formals?", + Reason => CE_Null_Not_Allowed); + + when others => + null; + end case; + end if; + end if; + end Null_Exclusion_Static_Checks; + + ---------------------------------- + -- Conditional_Statements_Begin -- + ---------------------------------- + + procedure Conditional_Statements_Begin is + begin + Saved_Checks_TOS := Saved_Checks_TOS + 1; + + -- If stack overflows, kill all checks, that way we know to simply reset + -- the number of saved checks to zero on return. This should never occur + -- in practice. + + if Saved_Checks_TOS > Saved_Checks_Stack'Last then + Kill_All_Checks; + + -- In the normal case, we just make a new stack entry saving the current + -- number of saved checks for a later restore. + + else + Saved_Checks_Stack (Saved_Checks_TOS) := Num_Saved_Checks; + + if Debug_Flag_CC then + w ("Conditional_Statements_Begin: Num_Saved_Checks = ", + Num_Saved_Checks); + end if; + end if; + end Conditional_Statements_Begin; + + -------------------------------- + -- Conditional_Statements_End -- + -------------------------------- + + procedure Conditional_Statements_End is + begin + pragma Assert (Saved_Checks_TOS > 0); + + -- If the saved checks stack overflowed, then we killed all checks, so + -- setting the number of saved checks back to zero is correct. This + -- should never occur in practice. + + if Saved_Checks_TOS > Saved_Checks_Stack'Last then + Num_Saved_Checks := 0; + + -- In the normal case, restore the number of saved checks from the top + -- stack entry. + + else + Num_Saved_Checks := Saved_Checks_Stack (Saved_Checks_TOS); + if Debug_Flag_CC then + w ("Conditional_Statements_End: Num_Saved_Checks = ", + Num_Saved_Checks); + end if; + end if; + + Saved_Checks_TOS := Saved_Checks_TOS - 1; + end Conditional_Statements_End; + + --------------------- + -- Determine_Range -- + --------------------- + + Cache_Size : constant := 2 ** 10; + type Cache_Index is range 0 .. Cache_Size - 1; + -- Determine size of below cache (power of 2 is more efficient!) + + Determine_Range_Cache_N : array (Cache_Index) of Node_Id; + Determine_Range_Cache_V : array (Cache_Index) of Boolean; + Determine_Range_Cache_Lo : array (Cache_Index) of Uint; + Determine_Range_Cache_Hi : array (Cache_Index) of Uint; + -- The above arrays are used to implement a small direct cache for + -- Determine_Range calls. Because of the way Determine_Range recursively + -- traces subexpressions, and because overflow checking calls the routine + -- on the way up the tree, a quadratic behavior can otherwise be + -- encountered in large expressions. The cache entry for node N is stored + -- in the (N mod Cache_Size) entry, and can be validated by checking the + -- actual node value stored there. The Range_Cache_V array records the + -- setting of Assume_Valid for the cache entry. + + procedure Determine_Range + (N : Node_Id; + OK : out Boolean; + Lo : out Uint; + Hi : out Uint; + Assume_Valid : Boolean := False) + is + Typ : Entity_Id := Etype (N); + -- Type to use, may get reset to base type for possibly invalid entity + + Lo_Left : Uint; + Hi_Left : Uint; + -- Lo and Hi bounds of left operand + + Lo_Right : Uint; + Hi_Right : Uint; + -- Lo and Hi bounds of right (or only) operand + + Bound : Node_Id; + -- Temp variable used to hold a bound node + + Hbound : Uint; + -- High bound of base type of expression + + Lor : Uint; + Hir : Uint; + -- Refined values for low and high bounds, after tightening + + OK1 : Boolean; + -- Used in lower level calls to indicate if call succeeded + + Cindex : Cache_Index; + -- Used to search cache + + function OK_Operands return Boolean; + -- Used for binary operators. Determines the ranges of the left and + -- right operands, and if they are both OK, returns True, and puts + -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left. + + ----------------- + -- OK_Operands -- + ----------------- + + function OK_Operands return Boolean is + begin + Determine_Range + (Left_Opnd (N), OK1, Lo_Left, Hi_Left, Assume_Valid); + + if not OK1 then + return False; + end if; + + Determine_Range + (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid); + return OK1; + end OK_Operands; + + -- Start of processing for Determine_Range + + begin + -- Prevent junk warnings by initializing range variables + + Lo := No_Uint; + Hi := No_Uint; + Lor := No_Uint; + Hir := No_Uint; + + -- If type is not defined, we can't determine its range + + if No (Typ) + + -- We don't deal with anything except discrete types + + or else not Is_Discrete_Type (Typ) + + -- Ignore type for which an error has been posted, since range in + -- this case may well be a bogosity deriving from the error. Also + -- ignore if error posted on the reference node. + + or else Error_Posted (N) or else Error_Posted (Typ) + then + OK := False; + return; + end if; + + -- For all other cases, we can determine the range + + OK := True; + + -- If value is compile time known, then the possible range is the one + -- value that we know this expression definitely has! + + if Compile_Time_Known_Value (N) then + Lo := Expr_Value (N); + Hi := Lo; + return; + end if; + + -- Return if already in the cache + + Cindex := Cache_Index (N mod Cache_Size); + + if Determine_Range_Cache_N (Cindex) = N + and then + Determine_Range_Cache_V (Cindex) = Assume_Valid + then + Lo := Determine_Range_Cache_Lo (Cindex); + Hi := Determine_Range_Cache_Hi (Cindex); + return; + end if; + + -- Otherwise, start by finding the bounds of the type of the expression, + -- the value cannot be outside this range (if it is, then we have an + -- overflow situation, which is a separate check, we are talking here + -- only about the expression value). + + -- First a check, never try to find the bounds of a generic type, since + -- these bounds are always junk values, and it is only valid to look at + -- the bounds in an instance. + + if Is_Generic_Type (Typ) then + OK := False; + return; + end if; + + -- First step, change to use base type unless we know the value is valid + + if (Is_Entity_Name (N) and then Is_Known_Valid (Entity (N))) + or else Assume_No_Invalid_Values + or else Assume_Valid + then + null; + else + Typ := Underlying_Type (Base_Type (Typ)); + end if; + + -- We use the actual bound unless it is dynamic, in which case use the + -- corresponding base type bound if possible. If we can't get a bound + -- then we figure we can't determine the range (a peculiar case, that + -- perhaps cannot happen, but there is no point in bombing in this + -- optimization circuit. + + -- First the low bound + + Bound := Type_Low_Bound (Typ); + + if Compile_Time_Known_Value (Bound) then + Lo := Expr_Value (Bound); + + elsif Compile_Time_Known_Value (Type_Low_Bound (Base_Type (Typ))) then + Lo := Expr_Value (Type_Low_Bound (Base_Type (Typ))); + + else + OK := False; + return; + end if; + + -- Now the high bound + + Bound := Type_High_Bound (Typ); + + -- We need the high bound of the base type later on, and this should + -- always be compile time known. Again, it is not clear that this + -- can ever be false, but no point in bombing. + + if Compile_Time_Known_Value (Type_High_Bound (Base_Type (Typ))) then + Hbound := Expr_Value (Type_High_Bound (Base_Type (Typ))); + Hi := Hbound; + + else + OK := False; + return; + end if; + + -- If we have a static subtype, then that may have a tighter bound so + -- use the upper bound of the subtype instead in this case. + + if Compile_Time_Known_Value (Bound) then + Hi := Expr_Value (Bound); + end if; + + -- We may be able to refine this value in certain situations. If any + -- refinement is possible, then Lor and Hir are set to possibly tighter + -- bounds, and OK1 is set to True. + + case Nkind (N) is + + -- For unary plus, result is limited by range of operand + + when N_Op_Plus => + Determine_Range + (Right_Opnd (N), OK1, Lor, Hir, Assume_Valid); + + -- For unary minus, determine range of operand, and negate it + + when N_Op_Minus => + Determine_Range + (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid); + + if OK1 then + Lor := -Hi_Right; + Hir := -Lo_Right; + end if; + + -- For binary addition, get range of each operand and do the + -- addition to get the result range. + + when N_Op_Add => + if OK_Operands then + Lor := Lo_Left + Lo_Right; + Hir := Hi_Left + Hi_Right; + end if; + + -- Division is tricky. The only case we consider is where the right + -- operand is a positive constant, and in this case we simply divide + -- the bounds of the left operand + + when N_Op_Divide => + if OK_Operands then + if Lo_Right = Hi_Right + and then Lo_Right > 0 + then + Lor := Lo_Left / Lo_Right; + Hir := Hi_Left / Lo_Right; + + else + OK1 := False; + end if; + end if; + + -- For binary subtraction, get range of each operand and do the worst + -- case subtraction to get the result range. + + when N_Op_Subtract => + if OK_Operands then + Lor := Lo_Left - Hi_Right; + Hir := Hi_Left - Lo_Right; + end if; + + -- For MOD, if right operand is a positive constant, then result must + -- be in the allowable range of mod results. + + when N_Op_Mod => + if OK_Operands then + if Lo_Right = Hi_Right + and then Lo_Right /= 0 + then + if Lo_Right > 0 then + Lor := Uint_0; + Hir := Lo_Right - 1; + + else -- Lo_Right < 0 + Lor := Lo_Right + 1; + Hir := Uint_0; + end if; + + else + OK1 := False; + end if; + end if; + + -- For REM, if right operand is a positive constant, then result must + -- be in the allowable range of mod results. + + when N_Op_Rem => + if OK_Operands then + if Lo_Right = Hi_Right + and then Lo_Right /= 0 + then + declare + Dval : constant Uint := (abs Lo_Right) - 1; + + begin + -- The sign of the result depends on the sign of the + -- dividend (but not on the sign of the divisor, hence + -- the abs operation above). + + if Lo_Left < 0 then + Lor := -Dval; + else + Lor := Uint_0; + end if; + + if Hi_Left < 0 then + Hir := Uint_0; + else + Hir := Dval; + end if; + end; + + else + OK1 := False; + end if; + end if; + + -- Attribute reference cases + + when N_Attribute_Reference => + case Attribute_Name (N) is + + -- For Pos/Val attributes, we can refine the range using the + -- possible range of values of the attribute expression. + + when Name_Pos | Name_Val => + Determine_Range + (First (Expressions (N)), OK1, Lor, Hir, Assume_Valid); + + -- For Length attribute, use the bounds of the corresponding + -- index type to refine the range. + + when Name_Length => + declare + Atyp : Entity_Id := Etype (Prefix (N)); + Inum : Nat; + Indx : Node_Id; + + LL, LU : Uint; + UL, UU : Uint; + + begin + if Is_Access_Type (Atyp) then + Atyp := Designated_Type (Atyp); + end if; + + -- For string literal, we know exact value + + if Ekind (Atyp) = E_String_Literal_Subtype then + OK := True; + Lo := String_Literal_Length (Atyp); + Hi := String_Literal_Length (Atyp); + return; + end if; + + -- Otherwise check for expression given + + if No (Expressions (N)) then + Inum := 1; + else + Inum := + UI_To_Int (Expr_Value (First (Expressions (N)))); + end if; + + Indx := First_Index (Atyp); + for J in 2 .. Inum loop + Indx := Next_Index (Indx); + end loop; + + -- If the index type is a formal type or derived from + -- one, the bounds are not static. + + if Is_Generic_Type (Root_Type (Etype (Indx))) then + OK := False; + return; + end if; + + Determine_Range + (Type_Low_Bound (Etype (Indx)), OK1, LL, LU, + Assume_Valid); + + if OK1 then + Determine_Range + (Type_High_Bound (Etype (Indx)), OK1, UL, UU, + Assume_Valid); + + if OK1 then + + -- The maximum value for Length is the biggest + -- possible gap between the values of the bounds. + -- But of course, this value cannot be negative. + + Hir := UI_Max (Uint_0, UU - LL + 1); + + -- For constrained arrays, the minimum value for + -- Length is taken from the actual value of the + -- bounds, since the index will be exactly of this + -- subtype. + + if Is_Constrained (Atyp) then + Lor := UI_Max (Uint_0, UL - LU + 1); + + -- For an unconstrained array, the minimum value + -- for length is always zero. + + else + Lor := Uint_0; + end if; + end if; + end if; + end; + + -- No special handling for other attributes + -- Probably more opportunities exist here??? + + when others => + OK1 := False; + + end case; + + -- For type conversion from one discrete type to another, we can + -- refine the range using the converted value. + + when N_Type_Conversion => + Determine_Range (Expression (N), OK1, Lor, Hir, Assume_Valid); + + -- Nothing special to do for all other expression kinds + + when others => + OK1 := False; + Lor := No_Uint; + Hir := No_Uint; + end case; + + -- At this stage, if OK1 is true, then we know that the actual result of + -- the computed expression is in the range Lor .. Hir. We can use this + -- to restrict the possible range of results. + + if OK1 then + + -- If the refined value of the low bound is greater than the type + -- high bound, then reset it to the more restrictive value. However, + -- we do NOT do this for the case of a modular type where the + -- possible upper bound on the value is above the base type high + -- bound, because that means the result could wrap. + + if Lor > Lo + and then not (Is_Modular_Integer_Type (Typ) and then Hir > Hbound) + then + Lo := Lor; + end if; + + -- Similarly, if the refined value of the high bound is less than the + -- value so far, then reset it to the more restrictive value. Again, + -- we do not do this if the refined low bound is negative for a + -- modular type, since this would wrap. + + if Hir < Hi + and then not (Is_Modular_Integer_Type (Typ) and then Lor < Uint_0) + then + Hi := Hir; + end if; + end if; + + -- Set cache entry for future call and we are all done + + Determine_Range_Cache_N (Cindex) := N; + Determine_Range_Cache_V (Cindex) := Assume_Valid; + Determine_Range_Cache_Lo (Cindex) := Lo; + Determine_Range_Cache_Hi (Cindex) := Hi; + return; + + -- If any exception occurs, it means that we have some bug in the compiler, + -- possibly triggered by a previous error, or by some unforeseen peculiar + -- occurrence. However, this is only an optimization attempt, so there is + -- really no point in crashing the compiler. Instead we just decide, too + -- bad, we can't figure out a range in this case after all. + + exception + when others => + + -- Debug flag K disables this behavior (useful for debugging) + + if Debug_Flag_K then + raise; + else + OK := False; + Lo := No_Uint; + Hi := No_Uint; + return; + end if; + end Determine_Range; + + ------------------------------------ + -- Discriminant_Checks_Suppressed -- + ------------------------------------ + + function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + if Present (E) then + if Is_Unchecked_Union (E) then + return True; + elsif Checks_May_Be_Suppressed (E) then + return Is_Check_Suppressed (E, Discriminant_Check); + end if; + end if; + + return Scope_Suppress (Discriminant_Check); + end Discriminant_Checks_Suppressed; + + -------------------------------- + -- Division_Checks_Suppressed -- + -------------------------------- + + function Division_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + if Present (E) and then Checks_May_Be_Suppressed (E) then + return Is_Check_Suppressed (E, Division_Check); + else + return Scope_Suppress (Division_Check); + end if; + end Division_Checks_Suppressed; + + ----------------------------------- + -- Elaboration_Checks_Suppressed -- + ----------------------------------- + + function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + -- The complication in this routine is that if we are in the dynamic + -- model of elaboration, we also check All_Checks, since All_Checks + -- does not set Elaboration_Check explicitly. + + if Present (E) then + if Kill_Elaboration_Checks (E) then + return True; + + elsif Checks_May_Be_Suppressed (E) then + if Is_Check_Suppressed (E, Elaboration_Check) then + return True; + elsif Dynamic_Elaboration_Checks then + return Is_Check_Suppressed (E, All_Checks); + else + return False; + end if; + end if; + end if; + + if Scope_Suppress (Elaboration_Check) then + return True; + elsif Dynamic_Elaboration_Checks then + return Scope_Suppress (All_Checks); + else + return False; + end if; + end Elaboration_Checks_Suppressed; + + --------------------------- + -- Enable_Overflow_Check -- + --------------------------- + + procedure Enable_Overflow_Check (N : Node_Id) is + Typ : constant Entity_Id := Base_Type (Etype (N)); + Chk : Nat; + OK : Boolean; + Ent : Entity_Id; + Ofs : Uint; + Lo : Uint; + Hi : Uint; + + begin + if Debug_Flag_CC then + w ("Enable_Overflow_Check for node ", Int (N)); + Write_Str (" Source location = "); + wl (Sloc (N)); + pg (Union_Id (N)); + end if; + + -- No check if overflow checks suppressed for type of node + + if Present (Etype (N)) + and then Overflow_Checks_Suppressed (Etype (N)) + then + return; + + -- Nothing to do for unsigned integer types, which do not overflow + + elsif Is_Modular_Integer_Type (Typ) then + return; + + -- Nothing to do if the range of the result is known OK. We skip this + -- for conversions, since the caller already did the check, and in any + -- case the condition for deleting the check for a type conversion is + -- different. + + elsif Nkind (N) /= N_Type_Conversion then + Determine_Range (N, OK, Lo, Hi, Assume_Valid => True); + + -- Note in the test below that we assume that the range is not OK + -- if a bound of the range is equal to that of the type. That's not + -- quite accurate but we do this for the following reasons: + + -- a) The way that Determine_Range works, it will typically report + -- the bounds of the value as being equal to the bounds of the + -- type, because it either can't tell anything more precise, or + -- does not think it is worth the effort to be more precise. + + -- b) It is very unusual to have a situation in which this would + -- generate an unnecessary overflow check (an example would be + -- a subtype with a range 0 .. Integer'Last - 1 to which the + -- literal value one is added). + + -- c) The alternative is a lot of special casing in this routine + -- which would partially duplicate Determine_Range processing. + + if OK + and then Lo > Expr_Value (Type_Low_Bound (Typ)) + and then Hi < Expr_Value (Type_High_Bound (Typ)) + then + if Debug_Flag_CC then + w ("No overflow check required"); + end if; + + return; + end if; + end if; + + -- If not in optimizing mode, set flag and we are done. We are also done + -- (and just set the flag) if the type is not a discrete type, since it + -- is not worth the effort to eliminate checks for other than discrete + -- types. In addition, we take this same path if we have stored the + -- maximum number of checks possible already (a very unlikely situation, + -- but we do not want to blow up!) + + if Optimization_Level = 0 + or else not Is_Discrete_Type (Etype (N)) + or else Num_Saved_Checks = Saved_Checks'Last + then + Activate_Overflow_Check (N); + + if Debug_Flag_CC then + w ("Optimization off"); + end if; + + return; + end if; + + -- Otherwise evaluate and check the expression + + Find_Check + (Expr => N, + Check_Type => 'O', + Target_Type => Empty, + Entry_OK => OK, + Check_Num => Chk, + Ent => Ent, + Ofs => Ofs); + + if Debug_Flag_CC then + w ("Called Find_Check"); + w (" OK = ", OK); + + if OK then + w (" Check_Num = ", Chk); + w (" Ent = ", Int (Ent)); + Write_Str (" Ofs = "); + pid (Ofs); + end if; + end if; + + -- If check is not of form to optimize, then set flag and we are done + + if not OK then + Activate_Overflow_Check (N); + return; + end if; + + -- If check is already performed, then return without setting flag + + if Chk /= 0 then + if Debug_Flag_CC then + w ("Check suppressed!"); + end if; + + return; + end if; + + -- Here we will make a new entry for the new check + + Activate_Overflow_Check (N); + Num_Saved_Checks := Num_Saved_Checks + 1; + Saved_Checks (Num_Saved_Checks) := + (Killed => False, + Entity => Ent, + Offset => Ofs, + Check_Type => 'O', + Target_Type => Empty); + + if Debug_Flag_CC then + w ("Make new entry, check number = ", Num_Saved_Checks); + w (" Entity = ", Int (Ent)); + Write_Str (" Offset = "); + pid (Ofs); + w (" Check_Type = O"); + w (" Target_Type = Empty"); + end if; + + -- If we get an exception, then something went wrong, probably because of + -- an error in the structure of the tree due to an incorrect program. Or it + -- may be a bug in the optimization circuit. In either case the safest + -- thing is simply to set the check flag unconditionally. + + exception + when others => + Activate_Overflow_Check (N); + + if Debug_Flag_CC then + w (" exception occurred, overflow flag set"); + end if; + + return; + end Enable_Overflow_Check; + + ------------------------ + -- Enable_Range_Check -- + ------------------------ + + procedure Enable_Range_Check (N : Node_Id) is + Chk : Nat; + OK : Boolean; + Ent : Entity_Id; + Ofs : Uint; + Ttyp : Entity_Id; + P : Node_Id; + + begin + -- Return if unchecked type conversion with range check killed. In this + -- case we never set the flag (that's what Kill_Range_Check is about!) + + if Nkind (N) = N_Unchecked_Type_Conversion + and then Kill_Range_Check (N) + then + return; + end if; + + -- Do not set range check flag if parent is assignment statement or + -- object declaration with Suppress_Assignment_Checks flag set + + if Nkind_In (Parent (N), N_Assignment_Statement, N_Object_Declaration) + and then Suppress_Assignment_Checks (Parent (N)) + then + return; + end if; + + -- Check for various cases where we should suppress the range check + + -- No check if range checks suppressed for type of node + + if Present (Etype (N)) + and then Range_Checks_Suppressed (Etype (N)) + then + return; + + -- No check if node is an entity name, and range checks are suppressed + -- for this entity, or for the type of this entity. + + elsif Is_Entity_Name (N) + and then (Range_Checks_Suppressed (Entity (N)) + or else Range_Checks_Suppressed (Etype (Entity (N)))) + then + return; + + -- No checks if index of array, and index checks are suppressed for + -- the array object or the type of the array. + + elsif Nkind (Parent (N)) = N_Indexed_Component then + declare + Pref : constant Node_Id := Prefix (Parent (N)); + begin + if Is_Entity_Name (Pref) + and then Index_Checks_Suppressed (Entity (Pref)) + then + return; + elsif Index_Checks_Suppressed (Etype (Pref)) then + return; + end if; + end; + end if; + + -- Debug trace output + + if Debug_Flag_CC then + w ("Enable_Range_Check for node ", Int (N)); + Write_Str (" Source location = "); + wl (Sloc (N)); + pg (Union_Id (N)); + end if; + + -- If not in optimizing mode, set flag and we are done. We are also done + -- (and just set the flag) if the type is not a discrete type, since it + -- is not worth the effort to eliminate checks for other than discrete + -- types. In addition, we take this same path if we have stored the + -- maximum number of checks possible already (a very unlikely situation, + -- but we do not want to blow up!) + + if Optimization_Level = 0 + or else No (Etype (N)) + or else not Is_Discrete_Type (Etype (N)) + or else Num_Saved_Checks = Saved_Checks'Last + then + Activate_Range_Check (N); + + if Debug_Flag_CC then + w ("Optimization off"); + end if; + + return; + end if; + + -- Otherwise find out the target type + + P := Parent (N); + + -- For assignment, use left side subtype + + if Nkind (P) = N_Assignment_Statement + and then Expression (P) = N + then + Ttyp := Etype (Name (P)); + + -- For indexed component, use subscript subtype + + elsif Nkind (P) = N_Indexed_Component then + declare + Atyp : Entity_Id; + Indx : Node_Id; + Subs : Node_Id; + + begin + Atyp := Etype (Prefix (P)); + + if Is_Access_Type (Atyp) then + Atyp := Designated_Type (Atyp); + + -- If the prefix is an access to an unconstrained array, + -- perform check unconditionally: it depends on the bounds of + -- an object and we cannot currently recognize whether the test + -- may be redundant. + + if not Is_Constrained (Atyp) then + Activate_Range_Check (N); + return; + end if; + + -- Ditto if the prefix is an explicit dereference whose designated + -- type is unconstrained. + + elsif Nkind (Prefix (P)) = N_Explicit_Dereference + and then not Is_Constrained (Atyp) + then + Activate_Range_Check (N); + return; + end if; + + Indx := First_Index (Atyp); + Subs := First (Expressions (P)); + loop + if Subs = N then + Ttyp := Etype (Indx); + exit; + end if; + + Next_Index (Indx); + Next (Subs); + end loop; + end; + + -- For now, ignore all other cases, they are not so interesting + + else + if Debug_Flag_CC then + w (" target type not found, flag set"); + end if; + + Activate_Range_Check (N); + return; + end if; + + -- Evaluate and check the expression + + Find_Check + (Expr => N, + Check_Type => 'R', + Target_Type => Ttyp, + Entry_OK => OK, + Check_Num => Chk, + Ent => Ent, + Ofs => Ofs); + + if Debug_Flag_CC then + w ("Called Find_Check"); + w ("Target_Typ = ", Int (Ttyp)); + w (" OK = ", OK); + + if OK then + w (" Check_Num = ", Chk); + w (" Ent = ", Int (Ent)); + Write_Str (" Ofs = "); + pid (Ofs); + end if; + end if; + + -- If check is not of form to optimize, then set flag and we are done + + if not OK then + if Debug_Flag_CC then + w (" expression not of optimizable type, flag set"); + end if; + + Activate_Range_Check (N); + return; + end if; + + -- If check is already performed, then return without setting flag + + if Chk /= 0 then + if Debug_Flag_CC then + w ("Check suppressed!"); + end if; + + return; + end if; + + -- Here we will make a new entry for the new check + + Activate_Range_Check (N); + Num_Saved_Checks := Num_Saved_Checks + 1; + Saved_Checks (Num_Saved_Checks) := + (Killed => False, + Entity => Ent, + Offset => Ofs, + Check_Type => 'R', + Target_Type => Ttyp); + + if Debug_Flag_CC then + w ("Make new entry, check number = ", Num_Saved_Checks); + w (" Entity = ", Int (Ent)); + Write_Str (" Offset = "); + pid (Ofs); + w (" Check_Type = R"); + w (" Target_Type = ", Int (Ttyp)); + pg (Union_Id (Ttyp)); + end if; + + -- If we get an exception, then something went wrong, probably because of + -- an error in the structure of the tree due to an incorrect program. Or + -- it may be a bug in the optimization circuit. In either case the safest + -- thing is simply to set the check flag unconditionally. + + exception + when others => + Activate_Range_Check (N); + + if Debug_Flag_CC then + w (" exception occurred, range flag set"); + end if; + + return; + end Enable_Range_Check; + + ------------------ + -- Ensure_Valid -- + ------------------ + + procedure Ensure_Valid (Expr : Node_Id; Holes_OK : Boolean := False) is + Typ : constant Entity_Id := Etype (Expr); + + begin + -- Ignore call if we are not doing any validity checking + + if not Validity_Checks_On then + return; + + -- Ignore call if range or validity checks suppressed on entity or type + + elsif Range_Or_Validity_Checks_Suppressed (Expr) then + return; + + -- No check required if expression is from the expander, we assume the + -- expander will generate whatever checks are needed. Note that this is + -- not just an optimization, it avoids infinite recursions! + + -- Unchecked conversions must be checked, unless they are initialized + -- scalar values, as in a component assignment in an init proc. + + -- In addition, we force a check if Force_Validity_Checks is set + + elsif not Comes_From_Source (Expr) + and then not Force_Validity_Checks + and then (Nkind (Expr) /= N_Unchecked_Type_Conversion + or else Kill_Range_Check (Expr)) + then + return; + + -- No check required if expression is known to have valid value + + elsif Expr_Known_Valid (Expr) then + return; + + -- Ignore case of enumeration with holes where the flag is set not to + -- worry about holes, since no special validity check is needed + + elsif Is_Enumeration_Type (Typ) + and then Has_Non_Standard_Rep (Typ) + and then Holes_OK + then + return; + + -- No check required on the left-hand side of an assignment + + elsif Nkind (Parent (Expr)) = N_Assignment_Statement + and then Expr = Name (Parent (Expr)) + then + return; + + -- No check on a universal real constant. The context will eventually + -- convert it to a machine number for some target type, or report an + -- illegality. + + elsif Nkind (Expr) = N_Real_Literal + and then Etype (Expr) = Universal_Real + then + return; + + -- If the expression denotes a component of a packed boolean array, + -- no possible check applies. We ignore the old ACATS chestnuts that + -- involve Boolean range True..True. + + -- Note: validity checks are generated for expressions that yield a + -- scalar type, when it is possible to create a value that is outside of + -- the type. If this is a one-bit boolean no such value exists. This is + -- an optimization, and it also prevents compiler blowing up during the + -- elaboration of improperly expanded packed array references. + + elsif Nkind (Expr) = N_Indexed_Component + and then Is_Bit_Packed_Array (Etype (Prefix (Expr))) + and then Root_Type (Etype (Expr)) = Standard_Boolean + then + return; + + -- An annoying special case. If this is an out parameter of a scalar + -- type, then the value is not going to be accessed, therefore it is + -- inappropriate to do any validity check at the call site. + + else + -- Only need to worry about scalar types + + if Is_Scalar_Type (Typ) then + declare + P : Node_Id; + N : Node_Id; + E : Entity_Id; + F : Entity_Id; + A : Node_Id; + L : List_Id; + + begin + -- Find actual argument (which may be a parameter association) + -- and the parent of the actual argument (the call statement) + + N := Expr; + P := Parent (Expr); + + if Nkind (P) = N_Parameter_Association then + N := P; + P := Parent (N); + end if; + + -- Only need to worry if we are argument of a procedure call + -- since functions don't have out parameters. If this is an + -- indirect or dispatching call, get signature from the + -- subprogram type. + + if Nkind (P) = N_Procedure_Call_Statement then + L := Parameter_Associations (P); + + if Is_Entity_Name (Name (P)) then + E := Entity (Name (P)); + else + pragma Assert (Nkind (Name (P)) = N_Explicit_Dereference); + E := Etype (Name (P)); + end if; + + -- Only need to worry if there are indeed actuals, and if + -- this could be a procedure call, otherwise we cannot get a + -- match (either we are not an argument, or the mode of the + -- formal is not OUT). This test also filters out the + -- generic case. + + if Is_Non_Empty_List (L) + and then Is_Subprogram (E) + then + -- This is the loop through parameters, looking for an + -- OUT parameter for which we are the argument. + + F := First_Formal (E); + A := First (L); + while Present (F) loop + if Ekind (F) = E_Out_Parameter and then A = N then + return; + end if; + + Next_Formal (F); + Next (A); + end loop; + end if; + end if; + end; + end if; + end if; + + -- If this is a boolean expression, only its elementary operands need + -- checking: if they are valid, a boolean or short-circuit operation + -- with them will be valid as well. + + if Base_Type (Typ) = Standard_Boolean + and then + (Nkind (Expr) in N_Op or else Nkind (Expr) in N_Short_Circuit) + then + return; + end if; + + -- If we fall through, a validity check is required + + Insert_Valid_Check (Expr); + + if Is_Entity_Name (Expr) + and then Safe_To_Capture_Value (Expr, Entity (Expr)) + then + Set_Is_Known_Valid (Entity (Expr)); + end if; + end Ensure_Valid; + + ---------------------- + -- Expr_Known_Valid -- + ---------------------- + + function Expr_Known_Valid (Expr : Node_Id) return Boolean is + Typ : constant Entity_Id := Etype (Expr); + + begin + -- Non-scalar types are always considered valid, since they never give + -- rise to the issues of erroneous or bounded error behavior that are + -- the concern. In formal reference manual terms the notion of validity + -- only applies to scalar types. Note that even when packed arrays are + -- represented using modular types, they are still arrays semantically, + -- so they are also always valid (in particular, the unused bits can be + -- random rubbish without affecting the validity of the array value). + + if not Is_Scalar_Type (Typ) or else Is_Packed_Array_Type (Typ) then + return True; + + -- If no validity checking, then everything is considered valid + + elsif not Validity_Checks_On then + return True; + + -- Floating-point types are considered valid unless floating-point + -- validity checks have been specifically turned on. + + elsif Is_Floating_Point_Type (Typ) + and then not Validity_Check_Floating_Point + then + return True; + + -- If the expression is the value of an object that is known to be + -- valid, then clearly the expression value itself is valid. + + elsif Is_Entity_Name (Expr) + and then Is_Known_Valid (Entity (Expr)) + then + return True; + + -- References to discriminants are always considered valid. The value + -- of a discriminant gets checked when the object is built. Within the + -- record, we consider it valid, and it is important to do so, since + -- otherwise we can try to generate bogus validity checks which + -- reference discriminants out of scope. Discriminants of concurrent + -- types are excluded for the same reason. + + elsif Is_Entity_Name (Expr) + and then Denotes_Discriminant (Expr, Check_Concurrent => True) + then + return True; + + -- If the type is one for which all values are known valid, then we are + -- sure that the value is valid except in the slightly odd case where + -- the expression is a reference to a variable whose size has been + -- explicitly set to a value greater than the object size. + + elsif Is_Known_Valid (Typ) then + if Is_Entity_Name (Expr) + and then Ekind (Entity (Expr)) = E_Variable + and then Esize (Entity (Expr)) > Esize (Typ) + then + return False; + else + return True; + end if; + + -- Integer and character literals always have valid values, where + -- appropriate these will be range checked in any case. + + elsif Nkind (Expr) = N_Integer_Literal + or else + Nkind (Expr) = N_Character_Literal + then + return True; + + -- If we have a type conversion or a qualification of a known valid + -- value, then the result will always be valid. + + elsif Nkind (Expr) = N_Type_Conversion + or else + Nkind (Expr) = N_Qualified_Expression + then + return Expr_Known_Valid (Expression (Expr)); + + -- The result of any operator is always considered valid, since we + -- assume the necessary checks are done by the operator. For operators + -- on floating-point operations, we must also check when the operation + -- is the right-hand side of an assignment, or is an actual in a call. + + elsif Nkind (Expr) in N_Op then + if Is_Floating_Point_Type (Typ) + and then Validity_Check_Floating_Point + and then + (Nkind (Parent (Expr)) = N_Assignment_Statement + or else Nkind (Parent (Expr)) = N_Function_Call + or else Nkind (Parent (Expr)) = N_Parameter_Association) + then + return False; + else + return True; + end if; + + -- The result of a membership test is always valid, since it is true or + -- false, there are no other possibilities. + + elsif Nkind (Expr) in N_Membership_Test then + return True; + + -- For all other cases, we do not know the expression is valid + + else + return False; + end if; + end Expr_Known_Valid; + + ---------------- + -- Find_Check -- + ---------------- + + procedure Find_Check + (Expr : Node_Id; + Check_Type : Character; + Target_Type : Entity_Id; + Entry_OK : out Boolean; + Check_Num : out Nat; + Ent : out Entity_Id; + Ofs : out Uint) + is + function Within_Range_Of + (Target_Type : Entity_Id; + Check_Type : Entity_Id) return Boolean; + -- Given a requirement for checking a range against Target_Type, and + -- and a range Check_Type against which a check has already been made, + -- determines if the check against check type is sufficient to ensure + -- that no check against Target_Type is required. + + --------------------- + -- Within_Range_Of -- + --------------------- + + function Within_Range_Of + (Target_Type : Entity_Id; + Check_Type : Entity_Id) return Boolean + is + begin + if Target_Type = Check_Type then + return True; + + else + declare + Tlo : constant Node_Id := Type_Low_Bound (Target_Type); + Thi : constant Node_Id := Type_High_Bound (Target_Type); + Clo : constant Node_Id := Type_Low_Bound (Check_Type); + Chi : constant Node_Id := Type_High_Bound (Check_Type); + + begin + if (Tlo = Clo + or else (Compile_Time_Known_Value (Tlo) + and then + Compile_Time_Known_Value (Clo) + and then + Expr_Value (Clo) >= Expr_Value (Tlo))) + and then + (Thi = Chi + or else (Compile_Time_Known_Value (Thi) + and then + Compile_Time_Known_Value (Chi) + and then + Expr_Value (Chi) <= Expr_Value (Clo))) + then + return True; + else + return False; + end if; + end; + end if; + end Within_Range_Of; + + -- Start of processing for Find_Check + + begin + -- Establish default, in case no entry is found + + Check_Num := 0; + + -- Case of expression is simple entity reference + + if Is_Entity_Name (Expr) then + Ent := Entity (Expr); + Ofs := Uint_0; + + -- Case of expression is entity + known constant + + elsif Nkind (Expr) = N_Op_Add + and then Compile_Time_Known_Value (Right_Opnd (Expr)) + and then Is_Entity_Name (Left_Opnd (Expr)) + then + Ent := Entity (Left_Opnd (Expr)); + Ofs := Expr_Value (Right_Opnd (Expr)); + + -- Case of expression is entity - known constant + + elsif Nkind (Expr) = N_Op_Subtract + and then Compile_Time_Known_Value (Right_Opnd (Expr)) + and then Is_Entity_Name (Left_Opnd (Expr)) + then + Ent := Entity (Left_Opnd (Expr)); + Ofs := UI_Negate (Expr_Value (Right_Opnd (Expr))); + + -- Any other expression is not of the right form + + else + Ent := Empty; + Ofs := Uint_0; + Entry_OK := False; + return; + end if; + + -- Come here with expression of appropriate form, check if entity is an + -- appropriate one for our purposes. + + if (Ekind (Ent) = E_Variable + or else Is_Constant_Object (Ent)) + and then not Is_Library_Level_Entity (Ent) + then + Entry_OK := True; + else + Entry_OK := False; + return; + end if; + + -- See if there is matching check already + + for J in reverse 1 .. Num_Saved_Checks loop + declare + SC : Saved_Check renames Saved_Checks (J); + + begin + if SC.Killed = False + and then SC.Entity = Ent + and then SC.Offset = Ofs + and then SC.Check_Type = Check_Type + and then Within_Range_Of (Target_Type, SC.Target_Type) + then + Check_Num := J; + return; + end if; + end; + end loop; + + -- If we fall through entry was not found + + return; + end Find_Check; + + --------------------------------- + -- Generate_Discriminant_Check -- + --------------------------------- + + -- Note: the code for this procedure is derived from the + -- Emit_Discriminant_Check Routine in trans.c. + + procedure Generate_Discriminant_Check (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Pref : constant Node_Id := Prefix (N); + Sel : constant Node_Id := Selector_Name (N); + + Orig_Comp : constant Entity_Id := + Original_Record_Component (Entity (Sel)); + -- The original component to be checked + + Discr_Fct : constant Entity_Id := + Discriminant_Checking_Func (Orig_Comp); + -- The discriminant checking function + + Discr : Entity_Id; + -- One discriminant to be checked in the type + + Real_Discr : Entity_Id; + -- Actual discriminant in the call + + Pref_Type : Entity_Id; + -- Type of relevant prefix (ignoring private/access stuff) + + Args : List_Id; + -- List of arguments for function call + + Formal : Entity_Id; + -- Keep track of the formal corresponding to the actual we build for + -- each discriminant, in order to be able to perform the necessary type + -- conversions. + + Scomp : Node_Id; + -- Selected component reference for checking function argument + + begin + Pref_Type := Etype (Pref); + + -- Force evaluation of the prefix, so that it does not get evaluated + -- twice (once for the check, once for the actual reference). Such a + -- double evaluation is always a potential source of inefficiency, + -- and is functionally incorrect in the volatile case, or when the + -- prefix may have side-effects. An entity or a component of an + -- entity requires no evaluation. + + if Is_Entity_Name (Pref) then + if Treat_As_Volatile (Entity (Pref)) then + Force_Evaluation (Pref, Name_Req => True); + end if; + + elsif Treat_As_Volatile (Etype (Pref)) then + Force_Evaluation (Pref, Name_Req => True); + + elsif Nkind (Pref) = N_Selected_Component + and then Is_Entity_Name (Prefix (Pref)) + then + null; + + else + Force_Evaluation (Pref, Name_Req => True); + end if; + + -- For a tagged type, use the scope of the original component to + -- obtain the type, because ??? + + if Is_Tagged_Type (Scope (Orig_Comp)) then + Pref_Type := Scope (Orig_Comp); + + -- For an untagged derived type, use the discriminants of the parent + -- which have been renamed in the derivation, possibly by a one-to-many + -- discriminant constraint. For non-tagged type, initially get the Etype + -- of the prefix + + else + if Is_Derived_Type (Pref_Type) + and then Number_Discriminants (Pref_Type) /= + Number_Discriminants (Etype (Base_Type (Pref_Type))) + then + Pref_Type := Etype (Base_Type (Pref_Type)); + end if; + end if; + + -- We definitely should have a checking function, This routine should + -- not be called if no discriminant checking function is present. + + pragma Assert (Present (Discr_Fct)); + + -- Create the list of the actual parameters for the call. This list + -- is the list of the discriminant fields of the record expression to + -- be discriminant checked. + + Args := New_List; + Formal := First_Formal (Discr_Fct); + Discr := First_Discriminant (Pref_Type); + while Present (Discr) loop + + -- If we have a corresponding discriminant field, and a parent + -- subtype is present, then we want to use the corresponding + -- discriminant since this is the one with the useful value. + + if Present (Corresponding_Discriminant (Discr)) + and then Ekind (Pref_Type) = E_Record_Type + and then Present (Parent_Subtype (Pref_Type)) + then + Real_Discr := Corresponding_Discriminant (Discr); + else + Real_Discr := Discr; + end if; + + -- Construct the reference to the discriminant + + Scomp := + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Pref_Type, + Duplicate_Subexpr (Pref)), + Selector_Name => New_Occurrence_Of (Real_Discr, Loc)); + + -- Manually analyze and resolve this selected component. We really + -- want it just as it appears above, and do not want the expander + -- playing discriminal games etc with this reference. Then we append + -- the argument to the list we are gathering. + + Set_Etype (Scomp, Etype (Real_Discr)); + Set_Analyzed (Scomp, True); + Append_To (Args, Convert_To (Etype (Formal), Scomp)); + + Next_Formal_With_Extras (Formal); + Next_Discriminant (Discr); + end loop; + + -- Now build and insert the call + + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Discr_Fct, Loc), + Parameter_Associations => Args), + Reason => CE_Discriminant_Check_Failed)); + end Generate_Discriminant_Check; + + --------------------------- + -- Generate_Index_Checks -- + --------------------------- + + procedure Generate_Index_Checks (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + A : constant Node_Id := Prefix (N); + Sub : Node_Id; + Ind : Nat; + Num : List_Id; + + begin + -- Ignore call if index checks suppressed for array object or type + + if (Is_Entity_Name (A) and then Index_Checks_Suppressed (Entity (A))) + or else Index_Checks_Suppressed (Etype (A)) + then + return; + end if; + + -- Generate the checks + + Sub := First (Expressions (N)); + Ind := 1; + while Present (Sub) loop + if Do_Range_Check (Sub) then + Set_Do_Range_Check (Sub, False); + + -- Force evaluation except for the case of a simple name of a + -- non-volatile entity. + + if not Is_Entity_Name (Sub) + or else Treat_As_Volatile (Entity (Sub)) + then + Force_Evaluation (Sub); + end if; + + -- Generate a raise of constraint error with the appropriate + -- reason and a condition of the form: + + -- Base_Type(Sub) not in array'range (subscript) + + -- Note that the reason we generate the conversion to the base + -- type here is that we definitely want the range check to take + -- place, even if it looks like the subtype is OK. Optimization + -- considerations that allow us to omit the check have already + -- been taken into account in the setting of the Do_Range_Check + -- flag earlier on. + + if Ind = 1 then + Num := No_List; + else + Num := New_List (Make_Integer_Literal (Loc, Ind)); + end if; + + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Not_In (Loc, + Left_Opnd => + Convert_To (Base_Type (Etype (Sub)), + Duplicate_Subexpr_Move_Checks (Sub)), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr_Move_Checks (A, Name_Req => True), + Attribute_Name => Name_Range, + Expressions => Num)), + Reason => CE_Index_Check_Failed)); + end if; + + Ind := Ind + 1; + Next (Sub); + end loop; + end Generate_Index_Checks; + + -------------------------- + -- Generate_Range_Check -- + -------------------------- + + procedure Generate_Range_Check + (N : Node_Id; + Target_Type : Entity_Id; + Reason : RT_Exception_Code) + is + Loc : constant Source_Ptr := Sloc (N); + Source_Type : constant Entity_Id := Etype (N); + Source_Base_Type : constant Entity_Id := Base_Type (Source_Type); + Target_Base_Type : constant Entity_Id := Base_Type (Target_Type); + + begin + -- First special case, if the source type is already within the range + -- of the target type, then no check is needed (probably we should have + -- stopped Do_Range_Check from being set in the first place, but better + -- late than later in preventing junk code! + + -- We do NOT apply this if the source node is a literal, since in this + -- case the literal has already been labeled as having the subtype of + -- the target. + + if In_Subrange_Of (Source_Type, Target_Type) + and then not + (Nkind (N) = N_Integer_Literal + or else + Nkind (N) = N_Real_Literal + or else + Nkind (N) = N_Character_Literal + or else + (Is_Entity_Name (N) + and then Ekind (Entity (N)) = E_Enumeration_Literal)) + then + return; + end if; + + -- We need a check, so force evaluation of the node, so that it does + -- not get evaluated twice (once for the check, once for the actual + -- reference). Such a double evaluation is always a potential source + -- of inefficiency, and is functionally incorrect in the volatile case. + + if not Is_Entity_Name (N) + or else Treat_As_Volatile (Entity (N)) + then + Force_Evaluation (N); + end if; + + -- The easiest case is when Source_Base_Type and Target_Base_Type are + -- the same since in this case we can simply do a direct check of the + -- value of N against the bounds of Target_Type. + + -- [constraint_error when N not in Target_Type] + + -- Note: this is by far the most common case, for example all cases of + -- checks on the RHS of assignments are in this category, but not all + -- cases are like this. Notably conversions can involve two types. + + if Source_Base_Type = Target_Base_Type then + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Not_In (Loc, + Left_Opnd => Duplicate_Subexpr (N), + Right_Opnd => New_Occurrence_Of (Target_Type, Loc)), + Reason => Reason)); + + -- Next test for the case where the target type is within the bounds + -- of the base type of the source type, since in this case we can + -- simply convert these bounds to the base type of T to do the test. + + -- [constraint_error when N not in + -- Source_Base_Type (Target_Type'First) + -- .. + -- Source_Base_Type(Target_Type'Last))] + + -- The conversions will always work and need no check + + -- Unchecked_Convert_To is used instead of Convert_To to handle the case + -- of converting from an enumeration value to an integer type, such as + -- occurs for the case of generating a range check on Enum'Val(Exp) + -- (which used to be handled by gigi). This is OK, since the conversion + -- itself does not require a check. + + elsif In_Subrange_Of (Target_Type, Source_Base_Type) then + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Not_In (Loc, + Left_Opnd => Duplicate_Subexpr (N), + + Right_Opnd => + Make_Range (Loc, + Low_Bound => + Unchecked_Convert_To (Source_Base_Type, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Target_Type, Loc), + Attribute_Name => Name_First)), + + High_Bound => + Unchecked_Convert_To (Source_Base_Type, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Target_Type, Loc), + Attribute_Name => Name_Last)))), + Reason => Reason)); + + -- Note that at this stage we now that the Target_Base_Type is not in + -- the range of the Source_Base_Type (since even the Target_Type itself + -- is not in this range). It could still be the case that Source_Type is + -- in range of the target base type since we have not checked that case. + + -- If that is the case, we can freely convert the source to the target, + -- and then test the target result against the bounds. + + elsif In_Subrange_Of (Source_Type, Target_Base_Type) then + + -- We make a temporary to hold the value of the converted value + -- (converted to the base type), and then we will do the test against + -- this temporary. + + -- Tnn : constant Target_Base_Type := Target_Base_Type (N); + -- [constraint_error when Tnn not in Target_Type] + + -- Then the conversion itself is replaced by an occurrence of Tnn + + declare + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); + + begin + Insert_Actions (N, New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Object_Definition => + New_Occurrence_Of (Target_Base_Type, Loc), + Constant_Present => True, + Expression => + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc), + Expression => Duplicate_Subexpr (N))), + + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Not_In (Loc, + Left_Opnd => New_Occurrence_Of (Tnn, Loc), + Right_Opnd => New_Occurrence_Of (Target_Type, Loc)), + + Reason => Reason))); + + Rewrite (N, New_Occurrence_Of (Tnn, Loc)); + + -- Set the type of N, because the declaration for Tnn might not + -- be analyzed yet, as is the case if N appears within a record + -- declaration, as a discriminant constraint or expression. + + Set_Etype (N, Target_Base_Type); + end; + + -- At this stage, we know that we have two scalar types, which are + -- directly convertible, and where neither scalar type has a base + -- range that is in the range of the other scalar type. + + -- The only way this can happen is with a signed and unsigned type. + -- So test for these two cases: + + else + -- Case of the source is unsigned and the target is signed + + if Is_Unsigned_Type (Source_Base_Type) + and then not Is_Unsigned_Type (Target_Base_Type) + then + -- If the source is unsigned and the target is signed, then we + -- know that the source is not shorter than the target (otherwise + -- the source base type would be in the target base type range). + + -- In other words, the unsigned type is either the same size as + -- the target, or it is larger. It cannot be smaller. + + pragma Assert + (Esize (Source_Base_Type) >= Esize (Target_Base_Type)); + + -- We only need to check the low bound if the low bound of the + -- target type is non-negative. If the low bound of the target + -- type is negative, then we know that we will fit fine. + + -- If the high bound of the target type is negative, then we + -- know we have a constraint error, since we can't possibly + -- have a negative source. + + -- With these two checks out of the way, we can do the check + -- using the source type safely + + -- This is definitely the most annoying case! + + -- [constraint_error + -- when (Target_Type'First >= 0 + -- and then + -- N < Source_Base_Type (Target_Type'First)) + -- or else Target_Type'Last < 0 + -- or else N > Source_Base_Type (Target_Type'Last)]; + + -- We turn off all checks since we know that the conversions + -- will work fine, given the guards for negative values. + + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Or_Else (Loc, + Make_Or_Else (Loc, + Left_Opnd => + Make_And_Then (Loc, + Left_Opnd => Make_Op_Ge (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Target_Type, Loc), + Attribute_Name => Name_First), + Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), + + Right_Opnd => + Make_Op_Lt (Loc, + Left_Opnd => Duplicate_Subexpr (N), + Right_Opnd => + Convert_To (Source_Base_Type, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Target_Type, Loc), + Attribute_Name => Name_First)))), + + Right_Opnd => + Make_Op_Lt (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Target_Type, Loc), + Attribute_Name => Name_Last), + Right_Opnd => Make_Integer_Literal (Loc, Uint_0))), + + Right_Opnd => + Make_Op_Gt (Loc, + Left_Opnd => Duplicate_Subexpr (N), + Right_Opnd => + Convert_To (Source_Base_Type, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Target_Type, Loc), + Attribute_Name => Name_Last)))), + + Reason => Reason), + Suppress => All_Checks); + + -- Only remaining possibility is that the source is signed and + -- the target is unsigned. + + else + pragma Assert (not Is_Unsigned_Type (Source_Base_Type) + and then Is_Unsigned_Type (Target_Base_Type)); + + -- If the source is signed and the target is unsigned, then we + -- know that the target is not shorter than the source (otherwise + -- the target base type would be in the source base type range). + + -- In other words, the unsigned type is either the same size as + -- the target, or it is larger. It cannot be smaller. + + -- Clearly we have an error if the source value is negative since + -- no unsigned type can have negative values. If the source type + -- is non-negative, then the check can be done using the target + -- type. + + -- Tnn : constant Target_Base_Type (N) := Target_Type; + + -- [constraint_error + -- when N < 0 or else Tnn not in Target_Type]; + + -- We turn off all checks for the conversion of N to the target + -- base type, since we generate the explicit check to ensure that + -- the value is non-negative + + declare + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); + + begin + Insert_Actions (N, New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Object_Definition => + New_Occurrence_Of (Target_Base_Type, Loc), + Constant_Present => True, + Expression => + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Target_Base_Type, Loc), + Expression => Duplicate_Subexpr (N))), + + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Lt (Loc, + Left_Opnd => Duplicate_Subexpr (N), + Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), + + Right_Opnd => + Make_Not_In (Loc, + Left_Opnd => New_Occurrence_Of (Tnn, Loc), + Right_Opnd => + New_Occurrence_Of (Target_Type, Loc))), + + Reason => Reason)), + Suppress => All_Checks); + + -- Set the Etype explicitly, because Insert_Actions may have + -- placed the declaration in the freeze list for an enclosing + -- construct, and thus it is not analyzed yet. + + Set_Etype (Tnn, Target_Base_Type); + Rewrite (N, New_Occurrence_Of (Tnn, Loc)); + end; + end if; + end if; + end Generate_Range_Check; + + ------------------ + -- Get_Check_Id -- + ------------------ + + function Get_Check_Id (N : Name_Id) return Check_Id is + begin + -- For standard check name, we can do a direct computation + + if N in First_Check_Name .. Last_Check_Name then + return Check_Id (N - (First_Check_Name - 1)); + + -- For non-standard names added by pragma Check_Name, search table + + else + for J in All_Checks + 1 .. Check_Names.Last loop + if Check_Names.Table (J) = N then + return J; + end if; + end loop; + end if; + + -- No matching name found + + return No_Check_Id; + end Get_Check_Id; + + --------------------- + -- Get_Discriminal -- + --------------------- + + function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (E); + D : Entity_Id; + Sc : Entity_Id; + + begin + -- The bound can be a bona fide parameter of a protected operation, + -- rather than a prival encoded as an in-parameter. + + if No (Discriminal_Link (Entity (Bound))) then + return Bound; + end if; + + -- Climb the scope stack looking for an enclosing protected type. If + -- we run out of scopes, return the bound itself. + + Sc := Scope (E); + while Present (Sc) loop + if Sc = Standard_Standard then + return Bound; + + elsif Ekind (Sc) = E_Protected_Type then + exit; + end if; + + Sc := Scope (Sc); + end loop; + + D := First_Discriminant (Sc); + while Present (D) loop + if Chars (D) = Chars (Bound) then + return New_Occurrence_Of (Discriminal (D), Loc); + end if; + + Next_Discriminant (D); + end loop; + + return Bound; + end Get_Discriminal; + + ---------------------- + -- Get_Range_Checks -- + ---------------------- + + function Get_Range_Checks + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty; + Warn_Node : Node_Id := Empty) return Check_Result + is + begin + return Selected_Range_Checks + (Ck_Node, Target_Typ, Source_Typ, Warn_Node); + end Get_Range_Checks; + + ------------------ + -- Guard_Access -- + ------------------ + + function Guard_Access + (Cond : Node_Id; + Loc : Source_Ptr; + Ck_Node : Node_Id) return Node_Id + is + begin + if Nkind (Cond) = N_Or_Else then + Set_Paren_Count (Cond, 1); + end if; + + if Nkind (Ck_Node) = N_Allocator then + return Cond; + else + return + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Ne (Loc, + Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node), + Right_Opnd => Make_Null (Loc)), + Right_Opnd => Cond); + end if; + end Guard_Access; + + ----------------------------- + -- Index_Checks_Suppressed -- + ----------------------------- + + function Index_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + if Present (E) and then Checks_May_Be_Suppressed (E) then + return Is_Check_Suppressed (E, Index_Check); + else + return Scope_Suppress (Index_Check); + end if; + end Index_Checks_Suppressed; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + for J in Determine_Range_Cache_N'Range loop + Determine_Range_Cache_N (J) := Empty; + end loop; + + Check_Names.Init; + + for J in Int range 1 .. All_Checks loop + Check_Names.Append (Name_Id (Int (First_Check_Name) + J - 1)); + end loop; + end Initialize; + + ------------------------- + -- Insert_Range_Checks -- + ------------------------- + + procedure Insert_Range_Checks + (Checks : Check_Result; + Node : Node_Id; + Suppress_Typ : Entity_Id; + Static_Sloc : Source_Ptr := No_Location; + Flag_Node : Node_Id := Empty; + Do_Before : Boolean := False) + is + Internal_Flag_Node : Node_Id := Flag_Node; + Internal_Static_Sloc : Source_Ptr := Static_Sloc; + + Check_Node : Node_Id; + Checks_On : constant Boolean := + (not Index_Checks_Suppressed (Suppress_Typ)) + or else + (not Range_Checks_Suppressed (Suppress_Typ)); + + begin + -- For now we just return if Checks_On is false, however this should be + -- enhanced to check for an always True value in the condition and to + -- generate a compilation warning??? + + if not Expander_Active or else not Checks_On then + return; + end if; + + if Static_Sloc = No_Location then + Internal_Static_Sloc := Sloc (Node); + end if; + + if No (Flag_Node) then + Internal_Flag_Node := Node; + end if; + + for J in 1 .. 2 loop + exit when No (Checks (J)); + + if Nkind (Checks (J)) = N_Raise_Constraint_Error + and then Present (Condition (Checks (J))) + then + if not Has_Dynamic_Range_Check (Internal_Flag_Node) then + Check_Node := Checks (J); + Mark_Rewrite_Insertion (Check_Node); + + if Do_Before then + Insert_Before_And_Analyze (Node, Check_Node); + else + Insert_After_And_Analyze (Node, Check_Node); + end if; + + Set_Has_Dynamic_Range_Check (Internal_Flag_Node); + end if; + + else + Check_Node := + Make_Raise_Constraint_Error (Internal_Static_Sloc, + Reason => CE_Range_Check_Failed); + Mark_Rewrite_Insertion (Check_Node); + + if Do_Before then + Insert_Before_And_Analyze (Node, Check_Node); + else + Insert_After_And_Analyze (Node, Check_Node); + end if; + end if; + end loop; + end Insert_Range_Checks; + + ------------------------ + -- Insert_Valid_Check -- + ------------------------ + + procedure Insert_Valid_Check (Expr : Node_Id) is + Loc : constant Source_Ptr := Sloc (Expr); + Exp : Node_Id; + + begin + -- Do not insert if checks off, or if not checking validity or + -- if expression is known to be valid + + if not Validity_Checks_On + or else Range_Or_Validity_Checks_Suppressed (Expr) + or else Expr_Known_Valid (Expr) + then + return; + end if; + + -- If we have a checked conversion, then validity check applies to + -- the expression inside the conversion, not the result, since if + -- the expression inside is valid, then so is the conversion result. + + Exp := Expr; + while Nkind (Exp) = N_Type_Conversion loop + Exp := Expression (Exp); + end loop; + + -- We are about to insert the validity check for Exp. We save and + -- reset the Do_Range_Check flag over this validity check, and then + -- put it back for the final original reference (Exp may be rewritten). + + declare + DRC : constant Boolean := Do_Range_Check (Exp); + + begin + Set_Do_Range_Check (Exp, False); + + -- Force evaluation to avoid multiple reads for atomic/volatile + + if Is_Entity_Name (Exp) + and then Is_Volatile (Entity (Exp)) + then + Force_Evaluation (Exp, Name_Req => True); + end if; + + -- Insert the validity check. Note that we do this with validity + -- checks turned off, to avoid recursion, we do not want validity + -- checks on the validity checking code itself! + + Insert_Action + (Expr, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr_No_Checks (Exp, Name_Req => True), + Attribute_Name => Name_Valid)), + Reason => CE_Invalid_Data), + Suppress => Validity_Check); + + -- If the expression is a reference to an element of a bit-packed + -- array, then it is rewritten as a renaming declaration. If the + -- expression is an actual in a call, it has not been expanded, + -- waiting for the proper point at which to do it. The same happens + -- with renamings, so that we have to force the expansion now. This + -- non-local complication is due to code in exp_ch2,adb, exp_ch4.adb + -- and exp_ch6.adb. + + if Is_Entity_Name (Exp) + and then Nkind (Parent (Entity (Exp))) = + N_Object_Renaming_Declaration + then + declare + Old_Exp : constant Node_Id := Name (Parent (Entity (Exp))); + begin + if Nkind (Old_Exp) = N_Indexed_Component + and then Is_Bit_Packed_Array (Etype (Prefix (Old_Exp))) + then + Expand_Packed_Element_Reference (Old_Exp); + end if; + end; + end if; + + -- Put back the Do_Range_Check flag on the resulting (possibly + -- rewritten) expression. + + -- Note: it might be thought that a validity check is not required + -- when a range check is present, but that's not the case, because + -- the back end is allowed to assume for the range check that the + -- operand is within its declared range (an assumption that validity + -- checking is all about NOT assuming!) + + -- Note: no need to worry about Possible_Local_Raise here, it will + -- already have been called if original node has Do_Range_Check set. + + Set_Do_Range_Check (Exp, DRC); + end; + end Insert_Valid_Check; + + ---------------------------------- + -- Install_Null_Excluding_Check -- + ---------------------------------- + + procedure Install_Null_Excluding_Check (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (Parent (N)); + Typ : constant Entity_Id := Etype (N); + + function Safe_To_Capture_In_Parameter_Value return Boolean; + -- Determines if it is safe to capture Known_Non_Null status for an + -- the entity referenced by node N. The caller ensures that N is indeed + -- an entity name. It is safe to capture the non-null status for an IN + -- parameter when the reference occurs within a declaration that is sure + -- to be executed as part of the declarative region. + + procedure Mark_Non_Null; + -- After installation of check, if the node in question is an entity + -- name, then mark this entity as non-null if possible. + + function Safe_To_Capture_In_Parameter_Value return Boolean is + E : constant Entity_Id := Entity (N); + S : constant Entity_Id := Current_Scope; + S_Par : Node_Id; + + begin + if Ekind (E) /= E_In_Parameter then + return False; + end if; + + -- Two initial context checks. We must be inside a subprogram body + -- with declarations and reference must not appear in nested scopes. + + if (Ekind (S) /= E_Function and then Ekind (S) /= E_Procedure) + or else Scope (E) /= S + then + return False; + end if; + + S_Par := Parent (Parent (S)); + + if Nkind (S_Par) /= N_Subprogram_Body + or else No (Declarations (S_Par)) + then + return False; + end if; + + declare + N_Decl : Node_Id; + P : Node_Id; + + begin + -- Retrieve the declaration node of N (if any). Note that N + -- may be a part of a complex initialization expression. + + P := Parent (N); + N_Decl := Empty; + while Present (P) loop + + -- If we have a short circuit form, and we are within the right + -- hand expression, we return false, since the right hand side + -- is not guaranteed to be elaborated. + + if Nkind (P) in N_Short_Circuit + and then N = Right_Opnd (P) + then + return False; + end if; + + -- Similarly, if we are in a conditional expression and not + -- part of the condition, then we return False, since neither + -- the THEN or ELSE expressions will always be elaborated. + + if Nkind (P) = N_Conditional_Expression + and then N /= First (Expressions (P)) + then + return False; + end if; + + -- If we are in a case expression, and not part of the + -- expression, then we return False, since a particular + -- branch may not always be elaborated + + if Nkind (P) = N_Case_Expression + and then N /= Expression (P) + then + return False; + end if; + + -- While traversing the parent chain, we find that N + -- belongs to a statement, thus it may never appear in + -- a declarative region. + + if Nkind (P) in N_Statement_Other_Than_Procedure_Call + or else Nkind (P) = N_Procedure_Call_Statement + then + return False; + end if; + + -- If we are at a declaration, record it and exit + + if Nkind (P) in N_Declaration + and then Nkind (P) not in N_Subprogram_Specification + then + N_Decl := P; + exit; + end if; + + P := Parent (P); + end loop; + + if No (N_Decl) then + return False; + end if; + + return List_Containing (N_Decl) = Declarations (S_Par); + end; + end Safe_To_Capture_In_Parameter_Value; + + ------------------- + -- Mark_Non_Null -- + ------------------- + + procedure Mark_Non_Null is + begin + -- Only case of interest is if node N is an entity name + + if Is_Entity_Name (N) then + + -- For sure, we want to clear an indication that this is known to + -- be null, since if we get past this check, it definitely is not! + + Set_Is_Known_Null (Entity (N), False); + + -- We can mark the entity as known to be non-null if either it is + -- safe to capture the value, or in the case of an IN parameter, + -- which is a constant, if the check we just installed is in the + -- declarative region of the subprogram body. In this latter case, + -- a check is decisive for the rest of the body if the expression + -- is sure to be elaborated, since we know we have to elaborate + -- all declarations before executing the body. + + -- Couldn't this always be part of Safe_To_Capture_Value ??? + + if Safe_To_Capture_Value (N, Entity (N)) + or else Safe_To_Capture_In_Parameter_Value + then + Set_Is_Known_Non_Null (Entity (N)); + end if; + end if; + end Mark_Non_Null; + + -- Start of processing for Install_Null_Excluding_Check + + begin + pragma Assert (Is_Access_Type (Typ)); + + -- No check inside a generic (why not???) + + if Inside_A_Generic then + return; + end if; + + -- No check needed if known to be non-null + + if Known_Non_Null (N) then + return; + end if; + + -- If known to be null, here is where we generate a compile time check + + if Known_Null (N) then + + -- Avoid generating warning message inside init procs + + if not Inside_Init_Proc then + Apply_Compile_Time_Constraint_Error + (N, + "null value not allowed here?", + CE_Access_Check_Failed); + else + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Reason => CE_Access_Check_Failed)); + end if; + + Mark_Non_Null; + return; + end if; + + -- If entity is never assigned, for sure a warning is appropriate + + if Is_Entity_Name (N) then + Check_Unset_Reference (N); + end if; + + -- No check needed if checks are suppressed on the range. Note that we + -- don't set Is_Known_Non_Null in this case (we could legitimately do + -- so, since the program is erroneous, but we don't like to casually + -- propagate such conclusions from erroneosity). + + if Access_Checks_Suppressed (Typ) then + return; + end if; + + -- No check needed for access to concurrent record types generated by + -- the expander. This is not just an optimization (though it does indeed + -- remove junk checks). It also avoids generation of junk warnings. + + if Nkind (N) in N_Has_Chars + and then Chars (N) = Name_uObject + and then Is_Concurrent_Record_Type + (Directly_Designated_Type (Etype (N))) + then + return; + end if; + + -- Otherwise install access check + + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => Duplicate_Subexpr_Move_Checks (N), + Right_Opnd => Make_Null (Loc)), + Reason => CE_Access_Check_Failed)); + + Mark_Non_Null; + end Install_Null_Excluding_Check; + + -------------------------- + -- Install_Static_Check -- + -------------------------- + + procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr) is + Stat : constant Boolean := Is_Static_Expression (R_Cno); + Typ : constant Entity_Id := Etype (R_Cno); + + begin + Rewrite (R_Cno, + Make_Raise_Constraint_Error (Loc, + Reason => CE_Range_Check_Failed)); + Set_Analyzed (R_Cno); + Set_Etype (R_Cno, Typ); + Set_Raises_Constraint_Error (R_Cno); + Set_Is_Static_Expression (R_Cno, Stat); + + -- Now deal with possible local raise handling + + Possible_Local_Raise (R_Cno, Standard_Constraint_Error); + end Install_Static_Check; + + --------------------- + -- Kill_All_Checks -- + --------------------- + + procedure Kill_All_Checks is + begin + if Debug_Flag_CC then + w ("Kill_All_Checks"); + end if; + + -- We reset the number of saved checks to zero, and also modify all + -- stack entries for statement ranges to indicate that the number of + -- checks at each level is now zero. + + Num_Saved_Checks := 0; + + -- Note: the Int'Min here avoids any possibility of J being out of + -- range when called from e.g. Conditional_Statements_Begin. + + for J in 1 .. Int'Min (Saved_Checks_TOS, Saved_Checks_Stack'Last) loop + Saved_Checks_Stack (J) := 0; + end loop; + end Kill_All_Checks; + + ----------------- + -- Kill_Checks -- + ----------------- + + procedure Kill_Checks (V : Entity_Id) is + begin + if Debug_Flag_CC then + w ("Kill_Checks for entity", Int (V)); + end if; + + for J in 1 .. Num_Saved_Checks loop + if Saved_Checks (J).Entity = V then + if Debug_Flag_CC then + w (" Checks killed for saved check ", J); + end if; + + Saved_Checks (J).Killed := True; + end if; + end loop; + end Kill_Checks; + + ------------------------------ + -- Length_Checks_Suppressed -- + ------------------------------ + + function Length_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + if Present (E) and then Checks_May_Be_Suppressed (E) then + return Is_Check_Suppressed (E, Length_Check); + else + return Scope_Suppress (Length_Check); + end if; + end Length_Checks_Suppressed; + + -------------------------------- + -- Overflow_Checks_Suppressed -- + -------------------------------- + + function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + if Present (E) and then Checks_May_Be_Suppressed (E) then + return Is_Check_Suppressed (E, Overflow_Check); + else + return Scope_Suppress (Overflow_Check); + end if; + end Overflow_Checks_Suppressed; + + ----------------------------- + -- Range_Checks_Suppressed -- + ----------------------------- + + function Range_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + if Present (E) then + + -- Note: for now we always suppress range checks on Vax float types, + -- since Gigi does not know how to generate these checks. + + if Vax_Float (E) then + return True; + elsif Kill_Range_Checks (E) then + return True; + elsif Checks_May_Be_Suppressed (E) then + return Is_Check_Suppressed (E, Range_Check); + end if; + end if; + + return Scope_Suppress (Range_Check); + end Range_Checks_Suppressed; + + ----------------------------------------- + -- Range_Or_Validity_Checks_Suppressed -- + ----------------------------------------- + + -- Note: the coding would be simpler here if we simply made appropriate + -- calls to Range/Validity_Checks_Suppressed, but that would result in + -- duplicated checks which we prefer to avoid. + + function Range_Or_Validity_Checks_Suppressed + (Expr : Node_Id) return Boolean + is + begin + -- Immediate return if scope checks suppressed for either check + + if Scope_Suppress (Range_Check) or Scope_Suppress (Validity_Check) then + return True; + end if; + + -- If no expression, that's odd, decide that checks are suppressed, + -- since we don't want anyone trying to do checks in this case, which + -- is most likely the result of some other error. + + if No (Expr) then + return True; + end if; + + -- Expression is present, so perform suppress checks on type + + declare + Typ : constant Entity_Id := Etype (Expr); + begin + if Vax_Float (Typ) then + return True; + elsif Checks_May_Be_Suppressed (Typ) + and then (Is_Check_Suppressed (Typ, Range_Check) + or else + Is_Check_Suppressed (Typ, Validity_Check)) + then + return True; + end if; + end; + + -- If expression is an entity name, perform checks on this entity + + if Is_Entity_Name (Expr) then + declare + Ent : constant Entity_Id := Entity (Expr); + begin + if Checks_May_Be_Suppressed (Ent) then + return Is_Check_Suppressed (Ent, Range_Check) + or else Is_Check_Suppressed (Ent, Validity_Check); + end if; + end; + end if; + + -- If we fall through, no checks suppressed + + return False; + end Range_Or_Validity_Checks_Suppressed; + + ------------------- + -- Remove_Checks -- + ------------------- + + procedure Remove_Checks (Expr : Node_Id) is + function Process (N : Node_Id) return Traverse_Result; + -- Process a single node during the traversal + + procedure Traverse is new Traverse_Proc (Process); + -- The traversal procedure itself + + ------------- + -- Process -- + ------------- + + function Process (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) not in N_Subexpr then + return Skip; + end if; + + Set_Do_Range_Check (N, False); + + case Nkind (N) is + when N_And_Then => + Traverse (Left_Opnd (N)); + return Skip; + + when N_Attribute_Reference => + Set_Do_Overflow_Check (N, False); + + when N_Function_Call => + Set_Do_Tag_Check (N, False); + + when N_Op => + Set_Do_Overflow_Check (N, False); + + case Nkind (N) is + when N_Op_Divide => + Set_Do_Division_Check (N, False); + + when N_Op_And => + Set_Do_Length_Check (N, False); + + when N_Op_Mod => + Set_Do_Division_Check (N, False); + + when N_Op_Or => + Set_Do_Length_Check (N, False); + + when N_Op_Rem => + Set_Do_Division_Check (N, False); + + when N_Op_Xor => + Set_Do_Length_Check (N, False); + + when others => + null; + end case; + + when N_Or_Else => + Traverse (Left_Opnd (N)); + return Skip; + + when N_Selected_Component => + Set_Do_Discriminant_Check (N, False); + + when N_Type_Conversion => + Set_Do_Length_Check (N, False); + Set_Do_Tag_Check (N, False); + Set_Do_Overflow_Check (N, False); + + when others => + null; + end case; + + return OK; + end Process; + + -- Start of processing for Remove_Checks + + begin + Traverse (Expr); + end Remove_Checks; + + ---------------------------- + -- Selected_Length_Checks -- + ---------------------------- + + function Selected_Length_Checks + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id; + Warn_Node : Node_Id) return Check_Result + is + Loc : constant Source_Ptr := Sloc (Ck_Node); + S_Typ : Entity_Id; + T_Typ : Entity_Id; + Expr_Actual : Node_Id; + Exptyp : Entity_Id; + Cond : Node_Id := Empty; + Do_Access : Boolean := False; + Wnode : Node_Id := Warn_Node; + Ret_Result : Check_Result := (Empty, Empty); + Num_Checks : Natural := 0; + + procedure Add_Check (N : Node_Id); + -- Adds the action given to Ret_Result if N is non-Empty + + function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id; + function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id; + -- Comments required ??? + + function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean; + -- True for equal literals and for nodes that denote the same constant + -- entity, even if its value is not a static constant. This includes the + -- case of a discriminal reference within an init proc. Removes some + -- obviously superfluous checks. + + function Length_E_Cond + (Exptyp : Entity_Id; + Typ : Entity_Id; + Indx : Nat) return Node_Id; + -- Returns expression to compute: + -- Typ'Length /= Exptyp'Length + + function Length_N_Cond + (Expr : Node_Id; + Typ : Entity_Id; + Indx : Nat) return Node_Id; + -- Returns expression to compute: + -- Typ'Length /= Expr'Length + + --------------- + -- Add_Check -- + --------------- + + procedure Add_Check (N : Node_Id) is + begin + if Present (N) then + + -- For now, ignore attempt to place more than 2 checks ??? + + if Num_Checks = 2 then + return; + end if; + + pragma Assert (Num_Checks <= 1); + Num_Checks := Num_Checks + 1; + Ret_Result (Num_Checks) := N; + end if; + end Add_Check; + + ------------------ + -- Get_E_Length -- + ------------------ + + function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is + SE : constant Entity_Id := Scope (E); + N : Node_Id; + E1 : Entity_Id := E; + + begin + if Ekind (Scope (E)) = E_Record_Type + and then Has_Discriminants (Scope (E)) + then + N := Build_Discriminal_Subtype_Of_Component (E); + + if Present (N) then + Insert_Action (Ck_Node, N); + E1 := Defining_Identifier (N); + end if; + end if; + + if Ekind (E1) = E_String_Literal_Subtype then + return + Make_Integer_Literal (Loc, + Intval => String_Literal_Length (E1)); + + elsif SE /= Standard_Standard + and then Ekind (Scope (SE)) = E_Protected_Type + and then Has_Discriminants (Scope (SE)) + and then Has_Completion (Scope (SE)) + and then not Inside_Init_Proc + then + -- If the type whose length is needed is a private component + -- constrained by a discriminant, we must expand the 'Length + -- attribute into an explicit computation, using the discriminal + -- of the current protected operation. This is because the actual + -- type of the prival is constructed after the protected opera- + -- tion has been fully expanded. + + declare + Indx_Type : Node_Id; + Lo : Node_Id; + Hi : Node_Id; + Do_Expand : Boolean := False; + + begin + Indx_Type := First_Index (E); + + for J in 1 .. Indx - 1 loop + Next_Index (Indx_Type); + end loop; + + Get_Index_Bounds (Indx_Type, Lo, Hi); + + if Nkind (Lo) = N_Identifier + and then Ekind (Entity (Lo)) = E_In_Parameter + then + Lo := Get_Discriminal (E, Lo); + Do_Expand := True; + end if; + + if Nkind (Hi) = N_Identifier + and then Ekind (Entity (Hi)) = E_In_Parameter + then + Hi := Get_Discriminal (E, Hi); + Do_Expand := True; + end if; + + if Do_Expand then + if not Is_Entity_Name (Lo) then + Lo := Duplicate_Subexpr_No_Checks (Lo); + end if; + + if not Is_Entity_Name (Hi) then + Lo := Duplicate_Subexpr_No_Checks (Hi); + end if; + + N := + Make_Op_Add (Loc, + Left_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => Hi, + Right_Opnd => Lo), + + Right_Opnd => Make_Integer_Literal (Loc, 1)); + return N; + + else + N := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => + New_Occurrence_Of (E1, Loc)); + + if Indx > 1 then + Set_Expressions (N, New_List ( + Make_Integer_Literal (Loc, Indx))); + end if; + + return N; + end if; + end; + + else + N := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => + New_Occurrence_Of (E1, Loc)); + + if Indx > 1 then + Set_Expressions (N, New_List ( + Make_Integer_Literal (Loc, Indx))); + end if; + + return N; + end if; + end Get_E_Length; + + ------------------ + -- Get_N_Length -- + ------------------ + + function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id is + begin + return + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => + Duplicate_Subexpr_No_Checks (N, Name_Req => True), + Expressions => New_List ( + Make_Integer_Literal (Loc, Indx))); + end Get_N_Length; + + ------------------- + -- Length_E_Cond -- + ------------------- + + function Length_E_Cond + (Exptyp : Entity_Id; + Typ : Entity_Id; + Indx : Nat) return Node_Id + is + begin + return + Make_Op_Ne (Loc, + Left_Opnd => Get_E_Length (Typ, Indx), + Right_Opnd => Get_E_Length (Exptyp, Indx)); + end Length_E_Cond; + + ------------------- + -- Length_N_Cond -- + ------------------- + + function Length_N_Cond + (Expr : Node_Id; + Typ : Entity_Id; + Indx : Nat) return Node_Id + is + begin + return + Make_Op_Ne (Loc, + Left_Opnd => Get_E_Length (Typ, Indx), + Right_Opnd => Get_N_Length (Expr, Indx)); + end Length_N_Cond; + + ----------------- + -- Same_Bounds -- + ----------------- + + function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean is + begin + return + (Nkind (L) = N_Integer_Literal + and then Nkind (R) = N_Integer_Literal + and then Intval (L) = Intval (R)) + + or else + (Is_Entity_Name (L) + and then Ekind (Entity (L)) = E_Constant + and then ((Is_Entity_Name (R) + and then Entity (L) = Entity (R)) + or else + (Nkind (R) = N_Type_Conversion + and then Is_Entity_Name (Expression (R)) + and then Entity (L) = Entity (Expression (R))))) + + or else + (Is_Entity_Name (R) + and then Ekind (Entity (R)) = E_Constant + and then Nkind (L) = N_Type_Conversion + and then Is_Entity_Name (Expression (L)) + and then Entity (R) = Entity (Expression (L))) + + or else + (Is_Entity_Name (L) + and then Is_Entity_Name (R) + and then Entity (L) = Entity (R) + and then Ekind (Entity (L)) = E_In_Parameter + and then Inside_Init_Proc); + end Same_Bounds; + + -- Start of processing for Selected_Length_Checks + + begin + if not Expander_Active then + return Ret_Result; + end if; + + if Target_Typ = Any_Type + or else Target_Typ = Any_Composite + or else Raises_Constraint_Error (Ck_Node) + then + return Ret_Result; + end if; + + if No (Wnode) then + Wnode := Ck_Node; + end if; + + T_Typ := Target_Typ; + + if No (Source_Typ) then + S_Typ := Etype (Ck_Node); + else + S_Typ := Source_Typ; + end if; + + if S_Typ = Any_Type or else S_Typ = Any_Composite then + return Ret_Result; + end if; + + if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then + S_Typ := Designated_Type (S_Typ); + T_Typ := Designated_Type (T_Typ); + Do_Access := True; + + -- A simple optimization for the null case + + if Known_Null (Ck_Node) then + return Ret_Result; + end if; + end if; + + if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then + if Is_Constrained (T_Typ) then + + -- The checking code to be generated will freeze the + -- corresponding array type. However, we must freeze the + -- type now, so that the freeze node does not appear within + -- the generated conditional expression, but ahead of it. + + Freeze_Before (Ck_Node, T_Typ); + + Expr_Actual := Get_Referenced_Object (Ck_Node); + Exptyp := Get_Actual_Subtype (Ck_Node); + + if Is_Access_Type (Exptyp) then + Exptyp := Designated_Type (Exptyp); + end if; + + -- String_Literal case. This needs to be handled specially be- + -- cause no index types are available for string literals. The + -- condition is simply: + + -- T_Typ'Length = string-literal-length + + if Nkind (Expr_Actual) = N_String_Literal + and then Ekind (Etype (Expr_Actual)) = E_String_Literal_Subtype + then + Cond := + Make_Op_Ne (Loc, + Left_Opnd => Get_E_Length (T_Typ, 1), + Right_Opnd => + Make_Integer_Literal (Loc, + Intval => + String_Literal_Length (Etype (Expr_Actual)))); + + -- General array case. Here we have a usable actual subtype for + -- the expression, and the condition is built from the two types + -- (Do_Length): + + -- T_Typ'Length /= Exptyp'Length or else + -- T_Typ'Length (2) /= Exptyp'Length (2) or else + -- T_Typ'Length (3) /= Exptyp'Length (3) or else + -- ... + + elsif Is_Constrained (Exptyp) then + declare + Ndims : constant Nat := Number_Dimensions (T_Typ); + + L_Index : Node_Id; + R_Index : Node_Id; + L_Low : Node_Id; + L_High : Node_Id; + R_Low : Node_Id; + R_High : Node_Id; + L_Length : Uint; + R_Length : Uint; + Ref_Node : Node_Id; + + begin + -- At the library level, we need to ensure that the type of + -- the object is elaborated before the check itself is + -- emitted. This is only done if the object is in the + -- current compilation unit, otherwise the type is frozen + -- and elaborated in its unit. + + if Is_Itype (Exptyp) + and then + Ekind (Cunit_Entity (Current_Sem_Unit)) = E_Package + and then + not In_Package_Body (Cunit_Entity (Current_Sem_Unit)) + and then In_Open_Scopes (Scope (Exptyp)) + then + Ref_Node := Make_Itype_Reference (Sloc (Ck_Node)); + Set_Itype (Ref_Node, Exptyp); + Insert_Action (Ck_Node, Ref_Node); + end if; + + L_Index := First_Index (T_Typ); + R_Index := First_Index (Exptyp); + + for Indx in 1 .. Ndims loop + if not (Nkind (L_Index) = N_Raise_Constraint_Error + or else + Nkind (R_Index) = N_Raise_Constraint_Error) + then + Get_Index_Bounds (L_Index, L_Low, L_High); + Get_Index_Bounds (R_Index, R_Low, R_High); + + -- Deal with compile time length check. Note that we + -- skip this in the access case, because the access + -- value may be null, so we cannot know statically. + + if not Do_Access + and then Compile_Time_Known_Value (L_Low) + and then Compile_Time_Known_Value (L_High) + and then Compile_Time_Known_Value (R_Low) + and then Compile_Time_Known_Value (R_High) + then + if Expr_Value (L_High) >= Expr_Value (L_Low) then + L_Length := Expr_Value (L_High) - + Expr_Value (L_Low) + 1; + else + L_Length := UI_From_Int (0); + end if; + + if Expr_Value (R_High) >= Expr_Value (R_Low) then + R_Length := Expr_Value (R_High) - + Expr_Value (R_Low) + 1; + else + R_Length := UI_From_Int (0); + end if; + + if L_Length > R_Length then + Add_Check + (Compile_Time_Constraint_Error + (Wnode, "too few elements for}?", T_Typ)); + + elsif L_Length < R_Length then + Add_Check + (Compile_Time_Constraint_Error + (Wnode, "too many elements for}?", T_Typ)); + end if; + + -- The comparison for an individual index subtype + -- is omitted if the corresponding index subtypes + -- statically match, since the result is known to + -- be true. Note that this test is worth while even + -- though we do static evaluation, because non-static + -- subtypes can statically match. + + elsif not + Subtypes_Statically_Match + (Etype (L_Index), Etype (R_Index)) + + and then not + (Same_Bounds (L_Low, R_Low) + and then Same_Bounds (L_High, R_High)) + then + Evolve_Or_Else + (Cond, Length_E_Cond (Exptyp, T_Typ, Indx)); + end if; + + Next (L_Index); + Next (R_Index); + end if; + end loop; + end; + + -- Handle cases where we do not get a usable actual subtype that + -- is constrained. This happens for example in the function call + -- and explicit dereference cases. In these cases, we have to get + -- the length or range from the expression itself, making sure we + -- do not evaluate it more than once. + + -- Here Ck_Node is the original expression, or more properly the + -- result of applying Duplicate_Expr to the original tree, forcing + -- the result to be a name. + + else + declare + Ndims : constant Nat := Number_Dimensions (T_Typ); + + begin + -- Build the condition for the explicit dereference case + + for Indx in 1 .. Ndims loop + Evolve_Or_Else + (Cond, Length_N_Cond (Ck_Node, T_Typ, Indx)); + end loop; + end; + end if; + end if; + end if; + + -- Construct the test and insert into the tree + + if Present (Cond) then + if Do_Access then + Cond := Guard_Access (Cond, Loc, Ck_Node); + end if; + + Add_Check + (Make_Raise_Constraint_Error (Loc, + Condition => Cond, + Reason => CE_Length_Check_Failed)); + end if; + + return Ret_Result; + end Selected_Length_Checks; + + --------------------------- + -- Selected_Range_Checks -- + --------------------------- + + function Selected_Range_Checks + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id; + Warn_Node : Node_Id) return Check_Result + is + Loc : constant Source_Ptr := Sloc (Ck_Node); + S_Typ : Entity_Id; + T_Typ : Entity_Id; + Expr_Actual : Node_Id; + Exptyp : Entity_Id; + Cond : Node_Id := Empty; + Do_Access : Boolean := False; + Wnode : Node_Id := Warn_Node; + Ret_Result : Check_Result := (Empty, Empty); + Num_Checks : Integer := 0; + + procedure Add_Check (N : Node_Id); + -- Adds the action given to Ret_Result if N is non-Empty + + function Discrete_Range_Cond + (Expr : Node_Id; + Typ : Entity_Id) return Node_Id; + -- Returns expression to compute: + -- Low_Bound (Expr) < Typ'First + -- or else + -- High_Bound (Expr) > Typ'Last + + function Discrete_Expr_Cond + (Expr : Node_Id; + Typ : Entity_Id) return Node_Id; + -- Returns expression to compute: + -- Expr < Typ'First + -- or else + -- Expr > Typ'Last + + function Get_E_First_Or_Last + (Loc : Source_Ptr; + E : Entity_Id; + Indx : Nat; + Nam : Name_Id) return Node_Id; + -- Returns an attribute reference + -- E'First or E'Last + -- with a source location of Loc. + -- + -- Nam is Name_First or Name_Last, according to which attribute is + -- desired. If Indx is non-zero, it is passed as a literal in the + -- Expressions of the attribute reference (identifying the desired + -- array dimension). + + function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id; + function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id; + -- Returns expression to compute: + -- N'First or N'Last using Duplicate_Subexpr_No_Checks + + function Range_E_Cond + (Exptyp : Entity_Id; + Typ : Entity_Id; + Indx : Nat) + return Node_Id; + -- Returns expression to compute: + -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last + + function Range_Equal_E_Cond + (Exptyp : Entity_Id; + Typ : Entity_Id; + Indx : Nat) return Node_Id; + -- Returns expression to compute: + -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last + + function Range_N_Cond + (Expr : Node_Id; + Typ : Entity_Id; + Indx : Nat) return Node_Id; + -- Return expression to compute: + -- Expr'First < Typ'First or else Expr'Last > Typ'Last + + --------------- + -- Add_Check -- + --------------- + + procedure Add_Check (N : Node_Id) is + begin + if Present (N) then + + -- For now, ignore attempt to place more than 2 checks ??? + + if Num_Checks = 2 then + return; + end if; + + pragma Assert (Num_Checks <= 1); + Num_Checks := Num_Checks + 1; + Ret_Result (Num_Checks) := N; + end if; + end Add_Check; + + ------------------------- + -- Discrete_Expr_Cond -- + ------------------------- + + function Discrete_Expr_Cond + (Expr : Node_Id; + Typ : Entity_Id) return Node_Id + is + begin + return + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Lt (Loc, + Left_Opnd => + Convert_To (Base_Type (Typ), + Duplicate_Subexpr_No_Checks (Expr)), + Right_Opnd => + Convert_To (Base_Type (Typ), + Get_E_First_Or_Last (Loc, Typ, 0, Name_First))), + + Right_Opnd => + Make_Op_Gt (Loc, + Left_Opnd => + Convert_To (Base_Type (Typ), + Duplicate_Subexpr_No_Checks (Expr)), + Right_Opnd => + Convert_To + (Base_Type (Typ), + Get_E_First_Or_Last (Loc, Typ, 0, Name_Last)))); + end Discrete_Expr_Cond; + + ------------------------- + -- Discrete_Range_Cond -- + ------------------------- + + function Discrete_Range_Cond + (Expr : Node_Id; + Typ : Entity_Id) return Node_Id + is + LB : Node_Id := Low_Bound (Expr); + HB : Node_Id := High_Bound (Expr); + + Left_Opnd : Node_Id; + Right_Opnd : Node_Id; + + begin + if Nkind (LB) = N_Identifier + and then Ekind (Entity (LB)) = E_Discriminant + then + LB := New_Occurrence_Of (Discriminal (Entity (LB)), Loc); + end if; + + if Nkind (HB) = N_Identifier + and then Ekind (Entity (HB)) = E_Discriminant + then + HB := New_Occurrence_Of (Discriminal (Entity (HB)), Loc); + end if; + + Left_Opnd := + Make_Op_Lt (Loc, + Left_Opnd => + Convert_To + (Base_Type (Typ), Duplicate_Subexpr_No_Checks (LB)), + + Right_Opnd => + Convert_To + (Base_Type (Typ), + Get_E_First_Or_Last (Loc, Typ, 0, Name_First))); + + if Base_Type (Typ) = Typ then + return Left_Opnd; + + elsif Compile_Time_Known_Value (High_Bound (Scalar_Range (Typ))) + and then + Compile_Time_Known_Value (High_Bound (Scalar_Range + (Base_Type (Typ)))) + then + if Is_Floating_Point_Type (Typ) then + if Expr_Value_R (High_Bound (Scalar_Range (Typ))) = + Expr_Value_R (High_Bound (Scalar_Range (Base_Type (Typ)))) + then + return Left_Opnd; + end if; + + else + if Expr_Value (High_Bound (Scalar_Range (Typ))) = + Expr_Value (High_Bound (Scalar_Range (Base_Type (Typ)))) + then + return Left_Opnd; + end if; + end if; + end if; + + Right_Opnd := + Make_Op_Gt (Loc, + Left_Opnd => + Convert_To + (Base_Type (Typ), Duplicate_Subexpr_No_Checks (HB)), + + Right_Opnd => + Convert_To + (Base_Type (Typ), + Get_E_First_Or_Last (Loc, Typ, 0, Name_Last))); + + return Make_Or_Else (Loc, Left_Opnd, Right_Opnd); + end Discrete_Range_Cond; + + ------------------------- + -- Get_E_First_Or_Last -- + ------------------------- + + function Get_E_First_Or_Last + (Loc : Source_Ptr; + E : Entity_Id; + Indx : Nat; + Nam : Name_Id) return Node_Id + is + Exprs : List_Id; + begin + if Indx > 0 then + Exprs := New_List (Make_Integer_Literal (Loc, UI_From_Int (Indx))); + else + Exprs := No_List; + end if; + + return Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (E, Loc), + Attribute_Name => Nam, + Expressions => Exprs); + end Get_E_First_Or_Last; + + ----------------- + -- Get_N_First -- + ----------------- + + function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id is + begin + return + Make_Attribute_Reference (Loc, + Attribute_Name => Name_First, + Prefix => + Duplicate_Subexpr_No_Checks (N, Name_Req => True), + Expressions => New_List ( + Make_Integer_Literal (Loc, Indx))); + end Get_N_First; + + ---------------- + -- Get_N_Last -- + ---------------- + + function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id is + begin + return + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Last, + Prefix => + Duplicate_Subexpr_No_Checks (N, Name_Req => True), + Expressions => New_List ( + Make_Integer_Literal (Loc, Indx))); + end Get_N_Last; + + ------------------ + -- Range_E_Cond -- + ------------------ + + function Range_E_Cond + (Exptyp : Entity_Id; + Typ : Entity_Id; + Indx : Nat) return Node_Id + is + begin + return + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Lt (Loc, + Left_Opnd => + Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First), + Right_Opnd => + Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)), + + Right_Opnd => + Make_Op_Gt (Loc, + Left_Opnd => + Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last), + Right_Opnd => + Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last))); + end Range_E_Cond; + + ------------------------ + -- Range_Equal_E_Cond -- + ------------------------ + + function Range_Equal_E_Cond + (Exptyp : Entity_Id; + Typ : Entity_Id; + Indx : Nat) return Node_Id + is + begin + return + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Ne (Loc, + Left_Opnd => + Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First), + Right_Opnd => + Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)), + + Right_Opnd => + Make_Op_Ne (Loc, + Left_Opnd => + Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last), + Right_Opnd => + Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last))); + end Range_Equal_E_Cond; + + ------------------ + -- Range_N_Cond -- + ------------------ + + function Range_N_Cond + (Expr : Node_Id; + Typ : Entity_Id; + Indx : Nat) return Node_Id + is + begin + return + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Lt (Loc, + Left_Opnd => + Get_N_First (Expr, Indx), + Right_Opnd => + Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)), + + Right_Opnd => + Make_Op_Gt (Loc, + Left_Opnd => + Get_N_Last (Expr, Indx), + Right_Opnd => + Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last))); + end Range_N_Cond; + + -- Start of processing for Selected_Range_Checks + + begin + if not Expander_Active then + return Ret_Result; + end if; + + if Target_Typ = Any_Type + or else Target_Typ = Any_Composite + or else Raises_Constraint_Error (Ck_Node) + then + return Ret_Result; + end if; + + if No (Wnode) then + Wnode := Ck_Node; + end if; + + T_Typ := Target_Typ; + + if No (Source_Typ) then + S_Typ := Etype (Ck_Node); + else + S_Typ := Source_Typ; + end if; + + if S_Typ = Any_Type or else S_Typ = Any_Composite then + return Ret_Result; + end if; + + -- The order of evaluating T_Typ before S_Typ seems to be critical + -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed + -- in, and since Node can be an N_Range node, it might be invalid. + -- Should there be an assert check somewhere for taking the Etype of + -- an N_Range node ??? + + if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then + S_Typ := Designated_Type (S_Typ); + T_Typ := Designated_Type (T_Typ); + Do_Access := True; + + -- A simple optimization for the null case + + if Known_Null (Ck_Node) then + return Ret_Result; + end if; + end if; + + -- For an N_Range Node, check for a null range and then if not + -- null generate a range check action. + + if Nkind (Ck_Node) = N_Range then + + -- There's no point in checking a range against itself + + if Ck_Node = Scalar_Range (T_Typ) then + return Ret_Result; + end if; + + declare + T_LB : constant Node_Id := Type_Low_Bound (T_Typ); + T_HB : constant Node_Id := Type_High_Bound (T_Typ); + Known_T_LB : constant Boolean := Compile_Time_Known_Value (T_LB); + Known_T_HB : constant Boolean := Compile_Time_Known_Value (T_HB); + + LB : Node_Id := Low_Bound (Ck_Node); + HB : Node_Id := High_Bound (Ck_Node); + Known_LB : Boolean; + Known_HB : Boolean; + + Null_Range : Boolean; + Out_Of_Range_L : Boolean; + Out_Of_Range_H : Boolean; + + begin + -- Compute what is known at compile time + + if Known_T_LB and Known_T_HB then + if Compile_Time_Known_Value (LB) then + Known_LB := True; + + -- There's no point in checking that a bound is within its + -- own range so pretend that it is known in this case. First + -- deal with low bound. + + elsif Ekind (Etype (LB)) = E_Signed_Integer_Subtype + and then Scalar_Range (Etype (LB)) = Scalar_Range (T_Typ) + then + LB := T_LB; + Known_LB := True; + + else + Known_LB := False; + end if; + + -- Likewise for the high bound + + if Compile_Time_Known_Value (HB) then + Known_HB := True; + + elsif Ekind (Etype (HB)) = E_Signed_Integer_Subtype + and then Scalar_Range (Etype (HB)) = Scalar_Range (T_Typ) + then + HB := T_HB; + Known_HB := True; + + else + Known_HB := False; + end if; + end if; + + -- Check for case where everything is static and we can do the + -- check at compile time. This is skipped if we have an access + -- type, since the access value may be null. + + -- ??? This code can be improved since you only need to know that + -- the two respective bounds (LB & T_LB or HB & T_HB) are known at + -- compile time to emit pertinent messages. + + if Known_T_LB and Known_T_HB and Known_LB and Known_HB + and not Do_Access + then + -- Floating-point case + + if Is_Floating_Point_Type (S_Typ) then + Null_Range := Expr_Value_R (HB) < Expr_Value_R (LB); + Out_Of_Range_L := + (Expr_Value_R (LB) < Expr_Value_R (T_LB)) + or else + (Expr_Value_R (LB) > Expr_Value_R (T_HB)); + + Out_Of_Range_H := + (Expr_Value_R (HB) > Expr_Value_R (T_HB)) + or else + (Expr_Value_R (HB) < Expr_Value_R (T_LB)); + + -- Fixed or discrete type case + + else + Null_Range := Expr_Value (HB) < Expr_Value (LB); + Out_Of_Range_L := + (Expr_Value (LB) < Expr_Value (T_LB)) + or else + (Expr_Value (LB) > Expr_Value (T_HB)); + + Out_Of_Range_H := + (Expr_Value (HB) > Expr_Value (T_HB)) + or else + (Expr_Value (HB) < Expr_Value (T_LB)); + end if; + + if not Null_Range then + if Out_Of_Range_L then + if No (Warn_Node) then + Add_Check + (Compile_Time_Constraint_Error + (Low_Bound (Ck_Node), + "static value out of range of}?", T_Typ)); + + else + Add_Check + (Compile_Time_Constraint_Error + (Wnode, + "static range out of bounds of}?", T_Typ)); + end if; + end if; + + if Out_Of_Range_H then + if No (Warn_Node) then + Add_Check + (Compile_Time_Constraint_Error + (High_Bound (Ck_Node), + "static value out of range of}?", T_Typ)); + + else + Add_Check + (Compile_Time_Constraint_Error + (Wnode, + "static range out of bounds of}?", T_Typ)); + end if; + end if; + end if; + + else + declare + LB : Node_Id := Low_Bound (Ck_Node); + HB : Node_Id := High_Bound (Ck_Node); + + begin + -- If either bound is a discriminant and we are within the + -- record declaration, it is a use of the discriminant in a + -- constraint of a component, and nothing can be checked + -- here. The check will be emitted within the init proc. + -- Before then, the discriminal has no real meaning. + -- Similarly, if the entity is a discriminal, there is no + -- check to perform yet. + + -- The same holds within a discriminated synchronized type, + -- where the discriminant may constrain a component or an + -- entry family. + + if Nkind (LB) = N_Identifier + and then Denotes_Discriminant (LB, True) + then + if Current_Scope = Scope (Entity (LB)) + or else Is_Concurrent_Type (Current_Scope) + or else Ekind (Entity (LB)) /= E_Discriminant + then + return Ret_Result; + else + LB := + New_Occurrence_Of (Discriminal (Entity (LB)), Loc); + end if; + end if; + + if Nkind (HB) = N_Identifier + and then Denotes_Discriminant (HB, True) + then + if Current_Scope = Scope (Entity (HB)) + or else Is_Concurrent_Type (Current_Scope) + or else Ekind (Entity (HB)) /= E_Discriminant + then + return Ret_Result; + else + HB := + New_Occurrence_Of (Discriminal (Entity (HB)), Loc); + end if; + end if; + + Cond := Discrete_Range_Cond (Ck_Node, T_Typ); + Set_Paren_Count (Cond, 1); + + Cond := + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Ge (Loc, + Left_Opnd => Duplicate_Subexpr_No_Checks (HB), + Right_Opnd => Duplicate_Subexpr_No_Checks (LB)), + Right_Opnd => Cond); + end; + end if; + end; + + elsif Is_Scalar_Type (S_Typ) then + + -- This somewhat duplicates what Apply_Scalar_Range_Check does, + -- except the above simply sets a flag in the node and lets + -- gigi generate the check base on the Etype of the expression. + -- Sometimes, however we want to do a dynamic check against an + -- arbitrary target type, so we do that here. + + if Ekind (Base_Type (S_Typ)) /= Ekind (Base_Type (T_Typ)) then + Cond := Discrete_Expr_Cond (Ck_Node, T_Typ); + + -- For literals, we can tell if the constraint error will be + -- raised at compile time, so we never need a dynamic check, but + -- if the exception will be raised, then post the usual warning, + -- and replace the literal with a raise constraint error + -- expression. As usual, skip this for access types + + elsif Compile_Time_Known_Value (Ck_Node) + and then not Do_Access + then + declare + LB : constant Node_Id := Type_Low_Bound (T_Typ); + UB : constant Node_Id := Type_High_Bound (T_Typ); + + Out_Of_Range : Boolean; + Static_Bounds : constant Boolean := + Compile_Time_Known_Value (LB) + and Compile_Time_Known_Value (UB); + + begin + -- Following range tests should use Sem_Eval routine ??? + + if Static_Bounds then + if Is_Floating_Point_Type (S_Typ) then + Out_Of_Range := + (Expr_Value_R (Ck_Node) < Expr_Value_R (LB)) + or else + (Expr_Value_R (Ck_Node) > Expr_Value_R (UB)); + + -- Fixed or discrete type + + else + Out_Of_Range := + Expr_Value (Ck_Node) < Expr_Value (LB) + or else + Expr_Value (Ck_Node) > Expr_Value (UB); + end if; + + -- Bounds of the type are static and the literal is out of + -- range so output a warning message. + + if Out_Of_Range then + if No (Warn_Node) then + Add_Check + (Compile_Time_Constraint_Error + (Ck_Node, + "static value out of range of}?", T_Typ)); + + else + Add_Check + (Compile_Time_Constraint_Error + (Wnode, + "static value out of range of}?", T_Typ)); + end if; + end if; + + else + Cond := Discrete_Expr_Cond (Ck_Node, T_Typ); + end if; + end; + + -- Here for the case of a non-static expression, we need a runtime + -- check unless the source type range is guaranteed to be in the + -- range of the target type. + + else + if not In_Subrange_Of (S_Typ, T_Typ) then + Cond := Discrete_Expr_Cond (Ck_Node, T_Typ); + end if; + end if; + end if; + + if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then + if Is_Constrained (T_Typ) then + + Expr_Actual := Get_Referenced_Object (Ck_Node); + Exptyp := Get_Actual_Subtype (Expr_Actual); + + if Is_Access_Type (Exptyp) then + Exptyp := Designated_Type (Exptyp); + end if; + + -- String_Literal case. This needs to be handled specially be- + -- cause no index types are available for string literals. The + -- condition is simply: + + -- T_Typ'Length = string-literal-length + + if Nkind (Expr_Actual) = N_String_Literal then + null; + + -- General array case. Here we have a usable actual subtype for + -- the expression, and the condition is built from the two types + + -- T_Typ'First < Exptyp'First or else + -- T_Typ'Last > Exptyp'Last or else + -- T_Typ'First(1) < Exptyp'First(1) or else + -- T_Typ'Last(1) > Exptyp'Last(1) or else + -- ... + + elsif Is_Constrained (Exptyp) then + declare + Ndims : constant Nat := Number_Dimensions (T_Typ); + + L_Index : Node_Id; + R_Index : Node_Id; + + begin + L_Index := First_Index (T_Typ); + R_Index := First_Index (Exptyp); + + for Indx in 1 .. Ndims loop + if not (Nkind (L_Index) = N_Raise_Constraint_Error + or else + Nkind (R_Index) = N_Raise_Constraint_Error) + then + -- Deal with compile time length check. Note that we + -- skip this in the access case, because the access + -- value may be null, so we cannot know statically. + + if not + Subtypes_Statically_Match + (Etype (L_Index), Etype (R_Index)) + then + -- If the target type is constrained then we + -- have to check for exact equality of bounds + -- (required for qualified expressions). + + if Is_Constrained (T_Typ) then + Evolve_Or_Else + (Cond, + Range_Equal_E_Cond (Exptyp, T_Typ, Indx)); + else + Evolve_Or_Else + (Cond, Range_E_Cond (Exptyp, T_Typ, Indx)); + end if; + end if; + + Next (L_Index); + Next (R_Index); + end if; + end loop; + end; + + -- Handle cases where we do not get a usable actual subtype that + -- is constrained. This happens for example in the function call + -- and explicit dereference cases. In these cases, we have to get + -- the length or range from the expression itself, making sure we + -- do not evaluate it more than once. + + -- Here Ck_Node is the original expression, or more properly the + -- result of applying Duplicate_Expr to the original tree, + -- forcing the result to be a name. + + else + declare + Ndims : constant Nat := Number_Dimensions (T_Typ); + + begin + -- Build the condition for the explicit dereference case + + for Indx in 1 .. Ndims loop + Evolve_Or_Else + (Cond, Range_N_Cond (Ck_Node, T_Typ, Indx)); + end loop; + end; + end if; + + else + -- For a conversion to an unconstrained array type, generate an + -- Action to check that the bounds of the source value are within + -- the constraints imposed by the target type (RM 4.6(38)). No + -- check is needed for a conversion to an access to unconstrained + -- array type, as 4.6(24.15/2) requires the designated subtypes + -- of the two access types to statically match. + + if Nkind (Parent (Ck_Node)) = N_Type_Conversion + and then not Do_Access + then + declare + Opnd_Index : Node_Id; + Targ_Index : Node_Id; + Opnd_Range : Node_Id; + + begin + Opnd_Index := First_Index (Get_Actual_Subtype (Ck_Node)); + Targ_Index := First_Index (T_Typ); + while Present (Opnd_Index) loop + + -- If the index is a range, use its bounds. If it is an + -- entity (as will be the case if it is a named subtype + -- or an itype created for a slice) retrieve its range. + + if Is_Entity_Name (Opnd_Index) + and then Is_Type (Entity (Opnd_Index)) + then + Opnd_Range := Scalar_Range (Entity (Opnd_Index)); + else + Opnd_Range := Opnd_Index; + end if; + + if Nkind (Opnd_Range) = N_Range then + if Is_In_Range + (Low_Bound (Opnd_Range), Etype (Targ_Index), + Assume_Valid => True) + and then + Is_In_Range + (High_Bound (Opnd_Range), Etype (Targ_Index), + Assume_Valid => True) + then + null; + + -- If null range, no check needed + + elsif + Compile_Time_Known_Value (High_Bound (Opnd_Range)) + and then + Compile_Time_Known_Value (Low_Bound (Opnd_Range)) + and then + Expr_Value (High_Bound (Opnd_Range)) < + Expr_Value (Low_Bound (Opnd_Range)) + then + null; + + elsif Is_Out_Of_Range + (Low_Bound (Opnd_Range), Etype (Targ_Index), + Assume_Valid => True) + or else + Is_Out_Of_Range + (High_Bound (Opnd_Range), Etype (Targ_Index), + Assume_Valid => True) + then + Add_Check + (Compile_Time_Constraint_Error + (Wnode, "value out of range of}?", T_Typ)); + + else + Evolve_Or_Else + (Cond, + Discrete_Range_Cond + (Opnd_Range, Etype (Targ_Index))); + end if; + end if; + + Next_Index (Opnd_Index); + Next_Index (Targ_Index); + end loop; + end; + end if; + end if; + end if; + + -- Construct the test and insert into the tree + + if Present (Cond) then + if Do_Access then + Cond := Guard_Access (Cond, Loc, Ck_Node); + end if; + + Add_Check + (Make_Raise_Constraint_Error (Loc, + Condition => Cond, + Reason => CE_Range_Check_Failed)); + end if; + + return Ret_Result; + end Selected_Range_Checks; + + ------------------------------- + -- Storage_Checks_Suppressed -- + ------------------------------- + + function Storage_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + if Present (E) and then Checks_May_Be_Suppressed (E) then + return Is_Check_Suppressed (E, Storage_Check); + else + return Scope_Suppress (Storage_Check); + end if; + end Storage_Checks_Suppressed; + + --------------------------- + -- Tag_Checks_Suppressed -- + --------------------------- + + function Tag_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + if Present (E) then + if Kill_Tag_Checks (E) then + return True; + elsif Checks_May_Be_Suppressed (E) then + return Is_Check_Suppressed (E, Tag_Check); + end if; + end if; + + return Scope_Suppress (Tag_Check); + end Tag_Checks_Suppressed; + + -------------------------- + -- Validity_Check_Range -- + -------------------------- + + procedure Validity_Check_Range (N : Node_Id) is + begin + if Validity_Checks_On and Validity_Check_Operands then + if Nkind (N) = N_Range then + Ensure_Valid (Low_Bound (N)); + Ensure_Valid (High_Bound (N)); + end if; + end if; + end Validity_Check_Range; + + -------------------------------- + -- Validity_Checks_Suppressed -- + -------------------------------- + + function Validity_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + if Present (E) and then Checks_May_Be_Suppressed (E) then + return Is_Check_Suppressed (E, Validity_Check); + else + return Scope_Suppress (Validity_Check); + end if; + end Validity_Checks_Suppressed; + +end Checks; diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads new file mode 100644 index 000000000..509a55c25 --- /dev/null +++ b/gcc/ada/checks.ads @@ -0,0 +1,721 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C H E C K S -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Package containing routines used to deal with runtime checks. These +-- routines are used both by the semantics and by the expander. In some +-- cases, checks are enabled simply by setting flags for gigi, and in +-- other cases the code for the check is expanded. + +-- The approach used for range and length checks, in regards to suppressed +-- checks, is to attempt to detect at compilation time that a constraint +-- error will occur. If this is detected a warning or error is issued and the +-- offending expression or statement replaced with a constraint error node. +-- This always occurs whether checks are suppressed or not. Dynamic range +-- checks are, of course, not inserted if checks are suppressed. + +with Namet; use Namet; +with Table; +with Types; use Types; +with Uintp; use Uintp; + +package Checks is + + procedure Initialize; + -- Called for each new main source program, to initialize internal + -- variables used in the package body of the Checks unit. + + function Access_Checks_Suppressed (E : Entity_Id) return Boolean; + function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean; + function Alignment_Checks_Suppressed (E : Entity_Id) return Boolean; + function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean; + function Division_Checks_Suppressed (E : Entity_Id) return Boolean; + function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean; + function Index_Checks_Suppressed (E : Entity_Id) return Boolean; + function Length_Checks_Suppressed (E : Entity_Id) return Boolean; + function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean; + function Range_Checks_Suppressed (E : Entity_Id) return Boolean; + function Storage_Checks_Suppressed (E : Entity_Id) return Boolean; + function Tag_Checks_Suppressed (E : Entity_Id) return Boolean; + function Validity_Checks_Suppressed (E : Entity_Id) return Boolean; + -- These functions check to see if the named check is suppressed, either + -- by an active scope suppress setting, or because the check has been + -- specifically suppressed for the given entity. If no entity is relevant + -- for the current check, then Empty is used as an argument. Note: the + -- reason we insist on specifying Empty is to force the caller to think + -- about whether there is any relevant entity that should be checked. + + ------------------------------------------- + -- Procedures to Activate Checking Flags -- + ------------------------------------------- + + procedure Activate_Division_Check (N : Node_Id); + pragma Inline (Activate_Division_Check); + -- Sets Do_Division_Check flag in node N, and handles possible local raise. + -- Always call this routine rather than calling Set_Do_Division_Check to + -- set an explicit value of True, to ensure handling the local raise case. + + procedure Activate_Overflow_Check (N : Node_Id); + pragma Inline (Activate_Overflow_Check); + -- Sets Do_Overflow_Check flag in node N, and handles possible local raise. + -- Always call this routine rather than calling Set_Do_Overflow_Check to + -- set an explicit value of True, to ensure handling the local raise case. + + procedure Activate_Range_Check (N : Node_Id); + pragma Inline (Activate_Range_Check); + -- Sets Do_Range_Check flag in node N, and handles possible local raise + -- Always call this routine rather than calling Set_Do_Range_Check to + -- set an explicit value of True, to ensure handling the local raise case. + + -------------------------------- + -- Procedures to Apply Checks -- + -------------------------------- + + -- General note on following checks. These checks are always active if + -- Expander_Active and not Inside_A_Generic. They are inactive and have + -- no effect Inside_A_Generic. In the case where not Expander_Active + -- and not Inside_A_Generic, most of them are inactive, but some of them + -- operate anyway since they may generate useful compile time warnings. + + procedure Apply_Access_Check (N : Node_Id); + -- Determines whether an expression node requires a runtime access + -- check and if so inserts the appropriate run-time check. + + procedure Apply_Accessibility_Check + (N : Node_Id; + Typ : Entity_Id; + Insert_Node : Node_Id); + -- Given a name N denoting an access parameter, emits a run-time + -- accessibility check (if necessary), checking that the level of + -- the object denoted by the access parameter is not deeper than the + -- level of the type Typ. Program_Error is raised if the check fails. + -- Insert_Node indicates the node where the check should be inserted. + + procedure Apply_Address_Clause_Check (E : Entity_Id; N : Node_Id); + -- E is the entity for an object which has an address clause. If checks + -- are enabled, then this procedure generates a check that the specified + -- address has an alignment consistent with the alignment of the object, + -- raising PE if this is not the case. The resulting check (if one is + -- generated) is inserted before node N. check is also made for the case of + -- a clear overlay situation that the size of the overlaying object is not + -- larger than the overlaid object. + + procedure Apply_Arithmetic_Overflow_Check (N : Node_Id); + -- Given a binary arithmetic operator (+ - *) expand a software integer + -- overflow check using range checks on a larger checking type or a call + -- to an appropriate runtime routine. This is used for all three operators + -- for the signed integer case, and for +/- in the fixed-point case. The + -- check is expanded only if Software_Overflow_Checking is enabled and + -- Do_Overflow_Check is set on node N. Note that divide is handled + -- separately using Apply_Arithmetic_Divide_Overflow_Check. + + procedure Apply_Constraint_Check + (N : Node_Id; + Typ : Entity_Id; + No_Sliding : Boolean := False); + -- Top-level procedure, calls all the others depending on the class of + -- Typ. Checks that expression N satisfies the constraint of type Typ. + -- No_Sliding is only relevant for constrained array types, if set to + -- True, it checks that indexes are in range. + + procedure Apply_Discriminant_Check + (N : Node_Id; + Typ : Entity_Id; + Lhs : Node_Id := Empty); + -- Given an expression N of a discriminated type, or of an access type + -- whose designated type is a discriminanted type, generates a check to + -- ensure that the expression can be converted to the subtype given as + -- the second parameter. Lhs is empty except in the case of assignments, + -- where the target object may be needed to determine the subtype to + -- check against (such as the cases of unconstrained formal parameters + -- and unconstrained aliased objects). For the case of unconstrained + -- formals, the check is performed only if the corresponding actual is + -- constrained, i.e., whether Lhs'Constrained is True. + + procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id); + -- N is an expression to which a predicate check may need to be applied + -- for Typ, if Typ has a predicate function. The check is applied only + -- if the type of N does not match Typ. + + function Build_Discriminant_Checks + (N : Node_Id; + T_Typ : Entity_Id) + return Node_Id; + -- Subsidiary routine for Apply_Discriminant_Check. Builds the expression + -- that compares discriminants of the expression with discriminants of the + -- type. Also used directly for membership tests (see Exp_Ch4.Expand_N_In). + + procedure Apply_Divide_Check (N : Node_Id); + -- The node kind is N_Op_Divide, N_Op_Mod, or N_Op_Rem. An appropriate + -- check is generated to ensure that the right operand is non-zero. In + -- the divide case, we also check that we do not have the annoying case + -- of the largest negative number divided by minus one. + + procedure Apply_Type_Conversion_Checks (N : Node_Id); + -- N is an N_Type_Conversion node. A type conversion actually involves + -- two sorts of checks. The first check is the checks that ensures that + -- the operand in the type conversion fits onto the base type of the + -- subtype it is being converted to (see RM 4.6 (28)-(50)). The second + -- check is there to ensure that once the operand has been converted to + -- a value of the target type, this converted value meets the + -- constraints imposed by the target subtype (see RM 4.6 (51)). + + procedure Apply_Universal_Integer_Attribute_Checks (N : Node_Id); + -- The argument N is an attribute reference node intended for processing + -- by gigi. The attribute is one that returns a universal integer, but + -- the attribute reference node is currently typed with the expected + -- result type. This routine deals with range and overflow checks needed + -- to make sure that the universal result is in range. + + procedure Determine_Range + (N : Node_Id; + OK : out Boolean; + Lo : out Uint; + Hi : out Uint; + Assume_Valid : Boolean := False); + -- N is a node for a subexpression. If N is of a discrete type with no + -- error indications, and no other peculiarities (e.g. missing type + -- fields), then OK is True on return, and Lo and Hi are set to a + -- conservative estimate of the possible range of values of N. Thus if OK + -- is True on return, the value of the subexpression N is known to like in + -- the range Lo .. Hi (inclusive). If the expression is not of a discrete + -- type, or some kind of error condition is detected, then OK is False on + -- exit, and Lo/Hi are set to No_Uint. Thus the significance of OK being + -- False on return is that no useful information is available on the range + -- of the expression. Assume_Valid determines whether the processing is + -- allowed to assume that values are in range of their subtypes. If it is + -- set to True, then this assumption is valid, if False, then processing + -- is done using base types to allow invalid values. + + procedure Install_Null_Excluding_Check (N : Node_Id); + -- Determines whether an access node requires a runtime access check and + -- if so inserts the appropriate run-time check. + + ------------------------------------------------------- + -- Control and Optimization of Range/Overflow Checks -- + ------------------------------------------------------- + + -- Range checks are controlled by the Do_Range_Check flag. The front end + -- is responsible for setting this flag in relevant nodes. Originally + -- the back end generated all corresponding range checks. But later on + -- we decided to generate many range checks in the front end. We are now + -- in the transitional phase where some of these checks are still done + -- by the back end, but many are done by the front end. It is possible + -- that in the future we might move all the checks to the front end. The + -- main remaining back end checks are for subscript checking. + + -- Overflow checks are similarly controlled by the Do_Overflow_Check flag. + -- The difference here is that if back end overflow checks are inactive + -- (Backend_Overflow_Checks_On_Target set False), then the actual overflow + -- checks are generated by the front end, but if back end overflow checks + -- are active (Backend_Overflow_Checks_On_Target set True), then the back + -- end does generate the checks. + + -- The following two routines are used to set these flags, they allow + -- for the possibility of eliminating checks. Checks can be eliminated + -- if an identical check has already been performed. + + procedure Enable_Overflow_Check (N : Node_Id); + -- First this routine determines if an overflow check is needed by doing + -- an appropriate range check. If a check is not needed, then the call + -- has no effect. If a check is needed then this routine sets the flag + -- Do_Overflow_Check in node N to True, unless it can be determined that + -- the check is not needed. The only condition under which this is the + -- case is if there was an identical check earlier on. + + procedure Enable_Range_Check (N : Node_Id); + -- Set Do_Range_Check flag in node N True, unless it can be determined + -- that the check is not needed. The only condition under which this is + -- the case is if there was an identical check earlier on. This routine + -- is not responsible for doing range analysis to determine whether or + -- not such a check is needed -- the caller is expected to do this. The + -- one other case in which the request to set the flag is ignored is + -- when Kill_Range_Check is set in an N_Unchecked_Conversion node. + + -- The following routines are used to keep track of processing sequences + -- of statements (e.g. the THEN statements of an IF statement). A check + -- that appears within such a sequence can eliminate an identical check + -- within this sequence of statements. However, after the end of the + -- sequence of statements, such a check is no longer of interest, since + -- it may not have been executed. + + procedure Conditional_Statements_Begin; + -- This call marks the start of processing of a sequence of statements. + -- Every call to this procedure must be followed by a matching call to + -- Conditional_Statements_End. + + procedure Conditional_Statements_End; + -- This call removes from consideration all saved checks since the + -- corresponding call to Conditional_Statements_Begin. These two + -- procedures operate in a stack like manner. + + -- The mechanism for optimizing checks works by remembering checks + -- that have already been made, but certain conditions, for example + -- an assignment to a variable involved in a check, may mean that the + -- remembered check is no longer valid, in the sense that if the same + -- expression appears again, another check is required because the + -- value may have changed. + + -- The following routines are used to note conditions which may render + -- some or all of the stored and remembered checks to be invalidated. + + procedure Kill_Checks (V : Entity_Id); + -- This procedure records an assignment or other condition that causes + -- the value of the variable to be changed, invalidating any stored + -- checks that reference the value. Note that all such checks must + -- be discarded, even if they are not in the current statement range. + + procedure Kill_All_Checks; + -- This procedure kills all remembered checks + + ----------------------------- + -- Length and Range Checks -- + ----------------------------- + + -- In the following procedures, there are three arguments which have + -- a common meaning as follows: + + -- Expr The expression to be checked. If a check is required, + -- the appropriate flag will be placed on this node. Whether + -- this node is further examined depends on the setting of + -- the parameter Source_Typ, as described below. + + -- ??? Apply_Length_Check and Apply_Range_Check do not have an Expr + -- formal + + -- ??? Apply_Length_Check and Apply_Range_Check have a Ck_Node formal + -- which is undocumented, is it the same as Expr? + + -- Target_Typ The target type on which the check is to be based. For + -- example, if we have a scalar range check, then the check + -- is that we are in range of this type. + + -- Source_Typ Normally Empty, but can be set to a type, in which case + -- this type is used for the check, see below. + + -- The checks operate in one of two modes: + + -- If Source_Typ is Empty, then the node Expr is examined, at the very + -- least to get the source subtype. In addition for some of the checks, + -- the actual form of the node may be examined. For example, a node of + -- type Integer whose actual form is an Integer conversion from a type + -- with range 0 .. 3 can be determined to have a value in range 0 .. 3. + + -- If Source_Typ is given, then nothing can be assumed about the Expr, + -- and indeed its contents are not examined. In this case the check is + -- based on the assumption that Expr can be an arbitrary value of the + -- given Source_Typ. + + -- Currently, the only case in which a Source_Typ is explicitly supplied + -- is for the case of Out and In_Out parameters, where, for the conversion + -- on return (the Out direction), the types must be reversed. This is + -- handled by the caller. + + procedure Apply_Length_Check + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty); + -- This procedure builds a sequence of declarations to do a length check + -- that checks if the lengths of the two arrays Target_Typ and source type + -- are the same. The resulting actions are inserted at Node using a call + -- to Insert_Actions. + -- + -- For access types, the Directly_Designated_Type is retrieved and + -- processing continues as enumerated above, with a guard against null + -- values. + -- + -- Note: calls to Apply_Length_Check currently never supply an explicit + -- Source_Typ parameter, but Apply_Length_Check takes this parameter and + -- processes it as described above for consistency with the other routines + -- in this section. + + procedure Apply_Range_Check + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty); + -- For a Node of kind N_Range, constructs a range check action that tests + -- first that the range is not null and then that the range is contained in + -- the Target_Typ range. + -- + -- For scalar types, constructs a range check action that first tests that + -- the expression is contained in the Target_Typ range. The difference + -- between this and Apply_Scalar_Range_Check is that the latter generates + -- the actual checking code in gigi against the Etype of the expression. + -- + -- For constrained array types, construct series of range check actions + -- to check that each Expr range is properly contained in the range of + -- Target_Typ. + -- + -- For a type conversion to an unconstrained array type, constructs a range + -- check action to check that the bounds of the source type are within the + -- constraints imposed by the Target_Typ. + -- + -- For access types, the Directly_Designated_Type is retrieved and + -- processing continues as enumerated above, with a guard against null + -- values. + -- + -- The source type is used by type conversions to unconstrained array + -- types to retrieve the corresponding bounds. + + procedure Apply_Static_Length_Check + (Expr : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty); + -- Tries to determine statically whether the two array types source type + -- and Target_Typ have the same length. If it can be determined at compile + -- time that they do not, then an N_Raise_Constraint_Error node replaces + -- Expr, and a warning message is issued. + + procedure Apply_Scalar_Range_Check + (Expr : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty; + Fixed_Int : Boolean := False); + -- For scalar types, determines whether an expression node should be + -- flagged as needing a runtime range check. If the node requires such a + -- check, the Do_Range_Check flag is turned on. The Fixed_Int flag if set + -- causes any fixed-point values to be treated as though they were discrete + -- values (i.e. the underlying integer value is used). + + type Check_Result is private; + -- Type used to return result of Get_Range_Checks call, for later use in + -- call to Insert_Range_Checks procedure. + + function Get_Range_Checks + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty; + Warn_Node : Node_Id := Empty) return Check_Result; + -- Like Apply_Range_Check, except it does not modify anything. Instead + -- it returns an encapsulated result of the check operations for later + -- use in a call to Insert_Range_Checks. If Warn_Node is non-empty, its + -- Sloc is used, in the static case, for the generated warning or error. + -- Additionally, it is used rather than Expr (or Low/High_Bound of Expr) + -- in constructing the check. + + procedure Append_Range_Checks + (Checks : Check_Result; + Stmts : List_Id; + Suppress_Typ : Entity_Id; + Static_Sloc : Source_Ptr; + Flag_Node : Node_Id); + -- Called to append range checks as returned by a call to Get_Range_Checks. + -- Stmts is a list to which either the dynamic check is appended or the + -- raise Constraint_Error statement is appended (for static checks). + -- Static_Sloc is the Sloc at which the raise CE node points, Flag_Node is + -- used as the node at which to set the Has_Dynamic_Check flag. Checks_On + -- is a boolean value that says if range and index checking is on or not. + + procedure Insert_Range_Checks + (Checks : Check_Result; + Node : Node_Id; + Suppress_Typ : Entity_Id; + Static_Sloc : Source_Ptr := No_Location; + Flag_Node : Node_Id := Empty; + Do_Before : Boolean := False); + -- Called to insert range checks as returned by a call to Get_Range_Checks. + -- Node is the node after which either the dynamic check is inserted or + -- the raise Constraint_Error statement is inserted (for static checks). + -- Suppress_Typ is the type to check to determine if checks are suppressed. + -- Static_Sloc, if passed, is the Sloc at which the raise CE node points, + -- otherwise Sloc (Node) is used. The Has_Dynamic_Check flag is normally + -- set at Node. If Flag_Node is present, then this is used instead as the + -- node at which to set the Has_Dynamic_Check flag. Normally the check is + -- inserted after, if Do_Before is True, the check is inserted before + -- Node. + + ----------------------- + -- Expander Routines -- + ----------------------- + + -- Some of the earlier processing for checks results in temporarily setting + -- the Do_Range_Check flag rather than actually generating checks. Now we + -- are moving the generation of such checks into the front end for reasons + -- of efficiency and simplicity (there were difficulties in handling this + -- in the back end when side effects were present in the expressions being + -- checked). + + -- Probably we could eliminate the Do_Range_Check flag entirely and + -- generate the checks earlier, but this is a delicate area and it + -- seemed safer to implement the following routines, which are called + -- late on in the expansion process. They check the Do_Range_Check flag + -- and if it is set, generate the actual checks and reset the flag. + + procedure Generate_Range_Check + (N : Node_Id; + Target_Type : Entity_Id; + Reason : RT_Exception_Code); + -- This procedure is called to actually generate and insert a range check. + -- A check is generated to ensure that the value of N lies within the range + -- of the target type. Note that the base type of N may be different from + -- the base type of the target type. This happens in the conversion case. + -- The Reason parameter is the exception code to be used for the exception + -- if raised. + -- + -- Note on the relation of this routine to the Do_Range_Check flag. Mostly + -- for historical reasons, we often set the Do_Range_Check flag and then + -- later we call Generate_Range_Check if this flag is set. Most probably we + -- could eliminate this intermediate setting of the flag (historically the + -- back end dealt with range checks, using this flag to indicate if a check + -- was required, then we moved checks into the front end). + + procedure Generate_Index_Checks (N : Node_Id); + -- This procedure is called to generate index checks on the subscripts for + -- the indexed component node N. Each subscript expression is examined, and + -- if the Do_Range_Check flag is set, an appropriate index check is + -- generated and the flag is reset. + + -- Similarly, we set the flag Do_Discriminant_Check in the semantic + -- analysis to indicate that a discriminant check is required for selected + -- component of a discriminated type. The following routine is called from + -- the expander to actually generate the call. + + procedure Generate_Discriminant_Check (N : Node_Id); + -- N is a selected component for which a discriminant check is required to + -- make sure that the discriminants have appropriate values for the + -- selection. This is done by calling the appropriate discriminant checking + -- routine for the selector. + + ----------------------- + -- Validity Checking -- + ----------------------- + + -- In (RM 13.9.1(9-11)) we have the following rules on invalid values + + -- If the representation of a scalar object does not represent value of + -- the object's subtype (perhaps because the object was not initialized), + -- the object is said to have an invalid representation. It is a bounded + -- error to evaluate the value of such an object. If the error is + -- detected, either Constraint_Error or Program_Error is raised. + -- Otherwise, execution continues using the invalid representation. The + -- rules of the language outside this subclause assume that all objects + -- have valid representations. The semantics of operations on invalid + -- representations are as follows: + -- + -- 10 If the representation of the object represents a value of the + -- object's type, the value of the type is used. + -- + -- 11 If the representation of the object does not represent a value + -- of the object's type, the semantics of operations on such + -- representations is implementation-defined, but does not by + -- itself lead to erroneous or unpredictable execution, or to + -- other objects becoming abnormal. + + -- We quote the rules in full here since they are quite delicate. Most + -- of the time, we can just compute away with wrong values, and get a + -- possibly wrong result, which is well within the range of allowed + -- implementation defined behavior. The two tricky cases are subscripted + -- array assignments, where we don't want to do wild stores, and case + -- statements where we don't want to do wild jumps. + + -- In GNAT, we control validity checking with a switch -gnatV that can take + -- three parameters, n/d/f for None/Default/Full. These modes have the + -- following meanings: + + -- None (no validity checking) + + -- In this mode, there is no specific checking for invalid values + -- and the code generator assumes that all stored values are always + -- within the bounds of the object subtype. The consequences are as + -- follows: + + -- For case statements, an out of range invalid value will cause + -- Constraint_Error to be raised, or an arbitrary one of the case + -- alternatives will be executed. Wild jumps cannot result even + -- in this mode, since we always do a range check + + -- For subscripted array assignments, wild stores will result in + -- the expected manner when addresses are calculated using values + -- of subscripts that are out of range. + + -- It could perhaps be argued that this mode is still conformant with + -- the letter of the RM, since implementation defined is a rather + -- broad category, but certainly it is not in the spirit of the + -- RM requirement, since wild stores certainly seem to be a case of + -- erroneous behavior. + + -- Default (default standard RM-compatible validity checking) + + -- In this mode, which is the default, minimal validity checking is + -- performed to ensure no erroneous behavior as follows: + + -- For case statements, an out of range invalid value will cause + -- Constraint_Error to be raised. + + -- For subscripted array assignments, invalid out of range + -- subscript values will cause Constraint_Error to be raised. + + -- Full (Full validity checking) + + -- In this mode, the protections guaranteed by the standard mode are + -- in place, and the following additional checks are made: + + -- For every assignment, the right side is checked for validity + + -- For every call, IN and IN OUT parameters are checked for validity + + -- For every subscripted array reference, both for stores and loads, + -- all subscripts are checked for validity. + + -- These checks are not required by the RM, but will in practice + -- improve the detection of uninitialized variables, particularly + -- if used in conjunction with pragma Normalize_Scalars. + + -- In the above description, we talk about performing validity checks, + -- but we don't actually generate a check in a case where the compiler + -- can be sure that the value is valid. Note that this assurance must + -- be achieved without assuming that any uninitialized value lies within + -- the range of its type. The following are cases in which values are + -- known to be valid. The flag Is_Known_Valid is used to keep track of + -- some of these cases. + + -- If all possible stored values are valid, then any uninitialized + -- value must be valid. + + -- Literals, including enumeration literals, are clearly always valid + + -- Constants are always assumed valid, with a validity check being + -- performed on the initializing value where necessary to ensure that + -- this is the case. + + -- For variables, the status is set to known valid if there is an + -- initializing expression. Again a check is made on the initializing + -- value if necessary to ensure that this assumption is valid. The + -- status can change as a result of local assignments to a variable. + -- If a known valid value is unconditionally assigned, then we mark + -- the left side as known valid. If a value is assigned that is not + -- known to be valid, then we mark the left side as invalid. This + -- kind of processing does NOT apply to non-local variables since we + -- are not following the flow graph (more properly the flow of actual + -- processing only corresponds to the flow graph for local assignments). + -- For non-local variables, we preserve the current setting, i.e. a + -- validity check is performed when assigning to a knonwn valid global. + + -- Note: no validity checking is required if range checks are suppressed + -- regardless of the setting of the validity checking mode. + + -- The following procedures are used in handling validity checking + + procedure Apply_Subscript_Validity_Checks (Expr : Node_Id); + -- Expr is the node for an indexed component. If validity checking and + -- range checking are enabled, all subscripts for this indexed component + -- are checked for validity. + + procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id); + -- Expr is a lvalue, i.e. an expression representing the target of an + -- assignment. This procedure checks for this expression involving an + -- assignment to an array value. We have to be sure that all the subscripts + -- in such a case are valid, since according to the rules in (RM + -- 13.9.1(9-11)) such assignments are not permitted to result in erroneous + -- behavior in the case of invalid subscript values. + + procedure Ensure_Valid (Expr : Node_Id; Holes_OK : Boolean := False); + -- Ensure that Expr represents a valid value of its type. If this type + -- is not a scalar type, then the call has no effect, since validity + -- is only an issue for scalar types. The effect of this call is to + -- check if the value is known valid, if so, nothing needs to be done. + -- If this is not known, then either Expr is set to be range checked, + -- or specific checking code is inserted so that an exception is raised + -- if the value is not valid. + -- + -- The optional argument Holes_OK indicates whether it is necessary to + -- worry about enumeration types with non-standard representations leading + -- to "holes" in the range of possible representations. If Holes_OK is + -- True, then such values are assumed valid (this is used when the caller + -- will make a separate check for this case anyway). If Holes_OK is False, + -- then this case is checked, and code is inserted to ensure that Expr is + -- valid, raising Constraint_Error if the value is not valid. + + function Expr_Known_Valid (Expr : Node_Id) return Boolean; + -- This function tests it the value of Expr is known to be valid in the + -- sense of RM 13.9.1(9-11). In the case of GNAT, it is only discrete types + -- which are a concern, since for non-discrete types we simply continue + -- computation with invalid values, which does not lead to erroneous + -- behavior. Thus Expr_Known_Valid always returns True if the type of Expr + -- is non-discrete. For discrete types the value returned is True only if + -- it can be determined that the value is Valid. Otherwise False is + -- returned. + + procedure Insert_Valid_Check (Expr : Node_Id); + -- Inserts code that will check for the value of Expr being valid, in + -- the sense of the 'Valid attribute returning True. Constraint_Error + -- will be raised if the value is not valid. + + procedure Null_Exclusion_Static_Checks (N : Node_Id); + -- Ada 2005 (AI-231): Check bad usages of the null-exclusion issue + + procedure Remove_Checks (Expr : Node_Id); + -- Remove all checks from Expr except those that are only executed + -- conditionally (on the right side of And Then/Or Else. This call + -- removes only embedded checks (Do_Range_Check, Do_Overflow_Check). + + procedure Validity_Check_Range (N : Node_Id); + -- If N is an N_Range node, then Ensure_Valid is called on its bounds, + -- if validity checking of operands is enabled. + + ----------------------------- + -- Handling of Check Names -- + ----------------------------- + + -- The following table contains Name_Id's for recognized checks. The first + -- entries (corresponding to the values of the subtype Predefined_Check_Id) + -- contain the Name_Id values for the checks that are predefined, including + -- All_Checks (see Types). Remaining entries are those that are introduced + -- by pragma Check_Names. + + package Check_Names is new Table.Table ( + Table_Component_Type => Name_Id, + Table_Index_Type => Check_Id, + Table_Low_Bound => 1, + Table_Initial => 30, + Table_Increment => 200, + Table_Name => "Name_Check_Names"); + + function Get_Check_Id (N : Name_Id) return Check_Id; + -- Function to search above table for matching name. If found returns the + -- corresponding Check_Id value in the range 1 .. Check_Name.Last. If not + -- found returns No_Check_Id. + +private + + type Check_Result is array (Positive range 1 .. 2) of Node_Id; + -- There are two cases for the result returned by Range_Check: + -- + -- For the static case the result is one or two nodes that should cause + -- a Constraint_Error. Typically these will include Expr itself or the + -- direct descendents of Expr, such as Low/High_Bound (Expr)). It is the + -- responsibility of the caller to rewrite and substitute the nodes with + -- N_Raise_Constraint_Error nodes. + -- + -- For the non-static case a single N_Raise_Constraint_Error node with a + -- non-empty Condition field is returned. + -- + -- Unused entries in Check_Result, if any, are simply set to Empty For + -- external clients, the required processing on this result is achieved + -- using the Insert_Range_Checks routine. + + pragma Inline (Apply_Length_Check); + pragma Inline (Apply_Range_Check); + pragma Inline (Apply_Static_Length_Check); +end Checks; diff --git a/gcc/ada/cio.c b/gcc/ada/cio.c new file mode 100644 index 000000000..277af0965 --- /dev/null +++ b/gcc/ada/cio.c @@ -0,0 +1,131 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * C I O * + * * + * C Implementation File * + * * + * Copyright (C) 1992-2009, Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. * + * * + * As a special exception under Section 7 of GPL version 3, you are granted * + * additional permissions described in the GCC Runtime Library Exception, * + * version 3.1, as published by the Free Software Foundation. * + * * + * You should have received a copy of the GNU General Public License and * + * a copy of the GCC Runtime Library Exception along with this program; * + * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +#ifdef IN_RTS +#include "tconfig.h" +#include "tsystem.h" +#include +#else +#include "config.h" +#include "system.h" +#endif + +#include "adaint.h" + +/* Don't use macros on GNU/Linux since they cause incompatible changes between + glibc 2.0 and 2.1 */ +#ifdef linux +#undef putchar +#undef getchar +#undef fputc +#undef stderr +#undef stdout +#endif + +#ifdef VTHREADS +#undef putchar +#undef getchar +#endif + +#ifdef RTX +#include +#include +#endif + +int +get_char (void) +{ +#ifdef VMS + return decc$getchar(); +#else + return getchar (); +#endif +} + +int +get_int (void) +{ + int x; + + scanf (" %d", &x); + return x; +} + +void +put_int (int x) +{ +#ifdef RTX + RtPrintf ("%d", x); +#else + /* Use fprintf rather than printf, since the latter is unbuffered + on vxworks */ + fprintf (stdout, "%d", x); +#endif +} + +void +put_int_stderr (int x) +{ +#ifdef RTX + RtPrintf ("%d", x); +#else + fprintf (stderr, "%d", x); +#endif +} + +void +put_char (int c) +{ +#ifdef RTX + RtPrintf ("%c", c); +#else + putchar (c); +#endif +} + +void +put_char_stderr (int c) +{ +#ifdef RTX + RtPrintf ("%c", c); +#else + fputc (c, stderr); +#endif +} + +#ifdef __vxworks + +char * +mktemp (char *template) +{ + return tmpnam (NULL); +} +#endif diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb new file mode 100644 index 000000000..8174e91e5 --- /dev/null +++ b/gcc/ada/clean.adb @@ -0,0 +1,1998 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C L E A N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with ALI; use ALI; +with Csets; +with Makeutl; use Makeutl; +with MLib.Tgt; use MLib.Tgt; +with Namet; use Namet; +with Opt; use Opt; +with Osint; use Osint; +with Osint.M; use Osint.M; +with Prj; use Prj; +with Prj.Env; +with Prj.Ext; +with Prj.Pars; +with Prj.Tree; use Prj.Tree; +with Prj.Util; use Prj.Util; +with Snames; +with Switch; use Switch; +with Table; +with Targparm; use Targparm; +with Types; use Types; + +with Ada.Command_Line; use Ada.Command_Line; + +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.IO; use GNAT.IO; +with GNAT.OS_Lib; use GNAT.OS_Lib; + +package body Clean is + + Initialized : Boolean := False; + -- Set to True by the first call to Initialize. + -- To avoid reinitialization of some packages. + + -- Suffixes of various files + + Assembly_Suffix : constant String := ".s"; + ALI_Suffix : constant String := ".ali"; + Tree_Suffix : constant String := ".adt"; + Object_Suffix : constant String := Get_Target_Object_Suffix.all; + Debug_Suffix : String := ".dg"; + -- Changed to "_dg" for VMS in the body of the package + + Repinfo_Suffix : String := ".rep"; + -- Changed to "_rep" for VMS in the body of the package + + B_Start : String_Ptr := new String'("b~"); + -- Prefix of binder generated file, and number of actual characters used. + -- Changed to "b__" for VMS in the body of the package. + + Object_Directory_Path : String_Access := null; + -- The path name of the object directory, set with switch -D + + Force_Deletions : Boolean := False; + -- Set to True by switch -f. When True, attempts to delete non writable + -- files will be done. + + Do_Nothing : Boolean := False; + -- Set to True when switch -n is specified. When True, no file is deleted. + -- gnatclean only lists the files that would have been deleted if the + -- switch -n had not been specified. + + File_Deleted : Boolean := False; + -- Set to True if at least one file has been deleted + + Copyright_Displayed : Boolean := False; + Usage_Displayed : Boolean := False; + + Project_File_Name : String_Access := null; + + Project_Node_Tree : Project_Node_Tree_Ref; + + Main_Project : Prj.Project_Id := Prj.No_Project; + + All_Projects : Boolean := False; + + -- Packages of project files where unknown attributes are errors + + Naming_String : aliased String := "naming"; + Builder_String : aliased String := "builder"; + Compiler_String : aliased String := "compiler"; + Binder_String : aliased String := "binder"; + Linker_String : aliased String := "linker"; + + Gnatmake_Packages : aliased String_List := + (Naming_String 'Access, + Builder_String 'Access, + Compiler_String 'Access, + Binder_String 'Access, + Linker_String 'Access); + + Packages_To_Check_By_Gnatmake : constant String_List_Access := + Gnatmake_Packages'Access; + + package Processed_Projects is new Table.Table + (Table_Component_Type => Project_Id, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Clean.Processed_Projects"); + -- Table to keep track of what project files have been processed, when + -- switch -r is specified. + + package Sources is new Table.Table + (Table_Component_Type => File_Name_Type, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Clean.Processed_Projects"); + -- Table to store all the source files of a library unit: spec, body and + -- subunits, to detect .dg files and delete them. + + ---------------------------- + -- Queue (Q) manipulation -- + ---------------------------- + + procedure Init_Q; + -- Must be called to initialize the Q + + procedure Insert_Q (Lib_File : File_Name_Type); + -- If Lib_File is not marked, inserts it at the end of Q and mark it + + function Empty_Q return Boolean; + -- Returns True if Q is empty + + procedure Extract_From_Q (Lib_File : out File_Name_Type); + -- Extracts the first element from the Q + + Q_Front : Natural; + -- Points to the first valid element in the Q + + package Q is new Table.Table ( + Table_Component_Type => File_Name_Type, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 4000, + Table_Increment => 100, + Table_Name => "Clean.Q"); + -- This is the actual queue + + ----------------------------- + -- Other local subprograms -- + ----------------------------- + + procedure Add_Source_Dir (N : String); + -- Call Add_Src_Search_Dir and output one line when in verbose mode + + procedure Add_Source_Directories is + new Prj.Env.For_All_Source_Dirs (Action => Add_Source_Dir); + + procedure Add_Object_Dir (N : String); + -- Call Add_Lib_Search_Dir and output one line when in verbose mode + + procedure Add_Object_Directories is + new Prj.Env.For_All_Object_Dirs (Action => Add_Object_Dir); + + function ALI_File_Name (Source : File_Name_Type) return String; + -- Returns the name of the ALI file corresponding to Source + + function Assembly_File_Name (Source : File_Name_Type) return String; + -- Returns the assembly file name corresponding to Source + + procedure Clean_Archive (Project : Project_Id; Global : Boolean); + -- Delete a global archive or library project archive and the dependency + -- file, if they exist. + + procedure Clean_Executables; + -- Do the cleaning work when no project file is specified + + procedure Clean_Interface_Copy_Directory (Project : Project_Id); + -- Delete files in an interface copy directory: any file that is a copy of + -- a source of the project. + + procedure Clean_Library_Directory (Project : Project_Id); + -- Delete the library file in a library directory and any ALI file of a + -- source of the project in a library ALI directory. + + procedure Clean_Project (Project : Project_Id); + -- Do the cleaning work when a project file is specified. This procedure + -- calls itself recursively when there are several project files in the + -- tree rooted at the main project file and switch -r has been specified. + + function Debug_File_Name (Source : File_Name_Type) return String; + -- Name of the expanded source file corresponding to Source + + procedure Delete (In_Directory : String; File : String); + -- Delete one file, or list the file name if switch -n is specified + + procedure Delete_Binder_Generated_Files + (Dir : String; + Source : File_Name_Type); + -- Delete the binder generated file in directory Dir for Source, if they + -- exist: for Unix these are b~.ads, b~.adb, + -- b~.ali and b~.o. + + procedure Display_Copyright; + -- Display the Copyright notice. If called several times, display the + -- Copyright notice only the first time. + + procedure Initialize; + -- Call the necessary package initializations + + function Object_File_Name (Source : File_Name_Type) return String; + -- Returns the object file name corresponding to Source + + procedure Parse_Cmd_Line; + -- Parse the command line + + function Repinfo_File_Name (Source : File_Name_Type) return String; + -- Returns the repinfo file name corresponding to Source + + function Tree_File_Name (Source : File_Name_Type) return String; + -- Returns the tree file name corresponding to Source + + function In_Extension_Chain + (Of_Project : Project_Id; + Prj : Project_Id) return Boolean; + -- Returns True iff Prj is an extension of Of_Project or if Of_Project is + -- an extension of Prj. + + procedure Usage; + -- Display the usage. If called several times, the usage is displayed only + -- the first time. + + -------------------- + -- Add_Object_Dir -- + -------------------- + + procedure Add_Object_Dir (N : String) is + begin + Add_Lib_Search_Dir (N); + + if Opt.Verbose_Mode then + Put ("Adding object directory """); + Put (N); + Put ("""."); + New_Line; + end if; + end Add_Object_Dir; + + -------------------- + -- Add_Source_Dir -- + -------------------- + + procedure Add_Source_Dir (N : String) is + begin + Add_Src_Search_Dir (N); + + if Opt.Verbose_Mode then + Put ("Adding source directory """); + Put (N); + Put ("""."); + New_Line; + end if; + end Add_Source_Dir; + + ------------------- + -- ALI_File_Name -- + ------------------- + + function ALI_File_Name (Source : File_Name_Type) return String is + Src : constant String := Get_Name_String (Source); + + begin + -- If the source name has an extension, then replace it with + -- the ALI suffix. + + for Index in reverse Src'First + 1 .. Src'Last loop + if Src (Index) = '.' then + return Src (Src'First .. Index - 1) & ALI_Suffix; + end if; + end loop; + + -- If there is no dot, or if it is the first character, just add the + -- ALI suffix. + + return Src & ALI_Suffix; + end ALI_File_Name; + + ------------------------ + -- Assembly_File_Name -- + ------------------------ + + function Assembly_File_Name (Source : File_Name_Type) return String is + Src : constant String := Get_Name_String (Source); + + begin + -- If the source name has an extension, then replace it with + -- the assembly suffix. + + for Index in reverse Src'First + 1 .. Src'Last loop + if Src (Index) = '.' then + return Src (Src'First .. Index - 1) & Assembly_Suffix; + end if; + end loop; + + -- If there is no dot, or if it is the first character, just add the + -- assembly suffix. + + return Src & Assembly_Suffix; + end Assembly_File_Name; + + ------------------- + -- Clean_Archive -- + ------------------- + + procedure Clean_Archive (Project : Project_Id; Global : Boolean) is + Current_Dir : constant Dir_Name_Str := Get_Current_Dir; + + Lib_Prefix : String_Access; + Archive_Name : String_Access; + -- The name of the archive file for this project + + Archive_Dep_Name : String_Access; + -- The name of the archive dependency file for this project + + Obj_Dir : constant String := + Get_Name_String (Project.Object_Directory.Display_Name); + + begin + Change_Dir (Obj_Dir); + + -- First, get the lib prefix, the archive file name and the archive + -- dependency file name. + + if Global then + Lib_Prefix := + new String'("lib" & Get_Name_String (Project.Display_Name)); + else + Lib_Prefix := + new String'("lib" & Get_Name_String (Project.Library_Name)); + end if; + + Archive_Name := new String'(Lib_Prefix.all & '.' & Archive_Ext); + Archive_Dep_Name := new String'(Lib_Prefix.all & ".deps"); + + -- Delete the archive file and the archive dependency file, if they + -- exist. + + if Is_Regular_File (Archive_Name.all) then + Delete (Obj_Dir, Archive_Name.all); + end if; + + if Is_Regular_File (Archive_Dep_Name.all) then + Delete (Obj_Dir, Archive_Dep_Name.all); + end if; + + Change_Dir (Current_Dir); + end Clean_Archive; + + ----------------------- + -- Clean_Executables -- + ----------------------- + + procedure Clean_Executables is + Main_Source_File : File_Name_Type; + -- Current main source + + Main_Lib_File : File_Name_Type; + -- ALI file of the current main + + Lib_File : File_Name_Type; + -- Current ALI file + + Full_Lib_File : File_Name_Type; + -- Full name of the current ALI file + + Text : Text_Buffer_Ptr; + The_ALI : ALI_Id; + + begin + Init_Q; + + -- It does not really matter if there is or not an object file + -- corresponding to an ALI file: if there is one, it will be deleted. + + Opt.Check_Object_Consistency := False; + + -- Proceed each executable one by one. Each source is marked as it is + -- processed, so common sources between executables will not be + -- processed several times. + + for N_File in 1 .. Osint.Number_Of_Files loop + Main_Source_File := Next_Main_Source; + Main_Lib_File := Osint.Lib_File_Name + (Main_Source_File, Current_File_Index); + Insert_Q (Main_Lib_File); + + while not Empty_Q loop + Sources.Set_Last (0); + Extract_From_Q (Lib_File); + Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File); + + -- If we have existing ALI file that is not read-only, process it + + if Full_Lib_File /= No_File + and then not Is_Readonly_Library (Full_Lib_File) + then + Text := Read_Library_Info (Lib_File); + + if Text /= null then + The_ALI := + Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True); + Free (Text); + + -- If no error was produced while loading this ALI file, + -- insert into the queue all the unmarked withed sources. + + if The_ALI /= No_ALI_Id then + for J in ALIs.Table (The_ALI).First_Unit .. + ALIs.Table (The_ALI).Last_Unit + loop + Sources.Increment_Last; + Sources.Table (Sources.Last) := + ALI.Units.Table (J).Sfile; + + for K in ALI.Units.Table (J).First_With .. + ALI.Units.Table (J).Last_With + loop + Insert_Q (Withs.Table (K).Afile); + end loop; + end loop; + + -- Look for subunits and put them in the Sources table + + for J in ALIs.Table (The_ALI).First_Sdep .. + ALIs.Table (The_ALI).Last_Sdep + loop + if Sdep.Table (J).Subunit_Name /= No_Name then + Sources.Increment_Last; + Sources.Table (Sources.Last) := + Sdep.Table (J).Sfile; + end if; + end loop; + end if; + end if; + + -- Now delete all existing files corresponding to this ALI file + + declare + Obj_Dir : constant String := + Dir_Name (Get_Name_String (Full_Lib_File)); + Obj : constant String := Object_File_Name (Lib_File); + Adt : constant String := Tree_File_Name (Lib_File); + Asm : constant String := Assembly_File_Name (Lib_File); + + begin + Delete (Obj_Dir, Get_Name_String (Lib_File)); + + if Is_Regular_File (Obj_Dir & Dir_Separator & Obj) then + Delete (Obj_Dir, Obj); + end if; + + if Is_Regular_File (Obj_Dir & Dir_Separator & Adt) then + Delete (Obj_Dir, Adt); + end if; + + if Is_Regular_File (Obj_Dir & Dir_Separator & Asm) then + Delete (Obj_Dir, Asm); + end if; + + -- Delete expanded source files (.dg) and/or repinfo files + -- (.rep) if any + + for J in 1 .. Sources.Last loop + declare + Deb : constant String := + Debug_File_Name (Sources.Table (J)); + Rep : constant String := + Repinfo_File_Name (Sources.Table (J)); + + begin + if Is_Regular_File (Obj_Dir & Dir_Separator & Deb) then + Delete (Obj_Dir, Deb); + end if; + + if Is_Regular_File (Obj_Dir & Dir_Separator & Rep) then + Delete (Obj_Dir, Rep); + end if; + end; + end loop; + end; + end if; + end loop; + + -- Delete the executable, if it exists, and the binder generated + -- files, if any. + + if not Compile_Only then + declare + Source : constant File_Name_Type := + Strip_Suffix (Main_Lib_File); + Executable : constant String := + Get_Name_String (Executable_Name (Source)); + begin + if Is_Regular_File (Executable) then + Delete ("", Executable); + end if; + + Delete_Binder_Generated_Files (Get_Current_Dir, Source); + end; + end if; + end loop; + end Clean_Executables; + + ------------------------------------ + -- Clean_Interface_Copy_Directory -- + ------------------------------------ + + procedure Clean_Interface_Copy_Directory (Project : Project_Id) is + Current : constant String := Get_Current_Dir; + + Direc : Dir_Type; + + Name : String (1 .. 200); + Last : Natural; + + Delete_File : Boolean; + Unit : Unit_Index; + + begin + if Project.Library + and then Project.Library_Src_Dir /= No_Path_Information + then + declare + Directory : constant String := + Get_Name_String (Project.Library_Src_Dir.Display_Name); + + begin + Change_Dir (Directory); + Open (Direc, "."); + + -- For each regular file in the directory, if switch -n has not + -- been specified, make it writable and delete the file if it is + -- a copy of a source of the project. + + loop + Read (Direc, Name, Last); + exit when Last = 0; + + declare + Filename : constant String := Name (1 .. Last); + + begin + if Is_Regular_File (Filename) then + Canonical_Case_File_Name (Name (1 .. Last)); + Delete_File := False; + + Unit := Units_Htable.Get_First (Project_Tree.Units_HT); + + -- Compare with source file names of the project + + while Unit /= No_Unit_Index loop + if Unit.File_Names (Impl) /= null + and then Ultimate_Extending_Project_Of + (Unit.File_Names (Impl).Project) = Project + and then + Get_Name_String (Unit.File_Names (Impl).File) = + Name (1 .. Last) + then + Delete_File := True; + exit; + end if; + + if Unit.File_Names (Spec) /= null + and then Ultimate_Extending_Project_Of + (Unit.File_Names (Spec).Project) = Project + and then + Get_Name_String + (Unit.File_Names (Spec).File) = Name (1 .. Last) + then + Delete_File := True; + exit; + end if; + + Unit := Units_Htable.Get_Next (Project_Tree.Units_HT); + end loop; + + if Delete_File then + if not Do_Nothing then + Set_Writable (Filename); + end if; + + Delete (Directory, Filename); + end if; + end if; + end; + end loop; + + Close (Direc); + + -- Restore the initial working directory + + Change_Dir (Current); + end; + end if; + end Clean_Interface_Copy_Directory; + + ----------------------------- + -- Clean_Library_Directory -- + ----------------------------- + + Empty_String : aliased String := ""; + + procedure Clean_Library_Directory (Project : Project_Id) is + Current : constant String := Get_Current_Dir; + + Lib_Filename : constant String := Get_Name_String (Project.Library_Name); + DLL_Name : String := + DLL_Prefix & Lib_Filename & "." & DLL_Ext; + Archive_Name : String := + "lib" & Lib_Filename & "." & Archive_Ext; + Direc : Dir_Type; + + Name : String (1 .. 200); + Last : Natural; + + Delete_File : Boolean; + + Minor : String_Access := Empty_String'Access; + Major : String_Access := Empty_String'Access; + + begin + if Project.Library then + if Project.Library_Kind /= Static + and then MLib.Tgt.Library_Major_Minor_Id_Supported + and then Project.Lib_Internal_Name /= No_Name + then + Minor := new String'(Get_Name_String (Project.Lib_Internal_Name)); + Major := new String'(MLib.Major_Id_Name (DLL_Name, Minor.all)); + end if; + + declare + Lib_Directory : constant String := + Get_Name_String + (Project.Library_Dir.Display_Name); + Lib_ALI_Directory : constant String := + Get_Name_String + (Project.Library_ALI_Dir.Display_Name); + + begin + Canonical_Case_File_Name (Archive_Name); + Canonical_Case_File_Name (DLL_Name); + + Change_Dir (Lib_Directory); + Open (Direc, "."); + + -- For each regular file in the directory, if switch -n has not + -- been specified, make it writable and delete the file if it is + -- the library file. + + loop + Read (Direc, Name, Last); + exit when Last = 0; + + declare + Filename : constant String := Name (1 .. Last); + + begin + if Is_Regular_File (Filename) + or else Is_Symbolic_Link (Filename) + then + Canonical_Case_File_Name (Name (1 .. Last)); + Delete_File := False; + + if (Project.Library_Kind = Static + and then Name (1 .. Last) = Archive_Name) + or else + ((Project.Library_Kind = Dynamic + or else + Project.Library_Kind = Relocatable) + and then + (Name (1 .. Last) = DLL_Name + or else + Name (1 .. Last) = Minor.all + or else + Name (1 .. Last) = Major.all)) + then + if not Do_Nothing then + Set_Writable (Filename); + end if; + + Delete (Lib_Directory, Filename); + end if; + end if; + end; + end loop; + + Close (Direc); + + Change_Dir (Lib_ALI_Directory); + Open (Direc, "."); + + -- For each regular file in the directory, if switch -n has not + -- been specified, make it writable and delete the file if it is + -- any ALI file of a source of the project. + + loop + Read (Direc, Name, Last); + exit when Last = 0; + + declare + Filename : constant String := Name (1 .. Last); + begin + if Is_Regular_File (Filename) then + Canonical_Case_File_Name (Name (1 .. Last)); + Delete_File := False; + + if Last > 4 and then Name (Last - 3 .. Last) = ".ali" then + declare + Unit : Unit_Index; + begin + -- Compare with ALI file names of the project + + Unit := Units_Htable.Get_First + (Project_Tree.Units_HT); + while Unit /= No_Unit_Index loop + if Unit.File_Names (Impl) /= null + and then Unit.File_Names (Impl).Project /= + No_Project + then + if Ultimate_Extending_Project_Of + (Unit.File_Names (Impl).Project) = + Project + then + Get_Name_String + (Unit.File_Names (Impl).File); + Name_Len := Name_Len - + File_Extension + (Name (1 .. Name_Len))'Length; + if Name_Buffer (1 .. Name_Len) = + Name (1 .. Last - 4) + then + Delete_File := True; + exit; + end if; + end if; + + elsif Unit.File_Names (Spec) /= null + and then Ultimate_Extending_Project_Of + (Unit.File_Names (Spec).Project) = + Project + then + Get_Name_String + (Unit.File_Names (Spec).File); + Name_Len := + Name_Len - + File_Extension + (Name (1 .. Name_Len))'Length; + + if Name_Buffer (1 .. Name_Len) = + Name (1 .. Last - 4) + then + Delete_File := True; + exit; + end if; + end if; + + Unit := + Units_Htable.Get_Next (Project_Tree.Units_HT); + end loop; + end; + end if; + + if Delete_File then + if not Do_Nothing then + Set_Writable (Filename); + end if; + + Delete (Lib_ALI_Directory, Filename); + end if; + end if; + end; + end loop; + + Close (Direc); + + -- Restore the initial working directory + + Change_Dir (Current); + end; + end if; + end Clean_Library_Directory; + + ------------------- + -- Clean_Project -- + ------------------- + + procedure Clean_Project (Project : Project_Id) is + Main_Source_File : File_Name_Type; + -- Name of executable on the command line without directory info + + Executable : File_Name_Type; + -- Name of the executable file + + Current_Dir : constant Dir_Name_Str := Get_Current_Dir; + Unit : Unit_Index; + File_Name1 : File_Name_Type; + Index1 : Int; + File_Name2 : File_Name_Type; + Index2 : Int; + Lib_File : File_Name_Type; + + Global_Archive : Boolean := False; + + begin + -- Check that we don't specify executable on the command line for + -- a main library project. + + if Project = Main_Project + and then Osint.Number_Of_Files /= 0 + and then Project.Library + then + Osint.Fail + ("Cannot specify executable(s) for a Library Project File"); + end if; + + -- Nothing to clean in an externally built project + + if Project.Externally_Built then + if Verbose_Mode then + Put ("Nothing to do to clean externally built project """); + Put (Get_Name_String (Project.Name)); + Put_Line (""""); + end if; + + else + if Verbose_Mode then + Put ("Cleaning project """); + Put (Get_Name_String (Project.Name)); + Put_Line (""""); + end if; + + -- Add project to the list of processed projects + + Processed_Projects.Increment_Last; + Processed_Projects.Table (Processed_Projects.Last) := Project; + + if Project.Object_Directory /= No_Path_Information then + declare + Obj_Dir : constant String := + Get_Name_String + (Project.Object_Directory.Display_Name); + + begin + Change_Dir (Obj_Dir); + + -- First, deal with Ada + + -- Look through the units to find those that are either + -- immediate sources or inherited sources of the project. + -- Extending projects may have no language specified, if + -- Source_Dirs or Source_Files is specified as an empty list, + -- so always look for Ada units in extending projects. + + if Has_Ada_Sources (Project) + or else Project.Extends /= No_Project + then + Unit := Units_Htable.Get_First (Project_Tree.Units_HT); + while Unit /= No_Unit_Index loop + File_Name1 := No_File; + File_Name2 := No_File; + + -- If either the spec or the body is a source of the + -- project, check for the corresponding ALI file in the + -- object directory. + + if (Unit.File_Names (Impl) /= null + and then + In_Extension_Chain + (Unit.File_Names (Impl).Project, Project)) + or else + (Unit.File_Names (Spec) /= null + and then In_Extension_Chain + (Unit.File_Names (Spec).Project, Project)) + then + if Unit.File_Names (Impl) /= null then + File_Name1 := Unit.File_Names (Impl).File; + Index1 := Unit.File_Names (Impl).Index; + else + File_Name1 := No_File; + Index1 := 0; + end if; + + if Unit.File_Names (Spec) /= null then + File_Name2 := Unit.File_Names (Spec).File; + Index2 := Unit.File_Names (Spec).Index; + else + File_Name2 := No_File; + Index2 := 0; + end if; + + -- If there is no body file name, then there may be + -- only a spec. + + if File_Name1 = No_File then + File_Name1 := File_Name2; + Index1 := Index2; + File_Name2 := No_File; + Index2 := 0; + end if; + end if; + + -- If there is either a spec or a body, look for files + -- in the object directory. + + if File_Name1 /= No_File then + Lib_File := Osint.Lib_File_Name (File_Name1, Index1); + + declare + Asm : constant String := + Assembly_File_Name (Lib_File); + ALI : constant String := + ALI_File_Name (Lib_File); + Obj : constant String := + Object_File_Name (Lib_File); + Adt : constant String := + Tree_File_Name (Lib_File); + Deb : constant String := + Debug_File_Name (File_Name1); + Rep : constant String := + Repinfo_File_Name (File_Name1); + Del : Boolean := True; + + begin + -- If the ALI file exists and is read-only, no file + -- is deleted. + + if Is_Regular_File (ALI) then + if Is_Writable_File (ALI) then + Delete (Obj_Dir, ALI); + + else + Del := False; + + if Verbose_Mode then + Put ('"'); + Put (Obj_Dir); + + if Obj_Dir (Obj_Dir'Last) /= + Dir_Separator + then + Put (Dir_Separator); + end if; + + Put (ALI); + Put_Line (""" is read-only"); + end if; + end if; + end if; + + if Del then + + -- Object file + + if Is_Regular_File (Obj) then + Delete (Obj_Dir, Obj); + end if; + + -- Assembly file + + if Is_Regular_File (Asm) then + Delete (Obj_Dir, Asm); + end if; + + -- Tree file + + if Is_Regular_File (Adt) then + Delete (Obj_Dir, Adt); + end if; + + -- First expanded source file + + if Is_Regular_File (Deb) then + Delete (Obj_Dir, Deb); + end if; + + -- Repinfo file + + if Is_Regular_File (Rep) then + Delete (Obj_Dir, Rep); + end if; + + -- Second expanded source file + + if File_Name2 /= No_File then + declare + Deb : constant String := + Debug_File_Name (File_Name2); + Rep : constant String := + Repinfo_File_Name (File_Name2); + + begin + if Is_Regular_File (Deb) then + Delete (Obj_Dir, Deb); + end if; + + if Is_Regular_File (Rep) then + Delete (Obj_Dir, Rep); + end if; + end; + end if; + end if; + end; + end if; + + Unit := Units_Htable.Get_Next (Project_Tree.Units_HT); + end loop; + end if; + + -- Check if a global archive and it dependency file could have + -- been created and, if they exist, delete them. + + if Project = Main_Project and then not Project.Library then + Global_Archive := False; + + declare + Proj : Project_List; + + begin + Proj := Project_Tree.Projects; + while Proj /= null loop + + -- For gnatmake, when the project specifies more than + -- just Ada as a language (even if course we could not + -- find any source file for the other languages), we + -- will take all the object files found in the object + -- directories. Since we know the project supports at + -- least Ada, we just have to test whether it has at + -- least two languages, and we do not care about the + -- sources. + + if Proj.Project.Languages /= null + and then Proj.Project.Languages.Next /= null + then + Global_Archive := True; + exit; + end if; + + Proj := Proj.Next; + end loop; + end; + + if Global_Archive then + Clean_Archive (Project, Global => True); + end if; + end if; + + end; + end if; + + -- If this is a library project, clean the library directory, the + -- interface copy dir and, for a Stand-Alone Library, the binder + -- generated files of the library. + + -- The directories are cleaned only if switch -c is not specified + + if Project.Library then + if not Compile_Only then + Clean_Library_Directory (Project); + + if Project.Library_Src_Dir /= No_Path_Information then + Clean_Interface_Copy_Directory (Project); + end if; + end if; + + if Project.Standalone_Library and then + Project.Object_Directory /= No_Path_Information + then + Delete_Binder_Generated_Files + (Get_Name_String (Project.Object_Directory.Display_Name), + File_Name_Type (Project.Library_Name)); + end if; + end if; + + if Verbose_Mode then + New_Line; + end if; + end if; + + -- If switch -r is specified, call Clean_Project recursively for the + -- imported projects and the project being extended. + + if All_Projects then + declare + Imported : Project_List; + Process : Boolean; + + begin + -- For each imported project, call Clean_Project if the project + -- has not been processed already. + + Imported := Project.Imported_Projects; + while Imported /= null loop + Process := True; + + for + J in Processed_Projects.First .. Processed_Projects.Last + loop + if Imported.Project = Processed_Projects.Table (J) then + Process := False; + exit; + end if; + end loop; + + if Process then + Clean_Project (Imported.Project); + end if; + + Imported := Imported.Next; + end loop; + + -- If this project extends another project, call Clean_Project for + -- the project being extended. It is guaranteed that it has not + -- called before, because no other project may import or extend + -- this project. + + if Project.Extends /= No_Project then + Clean_Project (Project.Extends); + end if; + end; + end if; + + -- For the main project, delete the executables and the binder + -- generated files. + + -- The executables are deleted only if switch -c is not specified + + if Project = Main_Project + and then Project.Exec_Directory /= No_Path_Information + then + declare + Exec_Dir : constant String := + Get_Name_String (Project.Exec_Directory.Display_Name); + + begin + Change_Dir (Exec_Dir); + + for N_File in 1 .. Osint.Number_Of_Files loop + Main_Source_File := Next_Main_Source; + + if not Compile_Only then + Executable := + Executable_Of + (Main_Project, + Project_Tree, + Main_Source_File, + Current_File_Index); + + declare + Exec_File_Name : constant String := + Get_Name_String (Executable); + + begin + if Is_Absolute_Path (Name => Exec_File_Name) then + if Is_Regular_File (Exec_File_Name) then + Delete ("", Exec_File_Name); + end if; + + else + if Is_Regular_File (Exec_File_Name) then + Delete (Exec_Dir, Exec_File_Name); + end if; + end if; + end; + end if; + + if Project.Object_Directory /= No_Path_Information then + Delete_Binder_Generated_Files + (Get_Name_String (Project.Object_Directory.Display_Name), + Strip_Suffix (Main_Source_File)); + end if; + end loop; + end; + end if; + + -- Change back to previous directory + + Change_Dir (Current_Dir); + end Clean_Project; + + --------------------- + -- Debug_File_Name -- + --------------------- + + function Debug_File_Name (Source : File_Name_Type) return String is + begin + return Get_Name_String (Source) & Debug_Suffix; + end Debug_File_Name; + + ------------ + -- Delete -- + ------------ + + procedure Delete (In_Directory : String; File : String) is + Full_Name : String (1 .. In_Directory'Length + File'Length + 1); + Last : Natural := 0; + Success : Boolean; + + begin + -- Indicate that at least one file is deleted or is to be deleted + + File_Deleted := True; + + -- Build the path name of the file to delete + + Last := In_Directory'Length; + Full_Name (1 .. Last) := In_Directory; + + if Last > 0 and then Full_Name (Last) /= Directory_Separator then + Last := Last + 1; + Full_Name (Last) := Directory_Separator; + end if; + + Full_Name (Last + 1 .. Last + File'Length) := File; + Last := Last + File'Length; + + -- If switch -n was used, simply output the path name + + if Do_Nothing then + Put_Line (Full_Name (1 .. Last)); + + -- Otherwise, delete the file if it is writable + + else + if Force_Deletions + or else Is_Writable_File (Full_Name (1 .. Last)) + or else Is_Symbolic_Link (Full_Name (1 .. Last)) + then + Delete_File (Full_Name (1 .. Last), Success); + else + Success := False; + end if; + + if Verbose_Mode or else not Quiet_Output then + if not Success then + Put ("Warning: """); + Put (Full_Name (1 .. Last)); + Put_Line (""" could not be deleted"); + + else + Put (""""); + Put (Full_Name (1 .. Last)); + Put_Line (""" has been deleted"); + end if; + end if; + end if; + end Delete; + + ----------------------------------- + -- Delete_Binder_Generated_Files -- + ----------------------------------- + + procedure Delete_Binder_Generated_Files + (Dir : String; + Source : File_Name_Type) + is + Source_Name : constant String := Get_Name_String (Source); + Current : constant String := Get_Current_Dir; + Last : constant Positive := B_Start'Length + Source_Name'Length; + File_Name : String (1 .. Last + 4); + + begin + Change_Dir (Dir); + + -- Build the file name (before the extension) + + File_Name (1 .. B_Start'Length) := B_Start.all; + File_Name (B_Start'Length + 1 .. Last) := Source_Name; + + -- Spec + + File_Name (Last + 1 .. Last + 4) := ".ads"; + + if Is_Regular_File (File_Name (1 .. Last + 4)) then + Delete (Dir, File_Name (1 .. Last + 4)); + end if; + + -- Body + + File_Name (Last + 1 .. Last + 4) := ".adb"; + + if Is_Regular_File (File_Name (1 .. Last + 4)) then + Delete (Dir, File_Name (1 .. Last + 4)); + end if; + + -- ALI file + + File_Name (Last + 1 .. Last + 4) := ".ali"; + + if Is_Regular_File (File_Name (1 .. Last + 4)) then + Delete (Dir, File_Name (1 .. Last + 4)); + end if; + + -- Object file + + File_Name (Last + 1 .. Last + Object_Suffix'Length) := Object_Suffix; + + if Is_Regular_File (File_Name (1 .. Last + Object_Suffix'Length)) then + Delete (Dir, File_Name (1 .. Last + Object_Suffix'Length)); + end if; + + -- Change back to previous directory + + Change_Dir (Current); + end Delete_Binder_Generated_Files; + + ----------------------- + -- Display_Copyright -- + ----------------------- + + procedure Display_Copyright is + begin + if not Copyright_Displayed then + Copyright_Displayed := True; + Display_Version ("GNATCLEAN", "2003"); + end if; + end Display_Copyright; + + ------------- + -- Empty_Q -- + ------------- + + function Empty_Q return Boolean is + begin + return Q_Front >= Q.Last; + end Empty_Q; + + -------------------- + -- Extract_From_Q -- + -------------------- + + procedure Extract_From_Q (Lib_File : out File_Name_Type) is + Lib : constant File_Name_Type := Q.Table (Q_Front); + begin + Q_Front := Q_Front + 1; + Lib_File := Lib; + end Extract_From_Q; + + --------------- + -- Gnatclean -- + --------------- + + procedure Gnatclean is + begin + -- Do the necessary initializations + + Clean.Initialize; + + -- Parse the command line, getting the switches and the executable names + + Parse_Cmd_Line; + + if Verbose_Mode then + Display_Copyright; + end if; + + if Project_File_Name /= null then + + -- A project file was specified by a -P switch + + if Opt.Verbose_Mode then + New_Line; + Put ("Parsing Project File """); + Put (Project_File_Name.all); + Put_Line ("""."); + New_Line; + end if; + + -- Set the project parsing verbosity to whatever was specified + -- by a possible -vP switch. + + Prj.Pars.Set_Verbosity (To => Current_Verbosity); + + -- Parse the project file. If there is an error, Main_Project + -- will still be No_Project. + + Prj.Pars.Parse + (Project => Main_Project, + In_Tree => Project_Tree, + In_Node_Tree => Project_Node_Tree, + Project_File_Name => Project_File_Name.all, + Flags => Gnatmake_Flags, + Packages_To_Check => Packages_To_Check_By_Gnatmake); + + if Main_Project = No_Project then + Fail ("""" & Project_File_Name.all & """ processing failed"); + end if; + + if Opt.Verbose_Mode then + New_Line; + Put ("Parsing of Project File """); + Put (Project_File_Name.all); + Put (""" is finished."); + New_Line; + end if; + + -- Add source directories and object directories to the search paths + + Add_Source_Directories (Main_Project, Project_Tree); + Add_Object_Directories (Main_Project); + end if; + + Osint.Add_Default_Search_Dirs; + + -- If a project file was specified, but no executable name, put all + -- the mains of the project file (if any) as if there were on the + -- command line. + + if Main_Project /= No_Project and then Osint.Number_Of_Files = 0 then + declare + Main : String_Element; + Value : String_List_Id := Main_Project.Mains; + begin + while Value /= Prj.Nil_String loop + Main := Project_Tree.String_Elements.Table (Value); + Osint.Add_File + (File_Name => Get_Name_String (Main.Value), + Index => Main.Index); + Value := Main.Next; + end loop; + end; + end if; + + -- If neither a project file nor an executable were specified, output + -- the usage and exit. + + if Main_Project = No_Project and then Osint.Number_Of_Files = 0 then + Usage; + return; + end if; + + if Verbose_Mode then + New_Line; + end if; + + if Main_Project /= No_Project then + + -- If a project file has been specified, call Clean_Project with the + -- project id of this project file, after resetting the list of + -- processed projects. + + Processed_Projects.Init; + Clean_Project (Main_Project); + + else + -- If no project file has been specified, the work is done in + -- Clean_Executables. + + Clean_Executables; + end if; + + -- In verbose mode, if Delete has not been called, indicate that no file + -- needs to be deleted. + + if Verbose_Mode and (not File_Deleted) then + New_Line; + + if Do_Nothing then + Put_Line ("No file needs to be deleted"); + else + Put_Line ("No file has been deleted"); + end if; + end if; + end Gnatclean; + + ------------------------ + -- In_Extension_Chain -- + ------------------------ + + function In_Extension_Chain + (Of_Project : Project_Id; + Prj : Project_Id) return Boolean + is + Proj : Project_Id; + + begin + if Prj = No_Project or else Of_Project = No_Project then + return False; + end if; + + if Of_Project = Prj then + return True; + end if; + + Proj := Of_Project; + while Proj.Extends /= No_Project loop + if Proj.Extends = Prj then + return True; + end if; + + Proj := Proj.Extends; + end loop; + + Proj := Prj; + while Proj.Extends /= No_Project loop + if Proj.Extends = Of_Project then + return True; + end if; + + Proj := Proj.Extends; + end loop; + + return False; + end In_Extension_Chain; + + ------------ + -- Init_Q -- + ------------ + + procedure Init_Q is + begin + Q_Front := Q.First; + Q.Set_Last (Q.First); + end Init_Q; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + if not Initialized then + Initialized := True; + + -- Get default search directories to locate system.ads when calling + -- Targparm.Get_Target_Parameters. + + Osint.Add_Default_Search_Dirs; + + -- Initialize some packages + + Csets.Initialize; + Snames.Initialize; + + Project_Node_Tree := new Project_Node_Tree_Data; + Prj.Tree.Initialize (Project_Node_Tree); + + Prj.Initialize (Project_Tree); + + -- Check if the platform is VMS and, if it is, change some variables + + Targparm.Get_Target_Parameters; + + if OpenVMS_On_Target then + Debug_Suffix (Debug_Suffix'First) := '_'; + Repinfo_Suffix (Repinfo_Suffix'First) := '_'; + B_Start := new String'("b__"); + end if; + end if; + + -- Reset global variables + + Free (Object_Directory_Path); + Do_Nothing := False; + File_Deleted := False; + Copyright_Displayed := False; + Usage_Displayed := False; + Free (Project_File_Name); + Main_Project := Prj.No_Project; + All_Projects := False; + end Initialize; + + -------------- + -- Insert_Q -- + -------------- + + procedure Insert_Q (Lib_File : File_Name_Type) is + begin + -- Do not insert an empty name or an already marked source + + if Lib_File /= No_File and then not Makeutl.Is_Marked (Lib_File) then + Q.Table (Q.Last) := Lib_File; + Q.Increment_Last; + + -- Mark the source that has been just added to the Q + + Makeutl.Mark (Lib_File); + end if; + end Insert_Q; + + ---------------------- + -- Object_File_Name -- + ---------------------- + + function Object_File_Name (Source : File_Name_Type) return String is + Src : constant String := Get_Name_String (Source); + + begin + -- If the source name has an extension, then replace it with + -- the Object suffix. + + for Index in reverse Src'First + 1 .. Src'Last loop + if Src (Index) = '.' then + return Src (Src'First .. Index - 1) & Object_Suffix; + end if; + end loop; + + -- If there is no dot, or if it is the first character, just add the + -- ALI suffix. + + return Src & Object_Suffix; + end Object_File_Name; + + -------------------- + -- Parse_Cmd_Line -- + -------------------- + + procedure Parse_Cmd_Line is + Last : constant Natural := Argument_Count; + Source_Index : Int := 0; + Index : Positive; + + procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); + + begin + -- First, check for --version and --help + + Check_Version_And_Help ("GNATCLEAN", "2003"); + + Index := 1; + while Index <= Last loop + declare + Arg : constant String := Argument (Index); + + procedure Bad_Argument; + -- Signal bad argument + + ------------------ + -- Bad_Argument -- + ------------------ + + procedure Bad_Argument is + begin + Fail ("invalid argument """ & Arg & """"); + end Bad_Argument; + + begin + if Arg'Length /= 0 then + if Arg (1) = '-' then + if Arg'Length = 1 then + Bad_Argument; + end if; + + case Arg (2) is + when '-' => + if Arg'Length > Subdirs_Option'Length and then + Arg (1 .. Subdirs_Option'Length) = Subdirs_Option + then + Subdirs := + new String' + (Arg (Subdirs_Option'Length + 1 .. Arg'Last)); + + elsif Arg = Makeutl.Unchecked_Shared_Lib_Imports then + Opt.Unchecked_Shared_Lib_Imports := True; + + else + Bad_Argument; + end if; + + when 'a' => + if Arg'Length < 4 then + Bad_Argument; + end if; + + if Arg (3) = 'O' then + Add_Lib_Search_Dir (Arg (4 .. Arg'Last)); + + elsif Arg (3) = 'P' then + Prj.Env.Add_Directories + (Project_Node_Tree.Project_Path, + Arg (4 .. Arg'Last)); + + else + Bad_Argument; + end if; + + when 'c' => + Compile_Only := True; + + when 'D' => + if Object_Directory_Path /= null then + Fail ("duplicate -D switch"); + + elsif Project_File_Name /= null then + Fail ("-P and -D cannot be used simultaneously"); + end if; + + if Arg'Length > 2 then + declare + Dir : constant String := Arg (3 .. Arg'Last); + begin + if not Is_Directory (Dir) then + Fail (Dir & " is not a directory"); + else + Add_Lib_Search_Dir (Dir); + end if; + end; + + else + if Index = Last then + Fail ("no directory specified after -D"); + end if; + + Index := Index + 1; + + declare + Dir : constant String := Argument (Index); + begin + if not Is_Directory (Dir) then + Fail (Dir & " is not a directory"); + else + Add_Lib_Search_Dir (Dir); + end if; + end; + end if; + + when 'e' => + if Arg = "-eL" then + Follow_Links_For_Files := True; + Follow_Links_For_Dirs := True; + + else + Bad_Argument; + end if; + + when 'f' => + Force_Deletions := True; + + when 'F' => + Full_Path_Name_For_Brief_Errors := True; + + when 'h' => + Usage; + + when 'i' => + if Arg'Length = 2 then + Bad_Argument; + end if; + + Source_Index := 0; + + for J in 3 .. Arg'Last loop + if Arg (J) not in '0' .. '9' then + Bad_Argument; + end if; + + Source_Index := + (20 * Source_Index) + + (Character'Pos (Arg (J)) - Character'Pos ('0')); + end loop; + + when 'I' => + if Arg = "-I-" then + Opt.Look_In_Primary_Dir := False; + + else + if Arg'Length = 2 then + Bad_Argument; + end if; + + Add_Lib_Search_Dir (Arg (3 .. Arg'Last)); + end if; + + when 'n' => + Do_Nothing := True; + + when 'P' => + if Project_File_Name /= null then + Fail ("multiple -P switches"); + + elsif Object_Directory_Path /= null then + Fail ("-D and -P cannot be used simultaneously"); + + end if; + + if Arg'Length > 2 then + declare + Prj : constant String := Arg (3 .. Arg'Last); + begin + if Prj'Length > 1 and then + Prj (Prj'First) = '=' + then + Project_File_Name := + new String' + (Prj (Prj'First + 1 .. Prj'Last)); + else + Project_File_Name := new String'(Prj); + end if; + end; + + else + if Index = Last then + Fail ("no project specified after -P"); + end if; + + Index := Index + 1; + Project_File_Name := new String'(Argument (Index)); + end if; + + when 'q' => + Quiet_Output := True; + + when 'r' => + All_Projects := True; + + when 'v' => + if Arg = "-v" then + Verbose_Mode := True; + + elsif Arg = "-vP0" then + Current_Verbosity := Prj.Default; + + elsif Arg = "-vP1" then + Current_Verbosity := Prj.Medium; + + elsif Arg = "-vP2" then + Current_Verbosity := Prj.High; + + else + Bad_Argument; + end if; + + when 'X' => + if Arg'Length = 2 then + Bad_Argument; + end if; + + declare + Ext_Asgn : constant String := Arg (3 .. Arg'Last); + Start : Positive := Ext_Asgn'First; + Stop : Natural := Ext_Asgn'Last; + Equal_Pos : Natural; + OK : Boolean := True; + + begin + if Ext_Asgn (Start) = '"' then + if Ext_Asgn (Stop) = '"' then + Start := Start + 1; + Stop := Stop - 1; + + else + OK := False; + end if; + end if; + + Equal_Pos := Start; + + while Equal_Pos <= Stop + and then Ext_Asgn (Equal_Pos) /= '=' + loop + Equal_Pos := Equal_Pos + 1; + end loop; + + if Equal_Pos = Start or else Equal_Pos > Stop then + OK := False; + end if; + + if OK then + Prj.Ext.Add + (Project_Node_Tree, + External_Name => + Ext_Asgn (Start .. Equal_Pos - 1), + Value => + Ext_Asgn (Equal_Pos + 1 .. Stop)); + + else + Fail + ("illegal external assignment '" + & Ext_Asgn + & "'"); + end if; + end; + + when others => + Bad_Argument; + end case; + + else + Add_File (Arg, Source_Index); + end if; + end if; + end; + + Index := Index + 1; + end loop; + end Parse_Cmd_Line; + + ----------------------- + -- Repinfo_File_Name -- + ----------------------- + + function Repinfo_File_Name (Source : File_Name_Type) return String is + begin + return Get_Name_String (Source) & Repinfo_Suffix; + end Repinfo_File_Name; + + -------------------- + -- Tree_File_Name -- + -------------------- + + function Tree_File_Name (Source : File_Name_Type) return String is + Src : constant String := Get_Name_String (Source); + + begin + -- If source name has an extension, then replace it with the tree suffix + + for Index in reverse Src'First + 1 .. Src'Last loop + if Src (Index) = '.' then + return Src (Src'First .. Index - 1) & Tree_Suffix; + end if; + end loop; + + -- If there is no dot, or if it is the first character, just add the + -- tree suffix. + + return Src & Tree_Suffix; + end Tree_File_Name; + + ----------- + -- Usage -- + ----------- + + procedure Usage is + begin + if not Usage_Displayed then + Usage_Displayed := True; + Display_Copyright; + Put_Line ("Usage: gnatclean [switches] {[-innn] name}"); + New_Line; + + Put_Line (" names is one or more file names from which " & + "the .adb or .ads suffix may be omitted"); + Put_Line (" names may be omitted if -P is specified"); + New_Line; + + Put_Line (" --subdirs=dir real obj/lib/exec dirs are subdirs"); + Put_Line (" " & Makeutl.Unchecked_Shared_Lib_Imports); + Put_Line (" Allow shared libraries to import static libraries"); + New_Line; + + Put_Line (" -c Only delete compiler generated files"); + Put_Line (" -D dir Specify dir as the object library"); + Put_Line (" -eL Follow symbolic links when processing " & + "project files"); + Put_Line (" -f Force deletions of unwritable files"); + Put_Line (" -F Full project path name " & + "in brief error messages"); + Put_Line (" -h Display this message"); + Put_Line (" -innn Index of unit in source for following names"); + Put_Line (" -n Nothing to do: only list files to delete"); + Put_Line (" -Pproj Use GNAT Project File proj"); + Put_Line (" -q Be quiet/terse"); + Put_Line (" -r Clean all projects recursively"); + Put_Line (" -v Verbose mode"); + Put_Line (" -vPx Specify verbosity when parsing " & + "GNAT Project Files"); + Put_Line (" -Xnm=val Specify an external reference " & + "for GNAT Project Files"); + New_Line; + + Put_Line (" -aPdir Add directory dir to project search path"); + New_Line; + + Put_Line (" -aOdir Specify ALI/object files search path"); + Put_Line (" -Idir Like -aOdir"); + Put_Line (" -I- Don't look for source/library files " & + "in the default directory"); + New_Line; + end if; + end Usage; + +end Clean; diff --git a/gcc/ada/clean.ads b/gcc/ada/clean.ads new file mode 100644 index 000000000..f344945c0 --- /dev/null +++ b/gcc/ada/clean.ads @@ -0,0 +1,33 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C L E A N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 implementation of gnatclean (see gnatclean.adb) + +package Clean is + + procedure Gnatclean; + -- The driver for gnatclean + +end Clean; diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb new file mode 100644 index 000000000..da6c8a688 --- /dev/null +++ b/gcc/ada/comperr.adb @@ -0,0 +1,441 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C O M P E R 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by AdaCore. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines called when a fatal internal compiler +-- error is detected. Calls to these routines cause termination of the +-- current compilation with appropriate error output. + +with Atree; use Atree; +with Debug; use Debug; +with Errout; use Errout; +with Gnatvsn; use Gnatvsn; +with Namet; use Namet; +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; +with Sinput; use Sinput; +with Sprint; use Sprint; +with Sdefault; use Sdefault; +with Targparm; use Targparm; +with Treepr; use Treepr; +with Types; use Types; + +with Ada.Exceptions; use Ada.Exceptions; + +with System.Soft_Links; use System.Soft_Links; + +package body Comperr is + + ---------------- + -- Local Data -- + ---------------- + + Abort_In_Progress : Boolean := False; + -- Used to prevent runaway recursion if something segfaults + -- while processing a previous abort. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Repeat_Char (Char : Character; Col : Nat; After : Character); + -- Output Char until current column is at or past Col, and then output + -- the character given by After (if column is already past Col on entry, + -- then the effect is simply to output the After character). + + -------------------- + -- Compiler_Abort -- + -------------------- + + procedure Compiler_Abort + (X : String; + Code : Integer := 0; + Fallback_Loc : String := "") + is + -- The procedures below output a "bug box" with information about + -- the cause of the compiler abort and about the preferred method + -- of reporting bugs. The default is a bug box appropriate for + -- the FSF version of GNAT, but there are specializations for + -- the GNATPRO and Public releases by AdaCore. + + XF : constant Positive := X'First; + -- Start index, usually 1, but we won't assume this + + procedure End_Line; + -- Add blanks up to column 76, and then a final vertical bar + + -------------- + -- End_Line -- + -------------- + + procedure End_Line is + begin + Repeat_Char (' ', 76, '|'); + Write_Eol; + end End_Line; + + Is_GPL_Version : constant Boolean := Gnatvsn.Build_Type = GPL; + Is_FSF_Version : constant Boolean := Gnatvsn.Build_Type = FSF; + + -- Start of processing for Compiler_Abort + + begin + Cancel_Special_Output; + + -- Prevent recursion through Compiler_Abort, e.g. via SIGSEGV + + if Abort_In_Progress then + Exit_Program (E_Abort); + end if; + + Abort_In_Progress := True; + + -- Generate a "standard" error message instead of a bug box in case of + -- .NET compiler, since we do not support all constructs of the + -- language. Of course ideally, we should detect this before bombing + -- on e.g. an assertion error, but in practice most of these bombs + -- are due to a legitimate case of a construct not being supported (in + -- a sense they all are, since for sure we are not supporting something + -- if we bomb!) By giving this message, we provide a more reasonable + -- practical interface, since giving scary bug boxes on unsupported + -- features is definitely not helpful. + + -- Similarly if we are generating SCIL, an error message is sufficient + -- instead of generating a bug box. + + -- Note that the call to Error_Msg_N below sets Serious_Errors_Detected + -- to 1, so we use the regular mechanism below in order to display a + -- "compilation abandoned" message and exit, so we still know we have + -- this case (and -gnatdk can still be used to get the bug box). + + if (VM_Target = CLI_Target or else CodePeer_Mode) + and then Serious_Errors_Detected = 0 + and then not Debug_Flag_K + and then Sloc (Current_Error_Node) > No_Location + then + if VM_Target = CLI_Target then + Error_Msg_N + ("unsupported construct in this context", + Current_Error_Node); + else + Error_Msg_N ("cannot generate 'S'C'I'L", Current_Error_Node); + end if; + end if; + + -- If any errors have already occurred, then we guess that the abort + -- may well be caused by previous errors, and we don't make too much + -- fuss about it, since we want to let programmer fix the errors first. + + -- Debug flag K disables this behavior (useful for debugging) + + if Serious_Errors_Detected /= 0 and then not Debug_Flag_K then + Errout.Finalize (Last_Call => True); + Errout.Output_Messages; + + Set_Standard_Error; + Write_Str ("compilation abandoned due to previous error"); + Write_Eol; + + Set_Standard_Output; + Source_Dump; + Tree_Dump; + Exit_Program (E_Errors); + + -- Otherwise give message with details of the abort + + else + Set_Standard_Error; + + -- Generate header for bug box + + Write_Char ('+'); + Repeat_Char ('=', 29, 'G'); + Write_Str ("NAT BUG DETECTED"); + Repeat_Char ('=', 76, '+'); + Write_Eol; + + -- Output GNAT version identification + + Write_Str ("| "); + Write_Str (Gnat_Version_String); + Write_Str (" ("); + + -- Output target name, deleting junk final reverse slash + + if Target_Name.all (Target_Name.all'Last) = '\' + or else Target_Name.all (Target_Name.all'Last) = '/' + then + Write_Str (Target_Name.all (1 .. Target_Name.all'Last - 1)); + else + Write_Str (Target_Name.all); + end if; + + -- Output identification of error + + Write_Str (") "); + + if X'Length + Column > 76 then + if Code < 0 then + Write_Str ("GCC error:"); + end if; + + End_Line; + + Write_Str ("| "); + end if; + + if X'Length > 70 then + declare + Last_Blank : Integer := 70; + + begin + for P in 39 .. 68 loop + if X (XF + P) = ' ' then + Last_Blank := P; + end if; + end loop; + + Write_Str (X (XF .. XF - 1 + Last_Blank)); + End_Line; + Write_Str ("| "); + Write_Str (X (XF + Last_Blank .. X'Last)); + end; + else + Write_Str (X); + end if; + + if Code > 0 then + Write_Str (", Code="); + Write_Int (Int (Code)); + + elsif Code = 0 then + + -- For exception case, get exception message from the TSD. Note + -- that it would be neater and cleaner to pass the exception + -- message (obtained from Exception_Message) as a parameter to + -- Compiler_Abort, but we can't do this quite yet since it would + -- cause bootstrap path problems for 3.10 to 3.11. + + Write_Char (' '); + Write_Str (Exception_Message (Get_Current_Excep.all.all)); + end if; + + End_Line; + + -- Output source location information + + if Sloc (Current_Error_Node) <= No_Location then + if Fallback_Loc'Length > 0 then + Write_Str ("| Error detected around "); + Write_Str (Fallback_Loc); + else + Write_Str ("| No source file position information available"); + end if; + + End_Line; + else + Write_Str ("| Error detected at "); + Write_Location (Sloc (Current_Error_Node)); + End_Line; + end if; + + -- There are two cases now. If the file gnat_bug.box exists, + -- we use the contents of this file at this point. + + declare + Lo : Source_Ptr; + Hi : Source_Ptr; + Src : Source_Buffer_Ptr; + + begin + Namet.Unlock; + Name_Buffer (1 .. 12) := "gnat_bug.box"; + Name_Len := 12; + Read_Source_File (Name_Enter, 0, Hi, Src); + + -- If we get a Src file, we use it + + if Src /= null then + Lo := 0; + + Outer : while Lo < Hi loop + Write_Str ("| "); + + Inner : loop + exit Inner when Src (Lo) = ASCII.CR + or else Src (Lo) = ASCII.LF; + Write_Char (Src (Lo)); + Lo := Lo + 1; + end loop Inner; + + End_Line; + + while Lo <= Hi + and then (Src (Lo) = ASCII.CR + or else Src (Lo) = ASCII.LF) + loop + Lo := Lo + 1; + end loop; + end loop Outer; + + -- Otherwise we use the standard fixed text + + else + if Is_FSF_Version then + Write_Str + ("| Please submit a bug report; see" & + " http://gcc.gnu.org/bugs.html."); + End_Line; + + elsif Is_GPL_Version then + + Write_Str + ("| Please submit a bug report by email " & + "to report@adacore.com."); + End_Line; + + Write_Str + ("| GAP members can alternatively use GNAT Tracker:"); + End_Line; + + Write_Str + ("| http://www.adacore.com/ " & + "section 'send a report'."); + End_Line; + + Write_Str + ("| See gnatinfo.txt for full info on procedure " & + "for submitting bugs."); + End_Line; + + else + Write_Str + ("| Please submit a bug report using GNAT Tracker:"); + End_Line; + + Write_Str + ("| http://www.adacore.com/gnattracker/ " & + "section 'send a report'."); + End_Line; + + Write_Str + ("| alternatively submit a bug report by email " & + "to report@adacore.com,"); + End_Line; + + Write_Str + ("| including your customer number #nnn " & + "in the subject line."); + End_Line; + end if; + + Write_Str + ("| Use a subject line meaningful to you" & + " and us to track the bug."); + End_Line; + + Write_Str + ("| Include the entire contents of this bug " & + "box in the report."); + End_Line; + + Write_Str + ("| Include the exact gcc or gnatmake command " & + "that you entered."); + End_Line; + + Write_Str + ("| Also include sources listed below in gnatchop format"); + End_Line; + + Write_Str + ("| (concatenated together with no headers between files)."); + End_Line; + + if not Is_FSF_Version then + Write_Str + ("| Use plain ASCII or MIME attachment."); + End_Line; + end if; + end if; + end; + + -- Complete output of bug box + + Write_Char ('+'); + Repeat_Char ('=', 76, '+'); + Write_Eol; + + if Debug_Flag_3 then + Write_Eol; + Write_Eol; + Print_Tree_Node (Current_Error_Node); + Write_Eol; + end if; + + Write_Eol; + + Write_Line ("Please include these source files with error report"); + Write_Line ("Note that list may not be accurate in some cases, "); + Write_Line ("so please double check that the problem can still "); + Write_Line ("be reproduced with the set of files listed."); + Write_Line ("Consider also -gnatd.n switch (see debug.adb)."); + Write_Eol; + + begin + Dump_Source_File_Names; + + -- If we blow up trying to print the list of file names, just output + -- informative msg and continue. + + exception + when others => + Write_Str ("list may be incomplete"); + end; + + Write_Eol; + Set_Standard_Output; + + Tree_Dump; + Source_Dump; + raise Unrecoverable_Error; + end if; + + end Compiler_Abort; + + ----------------- + -- Repeat_Char -- + ----------------- + + procedure Repeat_Char (Char : Character; Col : Nat; After : Character) is + begin + while Column < Col loop + Write_Char (Char); + end loop; + + Write_Char (After); + end Repeat_Char; + +end Comperr; diff --git a/gcc/ada/comperr.ads b/gcc/ada/comperr.ads new file mode 100644 index 000000000..04a606218 --- /dev/null +++ b/gcc/ada/comperr.ads @@ -0,0 +1,76 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C O M P E R R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 called when a fatal internal compiler +-- error is detected. Calls to this routines cause termination of the +-- current compilation with appropriate error output. + +package Comperr is + + procedure Compiler_Abort + (X : String; + Code : Integer := 0; + Fallback_Loc : String := ""); + -- Signals an internal compiler error. Never returns control. Depending on + -- processing may end up raising Unrecoverable_Error, or exiting directly. + -- The message output is a "bug box" containing the first string passed as + -- an argument. The Sloc field of the node in Current_Error_Node is used to + -- provide the location where the error should be signalled. If this Sloc + -- value is set to No_Location or any of the other special location values, + -- then the Fallback_Loc argument string is used instead. The message text + -- includes the node id, and the code parameter if it is positive. + -- + -- Note that this is only used at the outer level (to handle constraint + -- errors or assert errors etc.) In the normal logic of the compiler we + -- always use pragma Assert to check for errors, and if necessary an + -- explicit abort is achieved by pragma Assert (False). Code is positive + -- for a gigi abort (giving the gigi abort code), zero for a front + -- end exception (with possible message stored in TSD.Current_Excep, + -- and negative (an unused value) for a GCC abort. + + ------------------------------ + -- Use of gnat_bug.box File -- + ------------------------------ + + -- When comperr generates the "bug box". The first two lines contain + -- information on the version number, type of abort, and source location. + + -- Normally the remaining text is one of three possible forms + -- depending on Gnatvsn.Gnat_Version_Type (FSF, Public, GNATPRO). + -- See body of this package for the exact text used. + + -- In addition, an alternative mechanism exists for easily substituting + -- different text for this message. Compiler_Abort checks for the + -- existence of the file "gnat_bug.box" in the current source path. + -- Most typically this file, if present, will be in the directory + -- containing the run-time sources. + + -- If this file is present, then it is a plain ASCII file, whose contents + -- replace the remaining text. The lines in this file should be seventy-two + -- characters or less to avoid misformatting the right boundary of the box. + -- Note that the file does not contain the vertical bar characters or any + -- leading spaces in lines. + +end Comperr; diff --git a/gcc/ada/config-lang.in b/gcc/ada/config-lang.in new file mode 100644 index 000000000..3d829373b --- /dev/null +++ b/gcc/ada/config-lang.in @@ -0,0 +1,27 @@ +# Top level configure fragment for GNU Ada (GNAT). +# Copyright (C) 1994-2009 Free Software Foundation, Inc. + +#This file is part of GCC. + +#GCC is free software; you can redistribute it and/or modify +#it under the terms of the GNU General Public License as published by +#the Free Software Foundation; either version 3, or (at your option) +#any later version. + +#GCC is distributed in the hope that it will be useful, +#but WITHOUT ANY WARRANTY; without even the implied warranty of +#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +#GNU General Public License for more details. + +#You should have received a copy of the GNU General Public License +#along with GCC; see the file COPYING3. If not see +#. + +language="ada" +gcc_subdir="ada/gcc-interface" + +if [ -f ${srcdir}/gcc/ada/gcc-interface/config-lang.in ]; then + . ${srcdir}/gcc/ada/gcc-interface/config-lang.in +else + . ${srcdir}/ada/gcc-interface/config-lang.in +fi diff --git a/gcc/ada/csets.adb b/gcc/ada/csets.adb new file mode 100644 index 000000000..771affc3b --- /dev/null +++ b/gcc/ada/csets.adb @@ -0,0 +1,1187 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C S E T 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 Opt; use Opt; + +with System.WCh_Con; use System.WCh_Con; + +package body Csets is + + X_80 : constant Character := Character'Val (16#80#); + X_81 : constant Character := Character'Val (16#81#); + X_82 : constant Character := Character'Val (16#82#); + X_83 : constant Character := Character'Val (16#83#); + X_84 : constant Character := Character'Val (16#84#); + X_85 : constant Character := Character'Val (16#85#); + X_86 : constant Character := Character'Val (16#86#); + X_87 : constant Character := Character'Val (16#87#); + X_88 : constant Character := Character'Val (16#88#); + X_89 : constant Character := Character'Val (16#89#); + X_8A : constant Character := Character'Val (16#8A#); + X_8B : constant Character := Character'Val (16#8B#); + X_8C : constant Character := Character'Val (16#8C#); + X_8D : constant Character := Character'Val (16#8D#); + X_8E : constant Character := Character'Val (16#8E#); + X_8F : constant Character := Character'Val (16#8F#); + X_90 : constant Character := Character'Val (16#90#); + X_91 : constant Character := Character'Val (16#91#); + X_92 : constant Character := Character'Val (16#92#); + X_93 : constant Character := Character'Val (16#93#); + X_94 : constant Character := Character'Val (16#94#); + X_95 : constant Character := Character'Val (16#95#); + X_96 : constant Character := Character'Val (16#96#); + X_97 : constant Character := Character'Val (16#97#); + X_98 : constant Character := Character'Val (16#98#); + X_99 : constant Character := Character'Val (16#99#); + X_9A : constant Character := Character'Val (16#9A#); + X_9B : constant Character := Character'Val (16#9B#); + X_9C : constant Character := Character'Val (16#9C#); + X_9D : constant Character := Character'Val (16#9D#); + X_9E : constant Character := Character'Val (16#9E#); + X_9F : constant Character := Character'Val (16#9F#); + X_A0 : constant Character := Character'Val (16#A0#); + X_A1 : constant Character := Character'Val (16#A1#); + X_A2 : constant Character := Character'Val (16#A2#); + X_A3 : constant Character := Character'Val (16#A3#); + X_A4 : constant Character := Character'Val (16#A4#); + X_A5 : constant Character := Character'Val (16#A5#); + X_A6 : constant Character := Character'Val (16#A6#); + X_A7 : constant Character := Character'Val (16#A7#); + X_A8 : constant Character := Character'Val (16#A8#); + X_A9 : constant Character := Character'Val (16#A9#); + X_AA : constant Character := Character'Val (16#AA#); + X_AB : constant Character := Character'Val (16#AB#); + X_AC : constant Character := Character'Val (16#AC#); + X_AD : constant Character := Character'Val (16#AD#); + X_AE : constant Character := Character'Val (16#AE#); + X_AF : constant Character := Character'Val (16#AF#); + X_B0 : constant Character := Character'Val (16#B0#); + X_B1 : constant Character := Character'Val (16#B1#); + X_B2 : constant Character := Character'Val (16#B2#); + X_B3 : constant Character := Character'Val (16#B3#); + X_B4 : constant Character := Character'Val (16#B4#); + X_B5 : constant Character := Character'Val (16#B5#); + X_B6 : constant Character := Character'Val (16#B6#); + X_B7 : constant Character := Character'Val (16#B7#); + X_B8 : constant Character := Character'Val (16#B8#); + X_B9 : constant Character := Character'Val (16#B9#); + X_BA : constant Character := Character'Val (16#BA#); + X_BB : constant Character := Character'Val (16#BB#); + X_BC : constant Character := Character'Val (16#BC#); + X_BD : constant Character := Character'Val (16#BD#); + X_BE : constant Character := Character'Val (16#BE#); + X_BF : constant Character := Character'Val (16#BF#); + X_C0 : constant Character := Character'Val (16#C0#); + X_C1 : constant Character := Character'Val (16#C1#); + X_C2 : constant Character := Character'Val (16#C2#); + X_C3 : constant Character := Character'Val (16#C3#); + X_C4 : constant Character := Character'Val (16#C4#); + X_C5 : constant Character := Character'Val (16#C5#); + X_C6 : constant Character := Character'Val (16#C6#); + X_C7 : constant Character := Character'Val (16#C7#); + X_C8 : constant Character := Character'Val (16#C8#); + X_C9 : constant Character := Character'Val (16#C9#); + X_CA : constant Character := Character'Val (16#CA#); + X_CB : constant Character := Character'Val (16#CB#); + X_CC : constant Character := Character'Val (16#CC#); + X_CD : constant Character := Character'Val (16#CD#); + X_CE : constant Character := Character'Val (16#CE#); + X_CF : constant Character := Character'Val (16#CF#); + X_D0 : constant Character := Character'Val (16#D0#); + X_D1 : constant Character := Character'Val (16#D1#); + X_D2 : constant Character := Character'Val (16#D2#); + X_D3 : constant Character := Character'Val (16#D3#); + X_D4 : constant Character := Character'Val (16#D4#); + X_D5 : constant Character := Character'Val (16#D5#); + X_D6 : constant Character := Character'Val (16#D6#); + X_D7 : constant Character := Character'Val (16#D7#); + X_D8 : constant Character := Character'Val (16#D8#); + X_D9 : constant Character := Character'Val (16#D9#); + X_DA : constant Character := Character'Val (16#DA#); + X_DB : constant Character := Character'Val (16#DB#); + X_DC : constant Character := Character'Val (16#DC#); + X_DD : constant Character := Character'Val (16#DD#); + X_DE : constant Character := Character'Val (16#DE#); + X_DF : constant Character := Character'Val (16#DF#); + X_E0 : constant Character := Character'Val (16#E0#); + X_E1 : constant Character := Character'Val (16#E1#); + X_E2 : constant Character := Character'Val (16#E2#); + X_E3 : constant Character := Character'Val (16#E3#); + X_E4 : constant Character := Character'Val (16#E4#); + X_E5 : constant Character := Character'Val (16#E5#); + X_E6 : constant Character := Character'Val (16#E6#); + X_E7 : constant Character := Character'Val (16#E7#); + X_E8 : constant Character := Character'Val (16#E8#); + X_E9 : constant Character := Character'Val (16#E9#); + X_EA : constant Character := Character'Val (16#EA#); + X_EB : constant Character := Character'Val (16#EB#); + X_EC : constant Character := Character'Val (16#EC#); + X_ED : constant Character := Character'Val (16#ED#); + X_EE : constant Character := Character'Val (16#EE#); + X_EF : constant Character := Character'Val (16#EF#); + X_F0 : constant Character := Character'Val (16#F0#); + X_F1 : constant Character := Character'Val (16#F1#); + X_F2 : constant Character := Character'Val (16#F2#); + X_F3 : constant Character := Character'Val (16#F3#); + X_F4 : constant Character := Character'Val (16#F4#); + X_F5 : constant Character := Character'Val (16#F5#); + X_F6 : constant Character := Character'Val (16#F6#); + X_F7 : constant Character := Character'Val (16#F7#); + X_F8 : constant Character := Character'Val (16#F8#); + X_F9 : constant Character := Character'Val (16#F9#); + X_FA : constant Character := Character'Val (16#FA#); + X_FB : constant Character := Character'Val (16#FB#); + X_FC : constant Character := Character'Val (16#FC#); + X_FD : constant Character := Character'Val (16#FD#); + X_FE : constant Character := Character'Val (16#FE#); + X_FF : constant Character := Character'Val (16#FF#); + + ------------------------------------------ + -- Definitions for Latin-1 (ISO 8859-1) -- + ------------------------------------------ + + Fold_Latin_1 : constant Translate_Table := Translate_Table'( + + 'a' => 'A', X_E0 => X_C0, X_F0 => X_D0, + 'b' => 'B', X_E1 => X_C1, X_F1 => X_D1, + 'c' => 'C', X_E2 => X_C2, X_F2 => X_D2, + 'd' => 'D', X_E3 => X_C3, X_F3 => X_D3, + 'e' => 'E', X_E4 => X_C4, X_F4 => X_D4, + 'f' => 'F', X_E5 => X_C5, X_F5 => X_D5, + 'g' => 'G', X_E6 => X_C6, X_F6 => X_D6, + 'h' => 'H', X_E7 => X_C7, + 'i' => 'I', X_E8 => X_C8, X_F8 => X_D8, + 'j' => 'J', X_E9 => X_C9, X_F9 => X_D9, + 'k' => 'K', X_EA => X_CA, X_FA => X_DA, + 'l' => 'L', X_EB => X_CB, X_FB => X_DB, + 'm' => 'M', X_EC => X_CC, X_FC => X_DC, + 'n' => 'N', X_ED => X_CD, X_FD => X_DD, + 'o' => 'O', X_EE => X_CE, X_FE => X_DE, + 'p' => 'P', X_EF => X_CF, + 'q' => 'Q', + 'r' => 'R', + 's' => 'S', + 't' => 'T', + 'u' => 'U', + 'v' => 'V', + 'w' => 'W', + 'x' => 'X', + 'y' => 'Y', + 'z' => 'Z', + + 'A' => 'A', X_C0 => X_C0, X_D0 => X_D0, + 'B' => 'B', X_C1 => X_C1, X_D1 => X_D1, + 'C' => 'C', X_C2 => X_C2, X_D2 => X_D2, + 'D' => 'D', X_C3 => X_C3, X_D3 => X_D3, + 'E' => 'E', X_C4 => X_C4, X_D4 => X_D4, + 'F' => 'F', X_C5 => X_C5, X_D5 => X_D5, + 'G' => 'G', X_C6 => X_C6, X_D6 => X_D6, + 'H' => 'H', X_C7 => X_C7, + 'I' => 'I', X_C8 => X_C8, X_D8 => X_D8, + 'J' => 'J', X_C9 => X_C9, X_D9 => X_D9, + 'K' => 'K', X_CA => X_CA, X_DA => X_DA, + 'L' => 'L', X_CB => X_CB, X_DB => X_DB, + 'M' => 'M', X_CC => X_CC, X_DC => X_DC, + 'N' => 'N', X_CD => X_CD, X_DD => X_DD, + 'O' => 'O', X_CE => X_CE, X_DE => X_DE, + 'P' => 'P', X_CF => X_CF, X_DF => X_DF, X_FF => X_FF, + 'Q' => 'Q', + 'R' => 'R', + 'S' => 'S', + 'T' => 'T', + 'U' => 'U', + 'V' => 'V', + 'W' => 'W', + 'X' => 'X', + 'Y' => 'Y', + 'Z' => 'Z', + + '0' => '0', + '1' => '1', + '2' => '2', + '3' => '3', + '4' => '4', + '5' => '5', + '6' => '6', + '7' => '7', + '8' => '8', + '9' => '9', + + '_' => '_', + + others => ' '); + + ------------------------------------------ + -- Definitions for Latin-2 (ISO 8859-2) -- + ------------------------------------------ + + Fold_Latin_2 : constant Translate_Table := Translate_Table'( + + 'a' => 'A', X_E0 => X_C0, X_F0 => X_D0, + 'b' => 'B', X_E1 => X_C1, X_F1 => X_D1, X_B1 => X_A1, + 'c' => 'C', X_E2 => X_C2, X_F2 => X_D2, + 'd' => 'D', X_E3 => X_C3, X_F3 => X_D3, X_B3 => X_A3, + 'e' => 'E', X_E4 => X_C4, X_F4 => X_D4, + 'f' => 'F', X_E5 => X_C5, X_F5 => X_D5, X_B5 => X_A5, + 'g' => 'G', X_E6 => X_C6, X_F6 => X_D6, X_B6 => X_A6, + 'h' => 'H', X_E7 => X_C7, + 'i' => 'I', X_E8 => X_C8, X_F8 => X_D8, + 'j' => 'J', X_E9 => X_C9, X_F9 => X_D9, X_B9 => X_A9, + 'k' => 'K', X_EA => X_CA, X_FA => X_DA, X_BA => X_AA, + 'l' => 'L', X_EB => X_CB, X_FB => X_DB, X_BB => X_AB, + 'm' => 'M', X_EC => X_CC, X_FC => X_DC, X_BC => X_AC, + 'n' => 'N', X_ED => X_CD, X_FD => X_DD, + 'o' => 'O', X_EE => X_CE, X_FE => X_DE, X_BE => X_AE, + 'p' => 'P', X_EF => X_CF, X_FF => X_DF, X_BF => X_AF, + 'q' => 'Q', + 'r' => 'R', + 's' => 'S', + 't' => 'T', + 'u' => 'U', + 'v' => 'V', + 'w' => 'W', + 'x' => 'X', + 'y' => 'Y', + 'z' => 'Z', + + 'A' => 'A', X_C0 => X_C0, X_D0 => X_D0, + 'B' => 'B', X_C1 => X_C1, X_D1 => X_D1, X_A1 => X_A1, + 'C' => 'C', X_C2 => X_C2, X_D2 => X_D2, + 'D' => 'D', X_C3 => X_C3, X_D3 => X_D3, X_A3 => X_A3, + 'E' => 'E', X_C4 => X_C4, X_D4 => X_D4, + 'F' => 'F', X_C5 => X_C5, X_D5 => X_D5, X_A5 => X_A5, + 'G' => 'G', X_C6 => X_C6, X_D6 => X_D6, X_A6 => X_A6, + 'H' => 'H', X_C7 => X_C7, + 'I' => 'I', X_C8 => X_C8, X_D8 => X_D8, + 'J' => 'J', X_C9 => X_C9, X_D9 => X_D9, X_A9 => X_A9, + 'K' => 'K', X_CA => X_CA, X_DA => X_DA, X_AA => X_AA, + 'L' => 'L', X_CB => X_CB, X_DB => X_DB, X_AB => X_AB, + 'M' => 'M', X_CC => X_CC, X_DC => X_DC, X_AC => X_AC, + 'N' => 'N', X_CD => X_CD, X_DD => X_DD, + 'O' => 'O', X_CE => X_CE, X_DE => X_DE, X_AE => X_AE, + 'P' => 'P', X_CF => X_CF, X_DF => X_DF, X_AF => X_AF, + 'Q' => 'Q', + 'R' => 'R', + 'S' => 'S', + 'T' => 'T', + 'U' => 'U', + 'V' => 'V', + 'W' => 'W', + 'X' => 'X', + 'Y' => 'Y', + 'Z' => 'Z', + + '0' => '0', + '1' => '1', + '2' => '2', + '3' => '3', + '4' => '4', + '5' => '5', + '6' => '6', + '7' => '7', + '8' => '8', + '9' => '9', + + '_' => '_', + + others => ' '); + + ------------------------------------------ + -- Definitions for Latin-3 (ISO 8859-3) -- + ------------------------------------------ + + Fold_Latin_3 : constant Translate_Table := Translate_Table'( + + 'a' => 'A', X_E0 => X_C0, + 'b' => 'B', X_E1 => X_C1, X_F1 => X_D1, X_B1 => X_A1, + 'c' => 'C', X_E2 => X_C2, X_F2 => X_D2, + 'd' => 'D', X_F3 => X_D3, + 'e' => 'E', X_E4 => X_C4, X_F4 => X_D4, + 'f' => 'F', X_E5 => X_C5, X_F5 => X_D5, X_B5 => X_A5, + 'g' => 'G', X_E6 => X_C6, X_F6 => X_D6, X_B6 => X_A6, + 'h' => 'H', X_E7 => X_C7, + 'i' => 'I', X_E8 => X_C8, X_F8 => X_D8, + 'j' => 'J', X_E9 => X_C9, X_F9 => X_D9, X_B9 => X_A9, + 'k' => 'K', X_EA => X_CA, X_FA => X_DA, X_BA => X_AA, + 'l' => 'L', X_EB => X_CB, X_FB => X_DB, X_BB => X_AB, + 'm' => 'M', X_EC => X_CC, X_FC => X_DC, X_BC => X_AC, + 'n' => 'N', X_ED => X_CD, X_FD => X_DD, + 'o' => 'O', X_EE => X_CE, X_FE => X_DE, + 'p' => 'P', X_EF => X_CF, X_BF => X_AF, + 'q' => 'Q', + 'r' => 'R', + 's' => 'S', + 't' => 'T', + 'u' => 'U', + 'v' => 'V', + 'w' => 'W', + 'x' => 'X', + 'y' => 'Y', + 'z' => 'Z', + + 'A' => 'A', X_C0 => X_C0, + 'B' => 'B', X_C1 => X_C1, X_D1 => X_D1, X_A1 => X_A1, + 'C' => 'C', X_C2 => X_C2, X_D2 => X_D2, + 'D' => 'D', X_D3 => X_D3, + 'E' => 'E', X_C4 => X_C4, X_D4 => X_D4, + 'F' => 'F', X_C5 => X_C5, X_D5 => X_D5, X_A5 => X_A5, + 'G' => 'G', X_C6 => X_C6, X_D6 => X_D6, X_A6 => X_A6, + 'H' => 'H', X_C7 => X_C7, + 'I' => 'I', X_C8 => X_C8, X_D8 => X_D8, + 'J' => 'J', X_C9 => X_C9, X_D9 => X_D9, X_A9 => X_A9, + 'K' => 'K', X_CA => X_CA, X_DA => X_DA, X_AA => X_AA, + 'L' => 'L', X_CB => X_CB, X_DB => X_DB, X_AB => X_AB, + 'M' => 'M', X_CC => X_CC, X_DC => X_DC, X_AC => X_AC, + 'N' => 'N', X_CD => X_CD, X_DD => X_DD, + 'O' => 'O', X_CE => X_CE, X_DE => X_DE, + 'P' => 'P', X_CF => X_CF, X_AF => X_AF, + 'Q' => 'Q', + 'R' => 'R', + 'S' => 'S', + 'T' => 'T', + 'U' => 'U', + 'V' => 'V', + 'W' => 'W', + 'X' => 'X', + 'Y' => 'Y', + 'Z' => 'Z', + + '0' => '0', + '1' => '1', + '2' => '2', + '3' => '3', + '4' => '4', + '5' => '5', + '6' => '6', + '7' => '7', + '8' => '8', + '9' => '9', + + '_' => '_', + + others => ' '); + + ------------------------------------------ + -- Definitions for Latin-4 (ISO 8859-4) -- + ------------------------------------------ + + Fold_Latin_4 : constant Translate_Table := Translate_Table'( + + 'a' => 'A', X_E0 => X_C0, X_F0 => X_D0, + 'b' => 'B', X_E1 => X_C1, X_F1 => X_D1, X_B1 => X_A1, + 'c' => 'C', X_E2 => X_C2, X_F2 => X_D2, + 'd' => 'D', X_E3 => X_C3, X_F3 => X_D3, X_B3 => X_A3, + 'e' => 'E', X_E4 => X_C4, X_F4 => X_D4, + 'f' => 'F', X_E5 => X_C5, X_F5 => X_D5, X_B5 => X_A5, + 'g' => 'G', X_E6 => X_C6, X_F6 => X_D6, X_B6 => X_A6, + 'h' => 'H', X_E7 => X_C7, + 'i' => 'I', X_E8 => X_C8, X_F8 => X_D8, + 'j' => 'J', X_E9 => X_C9, X_F9 => X_D9, X_B9 => X_A9, + 'k' => 'K', X_EA => X_CA, X_FA => X_DA, X_BA => X_AA, + 'l' => 'L', X_EB => X_CB, X_FB => X_DB, X_BB => X_AB, + 'm' => 'M', X_EC => X_CC, X_FC => X_DC, X_BC => X_AC, + 'n' => 'N', X_ED => X_CD, X_FD => X_DD, + 'o' => 'O', X_EE => X_CE, X_FE => X_DE, X_BE => X_AE, + 'p' => 'P', X_EF => X_CF, + 'q' => 'Q', + 'r' => 'R', + 's' => 'S', + 't' => 'T', + 'u' => 'U', + 'v' => 'V', + 'w' => 'W', + 'x' => 'X', + 'y' => 'Y', + 'z' => 'Z', + + 'A' => 'A', X_C0 => X_C0, X_D0 => X_D0, + 'B' => 'B', X_C1 => X_C1, X_D1 => X_D1, X_A1 => X_A1, + 'C' => 'C', X_C2 => X_C2, X_D2 => X_D2, + 'D' => 'D', X_C3 => X_C3, X_D3 => X_D3, X_A3 => X_A3, + 'E' => 'E', X_C4 => X_C4, X_D4 => X_D4, + 'F' => 'F', X_C5 => X_C5, X_D5 => X_D5, X_A5 => X_A5, + 'G' => 'G', X_C6 => X_C6, X_D6 => X_D6, X_A6 => X_A6, + 'H' => 'H', X_C7 => X_C7, + 'I' => 'I', X_C8 => X_C8, X_D8 => X_D8, + 'J' => 'J', X_C9 => X_C9, X_D9 => X_D9, X_A9 => X_A9, + 'K' => 'K', X_CA => X_CA, X_DA => X_DA, X_AA => X_AA, + 'L' => 'L', X_CB => X_CB, X_DB => X_DB, X_AB => X_AB, + 'M' => 'M', X_CC => X_CC, X_DC => X_DC, X_AC => X_AC, + 'N' => 'N', X_CD => X_CD, X_DD => X_DD, + 'O' => 'O', X_CE => X_CE, X_DE => X_DE, X_AE => X_AE, + 'P' => 'P', X_CF => X_CF, + 'Q' => 'Q', + 'R' => 'R', + 'S' => 'S', + 'T' => 'T', + 'U' => 'U', + 'V' => 'V', + 'W' => 'W', + 'X' => 'X', + 'Y' => 'Y', + 'Z' => 'Z', + + '0' => '0', + '1' => '1', + '2' => '2', + '3' => '3', + '4' => '4', + '5' => '5', + '6' => '6', + '7' => '7', + '8' => '8', + '9' => '9', + + '_' => '_', + + others => ' '); + + --------------------------------------------------- + -- Definitions for Latin-5 (Cyrillic ISO-8859-5) -- + --------------------------------------------------- + + Fold_Latin_5 : constant Translate_Table := Translate_Table'( + + 'a' => 'A', X_D0 => X_B0, X_E0 => X_C0, + 'b' => 'B', X_D1 => X_B1, X_E1 => X_C1, X_F1 => X_A1, + 'c' => 'C', X_D2 => X_B2, X_E2 => X_C2, X_F2 => X_A2, + 'd' => 'D', X_D3 => X_B3, X_E3 => X_C3, X_F3 => X_A3, + 'e' => 'E', X_D4 => X_B4, X_E4 => X_C4, X_F4 => X_A4, + 'f' => 'F', X_D5 => X_B5, X_E5 => X_C5, X_F5 => X_A5, + 'g' => 'G', X_D6 => X_B6, X_E6 => X_C6, X_F6 => X_A6, + 'h' => 'H', X_D7 => X_B7, X_E7 => X_C7, X_F7 => X_A7, + 'i' => 'I', X_D8 => X_B8, X_E8 => X_C8, X_F8 => X_A8, + 'j' => 'J', X_D9 => X_B9, X_E9 => X_C9, X_F9 => X_A9, + 'k' => 'K', X_DA => X_BA, X_EA => X_CA, X_FA => X_AA, + 'l' => 'L', X_DB => X_BB, X_EB => X_CB, X_FB => X_AB, + 'm' => 'M', X_DC => X_BC, X_EC => X_CC, X_FC => X_AC, + 'n' => 'N', X_DD => X_BD, X_ED => X_CD, + 'o' => 'O', X_DE => X_BE, X_EE => X_CE, X_FE => X_AE, + 'p' => 'P', X_DF => X_BF, X_EF => X_CF, X_FF => X_AF, + 'q' => 'Q', + 'r' => 'R', + 's' => 'S', + 't' => 'T', + 'u' => 'U', + 'v' => 'V', + 'w' => 'W', + 'x' => 'X', + 'y' => 'Y', + 'z' => 'Z', + + 'A' => 'A', X_B0 => X_B0, X_C0 => X_C0, + 'B' => 'B', X_B1 => X_B1, X_C1 => X_C1, X_A1 => X_A1, + 'C' => 'C', X_B2 => X_B2, X_C2 => X_C2, X_A2 => X_A2, + 'D' => 'D', X_B3 => X_B3, X_C3 => X_C3, X_A3 => X_A3, + 'E' => 'E', X_B4 => X_B4, X_C4 => X_C4, X_A4 => X_A4, + 'F' => 'F', X_B5 => X_B5, X_C5 => X_C5, X_A5 => X_A5, + 'G' => 'G', X_B6 => X_B6, X_C6 => X_C6, X_A6 => X_A6, + 'H' => 'H', X_B7 => X_B7, X_C7 => X_C7, X_A7 => X_A7, + 'I' => 'I', X_B8 => X_B8, X_C8 => X_C8, X_A8 => X_A8, + 'J' => 'J', X_B9 => X_B9, X_C9 => X_C9, X_A9 => X_A9, + 'K' => 'K', X_BA => X_BA, X_CA => X_CA, X_AA => X_AA, + 'L' => 'L', X_BB => X_BB, X_CB => X_CB, X_AB => X_AB, + 'M' => 'M', X_BC => X_BC, X_CC => X_CC, X_AC => X_AC, + 'N' => 'N', X_BD => X_BD, X_CD => X_CD, + 'O' => 'O', X_BE => X_BE, X_CE => X_CE, X_AE => X_AE, + 'P' => 'P', X_BF => X_BF, X_CF => X_CF, X_AF => X_AF, + 'Q' => 'Q', + 'R' => 'R', + 'S' => 'S', + 'T' => 'T', + 'U' => 'U', + 'V' => 'V', + 'W' => 'W', + 'X' => 'X', + 'Y' => 'Y', + 'Z' => 'Z', + + '0' => '0', + '1' => '1', + '2' => '2', + '3' => '3', + '4' => '4', + '5' => '5', + '6' => '6', + '7' => '7', + '8' => '8', + '9' => '9', + + '_' => '_', + + others => ' '); + + ------------------------------------------ + -- Definitions for Latin-9 (ISO 8859-9) -- + ------------------------------------------ + + Fold_Latin_9 : constant Translate_Table := Translate_Table'( + + 'a' => 'A', X_E0 => X_C0, X_F0 => X_D0, + 'b' => 'B', X_E1 => X_C1, X_F1 => X_D1, + 'c' => 'C', X_E2 => X_C2, X_F2 => X_D2, + 'd' => 'D', X_E3 => X_C3, X_F3 => X_D3, + 'e' => 'E', X_E4 => X_C4, X_F4 => X_D4, + 'f' => 'F', X_E5 => X_C5, X_F5 => X_D5, + 'g' => 'G', X_E6 => X_C6, X_F6 => X_D6, + 'h' => 'H', X_E7 => X_C7, + 'i' => 'I', X_E8 => X_C8, X_F8 => X_D8, + 'j' => 'J', X_E9 => X_C9, X_F9 => X_D9, + 'k' => 'K', X_EA => X_CA, X_FA => X_DA, + 'l' => 'L', X_EB => X_CB, X_FB => X_DB, + 'm' => 'M', X_EC => X_CC, X_FC => X_DC, + 'n' => 'N', X_ED => X_CD, X_FD => X_DD, + 'o' => 'O', X_EE => X_CE, X_FE => X_DE, + 'p' => 'P', X_EF => X_CF, + 'q' => 'Q', X_A8 => X_A6, + 'r' => 'R', X_B8 => X_B4, + 's' => 'S', X_BD => X_BC, + 't' => 'T', X_BE => X_FF, + 'u' => 'U', + 'v' => 'V', + 'w' => 'W', + 'x' => 'X', + 'y' => 'Y', + 'z' => 'Z', + + 'A' => 'A', X_C0 => X_C0, X_D0 => X_D0, + 'B' => 'B', X_C1 => X_C1, X_D1 => X_D1, + 'C' => 'C', X_C2 => X_C2, X_D2 => X_D2, + 'D' => 'D', X_C3 => X_C3, X_D3 => X_D3, + 'E' => 'E', X_C4 => X_C4, X_D4 => X_D4, + 'F' => 'F', X_C5 => X_C5, X_D5 => X_D5, + 'G' => 'G', X_C6 => X_C6, X_D6 => X_D6, + 'H' => 'H', X_C7 => X_C7, + 'I' => 'I', X_C8 => X_C8, X_D8 => X_D8, + 'J' => 'J', X_C9 => X_C9, X_D9 => X_D9, + 'K' => 'K', X_CA => X_CA, X_DA => X_DA, + 'L' => 'L', X_CB => X_CB, X_DB => X_DB, + 'M' => 'M', X_CC => X_CC, X_DC => X_DC, + 'N' => 'N', X_CD => X_CD, X_DD => X_DD, + 'O' => 'O', X_CE => X_CE, X_DE => X_DE, + 'P' => 'P', X_CF => X_CF, X_DF => X_DF, X_FF => X_FF, + 'Q' => 'Q', X_A6 => X_A6, + 'R' => 'R', X_B4 => X_B4, + 'S' => 'S', X_BC => X_BC, + 'T' => 'T', + 'U' => 'U', + 'V' => 'V', + 'W' => 'W', + 'X' => 'X', + 'Y' => 'Y', + 'Z' => 'Z', + + '0' => '0', + '1' => '1', + '2' => '2', + '3' => '3', + '4' => '4', + '5' => '5', + '6' => '6', + '7' => '7', + '8' => '8', + '9' => '9', + + '_' => '_', + + others => ' '); + + -------------------------------------------- + -- Definitions for IBM PC (Code Page 437) -- + -------------------------------------------- + + -- Note: Code page 437 is the typical default in Windows for PC's in the + -- US, it corresponds to the original PC character set. See also the + -- definitions for code page 850. + + Fold_IBM_PC_437 : constant Translate_Table := Translate_Table'( + + 'a' => 'A', + 'b' => 'B', + 'c' => 'C', + 'd' => 'D', + 'e' => 'E', + 'f' => 'F', + 'g' => 'G', + 'h' => 'H', + 'i' => 'I', + 'j' => 'J', + 'k' => 'K', + 'l' => 'L', + 'm' => 'M', + 'n' => 'N', + 'o' => 'O', + 'p' => 'P', + 'q' => 'Q', + 'r' => 'R', + 's' => 'S', + 't' => 'T', + 'u' => 'U', + 'v' => 'V', + 'w' => 'W', + 'x' => 'X', + 'y' => 'Y', + 'z' => 'Z', + + 'A' => 'A', + 'B' => 'B', + 'C' => 'C', + 'D' => 'D', + 'E' => 'E', + 'F' => 'F', + 'G' => 'G', + 'H' => 'H', + 'I' => 'I', + 'J' => 'J', + 'K' => 'K', + 'L' => 'L', + 'M' => 'M', + 'N' => 'N', + 'O' => 'O', + 'P' => 'P', + 'Q' => 'Q', + 'R' => 'R', + 'S' => 'S', + 'T' => 'T', + 'U' => 'U', + 'V' => 'V', + 'W' => 'W', + 'X' => 'X', + 'Y' => 'Y', + 'Z' => 'Z', + + X_80 => X_80, -- C cedilla + X_81 => X_9A, -- u umlaut + X_82 => X_90, -- e acute + X_83 => X_83, -- a circumflex + X_84 => X_8E, -- a umlaut + X_85 => X_85, -- a grave + X_86 => X_8F, -- a ring + X_87 => X_80, -- c cedilla + X_88 => X_88, -- e circumflex + X_89 => X_89, -- e umlaut + X_8A => X_8A, -- e grave + X_8B => X_8B, -- i umlaut + X_8C => X_8C, -- i circumflex + X_8D => X_8D, -- i grave + X_8E => X_8E, -- A umlaut + X_8F => X_8F, -- A ring + + X_90 => X_90, -- E acute + X_91 => X_92, -- ae + X_92 => X_92, -- AE + X_93 => X_93, -- o circumflex + X_94 => X_99, -- o umlaut + X_95 => X_95, -- o grave + X_96 => X_96, -- u circumflex + X_97 => X_97, -- u grave + X_98 => X_98, -- y umlaut + X_99 => X_99, -- O umlaut + X_9A => X_9A, -- U umlaut + + X_A0 => X_A0, -- a acute + X_A1 => X_A1, -- i acute + X_A2 => X_A2, -- o acute + X_A3 => X_A3, -- u acute + X_A4 => X_A5, -- n tilde + X_A5 => X_A5, -- N tilde + X_A6 => X_A6, -- a underline + X_A7 => X_A7, -- o underline + + X_E0 => X_E0, -- lower case alpha + X_E1 => X_E1, -- lower case beta + X_E2 => X_E2, -- upper case gamma + X_E3 => X_E3, -- lower case pi + X_E4 => X_E4, -- upper case sigma (lower/upper sigma not equivalent) + X_E5 => X_E5, -- lower case sigma (lower/upper sigma not equivalent) + X_E6 => X_E6, -- lower case mu + X_E7 => X_E7, -- lower case tau + X_E8 => X_E8, -- upper case phi (lower/upper phi not equivalent) + X_E9 => X_E9, -- lower case theta + X_EA => X_EA, -- upper case omega + X_EB => X_EB, -- lower case delta + X_ED => X_ED, -- lower case phi (lower/upper phi not equivalent) + X_EE => X_EE, -- lower case epsilon + + X_FC => X_FC, -- lower case eta + + '0' => '0', + '1' => '1', + '2' => '2', + '3' => '3', + '4' => '4', + '5' => '5', + '6' => '6', + '7' => '7', + '8' => '8', + '9' => '9', + + '_' => '_', + + others => ' '); + + -------------------------------------------- + -- Definitions for IBM PC (Code Page 850) -- + -------------------------------------------- + + -- Note: Code page 850 is the typical default in Windows for PC's in + -- Europe, it is an extension of the original PC character set to include + -- the additional characters defined in ISO Latin-1. See also the + -- definitions for code page 437. + + Fold_IBM_PC_850 : constant Translate_Table := Translate_Table'( + + 'a' => 'A', + 'b' => 'B', + 'c' => 'C', + 'd' => 'D', + 'e' => 'E', + 'f' => 'F', + 'g' => 'G', + 'h' => 'H', + 'i' => 'I', + 'j' => 'J', + 'k' => 'K', + 'l' => 'L', + 'm' => 'M', + 'n' => 'N', + 'o' => 'O', + 'p' => 'P', + 'q' => 'Q', + 'r' => 'R', + 's' => 'S', + 't' => 'T', + 'u' => 'U', + 'v' => 'V', + 'w' => 'W', + 'x' => 'X', + 'y' => 'Y', + 'z' => 'Z', + + 'A' => 'A', + 'B' => 'B', + 'C' => 'C', + 'D' => 'D', + 'E' => 'E', + 'F' => 'F', + 'G' => 'G', + 'H' => 'H', + 'I' => 'I', + 'J' => 'J', + 'K' => 'K', + 'L' => 'L', + 'M' => 'M', + 'N' => 'N', + 'O' => 'O', + 'P' => 'P', + 'Q' => 'Q', + 'R' => 'R', + 'S' => 'S', + 'T' => 'T', + 'U' => 'U', + 'V' => 'V', + 'W' => 'W', + 'X' => 'X', + 'Y' => 'Y', + 'Z' => 'Z', + + X_80 => X_80, -- C cedilla + X_81 => X_9A, -- u umlaut + X_82 => X_90, -- e acute + X_83 => X_B6, -- a circumflex + X_84 => X_8E, -- a umlaut + X_85 => X_B7, -- a grave + X_86 => X_8F, -- a ring + X_87 => X_80, -- c cedilla + X_88 => X_D2, -- e circumflex + X_89 => X_D3, -- e umlaut + X_8A => X_D4, -- e grave + X_8B => X_D8, -- i umlaut + X_8C => X_D7, -- i circumflex + X_8D => X_DE, -- i grave + X_8E => X_8E, -- A umlaut + X_8F => X_8F, -- A ring + + X_90 => X_90, -- E acute + X_91 => X_92, -- ae + X_92 => X_92, -- AE + X_93 => X_E2, -- o circumflex + X_94 => X_99, -- o umlaut + X_95 => X_E3, -- o grave + X_96 => X_EA, -- u circumflex + X_97 => X_EB, -- u grave + X_98 => X_98, -- y umlaut + X_99 => X_99, -- O umlaut + X_9A => X_9A, -- U umlaut + + X_A0 => X_B5, -- a acute + X_A1 => X_D6, -- i acute + X_A2 => X_E0, -- o acute + X_A3 => X_E9, -- u acute + X_A4 => X_A5, -- n tilde + X_A5 => X_A5, -- N tilde + X_A6 => X_A6, -- a underline + X_A7 => X_A7, -- o underline + + X_B5 => X_B5, -- A acute + X_B6 => X_B6, -- A circumflex + X_B7 => X_B7, -- A grave + + X_C6 => X_C7, -- a tilde + X_C7 => X_C7, -- A tilde + + X_D0 => X_D1, -- eth + X_D1 => X_D1, -- Eth + X_D2 => X_D2, -- E circumflex + X_D3 => X_D3, -- E umlaut + X_D4 => X_D4, -- E grave + X_D5 => X_D5, -- dotless i, no uppercase + X_D6 => X_D6, -- I acute + X_D7 => X_D7, -- I circumflex + X_D8 => X_D8, -- I umlaut + X_DE => X_DE, -- I grave + + X_E0 => X_E0, -- O acute + X_E1 => X_E1, -- german dbl s, no uppercase + X_E2 => X_E2, -- O circumflex + X_E3 => X_E3, -- O grave + X_E4 => X_E4, -- o tilde + X_E5 => X_E5, -- O tilde + X_E7 => X_E8, -- thorn + X_E8 => X_E8, -- Thorn + X_E9 => X_E9, -- U acute + X_EA => X_EA, -- U circumflex + X_EB => X_EB, -- U grave + X_EC => X_ED, -- y acute + X_ED => X_ED, -- Y acute + + '0' => '0', + '1' => '1', + '2' => '2', + '3' => '3', + '4' => '4', + '5' => '5', + '6' => '6', + '7' => '7', + '8' => '8', + '9' => '9', + + '_' => '_', + + others => ' '); + + ----------------------------------------- + -- Definitions for Full Upper Half Set -- + ----------------------------------------- + + -- The full upper half set allows all upper half characters as letters, + -- and does not recognize any upper/lower case equivalences in this half. + + Fold_Full_Upper_Half : constant Translate_Table := Translate_Table'( + + 'a' => 'A', + 'b' => 'B', + 'c' => 'C', + 'd' => 'D', + 'e' => 'E', + 'f' => 'F', + 'g' => 'G', + 'h' => 'H', + 'i' => 'I', + 'j' => 'J', + 'k' => 'K', + 'l' => 'L', + 'm' => 'M', + 'n' => 'N', + 'o' => 'O', + 'p' => 'P', + 'q' => 'Q', + 'r' => 'R', + 's' => 'S', + 't' => 'T', + 'u' => 'U', + 'v' => 'V', + 'w' => 'W', + 'x' => 'X', + 'y' => 'Y', + 'z' => 'Z', + + 'A' => 'A', + 'B' => 'B', + 'C' => 'C', + 'D' => 'D', + 'E' => 'E', + 'F' => 'F', + 'G' => 'G', + 'H' => 'H', + 'I' => 'I', + 'J' => 'J', + 'K' => 'K', + 'L' => 'L', + 'M' => 'M', + 'N' => 'N', + 'O' => 'O', + 'P' => 'P', + 'Q' => 'Q', + 'R' => 'R', + 'S' => 'S', + 'T' => 'T', + 'U' => 'U', + 'V' => 'V', + 'W' => 'W', + 'X' => 'X', + 'Y' => 'Y', + 'Z' => 'Z', + + X_80 => X_80, X_90 => X_90, X_A0 => X_A0, X_B0 => X_B0, + X_81 => X_81, X_91 => X_91, X_A1 => X_A1, X_B1 => X_B1, + X_82 => X_82, X_92 => X_92, X_A2 => X_A2, X_B2 => X_B2, + X_83 => X_83, X_93 => X_93, X_A3 => X_A3, X_B3 => X_B3, + X_84 => X_84, X_94 => X_94, X_A4 => X_A4, X_B4 => X_B4, + X_85 => X_85, X_95 => X_95, X_A5 => X_A5, X_B5 => X_B5, + X_86 => X_86, X_96 => X_96, X_A6 => X_A6, X_B6 => X_B6, + X_87 => X_87, X_97 => X_97, X_A7 => X_A7, X_B7 => X_B7, + X_88 => X_88, X_98 => X_98, X_A8 => X_A8, X_B8 => X_B8, + X_89 => X_89, X_99 => X_99, X_A9 => X_A9, X_B9 => X_B9, + X_8A => X_8A, X_9A => X_9A, X_AA => X_AA, X_BA => X_BA, + X_8B => X_8B, X_9B => X_9B, X_AB => X_AB, X_BB => X_BB, + X_8C => X_8C, X_9C => X_9C, X_AC => X_AC, X_BC => X_BC, + X_8D => X_8D, X_9D => X_9D, X_AD => X_AD, X_BD => X_BD, + X_8E => X_8E, X_9E => X_9E, X_AE => X_AE, X_BE => X_BE, + X_8F => X_8F, X_9F => X_9F, X_AF => X_AF, X_BF => X_BF, + + X_C0 => X_C0, X_D0 => X_D0, X_E0 => X_E0, X_F0 => X_F0, + X_C1 => X_C1, X_D1 => X_D1, X_E1 => X_E1, X_F1 => X_F1, + X_C2 => X_C2, X_D2 => X_D2, X_E2 => X_E2, X_F2 => X_F2, + X_C3 => X_C3, X_D3 => X_D3, X_E3 => X_E3, X_F3 => X_F3, + X_C4 => X_C4, X_D4 => X_D4, X_E4 => X_E4, X_F4 => X_F4, + X_C5 => X_C5, X_D5 => X_D5, X_E5 => X_E5, X_F5 => X_F5, + X_C6 => X_C6, X_D6 => X_D6, X_E6 => X_E6, X_F6 => X_F6, + X_C7 => X_C7, X_D7 => X_D7, X_E7 => X_E7, X_F7 => X_F7, + X_C8 => X_C8, X_D8 => X_D8, X_E8 => X_E8, X_F8 => X_F8, + X_C9 => X_C9, X_D9 => X_D9, X_E9 => X_E9, X_F9 => X_F9, + X_CA => X_CA, X_DA => X_DA, X_EA => X_EA, X_FA => X_FA, + X_CB => X_CB, X_DB => X_DB, X_EB => X_EB, X_FB => X_FB, + X_CC => X_CC, X_DC => X_DC, X_EC => X_EC, X_FC => X_FC, + X_CD => X_CD, X_DD => X_DD, X_ED => X_ED, X_FD => X_FD, + X_CE => X_CE, X_DE => X_DE, X_EE => X_EE, X_FE => X_FE, + X_CF => X_CF, X_DF => X_DF, X_EF => X_EF, X_FF => X_FF, + + '0' => '0', + '1' => '1', + '2' => '2', + '3' => '3', + '4' => '4', + '5' => '5', + '6' => '6', + '7' => '7', + '8' => '8', + '9' => '9', + + '_' => '_', + + others => ' '); + + --------------------------------------- + -- Definitions for No Upper Half Set -- + --------------------------------------- + + -- The no upper half set allows no upper half characters as letters, and + -- thus there are no upper/lower case equivalences in this half. This set + -- corresponds to the Ada 83 rules. + + Fold_No_Upper_Half : constant Translate_Table := Translate_Table'( + + 'a' => 'A', + 'b' => 'B', + 'c' => 'C', + 'd' => 'D', + 'e' => 'E', + 'f' => 'F', + 'g' => 'G', + 'h' => 'H', + 'i' => 'I', + 'j' => 'J', + 'k' => 'K', + 'l' => 'L', + 'm' => 'M', + 'n' => 'N', + 'o' => 'O', + 'p' => 'P', + 'q' => 'Q', + 'r' => 'R', + 's' => 'S', + 't' => 'T', + 'u' => 'U', + 'v' => 'V', + 'w' => 'W', + 'x' => 'X', + 'y' => 'Y', + 'z' => 'Z', + + 'A' => 'A', + 'B' => 'B', + 'C' => 'C', + 'D' => 'D', + 'E' => 'E', + 'F' => 'F', + 'G' => 'G', + 'H' => 'H', + 'I' => 'I', + 'J' => 'J', + 'K' => 'K', + 'L' => 'L', + 'M' => 'M', + 'N' => 'N', + 'O' => 'O', + 'P' => 'P', + 'Q' => 'Q', + 'R' => 'R', + 'S' => 'S', + 'T' => 'T', + 'U' => 'U', + 'V' => 'V', + 'W' => 'W', + 'X' => 'X', + 'Y' => 'Y', + 'Z' => 'Z', + + '0' => '0', + '1' => '1', + '2' => '2', + '3' => '3', + '4' => '4', + '5' => '5', + '6' => '6', + '7' => '7', + '8' => '8', + '9' => '9', + + '_' => '_', + + others => ' '); + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + -- Set Fold_Upper table from source code indication + + if Identifier_Character_Set = '1' + or else Identifier_Character_Set = 'w' + then + Fold_Upper := Fold_Latin_1; + + elsif Identifier_Character_Set = '2' then + Fold_Upper := Fold_Latin_2; + + elsif Identifier_Character_Set = '3' then + Fold_Upper := Fold_Latin_3; + + elsif Identifier_Character_Set = '4' then + Fold_Upper := Fold_Latin_4; + + elsif Identifier_Character_Set = '5' then + Fold_Upper := Fold_Latin_5; + + elsif Identifier_Character_Set = 'p' then + Fold_Upper := Fold_IBM_PC_437; + + elsif Identifier_Character_Set = '8' then + Fold_Upper := Fold_IBM_PC_850; + + elsif Identifier_Character_Set = '9' then + Fold_Upper := Fold_Latin_9; + + elsif Identifier_Character_Set = 'f' then + Fold_Upper := Fold_Full_Upper_Half; + + else -- Identifier_Character_Set = 'n' + Fold_Upper := Fold_No_Upper_Half; + end if; + + -- Use Fold_Upper table to compute Fold_Lower table + + Fold_Lower := Fold_Upper; + + for J in Character loop + if J /= Fold_Upper (J) then + Fold_Lower (Fold_Upper (J)) := J; + Fold_Lower (J) := J; + end if; + end loop; + + Fold_Lower (' ') := ' '; + + -- Build Identifier_Char table from used entries of Fold_Upper + + for J in Character loop + Identifier_Char (J) := (Fold_Upper (J) /= ' '); + end loop; + + -- Always add [ as an identifier character to deal with the brackets + -- notation for wide characters used in identifiers. Note that if + -- we are not allowing wide characters in identifiers, then any use + -- of this notation will be flagged as an error in Scan_Identifier. + + Identifier_Char ('[') := True; + + -- Add entry for ESC if wide characters in use with a wide character + -- encoding method active that uses the ESC code for encoding. + + if Identifier_Character_Set = 'w' + and then Wide_Character_Encoding_Method in WC_ESC_Encoding_Method + then + Identifier_Char (ASCII.ESC) := True; + end if; + end Initialize; + + -------------------------- + -- Is_Lower_Case_Letter -- + -------------------------- + + function Is_Lower_Case_Letter (C : Character) return Boolean is + begin + return C /= Fold_Upper (C); + end Is_Lower_Case_Letter; + + -------------------------- + -- Is_Upper_Case_Letter -- + -------------------------- + + function Is_Upper_Case_Letter (C : Character) return Boolean is + begin + return C /= Fold_Lower (C); + end Is_Upper_Case_Letter; + +end Csets; diff --git a/gcc/ada/csets.ads b/gcc/ada/csets.ads new file mode 100644 index 000000000..ebf167096 --- /dev/null +++ b/gcc/ada/csets.ads @@ -0,0 +1,97 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C S E 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. -- +-- -- +------------------------------------------------------------------------------ + +package Csets is + pragma Elaborate_Body; + + -- This package contains character tables for the various character + -- sets that are supported for source representation. Character and + -- string literals are not affected, only identifiers. For each set, + -- the table in this package gives the mapping of letters to their + -- upper case equivalent. Each table thus provides the information + -- for building the table used to fold lower case to upper case, and + -- also the table of flags showing which characters are allowed in + -- identifiers. + + type Translate_Table is array (Character) of Character; + -- Type used to describe translate tables + + type Char_Array_Flags is array (Character) of Boolean; + -- Type used for character attribute arrays. Note that we deliberately + -- do NOT pack this table, since we don't want the extra overhead of + -- accessing a packed bit string. + + ---------------------------------------------- + -- Character Tables For Current Compilation -- + ---------------------------------------------- + + procedure Initialize; + -- Routine to initialize following character tables, whose content depends + -- on the character code being used to represent the source program. In + -- particular, the use of the upper half of the 8-bit code set varies. + -- The character set in use is specified by the value stored in + -- Opt.Identifier_Character_Set, which has the following settings: + + -- '1' Latin-1 (ISO-8859-1) + -- '2' Latin-2 (ISO-8859-2) + -- '3' Latin-3 (ISO-8859-3) + -- '4' Latin-4 (ISO-8859-4) + -- '5' Latin-5 (ISO-8859-5, Cyrillic) + -- 'p' IBM PC (code page 437) + -- '8' IBM PC (code page 850) + -- '9' Latin-9 (ISO-9959-9) + -- 'f' Full upper set (all distinct) + -- 'n' No upper characters (Ada/83 rules) + -- 'w' Latin-1 plus wide characters also allowed + + function Is_Upper_Case_Letter (C : Character) return Boolean; + pragma Inline (Is_Upper_Case_Letter); + -- Determine if character is upper case letter + + function Is_Lower_Case_Letter (C : Character) return Boolean; + pragma Inline (Is_Lower_Case_Letter); + -- Determine if character is lower case letter + + Fold_Upper : Translate_Table; + -- Table to fold lower case identifier letters to upper case + + Fold_Lower : Translate_Table; + -- Table to fold upper case identifier letters to lower case + + Identifier_Char : Char_Array_Flags; + -- This table has True entries for all characters that can legally appear + -- in identifiers, including digits, the underline character, all letters + -- including upper and lower case and extended letters (as controlled by + -- the setting of Opt.Identifier_Character_Set, left bracket for brackets + -- notation wide characters and also ESC if wide characters are permitted + -- in identifiers using escape sequences starting with ESC. + +end Csets; diff --git a/gcc/ada/csinfo.adb b/gcc/ada/csinfo.adb new file mode 100644 index 000000000..ef319cff9 --- /dev/null +++ b/gcc/ada/csinfo.adb @@ -0,0 +1,641 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT SYSTEM UTILITIES -- +-- -- +-- C S I N F O -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Check consistency of sinfo.ads and sinfo.adb. Checks that field name usage +-- is consistent and that assertion cross-reference lists are correct, as well +-- as making sure that all the comments on field name usage are consistent. + +-- Note that this is used both as a standalone program, and as a procedure +-- called by XSinfo. This raises an unhandled exception if it finds any +-- errors; we don't attempt any sophisticated error recovery. + +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; +with Ada.Strings.Maps; use Ada.Strings.Maps; +with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.Spitbol; use GNAT.Spitbol; +with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; +with GNAT.Spitbol.Table_Boolean; +with GNAT.Spitbol.Table_VString; + +procedure CSinfo is + + package TB renames GNAT.Spitbol.Table_Boolean; + package TV renames GNAT.Spitbol.Table_VString; + use TB, TV; + + Infil : File_Type; + Lineno : Natural := 0; + + Err : exception; + -- Raised on fatal error + + Done : exception; + -- Raised after error is found to terminate run + + WSP : constant Pattern := Span (' ' & ASCII.HT); + + Fields : TV.Table (300); + Fields1 : TV.Table (300); + Refs : TV.Table (300); + Refscopy : TV.Table (300); + Special : TB.Table (50); + Inlines : TV.Table (100); + + -- The following define the standard fields used for binary operator, + -- unary operator, and other expression nodes. Numbers in the range 1-5 + -- refer to the Fieldn fields. Letters D-R refer to flags: + + -- D = Flag4 + -- E = Flag5 + -- F = Flag6 + -- G = Flag7 + -- H = Flag8 + -- I = Flag9 + -- J = Flag10 + -- K = Flag11 + -- L = Flag12 + -- M = Flag13 + -- N = Flag14 + -- O = Flag15 + -- P = Flag16 + -- Q = Flag17 + -- R = Flag18 + + Flags : TV.Table (20); + -- Maps flag numbers to letters + + N_Fields : constant Pattern := BreakX ("JL"); + E_Fields : constant Pattern := BreakX ("5EFGHIJLOP"); + U_Fields : constant Pattern := BreakX ("1345EFGHIJKLOPQ"); + B_Fields : constant Pattern := BreakX ("12345EFGHIJKLOPQ"); + + Line : VString; + Bad : Boolean; + + Field : constant VString := Nul; + Fields_Used : VString := Nul; + Name : constant VString := Nul; + Next : constant VString := Nul; + Node : VString := Nul; + Ref : VString := Nul; + Synonym : constant VString := Nul; + Nxtref : constant VString := Nul; + + Which_Field : aliased VString := Nul; + + Node_Search : constant Pattern := WSP & "-- N_" & Rest * Node; + Break_Punc : constant Pattern := Break (" .,"); + Plus_Binary : constant Pattern := WSP + & "-- plus fields for binary operator"; + Plus_Unary : constant Pattern := WSP + & "-- plus fields for unary operator"; + Plus_Expr : constant Pattern := WSP + & "-- plus fields for expression"; + Break_Syn : constant Pattern := WSP & "-- " + & Break (' ') * Synonym + & " (" & Break (')') * Field; + Break_Field : constant Pattern := BreakX ('-') * Field; + Get_Field : constant Pattern := BreakX (Decimal_Digit_Set) + & Span (Decimal_Digit_Set) * Which_Field; + Break_WFld : constant Pattern := Break (Which_Field'Access); + Get_Funcsyn : constant Pattern := WSP & "function " & Rest * Synonym; + Extr_Field : constant Pattern := BreakX ('-') & "-- " & Rest * Field; + Get_Procsyn : constant Pattern := WSP & "procedure Set_" & Rest * Synonym; + Get_Inline : constant Pattern := WSP & "pragma Inline (" + & Break (')') * Name; + Set_Name : constant Pattern := "Set_" & Rest * Name; + Func_Rest : constant Pattern := " function " & Rest * Synonym; + Get_Nxtref : constant Pattern := Break (',') * Nxtref & ','; + Test_Syn : constant Pattern := Break ('=') & "= N_" + & (Break (" ,)") or Rest) * Next; + Chop_Comma : constant Pattern := BreakX (',') * Next; + Return_Fld : constant Pattern := WSP & "return " & Break (' ') * Field; + Set_Syn : constant Pattern := " procedure Set_" & Rest * Synonym; + Set_Fld : constant Pattern := WSP & "Set_" & Break (' ') * Field + & " (N, Val)"; + Break_With : constant Pattern := Break ('_') ** Field & "_With_Parent"; + + type VStringA is array (Natural range <>) of VString; + + procedure Next_Line; + -- Read next line trimmed from Infil into Line and bump Lineno + + procedure Sort (A : in out VStringA); + -- Sort a (small) array of VString's + + procedure Next_Line is + begin + Line := Get_Line (Infil); + Trim (Line); + Lineno := Lineno + 1; + end Next_Line; + + procedure Sort (A : in out VStringA) is + Temp : VString; + begin + <> + for J in 1 .. A'Length - 1 loop + if A (J) > A (J + 1) then + Temp := A (J); + A (J) := A (J + 1); + A (J + 1) := Temp; + goto Sort; + end if; + end loop; + end Sort; + +-- Start of processing for CSinfo + +begin + Anchored_Mode := True; + New_Line; + Open (Infil, In_File, "sinfo.ads"); + Put_Line ("Check for field name consistency"); + + -- Setup table for mapping flag numbers to letters + + Set (Flags, "4", V ("D")); + Set (Flags, "5", V ("E")); + Set (Flags, "6", V ("F")); + Set (Flags, "7", V ("G")); + Set (Flags, "8", V ("H")); + Set (Flags, "9", V ("I")); + Set (Flags, "10", V ("J")); + Set (Flags, "11", V ("K")); + Set (Flags, "12", V ("L")); + Set (Flags, "13", V ("M")); + Set (Flags, "14", V ("N")); + Set (Flags, "15", V ("O")); + Set (Flags, "16", V ("P")); + Set (Flags, "17", V ("Q")); + Set (Flags, "18", V ("R")); + + -- Special fields table. The following names are not recorded or checked + -- by Csinfo, since they are specially handled. This means that any field + -- definition or subprogram with a matching name is ignored. + + Set (Special, "Analyzed", True); + Set (Special, "Assignment_OK", True); + Set (Special, "Associated_Node", True); + Set (Special, "Cannot_Be_Constant", True); + Set (Special, "Chars", True); + Set (Special, "Comes_From_Source", True); + Set (Special, "Do_Overflow_Check", True); + Set (Special, "Do_Range_Check", True); + Set (Special, "Entity", True); + Set (Special, "Entity_Or_Associated_Node", True); + Set (Special, "Error_Posted", True); + Set (Special, "Etype", True); + Set (Special, "Evaluate_Once", True); + Set (Special, "First_Itype", True); + Set (Special, "Has_Aspect_Specifications", True); + Set (Special, "Has_Dynamic_Itype", True); + Set (Special, "Has_Dynamic_Range_Check", True); + Set (Special, "Has_Dynamic_Length_Check", True); + Set (Special, "Has_Private_View", True); + Set (Special, "Is_Controlling_Actual", True); + Set (Special, "Is_Overloaded", True); + Set (Special, "Is_Static_Expression", True); + Set (Special, "Left_Opnd", True); + Set (Special, "Must_Not_Freeze", True); + Set (Special, "Nkind_In", True); + Set (Special, "Parens", True); + Set (Special, "Pragma_Name", True); + Set (Special, "Raises_Constraint_Error", True); + Set (Special, "Right_Opnd", True); + + -- Loop to acquire information from node definitions in sinfo.ads, + -- checking for consistency in Op/Flag assignments to each synonym + + loop + Bad := False; + Next_Line; + exit when Match (Line, " -- Node Access Functions"); + + if Match (Line, Node_Search) + and then not Match (Node, Break_Punc) + then + Fields_Used := Nul; + + elsif Node = "" then + null; + + elsif Line = "" then + Node := Nul; + + elsif Match (Line, Plus_Binary) then + Bad := Match (Fields_Used, B_Fields); + + elsif Match (Line, Plus_Unary) then + Bad := Match (Fields_Used, U_Fields); + + elsif Match (Line, Plus_Expr) then + Bad := Match (Fields_Used, E_Fields); + + elsif not Match (Line, Break_Syn) then + null; + + elsif Match (Synonym, "plus") then + null; + + else + Match (Field, Break_Field); + + if not Present (Special, Synonym) then + if Present (Fields, Synonym) then + if Field /= Get (Fields, Synonym) then + Put_Line + ("Inconsistent field reference at line" & + Lineno'Img & " for " & Synonym); + raise Done; + end if; + + else + Set (Fields, Synonym, Field); + end if; + + Set (Refs, Synonym, Node & ',' & Get (Refs, Synonym)); + Match (Field, Get_Field); + + if Match (Field, "Flag") then + Which_Field := Get (Flags, Which_Field); + end if; + + if Match (Fields_Used, Break_WFld) then + Put_Line + ("Overlapping field at line " & Lineno'Img & + " for " & Synonym); + raise Done; + end if; + + Append (Fields_Used, Which_Field); + Bad := Bad or Match (Fields_Used, N_Fields); + end if; + end if; + + if Bad then + Put_Line ("fields conflict with standard fields for node " & Node); + raise Done; + end if; + end loop; + + Put_Line (" OK"); + New_Line; + Put_Line ("Check for function consistency"); + + -- Loop through field function definitions to make sure they are OK + + Fields1 := Fields; + loop + Next_Line; + exit when Match (Line, " -- Node Update"); + + if Match (Line, Get_Funcsyn) + and then not Present (Special, Synonym) + then + if not Present (Fields1, Synonym) then + Put_Line + ("function on line " & Lineno & + " is for unused synonym"); + raise Done; + end if; + + Next_Line; + + if not Match (Line, Extr_Field) then + raise Err; + end if; + + if Field /= Get (Fields1, Synonym) then + Put_Line ("Wrong field in function " & Synonym); + raise Done; + + else + Delete (Fields1, Synonym); + end if; + end if; + end loop; + + Put_Line (" OK"); + New_Line; + Put_Line ("Check for missing functions"); + + declare + List : constant TV.Table_Array := Convert_To_Array (Fields1); + + begin + if List'Length > 0 then + Put_Line ("No function for field synonym " & List (1).Name); + raise Done; + end if; + end; + + -- Check field set procedures + + Put_Line (" OK"); + New_Line; + Put_Line ("Check for set procedure consistency"); + + Fields1 := Fields; + loop + Next_Line; + exit when Match (Line, " -- Inline Pragmas"); + exit when Match (Line, " -- Iterator Procedures"); + + if Match (Line, Get_Procsyn) + and then not Present (Special, Synonym) + then + if not Present (Fields1, Synonym) then + Put_Line + ("procedure on line " & Lineno & " is for unused synonym"); + raise Done; + end if; + + Next_Line; + + if not Match (Line, Extr_Field) then + raise Err; + end if; + + if Field /= Get (Fields1, Synonym) then + Put_Line ("Wrong field in procedure Set_" & Synonym); + raise Done; + + else + Delete (Fields1, Synonym); + end if; + end if; + end loop; + + Put_Line (" OK"); + New_Line; + Put_Line ("Check for missing set procedures"); + + declare + List : constant TV.Table_Array := Convert_To_Array (Fields1); + + begin + if List'Length > 0 then + Put_Line ("No procedure for field synonym Set_" & List (1).Name); + raise Done; + end if; + end; + + Put_Line (" OK"); + New_Line; + Put_Line ("Check pragma Inlines are all for existing subprograms"); + + Clear (Fields1); + while not End_Of_File (Infil) loop + Next_Line; + + if Match (Line, Get_Inline) + and then not Present (Special, Name) + then + exit when Match (Name, Set_Name); + + if not Present (Fields, Name) then + Put_Line + ("Pragma Inline on line " & Lineno & + " does not correspond to synonym"); + raise Done; + + else + Set (Inlines, Name, Get (Inlines, Name) & 'r'); + end if; + end if; + end loop; + + Put_Line (" OK"); + New_Line; + Put_Line ("Check no pragma Inlines were omitted"); + + declare + List : constant TV.Table_Array := Convert_To_Array (Fields); + Nxt : VString := Nul; + + begin + for M in List'Range loop + Nxt := List (M).Name; + + if Get (Inlines, Nxt) /= "r" then + Put_Line ("Incorrect pragma Inlines for " & Nxt); + raise Done; + end if; + end loop; + end; + + Put_Line (" OK"); + New_Line; + Clear (Inlines); + + Close (Infil); + Open (Infil, In_File, "sinfo.adb"); + Lineno := 0; + Put_Line ("Check references in functions in body"); + + Refscopy := Refs; + loop + Next_Line; + exit when Match (Line, " -- Field Access Functions --"); + end loop; + + loop + Next_Line; + exit when Match (Line, " -- Field Set Procedures --"); + + if Match (Line, Func_Rest) + and then not Present (Special, Synonym) + then + Ref := Get (Refs, Synonym); + Delete (Refs, Synonym); + + if Ref = "" then + Put_Line + ("Function on line " & Lineno & " is for unknown synonym"); + raise Err; + end if; + + -- Alpha sort of references for this entry + + declare + Refa : VStringA (1 .. 100); + N : Natural := 0; + + begin + loop + exit when not Match (Ref, Get_Nxtref, Nul); + N := N + 1; + Refa (N) := Nxtref; + end loop; + + Sort (Refa (1 .. N)); + Next_Line; + Next_Line; + Next_Line; + + -- Checking references for one entry + + for M in 1 .. N loop + Next_Line; + + if not Match (Line, Test_Syn) then + Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno); + raise Done; + end if; + + Match (Next, Chop_Comma); + + if Next /= Refa (M) then + Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno); + raise Done; + end if; + end loop; + + Next_Line; + Match (Line, Return_Fld); + + if Field /= Get (Fields, Synonym) then + Put_Line + ("Wrong field for function " & Synonym & " at line " & + Lineno & " should be " & Get (Fields, Synonym)); + raise Done; + end if; + end; + end if; + end loop; + + Put_Line (" OK"); + New_Line; + Put_Line ("Check for missing functions in body"); + + declare + List : constant TV.Table_Array := Convert_To_Array (Refs); + + begin + if List'Length /= 0 then + Put_Line ("Missing function " & List (1).Name & " in body"); + raise Done; + end if; + end; + + Put_Line (" OK"); + New_Line; + Put_Line ("Check Set procedures in body"); + Refs := Refscopy; + + loop + Next_Line; + exit when Match (Line, "end"); + exit when Match (Line, " -- Iterator Procedures"); + + if Match (Line, Set_Syn) + and then not Present (Special, Synonym) + then + Ref := Get (Refs, Synonym); + Delete (Refs, Synonym); + + if Ref = "" then + Put_Line + ("Function on line " & Lineno & " is for unknown synonym"); + raise Err; + end if; + + -- Alpha sort of references for this entry + + declare + Refa : VStringA (1 .. 100); + N : Natural; + + begin + N := 0; + + loop + exit when not Match (Ref, Get_Nxtref, Nul); + N := N + 1; + Refa (N) := Nxtref; + end loop; + + Sort (Refa (1 .. N)); + + Next_Line; + Next_Line; + Next_Line; + + -- Checking references for one entry + + for M in 1 .. N loop + Next_Line; + + if not Match (Line, Test_Syn) + or else Next /= Refa (M) + then + Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno); + raise Err; + end if; + end loop; + + loop + Next_Line; + exit when Match (Line, Set_Fld); + end loop; + + Match (Field, Break_With); + + if Field /= Get (Fields, Synonym) then + Put_Line + ("Wrong field for procedure Set_" & Synonym & + " at line " & Lineno & " should be " & + Get (Fields, Synonym)); + raise Done; + end if; + + Delete (Fields1, Synonym); + end; + end if; + end loop; + + Put_Line (" OK"); + New_Line; + Put_Line ("Check for missing set procedures in body"); + + declare + List : constant TV.Table_Array := Convert_To_Array (Fields1); + + begin + if List'Length /= 0 then + Put_Line ("Missing procedure Set_" & List (1).Name & " in body"); + raise Done; + end if; + end; + + Put_Line (" OK"); + New_Line; + Put_Line ("All tests completed successfully, no errors detected"); + +end CSinfo; diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb new file mode 100644 index 000000000..ea1ecb661 --- /dev/null +++ b/gcc/ada/cstand.adb @@ -0,0 +1,1937 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C S T A N D -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Csets; use Csets; +with Debug; use Debug; +with Einfo; use Einfo; +with Layout; use Layout; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Output; use Output; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Scn; +with Sem_Mech; use Sem_Mech; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package body CStand is + + Stloc : constant Source_Ptr := Standard_Location; + Staloc : constant Source_Ptr := Standard_ASCII_Location; + -- Standard abbreviations used throughout this package + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Build_Float_Type (E : Entity_Id; Siz : Int; Digs : Int); + -- Procedure to build standard predefined float base type. The first + -- parameter is the entity for the type, and the second parameter + -- is the size in bits. The third parameter is the digits value. + + procedure Build_Signed_Integer_Type (E : Entity_Id; Siz : Int); + -- Procedure to build standard predefined signed integer subtype. The + -- first parameter is the entity for the subtype. The second parameter + -- is the size in bits. The corresponding base type is not built by + -- this routine but instead must be built by the caller where needed. + + procedure Create_Operators; + -- Make entries for each of the predefined operators in Standard + + procedure Create_Unconstrained_Base_Type + (E : Entity_Id; + K : Entity_Kind); + -- The predefined signed integer types are constrained subtypes which + -- must have a corresponding unconstrained base type. This type is almost + -- useless. The only place it has semantics is Subtypes_Statically_Match. + -- Consequently, we arrange for it to be identical apart from the setting + -- of the constrained bit. This routine takes an entity E for the Type, + -- copies it to estabish the base type, then resets the Ekind of the + -- original entity to K (the Ekind for the subtype). The Etype field of + -- E is set by the call (to point to the created base type entity), and + -- also the Is_Constrained flag of E is set. + -- + -- To understand the exact requirement for this, see RM 3.5.4(11) which + -- makes it clear that Integer, for example, is constrained, with the + -- constraint bounds matching the bounds of the (unconstrained) base + -- type. The point is that Integer and Integer'Base have identical + -- bounds, but do not statically match, since a subtype with constraints + -- never matches a subtype with no constraints. + + function Identifier_For (S : Standard_Entity_Type) return Node_Id; + -- Returns an identifier node with the same name as the defining + -- identifier corresponding to the given Standard_Entity_Type value + + procedure Make_Component + (Rec : Entity_Id; + Typ : Entity_Id; + Nam : String); + -- Build a record component with the given type and name, and append to + -- the list of components of Rec. + + function Make_Formal + (Typ : Entity_Id; + Formal_Name : String) return Entity_Id; + -- Construct entity for subprogram formal with given name and type + + function Make_Integer (V : Uint) return Node_Id; + -- Builds integer literal with given value + + procedure Make_Name (Id : Entity_Id; Nam : String); + -- Make an entry in the names table for Nam, and set as Chars field of Id + + function New_Operator (Op : Name_Id; Typ : Entity_Id) return Entity_Id; + -- Build entity for standard operator with given name and type + + function New_Standard_Entity + (New_Node_Kind : Node_Kind := N_Defining_Identifier) return Entity_Id; + -- Builds a new entity for Standard + + procedure Print_Standard; + -- Print representation of package Standard if switch set + + procedure Set_Integer_Bounds + (Id : Entity_Id; + Typ : Entity_Id; + Lb : Uint; + Hb : Uint); + -- Procedure to set bounds for integer type or subtype. Id is the entity + -- whose bounds and type are to be set. The Typ parameter is the Etype + -- value for the entity (which will be the same as Id for all predefined + -- integer base types. The third and fourth parameters are the bounds. + + ---------------------- + -- Build_Float_Type -- + ---------------------- + + procedure Build_Float_Type (E : Entity_Id; Siz : Int; Digs : Int) is + begin + Set_Type_Definition (Parent (E), + Make_Floating_Point_Definition (Stloc, + Digits_Expression => Make_Integer (UI_From_Int (Digs)))); + + Set_Ekind (E, E_Floating_Point_Type); + Set_Etype (E, E); + + if AAMP_On_Target then + Set_Float_Rep (E, AAMP); + else + Set_Float_Rep (E, IEEE_Binary); + end if; + + Init_Size (E, Siz); + Set_Elem_Alignment (E); + Init_Digits_Value (E, Digs); + Set_Float_Bounds (E); + Set_Is_Frozen (E); + Set_Is_Public (E); + Set_Size_Known_At_Compile_Time (E); + end Build_Float_Type; + + ------------------------------- + -- Build_Signed_Integer_Type -- + ------------------------------- + + procedure Build_Signed_Integer_Type (E : Entity_Id; Siz : Int) is + U2Siz1 : constant Uint := 2 ** (Siz - 1); + Lbound : constant Uint := -U2Siz1; + Ubound : constant Uint := U2Siz1 - 1; + + begin + Set_Type_Definition (Parent (E), + Make_Signed_Integer_Type_Definition (Stloc, + Low_Bound => Make_Integer (Lbound), + High_Bound => Make_Integer (Ubound))); + + Set_Ekind (E, E_Signed_Integer_Type); + Set_Etype (E, E); + Init_Size (E, Siz); + Set_Elem_Alignment (E); + Set_Integer_Bounds (E, E, Lbound, Ubound); + Set_Is_Frozen (E); + Set_Is_Public (E); + Set_Is_Known_Valid (E); + Set_Size_Known_At_Compile_Time (E); + end Build_Signed_Integer_Type; + + ---------------------- + -- Create_Operators -- + ---------------------- + + -- Each operator has an abbreviated signature. The formals have the names + -- LEFT and RIGHT. Their types are not actually used for resolution. + + procedure Create_Operators is + Op_Node : Entity_Id; + + -- The following tables define the binary and unary operators and their + -- corresponding result type. + + Binary_Ops : constant array (S_Binary_Ops) of Name_Id := + + -- There is one entry here for each binary operator, except for the + -- case of concatenation, where there are three entries, one for a + -- String result, one for Wide_String, and one for Wide_Wide_String. + + (Name_Op_Add, + Name_Op_And, + Name_Op_Concat, + Name_Op_Concat, + Name_Op_Concat, + Name_Op_Divide, + Name_Op_Eq, + Name_Op_Expon, + Name_Op_Ge, + Name_Op_Gt, + Name_Op_Le, + Name_Op_Lt, + Name_Op_Mod, + Name_Op_Multiply, + Name_Op_Ne, + Name_Op_Or, + Name_Op_Rem, + Name_Op_Subtract, + Name_Op_Xor); + + Bin_Op_Types : constant array (S_Binary_Ops) of Entity_Id := + + -- This table has the corresponding result types. The entries are + -- ordered so they correspond to the Binary_Ops array above. + + (Universal_Integer, -- Add + Standard_Boolean, -- And + Standard_String, -- Concat (String) + Standard_Wide_String, -- Concat (Wide_String) + Standard_Wide_Wide_String, -- Concat (Wide_Wide_String) + Universal_Integer, -- Divide + Standard_Boolean, -- Eq + Universal_Integer, -- Expon + Standard_Boolean, -- Ge + Standard_Boolean, -- Gt + Standard_Boolean, -- Le + Standard_Boolean, -- Lt + Universal_Integer, -- Mod + Universal_Integer, -- Multiply + Standard_Boolean, -- Ne + Standard_Boolean, -- Or + Universal_Integer, -- Rem + Universal_Integer, -- Subtract + Standard_Boolean); -- Xor + + Unary_Ops : constant array (S_Unary_Ops) of Name_Id := + + -- There is one entry here for each unary operator + + (Name_Op_Abs, + Name_Op_Subtract, + Name_Op_Not, + Name_Op_Add); + + Unary_Op_Types : constant array (S_Unary_Ops) of Entity_Id := + + -- This table has the corresponding result types. The entries are + -- ordered so they correspond to the Unary_Ops array above. + + (Universal_Integer, -- Abs + Universal_Integer, -- Subtract + Standard_Boolean, -- Not + Universal_Integer); -- Add + + begin + for J in S_Binary_Ops loop + Op_Node := New_Operator (Binary_Ops (J), Bin_Op_Types (J)); + SE (J) := Op_Node; + Append_Entity (Make_Formal (Any_Type, "LEFT"), Op_Node); + Append_Entity (Make_Formal (Any_Type, "RIGHT"), Op_Node); + end loop; + + for J in S_Unary_Ops loop + Op_Node := New_Operator (Unary_Ops (J), Unary_Op_Types (J)); + SE (J) := Op_Node; + Append_Entity (Make_Formal (Any_Type, "RIGHT"), Op_Node); + end loop; + + -- For concatenation, we create a separate operator for each + -- array type. This simplifies the resolution of the component- + -- component concatenation operation. In Standard, we set the types + -- of the formals for string, wide [wide]_string, concatenations. + + Set_Etype (First_Entity (Standard_Op_Concat), Standard_String); + Set_Etype (Last_Entity (Standard_Op_Concat), Standard_String); + + Set_Etype (First_Entity (Standard_Op_Concatw), Standard_Wide_String); + Set_Etype (Last_Entity (Standard_Op_Concatw), Standard_Wide_String); + + Set_Etype (First_Entity (Standard_Op_Concatww), + Standard_Wide_Wide_String); + + Set_Etype (Last_Entity (Standard_Op_Concatww), + Standard_Wide_Wide_String); + end Create_Operators; + + --------------------- + -- Create_Standard -- + --------------------- + + -- The tree for the package Standard is prefixed to all compilations. + -- Several entities required by semantic analysis are denoted by global + -- variables that are initialized to point to the corresponding + -- occurrences in STANDARD. The visible entities of STANDARD are + -- created here. The private entities defined in STANDARD are created + -- by Initialize_Standard in the semantics module. + + procedure Create_Standard is + Decl_S : constant List_Id := New_List; + -- List of declarations in Standard + + Decl_A : constant List_Id := New_List; + -- List of declarations in ASCII + + Decl : Node_Id; + Pspec : Node_Id; + Tdef_Node : Node_Id; + Ident_Node : Node_Id; + Ccode : Char_Code; + E_Id : Entity_Id; + R_Node : Node_Id; + B_Node : Node_Id; + + procedure Build_Exception (S : Standard_Entity_Type); + -- Procedure to declare given entity as an exception + + procedure Pack_String_Type (String_Type : Entity_Id); + -- Generate proper tree for pragma Pack that applies to given type, and + -- mark type as having the pragma. + + --------------------- + -- Build_Exception -- + --------------------- + + procedure Build_Exception (S : Standard_Entity_Type) is + begin + Set_Ekind (Standard_Entity (S), E_Exception); + Set_Etype (Standard_Entity (S), Standard_Exception_Type); + Set_Exception_Code (Standard_Entity (S), Uint_0); + Set_Is_Public (Standard_Entity (S), True); + + Decl := + Make_Exception_Declaration (Stloc, + Defining_Identifier => Standard_Entity (S)); + Append (Decl, Decl_S); + end Build_Exception; + + ---------------------- + -- Pack_String_Type -- + ---------------------- + + procedure Pack_String_Type (String_Type : Entity_Id) is + Prag : constant Node_Id := + Make_Pragma (Stloc, + Chars => Name_Pack, + Pragma_Argument_Associations => + New_List ( + Make_Pragma_Argument_Association (Stloc, + Expression => + New_Occurrence_Of (String_Type, Stloc)))); + begin + Append (Prag, Decl_S); + Record_Rep_Item (String_Type, Prag); + Set_Has_Pragma_Pack (String_Type, True); + end Pack_String_Type; + + -- Start of processing for Create_Standard + + begin + -- Initialize scanner for internal scans of literals + + Scn.Initialize_Scanner (No_Unit, Internal_Source_File); + + -- First step is to create defining identifiers for each entity + + for S in Standard_Entity_Type loop + declare + S_Name : constant String := Standard_Entity_Type'Image (S); + -- Name of entity (note we skip S_ at the start) + + Ident_Node : Node_Id; + -- Defining identifier node + + begin + Ident_Node := New_Standard_Entity; + Make_Name (Ident_Node, S_Name (3 .. S_Name'Length)); + Standard_Entity (S) := Ident_Node; + end; + end loop; + + -- Create package declaration node for package Standard + + Standard_Package_Node := New_Node (N_Package_Declaration, Stloc); + + Pspec := New_Node (N_Package_Specification, Stloc); + Set_Specification (Standard_Package_Node, Pspec); + + Set_Defining_Unit_Name (Pspec, Standard_Standard); + Set_Visible_Declarations (Pspec, Decl_S); + + Set_Ekind (Standard_Standard, E_Package); + Set_Is_Pure (Standard_Standard); + Set_Is_Compilation_Unit (Standard_Standard); + + -- Create type/subtype declaration nodes for standard types + + for S in S_Types loop + + -- Subtype declaration case + + if S = S_Natural or else S = S_Positive then + Decl := New_Node (N_Subtype_Declaration, Stloc); + Set_Subtype_Indication (Decl, + New_Occurrence_Of (Standard_Integer, Stloc)); + + -- Full type declaration case + + else + Decl := New_Node (N_Full_Type_Declaration, Stloc); + end if; + + Set_Is_Frozen (Standard_Entity (S)); + Set_Is_Public (Standard_Entity (S)); + Set_Defining_Identifier (Decl, Standard_Entity (S)); + Append (Decl, Decl_S); + end loop; + + -- Create type definition node for type Boolean. The Size is set to + -- 1 as required by Ada 95 and current ARG interpretations for Ada/83. + + -- Note: Object_Size of Boolean is 8. This means that we do NOT in + -- general know that Boolean variables have valid values, so we do + -- not set the Is_Known_Valid flag. + + Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc); + Set_Literals (Tdef_Node, New_List); + Append (Standard_False, Literals (Tdef_Node)); + Append (Standard_True, Literals (Tdef_Node)); + Set_Type_Definition (Parent (Standard_Boolean), Tdef_Node); + + Set_Ekind (Standard_Boolean, E_Enumeration_Type); + Set_First_Literal (Standard_Boolean, Standard_False); + Set_Etype (Standard_Boolean, Standard_Boolean); + Init_Esize (Standard_Boolean, Standard_Character_Size); + Init_RM_Size (Standard_Boolean, 1); + Set_Elem_Alignment (Standard_Boolean); + + Set_Is_Unsigned_Type (Standard_Boolean); + Set_Size_Known_At_Compile_Time (Standard_Boolean); + Set_Has_Pragma_Ordered (Standard_Boolean); + + Set_Ekind (Standard_True, E_Enumeration_Literal); + Set_Etype (Standard_True, Standard_Boolean); + Set_Enumeration_Pos (Standard_True, Uint_1); + Set_Enumeration_Rep (Standard_True, Uint_1); + Set_Is_Known_Valid (Standard_True, True); + + Set_Ekind (Standard_False, E_Enumeration_Literal); + Set_Etype (Standard_False, Standard_Boolean); + Set_Enumeration_Pos (Standard_False, Uint_0); + Set_Enumeration_Rep (Standard_False, Uint_0); + Set_Is_Known_Valid (Standard_False, True); + + -- For the bounds of Boolean, we create a range node corresponding to + + -- range False .. True + + -- where the occurrences of the literals must point to the + -- corresponding definition. + + R_Node := New_Node (N_Range, Stloc); + B_Node := New_Node (N_Identifier, Stloc); + Set_Chars (B_Node, Chars (Standard_False)); + Set_Entity (B_Node, Standard_False); + Set_Etype (B_Node, Standard_Boolean); + Set_Is_Static_Expression (B_Node); + Set_Low_Bound (R_Node, B_Node); + + B_Node := New_Node (N_Identifier, Stloc); + Set_Chars (B_Node, Chars (Standard_True)); + Set_Entity (B_Node, Standard_True); + Set_Etype (B_Node, Standard_Boolean); + Set_Is_Static_Expression (B_Node); + Set_High_Bound (R_Node, B_Node); + + Set_Scalar_Range (Standard_Boolean, R_Node); + Set_Etype (R_Node, Standard_Boolean); + Set_Parent (R_Node, Standard_Boolean); + + -- Record entity identifiers for boolean literals in the + -- Boolean_Literals array, for easy reference during expansion. + + Boolean_Literals := (False => Standard_False, True => Standard_True); + + -- Create type definition nodes for predefined integer types + + Build_Signed_Integer_Type + (Standard_Short_Short_Integer, Standard_Short_Short_Integer_Size); + + Build_Signed_Integer_Type + (Standard_Short_Integer, Standard_Short_Integer_Size); + + Build_Signed_Integer_Type + (Standard_Integer, Standard_Integer_Size); + + declare + LIS : Nat; + begin + if Debug_Flag_M then + LIS := 64; + else + LIS := Standard_Long_Integer_Size; + end if; + + Build_Signed_Integer_Type (Standard_Long_Integer, LIS); + end; + + Build_Signed_Integer_Type + (Standard_Long_Long_Integer, Standard_Long_Long_Integer_Size); + + Create_Unconstrained_Base_Type + (Standard_Short_Short_Integer, E_Signed_Integer_Subtype); + + Create_Unconstrained_Base_Type + (Standard_Short_Integer, E_Signed_Integer_Subtype); + + Create_Unconstrained_Base_Type + (Standard_Integer, E_Signed_Integer_Subtype); + + Create_Unconstrained_Base_Type + (Standard_Long_Integer, E_Signed_Integer_Subtype); + + Create_Unconstrained_Base_Type + (Standard_Long_Long_Integer, E_Signed_Integer_Subtype); + + -- Create type definition nodes for predefined float types + + Build_Float_Type + (Standard_Short_Float, + Standard_Short_Float_Size, + Standard_Short_Float_Digits); + + Build_Float_Type + (Standard_Float, + Standard_Float_Size, + Standard_Float_Digits); + + Build_Float_Type + (Standard_Long_Float, + Standard_Long_Float_Size, + Standard_Long_Float_Digits); + + Build_Float_Type + (Standard_Long_Long_Float, + Standard_Long_Long_Float_Size, + Standard_Long_Long_Float_Digits); + + -- Create type definition node for type Character. Note that we do not + -- set the Literals field, since type Character is handled with special + -- routine that do not need a literal list. + + Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc); + Set_Type_Definition (Parent (Standard_Character), Tdef_Node); + + Set_Ekind (Standard_Character, E_Enumeration_Type); + Set_Etype (Standard_Character, Standard_Character); + Init_Esize (Standard_Character, Standard_Character_Size); + Init_RM_Size (Standard_Character, 8); + Set_Elem_Alignment (Standard_Character); + + Set_Has_Pragma_Ordered (Standard_Character); + Set_Is_Unsigned_Type (Standard_Character); + Set_Is_Character_Type (Standard_Character); + Set_Is_Known_Valid (Standard_Character); + Set_Size_Known_At_Compile_Time (Standard_Character); + + -- Create the bounds for type Character + + R_Node := New_Node (N_Range, Stloc); + + -- Low bound for type Character (Standard.Nul) + + B_Node := New_Node (N_Character_Literal, Stloc); + Set_Is_Static_Expression (B_Node); + Set_Chars (B_Node, No_Name); + Set_Char_Literal_Value (B_Node, Uint_0); + Set_Entity (B_Node, Empty); + Set_Etype (B_Node, Standard_Character); + Set_Low_Bound (R_Node, B_Node); + + -- High bound for type Character + + B_Node := New_Node (N_Character_Literal, Stloc); + Set_Is_Static_Expression (B_Node); + Set_Chars (B_Node, No_Name); + Set_Char_Literal_Value (B_Node, UI_From_Int (16#FF#)); + Set_Entity (B_Node, Empty); + Set_Etype (B_Node, Standard_Character); + Set_High_Bound (R_Node, B_Node); + + Set_Scalar_Range (Standard_Character, R_Node); + Set_Etype (R_Node, Standard_Character); + Set_Parent (R_Node, Standard_Character); + + -- Create type definition for type Wide_Character. Note that we do not + -- set the Literals field, since type Wide_Character is handled with + -- special routines that do not need a literal list. + + Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc); + Set_Type_Definition (Parent (Standard_Wide_Character), Tdef_Node); + + Set_Ekind (Standard_Wide_Character, E_Enumeration_Type); + Set_Etype (Standard_Wide_Character, Standard_Wide_Character); + Init_Size (Standard_Wide_Character, Standard_Wide_Character_Size); + + Set_Elem_Alignment (Standard_Wide_Character); + Set_Has_Pragma_Ordered (Standard_Wide_Character); + Set_Is_Unsigned_Type (Standard_Wide_Character); + Set_Is_Character_Type (Standard_Wide_Character); + Set_Is_Known_Valid (Standard_Wide_Character); + Set_Size_Known_At_Compile_Time (Standard_Wide_Character); + + -- Create the bounds for type Wide_Character + + R_Node := New_Node (N_Range, Stloc); + + -- Low bound for type Wide_Character + + B_Node := New_Node (N_Character_Literal, Stloc); + Set_Is_Static_Expression (B_Node); + Set_Chars (B_Node, No_Name); -- ??? + Set_Char_Literal_Value (B_Node, Uint_0); + Set_Entity (B_Node, Empty); + Set_Etype (B_Node, Standard_Wide_Character); + Set_Low_Bound (R_Node, B_Node); + + -- High bound for type Wide_Character + + B_Node := New_Node (N_Character_Literal, Stloc); + Set_Is_Static_Expression (B_Node); + Set_Chars (B_Node, No_Name); -- ??? + Set_Char_Literal_Value (B_Node, UI_From_Int (16#FFFF#)); + Set_Entity (B_Node, Empty); + Set_Etype (B_Node, Standard_Wide_Character); + Set_High_Bound (R_Node, B_Node); + + Set_Scalar_Range (Standard_Wide_Character, R_Node); + Set_Etype (R_Node, Standard_Wide_Character); + Set_Parent (R_Node, Standard_Wide_Character); + + -- Create type definition for type Wide_Wide_Character. Note that we + -- do not set the Literals field, since type Wide_Wide_Character is + -- handled with special routines that do not need a literal list. + + Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc); + Set_Type_Definition (Parent (Standard_Wide_Wide_Character), Tdef_Node); + + Set_Ekind (Standard_Wide_Wide_Character, E_Enumeration_Type); + Set_Etype (Standard_Wide_Wide_Character, + Standard_Wide_Wide_Character); + Init_Size (Standard_Wide_Wide_Character, + Standard_Wide_Wide_Character_Size); + + Set_Elem_Alignment (Standard_Wide_Wide_Character); + Set_Has_Pragma_Ordered (Standard_Wide_Wide_Character); + Set_Is_Unsigned_Type (Standard_Wide_Wide_Character); + Set_Is_Character_Type (Standard_Wide_Wide_Character); + Set_Is_Known_Valid (Standard_Wide_Wide_Character); + Set_Size_Known_At_Compile_Time (Standard_Wide_Wide_Character); + Set_Is_Ada_2005_Only (Standard_Wide_Wide_Character); + + -- Create the bounds for type Wide_Wide_Character + + R_Node := New_Node (N_Range, Stloc); + + -- Low bound for type Wide_Wide_Character + + B_Node := New_Node (N_Character_Literal, Stloc); + Set_Is_Static_Expression (B_Node); + Set_Chars (B_Node, No_Name); -- ??? + Set_Char_Literal_Value (B_Node, Uint_0); + Set_Entity (B_Node, Empty); + Set_Etype (B_Node, Standard_Wide_Wide_Character); + Set_Low_Bound (R_Node, B_Node); + + -- High bound for type Wide_Wide_Character + + B_Node := New_Node (N_Character_Literal, Stloc); + Set_Is_Static_Expression (B_Node); + Set_Chars (B_Node, No_Name); -- ??? + Set_Char_Literal_Value (B_Node, UI_From_Int (16#7FFF_FFFF#)); + Set_Entity (B_Node, Empty); + Set_Etype (B_Node, Standard_Wide_Wide_Character); + Set_High_Bound (R_Node, B_Node); + + Set_Scalar_Range (Standard_Wide_Wide_Character, R_Node); + Set_Etype (R_Node, Standard_Wide_Wide_Character); + Set_Parent (R_Node, Standard_Wide_Wide_Character); + + -- Create type definition node for type String + + Tdef_Node := New_Node (N_Unconstrained_Array_Definition, Stloc); + + declare + CompDef_Node : Node_Id; + begin + CompDef_Node := New_Node (N_Component_Definition, Stloc); + Set_Aliased_Present (CompDef_Node, False); + Set_Access_Definition (CompDef_Node, Empty); + Set_Subtype_Indication (CompDef_Node, Identifier_For (S_Character)); + Set_Component_Definition (Tdef_Node, CompDef_Node); + end; + + Set_Subtype_Marks (Tdef_Node, New_List); + Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node)); + Set_Type_Definition (Parent (Standard_String), Tdef_Node); + + Set_Ekind (Standard_String, E_String_Type); + Set_Etype (Standard_String, Standard_String); + Set_Component_Type (Standard_String, Standard_Character); + Set_Component_Size (Standard_String, Uint_8); + Init_Size_Align (Standard_String); + Set_Alignment (Standard_String, Uint_1); + Pack_String_Type (Standard_String); + + -- On targets where a storage unit is larger than a byte (such as AAMP), + -- pragma Pack has a real effect on the representation of type String, + -- and the type must be marked as having a nonstandard representation. + + if System_Storage_Unit > Uint_8 then + Set_Has_Non_Standard_Rep (Standard_String); + Set_Has_Pragma_Pack (Standard_String); + end if; + + -- Set index type of String + + E_Id := First + (Subtype_Marks (Type_Definition (Parent (Standard_String)))); + Set_First_Index (Standard_String, E_Id); + Set_Entity (E_Id, Standard_Positive); + Set_Etype (E_Id, Standard_Positive); + + -- Create type definition node for type Wide_String + + Tdef_Node := New_Node (N_Unconstrained_Array_Definition, Stloc); + + declare + CompDef_Node : Node_Id; + begin + CompDef_Node := New_Node (N_Component_Definition, Stloc); + Set_Aliased_Present (CompDef_Node, False); + Set_Access_Definition (CompDef_Node, Empty); + Set_Subtype_Indication (CompDef_Node, + Identifier_For (S_Wide_Character)); + Set_Component_Definition (Tdef_Node, CompDef_Node); + end; + + Set_Subtype_Marks (Tdef_Node, New_List); + Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node)); + Set_Type_Definition (Parent (Standard_Wide_String), Tdef_Node); + + Set_Ekind (Standard_Wide_String, E_String_Type); + Set_Etype (Standard_Wide_String, Standard_Wide_String); + Set_Component_Type (Standard_Wide_String, Standard_Wide_Character); + Set_Component_Size (Standard_Wide_String, Uint_16); + Init_Size_Align (Standard_Wide_String); + Pack_String_Type (Standard_Wide_String); + + -- Set index type of Wide_String + + E_Id := First + (Subtype_Marks (Type_Definition (Parent (Standard_Wide_String)))); + Set_First_Index (Standard_Wide_String, E_Id); + Set_Entity (E_Id, Standard_Positive); + Set_Etype (E_Id, Standard_Positive); + + -- Create type definition node for type Wide_Wide_String + + Tdef_Node := New_Node (N_Unconstrained_Array_Definition, Stloc); + + declare + CompDef_Node : Node_Id; + begin + CompDef_Node := New_Node (N_Component_Definition, Stloc); + Set_Aliased_Present (CompDef_Node, False); + Set_Access_Definition (CompDef_Node, Empty); + Set_Subtype_Indication (CompDef_Node, + Identifier_For (S_Wide_Wide_Character)); + Set_Component_Definition (Tdef_Node, CompDef_Node); + end; + + Set_Subtype_Marks (Tdef_Node, New_List); + Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node)); + Set_Type_Definition (Parent (Standard_Wide_Wide_String), Tdef_Node); + + Set_Ekind (Standard_Wide_Wide_String, E_String_Type); + Set_Etype (Standard_Wide_Wide_String, + Standard_Wide_Wide_String); + Set_Component_Type (Standard_Wide_Wide_String, + Standard_Wide_Wide_Character); + Set_Component_Size (Standard_Wide_Wide_String, Uint_32); + Init_Size_Align (Standard_Wide_Wide_String); + Set_Is_Ada_2005_Only (Standard_Wide_Wide_String); + Pack_String_Type (Standard_Wide_Wide_String); + + -- Set index type of Wide_Wide_String + + E_Id := First + (Subtype_Marks (Type_Definition (Parent (Standard_Wide_Wide_String)))); + Set_First_Index (Standard_Wide_Wide_String, E_Id); + Set_Entity (E_Id, Standard_Positive); + Set_Etype (E_Id, Standard_Positive); + + -- Setup entity for Naturalend Create_Standard; + + Set_Ekind (Standard_Natural, E_Signed_Integer_Subtype); + Set_Etype (Standard_Natural, Base_Type (Standard_Integer)); + Init_Esize (Standard_Natural, Standard_Integer_Size); + Init_RM_Size (Standard_Natural, Standard_Integer_Size - 1); + Set_Elem_Alignment (Standard_Natural); + Set_Size_Known_At_Compile_Time + (Standard_Natural); + Set_Integer_Bounds (Standard_Natural, + Typ => Base_Type (Standard_Integer), + Lb => Uint_0, + Hb => Intval (High_Bound (Scalar_Range (Standard_Integer)))); + Set_Is_Constrained (Standard_Natural); + + -- Setup entity for Positive + + Set_Ekind (Standard_Positive, E_Signed_Integer_Subtype); + Set_Etype (Standard_Positive, Base_Type (Standard_Integer)); + Init_Esize (Standard_Positive, Standard_Integer_Size); + Init_RM_Size (Standard_Positive, Standard_Integer_Size - 1); + Set_Elem_Alignment (Standard_Positive); + + Set_Size_Known_At_Compile_Time (Standard_Positive); + + Set_Integer_Bounds (Standard_Positive, + Typ => Base_Type (Standard_Integer), + Lb => Uint_1, + Hb => Intval (High_Bound (Scalar_Range (Standard_Integer)))); + Set_Is_Constrained (Standard_Positive); + + -- Create declaration for package ASCII + + Decl := New_Node (N_Package_Declaration, Stloc); + Append (Decl, Decl_S); + + Pspec := New_Node (N_Package_Specification, Stloc); + Set_Specification (Decl, Pspec); + + Set_Defining_Unit_Name (Pspec, Standard_Entity (S_ASCII)); + Set_Ekind (Standard_Entity (S_ASCII), E_Package); + Set_Visible_Declarations (Pspec, Decl_A); + + -- Create control character definitions in package ASCII. Note that + -- the character literal entries created here correspond to literal + -- values that are impossible in the source, but can be represented + -- internally with no difficulties. + + Ccode := 16#00#; + + for S in S_ASCII_Names loop + Decl := New_Node (N_Object_Declaration, Staloc); + Set_Constant_Present (Decl, True); + + declare + A_Char : constant Entity_Id := Standard_Entity (S); + Expr_Decl : Node_Id; + + begin + Set_Sloc (A_Char, Staloc); + Set_Ekind (A_Char, E_Constant); + Set_Never_Set_In_Source (A_Char, True); + Set_Is_True_Constant (A_Char, True); + Set_Etype (A_Char, Standard_Character); + Set_Scope (A_Char, Standard_Entity (S_ASCII)); + Set_Is_Immediately_Visible (A_Char, False); + Set_Is_Public (A_Char, True); + Set_Is_Known_Valid (A_Char, True); + + Append_Entity (A_Char, Standard_Entity (S_ASCII)); + Set_Defining_Identifier (Decl, A_Char); + + Set_Object_Definition (Decl, Identifier_For (S_Character)); + Expr_Decl := New_Node (N_Character_Literal, Staloc); + Set_Expression (Decl, Expr_Decl); + + Set_Is_Static_Expression (Expr_Decl); + Set_Chars (Expr_Decl, No_Name); + Set_Etype (Expr_Decl, Standard_Character); + Set_Char_Literal_Value (Expr_Decl, UI_From_Int (Int (Ccode))); + end; + + Append (Decl, Decl_A); + + -- Increment character code, dealing with non-contiguities + + Ccode := Ccode + 1; + + if Ccode = 16#20# then + Ccode := 16#21#; + elsif Ccode = 16#27# then + Ccode := 16#3A#; + elsif Ccode = 16#3C# then + Ccode := 16#3F#; + elsif Ccode = 16#41# then + Ccode := 16#5B#; + end if; + end loop; + + -- Create semantic phase entities + + Standard_Void_Type := New_Standard_Entity; + Set_Ekind (Standard_Void_Type, E_Void); + Set_Etype (Standard_Void_Type, Standard_Void_Type); + Set_Scope (Standard_Void_Type, Standard_Standard); + Make_Name (Standard_Void_Type, "_void_type"); + + -- The type field of packages is set to void + + Set_Etype (Standard_Standard, Standard_Void_Type); + Set_Etype (Standard_ASCII, Standard_Void_Type); + + -- Standard_A_String is actually used in generated code, so it has a + -- type name that is reasonable, but does not overlap any Ada name. + + Standard_A_String := New_Standard_Entity; + Set_Ekind (Standard_A_String, E_Access_Type); + Set_Scope (Standard_A_String, Standard_Standard); + Set_Etype (Standard_A_String, Standard_A_String); + + if Debug_Flag_6 then + Init_Size (Standard_A_String, System_Address_Size); + else + Init_Size (Standard_A_String, System_Address_Size * 2); + end if; + + Init_Alignment (Standard_A_String); + + Set_Directly_Designated_Type + (Standard_A_String, Standard_String); + Make_Name (Standard_A_String, "access_string"); + + Standard_A_Char := New_Standard_Entity; + Set_Ekind (Standard_A_Char, E_Access_Type); + Set_Scope (Standard_A_Char, Standard_Standard); + Set_Etype (Standard_A_Char, Standard_A_String); + Init_Size (Standard_A_Char, System_Address_Size); + Set_Elem_Alignment (Standard_A_Char); + + Set_Directly_Designated_Type (Standard_A_Char, Standard_Character); + Make_Name (Standard_A_Char, "access_character"); + + -- Standard_Debug_Renaming_Type is used for the special objects created + -- to encode the names occurring in renaming declarations for use by the + -- debugger (see exp_dbug.adb). The type is a zero-sized subtype of + -- Standard.Integer. + + Standard_Debug_Renaming_Type := New_Standard_Entity; + + Set_Ekind (Standard_Debug_Renaming_Type, E_Signed_Integer_Subtype); + Set_Scope (Standard_Debug_Renaming_Type, Standard_Standard); + Set_Etype (Standard_Debug_Renaming_Type, Base_Type (Standard_Integer)); + Init_Esize (Standard_Debug_Renaming_Type, 0); + Init_RM_Size (Standard_Debug_Renaming_Type, 0); + Set_Size_Known_At_Compile_Time (Standard_Debug_Renaming_Type); + Set_Integer_Bounds (Standard_Debug_Renaming_Type, + Typ => Base_Type (Standard_Debug_Renaming_Type), + Lb => Uint_1, + Hb => Uint_0); + Set_Is_Constrained (Standard_Debug_Renaming_Type); + Set_Has_Size_Clause (Standard_Debug_Renaming_Type); + + Make_Name (Standard_Debug_Renaming_Type, "_renaming_type"); + + -- Note on type names. The type names for the following special types + -- are constructed so that they will look reasonable should they ever + -- appear in error messages etc, although in practice the use of the + -- special insertion character } for types results in special handling + -- of these type names in any case. The blanks in these names would + -- trouble in Gigi, but that's OK here, since none of these types + -- should ever get through to Gigi! Attributes of these types are + -- filled out to minimize problems with cascaded errors (for example, + -- Any_Integer is given reasonable and consistent type and size values) + + Any_Type := New_Standard_Entity; + Decl := New_Node (N_Full_Type_Declaration, Stloc); + Set_Defining_Identifier (Decl, Any_Type); + Set_Scope (Any_Type, Standard_Standard); + Build_Signed_Integer_Type (Any_Type, Standard_Integer_Size); + Make_Name (Any_Type, "any type"); + + Any_Id := New_Standard_Entity; + Set_Ekind (Any_Id, E_Variable); + Set_Scope (Any_Id, Standard_Standard); + Set_Etype (Any_Id, Any_Type); + Init_Esize (Any_Id); + Init_Alignment (Any_Id); + Make_Name (Any_Id, "any id"); + + Any_Access := New_Standard_Entity; + Set_Ekind (Any_Access, E_Access_Type); + Set_Scope (Any_Access, Standard_Standard); + Set_Etype (Any_Access, Any_Access); + Init_Size (Any_Access, System_Address_Size); + Set_Elem_Alignment (Any_Access); + Make_Name (Any_Access, "an access type"); + + Any_Character := New_Standard_Entity; + Set_Ekind (Any_Character, E_Enumeration_Type); + Set_Scope (Any_Character, Standard_Standard); + Set_Etype (Any_Character, Any_Character); + Set_Is_Unsigned_Type (Any_Character); + Set_Is_Character_Type (Any_Character); + Init_Esize (Any_Character, Standard_Character_Size); + Init_RM_Size (Any_Character, 8); + Set_Elem_Alignment (Any_Character); + Set_Scalar_Range (Any_Character, Scalar_Range (Standard_Character)); + Make_Name (Any_Character, "a character type"); + + Any_Array := New_Standard_Entity; + Set_Ekind (Any_Array, E_String_Type); + Set_Scope (Any_Array, Standard_Standard); + Set_Etype (Any_Array, Any_Array); + Set_Component_Type (Any_Array, Any_Character); + Init_Size_Align (Any_Array); + Make_Name (Any_Array, "an array type"); + + Any_Boolean := New_Standard_Entity; + Set_Ekind (Any_Boolean, E_Enumeration_Type); + Set_Scope (Any_Boolean, Standard_Standard); + Set_Etype (Any_Boolean, Standard_Boolean); + Init_Esize (Any_Boolean, Standard_Character_Size); + Init_RM_Size (Any_Boolean, 1); + Set_Elem_Alignment (Any_Boolean); + Set_Is_Unsigned_Type (Any_Boolean); + Set_Scalar_Range (Any_Boolean, Scalar_Range (Standard_Boolean)); + Make_Name (Any_Boolean, "a boolean type"); + + Any_Composite := New_Standard_Entity; + Set_Ekind (Any_Composite, E_Array_Type); + Set_Scope (Any_Composite, Standard_Standard); + Set_Etype (Any_Composite, Any_Composite); + Set_Component_Size (Any_Composite, Uint_0); + Set_Component_Type (Any_Composite, Standard_Integer); + Init_Size_Align (Any_Composite); + Make_Name (Any_Composite, "a composite type"); + + Any_Discrete := New_Standard_Entity; + Set_Ekind (Any_Discrete, E_Signed_Integer_Type); + Set_Scope (Any_Discrete, Standard_Standard); + Set_Etype (Any_Discrete, Any_Discrete); + Init_Size (Any_Discrete, Standard_Integer_Size); + Set_Elem_Alignment (Any_Discrete); + Make_Name (Any_Discrete, "a discrete type"); + + Any_Fixed := New_Standard_Entity; + Set_Ekind (Any_Fixed, E_Ordinary_Fixed_Point_Type); + Set_Scope (Any_Fixed, Standard_Standard); + Set_Etype (Any_Fixed, Any_Fixed); + Init_Size (Any_Fixed, Standard_Integer_Size); + Set_Elem_Alignment (Any_Fixed); + Make_Name (Any_Fixed, "a fixed-point type"); + + Any_Integer := New_Standard_Entity; + Set_Ekind (Any_Integer, E_Signed_Integer_Type); + Set_Scope (Any_Integer, Standard_Standard); + Set_Etype (Any_Integer, Standard_Long_Long_Integer); + Init_Size (Any_Integer, Standard_Long_Long_Integer_Size); + Set_Elem_Alignment (Any_Integer); + + Set_Integer_Bounds + (Any_Integer, + Typ => Base_Type (Standard_Integer), + Lb => Uint_0, + Hb => Intval (High_Bound (Scalar_Range (Standard_Integer)))); + Make_Name (Any_Integer, "an integer type"); + + Any_Modular := New_Standard_Entity; + Set_Ekind (Any_Modular, E_Modular_Integer_Type); + Set_Scope (Any_Modular, Standard_Standard); + Set_Etype (Any_Modular, Standard_Long_Long_Integer); + Init_Size (Any_Modular, Standard_Long_Long_Integer_Size); + Set_Elem_Alignment (Any_Modular); + Set_Is_Unsigned_Type (Any_Modular); + Make_Name (Any_Modular, "a modular type"); + + Any_Numeric := New_Standard_Entity; + Set_Ekind (Any_Numeric, E_Signed_Integer_Type); + Set_Scope (Any_Numeric, Standard_Standard); + Set_Etype (Any_Numeric, Standard_Long_Long_Integer); + Init_Size (Any_Numeric, Standard_Long_Long_Integer_Size); + Set_Elem_Alignment (Any_Numeric); + Make_Name (Any_Numeric, "a numeric type"); + + Any_Real := New_Standard_Entity; + Set_Ekind (Any_Real, E_Floating_Point_Type); + Set_Scope (Any_Real, Standard_Standard); + Set_Etype (Any_Real, Standard_Long_Long_Float); + Init_Size (Any_Real, Standard_Long_Long_Float_Size); + Set_Elem_Alignment (Any_Real); + Make_Name (Any_Real, "a real type"); + + Any_Scalar := New_Standard_Entity; + Set_Ekind (Any_Scalar, E_Signed_Integer_Type); + Set_Scope (Any_Scalar, Standard_Standard); + Set_Etype (Any_Scalar, Any_Scalar); + Init_Size (Any_Scalar, Standard_Integer_Size); + Set_Elem_Alignment (Any_Scalar); + Make_Name (Any_Scalar, "a scalar type"); + + Any_String := New_Standard_Entity; + Set_Ekind (Any_String, E_String_Type); + Set_Scope (Any_String, Standard_Standard); + Set_Etype (Any_String, Any_String); + Set_Component_Type (Any_String, Any_Character); + Init_Size_Align (Any_String); + Make_Name (Any_String, "a string type"); + + declare + Index : Node_Id; + + begin + Index := + Make_Range (Stloc, + Low_Bound => Make_Integer (Uint_0), + High_Bound => Make_Integer (Uint_2 ** Standard_Integer_Size)); + Set_Etype (Index, Standard_Integer); + Set_First_Index (Any_String, Index); + end; + + Standard_Integer_8 := New_Standard_Entity; + Decl := New_Node (N_Full_Type_Declaration, Stloc); + Set_Defining_Identifier (Decl, Standard_Integer_8); + Make_Name (Standard_Integer_8, "integer_8"); + Set_Scope (Standard_Integer_8, Standard_Standard); + Build_Signed_Integer_Type (Standard_Integer_8, 8); + + Standard_Integer_16 := New_Standard_Entity; + Decl := New_Node (N_Full_Type_Declaration, Stloc); + Set_Defining_Identifier (Decl, Standard_Integer_16); + Make_Name (Standard_Integer_16, "integer_16"); + Set_Scope (Standard_Integer_16, Standard_Standard); + Build_Signed_Integer_Type (Standard_Integer_16, 16); + + Standard_Integer_32 := New_Standard_Entity; + Decl := New_Node (N_Full_Type_Declaration, Stloc); + Set_Defining_Identifier (Decl, Standard_Integer_32); + Make_Name (Standard_Integer_32, "integer_32"); + Set_Scope (Standard_Integer_32, Standard_Standard); + Build_Signed_Integer_Type (Standard_Integer_32, 32); + + Standard_Integer_64 := New_Standard_Entity; + Decl := New_Node (N_Full_Type_Declaration, Stloc); + Set_Defining_Identifier (Decl, Standard_Integer_64); + Make_Name (Standard_Integer_64, "integer_64"); + Set_Scope (Standard_Integer_64, Standard_Standard); + Build_Signed_Integer_Type (Standard_Integer_64, 64); + + Standard_Unsigned := New_Standard_Entity; + Decl := New_Node (N_Full_Type_Declaration, Stloc); + Set_Defining_Identifier (Decl, Standard_Unsigned); + Make_Name (Standard_Unsigned, "unsigned"); + + Set_Ekind (Standard_Unsigned, E_Modular_Integer_Type); + Set_Scope (Standard_Unsigned, Standard_Standard); + Set_Etype (Standard_Unsigned, Standard_Unsigned); + Init_Size (Standard_Unsigned, Standard_Integer_Size); + Set_Elem_Alignment (Standard_Unsigned); + Set_Modulus (Standard_Unsigned, + Uint_2 ** Standard_Integer_Size); + Set_Is_Unsigned_Type (Standard_Unsigned); + Set_Size_Known_At_Compile_Time + (Standard_Unsigned); + Set_Is_Known_Valid (Standard_Unsigned, True); + + R_Node := New_Node (N_Range, Stloc); + Set_Low_Bound (R_Node, Make_Integer (Uint_0)); + Set_High_Bound (R_Node, Make_Integer (Modulus (Standard_Unsigned) - 1)); + Set_Etype (Low_Bound (R_Node), Standard_Unsigned); + Set_Etype (High_Bound (R_Node), Standard_Unsigned); + Set_Scalar_Range (Standard_Unsigned, R_Node); + + -- Note: universal integer and universal real are constructed as fully + -- formed signed numeric types, with parameters corresponding to the + -- longest runtime types (Long_Long_Integer and Long_Long_Float). This + -- allows Gigi to properly process references to universal types that + -- are not folded at compile time. + + Universal_Integer := New_Standard_Entity; + Decl := New_Node (N_Full_Type_Declaration, Stloc); + Set_Defining_Identifier (Decl, Universal_Integer); + Make_Name (Universal_Integer, "universal_integer"); + Set_Scope (Universal_Integer, Standard_Standard); + Build_Signed_Integer_Type + (Universal_Integer, Standard_Long_Long_Integer_Size); + + Universal_Real := New_Standard_Entity; + Decl := New_Node (N_Full_Type_Declaration, Stloc); + Set_Defining_Identifier (Decl, Universal_Real); + Make_Name (Universal_Real, "universal_real"); + Set_Scope (Universal_Real, Standard_Standard); + Build_Float_Type + (Universal_Real, + Standard_Long_Long_Float_Size, + Standard_Long_Long_Float_Digits); + + -- Note: universal fixed, unlike universal integer and universal real, + -- is never used at runtime, so it does not need to have bounds set. + + Universal_Fixed := New_Standard_Entity; + Decl := New_Node (N_Full_Type_Declaration, Stloc); + Set_Defining_Identifier (Decl, Universal_Fixed); + Make_Name (Universal_Fixed, "universal_fixed"); + Set_Ekind (Universal_Fixed, E_Ordinary_Fixed_Point_Type); + Set_Etype (Universal_Fixed, Universal_Fixed); + Set_Scope (Universal_Fixed, Standard_Standard); + Init_Size (Universal_Fixed, Standard_Long_Long_Integer_Size); + Set_Elem_Alignment (Universal_Fixed); + Set_Size_Known_At_Compile_Time + (Universal_Fixed); + + -- Create type declaration for Duration, using a 64-bit size. The + -- delta and size values depend on the mode set in system.ads. + + Build_Duration : declare + Dlo : Uint; + Dhi : Uint; + Delta_Val : Ureal; + + begin + -- In 32 bit mode, the size is 32 bits, and the delta and + -- small values are set to 20 milliseconds (20.0**(10.0**(-3)). + + if Duration_32_Bits_On_Target then + Dlo := Intval (Type_Low_Bound (Standard_Integer_32)); + Dhi := Intval (Type_High_Bound (Standard_Integer_32)); + Delta_Val := UR_From_Components (UI_From_Int (20), Uint_3, 10); + + -- In standard 64-bit mode, the size is 64-bits and the delta and + -- small values are set to nanoseconds (1.0**(10.0**(-9)) + + else + Dlo := Intval (Type_Low_Bound (Standard_Integer_64)); + Dhi := Intval (Type_High_Bound (Standard_Integer_64)); + Delta_Val := UR_From_Components (Uint_1, Uint_9, 10); + end if; + + Tdef_Node := Make_Ordinary_Fixed_Point_Definition (Stloc, + Delta_Expression => Make_Real_Literal (Stloc, Delta_Val), + Real_Range_Specification => + Make_Real_Range_Specification (Stloc, + Low_Bound => Make_Real_Literal (Stloc, + Realval => Dlo * Delta_Val), + High_Bound => Make_Real_Literal (Stloc, + Realval => Dhi * Delta_Val))); + + Set_Type_Definition (Parent (Standard_Duration), Tdef_Node); + + Set_Ekind (Standard_Duration, E_Ordinary_Fixed_Point_Type); + Set_Etype (Standard_Duration, Standard_Duration); + + if Duration_32_Bits_On_Target then + Init_Size (Standard_Duration, 32); + else + Init_Size (Standard_Duration, 64); + end if; + + Set_Elem_Alignment (Standard_Duration); + Set_Delta_Value (Standard_Duration, Delta_Val); + Set_Small_Value (Standard_Duration, Delta_Val); + Set_Scalar_Range (Standard_Duration, + Real_Range_Specification + (Type_Definition (Parent (Standard_Duration)))); + + -- Normally it does not matter that nodes in package Standard are + -- not marked as analyzed. The Scalar_Range of the fixed-point + -- type Standard_Duration is an exception, because of the special + -- test made in Freeze.Freeze_Fixed_Point_Type. + + Set_Analyzed (Scalar_Range (Standard_Duration)); + + Set_Etype (Type_High_Bound (Standard_Duration), Standard_Duration); + Set_Etype (Type_Low_Bound (Standard_Duration), Standard_Duration); + + Set_Is_Static_Expression (Type_High_Bound (Standard_Duration)); + Set_Is_Static_Expression (Type_Low_Bound (Standard_Duration)); + + Set_Corresponding_Integer_Value + (Type_High_Bound (Standard_Duration), Dhi); + + Set_Corresponding_Integer_Value + (Type_Low_Bound (Standard_Duration), Dlo); + + Set_Size_Known_At_Compile_Time (Standard_Duration); + end Build_Duration; + + -- Build standard exception type. Note that the type name here is + -- actually used in the generated code, so it must be set correctly + + -- ??? Also note that the Import_Code component is now declared + -- as a System.Standard_Library.Exception_Code to enforce run-time + -- library implementation consistency. It's too early here to resort + -- to rtsfind to get the proper node for that type, so we use the + -- closest possible available type node at hand instead. We should + -- probably be fixing this up at some point. + + Standard_Exception_Type := New_Standard_Entity; + Set_Ekind (Standard_Exception_Type, E_Record_Type); + Set_Etype (Standard_Exception_Type, Standard_Exception_Type); + Set_Scope (Standard_Exception_Type, Standard_Standard); + Set_Stored_Constraint + (Standard_Exception_Type, No_Elist); + Init_Size_Align (Standard_Exception_Type); + Set_Size_Known_At_Compile_Time + (Standard_Exception_Type, True); + Make_Name (Standard_Exception_Type, "exception"); + + Make_Component + (Standard_Exception_Type, Standard_Boolean, "Not_Handled_By_Others"); + Make_Component + (Standard_Exception_Type, Standard_Character, "Lang"); + Make_Component + (Standard_Exception_Type, Standard_Natural, "Name_Length"); + Make_Component + (Standard_Exception_Type, Standard_A_Char, "Full_Name"); + Make_Component + (Standard_Exception_Type, Standard_A_Char, "HTable_Ptr"); + Make_Component + (Standard_Exception_Type, Standard_Unsigned, "Import_Code"); + Make_Component + (Standard_Exception_Type, Standard_A_Char, "Raise_Hook"); + + -- Build tree for record declaration, for use by the back-end + + declare + Comp_List : List_Id; + Comp : Entity_Id; + + begin + Comp := First_Entity (Standard_Exception_Type); + Comp_List := New_List; + while Present (Comp) loop + Append ( + Make_Component_Declaration (Stloc, + Defining_Identifier => Comp, + Component_Definition => + Make_Component_Definition (Stloc, + Aliased_Present => False, + Subtype_Indication => New_Occurrence_Of (Etype (Comp), + Stloc))), + Comp_List); + + Next_Entity (Comp); + end loop; + + Decl := Make_Full_Type_Declaration (Stloc, + Defining_Identifier => Standard_Exception_Type, + Type_Definition => + Make_Record_Definition (Stloc, + End_Label => Empty, + Component_List => + Make_Component_List (Stloc, + Component_Items => Comp_List))); + end; + + Append (Decl, Decl_S); + + Layout_Type (Standard_Exception_Type); + + -- Create declarations of standard exceptions + + Build_Exception (S_Constraint_Error); + Build_Exception (S_Program_Error); + Build_Exception (S_Storage_Error); + Build_Exception (S_Tasking_Error); + + -- Numeric_Error is a normal exception in Ada 83, but in Ada 95 + -- it is a renaming of Constraint_Error. Is this test too early??? + + if Ada_Version = Ada_83 then + Build_Exception (S_Numeric_Error); + + else + Decl := New_Node (N_Exception_Renaming_Declaration, Stloc); + E_Id := Standard_Entity (S_Numeric_Error); + + Set_Ekind (E_Id, E_Exception); + Set_Exception_Code (E_Id, Uint_0); + Set_Etype (E_Id, Standard_Exception_Type); + Set_Is_Public (E_Id); + Set_Renamed_Entity (E_Id, Standard_Entity (S_Constraint_Error)); + + Set_Defining_Identifier (Decl, E_Id); + Append (Decl, Decl_S); + + Ident_Node := New_Node (N_Identifier, Stloc); + Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error))); + Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error)); + Set_Name (Decl, Ident_Node); + end if; + + -- Abort_Signal is an entity that does not get made visible + + Abort_Signal := New_Standard_Entity; + Set_Chars (Abort_Signal, Name_uAbort_Signal); + Set_Ekind (Abort_Signal, E_Exception); + Set_Exception_Code (Abort_Signal, Uint_0); + Set_Etype (Abort_Signal, Standard_Exception_Type); + Set_Scope (Abort_Signal, Standard_Standard); + Set_Is_Public (Abort_Signal, True); + Decl := + Make_Exception_Declaration (Stloc, + Defining_Identifier => Abort_Signal); + + -- Create defining identifiers for shift operator entities. Note + -- that these entities are used only for marking shift operators + -- generated internally, and hence need no structure, just a name + -- and a unique identity. + + Standard_Op_Rotate_Left := New_Standard_Entity; + Set_Chars (Standard_Op_Rotate_Left, Name_Rotate_Left); + Set_Ekind (Standard_Op_Rotate_Left, E_Operator); + + Standard_Op_Rotate_Right := New_Standard_Entity; + Set_Chars (Standard_Op_Rotate_Right, Name_Rotate_Right); + Set_Ekind (Standard_Op_Rotate_Right, E_Operator); + + Standard_Op_Shift_Left := New_Standard_Entity; + Set_Chars (Standard_Op_Shift_Left, Name_Shift_Left); + Set_Ekind (Standard_Op_Shift_Left, E_Operator); + + Standard_Op_Shift_Right := New_Standard_Entity; + Set_Chars (Standard_Op_Shift_Right, Name_Shift_Right); + Set_Ekind (Standard_Op_Shift_Right, E_Operator); + + Standard_Op_Shift_Right_Arithmetic := New_Standard_Entity; + Set_Chars (Standard_Op_Shift_Right_Arithmetic, + Name_Shift_Right_Arithmetic); + Set_Ekind (Standard_Op_Shift_Right_Arithmetic, + E_Operator); + + -- Create standard operator declarations + + Create_Operators; + + -- Initialize visibility table with entities in Standard + + for E in Standard_Entity_Type loop + if Ekind (Standard_Entity (E)) /= E_Operator then + Set_Name_Entity_Id + (Chars (Standard_Entity (E)), Standard_Entity (E)); + Set_Homonym (Standard_Entity (E), Empty); + end if; + + if E not in S_ASCII_Names then + Set_Scope (Standard_Entity (E), Standard_Standard); + Set_Is_Immediately_Visible (Standard_Entity (E)); + end if; + end loop; + + -- The predefined package Standard itself does not have a scope; + -- it is the only entity in the system not to have one, and this + -- is what identifies the package to Gigi. + + Set_Scope (Standard_Standard, Empty); + + -- Set global variables indicating last Id values and version + + Last_Standard_Node_Id := Last_Node_Id; + Last_Standard_List_Id := Last_List_Id; + + -- The Error node has an Etype of Any_Type to help error recovery + + Set_Etype (Error, Any_Type); + + -- Print representation of standard if switch set + + if Opt.Print_Standard then + Print_Standard; + end if; + end Create_Standard; + + ------------------------------------ + -- Create_Unconstrained_Base_Type -- + ------------------------------------ + + procedure Create_Unconstrained_Base_Type + (E : Entity_Id; + K : Entity_Kind) + is + New_Ent : constant Entity_Id := New_Copy (E); + + begin + Set_Ekind (E, K); + Set_Is_Constrained (E, True); + Set_Is_First_Subtype (E, True); + Set_Etype (E, New_Ent); + + Append_Entity (New_Ent, Standard_Standard); + Set_Is_Constrained (New_Ent, False); + Set_Etype (New_Ent, New_Ent); + Set_Is_Known_Valid (New_Ent, True); + + if K = E_Signed_Integer_Subtype then + Set_Etype (Low_Bound (Scalar_Range (E)), New_Ent); + Set_Etype (High_Bound (Scalar_Range (E)), New_Ent); + end if; + + end Create_Unconstrained_Base_Type; + + -------------------- + -- Identifier_For -- + -------------------- + + function Identifier_For (S : Standard_Entity_Type) return Node_Id is + Ident_Node : Node_Id; + begin + Ident_Node := New_Node (N_Identifier, Stloc); + Set_Chars (Ident_Node, Chars (Standard_Entity (S))); + return Ident_Node; + end Identifier_For; + + -------------------- + -- Make_Component -- + -------------------- + + procedure Make_Component + (Rec : Entity_Id; + Typ : Entity_Id; + Nam : String) + is + Id : constant Entity_Id := New_Standard_Entity; + + begin + Set_Ekind (Id, E_Component); + Set_Etype (Id, Typ); + Set_Scope (Id, Rec); + Init_Component_Location (Id); + + Set_Original_Record_Component (Id, Id); + Make_Name (Id, Nam); + Append_Entity (Id, Rec); + end Make_Component; + + ----------------- + -- Make_Formal -- + ----------------- + + function Make_Formal + (Typ : Entity_Id; + Formal_Name : String) return Entity_Id + is + Formal : Entity_Id; + + begin + Formal := New_Standard_Entity; + + Set_Ekind (Formal, E_In_Parameter); + Set_Mechanism (Formal, Default_Mechanism); + Set_Scope (Formal, Standard_Standard); + Set_Etype (Formal, Typ); + Make_Name (Formal, Formal_Name); + + return Formal; + end Make_Formal; + + ------------------ + -- Make_Integer -- + ------------------ + + function Make_Integer (V : Uint) return Node_Id is + N : constant Node_Id := Make_Integer_Literal (Stloc, V); + begin + Set_Is_Static_Expression (N); + return N; + end Make_Integer; + + --------------- + -- Make_Name -- + --------------- + + procedure Make_Name (Id : Entity_Id; Nam : String) is + begin + for J in 1 .. Nam'Length loop + Name_Buffer (J) := Fold_Lower (Nam (Nam'First + (J - 1))); + end loop; + + Name_Len := Nam'Length; + Set_Chars (Id, Name_Find); + end Make_Name; + + ------------------ + -- New_Operator -- + ------------------ + + function New_Operator (Op : Name_Id; Typ : Entity_Id) return Entity_Id is + Ident_Node : Entity_Id; + + begin + Ident_Node := Make_Defining_Identifier (Stloc, Op); + + Set_Is_Pure (Ident_Node, True); + Set_Ekind (Ident_Node, E_Operator); + Set_Etype (Ident_Node, Typ); + Set_Scope (Ident_Node, Standard_Standard); + Set_Homonym (Ident_Node, Get_Name_Entity_Id (Op)); + Set_Convention (Ident_Node, Convention_Intrinsic); + + Set_Is_Immediately_Visible (Ident_Node, True); + Set_Is_Intrinsic_Subprogram (Ident_Node, True); + + Set_Name_Entity_Id (Op, Ident_Node); + Append_Entity (Ident_Node, Standard_Standard); + return Ident_Node; + end New_Operator; + + ------------------------- + -- New_Standard_Entity -- + ------------------------- + + function New_Standard_Entity + (New_Node_Kind : Node_Kind := N_Defining_Identifier) return Entity_Id + is + E : constant Entity_Id := New_Entity (New_Node_Kind, Stloc); + + begin + -- All standard entities are Pure and Public + + Set_Is_Pure (E); + Set_Is_Public (E); + + -- All standard entity names are analyzed manually, and are thus + -- frozen as soon as they are created. + + Set_Is_Frozen (E); + + -- Set debug information required for all standard types + + Set_Needs_Debug_Info (E); + + -- All standard entities are built with fully qualified names, so + -- set the flag to prevent an abortive attempt at requalification! + + Set_Has_Qualified_Name (E); + + -- Return newly created entity to be completed by caller + + return E; + end New_Standard_Entity; + + -------------------- + -- Print_Standard -- + -------------------- + + procedure Print_Standard is + + procedure P (Item : String) renames Output.Write_Line; + -- Short-hand, since we do a lot of line writes here! + + procedure P_Int_Range (Size : Pos); + -- Prints the range of an integer based on its Size + + procedure P_Float_Range (Id : Entity_Id); + -- Prints the bounds range for the given float type entity + + ------------------- + -- P_Float_Range -- + ------------------- + + procedure P_Float_Range (Id : Entity_Id) is + begin + Write_Str (" range "); + UR_Write (Realval (Type_Low_Bound (Id))); + Write_Str (" .. "); + UR_Write (Realval (Type_High_Bound (Id))); + Write_Str (";"); + Write_Eol; + end P_Float_Range; + + ----------------- + -- P_Int_Range -- + ----------------- + + procedure P_Int_Range (Size : Pos) is + begin + Write_Str (" is range -(2 **"); + Write_Int (Size - 1); + Write_Str (")"); + Write_Str (" .. +(2 **"); + Write_Int (Size - 1); + Write_Str (" - 1);"); + Write_Eol; + end P_Int_Range; + + -- Start of processing for Print_Standard + + begin + P ("-- Representation of package Standard"); + Write_Eol; + P ("-- This is not accurate Ada, since new base types cannot be "); + P ("-- created, but the listing shows the target dependent"); + P ("-- characteristics of the Standard types for this compiler"); + Write_Eol; + + P ("package Standard is"); + P ("pragma Pure (Standard);"); + Write_Eol; + + P (" type Boolean is (False, True);"); + P (" for Boolean'Size use 1;"); + P (" for Boolean use (False => 0, True => 1);"); + Write_Eol; + + -- Integer types + + Write_Str (" type Integer"); + P_Int_Range (Standard_Integer_Size); + Write_Str (" for Integer'Size use "); + Write_Int (Standard_Integer_Size); + P (";"); + Write_Eol; + + P (" subtype Natural is Integer range 0 .. Integer'Last;"); + P (" subtype Positive is Integer range 1 .. Integer'Last;"); + Write_Eol; + + Write_Str (" type Short_Short_Integer"); + P_Int_Range (Standard_Short_Short_Integer_Size); + Write_Str (" for Short_Short_Integer'Size use "); + Write_Int (Standard_Short_Short_Integer_Size); + P (";"); + Write_Eol; + + Write_Str (" type Short_Integer"); + P_Int_Range (Standard_Short_Integer_Size); + Write_Str (" for Short_Integer'Size use "); + Write_Int (Standard_Short_Integer_Size); + P (";"); + Write_Eol; + + Write_Str (" type Long_Integer"); + P_Int_Range (Standard_Long_Integer_Size); + Write_Str (" for Long_Integer'Size use "); + Write_Int (Standard_Long_Integer_Size); + P (";"); + Write_Eol; + + Write_Str (" type Long_Long_Integer"); + P_Int_Range (Standard_Long_Long_Integer_Size); + Write_Str (" for Long_Long_Integer'Size use "); + Write_Int (Standard_Long_Long_Integer_Size); + P (";"); + Write_Eol; + + -- Floating point types + + Write_Str (" type Short_Float is digits "); + Write_Int (Standard_Short_Float_Digits); + Write_Eol; + P_Float_Range (Standard_Short_Float); + Write_Str (" for Short_Float'Size use "); + Write_Int (Standard_Short_Float_Size); + P (";"); + Write_Eol; + + Write_Str (" type Float is digits "); + Write_Int (Standard_Float_Digits); + Write_Eol; + P_Float_Range (Standard_Float); + Write_Str (" for Float'Size use "); + Write_Int (Standard_Float_Size); + P (";"); + Write_Eol; + + Write_Str (" type Long_Float is digits "); + Write_Int (Standard_Long_Float_Digits); + Write_Eol; + P_Float_Range (Standard_Long_Float); + Write_Str (" for Long_Float'Size use "); + Write_Int (Standard_Long_Float_Size); + P (";"); + Write_Eol; + + Write_Str (" type Long_Long_Float is digits "); + Write_Int (Standard_Long_Long_Float_Digits); + Write_Eol; + P_Float_Range (Standard_Long_Long_Float); + Write_Str (" for Long_Long_Float'Size use "); + Write_Int (Standard_Long_Long_Float_Size); + P (";"); + Write_Eol; + + P (" type Character is (...)"); + Write_Str (" for Character'Size use "); + Write_Int (Standard_Character_Size); + P (";"); + P (" -- See RM A.1(35) for details of this type"); + Write_Eol; + + P (" type Wide_Character is (...)"); + Write_Str (" for Wide_Character'Size use "); + Write_Int (Standard_Wide_Character_Size); + P (";"); + P (" -- See RM A.1(36) for details of this type"); + Write_Eol; + + P (" type Wide_Wide_Character is (...)"); + Write_Str (" for Wide_Wide_Character'Size use "); + Write_Int (Standard_Wide_Wide_Character_Size); + P (";"); + P (" -- See RM A.1(36) for details of this type"); + + P (" type String is array (Positive range <>) of Character;"); + P (" pragma Pack (String);"); + Write_Eol; + + P (" type Wide_String is array (Positive range <>)" & + " of Wide_Character;"); + P (" pragma Pack (Wide_String);"); + Write_Eol; + + P (" type Wide_Wide_String is array (Positive range <>)" & + " of Wide_Wide_Character;"); + P (" pragma Pack (Wide_Wide_String);"); + Write_Eol; + + -- Here it's OK to use the Duration type of the host compiler since + -- the implementation of Duration in GNAT is target independent. + + if Duration_32_Bits_On_Target then + P (" type Duration is delta 0.020"); + P (" range -((2 ** 31 - 1) * 0.020) .."); + P (" +((2 ** 31 - 1) * 0.020);"); + P (" for Duration'Small use 0.020;"); + else + P (" type Duration is delta 0.000000001"); + P (" range -((2 ** 63 - 1) * 0.000000001) .."); + P (" +((2 ** 63 - 1) * 0.000000001);"); + P (" for Duration'Small use 0.000000001;"); + end if; + + Write_Eol; + + P (" Constraint_Error : exception;"); + P (" Program_Error : exception;"); + P (" Storage_Error : exception;"); + P (" Tasking_Error : exception;"); + P (" Numeric_Error : exception renames Constraint_Error;"); + Write_Eol; + + P ("end Standard;"); + end Print_Standard; + + ---------------------- + -- Set_Float_Bounds -- + ---------------------- + + procedure Set_Float_Bounds (Id : Entity_Id) is + L : Node_Id; + -- Low bound of literal value + + H : Node_Id; + -- High bound of literal value + + R : Node_Id; + -- Range specification + + Radix : constant Uint := Machine_Radix_Value (Id); + Mantissa : constant Uint := Machine_Mantissa_Value (Id); + Emax : constant Uint := Machine_Emax_Value (Id); + Significand : constant Uint := Radix ** Mantissa - 1; + Exponent : constant Uint := Emax - Mantissa; + + begin + -- Note: for the call from Cstand to initially create the types in + -- Standard, Float_Rep will never be VAX_Native. Circuitry in Sem_Vfpt + -- will adjust these types appropriately VAX_Native if a pragma + -- Float_Representation (VAX_Float) is used. + + H := Make_Float_Literal (Stloc, Radix, Significand, Exponent); + L := Make_Float_Literal (Stloc, Radix, -Significand, Exponent); + + Set_Etype (L, Id); + Set_Is_Static_Expression (L); + + Set_Etype (H, Id); + Set_Is_Static_Expression (H); + + R := New_Node (N_Range, Stloc); + Set_Low_Bound (R, L); + Set_High_Bound (R, H); + Set_Includes_Infinities (R, True); + Set_Scalar_Range (Id, R); + Set_Etype (R, Id); + Set_Parent (R, Id); + end Set_Float_Bounds; + + ------------------------ + -- Set_Integer_Bounds -- + ------------------------ + + procedure Set_Integer_Bounds + (Id : Entity_Id; + Typ : Entity_Id; + Lb : Uint; + Hb : Uint) + is + L : Node_Id; -- Low bound of literal value + H : Node_Id; -- High bound of literal value + R : Node_Id; -- Range specification + + begin + L := Make_Integer (Lb); + H := Make_Integer (Hb); + + Set_Etype (L, Typ); + Set_Etype (H, Typ); + + R := New_Node (N_Range, Stloc); + Set_Low_Bound (R, L); + Set_High_Bound (R, H); + Set_Scalar_Range (Id, R); + Set_Etype (R, Typ); + Set_Parent (R, Id); + Set_Is_Unsigned_Type (Id, Lb >= 0); + end Set_Integer_Bounds; + +end CStand; diff --git a/gcc/ada/cstand.ads b/gcc/ada/cstand.ads new file mode 100644 index 000000000..c6dad23df --- /dev/null +++ b/gcc/ada/cstand.ads @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C S T A N D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 procedure that is used to create the tree for +-- package Standard and initialize the entities in package Stand. + +with Types; use Types; + +package CStand is + + procedure Create_Standard; + -- This procedure creates the tree for package standard, and initializes + -- the Standard_Entities array and Standard_Package_Node. First the + -- syntactic representation is created (as though the parser had parsed + -- a copy of the source of Standard) and then semantic information is + -- added as it would be by the semantic phases of the compiler. The + -- tree is in the standard format defined by Syntax_Info, except that + -- all Sloc values are set to Standard_Location except for nodes that + -- are part of package ASCII, which have Sloc = Standard_ASCII_Location. + -- The semantics info is in the format given by Entity_Info. The global + -- variables Last_Standard_Node_Id and Last_Standard_List_Id are also set. + + procedure Set_Float_Bounds (Id : Entity_Id); + -- Procedure to set bounds for float type or subtype. Id is the entity + -- whose bounds and type are to be set (a floating-point type). + +end CStand; diff --git a/gcc/ada/cstreams.c b/gcc/ada/cstreams.c new file mode 100644 index 000000000..9dea9a4f1 --- /dev/null +++ b/gcc/ada/cstreams.c @@ -0,0 +1,244 @@ +/**************************************************************************** + * * + * GNAT RUN-TIME COMPONENTS * + * * + * C S T R E A M S * + * * + * Auxiliary C functions for Interfaces.C.Streams * + * * + * 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. * + * * + ****************************************************************************/ + +/* Routines required for implementing routines in Interfaces.C.Streams */ + +#ifdef __vxworks +#include "vxWorks.h" +#endif + +#ifdef IN_RTS +#include "tconfig.h" +#include "tsystem.h" +#include +#else +#include "config.h" +#include "system.h" +#endif + +#include "adaint.h" + +#ifdef VMS +#include +#endif + +#ifdef linux +/* Don't use macros on GNU/Linux since they cause incompatible changes between + glibc 2.0 and 2.1 */ + +#ifdef stderr +# undef stderr +#endif +#ifdef stdin +# undef stdin +#endif +#ifdef stdout +# undef stdout +#endif + +#endif + +/* The _IONBF value in MINGW32 stdio.h is wrong. */ +#if defined (WINNT) || defined (_WINNT) +#if OLD_MINGW +#undef _IONBF +#define _IONBF 0004 +#endif +#endif + +int +__gnat_feof (FILE *stream) +{ + return (feof (stream)); +} + +int +__gnat_ferror (FILE *stream) +{ + return (ferror (stream)); +} + +int +__gnat_fileno (FILE *stream) +{ + return (fileno (stream)); +} + +int +__gnat_is_regular_file_fd (int fd) +{ + int ret; + GNAT_STRUCT_STAT statbuf; + + ret = GNAT_FSTAT (fd, &statbuf); + return (!ret && S_ISREG (statbuf.st_mode)); +} + +/* on some systems, the constants for seek are not defined, if so, then + provide the conventional definitions */ + +#ifndef SEEK_SET +#define SEEK_SET 0 /* Set file pointer to offset */ +#define SEEK_CUR 1 /* Set file pointer to its current value plus offset */ +#define SEEK_END 2 /* Set file pointer to the size of the file plus offset */ +#endif + +/* if L_tmpnam is not set, use a large number that should be safe */ +#ifndef L_tmpnam +#define L_tmpnam 256 +#endif + +int __gnat_constant_eof = EOF; +int __gnat_constant_iofbf = _IOFBF; +int __gnat_constant_iolbf = _IOLBF; +int __gnat_constant_ionbf = _IONBF; +int __gnat_constant_l_tmpnam = L_tmpnam; +int __gnat_constant_seek_cur = SEEK_CUR; +int __gnat_constant_seek_end = SEEK_END; +int __gnat_constant_seek_set = SEEK_SET; + +FILE * +__gnat_constant_stderr (void) +{ + return stderr; +} + +FILE * +__gnat_constant_stdin (void) +{ + return stdin; +} + +FILE * +__gnat_constant_stdout (void) +{ + return stdout; +} + +char * +__gnat_full_name (char *nam, char *buffer) +{ +#ifdef RTSS + /* RTSS applications have no current-directory notion, so RTSS file I/O + requests must use fully qualified path names, such as: + c:\temp\MyFile.txt (for a file system object) + \\.\MyDevice0 (for a device object) + */ + if (nam[1] == ':' || nam[0] == '\\') + strcpy (buffer, nam); + else + buffer[0] = '\0'; + +#elif defined (__MINGW32__) + /* If this is a device file return it as is; + under Windows NT a device file ends with ":". */ + if (nam[strlen (nam) - 1] == ':') + strcpy (buffer, nam); + else + { + char *p; + + _fullpath (buffer, nam, __gnat_max_path_len); + + for (p = buffer; *p; p++) + if (*p == '/') + *p = '\\'; + } + +#elif defined (sgi) || defined (__FreeBSD__) + + /* Use realpath function which resolves links and references to . and .. + on those Unix systems that support it. Note that GNU/Linux provides it but + cannot handle more than 5 symbolic links in a full name, so we use the + getcwd approach instead. */ + realpath (nam, buffer); + +#elif defined (VMS) + strncpy (buffer, __gnat_to_canonical_file_spec (nam), __gnat_max_path_len); + + if (buffer[0] == '/' || strchr (buffer, '!')) /* '!' means decnet node */ + strncpy (buffer, __gnat_to_host_file_spec (buffer), __gnat_max_path_len); + else + { + char *nambuffer = alloca (__gnat_max_path_len); + + strncpy (nambuffer, buffer, __gnat_max_path_len); + strncpy + (buffer, getcwd (buffer, __gnat_max_path_len, 0), __gnat_max_path_len); + strncat (buffer, "/", __gnat_max_path_len); + strncat (buffer, nambuffer, __gnat_max_path_len); + strncpy (buffer, __gnat_to_host_file_spec (buffer), __gnat_max_path_len); + } + +#elif defined (__vxworks) + + /* On VxWorks systems, an absolute path can be represented (depending on + the host platform) as either /dir/file, or device:/dir/file, or + device:drive_letter:/dir/file. Use the __gnat_is_absolute_path + to verify it. */ + + int length; + + if (__gnat_is_absolute_path (nam, strlen (nam))) + strcpy (buffer, nam); + + else + { + length = __gnat_max_path_len; + __gnat_get_current_dir (buffer, &length); + strncat (buffer, nam, __gnat_max_path_len - length - 1); + } + +#else + if (nam[0] != '/') + { + char *p = getcwd (buffer, __gnat_max_path_len); + + if (p == 0) + { + buffer[0] = '\0'; + return 0; + } + + + /* If the name returned is an absolute path, it is safe to append '/' + to the path and concatenate the name of the file. */ + if (buffer[0] == '/') + strcat (buffer, "/"); + + strcat (buffer, nam); + } + else + strcpy (buffer, nam); +#endif + + return buffer; +} diff --git a/gcc/ada/ctrl_c.c b/gcc/ada/ctrl_c.c new file mode 100644 index 000000000..a860b767c --- /dev/null +++ b/gcc/ada/ctrl_c.c @@ -0,0 +1,166 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * C T R L _ C * + * * + * C Implementation File * + * * + * 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. * + * * + ****************************************************************************/ + +#ifdef IN_RTS +#include "tconfig.h" +#include "tsystem.h" +#include +#else +#include "config.h" +#include "system.h" +#endif + +/* Services to intercept Ctrl-C */ + +/* __gnat_install_int_handler will install the specified handler. + If called for the first time, it will also save the original handler */ +void __gnat_install_int_handler (void (*) (void)); + +/* __gnat_uninstall_int_handler will reinstall the original handler */ +void __gnat_uninstall_int_handler (void); + +/* POSIX implementation */ + +#if (defined (__unix__) || defined (_AIX) || defined (__APPLE__)) \ + && !defined (__vxworks) + +#include + +void (*sigint_intercepted) (void) = 0; + +struct sigaction original_act; + +static void +__gnat_int_handler (int sig __attribute__ ((unused))) +{ + if (sigint_intercepted != 0) + sigint_intercepted (); +} + +/* Install handler and save original handler. */ + +void +__gnat_install_int_handler (void (*proc) (void)) +{ + struct sigaction act; + + if (sigint_intercepted == 0) + { + act.sa_handler = __gnat_int_handler; +#if defined (__Lynx__) + /* LynxOS does not support SA_RESTART. */ + act.sa_flags = 0; +#else + act.sa_flags = SA_RESTART; +#endif + sigemptyset (&act.sa_mask); + sigaction (SIGINT, &act, &original_act); + } + + sigint_intercepted = proc; +} + +/* Restore original handler */ + +void +__gnat_uninstall_int_handler (void) +{ + if (sigint_intercepted != 0) + { + sigaction (SIGINT, &original_act, 0); + sigint_intercepted = 0; + } +} + +/* Windows implementation */ + +#elif defined (__MINGW32__) + +#include "mingw32.h" +#include + +void (*sigint_intercepted) (void) = NULL; + +static BOOL WINAPI +__gnat_int_handler (DWORD dwCtrlType) +{ + switch (dwCtrlType) + { + case CTRL_C_EVENT: + case CTRL_BREAK_EVENT: + if (sigint_intercepted != 0) + { + sigint_intercepted (); + return TRUE; + } + break; + + case CTRL_CLOSE_EVENT: + case CTRL_LOGOFF_EVENT: + case CTRL_SHUTDOWN_EVENT: + break; + } + + return FALSE; +} + +void +__gnat_install_int_handler (void (*proc) (void)) +{ + if (sigint_intercepted == NULL) + SetConsoleCtrlHandler (__gnat_int_handler, TRUE); + + sigint_intercepted = proc; +} + +void +__gnat_uninstall_int_handler (void) +{ + if (sigint_intercepted != NULL) + SetConsoleCtrlHandler (__gnat_int_handler, FALSE); + + sigint_intercepted = NULL; +} + +/* Default implementation: do nothing */ + +#else + +void +__gnat_install_int_handler (void (*proc) (void) __attribute__ ((unused))) +{ +} + +void +__gnat_uninstall_int_handler (void) +{ +} +#endif diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb new file mode 100644 index 000000000..5bfe7c422 --- /dev/null +++ b/gcc/ada/debug.adb @@ -0,0 +1,906 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D E B U G -- +-- -- +-- 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 Debug is + + --------------------------------- + -- Summary of Debug Flag Usage -- + --------------------------------- + + -- Debug flags for compiler (GNAT1) + + -- da Generate messages tracking semantic analyzer progress + -- db Show encoding of type names for debug output + -- dc List names of units as they are compiled + -- dd Dynamic allocation of tables messages generated + -- de List the entity table + -- df Full tree/source print (includes withed units) + -- dg Print source from tree (generated code only) + -- dh Generate listing showing loading of name table hash chains + -- di Generate messages for visibility linking/delinking + -- dj Suppress "junk null check" for access parameter values + -- dk Generate GNATBUG message on abort, even if previous errors + -- dl Generate unit load trace messages + -- dm Allow VMS features even if not OpenVMS version + -- dn Generate messages for node/list allocation + -- do Print source from tree (original code only) + -- dp Generate messages for parser scope stack push/pops + -- dq No auto-alignment of small records + -- dr Generate parser resynchronization messages + -- ds Print source from tree (including original and generated stuff) + -- dt Print full tree + -- du Uncheck categorization pragmas + -- dv Output trace of overload resolution + -- dw Print trace of semantic scope stack + -- dx Force expansion on, even if no code being generated + -- dy Print tree of package Standard + -- dz Print source of package Standard + + -- dA All entities included in representation information output + -- dB Output debug encoding of type names and variants + -- dC Output debugging information on check suppression + -- dD Delete elaboration checks in inner level routines + -- dE Apply elaboration checks to predefined units + -- dF Front end data layout enabled + -- dG Generate all warnings including those normally suppressed + -- dH Hold (kill) call to gigi + -- dI Inhibit internal name numbering in gnatG listing + -- dJ Output debugging trace info for JGNAT (Java VM version of GNAT) + -- dK Kill all error messages + -- dL Output trace information on elaboration checking + -- dM Assume all variables are modified (no current values) + -- dN No file name information in exception messages + -- dO Output immediate error messages + -- dP Do not check for controlled objects in preelaborable packages + -- dQ + -- dR Bypass check for correct version of s-rpc + -- dS Never convert numbers to machine numbers in Sem_Eval + -- dT Convert to machine numbers only for constant declarations + -- dU Enable garbage collection of unreachable entities + -- dV Enable viewing of all symbols in debugger + -- dW Disable warnings on calls for IN OUT parameters + -- dX Display messages on reads of potentially uninitialized scalars + -- dY Enable configurable run-time mode + -- dZ Generate listing showing the contents of the dispatch tables + + -- d.a Force Target_Strict_Alignment mode to True + -- d.b + -- d.c Generate inline concatenation, do not call procedure + -- d.d + -- d.e + -- d.f Inhibit folding of static expressions + -- d.g Enable conversion of raise into goto + -- d.h + -- d.i Ignore Warnings pragmas + -- d.j + -- d.k + -- d.l Use Ada 95 semantics for limited function returns + -- d.m For -gnatl, print full source only for main unit + -- d.n Print source file names + -- d.o Generate .NET listing of CIL code + -- d.p Enable the .NET CIL verifier + -- d.q + -- d.r Enable OK_To_Reorder_Components in non-variant records + -- d.s Disable expansion of slice move, use memmove + -- d.t Disable static allocation of library level dispatch tables + -- d.u + -- d.v Enable OK_To_Reorder_Components in variant records + -- d.w Do not check for infinite loops + -- d.x No exception handlers + -- d.y + -- d.z + + -- d.A Read/write Aspect_Specifications hash table to tree + -- d.B + -- d.C Generate concatenation call, do not generate inline code + -- d.D + -- d.E + -- d.F + -- d.G + -- d.H + -- d.I SCIL generation mode + -- d.J Disable parallel SCIL generation mode + -- d.K + -- d.L Depend on back end for limited types in conditional expressions + -- d.M + -- d.N + -- d.O Dump internal SCO tables + -- d.P + -- d.Q + -- d.R + -- d.S Force Optimize_Alignment (Space) + -- d.T Force Optimize_Alignment (Time) + -- d.U + -- d.V + -- d.W Print out debugging information for Walk_Library_Items + -- d.X Use Expression_With_Actions + -- d.Y Do not use Expression_With_Actions + -- d.Z + + -- d1 Error msgs have node numbers where possible + -- d2 Eliminate error flags in verbose form error messages + -- d3 Dump bad node in Comperr on an abort + -- d4 Inhibit automatic krunch of predefined library unit files + -- d5 Debug output for tree read/write + -- d6 Default access unconstrained to thin pointers + -- d7 Do not output version & file time stamp in -gnatv or -gnatl mode + -- d8 Force opposite endianness in packed stuff + -- d9 + + -- Debug flags for binder (GNATBIND) + + -- da All links (including internal units) listed if there is a cycle + -- db Output information from Better_Choice + -- dc List units as they are chosen + -- dd + -- de Elaboration dependencies including system units + -- df + -- dg + -- dh + -- di Ignore_Errors mode for reading ali files + -- dj + -- dk + -- dl + -- dm + -- dn List details of manipulation of Num_Pred values + -- do Use old preference for elaboration order + -- dp + -- dq + -- dr + -- ds + -- dt + -- du List units as they are acquired + -- dv + -- dw + -- dx Force binder to read xref information from ali files + -- dy + -- dz + + -- Debug flags used in package Make and its clients (e.g. GNATMAKE) + + -- da + -- db + -- dc + -- dd + -- de + -- df Only output file names, not path names, in log + -- dg + -- dh + -- di + -- dj + -- dk + -- dl + -- dm Display the number of maximum simultaneous compilations + -- dn Do not delete temp files created by gnatmake + -- do + -- dp Prints the contents of the Q used by Make.Compile_Sources + -- dq Prints source files as they are enqueued and dequeued + -- dr + -- ds + -- dt Display time stamps when there is a mismatch + -- du List units as their ali files are acquired + -- dv + -- dw Prints the list of units withed by the unit currently explored + -- dx + -- dy + -- dz + + -------------------------------------------- + -- Documentation for Compiler Debug Flags -- + -------------------------------------------- + + -- da Generate messages tracking semantic analyzer progress. A message + -- is output showing each node as it gets analyzed, expanded, + -- resolved, or evaluated. This option is useful for finding out + -- exactly where a bomb during semantic analysis is occurring. + + -- db In Exp_Dbug, certain type names are encoded to include debugging + -- information. This debug switch causes lines to be output showing + -- the encodings used. + + -- dc List names of units as they are compiled. One line of output will + -- be generated at the start of compiling each unit (package or + -- subprogram). + + -- dd Dynamic allocation of tables messages generated. Each time a + -- table is reallocated, a line is output indicating the expansion. + + -- de List the entity table + + -- df Full tree/source print (includes withed units). Normally the tree + -- output (dt) or recreated source output (dg,do,ds) includes only + -- the main unit. If df is set, then the output in either case + -- includes all compiled units (see also dg,do,ds,dt). Note that to + -- be effective, this swich must be used in combination with one or + -- more of dt, dg, do or ds. + + -- dg Print the source recreated from the generated tree. In the case + -- where the tree has been rewritten this output includes only the + -- generated code, not the original code (see also df,do,ds,dz). + -- This flag differs from -gnatG in that the output also includes + -- non-source generated null statements, and freeze nodes, which + -- are normally omitted in -gnatG mode. + + -- dh Generates a table at the end of a compilation showing how the hash + -- table chains built by the Namet package are loaded. This is useful + -- in ensuring that the hashing algorithm (in Namet.Hash) is working + -- effectively with typical sets of program identifiers. + + -- di Generate messages for visibility linking/delinking + + -- dj Suppress "junk null check" for access parameters. This flag permits + -- Ada programs to pass null parameters to access parameters, and to + -- explicitly check such access values against the null literal. + -- Neither of these is valid Ada, but both were allowed in versions of + -- GNAT before 3.10, so this switch can ease the transition process. + + -- dk Immediate kill on abort. Normally on an abort (i.e. a call to + -- Comperr.Compiler_Abort), the GNATBUG message is not given if + -- there is a previous error. This debug switch bypasses this test + -- and gives the message unconditionally (useful for debugging). + + -- dl Generate unit load trace messages. A line of traceback output is + -- generated each time a request is made to the library manager to + -- load a new unit. + + -- dm Some features are permitted only in OpenVMS ports of GNAT (e.g. + -- the specification of passing by descriptor). Normally any use + -- of these features will be flagged as an error, but this debug + -- flag allows acceptance of these features in non OpenVMS ports. + -- Of course they may not have any useful effect, and in particular + -- attempting to generate code with this flag set may blow up. + -- The flag also forces the use of 64-bits for Long_Integer. + + -- dn Generate messages for node/list allocation. Each time a node or + -- list header is allocated, a line of output is generated. Certain + -- other basic tree operations also cause a line of output to be + -- generated. This option is useful in seeing where the parser is + -- blowing up. + + -- do Print the source recreated from the generated tree. In the case + -- where the tree has been rewritten, this output includes only the + -- original code, not the generated code (see also df,dg,ds,dz). + + -- dp Generate messages for parser scope stack push/pops. A line of + -- output by the parser each time the parser scope stack is either + -- pushed or popped. Useful in debugging situations where the + -- parser scope stack ends up incorrectly synchronized + + -- dq In layout version 1.38, 2002/01/12, a circuit was implemented + -- to give decent default alignment to short records that had no + -- specific alignment set. This debug option restores the previous + -- behavior of giving such records poor alignments, typically 1. + -- This may be useful in dealing with transition. + + -- dr Generate parser resynchronization messages. Normally the parser + -- resynchronizes quietly. With this debug option, two messages + -- are generated, one when the parser starts a resynchronization + -- skip, and another when it resumes parsing. Useful in debugging + -- inadequate error recovery situations. + + -- ds Print the source recreated from the generated tree. In the case + -- where the tree has been rewritten this output includes both the + -- generated code and the original code with the generated code + -- being enlosed in curly brackets (see also df,do,ds,dz) + + -- dt Print full tree. The generated tree is output (see also df,dy) + + -- du Uncheck categorization pragmas. This debug switch causes the + -- categorization pragmas (Pure, Preelaborate etc) to be ignored + -- so that normal checks are not made (this is particularly useful + -- for adding temporary debugging code to units that have pragmas + -- that are inconsistent with the debugging code added. + + -- dv Output trace of overload resolution. Outputs messages for + -- overload attempts that involve cascaded errors, or where + -- an interepretation is incompatible with the context. + + -- dw Write semantic scope stack messages. Each time a scope is created + -- or removed, a message is output (see the Sem_Ch8.Push_Scope and + -- Sem_Ch8.Pop_Scope subprograms). + + -- dx Force expansion on, even if no code being generated. Normally the + -- expander is inhibited if no code is generated. This switch forces + -- expansion to proceed normally even if the backend is not being + -- called. This is particularly useful for debugging purposes when + -- using the front-end only version of the compiler (which normally + -- would never do any expansion). + + -- dy Print tree of package Standard. Normally the tree print out does + -- not include package Standard, even if the -df switch is set. This + -- switch forces output of the internal tree built for Standard. + + -- dz Print source of package Standard. Normally the source print out + -- does not include package Standard, even if the -df switch is set. + -- This switch forces output of the source recreated from the internal + -- tree built for Standard. Note that this differs from -gnatS in + -- that it prints from the actual tree using the normal Sprint + -- circuitry for printing trees. + + -- dA Forces output of representation information, including full + -- information for all internal type and object entities, as well + -- as all user defined type and object entities including private + -- and incomplete types. This debug switch also automatically sets + -- the equivalent of -gnatR3m. + + -- dB Output debug encodings for types and variants. See Exp_Dbug for + -- exact form of the generated output. + + -- dC Output trace information showing the decisions made during + -- check suppression activity in unit Checks. + + -- dD Delete new elaboration checks. This flag causes GNAT to return + -- to the 3.13a elaboration semantics, and to suppress the fixing + -- of two bugs. The first is in the context of inner routines in + -- dynamic elaboration mode, when the subprogram we are in was + -- called at elaboration time by a unit that was also compiled with + -- dynamic elaboration checks. In this case, if A calls B calls C, + -- and all are in different units, we need an elaboration check at + -- each call. These nested checks were only put in recently (see + -- version 1.80 of Sem_Elab) and we provide this debug flag to + -- revert to the previous behavior in case of regressions. The + -- other behavior reverted by this flag is the treatment of the + -- Elaborate_Body pragma in static elaboration mode. This used to + -- be treated as not needing elaboration checking, but in fact in + -- general Elaborate_All is still required because of nested calls. + + -- dE Apply compile time elaboration checking for with relations between + -- predefined units. Normally no checks are made (it seems that at + -- least on the SGI, such checks run into trouble). + + -- dF Front end data layout enabled. Normally front end data layout + -- is only enabled if the target parameter Backend_Layout is False. + -- This debugging switch enables it unconditionally. + + -- dG Generate all warnings. Normally Errout suppresses warnings on + -- units that are not part of the main extended source, and also + -- suppresses warnings on instantiations in the main extended + -- source that duplicate warnings already posted on the template. + -- This switch stops both kinds of deletion and causes Errout to + -- post all warnings sent to it. + + -- dH Inhibit call to gigi. This is useful for testing front end data + -- layout, and may be useful in other debugging situations where + -- you do not want gigi to intefere with the testing. + + -- dI Inhibit internal name numbering in gnatDG listing. Any sequence of + -- the form appearing in + -- a name is replaced by .... This + -- is used in the fixed bugs run to minimize system and version + -- dependency in filed -gnatD or -gnatG output. + + -- dJ Generate debugging trace output for the JGNAT back end. This + -- consists of symbolic Java Byte Code sequences for all generated + -- classes plus additional information to indicate local variables + -- and methods. + + -- dK Kill all error messages. This debug flag suppresses the output + -- of all error messages. It is used in regression tests where the + -- error messages are target dependent and irrelevant. + + -- dL Output trace information on elaboration checking. This debug + -- switch causes output to be generated showing each call or + -- instantiation as it is checked, and the progress of the recursive + -- trace through calls at elaboration time. + + -- dM Assume all variables have been modified, and ignore current value + -- indications. This debug flag disconnects the tracking of constant + -- values (see Exp_Ch2.Expand_Current_Value). + + -- dN Do not generate file name information in exception messages + + -- dO Output immediate error messages. This causes error messages to + -- be output as soon as they are generated (disconnecting several + -- circuits for improvement of messages, deletion of duplicate + -- messages etc). Useful to diagnose compiler bombs caused by + -- erroneous handling of error situations + + -- dP Do not check for controlled objects in preelaborable packages. + -- RM 10.2.1(9) forbids the use of library level controlled objects + -- in preelaborable packages, but this restriction is a huge pain, + -- especially in the predefined library units. + + -- dR Bypass the check for a proper version of s-rpc being present + -- to use the -gnatz? switch. This allows debugging of the use + -- of stubs generation without needing to have GLADE (or some + -- other PCS installed). + + -- dS Omit conversion of fpt numbers to exact machine numbers in + -- non-static evaluation contexts (see Check_Non_Static_Context). + -- This is intended for testing out timing problems with this + -- conversion circuit. + + -- dT Similar to dS, but omits the conversions only in the case where + -- the parent is not a constant declaration. + + -- dU Enable garbage collection of unreachable entities. This enables + -- both the reachability analysis and changing the Is_Public and + -- Is_Eliminated flags. + + -- dV Enable viewing of all symbols in debugger. Causes debug information + -- to be generated for all symbols, including internal symbols. This + -- is enabled by default for -gnatD, but this switch allows this to + -- be enabled without generating modified source files. Note that the + -- use of -gnatdV ensures in the dwarf/elf case that all symbols that + -- are present in the elf tables are also in the dwarf tables (which + -- seems to be required by some tools). Another effect of dV is to + -- generate full qualified names, including internal names generated + -- for blocks and loops. + + -- dW Disable warnings when a possibly uninitialized scalar value is + -- passed to an IN OUT parameter of a procedure. This usage is a + -- quite improper bounded error [erroneous in Ada 83] situation, + -- and would normally generate a warning. However, to ease the + -- task of transitioning incorrect legacy code, we provide this + -- undocumented feature for suppressing these warnings. + + -- dY Enable configurable run-time mode, just as though the System file + -- had Configurable_Run_Time_Mode set to True. This is useful in + -- testing high integrity mode. + + -- dZ Generate listing showing the contents of the dispatch tables. Each + -- line has an internally generated number used for references between + -- tagged types and primitives. For each primitive the output has the + -- following fields: + -- + -- - Letter 'P' or letter 's': The former indicates that this + -- primitive will be located in a primary dispatch table. The + -- latter indicates that it will be located in a secondary + -- dispatch table. + -- + -- - Name of the primitive. In case of predefined Ada primitives + -- the text "(predefined)" is added before the name, and these + -- acronyms are used: SR (Stream_Read), SW (Stream_Write), SI + -- (Stream_Input), SO (Stream_Output), DA (Deep_Adjust), DF + -- (Deep_Finalize). In addition Oeq identifies the equality + -- operator, and "_assign" the assignment. + -- + -- - If the primitive covers interface types, two extra fields + -- referencing other primitives are generated: "Alias" references + -- the primitive of the tagged type that covers an interface + -- primitive, and "AI_Alias" references the covered interface + -- primitive. + -- + -- - The expression "at #xx" indicates the slot of the dispatch + -- table occupied by such primitive in its corresponding primary + -- or secondary dispatch table. + -- + -- - In case of abstract subprograms the text "is abstract" is + -- added at the end of the line. + + -- d.a Force Target_Strict_Alignment to True, even on targets where it + -- would normally be false. Can be used for testing strict alignment + -- circuitry in the compiler. + + -- d.c Generate inline concatenation, instead of calling one of the + -- System.Concat_n.Str_Concat_n routines in cases where the latter + -- routines would normally be called. + + -- d.f Suppress folding of static expressions. This of course results + -- in seriously non-conforming behavior, but is useful sometimes + -- when tracking down handling of complex expressions. + + -- d.g Enables conversion of a raise statement into a goto when the + -- relevant handler is statically determinable. For now we only try + -- this if this debug flag is set. Later we will enable this more + -- generally by default. + + -- d.i Ignore all occurrences of pragma Warnings in the sources. This can + -- be used in particular to disable Warnings (Off) to check if any of + -- these statements are inappropriate. + + -- d.l Use Ada 95 semantics for limited function returns. This may be + -- used to work around the incompatibility introduced by AI-318-2. + -- It is useful only in -gnat05 mode. + + -- d.m When -gnatl is used, the normal output includes full listings of + -- all files in the extended main source (body/spec/subunits). If this + -- debug switch is used, then the full listing is given only for the + -- main source (this corresponds to a previous behavior of -gnatl and + -- is used for running the ACATS tests). + + -- d.n Print source file names as they are loaded. This is useful if the + -- compiler has a bug -- these are the files that need to be included + -- in a bug report. + + -- d.o Generate listing showing the IL instructions generated by the .NET + -- compiler for each subprogram. + + -- d.p Enable the .NET CIL verifier. During development the verifier is + -- disabled by default and this flag is used to enable it. In the + -- future we will reverse this functionality. + + -- d.r Forces the flag OK_To_Reorder_Components to be set in all record + -- base types that have no discriminants. + + -- d.s Normally the compiler expands slice moves into loops if overlap + -- might be possible. This debug flag inhibits that expansion, and + -- the back end is expected to use an appropriate routine to handle + -- overlap, based on Forward_OK and Backwards_OK flags. + + -- d.t The compiler has been modified (a fairly extensive modification) + -- to generate static dispatch tables for library level tagged types. + -- This debug switch disables this modification and reverts to the + -- previous dynamic construction of tables. It is there as a possible + -- work around if we run into trouble with the new implementation. + + -- d.v Forces the flag OK_To_Reorder_Components to be set in all record + -- base types that have at least one discriminant (v = variant). + + -- d.w This flag turns off the scanning of loops to detect possible + -- infinite loops. + + -- d.A There seems to be a problem with ASIS if we activate the circuit + -- for reading and writing the aspect specification hash table, so + -- for now, this is controlled by the debug flag d.A. The hash table + -- is only written and read if this flag is set. + + -- d.x No exception handlers in generated code. This causes exception + -- handlers to be eliminated from the generated code. They are still + -- fully compiled and analyzed, they just get eliminated from the + -- code generation step. + + -- d.C Generate call to System.Concat_n.Str_Concat_n routines in cases + -- where we would normally generate inline concatenation code. + + -- d.I Generate SCIL mode. Generate intermediate code for the sake of + -- of static analysis tools, and ensure additional tree consistency + -- between different compilations of specs. + + -- d.J Disable parallel SCIL generation. Normally SCIL file generation is + -- done in parallel to speed processing. This switch disables this + -- behavior. + + -- d.L Normally the front end generates special expansion for conditional + -- expressions of a limited type. This debug flag removes this special + -- case expansion, leaving it up to the back end to handle conditional + -- expressions correctly. + + -- d.O Dump internal SCO tables. Before outputting the SCO information to + -- the ALI file, the internal SCO tables (SCO_Table/SCO_Unit_Table) + -- are dumped for debugging purposes. + + -- d.S Force Optimize_Alignment (Space) mode as the default + + -- d.T Force Optimize_Alignment (Time) mode as the default + + -- d.W Print out debugging information for Walk_Library_Items, including + -- the order in which units are walked. This is primarily for use in + -- debugging CodePeer mode. + + -- d.X By default, the compiler uses an elaborate rewriting framework for + -- short-circuited forms where the right hand condition generates + -- actions to be inserted. With the gcc backend, we now use the new + -- N_Expression_With_Actions node for this expansion, but we still use + -- the old method for other backends and in SCIL mode. This debug flag + -- forces use of the new N_Expression_With_Actions node in these other + -- cases and is intended for transitional use. + + -- d.Y Prevents the use of the N_Expression_With_Actions node even in the + -- case of the gcc back end. Provided as a back up in case the new + -- scheme has problems. + + -- d1 Error messages have node numbers where possible. Normally error + -- messages have only source locations. This option is useful when + -- debugging errors caused by expanded code, where the source location + -- does not give enough information. + + -- d2 Suppress output of the error position flags for verbose form error + -- messages. The messages are still interspersed in the listing, but + -- without any error flags or extra blank lines. Also causes an extra + -- <<< to be output at the right margin. This is intended to be the + -- easiest format for checking conformance of ACATS B tests. This + -- flag also suppresses the additional messages explaining why a + -- non-static expression is non-static (see Sem_Eval.Why_Not_Static). + -- This avoids having to worry about these messages in ACATS testing. + + -- d3 Causes Comperr to dump the contents of the node for which an abort + -- was detected (normally only the Node_Id of the node is output). + + -- d4 Inhibits automatic krunching of predefined library unit file names. + -- Normally, as described in the spec of package Krunch, such files + -- are automatically krunched to 8 characters, with special treatment + -- of the prefixes Ada, System, and Interfaces. Setting this debug + -- switch disables this special treatment. + + -- d5 Causes the tree read/write circuit to output detailed information + -- tracking the data that is read and written element by element. + + -- d6 Normally access-to-unconstrained-array types are represented + -- using fat (double) pointers. Using this debug flag causes them + -- to default to thin. This can be used to test the performance + -- implications of using thin pointers, and also to test that the + -- compiler functions correctly with this choice. + + -- d7 Normally a -gnatl or -gnatv listing includes the time stamp + -- of the source file. This debug flag suppresses this output, + -- and also suppresses the message with the version number. + -- This is useful in certain regression tests. + + -- d8 This forces the packed stuff to generate code assuming the + -- opposite endianness from the actual correct value. Useful in + -- testing out code generation from the packed routines. + + ------------------------------------------ + -- Documentation for Binder Debug Flags -- + ------------------------------------------ + + -- da Normally if there is an elaboration circularity, then in describing + -- the cycle, links involving internal units are omitted, since they + -- are irrelevant and confusing. This debug flag causes all links to + -- be listed, and is useful when diagnosing circularities introduced + -- by incorrect changes to the run-time library itself. + + -- db Output debug information from Better_Choice in Binde, which uses + -- various heuristics to determine elaboration order in cases where + -- multiple orders are valid. + + -- dc List units as they are chosen. As units are selected for addition to + -- the elaboration order, a line of output is generated showing which + -- unit has been selected. + + -- de Similar to the effect of -e (output complete list of elaboration + -- dependencies) except that internal units are included in the + -- listing. + + -- di Normally gnatbind calls Read_Ali with Ignore_Errors set to + -- False, since the binder really needs correct version ALI + -- files to do its job. This debug flag causes Ignore_Errors + -- mode to be set for the binder (and is particularly useful + -- for testing ignore errors mode). + + -- dn List details of manipulation of Num_Pred values during execution of + -- the algorithm used to determine a correct order of elaboration. This + -- is useful in diagnosing any problems in its behavior. + + -- do Use old elaboration order preference. The new preference rules + -- prefer specs with no bodies to specs with bodies, and between two + -- specs with bodies, prefers the one whose body is closer to being + -- able to be elaborated. This is a clear improvement, but we provide + -- this debug flag in case of regressions. + + -- du List unit name and file name for each unit as it is read in + + -- dx Force the binder to read (and then ignore) the xref information + -- in ali files (used to check that read circuit is working OK). + + -------------------------------------------- + -- Documentation for gnatmake Debug Flags -- + -------------------------------------------- + + -- df Only output file names, not path names, in log + + -- dm Issue a message indicating the maximum number of simultaneous + -- compilations. + + -- dn Do not delete temporary files created by gnatmake at the end + -- of execution, such as temporary config pragma files, mapping + -- files or project path files. + + -- dp Prints the Q used by routine Make.Compile_Sources every time + -- we go around the main compile loop of Make.Compile_Sources + + -- dq Prints source files as they are enqueued and dequeued in the Q + -- used by routine Make.Compile_Sources. Useful to figure out the + -- order in which sources are recompiled. + + -- dt When a time stamp mismatch has been found for an ALI file, + -- display the source file name, the time stamp expected and + -- the time stamp found. + + -- du List unit name and file name for each unit as it is read in + + -- dw Prints the list of units withed by the unit currently explored + -- during the main loop of Make.Compile_Sources. + + --------------------------------------------- + -- Documentation for gprbuild Debug Flags -- + --------------------------------------------- + + -- dn Do not delete temporary files createed by gprbuild at the end + -- of execution, such as temporary config pragma files, mapping + -- files or project path files. + + -- dt When a time stamp mismatch has been found for an ALI file, + -- display the source file name, the time stamp expected and + -- the time stamp found. + + -------------------- + -- Set_Debug_Flag -- + -------------------- + + procedure Set_Debug_Flag (C : Character; Val : Boolean := True) is + subtype Dig is Character range '1' .. '9'; + subtype LLet is Character range 'a' .. 'z'; + subtype ULet is Character range 'A' .. 'Z'; + + begin + if C in Dig then + case Dig (C) is + when '1' => Debug_Flag_1 := Val; + when '2' => Debug_Flag_2 := Val; + when '3' => Debug_Flag_3 := Val; + when '4' => Debug_Flag_4 := Val; + when '5' => Debug_Flag_5 := Val; + when '6' => Debug_Flag_6 := Val; + when '7' => Debug_Flag_7 := Val; + when '8' => Debug_Flag_8 := Val; + when '9' => Debug_Flag_9 := Val; + end case; + + elsif C in ULet then + case ULet (C) is + when 'A' => Debug_Flag_AA := Val; + when 'B' => Debug_Flag_BB := Val; + when 'C' => Debug_Flag_CC := Val; + when 'D' => Debug_Flag_DD := Val; + when 'E' => Debug_Flag_EE := Val; + when 'F' => Debug_Flag_FF := Val; + when 'G' => Debug_Flag_GG := Val; + when 'H' => Debug_Flag_HH := Val; + when 'I' => Debug_Flag_II := Val; + when 'J' => Debug_Flag_JJ := Val; + when 'K' => Debug_Flag_KK := Val; + when 'L' => Debug_Flag_LL := Val; + when 'M' => Debug_Flag_MM := Val; + when 'N' => Debug_Flag_NN := Val; + when 'O' => Debug_Flag_OO := Val; + when 'P' => Debug_Flag_PP := Val; + when 'Q' => Debug_Flag_QQ := Val; + when 'R' => Debug_Flag_RR := Val; + when 'S' => Debug_Flag_SS := Val; + when 'T' => Debug_Flag_TT := Val; + when 'U' => Debug_Flag_UU := Val; + when 'V' => Debug_Flag_VV := Val; + when 'W' => Debug_Flag_WW := Val; + when 'X' => Debug_Flag_XX := Val; + when 'Y' => Debug_Flag_YY := Val; + when 'Z' => Debug_Flag_ZZ := Val; + end case; + + else + case LLet (C) is + when 'a' => Debug_Flag_A := Val; + when 'b' => Debug_Flag_B := Val; + when 'c' => Debug_Flag_C := Val; + when 'd' => Debug_Flag_D := Val; + when 'e' => Debug_Flag_E := Val; + when 'f' => Debug_Flag_F := Val; + when 'g' => Debug_Flag_G := Val; + when 'h' => Debug_Flag_H := Val; + when 'i' => Debug_Flag_I := Val; + when 'j' => Debug_Flag_J := Val; + when 'k' => Debug_Flag_K := Val; + when 'l' => Debug_Flag_L := Val; + when 'm' => Debug_Flag_M := Val; + when 'n' => Debug_Flag_N := Val; + when 'o' => Debug_Flag_O := Val; + when 'p' => Debug_Flag_P := Val; + when 'q' => Debug_Flag_Q := Val; + when 'r' => Debug_Flag_R := Val; + when 's' => Debug_Flag_S := Val; + when 't' => Debug_Flag_T := Val; + when 'u' => Debug_Flag_U := Val; + when 'v' => Debug_Flag_V := Val; + when 'w' => Debug_Flag_W := Val; + when 'x' => Debug_Flag_X := Val; + when 'y' => Debug_Flag_Y := Val; + when 'z' => Debug_Flag_Z := Val; + end case; + end if; + end Set_Debug_Flag; + + --------------------------- + -- Set_Dotted_Debug_Flag -- + --------------------------- + + procedure Set_Dotted_Debug_Flag (C : Character; Val : Boolean := True) is + subtype Dig is Character range '1' .. '9'; + subtype LLet is Character range 'a' .. 'z'; + subtype ULet is Character range 'A' .. 'Z'; + + begin + if C in Dig then + case Dig (C) is + when '1' => Debug_Flag_Dot_1 := Val; + when '2' => Debug_Flag_Dot_2 := Val; + when '3' => Debug_Flag_Dot_3 := Val; + when '4' => Debug_Flag_Dot_4 := Val; + when '5' => Debug_Flag_Dot_5 := Val; + when '6' => Debug_Flag_Dot_6 := Val; + when '7' => Debug_Flag_Dot_7 := Val; + when '8' => Debug_Flag_Dot_8 := Val; + when '9' => Debug_Flag_Dot_9 := Val; + end case; + + elsif C in ULet then + case ULet (C) is + when 'A' => Debug_Flag_Dot_AA := Val; + when 'B' => Debug_Flag_Dot_BB := Val; + when 'C' => Debug_Flag_Dot_CC := Val; + when 'D' => Debug_Flag_Dot_DD := Val; + when 'E' => Debug_Flag_Dot_EE := Val; + when 'F' => Debug_Flag_Dot_FF := Val; + when 'G' => Debug_Flag_Dot_GG := Val; + when 'H' => Debug_Flag_Dot_HH := Val; + when 'I' => Debug_Flag_Dot_II := Val; + when 'J' => Debug_Flag_Dot_JJ := Val; + when 'K' => Debug_Flag_Dot_KK := Val; + when 'L' => Debug_Flag_Dot_LL := Val; + when 'M' => Debug_Flag_Dot_MM := Val; + when 'N' => Debug_Flag_Dot_NN := Val; + when 'O' => Debug_Flag_Dot_OO := Val; + when 'P' => Debug_Flag_Dot_PP := Val; + when 'Q' => Debug_Flag_Dot_QQ := Val; + when 'R' => Debug_Flag_Dot_RR := Val; + when 'S' => Debug_Flag_Dot_SS := Val; + when 'T' => Debug_Flag_Dot_TT := Val; + when 'U' => Debug_Flag_Dot_UU := Val; + when 'V' => Debug_Flag_Dot_VV := Val; + when 'W' => Debug_Flag_Dot_WW := Val; + when 'X' => Debug_Flag_Dot_XX := Val; + when 'Y' => Debug_Flag_Dot_YY := Val; + when 'Z' => Debug_Flag_Dot_ZZ := Val; + end case; + + else + case LLet (C) is + when 'a' => Debug_Flag_Dot_A := Val; + when 'b' => Debug_Flag_Dot_B := Val; + when 'c' => Debug_Flag_Dot_C := Val; + when 'd' => Debug_Flag_Dot_D := Val; + when 'e' => Debug_Flag_Dot_E := Val; + when 'f' => Debug_Flag_Dot_F := Val; + when 'g' => Debug_Flag_Dot_G := Val; + when 'h' => Debug_Flag_Dot_H := Val; + when 'i' => Debug_Flag_Dot_I := Val; + when 'j' => Debug_Flag_Dot_J := Val; + when 'k' => Debug_Flag_Dot_K := Val; + when 'l' => Debug_Flag_Dot_L := Val; + when 'm' => Debug_Flag_Dot_M := Val; + when 'n' => Debug_Flag_Dot_N := Val; + when 'o' => Debug_Flag_Dot_O := Val; + when 'p' => Debug_Flag_Dot_P := Val; + when 'q' => Debug_Flag_Dot_Q := Val; + when 'r' => Debug_Flag_Dot_R := Val; + when 's' => Debug_Flag_Dot_S := Val; + when 't' => Debug_Flag_Dot_T := Val; + when 'u' => Debug_Flag_Dot_U := Val; + when 'v' => Debug_Flag_Dot_V := Val; + when 'w' => Debug_Flag_Dot_W := Val; + when 'x' => Debug_Flag_Dot_X := Val; + when 'y' => Debug_Flag_Dot_Y := Val; + when 'z' => Debug_Flag_Dot_Z := Val; + end case; + end if; + end Set_Dotted_Debug_Flag; + +end Debug; diff --git a/gcc/ada/debug.ads b/gcc/ada/debug.ads new file mode 100644 index 000000000..9ebaa52cf --- /dev/null +++ b/gcc/ada/debug.ads @@ -0,0 +1,188 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D E B U G -- +-- -- +-- 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 global flags used to control the inclusion +-- of debugging code in various phases of the compiler. Some of these +-- flags are also used by the binder and gnatmake. + +package Debug is + pragma Preelaborate; + + ------------------------- + -- Dynamic Debug Flags -- + ------------------------- + + -- Flags that can be used to active various specialized debugging output + -- information. The flags are preset to False, which corresponds to the + -- given output being suppressed. The individual flags can be turned on + -- using the undocumented switch dxxx where xxx is a string of letters for + -- flags to be turned on. Documentation on the current usage of these flags + -- is contained in the body of Debug rather than the spec, so that we don't + -- have to recompile the world when a new debug flag is added. + + Debug_Flag_A : Boolean := False; + Debug_Flag_B : Boolean := False; + Debug_Flag_C : Boolean := False; + Debug_Flag_D : Boolean := False; + Debug_Flag_E : Boolean := False; + Debug_Flag_F : Boolean := False; + Debug_Flag_G : Boolean := False; + Debug_Flag_H : Boolean := False; + Debug_Flag_I : Boolean := False; + Debug_Flag_J : Boolean := False; + Debug_Flag_K : Boolean := False; + Debug_Flag_L : Boolean := False; + Debug_Flag_M : Boolean := False; + Debug_Flag_N : Boolean := False; + Debug_Flag_O : Boolean := False; + Debug_Flag_P : Boolean := False; + Debug_Flag_Q : Boolean := False; + Debug_Flag_R : Boolean := False; + Debug_Flag_S : Boolean := False; + Debug_Flag_T : Boolean := False; + Debug_Flag_U : Boolean := False; + Debug_Flag_V : Boolean := False; + Debug_Flag_W : Boolean := False; + Debug_Flag_X : Boolean := False; + Debug_Flag_Y : Boolean := False; + Debug_Flag_Z : Boolean := False; + + Debug_Flag_AA : Boolean := False; + Debug_Flag_BB : Boolean := False; + Debug_Flag_CC : Boolean := False; + Debug_Flag_DD : Boolean := False; + Debug_Flag_EE : Boolean := False; + Debug_Flag_FF : Boolean := False; + Debug_Flag_GG : Boolean := False; + Debug_Flag_HH : Boolean := False; + Debug_Flag_II : Boolean := False; + Debug_Flag_JJ : Boolean := False; + Debug_Flag_KK : Boolean := False; + Debug_Flag_LL : Boolean := False; + Debug_Flag_MM : Boolean := False; + Debug_Flag_NN : Boolean := False; + Debug_Flag_OO : Boolean := False; + Debug_Flag_PP : Boolean := False; + Debug_Flag_QQ : Boolean := False; + Debug_Flag_RR : Boolean := False; + Debug_Flag_SS : Boolean := False; + Debug_Flag_TT : Boolean := False; + Debug_Flag_UU : Boolean := False; + Debug_Flag_VV : Boolean := False; + Debug_Flag_WW : Boolean := False; + Debug_Flag_XX : Boolean := False; + Debug_Flag_YY : Boolean := False; + Debug_Flag_ZZ : Boolean := False; + + Debug_Flag_1 : Boolean := False; + Debug_Flag_2 : Boolean := False; + Debug_Flag_3 : Boolean := False; + Debug_Flag_4 : Boolean := False; + Debug_Flag_5 : Boolean := False; + Debug_Flag_6 : Boolean := False; + Debug_Flag_7 : Boolean := False; + Debug_Flag_8 : Boolean := False; + Debug_Flag_9 : Boolean := False; + + Debug_Flag_Dot_A : Boolean := False; + Debug_Flag_Dot_B : Boolean := False; + Debug_Flag_Dot_C : Boolean := False; + Debug_Flag_Dot_D : Boolean := False; + Debug_Flag_Dot_E : Boolean := False; + Debug_Flag_Dot_F : Boolean := False; + Debug_Flag_Dot_G : Boolean := False; + Debug_Flag_Dot_H : Boolean := False; + Debug_Flag_Dot_I : Boolean := False; + Debug_Flag_Dot_J : Boolean := False; + Debug_Flag_Dot_K : Boolean := False; + Debug_Flag_Dot_L : Boolean := False; + Debug_Flag_Dot_M : Boolean := False; + Debug_Flag_Dot_N : Boolean := False; + Debug_Flag_Dot_O : Boolean := False; + Debug_Flag_Dot_P : Boolean := False; + Debug_Flag_Dot_Q : Boolean := False; + Debug_Flag_Dot_R : Boolean := False; + Debug_Flag_Dot_S : Boolean := False; + Debug_Flag_Dot_T : Boolean := False; + Debug_Flag_Dot_U : Boolean := False; + Debug_Flag_Dot_V : Boolean := False; + Debug_Flag_Dot_W : Boolean := False; + Debug_Flag_Dot_X : Boolean := False; + Debug_Flag_Dot_Y : Boolean := False; + Debug_Flag_Dot_Z : Boolean := False; + + Debug_Flag_Dot_AA : Boolean := False; + Debug_Flag_Dot_BB : Boolean := False; + Debug_Flag_Dot_CC : Boolean := False; + Debug_Flag_Dot_DD : Boolean := False; + Debug_Flag_Dot_EE : Boolean := False; + Debug_Flag_Dot_FF : Boolean := False; + Debug_Flag_Dot_GG : Boolean := False; + Debug_Flag_Dot_HH : Boolean := False; + Debug_Flag_Dot_II : Boolean := False; + Debug_Flag_Dot_JJ : Boolean := False; + Debug_Flag_Dot_KK : Boolean := False; + Debug_Flag_Dot_LL : Boolean := False; + Debug_Flag_Dot_MM : Boolean := False; + Debug_Flag_Dot_NN : Boolean := False; + Debug_Flag_Dot_OO : Boolean := False; + Debug_Flag_Dot_PP : Boolean := False; + Debug_Flag_Dot_QQ : Boolean := False; + Debug_Flag_Dot_RR : Boolean := False; + Debug_Flag_Dot_SS : Boolean := False; + Debug_Flag_Dot_TT : Boolean := False; + Debug_Flag_Dot_UU : Boolean := False; + Debug_Flag_Dot_VV : Boolean := False; + Debug_Flag_Dot_WW : Boolean := False; + Debug_Flag_Dot_XX : Boolean := False; + Debug_Flag_Dot_YY : Boolean := False; + Debug_Flag_Dot_ZZ : Boolean := False; + + Debug_Flag_Dot_1 : Boolean := False; + Debug_Flag_Dot_2 : Boolean := False; + Debug_Flag_Dot_3 : Boolean := False; + Debug_Flag_Dot_4 : Boolean := False; + Debug_Flag_Dot_5 : Boolean := False; + Debug_Flag_Dot_6 : Boolean := False; + Debug_Flag_Dot_7 : Boolean := False; + Debug_Flag_Dot_8 : Boolean := False; + Debug_Flag_Dot_9 : Boolean := False; + + procedure Set_Debug_Flag (C : Character; Val : Boolean := True); + -- Where C is 0-9, A-Z, or a-z, sets the corresponding debug flag to + -- the given value. In the checks off version of debug, the call to + -- Set_Debug_Flag is always a null operation. + + procedure Set_Dotted_Debug_Flag (C : Character; Val : Boolean := True); + -- Where C is 0-9, A-Z, or a-z, sets the corresponding dotted debug + -- flag (e.g. call with C = 'a' for the .a flag). + +end Debug; diff --git a/gcc/ada/debug_a.adb b/gcc/ada/debug_a.adb new file mode 100644 index 000000000..35b7f0025 --- /dev/null +++ b/gcc/ada/debug_a.adb @@ -0,0 +1,144 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D E B U G _ A -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Debug; use Debug; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Output; use Output; + +package body Debug_A is + + Debug_A_Depth : Natural := 0; + -- Output for the debug A flag is preceded by a sequence of vertical bar + -- characters corresponding to the recursion depth of the actions being + -- recorded (analysis, expansion, resolution and evaluation of nodes) + -- This variable records the depth. + + Max_Node_Ids : constant := 200; + -- Maximum number of Node_Id values that get stacked + + Node_Ids : array (1 .. Max_Node_Ids) of Node_Id; + -- A stack used to keep track of Node_Id values for setting the value of + -- Current_Error_Node correctly. Note that if we have more than 200 + -- recursion levels, we just don't reset the right value on exit, which + -- is not crucial, since this is only for debugging! + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Debug_Output_Astring; + -- Outputs Debug_A_Depth number of vertical bars, used to preface messages + + ------------------- + -- Debug_A_Entry -- + ------------------- + + procedure Debug_A_Entry (S : String; N : Node_Id) is + begin + -- Output debugging information if -gnatda flag set + + if Debug_Flag_A then + Debug_Output_Astring; + Write_Str (S); + Write_Str ("Node_Id = "); + Write_Int (Int (N)); + Write_Str (" "); + Write_Location (Sloc (N)); + Write_Str (" "); + Write_Str (Node_Kind'Image (Nkind (N))); + Write_Eol; + end if; + + -- Now push the new element + + Debug_A_Depth := Debug_A_Depth + 1; + + if Debug_A_Depth <= Max_Node_Ids then + Node_Ids (Debug_A_Depth) := N; + end if; + + -- Set Current_Error_Node only if the new node has a decent Sloc + -- value, since it is for the Sloc value that we set this anyway. + -- If we don't have a decent Sloc value, we leave it unchanged. + + if Sloc (N) > No_Location then + Current_Error_Node := N; + end if; + end Debug_A_Entry; + + ------------------ + -- Debug_A_Exit -- + ------------------ + + procedure Debug_A_Exit (S : String; N : Node_Id; Comment : String) is + begin + Debug_A_Depth := Debug_A_Depth - 1; + + -- We look down the stack to find something with a decent Sloc. (If + -- we find nothing, just leave it unchanged which is not so terrible) + + for J in reverse 1 .. Integer'Min (Max_Node_Ids, Debug_A_Depth) loop + if Sloc (Node_Ids (J)) > No_Location then + Current_Error_Node := Node_Ids (J); + exit; + end if; + end loop; + + -- Output debugging information if -gnatda flag set + + if Debug_Flag_A then + Debug_Output_Astring; + Write_Str (S); + Write_Str ("Node_Id = "); + Write_Int (Int (N)); + Write_Str (Comment); + Write_Eol; + end if; + end Debug_A_Exit; + + -------------------------- + -- Debug_Output_Astring -- + -------------------------- + + procedure Debug_Output_Astring is + Vbars : constant String := "|||||||||||||||||||||||||"; + -- Should be constant, removed because of GNAT 1.78 bug ??? + + begin + if Debug_A_Depth > Vbars'Length then + for I in Vbars'Length .. Debug_A_Depth loop + Write_Char ('|'); + end loop; + + Write_Str (Vbars); + + else + Write_Str (Vbars (1 .. Debug_A_Depth)); + end if; + end Debug_Output_Astring; + +end Debug_A; diff --git a/gcc/ada/debug_a.ads b/gcc/ada/debug_a.ads new file mode 100644 index 000000000..4b23d6901 --- /dev/null +++ b/gcc/ada/debug_a.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D E B U G _ A -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains data and subprograms to support the A debug switch +-- that is used to generate output showing what node is being analyzed, +-- resolved, evaluated, or expanded. + +with Types; use Types; + +package Debug_A is + + -- Note: the following subprograms are used in a stack like manner, with + -- an exit call matching each entry call. This means that they can keep + -- track of the current node being worked on, with the entry call setting + -- a new value, by pushing the Node_Id value on a stack, and the exit call + -- popping this value off. Atree.Current_Error_Node is set by both the + -- entry and exit routines to point to the current node so that an abort + -- message indicates the node involved as accurately as possible. + + procedure Debug_A_Entry (S : String; N : Node_Id); + pragma Inline (Debug_A_Entry); + -- Generates a message prefixed by a sequence of bars showing the nesting + -- depth (depth increases by 1 for a Debug_A_Entry call and is decreased + -- by the corresponding Debug_A_Exit call). Then the string is output + -- (analyzing, expanding etc), followed by the node number and its kind. + -- This output is generated only if the debug A flag is set. If the debug + -- A flag is not set, then no output is generated. This call also sets the + -- Node_Id value in Atree.Current_Error_Node in case a bomb occurs. This + -- is done unconditionally, whether or not the debug A flag is set. + + procedure Debug_A_Exit (S : String; N : Node_Id; Comment : String); + pragma Inline (Debug_A_Exit); + -- Generates the corresponding termination message. The message is preceded + -- by a sequence of bars, followed by the string S, the node number, and + -- a trailing comment (e.g. " (already evaluated)"). This output is + -- generated only if the debug A flag is set. If the debug A flag is not + -- set, then no output is generated. This call also resets the value in + -- Atree.Current_Error_Node to what it was before the corresponding call + -- to Debug_A_Entry. + +end Debug_A; diff --git a/gcc/ada/dec.ads b/gcc/ada/dec.ads new file mode 100644 index 000000000..3a4d95d83 --- /dev/null +++ b/gcc/ada/dec.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- D E C -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an AlphaVMS package, which is imported by every package in +-- DECLib and tested for in gnatbind, in order to add "-ldecgnat" to +-- the bind. It is also a convenient parent for all DEC IO child packages. + +package DEC is + pragma Pure; +end DEC; diff --git a/gcc/ada/directio.ads b/gcc/ada/directio.ads new file mode 100644 index 000000000..c09f77270 --- /dev/null +++ b/gcc/ada/directio.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- D I R E C T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2005; +-- Explicit setting of Ada 2005 mode is required here, since we want to with a +-- child unit (not possible in Ada 83 mode), and Direct_IO is not considered +-- to be an internal unit that is automatically compiled in Ada 2005 mode +-- (since a user is allowed to redeclare Direct_IO). + +with Ada.Direct_IO; + +generic package Direct_IO renames Ada.Direct_IO; diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb new file mode 100644 index 000000000..deb0093de --- /dev/null +++ b/gcc/ada/einfo.adb @@ -0,0 +1,8632 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E I N F O -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram ordering, not used for this unit + +with Atree; use Atree; +with Nlists; use Nlists; +with Output; use Output; +with Sinfo; use Sinfo; +with Stand; use Stand; + +package body Einfo is + + use Atree.Unchecked_Access; + -- This is one of the packages that is allowed direct untyped access to + -- the fields in a node, since it provides the next level abstraction + -- which incorporates appropriate checks. + + ---------------------------------------------- + -- Usage of Fields in Defining Entity Nodes -- + ---------------------------------------------- + + -- Four of these fields are defined in Sinfo, since they in are the base + -- part of the node. The access routines for these four fields and the + -- corresponding set procedures are defined in Sinfo. These fields are + -- present in all entities. Note that Homonym is also in the base part of + -- the node, but has access routines that are more properly part of Einfo, + -- which is why they are defined here. + + -- Chars Name1 + -- Next_Entity Node2 + -- Scope Node3 + -- Etype Node5 + + -- Remaining fields are present only in extended nodes (i.e. entities) + + -- The following fields are present in all entities + + -- Homonym Node4 + -- First_Rep_Item Node6 + -- Freeze_Node Node7 + + -- The usage of other fields (and the entity kinds to which it applies) + -- depends on the particular field (see Einfo spec for details). + + -- Associated_Node_For_Itype Node8 + -- Dependent_Instances Elist8 + -- Hiding_Loop_Variable Node8 + -- Mechanism Uint8 (but returns Mechanism_Type) + -- Normalized_First_Bit Uint8 + -- Postcondition_Proc Node8 + -- Return_Applies_To Node8 + -- First_Exit_Statement Node8 + + -- Class_Wide_Type Node9 + -- Current_Value Node9 + -- Renaming_Map Uint9 + + -- Direct_Primitive_Operations Elist10 + -- Discriminal_Link Node10 + -- Float_Rep Uint10 (but returns Float_Rep_Kind) + -- Handler_Records List10 + -- Normalized_Position_Max Uint10 + + -- Component_Bit_Offset Uint11 + -- Full_View Node11 + -- Entry_Component Node11 + -- Enumeration_Pos Uint11 + -- Generic_Homonym Node11 + -- Protected_Body_Subprogram Node11 + -- Block_Node Node11 + + -- Barrier_Function Node12 + -- Enumeration_Rep Uint12 + -- Esize Uint12 + -- Next_Inlined_Subprogram Node12 + + -- Corresponding_Equality Node13 + -- Component_Clause Node13 + -- Elaboration_Entity Node13 + -- Extra_Accessibility Node13 + -- RM_Size Uint13 + + -- Alignment Uint14 + -- First_Optional_Parameter Node14 + -- Normalized_Position Uint14 + -- Shadow_Entities List14 + + -- Discriminant_Number Uint15 + -- DT_Position Uint15 + -- DT_Entry_Count Uint15 + -- Entry_Bodies_Array Node15 + -- Entry_Parameters_Type Node15 + -- Extra_Formal Node15 + -- Lit_Indexes Node15 + -- Related_Instance Node15 + -- Scale_Value Uint15 + -- Storage_Size_Variable Node15 + -- String_Literal_Low_Bound Node15 + + -- Access_Disp_Table Elist16 + -- Cloned_Subtype Node16 + -- DTC_Entity Node16 + -- Entry_Formal Node16 + -- First_Private_Entity Node16 + -- Lit_Strings Node16 + -- String_Literal_Length Uint16 + -- Unset_Reference Node16 + + -- Actual_Subtype Node17 + -- Digits_Value Uint17 + -- Discriminal Node17 + -- First_Entity Node17 + -- First_Index Node17 + -- First_Literal Node17 + -- Master_Id Node17 + -- Modulus Uint17 + -- Non_Limited_View Node17 + -- Prival Node17 + + -- Alias Node18 + -- Corresponding_Concurrent_Type Node18 + -- Corresponding_Protected_Entry Node18 + -- Corresponding_Record_Type Node18 + -- Delta_Value Ureal18 + -- Enclosing_Scope Node18 + -- Equivalent_Type Node18 + -- Private_Dependents Elist18 + -- Renamed_Entity Node18 + -- Renamed_Object Node18 + + -- Body_Entity Node19 + -- Corresponding_Discriminant Node19 + -- Finalization_Chain_Entity Node19 + -- Parent_Subtype Node19 + -- Related_Array_Object Node19 + -- Size_Check_Code Node19 + -- Spec_Entity Node19 + -- Underlying_Full_View Node19 + + -- Component_Type Node20 + -- Default_Value Node20 + -- Directly_Designated_Type Node20 + -- Discriminant_Checking_Func Node20 + -- Discriminant_Default_Value Node20 + -- Last_Entity Node20 + -- Prival_Link Node20 + -- Register_Exception_Call Node20 + -- Scalar_Range Node20 + + -- Accept_Address Elist21 + -- Default_Expr_Function Node21 + -- Discriminant_Constraint Elist21 + -- Interface_Name Node21 + -- Original_Array_Type Node21 + -- Small_Value Ureal21 + + -- Associated_Storage_Pool Node22 + -- Component_Size Uint22 + -- Corresponding_Remote_Type Node22 + -- Enumeration_Rep_Expr Node22 + -- Exception_Code Uint22 + -- Original_Record_Component Node22 + -- Private_View Node22 + -- Protected_Formal Node22 + -- Scope_Depth_Value Uint22 + -- Shared_Var_Procs_Instance Node22 + + -- Associated_Final_Chain Node23 + -- CR_Discriminant Node23 + -- Entry_Cancel_Parameter Node23 + -- Enum_Pos_To_Rep Node23 + -- Extra_Constrained Node23 + -- Generic_Renamings Elist23 + -- Inner_Instances Elist23 + -- Limited_View Node23 + -- Packed_Array_Type Node23 + -- Protection_Object Node23 + -- Stored_Constraint Elist23 + + -- Related_Expression Node24 + -- Spec_PPC_List Node24 + + -- Interface_Alias Node25 + -- Interfaces Elist25 + -- Debug_Renaming_Link Node25 + -- DT_Offset_To_Top_Func Node25 + -- PPC_Wrapper Node25 + -- Static_Predicate List25 + -- Task_Body_Procedure Node25 + + -- Dispatch_Table_Wrappers Elist26 + -- Last_Assignment Node26 + -- Overridden_Operation Node26 + -- Package_Instantiation Node26 + -- Relative_Deadline_Variable Node26 + -- Static_Initialization Node26 + + -- Current_Use_Clause Node27 + -- Related_Type Node27 + -- Wrapped_Entity Node27 + + -- Extra_Formals Node28 + -- Underlying_Record_View Node28 + + -- Subprograms_For_Type Node29 + + --------------------------------------------- + -- Usage of Flags in Defining Entity Nodes -- + --------------------------------------------- + + -- All flags are unique, there is no overlaying, so each flag is physically + -- present in every entity. However, for many of the flags, it only makes + -- sense for them to be set true for certain subsets of entity kinds. See + -- the spec of Einfo for further details. + + -- Note: Flag1-Flag3 are absent from this list, for historical reasons + + -- Is_Frozen Flag4 + -- Has_Discriminants Flag5 + -- Is_Dispatching_Operation Flag6 + -- Is_Immediately_Visible Flag7 + -- In_Use Flag8 + -- Is_Potentially_Use_Visible Flag9 + -- Is_Public Flag10 + + -- Is_Inlined Flag11 + -- Is_Constrained Flag12 + -- Is_Generic_Type Flag13 + -- Depends_On_Private Flag14 + -- Is_Aliased Flag15 + -- Is_Volatile Flag16 + -- Is_Internal Flag17 + -- Has_Delayed_Freeze Flag18 + -- Is_Abstract_Subprogram Flag19 + -- Is_Concurrent_Record_Type Flag20 + + -- Has_Master_Entity Flag21 + -- Needs_No_Actuals Flag22 + -- Has_Storage_Size_Clause Flag23 + -- Is_Imported Flag24 + -- Is_Limited_Record Flag25 + -- Has_Completion Flag26 + -- Has_Pragma_Controlled Flag27 + -- Is_Statically_Allocated Flag28 + -- Has_Size_Clause Flag29 + -- Has_Task Flag30 + + -- Checks_May_Be_Suppressed Flag31 + -- Kill_Elaboration_Checks Flag32 + -- Kill_Range_Checks Flag33 + -- Kill_Tag_Checks Flag34 + -- Is_Class_Wide_Equivalent_Type Flag35 + -- Referenced_As_LHS Flag36 + -- Is_Known_Non_Null Flag37 + -- Can_Never_Be_Null Flag38 + -- Body_Needed_For_SAL Flag40 + + -- Treat_As_Volatile Flag41 + -- Is_Controlled Flag42 + -- Has_Controlled_Component Flag43 + -- Is_Pure Flag44 + -- In_Private_Part Flag45 + -- Has_Alignment_Clause Flag46 + -- Has_Exit Flag47 + -- In_Package_Body Flag48 + -- Reachable Flag49 + -- Delay_Subprogram_Descriptors Flag50 + + -- Is_Packed Flag51 + -- Is_Entry_Formal Flag52 + -- Is_Private_Descendant Flag53 + -- Return_Present Flag54 + -- Is_Tagged_Type Flag55 + -- Has_Homonym Flag56 + -- Is_Hidden Flag57 + -- Non_Binary_Modulus Flag58 + -- Is_Preelaborated Flag59 + -- Is_Shared_Passive Flag60 + + -- Is_Remote_Types Flag61 + -- Is_Remote_Call_Interface Flag62 + -- Is_Character_Type Flag63 + -- Is_Intrinsic_Subprogram Flag64 + -- Has_Record_Rep_Clause Flag65 + -- Has_Enumeration_Rep_Clause Flag66 + -- Has_Small_Clause Flag67 + -- Has_Component_Size_Clause Flag68 + -- Is_Access_Constant Flag69 + -- Is_First_Subtype Flag70 + + -- Has_Completion_In_Body Flag71 + -- Has_Unknown_Discriminants Flag72 + -- Is_Child_Unit Flag73 + -- Is_CPP_Class Flag74 + -- Has_Non_Standard_Rep Flag75 + -- Is_Constructor Flag76 + -- Static_Elaboration_Desired Flag77 + -- Is_Tag Flag78 + -- Has_All_Calls_Remote Flag79 + -- Is_Constr_Subt_For_U_Nominal Flag80 + + -- Is_Asynchronous Flag81 + -- Has_Gigi_Rep_Item Flag82 + -- Has_Machine_Radix_Clause Flag83 + -- Machine_Radix_10 Flag84 + -- Is_Atomic Flag85 + -- Has_Atomic_Components Flag86 + -- Has_Volatile_Components Flag87 + -- Discard_Names Flag88 + -- Is_Interrupt_Handler Flag89 + -- Returns_By_Ref Flag90 + + -- Is_Itype Flag91 + -- Size_Known_At_Compile_Time Flag92 + -- Has_Subprogram_Descriptor Flag93 + -- Is_Generic_Actual_Type Flag94 + -- Uses_Sec_Stack Flag95 + -- Warnings_Off Flag96 + -- Is_Controlling_Formal Flag97 + -- Has_Controlling_Result Flag98 + -- Is_Exported Flag99 + -- Has_Specified_Layout Flag100 + + -- Has_Nested_Block_With_Handler Flag101 + -- Is_Called Flag102 + -- Is_Completely_Hidden Flag103 + -- Address_Taken Flag104 + -- Suppress_Init_Proc Flag105 + -- Is_Limited_Composite Flag106 + -- Is_Private_Composite Flag107 + -- Default_Expressions_Processed Flag108 + -- Is_Non_Static_Subtype Flag109 + -- Has_External_Tag_Rep_Clause Flag110 + + -- Is_Formal_Subprogram Flag111 + -- Is_Renaming_Of_Object Flag112 + -- No_Return Flag113 + -- Delay_Cleanups Flag114 + -- Never_Set_In_Source Flag115 + -- Is_Visible_Child_Unit Flag116 + -- Is_Unchecked_Union Flag117 + -- Is_For_Access_Subtype Flag118 + -- Has_Convention_Pragma Flag119 + -- Has_Primitive_Operations Flag120 + + -- Has_Pragma_Pack Flag121 + -- Is_Bit_Packed_Array Flag122 + -- Has_Unchecked_Union Flag123 + -- Is_Eliminated Flag124 + -- C_Pass_By_Copy Flag125 + -- Is_Instantiated Flag126 + -- Is_Valued_Procedure Flag127 + -- (used for Component_Alignment) Flag128 + -- (used for Component_Alignment) Flag129 + -- Is_Generic_Instance Flag130 + + -- No_Pool_Assigned Flag131 + -- Is_AST_Entry Flag132 + -- Is_VMS_Exception Flag133 + -- Is_Optional_Parameter Flag134 + -- Has_Aliased_Components Flag135 + -- No_Strict_Aliasing Flag136 + -- Is_Machine_Code_Subprogram Flag137 + -- Is_Packed_Array_Type Flag138 + -- Has_Biased_Representation Flag139 + -- Has_Complex_Representation Flag140 + + -- Is_Constr_Subt_For_UN_Aliased Flag141 + -- Has_Missing_Return Flag142 + -- Has_Recursive_Call Flag143 + -- Is_Unsigned_Type Flag144 + -- Strict_Alignment Flag145 + -- Is_Abstract_Type Flag146 + -- Needs_Debug_Info Flag147 + -- Suppress_Elaboration_Warnings Flag148 + -- Is_Compilation_Unit Flag149 + -- Has_Pragma_Elaborate_Body Flag150 + + -- Entry_Accepted Flag152 + -- Is_Obsolescent Flag153 + -- Has_Per_Object_Constraint Flag154 + -- Has_Private_Declaration Flag155 + -- Referenced Flag156 + -- Has_Pragma_Inline Flag157 + -- Finalize_Storage_Only Flag158 + -- From_With_Type Flag159 + -- Is_Package_Body_Entity Flag160 + + -- Has_Qualified_Name Flag161 + -- Nonzero_Is_True Flag162 + -- Is_True_Constant Flag163 + -- Reverse_Bit_Order Flag164 + -- Suppress_Style_Checks Flag165 + -- Debug_Info_Off Flag166 + -- Sec_Stack_Needed_For_Return Flag167 + -- Materialize_Entity Flag168 + -- Has_Pragma_Thread_Local_Storage Flag169 + -- Is_Known_Valid Flag170 + + -- Is_Hidden_Open_Scope Flag171 + -- Has_Object_Size_Clause Flag172 + -- Has_Fully_Qualified_Name Flag173 + -- Elaboration_Entity_Required Flag174 + -- Has_Forward_Instantiation Flag175 + -- Is_Discrim_SO_Function Flag176 + -- Size_Depends_On_Discriminant Flag177 + -- Is_Null_Init_Proc Flag178 + -- Has_Pragma_Pure_Function Flag179 + -- Has_Pragma_Unreferenced Flag180 + + -- Has_Contiguous_Rep Flag181 + -- Has_Xref_Entry Flag182 + -- Must_Be_On_Byte_Boundary Flag183 + -- Has_Stream_Size_Clause Flag184 + -- Is_Ada_2005_Only Flag185 + -- Is_Interface Flag186 + -- Has_Constrained_Partial_View Flag187 + -- Has_Persistent_BSS Flag188 + -- Is_Pure_Unit_Access_Type Flag189 + -- Has_Specified_Stream_Input Flag190 + + -- Has_Specified_Stream_Output Flag191 + -- Has_Specified_Stream_Read Flag192 + -- Has_Specified_Stream_Write Flag193 + -- Is_Local_Anonymous_Access Flag194 + -- Is_Primitive_Wrapper Flag195 + -- Was_Hidden Flag196 + -- Is_Limited_Interface Flag197 + -- Has_Pragma_Ordered Flag198 + -- Is_Ada_2012_Only Flag199 + + -- Has_Delayed_Aspects Flag200 + -- Has_Anon_Block_Suffix Flag201 + -- Itype_Printed Flag202 + -- Has_Pragma_Pure Flag203 + -- Is_Known_Null Flag204 + -- Low_Bound_Tested Flag205 + -- Is_Visible_Formal Flag206 + -- Known_To_Have_Preelab_Init Flag207 + -- Must_Have_Preelab_Init Flag208 + -- Is_Return_Object Flag209 + -- Elaborate_Body_Desirable Flag210 + + -- Has_Static_Discriminants Flag211 + -- Has_Pragma_Unreferenced_Objects Flag212 + -- Requires_Overriding Flag213 + -- Has_RACW Flag214 + -- Has_Up_Level_Access Flag215 + -- Universal_Aliasing Flag216 + -- Suppress_Value_Tracking_On_Call Flag217 + -- Is_Primitive Flag218 + -- Has_Initial_Value Flag219 + -- Has_Dispatch_Table Flag220 + + -- Has_Pragma_Preelab_Init Flag221 + -- Used_As_Generic_Actual Flag222 + -- Is_Descendent_Of_Address Flag223 + -- Is_Raised Flag224 + -- Is_Thunk Flag225 + -- Is_Only_Out_Parameter Flag226 + -- Referenced_As_Out_Parameter Flag227 + -- Has_Thunks Flag228 + -- Can_Use_Internal_Rep Flag229 + -- Has_Pragma_Inline_Always Flag230 + + -- Renamed_In_Spec Flag231 + -- Has_Invariants Flag232 + -- Has_Pragma_Unmodified Flag233 + -- Is_Dispatch_Table_Entity Flag234 + -- Is_Trivial_Subprogram Flag235 + -- Warnings_Off_Used Flag236 + -- Warnings_Off_Used_Unmodified Flag237 + -- Warnings_Off_Used_Unreferenced Flag238 + -- OK_To_Reorder_Components Flag239 + -- Has_Postconditions Flag240 + + -- Optimize_Alignment_Space Flag241 + -- Optimize_Alignment_Time Flag242 + -- Overlays_Constant Flag243 + -- Is_RACW_Stub_Type Flag244 + -- Is_Private_Primitive Flag245 + -- Is_Underlying_Record_View Flag246 + -- OK_To_Rename Flag247 + -- Has_Inheritable_Invariants Flag248 + -- Has_Predicates Flag250 + + -- (unused) Flag39 + -- (unused) Flag151 + -- (unused) Flag249 + -- (unused) Flag251 + -- (unused) Flag252 + -- (unused) Flag253 + -- (unused) Flag254 + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Rep_Clause (Id : E; Rep_Name : Name_Id) return N; + -- Returns the attribute definition clause for Id whose name is Rep_Name. + -- Returns Empty if no matching attribute definition clause found for Id. + + --------------- + -- Float_Rep -- + --------------- + + function Float_Rep (Id : E) return F is + pragma Assert (Is_Floating_Point_Type (Id)); + begin + return F'Val (UI_To_Int (Uint10 (Base_Type (Id)))); + end Float_Rep; + + ---------------- + -- Rep_Clause -- + ---------------- + + function Rep_Clause (Id : E; Rep_Name : Name_Id) return N is + Ritem : Node_Id; + + begin + Ritem := First_Rep_Item (Id); + while Present (Ritem) loop + if Nkind (Ritem) = N_Attribute_Definition_Clause + and then Chars (Ritem) = Rep_Name + then + return Ritem; + else + Next_Rep_Item (Ritem); + end if; + end loop; + + return Empty; + end Rep_Clause; + + -------------------------------- + -- Attribute Access Functions -- + -------------------------------- + + function Accept_Address (Id : E) return L is + begin + return Elist21 (Id); + end Accept_Address; + + function Access_Disp_Table (Id : E) return L is + begin + pragma Assert (Is_Tagged_Type (Id)); + return Elist16 (Implementation_Base_Type (Id)); + end Access_Disp_Table; + + function Actual_Subtype (Id : E) return E is + begin + pragma Assert + (Ekind_In (Id, E_Constant, E_Variable, E_Generic_In_Out_Parameter) + or else Is_Formal (Id)); + return Node17 (Id); + end Actual_Subtype; + + function Address_Taken (Id : E) return B is + begin + return Flag104 (Id); + end Address_Taken; + + function Alias (Id : E) return E is + begin + pragma Assert + (Is_Overloadable (Id) or else Ekind (Id) = E_Subprogram_Type); + return Node18 (Id); + end Alias; + + function Alignment (Id : E) return U is + begin + pragma Assert (Is_Type (Id) + or else Is_Formal (Id) + or else Ekind_In (Id, E_Loop_Parameter, + E_Constant, + E_Exception, + E_Variable)); + return Uint14 (Id); + end Alignment; + + function Associated_Final_Chain (Id : E) return E is + begin + pragma Assert (Is_Access_Type (Id)); + return Node23 (Id); + end Associated_Final_Chain; + + function Associated_Formal_Package (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Package); + return Node12 (Id); + end Associated_Formal_Package; + + function Associated_Node_For_Itype (Id : E) return N is + begin + return Node8 (Id); + end Associated_Node_For_Itype; + + function Associated_Storage_Pool (Id : E) return E is + begin + pragma Assert (Is_Access_Type (Id)); + return Node22 (Root_Type (Id)); + end Associated_Storage_Pool; + + function Barrier_Function (Id : E) return N is + begin + pragma Assert (Is_Entry (Id)); + return Node12 (Id); + end Barrier_Function; + + function Block_Node (Id : E) return N is + begin + pragma Assert (Ekind (Id) = E_Block); + return Node11 (Id); + end Block_Node; + + function Body_Entity (Id : E) return E is + begin + pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)); + return Node19 (Id); + end Body_Entity; + + function Body_Needed_For_SAL (Id : E) return B is + begin + pragma Assert + (Ekind (Id) = E_Package + or else Is_Subprogram (Id) + or else Is_Generic_Unit (Id)); + return Flag40 (Id); + end Body_Needed_For_SAL; + + function C_Pass_By_Copy (Id : E) return B is + begin + pragma Assert (Is_Record_Type (Id)); + return Flag125 (Implementation_Base_Type (Id)); + end C_Pass_By_Copy; + + function Can_Never_Be_Null (Id : E) return B is + begin + return Flag38 (Id); + end Can_Never_Be_Null; + + function Checks_May_Be_Suppressed (Id : E) return B is + begin + return Flag31 (Id); + end Checks_May_Be_Suppressed; + + function Class_Wide_Type (Id : E) return E is + begin + pragma Assert (Is_Type (Id)); + return Node9 (Id); + end Class_Wide_Type; + + function Cloned_Subtype (Id : E) return E is + begin + pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Class_Wide_Subtype)); + return Node16 (Id); + end Cloned_Subtype; + + function Component_Bit_Offset (Id : E) return U is + begin + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + return Uint11 (Id); + end Component_Bit_Offset; + + function Component_Clause (Id : E) return N is + begin + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + return Node13 (Id); + end Component_Clause; + + function Component_Size (Id : E) return U is + begin + pragma Assert (Is_Array_Type (Id)); + return Uint22 (Implementation_Base_Type (Id)); + end Component_Size; + + function Component_Type (Id : E) return E is + begin + pragma Assert (Is_Array_Type (Id) or else Is_String_Type (Id)); + return Node20 (Implementation_Base_Type (Id)); + end Component_Type; + + function Corresponding_Concurrent_Type (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Record_Type); + return Node18 (Id); + end Corresponding_Concurrent_Type; + + function Corresponding_Discriminant (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Discriminant); + return Node19 (Id); + end Corresponding_Discriminant; + + function Corresponding_Equality (Id : E) return E is + begin + pragma Assert + (Ekind (Id) = E_Function + and then not Comes_From_Source (Id) + and then Chars (Id) = Name_Op_Ne); + return Node13 (Id); + end Corresponding_Equality; + + function Corresponding_Protected_Entry (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Subprogram_Body); + return Node18 (Id); + end Corresponding_Protected_Entry; + + function Corresponding_Record_Type (Id : E) return E is + begin + pragma Assert (Is_Concurrent_Type (Id)); + return Node18 (Id); + end Corresponding_Record_Type; + + function Corresponding_Remote_Type (Id : E) return E is + begin + return Node22 (Id); + end Corresponding_Remote_Type; + + function Current_Use_Clause (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Package or else Is_Type (Id)); + return Node27 (Id); + end Current_Use_Clause; + + function Current_Value (Id : E) return N is + begin + pragma Assert (Ekind (Id) in Object_Kind); + return Node9 (Id); + end Current_Value; + + function CR_Discriminant (Id : E) return E is + begin + return Node23 (Id); + end CR_Discriminant; + + function Debug_Info_Off (Id : E) return B is + begin + return Flag166 (Id); + end Debug_Info_Off; + + function Debug_Renaming_Link (Id : E) return E is + begin + return Node25 (Id); + end Debug_Renaming_Link; + + function Default_Expr_Function (Id : E) return E is + begin + pragma Assert (Is_Formal (Id)); + return Node21 (Id); + end Default_Expr_Function; + + function Default_Expressions_Processed (Id : E) return B is + begin + return Flag108 (Id); + end Default_Expressions_Processed; + + function Default_Value (Id : E) return N is + begin + pragma Assert (Is_Formal (Id)); + return Node20 (Id); + end Default_Value; + + function Delay_Cleanups (Id : E) return B is + begin + return Flag114 (Id); + end Delay_Cleanups; + + function Delay_Subprogram_Descriptors (Id : E) return B is + begin + return Flag50 (Id); + end Delay_Subprogram_Descriptors; + + function Delta_Value (Id : E) return R is + begin + pragma Assert (Is_Fixed_Point_Type (Id)); + return Ureal18 (Id); + end Delta_Value; + + function Dependent_Instances (Id : E) return L is + begin + pragma Assert (Is_Generic_Instance (Id)); + return Elist8 (Id); + end Dependent_Instances; + + function Depends_On_Private (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag14 (Id); + end Depends_On_Private; + + function Digits_Value (Id : E) return U is + begin + pragma Assert + (Is_Floating_Point_Type (Id) + or else Is_Decimal_Fixed_Point_Type (Id)); + return Uint17 (Id); + end Digits_Value; + + function Direct_Primitive_Operations (Id : E) return L is + begin + pragma Assert (Is_Tagged_Type (Id)); + return Elist10 (Id); + end Direct_Primitive_Operations; + + function Directly_Designated_Type (Id : E) return E is + begin + pragma Assert (Is_Access_Type (Id)); + return Node20 (Id); + end Directly_Designated_Type; + + function Discard_Names (Id : E) return B is + begin + return Flag88 (Id); + end Discard_Names; + + function Discriminal (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Discriminant); + return Node17 (Id); + end Discriminal; + + function Discriminal_Link (Id : E) return N is + begin + return Node10 (Id); + end Discriminal_Link; + + function Discriminant_Checking_Func (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Component); + return Node20 (Id); + end Discriminant_Checking_Func; + + function Discriminant_Constraint (Id : E) return L is + begin + pragma Assert (Is_Composite_Type (Id) and then Has_Discriminants (Id)); + return Elist21 (Id); + end Discriminant_Constraint; + + function Discriminant_Default_Value (Id : E) return N is + begin + pragma Assert (Ekind (Id) = E_Discriminant); + return Node20 (Id); + end Discriminant_Default_Value; + + function Discriminant_Number (Id : E) return U is + begin + pragma Assert (Ekind (Id) = E_Discriminant); + return Uint15 (Id); + end Discriminant_Number; + + function Dispatch_Table_Wrappers (Id : E) return L is + begin + pragma Assert (Is_Tagged_Type (Id)); + return Elist26 (Implementation_Base_Type (Id)); + end Dispatch_Table_Wrappers; + + function DT_Entry_Count (Id : E) return U is + begin + pragma Assert (Ekind (Id) = E_Component and then Is_Tag (Id)); + return Uint15 (Id); + end DT_Entry_Count; + + function DT_Offset_To_Top_Func (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Component and then Is_Tag (Id)); + return Node25 (Id); + end DT_Offset_To_Top_Func; + + function DT_Position (Id : E) return U is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Procedure) + and then Present (DTC_Entity (Id))); + return Uint15 (Id); + end DT_Position; + + function DTC_Entity (Id : E) return E is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + return Node16 (Id); + end DTC_Entity; + + function Elaborate_Body_Desirable (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Package); + return Flag210 (Id); + end Elaborate_Body_Desirable; + + function Elaboration_Entity (Id : E) return E is + begin + pragma Assert + (Is_Subprogram (Id) + or else + Ekind (Id) = E_Package + or else + Is_Generic_Unit (Id)); + return Node13 (Id); + end Elaboration_Entity; + + function Elaboration_Entity_Required (Id : E) return B is + begin + pragma Assert + (Is_Subprogram (Id) + or else + Ekind (Id) = E_Package + or else + Is_Generic_Unit (Id)); + return Flag174 (Id); + end Elaboration_Entity_Required; + + function Enclosing_Scope (Id : E) return E is + begin + return Node18 (Id); + end Enclosing_Scope; + + function Entry_Accepted (Id : E) return B is + begin + pragma Assert (Is_Entry (Id)); + return Flag152 (Id); + end Entry_Accepted; + + function Entry_Bodies_Array (Id : E) return E is + begin + return Node15 (Id); + end Entry_Bodies_Array; + + function Entry_Cancel_Parameter (Id : E) return E is + begin + return Node23 (Id); + end Entry_Cancel_Parameter; + + function Entry_Component (Id : E) return E is + begin + return Node11 (Id); + end Entry_Component; + + function Entry_Formal (Id : E) return E is + begin + return Node16 (Id); + end Entry_Formal; + + function Entry_Index_Constant (Id : E) return N is + begin + pragma Assert (Ekind (Id) = E_Entry_Index_Parameter); + return Node18 (Id); + end Entry_Index_Constant; + + function Entry_Parameters_Type (Id : E) return E is + begin + return Node15 (Id); + end Entry_Parameters_Type; + + function Enum_Pos_To_Rep (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Enumeration_Type); + return Node23 (Id); + end Enum_Pos_To_Rep; + + function Enumeration_Pos (Id : E) return Uint is + begin + pragma Assert (Ekind (Id) = E_Enumeration_Literal); + return Uint11 (Id); + end Enumeration_Pos; + + function Enumeration_Rep (Id : E) return U is + begin + pragma Assert (Ekind (Id) = E_Enumeration_Literal); + return Uint12 (Id); + end Enumeration_Rep; + + function Enumeration_Rep_Expr (Id : E) return N is + begin + pragma Assert (Ekind (Id) = E_Enumeration_Literal); + return Node22 (Id); + end Enumeration_Rep_Expr; + + function Equivalent_Type (Id : E) return E is + begin + pragma Assert + (Ekind_In (Id, E_Class_Wide_Type, + E_Class_Wide_Subtype, + E_Access_Protected_Subprogram_Type, + E_Anonymous_Access_Protected_Subprogram_Type, + E_Access_Subprogram_Type, + E_Exception_Type)); + return Node18 (Id); + end Equivalent_Type; + + function Esize (Id : E) return Uint is + begin + return Uint12 (Id); + end Esize; + + function Exception_Code (Id : E) return Uint is + begin + pragma Assert (Ekind (Id) = E_Exception); + return Uint22 (Id); + end Exception_Code; + + function Extra_Accessibility (Id : E) return E is + begin + pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable); + return Node13 (Id); + end Extra_Accessibility; + + function Extra_Constrained (Id : E) return E is + begin + pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable); + return Node23 (Id); + end Extra_Constrained; + + function Extra_Formal (Id : E) return E is + begin + return Node15 (Id); + end Extra_Formal; + + function Extra_Formals (Id : E) return E is + begin + pragma Assert + (Is_Overloadable (Id) + or else Ekind_In (Id, E_Entry_Family, + E_Subprogram_Body, + E_Subprogram_Type)); + return Node28 (Id); + end Extra_Formals; + + function Can_Use_Internal_Rep (Id : E) return B is + begin + pragma Assert (Is_Access_Subprogram_Type (Base_Type (Id))); + return Flag229 (Base_Type (Id)); + end Can_Use_Internal_Rep; + + function Finalization_Chain_Entity (Id : E) return E is + begin + return Node19 (Id); + end Finalization_Chain_Entity; + + function Finalize_Storage_Only (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag158 (Base_Type (Id)); + end Finalize_Storage_Only; + + function First_Entity (Id : E) return E is + begin + return Node17 (Id); + end First_Entity; + + function First_Exit_Statement (Id : E) return N is + begin + pragma Assert (Ekind (Id) = E_Loop); + return Node8 (Id); + end First_Exit_Statement; + + function First_Index (Id : E) return N is + begin + pragma Assert (Is_Array_Type (Id) or else Is_String_Type (Id)); + return Node17 (Id); + end First_Index; + + function First_Literal (Id : E) return E is + begin + pragma Assert (Is_Enumeration_Type (Id)); + return Node17 (Id); + end First_Literal; + + function First_Optional_Parameter (Id : E) return E is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + return Node14 (Id); + end First_Optional_Parameter; + + function First_Private_Entity (Id : E) return E is + begin + pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package) + or else Ekind (Id) in Concurrent_Kind); + return Node16 (Id); + end First_Private_Entity; + + function First_Rep_Item (Id : E) return E is + begin + return Node6 (Id); + end First_Rep_Item; + + function Freeze_Node (Id : E) return N is + begin + return Node7 (Id); + end Freeze_Node; + + function From_With_Type (Id : E) return B is + begin + return Flag159 (Id); + end From_With_Type; + + function Full_View (Id : E) return E is + begin + pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Constant); + return Node11 (Id); + end Full_View; + + function Generic_Homonym (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Generic_Package); + return Node11 (Id); + end Generic_Homonym; + + function Generic_Renamings (Id : E) return L is + begin + return Elist23 (Id); + end Generic_Renamings; + + function Handler_Records (Id : E) return S is + begin + return List10 (Id); + end Handler_Records; + + function Has_Aliased_Components (Id : E) return B is + begin + return Flag135 (Implementation_Base_Type (Id)); + end Has_Aliased_Components; + + function Has_Alignment_Clause (Id : E) return B is + begin + return Flag46 (Id); + end Has_Alignment_Clause; + + function Has_All_Calls_Remote (Id : E) return B is + begin + return Flag79 (Id); + end Has_All_Calls_Remote; + + function Has_Anon_Block_Suffix (Id : E) return B is + begin + return Flag201 (Id); + end Has_Anon_Block_Suffix; + + function Has_Atomic_Components (Id : E) return B is + begin + return Flag86 (Implementation_Base_Type (Id)); + end Has_Atomic_Components; + + function Has_Biased_Representation (Id : E) return B is + begin + return Flag139 (Id); + end Has_Biased_Representation; + + function Has_Completion (Id : E) return B is + begin + return Flag26 (Id); + end Has_Completion; + + function Has_Completion_In_Body (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag71 (Id); + end Has_Completion_In_Body; + + function Has_Complex_Representation (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag140 (Implementation_Base_Type (Id)); + end Has_Complex_Representation; + + function Has_Component_Size_Clause (Id : E) return B is + begin + pragma Assert (Is_Array_Type (Id)); + return Flag68 (Implementation_Base_Type (Id)); + end Has_Component_Size_Clause; + + function Has_Constrained_Partial_View (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag187 (Id); + end Has_Constrained_Partial_View; + + function Has_Controlled_Component (Id : E) return B is + begin + return Flag43 (Base_Type (Id)); + end Has_Controlled_Component; + + function Has_Contiguous_Rep (Id : E) return B is + begin + return Flag181 (Id); + end Has_Contiguous_Rep; + + function Has_Controlling_Result (Id : E) return B is + begin + return Flag98 (Id); + end Has_Controlling_Result; + + function Has_Convention_Pragma (Id : E) return B is + begin + return Flag119 (Id); + end Has_Convention_Pragma; + + function Has_Delayed_Aspects (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag200 (Id); + end Has_Delayed_Aspects; + + function Has_Delayed_Freeze (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag18 (Id); + end Has_Delayed_Freeze; + + function Has_Discriminants (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag5 (Id); + end Has_Discriminants; + + function Has_Dispatch_Table (Id : E) return B is + begin + pragma Assert (Is_Tagged_Type (Id)); + return Flag220 (Id); + end Has_Dispatch_Table; + + function Has_Enumeration_Rep_Clause (Id : E) return B is + begin + pragma Assert (Is_Enumeration_Type (Id)); + return Flag66 (Id); + end Has_Enumeration_Rep_Clause; + + function Has_Exit (Id : E) return B is + begin + return Flag47 (Id); + end Has_Exit; + + function Has_External_Tag_Rep_Clause (Id : E) return B is + begin + pragma Assert (Is_Tagged_Type (Id)); + return Flag110 (Id); + end Has_External_Tag_Rep_Clause; + + function Has_Forward_Instantiation (Id : E) return B is + begin + return Flag175 (Id); + end Has_Forward_Instantiation; + + function Has_Fully_Qualified_Name (Id : E) return B is + begin + return Flag173 (Id); + end Has_Fully_Qualified_Name; + + function Has_Gigi_Rep_Item (Id : E) return B is + begin + return Flag82 (Id); + end Has_Gigi_Rep_Item; + + function Has_Homonym (Id : E) return B is + begin + return Flag56 (Id); + end Has_Homonym; + + function Has_Inheritable_Invariants (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag248 (Id); + end Has_Inheritable_Invariants; + + function Has_Initial_Value (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Variable or else Is_Formal (Id)); + return Flag219 (Id); + end Has_Initial_Value; + + function Has_Invariants (Id : E) return B is + begin + pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Procedure); + return Flag232 (Id); + end Has_Invariants; + + function Has_Machine_Radix_Clause (Id : E) return B is + begin + pragma Assert (Is_Decimal_Fixed_Point_Type (Id)); + return Flag83 (Id); + end Has_Machine_Radix_Clause; + + function Has_Master_Entity (Id : E) return B is + begin + return Flag21 (Id); + end Has_Master_Entity; + + function Has_Missing_Return (Id : E) return B is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Generic_Function)); + return Flag142 (Id); + end Has_Missing_Return; + + function Has_Nested_Block_With_Handler (Id : E) return B is + begin + return Flag101 (Id); + end Has_Nested_Block_With_Handler; + + function Has_Non_Standard_Rep (Id : E) return B is + begin + return Flag75 (Implementation_Base_Type (Id)); + end Has_Non_Standard_Rep; + + function Has_Object_Size_Clause (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag172 (Id); + end Has_Object_Size_Clause; + + function Has_Per_Object_Constraint (Id : E) return B is + begin + return Flag154 (Id); + end Has_Per_Object_Constraint; + + function Has_Persistent_BSS (Id : E) return B is + begin + return Flag188 (Id); + end Has_Persistent_BSS; + + function Has_Postconditions (Id : E) return B is + begin + pragma Assert (Is_Subprogram (Id)); + return Flag240 (Id); + end Has_Postconditions; + + function Has_Pragma_Controlled (Id : E) return B is + begin + pragma Assert (Is_Access_Type (Id)); + return Flag27 (Implementation_Base_Type (Id)); + end Has_Pragma_Controlled; + + function Has_Pragma_Elaborate_Body (Id : E) return B is + begin + return Flag150 (Id); + end Has_Pragma_Elaborate_Body; + + function Has_Pragma_Inline (Id : E) return B is + begin + return Flag157 (Id); + end Has_Pragma_Inline; + + function Has_Pragma_Inline_Always (Id : E) return B is + begin + return Flag230 (Id); + end Has_Pragma_Inline_Always; + + function Has_Pragma_Ordered (Id : E) return B is + begin + pragma Assert (Is_Enumeration_Type (Id)); + return Flag198 (Implementation_Base_Type (Id)); + end Has_Pragma_Ordered; + + function Has_Pragma_Pack (Id : E) return B is + begin + pragma Assert (Is_Record_Type (Id) or else Is_Array_Type (Id)); + return Flag121 (Implementation_Base_Type (Id)); + end Has_Pragma_Pack; + + function Has_Pragma_Preelab_Init (Id : E) return B is + begin + return Flag221 (Id); + end Has_Pragma_Preelab_Init; + + function Has_Pragma_Pure (Id : E) return B is + begin + return Flag203 (Id); + end Has_Pragma_Pure; + + function Has_Pragma_Pure_Function (Id : E) return B is + begin + return Flag179 (Id); + end Has_Pragma_Pure_Function; + + function Has_Pragma_Thread_Local_Storage (Id : E) return B is + begin + return Flag169 (Id); + end Has_Pragma_Thread_Local_Storage; + + function Has_Pragma_Unmodified (Id : E) return B is + begin + return Flag233 (Id); + end Has_Pragma_Unmodified; + + function Has_Pragma_Unreferenced (Id : E) return B is + begin + return Flag180 (Id); + end Has_Pragma_Unreferenced; + + function Has_Pragma_Unreferenced_Objects (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag212 (Id); + end Has_Pragma_Unreferenced_Objects; + + function Has_Predicates (Id : E) return B is + begin + return Flag250 (Id); + end Has_Predicates; + + function Has_Primitive_Operations (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag120 (Base_Type (Id)); + end Has_Primitive_Operations; + + function Has_Private_Declaration (Id : E) return B is + begin + return Flag155 (Id); + end Has_Private_Declaration; + + function Has_Qualified_Name (Id : E) return B is + begin + return Flag161 (Id); + end Has_Qualified_Name; + + function Has_RACW (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Package); + return Flag214 (Id); + end Has_RACW; + + function Has_Record_Rep_Clause (Id : E) return B is + begin + pragma Assert (Is_Record_Type (Id)); + return Flag65 (Implementation_Base_Type (Id)); + end Has_Record_Rep_Clause; + + function Has_Recursive_Call (Id : E) return B is + begin + pragma Assert (Is_Subprogram (Id)); + return Flag143 (Id); + end Has_Recursive_Call; + + function Has_Size_Clause (Id : E) return B is + begin + return Flag29 (Id); + end Has_Size_Clause; + + function Has_Small_Clause (Id : E) return B is + begin + return Flag67 (Id); + end Has_Small_Clause; + + function Has_Specified_Layout (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag100 (Implementation_Base_Type (Id)); + end Has_Specified_Layout; + + function Has_Specified_Stream_Input (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag190 (Id); + end Has_Specified_Stream_Input; + + function Has_Specified_Stream_Output (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag191 (Id); + end Has_Specified_Stream_Output; + + function Has_Specified_Stream_Read (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag192 (Id); + end Has_Specified_Stream_Read; + + function Has_Specified_Stream_Write (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag193 (Id); + end Has_Specified_Stream_Write; + + function Has_Static_Discriminants (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag211 (Id); + end Has_Static_Discriminants; + + function Has_Storage_Size_Clause (Id : E) return B is + begin + pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id)); + return Flag23 (Implementation_Base_Type (Id)); + end Has_Storage_Size_Clause; + + function Has_Stream_Size_Clause (Id : E) return B is + begin + return Flag184 (Id); + end Has_Stream_Size_Clause; + + function Has_Subprogram_Descriptor (Id : E) return B is + begin + return Flag93 (Id); + end Has_Subprogram_Descriptor; + + function Has_Task (Id : E) return B is + begin + return Flag30 (Base_Type (Id)); + end Has_Task; + + function Has_Thunks (Id : E) return B is + begin + return Flag228 (Id); + end Has_Thunks; + + function Has_Unchecked_Union (Id : E) return B is + begin + return Flag123 (Base_Type (Id)); + end Has_Unchecked_Union; + + function Has_Unknown_Discriminants (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag72 (Id); + end Has_Unknown_Discriminants; + + function Has_Up_Level_Access (Id : E) return B is + begin + pragma Assert + (Ekind_In (Id, E_Variable, E_Constant, E_Loop_Parameter)); + return Flag215 (Id); + end Has_Up_Level_Access; + + function Has_Volatile_Components (Id : E) return B is + begin + return Flag87 (Implementation_Base_Type (Id)); + end Has_Volatile_Components; + + function Has_Xref_Entry (Id : E) return B is + begin + return Flag182 (Implementation_Base_Type (Id)); + end Has_Xref_Entry; + + function Hiding_Loop_Variable (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Variable); + return Node8 (Id); + end Hiding_Loop_Variable; + + function Homonym (Id : E) return E is + begin + return Node4 (Id); + end Homonym; + + function Interface_Alias (Id : E) return E is + begin + pragma Assert (Is_Subprogram (Id)); + return Node25 (Id); + end Interface_Alias; + + function Interfaces (Id : E) return L is + begin + pragma Assert (Is_Record_Type (Id)); + return Elist25 (Id); + end Interfaces; + + function In_Package_Body (Id : E) return B is + begin + return Flag48 (Id); + end In_Package_Body; + + function In_Private_Part (Id : E) return B is + begin + return Flag45 (Id); + end In_Private_Part; + + function In_Use (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag8 (Id); + end In_Use; + + function Inner_Instances (Id : E) return L is + begin + return Elist23 (Id); + end Inner_Instances; + + function Interface_Name (Id : E) return N is + begin + return Node21 (Id); + end Interface_Name; + + function Is_Abstract_Subprogram (Id : E) return B is + begin + pragma Assert (Is_Overloadable (Id)); + return Flag19 (Id); + end Is_Abstract_Subprogram; + + function Is_Abstract_Type (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag146 (Id); + end Is_Abstract_Type; + + function Is_Local_Anonymous_Access (Id : E) return B is + begin + pragma Assert (Is_Access_Type (Id)); + return Flag194 (Id); + end Is_Local_Anonymous_Access; + + function Is_Access_Constant (Id : E) return B is + begin + pragma Assert (Is_Access_Type (Id)); + return Flag69 (Id); + end Is_Access_Constant; + + function Is_Ada_2005_Only (Id : E) return B is + begin + return Flag185 (Id); + end Is_Ada_2005_Only; + + function Is_Ada_2012_Only (Id : E) return B is + begin + return Flag199 (Id); + end Is_Ada_2012_Only; + + function Is_Aliased (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag15 (Id); + end Is_Aliased; + + function Is_AST_Entry (Id : E) return B is + begin + pragma Assert (Is_Entry (Id)); + return Flag132 (Id); + end Is_AST_Entry; + + function Is_Asynchronous (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Procedure or else Is_Type (Id)); + return Flag81 (Id); + end Is_Asynchronous; + + function Is_Atomic (Id : E) return B is + begin + return Flag85 (Id); + end Is_Atomic; + + function Is_Bit_Packed_Array (Id : E) return B is + begin + return Flag122 (Implementation_Base_Type (Id)); + end Is_Bit_Packed_Array; + + function Is_Called (Id : E) return B is + begin + pragma Assert (Ekind_In (Id, E_Procedure, E_Function)); + return Flag102 (Id); + end Is_Called; + + function Is_Character_Type (Id : E) return B is + begin + return Flag63 (Id); + end Is_Character_Type; + + function Is_Child_Unit (Id : E) return B is + begin + return Flag73 (Id); + end Is_Child_Unit; + + function Is_Class_Wide_Equivalent_Type (Id : E) return B is + begin + return Flag35 (Id); + end Is_Class_Wide_Equivalent_Type; + + function Is_Compilation_Unit (Id : E) return B is + begin + return Flag149 (Id); + end Is_Compilation_Unit; + + function Is_Completely_Hidden (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Discriminant); + return Flag103 (Id); + end Is_Completely_Hidden; + + function Is_Constr_Subt_For_U_Nominal (Id : E) return B is + begin + return Flag80 (Id); + end Is_Constr_Subt_For_U_Nominal; + + function Is_Constr_Subt_For_UN_Aliased (Id : E) return B is + begin + return Flag141 (Id); + end Is_Constr_Subt_For_UN_Aliased; + + function Is_Constrained (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag12 (Id); + end Is_Constrained; + + function Is_Constructor (Id : E) return B is + begin + return Flag76 (Id); + end Is_Constructor; + + function Is_Controlled (Id : E) return B is + begin + return Flag42 (Base_Type (Id)); + end Is_Controlled; + + function Is_Controlling_Formal (Id : E) return B is + begin + pragma Assert (Is_Formal (Id)); + return Flag97 (Id); + end Is_Controlling_Formal; + + function Is_CPP_Class (Id : E) return B is + begin + return Flag74 (Id); + end Is_CPP_Class; + + function Is_Descendent_Of_Address (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag223 (Id); + end Is_Descendent_Of_Address; + + function Is_Discrim_SO_Function (Id : E) return B is + begin + return Flag176 (Id); + end Is_Discrim_SO_Function; + + function Is_Dispatch_Table_Entity (Id : E) return B is + begin + return Flag234 (Id); + end Is_Dispatch_Table_Entity; + + function Is_Dispatching_Operation (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag6 (Id); + end Is_Dispatching_Operation; + + function Is_Eliminated (Id : E) return B is + begin + return Flag124 (Id); + end Is_Eliminated; + + function Is_Entry_Formal (Id : E) return B is + begin + return Flag52 (Id); + end Is_Entry_Formal; + + function Is_Exported (Id : E) return B is + begin + return Flag99 (Id); + end Is_Exported; + + function Is_First_Subtype (Id : E) return B is + begin + return Flag70 (Id); + end Is_First_Subtype; + + function Is_For_Access_Subtype (Id : E) return B is + begin + pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Private_Subtype)); + return Flag118 (Id); + end Is_For_Access_Subtype; + + function Is_Formal_Subprogram (Id : E) return B is + begin + return Flag111 (Id); + end Is_Formal_Subprogram; + + function Is_Frozen (Id : E) return B is + begin + return Flag4 (Id); + end Is_Frozen; + + function Is_Generic_Actual_Type (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag94 (Id); + end Is_Generic_Actual_Type; + + function Is_Generic_Instance (Id : E) return B is + begin + return Flag130 (Id); + end Is_Generic_Instance; + + function Is_Generic_Type (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag13 (Id); + end Is_Generic_Type; + + function Is_Hidden (Id : E) return B is + begin + return Flag57 (Id); + end Is_Hidden; + + function Is_Hidden_Open_Scope (Id : E) return B is + begin + return Flag171 (Id); + end Is_Hidden_Open_Scope; + + function Is_Immediately_Visible (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag7 (Id); + end Is_Immediately_Visible; + + function Is_Imported (Id : E) return B is + begin + return Flag24 (Id); + end Is_Imported; + + function Is_Inlined (Id : E) return B is + begin + return Flag11 (Id); + end Is_Inlined; + + function Is_Interface (Id : E) return B is + begin + return Flag186 (Id); + end Is_Interface; + + function Is_Instantiated (Id : E) return B is + begin + return Flag126 (Id); + end Is_Instantiated; + + function Is_Internal (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag17 (Id); + end Is_Internal; + + function Is_Interrupt_Handler (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag89 (Id); + end Is_Interrupt_Handler; + + function Is_Intrinsic_Subprogram (Id : E) return B is + begin + return Flag64 (Id); + end Is_Intrinsic_Subprogram; + + function Is_Itype (Id : E) return B is + begin + return Flag91 (Id); + end Is_Itype; + + function Is_Known_Non_Null (Id : E) return B is + begin + return Flag37 (Id); + end Is_Known_Non_Null; + + function Is_Known_Null (Id : E) return B is + begin + return Flag204 (Id); + end Is_Known_Null; + + function Is_Known_Valid (Id : E) return B is + begin + return Flag170 (Id); + end Is_Known_Valid; + + function Is_Limited_Composite (Id : E) return B is + begin + return Flag106 (Id); + end Is_Limited_Composite; + + function Is_Limited_Interface (Id : E) return B is + begin + return Flag197 (Id); + end Is_Limited_Interface; + + function Is_Limited_Record (Id : E) return B is + begin + return Flag25 (Id); + end Is_Limited_Record; + + function Is_Machine_Code_Subprogram (Id : E) return B is + begin + pragma Assert (Is_Subprogram (Id)); + return Flag137 (Id); + end Is_Machine_Code_Subprogram; + + function Is_Non_Static_Subtype (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag109 (Id); + end Is_Non_Static_Subtype; + + function Is_Null_Init_Proc (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Procedure); + return Flag178 (Id); + end Is_Null_Init_Proc; + + function Is_Obsolescent (Id : E) return B is + begin + return Flag153 (Id); + end Is_Obsolescent; + + function Is_Only_Out_Parameter (Id : E) return B is + begin + pragma Assert (Is_Formal (Id)); + return Flag226 (Id); + end Is_Only_Out_Parameter; + + function Is_Optional_Parameter (Id : E) return B is + begin + pragma Assert (Is_Formal (Id)); + return Flag134 (Id); + end Is_Optional_Parameter; + + function Is_Package_Body_Entity (Id : E) return B is + begin + return Flag160 (Id); + end Is_Package_Body_Entity; + + function Is_Packed (Id : E) return B is + begin + return Flag51 (Implementation_Base_Type (Id)); + end Is_Packed; + + function Is_Packed_Array_Type (Id : E) return B is + begin + return Flag138 (Id); + end Is_Packed_Array_Type; + + function Is_Potentially_Use_Visible (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag9 (Id); + end Is_Potentially_Use_Visible; + + function Is_Preelaborated (Id : E) return B is + begin + return Flag59 (Id); + end Is_Preelaborated; + + function Is_Primitive (Id : E) return B is + begin + pragma Assert + (Is_Overloadable (Id) + or else Ekind_In (Id, E_Generic_Function, E_Generic_Procedure)); + return Flag218 (Id); + end Is_Primitive; + + function Is_Primitive_Wrapper (Id : E) return B is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + return Flag195 (Id); + end Is_Primitive_Wrapper; + + function Is_Private_Composite (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag107 (Id); + end Is_Private_Composite; + + function Is_Private_Descendant (Id : E) return B is + begin + return Flag53 (Id); + end Is_Private_Descendant; + + function Is_Private_Primitive (Id : E) return B is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + return Flag245 (Id); + end Is_Private_Primitive; + + function Is_Public (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag10 (Id); + end Is_Public; + + function Is_Pure (Id : E) return B is + begin + return Flag44 (Id); + end Is_Pure; + + function Is_Pure_Unit_Access_Type (Id : E) return B is + begin + pragma Assert (Is_Access_Type (Id)); + return Flag189 (Id); + end Is_Pure_Unit_Access_Type; + + function Is_RACW_Stub_Type (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag244 (Id); + end Is_RACW_Stub_Type; + + function Is_Raised (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Exception); + return Flag224 (Id); + end Is_Raised; + + function Is_Remote_Call_Interface (Id : E) return B is + begin + return Flag62 (Id); + end Is_Remote_Call_Interface; + + function Is_Remote_Types (Id : E) return B is + begin + return Flag61 (Id); + end Is_Remote_Types; + + function Is_Renaming_Of_Object (Id : E) return B is + begin + return Flag112 (Id); + end Is_Renaming_Of_Object; + + function Is_Return_Object (Id : E) return B is + begin + return Flag209 (Id); + end Is_Return_Object; + + function Is_Shared_Passive (Id : E) return B is + begin + return Flag60 (Id); + end Is_Shared_Passive; + + function Is_Statically_Allocated (Id : E) return B is + begin + return Flag28 (Id); + end Is_Statically_Allocated; + + function Is_Tag (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag78 (Id); + end Is_Tag; + + function Is_Tagged_Type (Id : E) return B is + begin + return Flag55 (Id); + end Is_Tagged_Type; + + function Is_Thunk (Id : E) return B is + begin + pragma Assert (Is_Subprogram (Id)); + return Flag225 (Id); + end Is_Thunk; + + function Is_Trivial_Subprogram (Id : E) return B is + begin + return Flag235 (Id); + end Is_Trivial_Subprogram; + + function Is_True_Constant (Id : E) return B is + begin + return Flag163 (Id); + end Is_True_Constant; + + function Is_Unchecked_Union (Id : E) return B is + begin + return Flag117 (Implementation_Base_Type (Id)); + end Is_Unchecked_Union; + + function Is_Underlying_Record_View (Id : E) return B is + begin + return Flag246 (Id); + end Is_Underlying_Record_View; + + function Is_Unsigned_Type (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag144 (Id); + end Is_Unsigned_Type; + + function Is_Valued_Procedure (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Procedure); + return Flag127 (Id); + end Is_Valued_Procedure; + + function Is_Visible_Child_Unit (Id : E) return B is + begin + pragma Assert (Is_Child_Unit (Id)); + return Flag116 (Id); + end Is_Visible_Child_Unit; + + function Is_Visible_Formal (Id : E) return B is + begin + return Flag206 (Id); + end Is_Visible_Formal; + + function Is_VMS_Exception (Id : E) return B is + begin + return Flag133 (Id); + end Is_VMS_Exception; + + function Is_Volatile (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + + if Is_Type (Id) then + return Flag16 (Base_Type (Id)); + else + return Flag16 (Id); + end if; + end Is_Volatile; + + function Itype_Printed (Id : E) return B is + begin + pragma Assert (Is_Itype (Id)); + return Flag202 (Id); + end Itype_Printed; + + function Kill_Elaboration_Checks (Id : E) return B is + begin + return Flag32 (Id); + end Kill_Elaboration_Checks; + + function Kill_Range_Checks (Id : E) return B is + begin + return Flag33 (Id); + end Kill_Range_Checks; + + function Kill_Tag_Checks (Id : E) return B is + begin + return Flag34 (Id); + end Kill_Tag_Checks; + + function Known_To_Have_Preelab_Init (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag207 (Id); + end Known_To_Have_Preelab_Init; + + function Last_Assignment (Id : E) return N is + begin + pragma Assert (Is_Assignable (Id)); + return Node26 (Id); + end Last_Assignment; + + function Last_Entity (Id : E) return E is + begin + return Node20 (Id); + end Last_Entity; + + function Limited_View (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Package); + return Node23 (Id); + end Limited_View; + + function Lit_Indexes (Id : E) return E is + begin + pragma Assert (Is_Enumeration_Type (Id)); + return Node15 (Id); + end Lit_Indexes; + + function Lit_Strings (Id : E) return E is + begin + pragma Assert (Is_Enumeration_Type (Id)); + return Node16 (Id); + end Lit_Strings; + + function Low_Bound_Tested (Id : E) return B is + begin + return Flag205 (Id); + end Low_Bound_Tested; + + function Machine_Radix_10 (Id : E) return B is + begin + pragma Assert (Is_Decimal_Fixed_Point_Type (Id)); + return Flag84 (Id); + end Machine_Radix_10; + + function Master_Id (Id : E) return E is + begin + pragma Assert (Is_Access_Type (Id)); + return Node17 (Id); + end Master_Id; + + function Materialize_Entity (Id : E) return B is + begin + return Flag168 (Id); + end Materialize_Entity; + + function Mechanism (Id : E) return M is + begin + pragma Assert (Ekind (Id) = E_Function or else Is_Formal (Id)); + return UI_To_Int (Uint8 (Id)); + end Mechanism; + + function Modulus (Id : E) return Uint is + begin + pragma Assert (Is_Modular_Integer_Type (Id)); + return Uint17 (Base_Type (Id)); + end Modulus; + + function Must_Be_On_Byte_Boundary (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag183 (Id); + end Must_Be_On_Byte_Boundary; + + function Must_Have_Preelab_Init (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag208 (Id); + end Must_Have_Preelab_Init; + + function Needs_Debug_Info (Id : E) return B is + begin + return Flag147 (Id); + end Needs_Debug_Info; + + function Needs_No_Actuals (Id : E) return B is + begin + pragma Assert + (Is_Overloadable (Id) + or else Ekind_In (Id, E_Subprogram_Type, E_Entry_Family)); + return Flag22 (Id); + end Needs_No_Actuals; + + function Never_Set_In_Source (Id : E) return B is + begin + return Flag115 (Id); + end Never_Set_In_Source; + + function Next_Inlined_Subprogram (Id : E) return E is + begin + return Node12 (Id); + end Next_Inlined_Subprogram; + + function No_Pool_Assigned (Id : E) return B is + begin + pragma Assert (Is_Access_Type (Id)); + return Flag131 (Root_Type (Id)); + end No_Pool_Assigned; + + function No_Return (Id : E) return B is + begin + return Flag113 (Id); + end No_Return; + + function No_Strict_Aliasing (Id : E) return B is + begin + pragma Assert (Is_Access_Type (Id)); + return Flag136 (Base_Type (Id)); + end No_Strict_Aliasing; + + function Non_Binary_Modulus (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag58 (Base_Type (Id)); + end Non_Binary_Modulus; + + function Non_Limited_View (Id : E) return E is + begin + pragma Assert (Ekind (Id) in Incomplete_Kind); + return Node17 (Id); + end Non_Limited_View; + + function Nonzero_Is_True (Id : E) return B is + begin + pragma Assert (Root_Type (Id) = Standard_Boolean); + return Flag162 (Base_Type (Id)); + end Nonzero_Is_True; + + function Normalized_First_Bit (Id : E) return U is + begin + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + return Uint8 (Id); + end Normalized_First_Bit; + + function Normalized_Position (Id : E) return U is + begin + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + return Uint14 (Id); + end Normalized_Position; + + function Normalized_Position_Max (Id : E) return U is + begin + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + return Uint10 (Id); + end Normalized_Position_Max; + + function OK_To_Rename (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Variable); + return Flag247 (Id); + end OK_To_Rename; + + function OK_To_Reorder_Components (Id : E) return B is + begin + pragma Assert (Is_Record_Type (Id)); + return Flag239 (Base_Type (Id)); + end OK_To_Reorder_Components; + + function Optimize_Alignment_Space (Id : E) return B is + begin + pragma Assert + (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable)); + return Flag241 (Id); + end Optimize_Alignment_Space; + + function Optimize_Alignment_Time (Id : E) return B is + begin + pragma Assert + (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable)); + return Flag242 (Id); + end Optimize_Alignment_Time; + + function Original_Array_Type (Id : E) return E is + begin + pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id)); + return Node21 (Id); + end Original_Array_Type; + + function Original_Record_Component (Id : E) return E is + begin + pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant)); + return Node22 (Id); + end Original_Record_Component; + + function Overlays_Constant (Id : E) return B is + begin + return Flag243 (Id); + end Overlays_Constant; + + function Overridden_Operation (Id : E) return E is + begin + return Node26 (Id); + end Overridden_Operation; + + function Package_Instantiation (Id : E) return N is + begin + pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)); + return Node26 (Id); + end Package_Instantiation; + + function Packed_Array_Type (Id : E) return E is + begin + pragma Assert (Is_Array_Type (Id)); + return Node23 (Id); + end Packed_Array_Type; + + function Parent_Subtype (Id : E) return E is + begin + pragma Assert (Is_Record_Type (Id)); + return Node19 (Base_Type (Id)); + end Parent_Subtype; + + function Postcondition_Proc (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Procedure); + return Node8 (Id); + end Postcondition_Proc; + + function PPC_Wrapper (Id : E) return E is + begin + pragma Assert (Ekind_In (Id, E_Entry, E_Entry_Family)); + return Node25 (Id); + end PPC_Wrapper; + + function Prival (Id : E) return E is + begin + pragma Assert (Is_Protected_Component (Id)); + return Node17 (Id); + end Prival; + + function Prival_Link (Id : E) return E is + begin + pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); + return Node20 (Id); + end Prival_Link; + + function Private_Dependents (Id : E) return L is + begin + pragma Assert (Is_Incomplete_Or_Private_Type (Id)); + return Elist18 (Id); + end Private_Dependents; + + function Private_View (Id : E) return N is + begin + pragma Assert (Is_Private_Type (Id)); + return Node22 (Id); + end Private_View; + + function Protected_Body_Subprogram (Id : E) return E is + begin + pragma Assert (Is_Subprogram (Id) or else Is_Entry (Id)); + return Node11 (Id); + end Protected_Body_Subprogram; + + function Protected_Formal (Id : E) return E is + begin + pragma Assert (Is_Formal (Id)); + return Node22 (Id); + end Protected_Formal; + + function Protection_Object (Id : E) return E is + begin + pragma Assert + (Ekind_In (Id, E_Entry, E_Entry_Family, E_Function, E_Procedure)); + return Node23 (Id); + end Protection_Object; + + function Reachable (Id : E) return B is + begin + return Flag49 (Id); + end Reachable; + + function Referenced (Id : E) return B is + begin + return Flag156 (Id); + end Referenced; + + function Referenced_As_LHS (Id : E) return B is + begin + return Flag36 (Id); + end Referenced_As_LHS; + + function Referenced_As_Out_Parameter (Id : E) return B is + begin + return Flag227 (Id); + end Referenced_As_Out_Parameter; + + function Register_Exception_Call (Id : E) return N is + begin + pragma Assert (Ekind (Id) = E_Exception); + return Node20 (Id); + end Register_Exception_Call; + + function Related_Array_Object (Id : E) return E is + begin + pragma Assert (Is_Array_Type (Id)); + return Node19 (Id); + end Related_Array_Object; + + function Related_Expression (Id : E) return N is + begin + pragma Assert (Ekind (Id) in Type_Kind + or else Ekind_In (Id, E_Constant, E_Variable)); + return Node24 (Id); + end Related_Expression; + + function Related_Instance (Id : E) return E is + begin + pragma Assert (Ekind_In (Id, E_Package, E_Package_Body)); + return Node15 (Id); + end Related_Instance; + + function Related_Type (Id : E) return E is + begin + pragma Assert (Ekind_In (Id, E_Component, E_Constant, E_Variable)); + return Node27 (Id); + end Related_Type; + + function Relative_Deadline_Variable (Id : E) return E is + begin + pragma Assert (Is_Task_Type (Id)); + return Node26 (Implementation_Base_Type (Id)); + end Relative_Deadline_Variable; + + function Renamed_Entity (Id : E) return N is + begin + return Node18 (Id); + end Renamed_Entity; + + function Renamed_In_Spec (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Package); + return Flag231 (Id); + end Renamed_In_Spec; + + function Renamed_Object (Id : E) return N is + begin + return Node18 (Id); + end Renamed_Object; + + function Renaming_Map (Id : E) return U is + begin + return Uint9 (Id); + end Renaming_Map; + + function Requires_Overriding (Id : E) return B is + begin + pragma Assert (Is_Overloadable (Id)); + return Flag213 (Id); + end Requires_Overriding; + + function Return_Present (Id : E) return B is + begin + return Flag54 (Id); + end Return_Present; + + function Return_Applies_To (Id : E) return N is + begin + return Node8 (Id); + end Return_Applies_To; + + function Returns_By_Ref (Id : E) return B is + begin + return Flag90 (Id); + end Returns_By_Ref; + + function Reverse_Bit_Order (Id : E) return B is + begin + pragma Assert (Is_Record_Type (Id)); + return Flag164 (Base_Type (Id)); + end Reverse_Bit_Order; + + function RM_Size (Id : E) return U is + begin + pragma Assert (Is_Type (Id)); + return Uint13 (Id); + end RM_Size; + + function Scalar_Range (Id : E) return N is + begin + return Node20 (Id); + end Scalar_Range; + + function Scale_Value (Id : E) return U is + begin + return Uint15 (Id); + end Scale_Value; + + function Scope_Depth_Value (Id : E) return U is + begin + return Uint22 (Id); + end Scope_Depth_Value; + + function Sec_Stack_Needed_For_Return (Id : E) return B is + begin + return Flag167 (Id); + end Sec_Stack_Needed_For_Return; + + function Shadow_Entities (Id : E) return S is + begin + pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)); + return List14 (Id); + end Shadow_Entities; + + function Shared_Var_Procs_Instance (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Variable); + return Node22 (Id); + end Shared_Var_Procs_Instance; + + function Size_Check_Code (Id : E) return N is + begin + pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); + return Node19 (Id); + end Size_Check_Code; + + function Size_Depends_On_Discriminant (Id : E) return B is + begin + return Flag177 (Id); + end Size_Depends_On_Discriminant; + + function Size_Known_At_Compile_Time (Id : E) return B is + begin + return Flag92 (Id); + end Size_Known_At_Compile_Time; + + function Small_Value (Id : E) return R is + begin + pragma Assert (Is_Fixed_Point_Type (Id)); + return Ureal21 (Id); + end Small_Value; + + function Spec_Entity (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Package_Body or else Is_Formal (Id)); + return Node19 (Id); + end Spec_Entity; + + function Spec_PPC_List (Id : E) return N is + begin + pragma Assert + (Ekind_In (Id, E_Entry, E_Entry_Family) + or else Is_Subprogram (Id) + or else Is_Generic_Subprogram (Id)); + return Node24 (Id); + end Spec_PPC_List; + + function Static_Predicate (Id : E) return S is + begin + pragma Assert (Is_Discrete_Type (Id)); + return List25 (Id); + end Static_Predicate; + + function Storage_Size_Variable (Id : E) return E is + begin + pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id)); + return Node15 (Implementation_Base_Type (Id)); + end Storage_Size_Variable; + + function Static_Elaboration_Desired (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Package); + return Flag77 (Id); + end Static_Elaboration_Desired; + + function Static_Initialization (Id : E) return N is + begin + pragma Assert + (Ekind (Id) = E_Procedure and then not Is_Dispatching_Operation (Id)); + return Node26 (Id); + end Static_Initialization; + + function Stored_Constraint (Id : E) return L is + begin + pragma Assert + (Is_Composite_Type (Id) and then not Is_Array_Type (Id)); + return Elist23 (Id); + end Stored_Constraint; + + function Strict_Alignment (Id : E) return B is + begin + return Flag145 (Implementation_Base_Type (Id)); + end Strict_Alignment; + + function String_Literal_Length (Id : E) return U is + begin + return Uint16 (Id); + end String_Literal_Length; + + function String_Literal_Low_Bound (Id : E) return N is + begin + return Node15 (Id); + end String_Literal_Low_Bound; + + function Subprograms_For_Type (Id : E) return E is + begin + pragma Assert (Is_Type (Id) or else Is_Subprogram (Id)); + return Node29 (Id); + end Subprograms_For_Type; + + function Suppress_Elaboration_Warnings (Id : E) return B is + begin + return Flag148 (Id); + end Suppress_Elaboration_Warnings; + + function Suppress_Init_Proc (Id : E) return B is + begin + return Flag105 (Base_Type (Id)); + end Suppress_Init_Proc; + + function Suppress_Style_Checks (Id : E) return B is + begin + return Flag165 (Id); + end Suppress_Style_Checks; + + function Suppress_Value_Tracking_On_Call (Id : E) return B is + begin + return Flag217 (Id); + end Suppress_Value_Tracking_On_Call; + + function Task_Body_Procedure (Id : E) return N is + begin + pragma Assert (Ekind (Id) in Task_Kind); + return Node25 (Id); + end Task_Body_Procedure; + + function Treat_As_Volatile (Id : E) return B is + begin + return Flag41 (Id); + end Treat_As_Volatile; + + function Underlying_Full_View (Id : E) return E is + begin + pragma Assert (Ekind (Id) in Private_Kind); + return Node19 (Id); + end Underlying_Full_View; + + function Underlying_Record_View (Id : E) return E is + begin + return Node28 (Id); + end Underlying_Record_View; + + function Universal_Aliasing (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag216 (Base_Type (Id)); + end Universal_Aliasing; + + function Unset_Reference (Id : E) return N is + begin + return Node16 (Id); + end Unset_Reference; + + function Used_As_Generic_Actual (Id : E) return B is + begin + return Flag222 (Id); + end Used_As_Generic_Actual; + + function Uses_Sec_Stack (Id : E) return B is + begin + return Flag95 (Id); + end Uses_Sec_Stack; + + function Warnings_Off (Id : E) return B is + begin + return Flag96 (Id); + end Warnings_Off; + + function Warnings_Off_Used (Id : E) return B is + begin + return Flag236 (Id); + end Warnings_Off_Used; + + function Warnings_Off_Used_Unmodified (Id : E) return B is + begin + return Flag237 (Id); + end Warnings_Off_Used_Unmodified; + + function Warnings_Off_Used_Unreferenced (Id : E) return B is + begin + return Flag238 (Id); + end Warnings_Off_Used_Unreferenced; + + function Wrapped_Entity (Id : E) return E is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Procedure) + and then Is_Primitive_Wrapper (Id)); + return Node27 (Id); + end Wrapped_Entity; + + function Was_Hidden (Id : E) return B is + begin + return Flag196 (Id); + end Was_Hidden; + + ------------------------------ + -- Classification Functions -- + ------------------------------ + + function Is_Access_Type (Id : E) return B is + begin + return Ekind (Id) in Access_Kind; + end Is_Access_Type; + + function Is_Access_Protected_Subprogram_Type (Id : E) return B is + begin + return Ekind (Id) in Access_Protected_Kind; + end Is_Access_Protected_Subprogram_Type; + + function Is_Access_Subprogram_Type (Id : E) return B is + begin + return Ekind (Id) in Access_Subprogram_Kind; + end Is_Access_Subprogram_Type; + + function Is_Aggregate_Type (Id : E) return B is + begin + return Ekind (Id) in Aggregate_Kind; + end Is_Aggregate_Type; + + function Is_Array_Type (Id : E) return B is + begin + return Ekind (Id) in Array_Kind; + end Is_Array_Type; + + function Is_Assignable (Id : E) return B is + begin + return Ekind (Id) in Assignable_Kind; + end Is_Assignable; + + function Is_Class_Wide_Type (Id : E) return B is + begin + return Ekind (Id) in Class_Wide_Kind; + end Is_Class_Wide_Type; + + function Is_Composite_Type (Id : E) return B is + begin + return Ekind (Id) in Composite_Kind; + end Is_Composite_Type; + + function Is_Concurrent_Body (Id : E) return B is + begin + return Ekind (Id) in + Concurrent_Body_Kind; + end Is_Concurrent_Body; + + function Is_Concurrent_Record_Type (Id : E) return B is + begin + return Flag20 (Id); + end Is_Concurrent_Record_Type; + + function Is_Concurrent_Type (Id : E) return B is + begin + return Ekind (Id) in Concurrent_Kind; + end Is_Concurrent_Type; + + function Is_Decimal_Fixed_Point_Type (Id : E) return B is + begin + return Ekind (Id) in + Decimal_Fixed_Point_Kind; + end Is_Decimal_Fixed_Point_Type; + + function Is_Digits_Type (Id : E) return B is + begin + return Ekind (Id) in Digits_Kind; + end Is_Digits_Type; + + function Is_Discrete_Or_Fixed_Point_Type (Id : E) return B is + begin + return Ekind (Id) in Discrete_Or_Fixed_Point_Kind; + end Is_Discrete_Or_Fixed_Point_Type; + + function Is_Discrete_Type (Id : E) return B is + begin + return Ekind (Id) in Discrete_Kind; + end Is_Discrete_Type; + + function Is_Elementary_Type (Id : E) return B is + begin + return Ekind (Id) in Elementary_Kind; + end Is_Elementary_Type; + + function Is_Entry (Id : E) return B is + begin + return Ekind (Id) in Entry_Kind; + end Is_Entry; + + function Is_Enumeration_Type (Id : E) return B is + begin + return Ekind (Id) in + Enumeration_Kind; + end Is_Enumeration_Type; + + function Is_Fixed_Point_Type (Id : E) return B is + begin + return Ekind (Id) in + Fixed_Point_Kind; + end Is_Fixed_Point_Type; + + function Is_Floating_Point_Type (Id : E) return B is + begin + return Ekind (Id) in Float_Kind; + end Is_Floating_Point_Type; + + function Is_Formal (Id : E) return B is + begin + return Ekind (Id) in Formal_Kind; + end Is_Formal; + + function Is_Formal_Object (Id : E) return B is + begin + return Ekind (Id) in Formal_Object_Kind; + end Is_Formal_Object; + + function Is_Generic_Subprogram (Id : E) return B is + begin + return Ekind (Id) in Generic_Subprogram_Kind; + end Is_Generic_Subprogram; + + function Is_Generic_Unit (Id : E) return B is + begin + return Ekind (Id) in Generic_Unit_Kind; + end Is_Generic_Unit; + + function Is_Incomplete_Or_Private_Type (Id : E) return B is + begin + return Ekind (Id) in + Incomplete_Or_Private_Kind; + end Is_Incomplete_Or_Private_Type; + + function Is_Incomplete_Type (Id : E) return B is + begin + return Ekind (Id) in + Incomplete_Kind; + end Is_Incomplete_Type; + + function Is_Integer_Type (Id : E) return B is + begin + return Ekind (Id) in Integer_Kind; + end Is_Integer_Type; + + function Is_Modular_Integer_Type (Id : E) return B is + begin + return Ekind (Id) in + Modular_Integer_Kind; + end Is_Modular_Integer_Type; + + function Is_Named_Number (Id : E) return B is + begin + return Ekind (Id) in Named_Kind; + end Is_Named_Number; + + function Is_Numeric_Type (Id : E) return B is + begin + return Ekind (Id) in Numeric_Kind; + end Is_Numeric_Type; + + function Is_Object (Id : E) return B is + begin + return Ekind (Id) in Object_Kind; + end Is_Object; + + function Is_Ordinary_Fixed_Point_Type (Id : E) return B is + begin + return Ekind (Id) in + Ordinary_Fixed_Point_Kind; + end Is_Ordinary_Fixed_Point_Type; + + function Is_Overloadable (Id : E) return B is + begin + return Ekind (Id) in Overloadable_Kind; + end Is_Overloadable; + + function Is_Private_Type (Id : E) return B is + begin + return Ekind (Id) in Private_Kind; + end Is_Private_Type; + + function Is_Protected_Type (Id : E) return B is + begin + return Ekind (Id) in Protected_Kind; + end Is_Protected_Type; + + function Is_Real_Type (Id : E) return B is + begin + return Ekind (Id) in Real_Kind; + end Is_Real_Type; + + function Is_Record_Type (Id : E) return B is + begin + return Ekind (Id) in Record_Kind; + end Is_Record_Type; + + function Is_Scalar_Type (Id : E) return B is + begin + return Ekind (Id) in Scalar_Kind; + end Is_Scalar_Type; + + function Is_Signed_Integer_Type (Id : E) return B is + begin + return Ekind (Id) in Signed_Integer_Kind; + end Is_Signed_Integer_Type; + + function Is_Subprogram (Id : E) return B is + begin + return Ekind (Id) in Subprogram_Kind; + end Is_Subprogram; + + function Is_Task_Type (Id : E) return B is + begin + return Ekind (Id) in Task_Kind; + end Is_Task_Type; + + function Is_Type (Id : E) return B is + begin + return Ekind (Id) in Type_Kind; + end Is_Type; + + ------------------------------ + -- Attribute Set Procedures -- + ------------------------------ + + -- Note: in many of these set procedures an "obvious" assertion is missing. + -- The reason for this is that in many cases, a field is set before the + -- Ekind field is set, so that the field is set when Ekind = E_Void. It + -- it is possible to add assertions that specifically include the E_Void + -- possibility, but in some cases, we just omit the assertions. + + procedure Set_Accept_Address (Id : E; V : L) is + begin + Set_Elist21 (Id, V); + end Set_Accept_Address; + + procedure Set_Access_Disp_Table (Id : E; V : L) is + begin + pragma Assert (Is_Tagged_Type (Id) and then Is_Base_Type (Id)); + Set_Elist16 (Id, V); + end Set_Access_Disp_Table; + + procedure Set_Associated_Final_Chain (Id : E; V : E) is + begin + pragma Assert (Is_Access_Type (Id)); + Set_Node23 (Id, V); + end Set_Associated_Final_Chain; + + procedure Set_Associated_Formal_Package (Id : E; V : E) is + begin + Set_Node12 (Id, V); + end Set_Associated_Formal_Package; + + procedure Set_Associated_Node_For_Itype (Id : E; V : E) is + begin + Set_Node8 (Id, V); + end Set_Associated_Node_For_Itype; + + procedure Set_Associated_Storage_Pool (Id : E; V : E) is + begin + pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id)); + Set_Node22 (Id, V); + end Set_Associated_Storage_Pool; + + procedure Set_Actual_Subtype (Id : E; V : E) is + begin + pragma Assert + (Ekind_In (Id, E_Constant, E_Variable, E_Generic_In_Out_Parameter) + or else Is_Formal (Id)); + Set_Node17 (Id, V); + end Set_Actual_Subtype; + + procedure Set_Address_Taken (Id : E; V : B := True) is + begin + Set_Flag104 (Id, V); + end Set_Address_Taken; + + procedure Set_Alias (Id : E; V : E) is + begin + pragma Assert + (Is_Overloadable (Id) or else Ekind (Id) = E_Subprogram_Type); + Set_Node18 (Id, V); + end Set_Alias; + + procedure Set_Alignment (Id : E; V : U) is + begin + pragma Assert (Is_Type (Id) + or else Is_Formal (Id) + or else Ekind_In (Id, E_Loop_Parameter, + E_Constant, + E_Exception, + E_Variable)); + Set_Uint14 (Id, V); + end Set_Alignment; + + procedure Set_Barrier_Function (Id : E; V : N) is + begin + pragma Assert (Is_Entry (Id)); + Set_Node12 (Id, V); + end Set_Barrier_Function; + + procedure Set_Block_Node (Id : E; V : N) is + begin + pragma Assert (Ekind (Id) = E_Block); + Set_Node11 (Id, V); + end Set_Block_Node; + + procedure Set_Body_Entity (Id : E; V : E) is + begin + pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)); + Set_Node19 (Id, V); + end Set_Body_Entity; + + procedure Set_Body_Needed_For_SAL (Id : E; V : B := True) is + begin + pragma Assert + (Ekind (Id) = E_Package + or else Is_Subprogram (Id) + or else Is_Generic_Unit (Id)); + Set_Flag40 (Id, V); + end Set_Body_Needed_For_SAL; + + procedure Set_C_Pass_By_Copy (Id : E; V : B := True) is + begin + pragma Assert (Is_Record_Type (Id) and then Is_Base_Type (Id)); + Set_Flag125 (Id, V); + end Set_C_Pass_By_Copy; + + procedure Set_Can_Never_Be_Null (Id : E; V : B := True) is + begin + Set_Flag38 (Id, V); + end Set_Can_Never_Be_Null; + + procedure Set_Checks_May_Be_Suppressed (Id : E; V : B := True) is + begin + Set_Flag31 (Id, V); + end Set_Checks_May_Be_Suppressed; + + procedure Set_Class_Wide_Type (Id : E; V : E) is + begin + pragma Assert (Is_Type (Id)); + Set_Node9 (Id, V); + end Set_Class_Wide_Type; + + procedure Set_Cloned_Subtype (Id : E; V : E) is + begin + pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Class_Wide_Subtype)); + Set_Node16 (Id, V); + end Set_Cloned_Subtype; + + procedure Set_Component_Bit_Offset (Id : E; V : U) is + begin + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + Set_Uint11 (Id, V); + end Set_Component_Bit_Offset; + + procedure Set_Component_Clause (Id : E; V : N) is + begin + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + Set_Node13 (Id, V); + end Set_Component_Clause; + + procedure Set_Component_Size (Id : E; V : U) is + begin + pragma Assert (Is_Array_Type (Id) and then Is_Base_Type (Id)); + Set_Uint22 (Id, V); + end Set_Component_Size; + + procedure Set_Component_Type (Id : E; V : E) is + begin + pragma Assert (Is_Array_Type (Id) and then Is_Base_Type (Id)); + Set_Node20 (Id, V); + end Set_Component_Type; + + procedure Set_Corresponding_Concurrent_Type (Id : E; V : E) is + begin + pragma Assert + (Ekind (Id) = E_Record_Type and then Is_Concurrent_Type (V)); + Set_Node18 (Id, V); + end Set_Corresponding_Concurrent_Type; + + procedure Set_Corresponding_Discriminant (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Discriminant); + Set_Node19 (Id, V); + end Set_Corresponding_Discriminant; + + procedure Set_Corresponding_Equality (Id : E; V : E) is + begin + pragma Assert + (Ekind (Id) = E_Function + and then not Comes_From_Source (Id) + and then Chars (Id) = Name_Op_Ne); + Set_Node13 (Id, V); + end Set_Corresponding_Equality; + + procedure Set_Corresponding_Protected_Entry (Id : E; V : E) is + begin + pragma Assert (Ekind_In (Id, E_Void, E_Subprogram_Body)); + Set_Node18 (Id, V); + end Set_Corresponding_Protected_Entry; + + procedure Set_Corresponding_Record_Type (Id : E; V : E) is + begin + pragma Assert (Is_Concurrent_Type (Id)); + Set_Node18 (Id, V); + end Set_Corresponding_Record_Type; + + procedure Set_Corresponding_Remote_Type (Id : E; V : E) is + begin + Set_Node22 (Id, V); + end Set_Corresponding_Remote_Type; + + procedure Set_Current_Use_Clause (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Package or else Is_Type (Id)); + Set_Node27 (Id, V); + end Set_Current_Use_Clause; + + procedure Set_Current_Value (Id : E; V : N) is + begin + pragma Assert (Ekind (Id) in Object_Kind or else Ekind (Id) = E_Void); + Set_Node9 (Id, V); + end Set_Current_Value; + + procedure Set_CR_Discriminant (Id : E; V : E) is + begin + Set_Node23 (Id, V); + end Set_CR_Discriminant; + + procedure Set_Debug_Info_Off (Id : E; V : B := True) is + begin + Set_Flag166 (Id, V); + end Set_Debug_Info_Off; + + procedure Set_Debug_Renaming_Link (Id : E; V : E) is + begin + Set_Node25 (Id, V); + end Set_Debug_Renaming_Link; + + procedure Set_Default_Expr_Function (Id : E; V : E) is + begin + pragma Assert (Is_Formal (Id)); + Set_Node21 (Id, V); + end Set_Default_Expr_Function; + + procedure Set_Default_Expressions_Processed (Id : E; V : B := True) is + begin + Set_Flag108 (Id, V); + end Set_Default_Expressions_Processed; + + procedure Set_Default_Value (Id : E; V : N) is + begin + pragma Assert (Is_Formal (Id)); + Set_Node20 (Id, V); + end Set_Default_Value; + + procedure Set_Delay_Cleanups (Id : E; V : B := True) is + begin + pragma Assert + (Is_Subprogram (Id) + or else Is_Task_Type (Id) + or else Ekind (Id) = E_Block); + Set_Flag114 (Id, V); + end Set_Delay_Cleanups; + + procedure Set_Delay_Subprogram_Descriptors (Id : E; V : B := True) is + begin + pragma Assert + (Is_Subprogram (Id) or else Ekind_In (Id, E_Package, E_Package_Body)); + Set_Flag50 (Id, V); + end Set_Delay_Subprogram_Descriptors; + + procedure Set_Delta_Value (Id : E; V : R) is + begin + pragma Assert (Is_Fixed_Point_Type (Id)); + Set_Ureal18 (Id, V); + end Set_Delta_Value; + + procedure Set_Dependent_Instances (Id : E; V : L) is + begin + pragma Assert (Is_Generic_Instance (Id)); + Set_Elist8 (Id, V); + end Set_Dependent_Instances; + + procedure Set_Depends_On_Private (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag14 (Id, V); + end Set_Depends_On_Private; + + procedure Set_Digits_Value (Id : E; V : U) is + begin + pragma Assert + (Is_Floating_Point_Type (Id) + or else Is_Decimal_Fixed_Point_Type (Id)); + Set_Uint17 (Id, V); + end Set_Digits_Value; + + procedure Set_Directly_Designated_Type (Id : E; V : E) is + begin + Set_Node20 (Id, V); + end Set_Directly_Designated_Type; + + procedure Set_Discard_Names (Id : E; V : B := True) is + begin + Set_Flag88 (Id, V); + end Set_Discard_Names; + + procedure Set_Discriminal (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Discriminant); + Set_Node17 (Id, V); + end Set_Discriminal; + + procedure Set_Discriminal_Link (Id : E; V : E) is + begin + Set_Node10 (Id, V); + end Set_Discriminal_Link; + + procedure Set_Discriminant_Checking_Func (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Component); + Set_Node20 (Id, V); + end Set_Discriminant_Checking_Func; + + procedure Set_Discriminant_Constraint (Id : E; V : L) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Elist21 (Id, V); + end Set_Discriminant_Constraint; + + procedure Set_Discriminant_Default_Value (Id : E; V : N) is + begin + Set_Node20 (Id, V); + end Set_Discriminant_Default_Value; + + procedure Set_Discriminant_Number (Id : E; V : U) is + begin + Set_Uint15 (Id, V); + end Set_Discriminant_Number; + + procedure Set_Dispatch_Table_Wrappers (Id : E; V : L) is + begin + pragma Assert (Is_Tagged_Type (Id) + and then Is_Base_Type (Id) + and then Ekind_In (Id, E_Record_Type, + E_Record_Subtype, + E_Record_Type_With_Private, + E_Record_Subtype_With_Private)); + Set_Elist26 (Id, V); + end Set_Dispatch_Table_Wrappers; + + procedure Set_DT_Entry_Count (Id : E; V : U) is + begin + pragma Assert (Ekind (Id) = E_Component); + Set_Uint15 (Id, V); + end Set_DT_Entry_Count; + + procedure Set_DT_Offset_To_Top_Func (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Component and then Is_Tag (Id)); + Set_Node25 (Id, V); + end Set_DT_Offset_To_Top_Func; + + procedure Set_DT_Position (Id : E; V : U) is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + Set_Uint15 (Id, V); + end Set_DT_Position; + + procedure Set_DTC_Entity (Id : E; V : E) is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + Set_Node16 (Id, V); + end Set_DTC_Entity; + + procedure Set_Elaborate_Body_Desirable (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Package); + Set_Flag210 (Id, V); + end Set_Elaborate_Body_Desirable; + + procedure Set_Elaboration_Entity (Id : E; V : E) is + begin + pragma Assert + (Is_Subprogram (Id) + or else + Ekind (Id) = E_Package + or else + Is_Generic_Unit (Id)); + Set_Node13 (Id, V); + end Set_Elaboration_Entity; + + procedure Set_Elaboration_Entity_Required (Id : E; V : B := True) is + begin + pragma Assert + (Is_Subprogram (Id) + or else + Ekind (Id) = E_Package + or else + Is_Generic_Unit (Id)); + Set_Flag174 (Id, V); + end Set_Elaboration_Entity_Required; + + procedure Set_Enclosing_Scope (Id : E; V : E) is + begin + Set_Node18 (Id, V); + end Set_Enclosing_Scope; + + procedure Set_Entry_Accepted (Id : E; V : B := True) is + begin + pragma Assert (Is_Entry (Id)); + Set_Flag152 (Id, V); + end Set_Entry_Accepted; + + procedure Set_Entry_Bodies_Array (Id : E; V : E) is + begin + Set_Node15 (Id, V); + end Set_Entry_Bodies_Array; + + procedure Set_Entry_Cancel_Parameter (Id : E; V : E) is + begin + Set_Node23 (Id, V); + end Set_Entry_Cancel_Parameter; + + procedure Set_Entry_Component (Id : E; V : E) is + begin + Set_Node11 (Id, V); + end Set_Entry_Component; + + procedure Set_Entry_Formal (Id : E; V : E) is + begin + Set_Node16 (Id, V); + end Set_Entry_Formal; + + procedure Set_Entry_Index_Constant (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Entry_Index_Parameter); + Set_Node18 (Id, V); + end Set_Entry_Index_Constant; + + procedure Set_Entry_Parameters_Type (Id : E; V : E) is + begin + Set_Node15 (Id, V); + end Set_Entry_Parameters_Type; + + procedure Set_Enum_Pos_To_Rep (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Enumeration_Type); + Set_Node23 (Id, V); + end Set_Enum_Pos_To_Rep; + + procedure Set_Enumeration_Pos (Id : E; V : U) is + begin + pragma Assert (Ekind (Id) = E_Enumeration_Literal); + Set_Uint11 (Id, V); + end Set_Enumeration_Pos; + + procedure Set_Enumeration_Rep (Id : E; V : U) is + begin + pragma Assert (Ekind (Id) = E_Enumeration_Literal); + Set_Uint12 (Id, V); + end Set_Enumeration_Rep; + + procedure Set_Enumeration_Rep_Expr (Id : E; V : N) is + begin + pragma Assert (Ekind (Id) = E_Enumeration_Literal); + Set_Node22 (Id, V); + end Set_Enumeration_Rep_Expr; + + procedure Set_Equivalent_Type (Id : E; V : E) is + begin + pragma Assert + (Ekind_In (Id, E_Class_Wide_Type, + E_Class_Wide_Subtype, + E_Access_Protected_Subprogram_Type, + E_Anonymous_Access_Protected_Subprogram_Type, + E_Access_Subprogram_Type, + E_Exception_Type)); + Set_Node18 (Id, V); + end Set_Equivalent_Type; + + procedure Set_Esize (Id : E; V : U) is + begin + Set_Uint12 (Id, V); + end Set_Esize; + + procedure Set_Exception_Code (Id : E; V : U) is + begin + pragma Assert (Ekind (Id) = E_Exception); + Set_Uint22 (Id, V); + end Set_Exception_Code; + + procedure Set_Extra_Accessibility (Id : E; V : E) is + begin + pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable); + Set_Node13 (Id, V); + end Set_Extra_Accessibility; + + procedure Set_Extra_Constrained (Id : E; V : E) is + begin + pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable); + Set_Node23 (Id, V); + end Set_Extra_Constrained; + + procedure Set_Extra_Formal (Id : E; V : E) is + begin + Set_Node15 (Id, V); + end Set_Extra_Formal; + + procedure Set_Extra_Formals (Id : E; V : E) is + begin + pragma Assert + (Is_Overloadable (Id) + or else Ekind_In (Id, E_Entry_Family, + E_Subprogram_Body, + E_Subprogram_Type)); + Set_Node28 (Id, V); + end Set_Extra_Formals; + + procedure Set_Can_Use_Internal_Rep (Id : E; V : B := True) is + begin + pragma Assert + (Is_Access_Subprogram_Type (Id) and then Is_Base_Type (Id)); + Set_Flag229 (Id, V); + end Set_Can_Use_Internal_Rep; + + procedure Set_Finalization_Chain_Entity (Id : E; V : E) is + begin + Set_Node19 (Id, V); + end Set_Finalization_Chain_Entity; + + procedure Set_Finalize_Storage_Only (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id) and then Is_Base_Type (Id)); + Set_Flag158 (Id, V); + end Set_Finalize_Storage_Only; + + procedure Set_First_Entity (Id : E; V : E) is + begin + Set_Node17 (Id, V); + end Set_First_Entity; + + procedure Set_First_Exit_Statement (Id : E; V : N) is + begin + pragma Assert (Ekind (Id) = E_Loop); + Set_Node8 (Id, V); + end Set_First_Exit_Statement; + + procedure Set_First_Index (Id : E; V : N) is + begin + pragma Assert (Is_Array_Type (Id) or else Is_String_Type (Id)); + Set_Node17 (Id, V); + end Set_First_Index; + + procedure Set_First_Literal (Id : E; V : E) is + begin + pragma Assert (Is_Enumeration_Type (Id)); + Set_Node17 (Id, V); + end Set_First_Literal; + + procedure Set_First_Optional_Parameter (Id : E; V : E) is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + Set_Node14 (Id, V); + end Set_First_Optional_Parameter; + + procedure Set_First_Private_Entity (Id : E; V : E) is + begin + pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package) + or else Ekind (Id) in Concurrent_Kind); + Set_Node16 (Id, V); + end Set_First_Private_Entity; + + procedure Set_First_Rep_Item (Id : E; V : N) is + begin + Set_Node6 (Id, V); + end Set_First_Rep_Item; + + procedure Set_Float_Rep (Id : E; V : F) is + pragma Assert (Ekind (Id) = E_Floating_Point_Type); + begin + Set_Uint10 (Id, UI_From_Int (F'Pos (V))); + end Set_Float_Rep; + + procedure Set_Freeze_Node (Id : E; V : N) is + begin + Set_Node7 (Id, V); + end Set_Freeze_Node; + + procedure Set_From_With_Type (Id : E; V : B := True) is + begin + pragma Assert + (Is_Type (Id) + or else Ekind (Id) = E_Package); + Set_Flag159 (Id, V); + end Set_From_With_Type; + + procedure Set_Full_View (Id : E; V : E) is + begin + pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Constant); + Set_Node11 (Id, V); + end Set_Full_View; + + procedure Set_Generic_Homonym (Id : E; V : E) is + begin + Set_Node11 (Id, V); + end Set_Generic_Homonym; + + procedure Set_Generic_Renamings (Id : E; V : L) is + begin + Set_Elist23 (Id, V); + end Set_Generic_Renamings; + + procedure Set_Handler_Records (Id : E; V : S) is + begin + Set_List10 (Id, V); + end Set_Handler_Records; + + procedure Set_Has_Aliased_Components (Id : E; V : B := True) is + begin + pragma Assert (Id = Base_Type (Id)); + Set_Flag135 (Id, V); + end Set_Has_Aliased_Components; + + procedure Set_Has_Alignment_Clause (Id : E; V : B := True) is + begin + Set_Flag46 (Id, V); + end Set_Has_Alignment_Clause; + + procedure Set_Has_All_Calls_Remote (Id : E; V : B := True) is + begin + Set_Flag79 (Id, V); + end Set_Has_All_Calls_Remote; + + procedure Set_Has_Anon_Block_Suffix (Id : E; V : B := True) is + begin + Set_Flag201 (Id, V); + end Set_Has_Anon_Block_Suffix; + + procedure Set_Has_Atomic_Components (Id : E; V : B := True) is + begin + pragma Assert (not Is_Type (Id) or else Is_Base_Type (Id)); + Set_Flag86 (Id, V); + end Set_Has_Atomic_Components; + + procedure Set_Has_Biased_Representation (Id : E; V : B := True) is + begin + pragma Assert + ((V = False) or else (Is_Discrete_Type (Id) or else Is_Object (Id))); + Set_Flag139 (Id, V); + end Set_Has_Biased_Representation; + + procedure Set_Has_Completion (Id : E; V : B := True) is + begin + Set_Flag26 (Id, V); + end Set_Has_Completion; + + procedure Set_Has_Completion_In_Body (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag71 (Id, V); + end Set_Has_Completion_In_Body; + + procedure Set_Has_Complex_Representation (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Record_Type); + Set_Flag140 (Id, V); + end Set_Has_Complex_Representation; + + procedure Set_Has_Component_Size_Clause (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Array_Type); + Set_Flag68 (Id, V); + end Set_Has_Component_Size_Clause; + + procedure Set_Has_Constrained_Partial_View (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag187 (Id, V); + end Set_Has_Constrained_Partial_View; + + procedure Set_Has_Contiguous_Rep (Id : E; V : B := True) is + begin + Set_Flag181 (Id, V); + end Set_Has_Contiguous_Rep; + + procedure Set_Has_Controlled_Component (Id : E; V : B := True) is + begin + pragma Assert (Id = Base_Type (Id)); + Set_Flag43 (Id, V); + end Set_Has_Controlled_Component; + + procedure Set_Has_Controlling_Result (Id : E; V : B := True) is + begin + Set_Flag98 (Id, V); + end Set_Has_Controlling_Result; + + procedure Set_Has_Convention_Pragma (Id : E; V : B := True) is + begin + Set_Flag119 (Id, V); + end Set_Has_Convention_Pragma; + + procedure Set_Has_Delayed_Aspects (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag200 (Id, V); + end Set_Has_Delayed_Aspects; + + procedure Set_Has_Delayed_Freeze (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag18 (Id, V); + end Set_Has_Delayed_Freeze; + + procedure Set_Has_Discriminants (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag5 (Id, V); + end Set_Has_Discriminants; + + procedure Set_Has_Dispatch_Table (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Record_Type + and then Is_Tagged_Type (Id)); + Set_Flag220 (Id, V); + end Set_Has_Dispatch_Table; + + procedure Set_Has_Enumeration_Rep_Clause (Id : E; V : B := True) is + begin + pragma Assert (Is_Enumeration_Type (Id)); + Set_Flag66 (Id, V); + end Set_Has_Enumeration_Rep_Clause; + + procedure Set_Has_Exit (Id : E; V : B := True) is + begin + Set_Flag47 (Id, V); + end Set_Has_Exit; + + procedure Set_Has_External_Tag_Rep_Clause (Id : E; V : B := True) is + begin + pragma Assert (Is_Tagged_Type (Id)); + Set_Flag110 (Id, V); + end Set_Has_External_Tag_Rep_Clause; + + procedure Set_Has_Forward_Instantiation (Id : E; V : B := True) is + begin + Set_Flag175 (Id, V); + end Set_Has_Forward_Instantiation; + + procedure Set_Has_Fully_Qualified_Name (Id : E; V : B := True) is + begin + Set_Flag173 (Id, V); + end Set_Has_Fully_Qualified_Name; + + procedure Set_Has_Gigi_Rep_Item (Id : E; V : B := True) is + begin + Set_Flag82 (Id, V); + end Set_Has_Gigi_Rep_Item; + + procedure Set_Has_Homonym (Id : E; V : B := True) is + begin + Set_Flag56 (Id, V); + end Set_Has_Homonym; + + procedure Set_Has_Inheritable_Invariants (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag248 (Id, V); + end Set_Has_Inheritable_Invariants; + + procedure Set_Has_Initial_Value (Id : E; V : B := True) is + begin + pragma Assert (Ekind_In (Id, E_Variable, E_Out_Parameter)); + Set_Flag219 (Id, V); + end Set_Has_Initial_Value; + + procedure Set_Has_Invariants (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id) + or else Ekind (Id) = E_Procedure + or else Ekind (Id) = E_Void); + Set_Flag232 (Id, V); + end Set_Has_Invariants; + + procedure Set_Has_Machine_Radix_Clause (Id : E; V : B := True) is + begin + pragma Assert (Is_Decimal_Fixed_Point_Type (Id)); + Set_Flag83 (Id, V); + end Set_Has_Machine_Radix_Clause; + + procedure Set_Has_Master_Entity (Id : E; V : B := True) is + begin + Set_Flag21 (Id, V); + end Set_Has_Master_Entity; + + procedure Set_Has_Missing_Return (Id : E; V : B := True) is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Generic_Function)); + Set_Flag142 (Id, V); + end Set_Has_Missing_Return; + + procedure Set_Has_Nested_Block_With_Handler (Id : E; V : B := True) is + begin + Set_Flag101 (Id, V); + end Set_Has_Nested_Block_With_Handler; + + procedure Set_Has_Up_Level_Access (Id : E; V : B := True) is + begin + pragma Assert (Ekind_In (Id, E_Variable, E_Constant, E_Loop_Parameter)); + Set_Flag215 (Id, V); + end Set_Has_Up_Level_Access; + + procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True) is + begin + pragma Assert (Id = Base_Type (Id)); + Set_Flag75 (Id, V); + end Set_Has_Non_Standard_Rep; + + procedure Set_Has_Object_Size_Clause (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag172 (Id, V); + end Set_Has_Object_Size_Clause; + + procedure Set_Has_Per_Object_Constraint (Id : E; V : B := True) is + begin + Set_Flag154 (Id, V); + end Set_Has_Per_Object_Constraint; + + procedure Set_Has_Persistent_BSS (Id : E; V : B := True) is + begin + Set_Flag188 (Id, V); + end Set_Has_Persistent_BSS; + + procedure Set_Has_Postconditions (Id : E; V : B := True) is + begin + pragma Assert (Is_Subprogram (Id)); + Set_Flag240 (Id, V); + end Set_Has_Postconditions; + + procedure Set_Has_Pragma_Controlled (Id : E; V : B := True) is + begin + pragma Assert (Is_Access_Type (Id)); + Set_Flag27 (Base_Type (Id), V); + end Set_Has_Pragma_Controlled; + + procedure Set_Has_Pragma_Elaborate_Body (Id : E; V : B := True) is + begin + Set_Flag150 (Id, V); + end Set_Has_Pragma_Elaborate_Body; + + procedure Set_Has_Pragma_Inline (Id : E; V : B := True) is + begin + Set_Flag157 (Id, V); + end Set_Has_Pragma_Inline; + + procedure Set_Has_Pragma_Inline_Always (Id : E; V : B := True) is + begin + Set_Flag230 (Id, V); + end Set_Has_Pragma_Inline_Always; + + procedure Set_Has_Pragma_Ordered (Id : E; V : B := True) is + begin + pragma Assert (Is_Enumeration_Type (Id)); + pragma Assert (Id = Base_Type (Id)); + Set_Flag198 (Id, V); + end Set_Has_Pragma_Ordered; + + procedure Set_Has_Pragma_Pack (Id : E; V : B := True) is + begin + pragma Assert (Is_Array_Type (Id) or else Is_Record_Type (Id)); + pragma Assert (Id = Base_Type (Id)); + Set_Flag121 (Id, V); + end Set_Has_Pragma_Pack; + + procedure Set_Has_Pragma_Preelab_Init (Id : E; V : B := True) is + begin + Set_Flag221 (Id, V); + end Set_Has_Pragma_Preelab_Init; + + procedure Set_Has_Pragma_Pure (Id : E; V : B := True) is + begin + Set_Flag203 (Id, V); + end Set_Has_Pragma_Pure; + + procedure Set_Has_Pragma_Pure_Function (Id : E; V : B := True) is + begin + Set_Flag179 (Id, V); + end Set_Has_Pragma_Pure_Function; + + procedure Set_Has_Pragma_Thread_Local_Storage (Id : E; V : B := True) is + begin + Set_Flag169 (Id, V); + end Set_Has_Pragma_Thread_Local_Storage; + + procedure Set_Has_Pragma_Unmodified (Id : E; V : B := True) is + begin + Set_Flag233 (Id, V); + end Set_Has_Pragma_Unmodified; + + procedure Set_Has_Pragma_Unreferenced (Id : E; V : B := True) is + begin + Set_Flag180 (Id, V); + end Set_Has_Pragma_Unreferenced; + + procedure Set_Has_Pragma_Unreferenced_Objects (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag212 (Id, V); + end Set_Has_Pragma_Unreferenced_Objects; + + procedure Set_Has_Predicates (Id : E; V : B := True) is + begin + Set_Flag250 (Id, V); + end Set_Has_Predicates; + + procedure Set_Has_Primitive_Operations (Id : E; V : B := True) is + begin + pragma Assert (Id = Base_Type (Id)); + Set_Flag120 (Id, V); + end Set_Has_Primitive_Operations; + + procedure Set_Has_Private_Declaration (Id : E; V : B := True) is + begin + Set_Flag155 (Id, V); + end Set_Has_Private_Declaration; + + procedure Set_Has_Qualified_Name (Id : E; V : B := True) is + begin + Set_Flag161 (Id, V); + end Set_Has_Qualified_Name; + + procedure Set_Has_RACW (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Package); + Set_Flag214 (Id, V); + end Set_Has_RACW; + + procedure Set_Has_Record_Rep_Clause (Id : E; V : B := True) is + begin + pragma Assert (Id = Base_Type (Id)); + Set_Flag65 (Id, V); + end Set_Has_Record_Rep_Clause; + + procedure Set_Has_Recursive_Call (Id : E; V : B := True) is + begin + pragma Assert (Is_Subprogram (Id)); + Set_Flag143 (Id, V); + end Set_Has_Recursive_Call; + + procedure Set_Has_Size_Clause (Id : E; V : B := True) is + begin + Set_Flag29 (Id, V); + end Set_Has_Size_Clause; + + procedure Set_Has_Small_Clause (Id : E; V : B := True) is + begin + Set_Flag67 (Id, V); + end Set_Has_Small_Clause; + + procedure Set_Has_Specified_Layout (Id : E; V : B := True) is + begin + pragma Assert (Id = Base_Type (Id)); + Set_Flag100 (Id, V); + end Set_Has_Specified_Layout; + + procedure Set_Has_Specified_Stream_Input (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag190 (Id, V); + end Set_Has_Specified_Stream_Input; + + procedure Set_Has_Specified_Stream_Output (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag191 (Id, V); + end Set_Has_Specified_Stream_Output; + + procedure Set_Has_Specified_Stream_Read (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag192 (Id, V); + end Set_Has_Specified_Stream_Read; + + procedure Set_Has_Specified_Stream_Write (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag193 (Id, V); + end Set_Has_Specified_Stream_Write; + + procedure Set_Has_Static_Discriminants (Id : E; V : B := True) is + begin + Set_Flag211 (Id, V); + end Set_Has_Static_Discriminants; + + procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True) is + begin + pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id)); + pragma Assert (Id = Base_Type (Id)); + Set_Flag23 (Id, V); + end Set_Has_Storage_Size_Clause; + + procedure Set_Has_Stream_Size_Clause (Id : E; V : B := True) is + begin + pragma Assert (Is_Elementary_Type (Id)); + Set_Flag184 (Id, V); + end Set_Has_Stream_Size_Clause; + + procedure Set_Has_Subprogram_Descriptor (Id : E; V : B := True) is + begin + Set_Flag93 (Id, V); + end Set_Has_Subprogram_Descriptor; + + procedure Set_Has_Task (Id : E; V : B := True) is + begin + pragma Assert (Id = Base_Type (Id)); + Set_Flag30 (Id, V); + end Set_Has_Task; + + procedure Set_Has_Thunks (Id : E; V : B := True) is + begin + pragma Assert (Is_Tag (Id)); + Set_Flag228 (Id, V); + end Set_Has_Thunks; + + procedure Set_Has_Unchecked_Union (Id : E; V : B := True) is + begin + pragma Assert (Id = Base_Type (Id)); + Set_Flag123 (Id, V); + end Set_Has_Unchecked_Union; + + procedure Set_Has_Unknown_Discriminants (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag72 (Id, V); + end Set_Has_Unknown_Discriminants; + + procedure Set_Has_Volatile_Components (Id : E; V : B := True) is + begin + pragma Assert (not Is_Type (Id) or else Is_Base_Type (Id)); + Set_Flag87 (Id, V); + end Set_Has_Volatile_Components; + + procedure Set_Has_Xref_Entry (Id : E; V : B := True) is + begin + Set_Flag182 (Id, V); + end Set_Has_Xref_Entry; + + procedure Set_Hiding_Loop_Variable (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Variable); + Set_Node8 (Id, V); + end Set_Hiding_Loop_Variable; + + procedure Set_Homonym (Id : E; V : E) is + begin + pragma Assert (Id /= V); + Set_Node4 (Id, V); + end Set_Homonym; + + procedure Set_Interface_Alias (Id : E; V : E) is + begin + pragma Assert + (Is_Internal (Id) + and then Is_Hidden (Id) + and then (Ekind_In (Id, E_Procedure, E_Function))); + Set_Node25 (Id, V); + end Set_Interface_Alias; + + procedure Set_Interfaces (Id : E; V : L) is + begin + pragma Assert (Is_Record_Type (Id)); + Set_Elist25 (Id, V); + end Set_Interfaces; + + procedure Set_In_Package_Body (Id : E; V : B := True) is + begin + Set_Flag48 (Id, V); + end Set_In_Package_Body; + + procedure Set_In_Private_Part (Id : E; V : B := True) is + begin + Set_Flag45 (Id, V); + end Set_In_Private_Part; + + procedure Set_In_Use (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag8 (Id, V); + end Set_In_Use; + + procedure Set_Inner_Instances (Id : E; V : L) is + begin + Set_Elist23 (Id, V); + end Set_Inner_Instances; + + procedure Set_Interface_Name (Id : E; V : N) is + begin + Set_Node21 (Id, V); + end Set_Interface_Name; + + procedure Set_Is_Abstract_Subprogram (Id : E; V : B := True) is + begin + pragma Assert (Is_Overloadable (Id)); + Set_Flag19 (Id, V); + end Set_Is_Abstract_Subprogram; + + procedure Set_Is_Abstract_Type (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag146 (Id, V); + end Set_Is_Abstract_Type; + + procedure Set_Is_Local_Anonymous_Access (Id : E; V : B := True) is + begin + pragma Assert (Is_Access_Type (Id)); + Set_Flag194 (Id, V); + end Set_Is_Local_Anonymous_Access; + + procedure Set_Is_Access_Constant (Id : E; V : B := True) is + begin + pragma Assert (Is_Access_Type (Id)); + Set_Flag69 (Id, V); + end Set_Is_Access_Constant; + + procedure Set_Is_Ada_2005_Only (Id : E; V : B := True) is + begin + Set_Flag185 (Id, V); + end Set_Is_Ada_2005_Only; + + procedure Set_Is_Ada_2012_Only (Id : E; V : B := True) is + begin + Set_Flag199 (Id, V); + end Set_Is_Ada_2012_Only; + + procedure Set_Is_Aliased (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag15 (Id, V); + end Set_Is_Aliased; + + procedure Set_Is_AST_Entry (Id : E; V : B := True) is + begin + pragma Assert (Is_Entry (Id)); + Set_Flag132 (Id, V); + end Set_Is_AST_Entry; + + procedure Set_Is_Asynchronous (Id : E; V : B := True) is + begin + pragma Assert + (Ekind (Id) = E_Procedure or else Is_Type (Id)); + Set_Flag81 (Id, V); + end Set_Is_Asynchronous; + + procedure Set_Is_Atomic (Id : E; V : B := True) is + begin + Set_Flag85 (Id, V); + end Set_Is_Atomic; + + procedure Set_Is_Bit_Packed_Array (Id : E; V : B := True) is + begin + pragma Assert ((not V) + or else (Is_Array_Type (Id) and then Is_Base_Type (Id))); + + Set_Flag122 (Id, V); + end Set_Is_Bit_Packed_Array; + + procedure Set_Is_Called (Id : E; V : B := True) is + begin + pragma Assert (Ekind_In (Id, E_Procedure, E_Function)); + Set_Flag102 (Id, V); + end Set_Is_Called; + + procedure Set_Is_Character_Type (Id : E; V : B := True) is + begin + Set_Flag63 (Id, V); + end Set_Is_Character_Type; + + procedure Set_Is_Child_Unit (Id : E; V : B := True) is + begin + Set_Flag73 (Id, V); + end Set_Is_Child_Unit; + + procedure Set_Is_Class_Wide_Equivalent_Type (Id : E; V : B := True) is + begin + Set_Flag35 (Id, V); + end Set_Is_Class_Wide_Equivalent_Type; + + procedure Set_Is_Compilation_Unit (Id : E; V : B := True) is + begin + Set_Flag149 (Id, V); + end Set_Is_Compilation_Unit; + + procedure Set_Is_Completely_Hidden (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Discriminant); + Set_Flag103 (Id, V); + end Set_Is_Completely_Hidden; + + procedure Set_Is_Concurrent_Record_Type (Id : E; V : B := True) is + begin + Set_Flag20 (Id, V); + end Set_Is_Concurrent_Record_Type; + + procedure Set_Is_Constr_Subt_For_U_Nominal (Id : E; V : B := True) is + begin + Set_Flag80 (Id, V); + end Set_Is_Constr_Subt_For_U_Nominal; + + procedure Set_Is_Constr_Subt_For_UN_Aliased (Id : E; V : B := True) is + begin + Set_Flag141 (Id, V); + end Set_Is_Constr_Subt_For_UN_Aliased; + + procedure Set_Is_Constrained (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag12 (Id, V); + end Set_Is_Constrained; + + procedure Set_Is_Constructor (Id : E; V : B := True) is + begin + Set_Flag76 (Id, V); + end Set_Is_Constructor; + + procedure Set_Is_Controlled (Id : E; V : B := True) is + begin + pragma Assert (Id = Base_Type (Id)); + Set_Flag42 (Id, V); + end Set_Is_Controlled; + + procedure Set_Is_Controlling_Formal (Id : E; V : B := True) is + begin + pragma Assert (Is_Formal (Id)); + Set_Flag97 (Id, V); + end Set_Is_Controlling_Formal; + + procedure Set_Is_CPP_Class (Id : E; V : B := True) is + begin + Set_Flag74 (Id, V); + end Set_Is_CPP_Class; + + procedure Set_Is_Descendent_Of_Address (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag223 (Id, V); + end Set_Is_Descendent_Of_Address; + + procedure Set_Is_Discrim_SO_Function (Id : E; V : B := True) is + begin + Set_Flag176 (Id, V); + end Set_Is_Discrim_SO_Function; + + procedure Set_Is_Dispatch_Table_Entity (Id : E; V : B := True) is + begin + Set_Flag234 (Id, V); + end Set_Is_Dispatch_Table_Entity; + + procedure Set_Is_Dispatching_Operation (Id : E; V : B := True) is + begin + pragma Assert + (V = False + or else + Is_Overloadable (Id) + or else + Ekind (Id) = E_Subprogram_Type); + + Set_Flag6 (Id, V); + end Set_Is_Dispatching_Operation; + + procedure Set_Is_Eliminated (Id : E; V : B := True) is + begin + Set_Flag124 (Id, V); + end Set_Is_Eliminated; + + procedure Set_Is_Entry_Formal (Id : E; V : B := True) is + begin + Set_Flag52 (Id, V); + end Set_Is_Entry_Formal; + + procedure Set_Is_Exported (Id : E; V : B := True) is + begin + Set_Flag99 (Id, V); + end Set_Is_Exported; + + procedure Set_Is_First_Subtype (Id : E; V : B := True) is + begin + Set_Flag70 (Id, V); + end Set_Is_First_Subtype; + + procedure Set_Is_For_Access_Subtype (Id : E; V : B := True) is + begin + pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Private_Subtype)); + Set_Flag118 (Id, V); + end Set_Is_For_Access_Subtype; + + procedure Set_Is_Formal_Subprogram (Id : E; V : B := True) is + begin + Set_Flag111 (Id, V); + end Set_Is_Formal_Subprogram; + + procedure Set_Is_Frozen (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag4 (Id, V); + end Set_Is_Frozen; + + procedure Set_Is_Generic_Actual_Type (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag94 (Id, V); + end Set_Is_Generic_Actual_Type; + + procedure Set_Is_Generic_Instance (Id : E; V : B := True) is + begin + Set_Flag130 (Id, V); + end Set_Is_Generic_Instance; + + procedure Set_Is_Generic_Type (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag13 (Id, V); + end Set_Is_Generic_Type; + + procedure Set_Is_Hidden (Id : E; V : B := True) is + begin + Set_Flag57 (Id, V); + end Set_Is_Hidden; + + procedure Set_Is_Hidden_Open_Scope (Id : E; V : B := True) is + begin + Set_Flag171 (Id, V); + end Set_Is_Hidden_Open_Scope; + + procedure Set_Is_Immediately_Visible (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag7 (Id, V); + end Set_Is_Immediately_Visible; + + procedure Set_Is_Imported (Id : E; V : B := True) is + begin + Set_Flag24 (Id, V); + end Set_Is_Imported; + + procedure Set_Is_Inlined (Id : E; V : B := True) is + begin + Set_Flag11 (Id, V); + end Set_Is_Inlined; + + procedure Set_Is_Interface (Id : E; V : B := True) is + begin + pragma Assert + (Ekind_In (Id, E_Record_Type, + E_Record_Subtype, + E_Record_Type_With_Private, + E_Record_Subtype_With_Private, + E_Class_Wide_Type, + E_Class_Wide_Subtype)); + Set_Flag186 (Id, V); + end Set_Is_Interface; + + procedure Set_Is_Instantiated (Id : E; V : B := True) is + begin + Set_Flag126 (Id, V); + end Set_Is_Instantiated; + + procedure Set_Is_Internal (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag17 (Id, V); + end Set_Is_Internal; + + procedure Set_Is_Interrupt_Handler (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag89 (Id, V); + end Set_Is_Interrupt_Handler; + + procedure Set_Is_Intrinsic_Subprogram (Id : E; V : B := True) is + begin + Set_Flag64 (Id, V); + end Set_Is_Intrinsic_Subprogram; + + procedure Set_Is_Itype (Id : E; V : B := True) is + begin + Set_Flag91 (Id, V); + end Set_Is_Itype; + + procedure Set_Is_Known_Non_Null (Id : E; V : B := True) is + begin + Set_Flag37 (Id, V); + end Set_Is_Known_Non_Null; + + procedure Set_Is_Known_Null (Id : E; V : B := True) is + begin + Set_Flag204 (Id, V); + end Set_Is_Known_Null; + + procedure Set_Is_Known_Valid (Id : E; V : B := True) is + begin + Set_Flag170 (Id, V); + end Set_Is_Known_Valid; + + procedure Set_Is_Limited_Composite (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag106 (Id, V); + end Set_Is_Limited_Composite; + + procedure Set_Is_Limited_Interface (Id : E; V : B := True) is + begin + pragma Assert (Is_Interface (Id)); + Set_Flag197 (Id, V); + end Set_Is_Limited_Interface; + + procedure Set_Is_Limited_Record (Id : E; V : B := True) is + begin + Set_Flag25 (Id, V); + end Set_Is_Limited_Record; + + procedure Set_Is_Machine_Code_Subprogram (Id : E; V : B := True) is + begin + pragma Assert (Is_Subprogram (Id)); + Set_Flag137 (Id, V); + end Set_Is_Machine_Code_Subprogram; + + procedure Set_Is_Non_Static_Subtype (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag109 (Id, V); + end Set_Is_Non_Static_Subtype; + + procedure Set_Is_Null_Init_Proc (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Procedure); + Set_Flag178 (Id, V); + end Set_Is_Null_Init_Proc; + + procedure Set_Is_Obsolescent (Id : E; V : B := True) is + begin + Set_Flag153 (Id, V); + end Set_Is_Obsolescent; + + procedure Set_Is_Only_Out_Parameter (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Out_Parameter); + Set_Flag226 (Id, V); + end Set_Is_Only_Out_Parameter; + + procedure Set_Is_Optional_Parameter (Id : E; V : B := True) is + begin + pragma Assert (Is_Formal (Id)); + Set_Flag134 (Id, V); + end Set_Is_Optional_Parameter; + + procedure Set_Is_Package_Body_Entity (Id : E; V : B := True) is + begin + Set_Flag160 (Id, V); + end Set_Is_Package_Body_Entity; + + procedure Set_Is_Packed (Id : E; V : B := True) is + begin + pragma Assert (Id = Base_Type (Id)); + Set_Flag51 (Id, V); + end Set_Is_Packed; + + procedure Set_Is_Packed_Array_Type (Id : E; V : B := True) is + begin + Set_Flag138 (Id, V); + end Set_Is_Packed_Array_Type; + + procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag9 (Id, V); + end Set_Is_Potentially_Use_Visible; + + procedure Set_Is_Preelaborated (Id : E; V : B := True) is + begin + Set_Flag59 (Id, V); + end Set_Is_Preelaborated; + + procedure Set_Is_Primitive (Id : E; V : B := True) is + begin + pragma Assert + (Is_Overloadable (Id) + or else Ekind_In (Id, E_Generic_Function, E_Generic_Procedure)); + Set_Flag218 (Id, V); + end Set_Is_Primitive; + + procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True) is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + Set_Flag195 (Id, V); + end Set_Is_Primitive_Wrapper; + + procedure Set_Is_Private_Composite (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag107 (Id, V); + end Set_Is_Private_Composite; + + procedure Set_Is_Private_Descendant (Id : E; V : B := True) is + begin + Set_Flag53 (Id, V); + end Set_Is_Private_Descendant; + + procedure Set_Is_Private_Primitive (Id : E; V : B := True) is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + Set_Flag245 (Id, V); + end Set_Is_Private_Primitive; + + procedure Set_Is_Public (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag10 (Id, V); + end Set_Is_Public; + + procedure Set_Is_Pure (Id : E; V : B := True) is + begin + Set_Flag44 (Id, V); + end Set_Is_Pure; + + procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True) is + begin + pragma Assert (Is_Access_Type (Id)); + Set_Flag189 (Id, V); + end Set_Is_Pure_Unit_Access_Type; + + procedure Set_Is_RACW_Stub_Type (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag244 (Id, V); + end Set_Is_RACW_Stub_Type; + + procedure Set_Is_Raised (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Exception); + Set_Flag224 (Id, V); + end Set_Is_Raised; + + procedure Set_Is_Remote_Call_Interface (Id : E; V : B := True) is + begin + Set_Flag62 (Id, V); + end Set_Is_Remote_Call_Interface; + + procedure Set_Is_Remote_Types (Id : E; V : B := True) is + begin + Set_Flag61 (Id, V); + end Set_Is_Remote_Types; + + procedure Set_Is_Renaming_Of_Object (Id : E; V : B := True) is + begin + Set_Flag112 (Id, V); + end Set_Is_Renaming_Of_Object; + + procedure Set_Is_Return_Object (Id : E; V : B := True) is + begin + Set_Flag209 (Id, V); + end Set_Is_Return_Object; + + procedure Set_Is_Shared_Passive (Id : E; V : B := True) is + begin + Set_Flag60 (Id, V); + end Set_Is_Shared_Passive; + + procedure Set_Is_Statically_Allocated (Id : E; V : B := True) is + begin + pragma Assert + (Is_Type (Id) + or else Ekind_In (Id, E_Exception, + E_Variable, + E_Constant, + E_Void)); + Set_Flag28 (Id, V); + end Set_Is_Statically_Allocated; + + procedure Set_Is_Tag (Id : E; V : B := True) is + begin + pragma Assert (Ekind_In (Id, E_Component, E_Constant, E_Variable)); + Set_Flag78 (Id, V); + end Set_Is_Tag; + + procedure Set_Is_Tagged_Type (Id : E; V : B := True) is + begin + Set_Flag55 (Id, V); + end Set_Is_Tagged_Type; + + procedure Set_Is_Thunk (Id : E; V : B := True) is + begin + Set_Flag225 (Id, V); + end Set_Is_Thunk; + + procedure Set_Is_Trivial_Subprogram (Id : E; V : B := True) is + begin + Set_Flag235 (Id, V); + end Set_Is_Trivial_Subprogram; + + procedure Set_Is_True_Constant (Id : E; V : B := True) is + begin + Set_Flag163 (Id, V); + end Set_Is_True_Constant; + + procedure Set_Is_Unchecked_Union (Id : E; V : B := True) is + begin + pragma Assert (Id = Base_Type (Id)); + Set_Flag117 (Id, V); + end Set_Is_Unchecked_Union; + + procedure Set_Is_Underlying_Record_View (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Record_Type); + Set_Flag246 (Id, V); + end Set_Is_Underlying_Record_View; + + procedure Set_Is_Unsigned_Type (Id : E; V : B := True) is + begin + pragma Assert (Is_Discrete_Or_Fixed_Point_Type (Id)); + Set_Flag144 (Id, V); + end Set_Is_Unsigned_Type; + + procedure Set_Is_Valued_Procedure (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Procedure); + Set_Flag127 (Id, V); + end Set_Is_Valued_Procedure; + + procedure Set_Is_Visible_Child_Unit (Id : E; V : B := True) is + begin + pragma Assert (Is_Child_Unit (Id)); + Set_Flag116 (Id, V); + end Set_Is_Visible_Child_Unit; + + procedure Set_Is_Visible_Formal (Id : E; V : B := True) is + begin + Set_Flag206 (Id, V); + end Set_Is_Visible_Formal; + + procedure Set_Is_VMS_Exception (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Exception); + Set_Flag133 (Id, V); + end Set_Is_VMS_Exception; + + procedure Set_Is_Volatile (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag16 (Id, V); + end Set_Is_Volatile; + + procedure Set_Itype_Printed (Id : E; V : B := True) is + begin + pragma Assert (Is_Itype (Id)); + Set_Flag202 (Id, V); + end Set_Itype_Printed; + + procedure Set_Kill_Elaboration_Checks (Id : E; V : B := True) is + begin + Set_Flag32 (Id, V); + end Set_Kill_Elaboration_Checks; + + procedure Set_Kill_Range_Checks (Id : E; V : B := True) is + begin + Set_Flag33 (Id, V); + end Set_Kill_Range_Checks; + + procedure Set_Kill_Tag_Checks (Id : E; V : B := True) is + begin + Set_Flag34 (Id, V); + end Set_Kill_Tag_Checks; + + procedure Set_Known_To_Have_Preelab_Init (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag207 (Id, V); + end Set_Known_To_Have_Preelab_Init; + + procedure Set_Last_Assignment (Id : E; V : N) is + begin + pragma Assert (Is_Assignable (Id)); + Set_Node26 (Id, V); + end Set_Last_Assignment; + + procedure Set_Last_Entity (Id : E; V : E) is + begin + Set_Node20 (Id, V); + end Set_Last_Entity; + + procedure Set_Limited_View (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Package); + Set_Node23 (Id, V); + end Set_Limited_View; + + procedure Set_Lit_Indexes (Id : E; V : E) is + begin + pragma Assert (Is_Enumeration_Type (Id) and then Root_Type (Id) = Id); + Set_Node15 (Id, V); + end Set_Lit_Indexes; + + procedure Set_Lit_Strings (Id : E; V : E) is + begin + pragma Assert (Is_Enumeration_Type (Id) and then Root_Type (Id) = Id); + Set_Node16 (Id, V); + end Set_Lit_Strings; + + procedure Set_Low_Bound_Tested (Id : E; V : B := True) is + begin + pragma Assert (Is_Formal (Id)); + Set_Flag205 (Id, V); + end Set_Low_Bound_Tested; + + procedure Set_Machine_Radix_10 (Id : E; V : B := True) is + begin + pragma Assert (Is_Decimal_Fixed_Point_Type (Id)); + Set_Flag84 (Id, V); + end Set_Machine_Radix_10; + + procedure Set_Master_Id (Id : E; V : E) is + begin + pragma Assert (Is_Access_Type (Id)); + Set_Node17 (Id, V); + end Set_Master_Id; + + procedure Set_Materialize_Entity (Id : E; V : B := True) is + begin + Set_Flag168 (Id, V); + end Set_Materialize_Entity; + + procedure Set_Mechanism (Id : E; V : M) is + begin + pragma Assert (Ekind (Id) = E_Function or else Is_Formal (Id)); + Set_Uint8 (Id, UI_From_Int (V)); + end Set_Mechanism; + + procedure Set_Modulus (Id : E; V : U) is + begin + pragma Assert (Ekind (Id) = E_Modular_Integer_Type); + Set_Uint17 (Id, V); + end Set_Modulus; + + procedure Set_Must_Be_On_Byte_Boundary (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag183 (Id, V); + end Set_Must_Be_On_Byte_Boundary; + + procedure Set_Must_Have_Preelab_Init (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag208 (Id, V); + end Set_Must_Have_Preelab_Init; + + procedure Set_Needs_Debug_Info (Id : E; V : B := True) is + begin + Set_Flag147 (Id, V); + end Set_Needs_Debug_Info; + + procedure Set_Needs_No_Actuals (Id : E; V : B := True) is + begin + pragma Assert + (Is_Overloadable (Id) + or else Ekind_In (Id, E_Subprogram_Type, E_Entry_Family)); + Set_Flag22 (Id, V); + end Set_Needs_No_Actuals; + + procedure Set_Never_Set_In_Source (Id : E; V : B := True) is + begin + Set_Flag115 (Id, V); + end Set_Never_Set_In_Source; + + procedure Set_Next_Inlined_Subprogram (Id : E; V : E) is + begin + Set_Node12 (Id, V); + end Set_Next_Inlined_Subprogram; + + procedure Set_No_Pool_Assigned (Id : E; V : B := True) is + begin + pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id)); + Set_Flag131 (Id, V); + end Set_No_Pool_Assigned; + + procedure Set_No_Return (Id : E; V : B := True) is + begin + pragma Assert + (V = False or else Ekind_In (Id, E_Procedure, E_Generic_Procedure)); + Set_Flag113 (Id, V); + end Set_No_Return; + + procedure Set_No_Strict_Aliasing (Id : E; V : B := True) is + begin + pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id)); + Set_Flag136 (Id, V); + end Set_No_Strict_Aliasing; + + procedure Set_Non_Binary_Modulus (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id) and then Is_Base_Type (Id)); + Set_Flag58 (Id, V); + end Set_Non_Binary_Modulus; + + procedure Set_Non_Limited_View (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) in Incomplete_Kind); + Set_Node17 (Id, V); + end Set_Non_Limited_View; + + procedure Set_Nonzero_Is_True (Id : E; V : B := True) is + begin + pragma Assert + (Root_Type (Id) = Standard_Boolean + and then Ekind (Id) = E_Enumeration_Type); + Set_Flag162 (Id, V); + end Set_Nonzero_Is_True; + + procedure Set_Normalized_First_Bit (Id : E; V : U) is + begin + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + Set_Uint8 (Id, V); + end Set_Normalized_First_Bit; + + procedure Set_Normalized_Position (Id : E; V : U) is + begin + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + Set_Uint14 (Id, V); + end Set_Normalized_Position; + + procedure Set_Normalized_Position_Max (Id : E; V : U) is + begin + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + Set_Uint10 (Id, V); + end Set_Normalized_Position_Max; + + procedure Set_OK_To_Rename (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Variable); + Set_Flag247 (Id, V); + end Set_OK_To_Rename; + + procedure Set_OK_To_Reorder_Components (Id : E; V : B := True) is + begin + pragma Assert + (Is_Record_Type (Id) and then Is_Base_Type (Id)); + Set_Flag239 (Id, V); + end Set_OK_To_Reorder_Components; + + procedure Set_Optimize_Alignment_Space (Id : E; V : B := True) is + begin + pragma Assert + (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable)); + Set_Flag241 (Id, V); + end Set_Optimize_Alignment_Space; + + procedure Set_Optimize_Alignment_Time (Id : E; V : B := True) is + begin + pragma Assert + (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable)); + Set_Flag242 (Id, V); + end Set_Optimize_Alignment_Time; + + procedure Set_Original_Array_Type (Id : E; V : E) is + begin + pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id)); + Set_Node21 (Id, V); + end Set_Original_Array_Type; + + procedure Set_Original_Record_Component (Id : E; V : E) is + begin + pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant)); + Set_Node22 (Id, V); + end Set_Original_Record_Component; + + procedure Set_Overlays_Constant (Id : E; V : B := True) is + begin + Set_Flag243 (Id, V); + end Set_Overlays_Constant; + + procedure Set_Overridden_Operation (Id : E; V : E) is + begin + Set_Node26 (Id, V); + end Set_Overridden_Operation; + + procedure Set_Package_Instantiation (Id : E; V : N) is + begin + pragma Assert (Ekind_In (Id, E_Void, E_Generic_Package, E_Package)); + Set_Node26 (Id, V); + end Set_Package_Instantiation; + + procedure Set_Packed_Array_Type (Id : E; V : E) is + begin + pragma Assert (Is_Array_Type (Id)); + Set_Node23 (Id, V); + end Set_Packed_Array_Type; + + procedure Set_Parent_Subtype (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Record_Type); + Set_Node19 (Id, V); + end Set_Parent_Subtype; + + procedure Set_Postcondition_Proc (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Procedure); + Set_Node8 (Id, V); + end Set_Postcondition_Proc; + + procedure Set_PPC_Wrapper (Id : E; V : E) is + begin + pragma Assert (Ekind_In (Id, E_Entry, E_Entry_Family)); + Set_Node25 (Id, V); + end Set_PPC_Wrapper; + + procedure Set_Direct_Primitive_Operations (Id : E; V : L) is + begin + pragma Assert (Is_Tagged_Type (Id)); + Set_Elist10 (Id, V); + end Set_Direct_Primitive_Operations; + + procedure Set_Prival (Id : E; V : E) is + begin + pragma Assert (Is_Protected_Component (Id)); + Set_Node17 (Id, V); + end Set_Prival; + + procedure Set_Prival_Link (Id : E; V : E) is + begin + pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); + Set_Node20 (Id, V); + end Set_Prival_Link; + + procedure Set_Private_Dependents (Id : E; V : L) is + begin + pragma Assert (Is_Incomplete_Or_Private_Type (Id)); + Set_Elist18 (Id, V); + end Set_Private_Dependents; + + procedure Set_Private_View (Id : E; V : N) is + begin + pragma Assert (Is_Private_Type (Id)); + Set_Node22 (Id, V); + end Set_Private_View; + + procedure Set_Protected_Body_Subprogram (Id : E; V : E) is + begin + pragma Assert (Is_Subprogram (Id) or else Is_Entry (Id)); + Set_Node11 (Id, V); + end Set_Protected_Body_Subprogram; + + procedure Set_Protected_Formal (Id : E; V : E) is + begin + pragma Assert (Is_Formal (Id)); + Set_Node22 (Id, V); + end Set_Protected_Formal; + + procedure Set_Protection_Object (Id : E; V : E) is + begin + pragma Assert (Ekind_In (Id, E_Entry, + E_Entry_Family, + E_Function, + E_Procedure)); + Set_Node23 (Id, V); + end Set_Protection_Object; + + procedure Set_Reachable (Id : E; V : B := True) is + begin + Set_Flag49 (Id, V); + end Set_Reachable; + + procedure Set_Referenced (Id : E; V : B := True) is + begin + Set_Flag156 (Id, V); + end Set_Referenced; + + procedure Set_Referenced_As_LHS (Id : E; V : B := True) is + begin + Set_Flag36 (Id, V); + end Set_Referenced_As_LHS; + + procedure Set_Referenced_As_Out_Parameter (Id : E; V : B := True) is + begin + Set_Flag227 (Id, V); + end Set_Referenced_As_Out_Parameter; + + procedure Set_Register_Exception_Call (Id : E; V : N) is + begin + pragma Assert (Ekind (Id) = E_Exception); + Set_Node20 (Id, V); + end Set_Register_Exception_Call; + + procedure Set_Related_Array_Object (Id : E; V : E) is + begin + pragma Assert (Is_Array_Type (Id)); + Set_Node19 (Id, V); + end Set_Related_Array_Object; + + procedure Set_Related_Expression (Id : E; V : N) is + begin + pragma Assert (Ekind (Id) in Type_Kind + or else Ekind_In (Id, E_Constant, E_Variable, E_Void)); + Set_Node24 (Id, V); + end Set_Related_Expression; + + procedure Set_Related_Instance (Id : E; V : E) is + begin + pragma Assert (Ekind_In (Id, E_Package, E_Package_Body)); + Set_Node15 (Id, V); + end Set_Related_Instance; + + procedure Set_Related_Type (Id : E; V : E) is + begin + pragma Assert (Ekind_In (Id, E_Component, E_Constant, E_Variable)); + Set_Node27 (Id, V); + end Set_Related_Type; + + procedure Set_Relative_Deadline_Variable (Id : E; V : E) is + begin + pragma Assert (Is_Task_Type (Id) and then Is_Base_Type (Id)); + Set_Node26 (Id, V); + end Set_Relative_Deadline_Variable; + + procedure Set_Renamed_Entity (Id : E; V : N) is + begin + Set_Node18 (Id, V); + end Set_Renamed_Entity; + + procedure Set_Renamed_In_Spec (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Package); + Set_Flag231 (Id, V); + end Set_Renamed_In_Spec; + + procedure Set_Renamed_Object (Id : E; V : N) is + begin + Set_Node18 (Id, V); + end Set_Renamed_Object; + + procedure Set_Renaming_Map (Id : E; V : U) is + begin + Set_Uint9 (Id, V); + end Set_Renaming_Map; + + procedure Set_Requires_Overriding (Id : E; V : B := True) is + begin + pragma Assert (Is_Overloadable (Id)); + Set_Flag213 (Id, V); + end Set_Requires_Overriding; + + procedure Set_Return_Present (Id : E; V : B := True) is + begin + Set_Flag54 (Id, V); + end Set_Return_Present; + + procedure Set_Return_Applies_To (Id : E; V : N) is + begin + Set_Node8 (Id, V); + end Set_Return_Applies_To; + + procedure Set_Returns_By_Ref (Id : E; V : B := True) is + begin + Set_Flag90 (Id, V); + end Set_Returns_By_Ref; + + procedure Set_Reverse_Bit_Order (Id : E; V : B := True) is + begin + pragma Assert + (Is_Record_Type (Id) and then Is_Base_Type (Id)); + Set_Flag164 (Id, V); + end Set_Reverse_Bit_Order; + + procedure Set_RM_Size (Id : E; V : U) is + begin + pragma Assert (Is_Type (Id)); + Set_Uint13 (Id, V); + end Set_RM_Size; + + procedure Set_Scalar_Range (Id : E; V : N) is + begin + Set_Node20 (Id, V); + end Set_Scalar_Range; + + procedure Set_Scale_Value (Id : E; V : U) is + begin + Set_Uint15 (Id, V); + end Set_Scale_Value; + + procedure Set_Scope_Depth_Value (Id : E; V : U) is + begin + pragma Assert (not Is_Record_Type (Id)); + Set_Uint22 (Id, V); + end Set_Scope_Depth_Value; + + procedure Set_Sec_Stack_Needed_For_Return (Id : E; V : B := True) is + begin + Set_Flag167 (Id, V); + end Set_Sec_Stack_Needed_For_Return; + + procedure Set_Shadow_Entities (Id : E; V : S) is + begin + pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)); + Set_List14 (Id, V); + end Set_Shadow_Entities; + + procedure Set_Shared_Var_Procs_Instance (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Variable); + Set_Node22 (Id, V); + end Set_Shared_Var_Procs_Instance; + + procedure Set_Size_Check_Code (Id : E; V : N) is + begin + pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); + Set_Node19 (Id, V); + end Set_Size_Check_Code; + + procedure Set_Size_Depends_On_Discriminant (Id : E; V : B := True) is + begin + Set_Flag177 (Id, V); + end Set_Size_Depends_On_Discriminant; + + procedure Set_Size_Known_At_Compile_Time (Id : E; V : B := True) is + begin + Set_Flag92 (Id, V); + end Set_Size_Known_At_Compile_Time; + + procedure Set_Small_Value (Id : E; V : R) is + begin + pragma Assert (Is_Fixed_Point_Type (Id)); + Set_Ureal21 (Id, V); + end Set_Small_Value; + + procedure Set_Spec_Entity (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Package_Body or else Is_Formal (Id)); + Set_Node19 (Id, V); + end Set_Spec_Entity; + + procedure Set_Spec_PPC_List (Id : E; V : N) is + begin + pragma Assert + (Ekind_In (Id, E_Entry, E_Entry_Family, E_Void) + or else Is_Subprogram (Id) + or else Is_Generic_Subprogram (Id)); + Set_Node24 (Id, V); + end Set_Spec_PPC_List; + + procedure Set_Static_Predicate (Id : E; V : S) is + begin + pragma Assert + (Ekind_In (Id, E_Enumeration_Subtype, + E_Modular_Integer_Subtype, + E_Signed_Integer_Subtype) + and then Has_Predicates (Id)); + Set_List25 (Id, V); + end Set_Static_Predicate; + + procedure Set_Storage_Size_Variable (Id : E; V : E) is + begin + pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id)); + pragma Assert (Id = Base_Type (Id)); + Set_Node15 (Id, V); + end Set_Storage_Size_Variable; + + procedure Set_Static_Elaboration_Desired (Id : E; V : B) is + begin + pragma Assert (Ekind (Id) = E_Package); + Set_Flag77 (Id, V); + end Set_Static_Elaboration_Desired; + + procedure Set_Static_Initialization (Id : E; V : N) is + begin + pragma Assert + (Ekind (Id) = E_Procedure and then not Is_Dispatching_Operation (Id)); + Set_Node26 (Id, V); + end Set_Static_Initialization; + + procedure Set_Stored_Constraint (Id : E; V : L) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Elist23 (Id, V); + end Set_Stored_Constraint; + + procedure Set_Strict_Alignment (Id : E; V : B := True) is + begin + pragma Assert (Id = Base_Type (Id)); + Set_Flag145 (Id, V); + end Set_Strict_Alignment; + + procedure Set_String_Literal_Length (Id : E; V : U) is + begin + pragma Assert (Ekind (Id) = E_String_Literal_Subtype); + Set_Uint16 (Id, V); + end Set_String_Literal_Length; + + procedure Set_String_Literal_Low_Bound (Id : E; V : N) is + begin + pragma Assert (Ekind (Id) = E_String_Literal_Subtype); + Set_Node15 (Id, V); + end Set_String_Literal_Low_Bound; + + procedure Set_Subprograms_For_Type (Id : E; V : E) is + begin + pragma Assert (Is_Type (Id) or else Is_Subprogram (Id)); + Set_Node29 (Id, V); + end Set_Subprograms_For_Type; + + procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True) is + begin + Set_Flag148 (Id, V); + end Set_Suppress_Elaboration_Warnings; + + procedure Set_Suppress_Init_Proc (Id : E; V : B := True) is + begin + pragma Assert (Id = Base_Type (Id)); + Set_Flag105 (Id, V); + end Set_Suppress_Init_Proc; + + procedure Set_Suppress_Style_Checks (Id : E; V : B := True) is + begin + Set_Flag165 (Id, V); + end Set_Suppress_Style_Checks; + + procedure Set_Suppress_Value_Tracking_On_Call (Id : E; V : B := True) is + begin + Set_Flag217 (Id, V); + end Set_Suppress_Value_Tracking_On_Call; + + procedure Set_Task_Body_Procedure (Id : E; V : N) is + begin + pragma Assert (Ekind (Id) in Task_Kind); + Set_Node25 (Id, V); + end Set_Task_Body_Procedure; + + procedure Set_Treat_As_Volatile (Id : E; V : B := True) is + begin + Set_Flag41 (Id, V); + end Set_Treat_As_Volatile; + + procedure Set_Underlying_Full_View (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) in Private_Kind); + Set_Node19 (Id, V); + end Set_Underlying_Full_View; + + procedure Set_Underlying_Record_View (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Record_Type); + Set_Node28 (Id, V); + end Set_Underlying_Record_View; + + procedure Set_Universal_Aliasing (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id) and then Is_Base_Type (Id)); + Set_Flag216 (Id, V); + end Set_Universal_Aliasing; + + procedure Set_Unset_Reference (Id : E; V : N) is + begin + Set_Node16 (Id, V); + end Set_Unset_Reference; + + procedure Set_Uses_Sec_Stack (Id : E; V : B := True) is + begin + Set_Flag95 (Id, V); + end Set_Uses_Sec_Stack; + + procedure Set_Used_As_Generic_Actual (Id : E; V : B := True) is + begin + Set_Flag222 (Id, V); + end Set_Used_As_Generic_Actual; + + procedure Set_Warnings_Off (Id : E; V : B := True) is + begin + Set_Flag96 (Id, V); + end Set_Warnings_Off; + + procedure Set_Warnings_Off_Used (Id : E; V : B := True) is + begin + Set_Flag236 (Id, V); + end Set_Warnings_Off_Used; + + procedure Set_Warnings_Off_Used_Unmodified (Id : E; V : B := True) is + begin + Set_Flag237 (Id, V); + end Set_Warnings_Off_Used_Unmodified; + + procedure Set_Warnings_Off_Used_Unreferenced (Id : E; V : B := True) is + begin + Set_Flag238 (Id, V); + end Set_Warnings_Off_Used_Unreferenced; + + procedure Set_Was_Hidden (Id : E; V : B := True) is + begin + Set_Flag196 (Id, V); + end Set_Was_Hidden; + + procedure Set_Wrapped_Entity (Id : E; V : E) is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Procedure) + and then Is_Primitive_Wrapper (Id)); + Set_Node27 (Id, V); + end Set_Wrapped_Entity; + + ----------------------------------- + -- Field Initialization Routines -- + ----------------------------------- + + procedure Init_Alignment (Id : E) is + begin + Set_Uint14 (Id, Uint_0); + end Init_Alignment; + + procedure Init_Alignment (Id : E; V : Int) is + begin + Set_Uint14 (Id, UI_From_Int (V)); + end Init_Alignment; + + procedure Init_Component_Bit_Offset (Id : E) is + begin + Set_Uint11 (Id, No_Uint); + end Init_Component_Bit_Offset; + + procedure Init_Component_Bit_Offset (Id : E; V : Int) is + begin + Set_Uint11 (Id, UI_From_Int (V)); + end Init_Component_Bit_Offset; + + procedure Init_Component_Size (Id : E) is + begin + Set_Uint22 (Id, Uint_0); + end Init_Component_Size; + + procedure Init_Component_Size (Id : E; V : Int) is + begin + Set_Uint22 (Id, UI_From_Int (V)); + end Init_Component_Size; + + procedure Init_Digits_Value (Id : E) is + begin + Set_Uint17 (Id, Uint_0); + end Init_Digits_Value; + + procedure Init_Digits_Value (Id : E; V : Int) is + begin + Set_Uint17 (Id, UI_From_Int (V)); + end Init_Digits_Value; + + procedure Init_Esize (Id : E) is + begin + Set_Uint12 (Id, Uint_0); + end Init_Esize; + + procedure Init_Esize (Id : E; V : Int) is + begin + Set_Uint12 (Id, UI_From_Int (V)); + end Init_Esize; + + procedure Init_Normalized_First_Bit (Id : E) is + begin + Set_Uint8 (Id, No_Uint); + end Init_Normalized_First_Bit; + + procedure Init_Normalized_First_Bit (Id : E; V : Int) is + begin + Set_Uint8 (Id, UI_From_Int (V)); + end Init_Normalized_First_Bit; + + procedure Init_Normalized_Position (Id : E) is + begin + Set_Uint14 (Id, No_Uint); + end Init_Normalized_Position; + + procedure Init_Normalized_Position (Id : E; V : Int) is + begin + Set_Uint14 (Id, UI_From_Int (V)); + end Init_Normalized_Position; + + procedure Init_Normalized_Position_Max (Id : E) is + begin + Set_Uint10 (Id, No_Uint); + end Init_Normalized_Position_Max; + + procedure Init_Normalized_Position_Max (Id : E; V : Int) is + begin + Set_Uint10 (Id, UI_From_Int (V)); + end Init_Normalized_Position_Max; + + procedure Init_RM_Size (Id : E) is + begin + Set_Uint13 (Id, Uint_0); + end Init_RM_Size; + + procedure Init_RM_Size (Id : E; V : Int) is + begin + Set_Uint13 (Id, UI_From_Int (V)); + end Init_RM_Size; + + ----------------------------- + -- Init_Component_Location -- + ----------------------------- + + procedure Init_Component_Location (Id : E) is + begin + Set_Uint8 (Id, No_Uint); -- Normalized_First_Bit + Set_Uint10 (Id, No_Uint); -- Normalized_Position_Max + Set_Uint11 (Id, No_Uint); -- Component_Bit_Offset + Set_Uint12 (Id, Uint_0); -- Esize + Set_Uint14 (Id, No_Uint); -- Normalized_Position + end Init_Component_Location; + + --------------- + -- Init_Size -- + --------------- + + procedure Init_Size (Id : E; V : Int) is + begin + Set_Uint12 (Id, UI_From_Int (V)); -- Esize + Set_Uint13 (Id, UI_From_Int (V)); -- RM_Size + end Init_Size; + + --------------------- + -- Init_Size_Align -- + --------------------- + + procedure Init_Size_Align (Id : E) is + begin + Set_Uint12 (Id, Uint_0); -- Esize + Set_Uint13 (Id, Uint_0); -- RM_Size + Set_Uint14 (Id, Uint_0); -- Alignment + end Init_Size_Align; + + ---------------------------------------------- + -- Type Representation Attribute Predicates -- + ---------------------------------------------- + + function Known_Alignment (E : Entity_Id) return B is + begin + return Uint14 (E) /= Uint_0 + and then Uint14 (E) /= No_Uint; + end Known_Alignment; + + function Known_Component_Bit_Offset (E : Entity_Id) return B is + begin + return Uint11 (E) /= No_Uint; + end Known_Component_Bit_Offset; + + function Known_Component_Size (E : Entity_Id) return B is + begin + return Uint22 (Base_Type (E)) /= Uint_0 + and then Uint22 (Base_Type (E)) /= No_Uint; + end Known_Component_Size; + + function Known_Esize (E : Entity_Id) return B is + begin + return Uint12 (E) /= Uint_0 + and then Uint12 (E) /= No_Uint; + end Known_Esize; + + function Known_Normalized_First_Bit (E : Entity_Id) return B is + begin + return Uint8 (E) /= No_Uint; + end Known_Normalized_First_Bit; + + function Known_Normalized_Position (E : Entity_Id) return B is + begin + return Uint14 (E) /= No_Uint; + end Known_Normalized_Position; + + function Known_Normalized_Position_Max (E : Entity_Id) return B is + begin + return Uint10 (E) /= No_Uint; + end Known_Normalized_Position_Max; + + function Known_RM_Size (E : Entity_Id) return B is + begin + return Uint13 (E) /= No_Uint + and then (Uint13 (E) /= Uint_0 + or else Is_Discrete_Type (E) + or else Is_Fixed_Point_Type (E)); + end Known_RM_Size; + + function Known_Static_Component_Bit_Offset (E : Entity_Id) return B is + begin + return Uint11 (E) /= No_Uint + and then Uint11 (E) >= Uint_0; + end Known_Static_Component_Bit_Offset; + + function Known_Static_Component_Size (E : Entity_Id) return B is + begin + return Uint22 (Base_Type (E)) > Uint_0; + end Known_Static_Component_Size; + + function Known_Static_Esize (E : Entity_Id) return B is + begin + return Uint12 (E) > Uint_0 + and then not Is_Generic_Type (E); + end Known_Static_Esize; + + function Known_Static_Normalized_First_Bit (E : Entity_Id) return B is + begin + return Uint8 (E) /= No_Uint + and then Uint8 (E) >= Uint_0; + end Known_Static_Normalized_First_Bit; + + function Known_Static_Normalized_Position (E : Entity_Id) return B is + begin + return Uint14 (E) /= No_Uint + and then Uint14 (E) >= Uint_0; + end Known_Static_Normalized_Position; + + function Known_Static_Normalized_Position_Max (E : Entity_Id) return B is + begin + return Uint10 (E) /= No_Uint + and then Uint10 (E) >= Uint_0; + end Known_Static_Normalized_Position_Max; + + function Known_Static_RM_Size (E : Entity_Id) return B is + begin + return (Uint13 (E) > Uint_0 + or else Is_Discrete_Type (E) + or else Is_Fixed_Point_Type (E)) + and then not Is_Generic_Type (E); + end Known_Static_RM_Size; + + function Unknown_Alignment (E : Entity_Id) return B is + begin + return Uint14 (E) = Uint_0 + or else Uint14 (E) = No_Uint; + end Unknown_Alignment; + + function Unknown_Component_Bit_Offset (E : Entity_Id) return B is + begin + return Uint11 (E) = No_Uint; + end Unknown_Component_Bit_Offset; + + function Unknown_Component_Size (E : Entity_Id) return B is + begin + return Uint22 (Base_Type (E)) = Uint_0 + or else + Uint22 (Base_Type (E)) = No_Uint; + end Unknown_Component_Size; + + function Unknown_Esize (E : Entity_Id) return B is + begin + return Uint12 (E) = No_Uint + or else + Uint12 (E) = Uint_0; + end Unknown_Esize; + + function Unknown_Normalized_First_Bit (E : Entity_Id) return B is + begin + return Uint8 (E) = No_Uint; + end Unknown_Normalized_First_Bit; + + function Unknown_Normalized_Position (E : Entity_Id) return B is + begin + return Uint14 (E) = No_Uint; + end Unknown_Normalized_Position; + + function Unknown_Normalized_Position_Max (E : Entity_Id) return B is + begin + return Uint10 (E) = No_Uint; + end Unknown_Normalized_Position_Max; + + function Unknown_RM_Size (E : Entity_Id) return B is + begin + return (Uint13 (E) = Uint_0 + and then not Is_Discrete_Type (E) + and then not Is_Fixed_Point_Type (E)) + or else Uint13 (E) = No_Uint; + end Unknown_RM_Size; + + -------------------- + -- Address_Clause -- + -------------------- + + function Address_Clause (Id : E) return N is + begin + return Rep_Clause (Id, Name_Address); + end Address_Clause; + + --------------- + -- Aft_Value -- + --------------- + + function Aft_Value (Id : E) return U is + Result : Nat := 1; + Delta_Val : Ureal := Delta_Value (Id); + begin + while Delta_Val < Ureal_Tenth loop + Delta_Val := Delta_Val * Ureal_10; + Result := Result + 1; + end loop; + + return UI_From_Int (Result); + end Aft_Value; + + ---------------------- + -- Alignment_Clause -- + ---------------------- + + function Alignment_Clause (Id : E) return N is + begin + return Rep_Clause (Id, Name_Alignment); + end Alignment_Clause; + + ------------------- + -- Append_Entity -- + ------------------- + + procedure Append_Entity (Id : Entity_Id; V : Entity_Id) is + begin + if Last_Entity (V) = Empty then + Set_First_Entity (Id => V, V => Id); + else + Set_Next_Entity (Last_Entity (V), Id); + end if; + + Set_Next_Entity (Id, Empty); + Set_Scope (Id, V); + Set_Last_Entity (Id => V, V => Id); + end Append_Entity; + + --------------- + -- Base_Type -- + --------------- + + function Base_Type (Id : E) return E is + begin + case Ekind (Id) is + when E_Enumeration_Subtype | + E_Incomplete_Type | + E_Signed_Integer_Subtype | + E_Modular_Integer_Subtype | + E_Floating_Point_Subtype | + E_Ordinary_Fixed_Point_Subtype | + E_Decimal_Fixed_Point_Subtype | + E_Array_Subtype | + E_String_Subtype | + E_Record_Subtype | + E_Private_Subtype | + E_Record_Subtype_With_Private | + E_Limited_Private_Subtype | + E_Access_Subtype | + E_Protected_Subtype | + E_Task_Subtype | + E_String_Literal_Subtype | + E_Class_Wide_Subtype => + return Etype (Id); + + when others => + return Id; + end case; + end Base_Type; + + ------------------------- + -- Component_Alignment -- + ------------------------- + + -- Component Alignment is encoded using two flags, Flag128/129 as + -- follows. Note that both flags False = Align_Default, so that the + -- default initialization of flags to False initializes component + -- alignment to the default value as required. + + -- Flag128 Flag129 Value + -- ------- ------- ----- + -- False False Calign_Default + -- False True Calign_Component_Size + -- True False Calign_Component_Size_4 + -- True True Calign_Storage_Unit + + function Component_Alignment (Id : E) return C is + BT : constant Node_Id := Base_Type (Id); + + begin + pragma Assert (Is_Array_Type (Id) or else Is_Record_Type (Id)); + + if Flag128 (BT) then + if Flag129 (BT) then + return Calign_Storage_Unit; + else + return Calign_Component_Size_4; + end if; + + else + if Flag129 (BT) then + return Calign_Component_Size; + else + return Calign_Default; + end if; + end if; + end Component_Alignment; + + ---------------------- + -- Declaration_Node -- + ---------------------- + + function Declaration_Node (Id : E) return N is + P : Node_Id; + + begin + if Ekind (Id) = E_Incomplete_Type + and then Present (Full_View (Id)) + then + P := Parent (Full_View (Id)); + else + P := Parent (Id); + end if; + + loop + if Nkind (P) /= N_Selected_Component + and then Nkind (P) /= N_Expanded_Name + and then + not (Nkind (P) = N_Defining_Program_Unit_Name + and then Is_Child_Unit (Id)) + then + return P; + else + P := Parent (P); + end if; + end loop; + end Declaration_Node; + + --------------------- + -- Designated_Type -- + --------------------- + + function Designated_Type (Id : E) return E is + Desig_Type : E; + + begin + Desig_Type := Directly_Designated_Type (Id); + + if Ekind (Desig_Type) = E_Incomplete_Type + and then Present (Full_View (Desig_Type)) + then + return Full_View (Desig_Type); + + elsif Is_Class_Wide_Type (Desig_Type) + and then Ekind (Etype (Desig_Type)) = E_Incomplete_Type + and then Present (Full_View (Etype (Desig_Type))) + and then Present (Class_Wide_Type (Full_View (Etype (Desig_Type)))) + then + return Class_Wide_Type (Full_View (Etype (Desig_Type))); + + else + return Desig_Type; + end if; + end Designated_Type; + + ---------------------- + -- Entry_Index_Type -- + ---------------------- + + function Entry_Index_Type (Id : E) return N is + begin + pragma Assert (Ekind (Id) = E_Entry_Family); + return Etype (Discrete_Subtype_Definition (Parent (Id))); + end Entry_Index_Type; + + --------------------- + -- First_Component -- + --------------------- + + function First_Component (Id : E) return E is + Comp_Id : E; + + begin + pragma Assert + (Is_Record_Type (Id) or else Is_Incomplete_Or_Private_Type (Id)); + + Comp_Id := First_Entity (Id); + while Present (Comp_Id) loop + exit when Ekind (Comp_Id) = E_Component; + Comp_Id := Next_Entity (Comp_Id); + end loop; + + return Comp_Id; + end First_Component; + + ------------------------------------- + -- First_Component_Or_Discriminant -- + ------------------------------------- + + function First_Component_Or_Discriminant (Id : E) return E is + Comp_Id : E; + + begin + pragma Assert + (Is_Record_Type (Id) or else Is_Incomplete_Or_Private_Type (Id)); + + Comp_Id := First_Entity (Id); + while Present (Comp_Id) loop + exit when Ekind (Comp_Id) = E_Component + or else + Ekind (Comp_Id) = E_Discriminant; + Comp_Id := Next_Entity (Comp_Id); + end loop; + + return Comp_Id; + end First_Component_Or_Discriminant; + + ------------------ + -- First_Formal -- + ------------------ + + function First_Formal (Id : E) return E is + Formal : E; + + begin + pragma Assert + (Is_Overloadable (Id) + or else Ekind_In (Id, E_Entry_Family, + E_Subprogram_Body, + E_Subprogram_Type)); + + if Ekind (Id) = E_Enumeration_Literal then + return Empty; + + else + Formal := First_Entity (Id); + + if Present (Formal) and then Is_Formal (Formal) then + return Formal; + else + return Empty; + end if; + end if; + end First_Formal; + + ------------------------------ + -- First_Formal_With_Extras -- + ------------------------------ + + function First_Formal_With_Extras (Id : E) return E is + Formal : E; + + begin + pragma Assert + (Is_Overloadable (Id) + or else Ekind_In (Id, E_Entry_Family, + E_Subprogram_Body, + E_Subprogram_Type)); + + if Ekind (Id) = E_Enumeration_Literal then + return Empty; + + else + Formal := First_Entity (Id); + + if Present (Formal) and then Is_Formal (Formal) then + return Formal; + else + return Extra_Formals (Id); -- Empty if no extra formals + end if; + end if; + end First_Formal_With_Extras; + + ------------------------------------- + -- Get_Attribute_Definition_Clause -- + ------------------------------------- + + function Get_Attribute_Definition_Clause + (E : Entity_Id; + Id : Attribute_Id) return Node_Id + is + N : Node_Id; + + begin + N := First_Rep_Item (E); + while Present (N) loop + if Nkind (N) = N_Attribute_Definition_Clause + and then Get_Attribute_Id (Chars (N)) = Id + then + return N; + else + Next_Rep_Item (N); + end if; + end loop; + + return Empty; + end Get_Attribute_Definition_Clause; + + ------------------- + -- Get_Full_View -- + ------------------- + + function Get_Full_View (T : Entity_Id) return Entity_Id is + begin + if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then + return Full_View (T); + + elsif Is_Class_Wide_Type (T) + and then Ekind (Root_Type (T)) = E_Incomplete_Type + and then Present (Full_View (Root_Type (T))) + then + return Class_Wide_Type (Full_View (Root_Type (T))); + + else + return T; + end if; + end Get_Full_View; + + -------------------------------------- + -- Get_Record_Representation_Clause -- + -------------------------------------- + + function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id is + N : Node_Id; + + begin + N := First_Rep_Item (E); + while Present (N) loop + if Nkind (N) = N_Record_Representation_Clause then + return N; + end if; + + Next_Rep_Item (N); + end loop; + + return Empty; + end Get_Record_Representation_Clause; + + ----------------------------- + -- Get_Rep_Item_For_Entity -- + ----------------------------- + + function Get_Rep_Item_For_Entity + (E : Entity_Id; + Nam : Name_Id) return Node_Id + is + N : Node_Id; + Arg : Node_Id; + + begin + N := First_Rep_Item (E); + while Present (N) loop + if Nkind (N) = N_Pragma and then Pragma_Name (N) = Nam then + Arg := Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); + + if Is_Entity_Name (Arg) and then Entity (Arg) = E then + return N; + end if; + + elsif Nkind (N) = N_Attribute_Definition_Clause + and then Chars (N) = Nam + and then Entity (N) = E + then + return N; + + elsif Nkind (N) = N_Aspect_Specification + and then Chars (Identifier (N)) = Nam + and then Entity (N) = E + then + return N; + end if; + + Next_Rep_Item (N); + end loop; + + return Empty; + end Get_Rep_Item_For_Entity; + + -------------------- + -- Get_Rep_Pragma -- + -------------------- + + function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id is + N : Node_Id; + + begin + N := First_Rep_Item (E); + while Present (N) loop + if Nkind (N) = N_Pragma and then Pragma_Name (N) = Nam then + return N; + end if; + + Next_Rep_Item (N); + end loop; + + return Empty; + end Get_Rep_Pragma; + + ------------------------ + -- Has_Attach_Handler -- + ------------------------ + + function Has_Attach_Handler (Id : E) return B is + Ritem : Node_Id; + + begin + pragma Assert (Is_Protected_Type (Id)); + + Ritem := First_Rep_Item (Id); + while Present (Ritem) loop + if Nkind (Ritem) = N_Pragma + and then Pragma_Name (Ritem) = Name_Attach_Handler + then + return True; + else + Next_Rep_Item (Ritem); + end if; + end loop; + + return False; + end Has_Attach_Handler; + + ------------------------------------- + -- Has_Attribute_Definition_Clause -- + ------------------------------------- + + function Has_Attribute_Definition_Clause + (E : Entity_Id; + Id : Attribute_Id) return Boolean + is + begin + return Present (Get_Attribute_Definition_Clause (E, Id)); + end Has_Attribute_Definition_Clause; + + ----------------- + -- Has_Entries -- + ----------------- + + function Has_Entries (Id : E) return B is + Ent : Entity_Id; + + begin + pragma Assert (Is_Concurrent_Type (Id)); + + Ent := First_Entity (Id); + while Present (Ent) loop + if Is_Entry (Ent) then + return True; + end if; + + Ent := Next_Entity (Ent); + end loop; + + return False; + end Has_Entries; + + ---------------------------- + -- Has_Foreign_Convention -- + ---------------------------- + + function Has_Foreign_Convention (Id : E) return B is + begin + -- While regular Intrinsics such as the Standard operators fit in the + -- "Ada" convention, those with an Interface_Name materialize GCC + -- builtin imports for which Ada special treatments shouldn't apply. + + return Convention (Id) in Foreign_Convention + or else (Convention (Id) = Convention_Intrinsic + and then Present (Interface_Name (Id))); + end Has_Foreign_Convention; + + --------------------------- + -- Has_Interrupt_Handler -- + --------------------------- + + function Has_Interrupt_Handler (Id : E) return B is + Ritem : Node_Id; + + begin + pragma Assert (Is_Protected_Type (Id)); + + Ritem := First_Rep_Item (Id); + while Present (Ritem) loop + if Nkind (Ritem) = N_Pragma + and then Pragma_Name (Ritem) = Name_Interrupt_Handler + then + return True; + else + Next_Rep_Item (Ritem); + end if; + end loop; + + return False; + end Has_Interrupt_Handler; + + -------------------------- + -- Has_Private_Ancestor -- + -------------------------- + + function Has_Private_Ancestor (Id : E) return B is + R : constant Entity_Id := Root_Type (Id); + T1 : Entity_Id := Id; + begin + loop + if Is_Private_Type (T1) then + return True; + elsif T1 = R then + return False; + else + T1 := Etype (T1); + end if; + end loop; + end Has_Private_Ancestor; + + -------------------- + -- Has_Rep_Pragma -- + -------------------- + + function Has_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Boolean is + begin + return Present (Get_Rep_Pragma (E, Nam)); + end Has_Rep_Pragma; + + -------------------- + -- Has_Unmodified -- + -------------------- + + function Has_Unmodified (E : Entity_Id) return Boolean is + begin + if Has_Pragma_Unmodified (E) then + return True; + elsif Warnings_Off (E) then + Set_Warnings_Off_Used_Unmodified (E); + return True; + else + return False; + end if; + end Has_Unmodified; + + --------------------- + -- Has_Unreferenced -- + --------------------- + + function Has_Unreferenced (E : Entity_Id) return Boolean is + begin + if Has_Pragma_Unreferenced (E) then + return True; + elsif Warnings_Off (E) then + Set_Warnings_Off_Used_Unreferenced (E); + return True; + else + return False; + end if; + end Has_Unreferenced; + + ---------------------- + -- Has_Warnings_Off -- + ---------------------- + + function Has_Warnings_Off (E : Entity_Id) return Boolean is + begin + if Warnings_Off (E) then + Set_Warnings_Off_Used (E); + return True; + else + return False; + end if; + end Has_Warnings_Off; + + ------------------------------ + -- Implementation_Base_Type -- + ------------------------------ + + function Implementation_Base_Type (Id : E) return E is + Bastyp : Entity_Id; + Imptyp : Entity_Id; + + begin + Bastyp := Base_Type (Id); + + if Is_Incomplete_Or_Private_Type (Bastyp) then + Imptyp := Underlying_Type (Bastyp); + + -- If we have an implementation type, then just return it, + -- otherwise we return the Base_Type anyway. This can only + -- happen in error situations and should avoid some error bombs. + + if Present (Imptyp) then + return Base_Type (Imptyp); + else + return Bastyp; + end if; + + else + return Bastyp; + end if; + end Implementation_Base_Type; + + ------------------------- + -- Invariant_Procedure -- + ------------------------- + + function Invariant_Procedure (Id : E) return E is + S : Entity_Id; + + begin + pragma Assert (Is_Type (Id) and then Has_Invariants (Id)); + + if No (Subprograms_For_Type (Id)) then + return Empty; + + else + S := Subprograms_For_Type (Id); + while Present (S) loop + if Has_Invariants (S) then + return S; + else + S := Subprograms_For_Type (S); + end if; + end loop; + + return Empty; + end if; + end Invariant_Procedure; + + ------------------ + -- Is_Base_Type -- + ------------------ + + function Is_Base_Type (Id : E) return Boolean is + begin + return Id = Base_Type (Id); + end Is_Base_Type; + + --------------------- + -- Is_Boolean_Type -- + --------------------- + + function Is_Boolean_Type (Id : E) return B is + begin + return Root_Type (Id) = Standard_Boolean; + end Is_Boolean_Type; + + ------------------------ + -- Is_Constant_Object -- + ------------------------ + + function Is_Constant_Object (Id : E) return B is + K : constant Entity_Kind := Ekind (Id); + begin + return + K = E_Constant or else K = E_In_Parameter or else K = E_Loop_Parameter; + end Is_Constant_Object; + + -------------------- + -- Is_Discriminal -- + -------------------- + + function Is_Discriminal (Id : E) return B is + begin + return (Ekind_In (Id, E_Constant, E_In_Parameter) + and then Present (Discriminal_Link (Id))); + end Is_Discriminal; + + ---------------------- + -- Is_Dynamic_Scope -- + ---------------------- + + function Is_Dynamic_Scope (Id : E) return B is + begin + return + Ekind (Id) = E_Block + or else + Ekind (Id) = E_Function + or else + Ekind (Id) = E_Procedure + or else + Ekind (Id) = E_Subprogram_Body + or else + Ekind (Id) = E_Task_Type + or else + (Ekind (Id) = E_Limited_Private_Type + and then Present (Full_View (Id)) + and then Ekind (Full_View (Id)) = E_Task_Type) + or else + Ekind (Id) = E_Entry + or else + Ekind (Id) = E_Entry_Family + or else + Ekind (Id) = E_Return_Statement; + end Is_Dynamic_Scope; + + -------------------- + -- Is_Entity_Name -- + -------------------- + + function Is_Entity_Name (N : Node_Id) return Boolean is + Kind : constant Node_Kind := Nkind (N); + + begin + -- Identifiers, operator symbols, expanded names are entity names + + return Kind = N_Identifier + or else Kind = N_Operator_Symbol + or else Kind = N_Expanded_Name + + -- Attribute references are entity names if they refer to an entity. + -- Note that we don't do this by testing for the presence of the + -- Entity field in the N_Attribute_Reference node, since it may not + -- have been set yet. + + or else (Kind = N_Attribute_Reference + and then Is_Entity_Attribute_Name (Attribute_Name (N))); + end Is_Entity_Name; + + ----------------------------------- + -- Is_Package_Or_Generic_Package -- + ----------------------------------- + + function Is_Package_Or_Generic_Package (Id : E) return B is + begin + return + Ekind (Id) = E_Package + or else + Ekind (Id) = E_Generic_Package; + end Is_Package_Or_Generic_Package; + + ------------------------ + -- Predicate_Function -- + ------------------------ + + function Predicate_Function (Id : E) return E is + S : Entity_Id; + + begin + pragma Assert (Is_Type (Id)); + + if No (Subprograms_For_Type (Id)) then + return Empty; + + else + S := Subprograms_For_Type (Id); + while Present (S) loop + if Has_Predicates (S) then + return S; + else + S := Subprograms_For_Type (S); + end if; + end loop; + + return Empty; + end if; + end Predicate_Function; + + --------------- + -- Is_Prival -- + --------------- + + function Is_Prival (Id : E) return B is + begin + return (Ekind_In (Id, E_Constant, E_Variable) + and then Present (Prival_Link (Id))); + end Is_Prival; + + ---------------------------- + -- Is_Protected_Component -- + ---------------------------- + + function Is_Protected_Component (Id : E) return B is + begin + return Ekind (Id) = E_Component + and then Is_Protected_Type (Scope (Id)); + end Is_Protected_Component; + + ---------------------------- + -- Is_Protected_Interface -- + ---------------------------- + + function Is_Protected_Interface (Id : E) return B is + Typ : constant Entity_Id := Base_Type (Id); + begin + if not Is_Interface (Typ) then + return False; + elsif Is_Class_Wide_Type (Typ) then + return Is_Protected_Interface (Etype (Typ)); + else + return Protected_Present (Type_Definition (Parent (Typ))); + end if; + end Is_Protected_Interface; + + ------------------------------ + -- Is_Protected_Record_Type -- + ------------------------------ + + function Is_Protected_Record_Type (Id : E) return B is + begin + return + Is_Concurrent_Record_Type (Id) + and then Is_Protected_Type (Corresponding_Concurrent_Type (Id)); + end Is_Protected_Record_Type; + + -------------------------------- + -- Is_Standard_Character_Type -- + -------------------------------- + + function Is_Standard_Character_Type (Id : E) return B is + begin + if Is_Type (Id) then + declare + R : constant Entity_Id := Root_Type (Id); + begin + return + R = Standard_Character + or else + R = Standard_Wide_Character + or else + R = Standard_Wide_Wide_Character; + end; + + else + return False; + end if; + end Is_Standard_Character_Type; + + -------------------- + -- Is_String_Type -- + -------------------- + + function Is_String_Type (Id : E) return B is + begin + return Ekind (Id) in String_Kind + or else (Is_Array_Type (Id) + and then Id /= Any_Composite + and then Number_Dimensions (Id) = 1 + and then Is_Character_Type (Component_Type (Id))); + end Is_String_Type; + + ------------------------------- + -- Is_Synchronized_Interface -- + ------------------------------- + + function Is_Synchronized_Interface (Id : E) return B is + Typ : constant Entity_Id := Base_Type (Id); + + begin + if not Is_Interface (Typ) then + return False; + + elsif Is_Class_Wide_Type (Typ) then + return Is_Synchronized_Interface (Etype (Typ)); + + else + return Protected_Present (Type_Definition (Parent (Typ))) + or else Synchronized_Present (Type_Definition (Parent (Typ))) + or else Task_Present (Type_Definition (Parent (Typ))); + end if; + end Is_Synchronized_Interface; + + ----------------------- + -- Is_Task_Interface -- + ----------------------- + + function Is_Task_Interface (Id : E) return B is + Typ : constant Entity_Id := Base_Type (Id); + begin + if not Is_Interface (Typ) then + return False; + elsif Is_Class_Wide_Type (Typ) then + return Is_Task_Interface (Etype (Typ)); + else + return Task_Present (Type_Definition (Parent (Typ))); + end if; + end Is_Task_Interface; + + ------------------------- + -- Is_Task_Record_Type -- + ------------------------- + + function Is_Task_Record_Type (Id : E) return B is + begin + return + Is_Concurrent_Record_Type (Id) + and then Is_Task_Type (Corresponding_Concurrent_Type (Id)); + end Is_Task_Record_Type; + + ------------------------ + -- Is_Wrapper_Package -- + ------------------------ + + function Is_Wrapper_Package (Id : E) return B is + begin + return (Ekind (Id) = E_Package + and then Present (Related_Instance (Id))); + end Is_Wrapper_Package; + + ----------------- + -- Last_Formal -- + ----------------- + + function Last_Formal (Id : E) return E is + Formal : E; + + begin + pragma Assert + (Is_Overloadable (Id) + or else Ekind_In (Id, E_Entry_Family, + E_Subprogram_Body, + E_Subprogram_Type)); + + if Ekind (Id) = E_Enumeration_Literal then + return Empty; + + else + Formal := First_Formal (Id); + + if Present (Formal) then + while Present (Next_Formal (Formal)) loop + Formal := Next_Formal (Formal); + end loop; + end if; + + return Formal; + end if; + end Last_Formal; + + function Model_Emin_Value (Id : E) return Uint is + begin + return Machine_Emin_Value (Id); + end Model_Emin_Value; + + ------------------------- + -- Model_Epsilon_Value -- + ------------------------- + + function Model_Epsilon_Value (Id : E) return Ureal is + Radix : constant Ureal := UR_From_Uint (Machine_Radix_Value (Id)); + begin + return Radix ** (1 - Model_Mantissa_Value (Id)); + end Model_Epsilon_Value; + + -------------------------- + -- Model_Mantissa_Value -- + -------------------------- + + function Model_Mantissa_Value (Id : E) return Uint is + begin + return Machine_Mantissa_Value (Id); + end Model_Mantissa_Value; + + ----------------------- + -- Model_Small_Value -- + ----------------------- + + function Model_Small_Value (Id : E) return Ureal is + Radix : constant Ureal := UR_From_Uint (Machine_Radix_Value (Id)); + begin + return Radix ** (Model_Emin_Value (Id) - 1); + end Model_Small_Value; + + ------------------------ + -- Machine_Emax_Value -- + ------------------------ + + function Machine_Emax_Value (Id : E) return Uint is + Digs : constant Pos := UI_To_Int (Digits_Value (Base_Type (Id))); + + begin + case Float_Rep (Id) is + when IEEE_Binary => + case Digs is + when 1 .. 6 => return Uint_128; + when 7 .. 15 => return 2**10; + when 16 .. 18 => return 2**14; + when others => return No_Uint; + end case; + + when VAX_Native => + case Digs is + when 1 .. 9 => return 2**7 - 1; + when 10 .. 15 => return 2**10 - 1; + when others => return No_Uint; + end case; + + when AAMP => + return Uint_2 ** Uint_7 - Uint_1; + end case; + end Machine_Emax_Value; + + ------------------------ + -- Machine_Emin_Value -- + ------------------------ + + function Machine_Emin_Value (Id : E) return Uint is + begin + case Float_Rep (Id) is + when IEEE_Binary => return Uint_3 - Machine_Emax_Value (Id); + when VAX_Native => return -Machine_Emax_Value (Id); + when AAMP => return -Machine_Emax_Value (Id); + end case; + end Machine_Emin_Value; + + ---------------------------- + -- Machine_Mantissa_Value -- + ---------------------------- + + function Machine_Mantissa_Value (Id : E) return Uint is + Digs : constant Pos := UI_To_Int (Digits_Value (Base_Type (Id))); + + begin + case Float_Rep (Id) is + when IEEE_Binary => + case Digs is + when 1 .. 6 => return Uint_24; + when 7 .. 15 => return UI_From_Int (53); + when 16 .. 18 => return Uint_64; + when others => return No_Uint; + end case; + + when VAX_Native => + case Digs is + when 1 .. 6 => return Uint_24; + when 7 .. 9 => return UI_From_Int (56); + when 10 .. 15 => return UI_From_Int (53); + when others => return No_Uint; + end case; + + when AAMP => + case Digs is + when 1 .. 6 => return Uint_24; + when 7 .. 9 => return UI_From_Int (40); + when others => return No_Uint; + end case; + end case; + end Machine_Mantissa_Value; + + ------------------------- + -- Machine_Radix_Value -- + ------------------------- + + function Machine_Radix_Value (Id : E) return U is + begin + case Float_Rep (Id) is + when IEEE_Binary | VAX_Native | AAMP => + return Uint_2; + end case; + end Machine_Radix_Value; + + -------------------- + -- Next_Component -- + -------------------- + + function Next_Component (Id : E) return E is + Comp_Id : E; + + begin + Comp_Id := Next_Entity (Id); + while Present (Comp_Id) loop + exit when Ekind (Comp_Id) = E_Component; + Comp_Id := Next_Entity (Comp_Id); + end loop; + + return Comp_Id; + end Next_Component; + + ------------------------------------ + -- Next_Component_Or_Discriminant -- + ------------------------------------ + + function Next_Component_Or_Discriminant (Id : E) return E is + Comp_Id : E; + + begin + Comp_Id := Next_Entity (Id); + while Present (Comp_Id) loop + exit when Ekind_In (Comp_Id, E_Component, E_Discriminant); + Comp_Id := Next_Entity (Comp_Id); + end loop; + + return Comp_Id; + end Next_Component_Or_Discriminant; + + ----------------------- + -- Next_Discriminant -- + ----------------------- + + -- This function actually implements both Next_Discriminant and + -- Next_Stored_Discriminant by making sure that the Discriminant + -- returned is of the same variety as Id. + + function Next_Discriminant (Id : E) return E is + + -- Derived Tagged types with private extensions look like this... + + -- E_Discriminant d1 + -- E_Discriminant d2 + -- E_Component _tag + -- E_Discriminant d1 + -- E_Discriminant d2 + -- ... + + -- so it is critical not to go past the leading discriminants + + D : E := Id; + + begin + pragma Assert (Ekind (Id) = E_Discriminant); + + loop + D := Next_Entity (D); + if No (D) + or else (Ekind (D) /= E_Discriminant + and then not Is_Itype (D)) + then + return Empty; + end if; + + exit when Ekind (D) = E_Discriminant + and then (Is_Completely_Hidden (D) = Is_Completely_Hidden (Id)); + end loop; + + return D; + end Next_Discriminant; + + ----------------- + -- Next_Formal -- + ----------------- + + function Next_Formal (Id : E) return E is + P : E; + + begin + -- Follow the chain of declared entities as long as the kind of the + -- entity corresponds to a formal parameter. Skip internal entities + -- that may have been created for implicit subtypes, in the process + -- of analyzing default expressions. + + P := Id; + loop + P := Next_Entity (P); + + if No (P) or else Is_Formal (P) then + return P; + elsif not Is_Internal (P) then + return Empty; + end if; + end loop; + end Next_Formal; + + ----------------------------- + -- Next_Formal_With_Extras -- + ----------------------------- + + function Next_Formal_With_Extras (Id : E) return E is + begin + if Present (Extra_Formal (Id)) then + return Extra_Formal (Id); + else + return Next_Formal (Id); + end if; + end Next_Formal_With_Extras; + + ---------------- + -- Next_Index -- + ---------------- + + function Next_Index (Id : Node_Id) return Node_Id is + begin + return Next (Id); + end Next_Index; + + ------------------ + -- Next_Literal -- + ------------------ + + function Next_Literal (Id : E) return E is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Next (Id); + end Next_Literal; + + ------------------------------ + -- Next_Stored_Discriminant -- + ------------------------------ + + function Next_Stored_Discriminant (Id : E) return E is + begin + -- See comment in Next_Discriminant + + return Next_Discriminant (Id); + end Next_Stored_Discriminant; + + ----------------------- + -- Number_Dimensions -- + ----------------------- + + function Number_Dimensions (Id : E) return Pos is + N : Int; + T : Node_Id; + + begin + if Ekind (Id) in String_Kind then + return 1; + + else + N := 0; + T := First_Index (Id); + while Present (T) loop + N := N + 1; + T := Next (T); + end loop; + + return N; + end if; + end Number_Dimensions; + + -------------------- + -- Number_Entries -- + -------------------- + + function Number_Entries (Id : E) return Nat is + N : Int; + Ent : Entity_Id; + + begin + pragma Assert (Is_Concurrent_Type (Id)); + + N := 0; + Ent := First_Entity (Id); + while Present (Ent) loop + if Is_Entry (Ent) then + N := N + 1; + end if; + + Ent := Next_Entity (Ent); + end loop; + + return N; + end Number_Entries; + + -------------------- + -- Number_Formals -- + -------------------- + + function Number_Formals (Id : E) return Pos is + N : Int; + Formal : Entity_Id; + + begin + N := 0; + Formal := First_Formal (Id); + while Present (Formal) loop + N := N + 1; + Formal := Next_Formal (Formal); + end loop; + + return N; + end Number_Formals; + + -------------------- + -- Parameter_Mode -- + -------------------- + + function Parameter_Mode (Id : E) return Formal_Kind is + begin + return Ekind (Id); + end Parameter_Mode; + + -------------------------- + -- Primitive_Operations -- + -------------------------- + + function Primitive_Operations (Id : E) return L is + begin + if Is_Concurrent_Type (Id) then + if Present (Corresponding_Record_Type (Id)) then + return Direct_Primitive_Operations + (Corresponding_Record_Type (Id)); + else + return No_Elist; + end if; + else + return Direct_Primitive_Operations (Id); + end if; + end Primitive_Operations; + + --------------------- + -- Record_Rep_Item -- + --------------------- + + procedure Record_Rep_Item (E : Entity_Id; N : Node_Id) is + begin + Set_Next_Rep_Item (N, First_Rep_Item (E)); + Set_First_Rep_Item (E, N); + end Record_Rep_Item; + + --------------- + -- Root_Type -- + --------------- + + function Root_Type (Id : E) return E is + T, Etyp : E; + + begin + pragma Assert (Nkind (Id) in N_Entity); + + T := Base_Type (Id); + + if Ekind (T) = E_Class_Wide_Type then + return Etype (T); + + elsif Ekind (T) = E_Class_Wide_Subtype then + return Etype (Base_Type (T)); + + -- ??? T comes from Base_Type, how can it be a subtype? + -- Also Base_Type is supposed to be idempotent, so either way + -- this is equivalent to "return Etype (T)" and should be merged + -- with the E_Class_Wide_Type case. + + -- All other cases + + else + loop + Etyp := Etype (T); + + if T = Etyp then + return T; + + -- Following test catches some error cases resulting from + -- previous errors. + + elsif No (Etyp) then + return T; + + elsif Is_Private_Type (T) and then Etyp = Full_View (T) then + return T; + + elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then + return T; + end if; + + T := Etyp; + + -- Return if there is a circularity in the inheritance chain. This + -- happens in some error situations and we do not want to get + -- stuck in this loop. + + if T = Base_Type (Id) then + return T; + end if; + end loop; + end if; + end Root_Type; + + --------------------- + -- Safe_Emax_Value -- + --------------------- + + function Safe_Emax_Value (Id : E) return Uint is + begin + return Machine_Emax_Value (Id); + end Safe_Emax_Value; + + ---------------------- + -- Safe_First_Value -- + ---------------------- + + function Safe_First_Value (Id : E) return Ureal is + begin + return -Safe_Last_Value (Id); + end Safe_First_Value; + + --------------------- + -- Safe_Last_Value -- + --------------------- + + function Safe_Last_Value (Id : E) return Ureal is + Radix : constant Uint := Machine_Radix_Value (Id); + Mantissa : constant Uint := Machine_Mantissa_Value (Id); + Emax : constant Uint := Safe_Emax_Value (Id); + Significand : constant Uint := Radix ** Mantissa - 1; + Exponent : constant Uint := Emax - Mantissa; + + begin + if Radix = 2 then + return + UR_From_Components + (Num => Significand * 2 ** (Exponent mod 4), + Den => -Exponent / 4, + Rbase => 16); + + else + return + UR_From_Components + (Num => Significand, + Den => -Exponent, + Rbase => 16); + end if; + end Safe_Last_Value; + + ----------------- + -- Scope_Depth -- + ----------------- + + function Scope_Depth (Id : E) return Uint is + Scop : Entity_Id; + + begin + Scop := Id; + while Is_Record_Type (Scop) loop + Scop := Scope (Scop); + end loop; + + return Scope_Depth_Value (Scop); + end Scope_Depth; + + --------------------- + -- Scope_Depth_Set -- + --------------------- + + function Scope_Depth_Set (Id : E) return B is + begin + return not Is_Record_Type (Id) + and then Field22 (Id) /= Union_Id (Empty); + end Scope_Depth_Set; + + ----------------------------- + -- Set_Component_Alignment -- + ----------------------------- + + -- Component Alignment is encoded using two flags, Flag128/129 as + -- follows. Note that both flags False = Align_Default, so that the + -- default initialization of flags to False initializes component + -- alignment to the default value as required. + + -- Flag128 Flag129 Value + -- ------- ------- ----- + -- False False Calign_Default + -- False True Calign_Component_Size + -- True False Calign_Component_Size_4 + -- True True Calign_Storage_Unit + + procedure Set_Component_Alignment (Id : E; V : C) is + begin + pragma Assert ((Is_Array_Type (Id) or else Is_Record_Type (Id)) + and then Is_Base_Type (Id)); + + case V is + when Calign_Default => + Set_Flag128 (Id, False); + Set_Flag129 (Id, False); + + when Calign_Component_Size => + Set_Flag128 (Id, False); + Set_Flag129 (Id, True); + + when Calign_Component_Size_4 => + Set_Flag128 (Id, True); + Set_Flag129 (Id, False); + + when Calign_Storage_Unit => + Set_Flag128 (Id, True); + Set_Flag129 (Id, True); + end case; + end Set_Component_Alignment; + + ----------------------------- + -- Set_Invariant_Procedure -- + ----------------------------- + + procedure Set_Invariant_Procedure (Id : E; V : E) is + S : Entity_Id; + + begin + pragma Assert (Is_Type (Id) and then Has_Invariants (Id)); + + S := Subprograms_For_Type (Id); + Set_Subprograms_For_Type (Id, V); + + while Present (S) loop + if Has_Invariants (S) then + raise Program_Error; + else + S := Subprograms_For_Type (S); + end if; + end loop; + + Set_Subprograms_For_Type (Id, V); + end Set_Invariant_Procedure; + + ---------------------------- + -- Set_Predicate_Function -- + ---------------------------- + + procedure Set_Predicate_Function (Id : E; V : E) is + S : Entity_Id; + + begin + pragma Assert (Is_Type (Id) and then Has_Predicates (Id)); + + S := Subprograms_For_Type (Id); + Set_Subprograms_For_Type (Id, V); + + while Present (S) loop + if Has_Predicates (S) then + raise Program_Error; + else + S := Subprograms_For_Type (S); + end if; + end loop; + + Set_Subprograms_For_Type (Id, V); + end Set_Predicate_Function; + + ----------------- + -- Size_Clause -- + ----------------- + + function Size_Clause (Id : E) return N is + begin + return Rep_Clause (Id, Name_Size); + end Size_Clause; + + ------------------------ + -- Stream_Size_Clause -- + ------------------------ + + function Stream_Size_Clause (Id : E) return N is + begin + return Rep_Clause (Id, Name_Stream_Size); + end Stream_Size_Clause; + + ------------------ + -- Subtype_Kind -- + ------------------ + + function Subtype_Kind (K : Entity_Kind) return Entity_Kind is + Kind : Entity_Kind; + + begin + case K is + when Access_Kind => + Kind := E_Access_Subtype; + + when E_Array_Type | + E_Array_Subtype => + Kind := E_Array_Subtype; + + when E_Class_Wide_Type | + E_Class_Wide_Subtype => + Kind := E_Class_Wide_Subtype; + + when E_Decimal_Fixed_Point_Type | + E_Decimal_Fixed_Point_Subtype => + Kind := E_Decimal_Fixed_Point_Subtype; + + when E_Ordinary_Fixed_Point_Type | + E_Ordinary_Fixed_Point_Subtype => + Kind := E_Ordinary_Fixed_Point_Subtype; + + when E_Private_Type | + E_Private_Subtype => + Kind := E_Private_Subtype; + + when E_Limited_Private_Type | + E_Limited_Private_Subtype => + Kind := E_Limited_Private_Subtype; + + when E_Record_Type_With_Private | + E_Record_Subtype_With_Private => + Kind := E_Record_Subtype_With_Private; + + when E_Record_Type | + E_Record_Subtype => + Kind := E_Record_Subtype; + + when E_String_Type | + E_String_Subtype => + Kind := E_String_Subtype; + + when Enumeration_Kind => + Kind := E_Enumeration_Subtype; + + when Float_Kind => + Kind := E_Floating_Point_Subtype; + + when Signed_Integer_Kind => + Kind := E_Signed_Integer_Subtype; + + when Modular_Integer_Kind => + Kind := E_Modular_Integer_Subtype; + + when Protected_Kind => + Kind := E_Protected_Subtype; + + when Task_Kind => + Kind := E_Task_Subtype; + + when others => + Kind := E_Void; + raise Program_Error; + end case; + + return Kind; + end Subtype_Kind; + + --------------------- + -- Type_High_Bound -- + --------------------- + + function Type_High_Bound (Id : E) return Node_Id is + Rng : constant Node_Id := Scalar_Range (Id); + begin + if Nkind (Rng) = N_Subtype_Indication then + return High_Bound (Range_Expression (Constraint (Rng))); + else + return High_Bound (Rng); + end if; + end Type_High_Bound; + + -------------------- + -- Type_Low_Bound -- + -------------------- + + function Type_Low_Bound (Id : E) return Node_Id is + Rng : constant Node_Id := Scalar_Range (Id); + begin + if Nkind (Rng) = N_Subtype_Indication then + return Low_Bound (Range_Expression (Constraint (Rng))); + else + return Low_Bound (Rng); + end if; + end Type_Low_Bound; + + --------------------- + -- Underlying_Type -- + --------------------- + + function Underlying_Type (Id : E) return E is + begin + -- For record_with_private the underlying type is always the direct + -- full view. Never try to take the full view of the parent it + -- doesn't make sense. + + if Ekind (Id) = E_Record_Type_With_Private then + return Full_View (Id); + + elsif Ekind (Id) in Incomplete_Or_Private_Kind then + + -- If we have an incomplete or private type with a full view, + -- then we return the Underlying_Type of this full view + + if Present (Full_View (Id)) then + if Id = Full_View (Id) then + + -- Previous error in declaration + + return Empty; + + else + return Underlying_Type (Full_View (Id)); + end if; + + -- If we have an incomplete entity that comes from the limited + -- view then we return the Underlying_Type of its non-limited + -- view. + + elsif From_With_Type (Id) + and then Present (Non_Limited_View (Id)) + then + return Underlying_Type (Non_Limited_View (Id)); + + -- Otherwise check for the case where we have a derived type or + -- subtype, and if so get the Underlying_Type of the parent type. + + elsif Etype (Id) /= Id then + return Underlying_Type (Etype (Id)); + + -- Otherwise we have an incomplete or private type that has + -- no full view, which means that we have not encountered the + -- completion, so return Empty to indicate the underlying type + -- is not yet known. + + else + return Empty; + end if; + + -- For non-incomplete, non-private types, return the type itself + -- Also for entities that are not types at all return the entity + -- itself. + + else + return Id; + end if; + end Underlying_Type; + + --------------- + -- Vax_Float -- + --------------- + + function Vax_Float (Id : E) return B is + begin + return Is_Floating_Point_Type (Id) and then Float_Rep (Id) = VAX_Native; + end Vax_Float; + + ------------------------ + -- Write_Entity_Flags -- + ------------------------ + + procedure Write_Entity_Flags (Id : Entity_Id; Prefix : String) is + + procedure W (Flag_Name : String; Flag : Boolean); + -- Write out given flag if it is set + + ------- + -- W -- + ------- + + procedure W (Flag_Name : String; Flag : Boolean) is + begin + if Flag then + Write_Str (Prefix); + Write_Str (Flag_Name); + Write_Str (" = True"); + Write_Eol; + end if; + end W; + + -- Start of processing for Write_Entity_Flags + + begin + if (Is_Array_Type (Id) or else Is_Record_Type (Id)) + and then Is_Base_Type (Id) + then + Write_Str (Prefix); + Write_Str ("Component_Alignment = "); + + case Component_Alignment (Id) is + when Calign_Default => + Write_Str ("Calign_Default"); + + when Calign_Component_Size => + Write_Str ("Calign_Component_Size"); + + when Calign_Component_Size_4 => + Write_Str ("Calign_Component_Size_4"); + + when Calign_Storage_Unit => + Write_Str ("Calign_Storage_Unit"); + end case; + + Write_Eol; + end if; + + W ("Address_Taken", Flag104 (Id)); + W ("Body_Needed_For_SAL", Flag40 (Id)); + W ("C_Pass_By_Copy", Flag125 (Id)); + W ("Can_Never_Be_Null", Flag38 (Id)); + W ("Checks_May_Be_Suppressed", Flag31 (Id)); + W ("Debug_Info_Off", Flag166 (Id)); + W ("Default_Expressions_Processed", Flag108 (Id)); + W ("Delay_Cleanups", Flag114 (Id)); + W ("Delay_Subprogram_Descriptors", Flag50 (Id)); + W ("Depends_On_Private", Flag14 (Id)); + W ("Discard_Names", Flag88 (Id)); + W ("Elaboration_Entity_Required", Flag174 (Id)); + W ("Elaborate_Body_Desirable", Flag210 (Id)); + W ("Entry_Accepted", Flag152 (Id)); + W ("Can_Use_Internal_Rep", Flag229 (Id)); + W ("Finalize_Storage_Only", Flag158 (Id)); + W ("From_With_Type", Flag159 (Id)); + W ("Has_Aliased_Components", Flag135 (Id)); + W ("Has_Alignment_Clause", Flag46 (Id)); + W ("Has_All_Calls_Remote", Flag79 (Id)); + W ("Has_Anon_Block_Suffix", Flag201 (Id)); + W ("Has_Atomic_Components", Flag86 (Id)); + W ("Has_Biased_Representation", Flag139 (Id)); + W ("Has_Completion", Flag26 (Id)); + W ("Has_Completion_In_Body", Flag71 (Id)); + W ("Has_Complex_Representation", Flag140 (Id)); + W ("Has_Component_Size_Clause", Flag68 (Id)); + W ("Has_Contiguous_Rep", Flag181 (Id)); + W ("Has_Controlled_Component", Flag43 (Id)); + W ("Has_Controlling_Result", Flag98 (Id)); + W ("Has_Convention_Pragma", Flag119 (Id)); + W ("Has_Delayed_Aspects", Flag200 (Id)); + W ("Has_Delayed_Freeze", Flag18 (Id)); + W ("Has_Discriminants", Flag5 (Id)); + W ("Has_Enumeration_Rep_Clause", Flag66 (Id)); + W ("Has_Exit", Flag47 (Id)); + W ("Has_External_Tag_Rep_Clause", Flag110 (Id)); + W ("Has_Forward_Instantiation", Flag175 (Id)); + W ("Has_Fully_Qualified_Name", Flag173 (Id)); + W ("Has_Gigi_Rep_Item", Flag82 (Id)); + W ("Has_Homonym", Flag56 (Id)); + W ("Has_Inheritable_Invariants", Flag248 (Id)); + W ("Has_Initial_Value", Flag219 (Id)); + W ("Has_Invariants", Flag232 (Id)); + W ("Has_Machine_Radix_Clause", Flag83 (Id)); + W ("Has_Master_Entity", Flag21 (Id)); + W ("Has_Missing_Return", Flag142 (Id)); + W ("Has_Nested_Block_With_Handler", Flag101 (Id)); + W ("Has_Non_Standard_Rep", Flag75 (Id)); + W ("Has_Object_Size_Clause", Flag172 (Id)); + W ("Has_Per_Object_Constraint", Flag154 (Id)); + W ("Has_Persistent_BSS", Flag188 (Id)); + W ("Has_Postconditions", Flag240 (Id)); + W ("Has_Pragma_Controlled", Flag27 (Id)); + W ("Has_Pragma_Elaborate_Body", Flag150 (Id)); + W ("Has_Pragma_Inline", Flag157 (Id)); + W ("Has_Pragma_Inline_Always", Flag230 (Id)); + W ("Has_Pragma_Ordered", Flag198 (Id)); + W ("Has_Pragma_Pack", Flag121 (Id)); + W ("Has_Pragma_Preelab_Init", Flag221 (Id)); + W ("Has_Pragma_Pure", Flag203 (Id)); + W ("Has_Pragma_Pure_Function", Flag179 (Id)); + W ("Has_Pragma_Thread_Local_Storage", Flag169 (Id)); + W ("Has_Pragma_Unmodified", Flag233 (Id)); + W ("Has_Pragma_Unreferenced", Flag180 (Id)); + W ("Has_Pragma_Unreferenced_Objects", Flag212 (Id)); + W ("Has_Predicates", Flag250 (Id)); + W ("Has_Primitive_Operations", Flag120 (Id)); + W ("Has_Private_Declaration", Flag155 (Id)); + W ("Has_Qualified_Name", Flag161 (Id)); + W ("Has_RACW", Flag214 (Id)); + W ("Has_Record_Rep_Clause", Flag65 (Id)); + W ("Has_Recursive_Call", Flag143 (Id)); + W ("Has_Size_Clause", Flag29 (Id)); + W ("Has_Small_Clause", Flag67 (Id)); + W ("Has_Specified_Layout", Flag100 (Id)); + W ("Has_Specified_Stream_Input", Flag190 (Id)); + W ("Has_Specified_Stream_Output", Flag191 (Id)); + W ("Has_Specified_Stream_Read", Flag192 (Id)); + W ("Has_Specified_Stream_Write", Flag193 (Id)); + W ("Has_Static_Discriminants", Flag211 (Id)); + W ("Has_Storage_Size_Clause", Flag23 (Id)); + W ("Has_Stream_Size_Clause", Flag184 (Id)); + W ("Has_Subprogram_Descriptor", Flag93 (Id)); + W ("Has_Task", Flag30 (Id)); + W ("Has_Thunks", Flag228 (Id)); + W ("Has_Unchecked_Union", Flag123 (Id)); + W ("Has_Unknown_Discriminants", Flag72 (Id)); + W ("Has_Up_Level_Access", Flag215 (Id)); + W ("Has_Volatile_Components", Flag87 (Id)); + W ("Has_Xref_Entry", Flag182 (Id)); + W ("In_Package_Body", Flag48 (Id)); + W ("In_Private_Part", Flag45 (Id)); + W ("In_Use", Flag8 (Id)); + W ("Is_AST_Entry", Flag132 (Id)); + W ("Is_Abstract_Subprogram", Flag19 (Id)); + W ("Is_Abstract_Type", Flag146 (Id)); + W ("Is_Local_Anonymous_Access", Flag194 (Id)); + W ("Is_Access_Constant", Flag69 (Id)); + W ("Is_Ada_2005_Only", Flag185 (Id)); + W ("Is_Ada_2012_Only", Flag199 (Id)); + W ("Is_Aliased", Flag15 (Id)); + W ("Is_Asynchronous", Flag81 (Id)); + W ("Is_Atomic", Flag85 (Id)); + W ("Is_Bit_Packed_Array", Flag122 (Id)); + W ("Is_CPP_Class", Flag74 (Id)); + W ("Is_Called", Flag102 (Id)); + W ("Is_Character_Type", Flag63 (Id)); + W ("Is_Child_Unit", Flag73 (Id)); + W ("Is_Class_Wide_Equivalent_Type", Flag35 (Id)); + W ("Is_Compilation_Unit", Flag149 (Id)); + W ("Is_Completely_Hidden", Flag103 (Id)); + W ("Is_Concurrent_Record_Type", Flag20 (Id)); + W ("Is_Constr_Subt_For_UN_Aliased", Flag141 (Id)); + W ("Is_Constr_Subt_For_U_Nominal", Flag80 (Id)); + W ("Is_Constrained", Flag12 (Id)); + W ("Is_Constructor", Flag76 (Id)); + W ("Is_Controlled", Flag42 (Id)); + W ("Is_Controlling_Formal", Flag97 (Id)); + W ("Is_Descendent_Of_Address", Flag223 (Id)); + W ("Is_Discrim_SO_Function", Flag176 (Id)); + W ("Is_Dispatch_Table_Entity", Flag234 (Id)); + W ("Is_Dispatching_Operation", Flag6 (Id)); + W ("Is_Eliminated", Flag124 (Id)); + W ("Is_Entry_Formal", Flag52 (Id)); + W ("Is_Exported", Flag99 (Id)); + W ("Is_First_Subtype", Flag70 (Id)); + W ("Is_For_Access_Subtype", Flag118 (Id)); + W ("Is_Formal_Subprogram", Flag111 (Id)); + W ("Is_Frozen", Flag4 (Id)); + W ("Is_Generic_Actual_Type", Flag94 (Id)); + W ("Is_Generic_Instance", Flag130 (Id)); + W ("Is_Generic_Type", Flag13 (Id)); + W ("Is_Hidden", Flag57 (Id)); + W ("Is_Hidden_Open_Scope", Flag171 (Id)); + W ("Is_Immediately_Visible", Flag7 (Id)); + W ("Is_Imported", Flag24 (Id)); + W ("Is_Inlined", Flag11 (Id)); + W ("Is_Instantiated", Flag126 (Id)); + W ("Is_Interface", Flag186 (Id)); + W ("Is_Internal", Flag17 (Id)); + W ("Is_Interrupt_Handler", Flag89 (Id)); + W ("Is_Intrinsic_Subprogram", Flag64 (Id)); + W ("Is_Itype", Flag91 (Id)); + W ("Is_Known_Non_Null", Flag37 (Id)); + W ("Is_Known_Null", Flag204 (Id)); + W ("Is_Known_Valid", Flag170 (Id)); + W ("Is_Limited_Composite", Flag106 (Id)); + W ("Is_Limited_Interface", Flag197 (Id)); + W ("Is_Limited_Record", Flag25 (Id)); + W ("Is_Machine_Code_Subprogram", Flag137 (Id)); + W ("Is_Non_Static_Subtype", Flag109 (Id)); + W ("Is_Null_Init_Proc", Flag178 (Id)); + W ("Is_Obsolescent", Flag153 (Id)); + W ("Is_Only_Out_Parameter", Flag226 (Id)); + W ("Is_Optional_Parameter", Flag134 (Id)); + W ("Is_Package_Body_Entity", Flag160 (Id)); + W ("Is_Packed", Flag51 (Id)); + W ("Is_Packed_Array_Type", Flag138 (Id)); + W ("Is_Potentially_Use_Visible", Flag9 (Id)); + W ("Is_Preelaborated", Flag59 (Id)); + W ("Is_Primitive", Flag218 (Id)); + W ("Is_Primitive_Wrapper", Flag195 (Id)); + W ("Is_Private_Composite", Flag107 (Id)); + W ("Is_Private_Descendant", Flag53 (Id)); + W ("Is_Private_Primitive", Flag245 (Id)); + W ("Is_Public", Flag10 (Id)); + W ("Is_Pure", Flag44 (Id)); + W ("Is_Pure_Unit_Access_Type", Flag189 (Id)); + W ("Is_RACW_Stub_Type", Flag244 (Id)); + W ("Is_Raised", Flag224 (Id)); + W ("Is_Remote_Call_Interface", Flag62 (Id)); + W ("Is_Remote_Types", Flag61 (Id)); + W ("Is_Renaming_Of_Object", Flag112 (Id)); + W ("Is_Return_Object", Flag209 (Id)); + W ("Is_Shared_Passive", Flag60 (Id)); + W ("Is_Statically_Allocated", Flag28 (Id)); + W ("Is_Tag", Flag78 (Id)); + W ("Is_Tagged_Type", Flag55 (Id)); + W ("Is_Thunk", Flag225 (Id)); + W ("Is_Trivial_Subprogram", Flag235 (Id)); + W ("Is_True_Constant", Flag163 (Id)); + W ("Is_Unchecked_Union", Flag117 (Id)); + W ("Is_Underlying_Record_View", Flag246 (Id)); + W ("Is_Unsigned_Type", Flag144 (Id)); + W ("Is_VMS_Exception", Flag133 (Id)); + W ("Is_Valued_Procedure", Flag127 (Id)); + W ("Is_Visible_Child_Unit", Flag116 (Id)); + W ("Is_Visible_Formal", Flag206 (Id)); + W ("Is_Volatile", Flag16 (Id)); + W ("Itype_Printed", Flag202 (Id)); + W ("Kill_Elaboration_Checks", Flag32 (Id)); + W ("Kill_Range_Checks", Flag33 (Id)); + W ("Kill_Tag_Checks", Flag34 (Id)); + W ("Known_To_Have_Preelab_Init", Flag207 (Id)); + W ("Low_Bound_Tested", Flag205 (Id)); + W ("Machine_Radix_10", Flag84 (Id)); + W ("Materialize_Entity", Flag168 (Id)); + W ("Must_Be_On_Byte_Boundary", Flag183 (Id)); + W ("Must_Have_Preelab_Init", Flag208 (Id)); + W ("Needs_Debug_Info", Flag147 (Id)); + W ("Needs_No_Actuals", Flag22 (Id)); + W ("Never_Set_In_Source", Flag115 (Id)); + W ("No_Pool_Assigned", Flag131 (Id)); + W ("No_Return", Flag113 (Id)); + W ("No_Strict_Aliasing", Flag136 (Id)); + W ("Non_Binary_Modulus", Flag58 (Id)); + W ("Nonzero_Is_True", Flag162 (Id)); + W ("OK_To_Rename", Flag247 (Id)); + W ("OK_To_Reorder_Components", Flag239 (Id)); + W ("Optimize_Alignment_Space", Flag241 (Id)); + W ("Optimize_Alignment_Time", Flag242 (Id)); + W ("Overlays_Constant", Flag243 (Id)); + W ("Reachable", Flag49 (Id)); + W ("Referenced", Flag156 (Id)); + W ("Referenced_As_LHS", Flag36 (Id)); + W ("Referenced_As_Out_Parameter", Flag227 (Id)); + W ("Renamed_In_Spec", Flag231 (Id)); + W ("Requires_Overriding", Flag213 (Id)); + W ("Return_Present", Flag54 (Id)); + W ("Returns_By_Ref", Flag90 (Id)); + W ("Reverse_Bit_Order", Flag164 (Id)); + W ("Sec_Stack_Needed_For_Return", Flag167 (Id)); + W ("Size_Depends_On_Discriminant", Flag177 (Id)); + W ("Size_Known_At_Compile_Time", Flag92 (Id)); + W ("Static_Elaboration_Desired", Flag77 (Id)); + W ("Strict_Alignment", Flag145 (Id)); + W ("Suppress_Elaboration_Warnings", Flag148 (Id)); + W ("Suppress_Init_Proc", Flag105 (Id)); + W ("Suppress_Style_Checks", Flag165 (Id)); + W ("Suppress_Value_Tracking_On_Call", Flag217 (Id)); + W ("Treat_As_Volatile", Flag41 (Id)); + W ("Universal_Aliasing", Flag216 (Id)); + W ("Used_As_Generic_Actual", Flag222 (Id)); + W ("Uses_Sec_Stack", Flag95 (Id)); + W ("Warnings_Off", Flag96 (Id)); + W ("Warnings_Off_Used", Flag236 (Id)); + W ("Warnings_Off_Used_Unmodified", Flag237 (Id)); + W ("Warnings_Off_Used_Unreferenced", Flag238 (Id)); + W ("Was_Hidden", Flag196 (Id)); + end Write_Entity_Flags; + + ----------------------- + -- Write_Entity_Info -- + ----------------------- + + procedure Write_Entity_Info (Id : Entity_Id; Prefix : String) is + + procedure Write_Attribute (Which : String; Nam : E); + -- Write attribute value with given string name + + procedure Write_Kind (Id : Entity_Id); + -- Write Ekind field of entity + + --------------------- + -- Write_Attribute -- + --------------------- + + procedure Write_Attribute (Which : String; Nam : E) is + begin + Write_Str (Prefix); + Write_Str (Which); + Write_Int (Int (Nam)); + Write_Str (" "); + Write_Name (Chars (Nam)); + Write_Str (" "); + end Write_Attribute; + + ---------------- + -- Write_Kind -- + ---------------- + + procedure Write_Kind (Id : Entity_Id) is + K : constant String := Entity_Kind'Image (Ekind (Id)); + + begin + Write_Str (Prefix); + Write_Str (" Kind "); + + if Is_Type (Id) and then Is_Tagged_Type (Id) then + Write_Str ("TAGGED "); + end if; + + Write_Str (K (3 .. K'Length)); + Write_Str (" "); + + if Is_Type (Id) and then Depends_On_Private (Id) then + Write_Str ("Depends_On_Private "); + end if; + end Write_Kind; + + -- Start of processing for Write_Entity_Info + + begin + Write_Eol; + Write_Attribute ("Name ", Id); + Write_Int (Int (Id)); + Write_Eol; + Write_Kind (Id); + Write_Eol; + Write_Attribute (" Type ", Etype (Id)); + Write_Eol; + Write_Attribute (" Scope ", Scope (Id)); + Write_Eol; + + case Ekind (Id) is + + when Discrete_Kind => + Write_Str ("Bounds: Id = "); + + if Present (Scalar_Range (Id)) then + Write_Int (Int (Type_Low_Bound (Id))); + Write_Str (" .. Id = "); + Write_Int (Int (Type_High_Bound (Id))); + else + Write_Str ("Empty"); + end if; + + Write_Eol; + + when Array_Kind => + declare + Index : E; + + begin + Write_Attribute + (" Component Type ", Component_Type (Id)); + Write_Eol; + Write_Str (Prefix); + Write_Str (" Indexes "); + + Index := First_Index (Id); + while Present (Index) loop + Write_Attribute (" ", Etype (Index)); + Index := Next_Index (Index); + end loop; + + Write_Eol; + end; + + when Access_Kind => + Write_Attribute + (" Directly Designated Type ", + Directly_Designated_Type (Id)); + Write_Eol; + + when Overloadable_Kind => + if Present (Homonym (Id)) then + Write_Str (" Homonym "); + Write_Name (Chars (Homonym (Id))); + Write_Str (" "); + Write_Int (Int (Homonym (Id))); + Write_Eol; + end if; + + Write_Eol; + + when E_Component => + if Ekind (Scope (Id)) in Record_Kind then + Write_Attribute ( + " Original_Record_Component ", + Original_Record_Component (Id)); + Write_Int (Int (Original_Record_Component (Id))); + Write_Eol; + end if; + + when others => null; + end case; + end Write_Entity_Info; + + ----------------------- + -- Write_Field6_Name -- + ----------------------- + + procedure Write_Field6_Name (Id : Entity_Id) is + pragma Warnings (Off, Id); + begin + Write_Str ("First_Rep_Item"); + end Write_Field6_Name; + + ----------------------- + -- Write_Field7_Name -- + ----------------------- + + procedure Write_Field7_Name (Id : Entity_Id) is + pragma Warnings (Off, Id); + begin + Write_Str ("Freeze_Node"); + end Write_Field7_Name; + + ----------------------- + -- Write_Field8_Name -- + ----------------------- + + procedure Write_Field8_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when E_Component | + E_Discriminant => + Write_Str ("Normalized_First_Bit"); + + when Formal_Kind | + E_Function | + E_Subprogram_Body => + Write_Str ("Mechanism"); + + when Type_Kind => + Write_Str ("Associated_Node_For_Itype"); + + when E_Loop => + Write_Str ("First_Exit_Statement"); + + when E_Package => + Write_Str ("Dependent_Instances"); + + when E_Procedure => + Write_Str ("Postcondition_Proc"); + + when E_Return_Statement => + Write_Str ("Return_Applies_To"); + + when E_Variable => + Write_Str ("Hiding_Loop_Variable"); + + when others => + Write_Str ("Field8??"); + end case; + end Write_Field8_Name; + + ----------------------- + -- Write_Field9_Name -- + ----------------------- + + procedure Write_Field9_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Type_Kind => + Write_Str ("Class_Wide_Type"); + + when E_Function | + E_Generic_Function | + E_Generic_Package | + E_Generic_Procedure | + E_Package | + E_Procedure => + Write_Str ("Renaming_Map"); + + when Object_Kind => + Write_Str ("Current_Value"); + + when others => + Write_Str ("Field9??"); + end case; + end Write_Field9_Name; + + ------------------------ + -- Write_Field10_Name -- + ------------------------ + + procedure Write_Field10_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Class_Wide_Kind | + Incomplete_Kind | + E_Record_Type | + E_Record_Subtype | + Private_Kind | + Concurrent_Kind => + Write_Str ("Direct_Primitive_Operations"); + + when Float_Kind => + Write_Str ("Float_Rep"); + + when E_In_Parameter | + E_Constant => + Write_Str ("Discriminal_Link"); + + when E_Function | + E_Package | + E_Package_Body | + E_Procedure => + Write_Str ("Handler_Records"); + + when E_Component | + E_Discriminant => + Write_Str ("Normalized_Position_Max"); + + when others => + Write_Str ("Field10??"); + end case; + end Write_Field10_Name; + + ------------------------ + -- Write_Field11_Name -- + ------------------------ + + procedure Write_Field11_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Formal_Kind => + Write_Str ("Entry_Component"); + + when E_Component | + E_Discriminant => + Write_Str ("Component_Bit_Offset"); + + when E_Constant => + Write_Str ("Full_View"); + + when E_Enumeration_Literal => + Write_Str ("Enumeration_Pos"); + + when E_Block => + Write_Str ("Block_Node"); + + when E_Function | + E_Procedure | + E_Entry | + E_Entry_Family => + Write_Str ("Protected_Body_Subprogram"); + + when E_Generic_Package => + Write_Str ("Generic_Homonym"); + + when Type_Kind => + Write_Str ("Full_View"); + + when others => + Write_Str ("Field11??"); + end case; + end Write_Field11_Name; + + ------------------------ + -- Write_Field12_Name -- + ------------------------ + + procedure Write_Field12_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Entry_Kind => + Write_Str ("Barrier_Function"); + + when E_Enumeration_Literal => + Write_Str ("Enumeration_Rep"); + + when Type_Kind | + E_Component | + E_Constant | + E_Discriminant | + E_Exception | + E_In_Parameter | + E_In_Out_Parameter | + E_Out_Parameter | + E_Loop_Parameter | + E_Variable => + Write_Str ("Esize"); + + when E_Function | + E_Procedure => + Write_Str ("Next_Inlined_Subprogram"); + + when E_Package => + Write_Str ("Associated_Formal_Package"); + + when others => + Write_Str ("Field12??"); + end case; + end Write_Field12_Name; + + ------------------------ + -- Write_Field13_Name -- + ------------------------ + + procedure Write_Field13_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Type_Kind => + Write_Str ("RM_Size"); + + when E_Component | + E_Discriminant => + Write_Str ("Component_Clause"); + + when E_Function => + if not Comes_From_Source (Id) + and then + Chars (Id) = Name_Op_Ne + then + Write_Str ("Corresponding_Equality"); + + elsif Comes_From_Source (Id) then + Write_Str ("Elaboration_Entity"); + + else + Write_Str ("Field13??"); + end if; + + when Formal_Kind | + E_Variable => + Write_Str ("Extra_Accessibility"); + + when E_Procedure | + E_Package | + Generic_Unit_Kind => + Write_Str ("Elaboration_Entity"); + + when others => + Write_Str ("Field13??"); + end case; + end Write_Field13_Name; + + ----------------------- + -- Write_Field14_Name -- + ----------------------- + + procedure Write_Field14_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Type_Kind | + Formal_Kind | + E_Constant | + E_Exception | + E_Variable | + E_Loop_Parameter => + Write_Str ("Alignment"); + + when E_Component | + E_Discriminant => + Write_Str ("Normalized_Position"); + + when E_Function | + E_Procedure => + Write_Str ("First_Optional_Parameter"); + + when E_Package | + E_Generic_Package => + Write_Str ("Shadow_Entities"); + + when others => + Write_Str ("Field14??"); + end case; + end Write_Field14_Name; + + ------------------------ + -- Write_Field15_Name -- + ------------------------ + + procedure Write_Field15_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Access_Kind | + Task_Kind => + Write_Str ("Storage_Size_Variable"); + + when E_Component => + Write_Str ("DT_Entry_Count"); + + when Decimal_Fixed_Point_Kind => + Write_Str ("Scale_Value"); + + when E_Discriminant => + Write_Str ("Discriminant_Number"); + + when Formal_Kind => + Write_Str ("Extra_Formal"); + + when E_Function | + E_Procedure => + Write_Str ("DT_Position"); + + when Entry_Kind => + Write_Str ("Entry_Parameters_Type"); + + when Enumeration_Kind => + Write_Str ("Lit_Indexes"); + + when E_Package | + E_Package_Body => + Write_Str ("Related_Instance"); + + when E_Protected_Type => + Write_Str ("Entry_Bodies_Array"); + + when E_String_Literal_Subtype => + Write_Str ("String_Literal_Low_Bound"); + + when others => + Write_Str ("Field15??"); + end case; + end Write_Field15_Name; + + ------------------------ + -- Write_Field16_Name -- + ------------------------ + + procedure Write_Field16_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when E_Component => + Write_Str ("Entry_Formal"); + + when E_Function | + E_Procedure => + Write_Str ("DTC_Entity"); + + when E_Package | + E_Generic_Package | + Concurrent_Kind => + Write_Str ("First_Private_Entity"); + + when E_Record_Type | + E_Record_Type_With_Private => + Write_Str ("Access_Disp_Table"); + + when E_String_Literal_Subtype => + Write_Str ("String_Literal_Length"); + + when Enumeration_Kind => + Write_Str ("Lit_Strings"); + + when E_Variable | + E_Out_Parameter => + Write_Str ("Unset_Reference"); + + when E_Record_Subtype | + E_Class_Wide_Subtype => + Write_Str ("Cloned_Subtype"); + + when others => + Write_Str ("Field16??"); + end case; + end Write_Field16_Name; + + ------------------------ + -- Write_Field17_Name -- + ------------------------ + + procedure Write_Field17_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Digits_Kind => + Write_Str ("Digits_Value"); + + when E_Component => + Write_Str ("Prival"); + + when E_Discriminant => + Write_Str ("Discriminal"); + + when E_Block | + Class_Wide_Kind | + Concurrent_Kind | + Private_Kind | + E_Entry | + E_Entry_Family | + E_Function | + E_Generic_Function | + E_Generic_Package | + E_Generic_Procedure | + E_Loop | + E_Operator | + E_Package | + E_Package_Body | + E_Procedure | + E_Record_Type | + E_Record_Subtype | + E_Return_Statement | + E_Subprogram_Body | + E_Subprogram_Type => + Write_Str ("First_Entity"); + + when Array_Kind => + Write_Str ("First_Index"); + + when Enumeration_Kind => + Write_Str ("First_Literal"); + + when Access_Kind => + Write_Str ("Master_Id"); + + when Modular_Integer_Kind => + Write_Str ("Modulus"); + + when Formal_Kind | + E_Constant | + E_Generic_In_Out_Parameter | + E_Variable => + Write_Str ("Actual_Subtype"); + + when E_Incomplete_Type => + Write_Str ("Non_Limited_View"); + + when E_Incomplete_Subtype => + if From_With_Type (Id) then + Write_Str ("Non_Limited_View"); + end if; + + when others => + Write_Str ("Field17??"); + end case; + end Write_Field17_Name; + + ------------------------ + -- Write_Field18_Name -- + ------------------------ + + procedure Write_Field18_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when E_Enumeration_Literal | + E_Function | + E_Operator | + E_Procedure => + Write_Str ("Alias"); + + when E_Record_Type => + Write_Str ("Corresponding_Concurrent_Type"); + + when E_Subprogram_Body => + Write_Str ("Corresponding_Protected_Entry"); + + when E_Entry_Index_Parameter => + Write_Str ("Entry_Index_Constant"); + + when E_Class_Wide_Subtype | + E_Access_Protected_Subprogram_Type | + E_Anonymous_Access_Protected_Subprogram_Type | + E_Access_Subprogram_Type | + E_Exception_Type => + Write_Str ("Equivalent_Type"); + + when Fixed_Point_Kind => + Write_Str ("Delta_Value"); + + when Object_Kind => + Write_Str ("Renamed_Object"); + + when E_Exception | + E_Package | + E_Generic_Function | + E_Generic_Procedure | + E_Generic_Package => + Write_Str ("Renamed_Entity"); + + when Incomplete_Or_Private_Kind | + E_Record_Subtype => + Write_Str ("Private_Dependents"); + + when Concurrent_Kind => + Write_Str ("Corresponding_Record_Type"); + + when E_Label | + E_Loop | + E_Block => + Write_Str ("Enclosing_Scope"); + + when others => + Write_Str ("Field18??"); + end case; + end Write_Field18_Name; + + ----------------------- + -- Write_Field19_Name -- + ----------------------- + + procedure Write_Field19_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when E_Array_Type | + E_Array_Subtype => + Write_Str ("Related_Array_Object"); + + when E_Block | + Concurrent_Kind | + E_Function | + E_Procedure | + E_Return_Statement | + Entry_Kind => + Write_Str ("Finalization_Chain_Entity"); + + when E_Constant | E_Variable => + Write_Str ("Size_Check_Code"); + + when E_Discriminant => + Write_Str ("Corresponding_Discriminant"); + + when E_Package | + E_Generic_Package => + Write_Str ("Body_Entity"); + + when E_Package_Body | + Formal_Kind => + Write_Str ("Spec_Entity"); + + when Private_Kind => + Write_Str ("Underlying_Full_View"); + + when E_Record_Type => + Write_Str ("Parent_Subtype"); + + when others => + Write_Str ("Field19??"); + end case; + end Write_Field19_Name; + + ----------------------- + -- Write_Field20_Name -- + ----------------------- + + procedure Write_Field20_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Array_Kind => + Write_Str ("Component_Type"); + + when E_In_Parameter | + E_Generic_In_Parameter => + Write_Str ("Default_Value"); + + when Access_Kind => + Write_Str ("Directly_Designated_Type"); + + when E_Component => + Write_Str ("Discriminant_Checking_Func"); + + when E_Constant | + E_Variable => + Write_Str ("Prival_Link"); + + when E_Discriminant => + Write_Str ("Discriminant_Default_Value"); + + when E_Block | + Class_Wide_Kind | + Concurrent_Kind | + Private_Kind | + E_Entry | + E_Entry_Family | + E_Function | + E_Generic_Function | + E_Generic_Package | + E_Generic_Procedure | + E_Loop | + E_Operator | + E_Package | + E_Package_Body | + E_Procedure | + E_Record_Type | + E_Record_Subtype | + E_Return_Statement | + E_Subprogram_Body | + E_Subprogram_Type => + Write_Str ("Last_Entity"); + + when Scalar_Kind => + Write_Str ("Scalar_Range"); + + when E_Exception => + Write_Str ("Register_Exception_Call"); + + when others => + Write_Str ("Field20??"); + end case; + end Write_Field20_Name; + + ----------------------- + -- Write_Field21_Name -- + ----------------------- + + procedure Write_Field21_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when E_Constant | + E_Exception | + E_Function | + E_Generic_Function | + E_Procedure | + E_Generic_Procedure | + E_Variable => + Write_Str ("Interface_Name"); + + when Concurrent_Kind | + Incomplete_Or_Private_Kind | + Class_Wide_Kind | + E_Record_Type | + E_Record_Subtype => + Write_Str ("Discriminant_Constraint"); + + when Entry_Kind => + Write_Str ("Accept_Address"); + + when Fixed_Point_Kind => + Write_Str ("Small_Value"); + + when E_In_Parameter => + Write_Str ("Default_Expr_Function"); + + when Array_Kind | + Modular_Integer_Kind => + Write_Str ("Original_Array_Type"); + + when others => + Write_Str ("Field21??"); + end case; + end Write_Field21_Name; + + ----------------------- + -- Write_Field22_Name -- + ----------------------- + + procedure Write_Field22_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Access_Kind => + Write_Str ("Associated_Storage_Pool"); + + when Array_Kind => + Write_Str ("Component_Size"); + + when E_Component | + E_Discriminant => + Write_Str ("Original_Record_Component"); + + when E_Enumeration_Literal => + Write_Str ("Enumeration_Rep_Expr"); + + when E_Exception => + Write_Str ("Exception_Code"); + + when Formal_Kind => + Write_Str ("Protected_Formal"); + + when E_Record_Type => + Write_Str ("Corresponding_Remote_Type"); + + when E_Block | + E_Entry | + E_Entry_Family | + E_Function | + E_Loop | + E_Package | + E_Package_Body | + E_Generic_Package | + E_Generic_Function | + E_Generic_Procedure | + E_Procedure | + E_Protected_Type | + E_Return_Statement | + E_Subprogram_Body | + E_Task_Type => + Write_Str ("Scope_Depth_Value"); + + when E_Record_Type_With_Private | + E_Record_Subtype_With_Private | + E_Private_Type | + E_Private_Subtype | + E_Limited_Private_Type | + E_Limited_Private_Subtype => + Write_Str ("Private_View"); + + when E_Variable => + Write_Str ("Shared_Var_Procs_Instance"); + + when others => + Write_Str ("Field22??"); + end case; + end Write_Field22_Name; + + ------------------------ + -- Write_Field23_Name -- + ------------------------ + + procedure Write_Field23_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Access_Kind => + Write_Str ("Associated_Final_Chain"); + + when Array_Kind => + Write_Str ("Packed_Array_Type"); + + when E_Block => + Write_Str ("Entry_Cancel_Parameter"); + + when E_Discriminant => + Write_Str ("CR_Discriminant"); + + when E_Enumeration_Type => + Write_Str ("Enum_Pos_To_Rep"); + + when Formal_Kind | + E_Variable => + Write_Str ("Extra_Constrained"); + + when E_Generic_Function | + E_Generic_Package | + E_Generic_Procedure => + Write_Str ("Inner_Instances"); + + when Concurrent_Kind | + Incomplete_Or_Private_Kind | + Class_Wide_Kind | + E_Record_Type | + E_Record_Subtype => + Write_Str ("Stored_Constraint"); + + when E_Function | + E_Procedure => + if Present (Scope (Id)) + and then Is_Protected_Type (Scope (Id)) + then + Write_Str ("Protection_Object"); + else + Write_Str ("Generic_Renamings"); + end if; + + when E_Package => + if Is_Generic_Instance (Id) then + Write_Str ("Generic_Renamings"); + else + Write_Str ("Limited_View"); + end if; + + when Entry_Kind => + Write_Str ("Protection_Object"); + + when others => + Write_Str ("Field23??"); + end case; + end Write_Field23_Name; + + ------------------------ + -- Write_Field24_Name -- + ------------------------ + + procedure Write_Field24_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Subprogram_Kind => + Write_Str ("Spec_PPC_List"); + + when E_Variable | E_Constant | Type_Kind => + Write_Str ("Related_Expression"); + + when others => + Write_Str ("Field24???"); + end case; + end Write_Field24_Name; + + ------------------------ + -- Write_Field25_Name -- + ------------------------ + + procedure Write_Field25_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when E_Component => + Write_Str ("DT_Offset_To_Top_Func"); + + when E_Procedure | + E_Function => + Write_Str ("Interface_Alias"); + + when E_Record_Type | + E_Record_Subtype | + E_Record_Type_With_Private | + E_Record_Subtype_With_Private => + Write_Str ("Interfaces"); + + when Task_Kind => + Write_Str ("Task_Body_Procedure"); + + when E_Variable => + Write_Str ("Debug_Renaming_Link"); + + when E_Entry | + E_Entry_Family => + Write_Str ("PPC_Wrapper"); + + when E_Enumeration_Subtype | + E_Modular_Integer_Subtype | + E_Signed_Integer_Subtype => + Write_Str ("Static_Predicate"); + + when others => + Write_Str ("Field25??"); + end case; + end Write_Field25_Name; + + ------------------------ + -- Write_Field26_Name -- + ------------------------ + + procedure Write_Field26_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when E_Generic_Package | + E_Package => + Write_Str ("Package_Instantiation"); + + when E_Procedure | + E_Function => + if Is_Dispatching_Operation (Id) then + Write_Str ("Overridden_Operation"); + else + Write_Str ("Static_Initialization"); + end if; + + when E_Record_Type | + E_Record_Type_With_Private => + Write_Str ("Dispatch_Table_Wrappers"); + + when E_In_Out_Parameter | + E_Out_Parameter | + E_Variable => + Write_Str ("Last_Assignment"); + + when Task_Kind => + Write_Str ("Relative_Deadline_Variable"); + + when others => + Write_Str ("Field26??"); + end case; + end Write_Field26_Name; + + ------------------------ + -- Write_Field27_Name -- + ------------------------ + + procedure Write_Field27_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when E_Component | + E_Constant | + E_Variable => + Write_Str ("Related_Type"); + + when E_Procedure => + Write_Str ("Wrapped_Entity"); + + when E_Package | Type_Kind => + Write_Str ("Current_Use_Clause"); + + when others => + Write_Str ("Field27??"); + end case; + end Write_Field27_Name; + + ------------------------ + -- Write_Field28_Name -- + ------------------------ + + procedure Write_Field28_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when E_Procedure | E_Function | E_Entry => + Write_Str ("Extra_Formals"); + + when E_Record_Type => + Write_Str ("Underlying_Record_View"); + + when others => + Write_Str ("Field28??"); + end case; + end Write_Field28_Name; + + procedure Write_Field29_Name (Id : Entity_Id) is + begin + case Ekind (Id) is + when Type_Kind => + Write_Str ("Subprograms_For_Type"); + + when others => + Write_Str ("Field29??"); + end case; + end Write_Field29_Name; + + ------------------------- + -- Iterator Procedures -- + ------------------------- + + procedure Proc_Next_Component (N : in out Node_Id) is + begin + N := Next_Component (N); + end Proc_Next_Component; + + procedure Proc_Next_Component_Or_Discriminant (N : in out Node_Id) is + begin + N := Next_Entity (N); + while Present (N) loop + exit when Ekind_In (N, E_Component, E_Discriminant); + N := Next_Entity (N); + end loop; + end Proc_Next_Component_Or_Discriminant; + + procedure Proc_Next_Discriminant (N : in out Node_Id) is + begin + N := Next_Discriminant (N); + end Proc_Next_Discriminant; + + procedure Proc_Next_Formal (N : in out Node_Id) is + begin + N := Next_Formal (N); + end Proc_Next_Formal; + + procedure Proc_Next_Formal_With_Extras (N : in out Node_Id) is + begin + N := Next_Formal_With_Extras (N); + end Proc_Next_Formal_With_Extras; + + procedure Proc_Next_Index (N : in out Node_Id) is + begin + N := Next_Index (N); + end Proc_Next_Index; + + procedure Proc_Next_Inlined_Subprogram (N : in out Node_Id) is + begin + N := Next_Inlined_Subprogram (N); + end Proc_Next_Inlined_Subprogram; + + procedure Proc_Next_Literal (N : in out Node_Id) is + begin + N := Next_Literal (N); + end Proc_Next_Literal; + + procedure Proc_Next_Stored_Discriminant (N : in out Node_Id) is + begin + N := Next_Stored_Discriminant (N); + end Proc_Next_Stored_Discriminant; + +end Einfo; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads new file mode 100644 index 000000000..88fabd76f --- /dev/null +++ b/gcc/ada/einfo.ads @@ -0,0 +1,7997 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E I N F O -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with Namet; use Namet; +with Snames; use Snames; +with Types; use Types; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package Einfo is + +-- This package defines the annotations to the abstract syntax tree that +-- are needed to support semantic processing of an Ada compilation. + +-- Note that after editing this spec and the corresponding body it is +-- required to run ceinfo to check the consistentcy of spec and body. +-- See ceinfo.adb for more information about the checks made. + +-- These annotations are for the most part attributes of declared entities, +-- and they correspond to conventional symbol table information. Other +-- attributes include sets of meanings for overloaded names, possible +-- types for overloaded expressions, flags to indicate deferred constants, +-- incomplete types, etc. These attributes are stored in available fields +-- in tree nodes (i.e. fields not used by the parser, as defined by the +-- Sinfo package specification), and accessed by means of a set of +-- subprograms which define an abstract interface. + +-- There are two kinds of semantic information + +-- First, the tree nodes with the following Nkind values: + +-- N_Defining_Identifier +-- N_Defining_Character_Literal +-- N_Defining_Operator_Symbol + +-- are called Entities, and constitute the information that would often +-- be stored separately in a symbol table. These nodes are all extended +-- to provide extra space, and contain fields which depend on the entity +-- kind, as defined by the contents of the Ekind field. The use of the +-- Ekind field, and the associated fields in the entity, are defined +-- in this package, as are the access functions to these fields. + +-- Second, in some cases semantic information is stored directly in other +-- kinds of nodes, e.g. the Etype field, used to indicate the type of an +-- expression. The access functions to these fields are defined in the +-- Sinfo package, but their full documentation is to be found in +-- the Einfo package specification. + +-- Declaration processing places information in the nodes of their defining +-- identifiers. Name resolution places in all other occurrences of an +-- identifier a pointer to the corresponding defining occurrence. + +-------------------------------- +-- The XEINFO Utility Program -- +-------------------------------- + +-- XEINFO is a utility program which automatically produces a C header file, +-- einfo.h from the spec and body of package Einfo. It reads the input +-- files einfo.ads and einfo.adb and produces the output file einfo.h. +-- XEINFO is run automatically by the build scripts when you do a full +-- bootstrap. + +-- In order for this utility program to operate correctly, the form of the +-- einfo.ads and einfo.adb files must meet certain requirements and be laid +-- out in a specific manner. + +-- The general form of einfo.ads is as follows: + +-- type declaration for type Entity_Kind +-- subtype declarations declaring subranges of Entity_Kind +-- subtype declarations declaring synonyms for some standard types +-- function specs for attributes +-- procedure specs +-- pragma Inline declarations + +-- This order must be observed. There are no restrictions on the procedures, +-- since the C header file only includes functions (Gigi is not allowed to +-- modify the generated tree). However, functions are required to have headers +-- that fit on a single line. + +-- XEINFO reads and processes the function specs and the pragma Inlines. For +-- functions that are declared as inlined, XEINFO reads the corresponding body +-- from einfo.adb, and processes it into C code. This results in some strict +-- restrictions on which functions can be inlined: + +-- The function spec must be on a single line + +-- There can only be a single statement, contained on a single line, +-- not counting any pragma Assert statements. + +-- This single statement must either be a function call with simple, +-- single token arguments, or it must be a membership test of the form +-- a in b, where a and b are single tokens. + +-- For functions that are not inlined, there is no restriction on the body, +-- and XEINFO generates a direct reference in the C header file which allows +-- the C code in Gigi to directly call the corresponding Ada body. + +---------------------------------- +-- Handling of Type'Size Values -- +---------------------------------- + +-- The Ada 95 RM contains some rather peculiar (to us!) rules on the value +-- of type'Size (see RM 13.3(55)). We have found that attempting to use +-- these RM Size values generally, and in particular for determining the +-- default size of objects, creates chaos, and major incompatibilies in +-- existing code. + +-- We proceed as follows, for discrete and fixed-point subtypes, we have +-- two separate sizes for each subtype: + +-- The Object_Size, which is used for determining the default size of +-- objects and components. This size value can be referred to using the +-- Object_Size attribute. The phrase "is used" here means that it is +-- the basis of the determination of the size. The backend is free to +-- pad this up if necessary for efficiency, e.g. an 8-bit stand-alone +-- character might be stored in 32 bits on a machine with no efficient +-- byte access instructions such as the Alpha. + +-- The default rules for the value of Object_Size for fixed-point and +-- discrete types are as follows: + +-- The Object_Size for base subtypes reflect the natural hardware +-- size in bits (see Ttypes and Cstand for integer types). For +-- enumeration and fixed-point base subtypes have 8. 16. 32 or 64 +-- bits for this size, depending on the range of values to be stored. + +-- The Object_Size of a subtype is the same as the Object_Size of +-- the subtype from which it is obtained. + +-- The Object_Size of a derived base type is copied from the parent +-- base type, and the Object_Size of a derived first subtype is copied +-- from the parent first subtype. + +-- The Value_Size which is the number of bits required to store a value +-- of the type. This size can be referred to using the Value_Size +-- attribute. This value is used to determine how tightly to pack +-- records or arrays with components of this type, and also affects +-- the semantics of unchecked conversion (unchecked conversions where +-- the Value_Size values differ generate a warning, and are potentially +-- target dependent). + +-- The default rule for the value of Value_Size are as follows: + +-- The Value_Size for a base subtype is the minimum number of bits +-- required to store all values of the type (including the sign bit +-- only if negative values are possible). + +-- If a subtype statically matches the first subtype, then it has +-- by default the same Value_Size as the first subtype. This is a +-- consequence of RM 13.1(14) ("if two subtypes statically match, +-- then their subtype-specific aspects are the same".) + +-- All other subtypes have a Value_Size corresponding to the minimum +-- number of bits required to store all values of the subtype. For +-- dynamic bounds, it is assumed that the value can range down or up +-- to the corresponding bound of the ancestor + +-- The RM defined attribute Size corresponds to the Value_Size attribute + +-- The Size attribute may be defined for a first-named subtype. This sets +-- the Value_Size of the first-named subtype to the given value, and the +-- Object_Size of this first-named subtype to the given value padded up +-- to an appropriate boundary. It is a consequence of the default rules +-- above that this Object_Size will apply to all further subtypes. On the +-- other hand, Value_Size is affected only for the first subtype, any +-- dynamic subtypes obtained from it directly, and any statically matching +-- subtypes. The Value_Size of any other static subtypes is not affected. + +-- Value_Size and Object_Size may be explicitly set for any subtype using +-- an attribute definition clause. Note that the use of these attributes +-- can cause the RM 13.1(14) rule to be violated. If two access types +-- reference aliased objects whose subtypes have differing Object_Size +-- values as a result of explicit attribute definition clauses, then it +-- is erroneous to convert from one access subtype to the other. + +-- At the implementation level, Esize stores the Object_Size and the +-- RM_Size field stores the Value_Size (and hence the value of the +-- Size attribute, which, as noted above, is equivalent to Value_Size). + +-- To get a feel for the difference, consider the following examples (note +-- that in each case the base is short_short_integer with a size of 8): + +-- Object_Size Value_Size + +-- type x1 is range 0..5; 8 3 + +-- type x2 is range 0..5; +-- for x2'size use 12; 16 12 + +-- subtype x3 is x2 range 0 .. 3; 16 2 + +-- subtype x4 is x2'base range 0 .. 10; 8 4 + +-- subtype x5 is x2 range 0 .. dynamic; 16 (7) + +-- subtype x6 is x2'base range 0 .. dynamic; 8 (7) + +-- Note: the entries marked (7) are not actually specified by the Ada 95 RM, +-- but it seems in the spirit of the RM rules to allocate the minimum number +-- of bits known to be large enough to hold the given range of values. + +-- So far, so good, but GNAT has to obey the RM rules, so the question is +-- under what conditions must the RM Size be used. The following is a list +-- of the occasions on which the RM Size must be used: + +-- Component size for packed arrays or records +-- Value of the attribute Size for a type +-- Warning about sizes not matching for unchecked conversion + +-- The RM_Size field keeps track of the RM Size as needed in these +-- three situations. + +-- For elementary types other than discrete and fixed-point types, the +-- Object_Size and Value_Size are the same (and equivalent to the RM +-- attribute Size). Only Size may be specified for such types. + +-- For composite types, Object_Size and Value_Size are computed from their +-- respective value for the type of each element as well as the layout. + +-- All size attributes are stored as Uint values. Negative values are used to +-- reference GCC expressions for the case of non-static sizes, as explained +-- in Repinfo. + +-------------------------------------- +-- Delayed Freezing and Elaboration -- +-------------------------------------- + +-- The flag Has_Delayed_Freeze indicates that an entity carries an explicit +-- freeze node, which appears later in the expanded tree. + +-- a) The flag is used by the front-end to trigger expansion actions which +-- include the generation of that freeze node. Typically this happens at the +-- end of the current compilation unit, or before the first subprogram body is +-- encountered in the current unit. See files freeze and exp_ch13 for details +-- on the actions triggered by a freeze node, which include the construction +-- of initialization procedures and dispatch tables. + +-- b) The presence of a freeze node on an entity is used by the backend to +-- defer elaboration of the entity until its freeze node is seen. In the +-- absence of an explicit freeze node, an entity is frozen (and elaborated) +-- at the point of declaration. + +-- For object declarations, the flag is set when an address clause for the +-- object is encountered. Legality checks on the address expression only take +-- place at the freeze point of the object. + +-- Most types have an explicit freeze node, because they cannot be elaborated +-- until all representation and operational items that apply to them have been +-- analyzed. Private types and incomplete types have the flag set as well, as +-- do task and protected types. + +-- Implicit base types created for type derivations, as well as classwide +-- types created for all tagged types, have the flag set. + +-- If a subprogram has an access parameter whose designated type is incomplete +-- the subprogram has the flag set. + +----------------------- +-- Entity Attributes -- +----------------------- + +-- This section contains a complete list of the attributes that are defined +-- on entities. Some attributes apply to all entities, others only to certain +-- kinds of entities. In the latter case the attribute should only be set or +-- accessed if the Ekind field indicates an appropriate entity. + +-- There are two kinds of attributes that apply to entities, stored and +-- synthesized. Stored attributes correspond to a field or flag in the entity +-- itself. Such attributes are identified in the table below by giving the +-- field or flag in the attribute that is used to hold the attribute value. +-- Synthesized attributes are not stored directly, but are rather computed as +-- needed from other attributes, or from information in the tree. These are +-- marked "synthesized" in the table below. The stored attributes have both +-- access functions and set procedures to set the corresponding values, while +-- synthesized attributes have only access functions. + +-- Note: in the case of Node, Uint, or Elist fields, there are cases where +-- the same physical field is used for different purposes in different +-- entities, so these access functions should only be referenced for the +-- class of entities in which they are defined as being present. Flags are +-- not overlapped in this way, but nevertheless as a matter of style and +-- abstraction (which may or may not be checked by assertions in the body), +-- this restriction should be observed for flag fields as well. + +-- Note: certain of the attributes on types apply only to base types, and +-- are so noted by the notation [base type only]. These are cases where the +-- attribute of any subtype is the same as the attribute of the base type. +-- The attribute can be referenced on a subtype (and automatically retrieves +-- the value from the base type). However, it is an error to try to set the +-- attribute on other than the base type, and if assertions are enabled, +-- an attempt to set the attribute on a subtype will raise an assert error. + +-- Other attributes are noted as applying to the [implementation base type +-- only]. These are representation attributes which must always apply to a +-- full non-private type, and where the attributes are always on the full +-- type. The attribute can be referenced on a subtype (and automatically +-- retries the value from the implementation base type). However, it is an +-- error to try to set the attribute on other than the implementation base +-- type, and if assertions are enabled, an attempt to set the attribute on a +-- subtype will raise an assert error. + +-- Accept_Address (Elist21) +-- Present in entries. If an accept has a statement sequence, then an +-- address variable is created, which is used to hold the address of the +-- parameters, as passed by the runtime. Accept_Address holds an element +-- list which represents a stack of entities for these address variables. +-- The current entry is the top of the stack, which is the last element +-- on the list. A stack is required to handle the case of nested select +-- statements referencing the same entry. + +-- Access_Disp_Table (Elist16) [implementation base type only] +-- Present in record type entities. For a tagged type, points to the +-- dispatch tables associated with the tagged type. The first two +-- entities correspond with the primary dispatch table: 1) primary +-- dispatch table with user-defined primitives, 2) primary dispatch table +-- with predefined primitives. For each interface type covered by the +-- tagged type we also have: 3) secondary dispatch table with thunks of +-- primitives covering user-defined interface primitives, 4) secondary +-- dispatch table with thunks of predefined primitives, 5) secondary +-- dispatch table with user-defined primitives, and 6) secondary dispatch +-- table with predefined primitives. The last entity of this list is an +-- access type declaration used to expand dispatching calls through the +-- primary dispatch table. For a non-tagged record, contains Empty. + +-- Actual_Subtype (Node17) +-- Present in variables, constants, and formal parameters. This is the +-- subtype imposed by the value of the object, as opposed to its nominal +-- subtype, which is imposed by the declaration. The actual subtype +-- differs from the nominal one when the latter is indefinite (as in the +-- case of an unconstrained formal parameter, or a variable declared +-- with an unconstrained type and an initial value). The nominal subtype +-- is the Etype entry for the entity. The Actual_Subtype field is set +-- only if the actual subtype differs from the nominal subtype. If the +-- actual and nominal subtypes are the same, then the Actual_Subtype +-- field is Empty, and Etype indicates both types. +-- +-- For objects, the Actual_Subtype is set only if this is a discriminated +-- type. For arrays, the bounds of the expression are obtained and the +-- Etype of the object is directly the constrained subtype. This is +-- rather irregular, and the semantic checks that depend on the nominal +-- subtype being unconstrained use flag Is_Constr_Subt_For_U_Nominal(qv). + +-- Address_Clause (synthesized) +-- Applies to entries, objects and subprograms. Set if an address clause +-- is present which references the object or subprogram and points to +-- the N_Attribute_Definition_Clause node. Empty if no Address clause. +-- The expression in the address clause is always a constant that is +-- defined before the entity to which the address clause applies. +-- Note: Gigi references this field in E_Task_Type entities??? + +-- Address_Taken (Flag104) +-- Present in all entities. Set if the Address or Unrestricted_Access +-- attribute is applied directly to the entity, i.e. the entity is the +-- entity of the prefix of the attribute reference. Used by Gigi to +-- make sure that the address can be meaningfully taken, and also in +-- the case of subprograms to control output of certain warnings. + +-- Aft_Value (synthesized) +-- Applies to fixed and decimal types. Computes a universal integer +-- that holds value of the Aft attribute for the type. + +-- Alias (Node18) +-- Present in overloaded entities (literals, subprograms, entries) and +-- subprograms that cover a primitive operation of an abstract interface +-- (that is, subprograms with the Interface_Alias attribute). In case of +-- overloaded entities it points to the parent subprogram of a derived +-- subprogram. In case of abstract interface subprograms it points to the +-- subprogram that covers the abstract interface primitive. Also used for +-- a subprogram renaming, where it points to the renamed subprogram. For +-- an inherited operation (of a type extension) that is overridden in a +-- private part, the Alias is the overriding operation. In this fashion a +-- call from outside the package ends up executing the new body even if +-- non-dispatching, and a call from inside calls the overriding operation +-- because it hides the implicit one. Alias is always empty for entries. + +-- Alignment (Uint14) +-- Present in entities for types and also in constants, variables +-- (including exceptions where it refers to the static data allocated for +-- an exception), loop parameters, and formal parameters. This indicates +-- the desired alignment for a type, or the actual alignment for an +-- object. A value of zero (Uint_0) indicates that the alignment has not +-- been set yet. The alignment can be set by an explicit alignment +-- clause, or set by the front-end in package Layout, or set by the +-- back-end as part of the back end back-annotation process. The +-- alignment field is also present in E_Exception entities, but there it +-- is used only by the back-end for back annotation. + +-- Alignment_Clause (synthesized) +-- Applies to all entities for types and objects. If an alignment +-- attribute definition clause is present for the entity, then this +-- function returns the N_Attribute_Definition clause that specifies the +-- alignment. If no alignment clause applies to the type, then the call +-- to this function returns Empty. Note that the call can return a +-- non-Empty value even if Has_Alignment_Clause is not set (happens with +-- subtype and derived type declarations). Note also that a record +-- definition clause with an (obsolescent) mod clause is converted +-- into an attribute definition clause for this purpose. + +-- Associated_Formal_Package (Node12) +-- Present in packages that are the actuals of formal_packages. Points +-- to the entity in the declaration for the formal package. + +-- Associated_Node_For_Itype (Node8) +-- Present in all type and subtype entities. Set non-Empty only for +-- Itypes. Set to point to the associated node for the Itype, i.e. +-- the node whose elaboration generated the Itype. This is used for +-- copying trees, to determine whether or not to copy an Itype, and +-- also for accessibility checks on anonymous access types. This +-- node is typically an object declaration, component declaration, +-- type or subtype declaration. For an access discriminant in a type +-- declaration, the associated_node_for_itype is the discriminant +-- specification. For an access parameter it is the enclosing subprogram +-- declaration. + +-- Associated_Storage_Pool (Node22) [root type only] +-- Present in simple and general access type entities. References the +-- storage pool to be used for the corresponding collection. A value of +-- Empty means that the default pool is to be used. This is present +-- only in the root type, since derived types must have the same pool +-- as the parent type. + +-- Associated_Final_Chain (Node23) +-- Present in simple and general access type entities. References the +-- List_Controller object that holds the finalization chain on which +-- are attached dynamically allocated objects referenced by the access +-- type. Empty when the access type cannot reference a controlled object. + +-- Barrier_Function (Node12) +-- Present in protected entries and entry families. This is the +-- subprogram declaration for the body of the function that returns +-- the value of the entry barrier. + +-- Base_Type (synthesized) +-- Applies to all type entities. Returns the base type of a type or +-- subtype. The base type of a type is the type itself. The base type +-- of a subtype is the type that it constrains (which is always a type +-- entity, not some other subtype). Note that in the case of a subtype +-- of a private type, it is possible for the base type attribute to +-- return a private type, even if the subtype to which it applies is +-- non-private. See also Implementation_Base_Type. Note: it is allowed +-- to apply Base_Type to other than a type, in which case it simply +-- returns the entity unchanged. + +-- Block_Node (Node11) +-- Present in block entities. Points to the identifier in the +-- Block_Statement itself. Used when retrieving the block construct +-- for finalization purposes, The block entity has an implicit label +-- declaration in the enclosing declarative part, and has otherwise +-- no direct connection in the tree with the block statement. The +-- link is to the identifier (which is an occurrence of the entity) +-- and not to the block_statement itself, because the statement may +-- be rewritten, e.g. in the process of removing dead code. + +-- Body_Entity (Node19) +-- Present in package and generic package entities, points to the +-- corresponding package body entity if one is present. + +-- Body_Needed_For_SAL (Flag40) +-- Present in package and subprogram entities that are compilation +-- units. Indicates that the source for the body must be included +-- when the unit is part of a standalone library. + +-- C_Pass_By_Copy (Flag125) [implementation base type only] +-- Present in record types. Set if a pragma Convention for the record +-- type specifies convention C_Pass_By_Copy. This convention name is +-- treated as identical in all respects to convention C, except that +-- if it is specified for a record type, then the C_Pass_By_Copy flag +-- is set, and if a foreign convention subprogram has a formal of the +-- corresponding type, then the parameter passing mechanism will be +-- set to By_Copy (unless specifically overridden by an Import or +-- Export pragma). + +-- Can_Never_Be_Null (Flag38) +-- This flag is present in all entities, but can only be set in an object +-- which can never have a null value. This is set True for constant +-- access values initialized to a non-null value. This is also True for +-- all access parameters in Ada 83 and Ada 95 modes, and for access +-- parameters that explicitly exclude null in Ada 2005. +-- +-- This is used to avoid unnecessary resetting of the Is_Known_Non_Null +-- flag for such entities. In Ada 2005 mode, this is also used when +-- determining subtype conformance of subprogram profiles to ensure +-- that two formals have the same null-exclusion status. +-- +-- ??? This is also set on some access types, eg the Etype of the +-- anonymous access type of a controlling formal. + +-- Chars (Name1) +-- Present in all entities. This field contains an entry into the names +-- table that has the character string of the identifier, character +-- literal or operator symbol. See Namet for further details. Note that +-- throughout the processing of the front end, this name is the simple +-- unqualified name. However, just before gigi is called, a call is made +-- to Qualify_All_Entity_Names. This causes entity names to be qualified +-- using the encoding described in exp_dbug.ads, and from that point on +-- (including post gigi steps such as cross-reference generation), the +-- entities will contain the encoded qualified names. + +-- Checks_May_Be_Suppressed (Flag31) +-- Present in all entities. Set if a pragma Suppress or Unsuppress +-- mentions the entity specifically in the second argument. If this +-- flag is set the Global_Entity_Suppress and Local_Entity_Suppress +-- tables must be consulted to determine if there actually is an active +-- Suppress or Unsuppress pragma that applies to the entity. + +-- Class_Wide_Type (Node9) +-- Present in all type entities. For a tagged type or subtype, returns +-- the corresponding implicitly declared class-wide type. Set to Empty +-- for non-tagged types. + +-- Cloned_Subtype (Node16) +-- Present in E_Record_Subtype and E_Class_Wide_Subtype entities. +-- Each such entity can either have a Discriminant_Constraint, in +-- which case it represents a distinct type from the base type (and +-- will have a list of components and discrimants in the list headed by +-- First_Entity) or else no such constraint, in which case it will be a +-- copy of the base type. +-- +-- o Each element of the list in First_Entity is copied from the base +-- type; in that case, this field is Empty. +-- +-- o The list in First_Entity is shared with the base type; in that +-- case, this field points to that entity. +-- +-- A record or classwide subtype may also be a copy of some other +-- subtype and share the entities in the First_Entity with that subtype. +-- In that case, this field points to that subtype. +-- +-- For E_Class_Wide_Subtype, the presence of Equivalent_Type overrides +-- this field. Note that this field ONLY appears in subtype entries, not +-- in type entries, it is not present, and it is an error to reference +-- Cloned_Subtype in an E_Record_Type or E_Class_Wide_Type entity. + +-- Comes_From_Source +-- This flag appears on all nodes, including entities, and indicates +-- that the node was created by the scanner or parser from the original +-- source. Thus for entities, it indicates that the entity is defined +-- in the original source program. + +-- Component_Alignment (special field) [base type only] +-- Present in array and record entities. Contains a value of type +-- Component_Alignment_Kind indicating the alignment of components. +-- Set to Calign_Default normally, but can be overridden by use of +-- the Component_Alignment pragma. Note: this field is currently +-- stored in a non-standard way, see body for details. + +-- Component_Bit_Offset (Uint11) +-- Present in record components (E_Component, E_Discriminant) if a +-- component clause applies to the component. First bit position of +-- given component, computed from the first bit and position values +-- given in the component clause. A value of No_Uint means that the +-- value is not yet known. The value can be set by the appearance of +-- an explicit component clause in a record representation clause, +-- or it can be set by the front-end in package Layout, or it can be +-- set by the backend. By the time backend processing is completed, +-- this field is always set. A negative value is used to represent +-- a value which is not known at compile time, and must be computed +-- at run-time (this happens if fields of a record have variable +-- lengths). See package Layout for details of these values. +-- +-- Note: Component_Bit_Offset is redundant with respect to the fields +-- Normalized_First_Bit and Normalized_Position, and could in principle +-- be eliminated, but it is convenient in several situations, including +-- use in Gigi, to have this redundant field. + +-- Component_Clause (Node13) +-- Present in record components and discriminants. If a record +-- representation clause is present for the corresponding record type a +-- that specifies a position for the component, then the Component_Clause +-- field of the E_Component entity points to the N_Component_Clause node. +-- Set to Empty if no record representation clause was present, or if +-- there was no specification for this component. + +-- Component_Size (Uint22) [implementation base type only] +-- Present in array types. It contains the component size value for +-- the array. A value of No_Uint means that the value is not yet set. +-- The value can be set by the use of a component size clause, or +-- by the front end in package Layout, or by the backend. A negative +-- value is used to represent a value which is not known at compile +-- time, and must be computed at run-time (this happens if the type +-- of the component has a variable length size). See package Layout +-- for details of these values. + +-- Component_Type (Node20) [implementation base type only] +-- Present in array types and string types. References component type. + +-- Corresponding_Concurrent_Type (Node18) +-- Present in record types that are constructed by the expander to +-- represent task and protected types (Is_Concurrent_Record_Type flag +-- set True). Points to the entity for the corresponding task type or +-- protected type. + +-- Corresponding_Discriminant (Node19) +-- Present in discriminants of a derived type, when the discriminant is +-- used to constrain a discriminant of the parent type. Points to the +-- corresponding discriminant in the parent type. Otherwise it is Empty. + +-- Corresponding_Equality (Node13) +-- Present in function entities for implicit inequality operators. +-- Denotes the explicit or derived equality operation that creates +-- the implicit inequality. Note that this field is not present in +-- other function entities, only in implicit inequality routines, +-- where Comes_From_Source is always False. + +-- Corresponding_Protected_Entry (Node18) +-- Present in subprogram bodies. Set for subprogram bodies that implement +-- a protected type entry to point to the entity for the entry. + +-- Corresponding_Record_Type (Node18) +-- Present in protected and task types and subtypes. References the +-- entity for the corresponding record type constructed by the expander +-- (see Exp_Ch9). This type is used to represent values of the task type. + +-- Corresponding_Remote_Type (Node22) +-- Present in record types that describe the fat pointer structure for +-- Remote_Access_To_Subprogram types. References the original access +-- type. + +-- CR_Discriminant (Node23) +-- Present in discriminants of concurrent types. Denotes the homologous +-- discriminant of the corresponding record type. The CR_Discriminant is +-- created at the same time as the discriminal, and used to replace +-- occurrences of the discriminant within the type declaration. + +-- Current_Use_Clause (Node27) +-- Present in packages and in types. For packages, denotes the use +-- package clause currently in scope that makes the package use_visible. +-- For types, it denotes the use_type clause that makes the operators of +-- the type visible. Used for more precise warning messages on redundant +-- use clauses. + +-- Current_Value (Node9) +-- Present in all object entities. Set in E_Variable, E_Constant, formal +-- parameters and E_Loop_Parameter entities if we have trackable current +-- values. Set non-Empty if the (constant) current value of the variable +-- is known, This value is valid only for references from the same +-- sequential scope as the entity. The sequential scope of an entity +-- includes the immediate scope and any contained scopes that are package +-- specs, package bodies, blocks (at any nesting level) or statement +-- sequences in IF or loop statements. +-- +-- Another related use of this field is to record information about the +-- value obtained from an IF or WHILE statement condition. If the IF or +-- ELSIF or WHILE condition has the form "NOT {,NOT] OBJ RELOP VAL ", +-- or OBJ [AND [THEN]] expr, where OBJ refers to an entity with a +-- Current_Value field, RELOP is one of the six relational operators, and +-- VAL is a compile-time known value then the Current_Value field of OBJ +-- points to the N_If_Statement, N_Elsif_Part, or N_Iteration_Scheme node +-- of the relevant construct, and the Condition field of this can be +-- consulted to give information about the value of OBJ. For more details +-- on this usage, see the procedure Exp_Util.Get_Current_Value_Condition. + +-- Debug_Info_Off (Flag166) +-- Present in all entities. Set if a pragma Suppress_Debug_Info applies +-- to the entity, or if internal processing in the compiler determines +-- that suppression of debug information is desirable. Note that this +-- flag is only for use by the front end as part of the processing for +-- determining if Needs_Debug_Info should be set. The back end should +-- always test Needs_Debug_Info, it should never test Debug_Info_Off. + +-- Debug_Renaming_Link (Node25) +-- Used to link the variable associated with a debug renaming declaration +-- to the renamed entity. See Exp_Dbug.Debug_Renaming_Declaration for +-- details of the use of this field. + +-- Declaration_Node (synthesized) +-- Applies to all entities. Returns the tree node for the construct that +-- declared the entity. Normally this is just the Parent of the entity. +-- One exception arises with child units, where the parent of the entity +-- is a selected component/defining program unit name. Another exception +-- is that if the entity is an incomplete type that has been completed, +-- then we obtain the declaration node denoted by the full type, i.e. the +-- full type declaration node. Also note that for subprograms, this +-- returns the {function,procedure}_specification, not the subprogram_ +-- declaration. + +-- Default_Expr_Function (Node21) +-- Present in parameters. It holds the entity of the parameterless +-- function that is built to evaluate the default expression if it is +-- more complex than a simple identifier or literal. For the latter +-- simple cases or if there is no default value, this field is Empty. + +-- Default_Expressions_Processed (Flag108) +-- A flag in subprograms (functions, operators, procedures) and in +-- entries and entry families used to indicate that default expressions +-- have been processed and to avoid multiple calls to process the +-- default expressions (see Freeze.Process_Default_Expressions), which +-- would not only waste time, but also generate false error messages. + +-- Default_Value (Node20) +-- Present in formal parameters. Points to the node representing the +-- expression for the default value for the parameter. Empty if the +-- parameter has no default value (which is always the case for OUT +-- and IN OUT parameters in the absence of errors). + +-- Delay_Cleanups (Flag114) +-- Present in entities that have finalization lists (subprograms +-- blocks, and tasks). Set if there are pending generic body +-- instantiations for the corresponding entity. If this flag is +-- set, then generation of cleanup actions for the corresponding +-- entity must be delayed, since the insertion of the generic body +-- may affect cleanup generation (see Inline for further details). + +-- Delay_Subprogram_Descriptors (Flag50) +-- Present in entities for which exception subprogram descriptors +-- are generated (subprograms, package declarations and package +-- bodies). Present if there are pending generic body instantiations +-- for the corresponding entity. If this flag is set, then generation +-- of the subprogram descriptor for the corresponding enities must +-- be delayed, since the insertion of the generic body may add entries +-- to the list of handlers. +-- +-- Note: for subprograms, Delay_Subprogram_Descriptors is set if and +-- only if Delay_Cleanups is set. But Delay_Cleanups can be set for a +-- a block (in which case Delay_Subprogram_Descriptors is set for the +-- containing subprogram). In addition Delay_Subprogram_Descriptors is +-- set for a library level package declaration or body which contains +-- delayed instantiations (in this case the descriptor refers to the +-- enclosing elaboration procedure). + +-- Delta_Value (Ureal18) +-- Present in fixed and decimal types. Points to a universal real +-- that holds value of delta for the type, as given in the declaration +-- or as inherited by a subtype or derived type. + +-- Dependent_Instances (Elist8) +-- Present in packages that are instances. Holds list of instances +-- of inner generics. Used to place freeze nodes for those instances +-- after that of the current one, i.e. after the corresponding generic +-- bodies. + +-- Depends_On_Private (Flag14) +-- Present in all type entities. Set if the type is private or if it +-- depends on a private type. + +-- Designated_Type (synthesized) +-- Applies to access types. Returns the designated type. Differs +-- from Directly_Designated_Type in that if the access type refers +-- to an incomplete type, and the full type is available, then this +-- full type is returned instead of the incomplete type. + +-- Digits_Value (Uint17) +-- Present in floating point types and subtypes and decimal types and +-- subtypes. Contains the Digits value specified in the declaration. + +-- Direct_Primitive_Operations (Elist10) +-- Present in tagged types and subtypes (including synchronized types), +-- in tagged private types and in tagged incomplete types. Element list +-- of entities for primitive operations of the tagged type. Not present +-- in untagged types. In order to follow the C++ ABI, entities of +-- primitives that come from source must be stored in this list in the +-- order of their occurrence in the sources. For incomplete types the +-- list is always empty. + +-- Directly_Designated_Type (Node20) +-- Present in access types. This field points to the type that is +-- directly designated by the access type. In the case of an access +-- type to an incomplete type, this field references the incomplete +-- type. Note that in the semantic processing, what is useful in +-- nearly all cases is the full type designated by the access type. +-- The function Designated_Type obtains this full type in the case of +-- access to an incomplete type. + +-- Discard_Names (Flag88) +-- Present in types and exception entities. Set if pragma Discard_Names +-- applies to the entity. It is also set for declarative regions and +-- package specs for which a Discard_Names pragma with zero arguments +-- has been encountered. The purpose of setting this flag is to be able +-- to set the Discard_Names attribute on enumeration types declared +-- after the pragma within the same declarative region. This flag is +-- set to False if a Keep_Names pragma appears for an enumeration type. + +-- Discriminal (Node17) +-- Present in discriminants (Discriminant formal: GNAT's first +-- coinage). The entity used as a formal parameter that corresponds +-- to a discriminant. See section "Handling of Discriminants" for +-- full details of the use of discriminals. + +-- Discriminal_Link (Node10) +-- Present in discriminals (which have an Ekind of E_In_Parameter, +-- or E_Constant), points back to corresponding discriminant. + +-- Discriminant_Checking_Func (Node20) +-- Present in components. Points to the defining identifier of the +-- function built by the expander returns a Boolean indicating whether +-- the given record component exists for the current discriminant +-- values. + +-- Discriminant_Constraint (Elist21) +-- Present in entities whose Has_Discriminants flag is set (concurrent +-- types, subtypes, record types and subtypes, private types and +-- subtypes, limited private types and subtypes and incomplete types). +-- It is an error to reference the Discriminant_Constraint field if +-- Has_Discriminants is False. +-- +-- If the Is_Constrained flag is set, Discriminant_Constraint points +-- to an element list containing the discriminant constraints in the +-- same order in which the discriminants are declared. +-- +-- If the Is_Constrained flag is not set but the discriminants of the +-- unconstrained type have default initial values then this field +-- points to an element list giving these default initial values in +-- the same order in which the discriminants are declared. Note that +-- in this case the entity cannot be a tagged record type, because +-- discriminants in this case cannot have defaults. +-- +-- If the entity is a tagged record implicit type, then this field is +-- inherited from the first subtype (so that the itype is subtype +-- conformant with its first subtype, which is needed when the first +-- subtype overrides primitive operations inherited by the implicit +-- base type). +-- +-- In all other cases Discriminant_Constraint contains the empty +-- Elist (ie it is initialized with a call to New_Elmt_List). + +-- Discriminant_Default_Value (Node20) +-- Present in discriminants. Points to the node representing the +-- expression for the default value of the discriminant. Set to +-- Empty if the discriminant has no default value. + +-- Discriminant_Number (Uint15) +-- Present in discriminants. Gives the ranking of a discriminant in +-- the list of discriminants of the type, i.e. a sequential integer +-- index starting at 1 and ranging up to number of discriminants. + +-- Dispatch_Table_Wrappers (Elist26) [implementation base type only] +-- Present in record type [with private] entities. Set in library level +-- record type entities if we are generating statically allocated +-- dispatch tables. For a tagged type, points to the list of dispatch +-- table wrappers associated with the tagged type. For a non-tagged +-- record, contains No_Elist. + +-- DTC_Entity (Node16) +-- Present in function and procedure entities. Set to Empty unless +-- the subprogram is dispatching in which case it references the +-- Dispatch Table pointer Component. That is to say the component _tag +-- for regular Ada tagged types, for CPP_Class types and their +-- descendants this field points to the component entity in the record +-- that is the Vtable pointer for the Vtable containing the entry that +-- references the subprogram. + +-- DT_Entry_Count (Uint15) +-- Present in E_Component entities. Only used for component marked +-- Is_Tag. Store the number of entries in the Vtable (or Dispatch Table) + +-- DT_Offset_To_Top_Func (Node25) +-- Present in E_Component entities. Only used for component marked +-- Is_Tag. If present it stores the Offset_To_Top function used to +-- provide this value in tagged types whose ancestor has discriminants. + +-- DT_Position (Uint15) +-- Present in function and procedure entities which are dispatching +-- (should not be referenced without first checking that flag +-- Is_Dispatching_Operation is True). Contains the offset into +-- the Vtable for the entry that references the subprogram. + +-- Ekind (Ekind) +-- Present in all entities. Contains a value of the enumeration type +-- Entity_Kind declared in a subsequent section in this spec. + +-- Elaborate_Body_Desirable (Flag210) +-- Present in package entities. Set if the elaboration circuitry detects +-- a case where there is a package body that modifies one or more visible +-- entities in the package spec and there is no explicit Elaborate_Body +-- pragma for the package. This information is passed on to the binder, +-- which attempts, but does not promise, to elaborate the body as close +-- to the spec as possible. + +-- Elaboration_Entity (Node13) +-- Present in generic and non-generic package and subprogram +-- entities. This is a boolean entity associated with the unit that +-- is initially set to False, and is set True when the unit is +-- elaborated. This is used for two purposes. First, it is used to +-- implement required access before elaboration checks (the flag +-- must be true to call a subprogram at elaboration time). Second, +-- it is used to guard against repeated execution of the generated +-- elaboration code. +-- +-- Note that we always allocate this flag, and set this field, but +-- we do not always actually use it. It is only used if it is needed +-- for access-before-elaboration use (see Elaboration_Entity_Required +-- flag) or if either the spec or the body has elaboration code. If +-- neither of these two conditions holds, then the entity is still +-- allocated (since we don't know early enough whether or not there +-- is elaboration code), but is simply not used for any purpose. + +-- Elaboration_Entity_Required (Flag174) +-- Present in generics and non-generic package and subprogram +-- entities. Set only if Elaboration_Entity is non-Empty to indicate +-- that the boolean is required to be set even if there is no other +-- elaboration code. This occurs when the Elaboration_Entity flag +-- is used for required access-before-elaboration checking. If the +-- flag is only for preventing multiple execution of the elaboration +-- code, then if there is no other elaboration code, obviously there +-- is no need to set the flag. + +-- Enclosing_Scope (Node18) +-- Present in labels. Denotes the innermost enclosing construct that +-- contains the label. Identical to the scope of the label, except for +-- labels declared in the body of an accept statement, in which case the +-- entry_name is the Enclosing_Scope. Used to validate goto's within +-- accept statements. + +-- Entry_Accepted (Flag152) +-- Present in E_Entry and E_Entry_Family entities. Set if there is +-- at least one accept for this entry in the task body. Used to +-- generate warnings for missing accepts. + +-- Entry_Bodies_Array (Node15) +-- Present in protected types for which Has_Entries is true. +-- This is the defining identifier for the array of entry body +-- action procedures and barrier functions used by the runtime to +-- execute the user code associated with each entry. + +-- Entry_Cancel_Parameter (Node23) +-- Present in blocks. This only applies to a block statement for +-- which the Is_Asynchronous_Call_Block flag is set. It +-- contains the defining identifier of an object that must be +-- passed to the Cancel_Task_Entry_Call or Cancel_Protected_Entry_Call +-- call in the cleanup handler added to the block by +-- Exp_Ch7.Expand_Cleanup_Actions. This parameter is a Boolean +-- object for task entry calls and a Communications_Block object +-- in the case of protected entry calls. In both cases the objects +-- are declared in outer scopes to this block. + +-- Entry_Component (Node11) +-- Present in formal parameters (in, in out and out parameters). Used +-- only for formals of entries. References the corresponding component +-- of the entry parameter record for the entry. + +-- Entry_Formal (Node16) +-- Present in components of the record built to correspond to entry +-- parameters. This field points from the component to the formal. It +-- is the back pointer corresponding to Entry_Component. + +-- Entry_Index_Constant (Node18) +-- Present in an entry index parameter. This is an identifier that +-- eventually becomes the name of a constant representing the index +-- of the entry family member whose entry body is being executed. Used +-- to expand references to the entry index specification identifier. + +-- Entry_Index_Type (synthesized) +-- Applies to an entry family. Denotes Etype of the subtype indication +-- in the entry declaration. Used to resolve the index expression in an +-- accept statement for a member of the family, and in the prefix of +-- 'COUNT when it applies to a family member. + +-- Entry_Parameters_Type (Node15) +-- Present in entries. Points to the access-to-record type that is +-- constructed by the expander to hold a reference to the parameter +-- values. This reference is manipulated (as an address) by the +-- tasking runtime. The designated record represents a packaging +-- up of the entry parameters (see Exp_Ch9.Expand_N_Entry_Declaration +-- for further details). Entry_Parameters_Type is Empty if the entry +-- has no parameters. + +-- Enumeration_Pos (Uint11) +-- Present in enumeration literals. Contains the position number +-- corresponding to the value of the enumeration literal. + +-- Enumeration_Rep (Uint12) +-- Present in enumeration literals. Contains the representation that +-- corresponds to the value of the enumeration literal. Note that +-- this is normally the same as Enumeration_Pos except in the presence +-- of representation clauses, where Pos will still represent the +-- position of the literal within the type and Rep will have be the +-- value given in the representation clause. + +-- Enumeration_Rep_Expr (Node22) +-- Present in enumeration literals. Points to the expression in an +-- associated enumeration rep clause that provides the representation +-- value for this literal. Empty if no enumeration rep clause for this +-- literal (or if rep clause does not have an entry for this literal, +-- an error situation). This is also used to catch duplicate entries +-- for the same literal. + +-- Enum_Pos_To_Rep (Node23) +-- Present in enumeration types (but not enumeration subtypes). Set to +-- Empty unless the enumeration type has a non-standard representation +-- (i.e. at least one literal has a representation value different from +-- its pos value). In this case, Enum_Pos_To_Rep is the entity for an +-- array constructed when the type is frozen that maps Pos values to +-- corresponding Rep values. The index type of this array is Natural, +-- and the component type is a suitable integer type that holds the +-- full range of representation values. + +-- Equivalent_Type (Node18) +-- Present in class wide types and subtypes, access to protected +-- subprogram types, and in exception types. For a classwide type, it +-- is always Empty. For a class wide subtype, it points to an entity +-- created by the expander which gives Gigi an easily understandable +-- equivalent of the class subtype with a known size (given by an +-- initial value). See Exp_Util.Expand_Class_Wide_Subtype for further +-- details. For E_Exception_Type, this points to the record containing +-- the data necessary to represent exceptions (for further details, see +-- System.Standard_Library. For access_to_protected subprograms, it +-- denotes a record that holds pointers to the operation and to the +-- protected object. For remote Access_To_Subprogram types, it denotes +-- the record that is the fat pointer representation of an RAST. + +-- Esize (Uint12) +-- Present in all types and subtypes, and also for components, constants, +-- and variables, including exceptions where it refers to the static data +-- allocated for an exception. Contains the Object_Size of the type or of +-- the object. A value of zero indicates that the value is not yet known. +-- +-- For the case of components where a component clause is present, the +-- value is the value from the component clause, which must be non- +-- negative (but may be zero, which is acceptable for the case of +-- a type with only one possible value). It is also possible for Esize +-- of a component to be set without a component clause present, which +-- means that the component size is specified, but not the position. +-- See also RM_Size and the section on "Handling of Type'Size Values". +-- During gigi processing, the value is back annotated for all zero +-- values, so that after the call to gigi, the value is properly set. + +-- Etype (Node5) +-- Present in all entities. Represents the type of the entity, which +-- is itself another entity. For a type entity, points to the parent +-- type for a derived type, or if the type is not derived, points to +-- itself. For a subtype entity, Etype points to the base type. For +-- a class wide type, points to the parent type. For a subprogram or +-- subprogram type, Etype has the return type of a function or is set +-- to Standard_Void_Type to represent a procedure. +-- +-- Note one obscure case: for pragma Default_Storage_Pool (null), the +-- Etype of the N_Null node is Empty. + +-- Exception_Code (Uint22) +-- Present in exception entities. Set to zero unless either an +-- Import_Exception or Export_Exception pragma applies to the +-- pragma and specifies a Code value. See description of these +-- pragmas for details. Note that this field is relevant only if +-- Is_VMS_Exception is set. + +-- Extra_Formal (Node15) +-- Present in formal parameters in the non-generic case. Certain +-- parameters require extra implicit information to be passed (e.g. the +-- flag indicating if an unconstrained variant record argument is +-- constrained, and the accessibility level for access parameters. See +-- description of Extra_Constrained, Extra_Accessibility fields for +-- further details. Extra formal parameters are constructed to represent +-- these values, and chained to the end of the list of formals using the +-- Extra_Formal field (i.e. the Extra_Formal field of the last "real" +-- formal points to the first extra formal, and the Extra_Formal field of +-- each extra formal points to the next one, with Empty indicating the +-- end of the list of extra formals. + +-- Extra_Formals (Node28) +-- Applies to subprograms and subprogram types, and also in entries +-- and entry families. Returns first extra formal of the subprogram +-- or entry. Returns Empty if there are no extra formals. + +-- Extra_Accessibility (Node13) +-- Present in formal parameters in the non-generic case if expansion is +-- active. Normally Empty, but if a parameter is one for which a dynamic +-- accessibility check is required, then an extra formal of type +-- Natural is created (see description of field Extra_Formal), and the +-- Extra_Accessibility field of the formal parameter points to the entity +-- for this extra formal. Also present in variables when compiling +-- receiving stubs. In this case, a non Empty value means that this +-- variable's accessibility depth has been transmitted by the caller and +-- must be retrieved through the entity designed by this field instead of +-- being computed. + +-- Extra_Constrained (Node23) +-- Present in formal parameters in the non-generic case if expansion is +-- active. Normally Empty, but if a parameter is one for which a dynamic +-- indication of its constrained status is required, then an extra formal +-- of type Boolean is created (see description of field Extra_Formal), +-- and the Extra_Constrained field of the formal parameter points to the +-- entity for this extra formal. Also present in variables when compiling +-- receiving stubs. In this case, a non empty value means that this +-- variable's constrained status has been transmitted by the caller and +-- must be retrieved through the entity designed by this field instead of +-- being computed. + +-- Can_Use_Internal_Rep (Flag229) [base type only] +-- Present in Access_Subprogram_Kind nodes. This flag is set by the +-- front end and used by the back end. False means that the back end +-- must represent the type in the same way as Convention-C types (and +-- other foreign-convention types). On many targets, this means that +-- the back end will use dynamically generated trampolines for nested +-- subprograms. True means that the back end can represent the type in +-- some internal way. On the aforementioned targets, this means that the +-- back end will not use dynamically generated trampolines. This flag +-- must be False if Has_Foreign_Convention is True; otherwise, the front +-- end is free to set the policy. +-- +-- Setting this False in all cases corresponds to the traditional back +-- end strategy, where all access-to-subprogram types are represented the +-- same way, independent of the Convention. See also +-- Always_Compatible_Rep in Targparm. +-- +-- Efficiency note: On targets that use dynamically generated +-- trampolines, False generally favors efficiency of top-level +-- subprograms, whereas True generally favors efficiency of nested +-- ones. On other targets, this flag has little or no effect on +-- efficiency. The front end should take this into account. In +-- particular, pragma Favor_Top_Level gives a hint that the flag should +-- be False. +-- +-- Note: We considered using Convention-C for this purpose, but we need +-- this separate flag, because Convention-C implies that for +-- P'[Unrestricted_]Access, P also have convention C. Sometimes we want +-- to have Can_Use_Internal_Rep False for an access type, but allow P to +-- have convention Ada. + +-- Finalization_Chain_Entity (Node19) +-- Present in scopes that can have finalizable entities (blocks, +-- functions, procedures, tasks, entries, return statements). When this +-- field is empty it means that there are no finalization actions to +-- perform on exit of the scope. When this field contains 'Error', it +-- means that no finalization actions should happen at this level and +-- the finalization chain of a parent scope shall be used (??? this is +-- an improper use of 'Error' and should be changed). Otherwise it +-- contains an entity of type Finalizable_Ptr that is the head of the +-- list of objects to finalize on exit. See "Finalization Management" +-- section in exp_ch7.adb for more details. + +-- Finalize_Storage_Only (Flag158) [base type only] +-- Present in all types. Set on direct controlled types to which a +-- valid Finalize_Storage_Only pragma applies. This flag is also set on +-- composite types when they have at least one controlled component and +-- all their controlled components are Finalize_Storage_Only. It is also +-- inherited by type derivation except for direct controlled types where +-- the Finalize_Storage_Only pragma is required at each level of +-- derivation. + +-- First_Component (synthesized) +-- Applies to record types. Returns the first component by following the +-- chain of declared entities for the record until a component is found +-- (one with an Ekind of E_Component). The discriminants are skipped. If +-- the record is null, then Empty is returned. + +-- First_Component_Or_Discriminant (synthesized) +-- Similar to First_Component, but discriminants are not skipped, so will +-- find the first discriminant if discriminants are present. + +-- First_Entity (Node17) +-- Present in all entities which act as scopes to which a list of +-- associated entities is attached (blocks, class subtypes and types, +-- entries, functions, loops, packages, procedures, protected objects, +-- record types and subtypes, private types, task types and subtypes). +-- Points to a list of associated entities using the Next_Entity field +-- as a chain pointer with Empty marking the end of the list. + +-- First_Exit_Statement (Node8) +-- Present in E_Loop entity. The exit statements for a loop are chained +-- (in reverse order of appearance) using this field to point to the +-- first entry in the chain (last exit statement in the loop). The +-- entries are chained through the Next_Exit_Statement field of the +-- N_Exit_Statement node with Empty marking the end of the list. + +-- First_Formal (synthesized) +-- Applies to subprograms and subprogram types, and also in entries +-- and entry families. Returns first formal of the subprogram or entry. +-- The formals are the first entities declared in a subprogram or in +-- a subprogram type (the designated type of an Access_To_Subprogram +-- definition) or in an entry. + +-- First_Formal_With_Extras (synthesized) +-- Applies to subprograms and subprogram types, and also in entries +-- and entry families. Returns first formal of the subprogram or entry. +-- Returns Empty if there are no formals. The list returned includes +-- all the extra formals (see description of Extra_Formals field). + +-- First_Index (Node17) +-- Present in array types and subtypes and in string types and subtypes. +-- By introducing implicit subtypes for the index constraints, we have +-- the same structure for constrained and unconstrained arrays, subtype +-- marks and discrete ranges are both represented by a subtype. This +-- function returns the tree node corresponding to an occurrence of the +-- first index (NOT the entity for the type). Subsequent indexes are +-- obtained using Next_Index. Note that this field is present for the +-- case of string literal subtypes, but is always Empty. + +-- First_Literal (Node17) +-- Present in all enumeration types, including character and boolean +-- types. This field points to the first enumeration literal entity +-- for the type (i.e. it is set to First (Literals (N)) where N is +-- the enumeration type definition node. A special case occurs with +-- standard character and wide character types, where this field is +-- Empty, since there are no enumeration literal lists in these cases. +-- Note that this field is set in enumeration subtypes, but it still +-- points to the first literal of the base type in this case. + +-- First_Optional_Parameter (Node14) +-- Present in (non-generic) function and procedure entities. Set to a +-- non-null value only if a pragma Import_Function, Import_Procedure +-- or Import_Valued_Procedure specifies a First_Optional_Parameter +-- argument, in which case this field points to the parameter entity +-- corresponding to the specified parameter. + +-- First_Private_Entity (Node16) +-- Present in all entities containing private parts (packages, protected +-- types and subtypes, task types and subtypes). The entities on the +-- entity chain are in order of declaration, so the entries for private +-- entities are at the end of the chain. This field points to the first +-- entity for the private part. It is Empty if there are no entities +-- declared in the private part or if there is no private part. + +-- First_Rep_Item (Node6) +-- Present in all entities. If non-empty, points to a linked list of +-- representation pragmas nodes and representation clause nodes that +-- apply to the entity, linked using Next_Rep_Item, with Empty marking +-- the end of the list. In the case of derived types and subtypes, the +-- new entity inherits the chain at the point of declaration. This +-- means that it is possible to have multiple instances of the same +-- kind of rep item on the chain, in which case it is the first one +-- that applies to the entity. +-- +-- Note: pragmas that can apply to more than one overloadable entity, +-- (Convention, Interface, Inline, Inline_Always, Import, Export, +-- External) are never present on this chain when they apply to +-- overloadable entities, since it is impossible for a given pragma +-- to be on more than one chain at a time. +-- +-- For most representation items, the representation information is +-- reflected in other fields and flags in the entity. For example if a +-- record representation clause is present, the component entities +-- reflect the specified information. However, there are some items that +-- are only reflected in the chain. These include: +-- +-- Alignment attribute definition clause +-- Machine_Attribute pragma +-- Link_Alias pragma +-- Linker_Section pragma +-- Weak_External pragma +-- +-- If any of these items are present, then the flag Has_Gigi_Rep_Item +-- is set, indicating that Gigi should search the chain. +-- +-- Other representation items are included in the chain so that error +-- messages can easily locate the relevant nodes for posting errors. +-- Note in particular that size clauses are present only for this +-- purpose, and should only be accessed if Has_Size_Clause is set. + +-- Float_Rep (Uint10) +-- Present in floating-point entities. Contains a value of type +-- Float_Rep_Kind. Together with the Digits_Value uniquely defines +-- the floating-point representation to be used. + +-- Freeze_Node (Node7) +-- Present in all entities. If there is an associated freeze node for +-- the entity, this field references this freeze node. If no freeze +-- node is associated with the entity, then this field is Empty. See +-- package Freeze for further details. + +-- From_With_Type (Flag159) +-- Present in package and type entities. Indicates that the entity +-- appears in a With_Type clause in the context of some other unit, +-- either as the prefix (which must be a package), or as a type name. +-- The package can only be used to retrieve such a type, and the type +-- can be used only in component declarations and access definitions. +-- The With_Type clause is used to construct mutually recursive +-- types, i.e. record types (Java classes) that hold pointers to each +-- other. If such a type is an access type, it has no explicit freeze +-- node, so that the back-end does not attempt to elaborate it. +-- Currently this flag is also used to implement Ada 2005 (AI-50217). +-- It will be renamed to From_Limited_With after removal of the current +-- GNAT with_type clause??? + +-- Full_View (Node11) +-- Present in all type and subtype entities and in deferred constants. +-- References the entity for the corresponding full type declaration. +-- For all types other than private and incomplete types, this field +-- always contains Empty. If an incomplete type E1 is completed by a +-- private type E2 whose full type declaration entity is E3 then the +-- full view of E1 is E2, and the full view of E2 is E3. See also +-- Underlying_Type. + +-- Generic_Homonym (Node11) +-- Present in generic packages. The generic homonym is the entity of +-- a renaming declaration inserted in every generic unit. It is used +-- to resolve the name of a local entity that is given by a qualified +-- name, when the generic entity itself is hidden by a local name. + +-- Generic_Renamings (Elist23) +-- Present in package and subprogram instances. Holds mapping that +-- associates generic parameters with the corresponding instances, in +-- those cases where the instance is an entity. + +-- Handler_Records (List10) +-- Present in subprogram and package entities. Points to a list of +-- identifiers referencing the handler record entities for the +-- corresponding unit. + +-- Has_Aliased_Components (Flag135) [implementation base type only] +-- Present in array type entities. Indicates that the component type +-- of the array is aliased. + +-- Has_Alignment_Clause (Flag46) +-- Present in all type entities and objects. Indicates if an alignment +-- clause has been given for the entity. If set, then Alignment_Clause +-- returns the N_Attribute_Definition node for the alignment attribute +-- definition clause. Note that it is possible for this flag to be False +-- even when Alignment_Clause returns non_Empty (this happens in the case +-- of derived type declarations). + +-- Has_All_Calls_Remote (Flag79) +-- Present in all library unit entities. Set true if the library unit +-- has an All_Calls_Remote pragma. Note that such entities must also +-- be RCI entities, so the flag Is_Remote_Call_Interface will always +-- be set if this flag is set. + +-- Has_Anon_Block_Suffix (Flag201) +-- Present in all entities. Set if the entity is nested within one or +-- more anonymous blocks and the Chars field contains a name with an +-- anonymous block suffix (see Exp_Dbug for further details). + +-- Has_Atomic_Components (Flag86) [implementation base type only] +-- Present in all types and objects. Set only for an array type or +-- an array object if a valid pragma Atomic_Components applies to the +-- type or object. Note that in the case of an object, this flag is +-- only set on the object if there was an explicit pragma for the +-- object. In other words, the proper test for whether an object has +-- atomic components is to see if either the object or its base type +-- has this flag set. Note that in the case of a type, the pragma will +-- be chained to the rep item chain of the first subtype in the usual +-- manner. + +-- Has_Attach_Handler (synthesized) +-- Applies to record types that are constructed by the expander to +-- represent protected types. Returns True if there is at least one +-- Attach_Handler pragma in the corresponding specification. + +-- Has_Biased_Representation (Flag139) +-- Present in discrete types (where it applies to the type'size value), +-- and to objects (both stand-alone and components), where it applies to +-- the size of the object from a size or record component clause. In +-- all cases it indicates that the size in question is smaller than +-- would normally be required, but that the size requirement can be +-- satisfied by using a biased representation, in which stored values +-- have the low bound (Expr_Value (Type_Low_Bound (T)) subtracted to +-- reduce the required size. For example, a type with a range of 1..2 +-- takes one bit, using 0 to represent 1 and 1 to represent 2. +-- +-- Note that in the object and component cases, the flag is only set if +-- the type is unbiased, but the object specifies a smaller size than the +-- size of the type, forcing biased representation for the object, but +-- the subtype is still an unbiased type. + +-- Has_Completion (Flag26) +-- Present in all entities that require a completion (functions, +-- procedures, private types, limited private types, incomplete types, +-- constants and packages that require a body). The flag is set if the +-- completion has been encountered and analyzed. + +-- Has_Completion_In_Body (Flag71) +-- Present in all entities for types and subtypes. Set only in "Taft +-- amendment types" (incomplete types whose full declaration appears in +-- the package body). + +-- Has_Complex_Representation (Flag140) [implementation base type only] +-- Present in all type entities. Set only for a record base type to +-- which a valid pragma Complex_Representation applies. + +-- Has_Component_Size_Clause (Flag68) [implementation base type only] +-- Present in all type entities. Set if a component size clause is +-- present for the given type. Note that this flag can be False even +-- if Component_Size is non-zero (happens in the case of derived types). + +-- Has_Constrained_Partial_View (Flag187) +-- Present in private type and their completions, when the private +-- type has no discriminants and the full view has discriminants with +-- defaults. In Ada 2005 heap-allocated objects of such types are not +-- constrained, and can change their discriminants with full assignment. + +-- Has_Contiguous_Rep (Flag181) +-- Present in enumeration types. True if the type as a representation +-- clause whose entries are successive integers. + +-- Has_Controlling_Result (Flag98) +-- Present in E_Function entities. True if the function is a primitive +-- function of a tagged type which can dispatch on result. + +-- Has_Controlled_Component (Flag43) [base type only] +-- Present in all entities. Set only for composite type entities which +-- contain a component that either is a controlled type, or itself +-- contains controlled component (i.e. either Has_Controlled_Component +-- or Is_Controlled is set for at least one component). + +-- Has_Convention_Pragma (Flag119) +-- Present in all entities. Set true for an entity for which a valid +-- Convention, Import, or Export pragma has been given. Used to prevent +-- more than one such pragma appearing for a given entity (RM B.1(45)). + +-- Has_Delayed_Aspects (Flag200) Present in all entities. Set true if the +-- Rep_Item chain for the entity has one or more N_Aspect_Definition +-- nodes chained which are not to be evaluated till the freeze point. +-- The aspect definition expression clause has been preanalyzed to get +-- visibility at the point of use, but no other action has been taken. + +-- Has_Delayed_Freeze (Flag18) +-- Present in all entities. Set to indicate that an explicit freeze +-- node must be generated for the entity at its freezing point. See +-- separate section ("Delayed Freezing and Elaboration") for details. + +-- Has_Discriminants (Flag5) +-- Present in all types and subtypes. For types that are allowed to have +-- discriminants (record types and subtypes, task types and subtypes, +-- protected types and subtypes, private types, limited private types, +-- and incomplete types), indicates if the corresponding type or subtype +-- has a known discriminant part. Always false for all other types. + +-- Has_Dispatch_Table (Flag220) +-- Present in E_Record_Types that are tagged. Set to indicate that the +-- corresponding dispatch table is already built. This flag is used to +-- avoid duplicate construction of library level dispatch tables (because +-- the declaration of library level objects cause premature construction +-- of the table); otherwise the code that builds the table is added at +-- the end of the list of declarations of the package. + +-- Has_Entries (synthesized) +-- Applies to concurrent types. True if any entries are declared +-- within the task or protected definition for the type. + +-- Has_Enumeration_Rep_Clause (Flag66) +-- Present in enumeration types. Set if an enumeration representation +-- clause has been given for this enumeration type. Used to prevent more +-- than one enumeration representation clause for a given type. Note +-- that this does not imply a representation with holes, since the rep +-- clause may merely confirm the default 0..N representation. + +-- Has_External_Tag_Rep_Clause (Flag110) +-- Present in tagged types. Set if an external_tag rep. clause has been +-- given for this type. Use to avoid the generation of the default +-- external_tag. + +-- Has_Exit (Flag47) +-- Present in loop entities. Set if the loop contains an exit statement. + +-- Has_Foreign_Convention (synthesized) +-- Applies to all entities. Determines if the Convention for the +-- entity is a foreign convention (i.e. is other than Convention_Ada, +-- Convention_Intrinsic, Convention_Entry or Convention_Protected). + +-- Has_Forward_Instantiation (Flag175) +-- Present in package entities. Set true for packages that contain +-- instantiations of local generic entities, before the corresponding +-- generic body has been seen. If a package has a forward instantiation, +-- we cannot inline subprograms appearing in the same package because +-- the placement requirements of the instance will conflict with the +-- linear elaboration of front-end inlining. + +-- Has_Fully_Qualified_Name (Flag173) +-- Present in all entities. Set True if the name in the Chars field has +-- been replaced by the fully qualified name, as used for debug output. +-- See Exp_Dbug for a full description of the use of this flag and also +-- the related flag Has_Qualified_Name. + +-- Has_Gigi_Rep_Item (Flag82) +-- Present in all entities. Set if the rep item chain (referenced by +-- First_Rep_Item and linked through the Next_Rep_Item chain) contains a +-- representation item that needs to be specially processed by Gigi, i.e. +-- one of the following items: +-- +-- Machine_Attribute pragma +-- Linker_Alias pragma +-- Linker_Section pragma +-- Linker_Constructor pragma +-- Linker_Destructor pragma +-- Weak_External pragma +-- +-- If this flag is set, then Gigi should scan the rep item chain to +-- process any of these items that appear. At least one such item will +-- be present. + +-- Has_Homonym (Flag56) +-- Present in all entities. Set if an entity has a homonym in the same +-- scope. Used by Gigi to generate unique names for such entities. +-- +-- Has_Initial_Value (Flag219) +-- Present in entities for variables and out parameters. Set if there +-- is an explicit initial value expression in the declaration of the +-- variable. Note that this is set only if this initial value is +-- explicit, it is not set for the case of implicit initialization +-- of access types or controlled types. Always set to False for out +-- parameters. Also present in entities for in and in-out parameters, +-- but always false in these cases. +-- +-- Has_Interrupt_Handler (synthesized) +-- Applies to all protected type entities. Set if the protected type +-- definition contains at least one procedure to which a pragma +-- Interrupt_Handler applies. + +-- Has_Invariants (Flag232) +-- Present in all type entities and in subprogram entities. Set True in +-- private types if an Invariant or Invariant'Class aspect applies to the +-- type, or if the type inherits one or more Invariant'Class aspects. +-- Also set in the corresponding full type. Note: if this flag is set +-- True, then usually the Invariant_Procedure attribute is set once the +-- type is frozen, however this may not be true in some error situations. +-- Note that it might be the full type which has inheritable invariants, +-- and then the flag will also be set in the private type. Also set in +-- the invariant procedure entity, to distinguish it among entries in the +-- Subprograms_For_Type. + +-- Has_Inheritable_Invariants (Flag248) +-- Present in all type entities. Set True in private types from which one +-- or more Invariant'Class aspects will be inherited if a another type is +-- derived from the type (i.e. those types which have an Invariant'Class +-- aspect, or which inherit one or more Invariant'Class aspects). Also +-- set in the corresponding full types. Note that it might be the full +-- type which has inheritable invariants, and in this case the flag will +-- also be set in the private type. + +-- Has_Machine_Radix_Clause (Flag83) +-- Present in decimal types and subtypes, set if a Machine_Radix +-- representation clause is present. This flag is used to detect +-- the error of multiple machine radix clauses for a single type. + +-- Has_Master_Entity (Flag21) +-- Present in entities that can appear in the scope stack (see spec +-- of Sem). It is set if a task master entity (_master) has been +-- declared and initialized in the corresponding scope. + +-- Has_Missing_Return (Flag142) +-- Present in functions and generic functions. Set if there is one or +-- more missing return statements in the function. This is used to +-- control wrapping of the body in Exp_Ch6 to ensure that the program +-- error exception is correctly raised in this case at runtime. + +-- Has_Up_Level_Access (Flag215) +-- Present in E_Variable and E_Constant entities. Set if the entity +-- is a local variable declared in a subprogram p and is accessed in +-- a subprogram nested inside p. Currently this flag is only set when +-- VM_Target /= No_VM, for efficiency, since only the .NET back-end +-- makes use of it to generate proper code for up-level references. + +-- Has_Nested_Block_With_Handler (Flag101) +-- Present in scope entities. Set if there is a nested block within the +-- scope that has an exception handler and the two scopes are in the +-- same procedure. This is used by the backend for controlling certain +-- optimizations to ensure that they are consistent with exceptions. +-- See documentation in Gigi for further details. + +-- Has_Non_Standard_Rep (Flag75) [implementation base type only] +-- Present in all type entities. Set when some representation clause +-- or pragma causes the representation of the item to be significantly +-- modified. In this category are changes of small or radix for a +-- fixed-point type, change of component size for an array, and record +-- or enumeration representation clauses, as well as packed pragmas. +-- All other representation clauses (e.g. Size and Alignment clauses) +-- are not considered to be significant since they do not affect +-- stored bit patterns. + +-- Has_Object_Size_Clause (Flag172) +-- Present in entities for types and subtypes. Set if an Object_Size +-- clause has been processed for the type Used to prevent multiple +-- Object_Size clauses for a given entity. + +-- Has_Per_Object_Constraint (Flag154) +-- Present in E_Component entities, true if the subtype of the +-- component has a per object constraint. Per object constraints result +-- from the following situations: +-- +-- 1. N_Attribute_Reference - when the prefix is the enclosing type and +-- the attribute is Access. +-- 2. N_Discriminant_Association - when the expression uses the +-- discriminant of the enclosing type. +-- 3. N_Index_Or_Discriminant_Constraint - when at least one of the +-- individual constraints is a per object constraint. +-- 4. N_Range - when the lower or upper bound uses the discriminant of +-- the enclosing type. +-- 5. N_Range_Constraint - when the range expression uses the +-- discriminant of the enclosing type. + +-- Has_Persistent_BSS (Flag188) +-- Present in all entities. Set True for entities to which a valid +-- pragma Persistent_BSS applies. Note that although the pragma is +-- only meaningful for objects, we set it for all entities in a unit +-- to which the pragma applies, as well as the unit entity itself, for +-- convenience in propagating the flag to contained entities. + +-- Has_Postconditions (Flag240) +-- Present in subprogram entities. Set if postconditions are active for +-- the procedure, and a _postconditions procedure has been generated. + +-- Has_Pragma_Controlled (Flag27) [implementation base type only] +-- Present in access type entities. It is set if a pragma Controlled +-- applies to the access type. + +-- Has_Pragma_Elaborate_Body (Flag150) +-- Present in all entities. Set in compilation unit entities if a +-- pragma Elaborate_Body applies to the compilation unit. + +-- Has_Pragma_Inline (Flag157) +-- Present in all entities. Set for functions and procedures for which a +-- pragma Inline or Inline_Always applies to the subprogram. Note that +-- this flag can be set even if Is_Inlined is not set. This happens for +-- pragma Inline (if Inline_Active is False). In other words, the flag +-- Has_Pragma_Inline represents the formal semantic status, and is used +-- for checking semantic correctness. The flag Is_Inlined indicates +-- whether inlining is actually active for the entity. + +-- Has_Pragma_Inline_Always (Flag230) +-- Present in all entities. Set for functions and procedures for which a +-- pragma Inline_Always applies. Note that if this flag is set, the flag +-- Has_Pragma_Inline is also set. + +-- Has_Pragma_Ordered (Flag198) [implementation base type only] +-- Present in entities for enumeration types. If set indicates that a +-- valid pragma Ordered was given for the type. This flag is inherited +-- by derived enumeration types. We don't need to distinguish the derived +-- case since we allow multiple occurrences of this pragma anyway. + +-- Has_Pragma_Pack (Flag121) [implementation base type only] +-- Present in all entities. If set, indicates that a valid pragma Pack +-- was given for the type. Note that this flag is not inherited by +-- derived type. See also the Is_Packed flag. + +-- Has_Pragma_Pure (Flag203) +-- Present in all entities. If set, indicates that a valid pragma Pure +-- was given for the entity. In some cases, we need to test whether +-- Is_Pure was explicitly set using this pragma. + +-- Has_Pragma_Preelab_Init (Flag221) +-- Present in type and subtype entities. If set indicates that a valid +-- pragma Preelaborable_Initialization applies to the type. + +-- Has_Pragma_Pure_Function (Flag179) +-- Present in all entities. If set, indicates that a valid pragma +-- Pure_Function was given for the entity. In some cases, we need to +-- know that Is_Pure was explicitly set using this pragma. We also set +-- this flag for some internal entities that we know should be treated +-- as pure for optimization purposes. + +-- Has_Pragma_Thread_Local_Storage (Flag169) +-- Present in all entities. If set, indicates that a valid pragma +-- Thread_Local_Storage was given for the entity. + +-- Has_Pragma_Unmodified (Flag233) +-- Present in all entities. Can only be set for variables (E_Variable, +-- E_Out_Parameter, E_In_Out_Parameter). Set if a valid pragma Unmodified +-- applies to the variable, indicating that no warning should be given +-- if the entity is never modified. Note that clients should generally +-- not test this flag directly, but instead use function Has_Unmodified. + +-- Has_Pragma_Unreferenced (Flag180) +-- Present in all entities. Set if a valid pragma Unreferenced applies +-- to the entity, indicating that no warning should be given if the +-- entity has no references, but a warning should be given if it is +-- in fact referenced. For private types, this flag is set in both the +-- private entity and full entity if the pragma applies to either. Note +-- that clients should generally not test this flag directly, but instead +-- use function Has_Unreferenced. + +-- Has_Pragma_Unreferenced_Objects (Flag212) +-- Present in type and subtype entities. Set if a valid pragma +-- Unreferenced_Objects applies to the type, indicating that no warning +-- should be given for objects of such a type for being unreferenced +-- (but unlike the case with pragma Unreferenced, it is ok to reference +-- such an object and no warning is generated. + +-- Has_Predicates (Flag250) +-- Present in all entities. Set in type and subtype entities if a pragma +-- Predicate or Predicate aspect applies to the type, or if it inherits a +-- Predicate aspect from its parent or progenitor types. Also set in the +-- predicate function entity, to distinguish it among entries in the +-- Subprograms_For_Type. + +-- Has_Primitive_Operations (Flag120) [base type only] +-- Present in all type entities. Set if at least one primitive operation +-- is defined for the type. + +-- Has_Private_Ancestor (synthesized) +-- Applies to all type and subtype entities. Returns True if at least +-- one ancestor is private, and otherwise False if there are no private +-- ancestors. + +-- Has_Private_Declaration (Flag155) +-- Present in all entities. Returns True if it is the defining entity +-- of a private type declaration or its corresponding full declaration. +-- This flag is thus preserved when the full and the partial views are +-- exchanged, to indicate if a full type declaration is a completion. +-- Used for semantic checks in E.4(18) and elsewhere. + +-- Has_Qualified_Name (Flag161) +-- Present in all entities. Set True if the name in the Chars field +-- has been replaced by its qualified name, as used for debug output. +-- See Exp_Dbug for a full description of qualification requirements. +-- For some entities, the name is the fully qualified name, but there +-- are exceptions. In particular, for local variables in procedures, +-- we do not include the procedure itself or higher scopes. See also +-- the flag Has_Fully_Qualified_Name, which is set if the name does +-- indeed include the fully qualified name. + +-- Has_RACW (Flag214) +-- Present in package spec entities. Set if the spec contains the +-- declaration of a remote access-to-classwide type. + +-- Has_Record_Rep_Clause (Flag65) [implementation base type only] +-- Present in record types. Set if a record representation clause has +-- been given for this record type. Used to prevent more than one such +-- clause for a given record type. Note that this is initially cleared +-- for a derived type, even though the representation is inherited. See +-- also the flag Has_Specified_Layout. + +-- Has_Recursive_Call (Flag143) +-- Present in procedures. Set if a direct parameterless recursive call +-- is detected while analyzing the body. Used to activate some error +-- checks for infinite recursion. + +-- Has_Size_Clause (Flag29) +-- Present in entities for types and objects. Set if a size clause is +-- present for the entity. Used to prevent multiple Size clauses for a +-- given entity. Note that it is always initially cleared for a derived +-- type, even though the Size for such a type is inherited from a Size +-- clause given for the parent type. + +-- Has_Small_Clause (Flag67) +-- Present in ordinary fixed point types (but not subtypes). Indicates +-- that a small clause has been given for the entity. Used to prevent +-- multiple Small clauses for a given entity. Note that it is always +-- initially cleared for a derived type, even though the Small for such +-- a type is inherited from a Small clause given for the parent type. + +-- Has_Specified_Layout (Flag100) [implementation base type only] +-- Present in all type entities. Set for a record type or subtype if +-- the record layout has been specified by a record representation +-- clause. Note that this differs from the flag Has_Record_Rep_Clause +-- in that it is inherited by a derived type. Has_Record_Rep_Clause is +-- used to indicate that the type is mentioned explicitly in a record +-- representation clause, and thus is not inherited by a derived type. +-- This flag is always False for non-record types. + +-- Has_Specified_Stream_Input (Flag190) +-- Has_Specified_Stream_Output (Flag191) +-- Has_Specified_Stream_Read (Flag192) +-- Has_Specified_Stream_Write (Flag193) +-- Present in all type and subtype entities. Set for a given view if the +-- corresponding stream-oriented attribute has been defined by an +-- attribute definition clause. When such a clause occurs, a TSS is set +-- on the underlying full view; the flags are used to track visibility of +-- the attribute definition clause for partial or incomplete views. +-- +-- Has_Static_Discriminants (Flag211) +-- Present in record subtypes constrained by discriminant values. Set if +-- all the discriminant values have static values, meaning that in the +-- case of a variant record, the component list can be trimmed down to +-- include only the components corresponding to these discriminants. +-- +-- Has_Storage_Size_Clause (Flag23) [implementation base type only] +-- Present in task types and access types. It is set if a Storage_Size +-- clause is present for the type. Used to prevent multiple clauses for +-- one type. Note that this flag is initially cleared for a derived type +-- even though the Storage_Size for such a type is inherited from a +-- Storage_Size clause given for the parent type. Note that in the case +-- of access types, this flag is present only in the root type, since a +-- storage size clause cannot be given to a derived type. + +-- Has_Stream_Size_Clause (Flag184) +-- Present in all entities. It is set for types which have a Stream_Size +-- clause attribute. Used to prevent multiple Stream_Size clauses for a +-- given entity, and also whether it is necessary to check for a stream +-- size clause. + +-- Has_Subprogram_Descriptor (Flag93) +-- This flag is set on entities for which zero-cost exception subprogram +-- descriptors can be generated (subprograms and library level package +-- declarations and bodies). It indicates that a subprogram descriptor +-- has been generated, and is used to suppress generation of multiple +-- descriptors (e.g. when instantiating generic bodies). + +-- Has_Task (Flag30) [base type only] +-- Present in all type entities. Set on task types themselves, and also +-- (recursively) on any composite type which has a component for which +-- Has_Task is set. The meaning is that an allocator or declaration of +-- such an object must create the required tasks. Note: the flag is not +-- set on access types, even if they designate an object that Has_Task. + +-- Has_Thunks (Flag228) +-- Applies to E_Constant entities marked Is_Tag. True for secondary tag +-- referencing a dispatch table whose contents are pointers to thunks. + +-- Has_Unchecked_Union (Flag123) [base type only] +-- Present in all type entities. Set on unchecked unions themselves +-- and (recursively) on any composite type which has a component for +-- which Has_Unchecked_Union is set. The meaning is that a comparison +-- operation for the type is not permitted. Note that the flag is not +-- set on access types, even if they designate an object that has +-- the flag Has_Unchecked_Union set. + +-- Has_Unknown_Discriminants (Flag72) +-- Present in all entities. Set for types with unknown discriminants. +-- Types can have unknown discriminants either from their declaration or +-- through type derivation. The use of this flag exactly meets the spec +-- in RM 3.7(26). Note that all class-wide types are considered to have +-- unknown discriminants. Note that both Has_Discriminants and +-- Has_Unknown_Discriminants may be true for a type. Class-wide types and +-- their subtypes have unknown discriminants and can have declared ones +-- as well. Private types declared with unknown discriminants may have a +-- full view that has explicit discriminants, and both flag will be set +-- on the partial view, to insure that discriminants are properly +-- inherited in certain contexts. + +-- Has_Volatile_Components (Flag87) [implementation base type only] +-- Present in all types and objects. Set only for an array type or array +-- object if a valid pragma Volatile_Components or a valid pragma +-- Atomic_Components applies to the type or object. Note that in the case +-- of an object, this flag is only set on the object if there was an +-- explicit pragma for the object. In other words, the proper test for +-- whether an object has volatile components is to see if either the +-- object or its base type has this flag set. Note that in the case of a +-- type the pragma will be chained to the rep item chain of the first +-- subtype in the usual manner. + +-- Has_Xref_Entry (Flag182) +-- Present in all entities. Set if an entity has an entry in the Xref +-- information generated in ali files. This is true for all source +-- entities in the extended main source file. It is also true of entities +-- in other packages that are referenced directly or indirectly from the +-- main source file (indirect reference occurs when the main source file +-- references an entity with a type reference. See package Lib.Xref for +-- further details). + +-- Hiding_Loop_Variable (Node8) +-- Present in variables. Set only if a variable of a discrete type is +-- hidden by a loop variable in the same local scope, in which case +-- the Hiding_Loop_Variable field of the hidden variable points to +-- the E_Loop_Parameter entity doing the hiding. Used in processing +-- warning messages if the hidden variable turns out to be unused +-- or is referenced without being set. + +-- Homonym (Node4) +-- Present in all entities. Link for list of entities that have the +-- same source name and that are declared in the same or enclosing +-- scopes. Homonyms in the same scope are overloaded. Used for name +-- resolution and for the generation of debugging information. + +-- Implementation_Base_Type (synthesized) +-- Applies to all entities. For types, similar to Base_Type, but never +-- returns a private type when applied to a non-private type. Instead in +-- this case, it always returns the Underlying_Type of the base type, so +-- that we still have a concrete type. For entities other than types, +-- returns the entity unchanged. + +-- Interface_Alias (Node25) +-- Present in subprograms that cover a primitive operation of an abstract +-- interface type. Can be set only if the Is_Hidden flag is also set, +-- since such entities are always hidden. Points to its associated +-- interface subprogram. It is used to register the subprogram in +-- secondary dispatch table of the interface (Ada 2005: AI-251). + +-- Interfaces (Elist25) +-- Present in record types and subtypes. List of abstract interfaces +-- implemented by a tagged type that are not already implemented by the +-- ancestors (Ada 2005: AI-251). + +-- In_Package_Body (Flag48) +-- Present in package entities. Set on the entity that denotes the +-- package (the defining occurrence of the package declaration) while +-- analyzing and expanding the package body. Reset on completion of +-- analysis/expansion. + +-- In_Private_Part (Flag45) +-- Present in all entities. Can be set only in package entities and +-- objects. For package entities, this flag is set to indicate that the +-- private part of the package is being analyzed. The flag is reset at +-- the end of the package declaration. For objects it indicates that the +-- declaration of the object occurs in the private part of a package. + +-- Inner_Instances (Elist23) +-- Present in generic units. Contains element list of units that are +-- instantiated within the given generic. Used to diagnose circular +-- instantiations. + +-- Interface_Name (Node21) +-- Present in exceptions, functions, procedures, variables, constants, +-- and packages. Set to Empty unless an export, import, or interface +-- name pragma has explicitly specified an external name, in which +-- case it references an N_String_Literal node for the specified +-- external name. In the case of exceptions, the field is set by +-- Import_Exception/Export_Exception (which can be used in OpenVMS +-- versions only). Note that if this field is Empty, and Is_Imported +-- or Is_Exported is set, then the default interface name is the name +-- of the entity, cased in a manner that is appropriate to the system +-- in use. Note that Interface_Name is ignored if an address clause +-- is present (since it is meaningless in this case). +-- +-- An additional special case usage of this field is in JGNAT for +-- E_Component and E_Discriminant. JGNAT allows these entities to be +-- imported by specifying pragma Import within a component's containing +-- record definition. This supports interfacing to object fields defined +-- within Java classes, and such pragmas are generated by the jvm2ada +-- binding generator tool whenever it processes classes with public +-- object fields. A pragma Import for a component can define the +-- External_Name of the imported Java field (which is generally needed, +-- because Java names are case sensitive). + +-- Invariant_Procedure (synthesized) +-- Present in types and subtypes. Set for private types if one or more +-- Invariant, or Invariant'Class, or inherited Invariant'Class aspects +-- apply to the type. Points to the entity for a procedure which checks +-- the invariant. This invariant procedure takes a single argument of the +-- given type, and returns if the invariant holds, or raises exception +-- Assertion_Error with an appropriate message if it does not hold. This +-- attribute is present but always empty for private subtypes. This +-- attribute is also set for the corresponding full type. +-- +-- Note: the reason this is marked as a synthesized attribute is that the +-- way this is stored is as an element of the Subprograms_For_Type field. + +-- In_Use (Flag8) +-- Present in packages and types. Set when analyzing a use clause for +-- the corresponding entity. Reset at end of corresponding declarative +-- part. The flag on a type is also used to determine the visibility of +-- the primitive operators of the type. + +-- Is_Abstract_Subprogram (Flag19) +-- Present in all subprograms and entries. Set for abstract subprograms. +-- Always False for enumeration literals and entries. See also +-- Requires_Overriding. + +-- Is_Abstract_Type (Flag146) +-- Present in all types. Set for abstract types. + +-- Is_Access_Constant (Flag69) +-- Present in access types and subtypes. Indicates that the keyword +-- constant was present in the access type definition. + +-- Is_Access_Protected_Subprogram_Type (synthesized) +-- Applies to all types, true for named and anonymous access to +-- protected subprograms. + +-- Is_Access_Type (synthesized) +-- Applies to all entities, true for access types and subtypes + +-- Is_Ada_2005_Only (Flag185) +-- Present in all entities, true if a valid pragma Ada_05 or Ada_2005 +-- applies to the entity which specifically names the entity, indicating +-- that the entity is Ada 2005 only. Note that this flag is not set if +-- the entity is part of a unit compiled with the normal no-argument form +-- of pragma Ada_05 or Ada_2005. + +-- Is_Ada_2012_Only (Flag199) +-- Present in all entities, true if a valid pragma Ada_12 or Ada_2012 +-- applies to the entity which specifically names the entity, indicating +-- that the entity is Ada 2012 only. Note that this flag is not set if +-- the entity is part of a unit compiled with the normal no-argument form +-- of pragma Ada_12 or Ada_2012. + +-- Is_Aliased (Flag15) +-- Present in objects whose declarations carry the keyword aliased, +-- and on record components that have the keyword. + +-- Is_AST_Entry (Flag132) +-- Present in entry entities. Set if a valid pragma AST_Entry applies +-- to the entry. This flag can only be set in OpenVMS versions of GNAT. +-- Note: we also allow the flag to appear in entry families, but given +-- the current implementation of the pragma AST_Entry, this flag will +-- always be False in entry families. + +-- Is_Atomic (Flag85) +-- Present in all type entities, and also in constants, components and +-- variables. Set if a pragma Atomic or Shared applies to the entity. +-- In the case of private and incomplete types, this flag is set in +-- both the partial view and the full view. + +-- Is_Array_Type (synthesized) +-- Applies to all entities, true for array types and subtypes + +-- Is_Asynchronous (Flag81) +-- Present in all type entities and in procedure entities. Set +-- if a pragma Asynchronous applies to the entity. + +-- Is_Base_Type (synthesized) +-- Applies to type and subtype entities. True if entity is a base type + +-- Is_Bit_Packed_Array (Flag122) [implementation base type only] +-- Present in all entities. This flag is set for a packed array type that +-- is bit packed (i.e. the component size is known by the front end and +-- is in the range 1-7, 9-15, 17-31, or 33-63). Is_Packed is always set +-- if Is_Bit_Packed_Array is set, but it is possible for Is_Packed to be +-- set without Is_Bit_Packed_Array for the case of an array having one or +-- more index types that are enumeration types with non-standard +-- enumeration representations. + +-- Is_Boolean_Type (synthesized) +-- Applies to all entities, true for boolean types and subtypes, +-- i.e. Standard.Boolean and all types ultimately derived from it. + +-- Is_Called (Flag102) +-- Present in subprograms. Returns true if the subprogram is called +-- in the unit being compiled or in a unit in the context. Used for +-- inlining. + +-- Is_Character_Type (Flag63) +-- Present in all entities. Set for character types and subtypes, +-- i.e. enumeration types that have at least one character literal. + +-- Is_Child_Unit (Flag73) +-- Present in all entities. Set only for defining entities of program +-- units that are child units (but False for subunits). + +-- Is_Class_Wide_Type (synthesized) +-- Applies to all entities, true for class wide types and subtypes + +-- Is_Class_Wide_Equivalent_Type (Flag35) +-- Present in record types and subtypes. Set to True, if the type acts +-- as a class-wide equivalent type, i.e. the Equivalent_Type field of +-- some class-wide subtype entity references this record type. + +-- Is_Compilation_Unit (Flag149) +-- Present in all entities. Set if the entity is a package or subprogram +-- entity for a compilation unit other than a subunit (since we treat +-- subunits as part of the same compilation operation as the ultimate +-- parent, we do not consider them to be separate units for this flag). + +-- Is_Completely_Hidden (Flag103) +-- Present in all entities. This flag can be set only for E_Discriminant +-- entities. This flag can be set only for girder discriminants of +-- untagged types. When set, the entity is a girder discriminant of a +-- derived untagged type which is not directly visible in the derived +-- type because the derived type or one of its ancestors have renamed the +-- discriminants in the root type. Note: there are girder discriminants +-- which are not Completely_Hidden (e.g. discriminants of a root type). + +-- Is_Composite_Type (synthesized) +-- Applies to all entities, true for all composite types and +-- subtypes. Either Is_Composite_Type or Is_Elementary_Type (but +-- not both) is true of any type. + +-- Is_Concurrent_Record_Type (Flag20) +-- Present in record types and subtypes. Set if the type was created +-- by the expander to represent a task or protected type. For every +-- concurrent type, such as record type is constructed, and task and +-- protected objects are instances of this record type at runtime +-- (Gigi will replace declarations of the concurrent type using the +-- declarations of the corresponding record type). See package Exp_Ch9 +-- for further details. + +-- Is_Concurrent_Type (synthesized) +-- Applies to all entities, true for task types and subtypes and for +-- protected types and subtypes. + +-- Is_Constant_Object (synthesized) +-- Applies to all entities, true for E_Constant, E_Loop_Parameter, and +-- E_In_Parameter entities. + +-- Is_Constrained (Flag12) +-- Present in types or subtypes which may have index, discriminant +-- or range constraint (i.e. array types and subtypes, record types +-- and subtypes, string types and subtypes, and all numeric types). +-- Set if the type or subtype is constrained. + +-- Is_Constr_Subt_For_U_Nominal (Flag80) +-- Present in all types and subtypes. Set true only for the constructed +-- subtype of an object whose nominal subtype is unconstrained. Note +-- that the constructed subtype itself will be constrained. + +-- Is_Constr_Subt_For_UN_Aliased (Flag141) +-- Present in all types and subtypes. This flag can be set only if +-- Is_Constr_Subt_For_U_Nominal is also set. It indicates that in +-- addition the object concerned is aliased. This flag is used by +-- Gigi to determine whether a template must be constructed. + +-- Is_Constructor (Flag76) +-- Present in function and procedure entities. Set if a pragma +-- CPP_Constructor applies to the subprogram. + +-- Is_Controlled (Flag42) [base type only] +-- Present in all type entities. Indicates that the type is controlled, +-- i.e. is either a descendant of Ada.Finalization.Controlled or of +-- Ada.Finalization.Limited_Controlled. + +-- Is_Controlling_Formal (Flag97) +-- Present in all Formal_Kind entities. Marks the controlling parameters +-- of dispatching operations. + +-- Is_CPP_Class (Flag74) +-- Present in all type entities, set only for tagged types to which a +-- valid pragma Import (CPP, ...) or pragma CPP_Class has been applied. + +-- Is_Decimal_Fixed_Point_Type (synthesized) +-- Applies to all type entities, true for decimal fixed point +-- types and subtypes. + +-- Is_Descendent_Of_Address (Flag223) +-- Present in all type and subtype entities. Indicates that a type is an +-- address type that is visibly a numeric type. Used for semantic checks +-- on VMS to remove ambiguities in universal integer expressions that may +-- have an address interpretation + +-- Is_Discrete_Type (synthesized) +-- Applies to all entities, true for all discrete types and subtypes + +-- Is_Discrete_Or_Fixed_Point_Type (synthesized) +-- Applies to all entities, true for all discrete types and subtypes +-- and all fixed-point types and subtypes. + +-- Is_Discrim_SO_Function (Flag176) +-- Present in all entities. Set only in E_Function entities that Layout +-- creates to compute discriminant-dependent dynamic size/offset values. + +-- Is_Discriminal (synthesized) +-- Applies to all entities, true for renamings of discriminants. Such +-- entities appear as constants or in parameters. + +-- Is_Dispatch_Table_Entity (Flag234) +-- Applies to all entities. Set to indicate to the backend that this +-- entity is associated with a dispatch table. + +-- Is_Dispatching_Operation (Flag6) +-- Present in all entities. Set true for procedures, functions, +-- generic procedures and generic functions if the corresponding +-- operation is dispatching. + +-- Is_Dynamic_Scope (synthesized) +-- Applies to all Entities. Returns True if the entity is a dynamic +-- scope (i.e. a block, subprogram, task_type, entry +-- or extended return statement). + +-- Is_Elementary_Type (synthesized) +-- Applies to all entities, true for all elementary types and +-- subtypes. Either Is_Composite_Type or Is_Elementary_Type (but +-- not both) is true of any type. + +-- Is_Eliminated (Flag124) +-- Present in type entities, subprogram entities, and object entities. +-- Indicates that the corresponding entity has been eliminated by use +-- of pragma Eliminate. Also used to mark subprogram entities whose +-- declaration and body are within unreachable code that is removed. + +-- Is_Enumeration_Type (synthesized) +-- Present in all entities, true for enumeration types and subtypes + +-- Is_Entry (synthesized) +-- Applies to all entities, True only for entry and entry family +-- entities and False for all other entity kinds. + +-- Is_Entry_Formal (Flag52) +-- Present in all entities. Set only for entry formals (which can +-- only be in, in-out or out parameters). This flag is used to speed +-- up the test for the need to replace references in Exp_Ch2. + +-- Is_Exported (Flag99) +-- Present in all entities. Set if the entity is exported. For now we +-- only allow the export of constants, exceptions, functions, procedures +-- and variables, but that may well change later on. Exceptions can only +-- be exported in the OpenVMS and Java VM implementations of GNAT. + +-- Is_First_Subtype (Flag70) +-- Present in all entities. True for first subtypes (RM 3.2.1(6)), +-- i.e. the entity in the type declaration that introduced the type. +-- This may be the base type itself (e.g. for record declarations and +-- enumeration type declarations), or it may be the first subtype of +-- an anonymous base type (e.g. for integer type declarations or +-- constrained array declarations). + +-- Is_Fixed_Point_Type (synthesized) +-- Applies to all entities, true for decimal and ordinary fixed +-- point types and subtypes + +-- Is_Floating_Point_Type (synthesized) +-- Applies to all entities, true for float types and subtypes + +-- Is_Formal (synthesized) +-- Applies to all entities, true for IN, IN OUT and OUT parameters + +-- Is_Formal_Object (synthesized) +-- Applies to all entities, true for generic IN and IN OUT parameters + +-- Is_Formal_Subprogram (Flag111) +-- Present in all entities. Set for generic formal subprograms. + +-- Is_For_Access_Subtype (Flag118) +-- Present in E_Private_Subtype and E_Record_Subtype entities. Means the +-- sole purpose of the type is to be designated by an Access_Subtype and +-- hence should not be expanded into components because the type may not +-- have been found or frozen yet. + +-- Is_Frozen (Flag4) +-- Present in all type and subtype entities. Set if type or subtype has +-- been frozen. + +-- Is_Generic_Actual_Type (Flag94) +-- Present in all type and subtype entities. Set in the subtype +-- declaration that renames the generic formal as a subtype of the +-- actual. Guarantees that the subtype is not static within the instance. + +-- Is_Generic_Instance (Flag130) +-- Present in all entities. Set to indicate that the entity is an +-- instance of a generic unit, or a formal package (which is an instance +-- of the template). + +-- Is_Generic_Subprogram (synthesized) +-- Applies to all entities. Yields True for a generic subprogram +-- (generic function, generic subprogram), False for all other entities. + +-- Is_Generic_Type (Flag13) +-- Present in all entities. Set for types which are generic formal types. +-- Such types have an Ekind that corresponds to their classification, so +-- the Ekind cannot be used to identify generic types. + +-- Is_Generic_Unit (synthesized) +-- Applies to all entities. Yields True for a generic unit (generic +-- package, generic function, generic procedure), and False for all +-- other entities. + +-- Is_Hidden (Flag57) +-- Present in all entities. Set true for all entities declared in the +-- private part or body of a package. Also marks generic formals of a +-- formal package declared without a box. For library level entities, +-- this flag is set if the entity is not publicly visible. This flag +-- is reset when compiling the body of the package where the entity +-- is declared, when compiling the private part or body of a public +-- child unit, and when compiling a private child unit (see Install_ +-- Private_Declaration in sem_ch7). + +-- Is_Hidden_Open_Scope (Flag171) +-- Present in all entities. Set true for a scope that contains the +-- instantiation of a child unit, and whose entities are not visible +-- during analysis of the instance. + +-- Is_Immediately_Visible (Flag7) +-- Present in all entities. Set if entity is immediately visible, i.e. +-- is defined in some currently open scope (RM 8.3(4)). + +-- Is_Imported (Flag24) +-- Present in all entities. Set if the entity is imported. For now we +-- only allow the import of exceptions, functions, procedures, packages. +-- and variables. Exceptions can only be imported in the OpenVMS and +-- Java VM implementations of GNAT. Packages and types can only be +-- imported in the Java VM implementation. + +-- Is_Incomplete_Or_Private_Type (synthesized) +-- Applies to all entities, true for private and incomplete types + +-- Is_Incomplete_Type (synthesized) +-- Applies to all entities, true for incomplete types and subtypes + +-- Is_Inlined (Flag11) +-- Present in all entities. Set for functions and procedures which are +-- to be inlined. For subprograms created during expansion, this flag +-- may be set directly by the expander to request inlining. Also set +-- for packages that contain inlined subprograms, whose bodies must be +-- be compiled. Is_Inlined is also set on generic subprograms and is +-- inherited by their instances. It is also set on the body entities +-- of inlined subprograms. See also Has_Pragma_Inline. + +-- Is_Instantiated (Flag126) +-- Present in generic packages and generic subprograms. Set if the unit +-- is instantiated from somewhere in the extended main source unit. This +-- flag is used to control warnings about the unit being uninstantiated. +-- Also set in a package that is used as an actual for a generic package +-- formal in an instantiation. Also set on a parent instance, in the +-- instantiation of a child, which is implicitly declared in the parent. + +-- Is_Integer_Type (synthesized) +-- Applies to all entities, true for integer types and subtypes + +-- Is_Interface (Flag186) +-- Present in record types and subtypes. Set to indicate that the current +-- entity corresponds with an abstract interface. Because abstract +-- interfaces are conceptually a special kind of abstract tagged types +-- we represent them by means of tagged record types and subtypes +-- marked with this attribute. This allows us to reuse most of the +-- compiler support for abstract tagged types to implement interfaces +-- (Ada 2005: AI-251). + +-- Is_Internal (Flag17) +-- Present in all entities. Set to indicate an entity created during +-- semantic processing (e.g. an implicit type, or a temporary). The +-- current uses of this flag are: +-- +-- 1) Internal entities (such as temporaries generated for the result +-- of an inlined function call or dummy variables generated for the +-- debugger). Set to indicate that they need not be initialized, even +-- when scalars are initialized or normalized; +-- +-- 2) Predefined primitives of tagged types. Set to mark that they +-- have specific properties: first they are primitives even if they +-- are not defined in the type scope (the freezing point is not +-- necessarily in the same scope), and second the predefined equality +-- can be overridden by a user-defined equality, no body will be +-- generated in this case. +-- +-- 3) Object declarations generated by the expander that are implicitly +-- imported or exported so that they can be marked in Sprint output. +-- +-- 4) Internal entities in the list of primitives of tagged types that +-- are used to handle secondary dispatch tables. These entities have +-- also the attribute Interface_Alias. +-- +-- Is_Interrupt_Handler (Flag89) +-- Present in procedures. Set if a pragma Interrupt_Handler applies +-- to the procedure. The procedure must be parameterless, and on all +-- targets except AAMP it must be a protected procedure. + +-- Is_Intrinsic_Subprogram (Flag64) +-- Present in functions and procedures. It is set if a valid pragma +-- Interface or Import is present for this subprogram specifying pragma +-- Intrinsic. Valid means that the name and profile of the subprogram +-- match the requirements of one of the recognized intrinsic subprograms +-- (see package Sem_Intr for details). Note: the value of Convention for +-- such an entity will be set to Convention_Intrinsic, but it is the +-- setting of Is_Intrinsic_Subprogram, NOT simply having convention set +-- to intrinsic, which causes intrinsic code to be generated. + +-- Is_Itype (Flag91) +-- Present in all entities. Set to indicate that a type is an Itype, +-- which means that the declaration for the type does not appear +-- explicitly in the tree. Instead gigi will elaborate the type when it +-- is first used. Has_Delayed_Freeze can be set for Itypes, and the +-- meaning is that the first use (the one which causes the type to be +-- defined) will be the freeze node. Note that an important restriction +-- on Itypes is that the first use of such a type (the one that causes it +-- to be defined) must be in the same scope as the type. + +-- Is_Known_Non_Null (Flag37) +-- Present in all entities. Relevant (and can be set True) only for +-- objects of an access type. It is set if the object is currently +-- known to have a non-null value (meaning that no access checks +-- are needed). The indication can for example come from assignment +-- of an access parameter or an allocator whose value is known non-null. +-- +-- Note: this flag is set according to the sequential flow of the +-- program, watching the current value of the variable. However, +-- this processing can miss cases of changing the value of an aliased +-- or constant object, so even if this flag is set, it should not +-- be believed if the variable is aliased or volatile. It would +-- be a little neater to avoid the flag being set in the first +-- place in such cases, but that's trickier, and there is only +-- one place that tests the value anyway. +-- +-- The flag is dynamically set and reset as semantic analysis and +-- expansion proceeds. Its value is meaningless once the tree is +-- fully constructed, since it simply indicates the last state. +-- Thus this flag has no meaning to the back end. + +-- Is_Known_Null (Flag204) +-- Present in all entities. Relevant (and can be set True) only for +-- objects of an access type. It is set if the object is currently known +-- to have a null value (meaning that a dereference will surely raise +-- constraint error exception). The indication can come from an +-- assignment or object declaration. +-- +-- The comments above about sequential flow and aliased and volatile for +-- the Is_Known_Non_Null flag apply equally to the Is_Known_Null flag. + +-- Is_Known_Valid (Flag170) +-- Present in all entities. Relevant for types (and subtype) and +-- for objects (and enumeration literals) of a discrete type. +-- +-- The purpose of this flag is to implement the requirement stated +-- in (RM 13.9.1(9-11)) which require that the use of possibly invalid +-- values may not cause programs to become erroneous. See the function +-- Checks.Expr_Known_Valid for further details. Note that the setting +-- is conservative, in the sense that if the flag is set, it must be +-- right. If the flag is not set, nothing is known about the validity. +-- +-- For enumeration literals, the flag is always set, since clearly +-- an enumeration literal represents a valid value. Range checks +-- where necessary will ensure that this valid value is appropriate. +-- +-- For objects, the flag indicates the state of knowledge about the +-- current value of the object. This may be modified during expansion, +-- and thus the final value is not relevant to gigi. +-- +-- For types and subtypes, the flag is set if all possible bit patterns +-- of length Object_Size (i.e. Esize of the type) represent valid values +-- of the type. In general for such tytpes, all values are valid, the +-- only exception being the case where an object of the type has an +-- explicit size that is greater than Object_Size. +-- +-- For non-discrete objects, the setting of the Is_Known_Valid flag is +-- not defined, and is not relevant, since the considerations of the +-- requirement in (RM 13.9.1(9-11)) do not apply. +-- +-- The flag is dynamically set and reset as semantic analysis and +-- expansion proceeds. Its value is meaningless once the tree is +-- fully constructed, since it simply indicates the last state. +-- Thus this flag has no meaning to the back end. + +-- Is_Limited_Composite (Flag106) +-- Present in all entities. Set for composite types that have a +-- limited component. Used to enforce the rule that operations on +-- the composite type that depend on the full view of the component +-- do not become visible until the immediate scope of the composite +-- type itself (RM 7.3.1 (5)). + +-- Is_Limited_Interface (Flag197) +-- Present in record types and subtypes. True for interface types, if +-- interface is declared limited, task, protected, or synchronized, or +-- is derived from a limited interface. + +-- Is_Limited_Record (Flag25) +-- Present in all entities. Set to true for record (sub)types if the +-- record is declared to be limited. Note that this flag is not set +-- simply because some components of the record are limited. + +-- Is_Local_Anonymous_Access (Flag194) +-- Present in access types. Set for an anonymous access type to indicate +-- that the type is created for a record component with an access +-- definition, an array component, or a stand-alone object. Such +-- anonymous types have an accessibility level equal to that of the +-- declaration in which they appear, unlike the anonymous access types +-- that are created for access parameters and access discriminants. + +-- Is_Machine_Code_Subprogram (Flag137) +-- Present in subprogram entities. Set to indicate that the subprogram +-- is a machine code subprogram (i.e. its body includes at least one +-- code statement). Also indicates that all necessary semantic checks +-- as required by RM 13.8(3) have been performed. + +-- Is_Modular_Integer_Type (synthesized) +-- Applies to all entities. True if entity is a modular integer type + +-- Is_Non_Static_Subtype (Flag109) +-- Present in all type and subtype entities. It is set in some (but not +-- all) cases in which a subtype is known to be non-static. Before this +-- flag was added, the computation of whether a subtype was static was +-- entirely synthesized, by looking at the bounds, and the immediate +-- subtype parent. However, this method does not work for some Itypes +-- that have no parent set (and the only way to find the immediate +-- subtype parent is to go through the tree). For now, this flay is set +-- conservatively, i.e. if it is set then for sure the subtype is non- +-- static, but if it is not set, then the type may or may not be static. +-- Thus the test for a static subtype is that this flag is clear AND that +-- the bounds are static AND that the parent subtype (if available to be +-- tested) is static. Eventually we should make sure this flag is always +-- set right, at which point, these comments can be removed, and the +-- tests for static subtypes greatly simplified. + +-- Is_Null_Init_Proc (Flag178) +-- Present in procedure entities. Set for generated init proc procedures +-- (used to initialize composite types), if the code for the procedure +-- is null (i.e. is a return and nothing else). Such null initialization +-- procedures are generated in case some client is compiled using the +-- Initialize_Scalars pragma, generating a call to this null procedure, +-- but there is no need to call such procedures within a compilation +-- unit, and this flag is used to suppress such calls. + +-- Is_Numeric_Type (synthesized) +-- Applies to all entities, true for all numeric types and subtypes +-- (integer, fixed, float). + +-- Is_Object (synthesized) +-- Applies to all entities, true for entities representing objects, +-- including generic formal parameters. + +-- Is_Obsolescent (Flag153) +-- Present in all entities. Set for any entity for which a valid pragma +-- Obsolescent applies. + +-- Is_Only_Out_Parameter (Flag226) +-- Present in formal parameter entities. Set if this parameter is the +-- only OUT parameter for this formal part. If there is more than one +-- out parameter, or if there is some other IN OUT parameter then this +-- flag is not set in any of them. Used in generation of warnings. + +-- Is_Optional_Parameter (Flag134) +-- Present in parameter entities. Set if the parameter is specified as +-- optional by use of a First_Optional_Parameter argument to one of the +-- extended Import pragmas. Can only be set for OpenVMS versions of GNAT. + +-- Is_Ordinary_Fixed_Point_Type (synthesized) +-- Applies to all entities, true for ordinary fixed point types and +-- subtypes. + +-- Is_Package_Or_Generic_Package (synthesized) +-- Applies to all entities. True for packages and generic packages. +-- False for all other entities. + +-- Is_Package_Body_Entity (Flag160) +-- Present in all entities. Set for entities defined at the top level +-- of a package body. Used to control externally generated names. + +-- Is_Packed (Flag51) [implementation base type only] +-- Present in all type entities. This flag is set only for record and +-- array types which have a packed representation. There are three +-- cases which cause packing: +-- +-- 1. Explicit use of pragma Pack for an array of package components +-- 2. Explicit use of pragma Pack to pack a record +-- 4. Setting Component_Size of an array to a bit-packable value +-- 3. Indexing an array with a non-standard enumeration type. +-- +-- For records, Is_Packed is always set if Has_Pragma_Pack is set, +-- and can also be set on its own in a derived type which inherited +-- its packed status. +-- +-- For arrays, Is_Packed is set if an array is bit packed (i.e. the +-- component size is known at compile time and is 1-7, 9-15 or 17-31), +-- or if the array has one or more index types that are enumeration +-- types with non-standard representations (in GNAT, we store such +-- arrays compactly, using the Pos of the enumeration type value). +-- +-- As for the case of records, Is_Packed can be set on its own for a +-- derived type, with the same dual before/after freeze meaning. +-- Is_Packed can also be set as the result of an explicit component +-- size clause that specifies an appropriate component size. +-- +-- In the bit packed array case, Is_Bit_Packed_Array will be set in +-- the bit packed case once the array type is frozen. +-- +-- Before an array type is frozen, Is_Packed will always be set if +-- Has_Pragma_Pack is set. Before the freeze point, it is not possible +-- to know the component size, since the component type is not frozen +-- until the array type is frozen. Thus Is_Packed for an array type +-- before it is frozen means that packed is required. Then if it turns +-- out that the component size is not suitable for bit packing, the +-- Is_Packed flag gets turned off. + +-- Is_Packed_Array_Type (Flag138) +-- Present in all entities. This flag is set on the entity for the type +-- used to implement a packed array (either a modular type, or a subtype +-- of Packed_Bytes{1,2,4} as appropriate). The flag is set if and only +-- if the type appears in the Packed_Array_Type field of some other type +-- entity. It is used by Gigi to activate the special processing for such +-- types (unchecked conversions that would not otherwise be allowed are +-- allowed for such types). If the Is_Packed_Array_Type flag is set in +-- an entity, then the Original_Array_Type field of this entity points +-- to the original array type for which this is the packed array type. + +-- Is_Potentially_Use_Visible (Flag9) +-- Present in all entities. Set if entity is potentially use visible, +-- i.e. it is defined in a package that appears in a currently active +-- use clause (RM 8.4(8)). Note that potentially use visible entities +-- are not necessarily use visible (RM 8.4(9-11)). + +-- Is_Preelaborated (Flag59) +-- Present in all entities, set in E_Package and E_Generic_Package +-- entities to which a pragma Preelaborate is applied, and also in +-- all entities within such packages. Note that the fact that this +-- flag is set does not necesarily mean that no elaboration code is +-- generated for the package. + +-- Is_Primitive (Flag218) +-- Present in overloadable entities and in generic subprograms. Set to +-- indicate that this is a primitive operation of some type, which may +-- be a tagged type or a non-tagged type. Used to verify overriding +-- indicators in bodies. + +-- Is_Primitive_Wrapper (Flag195) +-- Present in functions and procedures created by the expander to serve +-- as an indirection mechanism to overriding primitives of concurrent +-- types, entries and protected procedures. + +-- Is_Prival (synthesized) +-- Applies to all entities, true for renamings of private protected +-- components. Such entities appear as constants or variables. + +-- Is_Private_Composite (Flag107) +-- Present in composite types that have a private component. Used to +-- enforce the rule that operations on the composite type that depend +-- on the full view of the component, do not become visible until the +-- immediate scope of the composite type itself (7.3.1 (5)). Both this +-- flag and Is_Limited_Composite are needed. + +-- Is_Private_Descendant (Flag53) +-- Present in entities that can represent library units (packages, +-- functions, procedures). Set if the library unit is itself a private +-- child unit, or if it is the descendent of a private child unit. + +-- Is_Private_Primitive (Flag245) +-- Present in subprograms. Set if the operation is a primitive of a +-- tagged type (procedure or function dispatching on result) whose +-- full view has not been seen. Used in particular for primitive +-- subprograms of a synchronized type declared between the two views +-- of the type, so that the wrapper built for such a subprogram can +-- be given the proper signature. + +-- Is_Private_Type (synthesized) +-- Applies to all entities, true for private types and subtypes, +-- as well as for record with private types as subtypes + +-- Is_Protected_Component (synthesized) +-- Applicable to all entities, true if the entity denotes a private +-- component of a protected type. + +-- Is_Protected_Interface (synthesized) +-- Present in types that are interfaces. True if interface is declared +-- protected, or is derived from protected interfaces. + +-- Is_Protected_Type (synthesized) +-- Applies to all entities, true for protected types and subtypes + +-- Is_Public (Flag10) +-- Present in all entities. Set to indicate that an entity defined in +-- one compilation unit can be referenced from other compilation units. +-- If this reference causes a reference in the generated variable, for +-- example in the case of a variable name, then Gigi will generate an +-- appropriate external name for use by the linker. + +-- Is_Protected_Record_Type (synthesized) +-- Applies to all entities, true if Is_Concurrent_Record_Type +-- Corresponding_Concurrent_Type is a protected type. + +-- Is_Pure (Flag44) +-- Present in all entities. Set in all entities of a unit to which a +-- pragma Pure is applied, and also set for the entity of the unit +-- itself. In addition, this flag may be set for any other functions +-- or procedures that are known to be side effect free, so in the case +-- of subprograms, the Is_Pure flag may be used by the optimizer to +-- imply that it can assume freedom from side effects (other than those +-- resulting from assignment to out parameters, or to objects designated +-- by access parameters). + +-- Is_Pure_Unit_Access_Type (Flag189) +-- Present in access type and subtype entities. Set if the type or +-- subtype appears in a pure unit. Used to give an error message at +-- freeze time if the access type has a storage pool. + +-- Is_RACW_Stub_Type (Flag244) +-- Present in all types, true for the stub types generated for remote +-- access-to-class-wide types. + +-- Is_Raised (Flag224) +-- Present in exception entities. Set if the entity is referenced by a +-- a raise statement. + +-- Is_Real_Type (synthesized) +-- Applies to all entities, true for real types and subtypes + +-- Is_Record_Type (synthesized) +-- Applies to all entities, true for record types and subtypes, +-- includes class-wide types and subtypes (which are also records) + +-- Is_Remote_Call_Interface (Flag62) +-- Present in all entities. Set in E_Package and E_Generic_Package +-- entities to which a pragma Remote_Call_Interface is applied, and +-- also on entities declared in the visible part of such a package. + +-- Is_Remote_Types (Flag61) +-- Present in all entities. Set in E_Package and E_Generic_Package +-- entities to which a pragma Remote_Types is applied, and also on +-- entities declared in the visible part of the spec of such a package. + +-- Is_Renaming_Of_Object (Flag112) +-- Present in all entities, set only for a variable or constant for +-- which the Renamed_Object field is non-empty and for which the +-- renaming is handled by the front end, by macro substitution of +-- a copy of the (evaluated) name tree whereever the variable is used. + +-- Is_Return_Object (Flag209) +-- Present in all object entities. True if the object is the return +-- object of an extended_return_statement; False otherwise. + +-- Is_Scalar_Type (synthesized) +-- Applies to all entities, true for scalar types and subtypes + +-- Is_Shared_Passive (Flag60) +-- Present in all entities. Set in E_Package and E_Generic_Package +-- entities to which a pragma Shared_Passive is applied, and also in +-- all entities within such packages. + +-- Is_Standard_Character_Type (synthesized) +-- Applies to all entities, true for types and subtypes whose root type +-- is one of the standard character types (Character, Wide_Character, +-- Wide_Wide_Character). + +-- Is_Statically_Allocated (Flag28) +-- Present in all entities. This can only be set True for exception, +-- variable, constant, and type/subtype entities. If the flag is set, +-- then the variable or constant must be allocated statically rather +-- than on the local stack frame. For exceptions, the meaning is that +-- the exception data should be allocated statically (and indeed this +-- flag is always set for exceptions, since exceptions do not have +-- local scope). For a type, the meaning is that the type must be +-- elaborated at the global level rather than locally. No type marked +-- with this flag may depend on a local variable, or on any other type +-- which does not also have this flag set to True. For a variable or +-- or constant, if the flag is set, then the type of the object must +-- either be declared at the library level, or it must also have the +-- flag set (since to allocate the object statically, its type must +-- also be elaborated globally). + +-- Is_String_Type (synthesized) +-- Applies to all type entities. Determines if the given type is a +-- string type, i.e. it is directly a string type or string subtype, +-- or a string slice type, or an array type with one dimension and a +-- component type that is a character type. + +-- Is_Subprogram (synthesized) +-- Applies to all entities, true for function, procedure and operator +-- entities. + +-- Is_Synchronized_Interface (synthesized) +-- Present in types that are interfaces. True if interface is declared +-- synchronized, task, or protected, or is derived from a synchronized +-- interface. + +-- Is_Tag (Flag78) +-- Present in E_Component and E_Constant entities. For regular tagged +-- type this flag is set on the tag component (whose name is Name_uTag). +-- For CPP_Class tagged types, this flag marks the pointer to the main +-- vtable (i.e. the one to be extended by derivation). + +-- Is_Tagged_Type (Flag55) +-- Present in all entities. Set for an entity for a tagged type. + +-- Is_Task_Interface (synthesized) +-- Present in types that are interfaces. True if interface is declared as +-- a task interface, or if it is derived from task interfaces. + +-- Is_Task_Record_Type (synthesized) +-- Applies to all entities. True if Is_Concurrent_Record_Type +-- Corresponding_Concurrent_Type is a task type. + +-- Is_Task_Type (synthesized) +-- Applies to all entities. True for task types and subtypes + +-- Is_Thunk (Flag225) +-- Present in all entities for subprograms (functions, procedures, and +-- operators). True for subprograms that are thunks, that is small +-- subprograms built by the expander for tagged types that cover +-- interface types. At run-time thunks displace the pointer to the object +-- (pointer named "this" in the C++ terminology) from a secondary +-- dispatch table to the primary dispatch table associated with a given +-- tagged type. Set by Expand_Interface Thunk and used by Expand_Call to +-- handle extra actuals associated with accessibility level. + +-- Is_Trivial_Subprogram (Flag235) +-- Present in all entities. Set in subprograms where either the body +-- consists of a single null statement, or the first or only statement +-- of the body raises an exception. This is used for suppressing certain +-- warnings, see Sem_Ch6.Analyze_Subprogram_Body discussion for details. + +-- Is_True_Constant (Flag163) +-- Present in all entities for constants and variables. Set in constants +-- and variables which have an initial value specified but which are +-- never assigned, partially or in the whole. For variables, it means +-- that the variable was initialized but never modified, and hence can be +-- treated as a constant by the code generator. For a constant, it means +-- that the constant was not modified by generated code (e.g. to set a +-- discriminant in an init proc). Assignments by user or generated code +-- will reset this flag. + +-- Is_Type (synthesized) +-- Applies to all entities, true for a type entity + +-- Is_Unchecked_Union (Flag117) [implementation base type only] +-- Present in all entities. Set only in record types to which the +-- pragma Unchecked_Union has been validly applied. + +-- Is_Underlying_Record_View (Flag246) [base type only] +-- Present in all entities. Set only in record types that represent the +-- underlying record view. This view is built for derivations of types +-- with unknown discriminants; it is a record with the same structure +-- as its corresponding record type, but whose parent is the full view +-- of the parent in the original type extension. + +-- Is_Unsigned_Type (Flag144) +-- Present in all types, but can be set only for discrete and fixed-point +-- type and subtype entities. This flag is only valid if the entity is +-- frozen. If set it indicates that the representation is known to be +-- unsigned (i.e. that no negative values appear in the range). This is +-- normally just a reflection of the lower bound of the subtype or base +-- type, but there is one case in which the setting is non-obvious, +-- namely the case of an unsigned subtype of a signed type from which +-- a further subtype is obtained using variable bounds. This further +-- subtype is still unsigned, but this cannot be determined by looking +-- at its bounds or the bounds of the corresponding base type. + +-- Is_Valued_Procedure (Flag127) +-- Present in procedure entities. Set if an Import_Valued_Procedure +-- or Export_Valued_Procedure pragma applies to the procedure entity. + +-- Is_Visible_Child_Unit (Flag116) +-- Present in compilation units that are child units. Once compiled, +-- child units remain chained to the entities in the parent unit, and +-- a separate flag must be used to indicate whether the names are +-- visible by selected notation, or not. + +-- Is_Visible_Formal (Flag206) +-- Present in all entities. Set for instances of the formals of a formal +-- package. Indicates that the entity must be made visible in the body +-- of the instance, to reproduce the visibility of the generic. This +-- simplifies visibility settings in instance bodies. +-- ??? confusion in above comments between being present and being set + +-- Is_VMS_Exception (Flag133) +-- Present in all entities. Set only for exception entities where the +-- exception was specified in an Import_Exception or Export_Exception +-- pragma with the VMS option for Form. See description of these pragmas +-- for details. This flag can only be set in OpenVMS versions of GNAT. + +-- Is_Volatile (Flag16) +-- Present in all type entities, and also in constants, components and +-- variables. Set if a pragma Volatile applies to the entity. Also set +-- if pragma Shared or pragma Atomic applies to entity. In the case of +-- private or incomplete types, this flag is set in both the private +-- and full view. The flag is not set reliably on private subtypes, +-- and is always retrieved from the base type (but this is not a base- +-- type-only attribute because it applies to other entities). Note that +-- the back end should use Treat_As_Volatile, rather than Is_Volatile +-- to indicate code generation requirements for volatile variables. +-- Similarly, any front end test which is concerned with suppressing +-- optimizations on volatile objects should test Treat_As_Volatile +-- rather than testing this flag. + +-- Is_Wrapper_Package (synthesized) +-- Present in package entities. Indicates that the package has been +-- created as a wrapper for a subprogram instantiation. + +-- Itype_Printed (Flag202) +-- Present in all type and subtype entities. Set in Itypes if the Itype +-- has been printed by Sprint. This is used to avoid printing an Itype +-- more than once. + +-- Kill_Elaboration_Checks (Flag32) +-- Present in all entities. Set by the expander to kill elaboration +-- checks which are known not to be needed. Equivalent in effect to +-- the use of pragma Suppress (Elaboration_Checks) for that entity +-- except that the effect is permanent and cannot be undone by a +-- subsequent pragma Unsuppress. + +-- Kill_Range_Checks (Flag33) +-- Present in all entities. Equivalent in effect to the use of pragma +-- Suppress (Range_Checks) for that entity except that the result is +-- permanent and cannot be undone by a subsequent pragma Unsuppress. +-- This is currently only used in one odd situation in Sem_Ch3 for +-- record types, and it would be good to get rid of it??? + +-- Kill_Tag_Checks (Flag34) +-- Present in all entities. Set by the expander to kill elaboration +-- checks which are known not to be needed. Equivalent in effect to +-- the use of pragma Suppress (Tag_Checks) for that entity except +-- that the result is permanent and cannot be undone by a subsequent +-- pragma Unsuppress. + +-- Known_To_Have_Preelab_Init (Flag207) +-- Present in all type and subtype entities. If set, then the type is +-- known to have preelaborable initialization. In the case of a partial +-- view of a private type, it is only possible for this to be set if a +-- pragma Preelaborable_Initialization is given for the type. For other +-- types, it is never set if the type does not have preelaborable +-- initialization, it may or may not be set if the type does have +-- preelaborable initialization. + +-- Last_Assignment (Node26) +-- Present in entities for variables, and OUT or IN OUT formals. Set for +-- a local variable or formal to point to the left side of an assignment +-- statement assigning a value to the variable. Cleared if the value of +-- the entity is referenced. Used to warn about dubious assignment +-- statements whose value is not used. + +-- Last_Entity (Node20) +-- Present in all entities which act as scopes to which a list of +-- associated entities is attached (blocks, class subtypes and types, +-- entries, functions, loops, packages, procedures, protected objects, +-- record types and subtypes, private types, task types and subtypes). +-- Points to the last entry in the list of associated entities chained +-- through the Next_Entity field. Empty if no entities are chained. + +-- Last_Formal (synthesized) +-- Applies to subprograms and subprogram types, and also in entries +-- and entry families. Returns last formal of the subprogram or entry. +-- The formals are the first entities declared in a subprogram or in +-- a subprogram type (the designated type of an Access_To_Subprogram +-- definition) or in an entry. + +-- Limited_View (Node23) +-- Present in non-generic package entities that are not instances. Bona +-- fide package with the limited-view list through the first_entity and +-- first_private attributes. The elements of this list are the shadow +-- entities created for the types and local packages that are declared +-- in a package appearing in a limited_with clause (Ada 2005: AI-50217) + +-- Lit_Indexes (Node15) +-- Present in enumeration types and subtypes. Non-empty only for the +-- case of an enumeration root type, where it contains the entity for +-- the generated indexes entity. See unit Exp_Imgv for full details of +-- the nature and use of this entity for implementing the Image and +-- Value attributes for the enumeration type in question. +-- +-- Lit_Strings (Node16) +-- Present in enumeration types and subtypes. Non-empty only for the +-- case of an enumeration root type, where it contains the entity for +-- the literals string entity. See unit Exp_Imgv for full details of +-- the nature and use of this entity for implementing the Image and +-- Value attributes for the enumeration type in question. + +-- Low_Bound_Tested (Flag205) +-- Present in all entities. Currently this can only be set True for +-- formal parameter entries of a standard unconstrained one-dimensional +-- array or string type. Indicates that an explicit test of the low bound +-- of the formal appeared in the code, e.g. in a pragma Assert. If this +-- flag is set, warnings about assuming the index low bound to be one +-- are suppressed. + +-- Machine_Radix_10 (Flag84) +-- Present in decimal types and subtypes, set if the Machine_Radix +-- is 10, as the result of the specification of a machine radix +-- representation clause. Note that it is possible for this flag +-- to be set without having Has_Machine_Radix_Clause True. This +-- happens when a type is derived from a type with a clause present. + +-- Master_Id (Node17) +-- Present in access types and subtypes. Empty unless Has_Task is +-- set for the designated type, in which case it points to the entity +-- for the Master_Id for the access type master. Also set for access-to- +-- limited-class-wide types whose root may be extended with task +-- components, and for access-to-limited-interfaces because they can be +-- used to reference tasks implementing such interface. + +-- Materialize_Entity (Flag168) +-- Present in all entities. Set only for constant or renamed entities +-- which should be materialized for debugging purposes. In the case of +-- a constant, a memory location should be allocated containing the +-- value. In the case of a renaming, a memory location containing the +-- renamed address should be allocated. + +-- Mechanism (Uint8) (returned as Mechanism_Type) +-- Present in functions and non-generic formal parameters. Indicates +-- the mechanism to be used for the function return or for the formal +-- parameter. See separate section on passing mechanisms. This field +-- is also set (to the default value of zero) in a subprogram body +-- entity but not used in this context. + +-- Modulus (Uint17) [base type only] +-- Present in modular types. Contains the modulus. For the binary +-- case, this will be a power of 2, but if Non_Binary_Modulus is +-- set, then it will not be a power of 2. + +-- Must_Be_On_Byte_Boundary (Flag183) +-- Present in entities for types and subtypes. Set if objects of +-- the type must always be allocated on a byte boundary (more +-- accurately a storage unit boundary). The front end checks that +-- component clauses respect this rule, and the back end ensures +-- that record packing does not violate this rule. Currently the +-- flag is set only for packed arrays longer than 64 bits where +-- the component size is not a power of 2. + +-- Must_Have_Preelab_Init (Flag208) +-- Present in entities for types and subtypes. Set in the full type of a +-- private type or subtype if a pragma Has_Preelaborable_Initialization +-- is present for the private type. Used to check that the full type has +-- preelaborable initialization at freeze time (this has to be deferred +-- to the freeze point because of the rule about overriding Initialize). + +-- Needs_Debug_Info (Flag147) +-- Present in all entities. Set if the entity requires normal debugging +-- information to be generated. This is true of all entities that have +-- Comes_From_Source set, and also transitively for entities associated +-- with such components (e.g. their types). It is true for all entities +-- in Debug_Generated_Code mode (-gnatD switch). This is the flag that +-- the back end should check to determine whether or not to generate +-- debugging information for an entity. Note that callers should always +-- use Sem_Util.Set_Debug_Info_Needed, rather than Set_Needs_Debug_Info, +-- so that the flag is set properly on subsidiary entities. + +-- Needs_No_Actuals (Flag22) +-- Present in callable entities (subprograms, entries, access to +-- subprograms) which can be called without actuals because all of +-- their formals (if any) have default values. This flag simplifies the +-- resolution of the syntactic ambiguity involving a call to these +-- entities when the return type is an array type, and a call can be +-- interpreted as an indexing of the result of the call. It is also +-- used to resolve various cases of entry calls. +-- +-- Never_Set_In_Source (Flag115) +-- Present in all entities, but can be set only for variables and +-- parameters. This flag is set if the object is never assigned a value +-- in user source code, either by assignment or by being used as an out +-- or in out parameter. Note that this flag is not reset from using an +-- initial value, so if you want to test for this case as well, test the +-- Has_Initial_Value flag also. +-- +-- This flag is only for the purposes of issuing warnings, it must not +-- be used by the code generator to indicate that the variable is in +-- fact a constant, since some assignments in generated code do not +-- count (for example, the call to an init proc to assign some but +-- not all of the fields in a partially initialized record). The code +-- generator should instead use the flag Is_True_Constant. +-- +-- For the purposes of this warning, the default assignment of +-- access variables to null is not considered the assignment of +-- of a value (so the warning can be given for code that relies +-- on this initial null value, when no other value is ever set). +-- +-- In variables and out parameters, if this flag is set after full +-- processing of the corresponding declarative unit, it indicates that +-- the variable or parameter was never set, and a warning message can +-- be issued. +-- +-- Note: this flag is initially set, and then cleared on encountering +-- any construct that might conceivably legitimately set the value. +-- Thus during the analysis of a declarative region and its associated +-- statement sequence, the meaning of the flag is "not set yet", and +-- once this analysis is complete the flag means "never assigned". + +-- Note: for variables appearing in package declarations, this flag +-- is never set. That is because there is no way to tell if some +-- client modifies the variable (or in the case of variables in the +-- private part, if some child unit modifies the variables). + +-- Note: in the case of renamed objects, the flag must be set in the +-- ultimate renamed object. Clients noting a possible modification +-- should use the Note_Possible_Modification procedure in Sem_Util +-- rather than Set_Never_Set_In_Source precisely to deal properly with +-- the renaming possibility. + +-- Next_Component (synthesized) +-- Applies to record components. Returns the next component by following +-- the chain of declared entities until one is found which corresponds to +-- a component (Ekind is E_Component). Any internal types generated from +-- the subtype indications of the record components are skipped. Returns +-- Empty if no more components. + +-- Next_Component_Or_Discriminant (synthesized) +-- Similar to Next_Component, but includes components and discriminants +-- so the input can have either E_Component or E_Discriminant, and the +-- same is true for the result. Returns Empty if no more components or +-- discriminants in the record. + +-- Next_Discriminant (synthesized) +-- Applies to discriminants returned by First/Next_Discriminant. +-- Returns the next language-defined (ie: perhaps non-girder) +-- discriminant by following the chain of declared entities as long as +-- the kind of the entity corresponds to a discriminant. Note that the +-- discriminants might be the only components of the record. +-- Returns Empty if there are no more. + +-- Next_Entity (Node2) +-- Present in all entities. The entities of a scope are chained, with +-- the head of the list being in the First_Entity field of the scope +-- entity. All entities use the Next_Entity field as a forward pointer +-- for this list, with Empty indicating the end of the list. Since this +-- field is in the base part of the entity, the access routines for this +-- field are in Sinfo. + +-- Next_Formal (synthesized) +-- Applies to the entity for a formal parameter. Returns the next +-- formal parameter of the subprogram or subprogram type. Returns +-- Empty if there are no more formals. + +-- Next_Formal_With_Extras (synthesized) +-- Applies to the entity for a formal parameter. Returns the next +-- formal parameter of the subprogram or subprogram type. Returns +-- Empty if there are no more formals. The list returned includes +-- all the extra formals (see description of Extra_Formal field) + +-- Next_Index (synthesized) +-- Applies to array types and subtypes and to string types and +-- subtypes. Yields the next index. The first index is obtained by +-- using the First_Index attribute, and then subsequent indexes are +-- obtained by applying Next_Index to the previous index. Empty is +-- returned to indicate that there are no more indexes. Note that +-- unlike most attributes in this package, Next_Index applies to +-- nodes for the indexes, not to entities. + +-- Next_Inlined_Subprogram (Node12) +-- Present in subprograms. Used to chain inlined subprograms used in +-- the current compilation, in the order in which they must be compiled +-- by Gigi to insure that all inlinings are performed. + +-- Next_Literal (synthesized) +-- Applies to enumeration literals, returns the next literal, or +-- Empty if applied to the last literal. This is actually a synonym +-- for Next, but its use is preferred in this context. + +-- Non_Binary_Modulus (Flag58) [base type only] +-- Present in all subtype and type entities. Set for modular integer +-- types if the modulus value is other than a power of 2. + +-- Non_Limited_View (Node17) +-- Present in incomplete types that are the shadow entities created +-- when analyzing a limited_with_clause (Ada 2005: AI-50217). Points to +-- the defining entity in the original declaration. + +-- Nonzero_Is_True (Flag162) [base type only] +-- Present in enumeration types. True if any non-zero value is to be +-- interpreted as true. Currently this is set true for derived Boolean +-- types which have a convention of C, C++ or Fortran. + +-- No_Pool_Assigned (Flag131) [root type only] Present in access types. +-- Set if a storage size clause applies to the variable with a static +-- expression value of zero. This flag is used to generate errors if any +-- attempt is made to allocate or free an instance of such an access +-- type. This is set only in the root type, since derived types must +-- have the same pool. + +-- No_Return (Flag113) +-- Present in all entities. Always false except in the case of procedures +-- and generic procedures for which a pragma No_Return is given. + +-- Normalized_First_Bit (Uint8) +-- Present in components and discriminants. Indicates the normalized +-- value of First_Bit for the component, i.e. the offset within the +-- lowest addressed storage unit containing part or all of the field. +-- Set to No_Uint if no first bit position is assigned yet. + +-- Normalized_Position (Uint14) +-- Present in components and discriminants. Indicates the normalized +-- value of Position for the component, i.e. the offset in storage +-- units from the start of the record to the lowest addressed storage +-- unit containing part or all of the field. + +-- Normalized_Position_Max (Uint10) +-- Present in components and discriminants. For almost all cases, this +-- is the same as Normalized_Position. The one exception is for the case +-- of a discriminated record containing one or more arrays whose length +-- depends on discriminants. In this case, the Normalized_Position_Max +-- field represents the maximum possible value of Normalized_Position +-- assuming min/max values for discriminant subscripts in all fields. +-- This is used by Layout in front end layout mode to properly computed +-- the maximum size such records (needed for allocation purposes when +-- there are default discriminants, and also for the 'Size value). + +-- No_Strict_Aliasing (Flag136) [base type only] +-- Present in access types. Set to direct the back end to avoid any +-- optimizations based on an assumption about the aliasing status of +-- objects designated by the access type. For the case of the gcc +-- back end, the effect is as though all references to objects of +-- the type were compiled with -fno-strict-aliasing. This flag is +-- set if an unchecked conversion with the access type as a target +-- type occurs in the same source unit as the declaration of the +-- access type, or if an explicit pragma No_Strict_Aliasing applies. + +-- Number_Dimensions (synthesized) +-- Applies to array types and subtypes. Returns the number of dimensions +-- of the array type or subtype as a value of type Pos. + +-- Number_Entries (synthesized) +-- Applies to concurrent types. Returns the number of entries that are +-- declared within the task or protected definition for the type. + +-- Number_Formals (synthesized) +-- Applies to subprograms and subprogram types. Yields the number of +-- formals as a value of type Pos. + +-- OK_To_Rename (Flag247) +-- Present only in entities for variables. If this flag is set, it +-- means that if the entity is used as the initial value of an object +-- declaration, the object declaration can be safely converted into a +-- renaming to avoid an extra copy. This is set for variables which are +-- generated by the expander to hold the result of evaluating some +-- expression. Most notably, the local variables used to store the result +-- of concatenations are so marked (see Exp_Ch4.Expand_Concatenate). It +-- is only worth setting this flag for composites, since for primitive +-- types, it is cheaper to do the copy. + +-- OK_To_Reorder_Components (Flag239) [base type only] +-- Present in record types. Set if the back end is permitted to reorder +-- the components. If not set, the record must be layed out in the order +-- in which the components are declared textually. Currently this flag +-- can only be set by debug switches. + +-- Optimize_Alignment_Space (Flag241) +-- A flag present in type, subtype, variable, and constant entities. This +-- flag records that the type or object is to be layed out in a manner +-- consistent with Optimize_Alignment (Space) mode. The compiler and +-- binder ensure a consistent view of any given type or object. If pragma +-- Optimize_Alignment (Off) mode applies to the type/object, then neither +-- of the flags Optimize_Alignment_Space/Optimize_Alignment_Time is set. + +-- Optimize_Alignment_Time (Flag242) +-- A flag present in type, subtype, variable, and constant entities. This +-- flag records that the type or object is to be layed out in a manner +-- consistent with Optimize_Alignment (Time) mode. The compiler and +-- binder ensure a consistent view of any given type or object. If pragma +-- Optimize_Alignment (Off) mode applies to the type/object, then neither +-- of the flags Optimize_Alignment_Space/Optimize_Alignment_Time is set. + +-- Original_Array_Type (Node21) +-- Present in modular types and array types and subtypes. Set only +-- if the Is_Packed_Array_Type flag is set, indicating that the type +-- is the implementation type for a packed array, and in this case it +-- points to the original array type for which this is the packed +-- array implementation type. + +-- Original_Record_Component (Node22) +-- Present in components, including discriminants. The usage depends +-- on whether the record is a base type and whether it is tagged. +-- +-- In base tagged types: +-- When the component is inherited in a record extension, it points +-- to the original component (the entity of the ancestor component +-- which is not itself inherited) otherwise it points to itself. +-- Gigi uses this attribute to implement the automatic dereference in +-- the extension and to apply the transformation: +-- +-- Rec_Ext.Comp -> Rec_Ext.Parent. ... .Parent.Comp +-- +-- In base non-tagged types: +-- Always points to itself except for non-girder discriminants, where +-- it points to the girder discriminant it renames. +-- +-- In subtypes (tagged and untagged): +-- Points to the component in the base type. + +-- Overlays_Constant (Flag243) +-- Present in all entities. Set only for a variable for which there is +-- an address clause which causes the variable to overlay a constant. + +-- Overridden_Operation (Node26) +-- Present in subprograms. For overriding operations, points to the +-- user-defined parent subprogram that is being overridden. + +-- Package_Instantiation (Node26) +-- Present in packages and generic packages. When present, this field +-- references an N_Package_Instantiation node associated with an +-- instantiated package. In the case where the referenced node has +-- been rewritten to an N_Package_Specification, the instantiation +-- node is available from the Original_Node field of the package spec +-- node. This is currently not guaranteed to be set in all cases, but +-- when set, the field is used in Get_Package_Instantiation_Node as +-- one of the means of obtaining the instantiation node. Eventually +-- it should be set in all cases, including package entities associated +-- with formal packages. ??? + +-- Packed_Array_Type (Node23) +-- Present in array types and subtypes, including the string literal +-- subtype case, if the corresponding type is packed (either bit packed +-- or packed to eliminate holes in non-contiguous enumeration type index +-- types). References the type used to represent the packed array, which +-- is either a modular type for short static arrays, or an array of +-- System.Unsigned. Note that in some situations (internal types, and +-- references to fields of variant records), it is not always possible +-- to construct this type in advance of its use. If Packed_Array_Type +-- is empty, then the necessary type is declared on the fly for each +-- reference to the array. + +-- Parameter_Mode (synthesized) +-- Applies to formal parameter entities. This is a synonym for Ekind, +-- used when obtaining the formal kind of a formal parameter (the result +-- is one of E_[In/Out/In_Out]_Parameter) + +-- Parent_Subtype (Node19) [base type only] +-- Present in E_Record_Type. Set only for derived tagged types, in which +-- case it points to the subtype of the parent type. This is the type +-- that is used as the Etype of the _parent field. + +-- Postcondition_Proc (Node8) +-- Present only in procedure entities, saves the entity of the generated +-- postcondition proc if one is present, otherwise is set to Empty. Used +-- to generate the call to this procedure in case the expander inserts +-- implicit return statements. + +-- PPC_Wrapper (Node25) +-- Present in entries and entry families. Set only if pre- or post- +-- conditions are present. The precondition_wrapper body is the original +-- entry call, decorated with the given precondition for the entry. + +-- Primitive_Operations (synthesized) +-- Present in concurrent types, tagged record types and subtypes, tagged +-- private types and tagged incomplete types. For concurrent types whose +-- Corresponding_Record_Type (CRT) is available, returns the list of +-- Direct_Primitive_Operations of its CRT; otherwise returns No_Elist. +-- For all the other types returns the Direct_Primitive_Operations. + +-- Predicate_Function (synthesized) +-- Present in all types. Set for types for which (Has_Predicates is True) +-- and for which a predicate procedure has been built that tests that the +-- specified predicates are True. Contains the entity for the function +-- which takes a single argument of the given type, and returns True if +-- the predicate holds and False if it does not. +-- +-- Note: the reason this is marked as a synthesized attribute is that the +-- way this is stored is as an element of the Subprograms_For_Type field. + +-- Prival (Node17) +-- Present in private components of protected types. Refers to the entity +-- of the component renaming declaration generated inside protected +-- subprograms, entries or barrier functions. + +-- Prival_Link (Node20) +-- Present in constants and variables which rename private components of +-- protected types. Set to the original private component. + +-- Private_Dependents (Elist18) +-- Present in private (sub)types. Records the subtypes of the private +-- type, derivations from it, and records and arrays with components +-- dependent on the type. +-- +-- The subtypes are traversed when installing and deinstalling (the full +-- view of) a private type in order to ensure correct view of the +-- subtypes. +-- +-- Used in similar fashion for incomplete types: holds list of subtypes +-- of these incomplete types that have discriminant constraints. The +-- full views of these subtypes are constructed when the full view of +-- the incomplete type is processed. + +-- In addition, if the incomplete type is the designated type in an +-- access definition for an access parameter, the operation may be +-- a dispatching primitive operation, which is only known when the full +-- declaration of the type is seen. Subprograms that have such an +-- access parameter are also placed in the list of private_dependents. + +-- Private_View (Node22) +-- For each private type, three entities are allocated, the private view, +-- the full view, and the shadow entity. The shadow entity contains a +-- copy of the private view and is used for restoring the proper private +-- view after a region in which the full view is visible (and is copied +-- into the entity normally used for the private view during this period +-- of visibility). The Private_View field is self-referential when the +-- private view lives in its normal entity, but in the copy that is made +-- in the shadow entity, it points to the proper location in which to +-- restore the private view saved in the shadow. + +-- Protected_Formal (Node22) +-- Present in formal parameters (in, in out and out parameters). Used +-- only for formals of protected operations. References corresponding +-- formal parameter in the unprotected version of the operation that +-- is created during expansion. + +-- Protected_Body_Subprogram (Node11) +-- Present in protected operations. References the entity for the +-- subprogram which implements the body of the operation. + +-- Protection_Object (Node23) +-- Applies to protected entries, entry families and subprograms. Denotes +-- the entity which is used to rename the _object component of protected +-- types. + +-- Reachable (Flag49) +-- Present in labels. The flag is set over the range of statements in +-- which a goto to that label is legal. + +-- Referenced (Flag156) +-- Present in all entities. Set if the entity is referenced, except for +-- the case of an appearance of a simple variable that is not a renaming +-- as the left side of an assignment in which case Referenced_As_LHS is +-- set instead, or a similar appearance as an out parameter actual, in +-- which case Referenced_As_Out_Parameter is set. + +-- Referenced_As_LHS (Flag36): +-- Present in all entities. This flag is set instead of Referenced if a +-- simple variable that is not a renaming appears as the left side of an +-- assignment. The reason we distinguish this kind of reference is that +-- we have a separate warning for variables that are only assigned and +-- never read. + +-- Referenced_As_Out_Parameter (Flag227): +-- Present in all entities. This flag is set instead of Referenced if a +-- simple variable that is not a renaming appears as an actual for an out +-- formal. The reason we distinguish this kind of reference is that +-- we have a separate warning for variables that are only assigned and +-- never read, and out parameters are a special case. + +-- Register_Exception_Call (Node20) +-- Present in exception entities. When an exception is declared, +-- a call is expanded to Register_Exception. This field points to +-- the expanded N_Procedure_Call_Statement node for this call. It +-- is used for Import/Export_Exception processing to modify the +-- register call to make appropriate entries in the special tables +-- used for handling these pragmas at runtime. + +-- Related_Array_Object (Node19) +-- Present in array types and subtypes. Used only for the base type +-- and subtype created for an anonymous array object. Set to point +-- to the entity of the corresponding array object. Currently used +-- only for type-related error messages. + +-- Related_Expression (Node24) +-- Present in variables and types. Set only for internally generated +-- entities, where it may be used to denote the source expression whose +-- elaboration created the variable declaration. If set, it is used +-- for generating clearer messages from CodePeer. +-- +-- Shouldn't it also be used for the same purpose in errout? It seems +-- odd to have two mechanisms here??? + +-- Related_Instance (Node15) +-- Present in the wrapper packages created for subprogram instances. +-- The internal subprogram that implements the instance is inside the +-- wrapper package, but for debugging purposes its external symbol +-- must correspond to the name and scope of the related instance. + +-- Related_Type (Node27) +-- Present in components, constants and variables. Set when there is an +-- associated dispatch table to point to entities containing primary or +-- secondary tags. Not set in the _tag component of record types. + +-- Relative_Deadline_Variable (Node26) [implementation base type only] +-- Present in task type entities. This flag is set if a valid and +-- effective pragma Relative_Deadline applies to the base type. Points +-- to the entity for a variable that is created to hold the value given +-- in a Relative_Deadline pragma for a task type. + +-- Renamed_Entity (Node18) +-- Present in exceptions, packages, subprograms and generic units. Set +-- for entities that are defined by a renaming declaration. Denotes the +-- renamed entity, or transitively the ultimate renamed entity if +-- there is a chain of renaming declarations. Empty if no renaming. + +-- Renamed_In_Spec (Flag231) + +-- Present in package entities. If a package renaming occurs within +-- a package spec, then this flag is set on the renamed package. The +-- purpose is to prevent a warning about unused entities in the renamed +-- package. Such a warning would be inappropriate since clients of the +-- package can see the entities in the package via the renaming. + +-- Renamed_Object (Node18) +-- Present in all objects (constants, variables, components, formal +-- parameters, generic formal parameters, and loop parameters). +-- ??? Present in discriminants? +-- Set non-Empty if the object was declared by a renaming declaration, +-- in which case it references the tree node for the name of the renamed +-- object. This is only possible for the variable and constant cases. +-- For formal parameters, this field is used in the course of inline +-- expansion, to map the formals of a subprogram into the corresponding +-- actuals. For formals of a task entry, it denotes the local renaming +-- that replaces the actual within the accept statement. The field is +-- Empty otherwise (it is always empty for loop parameters). + +-- Renaming_Map (Uint9) +-- Present in generic subprograms, generic packages, and their +-- instances. Also present in the instances of the corresponding +-- bodies. Denotes the renaming map (generic entities => instance +-- entities) used to construct the instance by givin an index into +-- the tables used to represent these maps. See Sem_Ch12 for further +-- details. The maps for package instances are also used when the +-- instance is the actual corresponding to a formal package. + +-- Requires_Overriding (Flag213) +-- Present in all subprograms and entries. Set for subprograms that +-- require overriding as defined by RM-2005-3.9.3(6/2). Note that this +-- is True only for implicitly declare subprograms; it is not set on the +-- parent type's subprogram. See also Is_Abstract_Subprogram. + +-- Return_Present (Flag54) +-- Present in function and generic function entities. Set if the +-- function contains a return statement (used for error checking). +-- This flag can also be set in procedure and generic procedure +-- entities (for convenience in setting it), but is only tested +-- for the function case. + +-- Return_Applies_To (Node8) +-- Present in E_Return_Statement. Points to the entity representing +-- the construct to which the return statement applies, as defined in +-- RM-6.5(4/2). Note that a (simple) return statement within an +-- extended_return_statement applies to the extended_return_statement, +-- even though it causes the whole function to return. + +-- Returns_By_Ref (Flag90) +-- Present in function entities, to indicate that the function +-- returns the result by reference, either because its return type is a +-- by-reference-type or because it uses explicitly the secondary stack. + +-- Reverse_Bit_Order (Flag164) [base type only] +-- Present in all record type entities. Set if a valid pragma an +-- attribute representation clause for Bit_Order has reversed the order +-- of bits from the default value. When this flag is set, a component +-- clause must specify a set of bits entirely contained in a single +-- storage unit (Ada 95) or a single machine scalar (see Ada 2005 +-- AI-133), or must occupy in integral number of storage units. + +-- RM_Size (Uint13) +-- Present in all type and subtype entities. Contains the value of +-- type'Size as defined in the RM. See also the Esize field and +-- and the description on "Handling of Type'Size Values". A value +-- of zero in this field for a non-discrete type means that +-- the front end has not yet determined the size value. For the +-- case of a discrete type, this field is always set by the front +-- end and zero is a legitimate value for a type with one value. + +-- Root_Type (synthesized) +-- Applies to all type entities. For class-wide types, return the root +-- type of the class covered by the CW type, otherwise returns the +-- ultimate derivation ancestor of the given type. This function +-- preserves the view, i.e. the Root_Type of a partial view is the +-- partial view of the ultimate ancestor, the Root_Type of a full view +-- is the full view of the ultimate ancestor. Note that this function +-- does not correspond exactly to the use of root type in the RM, since +-- in the RM root type applies to a class of types, not to a type. + +-- Scalar_Range (Node20) +-- Present in all scalar types (including modular types, where the +-- bounds are 0 .. modulus - 1). References a node in the tree that +-- contains the bounds for the range. Note that this information +-- could be obtained by rummaging around the tree, but it is more +-- convenient to have it immediately at hand in the entity. The +-- contents of Scalar_Range can either be an N_Subtype_Indication +-- node (with a constraint), or a Range node, but not a simple +-- subtype reference (a subtype is converted into a range). + +-- Scale_Value (Uint15) +-- Present in decimal fixed-point types and subtypes. Contains the scale +-- for the type (i.e. the value of type'Scale = the number of decimal +-- digits after the decimal point). + +-- Scope (Node3) +-- Present in all entities. Points to the entity for the scope (block, +-- loop, subprogram, package etc.) in which the entity is declared. +-- Since this field is in the base part of the entity node, the access +-- routines for this field are in Sinfo. Note that for a child package, +-- the Scope will be the parent package, and for a non-child package, +-- the Scope will be Standard. + +-- Scope_Depth (synthesized) +-- Applies to program units, blocks, concurrent types and entries, and +-- also to record types, i.e. to any entity that can appear on the scope +-- stack. Yields the scope depth value, which for those entities other +-- than records is simply the scope depth value, for record entities, it +-- is the Scope_Depth of the record scope. + +-- Scope_Depth_Value (Uint22) +-- Present in program units, blocks, concurrent types, and entries. +-- Indicates the number of scopes that statically enclose the declaration +-- of the unit or type. Library units have a depth of zero. Note that +-- record types can act as scopes but do NOT have this field set (see +-- Scope_Depth above) + +-- Scope_Depth_Set (synthesized) +-- Applies to a special predicate function that returns a Boolean value +-- indicating whether or not the Scope_Depth field has been set. It is +-- needed, since returns an invalid value in this case! + +-- Sec_Stack_Needed_For_Return (Flag167) +-- Present in scope entities (blocks, functions, procedures, tasks, +-- entries). Set to True when secondary stack is used to hold the +-- returned value of a function and thus should not be released on +-- scope exit. + +-- Shadow_Entities (List14) +-- Present in package and generic package entities. Points to a list +-- of entities that correspond to private types. For each private type +-- a shadow entity is created that holds a copy of the private view. +-- In regions of the program where the full views of these private +-- entities are visible, the full view is copied into the entity that +-- is normally used to hold the private view, but the shadow entity +-- copy is unchanged. The shadow entities are then used to restore the +-- original private views at the end of the region. This list is a +-- standard format list (i.e. First (Shadow_Entities) is the first +-- entry and subsequent entries are obtained using Next. + +-- Shared_Var_Procs_Instance (Node22) +-- Present in variables. Set non-Empty only if Is_Shared_Passive is +-- set, in which case this is the entity for the associated instance of +-- System.Shared_Storage.Shared_Var_Procs. See Exp_Smem for full details. + +-- Size_Check_Code (Node19) +-- Present in constants and variables. Normally Empty. Set if code is +-- generated to check the size of the object. This field is used to +-- suppress this code if a subsequent address clause is encountered. + +-- Size_Clause (synthesized) +-- Applies to all entities. If a size clause is present in the rep +-- item chain for an entity then the attribute definition clause node +-- for the size clause is returned. Otherwise Size_Clause returns Empty +-- if no item is present. Usually this is only meaningful if the flag +-- Has_Size_Clause is set. This is because when the representation item +-- chain is copied for a derived type, it can inherit a size clause that +-- is not applicable to the entity. + +-- Size_Depends_On_Discriminant (Flag177) +-- Present in all entities for types and subtypes. Indicates that the +-- size of the type depends on the value of one or more discriminants. +-- Currently, this flag is only set in front end layout mode for arrays +-- which have one or more bounds depending on a discriminant value. + +-- Size_Known_At_Compile_Time (Flag92) +-- Present in all entities for types and subtypes. Indicates that the +-- size of objects of the type is known at compile time. This flag is +-- used to optimize some generated code sequences, and also to enable +-- some error checks (e.g. disallowing component clauses on variable +-- length objects). It is set conservatively (i.e. if it is True, the +-- size is certainly known at compile time, if it is False, then the +-- size may or may not be known at compile time, but the code will +-- assume that it is not known). + +-- Small_Value (Ureal21) +-- Present in fixed point types. Points to the universal real for the +-- Small of the type, either as given in a representation clause, or +-- as computed (as a power of two) by the compiler. + +-- Spec_Entity (Node19) +-- Present in package body entities. Points to corresponding package +-- spec entity. Also present in subprogram body parameters in the +-- case where there is a separate spec, where this field references +-- the corresponding parameter entities in the spec. + +-- Spec_PPC_List (Node24) +-- Present in entries, and in subprogram and generic subprogram entities. +-- Points to a list of Precondition and Postcondition pragma nodes for +-- preconditions and postconditions declared in the spec. The last pragma +-- encountered is at the head of this list, so it is in reverse order of +-- textual appearance. Note that this includes precondition/postcondition +-- pragmas generated to correspond to Pre/Post aspects. + +-- Static_Predicate (List25) +-- Present in discrete types/subtypes with predicates (Has_Predicates +-- set True). Points to a list of expression and N_Range nodes that +-- represent the predicate in canonical form. The canonical form has +-- entries sorted in ascending order, with all duplicates eliminated, +-- and adjacent ranges coalesced, so that there is always a gap in the +-- values between successive entries. The entries in this list are +-- fully analyzed and typed with the base type of the subtype. Note +-- that all entries are static and have values within the subtype range. + +-- Storage_Size_Variable (Node15) [implementation base type only] +-- Present in access types and task type entities. This flag is set +-- if a valid and effective pragma Storage_Size applies to the base +-- type. Points to the entity for a variable that is created to +-- hold the value given in a Storage_Size pragma for an access +-- collection or a task type. Note that in the access type case, +-- this field is present only in the root type (since derived types +-- share the same storage pool). + +-- Static_Elaboration_Desired (Flag77) +-- Present in library-level packages. Set by the pragma of the same +-- name, to indicate that static initialization must be attempted for +-- all types declared in the package, and that a warning must be emitted +-- for those types to which static initialization is not available. + +-- Static_Initialization (Node26) +-- Present in initialization procedures for types whose objects can be +-- initialized statically. The value of this attribute is a positional +-- aggregate whose components are compile-time static values. Used +-- when available in object declarations to eliminate the call to the +-- initialization procedure, and to minimize elaboration code. + +-- Stored_Constraint (Elist23) +-- Present in entities that can have discriminants (concurrent types +-- subtypes, record types and subtypes, private types and subtypes, +-- limited private types and subtypes and incomplete types). Points +-- to an element list containing the expressions for each of the +-- stored discriminants for the record (sub)type. + +-- Strict_Alignment (Flag145) [implementation base type only] +-- Present in all type entities. Indicates that some containing part +-- is either aliased or tagged. This prohibits packing the object +-- tighter than its natural size and alignment. + +-- String_Literal_Length (Uint16) +-- Present in string literal subtypes (which are created to correspond +-- to string literals in the program). Contains the length of the string +-- literal. + +-- String_Literal_Low_Bound (Node15) +-- Present in string literal subtypes (which are created to correspond +-- to string literals in the program). Contains an expression whose +-- value represents the low bound of the literal. This is a copy of +-- the low bound of the applicable index constraint if there is one, +-- or a copy of the low bound of the index base type if not. + +-- Subprograms_For_Type (Node29) +-- Present in all type entities, and in subprogram entities. This is used +-- to hold a list of subprogram entities for subprograms associated with +-- the type, linked through the Subprogram_List field of the subprogram +-- entity. Basically this is a way of multiplexing the single field to +-- hold more than one entity (since we ran out of space in some type +-- entities). This is currently used for Invariant_Procedure and also +-- for Predicate_Function, and clients will always use the latter two +-- names to access entries in this list. + +-- Suppress_Elaboration_Warnings (Flag148) +-- Present in all entities, can be set only for subprogram entities and +-- for variables. If this flag is set then Sem_Elab will not generate +-- elaboration warnings for the subprogram or variable. Suppression of +-- such warnings is automatic for subprograms for which elaboration +-- checks are suppressed (without the need to set this flag), but the +-- flag is also set for various internal entities (such as init procs) +-- which are known not to generate any possible access before +-- elaboration, and it is set on variables when a warning is given to +-- avoid multiple elaboration warnings for the same variable. + +-- Suppress_Init_Proc (Flag105) [base type only] +-- Present in all type entities. Set to suppress the generation of +-- initialization procedures where they are known to be not needed. +-- For example, the enumeration image table entity uses this flag. + +-- Suppress_Style_Checks (Flag165) +-- Present in all entities. Suppresses any style checks specifically +-- associated with the given entity if set. + +-- Suppress_Value_Tracking_On_Call (Flag217) +-- Present in all entities. Set in a scope entity if value tracking is to +-- be suppressed on any call within the scope. Used when an access to a +-- local subprogram is computed, to deal with the possibility that this +-- value may be passed around, and if used, may clobber a local variable. + +-- Task_Body_Procedure (Node25) +-- Present in task types and subtypes. Points to the entity for the task +-- task body procedure (as further described in Exp_Ch9, task bodies are +-- expanded into procedures). A convenient function to retrieve this +-- field is Sem_Util.Get_Task_Body_Procedure. +-- +-- The last sentence is odd??? Why not have Task_Body_Procedure go to the +-- Underlying_Type of the Root_Type??? + +-- Treat_As_Volatile (Flag41) +-- Present in all type entities, and also in constants, components and +-- variables. Set if this entity is to be treated as volatile for code +-- generation purposes. Always set if Is_Volatile is set, but can also +-- be set as a result of situations (such as address overlays) where +-- the front end wishes to force volatile handling to inhibit aliasing +-- optimization which might be legally ok, but is undesirable. Note +-- that the back end always tests this flag rather than Is_Volatile. +-- The front end tests Is_Volatile if it is concerned with legality +-- checks associated with declared volatile variables, but if the test +-- is for the purposes of suppressing optimizations, then the front +-- end should test Treat_As_Volatile rather than Is_Volatile. +-- +-- Note: before testing Treat_As_Volatile, consider whether it would +-- be more appropriate to use Exp_Util.Is_Volatile_Reference instead, +-- which catches more cases of volatile references. + +-- Type_High_Bound (synthesized) +-- Applies to scalar types. Returns the tree node (Node_Id) that contains +-- the high bound of a scalar type. The returned value is literal for a +-- base type, but may be an expression in the case of scalar type with +-- dynamic bounds. Note that in the case of a fixed point type, the high +-- bound is in units of small, and is an integer. + +-- Type_Low_Bound (synthesized) +-- Applies to scalar types. Returns the tree node (Node_Id) that contains +-- the low bound of a scalar type. The returned value is literal for a +-- base type, but may be an expression in the case of scalar type with +-- dynamic bounds. Note that in the case of a fixed point type, the low +-- bound is in units of small, and is an integer. + +-- Underlying_Full_View (Node19) +-- Present in private subtypes that are the completion of other private +-- types, or in private types that are derived from private subtypes. If +-- the full view of a private type T is derived from another private type +-- with discriminants Td, the full view of T is also private, and there +-- is no way to attach to it a further full view that would convey the +-- structure of T to the back end. The Underlying_Full_ View is an +-- attribute of the full view that is a subtype of Td with the same +-- constraint as the declaration for T. The declaration for this subtype +-- is built at the point of the declaration of T, either as completion, +-- or as a subtype declaration where the base type is private and has a +-- private completion. If Td is already constrained, then its full view +-- can serve directly as the full view of T. + +-- Underlying_Record_View (Node28) +-- Present in record types. Set for record types that are extensions of +-- types with unknown discriminants, and also set for internally built +-- underlying record views to reference its original record type. Record +-- types that are extensions of types with unknown discriminants do not +-- have a completion, but they cannot be used without having some +-- discriminated view at hand. This view is a record type with the same +-- structure, whose parent type is the full view of the parent in the +-- original type extension. + +-- Underlying_Type (synthesized) +-- Applies to all entities. This is the identity function except in the +-- case where it is applied to an incomplete or private type, in which +-- case it is the underlying type of the type declared by the completion, +-- or Empty if the completion has not yet been encountered and analyzed. +-- +-- Note: the reason this attribute applies to all entities, and not just +-- types, is to legitimize code where Underlying_Type is applied to an +-- entity which may or may not be a type, with the intent that if it is a +-- type, its underlying type is taken. + +-- Universal_Aliasing (Flag216) [base type only] +-- Present in all type entities. Set to direct the back-end to avoid +-- any optimizations based on type-based alias analysis for this type. +-- Indicates that objects of this type can alias objects of any other +-- types, which guarantees that any objects can be referenced through +-- access types designating this type safely, whatever the actual type +-- of these objects. In other words, the effect is as though access +-- types designating this type were subject to No_Strict_Aliasing. + +-- Unset_Reference (Node16) +-- Present in variables and out parameters. This is normally Empty. It +-- is set to point to an identifier that represents a reference to the +-- entity before any value has been set. Only the first such reference +-- is identified. This field is used to generate a warning message if +-- necessary (see Sem_Warn.Check_Unset_Reference). + +-- Used_As_Generic_Actual (Flag222) +-- Present in all entities, set if the entity is used as an argument to +-- a generic instantiation. Used to tune certain warning messages. + +-- Uses_Sec_Stack (Flag95) +-- Present in scope entities (blocks,functions, procedures, tasks, +-- entries). Set to True when secondary stack is used in this scope and +-- must be released on exit unless Sec_Stack_Needed_For_Return is set. + +-- Warnings_Off (Flag96) +-- Present in all entities. Set if a pragma Warnings (Off, entity-name) +-- is used to suppress warnings for a given entity. It is also used by +-- the compiler in some situations to kill spurious warnings. Note that +-- clients should generally not test this flag directly, but instead +-- use function Has_Warnings_Off. + +-- Warnings_Off_Used (Flag236) +-- Present in all entities. Can only be set if Warnings_Off is set. If +-- set indicates that a warning was suppressed by the Warnings_Off flag, +-- and Unmodified/Unreferenced would not have suppressed the warning. + +-- Warnings_Off_Used_Unmodified (Flag237) +-- Present in all entities. Can only be set if Warnings_Off is set and +-- Has_Pragma_Unmodified is not set. If set indicates that a warning was +-- suppressed by the Warnings_Off status but that pragma Unmodified +-- would also have suppressed the warning. + +-- Warnings_Off_Used_Unreferenced (Flag238) +-- Present in all entities. Can only be set if Warnings_Off is set and +-- Has_Pragma_Unreferenced is not set. If set indicates that a warning +-- was suppressed by the Warnings_Off status but that pragma Unreferenced +-- would also have suppressed the warning. + +-- Was_Hidden (Flag196) +-- Present in all entities. Used to save the value of the Is_Hidden +-- attribute when the limited-view is installed (Ada 2005: AI-217). + +-- Wrapped_Entity (Node27) +-- Present in functions and procedures which have been classified as +-- Is_Primitive_Wrapper. Set to the entity being wrapped. + + ------------------ + -- Access Kinds -- + ------------------ + + -- The following entity kinds are introduced by the corresponding type + -- definitions: + + -- E_Access_Type, + -- E_General_Access_Type, + -- E_Access_Subprogram_Type, + -- E_Anonymous_Access_Subprogram_Type, + -- E_Access_Protected_Subprogram_Type, + -- E_Anonymous_Access_Protected_Subprogram_Type + -- E_Anonymous_Access_Type. + + -- E_Access_Subtype is for an access subtype created by a subtype + -- declaration. + + -- In addition, we define the kind E_Allocator_Type to label allocators. + -- This is because special resolution rules apply to this construct. + -- Eventually the constructs are labeled with the access type imposed by + -- the context. Gigi should never see the type E_Allocator. + + -- Similarly, the type E_Access_Attribute_Type is used as the initial kind + -- associated with an access attribute. After resolution a specific access + -- type will be established as determined by the context. + + -- Finally, the type Any_Access is used to label -null- during type + -- resolution. Any_Access is also replaced by the context type after + -- resolution. + + -------------------------------- + -- Classification of Entities -- + -------------------------------- + + -- The classification of program entities which follows is a refinement of + -- the list given in RM 3.1(1). E.g., separate entities denote subtypes of + -- different type classes. Ada 95 entities include class wide types, + -- protected types, subprogram types, generalized access types, generic + -- formal derived types and generic formal packages. + + -- The order chosen for these kinds allows us to classify related entities + -- so that they are contiguous. As a result, they do not appear in the + -- exact same order as their order of first appearance in the LRM (For + -- example, private types are listed before packages). The contiguity + -- allows us to define useful subtypes (see below) such as type entities, + -- overloaded entities, etc. + + -- Each entity (explicitly or implicitly declared) has a kind, which is + -- a value of the following type: + + type Entity_Kind is ( + + E_Void, + -- The initial Ekind value for a newly created entity. Also used as the + -- Ekind for Standard_Void_Type, a type entity in Standard used as a + -- dummy type for the return type of a procedure (the reason we create + -- this type is to share the circuits for performing overload resolution + -- on calls). + + ------------- + -- Objects -- + ------------- + + E_Component, + -- Components of a record declaration, private declarations of + -- protected objects. + + E_Constant, + -- Constants created by an object declaration with a constant keyword + + E_Discriminant, + -- A discriminant, created by the use of a discriminant in a type + -- declaration. + + E_Loop_Parameter, + -- A loop parameter created by a for loop + + E_Variable, + -- Variables created by an object declaration with no constant keyword + + ------------------------ + -- Parameter Entities -- + ------------------------ + + -- Parameters are also objects + + E_Out_Parameter, + -- An out parameter of a subprogram or entry + + E_In_Out_Parameter, + -- An in-out parameter of a subprogram or entry + + E_In_Parameter, + -- An in parameter of a subprogram or entry + + -------------------------------- + -- Generic Parameter Entities -- + -------------------------------- + + -- Generic parameters are also objects + + E_Generic_In_Out_Parameter, + -- A generic in out parameter, created by the use of a generic in out + -- parameter in a generic declaration. + + E_Generic_In_Parameter, + -- A generic in parameter, created by the use of a generic in + -- parameter in a generic declaration. + + ------------------- + -- Named Numbers -- + ------------------- + + E_Named_Integer, + -- Named numbers created by a number declaration with an integer value + + E_Named_Real, + -- Named numbers created by a number declaration with a real value + + ----------------------- + -- Enumeration Types -- + ----------------------- + + E_Enumeration_Type, + -- Enumeration types, created by an enumeration type declaration + + E_Enumeration_Subtype, + -- Enumeration subtypes, created by an explicit or implicit subtype + -- declaration applied to an enumeration type or subtype. + + ------------------- + -- Numeric Types -- + ------------------- + + E_Signed_Integer_Type, + -- Signed integer type, used for the anonymous base type of the + -- integer subtype created by an integer type declaration. + + E_Signed_Integer_Subtype, + -- Signed integer subtype, created by either an integer subtype or + -- integer type declaration (in the latter case an integer type is + -- created for the base type, and this is the first named subtype). + + E_Modular_Integer_Type, + -- Modular integer type, used for the anonymous base type of the + -- integer subtype created by a modular integer type declaration. + + E_Modular_Integer_Subtype, + -- Modular integer subtype, created by either an modular subtype + -- or modular type declaration (in the latter case a modular type + -- is created for the base type, and this is the first named subtype). + + E_Ordinary_Fixed_Point_Type, + -- Ordinary fixed type, used for the anonymous base type of the + -- fixed subtype created by an ordinary fixed point type declaration. + + E_Ordinary_Fixed_Point_Subtype, + -- Ordinary fixed point subtype, created by either an ordinary fixed + -- point subtype or ordinary fixed point type declaration (in the + -- latter case a fixed point type is created for the base type, and + -- this is the first named subtype). + + E_Decimal_Fixed_Point_Type, + -- Decimal fixed type, used for the anonymous base type of the decimal + -- fixed subtype created by an ordinary fixed point type declaration. + + E_Decimal_Fixed_Point_Subtype, + -- Decimal fixed point subtype, created by either a decimal fixed point + -- subtype or decimal fixed point type declaration (in the latter case + -- a fixed point type is created for the base type, and this is the + -- first named subtype). + + E_Floating_Point_Type, + -- Floating point type, used for the anonymous base type of the + -- floating point subtype created by a floating point type declaration. + + E_Floating_Point_Subtype, + -- Floating point subtype, created by either a floating point subtype + -- or floating point type declaration (in the latter case a floating + -- point type is created for the base type, and this is the first + -- named subtype). + + ------------------ + -- Access Types -- + ------------------ + + E_Access_Type, + -- An access type created by an access type declaration with no all + -- keyword present. Note that the predefined type Any_Access, which + -- has E_Access_Type Ekind, is used to label NULL in the upwards pass + -- of type analysis, to be replaced by the true access type in the + -- downwards resolution pass. + + E_Access_Subtype, + -- An access subtype created by a subtype declaration for any access + -- type (whether or not it is a general access type). + + E_Access_Attribute_Type, + -- An access type created for an access attribute (such as 'Access, + -- 'Unrestricted_Access and Unchecked_Access) + + E_Allocator_Type, + -- A special internal type used to label allocators and attribute + -- references using 'Access. This is needed because special resolution + -- rules apply to these constructs. On the resolution pass, this type + -- is always replaced by the actual access type, so Gigi should never + -- see types with this Ekind. + + E_General_Access_Type, + -- An access type created by an access type declaration with the all + -- keyword present. + + E_Access_Subprogram_Type, + -- An access to subprogram type, created by an access to subprogram + -- declaration. + + E_Anonymous_Access_Subprogram_Type, + -- An anonymous access to subprogram type, created by an access to + -- subprogram declaration, or generated for a current instance of + -- a type name appearing within a component definition that has an + -- anonymous access to subprogram type. + + E_Access_Protected_Subprogram_Type, + -- An access to a protected subprogram, created by the corresponding + -- declaration. Values of such a type denote both a protected object + -- and a protected operation within, and have different compile-time + -- and run-time properties than other access to subprograms. + + E_Anonymous_Access_Protected_Subprogram_Type, + -- An anonymous access to protected subprogram type, created by an + -- access to subprogram declaration. + + E_Anonymous_Access_Type, + -- An anonymous access type created by an access parameter or access + -- discriminant. + + --------------------- + -- Composite Types -- + --------------------- + + E_Array_Type, + -- An array type created by an array type declaration. Includes all + -- cases of arrays, except for string types. + + E_Array_Subtype, + -- An array subtype, created by an explicit array subtype declaration, + -- or the use of an anonymous array subtype. + + E_String_Type, + -- A string type, i.e. an array type whose component type is a character + -- type, and for which string literals can thus be written. + + E_String_Subtype, + -- A string subtype, created by an explicit subtype declaration for a + -- string type, or the use of an anonymous subtype of a string type, + + E_String_Literal_Subtype, + -- A special string subtype, used only to describe the type of a string + -- literal (will always be one dimensional, with literal bounds). + + E_Class_Wide_Type, + -- A class wide type, created by any tagged type declaration (i.e. if + -- a tagged type is declared, the corresponding class type is always + -- created, using this Ekind value). + + E_Class_Wide_Subtype, + -- A subtype of a class wide type, created by a subtype declaration + -- used to declare a subtype of a class type. + + E_Record_Type, + -- A record type, created by a record type declaration + + E_Record_Subtype, + -- A record subtype, created by a record subtype declaration + + E_Record_Type_With_Private, + -- Used for types defined by a private extension declaration, and + -- for tagged private types. Includes the fields for both private + -- types and for record types (with the sole exception of + -- Corresponding_Concurrent_Type which is obviously not needed). + -- This entity is considered to be both a record type and + -- a private type. + + E_Record_Subtype_With_Private, + -- A subtype of a type defined by a private extension declaration + + E_Private_Type, + -- A private type, created by a private type declaration + -- that has neither the keyword limited nor the keyword tagged. + + E_Private_Subtype, + -- A subtype of a private type, created by a subtype declaration used + -- to declare a subtype of a private type. + + E_Limited_Private_Type, + -- A limited private type, created by a private type declaration that + -- has the keyword limited, but not the keyword tagged. + + E_Limited_Private_Subtype, + -- A subtype of a limited private type, created by a subtype declaration + -- used to declare a subtype of a limited private type. + + E_Incomplete_Type, + -- An incomplete type, created by an incomplete type declaration + + E_Incomplete_Subtype, + -- An incomplete subtype, created by a subtype declaration where the + -- subtype mark denotes an incomplete type. + + E_Task_Type, + -- A task type, created by a task type declaration. An entity with this + -- Ekind is also created to describe the anonymous type of a task that + -- is created by a single task declaration. + + E_Task_Subtype, + -- A subtype of a task type, created by a subtype declaration used to + -- declare a subtype of a task type. + + E_Protected_Type, + -- A protected type, created by a protected type declaration. An entity + -- with this Ekind is also created to describe the anonymous type of + -- a protected object created by a single protected declaration. + + E_Protected_Subtype, + -- A subtype of a protected type, created by a subtype declaration used + -- to declare a subtype of a protected type. + + ----------------- + -- Other Types -- + ----------------- + + E_Exception_Type, + -- The type of an exception created by an exception declaration + + E_Subprogram_Type, + -- This is the designated type of an Access_To_Subprogram. Has type + -- and signature like a subprogram entity, so can appear in calls, + -- which are resolved like regular calls, except that such an entity + -- is not overloadable. + + --------------------------- + -- Overloadable Entities -- + --------------------------- + + E_Enumeration_Literal, + -- An enumeration literal, created by the use of the literal in an + -- enumeration type definition. + + E_Function, + -- A function, created by a function declaration or a function body + -- that acts as its own declaration. + + E_Operator, + -- A predefined operator, appearing in Standard, or an implicitly + -- defined concatenation operator created whenever an array is + -- declared. We do not make normal derived operators explicit in + -- the tree, but the concatenation operators are made explicit. + + E_Procedure, + -- A procedure, created by a procedure declaration or a procedure + -- body that acts as its own declaration. + + E_Entry, + -- An entry, created by an entry declaration in a task or protected + -- object. + + -------------------- + -- Other Entities -- + -------------------- + + E_Entry_Family, + -- An entry family, created by an entry family declaration in a + -- task or protected type definition. + + E_Block, + -- A block identifier, created by an explicit or implicit label on + -- a block or declare statement. + + E_Entry_Index_Parameter, + -- An entry index parameter created by an entry index specification + -- for the body of a protected entry family. + + E_Exception, + -- An exception created by an exception declaration. The exception + -- itself uses E_Exception for the Ekind, the implicit type that is + -- created to represent its type uses the Ekind E_Exception_Type. + + E_Generic_Function, + -- A generic function. This is the entity for a generic function + -- created by a generic subprogram declaration. + + E_Generic_Procedure, + -- A generic function. This is the entity for a generic procedure + -- created by a generic subprogram declaration. + + E_Generic_Package, + -- A generic package, this is the entity for a generic package created + -- by a generic package declaration. + + E_Label, + -- The defining entity for a label. Note that this is created by the + -- implicit label declaration, not the occurrence of the label itself, + -- which is simply a direct name referring to the label. + + E_Loop, + -- A loop identifier, created by an explicit or implicit label on a + -- loop statement. + + E_Return_Statement, + -- A dummy entity created for each return statement. Used to hold + -- information about the return statement (what it applies to) and in + -- rules checking. For example, a simple_return_statement that applies + -- to an extended_return_statement cannot have an expression; this + -- requires putting the E_Return_Statement entity for the + -- extended_return_statement on the scope stack. + + E_Package, + -- A package, created by a package declaration + + E_Package_Body, + -- A package body. This entity serves only limited functions, since + -- most semantic analysis uses the package entity (E_Package). However + -- there are some attributes that are significant for the body entity. + -- For example, collection of exception handlers. + + E_Protected_Object, + -- A protected object, created by an object declaration that declares + -- an object of a protected type. + + E_Protected_Body, + -- A protected body. This entity serves almost no function, since all + -- semantic analysis uses the protected entity (E_Protected_Type) + + E_Task_Body, + -- A task body. This entity serves almost no function, since all + -- semantic analysis uses the protected entity (E_Task_Type). + + E_Subprogram_Body + -- A subprogram body. Used when a subprogram has a separate declaration + -- to represent the entity for the body. This entity serves almost no + -- function, since all semantic analysis uses the subprogram entity + -- for the declaration (E_Function or E_Procedure). + ); + + for Entity_Kind'Size use 8; + -- The data structures in Atree assume this! + + -------------------------- + -- Subtype Declarations -- + -------------------------- + + -- The above entities are arranged so that they can be conveniently grouped + -- into subtype ranges. Note that for each of the xxx_Kind ranges defined + -- below, there is a corresponding Is_xxx (or for types, Is_xxx_Type) + -- predicate which is to be used in preference to direct range tests using + -- the subtype name. However, the subtype names are available for direct + -- use, e.g. as choices in case statements. + + subtype Access_Kind is Entity_Kind range + E_Access_Type .. + -- E_Access_Subtype + -- E_Access_Attribute_Type + -- E_Allocator_Type + -- E_General_Access_Type + -- E_Access_Subprogram_Type + -- E_Anonymous_Access_Subprogram_Type + -- E_Access_Protected_Subprogram_Type + -- E_Anonymous_Access_Protected_Subprogram_Type + E_Anonymous_Access_Type; + + subtype Access_Subprogram_Kind is Entity_Kind range + E_Access_Subprogram_Type .. + -- E_Anonymous_Access_Subprogram_Type + -- E_Access_Protected_Subprogram_Type + E_Anonymous_Access_Protected_Subprogram_Type; + + subtype Access_Protected_Kind is Entity_Kind range + E_Access_Protected_Subprogram_Type .. + E_Anonymous_Access_Protected_Subprogram_Type; + + subtype Aggregate_Kind is Entity_Kind range + E_Array_Type .. + -- E_Array_Subtype + -- E_String_Type + -- E_String_Subtype + -- E_String_Literal_Subtype + -- E_Class_Wide_Type + -- E_Class_Wide_Subtype + -- E_Record_Type + E_Record_Subtype; + + subtype Array_Kind is Entity_Kind range + E_Array_Type .. + -- E_Array_Subtype + -- E_String_Type + -- E_String_Subtype + E_String_Literal_Subtype; + + subtype Assignable_Kind is Entity_Kind range + E_Variable .. + -- E_Out_Parameter + E_In_Out_Parameter; + + subtype Class_Wide_Kind is Entity_Kind range + E_Class_Wide_Type .. + E_Class_Wide_Subtype; + + subtype Composite_Kind is Entity_Kind range + E_Array_Type .. + -- E_Array_Subtype + -- E_String_Type + -- E_String_Subtype + -- E_String_Literal_Subtype + -- E_Class_Wide_Type + -- E_Class_Wide_Subtype + -- E_Record_Type + -- E_Record_Subtype + -- E_Record_Type_With_Private + -- E_Record_Subtype_With_Private + -- E_Private_Type + -- E_Private_Subtype + -- E_Limited_Private_Type + -- E_Limited_Private_Subtype + -- E_Incomplete_Type + -- E_Incomplete_Subtype + -- E_Task_Type + -- E_Task_Subtype, + -- E_Protected_Type, + E_Protected_Subtype; + + subtype Concurrent_Kind is Entity_Kind range + E_Task_Type .. + -- E_Task_Subtype, + -- E_Protected_Type, + E_Protected_Subtype; + + subtype Concurrent_Body_Kind is Entity_Kind range + E_Protected_Body .. + E_Task_Body; + + subtype Decimal_Fixed_Point_Kind is Entity_Kind range + E_Decimal_Fixed_Point_Type .. + E_Decimal_Fixed_Point_Subtype; + + subtype Digits_Kind is Entity_Kind range + E_Decimal_Fixed_Point_Type .. + -- E_Decimal_Fixed_Point_Subtype + -- E_Floating_Point_Type + E_Floating_Point_Subtype; + + subtype Discrete_Kind is Entity_Kind range + E_Enumeration_Type .. + -- E_Enumeration_Subtype + -- E_Signed_Integer_Type + -- E_Signed_Integer_Subtype + -- E_Modular_Integer_Type + E_Modular_Integer_Subtype; + + subtype Discrete_Or_Fixed_Point_Kind is Entity_Kind range + E_Enumeration_Type .. + -- E_Enumeration_Subtype + -- E_Signed_Integer_Type + -- E_Signed_Integer_Subtype + -- E_Modular_Integer_Type + -- E_Modular_Integer_Subtype + -- E_Ordinary_Fixed_Point_Type + -- E_Ordinary_Fixed_Point_Subtype + -- E_Decimal_Fixed_Point_Type + E_Decimal_Fixed_Point_Subtype; + + subtype Elementary_Kind is Entity_Kind range + E_Enumeration_Type .. + -- E_Enumeration_Subtype + -- E_Signed_Integer_Type + -- E_Signed_Integer_Subtype + -- E_Modular_Integer_Type + -- E_Modular_Integer_Subtype + -- E_Ordinary_Fixed_Point_Type + -- E_Ordinary_Fixed_Point_Subtype + -- E_Decimal_Fixed_Point_Type + -- E_Decimal_Fixed_Point_Subtype + -- E_Floating_Point_Type + -- E_Floating_Point_Subtype + -- E_Access_Type + -- E_Access_Subtype + -- E_Access_Attribute_Type + -- E_Allocator_Type + -- E_General_Access_Type + -- E_Access_Subprogram_Type + -- E_Access_Protected_Subprogram_Type + -- E_Anonymous_Access_Subprogram_Type + -- E_Anonymous_Access_Protected_Subprogram_Type + E_Anonymous_Access_Type; + + subtype Enumeration_Kind is Entity_Kind range + E_Enumeration_Type .. + E_Enumeration_Subtype; + + subtype Entry_Kind is Entity_Kind range + E_Entry .. + E_Entry_Family; + + subtype Fixed_Point_Kind is Entity_Kind range + E_Ordinary_Fixed_Point_Type .. + -- E_Ordinary_Fixed_Point_Subtype + -- E_Decimal_Fixed_Point_Type + E_Decimal_Fixed_Point_Subtype; + + subtype Float_Kind is Entity_Kind range + E_Floating_Point_Type .. + E_Floating_Point_Subtype; + + subtype Formal_Kind is Entity_Kind range + E_Out_Parameter .. + -- E_In_Out_Parameter + E_In_Parameter; + + subtype Formal_Object_Kind is Entity_Kind range + E_Generic_In_Out_Parameter .. + E_Generic_In_Parameter; + + subtype Generic_Subprogram_Kind is Entity_Kind range + E_Generic_Function .. + E_Generic_Procedure; + + subtype Generic_Unit_Kind is Entity_Kind range + E_Generic_Function .. + -- E_Generic_Procedure + E_Generic_Package; + + subtype Incomplete_Kind is Entity_Kind range + E_Incomplete_Type .. + E_Incomplete_Subtype; + + subtype Incomplete_Or_Private_Kind is Entity_Kind range + E_Record_Type_With_Private .. + -- E_Record_Subtype_With_Private + -- E_Private_Type + -- E_Private_Subtype + -- E_Limited_Private_Type + -- E_Limited_Private_Subtype + -- E_Incomplete_Type + E_Incomplete_Subtype; + + subtype Integer_Kind is Entity_Kind range + E_Signed_Integer_Type .. + -- E_Signed_Integer_Subtype + -- E_Modular_Integer_Type + E_Modular_Integer_Subtype; + + subtype Modular_Integer_Kind is Entity_Kind range + E_Modular_Integer_Type .. + E_Modular_Integer_Subtype; + + subtype Named_Kind is Entity_Kind range + E_Named_Integer .. + E_Named_Real; + + subtype Numeric_Kind is Entity_Kind range + E_Signed_Integer_Type .. + -- E_Signed_Integer_Subtype + -- E_Modular_Integer_Type + -- E_Modular_Integer_Subtype + -- E_Ordinary_Fixed_Point_Type + -- E_Ordinary_Fixed_Point_Subtype + -- E_Decimal_Fixed_Point_Type + -- E_Decimal_Fixed_Point_Subtype + -- E_Floating_Point_Type + E_Floating_Point_Subtype; + + subtype Object_Kind is Entity_Kind range + E_Component .. + -- E_Constant + -- E_Discriminant + -- E_Loop_Parameter + -- E_Variable + -- E_Out_Parameter + -- E_In_Out_Parameter + -- E_In_Parameter + -- E_Generic_In_Out_Parameter + E_Generic_In_Parameter; + + subtype Ordinary_Fixed_Point_Kind is Entity_Kind range + E_Ordinary_Fixed_Point_Type .. + E_Ordinary_Fixed_Point_Subtype; + + subtype Overloadable_Kind is Entity_Kind range + E_Enumeration_Literal .. + -- E_Function + -- E_Operator + -- E_Procedure + E_Entry; + + subtype Private_Kind is Entity_Kind range + E_Record_Type_With_Private .. + -- E_Record_Subtype_With_Private + -- E_Private_Type + -- E_Private_Subtype + -- E_Limited_Private_Type + E_Limited_Private_Subtype; + + subtype Protected_Kind is Entity_Kind range + E_Protected_Type .. + E_Protected_Subtype; + + subtype Real_Kind is Entity_Kind range + E_Ordinary_Fixed_Point_Type .. + -- E_Ordinary_Fixed_Point_Subtype + -- E_Decimal_Fixed_Point_Type + -- E_Decimal_Fixed_Point_Subtype + -- E_Floating_Point_Type + E_Floating_Point_Subtype; + + subtype Record_Kind is Entity_Kind range + E_Class_Wide_Type .. + -- E_Class_Wide_Subtype + -- E_Record_Type + -- E_Record_Subtype + -- E_Record_Type_With_Private + E_Record_Subtype_With_Private; + + subtype Scalar_Kind is Entity_Kind range + E_Enumeration_Type .. + -- E_Enumeration_Subtype + -- E_Signed_Integer_Type + -- E_Signed_Integer_Subtype + -- E_Modular_Integer_Type + -- E_Modular_Integer_Subtype + -- E_Ordinary_Fixed_Point_Type + -- E_Ordinary_Fixed_Point_Subtype + -- E_Decimal_Fixed_Point_Type + -- E_Decimal_Fixed_Point_Subtype + -- E_Floating_Point_Type + E_Floating_Point_Subtype; + + subtype String_Kind is Entity_Kind range + E_String_Type .. + -- E_String_Subtype + E_String_Literal_Subtype; + + subtype Subprogram_Kind is Entity_Kind range + E_Function .. + -- E_Operator + E_Procedure; + + subtype Signed_Integer_Kind is Entity_Kind range + E_Signed_Integer_Type .. + E_Signed_Integer_Subtype; + + subtype Task_Kind is Entity_Kind range + E_Task_Type .. + E_Task_Subtype; + + subtype Type_Kind is Entity_Kind range + E_Enumeration_Type .. + -- E_Enumeration_Subtype + -- E_Signed_Integer_Type + -- E_Signed_Integer_Subtype + -- E_Modular_Integer_Type + -- E_Modular_Integer_Subtype + -- E_Ordinary_Fixed_Point_Type + -- E_Ordinary_Fixed_Point_Subtype + -- E_Decimal_Fixed_Point_Type + -- E_Decimal_Fixed_Point_Subtype + -- E_Floating_Point_Type + -- E_Floating_Point_Subtype + -- E_Access_Type + -- E_Access_Subtype + -- E_Access_Attribute_Type + -- E_Allocator_Type, + -- E_General_Access_Type + -- E_Access_Subprogram_Type, + -- E_Access_Protected_Subprogram_Type + -- E_Anonymous_Access_Subprogram_Type + -- E_Anonymous_Access_Protected_Subprogram_Type + -- E_Anonymous_Access_Type + -- E_Array_Type + -- E_Array_Subtype + -- E_String_Type + -- E_String_Subtype + -- E_String_Literal_Subtype + -- E_Class_Wide_Subtype + -- E_Class_Wide_Type + -- E_Record_Type + -- E_Record_Subtype + -- E_Record_Type_With_Private + -- E_Record_Subtype_With_Private + -- E_Private_Type + -- E_Private_Subtype + -- E_Limited_Private_Type + -- E_Limited_Private_Subtype + -- E_Incomplete_Type + -- E_Incomplete_Subtype + -- E_Task_Type + -- E_Task_Subtype + -- E_Protected_Type + -- E_Protected_Subtype + -- E_Exception_Type + E_Subprogram_Type; + + -------------------------------------------------------- + -- Description of Defined Attributes for Entity_Kinds -- + -------------------------------------------------------- + + -- For each enumeration value defined in Entity_Kind we list all the + -- attributes defined in Einfo which can legally be applied to an entity + -- of that kind. The implementation of the attribute functions (and for + -- non-synthesized attributes, of the corresponding set procedures) are + -- in the Einfo body. + + -- The following attributes apply to all entities + + -- Ekind (Ekind) + + -- Chars (Name1) + -- Next_Entity (Node2) + -- Scope (Node3) + -- Homonym (Node4) + -- Etype (Node5) + -- First_Rep_Item (Node6) + -- Freeze_Node (Node7) + + -- Address_Taken (Flag104) + -- Can_Never_Be_Null (Flag38) + -- Checks_May_Be_Suppressed (Flag31) + -- Debug_Info_Off (Flag166) + -- Has_Anon_Block_Suffix (Flag201) + -- Has_Controlled_Component (Flag43) (base type only) + -- Has_Convention_Pragma (Flag119) + -- Has_Delayed_Aspects (Flag200) + -- Has_Delayed_Freeze (Flag18) + -- Has_Fully_Qualified_Name (Flag173) + -- Has_Gigi_Rep_Item (Flag82) + -- Has_Homonym (Flag56) + -- Has_Persistent_BSS (Flag188) + -- Has_Pragma_Elaborate_Body (Flag150) + -- Has_Pragma_Inline (Flag157) + -- Has_Pragma_Inline_Always (Flag230) + -- Has_Pragma_Pack (Flag121) (base type only) + -- Has_Pragma_Pure (Flag203) + -- Has_Pragma_Pure_Function (Flag179) + -- Has_Pragma_Thread_Local_Storage (Flag169) + -- Has_Pragma_Unmodified (Flag233) + -- Has_Pragma_Unreferenced (Flag180) + -- Has_Predicates (Flag250) + -- Has_Private_Declaration (Flag155) + -- Has_Qualified_Name (Flag161) + -- Has_Stream_Size_Clause (Flag184) + -- Has_Unknown_Discriminants (Flag72) + -- Has_Xref_Entry (Flag182) + -- In_Private_Part (Flag45) + -- Is_Ada_2005_Only (Flag185) + -- Is_Ada_2012_Only (Flag199) + -- Is_Bit_Packed_Array (Flag122) (base type only) + -- Is_Character_Type (Flag63) + -- Is_Child_Unit (Flag73) + -- Is_Compilation_Unit (Flag149) + -- Is_Completely_Hidden (Flag103) + -- Is_Discrim_SO_Function (Flag176) + -- Is_Dispatch_Table_Entity (Flag234) + -- Is_Dispatching_Operation (Flag6) + -- Is_Entry_Formal (Flag52) + -- Is_Exported (Flag99) + -- Is_First_Subtype (Flag70) + -- Is_Formal_Subprogram (Flag111) + -- Is_Generic_Instance (Flag130) + -- Is_Generic_Type (Flag13) + -- Is_Hidden (Flag57) + -- Is_Hidden_Open_Scope (Flag171) + -- Is_Immediately_Visible (Flag7) + -- Is_Imported (Flag24) + -- Is_Inlined (Flag11) + -- Is_Internal (Flag17) + -- Is_Itype (Flag91) + -- Is_Known_Non_Null (Flag37) + -- Is_Known_Null (Flag204) + -- Is_Known_Valid (Flag170) + -- Is_Limited_Composite (Flag106) + -- Is_Limited_Record (Flag25) + -- Is_Obsolescent (Flag153) + -- Is_Package_Body_Entity (Flag160) + -- Is_Packed_Array_Type (Flag138) + -- Is_Potentially_Use_Visible (Flag9) + -- Is_Preelaborated (Flag59) + -- Is_Primitive_Wrapper (Flag195) + -- Is_Public (Flag10) + -- Is_Pure (Flag44) + -- Is_Remote_Call_Interface (Flag62) + -- Is_Remote_Types (Flag61) + -- Is_Renaming_Of_Object (Flag112) + -- Is_Shared_Passive (Flag60) + -- Is_Statically_Allocated (Flag28) + -- Is_Tagged_Type (Flag55) + -- Is_Trivial_Subprogram (Flag235) + -- Is_Unchecked_Union (Flag117) + -- Is_Visible_Formal (Flag206) + -- Is_VMS_Exception (Flag133) + -- Kill_Elaboration_Checks (Flag32) + -- Kill_Range_Checks (Flag33) + -- Kill_Tag_Checks (Flag34) + -- Low_Bound_Tested (Flag205) + -- Materialize_Entity (Flag168) + -- Needs_Debug_Info (Flag147) + -- Never_Set_In_Source (Flag115) + -- No_Return (Flag113) + -- Overlays_Constant (Flag243) + -- Referenced (Flag156) + -- Referenced_As_LHS (Flag36) + -- Referenced_As_Out_Parameter (Flag227) + -- Suppress_Elaboration_Warnings (Flag148) + -- Suppress_Style_Checks (Flag165) + -- Suppress_Value_Tracking_On_Call (Flag217) + -- Used_As_Generic_Actual (Flag222) + -- Warnings_Off (Flag96) + -- Warnings_Off_Used (Flag236) + -- Warnings_Off_Used_Unmodified (Flag237) + -- Warnings_Off_Used_Unreferenced (Flag238) + -- Was_Hidden (Flag196) + + -- Declaration_Node (synth) + -- Has_Foreign_Convention (synth) + -- Is_Dynamic_Scope (synth) + -- Is_Standard_Character_Type (synth) + -- Underlying_Type (synth) + -- all classification attributes (synth) + + -- The following list of access functions applies to all entities for + -- types and subtypes. References to this list appear subsequently as + -- as "(plus type attributes)" for each appropriate Entity_Kind. + + -- Associated_Node_For_Itype (Node8) + -- Class_Wide_Type (Node9) + -- Full_View (Node11) + -- Esize (Uint12) + -- RM_Size (Uint13) + -- Alignment (Uint14) + -- Related_Expression (Node24) + -- Current_Use_Clause (Node27) + -- Subprograms_For_Type (Node29) + + -- Depends_On_Private (Flag14) + -- Discard_Names (Flag88) + -- Finalize_Storage_Only (Flag158) (base type only) + -- From_With_Type (Flag159) + -- Has_Aliased_Components (Flag135) (base type only) + -- Has_Alignment_Clause (Flag46) + -- Has_Atomic_Components (Flag86) (base type only) + -- Has_Completion_In_Body (Flag71) + -- Has_Complex_Representation (Flag140) (base type only) + -- Has_Constrained_Partial_View (Flag187) + -- Has_Discriminants (Flag5) + -- Has_Inheritable_Invariants (Flag248) + -- Has_Invariants (Flag232) + -- Has_Non_Standard_Rep (Flag75) (base type only) + -- Has_Object_Size_Clause (Flag172) + -- Has_Pragma_Preelab_Init (Flag221) + -- Has_Pragma_Unreferenced_Objects (Flag212) + -- Has_Primitive_Operations (Flag120) (base type only) + -- Has_Size_Clause (Flag29) + -- Has_Specified_Layout (Flag100) (base type only) + -- Has_Specified_Stream_Input (Flag190) + -- Has_Specified_Stream_Output (Flag191) + -- Has_Specified_Stream_Read (Flag192) + -- Has_Specified_Stream_Write (Flag193) + -- Has_Task (Flag30) (base type only) + -- Has_Unchecked_Union (Flag123) (base type only) + -- Has_Volatile_Components (Flag87) (base type only) + -- In_Use (Flag8) + -- Is_Abstract_Type (Flag146) + -- Is_Asynchronous (Flag81) + -- Is_Atomic (Flag85) + -- Is_Constr_Subt_For_U_Nominal (Flag80) + -- Is_Constr_Subt_For_UN_Aliased (Flag141) + -- Is_Controlled (Flag42) (base type only) + -- Is_Eliminated (Flag124) + -- Is_Frozen (Flag4) + -- Is_Generic_Actual_Type (Flag94) + -- Is_RACW_Stub_Type (Flag244) + -- Is_Non_Static_Subtype (Flag109) + -- Is_Packed (Flag51) (base type only) + -- Is_Private_Composite (Flag107) + -- Is_Unsigned_Type (Flag144) + -- Is_Volatile (Flag16) + -- Itype_Printed (Flag202) (itypes only) + -- Known_To_Have_Preelab_Init (Flag207) + -- Must_Be_On_Byte_Boundary (Flag183) + -- Must_Have_Preelab_Init (Flag208) + -- Optimize_Alignment_Space (Flag241) + -- Optimize_Alignment_Time (Flag242) + -- Size_Depends_On_Discriminant (Flag177) + -- Size_Known_At_Compile_Time (Flag92) + -- Strict_Alignment (Flag145) (base type only) + -- Suppress_Init_Proc (Flag105) (base type only) + -- Treat_As_Volatile (Flag41) + -- Universal_Aliasing (Flag216) (base type only) + + -- Alignment_Clause (synth) + -- Base_Type (synth) + -- Has_Private_Ancestor (synth) + -- Implementation_Base_Type (synth) + -- Invariant_Procedure (synth) + -- Is_Access_Protected_Subprogram_Type (synth) + -- Predicate_Function (synth) + -- Root_Type (synth) + -- Size_Clause (synth) + + ------------------------------------------ + -- Applicable attributes by entity kind -- + ------------------------------------------ + + -- E_Access_Protected_Subprogram_Type + -- Equivalent_Type (Node18) + -- Directly_Designated_Type (Node20) + -- Needs_No_Actuals (Flag22) + -- Can_Use_Internal_Rep (Flag229) + -- (plus type attributes) + + -- E_Access_Subprogram_Type + -- Equivalent_Type (Node18) (remote types only) + -- Directly_Designated_Type (Node20) + -- Needs_No_Actuals (Flag22) + -- Can_Use_Internal_Rep (Flag229) + -- (plus type attributes) + + -- E_Access_Type + -- E_Access_Subtype + -- Storage_Size_Variable (Node15) (base type only) + -- Master_Id (Node17) + -- Directly_Designated_Type (Node20) + -- Associated_Storage_Pool (Node22) (root type only) + -- Associated_Final_Chain (Node23) + -- Has_Pragma_Controlled (Flag27) (base type only) + -- Has_Storage_Size_Clause (Flag23) (base type only) + -- Is_Access_Constant (Flag69) + -- Is_Local_Anonymous_Access (Flag194) + -- Is_Pure_Unit_Access_Type (Flag189) + -- No_Pool_Assigned (Flag131) (base type only) + -- No_Strict_Aliasing (Flag136) (base type only) + -- (plus type attributes) + + -- E_Access_Attribute_Type + -- Directly_Designated_Type (Node20) + -- (plus type attributes) + + -- E_Allocator_Type + -- Directly_Designated_Type (Node20) + -- (plus type attributes) + + -- E_Anonymous_Access_Subprogram_Type + -- E_Anonymous_Access_Protected_Subprogram_Type + -- Storage_Size_Variable (Node15) ??? is this needed ??? + -- Directly_Designated_Type (Node20) + -- Can_Use_Internal_Rep (Flag229) + -- (plus type attributes) + + -- E_Anonymous_Access_Type + -- Storage_Size_Variable (Node15) ??? is this needed ??? + -- Directly_Designated_Type (Node20) + -- (plus type attributes) + + -- E_Array_Type + -- E_Array_Subtype + -- First_Index (Node17) + -- Related_Array_Object (Node19) + -- Component_Type (Node20) (base type only) + -- Original_Array_Type (Node21) + -- Component_Size (Uint22) (base type only) + -- Packed_Array_Type (Node23) + -- Component_Alignment (special) (base type only) + -- Has_Component_Size_Clause (Flag68) (base type only) + -- Is_Aliased (Flag15) + -- Is_Constrained (Flag12) + -- Next_Index (synth) + -- Number_Dimensions (synth) + -- (plus type attributes) + + -- E_Block + -- Block_Node (Node11) + -- First_Entity (Node17) + -- Last_Entity (Node20) + -- Finalization_Chain_Entity (Node19) + -- Scope_Depth_Value (Uint22) + -- Entry_Cancel_Parameter (Node23) + -- Delay_Cleanups (Flag114) + -- Discard_Names (Flag88) + -- Has_Master_Entity (Flag21) + -- Has_Nested_Block_With_Handler (Flag101) + -- Sec_Stack_Needed_For_Return (Flag167) + -- Uses_Sec_Stack (Flag95) + -- Scope_Depth (synth) + + -- E_Class_Wide_Type + -- E_Class_Wide_Subtype + -- Direct_Primitive_Operations (Elist10) + -- Cloned_Subtype (Node16) (subtype case only) + -- First_Entity (Node17) + -- Equivalent_Type (Node18) (always Empty for type) + -- Last_Entity (Node20) + -- First_Component (synth) + -- First_Component_Or_Discriminant (synth) + -- (plus type attributes) + + -- E_Component + -- Normalized_First_Bit (Uint8) + -- Current_Value (Node9) (always Empty) + -- Normalized_Position_Max (Uint10) + -- Component_Bit_Offset (Uint11) + -- Esize (Uint12) + -- Component_Clause (Node13) + -- Normalized_Position (Uint14) + -- DT_Entry_Count (Uint15) + -- Entry_Formal (Node16) + -- Prival (Node17) + -- Renamed_Object (Node18) (always Empty) + -- Discriminant_Checking_Func (Node20) + -- Interface_Name (Node21) (JGNAT usage only) + -- Original_Record_Component (Node22) + -- DT_Offset_To_Top_Func (Node25) + -- Related_Type (Node27) + -- Has_Biased_Representation (Flag139) + -- Has_Per_Object_Constraint (Flag154) + -- Is_Atomic (Flag85) + -- Is_Tag (Flag78) + -- Is_Volatile (Flag16) + -- Treat_As_Volatile (Flag41) + -- Is_Return_Object (Flag209) + -- Next_Component (synth) + -- Next_Component_Or_Discriminant (synth) + + -- E_Constant + -- E_Loop_Parameter + -- Current_Value (Node9) (always Empty) + -- Discriminal_Link (Node10) (discriminals only) + -- Full_View (Node11) + -- Esize (Uint12) + -- Alignment (Uint14) + -- Actual_Subtype (Node17) + -- Renamed_Object (Node18) + -- Size_Check_Code (Node19) (constants only) + -- Prival_Link (Node20) (privals only) + -- Interface_Name (Node21) + -- Related_Type (Node27) (constants only) + -- Has_Alignment_Clause (Flag46) + -- Has_Atomic_Components (Flag86) + -- Has_Biased_Representation (Flag139) + -- Has_Completion (Flag26) (constants only) + -- Has_Thunks (Flag228) (constants only) + -- Has_Size_Clause (Flag29) + -- Has_Up_Level_Access (Flag215) + -- Has_Volatile_Components (Flag87) + -- Is_Atomic (Flag85) + -- Is_Eliminated (Flag124) + -- Is_Return_Object (Flag209) + -- Is_True_Constant (Flag163) + -- Is_Volatile (Flag16) + -- Optimize_Alignment_Space (Flag241) (constants only) + -- Optimize_Alignment_Time (Flag242) (constants only) + -- Treat_As_Volatile (Flag41) + -- Address_Clause (synth) + -- Alignment_Clause (synth) + -- Size_Clause (synth) + + -- E_Decimal_Fixed_Point_Type + -- E_Decimal_Fixed_Subtype + -- Scale_Value (Uint15) + -- Digits_Value (Uint17) + -- Scalar_Range (Node20) + -- Delta_Value (Ureal18) + -- Small_Value (Ureal21) + -- Has_Machine_Radix_Clause (Flag83) + -- Machine_Radix_10 (Flag84) + -- Aft_Value (synth) + -- Type_Low_Bound (synth) + -- Type_High_Bound (synth) + -- (plus type attributes) + + -- E_Discriminant + -- Normalized_First_Bit (Uint8) + -- Current_Value (Node9) (always Empty) + -- Normalized_Position_Max (Uint10) + -- Component_Bit_Offset (Uint11) + -- Esize (Uint12) + -- Component_Clause (Node13) + -- Normalized_Position (Uint14) + -- Discriminant_Number (Uint15) + -- Discriminal (Node17) + -- Renamed_Object (Node18) (always Empty) + -- Corresponding_Discriminant (Node19) + -- Discriminant_Default_Value (Node20) + -- Interface_Name (Node21) (JGNAT usage only) + -- Original_Record_Component (Node22) + -- CR_Discriminant (Node23) + -- Is_Return_Object (Flag209) + -- Next_Component_Or_Discriminant (synth) + -- Next_Discriminant (synth) + -- Next_Stored_Discriminant (synth) + + -- E_Entry + -- E_Entry_Family + -- Protected_Body_Subprogram (Node11) + -- Barrier_Function (Node12) + -- Entry_Parameters_Type (Node15) + -- First_Entity (Node17) + -- Alias (Node18) (for entry only. Empty) + -- Finalization_Chain_Entity (Node19) + -- Last_Entity (Node20) + -- Accept_Address (Elist21) + -- Scope_Depth_Value (Uint22) + -- Protection_Object (Node23) (protected kind) + -- Spec_PPC_List (Node24) (for entry only) + -- PPC_Wrapper (Node25) + -- Default_Expressions_Processed (Flag108) + -- Entry_Accepted (Flag152) + -- Is_AST_Entry (Flag132) (for entry only) + -- Needs_No_Actuals (Flag22) + -- Sec_Stack_Needed_For_Return (Flag167) + -- Uses_Sec_Stack (Flag95) + -- Address_Clause (synth) + -- Entry_Index_Type (synth) + -- First_Formal (synth) + -- First_Formal_With_Extras (synth) + -- Last_Formal (synth) + -- Number_Formals (synth) + -- Scope_Depth (synth) + + -- E_Entry_Index_Parameter + -- Entry_Index_Constant (Node18) + + -- E_Enumeration_Literal + -- Enumeration_Pos (Uint11) + -- Enumeration_Rep (Uint12) + -- Alias (Node18) + -- Enumeration_Rep_Expr (Node22) + -- Next_Literal (synth) + + -- E_Enumeration_Type + -- E_Enumeration_Subtype + -- Lit_Indexes (Node15) (root type only) + -- Lit_Strings (Node16) (root type only) + -- First_Literal (Node17) + -- Scalar_Range (Node20) + -- Enum_Pos_To_Rep (Node23) (type only) + -- Static_Predicate (List25) + -- Has_Biased_Representation (Flag139) + -- Has_Contiguous_Rep (Flag181) + -- Has_Enumeration_Rep_Clause (Flag66) + -- Has_Pragma_Ordered (Flag198) (base type only) + -- Nonzero_Is_True (Flag162) (base type only) + -- Type_Low_Bound (synth) + -- Type_High_Bound (synth) + -- (plus type attributes) + + -- E_Exception + -- Esize (Uint12) + -- Alignment (Uint14) + -- Renamed_Entity (Node18) + -- Register_Exception_Call (Node20) + -- Interface_Name (Node21) + -- Exception_Code (Uint22) + -- Discard_Names (Flag88) + -- Is_VMS_Exception (Flag133) + -- Is_Raised (Flag224) + + -- E_Exception_Type + -- Equivalent_Type (Node18) + -- (plus type attributes) + + -- E_Floating_Point_Type + -- E_Floating_Point_Subtype + -- Digits_Value (Uint17) + -- Float_Rep (Uint10) (Float_Rep_Kind) + -- Machine_Emax_Value (synth) + -- Machine_Emin_Value (synth) + -- Machine_Mantissa_Value (synth) + -- Machine_Radix_Value (synth) + -- Model_Emin_Value (synth) + -- Model_Epsilon_Value (synth) + -- Model_Mantissa_Value (synth) + -- Model_Small_Value (synth) + -- Safe_Emax_Value (synth) + -- Safe_First_Value (synth) + -- Safe_Last_Value (synth) + -- Scalar_Range (Node20) + -- Type_Low_Bound (synth) + -- Type_High_Bound (synth) + -- Vax_Float (synth) + -- (plus type attributes) + + -- E_Function + -- E_Generic_Function + -- Mechanism (Uint8) (Mechanism_Type) + -- Renaming_Map (Uint9) + -- Handler_Records (List10) (non-generic case only) + -- Protected_Body_Subprogram (Node11) + -- Next_Inlined_Subprogram (Node12) + -- Corresponding_Equality (Node13) (implicit /= only) + -- Elaboration_Entity (Node13) (all other cases) + -- First_Optional_Parameter (Node14) (non-generic case only) + -- DT_Position (Uint15) + -- DTC_Entity (Node16) + -- First_Entity (Node17) + -- Alias (Node18) (non-generic case only) + -- Renamed_Entity (Node18) (generic case only) + -- Finalization_Chain_Entity (Node19) + -- Last_Entity (Node20) + -- Interface_Name (Node21) + -- Scope_Depth_Value (Uint22) + -- Generic_Renamings (Elist23) (for an instance) + -- Inner_Instances (Elist23) (generic case only) + -- Protection_Object (Node23) (for concurrent kind) + -- Spec_PPC_List (Node24) + -- Interface_Alias (Node25) + -- Overridden_Operation (Node26) + -- Wrapped_Entity (Node27) (non-generic case only) + -- Extra_Formals (Node28) + -- Subprograms_For_Type (Node29) + -- Body_Needed_For_SAL (Flag40) + -- Elaboration_Entity_Required (Flag174) + -- Default_Expressions_Processed (Flag108) + -- Delay_Cleanups (Flag114) + -- Delay_Subprogram_Descriptors (Flag50) + -- Discard_Names (Flag88) + -- Has_Completion (Flag26) + -- Has_Controlling_Result (Flag98) + -- Has_Invariants (Flag232) + -- Has_Master_Entity (Flag21) + -- Has_Missing_Return (Flag142) + -- Has_Nested_Block_With_Handler (Flag101) + -- Has_Postconditions (Flag240) + -- Has_Recursive_Call (Flag143) + -- Has_Subprogram_Descriptor (Flag93) + -- Is_Abstract_Subprogram (Flag19) (non-generic case only) + -- Is_Called (Flag102) (non-generic case only) + -- Is_Constructor (Flag76) + -- Is_Discrim_SO_Function (Flag176) + -- Is_Eliminated (Flag124) + -- Is_Instantiated (Flag126) (generic case only) + -- Is_Intrinsic_Subprogram (Flag64) + -- Is_Machine_Code_Subprogram (Flag137) (non-generic case only) + -- Is_Primitive (Flag218) + -- Is_Primitive_Wrapper (Flag195) (non-generic case only) + -- Is_Private_Descendant (Flag53) + -- Is_Private_Primitive (Flag245) (non-generic case only) + -- Is_Pure (Flag44) + -- Is_Thunk (Flag225) + -- Is_Visible_Child_Unit (Flag116) + -- Needs_No_Actuals (Flag22) + -- Requires_Overriding (Flag213) (non-generic case only) + -- Return_Present (Flag54) + -- Returns_By_Ref (Flag90) + -- Sec_Stack_Needed_For_Return (Flag167) + -- Uses_Sec_Stack (Flag95) + -- Address_Clause (synth) + -- First_Formal (synth) + -- First_Formal_With_Extras (synth) + -- Last_Formal (synth) + -- Number_Formals (synth) + -- Scope_Depth (synth) + + -- E_General_Access_Type + -- Storage_Size_Variable (Node15) (base type only) + -- Master_Id (Node17) + -- Directly_Designated_Type (Node20) + -- Associated_Storage_Pool (Node22) (root type only) + -- Associated_Final_Chain (Node23) + -- (plus type attributes) + + -- E_Generic_In_Parameter + -- E_Generic_In_Out_Parameter + -- Current_Value (Node9) (always Empty) + -- Entry_Component (Node11) + -- Actual_Subtype (Node17) + -- Renamed_Object (Node18) (always Empty) + -- Default_Value (Node20) + -- Protected_Formal (Node22) + -- Is_Controlling_Formal (Flag97) + -- Is_Return_Object (Flag209) + -- Parameter_Mode (synth) + + -- E_Incomplete_Type + -- E_Incomplete_Subtype + -- Direct_Primitive_Operations (Elist10) + -- Non_Limited_View (Node17) + -- Private_Dependents (Elist18) + -- Discriminant_Constraint (Elist21) + -- Stored_Constraint (Elist23) + -- (plus type attributes) + + -- E_In_Parameter + -- E_In_Out_Parameter + -- E_Out_Parameter + -- Mechanism (Uint8) (Mechanism_Type) + -- Current_Value (Node9) + -- Discriminal_Link (Node10) (discriminals only) + -- Entry_Component (Node11) + -- Esize (Uint12) + -- Extra_Accessibility (Node13) + -- Alignment (Uint14) + -- Extra_Formal (Node15) + -- Unset_Reference (Node16) + -- Actual_Subtype (Node17) + -- Renamed_Object (Node18) + -- Spec_Entity (Node19) + -- Default_Value (Node20) + -- Default_Expr_Function (Node21) + -- Protected_Formal (Node22) + -- Extra_Constrained (Node23) + -- Last_Assignment (Node26) (OUT, IN-OUT only) + -- Has_Initial_Value (Flag219) + -- Is_Controlling_Formal (Flag97) + -- Is_Only_Out_Parameter (Flag226) + -- Is_Optional_Parameter (Flag134) + -- Low_Bound_Tested (Flag205) + -- Is_Return_Object (Flag209) + -- Parameter_Mode (synth) + + -- E_Label + -- Enclosing_Scope (Node18) + -- Reachable (Flag49) + + -- E_Limited_Private_Type + -- E_Limited_Private_Subtype + -- First_Entity (Node17) + -- Private_Dependents (Elist18) + -- Underlying_Full_View (Node19) + -- Last_Entity (Node20) + -- Discriminant_Constraint (Elist21) + -- Private_View (Node22) + -- Stored_Constraint (Elist23) + -- Has_Completion (Flag26) + -- (plus type attributes) + + -- E_Loop + -- First_Exit_Statement (Node8) + -- Has_Exit (Flag47) + -- Has_Master_Entity (Flag21) + -- Has_Nested_Block_With_Handler (Flag101) + + -- E_Modular_Integer_Type + -- E_Modular_Integer_Subtype + -- Modulus (Uint17) (base type only) + -- Original_Array_Type (Node21) + -- Scalar_Range (Node20) + -- Static_Predicate (List25) + -- Non_Binary_Modulus (Flag58) (base type only) + -- Has_Biased_Representation (Flag139) + -- Type_Low_Bound (synth) + -- Type_High_Bound (synth) + -- (plus type attributes) + + -- E_Named_Integer + + -- E_Named_Real + + -- E_Operator + -- First_Entity (Node17) + -- Alias (Node18) + -- Last_Entity (Node20) + -- Overridden_Operation (Node26) + -- Subprograms_For_Type (Node29) + -- Has_Invariants (Flag232) + -- Has_Postconditions (Flag240) + -- Is_Machine_Code_Subprogram (Flag137) + -- Is_Pure (Flag44) + -- Is_Intrinsic_Subprogram (Flag64) + -- Is_Primitive (Flag218) + -- Is_Thunk (Flag225) + -- Default_Expressions_Processed (Flag108) + -- Aren't there more flags and fields? seems like this list should be + -- more similar to the E_Function list, which is much longer ??? + + -- E_Ordinary_Fixed_Point_Type + -- E_Ordinary_Fixed_Point_Subtype + -- Delta_Value (Ureal18) + -- Scalar_Range (Node20) + -- Small_Value (Ureal21) + -- Has_Small_Clause (Flag67) + -- Aft_Value (synth) + -- Type_Low_Bound (synth) + -- Type_High_Bound (synth) + -- (plus type attributes) + + -- E_Package + -- E_Generic_Package + -- Dependent_Instances (Elist8) (for an instance) + -- Renaming_Map (Uint9) + -- Handler_Records (List10) (non-generic case only) + -- Generic_Homonym (Node11) (generic case only) + -- Associated_Formal_Package (Node12) + -- Elaboration_Entity (Node13) + -- Shadow_Entities (List14) + -- Related_Instance (Node15) (non-generic case only) + -- First_Private_Entity (Node16) + -- First_Entity (Node17) + -- Renamed_Entity (Node18) + -- Body_Entity (Node19) + -- Last_Entity (Node20) + -- Interface_Name (Node21) + -- Scope_Depth_Value (Uint22) + -- Generic_Renamings (Elist23) (for an instance) + -- Inner_Instances (Elist23) (generic case only) + -- Limited_View (Node23) (non-generic/instance) + -- Current_Use_Clause (Node27) + -- Package_Instantiation (Node26) + -- Delay_Subprogram_Descriptors (Flag50) + -- Body_Needed_For_SAL (Flag40) + -- Discard_Names (Flag88) + -- Elaboration_Entity_Required (Flag174) + -- Elaborate_Body_Desirable (Flag210) (non-generic case only) + -- From_With_Type (Flag159) + -- Has_All_Calls_Remote (Flag79) + -- Has_Completion (Flag26) + -- Has_Forward_Instantiation (Flag175) + -- Has_Master_Entity (Flag21) + -- Has_RACW (Flag214) (non-generic case only) + -- Has_Subprogram_Descriptor (Flag93) + -- In_Package_Body (Flag48) + -- In_Use (Flag8) + -- Is_Instantiated (Flag126) + -- Is_Private_Descendant (Flag53) + -- Is_Visible_Child_Unit (Flag116) + -- Is_Wrapper_Package (synth) (non-generic case only) + -- Renamed_In_Spec (Flag231) (non-generic case only) + -- Scope_Depth (synth) + -- Static_Elaboration_Desired (Flag77) (non-generic case only) + + -- E_Package_Body + -- Handler_Records (List10) (non-generic case only) + -- Related_Instance (Node15) (non-generic case only) + -- First_Entity (Node17) + -- Spec_Entity (Node19) + -- Last_Entity (Node20) + -- Scope_Depth_Value (Uint22) + -- Scope_Depth (synth) + -- Delay_Subprogram_Descriptors (Flag50) + -- Has_Subprogram_Descriptor (Flag93) + + -- E_Private_Type + -- E_Private_Subtype + -- Direct_Primitive_Operations (Elist10) + -- First_Entity (Node17) + -- Private_Dependents (Elist18) + -- Underlying_Full_View (Node19) + -- Last_Entity (Node20) + -- Discriminant_Constraint (Elist21) + -- Private_View (Node22) + -- Stored_Constraint (Elist23) + -- Has_Completion (Flag26) + -- Is_Controlled (Flag42) (base type only) + -- Is_For_Access_Subtype (Flag118) (subtype only) + -- (plus type attributes) + + -- E_Procedure + -- E_Generic_Procedure + -- Postcondition_Proc (Node8) (non-generic case only) + -- Renaming_Map (Uint9) + -- Handler_Records (List10) (non-generic case only) + -- Protected_Body_Subprogram (Node11) + -- Next_Inlined_Subprogram (Node12) + -- Elaboration_Entity (Node13) + -- First_Optional_Parameter (Node14) (non-generic case only) + -- DT_Position (Uint15) + -- DTC_Entity (Node16) + -- First_Entity (Node17) + -- Alias (Node18) (non-generic case only) + -- Renamed_Entity (Node18) (generic case only) + -- Finalization_Chain_Entity (Node19) + -- Last_Entity (Node20) + -- Interface_Name (Node21) + -- Scope_Depth_Value (Uint22) + -- Generic_Renamings (Elist23) (for an instance) + -- Inner_Instances (Elist23) (generic case only) + -- Protection_Object (Node23) (for concurrent kind) + -- Spec_PPC_List (Node24) + -- Interface_Alias (Node25) + -- Static_Initialization (Node26) (init_proc only) + -- Overridden_Operation (Node26) (never for init proc) + -- Wrapped_Entity (Node27) (non-generic case only) + -- Extra_Formals (Node28) + -- Body_Needed_For_SAL (Flag40) + -- Delay_Cleanups (Flag114) + -- Discard_Names (Flag88) + -- Elaboration_Entity_Required (Flag174) + -- Default_Expressions_Processed (Flag108) + -- Delay_Cleanups (Flag114) + -- Delay_Subprogram_Descriptors (Flag50) + -- Discard_Names (Flag88) + -- Has_Completion (Flag26) + -- Has_Invariants (Flag232) + -- Has_Master_Entity (Flag21) + -- Has_Nested_Block_With_Handler (Flag101) + -- Has_Postconditions (Flag240) + -- Has_Subprogram_Descriptor (Flag93) + -- Is_Abstract_Subprogram (Flag19) (non-generic case only) + -- Is_Asynchronous (Flag81) + -- Is_Called (Flag102) (non-generic case only) + -- Is_Constructor (Flag76) + -- Is_Eliminated (Flag124) + -- Is_Instantiated (Flag126) (generic case only) + -- Is_Interrupt_Handler (Flag89) + -- Is_Intrinsic_Subprogram (Flag64) + -- Is_Machine_Code_Subprogram (Flag137) (non-generic case only) + -- Is_Null_Init_Proc (Flag178) + -- Is_Primitive (Flag218) + -- Is_Primitive_Wrapper (Flag195) (non-generic case only) + -- Is_Private_Descendant (Flag53) + -- Is_Private_Primitive (Flag245) (non-generic case only) + -- Is_Pure (Flag44) + -- Is_Thunk (Flag225) + -- Is_Valued_Procedure (Flag127) + -- Is_Visible_Child_Unit (Flag116) + -- Needs_No_Actuals (Flag22) + -- No_Return (Flag113) + -- Requires_Overriding (Flag213) (non-generic case only) + -- Sec_Stack_Needed_For_Return (Flag167) + -- Address_Clause (synth) + -- First_Formal (synth) + -- First_Formal_With_Extras (synth) + -- Last_Formal (synth) + -- Number_Formals (synth) + + -- E_Protected_Body + -- (any others??? First/Last Entity, Scope_Depth???) + + -- E_Protected_Object + + -- E_Protected_Type + -- E_Protected_Subtype + -- Direct_Primitive_Operations (Elist10) + -- Entry_Bodies_Array (Node15) + -- First_Private_Entity (Node16) + -- First_Entity (Node17) + -- Corresponding_Record_Type (Node18) + -- Finalization_Chain_Entity (Node19) + -- Last_Entity (Node20) + -- Discriminant_Constraint (Elist21) + -- Scope_Depth_Value (Uint22) + -- Scope_Depth (synth) + -- Stored_Constraint (Elist23) + -- Has_Interrupt_Handler (synth) + -- Sec_Stack_Needed_For_Return (Flag167) ??? + -- Uses_Sec_Stack (Flag95) ??? + -- Has_Entries (synth) + -- Number_Entries (synth) + + -- E_Record_Type + -- E_Record_Subtype + -- Direct_Primitive_Operations (Elist10) + -- Access_Disp_Table (Elist16) (base type only) + -- Cloned_Subtype (Node16) (subtype case only) + -- First_Entity (Node17) + -- Corresponding_Concurrent_Type (Node18) + -- Parent_Subtype (Node19) (base type only) + -- Last_Entity (Node20) + -- Discriminant_Constraint (Elist21) + -- Corresponding_Remote_Type (Node22) + -- Stored_Constraint (Elist23) + -- Interfaces (Elist25) + -- Dispatch_Table_Wrappers (Elist26) (base type only) + -- Underlying_Record_View (Node28) (base type only) + -- Component_Alignment (special) (base type only) + -- C_Pass_By_Copy (Flag125) (base type only) + -- Has_Dispatch_Table (Flag220) (base tagged type only) + -- Has_External_Tag_Rep_Clause (Flag110) + -- Has_Record_Rep_Clause (Flag65) (base type only) + -- Has_Static_Discriminants (Flag211) (subtype only) + -- Is_Class_Wide_Equivalent_Type (Flag35) + -- Is_Concurrent_Record_Type (Flag20) + -- Is_Constrained (Flag12) + -- Is_Controlled (Flag42) (base type only) + -- Is_Interface (Flag186) + -- Is_Limited_Interface (Flag197) + -- OK_To_Reorder_Components (Flag239) (base type only) + -- Reverse_Bit_Order (Flag164) (base type only) + -- First_Component (synth) + -- First_Component_Or_Discriminant (synth) + -- (plus type attributes) + + -- E_Record_Type_With_Private + -- E_Record_Subtype_With_Private + -- Direct_Primitive_Operations (Elist10) + -- Access_Disp_Table (Elist16) (base type only) + -- First_Entity (Node17) + -- Private_Dependents (Elist18) + -- Underlying_Full_View (Node19) + -- Last_Entity (Node20) + -- Discriminant_Constraint (Elist21) + -- Private_View (Node22) + -- Stored_Constraint (Elist23) + -- Interfaces (Elist25) + -- Dispatch_Table_Wrappers (Elist26) (base type only) + -- Has_Completion (Flag26) + -- Has_Record_Rep_Clause (Flag65) (base type only) + -- Has_External_Tag_Rep_Clause (Flag110) + -- Is_Concurrent_Record_Type (Flag20) + -- Is_Constrained (Flag12) + -- Is_Controlled (Flag42) (base type only) + -- Is_Interface (Flag186) + -- Is_Limited_Interface (Flag197) + -- OK_To_Reorder_Components (Flag239) (base type only) + -- Reverse_Bit_Order (Flag164) (base type only) + -- First_Component (synth) + -- First_Component_Or_Discriminant (synth) + -- (plus type attributes) + + -- E_Return_Statement + -- Return_Applies_To (Node8) + -- Finalization_Chain_Entity (Node19) + + -- E_Signed_Integer_Type + -- E_Signed_Integer_Subtype + -- Scalar_Range (Node20) + -- Static_Predicate (List25) + -- Has_Biased_Representation (Flag139) + -- Type_Low_Bound (synth) + -- Type_High_Bound (synth) + -- (plus type attributes) + + -- E_String_Type + -- E_String_Subtype + -- First_Index (Node17) + -- Component_Type (Node20) (base type only) + -- Is_Constrained (Flag12) + -- Next_Index (synth) + -- Number_Dimensions (synth) + -- (plus type attributes) + + -- E_String_Literal_Subtype + -- String_Literal_Low_Bound (Node15) + -- String_Literal_Length (Uint16) + -- First_Index (Node17) (always Empty) + -- Packed_Array_Type (Node23) + -- (plus type attributes) + + -- E_Subprogram_Body + -- Mechanism (Uint8) + -- First_Entity (Node17) + -- Corresponding_Protected_Entry (Node18) + -- Last_Entity (Node20) + -- Scope_Depth_Value (Uint22) + -- Scope_Depth (synth) + + -- E_Subprogram_Type + -- Directly_Designated_Type (Node20) + -- First_Formal (synth) + -- First_Formal_With_Extras (synth) + -- Last_Formal (synth) + -- Number_Formals (synth) + -- (plus type attributes) + + -- E_Task_Body + -- (any others??? First/Last Entity, Scope_Depth???) + + -- E_Task_Type + -- E_Task_Subtype + -- Direct_Primitive_Operations (Elist10) + -- Storage_Size_Variable (Node15) (base type only) + -- First_Private_Entity (Node16) + -- First_Entity (Node17) + -- Corresponding_Record_Type (Node18) + -- Finalization_Chain_Entity (Node19) + -- Last_Entity (Node20) + -- Discriminant_Constraint (Elist21) + -- Scope_Depth_Value (Uint22) + -- Scope_Depth (synth) + -- Stored_Constraint (Elist23) + -- Task_Body_Procedure (Node25) + -- Delay_Cleanups (Flag114) + -- Has_Master_Entity (Flag21) + -- Has_Storage_Size_Clause (Flag23) (base type only) + -- Uses_Sec_Stack (Flag95) ??? + -- Sec_Stack_Needed_For_Return (Flag167) ??? + -- Has_Entries (synth) + -- Number_Entries (synth) + -- Relative_Deadline_Variable (Node26) (base type only) + -- (plus type attributes) + + -- E_Variable + -- Hiding_Loop_Variable (Node8) + -- Current_Value (Node9) + -- Esize (Uint12) + -- Extra_Accessibility (Node13) + -- Alignment (Uint14) + -- Unset_Reference (Node16) + -- Actual_Subtype (Node17) + -- Renamed_Object (Node18) + -- Size_Check_Code (Node19) + -- Prival_Link (Node20) + -- Interface_Name (Node21) + -- Shared_Var_Procs_Instance (Node22) + -- Extra_Constrained (Node23) + -- Related_Expression (Node24) + -- Debug_Renaming_Link (Node25) + -- Last_Assignment (Node26) + -- Related_Type (Node27) + -- Has_Alignment_Clause (Flag46) + -- Has_Atomic_Components (Flag86) + -- Has_Biased_Representation (Flag139) + -- Has_Initial_Value (Flag219) + -- Has_Size_Clause (Flag29) + -- Has_Up_Level_Access (Flag215) + -- Has_Volatile_Components (Flag87) + -- Is_Atomic (Flag85) + -- Is_Eliminated (Flag124) + -- Is_Shared_Passive (Flag60) + -- Is_True_Constant (Flag163) + -- Is_Volatile (Flag16) + -- Is_Return_Object (Flag209) + -- OK_To_Rename (Flag247) + -- Optimize_Alignment_Space (Flag241) + -- Optimize_Alignment_Time (Flag242) + -- Treat_As_Volatile (Flag41) + -- Address_Clause (synth) + -- Alignment_Clause (synth) + -- Size_Clause (synth) + + -- E_Void + -- Since E_Void is the initial Ekind value of an entity when it is first + -- created, one might expect that no attributes would be defined on such + -- an entity until its Ekind field is set. However, in practice, there + -- are many instances in which fields of an E_Void entity are set in the + -- code prior to setting the Ekind field. This is not well documented or + -- well controlled, and needs cleaning up later. Meanwhile, the access + -- procedures in the body of Einfo permit many, but not all, attributes + -- to be applied to an E_Void entity, precisely so that this kind of + -- pre-setting of attributes works. This is really a hole in the dynamic + -- type checking, since there is no assurance that the eventual Ekind + -- value will be appropriate for the attributes set, and the consequence + -- is that the dynamic type checking in the Einfo body is unnecessarily + -- weak. To be looked at systematically some time ??? + + --------------------------------- + -- Component_Alignment Control -- + --------------------------------- + + -- There are four types of alignment possible for array and record + -- types, and a field in the type entities contains a value of the + -- following type indicating which alignment choice applies. For full + -- details of the meaning of these alignment types, see description + -- of the Component_Alignment pragma + + type Component_Alignment_Kind is ( + Calign_Default, -- default alignment + Calign_Component_Size, -- natural alignment for component size + Calign_Component_Size_4, -- natural for size <= 4, 4 for size >= 4 + Calign_Storage_Unit); -- all components byte aligned + + ----------------------------------- + -- Floating Point Representation -- + ----------------------------------- + + type Float_Rep_Kind is ( + IEEE_Binary, -- IEEE 754p conform binary format + VAX_Native, -- VAX D, F, G or H format + AAMP); -- AAMP format + + --------------- + -- Iterators -- + --------------- + + -- In addition to attributes that are stored as plain data, other + -- attributes are procedural, and require some small amount of + -- computation. Of course, from the point of view of a user of this + -- package, the distinction is not visible (even the field information + -- provided below should be disregarded, as it is subject to change + -- without notice!). A number of attributes appear as lists: lists of + -- formals, lists of actuals, of discriminants, etc. For these, pairs + -- of functions are defined, which take the form: + + -- function First_Thing (E : Enclosing_Construct) return Thing; + -- function Next_Thing (T : Thing) return Thing; + + -- The end of iteration is always signaled by a value of Empty, so that + -- loops over these chains invariably have the form: + + -- This : Thing; + -- ... + -- This := First_Thing (E); + + -- while Present (This) loop + -- Do_Something_With (This); + -- ... + -- This := Next_Thing (This); + -- end loop; + + ----------------------------------- + -- Handling of Check Suppression -- + ----------------------------------- + + -- There are three ways that checks can be suppressed: + + -- 1. At the command line level + -- 2. At the scope level. + -- 3. At the entity level. + + -- See spec of Sem in sem.ads for details of the data structures used + -- to keep track of these various methods for suppressing checks. + + ------------------------------- + -- Handling of Discriminants -- + ------------------------------- + + -- During semantic processing, discriminants are separate entities which + -- reflect the semantic properties and allowed usage of discriminants in + -- the language. + + -- In the case of discriminants used as bounds, the references are handled + -- directly, since special processing is needed in any case. However, there + -- are two circumstances in which discriminants are referenced in a quite + -- general manner, like any other variables: + + -- In initialization expressions for records. Note that the expressions + -- used in Priority, Storage_Size, Task_Info and Relative_Deadline + -- pragmas are effectively in this category, since these pragmas are + -- converted to initialized record fields in the Corresponding_Record_ + -- Type. + + -- In task and protected bodies, where the discriminant values may be + -- referenced freely within these bodies. Discriminants can also appear + -- in bounds of entry families and in defaults of operations. + + -- In both these cases, the discriminants must be treated essentially as + -- objects. The following approach is used to simplify and minimize the + -- special processing that is required. + + -- When a record type with discriminants is analyzed, semantic processing + -- creates the entities for the discriminants. It also creates additional + -- sets of entities called discriminals, one for each of the discriminants, + -- and the Discriminal field of the discriminant entity points to this + -- additional entity, which is initially created as an uninitialized + -- (E_Void) entity. + + -- During expansion of expressions, any discriminant reference is replaced + -- by a reference to the corresponding discriminal. When the initialization + -- procedure for the record is created (there will always be one, since + -- discriminants are present, see Exp_Ch3 for further details), the + -- discriminals are used as the entities for the formal parameters of + -- this initialization procedure. The references to these discriminants + -- have already been replaced by references to these discriminals, which + -- are now the formal parameters corresponding to the required objects. + + -- In the case of a task or protected body, the semantics similarly creates + -- a set of discriminals for the discriminants of the task or protected + -- type. When the procedure is created for the task body, the parameter + -- passed in is a reference to the task value type, which contains the + -- required discriminant values. The expander creates a set of declarations + -- of the form: + + -- discr_nameD : constant discr_type renames _task.discr_name; + + -- where discr_nameD is the discriminal entity referenced by the task + -- discriminant, and _task is the task value passed in as the parameter. + -- Again, any references to discriminants in the task body have been + -- replaced by the discriminal reference, which is now an object that + -- contains the required value. + + -- This approach for tasks means that two sets of discriminals are needed + -- for a task type, one for the initialization procedure, and one for the + -- task body. This works out nicely, since the semantics allocates one set + -- for the task itself, and one set for the corresponding record. + + -- The one bit of trickiness arises in making sure that the right set of + -- discriminals is used at the right time. First the task definition is + -- processed. Any references to discriminants here are replaced by the + -- corresponding *task* discriminals (the record type doesn't even exist + -- yet, since it is constructed as part of the expansion of the task + -- declaration, which happens after the semantic processing of the task + -- definition). The discriminants to be used for the corresponding record + -- are created at the same time as the other discriminals, and held in the + -- CR_Discriminant field of the discriminant. A use of the discriminant in + -- a bound for an entry family is replaced with the CR_Discriminant because + -- it controls the bound of the entry queue array which is a component of + -- the corresponding record. + + -- Just before the record initialization routine is constructed, the + -- expander exchanges the task and record discriminals. This has two + -- effects. First the generation of the record initialization routine + -- uses the discriminals that are now on the record, which is the set + -- that used to be on the task, which is what we want. + + -- Second, a new set of (so far unused) discriminals is now on the task + -- discriminants, and it is this set that will be used for expanding the + -- task body, and also for the discriminal declarations at the start of + -- the task body. + + --------------------------------------------------- + -- Handling of private data in protected objects -- + --------------------------------------------------- + + -- Private components in protected types pose problems similar to those + -- of discriminants. Private data is visible and can be directly referenced + -- from protected bodies. However, when protected entries and subprograms + -- are expanded into corresponding bodies and barrier functions, private + -- components lose their original context and visibility. + + -- To remedy this side effect of expansion, private components are expanded + -- into renamings called "privals", by analogy with "discriminals". + + -- private_comp : comp_type renames _object.private_comp; + + -- Prival declarations are inserted during the analysis of subprogram and + -- entry bodies to ensure proper visibility for any subsequent expansion. + -- _Object is the formal parameter of the generated corresponding body or + -- a local renaming which denotes the protected object obtained from entry + -- parameter _O. Privals receive minimal decoration upon creation and are + -- categorized as either E_Variable for the general case or E_Constant when + -- they appear in functions. + + -- Along with the local declarations, each private component carries a + -- placeholder which references the prival entity in the current body. This + -- form of indirection is used to resolve name clashes of privals and other + -- locally visible entities such as parameters, local objects, entry family + -- indexes or identifiers used in the barrier condition. + + -- When analyzing the statements of a protected subprogram or entry, any + -- reference to a private component must resolve to the locally declared + -- prival through normal visibility. In case of name conflicts (the cases + -- above), the prival is marked as hidden and acts as a weakly declared + -- entity. As a result, the reference points to the correct entity. When a + -- private component is denoted by an expanded name (prot_type.comp for + -- example), the expansion mechanism uses the placeholder of the component + -- to correct the Entity and Etype of the reference. + + ------------------- + -- Type Synonyms -- + ------------------- + + -- The following type synonyms are used to tidy up the function and + -- procedure declarations that follow, and also to make it possible to meet + -- the requirement for the XEINFO utility that all function specs must fit + -- on a single source line. + + subtype B is Boolean; + subtype C is Component_Alignment_Kind; + subtype E is Entity_Id; + subtype F is Float_Rep_Kind; + subtype M is Mechanism_Type; + subtype N is Node_Id; + subtype U is Uint; + subtype R is Ureal; + subtype L is Elist_Id; + subtype S is List_Id; + + -------------------------------- + -- Attribute Access Functions -- + -------------------------------- + + -- All attributes are manipulated through a procedural interface. This + -- section contains the functions used to obtain attribute values which + -- correspond to values in fields or flags in the entity itself. + + function Accept_Address (Id : E) return L; + function Access_Disp_Table (Id : E) return L; + function Actual_Subtype (Id : E) return E; + function Address_Taken (Id : E) return B; + function Alias (Id : E) return E; + function Alignment (Id : E) return U; + function Associated_Final_Chain (Id : E) return E; + function Associated_Formal_Package (Id : E) return E; + function Associated_Node_For_Itype (Id : E) return N; + function Associated_Storage_Pool (Id : E) return E; + function Barrier_Function (Id : E) return N; + function Block_Node (Id : E) return N; + function Body_Entity (Id : E) return E; + function Body_Needed_For_SAL (Id : E) return B; + function CR_Discriminant (Id : E) return E; + function C_Pass_By_Copy (Id : E) return B; + function Can_Never_Be_Null (Id : E) return B; + function Checks_May_Be_Suppressed (Id : E) return B; + function Class_Wide_Type (Id : E) return E; + function Cloned_Subtype (Id : E) return E; + function Component_Alignment (Id : E) return C; + function Component_Clause (Id : E) return N; + function Component_Bit_Offset (Id : E) return U; + function Component_Size (Id : E) return U; + function Component_Type (Id : E) return E; + function Corresponding_Concurrent_Type (Id : E) return E; + function Corresponding_Discriminant (Id : E) return E; + function Corresponding_Equality (Id : E) return E; + function Corresponding_Protected_Entry (Id : E) return E; + function Corresponding_Record_Type (Id : E) return E; + function Corresponding_Remote_Type (Id : E) return E; + function Current_Use_Clause (Id : E) return E; + function Current_Value (Id : E) return N; + function Debug_Info_Off (Id : E) return B; + function Debug_Renaming_Link (Id : E) return E; + function Dispatch_Table_Wrappers (Id : E) return L; + function DTC_Entity (Id : E) return E; + function DT_Entry_Count (Id : E) return U; + function DT_Offset_To_Top_Func (Id : E) return E; + function DT_Position (Id : E) return U; + function Default_Expr_Function (Id : E) return E; + function Default_Expressions_Processed (Id : E) return B; + function Default_Value (Id : E) return N; + function Delay_Cleanups (Id : E) return B; + function Delay_Subprogram_Descriptors (Id : E) return B; + function Delta_Value (Id : E) return R; + function Dependent_Instances (Id : E) return L; + function Depends_On_Private (Id : E) return B; + function Digits_Value (Id : E) return U; + function Directly_Designated_Type (Id : E) return E; + function Discard_Names (Id : E) return B; + function Discriminal (Id : E) return E; + function Discriminal_Link (Id : E) return E; + function Discriminant_Checking_Func (Id : E) return E; + function Discriminant_Constraint (Id : E) return L; + function Discriminant_Default_Value (Id : E) return N; + function Discriminant_Number (Id : E) return U; + function Elaborate_Body_Desirable (Id : E) return B; + function Elaboration_Entity (Id : E) return E; + function Elaboration_Entity_Required (Id : E) return B; + function Enclosing_Scope (Id : E) return E; + function Entry_Accepted (Id : E) return B; + function Entry_Bodies_Array (Id : E) return E; + function Entry_Cancel_Parameter (Id : E) return E; + function Entry_Component (Id : E) return E; + function Entry_Formal (Id : E) return E; + function Entry_Index_Constant (Id : E) return E; + function Entry_Index_Type (Id : E) return E; + function Entry_Parameters_Type (Id : E) return E; + function Enum_Pos_To_Rep (Id : E) return E; + function Enumeration_Pos (Id : E) return U; + function Enumeration_Rep (Id : E) return U; + function Enumeration_Rep_Expr (Id : E) return N; + function Equivalent_Type (Id : E) return E; + function Esize (Id : E) return U; + function Exception_Code (Id : E) return U; + function Extra_Accessibility (Id : E) return E; + function Extra_Constrained (Id : E) return E; + function Extra_Formal (Id : E) return E; + function Extra_Formals (Id : E) return E; + function Can_Use_Internal_Rep (Id : E) return B; + function Finalization_Chain_Entity (Id : E) return E; + function Finalize_Storage_Only (Id : E) return B; + function First_Entity (Id : E) return E; + function First_Exit_Statement (Id : E) return N; + function First_Index (Id : E) return N; + function First_Literal (Id : E) return E; + function First_Optional_Parameter (Id : E) return E; + function First_Private_Entity (Id : E) return E; + function First_Rep_Item (Id : E) return N; + function Float_Rep (Id : E) return F; + function Freeze_Node (Id : E) return N; + function From_With_Type (Id : E) return B; + function Full_View (Id : E) return E; + function Generic_Homonym (Id : E) return E; + function Generic_Renamings (Id : E) return L; + function Handler_Records (Id : E) return S; + function Has_Aliased_Components (Id : E) return B; + function Has_Alignment_Clause (Id : E) return B; + function Has_All_Calls_Remote (Id : E) return B; + function Has_Anon_Block_Suffix (Id : E) return B; + function Has_Atomic_Components (Id : E) return B; + function Has_Biased_Representation (Id : E) return B; + function Has_Completion (Id : E) return B; + function Has_Completion_In_Body (Id : E) return B; + function Has_Complex_Representation (Id : E) return B; + function Has_Component_Size_Clause (Id : E) return B; + function Has_Constrained_Partial_View (Id : E) return B; + function Has_Contiguous_Rep (Id : E) return B; + function Has_Controlled_Component (Id : E) return B; + function Has_Controlling_Result (Id : E) return B; + function Has_Convention_Pragma (Id : E) return B; + function Has_Delayed_Aspects (Id : E) return B; + function Has_Delayed_Freeze (Id : E) return B; + function Has_Discriminants (Id : E) return B; + function Has_Dispatch_Table (Id : E) return B; + function Has_Enumeration_Rep_Clause (Id : E) return B; + function Has_Exit (Id : E) return B; + function Has_External_Tag_Rep_Clause (Id : E) return B; + function Has_Fully_Qualified_Name (Id : E) return B; + function Has_Gigi_Rep_Item (Id : E) return B; + function Has_Homonym (Id : E) return B; + function Has_Inheritable_Invariants (Id : E) return B; + function Has_Initial_Value (Id : E) return B; + function Has_Invariants (Id : E) return B; + function Has_Interrupt_Handler (Id : E) return B; + function Has_Machine_Radix_Clause (Id : E) return B; + function Has_Master_Entity (Id : E) return B; + function Has_Missing_Return (Id : E) return B; + function Has_Nested_Block_With_Handler (Id : E) return B; + function Has_Forward_Instantiation (Id : E) return B; + function Has_Up_Level_Access (Id : E) return B; + function Has_Non_Standard_Rep (Id : E) return B; + function Has_Object_Size_Clause (Id : E) return B; + function Has_Per_Object_Constraint (Id : E) return B; + function Has_Persistent_BSS (Id : E) return B; + function Has_Postconditions (Id : E) return B; + function Has_Pragma_Controlled (Id : E) return B; + function Has_Pragma_Elaborate_Body (Id : E) return B; + function Has_Pragma_Inline (Id : E) return B; + function Has_Pragma_Inline_Always (Id : E) return B; + function Has_Pragma_Ordered (Id : E) return B; + function Has_Pragma_Pack (Id : E) return B; + function Has_Pragma_Preelab_Init (Id : E) return B; + function Has_Pragma_Pure (Id : E) return B; + function Has_Pragma_Pure_Function (Id : E) return B; + function Has_Pragma_Thread_Local_Storage (Id : E) return B; + function Has_Pragma_Unmodified (Id : E) return B; + function Has_Pragma_Unreferenced (Id : E) return B; + function Has_Pragma_Unreferenced_Objects (Id : E) return B; + function Has_Predicates (Id : E) return B; + function Has_Primitive_Operations (Id : E) return B; + function Has_Qualified_Name (Id : E) return B; + function Has_RACW (Id : E) return B; + function Has_Record_Rep_Clause (Id : E) return B; + function Has_Recursive_Call (Id : E) return B; + function Has_Size_Clause (Id : E) return B; + function Has_Small_Clause (Id : E) return B; + function Has_Specified_Layout (Id : E) return B; + function Has_Specified_Stream_Input (Id : E) return B; + function Has_Specified_Stream_Output (Id : E) return B; + function Has_Specified_Stream_Read (Id : E) return B; + function Has_Specified_Stream_Write (Id : E) return B; + function Has_Static_Discriminants (Id : E) return B; + function Has_Storage_Size_Clause (Id : E) return B; + function Has_Stream_Size_Clause (Id : E) return B; + function Has_Subprogram_Descriptor (Id : E) return B; + function Has_Task (Id : E) return B; + function Has_Thunks (Id : E) return B; + function Has_Unchecked_Union (Id : E) return B; + function Has_Unknown_Discriminants (Id : E) return B; + function Has_Volatile_Components (Id : E) return B; + function Has_Xref_Entry (Id : E) return B; + function Hiding_Loop_Variable (Id : E) return E; + function Homonym (Id : E) return E; + function In_Package_Body (Id : E) return B; + function In_Private_Part (Id : E) return B; + function In_Use (Id : E) return B; + function Inner_Instances (Id : E) return L; + function Interface_Alias (Id : E) return E; + function Interfaces (Id : E) return L; + function Interface_Name (Id : E) return N; + function Is_AST_Entry (Id : E) return B; + function Is_Abstract_Subprogram (Id : E) return B; + function Is_Abstract_Type (Id : E) return B; + function Is_Access_Constant (Id : E) return B; + function Is_Ada_2005_Only (Id : E) return B; + function Is_Ada_2012_Only (Id : E) return B; + function Is_Aliased (Id : E) return B; + function Is_Asynchronous (Id : E) return B; + function Is_Atomic (Id : E) return B; + function Is_Bit_Packed_Array (Id : E) return B; + function Is_CPP_Class (Id : E) return B; + function Is_Called (Id : E) return B; + function Is_Character_Type (Id : E) return B; + function Is_Child_Unit (Id : E) return B; + function Is_Class_Wide_Equivalent_Type (Id : E) return B; + function Is_Compilation_Unit (Id : E) return B; + function Is_Completely_Hidden (Id : E) return B; + function Is_Constr_Subt_For_UN_Aliased (Id : E) return B; + function Is_Constr_Subt_For_U_Nominal (Id : E) return B; + function Is_Constrained (Id : E) return B; + function Is_Constructor (Id : E) return B; + function Is_Controlled (Id : E) return B; + function Is_Controlling_Formal (Id : E) return B; + function Is_Discrim_SO_Function (Id : E) return B; + function Is_Dispatch_Table_Entity (Id : E) return B; + function Is_Dispatching_Operation (Id : E) return B; + function Is_Eliminated (Id : E) return B; + function Is_Entry_Formal (Id : E) return B; + function Is_Exported (Id : E) return B; + function Is_First_Subtype (Id : E) return B; + function Is_For_Access_Subtype (Id : E) return B; + function Is_Frozen (Id : E) return B; + function Is_Generic_Instance (Id : E) return B; + function Is_Hidden (Id : E) return B; + function Is_Hidden_Open_Scope (Id : E) return B; + function Is_Immediately_Visible (Id : E) return B; + function Is_Imported (Id : E) return B; + function Is_Inlined (Id : E) return B; + function Is_Interface (Id : E) return B; + function Is_Instantiated (Id : E) return B; + function Is_Internal (Id : E) return B; + function Is_Interrupt_Handler (Id : E) return B; + function Is_Intrinsic_Subprogram (Id : E) return B; + function Is_Itype (Id : E) return B; + function Is_Known_Non_Null (Id : E) return B; + function Is_Known_Null (Id : E) return B; + function Is_Known_Valid (Id : E) return B; + function Is_Limited_Composite (Id : E) return B; + function Is_Limited_Interface (Id : E) return B; + function Is_Local_Anonymous_Access (Id : E) return B; + function Is_Machine_Code_Subprogram (Id : E) return B; + function Is_Non_Static_Subtype (Id : E) return B; + function Is_Null_Init_Proc (Id : E) return B; + function Is_Obsolescent (Id : E) return B; + function Is_Only_Out_Parameter (Id : E) return B; + function Is_Optional_Parameter (Id : E) return B; + function Is_Package_Body_Entity (Id : E) return B; + function Is_Packed (Id : E) return B; + function Is_Packed_Array_Type (Id : E) return B; + function Is_Potentially_Use_Visible (Id : E) return B; + function Is_Preelaborated (Id : E) return B; + function Is_Primitive (Id : E) return B; + function Is_Primitive_Wrapper (Id : E) return B; + function Is_Private_Composite (Id : E) return B; + function Is_Private_Descendant (Id : E) return B; + function Is_Private_Primitive (Id : E) return B; + function Is_Public (Id : E) return B; + function Is_Pure (Id : E) return B; + function Is_Pure_Unit_Access_Type (Id : E) return B; + function Is_RACW_Stub_Type (Id : E) return B; + function Is_Raised (Id : E) return B; + function Is_Remote_Call_Interface (Id : E) return B; + function Is_Remote_Types (Id : E) return B; + function Is_Renaming_Of_Object (Id : E) return B; + function Is_Return_Object (Id : E) return B; + function Is_Shared_Passive (Id : E) return B; + function Is_Statically_Allocated (Id : E) return B; + function Is_Tag (Id : E) return B; + function Is_Tagged_Type (Id : E) return B; + function Is_Thunk (Id : E) return B; + function Is_Trivial_Subprogram (Id : E) return B; + function Is_True_Constant (Id : E) return B; + function Is_Unchecked_Union (Id : E) return B; + function Is_Underlying_Record_View (Id : E) return B; + function Is_Unsigned_Type (Id : E) return B; + function Is_VMS_Exception (Id : E) return B; + function Is_Valued_Procedure (Id : E) return B; + function Is_Visible_Child_Unit (Id : E) return B; + function Is_Visible_Formal (Id : E) return B; + function Is_Volatile (Id : E) return B; + function Itype_Printed (Id : E) return B; + function Kill_Elaboration_Checks (Id : E) return B; + function Kill_Range_Checks (Id : E) return B; + function Kill_Tag_Checks (Id : E) return B; + function Known_To_Have_Preelab_Init (Id : E) return B; + function Last_Assignment (Id : E) return N; + function Last_Entity (Id : E) return E; + function Limited_View (Id : E) return E; + function Lit_Indexes (Id : E) return E; + function Lit_Strings (Id : E) return E; + function Low_Bound_Tested (Id : E) return B; + function Machine_Radix_10 (Id : E) return B; + function Master_Id (Id : E) return E; + function Materialize_Entity (Id : E) return B; + function Mechanism (Id : E) return M; + function Modulus (Id : E) return U; + function Must_Be_On_Byte_Boundary (Id : E) return B; + function Must_Have_Preelab_Init (Id : E) return B; + function Needs_Debug_Info (Id : E) return B; + function Needs_No_Actuals (Id : E) return B; + function Never_Set_In_Source (Id : E) return B; + function Next_Inlined_Subprogram (Id : E) return E; + function No_Pool_Assigned (Id : E) return B; + function No_Return (Id : E) return B; + function No_Strict_Aliasing (Id : E) return B; + function Non_Binary_Modulus (Id : E) return B; + function Non_Limited_View (Id : E) return E; + function Nonzero_Is_True (Id : E) return B; + function Normalized_First_Bit (Id : E) return U; + function Normalized_Position (Id : E) return U; + function Normalized_Position_Max (Id : E) return U; + function OK_To_Rename (Id : E) return B; + function OK_To_Reorder_Components (Id : E) return B; + function Optimize_Alignment_Space (Id : E) return B; + function Optimize_Alignment_Time (Id : E) return B; + function Original_Array_Type (Id : E) return E; + function Original_Record_Component (Id : E) return E; + function Overlays_Constant (Id : E) return B; + function Overridden_Operation (Id : E) return E; + function Package_Instantiation (Id : E) return N; + function Packed_Array_Type (Id : E) return E; + function Parent_Subtype (Id : E) return E; + function Postcondition_Proc (Id : E) return E; + function PPC_Wrapper (Id : E) return E; + function Direct_Primitive_Operations (Id : E) return L; + function Prival (Id : E) return E; + function Prival_Link (Id : E) return E; + function Private_Dependents (Id : E) return L; + function Private_View (Id : E) return N; + function Protected_Body_Subprogram (Id : E) return E; + function Protected_Formal (Id : E) return E; + function Protection_Object (Id : E) return E; + function RM_Size (Id : E) return U; + function Reachable (Id : E) return B; + function Referenced (Id : E) return B; + function Referenced_As_LHS (Id : E) return B; + function Referenced_As_Out_Parameter (Id : E) return B; + function Register_Exception_Call (Id : E) return N; + function Related_Array_Object (Id : E) return E; + function Related_Expression (Id : E) return N; + function Related_Instance (Id : E) return E; + function Related_Type (Id : E) return E; + function Relative_Deadline_Variable (Id : E) return E; + function Renamed_Entity (Id : E) return N; + function Renamed_In_Spec (Id : E) return B; + function Renamed_Object (Id : E) return N; + function Renaming_Map (Id : E) return U; + function Requires_Overriding (Id : E) return B; + function Return_Present (Id : E) return B; + function Return_Applies_To (Id : E) return N; + function Returns_By_Ref (Id : E) return B; + function Reverse_Bit_Order (Id : E) return B; + function Scalar_Range (Id : E) return N; + function Scale_Value (Id : E) return U; + function Scope_Depth_Value (Id : E) return U; + function Sec_Stack_Needed_For_Return (Id : E) return B; + function Shadow_Entities (Id : E) return S; + function Shared_Var_Procs_Instance (Id : E) return E; + function Size_Check_Code (Id : E) return N; + function Size_Known_At_Compile_Time (Id : E) return B; + function Size_Depends_On_Discriminant (Id : E) return B; + function Small_Value (Id : E) return R; + function Spec_Entity (Id : E) return E; + function Spec_PPC_List (Id : E) return N; + function Static_Predicate (Id : E) return S; + function Storage_Size_Variable (Id : E) return E; + function Static_Elaboration_Desired (Id : E) return B; + function Static_Initialization (Id : E) return N; + function Stored_Constraint (Id : E) return L; + function Strict_Alignment (Id : E) return B; + function String_Literal_Length (Id : E) return U; + function String_Literal_Low_Bound (Id : E) return N; + function Subprograms_For_Type (Id : E) return E; + function Suppress_Elaboration_Warnings (Id : E) return B; + function Suppress_Init_Proc (Id : E) return B; + function Suppress_Style_Checks (Id : E) return B; + function Suppress_Value_Tracking_On_Call (Id : E) return B; + function Task_Body_Procedure (Id : E) return N; + function Treat_As_Volatile (Id : E) return B; + function Underlying_Full_View (Id : E) return E; + function Underlying_Record_View (Id : E) return E; + function Universal_Aliasing (Id : E) return B; + function Unset_Reference (Id : E) return N; + function Used_As_Generic_Actual (Id : E) return B; + function Uses_Sec_Stack (Id : E) return B; + function Vax_Float (Id : E) return B; + function Warnings_Off (Id : E) return B; + function Warnings_Off_Used (Id : E) return B; + function Warnings_Off_Used_Unmodified (Id : E) return B; + function Warnings_Off_Used_Unreferenced (Id : E) return B; + function Was_Hidden (Id : E) return B; + function Wrapped_Entity (Id : E) return E; + + ------------------------------- + -- Classification Attributes -- + ------------------------------- + + -- These functions provide a convenient functional notation for testing + -- whether an Ekind value belongs to a specified kind, for example the + -- function Is_Elementary_Type tests if its argument is in Elementary_Kind. + -- In some cases, the test is of an entity attribute (e.g. in the case of + -- Is_Generic_Type where the Ekind does not provide the needed information) + + function Is_Access_Type (Id : E) return B; + function Is_Access_Protected_Subprogram_Type (Id : E) return B; + function Is_Access_Subprogram_Type (Id : E) return B; + function Is_Aggregate_Type (Id : E) return B; + function Is_Array_Type (Id : E) return B; + function Is_Assignable (Id : E) return B; + function Is_Class_Wide_Type (Id : E) return B; + function Is_Composite_Type (Id : E) return B; + function Is_Concurrent_Body (Id : E) return B; + function Is_Concurrent_Record_Type (Id : E) return B; + function Is_Concurrent_Type (Id : E) return B; + function Is_Decimal_Fixed_Point_Type (Id : E) return B; + function Is_Digits_Type (Id : E) return B; + function Is_Descendent_Of_Address (Id : E) return B; + function Is_Discrete_Or_Fixed_Point_Type (Id : E) return B; + function Is_Discrete_Type (Id : E) return B; + function Is_Elementary_Type (Id : E) return B; + function Is_Entry (Id : E) return B; + function Is_Enumeration_Type (Id : E) return B; + function Is_Fixed_Point_Type (Id : E) return B; + function Is_Floating_Point_Type (Id : E) return B; + function Is_Formal (Id : E) return B; + function Is_Formal_Object (Id : E) return B; + function Is_Formal_Subprogram (Id : E) return B; + function Is_Generic_Actual_Type (Id : E) return B; + function Is_Generic_Unit (Id : E) return B; + function Is_Generic_Type (Id : E) return B; + function Is_Generic_Subprogram (Id : E) return B; + function Is_Incomplete_Or_Private_Type (Id : E) return B; + function Is_Incomplete_Type (Id : E) return B; + function Is_Integer_Type (Id : E) return B; + function Is_Limited_Record (Id : E) return B; + function Is_Modular_Integer_Type (Id : E) return B; + function Is_Named_Number (Id : E) return B; + function Is_Numeric_Type (Id : E) return B; + function Is_Object (Id : E) return B; + function Is_Ordinary_Fixed_Point_Type (Id : E) return B; + function Is_Overloadable (Id : E) return B; + function Is_Private_Type (Id : E) return B; + function Is_Protected_Type (Id : E) return B; + function Is_Real_Type (Id : E) return B; + function Is_Record_Type (Id : E) return B; + function Is_Scalar_Type (Id : E) return B; + function Is_Signed_Integer_Type (Id : E) return B; + function Is_Subprogram (Id : E) return B; + function Is_Task_Type (Id : E) return B; + function Is_Type (Id : E) return B; + + ------------------------------------- + -- Synthesized Attribute Functions -- + ------------------------------------- + + -- The functions in this section synthesize attributes from the tree, + -- so they do not correspond to defined fields in the entity itself. + + function Address_Clause (Id : E) return N; + function Aft_Value (Id : E) return U; + function Alignment_Clause (Id : E) return N; + function Base_Type (Id : E) return E; + function Declaration_Node (Id : E) return N; + function Designated_Type (Id : E) return E; + function First_Component (Id : E) return E; + function First_Component_Or_Discriminant (Id : E) return E; + function First_Formal (Id : E) return E; + function First_Formal_With_Extras (Id : E) return E; + function Has_Attach_Handler (Id : E) return B; + function Has_Entries (Id : E) return B; + function Has_Foreign_Convention (Id : E) return B; + function Has_Private_Ancestor (Id : E) return B; + function Has_Private_Declaration (Id : E) return B; + function Implementation_Base_Type (Id : E) return E; + function Is_Base_Type (Id : E) return B; + function Is_Boolean_Type (Id : E) return B; + function Is_Constant_Object (Id : E) return B; + function Is_Discriminal (Id : E) return B; + function Is_Dynamic_Scope (Id : E) return B; + function Is_Package_Or_Generic_Package (Id : E) return B; + function Is_Prival (Id : E) return B; + function Is_Protected_Component (Id : E) return B; + function Is_Protected_Interface (Id : E) return B; + function Is_Protected_Record_Type (Id : E) return B; + function Is_Standard_Character_Type (Id : E) return B; + function Is_String_Type (Id : E) return B; + function Is_Synchronized_Interface (Id : E) return B; + function Is_Task_Interface (Id : E) return B; + function Is_Task_Record_Type (Id : E) return B; + function Is_Wrapper_Package (Id : E) return B; + function Last_Formal (Id : E) return E; + function Machine_Emax_Value (Id : E) return U; + function Machine_Emin_Value (Id : E) return U; + function Machine_Mantissa_Value (Id : E) return U; + function Machine_Radix_Value (Id : E) return U; + function Model_Emin_Value (Id : E) return U; + function Model_Epsilon_Value (Id : E) return R; + function Model_Mantissa_Value (Id : E) return U; + function Model_Small_Value (Id : E) return R; + function Next_Component (Id : E) return E; + function Next_Component_Or_Discriminant (Id : E) return E; + function Next_Discriminant (Id : E) return E; + function Next_Formal (Id : E) return E; + function Next_Formal_With_Extras (Id : E) return E; + function Next_Literal (Id : E) return E; + function Next_Stored_Discriminant (Id : E) return E; + function Number_Dimensions (Id : E) return Pos; + function Number_Entries (Id : E) return Nat; + function Number_Formals (Id : E) return Pos; + function Parameter_Mode (Id : E) return Formal_Kind; + function Primitive_Operations (Id : E) return L; + function Root_Type (Id : E) return E; + function Safe_Emax_Value (Id : E) return U; + function Safe_First_Value (Id : E) return R; + function Safe_Last_Value (Id : E) return R; + function Scope_Depth_Set (Id : E) return B; + function Size_Clause (Id : E) return N; + function Stream_Size_Clause (Id : E) return N; + function Type_High_Bound (Id : E) return N; + function Type_Low_Bound (Id : E) return N; + function Underlying_Type (Id : E) return E; + + ---------------------------------------------- + -- Type Representation Attribute Predicates -- + ---------------------------------------------- + + -- These predicates test the setting of the indicated attribute. If the + -- value has been set, then Known is True, and Unknown is False. If no + -- value is set, then Known is False and Unknown is True. The Known_Static + -- predicate is true only if the value is set (Known) and is set to a + -- compile time known value. Note that in the case of Alignment and + -- Normalized_First_Bit, dynamic values are not possible, so we do not + -- need a separate Known_Static calls in these cases. The not set (unknown) + -- values are as follows: + + -- Alignment Uint_0 or No_Uint + -- Component_Size Uint_0 or No_Uint + -- Component_Bit_Offset No_Uint + -- Digits_Value Uint_0 or No_Uint + -- Esize Uint_0 or No_Uint + -- Normalized_First_Bit No_Uint + -- Normalized_Position No_Uint + -- Normalized_Position_Max No_Uint + -- RM_Size Uint_0 or No_Uint + + -- It would be cleaner to use No_Uint in all these cases, but historically + -- we chose to use Uint_0 at first, and the change over will take time ??? + -- This is particularly true for the RM_Size field, where a value of zero + -- is legitimate. We deal with this by a nasty kludge that knows that the + -- value is always known static for discrete types (and no other types can + -- have an RM_Size value of zero). + + -- In two cases, Known_Static_Esize and Known_Static_RM_Size, there is one + -- more consideration, which is that we always return False for generic + -- types. Within a template, the size can look known, because of the fake + -- size values we put in template types, but they are not really known and + -- anyone testing if they are known within the template should get False as + -- a result to prevent incorrect assumptions. + + function Known_Alignment (E : Entity_Id) return B; + function Known_Component_Bit_Offset (E : Entity_Id) return B; + function Known_Component_Size (E : Entity_Id) return B; + function Known_Esize (E : Entity_Id) return B; + function Known_Normalized_First_Bit (E : Entity_Id) return B; + function Known_Normalized_Position (E : Entity_Id) return B; + function Known_Normalized_Position_Max (E : Entity_Id) return B; + function Known_RM_Size (E : Entity_Id) return B; + + function Known_Static_Component_Bit_Offset (E : Entity_Id) return B; + function Known_Static_Component_Size (E : Entity_Id) return B; + function Known_Static_Esize (E : Entity_Id) return B; + function Known_Static_Normalized_First_Bit (E : Entity_Id) return B; + function Known_Static_Normalized_Position (E : Entity_Id) return B; + function Known_Static_Normalized_Position_Max (E : Entity_Id) return B; + function Known_Static_RM_Size (E : Entity_Id) return B; + + function Unknown_Alignment (E : Entity_Id) return B; + function Unknown_Component_Bit_Offset (E : Entity_Id) return B; + function Unknown_Component_Size (E : Entity_Id) return B; + function Unknown_Esize (E : Entity_Id) return B; + function Unknown_Normalized_First_Bit (E : Entity_Id) return B; + function Unknown_Normalized_Position (E : Entity_Id) return B; + function Unknown_Normalized_Position_Max (E : Entity_Id) return B; + function Unknown_RM_Size (E : Entity_Id) return B; + + ------------------------------ + -- Attribute Set Procedures -- + ------------------------------ + + procedure Set_Accept_Address (Id : E; V : L); + procedure Set_Access_Disp_Table (Id : E; V : L); + procedure Set_Dispatch_Table_Wrappers (Id : E; V : L); + procedure Set_Actual_Subtype (Id : E; V : E); + procedure Set_Address_Taken (Id : E; V : B := True); + procedure Set_Alias (Id : E; V : E); + procedure Set_Alignment (Id : E; V : U); + procedure Set_Associated_Final_Chain (Id : E; V : E); + procedure Set_Associated_Formal_Package (Id : E; V : E); + procedure Set_Associated_Node_For_Itype (Id : E; V : N); + procedure Set_Associated_Storage_Pool (Id : E; V : E); + procedure Set_Barrier_Function (Id : E; V : N); + procedure Set_Block_Node (Id : E; V : N); + procedure Set_Body_Entity (Id : E; V : E); + procedure Set_Body_Needed_For_SAL (Id : E; V : B := True); + procedure Set_CR_Discriminant (Id : E; V : E); + procedure Set_C_Pass_By_Copy (Id : E; V : B := True); + procedure Set_Can_Never_Be_Null (Id : E; V : B := True); + procedure Set_Checks_May_Be_Suppressed (Id : E; V : B := True); + procedure Set_Class_Wide_Type (Id : E; V : E); + procedure Set_Cloned_Subtype (Id : E; V : E); + procedure Set_Component_Alignment (Id : E; V : C); + procedure Set_Component_Bit_Offset (Id : E; V : U); + procedure Set_Component_Clause (Id : E; V : N); + procedure Set_Component_Size (Id : E; V : U); + procedure Set_Component_Type (Id : E; V : E); + procedure Set_Corresponding_Concurrent_Type (Id : E; V : E); + procedure Set_Corresponding_Discriminant (Id : E; V : E); + procedure Set_Corresponding_Equality (Id : E; V : E); + procedure Set_Corresponding_Protected_Entry (Id : E; V : E); + procedure Set_Corresponding_Record_Type (Id : E; V : E); + procedure Set_Corresponding_Remote_Type (Id : E; V : E); + procedure Set_Current_Use_Clause (Id : E; V : E); + procedure Set_Current_Value (Id : E; V : N); + procedure Set_Debug_Info_Off (Id : E; V : B := True); + procedure Set_Debug_Renaming_Link (Id : E; V : E); + procedure Set_DTC_Entity (Id : E; V : E); + procedure Set_DT_Entry_Count (Id : E; V : U); + procedure Set_DT_Offset_To_Top_Func (Id : E; V : E); + procedure Set_DT_Position (Id : E; V : U); + procedure Set_Default_Expr_Function (Id : E; V : E); + procedure Set_Default_Expressions_Processed (Id : E; V : B := True); + procedure Set_Default_Value (Id : E; V : N); + procedure Set_Delay_Cleanups (Id : E; V : B := True); + procedure Set_Delay_Subprogram_Descriptors (Id : E; V : B := True); + procedure Set_Delta_Value (Id : E; V : R); + procedure Set_Dependent_Instances (Id : E; V : L); + procedure Set_Depends_On_Private (Id : E; V : B := True); + procedure Set_Digits_Value (Id : E; V : U); + procedure Set_Directly_Designated_Type (Id : E; V : E); + procedure Set_Discard_Names (Id : E; V : B := True); + procedure Set_Discriminal (Id : E; V : E); + procedure Set_Discriminal_Link (Id : E; V : E); + procedure Set_Discriminant_Checking_Func (Id : E; V : E); + procedure Set_Discriminant_Constraint (Id : E; V : L); + procedure Set_Discriminant_Default_Value (Id : E; V : N); + procedure Set_Discriminant_Number (Id : E; V : U); + procedure Set_Elaborate_Body_Desirable (Id : E; V : B := True); + procedure Set_Elaboration_Entity (Id : E; V : E); + procedure Set_Elaboration_Entity_Required (Id : E; V : B := True); + procedure Set_Enclosing_Scope (Id : E; V : E); + procedure Set_Entry_Accepted (Id : E; V : B := True); + procedure Set_Entry_Bodies_Array (Id : E; V : E); + procedure Set_Entry_Cancel_Parameter (Id : E; V : E); + procedure Set_Entry_Component (Id : E; V : E); + procedure Set_Entry_Formal (Id : E; V : E); + procedure Set_Entry_Index_Constant (Id : E; V : E); + procedure Set_Entry_Parameters_Type (Id : E; V : E); + procedure Set_Enum_Pos_To_Rep (Id : E; V : E); + procedure Set_Enumeration_Pos (Id : E; V : U); + procedure Set_Enumeration_Rep (Id : E; V : U); + procedure Set_Enumeration_Rep_Expr (Id : E; V : N); + procedure Set_Equivalent_Type (Id : E; V : E); + procedure Set_Esize (Id : E; V : U); + procedure Set_Exception_Code (Id : E; V : U); + procedure Set_Extra_Accessibility (Id : E; V : E); + procedure Set_Extra_Constrained (Id : E; V : E); + procedure Set_Extra_Formal (Id : E; V : E); + procedure Set_Extra_Formals (Id : E; V : E); + procedure Set_Can_Use_Internal_Rep (Id : E; V : B := True); + procedure Set_Finalization_Chain_Entity (Id : E; V : E); + procedure Set_Finalize_Storage_Only (Id : E; V : B := True); + procedure Set_First_Entity (Id : E; V : E); + procedure Set_First_Exit_Statement (Id : E; V : N); + procedure Set_First_Index (Id : E; V : N); + procedure Set_First_Literal (Id : E; V : E); + procedure Set_First_Optional_Parameter (Id : E; V : E); + procedure Set_First_Private_Entity (Id : E; V : E); + procedure Set_First_Rep_Item (Id : E; V : N); + procedure Set_Float_Rep (Id : E; V : F); + procedure Set_Freeze_Node (Id : E; V : N); + procedure Set_From_With_Type (Id : E; V : B := True); + procedure Set_Full_View (Id : E; V : E); + procedure Set_Generic_Homonym (Id : E; V : E); + procedure Set_Generic_Renamings (Id : E; V : L); + procedure Set_Handler_Records (Id : E; V : S); + procedure Set_Has_Aliased_Components (Id : E; V : B := True); + procedure Set_Has_Alignment_Clause (Id : E; V : B := True); + procedure Set_Has_All_Calls_Remote (Id : E; V : B := True); + procedure Set_Has_Anon_Block_Suffix (Id : E; V : B := True); + procedure Set_Has_Atomic_Components (Id : E; V : B := True); + procedure Set_Has_Biased_Representation (Id : E; V : B := True); + procedure Set_Has_Completion (Id : E; V : B := True); + procedure Set_Has_Completion_In_Body (Id : E; V : B := True); + procedure Set_Has_Complex_Representation (Id : E; V : B := True); + procedure Set_Has_Component_Size_Clause (Id : E; V : B := True); + procedure Set_Has_Constrained_Partial_View (Id : E; V : B := True); + procedure Set_Has_Contiguous_Rep (Id : E; V : B := True); + procedure Set_Has_Controlled_Component (Id : E; V : B := True); + procedure Set_Has_Controlling_Result (Id : E; V : B := True); + procedure Set_Has_Convention_Pragma (Id : E; V : B := True); + procedure Set_Has_Delayed_Aspects (Id : E; V : B := True); + procedure Set_Has_Delayed_Freeze (Id : E; V : B := True); + procedure Set_Has_Discriminants (Id : E; V : B := True); + procedure Set_Has_Dispatch_Table (Id : E; V : B := True); + procedure Set_Has_Enumeration_Rep_Clause (Id : E; V : B := True); + procedure Set_Has_Exit (Id : E; V : B := True); + procedure Set_Has_External_Tag_Rep_Clause (Id : E; V : B := True); + procedure Set_Has_Fully_Qualified_Name (Id : E; V : B := True); + procedure Set_Has_Gigi_Rep_Item (Id : E; V : B := True); + procedure Set_Has_Homonym (Id : E; V : B := True); + procedure Set_Has_Inheritable_Invariants (Id : E; V : B := True); + procedure Set_Has_Initial_Value (Id : E; V : B := True); + procedure Set_Has_Invariants (Id : E; V : B := True); + procedure Set_Has_Machine_Radix_Clause (Id : E; V : B := True); + procedure Set_Has_Master_Entity (Id : E; V : B := True); + procedure Set_Has_Missing_Return (Id : E; V : B := True); + procedure Set_Has_Nested_Block_With_Handler (Id : E; V : B := True); + procedure Set_Has_Forward_Instantiation (Id : E; V : B := True); + procedure Set_Has_Up_Level_Access (Id : E; V : B := True); + procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True); + procedure Set_Has_Object_Size_Clause (Id : E; V : B := True); + procedure Set_Has_Per_Object_Constraint (Id : E; V : B := True); + procedure Set_Has_Persistent_BSS (Id : E; V : B := True); + procedure Set_Has_Postconditions (Id : E; V : B := True); + procedure Set_Has_Pragma_Controlled (Id : E; V : B := True); + procedure Set_Has_Pragma_Elaborate_Body (Id : E; V : B := True); + procedure Set_Has_Pragma_Inline (Id : E; V : B := True); + procedure Set_Has_Pragma_Inline_Always (Id : E; V : B := True); + procedure Set_Has_Pragma_Ordered (Id : E; V : B := True); + procedure Set_Has_Pragma_Pack (Id : E; V : B := True); + procedure Set_Has_Pragma_Preelab_Init (Id : E; V : B := True); + procedure Set_Has_Pragma_Pure (Id : E; V : B := True); + procedure Set_Has_Pragma_Pure_Function (Id : E; V : B := True); + procedure Set_Has_Pragma_Thread_Local_Storage (Id : E; V : B := True); + procedure Set_Has_Pragma_Unmodified (Id : E; V : B := True); + procedure Set_Has_Pragma_Unreferenced (Id : E; V : B := True); + procedure Set_Has_Pragma_Unreferenced_Objects (Id : E; V : B := True); + procedure Set_Has_Predicates (Id : E; V : B := True); + procedure Set_Has_Primitive_Operations (Id : E; V : B := True); + procedure Set_Has_Private_Declaration (Id : E; V : B := True); + procedure Set_Has_Qualified_Name (Id : E; V : B := True); + procedure Set_Has_RACW (Id : E; V : B := True); + procedure Set_Has_Record_Rep_Clause (Id : E; V : B := True); + procedure Set_Has_Recursive_Call (Id : E; V : B := True); + procedure Set_Has_Size_Clause (Id : E; V : B := True); + procedure Set_Has_Small_Clause (Id : E; V : B := True); + procedure Set_Has_Specified_Layout (Id : E; V : B := True); + procedure Set_Has_Specified_Stream_Input (Id : E; V : B := True); + procedure Set_Has_Specified_Stream_Output (Id : E; V : B := True); + procedure Set_Has_Specified_Stream_Read (Id : E; V : B := True); + procedure Set_Has_Specified_Stream_Write (Id : E; V : B := True); + procedure Set_Has_Static_Discriminants (Id : E; V : B := True); + procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True); + procedure Set_Has_Stream_Size_Clause (Id : E; V : B := True); + procedure Set_Has_Subprogram_Descriptor (Id : E; V : B := True); + procedure Set_Has_Task (Id : E; V : B := True); + procedure Set_Has_Thunks (Id : E; V : B := True); + procedure Set_Has_Unchecked_Union (Id : E; V : B := True); + procedure Set_Has_Unknown_Discriminants (Id : E; V : B := True); + procedure Set_Has_Volatile_Components (Id : E; V : B := True); + procedure Set_Has_Xref_Entry (Id : E; V : B := True); + procedure Set_Hiding_Loop_Variable (Id : E; V : E); + procedure Set_Homonym (Id : E; V : E); + procedure Set_Interfaces (Id : E; V : L); + procedure Set_In_Package_Body (Id : E; V : B := True); + procedure Set_In_Private_Part (Id : E; V : B := True); + procedure Set_In_Use (Id : E; V : B := True); + procedure Set_Inner_Instances (Id : E; V : L); + procedure Set_Interface_Alias (Id : E; V : E); + procedure Set_Interface_Name (Id : E; V : N); + procedure Set_Is_AST_Entry (Id : E; V : B := True); + procedure Set_Is_Abstract_Subprogram (Id : E; V : B := True); + procedure Set_Is_Abstract_Type (Id : E; V : B := True); + procedure Set_Is_Access_Constant (Id : E; V : B := True); + procedure Set_Is_Ada_2005_Only (Id : E; V : B := True); + procedure Set_Is_Ada_2012_Only (Id : E; V : B := True); + procedure Set_Is_Aliased (Id : E; V : B := True); + procedure Set_Is_Asynchronous (Id : E; V : B := True); + procedure Set_Is_Atomic (Id : E; V : B := True); + procedure Set_Is_Bit_Packed_Array (Id : E; V : B := True); + procedure Set_Is_CPP_Class (Id : E; V : B := True); + procedure Set_Is_Called (Id : E; V : B := True); + procedure Set_Is_Character_Type (Id : E; V : B := True); + procedure Set_Is_Child_Unit (Id : E; V : B := True); + procedure Set_Is_Class_Wide_Equivalent_Type (Id : E; V : B := True); + procedure Set_Is_Compilation_Unit (Id : E; V : B := True); + procedure Set_Is_Completely_Hidden (Id : E; V : B := True); + procedure Set_Is_Concurrent_Record_Type (Id : E; V : B := True); + procedure Set_Is_Constr_Subt_For_UN_Aliased (Id : E; V : B := True); + procedure Set_Is_Constr_Subt_For_U_Nominal (Id : E; V : B := True); + procedure Set_Is_Constrained (Id : E; V : B := True); + procedure Set_Is_Constructor (Id : E; V : B := True); + procedure Set_Is_Controlled (Id : E; V : B := True); + procedure Set_Is_Controlling_Formal (Id : E; V : B := True); + procedure Set_Is_Descendent_Of_Address (Id : E; V : B := True); + procedure Set_Is_Discrim_SO_Function (Id : E; V : B := True); + procedure Set_Is_Dispatch_Table_Entity (Id : E; V : B := True); + procedure Set_Is_Dispatching_Operation (Id : E; V : B := True); + procedure Set_Is_Eliminated (Id : E; V : B := True); + procedure Set_Is_Entry_Formal (Id : E; V : B := True); + procedure Set_Is_Exported (Id : E; V : B := True); + procedure Set_Is_First_Subtype (Id : E; V : B := True); + procedure Set_Is_For_Access_Subtype (Id : E; V : B := True); + procedure Set_Is_Formal_Subprogram (Id : E; V : B := True); + procedure Set_Is_Frozen (Id : E; V : B := True); + procedure Set_Is_Generic_Actual_Type (Id : E; V : B := True); + procedure Set_Is_Generic_Instance (Id : E; V : B := True); + procedure Set_Is_Generic_Type (Id : E; V : B := True); + procedure Set_Is_Hidden (Id : E; V : B := True); + procedure Set_Is_Hidden_Open_Scope (Id : E; V : B := True); + procedure Set_Is_Immediately_Visible (Id : E; V : B := True); + procedure Set_Is_Imported (Id : E; V : B := True); + procedure Set_Is_Inlined (Id : E; V : B := True); + procedure Set_Is_Interface (Id : E; V : B := True); + procedure Set_Is_Instantiated (Id : E; V : B := True); + procedure Set_Is_Internal (Id : E; V : B := True); + procedure Set_Is_Interrupt_Handler (Id : E; V : B := True); + procedure Set_Is_Intrinsic_Subprogram (Id : E; V : B := True); + procedure Set_Is_Itype (Id : E; V : B := True); + procedure Set_Is_Known_Non_Null (Id : E; V : B := True); + procedure Set_Is_Known_Null (Id : E; V : B := True); + procedure Set_Is_Known_Valid (Id : E; V : B := True); + procedure Set_Is_Limited_Composite (Id : E; V : B := True); + procedure Set_Is_Limited_Interface (Id : E; V : B := True); + procedure Set_Is_Limited_Record (Id : E; V : B := True); + procedure Set_Is_Local_Anonymous_Access (Id : E; V : B := True); + procedure Set_Is_Machine_Code_Subprogram (Id : E; V : B := True); + procedure Set_Is_Non_Static_Subtype (Id : E; V : B := True); + procedure Set_Is_Null_Init_Proc (Id : E; V : B := True); + procedure Set_Is_Obsolescent (Id : E; V : B := True); + procedure Set_Is_Only_Out_Parameter (Id : E; V : B := True); + procedure Set_Is_Optional_Parameter (Id : E; V : B := True); + procedure Set_Is_Package_Body_Entity (Id : E; V : B := True); + procedure Set_Is_Packed (Id : E; V : B := True); + procedure Set_Is_Packed_Array_Type (Id : E; V : B := True); + procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True); + procedure Set_Is_Preelaborated (Id : E; V : B := True); + procedure Set_Is_Primitive (Id : E; V : B := True); + procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True); + procedure Set_Is_Private_Composite (Id : E; V : B := True); + procedure Set_Is_Private_Descendant (Id : E; V : B := True); + procedure Set_Is_Private_Primitive (Id : E; V : B := True); + procedure Set_Is_Public (Id : E; V : B := True); + procedure Set_Is_Pure (Id : E; V : B := True); + procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True); + procedure Set_Is_RACW_Stub_Type (Id : E; V : B := True); + procedure Set_Is_Raised (Id : E; V : B := True); + procedure Set_Is_Remote_Call_Interface (Id : E; V : B := True); + procedure Set_Is_Remote_Types (Id : E; V : B := True); + procedure Set_Is_Renaming_Of_Object (Id : E; V : B := True); + procedure Set_Is_Return_Object (Id : E; V : B := True); + procedure Set_Is_Shared_Passive (Id : E; V : B := True); + procedure Set_Is_Statically_Allocated (Id : E; V : B := True); + procedure Set_Is_Tag (Id : E; V : B := True); + procedure Set_Is_Tagged_Type (Id : E; V : B := True); + procedure Set_Is_Thunk (Id : E; V : B := True); + procedure Set_Is_Trivial_Subprogram (Id : E; V : B := True); + procedure Set_Is_True_Constant (Id : E; V : B := True); + procedure Set_Is_Unchecked_Union (Id : E; V : B := True); + procedure Set_Is_Underlying_Record_View (Id : E; V : B := True); + procedure Set_Is_Unsigned_Type (Id : E; V : B := True); + procedure Set_Is_VMS_Exception (Id : E; V : B := True); + procedure Set_Is_Valued_Procedure (Id : E; V : B := True); + procedure Set_Is_Visible_Child_Unit (Id : E; V : B := True); + procedure Set_Is_Visible_Formal (Id : E; V : B := True); + procedure Set_Is_Volatile (Id : E; V : B := True); + procedure Set_Itype_Printed (Id : E; V : B := True); + procedure Set_Kill_Elaboration_Checks (Id : E; V : B := True); + procedure Set_Kill_Range_Checks (Id : E; V : B := True); + procedure Set_Kill_Tag_Checks (Id : E; V : B := True); + procedure Set_Known_To_Have_Preelab_Init (Id : E; V : B := True); + procedure Set_Last_Assignment (Id : E; V : N); + procedure Set_Last_Entity (Id : E; V : E); + procedure Set_Limited_View (Id : E; V : E); + procedure Set_Lit_Indexes (Id : E; V : E); + procedure Set_Lit_Strings (Id : E; V : E); + procedure Set_Low_Bound_Tested (Id : E; V : B := True); + procedure Set_Machine_Radix_10 (Id : E; V : B := True); + procedure Set_Master_Id (Id : E; V : E); + procedure Set_Materialize_Entity (Id : E; V : B := True); + procedure Set_Mechanism (Id : E; V : M); + procedure Set_Modulus (Id : E; V : U); + procedure Set_Must_Be_On_Byte_Boundary (Id : E; V : B := True); + procedure Set_Must_Have_Preelab_Init (Id : E; V : B := True); + procedure Set_Needs_Debug_Info (Id : E; V : B := True); + procedure Set_Needs_No_Actuals (Id : E; V : B := True); + procedure Set_Never_Set_In_Source (Id : E; V : B := True); + procedure Set_Next_Inlined_Subprogram (Id : E; V : E); + procedure Set_No_Pool_Assigned (Id : E; V : B := True); + procedure Set_No_Return (Id : E; V : B := True); + procedure Set_No_Strict_Aliasing (Id : E; V : B := True); + procedure Set_Non_Binary_Modulus (Id : E; V : B := True); + procedure Set_Non_Limited_View (Id : E; V : E); + procedure Set_Nonzero_Is_True (Id : E; V : B := True); + procedure Set_Normalized_First_Bit (Id : E; V : U); + procedure Set_Normalized_Position (Id : E; V : U); + procedure Set_Normalized_Position_Max (Id : E; V : U); + procedure Set_OK_To_Rename (Id : E; V : B := True); + procedure Set_OK_To_Reorder_Components (Id : E; V : B := True); + procedure Set_Optimize_Alignment_Space (Id : E; V : B := True); + procedure Set_Optimize_Alignment_Time (Id : E; V : B := True); + procedure Set_Original_Array_Type (Id : E; V : E); + procedure Set_Original_Record_Component (Id : E; V : E); + procedure Set_Overlays_Constant (Id : E; V : B := True); + procedure Set_Overridden_Operation (Id : E; V : E); + procedure Set_Package_Instantiation (Id : E; V : N); + procedure Set_Packed_Array_Type (Id : E; V : E); + procedure Set_Parent_Subtype (Id : E; V : E); + procedure Set_Postcondition_Proc (Id : E; V : E); + procedure Set_PPC_Wrapper (Id : E; V : E); + procedure Set_Direct_Primitive_Operations (Id : E; V : L); + procedure Set_Prival (Id : E; V : E); + procedure Set_Prival_Link (Id : E; V : E); + procedure Set_Private_Dependents (Id : E; V : L); + procedure Set_Private_View (Id : E; V : N); + procedure Set_Protected_Body_Subprogram (Id : E; V : E); + procedure Set_Protected_Formal (Id : E; V : E); + procedure Set_Protection_Object (Id : E; V : E); + procedure Set_RM_Size (Id : E; V : U); + procedure Set_Reachable (Id : E; V : B := True); + procedure Set_Referenced (Id : E; V : B := True); + procedure Set_Referenced_As_LHS (Id : E; V : B := True); + procedure Set_Referenced_As_Out_Parameter (Id : E; V : B := True); + procedure Set_Register_Exception_Call (Id : E; V : N); + procedure Set_Related_Array_Object (Id : E; V : E); + procedure Set_Related_Expression (Id : E; V : N); + procedure Set_Related_Instance (Id : E; V : E); + procedure Set_Related_Type (Id : E; V : E); + procedure Set_Relative_Deadline_Variable (Id : E; V : E); + procedure Set_Renamed_Entity (Id : E; V : N); + procedure Set_Renamed_In_Spec (Id : E; V : B := True); + procedure Set_Renamed_Object (Id : E; V : N); + procedure Set_Renaming_Map (Id : E; V : U); + procedure Set_Requires_Overriding (Id : E; V : B := True); + procedure Set_Return_Present (Id : E; V : B := True); + procedure Set_Return_Applies_To (Id : E; V : N); + procedure Set_Returns_By_Ref (Id : E; V : B := True); + procedure Set_Reverse_Bit_Order (Id : E; V : B := True); + procedure Set_Scalar_Range (Id : E; V : N); + procedure Set_Scale_Value (Id : E; V : U); + procedure Set_Scope_Depth_Value (Id : E; V : U); + procedure Set_Sec_Stack_Needed_For_Return (Id : E; V : B := True); + procedure Set_Shadow_Entities (Id : E; V : S); + procedure Set_Shared_Var_Procs_Instance (Id : E; V : E); + procedure Set_Size_Check_Code (Id : E; V : N); + procedure Set_Size_Depends_On_Discriminant (Id : E; V : B := True); + procedure Set_Size_Known_At_Compile_Time (Id : E; V : B := True); + procedure Set_Small_Value (Id : E; V : R); + procedure Set_Spec_Entity (Id : E; V : E); + procedure Set_Spec_PPC_List (Id : E; V : N); + procedure Set_Static_Predicate (Id : E; V : S); + procedure Set_Storage_Size_Variable (Id : E; V : E); + procedure Set_Static_Elaboration_Desired (Id : E; V : B); + procedure Set_Static_Initialization (Id : E; V : N); + procedure Set_Stored_Constraint (Id : E; V : L); + procedure Set_Strict_Alignment (Id : E; V : B := True); + procedure Set_String_Literal_Length (Id : E; V : U); + procedure Set_String_Literal_Low_Bound (Id : E; V : N); + procedure Set_Subprograms_For_Type (Id : E; V : E); + procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True); + procedure Set_Suppress_Init_Proc (Id : E; V : B := True); + procedure Set_Suppress_Style_Checks (Id : E; V : B := True); + procedure Set_Suppress_Value_Tracking_On_Call (Id : E; V : B := True); + procedure Set_Task_Body_Procedure (Id : E; V : N); + procedure Set_Treat_As_Volatile (Id : E; V : B := True); + procedure Set_Underlying_Full_View (Id : E; V : E); + procedure Set_Underlying_Record_View (Id : E; V : E); + procedure Set_Universal_Aliasing (Id : E; V : B := True); + procedure Set_Unset_Reference (Id : E; V : N); + procedure Set_Used_As_Generic_Actual (Id : E; V : B := True); + procedure Set_Uses_Sec_Stack (Id : E; V : B := True); + procedure Set_Warnings_Off (Id : E; V : B := True); + procedure Set_Warnings_Off_Used (Id : E; V : B := True); + procedure Set_Warnings_Off_Used_Unmodified (Id : E; V : B := True); + procedure Set_Warnings_Off_Used_Unreferenced (Id : E; V : B := True); + procedure Set_Was_Hidden (Id : E; V : B := True); + procedure Set_Wrapped_Entity (Id : E; V : E); + + --------------------------------------------------- + -- Access to Subprograms in Subprograms_For_Type -- + --------------------------------------------------- + + function Invariant_Procedure (Id : E) return N; + function Predicate_Function (Id : E) return N; + + procedure Set_Invariant_Procedure (Id : E; V : E); + procedure Set_Predicate_Function (Id : E; V : E); + + ----------------------------------- + -- Field Initialization Routines -- + ----------------------------------- + + -- These routines are overloadings of some of the above Set procedures + -- where the argument is normally a Uint. The overloadings take an Int + -- parameter instead, and appropriately convert it. There are also + -- versions that implicitly initialize to the appropriate "not set" + -- value. The not set (unknown) values are as follows: + + -- Alignment Uint_0 + -- Component_Size Uint_0 + -- Component_Bit_Offset No_Uint + -- Digits_Value Uint_0 + -- Esize Uint_0 + -- Normalized_First_Bit No_Uint + -- Normalized_Position No_Uint + -- Normalized_Position_Max No_Uint + -- RM_Size Uint_0 + + -- It would be cleaner to use No_Uint in all these cases, but historically + -- we chose to use Uint_0 at first, and the change over will take time ??? + -- This is particularly true for the RM_Size field, where a value of zero + -- is legitimate and causes some kludges around the code. + + -- Contrary to the corresponding Set procedures above, these routines + -- do NOT check the entity kind of their argument, instead they set the + -- underlying Uint fields directly (this allows them to be used for + -- entities whose Ekind has not been set yet). + + procedure Init_Alignment (Id : E; V : Int); + procedure Init_Component_Size (Id : E; V : Int); + procedure Init_Component_Bit_Offset (Id : E; V : Int); + procedure Init_Digits_Value (Id : E; V : Int); + procedure Init_Esize (Id : E; V : Int); + procedure Init_Normalized_First_Bit (Id : E; V : Int); + procedure Init_Normalized_Position (Id : E; V : Int); + procedure Init_Normalized_Position_Max (Id : E; V : Int); + procedure Init_RM_Size (Id : E; V : Int); + + procedure Init_Alignment (Id : E); + procedure Init_Component_Size (Id : E); + procedure Init_Component_Bit_Offset (Id : E); + procedure Init_Digits_Value (Id : E); + procedure Init_Esize (Id : E); + procedure Init_Normalized_First_Bit (Id : E); + procedure Init_Normalized_Position (Id : E); + procedure Init_Normalized_Position_Max (Id : E); + procedure Init_RM_Size (Id : E); + + procedure Init_Size_Align (Id : E); + -- This procedure initializes both size fields and the alignment + -- field to all be Unknown. + + procedure Init_Size (Id : E; V : Int); + -- Initialize both the Esize and RM_Size fields of E to V + + procedure Init_Component_Location (Id : E); + -- Initializes all fields describing the location of a component + -- (Normalized_Position, Component_Bit_Offset, Normalized_First_Bit, + -- Normalized_Position_Max, Esize) to all be Unknown. + + --------------- + -- Iterators -- + --------------- + + -- The call to Next_xxx (obj) is equivalent to obj := Next_xxx (obj) + -- We define the set of Proc_Next_xxx routines simply for the purposes + -- of inlining them without necessarily inlining the function. + + procedure Proc_Next_Component (N : in out Node_Id); + procedure Proc_Next_Component_Or_Discriminant (N : in out Node_Id); + procedure Proc_Next_Discriminant (N : in out Node_Id); + procedure Proc_Next_Formal (N : in out Node_Id); + procedure Proc_Next_Formal_With_Extras (N : in out Node_Id); + procedure Proc_Next_Index (N : in out Node_Id); + procedure Proc_Next_Inlined_Subprogram (N : in out Node_Id); + procedure Proc_Next_Literal (N : in out Node_Id); + procedure Proc_Next_Stored_Discriminant (N : in out Node_Id); + + pragma Inline (Proc_Next_Component); + pragma Inline (Proc_Next_Component_Or_Discriminant); + pragma Inline (Proc_Next_Discriminant); + pragma Inline (Proc_Next_Formal); + pragma Inline (Proc_Next_Formal_With_Extras); + pragma Inline (Proc_Next_Index); + pragma Inline (Proc_Next_Inlined_Subprogram); + pragma Inline (Proc_Next_Literal); + pragma Inline (Proc_Next_Stored_Discriminant); + + procedure Next_Component (N : in out Node_Id) + renames Proc_Next_Component; + + procedure Next_Component_Or_Discriminant (N : in out Node_Id) + renames Proc_Next_Component_Or_Discriminant; + + procedure Next_Discriminant (N : in out Node_Id) + renames Proc_Next_Discriminant; + + procedure Next_Formal (N : in out Node_Id) + renames Proc_Next_Formal; + + procedure Next_Formal_With_Extras (N : in out Node_Id) + renames Proc_Next_Formal_With_Extras; + + procedure Next_Index (N : in out Node_Id) + renames Proc_Next_Index; + + procedure Next_Inlined_Subprogram (N : in out Node_Id) + renames Proc_Next_Inlined_Subprogram; + + procedure Next_Literal (N : in out Node_Id) + renames Proc_Next_Literal; + + procedure Next_Stored_Discriminant (N : in out Node_Id) + renames Proc_Next_Stored_Discriminant; + + --------------------------- + -- Testing Warning Flags -- + --------------------------- + + -- These routines are to be used rather than testing flags Warnings_Off, + -- Has_Pragma_Unmodified, Has_Pragma_Unreferenced. They deal with setting + -- the flags Warnings_Off_Used[_Unmodified|Unreferenced] for later access. + + function Has_Warnings_Off (E : Entity_Id) return Boolean; + -- If Warnings_Off is set on E, then returns True and also sets the flag + -- Warnings_Off_Used on E. If Warnings_Off is not set on E, returns False + -- and has no side effect. + + function Has_Unmodified (E : Entity_Id) return Boolean; + -- If flag Has_Pragma_Unmodified is set on E, returns True with no side + -- effects. Otherwise if Warnings_Off is set on E, returns True and also + -- sets the flag Warnings_Off_Used_Unmodified on E. If neither of the flags + -- Warnings_Off nor Has_Pragma_Unmodified is set, returns False with no + -- side effects. + + function Has_Unreferenced (E : Entity_Id) return Boolean; + -- If flag Has_Pragma_Unreferenced is set on E, returns True with no side + -- effects. Otherwise if Warnings_Off is set on E, returns True and also + -- sets the flag Warnings_Off_Used_Unreferenced on E. If neither of the + -- flags Warnings_Off nor Has_Pragma_Unreferenced is set, returns False + -- with no side effects. + + ---------------------------------------------- + -- Subprograms for Accessing Rep Item Chain -- + ---------------------------------------------- + + -- The First_Rep_Item field of every entity points to a linked list (linked + -- through Next_Rep_Item) of representation pragmas, attribute definition + -- clauses, representation clauses, and aspect specifications that apply to + -- the item. Note that in the case of types, it is assumed that any such + -- rep items for a base type also apply to all subtypes. This is achieved + -- by having the chain for subtypes link onto the chain for the base type, + -- so that new entries for the subtype are added at the start of the chain. + -- + -- Note: aspect specification nodes are linked only when evaluation of the + -- expression is deferred to the freeze point. For further details see + -- Sem_Ch13.Analyze_Aspect_Specifications. + + function Get_Attribute_Definition_Clause + (E : Entity_Id; + Id : Attribute_Id) return Node_Id; + -- Searches the Rep_Item chain for a given entity E, for an instance of an + -- attribute definition clause with the given attribute Id. If found, the + -- value returned is the N_Attribute_Definition_Clause node, otherwise + -- Empty is returned. + + function Get_Rep_Item_For_Entity + (E : Entity_Id; + Nam : Name_Id) return Node_Id; + -- Searches the Rep_Item chain for a given entity E, for an instance of a + -- rep item (pragma, attribute definition clause, or aspect specification) + -- whose name matches the given name. If one is found, it is returned, + -- otherwise Empty is returned. Unlike the other Get routines for the + -- Rep_Item chain, this only returns items whose entity matches E (it + -- does not return items from the parent chain). + + function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id; + -- Searches the Rep_Item chain for a given entity E, for a record + -- representation clause, and if found, returns it. Returns Empty + -- if no such clause is found. + + function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id; + -- Searches the Rep_Item chain for the given entity E, for an instance + -- a representation pragma with the given name Nam. If found then the + -- value returned is the N_Pragma node, otherwise Empty is returned. + + function Has_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Boolean; + -- Searches the Rep_Item chain for the given entity E, for an instance + -- of representation pragma with the given name Nam. If found then True + -- is returned, otherwise False indicates that no matching entry was found. + + function Has_Attribute_Definition_Clause + (E : Entity_Id; + Id : Attribute_Id) return Boolean; + -- Searches the Rep_Item chain for a given entity E, for an instance of an + -- attribute definition clause with the given attribute Id. If found, True + -- is returned, otherwise False indicates that no matching entry was found. + + procedure Record_Rep_Item (E : Entity_Id; N : Node_Id); + -- N is the node for a representation pragma, representation clause, an + -- attribute definition clause, or an aspect specification that applies to + -- entity E. This procedure links the node N onto the Rep_Item chain for + -- entity E. Note that it is an error to call this procedure with E being + -- overloadable, and N being a pragma that applies to multiple overloadable + -- entities (Convention, Interface, Inline, Inline_Always, Import, Export, + -- External). This is not allowed even in the case where the entity is not + -- overloaded, since we can't rely on it being present in the overloaded + -- case, it is not useful to have it present in the non-overloaded case. + + ------------------------------- + -- Miscellaneous Subprograms -- + ------------------------------- + + procedure Append_Entity (Id : Entity_Id; V : Entity_Id); + -- Add an entity to the list of entities declared in the scope V + + function Get_Full_View (T : Entity_Id) return Entity_Id; + -- If T is an incomplete type and the full declaration has been seen, or + -- is the name of a class_wide type whose root is incomplete, return the + -- corresponding full declaration, else return T itself. + + function Is_Entity_Name (N : Node_Id) return Boolean; + -- Test if the node N is the name of an entity (i.e. is an identifier, + -- expanded name, or an attribute reference that returns an entity). + + function Next_Index (Id : Node_Id) return Node_Id; + -- Given an index from a previous call to First_Index or Next_Index, + -- returns a node representing the occurrence of the next index subtype, + -- or Empty if there are no more index subtypes. + + function Scope_Depth (Id : Entity_Id) return Uint; + -- Returns the scope depth value of the Id, unless the Id is a record + -- type, in which case it returns the scope depth of the record scope. + + function Subtype_Kind (K : Entity_Kind) return Entity_Kind; + -- Given an entity_kind K this function returns the entity_kind + -- corresponding to subtype kind of the type represented by K. For + -- example if K is E_Signed_Integer_Type then E_Signed_Integer_Subtype + -- is returned. If K is already a subtype kind it itself is returned. An + -- internal error is generated if no such correspondence exists for K. + + ---------------------------------- + -- Debugging Output Subprograms -- + ---------------------------------- + + procedure Write_Entity_Flags (Id : Entity_Id; Prefix : String); + -- Writes a series of entries giving a line for each flag that is + -- set to True. Each line is prefixed by the given string + + procedure Write_Entity_Info (Id : Entity_Id; Prefix : String); + -- A debugging procedure to write out information about an entity + + procedure Write_Field6_Name (Id : Entity_Id); + procedure Write_Field7_Name (Id : Entity_Id); + procedure Write_Field8_Name (Id : Entity_Id); + procedure Write_Field9_Name (Id : Entity_Id); + procedure Write_Field10_Name (Id : Entity_Id); + procedure Write_Field11_Name (Id : Entity_Id); + procedure Write_Field12_Name (Id : Entity_Id); + procedure Write_Field13_Name (Id : Entity_Id); + procedure Write_Field14_Name (Id : Entity_Id); + procedure Write_Field15_Name (Id : Entity_Id); + procedure Write_Field16_Name (Id : Entity_Id); + procedure Write_Field17_Name (Id : Entity_Id); + procedure Write_Field18_Name (Id : Entity_Id); + procedure Write_Field19_Name (Id : Entity_Id); + procedure Write_Field20_Name (Id : Entity_Id); + procedure Write_Field21_Name (Id : Entity_Id); + procedure Write_Field22_Name (Id : Entity_Id); + procedure Write_Field23_Name (Id : Entity_Id); + procedure Write_Field24_Name (Id : Entity_Id); + procedure Write_Field25_Name (Id : Entity_Id); + procedure Write_Field26_Name (Id : Entity_Id); + procedure Write_Field27_Name (Id : Entity_Id); + procedure Write_Field28_Name (Id : Entity_Id); + procedure Write_Field29_Name (Id : Entity_Id); + -- These routines are used in Treepr to output a nice symbolic name for + -- the given field, depending on the Ekind. No blanks or end of lines are + -- output, just the characters of the field name. + + -------------------- + -- Inline Pragmas -- + -------------------- + + -- Note that these inline pragmas are referenced by the XEINFO utility + -- program in preparing the corresponding C header, and only those + -- subprograms meeting the requirements documented in the section on + -- XEINFO may be referenced in this section. + + pragma Inline (Accept_Address); + pragma Inline (Access_Disp_Table); + pragma Inline (Actual_Subtype); + pragma Inline (Address_Taken); + pragma Inline (Alias); + pragma Inline (Alignment); + pragma Inline (Associated_Final_Chain); + pragma Inline (Associated_Formal_Package); + pragma Inline (Associated_Node_For_Itype); + pragma Inline (Associated_Storage_Pool); + pragma Inline (Barrier_Function); + pragma Inline (Block_Node); + pragma Inline (Body_Entity); + pragma Inline (Body_Needed_For_SAL); + pragma Inline (CR_Discriminant); + pragma Inline (C_Pass_By_Copy); + pragma Inline (Can_Never_Be_Null); + pragma Inline (Checks_May_Be_Suppressed); + pragma Inline (Class_Wide_Type); + pragma Inline (Cloned_Subtype); + pragma Inline (Component_Bit_Offset); + pragma Inline (Component_Clause); + pragma Inline (Component_Size); + pragma Inline (Component_Type); + pragma Inline (Corresponding_Concurrent_Type); + pragma Inline (Corresponding_Discriminant); + pragma Inline (Corresponding_Equality); + pragma Inline (Corresponding_Protected_Entry); + pragma Inline (Corresponding_Record_Type); + pragma Inline (Corresponding_Remote_Type); + pragma Inline (Current_Use_Clause); + pragma Inline (Current_Value); + pragma Inline (Debug_Info_Off); + pragma Inline (Debug_Renaming_Link); + pragma Inline (Dispatch_Table_Wrappers); + pragma Inline (DTC_Entity); + pragma Inline (DT_Entry_Count); + pragma Inline (DT_Offset_To_Top_Func); + pragma Inline (DT_Position); + pragma Inline (Default_Expr_Function); + pragma Inline (Default_Expressions_Processed); + pragma Inline (Default_Value); + pragma Inline (Delay_Cleanups); + pragma Inline (Delay_Subprogram_Descriptors); + pragma Inline (Delta_Value); + pragma Inline (Dependent_Instances); + pragma Inline (Depends_On_Private); + pragma Inline (Digits_Value); + pragma Inline (Direct_Primitive_Operations); + pragma Inline (Directly_Designated_Type); + pragma Inline (Discard_Names); + pragma Inline (Discriminal); + pragma Inline (Discriminal_Link); + pragma Inline (Discriminant_Checking_Func); + pragma Inline (Discriminant_Constraint); + pragma Inline (Discriminant_Default_Value); + pragma Inline (Discriminant_Number); + pragma Inline (Elaborate_Body_Desirable); + pragma Inline (Elaboration_Entity); + pragma Inline (Elaboration_Entity_Required); + pragma Inline (Enclosing_Scope); + pragma Inline (Entry_Accepted); + pragma Inline (Entry_Bodies_Array); + pragma Inline (Entry_Cancel_Parameter); + pragma Inline (Entry_Component); + pragma Inline (Entry_Formal); + pragma Inline (Entry_Index_Constant); + pragma Inline (Entry_Index_Type); + pragma Inline (Entry_Parameters_Type); + pragma Inline (Enum_Pos_To_Rep); + pragma Inline (Enumeration_Pos); + pragma Inline (Enumeration_Rep); + pragma Inline (Enumeration_Rep_Expr); + pragma Inline (Equivalent_Type); + pragma Inline (Esize); + pragma Inline (Exception_Code); + pragma Inline (Extra_Accessibility); + pragma Inline (Extra_Constrained); + pragma Inline (Extra_Formal); + pragma Inline (Extra_Formals); + pragma Inline (Can_Use_Internal_Rep); + pragma Inline (Finalization_Chain_Entity); + pragma Inline (First_Entity); + pragma Inline (First_Exit_Statement); + pragma Inline (First_Index); + pragma Inline (First_Literal); + pragma Inline (First_Optional_Parameter); + pragma Inline (First_Private_Entity); + pragma Inline (First_Rep_Item); + pragma Inline (Freeze_Node); + pragma Inline (From_With_Type); + pragma Inline (Full_View); + pragma Inline (Generic_Homonym); + pragma Inline (Generic_Renamings); + pragma Inline (Handler_Records); + pragma Inline (Has_Aliased_Components); + pragma Inline (Has_Alignment_Clause); + pragma Inline (Has_All_Calls_Remote); + pragma Inline (Has_Anon_Block_Suffix); + pragma Inline (Has_Atomic_Components); + pragma Inline (Has_Biased_Representation); + pragma Inline (Has_Completion); + pragma Inline (Has_Completion_In_Body); + pragma Inline (Has_Complex_Representation); + pragma Inline (Has_Component_Size_Clause); + pragma Inline (Has_Constrained_Partial_View); + pragma Inline (Has_Contiguous_Rep); + pragma Inline (Has_Controlled_Component); + pragma Inline (Has_Controlling_Result); + pragma Inline (Has_Convention_Pragma); + pragma Inline (Has_Delayed_Aspects); + pragma Inline (Has_Delayed_Freeze); + pragma Inline (Has_Discriminants); + pragma Inline (Has_Dispatch_Table); + pragma Inline (Has_Enumeration_Rep_Clause); + pragma Inline (Has_Exit); + pragma Inline (Has_External_Tag_Rep_Clause); + pragma Inline (Has_Fully_Qualified_Name); + pragma Inline (Has_Gigi_Rep_Item); + pragma Inline (Has_Homonym); + pragma Inline (Has_Inheritable_Invariants); + pragma Inline (Has_Initial_Value); + pragma Inline (Has_Invariants); + pragma Inline (Has_Machine_Radix_Clause); + pragma Inline (Has_Master_Entity); + pragma Inline (Has_Missing_Return); + pragma Inline (Has_Nested_Block_With_Handler); + pragma Inline (Has_Forward_Instantiation); + pragma Inline (Has_Non_Standard_Rep); + pragma Inline (Has_Object_Size_Clause); + pragma Inline (Has_Per_Object_Constraint); + pragma Inline (Has_Persistent_BSS); + pragma Inline (Has_Postconditions); + pragma Inline (Has_Pragma_Controlled); + pragma Inline (Has_Pragma_Elaborate_Body); + pragma Inline (Has_Pragma_Inline); + pragma Inline (Has_Pragma_Inline_Always); + pragma Inline (Has_Pragma_Ordered); + pragma Inline (Has_Pragma_Pack); + pragma Inline (Has_Pragma_Preelab_Init); + pragma Inline (Has_Pragma_Pure); + pragma Inline (Has_Pragma_Pure_Function); + pragma Inline (Has_Pragma_Thread_Local_Storage); + pragma Inline (Has_Pragma_Unmodified); + pragma Inline (Has_Pragma_Unreferenced); + pragma Inline (Has_Pragma_Unreferenced_Objects); + pragma Inline (Has_Predicates); + pragma Inline (Has_Primitive_Operations); + pragma Inline (Has_Private_Declaration); + pragma Inline (Has_Qualified_Name); + pragma Inline (Has_RACW); + pragma Inline (Has_Record_Rep_Clause); + pragma Inline (Has_Recursive_Call); + pragma Inline (Has_Size_Clause); + pragma Inline (Has_Small_Clause); + pragma Inline (Has_Specified_Layout); + pragma Inline (Has_Specified_Stream_Input); + pragma Inline (Has_Specified_Stream_Output); + pragma Inline (Has_Specified_Stream_Read); + pragma Inline (Has_Specified_Stream_Write); + pragma Inline (Has_Static_Discriminants); + pragma Inline (Has_Storage_Size_Clause); + pragma Inline (Has_Stream_Size_Clause); + pragma Inline (Has_Subprogram_Descriptor); + pragma Inline (Has_Task); + pragma Inline (Has_Thunks); + pragma Inline (Has_Unchecked_Union); + pragma Inline (Has_Unknown_Discriminants); + pragma Inline (Has_Up_Level_Access); + pragma Inline (Has_Volatile_Components); + pragma Inline (Has_Xref_Entry); + pragma Inline (Hiding_Loop_Variable); + pragma Inline (Homonym); + pragma Inline (Interfaces); + pragma Inline (In_Package_Body); + pragma Inline (In_Private_Part); + pragma Inline (In_Use); + pragma Inline (Inner_Instances); + pragma Inline (Interface_Alias); + pragma Inline (Interface_Name); + pragma Inline (Is_AST_Entry); + pragma Inline (Is_Abstract_Subprogram); + pragma Inline (Is_Abstract_Type); + pragma Inline (Is_Access_Constant); + pragma Inline (Is_Ada_2005_Only); + pragma Inline (Is_Ada_2012_Only); + pragma Inline (Is_Access_Type); + pragma Inline (Is_Access_Protected_Subprogram_Type); + pragma Inline (Is_Access_Subprogram_Type); + pragma Inline (Is_Aggregate_Type); + pragma Inline (Is_Aliased); + pragma Inline (Is_Array_Type); + pragma Inline (Is_Assignable); + pragma Inline (Is_Asynchronous); + pragma Inline (Is_Atomic); + pragma Inline (Is_Bit_Packed_Array); + pragma Inline (Is_CPP_Class); + pragma Inline (Is_Called); + pragma Inline (Is_Character_Type); + pragma Inline (Is_Child_Unit); + pragma Inline (Is_Class_Wide_Equivalent_Type); + pragma Inline (Is_Class_Wide_Type); + pragma Inline (Is_Compilation_Unit); + pragma Inline (Is_Completely_Hidden); + pragma Inline (Is_Composite_Type); + pragma Inline (Is_Concurrent_Body); + pragma Inline (Is_Concurrent_Record_Type); + pragma Inline (Is_Concurrent_Type); + pragma Inline (Is_Constr_Subt_For_UN_Aliased); + pragma Inline (Is_Constr_Subt_For_U_Nominal); + pragma Inline (Is_Constrained); + pragma Inline (Is_Constructor); + pragma Inline (Is_Controlled); + pragma Inline (Is_Controlling_Formal); + pragma Inline (Is_Decimal_Fixed_Point_Type); + pragma Inline (Is_Discrim_SO_Function); + pragma Inline (Is_Digits_Type); + pragma Inline (Is_Descendent_Of_Address); + pragma Inline (Is_Discrete_Or_Fixed_Point_Type); + pragma Inline (Is_Discrete_Type); + pragma Inline (Is_Dispatch_Table_Entity); + pragma Inline (Is_Dispatching_Operation); + pragma Inline (Is_Elementary_Type); + pragma Inline (Is_Eliminated); + pragma Inline (Is_Entry); + pragma Inline (Is_Entry_Formal); + pragma Inline (Is_Enumeration_Type); + pragma Inline (Is_Exported); + pragma Inline (Is_First_Subtype); + pragma Inline (Is_Fixed_Point_Type); + pragma Inline (Is_Floating_Point_Type); + pragma Inline (Is_For_Access_Subtype); + pragma Inline (Is_Formal); + pragma Inline (Is_Formal_Object); + pragma Inline (Is_Formal_Subprogram); + pragma Inline (Is_Frozen); + pragma Inline (Is_Generic_Actual_Type); + pragma Inline (Is_Generic_Instance); + pragma Inline (Is_Generic_Subprogram); + pragma Inline (Is_Generic_Type); + pragma Inline (Is_Generic_Unit); + pragma Inline (Is_Hidden); + pragma Inline (Is_Hidden_Open_Scope); + pragma Inline (Is_Immediately_Visible); + pragma Inline (Is_Imported); + pragma Inline (Is_Incomplete_Or_Private_Type); + pragma Inline (Is_Incomplete_Type); + pragma Inline (Is_Inlined); + pragma Inline (Is_Interface); + pragma Inline (Is_Instantiated); + pragma Inline (Is_Integer_Type); + pragma Inline (Is_Internal); + pragma Inline (Is_Interrupt_Handler); + pragma Inline (Is_Intrinsic_Subprogram); + pragma Inline (Is_Itype); + pragma Inline (Is_Known_Non_Null); + pragma Inline (Is_Known_Null); + pragma Inline (Is_Known_Valid); + pragma Inline (Is_Limited_Composite); + pragma Inline (Is_Limited_Interface); + pragma Inline (Is_Limited_Record); + pragma Inline (Is_Local_Anonymous_Access); + pragma Inline (Is_Machine_Code_Subprogram); + pragma Inline (Is_Modular_Integer_Type); + pragma Inline (Is_Named_Number); + pragma Inline (Is_Non_Static_Subtype); + pragma Inline (Is_Null_Init_Proc); + pragma Inline (Is_Obsolescent); + pragma Inline (Is_Only_Out_Parameter); + pragma Inline (Is_Numeric_Type); + pragma Inline (Is_Object); + pragma Inline (Is_Optional_Parameter); + pragma Inline (Is_Package_Body_Entity); + pragma Inline (Is_Ordinary_Fixed_Point_Type); + pragma Inline (Is_Overloadable); + pragma Inline (Is_Packed); + pragma Inline (Is_Packed_Array_Type); + pragma Inline (Is_Potentially_Use_Visible); + pragma Inline (Is_Preelaborated); + pragma Inline (Is_Primitive); + pragma Inline (Is_Primitive_Wrapper); + pragma Inline (Is_Private_Composite); + pragma Inline (Is_Private_Descendant); + pragma Inline (Is_Private_Primitive); + pragma Inline (Is_Private_Type); + pragma Inline (Is_Protected_Type); + pragma Inline (Is_Public); + pragma Inline (Is_Pure); + pragma Inline (Is_Pure_Unit_Access_Type); + pragma Inline (Is_RACW_Stub_Type); + pragma Inline (Is_Raised); + pragma Inline (Is_Real_Type); + pragma Inline (Is_Record_Type); + pragma Inline (Is_Remote_Call_Interface); + pragma Inline (Is_Remote_Types); + pragma Inline (Is_Renaming_Of_Object); + pragma Inline (Is_Return_Object); + pragma Inline (Is_Scalar_Type); + pragma Inline (Is_Shared_Passive); + pragma Inline (Is_Signed_Integer_Type); + pragma Inline (Is_Statically_Allocated); + pragma Inline (Is_Subprogram); + pragma Inline (Is_Tag); + pragma Inline (Is_Tagged_Type); + pragma Inline (Is_True_Constant); + pragma Inline (Is_Task_Type); + pragma Inline (Is_Thunk); + pragma Inline (Is_Trivial_Subprogram); + pragma Inline (Is_Type); + pragma Inline (Is_Unchecked_Union); + pragma Inline (Is_Underlying_Record_View); + pragma Inline (Is_Unsigned_Type); + pragma Inline (Is_VMS_Exception); + pragma Inline (Is_Valued_Procedure); + pragma Inline (Is_Visible_Child_Unit); + pragma Inline (Is_Visible_Formal); + pragma Inline (Itype_Printed); + pragma Inline (Kill_Elaboration_Checks); + pragma Inline (Kill_Range_Checks); + pragma Inline (Kill_Tag_Checks); + pragma Inline (Known_To_Have_Preelab_Init); + pragma Inline (Last_Assignment); + pragma Inline (Last_Entity); + pragma Inline (Limited_View); + pragma Inline (Lit_Indexes); + pragma Inline (Lit_Strings); + pragma Inline (Low_Bound_Tested); + pragma Inline (Machine_Radix_10); + pragma Inline (Master_Id); + pragma Inline (Materialize_Entity); + pragma Inline (Mechanism); + pragma Inline (Modulus); + pragma Inline (Must_Be_On_Byte_Boundary); + pragma Inline (Must_Have_Preelab_Init); + pragma Inline (Needs_Debug_Info); + pragma Inline (Needs_No_Actuals); + pragma Inline (Never_Set_In_Source); + pragma Inline (Next_Index); + pragma Inline (Next_Inlined_Subprogram); + pragma Inline (Next_Literal); + pragma Inline (No_Pool_Assigned); + pragma Inline (No_Return); + pragma Inline (No_Strict_Aliasing); + pragma Inline (Non_Binary_Modulus); + pragma Inline (Non_Limited_View); + pragma Inline (Nonzero_Is_True); + pragma Inline (Normalized_First_Bit); + pragma Inline (Normalized_Position); + pragma Inline (Normalized_Position_Max); + pragma Inline (OK_To_Rename); + pragma Inline (OK_To_Reorder_Components); + pragma Inline (Optimize_Alignment_Space); + pragma Inline (Optimize_Alignment_Time); + pragma Inline (Original_Array_Type); + pragma Inline (Original_Record_Component); + pragma Inline (Overlays_Constant); + pragma Inline (Overridden_Operation); + pragma Inline (Package_Instantiation); + pragma Inline (Packed_Array_Type); + pragma Inline (Parameter_Mode); + pragma Inline (Parent_Subtype); + pragma Inline (Postcondition_Proc); + pragma Inline (PPC_Wrapper); + pragma Inline (Prival); + pragma Inline (Prival_Link); + pragma Inline (Private_Dependents); + pragma Inline (Private_View); + pragma Inline (Protected_Body_Subprogram); + pragma Inline (Protected_Formal); + pragma Inline (Protection_Object); + pragma Inline (RM_Size); + pragma Inline (Reachable); + pragma Inline (Referenced); + pragma Inline (Referenced_As_LHS); + pragma Inline (Referenced_As_Out_Parameter); + pragma Inline (Register_Exception_Call); + pragma Inline (Related_Array_Object); + pragma Inline (Related_Expression); + pragma Inline (Related_Instance); + pragma Inline (Related_Type); + pragma Inline (Relative_Deadline_Variable); + pragma Inline (Renamed_Entity); + pragma Inline (Renamed_In_Spec); + pragma Inline (Renamed_Object); + pragma Inline (Renaming_Map); + pragma Inline (Requires_Overriding); + pragma Inline (Return_Present); + pragma Inline (Return_Applies_To); + pragma Inline (Returns_By_Ref); + pragma Inline (Reverse_Bit_Order); + pragma Inline (Scalar_Range); + pragma Inline (Scale_Value); + pragma Inline (Scope_Depth_Value); + pragma Inline (Sec_Stack_Needed_For_Return); + pragma Inline (Shadow_Entities); + pragma Inline (Shared_Var_Procs_Instance); + pragma Inline (Size_Check_Code); + pragma Inline (Size_Depends_On_Discriminant); + pragma Inline (Size_Known_At_Compile_Time); + pragma Inline (Small_Value); + pragma Inline (Spec_Entity); + pragma Inline (Spec_PPC_List); + pragma Inline (Static_Predicate); + pragma Inline (Storage_Size_Variable); + pragma Inline (Static_Elaboration_Desired); + pragma Inline (Static_Initialization); + pragma Inline (Stored_Constraint); + pragma Inline (Strict_Alignment); + pragma Inline (String_Literal_Length); + pragma Inline (String_Literal_Low_Bound); + pragma Inline (Subprograms_For_Type); + pragma Inline (Suppress_Elaboration_Warnings); + pragma Inline (Suppress_Init_Proc); + pragma Inline (Suppress_Style_Checks); + pragma Inline (Suppress_Value_Tracking_On_Call); + pragma Inline (Task_Body_Procedure); + pragma Inline (Treat_As_Volatile); + pragma Inline (Underlying_Full_View); + pragma Inline (Underlying_Record_View); + pragma Inline (Universal_Aliasing); + pragma Inline (Unset_Reference); + pragma Inline (Used_As_Generic_Actual); + pragma Inline (Uses_Sec_Stack); + pragma Inline (Warnings_Off); + pragma Inline (Warnings_Off_Used); + pragma Inline (Warnings_Off_Used_Unmodified); + pragma Inline (Warnings_Off_Used_Unreferenced); + pragma Inline (Was_Hidden); + pragma Inline (Wrapped_Entity); + + pragma Inline (Init_Alignment); + pragma Inline (Init_Component_Bit_Offset); + pragma Inline (Init_Component_Size); + pragma Inline (Init_Digits_Value); + pragma Inline (Init_Esize); + pragma Inline (Init_RM_Size); + + pragma Inline (Set_Accept_Address); + pragma Inline (Set_Access_Disp_Table); + pragma Inline (Set_Actual_Subtype); + pragma Inline (Set_Address_Taken); + pragma Inline (Set_Alias); + pragma Inline (Set_Alignment); + pragma Inline (Set_Associated_Final_Chain); + pragma Inline (Set_Associated_Formal_Package); + pragma Inline (Set_Associated_Node_For_Itype); + pragma Inline (Set_Associated_Storage_Pool); + pragma Inline (Set_Barrier_Function); + pragma Inline (Set_Block_Node); + pragma Inline (Set_Body_Entity); + pragma Inline (Set_Body_Needed_For_SAL); + pragma Inline (Set_CR_Discriminant); + pragma Inline (Set_C_Pass_By_Copy); + pragma Inline (Set_Can_Never_Be_Null); + pragma Inline (Set_Checks_May_Be_Suppressed); + pragma Inline (Set_Class_Wide_Type); + pragma Inline (Set_Cloned_Subtype); + pragma Inline (Set_Component_Bit_Offset); + pragma Inline (Set_Component_Clause); + pragma Inline (Set_Component_Size); + pragma Inline (Set_Component_Type); + pragma Inline (Set_Corresponding_Concurrent_Type); + pragma Inline (Set_Corresponding_Discriminant); + pragma Inline (Set_Corresponding_Equality); + pragma Inline (Set_Corresponding_Protected_Entry); + pragma Inline (Set_Corresponding_Record_Type); + pragma Inline (Set_Corresponding_Remote_Type); + pragma Inline (Set_Current_Use_Clause); + pragma Inline (Set_Current_Value); + pragma Inline (Set_Debug_Info_Off); + pragma Inline (Set_Debug_Renaming_Link); + pragma Inline (Set_Dispatch_Table_Wrappers); + pragma Inline (Set_DTC_Entity); + pragma Inline (Set_DT_Entry_Count); + pragma Inline (Set_DT_Offset_To_Top_Func); + pragma Inline (Set_DT_Position); + pragma Inline (Set_Relative_Deadline_Variable); + pragma Inline (Set_Default_Expr_Function); + pragma Inline (Set_Default_Expressions_Processed); + pragma Inline (Set_Default_Value); + pragma Inline (Set_Delay_Cleanups); + pragma Inline (Set_Delay_Subprogram_Descriptors); + pragma Inline (Set_Delta_Value); + pragma Inline (Set_Dependent_Instances); + pragma Inline (Set_Depends_On_Private); + pragma Inline (Set_Digits_Value); + pragma Inline (Set_Direct_Primitive_Operations); + pragma Inline (Set_Directly_Designated_Type); + pragma Inline (Set_Discard_Names); + pragma Inline (Set_Discriminal); + pragma Inline (Set_Discriminal_Link); + pragma Inline (Set_Discriminant_Checking_Func); + pragma Inline (Set_Discriminant_Constraint); + pragma Inline (Set_Discriminant_Default_Value); + pragma Inline (Set_Discriminant_Number); + pragma Inline (Set_Elaborate_Body_Desirable); + pragma Inline (Set_Elaboration_Entity); + pragma Inline (Set_Elaboration_Entity_Required); + pragma Inline (Set_Enclosing_Scope); + pragma Inline (Set_Entry_Accepted); + pragma Inline (Set_Entry_Bodies_Array); + pragma Inline (Set_Entry_Cancel_Parameter); + pragma Inline (Set_Entry_Component); + pragma Inline (Set_Entry_Formal); + pragma Inline (Set_Entry_Parameters_Type); + pragma Inline (Set_Enum_Pos_To_Rep); + pragma Inline (Set_Enumeration_Pos); + pragma Inline (Set_Enumeration_Rep); + pragma Inline (Set_Enumeration_Rep_Expr); + pragma Inline (Set_Equivalent_Type); + pragma Inline (Set_Esize); + pragma Inline (Set_Exception_Code); + pragma Inline (Set_Extra_Accessibility); + pragma Inline (Set_Extra_Constrained); + pragma Inline (Set_Extra_Formal); + pragma Inline (Set_Extra_Formals); + pragma Inline (Set_Can_Use_Internal_Rep); + pragma Inline (Set_Finalization_Chain_Entity); + pragma Inline (Set_First_Entity); + pragma Inline (Set_First_Exit_Statement); + pragma Inline (Set_First_Index); + pragma Inline (Set_First_Literal); + pragma Inline (Set_First_Optional_Parameter); + pragma Inline (Set_First_Private_Entity); + pragma Inline (Set_First_Rep_Item); + pragma Inline (Set_Freeze_Node); + pragma Inline (Set_From_With_Type); + pragma Inline (Set_Full_View); + pragma Inline (Set_Generic_Homonym); + pragma Inline (Set_Generic_Renamings); + pragma Inline (Set_Handler_Records); + pragma Inline (Set_Has_Aliased_Components); + pragma Inline (Set_Has_Alignment_Clause); + pragma Inline (Set_Has_All_Calls_Remote); + pragma Inline (Set_Has_Anon_Block_Suffix); + pragma Inline (Set_Has_Atomic_Components); + pragma Inline (Set_Has_Biased_Representation); + pragma Inline (Set_Has_Completion); + pragma Inline (Set_Has_Completion_In_Body); + pragma Inline (Set_Has_Complex_Representation); + pragma Inline (Set_Has_Component_Size_Clause); + pragma Inline (Set_Has_Constrained_Partial_View); + pragma Inline (Set_Has_Contiguous_Rep); + pragma Inline (Set_Has_Controlled_Component); + pragma Inline (Set_Has_Controlling_Result); + pragma Inline (Set_Has_Convention_Pragma); + pragma Inline (Set_Has_Delayed_Aspects); + pragma Inline (Set_Has_Delayed_Freeze); + pragma Inline (Set_Has_Discriminants); + pragma Inline (Set_Has_Dispatch_Table); + pragma Inline (Set_Has_Enumeration_Rep_Clause); + pragma Inline (Set_Has_Exit); + pragma Inline (Set_Has_External_Tag_Rep_Clause); + pragma Inline (Set_Has_Fully_Qualified_Name); + pragma Inline (Set_Has_Gigi_Rep_Item); + pragma Inline (Set_Has_Homonym); + pragma Inline (Set_Has_Inheritable_Invariants); + pragma Inline (Set_Has_Initial_Value); + pragma Inline (Set_Has_Invariants); + pragma Inline (Set_Has_Machine_Radix_Clause); + pragma Inline (Set_Has_Master_Entity); + pragma Inline (Set_Has_Missing_Return); + pragma Inline (Set_Has_Nested_Block_With_Handler); + pragma Inline (Set_Has_Forward_Instantiation); + pragma Inline (Set_Has_Non_Standard_Rep); + pragma Inline (Set_Has_Object_Size_Clause); + pragma Inline (Set_Has_Per_Object_Constraint); + pragma Inline (Set_Has_Persistent_BSS); + pragma Inline (Set_Has_Postconditions); + pragma Inline (Set_Has_Pragma_Controlled); + pragma Inline (Set_Has_Pragma_Elaborate_Body); + pragma Inline (Set_Has_Pragma_Inline); + pragma Inline (Set_Has_Pragma_Inline_Always); + pragma Inline (Set_Has_Pragma_Ordered); + pragma Inline (Set_Has_Pragma_Pack); + pragma Inline (Set_Has_Pragma_Preelab_Init); + pragma Inline (Set_Has_Pragma_Pure); + pragma Inline (Set_Has_Pragma_Pure_Function); + pragma Inline (Set_Has_Pragma_Thread_Local_Storage); + pragma Inline (Set_Has_Pragma_Unmodified); + pragma Inline (Set_Has_Pragma_Unreferenced); + pragma Inline (Set_Has_Pragma_Unreferenced_Objects); + pragma Inline (Set_Has_Predicates); + pragma Inline (Set_Has_Primitive_Operations); + pragma Inline (Set_Has_Private_Declaration); + pragma Inline (Set_Has_Qualified_Name); + pragma Inline (Set_Has_RACW); + pragma Inline (Set_Has_Record_Rep_Clause); + pragma Inline (Set_Has_Recursive_Call); + pragma Inline (Set_Has_Size_Clause); + pragma Inline (Set_Has_Small_Clause); + pragma Inline (Set_Has_Specified_Layout); + pragma Inline (Set_Has_Specified_Stream_Input); + pragma Inline (Set_Has_Specified_Stream_Output); + pragma Inline (Set_Has_Specified_Stream_Read); + pragma Inline (Set_Has_Specified_Stream_Write); + pragma Inline (Set_Has_Static_Discriminants); + pragma Inline (Set_Has_Storage_Size_Clause); + pragma Inline (Set_Has_Stream_Size_Clause); + pragma Inline (Set_Has_Subprogram_Descriptor); + pragma Inline (Set_Has_Task); + pragma Inline (Set_Has_Thunks); + pragma Inline (Set_Has_Unchecked_Union); + pragma Inline (Set_Has_Unknown_Discriminants); + pragma Inline (Set_Has_Up_Level_Access); + pragma Inline (Set_Has_Volatile_Components); + pragma Inline (Set_Has_Xref_Entry); + pragma Inline (Set_Hiding_Loop_Variable); + pragma Inline (Set_Homonym); + pragma Inline (Set_Interfaces); + pragma Inline (Set_In_Package_Body); + pragma Inline (Set_In_Private_Part); + pragma Inline (Set_In_Use); + pragma Inline (Set_Inner_Instances); + pragma Inline (Set_Interface_Alias); + pragma Inline (Set_Interface_Name); + pragma Inline (Set_Is_AST_Entry); + pragma Inline (Set_Is_Abstract_Subprogram); + pragma Inline (Set_Is_Abstract_Type); + pragma Inline (Set_Is_Access_Constant); + pragma Inline (Set_Is_Ada_2005_Only); + pragma Inline (Set_Is_Ada_2012_Only); + pragma Inline (Set_Is_Aliased); + pragma Inline (Set_Is_Asynchronous); + pragma Inline (Set_Is_Atomic); + pragma Inline (Set_Is_Bit_Packed_Array); + pragma Inline (Set_Is_CPP_Class); + pragma Inline (Set_Is_Called); + pragma Inline (Set_Is_Character_Type); + pragma Inline (Set_Is_Child_Unit); + pragma Inline (Set_Is_Class_Wide_Equivalent_Type); + pragma Inline (Set_Is_Compilation_Unit); + pragma Inline (Set_Is_Completely_Hidden); + pragma Inline (Set_Is_Concurrent_Record_Type); + pragma Inline (Set_Is_Constr_Subt_For_U_Nominal); + pragma Inline (Set_Is_Constr_Subt_For_UN_Aliased); + pragma Inline (Set_Is_Constrained); + pragma Inline (Set_Is_Constructor); + pragma Inline (Set_Is_Controlled); + pragma Inline (Set_Is_Controlling_Formal); + pragma Inline (Set_Is_Descendent_Of_Address); + pragma Inline (Set_Is_Discrim_SO_Function); + pragma Inline (Set_Is_Dispatch_Table_Entity); + pragma Inline (Set_Is_Dispatching_Operation); + pragma Inline (Set_Is_Eliminated); + pragma Inline (Set_Is_Entry_Formal); + pragma Inline (Set_Is_Exported); + pragma Inline (Set_Is_First_Subtype); + pragma Inline (Set_Is_For_Access_Subtype); + pragma Inline (Set_Is_Formal_Subprogram); + pragma Inline (Set_Is_Frozen); + pragma Inline (Set_Is_Generic_Actual_Type); + pragma Inline (Set_Is_Generic_Instance); + pragma Inline (Set_Is_Generic_Type); + pragma Inline (Set_Is_Hidden); + pragma Inline (Set_Is_Hidden_Open_Scope); + pragma Inline (Set_Is_Immediately_Visible); + pragma Inline (Set_Is_Imported); + pragma Inline (Set_Is_Inlined); + pragma Inline (Set_Is_Interface); + pragma Inline (Set_Is_Instantiated); + pragma Inline (Set_Is_Internal); + pragma Inline (Set_Is_Interrupt_Handler); + pragma Inline (Set_Is_Intrinsic_Subprogram); + pragma Inline (Set_Is_Itype); + pragma Inline (Set_Is_Known_Non_Null); + pragma Inline (Set_Is_Known_Null); + pragma Inline (Set_Is_Known_Valid); + pragma Inline (Set_Is_Limited_Composite); + pragma Inline (Set_Is_Limited_Interface); + pragma Inline (Set_Is_Limited_Record); + pragma Inline (Set_Is_Local_Anonymous_Access); + pragma Inline (Set_Is_Machine_Code_Subprogram); + pragma Inline (Set_Is_Non_Static_Subtype); + pragma Inline (Set_Is_Null_Init_Proc); + pragma Inline (Set_Is_Obsolescent); + pragma Inline (Set_Is_Only_Out_Parameter); + pragma Inline (Set_Is_Optional_Parameter); + pragma Inline (Set_Is_Package_Body_Entity); + pragma Inline (Set_Is_Packed); + pragma Inline (Set_Is_Packed_Array_Type); + pragma Inline (Set_Is_Potentially_Use_Visible); + pragma Inline (Set_Is_Preelaborated); + pragma Inline (Set_Is_Primitive); + pragma Inline (Set_Is_Primitive_Wrapper); + pragma Inline (Set_Is_Private_Composite); + pragma Inline (Set_Is_Private_Descendant); + pragma Inline (Set_Is_Private_Primitive); + pragma Inline (Set_Is_Public); + pragma Inline (Set_Is_Pure); + pragma Inline (Set_Is_Pure_Unit_Access_Type); + pragma Inline (Set_Is_RACW_Stub_Type); + pragma Inline (Set_Is_Raised); + pragma Inline (Set_Is_Remote_Call_Interface); + pragma Inline (Set_Is_Remote_Types); + pragma Inline (Set_Is_Renaming_Of_Object); + pragma Inline (Set_Is_Return_Object); + pragma Inline (Set_Is_Shared_Passive); + pragma Inline (Set_Is_Statically_Allocated); + pragma Inline (Set_Is_Tag); + pragma Inline (Set_Is_Tagged_Type); + pragma Inline (Set_Is_Thunk); + pragma Inline (Set_Is_Trivial_Subprogram); + pragma Inline (Set_Is_True_Constant); + pragma Inline (Set_Is_Unchecked_Union); + pragma Inline (Set_Is_Underlying_Record_View); + pragma Inline (Set_Is_Unsigned_Type); + pragma Inline (Set_Is_VMS_Exception); + pragma Inline (Set_Is_Valued_Procedure); + pragma Inline (Set_Is_Visible_Child_Unit); + pragma Inline (Set_Is_Visible_Formal); + pragma Inline (Set_Is_Volatile); + pragma Inline (Set_Itype_Printed); + pragma Inline (Set_Kill_Elaboration_Checks); + pragma Inline (Set_Kill_Range_Checks); + pragma Inline (Set_Kill_Tag_Checks); + pragma Inline (Set_Known_To_Have_Preelab_Init); + pragma Inline (Set_Last_Assignment); + pragma Inline (Set_Last_Entity); + pragma Inline (Set_Limited_View); + pragma Inline (Set_Lit_Indexes); + pragma Inline (Set_Lit_Strings); + pragma Inline (Set_Low_Bound_Tested); + pragma Inline (Set_Machine_Radix_10); + pragma Inline (Set_Master_Id); + pragma Inline (Set_Materialize_Entity); + pragma Inline (Set_Mechanism); + pragma Inline (Set_Modulus); + pragma Inline (Set_Must_Be_On_Byte_Boundary); + pragma Inline (Set_Must_Have_Preelab_Init); + pragma Inline (Set_Needs_Debug_Info); + pragma Inline (Set_Needs_No_Actuals); + pragma Inline (Set_Never_Set_In_Source); + pragma Inline (Set_Next_Inlined_Subprogram); + pragma Inline (Set_No_Pool_Assigned); + pragma Inline (Set_No_Return); + pragma Inline (Set_No_Strict_Aliasing); + pragma Inline (Set_Non_Binary_Modulus); + pragma Inline (Set_Non_Limited_View); + pragma Inline (Set_Nonzero_Is_True); + pragma Inline (Set_Normalized_First_Bit); + pragma Inline (Set_Normalized_Position); + pragma Inline (Set_Normalized_Position_Max); + pragma Inline (Set_OK_To_Reorder_Components); + pragma Inline (Set_OK_To_Rename); + pragma Inline (Set_Optimize_Alignment_Space); + pragma Inline (Set_Optimize_Alignment_Time); + pragma Inline (Set_Original_Array_Type); + pragma Inline (Set_Original_Record_Component); + pragma Inline (Set_Overlays_Constant); + pragma Inline (Set_Overridden_Operation); + pragma Inline (Set_Package_Instantiation); + pragma Inline (Set_Packed_Array_Type); + pragma Inline (Set_Parent_Subtype); + pragma Inline (Set_Postcondition_Proc); + pragma Inline (Set_PPC_Wrapper); + pragma Inline (Set_Prival); + pragma Inline (Set_Prival_Link); + pragma Inline (Set_Private_Dependents); + pragma Inline (Set_Private_View); + pragma Inline (Set_Protected_Body_Subprogram); + pragma Inline (Set_Protected_Formal); + pragma Inline (Set_Protection_Object); + pragma Inline (Set_RM_Size); + pragma Inline (Set_Reachable); + pragma Inline (Set_Referenced); + pragma Inline (Set_Referenced_As_LHS); + pragma Inline (Set_Referenced_As_Out_Parameter); + pragma Inline (Set_Register_Exception_Call); + pragma Inline (Set_Related_Array_Object); + pragma Inline (Set_Related_Expression); + pragma Inline (Set_Related_Instance); + pragma Inline (Set_Related_Type); + pragma Inline (Set_Renamed_Entity); + pragma Inline (Set_Renamed_In_Spec); + pragma Inline (Set_Renamed_Object); + pragma Inline (Set_Renaming_Map); + pragma Inline (Set_Requires_Overriding); + pragma Inline (Set_Return_Present); + pragma Inline (Set_Return_Applies_To); + pragma Inline (Set_Returns_By_Ref); + pragma Inline (Set_Reverse_Bit_Order); + pragma Inline (Set_Scalar_Range); + pragma Inline (Set_Scale_Value); + pragma Inline (Set_Scope_Depth_Value); + pragma Inline (Set_Sec_Stack_Needed_For_Return); + pragma Inline (Set_Shadow_Entities); + pragma Inline (Set_Shared_Var_Procs_Instance); + pragma Inline (Set_Size_Check_Code); + pragma Inline (Set_Size_Depends_On_Discriminant); + pragma Inline (Set_Size_Known_At_Compile_Time); + pragma Inline (Set_Small_Value); + pragma Inline (Set_Spec_Entity); + pragma Inline (Set_Spec_PPC_List); + pragma Inline (Set_Static_Predicate); + pragma Inline (Set_Storage_Size_Variable); + pragma Inline (Set_Static_Elaboration_Desired); + pragma Inline (Set_Static_Initialization); + pragma Inline (Set_Stored_Constraint); + pragma Inline (Set_Strict_Alignment); + pragma Inline (Set_String_Literal_Length); + pragma Inline (Set_String_Literal_Low_Bound); + pragma Inline (Set_Subprograms_For_Type); + pragma Inline (Set_Suppress_Elaboration_Warnings); + pragma Inline (Set_Suppress_Init_Proc); + pragma Inline (Set_Suppress_Style_Checks); + pragma Inline (Set_Suppress_Value_Tracking_On_Call); + pragma Inline (Set_Task_Body_Procedure); + pragma Inline (Set_Treat_As_Volatile); + pragma Inline (Set_Underlying_Full_View); + pragma Inline (Set_Underlying_Record_View); + pragma Inline (Set_Universal_Aliasing); + pragma Inline (Set_Unset_Reference); + pragma Inline (Set_Used_As_Generic_Actual); + pragma Inline (Set_Uses_Sec_Stack); + pragma Inline (Set_Warnings_Off); + pragma Inline (Set_Warnings_Off_Used); + pragma Inline (Set_Warnings_Off_Used_Unmodified); + pragma Inline (Set_Warnings_Off_Used_Unreferenced); + pragma Inline (Set_Was_Hidden); + pragma Inline (Set_Wrapped_Entity); + + -- END XEINFO INLINES + + -- The following Inline pragmas are *not* read by xeinfo when building + -- the C version of this interface automatically (so the C version will + -- end up making out of line calls). The pragma scan in xeinfo will be + -- terminated on encountering the END XEINFO INLINES line. We inline + -- things here which are small, but not of the canonical attribute + -- access/set format that can be handled by xeinfo. + + pragma Inline (Is_Base_Type); + pragma Inline (Is_Package_Or_Generic_Package); + pragma Inline (Is_Volatile); + pragma Inline (Is_Wrapper_Package); + pragma Inline (Known_RM_Size); + pragma Inline (Known_Static_Component_Bit_Offset); + pragma Inline (Known_Static_RM_Size); + pragma Inline (Scope_Depth); + pragma Inline (Scope_Depth_Set); + pragma Inline (Unknown_RM_Size); + +end Einfo; diff --git a/gcc/ada/elists.adb b/gcc/ada/elists.adb new file mode 100644 index 000000000..58beb00d5 --- /dev/null +++ b/gcc/ada/elists.adb @@ -0,0 +1,492 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E L I S T 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. -- +-- -- +------------------------------------------------------------------------------ + +-- WARNING: There is a C version of this package. Any changes to this +-- source file must be properly reflected in the C header a-elists.h. + +with Alloc; +with Debug; use Debug; +with Output; use Output; +with Table; + +package body Elists is + + ------------------------------------- + -- Implementation of Element Lists -- + ------------------------------------- + + -- Element lists are composed of three types of entities. The element + -- list header, which references the first and last elements of the + -- list, the elements themselves which are singly linked and also + -- reference the nodes on the list, and finally the nodes themselves. + -- The following diagram shows how an element list is represented: + + -- +----------------------------------------------------+ + -- | +------------------------------------------+ | + -- | | | | + -- V | V | + -- +-----|--+ +-------+ +-------+ +-------+ | + -- | Elmt | | 1st | | 2nd | | Last | | + -- | List |--->| Elmt |--->| Elmt ---...-->| Elmt ---+ + -- | Header | | | | | | | | | | + -- +--------+ +---|---+ +---|---+ +---|---+ + -- | | | + -- V V V + -- +-------+ +-------+ +-------+ + -- | | | | | | + -- | Node1 | | Node2 | | Node3 | + -- | | | | | | + -- +-------+ +-------+ +-------+ + + -- The list header is an entry in the Elists table. The values used for + -- the type Elist_Id are subscripts into this table. The First_Elmt field + -- (Lfield1) points to the first element on the list, or to No_Elmt in the + -- case of an empty list. Similarly the Last_Elmt field (Lfield2) points to + -- the last element on the list or to No_Elmt in the case of an empty list. + + -- The elements themselves are entries in the Elmts table. The Next field + -- of each entry points to the next element, or to the Elist header if this + -- is the last item in the list. The Node field points to the node which + -- is referenced by the corresponding list entry. + + ------------------------- + -- Element List Tables -- + ------------------------- + + type Elist_Header is record + First : Elmt_Id; + Last : Elmt_Id; + end record; + + package Elists is new Table.Table ( + Table_Component_Type => Elist_Header, + Table_Index_Type => Elist_Id'Base, + Table_Low_Bound => First_Elist_Id, + Table_Initial => Alloc.Elists_Initial, + Table_Increment => Alloc.Elists_Increment, + Table_Name => "Elists"); + + type Elmt_Item is record + Node : Node_Or_Entity_Id; + Next : Union_Id; + end record; + + package Elmts is new Table.Table ( + Table_Component_Type => Elmt_Item, + Table_Index_Type => Elmt_Id'Base, + Table_Low_Bound => First_Elmt_Id, + Table_Initial => Alloc.Elmts_Initial, + Table_Increment => Alloc.Elmts_Increment, + Table_Name => "Elmts"); + + ----------------- + -- Append_Elmt -- + ----------------- + + procedure Append_Elmt (N : Node_Or_Entity_Id; To : Elist_Id) is + L : constant Elmt_Id := Elists.Table (To).Last; + + begin + Elmts.Increment_Last; + Elmts.Table (Elmts.Last).Node := N; + Elmts.Table (Elmts.Last).Next := Union_Id (To); + + if L = No_Elmt then + Elists.Table (To).First := Elmts.Last; + else + Elmts.Table (L).Next := Union_Id (Elmts.Last); + end if; + + Elists.Table (To).Last := Elmts.Last; + + if Debug_Flag_N then + Write_Str ("Append new element Elmt_Id = "); + Write_Int (Int (Elmts.Last)); + Write_Str (" to list Elist_Id = "); + Write_Int (Int (To)); + Write_Str (" referencing Node_Or_Entity_Id = "); + Write_Int (Int (N)); + Write_Eol; + end if; + end Append_Elmt; + + ------------------------ + -- Append_Unique_Elmt -- + ------------------------ + + procedure Append_Unique_Elmt (N : Node_Or_Entity_Id; To : Elist_Id) is + Elmt : Elmt_Id; + begin + Elmt := First_Elmt (To); + loop + if No (Elmt) then + Append_Elmt (N, To); + return; + elsif Node (Elmt) = N then + return; + else + Next_Elmt (Elmt); + end if; + end loop; + end Append_Unique_Elmt; + + -------------------- + -- Elists_Address -- + -------------------- + + function Elists_Address return System.Address is + begin + return Elists.Table (First_Elist_Id)'Address; + end Elists_Address; + + ------------------- + -- Elmts_Address -- + ------------------- + + function Elmts_Address return System.Address is + begin + return Elmts.Table (First_Elmt_Id)'Address; + end Elmts_Address; + + ---------------- + -- First_Elmt -- + ---------------- + + function First_Elmt (List : Elist_Id) return Elmt_Id is + begin + pragma Assert (List > Elist_Low_Bound); + return Elists.Table (List).First; + end First_Elmt; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Elists.Init; + Elmts.Init; + end Initialize; + + ----------------------- + -- Insert_Elmt_After -- + ----------------------- + + procedure Insert_Elmt_After (N : Node_Or_Entity_Id; Elmt : Elmt_Id) is + Nxt : constant Union_Id := Elmts.Table (Elmt).Next; + + begin + pragma Assert (Elmt /= No_Elmt); + + Elmts.Increment_Last; + Elmts.Table (Elmts.Last).Node := N; + Elmts.Table (Elmts.Last).Next := Nxt; + + Elmts.Table (Elmt).Next := Union_Id (Elmts.Last); + + if Nxt in Elist_Range then + Elists.Table (Elist_Id (Nxt)).Last := Elmts.Last; + end if; + end Insert_Elmt_After; + + ------------------------ + -- Is_Empty_Elmt_List -- + ------------------------ + + function Is_Empty_Elmt_List (List : Elist_Id) return Boolean is + begin + return Elists.Table (List).First = No_Elmt; + end Is_Empty_Elmt_List; + + ------------------- + -- Last_Elist_Id -- + ------------------- + + function Last_Elist_Id return Elist_Id is + begin + return Elists.Last; + end Last_Elist_Id; + + --------------- + -- Last_Elmt -- + --------------- + + function Last_Elmt (List : Elist_Id) return Elmt_Id is + begin + return Elists.Table (List).Last; + end Last_Elmt; + + ------------------ + -- Last_Elmt_Id -- + ------------------ + + function Last_Elmt_Id return Elmt_Id is + begin + return Elmts.Last; + end Last_Elmt_Id; + + ---------- + -- Lock -- + ---------- + + procedure Lock is + begin + Elists.Locked := True; + Elmts.Locked := True; + Elists.Release; + Elmts.Release; + end Lock; + + ------------------- + -- New_Elmt_List -- + ------------------- + + function New_Elmt_List return Elist_Id is + begin + Elists.Increment_Last; + Elists.Table (Elists.Last).First := No_Elmt; + Elists.Table (Elists.Last).Last := No_Elmt; + + if Debug_Flag_N then + Write_Str ("Allocate new element list, returned ID = "); + Write_Int (Int (Elists.Last)); + Write_Eol; + end if; + + return Elists.Last; + end New_Elmt_List; + + --------------- + -- Next_Elmt -- + --------------- + + function Next_Elmt (Elmt : Elmt_Id) return Elmt_Id is + N : constant Union_Id := Elmts.Table (Elmt).Next; + + begin + if N in Elist_Range then + return No_Elmt; + else + return Elmt_Id (N); + end if; + end Next_Elmt; + + procedure Next_Elmt (Elmt : in out Elmt_Id) is + begin + Elmt := Next_Elmt (Elmt); + end Next_Elmt; + + -------- + -- No -- + -------- + + function No (List : Elist_Id) return Boolean is + begin + return List = No_Elist; + end No; + + function No (Elmt : Elmt_Id) return Boolean is + begin + return Elmt = No_Elmt; + end No; + + ---------- + -- Node -- + ---------- + + function Node (Elmt : Elmt_Id) return Node_Or_Entity_Id is + begin + if Elmt = No_Elmt then + return Empty; + else + return Elmts.Table (Elmt).Node; + end if; + end Node; + + ---------------- + -- Num_Elists -- + ---------------- + + function Num_Elists return Nat is + begin + return Int (Elmts.Last) - Int (Elmts.First) + 1; + end Num_Elists; + + ------------------ + -- Prepend_Elmt -- + ------------------ + + procedure Prepend_Elmt (N : Node_Or_Entity_Id; To : Elist_Id) is + F : constant Elmt_Id := Elists.Table (To).First; + + begin + Elmts.Increment_Last; + Elmts.Table (Elmts.Last).Node := N; + + if F = No_Elmt then + Elists.Table (To).Last := Elmts.Last; + Elmts.Table (Elmts.Last).Next := Union_Id (To); + else + Elmts.Table (Elmts.Last).Next := Union_Id (F); + end if; + + Elists.Table (To).First := Elmts.Last; + end Prepend_Elmt; + + ------------- + -- Present -- + ------------- + + function Present (List : Elist_Id) return Boolean is + begin + return List /= No_Elist; + end Present; + + function Present (Elmt : Elmt_Id) return Boolean is + begin + return Elmt /= No_Elmt; + end Present; + + ----------------- + -- Remove_Elmt -- + ----------------- + + procedure Remove_Elmt (List : Elist_Id; Elmt : Elmt_Id) is + Nxt : Elmt_Id; + Prv : Elmt_Id; + + begin + Nxt := Elists.Table (List).First; + + -- Case of removing only element in the list + + if Elmts.Table (Nxt).Next in Elist_Range then + pragma Assert (Nxt = Elmt); + + Elists.Table (List).First := No_Elmt; + Elists.Table (List).Last := No_Elmt; + + -- Case of removing the first element in the list + + elsif Nxt = Elmt then + Elists.Table (List).First := Elmt_Id (Elmts.Table (Nxt).Next); + + -- Case of removing second or later element in the list + + else + loop + Prv := Nxt; + Nxt := Elmt_Id (Elmts.Table (Prv).Next); + exit when Nxt = Elmt + or else Elmts.Table (Nxt).Next in Elist_Range; + end loop; + + pragma Assert (Nxt = Elmt); + + Elmts.Table (Prv).Next := Elmts.Table (Nxt).Next; + + if Elmts.Table (Prv).Next in Elist_Range then + Elists.Table (List).Last := Prv; + end if; + end if; + end Remove_Elmt; + + ---------------------- + -- Remove_Last_Elmt -- + ---------------------- + + procedure Remove_Last_Elmt (List : Elist_Id) is + Nxt : Elmt_Id; + Prv : Elmt_Id; + + begin + Nxt := Elists.Table (List).First; + + -- Case of removing only element in the list + + if Elmts.Table (Nxt).Next in Elist_Range then + Elists.Table (List).First := No_Elmt; + Elists.Table (List).Last := No_Elmt; + + -- Case of at least two elements in list + + else + loop + Prv := Nxt; + Nxt := Elmt_Id (Elmts.Table (Prv).Next); + exit when Elmts.Table (Nxt).Next in Elist_Range; + end loop; + + Elmts.Table (Prv).Next := Elmts.Table (Nxt).Next; + Elists.Table (List).Last := Prv; + end if; + end Remove_Last_Elmt; + + ------------------ + -- Replace_Elmt -- + ------------------ + + procedure Replace_Elmt (Elmt : Elmt_Id; New_Node : Node_Or_Entity_Id) is + begin + Elmts.Table (Elmt).Node := New_Node; + end Replace_Elmt; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + begin + Elists.Tree_Read; + Elmts.Tree_Read; + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + begin + Elists.Tree_Write; + Elmts.Tree_Write; + end Tree_Write; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock is + begin + Elists.Locked := False; + Elmts.Locked := False; + end Unlock; + +end Elists; diff --git a/gcc/ada/elists.ads b/gcc/ada/elists.ads new file mode 100644 index 000000000..0e9a2a2f3 --- /dev/null +++ b/gcc/ada/elists.ads @@ -0,0 +1,176 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E L I S 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 provides facilities for manipulating lists of nodes (see +-- package Atree for format and implementation of tree nodes). Separate list +-- elements are allocated to represent elements of these lists, so it is +-- possible for a given node to be on more than one element list at a time. +-- See also package Nlists, which provides another form that is threaded +-- through the nodes themselves (using the Link field), which is more time +-- and space efficient, but a node can be only one such list. + +with Types; use Types; +with System; + +package Elists is + + -- An element list is represented by a header that is allocated in the + -- Elist header table. This header contains pointers to the first and + -- last elements in the list, or to No_Elmt if the list is empty. + + -- The elements in the list each contain a pointer to the next element + -- and a pointer to the referenced node. Putting a node into an element + -- list causes no change at all to the node itself, so a node may be + -- included in multiple element lists, and the nodes thus included may + -- or may not be elements of node lists (see package Nlists). + + procedure Initialize; + -- Initialize allocation of element list tables. Called at the start of + -- compiling each new main source file. Note that Initialize must not be + -- called if Tree_Read is used. + + procedure Lock; + -- Lock tables used for element lists before calling backend + + procedure Unlock; + -- Unlock list tables, in cases where the back end needs to modify them + + procedure Tree_Read; + -- Initializes internal tables from current tree file using the relevant + -- Table.Tree_Read routines. Note that Initialize should not be called if + -- Tree_Read is used. Tree_Read includes all necessary initialization. + + procedure Tree_Write; + -- Writes out internal tables to current tree file using the relevant + -- Table.Tree_Write routines. + + function Last_Elist_Id return Elist_Id; + -- Returns Id of last allocated element list header + + function Elists_Address return System.Address; + -- Return address of Elists table (used in Back_End for Gigi call) + + function Num_Elists return Nat; + -- Number of currently allocated element lists + + function Last_Elmt_Id return Elmt_Id; + -- Returns Id of last allocated list element + + function Elmts_Address return System.Address; + -- Return address of Elmts table (used in Back_End for Gigi call) + + function Node (Elmt : Elmt_Id) return Node_Or_Entity_Id; + pragma Inline (Node); + -- Returns the value of a given list element. Returns Empty if Elmt + -- is set to No_Elmt. + + function New_Elmt_List return Elist_Id; + -- Creates a new empty element list. Typically this is used to initialize + -- a field in some other node which points to an element list where the + -- list is then subsequently filled in using Append calls. + + function First_Elmt (List : Elist_Id) return Elmt_Id; + pragma Inline (First_Elmt); + -- Obtains the first element of the given element list or, if the list has + -- no items, then No_Elmt is returned. + + function Last_Elmt (List : Elist_Id) return Elmt_Id; + pragma Inline (Last_Elmt); + -- Obtains the last element of the given element list or, if the list has + -- no items, then No_Elmt is returned. + + function Next_Elmt (Elmt : Elmt_Id) return Elmt_Id; + pragma Inline (Next_Elmt); + -- This function returns the next element on an element list. The argument + -- must be a list element other than No_Elmt. Returns No_Elmt if the given + -- element is the last element of the list. + + procedure Next_Elmt (Elmt : in out Elmt_Id); + pragma Inline (Next_Elmt); + -- Next_Elmt (Elmt) is equivalent to Elmt := Next_Elmt (Elmt) + + function Is_Empty_Elmt_List (List : Elist_Id) return Boolean; + pragma Inline (Is_Empty_Elmt_List); + -- This function determines if a given tree id references an element list + -- that contains no items. + + procedure Append_Elmt (N : Node_Or_Entity_Id; To : Elist_Id); + -- Appends N at the end of To, allocating a new element. N must be a + -- non-empty node or entity Id, and To must be an Elist (not No_Elist). + + procedure Append_Unique_Elmt (N : Node_Or_Entity_Id; To : Elist_Id); + -- Like Append_Elmt, except that a check is made to see if To already + -- contains N and if so the call has no effect. + + procedure Prepend_Elmt (N : Node_Or_Entity_Id; To : Elist_Id); + -- Appends N at the beginning of To, allocating a new element + + procedure Insert_Elmt_After (N : Node_Or_Entity_Id; Elmt : Elmt_Id); + -- Add a new element (N) right after the pre-existing element Elmt + -- It is invalid to call this subprogram with Elmt = No_Elmt. + + procedure Replace_Elmt (Elmt : Elmt_Id; New_Node : Node_Or_Entity_Id); + pragma Inline (Replace_Elmt); + -- Causes the given element of the list to refer to New_Node, the node + -- which was previously referred to by Elmt is effectively removed from + -- the list and replaced by New_Node. + + procedure Remove_Elmt (List : Elist_Id; Elmt : Elmt_Id); + -- Removes Elmt from the given list. The node itself is not affected, + -- but the space used by the list element may be (but is not required + -- to be) freed for reuse in a subsequent Append_Elmt call. + + procedure Remove_Last_Elmt (List : Elist_Id); + -- Removes the last element of the given list. The node itself is not + -- affected, but the space used by the list element may be (but is not + -- required to be) freed for reuse in a subsequent Append_Elmt call. + + function No (List : Elist_Id) return Boolean; + pragma Inline (No); + -- Tests given Id for equality with No_Elist. This allows notations like + -- "if No (Statements)" as opposed to "if Statements = No_Elist". + + function Present (List : Elist_Id) return Boolean; + pragma Inline (Present); + -- Tests given Id for inequality with No_Elist. This allows notations like + -- "if Present (Statements)" as opposed to "if Statements /= No_Elist". + + function No (Elmt : Elmt_Id) return Boolean; + pragma Inline (No); + -- Tests given Id for equality with No_Elmt. This allows notations like + -- "if No (Operation)" as opposed to "if Operation = No_Elmt". + + function Present (Elmt : Elmt_Id) return Boolean; + pragma Inline (Present); + -- Tests given Id for inequality with No_Elmt. This allows notations like + -- "if Present (Operation)" as opposed to "if Operation /= No_Elmt". + +end Elists; diff --git a/gcc/ada/elists.h b/gcc/ada/elists.h new file mode 100644 index 000000000..06dd4fe4d --- /dev/null +++ b/gcc/ada/elists.h @@ -0,0 +1,97 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * E L I S T S * + * * + * C Header File * + * * + * Copyright (C) 1992-2007, Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING3. If not, go to * + * http://www.gnu.org/licenses for a complete copy of the license. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* This is the C header corresponding to the Ada package specification for + Elists. It also contains the implementations of inlined functions from the + package body for Elists. It was generated manually from elists.ads and + elists.adb and must be kept synchronized with changes in these files. + + Note that only routines for reading the tree are included, since the + tree transformer is not supposed to modify the tree in any way. */ + +/* The following are the structures used to hold element lists */ + +struct Elist_Header +{ + Elmt_Id first; + Elmt_Id last; +}; + +struct Elmt_Item +{ + Node_Id node; + Int next; +}; + +/* The element list headers and element descriptors themselves are stored in + two arrays. The pointers to these arrays are passed as a parameter to the + tree transformer procedure and stored in the global variables Elists_Ptr + and Elmts_Ptr. */ + +extern struct Elist_Header *Elists_Ptr; +extern struct Elmt_Item *Elmts_Ptr; + +/* Element List Access Functions: */ + +static Node_Id Node (Elmt_Id); +static Elmt_Id First_Elmt (Elist_Id); +static Elmt_Id Last_Elmt (Elist_Id); +static Elmt_Id Next_Elmt (Elmt_Id); +static Boolean Is_Empty_Elmt_List (Elist_Id); + +INLINE Node_Id +Node (Elmt_Id Elmt) +{ + return Elmts_Ptr[Elmt - First_Elmt_Id].node; +} + +INLINE Elmt_Id +First_Elmt (Elist_Id List) +{ + return Elists_Ptr[List - First_Elist_Id].first; +} + +INLINE Elmt_Id +Last_Elmt (Elist_Id List) +{ + return Elists_Ptr[List - First_Elist_Id].last; +} + +INLINE Elmt_Id +Next_Elmt (Elmt_Id Node) +{ + Int N = Elmts_Ptr[Node - First_Elmt_Id].next; + + if (IN (N, Elist_Range)) + return No_Elmt; + else + return N; +} + +INLINE Boolean +Is_Empty_Elmt_List (Elist_Id Id) +{ + return Elists_Ptr[Id - First_Elist_Id].first == No_Elmt; +} diff --git a/gcc/ada/env.c b/gcc/ada/env.c new file mode 100644 index 000000000..c53678ab8 --- /dev/null +++ b/gcc/ada/env.c @@ -0,0 +1,325 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * E N V * + * * + * C Implementation File * + * * + * 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. * + * * + ****************************************************************************/ + +/* Tru64 UNIX V4.0F declares unsetenv() only if AES_SOURCE (which + is plain broken, this should be _AES_SOURCE instead as everywhere else; + Tru64 UNIX V5.1B declares it only if _BSD. */ +#if defined (__alpha__) && defined (__osf__) +#define AES_SOURCE +#define _BSD +#endif + +#ifdef IN_RTS +#include "tconfig.h" +#include "tsystem.h" + +#include +#include +#include +#ifdef VMS +#include +#endif + +#if defined (__MINGW32__) +#include +#endif + +#if defined (__vxworks) \ + && ! (defined (__RTP__) || defined (__COREOS__) || defined (__VXWORKSMILS__)) +#include "envLib.h" +extern char** ppGlobalEnviron; +#endif + +/* We don't have libiberty, so use malloc. */ +#define xmalloc(S) malloc (S) +#else /* IN_RTS */ +#include "config.h" +#include "system.h" +#endif /* IN_RTS */ + +#if defined (__APPLE__) +#include +#endif + +#include "env.h" + +void +__gnat_getenv (char *name, int *len, char **value) +{ + *value = getenv (name); + if (!*value) + *len = 0; + else + *len = strlen (*value); + + return; +} + +/* VMS specific declarations for set_env_value. */ + +#ifdef VMS + +static char *to_host_path_spec (char *); + +struct descriptor_s +{ + unsigned short len, mbz; + __char_ptr32 adr; +}; + +typedef struct _ile3 +{ + unsigned short len, code; + __char_ptr32 adr; + unsigned short *retlen_adr; +} ile_s; + +#endif + +void +__gnat_setenv (char *name, char *value) +{ +#if defined (VMS) + struct descriptor_s name_desc; + /* Put in JOB table for now, so that the project stuff at least works. */ + struct descriptor_s table_desc = {7, 0, "LNM$JOB"}; + char *host_pathspec = value; + char *copy_pathspec; + int num_dirs_in_pathspec = 1; + char *ptr; + long status; + + name_desc.len = strlen (name); + name_desc.mbz = 0; + name_desc.adr = name; + + if (*host_pathspec == 0) + /* deassign */ + { + status = LIB$DELETE_LOGICAL (&name_desc, &table_desc); + /* no need to check status; if the logical name is not + defined, that's fine. */ + return; + } + + ptr = host_pathspec; + while (*ptr++) + if (*ptr == ',') + num_dirs_in_pathspec++; + + { + int i, status; + ile_s *ile_array = alloca (sizeof (ile_s) * (num_dirs_in_pathspec + 1)); + char *copy_pathspec = alloca (strlen (host_pathspec) + 1); + char *curr, *next; + + strcpy (copy_pathspec, host_pathspec); + curr = copy_pathspec; + for (i = 0; i < num_dirs_in_pathspec; i++) + { + next = strchr (curr, ','); + if (next == 0) + next = strchr (curr, 0); + + *next = 0; + ile_array[i].len = strlen (curr); + + /* Code 2 from lnmdef.h means it's a string. */ + ile_array[i].code = 2; + ile_array[i].adr = curr; + + /* retlen_adr is ignored. */ + ile_array[i].retlen_adr = 0; + curr = next + 1; + } + + /* Terminating item must be zero. */ + ile_array[i].len = 0; + ile_array[i].code = 0; + ile_array[i].adr = 0; + ile_array[i].retlen_adr = 0; + + status = LIB$SET_LOGICAL (&name_desc, 0, &table_desc, 0, ile_array); + if ((status & 1) != 1) + LIB$SIGNAL (status); + } + +#elif (defined (__vxworks) && defined (__RTP__)) || defined (__APPLE__) + setenv (name, value, 1); + +#else + size_t size = strlen (name) + strlen (value) + 2; + char *expression; + + expression = (char *) xmalloc (size * sizeof (char)); + + sprintf (expression, "%s=%s", name, value); + putenv (expression); +#if (defined (__FreeBSD__) && (__FreeBSD__ < 7)) \ + || defined (__MINGW32__) \ + ||(defined (__vxworks) && ! defined (__RTP__)) + /* On some systems like FreeBSD 6.x and earlier, MacOS X and Windows, + putenv is making a copy of the expression string so we can free + it after the call to putenv */ + free (expression); +#endif +#endif +} + +char ** +__gnat_environ (void) +{ +#if defined (VMS) || defined (RTX) \ + || (defined (VTHREADS) && ! defined (__VXWORKSMILS__)) + /* Not implemented */ + return NULL; +#elif defined (__APPLE__) + char ***result = _NSGetEnviron (); + return *result; +#elif defined (__MINGW32__) + return _environ; +#elif defined (sun) + extern char **_environ; + return _environ; +#else +#if ! (defined (__vxworks) \ + && ! (defined (__RTP__) || defined (__COREOS__) \ + || defined (__VXWORKSMILS__))) + /* in VxWorks kernel mode environ is macro and not a variable */ + /* same thing on 653 in the CoreOS and for VxWorks MILS vThreads */ + extern char **environ; +#endif + return environ; +#endif +} + +void __gnat_unsetenv (char *name) { +#if defined (VMS) + /* Not implemented */ + return; +#elif defined (__hpux__) || defined (sun) \ + || (defined (__mips) && defined (__sgi)) \ + || (defined (__vxworks) && ! defined (__RTP__)) \ + || defined (_AIX) || defined (__Lynx__) + + /* On Solaris, HP-UX and IRIX there is no function to clear an environment + variable. So we look for the variable in the environ table and delete it + by setting the entry to NULL. This can clearly cause some memory leaks + but free cannot be used on this context as not all strings in the environ + have been allocated using malloc. To avoid this memory leak another + method can be used. It consists in forcing the reallocation of all the + strings in the environ table using malloc on the first call on the + functions related to environment variable management. The disadvantage + is that if a program makes a direct call to getenv the return string + may be deallocated at some point. */ + /* Note that on AIX, unsetenv is not supported on 5.1 but it is on 5.3. + As we are still supporting AIX 5.1 we cannot use unsetenv */ + char **env = __gnat_environ (); + int index = 0; + size_t size = strlen (name); + + while (env[index] != NULL) { + if (strlen (env[index]) > size) { + if (strstr (env[index], name) == env[index] && + env[index][size] == '=') { +#if defined (__vxworks) && ! defined (__RTP__) + /* on Vxworks we are sure that the string has been allocated using + malloc */ + free (env[index]); +#endif + while (env[index] != NULL) { + env[index]=env[index + 1]; + index++; + } + } else + index++; + } else + index++; + } +#elif defined (__MINGW32__) + /* On Windows platform putenv ("key=") is equivalent to unsetenv (a + subsequent call to getenv ("key") will return NULL and not the "\0" + string */ + size_t size = strlen (name) + 2; + char *expression; + expression = (char *) xmalloc (size * sizeof (char)); + + sprintf (expression, "%s=", name); + putenv (expression); + free (expression); +#else + unsetenv (name); +#endif +} + +void __gnat_clearenv (void) { +#if defined (VMS) + /* not implemented */ + return; +#elif defined (sun) || (defined (__mips) && defined (__sgi)) \ + || (defined (__vxworks) && ! defined (__RTP__)) || defined (__Lynx__) + /* On Solaris, IRIX, VxWorks (not RTPs), and Lynx there is no system + call to unset a variable or to clear the environment so set all + the entries in the environ table to NULL (see comment in + __gnat_unsetenv for more explanation). */ + char **env = __gnat_environ (); + int index = 0; + + while (env[index] != NULL) { + env[index]=NULL; + index++; + } +#elif defined (__MINGW32__) || defined (__FreeBSD__) || defined (__APPLE__) \ + || (defined (__vxworks) && defined (__RTP__)) || defined (__CYGWIN__) \ + || defined (__NetBSD__) || defined (__OpenBSD__) || defined (__rtems__) + /* On Windows, FreeBSD and MacOS there is no function to clean all the + environment but there is a "clean" way to unset a variable. So go + through the environ table and call __gnat_unsetenv on all entries */ + char **env = __gnat_environ (); + size_t size; + + while (env[0] != NULL) { + size = 0; + while (env[0][size] != '=') + size++; + /* create a string that contains "name" */ + size++; + { + char expression[size]; + strncpy (expression, env[0], size); + expression[size - 1] = 0; + __gnat_unsetenv (expression); + } + } +#else + clearenv (); +#endif +} diff --git a/gcc/ada/env.h b/gcc/ada/env.h new file mode 100644 index 000000000..fa54d9fb9 --- /dev/null +++ b/gcc/ada/env.h @@ -0,0 +1,37 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * FE * + * * + * C Header File * + * * + * 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. * + * * + ****************************************************************************/ + +extern void __gnat_getenv (char *name, int *len, char **value); +extern void __gnat_setenv (char *name, char *value); +extern char **__gnat_environ (void); +extern void __gnat_unsetenv (char *name); +extern void __gnat_clearenv (void); + diff --git a/gcc/ada/err_vars.ads b/gcc/ada/err_vars.ads new file mode 100644 index 000000000..2cf2bedc9 --- /dev/null +++ b/gcc/ada/err_vars.ads @@ -0,0 +1,153 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E R R _ V A R 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains variables common to error reporting packages +-- including Errout and Prj.Err. + +with Namet; use Namet; +with Types; use Types; +with Uintp; use Uintp; + +package Err_Vars is + + -- All of these variables are set when needed, so they do not need to be + -- initialized. However, there is code that saves and restores existing + -- values, which may malfunction in -gnatVa mode if the variable has never + -- been initialized, so we initialize some variables to avoid exceptions + -- from invalid values in such cases. + + ------------------ + -- Error Counts -- + ------------------ + + Serious_Errors_Detected : Nat := 0; + -- This is a count of errors that are serious enough to stop expansion, + -- and hence to prevent generation of an object file even if the + -- switch -gnatQ is set. Initialized to zero at the start of compilation. + -- Initialized for -gnatVa use, see comment above. + + Total_Errors_Detected : Nat := 0; + -- Number of errors detected so far. Includes count of serious errors and + -- non-serious errors, so this value is always greater than or equal to the + -- Serious_Errors_Detected value. Initialized to zero at the start of + -- compilation. Initialized for -gnatVa use, see comment above. + + Warnings_Detected : Nat := 0; + -- Number of warnings detected. Initialized to zero at the start of + -- compilation. Initialized for -gnatVa use, see comment above. + + ---------------------------------- + -- Error Message Mode Variables -- + ---------------------------------- + + -- These variables control special error message modes. The initialized + -- values below give the normal default behavior, but they can be reset + -- by the caller to get different behavior as noted in the comments. These + -- variables are not reset by calls to the error message routines, so the + -- caller is responsible for resetting the default behavior after use. + + Error_Msg_Qual_Level : Int; + -- Number of levels of qualification required for type name (see the + -- description of the } insertion character. Note that this value does + -- note get reset by any Error_Msg call, so the caller is responsible + -- for resetting it. + + Warn_On_Instance : Boolean := False; + -- Normally if a warning is generated in a generic template from the + -- analysis of the template, then the warning really belongs in the + -- template, and the default value of False for this Boolean achieves + -- that effect. If Warn_On_Instance is set True, then the warnings are + -- generated on the instantiation (referring to the template) rather + -- than on the template itself. + + Raise_Exception_On_Error : Nat := 0; + -- If this value is non-zero, then any attempt to generate an error + -- message raises the exception Error_Msg_Exception, and the error + -- message is not output. This is used for defending against junk + -- resulting from illegalities, and also for substitution of more + -- appropriate error messages from higher semantic levels. It is + -- a counter so that the increment/decrement protocol nests neatly. + -- Initialized for -gnatVa use, see comment above. + + Error_Msg_Exception : exception; + -- Exception raised if Raise_Exception_On_Error is true + + Current_Error_Source_File : Source_File_Index := Internal_Source_File; + -- Id of current messages. Used to post file name when unit changes. This + -- is initialized to Main_Source_File at the start of a compilation, which + -- means that no file names will be output unless there are errors in units + -- other than the main unit. However, if the main unit has a pragma + -- Source_Reference line, then this is initialized to No_Source_File, + -- to force an initial reference to the real source file name. + + ---------------------------------------- + -- Error Message Insertion Parameters -- + ---------------------------------------- + + -- The error message routines work with strings that contain insertion + -- sequences that result in the insertion of variable data. The following + -- variables contain the required data. The procedure is to set one or more + -- of the following global variables to appropriate values before making a + -- call to one of the error message routines with a string containing the + -- insertion character to get the value inserted in an appropriate format. + + Error_Msg_Col : Column_Number; + -- Column for @ insertion character in message + + Error_Msg_Uint_1 : Uint; + Error_Msg_Uint_2 : Uint; + -- Uint values for ^ insertion characters in message + + Error_Msg_Sloc : Source_Ptr; + -- Source location for # insertion character in message + + Error_Msg_Name_1 : Name_Id; + Error_Msg_Name_2 : Name_Id; + Error_Msg_Name_3 : Name_Id; + -- Name_Id values for % insertion characters in message + + Error_Msg_File_1 : File_Name_Type; + Error_Msg_File_2 : File_Name_Type; + Error_Msg_File_3 : File_Name_Type; + -- File_Name_Type values for { insertion characters in message + + Error_Msg_Unit_1 : Unit_Name_Type; + Error_Msg_Unit_2 : Unit_Name_Type; + -- Unit_Name_Type values for $ insertion characters in message + + Error_Msg_Node_1 : Node_Id; + Error_Msg_Node_2 : Node_Id; + -- Node_Id values for & insertion characters in message + + Error_Msg_Warn : Boolean; + -- Used if current message contains a < insertion character to indicate + -- if the current message is a warning message. + + Error_Msg_String : String (1 .. 4096); + Error_Msg_Strlen : Natural; + -- Used if current message contains a ~ insertion character to indicate + -- insertion of the string Error_Msg_String (1 .. Error_Msg_Strlen). + +end Err_Vars; diff --git a/gcc/ada/errno.c b/gcc/ada/errno.c new file mode 100644 index 000000000..2eec9ac55 --- /dev/null +++ b/gcc/ada/errno.c @@ -0,0 +1,66 @@ +/**************************************************************************** + * * + * GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS * + * * + * E R R N O * + * * + * C Implementation File * + * * + * Copyright (C) 1992-2009, Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. * + * * + * As a special exception under Section 7 of GPL version 3, you are granted * + * additional permissions described in the GCC Runtime Library Exception, * + * version 3.1, as published by the Free Software Foundation. * + * * + * You should have received a copy of the GNU General Public License and * + * a copy of the GCC Runtime Library Exception along with this program; * + * see the files COPYING3 and COPYING.RUNTIME respectively. If 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 provides access to the C-language errno to the Ada interface + for POSIX. It is not possible in general to import errno, even in + Ada compilers that allow (as GNAT does) the importation of variables, + as it may be defined using a macro. +*/ + + +#define _REENTRANT +#define _THREAD_SAFE +#define _SGI_MP_SOURCE + +#ifdef MaRTE + +/* MaRTE OS provides its own implementation of errno related functionality. We + want to ensure the use of the MaRTE version for tasking programs (the MaRTE + library will not be linked if no tasking constructs are used), so we use the + weak symbols mechanism to use the MaRTE version whenever is available. */ + +#pragma weak __get_errno +#pragma weak __set_errno + +#endif + +#include +int +__get_errno(void) +{ + return errno; +} + +void +__set_errno(int err) +{ + errno = err; +} diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb new file mode 100644 index 000000000..0fb8f9e12 --- /dev/null +++ b/gcc/ada/errout.adb @@ -0,0 +1,3060 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E R R O U T -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Warning! Error messages can be generated during Gigi processing by direct +-- calls to error message routines, so it is essential that the processing +-- in this body be consistent with the requirements for the Gigi processing +-- environment, and that in particular, no disallowed table expansion is +-- allowed to occur. + +with Atree; use Atree; +with Casing; use Casing; +with Csets; use Csets; +with Debug; use Debug; +with Einfo; use Einfo; +with Erroutc; use Erroutc; +with Fname; use Fname; +with Gnatvsn; use Gnatvsn; +with Hostparm; use Hostparm; +with Lib; use Lib; +with Opt; use Opt; +with Nlists; use Nlists; +with Output; use Output; +with Scans; use Scans; +with Sem_Aux; use Sem_Aux; +with Sinput; use Sinput; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Stylesw; use Stylesw; +with Uname; use Uname; + +package body Errout is + + Errors_Must_Be_Ignored : Boolean := False; + -- Set to True by procedure Set_Ignore_Errors (True), when calls to error + -- message procedures should be ignored (when parsing irrelevant text in + -- sources being preprocessed). + + Finalize_Called : Boolean := False; + -- Set True if the Finalize routine has been called + + Warn_On_Instance : Boolean; + -- Flag set true for warning message to be posted on instance + + ------------------------------------ + -- Table of Non-Instance Messages -- + ------------------------------------ + + -- This table contains an entry for every error message processed by the + -- Error_Msg routine that is not posted on generic (or inlined) instance. + -- As explained in further detail in the Error_Msg procedure body, this + -- table is used to avoid posting redundant messages on instances. + + type NIM_Record is record + Msg : String_Ptr; + Loc : Source_Ptr; + end record; + -- Type used to store text and location of one message + + package Non_Instance_Msgs is new Table.Table ( + Table_Component_Type => NIM_Record, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 100, + Table_Increment => 100, + Table_Name => "Non_Instance_Msgs"); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Error_Msg_Internal + (Msg : String; + Sptr : Source_Ptr; + Optr : Source_Ptr; + Msg_Cont : Boolean); + -- This is the low level routine used to post messages after dealing with + -- the issue of messages placed on instantiations (which get broken up + -- into separate calls in Error_Msg). Sptr is the location on which the + -- flag will be placed in the output. In the case where the flag is on + -- the template, this points directly to the template, not to one of the + -- instantiation copies of the template. Optr is the original location + -- used to flag the error, and this may indeed point to an instantiation + -- copy. So typically we can see Optr pointing to the template location + -- in an instantiation copy when Sptr points to the source location of + -- the actual instantiation (i.e the line with the new). Msg_Cont is + -- set true if this is a continuation message. + + function No_Warnings (N : Node_Or_Entity_Id) return Boolean; + -- Determines if warnings should be suppressed for the given node + + function OK_Node (N : Node_Id) return Boolean; + -- Determines if a node is an OK node to place an error message on (return + -- True) or if the error message should be suppressed (return False). A + -- message is suppressed if the node already has an error posted on it, + -- or if it refers to an Etype that has an error posted on it, or if + -- it references an Entity that has an error posted on it. + + procedure Output_Source_Line + (L : Physical_Line_Number; + Sfile : Source_File_Index; + Errs : Boolean); + -- Outputs text of source line L, in file S, together with preceding line + -- number, as described above for Output_Line_Number. The Errs parameter + -- indicates if there are errors attached to the line, which forces + -- listing on, even in the presence of pragma List (Off). + + procedure Set_Msg_Insertion_Column; + -- Handle column number insertion (@ insertion character) + + procedure Set_Msg_Insertion_Node; + -- Handle node (name from node) insertion (& insertion character) + + procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr); + -- Handle type reference (right brace insertion character). Flag is the + -- location of the flag, which is provided for the internal call to + -- Set_Msg_Insertion_Line_Number, + + procedure Set_Msg_Insertion_Unit_Name (Suffix : Boolean := True); + -- Handle unit name insertion ($ insertion character). Depending on Boolean + -- parameter Suffix, (spec) or (body) is appended after the unit name. + + procedure Set_Msg_Node (Node : Node_Id); + -- Add the sequence of characters for the name associated with the + -- given node to the current message. + + procedure Set_Msg_Text (Text : String; Flag : Source_Ptr); + -- Add a sequence of characters to the current message. The characters may + -- be one of the special insertion characters (see documentation in spec). + -- Flag is the location at which the error is to be posted, which is used + -- to determine whether or not the # insertion needs a file name. The + -- variables Msg_Buffer, Msglen, Is_Style_Msg, Is_Warning_Msg, and + -- Is_Unconditional_Msg are set on return. + + procedure Set_Posted (N : Node_Id); + -- Sets the Error_Posted flag on the given node, and all its parents + -- that are subexpressions and then on the parent non-subexpression + -- construct that contains the original expression (this reduces the + -- number of cascaded messages). Note that this call only has an effect + -- for a serious error. For a non-serious error, it has no effect. + + procedure Set_Qualification (N : Nat; E : Entity_Id); + -- Outputs up to N levels of qualification for the given entity. For + -- example, the entity A.B.C.D will output B.C. if N = 2. + + function Special_Msg_Delete + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id) return Boolean; + -- This function is called from Error_Msg_NEL, passing the message Msg, + -- node N on which the error is to be posted, and the entity or node E + -- to be used for an & insertion in the message if any. The job of this + -- procedure is to test for certain cascaded messages that we would like + -- to suppress. If the message is to be suppressed then we return True. + -- If the message should be generated (the normal case) False is returned. + + procedure Unwind_Internal_Type (Ent : in out Entity_Id); + -- This procedure is given an entity id for an internal type, i.e. a type + -- with an internal name. It unwinds the type to try to get to something + -- reasonably printable, generating prefixes like "subtype of", "access + -- to", etc along the way in the buffer. The value in Ent on return is the + -- final name to be printed. Hopefully this is not an internal name, but in + -- some internal name cases, it is an internal name, and has to be printed + -- anyway (although in this case the message has been killed if possible). + -- The global variable Class_Flag is set to True if the resulting entity + -- should have 'Class appended to its name (see Add_Class procedure), and + -- is otherwise unchanged. + + procedure VMS_Convert; + -- This procedure has no effect if called when the host is not OpenVMS. If + -- the host is indeed OpenVMS, then the error message stored in Msg_Buffer + -- is scanned for appearances of switch names which need converting to + -- corresponding VMS qualifier names. See Gnames/Vnames table in Errout + -- spec for precise definition of the conversion that is performed by this + -- routine in OpenVMS mode. + + ----------------------- + -- Change_Error_Text -- + ----------------------- + + procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : String) is + Save_Next : Error_Msg_Id; + Err_Id : Error_Msg_Id := Error_Id; + + begin + Set_Msg_Text (New_Msg, Errors.Table (Error_Id).Sptr); + Errors.Table (Error_Id).Text := new String'(Msg_Buffer (1 .. Msglen)); + + -- If in immediate error message mode, output modified error message now + -- This is just a bit tricky, because we want to output just a single + -- message, and the messages we modified is already linked in. We solve + -- this by temporarily resetting its forward pointer to empty. + + if Debug_Flag_OO then + Save_Next := Errors.Table (Error_Id).Next; + Errors.Table (Error_Id).Next := No_Error_Msg; + Write_Eol; + Output_Source_Line + (Errors.Table (Error_Id).Line, Errors.Table (Error_Id).Sfile, True); + Output_Error_Msgs (Err_Id); + Errors.Table (Error_Id).Next := Save_Next; + end if; + end Change_Error_Text; + + ------------------------ + -- Compilation_Errors -- + ------------------------ + + function Compilation_Errors return Boolean is + begin + if not Finalize_Called then + raise Program_Error; + else + return Erroutc.Compilation_Errors; + end if; + end Compilation_Errors; + + --------------- + -- Error_Msg -- + --------------- + + -- Error_Msg posts a flag at the given location, except that if the + -- Flag_Location points within a generic template and corresponds to an + -- instantiation of this generic template, then the actual message will be + -- posted on the generic instantiation, along with additional messages + -- referencing the generic declaration. + + procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is + Sindex : Source_File_Index; + -- Source index for flag location + + Orig_Loc : Source_Ptr; + -- Original location of Flag_Location (i.e. location in original + -- template in instantiation case, otherwise unchanged). + + begin + -- It is a fatal error to issue an error message when scanning from the + -- internal source buffer (see Sinput for further documentation) + + pragma Assert (Sinput.Source /= Internal_Source_Ptr); + + -- Return if all errors are to be ignored + + if Errors_Must_Be_Ignored then + return; + end if; + + -- If we already have messages, and we are trying to place a message at + -- No_Location or in package Standard, then just ignore the attempt + -- since we assume that what is happening is some cascaded junk. Note + -- that this is safe in the sense that proceeding will surely bomb. + + if Flag_Location < First_Source_Ptr + and then Total_Errors_Detected > 0 + then + return; + end if; + + -- Start of processing for new message + + Sindex := Get_Source_File_Index (Flag_Location); + Test_Style_Warning_Serious_Msg (Msg); + Orig_Loc := Original_Location (Flag_Location); + + -- If the current location is in an instantiation, the issue arises of + -- whether to post the message on the template or the instantiation. + + -- The way we decide is to see if we have posted the same message on + -- the template when we compiled the template (the template is always + -- compiled before any instantiations). For this purpose, we use a + -- separate table of messages. The reason we do this is twofold: + + -- First, the messages can get changed by various processing + -- including the insertion of tokens etc, making it hard to + -- do the comparison. + + -- Second, we will suppress a warning on a template if it is not in + -- the current extended source unit. That's reasonable and means we + -- don't want the warning on the instantiation here either, but it + -- does mean that the main error table would not in any case include + -- the message. + + if Flag_Location = Orig_Loc then + Non_Instance_Msgs.Append ((new String'(Msg), Flag_Location)); + Warn_On_Instance := False; + + -- Here we have an instance message + + else + -- Delete if debug flag off, and this message duplicates a message + -- already posted on the corresponding template + + if not Debug_Flag_GG then + for J in Non_Instance_Msgs.First .. Non_Instance_Msgs.Last loop + if Msg = Non_Instance_Msgs.Table (J).Msg.all + and then Non_Instance_Msgs.Table (J).Loc = Orig_Loc + then + return; + end if; + end loop; + end if; + + -- No duplicate, so error/warning will be posted on instance + + Warn_On_Instance := Is_Warning_Msg; + end if; + + -- Ignore warning message that is suppressed for this location. Note + -- that style checks are not considered warning messages for this + -- purpose. + + if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) then + return; + + -- For style messages, check too many messages so far + + elsif Is_Style_Msg + and then Maximum_Messages /= 0 + and then Warnings_Detected >= Maximum_Messages + then + return; + end if; + + -- The idea at this stage is that we have two kinds of messages + + -- First, we have those messages that are to be placed as requested at + -- Flag_Location. This includes messages that have nothing to do with + -- generics, and also messages placed on generic templates that reflect + -- an error in the template itself. For such messages we simply call + -- Error_Msg_Internal to place the message in the requested location. + + if Instantiation (Sindex) = No_Location then + Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False); + return; + end if; + + -- If we are trying to flag an error in an instantiation, we may have + -- a generic contract violation. What we generate in this case is: + + -- instantiation error at ... + -- original error message + + -- or + + -- warning: in instantiation at + -- warning: original warning message + + -- All these messages are posted at the location of the top level + -- instantiation. If there are nested instantiations, then the + -- instantiation error message can be repeated, pointing to each + -- of the relevant instantiations. + + -- Note: the instantiation mechanism is also shared for inlining of + -- subprogram bodies when front end inlining is done. In this case the + -- messages have the form: + + -- in inlined body at ... + -- original error message + + -- or + + -- warning: in inlined body at + -- warning: original warning message + + -- OK, here we have an instantiation error, and we need to generate the + -- error on the instantiation, rather than on the template. + + declare + Actual_Error_Loc : Source_Ptr; + -- Location of outer level instantiation in instantiation case, or + -- just a copy of Flag_Location in the normal case. This is the + -- location where all error messages will actually be posted. + + Save_Error_Msg_Sloc : constant Source_Ptr := Error_Msg_Sloc; + -- Save possible location set for caller's message. We need to use + -- Error_Msg_Sloc for the location of the instantiation error but we + -- have to preserve a possible original value. + + X : Source_File_Index; + + Msg_Cont_Status : Boolean; + -- Used to label continuation lines in instantiation case with + -- proper Msg_Cont status. + + begin + -- Loop to find highest level instantiation, where all error + -- messages will be placed. + + X := Sindex; + loop + Actual_Error_Loc := Instantiation (X); + X := Get_Source_File_Index (Actual_Error_Loc); + exit when Instantiation (X) = No_Location; + end loop; + + -- Since we are generating the messages at the instantiation point in + -- any case, we do not want the references to the bad lines in the + -- instance to be annotated with the location of the instantiation. + + Suppress_Instance_Location := True; + Msg_Cont_Status := False; + + -- Loop to generate instantiation messages + + Error_Msg_Sloc := Flag_Location; + X := Get_Source_File_Index (Flag_Location); + while Instantiation (X) /= No_Location loop + + -- Suppress instantiation message on continuation lines + + if Msg (Msg'First) /= '\' then + + -- Case of inlined body + + if Inlined_Body (X) then + if Is_Warning_Msg or else Is_Style_Msg then + Error_Msg_Internal + ("?in inlined body #", + Actual_Error_Loc, Flag_Location, Msg_Cont_Status); + + else + Error_Msg_Internal + ("error in inlined body #", + Actual_Error_Loc, Flag_Location, Msg_Cont_Status); + end if; + + -- Case of generic instantiation + + else + if Is_Warning_Msg or else Is_Style_Msg then + Error_Msg_Internal + ("?in instantiation #", + Actual_Error_Loc, Flag_Location, Msg_Cont_Status); + + else + Error_Msg_Internal + ("instantiation error #", + Actual_Error_Loc, Flag_Location, Msg_Cont_Status); + end if; + end if; + end if; + + Error_Msg_Sloc := Instantiation (X); + X := Get_Source_File_Index (Error_Msg_Sloc); + Msg_Cont_Status := True; + end loop; + + Suppress_Instance_Location := False; + Error_Msg_Sloc := Save_Error_Msg_Sloc; + + -- Here we output the original message on the outer instantiation + + Error_Msg_Internal + (Msg, Actual_Error_Loc, Flag_Location, Msg_Cont_Status); + end; + end Error_Msg; + + ------------------ + -- Error_Msg_AP -- + ------------------ + + procedure Error_Msg_AP (Msg : String) is + S1 : Source_Ptr; + C : Character; + + begin + -- If we had saved the Scan_Ptr value after scanning the previous + -- token, then we would have exactly the right place for putting + -- the flag immediately at hand. However, that would add at least + -- two instructions to a Scan call *just* to service the possibility + -- of an Error_Msg_AP call. So instead we reconstruct that value. + + -- We have two possibilities, start with Prev_Token_Ptr and skip over + -- the current token, which is made harder by the possibility that this + -- token may be in error, or start with Token_Ptr and work backwards. + -- We used to take the second approach, but it's hard because of + -- comments, and harder still because things that look like comments + -- can appear inside strings. So now we take the first approach. + + -- Note: in the case where there is no previous token, Prev_Token_Ptr + -- is set to Source_First, which is a reasonable position for the + -- error flag in this situation. + + S1 := Prev_Token_Ptr; + C := Source (S1); + + -- If the previous token is a string literal, we need a special approach + -- since there may be white space inside the literal and we don't want + -- to stop on that white space. + + -- Note: since this is an error recovery issue anyway, it is not worth + -- worrying about special UTF_32 line terminator characters here. + + if Prev_Token = Tok_String_Literal then + loop + S1 := S1 + 1; + + if Source (S1) = C then + S1 := S1 + 1; + exit when Source (S1) /= C; + elsif Source (S1) in Line_Terminator then + exit; + end if; + end loop; + + -- Character literal also needs special handling + + elsif Prev_Token = Tok_Char_Literal then + S1 := S1 + 3; + + -- Otherwise we search forward for the end of the current token, marked + -- by a line terminator, white space, a comment symbol or if we bump + -- into the following token (i.e. the current token). + + -- Again, it is not worth worrying about UTF_32 special line terminator + -- characters in this context, since this is only for error recovery. + + else + while Source (S1) not in Line_Terminator + and then Source (S1) /= ' ' + and then Source (S1) /= ASCII.HT + and then (Source (S1) /= '-' or else Source (S1 + 1) /= '-') + and then S1 /= Token_Ptr + loop + S1 := S1 + 1; + end loop; + end if; + + -- S1 is now set to the location for the flag + + Error_Msg (Msg, S1); + end Error_Msg_AP; + + ------------------ + -- Error_Msg_BC -- + ------------------ + + procedure Error_Msg_BC (Msg : String) is + begin + -- If we are at end of file, post the flag after the previous token + + if Token = Tok_EOF then + Error_Msg_AP (Msg); + + -- If we are at start of file, post the flag at the current token + + elsif Token_Ptr = Source_First (Current_Source_File) then + Error_Msg_SC (Msg); + + -- If the character before the current token is a space or a horizontal + -- tab, then we place the flag on this character (in the case of a tab + -- we would really like to place it in the "last" character of the tab + -- space, but that it too much trouble to worry about). + + elsif Source (Token_Ptr - 1) = ' ' + or else Source (Token_Ptr - 1) = ASCII.HT + then + Error_Msg (Msg, Token_Ptr - 1); + + -- If there is no space or tab before the current token, then there is + -- no room to place the flag before the token, so we place it on the + -- token instead (this happens for example at the start of a line). + + else + Error_Msg (Msg, Token_Ptr); + end if; + end Error_Msg_BC; + + ------------------- + -- Error_Msg_CRT -- + ------------------- + + procedure Error_Msg_CRT (Feature : String; N : Node_Id) is + CNRT : constant String := " not allowed in no run time mode"; + CCRT : constant String := " not supported by configuration>"; + + S : String (1 .. Feature'Length + 1 + CCRT'Length); + L : Natural; + + begin + S (1) := '|'; + S (2 .. Feature'Length + 1) := Feature; + L := Feature'Length + 2; + + if No_Run_Time_Mode then + S (L .. L + CNRT'Length - 1) := CNRT; + L := L + CNRT'Length - 1; + + else pragma Assert (Configurable_Run_Time_Mode); + S (L .. L + CCRT'Length - 1) := CCRT; + L := L + CCRT'Length - 1; + end if; + + Error_Msg_N (S (1 .. L), N); + Configurable_Run_Time_Violations := Configurable_Run_Time_Violations + 1; + end Error_Msg_CRT; + + ----------------- + -- Error_Msg_F -- + ----------------- + + procedure Error_Msg_F (Msg : String; N : Node_Id) is + begin + Error_Msg_NEL (Msg, N, N, Sloc (First_Node (N))); + end Error_Msg_F; + + ------------------ + -- Error_Msg_FE -- + ------------------ + + procedure Error_Msg_FE + (Msg : String; + N : Node_Id; + E : Node_Or_Entity_Id) + is + begin + Error_Msg_NEL (Msg, N, E, Sloc (First_Node (N))); + end Error_Msg_FE; + + ------------------------ + -- Error_Msg_Internal -- + ------------------------ + + procedure Error_Msg_Internal + (Msg : String; + Sptr : Source_Ptr; + Optr : Source_Ptr; + Msg_Cont : Boolean) + is + Next_Msg : Error_Msg_Id; + -- Pointer to next message at insertion point + + Prev_Msg : Error_Msg_Id; + -- Pointer to previous message at insertion point + + Temp_Msg : Error_Msg_Id; + + procedure Handle_Serious_Error; + -- Internal procedure to do all error message handling for a serious + -- error message, other than bumping the error counts and arranging + -- for the message to be output. + + -------------------------- + -- Handle_Serious_Error -- + -------------------------- + + procedure Handle_Serious_Error is + begin + -- Turn off code generation if not done already + + if Operating_Mode = Generate_Code then + Operating_Mode := Check_Semantics; + Expander_Active := False; + end if; + + -- Set the fatal error flag in the unit table unless we are in + -- Try_Semantics mode. This stops the semantics from being performed + -- if we find a serious error. This is skipped if we are currently + -- dealing with the configuration pragma file. + + if not Try_Semantics and then Current_Source_Unit /= No_Unit then + Set_Fatal_Error (Get_Source_Unit (Sptr)); + end if; + end Handle_Serious_Error; + + -- Start of processing for Error_Msg_Internal + + begin + if Raise_Exception_On_Error /= 0 then + raise Error_Msg_Exception; + end if; + + Continuation := Msg_Cont; + Continuation_New_Line := False; + Suppress_Message := False; + Kill_Message := False; + Set_Msg_Text (Msg, Sptr); + + -- Kill continuation if parent message killed + + if Continuation and Last_Killed then + return; + end if; + + -- Return without doing anything if message is suppressed + + if Suppress_Message + and then not All_Errors_Mode + and then not Is_Warning_Msg + and then Msg (Msg'Last) /= '!' + then + if not Continuation then + Last_Killed := True; + end if; + + return; + end if; + + -- Return without doing anything if message is killed and this is not + -- the first error message. The philosophy is that if we get a weird + -- error message and we already have had a message, then we hope the + -- weird message is a junk cascaded message + + if Kill_Message + and then not All_Errors_Mode + and then Total_Errors_Detected /= 0 + then + if not Continuation then + Last_Killed := True; + end if; + + return; + end if; + + -- Special check for warning message to see if it should be output + + if Is_Warning_Msg then + + -- Immediate return if warning message and warnings are suppressed + + if Warnings_Suppressed (Optr) or else Warnings_Suppressed (Sptr) then + Cur_Msg := No_Error_Msg; + return; + end if; + + -- If the flag location is in the main extended source unit then for + -- sure we want the warning since it definitely belongs + + if In_Extended_Main_Source_Unit (Sptr) then + null; + + -- If the flag location is not in the main extended source unit, then + -- we want to eliminate the warning, unless it is in the extended + -- main code unit and we want warnings on the instance. + + elsif In_Extended_Main_Code_Unit (Sptr) and then Warn_On_Instance then + null; + + -- Keep warning if debug flag G set + + elsif Debug_Flag_GG then + null; + + -- Keep warning if message text ends in !! + + elsif Msg (Msg'Last) = '!' and then Msg (Msg'Last - 1) = '!' then + null; + + -- Here is where we delete a warning from a with'ed unit + + else + Cur_Msg := No_Error_Msg; + + if not Continuation then + Last_Killed := True; + end if; + + return; + end if; + end if; + + -- If message is to be ignored in special ignore message mode, this is + -- where we do this special processing, bypassing message output. + + if Ignore_Errors_Enable > 0 then + if Is_Serious_Error then + Handle_Serious_Error; + end if; + + return; + end if; + + -- If error message line length set, and this is a continuation message + -- then all we do is to append the text to the text of the last message + -- with a comma space separator (eliminating a possible (style) or + -- info prefix). + + if Error_Msg_Line_Length /= 0 + and then Continuation + then + Cur_Msg := Errors.Last; + + declare + Oldm : String_Ptr := Errors.Table (Cur_Msg).Text; + Newm : String (1 .. Oldm'Last + 2 + Msglen); + Newl : Natural; + M : Natural; + + begin + -- First copy old message to new one and free it + + Newm (Oldm'Range) := Oldm.all; + Newl := Oldm'Length; + Free (Oldm); + + -- Remove (style) or info: at start of message + + if Msglen > 8 and then Msg_Buffer (1 .. 8) = "(style) " then + M := 9; + + elsif Msglen > 6 and then Msg_Buffer (1 .. 6) = "info: " then + M := 7; + + else + M := 1; + end if; + + -- Now deal with separation between messages. Normally this is + -- simply comma space, but there are some special cases. + + -- If continuation new line, then put actual NL character in msg + + if Continuation_New_Line then + Newl := Newl + 1; + Newm (Newl) := ASCII.LF; + + -- If continuation message is enclosed in parentheses, then + -- special treatment (don't need a comma, and we want to combine + -- successive parenthetical remarks into a single one with + -- separating commas). + + elsif Msg_Buffer (M) = '(' and then Msg_Buffer (Msglen) = ')' then + + -- Case where existing message ends in right paren, remove + -- and separate parenthetical remarks with a comma. + + if Newm (Newl) = ')' then + Newm (Newl) := ','; + Msg_Buffer (M) := ' '; + + -- Case where we are adding new parenthetical comment + + else + Newl := Newl + 1; + Newm (Newl) := ' '; + end if; + + -- Case where continuation not in parens and no new line + + else + Newm (Newl + 1 .. Newl + 2) := ", "; + Newl := Newl + 2; + end if; + + -- Append new message + + Newm (Newl + 1 .. Newl + Msglen - M + 1) := + Msg_Buffer (M .. Msglen); + Newl := Newl + Msglen - M + 1; + Errors.Table (Cur_Msg).Text := new String'(Newm (1 .. Newl)); + end; + + return; + end if; + + -- Otherwise build error message object for new message + + Errors.Append + ((Text => new String'(Msg_Buffer (1 .. Msglen)), + Next => No_Error_Msg, + Prev => No_Error_Msg, + Sptr => Sptr, + Optr => Optr, + Sfile => Get_Source_File_Index (Sptr), + Line => Get_Physical_Line_Number (Sptr), + Col => Get_Column_Number (Sptr), + Warn => Is_Warning_Msg, + Style => Is_Style_Msg, + Serious => Is_Serious_Error, + Uncond => Is_Unconditional_Msg, + Msg_Cont => Continuation, + Deleted => False)); + Cur_Msg := Errors.Last; + + -- If immediate errors mode set, output error message now. Also output + -- now if the -d1 debug flag is set (so node number message comes out + -- just before actual error message) + + if Debug_Flag_OO or else Debug_Flag_1 then + Write_Eol; + Output_Source_Line + (Errors.Table (Cur_Msg).Line, Errors.Table (Cur_Msg).Sfile, True); + Temp_Msg := Cur_Msg; + Output_Error_Msgs (Temp_Msg); + + -- If not in immediate errors mode, then we insert the message in the + -- error chain for later output by Finalize. The messages are sorted + -- first by unit (main unit comes first), and within a unit by source + -- location (earlier flag location first in the chain). + + else + -- First a quick check, does this belong at the very end of the chain + -- of error messages. This saves a lot of time in the normal case if + -- there are lots of messages. + + if Last_Error_Msg /= No_Error_Msg + and then Errors.Table (Cur_Msg).Sfile = + Errors.Table (Last_Error_Msg).Sfile + and then (Sptr > Errors.Table (Last_Error_Msg).Sptr + or else + (Sptr = Errors.Table (Last_Error_Msg).Sptr + and then + Optr > Errors.Table (Last_Error_Msg).Optr)) + then + Prev_Msg := Last_Error_Msg; + Next_Msg := No_Error_Msg; + + -- Otherwise do a full sequential search for the insertion point + + else + Prev_Msg := No_Error_Msg; + Next_Msg := First_Error_Msg; + while Next_Msg /= No_Error_Msg loop + exit when + Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile; + + if Errors.Table (Cur_Msg).Sfile = + Errors.Table (Next_Msg).Sfile + then + exit when Sptr < Errors.Table (Next_Msg).Sptr + or else + (Sptr = Errors.Table (Next_Msg).Sptr + and then + Optr < Errors.Table (Next_Msg).Optr); + end if; + + Prev_Msg := Next_Msg; + Next_Msg := Errors.Table (Next_Msg).Next; + end loop; + end if; + + -- Now we insert the new message in the error chain. The insertion + -- point for the message is after Prev_Msg and before Next_Msg. + + -- The possible insertion point for the new message is after Prev_Msg + -- and before Next_Msg. However, this is where we do a special check + -- for redundant parsing messages, defined as messages posted on the + -- same line. The idea here is that probably such messages are junk + -- from the parser recovering. In full errors mode, we don't do this + -- deletion, but otherwise such messages are discarded at this stage. + + if Prev_Msg /= No_Error_Msg + and then Errors.Table (Prev_Msg).Line = + Errors.Table (Cur_Msg).Line + and then Errors.Table (Prev_Msg).Sfile = + Errors.Table (Cur_Msg).Sfile + and then Compiler_State = Parsing + and then not All_Errors_Mode + then + -- Don't delete unconditional messages and at this stage, don't + -- delete continuation lines (we attempted to delete those earlier + -- if the parent message was deleted. + + if not Errors.Table (Cur_Msg).Uncond + and then not Continuation + then + -- Don't delete if prev msg is warning and new msg is an error. + -- This is because we don't want a real error masked by a + -- warning. In all other cases (that is parse errors for the + -- same line that are not unconditional) we do delete the + -- message. This helps to avoid junk extra messages from + -- cascaded parsing errors + + if not (Errors.Table (Prev_Msg).Warn + or else + Errors.Table (Prev_Msg).Style) + or else + (Errors.Table (Cur_Msg).Warn + or else + Errors.Table (Cur_Msg).Style) + then + -- All tests passed, delete the message by simply returning + -- without any further processing. + + if not Continuation then + Last_Killed := True; + end if; + + return; + end if; + end if; + end if; + + -- Come here if message is to be inserted in the error chain + + if not Continuation then + Last_Killed := False; + end if; + + if Prev_Msg = No_Error_Msg then + First_Error_Msg := Cur_Msg; + else + Errors.Table (Prev_Msg).Next := Cur_Msg; + end if; + + Errors.Table (Cur_Msg).Next := Next_Msg; + + if Next_Msg = No_Error_Msg then + Last_Error_Msg := Cur_Msg; + end if; + end if; + + -- Bump appropriate statistics count + + if Errors.Table (Cur_Msg).Warn or else Errors.Table (Cur_Msg).Style then + Warnings_Detected := Warnings_Detected + 1; + + else + Total_Errors_Detected := Total_Errors_Detected + 1; + + if Errors.Table (Cur_Msg).Serious then + Serious_Errors_Detected := Serious_Errors_Detected + 1; + Handle_Serious_Error; + end if; + end if; + + -- If too many warnings turn off warnings + + if Maximum_Messages /= 0 then + if Warnings_Detected = Maximum_Messages then + Warning_Mode := Suppress; + end if; + + -- If too many errors abandon compilation + + if Total_Errors_Detected = Maximum_Messages then + raise Unrecoverable_Error; + end if; + end if; + end Error_Msg_Internal; + + ----------------- + -- Error_Msg_N -- + ----------------- + + procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is + begin + Error_Msg_NEL (Msg, N, N, Sloc (N)); + end Error_Msg_N; + + ------------------ + -- Error_Msg_NE -- + ------------------ + + procedure Error_Msg_NE + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id) + is + begin + Error_Msg_NEL (Msg, N, E, Sloc (N)); + end Error_Msg_NE; + + ------------------- + -- Error_Msg_NEL -- + ------------------- + + procedure Error_Msg_NEL + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id; + Flag_Location : Source_Ptr) + is + begin + if Special_Msg_Delete (Msg, N, E) then + return; + end if; + + Test_Style_Warning_Serious_Msg (Msg); + + -- Special handling for warning messages + + if Is_Warning_Msg then + + -- Suppress if no warnings set for either entity or node + + if No_Warnings (N) or else No_Warnings (E) then + + -- Disable any continuation messages as well + + Last_Killed := True; + return; + end if; + + -- Suppress if inside loop that is known to be null or is probably + -- null (case where loop executes only if invalid values present). + -- In either case warnings in the loop are likely to be junk. + + declare + P : Node_Id; + + begin + P := Parent (N); + while Present (P) loop + if Nkind (P) = N_Loop_Statement + and then Suppress_Loop_Warnings (P) + then + return; + end if; + + P := Parent (P); + end loop; + end; + end if; + + -- Test for message to be output + + if All_Errors_Mode + or else Msg (Msg'Last) = '!' + or else Is_Warning_Msg + or else OK_Node (N) + or else (Msg (Msg'First) = '\' and then not Last_Killed) + then + Debug_Output (N); + Error_Msg_Node_1 := E; + Error_Msg (Msg, Flag_Location); + + else + Last_Killed := True; + end if; + + if not (Is_Warning_Msg or Is_Style_Msg) then + Set_Posted (N); + end if; + end Error_Msg_NEL; + + ------------------ + -- Error_Msg_NW -- + ------------------ + + procedure Error_Msg_NW + (Eflag : Boolean; + Msg : String; + N : Node_Or_Entity_Id) + is + begin + if Eflag + and then In_Extended_Main_Source_Unit (N) + and then Comes_From_Source (N) + then + Error_Msg_NEL (Msg, N, N, Sloc (N)); + end if; + end Error_Msg_NW; + + ----------------- + -- Error_Msg_S -- + ----------------- + + procedure Error_Msg_S (Msg : String) is + begin + Error_Msg (Msg, Scan_Ptr); + end Error_Msg_S; + + ------------------ + -- Error_Msg_SC -- + ------------------ + + procedure Error_Msg_SC (Msg : String) is + begin + -- If we are at end of file, post the flag after the previous token + + if Token = Tok_EOF then + Error_Msg_AP (Msg); + + -- For all other cases the message is posted at the current token + -- pointer position + + else + Error_Msg (Msg, Token_Ptr); + end if; + end Error_Msg_SC; + + ------------------ + -- Error_Msg_SP -- + ------------------ + + procedure Error_Msg_SP (Msg : String) is + begin + -- Note: in the case where there is no previous token, Prev_Token_Ptr + -- is set to Source_First, which is a reasonable position for the + -- error flag in this situation + + Error_Msg (Msg, Prev_Token_Ptr); + end Error_Msg_SP; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Last_Call : Boolean) is + Cur : Error_Msg_Id; + Nxt : Error_Msg_Id; + F : Error_Msg_Id; + + procedure Delete_Warning (E : Error_Msg_Id); + -- Delete a message if not already deleted and adjust warning count + + -------------------- + -- Delete_Warning -- + -------------------- + + procedure Delete_Warning (E : Error_Msg_Id) is + begin + if not Errors.Table (E).Deleted then + Errors.Table (E).Deleted := True; + Warnings_Detected := Warnings_Detected - 1; + end if; + end Delete_Warning; + + -- Start of message for Finalize + + begin + -- Set Prev pointers + + Cur := First_Error_Msg; + while Cur /= No_Error_Msg loop + Nxt := Errors.Table (Cur).Next; + exit when Nxt = No_Error_Msg; + Errors.Table (Nxt).Prev := Cur; + Cur := Nxt; + end loop; + + -- Eliminate any duplicated error messages from the list. This is + -- done after the fact to avoid problems with Change_Error_Text. + + Cur := First_Error_Msg; + while Cur /= No_Error_Msg loop + Nxt := Errors.Table (Cur).Next; + + F := Nxt; + while F /= No_Error_Msg + and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr + loop + Check_Duplicate_Message (Cur, F); + F := Errors.Table (F).Next; + end loop; + + Cur := Nxt; + end loop; + + -- Mark any messages suppressed by specific warnings as Deleted + + Cur := First_Error_Msg; + while Cur /= No_Error_Msg loop + if not Errors.Table (Cur).Deleted + and then Warning_Specifically_Suppressed + (Errors.Table (Cur).Sptr, Errors.Table (Cur).Text) + then + Delete_Warning (Cur); + + -- If this is a continuation, delete previous messages + + F := Cur; + while Errors.Table (F).Msg_Cont loop + F := Errors.Table (F).Prev; + Delete_Warning (F); + end loop; + + -- Delete any following continuations + + F := Cur; + loop + F := Errors.Table (F).Next; + exit when F = No_Error_Msg; + exit when not Errors.Table (F).Msg_Cont; + Delete_Warning (F); + end loop; + end if; + + Cur := Errors.Table (Cur).Next; + end loop; + + Finalize_Called := True; + + -- Check consistency of specific warnings (may add warnings). We only + -- do this on the last call, after all possible warnings are posted. + + if Last_Call then + Validate_Specific_Warnings (Error_Msg'Access); + end if; + end Finalize; + + ---------------- + -- First_Node -- + ---------------- + + function First_Node (C : Node_Id) return Node_Id is + L : constant Source_Ptr := Sloc (Original_Node (C)); + Sfile : constant Source_File_Index := Get_Source_File_Index (L); + Earliest : Node_Id; + Eloc : Source_Ptr; + + function Test_Earlier (N : Node_Id) return Traverse_Result; + -- Function applied to every node in the construct + + procedure Search_Tree_First is new Traverse_Proc (Test_Earlier); + -- Create traversal procedure + + ------------------ + -- Test_Earlier -- + ------------------ + + function Test_Earlier (N : Node_Id) return Traverse_Result is + Loc : constant Source_Ptr := Sloc (Original_Node (N)); + + begin + -- Check for earlier. The tests for being in the same file ensures + -- against strange cases of foreign code somehow being present. We + -- don't want wild placement of messages if that happens, so it is + -- best to just ignore this situation. + + if Loc < Eloc + and then Get_Source_File_Index (Loc) = Sfile + then + Earliest := Original_Node (N); + Eloc := Loc; + end if; + + return OK_Orig; + end Test_Earlier; + + -- Start of processing for First_Node + + begin + Earliest := Original_Node (C); + Eloc := Sloc (Earliest); + Search_Tree_First (Original_Node (C)); + return Earliest; + end First_Node; + + ---------------- + -- First_Sloc -- + ---------------- + + function First_Sloc (N : Node_Id) return Source_Ptr is + SI : constant Source_File_Index := Source_Index (Get_Source_Unit (N)); + SF : constant Source_Ptr := Source_First (SI); + F : Node_Id; + S : Source_Ptr; + + begin + F := First_Node (N); + S := Sloc (F); + + -- The following circuit is a bit subtle. When we have parenthesized + -- expressions, then the Sloc will not record the location of the paren, + -- but we would like to post the flag on the paren. So what we do is to + -- crawl up the tree from the First_Node, adjusting the Sloc value for + -- any parentheses we know are present. Yes, we know this circuit is not + -- 100% reliable (e.g. because we don't record all possible paren level + -- values), but this is only for an error message so it is good enough. + + Node_Loop : loop + Paren_Loop : for J in 1 .. Paren_Count (F) loop + + -- We don't look more than 12 characters behind the current + -- location, and in any case not past the front of the source. + + Search_Loop : for K in 1 .. 12 loop + exit Search_Loop when S = SF; + + if Source_Text (SI) (S - 1) = '(' then + S := S - 1; + exit Search_Loop; + + elsif Source_Text (SI) (S - 1) <= ' ' then + S := S - 1; + + else + exit Search_Loop; + end if; + end loop Search_Loop; + end loop Paren_Loop; + + exit Node_Loop when F = N; + F := Parent (F); + exit Node_Loop when Nkind (F) not in N_Subexpr; + end loop Node_Loop; + + return S; + end First_Sloc; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Errors.Init; + First_Error_Msg := No_Error_Msg; + Last_Error_Msg := No_Error_Msg; + Serious_Errors_Detected := 0; + Total_Errors_Detected := 0; + Warnings_Detected := 0; + Cur_Msg := No_Error_Msg; + List_Pragmas.Init; + + -- Initialize warnings table, if all warnings are suppressed, supply an + -- initial dummy entry covering all possible source locations. + + Warnings.Init; + Specific_Warnings.Init; + + if Warning_Mode = Suppress then + Warnings.Append + ((Start => Source_Ptr'First, Stop => Source_Ptr'Last)); + end if; + end Initialize; + + ----------------- + -- No_Warnings -- + ----------------- + + function No_Warnings (N : Node_Or_Entity_Id) return Boolean is + begin + if Error_Posted (N) then + return True; + + elsif Nkind (N) in N_Entity and then Has_Warnings_Off (N) then + return True; + + elsif Is_Entity_Name (N) + and then Present (Entity (N)) + and then Has_Warnings_Off (Entity (N)) + then + return True; + + else + return False; + end if; + end No_Warnings; + + ------------- + -- OK_Node -- + ------------- + + function OK_Node (N : Node_Id) return Boolean is + K : constant Node_Kind := Nkind (N); + + begin + if Error_Posted (N) then + return False; + + elsif K in N_Has_Etype + and then Present (Etype (N)) + and then Error_Posted (Etype (N)) + then + return False; + + elsif (K in N_Op + or else K = N_Attribute_Reference + or else K = N_Character_Literal + or else K = N_Expanded_Name + or else K = N_Identifier + or else K = N_Operator_Symbol) + and then Present (Entity (N)) + and then Error_Posted (Entity (N)) + then + return False; + else + return True; + end if; + end OK_Node; + + --------------------- + -- Output_Messages -- + --------------------- + + procedure Output_Messages is + E : Error_Msg_Id; + Err_Flag : Boolean; + + procedure Write_Error_Summary; + -- Write error summary + + procedure Write_Header (Sfile : Source_File_Index); + -- Write header line (compiling or checking given file) + + procedure Write_Max_Errors; + -- Write message if max errors reached + + ------------------------- + -- Write_Error_Summary -- + ------------------------- + + procedure Write_Error_Summary is + begin + -- Extra blank line if error messages or source listing were output + + if Total_Errors_Detected + Warnings_Detected > 0 + or else Full_List + then + Write_Eol; + end if; + + -- Message giving number of lines read and number of errors detected. + -- This normally goes to Standard_Output. The exception is when brief + -- mode is not set, verbose mode (or full list mode) is set, and + -- there are errors. In this case we send the message to standard + -- error to make sure that *something* appears on standard error in + -- an error situation. + + -- Formerly, only the "# errors" suffix was sent to stderr, whereas + -- "# lines:" appeared on stdout. This caused problems on VMS when + -- the stdout buffer was flushed, giving an extra line feed after + -- the prefix. + + if Total_Errors_Detected + Warnings_Detected /= 0 + and then not Brief_Output + and then (Verbose_Mode or Full_List) + then + Set_Standard_Error; + end if; + + -- Message giving total number of lines + + Write_Str (" "); + Write_Int (Num_Source_Lines (Main_Source_File)); + + if Num_Source_Lines (Main_Source_File) = 1 then + Write_Str (" line: "); + else + Write_Str (" lines: "); + end if; + + if Total_Errors_Detected = 0 then + Write_Str ("No errors"); + + elsif Total_Errors_Detected = 1 then + Write_Str ("1 error"); + + else + Write_Int (Total_Errors_Detected); + Write_Str (" errors"); + end if; + + if Warnings_Detected /= 0 then + Write_Str (", "); + Write_Int (Warnings_Detected); + Write_Str (" warning"); + + if Warnings_Detected /= 1 then + Write_Char ('s'); + end if; + + if Warning_Mode = Treat_As_Error then + Write_Str (" (treated as error"); + + if Warnings_Detected /= 1 then + Write_Char ('s'); + end if; + + Write_Char (')'); + end if; + end if; + + Write_Eol; + Set_Standard_Output; + end Write_Error_Summary; + + ------------------ + -- Write_Header -- + ------------------ + + procedure Write_Header (Sfile : Source_File_Index) is + begin + if Verbose_Mode or Full_List then + if Original_Operating_Mode = Generate_Code then + Write_Str ("Compiling: "); + else + Write_Str ("Checking: "); + end if; + + Write_Name (Full_File_Name (Sfile)); + + if not Debug_Flag_7 then + Write_Str (" (source file time stamp: "); + Write_Time_Stamp (Sfile); + Write_Char (')'); + end if; + + Write_Eol; + end if; + end Write_Header; + + ---------------------- + -- Write_Max_Errors -- + ---------------------- + + procedure Write_Max_Errors is + begin + if Maximum_Messages /= 0 then + if Warnings_Detected >= Maximum_Messages then + Set_Standard_Error; + Write_Line ("maximum number of warnings output"); + Write_Line ("any further warnings suppressed"); + Set_Standard_Output; + end if; + + -- If too many errors print message + + if Total_Errors_Detected >= Maximum_Messages then + Set_Standard_Error; + Write_Line ("fatal error: maximum number of errors detected"); + Set_Standard_Output; + end if; + end if; + end Write_Max_Errors; + + -- Start of processing for Output_Messages + + begin + -- Error if Finalize has not been called + + if not Finalize_Called then + raise Program_Error; + end if; + + -- Reset current error source file if the main unit has a pragma + -- Source_Reference. This ensures outputting the proper name of + -- the source file in this situation. + + if Main_Source_File = No_Source_File + or else Num_SRef_Pragmas (Main_Source_File) /= 0 + then + Current_Error_Source_File := No_Source_File; + end if; + + -- Brief Error mode + + if Brief_Output or (not Full_List and not Verbose_Mode) then + Set_Standard_Error; + + E := First_Error_Msg; + while E /= No_Error_Msg loop + if not Errors.Table (E).Deleted and then not Debug_Flag_KK then + if Full_Path_Name_For_Brief_Errors then + Write_Name (Full_Ref_Name (Errors.Table (E).Sfile)); + else + Write_Name (Reference_Name (Errors.Table (E).Sfile)); + end if; + + Write_Char (':'); + Write_Int (Int (Physical_To_Logical + (Errors.Table (E).Line, + Errors.Table (E).Sfile))); + Write_Char (':'); + + if Errors.Table (E).Col < 10 then + Write_Char ('0'); + end if; + + Write_Int (Int (Errors.Table (E).Col)); + Write_Str (": "); + Output_Msg_Text (E); + Write_Eol; + end if; + + E := Errors.Table (E).Next; + end loop; + + Set_Standard_Output; + end if; + + -- Full source listing case + + if Full_List then + List_Pragmas_Index := 1; + List_Pragmas_Mode := True; + E := First_Error_Msg; + + -- Normal case, to stdout (copyright notice already output) + + if Full_List_File_Name = null then + if not Debug_Flag_7 then + Write_Eol; + end if; + + -- Output to file + + else + Create_List_File_Access.all (Full_List_File_Name.all); + Set_Special_Output (Write_List_Info_Access.all'Access); + + -- Write copyright notice to file + + if not Debug_Flag_7 then + Write_Str ("GNAT "); + Write_Str (Gnat_Version_String); + Write_Eol; + Write_Str ("Copyright 1992-" & + Current_Year & + ", Free Software Foundation, Inc."); + Write_Eol; + end if; + end if; + + -- First list extended main source file units with errors + + for U in Main_Unit .. Last_Unit loop + if In_Extended_Main_Source_Unit (Cunit_Entity (U)) + + -- If debug flag d.m is set, only the main source is listed + + and then (U = Main_Unit or else not Debug_Flag_Dot_M) + + -- If the unit of the entity does not come from source, it is + -- an implicit subprogram declaration for a child subprogram. + -- Do not emit errors for it, they are listed with the body. + + and then + (No (Cunit_Entity (U)) + or else Comes_From_Source (Cunit_Entity (U)) + or else not Is_Subprogram (Cunit_Entity (U))) + then + declare + Sfile : constant Source_File_Index := Source_Index (U); + + begin + Write_Eol; + Write_Header (Sfile); + Write_Eol; + + -- Normally, we don't want an "error messages from file" + -- message when listing the entire file, so we set the + -- current source file as the current error source file. + -- However, the old style of doing things was to list this + -- message if pragma Source_Reference is present, even for + -- the main unit. Since the purpose of the -gnatd.m switch + -- is to duplicate the old behavior, we skip the reset if + -- this debug flag is set. + + if not Debug_Flag_Dot_M then + Current_Error_Source_File := Sfile; + end if; + + for N in 1 .. Last_Source_Line (Sfile) loop + while E /= No_Error_Msg + and then Errors.Table (E).Deleted + loop + E := Errors.Table (E).Next; + end loop; + + Err_Flag := + E /= No_Error_Msg + and then Errors.Table (E).Line = N + and then Errors.Table (E).Sfile = Sfile; + + Output_Source_Line (N, Sfile, Err_Flag); + + if Err_Flag then + Output_Error_Msgs (E); + + if not Debug_Flag_2 then + Write_Eol; + end if; + end if; + end loop; + end; + end if; + end loop; + + -- Then output errors, if any, for subsidiary units not in the + -- main extended unit. + + -- Note: if debug flag d.m set, include errors for any units other + -- than the main unit in the extended source unit (e.g. spec and + -- subunits for a body). + + while E /= No_Error_Msg + and then (not In_Extended_Main_Source_Unit (Errors.Table (E).Sptr) + or else + (Debug_Flag_Dot_M + and then Get_Source_Unit + (Errors.Table (E).Sptr) /= Main_Unit)) + loop + if Errors.Table (E).Deleted then + E := Errors.Table (E).Next; + + else + Write_Eol; + Output_Source_Line + (Errors.Table (E).Line, Errors.Table (E).Sfile, True); + Output_Error_Msgs (E); + end if; + end loop; + + -- If output to file, write extra copy of error summary to the + -- output file, and then close it. + + if Full_List_File_Name /= null then + Write_Error_Summary; + Write_Max_Errors; + Close_List_File_Access.all; + Cancel_Special_Output; + end if; + end if; + + -- Verbose mode (error lines only with error flags). Normally this is + -- ignored in full list mode, unless we are listing to a file, in which + -- case we still generate -gnatv output to standard output. + + if Verbose_Mode + and then (not Full_List or else Full_List_File_Name /= null) + then + Write_Eol; + Write_Header (Main_Source_File); + E := First_Error_Msg; + + -- Loop through error lines + + while E /= No_Error_Msg loop + if Errors.Table (E).Deleted then + E := Errors.Table (E).Next; + else + Write_Eol; + Output_Source_Line + (Errors.Table (E).Line, Errors.Table (E).Sfile, True); + Output_Error_Msgs (E); + end if; + end loop; + end if; + + -- Output error summary if verbose or full list mode + + if Verbose_Mode or else Full_List then + Write_Error_Summary; + end if; + + Write_Max_Errors; + + if Warning_Mode = Treat_As_Error then + Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected; + Warnings_Detected := 0; + end if; + end Output_Messages; + + ------------------------ + -- Output_Source_Line -- + ------------------------ + + procedure Output_Source_Line + (L : Physical_Line_Number; + Sfile : Source_File_Index; + Errs : Boolean) + is + S : Source_Ptr; + C : Character; + + Line_Number_Output : Boolean := False; + -- Set True once line number is output + + Empty_Line : Boolean := True; + -- Set False if line includes at least one character + + begin + if Sfile /= Current_Error_Source_File then + Write_Str ("==============Error messages for "); + + case Sinput.File_Type (Sfile) is + when Sinput.Src => + Write_Str ("source"); + + when Sinput.Config => + Write_Str ("configuration pragmas"); + + when Sinput.Def => + Write_Str ("symbol definition"); + + when Sinput.Preproc => + Write_Str ("preprocessing data"); + end case; + + Write_Str (" file: "); + Write_Name (Full_File_Name (Sfile)); + Write_Eol; + + if Num_SRef_Pragmas (Sfile) > 0 then + Write_Str ("--------------Line numbers from file: "); + Write_Name (Full_Ref_Name (Sfile)); + Write_Str (" (starting at line "); + Write_Int (Int (First_Mapped_Line (Sfile))); + Write_Char (')'); + Write_Eol; + end if; + + Current_Error_Source_File := Sfile; + end if; + + if Errs or List_Pragmas_Mode then + Output_Line_Number (Physical_To_Logical (L, Sfile)); + Line_Number_Output := True; + end if; + + S := Line_Start (L, Sfile); + + loop + C := Source_Text (Sfile) (S); + exit when C = ASCII.LF or else C = ASCII.CR or else C = EOF; + + -- Deal with matching entry in List_Pragmas table + + if Full_List + and then List_Pragmas_Index <= List_Pragmas.Last + and then S = List_Pragmas.Table (List_Pragmas_Index).Ploc + then + case List_Pragmas.Table (List_Pragmas_Index).Ptyp is + when Page => + Write_Char (C); + + -- Ignore if on line with errors so that error flags + -- get properly listed with the error line . + + if not Errs then + Write_Char (ASCII.FF); + end if; + + when List_On => + List_Pragmas_Mode := True; + + if not Line_Number_Output then + Output_Line_Number (Physical_To_Logical (L, Sfile)); + Line_Number_Output := True; + end if; + + Write_Char (C); + + when List_Off => + Write_Char (C); + List_Pragmas_Mode := False; + end case; + + List_Pragmas_Index := List_Pragmas_Index + 1; + + -- Normal case (no matching entry in List_Pragmas table) + + else + if Errs or List_Pragmas_Mode then + Write_Char (C); + end if; + end if; + + Empty_Line := False; + S := S + 1; + end loop; + + -- If we have output a source line, then add the line terminator, with + -- training spaces preserved (so we output the line exactly as input). + + if Line_Number_Output then + if Empty_Line then + Write_Eol; + else + Write_Eol_Keep_Blanks; + end if; + end if; + end Output_Source_Line; + + ----------------------------- + -- Remove_Warning_Messages -- + ----------------------------- + + procedure Remove_Warning_Messages (N : Node_Id) is + + function Check_For_Warning (N : Node_Id) return Traverse_Result; + -- This function checks one node for a possible warning message + + function Check_All_Warnings is new Traverse_Func (Check_For_Warning); + -- This defines the traversal operation + + ----------------------- + -- Check_For_Warning -- + ----------------------- + + function Check_For_Warning (N : Node_Id) return Traverse_Result is + Loc : constant Source_Ptr := Sloc (N); + E : Error_Msg_Id; + + function To_Be_Removed (E : Error_Msg_Id) return Boolean; + -- Returns True for a message that is to be removed. Also adjusts + -- warning count appropriately. + + ------------------- + -- To_Be_Removed -- + ------------------- + + function To_Be_Removed (E : Error_Msg_Id) return Boolean is + begin + if E /= No_Error_Msg + + -- Don't remove if location does not match + + and then Errors.Table (E).Optr = Loc + + -- Don't remove if not warning/info message. Note that we do + -- not remove style messages here. They are warning messages + -- but not ones we want removed in this context. + + and then Errors.Table (E).Warn + + -- Don't remove unconditional messages + + and then not Errors.Table (E).Uncond + then + Warnings_Detected := Warnings_Detected - 1; + return True; + + -- No removal required + + else + return False; + end if; + end To_Be_Removed; + + -- Start of processing for Check_For_Warnings + + begin + while To_Be_Removed (First_Error_Msg) loop + First_Error_Msg := Errors.Table (First_Error_Msg).Next; + end loop; + + if First_Error_Msg = No_Error_Msg then + Last_Error_Msg := No_Error_Msg; + end if; + + E := First_Error_Msg; + while E /= No_Error_Msg loop + while To_Be_Removed (Errors.Table (E).Next) loop + Errors.Table (E).Next := + Errors.Table (Errors.Table (E).Next).Next; + + if Errors.Table (E).Next = No_Error_Msg then + Last_Error_Msg := E; + end if; + end loop; + + E := Errors.Table (E).Next; + end loop; + + if Nkind (N) = N_Raise_Constraint_Error + and then Original_Node (N) /= N + and then No (Condition (N)) + then + -- Warnings may have been posted on subexpressions of the original + -- tree. We place the original node back on the tree to remove + -- those warnings, whose sloc do not match those of any node in + -- the current tree. Given that we are in unreachable code, this + -- modification to the tree is harmless. + + declare + Status : Traverse_Final_Result; + + begin + if Is_List_Member (N) then + Set_Condition (N, Original_Node (N)); + Status := Check_All_Warnings (Condition (N)); + else + Rewrite (N, Original_Node (N)); + Status := Check_All_Warnings (N); + end if; + + return Status; + end; + + else + return OK; + end if; + end Check_For_Warning; + + -- Start of processing for Remove_Warning_Messages + + begin + if Warnings_Detected /= 0 then + declare + Discard : Traverse_Final_Result; + pragma Warnings (Off, Discard); + + begin + Discard := Check_All_Warnings (N); + end; + end if; + end Remove_Warning_Messages; + + procedure Remove_Warning_Messages (L : List_Id) is + Stat : Node_Id; + begin + if Is_Non_Empty_List (L) then + Stat := First (L); + while Present (Stat) loop + Remove_Warning_Messages (Stat); + Next (Stat); + end loop; + end if; + end Remove_Warning_Messages; + + --------------------------- + -- Set_Identifier_Casing -- + --------------------------- + + procedure Set_Identifier_Casing + (Identifier_Name : System.Address; + File_Name : System.Address) + is + Ident : constant Big_String_Ptr := To_Big_String_Ptr (Identifier_Name); + File : constant Big_String_Ptr := To_Big_String_Ptr (File_Name); + Flen : Natural; + + Desired_Case : Casing_Type := Mixed_Case; + -- Casing required for result. Default value of Mixed_Case is used if + -- for some reason we cannot find the right file name in the table. + + begin + -- Get length of file name + + Flen := 0; + while File (Flen + 1) /= ASCII.NUL loop + Flen := Flen + 1; + end loop; + + -- Loop through file names to find matching one. This is a bit slow, but + -- we only do it in error situations so it is not so terrible. Note that + -- if the loop does not exit, then the desired case will be left set to + -- Mixed_Case, this can happen if the name was not in canonical form, + -- and gets canonicalized on VMS. Possibly we could fix this by + -- unconditionally canonicalizing these names ??? + + for J in 1 .. Last_Source_File loop + Get_Name_String (Full_Debug_Name (J)); + + if Name_Len = Flen + and then Name_Buffer (1 .. Name_Len) = String (File (1 .. Flen)) + then + Desired_Case := Identifier_Casing (J); + exit; + end if; + end loop; + + -- Copy identifier as given to Name_Buffer + + for J in Name_Buffer'Range loop + Name_Buffer (J) := Ident (J); + + if Name_Buffer (J) = ASCII.NUL then + Name_Len := J - 1; + exit; + end if; + end loop; + + Set_Casing (Desired_Case); + end Set_Identifier_Casing; + + ----------------------- + -- Set_Ignore_Errors -- + ----------------------- + + procedure Set_Ignore_Errors (To : Boolean) is + begin + Errors_Must_Be_Ignored := To; + end Set_Ignore_Errors; + + ------------------------------ + -- Set_Msg_Insertion_Column -- + ------------------------------ + + procedure Set_Msg_Insertion_Column is + begin + if RM_Column_Check then + Set_Msg_Str (" in column "); + Set_Msg_Int (Int (Error_Msg_Col) + 1); + end if; + end Set_Msg_Insertion_Column; + + ---------------------------- + -- Set_Msg_Insertion_Node -- + ---------------------------- + + procedure Set_Msg_Insertion_Node is + K : Node_Kind; + + begin + Suppress_Message := + Error_Msg_Node_1 = Error + or else Error_Msg_Node_1 = Any_Type; + + if Error_Msg_Node_1 = Empty then + Set_Msg_Blank_Conditional; + Set_Msg_Str (""); + + elsif Error_Msg_Node_1 = Error then + Set_Msg_Blank; + Set_Msg_Str (""); + + elsif Error_Msg_Node_1 = Standard_Void_Type then + Set_Msg_Blank; + Set_Msg_Str ("procedure name"); + + else + Set_Msg_Blank_Conditional; + + -- Output name + + K := Nkind (Error_Msg_Node_1); + + -- If we have operator case, skip quotes since name of operator + -- itself will supply the required quotations. An operator can be an + -- applied use in an expression or an explicit operator symbol, or an + -- identifier whose name indicates it is an operator. + + if K in N_Op + or else K = N_Operator_Symbol + or else K = N_Defining_Operator_Symbol + or else ((K = N_Identifier or else K = N_Defining_Identifier) + and then Is_Operator_Name (Chars (Error_Msg_Node_1))) + then + Set_Msg_Node (Error_Msg_Node_1); + + -- Normal case, not an operator, surround with quotes + + else + Set_Msg_Quote; + Set_Qualification (Error_Msg_Qual_Level, Error_Msg_Node_1); + Set_Msg_Node (Error_Msg_Node_1); + Set_Msg_Quote; + end if; + end if; + + -- The following assignment ensures that a second ampersand insertion + -- character will correspond to the Error_Msg_Node_2 parameter. We + -- suppress possible validity checks in case operating in -gnatVa mode, + -- and Error_Msg_Node_2 is not needed and has not been set. + + declare + pragma Suppress (Range_Check); + begin + Error_Msg_Node_1 := Error_Msg_Node_2; + end; + end Set_Msg_Insertion_Node; + + -------------------------------------- + -- Set_Msg_Insertion_Type_Reference -- + -------------------------------------- + + procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr) is + Ent : Entity_Id; + + begin + Set_Msg_Blank; + + if Error_Msg_Node_1 = Standard_Void_Type then + Set_Msg_Str ("package or procedure name"); + return; + + elsif Error_Msg_Node_1 = Standard_Exception_Type then + Set_Msg_Str ("exception name"); + return; + + elsif Error_Msg_Node_1 = Any_Access + or else Error_Msg_Node_1 = Any_Array + or else Error_Msg_Node_1 = Any_Boolean + or else Error_Msg_Node_1 = Any_Character + or else Error_Msg_Node_1 = Any_Composite + or else Error_Msg_Node_1 = Any_Discrete + or else Error_Msg_Node_1 = Any_Fixed + or else Error_Msg_Node_1 = Any_Integer + or else Error_Msg_Node_1 = Any_Modular + or else Error_Msg_Node_1 = Any_Numeric + or else Error_Msg_Node_1 = Any_Real + or else Error_Msg_Node_1 = Any_Scalar + or else Error_Msg_Node_1 = Any_String + then + Get_Unqualified_Decoded_Name_String (Chars (Error_Msg_Node_1)); + Set_Msg_Name_Buffer; + return; + + elsif Error_Msg_Node_1 = Universal_Real then + Set_Msg_Str ("type universal real"); + return; + + elsif Error_Msg_Node_1 = Universal_Integer then + Set_Msg_Str ("type universal integer"); + return; + + elsif Error_Msg_Node_1 = Universal_Fixed then + Set_Msg_Str ("type universal fixed"); + return; + end if; + + -- Special case of anonymous array + + if Nkind (Error_Msg_Node_1) in N_Entity + and then Is_Array_Type (Error_Msg_Node_1) + and then Present (Related_Array_Object (Error_Msg_Node_1)) + then + Set_Msg_Str ("type of "); + Set_Msg_Node (Related_Array_Object (Error_Msg_Node_1)); + Set_Msg_Str (" declared"); + Set_Msg_Insertion_Line_Number + (Sloc (Related_Array_Object (Error_Msg_Node_1)), Flag); + return; + end if; + + -- If we fall through, it is not a special case, so first output + -- the name of the type, preceded by private for a private type + + if Is_Private_Type (Error_Msg_Node_1) then + Set_Msg_Str ("private type "); + else + Set_Msg_Str ("type "); + end if; + + Ent := Error_Msg_Node_1; + + if Is_Internal_Name (Chars (Ent)) then + Unwind_Internal_Type (Ent); + end if; + + -- Types in Standard are displayed as "Standard.name" + + if Sloc (Ent) <= Standard_Location then + Set_Msg_Quote; + Set_Msg_Str ("Standard."); + Set_Msg_Node (Ent); + Add_Class; + Set_Msg_Quote; + + -- Types in other language defined units are displayed as + -- "package-name.type-name" + + elsif + Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Ent))) + then + Get_Unqualified_Decoded_Name_String + (Unit_Name (Get_Source_Unit (Ent))); + Name_Len := Name_Len - 2; + Set_Msg_Quote; + Set_Casing (Mixed_Case); + Set_Msg_Name_Buffer; + Set_Msg_Char ('.'); + Set_Casing (Mixed_Case); + Set_Msg_Node (Ent); + Add_Class; + Set_Msg_Quote; + + -- All other types display as "type name" defined at line xxx + -- possibly qualified if qualification is requested. + + else + Set_Msg_Quote; + Set_Qualification (Error_Msg_Qual_Level, Ent); + Set_Msg_Node (Ent); + Add_Class; + + -- If Ent is an anonymous subprogram type, there is no name to print, + -- so remove enclosing quotes. + + if Buffer_Ends_With ("""") then + Buffer_Remove (""""); + else + Set_Msg_Quote; + end if; + end if; + + -- If the original type did not come from a predefined file, add the + -- location where the type was defined. + + if Sloc (Error_Msg_Node_1) > Standard_Location + and then + not Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Error_Msg_Node_1))) + then + Set_Msg_Str (" defined"); + Set_Msg_Insertion_Line_Number (Sloc (Error_Msg_Node_1), Flag); + + -- If it did come from a predefined file, deal with the case where + -- this was a file with a generic instantiation from elsewhere. + + else + if Sloc (Error_Msg_Node_1) > Standard_Location then + declare + Iloc : constant Source_Ptr := + Instantiation_Location (Sloc (Error_Msg_Node_1)); + + begin + if Iloc /= No_Location + and then not Suppress_Instance_Location + then + Set_Msg_Str (" from instance"); + Set_Msg_Insertion_Line_Number (Iloc, Flag); + end if; + end; + end if; + end if; + end Set_Msg_Insertion_Type_Reference; + + --------------------------------- + -- Set_Msg_Insertion_Unit_Name -- + --------------------------------- + + procedure Set_Msg_Insertion_Unit_Name (Suffix : Boolean := True) is + begin + if Error_Msg_Unit_1 = No_Unit_Name then + null; + + elsif Error_Msg_Unit_1 = Error_Unit_Name then + Set_Msg_Blank; + Set_Msg_Str (""); + + else + Get_Unit_Name_String (Error_Msg_Unit_1, Suffix); + Set_Msg_Blank; + Set_Msg_Quote; + Set_Msg_Name_Buffer; + Set_Msg_Quote; + end if; + + -- The following assignment ensures that a second percent insertion + -- character will correspond to the Error_Msg_Unit_2 parameter. We + -- suppress possible validity checks in case operating in -gnatVa mode, + -- and Error_Msg_Unit_2 is not needed and has not been set. + + declare + pragma Suppress (Range_Check); + begin + Error_Msg_Unit_1 := Error_Msg_Unit_2; + end; + end Set_Msg_Insertion_Unit_Name; + + ------------------ + -- Set_Msg_Node -- + ------------------ + + procedure Set_Msg_Node (Node : Node_Id) is + Ent : Entity_Id; + Nam : Name_Id; + + begin + if Nkind (Node) = N_Designator then + Set_Msg_Node (Name (Node)); + Set_Msg_Char ('.'); + Set_Msg_Node (Identifier (Node)); + return; + + elsif Nkind (Node) = N_Defining_Program_Unit_Name then + Set_Msg_Node (Name (Node)); + Set_Msg_Char ('.'); + Set_Msg_Node (Defining_Identifier (Node)); + return; + + elsif Nkind (Node) = N_Selected_Component then + Set_Msg_Node (Prefix (Node)); + Set_Msg_Char ('.'); + Set_Msg_Node (Selector_Name (Node)); + return; + end if; + + -- The only remaining possibilities are identifiers, defining + -- identifiers, pragmas, and pragma argument associations. + + if Nkind (Node) = N_Pragma then + Nam := Pragma_Name (Node); + + -- The other cases have Chars fields, and we want to test for possible + -- internal names, which generally represent something gone wrong. An + -- exception is the case of internal type names, where we try to find a + -- reasonable external representation for the external name + + elsif Is_Internal_Name (Chars (Node)) + and then + ((Is_Entity_Name (Node) + and then Present (Entity (Node)) + and then Is_Type (Entity (Node))) + or else + (Nkind (Node) = N_Defining_Identifier and then Is_Type (Node))) + then + if Nkind (Node) = N_Identifier then + Ent := Entity (Node); + else + Ent := Node; + end if; + + -- If the type is the designated type of an access_to_subprogram, + -- there is no name to provide in the call. + + if Ekind (Ent) = E_Subprogram_Type then + return; + else + Unwind_Internal_Type (Ent); + Nam := Chars (Ent); + end if; + + -- If not internal name, just use name in Chars field + + else + Nam := Chars (Node); + end if; + + -- At this stage, the name to output is in Nam + + Get_Unqualified_Decoded_Name_String (Nam); + + -- Remove trailing upper case letters from the name (useful for + -- dealing with some cases of internal names. + + while Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' loop + Name_Len := Name_Len - 1; + end loop; + + -- If we have any of the names from standard that start with the + -- characters "any " (e.g. Any_Type), then kill the message since + -- almost certainly it is a junk cascaded message. + + if Name_Len > 4 + and then Name_Buffer (1 .. 4) = "any " + then + Kill_Message := True; + end if; + + -- Now we have to set the proper case. If we have a source location + -- then do a check to see if the name in the source is the same name + -- as the name in the Names table, except for possible differences + -- in case, which is the case when we can copy from the source. + + declare + Src_Loc : constant Source_Ptr := Sloc (Node); + Sbuffer : Source_Buffer_Ptr; + Ref_Ptr : Integer; + Src_Ptr : Source_Ptr; + + begin + Ref_Ptr := 1; + Src_Ptr := Src_Loc; + + -- For standard locations, always use mixed case + + if Src_Loc <= No_Location + or else Sloc (Node) <= No_Location + then + Set_Casing (Mixed_Case); + + else + -- Determine if the reference we are dealing with corresponds to + -- text at the point of the error reference. This will often be + -- the case for simple identifier references, and is the case + -- where we can copy the spelling from the source. + + Sbuffer := Source_Text (Get_Source_File_Index (Src_Loc)); + + while Ref_Ptr <= Name_Len loop + exit when + Fold_Lower (Sbuffer (Src_Ptr)) /= + Fold_Lower (Name_Buffer (Ref_Ptr)); + Ref_Ptr := Ref_Ptr + 1; + Src_Ptr := Src_Ptr + 1; + end loop; + + -- If we get through the loop without a mismatch, then output the + -- name the way it is spelled in the source program + + if Ref_Ptr > Name_Len then + Src_Ptr := Src_Loc; + + for J in 1 .. Name_Len loop + Name_Buffer (J) := Sbuffer (Src_Ptr); + Src_Ptr := Src_Ptr + 1; + end loop; + + -- Otherwise set the casing using the default identifier casing + + else + Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case); + end if; + end if; + end; + + Set_Msg_Name_Buffer; + Add_Class; + end Set_Msg_Node; + + ------------------ + -- Set_Msg_Text -- + ------------------ + + procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is + C : Character; -- Current character + P : Natural; -- Current index; + + begin + Manual_Quote_Mode := False; + Is_Unconditional_Msg := False; + Msglen := 0; + Flag_Source := Get_Source_File_Index (Flag); + + P := Text'First; + while P <= Text'Last loop + C := Text (P); + P := P + 1; + + -- Check for insertion character or sequence + + case C is + when '%' => + if P <= Text'Last and then Text (P) = '%' then + P := P + 1; + Set_Msg_Insertion_Name_Literal; + else + Set_Msg_Insertion_Name; + end if; + + when '$' => + if P <= Text'Last and then Text (P) = '$' then + P := P + 1; + Set_Msg_Insertion_Unit_Name (Suffix => False); + + else + Set_Msg_Insertion_Unit_Name; + end if; + + when '{' => + Set_Msg_Insertion_File_Name; + + when '}' => + Set_Msg_Insertion_Type_Reference (Flag); + + when '*' => + Set_Msg_Insertion_Reserved_Name; + + when '&' => + Set_Msg_Insertion_Node; + + when '#' => + Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag); + + when '\' => + Continuation := True; + + if Text (P) = '\' then + Continuation_New_Line := True; + P := P + 1; + end if; + + when '@' => + Set_Msg_Insertion_Column; + + when '>' => + Set_Msg_Insertion_Run_Time_Name; + + when '^' => + Set_Msg_Insertion_Uint; + + when '`' => + Manual_Quote_Mode := not Manual_Quote_Mode; + Set_Msg_Char ('"'); + + when '!' => + Is_Unconditional_Msg := True; + + when '?' => + null; -- already dealt with + + when '<' => + null; -- already dealt with + + when '|' => + null; -- already dealt with + + when ''' => + Set_Msg_Char (Text (P)); + P := P + 1; + + when '~' => + Set_Msg_Str (Error_Msg_String (1 .. Error_Msg_Strlen)); + + -- Upper case letter + + when 'A' .. 'Z' => + + -- Start of reserved word if two or more + + if P <= Text'Last and then Text (P) in 'A' .. 'Z' then + P := P - 1; + Set_Msg_Insertion_Reserved_Word (Text, P); + + -- Single upper case letter is just inserted + + else + Set_Msg_Char (C); + end if; + + -- Normal character with no special treatment + + when others => + Set_Msg_Char (C); + end case; + end loop; + + VMS_Convert; + end Set_Msg_Text; + + ---------------- + -- Set_Posted -- + ---------------- + + procedure Set_Posted (N : Node_Id) is + P : Node_Id; + + begin + if Is_Serious_Error then + + -- We always set Error_Posted on the node itself + + Set_Error_Posted (N); + + -- If it is a subexpression, then set Error_Posted on parents up to + -- and including the first non-subexpression construct. This helps + -- avoid cascaded error messages within a single expression. + + P := N; + loop + P := Parent (P); + exit when No (P); + Set_Error_Posted (P); + exit when Nkind (P) not in N_Subexpr; + end loop; + + -- A special check, if we just posted an error on an attribute + -- definition clause, then also set the entity involved as posted. + -- For example, this stops complaining about the alignment after + -- complaining about the size, which is likely to be useless. + + if Nkind (P) = N_Attribute_Definition_Clause then + if Is_Entity_Name (Name (P)) then + Set_Error_Posted (Entity (Name (P))); + end if; + end if; + end if; + end Set_Posted; + + ----------------------- + -- Set_Qualification -- + ----------------------- + + procedure Set_Qualification (N : Nat; E : Entity_Id) is + begin + if N /= 0 and then Scope (E) /= Standard_Standard then + Set_Qualification (N - 1, Scope (E)); + Set_Msg_Node (Scope (E)); + Set_Msg_Char ('.'); + end if; + end Set_Qualification; + + ------------------------ + -- Special_Msg_Delete -- + ------------------------ + + -- Is it really right to have all this specialized knowledge in errout? + + function Special_Msg_Delete + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id) return Boolean + is + begin + -- Never delete messages in -gnatdO mode + + if Debug_Flag_OO then + return False; + + -- Processing for "atomic access cannot be guaranteed" + + elsif Msg = "atomic access to & cannot be guaranteed" then + + -- When an atomic object refers to a non-atomic type in the same + -- scope, we implicitly make the type atomic. In the non-error case + -- this is surely safe (and in fact prevents an error from occurring + -- if the type is not atomic by default). But if the object cannot be + -- made atomic, then we introduce an extra junk message by this + -- manipulation, which we get rid of here. + + -- We identify this case by the fact that it references a type for + -- which Is_Atomic is set, but there is no Atomic pragma setting it. + + if Is_Type (E) + and then Is_Atomic (E) + and then No (Get_Rep_Pragma (E, Name_Atomic)) + then + return True; + end if; + + -- Processing for "Size too small" messages + + elsif Msg = "size for& too small, minimum allowed is ^" then + + -- Suppress "size too small" errors in CodePeer mode, since pragma + -- Pack is also ignored in this configuration. + + if CodePeer_Mode then + return True; + + -- When a size is wrong for a frozen type there is no explicit size + -- clause, and other errors have occurred, suppress the message, + -- since it is likely that this size error is a cascaded result of + -- other errors. The reason we eliminate unfrozen types is that + -- messages issued before the freeze type are for sure OK. + + elsif Is_Frozen (E) + and then Serious_Errors_Detected > 0 + and then Nkind (N) /= N_Component_Clause + and then Nkind (Parent (N)) /= N_Component_Clause + and then + No (Get_Attribute_Definition_Clause (E, Attribute_Size)) + and then + No (Get_Attribute_Definition_Clause (E, Attribute_Object_Size)) + and then + No (Get_Attribute_Definition_Clause (E, Attribute_Value_Size)) + then + return True; + end if; + end if; + + -- All special tests complete, so go ahead with message + + return False; + end Special_Msg_Delete; + + -------------------------- + -- Unwind_Internal_Type -- + -------------------------- + + procedure Unwind_Internal_Type (Ent : in out Entity_Id) is + Derived : Boolean := False; + Mchar : Character; + Old_Ent : Entity_Id; + + begin + -- Undo placement of a quote, since we will put it back later + + Mchar := Msg_Buffer (Msglen); + + if Mchar = '"' then + Msglen := Msglen - 1; + end if; + + -- The loop here deals with recursive types, we are trying to find a + -- related entity that is not an implicit type. Note that the check with + -- Old_Ent stops us from getting "stuck". Also, we don't output the + -- "type derived from" message more than once in the case where we climb + -- up multiple levels. + + Find : loop + Old_Ent := Ent; + + -- Implicit access type, use directly designated type In Ada 2005, + -- the designated type may be an anonymous access to subprogram, in + -- which case we can only point to its definition. + + if Is_Access_Type (Ent) then + if Ekind (Ent) = E_Access_Subprogram_Type + or else Ekind (Ent) = E_Anonymous_Access_Subprogram_Type + or else Is_Access_Protected_Subprogram_Type (Ent) + then + Ent := Directly_Designated_Type (Ent); + + if not Comes_From_Source (Ent) then + if Buffer_Ends_With ("type ") then + Buffer_Remove ("type "); + end if; + + if Is_Itype (Ent) then + declare + Assoc : constant Node_Id := + Associated_Node_For_Itype (Ent); + + begin + if Nkind (Assoc) in N_Subprogram_Specification then + + -- Anonymous access to subprogram in a signature. + -- Indicate the enclosing subprogram. + + Ent := + Defining_Unit_Name + (Associated_Node_For_Itype (Ent)); + Set_Msg_Str + ("access to subprogram declared in profile of "); + + else + Set_Msg_Str ("access to subprogram with profile "); + end if; + end; + end if; + + elsif Ekind (Ent) = E_Function then + Set_Msg_Str ("access to function "); + else + Set_Msg_Str ("access to procedure "); + end if; + + exit Find; + + -- Type is access to object, named or anonymous + + else + Set_Msg_Str ("access to "); + Ent := Directly_Designated_Type (Ent); + end if; + + -- Classwide type + + elsif Is_Class_Wide_Type (Ent) then + Class_Flag := True; + Ent := Root_Type (Ent); + + -- Use base type if this is a subtype + + elsif Ent /= Base_Type (Ent) then + Buffer_Remove ("type "); + + -- Avoid duplication "subtype of subtype of", and also replace + -- "derived from subtype of" simply by "derived from" + + if not Buffer_Ends_With ("subtype of ") + and then not Buffer_Ends_With ("derived from ") + then + Set_Msg_Str ("subtype of "); + end if; + + Ent := Base_Type (Ent); + + -- If this is a base type with a first named subtype, use the first + -- named subtype instead. This is not quite accurate in all cases, + -- but it makes too much noise to be accurate and add 'Base in all + -- cases. Note that we only do this is the first named subtype is not + -- itself an internal name. This avoids the obvious loop (subtype -> + -- basetype -> subtype) which would otherwise occur!) + + else + declare + FST : constant Entity_Id := First_Subtype (Ent); + + begin + if not Is_Internal_Name (Chars (FST)) then + Ent := FST; + exit Find; + + -- Otherwise use root type + + else + if not Derived then + Buffer_Remove ("type "); + + -- Test for "subtype of type derived from" which seems + -- excessive and is replaced by "type derived from". + + Buffer_Remove ("subtype of"); + + -- Avoid duplicated "type derived from type derived from" + + if not Buffer_Ends_With ("type derived from ") then + Set_Msg_Str ("type derived from "); + end if; + + Derived := True; + end if; + end if; + end; + + Ent := Etype (Ent); + end if; + + -- If we are stuck in a loop, get out and settle for the internal + -- name after all. In this case we set to kill the message if it is + -- not the first error message (we really try hard not to show the + -- dirty laundry of the implementation to the poor user!) + + if Ent = Old_Ent then + Kill_Message := True; + exit Find; + end if; + + -- Get out if we finally found a non-internal name to use + + exit Find when not Is_Internal_Name (Chars (Ent)); + end loop Find; + + if Mchar = '"' then + Set_Msg_Char ('"'); + end if; + end Unwind_Internal_Type; + + ----------------- + -- VMS_Convert -- + ----------------- + + procedure VMS_Convert is + P : Natural; + L : Natural; + N : Natural; + + begin + if not OpenVMS then + return; + end if; + + P := Msg_Buffer'First; + loop + if P >= Msglen then + return; + end if; + + if Msg_Buffer (P) = '-' then + for G in Gnames'Range loop + L := Gnames (G)'Length; + + -- See if we have "-ggg switch", where ggg is Gnames entry + + if P + L + 7 <= Msglen + and then Msg_Buffer (P + 1 .. P + L) = Gnames (G).all + and then Msg_Buffer (P + L + 1 .. P + L + 7) = " switch" + then + -- Replace by "/vvv qualifier", where vvv is Vnames entry + + N := Vnames (G)'Length; + Msg_Buffer (P + N + 11 .. Msglen + N - L + 3) := + Msg_Buffer (P + L + 8 .. Msglen); + Msg_Buffer (P) := '/'; + Msg_Buffer (P + 1 .. P + N) := Vnames (G).all; + Msg_Buffer (P + N + 1 .. P + N + 10) := " qualifier"; + P := P + N + 10; + Msglen := Msglen + N - L + 3; + exit; + end if; + end loop; + end if; + + P := P + 1; + end loop; + end VMS_Convert; + +end Errout; diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads new file mode 100644 index 000000000..1dc22797c --- /dev/null +++ b/gcc/ada/errout.ads @@ -0,0 +1,828 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E R R O U T -- +-- -- +-- 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. -- +-- -- +-- You should have received a copy of the GNU General Public License along -- +-- with this program; see file COPYING3. If not see -- +-- . -- +-- -- +-- 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 to output error messages. They are +-- basically system independent, however in some environments, e.g. when the +-- parser is embedded into an editor, it may be appropriate to replace the +-- implementation of this package. + +with Err_Vars; +with Erroutc; +with Namet; use Namet; +with Table; +with Types; use Types; +with Uintp; use Uintp; + +with System; + +package Errout is + + Serious_Errors_Detected : Nat renames Err_Vars.Serious_Errors_Detected; + -- This is a count of errors that are serious enough to stop expansion, + -- and hence to prevent generation of an object file even if the switch + -- -gnatQ is set. + + Total_Errors_Detected : Nat renames Err_Vars.Total_Errors_Detected; + -- Number of errors detected so far. Includes count of serious errors and + -- non-serious errors, so this value is always greater than or equal to + -- the Serious_Errors_Detected value. + + Warnings_Detected : Nat renames Err_Vars.Warnings_Detected; + -- Number of warnings detected + + Configurable_Run_Time_Violations : Nat := 0; + -- Count of configurable run time violations so far. This is used to + -- suppress certain cascaded error messages when we know that we may not + -- have fully expanded some items, due to high integrity violations (i.e. + -- the use of constructs not permitted by the library in use, or improper + -- constructs in No_Run_Time mode). + + Current_Error_Source_File : Source_File_Index + renames Err_Vars.Current_Error_Source_File; + -- Id of current messages. Used to post file name when unit changes. This + -- is initialized to Main_Source_File at the start of a compilation, which + -- means that no file names will be output unless there are errors in + -- units other than the main unit. However, if the main unit has a pragma + -- Source_Reference line, then this is initialized to No_Source_File, to + -- force an initial reference to the real source file name. + + Raise_Exception_On_Error : Nat renames Err_Vars.Raise_Exception_On_Error; + -- If this value is non-zero, then any attempt to generate an error + -- message raises the exception Error_Msg_Exception, and the error message + -- is not output. This is used for defending against junk resulting from + -- illegalities, and also for substitution of more appropriate error + -- messages from higher semantic levels. It is a counter so that the + -- increment/decrement protocol nests neatly. + + Error_Msg_Exception : exception renames Err_Vars.Error_Msg_Exception; + -- Exception raised if Raise_Exception_On_Error is true + + ----------------------------------- + -- Suppression of Error Messages -- + ----------------------------------- + + -- In an effort to reduce the impact of redundant error messages, the + -- error output routines in this package normally suppress certain + -- classes of messages as follows: + + -- 1. Identical messages placed at the same point in the text. Such + -- duplicate error message result for example from rescanning + -- sections of the text that contain lexical errors. Only one of + -- such a set of duplicate messages is output, and the rest are + -- suppressed. + + -- 2. If more than one parser message is generated for a single source + -- line, then only the first message is output, the remaining + -- messages on the same line are suppressed. + + -- 3. If a message is posted on a node for which a message has been + -- previously posted, then only the first message is retained. The + -- Error_Posted flag is used to detect such multiple postings. Note + -- that this only applies to semantic messages, since otherwise + -- for parser messages, this would be a special case of case 2. + + -- 4. If a message is posted on a node whose Etype or Entity + -- fields reference entities on which an error message has + -- already been placed, as indicated by the Error_Posted flag + -- being set on these entities, then the message is suppressed. + + -- 5. If a message attempts to insert an Error node, or a direct + -- reference to the Any_Type node, then the message is suppressed. + + -- 6. Note that cases 2-5 only apply to error messages, not warning + -- messages. Warning messages are only suppressed for case 1, and + -- when they come from other than the main extended unit. + + -- This normal suppression action may be overridden in cases 2-5 (but not + -- in case 1) by setting All_Errors mode, or by setting the special + -- unconditional message insertion character (!) at the end of the message + -- text as described below. + + --------------------------------------------------------- + -- Error Message Text and Message Insertion Characters -- + --------------------------------------------------------- + + -- Error message text strings are composed of lower case letters, digits + -- and the special characters space, comma, period, colon and semicolon, + -- apostrophe and parentheses. Special insertion characters can also + -- appear which cause the error message circuit to modify the given + -- string as follows: + + -- Insertion character % (Percent: insert name from Names table) + -- The character % is replaced by the text for the name specified by + -- the Name_Id value stored in Error_Msg_Name_1. A blank precedes the + -- name if it is preceded by a non-blank character other than left + -- parenthesis. The name is enclosed in quotes unless manual quotation + -- mode is set. If the Name_Id is set to No_Name, then no insertion + -- occurs; if the Name_Id is set to Error_Name, then the string + -- is inserted. A second and third % may appear in a single + -- message, similarly replaced by the names which are specified by the + -- Name_Id values stored in Error_Msg_Name_2 and Error_Msg_Name_3. The + -- names are decoded and cased according to the current identifier + -- casing mode. Note: if a unit name ending with %b or %s is passed + -- for this kind of insertion, this suffix is simply stripped. Use a + -- unit name insertion ($) to process the suffix. + + -- Insertion character %% (Double percent: insert literal name) + -- The character sequence %% acts as described above for %, except + -- that the name is simply obtained with Get_Name_String and is not + -- decoded or cased, it is inserted literally from the names table. + -- A trailing %b or %s is not treated specially. + + -- Insertion character $ (Dollar: insert unit name from Names table) + -- The character $ is treated similarly to %, except that the name is + -- obtained from the Unit_Name_Type value in Error_Msg_Unit_1 and + -- Error_Msg_Unit_2, as provided by Get_Unit_Name_String in package + -- Uname. Note that this name includes the postfix (spec) or (body) + -- strings. If this postfix is not required, use the normal % + -- insertion for the unit name. + + -- Insertion character { (Left brace: insert file name from names table) + -- The character { is treated similarly to %, except that the input + -- value is a File_Name_Type value stored in Error_Msg_File_1 or + -- Error_Msg_File_2 or Error_Msg_File_3. The value is output literally, + -- enclosed in quotes as for %, but the case is not modified, the + -- insertion is the exact string stored in the names table without + -- adjusting the casing. + + -- Insertion character * (Asterisk, insert reserved word name) + -- The insertion character * is treated exactly like % except that the + -- resulting name is cased according to the default conventions for + -- reserved words (see package Scans). + + -- Insertion character & (Ampersand: insert name from node) + -- The insertion character & is treated similarly to %, except that + -- the name is taken from the Chars field of the given node, and may + -- refer to a child unit name, or a selected component. The casing is, + -- if possible, taken from the original source reference, which is + -- obtained from the Sloc field of the given node or nodes. If no Sloc + -- is available (happens e.g. for nodes in package Standard), then the + -- default case (see Scans spec) is used. The nodes to be used are + -- stored in Error_Msg_Node_1, Error_Msg_Node_2. No insertion occurs + -- for the Empty node, and the Error node results in the insertion of + -- the characters . In addition, if the special global variable + -- Error_Msg_Qual_Level is non-zero, then the reference will include + -- up to the given number of levels of qualification, using the scope + -- chain. + + -- Insertion character # (Pound: insert line number reference) + -- The character # is replaced by the string indicating the source + -- position stored in Error_Msg_Sloc. There are three cases: + -- + -- for package Standard: in package Standard + -- for locations in current file: at line nnn:ccc + -- for locations in other files: at filename:nnn:ccc + -- + -- By convention, the # insertion character is only used at the end of + -- an error message, so the above strings only appear as the last + -- characters of an error message. The only exceptions to this rule + -- are that an RM reference may follow in the form (RM .....) and a + -- right parenthesis may immediately follow the #. In the case of + -- continued messages, # can only appear at the end of a group of + -- continuation messages, except that \\ messages which always start + -- a new line end the sequence from the point of view of this rule. + -- The idea is that for any use of -gnatj, it will still be the case + -- that a location reference appears only at the end of a line. + + -- Note: the output of the string "at " is suppressed if the string + -- " from" or " from " immediately precedes the insertion character #. + -- Certain messages read better with from than at. + + -- Insertion character } (Right brace: insert type reference) + -- The character } is replaced by a string describing the type + -- referenced by the entity whose Id is stored in Error_Msg_Node_1. + -- the string gives the name or description of the type, and also + -- where appropriate the location of its declaration. Special cases + -- like "some integer type" are handled appropriately. Only one } is + -- allowed in a message, since there is not enough room for two (the + -- insertion can be quite long, including a file name) In addition, if + -- the special global variable Error_Msg_Qual_Level is non-zero, then + -- the reference will include up to the given number of levels of + -- qualification, using the scope chain. + + -- Insertion character @ (At: insert column number reference) + -- The character @ is replaced by null if the RM_Column_Check mode is + -- off (False). If the switch is on (True), then @ is replaced by the + -- text string " in column nnn" where nnn is the decimal + -- representation of the column number stored in Error_Msg_Col plus + -- one (the plus one is because the number is stored 0-origin and + -- displayed 1-origin). + + -- Insertion character ^ (Carret: insert integer value) + -- The character ^ is replaced by the decimal conversion of the Uint + -- value stored in Error_Msg_Uint_1, with a possible leading minus. + -- A second ^ may occur in the message, in which case it is replaced + -- by the decimal conversion of the Uint value in Error_Msg_Uint_2. + + -- Insertion character > (Right bracket, run time name) + -- The character > is replaced by a string of the form (name) if + -- Targparm scanned out a Run_Time_Name (see package Targparm for + -- details). The name is enclosed in parentheses and output in mixed + -- case mode (upper case after any space in the name). If no run time + -- name is defined, this insertion character has no effect. + + -- Insertion character ! (Exclamation: unconditional message) + -- The character ! appearing as the last character of a message makes + -- the message unconditional which means that it is output even if it + -- would normally be suppressed. See section above for a description + -- of the cases in which messages are normally suppressed. Note that + -- in the case of warnings, the meaning is that the warning should not + -- be removed in dead code (that's the only time that the use of ! + -- has any effect for a warning). + -- + -- Note: the presence of ! is ignored in continuation messages (i.e. + -- messages starting with the \ insertion character). The effect of the + -- use of ! in a parent message automatically applies to all of its + -- continuation messages (since we clearly don't want any case in which + -- continuations are separated from the parent message. It is allowable + -- to put ! in continuation messages, and the usual style is to include + -- it, since it makes it clear that the continuation is part of an + -- unconditional message. + + -- Insertion character !! (unconditional warning) + + -- Normally warning messages issued in other than the main unit are + -- suppressed. If the message ends with !! then this suppression is + -- avoided. This is currently used by the Compile_Time_Warning pragma + -- to ensure the message for a with'ed unit is output, and for warnings + -- on ineffective back-end inlining, which is detected in units that + -- contain subprograms to be inlined in the main program. + + -- Insertion character ? (Question: warning message) + -- The character ? appearing anywhere in a message makes the message + -- warning instead of a normal error message, and the text of the + -- message will be preceded by "warning:" in the normal case. The + -- handling of warnings if further controlled by the Warning_Mode + -- option (-w switch), see package Opt for further details, and also by + -- the current setting from pragma Warnings. This pragma applies only + -- to warnings issued from the semantic phase (not the parser), but + -- currently all relevant warnings are posted by the semantic phase + -- anyway. Messages starting with (style) are also treated as warning + -- messages. + -- + -- Note: when a warning message is output, the text of the message is + -- preceded by "warning: " in the normal case. An exception to this + -- rule occurs when the text of the message starts with "info: " in + -- which case this string is not prepended. This allows callers to + -- label certain warnings as informational messages, rather than as + -- warning messages requiring some action. + -- + -- Note: the presence of ? is ignored in continuation messages (i.e. + -- messages starting with the \ insertion character). The warning + -- status of continuations is determined only by the parent message + -- which is being continued. It is allowable to put ? in continuation + -- messages, and the usual style is to include it, since it makes it + -- clear that the continuation is part of a warning message. + + -- Insertion character < (Less Than: conditional warning message) + -- The character < appearing anywhere in a message is used for a + -- conditional error message. If Error_Msg_Warn is True, then the + -- effect is the same as ? described above. If Error_Msg_Warn is + -- False, then there is no effect. + + -- Insertion character A-Z (Upper case letter: Ada reserved word) + -- If two or more upper case letters appear in the message, they are + -- taken as an Ada reserved word, and are converted to the default + -- case for reserved words (see Scans package spec). Surrounding + -- quotes are added unless manual quotation mode is currently set. + + -- Insertion character ` (Backquote: set manual quotation mode) + -- The backquote character always appears in pairs. Each backquote of + -- the pair is replaced by a double quote character. In addition, any + -- reserved keywords, or name insertions between these backquotes are + -- not surrounded by the usual automatic double quotes. See the + -- section below on manual quotation mode for further details. + + -- Insertion character ' (Quote: literal character) + -- Precedes a character which is placed literally into the message. + -- Used to insert characters into messages that are one of the + -- insertion characters defined here. Also useful in inserting + -- sequences of upper case letters (e.g. RM) which are not to be + -- treated as keywords. + + -- Insertion character \ (Backslash: continuation message) + -- Indicates that the message is a continuation of a message + -- previously posted. This is used to ensure that such groups of + -- messages are treated as a unit. The \ character must be the first + -- character of the message text. + + -- Insertion character \\ (Two backslashes, continuation with new line) + -- This differs from \ only in -gnatjnn mode (Error_Message_Line_Length + -- set non-zero). This sequence forces a new line to start even when + -- continuations are being gathered into a single message. + + -- Insertion character | (Vertical bar: non-serious error) + -- By default, error messages (other than warning messages) are + -- considered to be fatal error messages which prevent expansion or + -- generation of code in the presence of the -gnatQ switch. If the + -- insertion character | appears, the message is considered to be + -- non-serious, and does not cause Serious_Errors_Detected to be + -- incremented (so expansion is not prevented by such a msg). + + -- Insertion character ~ (Tilde: insert string) + -- Indicates that Error_Msg_String (1 .. Error_Msg_Strlen) is to be + -- inserted to replace the ~ character. The string is inserted in the + -- literal form it appears, without any action on special characters. + + ---------------------------------------- + -- Specialization of Messages for VMS -- + ---------------------------------------- + + -- Some messages mention gcc-style switch names. When using an OpenVMS + -- host, such switch names must be converted to their corresponding VMS + -- qualifer. The following table controls this translation. In each case + -- the original message must contain the string "-xxx switch", where xxx + -- is the Gname? entry from below, and this string will be replaced by + -- "/yyy qualifier", where yyy is the corresponding Vname? entry. + + Gname1 : aliased constant String := "fno-strict-aliasing"; + Vname1 : aliased constant String := "OPTIMIZE=NO_STRICT_ALIASING"; + + Gname2 : aliased constant String := "gnatX"; + Vname2 : aliased constant String := "EXTENSIONS_ALLOWED"; + + Gname3 : aliased constant String := "gnatW"; + Vname3 : aliased constant String := "WIDE_CHARACTER_ENCODING"; + + Gname4 : aliased constant String := "gnatf"; + Vname4 : aliased constant String := "REPORT_ERRORS=FULL"; + + Gname5 : aliased constant String := "gnat05"; + Vname5 : aliased constant String := "05"; + + Gname6 : aliased constant String := "gnat2005"; + Vname6 : aliased constant String := "2005"; + + Gname7 : aliased constant String := "gnat12"; + Vname7 : aliased constant String := "12"; + + Gname8 : aliased constant String := "gnat2012"; + Vname8 : aliased constant String := "2012"; + + type Cstring_Ptr is access constant String; + + Gnames : array (Nat range <>) of Cstring_Ptr := + (Gname1'Access, + Gname2'Access, + Gname3'Access, + Gname4'Access, + Gname5'Access, + Gname6'Access, + Gname7'Access, + Gname8'Access); + + Vnames : array (Nat range <>) of Cstring_Ptr := + (Vname1'Access, + Vname2'Access, + Vname3'Access, + Vname4'Access, + Vname5'Access, + Vname6'Access, + Vname7'Access, + Vname8'Access); + + ----------------------------------------------------- + -- Global Values Used for Error Message Insertions -- + ----------------------------------------------------- + + -- The following global variables are essentially additional parameters + -- passed to the error message routine for insertion sequences described + -- above. The reason these are passed globally is that the insertion + -- mechanism is essentially an untyped one in which the appropriate + -- variables are set depending on the specific insertion characters used. + + -- Note that is mandatory that the caller ensure that global variables + -- are set before the Error_Msg call, otherwise the result is undefined. + + Error_Msg_Col : Column_Number renames Err_Vars.Error_Msg_Col; + -- Column for @ insertion character in message + + Error_Msg_Uint_1 : Uint renames Err_Vars.Error_Msg_Uint_1; + Error_Msg_Uint_2 : Uint renames Err_Vars.Error_Msg_Uint_2; + -- Uint values for ^ insertion characters in message + + Error_Msg_Sloc : Source_Ptr renames Err_Vars.Error_Msg_Sloc; + -- Source location for # insertion character in message + + Error_Msg_Name_1 : Name_Id renames Err_Vars.Error_Msg_Name_1; + Error_Msg_Name_2 : Name_Id renames Err_Vars.Error_Msg_Name_2; + Error_Msg_Name_3 : Name_Id renames Err_Vars.Error_Msg_Name_3; + -- Name_Id values for % insertion characters in message + + Error_Msg_File_1 : File_Name_Type renames Err_Vars.Error_Msg_File_1; + Error_Msg_File_2 : File_Name_Type renames Err_Vars.Error_Msg_File_2; + Error_Msg_File_3 : File_Name_Type renames Err_Vars.Error_Msg_File_3; + -- File_Name_Type values for { insertion characters in message + + Error_Msg_Unit_1 : Unit_Name_Type renames Err_Vars.Error_Msg_Unit_1; + Error_Msg_Unit_2 : Unit_Name_Type renames Err_Vars.Error_Msg_Unit_2; + -- Unit_Name_Type values for $ insertion characters in message + + Error_Msg_Node_1 : Node_Id renames Err_Vars.Error_Msg_Node_1; + Error_Msg_Node_2 : Node_Id renames Err_Vars.Error_Msg_Node_2; + -- Node_Id values for & insertion characters in message + + Error_Msg_Qual_Level : Int renames Err_Vars.Error_Msg_Qual_Level; + -- Number of levels of qualification required for type name (see the + -- description of the } insertion character. Note that this value does + -- note get reset by any Error_Msg call, so the caller is responsible + -- for resetting it. + + Error_Msg_Warn : Boolean renames Err_Vars.Error_Msg_Warn; + -- Used if current message contains a < insertion character to indicate + -- if the current message is a warning message. + + Error_Msg_String : String renames Err_Vars.Error_Msg_String; + Error_Msg_Strlen : Natural renames Err_Vars.Error_Msg_Strlen; + -- Used if current message contains a ~ insertion character to indicate + -- insertion of the string Error_Msg_String (1 .. Error_Msg_Strlen). + + ----------------------------------------------------- + -- Format of Messages and Manual Quotation Control -- + ----------------------------------------------------- + + -- Messages are generally all in lower case, except for inserted names + -- and appear in one of the following three forms: + + -- error: text + -- warning: text + + -- The prefixes error and warning are supplied automatically (depending + -- on the use of the ? insertion character), and the call to the error + -- message routine supplies the text. The "error: " prefix is omitted + -- in brief error message formats. + + -- Reserved Ada keywords in the message are in the default keyword case + -- (determined from the given source program), surrounded by quotation + -- marks. This is achieved by spelling the reserved word in upper case + -- letters, which is recognized as a request for insertion of quotation + -- marks by the error text processor. Thus for example: + + -- Error_Msg_AP ("IS expected"); + + -- would result in the output of one of the following: + + -- error: "is" expected + -- error: "IS" expected + -- error: "Is" expected + + -- the choice between these being made by looking at the casing convention + -- used for keywords (actually the first compilation unit keyword) in the + -- source file. + + -- Note: a special exception is that RM is never treated as a keyword + -- but instead is copied literally into the message, this avoids the + -- need for writing 'R'M for all reference manual quotes. + + -- In the case of names, the default mode for the error text processor + -- is to surround the name by quotation marks automatically. The case + -- used for the identifier names is taken from the source program where + -- possible, and otherwise is the default casing convention taken from + -- the source file usage. + + -- In some cases, better control over the placement of quote marks is + -- required. This is achieved using manual quotation mode. In this mode, + -- one or more insertion sequences is surrounded by backquote characters. + -- The backquote characters are output as double quote marks, and normal + -- automatic insertion of quotes is suppressed between the double quotes. + -- For example: + + -- Error_Msg_AP ("`END &;` expected"); + + -- generates a message like + + -- error: "end Open_Scope;" expected + + -- where the node specifying the name Open_Scope has been stored in + -- Error_Msg_Node_1 prior to the call. The great majority of error + -- messages operates in normal quotation mode. + + -- Note: the normal automatic insertion of spaces before insertion + -- sequences (such as those that come from & and %) is suppressed in + -- manual quotation mode, so blanks, if needed as in the above example, + -- must be explicitly present. + + ---------------------------- + -- Message ID Definitions -- + ---------------------------- + + subtype Error_Msg_Id is Erroutc.Error_Msg_Id; + function "=" (Left, Right : Error_Msg_Id) return Boolean + renames Erroutc."="; + -- A type used to represent specific error messages. Used by the clients + -- of this package only in the context of the Get_Error_Id and + -- Change_Error_Text subprograms. + + No_Error_Msg : constant Error_Msg_Id := Erroutc.No_Error_Msg; + -- A constant which is different from any value returned by Get_Error_Id. + -- Typically used by a client to indicate absense of a saved Id value. + + function Get_Msg_Id return Error_Msg_Id renames Erroutc.Get_Msg_Id; + -- Returns the Id of the message most recently posted using one of the + -- Error_Msg routines. + + function Get_Location (E : Error_Msg_Id) return Source_Ptr + renames Erroutc.Get_Location; + -- Returns the flag location of the error message with the given id E + + ------------------------ + -- List Pragmas Table -- + ------------------------ + + -- When a pragma Page or pragma List is encountered by the parser, an + -- entry is made in the following table. This table is then used to + -- control the full listing if one is being generated. Note that the + -- reason we do the processing in the parser is so that we get proper + -- listing control even in syntax check only mode. + + type List_Pragma_Type is (List_On, List_Off, Page); + + type List_Pragma_Record is record + Ptyp : List_Pragma_Type; + Ploc : Source_Ptr; + end record; + + -- Note: Ploc points to the terminating semicolon in the List_Off and Page + -- cases, and to the pragma keyword for List_On. In the case of a pragma + -- List_Off, a List_On entry is also made in the table, pointing to the + -- pragma keyword. This ensures that, as required, a List (Off) pragma is + -- listed even in list off mode. + + package List_Pragmas is new Table.Table ( + Table_Component_Type => List_Pragma_Record, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 200, + Table_Name => "List_Pragmas"); + + --------------------------- + -- Ignore_Errors Feature -- + --------------------------- + + -- In certain cases, notably for optional subunits, the compiler operates + -- in a mode where errors are to be ignored, and the whole unit is to be + -- considered as not present. To implement this we provide the following + -- flag to enable special handling, where error messages are suppressed, + -- but the Fatal_Error flag will still be set in the normal manner. + + Ignore_Errors_Enable : Nat := 0; + -- Triggering switch. If non-zero, then ignore errors mode is activated. + -- This is a counter to allow convenient nesting of enable/disable. + + ----------------------- + -- CODEFIX Facility -- + ----------------------- + + -- The GPS and GNATBench IDE's have a codefix facility that allows for + -- automatic correction of a subset of the errors and warnings issued + -- by the compiler. This is done by recognizing the text of specific + -- messages using appropriate matching patterns. + + -- The text of such messages should not be altered without coordinating + -- with the codefix code. All such messages are marked by a specific + -- style of comments, as shown by the following example: + + -- Error_Msg_N -- CODEFIX + -- (parameters ....) + + -- Any message marked with this -- CODEFIX comment should not be modified + -- without appropriate coordination. If new messages are added which may + -- be susceptible to automatic codefix action, they are marked using: + + ------------------------------ + -- Error Output Subprograms -- + ------------------------------ + + procedure Initialize; + -- Initializes for output of error messages. Must be called for each + -- source file before using any of the other routines in the package. + + procedure Finalize (Last_Call : Boolean); + -- Finalize processing of error message list. Includes processing for + -- duplicated error messages, and other similar final adjustment of the + -- list of error messages. Note that this procedure must be called before + -- calling Compilation_Errors to determine if there were any errors. It + -- is perfectly fine to call Finalize more than once, providing that the + -- parameter Last_Call is set False for every call except the last call. + + -- This multiple call capability is used to do some processing that may + -- generate messages. Call Finalize to eliminate duplicates and remove + -- deleted warnings. Test for compilation errors using Compilation_Errors, + -- then generate some more errors/warnings, call Finalize again to make + -- sure that all duplicates in these new messages are dealt with, then + -- finally call Output_Messages to output the final list of messages. The + -- argument Last_Call must be set False on all calls except the last call, + -- and must be set True on the last call (a value of True activates some + -- processing that must only be done after all messages are posted). + + procedure Output_Messages; + -- Output list of messages, including messages giving number of detected + -- errors and warnings. + + procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr); + -- Output a message at specified location. Can be called from the parser + -- or the semantic analyzer. + + procedure Error_Msg_S (Msg : String); + -- Output a message at current scan pointer location. This routine can be + -- called only from the parser, since it references Scan_Ptr. + + procedure Error_Msg_AP (Msg : String); + -- Output a message just after the previous token. This routine can be + -- called only from the parser, since it references Prev_Token_Ptr. + + procedure Error_Msg_BC (Msg : String); + -- Output a message just before the current token. Note that the important + -- difference between this and the previous routine is that the BC case + -- posts a flag on the current line, whereas AP can post a flag at the + -- end of the preceding line. This routine can be called only from the + -- parser, since it references Token_Ptr. + + procedure Error_Msg_SC (Msg : String); + -- Output a message at the start of the current token, unless we are at + -- the end of file, in which case we always output the message after the + -- last real token in the file. This routine can be called only from the + -- parser, since it references Token_Ptr. + + procedure Error_Msg_SP (Msg : String); + -- Output a message at the start of the previous token. This routine can + -- be called only from the parser, since it references Prev_Token_Ptr. + + procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id); + -- Output a message at the Sloc of the given node. This routine can be + -- called from the parser or the semantic analyzer, although the call from + -- the latter is much more common (and is the most usual way of generating + -- error messages from the analyzer). The message text may contain a + -- single & insertion, which will reference the given node. The message is + -- suppressed if the node N already has a message posted, or if it is a + -- warning and warnings and N is an entity node for which warnings are + -- suppressed. + + procedure Error_Msg_F (Msg : String; N : Node_Id); + -- Similar to Error_Msg_N except that the message is placed on the first + -- node of the construct N (First_Node (N)). + + procedure Error_Msg_NE + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id); + -- Output a message at the Sloc of the given node N, with an insertion of + -- the name from the given entity node E. This is used by the semantic + -- routines, where this is a common error message situation. The Msg text + -- will contain a & or } as usual to mark the insertion point. This + -- routine can be called from the parser or the analyzer. + + procedure Error_Msg_FE + (Msg : String; + N : Node_Id; + E : Node_Or_Entity_Id); + -- Same as Error_Msg_NE, except that the message is placed on the first + -- node of the construct N (First_Node (N)). + + procedure Error_Msg_NEL + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id; + Flag_Location : Source_Ptr); + -- Exactly the same as Error_Msg_NE, except that the flag is placed at + -- the specified Flag_Location instead of at Sloc (N). + + procedure Error_Msg_NW + (Eflag : Boolean; + Msg : String; + N : Node_Or_Entity_Id); + -- This routine is used for posting a message conditionally. The message + -- is posted (with the same effect as Error_Msg_N (Msg, N) if and only + -- if Eflag is True and if the node N is within the main extended source + -- unit and comes from source. Typically this is a warning mode flag. + -- This routine can only be called during semantic analysis. It may not + -- be called during parsing. + + procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : String); + -- The error message text of the message identified by Id is replaced by + -- the given text. This text may contain insertion characters in the + -- usual manner, and need not be the same length as the original text. + + function First_Node (C : Node_Id) return Node_Id; + -- Given a construct C, finds the first node in the construct, i.e. the + -- one with the lowest Sloc value. This is useful in placing error msgs. + + function First_Sloc (N : Node_Id) return Source_Ptr; + -- Given the node for an expression, return a source pointer value that + -- points to the start of the first token in the expression. In the case + -- where the expression is parenthesized, an attempt is made to include + -- the parentheses (i.e. to return the location of the initial paren). + + procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) + renames Erroutc.Purge_Messages; + -- All error messages whose location is in the range From .. To (not + -- including the end points) will be deleted from the error listing. + + procedure Remove_Warning_Messages (N : Node_Id); + -- Remove any warning messages corresponding to the Sloc of N or any + -- of its descendent nodes. No effect if no such warnings. Note that + -- style messages (identified by the fact that they start with "(style)" + -- are not removed by this call. Basically the idea behind this procedure + -- is to remove warnings about execution conditions from known dead code. + + procedure Remove_Warning_Messages (L : List_Id); + -- Remove warnings on all elements of a list (Calls Remove_Warning_Messages + -- on each element of the list, see above). + + procedure Set_Ignore_Errors (To : Boolean); + -- Following a call to this procedure with To=True, all error calls are + -- ignored. A call with To=False restores the default treatment in which + -- error calls are treated as usual (and as described in this spec). + + procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) + renames Erroutc.Set_Warnings_Mode_Off; + -- Called in response to a pragma Warnings (Off) to record the source + -- location from which warnings are to be turned off. + + procedure Set_Warnings_Mode_On (Loc : Source_Ptr) + renames Erroutc.Set_Warnings_Mode_On; + -- Called in response to a pragma Warnings (On) to record the source + -- location from which warnings are to be turned back on. + + procedure Set_Specific_Warning_Off + (Loc : Source_Ptr; + Msg : String; + Config : Boolean) + renames Erroutc.Set_Specific_Warning_Off; + -- This is called in response to the two argument form of pragma Warnings + -- where the first argument is OFF, and the second argument is the prefix + -- of a specific warning to be suppressed. The first argument is the start + -- of the suppression range, and the second argument is the string from + -- the pragma. + + procedure Set_Specific_Warning_On + (Loc : Source_Ptr; + Msg : String; + Err : out Boolean) + renames Erroutc.Set_Specific_Warning_On; + -- This is called in response to the two argument form of pragma Warnings + -- where the first argument is ON, and the second argument is the prefix + -- of a specific warning to be suppressed. The first argument is the end + -- of the suppression range, and the second argument is the string from + -- the pragma. Err is set to True on return to report the error of no + -- matching Warnings Off pragma preceding this one. + + function Compilation_Errors return Boolean; + -- Returns true if errors have been detected, or warnings in -gnatwe + -- (treat warnings as errors) mode. Note that it is mandatory to call + -- Finalize before calling this routine. + + procedure Error_Msg_CRT (Feature : String; N : Node_Id); + -- Posts a non-fatal message on node N saying that the feature identified + -- by the Feature argument is not supported in either configurable + -- run-time mode or no run-time mode (as appropriate). In the former case, + -- the name of the library is output if available. + + procedure dmsg (Id : Error_Msg_Id) renames Erroutc.dmsg; + -- Debugging routine to dump an error message + + ------------------------------------ + -- Utility Interface for Back End -- + ------------------------------------ + + -- The following subprograms can be used by the back end for the purposes + -- of concocting error messages that are not output via Errout, e.g. the + -- messages generated by the gcc back end. + + procedure Set_Identifier_Casing + (Identifier_Name : System.Address; + File_Name : System.Address); + -- The identifier is a null terminated string that represents the name of + -- an identifier appearing in the source program. File_Name is a null + -- terminated string giving the corresponding file name for the identifier + -- as obtained from the front end by the use of Full_Debug_Name to the + -- source file referenced by the corresponding source location value. On + -- return, the name is in Name_Buffer, null terminated with Name_Len set. + -- This name is the identifier name as passed, cased according to the + -- default identifier casing for the given file. + +end Errout; diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb new file mode 100644 index 000000000..e023f3174 --- /dev/null +++ b/gcc/ada/erroutc.adb @@ -0,0 +1,1380 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E R R O U T C -- +-- -- +-- 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. -- +-- -- +-- You should have received a copy of the GNU General Public License along -- +-- with this program; see file COPYING3. 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! Error messages can be generated during Gigi processing by direct +-- calls to error message routines, so it is essential that the processing +-- in this body be consistent with the requirements for the Gigi processing +-- environment, and that in particular, no disallowed table expansion is +-- allowed to occur. + +with Casing; use Casing; +with Debug; use Debug; +with Err_Vars; use Err_Vars; +with Namet; use Namet; +with Opt; use Opt; +with Output; use Output; +with Sinput; use Sinput; +with Snames; use Snames; +with Targparm; use Targparm; +with Uintp; use Uintp; + +package body Erroutc is + + --------------- + -- Add_Class -- + --------------- + + procedure Add_Class is + begin + if Class_Flag then + Class_Flag := False; + Set_Msg_Char ('''); + Get_Name_String (Name_Class); + Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case); + Set_Msg_Name_Buffer; + end if; + end Add_Class; + + ---------------------- + -- Buffer_Ends_With -- + ---------------------- + + function Buffer_Ends_With (S : String) return Boolean is + Len : constant Natural := S'Length; + begin + return + Msglen > Len + and then Msg_Buffer (Msglen - Len) = ' ' + and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S; + end Buffer_Ends_With; + + ------------------- + -- Buffer_Remove -- + ------------------- + + procedure Buffer_Remove (S : String) is + begin + if Buffer_Ends_With (S) then + Msglen := Msglen - S'Length; + end if; + end Buffer_Remove; + + ----------------------------- + -- Check_Duplicate_Message -- + ----------------------------- + + procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is + L1, L2 : Error_Msg_Id; + N1, N2 : Error_Msg_Id; + + procedure Delete_Msg (Delete, Keep : Error_Msg_Id); + -- Called to delete message Delete, keeping message Keep. Marks + -- all messages of Delete with deleted flag set to True, and also + -- makes sure that for the error messages that are retained the + -- preferred message is the one retained (we prefer the shorter + -- one in the case where one has an Instance tag). Note that we + -- always know that Keep has at least as many continuations as + -- Delete (since we always delete the shorter sequence). + + ---------------- + -- Delete_Msg -- + ---------------- + + procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is + D, K : Error_Msg_Id; + + begin + D := Delete; + K := Keep; + + loop + Errors.Table (D).Deleted := True; + + -- Adjust error message count + + if Errors.Table (D).Warn or else Errors.Table (D).Style then + Warnings_Detected := Warnings_Detected - 1; + + else + Total_Errors_Detected := Total_Errors_Detected - 1; + + if Errors.Table (D).Serious then + Serious_Errors_Detected := Serious_Errors_Detected - 1; + end if; + end if; + + -- Substitute shorter of the two error messages + + if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then + Errors.Table (K).Text := Errors.Table (D).Text; + end if; + + D := Errors.Table (D).Next; + K := Errors.Table (K).Next; + + if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then + return; + end if; + end loop; + end Delete_Msg; + + -- Start of processing for Check_Duplicate_Message + + begin + -- Both messages must be non-continuation messages and not deleted + + if Errors.Table (M1).Msg_Cont + or else Errors.Table (M2).Msg_Cont + or else Errors.Table (M1).Deleted + or else Errors.Table (M2).Deleted + then + return; + end if; + + -- Definitely not equal if message text does not match + + if not Same_Error (M1, M2) then + return; + end if; + + -- Same text. See if all continuations are also identical + + L1 := M1; + L2 := M2; + + loop + N1 := Errors.Table (L1).Next; + N2 := Errors.Table (L2).Next; + + -- If M1 continuations have run out, we delete M1, either the + -- messages have the same number of continuations, or M2 has + -- more and we prefer the one with more anyway. + + if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then + Delete_Msg (M1, M2); + return; + + -- If M2 continuations have run out, we delete M2 + + elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then + Delete_Msg (M2, M1); + return; + + -- Otherwise see if continuations are the same, if not, keep both + -- sequences, a curious case, but better to keep everything! + + elsif not Same_Error (N1, N2) then + return; + + -- If continuations are the same, continue scan + + else + L1 := N1; + L2 := N2; + end if; + end loop; + end Check_Duplicate_Message; + + ------------------------ + -- Compilation_Errors -- + ------------------------ + + function Compilation_Errors return Boolean is + begin + return Total_Errors_Detected /= 0 + or else (Warnings_Detected /= 0 + and then Warning_Mode = Treat_As_Error); + end Compilation_Errors; + + ------------------ + -- Debug_Output -- + ------------------ + + procedure Debug_Output (N : Node_Id) is + begin + if Debug_Flag_1 then + Write_Str ("*** following error message posted on node id = #"); + Write_Int (Int (N)); + Write_Str (" ***"); + Write_Eol; + end if; + end Debug_Output; + + ---------- + -- dmsg -- + ---------- + + procedure dmsg (Id : Error_Msg_Id) is + E : Error_Msg_Object renames Errors.Table (Id); + + begin + w ("Dumping error message, Id = ", Int (Id)); + w (" Text = ", E.Text.all); + w (" Next = ", Int (E.Next)); + w (" Sfile = ", Int (E.Sfile)); + + Write_Str + (" Sptr = "); + Write_Location (E.Sptr); + Write_Eol; + + Write_Str + (" Optr = "); + Write_Location (E.Optr); + Write_Eol; + + w (" Line = ", Int (E.Line)); + w (" Col = ", Int (E.Col)); + w (" Warn = ", E.Warn); + w (" Style = ", E.Style); + w (" Serious = ", E.Serious); + w (" Uncond = ", E.Uncond); + w (" Msg_Cont = ", E.Msg_Cont); + w (" Deleted = ", E.Deleted); + + Write_Eol; + end dmsg; + + ------------------ + -- Get_Location -- + ------------------ + + function Get_Location (E : Error_Msg_Id) return Source_Ptr is + begin + return Errors.Table (E).Sptr; + end Get_Location; + + ---------------- + -- Get_Msg_Id -- + ---------------- + + function Get_Msg_Id return Error_Msg_Id is + begin + return Cur_Msg; + end Get_Msg_Id; + + ----------------------- + -- Output_Error_Msgs -- + ----------------------- + + procedure Output_Error_Msgs (E : in out Error_Msg_Id) is + P : Source_Ptr; + T : Error_Msg_Id; + S : Error_Msg_Id; + + Flag_Num : Pos; + Mult_Flags : Boolean := False; + + begin + S := E; + + -- Skip deleted messages at start + + if Errors.Table (S).Deleted then + Set_Next_Non_Deleted_Msg (S); + end if; + + -- Figure out if we will place more than one error flag on this line + + T := S; + while T /= No_Error_Msg + and then Errors.Table (T).Line = Errors.Table (E).Line + and then Errors.Table (T).Sfile = Errors.Table (E).Sfile + loop + if Errors.Table (T).Sptr > Errors.Table (E).Sptr then + Mult_Flags := True; + end if; + + Set_Next_Non_Deleted_Msg (T); + end loop; + + -- Output the error flags. The circuit here makes sure that the tab + -- characters in the original line are properly accounted for. The + -- eight blanks at the start are to match the line number. + + if not Debug_Flag_2 then + Write_Str (" "); + P := Line_Start (Errors.Table (E).Sptr); + Flag_Num := 1; + + -- Loop through error messages for this line to place flags + + T := S; + while T /= No_Error_Msg + and then Errors.Table (T).Line = Errors.Table (E).Line + and then Errors.Table (T).Sfile = Errors.Table (E).Sfile + loop + -- Loop to output blanks till current flag position + + while P < Errors.Table (T).Sptr loop + if Source_Text (Errors.Table (T).Sfile) (P) = ASCII.HT then + Write_Char (ASCII.HT); + else + Write_Char (' '); + end if; + + P := P + 1; + end loop; + + -- Output flag (unless already output, this happens if more + -- than one error message occurs at the same flag position). + + if P = Errors.Table (T).Sptr then + if (Flag_Num = 1 and then not Mult_Flags) + or else Flag_Num > 9 + then + Write_Char ('|'); + else + Write_Char (Character'Val (Character'Pos ('0') + Flag_Num)); + end if; + + P := P + 1; + end if; + + Set_Next_Non_Deleted_Msg (T); + Flag_Num := Flag_Num + 1; + end loop; + + Write_Eol; + end if; + + -- Now output the error messages + + T := S; + while T /= No_Error_Msg + and then Errors.Table (T).Line = Errors.Table (E).Line + and then Errors.Table (T).Sfile = Errors.Table (E).Sfile + loop + Write_Str (" >>> "); + Output_Msg_Text (T); + + if Debug_Flag_2 then + while Column < 74 loop + Write_Char (' '); + end loop; + + Write_Str (" <<<"); + end if; + + Write_Eol; + Set_Next_Non_Deleted_Msg (T); + end loop; + + E := T; + end Output_Error_Msgs; + + ------------------------ + -- Output_Line_Number -- + ------------------------ + + procedure Output_Line_Number (L : Logical_Line_Number) is + D : Int; -- next digit + C : Character; -- next character + Z : Boolean; -- flag for zero suppress + N, M : Int; -- temporaries + + begin + if L = No_Line_Number then + Write_Str (" "); + + else + Z := False; + N := Int (L); + + M := 100_000; + while M /= 0 loop + D := Int (N / M); + N := N rem M; + M := M / 10; + + if D = 0 then + if Z then + C := '0'; + else + C := ' '; + end if; + else + Z := True; + C := Character'Val (D + 48); + end if; + + Write_Char (C); + end loop; + + Write_Str (". "); + end if; + end Output_Line_Number; + + --------------------- + -- Output_Msg_Text -- + --------------------- + + procedure Output_Msg_Text (E : Error_Msg_Id) is + Offs : constant Nat := Column - 1; + -- Offset to start of message, used for continuations + + Max : Integer; + -- Maximum characters to output on next line + + Length : Nat; + -- Maximum total length of lines + + Txt : constant String_Ptr := Errors.Table (E).Text; + Len : constant Natural := Txt'Length; + Ptr : Natural; + Split : Natural; + Start : Natural; + + begin + if Error_Msg_Line_Length = 0 then + Length := Nat'Last; + else + Length := Error_Msg_Line_Length; + end if; + + Max := Integer (Length - Column + 1); + + -- For warning message, add "warning: " unless msg starts with "info: " + + if Errors.Table (E).Warn then + if Len < 6 or else Txt (Txt'First .. Txt'First + 5) /= "info: " then + Write_Str ("warning: "); + Max := Max - 9; + end if; + + -- No prefix needed for style message, since "(style)" is there already + + elsif Errors.Table (E).Style then + null; + + -- All other cases, add "error: " + + elsif Opt.Unique_Error_Tag then + Write_Str ("error: "); + Max := Max - 7; + end if; + + -- Here we have to split the message up into multiple lines + + Ptr := 1; + loop + -- Make sure we do not have ludicrously small line + + Max := Integer'Max (Max, 20); + + -- If remaining text fits, output it respecting LF and we are done + + if Len - Ptr < Max then + for J in Ptr .. Len loop + if Txt (J) = ASCII.LF then + Write_Eol; + Write_Spaces (Offs); + else + Write_Char (Txt (J)); + end if; + end loop; + + return; + + -- Line does not fit + + else + Start := Ptr; + + -- First scan forward looking for a hard end of line + + for Scan in Ptr .. Ptr + Max - 1 loop + if Txt (Scan) = ASCII.LF then + Split := Scan - 1; + Ptr := Scan + 1; + goto Continue; + end if; + end loop; + + -- Otherwise scan backwards looking for a space + + for Scan in reverse Ptr .. Ptr + Max - 1 loop + if Txt (Scan) = ' ' then + Split := Scan - 1; + Ptr := Scan + 1; + goto Continue; + end if; + end loop; + + -- If we fall through, no space, so split line arbitrarily + + Split := Ptr + Max - 1; + Ptr := Split + 1; + end if; + + <> + if Start <= Split then + Write_Line (Txt (Start .. Split)); + Write_Spaces (Offs); + end if; + + Max := Integer (Length - Column + 1); + end loop; + end Output_Msg_Text; + + -------------------- + -- Purge_Messages -- + -------------------- + + procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is + E : Error_Msg_Id; + + function To_Be_Purged (E : Error_Msg_Id) return Boolean; + -- Returns True for a message that is to be purged. Also adjusts + -- error counts appropriately. + + ------------------ + -- To_Be_Purged -- + ------------------ + + function To_Be_Purged (E : Error_Msg_Id) return Boolean is + begin + if E /= No_Error_Msg + and then Errors.Table (E).Sptr > From + and then Errors.Table (E).Sptr < To + then + if Errors.Table (E).Warn or else Errors.Table (E).Style then + Warnings_Detected := Warnings_Detected - 1; + + else + Total_Errors_Detected := Total_Errors_Detected - 1; + + if Errors.Table (E).Serious then + Serious_Errors_Detected := Serious_Errors_Detected - 1; + end if; + end if; + + return True; + + else + return False; + end if; + end To_Be_Purged; + + -- Start of processing for Purge_Messages + + begin + while To_Be_Purged (First_Error_Msg) loop + First_Error_Msg := Errors.Table (First_Error_Msg).Next; + end loop; + + E := First_Error_Msg; + while E /= No_Error_Msg loop + while To_Be_Purged (Errors.Table (E).Next) loop + Errors.Table (E).Next := + Errors.Table (Errors.Table (E).Next).Next; + end loop; + + E := Errors.Table (E).Next; + end loop; + end Purge_Messages; + + ---------------- + -- Same_Error -- + ---------------- + + function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is + Msg1 : constant String_Ptr := Errors.Table (M1).Text; + Msg2 : constant String_Ptr := Errors.Table (M2).Text; + + Msg2_Len : constant Integer := Msg2'Length; + Msg1_Len : constant Integer := Msg1'Length; + + begin + return + Msg1.all = Msg2.all + or else + (Msg1_Len - 10 > Msg2_Len + and then + Msg2.all = Msg1.all (1 .. Msg2_Len) + and then + Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance") + or else + (Msg2_Len - 10 > Msg1_Len + and then + Msg1.all = Msg2.all (1 .. Msg1_Len) + and then + Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance"); + end Same_Error; + + ------------------- + -- Set_Msg_Blank -- + ------------------- + + procedure Set_Msg_Blank is + begin + if Msglen > 0 + and then Msg_Buffer (Msglen) /= ' ' + and then Msg_Buffer (Msglen) /= '(' + and then Msg_Buffer (Msglen) /= '-' + and then not Manual_Quote_Mode + then + Set_Msg_Char (' '); + end if; + end Set_Msg_Blank; + + ------------------------------- + -- Set_Msg_Blank_Conditional -- + ------------------------------- + + procedure Set_Msg_Blank_Conditional is + begin + if Msglen > 0 + and then Msg_Buffer (Msglen) /= ' ' + and then Msg_Buffer (Msglen) /= '(' + and then Msg_Buffer (Msglen) /= '"' + and then not Manual_Quote_Mode + then + Set_Msg_Char (' '); + end if; + end Set_Msg_Blank_Conditional; + + ------------------ + -- Set_Msg_Char -- + ------------------ + + procedure Set_Msg_Char (C : Character) is + begin + + -- The check for message buffer overflow is needed to deal with cases + -- where insertions get too long (in particular a child unit name can + -- be very long). + + if Msglen < Max_Msg_Length then + Msglen := Msglen + 1; + Msg_Buffer (Msglen) := C; + end if; + end Set_Msg_Char; + + --------------------------------- + -- Set_Msg_Insertion_File_Name -- + --------------------------------- + + procedure Set_Msg_Insertion_File_Name is + begin + if Error_Msg_File_1 = No_File then + null; + + elsif Error_Msg_File_1 = Error_File_Name then + Set_Msg_Blank; + Set_Msg_Str (""); + + else + Set_Msg_Blank; + Get_Name_String (Error_Msg_File_1); + Set_Msg_Quote; + Set_Msg_Name_Buffer; + Set_Msg_Quote; + end if; + + -- The following assignments ensure that the second and third { + -- insertion characters will correspond to the Error_Msg_File_2 and + -- Error_Msg_File_3 values and We suppress possible validity checks in + -- case operating in -gnatVa mode, and Error_Msg_File_2 or + -- Error_Msg_File_3 is not needed and has not been set. + + declare + pragma Suppress (Range_Check); + begin + Error_Msg_File_1 := Error_Msg_File_2; + Error_Msg_File_2 := Error_Msg_File_3; + end; + end Set_Msg_Insertion_File_Name; + + ----------------------------------- + -- Set_Msg_Insertion_Line_Number -- + ----------------------------------- + + procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is + Sindex_Loc : Source_File_Index; + Sindex_Flag : Source_File_Index; + + procedure Set_At; + -- Outputs "at " unless last characters in buffer are " from ". Certain + -- messages read better with from than at. + + ------------ + -- Set_At -- + ------------ + + procedure Set_At is + begin + if Msglen < 6 + or else Msg_Buffer (Msglen - 5 .. Msglen) /= " from " + then + Set_Msg_Str ("at "); + end if; + end Set_At; + + -- Start of processing for Set_Msg_Insertion_Line_Number + + begin + Set_Msg_Blank; + + if Loc = No_Location then + Set_At; + Set_Msg_Str ("unknown location"); + + elsif Loc = System_Location then + Set_Msg_Str ("in package System"); + Set_Msg_Insertion_Run_Time_Name; + + elsif Loc = Standard_Location then + Set_Msg_Str ("in package Standard"); + + elsif Loc = Standard_ASCII_Location then + Set_Msg_Str ("in package Standard.ASCII"); + + else + -- Add "at file-name:" if reference is to other than the source + -- file in which the error message is placed. Note that we check + -- full file names, rather than just the source indexes, to + -- deal with generic instantiations from the current file. + + Sindex_Loc := Get_Source_File_Index (Loc); + Sindex_Flag := Get_Source_File_Index (Flag); + + if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then + Set_At; + Get_Name_String + (Reference_Name (Get_Source_File_Index (Loc))); + Set_Msg_Name_Buffer; + Set_Msg_Char (':'); + + -- If in current file, add text "at line " + + else + Set_At; + Set_Msg_Str ("line "); + end if; + + -- Output line number for reference + + Set_Msg_Int (Int (Get_Logical_Line_Number (Loc))); + + -- Deal with the instantiation case. We may have a reference to, + -- e.g. a type, that is declared within a generic template, and + -- what we are really referring to is the occurrence in an instance. + -- In this case, the line number of the instantiation is also of + -- interest, and we add a notation: + + -- , instance at xxx + + -- where xxx is a line number output using this same routine (and + -- the recursion can go further if the instantiation is itself in + -- a generic template). + + -- The flag location passed to us in this situation is indeed the + -- line number within the template, but as described in Sinput.L + -- (file sinput-l.ads, section "Handling Generic Instantiations") + -- we can retrieve the location of the instantiation itself from + -- this flag location value. + + -- Note: this processing is suppressed if Suppress_Instance_Location + -- is set True. This is used to prevent redundant annotations of the + -- location of the instantiation in the case where we are placing + -- the messages on the instantiation in any case. + + if Instantiation (Sindex_Loc) /= No_Location + and then not Suppress_Instance_Location + then + Set_Msg_Str (", instance "); + Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag); + end if; + end if; + end Set_Msg_Insertion_Line_Number; + + ---------------------------- + -- Set_Msg_Insertion_Name -- + ---------------------------- + + procedure Set_Msg_Insertion_Name is + begin + if Error_Msg_Name_1 = No_Name then + null; + + elsif Error_Msg_Name_1 = Error_Name then + Set_Msg_Blank; + Set_Msg_Str (""); + + else + Set_Msg_Blank_Conditional; + Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1); + + -- Remove %s or %b at end. These come from unit names. If the + -- caller wanted the (unit) or (body), then they would have used + -- the $ insertion character. Certainly no error message should + -- ever have %b or %s explicitly occurring. + + if Name_Len > 2 + and then Name_Buffer (Name_Len - 1) = '%' + and then (Name_Buffer (Name_Len) = 'b' + or else + Name_Buffer (Name_Len) = 's') + then + Name_Len := Name_Len - 2; + end if; + + -- Remove upper case letter at end, again, we should not be getting + -- such names, and what we hope is that the remainder makes sense. + + if Name_Len > 1 + and then Name_Buffer (Name_Len) in 'A' .. 'Z' + then + Name_Len := Name_Len - 1; + end if; + + -- If operator name or character literal name, just print it as is + -- Also print as is if it ends in a right paren (case of x'val(nnn)) + + if Name_Buffer (1) = '"' + or else Name_Buffer (1) = ''' + or else Name_Buffer (Name_Len) = ')' + then + Set_Msg_Name_Buffer; + + -- Else output with surrounding quotes in proper casing mode + + else + Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case); + Set_Msg_Quote; + Set_Msg_Name_Buffer; + Set_Msg_Quote; + end if; + end if; + + -- The following assignments ensure that the second and third percent + -- insertion characters will correspond to the Error_Msg_Name_2 and + -- Error_Msg_Name_3 as required. We suppress possible validity checks in + -- case operating in -gnatVa mode, and Error_Msg_Name_1/2 is not needed + -- and has not been set. + + declare + pragma Suppress (Range_Check); + begin + Error_Msg_Name_1 := Error_Msg_Name_2; + Error_Msg_Name_2 := Error_Msg_Name_3; + end; + end Set_Msg_Insertion_Name; + + ------------------------------------ + -- Set_Msg_Insertion_Name_Literal -- + ------------------------------------ + + procedure Set_Msg_Insertion_Name_Literal is + begin + if Error_Msg_Name_1 = No_Name then + null; + + elsif Error_Msg_Name_1 = Error_Name then + Set_Msg_Blank; + Set_Msg_Str (""); + + else + Set_Msg_Blank; + Get_Name_String (Error_Msg_Name_1); + Set_Msg_Quote; + Set_Msg_Name_Buffer; + Set_Msg_Quote; + end if; + + -- The following assignments ensure that the second and third % or %% + -- insertion characters will correspond to the Error_Msg_Name_2 and + -- Error_Msg_Name_3 values and We suppress possible validity checks in + -- case operating in -gnatVa mode, and Error_Msg_Name_2 or + -- Error_Msg_Name_3 is not needed and has not been set. + + declare + pragma Suppress (Range_Check); + begin + Error_Msg_Name_1 := Error_Msg_Name_2; + Error_Msg_Name_2 := Error_Msg_Name_3; + end; + end Set_Msg_Insertion_Name_Literal; + + ------------------------------------- + -- Set_Msg_Insertion_Reserved_Name -- + ------------------------------------- + + procedure Set_Msg_Insertion_Reserved_Name is + begin + Set_Msg_Blank_Conditional; + Get_Name_String (Error_Msg_Name_1); + Set_Msg_Quote; + Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case); + Set_Msg_Name_Buffer; + Set_Msg_Quote; + end Set_Msg_Insertion_Reserved_Name; + + ------------------------------------- + -- Set_Msg_Insertion_Reserved_Word -- + ------------------------------------- + + procedure Set_Msg_Insertion_Reserved_Word + (Text : String; + J : in out Integer) + is + begin + Set_Msg_Blank_Conditional; + Name_Len := 0; + + while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop + Add_Char_To_Name_Buffer (Text (J)); + J := J + 1; + end loop; + + -- Here is where we make the special exception for RM + + if Name_Len = 2 and then Name_Buffer (1 .. 2) = "RM" then + Set_Msg_Name_Buffer; + + -- Not RM: case appropriately and add surrounding quotes + + else + Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case); + Set_Msg_Quote; + Set_Msg_Name_Buffer; + Set_Msg_Quote; + end if; + end Set_Msg_Insertion_Reserved_Word; + + ------------------------------------- + -- Set_Msg_Insertion_Run_Time_Name -- + ------------------------------------- + + procedure Set_Msg_Insertion_Run_Time_Name is + begin + if Targparm.Run_Time_Name_On_Target /= No_Name then + Set_Msg_Blank_Conditional; + Set_Msg_Char ('('); + Get_Name_String (Targparm.Run_Time_Name_On_Target); + Set_Casing (Mixed_Case); + Set_Msg_Str (Name_Buffer (1 .. Name_Len)); + Set_Msg_Char (')'); + end if; + end Set_Msg_Insertion_Run_Time_Name; + + ---------------------------- + -- Set_Msg_Insertion_Uint -- + ---------------------------- + + procedure Set_Msg_Insertion_Uint is + begin + Set_Msg_Blank; + UI_Image (Error_Msg_Uint_1); + + for J in 1 .. UI_Image_Length loop + Set_Msg_Char (UI_Image_Buffer (J)); + end loop; + + -- The following assignment ensures that a second caret insertion + -- character will correspond to the Error_Msg_Uint_2 parameter. We + -- suppress possible validity checks in case operating in -gnatVa mode, + -- and Error_Msg_Uint_2 is not needed and has not been set. + + declare + pragma Suppress (Range_Check); + begin + Error_Msg_Uint_1 := Error_Msg_Uint_2; + end; + end Set_Msg_Insertion_Uint; + + ----------------- + -- Set_Msg_Int -- + ----------------- + + procedure Set_Msg_Int (Line : Int) is + begin + if Line > 9 then + Set_Msg_Int (Line / 10); + end if; + + Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10))); + end Set_Msg_Int; + + ------------------------- + -- Set_Msg_Name_Buffer -- + ------------------------- + + procedure Set_Msg_Name_Buffer is + begin + for J in 1 .. Name_Len loop + Set_Msg_Char (Name_Buffer (J)); + end loop; + end Set_Msg_Name_Buffer; + + ------------------- + -- Set_Msg_Quote -- + ------------------- + + procedure Set_Msg_Quote is + begin + if not Manual_Quote_Mode then + Set_Msg_Char ('"'); + end if; + end Set_Msg_Quote; + + ----------------- + -- Set_Msg_Str -- + ----------------- + + procedure Set_Msg_Str (Text : String) is + begin + for J in Text'Range loop + Set_Msg_Char (Text (J)); + end loop; + end Set_Msg_Str; + + ------------------------------ + -- Set_Next_Non_Deleted_Msg -- + ------------------------------ + + procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is + begin + if E = No_Error_Msg then + return; + + else + loop + E := Errors.Table (E).Next; + exit when E = No_Error_Msg or else not Errors.Table (E).Deleted; + end loop; + end if; + end Set_Next_Non_Deleted_Msg; + + ------------------------------ + -- Set_Specific_Warning_Off -- + ------------------------------ + + procedure Set_Specific_Warning_Off + (Loc : Source_Ptr; + Msg : String; + Config : Boolean) + is + begin + Specific_Warnings.Append + ((Start => Loc, + Msg => new String'(Msg), + Stop => Source_Last (Current_Source_File), + Open => True, + Used => False, + Config => Config)); + end Set_Specific_Warning_Off; + + ----------------------------- + -- Set_Specific_Warning_On -- + ----------------------------- + + procedure Set_Specific_Warning_On + (Loc : Source_Ptr; + Msg : String; + Err : out Boolean) + is + begin + for J in 1 .. Specific_Warnings.Last loop + declare + SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J); + begin + if Msg = SWE.Msg.all + and then Loc > SWE.Start + and then SWE.Open + and then Get_Source_File_Index (SWE.Start) = + Get_Source_File_Index (Loc) + then + SWE.Stop := Loc; + SWE.Open := False; + Err := False; + + -- If a config pragma is specifically cancelled, consider + -- that it is no longer active as a configuration pragma. + + SWE.Config := False; + return; + end if; + end; + end loop; + + Err := True; + end Set_Specific_Warning_On; + + --------------------------- + -- Set_Warnings_Mode_Off -- + --------------------------- + + procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is + begin + -- Don't bother with entries from instantiation copies, since we + -- will already have a copy in the template, which is what matters + + if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then + return; + end if; + + -- If last entry in table already covers us, this is a redundant + -- pragma Warnings (Off) and can be ignored. This also handles the + -- case where all warnings are suppressed by command line switch. + + if Warnings.Last >= Warnings.First + and then Warnings.Table (Warnings.Last).Start <= Loc + and then Loc <= Warnings.Table (Warnings.Last).Stop + then + return; + + -- Otherwise establish a new entry, extending from the location of + -- the pragma to the end of the current source file. This ending + -- point will be adjusted by a subsequent pragma Warnings (On). + + else + Warnings.Increment_Last; + Warnings.Table (Warnings.Last).Start := Loc; + Warnings.Table (Warnings.Last).Stop := + Source_Last (Current_Source_File); + end if; + end Set_Warnings_Mode_Off; + + -------------------------- + -- Set_Warnings_Mode_On -- + -------------------------- + + procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is + begin + -- Don't bother with entries from instantiation copies, since we + -- will already have a copy in the template, which is what matters + + if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then + return; + end if; + + -- Nothing to do unless command line switch to suppress all warnings + -- is off, and the last entry in the warnings table covers this + -- pragma Warnings (On), in which case adjust the end point. + + if (Warnings.Last >= Warnings.First + and then Warnings.Table (Warnings.Last).Start <= Loc + and then Loc <= Warnings.Table (Warnings.Last).Stop) + and then Warning_Mode /= Suppress + then + Warnings.Table (Warnings.Last).Stop := Loc; + end if; + end Set_Warnings_Mode_On; + + ------------------------------------ + -- Test_Style_Warning_Serious_Msg -- + ------------------------------------ + + procedure Test_Style_Warning_Serious_Msg (Msg : String) is + begin + if Msg (Msg'First) = '\' then + return; + end if; + + Is_Serious_Error := True; + Is_Warning_Msg := False; + + Is_Style_Msg := + (Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)"); + + if Is_Style_Msg then + Is_Serious_Error := False; + end if; + + for J in Msg'Range loop + if Msg (J) = '?' + and then (J = Msg'First or else Msg (J - 1) /= ''') + then + Is_Warning_Msg := True; + + elsif Msg (J) = '<' + and then (J = Msg'First or else Msg (J - 1) /= ''') + then + Is_Warning_Msg := Error_Msg_Warn; + + elsif Msg (J) = '|' + and then (J = Msg'First or else Msg (J - 1) /= ''') + then + Is_Serious_Error := False; + end if; + end loop; + + if Is_Warning_Msg or Is_Style_Msg then + Is_Serious_Error := False; + end if; + end Test_Style_Warning_Serious_Msg; + + -------------------------------- + -- Validate_Specific_Warnings -- + -------------------------------- + + procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc) is + begin + for J in Specific_Warnings.First .. Specific_Warnings.Last loop + declare + SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J); + begin + if not SWE.Config then + if SWE.Open then + Eproc.all + ("?pragma Warnings Off with no matching Warnings On", + SWE.Start); + elsif not SWE.Used then + Eproc.all + ("?no warning suppressed by this pragma", SWE.Start); + end if; + end if; + end; + end loop; + end Validate_Specific_Warnings; + + ------------------------------------- + -- Warning_Specifically_Suppressed -- + ------------------------------------- + + function Warning_Specifically_Suppressed + (Loc : Source_Ptr; + Msg : String_Ptr) return Boolean + is + function Matches (S : String; P : String) return Boolean; + -- Returns true if the String S patches the pattern P, which can contain + -- wild card chars (*). The entire pattern must match the entire string. + + ------------- + -- Matches -- + ------------- + + function Matches (S : String; P : String) return Boolean is + Slast : constant Natural := S'Last; + PLast : constant Natural := P'Last; + + SPtr : Natural := S'First; + PPtr : Natural := P'First; + + begin + -- Loop advancing through characters of string and pattern + + SPtr := S'First; + PPtr := P'First; + loop + -- Return True if pattern is a single asterisk + + if PPtr = PLast and then P (PPtr) = '*' then + return True; + + -- Return True if both pattern and string exhausted + + elsif PPtr > PLast and then SPtr > Slast then + return True; + + -- Return False, if one exhausted and not the other + + elsif PPtr > PLast or else SPtr > Slast then + return False; + + -- Case where pattern starts with asterisk + + elsif P (PPtr) = '*' then + + -- Try all possible starting positions in S for match with + -- the remaining characters of the pattern. This is the + -- recursive call that implements the scanner backup. + + for J in SPtr .. Slast loop + if Matches (S (J .. Slast), P (PPtr + 1 .. PLast)) then + return True; + end if; + end loop; + + return False; + + -- Dealt with end of string and *, advance if we have a match + + elsif S (SPtr) = P (PPtr) then + SPtr := SPtr + 1; + PPtr := PPtr + 1; + + -- If first characters do not match, that's decisive + + else + return False; + end if; + end loop; + end Matches; + + -- Start of processing for Warning_Specifically_Suppressed + + begin + -- Loop through specific warning suppression entries + + for J in Specific_Warnings.First .. Specific_Warnings.Last loop + declare + SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J); + + begin + -- Pragma applies if it is a configuration pragma, or if the + -- location is in range of a specific non-configuration pragma. + + if SWE.Config + or else (SWE.Start <= Loc and then Loc <= SWE.Stop) + then + if Matches (Msg.all, SWE.Msg.all) then + SWE.Used := True; + return True; + end if; + end if; + end; + end loop; + + return False; + end Warning_Specifically_Suppressed; + + ------------------------- + -- Warnings_Suppressed -- + ------------------------- + + function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is + begin + if Warning_Mode = Suppress then + return True; + end if; + + -- Loop through table of ON/OFF warnings + + for J in Warnings.First .. Warnings.Last loop + if Warnings.Table (J).Start <= Loc + and then Loc <= Warnings.Table (J).Stop + then + return True; + end if; + end loop; + + return False; + end Warnings_Suppressed; + +end Erroutc; diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads new file mode 100644 index 000000000..d7628ed01 --- /dev/null +++ b/gcc/ada/erroutc.ads @@ -0,0 +1,505 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E R R O U T C -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This packages contains global variables and routines common to error +-- reporting packages, including Errout and Prj.Err. + +with Table; +with Types; use Types; + +package Erroutc is + + Class_Flag : Boolean := False; + -- This flag is set True when outputting a reference to a class-wide + -- type, and is used by Add_Class to insert 'Class at the proper point + + Continuation : Boolean := False; + -- Indicates if current message is a continuation. Initialized from the + -- Msg_Cont parameter in Error_Msg_Internal and then set True if a \ + -- insertion character is encountered. + + Continuation_New_Line : Boolean := False; + -- Indicates if current message was a continuation line marked with \\ to + -- force a new line. Set True if \\ encountered. + + Flag_Source : Source_File_Index; + -- Source file index for source file where error is being posted + + Is_Warning_Msg : Boolean := False; + -- Set True to indicate if current message is warning message + + Is_Style_Msg : Boolean := False; + -- Set True to indicate if the current message is a style message + -- (i.e. a message whose text starts with the characters "(style)"). + + Is_Serious_Error : Boolean := False; + -- Set by Set_Msg_Text to indicate if current message is serious error + + Is_Unconditional_Msg : Boolean := False; + -- Set by Set_Msg_Text to indicate if current message is unconditional + + Kill_Message : Boolean := False; + -- A flag used to kill weird messages (e.g. those containing uninterpreted + -- implicit type references) if we have already seen at least one message + -- already. The idea is that we hope the weird message is a junk cascaded + -- message that should be suppressed. + + Last_Killed : Boolean := False; + -- Set True if the most recently posted non-continuation message was + -- killed. This is used to determine the processing of any continuation + -- messages that follow. + + List_Pragmas_Index : Int := 0; + -- Index into List_Pragmas table + + List_Pragmas_Mode : Boolean := False; + -- Starts True, gets set False by pragma List (Off), True by List (On) + + Manual_Quote_Mode : Boolean := False; + -- Set True in manual quotation mode + + Max_Msg_Length : constant := 1024 + 2 * Int (Column_Number'Last); + -- Maximum length of error message. The addition of 2 * Column_Number'Last + -- ensures that two insertion tokens of maximum length can be accommodated. + -- The value of 1024 is an arbitrary value that should be more than long + -- enough to accommodate any reasonable message (and for that matter, some + -- pretty unreasonable messages!) + + Msg_Buffer : String (1 .. Max_Msg_Length); + -- Buffer used to prepare error messages + + Msglen : Integer := 0; + -- Number of characters currently stored in the message buffer + + Suppress_Message : Boolean; + -- A flag used to suppress certain obviously redundant messages (i.e. + -- those referring to a node whose type is Any_Type). This suppression + -- is effective only if All_Errors_Mode is off. + + Suppress_Instance_Location : Boolean := False; + -- Normally, if a # location in a message references a location within + -- a generic template, then a note is added giving the location of the + -- instantiation. If this variable is set True, then this note is not + -- output. This is used for internal processing for the case of an + -- illegal instantiation. See Error_Msg routine for further details. + + ---------------------------- + -- Message ID Definitions -- + ---------------------------- + + type Error_Msg_Id is new Int; + -- A type used to represent specific error messages. Used by the clients + -- of this package only in the context of the Get_Error_Id and + -- Change_Error_Text subprograms. + + No_Error_Msg : constant Error_Msg_Id := 0; + -- A constant which is different from any value returned by Get_Error_Id. + -- Typically used by a client to indicate absence of a saved Id value. + + Cur_Msg : Error_Msg_Id := No_Error_Msg; + -- Id of most recently posted error message + + function Get_Msg_Id return Error_Msg_Id; + -- Returns the Id of the message most recently posted using one of the + -- Error_Msg routines. + + function Get_Location (E : Error_Msg_Id) return Source_Ptr; + -- Returns the flag location of the error message with the given id E + + ----------------------------------- + -- Error Message Data Structures -- + ----------------------------------- + + -- The error messages are stored as a linked list of error message objects + -- sorted into ascending order by the source location (Sloc). Each object + -- records the text of the message and its source location. + + -- The following record type and table are used to represent error + -- messages, with one entry in the table being allocated for each message. + + type Error_Msg_Object is record + Text : String_Ptr; + -- Text of error message, fully expanded with all insertions + + Next : Error_Msg_Id; + -- Pointer to next message in error chain. A value of No_Error_Msg + -- indicates the end of the chain. + + Prev : Error_Msg_Id; + -- Pointer to previous message in error chain. Only set during the + -- Finalize procedure. A value of No_Error_Msg indicates the first + -- message in the chain. + + Sfile : Source_File_Index; + -- Source table index of source file. In the case of an error that + -- refers to a template, always references the original template + -- not an instantiation copy. + + Sptr : Source_Ptr; + -- Flag pointer. In the case of an error that refers to a template, + -- always references the original template, not an instantiation copy. + -- This value is the actual place in the source that the error message + -- will be posted. Note that an error placed on an instantiation will + -- have Sptr pointing to the instantiation point. + + Optr : Source_Ptr; + -- Flag location used in the call to post the error. This is normally + -- the same as Sptr, except when an error is posted on a particular + -- instantiation of a generic. In such a case, Sptr will point to + -- the original source location of the instantiation itself, but + -- Optr will point to the template location (more accurately to the + -- template copy in the instantiation copy corresponding to the + -- instantiation referenced by Sptr). + + Line : Physical_Line_Number; + -- Line number for error message + + Col : Column_Number; + -- Column number for error message + + Warn : Boolean; + -- True if warning message (i.e. insertion character ? appeared) + + Style : Boolean; + -- True if style message (starts with "(style)") + + Serious : Boolean; + -- True if serious error message (not a warning and no | character) + + Uncond : Boolean; + -- True if unconditional message (i.e. insertion character ! appeared) + + Msg_Cont : Boolean; + -- This is used for logical messages that are composed of multiple + -- individual messages. For messages that are not part of such a + -- group, or that are the first message in such a group. Msg_Cont + -- is set to False. For subsequent messages in a group, Msg_Cont + -- is set to True. This is used to make sure that such a group of + -- messages is either suppressed or retained as a group (e.g. in + -- the circuit that deletes identical messages). + + Deleted : Boolean; + -- If this flag is set, the message is not printed. This is used + -- in the circuit for deleting duplicate/redundant error messages. + end record; + + package Errors is new Table.Table ( + Table_Component_Type => Error_Msg_Object, + Table_Index_Type => Error_Msg_Id, + Table_Low_Bound => 1, + Table_Initial => 200, + Table_Increment => 200, + Table_Name => "Error"); + + First_Error_Msg : Error_Msg_Id; + -- The list of error messages, i.e. the first entry on the list of error + -- messages. This is not the same as the physically first entry in the + -- error message table, since messages are not always inserted in sequence. + + Last_Error_Msg : Error_Msg_Id; + -- The last entry on the list of error messages. Note that this is not + -- the same as the physically last entry in the error message table, since + -- messages are not always inserted in sequence. + + -------------------------- + -- Warning Mode Control -- + -------------------------- + + -- Pragma Warnings allows warnings to be turned off for a specified + -- region of code, and the following tables are the data structure used + -- to keep track of these regions. + + -- The first table is used for the basic command line control, and for + -- the forms of Warning with a single ON or OFF parameter + + -- It contains pairs of source locations, the first being the start + -- location for a warnings off region, and the second being the end + -- location. When a pragma Warnings (Off) is encountered, a new entry + -- is established extending from the location of the pragma to the + -- end of the current source file. A subsequent pragma Warnings (On) + -- adjusts the end point of this entry appropriately. + + -- If all warnings are suppressed by command switch, then there is a + -- dummy entry (put there by Errout.Initialize) at the start of the + -- table which covers all possible Source_Ptr values. Note that the + -- source pointer values in this table always reference the original + -- template, not an instantiation copy, in the generic case. + + type Warnings_Entry is record + Start : Source_Ptr; + Stop : Source_Ptr; + end record; + + package Warnings is new Table.Table ( + Table_Component_Type => Warnings_Entry, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 100, + Table_Increment => 200, + Table_Name => "Warnings"); + + -- The second table is used for the specific forms of the pragma, where + -- the first argument is ON or OFF, and the second parameter is a string + -- which is the entire message to suppress, or a prefix of it. + + type Specific_Warning_Entry is record + Start : Source_Ptr; + Stop : Source_Ptr; + -- Starting and ending source pointers for the range. These are always + -- from the same source file. + + Msg : String_Ptr; + -- Message from pragma Warnings (Off, string) + + Open : Boolean; + -- Set to True if OFF has been encountered with no matching ON + + Used : Boolean; + -- Set to True if entry has been used to suppress a warning + + Config : Boolean; + -- True if pragma is configuration pragma (in which case no matching + -- Off pragma is required, and it is not required that a specific + -- warning be suppressed). + end record; + + package Specific_Warnings is new Table.Table ( + Table_Component_Type => Specific_Warning_Entry, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 100, + Table_Increment => 200, + Table_Name => "Specific_Warnings"); + + -- Note on handling configuration case versus specific case. A complication + -- arises from this example: + + -- pragma Warnings (Off, "not referenced*"); + -- procedure Mumble (X : Integer) is + -- pragma Warnings (On, "not referenced*"); + -- begin + -- null; + -- end Mumble; + + -- The trouble is that the first pragma is technically a configuration + -- pragma, and yet it is clearly being used in the context of thinking + -- of it as a specific case. To deal with this, what we do is that the + -- On entry can match a configuration pragma from the same file, and if + -- we find such an On entry, we cancel the indication of it being the + -- configuration case. This seems to handle all cases we run into ok. + + ----------------- + -- Subprograms -- + ----------------- + + procedure Add_Class; + -- Add 'Class to buffer for class wide type case (Class_Flag set) + + function Buffer_Ends_With (S : String) return Boolean; + -- Tests if message buffer ends with given string preceded by a space + + procedure Buffer_Remove (S : String); + -- Removes given string from end of buffer if it is present + -- at end of buffer, and preceded by a space. + + function Compilation_Errors return Boolean; + -- Returns true if errors have been detected, or warnings in -gnatwe + -- (treat warnings as errors) mode. + + procedure dmsg (Id : Error_Msg_Id); + -- Debugging routine to dump an error message + + procedure Debug_Output (N : Node_Id); + -- Called from Error_Msg_N and Error_Msg_NE to generate line of debug + -- output giving node number (of node N) if the debug X switch is set. + + procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id); + -- This function is passed the Id values of two error messages. If + -- either M1 or M2 is a continuation message, or is already deleted, + -- the call is ignored. Otherwise a check is made to see if M1 and M2 + -- are duplicated or redundant. If so, the message to be deleted and + -- all its continuations are marked with the Deleted flag set to True. + + procedure Output_Error_Msgs (E : in out Error_Msg_Id); + -- Output source line, error flag, and text of stored error message and + -- all subsequent messages for the same line and unit. On return E is + -- set to be one higher than the last message output. + + procedure Output_Line_Number (L : Logical_Line_Number); + -- Output a line number as six digits (with leading zeroes suppressed), + -- followed by a period and a blank (note that this is 8 characters which + -- means that tabs in the source line will not get messed up). Line numbers + -- that match or are less than the last Source_Reference pragma are listed + -- as all blanks, avoiding output of junk line numbers. + + procedure Output_Msg_Text (E : Error_Msg_Id); + -- Outputs characters of text in the text of the error message E. Note that + -- no end of line is output, the caller is responsible for adding the end + -- of line. If Error_Msg_Line_Length is non-zero, this is the routine that + -- splits the line generating multiple lines of output, and in this case + -- the last line has no terminating end of line character. + + procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr); + -- All error messages whose location is in the range From .. To (not + -- including the end points) will be deleted from the error listing. + + function Same_Error (M1, M2 : Error_Msg_Id) return Boolean; + -- See if two messages have the same text. Returns true if the text + -- of the two messages is identical, or if one of them is the same + -- as the other with an appended "instance at xxx" tag. + + procedure Set_Msg_Blank; + -- Sets a single blank in the message if the preceding character is a + -- non-blank character other than a left parenthesis or minus. Has no + -- effect if manual quote mode is turned on. + + procedure Set_Msg_Blank_Conditional; + -- Sets a single blank in the message if the preceding character is a + -- non-blank character other than a left parenthesis or quote. Has no + -- effect if manual quote mode is turned on. + + procedure Set_Msg_Char (C : Character); + -- Add a single character to the current message. This routine does not + -- check for special insertion characters (they are just treated as text + -- characters if they occur). + + procedure Set_Msg_Insertion_File_Name; + -- Handle file name insertion (left brace insertion character) + + procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr); + -- Handle line number insertion (# insertion character). Loc is the + -- location to be referenced, and Flag is the location at which the + -- flag is posted (used to determine whether to add "in file xxx") + + procedure Set_Msg_Insertion_Name_Literal; + + procedure Set_Msg_Insertion_Name; + -- Handle name insertion (% insertion character) + + procedure Set_Msg_Insertion_Reserved_Name; + -- Handle insertion of reserved word name (* insertion character) + + procedure Set_Msg_Insertion_Reserved_Word + (Text : String; + J : in out Integer); + -- Handle reserved word insertion (upper case letters). The Text argument + -- is the current error message input text, and J is an index which on + -- entry points to the first character of the reserved word, and on exit + -- points past the last character of the reserved word. + + procedure Set_Msg_Insertion_Run_Time_Name; + -- If package System contains a definition for Run_Time_Name (see package + -- Targparm for details), then this procedure will insert a message of + -- the form (name) into the current error message, with name set in mixed + -- case (upper case after any spaces). If no run time name is defined, + -- then this routine has no effect). + + procedure Set_Msg_Insertion_Uint; + -- Handle Uint insertion (^ insertion character) + + procedure Set_Msg_Int (Line : Int); + -- Set the decimal representation of the argument in the error message + -- buffer with no leading zeroes output. + + procedure Set_Msg_Name_Buffer; + -- Output name from Name_Buffer, with surrounding quotes unless manual + -- quotation mode is in effect. + + procedure Set_Msg_Quote; + -- Set quote if in normal quote mode, nothing if in manual quote mode + + procedure Set_Msg_Str (Text : String); + -- Add a sequence of characters to the current message. This routine does + -- not check for special insertion characters (they are just treated as + -- text characters if they occur). + + procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id); + -- Given a message id, move to next message id, but skip any deleted + -- messages, so that this results in E on output being the first non- + -- deleted message following the input value of E, or No_Error_Msg if + -- the input value of E was either already No_Error_Msg, or was the + -- last non-deleted message. + + procedure Set_Specific_Warning_Off + (Loc : Source_Ptr; + Msg : String; + Config : Boolean); + -- This is called in response to the two argument form of pragma Warnings + -- where the first argument is OFF, and the second argument is a string + -- which identifies a specific warning to be suppressed. The first argument + -- is the start of the suppression range, and the second argument is the + -- string from the pragma. Loc is the location of the pragma (which is the + -- start of the range to suppress). Config is True for the configuration + -- pragma case (where there is no requirement for a matching OFF pragma). + + procedure Set_Specific_Warning_On + (Loc : Source_Ptr; + Msg : String; + Err : out Boolean); + -- This is called in response to the two argument form of pragma Warnings + -- where the first argument is ON, and the second argument is a string + -- which identifies a specific warning to be suppressed. The first argument + -- is the end of the suppression range, and the second argument is the + -- string from the pragma. Err is set to True on return to report the error + -- of no matching Warnings Off pragma preceding this one. + + procedure Set_Warnings_Mode_Off (Loc : Source_Ptr); + -- Called in response to a pragma Warnings (Off) to record the source + -- location from which warnings are to be turned off. + + procedure Set_Warnings_Mode_On (Loc : Source_Ptr); + -- Called in response to a pragma Warnings (On) to record the source + -- location from which warnings are to be turned back on. + + procedure Test_Style_Warning_Serious_Msg (Msg : String); + -- Sets Is_Warning_Msg true if Msg is a warning message (contains a + -- question mark character), and False otherwise. Is_Style_Msg is set true + -- if Msg is a style message (starts with "(style)". Sets Is_Serious_Error + -- True unless the message is a warning or style/info message or contains + -- the character | indicating a non-serious error message. Note that the + -- call has no effect for continuation messages (those whose first + -- character is '\'). + + function Warnings_Suppressed (Loc : Source_Ptr) return Boolean; + -- Determines if given location is covered by a warnings off suppression + -- range in the warnings table (or is suppressed by compilation option, + -- which generates a warning range for the whole source file). This routine + -- only deals with the general ON/OFF case, not specific warnings. True + -- is also returned if warnings are globally suppressed. + + function Warning_Specifically_Suppressed + (Loc : Source_Ptr; + Msg : String_Ptr) return Boolean; + -- Determines if given message to be posted at given location is suppressed + -- by specific ON/OFF Warnings pragmas specifying this particular message. + + type Error_Msg_Proc is + access procedure (Msg : String; Flag_Location : Source_Ptr); + procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc); + -- Checks that specific warnings are consistent (for non-configuration + -- case, properly closed, and used). The argument is a pointer to the + -- Error_Msg procedure to be called if any inconsistencies are detected. + +end Erroutc; diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb new file mode 100644 index 000000000..6a5bb692d --- /dev/null +++ b/gcc/ada/errutil.adb @@ -0,0 +1,774 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E R R U T I L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Err_Vars; use Err_Vars; +with Erroutc; use Erroutc; +with Namet; use Namet; +with Opt; use Opt; +with Output; use Output; +with Scans; use Scans; +with Sinput; use Sinput; +with Stylesw; use Stylesw; + +package body Errutil is + + Errors_Must_Be_Ignored : Boolean := False; + -- Set to True by procedure Set_Ignore_Errors (True), when calls to + -- error message procedures should be ignored (when parsing irrelevant + -- text in sources being preprocessed). + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Error_Msg_AP (Msg : String); + -- Output a message just after the previous token + + procedure Output_Source_Line + (L : Physical_Line_Number; + Sfile : Source_File_Index; + Errs : Boolean; + Source_Type : String); + -- Outputs text of source line L, in file S, together with preceding line + -- number, as described above for Output_Line_Number. The Errs parameter + -- indicates if there are errors attached to the line, which forces + -- listing on, even in the presence of pragma List (Off). + + procedure Set_Msg_Insertion_Column; + -- Handle column number insertion (@ insertion character) + + procedure Set_Msg_Text (Text : String; Flag : Source_Ptr); + -- Add a sequence of characters to the current message. The characters may + -- be one of the special insertion characters (see documentation in spec). + -- Flag is the location at which the error is to be posted, which is used + -- to determine whether or not the # insertion needs a file name. The + -- variables Msg_Buffer, Msglen, Is_Style_Msg, Is_Warning_Msg, and + -- Is_Unconditional_Msg are set on return. + + ------------------ + -- Error_Msg_AP -- + ------------------ + + procedure Error_Msg_AP (Msg : String) is + S1 : Source_Ptr; + C : Character; + + begin + -- If we had saved the Scan_Ptr value after scanning the previous + -- token, then we would have exactly the right place for putting + -- the flag immediately at hand. However, that would add at least + -- two instructions to a Scan call *just* to service the possibility + -- of an Error_Msg_AP call. So instead we reconstruct that value. + + -- We have two possibilities, start with Prev_Token_Ptr and skip over + -- the current token, which is made harder by the possibility that this + -- token may be in error, or start with Token_Ptr and work backwards. + -- We used to take the second approach, but it's hard because of + -- comments, and harder still because things that look like comments + -- can appear inside strings. So now we take the first approach. + + -- Note: in the case where there is no previous token, Prev_Token_Ptr + -- is set to Source_First, which is a reasonable position for the + -- error flag in this situation. + + S1 := Prev_Token_Ptr; + C := Source (S1); + + -- If the previous token is a string literal, we need a special approach + -- since there may be white space inside the literal and we don't want + -- to stop on that white space. + + -- Note that it is not worth worrying about special UTF_32 line + -- terminator characters in this context, since this is only about + -- error recovery anyway. + + if Prev_Token = Tok_String_Literal then + loop + S1 := S1 + 1; + + if Source (S1) = C then + S1 := S1 + 1; + exit when Source (S1) /= C; + elsif Source (S1) in Line_Terminator then + exit; + end if; + end loop; + + -- Character literal also needs special handling + + elsif Prev_Token = Tok_Char_Literal then + S1 := S1 + 3; + + -- Otherwise we search forward for the end of the current token, marked + -- by a line terminator, white space, a comment symbol or if we bump + -- into the following token (i.e. the current token) + + -- Note that it is not worth worrying about special UTF_32 line + -- terminator characters in this context, since this is only about + -- error recovery anyway. + + else + while Source (S1) not in Line_Terminator + and then Source (S1) /= ' ' + and then Source (S1) /= ASCII.HT + and then (Source (S1) /= '-' or else Source (S1 + 1) /= '-') + and then S1 /= Token_Ptr + loop + S1 := S1 + 1; + end loop; + end if; + + -- S1 is now set to the location for the flag + + Error_Msg (Msg, S1); + + end Error_Msg_AP; + + --------------- + -- Error_Msg -- + --------------- + + procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is + + Next_Msg : Error_Msg_Id; + -- Pointer to next message at insertion point + + Prev_Msg : Error_Msg_Id; + -- Pointer to previous message at insertion point + + Sptr : Source_Ptr renames Flag_Location; + -- Corresponds to the Sptr value in the error message object + + Optr : Source_Ptr renames Flag_Location; + -- Corresponds to the Optr value in the error message object. Note + -- that for this usage, Sptr and Optr always have the same value, + -- since we do not have to worry about generic instantiations. + + begin + if Errors_Must_Be_Ignored then + return; + end if; + + if Raise_Exception_On_Error /= 0 then + raise Error_Msg_Exception; + end if; + + Test_Style_Warning_Serious_Msg (Msg); + Set_Msg_Text (Msg, Sptr); + + -- Kill continuation if parent message killed + + if Continuation and Last_Killed then + return; + end if; + + -- Return without doing anything if message is killed and this is not + -- the first error message. The philosophy is that if we get a weird + -- error message and we already have had a message, then we hope the + -- weird message is a junk cascaded message + + -- Immediate return if warning message and warnings are suppressed. + -- Note that style messages are not warnings for this purpose. + + if Is_Warning_Msg and then Warnings_Suppressed (Sptr) then + Cur_Msg := No_Error_Msg; + return; + end if; + + -- Otherwise build error message object for new message + + Errors.Increment_Last; + Cur_Msg := Errors.Last; + Errors.Table (Cur_Msg).Text := new String'(Msg_Buffer (1 .. Msglen)); + Errors.Table (Cur_Msg).Next := No_Error_Msg; + Errors.Table (Cur_Msg).Sptr := Sptr; + Errors.Table (Cur_Msg).Optr := Optr; + Errors.Table (Cur_Msg).Sfile := Get_Source_File_Index (Sptr); + Errors.Table (Cur_Msg).Line := Get_Physical_Line_Number (Sptr); + Errors.Table (Cur_Msg).Col := Get_Column_Number (Sptr); + Errors.Table (Cur_Msg).Style := Is_Style_Msg; + Errors.Table (Cur_Msg).Warn := Is_Warning_Msg; + Errors.Table (Cur_Msg).Serious := Is_Serious_Error; + Errors.Table (Cur_Msg).Uncond := Is_Unconditional_Msg; + Errors.Table (Cur_Msg).Msg_Cont := Continuation; + Errors.Table (Cur_Msg).Deleted := False; + + Prev_Msg := No_Error_Msg; + Next_Msg := First_Error_Msg; + + while Next_Msg /= No_Error_Msg loop + exit when + Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile; + + if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile then + exit when Sptr < Errors.Table (Next_Msg).Sptr; + end if; + + Prev_Msg := Next_Msg; + Next_Msg := Errors.Table (Next_Msg).Next; + end loop; + + -- Now we insert the new message in the error chain. The insertion + -- point for the message is after Prev_Msg and before Next_Msg. + + -- The possible insertion point for the new message is after Prev_Msg + -- and before Next_Msg. However, this is where we do a special check + -- for redundant parsing messages, defined as messages posted on the + -- same line. The idea here is that probably such messages are junk + -- from the parser recovering. In full errors mode, we don't do this + -- deletion, but otherwise such messages are discarded at this stage. + + if Prev_Msg /= No_Error_Msg + and then Errors.Table (Prev_Msg).Line = + Errors.Table (Cur_Msg).Line + and then Errors.Table (Prev_Msg).Sfile = + Errors.Table (Cur_Msg).Sfile + then + -- Don't delete unconditional messages and at this stage, don't + -- delete continuation lines (we attempted to delete those earlier + -- if the parent message was deleted. + + if not Errors.Table (Cur_Msg).Uncond + and then not Continuation + then + + -- Don't delete if prev msg is warning and new msg is an error. + -- This is because we don't want a real error masked by a warning. + -- In all other cases (that is parse errors for the same line that + -- are not unconditional) we do delete the message. This helps to + -- avoid junk extra messages from cascaded parsing errors + + if not (Errors.Table (Prev_Msg).Warn + or else + Errors.Table (Prev_Msg).Style) + or else + (Errors.Table (Cur_Msg).Warn + or else + Errors.Table (Cur_Msg).Style) + then + -- All tests passed, delete the message by simply returning + -- without any further processing. + + if not Continuation then + Last_Killed := True; + end if; + + return; + end if; + end if; + end if; + + -- Come here if message is to be inserted in the error chain + + if not Continuation then + Last_Killed := False; + end if; + + if Prev_Msg = No_Error_Msg then + First_Error_Msg := Cur_Msg; + else + Errors.Table (Prev_Msg).Next := Cur_Msg; + end if; + + Errors.Table (Cur_Msg).Next := Next_Msg; + + -- Bump appropriate statistics count + + if Errors.Table (Cur_Msg).Warn + or else + Errors.Table (Cur_Msg).Style + then + Warnings_Detected := Warnings_Detected + 1; + + else + Total_Errors_Detected := Total_Errors_Detected + 1; + + if Errors.Table (Cur_Msg).Serious then + Serious_Errors_Detected := Serious_Errors_Detected + 1; + end if; + end if; + + end Error_Msg; + + ----------------- + -- Error_Msg_S -- + ----------------- + + procedure Error_Msg_S (Msg : String) is + begin + Error_Msg (Msg, Scan_Ptr); + end Error_Msg_S; + + ------------------ + -- Error_Msg_SC -- + ------------------ + + procedure Error_Msg_SC (Msg : String) is + begin + -- If we are at end of file, post the flag after the previous token + + if Token = Tok_EOF then + Error_Msg_AP (Msg); + + -- For all other cases the message is posted at the current token + -- pointer position + + else + Error_Msg (Msg, Token_Ptr); + end if; + end Error_Msg_SC; + + ------------------ + -- Error_Msg_SP -- + ------------------ + + procedure Error_Msg_SP (Msg : String) is + begin + -- Note: in the case where there is no previous token, Prev_Token_Ptr + -- is set to Source_First, which is a reasonable position for the + -- error flag in this situation + + Error_Msg (Msg, Prev_Token_Ptr); + end Error_Msg_SP; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Source_Type : String := "project") is + Cur : Error_Msg_Id; + Nxt : Error_Msg_Id; + E, F : Error_Msg_Id; + Err_Flag : Boolean; + + begin + -- Eliminate any duplicated error messages from the list. This is + -- done after the fact to avoid problems with Change_Error_Text. + + Cur := First_Error_Msg; + while Cur /= No_Error_Msg loop + Nxt := Errors.Table (Cur).Next; + + F := Nxt; + while F /= No_Error_Msg + and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr + loop + Check_Duplicate_Message (Cur, F); + F := Errors.Table (F).Next; + end loop; + + Cur := Nxt; + end loop; + + -- Brief Error mode + + if Brief_Output or (not Full_List and not Verbose_Mode) then + E := First_Error_Msg; + Set_Standard_Error; + + while E /= No_Error_Msg loop + if not Errors.Table (E).Deleted then + if Full_Path_Name_For_Brief_Errors then + Write_Name (Full_Ref_Name (Errors.Table (E).Sfile)); + else + Write_Name (Reference_Name (Errors.Table (E).Sfile)); + end if; + + Write_Char (':'); + Write_Int (Int (Physical_To_Logical + (Errors.Table (E).Line, + Errors.Table (E).Sfile))); + Write_Char (':'); + + if Errors.Table (E).Col < 10 then + Write_Char ('0'); + end if; + + Write_Int (Int (Errors.Table (E).Col)); + Write_Str (": "); + Output_Msg_Text (E); + Write_Eol; + end if; + + E := Errors.Table (E).Next; + end loop; + + Set_Standard_Output; + end if; + + -- Full source listing case + + if Full_List then + List_Pragmas_Index := 1; + List_Pragmas_Mode := True; + E := First_Error_Msg; + Write_Eol; + + -- First list initial main source file with its error messages + + for N in 1 .. Last_Source_Line (Main_Source_File) loop + Err_Flag := + E /= No_Error_Msg + and then Errors.Table (E).Line = N + and then Errors.Table (E).Sfile = Main_Source_File; + + Output_Source_Line (N, Main_Source_File, Err_Flag, Source_Type); + + if Err_Flag then + Output_Error_Msgs (E); + + Write_Eol; + end if; + end loop; + + -- Then output errors, if any, for subsidiary units + + while E /= No_Error_Msg + and then Errors.Table (E).Sfile /= Main_Source_File + loop + Write_Eol; + Output_Source_Line + (Errors.Table (E).Line, + Errors.Table (E).Sfile, + True, + Source_Type); + Output_Error_Msgs (E); + end loop; + end if; + + -- Verbose mode (error lines only with error flags) + + if Verbose_Mode then + E := First_Error_Msg; + + -- Loop through error lines + + while E /= No_Error_Msg loop + Write_Eol; + Output_Source_Line + (Errors.Table (E).Line, + Errors.Table (E).Sfile, + True, + Source_Type); + Output_Error_Msgs (E); + end loop; + end if; + + -- Output error summary if verbose or full list mode + + if Verbose_Mode or else Full_List then + + -- Extra blank line if error messages or source listing were output + + if Total_Errors_Detected + Warnings_Detected > 0 + or else Full_List + then + Write_Eol; + end if; + + -- Message giving number of lines read and number of errors detected. + -- This normally goes to Standard_Output. The exception is when brief + -- mode is not set, verbose mode (or full list mode) is set, and + -- there are errors. In this case we send the message to standard + -- error to make sure that *something* appears on standard error in + -- an error situation. + + -- Formerly, only the "# errors" suffix was sent to stderr, whereas + -- "# lines:" appeared on stdout. This caused problems on VMS when + -- the stdout buffer was flushed, giving an extra line feed after + -- the prefix. + + if Total_Errors_Detected + Warnings_Detected /= 0 + and then not Brief_Output + and then (Verbose_Mode or Full_List) + then + Set_Standard_Error; + end if; + + -- Message giving total number of lines + + Write_Str (" "); + Write_Int (Num_Source_Lines (Main_Source_File)); + + if Num_Source_Lines (Main_Source_File) = 1 then + Write_Str (" line: "); + else + Write_Str (" lines: "); + end if; + + if Total_Errors_Detected = 0 then + Write_Str ("No errors"); + + elsif Total_Errors_Detected = 1 then + Write_Str ("1 error"); + + else + Write_Int (Total_Errors_Detected); + Write_Str (" errors"); + end if; + + if Warnings_Detected /= 0 then + Write_Str (", "); + Write_Int (Warnings_Detected); + Write_Str (" warning"); + + if Warnings_Detected /= 1 then + Write_Char ('s'); + end if; + + if Warning_Mode = Treat_As_Error then + Write_Str (" (treated as error"); + + if Warnings_Detected /= 1 then + Write_Char ('s'); + end if; + + Write_Char (')'); + end if; + end if; + + Write_Eol; + Set_Standard_Output; + end if; + + if Maximum_Messages /= 0 then + if Warnings_Detected >= Maximum_Messages then + Set_Standard_Error; + Write_Line ("maximum number of warnings detected"); + Warning_Mode := Suppress; + end if; + + if Total_Errors_Detected >= Maximum_Messages then + Set_Standard_Error; + Write_Line ("fatal error: maximum errors reached"); + Set_Standard_Output; + end if; + end if; + + if Warning_Mode = Treat_As_Error then + Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected; + Warnings_Detected := 0; + end if; + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Errors.Init; + First_Error_Msg := No_Error_Msg; + Last_Error_Msg := No_Error_Msg; + Serious_Errors_Detected := 0; + Total_Errors_Detected := 0; + Warnings_Detected := 0; + Cur_Msg := No_Error_Msg; + + -- Initialize warnings table, if all warnings are suppressed, supply + -- an initial dummy entry covering all possible source locations. + + Warnings.Init; + + if Warning_Mode = Suppress then + Warnings.Increment_Last; + Warnings.Table (Warnings.Last).Start := Source_Ptr'First; + Warnings.Table (Warnings.Last).Stop := Source_Ptr'Last; + end if; + end Initialize; + + ------------------------ + -- Output_Source_Line -- + ------------------------ + + procedure Output_Source_Line + (L : Physical_Line_Number; + Sfile : Source_File_Index; + Errs : Boolean; + Source_Type : String) + is + S : Source_Ptr; + C : Character; + + Line_Number_Output : Boolean := False; + -- Set True once line number is output + + begin + if Sfile /= Current_Error_Source_File then + Write_Str ("==============Error messages for "); + Write_Str (Source_Type); + Write_Str (" file: "); + Write_Name (Full_File_Name (Sfile)); + Write_Eol; + Current_Error_Source_File := Sfile; + end if; + + if Errs then + Output_Line_Number (Physical_To_Logical (L, Sfile)); + Line_Number_Output := True; + end if; + + S := Line_Start (L, Sfile); + + loop + C := Source_Text (Sfile) (S); + exit when C = ASCII.LF or else C = ASCII.CR or else C = EOF; + + if Errs then + Write_Char (C); + end if; + + S := S + 1; + end loop; + + if Line_Number_Output then + Write_Eol; + end if; + end Output_Source_Line; + + ----------------------- + -- Set_Ignore_Errors -- + ----------------------- + + procedure Set_Ignore_Errors (To : Boolean) is + begin + Errors_Must_Be_Ignored := To; + end Set_Ignore_Errors; + + ------------------------------ + -- Set_Msg_Insertion_Column -- + ------------------------------ + + procedure Set_Msg_Insertion_Column is + begin + if RM_Column_Check then + Set_Msg_Str (" in column "); + Set_Msg_Int (Int (Error_Msg_Col) + 1); + end if; + end Set_Msg_Insertion_Column; + + ------------------ + -- Set_Msg_Text -- + ------------------ + + procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is + C : Character; -- Current character + P : Natural; -- Current index; + + begin + Manual_Quote_Mode := False; + Msglen := 0; + Flag_Source := Get_Source_File_Index (Flag); + P := Text'First; + + while P <= Text'Last loop + C := Text (P); + P := P + 1; + + -- Check for insertion character + + if C = '%' then + if P <= Text'Last and then Text (P) = '%' then + P := P + 1; + Set_Msg_Insertion_Name_Literal; + else + Set_Msg_Insertion_Name; + end if; + + elsif C = '$' then + + -- '$' is ignored + + null; + + elsif C = '{' then + Set_Msg_Insertion_File_Name; + + elsif C = '}' then + + -- '}' is ignored + + null; + + elsif C = '*' then + Set_Msg_Insertion_Reserved_Name; + + elsif C = '&' then + + -- '&' is ignored + + null; + + elsif C = '#' then + Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag); + + elsif C = '\' then + Continuation := True; + + elsif C = '@' then + Set_Msg_Insertion_Column; + + elsif C = '^' then + Set_Msg_Insertion_Uint; + + elsif C = '`' then + Manual_Quote_Mode := not Manual_Quote_Mode; + Set_Msg_Char ('"'); + + elsif C = '!' then + Is_Unconditional_Msg := True; + + elsif C = '?' then + null; + + elsif C = '<' then + null; + + elsif C = '|' then + null; + + elsif C = ''' then + Set_Msg_Char (Text (P)); + P := P + 1; + + -- Upper case letter (start of reserved word if 2 or more) + + elsif C in 'A' .. 'Z' + and then P <= Text'Last + and then Text (P) in 'A' .. 'Z' + then + P := P - 1; + Set_Msg_Insertion_Reserved_Word (Text, P); + + -- Normal character with no special treatment + + else + Set_Msg_Char (C); + end if; + + end loop; + end Set_Msg_Text; + +end Errutil; diff --git a/gcc/ada/errutil.ads b/gcc/ada/errutil.ads new file mode 100644 index 000000000..91ac4f108 --- /dev/null +++ b/gcc/ada/errutil.ads @@ -0,0 +1,155 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E R R U T I L -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 to output error messages and the +-- corresponding instantiation of Styleg, suitable to instantiate Scng. + +-- It is not dependent on the GNAT tree packages (Atree, Sinfo, ...) + +-- It uses the same global variables as Errout, located in package +-- Err_Vars. Like Errout, it also uses the common variables and routines +-- in package Erroutc. + +-- This package is used by the preprocessor (gprep.adb) and the project +-- manager (prj-err.ads). + +with Styleg; +with Types; use Types; + +package Errutil is + + --------------------------------------------------------- + -- Error Message Text and Message Insertion Characters -- + --------------------------------------------------------- + + -- Error message text strings are composed of lower case letters, digits + -- and the special characters space, comma, period, colon and semicolon, + -- apostrophe and parentheses. Special insertion characters can also + -- appear which cause the error message circuit to modify the given + -- string. For a full list of these, see the spec of errout. + + ----------------------------------------------------- + -- Format of Messages and Manual Quotation Control -- + ----------------------------------------------------- + + -- Messages are generally all in lower case, except for inserted names + -- and appear in one of the following two forms: + + -- error: text + -- warning: text + + -- The prefixes error and warning are supplied automatically (depending + -- on the use of the ? insertion character), and the call to the error + -- message routine supplies the text. The "error: " prefix is omitted + -- in brief error message formats. + + -- Reserved keywords in the message are in the default keyword case + -- (determined from the given source program), surrounded by quotation + -- marks. This is achieved by spelling the reserved word in upper case + -- letters, which is recognized as a request for insertion of quotation + -- marks by the error text processor. Thus for example: + + -- Error_Msg_AP ("IS expected"); + + -- would result in the output of one of the following: + + -- error: "is" expected + -- error: "IS" expected + -- error: "Is" expected + + -- the choice between these being made by looking at the casing convention + -- used for keywords (actually the first compilation unit keyword) in the + -- source file. + + -- In the case of names, the default mode for the error text processor + -- is to surround the name by quotation marks automatically. The case + -- used for the identifier names is taken from the source program where + -- possible, and otherwise is the default casing convention taken from + -- the source file usage. + + -- In some cases, better control over the placement of quote marks is + -- required. This is achieved using manual quotation mode. In this mode, + -- one or more insertion sequences is surrounded by backquote characters. + -- The backquote characters are output as double quote marks, and normal + -- automatic insertion of quotes is suppressed between the double quotes. + -- For example: + + -- Error_Msg_AP ("`END &;` expected"); + + -- generates a message like + + -- error: "end Open_Scope;" expected + + -- where the node specifying the name Open_Scope has been stored in + -- Error_Msg_Node_1 prior to the call. The great majority of error + -- messages operates in normal quotation mode. + + -- Note: the normal automatic insertion of spaces before insertion + -- sequences (such as those that come from & and %) is suppressed in + -- manual quotation mode, so blanks, if needed as in the above example, + -- must be explicitly present. + + ------------------------------ + -- Error Output Subprograms -- + ------------------------------ + + procedure Initialize; + -- Initializes for output of error messages. Must be called for each + -- file before using any of the other routines in the package. + + procedure Finalize (Source_Type : String := "project"); + -- Finalize processing of error messages for one file and output message + -- indicating the number of detected errors. + -- Source_Type is used in verbose mode to indicate the type of the source + -- being parsed (project file, definition file or input file for the + -- preprocessor). + + procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr); + -- Output a message at specified location + + procedure Error_Msg_S (Msg : String); + -- Output a message at current scan pointer location + + procedure Error_Msg_SC (Msg : String); + -- Output a message at the start of the current token, unless we are at + -- the end of file, in which case we always output the message after the + -- last real token in the file. + + procedure Error_Msg_SP (Msg : String); + -- Output a message at the start of the previous token + + procedure Set_Ignore_Errors (To : Boolean); + -- Indicate, when To = True, that all reported errors should + -- be ignored. By default reported errors are not ignored. + + package Style is new Styleg + (Error_Msg => Error_Msg, + Error_Msg_S => Error_Msg_S, + Error_Msg_SC => Error_Msg_SC, + Error_Msg_SP => Error_Msg_SP); + -- Instantiation of the generic style package, suitable for an + -- instantiation of Scng. + +end Errutil; diff --git a/gcc/ada/eval_fat.adb b/gcc/ada/eval_fat.adb new file mode 100644 index 000000000..3d0bff6a3 --- /dev/null +++ b/gcc/ada/eval_fat.adb @@ -0,0 +1,791 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E V A L _ F A T -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Einfo; use Einfo; +with Errout; use Errout; +with Targparm; use Targparm; + +package body Eval_Fat is + + Radix : constant Int := 2; + -- This code is currently only correct for the radix 2 case. We use the + -- symbolic value Radix where possible to help in the unlikely case of + -- anyone ever having to adjust this code for another value, and for + -- documentation purposes. + + -- Another assumption is that the range of the floating-point type is + -- symmetric around zero. + + type Radix_Power_Table is array (Int range 1 .. 4) of Int; + + Radix_Powers : constant Radix_Power_Table := + (Radix ** 1, Radix ** 2, Radix ** 3, Radix ** 4); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Decompose + (RT : R; + X : T; + Fraction : out T; + Exponent : out UI; + Mode : Rounding_Mode := Round); + -- Decomposes a non-zero floating-point number into fraction and exponent + -- parts. The fraction is in the interval 1.0 / Radix .. T'Pred (1.0) and + -- uses Rbase = Radix. The result is rounded to a nearest machine number. + + procedure Decompose_Int + (RT : R; + X : T; + Fraction : out UI; + Exponent : out UI; + Mode : Rounding_Mode); + -- This is similar to Decompose, except that the Fraction value returned + -- is an integer representing the value Fraction * Scale, where Scale is + -- the value (Machine_Radix_Value (RT) ** Machine_Mantissa_Value (RT)). The + -- value is obtained by using biased rounding (halfway cases round away + -- from zero), round to even, a floor operation or a ceiling operation + -- depending on the setting of Mode (see corresponding descriptions in + -- Urealp). + + -------------- + -- Adjacent -- + -------------- + + function Adjacent (RT : R; X, Towards : T) return T is + begin + if Towards = X then + return X; + elsif Towards > X then + return Succ (RT, X); + else + return Pred (RT, X); + end if; + end Adjacent; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (RT : R; X : T) return T is + XT : constant T := Truncation (RT, X); + begin + if UR_Is_Negative (X) then + return XT; + elsif X = XT then + return X; + else + return XT + Ureal_1; + end if; + end Ceiling; + + ------------- + -- Compose -- + ------------- + + function Compose (RT : R; Fraction : T; Exponent : UI) return T is + Arg_Frac : T; + Arg_Exp : UI; + pragma Warnings (Off, Arg_Exp); + begin + Decompose (RT, Fraction, Arg_Frac, Arg_Exp); + return Scaling (RT, Arg_Frac, Exponent); + end Compose; + + --------------- + -- Copy_Sign -- + --------------- + + function Copy_Sign (RT : R; Value, Sign : T) return T is + pragma Warnings (Off, RT); + Result : T; + + begin + Result := abs Value; + + if UR_Is_Negative (Sign) then + return -Result; + else + return Result; + end if; + end Copy_Sign; + + --------------- + -- Decompose -- + --------------- + + procedure Decompose + (RT : R; + X : T; + Fraction : out T; + Exponent : out UI; + Mode : Rounding_Mode := Round) + is + Int_F : UI; + + begin + Decompose_Int (RT, abs X, Int_F, Exponent, Mode); + + Fraction := UR_From_Components + (Num => Int_F, + Den => Machine_Mantissa_Value (RT), + Rbase => Radix, + Negative => False); + + if UR_Is_Negative (X) then + Fraction := -Fraction; + end if; + + return; + end Decompose; + + ------------------- + -- Decompose_Int -- + ------------------- + + -- This procedure should be modified with care, as there are many non- + -- obvious details that may cause problems that are hard to detect. For + -- zero arguments, Fraction and Exponent are set to zero. Note that sign + -- of zero cannot be preserved. + + procedure Decompose_Int + (RT : R; + X : T; + Fraction : out UI; + Exponent : out UI; + Mode : Rounding_Mode) + is + Base : Int := Rbase (X); + N : UI := abs Numerator (X); + D : UI := Denominator (X); + + N_Times_Radix : UI; + + Even : Boolean; + -- True iff Fraction is even + + Most_Significant_Digit : constant UI := + Radix ** (Machine_Mantissa_Value (RT) - 1); + + Uintp_Mark : Uintp.Save_Mark; + -- The code is divided into blocks that systematically release + -- intermediate values (this routine generates lots of junk!) + + begin + if N = Uint_0 then + Fraction := Uint_0; + Exponent := Uint_0; + return; + end if; + + Calculate_D_And_Exponent_1 : begin + Uintp_Mark := Mark; + Exponent := Uint_0; + + -- In cases where Base > 1, the actual denominator is Base**D. For + -- cases where Base is a power of Radix, use the value 1 for the + -- Denominator and adjust the exponent. + + -- Note: Exponent has different sign from D, because D is a divisor + + for Power in 1 .. Radix_Powers'Last loop + if Base = Radix_Powers (Power) then + Exponent := -D * Power; + Base := 0; + D := Uint_1; + exit; + end if; + end loop; + + Release_And_Save (Uintp_Mark, D, Exponent); + end Calculate_D_And_Exponent_1; + + if Base > 0 then + Calculate_Exponent : begin + Uintp_Mark := Mark; + + -- For bases that are a multiple of the Radix, divide the base by + -- Radix and adjust the Exponent. This will help because D will be + -- much smaller and faster to process. + + -- This occurs for decimal bases on machines with binary floating- + -- point for example. When calculating 1E40, with Radix = 2, N + -- will be 93 bits instead of 133. + + -- N E + -- ------ * Radix + -- D + -- Base + + -- N E + -- = -------------------------- * Radix + -- D D + -- (Base/Radix) * Radix + + -- N E-D + -- = --------------- * Radix + -- D + -- (Base/Radix) + + -- This code is commented out, because it causes numerous + -- failures in the regression suite. To be studied ??? + + while False and then Base > 0 and then Base mod Radix = 0 loop + Base := Base / Radix; + Exponent := Exponent + D; + end loop; + + Release_And_Save (Uintp_Mark, Exponent); + end Calculate_Exponent; + + -- For remaining bases we must actually compute the exponentiation + + -- Because the exponentiation can be negative, and D must be integer, + -- the numerator is corrected instead. + + Calculate_N_And_D : begin + Uintp_Mark := Mark; + + if D < 0 then + N := N * Base ** (-D); + D := Uint_1; + else + D := Base ** D; + end if; + + Release_And_Save (Uintp_Mark, N, D); + end Calculate_N_And_D; + + Base := 0; + end if; + + -- Now scale N and D so that N / D is a value in the interval [1.0 / + -- Radix, 1.0) and adjust Exponent accordingly, so the value N / D * + -- Radix ** Exponent remains unchanged. + + -- Step 1 - Adjust N so N / D >= 1 / Radix, or N = 0 + + -- N and D are positive, so N / D >= 1 / Radix implies N * Radix >= D. + -- As this scaling is not possible for N is Uint_0, zero is handled + -- explicitly at the start of this subprogram. + + Calculate_N_And_Exponent : begin + Uintp_Mark := Mark; + + N_Times_Radix := N * Radix; + while not (N_Times_Radix >= D) loop + N := N_Times_Radix; + Exponent := Exponent - 1; + N_Times_Radix := N * Radix; + end loop; + + Release_And_Save (Uintp_Mark, N, Exponent); + end Calculate_N_And_Exponent; + + -- Step 2 - Adjust D so N / D < 1 + + -- Scale up D so N / D < 1, so N < D + + Calculate_D_And_Exponent_2 : begin + Uintp_Mark := Mark; + + while not (N < D) loop + + -- As N / D >= 1, N / (D * Radix) will be at least 1 / Radix, so + -- the result of Step 1 stays valid + + D := D * Radix; + Exponent := Exponent + 1; + end loop; + + Release_And_Save (Uintp_Mark, D, Exponent); + end Calculate_D_And_Exponent_2; + + -- Here the value N / D is in the range [1.0 / Radix .. 1.0) + + -- Now find the fraction by doing a very simple-minded division until + -- enough digits have been computed. + + -- This division works for all radices, but is only efficient for a + -- binary radix. It is just like a manual division algorithm, but + -- instead of moving the denominator one digit right, we move the + -- numerator one digit left so the numerator and denominator remain + -- integral. + + Fraction := Uint_0; + Even := True; + + Calculate_Fraction_And_N : begin + Uintp_Mark := Mark; + + loop + while N >= D loop + N := N - D; + Fraction := Fraction + 1; + Even := not Even; + end loop; + + -- Stop when the result is in [1.0 / Radix, 1.0) + + exit when Fraction >= Most_Significant_Digit; + + N := N * Radix; + Fraction := Fraction * Radix; + Even := True; + end loop; + + Release_And_Save (Uintp_Mark, Fraction, N); + end Calculate_Fraction_And_N; + + Calculate_Fraction_And_Exponent : begin + Uintp_Mark := Mark; + + -- Determine correct rounding based on the remainder which is in + -- N and the divisor D. The rounding is performed on the absolute + -- value of X, so Ceiling and Floor need to check for the sign of + -- X explicitly. + + case Mode is + when Round_Even => + + -- This rounding mode should not be used for static + -- expressions, but only for compile-time evaluation of + -- non-static expressions. + + if (Even and then N * 2 > D) + or else + (not Even and then N * 2 >= D) + then + Fraction := Fraction + 1; + end if; + + when Round => + + -- Do not round to even as is done with IEEE arithmetic, but + -- instead round away from zero when the result is exactly + -- between two machine numbers. See RM 4.9(38). + + if N * 2 >= D then + Fraction := Fraction + 1; + end if; + + when Ceiling => + if N > Uint_0 and then not UR_Is_Negative (X) then + Fraction := Fraction + 1; + end if; + + when Floor => + if N > Uint_0 and then UR_Is_Negative (X) then + Fraction := Fraction + 1; + end if; + end case; + + -- The result must be normalized to [1.0/Radix, 1.0), so adjust if + -- the result is 1.0 because of rounding. + + if Fraction = Most_Significant_Digit * Radix then + Fraction := Most_Significant_Digit; + Exponent := Exponent + 1; + end if; + + -- Put back sign after applying the rounding + + if UR_Is_Negative (X) then + Fraction := -Fraction; + end if; + + Release_And_Save (Uintp_Mark, Fraction, Exponent); + end Calculate_Fraction_And_Exponent; + end Decompose_Int; + + -------------- + -- Exponent -- + -------------- + + function Exponent (RT : R; X : T) return UI is + X_Frac : UI; + X_Exp : UI; + pragma Warnings (Off, X_Frac); + begin + Decompose_Int (RT, X, X_Frac, X_Exp, Round_Even); + return X_Exp; + end Exponent; + + ----------- + -- Floor -- + ----------- + + function Floor (RT : R; X : T) return T is + XT : constant T := Truncation (RT, X); + + begin + if UR_Is_Positive (X) then + return XT; + + elsif XT = X then + return X; + + else + return XT - Ureal_1; + end if; + end Floor; + + -------------- + -- Fraction -- + -------------- + + function Fraction (RT : R; X : T) return T is + X_Frac : T; + X_Exp : UI; + pragma Warnings (Off, X_Exp); + begin + Decompose (RT, X, X_Frac, X_Exp); + return X_Frac; + end Fraction; + + ------------------ + -- Leading_Part -- + ------------------ + + function Leading_Part (RT : R; X : T; Radix_Digits : UI) return T is + RD : constant UI := UI_Min (Radix_Digits, Machine_Mantissa_Value (RT)); + L : UI; + Y : T; + begin + L := Exponent (RT, X) - RD; + Y := UR_From_Uint (UR_Trunc (Scaling (RT, X, -L))); + return Scaling (RT, Y, L); + end Leading_Part; + + ------------- + -- Machine -- + ------------- + + function Machine + (RT : R; + X : T; + Mode : Rounding_Mode; + Enode : Node_Id) return T + is + X_Frac : T; + X_Exp : UI; + Emin : constant UI := Machine_Emin_Value (RT); + + begin + Decompose (RT, X, X_Frac, X_Exp, Mode); + + -- Case of denormalized number or (gradual) underflow + + -- A denormalized number is one with the minimum exponent Emin, but that + -- breaks the assumption that the first digit of the mantissa is a one. + -- This allows the first non-zero digit to be in any of the remaining + -- Mant - 1 spots. The gap between subsequent denormalized numbers is + -- the same as for the smallest normalized numbers. However, the number + -- of significant digits left decreases as a result of the mantissa now + -- having leading seros. + + if X_Exp < Emin then + declare + Emin_Den : constant UI := Machine_Emin_Value (RT) + - Machine_Mantissa_Value (RT) + Uint_1; + begin + if X_Exp < Emin_Den or not Denorm_On_Target then + if UR_Is_Negative (X) then + Error_Msg_N + ("floating-point value underflows to -0.0?", Enode); + return Ureal_M_0; + + else + Error_Msg_N + ("floating-point value underflows to 0.0?", Enode); + return Ureal_0; + end if; + + elsif Denorm_On_Target then + + -- Emin - Mant <= X_Exp < Emin, so result is denormal. Handle + -- gradual underflow by first computing the number of + -- significant bits still available for the mantissa and + -- then truncating the fraction to this number of bits. + + -- If this value is different from the original fraction, + -- precision is lost due to gradual underflow. + + -- We probably should round here and prevent double rounding as + -- a result of first rounding to a model number and then to a + -- machine number. However, this is an extremely rare case that + -- is not worth the extra complexity. In any case, a warning is + -- issued in cases where gradual underflow occurs. + + declare + Denorm_Sig_Bits : constant UI := X_Exp - Emin_Den + 1; + + X_Frac_Denorm : constant T := UR_From_Components + (UR_Trunc (Scaling (RT, abs X_Frac, Denorm_Sig_Bits)), + Denorm_Sig_Bits, + Radix, + UR_Is_Negative (X)); + + begin + if X_Frac_Denorm /= X_Frac then + Error_Msg_N + ("gradual underflow causes loss of precision?", + Enode); + X_Frac := X_Frac_Denorm; + end if; + end; + end if; + end; + end if; + + return Scaling (RT, X_Frac, X_Exp); + end Machine; + + ----------- + -- Model -- + ----------- + + function Model (RT : R; X : T) return T is + X_Frac : T; + X_Exp : UI; + begin + Decompose (RT, X, X_Frac, X_Exp); + return Compose (RT, X_Frac, X_Exp); + end Model; + + ---------- + -- Pred -- + ---------- + + function Pred (RT : R; X : T) return T is + begin + return -Succ (RT, -X); + end Pred; + + --------------- + -- Remainder -- + --------------- + + function Remainder (RT : R; X, Y : T) return T is + A : T; + B : T; + Arg : T; + P : T; + Arg_Frac : T; + P_Frac : T; + Sign_X : T; + IEEE_Rem : T; + Arg_Exp : UI; + P_Exp : UI; + K : UI; + P_Even : Boolean; + + pragma Warnings (Off, Arg_Frac); + + begin + if UR_Is_Positive (X) then + Sign_X := Ureal_1; + else + Sign_X := -Ureal_1; + end if; + + Arg := abs X; + P := abs Y; + + if Arg < P then + P_Even := True; + IEEE_Rem := Arg; + P_Exp := Exponent (RT, P); + + else + -- ??? what about zero cases? + Decompose (RT, Arg, Arg_Frac, Arg_Exp); + Decompose (RT, P, P_Frac, P_Exp); + + P := Compose (RT, P_Frac, Arg_Exp); + K := Arg_Exp - P_Exp; + P_Even := True; + IEEE_Rem := Arg; + + for Cnt in reverse 0 .. UI_To_Int (K) loop + if IEEE_Rem >= P then + P_Even := False; + IEEE_Rem := IEEE_Rem - P; + else + P_Even := True; + end if; + + P := P * Ureal_Half; + end loop; + end if; + + -- That completes the calculation of modulus remainder. The final step + -- is get the IEEE remainder. Here we compare Rem with (abs Y) / 2. + + if P_Exp >= 0 then + A := IEEE_Rem; + B := abs Y * Ureal_Half; + + else + A := IEEE_Rem * Ureal_2; + B := abs Y; + end if; + + if A > B or else (A = B and then not P_Even) then + IEEE_Rem := IEEE_Rem - abs Y; + end if; + + return Sign_X * IEEE_Rem; + end Remainder; + + -------------- + -- Rounding -- + -------------- + + function Rounding (RT : R; X : T) return T is + Result : T; + Tail : T; + + begin + Result := Truncation (RT, abs X); + Tail := abs X - Result; + + if Tail >= Ureal_Half then + Result := Result + Ureal_1; + end if; + + if UR_Is_Negative (X) then + return -Result; + else + return Result; + end if; + end Rounding; + + ------------- + -- Scaling -- + ------------- + + function Scaling (RT : R; X : T; Adjustment : UI) return T is + pragma Warnings (Off, RT); + + begin + if Rbase (X) = Radix then + return UR_From_Components + (Num => Numerator (X), + Den => Denominator (X) - Adjustment, + Rbase => Radix, + Negative => UR_Is_Negative (X)); + + elsif Adjustment >= 0 then + return X * Radix ** Adjustment; + else + return X / Radix ** (-Adjustment); + end if; + end Scaling; + + ---------- + -- Succ -- + ---------- + + function Succ (RT : R; X : T) return T is + Emin : constant UI := Machine_Emin_Value (RT); + Mantissa : constant UI := Machine_Mantissa_Value (RT); + Exp : UI := UI_Max (Emin, Exponent (RT, X)); + Frac : T; + New_Frac : T; + + begin + if UR_Is_Zero (X) then + Exp := Emin; + end if; + + -- Set exponent such that the radix point will be directly following the + -- mantissa after scaling. + + if Denorm_On_Target or Exp /= Emin then + Exp := Exp - Mantissa; + else + Exp := Exp - 1; + end if; + + Frac := Scaling (RT, X, -Exp); + New_Frac := Ceiling (RT, Frac); + + if New_Frac = Frac then + if New_Frac = Scaling (RT, -Ureal_1, Mantissa - 1) then + New_Frac := New_Frac + Scaling (RT, Ureal_1, Uint_Minus_1); + else + New_Frac := New_Frac + Ureal_1; + end if; + end if; + + return Scaling (RT, New_Frac, Exp); + end Succ; + + ---------------- + -- Truncation -- + ---------------- + + function Truncation (RT : R; X : T) return T is + pragma Warnings (Off, RT); + begin + return UR_From_Uint (UR_Trunc (X)); + end Truncation; + + ----------------------- + -- Unbiased_Rounding -- + ----------------------- + + function Unbiased_Rounding (RT : R; X : T) return T is + Abs_X : constant T := abs X; + Result : T; + Tail : T; + + begin + Result := Truncation (RT, Abs_X); + Tail := Abs_X - Result; + + if Tail > Ureal_Half then + Result := Result + Ureal_1; + + elsif Tail = Ureal_Half then + Result := Ureal_2 * + Truncation (RT, (Result / Ureal_2) + Ureal_Half); + end if; + + if UR_Is_Negative (X) then + return -Result; + elsif UR_Is_Positive (X) then + return Result; + + -- For zero case, make sure sign of zero is preserved + + else + return X; + end if; + end Unbiased_Rounding; + +end Eval_Fat; diff --git a/gcc/ada/eval_fat.ads b/gcc/ada/eval_fat.ads new file mode 100644 index 000000000..964dd2224 --- /dev/null +++ b/gcc/ada/eval_fat.ads @@ -0,0 +1,102 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E V A L _ F A T -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides for compile-time evaluation of static calls to the +-- floating-point attribute functions. It is the compile-time equivalent of +-- the System.Fat_Gen runtime package. The coding is quite similar, as are +-- the subprogram specs, except that the type is passed as an explicit +-- first parameter (and used via ttypes, to obtain the necessary information +-- about the characteristics of the type for computing the results. + +with Types; use Types; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package Eval_Fat is + + subtype UI is Uint; + -- The compile time representation of universal integer + + subtype T is Ureal; + -- The compile time representation of floating-point values + + subtype R is Entity_Id; + -- The compile time representation of the floating-point root type + + -- The following functions perform the operation implied by their name + -- which corresponds to the name of the attribute which they compute. + -- The arguments correspond to the attribute function arguments. + + function Adjacent (RT : R; X, Towards : T) return T; + + function Ceiling (RT : R; X : T) return T; + + function Compose (RT : R; Fraction : T; Exponent : UI) return T; + + function Copy_Sign (RT : R; Value, Sign : T) return T; + + function Exponent (RT : R; X : T) return UI; + + function Floor (RT : R; X : T) return T; + + function Fraction (RT : R; X : T) return T; + + function Leading_Part (RT : R; X : T; Radix_Digits : UI) return T; + + function Model (RT : R; X : T) return T; + + function Pred (RT : R; X : T) return T; + + function Remainder (RT : R; X, Y : T) return T; + + function Rounding (RT : R; X : T) return T; + + function Scaling (RT : R; X : T; Adjustment : UI) return T; + + function Succ (RT : R; X : T) return T; + + function Truncation (RT : R; X : T) return T; + + function Unbiased_Rounding (RT : R; X : T) return T; + + -- The following global declarations are used by the Machine attribute + + type Rounding_Mode is (Floor, Ceiling, Round, Round_Even); + for Rounding_Mode use (0, 1, 2, 3); + -- Used to indicate rounding mode for Machine attribute + -- Note that C code in gigi knows that Round_Even is 3 + + -- The Machine attribute is special, in that it takes an extra argument + -- indicating the rounding mode, and also an argument Enode that is a + -- node used to post warnings (e.g. if asked to convert a negative zero + -- on a machine for which Signed_Zeros is False). + + function Machine + (RT : R; + X : T; + Mode : Rounding_Mode; + Enode : Node_Id) return T; + +end Eval_Fat; diff --git a/gcc/ada/exit.c b/gcc/ada/exit.c new file mode 100644 index 000000000..92873c15c --- /dev/null +++ b/gcc/ada/exit.c @@ -0,0 +1,55 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * E X I T * + * * + * C Implementation File * + * * + * Copyright (C) 1992-2009 Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. * + * * + * As a special exception under Section 7 of GPL version 3, you are granted * + * additional permissions described in the GCC Runtime Library Exception, * + * version 3.1, as published by the Free Software Foundation. * + * * + * You should have received a copy of the GNU General Public License and * + * a copy of the GCC Runtime Library Exception along with this program; * + * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +#ifdef __alpha_vxworks +#include "vxWorks.h" +#endif + +#ifdef IN_RTS +#include "tconfig.h" +#include "tsystem.h" +#include +#else +#include "config.h" +#include "system.h" +#endif + +#include "adaint.h" + +/* Routine used by Ada.Command_Line.Set_Exit_Status */ + +int gnat_exit_status = 0; + +void +__gnat_set_exit_status (int i) +{ + gnat_exit_status = i; +} diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb new file mode 100644 index 000000000..64d8127e5 --- /dev/null +++ b/gcc/ada/exp_aggr.adb @@ -0,0 +1,6721 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ A G G 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Expander; use Expander; +with Exp_Util; use Exp_Util; +with Exp_Ch3; use Exp_Ch3; +with Exp_Ch7; use Exp_Ch7; +with Exp_Ch9; use Exp_Ch9; +with Exp_Disp; use Exp_Disp; +with Exp_Tss; use Exp_Tss; +with Fname; use Fname; +with Freeze; use Freeze; +with Itypes; use Itypes; +with Lib; use Lib; +with Namet; use Namet; +with Nmake; use Nmake; +with Nlists; use Nlists; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Ttypes; use Ttypes; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch3; use Sem_Ch3; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +package body Exp_Aggr is + + type Case_Bounds is record + Choice_Lo : Node_Id; + Choice_Hi : Node_Id; + Choice_Node : Node_Id; + end record; + + type Case_Table_Type is array (Nat range <>) of Case_Bounds; + -- Table type used by Check_Case_Choices procedure + + function Must_Slide + (Obj_Type : Entity_Id; + Typ : Entity_Id) return Boolean; + -- A static array aggregate in an object declaration can in most cases be + -- expanded in place. The one exception is when the aggregate is given + -- with component associations that specify different bounds from those of + -- the type definition in the object declaration. In this pathological + -- case the aggregate must slide, and we must introduce an intermediate + -- temporary to hold it. + -- + -- The same holds in an assignment to one-dimensional array of arrays, + -- when a component may be given with bounds that differ from those of the + -- component type. + + procedure Sort_Case_Table (Case_Table : in out Case_Table_Type); + -- Sort the Case Table using the Lower Bound of each Choice as the key. + -- A simple insertion sort is used since the number of choices in a case + -- statement of variant part will usually be small and probably in near + -- sorted order. + + function Has_Default_Init_Comps (N : Node_Id) return Boolean; + -- N is an aggregate (record or array). Checks the presence of default + -- initialization (<>) in any component (Ada 2005: AI-287). + + function Is_Static_Dispatch_Table_Aggregate (N : Node_Id) return Boolean; + -- Returns true if N is an aggregate used to initialize the components + -- of an statically allocated dispatch table. + + ------------------------------------------------------ + -- Local subprograms for Record Aggregate Expansion -- + ------------------------------------------------------ + + procedure Expand_Record_Aggregate + (N : Node_Id; + Orig_Tag : Node_Id := Empty; + Parent_Expr : Node_Id := Empty); + -- This is the top level procedure for record aggregate expansion. + -- Expansion for record aggregates needs expand aggregates for tagged + -- record types. Specifically Expand_Record_Aggregate adds the Tag + -- field in front of the Component_Association list that was created + -- during resolution by Resolve_Record_Aggregate. + -- + -- N is the record aggregate node. + -- Orig_Tag is the value of the Tag that has to be provided for this + -- specific aggregate. It carries the tag corresponding to the type + -- of the outermost aggregate during the recursive expansion + -- Parent_Expr is the ancestor part of the original extension + -- aggregate + + procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id); + -- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the + -- aggregate (which can only be a record type, this procedure is only used + -- for record types). Transform the given aggregate into a sequence of + -- assignments performed component by component. + + function Build_Record_Aggr_Code + (N : Node_Id; + Typ : Entity_Id; + Lhs : Node_Id; + Flist : Node_Id := Empty; + Obj : Entity_Id := Empty; + Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id; + -- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the + -- aggregate. Target is an expression containing the location on which the + -- component by component assignments will take place. Returns the list of + -- assignments plus all other adjustments needed for tagged and controlled + -- types. Flist is an expression representing the finalization list on + -- which to attach the controlled components if any. Obj is present in the + -- object declaration and dynamic allocation cases, it contains an entity + -- that allows to know if the value being created needs to be attached to + -- the final list in case of pragma Finalize_Storage_Only. + -- + -- ??? + -- The meaning of the Obj formal is extremely unclear. *What* entity + -- should be passed? For the object declaration case we may guess that + -- this is the object being declared, but what about the allocator case? + -- + -- Is_Limited_Ancestor_Expansion indicates that the function has been + -- called recursively to expand the limited ancestor to avoid copying it. + + function Has_Mutable_Components (Typ : Entity_Id) return Boolean; + -- Return true if one of the component is of a discriminated type with + -- defaults. An aggregate for a type with mutable components must be + -- expanded into individual assignments. + + procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id); + -- If the type of the aggregate is a type extension with renamed discrimi- + -- nants, we must initialize the hidden discriminants of the parent. + -- Otherwise, the target object must not be initialized. The discriminants + -- are initialized by calling the initialization procedure for the type. + -- This is incorrect if the initialization of other components has any + -- side effects. We restrict this call to the case where the parent type + -- has a variant part, because this is the only case where the hidden + -- discriminants are accessed, namely when calling discriminant checking + -- functions of the parent type, and when applying a stream attribute to + -- an object of the derived type. + + ----------------------------------------------------- + -- Local Subprograms for Array Aggregate Expansion -- + ----------------------------------------------------- + + function Aggr_Size_OK (N : Node_Id; Typ : Entity_Id) return Boolean; + -- Very large static aggregates present problems to the back-end, and are + -- transformed into assignments and loops. This function verifies that the + -- total number of components of an aggregate is acceptable for rewriting + -- into a purely positional static form. Aggr_Size_OK must be called before + -- calling Flatten. + -- + -- This function also detects and warns about one-component aggregates that + -- appear in a non-static context. Even if the component value is static, + -- such an aggregate must be expanded into an assignment. + + procedure Convert_Array_Aggr_In_Allocator + (Decl : Node_Id; + Aggr : Node_Id; + Target : Node_Id); + -- If the aggregate appears within an allocator and can be expanded in + -- place, this routine generates the individual assignments to components + -- of the designated object. This is an optimization over the general + -- case, where a temporary is first created on the stack and then used to + -- construct the allocated object on the heap. + + procedure Convert_To_Positional + (N : Node_Id; + Max_Others_Replicate : Nat := 5; + Handle_Bit_Packed : Boolean := False); + -- If possible, convert named notation to positional notation. This + -- conversion is possible only in some static cases. If the conversion is + -- possible, then N is rewritten with the analyzed converted aggregate. + -- The parameter Max_Others_Replicate controls the maximum number of + -- values corresponding to an others choice that will be converted to + -- positional notation (the default of 5 is the normal limit, and reflects + -- the fact that normally the loop is better than a lot of separate + -- assignments). Note that this limit gets overridden in any case if + -- either of the restrictions No_Elaboration_Code or No_Implicit_Loops is + -- set. The parameter Handle_Bit_Packed is usually set False (since we do + -- not expect the back end to handle bit packed arrays, so the normal case + -- of conversion is pointless), but in the special case of a call from + -- Packed_Array_Aggregate_Handled, we set this parameter to True, since + -- these are cases we handle in there. + + procedure Expand_Array_Aggregate (N : Node_Id); + -- This is the top-level routine to perform array aggregate expansion. + -- N is the N_Aggregate node to be expanded. + + function Backend_Processing_Possible (N : Node_Id) return Boolean; + -- This function checks if array aggregate N can be processed directly + -- by the backend. If this is the case True is returned. + + function Build_Array_Aggr_Code + (N : Node_Id; + Ctype : Entity_Id; + Index : Node_Id; + Into : Node_Id; + Scalar_Comp : Boolean; + Indexes : List_Id := No_List; + Flist : Node_Id := Empty) return List_Id; + -- This recursive routine returns a list of statements containing the + -- loops and assignments that are needed for the expansion of the array + -- aggregate N. + -- + -- N is the (sub-)aggregate node to be expanded into code. This node + -- has been fully analyzed, and its Etype is properly set. + -- + -- Index is the index node corresponding to the array sub-aggregate N. + -- + -- Into is the target expression into which we are copying the aggregate. + -- Note that this node may not have been analyzed yet, and so the Etype + -- field may not be set. + -- + -- Scalar_Comp is True if the component type of the aggregate is scalar. + -- + -- Indexes is the current list of expressions used to index the + -- object we are writing into. + -- + -- Flist is an expression representing the finalization list on which + -- to attach the controlled components if any. + + function Number_Of_Choices (N : Node_Id) return Nat; + -- Returns the number of discrete choices (not including the others choice + -- if present) contained in (sub-)aggregate N. + + function Late_Expansion + (N : Node_Id; + Typ : Entity_Id; + Target : Node_Id; + Flist : Node_Id := Empty; + Obj : Entity_Id := Empty) return List_Id; + -- N is a nested (record or array) aggregate that has been marked with + -- 'Delay_Expansion'. Typ is the expected type of the aggregate and Target + -- is a (duplicable) expression that will hold the result of the aggregate + -- expansion. Flist is the finalization list to be used to attach + -- controlled components. 'Obj' when non empty, carries the original + -- object being initialized in order to know if it needs to be attached to + -- the previous parameter which may not be the case in the case where + -- Finalize_Storage_Only is set. Basically this procedure is used to + -- implement top-down expansions of nested aggregates. This is necessary + -- for avoiding temporaries at each level as well as for propagating the + -- right internal finalization list. + + function Make_OK_Assignment_Statement + (Sloc : Source_Ptr; + Name : Node_Id; + Expression : Node_Id) return Node_Id; + -- This is like Make_Assignment_Statement, except that Assignment_OK + -- is set in the left operand. All assignments built by this unit + -- use this routine. This is needed to deal with assignments to + -- initialized constants that are done in place. + + function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean; + -- Given an array aggregate, this function handles the case of a packed + -- array aggregate with all constant values, where the aggregate can be + -- evaluated at compile time. If this is possible, then N is rewritten + -- to be its proper compile time value with all the components properly + -- assembled. The expression is analyzed and resolved and True is + -- returned. If this transformation is not possible, N is unchanged + -- and False is returned + + function Safe_Slice_Assignment (N : Node_Id) return Boolean; + -- If a slice assignment has an aggregate with a single others_choice, + -- the assignment can be done in place even if bounds are not static, + -- by converting it into a loop over the discrete range of the slice. + + ------------------ + -- Aggr_Size_OK -- + ------------------ + + function Aggr_Size_OK (N : Node_Id; Typ : Entity_Id) return Boolean is + Lo : Node_Id; + Hi : Node_Id; + Indx : Node_Id; + Siz : Int; + Lov : Uint; + Hiv : Uint; + + -- The following constant determines the maximum size of an + -- array aggregate produced by converting named to positional + -- notation (e.g. from others clauses). This avoids running + -- away with attempts to convert huge aggregates, which hit + -- memory limits in the backend. + + -- The normal limit is 5000, but we increase this limit to + -- 2**24 (about 16 million) if Restrictions (No_Elaboration_Code) + -- or Restrictions (No_Implicit_Loops) is specified, since in + -- either case, we are at risk of declaring the program illegal + -- because of this limit. + + Max_Aggr_Size : constant Nat := + 5000 + (2 ** 24 - 5000) * + Boolean'Pos + (Restriction_Active (No_Elaboration_Code) + or else + Restriction_Active (No_Implicit_Loops)); + + function Component_Count (T : Entity_Id) return Int; + -- The limit is applied to the total number of components that the + -- aggregate will have, which is the number of static expressions + -- that will appear in the flattened array. This requires a recursive + -- computation of the number of scalar components of the structure. + + --------------------- + -- Component_Count -- + --------------------- + + function Component_Count (T : Entity_Id) return Int is + Res : Int := 0; + Comp : Entity_Id; + + begin + if Is_Scalar_Type (T) then + return 1; + + elsif Is_Record_Type (T) then + Comp := First_Component (T); + while Present (Comp) loop + Res := Res + Component_Count (Etype (Comp)); + Next_Component (Comp); + end loop; + + return Res; + + elsif Is_Array_Type (T) then + declare + Lo : constant Node_Id := + Type_Low_Bound (Etype (First_Index (T))); + Hi : constant Node_Id := + Type_High_Bound (Etype (First_Index (T))); + + Siz : constant Int := Component_Count (Component_Type (T)); + + begin + if not Compile_Time_Known_Value (Lo) + or else not Compile_Time_Known_Value (Hi) + then + return 0; + else + return + Siz * UI_To_Int (Expr_Value (Hi) - Expr_Value (Lo) + 1); + end if; + end; + + else + -- Can only be a null for an access type + + return 1; + end if; + end Component_Count; + + -- Start of processing for Aggr_Size_OK + + begin + Siz := Component_Count (Component_Type (Typ)); + + Indx := First_Index (Typ); + while Present (Indx) loop + Lo := Type_Low_Bound (Etype (Indx)); + Hi := Type_High_Bound (Etype (Indx)); + + -- Bounds need to be known at compile time + + if not Compile_Time_Known_Value (Lo) + or else not Compile_Time_Known_Value (Hi) + then + return False; + end if; + + Lov := Expr_Value (Lo); + Hiv := Expr_Value (Hi); + + -- A flat array is always safe + + if Hiv < Lov then + return True; + end if; + + -- One-component aggregates are suspicious, and if the context type + -- is an object declaration with non-static bounds it will trip gcc; + -- such an aggregate must be expanded into a single assignment. + + if Hiv = Lov + and then Nkind (Parent (N)) = N_Object_Declaration + then + declare + Index_Type : constant Entity_Id := + Etype + (First_Index + (Etype (Defining_Identifier (Parent (N))))); + Indx : Node_Id; + + begin + if not Compile_Time_Known_Value (Type_Low_Bound (Index_Type)) + or else not Compile_Time_Known_Value + (Type_High_Bound (Index_Type)) + then + if Present (Component_Associations (N)) then + Indx := + First (Choices (First (Component_Associations (N)))); + if Is_Entity_Name (Indx) + and then not Is_Type (Entity (Indx)) + then + Error_Msg_N + ("single component aggregate in non-static context?", + Indx); + Error_Msg_N ("\maybe subtype name was meant?", Indx); + end if; + end if; + + return False; + end if; + end; + end if; + + declare + Rng : constant Uint := Hiv - Lov + 1; + + begin + -- Check if size is too large + + if not UI_Is_In_Int_Range (Rng) then + return False; + end if; + + Siz := Siz * UI_To_Int (Rng); + end; + + if Siz <= 0 + or else Siz > Max_Aggr_Size + then + return False; + end if; + + -- Bounds must be in integer range, for later array construction + + if not UI_Is_In_Int_Range (Lov) + or else + not UI_Is_In_Int_Range (Hiv) + then + return False; + end if; + + Next_Index (Indx); + end loop; + + return True; + end Aggr_Size_OK; + + --------------------------------- + -- Backend_Processing_Possible -- + --------------------------------- + + -- Backend processing by Gigi/gcc is possible only if all the following + -- conditions are met: + + -- 1. N is fully positional + + -- 2. N is not a bit-packed array aggregate; + + -- 3. The size of N's array type must be known at compile time. Note + -- that this implies that the component size is also known + + -- 4. The array type of N does not follow the Fortran layout convention + -- or if it does it must be 1 dimensional. + + -- 5. The array component type may not be tagged (which could necessitate + -- reassignment of proper tags). + + -- 6. The array component type must not have unaligned bit components + + -- 7. None of the components of the aggregate may be bit unaligned + -- components. + + -- 8. There cannot be delayed components, since we do not know enough + -- at this stage to know if back end processing is possible. + + -- 9. There cannot be any discriminated record components, since the + -- back end cannot handle this complex case. + + -- 10. No controlled actions need to be generated for components + + -- 11. For a VM back end, the array should have no aliased components + + function Backend_Processing_Possible (N : Node_Id) return Boolean is + Typ : constant Entity_Id := Etype (N); + -- Typ is the correct constrained array subtype of the aggregate + + function Component_Check (N : Node_Id; Index : Node_Id) return Boolean; + -- This routine checks components of aggregate N, enforcing checks + -- 1, 7, 8, and 9. In the multi-dimensional case, these checks are + -- performed on subaggregates. The Index value is the current index + -- being checked in the multi-dimensional case. + + --------------------- + -- Component_Check -- + --------------------- + + function Component_Check (N : Node_Id; Index : Node_Id) return Boolean is + Expr : Node_Id; + + begin + -- Checks 1: (no component associations) + + if Present (Component_Associations (N)) then + return False; + end if; + + -- Checks on components + + -- Recurse to check subaggregates, which may appear in qualified + -- expressions. If delayed, the front-end will have to expand. + -- If the component is a discriminated record, treat as non-static, + -- as the back-end cannot handle this properly. + + Expr := First (Expressions (N)); + while Present (Expr) loop + + -- Checks 8: (no delayed components) + + if Is_Delayed_Aggregate (Expr) then + return False; + end if; + + -- Checks 9: (no discriminated records) + + if Present (Etype (Expr)) + and then Is_Record_Type (Etype (Expr)) + and then Has_Discriminants (Etype (Expr)) + then + return False; + end if; + + -- Checks 7. Component must not be bit aligned component + + if Possible_Bit_Aligned_Component (Expr) then + return False; + end if; + + -- Recursion to following indexes for multiple dimension case + + if Present (Next_Index (Index)) + and then not Component_Check (Expr, Next_Index (Index)) + then + return False; + end if; + + -- All checks for that component finished, on to next + + Next (Expr); + end loop; + + return True; + end Component_Check; + + -- Start of processing for Backend_Processing_Possible + + begin + -- Checks 2 (array not bit packed) and 10 (no controlled actions) + + if Is_Bit_Packed_Array (Typ) or else Needs_Finalization (Typ) then + return False; + end if; + + -- If component is limited, aggregate must be expanded because each + -- component assignment must be built in place. + + if Is_Immutably_Limited_Type (Component_Type (Typ)) then + return False; + end if; + + -- Checks 4 (array must not be multi-dimensional Fortran case) + + if Convention (Typ) = Convention_Fortran + and then Number_Dimensions (Typ) > 1 + then + return False; + end if; + + -- Checks 3 (size of array must be known at compile time) + + if not Size_Known_At_Compile_Time (Typ) then + return False; + end if; + + -- Checks on components + + if not Component_Check (N, First_Index (Typ)) then + return False; + end if; + + -- Checks 5 (if the component type is tagged, then we may need to do + -- tag adjustments. Perhaps this should be refined to check for any + -- component associations that actually need tag adjustment, similar + -- to the test in Component_Not_OK_For_Backend for record aggregates + -- with tagged components, but not clear whether it's worthwhile ???; + -- in the case of the JVM, object tags are handled implicitly) + + if Is_Tagged_Type (Component_Type (Typ)) + and then Tagged_Type_Expansion + then + return False; + end if; + + -- Checks 6 (component type must not have bit aligned components) + + if Type_May_Have_Bit_Aligned_Components (Component_Type (Typ)) then + return False; + end if; + + -- Checks 11: Array aggregates with aliased components are currently + -- not well supported by the VM backend; disable temporarily this + -- backend processing until it is definitely supported. + + if VM_Target /= No_VM + and then Has_Aliased_Components (Base_Type (Typ)) + then + return False; + end if; + + -- Backend processing is possible + + Set_Size_Known_At_Compile_Time (Etype (N), True); + return True; + end Backend_Processing_Possible; + + --------------------------- + -- Build_Array_Aggr_Code -- + --------------------------- + + -- The code that we generate from a one dimensional aggregate is + + -- 1. If the sub-aggregate contains discrete choices we + + -- (a) Sort the discrete choices + + -- (b) Otherwise for each discrete choice that specifies a range we + -- emit a loop. If a range specifies a maximum of three values, or + -- we are dealing with an expression we emit a sequence of + -- assignments instead of a loop. + + -- (c) Generate the remaining loops to cover the others choice if any + + -- 2. If the aggregate contains positional elements we + + -- (a) translate the positional elements in a series of assignments + + -- (b) Generate a final loop to cover the others choice if any. + -- Note that this final loop has to be a while loop since the case + + -- L : Integer := Integer'Last; + -- H : Integer := Integer'Last; + -- A : array (L .. H) := (1, others =>0); + + -- cannot be handled by a for loop. Thus for the following + + -- array (L .. H) := (.. positional elements.., others =>E); + + -- we always generate something like: + + -- J : Index_Type := Index_Of_Last_Positional_Element; + -- while J < H loop + -- J := Index_Base'Succ (J) + -- Tmp (J) := E; + -- end loop; + + function Build_Array_Aggr_Code + (N : Node_Id; + Ctype : Entity_Id; + Index : Node_Id; + Into : Node_Id; + Scalar_Comp : Boolean; + Indexes : List_Id := No_List; + Flist : Node_Id := Empty) return List_Id + is + Loc : constant Source_Ptr := Sloc (N); + Index_Base : constant Entity_Id := Base_Type (Etype (Index)); + Index_Base_L : constant Node_Id := Type_Low_Bound (Index_Base); + Index_Base_H : constant Node_Id := Type_High_Bound (Index_Base); + + function Add (Val : Int; To : Node_Id) return Node_Id; + -- Returns an expression where Val is added to expression To, unless + -- To+Val is provably out of To's base type range. To must be an + -- already analyzed expression. + + function Empty_Range (L, H : Node_Id) return Boolean; + -- Returns True if the range defined by L .. H is certainly empty + + function Equal (L, H : Node_Id) return Boolean; + -- Returns True if L = H for sure + + function Index_Base_Name return Node_Id; + -- Returns a new reference to the index type name + + function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id; + -- Ind must be a side-effect free expression. If the input aggregate + -- N to Build_Loop contains no sub-aggregates, then this function + -- returns the assignment statement: + -- + -- Into (Indexes, Ind) := Expr; + -- + -- Otherwise we call Build_Code recursively + -- + -- Ada 2005 (AI-287): In case of default initialized component, Expr + -- is empty and we generate a call to the corresponding IP subprogram. + + function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id; + -- Nodes L and H must be side-effect free expressions. + -- If the input aggregate N to Build_Loop contains no sub-aggregates, + -- This routine returns the for loop statement + -- + -- for J in Index_Base'(L) .. Index_Base'(H) loop + -- Into (Indexes, J) := Expr; + -- end loop; + -- + -- Otherwise we call Build_Code recursively. + -- As an optimization if the loop covers 3 or less scalar elements we + -- generate a sequence of assignments. + + function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id; + -- Nodes L and H must be side-effect free expressions. + -- If the input aggregate N to Build_Loop contains no sub-aggregates, + -- This routine returns the while loop statement + -- + -- J : Index_Base := L; + -- while J < H loop + -- J := Index_Base'Succ (J); + -- Into (Indexes, J) := Expr; + -- end loop; + -- + -- Otherwise we call Build_Code recursively + + function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean; + function Local_Expr_Value (E : Node_Id) return Uint; + -- These two Local routines are used to replace the corresponding ones + -- in sem_eval because while processing the bounds of an aggregate with + -- discrete choices whose index type is an enumeration, we build static + -- expressions not recognized by Compile_Time_Known_Value as such since + -- they have not yet been analyzed and resolved. All the expressions in + -- question are things like Index_Base_Name'Val (Const) which we can + -- easily recognize as being constant. + + --------- + -- Add -- + --------- + + function Add (Val : Int; To : Node_Id) return Node_Id is + Expr_Pos : Node_Id; + Expr : Node_Id; + To_Pos : Node_Id; + U_To : Uint; + U_Val : constant Uint := UI_From_Int (Val); + + begin + -- Note: do not try to optimize the case of Val = 0, because + -- we need to build a new node with the proper Sloc value anyway. + + -- First test if we can do constant folding + + if Local_Compile_Time_Known_Value (To) then + U_To := Local_Expr_Value (To) + Val; + + -- Determine if our constant is outside the range of the index. + -- If so return an Empty node. This empty node will be caught + -- by Empty_Range below. + + if Compile_Time_Known_Value (Index_Base_L) + and then U_To < Expr_Value (Index_Base_L) + then + return Empty; + + elsif Compile_Time_Known_Value (Index_Base_H) + and then U_To > Expr_Value (Index_Base_H) + then + return Empty; + end if; + + Expr_Pos := Make_Integer_Literal (Loc, U_To); + Set_Is_Static_Expression (Expr_Pos); + + if not Is_Enumeration_Type (Index_Base) then + Expr := Expr_Pos; + + -- If we are dealing with enumeration return + -- Index_Base'Val (Expr_Pos) + + else + Expr := + Make_Attribute_Reference + (Loc, + Prefix => Index_Base_Name, + Attribute_Name => Name_Val, + Expressions => New_List (Expr_Pos)); + end if; + + return Expr; + end if; + + -- If we are here no constant folding possible + + if not Is_Enumeration_Type (Index_Base) then + Expr := + Make_Op_Add (Loc, + Left_Opnd => Duplicate_Subexpr (To), + Right_Opnd => Make_Integer_Literal (Loc, U_Val)); + + -- If we are dealing with enumeration return + -- Index_Base'Val (Index_Base'Pos (To) + Val) + + else + To_Pos := + Make_Attribute_Reference + (Loc, + Prefix => Index_Base_Name, + Attribute_Name => Name_Pos, + Expressions => New_List (Duplicate_Subexpr (To))); + + Expr_Pos := + Make_Op_Add (Loc, + Left_Opnd => To_Pos, + Right_Opnd => Make_Integer_Literal (Loc, U_Val)); + + Expr := + Make_Attribute_Reference + (Loc, + Prefix => Index_Base_Name, + Attribute_Name => Name_Val, + Expressions => New_List (Expr_Pos)); + end if; + + return Expr; + end Add; + + ----------------- + -- Empty_Range -- + ----------------- + + function Empty_Range (L, H : Node_Id) return Boolean is + Is_Empty : Boolean := False; + Low : Node_Id; + High : Node_Id; + + begin + -- First check if L or H were already detected as overflowing the + -- index base range type by function Add above. If this is so Add + -- returns the empty node. + + if No (L) or else No (H) then + return True; + end if; + + for J in 1 .. 3 loop + case J is + + -- L > H range is empty + + when 1 => + Low := L; + High := H; + + -- B_L > H range must be empty + + when 2 => + Low := Index_Base_L; + High := H; + + -- L > B_H range must be empty + + when 3 => + Low := L; + High := Index_Base_H; + end case; + + if Local_Compile_Time_Known_Value (Low) + and then Local_Compile_Time_Known_Value (High) + then + Is_Empty := + UI_Gt (Local_Expr_Value (Low), Local_Expr_Value (High)); + end if; + + exit when Is_Empty; + end loop; + + return Is_Empty; + end Empty_Range; + + ----------- + -- Equal -- + ----------- + + function Equal (L, H : Node_Id) return Boolean is + begin + if L = H then + return True; + + elsif Local_Compile_Time_Known_Value (L) + and then Local_Compile_Time_Known_Value (H) + then + return UI_Eq (Local_Expr_Value (L), Local_Expr_Value (H)); + end if; + + return False; + end Equal; + + ---------------- + -- Gen_Assign -- + ---------------- + + function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id is + L : constant List_Id := New_List; + F : Entity_Id; + A : Node_Id; + + New_Indexes : List_Id; + Indexed_Comp : Node_Id; + Expr_Q : Node_Id; + Comp_Type : Entity_Id := Empty; + + function Add_Loop_Actions (Lis : List_Id) return List_Id; + -- Collect insert_actions generated in the construction of a + -- loop, and prepend them to the sequence of assignments to + -- complete the eventual body of the loop. + + ---------------------- + -- Add_Loop_Actions -- + ---------------------- + + function Add_Loop_Actions (Lis : List_Id) return List_Id is + Res : List_Id; + + begin + -- Ada 2005 (AI-287): Do nothing else in case of default + -- initialized component. + + if No (Expr) then + return Lis; + + elsif Nkind (Parent (Expr)) = N_Component_Association + and then Present (Loop_Actions (Parent (Expr))) + then + Append_List (Lis, Loop_Actions (Parent (Expr))); + Res := Loop_Actions (Parent (Expr)); + Set_Loop_Actions (Parent (Expr), No_List); + return Res; + + else + return Lis; + end if; + end Add_Loop_Actions; + + -- Start of processing for Gen_Assign + + begin + if No (Indexes) then + New_Indexes := New_List; + else + New_Indexes := New_Copy_List_Tree (Indexes); + end if; + + Append_To (New_Indexes, Ind); + + if Present (Flist) then + F := New_Copy_Tree (Flist); + + elsif Present (Etype (N)) and then Needs_Finalization (Etype (N)) then + if Is_Entity_Name (Into) + and then Present (Scope (Entity (Into))) + then + F := Find_Final_List (Scope (Entity (Into))); + else + F := Find_Final_List (Current_Scope); + end if; + else + F := Empty; + end if; + + if Present (Next_Index (Index)) then + return + Add_Loop_Actions ( + Build_Array_Aggr_Code + (N => Expr, + Ctype => Ctype, + Index => Next_Index (Index), + Into => Into, + Scalar_Comp => Scalar_Comp, + Indexes => New_Indexes, + Flist => F)); + end if; + + -- If we get here then we are at a bottom-level (sub-)aggregate + + Indexed_Comp := + Checks_Off + (Make_Indexed_Component (Loc, + Prefix => New_Copy_Tree (Into), + Expressions => New_Indexes)); + + Set_Assignment_OK (Indexed_Comp); + + -- Ada 2005 (AI-287): In case of default initialized component, Expr + -- is not present (and therefore we also initialize Expr_Q to empty). + + if No (Expr) then + Expr_Q := Empty; + elsif Nkind (Expr) = N_Qualified_Expression then + Expr_Q := Expression (Expr); + else + Expr_Q := Expr; + end if; + + if Present (Etype (N)) + and then Etype (N) /= Any_Composite + then + Comp_Type := Component_Type (Etype (N)); + pragma Assert (Comp_Type = Ctype); -- AI-287 + + elsif Present (Next (First (New_Indexes))) then + + -- Ada 2005 (AI-287): Do nothing in case of default initialized + -- component because we have received the component type in + -- the formal parameter Ctype. + + -- ??? Some assert pragmas have been added to check if this new + -- formal can be used to replace this code in all cases. + + if Present (Expr) then + + -- This is a multidimensional array. Recover the component + -- type from the outermost aggregate, because subaggregates + -- do not have an assigned type. + + declare + P : Node_Id; + + begin + P := Parent (Expr); + while Present (P) loop + if Nkind (P) = N_Aggregate + and then Present (Etype (P)) + then + Comp_Type := Component_Type (Etype (P)); + exit; + + else + P := Parent (P); + end if; + end loop; + + pragma Assert (Comp_Type = Ctype); -- AI-287 + end; + end if; + end if; + + -- Ada 2005 (AI-287): We only analyze the expression in case of non- + -- default initialized components (otherwise Expr_Q is not present). + + if Present (Expr_Q) + and then Nkind_In (Expr_Q, N_Aggregate, N_Extension_Aggregate) + then + -- At this stage the Expression may not have been analyzed yet + -- because the array aggregate code has not been updated to use + -- the Expansion_Delayed flag and avoid analysis altogether to + -- solve the same problem (see Resolve_Aggr_Expr). So let us do + -- the analysis of non-array aggregates now in order to get the + -- value of Expansion_Delayed flag for the inner aggregate ??? + + if Present (Comp_Type) and then not Is_Array_Type (Comp_Type) then + Analyze_And_Resolve (Expr_Q, Comp_Type); + end if; + + if Is_Delayed_Aggregate (Expr_Q) then + + -- This is either a subaggregate of a multidimensional array, + -- or a component of an array type whose component type is + -- also an array. In the latter case, the expression may have + -- component associations that provide different bounds from + -- those of the component type, and sliding must occur. Instead + -- of decomposing the current aggregate assignment, force the + -- re-analysis of the assignment, so that a temporary will be + -- generated in the usual fashion, and sliding will take place. + + if Nkind (Parent (N)) = N_Assignment_Statement + and then Is_Array_Type (Comp_Type) + and then Present (Component_Associations (Expr_Q)) + and then Must_Slide (Comp_Type, Etype (Expr_Q)) + then + Set_Expansion_Delayed (Expr_Q, False); + Set_Analyzed (Expr_Q, False); + + else + return + Add_Loop_Actions ( + Late_Expansion ( + Expr_Q, Etype (Expr_Q), Indexed_Comp, F)); + end if; + end if; + end if; + + -- Ada 2005 (AI-287): In case of default initialized component, call + -- the initialization subprogram associated with the component type. + -- If the component type is an access type, add an explicit null + -- assignment, because for the back-end there is an initialization + -- present for the whole aggregate, and no default initialization + -- will take place. + + -- In addition, if the component type is controlled, we must call + -- its Initialize procedure explicitly, because there is no explicit + -- object creation that will invoke it otherwise. + + if No (Expr) then + if Present (Base_Init_Proc (Base_Type (Ctype))) + or else Has_Task (Base_Type (Ctype)) + then + Append_List_To (L, + Build_Initialization_Call (Loc, + Id_Ref => Indexed_Comp, + Typ => Ctype, + With_Default_Init => True)); + + elsif Is_Access_Type (Ctype) then + Append_To (L, + Make_Assignment_Statement (Loc, + Name => Indexed_Comp, + Expression => Make_Null (Loc))); + end if; + + if Needs_Finalization (Ctype) then + Append_List_To (L, + Make_Init_Call ( + Ref => New_Copy_Tree (Indexed_Comp), + Typ => Ctype, + Flist_Ref => Find_Final_List (Current_Scope), + With_Attach => Make_Integer_Literal (Loc, 1))); + end if; + + else + -- Now generate the assignment with no associated controlled + -- actions since the target of the assignment may not have been + -- initialized, it is not possible to Finalize it as expected by + -- normal controlled assignment. The rest of the controlled + -- actions are done manually with the proper finalization list + -- coming from the context. + + A := + Make_OK_Assignment_Statement (Loc, + Name => Indexed_Comp, + Expression => New_Copy_Tree (Expr)); + + if Present (Comp_Type) and then Needs_Finalization (Comp_Type) then + Set_No_Ctrl_Actions (A); + + -- If this is an aggregate for an array of arrays, each + -- sub-aggregate will be expanded as well, and even with + -- No_Ctrl_Actions the assignments of inner components will + -- require attachment in their assignments to temporaries. + -- These temporaries must be finalized for each subaggregate, + -- to prevent multiple attachments of the same temporary + -- location to same finalization chain (and consequently + -- circular lists). To ensure that finalization takes place + -- for each subaggregate we wrap the assignment in a block. + + if Is_Array_Type (Comp_Type) + and then Nkind (Expr) = N_Aggregate + then + A := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (A))); + end if; + end if; + + Append_To (L, A); + + -- Adjust the tag if tagged (because of possible view + -- conversions), unless compiling for a VM where + -- tags are implicit. + + if Present (Comp_Type) + and then Is_Tagged_Type (Comp_Type) + and then Tagged_Type_Expansion + then + A := + Make_OK_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Indexed_Comp), + Selector_Name => + New_Reference_To + (First_Tag_Component (Comp_Type), Loc)), + + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Comp_Type))), + Loc))); + + Append_To (L, A); + end if; + + -- Adjust and attach the component to the proper final list, which + -- can be the controller of the outer record object or the final + -- list associated with the scope. + + -- If the component is itself an array of controlled types, whose + -- value is given by a sub-aggregate, then the attach calls have + -- been generated when individual subcomponent are assigned, and + -- must not be done again to prevent malformed finalization chains + -- (see comments above, concerning the creation of a block to hold + -- inner finalization actions). + + if Present (Comp_Type) + and then Needs_Finalization (Comp_Type) + and then not Is_Limited_Type (Comp_Type) + and then not + (Is_Array_Type (Comp_Type) + and then Is_Controlled (Component_Type (Comp_Type)) + and then Nkind (Expr) = N_Aggregate) + then + Append_List_To (L, + Make_Adjust_Call ( + Ref => New_Copy_Tree (Indexed_Comp), + Typ => Comp_Type, + Flist_Ref => F, + With_Attach => Make_Integer_Literal (Loc, 1))); + end if; + end if; + + return Add_Loop_Actions (L); + end Gen_Assign; + + -------------- + -- Gen_Loop -- + -------------- + + function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is + L_J : Node_Id; + + L_L : Node_Id; + -- Index_Base'(L) + + L_H : Node_Id; + -- Index_Base'(H) + + L_Range : Node_Id; + -- Index_Base'(L) .. Index_Base'(H) + + L_Iteration_Scheme : Node_Id; + -- L_J in Index_Base'(L) .. Index_Base'(H) + + L_Body : List_Id; + -- The statements to execute in the loop + + S : constant List_Id := New_List; + -- List of statements + + Tcopy : Node_Id; + -- Copy of expression tree, used for checking purposes + + begin + -- If loop bounds define an empty range return the null statement + + if Empty_Range (L, H) then + Append_To (S, Make_Null_Statement (Loc)); + + -- Ada 2005 (AI-287): Nothing else need to be done in case of + -- default initialized component. + + if No (Expr) then + null; + + else + -- The expression must be type-checked even though no component + -- of the aggregate will have this value. This is done only for + -- actual components of the array, not for subaggregates. Do + -- the check on a copy, because the expression may be shared + -- among several choices, some of which might be non-null. + + if Present (Etype (N)) + and then Is_Array_Type (Etype (N)) + and then No (Next_Index (Index)) + then + Expander_Mode_Save_And_Set (False); + Tcopy := New_Copy_Tree (Expr); + Set_Parent (Tcopy, N); + Analyze_And_Resolve (Tcopy, Component_Type (Etype (N))); + Expander_Mode_Restore; + end if; + end if; + + return S; + + -- If loop bounds are the same then generate an assignment + + elsif Equal (L, H) then + return Gen_Assign (New_Copy_Tree (L), Expr); + + -- If H - L <= 2 then generate a sequence of assignments when we are + -- processing the bottom most aggregate and it contains scalar + -- components. + + elsif No (Next_Index (Index)) + and then Scalar_Comp + and then Local_Compile_Time_Known_Value (L) + and then Local_Compile_Time_Known_Value (H) + and then Local_Expr_Value (H) - Local_Expr_Value (L) <= 2 + then + + Append_List_To (S, Gen_Assign (New_Copy_Tree (L), Expr)); + Append_List_To (S, Gen_Assign (Add (1, To => L), Expr)); + + if Local_Expr_Value (H) - Local_Expr_Value (L) = 2 then + Append_List_To (S, Gen_Assign (Add (2, To => L), Expr)); + end if; + + return S; + end if; + + -- Otherwise construct the loop, starting with the loop index L_J + + L_J := Make_Temporary (Loc, 'J', L); + + -- Construct "L .. H" in Index_Base. We use a qualified expression + -- for the bound to convert to the index base, but we don't need + -- to do that if we already have the base type at hand. + + if Etype (L) = Index_Base then + L_L := L; + else + L_L := + Make_Qualified_Expression (Loc, + Subtype_Mark => Index_Base_Name, + Expression => L); + end if; + + if Etype (H) = Index_Base then + L_H := H; + else + L_H := + Make_Qualified_Expression (Loc, + Subtype_Mark => Index_Base_Name, + Expression => H); + end if; + + L_Range := + Make_Range (Loc, + Low_Bound => L_L, + High_Bound => L_H); + + -- Construct "for L_J in Index_Base range L .. H" + + L_Iteration_Scheme := + Make_Iteration_Scheme + (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification + (Loc, + Defining_Identifier => L_J, + Discrete_Subtype_Definition => L_Range)); + + -- Construct the statements to execute in the loop body + + L_Body := Gen_Assign (New_Reference_To (L_J, Loc), Expr); + + -- Construct the final loop + + Append_To (S, Make_Implicit_Loop_Statement + (Node => N, + Identifier => Empty, + Iteration_Scheme => L_Iteration_Scheme, + Statements => L_Body)); + + -- A small optimization: if the aggregate is initialized with a box + -- and the component type has no initialization procedure, remove the + -- useless empty loop. + + if Nkind (First (S)) = N_Loop_Statement + and then Is_Empty_List (Statements (First (S))) + then + return New_List (Make_Null_Statement (Loc)); + else + return S; + end if; + end Gen_Loop; + + --------------- + -- Gen_While -- + --------------- + + -- The code built is + + -- W_J : Index_Base := L; + -- while W_J < H loop + -- W_J := Index_Base'Succ (W); + -- L_Body; + -- end loop; + + function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id is + W_J : Node_Id; + + W_Decl : Node_Id; + -- W_J : Base_Type := L; + + W_Iteration_Scheme : Node_Id; + -- while W_J < H + + W_Index_Succ : Node_Id; + -- Index_Base'Succ (J) + + W_Increment : Node_Id; + -- W_J := Index_Base'Succ (W) + + W_Body : constant List_Id := New_List; + -- The statements to execute in the loop + + S : constant List_Id := New_List; + -- list of statement + + begin + -- If loop bounds define an empty range or are equal return null + + if Empty_Range (L, H) or else Equal (L, H) then + Append_To (S, Make_Null_Statement (Loc)); + return S; + end if; + + -- Build the decl of W_J + + W_J := Make_Temporary (Loc, 'J', L); + W_Decl := + Make_Object_Declaration + (Loc, + Defining_Identifier => W_J, + Object_Definition => Index_Base_Name, + Expression => L); + + -- Theoretically we should do a New_Copy_Tree (L) here, but we know + -- that in this particular case L is a fresh Expr generated by + -- Add which we are the only ones to use. + + Append_To (S, W_Decl); + + -- Construct " while W_J < H" + + W_Iteration_Scheme := + Make_Iteration_Scheme + (Loc, + Condition => Make_Op_Lt + (Loc, + Left_Opnd => New_Reference_To (W_J, Loc), + Right_Opnd => New_Copy_Tree (H))); + + -- Construct the statements to execute in the loop body + + W_Index_Succ := + Make_Attribute_Reference + (Loc, + Prefix => Index_Base_Name, + Attribute_Name => Name_Succ, + Expressions => New_List (New_Reference_To (W_J, Loc))); + + W_Increment := + Make_OK_Assignment_Statement + (Loc, + Name => New_Reference_To (W_J, Loc), + Expression => W_Index_Succ); + + Append_To (W_Body, W_Increment); + Append_List_To (W_Body, + Gen_Assign (New_Reference_To (W_J, Loc), Expr)); + + -- Construct the final loop + + Append_To (S, Make_Implicit_Loop_Statement + (Node => N, + Identifier => Empty, + Iteration_Scheme => W_Iteration_Scheme, + Statements => W_Body)); + + return S; + end Gen_While; + + --------------------- + -- Index_Base_Name -- + --------------------- + + function Index_Base_Name return Node_Id is + begin + return New_Reference_To (Index_Base, Sloc (N)); + end Index_Base_Name; + + ------------------------------------ + -- Local_Compile_Time_Known_Value -- + ------------------------------------ + + function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean is + begin + return Compile_Time_Known_Value (E) + or else + (Nkind (E) = N_Attribute_Reference + and then Attribute_Name (E) = Name_Val + and then Compile_Time_Known_Value (First (Expressions (E)))); + end Local_Compile_Time_Known_Value; + + ---------------------- + -- Local_Expr_Value -- + ---------------------- + + function Local_Expr_Value (E : Node_Id) return Uint is + begin + if Compile_Time_Known_Value (E) then + return Expr_Value (E); + else + return Expr_Value (First (Expressions (E))); + end if; + end Local_Expr_Value; + + -- Build_Array_Aggr_Code Variables + + Assoc : Node_Id; + Choice : Node_Id; + Expr : Node_Id; + Typ : Entity_Id; + + Others_Expr : Node_Id := Empty; + Others_Box_Present : Boolean := False; + + Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N)); + Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N)); + -- The aggregate bounds of this specific sub-aggregate. Note that if + -- the code generated by Build_Array_Aggr_Code is executed then these + -- bounds are OK. Otherwise a Constraint_Error would have been raised. + + Aggr_Low : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_L); + Aggr_High : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_H); + -- After Duplicate_Subexpr these are side-effect free + + Low : Node_Id; + High : Node_Id; + + Nb_Choices : Nat := 0; + Table : Case_Table_Type (1 .. Number_Of_Choices (N)); + -- Used to sort all the different choice values + + Nb_Elements : Int; + -- Number of elements in the positional aggregate + + New_Code : constant List_Id := New_List; + + -- Start of processing for Build_Array_Aggr_Code + + begin + -- First before we start, a special case. if we have a bit packed + -- array represented as a modular type, then clear the value to + -- zero first, to ensure that unused bits are properly cleared. + + Typ := Etype (N); + + if Present (Typ) + and then Is_Bit_Packed_Array (Typ) + and then Is_Modular_Integer_Type (Packed_Array_Type (Typ)) + then + Append_To (New_Code, + Make_Assignment_Statement (Loc, + Name => New_Copy_Tree (Into), + Expression => + Unchecked_Convert_To (Typ, + Make_Integer_Literal (Loc, Uint_0)))); + end if; + + -- If the component type contains tasks, we need to build a Master + -- entity in the current scope, because it will be needed if build- + -- in-place functions are called in the expanded code. + + if Nkind (Parent (N)) = N_Object_Declaration + and then Has_Task (Typ) + then + Build_Master_Entity (Defining_Identifier (Parent (N))); + end if; + + -- STEP 1: Process component associations + + -- For those associations that may generate a loop, initialize + -- Loop_Actions to collect inserted actions that may be crated. + + -- Skip this if no component associations + + if No (Expressions (N)) then + + -- STEP 1 (a): Sort the discrete choices + + Assoc := First (Component_Associations (N)); + while Present (Assoc) loop + Choice := First (Choices (Assoc)); + while Present (Choice) loop + if Nkind (Choice) = N_Others_Choice then + Set_Loop_Actions (Assoc, New_List); + + if Box_Present (Assoc) then + Others_Box_Present := True; + else + Others_Expr := Expression (Assoc); + end if; + exit; + end if; + + Get_Index_Bounds (Choice, Low, High); + + if Low /= High then + Set_Loop_Actions (Assoc, New_List); + end if; + + Nb_Choices := Nb_Choices + 1; + if Box_Present (Assoc) then + Table (Nb_Choices) := (Choice_Lo => Low, + Choice_Hi => High, + Choice_Node => Empty); + else + Table (Nb_Choices) := (Choice_Lo => Low, + Choice_Hi => High, + Choice_Node => Expression (Assoc)); + end if; + Next (Choice); + end loop; + + Next (Assoc); + end loop; + + -- If there is more than one set of choices these must be static + -- and we can therefore sort them. Remember that Nb_Choices does not + -- account for an others choice. + + if Nb_Choices > 1 then + Sort_Case_Table (Table); + end if; + + -- STEP 1 (b): take care of the whole set of discrete choices + + for J in 1 .. Nb_Choices loop + Low := Table (J).Choice_Lo; + High := Table (J).Choice_Hi; + Expr := Table (J).Choice_Node; + Append_List (Gen_Loop (Low, High, Expr), To => New_Code); + end loop; + + -- STEP 1 (c): generate the remaining loops to cover others choice + -- We don't need to generate loops over empty gaps, but if there is + -- a single empty range we must analyze the expression for semantics + + if Present (Others_Expr) or else Others_Box_Present then + declare + First : Boolean := True; + + begin + for J in 0 .. Nb_Choices loop + if J = 0 then + Low := Aggr_Low; + else + Low := Add (1, To => Table (J).Choice_Hi); + end if; + + if J = Nb_Choices then + High := Aggr_High; + else + High := Add (-1, To => Table (J + 1).Choice_Lo); + end if; + + -- If this is an expansion within an init proc, make + -- sure that discriminant references are replaced by + -- the corresponding discriminal. + + if Inside_Init_Proc then + if Is_Entity_Name (Low) + and then Ekind (Entity (Low)) = E_Discriminant + then + Set_Entity (Low, Discriminal (Entity (Low))); + end if; + + if Is_Entity_Name (High) + and then Ekind (Entity (High)) = E_Discriminant + then + Set_Entity (High, Discriminal (Entity (High))); + end if; + end if; + + if First + or else not Empty_Range (Low, High) + then + First := False; + Append_List + (Gen_Loop (Low, High, Others_Expr), To => New_Code); + end if; + end loop; + end; + end if; + + -- STEP 2: Process positional components + + else + -- STEP 2 (a): Generate the assignments for each positional element + -- Note that here we have to use Aggr_L rather than Aggr_Low because + -- Aggr_L is analyzed and Add wants an analyzed expression. + + Expr := First (Expressions (N)); + Nb_Elements := -1; + while Present (Expr) loop + Nb_Elements := Nb_Elements + 1; + Append_List (Gen_Assign (Add (Nb_Elements, To => Aggr_L), Expr), + To => New_Code); + Next (Expr); + end loop; + + -- STEP 2 (b): Generate final loop if an others choice is present + -- Here Nb_Elements gives the offset of the last positional element. + + if Present (Component_Associations (N)) then + Assoc := Last (Component_Associations (N)); + + -- Ada 2005 (AI-287) + + if Box_Present (Assoc) then + Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L), + Aggr_High, + Empty), + To => New_Code); + else + Expr := Expression (Assoc); + + Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L), + Aggr_High, + Expr), -- AI-287 + To => New_Code); + end if; + end if; + end if; + + return New_Code; + end Build_Array_Aggr_Code; + + ---------------------------- + -- Build_Record_Aggr_Code -- + ---------------------------- + + function Build_Record_Aggr_Code + (N : Node_Id; + Typ : Entity_Id; + Lhs : Node_Id; + Flist : Node_Id := Empty; + Obj : Entity_Id := Empty; + Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id + is + Loc : constant Source_Ptr := Sloc (N); + L : constant List_Id := New_List; + N_Typ : constant Entity_Id := Etype (N); + + Comp : Node_Id; + Instr : Node_Id; + Ref : Node_Id; + Target : Entity_Id; + F : Node_Id; + Comp_Type : Entity_Id; + Selector : Entity_Id; + Comp_Expr : Node_Id; + Expr_Q : Node_Id; + + Internal_Final_List : Node_Id := Empty; + + -- If this is an internal aggregate, the External_Final_List is an + -- expression for the controller record of the enclosing type. + + -- If the current aggregate has several controlled components, this + -- expression will appear in several calls to attach to the finali- + -- zation list, and it must not be shared. + + External_Final_List : Node_Id; + Ancestor_Is_Expression : Boolean := False; + Ancestor_Is_Subtype_Mark : Boolean := False; + + Init_Typ : Entity_Id := Empty; + Attach : Node_Id; + + Ctrl_Stuff_Done : Boolean := False; + -- True if Gen_Ctrl_Actions_For_Aggr has already been called; calls + -- after the first do nothing. + + function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id; + -- Returns the value that the given discriminant of an ancestor type + -- should receive (in the absence of a conflict with the value provided + -- by an ancestor part of an extension aggregate). + + procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id); + -- Check that each of the discriminant values defined by the ancestor + -- part of an extension aggregate match the corresponding values + -- provided by either an association of the aggregate or by the + -- constraint imposed by a parent type (RM95-4.3.2(8)). + + function Compatible_Int_Bounds + (Agg_Bounds : Node_Id; + Typ_Bounds : Node_Id) return Boolean; + -- Return true if Agg_Bounds are equal or within Typ_Bounds. It is + -- assumed that both bounds are integer ranges. + + procedure Gen_Ctrl_Actions_For_Aggr; + -- Deal with the various controlled type data structure initializations + -- (but only if it hasn't been done already). + + function Get_Constraint_Association (T : Entity_Id) return Node_Id; + -- Returns the first discriminant association in the constraint + -- associated with T, if any, otherwise returns Empty. + + function Init_Controller + (Target : Node_Id; + Typ : Entity_Id; + F : Node_Id; + Attach : Node_Id; + Init_Pr : Boolean) return List_Id; + -- Returns the list of statements necessary to initialize the internal + -- controller of the (possible) ancestor typ into target and attach it + -- to finalization list F. Init_Pr conditions the call to the init proc + -- since it may already be done due to ancestor initialization. + + function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean; + -- Check whether Bounds is a range node and its lower and higher bounds + -- are integers literals. + + --------------------------------- + -- Ancestor_Discriminant_Value -- + --------------------------------- + + function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id is + Assoc : Node_Id; + Assoc_Elmt : Elmt_Id; + Aggr_Comp : Entity_Id; + Corresp_Disc : Entity_Id; + Current_Typ : Entity_Id := Base_Type (Typ); + Parent_Typ : Entity_Id; + Parent_Disc : Entity_Id; + Save_Assoc : Node_Id := Empty; + + begin + -- First check any discriminant associations to see if any of them + -- provide a value for the discriminant. + + if Present (Discriminant_Specifications (Parent (Current_Typ))) then + Assoc := First (Component_Associations (N)); + while Present (Assoc) loop + Aggr_Comp := Entity (First (Choices (Assoc))); + + if Ekind (Aggr_Comp) = E_Discriminant then + Save_Assoc := Expression (Assoc); + + Corresp_Disc := Corresponding_Discriminant (Aggr_Comp); + while Present (Corresp_Disc) loop + + -- If found a corresponding discriminant then return the + -- value given in the aggregate. (Note: this is not + -- correct in the presence of side effects. ???) + + if Disc = Corresp_Disc then + return Duplicate_Subexpr (Expression (Assoc)); + end if; + + Corresp_Disc := + Corresponding_Discriminant (Corresp_Disc); + end loop; + end if; + + Next (Assoc); + end loop; + end if; + + -- No match found in aggregate, so chain up parent types to find + -- a constraint that defines the value of the discriminant. + + Parent_Typ := Etype (Current_Typ); + while Current_Typ /= Parent_Typ loop + if Has_Discriminants (Parent_Typ) + and then not Has_Unknown_Discriminants (Parent_Typ) + then + Parent_Disc := First_Discriminant (Parent_Typ); + + -- We either get the association from the subtype indication + -- of the type definition itself, or from the discriminant + -- constraint associated with the type entity (which is + -- preferable, but it's not always present ???) + + if Is_Empty_Elmt_List ( + Discriminant_Constraint (Current_Typ)) + then + Assoc := Get_Constraint_Association (Current_Typ); + Assoc_Elmt := No_Elmt; + else + Assoc_Elmt := + First_Elmt (Discriminant_Constraint (Current_Typ)); + Assoc := Node (Assoc_Elmt); + end if; + + -- Traverse the discriminants of the parent type looking + -- for one that corresponds. + + while Present (Parent_Disc) and then Present (Assoc) loop + Corresp_Disc := Parent_Disc; + while Present (Corresp_Disc) + and then Disc /= Corresp_Disc + loop + Corresp_Disc := + Corresponding_Discriminant (Corresp_Disc); + end loop; + + if Disc = Corresp_Disc then + if Nkind (Assoc) = N_Discriminant_Association then + Assoc := Expression (Assoc); + end if; + + -- If the located association directly denotes a + -- discriminant, then use the value of a saved + -- association of the aggregate. This is a kludge to + -- handle certain cases involving multiple discriminants + -- mapped to a single discriminant of a descendant. It's + -- not clear how to locate the appropriate discriminant + -- value for such cases. ??? + + if Is_Entity_Name (Assoc) + and then Ekind (Entity (Assoc)) = E_Discriminant + then + Assoc := Save_Assoc; + end if; + + return Duplicate_Subexpr (Assoc); + end if; + + Next_Discriminant (Parent_Disc); + + if No (Assoc_Elmt) then + Next (Assoc); + else + Next_Elmt (Assoc_Elmt); + if Present (Assoc_Elmt) then + Assoc := Node (Assoc_Elmt); + else + Assoc := Empty; + end if; + end if; + end loop; + end if; + + Current_Typ := Parent_Typ; + Parent_Typ := Etype (Current_Typ); + end loop; + + -- In some cases there's no ancestor value to locate (such as + -- when an ancestor part given by an expression defines the + -- discriminant value). + + return Empty; + end Ancestor_Discriminant_Value; + + ---------------------------------- + -- Check_Ancestor_Discriminants -- + ---------------------------------- + + procedure Check_Ancestor_Discriminants (Anc_Typ : Entity_Id) is + Discr : Entity_Id; + Disc_Value : Node_Id; + Cond : Node_Id; + + begin + Discr := First_Discriminant (Base_Type (Anc_Typ)); + while Present (Discr) loop + Disc_Value := Ancestor_Discriminant_Value (Discr); + + if Present (Disc_Value) then + Cond := Make_Op_Ne (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Occurrence_Of (Discr, Loc)), + Right_Opnd => Disc_Value); + + Append_To (L, + Make_Raise_Constraint_Error (Loc, + Condition => Cond, + Reason => CE_Discriminant_Check_Failed)); + end if; + + Next_Discriminant (Discr); + end loop; + end Check_Ancestor_Discriminants; + + --------------------------- + -- Compatible_Int_Bounds -- + --------------------------- + + function Compatible_Int_Bounds + (Agg_Bounds : Node_Id; + Typ_Bounds : Node_Id) return Boolean + is + Agg_Lo : constant Uint := Intval (Low_Bound (Agg_Bounds)); + Agg_Hi : constant Uint := Intval (High_Bound (Agg_Bounds)); + Typ_Lo : constant Uint := Intval (Low_Bound (Typ_Bounds)); + Typ_Hi : constant Uint := Intval (High_Bound (Typ_Bounds)); + begin + return Typ_Lo <= Agg_Lo and then Agg_Hi <= Typ_Hi; + end Compatible_Int_Bounds; + + -------------------------------- + -- Get_Constraint_Association -- + -------------------------------- + + function Get_Constraint_Association (T : Entity_Id) return Node_Id is + Typ_Def : constant Node_Id := Type_Definition (Parent (T)); + Indic : constant Node_Id := Subtype_Indication (Typ_Def); + + begin + -- ??? Also need to cover case of a type mark denoting a subtype + -- with constraint. + + if Nkind (Indic) = N_Subtype_Indication + and then Present (Constraint (Indic)) + then + return First (Constraints (Constraint (Indic))); + end if; + + return Empty; + end Get_Constraint_Association; + + --------------------- + -- Init_Controller -- + --------------------- + + function Init_Controller + (Target : Node_Id; + Typ : Entity_Id; + F : Node_Id; + Attach : Node_Id; + Init_Pr : Boolean) return List_Id + is + L : constant List_Id := New_List; + Ref : Node_Id; + RC : RE_Id; + Target_Type : Entity_Id; + + begin + -- Generate: + -- init-proc (target._controller); + -- initialize (target._controller); + -- Attach_to_Final_List (target._controller, F); + + Ref := + Make_Selected_Component (Loc, + Prefix => Convert_To (Typ, New_Copy_Tree (Target)), + Selector_Name => Make_Identifier (Loc, Name_uController)); + Set_Assignment_OK (Ref); + + -- Ada 2005 (AI-287): Give support to aggregates of limited types. + -- If the type is intrinsically limited the controller is limited as + -- well. If it is tagged and limited then so is the controller. + -- Otherwise an untagged type may have limited components without its + -- full view being limited, so the controller is not limited. + + if Nkind (Target) = N_Identifier then + Target_Type := Etype (Target); + + elsif Nkind (Target) = N_Selected_Component then + Target_Type := Etype (Selector_Name (Target)); + + elsif Nkind (Target) = N_Unchecked_Type_Conversion then + Target_Type := Etype (Target); + + elsif Nkind (Target) = N_Unchecked_Expression + and then Nkind (Expression (Target)) = N_Indexed_Component + then + Target_Type := Etype (Prefix (Expression (Target))); + + else + Target_Type := Etype (Target); + end if; + + -- If the target has not been analyzed yet, as will happen with + -- delayed expansion, use the given type (either the aggregate type + -- or an ancestor) to determine limitedness. + + if No (Target_Type) then + Target_Type := Typ; + end if; + + if (Is_Tagged_Type (Target_Type)) + and then Is_Limited_Type (Target_Type) + then + RC := RE_Limited_Record_Controller; + + elsif Is_Immutably_Limited_Type (Target_Type) then + RC := RE_Limited_Record_Controller; + + else + RC := RE_Record_Controller; + end if; + + if Init_Pr then + Append_List_To (L, + Build_Initialization_Call (Loc, + Id_Ref => Ref, + Typ => RTE (RC), + In_Init_Proc => Within_Init_Proc)); + end if; + + Append_To (L, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + Find_Prim_Op (RTE (RC), Name_Initialize), Loc), + Parameter_Associations => + New_List (New_Copy_Tree (Ref)))); + + Append_To (L, + Make_Attach_Call ( + Obj_Ref => New_Copy_Tree (Ref), + Flist_Ref => F, + With_Attach => Attach)); + + return L; + end Init_Controller; + + ------------------------- + -- Is_Int_Range_Bounds -- + ------------------------- + + function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean is + begin + return Nkind (Bounds) = N_Range + and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal + and then Nkind (High_Bound (Bounds)) = N_Integer_Literal; + end Is_Int_Range_Bounds; + + ------------------------------- + -- Gen_Ctrl_Actions_For_Aggr -- + ------------------------------- + + procedure Gen_Ctrl_Actions_For_Aggr is + Alloc : Node_Id := Empty; + + begin + -- Do the work only the first time this is called + + if Ctrl_Stuff_Done then + return; + end if; + + Ctrl_Stuff_Done := True; + + if Present (Obj) + and then Finalize_Storage_Only (Typ) + and then + (Is_Library_Level_Entity (Obj) + or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) = + Standard_True) + + -- why not Is_True (Expr_Value (RTE (RE_Garbaage_Collected) ??? + then + Attach := Make_Integer_Literal (Loc, 0); + + elsif Nkind (Parent (N)) = N_Qualified_Expression + and then Nkind (Parent (Parent (N))) = N_Allocator + then + Alloc := Parent (Parent (N)); + Attach := Make_Integer_Literal (Loc, 2); + + else + Attach := Make_Integer_Literal (Loc, 1); + end if; + + -- Determine the external finalization list. It is either the + -- finalization list of the outer-scope or the one coming from + -- an outer aggregate. When the target is not a temporary, the + -- proper scope is the scope of the target rather than the + -- potentially transient current scope. + + if Needs_Finalization (Typ) then + + -- The current aggregate belongs to an allocator which creates + -- an object through an anonymous access type or acts as the root + -- of a coextension chain. + + if Present (Alloc) + and then + (Is_Coextension_Root (Alloc) + or else Ekind (Etype (Alloc)) = E_Anonymous_Access_Type) + then + if No (Associated_Final_Chain (Etype (Alloc))) then + Build_Final_List (Alloc, Etype (Alloc)); + end if; + + External_Final_List := + Make_Selected_Component (Loc, + Prefix => + New_Reference_To ( + Associated_Final_Chain (Etype (Alloc)), Loc), + Selector_Name => Make_Identifier (Loc, Name_F)); + + elsif Present (Flist) then + External_Final_List := New_Copy_Tree (Flist); + + elsif Is_Entity_Name (Target) + and then Present (Scope (Entity (Target))) + then + External_Final_List := + Find_Final_List (Scope (Entity (Target))); + + else + External_Final_List := Find_Final_List (Current_Scope); + end if; + else + External_Final_List := Empty; + end if; + + -- Initialize and attach the outer object in the is_controlled case + + if Is_Controlled (Typ) then + if Ancestor_Is_Subtype_Mark then + Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); + Set_Assignment_OK (Ref); + Append_To (L, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To + (Find_Prim_Op (Init_Typ, Name_Initialize), Loc), + Parameter_Associations => New_List (New_Copy_Tree (Ref)))); + end if; + + if not Has_Controlled_Component (Typ) then + Ref := New_Copy_Tree (Target); + Set_Assignment_OK (Ref); + + -- This is an aggregate of a coextension. Do not produce a + -- finalization call, but rather attach the reference of the + -- aggregate to its coextension chain. + + if Present (Alloc) + and then Is_Dynamic_Coextension (Alloc) + then + if No (Coextensions (Alloc)) then + Set_Coextensions (Alloc, New_Elmt_List); + end if; + + Append_Elmt (Ref, Coextensions (Alloc)); + else + Append_To (L, + Make_Attach_Call ( + Obj_Ref => Ref, + Flist_Ref => New_Copy_Tree (External_Final_List), + With_Attach => Attach)); + end if; + end if; + end if; + + -- In the Has_Controlled component case, all the intermediate + -- controllers must be initialized. + + if Has_Controlled_Component (Typ) + and not Is_Limited_Ancestor_Expansion + then + declare + Inner_Typ : Entity_Id; + Outer_Typ : Entity_Id; + At_Root : Boolean; + + begin + -- Find outer type with a controller + + Outer_Typ := Base_Type (Typ); + while Outer_Typ /= Init_Typ + and then not Has_New_Controlled_Component (Outer_Typ) + loop + Outer_Typ := Etype (Outer_Typ); + end loop; + + -- Attach it to the outer record controller to the external + -- final list. + + if Outer_Typ = Init_Typ then + Append_List_To (L, + Init_Controller ( + Target => Target, + Typ => Outer_Typ, + F => External_Final_List, + Attach => Attach, + Init_Pr => False)); + + At_Root := True; + Inner_Typ := Init_Typ; + + else + Append_List_To (L, + Init_Controller ( + Target => Target, + Typ => Outer_Typ, + F => External_Final_List, + Attach => Attach, + Init_Pr => True)); + + Inner_Typ := Etype (Outer_Typ); + At_Root := + not Is_Tagged_Type (Typ) or else Inner_Typ = Outer_Typ; + end if; + + -- The outer object has to be attached as well + + if Is_Controlled (Typ) then + Ref := New_Copy_Tree (Target); + Set_Assignment_OK (Ref); + Append_To (L, + Make_Attach_Call ( + Obj_Ref => Ref, + Flist_Ref => New_Copy_Tree (External_Final_List), + With_Attach => New_Copy_Tree (Attach))); + end if; + + -- Initialize the internal controllers for tagged types with + -- more than one controller. + + while not At_Root and then Inner_Typ /= Init_Typ loop + if Has_New_Controlled_Component (Inner_Typ) then + F := + Make_Selected_Component (Loc, + Prefix => + Convert_To (Outer_Typ, New_Copy_Tree (Target)), + Selector_Name => + Make_Identifier (Loc, Name_uController)); + F := + Make_Selected_Component (Loc, + Prefix => F, + Selector_Name => Make_Identifier (Loc, Name_F)); + + Append_List_To (L, + Init_Controller ( + Target => Target, + Typ => Inner_Typ, + F => F, + Attach => Make_Integer_Literal (Loc, 1), + Init_Pr => True)); + Outer_Typ := Inner_Typ; + end if; + + -- Stop at the root + + At_Root := Inner_Typ = Etype (Inner_Typ); + Inner_Typ := Etype (Inner_Typ); + end loop; + + -- If not done yet attach the controller of the ancestor part + + if Outer_Typ /= Init_Typ + and then Inner_Typ = Init_Typ + and then Has_Controlled_Component (Init_Typ) + then + F := + Make_Selected_Component (Loc, + Prefix => Convert_To (Outer_Typ, New_Copy_Tree (Target)), + Selector_Name => + Make_Identifier (Loc, Name_uController)); + F := + Make_Selected_Component (Loc, + Prefix => F, + Selector_Name => Make_Identifier (Loc, Name_F)); + + Attach := Make_Integer_Literal (Loc, 1); + Append_List_To (L, + Init_Controller ( + Target => Target, + Typ => Init_Typ, + F => F, + Attach => Attach, + Init_Pr => False)); + + -- Note: Init_Pr is False because the ancestor part has + -- already been initialized either way (by default, if + -- given by a type name, otherwise from the expression). + + end if; + end; + end if; + end Gen_Ctrl_Actions_For_Aggr; + + function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result; + -- If default expression of a component mentions a discriminant of the + -- type, it must be rewritten as the discriminant of the target object. + + function Replace_Type (Expr : Node_Id) return Traverse_Result; + -- If the aggregate contains a self-reference, traverse each expression + -- to replace a possible self-reference with a reference to the proper + -- component of the target of the assignment. + + -------------------------- + -- Rewrite_Discriminant -- + -------------------------- + + function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result is + begin + if Is_Entity_Name (Expr) + and then Present (Entity (Expr)) + and then Ekind (Entity (Expr)) = E_In_Parameter + and then Present (Discriminal_Link (Entity (Expr))) + and then Scope (Discriminal_Link (Entity (Expr))) + = Base_Type (Etype (N)) + then + Rewrite (Expr, + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Lhs), + Selector_Name => Make_Identifier (Loc, Chars (Expr)))); + end if; + return OK; + end Rewrite_Discriminant; + + ------------------ + -- Replace_Type -- + ------------------ + + function Replace_Type (Expr : Node_Id) return Traverse_Result is + begin + -- Note regarding the Root_Type test below: Aggregate components for + -- self-referential types include attribute references to the current + -- instance, of the form: Typ'access, etc.. These references are + -- rewritten as references to the target of the aggregate: the + -- left-hand side of an assignment, the entity in a declaration, + -- or a temporary. Without this test, we would improperly extended + -- this rewriting to attribute references whose prefix was not the + -- type of the aggregate. + + if Nkind (Expr) = N_Attribute_Reference + and then Is_Entity_Name (Prefix (Expr)) + and then Is_Type (Entity (Prefix (Expr))) + and then Root_Type (Etype (N)) = Root_Type (Entity (Prefix (Expr))) + then + if Is_Entity_Name (Lhs) then + Rewrite (Prefix (Expr), + New_Occurrence_Of (Entity (Lhs), Loc)); + + elsif Nkind (Lhs) = N_Selected_Component then + Rewrite (Expr, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Unrestricted_Access, + Prefix => New_Copy_Tree (Prefix (Lhs)))); + Set_Analyzed (Parent (Expr), False); + + else + Rewrite (Expr, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Unrestricted_Access, + Prefix => New_Copy_Tree (Lhs))); + Set_Analyzed (Parent (Expr), False); + end if; + end if; + + return OK; + end Replace_Type; + + procedure Replace_Self_Reference is + new Traverse_Proc (Replace_Type); + + procedure Replace_Discriminants is + new Traverse_Proc (Rewrite_Discriminant); + + -- Start of processing for Build_Record_Aggr_Code + + begin + if Has_Self_Reference (N) then + Replace_Self_Reference (N); + end if; + + -- If the target of the aggregate is class-wide, we must convert it + -- to the actual type of the aggregate, so that the proper components + -- are visible. We know already that the types are compatible. + + if Present (Etype (Lhs)) + and then Is_Class_Wide_Type (Etype (Lhs)) + then + Target := Unchecked_Convert_To (Typ, Lhs); + else + Target := Lhs; + end if; + + -- Deal with the ancestor part of extension aggregates or with the + -- discriminants of the root type. + + if Nkind (N) = N_Extension_Aggregate then + declare + A : constant Node_Id := Ancestor_Part (N); + Assign : List_Id; + + begin + -- If the ancestor part is a subtype mark "T", we generate + + -- init-proc (T(tmp)); if T is constrained and + -- init-proc (S(tmp)); where S applies an appropriate + -- constraint if T is unconstrained + + if Is_Entity_Name (A) and then Is_Type (Entity (A)) then + Ancestor_Is_Subtype_Mark := True; + + if Is_Constrained (Entity (A)) then + Init_Typ := Entity (A); + + -- For an ancestor part given by an unconstrained type mark, + -- create a subtype constrained by appropriate corresponding + -- discriminant values coming from either associations of the + -- aggregate or a constraint on a parent type. The subtype will + -- be used to generate the correct default value for the + -- ancestor part. + + elsif Has_Discriminants (Entity (A)) then + declare + Anc_Typ : constant Entity_Id := Entity (A); + Anc_Constr : constant List_Id := New_List; + Discrim : Entity_Id; + Disc_Value : Node_Id; + New_Indic : Node_Id; + Subt_Decl : Node_Id; + + begin + Discrim := First_Discriminant (Anc_Typ); + while Present (Discrim) loop + Disc_Value := Ancestor_Discriminant_Value (Discrim); + Append_To (Anc_Constr, Disc_Value); + Next_Discriminant (Discrim); + end loop; + + New_Indic := + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Anc_Typ, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Anc_Constr)); + + Init_Typ := Create_Itype (Ekind (Anc_Typ), N); + + Subt_Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Init_Typ, + Subtype_Indication => New_Indic); + + -- Itypes must be analyzed with checks off Declaration + -- must have a parent for proper handling of subsidiary + -- actions. + + Set_Parent (Subt_Decl, N); + Analyze (Subt_Decl, Suppress => All_Checks); + end; + end if; + + Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); + Set_Assignment_OK (Ref); + + if not Is_Interface (Init_Typ) then + Append_List_To (L, + Build_Initialization_Call (Loc, + Id_Ref => Ref, + Typ => Init_Typ, + In_Init_Proc => Within_Init_Proc, + With_Default_Init => Has_Default_Init_Comps (N) + or else + Has_Task (Base_Type (Init_Typ)))); + + if Is_Constrained (Entity (A)) + and then Has_Discriminants (Entity (A)) + then + Check_Ancestor_Discriminants (Entity (A)); + end if; + end if; + + -- Handle calls to C++ constructors + + elsif Is_CPP_Constructor_Call (A) then + Init_Typ := Etype (A); + Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); + Set_Assignment_OK (Ref); + + Append_List_To (L, + Build_Initialization_Call (Loc, + Id_Ref => Ref, + Typ => Init_Typ, + In_Init_Proc => Within_Init_Proc, + With_Default_Init => Has_Default_Init_Comps (N), + Constructor_Ref => A)); + + -- Ada 2005 (AI-287): If the ancestor part is an aggregate of + -- limited type, a recursive call expands the ancestor. Note that + -- in the limited case, the ancestor part must be either a + -- function call (possibly qualified, or wrapped in an unchecked + -- conversion) or aggregate (definitely qualified). + -- The ancestor part can also be a function call (that may be + -- transformed into an explicit dereference) or a qualification + -- of one such. + + elsif Is_Limited_Type (Etype (A)) + and then Nkind_In (Unqualify (A), N_Aggregate, + N_Extension_Aggregate) + then + Ancestor_Is_Expression := True; + + -- Set up finalization data for enclosing record, because + -- controlled subcomponents of the ancestor part will be + -- attached to it. + + Gen_Ctrl_Actions_For_Aggr; + + Append_List_To (L, + Build_Record_Aggr_Code ( + N => Unqualify (A), + Typ => Etype (Unqualify (A)), + Lhs => Target, + Flist => Flist, + Obj => Obj, + Is_Limited_Ancestor_Expansion => True)); + + -- If the ancestor part is an expression "E", we generate + + -- T(tmp) := E; + + -- In Ada 2005, this includes the case of a (possibly qualified) + -- limited function call. The assignment will turn into a + -- build-in-place function call (for further details, see + -- Make_Build_In_Place_Call_In_Assignment). + + else + Ancestor_Is_Expression := True; + Init_Typ := Etype (A); + + -- If the ancestor part is an aggregate, force its full + -- expansion, which was delayed. + + if Nkind_In (Unqualify (A), N_Aggregate, + N_Extension_Aggregate) + then + Set_Analyzed (A, False); + Set_Analyzed (Expression (A), False); + end if; + + Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); + Set_Assignment_OK (Ref); + + -- Make the assignment without usual controlled actions since + -- we only want the post adjust but not the pre finalize here + -- Add manual adjust when necessary. + + Assign := New_List ( + Make_OK_Assignment_Statement (Loc, + Name => Ref, + Expression => A)); + Set_No_Ctrl_Actions (First (Assign)); + + -- Assign the tag now to make sure that the dispatching call in + -- the subsequent deep_adjust works properly (unless VM_Target, + -- where tags are implicit). + + if Tagged_Type_Expansion then + Instr := + Make_OK_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Reference_To + (First_Tag_Component (Base_Type (Typ)), Loc)), + + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node (First_Elmt + (Access_Disp_Table (Base_Type (Typ)))), + Loc))); + + Set_Assignment_OK (Name (Instr)); + Append_To (Assign, Instr); + + -- Ada 2005 (AI-251): If tagged type has progenitors we must + -- also initialize tags of the secondary dispatch tables. + + if Has_Interfaces (Base_Type (Typ)) then + Init_Secondary_Tags + (Typ => Base_Type (Typ), + Target => Target, + Stmts_List => Assign); + end if; + end if; + + -- Call Adjust manually + + if Needs_Finalization (Etype (A)) + and then not Is_Limited_Type (Etype (A)) + then + Append_List_To (Assign, + Make_Adjust_Call ( + Ref => New_Copy_Tree (Ref), + Typ => Etype (A), + Flist_Ref => New_Reference_To ( + RTE (RE_Global_Final_List), Loc), + With_Attach => Make_Integer_Literal (Loc, 0))); + end if; + + Append_To (L, + Make_Unsuppress_Block (Loc, Name_Discriminant_Check, Assign)); + + if Has_Discriminants (Init_Typ) then + Check_Ancestor_Discriminants (Init_Typ); + end if; + end if; + end; + + -- Normal case (not an extension aggregate) + + else + -- Generate the discriminant expressions, component by component. + -- If the base type is an unchecked union, the discriminants are + -- unknown to the back-end and absent from a value of the type, so + -- assignments for them are not emitted. + + if Has_Discriminants (Typ) + and then not Is_Unchecked_Union (Base_Type (Typ)) + then + -- If the type is derived, and constrains discriminants of the + -- parent type, these discriminants are not components of the + -- aggregate, and must be initialized explicitly. They are not + -- visible components of the object, but can become visible with + -- a view conversion to the ancestor. + + declare + Btype : Entity_Id; + Parent_Type : Entity_Id; + Disc : Entity_Id; + Discr_Val : Elmt_Id; + + begin + Btype := Base_Type (Typ); + while Is_Derived_Type (Btype) + and then Present (Stored_Constraint (Btype)) + loop + Parent_Type := Etype (Btype); + + Disc := First_Discriminant (Parent_Type); + Discr_Val := + First_Elmt (Stored_Constraint (Base_Type (Typ))); + while Present (Discr_Val) loop + + -- Only those discriminants of the parent that are not + -- renamed by discriminants of the derived type need to + -- be added explicitly. + + if not Is_Entity_Name (Node (Discr_Val)) + or else + Ekind (Entity (Node (Discr_Val))) /= E_Discriminant + then + Comp_Expr := + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Occurrence_Of (Disc, Loc)); + + Instr := + Make_OK_Assignment_Statement (Loc, + Name => Comp_Expr, + Expression => New_Copy_Tree (Node (Discr_Val))); + + Set_No_Ctrl_Actions (Instr); + Append_To (L, Instr); + end if; + + Next_Discriminant (Disc); + Next_Elmt (Discr_Val); + end loop; + + Btype := Base_Type (Parent_Type); + end loop; + end; + + -- Generate discriminant init values for the visible discriminants + + declare + Discriminant : Entity_Id; + Discriminant_Value : Node_Id; + + begin + Discriminant := First_Stored_Discriminant (Typ); + while Present (Discriminant) loop + Comp_Expr := + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Occurrence_Of (Discriminant, Loc)); + + Discriminant_Value := + Get_Discriminant_Value ( + Discriminant, + N_Typ, + Discriminant_Constraint (N_Typ)); + + Instr := + Make_OK_Assignment_Statement (Loc, + Name => Comp_Expr, + Expression => New_Copy_Tree (Discriminant_Value)); + + Set_No_Ctrl_Actions (Instr); + Append_To (L, Instr); + + Next_Stored_Discriminant (Discriminant); + end loop; + end; + end if; + end if; + + -- For CPP types we generate an implicit call to the C++ default + -- constructor to ensure the proper initialization of the _Tag + -- component. + + if Is_CPP_Class (Root_Type (Typ)) + and then CPP_Num_Prims (Typ) > 0 + then + Invoke_Constructor : declare + CPP_Parent : constant Entity_Id := + Enclosing_CPP_Parent (Typ); + + procedure Invoke_IC_Proc (T : Entity_Id); + -- Recursive routine used to climb to parents. Required because + -- parents must be initialized before descendants to ensure + -- propagation of inherited C++ slots. + + -------------------- + -- Invoke_IC_Proc -- + -------------------- + + procedure Invoke_IC_Proc (T : Entity_Id) is + begin + -- Avoid generating extra calls. Initialization required + -- only for types defined from the level of derivation of + -- type of the constructor and the type of the aggregate. + + if T = CPP_Parent then + return; + end if; + + Invoke_IC_Proc (Etype (T)); + + -- Generate call to the IC routine + + if Present (CPP_Init_Proc (T)) then + Append_To (L, + Make_Procedure_Call_Statement (Loc, + New_Reference_To (CPP_Init_Proc (T), Loc))); + end if; + end Invoke_IC_Proc; + + -- Start of processing for Invoke_Constructor + + begin + -- Implicit invocation of the C++ constructor + + if Nkind (N) = N_Aggregate then + Append_To (L, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To + (Base_Init_Proc (CPP_Parent), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (CPP_Parent, + New_Copy_Tree (Lhs))))); + end if; + + Invoke_IC_Proc (Typ); + end Invoke_Constructor; + end if; + + -- Generate the assignments, component by component + + -- tmp.comp1 := Expr1_From_Aggr; + -- tmp.comp2 := Expr2_From_Aggr; + -- .... + + Comp := First (Component_Associations (N)); + while Present (Comp) loop + Selector := Entity (First (Choices (Comp))); + + -- C++ constructors + + if Is_CPP_Constructor_Call (Expression (Comp)) then + Append_List_To (L, + Build_Initialization_Call (Loc, + Id_Ref => Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Occurrence_Of (Selector, Loc)), + Typ => Etype (Selector), + Enclos_Type => Typ, + With_Default_Init => True, + Constructor_Ref => Expression (Comp))); + + -- Ada 2005 (AI-287): For each default-initialized component generate + -- a call to the corresponding IP subprogram if available. + + elsif Box_Present (Comp) + and then Has_Non_Null_Base_Init_Proc (Etype (Selector)) + then + if Ekind (Selector) /= E_Discriminant then + Gen_Ctrl_Actions_For_Aggr; + end if; + + -- Ada 2005 (AI-287): If the component type has tasks then + -- generate the activation chain and master entities (except + -- in case of an allocator because in that case these entities + -- are generated by Build_Task_Allocate_Block_With_Init_Stmts). + + declare + Ctype : constant Entity_Id := Etype (Selector); + Inside_Allocator : Boolean := False; + P : Node_Id := Parent (N); + + begin + if Is_Task_Type (Ctype) or else Has_Task (Ctype) then + while Present (P) loop + if Nkind (P) = N_Allocator then + Inside_Allocator := True; + exit; + end if; + + P := Parent (P); + end loop; + + if not Inside_Init_Proc and not Inside_Allocator then + Build_Activation_Chain_Entity (N); + end if; + end if; + end; + + Append_List_To (L, + Build_Initialization_Call (Loc, + Id_Ref => Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Occurrence_Of (Selector, Loc)), + Typ => Etype (Selector), + Enclos_Type => Typ, + With_Default_Init => True)); + + -- Prepare for component assignment + + elsif Ekind (Selector) /= E_Discriminant + or else Nkind (N) = N_Extension_Aggregate + then + -- All the discriminants have now been assigned + + -- This is now a good moment to initialize and attach all the + -- controllers. Their position may depend on the discriminants. + + if Ekind (Selector) /= E_Discriminant then + Gen_Ctrl_Actions_For_Aggr; + end if; + + Comp_Type := Etype (Selector); + Comp_Expr := + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Occurrence_Of (Selector, Loc)); + + if Nkind (Expression (Comp)) = N_Qualified_Expression then + Expr_Q := Expression (Expression (Comp)); + else + Expr_Q := Expression (Comp); + end if; + + -- The controller is the one of the parent type defining the + -- component (in case of inherited components). + + if Needs_Finalization (Comp_Type) then + Internal_Final_List := + Make_Selected_Component (Loc, + Prefix => Convert_To + (Scope (Original_Record_Component (Selector)), + New_Copy_Tree (Target)), + Selector_Name => Make_Identifier (Loc, Name_uController)); + + Internal_Final_List := + Make_Selected_Component (Loc, + Prefix => Internal_Final_List, + Selector_Name => Make_Identifier (Loc, Name_F)); + + -- The internal final list can be part of a constant object + + Set_Assignment_OK (Internal_Final_List); + + else + Internal_Final_List := Empty; + end if; + + -- Now either create the assignment or generate the code for the + -- inner aggregate top-down. + + if Is_Delayed_Aggregate (Expr_Q) then + + -- We have the following case of aggregate nesting inside + -- an object declaration: + + -- type Arr_Typ is array (Integer range <>) of ...; + + -- type Rec_Typ (...) is record + -- Obj_Arr_Typ : Arr_Typ (A .. B); + -- end record; + + -- Obj_Rec_Typ : Rec_Typ := (..., + -- Obj_Arr_Typ => (X => (...), Y => (...))); + + -- The length of the ranges of the aggregate and Obj_Add_Typ + -- are equal (B - A = Y - X), but they do not coincide (X /= + -- A and B /= Y). This case requires array sliding which is + -- performed in the following manner: + + -- subtype Arr_Sub is Arr_Typ (X .. Y); + -- Temp : Arr_Sub; + -- Temp (X) := (...); + -- ... + -- Temp (Y) := (...); + -- Obj_Rec_Typ.Obj_Arr_Typ := Temp; + + if Ekind (Comp_Type) = E_Array_Subtype + and then Is_Int_Range_Bounds (Aggregate_Bounds (Expr_Q)) + and then Is_Int_Range_Bounds (First_Index (Comp_Type)) + and then not + Compatible_Int_Bounds + (Agg_Bounds => Aggregate_Bounds (Expr_Q), + Typ_Bounds => First_Index (Comp_Type)) + then + -- Create the array subtype with bounds equal to those of + -- the corresponding aggregate. + + declare + SubE : constant Entity_Id := Make_Temporary (Loc, 'T'); + + SubD : constant Node_Id := + Make_Subtype_Declaration (Loc, + Defining_Identifier => SubE, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To + (Etype (Comp_Type), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint + (Loc, + Constraints => New_List ( + New_Copy_Tree + (Aggregate_Bounds (Expr_Q)))))); + + -- Create a temporary array of the above subtype which + -- will be used to capture the aggregate assignments. + + TmpE : constant Entity_Id := Make_Temporary (Loc, 'A', N); + + TmpD : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => TmpE, + Object_Definition => + New_Reference_To (SubE, Loc)); + + begin + Set_No_Initialization (TmpD); + Append_To (L, SubD); + Append_To (L, TmpD); + + -- Expand aggregate into assignments to the temp array + + Append_List_To (L, + Late_Expansion (Expr_Q, Comp_Type, + New_Reference_To (TmpE, Loc), Internal_Final_List)); + + -- Slide + + Append_To (L, + Make_Assignment_Statement (Loc, + Name => New_Copy_Tree (Comp_Expr), + Expression => New_Reference_To (TmpE, Loc))); + + -- Do not pass the original aggregate to Gigi as is, + -- since it will potentially clobber the front or the end + -- of the array. Setting the expression to empty is safe + -- since all aggregates are expanded into assignments. + + if Present (Obj) then + Set_Expression (Parent (Obj), Empty); + end if; + end; + + -- Normal case (sliding not required) + + else + Append_List_To (L, + Late_Expansion (Expr_Q, Comp_Type, Comp_Expr, + Internal_Final_List)); + end if; + + -- Expr_Q is not delayed aggregate + + else + if Has_Discriminants (Typ) then + Replace_Discriminants (Expr_Q); + end if; + + Instr := + Make_OK_Assignment_Statement (Loc, + Name => Comp_Expr, + Expression => Expr_Q); + + Set_No_Ctrl_Actions (Instr); + Append_To (L, Instr); + + -- Adjust the tag if tagged (because of possible view + -- conversions), unless compiling for a VM where tags are + -- implicit. + + -- tmp.comp._tag := comp_typ'tag; + + if Is_Tagged_Type (Comp_Type) + and then Tagged_Type_Expansion + then + Instr := + Make_OK_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Comp_Expr), + Selector_Name => + New_Reference_To + (First_Tag_Component (Comp_Type), Loc)), + + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Comp_Type))), + Loc))); + + Append_To (L, Instr); + end if; + + -- Adjust and Attach the component to the proper controller + + -- Adjust (tmp.comp); + -- Attach_To_Final_List (tmp.comp, + -- comp_typ (tmp)._record_controller.f) + + if Needs_Finalization (Comp_Type) + and then not Is_Limited_Type (Comp_Type) + then + Append_List_To (L, + Make_Adjust_Call ( + Ref => New_Copy_Tree (Comp_Expr), + Typ => Comp_Type, + Flist_Ref => Internal_Final_List, + With_Attach => Make_Integer_Literal (Loc, 1))); + end if; + end if; + + -- ??? + + elsif Ekind (Selector) = E_Discriminant + and then Nkind (N) /= N_Extension_Aggregate + and then Nkind (Parent (N)) = N_Component_Association + and then Is_Constrained (Typ) + then + -- We must check that the discriminant value imposed by the + -- context is the same as the value given in the subaggregate, + -- because after the expansion into assignments there is no + -- record on which to perform a regular discriminant check. + + declare + D_Val : Elmt_Id; + Disc : Entity_Id; + + begin + D_Val := First_Elmt (Discriminant_Constraint (Typ)); + Disc := First_Discriminant (Typ); + while Chars (Disc) /= Chars (Selector) loop + Next_Discriminant (Disc); + Next_Elmt (D_Val); + end loop; + + pragma Assert (Present (D_Val)); + + -- This check cannot performed for components that are + -- constrained by a current instance, because this is not a + -- value that can be compared with the actual constraint. + + if Nkind (Node (D_Val)) /= N_Attribute_Reference + or else not Is_Entity_Name (Prefix (Node (D_Val))) + or else not Is_Type (Entity (Prefix (Node (D_Val)))) + then + Append_To (L, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Copy_Tree (Node (D_Val)), + Right_Opnd => Expression (Comp)), + Reason => CE_Discriminant_Check_Failed)); + + else + -- Find self-reference in previous discriminant assignment, + -- and replace with proper expression. + + declare + Ass : Node_Id; + + begin + Ass := First (L); + while Present (Ass) loop + if Nkind (Ass) = N_Assignment_Statement + and then Nkind (Name (Ass)) = N_Selected_Component + and then Chars (Selector_Name (Name (Ass))) = + Chars (Disc) + then + Set_Expression + (Ass, New_Copy_Tree (Expression (Comp))); + exit; + end if; + Next (Ass); + end loop; + end; + end if; + end; + end if; + + Next (Comp); + end loop; + + -- If the type is tagged, the tag needs to be initialized (unless + -- compiling for the Java VM where tags are implicit). It is done + -- late in the initialization process because in some cases, we call + -- the init proc of an ancestor which will not leave out the right tag + + if Ancestor_Is_Expression then + null; + + -- For CPP types we generated a call to the C++ default constructor + -- before the components have been initialized to ensure the proper + -- initialization of the _Tag component (see above). + + elsif Is_CPP_Class (Typ) then + null; + + elsif Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then + Instr := + Make_OK_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Reference_To + (First_Tag_Component (Base_Type (Typ)), Loc)), + + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Base_Type (Typ)))), + Loc))); + + Append_To (L, Instr); + + -- Ada 2005 (AI-251): If the tagged type has been derived from + -- abstract interfaces we must also initialize the tags of the + -- secondary dispatch tables. + + if Has_Interfaces (Base_Type (Typ)) then + Init_Secondary_Tags + (Typ => Base_Type (Typ), + Target => Target, + Stmts_List => L); + end if; + end if; + + -- If the controllers have not been initialized yet (by lack of non- + -- discriminant components), let's do it now. + + Gen_Ctrl_Actions_For_Aggr; + + return L; + end Build_Record_Aggr_Code; + + ------------------------------- + -- Convert_Aggr_In_Allocator -- + ------------------------------- + + procedure Convert_Aggr_In_Allocator + (Alloc : Node_Id; + Decl : Node_Id; + Aggr : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Aggr); + Typ : constant Entity_Id := Etype (Aggr); + Temp : constant Entity_Id := Defining_Identifier (Decl); + + Occ : constant Node_Id := + Unchecked_Convert_To (Typ, + Make_Explicit_Dereference (Loc, + New_Reference_To (Temp, Loc))); + + Access_Type : constant Entity_Id := Etype (Temp); + Flist : Entity_Id; + + begin + -- If the allocator is for an access discriminant, there is no + -- finalization list for the anonymous access type, and the eventual + -- finalization of the object is handled through the coextension + -- mechanism. If the enclosing object is not dynamically allocated, + -- the access discriminant is itself placed on the stack. Otherwise, + -- some other finalization list is used (see exp_ch4.adb). + + -- Decl has been inserted in the code ahead of the allocator, using + -- Insert_Actions. We use Insert_Actions below as well, to ensure that + -- subsequent insertions are done in the proper order. Using (for + -- example) Insert_Actions_After to place the expanded aggregate + -- immediately after Decl may lead to out-of-order references if the + -- allocator has generated a finalization list, as when the designated + -- object is controlled and there is an open transient scope. + + if Ekind (Access_Type) = E_Anonymous_Access_Type + and then Nkind (Associated_Node_For_Itype (Access_Type)) = + N_Discriminant_Specification + then + Flist := Empty; + + elsif Needs_Finalization (Typ) then + Flist := Find_Final_List (Access_Type); + + -- Otherwise there are no controlled actions to be performed. + + else + Flist := Empty; + end if; + + if Is_Array_Type (Typ) then + Convert_Array_Aggr_In_Allocator (Decl, Aggr, Occ); + + elsif Has_Default_Init_Comps (Aggr) then + declare + L : constant List_Id := New_List; + Init_Stmts : List_Id; + + begin + Init_Stmts := + Late_Expansion + (Aggr, Typ, Occ, + Flist, + Associated_Final_Chain (Base_Type (Access_Type))); + + -- ??? Dubious actual for Obj: expect 'the original object being + -- initialized' + + if Has_Task (Typ) then + Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts); + Insert_Actions (Alloc, L); + else + Insert_Actions (Alloc, Init_Stmts); + end if; + end; + + else + Insert_Actions (Alloc, + Late_Expansion + (Aggr, Typ, Occ, Flist, + Associated_Final_Chain (Base_Type (Access_Type)))); + + -- ??? Dubious actual for Obj: expect 'the original object being + -- initialized' + + end if; + end Convert_Aggr_In_Allocator; + + -------------------------------- + -- Convert_Aggr_In_Assignment -- + -------------------------------- + + procedure Convert_Aggr_In_Assignment (N : Node_Id) is + Aggr : Node_Id := Expression (N); + Typ : constant Entity_Id := Etype (Aggr); + Occ : constant Node_Id := New_Copy_Tree (Name (N)); + + begin + if Nkind (Aggr) = N_Qualified_Expression then + Aggr := Expression (Aggr); + end if; + + Insert_Actions_After (N, + Late_Expansion + (Aggr, Typ, Occ, + Find_Final_List (Typ, New_Copy_Tree (Occ)))); + end Convert_Aggr_In_Assignment; + + --------------------------------- + -- Convert_Aggr_In_Object_Decl -- + --------------------------------- + + procedure Convert_Aggr_In_Object_Decl (N : Node_Id) is + Obj : constant Entity_Id := Defining_Identifier (N); + Aggr : Node_Id := Expression (N); + Loc : constant Source_Ptr := Sloc (Aggr); + Typ : constant Entity_Id := Etype (Aggr); + Occ : constant Node_Id := New_Occurrence_Of (Obj, Loc); + + function Discriminants_Ok return Boolean; + -- If the object type is constrained, the discriminants in the + -- aggregate must be checked against the discriminants of the subtype. + -- This cannot be done using Apply_Discriminant_Checks because after + -- expansion there is no aggregate left to check. + + ---------------------- + -- Discriminants_Ok -- + ---------------------- + + function Discriminants_Ok return Boolean is + Cond : Node_Id := Empty; + Check : Node_Id; + D : Entity_Id; + Disc1 : Elmt_Id; + Disc2 : Elmt_Id; + Val1 : Node_Id; + Val2 : Node_Id; + + begin + D := First_Discriminant (Typ); + Disc1 := First_Elmt (Discriminant_Constraint (Typ)); + Disc2 := First_Elmt (Discriminant_Constraint (Etype (Obj))); + while Present (Disc1) and then Present (Disc2) loop + Val1 := Node (Disc1); + Val2 := Node (Disc2); + + if not Is_OK_Static_Expression (Val1) + or else not Is_OK_Static_Expression (Val2) + then + Check := Make_Op_Ne (Loc, + Left_Opnd => Duplicate_Subexpr (Val1), + Right_Opnd => Duplicate_Subexpr (Val2)); + + if No (Cond) then + Cond := Check; + + else + Cond := Make_Or_Else (Loc, + Left_Opnd => Cond, + Right_Opnd => Check); + end if; + + elsif Expr_Value (Val1) /= Expr_Value (Val2) then + Apply_Compile_Time_Constraint_Error (Aggr, + Msg => "incorrect value for discriminant&?", + Reason => CE_Discriminant_Check_Failed, + Ent => D); + return False; + end if; + + Next_Discriminant (D); + Next_Elmt (Disc1); + Next_Elmt (Disc2); + end loop; + + -- If any discriminant constraint is non-static, emit a check + + if Present (Cond) then + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => Cond, + Reason => CE_Discriminant_Check_Failed)); + end if; + + return True; + end Discriminants_Ok; + + -- Start of processing for Convert_Aggr_In_Object_Decl + + begin + Set_Assignment_OK (Occ); + + if Nkind (Aggr) = N_Qualified_Expression then + Aggr := Expression (Aggr); + end if; + + if Has_Discriminants (Typ) + and then Typ /= Etype (Obj) + and then Is_Constrained (Etype (Obj)) + and then not Discriminants_Ok + then + return; + end if; + + -- If the context is an extended return statement, it has its own + -- finalization machinery (i.e. works like a transient scope) and + -- we do not want to create an additional one, because objects on + -- the finalization list of the return must be moved to the caller's + -- finalization list to complete the return. + + -- However, if the aggregate is limited, it is built in place, and the + -- controlled components are not assigned to intermediate temporaries + -- so there is no need for a transient scope in this case either. + + if Requires_Transient_Scope (Typ) + and then Ekind (Current_Scope) /= E_Return_Statement + and then not Is_Limited_Type (Typ) + then + Establish_Transient_Scope + (Aggr, + Sec_Stack => + Is_Controlled (Typ) or else Has_Controlled_Component (Typ)); + end if; + + Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ, Obj => Obj)); + Set_No_Initialization (N); + Initialize_Discriminants (N, Typ); + end Convert_Aggr_In_Object_Decl; + + ------------------------------------- + -- Convert_Array_Aggr_In_Allocator -- + ------------------------------------- + + procedure Convert_Array_Aggr_In_Allocator + (Decl : Node_Id; + Aggr : Node_Id; + Target : Node_Id) + is + Aggr_Code : List_Id; + Typ : constant Entity_Id := Etype (Aggr); + Ctyp : constant Entity_Id := Component_Type (Typ); + + begin + -- The target is an explicit dereference of the allocated object. + -- Generate component assignments to it, as for an aggregate that + -- appears on the right-hand side of an assignment statement. + + Aggr_Code := + Build_Array_Aggr_Code (Aggr, + Ctype => Ctyp, + Index => First_Index (Typ), + Into => Target, + Scalar_Comp => Is_Scalar_Type (Ctyp)); + + Insert_Actions_After (Decl, Aggr_Code); + end Convert_Array_Aggr_In_Allocator; + + ---------------------------- + -- Convert_To_Assignments -- + ---------------------------- + + procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + T : Entity_Id; + Temp : Entity_Id; + + Instr : Node_Id; + Target_Expr : Node_Id; + Parent_Kind : Node_Kind; + Unc_Decl : Boolean := False; + Parent_Node : Node_Id; + + begin + pragma Assert (not Is_Static_Dispatch_Table_Aggregate (N)); + pragma Assert (Is_Record_Type (Typ)); + + Parent_Node := Parent (N); + Parent_Kind := Nkind (Parent_Node); + + if Parent_Kind = N_Qualified_Expression then + + -- Check if we are in a unconstrained declaration because in this + -- case the current delayed expansion mechanism doesn't work when + -- the declared object size depend on the initializing expr. + + begin + Parent_Node := Parent (Parent_Node); + Parent_Kind := Nkind (Parent_Node); + + if Parent_Kind = N_Object_Declaration then + Unc_Decl := + not Is_Entity_Name (Object_Definition (Parent_Node)) + or else Has_Discriminants + (Entity (Object_Definition (Parent_Node))) + or else Is_Class_Wide_Type + (Entity (Object_Definition (Parent_Node))); + end if; + end; + end if; + + -- Just set the Delay flag in the cases where the transformation will be + -- done top down from above. + + if False + + -- Internal aggregate (transformed when expanding the parent) + + or else Parent_Kind = N_Aggregate + or else Parent_Kind = N_Extension_Aggregate + or else Parent_Kind = N_Component_Association + + -- Allocator (see Convert_Aggr_In_Allocator) + + or else Parent_Kind = N_Allocator + + -- Object declaration (see Convert_Aggr_In_Object_Decl) + + or else (Parent_Kind = N_Object_Declaration and then not Unc_Decl) + + -- Safe assignment (see Convert_Aggr_Assignments). So far only the + -- assignments in init procs are taken into account. + + or else (Parent_Kind = N_Assignment_Statement + and then Inside_Init_Proc) + + -- (Ada 2005) An inherently limited type in a return statement, + -- which will be handled in a build-in-place fashion, and may be + -- rewritten as an extended return and have its own finalization + -- machinery. In the case of a simple return, the aggregate needs + -- to be delayed until the scope for the return statement has been + -- created, so that any finalization chain will be associated with + -- that scope. For extended returns, we delay expansion to avoid the + -- creation of an unwanted transient scope that could result in + -- premature finalization of the return object (which is built in + -- in place within the caller's scope). + + or else + (Is_Immutably_Limited_Type (Typ) + and then + (Nkind (Parent (Parent_Node)) = N_Extended_Return_Statement + or else Nkind (Parent_Node) = N_Simple_Return_Statement)) + then + Set_Expansion_Delayed (N); + return; + end if; + + if Requires_Transient_Scope (Typ) then + Establish_Transient_Scope + (N, Sec_Stack => + Is_Controlled (Typ) or else Has_Controlled_Component (Typ)); + end if; + + -- If the aggregate is non-limited, create a temporary. If it is limited + -- and the context is an assignment, this is a subaggregate for an + -- enclosing aggregate being expanded. It must be built in place, so use + -- the target of the current assignment. + + if Is_Limited_Type (Typ) + and then Nkind (Parent (N)) = N_Assignment_Statement + then + Target_Expr := New_Copy_Tree (Name (Parent (N))); + Insert_Actions + (Parent (N), Build_Record_Aggr_Code (N, Typ, Target_Expr)); + Rewrite (Parent (N), Make_Null_Statement (Loc)); + + else + Temp := Make_Temporary (Loc, 'A', N); + + -- If the type inherits unknown discriminants, use the view with + -- known discriminants if available. + + if Has_Unknown_Discriminants (Typ) + and then Present (Underlying_Record_View (Typ)) + then + T := Underlying_Record_View (Typ); + else + T := Typ; + end if; + + Instr := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Occurrence_Of (T, Loc)); + + Set_No_Initialization (Instr); + Insert_Action (N, Instr); + Initialize_Discriminants (Instr, T); + Target_Expr := New_Occurrence_Of (Temp, Loc); + Insert_Actions (N, Build_Record_Aggr_Code (N, T, Target_Expr)); + Rewrite (N, New_Occurrence_Of (Temp, Loc)); + Analyze_And_Resolve (N, T); + end if; + end Convert_To_Assignments; + + --------------------------- + -- Convert_To_Positional -- + --------------------------- + + procedure Convert_To_Positional + (N : Node_Id; + Max_Others_Replicate : Nat := 5; + Handle_Bit_Packed : Boolean := False) + is + Typ : constant Entity_Id := Etype (N); + + Static_Components : Boolean := True; + + procedure Check_Static_Components; + -- Check whether all components of the aggregate are compile-time known + -- values, and can be passed as is to the back-end without further + -- expansion. + + function Flatten + (N : Node_Id; + Ix : Node_Id; + Ixb : Node_Id) return Boolean; + -- Convert the aggregate into a purely positional form if possible. On + -- entry the bounds of all dimensions are known to be static, and the + -- total number of components is safe enough to expand. + + function Is_Flat (N : Node_Id; Dims : Int) return Boolean; + -- Return True iff the array N is flat (which is not trivial in the case + -- of multidimensional aggregates). + + ----------------------------- + -- Check_Static_Components -- + ----------------------------- + + procedure Check_Static_Components is + Expr : Node_Id; + + begin + Static_Components := True; + + if Nkind (N) = N_String_Literal then + null; + + elsif Present (Expressions (N)) then + Expr := First (Expressions (N)); + while Present (Expr) loop + if Nkind (Expr) /= N_Aggregate + or else not Compile_Time_Known_Aggregate (Expr) + or else Expansion_Delayed (Expr) + then + Static_Components := False; + exit; + end if; + + Next (Expr); + end loop; + end if; + + if Nkind (N) = N_Aggregate + and then Present (Component_Associations (N)) + then + Expr := First (Component_Associations (N)); + while Present (Expr) loop + if Nkind_In (Expression (Expr), N_Integer_Literal, + N_Real_Literal) + then + null; + + elsif Is_Entity_Name (Expression (Expr)) + and then Present (Entity (Expression (Expr))) + and then Ekind (Entity (Expression (Expr))) = + E_Enumeration_Literal + then + null; + + elsif Nkind (Expression (Expr)) /= N_Aggregate + or else not Compile_Time_Known_Aggregate (Expression (Expr)) + or else Expansion_Delayed (Expression (Expr)) + then + Static_Components := False; + exit; + end if; + + Next (Expr); + end loop; + end if; + end Check_Static_Components; + + ------------- + -- Flatten -- + ------------- + + function Flatten + (N : Node_Id; + Ix : Node_Id; + Ixb : Node_Id) return Boolean + is + Loc : constant Source_Ptr := Sloc (N); + Blo : constant Node_Id := Type_Low_Bound (Etype (Ixb)); + Lo : constant Node_Id := Type_Low_Bound (Etype (Ix)); + Hi : constant Node_Id := Type_High_Bound (Etype (Ix)); + Lov : Uint; + Hiv : Uint; + + begin + if Nkind (Original_Node (N)) = N_String_Literal then + return True; + end if; + + if not Compile_Time_Known_Value (Lo) + or else not Compile_Time_Known_Value (Hi) + then + return False; + end if; + + Lov := Expr_Value (Lo); + Hiv := Expr_Value (Hi); + + if Hiv < Lov + or else not Compile_Time_Known_Value (Blo) + then + return False; + end if; + + -- Determine if set of alternatives is suitable for conversion and + -- build an array containing the values in sequence. + + declare + Vals : array (UI_To_Int (Lov) .. UI_To_Int (Hiv)) + of Node_Id := (others => Empty); + -- The values in the aggregate sorted appropriately + + Vlist : List_Id; + -- Same data as Vals in list form + + Rep_Count : Nat; + -- Used to validate Max_Others_Replicate limit + + Elmt : Node_Id; + Num : Int := UI_To_Int (Lov); + Choice_Index : Int; + Choice : Node_Id; + Lo, Hi : Node_Id; + + begin + if Present (Expressions (N)) then + Elmt := First (Expressions (N)); + while Present (Elmt) loop + if Nkind (Elmt) = N_Aggregate + and then Present (Next_Index (Ix)) + and then + not Flatten (Elmt, Next_Index (Ix), Next_Index (Ixb)) + then + return False; + end if; + + Vals (Num) := Relocate_Node (Elmt); + Num := Num + 1; + + Next (Elmt); + end loop; + end if; + + if No (Component_Associations (N)) then + return True; + end if; + + Elmt := First (Component_Associations (N)); + + if Nkind (Expression (Elmt)) = N_Aggregate then + if Present (Next_Index (Ix)) + and then + not Flatten + (Expression (Elmt), Next_Index (Ix), Next_Index (Ixb)) + then + return False; + end if; + end if; + + Component_Loop : while Present (Elmt) loop + Choice := First (Choices (Elmt)); + Choice_Loop : while Present (Choice) loop + + -- If we have an others choice, fill in the missing elements + -- subject to the limit established by Max_Others_Replicate. + + if Nkind (Choice) = N_Others_Choice then + Rep_Count := 0; + + for J in Vals'Range loop + if No (Vals (J)) then + Vals (J) := New_Copy_Tree (Expression (Elmt)); + Rep_Count := Rep_Count + 1; + + -- Check for maximum others replication. Note that + -- we skip this test if either of the restrictions + -- No_Elaboration_Code or No_Implicit_Loops is + -- active, if this is a preelaborable unit or a + -- predefined unit. This ensures that predefined + -- units get the same level of constant folding in + -- Ada 95 and Ada 05, where their categorization + -- has changed. + + declare + P : constant Entity_Id := + Cunit_Entity (Current_Sem_Unit); + + begin + -- Check if duplication OK and if so continue + -- processing. + + if Restriction_Active (No_Elaboration_Code) + or else Restriction_Active (No_Implicit_Loops) + or else Is_Preelaborated (P) + or else (Ekind (P) = E_Package_Body + and then + Is_Preelaborated (Spec_Entity (P))) + or else + Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (P))) + then + null; + + -- If duplication not OK, then we return False + -- if the replication count is too high + + elsif Rep_Count > Max_Others_Replicate then + return False; + + -- Continue on if duplication not OK, but the + -- replication count is not excessive. + + else + null; + end if; + end; + end if; + end loop; + + exit Component_Loop; + + -- Case of a subtype mark, identifier or expanded name + + elsif Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + then + Lo := Type_Low_Bound (Etype (Choice)); + Hi := Type_High_Bound (Etype (Choice)); + + -- Case of subtype indication + + elsif Nkind (Choice) = N_Subtype_Indication then + Lo := Low_Bound (Range_Expression (Constraint (Choice))); + Hi := High_Bound (Range_Expression (Constraint (Choice))); + + -- Case of a range + + elsif Nkind (Choice) = N_Range then + Lo := Low_Bound (Choice); + Hi := High_Bound (Choice); + + -- Normal subexpression case + + else pragma Assert (Nkind (Choice) in N_Subexpr); + if not Compile_Time_Known_Value (Choice) then + return False; + + else + Choice_Index := UI_To_Int (Expr_Value (Choice)); + if Choice_Index in Vals'Range then + Vals (Choice_Index) := + New_Copy_Tree (Expression (Elmt)); + goto Continue; + + else + -- Choice is statically out-of-range, will be + -- rewritten to raise Constraint_Error. + + return False; + end if; + end if; + end if; + + -- Range cases merge with Lo,Hi set + + if not Compile_Time_Known_Value (Lo) + or else + not Compile_Time_Known_Value (Hi) + then + return False; + else + for J in UI_To_Int (Expr_Value (Lo)) .. + UI_To_Int (Expr_Value (Hi)) + loop + Vals (J) := New_Copy_Tree (Expression (Elmt)); + end loop; + end if; + + <> + Next (Choice); + end loop Choice_Loop; + + Next (Elmt); + end loop Component_Loop; + + -- If we get here the conversion is possible + + Vlist := New_List; + for J in Vals'Range loop + Append (Vals (J), Vlist); + end loop; + + Rewrite (N, Make_Aggregate (Loc, Expressions => Vlist)); + Set_Aggregate_Bounds (N, Aggregate_Bounds (Original_Node (N))); + return True; + end; + end Flatten; + + ------------- + -- Is_Flat -- + ------------- + + function Is_Flat (N : Node_Id; Dims : Int) return Boolean is + Elmt : Node_Id; + + begin + if Dims = 0 then + return True; + + elsif Nkind (N) = N_Aggregate then + if Present (Component_Associations (N)) then + return False; + + else + Elmt := First (Expressions (N)); + while Present (Elmt) loop + if not Is_Flat (Elmt, Dims - 1) then + return False; + end if; + + Next (Elmt); + end loop; + + return True; + end if; + else + return True; + end if; + end Is_Flat; + + -- Start of processing for Convert_To_Positional + + begin + -- Ada 2005 (AI-287): Do not convert in case of default initialized + -- components because in this case will need to call the corresponding + -- IP procedure. + + if Has_Default_Init_Comps (N) then + return; + end if; + + if Is_Flat (N, Number_Dimensions (Typ)) then + return; + end if; + + if Is_Bit_Packed_Array (Typ) + and then not Handle_Bit_Packed + then + return; + end if; + + -- Do not convert to positional if controlled components are involved + -- since these require special processing + + if Has_Controlled_Component (Typ) then + return; + end if; + + Check_Static_Components; + + -- If the size is known, or all the components are static, try to + -- build a fully positional aggregate. + + -- The size of the type may not be known for an aggregate with + -- discriminated array components, but if the components are static + -- it is still possible to verify statically that the length is + -- compatible with the upper bound of the type, and therefore it is + -- worth flattening such aggregates as well. + + -- For now the back-end expands these aggregates into individual + -- assignments to the target anyway, but it is conceivable that + -- it will eventually be able to treat such aggregates statically??? + + if Aggr_Size_OK (N, Typ) + and then Flatten (N, First_Index (Typ), First_Index (Base_Type (Typ))) + then + if Static_Components then + Set_Compile_Time_Known_Aggregate (N); + Set_Expansion_Delayed (N, False); + end if; + + Analyze_And_Resolve (N, Typ); + end if; + end Convert_To_Positional; + + ---------------------------- + -- Expand_Array_Aggregate -- + ---------------------------- + + -- Array aggregate expansion proceeds as follows: + + -- 1. If requested we generate code to perform all the array aggregate + -- bound checks, specifically + + -- (a) Check that the index range defined by aggregate bounds is + -- compatible with corresponding index subtype. + + -- (b) If an others choice is present check that no aggregate + -- index is outside the bounds of the index constraint. + + -- (c) For multidimensional arrays make sure that all subaggregates + -- corresponding to the same dimension have the same bounds. + + -- 2. Check for packed array aggregate which can be converted to a + -- constant so that the aggregate disappeares completely. + + -- 3. Check case of nested aggregate. Generally nested aggregates are + -- handled during the processing of the parent aggregate. + + -- 4. Check if the aggregate can be statically processed. If this is the + -- case pass it as is to Gigi. Note that a necessary condition for + -- static processing is that the aggregate be fully positional. + + -- 5. If in place aggregate expansion is possible (i.e. no need to create + -- a temporary) then mark the aggregate as such and return. Otherwise + -- create a new temporary and generate the appropriate initialization + -- code. + + procedure Expand_Array_Aggregate (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Typ : constant Entity_Id := Etype (N); + Ctyp : constant Entity_Id := Component_Type (Typ); + -- Typ is the correct constrained array subtype of the aggregate + -- Ctyp is the corresponding component type. + + Aggr_Dimension : constant Pos := Number_Dimensions (Typ); + -- Number of aggregate index dimensions + + Aggr_Low : array (1 .. Aggr_Dimension) of Node_Id; + Aggr_High : array (1 .. Aggr_Dimension) of Node_Id; + -- Low and High bounds of the constraint for each aggregate index + + Aggr_Index_Typ : array (1 .. Aggr_Dimension) of Entity_Id; + -- The type of each index + + Maybe_In_Place_OK : Boolean; + -- If the type is neither controlled nor packed and the aggregate + -- is the expression in an assignment, assignment in place may be + -- possible, provided other conditions are met on the LHS. + + Others_Present : array (1 .. Aggr_Dimension) of Boolean := + (others => False); + -- If Others_Present (J) is True, then there is an others choice + -- in one of the sub-aggregates of N at dimension J. + + procedure Build_Constrained_Type (Positional : Boolean); + -- If the subtype is not static or unconstrained, build a constrained + -- type using the computable sizes of the aggregate and its sub- + -- aggregates. + + procedure Check_Bounds (Aggr_Bounds : Node_Id; Index_Bounds : Node_Id); + -- Checks that the bounds of Aggr_Bounds are within the bounds defined + -- by Index_Bounds. + + procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos); + -- Checks that in a multi-dimensional array aggregate all subaggregates + -- corresponding to the same dimension have the same bounds. + -- Sub_Aggr is an array sub-aggregate. Dim is the dimension + -- corresponding to the sub-aggregate. + + procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos); + -- Computes the values of array Others_Present. Sub_Aggr is the + -- array sub-aggregate we start the computation from. Dim is the + -- dimension corresponding to the sub-aggregate. + + function In_Place_Assign_OK return Boolean; + -- Simple predicate to determine whether an aggregate assignment can + -- be done in place, because none of the new values can depend on the + -- components of the target of the assignment. + + procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos); + -- Checks that if an others choice is present in any sub-aggregate no + -- aggregate index is outside the bounds of the index constraint. + -- Sub_Aggr is an array sub-aggregate. Dim is the dimension + -- corresponding to the sub-aggregate. + + function Safe_Left_Hand_Side (N : Node_Id) return Boolean; + -- In addition to Maybe_In_Place_OK, in order for an aggregate to be + -- built directly into the target of the assignment it must be free + -- of side-effects. + + ---------------------------- + -- Build_Constrained_Type -- + ---------------------------- + + procedure Build_Constrained_Type (Positional : Boolean) is + Loc : constant Source_Ptr := Sloc (N); + Agg_Type : constant Entity_Id := Make_Temporary (Loc, 'A'); + Comp : Node_Id; + Decl : Node_Id; + Typ : constant Entity_Id := Etype (N); + Indexes : constant List_Id := New_List; + Num : Int; + Sub_Agg : Node_Id; + + begin + -- If the aggregate is purely positional, all its subaggregates + -- have the same size. We collect the dimensions from the first + -- subaggregate at each level. + + if Positional then + Sub_Agg := N; + + for D in 1 .. Number_Dimensions (Typ) loop + Sub_Agg := First (Expressions (Sub_Agg)); + + Comp := Sub_Agg; + Num := 0; + while Present (Comp) loop + Num := Num + 1; + Next (Comp); + end loop; + + Append_To (Indexes, + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Make_Integer_Literal (Loc, Num))); + end loop; + + else + -- We know the aggregate type is unconstrained and the aggregate + -- is not processable by the back end, therefore not necessarily + -- positional. Retrieve each dimension bounds (computed earlier). + + for D in 1 .. Number_Dimensions (Typ) loop + Append ( + Make_Range (Loc, + Low_Bound => Aggr_Low (D), + High_Bound => Aggr_High (D)), + Indexes); + end loop; + end if; + + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Agg_Type, + Type_Definition => + Make_Constrained_Array_Definition (Loc, + Discrete_Subtype_Definitions => Indexes, + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (Component_Type (Typ), Loc)))); + + Insert_Action (N, Decl); + Analyze (Decl); + Set_Etype (N, Agg_Type); + Set_Is_Itype (Agg_Type); + Freeze_Itype (Agg_Type, N); + end Build_Constrained_Type; + + ------------------ + -- Check_Bounds -- + ------------------ + + procedure Check_Bounds (Aggr_Bounds : Node_Id; Index_Bounds : Node_Id) is + Aggr_Lo : Node_Id; + Aggr_Hi : Node_Id; + + Ind_Lo : Node_Id; + Ind_Hi : Node_Id; + + Cond : Node_Id := Empty; + + begin + Get_Index_Bounds (Aggr_Bounds, Aggr_Lo, Aggr_Hi); + Get_Index_Bounds (Index_Bounds, Ind_Lo, Ind_Hi); + + -- Generate the following test: + -- + -- [constraint_error when + -- Aggr_Lo <= Aggr_Hi and then + -- (Aggr_Lo < Ind_Lo or else Aggr_Hi > Ind_Hi)] + + -- As an optimization try to see if some tests are trivially vacuous + -- because we are comparing an expression against itself. + + if Aggr_Lo = Ind_Lo and then Aggr_Hi = Ind_Hi then + Cond := Empty; + + elsif Aggr_Hi = Ind_Hi then + Cond := + Make_Op_Lt (Loc, + Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo), + Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Lo)); + + elsif Aggr_Lo = Ind_Lo then + Cond := + Make_Op_Gt (Loc, + Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi), + Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Hi)); + + else + Cond := + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Lt (Loc, + Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo), + Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Lo)), + + Right_Opnd => + Make_Op_Gt (Loc, + Left_Opnd => Duplicate_Subexpr (Aggr_Hi), + Right_Opnd => Duplicate_Subexpr (Ind_Hi))); + end if; + + if Present (Cond) then + Cond := + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Le (Loc, + Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo), + Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi)), + + Right_Opnd => Cond); + + Set_Analyzed (Left_Opnd (Left_Opnd (Cond)), False); + Set_Analyzed (Right_Opnd (Left_Opnd (Cond)), False); + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => Cond, + Reason => CE_Length_Check_Failed)); + end if; + end Check_Bounds; + + ---------------------------- + -- Check_Same_Aggr_Bounds -- + ---------------------------- + + procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos) is + Sub_Lo : constant Node_Id := Low_Bound (Aggregate_Bounds (Sub_Aggr)); + Sub_Hi : constant Node_Id := High_Bound (Aggregate_Bounds (Sub_Aggr)); + -- The bounds of this specific sub-aggregate + + Aggr_Lo : constant Node_Id := Aggr_Low (Dim); + Aggr_Hi : constant Node_Id := Aggr_High (Dim); + -- The bounds of the aggregate for this dimension + + Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim); + -- The index type for this dimension.xxx + + Cond : Node_Id := Empty; + Assoc : Node_Id; + Expr : Node_Id; + + begin + -- If index checks are on generate the test + + -- [constraint_error when + -- Aggr_Lo /= Sub_Lo or else Aggr_Hi /= Sub_Hi] + + -- As an optimization try to see if some tests are trivially vacuos + -- because we are comparing an expression against itself. Also for + -- the first dimension the test is trivially vacuous because there + -- is just one aggregate for dimension 1. + + if Index_Checks_Suppressed (Ind_Typ) then + Cond := Empty; + + elsif Dim = 1 + or else (Aggr_Lo = Sub_Lo and then Aggr_Hi = Sub_Hi) + then + Cond := Empty; + + elsif Aggr_Hi = Sub_Hi then + Cond := + Make_Op_Ne (Loc, + Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo), + Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Lo)); + + elsif Aggr_Lo = Sub_Lo then + Cond := + Make_Op_Ne (Loc, + Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi), + Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Hi)); + + else + Cond := + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Ne (Loc, + Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo), + Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Lo)), + + Right_Opnd => + Make_Op_Ne (Loc, + Left_Opnd => Duplicate_Subexpr (Aggr_Hi), + Right_Opnd => Duplicate_Subexpr (Sub_Hi))); + end if; + + if Present (Cond) then + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => Cond, + Reason => CE_Length_Check_Failed)); + end if; + + -- Now look inside the sub-aggregate to see if there is more work + + if Dim < Aggr_Dimension then + + -- Process positional components + + if Present (Expressions (Sub_Aggr)) then + Expr := First (Expressions (Sub_Aggr)); + while Present (Expr) loop + Check_Same_Aggr_Bounds (Expr, Dim + 1); + Next (Expr); + end loop; + end if; + + -- Process component associations + + if Present (Component_Associations (Sub_Aggr)) then + Assoc := First (Component_Associations (Sub_Aggr)); + while Present (Assoc) loop + Expr := Expression (Assoc); + Check_Same_Aggr_Bounds (Expr, Dim + 1); + Next (Assoc); + end loop; + end if; + end if; + end Check_Same_Aggr_Bounds; + + ---------------------------- + -- Compute_Others_Present -- + ---------------------------- + + procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos) is + Assoc : Node_Id; + Expr : Node_Id; + + begin + if Present (Component_Associations (Sub_Aggr)) then + Assoc := Last (Component_Associations (Sub_Aggr)); + + if Nkind (First (Choices (Assoc))) = N_Others_Choice then + Others_Present (Dim) := True; + end if; + end if; + + -- Now look inside the sub-aggregate to see if there is more work + + if Dim < Aggr_Dimension then + + -- Process positional components + + if Present (Expressions (Sub_Aggr)) then + Expr := First (Expressions (Sub_Aggr)); + while Present (Expr) loop + Compute_Others_Present (Expr, Dim + 1); + Next (Expr); + end loop; + end if; + + -- Process component associations + + if Present (Component_Associations (Sub_Aggr)) then + Assoc := First (Component_Associations (Sub_Aggr)); + while Present (Assoc) loop + Expr := Expression (Assoc); + Compute_Others_Present (Expr, Dim + 1); + Next (Assoc); + end loop; + end if; + end if; + end Compute_Others_Present; + + ------------------------ + -- In_Place_Assign_OK -- + ------------------------ + + function In_Place_Assign_OK return Boolean is + Aggr_In : Node_Id; + Aggr_Lo : Node_Id; + Aggr_Hi : Node_Id; + Obj_In : Node_Id; + Obj_Lo : Node_Id; + Obj_Hi : Node_Id; + + function Is_Others_Aggregate (Aggr : Node_Id) return Boolean; + -- Aggregates that consist of a single Others choice are safe + -- if the single expression is. + + function Safe_Aggregate (Aggr : Node_Id) return Boolean; + -- Check recursively that each component of a (sub)aggregate does + -- not depend on the variable being assigned to. + + function Safe_Component (Expr : Node_Id) return Boolean; + -- Verify that an expression cannot depend on the variable being + -- assigned to. Room for improvement here (but less than before). + + ------------------------- + -- Is_Others_Aggregate -- + ------------------------- + + function Is_Others_Aggregate (Aggr : Node_Id) return Boolean is + begin + return No (Expressions (Aggr)) + and then Nkind + (First (Choices (First (Component_Associations (Aggr))))) + = N_Others_Choice; + end Is_Others_Aggregate; + + -------------------- + -- Safe_Aggregate -- + -------------------- + + function Safe_Aggregate (Aggr : Node_Id) return Boolean is + Expr : Node_Id; + + begin + if Present (Expressions (Aggr)) then + Expr := First (Expressions (Aggr)); + while Present (Expr) loop + if Nkind (Expr) = N_Aggregate then + if not Safe_Aggregate (Expr) then + return False; + end if; + + elsif not Safe_Component (Expr) then + return False; + end if; + + Next (Expr); + end loop; + end if; + + if Present (Component_Associations (Aggr)) then + Expr := First (Component_Associations (Aggr)); + while Present (Expr) loop + if Nkind (Expression (Expr)) = N_Aggregate then + if not Safe_Aggregate (Expression (Expr)) then + return False; + end if; + + elsif not Safe_Component (Expression (Expr)) then + return False; + end if; + + Next (Expr); + end loop; + end if; + + return True; + end Safe_Aggregate; + + -------------------- + -- Safe_Component -- + -------------------- + + function Safe_Component (Expr : Node_Id) return Boolean is + Comp : Node_Id := Expr; + + function Check_Component (Comp : Node_Id) return Boolean; + -- Do the recursive traversal, after copy + + --------------------- + -- Check_Component -- + --------------------- + + function Check_Component (Comp : Node_Id) return Boolean is + begin + if Is_Overloaded (Comp) then + return False; + end if; + + return Compile_Time_Known_Value (Comp) + + or else (Is_Entity_Name (Comp) + and then Present (Entity (Comp)) + and then No (Renamed_Object (Entity (Comp)))) + + or else (Nkind (Comp) = N_Attribute_Reference + and then Check_Component (Prefix (Comp))) + + or else (Nkind (Comp) in N_Binary_Op + and then Check_Component (Left_Opnd (Comp)) + and then Check_Component (Right_Opnd (Comp))) + + or else (Nkind (Comp) in N_Unary_Op + and then Check_Component (Right_Opnd (Comp))) + + or else (Nkind (Comp) = N_Selected_Component + and then Check_Component (Prefix (Comp))) + + or else (Nkind (Comp) = N_Unchecked_Type_Conversion + and then Check_Component (Expression (Comp))); + end Check_Component; + + -- Start of processing for Safe_Component + + begin + -- If the component appears in an association that may + -- correspond to more than one element, it is not analyzed + -- before the expansion into assignments, to avoid side effects. + -- We analyze, but do not resolve the copy, to obtain sufficient + -- entity information for the checks that follow. If component is + -- overloaded we assume an unsafe function call. + + if not Analyzed (Comp) then + if Is_Overloaded (Expr) then + return False; + + elsif Nkind (Expr) = N_Aggregate + and then not Is_Others_Aggregate (Expr) + then + return False; + + elsif Nkind (Expr) = N_Allocator then + + -- For now, too complex to analyze + + return False; + end if; + + Comp := New_Copy_Tree (Expr); + Set_Parent (Comp, Parent (Expr)); + Analyze (Comp); + end if; + + if Nkind (Comp) = N_Aggregate then + return Safe_Aggregate (Comp); + else + return Check_Component (Comp); + end if; + end Safe_Component; + + -- Start of processing for In_Place_Assign_OK + + begin + if Present (Component_Associations (N)) then + + -- On assignment, sliding can take place, so we cannot do the + -- assignment in place unless the bounds of the aggregate are + -- statically equal to those of the target. + + -- If the aggregate is given by an others choice, the bounds + -- are derived from the left-hand side, and the assignment is + -- safe if the expression is. + + if Is_Others_Aggregate (N) then + return + Safe_Component + (Expression (First (Component_Associations (N)))); + end if; + + Aggr_In := First_Index (Etype (N)); + + if Nkind (Parent (N)) = N_Assignment_Statement then + Obj_In := First_Index (Etype (Name (Parent (N)))); + + else + -- Context is an allocator. Check bounds of aggregate + -- against given type in qualified expression. + + pragma Assert (Nkind (Parent (Parent (N))) = N_Allocator); + Obj_In := + First_Index (Etype (Entity (Subtype_Mark (Parent (N))))); + end if; + + while Present (Aggr_In) loop + Get_Index_Bounds (Aggr_In, Aggr_Lo, Aggr_Hi); + Get_Index_Bounds (Obj_In, Obj_Lo, Obj_Hi); + + if not Compile_Time_Known_Value (Aggr_Lo) + or else not Compile_Time_Known_Value (Aggr_Hi) + or else not Compile_Time_Known_Value (Obj_Lo) + or else not Compile_Time_Known_Value (Obj_Hi) + or else Expr_Value (Aggr_Lo) /= Expr_Value (Obj_Lo) + or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi) + then + return False; + end if; + + Next_Index (Aggr_In); + Next_Index (Obj_In); + end loop; + end if; + + -- Now check the component values themselves + + return Safe_Aggregate (N); + end In_Place_Assign_OK; + + ------------------ + -- Others_Check -- + ------------------ + + procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos) is + Aggr_Lo : constant Node_Id := Aggr_Low (Dim); + Aggr_Hi : constant Node_Id := Aggr_High (Dim); + -- The bounds of the aggregate for this dimension + + Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim); + -- The index type for this dimension + + Need_To_Check : Boolean := False; + + Choices_Lo : Node_Id := Empty; + Choices_Hi : Node_Id := Empty; + -- The lowest and highest discrete choices for a named sub-aggregate + + Nb_Choices : Int := -1; + -- The number of discrete non-others choices in this sub-aggregate + + Nb_Elements : Uint := Uint_0; + -- The number of elements in a positional aggregate + + Cond : Node_Id := Empty; + + Assoc : Node_Id; + Choice : Node_Id; + Expr : Node_Id; + + begin + -- Check if we have an others choice. If we do make sure that this + -- sub-aggregate contains at least one element in addition to the + -- others choice. + + if Range_Checks_Suppressed (Ind_Typ) then + Need_To_Check := False; + + elsif Present (Expressions (Sub_Aggr)) + and then Present (Component_Associations (Sub_Aggr)) + then + Need_To_Check := True; + + elsif Present (Component_Associations (Sub_Aggr)) then + Assoc := Last (Component_Associations (Sub_Aggr)); + + if Nkind (First (Choices (Assoc))) /= N_Others_Choice then + Need_To_Check := False; + + else + -- Count the number of discrete choices. Start with -1 because + -- the others choice does not count. + + Nb_Choices := -1; + Assoc := First (Component_Associations (Sub_Aggr)); + while Present (Assoc) loop + Choice := First (Choices (Assoc)); + while Present (Choice) loop + Nb_Choices := Nb_Choices + 1; + Next (Choice); + end loop; + + Next (Assoc); + end loop; + + -- If there is only an others choice nothing to do + + Need_To_Check := (Nb_Choices > 0); + end if; + + else + Need_To_Check := False; + end if; + + -- If we are dealing with a positional sub-aggregate with an others + -- choice then compute the number or positional elements. + + if Need_To_Check and then Present (Expressions (Sub_Aggr)) then + Expr := First (Expressions (Sub_Aggr)); + Nb_Elements := Uint_0; + while Present (Expr) loop + Nb_Elements := Nb_Elements + 1; + Next (Expr); + end loop; + + -- If the aggregate contains discrete choices and an others choice + -- compute the smallest and largest discrete choice values. + + elsif Need_To_Check then + Compute_Choices_Lo_And_Choices_Hi : declare + + Table : Case_Table_Type (1 .. Nb_Choices); + -- Used to sort all the different choice values + + J : Pos := 1; + Low : Node_Id; + High : Node_Id; + + begin + Assoc := First (Component_Associations (Sub_Aggr)); + while Present (Assoc) loop + Choice := First (Choices (Assoc)); + while Present (Choice) loop + if Nkind (Choice) = N_Others_Choice then + exit; + end if; + + Get_Index_Bounds (Choice, Low, High); + Table (J).Choice_Lo := Low; + Table (J).Choice_Hi := High; + + J := J + 1; + Next (Choice); + end loop; + + Next (Assoc); + end loop; + + -- Sort the discrete choices + + Sort_Case_Table (Table); + + Choices_Lo := Table (1).Choice_Lo; + Choices_Hi := Table (Nb_Choices).Choice_Hi; + end Compute_Choices_Lo_And_Choices_Hi; + end if; + + -- If no others choice in this sub-aggregate, or the aggregate + -- comprises only an others choice, nothing to do. + + if not Need_To_Check then + Cond := Empty; + + -- If we are dealing with an aggregate containing an others choice + -- and positional components, we generate the following test: + + -- if Ind_Typ'Pos (Aggr_Lo) + (Nb_Elements - 1) > + -- Ind_Typ'Pos (Aggr_Hi) + -- then + -- raise Constraint_Error; + -- end if; + + elsif Nb_Elements > Uint_0 then + Cond := + Make_Op_Gt (Loc, + Left_Opnd => + Make_Op_Add (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ind_Typ, Loc), + Attribute_Name => Name_Pos, + Expressions => + New_List + (Duplicate_Subexpr_Move_Checks (Aggr_Lo))), + Right_Opnd => Make_Integer_Literal (Loc, Nb_Elements - 1)), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ind_Typ, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Duplicate_Subexpr_Move_Checks (Aggr_Hi)))); + + -- If we are dealing with an aggregate containing an others choice + -- and discrete choices we generate the following test: + + -- [constraint_error when + -- Choices_Lo < Aggr_Lo or else Choices_Hi > Aggr_Hi]; + + else + Cond := + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Lt (Loc, + Left_Opnd => + Duplicate_Subexpr_Move_Checks (Choices_Lo), + Right_Opnd => + Duplicate_Subexpr_Move_Checks (Aggr_Lo)), + + Right_Opnd => + Make_Op_Gt (Loc, + Left_Opnd => + Duplicate_Subexpr (Choices_Hi), + Right_Opnd => + Duplicate_Subexpr (Aggr_Hi))); + end if; + + if Present (Cond) then + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => Cond, + Reason => CE_Length_Check_Failed)); + -- Questionable reason code, shouldn't that be a + -- CE_Range_Check_Failed ??? + end if; + + -- Now look inside the sub-aggregate to see if there is more work + + if Dim < Aggr_Dimension then + + -- Process positional components + + if Present (Expressions (Sub_Aggr)) then + Expr := First (Expressions (Sub_Aggr)); + while Present (Expr) loop + Others_Check (Expr, Dim + 1); + Next (Expr); + end loop; + end if; + + -- Process component associations + + if Present (Component_Associations (Sub_Aggr)) then + Assoc := First (Component_Associations (Sub_Aggr)); + while Present (Assoc) loop + Expr := Expression (Assoc); + Others_Check (Expr, Dim + 1); + Next (Assoc); + end loop; + end if; + end if; + end Others_Check; + + ------------------------- + -- Safe_Left_Hand_Side -- + ------------------------- + + function Safe_Left_Hand_Side (N : Node_Id) return Boolean is + function Is_Safe_Index (Indx : Node_Id) return Boolean; + -- If the left-hand side includes an indexed component, check that + -- the indexes are free of side-effect. + + ------------------- + -- Is_Safe_Index -- + ------------------- + + function Is_Safe_Index (Indx : Node_Id) return Boolean is + begin + if Is_Entity_Name (Indx) then + return True; + + elsif Nkind (Indx) = N_Integer_Literal then + return True; + + elsif Nkind (Indx) = N_Function_Call + and then Is_Entity_Name (Name (Indx)) + and then + Has_Pragma_Pure_Function (Entity (Name (Indx))) + then + return True; + + elsif Nkind (Indx) = N_Type_Conversion + and then Is_Safe_Index (Expression (Indx)) + then + return True; + + else + return False; + end if; + end Is_Safe_Index; + + -- Start of processing for Safe_Left_Hand_Side + + begin + if Is_Entity_Name (N) then + return True; + + elsif Nkind_In (N, N_Explicit_Dereference, N_Selected_Component) + and then Safe_Left_Hand_Side (Prefix (N)) + then + return True; + + elsif Nkind (N) = N_Indexed_Component + and then Safe_Left_Hand_Side (Prefix (N)) + and then + Is_Safe_Index (First (Expressions (N))) + then + return True; + + elsif Nkind (N) = N_Unchecked_Type_Conversion then + return Safe_Left_Hand_Side (Expression (N)); + + else + return False; + end if; + end Safe_Left_Hand_Side; + + -- Local variables + + Tmp : Entity_Id; + -- Holds the temporary aggregate value + + Tmp_Decl : Node_Id; + -- Holds the declaration of Tmp + + Aggr_Code : List_Id; + Parent_Node : Node_Id; + Parent_Kind : Node_Kind; + + -- Start of processing for Expand_Array_Aggregate + + begin + -- Do not touch the special aggregates of attributes used for Asm calls + + if Is_RTE (Ctyp, RE_Asm_Input_Operand) + or else Is_RTE (Ctyp, RE_Asm_Output_Operand) + then + return; + end if; + + -- If the semantic analyzer has determined that aggregate N will raise + -- Constraint_Error at run time, then the aggregate node has been + -- replaced with an N_Raise_Constraint_Error node and we should + -- never get here. + + pragma Assert (not Raises_Constraint_Error (N)); + + -- STEP 1a + + -- Check that the index range defined by aggregate bounds is + -- compatible with corresponding index subtype. + + Index_Compatibility_Check : declare + Aggr_Index_Range : Node_Id := First_Index (Typ); + -- The current aggregate index range + + Index_Constraint : Node_Id := First_Index (Etype (Typ)); + -- The corresponding index constraint against which we have to + -- check the above aggregate index range. + + begin + Compute_Others_Present (N, 1); + + for J in 1 .. Aggr_Dimension loop + -- There is no need to emit a check if an others choice is + -- present for this array aggregate dimension since in this + -- case one of N's sub-aggregates has taken its bounds from the + -- context and these bounds must have been checked already. In + -- addition all sub-aggregates corresponding to the same + -- dimension must all have the same bounds (checked in (c) below). + + if not Range_Checks_Suppressed (Etype (Index_Constraint)) + and then not Others_Present (J) + then + -- We don't use Checks.Apply_Range_Check here because it emits + -- a spurious check. Namely it checks that the range defined by + -- the aggregate bounds is non empty. But we know this already + -- if we get here. + + Check_Bounds (Aggr_Index_Range, Index_Constraint); + end if; + + -- Save the low and high bounds of the aggregate index as well as + -- the index type for later use in checks (b) and (c) below. + + Aggr_Low (J) := Low_Bound (Aggr_Index_Range); + Aggr_High (J) := High_Bound (Aggr_Index_Range); + + Aggr_Index_Typ (J) := Etype (Index_Constraint); + + Next_Index (Aggr_Index_Range); + Next_Index (Index_Constraint); + end loop; + end Index_Compatibility_Check; + + -- STEP 1b + + -- If an others choice is present check that no aggregate index is + -- outside the bounds of the index constraint. + + Others_Check (N, 1); + + -- STEP 1c + + -- For multidimensional arrays make sure that all subaggregates + -- corresponding to the same dimension have the same bounds. + + if Aggr_Dimension > 1 then + Check_Same_Aggr_Bounds (N, 1); + end if; + + -- STEP 2 + + -- Here we test for is packed array aggregate that we can handle at + -- compile time. If so, return with transformation done. Note that we do + -- this even if the aggregate is nested, because once we have done this + -- processing, there is no more nested aggregate! + + if Packed_Array_Aggregate_Handled (N) then + return; + end if; + + -- At this point we try to convert to positional form + + if Ekind (Current_Scope) = E_Package + and then Static_Elaboration_Desired (Current_Scope) + then + Convert_To_Positional (N, Max_Others_Replicate => 100); + + else + Convert_To_Positional (N); + end if; + + -- if the result is no longer an aggregate (e.g. it may be a string + -- literal, or a temporary which has the needed value), then we are + -- done, since there is no longer a nested aggregate. + + if Nkind (N) /= N_Aggregate then + return; + + -- We are also done if the result is an analyzed aggregate + -- This case could use more comments ??? + + elsif Analyzed (N) + and then N /= Original_Node (N) + then + return; + end if; + + -- If all aggregate components are compile-time known and the aggregate + -- has been flattened, nothing left to do. The same occurs if the + -- aggregate is used to initialize the components of an statically + -- allocated dispatch table. + + if Compile_Time_Known_Aggregate (N) + or else Is_Static_Dispatch_Table_Aggregate (N) + then + Set_Expansion_Delayed (N, False); + return; + end if; + + -- Now see if back end processing is possible + + if Backend_Processing_Possible (N) then + + -- If the aggregate is static but the constraints are not, build + -- a static subtype for the aggregate, so that Gigi can place it + -- in static memory. Perform an unchecked_conversion to the non- + -- static type imposed by the context. + + declare + Itype : constant Entity_Id := Etype (N); + Index : Node_Id; + Needs_Type : Boolean := False; + + begin + Index := First_Index (Itype); + while Present (Index) loop + if not Is_Static_Subtype (Etype (Index)) then + Needs_Type := True; + exit; + else + Next_Index (Index); + end if; + end loop; + + if Needs_Type then + Build_Constrained_Type (Positional => True); + Rewrite (N, Unchecked_Convert_To (Itype, N)); + Analyze (N); + end if; + end; + + return; + end if; + + -- STEP 3 + + -- Delay expansion for nested aggregates: it will be taken care of + -- when the parent aggregate is expanded. + + Parent_Node := Parent (N); + Parent_Kind := Nkind (Parent_Node); + + if Parent_Kind = N_Qualified_Expression then + Parent_Node := Parent (Parent_Node); + Parent_Kind := Nkind (Parent_Node); + end if; + + if Parent_Kind = N_Aggregate + or else Parent_Kind = N_Extension_Aggregate + or else Parent_Kind = N_Component_Association + or else (Parent_Kind = N_Object_Declaration + and then Needs_Finalization (Typ)) + or else (Parent_Kind = N_Assignment_Statement + and then Inside_Init_Proc) + then + if Static_Array_Aggregate (N) + or else Compile_Time_Known_Aggregate (N) + then + Set_Expansion_Delayed (N, False); + return; + else + Set_Expansion_Delayed (N); + return; + end if; + end if; + + -- STEP 4 + + -- Look if in place aggregate expansion is possible + + -- For object declarations we build the aggregate in place, unless + -- the array is bit-packed or the component is controlled. + + -- For assignments we do the assignment in place if all the component + -- associations have compile-time known values. For other cases we + -- create a temporary. The analysis for safety of on-line assignment + -- is delicate, i.e. we don't know how to do it fully yet ??? + + -- For allocators we assign to the designated object in place if the + -- aggregate meets the same conditions as other in-place assignments. + -- In this case the aggregate may not come from source but was created + -- for default initialization, e.g. with Initialize_Scalars. + + if Requires_Transient_Scope (Typ) then + Establish_Transient_Scope + (N, Sec_Stack => Has_Controlled_Component (Typ)); + end if; + + if Has_Default_Init_Comps (N) then + Maybe_In_Place_OK := False; + + elsif Is_Bit_Packed_Array (Typ) + or else Has_Controlled_Component (Typ) + then + Maybe_In_Place_OK := False; + + else + Maybe_In_Place_OK := + (Nkind (Parent (N)) = N_Assignment_Statement + and then Comes_From_Source (N) + and then In_Place_Assign_OK) + + or else + (Nkind (Parent (Parent (N))) = N_Allocator + and then In_Place_Assign_OK); + end if; + + -- If this is an array of tasks, it will be expanded into build-in-place + -- assignments. Build an activation chain for the tasks now. + + if Has_Task (Etype (N)) then + Build_Activation_Chain_Entity (N); + end if; + + -- Should document these individual tests ??? + + if not Has_Default_Init_Comps (N) + and then Comes_From_Source (Parent (N)) + and then Nkind (Parent (N)) = N_Object_Declaration + and then not + Must_Slide (Etype (Defining_Identifier (Parent (N))), Typ) + and then N = Expression (Parent (N)) + and then not Is_Bit_Packed_Array (Typ) + and then not Has_Controlled_Component (Typ) + + -- If the aggregate is the expression in an object declaration, it + -- cannot be expanded in place. Lookahead in the current declarative + -- part to find an address clause for the object being declared. If + -- one is present, we cannot build in place. Unclear comment??? + + and then not Has_Following_Address_Clause (Parent (N)) + then + Tmp := Defining_Identifier (Parent (N)); + Set_No_Initialization (Parent (N)); + Set_Expression (Parent (N), Empty); + + -- Set the type of the entity, for use in the analysis of the + -- subsequent indexed assignments. If the nominal type is not + -- constrained, build a subtype from the known bounds of the + -- aggregate. If the declaration has a subtype mark, use it, + -- otherwise use the itype of the aggregate. + + if not Is_Constrained (Typ) then + Build_Constrained_Type (Positional => False); + elsif Is_Entity_Name (Object_Definition (Parent (N))) + and then Is_Constrained (Entity (Object_Definition (Parent (N)))) + then + Set_Etype (Tmp, Entity (Object_Definition (Parent (N)))); + else + Set_Size_Known_At_Compile_Time (Typ, False); + Set_Etype (Tmp, Typ); + end if; + + elsif Maybe_In_Place_OK + and then Nkind (Parent (N)) = N_Qualified_Expression + and then Nkind (Parent (Parent (N))) = N_Allocator + then + Set_Expansion_Delayed (N); + return; + + -- In the remaining cases the aggregate is the RHS of an assignment + + elsif Maybe_In_Place_OK + and then Safe_Left_Hand_Side (Name (Parent (N))) + then + Tmp := Name (Parent (N)); + + if Etype (Tmp) /= Etype (N) then + Apply_Length_Check (N, Etype (Tmp)); + + if Nkind (N) = N_Raise_Constraint_Error then + + -- Static error, nothing further to expand + + return; + end if; + end if; + + elsif Maybe_In_Place_OK + and then Nkind (Name (Parent (N))) = N_Slice + and then Safe_Slice_Assignment (N) + then + -- Safe_Slice_Assignment rewrites assignment as a loop + + return; + + -- Step 5 + + -- In place aggregate expansion is not possible + + else + Maybe_In_Place_OK := False; + Tmp := Make_Temporary (Loc, 'A', N); + Tmp_Decl := + Make_Object_Declaration + (Loc, + Defining_Identifier => Tmp, + Object_Definition => New_Occurrence_Of (Typ, Loc)); + Set_No_Initialization (Tmp_Decl, True); + + -- If we are within a loop, the temporary will be pushed on the + -- stack at each iteration. If the aggregate is the expression for an + -- allocator, it will be immediately copied to the heap and can + -- be reclaimed at once. We create a transient scope around the + -- aggregate for this purpose. + + if Ekind (Current_Scope) = E_Loop + and then Nkind (Parent (Parent (N))) = N_Allocator + then + Establish_Transient_Scope (N, False); + end if; + + Insert_Action (N, Tmp_Decl); + end if; + + -- Construct and insert the aggregate code. We can safely suppress index + -- checks because this code is guaranteed not to raise CE on index + -- checks. However we should *not* suppress all checks. + + declare + Target : Node_Id; + + begin + if Nkind (Tmp) = N_Defining_Identifier then + Target := New_Reference_To (Tmp, Loc); + + else + + if Has_Default_Init_Comps (N) then + + -- Ada 2005 (AI-287): This case has not been analyzed??? + + raise Program_Error; + end if; + + -- Name in assignment is explicit dereference + + Target := New_Copy (Tmp); + end if; + + Aggr_Code := + Build_Array_Aggr_Code (N, + Ctype => Ctyp, + Index => First_Index (Typ), + Into => Target, + Scalar_Comp => Is_Scalar_Type (Ctyp)); + end; + + if Comes_From_Source (Tmp) then + Insert_Actions_After (Parent (N), Aggr_Code); + + else + Insert_Actions (N, Aggr_Code); + end if; + + -- If the aggregate has been assigned in place, remove the original + -- assignment. + + if Nkind (Parent (N)) = N_Assignment_Statement + and then Maybe_In_Place_OK + then + Rewrite (Parent (N), Make_Null_Statement (Loc)); + + elsif Nkind (Parent (N)) /= N_Object_Declaration + or else Tmp /= Defining_Identifier (Parent (N)) + then + Rewrite (N, New_Occurrence_Of (Tmp, Loc)); + Analyze_And_Resolve (N, Typ); + end if; + end Expand_Array_Aggregate; + + ------------------------ + -- Expand_N_Aggregate -- + ------------------------ + + procedure Expand_N_Aggregate (N : Node_Id) is + begin + if Is_Record_Type (Etype (N)) then + Expand_Record_Aggregate (N); + else + Expand_Array_Aggregate (N); + end if; + exception + when RE_Not_Available => + return; + end Expand_N_Aggregate; + + ---------------------------------- + -- Expand_N_Extension_Aggregate -- + ---------------------------------- + + -- If the ancestor part is an expression, add a component association for + -- the parent field. If the type of the ancestor part is not the direct + -- parent of the expected type, build recursively the needed ancestors. + -- If the ancestor part is a subtype_mark, replace aggregate with a decla- + -- ration for a temporary of the expected type, followed by individual + -- assignments to the given components. + + procedure Expand_N_Extension_Aggregate (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + A : constant Node_Id := Ancestor_Part (N); + Typ : constant Entity_Id := Etype (N); + + begin + -- If the ancestor is a subtype mark, an init proc must be called + -- on the resulting object which thus has to be materialized in + -- the front-end + + if Is_Entity_Name (A) and then Is_Type (Entity (A)) then + Convert_To_Assignments (N, Typ); + + -- The extension aggregate is transformed into a record aggregate + -- of the following form (c1 and c2 are inherited components) + + -- (Exp with c3 => a, c4 => b) + -- ==> (c1 => Exp.c1, c2 => Exp.c2, c3 => a, c4 => b) + + else + Set_Etype (N, Typ); + + if Tagged_Type_Expansion then + Expand_Record_Aggregate (N, + Orig_Tag => + New_Occurrence_Of + (Node (First_Elmt (Access_Disp_Table (Typ))), Loc), + Parent_Expr => A); + else + -- No tag is needed in the case of a VM + Expand_Record_Aggregate (N, + Parent_Expr => A); + end if; + end if; + + exception + when RE_Not_Available => + return; + end Expand_N_Extension_Aggregate; + + ----------------------------- + -- Expand_Record_Aggregate -- + ----------------------------- + + procedure Expand_Record_Aggregate + (N : Node_Id; + Orig_Tag : Node_Id := Empty; + Parent_Expr : Node_Id := Empty) + is + Loc : constant Source_Ptr := Sloc (N); + Comps : constant List_Id := Component_Associations (N); + Typ : constant Entity_Id := Etype (N); + Base_Typ : constant Entity_Id := Base_Type (Typ); + + Static_Components : Boolean := True; + -- Flag to indicate whether all components are compile-time known, + -- and the aggregate can be constructed statically and handled by + -- the back-end. + + function Component_Not_OK_For_Backend return Boolean; + -- Check for presence of component which makes it impossible for the + -- backend to process the aggregate, thus requiring the use of a series + -- of assignment statements. Cases checked for are a nested aggregate + -- needing Late_Expansion, the presence of a tagged component which may + -- need tag adjustment, and a bit unaligned component reference. + -- + -- We also force expansion into assignments if a component is of a + -- mutable type (including a private type with discriminants) because + -- in that case the size of the component to be copied may be smaller + -- than the side of the target, and there is no simple way for gigi + -- to compute the size of the object to be copied. + -- + -- NOTE: This is part of the ongoing work to define precisely the + -- interface between front-end and back-end handling of aggregates. + -- In general it is desirable to pass aggregates as they are to gigi, + -- in order to minimize elaboration code. This is one case where the + -- semantics of Ada complicate the analysis and lead to anomalies in + -- the gcc back-end if the aggregate is not expanded into assignments. + + ---------------------------------- + -- Component_Not_OK_For_Backend -- + ---------------------------------- + + function Component_Not_OK_For_Backend return Boolean is + C : Node_Id; + Expr_Q : Node_Id; + + begin + if No (Comps) then + return False; + end if; + + C := First (Comps); + while Present (C) loop + + -- If the component has box initialization, expansion is needed + -- and component is not ready for backend. + + if Box_Present (C) then + return True; + end if; + + if Nkind (Expression (C)) = N_Qualified_Expression then + Expr_Q := Expression (Expression (C)); + else + Expr_Q := Expression (C); + end if; + + -- Return true if the aggregate has any associations for tagged + -- components that may require tag adjustment. + + -- These are cases where the source expression may have a tag that + -- could differ from the component tag (e.g., can occur for type + -- conversions and formal parameters). (Tag adjustment not needed + -- if VM_Target because object tags are implicit in the machine.) + + if Is_Tagged_Type (Etype (Expr_Q)) + and then (Nkind (Expr_Q) = N_Type_Conversion + or else (Is_Entity_Name (Expr_Q) + and then + Ekind (Entity (Expr_Q)) in Formal_Kind)) + and then Tagged_Type_Expansion + then + Static_Components := False; + return True; + + elsif Is_Delayed_Aggregate (Expr_Q) then + Static_Components := False; + return True; + + elsif Possible_Bit_Aligned_Component (Expr_Q) then + Static_Components := False; + return True; + end if; + + if Is_Scalar_Type (Etype (Expr_Q)) then + if not Compile_Time_Known_Value (Expr_Q) then + Static_Components := False; + end if; + + elsif Nkind (Expr_Q) /= N_Aggregate + or else not Compile_Time_Known_Aggregate (Expr_Q) + then + Static_Components := False; + + if Is_Private_Type (Etype (Expr_Q)) + and then Has_Discriminants (Etype (Expr_Q)) + then + return True; + end if; + end if; + + Next (C); + end loop; + + return False; + end Component_Not_OK_For_Backend; + + -- Remaining Expand_Record_Aggregate variables + + Tag_Value : Node_Id; + Comp : Entity_Id; + New_Comp : Node_Id; + + -- Start of processing for Expand_Record_Aggregate + + begin + -- If the aggregate is to be assigned to an atomic variable, we + -- have to prevent a piecemeal assignment even if the aggregate + -- is to be expanded. We create a temporary for the aggregate, and + -- assign the temporary instead, so that the back end can generate + -- an atomic move for it. + + if Is_Atomic (Typ) + and then Comes_From_Source (Parent (N)) + and then Is_Atomic_Aggregate (N, Typ) + then + return; + + -- No special management required for aggregates used to initialize + -- statically allocated dispatch tables + + elsif Is_Static_Dispatch_Table_Aggregate (N) then + return; + end if; + + -- Ada 2005 (AI-318-2): We need to convert to assignments if components + -- are build-in-place function calls. The assignments will each turn + -- into a build-in-place function call. If components are all static, + -- we can pass the aggregate to the backend regardless of limitedness. + + -- Extension aggregates, aggregates in extended return statements, and + -- aggregates for C++ imported types must be expanded. + + if Ada_Version >= Ada_2005 and then Is_Immutably_Limited_Type (Typ) then + if not Nkind_In (Parent (N), N_Object_Declaration, + N_Component_Association) + then + Convert_To_Assignments (N, Typ); + + elsif Nkind (N) = N_Extension_Aggregate + or else Convention (Typ) = Convention_CPP + then + Convert_To_Assignments (N, Typ); + + elsif not Size_Known_At_Compile_Time (Typ) + or else Component_Not_OK_For_Backend + or else not Static_Components + then + Convert_To_Assignments (N, Typ); + + else + Set_Compile_Time_Known_Aggregate (N); + Set_Expansion_Delayed (N, False); + end if; + + -- Gigi doesn't handle properly temporaries of variable size + -- so we generate it in the front-end + + elsif not Size_Known_At_Compile_Time (Typ) then + Convert_To_Assignments (N, Typ); + + -- Temporaries for controlled aggregates need to be attached to a + -- final chain in order to be properly finalized, so it has to + -- be created in the front-end + + elsif Is_Controlled (Typ) + or else Has_Controlled_Component (Base_Type (Typ)) + then + Convert_To_Assignments (N, Typ); + + -- Ada 2005 (AI-287): In case of default initialized components we + -- convert the aggregate into assignments. + + elsif Has_Default_Init_Comps (N) then + Convert_To_Assignments (N, Typ); + + -- Check components + + elsif Component_Not_OK_For_Backend then + Convert_To_Assignments (N, Typ); + + -- If an ancestor is private, some components are not inherited and + -- we cannot expand into a record aggregate + + elsif Has_Private_Ancestor (Typ) then + Convert_To_Assignments (N, Typ); + + -- ??? The following was done to compile fxacc00.ads in the ACVCs. Gigi + -- is not able to handle the aggregate for Late_Request. + + elsif Is_Tagged_Type (Typ) and then Has_Discriminants (Typ) then + Convert_To_Assignments (N, Typ); + + -- If the tagged types covers interface types we need to initialize all + -- hidden components containing pointers to secondary dispatch tables. + + elsif Is_Tagged_Type (Typ) and then Has_Interfaces (Typ) then + Convert_To_Assignments (N, Typ); + + -- If some components are mutable, the size of the aggregate component + -- may be distinct from the default size of the type component, so + -- we need to expand to insure that the back-end copies the proper + -- size of the data. + + elsif Has_Mutable_Components (Typ) then + Convert_To_Assignments (N, Typ); + + -- If the type involved has any non-bit aligned components, then we are + -- not sure that the back end can handle this case correctly. + + elsif Type_May_Have_Bit_Aligned_Components (Typ) then + Convert_To_Assignments (N, Typ); + + -- In all other cases, build a proper aggregate handlable by gigi + + else + if Nkind (N) = N_Aggregate then + + -- If the aggregate is static and can be handled by the back-end, + -- nothing left to do. + + if Static_Components then + Set_Compile_Time_Known_Aggregate (N); + Set_Expansion_Delayed (N, False); + end if; + end if; + + -- If no discriminants, nothing special to do + + if not Has_Discriminants (Typ) then + null; + + -- Case of discriminants present + + elsif Is_Derived_Type (Typ) then + + -- For untagged types, non-stored discriminants are replaced + -- with stored discriminants, which are the ones that gigi uses + -- to describe the type and its components. + + Generate_Aggregate_For_Derived_Type : declare + Constraints : constant List_Id := New_List; + First_Comp : Node_Id; + Discriminant : Entity_Id; + Decl : Node_Id; + Num_Disc : Int := 0; + Num_Gird : Int := 0; + + procedure Prepend_Stored_Values (T : Entity_Id); + -- Scan the list of stored discriminants of the type, and add + -- their values to the aggregate being built. + + --------------------------- + -- Prepend_Stored_Values -- + --------------------------- + + procedure Prepend_Stored_Values (T : Entity_Id) is + begin + Discriminant := First_Stored_Discriminant (T); + while Present (Discriminant) loop + New_Comp := + Make_Component_Association (Loc, + Choices => + New_List (New_Occurrence_Of (Discriminant, Loc)), + + Expression => + New_Copy_Tree ( + Get_Discriminant_Value ( + Discriminant, + Typ, + Discriminant_Constraint (Typ)))); + + if No (First_Comp) then + Prepend_To (Component_Associations (N), New_Comp); + else + Insert_After (First_Comp, New_Comp); + end if; + + First_Comp := New_Comp; + Next_Stored_Discriminant (Discriminant); + end loop; + end Prepend_Stored_Values; + + -- Start of processing for Generate_Aggregate_For_Derived_Type + + begin + -- Remove the associations for the discriminant of derived type + + First_Comp := First (Component_Associations (N)); + while Present (First_Comp) loop + Comp := First_Comp; + Next (First_Comp); + + if Ekind (Entity + (First (Choices (Comp)))) = E_Discriminant + then + Remove (Comp); + Num_Disc := Num_Disc + 1; + end if; + end loop; + + -- Insert stored discriminant associations in the correct + -- order. If there are more stored discriminants than new + -- discriminants, there is at least one new discriminant that + -- constrains more than one of the stored discriminants. In + -- this case we need to construct a proper subtype of the + -- parent type, in order to supply values to all the + -- components. Otherwise there is one-one correspondence + -- between the constraints and the stored discriminants. + + First_Comp := Empty; + + Discriminant := First_Stored_Discriminant (Base_Type (Typ)); + while Present (Discriminant) loop + Num_Gird := Num_Gird + 1; + Next_Stored_Discriminant (Discriminant); + end loop; + + -- Case of more stored discriminants than new discriminants + + if Num_Gird > Num_Disc then + + -- Create a proper subtype of the parent type, which is the + -- proper implementation type for the aggregate, and convert + -- it to the intended target type. + + Discriminant := First_Stored_Discriminant (Base_Type (Typ)); + while Present (Discriminant) loop + New_Comp := + New_Copy_Tree ( + Get_Discriminant_Value ( + Discriminant, + Typ, + Discriminant_Constraint (Typ))); + Append (New_Comp, Constraints); + Next_Stored_Discriminant (Discriminant); + end loop; + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'T'), + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Etype (Base_Type (Typ)), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint + (Loc, Constraints))); + + Insert_Action (N, Decl); + Prepend_Stored_Values (Base_Type (Typ)); + + Set_Etype (N, Defining_Identifier (Decl)); + Set_Analyzed (N); + + Rewrite (N, Unchecked_Convert_To (Typ, N)); + Analyze (N); + + -- Case where we do not have fewer new discriminants than + -- stored discriminants, so in this case we can simply use the + -- stored discriminants of the subtype. + + else + Prepend_Stored_Values (Typ); + end if; + end Generate_Aggregate_For_Derived_Type; + end if; + + if Is_Tagged_Type (Typ) then + + -- The tagged case, _parent and _tag component must be created + + -- Reset null_present unconditionally. tagged records always have + -- at least one field (the tag or the parent) + + Set_Null_Record_Present (N, False); + + -- When the current aggregate comes from the expansion of an + -- extension aggregate, the parent expr is replaced by an + -- aggregate formed by selected components of this expr + + if Present (Parent_Expr) + and then Is_Empty_List (Comps) + then + Comp := First_Component_Or_Discriminant (Typ); + while Present (Comp) loop + + -- Skip all expander-generated components + + if + not Comes_From_Source (Original_Record_Component (Comp)) + then + null; + + else + New_Comp := + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Typ, + Duplicate_Subexpr (Parent_Expr, True)), + + Selector_Name => New_Occurrence_Of (Comp, Loc)); + + Append_To (Comps, + Make_Component_Association (Loc, + Choices => + New_List (New_Occurrence_Of (Comp, Loc)), + Expression => + New_Comp)); + + Analyze_And_Resolve (New_Comp, Etype (Comp)); + end if; + + Next_Component_Or_Discriminant (Comp); + end loop; + end if; + + -- Compute the value for the Tag now, if the type is a root it + -- will be included in the aggregate right away, otherwise it will + -- be propagated to the parent aggregate + + if Present (Orig_Tag) then + Tag_Value := Orig_Tag; + elsif not Tagged_Type_Expansion then + Tag_Value := Empty; + else + Tag_Value := + New_Occurrence_Of + (Node (First_Elmt (Access_Disp_Table (Typ))), Loc); + end if; + + -- For a derived type, an aggregate for the parent is formed with + -- all the inherited components. + + if Is_Derived_Type (Typ) then + + declare + First_Comp : Node_Id; + Parent_Comps : List_Id; + Parent_Aggr : Node_Id; + Parent_Name : Node_Id; + + begin + -- Remove the inherited component association from the + -- aggregate and store them in the parent aggregate + + First_Comp := First (Component_Associations (N)); + Parent_Comps := New_List; + while Present (First_Comp) + and then Scope (Original_Record_Component ( + Entity (First (Choices (First_Comp))))) /= Base_Typ + loop + Comp := First_Comp; + Next (First_Comp); + Remove (Comp); + Append (Comp, Parent_Comps); + end loop; + + Parent_Aggr := Make_Aggregate (Loc, + Component_Associations => Parent_Comps); + Set_Etype (Parent_Aggr, Etype (Base_Type (Typ))); + + -- Find the _parent component + + Comp := First_Component (Typ); + while Chars (Comp) /= Name_uParent loop + Comp := Next_Component (Comp); + end loop; + + Parent_Name := New_Occurrence_Of (Comp, Loc); + + -- Insert the parent aggregate + + Prepend_To (Component_Associations (N), + Make_Component_Association (Loc, + Choices => New_List (Parent_Name), + Expression => Parent_Aggr)); + + -- Expand recursively the parent propagating the right Tag + + Expand_Record_Aggregate ( + Parent_Aggr, Tag_Value, Parent_Expr); + end; + + -- For a root type, the tag component is added (unless compiling + -- for the VMs, where tags are implicit). + + elsif Tagged_Type_Expansion then + declare + Tag_Name : constant Node_Id := + New_Occurrence_Of + (First_Tag_Component (Typ), Loc); + Typ_Tag : constant Entity_Id := RTE (RE_Tag); + Conv_Node : constant Node_Id := + Unchecked_Convert_To (Typ_Tag, Tag_Value); + + begin + Set_Etype (Conv_Node, Typ_Tag); + Prepend_To (Component_Associations (N), + Make_Component_Association (Loc, + Choices => New_List (Tag_Name), + Expression => Conv_Node)); + end; + end if; + end if; + end if; + + end Expand_Record_Aggregate; + + ---------------------------- + -- Has_Default_Init_Comps -- + ---------------------------- + + function Has_Default_Init_Comps (N : Node_Id) return Boolean is + Comps : constant List_Id := Component_Associations (N); + C : Node_Id; + Expr : Node_Id; + begin + pragma Assert (Nkind_In (N, N_Aggregate, N_Extension_Aggregate)); + + if No (Comps) then + return False; + end if; + + if Has_Self_Reference (N) then + return True; + end if; + + -- Check if any direct component has default initialized components + + C := First (Comps); + while Present (C) loop + if Box_Present (C) then + return True; + end if; + + Next (C); + end loop; + + -- Recursive call in case of aggregate expression + + C := First (Comps); + while Present (C) loop + Expr := Expression (C); + + if Present (Expr) + and then + Nkind_In (Expr, N_Aggregate, N_Extension_Aggregate) + and then Has_Default_Init_Comps (Expr) + then + return True; + end if; + + Next (C); + end loop; + + return False; + end Has_Default_Init_Comps; + + -------------------------- + -- Is_Delayed_Aggregate -- + -------------------------- + + function Is_Delayed_Aggregate (N : Node_Id) return Boolean is + Node : Node_Id := N; + Kind : Node_Kind := Nkind (Node); + + begin + if Kind = N_Qualified_Expression then + Node := Expression (Node); + Kind := Nkind (Node); + end if; + + if Kind /= N_Aggregate and then Kind /= N_Extension_Aggregate then + return False; + else + return Expansion_Delayed (Node); + end if; + end Is_Delayed_Aggregate; + + ---------------------------------------- + -- Is_Static_Dispatch_Table_Aggregate -- + ---------------------------------------- + + function Is_Static_Dispatch_Table_Aggregate (N : Node_Id) return Boolean is + Typ : constant Entity_Id := Base_Type (Etype (N)); + + begin + return Static_Dispatch_Tables + and then Tagged_Type_Expansion + and then RTU_Loaded (Ada_Tags) + + -- Avoid circularity when rebuilding the compiler + + and then Cunit_Entity (Get_Source_Unit (N)) /= RTU_Entity (Ada_Tags) + and then (Typ = RTE (RE_Dispatch_Table_Wrapper) + or else + Typ = RTE (RE_Address_Array) + or else + Typ = RTE (RE_Type_Specific_Data) + or else + Typ = RTE (RE_Tag_Table) + or else + (RTE_Available (RE_Interface_Data) + and then Typ = RTE (RE_Interface_Data)) + or else + (RTE_Available (RE_Interfaces_Array) + and then Typ = RTE (RE_Interfaces_Array)) + or else + (RTE_Available (RE_Interface_Data_Element) + and then Typ = RTE (RE_Interface_Data_Element))); + end Is_Static_Dispatch_Table_Aggregate; + + -------------------- + -- Late_Expansion -- + -------------------- + + function Late_Expansion + (N : Node_Id; + Typ : Entity_Id; + Target : Node_Id; + Flist : Node_Id := Empty; + Obj : Entity_Id := Empty) return List_Id + is + begin + if Is_Record_Type (Etype (N)) then + return Build_Record_Aggr_Code (N, Typ, Target, Flist, Obj); + + else pragma Assert (Is_Array_Type (Etype (N))); + return + Build_Array_Aggr_Code + (N => N, + Ctype => Component_Type (Etype (N)), + Index => First_Index (Typ), + Into => Target, + Scalar_Comp => Is_Scalar_Type (Component_Type (Typ)), + Indexes => No_List, + Flist => Flist); + end if; + end Late_Expansion; + + ---------------------------------- + -- Make_OK_Assignment_Statement -- + ---------------------------------- + + function Make_OK_Assignment_Statement + (Sloc : Source_Ptr; + Name : Node_Id; + Expression : Node_Id) return Node_Id + is + begin + Set_Assignment_OK (Name); + + return Make_Assignment_Statement (Sloc, Name, Expression); + end Make_OK_Assignment_Statement; + + ----------------------- + -- Number_Of_Choices -- + ----------------------- + + function Number_Of_Choices (N : Node_Id) return Nat is + Assoc : Node_Id; + Choice : Node_Id; + + Nb_Choices : Nat := 0; + + begin + if Present (Expressions (N)) then + return 0; + end if; + + Assoc := First (Component_Associations (N)); + while Present (Assoc) loop + Choice := First (Choices (Assoc)); + while Present (Choice) loop + if Nkind (Choice) /= N_Others_Choice then + Nb_Choices := Nb_Choices + 1; + end if; + + Next (Choice); + end loop; + + Next (Assoc); + end loop; + + return Nb_Choices; + end Number_Of_Choices; + + ------------------------------------ + -- Packed_Array_Aggregate_Handled -- + ------------------------------------ + + -- The current version of this procedure will handle at compile time + -- any array aggregate that meets these conditions: + + -- One dimensional, bit packed + -- Underlying packed type is modular type + -- Bounds are within 32-bit Int range + -- All bounds and values are static + + function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Ctyp : constant Entity_Id := Component_Type (Typ); + + Not_Handled : exception; + -- Exception raised if this aggregate cannot be handled + + begin + -- For now, handle only one dimensional bit packed arrays + + if not Is_Bit_Packed_Array (Typ) + or else Number_Dimensions (Typ) > 1 + or else not Is_Modular_Integer_Type (Packed_Array_Type (Typ)) + then + return False; + end if; + + if not Is_Scalar_Type (Component_Type (Typ)) + and then Has_Non_Standard_Rep (Component_Type (Typ)) + then + return False; + end if; + + declare + Csiz : constant Nat := UI_To_Int (Component_Size (Typ)); + + Lo : Node_Id; + Hi : Node_Id; + -- Bounds of index type + + Lob : Uint; + Hib : Uint; + -- Values of bounds if compile time known + + function Get_Component_Val (N : Node_Id) return Uint; + -- Given a expression value N of the component type Ctyp, returns a + -- value of Csiz (component size) bits representing this value. If + -- the value is non-static or any other reason exists why the value + -- cannot be returned, then Not_Handled is raised. + + ----------------------- + -- Get_Component_Val -- + ----------------------- + + function Get_Component_Val (N : Node_Id) return Uint is + Val : Uint; + + begin + -- We have to analyze the expression here before doing any further + -- processing here. The analysis of such expressions is deferred + -- till expansion to prevent some problems of premature analysis. + + Analyze_And_Resolve (N, Ctyp); + + -- Must have a compile time value. String literals have to be + -- converted into temporaries as well, because they cannot easily + -- be converted into their bit representation. + + if not Compile_Time_Known_Value (N) + or else Nkind (N) = N_String_Literal + then + raise Not_Handled; + end if; + + Val := Expr_Rep_Value (N); + + -- Adjust for bias, and strip proper number of bits + + if Has_Biased_Representation (Ctyp) then + Val := Val - Expr_Value (Type_Low_Bound (Ctyp)); + end if; + + return Val mod Uint_2 ** Csiz; + end Get_Component_Val; + + -- Here we know we have a one dimensional bit packed array + + begin + Get_Index_Bounds (First_Index (Typ), Lo, Hi); + + -- Cannot do anything if bounds are dynamic + + if not Compile_Time_Known_Value (Lo) + or else + not Compile_Time_Known_Value (Hi) + then + return False; + end if; + + -- Or are silly out of range of int bounds + + Lob := Expr_Value (Lo); + Hib := Expr_Value (Hi); + + if not UI_Is_In_Int_Range (Lob) + or else + not UI_Is_In_Int_Range (Hib) + then + return False; + end if; + + -- At this stage we have a suitable aggregate for handling at compile + -- time (the only remaining checks are that the values of expressions + -- in the aggregate are compile time known (check is performed by + -- Get_Component_Val), and that any subtypes or ranges are statically + -- known. + + -- If the aggregate is not fully positional at this stage, then + -- convert it to positional form. Either this will fail, in which + -- case we can do nothing, or it will succeed, in which case we have + -- succeeded in handling the aggregate, or it will stay an aggregate, + -- in which case we have failed to handle this case. + + if Present (Component_Associations (N)) then + Convert_To_Positional + (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True); + return Nkind (N) /= N_Aggregate; + end if; + + -- Otherwise we are all positional, so convert to proper value + + declare + Lov : constant Int := UI_To_Int (Lob); + Hiv : constant Int := UI_To_Int (Hib); + + Len : constant Nat := Int'Max (0, Hiv - Lov + 1); + -- The length of the array (number of elements) + + Aggregate_Val : Uint; + -- Value of aggregate. The value is set in the low order bits of + -- this value. For the little-endian case, the values are stored + -- from low-order to high-order and for the big-endian case the + -- values are stored from high-order to low-order. Note that gigi + -- will take care of the conversions to left justify the value in + -- the big endian case (because of left justified modular type + -- processing), so we do not have to worry about that here. + + Lit : Node_Id; + -- Integer literal for resulting constructed value + + Shift : Nat; + -- Shift count from low order for next value + + Incr : Int; + -- Shift increment for loop + + Expr : Node_Id; + -- Next expression from positional parameters of aggregate + + begin + -- For little endian, we fill up the low order bits of the target + -- value. For big endian we fill up the high order bits of the + -- target value (which is a left justified modular value). + + if Bytes_Big_Endian xor Debug_Flag_8 then + Shift := Csiz * (Len - 1); + Incr := -Csiz; + else + Shift := 0; + Incr := +Csiz; + end if; + + -- Loop to set the values + + if Len = 0 then + Aggregate_Val := Uint_0; + else + Expr := First (Expressions (N)); + Aggregate_Val := Get_Component_Val (Expr) * Uint_2 ** Shift; + + for J in 2 .. Len loop + Shift := Shift + Incr; + Next (Expr); + Aggregate_Val := + Aggregate_Val + Get_Component_Val (Expr) * Uint_2 ** Shift; + end loop; + end if; + + -- Now we can rewrite with the proper value + + Lit := + Make_Integer_Literal (Loc, + Intval => Aggregate_Val); + Set_Print_In_Hex (Lit); + + -- Construct the expression using this literal. Note that it is + -- important to qualify the literal with its proper modular type + -- since universal integer does not have the required range and + -- also this is a left justified modular type, which is important + -- in the big-endian case. + + Rewrite (N, + Unchecked_Convert_To (Typ, + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Occurrence_Of (Packed_Array_Type (Typ), Loc), + Expression => Lit))); + + Analyze_And_Resolve (N, Typ); + return True; + end; + end; + + exception + when Not_Handled => + return False; + end Packed_Array_Aggregate_Handled; + + ---------------------------- + -- Has_Mutable_Components -- + ---------------------------- + + function Has_Mutable_Components (Typ : Entity_Id) return Boolean is + Comp : Entity_Id; + + begin + Comp := First_Component (Typ); + while Present (Comp) loop + if Is_Record_Type (Etype (Comp)) + and then Has_Discriminants (Etype (Comp)) + and then not Is_Constrained (Etype (Comp)) + then + return True; + end if; + + Next_Component (Comp); + end loop; + + return False; + end Has_Mutable_Components; + + ------------------------------ + -- Initialize_Discriminants -- + ------------------------------ + + procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Bas : constant Entity_Id := Base_Type (Typ); + Par : constant Entity_Id := Etype (Bas); + Decl : constant Node_Id := Parent (Par); + Ref : Node_Id; + + begin + if Is_Tagged_Type (Bas) + and then Is_Derived_Type (Bas) + and then Has_Discriminants (Par) + and then Has_Discriminants (Bas) + and then Number_Discriminants (Bas) /= Number_Discriminants (Par) + and then Nkind (Decl) = N_Full_Type_Declaration + and then Nkind (Type_Definition (Decl)) = N_Record_Definition + and then Present + (Variant_Part (Component_List (Type_Definition (Decl)))) + and then Nkind (N) /= N_Extension_Aggregate + then + + -- Call init proc to set discriminants. + -- There should eventually be a special procedure for this ??? + + Ref := New_Reference_To (Defining_Identifier (N), Loc); + Insert_Actions_After (N, + Build_Initialization_Call (Sloc (N), Ref, Typ)); + end if; + end Initialize_Discriminants; + + ---------------- + -- Must_Slide -- + ---------------- + + function Must_Slide + (Obj_Type : Entity_Id; + Typ : Entity_Id) return Boolean + is + L1, L2, H1, H2 : Node_Id; + begin + -- No sliding if the type of the object is not established yet, if it is + -- an unconstrained type whose actual subtype comes from the aggregate, + -- or if the two types are identical. + + if not Is_Array_Type (Obj_Type) then + return False; + + elsif not Is_Constrained (Obj_Type) then + return False; + + elsif Typ = Obj_Type then + return False; + + else + -- Sliding can only occur along the first dimension + + Get_Index_Bounds (First_Index (Typ), L1, H1); + Get_Index_Bounds (First_Index (Obj_Type), L2, H2); + + if not Is_Static_Expression (L1) + or else not Is_Static_Expression (L2) + or else not Is_Static_Expression (H1) + or else not Is_Static_Expression (H2) + then + return False; + else + return Expr_Value (L1) /= Expr_Value (L2) + or else Expr_Value (H1) /= Expr_Value (H2); + end if; + end if; + end Must_Slide; + + --------------------------- + -- Safe_Slice_Assignment -- + --------------------------- + + function Safe_Slice_Assignment (N : Node_Id) return Boolean is + Loc : constant Source_Ptr := Sloc (Parent (N)); + Pref : constant Node_Id := Prefix (Name (Parent (N))); + Range_Node : constant Node_Id := Discrete_Range (Name (Parent (N))); + Expr : Node_Id; + L_J : Entity_Id; + L_Iter : Node_Id; + L_Body : Node_Id; + Stat : Node_Id; + + begin + -- Generate: for J in Range loop Pref (J) := Expr; end loop; + + if Comes_From_Source (N) + and then No (Expressions (N)) + and then Nkind (First (Choices (First (Component_Associations (N))))) + = N_Others_Choice + then + Expr := Expression (First (Component_Associations (N))); + L_J := Make_Temporary (Loc, 'J'); + + L_Iter := + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification + (Loc, + Defining_Identifier => L_J, + Discrete_Subtype_Definition => Relocate_Node (Range_Node))); + + L_Body := + Make_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => Relocate_Node (Pref), + Expressions => New_List (New_Occurrence_Of (L_J, Loc))), + Expression => Relocate_Node (Expr)); + + -- Construct the final loop + + Stat := + Make_Implicit_Loop_Statement + (Node => Parent (N), + Identifier => Empty, + Iteration_Scheme => L_Iter, + Statements => New_List (L_Body)); + + -- Set type of aggregate to be type of lhs in assignment, + -- to suppress redundant length checks. + + Set_Etype (N, Etype (Name (Parent (N)))); + + Rewrite (Parent (N), Stat); + Analyze (Parent (N)); + return True; + + else + return False; + end if; + end Safe_Slice_Assignment; + + --------------------- + -- Sort_Case_Table -- + --------------------- + + procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is + L : constant Int := Case_Table'First; + U : constant Int := Case_Table'Last; + K : Int; + J : Int; + T : Case_Bounds; + + begin + K := L; + while K /= U loop + T := Case_Table (K + 1); + + J := K + 1; + while J /= L + and then Expr_Value (Case_Table (J - 1).Choice_Lo) > + Expr_Value (T.Choice_Lo) + loop + Case_Table (J) := Case_Table (J - 1); + J := J - 1; + end loop; + + Case_Table (J) := T; + K := K + 1; + end loop; + end Sort_Case_Table; + + ---------------------------- + -- Static_Array_Aggregate -- + ---------------------------- + + function Static_Array_Aggregate (N : Node_Id) return Boolean is + Bounds : constant Node_Id := Aggregate_Bounds (N); + + Typ : constant Entity_Id := Etype (N); + Comp_Type : constant Entity_Id := Component_Type (Typ); + Agg : Node_Id; + Expr : Node_Id; + Lo : Node_Id; + Hi : Node_Id; + + begin + if Is_Tagged_Type (Typ) + or else Is_Controlled (Typ) + or else Is_Packed (Typ) + then + return False; + end if; + + if Present (Bounds) + and then Nkind (Bounds) = N_Range + and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal + and then Nkind (High_Bound (Bounds)) = N_Integer_Literal + then + Lo := Low_Bound (Bounds); + Hi := High_Bound (Bounds); + + if No (Component_Associations (N)) then + + -- Verify that all components are static integers + + Expr := First (Expressions (N)); + while Present (Expr) loop + if Nkind (Expr) /= N_Integer_Literal then + return False; + end if; + + Next (Expr); + end loop; + + return True; + + else + -- We allow only a single named association, either a static + -- range or an others_clause, with a static expression. + + Expr := First (Component_Associations (N)); + + if Present (Expressions (N)) then + return False; + + elsif Present (Next (Expr)) then + return False; + + elsif Present (Next (First (Choices (Expr)))) then + return False; + + else + -- The aggregate is static if all components are literals, + -- or else all its components are static aggregates for the + -- component type. We also limit the size of a static aggregate + -- to prevent runaway static expressions. + + if Is_Array_Type (Comp_Type) + or else Is_Record_Type (Comp_Type) + then + if Nkind (Expression (Expr)) /= N_Aggregate + or else + not Compile_Time_Known_Aggregate (Expression (Expr)) + then + return False; + end if; + + elsif Nkind (Expression (Expr)) /= N_Integer_Literal then + return False; + + elsif not Aggr_Size_OK (N, Typ) then + return False; + end if; + + -- Create a positional aggregate with the right number of + -- copies of the expression. + + Agg := Make_Aggregate (Sloc (N), New_List, No_List); + + for I in UI_To_Int (Intval (Lo)) .. UI_To_Int (Intval (Hi)) + loop + Append_To + (Expressions (Agg), New_Copy (Expression (Expr))); + + -- The copied expression must be analyzed and resolved. + -- Besides setting the type, this ensures that static + -- expressions are appropriately marked as such. + + Analyze_And_Resolve + (Last (Expressions (Agg)), Component_Type (Typ)); + end loop; + + Set_Aggregate_Bounds (Agg, Bounds); + Set_Etype (Agg, Typ); + Set_Analyzed (Agg); + Rewrite (N, Agg); + Set_Compile_Time_Known_Aggregate (N); + + return True; + end if; + end if; + + else + return False; + end if; + end Static_Array_Aggregate; + +end Exp_Aggr; diff --git a/gcc/ada/exp_aggr.ads b/gcc/ada/exp_aggr.ads new file mode 100644 index 000000000..5d14f1d5f --- /dev/null +++ b/gcc/ada/exp_aggr.ads @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ A G G 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Types; use Types; + +package Exp_Aggr is + + procedure Expand_N_Aggregate (N : Node_Id); + procedure Expand_N_Extension_Aggregate (N : Node_Id); + + function Is_Delayed_Aggregate (N : Node_Id) return Boolean; + -- Returns True if N is an aggregate of some kind whose Expansion_Delayed + -- flag is set (see sinfo for meaning of flag). + + procedure Convert_Aggr_In_Object_Decl (N : Node_Id); + -- N is a N_Object_Declaration with an expression which must be an + -- N_Aggregate or N_Extension_Aggregate with Expansion_Delayed. + -- This procedure performs in-place aggregate assignment. + + procedure Convert_Aggr_In_Allocator + (Alloc : Node_Id; + Decl : Node_Id; + Aggr : Node_Id); + -- Alloc is the allocator whose expression is the aggregate Aggr. + -- Decl is an N_Object_Declaration created during allocator expansion. + -- This procedure performs in-place aggregate assignment into the + -- temporary declared in Decl, and the allocator becomes an access to + -- that temporary. + + procedure Convert_Aggr_In_Assignment (N : Node_Id); + -- If the right-hand side of an assignment is an aggregate, expand the + -- statement into a series of individual component assignments. This is + -- done if there are non-static values involved in either the bounds or + -- the components, and the aggregate cannot be handled as a whole by the + -- backend. + + function Static_Array_Aggregate (N : Node_Id) return Boolean; + -- N is an array aggregate that may have a component association with + -- an others clause and a range. If bounds are static and the expressions + -- are compile-time known constants, rewrite N as a purely positional + -- aggregate, to be use to initialize variables and components of the type + -- without generating elaboration code. +end Exp_Aggr; diff --git a/gcc/ada/exp_atag.adb b/gcc/ada/exp_atag.adb new file mode 100644 index 000000000..7ed2a3f5f --- /dev/null +++ b/gcc/ada/exp_atag.adb @@ -0,0 +1,904 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ A T A G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2006-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Elists; use Elists; +with Exp_Disp; use Exp_Disp; +with Exp_Util; use Exp_Util; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Rtsfind; use Rtsfind; +with Sinfo; use Sinfo; +with Sem_Aux; use Sem_Aux; +with Sem_Disp; use Sem_Disp; +with Sem_Util; use Sem_Util; +with Stand; use Stand; +with Snames; use Snames; +with Tbuild; use Tbuild; + +package body Exp_Atag is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Build_DT + (Loc : Source_Ptr; + Tag_Node : Node_Id) return Node_Id; + -- Build code that displaces the Tag to reference the base of the wrapper + -- record + -- + -- Generates: + -- To_Dispatch_Table_Ptr + -- (To_Address (Tag_Node) - Tag_Node.Prims_Ptr'Position); + + function Build_TSD + (Loc : Source_Ptr; + Tag_Node_Addr : Node_Id) return Node_Id; + -- Build code that retrieves the address of the record containing the Type + -- Specific Data generated by GNAT. + -- + -- Generate: To_Type_Specific_Data_Ptr + -- (To_Addr_Ptr (Tag_Node_Addr - Typeinfo_Offset).all); + + ------------------------------------------------ + -- Build_Common_Dispatching_Select_Statements -- + ------------------------------------------------ + + procedure Build_Common_Dispatching_Select_Statements + (Loc : Source_Ptr; + DT_Ptr : Entity_Id; + Stmts : List_Id) + is + begin + -- Generate: + -- C := get_prim_op_kind (tag! (VP), S); + + -- where C is the out parameter capturing the call kind and S is the + -- dispatch table slot number. + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uC), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), + Make_Identifier (Loc, Name_uS))))); + + -- Generate: + + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure; + -- then + -- F := True; + -- return; + + -- where F is the out parameter capturing the status of a potential + -- entry call. + + Append_To (Stmts, + Make_If_Statement (Loc, + + Condition => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => Make_Identifier (Loc, Name_uC), + Right_Opnd => + New_Reference_To (RTE (RE_POK_Procedure), Loc)), + Right_Opnd => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => Make_Identifier (Loc, Name_uC), + Right_Opnd => + New_Reference_To + (RTE (RE_POK_Protected_Procedure), Loc)), + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => Make_Identifier (Loc, Name_uC), + Right_Opnd => + New_Reference_To + (RTE (RE_POK_Task_Procedure), Loc)))), + + Then_Statements => + New_List ( + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uF), + Expression => New_Reference_To (Standard_True, Loc)), + Make_Simple_Return_Statement (Loc)))); + end Build_Common_Dispatching_Select_Statements; + + ------------------------- + -- Build_CW_Membership -- + ------------------------- + + procedure Build_CW_Membership + (Loc : Source_Ptr; + Obj_Tag_Node : in out Node_Id; + Typ_Tag_Node : Node_Id; + Related_Nod : Node_Id; + New_Node : out Node_Id) + is + Tag_Addr : constant Entity_Id := Make_Temporary (Loc, 'D', Obj_Tag_Node); + Obj_TSD : constant Entity_Id := Make_Temporary (Loc, 'D'); + Typ_TSD : constant Entity_Id := Make_Temporary (Loc, 'D'); + Index : constant Entity_Id := Make_Temporary (Loc, 'D'); + + begin + -- Generate: + + -- Tag_Addr : constant Tag := Address!(Obj_Tag); + -- Obj_TSD : constant Type_Specific_Data_Ptr + -- := Build_TSD (Tag_Addr); + -- Typ_TSD : constant Type_Specific_Data_Ptr + -- := Build_TSD (Address!(Typ_Tag)); + -- Index : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth + -- Index > 0 and then Obj_TSD.Tags_Table (Index) = Typ'Tag + + Insert_Action (Related_Nod, + Make_Object_Declaration (Loc, + Defining_Identifier => Tag_Addr, + Constant_Present => True, + Object_Definition => New_Reference_To (RTE (RE_Address), Loc), + Expression => Unchecked_Convert_To + (RTE (RE_Address), Obj_Tag_Node))); + + -- Unchecked_Convert_To relocates Obj_Tag_Node and therefore we must + -- update it. + + Obj_Tag_Node := Expression (Expression (Parent (Tag_Addr))); + + Insert_Action (Related_Nod, + Make_Object_Declaration (Loc, + Defining_Identifier => Obj_TSD, + Constant_Present => True, + Object_Definition => New_Reference_To + (RTE (RE_Type_Specific_Data_Ptr), Loc), + Expression => Build_TSD (Loc, New_Reference_To (Tag_Addr, Loc)))); + + Insert_Action (Related_Nod, + Make_Object_Declaration (Loc, + Defining_Identifier => Typ_TSD, + Constant_Present => True, + Object_Definition => New_Reference_To + (RTE (RE_Type_Specific_Data_Ptr), Loc), + Expression => Build_TSD (Loc, + Unchecked_Convert_To (RTE (RE_Address), + Typ_Tag_Node)))); + + Insert_Action (Related_Nod, + Make_Object_Declaration (Loc, + Defining_Identifier => Index, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), + Expression => + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Obj_TSD, Loc), + Selector_Name => + New_Reference_To + (RTE_Record_Component (RE_Idepth), Loc)), + + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Typ_TSD, Loc), + Selector_Name => + New_Reference_To + (RTE_Record_Component (RE_Idepth), Loc))))); + + New_Node := + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Ge (Loc, + Left_Opnd => New_Occurrence_Of (Index, Loc), + Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), + + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Indexed_Component (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Obj_TSD, Loc), + Selector_Name => + New_Reference_To + (RTE_Record_Component (RE_Tags_Table), Loc)), + Expressions => + New_List (New_Occurrence_Of (Index, Loc))), + + Right_Opnd => Typ_Tag_Node)); + end Build_CW_Membership; + + -------------- + -- Build_DT -- + -------------- + + function Build_DT + (Loc : Source_Ptr; + Tag_Node : Node_Id) return Node_Id + is + begin + return + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_DT), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), Tag_Node))); + end Build_DT; + + ---------------------------- + -- Build_Get_Access_Level -- + ---------------------------- + + function Build_Get_Access_Level + (Loc : Source_Ptr; + Tag_Node : Node_Id) return Node_Id + is + begin + return + Make_Selected_Component (Loc, + Prefix => + Build_TSD (Loc, + Unchecked_Convert_To (RTE (RE_Address), Tag_Node)), + Selector_Name => + New_Reference_To + (RTE_Record_Component (RE_Access_Level), Loc)); + end Build_Get_Access_Level; + + ------------------------------------------ + -- Build_Get_Predefined_Prim_Op_Address -- + ------------------------------------------ + + procedure Build_Get_Predefined_Prim_Op_Address + (Loc : Source_Ptr; + Position : Uint; + Tag_Node : in out Node_Id; + New_Node : out Node_Id) + is + Ctrl_Tag : Node_Id; + + begin + Ctrl_Tag := Unchecked_Convert_To (RTE (RE_Address), Tag_Node); + + -- Unchecked_Convert_To relocates the controlling tag node and therefore + -- we must update it. + + Tag_Node := Expression (Ctrl_Tag); + + -- Build code that retrieves the address of the dispatch table + -- containing the predefined Ada primitives: + -- + -- Generate: + -- To_Predef_Prims_Table_Ptr + -- (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all); + + New_Node := + Make_Indexed_Component (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Addr_Ptr), + Make_Function_Call (Loc, + Name => + Make_Expanded_Name (Loc, + Chars => Name_Op_Subtract, + Prefix => + New_Reference_To + (RTU_Entity (System_Storage_Elements), Loc), + Selector_Name => + Make_Identifier (Loc, Name_Op_Subtract)), + Parameter_Associations => New_List ( + Ctrl_Tag, + New_Reference_To + (RTE (RE_DT_Predef_Prims_Offset), Loc)))))), + Expressions => + New_List (Make_Integer_Literal (Loc, Position))); + end Build_Get_Predefined_Prim_Op_Address; + + ----------------------------- + -- Build_Inherit_CPP_Prims -- + ----------------------------- + + function Build_Inherit_CPP_Prims (Typ : Entity_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (Typ); + CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ); + CPP_Table : array (1 .. CPP_Nb_Prims) of Boolean := (others => False); + CPP_Typ : constant Entity_Id := Enclosing_CPP_Parent (Typ); + Result : constant List_Id := New_List; + Parent_Typ : constant Entity_Id := Etype (Typ); + E : Entity_Id; + Elmt : Elmt_Id; + Parent_Tag : Entity_Id; + Prim : Entity_Id; + Prim_Pos : Nat; + Typ_Tag : Entity_Id; + + begin + pragma Assert (not Is_CPP_Class (Typ)); + + -- No code needed if this type has no primitives inherited from C++ + + if CPP_Nb_Prims = 0 then + return Result; + end if; + + -- Stage 1: Inherit and override C++ slots of the primary dispatch table + + -- Generate: + -- Typ'Tag (Prim_Pos) := Prim'Unrestricted_Access; + + Parent_Tag := Node (First_Elmt (Access_Disp_Table (Parent_Typ))); + Typ_Tag := Node (First_Elmt (Access_Disp_Table (Typ))); + + Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Elmt) loop + Prim := Node (Elmt); + E := Ultimate_Alias (Prim); + Prim_Pos := UI_To_Int (DT_Position (E)); + + -- Skip predefined, abstract, and eliminated primitives. Skip also + -- primitives not located in the C++ part of the dispatch table. + + if not Is_Predefined_Dispatching_Operation (Prim) + and then not Is_Predefined_Dispatching_Operation (E) + and then not Present (Interface_Alias (Prim)) + and then not Is_Abstract_Subprogram (E) + and then not Is_Eliminated (E) + and then Prim_Pos <= CPP_Nb_Prims + and then Find_Dispatching_Type (E) = Typ + then + -- Remember that this slot is used + + pragma Assert (CPP_Table (Prim_Pos) = False); + CPP_Table (Prim_Pos) := True; + + Append_To (Result, + Make_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To + (Node (Last_Elmt (Access_Disp_Table (Typ))), + New_Reference_To (Typ_Tag, Loc))), + Expressions => + New_List (Make_Integer_Literal (Loc, Prim_Pos))), + + Expression => + Unchecked_Convert_To (RTE (RE_Prim_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (E, Loc), + Attribute_Name => Name_Unrestricted_Access)))); + end if; + + Next_Elmt (Elmt); + end loop; + + -- If all primitives have been overridden then there is no need to copy + -- from Typ's parent its dispatch table. Otherwise, if some primitive is + -- inherited from the parent we copy only the C++ part of the dispatch + -- table from the parent before the assignments that initialize the + -- overridden primitives. + + -- Generate: + + -- type CPP_TypG is array (1 .. CPP_Nb_Prims) ofd Prim_Ptr; + -- type CPP_TypH is access CPP_TypG; + -- CPP_TypG!(Typ_Tag).all := CPP_TypG!(Parent_Tag).all; + + -- Note: There is no need to duplicate the declarations of CPP_TypG and + -- CPP_TypH because, for expansion of dispatching calls, these + -- entities are stored in the last elements of Access_Disp_Table. + + for J in CPP_Table'Range loop + if not CPP_Table (J) then + Prepend_To (Result, + Make_Assignment_Statement (Loc, + Name => + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To + (Node (Last_Elmt (Access_Disp_Table (CPP_Typ))), + New_Reference_To (Typ_Tag, Loc))), + Expression => + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To + (Node (Last_Elmt (Access_Disp_Table (CPP_Typ))), + New_Reference_To (Parent_Tag, Loc))))); + exit; + end if; + end loop; + + -- Stage 2: Inherit and override C++ slots of secondary dispatch tables + + declare + Iface : Entity_Id; + Iface_Nb_Prims : Nat; + Parent_Ifaces_List : Elist_Id; + Parent_Ifaces_Comp_List : Elist_Id; + Parent_Ifaces_Tag_List : Elist_Id; + Parent_Iface_Tag_Elmt : Elmt_Id; + Typ_Ifaces_List : Elist_Id; + Typ_Ifaces_Comp_List : Elist_Id; + Typ_Ifaces_Tag_List : Elist_Id; + Typ_Iface_Tag_Elmt : Elmt_Id; + + begin + Collect_Interfaces_Info + (T => Parent_Typ, + Ifaces_List => Parent_Ifaces_List, + Components_List => Parent_Ifaces_Comp_List, + Tags_List => Parent_Ifaces_Tag_List); + + Collect_Interfaces_Info + (T => Typ, + Ifaces_List => Typ_Ifaces_List, + Components_List => Typ_Ifaces_Comp_List, + Tags_List => Typ_Ifaces_Tag_List); + + Parent_Iface_Tag_Elmt := First_Elmt (Parent_Ifaces_Tag_List); + Typ_Iface_Tag_Elmt := First_Elmt (Typ_Ifaces_Tag_List); + while Present (Parent_Iface_Tag_Elmt) loop + Parent_Tag := Node (Parent_Iface_Tag_Elmt); + Typ_Tag := Node (Typ_Iface_Tag_Elmt); + + pragma Assert + (Related_Type (Parent_Tag) = Related_Type (Typ_Tag)); + Iface := Related_Type (Parent_Tag); + + Iface_Nb_Prims := + UI_To_Int (DT_Entry_Count (First_Tag_Component (Iface))); + + if Iface_Nb_Prims > 0 then + + -- Update slots of overridden primitives + + declare + Last_Nod : constant Node_Id := Last (Result); + Nb_Prims : constant Nat := UI_To_Int + (DT_Entry_Count + (First_Tag_Component (Iface))); + Elmt : Elmt_Id; + Prim : Entity_Id; + E : Entity_Id; + Prim_Pos : Nat; + + Prims_Table : array (1 .. Nb_Prims) of Boolean; + + begin + Prims_Table := (others => False); + + Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Elmt) loop + Prim := Node (Elmt); + E := Ultimate_Alias (Prim); + + if not Is_Predefined_Dispatching_Operation (Prim) + and then Present (Interface_Alias (Prim)) + and then Find_Dispatching_Type (Interface_Alias (Prim)) + = Iface + and then not Is_Abstract_Subprogram (E) + and then not Is_Eliminated (E) + and then Find_Dispatching_Type (E) = Typ + then + Prim_Pos := UI_To_Int (DT_Position (Prim)); + + -- Remember that this slot is already initialized + + pragma Assert (Prims_Table (Prim_Pos) = False); + Prims_Table (Prim_Pos) := True; + + Append_To (Result, + Make_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To + (Node + (Last_Elmt + (Access_Disp_Table (Iface))), + New_Reference_To (Typ_Tag, Loc))), + Expressions => + New_List + (Make_Integer_Literal (Loc, Prim_Pos))), + + Expression => + Unchecked_Convert_To (RTE (RE_Prim_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (E, Loc), + Attribute_Name => + Name_Unrestricted_Access)))); + end if; + + Next_Elmt (Elmt); + end loop; + + -- Check if all primitives from the parent have been + -- overridden (to avoid copying the whole secondary + -- table from the parent). + + -- IfaceG!(Typ_Sec_Tag).all := IfaceG!(Parent_Sec_Tag).all; + + for J in Prims_Table'Range loop + if not Prims_Table (J) then + Insert_After (Last_Nod, + Make_Assignment_Statement (Loc, + Name => + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To + (Node (Last_Elmt (Access_Disp_Table (Iface))), + New_Reference_To (Typ_Tag, Loc))), + Expression => + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To + (Node (Last_Elmt (Access_Disp_Table (Iface))), + New_Reference_To (Parent_Tag, Loc))))); + exit; + end if; + end loop; + end; + end if; + + Next_Elmt (Typ_Iface_Tag_Elmt); + Next_Elmt (Parent_Iface_Tag_Elmt); + end loop; + end; + + return Result; + end Build_Inherit_CPP_Prims; + + ------------------------- + -- Build_Inherit_Prims -- + ------------------------- + + function Build_Inherit_Prims + (Loc : Source_Ptr; + Typ : Entity_Id; + Old_Tag_Node : Node_Id; + New_Tag_Node : Node_Id; + Num_Prims : Nat) return Node_Id + is + begin + if RTE_Available (RE_DT) then + return + Make_Assignment_Statement (Loc, + Name => + Make_Slice (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => + Build_DT (Loc, New_Tag_Node), + Selector_Name => + New_Reference_To + (RTE_Record_Component (RE_Prims_Ptr), Loc)), + Discrete_Range => + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Make_Integer_Literal (Loc, Num_Prims))), + + Expression => + Make_Slice (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => + Build_DT (Loc, Old_Tag_Node), + Selector_Name => + New_Reference_To + (RTE_Record_Component (RE_Prims_Ptr), Loc)), + Discrete_Range => + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Make_Integer_Literal (Loc, Num_Prims)))); + else + return + Make_Assignment_Statement (Loc, + Name => + Make_Slice (Loc, + Prefix => + Unchecked_Convert_To + (Node (Last_Elmt (Access_Disp_Table (Typ))), + New_Tag_Node), + Discrete_Range => + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Make_Integer_Literal (Loc, Num_Prims))), + + Expression => + Make_Slice (Loc, + Prefix => + Unchecked_Convert_To + (Node (Last_Elmt (Access_Disp_Table (Typ))), + Old_Tag_Node), + Discrete_Range => + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Make_Integer_Literal (Loc, Num_Prims)))); + end if; + end Build_Inherit_Prims; + + ------------------------------- + -- Build_Get_Prim_Op_Address -- + ------------------------------- + + procedure Build_Get_Prim_Op_Address + (Loc : Source_Ptr; + Typ : Entity_Id; + Position : Uint; + Tag_Node : in out Node_Id; + New_Node : out Node_Id) + is + New_Prefix : Node_Id; + + begin + pragma Assert + (Position <= DT_Entry_Count (First_Tag_Component (Typ))); + + -- At the end of the Access_Disp_Table list we have the type + -- declaration required to convert the tag into a pointer to + -- the prims_ptr table (see Freeze_Record_Type). + + New_Prefix := + Unchecked_Convert_To + (Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node); + + -- Unchecked_Convert_To relocates the controlling tag node and therefore + -- we must update it. + + Tag_Node := Expression (New_Prefix); + + New_Node := + Make_Indexed_Component (Loc, + Prefix => New_Prefix, + Expressions => New_List (Make_Integer_Literal (Loc, Position))); + end Build_Get_Prim_Op_Address; + + ----------------------------- + -- Build_Get_Transportable -- + ----------------------------- + + function Build_Get_Transportable + (Loc : Source_Ptr; + Tag_Node : Node_Id) return Node_Id + is + begin + return + Make_Selected_Component (Loc, + Prefix => + Build_TSD (Loc, + Unchecked_Convert_To (RTE (RE_Address), Tag_Node)), + Selector_Name => + New_Reference_To + (RTE_Record_Component (RE_Transportable), Loc)); + end Build_Get_Transportable; + + ------------------------------------ + -- Build_Inherit_Predefined_Prims -- + ------------------------------------ + + function Build_Inherit_Predefined_Prims + (Loc : Source_Ptr; + Old_Tag_Node : Node_Id; + New_Tag_Node : Node_Id) return Node_Id + is + begin + return + Make_Assignment_Statement (Loc, + Name => + Make_Slice (Loc, + Prefix => + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Addr_Ptr), + New_Tag_Node)))), + Discrete_Range => Make_Range (Loc, + Make_Integer_Literal (Loc, Uint_1), + New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))), + + Expression => + Make_Slice (Loc, + Prefix => + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Addr_Ptr), + Old_Tag_Node)))), + Discrete_Range => + Make_Range (Loc, + Make_Integer_Literal (Loc, 1), + New_Reference_To (RTE (RE_Max_Predef_Prims), Loc)))); + end Build_Inherit_Predefined_Prims; + + ------------------------- + -- Build_Offset_To_Top -- + ------------------------- + + function Build_Offset_To_Top + (Loc : Source_Ptr; + This_Node : Node_Id) return Node_Id + is + Tag_Node : Node_Id; + + begin + Tag_Node := + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Tag_Ptr), This_Node)); + + return + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr), + Make_Function_Call (Loc, + Name => + Make_Expanded_Name (Loc, + Chars => Name_Op_Subtract, + Prefix => + New_Reference_To + (RTU_Entity (System_Storage_Elements), Loc), + Selector_Name => Make_Identifier (Loc, Name_Op_Subtract)), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), Tag_Node), + New_Reference_To + (RTE (RE_DT_Offset_To_Top_Offset), Loc))))); + end Build_Offset_To_Top; + + ------------------------------------------ + -- Build_Set_Predefined_Prim_Op_Address -- + ------------------------------------------ + + function Build_Set_Predefined_Prim_Op_Address + (Loc : Source_Ptr; + Tag_Node : Node_Id; + Position : Uint; + Address_Node : Node_Id) return Node_Id + is + begin + return + Make_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Addr_Ptr), Tag_Node))), + Expressions => + New_List (Make_Integer_Literal (Loc, Position))), + + Expression => Address_Node); + end Build_Set_Predefined_Prim_Op_Address; + + ------------------------------- + -- Build_Set_Prim_Op_Address -- + ------------------------------- + + function Build_Set_Prim_Op_Address + (Loc : Source_Ptr; + Typ : Entity_Id; + Tag_Node : Node_Id; + Position : Uint; + Address_Node : Node_Id) return Node_Id + is + Ctrl_Tag : Node_Id := Tag_Node; + New_Node : Node_Id; + + begin + Build_Get_Prim_Op_Address (Loc, Typ, Position, Ctrl_Tag, New_Node); + + return + Make_Assignment_Statement (Loc, + Name => New_Node, + Expression => Address_Node); + end Build_Set_Prim_Op_Address; + + ----------------------------- + -- Build_Set_Size_Function -- + ----------------------------- + + function Build_Set_Size_Function + (Loc : Source_Ptr; + Tag_Node : Node_Id; + Size_Func : Entity_Id) return Node_Id is + begin + pragma Assert (Chars (Size_Func) = Name_uSize + and then RTE_Record_Component_Available (RE_Size_Func)); + return + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => + Build_TSD (Loc, + Unchecked_Convert_To (RTE (RE_Address), Tag_Node)), + Selector_Name => + New_Reference_To + (RTE_Record_Component (RE_Size_Func), Loc)), + Expression => + Unchecked_Convert_To (RTE (RE_Size_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Size_Func, Loc), + Attribute_Name => Name_Unrestricted_Access))); + end Build_Set_Size_Function; + + ------------------------------------ + -- Build_Set_Static_Offset_To_Top -- + ------------------------------------ + + function Build_Set_Static_Offset_To_Top + (Loc : Source_Ptr; + Iface_Tag : Node_Id; + Offset_Value : Node_Id) return Node_Id is + begin + return + Make_Assignment_Statement (Loc, + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr), + Make_Function_Call (Loc, + Name => + Make_Expanded_Name (Loc, + Chars => Name_Op_Subtract, + Prefix => + New_Reference_To + (RTU_Entity (System_Storage_Elements), Loc), + Selector_Name => Make_Identifier (Loc, Name_Op_Subtract)), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), Iface_Tag), + New_Reference_To + (RTE (RE_DT_Offset_To_Top_Offset), Loc))))), + Offset_Value); + end Build_Set_Static_Offset_To_Top; + + --------------- + -- Build_TSD -- + --------------- + + function Build_TSD + (Loc : Source_Ptr; + Tag_Node_Addr : Node_Id) return Node_Id is + begin + return + Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr), + Make_Explicit_Dereference (Loc, + Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr), + Make_Function_Call (Loc, + Name => + Make_Expanded_Name (Loc, + Chars => Name_Op_Subtract, + Prefix => + New_Reference_To + (RTU_Entity (System_Storage_Elements), Loc), + Selector_Name => Make_Identifier (Loc, Name_Op_Subtract)), + + Parameter_Associations => New_List ( + Tag_Node_Addr, + New_Reference_To + (RTE (RE_DT_Typeinfo_Ptr_Size), Loc)))))); + end Build_TSD; + +end Exp_Atag; diff --git a/gcc/ada/exp_atag.ads b/gcc/ada/exp_atag.ads new file mode 100644 index 000000000..384a2d0ba --- /dev/null +++ b/gcc/ada/exp_atag.ads @@ -0,0 +1,193 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ A T A G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2006-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 involved in the frontend expansion of +-- subprograms of package Ada.Tags + +with Types; use Types; +with Uintp; use Uintp; + +package Exp_Atag is + + -- Note: In all the subprograms of this package formal 'Loc' is the source + -- location used in constructing the corresponding nodes. + + procedure Build_Common_Dispatching_Select_Statements + (Loc : Source_Ptr; + DT_Ptr : Entity_Id; + Stmts : List_Id); + -- Ada 2005 (AI-345): Generate statements that are common between timed, + -- asynchronous, and conditional select expansion. + + procedure Build_CW_Membership + (Loc : Source_Ptr; + Obj_Tag_Node : in out Node_Id; + Typ_Tag_Node : Node_Id; + Related_Nod : Node_Id; + New_Node : out Node_Id); + -- Build code that returns true if Obj_Tag is in Typ_Tag'Class. Each DT + -- has a table of ancestors and its inheritance level (Idepth). Obj is in + -- Typ'Class if Typ'Tag is found in the table of ancestors referenced by + -- Obj'Tag. Knowing the level of inheritance of both types, this can be + -- computed in constant time by the formula: + -- + -- Index := TSD (Obj'Tag).Idepth - TSD (Typ'Tag).Idepth; + -- Index > 0 and then TSD (Obj'Tag).Tags_Table (Index) = Typ'Tag + -- + -- Related_Nod is the node where the implicit declaration of variable Index + -- is inserted. Obj_Tag_Node is relocated. + + function Build_Get_Access_Level + (Loc : Source_Ptr; + Tag_Node : Node_Id) return Node_Id; + -- Build code that retrieves the accessibility level of the tagged type. + -- + -- Generates: TSD (Tag).Access_Level + + procedure Build_Get_Predefined_Prim_Op_Address + (Loc : Source_Ptr; + Position : Uint; + Tag_Node : in out Node_Id; + New_Node : out Node_Id); + -- Given a pointer to a dispatch table (T) and a position in the DT, build + -- code that gets the address of the predefined virtual function stored in + -- it (used for dispatching calls). Tag_Node is relocated. + -- + -- Generates: Predefined_DT (Tag).D (Position); + + procedure Build_Get_Prim_Op_Address + (Loc : Source_Ptr; + Typ : Entity_Id; + Position : Uint; + Tag_Node : in out Node_Id; + New_Node : out Node_Id); + -- Build code that retrieves the address of the virtual function stored in + -- a given position of the dispatch table (used for dispatching calls). + -- Tag_Node is relocated. + -- + -- Generates: To_Tag (Tag).D (Position); + + function Build_Get_Transportable + (Loc : Source_Ptr; + Tag_Node : Node_Id) return Node_Id; + -- Build code that retrieves the value of the Transportable flag for + -- the given Tag. + -- + -- Generates: TSD (Tag).Transportable; + + function Build_Inherit_CPP_Prims (Typ : Entity_Id) return List_Id; + -- Build code that copies from Typ's parent the dispatch table slots of + -- inherited primitives and updates slots of overridden primitives. The + -- generated code handles primary and secondary dispatch tables of Typ. + + function Build_Inherit_Predefined_Prims + (Loc : Source_Ptr; + Old_Tag_Node : Node_Id; + New_Tag_Node : Node_Id) return Node_Id; + -- Build code that inherits the predefined primitives of the parent. + -- + -- Generates: Predefined_DT (New_T).D (All_Predefined_Prims) := + -- Predefined_DT (Old_T).D (All_Predefined_Prims); + -- + -- Required to build non-library level dispatch tables. Also required + -- when compiling without static dispatch tables support. + + function Build_Inherit_Prims + (Loc : Source_Ptr; + Typ : Entity_Id; + Old_Tag_Node : Node_Id; + New_Tag_Node : Node_Id; + Num_Prims : Nat) return Node_Id; + -- Build code that inherits Num_Prims user-defined primitives from the + -- dispatch table of the parent type of tagged type Typ. It is used to + -- copy the dispatch table of the parent in the following cases: + -- a) case of derivations of CPP_Class types + -- b) tagged types whose dispatch table is not statically allocated + -- + -- Generates: + -- New_Tag.Prims_Ptr (1 .. Num_Prims) := + -- Old_Tag.Prims_Ptr (1 .. Num_Prims); + + function Build_Offset_To_Top + (Loc : Source_Ptr; + This_Node : Node_Id) return Node_Id; + -- Build code that references the Offset_To_Top component of the primary + -- or secondary dispatch table associated with This_Node. This subprogram + -- provides a subset of the functionality provided by the function + -- Offset_To_Top of package Ada.Tags, and is only called by the frontend + -- when such routine is not available in a configurable runtime. + -- + -- Generates: + -- Offset_To_Top_Ptr + -- (Address!(Tag_Ptr!(This).all) - Offset_To_Top_Offset) + + function Build_Set_Predefined_Prim_Op_Address + (Loc : Source_Ptr; + Tag_Node : Node_Id; + Position : Uint; + Address_Node : Node_Id) return Node_Id; + -- Build code that saves the address of a virtual function in a given + -- Position of the portion of the dispatch table associated with the + -- predefined primitives of Tag. Called from Exp_Disp.Fill_DT_Entry + -- and Exp_Disp.Fill_Secondary_DT_Entry. It is used for: + -- 1) Filling the dispatch table of CPP_Class types. + -- 2) Late overriding (see Check_Dispatching_Operation). + -- + -- Generates: Predefined_DT (Tag).D (Position) := Value + + function Build_Set_Prim_Op_Address + (Loc : Source_Ptr; + Typ : Entity_Id; + Tag_Node : Node_Id; + Position : Uint; + Address_Node : Node_Id) return Node_Id; + -- Build code that saves the address of a virtual function in a given + -- Position of the dispatch table associated with the Tag. Called from + -- Exp_Disp.Fill_DT_Entry and Exp_Disp.Fill_Secondary_DT_Entry. Used for: + -- 1) Filling the dispatch table of CPP_Class types. + -- 2) Late overriding (see Check_Dispatching_Operation). + -- + -- Generates: Tag.D (Position) := Value + + function Build_Set_Size_Function + (Loc : Source_Ptr; + Tag_Node : Node_Id; + Size_Func : Entity_Id) return Node_Id; + -- Build code that saves in the TSD the address of the function + -- calculating _size of the object. + + function Build_Set_Static_Offset_To_Top + (Loc : Source_Ptr; + Iface_Tag : Node_Id; + Offset_Value : Node_Id) return Node_Id; + -- Build code that initialize the Offset_To_Top component of the + -- secondary dispatch table referenced by Iface_Tag. + -- + -- Generates: + -- Offset_To_Top_Ptr + -- (Address!(Tag_Ptr!(This).all) - Offset_To_Top_Offset).all + -- := Offset_Value + +end Exp_Atag; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb new file mode 100644 index 000000000..fe92f98cb --- /dev/null +++ b/gcc/ada/exp_attr.adb @@ -0,0 +1,5791 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ A T T 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. -- +-- -- +-- You should have received a copy of the GNU General Public License along -- +-- with this program; see file COPYING3. If not see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Einfo; use Einfo; +with Elists; use Elists; +with Exp_Atag; use Exp_Atag; +with Exp_Ch2; use Exp_Ch2; +with Exp_Ch3; use Exp_Ch3; +with Exp_Ch6; use Exp_Ch6; +with Exp_Ch9; use Exp_Ch9; +with Exp_Dist; use Exp_Dist; +with Exp_Imgv; use Exp_Imgv; +with Exp_Pakd; use Exp_Pakd; +with Exp_Strm; use Exp_Strm; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Exp_VFpt; use Exp_VFpt; +with Fname; use Fname; +with Freeze; use Freeze; +with Gnatvsn; use Gnatvsn; +with Itypes; use Itypes; +with Lib; use Lib; +with Namet; use Namet; +with Nmake; use Nmake; +with Nlists; use Nlists; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch7; use Sem_Ch7; +with Sem_Ch8; use Sem_Ch8; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; +with Uname; use Uname; +with Validsw; use Validsw; + +package body Exp_Attr is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Compile_Stream_Body_In_Scope + (N : Node_Id; + Decl : Node_Id; + Arr : Entity_Id; + Check : Boolean); + -- The body for a stream subprogram may be generated outside of the scope + -- of the type. If the type is fully private, it may depend on the full + -- view of other types (e.g. indexes) that are currently private as well. + -- We install the declarations of the package in which the type is declared + -- before compiling the body in what is its proper environment. The Check + -- parameter indicates if checks are to be suppressed for the stream body. + -- We suppress checks for array/record reads, since the rule is that these + -- are like assignments, out of range values due to uninitialized storage, + -- or other invalid values do NOT cause a Constraint_Error to be raised. + + procedure Expand_Access_To_Protected_Op + (N : Node_Id; + Pref : Node_Id; + Typ : Entity_Id); + -- An attribute reference to a protected subprogram is transformed into + -- a pair of pointers: one to the object, and one to the operations. + -- This expansion is performed for 'Access and for 'Unrestricted_Access. + + procedure Expand_Fpt_Attribute + (N : Node_Id; + Pkg : RE_Id; + Nam : Name_Id; + Args : List_Id); + -- This procedure expands a call to a floating-point attribute function. + -- N is the attribute reference node, and Args is a list of arguments to + -- be passed to the function call. Pkg identifies the package containing + -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args + -- have already been converted to the floating-point type for which Pkg was + -- instantiated. The Nam argument is the relevant attribute processing + -- routine to be called. This is the same as the attribute name, except in + -- the Unaligned_Valid case. + + procedure Expand_Fpt_Attribute_R (N : Node_Id); + -- This procedure expands a call to a floating-point attribute function + -- that takes a single floating-point argument. The function to be called + -- is always the same as the attribute name. + + procedure Expand_Fpt_Attribute_RI (N : Node_Id); + -- This procedure expands a call to a floating-point attribute function + -- that takes one floating-point argument and one integer argument. The + -- function to be called is always the same as the attribute name. + + procedure Expand_Fpt_Attribute_RR (N : Node_Id); + -- This procedure expands a call to a floating-point attribute function + -- that takes two floating-point arguments. The function to be called + -- is always the same as the attribute name. + + procedure Expand_Pred_Succ (N : Node_Id); + -- Handles expansion of Pred or Succ attributes for case of non-real + -- operand with overflow checking required. + + function Get_Index_Subtype (N : Node_Id) return Entity_Id; + -- Used for Last, Last, and Length, when the prefix is an array type. + -- Obtains the corresponding index subtype. + + procedure Find_Fat_Info + (T : Entity_Id; + Fat_Type : out Entity_Id; + Fat_Pkg : out RE_Id); + -- Given a floating-point type T, identifies the package containing the + -- attributes for this type (returned in Fat_Pkg), and the corresponding + -- type for which this package was instantiated from Fat_Gen. Error if T + -- is not a floating-point type. + + function Find_Stream_Subprogram + (Typ : Entity_Id; + Nam : TSS_Name_Type) return Entity_Id; + -- Returns the stream-oriented subprogram attribute for Typ. For tagged + -- types, the corresponding primitive operation is looked up, else the + -- appropriate TSS from the type itself, or from its closest ancestor + -- defining it, is returned. In both cases, inheritance of representation + -- aspects is thus taken into account. + + function Full_Base (T : Entity_Id) return Entity_Id; + -- The stream functions need to examine the underlying representation of + -- composite types. In some cases T may be non-private but its base type + -- is, in which case the function returns the corresponding full view. + + function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id; + -- Given a type, find a corresponding stream convert pragma that applies to + -- the implementation base type of this type (Typ). If found, return the + -- pragma node, otherwise return Empty if no pragma is found. + + function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean; + -- Utility for array attributes, returns true on packed constrained + -- arrays, and on access to same. + + function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean; + -- Returns true iff the given node refers to an attribute call that + -- can be expanded directly by the back end and does not need front end + -- expansion. Typically used for rounding and truncation attributes that + -- appear directly inside a conversion to integer. + + ---------------------------------- + -- Compile_Stream_Body_In_Scope -- + ---------------------------------- + + procedure Compile_Stream_Body_In_Scope + (N : Node_Id; + Decl : Node_Id; + Arr : Entity_Id; + Check : Boolean) + is + Installed : Boolean := False; + Scop : constant Entity_Id := Scope (Arr); + Curr : constant Entity_Id := Current_Scope; + + begin + if Is_Hidden (Arr) + and then not In_Open_Scopes (Scop) + and then Ekind (Scop) = E_Package + then + Push_Scope (Scop); + Install_Visible_Declarations (Scop); + Install_Private_Declarations (Scop); + Installed := True; + + -- The entities in the package are now visible, but the generated + -- stream entity must appear in the current scope (usually an + -- enclosing stream function) so that itypes all have their proper + -- scopes. + + Push_Scope (Curr); + end if; + + if Check then + Insert_Action (N, Decl); + else + Insert_Action (N, Decl, Suppress => All_Checks); + end if; + + if Installed then + + -- Remove extra copy of current scope, and package itself + + Pop_Scope; + End_Package_Scope (Scop); + end if; + end Compile_Stream_Body_In_Scope; + + ----------------------------------- + -- Expand_Access_To_Protected_Op -- + ----------------------------------- + + procedure Expand_Access_To_Protected_Op + (N : Node_Id; + Pref : Node_Id; + Typ : Entity_Id) + is + -- The value of the attribute_reference is a record containing two + -- fields: an access to the protected object, and an access to the + -- subprogram itself. The prefix is a selected component. + + Loc : constant Source_Ptr := Sloc (N); + Agg : Node_Id; + Btyp : constant Entity_Id := Base_Type (Typ); + Sub : Entity_Id; + Sub_Ref : Node_Id; + E_T : constant Entity_Id := Equivalent_Type (Btyp); + Acc : constant Entity_Id := + Etype (Next_Component (First_Component (E_T))); + Obj_Ref : Node_Id; + Curr : Entity_Id; + + function May_Be_External_Call return Boolean; + -- If the 'Access is to a local operation, but appears in a context + -- where it may lead to a call from outside the object, we must treat + -- this as an external call. Clearly we cannot tell without full + -- flow analysis, and a subsequent call that uses this 'Access may + -- lead to a bounded error (trying to seize locks twice, e.g.). For + -- now we treat 'Access as a potential external call if it is an actual + -- in a call to an outside subprogram. + + -------------------------- + -- May_Be_External_Call -- + -------------------------- + + function May_Be_External_Call return Boolean is + Subp : Entity_Id; + Par : Node_Id := Parent (N); + + begin + -- Account for the case where the Access attribute is part of a + -- named parameter association. + + if Nkind (Par) = N_Parameter_Association then + Par := Parent (Par); + end if; + + if Nkind_In (Par, N_Procedure_Call_Statement, N_Function_Call) + and then Is_Entity_Name (Name (Par)) + then + Subp := Entity (Name (Par)); + return not In_Open_Scopes (Scope (Subp)); + else + return False; + end if; + end May_Be_External_Call; + + -- Start of processing for Expand_Access_To_Protected_Op + + begin + -- Within the body of the protected type, the prefix designates a local + -- operation, and the object is the first parameter of the corresponding + -- protected body of the current enclosing operation. + + if Is_Entity_Name (Pref) then + if May_Be_External_Call then + Sub := + New_Occurrence_Of (External_Subprogram (Entity (Pref)), Loc); + else + Sub := + New_Occurrence_Of + (Protected_Body_Subprogram (Entity (Pref)), Loc); + end if; + + -- Don't traverse the scopes when the attribute occurs within an init + -- proc, because we directly use the _init formal of the init proc in + -- that case. + + Curr := Current_Scope; + if not Is_Init_Proc (Curr) then + pragma Assert (In_Open_Scopes (Scope (Entity (Pref)))); + + while Scope (Curr) /= Scope (Entity (Pref)) loop + Curr := Scope (Curr); + end loop; + end if; + + -- In case of protected entries the first formal of its Protected_ + -- Body_Subprogram is the address of the object. + + if Ekind (Curr) = E_Entry then + Obj_Ref := + New_Occurrence_Of + (First_Formal + (Protected_Body_Subprogram (Curr)), Loc); + + -- If the current scope is an init proc, then use the address of the + -- _init formal as the object reference. + + elsif Is_Init_Proc (Curr) then + Obj_Ref := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (First_Formal (Curr), Loc), + Attribute_Name => Name_Address); + + -- In case of protected subprograms the first formal of its + -- Protected_Body_Subprogram is the object and we get its address. + + else + Obj_Ref := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (First_Formal + (Protected_Body_Subprogram (Curr)), Loc), + Attribute_Name => Name_Address); + end if; + + -- Case where the prefix is not an entity name. Find the + -- version of the protected operation to be called from + -- outside the protected object. + + else + Sub := + New_Occurrence_Of + (External_Subprogram + (Entity (Selector_Name (Pref))), Loc); + + Obj_Ref := + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Prefix (Pref)), + Attribute_Name => Name_Address); + end if; + + Sub_Ref := + Make_Attribute_Reference (Loc, + Prefix => Sub, + Attribute_Name => Name_Access); + + -- We set the type of the access reference to the already generated + -- access_to_subprogram type, and declare the reference analyzed, to + -- prevent further expansion when the enclosing aggregate is analyzed. + + Set_Etype (Sub_Ref, Acc); + Set_Analyzed (Sub_Ref); + + Agg := + Make_Aggregate (Loc, + Expressions => New_List (Obj_Ref, Sub_Ref)); + + -- Sub_Ref has been marked as analyzed, but we still need to make sure + -- Sub is correctly frozen. + + Freeze_Before (N, Entity (Sub)); + + Rewrite (N, Agg); + Analyze_And_Resolve (N, E_T); + + -- For subsequent analysis, the node must retain its type. The backend + -- will replace it with the equivalent type where needed. + + Set_Etype (N, Typ); + end Expand_Access_To_Protected_Op; + + -------------------------- + -- Expand_Fpt_Attribute -- + -------------------------- + + procedure Expand_Fpt_Attribute + (N : Node_Id; + Pkg : RE_Id; + Nam : Name_Id; + Args : List_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Fnm : Node_Id; + + begin + -- The function name is the selected component Attr_xxx.yyy where + -- Attr_xxx is the package name, and yyy is the argument Nam. + + -- Note: it would be more usual to have separate RE entries for each + -- of the entities in the Fat packages, but first they have identical + -- names (so we would have to have lots of renaming declarations to + -- meet the normal RE rule of separate names for all runtime entities), + -- and second there would be an awful lot of them! + + Fnm := + Make_Selected_Component (Loc, + Prefix => New_Reference_To (RTE (Pkg), Loc), + Selector_Name => Make_Identifier (Loc, Nam)); + + -- The generated call is given the provided set of parameters, and then + -- wrapped in a conversion which converts the result to the target type + -- We use the base type as the target because a range check may be + -- required. + + Rewrite (N, + Unchecked_Convert_To (Base_Type (Etype (N)), + Make_Function_Call (Loc, + Name => Fnm, + Parameter_Associations => Args))); + + Analyze_And_Resolve (N, Typ); + end Expand_Fpt_Attribute; + + ---------------------------- + -- Expand_Fpt_Attribute_R -- + ---------------------------- + + -- The single argument is converted to its root type to call the + -- appropriate runtime function, with the actual call being built + -- by Expand_Fpt_Attribute + + procedure Expand_Fpt_Attribute_R (N : Node_Id) is + E1 : constant Node_Id := First (Expressions (N)); + Ftp : Entity_Id; + Pkg : RE_Id; + begin + Find_Fat_Info (Etype (E1), Ftp, Pkg); + Expand_Fpt_Attribute + (N, Pkg, Attribute_Name (N), + New_List (Unchecked_Convert_To (Ftp, Relocate_Node (E1)))); + end Expand_Fpt_Attribute_R; + + ----------------------------- + -- Expand_Fpt_Attribute_RI -- + ----------------------------- + + -- The first argument is converted to its root type and the second + -- argument is converted to standard long long integer to call the + -- appropriate runtime function, with the actual call being built + -- by Expand_Fpt_Attribute + + procedure Expand_Fpt_Attribute_RI (N : Node_Id) is + E1 : constant Node_Id := First (Expressions (N)); + Ftp : Entity_Id; + Pkg : RE_Id; + E2 : constant Node_Id := Next (E1); + begin + Find_Fat_Info (Etype (E1), Ftp, Pkg); + Expand_Fpt_Attribute + (N, Pkg, Attribute_Name (N), + New_List ( + Unchecked_Convert_To (Ftp, Relocate_Node (E1)), + Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2)))); + end Expand_Fpt_Attribute_RI; + + ----------------------------- + -- Expand_Fpt_Attribute_RR -- + ----------------------------- + + -- The two arguments are converted to their root types to call the + -- appropriate runtime function, with the actual call being built + -- by Expand_Fpt_Attribute + + procedure Expand_Fpt_Attribute_RR (N : Node_Id) is + E1 : constant Node_Id := First (Expressions (N)); + Ftp : Entity_Id; + Pkg : RE_Id; + E2 : constant Node_Id := Next (E1); + begin + Find_Fat_Info (Etype (E1), Ftp, Pkg); + Expand_Fpt_Attribute + (N, Pkg, Attribute_Name (N), + New_List ( + Unchecked_Convert_To (Ftp, Relocate_Node (E1)), + Unchecked_Convert_To (Ftp, Relocate_Node (E2)))); + end Expand_Fpt_Attribute_RR; + + ---------------------------------- + -- Expand_N_Attribute_Reference -- + ---------------------------------- + + procedure Expand_N_Attribute_Reference (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Btyp : constant Entity_Id := Base_Type (Typ); + Pref : constant Node_Id := Prefix (N); + Ptyp : constant Entity_Id := Etype (Pref); + Exprs : constant List_Id := Expressions (N); + Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); + + procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id); + -- Rewrites a stream attribute for Read, Write or Output with the + -- procedure call. Pname is the entity for the procedure to call. + + ------------------------------ + -- Rewrite_Stream_Proc_Call -- + ------------------------------ + + procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is + Item : constant Node_Id := Next (First (Exprs)); + Formal : constant Entity_Id := Next_Formal (First_Formal (Pname)); + Formal_Typ : constant Entity_Id := Etype (Formal); + Is_Written : constant Boolean := (Ekind (Formal) /= E_In_Parameter); + + begin + -- The expansion depends on Item, the second actual, which is + -- the object being streamed in or out. + + -- If the item is a component of a packed array type, and + -- a conversion is needed on exit, we introduce a temporary to + -- hold the value, because otherwise the packed reference will + -- not be properly expanded. + + if Nkind (Item) = N_Indexed_Component + and then Is_Packed (Base_Type (Etype (Prefix (Item)))) + and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ) + and then Is_Written + then + declare + Temp : constant Entity_Id := Make_Temporary (Loc, 'V'); + Decl : Node_Id; + Assn : Node_Id; + + begin + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => + New_Occurrence_Of (Formal_Typ, Loc)); + Set_Etype (Temp, Formal_Typ); + + Assn := + Make_Assignment_Statement (Loc, + Name => New_Copy_Tree (Item), + Expression => + Unchecked_Convert_To + (Etype (Item), New_Occurrence_Of (Temp, Loc))); + + Rewrite (Item, New_Occurrence_Of (Temp, Loc)); + Insert_Actions (N, + New_List ( + Decl, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Pname, Loc), + Parameter_Associations => Exprs), + Assn)); + + Rewrite (N, Make_Null_Statement (Loc)); + return; + end; + end if; + + -- For the class-wide dispatching cases, and for cases in which + -- the base type of the second argument matches the base type of + -- the corresponding formal parameter (that is to say the stream + -- operation is not inherited), we are all set, and can use the + -- argument unchanged. + + -- For all other cases we do an unchecked conversion of the second + -- parameter to the type of the formal of the procedure we are + -- calling. This deals with the private type cases, and with going + -- to the root type as required in elementary type case. + + if not Is_Class_Wide_Type (Entity (Pref)) + and then not Is_Class_Wide_Type (Etype (Item)) + and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ) + then + Rewrite (Item, + Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item))); + + -- For untagged derived types set Assignment_OK, to prevent + -- copies from being created when the unchecked conversion + -- is expanded (which would happen in Remove_Side_Effects + -- if Expand_N_Unchecked_Conversion were allowed to call + -- Force_Evaluation). The copy could violate Ada semantics + -- in cases such as an actual that is an out parameter. + -- Note that this approach is also used in exp_ch7 for calls + -- to controlled type operations to prevent problems with + -- actuals wrapped in unchecked conversions. + + if Is_Untagged_Derivation (Etype (Expression (Item))) then + Set_Assignment_OK (Item); + end if; + end if; + + -- The stream operation to call maybe a renaming created by + -- an attribute definition clause, and may not be frozen yet. + -- Ensure that it has the necessary extra formals. + + if not Is_Frozen (Pname) then + Create_Extra_Formals (Pname); + end if; + + -- And now rewrite the call + + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Pname, Loc), + Parameter_Associations => Exprs)); + + Analyze (N); + end Rewrite_Stream_Proc_Call; + + -- Start of processing for Expand_N_Attribute_Reference + + begin + -- Do required validity checking, if enabled. Do not apply check to + -- output parameters of an Asm instruction, since the value of this + -- is not set till after the attribute has been elaborated, and do + -- not apply the check to the arguments of a 'Read or 'Input attribute + -- reference since the scalar argument is an OUT scalar. + + if Validity_Checks_On and then Validity_Check_Operands + and then Id /= Attribute_Asm_Output + and then Id /= Attribute_Read + and then Id /= Attribute_Input + then + declare + Expr : Node_Id; + begin + Expr := First (Expressions (N)); + while Present (Expr) loop + Ensure_Valid (Expr); + Next (Expr); + end loop; + end; + end if; + + -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in- + -- place function, then a temporary return object needs to be created + -- and access to it must be passed to the function. Currently we limit + -- such functions to those with inherently limited result subtypes, but + -- eventually we plan to expand the functions that are treated as + -- build-in-place to include other composite result types. + + if Ada_Version >= Ada_2005 + and then Is_Build_In_Place_Function_Call (Pref) + then + Make_Build_In_Place_Call_In_Anonymous_Context (Pref); + end if; + + -- If prefix is a protected type name, this is a reference to the + -- current instance of the type. For a component definition, nothing + -- to do (expansion will occur in the init proc). In other contexts, + -- rewrite into reference to current instance. + + if Is_Protected_Self_Reference (Pref) + and then not + (Nkind_In (Parent (N), N_Index_Or_Discriminant_Constraint, + N_Discriminant_Association) + and then Nkind (Parent (Parent (Parent (Parent (N))))) = + N_Component_Definition) + then + Rewrite (Pref, Concurrent_Ref (Pref)); + Analyze (Pref); + end if; + + -- Remaining processing depends on specific attribute + + case Id is + + ------------ + -- Access -- + ------------ + + when Attribute_Access | + Attribute_Unchecked_Access | + Attribute_Unrestricted_Access => + + Access_Cases : declare + Ref_Object : constant Node_Id := Get_Referenced_Object (Pref); + Btyp_DDT : Entity_Id; + + function Enclosing_Object (N : Node_Id) return Node_Id; + -- If N denotes a compound name (selected component, indexed + -- component, or slice), returns the name of the outermost such + -- enclosing object. Otherwise returns N. If the object is a + -- renaming, then the renamed object is returned. + + ---------------------- + -- Enclosing_Object -- + ---------------------- + + function Enclosing_Object (N : Node_Id) return Node_Id is + Obj_Name : Node_Id; + + begin + Obj_Name := N; + while Nkind_In (Obj_Name, N_Selected_Component, + N_Indexed_Component, + N_Slice) + loop + Obj_Name := Prefix (Obj_Name); + end loop; + + return Get_Referenced_Object (Obj_Name); + end Enclosing_Object; + + -- Local declarations + + Enc_Object : constant Node_Id := Enclosing_Object (Ref_Object); + + -- Start of processing for Access_Cases + + begin + Btyp_DDT := Designated_Type (Btyp); + + -- Handle designated types that come from the limited view + + if Ekind (Btyp_DDT) = E_Incomplete_Type + and then From_With_Type (Btyp_DDT) + and then Present (Non_Limited_View (Btyp_DDT)) + then + Btyp_DDT := Non_Limited_View (Btyp_DDT); + + elsif Is_Class_Wide_Type (Btyp_DDT) + and then Ekind (Etype (Btyp_DDT)) = E_Incomplete_Type + and then From_With_Type (Etype (Btyp_DDT)) + and then Present (Non_Limited_View (Etype (Btyp_DDT))) + and then Present (Class_Wide_Type + (Non_Limited_View (Etype (Btyp_DDT)))) + then + Btyp_DDT := + Class_Wide_Type (Non_Limited_View (Etype (Btyp_DDT))); + end if; + + -- In order to improve the text of error messages, the designated + -- type of access-to-subprogram itypes is set by the semantics as + -- the associated subprogram entity (see sem_attr). Now we replace + -- such node with the proper E_Subprogram_Type itype. + + if Id = Attribute_Unrestricted_Access + and then Is_Subprogram (Directly_Designated_Type (Typ)) + then + -- The following conditions ensure that this special management + -- is done only for "Address!(Prim'Unrestricted_Access)" nodes. + -- At this stage other cases in which the designated type is + -- still a subprogram (instead of an E_Subprogram_Type) are + -- wrong because the semantics must have overridden the type of + -- the node with the type imposed by the context. + + if Nkind (Parent (N)) = N_Unchecked_Type_Conversion + and then Etype (Parent (N)) = RTE (RE_Prim_Ptr) + then + Set_Etype (N, RTE (RE_Prim_Ptr)); + + else + declare + Subp : constant Entity_Id := + Directly_Designated_Type (Typ); + Etyp : Entity_Id; + Extra : Entity_Id := Empty; + New_Formal : Entity_Id; + Old_Formal : Entity_Id := First_Formal (Subp); + Subp_Typ : Entity_Id; + + begin + Subp_Typ := Create_Itype (E_Subprogram_Type, N); + Set_Etype (Subp_Typ, Etype (Subp)); + Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp)); + + if Present (Old_Formal) then + New_Formal := New_Copy (Old_Formal); + Set_First_Entity (Subp_Typ, New_Formal); + + loop + Set_Scope (New_Formal, Subp_Typ); + Etyp := Etype (New_Formal); + + -- Handle itypes. There is no need to duplicate + -- here the itypes associated with record types + -- (i.e the implicit full view of private types). + + if Is_Itype (Etyp) + and then Ekind (Base_Type (Etyp)) /= E_Record_Type + then + Extra := New_Copy (Etyp); + Set_Parent (Extra, New_Formal); + Set_Etype (New_Formal, Extra); + Set_Scope (Extra, Subp_Typ); + end if; + + Extra := New_Formal; + Next_Formal (Old_Formal); + exit when No (Old_Formal); + + Set_Next_Entity (New_Formal, + New_Copy (Old_Formal)); + Next_Entity (New_Formal); + end loop; + + Set_Next_Entity (New_Formal, Empty); + Set_Last_Entity (Subp_Typ, Extra); + end if; + + -- Now that the explicit formals have been duplicated, + -- any extra formals needed by the subprogram must be + -- created. + + if Present (Extra) then + Set_Extra_Formal (Extra, Empty); + end if; + + Create_Extra_Formals (Subp_Typ); + Set_Directly_Designated_Type (Typ, Subp_Typ); + end; + end if; + end if; + + if Is_Access_Protected_Subprogram_Type (Btyp) then + Expand_Access_To_Protected_Op (N, Pref, Typ); + + -- If prefix is a type name, this is a reference to the current + -- instance of the type, within its initialization procedure. + + elsif Is_Entity_Name (Pref) + and then Is_Type (Entity (Pref)) + then + declare + Par : Node_Id; + Formal : Entity_Id; + + begin + -- If the current instance name denotes a task type, then + -- the access attribute is rewritten to be the name of the + -- "_task" parameter associated with the task type's task + -- procedure. An unchecked conversion is applied to ensure + -- a type match in cases of expander-generated calls (e.g. + -- init procs). + + if Is_Task_Type (Entity (Pref)) then + Formal := + First_Entity (Get_Task_Body_Procedure (Entity (Pref))); + while Present (Formal) loop + exit when Chars (Formal) = Name_uTask; + Next_Entity (Formal); + end loop; + + pragma Assert (Present (Formal)); + + Rewrite (N, + Unchecked_Convert_To (Typ, + New_Occurrence_Of (Formal, Loc))); + Set_Etype (N, Typ); + + -- The expression must appear in a default expression, + -- (which in the initialization procedure is the + -- right-hand side of an assignment), and not in a + -- discriminant constraint. + + else + Par := Parent (N); + while Present (Par) loop + exit when Nkind (Par) = N_Assignment_Statement; + + if Nkind (Par) = N_Component_Declaration then + return; + end if; + + Par := Parent (Par); + end loop; + + if Present (Par) then + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Attribute_Name => Attribute_Name (N))); + + Analyze_And_Resolve (N, Typ); + end if; + end if; + end; + + -- If the prefix of an Access attribute is a dereference of an + -- access parameter (or a renaming of such a dereference, or a + -- subcomponent of such a dereference) and the context is a + -- general access type (including the type of an object or + -- component with an access_definition, but not the anonymous + -- type of an access parameter or access discriminant), then + -- apply an accessibility check to the access parameter. We used + -- to rewrite the access parameter as a type conversion, but that + -- could only be done if the immediate prefix of the Access + -- attribute was the dereference, and didn't handle cases where + -- the attribute is applied to a subcomponent of the dereference, + -- since there's generally no available, appropriate access type + -- to convert to in that case. The attribute is passed as the + -- point to insert the check, because the access parameter may + -- come from a renaming, possibly in a different scope, and the + -- check must be associated with the attribute itself. + + elsif Id = Attribute_Access + and then Nkind (Enc_Object) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Enc_Object)) + and then (Ekind (Btyp) = E_General_Access_Type + or else Is_Local_Anonymous_Access (Btyp)) + and then Ekind (Entity (Prefix (Enc_Object))) in Formal_Kind + and then Ekind (Etype (Entity (Prefix (Enc_Object)))) + = E_Anonymous_Access_Type + and then Present (Extra_Accessibility + (Entity (Prefix (Enc_Object)))) + then + Apply_Accessibility_Check (Prefix (Enc_Object), Typ, N); + + -- Ada 2005 (AI-251): If the designated type is an interface we + -- add an implicit conversion to force the displacement of the + -- pointer to reference the secondary dispatch table. + + elsif Is_Interface (Btyp_DDT) + and then (Comes_From_Source (N) + or else Comes_From_Source (Ref_Object) + or else (Nkind (Ref_Object) in N_Has_Chars + and then Chars (Ref_Object) = Name_uInit)) + then + if Nkind (Ref_Object) /= N_Explicit_Dereference then + + -- No implicit conversion required if types match, or if + -- the prefix is the class_wide_type of the interface. In + -- either case passing an object of the interface type has + -- already set the pointer correctly. + + if Btyp_DDT = Etype (Ref_Object) + or else (Is_Class_Wide_Type (Etype (Ref_Object)) + and then + Class_Wide_Type (Btyp_DDT) = Etype (Ref_Object)) + then + null; + + else + Rewrite (Prefix (N), + Convert_To (Btyp_DDT, + New_Copy_Tree (Prefix (N)))); + + Analyze_And_Resolve (Prefix (N), Btyp_DDT); + end if; + + -- When the object is an explicit dereference, convert the + -- dereference's prefix. + + else + declare + Obj_DDT : constant Entity_Id := + Base_Type + (Directly_Designated_Type + (Etype (Prefix (Ref_Object)))); + begin + -- No implicit conversion required if designated types + -- match. + + if Obj_DDT /= Btyp_DDT + and then not (Is_Class_Wide_Type (Obj_DDT) + and then Etype (Obj_DDT) = Btyp_DDT) + then + Rewrite (N, + Convert_To (Typ, + New_Copy_Tree (Prefix (Ref_Object)))); + Analyze_And_Resolve (N, Typ); + end if; + end; + end if; + end if; + end Access_Cases; + + -------------- + -- Adjacent -- + -------------- + + -- Transforms 'Adjacent into a call to the floating-point attribute + -- function Adjacent in Fat_xxx (where xxx is the root type) + + when Attribute_Adjacent => + Expand_Fpt_Attribute_RR (N); + + ------------- + -- Address -- + ------------- + + when Attribute_Address => Address : declare + Task_Proc : Entity_Id; + + begin + -- If the prefix is a task or a task type, the useful address is that + -- of the procedure for the task body, i.e. the actual program unit. + -- We replace the original entity with that of the procedure. + + if Is_Entity_Name (Pref) + and then Is_Task_Type (Entity (Pref)) + then + Task_Proc := Next_Entity (Root_Type (Ptyp)); + + while Present (Task_Proc) loop + exit when Ekind (Task_Proc) = E_Procedure + and then Etype (First_Formal (Task_Proc)) = + Corresponding_Record_Type (Ptyp); + Next_Entity (Task_Proc); + end loop; + + if Present (Task_Proc) then + Set_Entity (Pref, Task_Proc); + Set_Etype (Pref, Etype (Task_Proc)); + end if; + + -- Similarly, the address of a protected operation is the address + -- of the corresponding protected body, regardless of the protected + -- object from which it is selected. + + elsif Nkind (Pref) = N_Selected_Component + and then Is_Subprogram (Entity (Selector_Name (Pref))) + and then Is_Protected_Type (Scope (Entity (Selector_Name (Pref)))) + then + Rewrite (Pref, + New_Occurrence_Of ( + External_Subprogram (Entity (Selector_Name (Pref))), Loc)); + + elsif Nkind (Pref) = N_Explicit_Dereference + and then Ekind (Ptyp) = E_Subprogram_Type + and then Convention (Ptyp) = Convention_Protected + then + -- The prefix is be a dereference of an access_to_protected_ + -- subprogram. The desired address is the second component of + -- the record that represents the access. + + declare + Addr : constant Entity_Id := Etype (N); + Ptr : constant Node_Id := Prefix (Pref); + T : constant Entity_Id := + Equivalent_Type (Base_Type (Etype (Ptr))); + + begin + Rewrite (N, + Unchecked_Convert_To (Addr, + Make_Selected_Component (Loc, + Prefix => Unchecked_Convert_To (T, Ptr), + Selector_Name => New_Occurrence_Of ( + Next_Entity (First_Entity (T)), Loc)))); + + Analyze_And_Resolve (N, Addr); + end; + + -- Ada 2005 (AI-251): Class-wide interface objects are always + -- "displaced" to reference the tag associated with the interface + -- type. In order to obtain the real address of such objects we + -- generate a call to a run-time subprogram that returns the base + -- address of the object. + + -- This processing is not needed in the VM case, where dispatching + -- issues are taken care of by the virtual machine. + + elsif Is_Class_Wide_Type (Ptyp) + and then Is_Interface (Ptyp) + and then Tagged_Type_Expansion + and then not (Nkind (Pref) in N_Has_Entity + and then Is_Subprogram (Entity (Pref))) + then + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Base_Address), Loc), + Parameter_Associations => New_List ( + Relocate_Node (N)))); + Analyze (N); + return; + end if; + + -- Deal with packed array reference, other cases are handled by + -- the back end. + + if Involves_Packed_Array_Reference (Pref) then + Expand_Packed_Address_Reference (N); + end if; + end Address; + + --------------- + -- Alignment -- + --------------- + + when Attribute_Alignment => Alignment : declare + New_Node : Node_Id; + + begin + -- For class-wide types, X'Class'Alignment is transformed into a + -- direct reference to the Alignment of the class type, so that the + -- back end does not have to deal with the X'Class'Alignment + -- reference. + + if Is_Entity_Name (Pref) + and then Is_Class_Wide_Type (Entity (Pref)) + then + Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc)); + return; + + -- For x'Alignment applied to an object of a class wide type, + -- transform X'Alignment into a call to the predefined primitive + -- operation _Alignment applied to X. + + elsif Is_Class_Wide_Type (Ptyp) then + + -- No need to do anything else compiling under restriction + -- No_Dispatching_Calls. During the semantic analysis we + -- already notified such violation. + + if Restriction_Active (No_Dispatching_Calls) then + return; + end if; + + New_Node := + Make_Function_Call (Loc, + Name => New_Reference_To + (Find_Prim_Op (Ptyp, Name_uAlignment), Loc), + Parameter_Associations => New_List (Pref)); + + if Typ /= Standard_Integer then + + -- The context is a specific integer type with which the + -- original attribute was compatible. The function has a + -- specific type as well, so to preserve the compatibility + -- we must convert explicitly. + + New_Node := Convert_To (Typ, New_Node); + end if; + + Rewrite (N, New_Node); + Analyze_And_Resolve (N, Typ); + return; + + -- For all other cases, we just have to deal with the case of + -- the fact that the result can be universal. + + else + Apply_Universal_Integer_Attribute_Checks (N); + end if; + end Alignment; + + --------------- + -- AST_Entry -- + --------------- + + when Attribute_AST_Entry => AST_Entry : declare + Ttyp : Entity_Id; + T_Id : Node_Id; + Eent : Entity_Id; + + Entry_Ref : Node_Id; + -- The reference to the entry or entry family + + Index : Node_Id; + -- The index expression for an entry family reference, or + -- the Empty if Entry_Ref references a simple entry. + + begin + if Nkind (Pref) = N_Indexed_Component then + Entry_Ref := Prefix (Pref); + Index := First (Expressions (Pref)); + else + Entry_Ref := Pref; + Index := Empty; + end if; + + -- Get expression for Task_Id and the entry entity + + if Nkind (Entry_Ref) = N_Selected_Component then + T_Id := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Identity, + Prefix => Prefix (Entry_Ref)); + + Ttyp := Etype (Prefix (Entry_Ref)); + Eent := Entity (Selector_Name (Entry_Ref)); + + else + T_Id := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Current_Task), Loc)); + + Eent := Entity (Entry_Ref); + + -- We have to find the enclosing task to get the task type + -- There must be one, since we already validated this earlier + + Ttyp := Current_Scope; + while not Is_Task_Type (Ttyp) loop + Ttyp := Scope (Ttyp); + end loop; + end if; + + -- Now rewrite the attribute with a call to Create_AST_Handler + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Create_AST_Handler), Loc), + Parameter_Associations => New_List ( + T_Id, + Entry_Index_Expression (Loc, Eent, Index, Ttyp)))); + + Analyze_And_Resolve (N, RTE (RE_AST_Handler)); + end AST_Entry; + + --------- + -- Bit -- + --------- + + -- We compute this if a packed array reference was present, otherwise we + -- leave the computation up to the back end. + + when Attribute_Bit => + if Involves_Packed_Array_Reference (Pref) then + Expand_Packed_Bit_Reference (N); + else + Apply_Universal_Integer_Attribute_Checks (N); + end if; + + ------------------ + -- Bit_Position -- + ------------------ + + -- We compute this if a component clause was present, otherwise we leave + -- the computation up to the back end, since we don't know what layout + -- will be chosen. + + -- Note that the attribute can apply to a naked record component + -- in generated code (i.e. the prefix is an identifier that + -- references the component or discriminant entity). + + when Attribute_Bit_Position => Bit_Position : declare + CE : Entity_Id; + + begin + if Nkind (Pref) = N_Identifier then + CE := Entity (Pref); + else + CE := Entity (Selector_Name (Pref)); + end if; + + if Known_Static_Component_Bit_Offset (CE) then + Rewrite (N, + Make_Integer_Literal (Loc, + Intval => Component_Bit_Offset (CE))); + Analyze_And_Resolve (N, Typ); + + else + Apply_Universal_Integer_Attribute_Checks (N); + end if; + end Bit_Position; + + ------------------ + -- Body_Version -- + ------------------ + + -- A reference to P'Body_Version or P'Version is expanded to + + -- Vnn : Unsigned; + -- pragma Import (C, Vnn, "uuuuT"); + -- ... + -- Get_Version_String (Vnn) + + -- where uuuu is the unit name (dots replaced by double underscore) + -- and T is B for the cases of Body_Version, or Version applied to a + -- subprogram acting as its own spec, and S for Version applied to a + -- subprogram spec or package. This sequence of code references the + -- unsigned constant created in the main program by the binder. + + -- A special exception occurs for Standard, where the string returned + -- is a copy of the library string in gnatvsn.ads. + + when Attribute_Body_Version | Attribute_Version => Version : declare + E : constant Entity_Id := Make_Temporary (Loc, 'V'); + Pent : Entity_Id; + S : String_Id; + + begin + -- If not library unit, get to containing library unit + + Pent := Entity (Pref); + while Pent /= Standard_Standard + and then Scope (Pent) /= Standard_Standard + and then not Is_Child_Unit (Pent) + loop + Pent := Scope (Pent); + end loop; + + -- Special case Standard and Standard.ASCII + + if Pent = Standard_Standard or else Pent = Standard_ASCII then + Rewrite (N, + Make_String_Literal (Loc, + Strval => Verbose_Library_Version)); + + -- All other cases + + else + -- Build required string constant + + Get_Name_String (Get_Unit_Name (Pent)); + + Start_String; + for J in 1 .. Name_Len - 2 loop + if Name_Buffer (J) = '.' then + Store_String_Chars ("__"); + else + Store_String_Char (Get_Char_Code (Name_Buffer (J))); + end if; + end loop; + + -- Case of subprogram acting as its own spec, always use body + + if Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification + and then Nkind (Parent (Declaration_Node (Pent))) = + N_Subprogram_Body + and then Acts_As_Spec (Parent (Declaration_Node (Pent))) + then + Store_String_Chars ("B"); + + -- Case of no body present, always use spec + + elsif not Unit_Requires_Body (Pent) then + Store_String_Chars ("S"); + + -- Otherwise use B for Body_Version, S for spec + + elsif Id = Attribute_Body_Version then + Store_String_Chars ("B"); + else + Store_String_Chars ("S"); + end if; + + S := End_String; + Lib.Version_Referenced (S); + + -- Insert the object declaration + + Insert_Actions (N, New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => E, + Object_Definition => + New_Occurrence_Of (RTE (RE_Unsigned), Loc)))); + + -- Set entity as imported with correct external name + + Set_Is_Imported (E); + Set_Interface_Name (E, Make_String_Literal (Loc, S)); + + -- Set entity as internal to ensure proper Sprint output of its + -- implicit importation. + + Set_Is_Internal (E); + + -- And now rewrite original reference + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Get_Version_String), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (E, Loc)))); + end if; + + Analyze_And_Resolve (N, RTE (RE_Version_String)); + end Version; + + ------------- + -- Ceiling -- + ------------- + + -- Transforms 'Ceiling into a call to the floating-point attribute + -- function Ceiling in Fat_xxx (where xxx is the root type) + + when Attribute_Ceiling => + Expand_Fpt_Attribute_R (N); + + -------------- + -- Callable -- + -------------- + + -- Transforms 'Callable attribute into a call to the Callable function + + when Attribute_Callable => Callable : + begin + -- We have an object of a task interface class-wide type as a prefix + -- to Callable. Generate: + -- callable (Task_Id (Pref._disp_get_task_id)); + + if Ada_Version >= Ada_2005 + and then Ekind (Ptyp) = E_Class_Wide_Type + and then Is_Interface (Ptyp) + and then Is_Task_Interface (Ptyp) + then + Rewrite (N, + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Callable), Loc), + Parameter_Associations => New_List ( + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Reference_To (RTE (RO_ST_Task_Id), Loc), + Expression => + Make_Selected_Component (Loc, + Prefix => + New_Copy_Tree (Pref), + Selector_Name => + Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))))); + + else + Rewrite (N, + Build_Call_With_Task (Pref, RTE (RE_Callable))); + end if; + + Analyze_And_Resolve (N, Standard_Boolean); + end Callable; + + ------------ + -- Caller -- + ------------ + + -- Transforms 'Caller attribute into a call to either the + -- Task_Entry_Caller or the Protected_Entry_Caller function. + + when Attribute_Caller => Caller : declare + Id_Kind : constant Entity_Id := RTE (RO_AT_Task_Id); + Ent : constant Entity_Id := Entity (Pref); + Conctype : constant Entity_Id := Scope (Ent); + Nest_Depth : Integer := 0; + Name : Node_Id; + S : Entity_Id; + + begin + -- Protected case + + if Is_Protected_Type (Conctype) then + case Corresponding_Runtime_Package (Conctype) is + when System_Tasking_Protected_Objects_Entries => + Name := + New_Reference_To + (RTE (RE_Protected_Entry_Caller), Loc); + + when System_Tasking_Protected_Objects_Single_Entry => + Name := + New_Reference_To + (RTE (RE_Protected_Single_Entry_Caller), Loc); + + when others => + raise Program_Error; + end case; + + Rewrite (N, + Unchecked_Convert_To (Id_Kind, + Make_Function_Call (Loc, + Name => Name, + Parameter_Associations => New_List ( + New_Reference_To + (Find_Protection_Object (Current_Scope), Loc))))); + + -- Task case + + else + -- Determine the nesting depth of the E'Caller attribute, that + -- is, how many accept statements are nested within the accept + -- statement for E at the point of E'Caller. The runtime uses + -- this depth to find the specified entry call. + + for J in reverse 0 .. Scope_Stack.Last loop + S := Scope_Stack.Table (J).Entity; + + -- We should not reach the scope of the entry, as it should + -- already have been checked in Sem_Attr that this attribute + -- reference is within a matching accept statement. + + pragma Assert (S /= Conctype); + + if S = Ent then + exit; + + elsif Is_Entry (S) then + Nest_Depth := Nest_Depth + 1; + end if; + end loop; + + Rewrite (N, + Unchecked_Convert_To (Id_Kind, + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Task_Entry_Caller), Loc), + Parameter_Associations => New_List ( + Make_Integer_Literal (Loc, + Intval => Int (Nest_Depth)))))); + end if; + + Analyze_And_Resolve (N, Id_Kind); + end Caller; + + ------------- + -- Compose -- + ------------- + + -- Transforms 'Compose into a call to the floating-point attribute + -- function Compose in Fat_xxx (where xxx is the root type) + + -- Note: we strictly should have special code here to deal with the + -- case of absurdly negative arguments (less than Integer'First) + -- which will return a (signed) zero value, but it hardly seems + -- worth the effort. Absurdly large positive arguments will raise + -- constraint error which is fine. + + when Attribute_Compose => + Expand_Fpt_Attribute_RI (N); + + ----------------- + -- Constrained -- + ----------------- + + when Attribute_Constrained => Constrained : declare + Formal_Ent : constant Entity_Id := Param_Entity (Pref); + + function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean; + -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a + -- view of an aliased object whose subtype is constrained. + + --------------------------------- + -- Is_Constrained_Aliased_View -- + --------------------------------- + + function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is + E : Entity_Id; + + begin + if Is_Entity_Name (Obj) then + E := Entity (Obj); + + if Present (Renamed_Object (E)) then + return Is_Constrained_Aliased_View (Renamed_Object (E)); + else + return Is_Aliased (E) and then Is_Constrained (Etype (E)); + end if; + + else + return Is_Aliased_View (Obj) + and then + (Is_Constrained (Etype (Obj)) + or else (Nkind (Obj) = N_Explicit_Dereference + and then + not Has_Constrained_Partial_View + (Base_Type (Etype (Obj))))); + end if; + end Is_Constrained_Aliased_View; + + -- Start of processing for Constrained + + begin + -- Reference to a parameter where the value is passed as an extra + -- actual, corresponding to the extra formal referenced by the + -- Extra_Constrained field of the corresponding formal. If this + -- is an entry in-parameter, it is replaced by a constant renaming + -- for which Extra_Constrained is never created. + + if Present (Formal_Ent) + and then Ekind (Formal_Ent) /= E_Constant + and then Present (Extra_Constrained (Formal_Ent)) + then + Rewrite (N, + New_Occurrence_Of + (Extra_Constrained (Formal_Ent), Sloc (N))); + + -- For variables with a Extra_Constrained field, we use the + -- corresponding entity. + + elsif Nkind (Pref) = N_Identifier + and then Ekind (Entity (Pref)) = E_Variable + and then Present (Extra_Constrained (Entity (Pref))) + then + Rewrite (N, + New_Occurrence_Of + (Extra_Constrained (Entity (Pref)), Sloc (N))); + + -- For all other entity names, we can tell at compile time + + elsif Is_Entity_Name (Pref) then + declare + Ent : constant Entity_Id := Entity (Pref); + Res : Boolean; + + begin + -- (RM J.4) obsolescent cases + + if Is_Type (Ent) then + + -- Private type + + if Is_Private_Type (Ent) then + Res := not Has_Discriminants (Ent) + or else Is_Constrained (Ent); + + -- It not a private type, must be a generic actual type + -- that corresponded to a private type. We know that this + -- correspondence holds, since otherwise the reference + -- within the generic template would have been illegal. + + else + if Is_Composite_Type (Underlying_Type (Ent)) then + Res := Is_Constrained (Ent); + else + Res := True; + end if; + end if; + + -- If the prefix is not a variable or is aliased, then + -- definitely true; if it's a formal parameter without an + -- associated extra formal, then treat it as constrained. + + -- Ada 2005 (AI-363): An aliased prefix must be known to be + -- constrained in order to set the attribute to True. + + elsif not Is_Variable (Pref) + or else Present (Formal_Ent) + or else (Ada_Version < Ada_2005 + and then Is_Aliased_View (Pref)) + or else (Ada_Version >= Ada_2005 + and then Is_Constrained_Aliased_View (Pref)) + then + Res := True; + + -- Variable case, look at type to see if it is constrained. + -- Note that the one case where this is not accurate (the + -- procedure formal case), has been handled above. + + -- We use the Underlying_Type here (and below) in case the + -- type is private without discriminants, but the full type + -- has discriminants. This case is illegal, but we generate it + -- internally for passing to the Extra_Constrained parameter. + + else + -- In Ada 2012, test for case of a limited tagged type, in + -- which case the attribute is always required to return + -- True. The underlying type is tested, to make sure we also + -- return True for cases where there is an unconstrained + -- object with an untagged limited partial view which has + -- defaulted discriminants (such objects always produce a + -- False in earlier versions of Ada). (Ada 2012: AI05-0214) + + Res := Is_Constrained (Underlying_Type (Etype (Ent))) + or else + (Ada_Version >= Ada_2012 + and then Is_Tagged_Type (Underlying_Type (Ptyp)) + and then Is_Limited_Type (Ptyp)); + end if; + + Rewrite (N, New_Reference_To (Boolean_Literals (Res), Loc)); + end; + + -- Prefix is not an entity name. These are also cases where we can + -- always tell at compile time by looking at the form and type of the + -- prefix. If an explicit dereference of an object with constrained + -- partial view, this is unconstrained (Ada 2005: AI95-0363). If the + -- underlying type is a limited tagged type, then Constrained is + -- required to always return True (Ada 2012: AI05-0214). + + else + Rewrite (N, + New_Reference_To ( + Boolean_Literals ( + not Is_Variable (Pref) + or else + (Nkind (Pref) = N_Explicit_Dereference + and then + not Has_Constrained_Partial_View (Base_Type (Ptyp))) + or else Is_Constrained (Underlying_Type (Ptyp)) + or else (Ada_Version >= Ada_2012 + and then Is_Tagged_Type (Underlying_Type (Ptyp)) + and then Is_Limited_Type (Ptyp))), + Loc)); + end if; + + Analyze_And_Resolve (N, Standard_Boolean); + end Constrained; + + --------------- + -- Copy_Sign -- + --------------- + + -- Transforms 'Copy_Sign into a call to the floating-point attribute + -- function Copy_Sign in Fat_xxx (where xxx is the root type) + + when Attribute_Copy_Sign => + Expand_Fpt_Attribute_RR (N); + + ----------- + -- Count -- + ----------- + + -- Transforms 'Count attribute into a call to the Count function + + when Attribute_Count => Count : declare + Call : Node_Id; + Conctyp : Entity_Id; + Entnam : Node_Id; + Entry_Id : Entity_Id; + Index : Node_Id; + Name : Node_Id; + + begin + -- If the prefix is a member of an entry family, retrieve both + -- entry name and index. For a simple entry there is no index. + + if Nkind (Pref) = N_Indexed_Component then + Entnam := Prefix (Pref); + Index := First (Expressions (Pref)); + else + Entnam := Pref; + Index := Empty; + end if; + + Entry_Id := Entity (Entnam); + + -- Find the concurrent type in which this attribute is referenced + -- (there had better be one). + + Conctyp := Current_Scope; + while not Is_Concurrent_Type (Conctyp) loop + Conctyp := Scope (Conctyp); + end loop; + + -- Protected case + + if Is_Protected_Type (Conctyp) then + case Corresponding_Runtime_Package (Conctyp) is + when System_Tasking_Protected_Objects_Entries => + Name := New_Reference_To (RTE (RE_Protected_Count), Loc); + + Call := + Make_Function_Call (Loc, + Name => Name, + Parameter_Associations => New_List ( + New_Reference_To + (Find_Protection_Object (Current_Scope), Loc), + Entry_Index_Expression + (Loc, Entry_Id, Index, Scope (Entry_Id)))); + + when System_Tasking_Protected_Objects_Single_Entry => + Name := + New_Reference_To (RTE (RE_Protected_Count_Entry), Loc); + + Call := + Make_Function_Call (Loc, + Name => Name, + Parameter_Associations => New_List ( + New_Reference_To + (Find_Protection_Object (Current_Scope), Loc))); + + when others => + raise Program_Error; + end case; + + -- Task case + + else + Call := + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Task_Count), Loc), + Parameter_Associations => New_List ( + Entry_Index_Expression (Loc, + Entry_Id, Index, Scope (Entry_Id)))); + end if; + + -- The call returns type Natural but the context is universal integer + -- so any integer type is allowed. The attribute was already resolved + -- so its Etype is the required result type. If the base type of the + -- context type is other than Standard.Integer we put in a conversion + -- to the required type. This can be a normal typed conversion since + -- both input and output types of the conversion are integer types + + if Base_Type (Typ) /= Base_Type (Standard_Integer) then + Rewrite (N, Convert_To (Typ, Call)); + else + Rewrite (N, Call); + end if; + + Analyze_And_Resolve (N, Typ); + end Count; + + --------------- + -- Elab_Body -- + --------------- + + -- This processing is shared by Elab_Spec + + -- What we do is to insert the following declarations + + -- procedure tnn; + -- pragma Import (C, enn, "name___elabb/s"); + + -- and then the Elab_Body/Spec attribute is replaced by a reference + -- to this defining identifier. + + when Attribute_Elab_Body | + Attribute_Elab_Spec => + + Elab_Body : declare + Ent : constant Entity_Id := Make_Temporary (Loc, 'E'); + Str : String_Id; + Lang : Node_Id; + + procedure Make_Elab_String (Nod : Node_Id); + -- Given Nod, an identifier, or a selected component, put the + -- image into the current string literal, with double underline + -- between components. + + ---------------------- + -- Make_Elab_String -- + ---------------------- + + procedure Make_Elab_String (Nod : Node_Id) is + begin + if Nkind (Nod) = N_Selected_Component then + Make_Elab_String (Prefix (Nod)); + + case VM_Target is + when JVM_Target => + Store_String_Char ('$'); + when CLI_Target => + Store_String_Char ('.'); + when No_VM => + Store_String_Char ('_'); + Store_String_Char ('_'); + end case; + + Get_Name_String (Chars (Selector_Name (Nod))); + + else + pragma Assert (Nkind (Nod) = N_Identifier); + Get_Name_String (Chars (Nod)); + end if; + + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + end Make_Elab_String; + + -- Start of processing for Elab_Body/Elab_Spec + + begin + -- First we need to prepare the string literal for the name of + -- the elaboration routine to be referenced. + + Start_String; + Make_Elab_String (Pref); + + if VM_Target = No_VM then + Store_String_Chars ("___elab"); + Lang := Make_Identifier (Loc, Name_C); + else + Store_String_Chars ("._elab"); + Lang := Make_Identifier (Loc, Name_Ada); + end if; + + if Id = Attribute_Elab_Body then + Store_String_Char ('b'); + else + Store_String_Char ('s'); + end if; + + Str := End_String; + + Insert_Actions (N, New_List ( + Make_Subprogram_Declaration (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Ent)), + + Make_Pragma (Loc, + Chars => Name_Import, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, Expression => Lang), + + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Chars (Ent))), + + Make_Pragma_Argument_Association (Loc, + Expression => Make_String_Literal (Loc, Str)))))); + + Set_Entity (N, Ent); + Rewrite (N, New_Occurrence_Of (Ent, Loc)); + end Elab_Body; + + ---------------- + -- Elaborated -- + ---------------- + + -- Elaborated is always True for preelaborated units, predefined units, + -- pure units and units which have Elaborate_Body pragmas. These units + -- have no elaboration entity. + + -- Note: The Elaborated attribute is never passed to the back end + + when Attribute_Elaborated => Elaborated : declare + Ent : constant Entity_Id := Entity (Pref); + + begin + if Present (Elaboration_Entity (Ent)) then + Rewrite (N, + New_Occurrence_Of (Elaboration_Entity (Ent), Loc)); + else + Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); + end if; + end Elaborated; + + -------------- + -- Enum_Rep -- + -------------- + + when Attribute_Enum_Rep => Enum_Rep : + begin + -- X'Enum_Rep (Y) expands to + + -- target-type (Y) + + -- This is simply a direct conversion from the enumeration type to + -- the target integer type, which is treated by the back end as a + -- normal integer conversion, treating the enumeration type as an + -- integer, which is exactly what we want! We set Conversion_OK to + -- make sure that the analyzer does not complain about what otherwise + -- might be an illegal conversion. + + if Is_Non_Empty_List (Exprs) then + Rewrite (N, + OK_Convert_To (Typ, Relocate_Node (First (Exprs)))); + + -- X'Enum_Rep where X is an enumeration literal is replaced by + -- the literal value. + + elsif Ekind (Entity (Pref)) = E_Enumeration_Literal then + Rewrite (N, + Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Pref)))); + + -- If this is a renaming of a literal, recover the representation + -- of the original. + + elsif Ekind (Entity (Pref)) = E_Constant + and then Present (Renamed_Object (Entity (Pref))) + and then + Ekind (Entity (Renamed_Object (Entity (Pref)))) + = E_Enumeration_Literal + then + Rewrite (N, + Make_Integer_Literal (Loc, + Enumeration_Rep (Entity (Renamed_Object (Entity (Pref)))))); + + -- X'Enum_Rep where X is an object does a direct unchecked conversion + -- of the object value, as described for the type case above. + + else + Rewrite (N, + OK_Convert_To (Typ, Relocate_Node (Pref))); + end if; + + Set_Etype (N, Typ); + Analyze_And_Resolve (N, Typ); + end Enum_Rep; + + -------------- + -- Enum_Val -- + -------------- + + when Attribute_Enum_Val => Enum_Val : declare + Expr : Node_Id; + Btyp : constant Entity_Id := Base_Type (Ptyp); + + begin + -- X'Enum_Val (Y) expands to + + -- [constraint_error when _rep_to_pos (Y, False) = -1, msg] + -- X!(Y); + + Expr := Unchecked_Convert_To (Ptyp, First (Exprs)); + + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To (TSS (Btyp, TSS_Rep_To_Pos), Loc), + Parameter_Associations => New_List ( + Relocate_Node (Duplicate_Subexpr (Expr)), + New_Occurrence_Of (Standard_False, Loc))), + + Right_Opnd => Make_Integer_Literal (Loc, -1)), + Reason => CE_Range_Check_Failed)); + + Rewrite (N, Expr); + Analyze_And_Resolve (N, Ptyp); + end Enum_Val; + + -------------- + -- Exponent -- + -------------- + + -- Transforms 'Exponent into a call to the floating-point attribute + -- function Exponent in Fat_xxx (where xxx is the root type) + + when Attribute_Exponent => + Expand_Fpt_Attribute_R (N); + + ------------------ + -- External_Tag -- + ------------------ + + -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag) + + when Attribute_External_Tag => External_Tag : + begin + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_External_Tag), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Tag, + Prefix => Prefix (N))))); + + Analyze_And_Resolve (N, Standard_String); + end External_Tag; + + ----------- + -- First -- + ----------- + + when Attribute_First => + + -- If the prefix type is a constrained packed array type which + -- already has a Packed_Array_Type representation defined, then + -- replace this attribute with a direct reference to 'First of the + -- appropriate index subtype (since otherwise the back end will try + -- to give us the value of 'First for this implementation type). + + if Is_Constrained_Packed_Array (Ptyp) then + Rewrite (N, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_First, + Prefix => New_Reference_To (Get_Index_Subtype (N), Loc))); + Analyze_And_Resolve (N, Typ); + + elsif Is_Access_Type (Ptyp) then + Apply_Access_Check (N); + end if; + + --------------- + -- First_Bit -- + --------------- + + -- Compute this if component clause was present, otherwise we leave the + -- computation to be completed in the back-end, since we don't know what + -- layout will be chosen. + + when Attribute_First_Bit => First_Bit : declare + CE : constant Entity_Id := Entity (Selector_Name (Pref)); + + begin + if Known_Static_Component_Bit_Offset (CE) then + Rewrite (N, + Make_Integer_Literal (Loc, + Component_Bit_Offset (CE) mod System_Storage_Unit)); + + Analyze_And_Resolve (N, Typ); + + else + Apply_Universal_Integer_Attribute_Checks (N); + end if; + end First_Bit; + + ----------------- + -- Fixed_Value -- + ----------------- + + -- We transform: + + -- fixtype'Fixed_Value (integer-value) + + -- into + + -- fixtype(integer-value) + + -- We do all the required analysis of the conversion here, because we do + -- not want this to go through the fixed-point conversion circuits. Note + -- that the back end always treats fixed-point as equivalent to the + -- corresponding integer type anyway. + + when Attribute_Fixed_Value => Fixed_Value : + begin + Rewrite (N, + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc), + Expression => Relocate_Node (First (Exprs)))); + Set_Etype (N, Entity (Pref)); + Set_Analyzed (N); + + -- Note: it might appear that a properly analyzed unchecked conversion + -- would be just fine here, but that's not the case, since the full + -- range checks performed by the following call are critical! + + Apply_Type_Conversion_Checks (N); + end Fixed_Value; + + ----------- + -- Floor -- + ----------- + + -- Transforms 'Floor into a call to the floating-point attribute + -- function Floor in Fat_xxx (where xxx is the root type) + + when Attribute_Floor => + Expand_Fpt_Attribute_R (N); + + ---------- + -- Fore -- + ---------- + + -- For the fixed-point type Typ: + + -- Typ'Fore + + -- expands into + + -- Result_Type (System.Fore (Universal_Real (Type'First)), + -- Universal_Real (Type'Last)) + + -- Note that we know that the type is a non-static subtype, or Fore + -- would have itself been computed dynamically in Eval_Attribute. + + when Attribute_Fore => Fore : begin + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Fore), Loc), + + Parameter_Associations => New_List ( + Convert_To (Universal_Real, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_First)), + + Convert_To (Universal_Real, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_Last)))))); + + Analyze_And_Resolve (N, Typ); + end Fore; + + -------------- + -- Fraction -- + -------------- + + -- Transforms 'Fraction into a call to the floating-point attribute + -- function Fraction in Fat_xxx (where xxx is the root type) + + when Attribute_Fraction => + Expand_Fpt_Attribute_R (N); + + -------------- + -- From_Any -- + -------------- + + when Attribute_From_Any => From_Any : declare + P_Type : constant Entity_Id := Etype (Pref); + Decls : constant List_Id := New_List; + begin + Rewrite (N, + Build_From_Any_Call (P_Type, + Relocate_Node (First (Exprs)), + Decls)); + Insert_Actions (N, Decls); + Analyze_And_Resolve (N, P_Type); + end From_Any; + + -------------- + -- Identity -- + -------------- + + -- For an exception returns a reference to the exception data: + -- Exception_Id!(Prefix'Reference) + + -- For a task it returns a reference to the _task_id component of + -- corresponding record: + + -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined + + -- in Ada.Task_Identification + + when Attribute_Identity => Identity : declare + Id_Kind : Entity_Id; + + begin + if Ptyp = Standard_Exception_Type then + Id_Kind := RTE (RE_Exception_Id); + + if Present (Renamed_Object (Entity (Pref))) then + Set_Entity (Pref, Renamed_Object (Entity (Pref))); + end if; + + Rewrite (N, + Unchecked_Convert_To (Id_Kind, Make_Reference (Loc, Pref))); + else + Id_Kind := RTE (RO_AT_Task_Id); + + -- If the prefix is a task interface, the Task_Id is obtained + -- dynamically through a dispatching call, as for other task + -- attributes applied to interfaces. + + if Ada_Version >= Ada_2005 + and then Ekind (Ptyp) = E_Class_Wide_Type + and then Is_Interface (Ptyp) + and then Is_Task_Interface (Ptyp) + then + Rewrite (N, + Unchecked_Convert_To (Id_Kind, + Make_Selected_Component (Loc, + Prefix => + New_Copy_Tree (Pref), + Selector_Name => + Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))); + + else + Rewrite (N, + Unchecked_Convert_To (Id_Kind, Concurrent_Ref (Pref))); + end if; + end if; + + Analyze_And_Resolve (N, Id_Kind); + end Identity; + + ----------- + -- Image -- + ----------- + + -- Image attribute is handled in separate unit Exp_Imgv + + when Attribute_Image => + Exp_Imgv.Expand_Image_Attribute (N); + + --------- + -- Img -- + --------- + + -- X'Img is expanded to typ'Image (X), where typ is the type of X + + when Attribute_Img => Img : + begin + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_Image, + Expressions => New_List (Relocate_Node (Pref)))); + + Analyze_And_Resolve (N, Standard_String); + end Img; + + ----------- + -- Input -- + ----------- + + when Attribute_Input => Input : declare + P_Type : constant Entity_Id := Entity (Pref); + B_Type : constant Entity_Id := Base_Type (P_Type); + U_Type : constant Entity_Id := Underlying_Type (P_Type); + Strm : constant Node_Id := First (Exprs); + Fname : Entity_Id; + Decl : Node_Id; + Call : Node_Id; + Prag : Node_Id; + Arg2 : Node_Id; + Rfunc : Node_Id; + + Cntrl : Node_Id := Empty; + -- Value for controlling argument in call. Always Empty except in + -- the dispatching (class-wide type) case, where it is a reference + -- to the dummy object initialized to the right internal tag. + + procedure Freeze_Stream_Subprogram (F : Entity_Id); + -- The expansion of the attribute reference may generate a call to + -- a user-defined stream subprogram that is frozen by the call. This + -- can lead to access-before-elaboration problem if the reference + -- appears in an object declaration and the subprogram body has not + -- been seen. The freezing of the subprogram requires special code + -- because it appears in an expanded context where expressions do + -- not freeze their constituents. + + ------------------------------ + -- Freeze_Stream_Subprogram -- + ------------------------------ + + procedure Freeze_Stream_Subprogram (F : Entity_Id) is + Decl : constant Node_Id := Unit_Declaration_Node (F); + Bod : Node_Id; + + begin + -- If this is user-defined subprogram, the corresponding + -- stream function appears as a renaming-as-body, and the + -- user subprogram must be retrieved by tree traversal. + + if Present (Decl) + and then Nkind (Decl) = N_Subprogram_Declaration + and then Present (Corresponding_Body (Decl)) + then + Bod := Corresponding_Body (Decl); + + if Nkind (Unit_Declaration_Node (Bod)) = + N_Subprogram_Renaming_Declaration + then + Set_Is_Frozen (Entity (Name (Unit_Declaration_Node (Bod)))); + end if; + end if; + end Freeze_Stream_Subprogram; + + -- Start of processing for Input + + begin + -- If no underlying type, we have an error that will be diagnosed + -- elsewhere, so here we just completely ignore the expansion. + + if No (U_Type) then + return; + end if; + + -- If there is a TSS for Input, just call it + + Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input); + + if Present (Fname) then + null; + + else + -- If there is a Stream_Convert pragma, use it, we rewrite + + -- sourcetyp'Input (stream) + + -- as + + -- sourcetyp (streamread (strmtyp'Input (stream))); + + -- where streamread is the given Read function that converts an + -- argument of type strmtyp to type sourcetyp or a type from which + -- it is derived (extra conversion required for the derived case). + + Prag := Get_Stream_Convert_Pragma (P_Type); + + if Present (Prag) then + Arg2 := Next (First (Pragma_Argument_Associations (Prag))); + Rfunc := Entity (Expression (Arg2)); + + Rewrite (N, + Convert_To (B_Type, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Rfunc, Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Etype (First_Formal (Rfunc)), Loc), + Attribute_Name => Name_Input, + Expressions => Exprs))))); + + Analyze_And_Resolve (N, B_Type); + return; + + -- Elementary types + + elsif Is_Elementary_Type (U_Type) then + + -- A special case arises if we have a defined _Read routine, + -- since in this case we are required to call this routine. + + if Present (TSS (Base_Type (U_Type), TSS_Stream_Read)) then + Build_Record_Or_Elementary_Input_Function + (Loc, U_Type, Decl, Fname); + Insert_Action (N, Decl); + + -- For normal cases, we call the I_xxx routine directly + + else + Rewrite (N, Build_Elementary_Input_Call (N)); + Analyze_And_Resolve (N, P_Type); + return; + end if; + + -- Array type case + + elsif Is_Array_Type (U_Type) then + Build_Array_Input_Function (Loc, U_Type, Decl, Fname); + Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False); + + -- Dispatching case with class-wide type + + elsif Is_Class_Wide_Type (P_Type) then + + -- No need to do anything else compiling under restriction + -- No_Dispatching_Calls. During the semantic analysis we + -- already notified such violation. + + if Restriction_Active (No_Dispatching_Calls) then + return; + end if; + + declare + Rtyp : constant Entity_Id := Root_Type (P_Type); + Dnn : Entity_Id; + Decl : Node_Id; + Expr : Node_Id; + + begin + -- Read the internal tag (RM 13.13.2(34)) and use it to + -- initialize a dummy tag object: + + -- Dnn : Ada.Tags.Tag := + -- Descendant_Tag (String'Input (Strm), P_Type); + + -- This dummy object is used only to provide a controlling + -- argument for the eventual _Input call. Descendant_Tag is + -- called rather than Internal_Tag to ensure that we have a + -- tag for a type that is descended from the prefix type and + -- declared at the same accessibility level (the exception + -- Tag_Error will be raised otherwise). The level check is + -- required for Ada 2005 because tagged types can be + -- extended in nested scopes (AI-344). + + Expr := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_String, Loc), + Attribute_Name => Name_Input, + Expressions => New_List ( + Relocate_Node (Duplicate_Subexpr (Strm)))), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (P_Type, Loc), + Attribute_Name => Name_Tag))); + + Dnn := Make_Temporary (Loc, 'D', Expr); + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Dnn, + Object_Definition => + New_Occurrence_Of (RTE (RE_Tag), Loc), + Expression => Expr); + + Insert_Action (N, Decl); + + -- Now we need to get the entity for the call, and construct + -- a function call node, where we preset a reference to Dnn + -- as the controlling argument (doing an unchecked convert + -- to the class-wide tagged type to make it look like a real + -- tagged object). + + Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input); + Cntrl := + Unchecked_Convert_To (P_Type, + New_Occurrence_Of (Dnn, Loc)); + Set_Etype (Cntrl, P_Type); + Set_Parent (Cntrl, N); + end; + + -- For tagged types, use the primitive Input function + + elsif Is_Tagged_Type (U_Type) then + Fname := Find_Prim_Op (U_Type, TSS_Stream_Input); + + -- All other record type cases, including protected records. The + -- latter only arise for expander generated code for handling + -- shared passive partition access. + + else + pragma Assert + (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type)); + + -- Ada 2005 (AI-216): Program_Error is raised executing default + -- implementation of the Input attribute of an unchecked union + -- type if the type lacks default discriminant values. + + if Is_Unchecked_Union (Base_Type (U_Type)) + and then No (Discriminant_Constraint (U_Type)) + then + Insert_Action (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction)); + + return; + end if; + + Build_Record_Or_Elementary_Input_Function + (Loc, Base_Type (U_Type), Decl, Fname); + Insert_Action (N, Decl); + + if Nkind (Parent (N)) = N_Object_Declaration + and then Is_Record_Type (U_Type) + then + -- The stream function may contain calls to user-defined + -- Read procedures for individual components. + + declare + Comp : Entity_Id; + Func : Entity_Id; + + begin + Comp := First_Component (U_Type); + while Present (Comp) loop + Func := + Find_Stream_Subprogram + (Etype (Comp), TSS_Stream_Read); + + if Present (Func) then + Freeze_Stream_Subprogram (Func); + end if; + + Next_Component (Comp); + end loop; + end; + end if; + end if; + end if; + + -- If we fall through, Fname is the function to be called. The result + -- is obtained by calling the appropriate function, then converting + -- the result. The conversion does a subtype check. + + Call := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Fname, Loc), + Parameter_Associations => New_List ( + Relocate_Node (Strm))); + + Set_Controlling_Argument (Call, Cntrl); + Rewrite (N, Unchecked_Convert_To (P_Type, Call)); + Analyze_And_Resolve (N, P_Type); + + if Nkind (Parent (N)) = N_Object_Declaration then + Freeze_Stream_Subprogram (Fname); + end if; + end Input; + + ------------------- + -- Integer_Value -- + ------------------- + + -- We transform + + -- inttype'Fixed_Value (fixed-value) + + -- into + + -- inttype(integer-value)) + + -- we do all the required analysis of the conversion here, because we do + -- not want this to go through the fixed-point conversion circuits. Note + -- that the back end always treats fixed-point as equivalent to the + -- corresponding integer type anyway. + + when Attribute_Integer_Value => Integer_Value : + begin + Rewrite (N, + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc), + Expression => Relocate_Node (First (Exprs)))); + Set_Etype (N, Entity (Pref)); + Set_Analyzed (N); + + -- Note: it might appear that a properly analyzed unchecked conversion + -- would be just fine here, but that's not the case, since the full + -- range checks performed by the following call are critical! + + Apply_Type_Conversion_Checks (N); + end Integer_Value; + + ------------------- + -- Invalid_Value -- + ------------------- + + when Attribute_Invalid_Value => + Rewrite (N, Get_Simple_Init_Val (Ptyp, N)); + + ---------- + -- Last -- + ---------- + + when Attribute_Last => + + -- If the prefix type is a constrained packed array type which + -- already has a Packed_Array_Type representation defined, then + -- replace this attribute with a direct reference to 'Last of the + -- appropriate index subtype (since otherwise the back end will try + -- to give us the value of 'Last for this implementation type). + + if Is_Constrained_Packed_Array (Ptyp) then + Rewrite (N, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Last, + Prefix => New_Reference_To (Get_Index_Subtype (N), Loc))); + Analyze_And_Resolve (N, Typ); + + elsif Is_Access_Type (Ptyp) then + Apply_Access_Check (N); + end if; + + -------------- + -- Last_Bit -- + -------------- + + -- We compute this if a component clause was present, otherwise we leave + -- the computation up to the back end, since we don't know what layout + -- will be chosen. + + when Attribute_Last_Bit => Last_Bit : declare + CE : constant Entity_Id := Entity (Selector_Name (Pref)); + + begin + if Known_Static_Component_Bit_Offset (CE) + and then Known_Static_Esize (CE) + then + Rewrite (N, + Make_Integer_Literal (Loc, + Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit) + + Esize (CE) - 1)); + + Analyze_And_Resolve (N, Typ); + + else + Apply_Universal_Integer_Attribute_Checks (N); + end if; + end Last_Bit; + + ------------------ + -- Leading_Part -- + ------------------ + + -- Transforms 'Leading_Part into a call to the floating-point attribute + -- function Leading_Part in Fat_xxx (where xxx is the root type) + + -- Note: strictly, we should generate special case code to deal with + -- absurdly large positive arguments (greater than Integer'Last), which + -- result in returning the first argument unchanged, but it hardly seems + -- worth the effort. We raise constraint error for absurdly negative + -- arguments which is fine. + + when Attribute_Leading_Part => + Expand_Fpt_Attribute_RI (N); + + ------------ + -- Length -- + ------------ + + when Attribute_Length => declare + Ityp : Entity_Id; + Xnum : Uint; + + begin + -- Processing for packed array types + + if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then + Ityp := Get_Index_Subtype (N); + + -- If the index type, Ityp, is an enumeration type with holes, + -- then we calculate X'Length explicitly using + + -- Typ'Max + -- (0, Ityp'Pos (X'Last (N)) - + -- Ityp'Pos (X'First (N)) + 1); + + -- Since the bounds in the template are the representation values + -- and the back end would get the wrong value. + + if Is_Enumeration_Type (Ityp) + and then Present (Enum_Pos_To_Rep (Base_Type (Ityp))) + then + if No (Exprs) then + Xnum := Uint_1; + else + Xnum := Expr_Value (First (Expressions (N))); + end if; + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Max, + Expressions => New_List + (Make_Integer_Literal (Loc, 0), + + Make_Op_Add (Loc, + Left_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ityp, Loc), + Attribute_Name => Name_Pos, + + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Pref), + Attribute_Name => Name_Last, + Expressions => New_List ( + Make_Integer_Literal (Loc, Xnum))))), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ityp, Loc), + Attribute_Name => Name_Pos, + + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr_No_Checks (Pref), + Attribute_Name => Name_First, + Expressions => New_List ( + Make_Integer_Literal (Loc, Xnum)))))), + + Right_Opnd => Make_Integer_Literal (Loc, 1))))); + + Analyze_And_Resolve (N, Typ, Suppress => All_Checks); + return; + + -- If the prefix type is a constrained packed array type which + -- already has a Packed_Array_Type representation defined, then + -- replace this attribute with a direct reference to 'Range_Length + -- of the appropriate index subtype (since otherwise the back end + -- will try to give us the value of 'Length for this + -- implementation type). + + elsif Is_Constrained (Ptyp) then + Rewrite (N, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Range_Length, + Prefix => New_Reference_To (Ityp, Loc))); + Analyze_And_Resolve (N, Typ); + end if; + + -- Access type case + + elsif Is_Access_Type (Ptyp) then + Apply_Access_Check (N); + + -- If the designated type is a packed array type, then we convert + -- the reference to: + + -- typ'Max (0, 1 + + -- xtyp'Pos (Pref'Last (Expr)) - + -- xtyp'Pos (Pref'First (Expr))); + + -- This is a bit complex, but it is the easiest thing to do that + -- works in all cases including enum types with holes xtyp here + -- is the appropriate index type. + + declare + Dtyp : constant Entity_Id := Designated_Type (Ptyp); + Xtyp : Entity_Id; + + begin + if Is_Array_Type (Dtyp) and then Is_Packed (Dtyp) then + Xtyp := Get_Index_Subtype (N); + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Max, + Expressions => New_List ( + Make_Integer_Literal (Loc, 0), + + Make_Op_Add (Loc, + Make_Integer_Literal (Loc, 1), + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Xtyp, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Pref), + Attribute_Name => Name_Last, + Expressions => + New_Copy_List (Exprs)))), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Xtyp, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr_No_Checks (Pref), + Attribute_Name => Name_First, + Expressions => + New_Copy_List (Exprs))))))))); + + Analyze_And_Resolve (N, Typ); + end if; + end; + + -- Otherwise leave it to the back end + + else + Apply_Universal_Integer_Attribute_Checks (N); + end if; + end; + + ------------- + -- Machine -- + ------------- + + -- Transforms 'Machine into a call to the floating-point attribute + -- function Machine in Fat_xxx (where xxx is the root type) + + when Attribute_Machine => + Expand_Fpt_Attribute_R (N); + + ---------------------- + -- Machine_Rounding -- + ---------------------- + + -- Transforms 'Machine_Rounding into a call to the floating-point + -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root + -- type). Expansion is avoided for cases the back end can handle + -- directly. + + when Attribute_Machine_Rounding => + if not Is_Inline_Floating_Point_Attribute (N) then + Expand_Fpt_Attribute_R (N); + end if; + + ------------------ + -- Machine_Size -- + ------------------ + + -- Machine_Size is equivalent to Object_Size, so transform it into + -- Object_Size and that way the back end never sees Machine_Size. + + when Attribute_Machine_Size => + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => Prefix (N), + Attribute_Name => Name_Object_Size)); + + Analyze_And_Resolve (N, Typ); + + -------------- + -- Mantissa -- + -------------- + + -- The only case that can get this far is the dynamic case of the old + -- Ada 83 Mantissa attribute for the fixed-point case. For this case, + -- we expand: + + -- typ'Mantissa + + -- into + + -- ityp (System.Mantissa.Mantissa_Value + -- (Integer'Integer_Value (typ'First), + -- Integer'Integer_Value (typ'Last))); + + when Attribute_Mantissa => Mantissa : begin + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc), + + Parameter_Associations => New_List ( + + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Integer, Loc), + Attribute_Name => Name_Integer_Value, + Expressions => New_List ( + + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Attribute_Name => Name_First))), + + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Integer, Loc), + Attribute_Name => Name_Integer_Value, + Expressions => New_List ( + + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Attribute_Name => Name_Last))))))); + + Analyze_And_Resolve (N, Typ); + end Mantissa; + + -------------------- + -- Mechanism_Code -- + -------------------- + + when Attribute_Mechanism_Code => + + -- We must replace the prefix in the renamed case + + if Is_Entity_Name (Pref) + and then Present (Alias (Entity (Pref))) + then + Set_Renamed_Subprogram (Pref, Alias (Entity (Pref))); + end if; + + --------- + -- Mod -- + --------- + + when Attribute_Mod => Mod_Case : declare + Arg : constant Node_Id := Relocate_Node (First (Exprs)); + Hi : constant Node_Id := Type_High_Bound (Etype (Arg)); + Modv : constant Uint := Modulus (Btyp); + + begin + + -- This is not so simple. The issue is what type to use for the + -- computation of the modular value. + + -- The easy case is when the modulus value is within the bounds + -- of the signed integer type of the argument. In this case we can + -- just do the computation in that signed integer type, and then + -- do an ordinary conversion to the target type. + + if Modv <= Expr_Value (Hi) then + Rewrite (N, + Convert_To (Btyp, + Make_Op_Mod (Loc, + Left_Opnd => Arg, + Right_Opnd => Make_Integer_Literal (Loc, Modv)))); + + -- Here we know that the modulus is larger than type'Last of the + -- integer type. There are two cases to consider: + + -- a) The integer value is non-negative. In this case, it is + -- returned as the result (since it is less than the modulus). + + -- b) The integer value is negative. In this case, we know that the + -- result is modulus + value, where the value might be as small as + -- -modulus. The trouble is what type do we use to do the subtract. + -- No type will do, since modulus can be as big as 2**64, and no + -- integer type accommodates this value. Let's do bit of algebra + + -- modulus + value + -- = modulus - (-value) + -- = (modulus - 1) - (-value - 1) + + -- Now modulus - 1 is certainly in range of the modular type. + -- -value is in the range 1 .. modulus, so -value -1 is in the + -- range 0 .. modulus-1 which is in range of the modular type. + -- Furthermore, (-value - 1) can be expressed as -(value + 1) + -- which we can compute using the integer base type. + + -- Once this is done we analyze the conditional expression without + -- range checks, because we know everything is in range, and we + -- want to prevent spurious warnings on either branch. + + else + Rewrite (N, + Make_Conditional_Expression (Loc, + Expressions => New_List ( + Make_Op_Ge (Loc, + Left_Opnd => Duplicate_Subexpr (Arg), + Right_Opnd => Make_Integer_Literal (Loc, 0)), + + Convert_To (Btyp, + Duplicate_Subexpr_No_Checks (Arg)), + + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Integer_Literal (Loc, + Intval => Modv - 1), + Right_Opnd => + Convert_To (Btyp, + Make_Op_Minus (Loc, + Right_Opnd => + Make_Op_Add (Loc, + Left_Opnd => Duplicate_Subexpr_No_Checks (Arg), + Right_Opnd => + Make_Integer_Literal (Loc, + Intval => 1)))))))); + + end if; + + Analyze_And_Resolve (N, Btyp, Suppress => All_Checks); + end Mod_Case; + + ----------- + -- Model -- + ----------- + + -- Transforms 'Model into a call to the floating-point attribute + -- function Model in Fat_xxx (where xxx is the root type) + + when Attribute_Model => + Expand_Fpt_Attribute_R (N); + + ----------------- + -- Object_Size -- + ----------------- + + -- The processing for Object_Size shares the processing for Size + + --------- + -- Old -- + --------- + + when Attribute_Old => Old : declare + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', Pref); + Subp : Node_Id; + Asn_Stm : Node_Id; + + begin + -- Find the nearest subprogram body, ignoring _Preconditions + + Subp := N; + loop + Subp := Parent (Subp); + exit when Nkind (Subp) = N_Subprogram_Body + and then Chars (Defining_Entity (Subp)) /= Name_uPostconditions; + end loop; + + -- Insert the initialized object declaration at the start of the + -- subprogram's declarations. + + Asn_Stm := + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Etype (N), Loc), + Expression => Pref); + + -- Push the subprogram's scope, so that the object will be analyzed + -- in that context (rather than the context of the Precondition + -- subprogram) and will have its Scope set properly. + + if Present (Corresponding_Spec (Subp)) then + Push_Scope (Corresponding_Spec (Subp)); + else + Push_Scope (Defining_Entity (Subp)); + end if; + + if Is_Empty_List (Declarations (Subp)) then + Set_Declarations (Subp, New_List (Asn_Stm)); + Analyze (Asn_Stm); + else + Insert_Action (First (Declarations (Subp)), Asn_Stm); + end if; + + Pop_Scope; + + Rewrite (N, New_Occurrence_Of (Tnn, Loc)); + end Old; + + ------------ + -- Output -- + ------------ + + when Attribute_Output => Output : declare + P_Type : constant Entity_Id := Entity (Pref); + U_Type : constant Entity_Id := Underlying_Type (P_Type); + Pname : Entity_Id; + Decl : Node_Id; + Prag : Node_Id; + Arg3 : Node_Id; + Wfunc : Node_Id; + + begin + -- If no underlying type, we have an error that will be diagnosed + -- elsewhere, so here we just completely ignore the expansion. + + if No (U_Type) then + return; + end if; + + -- If TSS for Output is present, just call it + + Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output); + + if Present (Pname) then + null; + + else + -- If there is a Stream_Convert pragma, use it, we rewrite + + -- sourcetyp'Output (stream, Item) + + -- as + + -- strmtyp'Output (Stream, strmwrite (acttyp (Item))); + + -- where strmwrite is the given Write function that converts an + -- argument of type sourcetyp or a type acctyp, from which it is + -- derived to type strmtyp. The conversion to acttyp is required + -- for the derived case. + + Prag := Get_Stream_Convert_Pragma (P_Type); + + if Present (Prag) then + Arg3 := + Next (Next (First (Pragma_Argument_Associations (Prag)))); + Wfunc := Entity (Expression (Arg3)); + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etype (Wfunc), Loc), + Attribute_Name => Name_Output, + Expressions => New_List ( + Relocate_Node (First (Exprs)), + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Wfunc, Loc), + Parameter_Associations => New_List ( + OK_Convert_To (Etype (First_Formal (Wfunc)), + Relocate_Node (Next (First (Exprs))))))))); + + Analyze (N); + return; + + -- For elementary types, we call the W_xxx routine directly. + -- Note that the effect of Write and Output is identical for + -- the case of an elementary type, since there are no + -- discriminants or bounds. + + elsif Is_Elementary_Type (U_Type) then + + -- A special case arises if we have a defined _Write routine, + -- since in this case we are required to call this routine. + + if Present (TSS (Base_Type (U_Type), TSS_Stream_Write)) then + Build_Record_Or_Elementary_Output_Procedure + (Loc, U_Type, Decl, Pname); + Insert_Action (N, Decl); + + -- For normal cases, we call the W_xxx routine directly + + else + Rewrite (N, Build_Elementary_Write_Call (N)); + Analyze (N); + return; + end if; + + -- Array type case + + elsif Is_Array_Type (U_Type) then + Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname); + Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False); + + -- Class-wide case, first output external tag, then dispatch + -- to the appropriate primitive Output function (RM 13.13.2(31)). + + elsif Is_Class_Wide_Type (P_Type) then + + -- No need to do anything else compiling under restriction + -- No_Dispatching_Calls. During the semantic analysis we + -- already notified such violation. + + if Restriction_Active (No_Dispatching_Calls) then + return; + end if; + + Tag_Write : declare + Strm : constant Node_Id := First (Exprs); + Item : constant Node_Id := Next (Strm); + + begin + -- Ada 2005 (AI-344): Check that the accessibility level + -- of the type of the output object is not deeper than + -- that of the attribute's prefix type. + + -- if Get_Access_Level (Item'Tag) + -- /= Get_Access_Level (P_Type'Tag) + -- then + -- raise Tag_Error; + -- end if; + + -- String'Output (Strm, External_Tag (Item'Tag)); + + -- We cannot figure out a practical way to implement this + -- accessibility check on virtual machines, so we omit it. + + if Ada_Version >= Ada_2005 + and then Tagged_Type_Expansion + then + Insert_Action (N, + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => + Build_Get_Access_Level (Loc, + Make_Attribute_Reference (Loc, + Prefix => + Relocate_Node ( + Duplicate_Subexpr (Item, + Name_Req => True)), + Attribute_Name => Name_Tag)), + + Right_Opnd => + Make_Integer_Literal (Loc, + Type_Access_Level (P_Type))), + + Then_Statements => + New_List (Make_Raise_Statement (Loc, + New_Occurrence_Of ( + RTE (RE_Tag_Error), Loc))))); + end if; + + Insert_Action (N, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_String, Loc), + Attribute_Name => Name_Output, + Expressions => New_List ( + Relocate_Node (Duplicate_Subexpr (Strm)), + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_External_Tag), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + Relocate_Node + (Duplicate_Subexpr (Item, Name_Req => True)), + Attribute_Name => Name_Tag)))))); + end Tag_Write; + + Pname := Find_Prim_Op (U_Type, TSS_Stream_Output); + + -- Tagged type case, use the primitive Output function + + elsif Is_Tagged_Type (U_Type) then + Pname := Find_Prim_Op (U_Type, TSS_Stream_Output); + + -- All other record type cases, including protected records. + -- The latter only arise for expander generated code for + -- handling shared passive partition access. + + else + pragma Assert + (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type)); + + -- Ada 2005 (AI-216): Program_Error is raised when executing + -- the default implementation of the Output attribute of an + -- unchecked union type if the type lacks default discriminant + -- values. + + if Is_Unchecked_Union (Base_Type (U_Type)) + and then No (Discriminant_Constraint (U_Type)) + then + Insert_Action (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction)); + + return; + end if; + + Build_Record_Or_Elementary_Output_Procedure + (Loc, Base_Type (U_Type), Decl, Pname); + Insert_Action (N, Decl); + end if; + end if; + + -- If we fall through, Pname is the name of the procedure to call + + Rewrite_Stream_Proc_Call (Pname); + end Output; + + --------- + -- Pos -- + --------- + + -- For enumeration types with a standard representation, Pos is + -- handled by the back end. + + -- For enumeration types, with a non-standard representation we generate + -- a call to the _Rep_To_Pos function created when the type was frozen. + -- The call has the form + + -- _rep_to_pos (expr, flag) + + -- The parameter flag is True if range checks are enabled, causing + -- Program_Error to be raised if the expression has an invalid + -- representation, and False if range checks are suppressed. + + -- For integer types, Pos is equivalent to a simple integer + -- conversion and we rewrite it as such + + when Attribute_Pos => Pos : + declare + Etyp : Entity_Id := Base_Type (Entity (Pref)); + + begin + -- Deal with zero/non-zero boolean values + + if Is_Boolean_Type (Etyp) then + Adjust_Condition (First (Exprs)); + Etyp := Standard_Boolean; + Set_Prefix (N, New_Occurrence_Of (Standard_Boolean, Loc)); + end if; + + -- Case of enumeration type + + if Is_Enumeration_Type (Etyp) then + + -- Non-standard enumeration type (generate call) + + if Present (Enum_Pos_To_Rep (Etyp)) then + Append_To (Exprs, Rep_To_Pos_Flag (Etyp, Loc)); + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => + New_Reference_To (TSS (Etyp, TSS_Rep_To_Pos), Loc), + Parameter_Associations => Exprs))); + + Analyze_And_Resolve (N, Typ); + + -- Standard enumeration type (do universal integer check) + + else + Apply_Universal_Integer_Attribute_Checks (N); + end if; + + -- Deal with integer types (replace by conversion) + + elsif Is_Integer_Type (Etyp) then + Rewrite (N, Convert_To (Typ, First (Exprs))); + Analyze_And_Resolve (N, Typ); + end if; + + end Pos; + + -------------- + -- Position -- + -------------- + + -- We compute this if a component clause was present, otherwise we leave + -- the computation up to the back end, since we don't know what layout + -- will be chosen. + + when Attribute_Position => Position : + declare + CE : constant Entity_Id := Entity (Selector_Name (Pref)); + + begin + if Present (Component_Clause (CE)) then + Rewrite (N, + Make_Integer_Literal (Loc, + Intval => Component_Bit_Offset (CE) / System_Storage_Unit)); + Analyze_And_Resolve (N, Typ); + + else + Apply_Universal_Integer_Attribute_Checks (N); + end if; + end Position; + + ---------- + -- Pred -- + ---------- + + -- 1. Deal with enumeration types with holes + -- 2. For floating-point, generate call to attribute function + -- 3. For other cases, deal with constraint checking + + when Attribute_Pred => Pred : + declare + Etyp : constant Entity_Id := Base_Type (Ptyp); + + begin + + -- For enumeration types with non-standard representations, we + -- expand typ'Pred (x) into + + -- Pos_To_Rep (Rep_To_Pos (x) - 1) + + -- If the representation is contiguous, we compute instead + -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations. + -- The conversion function Enum_Pos_To_Rep is defined on the + -- base type, not the subtype, so we have to use the base type + -- explicitly for this and other enumeration attributes. + + if Is_Enumeration_Type (Ptyp) + and then Present (Enum_Pos_To_Rep (Etyp)) + then + if Has_Contiguous_Rep (Etyp) then + Rewrite (N, + Unchecked_Convert_To (Ptyp, + Make_Op_Add (Loc, + Left_Opnd => + Make_Integer_Literal (Loc, + Enumeration_Rep (First_Literal (Ptyp))), + Right_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To + (TSS (Etyp, TSS_Rep_To_Pos), Loc), + + Parameter_Associations => + New_List ( + Unchecked_Convert_To (Ptyp, + Make_Op_Subtract (Loc, + Left_Opnd => + Unchecked_Convert_To (Standard_Integer, + Relocate_Node (First (Exprs))), + Right_Opnd => + Make_Integer_Literal (Loc, 1))), + Rep_To_Pos_Flag (Ptyp, Loc)))))); + + else + -- Add Boolean parameter True, to request program errror if + -- we have a bad representation on our hands. If checks are + -- suppressed, then add False instead + + Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc)); + Rewrite (N, + Make_Indexed_Component (Loc, + Prefix => + New_Reference_To + (Enum_Pos_To_Rep (Etyp), Loc), + Expressions => New_List ( + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To + (TSS (Etyp, TSS_Rep_To_Pos), Loc), + Parameter_Associations => Exprs), + Right_Opnd => Make_Integer_Literal (Loc, 1))))); + end if; + + Analyze_And_Resolve (N, Typ); + + -- For floating-point, we transform 'Pred into a call to the Pred + -- floating-point attribute function in Fat_xxx (xxx is root type) + + elsif Is_Floating_Point_Type (Ptyp) then + Expand_Fpt_Attribute_R (N); + Analyze_And_Resolve (N, Typ); + + -- For modular types, nothing to do (no overflow, since wraps) + + elsif Is_Modular_Integer_Type (Ptyp) then + null; + + -- For other types, if argument is marked as needing a range check or + -- overflow checking is enabled, we must generate a check. + + elsif not Overflow_Checks_Suppressed (Ptyp) + or else Do_Range_Check (First (Exprs)) + then + Set_Do_Range_Check (First (Exprs), False); + Expand_Pred_Succ (N); + end if; + end Pred; + + -------------- + -- Priority -- + -------------- + + -- Ada 2005 (AI-327): Dynamic ceiling priorities + + -- We rewrite X'Priority as the following run-time call: + + -- Get_Ceiling (X._Object) + + -- Note that although X'Priority is notionally an object, it is quite + -- deliberately not defined as an aliased object in the RM. This means + -- that it works fine to rewrite it as a call, without having to worry + -- about complications that would other arise from X'Priority'Access, + -- which is illegal, because of the lack of aliasing. + + when Attribute_Priority => + declare + Call : Node_Id; + Conctyp : Entity_Id; + Object_Parm : Node_Id; + Subprg : Entity_Id; + RT_Subprg_Name : Node_Id; + + begin + -- Look for the enclosing concurrent type + + Conctyp := Current_Scope; + while not Is_Concurrent_Type (Conctyp) loop + Conctyp := Scope (Conctyp); + end loop; + + pragma Assert (Is_Protected_Type (Conctyp)); + + -- Generate the actual of the call + + Subprg := Current_Scope; + while not Present (Protected_Body_Subprogram (Subprg)) loop + Subprg := Scope (Subprg); + end loop; + + -- Use of 'Priority inside protected entries and barriers (in + -- both cases the type of the first formal of their expanded + -- subprogram is Address) + + if Etype (First_Entity (Protected_Body_Subprogram (Subprg))) + = RTE (RE_Address) + then + declare + New_Itype : Entity_Id; + + begin + -- In the expansion of protected entries the type of the + -- first formal of the Protected_Body_Subprogram is an + -- Address. In order to reference the _object component + -- we generate: + + -- type T is access p__ptTV; + -- freeze T [] + + New_Itype := Create_Itype (E_Access_Type, N); + Set_Etype (New_Itype, New_Itype); + Set_Directly_Designated_Type (New_Itype, + Corresponding_Record_Type (Conctyp)); + Freeze_Itype (New_Itype, N); + + -- Generate: + -- T!(O)._object'unchecked_access + + Object_Parm := + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (New_Itype, + New_Reference_To + (First_Entity + (Protected_Body_Subprogram (Subprg)), + Loc)), + Selector_Name => + Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access); + end; + + -- Use of 'Priority inside a protected subprogram + + else + Object_Parm := + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To + (First_Entity + (Protected_Body_Subprogram (Subprg)), + Loc), + Selector_Name => Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access); + end if; + + -- Select the appropriate run-time subprogram + + if Number_Entries (Conctyp) = 0 then + RT_Subprg_Name := + New_Reference_To (RTE (RE_Get_Ceiling), Loc); + else + RT_Subprg_Name := + New_Reference_To (RTE (RO_PE_Get_Ceiling), Loc); + end if; + + Call := + Make_Function_Call (Loc, + Name => RT_Subprg_Name, + Parameter_Associations => New_List (Object_Parm)); + + Rewrite (N, Call); + + -- Avoid the generation of extra checks on the pointer to the + -- protected object. + + Analyze_And_Resolve (N, Typ, Suppress => Access_Check); + end; + + ------------------ + -- Range_Length -- + ------------------ + + when Attribute_Range_Length => Range_Length : begin + + -- The only special processing required is for the case where + -- Range_Length is applied to an enumeration type with holes. + -- In this case we transform + + -- X'Range_Length + + -- to + + -- X'Pos (X'Last) - X'Pos (X'First) + 1 + + -- So that the result reflects the proper Pos values instead + -- of the underlying representations. + + if Is_Enumeration_Type (Ptyp) + and then Has_Non_Standard_Rep (Ptyp) + then + Rewrite (N, + Make_Op_Add (Loc, + Left_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Pos, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Last, + Prefix => New_Occurrence_Of (Ptyp, Loc)))), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Pos, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Attribute_Name => Name_First, + Prefix => New_Occurrence_Of (Ptyp, Loc))))), + + Right_Opnd => Make_Integer_Literal (Loc, 1))); + + Analyze_And_Resolve (N, Typ); + + -- For all other cases, the attribute is handled by the back end, but + -- we need to deal with the case of the range check on a universal + -- integer. + + else + Apply_Universal_Integer_Attribute_Checks (N); + end if; + end Range_Length; + + ---------- + -- Read -- + ---------- + + when Attribute_Read => Read : declare + P_Type : constant Entity_Id := Entity (Pref); + B_Type : constant Entity_Id := Base_Type (P_Type); + U_Type : constant Entity_Id := Underlying_Type (P_Type); + Pname : Entity_Id; + Decl : Node_Id; + Prag : Node_Id; + Arg2 : Node_Id; + Rfunc : Node_Id; + Lhs : Node_Id; + Rhs : Node_Id; + + begin + -- If no underlying type, we have an error that will be diagnosed + -- elsewhere, so here we just completely ignore the expansion. + + if No (U_Type) then + return; + end if; + + -- The simple case, if there is a TSS for Read, just call it + + Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read); + + if Present (Pname) then + null; + + else + -- If there is a Stream_Convert pragma, use it, we rewrite + + -- sourcetyp'Read (stream, Item) + + -- as + + -- Item := sourcetyp (strmread (strmtyp'Input (Stream))); + + -- where strmread is the given Read function that converts an + -- argument of type strmtyp to type sourcetyp or a type from which + -- it is derived. The conversion to sourcetyp is required in the + -- latter case. + + -- A special case arises if Item is a type conversion in which + -- case, we have to expand to: + + -- Itemx := typex (strmread (strmtyp'Input (Stream))); + + -- where Itemx is the expression of the type conversion (i.e. + -- the actual object), and typex is the type of Itemx. + + Prag := Get_Stream_Convert_Pragma (P_Type); + + if Present (Prag) then + Arg2 := Next (First (Pragma_Argument_Associations (Prag))); + Rfunc := Entity (Expression (Arg2)); + Lhs := Relocate_Node (Next (First (Exprs))); + Rhs := + OK_Convert_To (B_Type, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Rfunc, Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Etype (First_Formal (Rfunc)), Loc), + Attribute_Name => Name_Input, + Expressions => New_List ( + Relocate_Node (First (Exprs))))))); + + if Nkind (Lhs) = N_Type_Conversion then + Lhs := Expression (Lhs); + Rhs := Convert_To (Etype (Lhs), Rhs); + end if; + + Rewrite (N, + Make_Assignment_Statement (Loc, + Name => Lhs, + Expression => Rhs)); + Set_Assignment_OK (Lhs); + Analyze (N); + return; + + -- For elementary types, we call the I_xxx routine using the first + -- parameter and then assign the result into the second parameter. + -- We set Assignment_OK to deal with the conversion case. + + elsif Is_Elementary_Type (U_Type) then + declare + Lhs : Node_Id; + Rhs : Node_Id; + + begin + Lhs := Relocate_Node (Next (First (Exprs))); + Rhs := Build_Elementary_Input_Call (N); + + if Nkind (Lhs) = N_Type_Conversion then + Lhs := Expression (Lhs); + Rhs := Convert_To (Etype (Lhs), Rhs); + end if; + + Set_Assignment_OK (Lhs); + + Rewrite (N, + Make_Assignment_Statement (Loc, + Name => Lhs, + Expression => Rhs)); + + Analyze (N); + return; + end; + + -- Array type case + + elsif Is_Array_Type (U_Type) then + Build_Array_Read_Procedure (N, U_Type, Decl, Pname); + Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False); + + -- Tagged type case, use the primitive Read function. Note that + -- this will dispatch in the class-wide case which is what we want + + elsif Is_Tagged_Type (U_Type) then + Pname := Find_Prim_Op (U_Type, TSS_Stream_Read); + + -- All other record type cases, including protected records. The + -- latter only arise for expander generated code for handling + -- shared passive partition access. + + else + pragma Assert + (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type)); + + -- Ada 2005 (AI-216): Program_Error is raised when executing + -- the default implementation of the Read attribute of an + -- Unchecked_Union type. + + if Is_Unchecked_Union (Base_Type (U_Type)) then + Insert_Action (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction)); + end if; + + if Has_Discriminants (U_Type) + and then Present + (Discriminant_Default_Value (First_Discriminant (U_Type))) + then + Build_Mutable_Record_Read_Procedure + (Loc, Full_Base (U_Type), Decl, Pname); + else + Build_Record_Read_Procedure + (Loc, Full_Base (U_Type), Decl, Pname); + end if; + + -- Suppress checks, uninitialized or otherwise invalid + -- data does not cause constraint errors to be raised for + -- a complete record read. + + Insert_Action (N, Decl, All_Checks); + end if; + end if; + + Rewrite_Stream_Proc_Call (Pname); + end Read; + + --------- + -- Ref -- + --------- + + -- Ref is identical to To_Address, see To_Address for processing + + --------------- + -- Remainder -- + --------------- + + -- Transforms 'Remainder into a call to the floating-point attribute + -- function Remainder in Fat_xxx (where xxx is the root type) + + when Attribute_Remainder => + Expand_Fpt_Attribute_RR (N); + + ------------ + -- Result -- + ------------ + + -- Transform 'Result into reference to _Result formal. At the point + -- where a legal 'Result attribute is expanded, we know that we are in + -- the context of a _Postcondition function with a _Result parameter. + + when Attribute_Result => + Rewrite (N, Make_Identifier (Loc, Chars => Name_uResult)); + Analyze_And_Resolve (N, Typ); + + ----------- + -- Round -- + ----------- + + -- The handling of the Round attribute is quite delicate. The processing + -- in Sem_Attr introduced a conversion to universal real, reflecting the + -- semantics of Round, but we do not want anything to do with universal + -- real at runtime, since this corresponds to using floating-point + -- arithmetic. + + -- What we have now is that the Etype of the Round attribute correctly + -- indicates the final result type. The operand of the Round is the + -- conversion to universal real, described above, and the operand of + -- this conversion is the actual operand of Round, which may be the + -- special case of a fixed point multiplication or division (Etype = + -- universal fixed) + + -- The exapander will expand first the operand of the conversion, then + -- the conversion, and finally the round attribute itself, since we + -- always work inside out. But we cannot simply process naively in this + -- order. In the semantic world where universal fixed and real really + -- exist and have infinite precision, there is no problem, but in the + -- implementation world, where universal real is a floating-point type, + -- we would get the wrong result. + + -- So the approach is as follows. First, when expanding a multiply or + -- divide whose type is universal fixed, we do nothing at all, instead + -- deferring the operation till later. + + -- The actual processing is done in Expand_N_Type_Conversion which + -- handles the special case of Round by looking at its parent to see if + -- it is a Round attribute, and if it is, handling the conversion (or + -- its fixed multiply/divide child) in an appropriate manner. + + -- This means that by the time we get to expanding the Round attribute + -- itself, the Round is nothing more than a type conversion (and will + -- often be a null type conversion), so we just replace it with the + -- appropriate conversion operation. + + when Attribute_Round => + Rewrite (N, + Convert_To (Etype (N), Relocate_Node (First (Exprs)))); + Analyze_And_Resolve (N); + + -------------- + -- Rounding -- + -------------- + + -- Transforms 'Rounding into a call to the floating-point attribute + -- function Rounding in Fat_xxx (where xxx is the root type) + + when Attribute_Rounding => + Expand_Fpt_Attribute_R (N); + + ------------- + -- Scaling -- + ------------- + + -- Transforms 'Scaling into a call to the floating-point attribute + -- function Scaling in Fat_xxx (where xxx is the root type) + + when Attribute_Scaling => + Expand_Fpt_Attribute_RI (N); + + ---------- + -- Size -- + ---------- + + when Attribute_Size | + Attribute_Object_Size | + Attribute_Value_Size | + Attribute_VADS_Size => Size : + + declare + Siz : Uint; + New_Node : Node_Id; + + begin + -- Processing for VADS_Size case. Note that this processing removes + -- all traces of VADS_Size from the tree, and completes all required + -- processing for VADS_Size by translating the attribute reference + -- to an appropriate Size or Object_Size reference. + + if Id = Attribute_VADS_Size + or else (Use_VADS_Size and then Id = Attribute_Size) + then + -- If the size is specified, then we simply use the specified + -- size. This applies to both types and objects. The size of an + -- object can be specified in the following ways: + + -- An explicit size object is given for an object + -- A component size is specified for an indexed component + -- A component clause is specified for a selected component + -- The object is a component of a packed composite object + + -- If the size is specified, then VADS_Size of an object + + if (Is_Entity_Name (Pref) + and then Present (Size_Clause (Entity (Pref)))) + or else + (Nkind (Pref) = N_Component_Clause + and then (Present (Component_Clause + (Entity (Selector_Name (Pref)))) + or else Is_Packed (Etype (Prefix (Pref))))) + or else + (Nkind (Pref) = N_Indexed_Component + and then (Component_Size (Etype (Prefix (Pref))) /= 0 + or else Is_Packed (Etype (Prefix (Pref))))) + then + Set_Attribute_Name (N, Name_Size); + + -- Otherwise if we have an object rather than a type, then the + -- VADS_Size attribute applies to the type of the object, rather + -- than the object itself. This is one of the respects in which + -- VADS_Size differs from Size. + + else + if (not Is_Entity_Name (Pref) + or else not Is_Type (Entity (Pref))) + and then (Is_Scalar_Type (Ptyp) or else Is_Constrained (Ptyp)) + then + Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc)); + end if; + + -- For a scalar type for which no size was explicitly given, + -- VADS_Size means Object_Size. This is the other respect in + -- which VADS_Size differs from Size. + + if Is_Scalar_Type (Ptyp) and then No (Size_Clause (Ptyp)) then + Set_Attribute_Name (N, Name_Object_Size); + + -- In all other cases, Size and VADS_Size are the sane + + else + Set_Attribute_Name (N, Name_Size); + end if; + end if; + end if; + + -- For class-wide types, X'Class'Size is transformed into a direct + -- reference to the Size of the class type, so that the back end does + -- not have to deal with the X'Class'Size reference. + + if Is_Entity_Name (Pref) + and then Is_Class_Wide_Type (Entity (Pref)) + then + Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc)); + return; + + -- For X'Size applied to an object of a class-wide type, transform + -- X'Size into a call to the primitive operation _Size applied to X. + + elsif Is_Class_Wide_Type (Ptyp) + or else (Id = Attribute_Size + and then Is_Tagged_Type (Ptyp) + and then Has_Unknown_Discriminants (Ptyp)) + then + -- No need to do anything else compiling under restriction + -- No_Dispatching_Calls. During the semantic analysis we + -- already notified such violation. + + if Restriction_Active (No_Dispatching_Calls) then + return; + end if; + + New_Node := + Make_Function_Call (Loc, + Name => New_Reference_To + (Find_Prim_Op (Ptyp, Name_uSize), Loc), + Parameter_Associations => New_List (Pref)); + + if Typ /= Standard_Long_Long_Integer then + + -- The context is a specific integer type with which the + -- original attribute was compatible. The function has a + -- specific type as well, so to preserve the compatibility + -- we must convert explicitly. + + New_Node := Convert_To (Typ, New_Node); + end if; + + Rewrite (N, New_Node); + Analyze_And_Resolve (N, Typ); + return; + + -- Case of known RM_Size of a type + + elsif (Id = Attribute_Size or else Id = Attribute_Value_Size) + and then Is_Entity_Name (Pref) + and then Is_Type (Entity (Pref)) + and then Known_Static_RM_Size (Entity (Pref)) + then + Siz := RM_Size (Entity (Pref)); + + -- Case of known Esize of a type + + elsif Id = Attribute_Object_Size + and then Is_Entity_Name (Pref) + and then Is_Type (Entity (Pref)) + and then Known_Static_Esize (Entity (Pref)) + then + Siz := Esize (Entity (Pref)); + + -- Case of known size of object + + elsif Id = Attribute_Size + and then Is_Entity_Name (Pref) + and then Is_Object (Entity (Pref)) + and then Known_Esize (Entity (Pref)) + and then Known_Static_Esize (Entity (Pref)) + then + Siz := Esize (Entity (Pref)); + + -- For an array component, we can do Size in the front end + -- if the component_size of the array is set. + + elsif Nkind (Pref) = N_Indexed_Component then + Siz := Component_Size (Etype (Prefix (Pref))); + + -- For a record component, we can do Size in the front end if there + -- is a component clause, or if the record is packed and the + -- component's size is known at compile time. + + elsif Nkind (Pref) = N_Selected_Component then + declare + Rec : constant Entity_Id := Etype (Prefix (Pref)); + Comp : constant Entity_Id := Entity (Selector_Name (Pref)); + + begin + if Present (Component_Clause (Comp)) then + Siz := Esize (Comp); + + elsif Is_Packed (Rec) then + Siz := RM_Size (Ptyp); + + else + Apply_Universal_Integer_Attribute_Checks (N); + return; + end if; + end; + + -- All other cases are handled by the back end + + else + Apply_Universal_Integer_Attribute_Checks (N); + + -- If Size is applied to a formal parameter that is of a packed + -- array subtype, then apply Size to the actual subtype. + + if Is_Entity_Name (Pref) + and then Is_Formal (Entity (Pref)) + and then Is_Array_Type (Ptyp) + and then Is_Packed (Ptyp) + then + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc), + Attribute_Name => Name_Size)); + Analyze_And_Resolve (N, Typ); + end if; + + -- If Size applies to a dereference of an access to unconstrained + -- packed array, the back end needs to see its unconstrained + -- nominal type, but also a hint to the actual constrained type. + + if Nkind (Pref) = N_Explicit_Dereference + and then Is_Array_Type (Ptyp) + and then not Is_Constrained (Ptyp) + and then Is_Packed (Ptyp) + then + Set_Actual_Designated_Subtype (Pref, + Get_Actual_Subtype (Pref)); + end if; + + return; + end if; + + -- Common processing for record and array component case + + if Siz /= No_Uint and then Siz /= 0 then + declare + CS : constant Boolean := Comes_From_Source (N); + + begin + Rewrite (N, Make_Integer_Literal (Loc, Siz)); + + -- This integer literal is not a static expression. We do not + -- call Analyze_And_Resolve here, because this would activate + -- the circuit for deciding that a static value was out of + -- range, and we don't want that. + + -- So just manually set the type, mark the expression as non- + -- static, and then ensure that the result is checked properly + -- if the attribute comes from source (if it was internally + -- generated, we never need a constraint check). + + Set_Etype (N, Typ); + Set_Is_Static_Expression (N, False); + + if CS then + Apply_Constraint_Check (N, Typ); + end if; + end; + end if; + end Size; + + ------------------ + -- Storage_Pool -- + ------------------ + + when Attribute_Storage_Pool => + Rewrite (N, + Make_Type_Conversion (Loc, + Subtype_Mark => New_Reference_To (Etype (N), Loc), + Expression => New_Reference_To (Entity (N), Loc))); + Analyze_And_Resolve (N, Typ); + + ------------------ + -- Storage_Size -- + ------------------ + + when Attribute_Storage_Size => Storage_Size : begin + + -- Access type case, always go to the root type + + -- The case of access types results in a value of zero for the case + -- where no storage size attribute clause has been given. If a + -- storage size has been given, then the attribute is converted + -- to a reference to the variable used to hold this value. + + if Is_Access_Type (Ptyp) then + if Present (Storage_Size_Variable (Root_Type (Ptyp))) then + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Typ, Loc), + Attribute_Name => Name_Max, + Expressions => New_List ( + Make_Integer_Literal (Loc, 0), + Convert_To (Typ, + New_Reference_To + (Storage_Size_Variable (Root_Type (Ptyp)), Loc))))); + + elsif Present (Associated_Storage_Pool (Root_Type (Ptyp))) then + Rewrite (N, + OK_Convert_To (Typ, + Make_Function_Call (Loc, + Name => + New_Reference_To + (Find_Prim_Op + (Etype (Associated_Storage_Pool (Root_Type (Ptyp))), + Attribute_Name (N)), + Loc), + + Parameter_Associations => New_List ( + New_Reference_To + (Associated_Storage_Pool (Root_Type (Ptyp)), Loc))))); + + else + Rewrite (N, Make_Integer_Literal (Loc, 0)); + end if; + + Analyze_And_Resolve (N, Typ); + + -- For tasks, we retrieve the size directly from the TCB. The + -- size may depend on a discriminant of the type, and therefore + -- can be a per-object expression, so type-level information is + -- not sufficient in general. There are four cases to consider: + + -- a) If the attribute appears within a task body, the designated + -- TCB is obtained by a call to Self. + + -- b) If the prefix of the attribute is the name of a task object, + -- the designated TCB is the one stored in the corresponding record. + + -- c) If the prefix is a task type, the size is obtained from the + -- size variable created for each task type + + -- d) If no storage_size was specified for the type , there is no + -- size variable, and the value is a system-specific default. + + else + if In_Open_Scopes (Ptyp) then + + -- Storage_Size (Self) + + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Storage_Size), Loc), + Parameter_Associations => + New_List ( + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Self), Loc)))))); + + elsif not Is_Entity_Name (Pref) + or else not Is_Type (Entity (Pref)) + then + -- Storage_Size (Rec (Obj).Size) + + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Storage_Size), Loc), + Parameter_Associations => + New_List ( + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To ( + Corresponding_Record_Type (Ptyp), + New_Copy_Tree (Pref)), + Selector_Name => + Make_Identifier (Loc, Name_uTask_Id)))))); + + elsif Present (Storage_Size_Variable (Ptyp)) then + + -- Static storage size pragma given for type: retrieve value + -- from its allocated storage variable. + + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Adjust_Storage_Size), Loc), + Parameter_Associations => + New_List ( + New_Reference_To ( + Storage_Size_Variable (Ptyp), Loc))))); + else + -- Get system default + + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Default_Stack_Size), Loc)))); + end if; + + Analyze_And_Resolve (N, Typ); + end if; + end Storage_Size; + + ----------------- + -- Stream_Size -- + ----------------- + + when Attribute_Stream_Size => Stream_Size : declare + Size : Int; + + begin + -- If we have a Stream_Size clause for this type use it, otherwise + -- the Stream_Size if the size of the type. + + if Has_Stream_Size_Clause (Ptyp) then + Size := + UI_To_Int + (Static_Integer (Expression (Stream_Size_Clause (Ptyp)))); + else + Size := UI_To_Int (Esize (Ptyp)); + end if; + + Rewrite (N, Make_Integer_Literal (Loc, Intval => Size)); + Analyze_And_Resolve (N, Typ); + end Stream_Size; + + ---------- + -- Succ -- + ---------- + + -- 1. Deal with enumeration types with holes + -- 2. For floating-point, generate call to attribute function + -- 3. For other cases, deal with constraint checking + + when Attribute_Succ => Succ : declare + Etyp : constant Entity_Id := Base_Type (Ptyp); + + begin + + -- For enumeration types with non-standard representations, we + -- expand typ'Succ (x) into + + -- Pos_To_Rep (Rep_To_Pos (x) + 1) + + -- If the representation is contiguous, we compute instead + -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations. + + if Is_Enumeration_Type (Ptyp) + and then Present (Enum_Pos_To_Rep (Etyp)) + then + if Has_Contiguous_Rep (Etyp) then + Rewrite (N, + Unchecked_Convert_To (Ptyp, + Make_Op_Add (Loc, + Left_Opnd => + Make_Integer_Literal (Loc, + Enumeration_Rep (First_Literal (Ptyp))), + Right_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To + (TSS (Etyp, TSS_Rep_To_Pos), Loc), + + Parameter_Associations => + New_List ( + Unchecked_Convert_To (Ptyp, + Make_Op_Add (Loc, + Left_Opnd => + Unchecked_Convert_To (Standard_Integer, + Relocate_Node (First (Exprs))), + Right_Opnd => + Make_Integer_Literal (Loc, 1))), + Rep_To_Pos_Flag (Ptyp, Loc)))))); + else + -- Add Boolean parameter True, to request program errror if + -- we have a bad representation on our hands. Add False if + -- checks are suppressed. + + Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc)); + Rewrite (N, + Make_Indexed_Component (Loc, + Prefix => + New_Reference_To + (Enum_Pos_To_Rep (Etyp), Loc), + Expressions => New_List ( + Make_Op_Add (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To + (TSS (Etyp, TSS_Rep_To_Pos), Loc), + Parameter_Associations => Exprs), + Right_Opnd => Make_Integer_Literal (Loc, 1))))); + end if; + + Analyze_And_Resolve (N, Typ); + + -- For floating-point, we transform 'Succ into a call to the Succ + -- floating-point attribute function in Fat_xxx (xxx is root type) + + elsif Is_Floating_Point_Type (Ptyp) then + Expand_Fpt_Attribute_R (N); + Analyze_And_Resolve (N, Typ); + + -- For modular types, nothing to do (no overflow, since wraps) + + elsif Is_Modular_Integer_Type (Ptyp) then + null; + + -- For other types, if argument is marked as needing a range check or + -- overflow checking is enabled, we must generate a check. + + elsif not Overflow_Checks_Suppressed (Ptyp) + or else Do_Range_Check (First (Exprs)) + then + Set_Do_Range_Check (First (Exprs), False); + Expand_Pred_Succ (N); + end if; + end Succ; + + --------- + -- Tag -- + --------- + + -- Transforms X'Tag into a direct reference to the tag of X + + when Attribute_Tag => Tag : declare + Ttyp : Entity_Id; + Prefix_Is_Type : Boolean; + + begin + if Is_Entity_Name (Pref) and then Is_Type (Entity (Pref)) then + Ttyp := Entity (Pref); + Prefix_Is_Type := True; + else + Ttyp := Ptyp; + Prefix_Is_Type := False; + end if; + + if Is_Class_Wide_Type (Ttyp) then + Ttyp := Root_Type (Ttyp); + end if; + + Ttyp := Underlying_Type (Ttyp); + + -- Ada 2005: The type may be a synchronized tagged type, in which + -- case the tag information is stored in the corresponding record. + + if Is_Concurrent_Type (Ttyp) then + Ttyp := Corresponding_Record_Type (Ttyp); + end if; + + if Prefix_Is_Type then + + -- For VMs we leave the type attribute unexpanded because + -- there's not a dispatching table to reference. + + if Tagged_Type_Expansion then + Rewrite (N, + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Ttyp))), Loc))); + Analyze_And_Resolve (N, RTE (RE_Tag)); + end if; + + -- Ada 2005 (AI-251): The use of 'Tag in the sources always + -- references the primary tag of the actual object. If 'Tag is + -- applied to class-wide interface objects we generate code that + -- displaces "this" to reference the base of the object. + + elsif Comes_From_Source (N) + and then Is_Class_Wide_Type (Etype (Prefix (N))) + and then Is_Interface (Etype (Prefix (N))) + then + -- Generate: + -- (To_Tag_Ptr (Prefix'Address)).all + + -- Note that Prefix'Address is recursively expanded into a call + -- to Base_Address (Obj.Tag) + + -- Not needed for VM targets, since all handled by the VM + + if Tagged_Type_Expansion then + Rewrite (N, + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Tag_Ptr), + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Pref), + Attribute_Name => Name_Address)))); + Analyze_And_Resolve (N, RTE (RE_Tag)); + end if; + + else + Rewrite (N, + Make_Selected_Component (Loc, + Prefix => Relocate_Node (Pref), + Selector_Name => + New_Reference_To (First_Tag_Component (Ttyp), Loc))); + Analyze_And_Resolve (N, RTE (RE_Tag)); + end if; + end Tag; + + ---------------- + -- Terminated -- + ---------------- + + -- Transforms 'Terminated attribute into a call to Terminated function + + when Attribute_Terminated => Terminated : + begin + -- The prefix of Terminated is of a task interface class-wide type. + -- Generate: + -- terminated (Task_Id (Pref._disp_get_task_id)); + + if Ada_Version >= Ada_2005 + and then Ekind (Ptyp) = E_Class_Wide_Type + and then Is_Interface (Ptyp) + and then Is_Task_Interface (Ptyp) + then + Rewrite (N, + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Terminated), Loc), + Parameter_Associations => New_List ( + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Reference_To (RTE (RO_ST_Task_Id), Loc), + Expression => + Make_Selected_Component (Loc, + Prefix => + New_Copy_Tree (Pref), + Selector_Name => + Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))))); + + elsif Restricted_Profile then + Rewrite (N, + Build_Call_With_Task (Pref, RTE (RE_Restricted_Terminated))); + + else + Rewrite (N, + Build_Call_With_Task (Pref, RTE (RE_Terminated))); + end if; + + Analyze_And_Resolve (N, Standard_Boolean); + end Terminated; + + ---------------- + -- To_Address -- + ---------------- + + -- Transforms System'To_Address (X) and System.Address'Ref (X) into + -- unchecked conversion from (integral) type of X to type address. + + when Attribute_To_Address | Attribute_Ref => + Rewrite (N, + Unchecked_Convert_To (RTE (RE_Address), + Relocate_Node (First (Exprs)))); + Analyze_And_Resolve (N, RTE (RE_Address)); + + ------------ + -- To_Any -- + ------------ + + when Attribute_To_Any => To_Any : declare + P_Type : constant Entity_Id := Etype (Pref); + Decls : constant List_Id := New_List; + begin + Rewrite (N, + Build_To_Any_Call + (Convert_To (P_Type, + Relocate_Node (First (Exprs))), Decls)); + Insert_Actions (N, Decls); + Analyze_And_Resolve (N, RTE (RE_Any)); + end To_Any; + + ---------------- + -- Truncation -- + ---------------- + + -- Transforms 'Truncation into a call to the floating-point attribute + -- function Truncation in Fat_xxx (where xxx is the root type). + -- Expansion is avoided for cases the back end can handle directly. + + when Attribute_Truncation => + if not Is_Inline_Floating_Point_Attribute (N) then + Expand_Fpt_Attribute_R (N); + end if; + + -------------- + -- TypeCode -- + -------------- + + when Attribute_TypeCode => TypeCode : declare + P_Type : constant Entity_Id := Etype (Pref); + Decls : constant List_Id := New_List; + begin + Rewrite (N, Build_TypeCode_Call (Loc, P_Type, Decls)); + Insert_Actions (N, Decls); + Analyze_And_Resolve (N, RTE (RE_TypeCode)); + end TypeCode; + + ----------------------- + -- Unbiased_Rounding -- + ----------------------- + + -- Transforms 'Unbiased_Rounding into a call to the floating-point + -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the + -- root type). Expansion is avoided for cases the back end can handle + -- directly. + + when Attribute_Unbiased_Rounding => + if not Is_Inline_Floating_Point_Attribute (N) then + Expand_Fpt_Attribute_R (N); + end if; + + ----------------- + -- UET_Address -- + ----------------- + + when Attribute_UET_Address => UET_Address : declare + Ent : constant Entity_Id := Make_Temporary (Loc, 'T'); + + begin + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Ent, + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Address), Loc))); + + -- Construct name __gnat_xxx__SDP, where xxx is the unit name + -- in normal external form. + + Get_External_Unit_Name_String (Get_Unit_Name (Pref)); + Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len); + Name_Len := Name_Len + 7; + Name_Buffer (1 .. 7) := "__gnat_"; + Name_Buffer (Name_Len + 1 .. Name_Len + 5) := "__SDP"; + Name_Len := Name_Len + 5; + + Set_Is_Imported (Ent); + Set_Interface_Name (Ent, + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer)); + + -- Set entity as internal to ensure proper Sprint output of its + -- implicit importation. + + Set_Is_Internal (Ent); + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ent, Loc), + Attribute_Name => Name_Address)); + + Analyze_And_Resolve (N, Typ); + end UET_Address; + + --------------- + -- VADS_Size -- + --------------- + + -- The processing for VADS_Size is shared with Size + + --------- + -- Val -- + --------- + + -- For enumeration types with a standard representation, and for all + -- other types, Val is handled by the back end. For enumeration types + -- with a non-standard representation we use the _Pos_To_Rep array that + -- was created when the type was frozen. + + when Attribute_Val => Val : declare + Etyp : constant Entity_Id := Base_Type (Entity (Pref)); + + begin + if Is_Enumeration_Type (Etyp) + and then Present (Enum_Pos_To_Rep (Etyp)) + then + if Has_Contiguous_Rep (Etyp) then + declare + Rep_Node : constant Node_Id := + Unchecked_Convert_To (Etyp, + Make_Op_Add (Loc, + Left_Opnd => + Make_Integer_Literal (Loc, + Enumeration_Rep (First_Literal (Etyp))), + Right_Opnd => + (Convert_To (Standard_Integer, + Relocate_Node (First (Exprs)))))); + + begin + Rewrite (N, + Unchecked_Convert_To (Etyp, + Make_Op_Add (Loc, + Left_Opnd => + Make_Integer_Literal (Loc, + Enumeration_Rep (First_Literal (Etyp))), + Right_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To + (TSS (Etyp, TSS_Rep_To_Pos), Loc), + Parameter_Associations => New_List ( + Rep_Node, + Rep_To_Pos_Flag (Etyp, Loc)))))); + end; + + else + Rewrite (N, + Make_Indexed_Component (Loc, + Prefix => New_Reference_To (Enum_Pos_To_Rep (Etyp), Loc), + Expressions => New_List ( + Convert_To (Standard_Integer, + Relocate_Node (First (Exprs)))))); + end if; + + Analyze_And_Resolve (N, Typ); + + -- If the argument is marked as requiring a range check then generate + -- it here. + + elsif Do_Range_Check (First (Exprs)) then + Set_Do_Range_Check (First (Exprs), False); + Generate_Range_Check (First (Exprs), Etyp, CE_Range_Check_Failed); + end if; + end Val; + + ----------- + -- Valid -- + ----------- + + -- The code for valid is dependent on the particular types involved. + -- See separate sections below for the generated code in each case. + + when Attribute_Valid => Valid : declare + Btyp : Entity_Id := Base_Type (Ptyp); + Tst : Node_Id; + + Save_Validity_Checks_On : constant Boolean := Validity_Checks_On; + -- Save the validity checking mode. We always turn off validity + -- checking during process of 'Valid since this is one place + -- where we do not want the implicit validity checks to intefere + -- with the explicit validity check that the programmer is doing. + + function Make_Range_Test return Node_Id; + -- Build the code for a range test of the form + -- Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last) + + --------------------- + -- Make_Range_Test -- + --------------------- + + function Make_Range_Test return Node_Id is + Temp : constant Node_Id := Duplicate_Subexpr (Pref); + + begin + -- The value whose validity is being checked has been captured in + -- an object declaration. We certainly don't want this object to + -- appear valid because the declaration initializes it! + + if Is_Entity_Name (Temp) then + Set_Is_Known_Valid (Entity (Temp), False); + end if; + + return + Make_In (Loc, + Left_Opnd => + Unchecked_Convert_To (Btyp, Temp), + Right_Opnd => + Make_Range (Loc, + Low_Bound => + Unchecked_Convert_To (Btyp, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Attribute_Name => Name_First)), + High_Bound => + Unchecked_Convert_To (Btyp, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Attribute_Name => Name_Last)))); + end Make_Range_Test; + + -- Start of processing for Attribute_Valid + + begin + -- Do not expand sourced code 'Valid reference in CodePeer mode, + -- will be handled by the back-end directly. + + if CodePeer_Mode and then Comes_From_Source (N) then + return; + end if; + + -- Turn off validity checks. We do not want any implicit validity + -- checks to intefere with the explicit check from the attribute + + Validity_Checks_On := False; + + -- Floating-point case. This case is handled by the Valid attribute + -- code in the floating-point attribute run-time library. + + if Is_Floating_Point_Type (Ptyp) then + declare + Pkg : RE_Id; + Ftp : Entity_Id; + + begin + + case Float_Rep (Btyp) is + + -- For vax fpt types, call appropriate routine in special + -- vax floating point unit. No need to worry about loads in + -- this case, since these types have no signalling NaN's. + + when VAX_Native => Expand_Vax_Valid (N); + + -- The AAMP back end handles Valid for floating-point types + + when AAMP => + Analyze_And_Resolve (Pref, Ptyp); + Set_Etype (N, Standard_Boolean); + Set_Analyzed (N); + + when IEEE_Binary => + Find_Fat_Info (Ptyp, Ftp, Pkg); + + -- If the floating-point object might be unaligned, we + -- need to call the special routine Unaligned_Valid, + -- which makes the needed copy, being careful not to + -- load the value into any floating-point register. + -- The argument in this case is obj'Address (see + -- Unaligned_Valid routine in Fat_Gen). + + if Is_Possibly_Unaligned_Object (Pref) then + Expand_Fpt_Attribute + (N, Pkg, Name_Unaligned_Valid, + New_List ( + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Pref), + Attribute_Name => Name_Address))); + + -- In the normal case where we are sure the object is + -- aligned, we generate a call to Valid, and the argument + -- in this case is obj'Unrestricted_Access (after + -- converting obj to the right floating-point type). + + else + Expand_Fpt_Attribute + (N, Pkg, Name_Valid, + New_List ( + Make_Attribute_Reference (Loc, + Prefix => Unchecked_Convert_To (Ftp, Pref), + Attribute_Name => Name_Unrestricted_Access))); + end if; + end case; + + -- One more task, we still need a range check. Required + -- only if we have a constraint, since the Valid routine + -- catches infinities properly (infinities are never valid). + + -- The way we do the range check is simply to create the + -- expression: Valid (N) and then Base_Type(Pref) in Typ. + + if not Subtypes_Statically_Match (Ptyp, Btyp) then + Rewrite (N, + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (N), + Right_Opnd => + Make_In (Loc, + Left_Opnd => Convert_To (Btyp, Pref), + Right_Opnd => New_Occurrence_Of (Ptyp, Loc)))); + end if; + end; + + -- Enumeration type with holes + + -- For enumeration types with holes, the Pos value constructed by + -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a + -- second argument of False returns minus one for an invalid value, + -- and the non-negative pos value for a valid value, so the + -- expansion of X'Valid is simply: + + -- type(X)'Pos (X) >= 0 + + -- We can't quite generate it that way because of the requirement + -- for the non-standard second argument of False in the resulting + -- rep_to_pos call, so we have to explicitly create: + + -- _rep_to_pos (X, False) >= 0 + + -- If we have an enumeration subtype, we also check that the + -- value is in range: + + -- _rep_to_pos (X, False) >= 0 + -- and then + -- (X >= type(X)'First and then type(X)'Last <= X) + + elsif Is_Enumeration_Type (Ptyp) + and then Present (Enum_Pos_To_Rep (Base_Type (Ptyp))) + then + Tst := + Make_Op_Ge (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To + (TSS (Base_Type (Ptyp), TSS_Rep_To_Pos), Loc), + Parameter_Associations => New_List ( + Pref, + New_Occurrence_Of (Standard_False, Loc))), + Right_Opnd => Make_Integer_Literal (Loc, 0)); + + if Ptyp /= Btyp + and then + (Type_Low_Bound (Ptyp) /= Type_Low_Bound (Btyp) + or else + Type_High_Bound (Ptyp) /= Type_High_Bound (Btyp)) + then + -- The call to Make_Range_Test will create declarations + -- that need a proper insertion point, but Pref is now + -- attached to a node with no ancestor. Attach to tree + -- even if it is to be rewritten below. + + Set_Parent (Tst, Parent (N)); + + Tst := + Make_And_Then (Loc, + Left_Opnd => Make_Range_Test, + Right_Opnd => Tst); + end if; + + Rewrite (N, Tst); + + -- Fortran convention booleans + + -- For the very special case of Fortran convention booleans, the + -- value is always valid, since it is an integer with the semantics + -- that non-zero is true, and any value is permissible. + + elsif Is_Boolean_Type (Ptyp) + and then Convention (Ptyp) = Convention_Fortran + then + Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); + + -- For biased representations, we will be doing an unchecked + -- conversion without unbiasing the result. That means that the range + -- test has to take this into account, and the proper form of the + -- test is: + + -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length) + + elsif Has_Biased_Representation (Ptyp) then + Btyp := RTE (RE_Unsigned_32); + Rewrite (N, + Make_Op_Lt (Loc, + Left_Opnd => + Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)), + Right_Opnd => + Unchecked_Convert_To (Btyp, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Attribute_Name => Name_Range_Length)))); + + -- For all other scalar types, what we want logically is a + -- range test: + + -- X in type(X)'First .. type(X)'Last + + -- But that's precisely what won't work because of possible + -- unwanted optimization (and indeed the basic motivation for + -- the Valid attribute is exactly that this test does not work!) + -- What will work is: + + -- Btyp!(X) >= Btyp!(type(X)'First) + -- and then + -- Btyp!(X) <= Btyp!(type(X)'Last) + + -- where Btyp is an integer type large enough to cover the full + -- range of possible stored values (i.e. it is chosen on the basis + -- of the size of the type, not the range of the values). We write + -- this as two tests, rather than a range check, so that static + -- evaluation will easily remove either or both of the checks if + -- they can be -statically determined to be true (this happens + -- when the type of X is static and the range extends to the full + -- range of stored values). + + -- Unsigned types. Note: it is safe to consider only whether the + -- subtype is unsigned, since we will in that case be doing all + -- unsigned comparisons based on the subtype range. Since we use the + -- actual subtype object size, this is appropriate. + + -- For example, if we have + + -- subtype x is integer range 1 .. 200; + -- for x'Object_Size use 8; + + -- Now the base type is signed, but objects of this type are bits + -- unsigned, and doing an unsigned test of the range 1 to 200 is + -- correct, even though a value greater than 127 looks signed to a + -- signed comparison. + + elsif Is_Unsigned_Type (Ptyp) then + if Esize (Ptyp) <= 32 then + Btyp := RTE (RE_Unsigned_32); + else + Btyp := RTE (RE_Unsigned_64); + end if; + + Rewrite (N, Make_Range_Test); + + -- Signed types + + else + if Esize (Ptyp) <= Esize (Standard_Integer) then + Btyp := Standard_Integer; + else + Btyp := Universal_Integer; + end if; + + Rewrite (N, Make_Range_Test); + end if; + + Analyze_And_Resolve (N, Standard_Boolean); + Validity_Checks_On := Save_Validity_Checks_On; + end Valid; + + ----------- + -- Value -- + ----------- + + -- Value attribute is handled in separate unti Exp_Imgv + + when Attribute_Value => + Exp_Imgv.Expand_Value_Attribute (N); + + ----------------- + -- Value_Size -- + ----------------- + + -- The processing for Value_Size shares the processing for Size + + ------------- + -- Version -- + ------------- + + -- The processing for Version shares the processing for Body_Version + + ---------------- + -- Wide_Image -- + ---------------- + + -- Wide_Image attribute is handled in separate unit Exp_Imgv + + when Attribute_Wide_Image => + Exp_Imgv.Expand_Wide_Image_Attribute (N); + + --------------------- + -- Wide_Wide_Image -- + --------------------- + + -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv + + when Attribute_Wide_Wide_Image => + Exp_Imgv.Expand_Wide_Wide_Image_Attribute (N); + + ---------------- + -- Wide_Value -- + ---------------- + + -- We expand typ'Wide_Value (X) into + + -- typ'Value + -- (Wide_String_To_String (X, Wide_Character_Encoding_Method)) + + -- Wide_String_To_String is a runtime function that converts its wide + -- string argument to String, converting any non-translatable characters + -- into appropriate escape sequences. This preserves the required + -- semantics of Wide_Value in all cases, and results in a very simple + -- implementation approach. + + -- Note: for this approach to be fully standard compliant for the cases + -- where typ is Wide_Character and Wide_Wide_Character, the encoding + -- method must cover the entire character range (e.g. UTF-8). But that + -- is a reasonable requirement when dealing with encoded character + -- sequences. Presumably if one of the restrictive encoding mechanisms + -- is in use such as Shift-JIS, then characters that cannot be + -- represented using this encoding will not appear in any case. + + when Attribute_Wide_Value => Wide_Value : + begin + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => Pref, + Attribute_Name => Name_Value, + + Expressions => New_List ( + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Wide_String_To_String), Loc), + + Parameter_Associations => New_List ( + Relocate_Node (First (Exprs)), + Make_Integer_Literal (Loc, + Intval => Int (Wide_Character_Encoding_Method))))))); + + Analyze_And_Resolve (N, Typ); + end Wide_Value; + + --------------------- + -- Wide_Wide_Value -- + --------------------- + + -- We expand typ'Wide_Value_Value (X) into + + -- typ'Value + -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method)) + + -- Wide_Wide_String_To_String is a runtime function that converts its + -- wide string argument to String, converting any non-translatable + -- characters into appropriate escape sequences. This preserves the + -- required semantics of Wide_Wide_Value in all cases, and results in a + -- very simple implementation approach. + + -- It's not quite right where typ = Wide_Wide_Character, because the + -- encoding method may not cover the whole character type ??? + + when Attribute_Wide_Wide_Value => Wide_Wide_Value : + begin + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => Pref, + Attribute_Name => Name_Value, + + Expressions => New_List ( + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Wide_Wide_String_To_String), Loc), + + Parameter_Associations => New_List ( + Relocate_Node (First (Exprs)), + Make_Integer_Literal (Loc, + Intval => Int (Wide_Character_Encoding_Method))))))); + + Analyze_And_Resolve (N, Typ); + end Wide_Wide_Value; + + --------------------- + -- Wide_Wide_Width -- + --------------------- + + -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv + + when Attribute_Wide_Wide_Width => + Exp_Imgv.Expand_Width_Attribute (N, Wide_Wide); + + ---------------- + -- Wide_Width -- + ---------------- + + -- Wide_Width attribute is handled in separate unit Exp_Imgv + + when Attribute_Wide_Width => + Exp_Imgv.Expand_Width_Attribute (N, Wide); + + ----------- + -- Width -- + ----------- + + -- Width attribute is handled in separate unit Exp_Imgv + + when Attribute_Width => + Exp_Imgv.Expand_Width_Attribute (N, Normal); + + ----------- + -- Write -- + ----------- + + when Attribute_Write => Write : declare + P_Type : constant Entity_Id := Entity (Pref); + U_Type : constant Entity_Id := Underlying_Type (P_Type); + Pname : Entity_Id; + Decl : Node_Id; + Prag : Node_Id; + Arg3 : Node_Id; + Wfunc : Node_Id; + + begin + -- If no underlying type, we have an error that will be diagnosed + -- elsewhere, so here we just completely ignore the expansion. + + if No (U_Type) then + return; + end if; + + -- The simple case, if there is a TSS for Write, just call it + + Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write); + + if Present (Pname) then + null; + + else + -- If there is a Stream_Convert pragma, use it, we rewrite + + -- sourcetyp'Output (stream, Item) + + -- as + + -- strmtyp'Output (Stream, strmwrite (acttyp (Item))); + + -- where strmwrite is the given Write function that converts an + -- argument of type sourcetyp or a type acctyp, from which it is + -- derived to type strmtyp. The conversion to acttyp is required + -- for the derived case. + + Prag := Get_Stream_Convert_Pragma (P_Type); + + if Present (Prag) then + Arg3 := + Next (Next (First (Pragma_Argument_Associations (Prag)))); + Wfunc := Entity (Expression (Arg3)); + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etype (Wfunc), Loc), + Attribute_Name => Name_Output, + Expressions => New_List ( + Relocate_Node (First (Exprs)), + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Wfunc, Loc), + Parameter_Associations => New_List ( + OK_Convert_To (Etype (First_Formal (Wfunc)), + Relocate_Node (Next (First (Exprs))))))))); + + Analyze (N); + return; + + -- For elementary types, we call the W_xxx routine directly + + elsif Is_Elementary_Type (U_Type) then + Rewrite (N, Build_Elementary_Write_Call (N)); + Analyze (N); + return; + + -- Array type case + + elsif Is_Array_Type (U_Type) then + Build_Array_Write_Procedure (N, U_Type, Decl, Pname); + Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False); + + -- Tagged type case, use the primitive Write function. Note that + -- this will dispatch in the class-wide case which is what we want + + elsif Is_Tagged_Type (U_Type) then + Pname := Find_Prim_Op (U_Type, TSS_Stream_Write); + + -- All other record type cases, including protected records. + -- The latter only arise for expander generated code for + -- handling shared passive partition access. + + else + pragma Assert + (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type)); + + -- Ada 2005 (AI-216): Program_Error is raised when executing + -- the default implementation of the Write attribute of an + -- Unchecked_Union type. However, if the 'Write reference is + -- within the generated Output stream procedure, Write outputs + -- the components, and the default values of the discriminant + -- are streamed by the Output procedure itself. + + if Is_Unchecked_Union (Base_Type (U_Type)) + and not Is_TSS (Current_Scope, TSS_Stream_Output) + then + Insert_Action (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction)); + end if; + + if Has_Discriminants (U_Type) + and then Present + (Discriminant_Default_Value (First_Discriminant (U_Type))) + then + Build_Mutable_Record_Write_Procedure + (Loc, Full_Base (U_Type), Decl, Pname); + else + Build_Record_Write_Procedure + (Loc, Full_Base (U_Type), Decl, Pname); + end if; + + Insert_Action (N, Decl); + end if; + end if; + + -- If we fall through, Pname is the procedure to be called + + Rewrite_Stream_Proc_Call (Pname); + end Write; + + -- Component_Size is handled by the back end, unless the component size + -- is known at compile time, which is always true in the packed array + -- case. It is important that the packed array case is handled in the + -- front end (see Eval_Attribute) since the back end would otherwise get + -- confused by the equivalent packed array type. + + when Attribute_Component_Size => + null; + + -- The following attributes are handled by the back end (except that + -- static cases have already been evaluated during semantic processing, + -- but in any case the back end should not count on this). The one bit + -- of special processing required is that these attributes typically + -- generate conditionals in the code, so we need to check the relevant + -- restriction. + + when Attribute_Max | + Attribute_Min => + Check_Restriction (No_Implicit_Conditionals, N); + + -- The following attributes are handled by the back end (except that + -- static cases have already been evaluated during semantic processing, + -- but in any case the back end should not count on this). + + -- The back end also handles the non-class-wide cases of Size + + when Attribute_Bit_Order | + Attribute_Code_Address | + Attribute_Definite | + Attribute_Null_Parameter | + Attribute_Passed_By_Reference | + Attribute_Pool_Address => + null; + + -- The following attributes are also handled by the back end, but return + -- a universal integer result, so may need a conversion for checking + -- that the result is in range. + + when Attribute_Aft | + Attribute_Max_Alignment_For_Allocation | + Attribute_Max_Size_In_Storage_Elements => + Apply_Universal_Integer_Attribute_Checks (N); + + -- The following attributes should not appear at this stage, since they + -- have already been handled by the analyzer (and properly rewritten + -- with corresponding values or entities to represent the right values) + + when Attribute_Abort_Signal | + Attribute_Address_Size | + Attribute_Base | + Attribute_Class | + Attribute_Compiler_Version | + Attribute_Default_Bit_Order | + Attribute_Delta | + Attribute_Denorm | + Attribute_Digits | + Attribute_Emax | + Attribute_Enabled | + Attribute_Epsilon | + Attribute_Fast_Math | + Attribute_Has_Access_Values | + Attribute_Has_Discriminants | + Attribute_Has_Tagged_Values | + Attribute_Large | + Attribute_Machine_Emax | + Attribute_Machine_Emin | + Attribute_Machine_Mantissa | + Attribute_Machine_Overflows | + Attribute_Machine_Radix | + Attribute_Machine_Rounds | + Attribute_Maximum_Alignment | + Attribute_Model_Emin | + Attribute_Model_Epsilon | + Attribute_Model_Mantissa | + Attribute_Model_Small | + Attribute_Modulus | + Attribute_Partition_ID | + Attribute_Range | + Attribute_Safe_Emax | + Attribute_Safe_First | + Attribute_Safe_Large | + Attribute_Safe_Last | + Attribute_Safe_Small | + Attribute_Scale | + Attribute_Signed_Zeros | + Attribute_Small | + Attribute_Storage_Unit | + Attribute_Stub_Type | + Attribute_Target_Name | + Attribute_Type_Class | + Attribute_Type_Key | + Attribute_Unconstrained_Array | + Attribute_Universal_Literal_String | + Attribute_Wchar_T_Size | + Attribute_Word_Size => + + raise Program_Error; + + -- The Asm_Input and Asm_Output attributes are not expanded at this + -- stage, but will be eliminated in the expansion of the Asm call, see + -- Exp_Intr for details. So the back end will never see these either. + + when Attribute_Asm_Input | + Attribute_Asm_Output => + + null; + + end case; + + exception + when RE_Not_Available => + return; + end Expand_N_Attribute_Reference; + + ---------------------- + -- Expand_Pred_Succ -- + ---------------------- + + -- For typ'Pred (exp), we generate the check + + -- [constraint_error when exp = typ'Base'First] + + -- Similarly, for typ'Succ (exp), we generate the check + + -- [constraint_error when exp = typ'Base'Last] + + -- These checks are not generated for modular types, since the proper + -- semantics for Succ and Pred on modular types is to wrap, not raise CE. + -- We also suppress these checks if we are the right side of an assignment + -- statement or the expression of an object declaration, where the flag + -- Suppress_Assignment_Checks is set for the assignment/declaration. + + procedure Expand_Pred_Succ (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + P : constant Node_Id := Parent (N); + Cnam : Name_Id; + + begin + if Attribute_Name (N) = Name_Pred then + Cnam := Name_First; + else + Cnam := Name_Last; + end if; + + if not Nkind_In (P, N_Assignment_Statement, N_Object_Declaration) + or else not Suppress_Assignment_Checks (P) + then + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Duplicate_Subexpr_Move_Checks (First (Expressions (N))), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Base_Type (Etype (Prefix (N))), Loc), + Attribute_Name => Cnam)), + Reason => CE_Overflow_Check_Failed)); + end if; + end Expand_Pred_Succ; + + ------------------- + -- Find_Fat_Info -- + ------------------- + + procedure Find_Fat_Info + (T : Entity_Id; + Fat_Type : out Entity_Id; + Fat_Pkg : out RE_Id) + is + Btyp : constant Entity_Id := Base_Type (T); + Rtyp : constant Entity_Id := Root_Type (T); + Digs : constant Nat := UI_To_Int (Digits_Value (Btyp)); + + begin + -- If the base type is VAX float, then get appropriate VAX float type + + if Vax_Float (Btyp) then + case Digs is + when 6 => + Fat_Type := RTE (RE_Fat_VAX_F); + Fat_Pkg := RE_Attr_VAX_F_Float; + + when 9 => + Fat_Type := RTE (RE_Fat_VAX_D); + Fat_Pkg := RE_Attr_VAX_D_Float; + + when 15 => + Fat_Type := RTE (RE_Fat_VAX_G); + Fat_Pkg := RE_Attr_VAX_G_Float; + + when others => + raise Program_Error; + end case; + + -- If root type is VAX float, this is the case where the library has + -- been recompiled in VAX float mode, and we have an IEEE float type. + -- This is when we use the special IEEE Fat packages. + + elsif Vax_Float (Rtyp) then + case Digs is + when 6 => + Fat_Type := RTE (RE_Fat_IEEE_Short); + Fat_Pkg := RE_Attr_IEEE_Short; + + when 15 => + Fat_Type := RTE (RE_Fat_IEEE_Long); + Fat_Pkg := RE_Attr_IEEE_Long; + + when others => + raise Program_Error; + end case; + + -- If neither the base type nor the root type is VAX_Native then VAX + -- float is out of the picture, and we can just use the root type. + + else + Fat_Type := Rtyp; + + if Fat_Type = Standard_Short_Float then + Fat_Pkg := RE_Attr_Short_Float; + + elsif Fat_Type = Standard_Float then + Fat_Pkg := RE_Attr_Float; + + elsif Fat_Type = Standard_Long_Float then + Fat_Pkg := RE_Attr_Long_Float; + + elsif Fat_Type = Standard_Long_Long_Float then + Fat_Pkg := RE_Attr_Long_Long_Float; + + -- Universal real (which is its own root type) is treated as being + -- equivalent to Standard.Long_Long_Float, since it is defined to + -- have the same precision as the longest Float type. + + elsif Fat_Type = Universal_Real then + Fat_Type := Standard_Long_Long_Float; + Fat_Pkg := RE_Attr_Long_Long_Float; + + else + raise Program_Error; + end if; + end if; + end Find_Fat_Info; + + ---------------------------- + -- Find_Stream_Subprogram -- + ---------------------------- + + function Find_Stream_Subprogram + (Typ : Entity_Id; + Nam : TSS_Name_Type) return Entity_Id + is + Base_Typ : constant Entity_Id := Base_Type (Typ); + Ent : constant Entity_Id := TSS (Typ, Nam); + + begin + if Present (Ent) then + return Ent; + end if; + + -- Stream attributes for strings are expanded into library calls. The + -- following checks are disabled when the run-time is not available or + -- when compiling predefined types due to bootstrap issues. As a result, + -- the compiler will generate in-place stream routines for string types + -- that appear in GNAT's library, but will generate calls via rtsfind + -- to library routines for user code. + + -- ??? For now, disable this code for JVM, since this generates a + -- VerifyError exception at run time on e.g. c330001. + + -- This is disabled for AAMP, to avoid creating dependences on files not + -- supported in the AAMP library (such as s-fileio.adb). + + if VM_Target /= JVM_Target + and then not AAMP_On_Target + and then + not Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit)) + then + -- String as defined in package Ada + + if Base_Typ = Standard_String then + if Restriction_Active (No_Stream_Optimizations) then + if Nam = TSS_Stream_Input then + return RTE (RE_String_Input); + + elsif Nam = TSS_Stream_Output then + return RTE (RE_String_Output); + + elsif Nam = TSS_Stream_Read then + return RTE (RE_String_Read); + + else pragma Assert (Nam = TSS_Stream_Write); + return RTE (RE_String_Write); + end if; + + else + if Nam = TSS_Stream_Input then + return RTE (RE_String_Input_Blk_IO); + + elsif Nam = TSS_Stream_Output then + return RTE (RE_String_Output_Blk_IO); + + elsif Nam = TSS_Stream_Read then + return RTE (RE_String_Read_Blk_IO); + + else pragma Assert (Nam = TSS_Stream_Write); + return RTE (RE_String_Write_Blk_IO); + end if; + end if; + + -- Wide_String as defined in package Ada + + elsif Base_Typ = Standard_Wide_String then + if Restriction_Active (No_Stream_Optimizations) then + if Nam = TSS_Stream_Input then + return RTE (RE_Wide_String_Input); + + elsif Nam = TSS_Stream_Output then + return RTE (RE_Wide_String_Output); + + elsif Nam = TSS_Stream_Read then + return RTE (RE_Wide_String_Read); + + else pragma Assert (Nam = TSS_Stream_Write); + return RTE (RE_Wide_String_Write); + end if; + + else + if Nam = TSS_Stream_Input then + return RTE (RE_Wide_String_Input_Blk_IO); + + elsif Nam = TSS_Stream_Output then + return RTE (RE_Wide_String_Output_Blk_IO); + + elsif Nam = TSS_Stream_Read then + return RTE (RE_Wide_String_Read_Blk_IO); + + else pragma Assert (Nam = TSS_Stream_Write); + return RTE (RE_Wide_String_Write_Blk_IO); + end if; + end if; + + -- Wide_Wide_String as defined in package Ada + + elsif Base_Typ = Standard_Wide_Wide_String then + if Restriction_Active (No_Stream_Optimizations) then + if Nam = TSS_Stream_Input then + return RTE (RE_Wide_Wide_String_Input); + + elsif Nam = TSS_Stream_Output then + return RTE (RE_Wide_Wide_String_Output); + + elsif Nam = TSS_Stream_Read then + return RTE (RE_Wide_Wide_String_Read); + + else pragma Assert (Nam = TSS_Stream_Write); + return RTE (RE_Wide_Wide_String_Write); + end if; + + else + if Nam = TSS_Stream_Input then + return RTE (RE_Wide_Wide_String_Input_Blk_IO); + + elsif Nam = TSS_Stream_Output then + return RTE (RE_Wide_Wide_String_Output_Blk_IO); + + elsif Nam = TSS_Stream_Read then + return RTE (RE_Wide_Wide_String_Read_Blk_IO); + + else pragma Assert (Nam = TSS_Stream_Write); + return RTE (RE_Wide_Wide_String_Write_Blk_IO); + end if; + end if; + end if; + end if; + + if Is_Tagged_Type (Typ) + and then Is_Derived_Type (Typ) + then + return Find_Prim_Op (Typ, Nam); + else + return Find_Inherited_TSS (Typ, Nam); + end if; + end Find_Stream_Subprogram; + + --------------- + -- Full_Base -- + --------------- + + function Full_Base (T : Entity_Id) return Entity_Id is + BT : Entity_Id; + + begin + BT := Base_Type (T); + + if Is_Private_Type (BT) + and then Present (Full_View (BT)) + then + BT := Full_View (BT); + end if; + + return BT; + end Full_Base; + + ----------------------- + -- Get_Index_Subtype -- + ----------------------- + + function Get_Index_Subtype (N : Node_Id) return Node_Id is + P_Type : Entity_Id := Etype (Prefix (N)); + Indx : Node_Id; + J : Int; + + begin + if Is_Access_Type (P_Type) then + P_Type := Designated_Type (P_Type); + end if; + + if No (Expressions (N)) then + J := 1; + else + J := UI_To_Int (Expr_Value (First (Expressions (N)))); + end if; + + Indx := First_Index (P_Type); + while J > 1 loop + Next_Index (Indx); + J := J - 1; + end loop; + + return Etype (Indx); + end Get_Index_Subtype; + + ------------------------------- + -- Get_Stream_Convert_Pragma -- + ------------------------------- + + function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id is + Typ : Entity_Id; + N : Node_Id; + + begin + -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity + -- that a stream convert pragma for a tagged type is not inherited from + -- its parent. Probably what is wrong here is that it is basically + -- incorrect to consider a stream convert pragma to be a representation + -- pragma at all ??? + + N := First_Rep_Item (Implementation_Base_Type (T)); + while Present (N) loop + if Nkind (N) = N_Pragma + and then Pragma_Name (N) = Name_Stream_Convert + then + -- For tagged types this pragma is not inherited, so we + -- must verify that it is defined for the given type and + -- not an ancestor. + + Typ := + Entity (Expression (First (Pragma_Argument_Associations (N)))); + + if not Is_Tagged_Type (T) + or else T = Typ + or else (Is_Private_Type (Typ) and then T = Full_View (Typ)) + then + return N; + end if; + end if; + + Next_Rep_Item (N); + end loop; + + return Empty; + end Get_Stream_Convert_Pragma; + + --------------------------------- + -- Is_Constrained_Packed_Array -- + --------------------------------- + + function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean is + Arr : Entity_Id := Typ; + + begin + if Is_Access_Type (Arr) then + Arr := Designated_Type (Arr); + end if; + + return Is_Array_Type (Arr) + and then Is_Constrained (Arr) + and then Present (Packed_Array_Type (Arr)); + end Is_Constrained_Packed_Array; + + ---------------------------------------- + -- Is_Inline_Floating_Point_Attribute -- + ---------------------------------------- + + function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean is + Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); + + begin + if Nkind (Parent (N)) /= N_Type_Conversion + or else not Is_Integer_Type (Etype (Parent (N))) + then + return False; + end if; + + -- Should also support 'Machine_Rounding and 'Unbiased_Rounding, but + -- required back end support has not been implemented yet ??? + + return Id = Attribute_Truncation; + end Is_Inline_Floating_Point_Attribute; + +end Exp_Attr; diff --git a/gcc/ada/exp_attr.ads b/gcc/ada/exp_attr.ads new file mode 100644 index 000000000..8fca7a058 --- /dev/null +++ b/gcc/ada/exp_attr.ads @@ -0,0 +1,34 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ A T T R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for attribute references + +with Types; use Types; + +package Exp_Attr is + + procedure Expand_N_Attribute_Reference (N : Node_Id); + +end Exp_Attr; diff --git a/gcc/ada/exp_cg.adb b/gcc/ada/exp_cg.adb new file mode 100644 index 000000000..4f9666476 --- /dev/null +++ b/gcc/ada/exp_cg.adb @@ -0,0 +1,670 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Elists; use Elists; +with Exp_Disp; use Exp_Disp; +with Exp_Dbug; use Exp_Dbug; +with Exp_Tss; use Exp_Tss; +with Lib; use Lib; +with Namet; use Namet; +with Opt; use Opt; +with Output; use Output; +with Sem_Aux; use Sem_Aux; +with Sem_Disp; use Sem_Disp; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with System; use System; +with Table; +with Uintp; use Uintp; + +package body Exp_CG is + + -- We duplicate here some declarations from packages Interfaces.C and + -- Interfaces.C_Streams because adding their dependence to the frontend + -- causes bootstrapping problems with old versions of the compiler. + + subtype FILEs is System.Address; + -- Corresponds to the C type FILE* + + subtype C_chars is System.Address; + -- Pointer to null-terminated array of characters + + function fputs (Strng : C_chars; Stream : FILEs) return Integer; + pragma Import (C, fputs, "fputs"); + + -- Import the file stream associated with the "ci" output file. Done to + -- generate the output in the file created and left opened by routine + -- toplev.c before calling gnat1drv. + + Callgraph_Info_File : FILEs; + pragma Import (C, Callgraph_Info_File); + + package Call_Graph_Nodes is new Table.Table ( + Table_Component_Type => Node_Id, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 100, + Table_Name => "Call_Graph_Nodes"); + -- This table records nodes associated with dispatching calls and tagged + -- type declarations found in the main compilation unit. Used as an + -- auxiliary storage because the call-graph output requires fully qualified + -- names and they are not available until the backend is called. + + function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean; + -- Determines if E is a predefined primitive operation. + -- Note: This routine should replace the routine with the same name that is + -- currently available in exp_disp because it extends its functionality to + -- handle fully qualified names ??? + + function Slot_Number (Prim : Entity_Id) return Uint; + -- Returns the slot number associated with Prim. For predefined primitives + -- the slot is returned as a negative number. + + procedure Write_Output (Str : String); + -- Used to print a line in the output file (this is used as the + -- argument for a call to Set_Special_Output in package Output). + + procedure Write_Call_Info (Call : Node_Id); + -- Subsidiary of Generate_CG_Output that generates the output associated + -- with a dispatching call. + + procedure Write_Type_Info (Typ : Entity_Id); + -- Subsidiary of Generate_CG_Output that generates the output associated + -- with a tagged type declaration. + + ------------------------ + -- Generate_CG_Output -- + ------------------------ + + procedure Generate_CG_Output is + N : Node_Id; + + begin + -- No output if the "ci" output file has not been previously opened + -- by toplev.c + + if Callgraph_Info_File = Null_Address then + return; + end if; + + -- Setup write routine, create the output file and generate the output + + Set_Special_Output (Write_Output'Access); + + for J in Call_Graph_Nodes.First .. Call_Graph_Nodes.Last loop + N := Call_Graph_Nodes.Table (J); + + if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) then + Write_Call_Info (N); + + else pragma Assert (Nkind (N) = N_Defining_Identifier); + + -- The type may be a private untagged type whose completion is + -- tagged, in which case we must use the full tagged view. + + if not Is_Tagged_Type (N) and then Is_Private_Type (N) then + N := Full_View (N); + end if; + + pragma Assert (Is_Tagged_Type (N)); + + Write_Type_Info (N); + end if; + end loop; + + Set_Special_Output (null); + end Generate_CG_Output; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Call_Graph_Nodes.Init; + end Initialize; + + ----------------------------------------- + -- Is_Predefined_Dispatching_Operation -- + ----------------------------------------- + + function Is_Predefined_Dispatching_Operation + (E : Entity_Id) return Boolean + is + function Homonym_Suffix_Length (E : Entity_Id) return Natural; + -- Returns the length of the homonym suffix corresponding to E. + -- Note: This routine relies on the functionality provided by routines + -- of Exp_Dbug. Further work needed here to decide if it should be + -- located in that package??? + + --------------------------- + -- Homonym_Suffix_Length -- + --------------------------- + + function Homonym_Suffix_Length (E : Entity_Id) return Natural is + Prefix_Length : constant := 2; + -- Length of prefix "__" + + H : Entity_Id; + Nr : Nat := 1; + + begin + if not Has_Homonym (E) then + return 0; + + else + H := Homonym (E); + while Present (H) loop + if Scope (H) = Scope (E) then + Nr := Nr + 1; + end if; + + H := Homonym (H); + end loop; + + if Nr = 1 then + return 0; + + -- Prefix "__" followed by number + + else + declare + Result : Natural := Prefix_Length + 1; + + begin + while Nr >= 10 loop + Result := Result + 1; + Nr := Nr / 10; + end loop; + + return Result; + end; + end if; + end if; + end Homonym_Suffix_Length; + + -- Local variables + + Full_Name : constant String := Get_Name_String (Chars (E)); + Suffix_Length : Natural; + TSS_Name : TSS_Name_Type; + + -- Start of processing for Is_Predefined_Dispatching_Operation + + begin + if not Is_Dispatching_Operation (E) then + return False; + end if; + + -- Search for and strip suffix for body-nested package entities + + Suffix_Length := Homonym_Suffix_Length (E); + for J in reverse Full_Name'First + 2 .. Full_Name'Last loop + if Full_Name (J) = 'X' then + + -- Include the "X", "Xb", "Xn", ... in the part of the + -- suffix to be removed. + + Suffix_Length := Suffix_Length + Full_Name'Last - J + 1; + exit; + end if; + + exit when Full_Name (J) /= 'b' and then Full_Name (J) /= 'n'; + end loop; + + -- Most predefined primitives have internally generated names. Equality + -- must be treated differently; the predefined operation is recognized + -- as a homogeneous binary operator that returns Boolean. + + if Full_Name'Length > TSS_Name_Type'Length then + TSS_Name := + TSS_Name_Type + (Full_Name + (Full_Name'Last - TSS_Name'Length - Suffix_Length + 1 + .. Full_Name'Last - Suffix_Length)); + + if TSS_Name = TSS_Stream_Read + or else TSS_Name = TSS_Stream_Write + or else TSS_Name = TSS_Stream_Input + or else TSS_Name = TSS_Stream_Output + or else TSS_Name = TSS_Deep_Adjust + or else TSS_Name = TSS_Deep_Finalize + then + return True; + + elsif not Has_Fully_Qualified_Name (E) then + if Chars (E) = Name_uSize + or else Chars (E) = Name_uAlignment + or else + (Chars (E) = Name_Op_Eq + and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) + or else Chars (E) = Name_uAssign + or else Is_Predefined_Interface_Primitive (E) + then + return True; + end if; + + -- Handle fully qualified names + + else + declare + type Names_Table is array (Positive range <>) of Name_Id; + + Predef_Names_95 : constant Names_Table := + (Name_uSize, + Name_uAlignment, + Name_Op_Eq, + Name_uAssign); + + Predef_Names_05 : constant Names_Table := + (Name_uDisp_Asynchronous_Select, + Name_uDisp_Conditional_Select, + Name_uDisp_Get_Prim_Op_Kind, + Name_uDisp_Get_Task_Id, + Name_uDisp_Requeue, + Name_uDisp_Timed_Select); + + begin + for J in Predef_Names_95'Range loop + Get_Name_String (Predef_Names_95 (J)); + + -- The predefined primitive operations are identified by the + -- names "_size", "_alignment", etc. If we try a pattern + -- matching against this string, we can wrongly match other + -- primitive operations like "get_size". To avoid this, we + -- add the "__" scope separator, which can only prepend + -- predefined primitive operations because other primitive + -- operations can neither start with an underline nor + -- contain two consecutive underlines in its name. + + if Full_Name'Last - Suffix_Length > Name_Len + 2 + and then + Full_Name + (Full_Name'Last - Name_Len - 2 - Suffix_Length + 1 + .. Full_Name'Last - Suffix_Length) = + "__" & Name_Buffer (1 .. Name_Len) + then + -- For the equality operator the type of the two operands + -- must also match. + + return Predef_Names_95 (J) /= Name_Op_Eq + or else + Etype (First_Formal (E)) = Etype (Last_Formal (E)); + end if; + end loop; + + if Ada_Version >= Ada_2005 then + for J in Predef_Names_05'Range loop + Get_Name_String (Predef_Names_05 (J)); + + if Full_Name'Last - Suffix_Length > Name_Len + 2 + and then + Full_Name + (Full_Name'Last - Name_Len - 2 - Suffix_Length + 1 + .. Full_Name'Last - Suffix_Length) = + "__" & Name_Buffer (1 .. Name_Len) + then + return True; + end if; + end loop; + end if; + end; + end if; + end if; + + return False; + end Is_Predefined_Dispatching_Operation; + + ---------------------- + -- Register_CG_Node -- + ---------------------- + + procedure Register_CG_Node (N : Node_Id) is + begin + if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) then + if Current_Scope = Main_Unit_Entity + or else Entity_Is_In_Main_Unit (Current_Scope) + then + -- Register a copy of the dispatching call node. Needed since the + -- node containing a dispatching call is rewritten by the + -- expander. + + declare + Copy : constant Node_Id := New_Copy (N); + Par : Node_Id; + + begin + -- Determine the enclosing scope to use when generating the + -- call graph. This must be done now to avoid problems with + -- control structures that may be rewritten during expansion. + + Par := Parent (N); + while Nkind (Par) /= N_Subprogram_Body + and then Nkind (Parent (Par)) /= N_Compilation_Unit + loop + Par := Parent (Par); + pragma Assert (Present (Par)); + end loop; + + Set_Parent (Copy, Par); + Call_Graph_Nodes.Append (Copy); + end; + end if; + + else pragma Assert (Nkind (N) = N_Defining_Identifier); + if Entity_Is_In_Main_Unit (N) then + Call_Graph_Nodes.Append (N); + end if; + end if; + end Register_CG_Node; + + ----------------- + -- Slot_Number -- + ----------------- + + function Slot_Number (Prim : Entity_Id) return Uint is + E : constant Entity_Id := Ultimate_Alias (Prim); + begin + if Is_Predefined_Dispatching_Operation (E) then + return -DT_Position (E); + else + return DT_Position (E); + end if; + end Slot_Number; + + ------------------ + -- Write_Output -- + ------------------ + + procedure Write_Output (Str : String) is + Nul : constant Character := Character'First; + Line : String (Str'First .. Str'Last + 1); + Errno : Integer; + + begin + -- Add the null character to the string as required by fputs + + Line := Str & Nul; + Errno := fputs (Line'Address, Callgraph_Info_File); + pragma Assert (Errno >= 0); + end Write_Output; + + --------------------- + -- Write_Call_Info -- + --------------------- + + procedure Write_Call_Info (Call : Node_Id) is + Ctrl_Arg : constant Node_Id := Controlling_Argument (Call); + Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg)); + Prim : constant Entity_Id := Entity (Sinfo.Name (Call)); + P : constant Node_Id := Parent (Call); + + begin + Write_Str ("edge: { sourcename: "); + Write_Char ('"'); + + -- The parent node is the construct that contains the call: subprogram + -- body or library-level package. Display the qualified name of the + -- entity of the construct. For a subprogram, it is the entity of the + -- spec, which carries a homonym counter when it is overloaded. + + if Nkind (P) = N_Subprogram_Body + and then not Acts_As_Spec (P) + then + Get_External_Name (Corresponding_Spec (P), Has_Suffix => False); + + else + Get_External_Name (Defining_Entity (P), Has_Suffix => False); + end if; + + Write_Str (Name_Buffer (1 .. Name_Len)); + + if Nkind (P) = N_Package_Declaration then + Write_Str ("___elabs"); + + elsif Nkind (P) = N_Package_Body then + Write_Str ("___elabb"); + end if; + + Write_Char ('"'); + Write_Eol; + + -- The targetname is a triple: + -- N: the index in a vtable used for dispatch + -- V: the type who's vtable is used + -- S: the static type of the expression + + Write_Str (" targetname: "); + Write_Char ('"'); + + pragma Assert (No (Interface_Alias (Prim))); + + -- The check on Is_Ancestor is done here to avoid problems with + -- renamings of primitives. For example: + + -- type Root is tagged ... + -- procedure Base (Obj : Root); + -- procedure Base2 (Obj : Root) renames Base; + + if Present (Alias (Prim)) + and then + Is_Ancestor + (Find_Dispatching_Type (Ultimate_Alias (Prim)), + Root_Type (Ctrl_Typ)) + then + -- This is a special case in which we generate in the ci file the + -- slot number of the renaming primitive (i.e. Base2) but instead of + -- generating the name of this renaming entity we reference directly + -- the renamed entity (i.e. Base). + + Write_Int (UI_To_Int (Slot_Number (Prim))); + Write_Char (':'); + Write_Name + (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim)))); + else + Write_Int (UI_To_Int (Slot_Number (Prim))); + Write_Char (':'); + Write_Name (Chars (Root_Type (Ctrl_Typ))); + end if; + + Write_Char (','); + Write_Name (Chars (Root_Type (Ctrl_Typ))); + + Write_Char ('"'); + Write_Eol; + + Write_Str (" label: "); + Write_Char ('"'); + Write_Location (Sloc (Call)); + Write_Char ('"'); + Write_Eol; + + Write_Char ('}'); + Write_Eol; + end Write_Call_Info; + + --------------------- + -- Write_Type_Info -- + --------------------- + + procedure Write_Type_Info (Typ : Entity_Id) is + Elmt : Elmt_Id; + Prim : Node_Id; + + Parent_Typ : Entity_Id; + Separator_Needed : Boolean := False; + + begin + -- Initialize Parent_Typ handling private types + + Parent_Typ := Etype (Typ); + + if Present (Full_View (Parent_Typ)) then + Parent_Typ := Full_View (Parent_Typ); + end if; + + Write_Str ("class {"); + Write_Eol; + + Write_Str (" classname: "); + Write_Char ('"'); + Write_Name (Chars (Typ)); + Write_Char ('"'); + Write_Eol; + + Write_Str (" label: "); + Write_Char ('"'); + Write_Name (Chars (Typ)); + Write_Char ('\'); + Write_Location (Sloc (Typ)); + Write_Char ('"'); + Write_Eol; + + if Parent_Typ /= Typ then + Write_Str (" parent: "); + Write_Char ('"'); + Write_Name (Chars (Parent_Typ)); + + -- Note: Einfo prefix not needed if this routine is moved to + -- exp_disp??? + + if Present (Einfo.Interfaces (Typ)) + and then not Is_Empty_Elmt_List (Einfo.Interfaces (Typ)) + then + Elmt := First_Elmt (Einfo.Interfaces (Typ)); + while Present (Elmt) loop + Write_Str (", "); + Write_Name (Chars (Node (Elmt))); + Next_Elmt (Elmt); + end loop; + end if; + + Write_Char ('"'); + Write_Eol; + end if; + + Write_Str (" virtuals: "); + Write_Char ('"'); + + Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Elmt) loop + Prim := Node (Elmt); + + -- Skip internal entities associated with overridden interface + -- primitives, and also inherited primitives. + + if Present (Interface_Alias (Prim)) + or else + (Present (Alias (Prim)) + and then Find_Dispatching_Type (Prim) /= + Find_Dispatching_Type (Alias (Prim))) + then + goto Continue; + end if; + + -- Do not generate separator for output of first primitive + + if Separator_Needed then + Write_Str ("\n"); + Write_Eol; + Write_Str (" "); + else + Separator_Needed := True; + end if; + + Write_Int (UI_To_Int (Slot_Number (Prim))); + Write_Char (':'); + + -- Handle renamed primitives + + if Present (Alias (Prim)) then + Write_Name (Chars (Ultimate_Alias (Prim))); + else + Write_Name (Chars (Prim)); + end if; + + -- Display overriding of parent primitives + + if Present (Overridden_Operation (Prim)) + and then + Is_Ancestor + (Find_Dispatching_Type (Overridden_Operation (Prim)), Typ) + then + Write_Char (','); + Write_Int + (UI_To_Int (Slot_Number (Overridden_Operation (Prim)))); + Write_Char (':'); + Write_Name + (Chars (Find_Dispatching_Type (Overridden_Operation (Prim)))); + end if; + + -- Display overriding of interface primitives + + if Has_Interfaces (Typ) then + declare + Prim_Elmt : Elmt_Id; + Prim_Op : Node_Id; + Int_Alias : Entity_Id; + + begin + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim_Op := Node (Prim_Elmt); + Int_Alias := Interface_Alias (Prim_Op); + + if Present (Int_Alias) + and then + not Is_Ancestor (Find_Dispatching_Type (Int_Alias), Typ) + and then (Alias (Prim_Op)) = Prim + then + Write_Char (','); + Write_Int (UI_To_Int (Slot_Number (Int_Alias))); + Write_Char (':'); + Write_Name (Chars (Find_Dispatching_Type (Int_Alias))); + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end; + end if; + + <> + Next_Elmt (Elmt); + end loop; + + Write_Char ('"'); + Write_Eol; + + Write_Char ('}'); + Write_Eol; + end Write_Type_Info; + +end Exp_CG; diff --git a/gcc/ada/exp_cg.ads b/gcc/ada/exp_cg.ads new file mode 100644 index 000000000..5c2458d84 --- /dev/null +++ b/gcc/ada/exp_cg.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C G -- +-- -- +-- S p e c -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 to store and handle nodes required +-- to generate call graph information of dispatching calls. + +with Types; use Types; + +package Exp_CG is + + procedure Generate_CG_Output; + -- Generate in the standard output the information associated with tagged + -- types declaration and dispatching calls + + procedure Initialize; + -- Called at the start of compilation to initialize the table that stores + -- the tree nodes used by Generate_Output. This table is required because + -- the format of the output requires fully qualified names (and hence the + -- output must be generated after the source program has been compiled). + + procedure Register_CG_Node (N : Node_Id); + -- Register a dispatching call node or the defining entity of a tagged + -- type declaration + +end Exp_CG; diff --git a/gcc/ada/exp_ch10.ads b/gcc/ada/exp_ch10.ads new file mode 100644 index 000000000..a6acb805b --- /dev/null +++ b/gcc/ada/exp_ch10.ads @@ -0,0 +1,29 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 1 0 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for chapter 10 constructs + +package Exp_Ch10 is +end Exp_Ch10; diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb new file mode 100644 index 000000000..80d1d8d69 --- /dev/null +++ b/gcc/ada/exp_ch11.adb @@ -0,0 +1,2035 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 1 1 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Casing; use Casing; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Ch7; use Exp_Ch7; +with Exp_Util; use Exp_Util; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Ch8; use Sem_Ch8; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +package body Exp_Ch11 is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Warn_No_Exception_Propagation_Active (N : Node_Id); + -- Generates warning that pragma Restrictions (No_Exception_Propagation) + -- is in effect. Caller then generates appropriate continuation message. + -- N is the node on which the warning is placed. + + procedure Warn_If_No_Propagation (N : Node_Id); + -- Called for an exception raise that is not a local raise (and thus can + -- not be optimized to a goto. Issues warning if No_Exception_Propagation + -- restriction is set. N is the node for the raise or equivalent call. + + --------------------------- + -- Expand_At_End_Handler -- + --------------------------- + + -- For a handled statement sequence that has a cleanup (At_End_Proc + -- field set), an exception handler of the following form is required: + + -- exception + -- when all others => + -- cleanup call + -- raise; + + -- Note: this exception handler is treated rather specially by + -- subsequent expansion in two respects: + + -- The normal call to Undefer_Abort is omitted + -- The raise call does not do Defer_Abort + + -- This is because the current tasking code seems to assume that + -- the call to the cleanup routine that is made from an exception + -- handler for the abort signal is called with aborts deferred. + + -- This expansion is only done if we have front end exception handling. + -- If we have back end exception handling, then the AT END handler is + -- left alone, and cleanups (including the exceptional case) are handled + -- by the back end. + + -- In the front end case, the exception handler described above handles + -- the exceptional case. The AT END handler is left in the generated tree + -- and the code generator (e.g. gigi) must still handle proper generation + -- of cleanup calls for the non-exceptional case. + + procedure Expand_At_End_Handler (HSS : Node_Id; Block : Node_Id) is + Clean : constant Entity_Id := Entity (At_End_Proc (HSS)); + Loc : constant Source_Ptr := Sloc (Clean); + Ohandle : Node_Id; + Stmnts : List_Id; + + begin + pragma Assert (Present (Clean)); + pragma Assert (No (Exception_Handlers (HSS))); + + -- Don't expand if back end exception handling active + + if Exception_Mechanism = Back_End_Exceptions then + return; + end if; + + -- Don't expand an At End handler if we have already had configurable + -- run-time violations, since likely this will just be a matter of + -- generating useless cascaded messages + + if Configurable_Run_Time_Violations > 0 then + return; + end if; + + -- Don't expand an At End handler if we are not allowing exceptions + -- or if exceptions are transformed into local gotos, and never + -- propagated (No_Exception_Propagation). + + if No_Exception_Handlers_Set then + return; + end if; + + if Present (Block) then + Push_Scope (Block); + end if; + + Ohandle := + Make_Others_Choice (Loc); + Set_All_Others (Ohandle); + + Stmnts := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Clean, Loc))); + + -- Generate reraise statement as last statement of AT-END handler, + -- unless we are under control of No_Exception_Propagation, in which + -- case no exception propagation is possible anyway, so we do not need + -- a reraise (the AT END handler in this case is only for normal exits + -- not for exceptional exits). Also, we flag the Reraise statement as + -- being part of an AT END handler to prevent signalling this reraise + -- as a violation of the restriction when it is not set. + + if not Restriction_Active (No_Exception_Propagation) then + declare + Rstm : constant Node_Id := Make_Raise_Statement (Loc); + begin + Set_From_At_End (Rstm); + Append_To (Stmnts, Rstm); + end; + end if; + + Set_Exception_Handlers (HSS, New_List ( + Make_Implicit_Exception_Handler (Loc, + Exception_Choices => New_List (Ohandle), + Statements => Stmnts))); + + Analyze_List (Stmnts, Suppress => All_Checks); + Expand_Exception_Handlers (HSS); + + if Present (Block) then + Pop_Scope; + end if; + end Expand_At_End_Handler; + + ------------------------------- + -- Expand_Exception_Handlers -- + ------------------------------- + + procedure Expand_Exception_Handlers (HSS : Node_Id) is + Handlrs : constant List_Id := Exception_Handlers (HSS); + Loc : constant Source_Ptr := Sloc (HSS); + Handler : Node_Id; + Others_Choice : Boolean; + Obj_Decl : Node_Id; + Next_Handler : Node_Id; + + procedure Expand_Local_Exception_Handlers; + -- This procedure handles the expansion of exception handlers for the + -- optimization of local raise statements into goto statements. + + procedure Prepend_Call_To_Handler + (Proc : RE_Id; + Args : List_Id := No_List); + -- Routine to prepend a call to the procedure referenced by Proc at + -- the start of the handler code for the current Handler. + + procedure Replace_Raise_By_Goto (Raise_S : Node_Id; Goto_L1 : Node_Id); + -- Raise_S is a raise statement (possibly expanded, and possibly of the + -- form of a Raise_xxx_Error node with a condition. This procedure is + -- called to replace the raise action with the (already analyzed) goto + -- statement passed as Goto_L1. This procedure also takes care of the + -- requirement of inserting a Local_Raise call where possible. + + ------------------------------------- + -- Expand_Local_Exception_Handlers -- + ------------------------------------- + + -- There are two cases for this transformation. First the case of + -- explicit raise statements. For this case, the transformation we do + -- looks like this. Right now we have for example (where L1, L2 are + -- exception labels) + + -- begin + -- ... + -- raise_exception (excep1'identity); -- was raise excep1 + -- ... + -- raise_exception (excep2'identity); -- was raise excep2 + -- ... + -- exception + -- when excep1 => + -- estmts1 + -- when excep2 => + -- estmts2 + -- end; + + -- This gets transformed into: + + -- begin + -- L1 : label; -- marked Exception_Junk + -- L2 : label; -- marked Exception_Junk + -- L3 : label; -- marked Exception_Junk + + -- begin -- marked Exception_Junk + -- ... + -- local_raise (excep1'address); -- was raise excep1 + -- goto L1; + -- ... + -- local_raise (excep2'address); -- was raise excep2 + -- goto L2; + -- ... + -- exception + -- when excep1 => + -- goto L1; + -- when excep2 => + -- goto L2; + -- end; + + -- goto L3; -- skip handler if no raise, marked Exception_Junk + + -- <> -- local excep target label, marked Exception_Junk + -- begin -- marked Exception_Junk + -- estmts1 + -- end; + -- goto L3; -- marked Exception_Junk + + -- <> -- marked Exception_Junk + -- begin -- marked Exception_Junk + -- estmts2 + -- end; + -- goto L3; -- marked Exception_Junk + -- <> -- marked Exception_Junk + -- end; + + -- Note: the reason we wrap the original statement sequence in an + -- inner block is that there may be raise statements within the + -- sequence of statements in the handlers, and we must ensure that + -- these are properly handled, and in particular, such raise statements + -- must not reenter the same exception handlers. + + -- If the restriction No_Exception_Propagation is in effect, then we + -- can omit the exception handlers. + + -- begin + -- L1 : label; -- marked Exception_Junk + -- L2 : label; -- marked Exception_Junk + -- L3 : label; -- marked Exception_Junk + + -- begin -- marked Exception_Junk + -- ... + -- local_raise (excep1'address); -- was raise excep1 + -- goto L1; + -- ... + -- local_raise (excep2'address); -- was raise excep2 + -- goto L2; + -- ... + -- end; + + -- goto L3; -- skip handler if no raise, marked Exception_Junk + + -- <> -- local excep target label, marked Exception_Junk + -- begin -- marked Exception_Junk + -- estmts1 + -- end; + -- goto L3; -- marked Exception_Junk + + -- <> -- marked Exception_Junk + -- begin -- marked Exception_Junk + -- estmts2 + -- end; + + -- <> -- marked Exception_Junk + -- end; + + -- The second case is for exceptions generated by the back end in one + -- of three situations: + + -- 1. Front end generates N_Raise_xxx_Error node + -- 2. Front end sets Do_xxx_Check flag in subexpression node + -- 3. Back end detects a situation where an exception is appropriate + + -- In all these cases, the current processing in gigi is to generate a + -- call to the appropriate Rcheck_xx routine (where xx encodes both the + -- exception message and the exception to be raised, Constraint_Error, + -- Program_Error, or Storage_Error. + + -- We could handle some subcases of 1 using the same front end expansion + -- into gotos, but even for case 1, we can't handle all cases, since + -- generating gotos in the middle of expressions is not possible (it's + -- possible at the gigi/gcc level, but not at the level of the GNAT + -- tree). + + -- In any case, it seems easier to have a scheme which handles all three + -- cases in a uniform manner. So here is how we proceed in this case. + + -- This procedure detects all handlers for these three exceptions, + -- Constraint_Error, Program_Error and Storage_Error (including WHEN + -- OTHERS handlers that cover one or more of these cases). + + -- If the handler meets the requirements for being the target of a local + -- raise, then the front end does the expansion described previously, + -- creating a label to be used as a goto target to raise the exception. + -- However, no attempt is made in the front end to convert any related + -- raise statements into gotos, e.g. all N_Raise_xxx_Error nodes are + -- left unchanged and passed to the back end. + + -- Instead, the front end generates two nodes + + -- N_Push_Constraint_Error_Label + -- N_Push_Program_Error_Label + -- N_Push_Storage_Error_Label + + -- The Push node is generated at the start of the statements + -- covered by the handler, and has as a parameter the label to be + -- used as the raise target. + + -- N_Pop_Constraint_Error_Label + -- N_Pop_Program_Error_Label + -- N_Pop_Storage_Error_Label + + -- The Pop node is generated at the end of the covered statements + -- and undoes the effect of the preceding corresponding Push node. + + -- In the case where the handler does NOT meet the requirements, the + -- front end will still generate the Push and Pop nodes, but the label + -- field in the Push node will be empty signifying that for this region + -- of code, no optimization is possible. + + -- The back end must maintain three stacks, one for each exception case, + -- the Push node pushes an entry onto the corresponding stack, and Pop + -- node pops off the entry. Then instead of calling Rcheck_nn, if the + -- corresponding top stack entry has an non-empty label, a goto is + -- generated. This goto should be preceded by a call to Local_Raise as + -- described above. + + -- An example of this transformation is as follows, given: + + -- declare + -- A : Integer range 1 .. 10; + -- begin + -- A := B + C; + -- exception + -- when Constraint_Error => + -- estmts + -- end; + + -- gets transformed to: + + -- declare + -- A : Integer range 1 .. 10; + + -- begin + -- L1 : label; + -- L2 : label; + + -- begin + -- %push_constraint_error_label (L1) + -- R1b : constant long_long_integer := long_long_integer?(b) + + -- long_long_integer?(c); + -- [constraint_error when + -- not (R1b in -16#8000_0000# .. 16#7FFF_FFFF#) + -- "overflow check failed"] + -- a := integer?(R1b); + -- %pop_constraint_error_Label + + -- exception + -- ... + -- when constraint_error => + -- goto L1; + -- end; + + -- goto L2; -- skip handler when exception not raised + -- <> -- target label for local exception + -- estmts + -- <> + -- end; + + -- Note: the generated labels and goto statements all have the flag + -- Exception_Junk set True, so that Sem_Ch6.Check_Returns will ignore + -- this generated exception stuff when checking for missing return + -- statements (see circuitry in Check_Statement_Sequence). + + -- Note: All of the processing described above occurs only if + -- restriction No_Exception_Propagation applies or debug flag .g is + -- enabled. + + CE_Locally_Handled : Boolean := False; + SE_Locally_Handled : Boolean := False; + PE_Locally_Handled : Boolean := False; + -- These three flags indicate whether a handler for the corresponding + -- exception (CE=Constraint_Error, SE=Storage_Error, PE=Program_Error) + -- is present. If so the switch is set to True, the Exception_Label + -- field of the corresponding handler is set, and appropriate Push + -- and Pop nodes are inserted into the code. + + Local_Expansion_Required : Boolean := False; + -- Set True if we have at least one handler requiring local raise + -- expansion as described above. + + procedure Expand_Local_Exception_Handlers is + + procedure Add_Exception_Label (H : Node_Id); + -- H is an exception handler. First check for an Exception_Label + -- already allocated for H. If none, allocate one, set the field in + -- the handler node, add the label declaration, and set the flag + -- Local_Expansion_Required. Note: if Local_Raise_Not_OK is set + -- the call has no effect and Exception_Label is left empty. + + procedure Add_Label_Declaration (L : Entity_Id); + -- Add an implicit declaration of the given label to the declaration + -- list in the parent of the current sequence of handled statements. + + generic + Exc_Locally_Handled : in out Boolean; + -- Flag indicating whether a local handler for this exception + -- has already been generated. + + with function Make_Push_Label (Loc : Source_Ptr) return Node_Id; + -- Function to create a Push_xxx_Label node + + with function Make_Pop_Label (Loc : Source_Ptr) return Node_Id; + -- Function to create a Pop_xxx_Label node + + procedure Generate_Push_Pop (H : Node_Id); + -- Common code for Generate_Push_Pop_xxx below, used to generate an + -- exception label and Push/Pop nodes for Constraint_Error, + -- Program_Error, or Storage_Error. + + ------------------------- + -- Add_Exception_Label -- + ------------------------- + + procedure Add_Exception_Label (H : Node_Id) is + begin + if No (Exception_Label (H)) + and then not Local_Raise_Not_OK (H) + and then not Special_Exception_Package_Used + then + Local_Expansion_Required := True; + + declare + L : constant Entity_Id := Make_Temporary (Sloc (H), 'L'); + begin + Set_Exception_Label (H, L); + Add_Label_Declaration (L); + end; + end if; + end Add_Exception_Label; + + --------------------------- + -- Add_Label_Declaration -- + --------------------------- + + procedure Add_Label_Declaration (L : Entity_Id) is + P : constant Node_Id := Parent (HSS); + + Decl_L : constant Node_Id := + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => L); + + begin + if Declarations (P) = No_List then + Set_Declarations (P, Empty_List); + end if; + + Append (Decl_L, Declarations (P)); + Analyze (Decl_L); + end Add_Label_Declaration; + + ----------------------- + -- Generate_Push_Pop -- + ----------------------- + + procedure Generate_Push_Pop (H : Node_Id) is + begin + if Exc_Locally_Handled then + return; + else + Exc_Locally_Handled := True; + end if; + + Add_Exception_Label (H); + + declare + F : constant Node_Id := First (Statements (HSS)); + L : constant Node_Id := Last (Statements (HSS)); + + Push : constant Node_Id := Make_Push_Label (Sloc (F)); + Pop : constant Node_Id := Make_Pop_Label (Sloc (L)); + + begin + -- We make sure that a call to Get_Local_Raise_Call_Entity is + -- made during front end processing, so that when we need it + -- in the back end, it will already be available and loaded. + + Discard_Node (Get_Local_Raise_Call_Entity); + + -- Prepare and insert Push and Pop nodes + + Set_Exception_Label (Push, Exception_Label (H)); + Insert_Before (F, Push); + Set_Analyzed (Push); + + Insert_After (L, Pop); + Set_Analyzed (Pop); + end; + end Generate_Push_Pop; + + -- Local declarations + + Loc : constant Source_Ptr := Sloc (HSS); + Stmts : List_Id := No_List; + Choice : Node_Id; + Excep : Entity_Id; + + procedure Generate_Push_Pop_For_Constraint_Error is + new Generate_Push_Pop + (Exc_Locally_Handled => CE_Locally_Handled, + Make_Push_Label => Make_Push_Constraint_Error_Label, + Make_Pop_Label => Make_Pop_Constraint_Error_Label); + -- If no Push/Pop has been generated for CE yet, then set the flag + -- CE_Locally_Handled, allocate an Exception_Label for handler H (if + -- not already done), and generate Push/Pop nodes for the exception + -- label at the start and end of the statements of HSS. + + procedure Generate_Push_Pop_For_Program_Error is + new Generate_Push_Pop + (Exc_Locally_Handled => PE_Locally_Handled, + Make_Push_Label => Make_Push_Program_Error_Label, + Make_Pop_Label => Make_Pop_Program_Error_Label); + -- If no Push/Pop has been generated for PE yet, then set the flag + -- PE_Locally_Handled, allocate an Exception_Label for handler H (if + -- not already done), and generate Push/Pop nodes for the exception + -- label at the start and end of the statements of HSS. + + procedure Generate_Push_Pop_For_Storage_Error is + new Generate_Push_Pop + (Exc_Locally_Handled => SE_Locally_Handled, + Make_Push_Label => Make_Push_Storage_Error_Label, + Make_Pop_Label => Make_Pop_Storage_Error_Label); + -- If no Push/Pop has been generated for SE yet, then set the flag + -- SE_Locally_Handled, allocate an Exception_Label for handler H (if + -- not already done), and generate Push/Pop nodes for the exception + -- label at the start and end of the statements of HSS. + + -- Start of processing for Expand_Local_Exception_Handlers + + begin + -- No processing if all exception handlers will get removed + + if Debug_Flag_Dot_X then + return; + end if; + + -- See for each handler if we have any local raises to expand + + Handler := First_Non_Pragma (Handlrs); + while Present (Handler) loop + + -- Note, we do not test Local_Raise_Not_OK here, because in the + -- case of Push/Pop generation we want to generate push with a + -- null label. The Add_Exception_Label routine has no effect if + -- Local_Raise_Not_OK is set, so this works as required. + + if Present (Local_Raise_Statements (Handler)) then + Add_Exception_Label (Handler); + end if; + + -- If we are doing local raise to goto optimization (restriction + -- No_Exception_Propagation set or debug flag .g set), then check + -- to see if handler handles CE, PE, SE and if so generate the + -- appropriate push/pop sequence for the back end. + + if (Debug_Flag_Dot_G + or else Restriction_Active (No_Exception_Propagation)) + and then Has_Local_Raise (Handler) + then + Choice := First (Exception_Choices (Handler)); + while Present (Choice) loop + if Nkind (Choice) = N_Others_Choice + and then not All_Others (Choice) + then + Generate_Push_Pop_For_Constraint_Error (Handler); + Generate_Push_Pop_For_Program_Error (Handler); + Generate_Push_Pop_For_Storage_Error (Handler); + + elsif Is_Entity_Name (Choice) then + Excep := Get_Renamed_Entity (Entity (Choice)); + + if Excep = Standard_Constraint_Error then + Generate_Push_Pop_For_Constraint_Error (Handler); + elsif Excep = Standard_Program_Error then + Generate_Push_Pop_For_Program_Error (Handler); + elsif Excep = Standard_Storage_Error then + Generate_Push_Pop_For_Storage_Error (Handler); + end if; + end if; + + Next (Choice); + end loop; + end if; + + Next_Non_Pragma (Handler); + end loop; + + -- Nothing to do if no handlers requiring the goto transformation + + if not (Local_Expansion_Required) then + return; + end if; + + -- Prepare to do the transformation + + declare + -- L3 is the label to exit the HSS + + L3_Dent : constant Entity_Id := Make_Temporary (Loc, 'L'); + + Labl_L3 : constant Node_Id := + Make_Label (Loc, + Identifier => New_Occurrence_Of (L3_Dent, Loc)); + + Blk_Stm : Node_Id; + Relmt : Elmt_Id; + + begin + Set_Exception_Junk (Labl_L3); + Add_Label_Declaration (L3_Dent); + + -- Wrap existing statements and handlers in an inner block + + Blk_Stm := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => Relocate_Node (HSS)); + Set_Exception_Junk (Blk_Stm); + + Rewrite (HSS, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Blk_Stm), + End_Label => Relocate_Node (End_Label (HSS)))); + + -- Set block statement as analyzed, we don't want to actually call + -- Analyze on this block, it would cause a recursion in exception + -- handler processing which would mess things up. + + Set_Analyzed (Blk_Stm); + + -- Now loop through the exception handlers to deal with those that + -- are targets of local raise statements. + + Handler := First_Non_Pragma (Handlrs); + while Present (Handler) loop + if Present (Exception_Label (Handler)) then + + -- This handler needs the goto expansion + + declare + Loc : constant Source_Ptr := Sloc (Handler); + + -- L1 is the start label for this handler + + L1_Dent : constant Entity_Id := Exception_Label (Handler); + + Labl_L1 : constant Node_Id := + Make_Label (Loc, + Identifier => + New_Occurrence_Of (L1_Dent, Loc)); + + -- Jump to L1 to be used as replacement for the original + -- handler (used in the case where exception propagation + -- may still occur). + + Name_L1 : constant Node_Id := + New_Occurrence_Of (L1_Dent, Loc); + + Goto_L1 : constant Node_Id := + Make_Goto_Statement (Loc, + Name => Name_L1); + + -- Jump to L3 to be used at the end of handler + + Name_L3 : constant Node_Id := + New_Occurrence_Of (L3_Dent, Loc); + + Goto_L3 : constant Node_Id := + Make_Goto_Statement (Loc, + Name => Name_L3); + + H_Stmts : constant List_Id := Statements (Handler); + + begin + Set_Exception_Junk (Labl_L1); + Set_Exception_Junk (Goto_L3); + + -- Note: we do NOT set Exception_Junk in Goto_L1, since + -- this is a real transfer of control that we want the + -- Sem_Ch6.Check_Returns procedure to recognize properly. + + -- Replace handler by a goto L1. We can mark this as + -- analyzed since it is fully formed, and we don't + -- want it going through any further checks. We save + -- the last statement location in the goto L1 node for + -- the benefit of Sem_Ch6.Check_Returns. + + Set_Statements (Handler, New_List (Goto_L1)); + Set_Analyzed (Goto_L1); + Set_Etype (Name_L1, Standard_Void_Type); + + -- Now replace all the raise statements by goto L1 + + if Present (Local_Raise_Statements (Handler)) then + Relmt := First_Elmt (Local_Raise_Statements (Handler)); + while Present (Relmt) loop + declare + Raise_S : constant Node_Id := Node (Relmt); + RLoc : constant Source_Ptr := Sloc (Raise_S); + Name_L1 : constant Node_Id := + New_Occurrence_Of (L1_Dent, Loc); + Goto_L1 : constant Node_Id := + Make_Goto_Statement (RLoc, + Name => Name_L1); + + begin + -- Replace raise by goto L1 + + Set_Analyzed (Goto_L1); + Set_Etype (Name_L1, Standard_Void_Type); + Replace_Raise_By_Goto (Raise_S, Goto_L1); + end; + + Next_Elmt (Relmt); + end loop; + end if; + + -- Add a goto L3 at end of statement list in block. The + -- first time, this is what skips over the exception + -- handlers in the normal case. Subsequent times, it + -- terminates the execution of the previous handler code, + -- and skips subsequent handlers. + + Stmts := Statements (HSS); + + Insert_After (Last (Stmts), Goto_L3); + Set_Analyzed (Goto_L3); + Set_Etype (Name_L3, Standard_Void_Type); + + -- Now we drop the label that marks the handler start, + -- followed by the statements of the handler. + + Set_Etype (Identifier (Labl_L1), Standard_Void_Type); + + Insert_After_And_Analyze (Last (Stmts), Labl_L1); + + declare + Loc : constant Source_Ptr := Sloc (First (H_Stmts)); + Blk : constant Node_Id := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => H_Stmts)); + begin + Set_Exception_Junk (Blk); + Insert_After_And_Analyze (Last (Stmts), Blk); + end; + end; + + -- Here if we have local raise statements but the handler is + -- not suitable for processing with a local raise. In this + -- case we have to generate possible diagnostics. + + elsif Has_Local_Raise (Handler) + and then Local_Raise_Statements (Handler) /= No_Elist + then + Relmt := First_Elmt (Local_Raise_Statements (Handler)); + while Present (Relmt) loop + Warn_If_No_Propagation (Node (Relmt)); + Next_Elmt (Relmt); + end loop; + end if; + + Next (Handler); + end loop; + + -- Only remaining step is to drop the L3 label and we are done + + Set_Etype (Identifier (Labl_L3), Standard_Void_Type); + + -- If we had at least one handler, then we drop the label after + -- the last statement of that handler. + + if Stmts /= No_List then + Insert_After_And_Analyze (Last (Stmts), Labl_L3); + + -- Otherwise we have removed all the handlers (this results from + -- use of pragma Restrictions (No_Exception_Propagation), and we + -- drop the label at the end of the statements of the HSS. + + else + Insert_After_And_Analyze (Last (Statements (HSS)), Labl_L3); + end if; + + return; + end; + end Expand_Local_Exception_Handlers; + + ----------------------------- + -- Prepend_Call_To_Handler -- + ----------------------------- + + procedure Prepend_Call_To_Handler + (Proc : RE_Id; + Args : List_Id := No_List) + is + Ent : constant Entity_Id := RTE (Proc); + + begin + -- If we have no Entity, then we are probably in no run time mode or + -- some weird error has occurred. In either case do nothing. Note use + -- of No_Location to hide this code from the debugger, so single + -- stepping doesn't jump back and forth. + + if Present (Ent) then + declare + Call : constant Node_Id := + Make_Procedure_Call_Statement (No_Location, + Name => New_Occurrence_Of (RTE (Proc), No_Location), + Parameter_Associations => Args); + + begin + Prepend_To (Statements (Handler), Call); + Analyze (Call, Suppress => All_Checks); + end; + end if; + end Prepend_Call_To_Handler; + + --------------------------- + -- Replace_Raise_By_Goto -- + --------------------------- + + procedure Replace_Raise_By_Goto (Raise_S : Node_Id; Goto_L1 : Node_Id) is + Loc : constant Source_Ptr := Sloc (Raise_S); + Excep : Entity_Id; + LR : Node_Id; + Cond : Node_Id; + Orig : Node_Id; + + begin + -- If we have a null statement, it means that there is no replacement + -- needed (typically this results from a suppressed check). + + if Nkind (Raise_S) = N_Null_Statement then + return; + + -- Test for Raise_xxx_Error + + elsif Nkind (Raise_S) = N_Raise_Constraint_Error then + Excep := Standard_Constraint_Error; + Cond := Condition (Raise_S); + + elsif Nkind (Raise_S) = N_Raise_Storage_Error then + Excep := Standard_Storage_Error; + Cond := Condition (Raise_S); + + elsif Nkind (Raise_S) = N_Raise_Program_Error then + Excep := Standard_Program_Error; + Cond := Condition (Raise_S); + + -- The only other possibility is a node that is or used to be a + -- simple raise statement. + + else + Orig := Original_Node (Raise_S); + pragma Assert (Nkind (Orig) = N_Raise_Statement + and then Present (Name (Orig)) + and then No (Expression (Orig))); + Excep := Entity (Name (Orig)); + Cond := Empty; + end if; + + -- Here Excep is the exception to raise, and Cond is the condition + -- First prepare the call to Local_Raise (excep'address). + + if RTE_Available (RE_Local_Raise) then + LR := + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Local_Raise), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Excep, Loc), + Attribute_Name => Name_Identity)))); + + -- Use null statement if Local_Raise not available + + else + LR := + Make_Null_Statement (Loc); + end if; + + -- If there is no condition, we rewrite as + + -- begin + -- Local_Raise (excep'Identity); + -- goto L1; + -- end; + + if No (Cond) then + Rewrite (Raise_S, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (LR, Goto_L1)))); + Set_Exception_Junk (Raise_S); + + -- If there is a condition, we rewrite as + + -- if condition then + -- Local_Raise (excep'Identity); + -- goto L1; + -- end if; + + else + Rewrite (Raise_S, + Make_If_Statement (Loc, + Condition => Cond, + Then_Statements => New_List (LR, Goto_L1))); + end if; + + Analyze (Raise_S); + end Replace_Raise_By_Goto; + + -- Start of processing for Expand_Exception_Handlers + + begin + Expand_Local_Exception_Handlers; + + -- Loop through handlers + + Handler := First_Non_Pragma (Handlrs); + Handler_Loop : while Present (Handler) loop + Next_Handler := Next_Non_Pragma (Handler); + + -- Remove source handler if gnat debug flag .x is set + + if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then + Remove (Handler); + + -- Remove handler if no exception propagation, generating a warning + -- if a source generated handler was not the target of a local raise. + + else + if Restriction_Active (No_Exception_Propagation) + and then not Has_Local_Raise (Handler) + and then Comes_From_Source (Handler) + and then Warn_On_Non_Local_Exception + then + Warn_No_Exception_Propagation_Active (Handler); + Error_Msg_N + ("\?this handler can never be entered, and has been removed", + Handler); + end if; + + if No_Exception_Propagation_Active then + Remove (Handler); + + -- Exception handler is active and retained and must be processed + + else + -- If an exception occurrence is present, then we must declare + -- it and initialize it from the value stored in the TSD + + -- declare + -- name : Exception_Occurrence; + -- begin + -- Save_Occurrence (name, Get_Current_Excep.all) + -- ... + -- end; + + if Present (Choice_Parameter (Handler)) then + declare + Cparm : constant Entity_Id := Choice_Parameter (Handler); + Cloc : constant Source_Ptr := Sloc (Cparm); + Hloc : constant Source_Ptr := Sloc (Handler); + Save : Node_Id; + + begin + -- Note use of No_Location to hide this code from the + -- debugger, so single stepping doesn't jump back and + -- forth. + + Save := + Make_Procedure_Call_Statement (No_Location, + Name => + New_Occurrence_Of (RTE (RE_Save_Occurrence), + No_Location), + Parameter_Associations => New_List ( + New_Occurrence_Of (Cparm, Cloc), + Make_Explicit_Dereference (No_Location, + Make_Function_Call (No_Location, + Name => Make_Explicit_Dereference (No_Location, + New_Occurrence_Of + (RTE (RE_Get_Current_Excep), + No_Location)))))); + + Mark_Rewrite_Insertion (Save); + Prepend (Save, Statements (Handler)); + + Obj_Decl := + Make_Object_Declaration + (Cloc, + Defining_Identifier => Cparm, + Object_Definition => + New_Occurrence_Of + (RTE (RE_Exception_Occurrence), Cloc)); + Set_No_Initialization (Obj_Decl, True); + + Rewrite (Handler, + Make_Exception_Handler (Hloc, + Choice_Parameter => Empty, + Exception_Choices => Exception_Choices (Handler), + + Statements => New_List ( + Make_Block_Statement (Hloc, + Declarations => New_List (Obj_Decl), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Hloc, + Statements => Statements (Handler)))))); + + -- Local raise statements can't occur, since exception + -- handlers with choice parameters are not allowed when + -- No_Exception_Propagation applies, so set attributes + -- accordingly. + + Set_Local_Raise_Statements (Handler, No_Elist); + Set_Local_Raise_Not_OK (Handler); + + Analyze_List + (Statements (Handler), Suppress => All_Checks); + end; + end if; + + -- The processing at this point is rather different for the JVM + -- case, so we completely separate the processing. + + -- For the VM case, we unconditionally call Update_Exception, + -- passing a call to the intrinsic Current_Target_Exception + -- (see JVM/.NET versions of Ada.Exceptions for details). + + if VM_Target /= No_VM then + declare + Arg : constant Node_Id := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Current_Target_Exception), Loc)); + begin + Prepend_Call_To_Handler + (RE_Update_Exception, New_List (Arg)); + end; + + -- For the normal case, we have to worry about the state of + -- abort deferral. Generally, we defer abort during runtime + -- handling of exceptions. When control is passed to the + -- handler, then in the normal case we undefer aborts. In + -- any case this entire handling is relevant only if aborts + -- are allowed! + + elsif Abort_Allowed then + + -- There are some special cases in which we do not do the + -- undefer. In particular a finalization (AT END) handler + -- wants to operate with aborts still deferred. + + -- We also suppress the call if this is the special handler + -- for Abort_Signal, since if we are aborting, we want to + -- keep aborts deferred (one abort is enough). + + -- If abort really needs to be deferred the expander must + -- add this call explicitly, see + -- Expand_N_Asynchronous_Select. + + Others_Choice := + Nkind (First (Exception_Choices (Handler))) = + N_Others_Choice; + + if (Others_Choice + or else Entity (First (Exception_Choices (Handler))) /= + Stand.Abort_Signal) + and then not + (Others_Choice + and then + All_Others (First (Exception_Choices (Handler)))) + and then Abort_Allowed + then + Prepend_Call_To_Handler (RE_Abort_Undefer); + end if; + end if; + end if; + end if; + + Handler := Next_Handler; + end loop Handler_Loop; + + -- If all handlers got removed, then remove the list. Note we cannot + -- reference HSS here, since expanding local handlers may have buried + -- the handlers in an inner block. + + if Is_Empty_List (Handlrs) then + Set_Exception_Handlers (Parent (Handlrs), No_List); + end if; + end Expand_Exception_Handlers; + + ------------------------------------ + -- Expand_N_Exception_Declaration -- + ------------------------------------ + + -- Generates: + -- exceptE : constant String := "A.B.EXCEP"; -- static data + -- except : exception_data := ( + -- Handled_By_Other => False, + -- Lang => 'A', + -- Name_Length => exceptE'Length, + -- Full_Name => exceptE'Address, + -- HTable_Ptr => null, + -- Import_Code => 0, + -- Raise_Hook => null, + -- ); + + -- (protecting test only needed if not at library level) + -- + -- exceptF : Boolean := True -- static data + -- if exceptF then + -- exceptF := False; + -- Register_Exception (except'Unchecked_Access); + -- end if; + + procedure Expand_N_Exception_Declaration (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Id : constant Entity_Id := Defining_Identifier (N); + L : List_Id := New_List; + Flag_Id : Entity_Id; + + Name_Exname : constant Name_Id := New_External_Name (Chars (Id), 'E'); + Exname : constant Node_Id := + Make_Defining_Identifier (Loc, Name_Exname); + + procedure Force_Static_Allocation_Of_Referenced_Objects + (Aggregate : Node_Id); + -- A specialized solution to one particular case of an ugly problem + -- + -- The given aggregate includes an Unchecked_Conversion as one of the + -- component values. The call to Analyze_And_Resolve below ends up + -- calling Exp_Ch4.Expand_N_Unchecked_Type_Conversion, which may decide + -- to introduce a (constant) temporary and then obtain the component + -- value by evaluating the temporary. + -- + -- In the case of an exception declared within a subprogram (or any + -- other dynamic scope), this is a bad transformation. The exception + -- object is marked as being Statically_Allocated but the temporary is + -- not. If the initial value of a Statically_Allocated declaration + -- references a dynamically allocated object, this prevents static + -- initialization of the object. + -- + -- We cope with this here by marking the temporary Statically_Allocated. + -- It might seem cleaner to generalize this utility and then use it to + -- enforce a rule that the entities referenced in the declaration of any + -- "hoisted" (i.e., Is_Statically_Allocated and not Is_Library_Level) + -- entity must also be either Library_Level or hoisted. It turns out + -- that this would be incompatible with the current treatment of an + -- object which is local to a subprogram, subject to an Export pragma, + -- not subject to an address clause, and whose declaration contains + -- references to other local (non-hoisted) objects (e.g., in the initial + -- value expression). + + --------------------------------------------------- + -- Force_Static_Allocation_Of_Referenced_Objects -- + --------------------------------------------------- + + procedure Force_Static_Allocation_Of_Referenced_Objects + (Aggregate : Node_Id) + is + function Fixup_Node (N : Node_Id) return Traverse_Result; + -- If the given node references a dynamically allocated object, then + -- correct the declaration of the object. + + ---------------- + -- Fixup_Node -- + ---------------- + + function Fixup_Node (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) in N_Has_Entity + and then Present (Entity (N)) + and then not Is_Library_Level_Entity (Entity (N)) + + -- Note: the following test is not needed but it seems cleaner + -- to do this test (this would be more important if procedure + -- Force_Static_Allocation_Of_Referenced_Objects recursively + -- traversed the declaration of an entity after marking it as + -- statically allocated). + + and then not Is_Statically_Allocated (Entity (N)) + then + Set_Is_Statically_Allocated (Entity (N)); + end if; + + return OK; + end Fixup_Node; + + procedure Fixup_Tree is new Traverse_Proc (Fixup_Node); + + -- Start of processing for Force_Static_Allocation_Of_Referenced_Objects + + begin + Fixup_Tree (Aggregate); + end Force_Static_Allocation_Of_Referenced_Objects; + + -- Start of processing for Expand_N_Exception_Declaration + + begin + -- There is no expansion needed when compiling for the JVM since the + -- JVM has a built-in exception mechanism. See cil/gnatlib/a-except.ads + -- for details. + + if VM_Target /= No_VM then + return; + end if; + + -- Definition of the external name: nam : constant String := "A.B.NAME"; + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Exname, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, + Strval => Fully_Qualified_Name_String (Id)))); + + Set_Is_Statically_Allocated (Exname); + + -- Create the aggregate list for type Standard.Exception_Type: + -- Handled_By_Other component: False + + Append_To (L, New_Occurrence_Of (Standard_False, Loc)); + + -- Lang component: 'A' + + Append_To (L, + Make_Character_Literal (Loc, + Chars => Name_uA, + Char_Literal_Value => UI_From_Int (Character'Pos ('A')))); + + -- Name_Length component: Nam'Length + + Append_To (L, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Exname, Loc), + Attribute_Name => Name_Length)); + + -- Full_Name component: Standard.A_Char!(Nam'Address) + + Append_To (L, Unchecked_Convert_To (Standard_A_Char, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Exname, Loc), + Attribute_Name => Name_Address))); + + -- HTable_Ptr component: null + + Append_To (L, Make_Null (Loc)); + + -- Import_Code component: 0 + + Append_To (L, Make_Integer_Literal (Loc, 0)); + + -- Raise_Hook component: null + + Append_To (L, Make_Null (Loc)); + + Set_Expression (N, Make_Aggregate (Loc, Expressions => L)); + Analyze_And_Resolve (Expression (N), Etype (Id)); + + Force_Static_Allocation_Of_Referenced_Objects (Expression (N)); + + -- Register_Exception (except'Unchecked_Access); + + if not No_Exception_Handlers_Set + and then not Restriction_Active (No_Exception_Registration) + then + L := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Register_Exception), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Id, Loc), + Attribute_Name => Name_Unrestricted_Access))))); + + Set_Register_Exception_Call (Id, First (L)); + + if not Is_Library_Level_Entity (Id) then + Flag_Id := Make_Defining_Identifier (Loc, + New_External_Name (Chars (Id), 'F')); + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Flag_Id, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc), + Expression => + New_Occurrence_Of (Standard_True, Loc))); + + Set_Is_Statically_Allocated (Flag_Id); + + Append_To (L, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Flag_Id, Loc), + Expression => New_Occurrence_Of (Standard_False, Loc))); + + Insert_After_And_Analyze (N, + Make_Implicit_If_Statement (N, + Condition => New_Occurrence_Of (Flag_Id, Loc), + Then_Statements => L)); + + else + Insert_List_After_And_Analyze (N, L); + end if; + end if; + end Expand_N_Exception_Declaration; + + --------------------------------------------- + -- Expand_N_Handled_Sequence_Of_Statements -- + --------------------------------------------- + + procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is + begin + -- Expand exception handlers + + if Present (Exception_Handlers (N)) + and then not Restriction_Active (No_Exception_Handlers) + then + Expand_Exception_Handlers (N); + end if; + + -- If local exceptions are being expanded, the previous call will + -- have rewritten the construct as a block and reanalyzed it. No + -- further expansion is needed. + + if Analyzed (N) then + return; + end if; + + -- Add clean up actions if required + + if Nkind (Parent (N)) /= N_Package_Body + and then Nkind (Parent (N)) /= N_Accept_Statement + and then Nkind (Parent (N)) /= N_Extended_Return_Statement + and then not Delay_Cleanups (Current_Scope) + then + Expand_Cleanup_Actions (Parent (N)); + else + Set_First_Real_Statement (N, First (Statements (N))); + end if; + end Expand_N_Handled_Sequence_Of_Statements; + + ------------------------------------- + -- Expand_N_Raise_Constraint_Error -- + ------------------------------------- + + procedure Expand_N_Raise_Constraint_Error (N : Node_Id) is + begin + -- We adjust the condition to deal with the C/Fortran boolean case. This + -- may well not be necessary, as all such conditions are generated by + -- the expander and probably are all standard boolean, but who knows + -- what strange optimization in future may require this adjustment! + + Adjust_Condition (Condition (N)); + + -- Now deal with possible local raise handling + + Possible_Local_Raise (N, Standard_Constraint_Error); + end Expand_N_Raise_Constraint_Error; + + ---------------------------------- + -- Expand_N_Raise_Program_Error -- + ---------------------------------- + + procedure Expand_N_Raise_Program_Error (N : Node_Id) is + begin + -- We adjust the condition to deal with the C/Fortran boolean case. This + -- may well not be necessary, as all such conditions are generated by + -- the expander and probably are all standard boolean, but who knows + -- what strange optimization in future may require this adjustment! + + Adjust_Condition (Condition (N)); + + -- Now deal with possible local raise handling + + Possible_Local_Raise (N, Standard_Program_Error); + end Expand_N_Raise_Program_Error; + + ------------------------------ + -- Expand_N_Raise_Statement -- + ------------------------------ + + procedure Expand_N_Raise_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ehand : Node_Id; + E : Entity_Id; + Str : String_Id; + H : Node_Id; + + begin + -- Processing for locally handled exception (exclude reraise case) + + if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then + if Debug_Flag_Dot_G + or else Restriction_Active (No_Exception_Propagation) + then + -- If we have a local handler, then note that this is potentially + -- able to be transformed into a goto statement. + + H := Find_Local_Handler (Entity (Name (N)), N); + + if Present (H) then + if Local_Raise_Statements (H) = No_Elist then + Set_Local_Raise_Statements (H, New_Elmt_List); + end if; + + -- Append the new entry if it is not there already. Sometimes + -- we have situations where due to reexpansion, the same node + -- is analyzed twice and would otherwise be added twice. + + Append_Unique_Elmt (N, Local_Raise_Statements (H)); + Set_Has_Local_Raise (H); + + -- If no local handler, then generate no propagation warning + + else + Warn_If_No_Propagation (N); + end if; + + end if; + end if; + + -- If a string expression is present, then the raise statement is + -- converted to a call: + -- Raise_Exception (exception-name'Identity, string); + -- and there is nothing else to do. + + if Present (Expression (N)) then + + -- Avoid passing exception-name'identity in runtimes in which this + -- argument is not used. This avoids generating undefined references + -- to these exceptions when compiling with no optimization + + if Configurable_Run_Time_On_Target + and then (Restriction_Active (No_Exception_Handlers) + or else + Restriction_Active (No_Exception_Propagation)) + then + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (RTE (RE_Null_Id), Loc), + Expression (N)))); + else + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Name (N), + Attribute_Name => Name_Identity), + Expression (N)))); + end if; + + Analyze (N); + return; + end if; + + -- Remaining processing is for the case where no string expression + -- is present. + + -- Don't expand a raise statement that does not come from source + -- if we have already had configurable run-time violations, since + -- most likely it will be junk cascaded nonsense. + + if Configurable_Run_Time_Violations > 0 + and then not Comes_From_Source (N) + then + return; + end if; + + -- Convert explicit raise of Program_Error, Constraint_Error, and + -- Storage_Error into the corresponding raise (in High_Integrity_Mode + -- all other raises will get normal expansion and be disallowed, + -- but this is also faster in all modes). + + if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then + if Entity (Name (N)) = Standard_Constraint_Error then + Rewrite (N, + Make_Raise_Constraint_Error (Loc, + Reason => CE_Explicit_Raise)); + Analyze (N); + return; + + elsif Entity (Name (N)) = Standard_Program_Error then + Rewrite (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Explicit_Raise)); + Analyze (N); + return; + + elsif Entity (Name (N)) = Standard_Storage_Error then + Rewrite (N, + Make_Raise_Storage_Error (Loc, + Reason => SE_Explicit_Raise)); + Analyze (N); + return; + end if; + end if; + + -- Case of name present, in this case we expand raise name to + + -- Raise_Exception (name'Identity, location_string); + + -- where location_string identifies the file/line of the raise + + if Present (Name (N)) then + declare + Id : Entity_Id := Entity (Name (N)); + + begin + Name_Len := 0; + Build_Location_String (Loc); + + -- If the exception is a renaming, use the exception that it + -- renames (which might be a predefined exception, e.g.). + + if Present (Renamed_Object (Id)) then + Id := Renamed_Object (Id); + end if; + + -- Build a C-compatible string in case of no exception handlers, + -- since this is what the last chance handler is expecting. + + if No_Exception_Handlers_Set then + + -- Generate an empty message if configuration pragma + -- Suppress_Exception_Locations is set for this unit. + + if Opt.Exception_Locations_Suppressed then + Name_Len := 1; + else + Name_Len := Name_Len + 1; + end if; + + Name_Buffer (Name_Len) := ASCII.NUL; + end if; + + if Opt.Exception_Locations_Suppressed then + Name_Len := 0; + end if; + + Str := String_From_Name_Buffer; + + -- For VMS exceptions, convert the raise into a call to + -- lib$stop so it will be handled by __gnat_error_handler. + + if Is_VMS_Exception (Id) then + declare + Excep_Image : String_Id; + Cond : Node_Id; + + begin + if Present (Interface_Name (Id)) then + Excep_Image := Strval (Interface_Name (Id)); + else + Get_Name_String (Chars (Id)); + Set_All_Upper_Case; + Excep_Image := String_From_Name_Buffer; + end if; + + if Exception_Code (Id) /= No_Uint then + Cond := + Make_Integer_Literal (Loc, Exception_Code (Id)); + else + Cond := + Unchecked_Convert_To (Standard_Integer, + Make_Function_Call (Loc, + Name => New_Occurrence_Of + (RTE (RE_Import_Value), Loc), + Parameter_Associations => New_List + (Make_String_Literal (Loc, + Strval => Excep_Image)))); + end if; + + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Lib_Stop), Loc), + Parameter_Associations => New_List (Cond))); + Analyze_And_Resolve (Cond, Standard_Integer); + end; + + -- Not VMS exception case, convert raise to call to the + -- Raise_Exception routine. + + else + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Name (N), + Attribute_Name => Name_Identity), + Make_String_Literal (Loc, + Strval => Str)))); + end if; + end; + + -- Case of no name present (reraise). We rewrite the raise to: + + -- Reraise_Occurrence_Always (EO); + + -- where EO is the current exception occurrence. If the current handler + -- does not have a choice parameter specification, then we provide one. + + else + -- Find innermost enclosing exception handler (there must be one, + -- since the semantics has already verified that this raise statement + -- is valid, and a raise with no arguments is only permitted in the + -- context of an exception handler. + + Ehand := Parent (N); + while Nkind (Ehand) /= N_Exception_Handler loop + Ehand := Parent (Ehand); + end loop; + + -- Make exception choice parameter if none present. Note that we do + -- not need to put the entity on the entity chain, since no one will + -- be referencing this entity by normal visibility methods. + + if No (Choice_Parameter (Ehand)) then + E := Make_Temporary (Loc, 'E'); + Set_Choice_Parameter (Ehand, E); + Set_Ekind (E, E_Variable); + Set_Etype (E, RTE (RE_Exception_Occurrence)); + Set_Scope (E, Current_Scope); + end if; + + -- Now rewrite the raise as a call to Reraise. A special case arises + -- if this raise statement occurs in the context of a handler for + -- all others (i.e. an at end handler). in this case we avoid + -- the call to defer abort, cleanup routines are expected to be + -- called in this case with aborts deferred. + + declare + Ech : constant Node_Id := First (Exception_Choices (Ehand)); + Ent : Entity_Id; + + begin + if Nkind (Ech) = N_Others_Choice + and then All_Others (Ech) + then + Ent := RTE (RE_Reraise_Occurrence_No_Defer); + else + Ent := RTE (RE_Reraise_Occurrence_Always); + end if; + + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Ent, Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Choice_Parameter (Ehand), Loc)))); + end; + end if; + + Analyze (N); + end Expand_N_Raise_Statement; + + ---------------------------------- + -- Expand_N_Raise_Storage_Error -- + ---------------------------------- + + procedure Expand_N_Raise_Storage_Error (N : Node_Id) is + begin + -- We adjust the condition to deal with the C/Fortran boolean case. This + -- may well not be necessary, as all such conditions are generated by + -- the expander and probably are all standard boolean, but who knows + -- what strange optimization in future may require this adjustment! + + Adjust_Condition (Condition (N)); + + -- Now deal with possible local raise handling + + Possible_Local_Raise (N, Standard_Storage_Error); + end Expand_N_Raise_Storage_Error; + + -------------------------- + -- Possible_Local_Raise -- + -------------------------- + + procedure Possible_Local_Raise (N : Node_Id; E : Entity_Id) is + begin + -- Nothing to do if local raise optimization not active + + if not Debug_Flag_Dot_G + and then not Restriction_Active (No_Exception_Propagation) + then + return; + end if; + + -- Nothing to do if original node was an explicit raise, because in + -- that case, we already generated the required warning for the raise. + + if Nkind (Original_Node (N)) = N_Raise_Statement then + return; + end if; + + -- Otherwise see if we have a local handler for the exception + + declare + H : constant Node_Id := Find_Local_Handler (E, N); + + begin + -- If so, mark that it has a local raise + + if Present (H) then + Set_Has_Local_Raise (H, True); + + -- Otherwise, if the No_Exception_Propagation restriction is active + -- and the warning is enabled, generate the appropriate warnings. + + elsif Warn_On_Non_Local_Exception + and then Restriction_Active (No_Exception_Propagation) + then + Warn_No_Exception_Propagation_Active (N); + + if Configurable_Run_Time_Mode then + Error_Msg_NE + ("\?& may call Last_Chance_Handler", N, E); + else + Error_Msg_NE + ("\?& may result in unhandled exception", N, E); + end if; + end if; + end; + end Possible_Local_Raise; + + ------------------------------ + -- Expand_N_Subprogram_Info -- + ------------------------------ + + procedure Expand_N_Subprogram_Info (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + begin + -- For now, we replace an Expand_N_Subprogram_Info node with an + -- attribute reference that gives the address of the procedure. + -- This is because gigi does not yet recognize this node, and + -- for the initial targets, this is the right value anyway. + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => Identifier (N), + Attribute_Name => Name_Code_Address)); + + Analyze_And_Resolve (N, RTE (RE_Code_Loc)); + end Expand_N_Subprogram_Info; + + ------------------------ + -- Find_Local_Handler -- + ------------------------ + + function Find_Local_Handler + (Ename : Entity_Id; + Nod : Node_Id) return Node_Id + is + N : Node_Id; + P : Node_Id; + H : Node_Id; + C : Node_Id; + + SSE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); + -- This is used to test for wrapped actions below + + ERaise : Entity_Id; + EHandle : Entity_Id; + -- The entity Id's for the exception we are raising and handling, using + -- the renamed exception if a Renamed_Entity is present. + + begin + -- Never any local handler if all handlers removed + + if Debug_Flag_Dot_X then + return Empty; + end if; + + -- Get the exception we are raising, allowing for renaming + + ERaise := Get_Renamed_Entity (Ename); + + -- We need to check if the node we are looking at is contained in + -- + + -- Loop to search up the tree + + N := Nod; + loop + P := Parent (N); + + -- If we get to the top of the tree, or to a subprogram, task, entry, + -- protected body, or accept statement without having found a + -- matching handler, then there is no local handler. + + if No (P) + or else Nkind (P) = N_Subprogram_Body + or else Nkind (P) = N_Task_Body + or else Nkind (P) = N_Protected_Body + or else Nkind (P) = N_Entry_Body + or else Nkind (P) = N_Accept_Statement + then + return Empty; + + -- Test for handled sequence of statements with at least one + -- exception handler which might be the one we are looking for. + + elsif Nkind (P) = N_Handled_Sequence_Of_Statements + and then Present (Exception_Handlers (P)) + then + -- Before we proceed we need to check if the node N is covered + -- by the statement part of P rather than one of its exception + -- handlers (an exception handler obviously does not cover its + -- own statements). + + -- This test is more delicate than might be thought. It is not + -- just a matter of checking the Statements (P), because the node + -- might be waiting to be wrapped in a transient scope, in which + -- case it will end up in the block statements, even though it + -- is not there now. + + if Is_List_Member (N) + and then (List_Containing (N) = Statements (P) + or else + List_Containing (N) = SSE.Actions_To_Be_Wrapped_Before + or else + List_Containing (N) = SSE.Actions_To_Be_Wrapped_After) + then + -- Loop through exception handlers + + H := First (Exception_Handlers (P)); + while Present (H) loop + + -- Loop through choices in one handler + + C := First (Exception_Choices (H)); + while Present (C) loop + + -- Deal with others case + + if Nkind (C) = N_Others_Choice then + + -- Matching others handler, but we need to ensure + -- there is no choice parameter. If there is, then we + -- don't have a local handler after all (since we do + -- not allow choice parameters for local handlers). + + if No (Choice_Parameter (H)) then + return H; + else + return Empty; + end if; + + -- If not others must be entity name + + elsif Nkind (C) /= N_Others_Choice then + pragma Assert (Is_Entity_Name (C)); + pragma Assert (Present (Entity (C))); + + -- Get exception being handled, dealing with renaming + + EHandle := Get_Renamed_Entity (Entity (C)); + + -- If match, then check choice parameter + + if ERaise = EHandle then + if No (Choice_Parameter (H)) then + return H; + else + return Empty; + end if; + end if; + end if; + + Next (C); + end loop; + + Next (H); + end loop; + end if; + end if; + + N := P; + end loop; + end Find_Local_Handler; + + --------------------------------- + -- Get_Local_Raise_Call_Entity -- + --------------------------------- + + -- Note: this is primary provided for use by the back end in generating + -- calls to Local_Raise. But it would be too late in the back end to call + -- RTE if this actually caused a load/analyze of the unit. So what we do + -- is to ensure there is a dummy call to this function during front end + -- processing so that the unit gets loaded then, and not later. + + Local_Raise_Call_Entity : Entity_Id; + Local_Raise_Call_Entity_Set : Boolean := False; + + function Get_Local_Raise_Call_Entity return Entity_Id is + begin + if not Local_Raise_Call_Entity_Set then + Local_Raise_Call_Entity_Set := True; + + if RTE_Available (RE_Local_Raise) then + Local_Raise_Call_Entity := RTE (RE_Local_Raise); + else + Local_Raise_Call_Entity := Empty; + end if; + end if; + + return Local_Raise_Call_Entity; + end Get_Local_Raise_Call_Entity; + + ----------------------------- + -- Get_RT_Exception_Entity -- + ----------------------------- + + function Get_RT_Exception_Entity (R : RT_Exception_Code) return Entity_Id is + begin + case R is + when RT_CE_Exceptions => return Standard_Constraint_Error; + when RT_PE_Exceptions => return Standard_Program_Error; + when RT_SE_Exceptions => return Standard_Storage_Error; + end case; + end Get_RT_Exception_Entity; + + ---------------------- + -- Is_Non_Ada_Error -- + ---------------------- + + function Is_Non_Ada_Error (E : Entity_Id) return Boolean is + begin + if not OpenVMS_On_Target then + return False; + end if; + + Get_Name_String (Chars (E)); + + -- Note: it is a little irregular for the body of exp_ch11 to know + -- the details of the encoding scheme for names, but on the other + -- hand, gigi knows them, and this is for gigi's benefit anyway! + + if Name_Buffer (1 .. 30) /= "system__aux_dec__non_ada_error" then + return False; + end if; + + return True; + end Is_Non_Ada_Error; + + ---------------------------- + -- Warn_If_No_Propagation -- + ---------------------------- + + procedure Warn_If_No_Propagation (N : Node_Id) is + begin + if Restriction_Check_Required (No_Exception_Propagation) + and then Warn_On_Non_Local_Exception + then + Warn_No_Exception_Propagation_Active (N); + + if Configurable_Run_Time_Mode then + Error_Msg_N + ("\?Last_Chance_Handler will be called on exception", N); + else + Error_Msg_N + ("\?execution may raise unhandled exception", N); + end if; + end if; + end Warn_If_No_Propagation; + + ------------------------------------------ + -- Warn_No_Exception_Propagation_Active -- + ------------------------------------------ + + procedure Warn_No_Exception_Propagation_Active (N : Node_Id) is + begin + Error_Msg_N + ("?pragma Restrictions (No_Exception_Propagation) in effect", N); + end Warn_No_Exception_Propagation_Active; + +end Exp_Ch11; diff --git a/gcc/ada/exp_ch11.ads b/gcc/ada/exp_ch11.ads new file mode 100644 index 000000000..8ba25ad73 --- /dev/null +++ b/gcc/ada/exp_ch11.ads @@ -0,0 +1,95 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 1 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. -- +-- -- +-- You should have received a copy of the GNU General Public License along -- +-- with this program; see file COPYING3. If not see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for chapter 11 constructs + +with Types; use Types; + +package Exp_Ch11 is + procedure Expand_N_Exception_Declaration (N : Node_Id); + procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id); + procedure Expand_N_Raise_Constraint_Error (N : Node_Id); + procedure Expand_N_Raise_Program_Error (N : Node_Id); + procedure Expand_N_Raise_Statement (N : Node_Id); + procedure Expand_N_Raise_Storage_Error (N : Node_Id); + procedure Expand_N_Subprogram_Info (N : Node_Id); + + -- Data structures for gathering information to build exception tables + -- See runtime routine Ada.Exceptions for full details on the format and + -- content of these tables. + + procedure Expand_At_End_Handler (HSS : Node_Id; Block : Node_Id); + -- Given a handled statement sequence, HSS, for which the At_End_Proc + -- field is set, and which currently has no exception handlers, this + -- procedure expands the special exception handler required. + -- This procedure also create a new scope for the given Block, if + -- Block is not Empty. + + procedure Expand_Exception_Handlers (HSS : Node_Id); + -- This procedure expands exception handlers, and is called as part + -- of the processing for Expand_N_Handled_Sequence_Of_Statements and + -- is also called from Expand_At_End_Handler. N is the handled sequence + -- of statements that has the exception handler(s) to be expanded. This + -- is also called to expand the special exception handler built for + -- accept bodies (see Exp_Ch9.Build_Accept_Body). + + function Find_Local_Handler + (Ename : Entity_Id; + Nod : Node_Id) return Node_Id; + -- This function searches for a local exception handler that will handle + -- the exception named by Ename. If such a local hander exists, then the + -- corresponding N_Exception_Handler is returned. If no such handler is + -- found then Empty is returned. In order to match and return True, the + -- handler may not have a choice parameter specification. Nod is the raise + -- node that references the handler. + + function Get_Local_Raise_Call_Entity return Entity_Id; + -- This function is provided for use by the back end in conjunction with + -- generation of Local_Raise calls when an exception raise is converted to + -- a goto statement. If Local_Raise is defined, its entity is returned, + -- if not, Empty is returned (in which case the call is silently skipped). + + function Get_RT_Exception_Entity (R : RT_Exception_Code) return Entity_Id; + -- This function is provided for use by the back end in conjunction with + -- generation of Local_Raise calls when an exception raise is converted to + -- a goto statement. The argument is the reason code which would be used + -- to determine which Rcheck_nn procedure to call. The returned result is + -- the exception entity to be passed to Local_Raise. + + function Is_Non_Ada_Error (E : Entity_Id) return Boolean; + -- This function is provided for Gigi use. It returns True if operating on + -- VMS, and the argument E is the entity for System.Aux_Dec.Non_Ada_Error. + -- This is used to generate the special matching code for this exception. + + procedure Possible_Local_Raise (N : Node_Id; E : Entity_Id); + -- This procedure is called whenever node N might cause the back end + -- to generate a local raise for a local Constraint/Program/Storage_Error + -- exception. It deals with generating a warning if there is no local + -- handler (and restriction No_Exception_Propagation is set), or if there + -- is a local handler marking that it has a local raise. E is the entity + -- of the corresponding exception. + +end Exp_Ch11; diff --git a/gcc/ada/exp_ch12.adb b/gcc/ada/exp_ch12.adb new file mode 100644 index 000000000..5ff2ee3af --- /dev/null +++ b/gcc/ada/exp_ch12.adb @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 1 2 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Einfo; use Einfo; +with Exp_Util; use Exp_Util; +with Nmake; use Nmake; +with Sinfo; use Sinfo; +with Stand; use Stand; +with Tbuild; use Tbuild; + +package body Exp_Ch12 is + + ------------------------------------ + -- Expand_N_Generic_Instantiation -- + ------------------------------------ + + -- If elaboration entity is defined and this is not an outer level entity, + -- we need to generate a check for it here. + + procedure Expand_N_Generic_Instantiation (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ent : constant Entity_Id := Entity (Name (N)); + + begin + if Etype (Name (N)) = Any_Type then + return; + end if; + + if Present (Elaboration_Entity (Ent)) + and then not Is_Compilation_Unit (Ent) + and then not Elaboration_Checks_Suppressed (Ent) + then + Insert_Action (Instance_Spec (N), + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + New_Occurrence_Of (Elaboration_Entity (Ent), Loc)), + Reason => PE_Access_Before_Elaboration)); + end if; + end Expand_N_Generic_Instantiation; + +end Exp_Ch12; diff --git a/gcc/ada/exp_ch12.ads b/gcc/ada/exp_ch12.ads new file mode 100644 index 000000000..619f0312d --- /dev/null +++ b/gcc/ada/exp_ch12.ads @@ -0,0 +1,32 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 1 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for chapter 12 constructs + +with Types; use Types; + +package Exp_Ch12 is + procedure Expand_N_Generic_Instantiation (N : Node_Id); +end Exp_Ch12; diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb new file mode 100644 index 000000000..f3de66c6a --- /dev/null +++ b/gcc/ada/exp_ch13.adb @@ -0,0 +1,498 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 1 3 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Einfo; use Einfo; +with Exp_Ch3; use Exp_Ch3; +with Exp_Ch6; use Exp_Ch6; +with Exp_Imgv; use Exp_Imgv; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Ch7; use Sem_Ch7; +with Sem_Ch8; use Sem_Ch8; +with Sem_Eval; use Sem_Eval; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Tbuild; use Tbuild; +with Uintp; use Uintp; +with Validsw; use Validsw; + +package body Exp_Ch13 is + + ------------------------------------------ + -- Expand_N_Attribute_Definition_Clause -- + ------------------------------------------ + + -- Expansion action depends on attribute involved + + procedure Expand_N_Attribute_Definition_Clause (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Exp : constant Node_Id := Expression (N); + Ent : Entity_Id; + V : Node_Id; + + begin + Ent := Entity (Name (N)); + + if Is_Type (Ent) then + Ent := Underlying_Type (Ent); + end if; + + case Get_Attribute_Id (Chars (N)) is + + ------------- + -- Address -- + ------------- + + when Attribute_Address => + + -- If there is an initialization which did not come from the + -- source program, then it is an artifact of our expansion, and we + -- suppress it. The case we are most concerned about here is the + -- initialization of a packed array to all false, which seems + -- inappropriate for variable to which an address clause is + -- applied. The expression may itself have been rewritten if the + -- type is packed array, so we need to examine whether the + -- original node is in the source. An exception though is the case + -- of an access variable which is default initialized to null, and + -- such initialization is retained. + + -- Furthermore, if the initialization is the equivalent aggregate + -- of the type initialization procedure, it replaces an implicit + -- call to the init proc, and must be respected. Note that for + -- packed types we do not build equivalent aggregates. + + -- Also, if Init_Or_Norm_Scalars applies, then we need to retain + -- any default initialization for objects of scalar types and + -- types with scalar components. Normally a composite type will + -- have an init_proc in the presence of Init_Or_Norm_Scalars, + -- so when that flag is set we have just have to do a test for + -- scalar and string types (the predefined string types such as + -- String and Wide_String don't have an init_proc). + + declare + Decl : constant Node_Id := Declaration_Node (Ent); + Typ : constant Entity_Id := Etype (Ent); + + begin + if Nkind (Decl) = N_Object_Declaration + and then Present (Expression (Decl)) + and then Nkind (Expression (Decl)) /= N_Null + and then + not Comes_From_Source (Original_Node (Expression (Decl))) + then + if Present (Base_Init_Proc (Typ)) + and then + Present (Static_Initialization (Base_Init_Proc (Typ))) + then + null; + + elsif Init_Or_Norm_Scalars + and then + (Is_Scalar_Type (Typ) or else Is_String_Type (Typ)) + then + null; + + else + Set_Expression (Decl, Empty); + end if; + + -- An object declaration to which an address clause applies + -- has a delayed freeze, but the address expression itself + -- must be elaborated at the point it appears. If the object + -- is controlled, additional checks apply elsewhere. + + elsif Nkind (Decl) = N_Object_Declaration + and then not Needs_Constant_Address (Decl, Typ) + then + Remove_Side_Effects (Exp); + end if; + end; + + --------------- + -- Alignment -- + --------------- + + when Attribute_Alignment => + + -- As required by Gigi, we guarantee that the operand is an + -- integer literal (this simplifies things in Gigi). + + if Nkind (Exp) /= N_Integer_Literal then + Rewrite + (Exp, Make_Integer_Literal (Loc, Expr_Value (Exp))); + end if; + + ------------------ + -- Storage_Size -- + ------------------ + + when Attribute_Storage_Size => + + -- If the type is a task type, then assign the value of the + -- storage size to the Size variable associated with the task. + -- task_typeZ := expression + + if Ekind (Ent) = E_Task_Type then + Insert_Action (N, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Storage_Size_Variable (Ent), Loc), + Expression => + Convert_To (RTE (RE_Size_Type), Expression (N)))); + + -- For Storage_Size for an access type, create a variable to hold + -- the value of the specified size with name typeV and expand an + -- assignment statement to initialize this value. + + elsif Is_Access_Type (Ent) then + + -- We don't need the variable for a storage size of zero + + if not No_Pool_Assigned (Ent) then + V := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Ent), 'V')); + + -- Insert the declaration of the object + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => V, + Object_Definition => + New_Reference_To (RTE (RE_Storage_Offset), Loc), + Expression => + Convert_To (RTE (RE_Storage_Offset), Expression (N)))); + + Set_Storage_Size_Variable (Ent, Entity_Id (V)); + end if; + end if; + + -- Other attributes require no expansion + + when others => + null; + + end case; + end Expand_N_Attribute_Definition_Clause; + + ---------------------------- + -- Expand_N_Freeze_Entity -- + ---------------------------- + + procedure Expand_N_Freeze_Entity (N : Node_Id) is + E : constant Entity_Id := Entity (N); + E_Scope : Entity_Id; + S : Entity_Id; + In_Other_Scope : Boolean; + In_Outer_Scope : Boolean; + Decl : Node_Id; + Delete : Boolean := False; + + begin + -- If there are delayed aspect specifications, we insert them just + -- before the freeze node. They are already analyzed so we don't need + -- to reanalyze them (they were analyzed before the type was frozen), + -- but we want them in the tree for the back end, and so that the + -- listing from sprint is clearer on where these occur logically. + + if Has_Delayed_Aspects (E) then + declare + Aitem : Node_Id; + Ritem : Node_Id; + + begin + Ritem := First_Rep_Item (E); + while Present (Ritem) loop + if Nkind (Ritem) = N_Aspect_Specification then + Aitem := Aspect_Rep_Item (Ritem); + pragma Assert (Is_Delayed_Aspect (Aitem)); + Insert_Before (N, Aitem); + end if; + + Next_Rep_Item (Ritem); + end loop; + end; + end if; + + -- Processing for objects with address clauses + + if Is_Object (E) and then Present (Address_Clause (E)) then + Apply_Address_Clause_Check (E, N); + return; + + -- Only other items requiring any front end action are types and + -- subprograms. + + elsif not Is_Type (E) and then not Is_Subprogram (E) then + return; + end if; + + -- Here E is a type or a subprogram + + E_Scope := Scope (E); + + -- This is an error protection against previous errors + + if No (E_Scope) then + return; + end if; + + -- Remember that we are processing a freezing entity and its freezing + -- nodes. This flag (non-zero = set) is used to avoid the need of + -- climbing through the tree while processing the freezing actions (ie. + -- to avoid generating spurious warnings or to avoid killing constant + -- indications while processing the code associated with freezing + -- actions). We use a counter to deal with nesting. + + Inside_Freezing_Actions := Inside_Freezing_Actions + 1; + + -- If we are freezing entities defined in protected types, they belong + -- in the enclosing scope, given that the original type has been + -- expanded away. The same is true for entities in task types, in + -- particular the parameter records of entries (Entities in bodies are + -- all frozen within the body). If we are in the task body, this is a + -- proper scope. If we are within a subprogram body, the proper scope + -- is the corresponding spec. This may happen for itypes generated in + -- the bodies of protected operations. + + if Ekind (E_Scope) = E_Protected_Type + or else (Ekind (E_Scope) = E_Task_Type + and then not Has_Completion (E_Scope)) + then + E_Scope := Scope (E_Scope); + + elsif Ekind (E_Scope) = E_Subprogram_Body then + E_Scope := Corresponding_Spec (Unit_Declaration_Node (E_Scope)); + end if; + + S := Current_Scope; + while S /= Standard_Standard and then S /= E_Scope loop + S := Scope (S); + end loop; + + In_Other_Scope := not (S = E_Scope); + In_Outer_Scope := (not In_Other_Scope) and then (S /= Current_Scope); + + -- If the entity being frozen is defined in a scope that is not + -- currently on the scope stack, we must establish the proper + -- visibility before freezing the entity and related subprograms. + + if In_Other_Scope then + Push_Scope (E_Scope); + Install_Visible_Declarations (E_Scope); + + if Is_Package_Or_Generic_Package (E_Scope) or else + Is_Protected_Type (E_Scope) or else + Is_Task_Type (E_Scope) + then + Install_Private_Declarations (E_Scope); + end if; + + -- If the entity is in an outer scope, then that scope needs to + -- temporarily become the current scope so that operations created + -- during type freezing will be declared in the right scope and + -- can properly override any corresponding inherited operations. + + elsif In_Outer_Scope then + Push_Scope (E_Scope); + end if; + + -- If type, freeze the type + + if Is_Type (E) then + Delete := Freeze_Type (N); + + -- And for enumeration type, build the enumeration tables + + if Is_Enumeration_Type (E) then + Build_Enumeration_Image_Tables (E, N); + end if; + + -- If subprogram, freeze the subprogram + + elsif Is_Subprogram (E) then + Freeze_Subprogram (N); + + -- Ada 2005 (AI-251): Remove the freezing node associated with the + -- entities internally used by the frontend to register primitives + -- covering abstract interfaces. The call to Freeze_Subprogram has + -- already expanded the code that fills the corresponding entry in + -- its secondary dispatch table and therefore the code generator + -- has nothing else to do with this freezing node. + + Delete := Present (Interface_Alias (E)); + end if; + + -- Analyze actions generated by freezing. The init_proc contains source + -- expressions that may raise Constraint_Error, and the assignment + -- procedure for complex types needs checks on individual component + -- assignments, but all other freezing actions should be compiled with + -- all checks off. + + if Present (Actions (N)) then + Decl := First (Actions (N)); + while Present (Decl) loop + if Nkind (Decl) = N_Subprogram_Body + and then (Is_Init_Proc (Defining_Entity (Decl)) + or else + Chars (Defining_Entity (Decl)) = Name_uAssign) + then + Analyze (Decl); + + -- A subprogram body created for a renaming_as_body completes + -- a previous declaration, which may be in a different scope. + -- Establish the proper scope before analysis. + + elsif Nkind (Decl) = N_Subprogram_Body + and then Present (Corresponding_Spec (Decl)) + and then Scope (Corresponding_Spec (Decl)) /= Current_Scope + then + Push_Scope (Scope (Corresponding_Spec (Decl))); + Analyze (Decl, Suppress => All_Checks); + Pop_Scope; + + -- We treat generated equality specially, if validity checks are + -- enabled, in order to detect components default-initialized + -- with invalid values. + + elsif Nkind (Decl) = N_Subprogram_Body + and then Chars (Defining_Entity (Decl)) = Name_Op_Eq + and then Validity_Checks_On + and then Initialize_Scalars + then + declare + Save_Force : constant Boolean := Force_Validity_Checks; + begin + Force_Validity_Checks := True; + Analyze (Decl); + Force_Validity_Checks := Save_Force; + end; + + else + Analyze (Decl, Suppress => All_Checks); + end if; + + Next (Decl); + end loop; + end if; + + -- If we are to delete this N_Freeze_Entity, do so by rewriting so that + -- a loop on all nodes being inserted will work propertly. + + if Delete then + Rewrite (N, Make_Null_Statement (Sloc (N))); + end if; + + -- Pop scope if we installed one for the analysis + + if In_Other_Scope then + if Ekind (Current_Scope) = E_Package then + End_Package_Scope (E_Scope); + else + End_Scope; + end if; + + elsif In_Outer_Scope then + Pop_Scope; + end if; + + -- Restore previous value of the nesting-level counter that records + -- whether we are inside a (possibly nested) call to this procedure. + + Inside_Freezing_Actions := Inside_Freezing_Actions - 1; + end Expand_N_Freeze_Entity; + + ------------------------------------------- + -- Expand_N_Record_Representation_Clause -- + ------------------------------------------- + + -- The only expansion required is for the case of a mod clause present, + -- which is removed, and translated into an alignment representation + -- clause inserted immediately after the record rep clause with any + -- initial pragmas inserted at the start of the component clause list. + + procedure Expand_N_Record_Representation_Clause (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Rectype : constant Entity_Id := Entity (Identifier (N)); + Mod_Val : Uint; + Citems : List_Id; + Repitem : Node_Id; + AtM_Nod : Node_Id; + + begin + if Present (Mod_Clause (N)) and then not Ignore_Rep_Clauses then + Mod_Val := Expr_Value (Expression (Mod_Clause (N))); + Citems := Pragmas_Before (Mod_Clause (N)); + + if Present (Citems) then + Append_List_To (Citems, Component_Clauses (N)); + Set_Component_Clauses (N, Citems); + end if; + + AtM_Nod := + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (Base_Type (Rectype), Loc), + Chars => Name_Alignment, + Expression => Make_Integer_Literal (Loc, Mod_Val)); + + Set_From_At_Mod (AtM_Nod); + Insert_After (N, AtM_Nod); + Set_Mod_Clause (N, Empty); + end if; + + -- If the record representation clause has no components, then + -- completely remove it. Note that we also have to remove + -- ourself from the Rep Item list. + + if Is_Empty_List (Component_Clauses (N)) then + if First_Rep_Item (Rectype) = N then + Set_First_Rep_Item (Rectype, Next_Rep_Item (N)); + else + Repitem := First_Rep_Item (Rectype); + while Present (Next_Rep_Item (Repitem)) loop + if Next_Rep_Item (Repitem) = N then + Set_Next_Rep_Item (Repitem, Next_Rep_Item (N)); + exit; + end if; + + Next_Rep_Item (Repitem); + end loop; + end if; + + Rewrite (N, + Make_Null_Statement (Loc)); + end if; + end Expand_N_Record_Representation_Clause; + +end Exp_Ch13; diff --git a/gcc/ada/exp_ch13.ads b/gcc/ada/exp_ch13.ads new file mode 100644 index 000000000..4090d8ac8 --- /dev/null +++ b/gcc/ada/exp_ch13.ads @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 1 3 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for chapter 13 constructs + +with Types; use Types; + +package Exp_Ch13 is + + procedure Expand_N_Attribute_Definition_Clause (N : Node_Id); + procedure Expand_N_Freeze_Entity (N : Node_Id); + procedure Expand_N_Record_Representation_Clause (N : Node_Id); + +end Exp_Ch13; diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb new file mode 100644 index 000000000..e0be4042f --- /dev/null +++ b/gcc/ada/exp_ch2.adb @@ -0,0 +1,744 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 2 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Smem; use Exp_Smem; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Exp_VFpt; use Exp_VFpt; +with Namet; use Namet; +with Nmake; use Nmake; +with Opt; use Opt; +with Output; use Output; +with Sem; use Sem; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +package body Exp_Ch2 is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Expand_Current_Value (N : Node_Id); + -- N is a node for a variable whose Current_Value field is set. If N is + -- node is for a discrete type, replaces node with a copy of the referenced + -- value. This provides a limited form of value propagation for variables + -- which are initialized or assigned not been further modified at the time + -- of reference. The call has no effect if the Current_Value refers to a + -- conditional with condition other than equality. + + procedure Expand_Discriminant (N : Node_Id); + -- An occurrence of a discriminant within a discriminated type is replaced + -- with the corresponding discriminal, that is to say the formal parameter + -- of the initialization procedure for the type that is associated with + -- that particular discriminant. This replacement is not performed for + -- discriminants of records that appear in constraints of component of the + -- record, because Gigi uses the discriminant name to retrieve its value. + -- In the other hand, it has to be performed for default expressions of + -- components because they are used in the record init procedure. See Einfo + -- for more details, and Exp_Ch3, Exp_Ch9 for examples of use. For + -- discriminants of tasks and protected types, the transformation is more + -- complex when it occurs within a default expression for an entry or + -- protected operation. The corresponding default_expression_function has + -- an additional parameter which is the target of an entry call, and the + -- discriminant of the task must be replaced with a reference to the + -- discriminant of that formal parameter. + + procedure Expand_Entity_Reference (N : Node_Id); + -- Common processing for expansion of identifiers and expanded names + -- Dispatches to specific expansion procedures. + + procedure Expand_Entry_Index_Parameter (N : Node_Id); + -- A reference to the identifier in the entry index specification of an + -- entry body is modified to a reference to a constant definition equal to + -- the index of the entry family member being called. This constant is + -- calculated as part of the elaboration of the expanded code for the body, + -- and is calculated from the object-wide entry index returned by Next_ + -- Entry_Call. + + procedure Expand_Entry_Parameter (N : Node_Id); + -- A reference to an entry parameter is modified to be a reference to the + -- corresponding component of the entry parameter record that is passed by + -- the runtime to the accept body procedure. + + procedure Expand_Formal (N : Node_Id); + -- A reference to a formal parameter of a protected subprogram is expanded + -- into the corresponding formal of the unprotected procedure used to + -- represent the operation within the protected object. In other cases + -- Expand_Formal is a no-op. + + procedure Expand_Protected_Component (N : Node_Id); + -- A reference to a private component of a protected type is expanded into + -- a reference to the corresponding prival in the current protected entry + -- or subprogram. + + procedure Expand_Renaming (N : Node_Id); + -- For renamings, just replace the identifier by the corresponding + -- named expression. Note that this has been evaluated (see routine + -- Exp_Ch8.Expand_N_Object_Renaming.Evaluate_Name) so this gives + -- the correct renaming semantics. + + -------------------------- + -- Expand_Current_Value -- + -------------------------- + + procedure Expand_Current_Value (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + E : constant Entity_Id := Entity (N); + CV : constant Node_Id := Current_Value (E); + T : constant Entity_Id := Etype (N); + Val : Node_Id; + Op : Node_Kind; + + -- Start of processing for Expand_Current_Value + + begin + if True + + -- No replacement if value raises constraint error + + and then Nkind (CV) /= N_Raise_Constraint_Error + + -- Do this only for discrete types + + and then Is_Discrete_Type (T) + + -- Do not replace biased types, since it is problematic to + -- consistently generate a sensible constant value in this case. + + and then not Has_Biased_Representation (T) + + -- Do not replace lvalues + + and then not May_Be_Lvalue (N) + + -- Check that entity is suitable for replacement + + and then OK_To_Do_Constant_Replacement (E) + + -- Do not replace occurrences in pragmas (where names typically + -- appear not as values, but as simply names. If there are cases + -- where values are required, it is only a very minor efficiency + -- issue that they do not get replaced when they could be). + + and then Nkind (Parent (N)) /= N_Pragma_Argument_Association + + -- Do not replace the prefixes of attribute references, since this + -- causes trouble with cases like 4'Size. Also for Name_Asm_Input and + -- Name_Asm_Output, don't do replacement anywhere, since we can have + -- lvalue references in the arguments. + + and then not (Nkind (Parent (N)) = N_Attribute_Reference + and then + (Attribute_Name (Parent (N)) = Name_Asm_Input + or else + Attribute_Name (Parent (N)) = Name_Asm_Output + or else + Prefix (Parent (N)) = N)) + + then + -- Case of Current_Value is a compile time known value + + if Nkind (CV) in N_Subexpr then + Val := CV; + + -- Case of Current_Value is a conditional expression reference + + else + Get_Current_Value_Condition (N, Op, Val); + + if Op /= N_Op_Eq then + return; + end if; + end if; + + -- If constant value is an occurrence of an enumeration literal, + -- then we just make another occurrence of the same literal. + + if Is_Entity_Name (Val) + and then Ekind (Entity (Val)) = E_Enumeration_Literal + then + Rewrite (N, + Unchecked_Convert_To (T, + New_Occurrence_Of (Entity (Val), Loc))); + + -- If constant is of an integer type, just make an appropriately + -- integer literal, which will get the proper type. + + elsif Is_Integer_Type (T) then + Rewrite (N, + Make_Integer_Literal (Loc, + Intval => Expr_Rep_Value (Val))); + + -- Otherwise do unchecked conversion of value to right type + + else + Rewrite (N, + Unchecked_Convert_To (T, + Make_Integer_Literal (Loc, + Intval => Expr_Rep_Value (Val)))); + end if; + + Analyze_And_Resolve (N, T); + Set_Is_Static_Expression (N, False); + end if; + end Expand_Current_Value; + + ------------------------- + -- Expand_Discriminant -- + ------------------------- + + procedure Expand_Discriminant (N : Node_Id) is + Scop : constant Entity_Id := Scope (Entity (N)); + P : Node_Id := N; + Parent_P : Node_Id := Parent (P); + In_Entry : Boolean := False; + + begin + -- The Incomplete_Or_Private_Kind happens while resolving the + -- discriminant constraint involved in a derived full type, + -- such as: + + -- type D is private; + -- type D(C : ...) is new T(C); + + if Ekind (Scop) = E_Record_Type + or Ekind (Scop) in Incomplete_Or_Private_Kind + then + -- Find the origin by walking up the tree till the component + -- declaration + + while Present (Parent_P) + and then Nkind (Parent_P) /= N_Component_Declaration + loop + P := Parent_P; + Parent_P := Parent (P); + end loop; + + -- If the discriminant reference was part of the default expression + -- it has to be "discriminalized" + + if Present (Parent_P) and then P = Expression (Parent_P) then + Set_Entity (N, Discriminal (Entity (N))); + end if; + + elsif Is_Concurrent_Type (Scop) then + while Present (Parent_P) + and then Nkind (Parent_P) /= N_Subprogram_Body + loop + P := Parent_P; + + if Nkind (P) = N_Entry_Declaration then + In_Entry := True; + end if; + + Parent_P := Parent (Parent_P); + end loop; + + -- If the discriminant occurs within the default expression for a + -- formal of an entry or protected operation, replace it with a + -- reference to the discriminant of the formal of the enclosing + -- operation. + + if Present (Parent_P) + and then Present (Corresponding_Spec (Parent_P)) + then + declare + Loc : constant Source_Ptr := Sloc (N); + D_Fun : constant Entity_Id := Corresponding_Spec (Parent_P); + Formal : constant Entity_Id := First_Formal (D_Fun); + New_N : Node_Id; + Disc : Entity_Id; + + begin + -- Verify that we are within the body of an entry or protected + -- operation. Its first formal parameter is the synchronized + -- type itself. + + if Present (Formal) + and then Etype (Formal) = Scope (Entity (N)) + then + Disc := CR_Discriminant (Entity (N)); + + New_N := + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Formal, Loc), + Selector_Name => New_Occurrence_Of (Disc, Loc)); + + Set_Etype (New_N, Etype (N)); + Rewrite (N, New_N); + + else + Set_Entity (N, Discriminal (Entity (N))); + end if; + end; + + elsif Nkind (Parent (N)) = N_Range + and then In_Entry + then + Set_Entity (N, CR_Discriminant (Entity (N))); + + -- Finally, if the entity is the discriminant of the original + -- type declaration, and we are within the initialization + -- procedure for a task, the designated entity is the + -- discriminal of the task body. This can happen when the + -- argument of pragma Task_Name mentions a discriminant, + -- because the pragma is analyzed in the task declaration + -- but is expanded in the call to Create_Task in the init_proc. + + elsif Within_Init_Proc then + Set_Entity (N, Discriminal (CR_Discriminant (Entity (N)))); + else + Set_Entity (N, Discriminal (Entity (N))); + end if; + + else + Set_Entity (N, Discriminal (Entity (N))); + end if; + end Expand_Discriminant; + + ----------------------------- + -- Expand_Entity_Reference -- + ----------------------------- + + procedure Expand_Entity_Reference (N : Node_Id) is + E : constant Entity_Id := Entity (N); + + begin + -- Defend against errors + + if No (E) and then Total_Errors_Detected /= 0 then + return; + end if; + + if Ekind (E) = E_Discriminant then + Expand_Discriminant (N); + + elsif Is_Entry_Formal (E) then + Expand_Entry_Parameter (N); + + elsif Is_Protected_Component (E) then + if No_Run_Time_Mode then + return; + end if; + + Expand_Protected_Component (N); + + elsif Ekind (E) = E_Entry_Index_Parameter then + Expand_Entry_Index_Parameter (N); + + elsif Is_Formal (E) then + Expand_Formal (N); + + elsif Is_Renaming_Of_Object (E) then + Expand_Renaming (N); + + elsif Ekind (E) = E_Variable + and then Is_Shared_Passive (E) + then + Expand_Shared_Passive_Variable (N); + end if; + + -- Test code for implementing the pragma Reviewable requirement of + -- classifying reads of scalars as referencing potentially uninitialized + -- objects or not. + + if Debug_Flag_XX + and then Is_Scalar_Type (Etype (N)) + and then (Is_Assignable (E) or else Is_Constant_Object (E)) + and then Comes_From_Source (N) + and then not Is_LHS (N) + and then not Is_Actual_Out_Parameter (N) + and then (Nkind (Parent (N)) /= N_Attribute_Reference + or else Attribute_Name (Parent (N)) /= Name_Valid) + then + Write_Location (Sloc (N)); + Write_Str (": Read from scalar """); + Write_Name (Chars (N)); + Write_Str (""""); + + if Is_Known_Valid (E) then + Write_Str (", Is_Known_Valid"); + end if; + + Write_Eol; + end if; + + -- Interpret possible Current_Value for variable case + + if Is_Assignable (E) + and then Present (Current_Value (E)) + then + Expand_Current_Value (N); + + -- We do want to warn for the case of a boolean variable (not a + -- boolean constant) whose value is known at compile time. + + if Is_Boolean_Type (Etype (N)) then + Warn_On_Known_Condition (N); + end if; + + -- Don't mess with Current_Value for compile time known values. Not + -- only is it unnecessary, but we could disturb an indication of a + -- static value, which could cause semantic trouble. + + elsif Compile_Time_Known_Value (N) then + null; + + -- Interpret possible Current_Value for constant case + + elsif Is_Constant_Object (E) + and then Present (Current_Value (E)) + then + Expand_Current_Value (N); + end if; + end Expand_Entity_Reference; + + ---------------------------------- + -- Expand_Entry_Index_Parameter -- + ---------------------------------- + + procedure Expand_Entry_Index_Parameter (N : Node_Id) is + Index_Con : constant Entity_Id := Entry_Index_Constant (Entity (N)); + begin + Set_Entity (N, Index_Con); + Set_Etype (N, Etype (Index_Con)); + end Expand_Entry_Index_Parameter; + + ---------------------------- + -- Expand_Entry_Parameter -- + ---------------------------- + + procedure Expand_Entry_Parameter (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ent_Formal : constant Entity_Id := Entity (N); + Ent_Spec : constant Entity_Id := Scope (Ent_Formal); + Parm_Type : constant Entity_Id := Entry_Parameters_Type (Ent_Spec); + Acc_Stack : constant Elist_Id := Accept_Address (Ent_Spec); + Addr_Ent : constant Entity_Id := Node (Last_Elmt (Acc_Stack)); + P_Comp_Ref : Entity_Id; + + function In_Assignment_Context (N : Node_Id) return Boolean; + -- Check whether this is a context in which the entry formal may be + -- assigned to. + + --------------------------- + -- In_Assignment_Context -- + --------------------------- + + function In_Assignment_Context (N : Node_Id) return Boolean is + begin + -- Case of use in a call + + -- ??? passing a formal as actual for a mode IN formal is + -- considered as an assignment? + + if Nkind_In (Parent (N), N_Procedure_Call_Statement, + N_Entry_Call_Statement) + or else (Nkind (Parent (N)) = N_Assignment_Statement + and then N = Name (Parent (N))) + then + return True; + + -- Case of a parameter association: climb up to enclosing call + + elsif Nkind (Parent (N)) = N_Parameter_Association then + return In_Assignment_Context (Parent (N)); + + -- Case of a selected component, indexed component or slice prefix: + -- climb up the tree, unless the prefix is of an access type (in + -- which case there is an implicit dereference, and the formal itself + -- is not being assigned to). + + elsif Nkind_In (Parent (N), N_Selected_Component, + N_Indexed_Component, + N_Slice) + and then N = Prefix (Parent (N)) + and then not Is_Access_Type (Etype (N)) + and then In_Assignment_Context (Parent (N)) + then + return True; + + else + return False; + end if; + end In_Assignment_Context; + + -- Start of processing for Expand_Entry_Parameter + + begin + if Is_Task_Type (Scope (Ent_Spec)) + and then Comes_From_Source (Ent_Formal) + then + -- Before replacing the formal with the local renaming that is used + -- in the accept block, note if this is an assignment context, and + -- note the modification to avoid spurious warnings, because the + -- original entity is not used further. If formal is unconstrained, + -- we also generate an extra parameter to hold the Constrained + -- attribute of the actual. No renaming is generated for this flag. + + -- Calling Note_Possible_Modification in the expander is dubious, + -- because this generates a cross-reference entry, and should be + -- done during semantic processing so it is called in -gnatc mode??? + + if Ekind (Entity (N)) /= E_In_Parameter + and then In_Assignment_Context (N) + then + Note_Possible_Modification (N, Sure => True); + end if; + + Rewrite (N, New_Occurrence_Of (Renamed_Object (Entity (N)), Loc)); + return; + end if; + + -- What we need is a reference to the corresponding component of the + -- parameter record object. The Accept_Address field of the entry entity + -- references the address variable that contains the address of the + -- accept parameters record. We first have to do an unchecked conversion + -- to turn this into a pointer to the parameter record and then we + -- select the required parameter field. + + P_Comp_Ref := + Make_Selected_Component (Loc, + Prefix => + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (Parm_Type, + New_Reference_To (Addr_Ent, Loc))), + Selector_Name => + New_Reference_To (Entry_Component (Ent_Formal), Loc)); + + -- For all types of parameters, the constructed parameter record object + -- contains a pointer to the parameter. Thus we must dereference them to + -- access them (this will often be redundant, since the dereference is + -- implicit, but no harm is done by making it explicit). + + Rewrite (N, + Make_Explicit_Dereference (Loc, P_Comp_Ref)); + + Analyze (N); + end Expand_Entry_Parameter; + + ------------------- + -- Expand_Formal -- + ------------------- + + procedure Expand_Formal (N : Node_Id) is + E : constant Entity_Id := Entity (N); + Scop : constant Entity_Id := Scope (E); + + begin + -- Check whether the subprogram of which this is a formal is + -- a protected operation. The initialization procedure for + -- the corresponding record type is not itself a protected operation. + + if Is_Protected_Type (Scope (Scop)) + and then not Is_Init_Proc (Scop) + and then Present (Protected_Formal (E)) + then + Set_Entity (N, Protected_Formal (E)); + end if; + end Expand_Formal; + + ---------------------------- + -- Expand_N_Expanded_Name -- + ---------------------------- + + procedure Expand_N_Expanded_Name (N : Node_Id) is + begin + Expand_Entity_Reference (N); + end Expand_N_Expanded_Name; + + ------------------------- + -- Expand_N_Identifier -- + ------------------------- + + procedure Expand_N_Identifier (N : Node_Id) is + begin + Expand_Entity_Reference (N); + end Expand_N_Identifier; + + --------------------------- + -- Expand_N_Real_Literal -- + --------------------------- + + procedure Expand_N_Real_Literal (N : Node_Id) is + begin + if Vax_Float (Etype (N)) then + Expand_Vax_Real_Literal (N); + end if; + end Expand_N_Real_Literal; + + -------------------------------- + -- Expand_Protected_Component -- + -------------------------------- + + procedure Expand_Protected_Component (N : Node_Id) is + + function Inside_Eliminated_Body return Boolean; + -- Determine whether the current entity is inside a subprogram or an + -- entry which has been marked as eliminated. + + ---------------------------- + -- Inside_Eliminated_Body -- + ---------------------------- + + function Inside_Eliminated_Body return Boolean is + S : Entity_Id := Current_Scope; + + begin + while Present (S) loop + if (Ekind (S) = E_Entry + or else Ekind (S) = E_Entry_Family + or else Ekind (S) = E_Function + or else Ekind (S) = E_Procedure) + and then Is_Eliminated (S) + then + return True; + end if; + + S := Scope (S); + end loop; + + return False; + end Inside_Eliminated_Body; + + -- Start of processing for Expand_Protected_Component + + begin + -- Eliminated bodies are not expanded and thus do not need privals + + if not Inside_Eliminated_Body then + declare + Priv : constant Entity_Id := Prival (Entity (N)); + begin + Set_Entity (N, Priv); + Set_Etype (N, Etype (Priv)); + end; + end if; + end Expand_Protected_Component; + + --------------------- + -- Expand_Renaming -- + --------------------- + + procedure Expand_Renaming (N : Node_Id) is + E : constant Entity_Id := Entity (N); + T : constant Entity_Id := Etype (N); + + begin + Rewrite (N, New_Copy_Tree (Renamed_Object (E))); + + -- We mark the copy as unanalyzed, so that it is sure to be reanalyzed + -- at the top level. This is needed in the packed case since we + -- specifically avoided expanding packed array references when the + -- renaming declaration was analyzed. + + Reset_Analyzed_Flags (N); + Analyze_And_Resolve (N, T); + end Expand_Renaming; + + ------------------ + -- Param_Entity -- + ------------------ + + -- This would be trivial, simply a test for an identifier that was a + -- reference to a formal, if it were not for the fact that a previous call + -- to Expand_Entry_Parameter will have modified the reference to the + -- identifier. A formal of a protected entity is rewritten as + + -- typ!(recobj).rec.all'Constrained + + -- where rec is a selector whose Entry_Formal link points to the formal + -- For a formal of a task entity, the formal is rewritten as a local + -- renaming. + + -- In addition, a formal that is marked volatile because it is aliased + -- through an address clause is rewritten as dereference as well. + + function Param_Entity (N : Node_Id) return Entity_Id is + Renamed_Obj : Node_Id; + + begin + -- Simple reference case + + if Nkind_In (N, N_Identifier, N_Expanded_Name) then + if Is_Formal (Entity (N)) then + return Entity (N); + + -- Handle renamings of formal parameters and formals of tasks that + -- are rewritten as renamings. + + elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration then + Renamed_Obj := Get_Referenced_Object (Renamed_Object (Entity (N))); + + if Is_Entity_Name (Renamed_Obj) + and then Is_Formal (Entity (Renamed_Obj)) + then + return Entity (Renamed_Obj); + + elsif + Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement + then + return Entity (N); + end if; + end if; + + else + if Nkind (N) = N_Explicit_Dereference then + declare + P : constant Node_Id := Prefix (N); + S : Node_Id; + + begin + if Nkind (P) = N_Selected_Component then + S := Selector_Name (P); + + if Present (Entry_Formal (Entity (S))) then + return Entry_Formal (Entity (S)); + end if; + + elsif Nkind (Original_Node (N)) = N_Identifier then + return Param_Entity (Original_Node (N)); + end if; + end; + end if; + end if; + + return (Empty); + end Param_Entity; + +end Exp_Ch2; diff --git a/gcc/ada/exp_ch2.ads b/gcc/ada/exp_ch2.ads new file mode 100644 index 000000000..f1d5eb310 --- /dev/null +++ b/gcc/ada/exp_ch2.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for chapter 2 constructs + +with Types; use Types; +package Exp_Ch2 is + + procedure Expand_N_Expanded_Name (N : Node_Id); + procedure Expand_N_Identifier (N : Node_Id); + procedure Expand_N_Real_Literal (N : Node_Id); + + function Param_Entity (N : Node_Id) return Entity_Id; + -- Given an expression N, determines if the expression is a reference + -- to a formal (of a subprogram or entry), and if so returns the Id + -- of the corresponding formal entity, otherwise returns Empty. The + -- reason that this is in Exp_Ch2 is that it has to deal with the case + -- where the reference is to an entry formal, and has been expanded + -- already. Since Exp_Ch2 is in charge of the expansion, it is best + -- suited to knowing how to detect this case. Also handles the case + -- of references to renamings of formals. + +end Exp_Ch2; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb new file mode 100644 index 000000000..ecbb9a3a9 --- /dev/null +++ b/gcc/ada/exp_ch3.adb @@ -0,0 +1,9142 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 3 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Einfo; use Einfo; +with Errout; use Errout; +with Exp_Aggr; use Exp_Aggr; +with Exp_Atag; use Exp_Atag; +with Exp_Ch4; use Exp_Ch4; +with Exp_Ch6; use Exp_Ch6; +with Exp_Ch7; use Exp_Ch7; +with Exp_Ch9; use Exp_Ch9; +with Exp_Ch11; use Exp_Ch11; +with Exp_Disp; use Exp_Disp; +with Exp_Dist; use Exp_Dist; +with Exp_Smem; use Exp_Smem; +with Exp_Strm; use Exp_Strm; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Attr; use Sem_Attr; +with Sem_Cat; use Sem_Cat; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Disp; use Sem_Disp; +with Sem_Eval; use Sem_Eval; +with Sem_Mech; use Sem_Mech; +with Sem_Res; use Sem_Res; +with Sem_SCIL; use Sem_SCIL; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Stand; use Stand; +with Snames; use Snames; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Validsw; use Validsw; + +package body Exp_Ch3 is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Add_Final_Chain (Def_Id : Entity_Id) return Entity_Id; + -- Add the declaration of a finalization list to the freeze actions for + -- Def_Id, and return its defining identifier. + + procedure Adjust_Discriminants (Rtype : Entity_Id); + -- This is used when freezing a record type. It attempts to construct + -- more restrictive subtypes for discriminants so that the max size of + -- the record can be calculated more accurately. See the body of this + -- procedure for details. + + procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id); + -- Build initialization procedure for given array type. Nod is a node + -- used for attachment of any actions required in its construction. + -- It also supplies the source location used for the procedure. + + function Build_Discriminant_Formals + (Rec_Id : Entity_Id; + Use_Dl : Boolean) return List_Id; + -- This function uses the discriminants of a type to build a list of + -- formal parameters, used in Build_Init_Procedure among other places. + -- If the flag Use_Dl is set, the list is built using the already + -- defined discriminals of the type, as is the case for concurrent + -- types with discriminants. Otherwise new identifiers are created, + -- with the source names of the discriminants. + + function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id; + -- This function builds a static aggregate that can serve as the initial + -- value for an array type whose bounds are static, and whose component + -- type is a composite type that has a static equivalent aggregate. + -- The equivalent array aggregate is used both for object initialization + -- and for component initialization, when used in the following function. + + function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id; + -- This function builds a static aggregate that can serve as the initial + -- value for a record type whose components are scalar and initialized + -- with compile-time values, or arrays with similar initialization or + -- defaults. When possible, initialization of an object of the type can + -- be achieved by using a copy of the aggregate as an initial value, thus + -- removing the implicit call that would otherwise constitute elaboration + -- code. + + function Build_Master_Renaming + (N : Node_Id; + T : Entity_Id) return Entity_Id; + -- If the designated type of an access type is a task type or contains + -- tasks, we make sure that a _Master variable is declared in the current + -- scope, and then declare a renaming for it: + -- + -- atypeM : Master_Id renames _Master; + -- + -- where atyp is the name of the access type. This declaration is used when + -- an allocator for the access type is expanded. The node is the full + -- declaration of the designated type that contains tasks. The renaming + -- declaration is inserted before N, and after the Master declaration. + + procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id); + -- Build record initialization procedure. N is the type declaration + -- node, and Pe is the corresponding entity for the record type. + + procedure Build_Slice_Assignment (Typ : Entity_Id); + -- Build assignment procedure for one-dimensional arrays of controlled + -- types. Other array and slice assignments are expanded in-line, but + -- the code expansion for controlled components (when control actions + -- are active) can lead to very large blocks that GCC3 handles poorly. + + procedure Build_Untagged_Equality (Typ : Entity_Id); + -- AI05-0123: Equality on untagged records composes. This procedure + -- builds the equality routine for an untagged record that has components + -- of a record type that has user-defined primitive equality operations. + -- The resulting operation is a TSS subprogram. + + procedure Build_Variant_Record_Equality (Typ : Entity_Id); + -- Create An Equality function for the non-tagged variant record 'Typ' + -- and attach it to the TSS list + + procedure Check_Stream_Attributes (Typ : Entity_Id); + -- Check that if a limited extension has a parent with user-defined stream + -- attributes, and does not itself have user-defined stream-attributes, + -- then any limited component of the extension also has the corresponding + -- user-defined stream attributes. + + procedure Clean_Task_Names + (Typ : Entity_Id; + Proc_Id : Entity_Id); + -- If an initialization procedure includes calls to generate names + -- for task subcomponents, indicate that secondary stack cleanup is + -- needed after an initialization. Typ is the component type, and Proc_Id + -- the initialization procedure for the enclosing composite type. + + procedure Expand_Tagged_Root (T : Entity_Id); + -- Add a field _Tag at the beginning of the record. This field carries + -- the value of the access to the Dispatch table. This procedure is only + -- called on root type, the _Tag field being inherited by the descendants. + + procedure Expand_Record_Controller (T : Entity_Id); + -- T must be a record type that Has_Controlled_Component. Add a field + -- _controller of type Record_Controller or Limited_Record_Controller + -- in the record T. + + procedure Expand_Freeze_Array_Type (N : Node_Id); + -- Freeze an array type. Deals with building the initialization procedure, + -- creating the packed array type for a packed array and also with the + -- creation of the controlling procedures for the controlled case. The + -- argument N is the N_Freeze_Entity node for the type. + + procedure Expand_Freeze_Enumeration_Type (N : Node_Id); + -- Freeze enumeration type with non-standard representation. Builds the + -- array and function needed to convert between enumeration pos and + -- enumeration representation values. N is the N_Freeze_Entity node + -- for the type. + + procedure Expand_Freeze_Record_Type (N : Node_Id); + -- Freeze record type. Builds all necessary discriminant checking + -- and other ancillary functions, and builds dispatch tables where + -- needed. The argument N is the N_Freeze_Entity node. This processing + -- applies only to E_Record_Type entities, not to class wide types, + -- record subtypes, or private types. + + procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id); + -- Treat user-defined stream operations as renaming_as_body if the + -- subprogram they rename is not frozen when the type is frozen. + + procedure Initialization_Warning (E : Entity_Id); + -- If static elaboration of the package is requested, indicate + -- when a type does meet the conditions for static initialization. If + -- E is a type, it has components that have no static initialization. + -- if E is an entity, its initial expression is not compile-time known. + + function Init_Formals (Typ : Entity_Id) return List_Id; + -- This function builds the list of formals for an initialization routine. + -- The first formal is always _Init with the given type. For task value + -- record types and types containing tasks, three additional formals are + -- added: + -- + -- _Master : Master_Id + -- _Chain : in out Activation_Chain + -- _Task_Name : String + -- + -- The caller must append additional entries for discriminants if required. + + function In_Runtime (E : Entity_Id) return Boolean; + -- Check if E is defined in the RTL (in a child of Ada or System). Used + -- to avoid to bring in the overhead of _Input, _Output for tagged types. + + function Is_Variable_Size_Array (E : Entity_Id) return Boolean; + -- Returns true if E has variable size components + + function Is_Variable_Size_Record (E : Entity_Id) return Boolean; + -- Returns true if E has variable size components + + function Make_Eq_Body + (Typ : Entity_Id; + Eq_Name : Name_Id) return Node_Id; + -- Build the body of a primitive equality operation for a tagged record + -- type, or in Ada 2012 for any record type that has components with a + -- user-defined equality. Factored out of Predefined_Primitive_Bodies. + + function Make_Eq_Case + (E : Entity_Id; + CL : Node_Id; + Discr : Entity_Id := Empty) return List_Id; + -- Building block for variant record equality. Defined to share the code + -- between the tagged and non-tagged case. Given a Component_List node CL, + -- it generates an 'if' followed by a 'case' statement that compares all + -- components of local temporaries named X and Y (that are declared as + -- formals at some upper level). E provides the Sloc to be used for the + -- generated code. Discr is used as the case statement switch in the case + -- of Unchecked_Union equality. + + function Make_Eq_If + (E : Entity_Id; + L : List_Id) return Node_Id; + -- Building block for variant record equality. Defined to share the code + -- between the tagged and non-tagged case. Given the list of components + -- (or discriminants) L, it generates a return statement that compares all + -- components of local temporaries named X and Y (that are declared as + -- formals at some upper level). E provides the Sloc to be used for the + -- generated code. + + procedure Make_Predefined_Primitive_Specs + (Tag_Typ : Entity_Id; + Predef_List : out List_Id; + Renamed_Eq : out Entity_Id); + -- Create a list with the specs of the predefined primitive operations. + -- For tagged types that are interfaces all these primitives are defined + -- abstract. + -- + -- The following entries are present for all tagged types, and provide + -- the results of the corresponding attribute applied to the object. + -- Dispatching is required in general, since the result of the attribute + -- will vary with the actual object subtype. + -- + -- _alignment provides result of 'Alignment attribute + -- _size provides result of 'Size attribute + -- typSR provides result of 'Read attribute + -- typSW provides result of 'Write attribute + -- typSI provides result of 'Input attribute + -- typSO provides result of 'Output attribute + -- + -- The following entries are additionally present for non-limited tagged + -- types, and implement additional dispatching operations for predefined + -- operations: + -- + -- _equality implements "=" operator + -- _assign implements assignment operation + -- typDF implements deep finalization + -- typDA implements deep adjust + -- + -- The latter two are empty procedures unless the type contains some + -- controlled components that require finalization actions (the deep + -- in the name refers to the fact that the action applies to components). + -- + -- The list is returned in Predef_List. The Parameter Renamed_Eq either + -- returns the value Empty, or else the defining unit name for the + -- predefined equality function in the case where the type has a primitive + -- operation that is a renaming of predefined equality (but only if there + -- is also an overriding user-defined equality function). The returned + -- Renamed_Eq will be passed to the corresponding parameter of + -- Predefined_Primitive_Bodies. + + function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean; + -- returns True if there are representation clauses for type T that are not + -- inherited. If the result is false, the init_proc and the discriminant + -- checking functions of the parent can be reused by a derived type. + + procedure Make_Controlling_Function_Wrappers + (Tag_Typ : Entity_Id; + Decl_List : out List_Id; + Body_List : out List_Id); + -- Ada 2005 (AI-391): Makes specs and bodies for the wrapper functions + -- associated with inherited functions with controlling results which + -- are not overridden. The body of each wrapper function consists solely + -- of a return statement whose expression is an extension aggregate + -- invoking the inherited subprogram's parent subprogram and extended + -- with a null association list. + + function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id; + -- Ada 2005 (AI-251): Makes specs for null procedures associated with any + -- null procedures inherited from an interface type that have not been + -- overridden. Only one null procedure will be created for a given set of + -- inherited null procedures with homographic profiles. + + function Predef_Spec_Or_Body + (Loc : Source_Ptr; + Tag_Typ : Entity_Id; + Name : Name_Id; + Profile : List_Id; + Ret_Type : Entity_Id := Empty; + For_Body : Boolean := False) return Node_Id; + -- This function generates the appropriate expansion for a predefined + -- primitive operation specified by its name, parameter profile and + -- return type (Empty means this is a procedure). If For_Body is false, + -- then the returned node is a subprogram declaration. If For_Body is + -- true, then the returned node is a empty subprogram body containing + -- no declarations and no statements. + + function Predef_Stream_Attr_Spec + (Loc : Source_Ptr; + Tag_Typ : Entity_Id; + Name : TSS_Name_Type; + For_Body : Boolean := False) return Node_Id; + -- Specialized version of Predef_Spec_Or_Body that apply to read, write, + -- input and output attribute whose specs are constructed in Exp_Strm. + + function Predef_Deep_Spec + (Loc : Source_Ptr; + Tag_Typ : Entity_Id; + Name : TSS_Name_Type; + For_Body : Boolean := False) return Node_Id; + -- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust + -- and _deep_finalize + + function Predefined_Primitive_Bodies + (Tag_Typ : Entity_Id; + Renamed_Eq : Entity_Id) return List_Id; + -- Create the bodies of the predefined primitives that are described in + -- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote + -- the defining unit name of the type's predefined equality as returned + -- by Make_Predefined_Primitive_Specs. + + function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id; + -- Freeze entities of all predefined primitive operations. This is needed + -- because the bodies of these operations do not normally do any freezing. + + function Stream_Operation_OK + (Typ : Entity_Id; + Operation : TSS_Name_Type) return Boolean; + -- Check whether the named stream operation must be emitted for a given + -- type. The rules for inheritance of stream attributes by type extensions + -- are enforced by this function. Furthermore, various restrictions prevent + -- the generation of these operations, as a useful optimization or for + -- certification purposes. + + --------------------- + -- Add_Final_Chain -- + --------------------- + + function Add_Final_Chain (Def_Id : Entity_Id) return Entity_Id is + Loc : constant Source_Ptr := Sloc (Def_Id); + Flist : Entity_Id; + + begin + Flist := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Def_Id), 'L')); + + Append_Freeze_Action (Def_Id, + Make_Object_Declaration (Loc, + Defining_Identifier => Flist, + Object_Definition => + New_Reference_To (RTE (RE_List_Controller), Loc))); + + return Flist; + end Add_Final_Chain; + + -------------------------- + -- Adjust_Discriminants -- + -------------------------- + + -- This procedure attempts to define subtypes for discriminants that are + -- more restrictive than those declared. Such a replacement is possible if + -- we can demonstrate that values outside the restricted range would cause + -- constraint errors in any case. The advantage of restricting the + -- discriminant types in this way is that the maximum size of the variant + -- record can be calculated more conservatively. + + -- An example of a situation in which we can perform this type of + -- restriction is the following: + + -- subtype B is range 1 .. 10; + -- type Q is array (B range <>) of Integer; + + -- type V (N : Natural) is record + -- C : Q (1 .. N); + -- end record; + + -- In this situation, we can restrict the upper bound of N to 10, since + -- any larger value would cause a constraint error in any case. + + -- There are many situations in which such restriction is possible, but + -- for now, we just look for cases like the above, where the component + -- in question is a one dimensional array whose upper bound is one of + -- the record discriminants. Also the component must not be part of + -- any variant part, since then the component does not always exist. + + procedure Adjust_Discriminants (Rtype : Entity_Id) is + Loc : constant Source_Ptr := Sloc (Rtype); + Comp : Entity_Id; + Ctyp : Entity_Id; + Ityp : Entity_Id; + Lo : Node_Id; + Hi : Node_Id; + P : Node_Id; + Loval : Uint; + Discr : Entity_Id; + Dtyp : Entity_Id; + Dhi : Node_Id; + Dhiv : Uint; + Ahi : Node_Id; + Ahiv : Uint; + Tnn : Entity_Id; + + begin + Comp := First_Component (Rtype); + while Present (Comp) loop + + -- If our parent is a variant, quit, we do not look at components + -- that are in variant parts, because they may not always exist. + + P := Parent (Comp); -- component declaration + P := Parent (P); -- component list + + exit when Nkind (Parent (P)) = N_Variant; + + -- We are looking for a one dimensional array type + + Ctyp := Etype (Comp); + + if not Is_Array_Type (Ctyp) + or else Number_Dimensions (Ctyp) > 1 + then + goto Continue; + end if; + + -- The lower bound must be constant, and the upper bound is a + -- discriminant (which is a discriminant of the current record). + + Ityp := Etype (First_Index (Ctyp)); + Lo := Type_Low_Bound (Ityp); + Hi := Type_High_Bound (Ityp); + + if not Compile_Time_Known_Value (Lo) + or else Nkind (Hi) /= N_Identifier + or else No (Entity (Hi)) + or else Ekind (Entity (Hi)) /= E_Discriminant + then + goto Continue; + end if; + + -- We have an array with appropriate bounds + + Loval := Expr_Value (Lo); + Discr := Entity (Hi); + Dtyp := Etype (Discr); + + -- See if the discriminant has a known upper bound + + Dhi := Type_High_Bound (Dtyp); + + if not Compile_Time_Known_Value (Dhi) then + goto Continue; + end if; + + Dhiv := Expr_Value (Dhi); + + -- See if base type of component array has known upper bound + + Ahi := Type_High_Bound (Etype (First_Index (Base_Type (Ctyp)))); + + if not Compile_Time_Known_Value (Ahi) then + goto Continue; + end if; + + Ahiv := Expr_Value (Ahi); + + -- The condition for doing the restriction is that the high bound + -- of the discriminant is greater than the low bound of the array, + -- and is also greater than the high bound of the base type index. + + if Dhiv > Loval and then Dhiv > Ahiv then + + -- We can reset the upper bound of the discriminant type to + -- whichever is larger, the low bound of the component, or + -- the high bound of the base type array index. + + -- We build a subtype that is declared as + + -- subtype Tnn is discr_type range discr_type'First .. max; + + -- And insert this declaration into the tree. The type of the + -- discriminant is then reset to this more restricted subtype. + + Tnn := Make_Temporary (Loc, 'T'); + + Insert_Action (Declaration_Node (Rtype), + Make_Subtype_Declaration (Loc, + Defining_Identifier => Tnn, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Dtyp, Loc), + Constraint => + Make_Range_Constraint (Loc, + Range_Expression => + Make_Range (Loc, + Low_Bound => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_First, + Prefix => New_Occurrence_Of (Dtyp, Loc)), + High_Bound => + Make_Integer_Literal (Loc, + Intval => UI_Max (Loval, Ahiv))))))); + + Set_Etype (Discr, Tnn); + end if; + + <> + Next_Component (Comp); + end loop; + end Adjust_Discriminants; + + --------------------------- + -- Build_Array_Init_Proc -- + --------------------------- + + procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is + Loc : constant Source_Ptr := Sloc (Nod); + Comp_Type : constant Entity_Id := Component_Type (A_Type); + Index_List : List_Id; + Proc_Id : Entity_Id; + Body_Stmts : List_Id; + Has_Default_Init : Boolean; + + function Init_Component return List_Id; + -- Create one statement to initialize one array component, designated + -- by a full set of indexes. + + function Init_One_Dimension (N : Int) return List_Id; + -- Create loop to initialize one dimension of the array. The single + -- statement in the loop body initializes the inner dimensions if any, + -- or else the single component. Note that this procedure is called + -- recursively, with N being the dimension to be initialized. A call + -- with N greater than the number of dimensions simply generates the + -- component initialization, terminating the recursion. + + -------------------- + -- Init_Component -- + -------------------- + + function Init_Component return List_Id is + Comp : Node_Id; + + begin + Comp := + Make_Indexed_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Expressions => Index_List); + + if Needs_Simple_Initialization (Comp_Type) then + Set_Assignment_OK (Comp); + return New_List ( + Make_Assignment_Statement (Loc, + Name => Comp, + Expression => + Get_Simple_Init_Val + (Comp_Type, Nod, Component_Size (A_Type)))); + + else + Clean_Task_Names (Comp_Type, Proc_Id); + return + Build_Initialization_Call + (Loc, Comp, Comp_Type, + In_Init_Proc => True, + Enclos_Type => A_Type); + end if; + end Init_Component; + + ------------------------ + -- Init_One_Dimension -- + ------------------------ + + function Init_One_Dimension (N : Int) return List_Id is + Index : Entity_Id; + + begin + -- If the component does not need initializing, then there is nothing + -- to do here, so we return a null body. This occurs when generating + -- the dummy Init_Proc needed for Initialize_Scalars processing. + + if not Has_Non_Null_Base_Init_Proc (Comp_Type) + and then not Needs_Simple_Initialization (Comp_Type) + and then not Has_Task (Comp_Type) + then + return New_List (Make_Null_Statement (Loc)); + + -- If all dimensions dealt with, we simply initialize the component + + elsif N > Number_Dimensions (A_Type) then + return Init_Component; + + -- Here we generate the required loop + + else + Index := + Make_Defining_Identifier (Loc, New_External_Name ('J', N)); + + Append (New_Reference_To (Index, Loc), Index_List); + + return New_List ( + Make_Implicit_Loop_Statement (Nod, + Identifier => Empty, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Index, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Attribute_Name => Name_Range, + Expressions => New_List ( + Make_Integer_Literal (Loc, N))))), + Statements => Init_One_Dimension (N + 1))); + end if; + end Init_One_Dimension; + + -- Start of processing for Build_Array_Init_Proc + + begin + -- Nothing to generate in the following cases: + + -- 1. Initialization is suppressed for the type + -- 2. The type is a value type, in the CIL sense. + -- 3. The type has CIL/JVM convention. + -- 4. An initialization already exists for the base type + + if Suppress_Init_Proc (A_Type) + or else Is_Value_Type (Comp_Type) + or else Convention (A_Type) = Convention_CIL + or else Convention (A_Type) = Convention_Java + or else Present (Base_Init_Proc (A_Type)) + then + return; + end if; + + Index_List := New_List; + + -- We need an initialization procedure if any of the following is true: + + -- 1. The component type has an initialization procedure + -- 2. The component type needs simple initialization + -- 3. Tasks are present + -- 4. The type is marked as a public entity + + -- The reason for the public entity test is to deal properly with the + -- Initialize_Scalars pragma. This pragma can be set in the client and + -- not in the declaring package, this means the client will make a call + -- to the initialization procedure (because one of conditions 1-3 must + -- apply in this case), and we must generate a procedure (even if it is + -- null) to satisfy the call in this case. + + -- Exception: do not build an array init_proc for a type whose root + -- type is Standard.String or Standard.Wide_[Wide_]String, since there + -- is no place to put the code, and in any case we handle initialization + -- of such types (in the Initialize_Scalars case, that's the only time + -- the issue arises) in a special manner anyway which does not need an + -- init_proc. + + Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type) + or else Needs_Simple_Initialization (Comp_Type) + or else Has_Task (Comp_Type); + + if Has_Default_Init + or else (not Restriction_Active (No_Initialize_Scalars) + and then Is_Public (A_Type) + and then Root_Type (A_Type) /= Standard_String + and then Root_Type (A_Type) /= Standard_Wide_String + and then Root_Type (A_Type) /= Standard_Wide_Wide_String) + then + Proc_Id := + Make_Defining_Identifier (Loc, + Chars => Make_Init_Proc_Name (A_Type)); + + -- If No_Default_Initialization restriction is active, then we don't + -- want to build an init_proc, but we need to mark that an init_proc + -- would be needed if this restriction was not active (so that we can + -- detect attempts to call it), so set a dummy init_proc in place. + -- This is only done though when actual default initialization is + -- needed (and not done when only Is_Public is True), since otherwise + -- objects such as arrays of scalars could be wrongly flagged as + -- violating the restriction. + + if Restriction_Active (No_Default_Initialization) then + if Has_Default_Init then + Set_Init_Proc (A_Type, Proc_Id); + end if; + + return; + end if; + + Body_Stmts := Init_One_Dimension (1); + + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc_Id, + Parameter_Specifications => Init_Formals (A_Type)), + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Body_Stmts))); + + Set_Ekind (Proc_Id, E_Procedure); + Set_Is_Public (Proc_Id, Is_Public (A_Type)); + Set_Is_Internal (Proc_Id); + Set_Has_Completion (Proc_Id); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Proc_Id); + end if; + + -- Set inlined unless controlled stuff or tasks around, in which + -- case we do not want to inline, because nested stuff may cause + -- difficulties in inter-unit inlining, and furthermore there is + -- in any case no point in inlining such complex init procs. + + if not Has_Task (Proc_Id) + and then not Needs_Finalization (Proc_Id) + then + Set_Is_Inlined (Proc_Id); + end if; + + -- Associate Init_Proc with type, and determine if the procedure + -- is null (happens because of the Initialize_Scalars pragma case, + -- where we have to generate a null procedure in case it is called + -- by a client with Initialize_Scalars set). Such procedures have + -- to be generated, but do not have to be called, so we mark them + -- as null to suppress the call. + + Set_Init_Proc (A_Type, Proc_Id); + + if List_Length (Body_Stmts) = 1 + + -- We must skip SCIL nodes because they may have been added to this + -- list by Insert_Actions. + + and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement + then + Set_Is_Null_Init_Proc (Proc_Id); + + else + -- Try to build a static aggregate to initialize statically + -- objects of the type. This can only be done for constrained + -- one-dimensional arrays with static bounds. + + Set_Static_Initialization + (Proc_Id, + Build_Equivalent_Array_Aggregate (First_Subtype (A_Type))); + end if; + end if; + end Build_Array_Init_Proc; + + ----------------------------- + -- Build_Class_Wide_Master -- + ----------------------------- + + procedure Build_Class_Wide_Master (T : Entity_Id) is + Loc : constant Source_Ptr := Sloc (T); + M_Id : Entity_Id; + Decl : Node_Id; + P : Node_Id; + Par : Node_Id; + Scop : Entity_Id; + + begin + -- Nothing to do if there is no task hierarchy + + if Restriction_Active (No_Task_Hierarchy) then + return; + end if; + + -- Find declaration that created the access type: either a type + -- declaration, or an object declaration with an access definition, + -- in which case the type is anonymous. + + if Is_Itype (T) then + P := Associated_Node_For_Itype (T); + else + P := Parent (T); + end if; + + Scop := Find_Master_Scope (T); + + -- Nothing to do if we already built a master entity for this scope + + if not Has_Master_Entity (Scop) then + + -- First build the master entity + -- _Master : constant Master_Id := Current_Master.all; + -- and insert it just before the current declaration. + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uMaster), + Constant_Present => True, + Object_Definition => New_Reference_To (Standard_Integer, Loc), + Expression => + Make_Explicit_Dereference (Loc, + New_Reference_To (RTE (RE_Current_Master), Loc))); + + Set_Has_Master_Entity (Scop); + Insert_Action (P, Decl); + Analyze (Decl); + + -- Now mark the containing scope as a task master. Masters + -- associated with return statements are already marked at + -- this stage (see Analyze_Subprogram_Body). + + if Ekind (Current_Scope) /= E_Return_Statement then + Par := P; + while Nkind (Par) /= N_Compilation_Unit loop + Par := Parent (Par); + + -- If we fall off the top, we are at the outer level, and the + -- environment task is our effective master, so nothing to mark. + + if Nkind_In + (Par, N_Task_Body, N_Block_Statement, N_Subprogram_Body) + then + Set_Is_Task_Master (Par, True); + exit; + end if; + end loop; + end if; + end if; + + -- Now define the renaming of the master_id + + M_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (T), 'M')); + + Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => M_Id, + Subtype_Mark => New_Reference_To (Standard_Integer, Loc), + Name => Make_Identifier (Loc, Name_uMaster)); + Insert_Before (P, Decl); + Analyze (Decl); + + Set_Master_Id (T, M_Id); + + exception + when RE_Not_Available => + return; + end Build_Class_Wide_Master; + + -------------------------------- + -- Build_Discr_Checking_Funcs -- + -------------------------------- + + procedure Build_Discr_Checking_Funcs (N : Node_Id) is + Rec_Id : Entity_Id; + Loc : Source_Ptr; + Enclosing_Func_Id : Entity_Id; + Sequence : Nat := 1; + Type_Def : Node_Id; + V : Node_Id; + + function Build_Case_Statement + (Case_Id : Entity_Id; + Variant : Node_Id) return Node_Id; + -- Build a case statement containing only two alternatives. The first + -- alternative corresponds exactly to the discrete choices given on the + -- variant with contains the components that we are generating the + -- checks for. If the discriminant is one of these return False. The + -- second alternative is an OTHERS choice that will return True + -- indicating the discriminant did not match. + + function Build_Dcheck_Function + (Case_Id : Entity_Id; + Variant : Node_Id) return Entity_Id; + -- Build the discriminant checking function for a given variant + + procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id); + -- Builds the discriminant checking function for each variant of the + -- given variant part of the record type. + + -------------------------- + -- Build_Case_Statement -- + -------------------------- + + function Build_Case_Statement + (Case_Id : Entity_Id; + Variant : Node_Id) return Node_Id + is + Alt_List : constant List_Id := New_List; + Actuals_List : List_Id; + Case_Node : Node_Id; + Case_Alt_Node : Node_Id; + Choice : Node_Id; + Choice_List : List_Id; + D : Entity_Id; + Return_Node : Node_Id; + + begin + Case_Node := New_Node (N_Case_Statement, Loc); + + -- Replace the discriminant which controls the variant, with the name + -- of the formal of the checking function. + + Set_Expression (Case_Node, Make_Identifier (Loc, Chars (Case_Id))); + + Choice := First (Discrete_Choices (Variant)); + + if Nkind (Choice) = N_Others_Choice then + Choice_List := New_Copy_List (Others_Discrete_Choices (Choice)); + else + Choice_List := New_Copy_List (Discrete_Choices (Variant)); + end if; + + if not Is_Empty_List (Choice_List) then + Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); + Set_Discrete_Choices (Case_Alt_Node, Choice_List); + + -- In case this is a nested variant, we need to return the result + -- of the discriminant checking function for the immediately + -- enclosing variant. + + if Present (Enclosing_Func_Id) then + Actuals_List := New_List; + + D := First_Discriminant (Rec_Id); + while Present (D) loop + Append (Make_Identifier (Loc, Chars (D)), Actuals_List); + Next_Discriminant (D); + end loop; + + Return_Node := + Make_Simple_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => + New_Reference_To (Enclosing_Func_Id, Loc), + Parameter_Associations => + Actuals_List)); + + else + Return_Node := + Make_Simple_Return_Statement (Loc, + Expression => + New_Reference_To (Standard_False, Loc)); + end if; + + Set_Statements (Case_Alt_Node, New_List (Return_Node)); + Append (Case_Alt_Node, Alt_List); + end if; + + Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); + Choice_List := New_List (New_Node (N_Others_Choice, Loc)); + Set_Discrete_Choices (Case_Alt_Node, Choice_List); + + Return_Node := + Make_Simple_Return_Statement (Loc, + Expression => + New_Reference_To (Standard_True, Loc)); + + Set_Statements (Case_Alt_Node, New_List (Return_Node)); + Append (Case_Alt_Node, Alt_List); + + Set_Alternatives (Case_Node, Alt_List); + return Case_Node; + end Build_Case_Statement; + + --------------------------- + -- Build_Dcheck_Function -- + --------------------------- + + function Build_Dcheck_Function + (Case_Id : Entity_Id; + Variant : Node_Id) return Entity_Id + is + Body_Node : Node_Id; + Func_Id : Entity_Id; + Parameter_List : List_Id; + Spec_Node : Node_Id; + + begin + Body_Node := New_Node (N_Subprogram_Body, Loc); + Sequence := Sequence + 1; + + Func_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Rec_Id), 'D', Sequence)); + + Spec_Node := New_Node (N_Function_Specification, Loc); + Set_Defining_Unit_Name (Spec_Node, Func_Id); + + Parameter_List := Build_Discriminant_Formals (Rec_Id, False); + + Set_Parameter_Specifications (Spec_Node, Parameter_List); + Set_Result_Definition (Spec_Node, + New_Reference_To (Standard_Boolean, Loc)); + Set_Specification (Body_Node, Spec_Node); + Set_Declarations (Body_Node, New_List); + + Set_Handled_Statement_Sequence (Body_Node, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Build_Case_Statement (Case_Id, Variant)))); + + Set_Ekind (Func_Id, E_Function); + Set_Mechanism (Func_Id, Default_Mechanism); + Set_Is_Inlined (Func_Id, True); + Set_Is_Pure (Func_Id, True); + Set_Is_Public (Func_Id, Is_Public (Rec_Id)); + Set_Is_Internal (Func_Id, True); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Func_Id); + end if; + + Analyze (Body_Node); + + Append_Freeze_Action (Rec_Id, Body_Node); + Set_Dcheck_Function (Variant, Func_Id); + return Func_Id; + end Build_Dcheck_Function; + + ---------------------------- + -- Build_Dcheck_Functions -- + ---------------------------- + + procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id) is + Component_List_Node : Node_Id; + Decl : Entity_Id; + Discr_Name : Entity_Id; + Func_Id : Entity_Id; + Variant : Node_Id; + Saved_Enclosing_Func_Id : Entity_Id; + + begin + -- Build the discriminant-checking function for each variant, and + -- label all components of that variant with the function's name. + -- We only Generate a discriminant-checking function when the + -- variant is not empty, to prevent the creation of dead code. + -- The exception to that is when Frontend_Layout_On_Target is set, + -- because the variant record size function generated in package + -- Layout needs to generate calls to all discriminant-checking + -- functions, including those for empty variants. + + Discr_Name := Entity (Name (Variant_Part_Node)); + Variant := First_Non_Pragma (Variants (Variant_Part_Node)); + + while Present (Variant) loop + Component_List_Node := Component_List (Variant); + + if not Null_Present (Component_List_Node) + or else Frontend_Layout_On_Target + then + Func_Id := Build_Dcheck_Function (Discr_Name, Variant); + Decl := + First_Non_Pragma (Component_Items (Component_List_Node)); + + while Present (Decl) loop + Set_Discriminant_Checking_Func + (Defining_Identifier (Decl), Func_Id); + + Next_Non_Pragma (Decl); + end loop; + + if Present (Variant_Part (Component_List_Node)) then + Saved_Enclosing_Func_Id := Enclosing_Func_Id; + Enclosing_Func_Id := Func_Id; + Build_Dcheck_Functions (Variant_Part (Component_List_Node)); + Enclosing_Func_Id := Saved_Enclosing_Func_Id; + end if; + end if; + + Next_Non_Pragma (Variant); + end loop; + end Build_Dcheck_Functions; + + -- Start of processing for Build_Discr_Checking_Funcs + + begin + -- Only build if not done already + + if not Discr_Check_Funcs_Built (N) then + Type_Def := Type_Definition (N); + + if Nkind (Type_Def) = N_Record_Definition then + if No (Component_List (Type_Def)) then -- null record. + return; + else + V := Variant_Part (Component_List (Type_Def)); + end if; + + else pragma Assert (Nkind (Type_Def) = N_Derived_Type_Definition); + if No (Component_List (Record_Extension_Part (Type_Def))) then + return; + else + V := Variant_Part + (Component_List (Record_Extension_Part (Type_Def))); + end if; + end if; + + Rec_Id := Defining_Identifier (N); + + if Present (V) and then not Is_Unchecked_Union (Rec_Id) then + Loc := Sloc (N); + Enclosing_Func_Id := Empty; + Build_Dcheck_Functions (V); + end if; + + Set_Discr_Check_Funcs_Built (N); + end if; + end Build_Discr_Checking_Funcs; + + -------------------------------- + -- Build_Discriminant_Formals -- + -------------------------------- + + function Build_Discriminant_Formals + (Rec_Id : Entity_Id; + Use_Dl : Boolean) return List_Id + is + Loc : Source_Ptr := Sloc (Rec_Id); + Parameter_List : constant List_Id := New_List; + D : Entity_Id; + Formal : Entity_Id; + Formal_Type : Entity_Id; + Param_Spec_Node : Node_Id; + + begin + if Has_Discriminants (Rec_Id) then + D := First_Discriminant (Rec_Id); + while Present (D) loop + Loc := Sloc (D); + + if Use_Dl then + Formal := Discriminal (D); + Formal_Type := Etype (Formal); + else + Formal := Make_Defining_Identifier (Loc, Chars (D)); + Formal_Type := Etype (D); + end if; + + Param_Spec_Node := + Make_Parameter_Specification (Loc, + Defining_Identifier => Formal, + Parameter_Type => + New_Reference_To (Formal_Type, Loc)); + Append (Param_Spec_Node, Parameter_List); + Next_Discriminant (D); + end loop; + end if; + + return Parameter_List; + end Build_Discriminant_Formals; + + -------------------------------------- + -- Build_Equivalent_Array_Aggregate -- + -------------------------------------- + + function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (T); + Comp_Type : constant Entity_Id := Component_Type (T); + Index_Type : constant Entity_Id := Etype (First_Index (T)); + Proc : constant Entity_Id := Base_Init_Proc (T); + Lo, Hi : Node_Id; + Aggr : Node_Id; + Expr : Node_Id; + + begin + if not Is_Constrained (T) + or else Number_Dimensions (T) > 1 + or else No (Proc) + then + Initialization_Warning (T); + return Empty; + end if; + + Lo := Type_Low_Bound (Index_Type); + Hi := Type_High_Bound (Index_Type); + + if not Compile_Time_Known_Value (Lo) + or else not Compile_Time_Known_Value (Hi) + then + Initialization_Warning (T); + return Empty; + end if; + + if Is_Record_Type (Comp_Type) + and then Present (Base_Init_Proc (Comp_Type)) + then + Expr := Static_Initialization (Base_Init_Proc (Comp_Type)); + + if No (Expr) then + Initialization_Warning (T); + return Empty; + end if; + + else + Initialization_Warning (T); + return Empty; + end if; + + Aggr := Make_Aggregate (Loc, No_List, New_List); + Set_Etype (Aggr, T); + Set_Aggregate_Bounds (Aggr, + Make_Range (Loc, + Low_Bound => New_Copy (Lo), + High_Bound => New_Copy (Hi))); + Set_Parent (Aggr, Parent (Proc)); + + Append_To (Component_Associations (Aggr), + Make_Component_Association (Loc, + Choices => + New_List ( + Make_Range (Loc, + Low_Bound => New_Copy (Lo), + High_Bound => New_Copy (Hi))), + Expression => Expr)); + + if Static_Array_Aggregate (Aggr) then + return Aggr; + else + Initialization_Warning (T); + return Empty; + end if; + end Build_Equivalent_Array_Aggregate; + + --------------------------------------- + -- Build_Equivalent_Record_Aggregate -- + --------------------------------------- + + function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id is + Agg : Node_Id; + Comp : Entity_Id; + Comp_Type : Entity_Id; + + -- Start of processing for Build_Equivalent_Record_Aggregate + + begin + if not Is_Record_Type (T) + or else Has_Discriminants (T) + or else Is_Limited_Type (T) + or else Has_Non_Standard_Rep (T) + then + Initialization_Warning (T); + return Empty; + end if; + + Comp := First_Component (T); + + -- A null record needs no warning + + if No (Comp) then + return Empty; + end if; + + while Present (Comp) loop + + -- Array components are acceptable if initialized by a positional + -- aggregate with static components. + + if Is_Array_Type (Etype (Comp)) then + Comp_Type := Component_Type (Etype (Comp)); + + if Nkind (Parent (Comp)) /= N_Component_Declaration + or else No (Expression (Parent (Comp))) + or else Nkind (Expression (Parent (Comp))) /= N_Aggregate + then + Initialization_Warning (T); + return Empty; + + elsif Is_Scalar_Type (Component_Type (Etype (Comp))) + and then + (not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type)) + or else + not Compile_Time_Known_Value (Type_High_Bound (Comp_Type))) + then + Initialization_Warning (T); + return Empty; + + elsif + not Static_Array_Aggregate (Expression (Parent (Comp))) + then + Initialization_Warning (T); + return Empty; + end if; + + elsif Is_Scalar_Type (Etype (Comp)) then + Comp_Type := Etype (Comp); + + if Nkind (Parent (Comp)) /= N_Component_Declaration + or else No (Expression (Parent (Comp))) + or else not Compile_Time_Known_Value (Expression (Parent (Comp))) + or else not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type)) + or else not + Compile_Time_Known_Value (Type_High_Bound (Comp_Type)) + then + Initialization_Warning (T); + return Empty; + end if; + + -- For now, other types are excluded + + else + Initialization_Warning (T); + return Empty; + end if; + + Next_Component (Comp); + end loop; + + -- All components have static initialization. Build positional aggregate + -- from the given expressions or defaults. + + Agg := Make_Aggregate (Sloc (T), New_List, New_List); + Set_Parent (Agg, Parent (T)); + + Comp := First_Component (T); + while Present (Comp) loop + Append + (New_Copy_Tree (Expression (Parent (Comp))), Expressions (Agg)); + Next_Component (Comp); + end loop; + + Analyze_And_Resolve (Agg, T); + return Agg; + end Build_Equivalent_Record_Aggregate; + + ------------------------------- + -- Build_Initialization_Call -- + ------------------------------- + + -- References to a discriminant inside the record type declaration can + -- appear either in the subtype_indication to constrain a record or an + -- array, or as part of a larger expression given for the initial value + -- of a component. In both of these cases N appears in the record + -- initialization procedure and needs to be replaced by the formal + -- parameter of the initialization procedure which corresponds to that + -- discriminant. + + -- In the example below, references to discriminants D1 and D2 in proc_1 + -- are replaced by references to formals with the same name + -- (discriminals) + + -- A similar replacement is done for calls to any record initialization + -- procedure for any components that are themselves of a record type. + + -- type R (D1, D2 : Integer) is record + -- X : Integer := F * D1; + -- Y : Integer := F * D2; + -- end record; + + -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is + -- begin + -- Out_2.D1 := D1; + -- Out_2.D2 := D2; + -- Out_2.X := F * D1; + -- Out_2.Y := F * D2; + -- end; + + function Build_Initialization_Call + (Loc : Source_Ptr; + Id_Ref : Node_Id; + Typ : Entity_Id; + In_Init_Proc : Boolean := False; + Enclos_Type : Entity_Id := Empty; + Discr_Map : Elist_Id := New_Elmt_List; + With_Default_Init : Boolean := False; + Constructor_Ref : Node_Id := Empty) return List_Id + is + Res : constant List_Id := New_List; + Arg : Node_Id; + Args : List_Id; + Controller_Typ : Entity_Id; + Decl : Node_Id; + Decls : List_Id; + Discr : Entity_Id; + First_Arg : Node_Id; + Full_Init_Type : Entity_Id; + Full_Type : Entity_Id := Typ; + Init_Type : Entity_Id; + Proc : Entity_Id; + + begin + pragma Assert (Constructor_Ref = Empty + or else Is_CPP_Constructor_Call (Constructor_Ref)); + + if No (Constructor_Ref) then + Proc := Base_Init_Proc (Typ); + else + Proc := Base_Init_Proc (Typ, Entity (Name (Constructor_Ref))); + end if; + + pragma Assert (Present (Proc)); + Init_Type := Etype (First_Formal (Proc)); + Full_Init_Type := Underlying_Type (Init_Type); + + -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars + -- is active (in which case we make the call anyway, since in the + -- actual compiled client it may be non null). + -- Also nothing to do for value types. + + if (Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars) + or else Is_Value_Type (Typ) + or else + (Is_Array_Type (Typ) and then Is_Value_Type (Component_Type (Typ))) + then + return Empty_List; + end if; + + -- Go to full view if private type. In the case of successive + -- private derivations, this can require more than one step. + + while Is_Private_Type (Full_Type) + and then Present (Full_View (Full_Type)) + loop + Full_Type := Full_View (Full_Type); + end loop; + + -- If Typ is derived, the procedure is the initialization procedure for + -- the root type. Wrap the argument in an conversion to make it type + -- honest. Actually it isn't quite type honest, because there can be + -- conflicts of views in the private type case. That is why we set + -- Conversion_OK in the conversion node. + + if (Is_Record_Type (Typ) + or else Is_Array_Type (Typ) + or else Is_Private_Type (Typ)) + and then Init_Type /= Base_Type (Typ) + then + First_Arg := OK_Convert_To (Etype (Init_Type), Id_Ref); + Set_Etype (First_Arg, Init_Type); + + else + First_Arg := Id_Ref; + end if; + + Args := New_List (Convert_Concurrent (First_Arg, Typ)); + + -- In the tasks case, add _Master as the value of the _Master parameter + -- and _Chain as the value of the _Chain parameter. At the outer level, + -- these will be variables holding the corresponding values obtained + -- from GNARL. At inner levels, they will be the parameters passed down + -- through the outer routines. + + if Has_Task (Full_Type) then + if Restriction_Active (No_Task_Hierarchy) then + Append_To (Args, + New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc)); + else + Append_To (Args, Make_Identifier (Loc, Name_uMaster)); + end if; + + Append_To (Args, Make_Identifier (Loc, Name_uChain)); + + -- Ada 2005 (AI-287): In case of default initialized components + -- with tasks, we generate a null string actual parameter. + -- This is just a workaround that must be improved later??? + + if With_Default_Init then + Append_To (Args, + Make_String_Literal (Loc, + Strval => "")); + + else + Decls := + Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type, In_Init_Proc); + Decl := Last (Decls); + + Append_To (Args, + New_Occurrence_Of (Defining_Identifier (Decl), Loc)); + Append_List (Decls, Res); + end if; + + else + Decls := No_List; + Decl := Empty; + end if; + + -- Add discriminant values if discriminants are present + + if Has_Discriminants (Full_Init_Type) then + Discr := First_Discriminant (Full_Init_Type); + + while Present (Discr) loop + + -- If this is a discriminated concurrent type, the init_proc + -- for the corresponding record is being called. Use that type + -- directly to find the discriminant value, to handle properly + -- intervening renamed discriminants. + + declare + T : Entity_Id := Full_Type; + + begin + if Is_Protected_Type (T) then + T := Corresponding_Record_Type (T); + + elsif Is_Private_Type (T) + and then Present (Underlying_Full_View (T)) + and then Is_Protected_Type (Underlying_Full_View (T)) + then + T := Corresponding_Record_Type (Underlying_Full_View (T)); + end if; + + Arg := + Get_Discriminant_Value ( + Discr, + T, + Discriminant_Constraint (Full_Type)); + end; + + if In_Init_Proc then + + -- Replace any possible references to the discriminant in the + -- call to the record initialization procedure with references + -- to the appropriate formal parameter. + + if Nkind (Arg) = N_Identifier + and then Ekind (Entity (Arg)) = E_Discriminant + then + Arg := New_Reference_To (Discriminal (Entity (Arg)), Loc); + + -- Case of access discriminants. We replace the reference + -- to the type by a reference to the actual object + + elsif Nkind (Arg) = N_Attribute_Reference + and then Is_Access_Type (Etype (Arg)) + and then Is_Entity_Name (Prefix (Arg)) + and then Is_Type (Entity (Prefix (Arg))) + then + Arg := + Make_Attribute_Reference (Loc, + Prefix => New_Copy (Prefix (Id_Ref)), + Attribute_Name => Name_Unrestricted_Access); + + -- Otherwise make a copy of the default expression. Note that + -- we use the current Sloc for this, because we do not want the + -- call to appear to be at the declaration point. Within the + -- expression, replace discriminants with their discriminals. + + else + Arg := + New_Copy_Tree (Arg, Map => Discr_Map, New_Sloc => Loc); + end if; + + else + if Is_Constrained (Full_Type) then + Arg := Duplicate_Subexpr_No_Checks (Arg); + else + -- The constraints come from the discriminant default exps, + -- they must be reevaluated, so we use New_Copy_Tree but we + -- ensure the proper Sloc (for any embedded calls). + + Arg := New_Copy_Tree (Arg, New_Sloc => Loc); + end if; + end if; + + -- Ada 2005 (AI-287): In case of default initialized components, + -- if the component is constrained with a discriminant of the + -- enclosing type, we need to generate the corresponding selected + -- component node to access the discriminant value. In other cases + -- this is not required, either because we are inside the init + -- proc and we use the corresponding formal, or else because the + -- component is constrained by an expression. + + if With_Default_Init + and then Nkind (Id_Ref) = N_Selected_Component + and then Nkind (Arg) = N_Identifier + and then Ekind (Entity (Arg)) = E_Discriminant + then + Append_To (Args, + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Prefix (Id_Ref)), + Selector_Name => Arg)); + else + Append_To (Args, Arg); + end if; + + Next_Discriminant (Discr); + end loop; + end if; + + -- If this is a call to initialize the parent component of a derived + -- tagged type, indicate that the tag should not be set in the parent. + + if Is_Tagged_Type (Full_Init_Type) + and then not Is_CPP_Class (Full_Init_Type) + and then Nkind (Id_Ref) = N_Selected_Component + and then Chars (Selector_Name (Id_Ref)) = Name_uParent + then + Append_To (Args, New_Occurrence_Of (Standard_False, Loc)); + + elsif Present (Constructor_Ref) then + Append_List_To (Args, + New_Copy_List (Parameter_Associations (Constructor_Ref))); + end if; + + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Proc, Loc), + Parameter_Associations => Args)); + + if Needs_Finalization (Typ) + and then Nkind (Id_Ref) = N_Selected_Component + then + if Chars (Selector_Name (Id_Ref)) /= Name_uParent then + Append_List_To (Res, + Make_Init_Call ( + Ref => New_Copy_Tree (First_Arg), + Typ => Typ, + Flist_Ref => + Find_Final_List (Typ, New_Copy_Tree (First_Arg)), + With_Attach => Make_Integer_Literal (Loc, 1))); + + -- If the enclosing type is an extension with new controlled + -- components, it has his own record controller. If the parent + -- also had a record controller, attach it to the new one. + + -- Build_Init_Statements relies on the fact that in this specific + -- case the last statement of the result is the attach call to + -- the controller. If this is changed, it must be synchronized. + + elsif Present (Enclos_Type) + and then Has_New_Controlled_Component (Enclos_Type) + and then Has_Controlled_Component (Typ) + then + if Is_Immutably_Limited_Type (Typ) then + Controller_Typ := RTE (RE_Limited_Record_Controller); + else + Controller_Typ := RTE (RE_Record_Controller); + end if; + + Append_List_To (Res, + Make_Init_Call ( + Ref => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (First_Arg), + Selector_Name => Make_Identifier (Loc, Name_uController)), + Typ => Controller_Typ, + Flist_Ref => Find_Final_List (Typ, New_Copy_Tree (First_Arg)), + With_Attach => Make_Integer_Literal (Loc, 1))); + end if; + end if; + + return Res; + + exception + when RE_Not_Available => + return Empty_List; + end Build_Initialization_Call; + + --------------------------- + -- Build_Master_Renaming -- + --------------------------- + + function Build_Master_Renaming + (N : Node_Id; + T : Entity_Id) return Entity_Id + is + Loc : constant Source_Ptr := Sloc (N); + M_Id : Entity_Id; + Decl : Node_Id; + + begin + -- Nothing to do if there is no task hierarchy + + if Restriction_Active (No_Task_Hierarchy) then + return Empty; + end if; + + M_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (T), 'M')); + + Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => M_Id, + Subtype_Mark => New_Reference_To (RTE (RE_Master_Id), Loc), + Name => Make_Identifier (Loc, Name_uMaster)); + Insert_Before (N, Decl); + Analyze (Decl); + return M_Id; + + exception + when RE_Not_Available => + return Empty; + end Build_Master_Renaming; + + --------------------------- + -- Build_Master_Renaming -- + --------------------------- + + procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id) is + M_Id : Entity_Id; + + begin + -- Nothing to do if there is no task hierarchy + + if Restriction_Active (No_Task_Hierarchy) then + return; + end if; + + M_Id := Build_Master_Renaming (N, T); + Set_Master_Id (T, M_Id); + + exception + when RE_Not_Available => + return; + end Build_Master_Renaming; + + ---------------------------- + -- Build_Record_Init_Proc -- + ---------------------------- + + procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id) is + Loc : Source_Ptr := Sloc (N); + Discr_Map : constant Elist_Id := New_Elmt_List; + Proc_Id : Entity_Id; + Rec_Type : Entity_Id; + Set_Tag : Entity_Id := Empty; + + function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id; + -- Build a assignment statement node which assigns to record component + -- its default expression if defined. The assignment left hand side is + -- marked Assignment_OK so that initialization of limited private + -- records works correctly, Return also the adjustment call for + -- controlled objects + + procedure Build_Discriminant_Assignments (Statement_List : List_Id); + -- If the record has discriminants, adds assignment statements to + -- statement list to initialize the discriminant values from the + -- arguments of the initialization procedure. + + function Build_Init_Statements (Comp_List : Node_Id) return List_Id; + -- Build a list representing a sequence of statements which initialize + -- components of the given component list. This may involve building + -- case statements for the variant parts. + + function Build_Init_Call_Thru (Parameters : List_Id) return List_Id; + -- Given a non-tagged type-derivation that declares discriminants, + -- such as + -- + -- type R (R1, R2 : Integer) is record ... end record; + -- + -- type D (D1 : Integer) is new R (1, D1); + -- + -- we make the _init_proc of D be + -- + -- procedure _init_proc(X : D; D1 : Integer) is + -- begin + -- _init_proc( R(X), 1, D1); + -- end _init_proc; + -- + -- This function builds the call statement in this _init_proc. + + procedure Build_CPP_Init_Procedure; + -- Build the tree corresponding to the procedure specification and body + -- of the IC procedure that initializes the C++ part of the dispatch + -- table of an Ada tagged type that is a derivation of a CPP type. + -- Install it as the CPP_Init TSS. + + procedure Build_Init_Procedure; + -- Build the tree corresponding to the procedure specification and body + -- of the initialization procedure (by calling all the preceding + -- auxiliary routines), and install it as the _init TSS. + + procedure Build_Offset_To_Top_Functions; + -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec + -- and body of the Offset_To_Top function that is generated when the + -- parent of a type with discriminants has secondary dispatch tables. + + procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id); + -- Add range checks to components of discriminated records. S is a + -- subtype indication of a record component. Check_List is a list + -- to which the check actions are appended. + + function Component_Needs_Simple_Initialization + (T : Entity_Id) return Boolean; + -- Determines if a component needs simple initialization, given its type + -- T. This is the same as Needs_Simple_Initialization except for the + -- following difference: the types Tag and Interface_Tag, that are + -- access types which would normally require simple initialization to + -- null, do not require initialization as components, since they are + -- explicitly initialized by other means. + + procedure Constrain_Array + (SI : Node_Id; + Check_List : List_Id); + -- Called from Build_Record_Checks. + -- Apply a list of index constraints to an unconstrained array type. + -- The first parameter is the entity for the resulting subtype. + -- Check_List is a list to which the check actions are appended. + + procedure Constrain_Index + (Index : Node_Id; + S : Node_Id; + Check_List : List_Id); + -- Process an index constraint in a constrained array declaration. + -- The constraint can be a subtype name, or a range with or without + -- an explicit subtype mark. The index is the corresponding index of the + -- unconstrained array. S is the range expression. Check_List is a list + -- to which the check actions are appended (called from + -- Build_Record_Checks). + + function Parent_Subtype_Renaming_Discrims return Boolean; + -- Returns True for base types N that rename discriminants, else False + + function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean; + -- Determines whether a record initialization procedure needs to be + -- generated for the given record type. + + ---------------------- + -- Build_Assignment -- + ---------------------- + + function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is + Exp : Node_Id := N; + Lhs : Node_Id; + Typ : constant Entity_Id := Underlying_Type (Etype (Id)); + Kind : Node_Kind := Nkind (N); + Res : List_Id; + + begin + Loc := Sloc (N); + Lhs := + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => New_Occurrence_Of (Id, Loc)); + Set_Assignment_OK (Lhs); + + -- Case of an access attribute applied to the current instance. + -- Replace the reference to the type by a reference to the actual + -- object. (Note that this handles the case of the top level of + -- the expression being given by such an attribute, but does not + -- cover uses nested within an initial value expression. Nested + -- uses are unlikely to occur in practice, but are theoretically + -- possible. It is not clear how to handle them without fully + -- traversing the expression. ??? + + if Kind = N_Attribute_Reference + and then (Attribute_Name (N) = Name_Unchecked_Access + or else + Attribute_Name (N) = Name_Unrestricted_Access) + and then Is_Entity_Name (Prefix (N)) + and then Is_Type (Entity (Prefix (N))) + and then Entity (Prefix (N)) = Rec_Type + then + Exp := + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Attribute_Name => Name_Unrestricted_Access); + end if; + + -- Take a copy of Exp to ensure that later copies of this component + -- declaration in derived types see the original tree, not a node + -- rewritten during expansion of the init_proc. If the copy contains + -- itypes, the scope of the new itypes is the init_proc being built. + + Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id); + + Res := New_List ( + Make_Assignment_Statement (Loc, + Name => Lhs, + Expression => Exp)); + + Set_No_Ctrl_Actions (First (Res)); + + -- Adjust the tag if tagged (because of possible view conversions). + -- Suppress the tag adjustment when VM_Target because VM tags are + -- represented implicitly in objects. + + if Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then + Append_To (Res, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Lhs, New_Scope => Proc_Id), + Selector_Name => + New_Reference_To (First_Tag_Component (Typ), Loc)), + + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)))); + end if; + + -- Adjust the component if controlled except if it is an aggregate + -- that will be expanded inline. + + if Kind = N_Qualified_Expression then + Kind := Nkind (Expression (N)); + end if; + + if Needs_Finalization (Typ) + and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate)) + and then not Is_Immutably_Limited_Type (Typ) + then + declare + Ref : constant Node_Id := + New_Copy_Tree (Lhs, New_Scope => Proc_Id); + begin + Append_List_To (Res, + Make_Adjust_Call ( + Ref => Ref, + Typ => Etype (Id), + Flist_Ref => Find_Final_List (Etype (Id), Ref), + With_Attach => Make_Integer_Literal (Loc, 1))); + end; + end if; + + return Res; + + exception + when RE_Not_Available => + return Empty_List; + end Build_Assignment; + + ------------------------------------ + -- Build_Discriminant_Assignments -- + ------------------------------------ + + procedure Build_Discriminant_Assignments (Statement_List : List_Id) is + D : Entity_Id; + Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type); + + begin + if Has_Discriminants (Rec_Type) + and then not Is_Unchecked_Union (Rec_Type) + then + D := First_Discriminant (Rec_Type); + + while Present (D) loop + + -- Don't generate the assignment for discriminants in derived + -- tagged types if the discriminant is a renaming of some + -- ancestor discriminant. This initialization will be done + -- when initializing the _parent field of the derived record. + + if Is_Tagged and then + Present (Corresponding_Discriminant (D)) + then + null; + + else + Loc := Sloc (D); + Append_List_To (Statement_List, + Build_Assignment (D, + New_Reference_To (Discriminal (D), Loc))); + end if; + + Next_Discriminant (D); + end loop; + end if; + end Build_Discriminant_Assignments; + + -------------------------- + -- Build_Init_Call_Thru -- + -------------------------- + + function Build_Init_Call_Thru (Parameters : List_Id) return List_Id is + Parent_Proc : constant Entity_Id := + Base_Init_Proc (Etype (Rec_Type)); + + Parent_Type : constant Entity_Id := + Etype (First_Formal (Parent_Proc)); + + Uparent_Type : constant Entity_Id := + Underlying_Type (Parent_Type); + + First_Discr_Param : Node_Id; + + Parent_Discr : Entity_Id; + First_Arg : Node_Id; + Args : List_Id; + Arg : Node_Id; + Res : List_Id; + + begin + -- First argument (_Init) is the object to be initialized. + -- ??? not sure where to get a reasonable Loc for First_Arg + + First_Arg := + OK_Convert_To (Parent_Type, + New_Reference_To (Defining_Identifier (First (Parameters)), Loc)); + + Set_Etype (First_Arg, Parent_Type); + + Args := New_List (Convert_Concurrent (First_Arg, Rec_Type)); + + -- In the tasks case, + -- add _Master as the value of the _Master parameter + -- add _Chain as the value of the _Chain parameter. + -- add _Task_Name as the value of the _Task_Name parameter. + -- At the outer level, these will be variables holding the + -- corresponding values obtained from GNARL or the expander. + -- + -- At inner levels, they will be the parameters passed down through + -- the outer routines. + + First_Discr_Param := Next (First (Parameters)); + + if Has_Task (Rec_Type) then + if Restriction_Active (No_Task_Hierarchy) then + Append_To (Args, + New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc)); + else + Append_To (Args, Make_Identifier (Loc, Name_uMaster)); + end if; + + Append_To (Args, Make_Identifier (Loc, Name_uChain)); + Append_To (Args, Make_Identifier (Loc, Name_uTask_Name)); + First_Discr_Param := Next (Next (Next (First_Discr_Param))); + end if; + + -- Append discriminant values + + if Has_Discriminants (Uparent_Type) then + pragma Assert (not Is_Tagged_Type (Uparent_Type)); + + Parent_Discr := First_Discriminant (Uparent_Type); + while Present (Parent_Discr) loop + + -- Get the initial value for this discriminant + -- ??? needs to be cleaned up to use parent_Discr_Constr + -- directly. + + declare + Discr_Value : Elmt_Id := + First_Elmt + (Stored_Constraint (Rec_Type)); + + Discr : Entity_Id := + First_Stored_Discriminant (Uparent_Type); + begin + while Original_Record_Component (Parent_Discr) /= Discr loop + Next_Stored_Discriminant (Discr); + Next_Elmt (Discr_Value); + end loop; + + Arg := Node (Discr_Value); + end; + + -- Append it to the list + + if Nkind (Arg) = N_Identifier + and then Ekind (Entity (Arg)) = E_Discriminant + then + Append_To (Args, + New_Reference_To (Discriminal (Entity (Arg)), Loc)); + + -- Case of access discriminants. We replace the reference + -- to the type by a reference to the actual object. + + -- Is above comment right??? Use of New_Copy below seems mighty + -- suspicious ??? + + else + Append_To (Args, New_Copy (Arg)); + end if; + + Next_Discriminant (Parent_Discr); + end loop; + end if; + + Res := + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Parent_Proc, Loc), + Parameter_Associations => Args)); + + return Res; + end Build_Init_Call_Thru; + + ----------------------------------- + -- Build_Offset_To_Top_Functions -- + ----------------------------------- + + procedure Build_Offset_To_Top_Functions is + + procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id); + -- Generate: + -- function Fxx (O : in Rec_Typ) return Storage_Offset is + -- begin + -- return O.Iface_Comp'Position; + -- end Fxx; + + ---------------------------------- + -- Build_Offset_To_Top_Function -- + ---------------------------------- + + procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id) is + Body_Node : Node_Id; + Func_Id : Entity_Id; + Spec_Node : Node_Id; + + begin + Func_Id := Make_Temporary (Loc, 'F'); + Set_DT_Offset_To_Top_Func (Iface_Comp, Func_Id); + + -- Generate + -- function Fxx (O : in Rec_Typ) return Storage_Offset; + + Spec_Node := New_Node (N_Function_Specification, Loc); + Set_Defining_Unit_Name (Spec_Node, Func_Id); + Set_Parameter_Specifications (Spec_Node, New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), + In_Present => True, + Parameter_Type => New_Reference_To (Rec_Type, Loc)))); + Set_Result_Definition (Spec_Node, + New_Reference_To (RTE (RE_Storage_Offset), Loc)); + + -- Generate + -- function Fxx (O : in Rec_Typ) return Storage_Offset is + -- begin + -- return O.Iface_Comp'Position; + -- end Fxx; + + Body_Node := New_Node (N_Subprogram_Body, Loc); + Set_Specification (Body_Node, Spec_Node); + Set_Declarations (Body_Node, New_List); + Set_Handled_Statement_Sequence (Body_Node, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uO), + Selector_Name => + New_Reference_To (Iface_Comp, Loc)), + Attribute_Name => Name_Position))))); + + Set_Ekind (Func_Id, E_Function); + Set_Mechanism (Func_Id, Default_Mechanism); + Set_Is_Internal (Func_Id, True); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Func_Id); + end if; + + Analyze (Body_Node); + + Append_Freeze_Action (Rec_Type, Body_Node); + end Build_Offset_To_Top_Function; + + -- Local variables + + Ifaces_Comp_List : Elist_Id; + Iface_Comp_Elmt : Elmt_Id; + Iface_Comp : Node_Id; + + -- Start of processing for Build_Offset_To_Top_Functions + + begin + -- Offset_To_Top_Functions are built only for derivations of types + -- with discriminants that cover interface types. + -- Nothing is needed either in case of virtual machines, since + -- interfaces are handled directly by the VM. + + if not Is_Tagged_Type (Rec_Type) + or else Etype (Rec_Type) = Rec_Type + or else not Has_Discriminants (Etype (Rec_Type)) + or else not Tagged_Type_Expansion + then + return; + end if; + + Collect_Interface_Components (Rec_Type, Ifaces_Comp_List); + + -- For each interface type with secondary dispatch table we generate + -- the Offset_To_Top_Functions (required to displace the pointer in + -- interface conversions) + + Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List); + while Present (Iface_Comp_Elmt) loop + Iface_Comp := Node (Iface_Comp_Elmt); + pragma Assert (Is_Interface (Related_Type (Iface_Comp))); + + -- If the interface is a parent of Rec_Type it shares the primary + -- dispatch table and hence there is no need to build the function + + if not Is_Ancestor (Related_Type (Iface_Comp), Rec_Type) then + Build_Offset_To_Top_Function (Iface_Comp); + end if; + + Next_Elmt (Iface_Comp_Elmt); + end loop; + end Build_Offset_To_Top_Functions; + + ------------------------------ + -- Build_CPP_Init_Procedure -- + ------------------------------ + + procedure Build_CPP_Init_Procedure is + Body_Node : Node_Id; + Body_Stmts : List_Id; + Flag_Id : Entity_Id; + Flag_Decl : Node_Id; + Handled_Stmt_Node : Node_Id; + Init_Tags_List : List_Id; + Proc_Id : Entity_Id; + Proc_Spec_Node : Node_Id; + + begin + -- Check cases requiring no IC routine + + if not Is_CPP_Class (Root_Type (Rec_Type)) + or else Is_CPP_Class (Rec_Type) + or else CPP_Num_Prims (Rec_Type) = 0 + or else not Tagged_Type_Expansion + or else No_Run_Time_Mode + then + return; + end if; + + -- Generate: + + -- Flag : Boolean := False; + -- + -- procedure Typ_IC is + -- begin + -- if not Flag then + -- Copy C++ dispatch table slots from parent + -- Update C++ slots of overridden primitives + -- end if; + -- end; + + Flag_Id := Make_Temporary (Loc, 'F'); + + Flag_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Flag_Id, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc), + Expression => + New_Reference_To (Standard_True, Loc)); + + Analyze (Flag_Decl); + Append_Freeze_Action (Rec_Type, Flag_Decl); + + Body_Stmts := New_List; + Body_Node := New_Node (N_Subprogram_Body, Loc); + + Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc); + + Proc_Id := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name (Rec_Type, TSS_CPP_Init_Proc)); + + Set_Ekind (Proc_Id, E_Procedure); + Set_Is_Internal (Proc_Id); + + Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id); + + Set_Parameter_Specifications (Proc_Spec_Node, New_List); + Set_Specification (Body_Node, Proc_Spec_Node); + Set_Declarations (Body_Node, New_List); + + Init_Tags_List := Build_Inherit_CPP_Prims (Rec_Type); + + Append_To (Init_Tags_List, + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Flag_Id, Loc), + Expression => + New_Reference_To (Standard_False, Loc))); + + Append_To (Body_Stmts, + Make_If_Statement (Loc, + Condition => New_Occurrence_Of (Flag_Id, Loc), + Then_Statements => Init_Tags_List)); + + Handled_Stmt_Node := + New_Node (N_Handled_Sequence_Of_Statements, Loc); + Set_Statements (Handled_Stmt_Node, Body_Stmts); + Set_Exception_Handlers (Handled_Stmt_Node, No_List); + Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Proc_Id); + end if; + + -- Associate CPP_Init_Proc with type + + Set_Init_Proc (Rec_Type, Proc_Id); + end Build_CPP_Init_Procedure; + + -------------------------- + -- Build_Init_Procedure -- + -------------------------- + + procedure Build_Init_Procedure is + Body_Node : Node_Id; + Handled_Stmt_Node : Node_Id; + Parameters : List_Id; + Proc_Spec_Node : Node_Id; + Body_Stmts : List_Id; + Record_Extension_Node : Node_Id; + Init_Tags_List : List_Id; + + begin + Body_Stmts := New_List; + Body_Node := New_Node (N_Subprogram_Body, Loc); + Set_Ekind (Proc_Id, E_Procedure); + + Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc); + Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id); + + Parameters := Init_Formals (Rec_Type); + Append_List_To (Parameters, + Build_Discriminant_Formals (Rec_Type, True)); + + -- For tagged types, we add a flag to indicate whether the routine + -- is called to initialize a parent component in the init_proc of + -- a type extension. If the flag is false, we do not set the tag + -- because it has been set already in the extension. + + if Is_Tagged_Type (Rec_Type) then + Set_Tag := Make_Temporary (Loc, 'P'); + + Append_To (Parameters, + Make_Parameter_Specification (Loc, + Defining_Identifier => Set_Tag, + Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), + Expression => New_Occurrence_Of (Standard_True, Loc))); + end if; + + Set_Parameter_Specifications (Proc_Spec_Node, Parameters); + Set_Specification (Body_Node, Proc_Spec_Node); + Set_Declarations (Body_Node, New_List); + + if Parent_Subtype_Renaming_Discrims then + + -- N is a Derived_Type_Definition that renames the parameters + -- of the ancestor type. We initialize it by expanding our + -- discriminants and call the ancestor _init_proc with a + -- type-converted object + + Append_List_To (Body_Stmts, + Build_Init_Call_Thru (Parameters)); + + elsif Nkind (Type_Definition (N)) = N_Record_Definition then + Build_Discriminant_Assignments (Body_Stmts); + + if not Null_Present (Type_Definition (N)) then + Append_List_To (Body_Stmts, + Build_Init_Statements ( + Component_List (Type_Definition (N)))); + end if; + + else + -- N is a Derived_Type_Definition with a possible non-empty + -- extension. The initialization of a type extension consists + -- in the initialization of the components in the extension. + + Build_Discriminant_Assignments (Body_Stmts); + + Record_Extension_Node := + Record_Extension_Part (Type_Definition (N)); + + if not Null_Present (Record_Extension_Node) then + declare + Stmts : constant List_Id := + Build_Init_Statements ( + Component_List (Record_Extension_Node)); + + begin + -- The parent field must be initialized first because + -- the offset of the new discriminants may depend on it + + Prepend_To (Body_Stmts, Remove_Head (Stmts)); + Append_List_To (Body_Stmts, Stmts); + end; + end if; + end if; + + -- Add here the assignment to instantiate the Tag + + -- The assignment corresponds to the code: + + -- _Init._Tag := Typ'Tag; + + -- Suppress the tag assignment when VM_Target because VM tags are + -- represented implicitly in objects. It is also suppressed in case + -- of CPP_Class types because in this case the tag is initialized in + -- the C++ side. + + if Is_Tagged_Type (Rec_Type) + and then Tagged_Type_Expansion + and then not No_Run_Time_Mode + then + -- Case 1: Ada tagged types with no CPP ancestor. Set the tags of + -- the actual object and invoke the IP of the parent (in this + -- order). The tag must be initialized before the call to the IP + -- of the parent and the assignments to other components because + -- the initial value of the components may depend on the tag (eg. + -- through a dispatching operation on an access to the current + -- type). The tag assignment is not done when initializing the + -- parent component of a type extension, because in that case the + -- tag is set in the extension. + + if not Is_CPP_Class (Root_Type (Rec_Type)) then + + -- Initialize the primary tag component + + Init_Tags_List := New_List ( + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => + New_Reference_To + (First_Tag_Component (Rec_Type), Loc)), + Expression => + New_Reference_To + (Node + (First_Elmt (Access_Disp_Table (Rec_Type))), Loc))); + + -- Ada 2005 (AI-251): Initialize the secondary tags components + -- located at fixed positions (tags whose position depends on + -- variable size components are initialized later ---see below) + + if Ada_Version >= Ada_2005 + and then not Is_Interface (Rec_Type) + and then Has_Interfaces (Rec_Type) + then + Init_Secondary_Tags + (Typ => Rec_Type, + Target => Make_Identifier (Loc, Name_uInit), + Stmts_List => Init_Tags_List, + Fixed_Comps => True, + Variable_Comps => False); + end if; + + Prepend_To (Body_Stmts, + Make_If_Statement (Loc, + Condition => New_Occurrence_Of (Set_Tag, Loc), + Then_Statements => Init_Tags_List)); + + -- Case 2: CPP type. The imported C++ constructor takes care of + -- tags initialization. No action needed here because the IP + -- is built by Set_CPP_Constructors; in this case the IP is a + -- wrapper that invokes the C++ constructor and copies the C++ + -- tags locally. Done to inherit the C++ slots in Ada derivations + -- (see case 3). + + elsif Is_CPP_Class (Rec_Type) then + pragma Assert (False); + null; + + -- Case 3: Combined hierarchy containing C++ types and Ada tagged + -- type derivations. Derivations of imported C++ classes add a + -- complication, because we cannot inhibit tag setting in the + -- constructor for the parent. Hence we initialize the tag after + -- the call to the parent IP (that is, in reverse order compared + -- with pure Ada hierarchies ---see comment on case 1). + + else + -- Initialize the primary tag + + Init_Tags_List := New_List ( + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => + New_Reference_To + (First_Tag_Component (Rec_Type), Loc)), + Expression => + New_Reference_To + (Node + (First_Elmt (Access_Disp_Table (Rec_Type))), Loc))); + + -- Ada 2005 (AI-251): Initialize the secondary tags components + -- located at fixed positions (tags whose position depends on + -- variable size components are initialized later ---see below) + + if Ada_Version >= Ada_2005 + and then not Is_Interface (Rec_Type) + and then Has_Interfaces (Rec_Type) + then + Init_Secondary_Tags + (Typ => Rec_Type, + Target => Make_Identifier (Loc, Name_uInit), + Stmts_List => Init_Tags_List, + Fixed_Comps => True, + Variable_Comps => False); + end if; + + -- Initialize the tag component after invocation of parent IP. + + -- Generate: + -- parent_IP(_init.parent); // Invokes the C++ constructor + -- [ typIC; ] // Inherit C++ slots from parent + -- init_tags + + declare + Ins_Nod : Node_Id; + + begin + -- Search for the call to the IP of the parent. We assume + -- that the first init_proc call is for the parent. + + Ins_Nod := First (Body_Stmts); + while Present (Next (Ins_Nod)) + and then (Nkind (Ins_Nod) /= N_Procedure_Call_Statement + or else not Is_Init_Proc (Name (Ins_Nod))) + loop + Next (Ins_Nod); + end loop; + + -- The IC routine copies the inherited slots of the C+ part + -- of the dispatch table from the parent and updates the + -- overridden C++ slots. + + if CPP_Num_Prims (Rec_Type) > 0 then + declare + Init_DT : Entity_Id; + New_Nod : Node_Id; + + begin + Init_DT := CPP_Init_Proc (Rec_Type); + pragma Assert (Present (Init_DT)); + + New_Nod := + Make_Procedure_Call_Statement (Loc, + New_Reference_To (Init_DT, Loc)); + Insert_After (Ins_Nod, New_Nod); + + -- Update location of init tag statements + + Ins_Nod := New_Nod; + end; + end if; + + Insert_List_After (Ins_Nod, Init_Tags_List); + end; + end if; + + -- Ada 2005 (AI-251): Initialize the secondary tag components + -- located at variable positions. We delay the generation of this + -- code until here because the value of the attribute 'Position + -- applied to variable size components of the parent type that + -- depend on discriminants is only safely read at runtime after + -- the parent components have been initialized. + + if Ada_Version >= Ada_2005 + and then not Is_Interface (Rec_Type) + and then Has_Interfaces (Rec_Type) + and then Has_Discriminants (Etype (Rec_Type)) + and then Is_Variable_Size_Record (Etype (Rec_Type)) + then + Init_Tags_List := New_List; + + Init_Secondary_Tags + (Typ => Rec_Type, + Target => Make_Identifier (Loc, Name_uInit), + Stmts_List => Init_Tags_List, + Fixed_Comps => False, + Variable_Comps => True); + + if Is_Non_Empty_List (Init_Tags_List) then + Append_List_To (Body_Stmts, Init_Tags_List); + end if; + end if; + end if; + + Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc); + Set_Statements (Handled_Stmt_Node, Body_Stmts); + Set_Exception_Handlers (Handled_Stmt_Node, No_List); + Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Proc_Id); + end if; + + -- Associate Init_Proc with type, and determine if the procedure + -- is null (happens because of the Initialize_Scalars pragma case, + -- where we have to generate a null procedure in case it is called + -- by a client with Initialize_Scalars set). Such procedures have + -- to be generated, but do not have to be called, so we mark them + -- as null to suppress the call. + + Set_Init_Proc (Rec_Type, Proc_Id); + + if List_Length (Body_Stmts) = 1 + + -- We must skip SCIL nodes because they may have been added to this + -- list by Insert_Actions. + + and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement + and then VM_Target = No_VM + then + -- Even though the init proc may be null at this time it might get + -- some stuff added to it later by the VM backend. + + Set_Is_Null_Init_Proc (Proc_Id); + end if; + end Build_Init_Procedure; + + --------------------------- + -- Build_Init_Statements -- + --------------------------- + + function Build_Init_Statements (Comp_List : Node_Id) return List_Id is + Check_List : constant List_Id := New_List; + Alt_List : List_Id; + Decl : Node_Id; + Id : Entity_Id; + Names : Node_Id; + Statement_List : List_Id; + Stmts : List_Id; + Typ : Entity_Id; + Variant : Node_Id; + + Per_Object_Constraint_Components : Boolean; + + function Has_Access_Constraint (E : Entity_Id) return Boolean; + -- Components with access discriminants that depend on the current + -- instance must be initialized after all other components. + + --------------------------- + -- Has_Access_Constraint -- + --------------------------- + + function Has_Access_Constraint (E : Entity_Id) return Boolean is + Disc : Entity_Id; + T : constant Entity_Id := Etype (E); + + begin + if Has_Per_Object_Constraint (E) + and then Has_Discriminants (T) + then + Disc := First_Discriminant (T); + while Present (Disc) loop + if Is_Access_Type (Etype (Disc)) then + return True; + end if; + + Next_Discriminant (Disc); + end loop; + + return False; + else + return False; + end if; + end Has_Access_Constraint; + + -- Start of processing for Build_Init_Statements + + begin + if Null_Present (Comp_List) then + return New_List (Make_Null_Statement (Loc)); + end if; + + Statement_List := New_List; + + -- Loop through visible declarations of task types and protected + -- types moving any expanded code from the spec to the body of the + -- init procedure. + + if Is_Task_Record_Type (Rec_Type) + or else Is_Protected_Record_Type (Rec_Type) + then + declare + Decl : constant Node_Id := + Parent (Corresponding_Concurrent_Type (Rec_Type)); + Def : Node_Id; + N1 : Node_Id; + N2 : Node_Id; + + begin + if Is_Task_Record_Type (Rec_Type) then + Def := Task_Definition (Decl); + else + Def := Protected_Definition (Decl); + end if; + + if Present (Def) then + N1 := First (Visible_Declarations (Def)); + while Present (N1) loop + N2 := N1; + N1 := Next (N1); + + if Nkind (N2) in N_Statement_Other_Than_Procedure_Call + or else Nkind (N2) in N_Raise_xxx_Error + or else Nkind (N2) = N_Procedure_Call_Statement + then + Append_To (Statement_List, + New_Copy_Tree (N2, New_Scope => Proc_Id)); + Rewrite (N2, Make_Null_Statement (Sloc (N2))); + Analyze (N2); + end if; + end loop; + end if; + end; + end if; + + -- Loop through components, skipping pragmas, in 2 steps. The first + -- step deals with regular components. The second step deals with + -- components have per object constraints, and no explicit initia- + -- lization. + + Per_Object_Constraint_Components := False; + + -- First step : regular components + + Decl := First_Non_Pragma (Component_Items (Comp_List)); + while Present (Decl) loop + Loc := Sloc (Decl); + Build_Record_Checks + (Subtype_Indication (Component_Definition (Decl)), Check_List); + + Id := Defining_Identifier (Decl); + Typ := Etype (Id); + + if Has_Access_Constraint (Id) + and then No (Expression (Decl)) + then + -- Skip processing for now and ask for a second pass + + Per_Object_Constraint_Components := True; + + else + -- Case of explicit initialization + + if Present (Expression (Decl)) then + if Is_CPP_Constructor_Call (Expression (Decl)) then + Stmts := + Build_Initialization_Call + (Loc, + Id_Ref => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uInit), + Selector_Name => New_Occurrence_Of (Id, Loc)), + Typ => Typ, + In_Init_Proc => True, + Enclos_Type => Rec_Type, + Discr_Map => Discr_Map, + Constructor_Ref => Expression (Decl)); + else + Stmts := Build_Assignment (Id, Expression (Decl)); + end if; + + -- Case of composite component with its own Init_Proc + + elsif not Is_Interface (Typ) + and then Has_Non_Null_Base_Init_Proc (Typ) + then + Stmts := + Build_Initialization_Call + (Loc, + Id_Ref => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => New_Occurrence_Of (Id, Loc)), + Typ => Typ, + In_Init_Proc => True, + Enclos_Type => Rec_Type, + Discr_Map => Discr_Map); + + Clean_Task_Names (Typ, Proc_Id); + + -- Case of component needing simple initialization + + elsif Component_Needs_Simple_Initialization (Typ) then + Stmts := + Build_Assignment + (Id, Get_Simple_Init_Val (Typ, N, Esize (Id))); + + -- Nothing needed for this case + + else + Stmts := No_List; + end if; + + if Present (Check_List) then + Append_List_To (Statement_List, Check_List); + end if; + + if Present (Stmts) then + + -- Add the initialization of the record controller before + -- the _Parent field is attached to it when the attachment + -- can occur. It does not work to simply initialize the + -- controller first: it must be initialized after the parent + -- if the parent holds discriminants that can be used to + -- compute the offset of the controller. We assume here that + -- the last statement of the initialization call is the + -- attachment of the parent (see Build_Initialization_Call) + + if Chars (Id) = Name_uController + and then Rec_Type /= Etype (Rec_Type) + and then Has_Controlled_Component (Etype (Rec_Type)) + and then Has_New_Controlled_Component (Rec_Type) + and then Present (Last (Statement_List)) + then + Insert_List_Before (Last (Statement_List), Stmts); + else + Append_List_To (Statement_List, Stmts); + end if; + end if; + end if; + + Next_Non_Pragma (Decl); + end loop; + + -- Set up tasks and protected object support. This needs to be done + -- before any component with a per-object access discriminant + -- constraint, or any variant part (which may contain such + -- components) is initialized, because the initialization of these + -- components may reference the enclosing concurrent object. + + -- For a task record type, add the task create call and calls + -- to bind any interrupt (signal) entries. + + if Is_Task_Record_Type (Rec_Type) then + + -- In the case of the restricted run time the ATCB has already + -- been preallocated. + + if Restricted_Profile then + Append_To (Statement_List, + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), + Expression => Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => Make_Identifier (Loc, Name_uATCB)), + Attribute_Name => Name_Unchecked_Access))); + end if; + + Append_To (Statement_List, Make_Task_Create_Call (Rec_Type)); + + -- Generate the statements which map a string entry name to a + -- task entry index. Note that the task may not have entries. + + if Entry_Names_OK then + Names := Build_Entry_Names (Rec_Type); + + if Present (Names) then + Append_To (Statement_List, Names); + end if; + end if; + + declare + Task_Type : constant Entity_Id := + Corresponding_Concurrent_Type (Rec_Type); + Task_Decl : constant Node_Id := Parent (Task_Type); + Task_Def : constant Node_Id := Task_Definition (Task_Decl); + Vis_Decl : Node_Id; + Ent : Entity_Id; + + begin + if Present (Task_Def) then + Vis_Decl := First (Visible_Declarations (Task_Def)); + while Present (Vis_Decl) loop + Loc := Sloc (Vis_Decl); + + if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then + if Get_Attribute_Id (Chars (Vis_Decl)) = + Attribute_Address + then + Ent := Entity (Name (Vis_Decl)); + + if Ekind (Ent) = E_Entry then + Append_To (Statement_List, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + RTE (RE_Bind_Interrupt_To_Entry), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uInit), + Selector_Name => + Make_Identifier (Loc, Name_uTask_Id)), + Entry_Index_Expression + (Loc, Ent, Empty, Task_Type), + Expression (Vis_Decl)))); + end if; + end if; + end if; + + Next (Vis_Decl); + end loop; + end if; + end; + end if; + + -- For a protected type, add statements generated by + -- Make_Initialize_Protection. + + if Is_Protected_Record_Type (Rec_Type) then + Append_List_To (Statement_List, + Make_Initialize_Protection (Rec_Type)); + + -- Generate the statements which map a string entry name to a + -- protected entry index. Note that the protected type may not + -- have entries. + + if Entry_Names_OK then + Names := Build_Entry_Names (Rec_Type); + + if Present (Names) then + Append_To (Statement_List, Names); + end if; + end if; + end if; + + if Per_Object_Constraint_Components then + + -- Second pass: components with per-object constraints + + Decl := First_Non_Pragma (Component_Items (Comp_List)); + while Present (Decl) loop + Loc := Sloc (Decl); + Id := Defining_Identifier (Decl); + Typ := Etype (Id); + + if Has_Access_Constraint (Id) + and then No (Expression (Decl)) + then + if Has_Non_Null_Base_Init_Proc (Typ) then + Append_List_To (Statement_List, + Build_Initialization_Call (Loc, + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => New_Occurrence_Of (Id, Loc)), + Typ, + In_Init_Proc => True, + Enclos_Type => Rec_Type, + Discr_Map => Discr_Map)); + + Clean_Task_Names (Typ, Proc_Id); + + elsif Component_Needs_Simple_Initialization (Typ) then + Append_List_To (Statement_List, + Build_Assignment + (Id, Get_Simple_Init_Val (Typ, N, Esize (Id)))); + end if; + end if; + + Next_Non_Pragma (Decl); + end loop; + end if; + + -- Process the variant part + + if Present (Variant_Part (Comp_List)) then + Alt_List := New_List; + Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); + while Present (Variant) loop + Loc := Sloc (Variant); + Append_To (Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_Copy_List (Discrete_Choices (Variant)), + Statements => + Build_Init_Statements (Component_List (Variant)))); + Next_Non_Pragma (Variant); + end loop; + + -- The expression of the case statement which is a reference + -- to one of the discriminants is replaced by the appropriate + -- formal parameter of the initialization procedure. + + Append_To (Statement_List, + Make_Case_Statement (Loc, + Expression => + New_Reference_To (Discriminal ( + Entity (Name (Variant_Part (Comp_List)))), Loc), + Alternatives => Alt_List)); + end if; + + -- If no initializations when generated for component declarations + -- corresponding to this Statement_List, append a null statement + -- to the Statement_List to make it a valid Ada tree. + + if Is_Empty_List (Statement_List) then + Append (New_Node (N_Null_Statement, Loc), Statement_List); + end if; + + return Statement_List; + + exception + when RE_Not_Available => + return Empty_List; + end Build_Init_Statements; + + ------------------------- + -- Build_Record_Checks -- + ------------------------- + + procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is + Subtype_Mark_Id : Entity_Id; + + begin + if Nkind (S) = N_Subtype_Indication then + Find_Type (Subtype_Mark (S)); + Subtype_Mark_Id := Entity (Subtype_Mark (S)); + + -- Remaining processing depends on type + + case Ekind (Subtype_Mark_Id) is + + when Array_Kind => + Constrain_Array (S, Check_List); + + when others => + null; + end case; + end if; + end Build_Record_Checks; + + ------------------------------------------- + -- Component_Needs_Simple_Initialization -- + ------------------------------------------- + + function Component_Needs_Simple_Initialization + (T : Entity_Id) return Boolean + is + begin + return + Needs_Simple_Initialization (T) + and then not Is_RTE (T, RE_Tag) + + -- Ada 2005 (AI-251): Check also the tag of abstract interfaces + + and then not Is_RTE (T, RE_Interface_Tag); + end Component_Needs_Simple_Initialization; + + --------------------- + -- Constrain_Array -- + --------------------- + + procedure Constrain_Array + (SI : Node_Id; + Check_List : List_Id) + is + C : constant Node_Id := Constraint (SI); + Number_Of_Constraints : Nat := 0; + Index : Node_Id; + S, T : Entity_Id; + + begin + T := Entity (Subtype_Mark (SI)); + + if Ekind (T) in Access_Kind then + T := Designated_Type (T); + end if; + + S := First (Constraints (C)); + + while Present (S) loop + Number_Of_Constraints := Number_Of_Constraints + 1; + Next (S); + end loop; + + -- In either case, the index constraint must provide a discrete + -- range for each index of the array type and the type of each + -- discrete range must be the same as that of the corresponding + -- index. (RM 3.6.1) + + S := First (Constraints (C)); + Index := First_Index (T); + Analyze (Index); + + -- Apply constraints to each index type + + for J in 1 .. Number_Of_Constraints loop + Constrain_Index (Index, S, Check_List); + Next (Index); + Next (S); + end loop; + + end Constrain_Array; + + --------------------- + -- Constrain_Index -- + --------------------- + + procedure Constrain_Index + (Index : Node_Id; + S : Node_Id; + Check_List : List_Id) + is + T : constant Entity_Id := Etype (Index); + + begin + if Nkind (S) = N_Range then + Process_Range_Expr_In_Decl (S, T, Check_List); + end if; + end Constrain_Index; + + -------------------------------------- + -- Parent_Subtype_Renaming_Discrims -- + -------------------------------------- + + function Parent_Subtype_Renaming_Discrims return Boolean is + De : Entity_Id; + Dp : Entity_Id; + + begin + if Base_Type (Pe) /= Pe then + return False; + end if; + + if Etype (Pe) = Pe + or else not Has_Discriminants (Pe) + or else Is_Constrained (Pe) + or else Is_Tagged_Type (Pe) + then + return False; + end if; + + -- If there are no explicit stored discriminants we have inherited + -- the root type discriminants so far, so no renamings occurred. + + if First_Discriminant (Pe) = First_Stored_Discriminant (Pe) then + return False; + end if; + + -- Check if we have done some trivial renaming of the parent + -- discriminants, i.e. something like + -- + -- type DT (X1,X2: int) is new PT (X1,X2); + + De := First_Discriminant (Pe); + Dp := First_Discriminant (Etype (Pe)); + + while Present (De) loop + pragma Assert (Present (Dp)); + + if Corresponding_Discriminant (De) /= Dp then + return True; + end if; + + Next_Discriminant (De); + Next_Discriminant (Dp); + end loop; + + return Present (Dp); + end Parent_Subtype_Renaming_Discrims; + + ------------------------ + -- Requires_Init_Proc -- + ------------------------ + + function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is + Comp_Decl : Node_Id; + Id : Entity_Id; + Typ : Entity_Id; + + begin + -- Definitely do not need one if specifically suppressed + + if Suppress_Init_Proc (Rec_Id) then + return False; + end if; + + -- If it is a type derived from a type with unknown discriminants, + -- we cannot build an initialization procedure for it. + + if Has_Unknown_Discriminants (Rec_Id) + or else Has_Unknown_Discriminants (Etype (Rec_Id)) + then + return False; + end if; + + -- Otherwise we need to generate an initialization procedure if + -- Is_CPP_Class is False and at least one of the following applies: + + -- 1. Discriminants are present, since they need to be initialized + -- with the appropriate discriminant constraint expressions. + -- However, the discriminant of an unchecked union does not + -- count, since the discriminant is not present. + + -- 2. The type is a tagged type, since the implicit Tag component + -- needs to be initialized with a pointer to the dispatch table. + + -- 3. The type contains tasks + + -- 4. One or more components has an initial value + + -- 5. One or more components is for a type which itself requires + -- an initialization procedure. + + -- 6. One or more components is a type that requires simple + -- initialization (see Needs_Simple_Initialization), except + -- that types Tag and Interface_Tag are excluded, since fields + -- of these types are initialized by other means. + + -- 7. The type is the record type built for a task type (since at + -- the very least, Create_Task must be called) + + -- 8. The type is the record type built for a protected type (since + -- at least Initialize_Protection must be called) + + -- 9. The type is marked as a public entity. The reason we add this + -- case (even if none of the above apply) is to properly handle + -- Initialize_Scalars. If a package is compiled without an IS + -- pragma, and the client is compiled with an IS pragma, then + -- the client will think an initialization procedure is present + -- and call it, when in fact no such procedure is required, but + -- since the call is generated, there had better be a routine + -- at the other end of the call, even if it does nothing!) + + -- Note: the reason we exclude the CPP_Class case is because in this + -- case the initialization is performed by the C++ constructors, and + -- the IP is built by Set_CPP_Constructors. + + if Is_CPP_Class (Rec_Id) then + return False; + + elsif Is_Interface (Rec_Id) then + return False; + + elsif (Has_Discriminants (Rec_Id) + and then not Is_Unchecked_Union (Rec_Id)) + or else Is_Tagged_Type (Rec_Id) + or else Is_Concurrent_Record_Type (Rec_Id) + or else Has_Task (Rec_Id) + then + return True; + end if; + + Id := First_Component (Rec_Id); + while Present (Id) loop + Comp_Decl := Parent (Id); + Typ := Etype (Id); + + if Present (Expression (Comp_Decl)) + or else Has_Non_Null_Base_Init_Proc (Typ) + or else Component_Needs_Simple_Initialization (Typ) + then + return True; + end if; + + Next_Component (Id); + end loop; + + -- As explained above, a record initialization procedure is needed + -- for public types in case Initialize_Scalars applies to a client. + -- However, such a procedure is not needed in the case where either + -- of restrictions No_Initialize_Scalars or No_Default_Initialization + -- applies. No_Initialize_Scalars excludes the possibility of using + -- Initialize_Scalars in any partition, and No_Default_Initialization + -- implies that no initialization should ever be done for objects of + -- the type, so is incompatible with Initialize_Scalars. + + if not Restriction_Active (No_Initialize_Scalars) + and then not Restriction_Active (No_Default_Initialization) + and then Is_Public (Rec_Id) + then + return True; + end if; + + return False; + end Requires_Init_Proc; + + -- Start of processing for Build_Record_Init_Proc + + begin + -- Check for value type, which means no initialization required + + Rec_Type := Defining_Identifier (N); + + if Is_Value_Type (Rec_Type) then + return; + end if; + + -- This may be full declaration of a private type, in which case + -- the visible entity is a record, and the private entity has been + -- exchanged with it in the private part of the current package. + -- The initialization procedure is built for the record type, which + -- is retrievable from the private entity. + + if Is_Incomplete_Or_Private_Type (Rec_Type) then + Rec_Type := Underlying_Type (Rec_Type); + end if; + + -- If there are discriminants, build the discriminant map to replace + -- discriminants by their discriminals in complex bound expressions. + -- These only arise for the corresponding records of synchronized types. + + if Is_Concurrent_Record_Type (Rec_Type) + and then Has_Discriminants (Rec_Type) + then + declare + Disc : Entity_Id; + begin + Disc := First_Discriminant (Rec_Type); + while Present (Disc) loop + Append_Elmt (Disc, Discr_Map); + Append_Elmt (Discriminal (Disc), Discr_Map); + Next_Discriminant (Disc); + end loop; + end; + end if; + + -- Derived types that have no type extension can use the initialization + -- procedure of their parent and do not need a procedure of their own. + -- This is only correct if there are no representation clauses for the + -- type or its parent, and if the parent has in fact been frozen so + -- that its initialization procedure exists. + + if Is_Derived_Type (Rec_Type) + and then not Is_Tagged_Type (Rec_Type) + and then not Is_Unchecked_Union (Rec_Type) + and then not Has_New_Non_Standard_Rep (Rec_Type) + and then not Parent_Subtype_Renaming_Discrims + and then Has_Non_Null_Base_Init_Proc (Etype (Rec_Type)) + then + Copy_TSS (Base_Init_Proc (Etype (Rec_Type)), Rec_Type); + + -- Otherwise if we need an initialization procedure, then build one, + -- mark it as public and inlinable and as having a completion. + + elsif Requires_Init_Proc (Rec_Type) + or else Is_Unchecked_Union (Rec_Type) + then + Proc_Id := + Make_Defining_Identifier (Loc, + Chars => Make_Init_Proc_Name (Rec_Type)); + + -- If No_Default_Initialization restriction is active, then we don't + -- want to build an init_proc, but we need to mark that an init_proc + -- would be needed if this restriction was not active (so that we can + -- detect attempts to call it), so set a dummy init_proc in place. + + if Restriction_Active (No_Default_Initialization) then + Set_Init_Proc (Rec_Type, Proc_Id); + return; + end if; + + Build_Offset_To_Top_Functions; + Build_CPP_Init_Procedure; + Build_Init_Procedure; + Set_Is_Public (Proc_Id, Is_Public (Pe)); + + -- The initialization of protected records is not worth inlining. + -- In addition, when compiled for another unit for inlining purposes, + -- it may make reference to entities that have not been elaborated + -- yet. The initialization of controlled records contains a nested + -- clean-up procedure that makes it impractical to inline as well, + -- and leads to undefined symbols if inlined in a different unit. + -- Similar considerations apply to task types. + + if not Is_Concurrent_Type (Rec_Type) + and then not Has_Task (Rec_Type) + and then not Needs_Finalization (Rec_Type) + then + Set_Is_Inlined (Proc_Id); + end if; + + Set_Is_Internal (Proc_Id); + Set_Has_Completion (Proc_Id); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Proc_Id); + end if; + + declare + Agg : constant Node_Id := + Build_Equivalent_Record_Aggregate (Rec_Type); + + procedure Collect_Itypes (Comp : Node_Id); + -- Generate references to itypes in the aggregate, because + -- the first use of the aggregate may be in a nested scope. + + -------------------- + -- Collect_Itypes -- + -------------------- + + procedure Collect_Itypes (Comp : Node_Id) is + Ref : Node_Id; + Sub_Aggr : Node_Id; + Typ : constant Entity_Id := Etype (Comp); + + begin + if Is_Array_Type (Typ) + and then Is_Itype (Typ) + then + Ref := Make_Itype_Reference (Loc); + Set_Itype (Ref, Typ); + Append_Freeze_Action (Rec_Type, Ref); + + Ref := Make_Itype_Reference (Loc); + Set_Itype (Ref, Etype (First_Index (Typ))); + Append_Freeze_Action (Rec_Type, Ref); + + Sub_Aggr := First (Expressions (Comp)); + + -- Recurse on nested arrays + + while Present (Sub_Aggr) loop + Collect_Itypes (Sub_Aggr); + Next (Sub_Aggr); + end loop; + end if; + end Collect_Itypes; + + begin + -- If there is a static initialization aggregate for the type, + -- generate itype references for the types of its (sub)components, + -- to prevent out-of-scope errors in the resulting tree. + -- The aggregate may have been rewritten as a Raise node, in which + -- case there are no relevant itypes. + + if Present (Agg) + and then Nkind (Agg) = N_Aggregate + then + Set_Static_Initialization (Proc_Id, Agg); + + declare + Comp : Node_Id; + begin + Comp := First (Component_Associations (Agg)); + while Present (Comp) loop + Collect_Itypes (Expression (Comp)); + Next (Comp); + end loop; + end; + end if; + end; + end if; + end Build_Record_Init_Proc; + + ---------------------------- + -- Build_Slice_Assignment -- + ---------------------------- + + -- Generates the following subprogram: + + -- procedure Assign + -- (Source, Target : Array_Type, + -- Left_Lo, Left_Hi : Index; + -- Right_Lo, Right_Hi : Index; + -- Rev : Boolean) + -- is + -- Li1 : Index; + -- Ri1 : Index; + + -- begin + + -- if Left_Hi < Left_Lo then + -- return; + -- end if; + + -- if Rev then + -- Li1 := Left_Hi; + -- Ri1 := Right_Hi; + -- else + -- Li1 := Left_Lo; + -- Ri1 := Right_Lo; + -- end if; + + -- loop + -- Target (Li1) := Source (Ri1); + + -- if Rev then + -- exit when Li1 = Left_Lo; + -- Li1 := Index'pred (Li1); + -- Ri1 := Index'pred (Ri1); + -- else + -- exit when Li1 = Left_Hi; + -- Li1 := Index'succ (Li1); + -- Ri1 := Index'succ (Ri1); + -- end if; + -- end loop; + -- end Assign; + + procedure Build_Slice_Assignment (Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); + Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ))); + + Larray : constant Entity_Id := Make_Temporary (Loc, 'A'); + Rarray : constant Entity_Id := Make_Temporary (Loc, 'R'); + Left_Lo : constant Entity_Id := Make_Temporary (Loc, 'L'); + Left_Hi : constant Entity_Id := Make_Temporary (Loc, 'L'); + Right_Lo : constant Entity_Id := Make_Temporary (Loc, 'R'); + Right_Hi : constant Entity_Id := Make_Temporary (Loc, 'R'); + Rev : constant Entity_Id := Make_Temporary (Loc, 'D'); + -- Formal parameters of procedure + + Proc_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name (Typ, TSS_Slice_Assign)); + + Lnn : constant Entity_Id := Make_Temporary (Loc, 'L'); + Rnn : constant Entity_Id := Make_Temporary (Loc, 'R'); + -- Subscripts for left and right sides + + Decls : List_Id; + Loops : Node_Id; + Stats : List_Id; + + begin + -- Build declarations for indexes + + Decls := New_List; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Lnn, + Object_Definition => + New_Occurrence_Of (Index, Loc))); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Rnn, + Object_Definition => + New_Occurrence_Of (Index, Loc))); + + Stats := New_List; + + -- Build test for empty slice case + + Append_To (Stats, + Make_If_Statement (Loc, + Condition => + Make_Op_Lt (Loc, + Left_Opnd => New_Occurrence_Of (Left_Hi, Loc), + Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)), + Then_Statements => New_List (Make_Simple_Return_Statement (Loc)))); + + -- Build initializations for indexes + + declare + F_Init : constant List_Id := New_List; + B_Init : constant List_Id := New_List; + + begin + Append_To (F_Init, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Lnn, Loc), + Expression => New_Occurrence_Of (Left_Lo, Loc))); + + Append_To (F_Init, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Rnn, Loc), + Expression => New_Occurrence_Of (Right_Lo, Loc))); + + Append_To (B_Init, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Lnn, Loc), + Expression => New_Occurrence_Of (Left_Hi, Loc))); + + Append_To (B_Init, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Rnn, Loc), + Expression => New_Occurrence_Of (Right_Hi, Loc))); + + Append_To (Stats, + Make_If_Statement (Loc, + Condition => New_Occurrence_Of (Rev, Loc), + Then_Statements => B_Init, + Else_Statements => F_Init)); + end; + + -- Now construct the assignment statement + + Loops := + Make_Loop_Statement (Loc, + Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (Larray, Loc), + Expressions => New_List (New_Occurrence_Of (Lnn, Loc))), + Expression => + Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (Rarray, Loc), + Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))), + End_Label => Empty); + + -- Build the exit condition and increment/decrement statements + + declare + F_Ass : constant List_Id := New_List; + B_Ass : constant List_Id := New_List; + + begin + Append_To (F_Ass, + Make_Exit_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Lnn, Loc), + Right_Opnd => New_Occurrence_Of (Left_Hi, Loc)))); + + Append_To (F_Ass, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Lnn, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Index, Loc), + Attribute_Name => Name_Succ, + Expressions => New_List ( + New_Occurrence_Of (Lnn, Loc))))); + + Append_To (F_Ass, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Rnn, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Index, Loc), + Attribute_Name => Name_Succ, + Expressions => New_List ( + New_Occurrence_Of (Rnn, Loc))))); + + Append_To (B_Ass, + Make_Exit_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Lnn, Loc), + Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)))); + + Append_To (B_Ass, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Lnn, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Index, Loc), + Attribute_Name => Name_Pred, + Expressions => New_List ( + New_Occurrence_Of (Lnn, Loc))))); + + Append_To (B_Ass, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Rnn, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Index, Loc), + Attribute_Name => Name_Pred, + Expressions => New_List ( + New_Occurrence_Of (Rnn, Loc))))); + + Append_To (Statements (Loops), + Make_If_Statement (Loc, + Condition => New_Occurrence_Of (Rev, Loc), + Then_Statements => B_Ass, + Else_Statements => F_Ass)); + end; + + Append_To (Stats, Loops); + + declare + Spec : Node_Id; + Formals : List_Id := New_List; + + begin + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Larray, + Out_Present => True, + Parameter_Type => + New_Reference_To (Base_Type (Typ), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Rarray, + Parameter_Type => + New_Reference_To (Base_Type (Typ), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Left_Lo, + Parameter_Type => + New_Reference_To (Index, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Left_Hi, + Parameter_Type => + New_Reference_To (Index, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Right_Lo, + Parameter_Type => + New_Reference_To (Index, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Right_Hi, + Parameter_Type => + New_Reference_To (Index, Loc))); + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => Rev, + Parameter_Type => + New_Reference_To (Standard_Boolean, Loc))); + + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc_Name, + Parameter_Specifications => Formals); + + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stats))); + end; + + Set_TSS (Typ, Proc_Name); + Set_Is_Pure (Proc_Name); + end Build_Slice_Assignment; + + ----------------------------- + -- Build_Untagged_Equality -- + ----------------------------- + + procedure Build_Untagged_Equality (Typ : Entity_Id) is + Build_Eq : Boolean; + Comp : Entity_Id; + Decl : Node_Id; + Op : Entity_Id; + Prim : Elmt_Id; + Eq_Op : Entity_Id; + + function User_Defined_Eq (T : Entity_Id) return Entity_Id; + -- Check whether the type T has a user-defined primitive equality. If so + -- return it, else return Empty. If true for a component of Typ, we have + -- to build the primitive equality for it. + + --------------------- + -- User_Defined_Eq -- + --------------------- + + function User_Defined_Eq (T : Entity_Id) return Entity_Id is + Prim : Elmt_Id; + Op : Entity_Id; + + begin + Op := TSS (T, TSS_Composite_Equality); + + if Present (Op) then + return Op; + end if; + + Prim := First_Elmt (Collect_Primitive_Operations (T)); + while Present (Prim) loop + Op := Node (Prim); + + if Chars (Op) = Name_Op_Eq + and then Etype (Op) = Standard_Boolean + and then Etype (First_Formal (Op)) = T + and then Etype (Next_Formal (First_Formal (Op))) = T + then + return Op; + end if; + + Next_Elmt (Prim); + end loop; + + return Empty; + end User_Defined_Eq; + + -- Start of processing for Build_Untagged_Equality + + begin + -- If a record component has a primitive equality operation, we must + -- build the corresponding one for the current type. + + Build_Eq := False; + Comp := First_Component (Typ); + while Present (Comp) loop + if Is_Record_Type (Etype (Comp)) + and then Present (User_Defined_Eq (Etype (Comp))) + then + Build_Eq := True; + end if; + + Next_Component (Comp); + end loop; + + -- If there is a user-defined equality for the type, we do not create + -- the implicit one. + + Prim := First_Elmt (Collect_Primitive_Operations (Typ)); + Eq_Op := Empty; + while Present (Prim) loop + if Chars (Node (Prim)) = Name_Op_Eq + and then Comes_From_Source (Node (Prim)) + + -- Don't we also need to check formal types and return type as in + -- User_Defined_Eq above??? + + then + Eq_Op := Node (Prim); + Build_Eq := False; + exit; + end if; + + Next_Elmt (Prim); + end loop; + + -- If the type is derived, inherit the operation, if present, from the + -- parent type. It may have been declared after the type derivation. If + -- the parent type itself is derived, it may have inherited an operation + -- that has itself been overridden, so update its alias and related + -- flags. Ditto for inequality. + + if No (Eq_Op) and then Is_Derived_Type (Typ) then + Prim := First_Elmt (Collect_Primitive_Operations (Etype (Typ))); + while Present (Prim) loop + if Chars (Node (Prim)) = Name_Op_Eq then + Copy_TSS (Node (Prim), Typ); + Build_Eq := False; + + declare + Op : constant Entity_Id := User_Defined_Eq (Typ); + Eq_Op : constant Entity_Id := Node (Prim); + NE_Op : constant Entity_Id := Next_Entity (Eq_Op); + + begin + if Present (Op) then + Set_Alias (Op, Eq_Op); + Set_Is_Abstract_Subprogram + (Op, Is_Abstract_Subprogram (Eq_Op)); + + if Chars (Next_Entity (Op)) = Name_Op_Ne then + Set_Is_Abstract_Subprogram + (Next_Entity (Op), Is_Abstract_Subprogram (NE_Op)); + end if; + end if; + end; + + exit; + end if; + + Next_Elmt (Prim); + end loop; + end if; + + -- If not inherited and not user-defined, build body as for a type with + -- tagged components. + + if Build_Eq then + Decl := + Make_Eq_Body (Typ, Make_TSS_Name (Typ, TSS_Composite_Equality)); + Op := Defining_Entity (Decl); + Set_TSS (Typ, Op); + Set_Is_Pure (Op); + + if Is_Library_Level_Entity (Typ) then + Set_Is_Public (Op); + end if; + end if; + end Build_Untagged_Equality; + + ------------------------------------ + -- Build_Variant_Record_Equality -- + ------------------------------------ + + -- Generates: + + -- function _Equality (X, Y : T) return Boolean is + -- begin + -- -- Compare discriminants + + -- if False or else X.D1 /= Y.D1 or else X.D2 /= Y.D2 then + -- return False; + -- end if; + + -- -- Compare components + + -- if False or else X.C1 /= Y.C1 or else X.C2 /= Y.C2 then + -- return False; + -- end if; + + -- -- Compare variant part + + -- case X.D1 is + -- when V1 => + -- if False or else X.C2 /= Y.C2 or else X.C3 /= Y.C3 then + -- return False; + -- end if; + -- ... + -- when Vn => + -- if False or else X.Cn /= Y.Cn then + -- return False; + -- end if; + -- end case; + + -- return True; + -- end _Equality; + + procedure Build_Variant_Record_Equality (Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); + + F : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name (Typ, TSS_Composite_Equality)); + + X : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_X); + + Y : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_Y); + + Def : constant Node_Id := Parent (Typ); + Comps : constant Node_Id := Component_List (Type_Definition (Def)); + Stmts : constant List_Id := New_List; + Pspecs : constant List_Id := New_List; + + begin + -- Derived Unchecked_Union types no longer inherit the equality function + -- of their parent. + + if Is_Derived_Type (Typ) + and then not Is_Unchecked_Union (Typ) + and then not Has_New_Non_Standard_Rep (Typ) + then + declare + Parent_Eq : constant Entity_Id := + TSS (Root_Type (Typ), TSS_Composite_Equality); + + begin + if Present (Parent_Eq) then + Copy_TSS (Parent_Eq, Typ); + return; + end if; + end; + end if; + + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => F, + Parameter_Specifications => Pspecs, + Result_Definition => New_Reference_To (Standard_Boolean, Loc)), + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts))); + + Append_To (Pspecs, + Make_Parameter_Specification (Loc, + Defining_Identifier => X, + Parameter_Type => New_Reference_To (Typ, Loc))); + + Append_To (Pspecs, + Make_Parameter_Specification (Loc, + Defining_Identifier => Y, + Parameter_Type => New_Reference_To (Typ, Loc))); + + -- Unchecked_Unions require additional machinery to support equality. + -- Two extra parameters (A and B) are added to the equality function + -- parameter list in order to capture the inferred values of the + -- discriminants in later calls. + + if Is_Unchecked_Union (Typ) then + declare + Discr_Type : constant Node_Id := Etype (First_Discriminant (Typ)); + + A : constant Node_Id := + Make_Defining_Identifier (Loc, + Chars => Name_A); + + B : constant Node_Id := + Make_Defining_Identifier (Loc, + Chars => Name_B); + + begin + -- Add A and B to the parameter list + + Append_To (Pspecs, + Make_Parameter_Specification (Loc, + Defining_Identifier => A, + Parameter_Type => New_Reference_To (Discr_Type, Loc))); + + Append_To (Pspecs, + Make_Parameter_Specification (Loc, + Defining_Identifier => B, + Parameter_Type => New_Reference_To (Discr_Type, Loc))); + + -- Generate the following header code to compare the inferred + -- discriminants: + + -- if a /= b then + -- return False; + -- end if; + + Append_To (Stmts, + Make_If_Statement (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Reference_To (A, Loc), + Right_Opnd => New_Reference_To (B, Loc)), + Then_Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Standard_False, Loc))))); + + -- Generate component-by-component comparison. Note that we must + -- propagate one of the inferred discriminant formals to act as + -- the case statement switch. + + Append_List_To (Stmts, + Make_Eq_Case (Typ, Comps, A)); + + end; + + -- Normal case (not unchecked union) + + else + Append_To (Stmts, + Make_Eq_If (Typ, + Discriminant_Specifications (Def))); + + Append_List_To (Stmts, + Make_Eq_Case (Typ, Comps)); + end if; + + Append_To (Stmts, + Make_Simple_Return_Statement (Loc, + Expression => New_Reference_To (Standard_True, Loc))); + + Set_TSS (Typ, F); + Set_Is_Pure (F); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (F); + end if; + end Build_Variant_Record_Equality; + + ----------------------------- + -- Check_Stream_Attributes -- + ----------------------------- + + procedure Check_Stream_Attributes (Typ : Entity_Id) is + Comp : Entity_Id; + Par_Read : constant Boolean := + Stream_Attribute_Available (Typ, TSS_Stream_Read) + and then not Has_Specified_Stream_Read (Typ); + Par_Write : constant Boolean := + Stream_Attribute_Available (Typ, TSS_Stream_Write) + and then not Has_Specified_Stream_Write (Typ); + + procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type); + -- Check that Comp has a user-specified Nam stream attribute + + ---------------- + -- Check_Attr -- + ---------------- + + procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type) is + begin + if not Stream_Attribute_Available (Etype (Comp), TSS_Nam) then + Error_Msg_Name_1 := Nam; + Error_Msg_N + ("|component& in limited extension must have% attribute", Comp); + end if; + end Check_Attr; + + -- Start of processing for Check_Stream_Attributes + + begin + if Par_Read or else Par_Write then + Comp := First_Component (Typ); + while Present (Comp) loop + if Comes_From_Source (Comp) + and then Original_Record_Component (Comp) = Comp + and then Is_Limited_Type (Etype (Comp)) + then + if Par_Read then + Check_Attr (Name_Read, TSS_Stream_Read); + end if; + + if Par_Write then + Check_Attr (Name_Write, TSS_Stream_Write); + end if; + end if; + + Next_Component (Comp); + end loop; + end if; + end Check_Stream_Attributes; + + ----------------------------- + -- Expand_Record_Extension -- + ----------------------------- + + -- Add a field _parent at the beginning of the record extension. This is + -- used to implement inheritance. Here are some examples of expansion: + + -- 1. no discriminants + -- type T2 is new T1 with null record; + -- gives + -- type T2 is new T1 with record + -- _Parent : T1; + -- end record; + + -- 2. renamed discriminants + -- type T2 (B, C : Int) is new T1 (A => B) with record + -- _Parent : T1 (A => B); + -- D : Int; + -- end; + + -- 3. inherited discriminants + -- type T2 is new T1 with record -- discriminant A inherited + -- _Parent : T1 (A); + -- D : Int; + -- end; + + procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is + Indic : constant Node_Id := Subtype_Indication (Def); + Loc : constant Source_Ptr := Sloc (Def); + Rec_Ext_Part : Node_Id := Record_Extension_Part (Def); + Par_Subtype : Entity_Id; + Comp_List : Node_Id; + Comp_Decl : Node_Id; + Parent_N : Node_Id; + D : Entity_Id; + List_Constr : constant List_Id := New_List; + + begin + -- Expand_Record_Extension is called directly from the semantics, so + -- we must check to see whether expansion is active before proceeding + + if not Expander_Active then + return; + end if; + + -- This may be a derivation of an untagged private type whose full + -- view is tagged, in which case the Derived_Type_Definition has no + -- extension part. Build an empty one now. + + if No (Rec_Ext_Part) then + Rec_Ext_Part := + Make_Record_Definition (Loc, + End_Label => Empty, + Component_List => Empty, + Null_Present => True); + + Set_Record_Extension_Part (Def, Rec_Ext_Part); + Mark_Rewrite_Insertion (Rec_Ext_Part); + end if; + + Comp_List := Component_List (Rec_Ext_Part); + + Parent_N := Make_Defining_Identifier (Loc, Name_uParent); + + -- If the derived type inherits its discriminants the type of the + -- _parent field must be constrained by the inherited discriminants + + if Has_Discriminants (T) + and then Nkind (Indic) /= N_Subtype_Indication + and then not Is_Constrained (Entity (Indic)) + then + D := First_Discriminant (T); + while Present (D) loop + Append_To (List_Constr, New_Occurrence_Of (D, Loc)); + Next_Discriminant (D); + end loop; + + Par_Subtype := + Process_Subtype ( + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (Entity (Indic), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => List_Constr)), + Def); + + -- Otherwise the original subtype_indication is just what is needed + + else + Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def); + end if; + + Set_Parent_Subtype (T, Par_Subtype); + + Comp_Decl := + Make_Component_Declaration (Loc, + Defining_Identifier => Parent_N, + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => New_Reference_To (Par_Subtype, Loc))); + + if Null_Present (Rec_Ext_Part) then + Set_Component_List (Rec_Ext_Part, + Make_Component_List (Loc, + Component_Items => New_List (Comp_Decl), + Variant_Part => Empty, + Null_Present => False)); + Set_Null_Present (Rec_Ext_Part, False); + + elsif Null_Present (Comp_List) + or else Is_Empty_List (Component_Items (Comp_List)) + then + Set_Component_Items (Comp_List, New_List (Comp_Decl)); + Set_Null_Present (Comp_List, False); + + else + Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); + end if; + + Analyze (Comp_Decl); + end Expand_Record_Extension; + + ------------------------------------ + -- Expand_N_Full_Type_Declaration -- + ------------------------------------ + + procedure Expand_N_Full_Type_Declaration (N : Node_Id) is + Def_Id : constant Entity_Id := Defining_Identifier (N); + B_Id : constant Entity_Id := Base_Type (Def_Id); + Par_Id : Entity_Id; + FN : Node_Id; + + procedure Build_Master (Def_Id : Entity_Id); + -- Create the master associated with Def_Id + + ------------------ + -- Build_Master -- + ------------------ + + procedure Build_Master (Def_Id : Entity_Id) is + begin + -- Anonymous access types are created for the components of the + -- record parameter for an entry declaration. No master is created + -- for such a type. + + if Has_Task (Designated_Type (Def_Id)) + and then Comes_From_Source (N) + then + Build_Master_Entity (Def_Id); + Build_Master_Renaming (Parent (Def_Id), Def_Id); + + -- Create a class-wide master because a Master_Id must be generated + -- for access-to-limited-class-wide types whose root may be extended + -- with task components. + + -- Note: This code covers access-to-limited-interfaces because they + -- can be used to reference tasks implementing them. + + elsif Is_Class_Wide_Type (Designated_Type (Def_Id)) + and then Is_Limited_Type (Designated_Type (Def_Id)) + and then Tasking_Allowed + + -- Do not create a class-wide master for types whose convention is + -- Java since these types cannot embed Ada tasks anyway. Note that + -- the following test cannot catch the following case: + + -- package java.lang.Object is + -- type Typ is tagged limited private; + -- type Ref is access all Typ'Class; + -- private + -- type Typ is tagged limited ...; + -- pragma Convention (Typ, Java) + -- end; + + -- Because the convention appears after we have done the + -- processing for type Ref. + + and then Convention (Designated_Type (Def_Id)) /= Convention_Java + and then Convention (Designated_Type (Def_Id)) /= Convention_CIL + then + Build_Class_Wide_Master (Def_Id); + end if; + end Build_Master; + + -- Start of processing for Expand_N_Full_Type_Declaration + + begin + if Is_Access_Type (Def_Id) then + Build_Master (Def_Id); + + if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then + Expand_Access_Protected_Subprogram_Type (N); + end if; + + elsif Ada_Version >= Ada_2005 + and then Is_Array_Type (Def_Id) + and then Is_Access_Type (Component_Type (Def_Id)) + and then Ekind (Component_Type (Def_Id)) = E_Anonymous_Access_Type + then + Build_Master (Component_Type (Def_Id)); + + elsif Has_Task (Def_Id) then + Expand_Previous_Access_Type (Def_Id); + + elsif Ada_Version >= Ada_2005 + and then + (Is_Record_Type (Def_Id) + or else (Is_Array_Type (Def_Id) + and then Is_Record_Type (Component_Type (Def_Id)))) + then + declare + Comp : Entity_Id; + Typ : Entity_Id; + M_Id : Entity_Id; + + begin + -- Look for the first anonymous access type component + + if Is_Array_Type (Def_Id) then + Comp := First_Entity (Component_Type (Def_Id)); + else + Comp := First_Entity (Def_Id); + end if; + + while Present (Comp) loop + Typ := Etype (Comp); + + exit when Is_Access_Type (Typ) + and then Ekind (Typ) = E_Anonymous_Access_Type; + + Next_Entity (Comp); + end loop; + + -- If found we add a renaming declaration of master_id and we + -- associate it to each anonymous access type component. Do + -- nothing if the access type already has a master. This will be + -- the case if the array type is the packed array created for a + -- user-defined array type T, where the master_id is created when + -- expanding the declaration for T. + + if Present (Comp) + and then Ekind (Typ) = E_Anonymous_Access_Type + and then not Restriction_Active (No_Task_Hierarchy) + and then No (Master_Id (Typ)) + + -- Do not consider run-times with no tasking support + + and then RTE_Available (RE_Current_Master) + and then Has_Task (Non_Limited_Designated_Type (Typ)) + then + Build_Master_Entity (Def_Id); + M_Id := Build_Master_Renaming (N, Def_Id); + + if Is_Array_Type (Def_Id) then + Comp := First_Entity (Component_Type (Def_Id)); + else + Comp := First_Entity (Def_Id); + end if; + + while Present (Comp) loop + Typ := Etype (Comp); + + if Is_Access_Type (Typ) + and then Ekind (Typ) = E_Anonymous_Access_Type + then + Set_Master_Id (Typ, M_Id); + end if; + + Next_Entity (Comp); + end loop; + end if; + end; + end if; + + Par_Id := Etype (B_Id); + + -- The parent type is private then we need to inherit any TSS operations + -- from the full view. + + if Ekind (Par_Id) in Private_Kind + and then Present (Full_View (Par_Id)) + then + Par_Id := Base_Type (Full_View (Par_Id)); + end if; + + if Nkind (Type_Definition (Original_Node (N))) = + N_Derived_Type_Definition + and then not Is_Tagged_Type (Def_Id) + and then Present (Freeze_Node (Par_Id)) + and then Present (TSS_Elist (Freeze_Node (Par_Id))) + then + Ensure_Freeze_Node (B_Id); + FN := Freeze_Node (B_Id); + + if No (TSS_Elist (FN)) then + Set_TSS_Elist (FN, New_Elmt_List); + end if; + + declare + T_E : constant Elist_Id := TSS_Elist (FN); + Elmt : Elmt_Id; + + begin + Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id))); + while Present (Elmt) loop + if Chars (Node (Elmt)) /= Name_uInit then + Append_Elmt (Node (Elmt), T_E); + end if; + + Next_Elmt (Elmt); + end loop; + + -- If the derived type itself is private with a full view, then + -- associate the full view with the inherited TSS_Elist as well. + + if Ekind (B_Id) in Private_Kind + and then Present (Full_View (B_Id)) + then + Ensure_Freeze_Node (Base_Type (Full_View (B_Id))); + Set_TSS_Elist + (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN)); + end if; + end; + end if; + end Expand_N_Full_Type_Declaration; + + --------------------------------- + -- Expand_N_Object_Declaration -- + --------------------------------- + + -- First we do special processing for objects of a tagged type where this + -- is the point at which the type is frozen. The creation of the dispatch + -- table and the initialization procedure have to be deferred to this + -- point, since we reference previously declared primitive subprograms. + + -- For all types, we call an initialization procedure if there is one + + procedure Expand_N_Object_Declaration (N : Node_Id) is + Def_Id : constant Entity_Id := Defining_Identifier (N); + Expr : constant Node_Id := Expression (N); + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (Def_Id); + Base_Typ : constant Entity_Id := Base_Type (Typ); + Expr_Q : Node_Id; + Id_Ref : Node_Id; + New_Ref : Node_Id; + + Init_After : Node_Id := N; + -- Node after which the init proc call is to be inserted. This is + -- normally N, except for the case of a shared passive variable, in + -- which case the init proc call must be inserted only after the bodies + -- of the shared variable procedures have been seen. + + function Rewrite_As_Renaming return Boolean; + -- Indicate whether to rewrite a declaration with initialization into an + -- object renaming declaration (see below). + + ------------------------- + -- Rewrite_As_Renaming -- + ------------------------- + + function Rewrite_As_Renaming return Boolean is + begin + return not Aliased_Present (N) + and then Is_Entity_Name (Expr_Q) + and then Ekind (Entity (Expr_Q)) = E_Variable + and then OK_To_Rename (Entity (Expr_Q)) + and then Is_Entity_Name (Object_Definition (N)); + end Rewrite_As_Renaming; + + -- Start of processing for Expand_N_Object_Declaration + + begin + -- Don't do anything for deferred constants. All proper actions will be + -- expanded during the full declaration. + + if No (Expr) and Constant_Present (N) then + return; + end if; + + -- Force construction of dispatch tables of library level tagged types + + if Tagged_Type_Expansion + and then Static_Dispatch_Tables + and then Is_Library_Level_Entity (Def_Id) + and then Is_Library_Level_Tagged_Type (Base_Typ) + and then (Ekind (Base_Typ) = E_Record_Type + or else Ekind (Base_Typ) = E_Protected_Type + or else Ekind (Base_Typ) = E_Task_Type) + and then not Has_Dispatch_Table (Base_Typ) + then + declare + New_Nodes : List_Id := No_List; + + begin + if Is_Concurrent_Type (Base_Typ) then + New_Nodes := Make_DT (Corresponding_Record_Type (Base_Typ), N); + else + New_Nodes := Make_DT (Base_Typ, N); + end if; + + if not Is_Empty_List (New_Nodes) then + Insert_List_Before (N, New_Nodes); + end if; + end; + end if; + + -- Make shared memory routines for shared passive variable + + if Is_Shared_Passive (Def_Id) then + Init_After := Make_Shared_Var_Procs (N); + end if; + + -- If tasks being declared, make sure we have an activation chain + -- defined for the tasks (has no effect if we already have one), and + -- also that a Master variable is established and that the appropriate + -- enclosing construct is established as a task master. + + if Has_Task (Typ) then + Build_Activation_Chain_Entity (N); + Build_Master_Entity (Def_Id); + end if; + + -- Build a list controller for declarations where the type is anonymous + -- access and the designated type is controlled. Only declarations from + -- source files receive such controllers in order to provide the same + -- lifespan for any potential coextensions that may be associated with + -- the object. Finalization lists of internal controlled anonymous + -- access objects are already handled in Expand_N_Allocator. + + if Comes_From_Source (N) + and then Ekind (Typ) = E_Anonymous_Access_Type + and then Is_Controlled (Directly_Designated_Type (Typ)) + and then No (Associated_Final_Chain (Typ)) + then + Build_Final_List (N, Typ); + end if; + + -- Default initialization required, and no expression present + + if No (Expr) then + + -- For the default initialization case, if we have a private type + -- with invariants, and invariant checks are enabled, then insert an + -- invariant check after the object declaration. Note that it is OK + -- to clobber the object with an invalid value since if the exception + -- is raised, then the object will go out of scope. + + if Has_Invariants (Typ) + and then Present (Invariant_Procedure (Typ)) + then + Insert_After (N, + Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc))); + end if; + + -- Expand Initialize call for controlled objects. One may wonder why + -- the Initialize Call is not done in the regular Init procedure + -- attached to the record type. That's because the init procedure is + -- recursively called on each component, including _Parent, thus the + -- Init call for a controlled object would generate not only one + -- Initialize call as it is required but one for each ancestor of + -- its type. This processing is suppressed if No_Initialization set. + + if not Needs_Finalization (Typ) + or else No_Initialization (N) + then + null; + + elsif not Abort_Allowed + or else not Comes_From_Source (N) + then + Insert_Actions_After (Init_After, + Make_Init_Call ( + Ref => New_Occurrence_Of (Def_Id, Loc), + Typ => Base_Type (Typ), + Flist_Ref => Find_Final_List (Def_Id), + With_Attach => Make_Integer_Literal (Loc, 1))); + + -- Abort allowed + + else + -- We need to protect the initialize call + + -- begin + -- Defer_Abort.all; + -- Initialize (...); + -- at end + -- Undefer_Abort.all; + -- end; + + -- ??? this won't protect the initialize call for controlled + -- components which are part of the init proc, so this block + -- should probably also contain the call to _init_proc but this + -- requires some code reorganization... + + declare + L : constant List_Id := + Make_Init_Call + (Ref => New_Occurrence_Of (Def_Id, Loc), + Typ => Base_Type (Typ), + Flist_Ref => Find_Final_List (Def_Id), + With_Attach => Make_Integer_Literal (Loc, 1)); + + Blk : constant Node_Id := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, L)); + + begin + Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer)); + Set_At_End_Proc (Handled_Statement_Sequence (Blk), + New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)); + Insert_Actions_After (Init_After, New_List (Blk)); + Expand_At_End_Handler + (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk))); + end; + end if; + + -- Call type initialization procedure if there is one. We build the + -- call and put it immediately after the object declaration, so that + -- it will be expanded in the usual manner. Note that this will + -- result in proper handling of defaulted discriminants. + + -- Need call if there is a base init proc + + if Has_Non_Null_Base_Init_Proc (Typ) + + -- Suppress call if No_Initialization set on declaration + + and then not No_Initialization (N) + + -- Suppress call for special case of value type for VM + + and then not Is_Value_Type (Typ) + + -- Suppress call if Suppress_Init_Proc set on the type. This is + -- needed for the derived type case, where Suppress_Initialization + -- may be set for the derived type, even if there is an init proc + -- defined for the root type. + + and then not Suppress_Init_Proc (Typ) + then + -- Return without initializing when No_Default_Initialization + -- applies. Note that the actual restriction check occurs later, + -- when the object is frozen, because we don't know yet whether + -- the object is imported, which is a case where the check does + -- not apply. + + if Restriction_Active (No_Default_Initialization) then + return; + end if; + + -- The call to the initialization procedure does NOT freeze the + -- object being initialized. This is because the call is not a + -- source level call. This works fine, because the only possible + -- statements depending on freeze status that can appear after the + -- Init_Proc call are rep clauses which can safely appear after + -- actual references to the object. Note that this call may + -- subsequently be removed (if a pragma Import is encountered), + -- or moved to the freeze actions for the object (e.g. if an + -- address clause is applied to the object, causing it to get + -- delayed freezing). + + Id_Ref := New_Reference_To (Def_Id, Loc); + Set_Must_Not_Freeze (Id_Ref); + Set_Assignment_OK (Id_Ref); + + declare + Init_Expr : constant Node_Id := + Static_Initialization (Base_Init_Proc (Typ)); + begin + if Present (Init_Expr) then + Set_Expression + (N, New_Copy_Tree (Init_Expr, New_Scope => Current_Scope)); + return; + else + Initialization_Warning (Id_Ref); + + Insert_Actions_After (Init_After, + Build_Initialization_Call (Loc, Id_Ref, Typ)); + end if; + end; + + -- If simple initialization is required, then set an appropriate + -- simple initialization expression in place. This special + -- initialization is required even though No_Init_Flag is present, + -- but is not needed if there was an explicit initialization. + + -- An internally generated temporary needs no initialization because + -- it will be assigned subsequently. In particular, there is no point + -- in applying Initialize_Scalars to such a temporary. + + elsif Needs_Simple_Initialization + (Typ, + Initialize_Scalars + and then not Has_Following_Address_Clause (N)) + and then not Is_Internal (Def_Id) + and then not Has_Init_Expression (N) + then + Set_No_Initialization (N, False); + Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id))); + Analyze_And_Resolve (Expression (N), Typ); + end if; + + -- Generate attribute for Persistent_BSS if needed + + if Persistent_BSS_Mode + and then Comes_From_Source (N) + and then Is_Potentially_Persistent_Type (Typ) + and then not Has_Init_Expression (N) + and then Is_Library_Level_Entity (Def_Id) + then + declare + Prag : Node_Id; + begin + Prag := + Make_Linker_Section_Pragma + (Def_Id, Sloc (N), ".persistent.bss"); + Insert_After (N, Prag); + Analyze (Prag); + end; + end if; + + -- If access type, then we know it is null if not initialized + + if Is_Access_Type (Typ) then + Set_Is_Known_Null (Def_Id); + end if; + + -- Explicit initialization present + + else + -- Obtain actual expression from qualified expression + + if Nkind (Expr) = N_Qualified_Expression then + Expr_Q := Expression (Expr); + else + Expr_Q := Expr; + end if; + + -- When we have the appropriate type of aggregate in the expression + -- (it has been determined during analysis of the aggregate by + -- setting the delay flag), let's perform in place assignment and + -- thus avoid creating a temporary. + + if Is_Delayed_Aggregate (Expr_Q) then + Convert_Aggr_In_Object_Decl (N); + + -- Ada 2005 (AI-318-02): If the initialization expression is a call + -- to a build-in-place function, then access to the declared object + -- must be passed to the function. Currently we limit such functions + -- to those with constrained limited result subtypes, but eventually + -- plan to expand the allowed forms of functions that are treated as + -- build-in-place. + + elsif Ada_Version >= Ada_2005 + and then Is_Build_In_Place_Function_Call (Expr_Q) + then + Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q); + + -- The previous call expands the expression initializing the + -- built-in-place object into further code that will be analyzed + -- later. No further expansion needed here. + + return; + + -- Ada 2005 (AI-251): Rewrite the expression that initializes a + -- class-wide object to ensure that we copy the full object, + -- unless we are targetting a VM where interfaces are handled by + -- VM itself. Note that if the root type of Typ is an ancestor + -- of Expr's type, both types share the same dispatch table and + -- there is no need to displace the pointer. + + elsif Comes_From_Source (N) + and then Is_Interface (Typ) + then + pragma Assert (Is_Class_Wide_Type (Typ)); + + -- If the object is a return object of an inherently limited type, + -- which implies build-in-place treatment, bypass the special + -- treatment of class-wide interface initialization below. In this + -- case, the expansion of the return statement will take care of + -- creating the object (via allocator) and initializing it. + + if Is_Return_Object (Def_Id) + and then Is_Immutably_Limited_Type (Typ) + then + null; + + elsif Tagged_Type_Expansion then + declare + Iface : constant Entity_Id := Root_Type (Typ); + Expr_N : Node_Id := Expr; + Expr_Typ : Entity_Id; + New_Expr : Node_Id; + Obj_Id : Entity_Id; + Tag_Comp : Node_Id; + + begin + -- If the original node of the expression was a conversion + -- to this specific class-wide interface type then we + -- restore the original node because we must copy the object + -- before displacing the pointer to reference the secondary + -- tag component. This code must be kept synchronized with + -- the expansion done by routine Expand_Interface_Conversion + + if not Comes_From_Source (Expr_N) + and then Nkind (Expr_N) = N_Explicit_Dereference + and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion + and then Etype (Original_Node (Expr_N)) = Typ + then + Rewrite (Expr_N, Original_Node (Expression (N))); + end if; + + -- Avoid expansion of redundant interface conversion + + if Is_Interface (Etype (Expr_N)) + and then Nkind (Expr_N) = N_Type_Conversion + and then Etype (Expr_N) = Typ + then + Expr_N := Expression (Expr_N); + Set_Expression (N, Expr_N); + end if; + + Obj_Id := Make_Temporary (Loc, 'D', Expr_N); + Expr_Typ := Base_Type (Etype (Expr_N)); + + if Is_Class_Wide_Type (Expr_Typ) then + Expr_Typ := Root_Type (Expr_Typ); + end if; + + -- Replace + -- CW : I'Class := Obj; + -- by + -- Tmp : T := Obj; + -- type Ityp is not null access I'Class; + -- CW : I'Class renames Ityp(Tmp.I_Tag'Address).all; + + if Comes_From_Source (Expr_N) + and then Nkind (Expr_N) = N_Identifier + and then not Is_Interface (Expr_Typ) + and then Interface_Present_In_Ancestor (Expr_Typ, Typ) + and then (Expr_Typ = Etype (Expr_Typ) + or else not + Is_Variable_Size_Record (Etype (Expr_Typ))) + then + -- Copy the object + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Obj_Id, + Object_Definition => + New_Occurrence_Of (Expr_Typ, Loc), + Expression => + Relocate_Node (Expr_N))); + + -- Statically reference the tag associated with the + -- interface + + Tag_Comp := + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Obj_Id, Loc), + Selector_Name => + New_Reference_To + (Find_Interface_Tag (Expr_Typ, Iface), Loc)); + + -- Replace + -- IW : I'Class := Obj; + -- by + -- type Equiv_Record is record ... end record; + -- implicit subtype CW is ; + -- Tmp : CW := CW!(Obj); + -- type Ityp is not null access I'Class; + -- IW : I'Class renames + -- Ityp!(Displace (Temp'Address, I'Tag)).all; + + else + -- Generate the equivalent record type and update the + -- subtype indication to reference it. + + Expand_Subtype_From_Expr + (N => N, + Unc_Type => Typ, + Subtype_Indic => Object_Definition (N), + Exp => Expr_N); + + if not Is_Interface (Etype (Expr_N)) then + New_Expr := Relocate_Node (Expr_N); + + -- For interface types we use 'Address which displaces + -- the pointer to the base of the object (if required) + + else + New_Expr := + Unchecked_Convert_To (Etype (Object_Definition (N)), + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Tag_Ptr), + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Expr_N), + Attribute_Name => Name_Address)))); + end if; + + -- Copy the object + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Obj_Id, + Object_Definition => + New_Occurrence_Of + (Etype (Object_Definition (N)), Loc), + Expression => New_Expr)); + + -- Dynamically reference the tag associated with the + -- interface. + + Tag_Comp := + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Displace), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Obj_Id, Loc), + Attribute_Name => Name_Address), + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Iface))), + Loc))); + end if; + + Rewrite (N, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'D'), + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Name => Convert_Tag_To_Interface (Typ, Tag_Comp))); + + Analyze (N, Suppress => All_Checks); + + -- Replace internal identifier of rewritten node by the + -- identifier found in the sources. We also have to exchange + -- entities containing their defining identifiers to ensure + -- the correct replacement of the object declaration by this + -- object renaming declaration ---because these identifiers + -- were previously added by Enter_Name to the current scope. + -- We must preserve the homonym chain of the source entity + -- as well. + + Set_Chars (Defining_Identifier (N), Chars (Def_Id)); + Set_Homonym (Defining_Identifier (N), Homonym (Def_Id)); + Exchange_Entities (Defining_Identifier (N), Def_Id); + end; + end if; + + return; + + else + -- In most cases, we must check that the initial value meets any + -- constraint imposed by the declared type. However, there is one + -- very important exception to this rule. If the entity has an + -- unconstrained nominal subtype, then it acquired its constraints + -- from the expression in the first place, and not only does this + -- mean that the constraint check is not needed, but an attempt to + -- perform the constraint check can cause order of elaboration + -- problems. + + if not Is_Constr_Subt_For_U_Nominal (Typ) then + + -- If this is an allocator for an aggregate that has been + -- allocated in place, delay checks until assignments are + -- made, because the discriminants are not initialized. + + if Nkind (Expr) = N_Allocator + and then No_Initialization (Expr) + then + null; + + -- Otherwise apply a constraint check now if no prev error + + elsif Nkind (Expr) /= N_Error then + Apply_Constraint_Check (Expr, Typ); + + -- If the expression has been marked as requiring a range + -- generate it now and reset the flag. + + if Do_Range_Check (Expr) then + Set_Do_Range_Check (Expr, False); + + if not Suppress_Assignment_Checks (N) then + Generate_Range_Check + (Expr, Typ, CE_Range_Check_Failed); + end if; + end if; + end if; + end if; + + -- If the type is controlled and not inherently limited, then + -- the target is adjusted after the copy and attached to the + -- finalization list. However, no adjustment is done in the case + -- where the object was initialized by a call to a function whose + -- result is built in place, since no copy occurred. (Eventually + -- we plan to support in-place function results for some cases + -- of nonlimited types. ???) Similarly, no adjustment is required + -- if we are going to rewrite the object declaration into a + -- renaming declaration. + + if Needs_Finalization (Typ) + and then not Is_Immutably_Limited_Type (Typ) + and then not Rewrite_As_Renaming + then + Insert_Actions_After (Init_After, + Make_Adjust_Call ( + Ref => New_Reference_To (Def_Id, Loc), + Typ => Base_Type (Typ), + Flist_Ref => Find_Final_List (Def_Id), + With_Attach => Make_Integer_Literal (Loc, 1))); + end if; + + -- For tagged types, when an init value is given, the tag has to + -- be re-initialized separately in order to avoid the propagation + -- of a wrong tag coming from a view conversion unless the type + -- is class wide (in this case the tag comes from the init value). + -- Suppress the tag assignment when VM_Target because VM tags are + -- represented implicitly in objects. Ditto for types that are + -- CPP_CLASS, and for initializations that are aggregates, because + -- they have to have the right tag. + + if Is_Tagged_Type (Typ) + and then not Is_Class_Wide_Type (Typ) + and then not Is_CPP_Class (Typ) + and then Tagged_Type_Expansion + and then Nkind (Expr) /= N_Aggregate + then + -- The re-assignment of the tag has to be done even if the + -- object is a constant. + + New_Ref := + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Def_Id, Loc), + Selector_Name => + New_Reference_To (First_Tag_Component (Typ), Loc)); + + Set_Assignment_OK (New_Ref); + + Insert_After (Init_After, + Make_Assignment_Statement (Loc, + Name => New_Ref, + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node + (First_Elmt + (Access_Disp_Table (Base_Type (Typ)))), + Loc)))); + + elsif Is_Tagged_Type (Typ) + and then Is_CPP_Constructor_Call (Expr) + then + -- The call to the initialization procedure does NOT freeze the + -- object being initialized. + + Id_Ref := New_Reference_To (Def_Id, Loc); + Set_Must_Not_Freeze (Id_Ref); + Set_Assignment_OK (Id_Ref); + + Insert_Actions_After (Init_After, + Build_Initialization_Call (Loc, Id_Ref, Typ, + Constructor_Ref => Expr)); + + -- We remove here the original call to the constructor + -- to avoid its management in the backend + + Set_Expression (N, Empty); + return; + + -- For discrete types, set the Is_Known_Valid flag if the + -- initializing value is known to be valid. + + elsif Is_Discrete_Type (Typ) and then Expr_Known_Valid (Expr) then + Set_Is_Known_Valid (Def_Id); + + elsif Is_Access_Type (Typ) then + + -- For access types set the Is_Known_Non_Null flag if the + -- initializing value is known to be non-null. We can also set + -- Can_Never_Be_Null if this is a constant. + + if Known_Non_Null (Expr) then + Set_Is_Known_Non_Null (Def_Id, True); + + if Constant_Present (N) then + Set_Can_Never_Be_Null (Def_Id); + end if; + end if; + end if; + + -- If validity checking on copies, validate initial expression. + -- But skip this if declaration is for a generic type, since it + -- makes no sense to validate generic types. Not clear if this + -- can happen for legal programs, but it definitely can arise + -- from previous instantiation errors. + + if Validity_Checks_On + and then Validity_Check_Copies + and then not Is_Generic_Type (Etype (Def_Id)) + then + Ensure_Valid (Expr); + Set_Is_Known_Valid (Def_Id); + end if; + end if; + + -- Cases where the back end cannot handle the initialization directly + -- In such cases, we expand an assignment that will be appropriately + -- handled by Expand_N_Assignment_Statement. + + -- The exclusion of the unconstrained case is wrong, but for now it + -- is too much trouble ??? + + if (Is_Possibly_Unaligned_Slice (Expr) + or else (Is_Possibly_Unaligned_Object (Expr) + and then not Represented_As_Scalar (Etype (Expr)))) + + -- The exclusion of the unconstrained case is wrong, but for now + -- it is too much trouble ??? + + and then not (Is_Array_Type (Etype (Expr)) + and then not Is_Constrained (Etype (Expr))) + then + declare + Stat : constant Node_Id := + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Def_Id, Loc), + Expression => Relocate_Node (Expr)); + begin + Set_Expression (N, Empty); + Set_No_Initialization (N); + Set_Assignment_OK (Name (Stat)); + Set_No_Ctrl_Actions (Stat); + Insert_After_And_Analyze (Init_After, Stat); + end; + end if; + + -- Final transformation, if the initializing expression is an entity + -- for a variable with OK_To_Rename set, then we transform: + + -- X : typ := expr; + + -- into + + -- X : typ renames expr + + -- provided that X is not aliased. The aliased case has to be + -- excluded in general because Expr will not be aliased in general. + + if Rewrite_As_Renaming then + Rewrite (N, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Defining_Identifier (N), + Subtype_Mark => Object_Definition (N), + Name => Expr_Q)); + + -- We do not analyze this renaming declaration, because all its + -- components have already been analyzed, and if we were to go + -- ahead and analyze it, we would in effect be trying to generate + -- another declaration of X, which won't do! + + Set_Renamed_Object (Defining_Identifier (N), Expr_Q); + Set_Analyzed (N); + end if; + end if; + + -- Exception on library entity not available + + exception + when RE_Not_Available => + return; + end Expand_N_Object_Declaration; + + --------------------------------- + -- Expand_N_Subtype_Indication -- + --------------------------------- + + -- Add a check on the range of the subtype. The static case is partially + -- duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need + -- to check here for the static case in order to avoid generating + -- extraneous expanded code. Also deal with validity checking. + + procedure Expand_N_Subtype_Indication (N : Node_Id) is + Ran : constant Node_Id := Range_Expression (Constraint (N)); + Typ : constant Entity_Id := Entity (Subtype_Mark (N)); + + begin + if Nkind (Constraint (N)) = N_Range_Constraint then + Validity_Check_Range (Range_Expression (Constraint (N))); + end if; + + if Nkind_In (Parent (N), N_Constrained_Array_Definition, N_Slice) then + Apply_Range_Check (Ran, Typ); + end if; + end Expand_N_Subtype_Indication; + + --------------------------- + -- Expand_N_Variant_Part -- + --------------------------- + + -- If the last variant does not contain the Others choice, replace it with + -- an N_Others_Choice node since Gigi always wants an Others. Note that we + -- do not bother to call Analyze on the modified variant part, since it's + -- only effect would be to compute the Others_Discrete_Choices node + -- laboriously, and of course we already know the list of choices that + -- corresponds to the others choice (it's the list we are replacing!) + + procedure Expand_N_Variant_Part (N : Node_Id) is + Last_Var : constant Node_Id := Last_Non_Pragma (Variants (N)); + Others_Node : Node_Id; + begin + if Nkind (First (Discrete_Choices (Last_Var))) /= N_Others_Choice then + Others_Node := Make_Others_Choice (Sloc (Last_Var)); + Set_Others_Discrete_Choices + (Others_Node, Discrete_Choices (Last_Var)); + Set_Discrete_Choices (Last_Var, New_List (Others_Node)); + end if; + end Expand_N_Variant_Part; + + --------------------------------- + -- Expand_Previous_Access_Type -- + --------------------------------- + + procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is + T : Entity_Id := First_Entity (Current_Scope); + + begin + -- Find all access types declared in the current scope, whose + -- designated type is Def_Id. If it does not have a Master_Id, + -- create one now. + + while Present (T) loop + if Is_Access_Type (T) + and then Designated_Type (T) = Def_Id + and then No (Master_Id (T)) + then + Build_Master_Entity (Def_Id); + Build_Master_Renaming (Parent (Def_Id), T); + end if; + + Next_Entity (T); + end loop; + end Expand_Previous_Access_Type; + + ------------------------------ + -- Expand_Record_Controller -- + ------------------------------ + + procedure Expand_Record_Controller (T : Entity_Id) is + Def : Node_Id := Type_Definition (Parent (T)); + Comp_List : Node_Id; + Comp_Decl : Node_Id; + Loc : Source_Ptr; + First_Comp : Node_Id; + Controller_Type : Entity_Id; + Ent : Entity_Id; + + begin + if Nkind (Def) = N_Derived_Type_Definition then + Def := Record_Extension_Part (Def); + end if; + + if Null_Present (Def) then + Set_Component_List (Def, + Make_Component_List (Sloc (Def), + Component_Items => Empty_List, + Variant_Part => Empty, + Null_Present => True)); + end if; + + Comp_List := Component_List (Def); + + if Null_Present (Comp_List) + or else Is_Empty_List (Component_Items (Comp_List)) + then + Loc := Sloc (Comp_List); + else + Loc := Sloc (First (Component_Items (Comp_List))); + end if; + + if Is_Immutably_Limited_Type (T) then + Controller_Type := RTE (RE_Limited_Record_Controller); + else + Controller_Type := RTE (RE_Record_Controller); + end if; + + Ent := Make_Defining_Identifier (Loc, Name_uController); + + Comp_Decl := + Make_Component_Declaration (Loc, + Defining_Identifier => Ent, + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => New_Reference_To (Controller_Type, Loc))); + + if Null_Present (Comp_List) + or else Is_Empty_List (Component_Items (Comp_List)) + then + Set_Component_Items (Comp_List, New_List (Comp_Decl)); + Set_Null_Present (Comp_List, False); + + else + -- The controller cannot be placed before the _Parent field since + -- gigi lays out field in order and _parent must be first to preserve + -- the polymorphism of tagged types. + + First_Comp := First (Component_Items (Comp_List)); + + if not Is_Tagged_Type (T) then + Insert_Before (First_Comp, Comp_Decl); + + -- if T is a tagged type, place controller declaration after parent + -- field and after eventual tags of interface types. + + else + while Present (First_Comp) + and then + (Chars (Defining_Identifier (First_Comp)) = Name_uParent + or else Is_Tag (Defining_Identifier (First_Comp)) + + -- Ada 2005 (AI-251): The following condition covers secondary + -- tags but also the adjacent component containing the offset + -- to the base of the object (component generated if the parent + -- has discriminants --- see Add_Interface_Tag_Components). + -- This is required to avoid the addition of the controller + -- between the secondary tag and its adjacent component. + + or else Present + (Related_Type + (Defining_Identifier (First_Comp)))) + loop + Next (First_Comp); + end loop; + + -- An empty tagged extension might consist only of the parent + -- component. Otherwise insert the controller before the first + -- component that is neither parent nor tag. + + if Present (First_Comp) then + Insert_Before (First_Comp, Comp_Decl); + else + Append (Comp_Decl, Component_Items (Comp_List)); + end if; + end if; + end if; + + Push_Scope (T); + Analyze (Comp_Decl); + Set_Ekind (Ent, E_Component); + Init_Component_Location (Ent); + + -- Move the _controller entity ahead in the list of internal entities + -- of the enclosing record so that it is selected instead of a + -- potentially inherited one. + + declare + E : constant Entity_Id := Last_Entity (T); + Comp : Entity_Id; + + begin + pragma Assert (Chars (E) = Name_uController); + + Set_Next_Entity (E, First_Entity (T)); + Set_First_Entity (T, E); + + Comp := Next_Entity (E); + while Next_Entity (Comp) /= E loop + Next_Entity (Comp); + end loop; + + Set_Next_Entity (Comp, Empty); + Set_Last_Entity (T, Comp); + end; + + End_Scope; + + exception + when RE_Not_Available => + return; + end Expand_Record_Controller; + + ------------------------ + -- Expand_Tagged_Root -- + ------------------------ + + procedure Expand_Tagged_Root (T : Entity_Id) is + Def : constant Node_Id := Type_Definition (Parent (T)); + Comp_List : Node_Id; + Comp_Decl : Node_Id; + Sloc_N : Source_Ptr; + + begin + if Null_Present (Def) then + Set_Component_List (Def, + Make_Component_List (Sloc (Def), + Component_Items => Empty_List, + Variant_Part => Empty, + Null_Present => True)); + end if; + + Comp_List := Component_List (Def); + + if Null_Present (Comp_List) + or else Is_Empty_List (Component_Items (Comp_List)) + then + Sloc_N := Sloc (Comp_List); + else + Sloc_N := Sloc (First (Component_Items (Comp_List))); + end if; + + Comp_Decl := + Make_Component_Declaration (Sloc_N, + Defining_Identifier => First_Tag_Component (T), + Component_Definition => + Make_Component_Definition (Sloc_N, + Aliased_Present => False, + Subtype_Indication => New_Reference_To (RTE (RE_Tag), Sloc_N))); + + if Null_Present (Comp_List) + or else Is_Empty_List (Component_Items (Comp_List)) + then + Set_Component_Items (Comp_List, New_List (Comp_Decl)); + Set_Null_Present (Comp_List, False); + + else + Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); + end if; + + -- We don't Analyze the whole expansion because the tag component has + -- already been analyzed previously. Here we just insure that the tree + -- is coherent with the semantic decoration + + Find_Type (Subtype_Indication (Component_Definition (Comp_Decl))); + + exception + when RE_Not_Available => + return; + end Expand_Tagged_Root; + + ---------------------- + -- Clean_Task_Names -- + ---------------------- + + procedure Clean_Task_Names + (Typ : Entity_Id; + Proc_Id : Entity_Id) + is + begin + if Has_Task (Typ) + and then not Restriction_Active (No_Implicit_Heap_Allocations) + and then not Global_Discard_Names + and then Tagged_Type_Expansion + then + Set_Uses_Sec_Stack (Proc_Id); + end if; + end Clean_Task_Names; + + ------------------------------ + -- Expand_Freeze_Array_Type -- + ------------------------------ + + procedure Expand_Freeze_Array_Type (N : Node_Id) is + Typ : constant Entity_Id := Entity (N); + Comp_Typ : constant Entity_Id := Component_Type (Typ); + Base : constant Entity_Id := Base_Type (Typ); + + begin + if not Is_Bit_Packed_Array (Typ) then + + -- If the component contains tasks, so does the array type. This may + -- not be indicated in the array type because the component may have + -- been a private type at the point of definition. Same if component + -- type is controlled. + + Set_Has_Task (Base, Has_Task (Comp_Typ)); + Set_Has_Controlled_Component (Base, + Has_Controlled_Component (Comp_Typ) + or else Is_Controlled (Comp_Typ)); + + if No (Init_Proc (Base)) then + + -- If this is an anonymous array created for a declaration with + -- an initial value, its init_proc will never be called. The + -- initial value itself may have been expanded into assignments, + -- in which case the object declaration is carries the + -- No_Initialization flag. + + if Is_Itype (Base) + and then Nkind (Associated_Node_For_Itype (Base)) = + N_Object_Declaration + and then (Present (Expression (Associated_Node_For_Itype (Base))) + or else + No_Initialization (Associated_Node_For_Itype (Base))) + then + null; + + -- We do not need an init proc for string or wide [wide] string, + -- since the only time these need initialization in normalize or + -- initialize scalars mode, and these types are treated specially + -- and do not need initialization procedures. + + elsif Root_Type (Base) = Standard_String + or else Root_Type (Base) = Standard_Wide_String + or else Root_Type (Base) = Standard_Wide_Wide_String + then + null; + + -- Otherwise we have to build an init proc for the subtype + + else + Build_Array_Init_Proc (Base, N); + end if; + end if; + + if Typ = Base then + if Has_Controlled_Component (Base) then + Build_Controlling_Procs (Base); + + if not Is_Limited_Type (Comp_Typ) + and then Number_Dimensions (Typ) = 1 + then + Build_Slice_Assignment (Typ); + end if; + + elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type + and then Needs_Finalization (Directly_Designated_Type (Comp_Typ)) + then + Set_Associated_Final_Chain (Comp_Typ, Add_Final_Chain (Typ)); + end if; + end if; + + -- For packed case, default initialization, except if the component type + -- is itself a packed structure with an initialization procedure, or + -- initialize/normalize scalars active, and we have a base type, or the + -- type is public, because in that case a client might specify + -- Normalize_Scalars and there better be a public Init_Proc for it. + + elsif (Present (Init_Proc (Component_Type (Base))) + and then No (Base_Init_Proc (Base))) + or else (Init_Or_Norm_Scalars and then Base = Typ) + or else Is_Public (Typ) + then + Build_Array_Init_Proc (Base, N); + end if; + end Expand_Freeze_Array_Type; + + ------------------------------------ + -- Expand_Freeze_Enumeration_Type -- + ------------------------------------ + + procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is + Typ : constant Entity_Id := Entity (N); + Loc : constant Source_Ptr := Sloc (Typ); + Ent : Entity_Id; + Lst : List_Id; + Num : Nat; + Arr : Entity_Id; + Fent : Entity_Id; + Ityp : Entity_Id; + Is_Contiguous : Boolean; + Pos_Expr : Node_Id; + Last_Repval : Uint; + + Func : Entity_Id; + pragma Warnings (Off, Func); + + begin + -- Various optimizations possible if given representation is contiguous + + Is_Contiguous := True; + + Ent := First_Literal (Typ); + Last_Repval := Enumeration_Rep (Ent); + + Next_Literal (Ent); + while Present (Ent) loop + if Enumeration_Rep (Ent) - Last_Repval /= 1 then + Is_Contiguous := False; + exit; + else + Last_Repval := Enumeration_Rep (Ent); + end if; + + Next_Literal (Ent); + end loop; + + if Is_Contiguous then + Set_Has_Contiguous_Rep (Typ); + Ent := First_Literal (Typ); + Num := 1; + Lst := New_List (New_Reference_To (Ent, Sloc (Ent))); + + else + -- Build list of literal references + + Lst := New_List; + Num := 0; + + Ent := First_Literal (Typ); + while Present (Ent) loop + Append_To (Lst, New_Reference_To (Ent, Sloc (Ent))); + Num := Num + 1; + Next_Literal (Ent); + end loop; + end if; + + -- Now build an array declaration + + -- typA : array (Natural range 0 .. num - 1) of ctype := + -- (v, v, v, v, v, ....) + + -- where ctype is the corresponding integer type. If the representation + -- is contiguous, we only keep the first literal, which provides the + -- offset for Pos_To_Rep computations. + + Arr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), 'A')); + + Append_Freeze_Action (Typ, + Make_Object_Declaration (Loc, + Defining_Identifier => Arr, + Constant_Present => True, + + Object_Definition => + Make_Constrained_Array_Definition (Loc, + Discrete_Subtype_Definitions => New_List ( + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (Standard_Natural, Loc), + Constraint => + Make_Range_Constraint (Loc, + Range_Expression => + Make_Range (Loc, + Low_Bound => + Make_Integer_Literal (Loc, 0), + High_Bound => + Make_Integer_Literal (Loc, Num - 1))))), + + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => New_Reference_To (Typ, Loc))), + + Expression => + Make_Aggregate (Loc, + Expressions => Lst))); + + Set_Enum_Pos_To_Rep (Typ, Arr); + + -- Now we build the function that converts representation values to + -- position values. This function has the form: + + -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is + -- begin + -- case ityp!(A) is + -- when enum-lit'Enum_Rep => return posval; + -- when enum-lit'Enum_Rep => return posval; + -- ... + -- when others => + -- [raise Constraint_Error when F "invalid data"] + -- return -1; + -- end case; + -- end; + + -- Note: the F parameter determines whether the others case (no valid + -- representation) raises Constraint_Error or returns a unique value + -- of minus one. The latter case is used, e.g. in 'Valid code. + + -- Note: the reason we use Enum_Rep values in the case here is to avoid + -- the code generator making inappropriate assumptions about the range + -- of the values in the case where the value is invalid. ityp is a + -- signed or unsigned integer type of appropriate width. + + -- Note: if exceptions are not supported, then we suppress the raise + -- and return -1 unconditionally (this is an erroneous program in any + -- case and there is no obligation to raise Constraint_Error here!) We + -- also do this if pragma Restrictions (No_Exceptions) is active. + + -- Is this right??? What about No_Exception_Propagation??? + + -- Representations are signed + + if Enumeration_Rep (First_Literal (Typ)) < 0 then + + -- The underlying type is signed. Reset the Is_Unsigned_Type + -- explicitly, because it might have been inherited from + -- parent type. + + Set_Is_Unsigned_Type (Typ, False); + + if Esize (Typ) <= Standard_Integer_Size then + Ityp := Standard_Integer; + else + Ityp := Universal_Integer; + end if; + + -- Representations are unsigned + + else + if Esize (Typ) <= Standard_Integer_Size then + Ityp := RTE (RE_Unsigned); + else + Ityp := RTE (RE_Long_Long_Unsigned); + end if; + end if; + + -- The body of the function is a case statement. First collect case + -- alternatives, or optimize the contiguous case. + + Lst := New_List; + + -- If representation is contiguous, Pos is computed by subtracting + -- the representation of the first literal. + + if Is_Contiguous then + Ent := First_Literal (Typ); + + if Enumeration_Rep (Ent) = Last_Repval then + + -- Another special case: for a single literal, Pos is zero + + Pos_Expr := Make_Integer_Literal (Loc, Uint_0); + + else + Pos_Expr := + Convert_To (Standard_Integer, + Make_Op_Subtract (Loc, + Left_Opnd => + Unchecked_Convert_To + (Ityp, Make_Identifier (Loc, Name_uA)), + Right_Opnd => + Make_Integer_Literal (Loc, + Intval => Enumeration_Rep (First_Literal (Typ))))); + end if; + + Append_To (Lst, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List ( + Make_Range (Sloc (Enumeration_Rep_Expr (Ent)), + Low_Bound => + Make_Integer_Literal (Loc, + Intval => Enumeration_Rep (Ent)), + High_Bound => + Make_Integer_Literal (Loc, Intval => Last_Repval))), + + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => Pos_Expr)))); + + else + Ent := First_Literal (Typ); + while Present (Ent) loop + Append_To (Lst, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List ( + Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)), + Intval => Enumeration_Rep (Ent))), + + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Integer_Literal (Loc, + Intval => Enumeration_Pos (Ent)))))); + + Next_Literal (Ent); + end loop; + end if; + + -- In normal mode, add the others clause with the test + + if not No_Exception_Handlers_Set then + Append_To (Lst, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List ( + Make_Raise_Constraint_Error (Loc, + Condition => Make_Identifier (Loc, Name_uF), + Reason => CE_Invalid_Data), + Make_Simple_Return_Statement (Loc, + Expression => + Make_Integer_Literal (Loc, -1))))); + + -- If either of the restrictions No_Exceptions_Handlers/Propagation is + -- active then return -1 (we cannot usefully raise Constraint_Error in + -- this case). See description above for further details. + + else + Append_To (Lst, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Integer_Literal (Loc, -1))))); + end if; + + -- Now we can build the function body + + Fent := + Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos)); + + Func := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Fent, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uA), + Parameter_Type => New_Reference_To (Typ, Loc)), + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uF), + Parameter_Type => New_Reference_To (Standard_Boolean, Loc))), + + Result_Definition => New_Reference_To (Standard_Integer, Loc)), + + Declarations => Empty_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Case_Statement (Loc, + Expression => + Unchecked_Convert_To + (Ityp, Make_Identifier (Loc, Name_uA)), + Alternatives => Lst)))); + + Set_TSS (Typ, Fent); + + -- Set Pure flag (it will be reset if the current context is not Pure). + -- We also pretend there was a pragma Pure_Function so that for purposes + -- of optimization and constant-folding, we will consider the function + -- Pure even if we are not in a Pure context). + + Set_Is_Pure (Fent); + Set_Has_Pragma_Pure_Function (Fent); + + -- Unless we are in -gnatD mode, where we are debugging generated code, + -- this is an internal entity for which we don't need debug info. + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Fent); + end if; + + exception + when RE_Not_Available => + return; + end Expand_Freeze_Enumeration_Type; + + ------------------------------- + -- Expand_Freeze_Record_Type -- + ------------------------------- + + procedure Expand_Freeze_Record_Type (N : Node_Id) is + Def_Id : constant Node_Id := Entity (N); + Type_Decl : constant Node_Id := Parent (Def_Id); + Comp : Entity_Id; + Comp_Typ : Entity_Id; + Predef_List : List_Id; + + Flist : Entity_Id := Empty; + -- Finalization list allocated for the case of a type with anonymous + -- access components whose designated type is potentially controlled. + + Renamed_Eq : Node_Id := Empty; + -- Defining unit name for the predefined equality function in the case + -- where the type has a primitive operation that is a renaming of + -- predefined equality (but only if there is also an overriding + -- user-defined equality function). Used to pass this entity from + -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies. + + Wrapper_Decl_List : List_Id := No_List; + Wrapper_Body_List : List_Id := No_List; + + -- Start of processing for Expand_Freeze_Record_Type + + begin + -- Build discriminant checking functions if not a derived type (for + -- derived types that are not tagged types, always use the discriminant + -- checking functions of the parent type). However, for untagged types + -- the derivation may have taken place before the parent was frozen, so + -- we copy explicitly the discriminant checking functions from the + -- parent into the components of the derived type. + + if not Is_Derived_Type (Def_Id) + or else Has_New_Non_Standard_Rep (Def_Id) + or else Is_Tagged_Type (Def_Id) + then + Build_Discr_Checking_Funcs (Type_Decl); + + elsif Is_Derived_Type (Def_Id) + and then not Is_Tagged_Type (Def_Id) + + -- If we have a derived Unchecked_Union, we do not inherit the + -- discriminant checking functions from the parent type since the + -- discriminants are non existent. + + and then not Is_Unchecked_Union (Def_Id) + and then Has_Discriminants (Def_Id) + then + declare + Old_Comp : Entity_Id; + + begin + Old_Comp := + First_Component (Base_Type (Underlying_Type (Etype (Def_Id)))); + Comp := First_Component (Def_Id); + while Present (Comp) loop + if Ekind (Comp) = E_Component + and then Chars (Comp) = Chars (Old_Comp) + then + Set_Discriminant_Checking_Func (Comp, + Discriminant_Checking_Func (Old_Comp)); + end if; + + Next_Component (Old_Comp); + Next_Component (Comp); + end loop; + end; + end if; + + if Is_Derived_Type (Def_Id) + and then Is_Limited_Type (Def_Id) + and then Is_Tagged_Type (Def_Id) + then + Check_Stream_Attributes (Def_Id); + end if; + + -- Update task and controlled component flags, because some of the + -- component types may have been private at the point of the record + -- declaration. + + Comp := First_Component (Def_Id); + while Present (Comp) loop + Comp_Typ := Etype (Comp); + + if Has_Task (Comp_Typ) then + Set_Has_Task (Def_Id); + + -- Do not set Has_Controlled_Component on a class-wide equivalent + -- type. See Make_CW_Equivalent_Type. + + elsif not Is_Class_Wide_Equivalent_Type (Def_Id) + and then (Has_Controlled_Component (Comp_Typ) + or else (Chars (Comp) /= Name_uParent + and then Is_Controlled (Comp_Typ))) + then + Set_Has_Controlled_Component (Def_Id); + + elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type + and then Needs_Finalization (Directly_Designated_Type (Comp_Typ)) + then + if No (Flist) then + Flist := Add_Final_Chain (Def_Id); + end if; + + Set_Associated_Final_Chain (Comp_Typ, Flist); + end if; + + Next_Component (Comp); + end loop; + + -- Handle constructors of non-tagged CPP_Class types + + if not Is_Tagged_Type (Def_Id) and then Is_CPP_Class (Def_Id) then + Set_CPP_Constructors (Def_Id); + end if; + + -- Creation of the Dispatch Table. Note that a Dispatch Table is built + -- for regular tagged types as well as for Ada types deriving from a C++ + -- Class, but not for tagged types directly corresponding to C++ classes + -- In the later case we assume that it is created in the C++ side and we + -- just use it. + + if Is_Tagged_Type (Def_Id) then + + -- Add the _Tag component + + if Underlying_Type (Etype (Def_Id)) = Def_Id then + Expand_Tagged_Root (Def_Id); + end if; + + if Is_CPP_Class (Def_Id) then + Set_All_DT_Position (Def_Id); + + -- Create the tag entities with a minimum decoration + + if Tagged_Type_Expansion then + Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id)); + end if; + + Set_CPP_Constructors (Def_Id); + + else + if not Building_Static_DT (Def_Id) then + + -- Usually inherited primitives are not delayed but the first + -- Ada extension of a CPP_Class is an exception since the + -- address of the inherited subprogram has to be inserted in + -- the new Ada Dispatch Table and this is a freezing action. + + -- Similarly, if this is an inherited operation whose parent is + -- not frozen yet, it is not in the DT of the parent, and we + -- generate an explicit freeze node for the inherited operation + -- so it is properly inserted in the DT of the current type. + + declare + Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + Elmt := First_Elmt (Primitive_Operations (Def_Id)); + while Present (Elmt) loop + Subp := Node (Elmt); + + if Present (Alias (Subp)) then + if Is_CPP_Class (Etype (Def_Id)) then + Set_Has_Delayed_Freeze (Subp); + + elsif Has_Delayed_Freeze (Alias (Subp)) + and then not Is_Frozen (Alias (Subp)) + then + Set_Is_Frozen (Subp, False); + Set_Has_Delayed_Freeze (Subp); + end if; + end if; + + Next_Elmt (Elmt); + end loop; + end; + end if; + + -- Unfreeze momentarily the type to add the predefined primitives + -- operations. The reason we unfreeze is so that these predefined + -- operations will indeed end up as primitive operations (which + -- must be before the freeze point). + + Set_Is_Frozen (Def_Id, False); + + -- Do not add the spec of predefined primitives in case of + -- CPP tagged type derivations that have convention CPP. + + if Is_CPP_Class (Root_Type (Def_Id)) + and then Convention (Def_Id) = Convention_CPP + then + null; + + -- Do not add the spec of predefined primitives in case of + -- CIL and Java tagged types + + elsif Convention (Def_Id) = Convention_CIL + or else Convention (Def_Id) = Convention_Java + then + null; + + -- Do not add the spec of the predefined primitives if we are + -- compiling under restriction No_Dispatching_Calls + + elsif not Restriction_Active (No_Dispatching_Calls) then + Make_Predefined_Primitive_Specs + (Def_Id, Predef_List, Renamed_Eq); + Insert_List_Before_And_Analyze (N, Predef_List); + end if; + + -- Ada 2005 (AI-391): For a nonabstract null extension, create + -- wrapper functions for each nonoverridden inherited function + -- with a controlling result of the type. The wrapper for such + -- a function returns an extension aggregate that invokes the + -- parent function. + + if Ada_Version >= Ada_2005 + and then not Is_Abstract_Type (Def_Id) + and then Is_Null_Extension (Def_Id) + then + Make_Controlling_Function_Wrappers + (Def_Id, Wrapper_Decl_List, Wrapper_Body_List); + Insert_List_Before_And_Analyze (N, Wrapper_Decl_List); + end if; + + -- Ada 2005 (AI-251): For a nonabstract type extension, build + -- null procedure declarations for each set of homographic null + -- procedures that are inherited from interface types but not + -- overridden. This is done to ensure that the dispatch table + -- entry associated with such null primitives are properly filled. + + if Ada_Version >= Ada_2005 + and then Etype (Def_Id) /= Def_Id + and then not Is_Abstract_Type (Def_Id) + and then Has_Interfaces (Def_Id) + then + Insert_Actions (N, Make_Null_Procedure_Specs (Def_Id)); + end if; + + Set_Is_Frozen (Def_Id); + if not Is_Derived_Type (Def_Id) + or else Is_Tagged_Type (Etype (Def_Id)) + then + Set_All_DT_Position (Def_Id); + end if; + + -- Add the controlled component before the freezing actions + -- referenced in those actions. + + if Has_New_Controlled_Component (Def_Id) then + Expand_Record_Controller (Def_Id); + end if; + + -- Create and decorate the tags. Suppress their creation when + -- VM_Target because the dispatching mechanism is handled + -- internally by the VMs. + + if Tagged_Type_Expansion then + Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id)); + + -- Generate dispatch table of locally defined tagged type. + -- Dispatch tables of library level tagged types are built + -- later (see Analyze_Declarations). + + if not Building_Static_DT (Def_Id) then + Append_Freeze_Actions (Def_Id, Make_DT (Def_Id)); + end if; + end if; + + -- If the type has unknown discriminants, propagate dispatching + -- information to its underlying record view, which does not get + -- its own dispatch table. + + if Is_Derived_Type (Def_Id) + and then Has_Unknown_Discriminants (Def_Id) + and then Present (Underlying_Record_View (Def_Id)) + then + declare + Rep : constant Entity_Id := + Underlying_Record_View (Def_Id); + begin + Set_Access_Disp_Table + (Rep, Access_Disp_Table (Def_Id)); + Set_Dispatch_Table_Wrappers + (Rep, Dispatch_Table_Wrappers (Def_Id)); + Set_Direct_Primitive_Operations + (Rep, Direct_Primitive_Operations (Def_Id)); + end; + end if; + + -- Make sure that the primitives Initialize, Adjust and Finalize + -- are Frozen before other TSS subprograms. We don't want them + -- Frozen inside. + + if Is_Controlled (Def_Id) then + if not Is_Limited_Type (Def_Id) then + Append_Freeze_Actions (Def_Id, + Freeze_Entity + (Find_Prim_Op (Def_Id, Name_Adjust), Def_Id)); + end if; + + Append_Freeze_Actions (Def_Id, + Freeze_Entity + (Find_Prim_Op (Def_Id, Name_Initialize), Def_Id)); + + Append_Freeze_Actions (Def_Id, + Freeze_Entity + (Find_Prim_Op (Def_Id, Name_Finalize), Def_Id)); + end if; + + -- Freeze rest of primitive operations. There is no need to handle + -- the predefined primitives if we are compiling under restriction + -- No_Dispatching_Calls + + if not Restriction_Active (No_Dispatching_Calls) then + Append_Freeze_Actions + (Def_Id, Predefined_Primitive_Freeze (Def_Id)); + end if; + end if; + + -- In the non-tagged case, ever since Ada83 an equality function must + -- be provided for variant records that are not unchecked unions. + -- In Ada 2012 the equality function composes, and thus must be built + -- explicitly just as for tagged records. + + elsif Has_Discriminants (Def_Id) + and then not Is_Limited_Type (Def_Id) + then + declare + Comps : constant Node_Id := + Component_List (Type_Definition (Type_Decl)); + begin + if Present (Comps) + and then Present (Variant_Part (Comps)) + then + Build_Variant_Record_Equality (Def_Id); + end if; + end; + + -- Otherwise create primitive equality operation (AI05-0123) + + -- This is done unconditionally to ensure that tools can be linked + -- properly with user programs compiled with older language versions. + -- It might be worth including a switch to revert to a non-composable + -- equality for untagged records, even though no program depending on + -- non-composability has surfaced ??? + + elsif Comes_From_Source (Def_Id) + and then Convention (Def_Id) = Convention_Ada + and then not Is_Limited_Type (Def_Id) + then + Build_Untagged_Equality (Def_Id); + end if; + + -- Before building the record initialization procedure, if we are + -- dealing with a concurrent record value type, then we must go through + -- the discriminants, exchanging discriminals between the concurrent + -- type and the concurrent record value type. See the section "Handling + -- of Discriminants" in the Einfo spec for details. + + if Is_Concurrent_Record_Type (Def_Id) + and then Has_Discriminants (Def_Id) + then + declare + Ctyp : constant Entity_Id := + Corresponding_Concurrent_Type (Def_Id); + Conc_Discr : Entity_Id; + Rec_Discr : Entity_Id; + Temp : Entity_Id; + + begin + Conc_Discr := First_Discriminant (Ctyp); + Rec_Discr := First_Discriminant (Def_Id); + while Present (Conc_Discr) loop + Temp := Discriminal (Conc_Discr); + Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr)); + Set_Discriminal (Rec_Discr, Temp); + + Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr); + Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr); + + Next_Discriminant (Conc_Discr); + Next_Discriminant (Rec_Discr); + end loop; + end; + end if; + + if Has_Controlled_Component (Def_Id) then + if No (Controller_Component (Def_Id)) then + Expand_Record_Controller (Def_Id); + end if; + + Build_Controlling_Procs (Def_Id); + end if; + + Adjust_Discriminants (Def_Id); + + if Tagged_Type_Expansion or else not Is_Interface (Def_Id) then + + -- Do not need init for interfaces on e.g. CIL since they're + -- abstract. Helps operation of peverify (the PE Verify tool). + + Build_Record_Init_Proc (Type_Decl, Def_Id); + end if; + + -- For tagged type that are not interfaces, build bodies of primitive + -- operations. Note: do this after building the record initialization + -- procedure, since the primitive operations may need the initialization + -- routine. There is no need to add predefined primitives of interfaces + -- because all their predefined primitives are abstract. + + if Is_Tagged_Type (Def_Id) + and then not Is_Interface (Def_Id) + then + -- Do not add the body of predefined primitives in case of + -- CPP tagged type derivations that have convention CPP. + + if Is_CPP_Class (Root_Type (Def_Id)) + and then Convention (Def_Id) = Convention_CPP + then + null; + + -- Do not add the body of predefined primitives in case of + -- CIL and Java tagged types. + + elsif Convention (Def_Id) = Convention_CIL + or else Convention (Def_Id) = Convention_Java + then + null; + + -- Do not add the body of the predefined primitives if we are + -- compiling under restriction No_Dispatching_Calls or if we are + -- compiling a CPP tagged type. + + elsif not Restriction_Active (No_Dispatching_Calls) then + Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq); + Append_Freeze_Actions (Def_Id, Predef_List); + end if; + + -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden + -- inherited functions, then add their bodies to the freeze actions. + + if Present (Wrapper_Body_List) then + Append_Freeze_Actions (Def_Id, Wrapper_Body_List); + end if; + + -- Create extra formals for the primitive operations of the type. + -- This must be done before analyzing the body of the initialization + -- procedure, because a self-referential type might call one of these + -- primitives in the body of the init_proc itself. + + declare + Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + Elmt := First_Elmt (Primitive_Operations (Def_Id)); + while Present (Elmt) loop + Subp := Node (Elmt); + if not Has_Foreign_Convention (Subp) + and then not Is_Predefined_Dispatching_Operation (Subp) + then + Create_Extra_Formals (Subp); + end if; + + Next_Elmt (Elmt); + end loop; + end; + end if; + end Expand_Freeze_Record_Type; + + ------------------------------ + -- Freeze_Stream_Operations -- + ------------------------------ + + procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id) is + Names : constant array (1 .. 4) of TSS_Name_Type := + (TSS_Stream_Input, + TSS_Stream_Output, + TSS_Stream_Read, + TSS_Stream_Write); + Stream_Op : Entity_Id; + + begin + -- Primitive operations of tagged types are frozen when the dispatch + -- table is constructed. + + if not Comes_From_Source (Typ) + or else Is_Tagged_Type (Typ) + then + return; + end if; + + for J in Names'Range loop + Stream_Op := TSS (Typ, Names (J)); + + if Present (Stream_Op) + and then Is_Subprogram (Stream_Op) + and then Nkind (Unit_Declaration_Node (Stream_Op)) = + N_Subprogram_Declaration + and then not Is_Frozen (Stream_Op) + then + Append_Freeze_Actions (Typ, Freeze_Entity (Stream_Op, N)); + end if; + end loop; + end Freeze_Stream_Operations; + + ----------------- + -- Freeze_Type -- + ----------------- + + -- Full type declarations are expanded at the point at which the type is + -- frozen. The formal N is the Freeze_Node for the type. Any statements or + -- declarations generated by the freezing (e.g. the procedure generated + -- for initialization) are chained in the Actions field list of the freeze + -- node using Append_Freeze_Actions. + + function Freeze_Type (N : Node_Id) return Boolean is + Def_Id : constant Entity_Id := Entity (N); + RACW_Seen : Boolean := False; + Result : Boolean := False; + + begin + -- Process associated access types needing special processing + + if Present (Access_Types_To_Process (N)) then + declare + E : Elmt_Id := First_Elmt (Access_Types_To_Process (N)); + begin + while Present (E) loop + + if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then + Validate_RACW_Primitives (Node (E)); + RACW_Seen := True; + end if; + + E := Next_Elmt (E); + end loop; + end; + + if RACW_Seen then + + -- If there are RACWs designating this type, make stubs now + + Remote_Types_Tagged_Full_View_Encountered (Def_Id); + end if; + end if; + + -- Freeze processing for record types + + if Is_Record_Type (Def_Id) then + if Ekind (Def_Id) = E_Record_Type then + Expand_Freeze_Record_Type (N); + + -- The subtype may have been declared before the type was frozen. If + -- the type has controlled components it is necessary to create the + -- entity for the controller explicitly because it did not exist at + -- the point of the subtype declaration. Only the entity is needed, + -- the back-end will obtain the layout from the type. This is only + -- necessary if this is constrained subtype whose component list is + -- not shared with the base type. + + elsif Ekind (Def_Id) = E_Record_Subtype + and then Has_Discriminants (Def_Id) + and then Last_Entity (Def_Id) /= Last_Entity (Base_Type (Def_Id)) + and then Present (Controller_Component (Def_Id)) + then + declare + Old_C : constant Entity_Id := Controller_Component (Def_Id); + New_C : Entity_Id; + + begin + if Scope (Old_C) = Base_Type (Def_Id) then + + -- The entity is the one in the parent. Create new one + + New_C := New_Copy (Old_C); + Set_Parent (New_C, Parent (Old_C)); + Push_Scope (Def_Id); + Enter_Name (New_C); + End_Scope; + end if; + end; + + if Is_Itype (Def_Id) + and then Is_Record_Type (Underlying_Type (Scope (Def_Id))) + then + -- The freeze node is only used to introduce the controller, + -- the back-end has no use for it for a discriminated + -- component. + + Set_Freeze_Node (Def_Id, Empty); + Set_Has_Delayed_Freeze (Def_Id, False); + Result := True; + end if; + + -- Similar process if the controller of the subtype is not present + -- but the parent has it. This can happen with constrained + -- record components where the subtype is an itype. + + elsif Ekind (Def_Id) = E_Record_Subtype + and then Is_Itype (Def_Id) + and then No (Controller_Component (Def_Id)) + and then Present (Controller_Component (Etype (Def_Id))) + then + declare + Old_C : constant Entity_Id := + Controller_Component (Etype (Def_Id)); + New_C : constant Entity_Id := New_Copy (Old_C); + + begin + Set_Next_Entity (New_C, First_Entity (Def_Id)); + Set_First_Entity (Def_Id, New_C); + + -- The freeze node is only used to introduce the controller, + -- the back-end has no use for it for a discriminated + -- component. + + Set_Freeze_Node (Def_Id, Empty); + Set_Has_Delayed_Freeze (Def_Id, False); + Result := True; + end; + end if; + + -- Freeze processing for array types + + elsif Is_Array_Type (Def_Id) then + Expand_Freeze_Array_Type (N); + + -- Freeze processing for access types + + -- For pool-specific access types, find out the pool object used for + -- this type, needs actual expansion of it in some cases. Here are the + -- different cases : + + -- 1. Rep Clause "for Def_Id'Storage_Size use 0;" + -- ---> don't use any storage pool + + -- 2. Rep Clause : for Def_Id'Storage_Size use Expr. + -- Expand: + -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment); + + -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object" + -- ---> Storage Pool is the specified one + + -- See GNAT Pool packages in the Run-Time for more details + + elsif Ekind_In (Def_Id, E_Access_Type, E_General_Access_Type) then + declare + Loc : constant Source_Ptr := Sloc (N); + Desig_Type : constant Entity_Id := Designated_Type (Def_Id); + Pool_Object : Entity_Id; + + Freeze_Action_Typ : Entity_Id; + + begin + -- Case 1 + + -- Rep Clause "for Def_Id'Storage_Size use 0;" + -- ---> don't use any storage pool + + if No_Pool_Assigned (Def_Id) then + null; + + -- Case 2 + + -- Rep Clause : for Def_Id'Storage_Size use Expr. + -- ---> Expand: + -- Def_Id__Pool : Stack_Bounded_Pool + -- (Expr, DT'Size, DT'Alignment); + + elsif Has_Storage_Size_Clause (Def_Id) then + declare + DT_Size : Node_Id; + DT_Align : Node_Id; + + begin + -- For unconstrained composite types we give a size of zero + -- so that the pool knows that it needs a special algorithm + -- for variable size object allocation. + + if Is_Composite_Type (Desig_Type) + and then not Is_Constrained (Desig_Type) + then + DT_Size := + Make_Integer_Literal (Loc, 0); + + DT_Align := + Make_Integer_Literal (Loc, Maximum_Alignment); + + else + DT_Size := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Desig_Type, Loc), + Attribute_Name => Name_Max_Size_In_Storage_Elements); + + DT_Align := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Desig_Type, Loc), + Attribute_Name => Name_Alignment); + end if; + + Pool_Object := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Def_Id), 'P')); + + -- We put the code associated with the pools in the entity + -- that has the later freeze node, usually the access type + -- but it can also be the designated_type; because the pool + -- code requires both those types to be frozen + + if Is_Frozen (Desig_Type) + and then (No (Freeze_Node (Desig_Type)) + or else Analyzed (Freeze_Node (Desig_Type))) + then + Freeze_Action_Typ := Def_Id; + + -- A Taft amendment type cannot get the freeze actions + -- since the full view is not there. + + elsif Is_Incomplete_Or_Private_Type (Desig_Type) + and then No (Full_View (Desig_Type)) + then + Freeze_Action_Typ := Def_Id; + + else + Freeze_Action_Typ := Desig_Type; + end if; + + Append_Freeze_Action (Freeze_Action_Typ, + Make_Object_Declaration (Loc, + Defining_Identifier => Pool_Object, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To + (RTE (RE_Stack_Bounded_Pool), Loc), + + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + + -- First discriminant is the Pool Size + + New_Reference_To ( + Storage_Size_Variable (Def_Id), Loc), + + -- Second discriminant is the element size + + DT_Size, + + -- Third discriminant is the alignment + + DT_Align))))); + end; + + Set_Associated_Storage_Pool (Def_Id, Pool_Object); + + -- Case 3 + + -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object" + -- ---> Storage Pool is the specified one + + elsif Present (Associated_Storage_Pool (Def_Id)) then + + -- Nothing to do the associated storage pool has been attached + -- when analyzing the rep. clause + + null; + end if; + + -- For access-to-controlled types (including class-wide types and + -- Taft-amendment types which potentially have controlled + -- components), expand the list controller object that will store + -- the dynamically allocated objects. Do not do this + -- transformation for expander-generated access types, but do it + -- for types that are the full view of types derived from other + -- private types. Also suppress the list controller in the case + -- of a designated type with convention Java, since this is used + -- when binding to Java API specs, where there's no equivalent of + -- a finalization list and we don't want to pull in the + -- finalization support if not needed. + + if not Comes_From_Source (Def_Id) + and then not Has_Private_Declaration (Def_Id) + then + null; + + elsif (Needs_Finalization (Desig_Type) + and then Convention (Desig_Type) /= Convention_Java + and then Convention (Desig_Type) /= Convention_CIL) + or else + (Is_Incomplete_Or_Private_Type (Desig_Type) + and then No (Full_View (Desig_Type)) + + -- An exception is made for types defined in the run-time + -- because Ada.Tags.Tag itself is such a type and cannot + -- afford this unnecessary overhead that would generates a + -- loop in the expansion scheme... + + and then not In_Runtime (Def_Id) + + -- Another exception is if Restrictions (No_Finalization) + -- is active, since then we know nothing is controlled. + + and then not Restriction_Active (No_Finalization)) + + -- If the designated type is not frozen yet, its controlled + -- status must be retrieved explicitly. + + or else (Is_Array_Type (Desig_Type) + and then not Is_Frozen (Desig_Type) + and then Needs_Finalization (Component_Type (Desig_Type))) + + -- The designated type has controlled anonymous access + -- discriminants. + + or else Has_Controlled_Coextensions (Desig_Type) + then + Set_Associated_Final_Chain (Def_Id, Add_Final_Chain (Def_Id)); + end if; + end; + + -- Freeze processing for enumeration types + + elsif Ekind (Def_Id) = E_Enumeration_Type then + + -- We only have something to do if we have a non-standard + -- representation (i.e. at least one literal whose pos value + -- is not the same as its representation) + + if Has_Non_Standard_Rep (Def_Id) then + Expand_Freeze_Enumeration_Type (N); + end if; + + -- Private types that are completed by a derivation from a private + -- type have an internally generated full view, that needs to be + -- frozen. This must be done explicitly because the two views share + -- the freeze node, and the underlying full view is not visible when + -- the freeze node is analyzed. + + elsif Is_Private_Type (Def_Id) + and then Is_Derived_Type (Def_Id) + and then Present (Full_View (Def_Id)) + and then Is_Itype (Full_View (Def_Id)) + and then Has_Private_Declaration (Full_View (Def_Id)) + and then Freeze_Node (Full_View (Def_Id)) = N + then + Set_Entity (N, Full_View (Def_Id)); + Result := Freeze_Type (N); + Set_Entity (N, Def_Id); + + -- All other types require no expander action. There are such cases + -- (e.g. task types and protected types). In such cases, the freeze + -- nodes are there for use by Gigi. + + end if; + + Freeze_Stream_Operations (N, Def_Id); + return Result; + + exception + when RE_Not_Available => + return False; + end Freeze_Type; + + ------------------------- + -- Get_Simple_Init_Val -- + ------------------------- + + function Get_Simple_Init_Val + (T : Entity_Id; + N : Node_Id; + Size : Uint := No_Uint) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Val : Node_Id; + Result : Node_Id; + Val_RE : RE_Id; + + Size_To_Use : Uint; + -- This is the size to be used for computation of the appropriate + -- initial value for the Normalize_Scalars and Initialize_Scalars case. + + IV_Attribute : constant Boolean := + Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) = Name_Invalid_Value; + + Lo_Bound : Uint; + Hi_Bound : Uint; + -- These are the values computed by the procedure Check_Subtype_Bounds + + procedure Check_Subtype_Bounds; + -- This procedure examines the subtype T, and its ancestor subtypes and + -- derived types to determine the best known information about the + -- bounds of the subtype. After the call Lo_Bound is set either to + -- No_Uint if no information can be determined, or to a value which + -- represents a known low bound, i.e. a valid value of the subtype can + -- not be less than this value. Hi_Bound is similarly set to a known + -- high bound (valid value cannot be greater than this). + + -------------------------- + -- Check_Subtype_Bounds -- + -------------------------- + + procedure Check_Subtype_Bounds is + ST1 : Entity_Id; + ST2 : Entity_Id; + Lo : Node_Id; + Hi : Node_Id; + Loval : Uint; + Hival : Uint; + + begin + Lo_Bound := No_Uint; + Hi_Bound := No_Uint; + + -- Loop to climb ancestor subtypes and derived types + + ST1 := T; + loop + if not Is_Discrete_Type (ST1) then + return; + end if; + + Lo := Type_Low_Bound (ST1); + Hi := Type_High_Bound (ST1); + + if Compile_Time_Known_Value (Lo) then + Loval := Expr_Value (Lo); + + if Lo_Bound = No_Uint or else Lo_Bound < Loval then + Lo_Bound := Loval; + end if; + end if; + + if Compile_Time_Known_Value (Hi) then + Hival := Expr_Value (Hi); + + if Hi_Bound = No_Uint or else Hi_Bound > Hival then + Hi_Bound := Hival; + end if; + end if; + + ST2 := Ancestor_Subtype (ST1); + + if No (ST2) then + ST2 := Etype (ST1); + end if; + + exit when ST1 = ST2; + ST1 := ST2; + end loop; + end Check_Subtype_Bounds; + + -- Start of processing for Get_Simple_Init_Val + + begin + -- For a private type, we should always have an underlying type + -- (because this was already checked in Needs_Simple_Initialization). + -- What we do is to get the value for the underlying type and then do + -- an Unchecked_Convert to the private type. + + if Is_Private_Type (T) then + Val := Get_Simple_Init_Val (Underlying_Type (T), N, Size); + + -- A special case, if the underlying value is null, then qualify it + -- with the underlying type, so that the null is properly typed + -- Similarly, if it is an aggregate it must be qualified, because an + -- unchecked conversion does not provide a context for it. + + if Nkind_In (Val, N_Null, N_Aggregate) then + Val := + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Occurrence_Of (Underlying_Type (T), Loc), + Expression => Val); + end if; + + Result := Unchecked_Convert_To (T, Val); + + -- Don't truncate result (important for Initialize/Normalize_Scalars) + + if Nkind (Result) = N_Unchecked_Type_Conversion + and then Is_Scalar_Type (Underlying_Type (T)) + then + Set_No_Truncation (Result); + end if; + + return Result; + + -- For scalars, we must have normalize/initialize scalars case, or + -- if the node N is an 'Invalid_Value attribute node. + + elsif Is_Scalar_Type (T) then + pragma Assert (Init_Or_Norm_Scalars or IV_Attribute); + + -- Compute size of object. If it is given by the caller, we can use + -- it directly, otherwise we use Esize (T) as an estimate. As far as + -- we know this covers all cases correctly. + + if Size = No_Uint or else Size <= Uint_0 then + Size_To_Use := UI_Max (Uint_1, Esize (T)); + else + Size_To_Use := Size; + end if; + + -- Maximum size to use is 64 bits, since we will create values + -- of type Unsigned_64 and the range must fit this type. + + if Size_To_Use /= No_Uint and then Size_To_Use > Uint_64 then + Size_To_Use := Uint_64; + end if; + + -- Check known bounds of subtype + + Check_Subtype_Bounds; + + -- Processing for Normalize_Scalars case + + if Normalize_Scalars and then not IV_Attribute then + + -- If zero is invalid, it is a convenient value to use that is + -- for sure an appropriate invalid value in all situations. + + if Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then + Val := Make_Integer_Literal (Loc, 0); + + -- Cases where all one bits is the appropriate invalid value + + -- For modular types, all 1 bits is either invalid or valid. If + -- it is valid, then there is nothing that can be done since there + -- are no invalid values (we ruled out zero already). + + -- For signed integer types that have no negative values, either + -- there is room for negative values, or there is not. If there + -- is, then all 1 bits may be interpreted as minus one, which is + -- certainly invalid. Alternatively it is treated as the largest + -- positive value, in which case the observation for modular types + -- still applies. + + -- For float types, all 1-bits is a NaN (not a number), which is + -- certainly an appropriately invalid value. + + elsif Is_Unsigned_Type (T) + or else Is_Floating_Point_Type (T) + or else Is_Enumeration_Type (T) + then + Val := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1); + + -- Resolve as Unsigned_64, because the largest number we + -- can generate is out of range of universal integer. + + Analyze_And_Resolve (Val, RTE (RE_Unsigned_64)); + + -- Case of signed types + + else + declare + Signed_Size : constant Uint := + UI_Min (Uint_63, Size_To_Use - 1); + + begin + -- Normally we like to use the most negative number. The + -- one exception is when this number is in the known + -- subtype range and the largest positive number is not in + -- the known subtype range. + + -- For this exceptional case, use largest positive value + + if Lo_Bound /= No_Uint and then Hi_Bound /= No_Uint + and then Lo_Bound <= (-(2 ** Signed_Size)) + and then Hi_Bound < 2 ** Signed_Size + then + Val := Make_Integer_Literal (Loc, 2 ** Signed_Size - 1); + + -- Normal case of largest negative value + + else + Val := Make_Integer_Literal (Loc, -(2 ** Signed_Size)); + end if; + end; + end if; + + -- Here for Initialize_Scalars case (or Invalid_Value attribute used) + + else + -- For float types, use float values from System.Scalar_Values + + if Is_Floating_Point_Type (T) then + if Root_Type (T) = Standard_Short_Float then + Val_RE := RE_IS_Isf; + elsif Root_Type (T) = Standard_Float then + Val_RE := RE_IS_Ifl; + elsif Root_Type (T) = Standard_Long_Float then + Val_RE := RE_IS_Ilf; + else pragma Assert (Root_Type (T) = Standard_Long_Long_Float); + Val_RE := RE_IS_Ill; + end if; + + -- If zero is invalid, use zero values from System.Scalar_Values + + elsif Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then + if Size_To_Use <= 8 then + Val_RE := RE_IS_Iz1; + elsif Size_To_Use <= 16 then + Val_RE := RE_IS_Iz2; + elsif Size_To_Use <= 32 then + Val_RE := RE_IS_Iz4; + else + Val_RE := RE_IS_Iz8; + end if; + + -- For unsigned, use unsigned values from System.Scalar_Values + + elsif Is_Unsigned_Type (T) then + if Size_To_Use <= 8 then + Val_RE := RE_IS_Iu1; + elsif Size_To_Use <= 16 then + Val_RE := RE_IS_Iu2; + elsif Size_To_Use <= 32 then + Val_RE := RE_IS_Iu4; + else + Val_RE := RE_IS_Iu8; + end if; + + -- For signed, use signed values from System.Scalar_Values + + else + if Size_To_Use <= 8 then + Val_RE := RE_IS_Is1; + elsif Size_To_Use <= 16 then + Val_RE := RE_IS_Is2; + elsif Size_To_Use <= 32 then + Val_RE := RE_IS_Is4; + else + Val_RE := RE_IS_Is8; + end if; + end if; + + Val := New_Occurrence_Of (RTE (Val_RE), Loc); + end if; + + -- The final expression is obtained by doing an unchecked conversion + -- of this result to the base type of the required subtype. We use + -- the base type to avoid the unchecked conversion from chopping + -- bits, and then we set Kill_Range_Check to preserve the "bad" + -- value. + + Result := Unchecked_Convert_To (Base_Type (T), Val); + + -- Ensure result is not truncated, since we want the "bad" bits + -- and also kill range check on result. + + if Nkind (Result) = N_Unchecked_Type_Conversion then + Set_No_Truncation (Result); + Set_Kill_Range_Check (Result, True); + end if; + + return Result; + + -- String or Wide_[Wide]_String (must have Initialize_Scalars set) + + elsif Root_Type (T) = Standard_String + or else + Root_Type (T) = Standard_Wide_String + or else + Root_Type (T) = Standard_Wide_Wide_String + then + pragma Assert (Init_Or_Norm_Scalars); + + return + Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List ( + Make_Others_Choice (Loc)), + Expression => + Get_Simple_Init_Val + (Component_Type (T), N, Esize (Root_Type (T)))))); + + -- Access type is initialized to null + + elsif Is_Access_Type (T) then + return + Make_Null (Loc); + + -- No other possibilities should arise, since we should only be + -- calling Get_Simple_Init_Val if Needs_Simple_Initialization + -- returned True, indicating one of the above cases held. + + else + raise Program_Error; + end if; + + exception + when RE_Not_Available => + return Empty; + end Get_Simple_Init_Val; + + ------------------------------ + -- Has_New_Non_Standard_Rep -- + ------------------------------ + + function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean is + begin + if not Is_Derived_Type (T) then + return Has_Non_Standard_Rep (T) + or else Has_Non_Standard_Rep (Root_Type (T)); + + -- If Has_Non_Standard_Rep is not set on the derived type, the + -- representation is fully inherited. + + elsif not Has_Non_Standard_Rep (T) then + return False; + + else + return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T)); + + -- May need a more precise check here: the First_Rep_Item may + -- be a stream attribute, which does not affect the representation + -- of the type ??? + end if; + end Has_New_Non_Standard_Rep; + + ---------------- + -- In_Runtime -- + ---------------- + + function In_Runtime (E : Entity_Id) return Boolean is + S1 : Entity_Id; + + begin + S1 := Scope (E); + while Scope (S1) /= Standard_Standard loop + S1 := Scope (S1); + end loop; + + return Chars (S1) = Name_System or else Chars (S1) = Name_Ada; + end In_Runtime; + + ---------------------------- + -- Initialization_Warning -- + ---------------------------- + + procedure Initialization_Warning (E : Entity_Id) is + Warning_Needed : Boolean; + + begin + Warning_Needed := False; + + if Ekind (Current_Scope) = E_Package + and then Static_Elaboration_Desired (Current_Scope) + then + if Is_Type (E) then + if Is_Record_Type (E) then + if Has_Discriminants (E) + or else Is_Limited_Type (E) + or else Has_Non_Standard_Rep (E) + then + Warning_Needed := True; + + else + -- Verify that at least one component has an initialization + -- expression. No need for a warning on a type if all its + -- components have no initialization. + + declare + Comp : Entity_Id; + + begin + Comp := First_Component (E); + while Present (Comp) loop + if Ekind (Comp) = E_Discriminant + or else + (Nkind (Parent (Comp)) = N_Component_Declaration + and then Present (Expression (Parent (Comp)))) + then + Warning_Needed := True; + exit; + end if; + + Next_Component (Comp); + end loop; + end; + end if; + + if Warning_Needed then + Error_Msg_N + ("Objects of the type cannot be initialized " & + "statically by default?", + Parent (E)); + end if; + end if; + + else + Error_Msg_N ("Object cannot be initialized statically?", E); + end if; + end if; + end Initialization_Warning; + + ------------------ + -- Init_Formals -- + ------------------ + + function Init_Formals (Typ : Entity_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (Typ); + Formals : List_Id; + + begin + -- First parameter is always _Init : in out typ. Note that we need + -- this to be in/out because in the case of the task record value, + -- there are default record fields (_Priority, _Size, -Task_Info) + -- that may be referenced in the generated initialization routine. + + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uInit), + In_Present => True, + Out_Present => True, + Parameter_Type => New_Reference_To (Typ, Loc))); + + -- For task record value, or type that contains tasks, add two more + -- formals, _Master : Master_Id and _Chain : in out Activation_Chain + -- We also add these parameters for the task record type case. + + if Has_Task (Typ) + or else (Is_Record_Type (Typ) and then Is_Task_Record_Type (Typ)) + then + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uMaster), + Parameter_Type => New_Reference_To (RTE (RE_Master_Id), Loc))); + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uChain), + In_Present => True, + Out_Present => True, + Parameter_Type => + New_Reference_To (RTE (RE_Activation_Chain), Loc))); + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uTask_Name), + In_Present => True, + Parameter_Type => + New_Reference_To (Standard_String, Loc))); + end if; + + return Formals; + + exception + when RE_Not_Available => + return Empty_List; + end Init_Formals; + + ------------------------- + -- Init_Secondary_Tags -- + ------------------------- + + procedure Init_Secondary_Tags + (Typ : Entity_Id; + Target : Node_Id; + Stmts_List : List_Id; + Fixed_Comps : Boolean := True; + Variable_Comps : Boolean := True) + is + Loc : constant Source_Ptr := Sloc (Target); + + -- Inherit the C++ tag of the secondary dispatch table of Typ associated + -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag. + + procedure Initialize_Tag + (Typ : Entity_Id; + Iface : Entity_Id; + Tag_Comp : Entity_Id; + Iface_Tag : Node_Id); + -- Initialize the tag of the secondary dispatch table of Typ associated + -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag. + -- Compiling under the CPP full ABI compatibility mode, if the ancestor + -- of Typ CPP tagged type we generate code to inherit the contents of + -- the dispatch table directly from the ancestor. + + -------------------- + -- Initialize_Tag -- + -------------------- + + procedure Initialize_Tag + (Typ : Entity_Id; + Iface : Entity_Id; + Tag_Comp : Entity_Id; + Iface_Tag : Node_Id) + is + Comp_Typ : Entity_Id; + Offset_To_Top_Comp : Entity_Id := Empty; + + begin + -- Initialize the pointer to the secondary DT associated with the + -- interface. + + if not Is_Ancestor (Iface, Typ) then + Append_To (Stmts_List, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Reference_To (Tag_Comp, Loc)), + Expression => + New_Reference_To (Iface_Tag, Loc))); + end if; + + Comp_Typ := Scope (Tag_Comp); + + -- Initialize the entries of the table of interfaces. We generate a + -- different call when the parent of the type has variable size + -- components. + + if Comp_Typ /= Etype (Comp_Typ) + and then Is_Variable_Size_Record (Etype (Comp_Typ)) + and then Chars (Tag_Comp) /= Name_uTag + then + pragma Assert (Present (DT_Offset_To_Top_Func (Tag_Comp))); + + -- Issue error if Set_Dynamic_Offset_To_Top is not available in a + -- configurable run-time environment. + + if not RTE_Available (RE_Set_Dynamic_Offset_To_Top) then + Error_Msg_CRT + ("variable size record with interface types", Typ); + return; + end if; + + -- Generate: + -- Set_Dynamic_Offset_To_Top + -- (This => Init, + -- Interface_T => Iface'Tag, + -- Offset_Value => n, + -- Offset_Func => Fn'Address) + + Append_To (Stmts_List, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To + (RTE (RE_Set_Dynamic_Offset_To_Top), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Copy_Tree (Target), + Attribute_Name => Name_Address), + + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Iface))), + Loc)), + + Unchecked_Convert_To + (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Reference_To (Tag_Comp, Loc)), + Attribute_Name => Name_Position)), + + Unchecked_Convert_To (RTE (RE_Offset_To_Top_Function_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To + (DT_Offset_To_Top_Func (Tag_Comp), Loc), + Attribute_Name => Name_Address))))); + + -- In this case the next component stores the value of the + -- offset to the top. + + Offset_To_Top_Comp := Next_Entity (Tag_Comp); + pragma Assert (Present (Offset_To_Top_Comp)); + + Append_To (Stmts_List, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Reference_To + (Offset_To_Top_Comp, Loc)), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Reference_To (Tag_Comp, Loc)), + Attribute_Name => Name_Position))); + + -- Normal case: No discriminants in the parent type + + else + -- Don't need to set any value if this interface shares + -- the primary dispatch table. + + if not Is_Ancestor (Iface, Typ) then + Append_To (Stmts_List, + Build_Set_Static_Offset_To_Top (Loc, + Iface_Tag => New_Reference_To (Iface_Tag, Loc), + Offset_Value => + Unchecked_Convert_To (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Reference_To (Tag_Comp, Loc)), + Attribute_Name => Name_Position)))); + end if; + + -- Generate: + -- Register_Interface_Offset + -- (This => Init, + -- Interface_T => Iface'Tag, + -- Is_Constant => True, + -- Offset_Value => n, + -- Offset_Func => null); + + if RTE_Available (RE_Register_Interface_Offset) then + Append_To (Stmts_List, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To + (RTE (RE_Register_Interface_Offset), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Copy_Tree (Target), + Attribute_Name => Name_Address), + + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Iface))), Loc)), + + New_Occurrence_Of (Standard_True, Loc), + + Unchecked_Convert_To + (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Reference_To (Tag_Comp, Loc)), + Attribute_Name => Name_Position)), + + Make_Null (Loc)))); + end if; + end if; + end Initialize_Tag; + + -- Local variables + + Full_Typ : Entity_Id; + Ifaces_List : Elist_Id; + Ifaces_Comp_List : Elist_Id; + Ifaces_Tag_List : Elist_Id; + Iface_Elmt : Elmt_Id; + Iface_Comp_Elmt : Elmt_Id; + Iface_Tag_Elmt : Elmt_Id; + Tag_Comp : Node_Id; + In_Variable_Pos : Boolean; + + -- Start of processing for Init_Secondary_Tags + + begin + -- Handle private types + + if Present (Full_View (Typ)) then + Full_Typ := Full_View (Typ); + else + Full_Typ := Typ; + end if; + + Collect_Interfaces_Info + (Full_Typ, Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List); + + Iface_Elmt := First_Elmt (Ifaces_List); + Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List); + Iface_Tag_Elmt := First_Elmt (Ifaces_Tag_List); + while Present (Iface_Elmt) loop + Tag_Comp := Node (Iface_Comp_Elmt); + + -- Check if parent of record type has variable size components + + In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp)) + and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp))); + + -- If we are compiling under the CPP full ABI compatibility mode and + -- the ancestor is a CPP_Pragma tagged type then we generate code to + -- initialize the secondary tag components from tags that reference + -- secondary tables filled with copy of parent slots. + + if Is_CPP_Class (Root_Type (Full_Typ)) then + + -- Reject interface components located at variable offset in + -- C++ derivations. This is currently unsupported. + + if not Fixed_Comps and then In_Variable_Pos then + + -- Locate the first dynamic component of the record. Done to + -- improve the text of the warning. + + declare + Comp : Entity_Id; + Comp_Typ : Entity_Id; + + begin + Comp := First_Entity (Typ); + while Present (Comp) loop + Comp_Typ := Etype (Comp); + + if Ekind (Comp) /= E_Discriminant + and then not Is_Tag (Comp) + then + exit when + (Is_Record_Type (Comp_Typ) + and then Is_Variable_Size_Record + (Base_Type (Comp_Typ))) + or else + (Is_Array_Type (Comp_Typ) + and then Is_Variable_Size_Array (Comp_Typ)); + end if; + + Next_Entity (Comp); + end loop; + + pragma Assert (Present (Comp)); + Error_Msg_Node_2 := Comp; + Error_Msg_NE + ("parent type & with dynamic component & cannot be parent" + & " of 'C'P'P derivation if new interfaces are present", + Typ, Scope (Original_Record_Component (Comp))); + + Error_Msg_Sloc := + Sloc (Scope (Original_Record_Component (Comp))); + Error_Msg_NE + ("type derived from 'C'P'P type & defined #", + Typ, Scope (Original_Record_Component (Comp))); + + -- Avoid duplicated warnings + + exit; + end; + + -- Initialize secondary tags + + else + Append_To (Stmts_List, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Reference_To (Node (Iface_Comp_Elmt), Loc)), + Expression => + New_Reference_To (Node (Iface_Tag_Elmt), Loc))); + end if; + + -- Otherwise generate code to initialize the tag + + else + if (In_Variable_Pos and then Variable_Comps) + or else (not In_Variable_Pos and then Fixed_Comps) + then + Initialize_Tag (Full_Typ, + Iface => Node (Iface_Elmt), + Tag_Comp => Tag_Comp, + Iface_Tag => Node (Iface_Tag_Elmt)); + end if; + end if; + + Next_Elmt (Iface_Elmt); + Next_Elmt (Iface_Comp_Elmt); + Next_Elmt (Iface_Tag_Elmt); + end loop; + end Init_Secondary_Tags; + + ---------------------------- + -- Is_Variable_Size_Array -- + ---------------------------- + + function Is_Variable_Size_Array (E : Entity_Id) return Boolean is + + function Is_Constant_Bound (Exp : Node_Id) return Boolean; + -- To simplify handling of array components. Determines whether the + -- given bound is constant (a constant or enumeration literal, or an + -- integer literal) as opposed to per-object, through an expression + -- or a discriminant. + + ----------------------- + -- Is_Constant_Bound -- + ----------------------- + + function Is_Constant_Bound (Exp : Node_Id) return Boolean is + begin + if Nkind (Exp) = N_Integer_Literal then + return True; + else + return + Is_Entity_Name (Exp) + and then Present (Entity (Exp)) + and then + (Ekind (Entity (Exp)) = E_Constant + or else Ekind (Entity (Exp)) = E_Enumeration_Literal); + end if; + end Is_Constant_Bound; + + -- Local variables + + Idx : Node_Id; + + -- Start of processing for Is_Variable_Sized_Array + + begin + pragma Assert (Is_Array_Type (E)); + + -- Check if some index is initialized with a non-constant value + + Idx := First_Index (E); + while Present (Idx) loop + if Nkind (Idx) = N_Range then + if not Is_Constant_Bound (Low_Bound (Idx)) + or else not Is_Constant_Bound (High_Bound (Idx)) + then + return True; + end if; + end if; + + Idx := Next_Index (Idx); + end loop; + + return False; + end Is_Variable_Size_Array; + + ----------------------------- + -- Is_Variable_Size_Record -- + ----------------------------- + + function Is_Variable_Size_Record (E : Entity_Id) return Boolean is + Comp : Entity_Id; + Comp_Typ : Entity_Id; + + begin + pragma Assert (Is_Record_Type (E)); + + Comp := First_Entity (E); + while Present (Comp) loop + Comp_Typ := Etype (Comp); + + -- Recursive call if the record type has discriminants + + if Is_Record_Type (Comp_Typ) + and then Has_Discriminants (Comp_Typ) + and then Is_Variable_Size_Record (Comp_Typ) + then + return True; + + elsif Is_Array_Type (Comp_Typ) + and then Is_Variable_Size_Array (Comp_Typ) + then + return True; + end if; + + Next_Entity (Comp); + end loop; + + return False; + end Is_Variable_Size_Record; + + ---------------------------------------- + -- Make_Controlling_Function_Wrappers -- + ---------------------------------------- + + procedure Make_Controlling_Function_Wrappers + (Tag_Typ : Entity_Id; + Decl_List : out List_Id; + Body_List : out List_Id) + is + Loc : constant Source_Ptr := Sloc (Tag_Typ); + Prim_Elmt : Elmt_Id; + Subp : Entity_Id; + Actual_List : List_Id; + Formal_List : List_Id; + Formal : Entity_Id; + Par_Formal : Entity_Id; + Formal_Node : Node_Id; + Func_Body : Node_Id; + Func_Decl : Node_Id; + Func_Spec : Node_Id; + Return_Stmt : Node_Id; + + begin + Decl_List := New_List; + Body_List := New_List; + + Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + + while Present (Prim_Elmt) loop + Subp := Node (Prim_Elmt); + + -- If a primitive function with a controlling result of the type has + -- not been overridden by the user, then we must create a wrapper + -- function here that effectively overrides it and invokes the + -- (non-abstract) parent function. This can only occur for a null + -- extension. Note that functions with anonymous controlling access + -- results don't qualify and must be overridden. We also exclude + -- Input attributes, since each type will have its own version of + -- Input constructed by the expander. The test for Comes_From_Source + -- is needed to distinguish inherited operations from renamings + -- (which also have Alias set). + + -- The function may be abstract, or require_Overriding may be set + -- for it, because tests for null extensions may already have reset + -- the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not + -- set, functions that need wrappers are recognized by having an + -- alias that returns the parent type. + + if Comes_From_Source (Subp) + or else No (Alias (Subp)) + or else Ekind (Subp) /= E_Function + or else not Has_Controlling_Result (Subp) + or else Is_Access_Type (Etype (Subp)) + or else Is_Abstract_Subprogram (Alias (Subp)) + or else Is_TSS (Subp, TSS_Stream_Input) + then + goto Next_Prim; + + elsif Is_Abstract_Subprogram (Subp) + or else Requires_Overriding (Subp) + or else + (Is_Null_Extension (Etype (Subp)) + and then Etype (Alias (Subp)) /= Etype (Subp)) + then + Formal_List := No_List; + Formal := First_Formal (Subp); + + if Present (Formal) then + Formal_List := New_List; + + while Present (Formal) loop + Append + (Make_Parameter_Specification + (Loc, + Defining_Identifier => + Make_Defining_Identifier (Sloc (Formal), + Chars => Chars (Formal)), + In_Present => In_Present (Parent (Formal)), + Out_Present => Out_Present (Parent (Formal)), + Null_Exclusion_Present => + Null_Exclusion_Present (Parent (Formal)), + Parameter_Type => + New_Reference_To (Etype (Formal), Loc), + Expression => + New_Copy_Tree (Expression (Parent (Formal)))), + Formal_List); + + Next_Formal (Formal); + end loop; + end if; + + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => Chars (Subp)), + Parameter_Specifications => Formal_List, + Result_Definition => + New_Reference_To (Etype (Subp), Loc)); + + Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); + Append_To (Decl_List, Func_Decl); + + -- Build a wrapper body that calls the parent function. The body + -- contains a single return statement that returns an extension + -- aggregate whose ancestor part is a call to the parent function, + -- passing the formals as actuals (with any controlling arguments + -- converted to the types of the corresponding formals of the + -- parent function, which might be anonymous access types), and + -- having a null extension. + + Formal := First_Formal (Subp); + Par_Formal := First_Formal (Alias (Subp)); + Formal_Node := First (Formal_List); + + if Present (Formal) then + Actual_List := New_List; + else + Actual_List := No_List; + end if; + + while Present (Formal) loop + if Is_Controlling_Formal (Formal) then + Append_To (Actual_List, + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Etype (Par_Formal), Loc), + Expression => + New_Reference_To + (Defining_Identifier (Formal_Node), Loc))); + else + Append_To + (Actual_List, + New_Reference_To + (Defining_Identifier (Formal_Node), Loc)); + end if; + + Next_Formal (Formal); + Next_Formal (Par_Formal); + Next (Formal_Node); + end loop; + + Return_Stmt := + Make_Simple_Return_Statement (Loc, + Expression => + Make_Extension_Aggregate (Loc, + Ancestor_Part => + Make_Function_Call (Loc, + Name => New_Reference_To (Alias (Subp), Loc), + Parameter_Associations => Actual_List), + Null_Record_Present => True)); + + Func_Body := + Make_Subprogram_Body (Loc, + Specification => New_Copy_Tree (Func_Spec), + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Return_Stmt))); + + Set_Defining_Unit_Name + (Specification (Func_Body), + Make_Defining_Identifier (Loc, Chars (Subp))); + + Append_To (Body_List, Func_Body); + + -- Replace the inherited function with the wrapper function + -- in the primitive operations list. + + Override_Dispatching_Operation + (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec)); + end if; + + <> + Next_Elmt (Prim_Elmt); + end loop; + end Make_Controlling_Function_Wrappers; + + ------------------- + -- Make_Eq_Body -- + ------------------- + + function Make_Eq_Body + (Typ : Entity_Id; + Eq_Name : Name_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Parent (Typ)); + Decl : Node_Id; + Def : constant Node_Id := Parent (Typ); + Stmts : constant List_Id := New_List; + Variant_Case : Boolean := Has_Discriminants (Typ); + Comps : Node_Id := Empty; + Typ_Def : Node_Id := Type_Definition (Def); + + begin + Decl := + Predef_Spec_Or_Body (Loc, + Tag_Typ => Typ, + Name => Eq_Name, + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_X), + Parameter_Type => New_Reference_To (Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Y), + Parameter_Type => New_Reference_To (Typ, Loc))), + + Ret_Type => Standard_Boolean, + For_Body => True); + + if Variant_Case then + if Nkind (Typ_Def) = N_Derived_Type_Definition then + Typ_Def := Record_Extension_Part (Typ_Def); + end if; + + if Present (Typ_Def) then + Comps := Component_List (Typ_Def); + end if; + + Variant_Case := + Present (Comps) and then Present (Variant_Part (Comps)); + end if; + + if Variant_Case then + Append_To (Stmts, + Make_Eq_If (Typ, Discriminant_Specifications (Def))); + Append_List_To (Stmts, Make_Eq_Case (Typ, Comps)); + Append_To (Stmts, + Make_Simple_Return_Statement (Loc, + Expression => New_Reference_To (Standard_True, Loc))); + + else + Append_To (Stmts, + Make_Simple_Return_Statement (Loc, + Expression => + Expand_Record_Equality + (Typ, + Typ => Typ, + Lhs => Make_Identifier (Loc, Name_X), + Rhs => Make_Identifier (Loc, Name_Y), + Bodies => Declarations (Decl)))); + end if; + + Set_Handled_Statement_Sequence + (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts)); + return Decl; + end Make_Eq_Body; + + ------------------ + -- Make_Eq_Case -- + ------------------ + + -- + -- case X.D1 is + -- when V1 => on subcomponents + -- ... + -- when Vn => on subcomponents + -- end case; + + function Make_Eq_Case + (E : Entity_Id; + CL : Node_Id; + Discr : Entity_Id := Empty) return List_Id + is + Loc : constant Source_Ptr := Sloc (E); + Result : constant List_Id := New_List; + Variant : Node_Id; + Alt_List : List_Id; + + begin + Append_To (Result, Make_Eq_If (E, Component_Items (CL))); + + if No (Variant_Part (CL)) then + return Result; + end if; + + Variant := First_Non_Pragma (Variants (Variant_Part (CL))); + + if No (Variant) then + return Result; + end if; + + Alt_List := New_List; + + while Present (Variant) loop + Append_To (Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)), + Statements => Make_Eq_Case (E, Component_List (Variant)))); + + Next_Non_Pragma (Variant); + end loop; + + -- If we have an Unchecked_Union, use one of the parameters that + -- captures the discriminants. + + if Is_Unchecked_Union (E) then + Append_To (Result, + Make_Case_Statement (Loc, + Expression => New_Reference_To (Discr, Loc), + Alternatives => Alt_List)); + + else + Append_To (Result, + Make_Case_Statement (Loc, + Expression => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_X), + Selector_Name => New_Copy (Name (Variant_Part (CL)))), + Alternatives => Alt_List)); + end if; + + return Result; + end Make_Eq_Case; + + ---------------- + -- Make_Eq_If -- + ---------------- + + -- Generates: + + -- if + -- X.C1 /= Y.C1 + -- or else + -- X.C2 /= Y.C2 + -- ... + -- then + -- return False; + -- end if; + + -- or a null statement if the list L is empty + + function Make_Eq_If + (E : Entity_Id; + L : List_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (E); + C : Node_Id; + Field_Name : Name_Id; + Cond : Node_Id; + + begin + if No (L) then + return Make_Null_Statement (Loc); + + else + Cond := Empty; + + C := First_Non_Pragma (L); + while Present (C) loop + Field_Name := Chars (Defining_Identifier (C)); + + -- The tags must not be compared: they are not part of the value. + -- Ditto for the controller component, if present. + + -- Note also that in the following, we use Make_Identifier for + -- the component names. Use of New_Reference_To to identify the + -- components would be incorrect because the wrong entities for + -- discriminants could be picked up in the private type case. + + if Field_Name /= Name_uTag + and then + Field_Name /= Name_uController + then + Evolve_Or_Else (Cond, + Make_Op_Ne (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_X), + Selector_Name => Make_Identifier (Loc, Field_Name)), + + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_Y), + Selector_Name => Make_Identifier (Loc, Field_Name)))); + end if; + + Next_Non_Pragma (C); + end loop; + + if No (Cond) then + return Make_Null_Statement (Loc); + + else + return + Make_Implicit_If_Statement (E, + Condition => Cond, + Then_Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Standard_False, Loc)))); + end if; + end if; + end Make_Eq_If; + + ------------------------------- + -- Make_Null_Procedure_Specs -- + ------------------------------- + + function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id is + Decl_List : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Tag_Typ); + Formal : Entity_Id; + Formal_List : List_Id; + New_Param_Spec : Node_Id; + Parent_Subp : Entity_Id; + Prim_Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Prim_Elmt) loop + Subp := Node (Prim_Elmt); + + -- If a null procedure inherited from an interface has not been + -- overridden, then we build a null procedure declaration to + -- override the inherited procedure. + + Parent_Subp := Alias (Subp); + + if Present (Parent_Subp) + and then Is_Null_Interface_Primitive (Parent_Subp) + then + Formal_List := No_List; + Formal := First_Formal (Subp); + + if Present (Formal) then + Formal_List := New_List; + + while Present (Formal) loop + + -- Copy the parameter spec including default expressions + + New_Param_Spec := + New_Copy_Tree (Parent (Formal), New_Sloc => Loc); + + -- Generate a new defining identifier for the new formal. + -- required because New_Copy_Tree does not duplicate + -- semantic fields (except itypes). + + Set_Defining_Identifier (New_Param_Spec, + Make_Defining_Identifier (Sloc (Formal), + Chars => Chars (Formal))); + + -- For controlling arguments we must change their + -- parameter type to reference the tagged type (instead + -- of the interface type) + + if Is_Controlling_Formal (Formal) then + if Nkind (Parameter_Type (Parent (Formal))) + = N_Identifier + then + Set_Parameter_Type (New_Param_Spec, + New_Occurrence_Of (Tag_Typ, Loc)); + + else pragma Assert + (Nkind (Parameter_Type (Parent (Formal))) + = N_Access_Definition); + Set_Subtype_Mark (Parameter_Type (New_Param_Spec), + New_Occurrence_Of (Tag_Typ, Loc)); + end if; + end if; + + Append (New_Param_Spec, Formal_List); + + Next_Formal (Formal); + end loop; + end if; + + Append_To (Decl_List, + Make_Subprogram_Declaration (Loc, + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Chars (Subp)), + Parameter_Specifications => Formal_List, + Null_Present => True))); + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + return Decl_List; + end Make_Null_Procedure_Specs; + + ------------------------------------- + -- Make_Predefined_Primitive_Specs -- + ------------------------------------- + + procedure Make_Predefined_Primitive_Specs + (Tag_Typ : Entity_Id; + Predef_List : out List_Id; + Renamed_Eq : out Entity_Id) + is + Loc : constant Source_Ptr := Sloc (Tag_Typ); + Res : constant List_Id := New_List; + Prim : Elmt_Id; + Eq_Needed : Boolean; + Eq_Spec : Node_Id; + Eq_Name : Name_Id := Name_Op_Eq; + + function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean; + -- Returns true if Prim is a renaming of an unresolved predefined + -- equality operation. + + ------------------------------- + -- Is_Predefined_Eq_Renaming -- + ------------------------------- + + function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean is + begin + return Chars (Prim) /= Name_Op_Eq + and then Present (Alias (Prim)) + and then Comes_From_Source (Prim) + and then Is_Intrinsic_Subprogram (Alias (Prim)) + and then Chars (Alias (Prim)) = Name_Op_Eq; + end Is_Predefined_Eq_Renaming; + + -- Start of processing for Make_Predefined_Primitive_Specs + + begin + Renamed_Eq := Empty; + + -- Spec of _Size + + Append_To (Res, Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Name_uSize, + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), + Parameter_Type => New_Reference_To (Tag_Typ, Loc))), + + Ret_Type => Standard_Long_Long_Integer)); + + -- Spec of _Alignment + + Append_To (Res, Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Name_uAlignment, + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), + Parameter_Type => New_Reference_To (Tag_Typ, Loc))), + + Ret_Type => Standard_Integer)); + + -- Specs for dispatching stream attributes + + declare + Stream_Op_TSS_Names : + constant array (Integer range <>) of TSS_Name_Type := + (TSS_Stream_Read, + TSS_Stream_Write, + TSS_Stream_Input, + TSS_Stream_Output); + + begin + for Op in Stream_Op_TSS_Names'Range loop + if Stream_Operation_OK (Tag_Typ, Stream_Op_TSS_Names (Op)) then + Append_To (Res, + Predef_Stream_Attr_Spec (Loc, Tag_Typ, + Stream_Op_TSS_Names (Op))); + end if; + end loop; + end; + + -- Spec of "=" is expanded if the type is not limited and if a + -- user defined "=" was not already declared for the non-full + -- view of a private extension + + if not Is_Limited_Type (Tag_Typ) then + Eq_Needed := True; + Prim := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Prim) loop + + -- If a primitive is encountered that renames the predefined + -- equality operator before reaching any explicit equality + -- primitive, then we still need to create a predefined equality + -- function, because calls to it can occur via the renaming. A new + -- name is created for the equality to avoid conflicting with any + -- user-defined equality. (Note that this doesn't account for + -- renamings of equality nested within subpackages???) + + if Is_Predefined_Eq_Renaming (Node (Prim)) then + Eq_Name := New_External_Name (Chars (Node (Prim)), 'E'); + + -- User-defined equality + + elsif Chars (Node (Prim)) = Name_Op_Eq + and then Etype (First_Formal (Node (Prim))) = + Etype (Next_Formal (First_Formal (Node (Prim)))) + and then Base_Type (Etype (Node (Prim))) = Standard_Boolean + then + if No (Alias (Node (Prim))) + or else Nkind (Unit_Declaration_Node (Node (Prim))) = + N_Subprogram_Renaming_Declaration + then + Eq_Needed := False; + exit; + + -- If the parent is not an interface type and has an abstract + -- equality function, the inherited equality is abstract as + -- well, and no body can be created for it. + + elsif not Is_Interface (Etype (Tag_Typ)) + and then Present (Alias (Node (Prim))) + and then Is_Abstract_Subprogram (Alias (Node (Prim))) + then + Eq_Needed := False; + exit; + + -- If the type has an equality function corresponding with + -- a primitive defined in an interface type, the inherited + -- equality is abstract as well, and no body can be created + -- for it. + + elsif Present (Alias (Node (Prim))) + and then Comes_From_Source (Ultimate_Alias (Node (Prim))) + and then + Is_Interface + (Find_Dispatching_Type (Ultimate_Alias (Node (Prim)))) + then + Eq_Needed := False; + exit; + end if; + end if; + + Next_Elmt (Prim); + end loop; + + -- If a renaming of predefined equality was found but there was no + -- user-defined equality (so Eq_Needed is still true), then set the + -- name back to Name_Op_Eq. But in the case where a user-defined + -- equality was located after such a renaming, then the predefined + -- equality function is still needed, so Eq_Needed must be set back + -- to True. + + if Eq_Name /= Name_Op_Eq then + if Eq_Needed then + Eq_Name := Name_Op_Eq; + else + Eq_Needed := True; + end if; + end if; + + if Eq_Needed then + Eq_Spec := Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Eq_Name, + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_X), + Parameter_Type => New_Reference_To (Tag_Typ, Loc)), + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Y), + Parameter_Type => New_Reference_To (Tag_Typ, Loc))), + Ret_Type => Standard_Boolean); + Append_To (Res, Eq_Spec); + + if Eq_Name /= Name_Op_Eq then + Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec)); + + Prim := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Prim) loop + + -- Any renamings of equality that appeared before an + -- overriding equality must be updated to refer to the + -- entity for the predefined equality, otherwise calls via + -- the renaming would get incorrectly resolved to call the + -- user-defined equality function. + + if Is_Predefined_Eq_Renaming (Node (Prim)) then + Set_Alias (Node (Prim), Renamed_Eq); + + -- Exit upon encountering a user-defined equality + + elsif Chars (Node (Prim)) = Name_Op_Eq + and then No (Alias (Node (Prim))) + then + exit; + end if; + + Next_Elmt (Prim); + end loop; + end if; + end if; + + -- Spec for dispatching assignment + + Append_To (Res, Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Name_uAssign, + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), + Out_Present => True, + Parameter_Type => New_Reference_To (Tag_Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), + Parameter_Type => New_Reference_To (Tag_Typ, Loc))))); + end if; + + -- Ada 2005: Generate declarations for the following primitive + -- operations for limited interfaces and synchronized types that + -- implement a limited interface. + + -- Disp_Asynchronous_Select + -- Disp_Conditional_Select + -- Disp_Get_Prim_Op_Kind + -- Disp_Get_Task_Id + -- Disp_Requeue + -- Disp_Timed_Select + + -- These operations cannot be implemented on VM targets, so we simply + -- disable their generation in this case. Disable the generation of + -- these bodies if No_Dispatching_Calls, Ravenscar or ZFP is active. + + if Ada_Version >= Ada_2005 + and then Tagged_Type_Expansion + and then not Restriction_Active (No_Dispatching_Calls) + and then not Restriction_Active (No_Select_Statements) + and then RTE_Available (RE_Select_Specific_Data) + then + -- These primitives are defined abstract in interface types + + if Is_Interface (Tag_Typ) + and then Is_Limited_Record (Tag_Typ) + then + Append_To (Res, + Make_Abstract_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Asynchronous_Select_Spec (Tag_Typ))); + + Append_To (Res, + Make_Abstract_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Conditional_Select_Spec (Tag_Typ))); + + Append_To (Res, + Make_Abstract_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ))); + + Append_To (Res, + Make_Abstract_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Get_Task_Id_Spec (Tag_Typ))); + + Append_To (Res, + Make_Abstract_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Requeue_Spec (Tag_Typ))); + + Append_To (Res, + Make_Abstract_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Timed_Select_Spec (Tag_Typ))); + + -- If the ancestor is an interface type we declare non-abstract + -- primitives to override the abstract primitives of the interface + -- type. + + elsif (not Is_Interface (Tag_Typ) + and then Is_Interface (Etype (Tag_Typ)) + and then Is_Limited_Record (Etype (Tag_Typ))) + or else + (Is_Concurrent_Record_Type (Tag_Typ) + and then Has_Interfaces (Tag_Typ)) + then + Append_To (Res, + Make_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Asynchronous_Select_Spec (Tag_Typ))); + + Append_To (Res, + Make_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Conditional_Select_Spec (Tag_Typ))); + + Append_To (Res, + Make_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ))); + + Append_To (Res, + Make_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Get_Task_Id_Spec (Tag_Typ))); + + Append_To (Res, + Make_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Requeue_Spec (Tag_Typ))); + + Append_To (Res, + Make_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Timed_Select_Spec (Tag_Typ))); + end if; + end if; + + -- Specs for finalization actions that may be required in case a future + -- extension contain a controlled element. We generate those only for + -- root tagged types where they will get dummy bodies or when the type + -- has controlled components and their body must be generated. It is + -- also impossible to provide those for tagged types defined within + -- s-finimp since it would involve circularity problems + + if In_Finalization_Root (Tag_Typ) then + null; + + -- We also skip these if finalization is not available + + elsif Restriction_Active (No_Finalization) then + null; + + -- Skip these for CIL Value types, where finalization is not available + + elsif Is_Value_Type (Tag_Typ) then + null; + + elsif Etype (Tag_Typ) = Tag_Typ + or else Needs_Finalization (Tag_Typ) + + -- Ada 2005 (AI-251): We must also generate these subprograms if + -- the immediate ancestor is an interface to ensure the correct + -- initialization of its dispatch table. + + or else (not Is_Interface (Tag_Typ) + and then Is_Interface (Etype (Tag_Typ))) + + -- Ada 205 (AI-251): We must also generate these subprograms if + -- the parent of an nonlimited interface is a limited interface + + or else (Is_Interface (Tag_Typ) + and then not Is_Limited_Interface (Tag_Typ) + and then Is_Limited_Interface (Etype (Tag_Typ))) + then + if not Is_Limited_Type (Tag_Typ) then + Append_To (Res, + Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust)); + end if; + + Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize)); + end if; + + Predef_List := Res; + end Make_Predefined_Primitive_Specs; + + --------------------------------- + -- Needs_Simple_Initialization -- + --------------------------------- + + function Needs_Simple_Initialization + (T : Entity_Id; + Consider_IS : Boolean := True) return Boolean + is + Consider_IS_NS : constant Boolean := + Normalize_Scalars + or (Initialize_Scalars and Consider_IS); + + begin + -- Check for private type, in which case test applies to the underlying + -- type of the private type. + + if Is_Private_Type (T) then + declare + RT : constant Entity_Id := Underlying_Type (T); + + begin + if Present (RT) then + return Needs_Simple_Initialization (RT); + else + return False; + end if; + end; + + -- Cases needing simple initialization are access types, and, if pragma + -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar + -- types. + + elsif Is_Access_Type (T) + or else (Consider_IS_NS and then (Is_Scalar_Type (T))) + then + return True; + + -- If Initialize/Normalize_Scalars is in effect, string objects also + -- need initialization, unless they are created in the course of + -- expanding an aggregate (since in the latter case they will be + -- filled with appropriate initializing values before they are used). + + elsif Consider_IS_NS + and then + (Root_Type (T) = Standard_String + or else Root_Type (T) = Standard_Wide_String + or else Root_Type (T) = Standard_Wide_Wide_String) + and then + (not Is_Itype (T) + or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate) + then + return True; + + else + return False; + end if; + end Needs_Simple_Initialization; + + ---------------------- + -- Predef_Deep_Spec -- + ---------------------- + + function Predef_Deep_Spec + (Loc : Source_Ptr; + Tag_Typ : Entity_Id; + Name : TSS_Name_Type; + For_Body : Boolean := False) return Node_Id + is + Prof : List_Id; + Type_B : Entity_Id; + + begin + if Name = TSS_Deep_Finalize then + Prof := New_List; + Type_B := Standard_Boolean; + + else + Prof := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_L), + In_Present => True, + Out_Present => True, + Parameter_Type => + New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); + Type_B := Standard_Short_Short_Integer; + end if; + + Append_To (Prof, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + In_Present => True, + Out_Present => True, + Parameter_Type => New_Reference_To (Tag_Typ, Loc))); + + Append_To (Prof, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_B), + Parameter_Type => New_Reference_To (Type_B, Loc))); + + return Predef_Spec_Or_Body (Loc, + Name => Make_TSS_Name (Tag_Typ, Name), + Tag_Typ => Tag_Typ, + Profile => Prof, + For_Body => For_Body); + + exception + when RE_Not_Available => + return Empty; + end Predef_Deep_Spec; + + ------------------------- + -- Predef_Spec_Or_Body -- + ------------------------- + + function Predef_Spec_Or_Body + (Loc : Source_Ptr; + Tag_Typ : Entity_Id; + Name : Name_Id; + Profile : List_Id; + Ret_Type : Entity_Id := Empty; + For_Body : Boolean := False) return Node_Id + is + Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name); + Spec : Node_Id; + + begin + Set_Is_Public (Id, Is_Public (Tag_Typ)); + + -- The internal flag is set to mark these declarations because they have + -- specific properties. First, they are primitives even if they are not + -- defined in the type scope (the freezing point is not necessarily in + -- the same scope). Second, the predefined equality can be overridden by + -- a user-defined equality, no body will be generated in this case. + + Set_Is_Internal (Id); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Id); + end if; + + if No (Ret_Type) then + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Id, + Parameter_Specifications => Profile); + else + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Id, + Parameter_Specifications => Profile, + Result_Definition => + New_Reference_To (Ret_Type, Loc)); + end if; + + if Is_Interface (Tag_Typ) then + return Make_Abstract_Subprogram_Declaration (Loc, Spec); + + -- If body case, return empty subprogram body. Note that this is ill- + -- formed, because there is not even a null statement, and certainly not + -- a return in the function case. The caller is expected to do surgery + -- on the body to add the appropriate stuff. + + elsif For_Body then + return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty); + + -- For the case of an Input attribute predefined for an abstract type, + -- generate an abstract specification. This will never be called, but we + -- need the slot allocated in the dispatching table so that attributes + -- typ'Class'Input and typ'Class'Output will work properly. + + elsif Is_TSS (Name, TSS_Stream_Input) + and then Is_Abstract_Type (Tag_Typ) + then + return Make_Abstract_Subprogram_Declaration (Loc, Spec); + + -- Normal spec case, where we return a subprogram declaration + + else + return Make_Subprogram_Declaration (Loc, Spec); + end if; + end Predef_Spec_Or_Body; + + ----------------------------- + -- Predef_Stream_Attr_Spec -- + ----------------------------- + + function Predef_Stream_Attr_Spec + (Loc : Source_Ptr; + Tag_Typ : Entity_Id; + Name : TSS_Name_Type; + For_Body : Boolean := False) return Node_Id + is + Ret_Type : Entity_Id; + + begin + if Name = TSS_Stream_Input then + Ret_Type := Tag_Typ; + else + Ret_Type := Empty; + end if; + + return Predef_Spec_Or_Body (Loc, + Name => Make_TSS_Name (Tag_Typ, Name), + Tag_Typ => Tag_Typ, + Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name), + Ret_Type => Ret_Type, + For_Body => For_Body); + end Predef_Stream_Attr_Spec; + + --------------------------------- + -- Predefined_Primitive_Bodies -- + --------------------------------- + + function Predefined_Primitive_Bodies + (Tag_Typ : Entity_Id; + Renamed_Eq : Entity_Id) return List_Id + is + Loc : constant Source_Ptr := Sloc (Tag_Typ); + Res : constant List_Id := New_List; + Decl : Node_Id; + Prim : Elmt_Id; + Eq_Needed : Boolean; + Eq_Name : Name_Id; + Ent : Entity_Id; + + pragma Warnings (Off, Ent); + + begin + pragma Assert (not Is_Interface (Tag_Typ)); + + -- See if we have a predefined "=" operator + + if Present (Renamed_Eq) then + Eq_Needed := True; + Eq_Name := Chars (Renamed_Eq); + + -- If the parent is an interface type then it has defined all the + -- predefined primitives abstract and we need to check if the type + -- has some user defined "=" function to avoid generating it. + + elsif Is_Interface (Etype (Tag_Typ)) then + Eq_Needed := True; + Eq_Name := Name_Op_Eq; + + Prim := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Prim) loop + if Chars (Node (Prim)) = Name_Op_Eq + and then not Is_Internal (Node (Prim)) + then + Eq_Needed := False; + Eq_Name := No_Name; + exit; + end if; + + Next_Elmt (Prim); + end loop; + + else + Eq_Needed := False; + Eq_Name := No_Name; + + Prim := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Prim) loop + if Chars (Node (Prim)) = Name_Op_Eq + and then Is_Internal (Node (Prim)) + then + Eq_Needed := True; + Eq_Name := Name_Op_Eq; + exit; + end if; + + Next_Elmt (Prim); + end loop; + end if; + + -- Body of _Alignment + + Decl := Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Name_uAlignment, + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), + Parameter_Type => New_Reference_To (Tag_Typ, Loc))), + + Ret_Type => Standard_Integer, + For_Body => True); + + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_X), + Attribute_Name => Name_Alignment))))); + + Append_To (Res, Decl); + + -- Body of _Size + + Decl := Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Name_uSize, + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), + Parameter_Type => New_Reference_To (Tag_Typ, Loc))), + + Ret_Type => Standard_Long_Long_Integer, + For_Body => True); + + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_X), + Attribute_Name => Name_Size))))); + + Append_To (Res, Decl); + + -- Bodies for Dispatching stream IO routines. We need these only for + -- non-limited types (in the limited case there is no dispatching). + -- We also skip them if dispatching or finalization are not available. + + if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read) + and then No (TSS (Tag_Typ, TSS_Stream_Read)) + then + Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent); + Append_To (Res, Decl); + end if; + + if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write) + and then No (TSS (Tag_Typ, TSS_Stream_Write)) + then + Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent); + Append_To (Res, Decl); + end if; + + -- Skip body of _Input for the abstract case, since the corresponding + -- spec is abstract (see Predef_Spec_Or_Body). + + if not Is_Abstract_Type (Tag_Typ) + and then Stream_Operation_OK (Tag_Typ, TSS_Stream_Input) + and then No (TSS (Tag_Typ, TSS_Stream_Input)) + then + Build_Record_Or_Elementary_Input_Function + (Loc, Tag_Typ, Decl, Ent); + Append_To (Res, Decl); + end if; + + if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output) + and then No (TSS (Tag_Typ, TSS_Stream_Output)) + then + Build_Record_Or_Elementary_Output_Procedure + (Loc, Tag_Typ, Decl, Ent); + Append_To (Res, Decl); + end if; + + -- Ada 2005: Generate bodies for the following primitive operations for + -- limited interfaces and synchronized types that implement a limited + -- interface. + + -- disp_asynchronous_select + -- disp_conditional_select + -- disp_get_prim_op_kind + -- disp_get_task_id + -- disp_timed_select + + -- The interface versions will have null bodies + + -- These operations cannot be implemented on VM targets, so we simply + -- disable their generation in this case. Disable the generation of + -- these bodies if No_Dispatching_Calls, Ravenscar or ZFP is active. + + if Ada_Version >= Ada_2005 + and then Tagged_Type_Expansion + and then not Is_Interface (Tag_Typ) + and then + ((Is_Interface (Etype (Tag_Typ)) + and then Is_Limited_Record (Etype (Tag_Typ))) + or else (Is_Concurrent_Record_Type (Tag_Typ) + and then Has_Interfaces (Tag_Typ))) + and then not Restriction_Active (No_Dispatching_Calls) + and then not Restriction_Active (No_Select_Statements) + and then RTE_Available (RE_Select_Specific_Data) + then + Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ)); + Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ)); + Append_To (Res, Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ)); + Append_To (Res, Make_Disp_Get_Task_Id_Body (Tag_Typ)); + Append_To (Res, Make_Disp_Requeue_Body (Tag_Typ)); + Append_To (Res, Make_Disp_Timed_Select_Body (Tag_Typ)); + end if; + + if not Is_Limited_Type (Tag_Typ) + and then not Is_Interface (Tag_Typ) + then + -- Body for equality + + if Eq_Needed then + Decl := Make_Eq_Body (Tag_Typ, Eq_Name); + Append_To (Res, Decl); + end if; + + -- Body for dispatching assignment + + Decl := + Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Name_uAssign, + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), + Out_Present => True, + Parameter_Type => New_Reference_To (Tag_Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), + Parameter_Type => New_Reference_To (Tag_Typ, Loc))), + For_Body => True); + + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, New_List ( + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_X), + Expression => Make_Identifier (Loc, Name_Y))))); + + Append_To (Res, Decl); + end if; + + -- Generate dummy bodies for finalization actions of types that have + -- no controlled components. + + -- Skip this processing if we are in the finalization routine in the + -- runtime itself, otherwise we get hopelessly circularly confused! + + if In_Finalization_Root (Tag_Typ) then + null; + + -- Skip this if finalization is not available + + elsif Restriction_Active (No_Finalization) then + null; + + elsif (Etype (Tag_Typ) = Tag_Typ + or else Is_Controlled (Tag_Typ) + + -- Ada 2005 (AI-251): We must also generate these subprograms + -- if the immediate ancestor of Tag_Typ is an interface to + -- ensure the correct initialization of its dispatch table. + + or else (not Is_Interface (Tag_Typ) + and then + Is_Interface (Etype (Tag_Typ)))) + and then not Has_Controlled_Component (Tag_Typ) + then + if not Is_Limited_Type (Tag_Typ) then + Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True); + + if Is_Controlled (Tag_Typ) then + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, + Make_Adjust_Call ( + Ref => Make_Identifier (Loc, Name_V), + Typ => Tag_Typ, + Flist_Ref => Make_Identifier (Loc, Name_L), + With_Attach => Make_Identifier (Loc, Name_B)))); + + else + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, New_List ( + Make_Null_Statement (Loc)))); + end if; + + Append_To (Res, Decl); + end if; + + Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True); + + if Is_Controlled (Tag_Typ) then + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, + Make_Final_Call ( + Ref => Make_Identifier (Loc, Name_V), + Typ => Tag_Typ, + With_Detach => Make_Identifier (Loc, Name_B)))); + + else + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, New_List ( + Make_Null_Statement (Loc)))); + end if; + + Append_To (Res, Decl); + end if; + + return Res; + end Predefined_Primitive_Bodies; + + --------------------------------- + -- Predefined_Primitive_Freeze -- + --------------------------------- + + function Predefined_Primitive_Freeze + (Tag_Typ : Entity_Id) return List_Id + is + Res : constant List_Id := New_List; + Prim : Elmt_Id; + Frnodes : List_Id; + + begin + Prim := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Prim) loop + if Is_Predefined_Dispatching_Operation (Node (Prim)) then + Frnodes := Freeze_Entity (Node (Prim), Tag_Typ); + + if Present (Frnodes) then + Append_List_To (Res, Frnodes); + end if; + end if; + + Next_Elmt (Prim); + end loop; + + return Res; + end Predefined_Primitive_Freeze; + + ------------------------- + -- Stream_Operation_OK -- + ------------------------- + + function Stream_Operation_OK + (Typ : Entity_Id; + Operation : TSS_Name_Type) return Boolean + is + Has_Predefined_Or_Specified_Stream_Attribute : Boolean := False; + + begin + -- Special case of a limited type extension: a default implementation + -- of the stream attributes Read or Write exists if that attribute + -- has been specified or is available for an ancestor type; a default + -- implementation of the attribute Output (resp. Input) exists if the + -- attribute has been specified or Write (resp. Read) is available for + -- an ancestor type. The last condition only applies under Ada 2005. + + if Is_Limited_Type (Typ) + and then Is_Tagged_Type (Typ) + then + if Operation = TSS_Stream_Read then + Has_Predefined_Or_Specified_Stream_Attribute := + Has_Specified_Stream_Read (Typ); + + elsif Operation = TSS_Stream_Write then + Has_Predefined_Or_Specified_Stream_Attribute := + Has_Specified_Stream_Write (Typ); + + elsif Operation = TSS_Stream_Input then + Has_Predefined_Or_Specified_Stream_Attribute := + Has_Specified_Stream_Input (Typ) + or else + (Ada_Version >= Ada_2005 + and then Stream_Operation_OK (Typ, TSS_Stream_Read)); + + elsif Operation = TSS_Stream_Output then + Has_Predefined_Or_Specified_Stream_Attribute := + Has_Specified_Stream_Output (Typ) + or else + (Ada_Version >= Ada_2005 + and then Stream_Operation_OK (Typ, TSS_Stream_Write)); + end if; + + -- Case of inherited TSS_Stream_Read or TSS_Stream_Write + + if not Has_Predefined_Or_Specified_Stream_Attribute + and then Is_Derived_Type (Typ) + and then (Operation = TSS_Stream_Read + or else Operation = TSS_Stream_Write) + then + Has_Predefined_Or_Specified_Stream_Attribute := + Present + (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation)); + end if; + end if; + + -- If the type is not limited, or else is limited but the attribute is + -- explicitly specified or is predefined for the type, then return True, + -- unless other conditions prevail, such as restrictions prohibiting + -- streams or dispatching operations. We also return True for limited + -- interfaces, because they may be extended by nonlimited types and + -- permit inheritance in this case (addresses cases where an abstract + -- extension doesn't get 'Input declared, as per comments below, but + -- 'Class'Input must still be allowed). Note that attempts to apply + -- stream attributes to a limited interface or its class-wide type + -- (or limited extensions thereof) will still get properly rejected + -- by Check_Stream_Attribute. + + -- We exclude the Input operation from being a predefined subprogram in + -- the case where the associated type is an abstract extension, because + -- the attribute is not callable in that case, per 13.13.2(49/2). Also, + -- we don't want an abstract version created because types derived from + -- the abstract type may not even have Input available (for example if + -- derived from a private view of the abstract type that doesn't have + -- a visible Input), but a VM such as .NET or the Java VM can treat the + -- operation as inherited anyway, and we don't want an abstract function + -- to be (implicitly) inherited in that case because it can lead to a VM + -- exception. + + return (not Is_Limited_Type (Typ) + or else Is_Interface (Typ) + or else Has_Predefined_Or_Specified_Stream_Attribute) + and then (Operation /= TSS_Stream_Input + or else not Is_Abstract_Type (Typ) + or else not Is_Derived_Type (Typ)) + and then not Has_Unknown_Discriminants (Typ) + and then not (Is_Interface (Typ) + and then (Is_Task_Interface (Typ) + or else Is_Protected_Interface (Typ) + or else Is_Synchronized_Interface (Typ))) + and then not Restriction_Active (No_Streams) + and then not Restriction_Active (No_Dispatch) + and then not No_Run_Time_Mode + and then RTE_Available (RE_Tag) + and then RTE_Available (RE_Root_Stream_Type); + end Stream_Operation_OK; + +end Exp_Ch3; diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads new file mode 100644 index 000000000..beb74b562 --- /dev/null +++ b/gcc/ada/exp_ch3.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 3 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for chapter 3 constructs + +with Types; use Types; +with Elists; use Elists; +with Uintp; use Uintp; + +package Exp_Ch3 is + + procedure Expand_N_Object_Declaration (N : Node_Id); + procedure Expand_N_Subtype_Indication (N : Node_Id); + procedure Expand_N_Variant_Part (N : Node_Id); + procedure Expand_N_Full_Type_Declaration (N : Node_Id); + + procedure Expand_Previous_Access_Type (Def_Id : Entity_Id); + -- For a full type declaration that contains tasks, or that is a task, + -- check whether there exists an access type whose designated type is an + -- incomplete declarations for the current composite type. If so, build the + -- master for that access type, now that it is known to denote an object + -- with tasks. + + procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id); + -- Add a field _parent in the extension part of the record + + procedure Build_Class_Wide_Master (T : Entity_Id); + -- For access to class-wide limited types we must build a task master + -- because some subsequent extension may add a task component. To avoid + -- bringing in the tasking run-time whenever an access-to-class-wide + -- limited type is used, we use the soft-link mechanism and add a level of + -- indirection to calls to routines that manipulate Master_Ids. This must + -- also be used for anonymous access types whose designated type is a task + -- or synchronized interface. + + procedure Build_Discr_Checking_Funcs (N : Node_Id); + -- Builds function which checks whether the component name is consistent + -- with the current discriminants. N is the full type declaration node, + -- and the discriminant checking functions are inserted after this node. + + function Build_Initialization_Call + (Loc : Source_Ptr; + Id_Ref : Node_Id; + Typ : Entity_Id; + In_Init_Proc : Boolean := False; + Enclos_Type : Entity_Id := Empty; + Discr_Map : Elist_Id := New_Elmt_List; + With_Default_Init : Boolean := False; + Constructor_Ref : Node_Id := Empty) return List_Id; + -- Builds a call to the initialization procedure for the base type of Typ, + -- passing it the object denoted by Id_Ref, plus additional parameters as + -- appropriate for the type (the _Master, for task types, for example). + -- Loc is the source location for the constructed tree. In_Init_Proc has + -- to be set to True when the call is itself in an init proc in order to + -- enable the use of discriminals. Enclos_Type is the enclosing type when + -- initializing a component in an outer init proc, and it is used for + -- various expansion cases including the case where Typ is a task type + -- which is an array component, the indexes of the enclosing type are + -- used to build the string that identifies each task at runtime. + -- + -- Discr_Map is used to replace discriminants by their discriminals in + -- expressions used to constrain record components. In the presence of + -- entry families bounded by discriminants, protected type discriminants + -- can appear within expressions in array bounds (not as stand-alone + -- identifiers) and a general replacement is necessary. + -- + -- Ada 2005 (AI-287): With_Default_Init is used to indicate that the + -- initialization call corresponds to a default initialized component + -- of an aggregate. + -- + -- Constructor_Ref is a call to a constructor subprogram. It is currently + -- used only to support C++ constructors. + + procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id); + -- If the designated type of an access type is a task type or contains + -- tasks, we make sure that a _Master variable is declared in the current + -- scope, and then declare a renaming for it: + -- + -- atypeM : Master_Id renames _Master; + -- + -- where atyp is the name of the access type. This declaration is + -- used when an allocator for the access type is expanded. The node N + -- is the full declaration of the designated type that contains tasks. + -- The renaming declaration is inserted before N, and after the Master + -- declaration. + + function Freeze_Type (N : Node_Id) return Boolean; + -- This function executes the freezing actions associated with the given + -- freeze type node N and returns True if the node is to be deleted. We + -- delete the node if it is present just for front end purpose and we don't + -- want Gigi to see the node. This function can't delete the node itself + -- since it would confuse any remaining processing of the freeze node. + + procedure Init_Secondary_Tags + (Typ : Entity_Id; + Target : Node_Id; + Stmts_List : List_Id; + Fixed_Comps : Boolean := True; + Variable_Comps : Boolean := True); + -- Ada 2005 (AI-251): Initialize the tags of the secondary dispatch tables + -- of Typ. The generated code referencing tag fields of Target is appended + -- to Stmts_List. If Fixed_Comps is True then the tag components located at + -- fixed positions of Target are initialized; if Variable_Comps is True + -- then tags components located at variable positions of Target are + -- initialized. + + function Needs_Simple_Initialization + (T : Entity_Id; + Consider_IS : Boolean := True) return Boolean; + -- Certain types need initialization even though there is no specific + -- initialization routine. In this category are access types (which need + -- initializing to null), packed array types whose implementation is a + -- modular type, and all scalar types if Normalize_Scalars is set, as well + -- as private types whose underlying type is present and meets any of these + -- criteria. Finally, descendants of String and Wide_String also need + -- initialization in Initialize/Normalize_Scalars mode. Consider_IS is + -- normally True. If it is False, the Initialize_Scalars is not considered + -- in determining whether simple initialization is needed. + + function Get_Simple_Init_Val + (T : Entity_Id; + N : Node_Id; + Size : Uint := No_Uint) return Node_Id; + -- For a type which Needs_Simple_Initialization (see above), prepares the + -- tree for an expression representing the required initial value. N is a + -- node whose source location used in constructing this tree which is + -- returned as the result of the call. The Size parameter indicates the + -- target size of the object if it is known (indicated by a value that is + -- not No_Uint and is greater than zero). If Size is not given (Size set to + -- No_Uint, or non-positive), then the Esize of T is used as an estimate of + -- the Size. The object size is needed to prepare a known invalid value for + -- use by Normalize_Scalars. A call to this routine where T is a scalar + -- type is only valid if we are in Normalize_Scalars or Initialize_Scalars + -- mode, or if N is the node for a 'Invalid_Value attribute node. + +end Exp_Ch3; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb new file mode 100644 index 000000000..fa1ad4f44 --- /dev/null +++ b/gcc/ada/exp_ch4.adb @@ -0,0 +1,10537 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 4 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Aggr; use Exp_Aggr; +with Exp_Atag; use Exp_Atag; +with Exp_Ch3; use Exp_Ch3; +with Exp_Ch6; use Exp_Ch6; +with Exp_Ch7; use Exp_Ch7; +with Exp_Ch9; use Exp_Ch9; +with Exp_Disp; use Exp_Disp; +with Exp_Fixd; use Exp_Fixd; +with Exp_Intr; use Exp_Intr; +with Exp_Pakd; use Exp_Pakd; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Exp_VFpt; use Exp_VFpt; +with Freeze; use Freeze; +with Inline; use Inline; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Par_SCO; use Par_SCO; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Cat; use Sem_Cat; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch13; use Sem_Ch13; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with SCIL_LL; use SCIL_LL; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; +with Urealp; use Urealp; +with Validsw; use Validsw; + +package body Exp_Ch4 is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Binary_Op_Validity_Checks (N : Node_Id); + pragma Inline (Binary_Op_Validity_Checks); + -- Performs validity checks for a binary operator + + procedure Build_Boolean_Array_Proc_Call + (N : Node_Id; + Op1 : Node_Id; + Op2 : Node_Id); + -- If a boolean array assignment can be done in place, build call to + -- corresponding library procedure. + + procedure Displace_Allocator_Pointer (N : Node_Id); + -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and + -- Expand_Allocator_Expression. Allocating class-wide interface objects + -- this routine displaces the pointer to the allocated object to reference + -- the component referencing the corresponding secondary dispatch table. + + procedure Expand_Allocator_Expression (N : Node_Id); + -- Subsidiary to Expand_N_Allocator, for the case when the expression + -- is a qualified expression or an aggregate. + + procedure Expand_Array_Comparison (N : Node_Id); + -- This routine handles expansion of the comparison operators (N_Op_Lt, + -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic + -- code for these operators is similar, differing only in the details of + -- the actual comparison call that is made. Special processing (call a + -- run-time routine) + + function Expand_Array_Equality + (Nod : Node_Id; + Lhs : Node_Id; + Rhs : Node_Id; + Bodies : List_Id; + Typ : Entity_Id) return Node_Id; + -- Expand an array equality into a call to a function implementing this + -- equality, and a call to it. Loc is the location for the generated nodes. + -- Lhs and Rhs are the array expressions to be compared. Bodies is a list + -- on which to attach bodies of local functions that are created in the + -- process. It is the responsibility of the caller to insert those bodies + -- at the right place. Nod provides the Sloc value for the generated code. + -- Normally the types used for the generated equality routine are taken + -- from Lhs and Rhs. However, in some situations of generated code, the + -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies + -- the type to be used for the formal parameters. + + procedure Expand_Boolean_Operator (N : Node_Id); + -- Common expansion processing for Boolean operators (And, Or, Xor) for the + -- case of array type arguments. + + procedure Expand_Short_Circuit_Operator (N : Node_Id); + -- Common expansion processing for short-circuit boolean operators + + function Expand_Composite_Equality + (Nod : Node_Id; + Typ : Entity_Id; + Lhs : Node_Id; + Rhs : Node_Id; + Bodies : List_Id) return Node_Id; + -- Local recursive function used to expand equality for nested composite + -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which + -- to attach bodies of local functions that are created in the process. + -- This is the responsibility of the caller to insert those bodies at the + -- right place. Nod provides the Sloc value for generated code. Lhs and Rhs + -- are the left and right sides for the comparison, and Typ is the type of + -- the arrays to compare. + + procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id); + -- Routine to expand concatenation of a sequence of two or more operands + -- (in the list Operands) and replace node Cnode with the result of the + -- concatenation. The operands can be of any appropriate type, and can + -- include both arrays and singleton elements. + + procedure Fixup_Universal_Fixed_Operation (N : Node_Id); + -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal + -- fixed. We do not have such a type at runtime, so the purpose of this + -- routine is to find the real type by looking up the tree. We also + -- determine if the operation must be rounded. + + function Get_Allocator_Final_List + (N : Node_Id; + T : Entity_Id; + PtrT : Entity_Id) return Entity_Id; + -- If the designated type is controlled, build final_list expression for + -- created object. If context is an access parameter, create a local access + -- type to have a usable finalization list. + + function Has_Inferable_Discriminants (N : Node_Id) return Boolean; + -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable + -- discriminants if it has a constrained nominal type, unless the object + -- is a component of an enclosing Unchecked_Union object that is subject + -- to a per-object constraint and the enclosing object lacks inferable + -- discriminants. + -- + -- An expression of an Unchecked_Union type has inferable discriminants + -- if it is either a name of an object with inferable discriminants or a + -- qualified expression whose subtype mark denotes a constrained subtype. + + procedure Insert_Dereference_Action (N : Node_Id); + -- N is an expression whose type is an access. When the type of the + -- associated storage pool is derived from Checked_Pool, generate a + -- call to the 'Dereference' primitive operation. + + function Make_Array_Comparison_Op + (Typ : Entity_Id; + Nod : Node_Id) return Node_Id; + -- Comparisons between arrays are expanded in line. This function produces + -- the body of the implementation of (a > b), where a and b are one- + -- dimensional arrays of some discrete type. The original node is then + -- expanded into the appropriate call to this function. Nod provides the + -- Sloc value for the generated code. + + function Make_Boolean_Array_Op + (Typ : Entity_Id; + N : Node_Id) return Node_Id; + -- Boolean operations on boolean arrays are expanded in line. This function + -- produce the body for the node N, which is (a and b), (a or b), or (a xor + -- b). It is used only the normal case and not the packed case. The type + -- involved, Typ, is the Boolean array type, and the logical operations in + -- the body are simple boolean operations. Note that Typ is always a + -- constrained type (the caller has ensured this by using + -- Convert_To_Actual_Subtype if necessary). + + procedure Rewrite_Comparison (N : Node_Id); + -- If N is the node for a comparison whose outcome can be determined at + -- compile time, then the node N can be rewritten with True or False. If + -- the outcome cannot be determined at compile time, the call has no + -- effect. If N is a type conversion, then this processing is applied to + -- its expression. If N is neither comparison nor a type conversion, the + -- call has no effect. + + procedure Tagged_Membership + (N : Node_Id; + SCIL_Node : out Node_Id; + Result : out Node_Id); + -- Construct the expression corresponding to the tagged membership test. + -- Deals with a second operand being (or not) a class-wide type. + + function Safe_In_Place_Array_Op + (Lhs : Node_Id; + Op1 : Node_Id; + Op2 : Node_Id) return Boolean; + -- In the context of an assignment, where the right-hand side is a boolean + -- operation on arrays, check whether operation can be performed in place. + + procedure Unary_Op_Validity_Checks (N : Node_Id); + pragma Inline (Unary_Op_Validity_Checks); + -- Performs validity checks for a unary operator + + ------------------------------- + -- Binary_Op_Validity_Checks -- + ------------------------------- + + procedure Binary_Op_Validity_Checks (N : Node_Id) is + begin + if Validity_Checks_On and Validity_Check_Operands then + Ensure_Valid (Left_Opnd (N)); + Ensure_Valid (Right_Opnd (N)); + end if; + end Binary_Op_Validity_Checks; + + ------------------------------------ + -- Build_Boolean_Array_Proc_Call -- + ------------------------------------ + + procedure Build_Boolean_Array_Proc_Call + (N : Node_Id; + Op1 : Node_Id; + Op2 : Node_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Kind : constant Node_Kind := Nkind (Expression (N)); + Target : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => Name (N), + Attribute_Name => Name_Address); + + Arg1 : Node_Id := Op1; + Arg2 : Node_Id := Op2; + Call_Node : Node_Id; + Proc_Name : Entity_Id; + + begin + if Kind = N_Op_Not then + if Nkind (Op1) in N_Binary_Op then + + -- Use negated version of the binary operators + + if Nkind (Op1) = N_Op_And then + Proc_Name := RTE (RE_Vector_Nand); + + elsif Nkind (Op1) = N_Op_Or then + Proc_Name := RTE (RE_Vector_Nor); + + else pragma Assert (Nkind (Op1) = N_Op_Xor); + Proc_Name := RTE (RE_Vector_Xor); + end if; + + Call_Node := + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Proc_Name, Loc), + + Parameter_Associations => New_List ( + Target, + Make_Attribute_Reference (Loc, + Prefix => Left_Opnd (Op1), + Attribute_Name => Name_Address), + + Make_Attribute_Reference (Loc, + Prefix => Right_Opnd (Op1), + Attribute_Name => Name_Address), + + Make_Attribute_Reference (Loc, + Prefix => Left_Opnd (Op1), + Attribute_Name => Name_Length))); + + else + Proc_Name := RTE (RE_Vector_Not); + + Call_Node := + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Proc_Name, Loc), + Parameter_Associations => New_List ( + Target, + + Make_Attribute_Reference (Loc, + Prefix => Op1, + Attribute_Name => Name_Address), + + Make_Attribute_Reference (Loc, + Prefix => Op1, + Attribute_Name => Name_Length))); + end if; + + else + -- We use 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) + + if Nkind (Op1) = N_Op_Not then + Arg1 := Right_Opnd (Op1); + Arg2 := Right_Opnd (Op2); + if Kind = N_Op_And then + Proc_Name := RTE (RE_Vector_Nor); + elsif Kind = N_Op_Or then + Proc_Name := RTE (RE_Vector_Nand); + else + Proc_Name := RTE (RE_Vector_Xor); + end if; + + else + if Kind = N_Op_And then + Proc_Name := RTE (RE_Vector_And); + elsif Kind = N_Op_Or then + Proc_Name := RTE (RE_Vector_Or); + elsif Nkind (Op2) = N_Op_Not then + Proc_Name := RTE (RE_Vector_Nxor); + Arg2 := Right_Opnd (Op2); + else + Proc_Name := RTE (RE_Vector_Xor); + end if; + end if; + + Call_Node := + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Proc_Name, Loc), + Parameter_Associations => New_List ( + Target, + Make_Attribute_Reference (Loc, + Prefix => Arg1, + Attribute_Name => Name_Address), + Make_Attribute_Reference (Loc, + Prefix => Arg2, + Attribute_Name => Name_Address), + Make_Attribute_Reference (Loc, + Prefix => Arg1, + Attribute_Name => Name_Length))); + end if; + + Rewrite (N, Call_Node); + Analyze (N); + + exception + when RE_Not_Available => + return; + end Build_Boolean_Array_Proc_Call; + + -------------------------------- + -- Displace_Allocator_Pointer -- + -------------------------------- + + procedure Displace_Allocator_Pointer (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Orig_Node : constant Node_Id := Original_Node (N); + Dtyp : Entity_Id; + Etyp : Entity_Id; + PtrT : Entity_Id; + + begin + -- Do nothing in case of VM targets: the virtual machine will handle + -- interfaces directly. + + if not Tagged_Type_Expansion then + return; + end if; + + pragma Assert (Nkind (N) = N_Identifier + and then Nkind (Orig_Node) = N_Allocator); + + PtrT := Etype (Orig_Node); + Dtyp := Available_View (Designated_Type (PtrT)); + Etyp := Etype (Expression (Orig_Node)); + + if Is_Class_Wide_Type (Dtyp) + and then Is_Interface (Dtyp) + then + -- If the type of the allocator expression is not an interface type + -- we can generate code to reference the record component containing + -- the pointer to the secondary dispatch table. + + if not Is_Interface (Etyp) then + declare + Saved_Typ : constant Entity_Id := Etype (Orig_Node); + + begin + -- 1) Get access to the allocated object + + Rewrite (N, + Make_Explicit_Dereference (Loc, + Relocate_Node (N))); + Set_Etype (N, Etyp); + Set_Analyzed (N); + + -- 2) Add the conversion to displace the pointer to reference + -- the secondary dispatch table. + + Rewrite (N, Convert_To (Dtyp, Relocate_Node (N))); + Analyze_And_Resolve (N, Dtyp); + + -- 3) The 'access to the secondary dispatch table will be used + -- as the value returned by the allocator. + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (N), + Attribute_Name => Name_Access)); + Set_Etype (N, Saved_Typ); + Set_Analyzed (N); + end; + + -- If the type of the allocator expression is an interface type we + -- generate a run-time call to displace "this" to reference the + -- component containing the pointer to the secondary dispatch table + -- or else raise Constraint_Error if the actual object does not + -- implement the target interface. This case corresponds with the + -- following example: + + -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is + -- begin + -- return new Iface_2'Class'(Obj); + -- end Op; + + else + Rewrite (N, + Unchecked_Convert_To (PtrT, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Displace), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), + Relocate_Node (N)), + + New_Occurrence_Of + (Elists.Node + (First_Elmt + (Access_Disp_Table (Etype (Base_Type (Dtyp))))), + Loc))))); + Analyze_And_Resolve (N, PtrT); + end if; + end if; + end Displace_Allocator_Pointer; + + --------------------------------- + -- Expand_Allocator_Expression -- + --------------------------------- + + procedure Expand_Allocator_Expression (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Exp : constant Node_Id := Expression (Expression (N)); + PtrT : constant Entity_Id := Etype (N); + DesigT : constant Entity_Id := Designated_Type (PtrT); + + procedure Apply_Accessibility_Check + (Ref : Node_Id; + Built_In_Place : Boolean := False); + -- Ada 2005 (AI-344): For an allocator with a class-wide designated + -- type, generate an accessibility check to verify that the level of the + -- type of the created object is not deeper than the level of the access + -- type. If the type of the qualified expression is class- wide, then + -- always generate the check (except in the case where it is known to be + -- unnecessary, see comment below). Otherwise, only generate the check + -- if the level of the qualified expression type is statically deeper + -- than the access type. + -- + -- Although the static accessibility will generally have been performed + -- as a legality check, it won't have been done in cases where the + -- allocator appears in generic body, so a run-time check is needed in + -- general. One special case is when the access type is declared in the + -- same scope as the class-wide allocator, in which case the check can + -- never fail, so it need not be generated. + -- + -- As an open issue, there seem to be cases where the static level + -- associated with the class-wide object's underlying type is not + -- sufficient to perform the proper accessibility check, such as for + -- allocators in nested subprograms or accept statements initialized by + -- class-wide formals when the actual originates outside at a deeper + -- static level. The nested subprogram case might require passing + -- accessibility levels along with class-wide parameters, and the task + -- case seems to be an actual gap in the language rules that needs to + -- be fixed by the ARG. ??? + + ------------------------------- + -- Apply_Accessibility_Check -- + ------------------------------- + + procedure Apply_Accessibility_Check + (Ref : Node_Id; + Built_In_Place : Boolean := False) + is + Ref_Node : Node_Id; + + begin + -- Note: we skip the accessibility check for the VM case, since + -- there does not seem to be any practical way of implementing it. + + if Ada_Version >= Ada_2005 + and then Tagged_Type_Expansion + and then Is_Class_Wide_Type (DesigT) + and then not Scope_Suppress (Accessibility_Check) + and then + (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT) + or else + (Is_Class_Wide_Type (Etype (Exp)) + and then Scope (PtrT) /= Current_Scope)) + then + -- If the allocator was built in place Ref is already a reference + -- to the access object initialized to the result of the allocator + -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). Otherwise + -- it is the entity associated with the object containing the + -- address of the allocated object. + + if Built_In_Place then + Ref_Node := New_Copy (Ref); + else + Ref_Node := New_Reference_To (Ref, Loc); + end if; + + Insert_Action (N, + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => + Build_Get_Access_Level (Loc, + Make_Attribute_Reference (Loc, + Prefix => Ref_Node, + Attribute_Name => Name_Tag)), + Right_Opnd => + Make_Integer_Literal (Loc, + Type_Access_Level (PtrT))), + Reason => PE_Accessibility_Check_Failed)); + end if; + end Apply_Accessibility_Check; + + -- Local variables + + Indic : constant Node_Id := Subtype_Mark (Expression (N)); + T : constant Entity_Id := Entity (Indic); + Flist : Node_Id; + Node : Node_Id; + Temp : Entity_Id; + + TagT : Entity_Id := Empty; + -- Type used as source for tag assignment + + TagR : Node_Id := Empty; + -- Target reference for tag assignment + + Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp); + + Tag_Assign : Node_Id; + Tmp_Node : Node_Id; + + -- Start of processing for Expand_Allocator_Expression + + begin + if Is_Tagged_Type (T) or else Needs_Finalization (T) then + + if Is_CPP_Constructor_Call (Exp) then + + -- Generate: + -- Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn + + -- Allocate the object with no expression + + Node := Relocate_Node (N); + Set_Expression (Node, New_Reference_To (Etype (Exp), Loc)); + + -- Avoid its expansion to avoid generating a call to the default + -- C++ constructor + + Set_Analyzed (Node); + + Temp := Make_Temporary (Loc, 'P', N); + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Constant_Present => True, + Object_Definition => New_Reference_To (PtrT, Loc), + Expression => Node)); + + Apply_Accessibility_Check (Temp); + + -- Locate the enclosing list and insert the C++ constructor call + + declare + P : Node_Id; + + begin + P := Parent (Node); + while not Is_List_Member (P) loop + P := Parent (P); + end loop; + + Insert_List_After_And_Analyze (P, + Build_Initialization_Call (Loc, + Id_Ref => + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Temp, Loc)), + Typ => Etype (Exp), + Constructor_Ref => Exp)); + end; + + Rewrite (N, New_Reference_To (Temp, Loc)); + Analyze_And_Resolve (N, PtrT); + return; + end if; + + -- Ada 2005 (AI-318-02): If the initialization expression is a call + -- to a build-in-place function, then access to the allocated object + -- must be passed to the function. Currently we limit such functions + -- to those with constrained limited result subtypes, but eventually + -- we plan to expand the allowed forms of functions that are treated + -- as build-in-place. + + if Ada_Version >= Ada_2005 + and then Is_Build_In_Place_Function_Call (Exp) + then + Make_Build_In_Place_Call_In_Allocator (N, Exp); + Apply_Accessibility_Check (N, Built_In_Place => True); + return; + end if; + + -- Actions inserted before: + -- Temp : constant ptr_T := new T'(Expression); + -- Temp._tag := T'tag; + -- Adjust (Finalizable (Temp.all)); + -- Attach_To_Final_List (Finalizable (Temp.all)); + + -- We analyze by hand the new internal allocator to avoid + -- any recursion and inappropriate call to Initialize + + -- We don't want to remove side effects when the expression must be + -- built in place. In the case of a build-in-place function call, + -- that could lead to a duplication of the call, which was already + -- substituted for the allocator. + + if not Aggr_In_Place then + Remove_Side_Effects (Exp); + end if; + + Temp := Make_Temporary (Loc, 'P', N); + + -- For a class wide allocation generate the following code: + + -- type Equiv_Record is record ... end record; + -- implicit subtype CW is ; + -- temp : PtrT := new CW'(CW!(expr)); + + if Is_Class_Wide_Type (T) then + Expand_Subtype_From_Expr (Empty, T, Indic, Exp); + + -- Ada 2005 (AI-251): If the expression is a class-wide interface + -- object we generate code to move up "this" to reference the + -- base of the object before allocating the new object. + + -- Note that Exp'Address is recursively expanded into a call + -- to Base_Address (Exp.Tag) + + if Is_Class_Wide_Type (Etype (Exp)) + and then Is_Interface (Etype (Exp)) + and then Tagged_Type_Expansion + then + Set_Expression + (Expression (N), + Unchecked_Convert_To (Entity (Indic), + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Tag_Ptr), + Make_Attribute_Reference (Loc, + Prefix => Exp, + Attribute_Name => Name_Address))))); + + else + Set_Expression + (Expression (N), + Unchecked_Convert_To (Entity (Indic), Exp)); + end if; + + Analyze_And_Resolve (Expression (N), Entity (Indic)); + end if; + + -- Keep separate the management of allocators returning interfaces + + if not Is_Interface (Directly_Designated_Type (PtrT)) then + if Aggr_In_Place then + Tmp_Node := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Reference_To (PtrT, Loc), + Expression => + Make_Allocator (Loc, + New_Reference_To (Etype (Exp), Loc))); + + -- Copy the Comes_From_Source flag for the allocator we just + -- built, since logically this allocator is a replacement of + -- the original allocator node. This is for proper handling of + -- restriction No_Implicit_Heap_Allocations. + + Set_Comes_From_Source + (Expression (Tmp_Node), Comes_From_Source (N)); + + Set_No_Initialization (Expression (Tmp_Node)); + Insert_Action (N, Tmp_Node); + + if Needs_Finalization (T) + and then Ekind (PtrT) = E_Anonymous_Access_Type + then + -- Create local finalization list for access parameter + + Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT); + end if; + + Convert_Aggr_In_Allocator (N, Tmp_Node, Exp); + + else + Node := Relocate_Node (N); + Set_Analyzed (Node); + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Constant_Present => True, + Object_Definition => New_Reference_To (PtrT, Loc), + Expression => Node)); + end if; + + -- Ada 2005 (AI-251): Handle allocators whose designated type is an + -- interface type. In this case we use the type of the qualified + -- expression to allocate the object. + + else + declare + Def_Id : constant Entity_Id := Make_Temporary (Loc, 'T'); + New_Decl : Node_Id; + + begin + New_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Def_Id, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Null_Exclusion_Present => False, + Constant_Present => False, + Subtype_Indication => + New_Reference_To (Etype (Exp), Loc))); + + Insert_Action (N, New_Decl); + + -- Inherit the final chain to ensure that the expansion of the + -- aggregate is correct in case of controlled types + + if Needs_Finalization (Directly_Designated_Type (PtrT)) then + Set_Associated_Final_Chain (Def_Id, + Associated_Final_Chain (PtrT)); + end if; + + -- Declare the object using the previous type declaration + + if Aggr_In_Place then + Tmp_Node := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Reference_To (Def_Id, Loc), + Expression => + Make_Allocator (Loc, + New_Reference_To (Etype (Exp), Loc))); + + -- Copy the Comes_From_Source flag for the allocator we just + -- built, since logically this allocator is a replacement of + -- the original allocator node. This is for proper handling + -- of restriction No_Implicit_Heap_Allocations. + + Set_Comes_From_Source + (Expression (Tmp_Node), Comes_From_Source (N)); + + Set_No_Initialization (Expression (Tmp_Node)); + Insert_Action (N, Tmp_Node); + + if Needs_Finalization (T) + and then Ekind (PtrT) = E_Anonymous_Access_Type + then + -- Create local finalization list for access parameter + + Flist := + Get_Allocator_Final_List (N, Base_Type (T), PtrT); + end if; + + Convert_Aggr_In_Allocator (N, Tmp_Node, Exp); + else + Node := Relocate_Node (N); + Set_Analyzed (Node); + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Constant_Present => True, + Object_Definition => New_Reference_To (Def_Id, Loc), + Expression => Node)); + end if; + + -- Generate an additional object containing the address of the + -- returned object. The type of this second object declaration + -- is the correct type required for the common processing that + -- is still performed by this subprogram. The displacement of + -- this pointer to reference the component associated with the + -- interface type will be done at the end of common processing. + + New_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'P'), + Object_Definition => New_Reference_To (PtrT, Loc), + Expression => Unchecked_Convert_To (PtrT, + New_Reference_To (Temp, Loc))); + + Insert_Action (N, New_Decl); + + Tmp_Node := New_Decl; + Temp := Defining_Identifier (New_Decl); + end; + end if; + + Apply_Accessibility_Check (Temp); + + -- Generate the tag assignment + + -- Suppress the tag assignment when VM_Target because VM tags are + -- represented implicitly in objects. + + if not Tagged_Type_Expansion then + null; + + -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide + -- interface objects because in this case the tag does not change. + + elsif Is_Interface (Directly_Designated_Type (Etype (N))) then + pragma Assert (Is_Class_Wide_Type + (Directly_Designated_Type (Etype (N)))); + null; + + elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then + TagT := T; + TagR := New_Reference_To (Temp, Loc); + + elsif Is_Private_Type (T) + and then Is_Tagged_Type (Underlying_Type (T)) + then + TagT := Underlying_Type (T); + TagR := + Unchecked_Convert_To (Underlying_Type (T), + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Temp, Loc))); + end if; + + if Present (TagT) then + Tag_Assign := + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => TagR, + Selector_Name => + New_Reference_To (First_Tag_Component (TagT), Loc)), + + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Elists.Node (First_Elmt (Access_Disp_Table (TagT))), + Loc))); + + -- The previous assignment has to be done in any case + + Set_Assignment_OK (Name (Tag_Assign)); + Insert_Action (N, Tag_Assign); + end if; + + if Needs_Finalization (DesigT) + and then Needs_Finalization (T) + then + declare + Attach : Node_Id; + Apool : constant Entity_Id := + Associated_Storage_Pool (PtrT); + + begin + -- If it is an allocation on the secondary stack (i.e. a value + -- returned from a function), the object is attached on the + -- caller side as soon as the call is completed (see + -- Expand_Ctrl_Function_Call) + + if Is_RTE (Apool, RE_SS_Pool) then + declare + F : constant Entity_Id := Make_Temporary (Loc, 'F'); + begin + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => F, + Object_Definition => + New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); + Flist := New_Reference_To (F, Loc); + Attach := Make_Integer_Literal (Loc, 1); + end; + + -- Normal case, not a secondary stack allocation + + else + if Needs_Finalization (T) + and then Ekind (PtrT) = E_Anonymous_Access_Type + then + -- Create local finalization list for access parameter + + Flist := + Get_Allocator_Final_List (N, Base_Type (T), PtrT); + else + Flist := Find_Final_List (PtrT); + end if; + + Attach := Make_Integer_Literal (Loc, 2); + end if; + + -- Generate an Adjust call if the object will be moved. In Ada + -- 2005, the object may be inherently limited, in which case + -- there is no Adjust procedure, and the object is built in + -- place. In Ada 95, the object can be limited but not + -- inherently limited if this allocator came from a return + -- statement (we're allocating the result on the secondary + -- stack). In that case, the object will be moved, so we _do_ + -- want to Adjust. + + if not Aggr_In_Place + and then not Is_Immutably_Limited_Type (T) + then + Insert_Actions (N, + Make_Adjust_Call ( + Ref => + + -- An unchecked conversion is needed in the classwide + -- case because the designated type can be an ancestor of + -- the subtype mark of the allocator. + + Unchecked_Convert_To (T, + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Temp, Loc))), + + Typ => T, + Flist_Ref => Flist, + With_Attach => Attach, + Allocator => True)); + end if; + end; + end if; + + Rewrite (N, New_Reference_To (Temp, Loc)); + Analyze_And_Resolve (N, PtrT); + + -- Ada 2005 (AI-251): Displace the pointer to reference the record + -- component containing the secondary dispatch table of the interface + -- type. + + if Is_Interface (Directly_Designated_Type (PtrT)) then + Displace_Allocator_Pointer (N); + end if; + + elsif Aggr_In_Place then + Temp := Make_Temporary (Loc, 'P', N); + Tmp_Node := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Reference_To (PtrT, Loc), + Expression => Make_Allocator (Loc, + New_Reference_To (Etype (Exp), Loc))); + + -- Copy the Comes_From_Source flag for the allocator we just built, + -- since logically this allocator is a replacement of the original + -- allocator node. This is for proper handling of restriction + -- No_Implicit_Heap_Allocations. + + Set_Comes_From_Source + (Expression (Tmp_Node), Comes_From_Source (N)); + + Set_No_Initialization (Expression (Tmp_Node)); + Insert_Action (N, Tmp_Node); + Convert_Aggr_In_Allocator (N, Tmp_Node, Exp); + Rewrite (N, New_Reference_To (Temp, Loc)); + Analyze_And_Resolve (N, PtrT); + + elsif Is_Access_Type (T) + and then Can_Never_Be_Null (T) + then + Install_Null_Excluding_Check (Exp); + + elsif Is_Access_Type (DesigT) + and then Nkind (Exp) = N_Allocator + and then Nkind (Expression (Exp)) /= N_Qualified_Expression + then + -- Apply constraint to designated subtype indication + + Apply_Constraint_Check (Expression (Exp), + Designated_Type (DesigT), + No_Sliding => True); + + if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then + + -- Propagate constraint_error to enclosing allocator + + Rewrite (Exp, New_Copy (Expression (Exp))); + end if; + else + -- If we have: + -- type A is access T1; + -- X : A := new T2'(...); + -- T1 and T2 can be different subtypes, and we might need to check + -- both constraints. First check against the type of the qualified + -- expression. + + Apply_Constraint_Check (Exp, T, No_Sliding => True); + + if Do_Range_Check (Exp) then + Set_Do_Range_Check (Exp, False); + Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed); + end if; + + -- A check is also needed in cases where the designated subtype is + -- constrained and differs from the subtype given in the qualified + -- expression. Note that the check on the qualified expression does + -- not allow sliding, but this check does (a relaxation from Ada 83). + + if Is_Constrained (DesigT) + and then not Subtypes_Statically_Match (T, DesigT) + then + Apply_Constraint_Check + (Exp, DesigT, No_Sliding => False); + + if Do_Range_Check (Exp) then + Set_Do_Range_Check (Exp, False); + Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed); + end if; + end if; + + -- For an access to unconstrained packed array, GIGI needs to see an + -- expression with a constrained subtype in order to compute the + -- proper size for the allocator. + + if Is_Array_Type (T) + and then not Is_Constrained (T) + and then Is_Packed (T) + then + declare + ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A'); + Internal_Exp : constant Node_Id := Relocate_Node (Exp); + begin + Insert_Action (Exp, + Make_Subtype_Declaration (Loc, + Defining_Identifier => ConstrT, + Subtype_Indication => + Make_Subtype_From_Expr (Exp, T))); + Freeze_Itype (ConstrT, Exp); + Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp)); + end; + end if; + + -- Ada 2005 (AI-318-02): If the initialization expression is a call + -- to a build-in-place function, then access to the allocated object + -- must be passed to the function. Currently we limit such functions + -- to those with constrained limited result subtypes, but eventually + -- we plan to expand the allowed forms of functions that are treated + -- as build-in-place. + + if Ada_Version >= Ada_2005 + and then Is_Build_In_Place_Function_Call (Exp) + then + Make_Build_In_Place_Call_In_Allocator (N, Exp); + end if; + end if; + + exception + when RE_Not_Available => + return; + end Expand_Allocator_Expression; + + ----------------------------- + -- Expand_Array_Comparison -- + ----------------------------- + + -- Expansion is only required in the case of array types. For the unpacked + -- case, an appropriate runtime routine is called. For packed cases, and + -- also in some other cases where a runtime routine cannot be called, the + -- form of the expansion is: + + -- [body for greater_nn; boolean_expression] + + -- The body is built by Make_Array_Comparison_Op, and the form of the + -- Boolean expression depends on the operator involved. + + procedure Expand_Array_Comparison (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Op1 : Node_Id := Left_Opnd (N); + Op2 : Node_Id := Right_Opnd (N); + Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); + Ctyp : constant Entity_Id := Component_Type (Typ1); + + Expr : Node_Id; + Func_Body : Node_Id; + Func_Name : Entity_Id; + + Comp : RE_Id; + + Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size; + -- True for byte addressable target + + function Length_Less_Than_4 (Opnd : Node_Id) return Boolean; + -- Returns True if the length of the given operand is known to be less + -- than 4. Returns False if this length is known to be four or greater + -- or is not known at compile time. + + ------------------------ + -- Length_Less_Than_4 -- + ------------------------ + + function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is + Otyp : constant Entity_Id := Etype (Opnd); + + begin + if Ekind (Otyp) = E_String_Literal_Subtype then + return String_Literal_Length (Otyp) < 4; + + else + declare + Ityp : constant Entity_Id := Etype (First_Index (Otyp)); + Lo : constant Node_Id := Type_Low_Bound (Ityp); + Hi : constant Node_Id := Type_High_Bound (Ityp); + Lov : Uint; + Hiv : Uint; + + begin + if Compile_Time_Known_Value (Lo) then + Lov := Expr_Value (Lo); + else + return False; + end if; + + if Compile_Time_Known_Value (Hi) then + Hiv := Expr_Value (Hi); + else + return False; + end if; + + return Hiv < Lov + 3; + end; + end if; + end Length_Less_Than_4; + + -- Start of processing for Expand_Array_Comparison + + begin + -- Deal first with unpacked case, where we can call a runtime routine + -- except that we avoid this for targets for which are not addressable + -- by bytes, and for the JVM/CIL, since they do not support direct + -- addressing of array components. + + if not Is_Bit_Packed_Array (Typ1) + and then Byte_Addressable + and then VM_Target = No_VM + then + -- The call we generate is: + + -- Compare_Array_xn[_Unaligned] + -- (left'address, right'address, left'length, right'length) 0 + + -- x = U for unsigned, S for signed + -- n = 8,16,32,64 for component size + -- Add _Unaligned if length < 4 and component size is 8. + -- is the standard comparison operator + + if Component_Size (Typ1) = 8 then + if Length_Less_Than_4 (Op1) + or else + Length_Less_Than_4 (Op2) + then + if Is_Unsigned_Type (Ctyp) then + Comp := RE_Compare_Array_U8_Unaligned; + else + Comp := RE_Compare_Array_S8_Unaligned; + end if; + + else + if Is_Unsigned_Type (Ctyp) then + Comp := RE_Compare_Array_U8; + else + Comp := RE_Compare_Array_S8; + end if; + end if; + + elsif Component_Size (Typ1) = 16 then + if Is_Unsigned_Type (Ctyp) then + Comp := RE_Compare_Array_U16; + else + Comp := RE_Compare_Array_S16; + end if; + + elsif Component_Size (Typ1) = 32 then + if Is_Unsigned_Type (Ctyp) then + Comp := RE_Compare_Array_U32; + else + Comp := RE_Compare_Array_S32; + end if; + + else pragma Assert (Component_Size (Typ1) = 64); + if Is_Unsigned_Type (Ctyp) then + Comp := RE_Compare_Array_U64; + else + Comp := RE_Compare_Array_S64; + end if; + end if; + + Remove_Side_Effects (Op1, Name_Req => True); + Remove_Side_Effects (Op2, Name_Req => True); + + Rewrite (Op1, + Make_Function_Call (Sloc (Op1), + Name => New_Occurrence_Of (RTE (Comp), Loc), + + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Op1), + Attribute_Name => Name_Address), + + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Op2), + Attribute_Name => Name_Address), + + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Op1), + Attribute_Name => Name_Length), + + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Op2), + Attribute_Name => Name_Length)))); + + Rewrite (Op2, + Make_Integer_Literal (Sloc (Op2), + Intval => Uint_0)); + + Analyze_And_Resolve (Op1, Standard_Integer); + Analyze_And_Resolve (Op2, Standard_Integer); + return; + end if; + + -- Cases where we cannot make runtime call + + -- For (a <= b) we convert to not (a > b) + + if Chars (N) = Name_Op_Le then + Rewrite (N, + Make_Op_Not (Loc, + Right_Opnd => + Make_Op_Gt (Loc, + Left_Opnd => Op1, + Right_Opnd => Op2))); + Analyze_And_Resolve (N, Standard_Boolean); + return; + + -- For < the Boolean expression is + -- greater__nn (op2, op1) + + elsif Chars (N) = Name_Op_Lt then + Func_Body := Make_Array_Comparison_Op (Typ1, N); + + -- Switch operands + + Op1 := Right_Opnd (N); + Op2 := Left_Opnd (N); + + -- For (a >= b) we convert to not (a < b) + + elsif Chars (N) = Name_Op_Ge then + Rewrite (N, + Make_Op_Not (Loc, + Right_Opnd => + Make_Op_Lt (Loc, + Left_Opnd => Op1, + Right_Opnd => Op2))); + Analyze_And_Resolve (N, Standard_Boolean); + return; + + -- For > the Boolean expression is + -- greater__nn (op1, op2) + + else + pragma Assert (Chars (N) = Name_Op_Gt); + Func_Body := Make_Array_Comparison_Op (Typ1, N); + end if; + + Func_Name := Defining_Unit_Name (Specification (Func_Body)); + Expr := + Make_Function_Call (Loc, + Name => New_Reference_To (Func_Name, Loc), + Parameter_Associations => New_List (Op1, Op2)); + + Insert_Action (N, Func_Body); + Rewrite (N, Expr); + Analyze_And_Resolve (N, Standard_Boolean); + + exception + when RE_Not_Available => + return; + end Expand_Array_Comparison; + + --------------------------- + -- Expand_Array_Equality -- + --------------------------- + + -- Expand an equality function for multi-dimensional arrays. Here is an + -- example of such a function for Nb_Dimension = 2 + + -- function Enn (A : atyp; B : btyp) return boolean is + -- begin + -- if (A'length (1) = 0 or else A'length (2) = 0) + -- and then + -- (B'length (1) = 0 or else B'length (2) = 0) + -- then + -- return True; -- RM 4.5.2(22) + -- end if; + + -- if A'length (1) /= B'length (1) + -- or else + -- A'length (2) /= B'length (2) + -- then + -- return False; -- RM 4.5.2(23) + -- end if; + + -- declare + -- A1 : Index_T1 := A'first (1); + -- B1 : Index_T1 := B'first (1); + -- begin + -- loop + -- declare + -- A2 : Index_T2 := A'first (2); + -- B2 : Index_T2 := B'first (2); + -- begin + -- loop + -- if A (A1, A2) /= B (B1, B2) then + -- return False; + -- end if; + + -- exit when A2 = A'last (2); + -- A2 := Index_T2'succ (A2); + -- B2 := Index_T2'succ (B2); + -- end loop; + -- end; + + -- exit when A1 = A'last (1); + -- A1 := Index_T1'succ (A1); + -- B1 := Index_T1'succ (B1); + -- end loop; + -- end; + + -- return true; + -- end Enn; + + -- Note on the formal types used (atyp and btyp). If either of the arrays + -- is of a private type, we use the underlying type, and do an unchecked + -- conversion of the actual. If either of the arrays has a bound depending + -- on a discriminant, then we use the base type since otherwise we have an + -- escaped discriminant in the function. + + -- If both arrays are constrained and have the same bounds, we can generate + -- a loop with an explicit iteration scheme using a 'Range attribute over + -- the first array. + + function Expand_Array_Equality + (Nod : Node_Id; + Lhs : Node_Id; + Rhs : Node_Id; + Bodies : List_Id; + Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Nod); + Decls : constant List_Id := New_List; + Index_List1 : constant List_Id := New_List; + Index_List2 : constant List_Id := New_List; + + Actuals : List_Id; + Formals : List_Id; + Func_Name : Entity_Id; + Func_Body : Node_Id; + + A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA); + B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB); + + Ltyp : Entity_Id; + Rtyp : Entity_Id; + -- The parameter types to be used for the formals + + function Arr_Attr + (Arr : Entity_Id; + Nam : Name_Id; + Num : Int) return Node_Id; + -- This builds the attribute reference Arr'Nam (Expr) + + function Component_Equality (Typ : Entity_Id) return Node_Id; + -- Create one statement to compare corresponding components, designated + -- by a full set of indexes. + + function Get_Arg_Type (N : Node_Id) return Entity_Id; + -- Given one of the arguments, computes the appropriate type to be used + -- for that argument in the corresponding function formal + + function Handle_One_Dimension + (N : Int; + Index : Node_Id) return Node_Id; + -- This procedure returns the following code + -- + -- declare + -- Bn : Index_T := B'First (N); + -- begin + -- loop + -- xxx + -- exit when An = A'Last (N); + -- An := Index_T'Succ (An) + -- Bn := Index_T'Succ (Bn) + -- end loop; + -- end; + -- + -- If both indexes are constrained and identical, the procedure + -- returns a simpler loop: + -- + -- for An in A'Range (N) loop + -- xxx + -- end loop + -- + -- N is the dimension for which we are generating a loop. Index is the + -- N'th index node, whose Etype is Index_Type_n in the above code. The + -- xxx statement is either the loop or declare for the next dimension + -- or if this is the last dimension the comparison of corresponding + -- components of the arrays. + -- + -- The actual way the code works is to return the comparison of + -- corresponding components for the N+1 call. That's neater! + + function Test_Empty_Arrays return Node_Id; + -- This function constructs the test for both arrays being empty + -- (A'length (1) = 0 or else A'length (2) = 0 or else ...) + -- and then + -- (B'length (1) = 0 or else B'length (2) = 0 or else ...) + + function Test_Lengths_Correspond return Node_Id; + -- This function constructs the test for arrays having different lengths + -- in at least one index position, in which case the resulting code is: + + -- A'length (1) /= B'length (1) + -- or else + -- A'length (2) /= B'length (2) + -- or else + -- ... + + -------------- + -- Arr_Attr -- + -------------- + + function Arr_Attr + (Arr : Entity_Id; + Nam : Name_Id; + Num : Int) return Node_Id + is + begin + return + Make_Attribute_Reference (Loc, + Attribute_Name => Nam, + Prefix => New_Reference_To (Arr, Loc), + Expressions => New_List (Make_Integer_Literal (Loc, Num))); + end Arr_Attr; + + ------------------------ + -- Component_Equality -- + ------------------------ + + function Component_Equality (Typ : Entity_Id) return Node_Id is + Test : Node_Id; + L, R : Node_Id; + + begin + -- if a(i1...) /= b(j1...) then return false; end if; + + L := + Make_Indexed_Component (Loc, + Prefix => Make_Identifier (Loc, Chars (A)), + Expressions => Index_List1); + + R := + Make_Indexed_Component (Loc, + Prefix => Make_Identifier (Loc, Chars (B)), + Expressions => Index_List2); + + Test := Expand_Composite_Equality + (Nod, Component_Type (Typ), L, R, Decls); + + -- If some (sub)component is an unchecked_union, the whole operation + -- will raise program error. + + if Nkind (Test) = N_Raise_Program_Error then + + -- This node is going to be inserted at a location where a + -- statement is expected: clear its Etype so analysis will set + -- it to the expected Standard_Void_Type. + + Set_Etype (Test, Empty); + return Test; + + else + return + Make_Implicit_If_Statement (Nod, + Condition => Make_Op_Not (Loc, Right_Opnd => Test), + Then_Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Standard_False, Loc)))); + end if; + end Component_Equality; + + ------------------ + -- Get_Arg_Type -- + ------------------ + + function Get_Arg_Type (N : Node_Id) return Entity_Id is + T : Entity_Id; + X : Node_Id; + + begin + T := Etype (N); + + if No (T) then + return Typ; + + else + T := Underlying_Type (T); + + X := First_Index (T); + while Present (X) loop + if Denotes_Discriminant (Type_Low_Bound (Etype (X))) + or else + Denotes_Discriminant (Type_High_Bound (Etype (X))) + then + T := Base_Type (T); + exit; + end if; + + Next_Index (X); + end loop; + + return T; + end if; + end Get_Arg_Type; + + -------------------------- + -- Handle_One_Dimension -- + --------------------------- + + function Handle_One_Dimension + (N : Int; + Index : Node_Id) return Node_Id + is + Need_Separate_Indexes : constant Boolean := + Ltyp /= Rtyp + or else not Is_Constrained (Ltyp); + -- If the index types are identical, and we are working with + -- constrained types, then we can use the same index for both + -- of the arrays. + + An : constant Entity_Id := Make_Temporary (Loc, 'A'); + + Bn : Entity_Id; + Index_T : Entity_Id; + Stm_List : List_Id; + Loop_Stm : Node_Id; + + begin + if N > Number_Dimensions (Ltyp) then + return Component_Equality (Ltyp); + end if; + + -- Case where we generate a loop + + Index_T := Base_Type (Etype (Index)); + + if Need_Separate_Indexes then + Bn := Make_Temporary (Loc, 'B'); + else + Bn := An; + end if; + + Append (New_Reference_To (An, Loc), Index_List1); + Append (New_Reference_To (Bn, Loc), Index_List2); + + Stm_List := New_List ( + Handle_One_Dimension (N + 1, Next_Index (Index))); + + if Need_Separate_Indexes then + + -- Generate guard for loop, followed by increments of indexes + + Append_To (Stm_List, + Make_Exit_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Reference_To (An, Loc), + Right_Opnd => Arr_Attr (A, Name_Last, N)))); + + Append_To (Stm_List, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (An, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Index_T, Loc), + Attribute_Name => Name_Succ, + Expressions => New_List (New_Reference_To (An, Loc))))); + + Append_To (Stm_List, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Bn, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Index_T, Loc), + Attribute_Name => Name_Succ, + Expressions => New_List (New_Reference_To (Bn, Loc))))); + end if; + + -- If separate indexes, we need a declare block for An and Bn, and a + -- loop without an iteration scheme. + + if Need_Separate_Indexes then + Loop_Stm := + Make_Implicit_Loop_Statement (Nod, Statements => Stm_List); + + return + Make_Block_Statement (Loc, + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => An, + Object_Definition => New_Reference_To (Index_T, Loc), + Expression => Arr_Attr (A, Name_First, N)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Bn, + Object_Definition => New_Reference_To (Index_T, Loc), + Expression => Arr_Attr (B, Name_First, N))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Loop_Stm))); + + -- If no separate indexes, return loop statement with explicit + -- iteration scheme on its own + + else + Loop_Stm := + Make_Implicit_Loop_Statement (Nod, + Statements => Stm_List, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => An, + Discrete_Subtype_Definition => + Arr_Attr (A, Name_Range, N)))); + return Loop_Stm; + end if; + end Handle_One_Dimension; + + ----------------------- + -- Test_Empty_Arrays -- + ----------------------- + + function Test_Empty_Arrays return Node_Id is + Alist : Node_Id; + Blist : Node_Id; + + Atest : Node_Id; + Btest : Node_Id; + + begin + Alist := Empty; + Blist := Empty; + for J in 1 .. Number_Dimensions (Ltyp) loop + Atest := + Make_Op_Eq (Loc, + Left_Opnd => Arr_Attr (A, Name_Length, J), + Right_Opnd => Make_Integer_Literal (Loc, 0)); + + Btest := + Make_Op_Eq (Loc, + Left_Opnd => Arr_Attr (B, Name_Length, J), + Right_Opnd => Make_Integer_Literal (Loc, 0)); + + if No (Alist) then + Alist := Atest; + Blist := Btest; + + else + Alist := + Make_Or_Else (Loc, + Left_Opnd => Relocate_Node (Alist), + Right_Opnd => Atest); + + Blist := + Make_Or_Else (Loc, + Left_Opnd => Relocate_Node (Blist), + Right_Opnd => Btest); + end if; + end loop; + + return + Make_And_Then (Loc, + Left_Opnd => Alist, + Right_Opnd => Blist); + end Test_Empty_Arrays; + + ----------------------------- + -- Test_Lengths_Correspond -- + ----------------------------- + + function Test_Lengths_Correspond return Node_Id is + Result : Node_Id; + Rtest : Node_Id; + + begin + Result := Empty; + for J in 1 .. Number_Dimensions (Ltyp) loop + Rtest := + Make_Op_Ne (Loc, + Left_Opnd => Arr_Attr (A, Name_Length, J), + Right_Opnd => Arr_Attr (B, Name_Length, J)); + + if No (Result) then + Result := Rtest; + else + Result := + Make_Or_Else (Loc, + Left_Opnd => Relocate_Node (Result), + Right_Opnd => Rtest); + end if; + end loop; + + return Result; + end Test_Lengths_Correspond; + + -- Start of processing for Expand_Array_Equality + + begin + Ltyp := Get_Arg_Type (Lhs); + Rtyp := Get_Arg_Type (Rhs); + + -- For now, if the argument types are not the same, go to the base type, + -- since the code assumes that the formals have the same type. This is + -- fixable in future ??? + + if Ltyp /= Rtyp then + Ltyp := Base_Type (Ltyp); + Rtyp := Base_Type (Rtyp); + pragma Assert (Ltyp = Rtyp); + end if; + + -- Build list of formals for function + + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => A, + Parameter_Type => New_Reference_To (Ltyp, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => B, + Parameter_Type => New_Reference_To (Rtyp, Loc))); + + Func_Name := Make_Temporary (Loc, 'E'); + + -- Build statement sequence for function + + Func_Body := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Func_Name, + Parameter_Specifications => Formals, + Result_Definition => New_Reference_To (Standard_Boolean, Loc)), + + Declarations => Decls, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + + Make_Implicit_If_Statement (Nod, + Condition => Test_Empty_Arrays, + Then_Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + New_Occurrence_Of (Standard_True, Loc)))), + + Make_Implicit_If_Statement (Nod, + Condition => Test_Lengths_Correspond, + Then_Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + New_Occurrence_Of (Standard_False, Loc)))), + + Handle_One_Dimension (1, First_Index (Ltyp)), + + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Standard_True, Loc))))); + + Set_Has_Completion (Func_Name, True); + Set_Is_Inlined (Func_Name); + + -- If the array type is distinct from the type of the arguments, it + -- is the full view of a private type. Apply an unchecked conversion + -- to insure that analysis of the call succeeds. + + declare + L, R : Node_Id; + + begin + L := Lhs; + R := Rhs; + + if No (Etype (Lhs)) + or else Base_Type (Etype (Lhs)) /= Base_Type (Ltyp) + then + L := OK_Convert_To (Ltyp, Lhs); + end if; + + if No (Etype (Rhs)) + or else Base_Type (Etype (Rhs)) /= Base_Type (Rtyp) + then + R := OK_Convert_To (Rtyp, Rhs); + end if; + + Actuals := New_List (L, R); + end; + + Append_To (Bodies, Func_Body); + + return + Make_Function_Call (Loc, + Name => New_Reference_To (Func_Name, Loc), + Parameter_Associations => Actuals); + end Expand_Array_Equality; + + ----------------------------- + -- Expand_Boolean_Operator -- + ----------------------------- + + -- Note that we first get the actual subtypes of the operands, since we + -- always want to deal with types that have bounds. + + procedure Expand_Boolean_Operator (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + + begin + -- Special case of bit packed array where both operands are known to be + -- properly aligned. In this case we use an efficient run time routine + -- to carry out the operation (see System.Bit_Ops). + + if Is_Bit_Packed_Array (Typ) + and then not Is_Possibly_Unaligned_Object (Left_Opnd (N)) + and then not Is_Possibly_Unaligned_Object (Right_Opnd (N)) + then + Expand_Packed_Boolean_Operator (N); + return; + end if; + + -- For the normal non-packed case, the general expansion is to build + -- function for carrying out the comparison (use Make_Boolean_Array_Op) + -- and then inserting it into the tree. The original operator node is + -- then rewritten as a call to this function. We also use this in the + -- packed case if either operand is a possibly unaligned object. + + declare + Loc : constant Source_Ptr := Sloc (N); + L : constant Node_Id := Relocate_Node (Left_Opnd (N)); + R : constant Node_Id := Relocate_Node (Right_Opnd (N)); + Func_Body : Node_Id; + Func_Name : Entity_Id; + + begin + Convert_To_Actual_Subtype (L); + Convert_To_Actual_Subtype (R); + Ensure_Defined (Etype (L), N); + Ensure_Defined (Etype (R), N); + Apply_Length_Check (R, Etype (L)); + + if Nkind (N) = N_Op_Xor then + Silly_Boolean_Array_Xor_Test (N, Etype (L)); + end if; + + if Nkind (Parent (N)) = N_Assignment_Statement + and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R) + then + Build_Boolean_Array_Proc_Call (Parent (N), L, R); + + elsif Nkind (Parent (N)) = N_Op_Not + and then Nkind (N) = N_Op_And + and then + Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R) + then + return; + else + + Func_Body := Make_Boolean_Array_Op (Etype (L), N); + Func_Name := Defining_Unit_Name (Specification (Func_Body)); + Insert_Action (N, Func_Body); + + -- Now rewrite the expression with a call + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (Func_Name, Loc), + Parameter_Associations => + New_List ( + L, + Make_Type_Conversion + (Loc, New_Reference_To (Etype (L), Loc), R)))); + + Analyze_And_Resolve (N, Typ); + end if; + end; + end Expand_Boolean_Operator; + + ------------------------------- + -- Expand_Composite_Equality -- + ------------------------------- + + -- This function is only called for comparing internal fields of composite + -- types when these fields are themselves composites. This is a special + -- case because it is not possible to respect normal Ada visibility rules. + + function Expand_Composite_Equality + (Nod : Node_Id; + Typ : Entity_Id; + Lhs : Node_Id; + Rhs : Node_Id; + Bodies : List_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Nod); + Full_Type : Entity_Id; + Prim : Elmt_Id; + Eq_Op : Entity_Id; + + begin + if Is_Private_Type (Typ) then + Full_Type := Underlying_Type (Typ); + else + Full_Type := Typ; + end if; + + -- Defense against malformed private types with no completion the error + -- will be diagnosed later by check_completion + + if No (Full_Type) then + return New_Reference_To (Standard_False, Loc); + end if; + + Full_Type := Base_Type (Full_Type); + + if Is_Array_Type (Full_Type) then + + -- If the operand is an elementary type other than a floating-point + -- type, then we can simply use the built-in block bitwise equality, + -- since the predefined equality operators always apply and bitwise + -- equality is fine for all these cases. + + if Is_Elementary_Type (Component_Type (Full_Type)) + and then not Is_Floating_Point_Type (Component_Type (Full_Type)) + then + return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs); + + -- For composite component types, and floating-point types, use the + -- expansion. This deals with tagged component types (where we use + -- the applicable equality routine) and floating-point, (where we + -- need to worry about negative zeroes), and also the case of any + -- composite type recursively containing such fields. + + else + return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Full_Type); + end if; + + elsif Is_Tagged_Type (Full_Type) then + + -- Call the primitive operation "=" of this type + + if Is_Class_Wide_Type (Full_Type) then + Full_Type := Root_Type (Full_Type); + end if; + + -- If this is derived from an untagged private type completed with a + -- tagged type, it does not have a full view, so we use the primitive + -- operations of the private type. This check should no longer be + -- necessary when these types receive their full views ??? + + if Is_Private_Type (Typ) + and then not Is_Tagged_Type (Typ) + and then not Is_Controlled (Typ) + and then Is_Derived_Type (Typ) + and then No (Full_View (Typ)) + then + Prim := First_Elmt (Collect_Primitive_Operations (Typ)); + else + Prim := First_Elmt (Primitive_Operations (Full_Type)); + end if; + + loop + Eq_Op := Node (Prim); + exit when Chars (Eq_Op) = Name_Op_Eq + and then Etype (First_Formal (Eq_Op)) = + Etype (Next_Formal (First_Formal (Eq_Op))) + and then Base_Type (Etype (Eq_Op)) = Standard_Boolean; + Next_Elmt (Prim); + pragma Assert (Present (Prim)); + end loop; + + Eq_Op := Node (Prim); + + return + Make_Function_Call (Loc, + Name => New_Reference_To (Eq_Op, Loc), + Parameter_Associations => + New_List + (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs), + Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs))); + + elsif Is_Record_Type (Full_Type) then + Eq_Op := TSS (Full_Type, TSS_Composite_Equality); + + if Present (Eq_Op) then + if Etype (First_Formal (Eq_Op)) /= Full_Type then + + -- Inherited equality from parent type. Convert the actuals to + -- match signature of operation. + + declare + T : constant Entity_Id := Etype (First_Formal (Eq_Op)); + + begin + return + Make_Function_Call (Loc, + Name => New_Reference_To (Eq_Op, Loc), + Parameter_Associations => + New_List (OK_Convert_To (T, Lhs), + OK_Convert_To (T, Rhs))); + end; + + else + -- Comparison between Unchecked_Union components + + if Is_Unchecked_Union (Full_Type) then + declare + Lhs_Type : Node_Id := Full_Type; + Rhs_Type : Node_Id := Full_Type; + Lhs_Discr_Val : Node_Id; + Rhs_Discr_Val : Node_Id; + + begin + -- Lhs subtype + + if Nkind (Lhs) = N_Selected_Component then + Lhs_Type := Etype (Entity (Selector_Name (Lhs))); + end if; + + -- Rhs subtype + + if Nkind (Rhs) = N_Selected_Component then + Rhs_Type := Etype (Entity (Selector_Name (Rhs))); + end if; + + -- Lhs of the composite equality + + if Is_Constrained (Lhs_Type) then + + -- Since the enclosing record type can never be an + -- Unchecked_Union (this code is executed for records + -- that do not have variants), we may reference its + -- discriminant(s). + + if Nkind (Lhs) = N_Selected_Component + and then Has_Per_Object_Constraint ( + Entity (Selector_Name (Lhs))) + then + Lhs_Discr_Val := + Make_Selected_Component (Loc, + Prefix => Prefix (Lhs), + Selector_Name => + New_Copy ( + Get_Discriminant_Value ( + First_Discriminant (Lhs_Type), + Lhs_Type, + Stored_Constraint (Lhs_Type)))); + + else + Lhs_Discr_Val := New_Copy ( + Get_Discriminant_Value ( + First_Discriminant (Lhs_Type), + Lhs_Type, + Stored_Constraint (Lhs_Type))); + + end if; + else + -- It is not possible to infer the discriminant since + -- the subtype is not constrained. + + return + Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction); + end if; + + -- Rhs of the composite equality + + if Is_Constrained (Rhs_Type) then + if Nkind (Rhs) = N_Selected_Component + and then Has_Per_Object_Constraint ( + Entity (Selector_Name (Rhs))) + then + Rhs_Discr_Val := + Make_Selected_Component (Loc, + Prefix => Prefix (Rhs), + Selector_Name => + New_Copy ( + Get_Discriminant_Value ( + First_Discriminant (Rhs_Type), + Rhs_Type, + Stored_Constraint (Rhs_Type)))); + + else + Rhs_Discr_Val := New_Copy ( + Get_Discriminant_Value ( + First_Discriminant (Rhs_Type), + Rhs_Type, + Stored_Constraint (Rhs_Type))); + + end if; + else + return + Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction); + end if; + + -- Call the TSS equality function with the inferred + -- discriminant values. + + return + Make_Function_Call (Loc, + Name => New_Reference_To (Eq_Op, Loc), + Parameter_Associations => New_List ( + Lhs, + Rhs, + Lhs_Discr_Val, + Rhs_Discr_Val)); + end; + + else + return + Make_Function_Call (Loc, + Name => New_Reference_To (Eq_Op, Loc), + Parameter_Associations => New_List (Lhs, Rhs)); + end if; + end if; + + elsif Ada_Version >= Ada_2012 then + + -- if no TSS has been created for the type, check whether there is + -- a primitive equality declared for it. If it is abstract replace + -- the call with an explicit raise (AI05-0123). + + declare + Prim : Elmt_Id; + + begin + Prim := First_Elmt (Collect_Primitive_Operations (Full_Type)); + while Present (Prim) loop + + -- Locate primitive equality with the right signature + + if Chars (Node (Prim)) = Name_Op_Eq + and then Etype (First_Formal (Node (Prim))) = + Etype (Next_Formal (First_Formal (Node (Prim)))) + and then Etype (Node (Prim)) = Standard_Boolean + then + if Is_Abstract_Subprogram (Node (Prim)) then + return + Make_Raise_Program_Error (Loc, + Reason => PE_Explicit_Raise); + else + return + Make_Function_Call (Loc, + Name => New_Reference_To (Node (Prim), Loc), + Parameter_Associations => New_List (Lhs, Rhs)); + end if; + end if; + + Next_Elmt (Prim); + end loop; + end; + + -- Use predefined equality iff no user-defined primitive exists + + return Make_Op_Eq (Loc, Lhs, Rhs); + + else + return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies); + end if; + + else + -- If not array or record type, it is predefined equality. + + return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs); + end if; + end Expand_Composite_Equality; + + ------------------------ + -- Expand_Concatenate -- + ------------------------ + + procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id) is + Loc : constant Source_Ptr := Sloc (Cnode); + + Atyp : constant Entity_Id := Base_Type (Etype (Cnode)); + -- Result type of concatenation + + Ctyp : constant Entity_Id := Base_Type (Component_Type (Etype (Cnode))); + -- Component type. Elements of this component type can appear as one + -- of the operands of concatenation as well as arrays. + + Istyp : constant Entity_Id := Etype (First_Index (Atyp)); + -- Index subtype + + Ityp : constant Entity_Id := Base_Type (Istyp); + -- Index type. This is the base type of the index subtype, and is used + -- for all computed bounds (which may be out of range of Istyp in the + -- case of null ranges). + + Artyp : Entity_Id; + -- This is the type we use to do arithmetic to compute the bounds and + -- lengths of operands. The choice of this type is a little subtle and + -- is discussed in a separate section at the start of the body code. + + Concatenation_Error : exception; + -- Raised if concatenation is sure to raise a CE + + Result_May_Be_Null : Boolean := True; + -- Reset to False if at least one operand is encountered which is known + -- at compile time to be non-null. Used for handling the special case + -- of setting the high bound to the last operand high bound for a null + -- result, thus ensuring a proper high bound in the super-flat case. + + N : constant Nat := List_Length (Opnds); + -- Number of concatenation operands including possibly null operands + + NN : Nat := 0; + -- Number of operands excluding any known to be null, except that the + -- last operand is always retained, in case it provides the bounds for + -- a null result. + + Opnd : Node_Id; + -- Current operand being processed in the loop through operands. After + -- this loop is complete, always contains the last operand (which is not + -- the same as Operands (NN), since null operands are skipped). + + -- Arrays describing the operands, only the first NN entries of each + -- array are set (NN < N when we exclude known null operands). + + Is_Fixed_Length : array (1 .. N) of Boolean; + -- True if length of corresponding operand known at compile time + + Operands : array (1 .. N) of Node_Id; + -- Set to the corresponding entry in the Opnds list (but note that null + -- operands are excluded, so not all entries in the list are stored). + + Fixed_Length : array (1 .. N) of Uint; + -- Set to length of operand. Entries in this array are set only if the + -- corresponding entry in Is_Fixed_Length is True. + + Opnd_Low_Bound : array (1 .. N) of Node_Id; + -- Set to lower bound of operand. Either an integer literal in the case + -- where the bound is known at compile time, else actual lower bound. + -- The operand low bound is of type Ityp. + + Var_Length : array (1 .. N) of Entity_Id; + -- Set to an entity of type Natural that contains the length of an + -- operand whose length is not known at compile time. Entries in this + -- array are set only if the corresponding entry in Is_Fixed_Length + -- is False. The entity is of type Artyp. + + Aggr_Length : array (0 .. N) of Node_Id; + -- The J'th entry in an expression node that represents the total length + -- of operands 1 through J. It is either an integer literal node, or a + -- reference to a constant entity with the right value, so it is fine + -- to just do a Copy_Node to get an appropriate copy. The extra zero'th + -- entry always is set to zero. The length is of type Artyp. + + Low_Bound : Node_Id; + -- A tree node representing the low bound of the result (of type Ityp). + -- This is either an integer literal node, or an identifier reference to + -- a constant entity initialized to the appropriate value. + + Last_Opnd_High_Bound : Node_Id; + -- A tree node representing the high bound of the last operand. This + -- need only be set if the result could be null. It is used for the + -- special case of setting the right high bound for a null result. + -- This is of type Ityp. + + High_Bound : Node_Id; + -- A tree node representing the high bound of the result (of type Ityp) + + Result : Node_Id; + -- Result of the concatenation (of type Ityp) + + Actions : constant List_Id := New_List; + -- Collect actions to be inserted if Save_Space is False + + Save_Space : Boolean; + pragma Warnings (Off, Save_Space); + -- Set to True if we are saving generated code space by calling routines + -- in packages System.Concat_n. + + Known_Non_Null_Operand_Seen : Boolean; + -- Set True during generation of the assignments of operands into + -- result once an operand known to be non-null has been seen. + + function Make_Artyp_Literal (Val : Nat) return Node_Id; + -- This function makes an N_Integer_Literal node that is returned in + -- analyzed form with the type set to Artyp. Importantly this literal + -- is not flagged as static, so that if we do computations with it that + -- result in statically detected out of range conditions, we will not + -- generate error messages but instead warning messages. + + function To_Artyp (X : Node_Id) return Node_Id; + -- Given a node of type Ityp, returns the corresponding value of type + -- Artyp. For non-enumeration types, this is a plain integer conversion. + -- For enum types, the Pos of the value is returned. + + function To_Ityp (X : Node_Id) return Node_Id; + -- The inverse function (uses Val in the case of enumeration types) + + ------------------------ + -- Make_Artyp_Literal -- + ------------------------ + + function Make_Artyp_Literal (Val : Nat) return Node_Id is + Result : constant Node_Id := Make_Integer_Literal (Loc, Val); + begin + Set_Etype (Result, Artyp); + Set_Analyzed (Result, True); + Set_Is_Static_Expression (Result, False); + return Result; + end Make_Artyp_Literal; + + -------------- + -- To_Artyp -- + -------------- + + function To_Artyp (X : Node_Id) return Node_Id is + begin + if Ityp = Base_Type (Artyp) then + return X; + + elsif Is_Enumeration_Type (Ityp) then + return + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ityp, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List (X)); + + else + return Convert_To (Artyp, X); + end if; + end To_Artyp; + + ------------- + -- To_Ityp -- + ------------- + + function To_Ityp (X : Node_Id) return Node_Id is + begin + if Is_Enumeration_Type (Ityp) then + return + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ityp, Loc), + Attribute_Name => Name_Val, + Expressions => New_List (X)); + + -- Case where we will do a type conversion + + else + if Ityp = Base_Type (Artyp) then + return X; + else + return Convert_To (Ityp, X); + end if; + end if; + end To_Ityp; + + -- Local Declarations + + Opnd_Typ : Entity_Id; + Ent : Entity_Id; + Len : Uint; + J : Nat; + Clen : Node_Id; + Set : Boolean; + + begin + -- Choose an appropriate computational type + + -- We will be doing calculations of lengths and bounds in this routine + -- and computing one from the other in some cases, e.g. getting the high + -- bound by adding the length-1 to the low bound. + + -- We can't just use the index type, or even its base type for this + -- purpose for two reasons. First it might be an enumeration type which + -- is not suitable for computations of any kind, and second it may + -- simply not have enough range. For example if the index type is + -- -128..+127 then lengths can be up to 256, which is out of range of + -- the type. + + -- For enumeration types, we can simply use Standard_Integer, this is + -- sufficient since the actual number of enumeration literals cannot + -- possibly exceed the range of integer (remember we will be doing the + -- arithmetic with POS values, not representation values). + + if Is_Enumeration_Type (Ityp) then + Artyp := Standard_Integer; + + -- If index type is Positive, we use the standard unsigned type, to give + -- more room on the top of the range, obviating the need for an overflow + -- check when creating the upper bound. This is needed to avoid junk + -- overflow checks in the common case of String types. + + -- ??? Disabled for now + + -- elsif Istyp = Standard_Positive then + -- Artyp := Standard_Unsigned; + + -- For modular types, we use a 32-bit modular type for types whose size + -- is in the range 1-31 bits. For 32-bit unsigned types, we use the + -- identity type, and for larger unsigned types we use 64-bits. + + elsif Is_Modular_Integer_Type (Ityp) then + if RM_Size (Ityp) < RM_Size (Standard_Unsigned) then + Artyp := Standard_Unsigned; + elsif RM_Size (Ityp) = RM_Size (Standard_Unsigned) then + Artyp := Ityp; + else + Artyp := RTE (RE_Long_Long_Unsigned); + end if; + + -- Similar treatment for signed types + + else + if RM_Size (Ityp) < RM_Size (Standard_Integer) then + Artyp := Standard_Integer; + elsif RM_Size (Ityp) = RM_Size (Standard_Integer) then + Artyp := Ityp; + else + Artyp := Standard_Long_Long_Integer; + end if; + end if; + + -- Supply dummy entry at start of length array + + Aggr_Length (0) := Make_Artyp_Literal (0); + + -- Go through operands setting up the above arrays + + J := 1; + while J <= N loop + Opnd := Remove_Head (Opnds); + Opnd_Typ := Etype (Opnd); + + -- The parent got messed up when we put the operands in a list, + -- so now put back the proper parent for the saved operand, that + -- is to say the concatenation node, to make sure that each operand + -- is seen as a subexpression, e.g. if actions must be inserted. + + Set_Parent (Opnd, Cnode); + + -- Set will be True when we have setup one entry in the array + + Set := False; + + -- Singleton element (or character literal) case + + if Base_Type (Opnd_Typ) = Ctyp then + NN := NN + 1; + Operands (NN) := Opnd; + Is_Fixed_Length (NN) := True; + Fixed_Length (NN) := Uint_1; + Result_May_Be_Null := False; + + -- Set low bound of operand (no need to set Last_Opnd_High_Bound + -- since we know that the result cannot be null). + + Opnd_Low_Bound (NN) := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Istyp, Loc), + Attribute_Name => Name_First); + + Set := True; + + -- String literal case (can only occur for strings of course) + + elsif Nkind (Opnd) = N_String_Literal then + Len := String_Literal_Length (Opnd_Typ); + + if Len /= 0 then + Result_May_Be_Null := False; + end if; + + -- Capture last operand high bound if result could be null + + if J = N and then Result_May_Be_Null then + Last_Opnd_High_Bound := + Make_Op_Add (Loc, + Left_Opnd => + New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)), + Right_Opnd => Make_Integer_Literal (Loc, 1)); + end if; + + -- Skip null string literal + + if J < N and then Len = 0 then + goto Continue; + end if; + + NN := NN + 1; + Operands (NN) := Opnd; + Is_Fixed_Length (NN) := True; + + -- Set length and bounds + + Fixed_Length (NN) := Len; + + Opnd_Low_Bound (NN) := + New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)); + + Set := True; + + -- All other cases + + else + -- Check constrained case with known bounds + + if Is_Constrained (Opnd_Typ) then + declare + Index : constant Node_Id := First_Index (Opnd_Typ); + Indx_Typ : constant Entity_Id := Etype (Index); + Lo : constant Node_Id := Type_Low_Bound (Indx_Typ); + Hi : constant Node_Id := Type_High_Bound (Indx_Typ); + + begin + -- Fixed length constrained array type with known at compile + -- time bounds is last case of fixed length operand. + + if Compile_Time_Known_Value (Lo) + and then + Compile_Time_Known_Value (Hi) + then + declare + Loval : constant Uint := Expr_Value (Lo); + Hival : constant Uint := Expr_Value (Hi); + Len : constant Uint := + UI_Max (Hival - Loval + 1, Uint_0); + + begin + if Len > 0 then + Result_May_Be_Null := False; + end if; + + -- Capture last operand bound if result could be null + + if J = N and then Result_May_Be_Null then + Last_Opnd_High_Bound := + Convert_To (Ityp, + Make_Integer_Literal (Loc, + Intval => Expr_Value (Hi))); + end if; + + -- Exclude null length case unless last operand + + if J < N and then Len = 0 then + goto Continue; + end if; + + NN := NN + 1; + Operands (NN) := Opnd; + Is_Fixed_Length (NN) := True; + Fixed_Length (NN) := Len; + + Opnd_Low_Bound (NN) := To_Ityp ( + Make_Integer_Literal (Loc, + Intval => Expr_Value (Lo))); + + Set := True; + end; + end if; + end; + end if; + + -- All cases where the length is not known at compile time, or the + -- special case of an operand which is known to be null but has a + -- lower bound other than 1 or is other than a string type. + + if not Set then + NN := NN + 1; + + -- Capture operand bounds + + Opnd_Low_Bound (NN) := + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr (Opnd, Name_Req => True), + Attribute_Name => Name_First); + + if J = N and Result_May_Be_Null then + Last_Opnd_High_Bound := + Convert_To (Ityp, + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr (Opnd, Name_Req => True), + Attribute_Name => Name_Last)); + end if; + + -- Capture length of operand in entity + + Operands (NN) := Opnd; + Is_Fixed_Length (NN) := False; + + Var_Length (NN) := Make_Temporary (Loc, 'L'); + + Append_To (Actions, + Make_Object_Declaration (Loc, + Defining_Identifier => Var_Length (NN), + Constant_Present => True, + + Object_Definition => + New_Occurrence_Of (Artyp, Loc), + + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr (Opnd, Name_Req => True), + Attribute_Name => Name_Length))); + end if; + end if; + + -- Set next entry in aggregate length array + + -- For first entry, make either integer literal for fixed length + -- or a reference to the saved length for variable length. + + if NN = 1 then + if Is_Fixed_Length (1) then + Aggr_Length (1) := + Make_Integer_Literal (Loc, + Intval => Fixed_Length (1)); + else + Aggr_Length (1) := + New_Reference_To (Var_Length (1), Loc); + end if; + + -- If entry is fixed length and only fixed lengths so far, make + -- appropriate new integer literal adding new length. + + elsif Is_Fixed_Length (NN) + and then Nkind (Aggr_Length (NN - 1)) = N_Integer_Literal + then + Aggr_Length (NN) := + Make_Integer_Literal (Loc, + Intval => Fixed_Length (NN) + Intval (Aggr_Length (NN - 1))); + + -- All other cases, construct an addition node for the length and + -- create an entity initialized to this length. + + else + Ent := Make_Temporary (Loc, 'L'); + + if Is_Fixed_Length (NN) then + Clen := Make_Integer_Literal (Loc, Fixed_Length (NN)); + else + Clen := New_Reference_To (Var_Length (NN), Loc); + end if; + + Append_To (Actions, + Make_Object_Declaration (Loc, + Defining_Identifier => Ent, + Constant_Present => True, + + Object_Definition => + New_Occurrence_Of (Artyp, Loc), + + Expression => + Make_Op_Add (Loc, + Left_Opnd => New_Copy (Aggr_Length (NN - 1)), + Right_Opnd => Clen))); + + Aggr_Length (NN) := Make_Identifier (Loc, Chars => Chars (Ent)); + end if; + + <> + J := J + 1; + end loop; + + -- If we have only skipped null operands, return the last operand + + if NN = 0 then + Result := Opnd; + goto Done; + end if; + + -- If we have only one non-null operand, return it and we are done. + -- There is one case in which this cannot be done, and that is when + -- the sole operand is of the element type, in which case it must be + -- converted to an array, and the easiest way of doing that is to go + -- through the normal general circuit. + + if NN = 1 + and then Base_Type (Etype (Operands (1))) /= Ctyp + then + Result := Operands (1); + goto Done; + end if; + + -- Cases where we have a real concatenation + + -- Next step is to find the low bound for the result array that we + -- will allocate. The rules for this are in (RM 4.5.6(5-7)). + + -- If the ultimate ancestor of the index subtype is a constrained array + -- definition, then the lower bound is that of the index subtype as + -- specified by (RM 4.5.3(6)). + + -- The right test here is to go to the root type, and then the ultimate + -- ancestor is the first subtype of this root type. + + if Is_Constrained (First_Subtype (Root_Type (Atyp))) then + Low_Bound := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (First_Subtype (Root_Type (Atyp)), Loc), + Attribute_Name => Name_First); + + -- If the first operand in the list has known length we know that + -- the lower bound of the result is the lower bound of this operand. + + elsif Is_Fixed_Length (1) then + Low_Bound := Opnd_Low_Bound (1); + + -- OK, we don't know the lower bound, we have to build a horrible + -- expression actions node of the form + + -- if Cond1'Length /= 0 then + -- Opnd1 low bound + -- else + -- if Opnd2'Length /= 0 then + -- Opnd2 low bound + -- else + -- ... + + -- The nesting ends either when we hit an operand whose length is known + -- at compile time, or on reaching the last operand, whose low bound we + -- take unconditionally whether or not it is null. It's easiest to do + -- this with a recursive procedure: + + else + declare + function Get_Known_Bound (J : Nat) return Node_Id; + -- Returns the lower bound determined by operands J .. NN + + --------------------- + -- Get_Known_Bound -- + --------------------- + + function Get_Known_Bound (J : Nat) return Node_Id is + begin + if Is_Fixed_Length (J) or else J = NN then + return New_Copy (Opnd_Low_Bound (J)); + + else + return + Make_Conditional_Expression (Loc, + Expressions => New_List ( + + Make_Op_Ne (Loc, + Left_Opnd => New_Reference_To (Var_Length (J), Loc), + Right_Opnd => Make_Integer_Literal (Loc, 0)), + + New_Copy (Opnd_Low_Bound (J)), + Get_Known_Bound (J + 1))); + end if; + end Get_Known_Bound; + + begin + Ent := Make_Temporary (Loc, 'L'); + + Append_To (Actions, + Make_Object_Declaration (Loc, + Defining_Identifier => Ent, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Ityp, Loc), + Expression => Get_Known_Bound (1))); + + Low_Bound := New_Reference_To (Ent, Loc); + end; + end if; + + -- Now we can safely compute the upper bound, normally + -- Low_Bound + Length - 1. + + High_Bound := + To_Ityp ( + Make_Op_Add (Loc, + Left_Opnd => To_Artyp (New_Copy (Low_Bound)), + Right_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => New_Copy (Aggr_Length (NN)), + Right_Opnd => Make_Artyp_Literal (1)))); + + -- Note that calculation of the high bound may cause overflow in some + -- very weird cases, so in the general case we need an overflow check on + -- the high bound. We can avoid this for the common case of string types + -- and other types whose index is Positive, since we chose a wider range + -- for the arithmetic type. + + if Istyp /= Standard_Positive then + Activate_Overflow_Check (High_Bound); + end if; + + -- Handle the exceptional case where the result is null, in which case + -- case the bounds come from the last operand (so that we get the proper + -- bounds if the last operand is super-flat). + + if Result_May_Be_Null then + High_Bound := + Make_Conditional_Expression (Loc, + Expressions => New_List ( + Make_Op_Eq (Loc, + Left_Opnd => New_Copy (Aggr_Length (NN)), + Right_Opnd => Make_Artyp_Literal (0)), + Last_Opnd_High_Bound, + High_Bound)); + end if; + + -- Here is where we insert the saved up actions + + Insert_Actions (Cnode, Actions, Suppress => All_Checks); + + -- Now we construct an array object with appropriate bounds. We mark + -- the target as internal to prevent useless initialization when + -- Initialize_Scalars is enabled. + + Ent := Make_Temporary (Loc, 'S'); + Set_Is_Internal (Ent); + + -- If the bound is statically known to be out of range, we do not want + -- to abort, we want a warning and a runtime constraint error. Note that + -- we have arranged that the result will not be treated as a static + -- constant, so we won't get an illegality during this insertion. + + Insert_Action (Cnode, + Make_Object_Declaration (Loc, + Defining_Identifier => Ent, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Atyp, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Low_Bound => Low_Bound, + High_Bound => High_Bound))))), + Suppress => All_Checks); + + -- If the result of the concatenation appears as the initializing + -- expression of an object declaration, we can just rename the + -- result, rather than copying it. + + Set_OK_To_Rename (Ent); + + -- Catch the static out of range case now + + if Raises_Constraint_Error (High_Bound) then + raise Concatenation_Error; + end if; + + -- Now we will generate the assignments to do the actual concatenation + + -- There is one case in which we will not do this, namely when all the + -- following conditions are met: + + -- The result type is Standard.String + + -- There are nine or fewer retained (non-null) operands + + -- The optimization level is -O0 + + -- The corresponding System.Concat_n.Str_Concat_n routine is + -- available in the run time. + + -- The debug flag gnatd.c is not set + + -- If all these conditions are met then we generate a call to the + -- relevant concatenation routine. The purpose of this is to avoid + -- undesirable code bloat at -O0. + + if Atyp = Standard_String + and then NN in 2 .. 9 + and then (Opt.Optimization_Level = 0 or else Debug_Flag_Dot_CC) + and then not Debug_Flag_Dot_C + then + declare + RR : constant array (Nat range 2 .. 9) of RE_Id := + (RE_Str_Concat_2, + RE_Str_Concat_3, + RE_Str_Concat_4, + RE_Str_Concat_5, + RE_Str_Concat_6, + RE_Str_Concat_7, + RE_Str_Concat_8, + RE_Str_Concat_9); + + begin + if RTE_Available (RR (NN)) then + declare + Opnds : constant List_Id := + New_List (New_Occurrence_Of (Ent, Loc)); + + begin + for J in 1 .. NN loop + if Is_List_Member (Operands (J)) then + Remove (Operands (J)); + end if; + + if Base_Type (Etype (Operands (J))) = Ctyp then + Append_To (Opnds, + Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, 1)), + Expression => Operands (J))))); + + else + Append_To (Opnds, Operands (J)); + end if; + end loop; + + Insert_Action (Cnode, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RR (NN)), Loc), + Parameter_Associations => Opnds)); + + Result := New_Reference_To (Ent, Loc); + goto Done; + end; + end if; + end; + end if; + + -- Not special case so generate the assignments + + Known_Non_Null_Operand_Seen := False; + + for J in 1 .. NN loop + declare + Lo : constant Node_Id := + Make_Op_Add (Loc, + Left_Opnd => To_Artyp (New_Copy (Low_Bound)), + Right_Opnd => Aggr_Length (J - 1)); + + Hi : constant Node_Id := + Make_Op_Add (Loc, + Left_Opnd => To_Artyp (New_Copy (Low_Bound)), + Right_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => Aggr_Length (J), + Right_Opnd => Make_Artyp_Literal (1))); + + begin + -- Singleton case, simple assignment + + if Base_Type (Etype (Operands (J))) = Ctyp then + Known_Non_Null_Operand_Seen := True; + Insert_Action (Cnode, + Make_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (Ent, Loc), + Expressions => New_List (To_Ityp (Lo))), + Expression => Operands (J)), + Suppress => All_Checks); + + -- Array case, slice assignment, skipped when argument is fixed + -- length and known to be null. + + elsif (not Is_Fixed_Length (J)) or else (Fixed_Length (J) > 0) then + declare + Assign : Node_Id := + Make_Assignment_Statement (Loc, + Name => + Make_Slice (Loc, + Prefix => + New_Occurrence_Of (Ent, Loc), + Discrete_Range => + Make_Range (Loc, + Low_Bound => To_Ityp (Lo), + High_Bound => To_Ityp (Hi))), + Expression => Operands (J)); + begin + if Is_Fixed_Length (J) then + Known_Non_Null_Operand_Seen := True; + + elsif not Known_Non_Null_Operand_Seen then + + -- Here if operand length is not statically known and no + -- operand known to be non-null has been processed yet. + -- If operand length is 0, we do not need to perform the + -- assignment, and we must avoid the evaluation of the + -- high bound of the slice, since it may underflow if the + -- low bound is Ityp'First. + + Assign := + Make_Implicit_If_Statement (Cnode, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => + New_Occurrence_Of (Var_Length (J), Loc), + Right_Opnd => Make_Integer_Literal (Loc, 0)), + Then_Statements => + New_List (Assign)); + end if; + + Insert_Action (Cnode, Assign, Suppress => All_Checks); + end; + end if; + end; + end loop; + + -- Finally we build the result, which is a reference to the array object + + Result := New_Reference_To (Ent, Loc); + + <> + Rewrite (Cnode, Result); + Analyze_And_Resolve (Cnode, Atyp); + + exception + when Concatenation_Error => + + -- Kill warning generated for the declaration of the static out of + -- range high bound, and instead generate a Constraint_Error with + -- an appropriate specific message. + + Kill_Dead_Code (Declaration_Node (Entity (High_Bound))); + Apply_Compile_Time_Constraint_Error + (N => Cnode, + Msg => "concatenation result upper bound out of range?", + Reason => CE_Range_Check_Failed); + -- Set_Etype (Cnode, Atyp); + end Expand_Concatenate; + + ------------------------ + -- Expand_N_Allocator -- + ------------------------ + + procedure Expand_N_Allocator (N : Node_Id) is + PtrT : constant Entity_Id := Etype (N); + Dtyp : constant Entity_Id := Available_View (Designated_Type (PtrT)); + Etyp : constant Entity_Id := Etype (Expression (N)); + Loc : constant Source_Ptr := Sloc (N); + Desig : Entity_Id; + Temp : Entity_Id; + Nod : Node_Id; + + procedure Complete_Coextension_Finalization; + -- Generate finalization calls for all nested coextensions of N. This + -- routine may allocate list controllers if necessary. + + procedure Rewrite_Coextension (N : Node_Id); + -- Static coextensions have the same lifetime as the entity they + -- constrain. Such occurrences can be rewritten as aliased objects + -- and their unrestricted access used instead of the coextension. + + function Size_In_Storage_Elements (E : Entity_Id) return Node_Id; + -- Given a constrained array type E, returns a node representing the + -- code to compute the size in storage elements for the given type. + -- This is done without using the attribute (which malfunctions for + -- large sizes ???) + + --------------------------------------- + -- Complete_Coextension_Finalization -- + --------------------------------------- + + procedure Complete_Coextension_Finalization is + Coext : Node_Id; + Coext_Elmt : Elmt_Id; + Flist : Node_Id; + Ref : Node_Id; + + function Inside_A_Return_Statement (N : Node_Id) return Boolean; + -- Determine whether node N is part of a return statement + + function Needs_Initialization_Call (N : Node_Id) return Boolean; + -- Determine whether node N is a subtype indicator allocator which + -- acts a coextension. Such coextensions need initialization. + + ------------------------------- + -- Inside_A_Return_Statement -- + ------------------------------- + + function Inside_A_Return_Statement (N : Node_Id) return Boolean is + P : Node_Id; + + begin + P := Parent (N); + while Present (P) loop + if Nkind_In + (P, N_Extended_Return_Statement, N_Simple_Return_Statement) + then + return True; + + -- Stop the traversal when we reach a subprogram body + + elsif Nkind (P) = N_Subprogram_Body then + return False; + end if; + + P := Parent (P); + end loop; + + return False; + end Inside_A_Return_Statement; + + ------------------------------- + -- Needs_Initialization_Call -- + ------------------------------- + + function Needs_Initialization_Call (N : Node_Id) return Boolean is + Obj_Decl : Node_Id; + + begin + if Nkind (N) = N_Explicit_Dereference + and then Nkind (Prefix (N)) = N_Identifier + and then Nkind (Parent (Entity (Prefix (N)))) = + N_Object_Declaration + then + Obj_Decl := Parent (Entity (Prefix (N))); + + return + Present (Expression (Obj_Decl)) + and then Nkind (Expression (Obj_Decl)) = N_Allocator + and then Nkind (Expression (Expression (Obj_Decl))) /= + N_Qualified_Expression; + end if; + + return False; + end Needs_Initialization_Call; + + -- Start of processing for Complete_Coextension_Finalization + + begin + -- When a coextension root is inside a return statement, we need to + -- use the finalization chain of the function's scope. This does not + -- apply for controlled named access types because in those cases we + -- can use the finalization chain of the type itself. + + if Inside_A_Return_Statement (N) + and then + (Ekind (PtrT) = E_Anonymous_Access_Type + or else + (Ekind (PtrT) = E_Access_Type + and then No (Associated_Final_Chain (PtrT)))) + then + declare + Decl : Node_Id; + Outer_S : Entity_Id; + S : Entity_Id; + + begin + S := Current_Scope; + while Present (S) and then S /= Standard_Standard loop + if Ekind (S) = E_Function then + Outer_S := Scope (S); + + -- Retrieve the declaration of the body + + Decl := + Parent + (Parent + (Corresponding_Body (Parent (Parent (S))))); + exit; + end if; + + S := Scope (S); + end loop; + + -- Push the scope of the function body since we are inserting + -- the list before the body, but we are currently in the body + -- itself. Override the finalization list of PtrT since the + -- finalization context is now different. + + Push_Scope (Outer_S); + Build_Final_List (Decl, PtrT); + Pop_Scope; + end; + + -- The root allocator may not be controlled, but it still needs a + -- finalization list for all nested coextensions. + + elsif No (Associated_Final_Chain (PtrT)) then + Build_Final_List (N, PtrT); + end if; + + Flist := + Make_Selected_Component (Loc, + Prefix => + New_Reference_To (Associated_Final_Chain (PtrT), Loc), + Selector_Name => Make_Identifier (Loc, Name_F)); + + Coext_Elmt := First_Elmt (Coextensions (N)); + while Present (Coext_Elmt) loop + Coext := Node (Coext_Elmt); + + -- Generate: + -- typ! (coext.all) + + if Nkind (Coext) = N_Identifier then + Ref := + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Reference_To (Etype (Coext), Loc), + Expression => + Make_Explicit_Dereference (Loc, + Prefix => New_Copy_Tree (Coext))); + else + Ref := New_Copy_Tree (Coext); + end if; + + -- No initialization call if not allowed + + Check_Restriction (No_Default_Initialization, N); + + if not Restriction_Active (No_Default_Initialization) then + + -- Generate: + -- initialize (Ref) + -- attach_to_final_list (Ref, Flist, 2) + + if Needs_Initialization_Call (Coext) then + Insert_Actions (N, + Make_Init_Call ( + Ref => Ref, + Typ => Etype (Coext), + Flist_Ref => Flist, + With_Attach => Make_Integer_Literal (Loc, Uint_2))); + + -- Generate: + -- attach_to_final_list (Ref, Flist, 2) + + else + Insert_Action (N, + Make_Attach_Call ( + Obj_Ref => Ref, + Flist_Ref => New_Copy_Tree (Flist), + With_Attach => Make_Integer_Literal (Loc, Uint_2))); + end if; + end if; + + Next_Elmt (Coext_Elmt); + end loop; + end Complete_Coextension_Finalization; + + ------------------------- + -- Rewrite_Coextension -- + ------------------------- + + procedure Rewrite_Coextension (N : Node_Id) is + Temp : constant Node_Id := Make_Temporary (Loc, 'C'); + + -- Generate: + -- Cnn : aliased Etyp; + + Decl : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (Etyp, Loc)); + Nod : Node_Id; + + begin + if Nkind (Expression (N)) = N_Qualified_Expression then + Set_Expression (Decl, Expression (Expression (N))); + end if; + + -- Find the proper insertion node for the declaration + + Nod := Parent (N); + while Present (Nod) loop + exit when Nkind (Nod) in N_Statement_Other_Than_Procedure_Call + or else Nkind (Nod) = N_Procedure_Call_Statement + or else Nkind (Nod) in N_Declaration; + Nod := Parent (Nod); + end loop; + + Insert_Before (Nod, Decl); + Analyze (Decl); + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Temp, Loc), + Attribute_Name => Name_Unrestricted_Access)); + + Analyze_And_Resolve (N, PtrT); + end Rewrite_Coextension; + + ------------------------------ + -- Size_In_Storage_Elements -- + ------------------------------ + + function Size_In_Storage_Elements (E : Entity_Id) return Node_Id is + begin + -- Logically this just returns E'Max_Size_In_Storage_Elements. + -- However, the reason for the existence of this function is + -- to construct a test for sizes too large, which means near the + -- 32-bit limit on a 32-bit machine, and precisely the trouble + -- is that we get overflows when sizes are greater than 2**31. + + -- So what we end up doing for array types is to use the expression: + + -- number-of-elements * component_type'Max_Size_In_Storage_Elements + + -- which avoids this problem. All this is a bit bogus, but it does + -- mean we catch common cases of trying to allocate arrays that + -- are too large, and which in the absence of a check results in + -- undetected chaos ??? + + declare + Len : Node_Id; + Res : Node_Id; + + begin + for J in 1 .. Number_Dimensions (E) loop + Len := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (E, Loc), + Attribute_Name => Name_Length, + Expressions => New_List ( + Make_Integer_Literal (Loc, J))); + + if J = 1 then + Res := Len; + + else + Res := + Make_Op_Multiply (Loc, + Left_Opnd => Res, + Right_Opnd => Len); + end if; + end loop; + + return + Make_Op_Multiply (Loc, + Left_Opnd => Len, + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Component_Type (E), Loc), + Attribute_Name => Name_Max_Size_In_Storage_Elements)); + end; + end Size_In_Storage_Elements; + + -- Start of processing for Expand_N_Allocator + + begin + -- RM E.2.3(22). We enforce that the expected type of an allocator + -- shall not be a remote access-to-class-wide-limited-private type + + -- Why is this being done at expansion time, seems clearly wrong ??? + + Validate_Remote_Access_To_Class_Wide_Type (N); + + -- Set the Storage Pool + + Set_Storage_Pool (N, Associated_Storage_Pool (Root_Type (PtrT))); + + if Present (Storage_Pool (N)) then + if Is_RTE (Storage_Pool (N), RE_SS_Pool) then + if VM_Target = No_VM then + Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); + end if; + + elsif Is_Class_Wide_Type (Etype (Storage_Pool (N))) then + Set_Procedure_To_Call (N, RTE (RE_Allocate_Any)); + + else + Set_Procedure_To_Call (N, + Find_Prim_Op (Etype (Storage_Pool (N)), Name_Allocate)); + end if; + end if; + + -- Under certain circumstances we can replace an allocator by an access + -- to statically allocated storage. The conditions, as noted in AARM + -- 3.10 (10c) are as follows: + + -- Size and initial value is known at compile time + -- Access type is access-to-constant + + -- The allocator is not part of a constraint on a record component, + -- because in that case the inserted actions are delayed until the + -- record declaration is fully analyzed, which is too late for the + -- analysis of the rewritten allocator. + + if Is_Access_Constant (PtrT) + and then Nkind (Expression (N)) = N_Qualified_Expression + and then Compile_Time_Known_Value (Expression (Expression (N))) + and then Size_Known_At_Compile_Time (Etype (Expression + (Expression (N)))) + and then not Is_Record_Type (Current_Scope) + then + -- Here we can do the optimization. For the allocator + + -- new x'(y) + + -- We insert an object declaration + + -- Tnn : aliased x := y; + + -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is + -- marked as requiring static allocation. + + Temp := Make_Temporary (Loc, 'T', Expression (Expression (N))); + Desig := Subtype_Mark (Expression (N)); + + -- If context is constrained, use constrained subtype directly, + -- so that the constant is not labelled as having a nominally + -- unconstrained subtype. + + if Entity (Desig) = Base_Type (Dtyp) then + Desig := New_Occurrence_Of (Dtyp, Loc); + end if; + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Aliased_Present => True, + Constant_Present => Is_Access_Constant (PtrT), + Object_Definition => Desig, + Expression => Expression (Expression (N)))); + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Temp, Loc), + Attribute_Name => Name_Unrestricted_Access)); + + Analyze_And_Resolve (N, PtrT); + + -- We set the variable as statically allocated, since we don't want + -- it going on the stack of the current procedure! + + Set_Is_Statically_Allocated (Temp); + return; + end if; + + -- Same if the allocator is an access discriminant for a local object: + -- instead of an allocator we create a local value and constrain the + -- enclosing object with the corresponding access attribute. + + if Is_Static_Coextension (N) then + Rewrite_Coextension (N); + return; + end if; + + -- The current allocator creates an object which may contain nested + -- coextensions. Use the current allocator's finalization list to + -- generate finalization call for all nested coextensions. + + if Is_Coextension_Root (N) then + Complete_Coextension_Finalization; + end if; + + -- Check for size too large, we do this because the back end misses + -- proper checks here and can generate rubbish allocation calls when + -- we are near the limit. We only do this for the 32-bit address case + -- since that is from a practical point of view where we see a problem. + + if System_Address_Size = 32 + and then not Storage_Checks_Suppressed (PtrT) + and then not Storage_Checks_Suppressed (Dtyp) + and then not Storage_Checks_Suppressed (Etyp) + then + -- The check we want to generate should look like + + -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then + -- raise Storage_Error; + -- end if; + + -- where 3.5 gigabytes is a constant large enough to accommodate any + -- reasonable request for. But we can't do it this way because at + -- least at the moment we don't compute this attribute right, and + -- can silently give wrong results when the result gets large. Since + -- this is all about large results, that's bad, so instead we only + -- apply the check for constrained arrays, and manually compute the + -- value of the attribute ??? + + if Is_Array_Type (Etyp) and then Is_Constrained (Etyp) then + Insert_Action (N, + Make_Raise_Storage_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => Size_In_Storage_Elements (Etyp), + Right_Opnd => + Make_Integer_Literal (Loc, + Intval => Uint_7 * (Uint_2 ** 29))), + Reason => SE_Object_Too_Large)); + end if; + end if; + + -- Handle case of qualified expression (other than optimization above) + -- First apply constraint checks, because the bounds or discriminants + -- in the aggregate might not match the subtype mark in the allocator. + + if Nkind (Expression (N)) = N_Qualified_Expression then + Apply_Constraint_Check + (Expression (Expression (N)), Etype (Expression (N))); + + Expand_Allocator_Expression (N); + return; + end if; + + -- If the allocator is for a type which requires initialization, and + -- there is no initial value (i.e. operand is a subtype indication + -- rather than a qualified expression), then we must generate a call to + -- the initialization routine using an expressions action node: + + -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn] + + -- Here ptr_T is the pointer type for the allocator, and T is the + -- subtype of the allocator. A special case arises if the designated + -- type of the access type is a task or contains tasks. In this case + -- the call to Init (Temp.all ...) is replaced by code that ensures + -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block + -- for details). In addition, if the type T is a task T, then the + -- first argument to Init must be converted to the task record type. + + declare + T : constant Entity_Id := Entity (Expression (N)); + Init : Entity_Id; + Arg1 : Node_Id; + Args : List_Id; + Decls : List_Id; + Decl : Node_Id; + Discr : Elmt_Id; + Flist : Node_Id; + Temp_Decl : Node_Id; + Temp_Type : Entity_Id; + Attach_Level : Uint; + + begin + if No_Initialization (N) then + null; + + -- Case of no initialization procedure present + + elsif not Has_Non_Null_Base_Init_Proc (T) then + + -- Case of simple initialization required + + if Needs_Simple_Initialization (T) then + Check_Restriction (No_Default_Initialization, N); + Rewrite (Expression (N), + Make_Qualified_Expression (Loc, + Subtype_Mark => New_Occurrence_Of (T, Loc), + Expression => Get_Simple_Init_Val (T, N))); + + Analyze_And_Resolve (Expression (Expression (N)), T); + Analyze_And_Resolve (Expression (N), T); + Set_Paren_Count (Expression (Expression (N)), 1); + Expand_N_Allocator (N); + + -- No initialization required + + else + null; + end if; + + -- Case of initialization procedure present, must be called + + else + Check_Restriction (No_Default_Initialization, N); + + if not Restriction_Active (No_Default_Initialization) then + Init := Base_Init_Proc (T); + Nod := N; + Temp := Make_Temporary (Loc, 'P'); + + -- Construct argument list for the initialization routine call + + Arg1 := + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Temp, Loc)); + Set_Assignment_OK (Arg1); + Temp_Type := PtrT; + + -- The initialization procedure expects a specific type. if the + -- context is access to class wide, indicate that the object + -- being allocated has the right specific type. + + if Is_Class_Wide_Type (Dtyp) then + Arg1 := Unchecked_Convert_To (T, Arg1); + end if; + + -- If designated type is a concurrent type or if it is private + -- type whose definition is a concurrent type, the first + -- argument in the Init routine has to be unchecked conversion + -- to the corresponding record type. If the designated type is + -- a derived type, we also convert the argument to its root + -- type. + + if Is_Concurrent_Type (T) then + Arg1 := + Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1); + + elsif Is_Private_Type (T) + and then Present (Full_View (T)) + and then Is_Concurrent_Type (Full_View (T)) + then + Arg1 := + Unchecked_Convert_To + (Corresponding_Record_Type (Full_View (T)), Arg1); + + elsif Etype (First_Formal (Init)) /= Base_Type (T) then + declare + Ftyp : constant Entity_Id := Etype (First_Formal (Init)); + begin + Arg1 := OK_Convert_To (Etype (Ftyp), Arg1); + Set_Etype (Arg1, Ftyp); + end; + end if; + + Args := New_List (Arg1); + + -- For the task case, pass the Master_Id of the access type as + -- the value of the _Master parameter, and _Chain as the value + -- of the _Chain parameter (_Chain will be defined as part of + -- the generated code for the allocator). + + -- In Ada 2005, the context may be a function that returns an + -- anonymous access type. In that case the Master_Id has been + -- created when expanding the function declaration. + + if Has_Task (T) then + if No (Master_Id (Base_Type (PtrT))) then + + -- The designated type was an incomplete type, and the + -- access type did not get expanded. Salvage it now. + + if not Restriction_Active (No_Task_Hierarchy) then + pragma Assert (Present (Parent (Base_Type (PtrT)))); + Expand_N_Full_Type_Declaration + (Parent (Base_Type (PtrT))); + end if; + end if; + + -- If the context of the allocator is a declaration or an + -- assignment, we can generate a meaningful image for it, + -- even though subsequent assignments might remove the + -- connection between task and entity. We build this image + -- when the left-hand side is a simple variable, a simple + -- indexed assignment or a simple selected component. + + if Nkind (Parent (N)) = N_Assignment_Statement then + declare + Nam : constant Node_Id := Name (Parent (N)); + + begin + if Is_Entity_Name (Nam) then + Decls := + Build_Task_Image_Decls + (Loc, + New_Occurrence_Of + (Entity (Nam), Sloc (Nam)), T); + + elsif Nkind_In + (Nam, N_Indexed_Component, N_Selected_Component) + and then Is_Entity_Name (Prefix (Nam)) + then + Decls := + Build_Task_Image_Decls + (Loc, Nam, Etype (Prefix (Nam))); + else + Decls := Build_Task_Image_Decls (Loc, T, T); + end if; + end; + + elsif Nkind (Parent (N)) = N_Object_Declaration then + Decls := + Build_Task_Image_Decls + (Loc, Defining_Identifier (Parent (N)), T); + + else + Decls := Build_Task_Image_Decls (Loc, T, T); + end if; + + if Restriction_Active (No_Task_Hierarchy) then + Append_To (Args, + New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc)); + else + Append_To (Args, + New_Reference_To + (Master_Id (Base_Type (Root_Type (PtrT))), Loc)); + end if; + + Append_To (Args, Make_Identifier (Loc, Name_uChain)); + + Decl := Last (Decls); + Append_To (Args, + New_Occurrence_Of (Defining_Identifier (Decl), Loc)); + + -- Has_Task is false, Decls not used + + else + Decls := No_List; + end if; + + -- Add discriminants if discriminated type + + declare + Dis : Boolean := False; + Typ : Entity_Id; + + begin + if Has_Discriminants (T) then + Dis := True; + Typ := T; + + elsif Is_Private_Type (T) + and then Present (Full_View (T)) + and then Has_Discriminants (Full_View (T)) + then + Dis := True; + Typ := Full_View (T); + end if; + + if Dis then + + -- If the allocated object will be constrained by the + -- default values for discriminants, then build a subtype + -- with those defaults, and change the allocated subtype + -- to that. Note that this happens in fewer cases in Ada + -- 2005 (AI-363). + + if not Is_Constrained (Typ) + and then Present (Discriminant_Default_Value + (First_Discriminant (Typ))) + and then (Ada_Version < Ada_2005 + or else + not Has_Constrained_Partial_View (Typ)) + then + Typ := Build_Default_Subtype (Typ, N); + Set_Expression (N, New_Reference_To (Typ, Loc)); + end if; + + Discr := First_Elmt (Discriminant_Constraint (Typ)); + while Present (Discr) loop + Nod := Node (Discr); + Append (New_Copy_Tree (Node (Discr)), Args); + + -- AI-416: when the discriminant constraint is an + -- anonymous access type make sure an accessibility + -- check is inserted if necessary (3.10.2(22.q/2)) + + if Ada_Version >= Ada_2005 + and then + Ekind (Etype (Nod)) = E_Anonymous_Access_Type + then + Apply_Accessibility_Check + (Nod, Typ, Insert_Node => Nod); + end if; + + Next_Elmt (Discr); + end loop; + end if; + end; + + -- We set the allocator as analyzed so that when we analyze the + -- expression actions node, we do not get an unwanted recursive + -- expansion of the allocator expression. + + Set_Analyzed (N, True); + Nod := Relocate_Node (N); + + -- Here is the transformation: + -- input: new T + -- output: Temp : constant ptr_T := new T; + -- Init (Temp.all, ...); + -- Attach_To_Final_List (Finalizable (Temp.all)); + -- Initialize (Finalizable (Temp.all)); + + -- Here ptr_T is the pointer type for the allocator, and is the + -- subtype of the allocator. + + Temp_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Constant_Present => True, + Object_Definition => New_Reference_To (Temp_Type, Loc), + Expression => Nod); + + Set_Assignment_OK (Temp_Decl); + Insert_Action (N, Temp_Decl, Suppress => All_Checks); + + -- If the designated type is a task type or contains tasks, + -- create block to activate created tasks, and insert + -- declaration for Task_Image variable ahead of call. + + if Has_Task (T) then + declare + L : constant List_Id := New_List; + Blk : Node_Id; + begin + Build_Task_Allocate_Block (L, Nod, Args); + Blk := Last (L); + Insert_List_Before (First (Declarations (Blk)), Decls); + Insert_Actions (N, L); + end; + + else + Insert_Action (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Init, Loc), + Parameter_Associations => Args)); + end if; + + if Needs_Finalization (T) then + + -- Postpone the generation of a finalization call for the + -- current allocator if it acts as a coextension. + + if Is_Dynamic_Coextension (N) then + if No (Coextensions (N)) then + Set_Coextensions (N, New_Elmt_List); + end if; + + Append_Elmt (New_Copy_Tree (Arg1), Coextensions (N)); + + else + Flist := + Get_Allocator_Final_List (N, Base_Type (T), PtrT); + + -- Anonymous access types created for access parameters + -- are attached to an explicitly constructed controller, + -- which ensures that they can be finalized properly, + -- even if their deallocation might not happen. The list + -- associated with the controller is doubly-linked. For + -- other anonymous access types, the object may end up + -- on the global final list which is singly-linked. + -- Work needed for access discriminants in Ada 2005 ??? + + if Ekind (PtrT) = E_Anonymous_Access_Type then + Attach_Level := Uint_1; + else + Attach_Level := Uint_2; + end if; + + Insert_Actions (N, + Make_Init_Call ( + Ref => New_Copy_Tree (Arg1), + Typ => T, + Flist_Ref => Flist, + With_Attach => Make_Integer_Literal (Loc, + Intval => Attach_Level))); + end if; + end if; + + Rewrite (N, New_Reference_To (Temp, Loc)); + Analyze_And_Resolve (N, PtrT); + end if; + end if; + end; + + -- Ada 2005 (AI-251): If the allocator is for a class-wide interface + -- object that has been rewritten as a reference, we displace "this" + -- to reference properly its secondary dispatch table. + + if Nkind (N) = N_Identifier + and then Is_Interface (Dtyp) + then + Displace_Allocator_Pointer (N); + end if; + + exception + when RE_Not_Available => + return; + end Expand_N_Allocator; + + ----------------------- + -- Expand_N_And_Then -- + ----------------------- + + procedure Expand_N_And_Then (N : Node_Id) + renames Expand_Short_Circuit_Operator; + + ------------------------------ + -- Expand_N_Case_Expression -- + ------------------------------ + + procedure Expand_N_Case_Expression (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Cstmt : Node_Id; + Tnn : Entity_Id; + Pnn : Entity_Id; + Actions : List_Id; + Ttyp : Entity_Id; + Alt : Node_Id; + Fexp : Node_Id; + + begin + -- We expand + + -- case X is when A => AX, when B => BX ... + + -- to + + -- do + -- Tnn : typ; + -- case X is + -- when A => + -- Tnn := AX; + -- when B => + -- Tnn := BX; + -- ... + -- end case; + -- in Tnn end; + + -- However, this expansion is wrong for limited types, and also + -- wrong for unconstrained types (since the bounds may not be the + -- same in all branches). Furthermore it involves an extra copy + -- for large objects. So we take care of this by using the following + -- modified expansion for non-scalar types: + + -- do + -- type Pnn is access all typ; + -- Tnn : Pnn; + -- case X is + -- when A => + -- T := AX'Unrestricted_Access; + -- when B => + -- T := BX'Unrestricted_Access; + -- ... + -- end case; + -- in Tnn.all end; + + Cstmt := + Make_Case_Statement (Loc, + Expression => Expression (N), + Alternatives => New_List); + + Actions := New_List; + + -- Scalar case + + if Is_Scalar_Type (Typ) then + Ttyp := Typ; + + else + Pnn := Make_Temporary (Loc, 'P'); + Append_To (Actions, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Pnn, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Reference_To (Typ, Loc)))); + Ttyp := Pnn; + end if; + + Tnn := Make_Temporary (Loc, 'T'); + Append_To (Actions, + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Object_Definition => New_Occurrence_Of (Ttyp, Loc))); + + -- Now process the alternatives + + Alt := First (Alternatives (N)); + while Present (Alt) loop + declare + Aexp : Node_Id := Expression (Alt); + Aloc : constant Source_Ptr := Sloc (Aexp); + + begin + if not Is_Scalar_Type (Typ) then + Aexp := + Make_Attribute_Reference (Aloc, + Prefix => Relocate_Node (Aexp), + Attribute_Name => Name_Unrestricted_Access); + end if; + + Append_To + (Alternatives (Cstmt), + Make_Case_Statement_Alternative (Sloc (Alt), + Discrete_Choices => Discrete_Choices (Alt), + Statements => New_List ( + Make_Assignment_Statement (Aloc, + Name => New_Occurrence_Of (Tnn, Loc), + Expression => Aexp)))); + end; + + Next (Alt); + end loop; + + Append_To (Actions, Cstmt); + + -- Construct and return final expression with actions + + if Is_Scalar_Type (Typ) then + Fexp := New_Occurrence_Of (Tnn, Loc); + else + Fexp := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Tnn, Loc)); + end if; + + Rewrite (N, + Make_Expression_With_Actions (Loc, + Expression => Fexp, + Actions => Actions)); + + Analyze_And_Resolve (N, Typ); + end Expand_N_Case_Expression; + + ------------------------------------- + -- Expand_N_Conditional_Expression -- + ------------------------------------- + + -- Deal with limited types and expression actions + + procedure Expand_N_Conditional_Expression (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Cond : constant Node_Id := First (Expressions (N)); + Thenx : constant Node_Id := Next (Cond); + Elsex : constant Node_Id := Next (Thenx); + Typ : constant Entity_Id := Etype (N); + + Cnn : Entity_Id; + Decl : Node_Id; + New_If : Node_Id; + New_N : Node_Id; + P_Decl : Node_Id; + Expr : Node_Id; + Actions : List_Id; + + begin + -- Fold at compile time if condition known. We have already folded + -- static conditional expressions, but it is possible to fold any + -- case in which the condition is known at compile time, even though + -- the result is non-static. + + -- Note that we don't do the fold of such cases in Sem_Elab because + -- it can cause infinite loops with the expander adding a conditional + -- expression, and Sem_Elab circuitry removing it repeatedly. + + if Compile_Time_Known_Value (Cond) then + if Is_True (Expr_Value (Cond)) then + Expr := Thenx; + Actions := Then_Actions (N); + else + Expr := Elsex; + Actions := Else_Actions (N); + end if; + + Remove (Expr); + + if Present (Actions) then + + -- If we are not allowed to use Expression_With_Actions, just + -- skip the optimization, it is not critical for correctness. + + if not Use_Expression_With_Actions then + goto Skip_Optimization; + end if; + + Rewrite (N, + Make_Expression_With_Actions (Loc, + Expression => Relocate_Node (Expr), + Actions => Actions)); + Analyze_And_Resolve (N, Typ); + + else + Rewrite (N, Relocate_Node (Expr)); + end if; + + -- Note that the result is never static (legitimate cases of static + -- conditional expressions were folded in Sem_Eval). + + Set_Is_Static_Expression (N, False); + return; + end if; + + <> + + -- If the type is limited or unconstrained, we expand as follows to + -- avoid any possibility of improper copies. + + -- Note: it may be possible to avoid this special processing if the + -- back end uses its own mechanisms for handling by-reference types ??? + + -- type Ptr is access all Typ; + -- Cnn : Ptr; + -- if cond then + -- <> + -- Cnn := then-expr'Unrestricted_Access; + -- else + -- <> + -- Cnn := else-expr'Unrestricted_Access; + -- end if; + + -- and replace the conditional expression by a reference to Cnn.all. + + -- This special case can be skipped if the back end handles limited + -- types properly and ensures that no incorrect copies are made. + + if Is_By_Reference_Type (Typ) + and then not Back_End_Handles_Limited_Types + then + Cnn := Make_Temporary (Loc, 'C', N); + + P_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'A'), + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Reference_To (Typ, Loc))); + + Insert_Action (N, P_Decl); + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Cnn, + Object_Definition => + New_Occurrence_Of (Defining_Identifier (P_Decl), Loc)); + + New_If := + Make_Implicit_If_Statement (N, + Condition => Relocate_Node (Cond), + + Then_Statements => New_List ( + Make_Assignment_Statement (Sloc (Thenx), + Name => New_Occurrence_Of (Cnn, Sloc (Thenx)), + Expression => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Unrestricted_Access, + Prefix => Relocate_Node (Thenx)))), + + Else_Statements => New_List ( + Make_Assignment_Statement (Sloc (Elsex), + Name => New_Occurrence_Of (Cnn, Sloc (Elsex)), + Expression => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Unrestricted_Access, + Prefix => Relocate_Node (Elsex))))); + + New_N := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Cnn, Loc)); + + -- For other types, we only need to expand if there are other actions + -- associated with either branch. + + elsif Present (Then_Actions (N)) or else Present (Else_Actions (N)) then + + -- We have two approaches to handling this. If we are allowed to use + -- N_Expression_With_Actions, then we can just wrap the actions into + -- the appropriate expression. + + if Use_Expression_With_Actions then + if Present (Then_Actions (N)) then + Rewrite (Thenx, + Make_Expression_With_Actions (Sloc (Thenx), + Actions => Then_Actions (N), + Expression => Relocate_Node (Thenx))); + Set_Then_Actions (N, No_List); + Analyze_And_Resolve (Thenx, Typ); + end if; + + if Present (Else_Actions (N)) then + Rewrite (Elsex, + Make_Expression_With_Actions (Sloc (Elsex), + Actions => Else_Actions (N), + Expression => Relocate_Node (Elsex))); + Set_Else_Actions (N, No_List); + Analyze_And_Resolve (Elsex, Typ); + end if; + + return; + + -- if we can't use N_Expression_With_Actions nodes, then we insert + -- the following sequence of actions (using Insert_Actions): + + -- Cnn : typ; + -- if cond then + -- <> + -- Cnn := then-expr; + -- else + -- <> + -- Cnn := else-expr + -- end if; + + -- and replace the conditional expression by a reference to Cnn + + else + Cnn := Make_Temporary (Loc, 'C', N); + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Cnn, + Object_Definition => New_Occurrence_Of (Typ, Loc)); + + New_If := + Make_Implicit_If_Statement (N, + Condition => Relocate_Node (Cond), + + Then_Statements => New_List ( + Make_Assignment_Statement (Sloc (Thenx), + Name => New_Occurrence_Of (Cnn, Sloc (Thenx)), + Expression => Relocate_Node (Thenx))), + + Else_Statements => New_List ( + Make_Assignment_Statement (Sloc (Elsex), + Name => New_Occurrence_Of (Cnn, Sloc (Elsex)), + Expression => Relocate_Node (Elsex)))); + + Set_Assignment_OK (Name (First (Then_Statements (New_If)))); + Set_Assignment_OK (Name (First (Else_Statements (New_If)))); + + New_N := New_Occurrence_Of (Cnn, Loc); + end if; + + -- If no actions then no expansion needed, gigi will handle it using + -- the same approach as a C conditional expression. + + else + return; + end if; + + -- Fall through here for either the limited expansion, or the case of + -- inserting actions for non-limited types. In both these cases, we must + -- move the SLOC of the parent If statement to the newly created one and + -- change it to the SLOC of the expression which, after expansion, will + -- correspond to what is being evaluated. + + if Present (Parent (N)) + and then Nkind (Parent (N)) = N_If_Statement + then + Set_Sloc (New_If, Sloc (Parent (N))); + Set_Sloc (Parent (N), Loc); + end if; + + -- Make sure Then_Actions and Else_Actions are appropriately moved + -- to the new if statement. + + if Present (Then_Actions (N)) then + Insert_List_Before + (First (Then_Statements (New_If)), Then_Actions (N)); + end if; + + if Present (Else_Actions (N)) then + Insert_List_Before + (First (Else_Statements (New_If)), Else_Actions (N)); + end if; + + Insert_Action (N, Decl); + Insert_Action (N, New_If); + Rewrite (N, New_N); + Analyze_And_Resolve (N, Typ); + end Expand_N_Conditional_Expression; + + ----------------------------------- + -- Expand_N_Explicit_Dereference -- + ----------------------------------- + + procedure Expand_N_Explicit_Dereference (N : Node_Id) is + begin + -- Insert explicit dereference call for the checked storage pool case + + Insert_Dereference_Action (Prefix (N)); + end Expand_N_Explicit_Dereference; + + ----------------- + -- Expand_N_In -- + ----------------- + + procedure Expand_N_In (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Restyp : constant Entity_Id := Etype (N); + Lop : constant Node_Id := Left_Opnd (N); + Rop : constant Node_Id := Right_Opnd (N); + Static : constant Boolean := Is_OK_Static_Expression (N); + + Ltyp : Entity_Id; + Rtyp : Entity_Id; + + procedure Expand_Set_Membership; + -- For each choice we create a simple equality or membership test. + -- The whole membership is rewritten connecting these with OR ELSE. + + --------------------------- + -- Expand_Set_Membership -- + --------------------------- + + procedure Expand_Set_Membership is + Alt : Node_Id; + Res : Node_Id; + + function Make_Cond (Alt : Node_Id) return Node_Id; + -- If the alternative is a subtype mark, create a simple membership + -- test. Otherwise create an equality test for it. + + --------------- + -- Make_Cond -- + --------------- + + function Make_Cond (Alt : Node_Id) return Node_Id is + Cond : Node_Id; + L : constant Node_Id := New_Copy (Lop); + R : constant Node_Id := Relocate_Node (Alt); + + begin + if (Is_Entity_Name (Alt) and then Is_Type (Entity (Alt))) + or else Nkind (Alt) = N_Range + then + Cond := + Make_In (Sloc (Alt), + Left_Opnd => L, + Right_Opnd => R); + else + Cond := + Make_Op_Eq (Sloc (Alt), + Left_Opnd => L, + Right_Opnd => R); + end if; + + return Cond; + end Make_Cond; + + -- Start of processing for Expand_Set_Membership + + begin + Alt := Last (Alternatives (N)); + Res := Make_Cond (Alt); + + Prev (Alt); + while Present (Alt) loop + Res := + Make_Or_Else (Sloc (Alt), + Left_Opnd => Make_Cond (Alt), + Right_Opnd => Res); + Prev (Alt); + end loop; + + Rewrite (N, Res); + Analyze_And_Resolve (N, Standard_Boolean); + end Expand_Set_Membership; + + procedure Substitute_Valid_Check; + -- Replaces node N by Lop'Valid. This is done when we have an explicit + -- test for the left operand being in range of its subtype. + + ---------------------------- + -- Substitute_Valid_Check -- + ---------------------------- + + procedure Substitute_Valid_Check is + begin + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Lop), + Attribute_Name => Name_Valid)); + + Analyze_And_Resolve (N, Restyp); + + Error_Msg_N ("?explicit membership test may be optimized away", N); + Error_Msg_N -- CODEFIX + ("\?use ''Valid attribute instead", N); + return; + end Substitute_Valid_Check; + + -- Start of processing for Expand_N_In + + begin + -- If set membership case, expand with separate procedure + + if Present (Alternatives (N)) then + Remove_Side_Effects (Lop); + Expand_Set_Membership; + return; + end if; + + -- Not set membership, proceed with expansion + + Ltyp := Etype (Left_Opnd (N)); + Rtyp := Etype (Right_Opnd (N)); + + -- Check case of explicit test for an expression in range of its + -- subtype. This is suspicious usage and we replace it with a 'Valid + -- test and give a warning. For floating point types however, this is a + -- standard way to check for finite numbers, and using 'Valid would + -- typically be a pessimization. Also skip this test for predicated + -- types, since it is perfectly reasonable to check if a value meets + -- its predicate. + + if Is_Scalar_Type (Ltyp) + and then not Is_Floating_Point_Type (Ltyp) + and then Nkind (Rop) in N_Has_Entity + and then Ltyp = Entity (Rop) + and then Comes_From_Source (N) + and then VM_Target = No_VM + and then not (Is_Discrete_Type (Ltyp) + and then Present (Predicate_Function (Ltyp))) + then + Substitute_Valid_Check; + return; + end if; + + -- Do validity check on operands + + if Validity_Checks_On and Validity_Check_Operands then + Ensure_Valid (Left_Opnd (N)); + Validity_Check_Range (Right_Opnd (N)); + end if; + + -- Case of explicit range + + if Nkind (Rop) = N_Range then + declare + Lo : constant Node_Id := Low_Bound (Rop); + Hi : constant Node_Id := High_Bound (Rop); + + Lo_Orig : constant Node_Id := Original_Node (Lo); + Hi_Orig : constant Node_Id := Original_Node (Hi); + + Lcheck : Compare_Result; + Ucheck : Compare_Result; + + Warn1 : constant Boolean := + Constant_Condition_Warnings + and then Comes_From_Source (N) + and then not In_Instance; + -- This must be true for any of the optimization warnings, we + -- clearly want to give them only for source with the flag on. We + -- also skip these warnings in an instance since it may be the + -- case that different instantiations have different ranges. + + Warn2 : constant Boolean := + Warn1 + and then Nkind (Original_Node (Rop)) = N_Range + and then Is_Integer_Type (Etype (Lo)); + -- For the case where only one bound warning is elided, we also + -- insist on an explicit range and an integer type. The reason is + -- that the use of enumeration ranges including an end point is + -- common, as is the use of a subtype name, one of whose bounds is + -- the same as the type of the expression. + + begin + -- If test is explicit x'First .. x'Last, replace by valid check + + -- Could use some individual comments for this complex test ??? + + if Is_Scalar_Type (Ltyp) + and then Nkind (Lo_Orig) = N_Attribute_Reference + and then Attribute_Name (Lo_Orig) = Name_First + and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity + and then Entity (Prefix (Lo_Orig)) = Ltyp + and then Nkind (Hi_Orig) = N_Attribute_Reference + and then Attribute_Name (Hi_Orig) = Name_Last + and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity + and then Entity (Prefix (Hi_Orig)) = Ltyp + and then Comes_From_Source (N) + and then VM_Target = No_VM + then + Substitute_Valid_Check; + goto Leave; + end if; + + -- If bounds of type are known at compile time, and the end points + -- are known at compile time and identical, this is another case + -- for substituting a valid test. We only do this for discrete + -- types, since it won't arise in practice for float types. + + if Comes_From_Source (N) + and then Is_Discrete_Type (Ltyp) + and then Compile_Time_Known_Value (Type_High_Bound (Ltyp)) + and then Compile_Time_Known_Value (Type_Low_Bound (Ltyp)) + and then Compile_Time_Known_Value (Lo) + and then Compile_Time_Known_Value (Hi) + and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi) + and then Expr_Value (Type_Low_Bound (Ltyp)) = Expr_Value (Lo) + + -- Kill warnings in instances, since they may be cases where we + -- have a test in the generic that makes sense with some types + -- and not with other types. + + and then not In_Instance + then + Substitute_Valid_Check; + goto Leave; + end if; + + -- If we have an explicit range, do a bit of optimization based on + -- range analysis (we may be able to kill one or both checks). + + Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => False); + Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => False); + + -- If either check is known to fail, replace result by False since + -- the other check does not matter. Preserve the static flag for + -- legality checks, because we are constant-folding beyond RM 4.9. + + if Lcheck = LT or else Ucheck = GT then + if Warn1 then + Error_Msg_N ("?range test optimized away", N); + Error_Msg_N ("\?value is known to be out of range", N); + end if; + + Rewrite (N, New_Reference_To (Standard_False, Loc)); + Analyze_And_Resolve (N, Restyp); + Set_Is_Static_Expression (N, Static); + goto Leave; + + -- If both checks are known to succeed, replace result by True, + -- since we know we are in range. + + elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then + if Warn1 then + Error_Msg_N ("?range test optimized away", N); + Error_Msg_N ("\?value is known to be in range", N); + end if; + + Rewrite (N, New_Reference_To (Standard_True, Loc)); + Analyze_And_Resolve (N, Restyp); + Set_Is_Static_Expression (N, Static); + goto Leave; + + -- If lower bound check succeeds and upper bound check is not + -- known to succeed or fail, then replace the range check with + -- a comparison against the upper bound. + + elsif Lcheck in Compare_GE then + if Warn2 and then not In_Instance then + Error_Msg_N ("?lower bound test optimized away", Lo); + Error_Msg_N ("\?value is known to be in range", Lo); + end if; + + Rewrite (N, + Make_Op_Le (Loc, + Left_Opnd => Lop, + Right_Opnd => High_Bound (Rop))); + Analyze_And_Resolve (N, Restyp); + goto Leave; + + -- If upper bound check succeeds and lower bound check is not + -- known to succeed or fail, then replace the range check with + -- a comparison against the lower bound. + + elsif Ucheck in Compare_LE then + if Warn2 and then not In_Instance then + Error_Msg_N ("?upper bound test optimized away", Hi); + Error_Msg_N ("\?value is known to be in range", Hi); + end if; + + Rewrite (N, + Make_Op_Ge (Loc, + Left_Opnd => Lop, + Right_Opnd => Low_Bound (Rop))); + Analyze_And_Resolve (N, Restyp); + goto Leave; + end if; + + -- We couldn't optimize away the range check, but there is one + -- more issue. If we are checking constant conditionals, then we + -- see if we can determine the outcome assuming everything is + -- valid, and if so give an appropriate warning. + + if Warn1 and then not Assume_No_Invalid_Values then + Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => True); + Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => True); + + -- Result is out of range for valid value + + if Lcheck = LT or else Ucheck = GT then + Error_Msg_N + ("?value can only be in range if it is invalid", N); + + -- Result is in range for valid value + + elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then + Error_Msg_N + ("?value can only be out of range if it is invalid", N); + + -- Lower bound check succeeds if value is valid + + elsif Warn2 and then Lcheck in Compare_GE then + Error_Msg_N + ("?lower bound check only fails if it is invalid", Lo); + + -- Upper bound check succeeds if value is valid + + elsif Warn2 and then Ucheck in Compare_LE then + Error_Msg_N + ("?upper bound check only fails for invalid values", Hi); + end if; + end if; + end; + + -- For all other cases of an explicit range, nothing to be done + + goto Leave; + + -- Here right operand is a subtype mark + + else + declare + Typ : Entity_Id := Etype (Rop); + Is_Acc : constant Boolean := Is_Access_Type (Typ); + Cond : Node_Id := Empty; + New_N : Node_Id; + Obj : Node_Id := Lop; + SCIL_Node : Node_Id; + + begin + Remove_Side_Effects (Obj); + + -- For tagged type, do tagged membership operation + + if Is_Tagged_Type (Typ) then + + -- No expansion will be performed when VM_Target, as the VM + -- back-ends will handle the membership tests directly (tags + -- are not explicitly represented in Java objects, so the + -- normal tagged membership expansion is not what we want). + + if Tagged_Type_Expansion then + Tagged_Membership (N, SCIL_Node, New_N); + Rewrite (N, New_N); + Analyze_And_Resolve (N, Restyp); + + -- Update decoration of relocated node referenced by the + -- SCIL node. + + if Generate_SCIL and then Present (SCIL_Node) then + Set_SCIL_Node (N, SCIL_Node); + end if; + end if; + + goto Leave; + + -- If type is scalar type, rewrite as x in t'First .. t'Last. + -- This reason we do this is that the bounds may have the wrong + -- type if they come from the original type definition. Also this + -- way we get all the processing above for an explicit range. + + -- Don't do this for predicated types, since in this case we + -- want to check the predicate! + + elsif Is_Scalar_Type (Typ) then + if No (Predicate_Function (Typ)) then + Rewrite (Rop, + Make_Range (Loc, + Low_Bound => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_First, + Prefix => New_Reference_To (Typ, Loc)), + + High_Bound => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Last, + Prefix => New_Reference_To (Typ, Loc)))); + Analyze_And_Resolve (N, Restyp); + end if; + + goto Leave; + + -- Ada 2005 (AI-216): Program_Error is raised when evaluating + -- a membership test if the subtype mark denotes a constrained + -- Unchecked_Union subtype and the expression lacks inferable + -- discriminants. + + elsif Is_Unchecked_Union (Base_Type (Typ)) + and then Is_Constrained (Typ) + and then not Has_Inferable_Discriminants (Lop) + then + Insert_Action (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction)); + + -- Prevent Gigi from generating incorrect code by rewriting the + -- test as False. + + Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); + goto Leave; + end if; + + -- Here we have a non-scalar type + + if Is_Acc then + Typ := Designated_Type (Typ); + end if; + + if not Is_Constrained (Typ) then + Rewrite (N, New_Reference_To (Standard_True, Loc)); + Analyze_And_Resolve (N, Restyp); + + -- For the constrained array case, we have to check the subscripts + -- for an exact match if the lengths are non-zero (the lengths + -- must match in any case). + + elsif Is_Array_Type (Typ) then + Check_Subscripts : declare + function Build_Attribute_Reference + (E : Node_Id; + Nam : Name_Id; + Dim : Nat) return Node_Id; + -- Build attribute reference E'Nam (Dim) + + ------------------------------- + -- Build_Attribute_Reference -- + ------------------------------- + + function Build_Attribute_Reference + (E : Node_Id; + Nam : Name_Id; + Dim : Nat) return Node_Id + is + begin + return + Make_Attribute_Reference (Loc, + Prefix => E, + Attribute_Name => Nam, + Expressions => New_List ( + Make_Integer_Literal (Loc, Dim))); + end Build_Attribute_Reference; + + -- Start of processing for Check_Subscripts + + begin + for J in 1 .. Number_Dimensions (Typ) loop + Evolve_And_Then (Cond, + Make_Op_Eq (Loc, + Left_Opnd => + Build_Attribute_Reference + (Duplicate_Subexpr_No_Checks (Obj), + Name_First, J), + Right_Opnd => + Build_Attribute_Reference + (New_Occurrence_Of (Typ, Loc), Name_First, J))); + + Evolve_And_Then (Cond, + Make_Op_Eq (Loc, + Left_Opnd => + Build_Attribute_Reference + (Duplicate_Subexpr_No_Checks (Obj), + Name_Last, J), + Right_Opnd => + Build_Attribute_Reference + (New_Occurrence_Of (Typ, Loc), Name_Last, J))); + end loop; + + if Is_Acc then + Cond := + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => Obj, + Right_Opnd => Make_Null (Loc)), + Right_Opnd => Cond); + end if; + + Rewrite (N, Cond); + Analyze_And_Resolve (N, Restyp); + end Check_Subscripts; + + -- These are the cases where constraint checks may be required, + -- e.g. records with possible discriminants + + else + -- Expand the test into a series of discriminant comparisons. + -- The expression that is built is the negation of the one that + -- is used for checking discriminant constraints. + + Obj := Relocate_Node (Left_Opnd (N)); + + if Has_Discriminants (Typ) then + Cond := Make_Op_Not (Loc, + Right_Opnd => Build_Discriminant_Checks (Obj, Typ)); + + if Is_Acc then + Cond := Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => Obj, + Right_Opnd => Make_Null (Loc)), + Right_Opnd => Cond); + end if; + + else + Cond := New_Occurrence_Of (Standard_True, Loc); + end if; + + Rewrite (N, Cond); + Analyze_And_Resolve (N, Restyp); + end if; + end; + end if; + + -- At this point, we have done the processing required for the basic + -- membership test, but not yet dealt with the predicate. + + <> + + -- If a predicate is present, then we do the predicate test, but we + -- most certainly want to omit this if we are within the predicate + -- function itself, since otherwise we have an infinite recursion! + + declare + PFunc : constant Entity_Id := Predicate_Function (Rtyp); + + begin + if Present (PFunc) + and then Current_Scope /= PFunc + then + Rewrite (N, + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (N), + Right_Opnd => Make_Predicate_Call (Rtyp, Lop))); + + -- Analyze new expression, mark left operand as analyzed to + -- avoid infinite recursion adding predicate calls. + + Set_Analyzed (Left_Opnd (N)); + Analyze_And_Resolve (N, Standard_Boolean); + + -- All done, skip attempt at compile time determination of result + + return; + end if; + end; + end Expand_N_In; + + -------------------------------- + -- Expand_N_Indexed_Component -- + -------------------------------- + + procedure Expand_N_Indexed_Component (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + P : constant Node_Id := Prefix (N); + T : constant Entity_Id := Etype (P); + + begin + -- A special optimization, if we have an indexed component that is + -- selecting from a slice, then we can eliminate the slice, since, for + -- example, x (i .. j)(k) is identical to x(k). The only difference is + -- the range check required by the slice. The range check for the slice + -- itself has already been generated. The range check for the + -- subscripting operation is ensured by converting the subject to + -- the subtype of the slice. + + -- This optimization not only generates better code, avoiding slice + -- messing especially in the packed case, but more importantly bypasses + -- some problems in handling this peculiar case, for example, the issue + -- of dealing specially with object renamings. + + if Nkind (P) = N_Slice then + Rewrite (N, + Make_Indexed_Component (Loc, + Prefix => Prefix (P), + Expressions => New_List ( + Convert_To + (Etype (First_Index (Etype (P))), + First (Expressions (N)))))); + Analyze_And_Resolve (N, Typ); + return; + end if; + + -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place + -- function, then additional actuals must be passed. + + if Ada_Version >= Ada_2005 + and then Is_Build_In_Place_Function_Call (P) + then + Make_Build_In_Place_Call_In_Anonymous_Context (P); + end if; + + -- If the prefix is an access type, then we unconditionally rewrite if + -- as an explicit dereference. This simplifies processing for several + -- cases, including packed array cases and certain cases in which checks + -- must be generated. We used to try to do this only when it was + -- necessary, but it cleans up the code to do it all the time. + + if Is_Access_Type (T) then + Insert_Explicit_Dereference (P); + Analyze_And_Resolve (P, Designated_Type (T)); + end if; + + -- Generate index and validity checks + + Generate_Index_Checks (N); + + if Validity_Checks_On and then Validity_Check_Subscripts then + Apply_Subscript_Validity_Checks (N); + end if; + + -- All done for the non-packed case + + if not Is_Packed (Etype (Prefix (N))) then + return; + end if; + + -- For packed arrays that are not bit-packed (i.e. the case of an array + -- with one or more index types with a non-contiguous enumeration type), + -- we can always use the normal packed element get circuit. + + if not Is_Bit_Packed_Array (Etype (Prefix (N))) then + Expand_Packed_Element_Reference (N); + return; + end if; + + -- For a reference to a component of a bit packed array, we have to + -- convert it to a reference to the corresponding Packed_Array_Type. + -- We only want to do this for simple references, and not for: + + -- Left side of assignment, or prefix of left side of assignment, or + -- prefix of the prefix, to handle packed arrays of packed arrays, + -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement + + -- Renaming objects in renaming associations + -- This case is handled when a use of the renamed variable occurs + + -- Actual parameters for a procedure call + -- This case is handled in Exp_Ch6.Expand_Actuals + + -- The second expression in a 'Read attribute reference + + -- The prefix of an address or bit or size attribute reference + + -- The following circuit detects these exceptions + + declare + Child : Node_Id := N; + Parnt : Node_Id := Parent (N); + + begin + loop + if Nkind (Parnt) = N_Unchecked_Expression then + null; + + elsif Nkind_In (Parnt, N_Object_Renaming_Declaration, + N_Procedure_Call_Statement) + or else (Nkind (Parnt) = N_Parameter_Association + and then + Nkind (Parent (Parnt)) = N_Procedure_Call_Statement) + then + return; + + elsif Nkind (Parnt) = N_Attribute_Reference + and then (Attribute_Name (Parnt) = Name_Address + or else + Attribute_Name (Parnt) = Name_Bit + or else + Attribute_Name (Parnt) = Name_Size) + and then Prefix (Parnt) = Child + then + return; + + elsif Nkind (Parnt) = N_Assignment_Statement + and then Name (Parnt) = Child + then + return; + + -- If the expression is an index of an indexed component, it must + -- be expanded regardless of context. + + elsif Nkind (Parnt) = N_Indexed_Component + and then Child /= Prefix (Parnt) + then + Expand_Packed_Element_Reference (N); + return; + + elsif Nkind (Parent (Parnt)) = N_Assignment_Statement + and then Name (Parent (Parnt)) = Parnt + then + return; + + elsif Nkind (Parnt) = N_Attribute_Reference + and then Attribute_Name (Parnt) = Name_Read + and then Next (First (Expressions (Parnt))) = Child + then + return; + + elsif Nkind_In (Parnt, N_Indexed_Component, N_Selected_Component) + and then Prefix (Parnt) = Child + then + null; + + else + Expand_Packed_Element_Reference (N); + return; + end if; + + -- Keep looking up tree for unchecked expression, or if we are the + -- prefix of a possible assignment left side. + + Child := Parnt; + Parnt := Parent (Child); + end loop; + end; + end Expand_N_Indexed_Component; + + --------------------- + -- Expand_N_Not_In -- + --------------------- + + -- Replace a not in b by not (a in b) so that the expansions for (a in b) + -- can be done. This avoids needing to duplicate this expansion code. + + procedure Expand_N_Not_In (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Cfs : constant Boolean := Comes_From_Source (N); + + begin + Rewrite (N, + Make_Op_Not (Loc, + Right_Opnd => + Make_In (Loc, + Left_Opnd => Left_Opnd (N), + Right_Opnd => Right_Opnd (N)))); + + -- If this is a set membership, preserve list of alternatives + + Set_Alternatives (Right_Opnd (N), Alternatives (Original_Node (N))); + + -- We want this to appear as coming from source if original does (see + -- transformations in Expand_N_In). + + Set_Comes_From_Source (N, Cfs); + Set_Comes_From_Source (Right_Opnd (N), Cfs); + + -- Now analyze transformed node + + Analyze_And_Resolve (N, Typ); + end Expand_N_Not_In; + + ------------------- + -- Expand_N_Null -- + ------------------- + + -- The only replacement required is for the case of a null of a type that + -- is an access to protected subprogram, or a subtype thereof. We represent + -- such access values as a record, and so we must replace the occurrence of + -- null by the equivalent record (with a null address and a null pointer in + -- it), so that the backend creates the proper value. + + procedure Expand_N_Null (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Base_Type (Etype (N)); + Agg : Node_Id; + + begin + if Is_Access_Protected_Subprogram_Type (Typ) then + Agg := + Make_Aggregate (Loc, + Expressions => New_List ( + New_Occurrence_Of (RTE (RE_Null_Address), Loc), + Make_Null (Loc))); + + Rewrite (N, Agg); + Analyze_And_Resolve (N, Equivalent_Type (Typ)); + + -- For subsequent semantic analysis, the node must retain its type. + -- Gigi in any case replaces this type by the corresponding record + -- type before processing the node. + + Set_Etype (N, Typ); + end if; + + exception + when RE_Not_Available => + return; + end Expand_N_Null; + + --------------------- + -- Expand_N_Op_Abs -- + --------------------- + + procedure Expand_N_Op_Abs (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Expr : constant Node_Id := Right_Opnd (N); + + begin + Unary_Op_Validity_Checks (N); + + -- Deal with software overflow checking + + if not Backend_Overflow_Checks_On_Target + and then Is_Signed_Integer_Type (Etype (N)) + and then Do_Overflow_Check (N) + then + -- The only case to worry about is when the argument is equal to the + -- largest negative number, so what we do is to insert the check: + + -- [constraint_error when Expr = typ'Base'First] + + -- with the usual Duplicate_Subexpr use coding for expr + + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => Duplicate_Subexpr (Expr), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Base_Type (Etype (Expr)), Loc), + Attribute_Name => Name_First)), + Reason => CE_Overflow_Check_Failed)); + end if; + + -- Vax floating-point types case + + if Vax_Float (Etype (N)) then + Expand_Vax_Arith (N); + end if; + end Expand_N_Op_Abs; + + --------------------- + -- Expand_N_Op_Add -- + --------------------- + + procedure Expand_N_Op_Add (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + + begin + Binary_Op_Validity_Checks (N); + + -- N + 0 = 0 + N = N for integer types + + if Is_Integer_Type (Typ) then + if Compile_Time_Known_Value (Right_Opnd (N)) + and then Expr_Value (Right_Opnd (N)) = Uint_0 + then + Rewrite (N, Left_Opnd (N)); + return; + + elsif Compile_Time_Known_Value (Left_Opnd (N)) + and then Expr_Value (Left_Opnd (N)) = Uint_0 + then + Rewrite (N, Right_Opnd (N)); + return; + end if; + end if; + + -- Arithmetic overflow checks for signed integer/fixed point types + + if Is_Signed_Integer_Type (Typ) + or else Is_Fixed_Point_Type (Typ) + then + Apply_Arithmetic_Overflow_Check (N); + return; + + -- Vax floating-point types case + + elsif Vax_Float (Typ) then + Expand_Vax_Arith (N); + end if; + end Expand_N_Op_Add; + + --------------------- + -- Expand_N_Op_And -- + --------------------- + + procedure Expand_N_Op_And (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + + begin + Binary_Op_Validity_Checks (N); + + if Is_Array_Type (Etype (N)) then + Expand_Boolean_Operator (N); + + elsif Is_Boolean_Type (Etype (N)) then + + -- Replace AND by AND THEN if Short_Circuit_And_Or active and the + -- type is standard Boolean (do not mess with AND that uses a non- + -- standard Boolean type, because something strange is going on). + + if Short_Circuit_And_Or and then Typ = Standard_Boolean then + Rewrite (N, + Make_And_Then (Sloc (N), + Left_Opnd => Relocate_Node (Left_Opnd (N)), + Right_Opnd => Relocate_Node (Right_Opnd (N)))); + Analyze_And_Resolve (N, Typ); + + -- Otherwise, adjust conditions + + else + Adjust_Condition (Left_Opnd (N)); + Adjust_Condition (Right_Opnd (N)); + Set_Etype (N, Standard_Boolean); + Adjust_Result_Type (N, Typ); + end if; + + elsif Is_Intrinsic_Subprogram (Entity (N)) then + Expand_Intrinsic_Call (N, Entity (N)); + + end if; + end Expand_N_Op_And; + + ------------------------ + -- Expand_N_Op_Concat -- + ------------------------ + + procedure Expand_N_Op_Concat (N : Node_Id) is + Opnds : List_Id; + -- List of operands to be concatenated + + Cnode : Node_Id; + -- Node which is to be replaced by the result of concatenating the nodes + -- in the list Opnds. + + begin + -- Ensure validity of both operands + + Binary_Op_Validity_Checks (N); + + -- If we are the left operand of a concatenation higher up the tree, + -- then do nothing for now, since we want to deal with a series of + -- concatenations as a unit. + + if Nkind (Parent (N)) = N_Op_Concat + and then N = Left_Opnd (Parent (N)) + then + return; + end if; + + -- We get here with a concatenation whose left operand may be a + -- concatenation itself with a consistent type. We need to process + -- these concatenation operands from left to right, which means + -- from the deepest node in the tree to the highest node. + + Cnode := N; + while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop + Cnode := Left_Opnd (Cnode); + end loop; + + -- Now Cnode is the deepest concatenation, and its parents are the + -- concatenation nodes above, so now we process bottom up, doing the + -- operations. We gather a string that is as long as possible up to five + -- operands. + + -- The outer loop runs more than once if more than one concatenation + -- type is involved. + + Outer : loop + Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode)); + Set_Parent (Opnds, N); + + -- The inner loop gathers concatenation operands + + Inner : while Cnode /= N + and then Base_Type (Etype (Cnode)) = + Base_Type (Etype (Parent (Cnode))) + loop + Cnode := Parent (Cnode); + Append (Right_Opnd (Cnode), Opnds); + end loop Inner; + + Expand_Concatenate (Cnode, Opnds); + + exit Outer when Cnode = N; + Cnode := Parent (Cnode); + end loop Outer; + end Expand_N_Op_Concat; + + ------------------------ + -- Expand_N_Op_Divide -- + ------------------------ + + procedure Expand_N_Op_Divide (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Lopnd : constant Node_Id := Left_Opnd (N); + Ropnd : constant Node_Id := Right_Opnd (N); + Ltyp : constant Entity_Id := Etype (Lopnd); + Rtyp : constant Entity_Id := Etype (Ropnd); + Typ : Entity_Id := Etype (N); + Rknow : constant Boolean := Is_Integer_Type (Typ) + and then + Compile_Time_Known_Value (Ropnd); + Rval : Uint; + + begin + Binary_Op_Validity_Checks (N); + + if Rknow then + Rval := Expr_Value (Ropnd); + end if; + + -- N / 1 = N for integer types + + if Rknow and then Rval = Uint_1 then + Rewrite (N, Lopnd); + return; + end if; + + -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that + -- Is_Power_Of_2_For_Shift is set means that we know that our left + -- operand is an unsigned integer, as required for this to work. + + if Nkind (Ropnd) = N_Op_Expon + and then Is_Power_Of_2_For_Shift (Ropnd) + + -- We cannot do this transformation in configurable run time mode if we + -- have 64-bit integers and long shifts are not available. + + and then + (Esize (Ltyp) <= 32 + or else Support_Long_Shifts_On_Target) + then + Rewrite (N, + Make_Op_Shift_Right (Loc, + Left_Opnd => Lopnd, + Right_Opnd => + Convert_To (Standard_Natural, Right_Opnd (Ropnd)))); + Analyze_And_Resolve (N, Typ); + return; + end if; + + -- Do required fixup of universal fixed operation + + if Typ = Universal_Fixed then + Fixup_Universal_Fixed_Operation (N); + Typ := Etype (N); + end if; + + -- Divisions with fixed-point results + + if Is_Fixed_Point_Type (Typ) then + + -- No special processing if Treat_Fixed_As_Integer is set, since + -- from a semantic point of view such operations are simply integer + -- operations and will be treated that way. + + if not Treat_Fixed_As_Integer (N) then + if Is_Integer_Type (Rtyp) then + Expand_Divide_Fixed_By_Integer_Giving_Fixed (N); + else + Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N); + end if; + end if; + + -- Other cases of division of fixed-point operands. Again we exclude the + -- case where Treat_Fixed_As_Integer is set. + + elsif (Is_Fixed_Point_Type (Ltyp) or else + Is_Fixed_Point_Type (Rtyp)) + and then not Treat_Fixed_As_Integer (N) + then + if Is_Integer_Type (Typ) then + Expand_Divide_Fixed_By_Fixed_Giving_Integer (N); + else + pragma Assert (Is_Floating_Point_Type (Typ)); + Expand_Divide_Fixed_By_Fixed_Giving_Float (N); + end if; + + -- Mixed-mode operations can appear in a non-static universal context, + -- in which case the integer argument must be converted explicitly. + + elsif Typ = Universal_Real + and then Is_Integer_Type (Rtyp) + then + Rewrite (Ropnd, + Convert_To (Universal_Real, Relocate_Node (Ropnd))); + + Analyze_And_Resolve (Ropnd, Universal_Real); + + elsif Typ = Universal_Real + and then Is_Integer_Type (Ltyp) + then + Rewrite (Lopnd, + Convert_To (Universal_Real, Relocate_Node (Lopnd))); + + Analyze_And_Resolve (Lopnd, Universal_Real); + + -- Non-fixed point cases, do integer zero divide and overflow checks + + elsif Is_Integer_Type (Typ) then + Apply_Divide_Check (N); + + -- Check for 64-bit division available, or long shifts if the divisor + -- is a small power of 2 (since such divides will be converted into + -- long shifts). + + if Esize (Ltyp) > 32 + and then not Support_64_Bit_Divides_On_Target + and then + (not Rknow + or else not Support_Long_Shifts_On_Target + or else (Rval /= Uint_2 and then + Rval /= Uint_4 and then + Rval /= Uint_8 and then + Rval /= Uint_16 and then + Rval /= Uint_32 and then + Rval /= Uint_64)) + then + Error_Msg_CRT ("64-bit division", N); + end if; + + -- Deal with Vax_Float + + elsif Vax_Float (Typ) then + Expand_Vax_Arith (N); + return; + end if; + end Expand_N_Op_Divide; + + -------------------- + -- Expand_N_Op_Eq -- + -------------------- + + procedure Expand_N_Op_Eq (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Lhs : constant Node_Id := Left_Opnd (N); + Rhs : constant Node_Id := Right_Opnd (N); + Bodies : constant List_Id := New_List; + A_Typ : constant Entity_Id := Etype (Lhs); + + Typl : Entity_Id := A_Typ; + Op_Name : Entity_Id; + Prim : Elmt_Id; + + procedure Build_Equality_Call (Eq : Entity_Id); + -- If a constructed equality exists for the type or for its parent, + -- build and analyze call, adding conversions if the operation is + -- inherited. + + function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean; + -- Determines whether a type has a subcomponent of an unconstrained + -- Unchecked_Union subtype. Typ is a record type. + + ------------------------- + -- Build_Equality_Call -- + ------------------------- + + procedure Build_Equality_Call (Eq : Entity_Id) is + Op_Type : constant Entity_Id := Etype (First_Formal (Eq)); + L_Exp : Node_Id := Relocate_Node (Lhs); + R_Exp : Node_Id := Relocate_Node (Rhs); + + begin + if Base_Type (Op_Type) /= Base_Type (A_Typ) + and then not Is_Class_Wide_Type (A_Typ) + then + L_Exp := OK_Convert_To (Op_Type, L_Exp); + R_Exp := OK_Convert_To (Op_Type, R_Exp); + end if; + + -- If we have an Unchecked_Union, we need to add the inferred + -- discriminant values as actuals in the function call. At this + -- point, the expansion has determined that both operands have + -- inferable discriminants. + + if Is_Unchecked_Union (Op_Type) then + declare + Lhs_Type : constant Node_Id := Etype (L_Exp); + Rhs_Type : constant Node_Id := Etype (R_Exp); + Lhs_Discr_Val : Node_Id; + Rhs_Discr_Val : Node_Id; + + begin + -- Per-object constrained selected components require special + -- attention. If the enclosing scope of the component is an + -- Unchecked_Union, we cannot reference its discriminants + -- directly. This is why we use the two extra parameters of + -- the equality function of the enclosing Unchecked_Union. + + -- type UU_Type (Discr : Integer := 0) is + -- . . . + -- end record; + -- pragma Unchecked_Union (UU_Type); + + -- 1. Unchecked_Union enclosing record: + + -- type Enclosing_UU_Type (Discr : Integer := 0) is record + -- . . . + -- Comp : UU_Type (Discr); + -- . . . + -- end Enclosing_UU_Type; + -- pragma Unchecked_Union (Enclosing_UU_Type); + + -- Obj1 : Enclosing_UU_Type; + -- Obj2 : Enclosing_UU_Type (1); + + -- [. . .] Obj1 = Obj2 [. . .] + + -- Generated code: + + -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then + + -- A and B are the formal parameters of the equality function + -- of Enclosing_UU_Type. The function always has two extra + -- formals to capture the inferred discriminant values. + + -- 2. Non-Unchecked_Union enclosing record: + + -- type + -- Enclosing_Non_UU_Type (Discr : Integer := 0) + -- is record + -- . . . + -- Comp : UU_Type (Discr); + -- . . . + -- end Enclosing_Non_UU_Type; + + -- Obj1 : Enclosing_Non_UU_Type; + -- Obj2 : Enclosing_Non_UU_Type (1); + + -- ... Obj1 = Obj2 ... + + -- Generated code: + + -- if not (uu_typeEQ (obj1.comp, obj2.comp, + -- obj1.discr, obj2.discr)) then + + -- In this case we can directly reference the discriminants of + -- the enclosing record. + + -- Lhs of equality + + if Nkind (Lhs) = N_Selected_Component + and then Has_Per_Object_Constraint + (Entity (Selector_Name (Lhs))) + then + -- Enclosing record is an Unchecked_Union, use formal A + + if Is_Unchecked_Union + (Scope (Entity (Selector_Name (Lhs)))) + then + Lhs_Discr_Val := Make_Identifier (Loc, Name_A); + + -- Enclosing record is of a non-Unchecked_Union type, it is + -- possible to reference the discriminant. + + else + Lhs_Discr_Val := + Make_Selected_Component (Loc, + Prefix => Prefix (Lhs), + Selector_Name => + New_Copy + (Get_Discriminant_Value + (First_Discriminant (Lhs_Type), + Lhs_Type, + Stored_Constraint (Lhs_Type)))); + end if; + + -- Comment needed here ??? + + else + -- Infer the discriminant value + + Lhs_Discr_Val := + New_Copy + (Get_Discriminant_Value + (First_Discriminant (Lhs_Type), + Lhs_Type, + Stored_Constraint (Lhs_Type))); + end if; + + -- Rhs of equality + + if Nkind (Rhs) = N_Selected_Component + and then Has_Per_Object_Constraint + (Entity (Selector_Name (Rhs))) + then + if Is_Unchecked_Union + (Scope (Entity (Selector_Name (Rhs)))) + then + Rhs_Discr_Val := Make_Identifier (Loc, Name_B); + + else + Rhs_Discr_Val := + Make_Selected_Component (Loc, + Prefix => Prefix (Rhs), + Selector_Name => + New_Copy (Get_Discriminant_Value ( + First_Discriminant (Rhs_Type), + Rhs_Type, + Stored_Constraint (Rhs_Type)))); + + end if; + else + Rhs_Discr_Val := + New_Copy (Get_Discriminant_Value ( + First_Discriminant (Rhs_Type), + Rhs_Type, + Stored_Constraint (Rhs_Type))); + + end if; + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (Eq, Loc), + Parameter_Associations => New_List ( + L_Exp, + R_Exp, + Lhs_Discr_Val, + Rhs_Discr_Val))); + end; + + -- Normal case, not an unchecked union + + else + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (Eq, Loc), + Parameter_Associations => New_List (L_Exp, R_Exp))); + end if; + + Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); + end Build_Equality_Call; + + ------------------------------------ + -- Has_Unconstrained_UU_Component -- + ------------------------------------ + + function Has_Unconstrained_UU_Component + (Typ : Node_Id) return Boolean + is + Tdef : constant Node_Id := + Type_Definition (Declaration_Node (Base_Type (Typ))); + Clist : Node_Id; + Vpart : Node_Id; + + function Component_Is_Unconstrained_UU + (Comp : Node_Id) return Boolean; + -- Determines whether the subtype of the component is an + -- unconstrained Unchecked_Union. + + function Variant_Is_Unconstrained_UU + (Variant : Node_Id) return Boolean; + -- Determines whether a component of the variant has an unconstrained + -- Unchecked_Union subtype. + + ----------------------------------- + -- Component_Is_Unconstrained_UU -- + ----------------------------------- + + function Component_Is_Unconstrained_UU + (Comp : Node_Id) return Boolean + is + begin + if Nkind (Comp) /= N_Component_Declaration then + return False; + end if; + + declare + Sindic : constant Node_Id := + Subtype_Indication (Component_Definition (Comp)); + + begin + -- Unconstrained nominal type. In the case of a constraint + -- present, the node kind would have been N_Subtype_Indication. + + if Nkind (Sindic) = N_Identifier then + return Is_Unchecked_Union (Base_Type (Etype (Sindic))); + end if; + + return False; + end; + end Component_Is_Unconstrained_UU; + + --------------------------------- + -- Variant_Is_Unconstrained_UU -- + --------------------------------- + + function Variant_Is_Unconstrained_UU + (Variant : Node_Id) return Boolean + is + Clist : constant Node_Id := Component_List (Variant); + + begin + if Is_Empty_List (Component_Items (Clist)) then + return False; + end if; + + -- We only need to test one component + + declare + Comp : Node_Id := First (Component_Items (Clist)); + + begin + while Present (Comp) loop + if Component_Is_Unconstrained_UU (Comp) then + return True; + end if; + + Next (Comp); + end loop; + end; + + -- None of the components withing the variant were of + -- unconstrained Unchecked_Union type. + + return False; + end Variant_Is_Unconstrained_UU; + + -- Start of processing for Has_Unconstrained_UU_Component + + begin + if Null_Present (Tdef) then + return False; + end if; + + Clist := Component_List (Tdef); + Vpart := Variant_Part (Clist); + + -- Inspect available components + + if Present (Component_Items (Clist)) then + declare + Comp : Node_Id := First (Component_Items (Clist)); + + begin + while Present (Comp) loop + + -- One component is sufficient + + if Component_Is_Unconstrained_UU (Comp) then + return True; + end if; + + Next (Comp); + end loop; + end; + end if; + + -- Inspect available components withing variants + + if Present (Vpart) then + declare + Variant : Node_Id := First (Variants (Vpart)); + + begin + while Present (Variant) loop + + -- One component within a variant is sufficient + + if Variant_Is_Unconstrained_UU (Variant) then + return True; + end if; + + Next (Variant); + end loop; + end; + end if; + + -- Neither the available components, nor the components inside the + -- variant parts were of an unconstrained Unchecked_Union subtype. + + return False; + end Has_Unconstrained_UU_Component; + + -- Start of processing for Expand_N_Op_Eq + + begin + Binary_Op_Validity_Checks (N); + + if Ekind (Typl) = E_Private_Type then + Typl := Underlying_Type (Typl); + elsif Ekind (Typl) = E_Private_Subtype then + Typl := Underlying_Type (Base_Type (Typl)); + else + null; + end if; + + -- It may happen in error situations that the underlying type is not + -- set. The error will be detected later, here we just defend the + -- expander code. + + if No (Typl) then + return; + end if; + + Typl := Base_Type (Typl); + + -- Boolean types (requiring handling of non-standard case) + + if Is_Boolean_Type (Typl) then + Adjust_Condition (Left_Opnd (N)); + Adjust_Condition (Right_Opnd (N)); + Set_Etype (N, Standard_Boolean); + Adjust_Result_Type (N, Typ); + + -- Array types + + elsif Is_Array_Type (Typl) then + + -- If we are doing full validity checking, and it is possible for the + -- array elements to be invalid then expand out array comparisons to + -- make sure that we check the array elements. + + if Validity_Check_Operands + and then not Is_Known_Valid (Component_Type (Typl)) + then + declare + Save_Force_Validity_Checks : constant Boolean := + Force_Validity_Checks; + begin + Force_Validity_Checks := True; + Rewrite (N, + Expand_Array_Equality + (N, + Relocate_Node (Lhs), + Relocate_Node (Rhs), + Bodies, + Typl)); + Insert_Actions (N, Bodies); + Analyze_And_Resolve (N, Standard_Boolean); + Force_Validity_Checks := Save_Force_Validity_Checks; + end; + + -- Packed case where both operands are known aligned + + elsif Is_Bit_Packed_Array (Typl) + and then not Is_Possibly_Unaligned_Object (Lhs) + and then not Is_Possibly_Unaligned_Object (Rhs) + then + Expand_Packed_Eq (N); + + -- Where the component type is elementary we can use a block bit + -- comparison (if supported on the target) exception in the case + -- of floating-point (negative zero issues require element by + -- element comparison), and atomic types (where we must be sure + -- to load elements independently) and possibly unaligned arrays. + + elsif Is_Elementary_Type (Component_Type (Typl)) + and then not Is_Floating_Point_Type (Component_Type (Typl)) + and then not Is_Atomic (Component_Type (Typl)) + and then not Is_Possibly_Unaligned_Object (Lhs) + and then not Is_Possibly_Unaligned_Object (Rhs) + and then Support_Composite_Compare_On_Target + then + null; + + -- For composite and floating-point cases, expand equality loop to + -- make sure of using proper comparisons for tagged types, and + -- correctly handling the floating-point case. + + else + Rewrite (N, + Expand_Array_Equality + (N, + Relocate_Node (Lhs), + Relocate_Node (Rhs), + Bodies, + Typl)); + Insert_Actions (N, Bodies, Suppress => All_Checks); + Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); + end if; + + -- Record Types + + elsif Is_Record_Type (Typl) then + + -- For tagged types, use the primitive "=" + + if Is_Tagged_Type (Typl) then + + -- No need to do anything else compiling under restriction + -- No_Dispatching_Calls. During the semantic analysis we + -- already notified such violation. + + if Restriction_Active (No_Dispatching_Calls) then + return; + end if; + + -- If this is derived from an untagged private type completed with + -- a tagged type, it does not have a full view, so we use the + -- primitive operations of the private type. This check should no + -- longer be necessary when these types get their full views??? + + if Is_Private_Type (A_Typ) + and then not Is_Tagged_Type (A_Typ) + and then Is_Derived_Type (A_Typ) + and then No (Full_View (A_Typ)) + then + -- Search for equality operation, checking that the operands + -- have the same type. Note that we must find a matching entry, + -- or something is very wrong! + + Prim := First_Elmt (Collect_Primitive_Operations (A_Typ)); + + while Present (Prim) loop + exit when Chars (Node (Prim)) = Name_Op_Eq + and then Etype (First_Formal (Node (Prim))) = + Etype (Next_Formal (First_Formal (Node (Prim)))) + and then + Base_Type (Etype (Node (Prim))) = Standard_Boolean; + + Next_Elmt (Prim); + end loop; + + pragma Assert (Present (Prim)); + Op_Name := Node (Prim); + + -- Find the type's predefined equality or an overriding + -- user- defined equality. The reason for not simply calling + -- Find_Prim_Op here is that there may be a user-defined + -- overloaded equality op that precedes the equality that we want, + -- so we have to explicitly search (e.g., there could be an + -- equality with two different parameter types). + + else + if Is_Class_Wide_Type (Typl) then + Typl := Root_Type (Typl); + end if; + + Prim := First_Elmt (Primitive_Operations (Typl)); + while Present (Prim) loop + exit when Chars (Node (Prim)) = Name_Op_Eq + and then Etype (First_Formal (Node (Prim))) = + Etype (Next_Formal (First_Formal (Node (Prim)))) + and then + Base_Type (Etype (Node (Prim))) = Standard_Boolean; + + Next_Elmt (Prim); + end loop; + + pragma Assert (Present (Prim)); + Op_Name := Node (Prim); + end if; + + Build_Equality_Call (Op_Name); + + -- Ada 2005 (AI-216): Program_Error is raised when evaluating the + -- predefined equality operator for a type which has a subcomponent + -- of an Unchecked_Union type whose nominal subtype is unconstrained. + + elsif Has_Unconstrained_UU_Component (Typl) then + Insert_Action (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction)); + + -- Prevent Gigi from generating incorrect code by rewriting the + -- equality as a standard False. + + Rewrite (N, + New_Occurrence_Of (Standard_False, Loc)); + + elsif Is_Unchecked_Union (Typl) then + + -- If we can infer the discriminants of the operands, we make a + -- call to the TSS equality function. + + if Has_Inferable_Discriminants (Lhs) + and then + Has_Inferable_Discriminants (Rhs) + then + Build_Equality_Call + (TSS (Root_Type (Typl), TSS_Composite_Equality)); + + else + -- Ada 2005 (AI-216): Program_Error is raised when evaluating + -- the predefined equality operator for an Unchecked_Union type + -- if either of the operands lack inferable discriminants. + + Insert_Action (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction)); + + -- Prevent Gigi from generating incorrect code by rewriting + -- the equality as a standard False. + + Rewrite (N, + New_Occurrence_Of (Standard_False, Loc)); + + end if; + + -- If a type support function is present (for complex cases), use it + + elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then + Build_Equality_Call + (TSS (Root_Type (Typl), TSS_Composite_Equality)); + + -- Otherwise expand the component by component equality. Note that + -- we never use block-bit comparisons for records, because of the + -- problems with gaps. The backend will often be able to recombine + -- the separate comparisons that we generate here. + + else + Remove_Side_Effects (Lhs); + Remove_Side_Effects (Rhs); + Rewrite (N, + Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies)); + + Insert_Actions (N, Bodies, Suppress => All_Checks); + Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); + end if; + end if; + + -- Test if result is known at compile time + + Rewrite_Comparison (N); + + -- If we still have comparison for Vax_Float, process it + + if Vax_Float (Typl) and then Nkind (N) in N_Op_Compare then + Expand_Vax_Comparison (N); + return; + end if; + end Expand_N_Op_Eq; + + ----------------------- + -- Expand_N_Op_Expon -- + ----------------------- + + procedure Expand_N_Op_Expon (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Rtyp : constant Entity_Id := Root_Type (Typ); + Base : constant Node_Id := Relocate_Node (Left_Opnd (N)); + Bastyp : constant Node_Id := Etype (Base); + Exp : constant Node_Id := Relocate_Node (Right_Opnd (N)); + Exptyp : constant Entity_Id := Etype (Exp); + Ovflo : constant Boolean := Do_Overflow_Check (N); + Expv : Uint; + Xnode : Node_Id; + Temp : Node_Id; + Rent : RE_Id; + Ent : Entity_Id; + Etyp : Entity_Id; + + begin + Binary_Op_Validity_Checks (N); + + -- If either operand is of a private type, then we have the use of an + -- intrinsic operator, and we get rid of the privateness, by using root + -- types of underlying types for the actual operation. Otherwise the + -- private types will cause trouble if we expand multiplications or + -- shifts etc. We also do this transformation if the result type is + -- different from the base type. + + if Is_Private_Type (Etype (Base)) + or else + Is_Private_Type (Typ) + or else + Is_Private_Type (Exptyp) + or else + Rtyp /= Root_Type (Bastyp) + then + declare + Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp)); + Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp)); + + begin + Rewrite (N, + Unchecked_Convert_To (Typ, + Make_Op_Expon (Loc, + Left_Opnd => Unchecked_Convert_To (Bt, Base), + Right_Opnd => Unchecked_Convert_To (Et, Exp)))); + Analyze_And_Resolve (N, Typ); + return; + end; + end if; + + -- Test for case of known right argument + + if Compile_Time_Known_Value (Exp) then + Expv := Expr_Value (Exp); + + -- We only fold small non-negative exponents. You might think we + -- could fold small negative exponents for the real case, but we + -- can't because we are required to raise Constraint_Error for + -- the case of 0.0 ** (negative) even if Machine_Overflows = False. + -- See ACVC test C4A012B. + + if Expv >= 0 and then Expv <= 4 then + + -- X ** 0 = 1 (or 1.0) + + if Expv = 0 then + + -- Call Remove_Side_Effects to ensure that any side effects + -- in the ignored left operand (in particular function calls + -- to user defined functions) are properly executed. + + Remove_Side_Effects (Base); + + if Ekind (Typ) in Integer_Kind then + Xnode := Make_Integer_Literal (Loc, Intval => 1); + else + Xnode := Make_Real_Literal (Loc, Ureal_1); + end if; + + -- X ** 1 = X + + elsif Expv = 1 then + Xnode := Base; + + -- X ** 2 = X * X + + elsif Expv = 2 then + Xnode := + Make_Op_Multiply (Loc, + Left_Opnd => Duplicate_Subexpr (Base), + Right_Opnd => Duplicate_Subexpr_No_Checks (Base)); + + -- X ** 3 = X * X * X + + elsif Expv = 3 then + Xnode := + Make_Op_Multiply (Loc, + Left_Opnd => + Make_Op_Multiply (Loc, + Left_Opnd => Duplicate_Subexpr (Base), + Right_Opnd => Duplicate_Subexpr_No_Checks (Base)), + Right_Opnd => Duplicate_Subexpr_No_Checks (Base)); + + -- X ** 4 -> + -- En : constant base'type := base * base; + -- ... + -- En * En + + else -- Expv = 4 + Temp := Make_Temporary (Loc, 'E', Base); + + Insert_Actions (N, New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Constant_Present => True, + Object_Definition => New_Reference_To (Typ, Loc), + Expression => + Make_Op_Multiply (Loc, + Left_Opnd => Duplicate_Subexpr (Base), + Right_Opnd => Duplicate_Subexpr_No_Checks (Base))))); + + Xnode := + Make_Op_Multiply (Loc, + Left_Opnd => New_Reference_To (Temp, Loc), + Right_Opnd => New_Reference_To (Temp, Loc)); + end if; + + Rewrite (N, Xnode); + Analyze_And_Resolve (N, Typ); + return; + end if; + end if; + + -- Case of (2 ** expression) appearing as an argument of an integer + -- multiplication, or as the right argument of a division of a non- + -- negative integer. In such cases we leave the node untouched, setting + -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion + -- of the higher level node converts it into a shift. + + -- Another case is 2 ** N in any other context. We simply convert + -- this to 1 * 2 ** N, and then the above transformation applies. + + -- Note: this transformation is not applicable for a modular type with + -- a non-binary modulus in the multiplication case, since we get a wrong + -- result if the shift causes an overflow before the modular reduction. + + if Nkind (Base) = N_Integer_Literal + and then Intval (Base) = 2 + and then Is_Integer_Type (Root_Type (Exptyp)) + and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer) + and then Is_Unsigned_Type (Exptyp) + and then not Ovflo + then + -- First the multiply and divide cases + + if Nkind_In (Parent (N), N_Op_Divide, N_Op_Multiply) then + declare + P : constant Node_Id := Parent (N); + L : constant Node_Id := Left_Opnd (P); + R : constant Node_Id := Right_Opnd (P); + + begin + if (Nkind (P) = N_Op_Multiply + and then not Non_Binary_Modulus (Typ) + and then + ((Is_Integer_Type (Etype (L)) and then R = N) + or else + (Is_Integer_Type (Etype (R)) and then L = N)) + and then not Do_Overflow_Check (P)) + or else + (Nkind (P) = N_Op_Divide + and then Is_Integer_Type (Etype (L)) + and then Is_Unsigned_Type (Etype (L)) + and then R = N + and then not Do_Overflow_Check (P)) + then + Set_Is_Power_Of_2_For_Shift (N); + return; + end if; + end; + + -- Now the other cases + + elsif not Non_Binary_Modulus (Typ) then + Rewrite (N, + Make_Op_Multiply (Loc, + Left_Opnd => Make_Integer_Literal (Loc, 1), + Right_Opnd => Relocate_Node (N))); + Analyze_And_Resolve (N, Typ); + return; + end if; + end if; + + -- Fall through if exponentiation must be done using a runtime routine + + -- First deal with modular case + + if Is_Modular_Integer_Type (Rtyp) then + + -- Non-binary case, we call the special exponentiation routine for + -- the non-binary case, converting the argument to Long_Long_Integer + -- and passing the modulus value. Then the result is converted back + -- to the base type. + + if Non_Binary_Modulus (Rtyp) then + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Exp_Modular), Loc), + Parameter_Associations => New_List ( + Convert_To (Standard_Integer, Base), + Make_Integer_Literal (Loc, Modulus (Rtyp)), + Exp)))); + + -- Binary case, in this case, we call one of two routines, either the + -- unsigned integer case, or the unsigned long long integer case, + -- with a final "and" operation to do the required mod. + + else + if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then + Ent := RTE (RE_Exp_Unsigned); + else + Ent := RTE (RE_Exp_Long_Long_Unsigned); + end if; + + Rewrite (N, + Convert_To (Typ, + Make_Op_And (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => New_Reference_To (Ent, Loc), + Parameter_Associations => New_List ( + Convert_To (Etype (First_Formal (Ent)), Base), + Exp)), + Right_Opnd => + Make_Integer_Literal (Loc, Modulus (Rtyp) - 1)))); + + end if; + + -- Common exit point for modular type case + + Analyze_And_Resolve (N, Typ); + return; + + -- Signed integer cases, done using either Integer or Long_Long_Integer. + -- It is not worth having routines for Short_[Short_]Integer, since for + -- most machines it would not help, and it would generate more code that + -- might need certification when a certified run time is required. + + -- In the integer cases, we have two routines, one for when overflow + -- checks are required, and one when they are not required, since there + -- is a real gain in omitting checks on many machines. + + elsif Rtyp = Base_Type (Standard_Long_Long_Integer) + or else (Rtyp = Base_Type (Standard_Long_Integer) + and then + Esize (Standard_Long_Integer) > Esize (Standard_Integer)) + or else (Rtyp = Universal_Integer) + then + Etyp := Standard_Long_Long_Integer; + + if Ovflo then + Rent := RE_Exp_Long_Long_Integer; + else + Rent := RE_Exn_Long_Long_Integer; + end if; + + elsif Is_Signed_Integer_Type (Rtyp) then + Etyp := Standard_Integer; + + if Ovflo then + Rent := RE_Exp_Integer; + else + Rent := RE_Exn_Integer; + end if; + + -- Floating-point cases, always done using Long_Long_Float. We do not + -- need separate routines for the overflow case here, since in the case + -- of floating-point, we generate infinities anyway as a rule (either + -- that or we automatically trap overflow), and if there is an infinity + -- generated and a range check is required, the check will fail anyway. + + else + pragma Assert (Is_Floating_Point_Type (Rtyp)); + Etyp := Standard_Long_Long_Float; + Rent := RE_Exn_Long_Long_Float; + end if; + + -- Common processing for integer cases and floating-point cases. + -- If we are in the right type, we can call runtime routine directly + + if Typ = Etyp + and then Rtyp /= Universal_Integer + and then Rtyp /= Universal_Real + then + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (Rent), Loc), + Parameter_Associations => New_List (Base, Exp))); + + -- Otherwise we have to introduce conversions (conversions are also + -- required in the universal cases, since the runtime routine is + -- typed using one of the standard types). + + else + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (Rent), Loc), + Parameter_Associations => New_List ( + Convert_To (Etyp, Base), + Exp)))); + end if; + + Analyze_And_Resolve (N, Typ); + return; + + exception + when RE_Not_Available => + return; + end Expand_N_Op_Expon; + + -------------------- + -- Expand_N_Op_Ge -- + -------------------- + + procedure Expand_N_Op_Ge (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + Op1 : constant Node_Id := Left_Opnd (N); + Op2 : constant Node_Id := Right_Opnd (N); + Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); + + begin + Binary_Op_Validity_Checks (N); + + if Is_Array_Type (Typ1) then + Expand_Array_Comparison (N); + return; + end if; + + if Is_Boolean_Type (Typ1) then + Adjust_Condition (Op1); + Adjust_Condition (Op2); + Set_Etype (N, Standard_Boolean); + Adjust_Result_Type (N, Typ); + end if; + + Rewrite_Comparison (N); + + -- If we still have comparison, and Vax_Float type, process it + + if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then + Expand_Vax_Comparison (N); + return; + end if; + end Expand_N_Op_Ge; + + -------------------- + -- Expand_N_Op_Gt -- + -------------------- + + procedure Expand_N_Op_Gt (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + Op1 : constant Node_Id := Left_Opnd (N); + Op2 : constant Node_Id := Right_Opnd (N); + Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); + + begin + Binary_Op_Validity_Checks (N); + + if Is_Array_Type (Typ1) then + Expand_Array_Comparison (N); + return; + end if; + + if Is_Boolean_Type (Typ1) then + Adjust_Condition (Op1); + Adjust_Condition (Op2); + Set_Etype (N, Standard_Boolean); + Adjust_Result_Type (N, Typ); + end if; + + Rewrite_Comparison (N); + + -- If we still have comparison, and Vax_Float type, process it + + if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then + Expand_Vax_Comparison (N); + return; + end if; + end Expand_N_Op_Gt; + + -------------------- + -- Expand_N_Op_Le -- + -------------------- + + procedure Expand_N_Op_Le (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + Op1 : constant Node_Id := Left_Opnd (N); + Op2 : constant Node_Id := Right_Opnd (N); + Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); + + begin + Binary_Op_Validity_Checks (N); + + if Is_Array_Type (Typ1) then + Expand_Array_Comparison (N); + return; + end if; + + if Is_Boolean_Type (Typ1) then + Adjust_Condition (Op1); + Adjust_Condition (Op2); + Set_Etype (N, Standard_Boolean); + Adjust_Result_Type (N, Typ); + end if; + + Rewrite_Comparison (N); + + -- If we still have comparison, and Vax_Float type, process it + + if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then + Expand_Vax_Comparison (N); + return; + end if; + end Expand_N_Op_Le; + + -------------------- + -- Expand_N_Op_Lt -- + -------------------- + + procedure Expand_N_Op_Lt (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + Op1 : constant Node_Id := Left_Opnd (N); + Op2 : constant Node_Id := Right_Opnd (N); + Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); + + begin + Binary_Op_Validity_Checks (N); + + if Is_Array_Type (Typ1) then + Expand_Array_Comparison (N); + return; + end if; + + if Is_Boolean_Type (Typ1) then + Adjust_Condition (Op1); + Adjust_Condition (Op2); + Set_Etype (N, Standard_Boolean); + Adjust_Result_Type (N, Typ); + end if; + + Rewrite_Comparison (N); + + -- If we still have comparison, and Vax_Float type, process it + + if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then + Expand_Vax_Comparison (N); + return; + end if; + end Expand_N_Op_Lt; + + ----------------------- + -- Expand_N_Op_Minus -- + ----------------------- + + procedure Expand_N_Op_Minus (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + + begin + Unary_Op_Validity_Checks (N); + + if not Backend_Overflow_Checks_On_Target + and then Is_Signed_Integer_Type (Etype (N)) + and then Do_Overflow_Check (N) + then + -- Software overflow checking expands -expr into (0 - expr) + + Rewrite (N, + Make_Op_Subtract (Loc, + Left_Opnd => Make_Integer_Literal (Loc, 0), + Right_Opnd => Right_Opnd (N))); + + Analyze_And_Resolve (N, Typ); + + -- Vax floating-point types case + + elsif Vax_Float (Etype (N)) then + Expand_Vax_Arith (N); + end if; + end Expand_N_Op_Minus; + + --------------------- + -- Expand_N_Op_Mod -- + --------------------- + + procedure Expand_N_Op_Mod (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + DOC : constant Boolean := Do_Overflow_Check (N); + DDC : constant Boolean := Do_Division_Check (N); + + LLB : Uint; + Llo : Uint; + Lhi : Uint; + LOK : Boolean; + Rlo : Uint; + Rhi : Uint; + ROK : Boolean; + + pragma Warnings (Off, Lhi); + + begin + Binary_Op_Validity_Checks (N); + + Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True); + Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True); + + -- Convert mod to rem if operands are known non-negative. We do this + -- since it is quite likely that this will improve the quality of code, + -- (the operation now corresponds to the hardware remainder), and it + -- does not seem likely that it could be harmful. + + if LOK and then Llo >= 0 + and then + ROK and then Rlo >= 0 + then + Rewrite (N, + Make_Op_Rem (Sloc (N), + Left_Opnd => Left_Opnd (N), + Right_Opnd => Right_Opnd (N))); + + -- Instead of reanalyzing the node we do the analysis manually. This + -- avoids anomalies when the replacement is done in an instance and + -- is epsilon more efficient. + + Set_Entity (N, Standard_Entity (S_Op_Rem)); + Set_Etype (N, Typ); + Set_Do_Overflow_Check (N, DOC); + Set_Do_Division_Check (N, DDC); + Expand_N_Op_Rem (N); + Set_Analyzed (N); + + -- Otherwise, normal mod processing + + else + if Is_Integer_Type (Etype (N)) then + Apply_Divide_Check (N); + end if; + + -- Apply optimization x mod 1 = 0. We don't really need that with + -- gcc, but it is useful with other back ends (e.g. AAMP), and is + -- certainly harmless. + + if Is_Integer_Type (Etype (N)) + and then Compile_Time_Known_Value (Right) + and then Expr_Value (Right) = Uint_1 + then + -- Call Remove_Side_Effects to ensure that any side effects in + -- the ignored left operand (in particular function calls to + -- user defined functions) are properly executed. + + Remove_Side_Effects (Left); + + Rewrite (N, Make_Integer_Literal (Loc, 0)); + Analyze_And_Resolve (N, Typ); + return; + end if; + + -- Deal with annoying case of largest negative number remainder + -- minus one. Gigi does not handle this case correctly, because + -- it generates a divide instruction which may trap in this case. + + -- In fact the check is quite easy, if the right operand is -1, then + -- the mod value is always 0, and we can just ignore the left operand + -- completely in this case. + + -- The operand type may be private (e.g. in the expansion of an + -- intrinsic operation) so we must use the underlying type to get the + -- bounds, and convert the literals explicitly. + + LLB := + Expr_Value + (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left))))); + + if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi)) + and then + ((not LOK) or else (Llo = LLB)) + then + Rewrite (N, + Make_Conditional_Expression (Loc, + Expressions => New_List ( + Make_Op_Eq (Loc, + Left_Opnd => Duplicate_Subexpr (Right), + Right_Opnd => + Unchecked_Convert_To (Typ, + Make_Integer_Literal (Loc, -1))), + Unchecked_Convert_To (Typ, + Make_Integer_Literal (Loc, Uint_0)), + Relocate_Node (N)))); + + Set_Analyzed (Next (Next (First (Expressions (N))))); + Analyze_And_Resolve (N, Typ); + end if; + end if; + end Expand_N_Op_Mod; + + -------------------------- + -- Expand_N_Op_Multiply -- + -------------------------- + + procedure Expand_N_Op_Multiply (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Lop : constant Node_Id := Left_Opnd (N); + Rop : constant Node_Id := Right_Opnd (N); + + Lp2 : constant Boolean := + Nkind (Lop) = N_Op_Expon + and then Is_Power_Of_2_For_Shift (Lop); + + Rp2 : constant Boolean := + Nkind (Rop) = N_Op_Expon + and then Is_Power_Of_2_For_Shift (Rop); + + Ltyp : constant Entity_Id := Etype (Lop); + Rtyp : constant Entity_Id := Etype (Rop); + Typ : Entity_Id := Etype (N); + + begin + Binary_Op_Validity_Checks (N); + + -- Special optimizations for integer types + + if Is_Integer_Type (Typ) then + + -- N * 0 = 0 for integer types + + if Compile_Time_Known_Value (Rop) + and then Expr_Value (Rop) = Uint_0 + then + -- Call Remove_Side_Effects to ensure that any side effects in + -- the ignored left operand (in particular function calls to + -- user defined functions) are properly executed. + + Remove_Side_Effects (Lop); + + Rewrite (N, Make_Integer_Literal (Loc, Uint_0)); + Analyze_And_Resolve (N, Typ); + return; + end if; + + -- Similar handling for 0 * N = 0 + + if Compile_Time_Known_Value (Lop) + and then Expr_Value (Lop) = Uint_0 + then + Remove_Side_Effects (Rop); + Rewrite (N, Make_Integer_Literal (Loc, Uint_0)); + Analyze_And_Resolve (N, Typ); + return; + end if; + + -- N * 1 = 1 * N = N for integer types + + -- This optimisation is not done if we are going to + -- rewrite the product 1 * 2 ** N to a shift. + + if Compile_Time_Known_Value (Rop) + and then Expr_Value (Rop) = Uint_1 + and then not Lp2 + then + Rewrite (N, Lop); + return; + + elsif Compile_Time_Known_Value (Lop) + and then Expr_Value (Lop) = Uint_1 + and then not Rp2 + then + Rewrite (N, Rop); + return; + end if; + end if; + + -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that + -- Is_Power_Of_2_For_Shift is set means that we know that our left + -- operand is an integer, as required for this to work. + + if Rp2 then + if Lp2 then + + -- Convert 2 ** A * 2 ** B into 2 ** (A + B) + + Rewrite (N, + Make_Op_Expon (Loc, + Left_Opnd => Make_Integer_Literal (Loc, 2), + Right_Opnd => + Make_Op_Add (Loc, + Left_Opnd => Right_Opnd (Lop), + Right_Opnd => Right_Opnd (Rop)))); + Analyze_And_Resolve (N, Typ); + return; + + else + Rewrite (N, + Make_Op_Shift_Left (Loc, + Left_Opnd => Lop, + Right_Opnd => + Convert_To (Standard_Natural, Right_Opnd (Rop)))); + Analyze_And_Resolve (N, Typ); + return; + end if; + + -- Same processing for the operands the other way round + + elsif Lp2 then + Rewrite (N, + Make_Op_Shift_Left (Loc, + Left_Opnd => Rop, + Right_Opnd => + Convert_To (Standard_Natural, Right_Opnd (Lop)))); + Analyze_And_Resolve (N, Typ); + return; + end if; + + -- Do required fixup of universal fixed operation + + if Typ = Universal_Fixed then + Fixup_Universal_Fixed_Operation (N); + Typ := Etype (N); + end if; + + -- Multiplications with fixed-point results + + if Is_Fixed_Point_Type (Typ) then + + -- No special processing if Treat_Fixed_As_Integer is set, since from + -- a semantic point of view such operations are simply integer + -- operations and will be treated that way. + + if not Treat_Fixed_As_Integer (N) then + + -- Case of fixed * integer => fixed + + if Is_Integer_Type (Rtyp) then + Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N); + + -- Case of integer * fixed => fixed + + elsif Is_Integer_Type (Ltyp) then + Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N); + + -- Case of fixed * fixed => fixed + + else + Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N); + end if; + end if; + + -- Other cases of multiplication of fixed-point operands. Again we + -- exclude the cases where Treat_Fixed_As_Integer flag is set. + + elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp)) + and then not Treat_Fixed_As_Integer (N) + then + if Is_Integer_Type (Typ) then + Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N); + else + pragma Assert (Is_Floating_Point_Type (Typ)); + Expand_Multiply_Fixed_By_Fixed_Giving_Float (N); + end if; + + -- Mixed-mode operations can appear in a non-static universal context, + -- in which case the integer argument must be converted explicitly. + + elsif Typ = Universal_Real + and then Is_Integer_Type (Rtyp) + then + Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop))); + + Analyze_And_Resolve (Rop, Universal_Real); + + elsif Typ = Universal_Real + and then Is_Integer_Type (Ltyp) + then + Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop))); + + Analyze_And_Resolve (Lop, Universal_Real); + + -- Non-fixed point cases, check software overflow checking required + + elsif Is_Signed_Integer_Type (Etype (N)) then + Apply_Arithmetic_Overflow_Check (N); + + -- Deal with VAX float case + + elsif Vax_Float (Typ) then + Expand_Vax_Arith (N); + return; + end if; + end Expand_N_Op_Multiply; + + -------------------- + -- Expand_N_Op_Ne -- + -------------------- + + procedure Expand_N_Op_Ne (N : Node_Id) is + Typ : constant Entity_Id := Etype (Left_Opnd (N)); + + begin + -- Case of elementary type with standard operator + + if Is_Elementary_Type (Typ) + and then Sloc (Entity (N)) = Standard_Location + then + Binary_Op_Validity_Checks (N); + + -- Boolean types (requiring handling of non-standard case) + + if Is_Boolean_Type (Typ) then + Adjust_Condition (Left_Opnd (N)); + Adjust_Condition (Right_Opnd (N)); + Set_Etype (N, Standard_Boolean); + Adjust_Result_Type (N, Typ); + end if; + + Rewrite_Comparison (N); + + -- If we still have comparison for Vax_Float, process it + + if Vax_Float (Typ) and then Nkind (N) in N_Op_Compare then + Expand_Vax_Comparison (N); + return; + end if; + + -- For all cases other than elementary types, we rewrite node as the + -- negation of an equality operation, and reanalyze. The equality to be + -- used is defined in the same scope and has the same signature. This + -- signature must be set explicitly since in an instance it may not have + -- the same visibility as in the generic unit. This avoids duplicating + -- or factoring the complex code for record/array equality tests etc. + + else + declare + Loc : constant Source_Ptr := Sloc (N); + Neg : Node_Id; + Ne : constant Entity_Id := Entity (N); + + begin + Binary_Op_Validity_Checks (N); + + Neg := + Make_Op_Not (Loc, + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => Left_Opnd (N), + Right_Opnd => Right_Opnd (N))); + Set_Paren_Count (Right_Opnd (Neg), 1); + + if Scope (Ne) /= Standard_Standard then + Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne)); + end if; + + -- For navigation purposes, the inequality is treated as an + -- implicit reference to the corresponding equality. Preserve the + -- Comes_From_ source flag so that the proper Xref entry is + -- generated. + + Preserve_Comes_From_Source (Neg, N); + Preserve_Comes_From_Source (Right_Opnd (Neg), N); + Rewrite (N, Neg); + Analyze_And_Resolve (N, Standard_Boolean); + end; + end if; + end Expand_N_Op_Ne; + + --------------------- + -- Expand_N_Op_Not -- + --------------------- + + -- If the argument is other than a Boolean array type, there is no special + -- expansion required, except for VMS operations on signed integers. + + -- For the packed case, we call the special routine in Exp_Pakd, except + -- that if the component size is greater than one, we use the standard + -- routine generating a gruesome loop (it is so peculiar to have packed + -- arrays with non-standard Boolean representations anyway, so it does not + -- matter that we do not handle this case efficiently). + + -- For the unpacked case (and for the special packed case where we have non + -- standard Booleans, as discussed above), we generate and insert into the + -- tree the following function definition: + + -- function Nnnn (A : arr) is + -- B : arr; + -- begin + -- for J in a'range loop + -- B (J) := not A (J); + -- end loop; + -- return B; + -- end Nnnn; + + -- Here arr is the actual subtype of the parameter (and hence always + -- constrained). Then we replace the not with a call to this function. + + procedure Expand_N_Op_Not (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Opnd : Node_Id; + Arr : Entity_Id; + A : Entity_Id; + B : Entity_Id; + J : Entity_Id; + A_J : Node_Id; + B_J : Node_Id; + + Func_Name : Entity_Id; + Loop_Statement : Node_Id; + + begin + Unary_Op_Validity_Checks (N); + + -- For boolean operand, deal with non-standard booleans + + if Is_Boolean_Type (Typ) then + Adjust_Condition (Right_Opnd (N)); + Set_Etype (N, Standard_Boolean); + Adjust_Result_Type (N, Typ); + return; + end if; + + -- For the VMS "not" on signed integer types, use conversion to and from + -- a predefined modular type. + + if Is_VMS_Operator (Entity (N)) then + declare + Rtyp : Entity_Id; + Utyp : Entity_Id; + + begin + -- If this is a derived type, retrieve original VMS type so that + -- the proper sized type is used for intermediate values. + + if Is_Derived_Type (Typ) then + Rtyp := First_Subtype (Etype (Typ)); + else + Rtyp := Typ; + end if; + + -- The proper unsigned type must have a size compatible with the + -- operand, to prevent misalignment. + + if RM_Size (Rtyp) <= 8 then + Utyp := RTE (RE_Unsigned_8); + + elsif RM_Size (Rtyp) <= 16 then + Utyp := RTE (RE_Unsigned_16); + + elsif RM_Size (Rtyp) = RM_Size (Standard_Unsigned) then + Utyp := RTE (RE_Unsigned_32); + + else + Utyp := RTE (RE_Long_Long_Unsigned); + end if; + + Rewrite (N, + Unchecked_Convert_To (Typ, + Make_Op_Not (Loc, + Unchecked_Convert_To (Utyp, Right_Opnd (N))))); + Analyze_And_Resolve (N, Typ); + return; + end; + end if; + + -- Only array types need any other processing + + if not Is_Array_Type (Typ) then + return; + end if; + + -- Case of array operand. If bit packed with a component size of 1, + -- handle it in Exp_Pakd if the operand is known to be aligned. + + if Is_Bit_Packed_Array (Typ) + and then Component_Size (Typ) = 1 + and then not Is_Possibly_Unaligned_Object (Right_Opnd (N)) + then + Expand_Packed_Not (N); + return; + end if; + + -- Case of array operand which is not bit-packed. If the context is + -- a safe assignment, call in-place operation, If context is a larger + -- boolean expression in the context of a safe assignment, expansion is + -- done by enclosing operation. + + Opnd := Relocate_Node (Right_Opnd (N)); + Convert_To_Actual_Subtype (Opnd); + Arr := Etype (Opnd); + Ensure_Defined (Arr, N); + Silly_Boolean_Array_Not_Test (N, Arr); + + if Nkind (Parent (N)) = N_Assignment_Statement then + if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then + Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty); + return; + + -- Special case the negation of a binary operation + + elsif Nkind_In (Opnd, N_Op_And, N_Op_Or, N_Op_Xor) + and then Safe_In_Place_Array_Op + (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd)) + then + Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty); + return; + end if; + + elsif Nkind (Parent (N)) in N_Binary_Op + and then Nkind (Parent (Parent (N))) = N_Assignment_Statement + then + declare + Op1 : constant Node_Id := Left_Opnd (Parent (N)); + Op2 : constant Node_Id := Right_Opnd (Parent (N)); + Lhs : constant Node_Id := Name (Parent (Parent (N))); + + begin + if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then + + -- (not A) op (not B) can be reduced to a single call + + if N = Op1 and then Nkind (Op2) = N_Op_Not then + return; + + elsif N = Op2 and then Nkind (Op1) = N_Op_Not then + return; + + -- A xor (not B) can also be special-cased + + elsif N = Op2 and then Nkind (Parent (N)) = N_Op_Xor then + return; + end if; + end if; + end; + end if; + + A := Make_Defining_Identifier (Loc, Name_uA); + B := Make_Defining_Identifier (Loc, Name_uB); + J := Make_Defining_Identifier (Loc, Name_uJ); + + A_J := + Make_Indexed_Component (Loc, + Prefix => New_Reference_To (A, Loc), + Expressions => New_List (New_Reference_To (J, Loc))); + + B_J := + Make_Indexed_Component (Loc, + Prefix => New_Reference_To (B, Loc), + Expressions => New_List (New_Reference_To (J, Loc))); + + Loop_Statement := + Make_Implicit_Loop_Statement (N, + Identifier => Empty, + + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => J, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Chars (A)), + Attribute_Name => Name_Range))), + + Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => B_J, + Expression => Make_Op_Not (Loc, A_J)))); + + Func_Name := Make_Temporary (Loc, 'N'); + Set_Is_Inlined (Func_Name); + + Insert_Action (N, + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Func_Name, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => A, + Parameter_Type => New_Reference_To (Typ, Loc))), + Result_Definition => New_Reference_To (Typ, Loc)), + + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => B, + Object_Definition => New_Reference_To (Arr, Loc))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Loop_Statement, + Make_Simple_Return_Statement (Loc, + Expression => Make_Identifier (Loc, Chars (B))))))); + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (Func_Name, Loc), + Parameter_Associations => New_List (Opnd))); + + Analyze_And_Resolve (N, Typ); + end Expand_N_Op_Not; + + -------------------- + -- Expand_N_Op_Or -- + -------------------- + + procedure Expand_N_Op_Or (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + + begin + Binary_Op_Validity_Checks (N); + + if Is_Array_Type (Etype (N)) then + Expand_Boolean_Operator (N); + + elsif Is_Boolean_Type (Etype (N)) then + + -- Replace OR by OR ELSE if Short_Circuit_And_Or active and the type + -- is standard Boolean (do not mess with AND that uses a non-standard + -- Boolean type, because something strange is going on). + + if Short_Circuit_And_Or and then Typ = Standard_Boolean then + Rewrite (N, + Make_Or_Else (Sloc (N), + Left_Opnd => Relocate_Node (Left_Opnd (N)), + Right_Opnd => Relocate_Node (Right_Opnd (N)))); + Analyze_And_Resolve (N, Typ); + + -- Otherwise, adjust conditions + + else + Adjust_Condition (Left_Opnd (N)); + Adjust_Condition (Right_Opnd (N)); + Set_Etype (N, Standard_Boolean); + Adjust_Result_Type (N, Typ); + end if; + + elsif Is_Intrinsic_Subprogram (Entity (N)) then + Expand_Intrinsic_Call (N, Entity (N)); + + end if; + end Expand_N_Op_Or; + + ---------------------- + -- Expand_N_Op_Plus -- + ---------------------- + + procedure Expand_N_Op_Plus (N : Node_Id) is + begin + Unary_Op_Validity_Checks (N); + end Expand_N_Op_Plus; + + --------------------- + -- Expand_N_Op_Rem -- + --------------------- + + procedure Expand_N_Op_Rem (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + + Lo : Uint; + Hi : Uint; + OK : Boolean; + + Lneg : Boolean; + Rneg : Boolean; + -- Set if corresponding operand can be negative + + pragma Unreferenced (Hi); + + begin + Binary_Op_Validity_Checks (N); + + if Is_Integer_Type (Etype (N)) then + Apply_Divide_Check (N); + end if; + + -- Apply optimization x rem 1 = 0. We don't really need that with gcc, + -- but it is useful with other back ends (e.g. AAMP), and is certainly + -- harmless. + + if Is_Integer_Type (Etype (N)) + and then Compile_Time_Known_Value (Right) + and then Expr_Value (Right) = Uint_1 + then + -- Call Remove_Side_Effects to ensure that any side effects in the + -- ignored left operand (in particular function calls to user defined + -- functions) are properly executed. + + Remove_Side_Effects (Left); + + Rewrite (N, Make_Integer_Literal (Loc, 0)); + Analyze_And_Resolve (N, Typ); + return; + end if; + + -- Deal with annoying case of largest negative number remainder minus + -- one. Gigi does not handle this case correctly, because it generates + -- a divide instruction which may trap in this case. + + -- In fact the check is quite easy, if the right operand is -1, then + -- the remainder is always 0, and we can just ignore the left operand + -- completely in this case. + + Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True); + Lneg := (not OK) or else Lo < 0; + + Determine_Range (Left, OK, Lo, Hi, Assume_Valid => True); + Rneg := (not OK) or else Lo < 0; + + -- We won't mess with trying to find out if the left operand can really + -- be the largest negative number (that's a pain in the case of private + -- types and this is really marginal). We will just assume that we need + -- the test if the left operand can be negative at all. + + if Lneg and Rneg then + Rewrite (N, + Make_Conditional_Expression (Loc, + Expressions => New_List ( + Make_Op_Eq (Loc, + Left_Opnd => Duplicate_Subexpr (Right), + Right_Opnd => + Unchecked_Convert_To (Typ, Make_Integer_Literal (Loc, -1))), + + Unchecked_Convert_To (Typ, + Make_Integer_Literal (Loc, Uint_0)), + + Relocate_Node (N)))); + + Set_Analyzed (Next (Next (First (Expressions (N))))); + Analyze_And_Resolve (N, Typ); + end if; + end Expand_N_Op_Rem; + + ----------------------------- + -- Expand_N_Op_Rotate_Left -- + ----------------------------- + + procedure Expand_N_Op_Rotate_Left (N : Node_Id) is + begin + Binary_Op_Validity_Checks (N); + end Expand_N_Op_Rotate_Left; + + ------------------------------ + -- Expand_N_Op_Rotate_Right -- + ------------------------------ + + procedure Expand_N_Op_Rotate_Right (N : Node_Id) is + begin + Binary_Op_Validity_Checks (N); + end Expand_N_Op_Rotate_Right; + + ---------------------------- + -- Expand_N_Op_Shift_Left -- + ---------------------------- + + procedure Expand_N_Op_Shift_Left (N : Node_Id) is + begin + Binary_Op_Validity_Checks (N); + end Expand_N_Op_Shift_Left; + + ----------------------------- + -- Expand_N_Op_Shift_Right -- + ----------------------------- + + procedure Expand_N_Op_Shift_Right (N : Node_Id) is + begin + Binary_Op_Validity_Checks (N); + end Expand_N_Op_Shift_Right; + + ---------------------------------------- + -- Expand_N_Op_Shift_Right_Arithmetic -- + ---------------------------------------- + + procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is + begin + Binary_Op_Validity_Checks (N); + end Expand_N_Op_Shift_Right_Arithmetic; + + -------------------------- + -- Expand_N_Op_Subtract -- + -------------------------- + + procedure Expand_N_Op_Subtract (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + + begin + Binary_Op_Validity_Checks (N); + + -- N - 0 = N for integer types + + if Is_Integer_Type (Typ) + and then Compile_Time_Known_Value (Right_Opnd (N)) + and then Expr_Value (Right_Opnd (N)) = 0 + then + Rewrite (N, Left_Opnd (N)); + return; + end if; + + -- Arithmetic overflow checks for signed integer/fixed point types + + if Is_Signed_Integer_Type (Typ) + or else + Is_Fixed_Point_Type (Typ) + then + Apply_Arithmetic_Overflow_Check (N); + + -- VAX floating-point types case + + elsif Vax_Float (Typ) then + Expand_Vax_Arith (N); + end if; + end Expand_N_Op_Subtract; + + --------------------- + -- Expand_N_Op_Xor -- + --------------------- + + procedure Expand_N_Op_Xor (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + + begin + Binary_Op_Validity_Checks (N); + + if Is_Array_Type (Etype (N)) then + Expand_Boolean_Operator (N); + + elsif Is_Boolean_Type (Etype (N)) then + Adjust_Condition (Left_Opnd (N)); + Adjust_Condition (Right_Opnd (N)); + Set_Etype (N, Standard_Boolean); + Adjust_Result_Type (N, Typ); + + elsif Is_Intrinsic_Subprogram (Entity (N)) then + Expand_Intrinsic_Call (N, Entity (N)); + + end if; + end Expand_N_Op_Xor; + + ---------------------- + -- Expand_N_Or_Else -- + ---------------------- + + procedure Expand_N_Or_Else (N : Node_Id) + renames Expand_Short_Circuit_Operator; + + ----------------------------------- + -- Expand_N_Qualified_Expression -- + ----------------------------------- + + procedure Expand_N_Qualified_Expression (N : Node_Id) is + Operand : constant Node_Id := Expression (N); + Target_Type : constant Entity_Id := Entity (Subtype_Mark (N)); + + begin + -- Do validity check if validity checking operands + + if Validity_Checks_On + and then Validity_Check_Operands + then + Ensure_Valid (Operand); + end if; + + -- Apply possible constraint check + + Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True); + + if Do_Range_Check (Operand) then + Set_Do_Range_Check (Operand, False); + Generate_Range_Check (Operand, Target_Type, CE_Range_Check_Failed); + end if; + end Expand_N_Qualified_Expression; + + ------------------------------------ + -- Expand_N_Quantified_Expression -- + ------------------------------------ + + -- We expand: + + -- for all X in range => Cond + + -- into: + + -- T := True; + -- for X in range loop + -- if not Cond then + -- T := False; + -- exit; + -- end if; + -- end loop; + + -- Conversely, an existentially quantified expression: + + -- for some X in range => Cond + + -- becomes: + + -- T := False; + -- for X in range loop + -- if Cond then + -- T := True; + -- exit; + -- end if; + -- end loop; + + -- In both cases, the iteration may be over a container in which case it is + -- given by an iterator specification, not a loop parameter specification. + + procedure Expand_N_Quantified_Expression (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Is_Universal : constant Boolean := All_Present (N); + Actions : constant List_Id := New_List; + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); + Cond : Node_Id; + Decl : Node_Id; + I_Scheme : Node_Id; + Test : Node_Id; + + begin + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), + Expression => + New_Occurrence_Of (Boolean_Literals (Is_Universal), Loc)); + Append_To (Actions, Decl); + + Cond := Relocate_Node (Condition (N)); + + if Is_Universal then + Cond := Make_Op_Not (Loc, Cond); + end if; + + Test := + Make_Implicit_If_Statement (N, + Condition => Cond, + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Tnn, Loc), + Expression => + New_Occurrence_Of (Boolean_Literals (not Is_Universal), Loc)), + Make_Exit_Statement (Loc))); + + if Present (Loop_Parameter_Specification (N)) then + I_Scheme := + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Loop_Parameter_Specification (N)); + else + I_Scheme := + Make_Iteration_Scheme (Loc, + Iterator_Specification => Iterator_Specification (N)); + end if; + + Append_To (Actions, + Make_Loop_Statement (Loc, + Iteration_Scheme => I_Scheme, + Statements => New_List (Test), + End_Label => Empty)); + + -- The components of the scheme have already been analyzed, and the loop + -- parameter declaration has been processed. + + Set_Analyzed (Iteration_Scheme (Last (Actions))); + + Rewrite (N, + Make_Expression_With_Actions (Loc, + Expression => New_Occurrence_Of (Tnn, Loc), + Actions => Actions)); + + Analyze_And_Resolve (N, Standard_Boolean); + end Expand_N_Quantified_Expression; + + --------------------------------- + -- Expand_N_Selected_Component -- + --------------------------------- + + -- If the selector is a discriminant of a concurrent object, rewrite the + -- prefix to denote the corresponding record type. + + procedure Expand_N_Selected_Component (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Par : constant Node_Id := Parent (N); + P : constant Node_Id := Prefix (N); + Ptyp : Entity_Id := Underlying_Type (Etype (P)); + Disc : Entity_Id; + New_N : Node_Id; + Dcon : Elmt_Id; + Dval : Node_Id; + + function In_Left_Hand_Side (Comp : Node_Id) return Boolean; + -- Gigi needs a temporary for prefixes that depend on a discriminant, + -- unless the context of an assignment can provide size information. + -- Don't we have a general routine that does this??? + + ----------------------- + -- In_Left_Hand_Side -- + ----------------------- + + function In_Left_Hand_Side (Comp : Node_Id) return Boolean is + begin + return (Nkind (Parent (Comp)) = N_Assignment_Statement + and then Comp = Name (Parent (Comp))) + or else (Present (Parent (Comp)) + and then Nkind (Parent (Comp)) in N_Subexpr + and then In_Left_Hand_Side (Parent (Comp))); + end In_Left_Hand_Side; + + -- Start of processing for Expand_N_Selected_Component + + begin + -- Insert explicit dereference if required + + if Is_Access_Type (Ptyp) then + Insert_Explicit_Dereference (P); + Analyze_And_Resolve (P, Designated_Type (Ptyp)); + + if Ekind (Etype (P)) = E_Private_Subtype + and then Is_For_Access_Subtype (Etype (P)) + then + Set_Etype (P, Base_Type (Etype (P))); + end if; + + Ptyp := Etype (P); + end if; + + -- Deal with discriminant check required + + if Do_Discriminant_Check (N) then + + -- Present the discriminant checking function to the backend, so that + -- it can inline the call to the function. + + Add_Inlined_Body + (Discriminant_Checking_Func + (Original_Record_Component (Entity (Selector_Name (N))))); + + -- Now reset the flag and generate the call + + Set_Do_Discriminant_Check (N, False); + Generate_Discriminant_Check (N); + end if; + + -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place + -- function, then additional actuals must be passed. + + if Ada_Version >= Ada_2005 + and then Is_Build_In_Place_Function_Call (P) + then + Make_Build_In_Place_Call_In_Anonymous_Context (P); + end if; + + -- Gigi cannot handle unchecked conversions that are the prefix of a + -- selected component with discriminants. This must be checked during + -- expansion, because during analysis the type of the selector is not + -- known at the point the prefix is analyzed. If the conversion is the + -- target of an assignment, then we cannot force the evaluation. + + if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion + and then Has_Discriminants (Etype (N)) + and then not In_Left_Hand_Side (N) + then + Force_Evaluation (Prefix (N)); + end if; + + -- Remaining processing applies only if selector is a discriminant + + if Ekind (Entity (Selector_Name (N))) = E_Discriminant then + + -- If the selector is a discriminant of a constrained record type, + -- we may be able to rewrite the expression with the actual value + -- of the discriminant, a useful optimization in some cases. + + if Is_Record_Type (Ptyp) + and then Has_Discriminants (Ptyp) + and then Is_Constrained (Ptyp) + then + -- Do this optimization for discrete types only, and not for + -- access types (access discriminants get us into trouble!) + + if not Is_Discrete_Type (Etype (N)) then + null; + + -- Don't do this on the left hand of an assignment statement. + -- Normally one would think that references like this would not + -- occur, but they do in generated code, and mean that we really + -- do want to assign the discriminant! + + elsif Nkind (Par) = N_Assignment_Statement + and then Name (Par) = N + then + null; + + -- Don't do this optimization for the prefix of an attribute or + -- the name of an object renaming declaration since these are + -- contexts where we do not want the value anyway. + + elsif (Nkind (Par) = N_Attribute_Reference + and then Prefix (Par) = N) + or else Is_Renamed_Object (N) + then + null; + + -- Don't do this optimization if we are within the code for a + -- discriminant check, since the whole point of such a check may + -- be to verify the condition on which the code below depends! + + elsif Is_In_Discriminant_Check (N) then + null; + + -- Green light to see if we can do the optimization. There is + -- still one condition that inhibits the optimization below but + -- now is the time to check the particular discriminant. + + else + -- Loop through discriminants to find the matching discriminant + -- constraint to see if we can copy it. + + Disc := First_Discriminant (Ptyp); + Dcon := First_Elmt (Discriminant_Constraint (Ptyp)); + Discr_Loop : while Present (Dcon) loop + Dval := Node (Dcon); + + -- Check if this is the matching discriminant + + if Disc = Entity (Selector_Name (N)) then + + -- Here we have the matching discriminant. Check for + -- the case of a discriminant of a component that is + -- constrained by an outer discriminant, which cannot + -- be optimized away. + + if Denotes_Discriminant + (Dval, Check_Concurrent => True) + then + exit Discr_Loop; + + elsif Nkind (Original_Node (Dval)) = N_Selected_Component + and then + Denotes_Discriminant + (Selector_Name (Original_Node (Dval)), True) + then + exit Discr_Loop; + + -- Do not retrieve value if constraint is not static. It + -- is generally not useful, and the constraint may be a + -- rewritten outer discriminant in which case it is in + -- fact incorrect. + + elsif Is_Entity_Name (Dval) + and then Nkind (Parent (Entity (Dval))) + = N_Object_Declaration + and then Present (Expression (Parent (Entity (Dval)))) + and then + not Is_Static_Expression + (Expression (Parent (Entity (Dval)))) + then + exit Discr_Loop; + + -- In the context of a case statement, the expression may + -- have the base type of the discriminant, and we need to + -- preserve the constraint to avoid spurious errors on + -- missing cases. + + elsif Nkind (Parent (N)) = N_Case_Statement + and then Etype (Dval) /= Etype (Disc) + then + Rewrite (N, + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Occurrence_Of (Etype (Disc), Loc), + Expression => + New_Copy_Tree (Dval))); + Analyze_And_Resolve (N, Etype (Disc)); + + -- In case that comes out as a static expression, + -- reset it (a selected component is never static). + + Set_Is_Static_Expression (N, False); + return; + + -- Otherwise we can just copy the constraint, but the + -- result is certainly not static! In some cases the + -- discriminant constraint has been analyzed in the + -- context of the original subtype indication, but for + -- itypes the constraint might not have been analyzed + -- yet, and this must be done now. + + else + Rewrite (N, New_Copy_Tree (Dval)); + Analyze_And_Resolve (N); + Set_Is_Static_Expression (N, False); + return; + end if; + end if; + + Next_Elmt (Dcon); + Next_Discriminant (Disc); + end loop Discr_Loop; + + -- Note: the above loop should always find a matching + -- discriminant, but if it does not, we just missed an + -- optimization due to some glitch (perhaps a previous error), + -- so ignore. + + end if; + end if; + + -- The only remaining processing is in the case of a discriminant of + -- a concurrent object, where we rewrite the prefix to denote the + -- corresponding record type. If the type is derived and has renamed + -- discriminants, use corresponding discriminant, which is the one + -- that appears in the corresponding record. + + if not Is_Concurrent_Type (Ptyp) then + return; + end if; + + Disc := Entity (Selector_Name (N)); + + if Is_Derived_Type (Ptyp) + and then Present (Corresponding_Discriminant (Disc)) + then + Disc := Corresponding_Discriminant (Disc); + end if; + + New_N := + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Corresponding_Record_Type (Ptyp), + New_Copy_Tree (P)), + Selector_Name => Make_Identifier (Loc, Chars (Disc))); + + Rewrite (N, New_N); + Analyze (N); + end if; + end Expand_N_Selected_Component; + + -------------------- + -- Expand_N_Slice -- + -------------------- + + procedure Expand_N_Slice (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Pfx : constant Node_Id := Prefix (N); + Ptp : Entity_Id := Etype (Pfx); + + function Is_Procedure_Actual (N : Node_Id) return Boolean; + -- Check whether the argument is an actual for a procedure call, in + -- which case the expansion of a bit-packed slice is deferred until the + -- call itself is expanded. The reason this is required is that we might + -- have an IN OUT or OUT parameter, and the copy out is essential, and + -- that copy out would be missed if we created a temporary here in + -- Expand_N_Slice. Note that we don't bother to test specifically for an + -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it + -- is harmless to defer expansion in the IN case, since the call + -- processing will still generate the appropriate copy in operation, + -- which will take care of the slice. + + procedure Make_Temporary_For_Slice; + -- Create a named variable for the value of the slice, in cases where + -- the back-end cannot handle it properly, e.g. when packed types or + -- unaligned slices are involved. + + ------------------------- + -- Is_Procedure_Actual -- + ------------------------- + + function Is_Procedure_Actual (N : Node_Id) return Boolean is + Par : Node_Id := Parent (N); + + begin + loop + -- If our parent is a procedure call we can return + + if Nkind (Par) = N_Procedure_Call_Statement then + return True; + + -- If our parent is a type conversion, keep climbing the tree, + -- since a type conversion can be a procedure actual. Also keep + -- climbing if parameter association or a qualified expression, + -- since these are additional cases that do can appear on + -- procedure actuals. + + elsif Nkind_In (Par, N_Type_Conversion, + N_Parameter_Association, + N_Qualified_Expression) + then + Par := Parent (Par); + + -- Any other case is not what we are looking for + + else + return False; + end if; + end loop; + end Is_Procedure_Actual; + + ------------------------------ + -- Make_Temporary_For_Slice -- + ------------------------------ + + procedure Make_Temporary_For_Slice is + Decl : Node_Id; + Ent : constant Entity_Id := Make_Temporary (Loc, 'T', N); + + begin + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Ent, + Object_Definition => New_Occurrence_Of (Typ, Loc)); + + Set_No_Initialization (Decl); + + Insert_Actions (N, New_List ( + Decl, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Ent, Loc), + Expression => Relocate_Node (N)))); + + Rewrite (N, New_Occurrence_Of (Ent, Loc)); + Analyze_And_Resolve (N, Typ); + end Make_Temporary_For_Slice; + + -- Start of processing for Expand_N_Slice + + begin + -- Special handling for access types + + if Is_Access_Type (Ptp) then + + Ptp := Designated_Type (Ptp); + + Rewrite (Pfx, + Make_Explicit_Dereference (Sloc (N), + Prefix => Relocate_Node (Pfx))); + + Analyze_And_Resolve (Pfx, Ptp); + end if; + + -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place + -- function, then additional actuals must be passed. + + if Ada_Version >= Ada_2005 + and then Is_Build_In_Place_Function_Call (Pfx) + then + Make_Build_In_Place_Call_In_Anonymous_Context (Pfx); + end if; + + -- The remaining case to be handled is packed slices. We can leave + -- packed slices as they are in the following situations: + + -- 1. Right or left side of an assignment (we can handle this + -- situation correctly in the assignment statement expansion). + + -- 2. Prefix of indexed component (the slide is optimized away in this + -- case, see the start of Expand_N_Slice.) + + -- 3. Object renaming declaration, since we want the name of the + -- slice, not the value. + + -- 4. Argument to procedure call, since copy-in/copy-out handling may + -- be required, and this is handled in the expansion of call + -- itself. + + -- 5. Prefix of an address attribute (this is an error which is caught + -- elsewhere, and the expansion would interfere with generating the + -- error message). + + if not Is_Packed (Typ) then + + -- Apply transformation for actuals of a function call, where + -- Expand_Actuals is not used. + + if Nkind (Parent (N)) = N_Function_Call + and then Is_Possibly_Unaligned_Slice (N) + then + Make_Temporary_For_Slice; + end if; + + elsif Nkind (Parent (N)) = N_Assignment_Statement + or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement + and then Parent (N) = Name (Parent (Parent (N)))) + then + return; + + elsif Nkind (Parent (N)) = N_Indexed_Component + or else Is_Renamed_Object (N) + or else Is_Procedure_Actual (N) + then + return; + + elsif Nkind (Parent (N)) = N_Attribute_Reference + and then Attribute_Name (Parent (N)) = Name_Address + then + return; + + else + Make_Temporary_For_Slice; + end if; + end Expand_N_Slice; + + ------------------------------ + -- Expand_N_Type_Conversion -- + ------------------------------ + + procedure Expand_N_Type_Conversion (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Operand : constant Node_Id := Expression (N); + Target_Type : constant Entity_Id := Etype (N); + Operand_Type : Entity_Id := Etype (Operand); + + procedure Handle_Changed_Representation; + -- This is called in the case of record and array type conversions to + -- see if there is a change of representation to be handled. Change of + -- representation is actually handled at the assignment statement level, + -- and what this procedure does is rewrite node N conversion as an + -- assignment to temporary. If there is no change of representation, + -- then the conversion node is unchanged. + + procedure Raise_Accessibility_Error; + -- Called when we know that an accessibility check will fail. Rewrites + -- node N to an appropriate raise statement and outputs warning msgs. + -- The Etype of the raise node is set to Target_Type. + + procedure Real_Range_Check; + -- Handles generation of range check for real target value + + ----------------------------------- + -- Handle_Changed_Representation -- + ----------------------------------- + + procedure Handle_Changed_Representation is + Temp : Entity_Id; + Decl : Node_Id; + Odef : Node_Id; + Disc : Node_Id; + N_Ix : Node_Id; + Cons : List_Id; + + begin + -- Nothing else to do if no change of representation + + if Same_Representation (Operand_Type, Target_Type) then + return; + + -- The real change of representation work is done by the assignment + -- statement processing. So if this type conversion is appearing as + -- the expression of an assignment statement, nothing needs to be + -- done to the conversion. + + elsif Nkind (Parent (N)) = N_Assignment_Statement then + return; + + -- Otherwise we need to generate a temporary variable, and do the + -- change of representation assignment into that temporary variable. + -- The conversion is then replaced by a reference to this variable. + + else + Cons := No_List; + + -- If type is unconstrained we have to add a constraint, copied + -- from the actual value of the left hand side. + + if not Is_Constrained (Target_Type) then + if Has_Discriminants (Operand_Type) then + Disc := First_Discriminant (Operand_Type); + + if Disc /= First_Stored_Discriminant (Operand_Type) then + Disc := First_Stored_Discriminant (Operand_Type); + end if; + + Cons := New_List; + while Present (Disc) loop + Append_To (Cons, + Make_Selected_Component (Loc, + Prefix => + Duplicate_Subexpr_Move_Checks (Operand), + Selector_Name => + Make_Identifier (Loc, Chars (Disc)))); + Next_Discriminant (Disc); + end loop; + + elsif Is_Array_Type (Operand_Type) then + N_Ix := First_Index (Target_Type); + Cons := New_List; + + for J in 1 .. Number_Dimensions (Operand_Type) loop + + -- We convert the bounds explicitly. We use an unchecked + -- conversion because bounds checks are done elsewhere. + + Append_To (Cons, + Make_Range (Loc, + Low_Bound => + Unchecked_Convert_To (Etype (N_Ix), + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr_No_Checks + (Operand, Name_Req => True), + Attribute_Name => Name_First, + Expressions => New_List ( + Make_Integer_Literal (Loc, J)))), + + High_Bound => + Unchecked_Convert_To (Etype (N_Ix), + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr_No_Checks + (Operand, Name_Req => True), + Attribute_Name => Name_Last, + Expressions => New_List ( + Make_Integer_Literal (Loc, J)))))); + + Next_Index (N_Ix); + end loop; + end if; + end if; + + Odef := New_Occurrence_Of (Target_Type, Loc); + + if Present (Cons) then + Odef := + Make_Subtype_Indication (Loc, + Subtype_Mark => Odef, + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Cons)); + end if; + + Temp := Make_Temporary (Loc, 'C'); + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => Odef); + + Set_No_Initialization (Decl, True); + + -- Insert required actions. It is essential to suppress checks + -- since we have suppressed default initialization, which means + -- that the variable we create may have no discriminants. + + Insert_Actions (N, + New_List ( + Decl, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Temp, Loc), + Expression => Relocate_Node (N))), + Suppress => All_Checks); + + Rewrite (N, New_Occurrence_Of (Temp, Loc)); + return; + end if; + end Handle_Changed_Representation; + + ------------------------------- + -- Raise_Accessibility_Error -- + ------------------------------- + + procedure Raise_Accessibility_Error is + begin + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Accessibility_Check_Failed)); + Set_Etype (N, Target_Type); + + Error_Msg_N ("?accessibility check failure", N); + Error_Msg_NE + ("\?& will be raised at run time", N, Standard_Program_Error); + end Raise_Accessibility_Error; + + ---------------------- + -- Real_Range_Check -- + ---------------------- + + -- Case of conversions to floating-point or fixed-point. If range checks + -- are enabled and the target type has a range constraint, we convert: + + -- typ (x) + + -- to + + -- Tnn : typ'Base := typ'Base (x); + -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last] + -- Tnn + + -- This is necessary when there is a conversion of integer to float or + -- to fixed-point to ensure that the correct checks are made. It is not + -- necessary for float to float where it is enough to simply set the + -- Do_Range_Check flag. + + procedure Real_Range_Check is + Btyp : constant Entity_Id := Base_Type (Target_Type); + Lo : constant Node_Id := Type_Low_Bound (Target_Type); + Hi : constant Node_Id := Type_High_Bound (Target_Type); + Xtyp : constant Entity_Id := Etype (Operand); + Conv : Node_Id; + Tnn : Entity_Id; + + begin + -- Nothing to do if conversion was rewritten + + if Nkind (N) /= N_Type_Conversion then + return; + end if; + + -- Nothing to do if range checks suppressed, or target has the same + -- range as the base type (or is the base type). + + if Range_Checks_Suppressed (Target_Type) + or else (Lo = Type_Low_Bound (Btyp) + and then + Hi = Type_High_Bound (Btyp)) + then + return; + end if; + + -- Nothing to do if expression is an entity on which checks have been + -- suppressed. + + if Is_Entity_Name (Operand) + and then Range_Checks_Suppressed (Entity (Operand)) + then + return; + end if; + + -- Nothing to do if bounds are all static and we can tell that the + -- expression is within the bounds of the target. Note that if the + -- operand is of an unconstrained floating-point type, then we do + -- not trust it to be in range (might be infinite) + + declare + S_Lo : constant Node_Id := Type_Low_Bound (Xtyp); + S_Hi : constant Node_Id := Type_High_Bound (Xtyp); + + begin + if (not Is_Floating_Point_Type (Xtyp) + or else Is_Constrained (Xtyp)) + and then Compile_Time_Known_Value (S_Lo) + and then Compile_Time_Known_Value (S_Hi) + and then Compile_Time_Known_Value (Hi) + and then Compile_Time_Known_Value (Lo) + then + declare + D_Lov : constant Ureal := Expr_Value_R (Lo); + D_Hiv : constant Ureal := Expr_Value_R (Hi); + S_Lov : Ureal; + S_Hiv : Ureal; + + begin + if Is_Real_Type (Xtyp) then + S_Lov := Expr_Value_R (S_Lo); + S_Hiv := Expr_Value_R (S_Hi); + else + S_Lov := UR_From_Uint (Expr_Value (S_Lo)); + S_Hiv := UR_From_Uint (Expr_Value (S_Hi)); + end if; + + if D_Hiv > D_Lov + and then S_Lov >= D_Lov + and then S_Hiv <= D_Hiv + then + Set_Do_Range_Check (Operand, False); + return; + end if; + end; + end if; + end; + + -- For float to float conversions, we are done + + if Is_Floating_Point_Type (Xtyp) + and then + Is_Floating_Point_Type (Btyp) + then + return; + end if; + + -- Otherwise rewrite the conversion as described above + + Conv := Relocate_Node (N); + Rewrite (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc)); + Set_Etype (Conv, Btyp); + + -- Enable overflow except for case of integer to float conversions, + -- where it is never required, since we can never have overflow in + -- this case. + + if not Is_Integer_Type (Etype (Operand)) then + Enable_Overflow_Check (Conv); + end if; + + Tnn := Make_Temporary (Loc, 'T', Conv); + + Insert_Actions (N, New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Object_Definition => New_Occurrence_Of (Btyp, Loc), + Constant_Present => True, + Expression => Conv), + + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Lt (Loc, + Left_Opnd => New_Occurrence_Of (Tnn, Loc), + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_First, + Prefix => + New_Occurrence_Of (Target_Type, Loc))), + + Right_Opnd => + Make_Op_Gt (Loc, + Left_Opnd => New_Occurrence_Of (Tnn, Loc), + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Last, + Prefix => + New_Occurrence_Of (Target_Type, Loc)))), + Reason => CE_Range_Check_Failed))); + + Rewrite (N, New_Occurrence_Of (Tnn, Loc)); + Analyze_And_Resolve (N, Btyp); + end Real_Range_Check; + + -- Start of processing for Expand_N_Type_Conversion + + begin + -- Nothing at all to do if conversion is to the identical type so remove + -- the conversion completely, it is useless, except that it may carry + -- an Assignment_OK attribute, which must be propagated to the operand. + + if Operand_Type = Target_Type then + if Assignment_OK (N) then + Set_Assignment_OK (Operand); + end if; + + Rewrite (N, Relocate_Node (Operand)); + goto Done; + end if; + + -- Nothing to do if this is the second argument of read. This is a + -- "backwards" conversion that will be handled by the specialized code + -- in attribute processing. + + if Nkind (Parent (N)) = N_Attribute_Reference + and then Attribute_Name (Parent (N)) = Name_Read + and then Next (First (Expressions (Parent (N)))) = N + then + goto Done; + end if; + + -- Check for case of converting to a type that has an invariant + -- associated with it. This required an invariant check. We convert + + -- typ (expr) + + -- into + + -- do invariant_check (typ (expr)) in typ (expr); + + -- using Duplicate_Subexpr to avoid multiple side effects + + -- Note: the Comes_From_Source check, and then the resetting of this + -- flag prevents what would otherwise be an infinite recursion. + + if Has_Invariants (Target_Type) + and then Present (Invariant_Procedure (Target_Type)) + and then Comes_From_Source (N) + then + Set_Comes_From_Source (N, False); + Rewrite (N, + Make_Expression_With_Actions (Loc, + Actions => New_List ( + Make_Invariant_Call (Duplicate_Subexpr (N))), + Expression => Duplicate_Subexpr_No_Checks (N))); + Analyze_And_Resolve (N, Target_Type); + goto Done; + end if; + + -- Here if we may need to expand conversion + + -- If the operand of the type conversion is an arithmetic operation on + -- signed integers, and the based type of the signed integer type in + -- question is smaller than Standard.Integer, we promote both of the + -- operands to type Integer. + + -- For example, if we have + + -- target-type (opnd1 + opnd2) + + -- and opnd1 and opnd2 are of type short integer, then we rewrite + -- this as: + + -- target-type (integer(opnd1) + integer(opnd2)) + + -- We do this because we are always allowed to compute in a larger type + -- if we do the right thing with the result, and in this case we are + -- going to do a conversion which will do an appropriate check to make + -- sure that things are in range of the target type in any case. This + -- avoids some unnecessary intermediate overflows. + + -- We might consider a similar transformation in the case where the + -- target is a real type or a 64-bit integer type, and the operand + -- is an arithmetic operation using a 32-bit integer type. However, + -- we do not bother with this case, because it could cause significant + -- inefficiencies on 32-bit machines. On a 64-bit machine it would be + -- much cheaper, but we don't want different behavior on 32-bit and + -- 64-bit machines. Note that the exclusion of the 64-bit case also + -- handles the configurable run-time cases where 64-bit arithmetic + -- may simply be unavailable. + + -- Note: this circuit is partially redundant with respect to the circuit + -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in + -- the processing here. Also we still need the Checks circuit, since we + -- have to be sure not to generate junk overflow checks in the first + -- place, since it would be trick to remove them here! + + if Integer_Promotion_Possible (N) then + + -- All conditions met, go ahead with transformation + + declare + Opnd : Node_Id; + L, R : Node_Id; + + begin + R := + Make_Type_Conversion (Loc, + Subtype_Mark => New_Reference_To (Standard_Integer, Loc), + Expression => Relocate_Node (Right_Opnd (Operand))); + + Opnd := New_Op_Node (Nkind (Operand), Loc); + Set_Right_Opnd (Opnd, R); + + if Nkind (Operand) in N_Binary_Op then + L := + Make_Type_Conversion (Loc, + Subtype_Mark => New_Reference_To (Standard_Integer, Loc), + Expression => Relocate_Node (Left_Opnd (Operand))); + + Set_Left_Opnd (Opnd, L); + end if; + + Rewrite (N, + Make_Type_Conversion (Loc, + Subtype_Mark => Relocate_Node (Subtype_Mark (N)), + Expression => Opnd)); + + Analyze_And_Resolve (N, Target_Type); + goto Done; + end; + end if; + + -- Do validity check if validity checking operands + + if Validity_Checks_On + and then Validity_Check_Operands + then + Ensure_Valid (Operand); + end if; + + -- Special case of converting from non-standard boolean type + + if Is_Boolean_Type (Operand_Type) + and then (Nonzero_Is_True (Operand_Type)) + then + Adjust_Condition (Operand); + Set_Etype (Operand, Standard_Boolean); + Operand_Type := Standard_Boolean; + end if; + + -- Case of converting to an access type + + if Is_Access_Type (Target_Type) then + + -- Apply an accessibility check when the conversion operand is an + -- access parameter (or a renaming thereof), unless conversion was + -- expanded from an Unchecked_ or Unrestricted_Access attribute. + -- Note that other checks may still need to be applied below (such + -- as tagged type checks). + + if Is_Entity_Name (Operand) + and then + (Is_Formal (Entity (Operand)) + or else + (Present (Renamed_Object (Entity (Operand))) + and then Is_Entity_Name (Renamed_Object (Entity (Operand))) + and then Is_Formal + (Entity (Renamed_Object (Entity (Operand)))))) + and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type + and then (Nkind (Original_Node (N)) /= N_Attribute_Reference + or else Attribute_Name (Original_Node (N)) = Name_Access) + then + Apply_Accessibility_Check + (Operand, Target_Type, Insert_Node => Operand); + + -- If the level of the operand type is statically deeper than the + -- level of the target type, then force Program_Error. Note that this + -- can only occur for cases where the attribute is within the body of + -- an instantiation (otherwise the conversion will already have been + -- rejected as illegal). Note: warnings are issued by the analyzer + -- for the instance cases. + + elsif In_Instance_Body + and then Type_Access_Level (Operand_Type) > + Type_Access_Level (Target_Type) + then + Raise_Accessibility_Error; + + -- When the operand is a selected access discriminant the check needs + -- to be made against the level of the object denoted by the prefix + -- of the selected name. Force Program_Error for this case as well + -- (this accessibility violation can only happen if within the body + -- of an instantiation). + + elsif In_Instance_Body + and then Ekind (Operand_Type) = E_Anonymous_Access_Type + and then Nkind (Operand) = N_Selected_Component + and then Object_Access_Level (Operand) > + Type_Access_Level (Target_Type) + then + Raise_Accessibility_Error; + goto Done; + end if; + end if; + + -- Case of conversions of tagged types and access to tagged types + + -- When needed, that is to say when the expression is class-wide, Add + -- runtime a tag check for (strict) downward conversion by using the + -- membership test, generating: + + -- [constraint_error when Operand not in Target_Type'Class] + + -- or in the access type case + + -- [constraint_error + -- when Operand /= null + -- and then Operand.all not in + -- Designated_Type (Target_Type)'Class] + + if (Is_Access_Type (Target_Type) + and then Is_Tagged_Type (Designated_Type (Target_Type))) + or else Is_Tagged_Type (Target_Type) + then + -- Do not do any expansion in the access type case if the parent is a + -- renaming, since this is an error situation which will be caught by + -- Sem_Ch8, and the expansion can interfere with this error check. + + if Is_Access_Type (Target_Type) and then Is_Renamed_Object (N) then + goto Done; + end if; + + -- Otherwise, proceed with processing tagged conversion + + Tagged_Conversion : declare + Actual_Op_Typ : Entity_Id; + Actual_Targ_Typ : Entity_Id; + Make_Conversion : Boolean := False; + Root_Op_Typ : Entity_Id; + + procedure Make_Tag_Check (Targ_Typ : Entity_Id); + -- Create a membership check to test whether Operand is a member + -- of Targ_Typ. If the original Target_Type is an access, include + -- a test for null value. The check is inserted at N. + + -------------------- + -- Make_Tag_Check -- + -------------------- + + procedure Make_Tag_Check (Targ_Typ : Entity_Id) is + Cond : Node_Id; + + begin + -- Generate: + -- [Constraint_Error + -- when Operand /= null + -- and then Operand.all not in Targ_Typ] + + if Is_Access_Type (Target_Type) then + Cond := + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Ne (Loc, + Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), + Right_Opnd => Make_Null (Loc)), + + Right_Opnd => + Make_Not_In (Loc, + Left_Opnd => + Make_Explicit_Dereference (Loc, + Prefix => Duplicate_Subexpr_No_Checks (Operand)), + Right_Opnd => New_Reference_To (Targ_Typ, Loc))); + + -- Generate: + -- [Constraint_Error when Operand not in Targ_Typ] + + else + Cond := + Make_Not_In (Loc, + Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), + Right_Opnd => New_Reference_To (Targ_Typ, Loc)); + end if; + + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => Cond, + Reason => CE_Tag_Check_Failed)); + end Make_Tag_Check; + + -- Start of processing for Tagged_Conversion + + begin + if Is_Access_Type (Target_Type) then + + -- Handle entities from the limited view + + Actual_Op_Typ := + Available_View (Designated_Type (Operand_Type)); + Actual_Targ_Typ := + Available_View (Designated_Type (Target_Type)); + else + Actual_Op_Typ := Operand_Type; + Actual_Targ_Typ := Target_Type; + end if; + + Root_Op_Typ := Root_Type (Actual_Op_Typ); + + -- Ada 2005 (AI-251): Handle interface type conversion + + if Is_Interface (Actual_Op_Typ) then + Expand_Interface_Conversion (N, Is_Static => False); + goto Done; + end if; + + if not Tag_Checks_Suppressed (Actual_Targ_Typ) then + + -- Create a runtime tag check for a downward class-wide type + -- conversion. + + if Is_Class_Wide_Type (Actual_Op_Typ) + and then Actual_Op_Typ /= Actual_Targ_Typ + and then Root_Op_Typ /= Actual_Targ_Typ + and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ) + then + Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ)); + Make_Conversion := True; + end if; + + -- AI05-0073: If the result subtype of the function is defined + -- by an access_definition designating a specific tagged type + -- T, a check is made that the result value is null or the tag + -- of the object designated by the result value identifies T. + -- Constraint_Error is raised if this check fails. + + if Nkind (Parent (N)) = Sinfo.N_Return_Statement then + declare + Func : Entity_Id; + Func_Typ : Entity_Id; + + begin + -- Climb scope stack looking for the enclosing function + + Func := Current_Scope; + while Present (Func) + and then Ekind (Func) /= E_Function + loop + Func := Scope (Func); + end loop; + + -- The function's return subtype must be defined using + -- an access definition. + + if Nkind (Result_Definition (Parent (Func))) = + N_Access_Definition + then + Func_Typ := Directly_Designated_Type (Etype (Func)); + + -- The return subtype denotes a specific tagged type, + -- in other words, a non class-wide type. + + if Is_Tagged_Type (Func_Typ) + and then not Is_Class_Wide_Type (Func_Typ) + then + Make_Tag_Check (Actual_Targ_Typ); + Make_Conversion := True; + end if; + end if; + end; + end if; + + -- We have generated a tag check for either a class-wide type + -- conversion or for AI05-0073. + + if Make_Conversion then + declare + Conv : Node_Id; + begin + Conv := + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), + Expression => Relocate_Node (Expression (N))); + Rewrite (N, Conv); + Analyze_And_Resolve (N, Target_Type); + end; + end if; + end if; + end Tagged_Conversion; + + -- Case of other access type conversions + + elsif Is_Access_Type (Target_Type) then + Apply_Constraint_Check (Operand, Target_Type); + + -- Case of conversions from a fixed-point type + + -- These conversions require special expansion and processing, found in + -- the Exp_Fixd package. We ignore cases where Conversion_OK is set, + -- since from a semantic point of view, these are simple integer + -- conversions, which do not need further processing. + + elsif Is_Fixed_Point_Type (Operand_Type) + and then not Conversion_OK (N) + then + -- We should never see universal fixed at this case, since the + -- expansion of the constituent divide or multiply should have + -- eliminated the explicit mention of universal fixed. + + pragma Assert (Operand_Type /= Universal_Fixed); + + -- Check for special case of the conversion to universal real that + -- occurs as a result of the use of a round attribute. In this case, + -- the real type for the conversion is taken from the target type of + -- the Round attribute and the result must be marked as rounded. + + if Target_Type = Universal_Real + and then Nkind (Parent (N)) = N_Attribute_Reference + and then Attribute_Name (Parent (N)) = Name_Round + then + Set_Rounded_Result (N); + Set_Etype (N, Etype (Parent (N))); + end if; + + -- Otherwise do correct fixed-conversion, but skip these if the + -- Conversion_OK flag is set, because from a semantic point of view + -- these are simple integer conversions needing no further processing + -- (the backend will simply treat them as integers). + + if not Conversion_OK (N) then + if Is_Fixed_Point_Type (Etype (N)) then + Expand_Convert_Fixed_To_Fixed (N); + Real_Range_Check; + + elsif Is_Integer_Type (Etype (N)) then + Expand_Convert_Fixed_To_Integer (N); + + else + pragma Assert (Is_Floating_Point_Type (Etype (N))); + Expand_Convert_Fixed_To_Float (N); + Real_Range_Check; + end if; + end if; + + -- Case of conversions to a fixed-point type + + -- These conversions require special expansion and processing, found in + -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set, + -- since from a semantic point of view, these are simple integer + -- conversions, which do not need further processing. + + elsif Is_Fixed_Point_Type (Target_Type) + and then not Conversion_OK (N) + then + if Is_Integer_Type (Operand_Type) then + Expand_Convert_Integer_To_Fixed (N); + Real_Range_Check; + else + pragma Assert (Is_Floating_Point_Type (Operand_Type)); + Expand_Convert_Float_To_Fixed (N); + Real_Range_Check; + end if; + + -- Case of float-to-integer conversions + + -- We also handle float-to-fixed conversions with Conversion_OK set + -- since semantically the fixed-point target is treated as though it + -- were an integer in such cases. + + elsif Is_Floating_Point_Type (Operand_Type) + and then + (Is_Integer_Type (Target_Type) + or else + (Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N))) + then + -- One more check here, gcc is still not able to do conversions of + -- this type with proper overflow checking, and so gigi is doing an + -- approximation of what is required by doing floating-point compares + -- with the end-point. But that can lose precision in some cases, and + -- give a wrong result. Converting the operand to Universal_Real is + -- helpful, but still does not catch all cases with 64-bit integers + -- on targets with only 64-bit floats. + + -- The above comment seems obsoleted by Apply_Float_Conversion_Check + -- Can this code be removed ??? + + if Do_Range_Check (Operand) then + Rewrite (Operand, + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Universal_Real, Loc), + Expression => + Relocate_Node (Operand))); + + Set_Etype (Operand, Universal_Real); + Enable_Range_Check (Operand); + Set_Do_Range_Check (Expression (Operand), False); + end if; + + -- Case of array conversions + + -- Expansion of array conversions, add required length/range checks but + -- only do this if there is no change of representation. For handling of + -- this case, see Handle_Changed_Representation. + + elsif Is_Array_Type (Target_Type) then + if Is_Constrained (Target_Type) then + Apply_Length_Check (Operand, Target_Type); + else + Apply_Range_Check (Operand, Target_Type); + end if; + + Handle_Changed_Representation; + + -- Case of conversions of discriminated types + + -- Add required discriminant checks if target is constrained. Again this + -- change is skipped if we have a change of representation. + + elsif Has_Discriminants (Target_Type) + and then Is_Constrained (Target_Type) + then + Apply_Discriminant_Check (Operand, Target_Type); + Handle_Changed_Representation; + + -- Case of all other record conversions. The only processing required + -- is to check for a change of representation requiring the special + -- assignment processing. + + elsif Is_Record_Type (Target_Type) then + + -- Ada 2005 (AI-216): Program_Error is raised when converting from + -- a derived Unchecked_Union type to an unconstrained type that is + -- not Unchecked_Union if the operand lacks inferable discriminants. + + if Is_Derived_Type (Operand_Type) + and then Is_Unchecked_Union (Base_Type (Operand_Type)) + and then not Is_Constrained (Target_Type) + and then not Is_Unchecked_Union (Base_Type (Target_Type)) + and then not Has_Inferable_Discriminants (Operand) + then + -- To prevent Gigi from generating illegal code, we generate a + -- Program_Error node, but we give it the target type of the + -- conversion. + + declare + PE : constant Node_Id := Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction); + + begin + Set_Etype (PE, Target_Type); + Rewrite (N, PE); + + end; + else + Handle_Changed_Representation; + end if; + + -- Case of conversions of enumeration types + + elsif Is_Enumeration_Type (Target_Type) then + + -- Special processing is required if there is a change of + -- representation (from enumeration representation clauses). + + if not Same_Representation (Target_Type, Operand_Type) then + + -- Convert: x(y) to x'val (ytyp'val (y)) + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Target_Type, Loc), + Attribute_Name => Name_Val, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Operand_Type, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List (Operand))))); + + Analyze_And_Resolve (N, Target_Type); + end if; + + -- Case of conversions to floating-point + + elsif Is_Floating_Point_Type (Target_Type) then + Real_Range_Check; + end if; + + -- At this stage, either the conversion node has been transformed into + -- some other equivalent expression, or left as a conversion that can be + -- handled by Gigi, in the following cases: + + -- Conversions with no change of representation or type + + -- Numeric conversions involving integer, floating- and fixed-point + -- values. Fixed-point values are allowed only if Conversion_OK is + -- set, i.e. if the fixed-point values are to be treated as integers. + + -- No other conversions should be passed to Gigi + + -- Check: are these rules stated in sinfo??? if so, why restate here??? + + -- The only remaining step is to generate a range check if we still have + -- a type conversion at this stage and Do_Range_Check is set. For now we + -- do this only for conversions of discrete types. + + if Nkind (N) = N_Type_Conversion + and then Is_Discrete_Type (Etype (N)) + then + declare + Expr : constant Node_Id := Expression (N); + Ftyp : Entity_Id; + Ityp : Entity_Id; + + begin + if Do_Range_Check (Expr) + and then Is_Discrete_Type (Etype (Expr)) + then + Set_Do_Range_Check (Expr, False); + + -- Before we do a range check, we have to deal with treating a + -- fixed-point operand as an integer. The way we do this is + -- simply to do an unchecked conversion to an appropriate + -- integer type large enough to hold the result. + + -- This code is not active yet, because we are only dealing + -- with discrete types so far ??? + + if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer + and then Treat_Fixed_As_Integer (Expr) + then + Ftyp := Base_Type (Etype (Expr)); + + if Esize (Ftyp) >= Esize (Standard_Integer) then + Ityp := Standard_Long_Long_Integer; + else + Ityp := Standard_Integer; + end if; + + Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr)); + end if; + + -- Reset overflow flag, since the range check will include + -- dealing with possible overflow, and generate the check. If + -- Address is either a source type or target type, suppress + -- range check to avoid typing anomalies when it is a visible + -- integer type. + + Set_Do_Overflow_Check (N, False); + if not Is_Descendent_Of_Address (Etype (Expr)) + and then not Is_Descendent_Of_Address (Target_Type) + then + Generate_Range_Check + (Expr, Target_Type, CE_Range_Check_Failed); + end if; + end if; + end; + end if; + + -- Final step, if the result is a type conversion involving Vax_Float + -- types, then it is subject for further special processing. + + if Nkind (N) = N_Type_Conversion + and then (Vax_Float (Operand_Type) or else Vax_Float (Target_Type)) + then + Expand_Vax_Conversion (N); + goto Done; + end if; + + -- Here at end of processing + + <> + -- Apply predicate check if required. Note that we can't just call + -- Apply_Predicate_Check here, because the type looks right after + -- the conversion and it would omit the check. The Comes_From_Source + -- guard is necessary to prevent infinite recursions when we generate + -- internal conversions for the purpose of checking predicates. + + if Present (Predicate_Function (Target_Type)) + and then Target_Type /= Operand_Type + and then Comes_From_Source (N) + then + Insert_Action (N, + Make_Predicate_Check (Target_Type, Duplicate_Subexpr (N))); + end if; + end Expand_N_Type_Conversion; + + ----------------------------------- + -- Expand_N_Unchecked_Expression -- + ----------------------------------- + + -- Remove the unchecked expression node from the tree. Its job was simply + -- to make sure that its constituent expression was handled with checks + -- off, and now that that is done, we can remove it from the tree, and + -- indeed must, since Gigi does not expect to see these nodes. + + procedure Expand_N_Unchecked_Expression (N : Node_Id) is + Exp : constant Node_Id := Expression (N); + begin + Set_Assignment_OK (Exp, Assignment_OK (N) or else Assignment_OK (Exp)); + Rewrite (N, Exp); + end Expand_N_Unchecked_Expression; + + ---------------------------------------- + -- Expand_N_Unchecked_Type_Conversion -- + ---------------------------------------- + + -- If this cannot be handled by Gigi and we haven't already made a + -- temporary for it, do it now. + + procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is + Target_Type : constant Entity_Id := Etype (N); + Operand : constant Node_Id := Expression (N); + Operand_Type : constant Entity_Id := Etype (Operand); + + begin + -- Nothing at all to do if conversion is to the identical type so remove + -- the conversion completely, it is useless, except that it may carry + -- an Assignment_OK indication which must be propagated to the operand. + + if Operand_Type = Target_Type then + + -- Code duplicates Expand_N_Unchecked_Expression above, factor??? + + if Assignment_OK (N) then + Set_Assignment_OK (Operand); + end if; + + Rewrite (N, Relocate_Node (Operand)); + return; + end if; + + -- If we have a conversion of a compile time known value to a target + -- type and the value is in range of the target type, then we can simply + -- replace the construct by an integer literal of the correct type. We + -- only apply this to integer types being converted. Possibly it may + -- apply in other cases, but it is too much trouble to worry about. + + -- Note that we do not do this transformation if the Kill_Range_Check + -- flag is set, since then the value may be outside the expected range. + -- This happens in the Normalize_Scalars case. + + -- We also skip this if either the target or operand type is biased + -- because in this case, the unchecked conversion is supposed to + -- preserve the bit pattern, not the integer value. + + if Is_Integer_Type (Target_Type) + and then not Has_Biased_Representation (Target_Type) + and then Is_Integer_Type (Operand_Type) + and then not Has_Biased_Representation (Operand_Type) + and then Compile_Time_Known_Value (Operand) + and then not Kill_Range_Check (N) + then + declare + Val : constant Uint := Expr_Value (Operand); + + begin + if Compile_Time_Known_Value (Type_Low_Bound (Target_Type)) + and then + Compile_Time_Known_Value (Type_High_Bound (Target_Type)) + and then + Val >= Expr_Value (Type_Low_Bound (Target_Type)) + and then + Val <= Expr_Value (Type_High_Bound (Target_Type)) + then + Rewrite (N, Make_Integer_Literal (Sloc (N), Val)); + + -- If Address is the target type, just set the type to avoid a + -- spurious type error on the literal when Address is a visible + -- integer type. + + if Is_Descendent_Of_Address (Target_Type) then + Set_Etype (N, Target_Type); + else + Analyze_And_Resolve (N, Target_Type); + end if; + + return; + end if; + end; + end if; + + -- Nothing to do if conversion is safe + + if Safe_Unchecked_Type_Conversion (N) then + return; + end if; + + -- Otherwise force evaluation unless Assignment_OK flag is set (this + -- flag indicates ??? -- more comments needed here) + + if Assignment_OK (N) then + null; + else + Force_Evaluation (N); + end if; + end Expand_N_Unchecked_Type_Conversion; + + ---------------------------- + -- Expand_Record_Equality -- + ---------------------------- + + -- For non-variant records, Equality is expanded when needed into: + + -- and then Lhs.Discr1 = Rhs.Discr1 + -- and then ... + -- and then Lhs.Discrn = Rhs.Discrn + -- and then Lhs.Cmp1 = Rhs.Cmp1 + -- and then ... + -- and then Lhs.Cmpn = Rhs.Cmpn + + -- The expression is folded by the back-end for adjacent fields. This + -- function is called for tagged record in only one occasion: for imple- + -- menting predefined primitive equality (see Predefined_Primitives_Bodies) + -- otherwise the primitive "=" is used directly. + + function Expand_Record_Equality + (Nod : Node_Id; + Typ : Entity_Id; + Lhs : Node_Id; + Rhs : Node_Id; + Bodies : List_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Nod); + + Result : Node_Id; + C : Entity_Id; + + First_Time : Boolean := True; + + function Suitable_Element (C : Entity_Id) return Entity_Id; + -- Return the first field to compare beginning with C, skipping the + -- inherited components. + + ---------------------- + -- Suitable_Element -- + ---------------------- + + function Suitable_Element (C : Entity_Id) return Entity_Id is + begin + if No (C) then + return Empty; + + elsif Ekind (C) /= E_Discriminant + and then Ekind (C) /= E_Component + then + return Suitable_Element (Next_Entity (C)); + + elsif Is_Tagged_Type (Typ) + and then C /= Original_Record_Component (C) + then + return Suitable_Element (Next_Entity (C)); + + elsif Chars (C) = Name_uController + or else Chars (C) = Name_uTag + then + return Suitable_Element (Next_Entity (C)); + + elsif Is_Interface (Etype (C)) then + return Suitable_Element (Next_Entity (C)); + + else + return C; + end if; + end Suitable_Element; + + -- Start of processing for Expand_Record_Equality + + begin + -- Generates the following code: (assuming that Typ has one Discr and + -- component C2 is also a record) + + -- True + -- and then Lhs.Discr1 = Rhs.Discr1 + -- and then Lhs.C1 = Rhs.C1 + -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn + -- and then ... + -- and then Lhs.Cmpn = Rhs.Cmpn + + Result := New_Reference_To (Standard_True, Loc); + C := Suitable_Element (First_Entity (Typ)); + while Present (C) loop + declare + New_Lhs : Node_Id; + New_Rhs : Node_Id; + Check : Node_Id; + + begin + if First_Time then + First_Time := False; + New_Lhs := Lhs; + New_Rhs := Rhs; + else + New_Lhs := New_Copy_Tree (Lhs); + New_Rhs := New_Copy_Tree (Rhs); + end if; + + Check := + Expand_Composite_Equality (Nod, Etype (C), + Lhs => + Make_Selected_Component (Loc, + Prefix => New_Lhs, + Selector_Name => New_Reference_To (C, Loc)), + Rhs => + Make_Selected_Component (Loc, + Prefix => New_Rhs, + Selector_Name => New_Reference_To (C, Loc)), + Bodies => Bodies); + + -- If some (sub)component is an unchecked_union, the whole + -- operation will raise program error. + + if Nkind (Check) = N_Raise_Program_Error then + Result := Check; + Set_Etype (Result, Standard_Boolean); + exit; + else + Result := + Make_And_Then (Loc, + Left_Opnd => Result, + Right_Opnd => Check); + end if; + end; + + C := Suitable_Element (Next_Entity (C)); + end loop; + + return Result; + end Expand_Record_Equality; + + ----------------------------------- + -- Expand_Short_Circuit_Operator -- + ----------------------------------- + + -- Deal with special expansion if actions are present for the right operand + -- and deal with optimizing case of arguments being True or False. We also + -- deal with the special case of non-standard boolean values. + + procedure Expand_Short_Circuit_Operator (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + LocR : constant Source_Ptr := Sloc (Right); + Actlist : List_Id; + + Shortcut_Value : constant Boolean := Nkind (N) = N_Or_Else; + Shortcut_Ent : constant Entity_Id := Boolean_Literals (Shortcut_Value); + -- If Left = Shortcut_Value then Right need not be evaluated + + function Make_Test_Expr (Opnd : Node_Id) return Node_Id; + -- For Opnd a boolean expression, return a Boolean expression equivalent + -- to Opnd /= Shortcut_Value. + + -------------------- + -- Make_Test_Expr -- + -------------------- + + function Make_Test_Expr (Opnd : Node_Id) return Node_Id is + begin + if Shortcut_Value then + return Make_Op_Not (Sloc (Opnd), Opnd); + else + return Opnd; + end if; + end Make_Test_Expr; + + Op_Var : Entity_Id; + -- Entity for a temporary variable holding the value of the operator, + -- used for expansion in the case where actions are present. + + -- Start of processing for Expand_Short_Circuit_Operator + + begin + -- Deal with non-standard booleans + + if Is_Boolean_Type (Typ) then + Adjust_Condition (Left); + Adjust_Condition (Right); + Set_Etype (N, Standard_Boolean); + end if; + + -- Check for cases where left argument is known to be True or False + + if Compile_Time_Known_Value (Left) then + + -- Mark SCO for left condition as compile time known + + if Generate_SCO and then Comes_From_Source (Left) then + Set_SCO_Condition (Left, Expr_Value_E (Left) = Standard_True); + end if; + + -- Rewrite True AND THEN Right / False OR ELSE Right to Right. + -- Any actions associated with Right will be executed unconditionally + -- and can thus be inserted into the tree unconditionally. + + if Expr_Value_E (Left) /= Shortcut_Ent then + if Present (Actions (N)) then + Insert_Actions (N, Actions (N)); + end if; + + Rewrite (N, Right); + + -- Rewrite False AND THEN Right / True OR ELSE Right to Left. + -- In this case we can forget the actions associated with Right, + -- since they will never be executed. + + else + Kill_Dead_Code (Right); + Kill_Dead_Code (Actions (N)); + Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc)); + end if; + + Adjust_Result_Type (N, Typ); + return; + end if; + + -- If Actions are present for the right operand, we have to do some + -- special processing. We can't just let these actions filter back into + -- code preceding the short circuit (which is what would have happened + -- if we had not trapped them in the short-circuit form), since they + -- must only be executed if the right operand of the short circuit is + -- executed and not otherwise. + + -- the temporary variable C. + + if Present (Actions (N)) then + Actlist := Actions (N); + + -- The old approach is to expand: + + -- left AND THEN right + + -- into + + -- C : Boolean := False; + -- IF left THEN + -- Actions; + -- IF right THEN + -- C := True; + -- END IF; + -- END IF; + + -- and finally rewrite the operator into a reference to C. Similarly + -- for left OR ELSE right, with negated values. Note that this + -- rewrite causes some difficulties for coverage analysis because + -- of the introduction of the new variable C, which obscures the + -- structure of the test. + + -- We use this "old approach" if use of N_Expression_With_Actions + -- is False (see description in Opt of when this is or is not set). + + if not Use_Expression_With_Actions then + Op_Var := Make_Temporary (Loc, 'C', Related_Node => N); + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => + Op_Var, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc), + Expression => + New_Occurrence_Of (Shortcut_Ent, Loc))); + + Append_To (Actlist, + Make_Implicit_If_Statement (Right, + Condition => Make_Test_Expr (Right), + Then_Statements => New_List ( + Make_Assignment_Statement (LocR, + Name => New_Occurrence_Of (Op_Var, LocR), + Expression => + New_Occurrence_Of + (Boolean_Literals (not Shortcut_Value), LocR))))); + + Insert_Action (N, + Make_Implicit_If_Statement (Left, + Condition => Make_Test_Expr (Left), + Then_Statements => Actlist)); + + Rewrite (N, New_Occurrence_Of (Op_Var, Loc)); + Analyze_And_Resolve (N, Standard_Boolean); + + -- The new approach, activated for now by the use of debug flag + -- -gnatd.X is to use the new Expression_With_Actions node for the + -- right operand of the short-circuit form. This should solve the + -- traceability problems for coverage analysis. + + else + Rewrite (Right, + Make_Expression_With_Actions (LocR, + Expression => Relocate_Node (Right), + Actions => Actlist)); + Set_Actions (N, No_List); + Analyze_And_Resolve (Right, Standard_Boolean); + end if; + + Adjust_Result_Type (N, Typ); + return; + end if; + + -- No actions present, check for cases of right argument True/False + + if Compile_Time_Known_Value (Right) then + + -- Mark SCO for left condition as compile time known + + if Generate_SCO and then Comes_From_Source (Right) then + Set_SCO_Condition (Right, Expr_Value_E (Right) = Standard_True); + end if; + + -- Change (Left and then True), (Left or else False) to Left. + -- Note that we know there are no actions associated with the right + -- operand, since we just checked for this case above. + + if Expr_Value_E (Right) /= Shortcut_Ent then + Rewrite (N, Left); + + -- Change (Left and then False), (Left or else True) to Right, + -- making sure to preserve any side effects associated with the Left + -- operand. + + else + Remove_Side_Effects (Left); + Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc)); + end if; + end if; + + Adjust_Result_Type (N, Typ); + end Expand_Short_Circuit_Operator; + + ------------------------------------- + -- Fixup_Universal_Fixed_Operation -- + ------------------------------------- + + procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is + Conv : constant Node_Id := Parent (N); + + begin + -- We must have a type conversion immediately above us + + pragma Assert (Nkind (Conv) = N_Type_Conversion); + + -- Normally the type conversion gives our target type. The exception + -- occurs in the case of the Round attribute, where the conversion + -- will be to universal real, and our real type comes from the Round + -- attribute (as well as an indication that we must round the result) + + if Nkind (Parent (Conv)) = N_Attribute_Reference + and then Attribute_Name (Parent (Conv)) = Name_Round + then + Set_Etype (N, Etype (Parent (Conv))); + Set_Rounded_Result (N); + + -- Normal case where type comes from conversion above us + + else + Set_Etype (N, Etype (Conv)); + end if; + end Fixup_Universal_Fixed_Operation; + + ------------------------------ + -- Get_Allocator_Final_List -- + ------------------------------ + + function Get_Allocator_Final_List + (N : Node_Id; + T : Entity_Id; + PtrT : Entity_Id) return Entity_Id + is + Loc : constant Source_Ptr := Sloc (N); + + Owner : Entity_Id := PtrT; + -- The entity whose finalization list must be used to attach the + -- allocated object. + + begin + if Ekind (PtrT) = E_Anonymous_Access_Type then + + -- If the context is an access parameter, we need to create a + -- non-anonymous access type in order to have a usable final list, + -- because there is otherwise no pool to which the allocated object + -- can belong. We create both the type and the finalization chain + -- here, because freezing an internal type does not create such a + -- chain. The Final_Chain that is thus created is shared by the + -- access parameter. The access type is tested against the result + -- type of the function to exclude allocators whose type is an + -- anonymous access result type. We freeze the type at once to + -- ensure that it is properly decorated for the back-end, even + -- if the context and current scope is a loop. + + if Nkind (Associated_Node_For_Itype (PtrT)) + in N_Subprogram_Specification + and then + PtrT /= + Etype (Defining_Unit_Name (Associated_Node_For_Itype (PtrT))) + then + Owner := Make_Temporary (Loc, 'J'); + Insert_Action (N, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Owner, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (T, Loc)))); + + Freeze_Before (N, Owner); + Build_Final_List (N, Owner); + Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Owner)); + + -- Ada 2005 (AI-318-02): If the context is a return object + -- declaration, then the anonymous return subtype is defined to have + -- the same accessibility level as that of the function's result + -- subtype, which means that we want the scope where the function is + -- declared. + + elsif Nkind (Associated_Node_For_Itype (PtrT)) = N_Object_Declaration + and then Ekind (Scope (PtrT)) = E_Return_Statement + then + Owner := Scope (Return_Applies_To (Scope (PtrT))); + + -- Case of an access discriminant, or (Ada 2005) of an anonymous + -- access component or anonymous access function result: find the + -- final list associated with the scope of the type. (In the + -- anonymous access component kind, a list controller will have + -- been allocated when freezing the record type, and PtrT has an + -- Associated_Final_Chain attribute designating it.) + + elsif No (Associated_Final_Chain (PtrT)) then + Owner := Scope (PtrT); + end if; + end if; + + return Find_Final_List (Owner); + end Get_Allocator_Final_List; + + --------------------------------- + -- Has_Inferable_Discriminants -- + --------------------------------- + + function Has_Inferable_Discriminants (N : Node_Id) return Boolean is + + function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean; + -- Determines whether the left-most prefix of a selected component is a + -- formal parameter in a subprogram. Assumes N is a selected component. + + -------------------------------- + -- Prefix_Is_Formal_Parameter -- + -------------------------------- + + function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is + Sel_Comp : Node_Id := N; + + begin + -- Move to the left-most prefix by climbing up the tree + + while Present (Parent (Sel_Comp)) + and then Nkind (Parent (Sel_Comp)) = N_Selected_Component + loop + Sel_Comp := Parent (Sel_Comp); + end loop; + + return Ekind (Entity (Prefix (Sel_Comp))) in Formal_Kind; + end Prefix_Is_Formal_Parameter; + + -- Start of processing for Has_Inferable_Discriminants + + begin + -- For identifiers and indexed components, it is sufficient to have a + -- constrained Unchecked_Union nominal subtype. + + if Nkind_In (N, N_Identifier, N_Indexed_Component) then + return Is_Unchecked_Union (Base_Type (Etype (N))) + and then + Is_Constrained (Etype (N)); + + -- For selected components, the subtype of the selector must be a + -- constrained Unchecked_Union. If the component is subject to a + -- per-object constraint, then the enclosing object must have inferable + -- discriminants. + + elsif Nkind (N) = N_Selected_Component then + if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then + + -- A small hack. If we have a per-object constrained selected + -- component of a formal parameter, return True since we do not + -- know the actual parameter association yet. + + if Prefix_Is_Formal_Parameter (N) then + return True; + end if; + + -- Otherwise, check the enclosing object and the selector + + return Has_Inferable_Discriminants (Prefix (N)) + and then + Has_Inferable_Discriminants (Selector_Name (N)); + end if; + + -- The call to Has_Inferable_Discriminants will determine whether + -- the selector has a constrained Unchecked_Union nominal type. + + return Has_Inferable_Discriminants (Selector_Name (N)); + + -- A qualified expression has inferable discriminants if its subtype + -- mark is a constrained Unchecked_Union subtype. + + elsif Nkind (N) = N_Qualified_Expression then + return Is_Unchecked_Union (Subtype_Mark (N)) + and then + Is_Constrained (Subtype_Mark (N)); + + end if; + + return False; + end Has_Inferable_Discriminants; + + ------------------------------- + -- Insert_Dereference_Action -- + ------------------------------- + + procedure Insert_Dereference_Action (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Pool : constant Entity_Id := Associated_Storage_Pool (Typ); + Pnod : constant Node_Id := Parent (N); + + function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean; + -- Return true if type of P is derived from Checked_Pool; + + ----------------------------- + -- Is_Checked_Storage_Pool -- + ----------------------------- + + function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is + T : Entity_Id; + + begin + if No (P) then + return False; + end if; + + T := Etype (P); + while T /= Etype (T) loop + if Is_RTE (T, RE_Checked_Pool) then + return True; + else + T := Etype (T); + end if; + end loop; + + return False; + end Is_Checked_Storage_Pool; + + -- Start of processing for Insert_Dereference_Action + + begin + pragma Assert (Nkind (Pnod) = N_Explicit_Dereference); + + if not (Is_Checked_Storage_Pool (Pool) + and then Comes_From_Source (Original_Node (Pnod))) + then + return; + end if; + + Insert_Action (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + Find_Prim_Op (Etype (Pool), Name_Dereference), Loc), + + Parameter_Associations => New_List ( + + -- Pool + + New_Reference_To (Pool, Loc), + + -- Storage_Address. We use the attribute Pool_Address, which uses + -- the pointer itself to find the address of the object, and which + -- handles unconstrained arrays properly by computing the address + -- of the template. i.e. the correct address of the corresponding + -- allocation. + + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr_Move_Checks (N), + Attribute_Name => Name_Pool_Address), + + -- Size_In_Storage_Elements + + Make_Op_Divide (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + Make_Explicit_Dereference (Loc, + Duplicate_Subexpr_Move_Checks (N)), + Attribute_Name => Name_Size), + Right_Opnd => + Make_Integer_Literal (Loc, System_Storage_Unit)), + + -- Alignment + + Make_Attribute_Reference (Loc, + Prefix => + Make_Explicit_Dereference (Loc, + Duplicate_Subexpr_Move_Checks (N)), + Attribute_Name => Name_Alignment)))); + + exception + when RE_Not_Available => + return; + end Insert_Dereference_Action; + + -------------------------------- + -- Integer_Promotion_Possible -- + -------------------------------- + + function Integer_Promotion_Possible (N : Node_Id) return Boolean is + Operand : constant Node_Id := Expression (N); + Operand_Type : constant Entity_Id := Etype (Operand); + Root_Operand_Type : constant Entity_Id := Root_Type (Operand_Type); + + begin + pragma Assert (Nkind (N) = N_Type_Conversion); + + return + + -- We only do the transformation for source constructs. We assume + -- that the expander knows what it is doing when it generates code. + + Comes_From_Source (N) + + -- If the operand type is Short_Integer or Short_Short_Integer, + -- then we will promote to Integer, which is available on all + -- targets, and is sufficient to ensure no intermediate overflow. + -- Furthermore it is likely to be as efficient or more efficient + -- than using the smaller type for the computation so we do this + -- unconditionally. + + and then + (Root_Operand_Type = Base_Type (Standard_Short_Integer) + or else + Root_Operand_Type = Base_Type (Standard_Short_Short_Integer)) + + -- Test for interesting operation, which includes addition, + -- division, exponentiation, multiplication, subtraction, absolute + -- value and unary negation. Unary "+" is omitted since it is a + -- no-op and thus can't overflow. + + and then Nkind_In (Operand, N_Op_Abs, + N_Op_Add, + N_Op_Divide, + N_Op_Expon, + N_Op_Minus, + N_Op_Multiply, + N_Op_Subtract); + end Integer_Promotion_Possible; + + ------------------------------ + -- Make_Array_Comparison_Op -- + ------------------------------ + + -- This is a hand-coded expansion of the following generic function: + + -- generic + -- type elem is (<>); + -- type index is (<>); + -- type a is array (index range <>) of elem; + + -- function Gnnn (X : a; Y: a) return boolean is + -- J : index := Y'first; + + -- begin + -- if X'length = 0 then + -- return false; + + -- elsif Y'length = 0 then + -- return true; + + -- else + -- for I in X'range loop + -- if X (I) = Y (J) then + -- if J = Y'last then + -- exit; + -- else + -- J := index'succ (J); + -- end if; + + -- else + -- return X (I) > Y (J); + -- end if; + -- end loop; + + -- return X'length > Y'length; + -- end if; + -- end Gnnn; + + -- Note that since we are essentially doing this expansion by hand, we + -- do not need to generate an actual or formal generic part, just the + -- instantiated function itself. + + function Make_Array_Comparison_Op + (Typ : Entity_Id; + Nod : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Nod); + + X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX); + Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY); + I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI); + J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ); + + Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ))); + + Loop_Statement : Node_Id; + Loop_Body : Node_Id; + If_Stat : Node_Id; + Inner_If : Node_Id; + Final_Expr : Node_Id; + Func_Body : Node_Id; + Func_Name : Entity_Id; + Formals : List_Id; + Length1 : Node_Id; + Length2 : Node_Id; + + begin + -- if J = Y'last then + -- exit; + -- else + -- J := index'succ (J); + -- end if; + + Inner_If := + Make_Implicit_If_Statement (Nod, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Reference_To (J, Loc), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Y, Loc), + Attribute_Name => Name_Last)), + + Then_Statements => New_List ( + Make_Exit_Statement (Loc)), + + Else_Statements => + New_List ( + Make_Assignment_Statement (Loc, + Name => New_Reference_To (J, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Index, Loc), + Attribute_Name => Name_Succ, + Expressions => New_List (New_Reference_To (J, Loc)))))); + + -- if X (I) = Y (J) then + -- if ... end if; + -- else + -- return X (I) > Y (J); + -- end if; + + Loop_Body := + Make_Implicit_If_Statement (Nod, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Indexed_Component (Loc, + Prefix => New_Reference_To (X, Loc), + Expressions => New_List (New_Reference_To (I, Loc))), + + Right_Opnd => + Make_Indexed_Component (Loc, + Prefix => New_Reference_To (Y, Loc), + Expressions => New_List (New_Reference_To (J, Loc)))), + + Then_Statements => New_List (Inner_If), + + Else_Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Op_Gt (Loc, + Left_Opnd => + Make_Indexed_Component (Loc, + Prefix => New_Reference_To (X, Loc), + Expressions => New_List (New_Reference_To (I, Loc))), + + Right_Opnd => + Make_Indexed_Component (Loc, + Prefix => New_Reference_To (Y, Loc), + Expressions => New_List ( + New_Reference_To (J, Loc))))))); + + -- for I in X'range loop + -- if ... end if; + -- end loop; + + Loop_Statement := + Make_Implicit_Loop_Statement (Nod, + Identifier => Empty, + + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => I, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (X, Loc), + Attribute_Name => Name_Range))), + + Statements => New_List (Loop_Body)); + + -- if X'length = 0 then + -- return false; + -- elsif Y'length = 0 then + -- return true; + -- else + -- for ... loop ... end loop; + -- return X'length > Y'length; + -- end if; + + Length1 := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (X, Loc), + Attribute_Name => Name_Length); + + Length2 := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Y, Loc), + Attribute_Name => Name_Length); + + Final_Expr := + Make_Op_Gt (Loc, + Left_Opnd => Length1, + Right_Opnd => Length2); + + If_Stat := + Make_Implicit_If_Statement (Nod, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (X, Loc), + Attribute_Name => Name_Length), + Right_Opnd => + Make_Integer_Literal (Loc, 0)), + + Then_Statements => + New_List ( + Make_Simple_Return_Statement (Loc, + Expression => New_Reference_To (Standard_False, Loc))), + + Elsif_Parts => New_List ( + Make_Elsif_Part (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Y, Loc), + Attribute_Name => Name_Length), + Right_Opnd => + Make_Integer_Literal (Loc, 0)), + + Then_Statements => + New_List ( + Make_Simple_Return_Statement (Loc, + Expression => New_Reference_To (Standard_True, Loc))))), + + Else_Statements => New_List ( + Loop_Statement, + Make_Simple_Return_Statement (Loc, + Expression => Final_Expr))); + + -- (X : a; Y: a) + + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => X, + Parameter_Type => New_Reference_To (Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Y, + Parameter_Type => New_Reference_To (Typ, Loc))); + + -- function Gnnn (...) return boolean is + -- J : index := Y'first; + -- begin + -- if ... end if; + -- end Gnnn; + + Func_Name := Make_Temporary (Loc, 'G'); + + Func_Body := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Func_Name, + Parameter_Specifications => Formals, + Result_Definition => New_Reference_To (Standard_Boolean, Loc)), + + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => J, + Object_Definition => New_Reference_To (Index, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Y, Loc), + Attribute_Name => Name_First))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (If_Stat))); + + return Func_Body; + end Make_Array_Comparison_Op; + + --------------------------- + -- Make_Boolean_Array_Op -- + --------------------------- + + -- For logical operations on boolean arrays, expand in line the following, + -- replacing 'and' with 'or' or 'xor' where needed: + + -- function Annn (A : typ; B: typ) return typ is + -- C : typ; + -- begin + -- for J in A'range loop + -- C (J) := A (J) op B (J); + -- end loop; + -- return C; + -- end Annn; + + -- Here typ is the boolean array type + + function Make_Boolean_Array_Op + (Typ : Entity_Id; + N : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + + A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA); + B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB); + C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC); + J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ); + + A_J : Node_Id; + B_J : Node_Id; + C_J : Node_Id; + Op : Node_Id; + + Formals : List_Id; + Func_Name : Entity_Id; + Func_Body : Node_Id; + Loop_Statement : Node_Id; + + begin + A_J := + Make_Indexed_Component (Loc, + Prefix => New_Reference_To (A, Loc), + Expressions => New_List (New_Reference_To (J, Loc))); + + B_J := + Make_Indexed_Component (Loc, + Prefix => New_Reference_To (B, Loc), + Expressions => New_List (New_Reference_To (J, Loc))); + + C_J := + Make_Indexed_Component (Loc, + Prefix => New_Reference_To (C, Loc), + Expressions => New_List (New_Reference_To (J, Loc))); + + if Nkind (N) = N_Op_And then + Op := + Make_Op_And (Loc, + Left_Opnd => A_J, + Right_Opnd => B_J); + + elsif Nkind (N) = N_Op_Or then + Op := + Make_Op_Or (Loc, + Left_Opnd => A_J, + Right_Opnd => B_J); + + else + Op := + Make_Op_Xor (Loc, + Left_Opnd => A_J, + Right_Opnd => B_J); + end if; + + Loop_Statement := + Make_Implicit_Loop_Statement (N, + Identifier => Empty, + + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => J, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (A, Loc), + Attribute_Name => Name_Range))), + + Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => C_J, + Expression => Op))); + + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => A, + Parameter_Type => New_Reference_To (Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => B, + Parameter_Type => New_Reference_To (Typ, Loc))); + + Func_Name := Make_Temporary (Loc, 'A'); + Set_Is_Inlined (Func_Name); + + Func_Body := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Func_Name, + Parameter_Specifications => Formals, + Result_Definition => New_Reference_To (Typ, Loc)), + + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => C, + Object_Definition => New_Reference_To (Typ, Loc))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Loop_Statement, + Make_Simple_Return_Statement (Loc, + Expression => New_Reference_To (C, Loc))))); + + return Func_Body; + end Make_Boolean_Array_Op; + + ------------------------ + -- Rewrite_Comparison -- + ------------------------ + + procedure Rewrite_Comparison (N : Node_Id) is + Warning_Generated : Boolean := False; + -- Set to True if first pass with Assume_Valid generates a warning in + -- which case we skip the second pass to avoid warning overloaded. + + Result : Node_Id; + -- Set to Standard_True or Standard_False + + begin + if Nkind (N) = N_Type_Conversion then + Rewrite_Comparison (Expression (N)); + return; + + elsif Nkind (N) not in N_Op_Compare then + return; + end if; + + -- Now start looking at the comparison in detail. We potentially go + -- through this loop twice. The first time, Assume_Valid is set False + -- in the call to Compile_Time_Compare. If this call results in a + -- clear result of always True or Always False, that's decisive and + -- we are done. Otherwise we repeat the processing with Assume_Valid + -- set to True to generate additional warnings. We can skip that step + -- if Constant_Condition_Warnings is False. + + for AV in False .. True loop + declare + Typ : constant Entity_Id := Etype (N); + Op1 : constant Node_Id := Left_Opnd (N); + Op2 : constant Node_Id := Right_Opnd (N); + + Res : constant Compare_Result := + Compile_Time_Compare (Op1, Op2, Assume_Valid => AV); + -- Res indicates if compare outcome can be compile time determined + + True_Result : Boolean; + False_Result : Boolean; + + begin + case N_Op_Compare (Nkind (N)) is + when N_Op_Eq => + True_Result := Res = EQ; + False_Result := Res = LT or else Res = GT or else Res = NE; + + when N_Op_Ge => + True_Result := Res in Compare_GE; + False_Result := Res = LT; + + if Res = LE + and then Constant_Condition_Warnings + and then Comes_From_Source (Original_Node (N)) + and then Nkind (Original_Node (N)) = N_Op_Ge + and then not In_Instance + and then Is_Integer_Type (Etype (Left_Opnd (N))) + and then not Has_Warnings_Off (Etype (Left_Opnd (N))) + then + Error_Msg_N + ("can never be greater than, could replace by ""'=""?", N); + Warning_Generated := True; + end if; + + when N_Op_Gt => + True_Result := Res = GT; + False_Result := Res in Compare_LE; + + when N_Op_Lt => + True_Result := Res = LT; + False_Result := Res in Compare_GE; + + when N_Op_Le => + True_Result := Res in Compare_LE; + False_Result := Res = GT; + + if Res = GE + and then Constant_Condition_Warnings + and then Comes_From_Source (Original_Node (N)) + and then Nkind (Original_Node (N)) = N_Op_Le + and then not In_Instance + and then Is_Integer_Type (Etype (Left_Opnd (N))) + and then not Has_Warnings_Off (Etype (Left_Opnd (N))) + then + Error_Msg_N + ("can never be less than, could replace by ""'=""?", N); + Warning_Generated := True; + end if; + + when N_Op_Ne => + True_Result := Res = NE or else Res = GT or else Res = LT; + False_Result := Res = EQ; + end case; + + -- If this is the first iteration, then we actually convert the + -- comparison into True or False, if the result is certain. + + if AV = False then + if True_Result or False_Result then + if True_Result then + Result := Standard_True; + else + Result := Standard_False; + end if; + + Rewrite (N, + Convert_To (Typ, + New_Occurrence_Of (Result, Sloc (N)))); + Analyze_And_Resolve (N, Typ); + Warn_On_Known_Condition (N); + return; + end if; + + -- If this is the second iteration (AV = True), and the original + -- node comes from source and we are not in an instance, then give + -- a warning if we know result would be True or False. Note: we + -- know Constant_Condition_Warnings is set if we get here. + + elsif Comes_From_Source (Original_Node (N)) + and then not In_Instance + then + if True_Result then + Error_Msg_N + ("condition can only be False if invalid values present?", + N); + elsif False_Result then + Error_Msg_N + ("condition can only be True if invalid values present?", + N); + end if; + end if; + end; + + -- Skip second iteration if not warning on constant conditions or + -- if the first iteration already generated a warning of some kind or + -- if we are in any case assuming all values are valid (so that the + -- first iteration took care of the valid case). + + exit when not Constant_Condition_Warnings; + exit when Warning_Generated; + exit when Assume_No_Invalid_Values; + end loop; + end Rewrite_Comparison; + + ---------------------------- + -- Safe_In_Place_Array_Op -- + ---------------------------- + + function Safe_In_Place_Array_Op + (Lhs : Node_Id; + Op1 : Node_Id; + Op2 : Node_Id) return Boolean + is + Target : Entity_Id; + + function Is_Safe_Operand (Op : Node_Id) return Boolean; + -- Operand is safe if it cannot overlap part of the target of the + -- operation. If the operand and the target are identical, the operand + -- is safe. The operand can be empty in the case of negation. + + function Is_Unaliased (N : Node_Id) return Boolean; + -- Check that N is a stand-alone entity + + ------------------ + -- Is_Unaliased -- + ------------------ + + function Is_Unaliased (N : Node_Id) return Boolean is + begin + return + Is_Entity_Name (N) + and then No (Address_Clause (Entity (N))) + and then No (Renamed_Object (Entity (N))); + end Is_Unaliased; + + --------------------- + -- Is_Safe_Operand -- + --------------------- + + function Is_Safe_Operand (Op : Node_Id) return Boolean is + begin + if No (Op) then + return True; + + elsif Is_Entity_Name (Op) then + return Is_Unaliased (Op); + + elsif Nkind_In (Op, N_Indexed_Component, N_Selected_Component) then + return Is_Unaliased (Prefix (Op)); + + elsif Nkind (Op) = N_Slice then + return + Is_Unaliased (Prefix (Op)) + and then Entity (Prefix (Op)) /= Target; + + elsif Nkind (Op) = N_Op_Not then + return Is_Safe_Operand (Right_Opnd (Op)); + + else + return False; + end if; + end Is_Safe_Operand; + + -- Start of processing for Is_Safe_In_Place_Array_Op + + begin + -- Skip this processing if the component size is different from system + -- storage unit (since at least for NOT this would cause problems). + + if Component_Size (Etype (Lhs)) /= System_Storage_Unit then + return False; + + -- Cannot do in place stuff on VM_Target since cannot pass addresses + + elsif VM_Target /= No_VM then + return False; + + -- Cannot do in place stuff if non-standard Boolean representation + + elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then + return False; + + elsif not Is_Unaliased (Lhs) then + return False; + + else + Target := Entity (Lhs); + return Is_Safe_Operand (Op1) and then Is_Safe_Operand (Op2); + end if; + end Safe_In_Place_Array_Op; + + ----------------------- + -- Tagged_Membership -- + ----------------------- + + -- There are two different cases to consider depending on whether the right + -- operand is a class-wide type or not. If not we just compare the actual + -- tag of the left expr to the target type tag: + -- + -- Left_Expr.Tag = Right_Type'Tag; + -- + -- If it is a class-wide type we use the RT function CW_Membership which is + -- usually implemented by looking in the ancestor tables contained in the + -- dispatch table pointed by Left_Expr.Tag for Typ'Tag + + -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT + -- function IW_Membership which is usually implemented by looking in the + -- table of abstract interface types plus the ancestor table contained in + -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag + + procedure Tagged_Membership + (N : Node_Id; + SCIL_Node : out Node_Id; + Result : out Node_Id) + is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + Loc : constant Source_Ptr := Sloc (N); + + Left_Type : Entity_Id; + New_Node : Node_Id; + Right_Type : Entity_Id; + Obj_Tag : Node_Id; + + begin + SCIL_Node := Empty; + + -- Handle entities from the limited view + + Left_Type := Available_View (Etype (Left)); + Right_Type := Available_View (Etype (Right)); + + if Is_Class_Wide_Type (Left_Type) then + Left_Type := Root_Type (Left_Type); + end if; + + Obj_Tag := + Make_Selected_Component (Loc, + Prefix => Relocate_Node (Left), + Selector_Name => + New_Reference_To (First_Tag_Component (Left_Type), Loc)); + + if Is_Class_Wide_Type (Right_Type) then + + -- No need to issue a run-time check if we statically know that the + -- result of this membership test is always true. For example, + -- considering the following declarations: + + -- type Iface is interface; + -- type T is tagged null record; + -- type DT is new T and Iface with null record; + + -- Obj1 : T; + -- Obj2 : DT; + + -- These membership tests are always true: + + -- Obj1 in T'Class + -- Obj2 in T'Class; + -- Obj2 in Iface'Class; + + -- We do not need to handle cases where the membership is illegal. + -- For example: + + -- Obj1 in DT'Class; -- Compile time error + -- Obj1 in Iface'Class; -- Compile time error + + if not Is_Class_Wide_Type (Left_Type) + and then (Is_Ancestor (Etype (Right_Type), Left_Type) + or else (Is_Interface (Etype (Right_Type)) + and then Interface_Present_In_Ancestor + (Typ => Left_Type, + Iface => Etype (Right_Type)))) + then + Result := New_Reference_To (Standard_True, Loc); + return; + end if; + + -- Ada 2005 (AI-251): Class-wide applied to interfaces + + if Is_Interface (Etype (Class_Wide_Type (Right_Type))) + + -- Support to: "Iface_CW_Typ in Typ'Class" + + or else Is_Interface (Left_Type) + then + -- Issue error if IW_Membership operation not available in a + -- configurable run time setting. + + if not RTE_Available (RE_IW_Membership) then + Error_Msg_CRT + ("dynamic membership test on interface types", N); + Result := Empty; + return; + end if; + + Result := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Obj_Tag, + Attribute_Name => Name_Address), + New_Reference_To ( + Node (First_Elmt + (Access_Disp_Table (Root_Type (Right_Type)))), + Loc))); + + -- Ada 95: Normal case + + else + Build_CW_Membership (Loc, + Obj_Tag_Node => Obj_Tag, + Typ_Tag_Node => + New_Reference_To ( + Node (First_Elmt + (Access_Disp_Table (Root_Type (Right_Type)))), + Loc), + Related_Nod => N, + New_Node => New_Node); + + -- Generate the SCIL node for this class-wide membership test. + -- Done here because the previous call to Build_CW_Membership + -- relocates Obj_Tag. + + if Generate_SCIL then + SCIL_Node := Make_SCIL_Membership_Test (Sloc (N)); + Set_SCIL_Entity (SCIL_Node, Etype (Right_Type)); + Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag); + end if; + + Result := New_Node; + end if; + + -- Right_Type is not a class-wide type + + else + -- No need to check the tag of the object if Right_Typ is abstract + + if Is_Abstract_Type (Right_Type) then + Result := New_Reference_To (Standard_False, Loc); + + else + Result := + Make_Op_Eq (Loc, + Left_Opnd => Obj_Tag, + Right_Opnd => + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Right_Type))), Loc)); + end if; + end if; + end Tagged_Membership; + + ------------------------------ + -- Unary_Op_Validity_Checks -- + ------------------------------ + + procedure Unary_Op_Validity_Checks (N : Node_Id) is + begin + if Validity_Checks_On and Validity_Check_Operands then + Ensure_Valid (Right_Opnd (N)); + end if; + end Unary_Op_Validity_Checks; + +end Exp_Ch4; diff --git a/gcc/ada/exp_ch4.ads b/gcc/ada/exp_ch4.ads new file mode 100644 index 000000000..804365806 --- /dev/null +++ b/gcc/ada/exp_ch4.ads @@ -0,0 +1,100 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 4 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for chapter 4 constructs + +with Types; use Types; + +package Exp_Ch4 is + + procedure Expand_N_Allocator (N : Node_Id); + procedure Expand_N_And_Then (N : Node_Id); + procedure Expand_N_Case_Expression (N : Node_Id); + procedure Expand_N_Conditional_Expression (N : Node_Id); + procedure Expand_N_Explicit_Dereference (N : Node_Id); + procedure Expand_N_In (N : Node_Id); + procedure Expand_N_Indexed_Component (N : Node_Id); + procedure Expand_N_Not_In (N : Node_Id); + procedure Expand_N_Null (N : Node_Id); + procedure Expand_N_Op_Abs (N : Node_Id); + procedure Expand_N_Op_Add (N : Node_Id); + procedure Expand_N_Op_And (N : Node_Id); + procedure Expand_N_Op_Concat (N : Node_Id); + procedure Expand_N_Op_Divide (N : Node_Id); + procedure Expand_N_Op_Expon (N : Node_Id); + procedure Expand_N_Op_Eq (N : Node_Id); + procedure Expand_N_Op_Ge (N : Node_Id); + procedure Expand_N_Op_Gt (N : Node_Id); + procedure Expand_N_Op_Le (N : Node_Id); + procedure Expand_N_Op_Lt (N : Node_Id); + procedure Expand_N_Op_Minus (N : Node_Id); + procedure Expand_N_Op_Mod (N : Node_Id); + procedure Expand_N_Op_Multiply (N : Node_Id); + procedure Expand_N_Op_Ne (N : Node_Id); + procedure Expand_N_Op_Not (N : Node_Id); + procedure Expand_N_Op_Or (N : Node_Id); + procedure Expand_N_Op_Plus (N : Node_Id); + procedure Expand_N_Op_Rem (N : Node_Id); + procedure Expand_N_Op_Rotate_Left (N : Node_Id); + procedure Expand_N_Op_Rotate_Right (N : Node_Id); + procedure Expand_N_Op_Shift_Left (N : Node_Id); + procedure Expand_N_Op_Shift_Right (N : Node_Id); + procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id); + procedure Expand_N_Op_Subtract (N : Node_Id); + procedure Expand_N_Op_Xor (N : Node_Id); + procedure Expand_N_Or_Else (N : Node_Id); + procedure Expand_N_Qualified_Expression (N : Node_Id); + procedure Expand_N_Quantified_Expression (N : Node_Id); + procedure Expand_N_Selected_Component (N : Node_Id); + procedure Expand_N_Slice (N : Node_Id); + procedure Expand_N_Type_Conversion (N : Node_Id); + procedure Expand_N_Unchecked_Expression (N : Node_Id); + procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id); + + function Expand_Record_Equality + (Nod : Node_Id; + Typ : Entity_Id; + Lhs : Node_Id; + Rhs : Node_Id; + Bodies : List_Id) + return Node_Id; + -- Expand a record equality into an expression that compares the fields + -- individually to yield the required Boolean result. Loc is the + -- location for the generated nodes. Typ is the type of the record, and + -- Lhs, Rhs are the record expressions to be compared, these + -- expressions need not to be analyzed but have to be side-effect free. + -- Bodies is a list on which to attach bodies of local functions that + -- are created in the process. This is the responsibility of the caller + -- to insert those bodies at the right place. Nod provides the Sloc + -- value for generated code. + + function Integer_Promotion_Possible (N : Node_Id) return Boolean; + -- Returns true if the node is a type conversion whose operand is an + -- arithmetic operation on signed integers, and the base type of the + -- signed integer type is smaller than Standard.Integer. In such case we + -- have special circuitry in Expand_N_Type_Conversion to promote both of + -- the operands to type Integer. + +end Exp_Ch4; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb new file mode 100644 index 000000000..bdd5d3adc --- /dev/null +++ b/gcc/ada/exp_ch5.adb @@ -0,0 +1,3933 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 5 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Debug; use Debug; +with Einfo; use Einfo; +with Exp_Aggr; use Exp_Aggr; +with Exp_Ch6; use Exp_Ch6; +with Exp_Ch7; use Exp_Ch7; +with Exp_Ch11; use Exp_Ch11; +with Exp_Dbug; use Exp_Dbug; +with Exp_Pakd; use Exp_Pakd; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sinfo; use Sinfo; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch13; use Sem_Ch13; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; +with Validsw; use Validsw; + +package body Exp_Ch5 is + + function Change_Of_Representation (N : Node_Id) return Boolean; + -- Determine if the right hand side of the assignment N is a type + -- conversion which requires a change of representation. Called + -- only for the array and record cases. + + procedure Expand_Assign_Array (N : Node_Id; Rhs : Node_Id); + -- N is an assignment which assigns an array value. This routine process + -- the various special cases and checks required for such assignments, + -- including change of representation. Rhs is normally simply the right + -- hand side of the assignment, except that if the right hand side is + -- a type conversion or a qualified expression, then the Rhs is the + -- actual expression inside any such type conversions or qualifications. + + function Expand_Assign_Array_Loop + (N : Node_Id; + Larray : Entity_Id; + Rarray : Entity_Id; + L_Type : Entity_Id; + R_Type : Entity_Id; + Ndim : Pos; + Rev : Boolean) return Node_Id; + -- N is an assignment statement which assigns an array value. This routine + -- expands the assignment into a loop (or nested loops for the case of a + -- multi-dimensional array) to do the assignment component by component. + -- Larray and Rarray are the entities of the actual arrays on the left + -- hand and right hand sides. L_Type and R_Type are the types of these + -- arrays (which may not be the same, due to either sliding, or to a + -- change of representation case). Ndim is the number of dimensions and + -- the parameter Rev indicates if the loops run normally (Rev = False), + -- or reversed (Rev = True). The value returned is the constructed + -- loop statement. Auxiliary declarations are inserted before node N + -- using the standard Insert_Actions mechanism. + + procedure Expand_Assign_Record (N : Node_Id); + -- N is an assignment of a non-tagged record value. This routine handles + -- the case where the assignment must be made component by component, + -- either because the target is not byte aligned, or there is a change + -- of representation, or when we have a tagged type with a representation + -- clause (this last case is required because holes in the tagged type + -- might be filled with components from child types). + + procedure Expand_Iterator_Loop (N : Node_Id); + -- Expand loop over arrays and containers that uses the form "for X of C" + -- with an optional subtype mark, or "for Y in C". + + procedure Expand_Predicated_Loop (N : Node_Id); + -- Expand for loop over predicated subtype + + function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id; + -- Generate the necessary code for controlled and tagged assignment, that + -- is to say, finalization of the target before, adjustment of the target + -- after and save and restore of the tag and finalization pointers which + -- are not 'part of the value' and must not be changed upon assignment. N + -- is the original Assignment node. + + ------------------------------ + -- Change_Of_Representation -- + ------------------------------ + + function Change_Of_Representation (N : Node_Id) return Boolean is + Rhs : constant Node_Id := Expression (N); + begin + return + Nkind (Rhs) = N_Type_Conversion + and then + not Same_Representation (Etype (Rhs), Etype (Expression (Rhs))); + end Change_Of_Representation; + + ------------------------- + -- Expand_Assign_Array -- + ------------------------- + + -- There are two issues here. First, do we let Gigi do a block move, or + -- do we expand out into a loop? Second, we need to set the two flags + -- Forwards_OK and Backwards_OK which show whether the block move (or + -- corresponding loops) can be legitimately done in a forwards (low to + -- high) or backwards (high to low) manner. + + procedure Expand_Assign_Array (N : Node_Id; Rhs : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Lhs : constant Node_Id := Name (N); + + Act_Lhs : constant Node_Id := Get_Referenced_Object (Lhs); + Act_Rhs : Node_Id := Get_Referenced_Object (Rhs); + + L_Type : constant Entity_Id := + Underlying_Type (Get_Actual_Subtype (Act_Lhs)); + R_Type : Entity_Id := + Underlying_Type (Get_Actual_Subtype (Act_Rhs)); + + L_Slice : constant Boolean := Nkind (Act_Lhs) = N_Slice; + R_Slice : constant Boolean := Nkind (Act_Rhs) = N_Slice; + + Crep : constant Boolean := Change_Of_Representation (N); + + Larray : Node_Id; + Rarray : Node_Id; + + Ndim : constant Pos := Number_Dimensions (L_Type); + + Loop_Required : Boolean := False; + -- This switch is set to True if the array move must be done using + -- an explicit front end generated loop. + + procedure Apply_Dereference (Arg : Node_Id); + -- If the argument is an access to an array, and the assignment is + -- converted into a procedure call, apply explicit dereference. + + function Has_Address_Clause (Exp : Node_Id) return Boolean; + -- Test if Exp is a reference to an array whose declaration has + -- an address clause, or it is a slice of such an array. + + function Is_Formal_Array (Exp : Node_Id) return Boolean; + -- Test if Exp is a reference to an array which is either a formal + -- parameter or a slice of a formal parameter. These are the cases + -- where hidden aliasing can occur. + + function Is_Non_Local_Array (Exp : Node_Id) return Boolean; + -- Determine if Exp is a reference to an array variable which is other + -- than an object defined in the current scope, or a slice of such + -- an object. Such objects can be aliased to parameters (unlike local + -- array references). + + ----------------------- + -- Apply_Dereference -- + ----------------------- + + procedure Apply_Dereference (Arg : Node_Id) is + Typ : constant Entity_Id := Etype (Arg); + begin + if Is_Access_Type (Typ) then + Rewrite (Arg, Make_Explicit_Dereference (Loc, + Prefix => Relocate_Node (Arg))); + Analyze_And_Resolve (Arg, Designated_Type (Typ)); + end if; + end Apply_Dereference; + + ------------------------ + -- Has_Address_Clause -- + ------------------------ + + function Has_Address_Clause (Exp : Node_Id) return Boolean is + begin + return + (Is_Entity_Name (Exp) and then + Present (Address_Clause (Entity (Exp)))) + or else + (Nkind (Exp) = N_Slice and then Has_Address_Clause (Prefix (Exp))); + end Has_Address_Clause; + + --------------------- + -- Is_Formal_Array -- + --------------------- + + function Is_Formal_Array (Exp : Node_Id) return Boolean is + begin + return + (Is_Entity_Name (Exp) and then Is_Formal (Entity (Exp))) + or else + (Nkind (Exp) = N_Slice and then Is_Formal_Array (Prefix (Exp))); + end Is_Formal_Array; + + ------------------------ + -- Is_Non_Local_Array -- + ------------------------ + + function Is_Non_Local_Array (Exp : Node_Id) return Boolean is + begin + return (Is_Entity_Name (Exp) + and then Scope (Entity (Exp)) /= Current_Scope) + or else (Nkind (Exp) = N_Slice + and then Is_Non_Local_Array (Prefix (Exp))); + end Is_Non_Local_Array; + + -- Determine if Lhs, Rhs are formal arrays or nonlocal arrays + + Lhs_Formal : constant Boolean := Is_Formal_Array (Act_Lhs); + Rhs_Formal : constant Boolean := Is_Formal_Array (Act_Rhs); + + Lhs_Non_Local_Var : constant Boolean := Is_Non_Local_Array (Act_Lhs); + Rhs_Non_Local_Var : constant Boolean := Is_Non_Local_Array (Act_Rhs); + + -- Start of processing for Expand_Assign_Array + + begin + -- Deal with length check. Note that the length check is done with + -- respect to the right hand side as given, not a possible underlying + -- renamed object, since this would generate incorrect extra checks. + + Apply_Length_Check (Rhs, L_Type); + + -- We start by assuming that the move can be done in either direction, + -- i.e. that the two sides are completely disjoint. + + Set_Forwards_OK (N, True); + Set_Backwards_OK (N, True); + + -- Normally it is only the slice case that can lead to overlap, and + -- explicit checks for slices are made below. But there is one case + -- where the slice can be implicit and invisible to us: when we have a + -- one dimensional array, and either both operands are parameters, or + -- one is a parameter (which can be a slice passed by reference) and the + -- other is a non-local variable. In this case the parameter could be a + -- slice that overlaps with the other operand. + + -- However, if the array subtype is a constrained first subtype in the + -- parameter case, then we don't have to worry about overlap, since + -- slice assignments aren't possible (other than for a slice denoting + -- the whole array). + + -- Note: No overlap is possible if there is a change of representation, + -- so we can exclude this case. + + if Ndim = 1 + and then not Crep + and then + ((Lhs_Formal and Rhs_Formal) + or else + (Lhs_Formal and Rhs_Non_Local_Var) + or else + (Rhs_Formal and Lhs_Non_Local_Var)) + and then + (not Is_Constrained (Etype (Lhs)) + or else not Is_First_Subtype (Etype (Lhs))) + + -- In the case of compiling for the Java or .NET Virtual Machine, + -- slices are always passed by making a copy, so we don't have to + -- worry about overlap. We also want to prevent generation of "<" + -- comparisons for array addresses, since that's a meaningless + -- operation on the VM. + + and then VM_Target = No_VM + then + Set_Forwards_OK (N, False); + Set_Backwards_OK (N, False); + + -- Note: the bit-packed case is not worrisome here, since if we have + -- a slice passed as a parameter, it is always aligned on a byte + -- boundary, and if there are no explicit slices, the assignment + -- can be performed directly. + end if; + + -- If either operand has an address clause clear Backwards_OK and + -- Forwards_OK, since we cannot tell if the operands overlap. We + -- exclude this treatment when Rhs is an aggregate, since we know + -- that overlap can't occur. + + if (Has_Address_Clause (Lhs) and then Nkind (Rhs) /= N_Aggregate) + or else Has_Address_Clause (Rhs) + then + Set_Forwards_OK (N, False); + Set_Backwards_OK (N, False); + end if; + + -- We certainly must use a loop for change of representation and also + -- we use the operand of the conversion on the right hand side as the + -- effective right hand side (the component types must match in this + -- situation). + + if Crep then + Act_Rhs := Get_Referenced_Object (Rhs); + R_Type := Get_Actual_Subtype (Act_Rhs); + Loop_Required := True; + + -- We require a loop if the left side is possibly bit unaligned + + elsif Possible_Bit_Aligned_Component (Lhs) + or else + Possible_Bit_Aligned_Component (Rhs) + then + Loop_Required := True; + + -- Arrays with controlled components are expanded into a loop to force + -- calls to Adjust at the component level. + + elsif Has_Controlled_Component (L_Type) then + Loop_Required := True; + + -- If object is atomic, we cannot tolerate a loop + + elsif Is_Atomic_Object (Act_Lhs) + or else + Is_Atomic_Object (Act_Rhs) + then + return; + + -- Loop is required if we have atomic components since we have to + -- be sure to do any accesses on an element by element basis. + + elsif Has_Atomic_Components (L_Type) + or else Has_Atomic_Components (R_Type) + or else Is_Atomic (Component_Type (L_Type)) + or else Is_Atomic (Component_Type (R_Type)) + then + Loop_Required := True; + + -- Case where no slice is involved + + elsif not L_Slice and not R_Slice then + + -- The following code deals with the case of unconstrained bit packed + -- arrays. The problem is that the template for such arrays contains + -- the bounds of the actual source level array, but the copy of an + -- entire array requires the bounds of the underlying array. It would + -- be nice if the back end could take care of this, but right now it + -- does not know how, so if we have such a type, then we expand out + -- into a loop, which is inefficient but works correctly. If we don't + -- do this, we get the wrong length computed for the array to be + -- moved. The two cases we need to worry about are: + + -- Explicit dereference of an unconstrained packed array type as in + -- the following example: + + -- procedure C52 is + -- type BITS is array(INTEGER range <>) of BOOLEAN; + -- pragma PACK(BITS); + -- type A is access BITS; + -- P1,P2 : A; + -- begin + -- P1 := new BITS (1 .. 65_535); + -- P2 := new BITS (1 .. 65_535); + -- P2.ALL := P1.ALL; + -- end C52; + + -- A formal parameter reference with an unconstrained bit array type + -- is the other case we need to worry about (here we assume the same + -- BITS type declared above): + + -- procedure Write_All (File : out BITS; Contents : BITS); + -- begin + -- File.Storage := Contents; + -- end Write_All; + + -- We expand to a loop in either of these two cases + + -- Question for future thought. Another potentially more efficient + -- approach would be to create the actual subtype, and then do an + -- unchecked conversion to this actual subtype ??? + + Check_Unconstrained_Bit_Packed_Array : declare + + function Is_UBPA_Reference (Opnd : Node_Id) return Boolean; + -- Function to perform required test for the first case, above + -- (dereference of an unconstrained bit packed array). + + ----------------------- + -- Is_UBPA_Reference -- + ----------------------- + + function Is_UBPA_Reference (Opnd : Node_Id) return Boolean is + Typ : constant Entity_Id := Underlying_Type (Etype (Opnd)); + P_Type : Entity_Id; + Des_Type : Entity_Id; + + begin + if Present (Packed_Array_Type (Typ)) + and then Is_Array_Type (Packed_Array_Type (Typ)) + and then not Is_Constrained (Packed_Array_Type (Typ)) + then + return True; + + elsif Nkind (Opnd) = N_Explicit_Dereference then + P_Type := Underlying_Type (Etype (Prefix (Opnd))); + + if not Is_Access_Type (P_Type) then + return False; + + else + Des_Type := Designated_Type (P_Type); + return + Is_Bit_Packed_Array (Des_Type) + and then not Is_Constrained (Des_Type); + end if; + + else + return False; + end if; + end Is_UBPA_Reference; + + -- Start of processing for Check_Unconstrained_Bit_Packed_Array + + begin + if Is_UBPA_Reference (Lhs) + or else + Is_UBPA_Reference (Rhs) + then + Loop_Required := True; + + -- Here if we do not have the case of a reference to a bit packed + -- unconstrained array case. In this case gigi can most certainly + -- handle the assignment if a forwards move is allowed. + + -- (could it handle the backwards case also???) + + elsif Forwards_OK (N) then + return; + end if; + end Check_Unconstrained_Bit_Packed_Array; + + -- The back end can always handle the assignment if the right side is a + -- string literal (note that overlap is definitely impossible in this + -- case). If the type is packed, a string literal is always converted + -- into an aggregate, except in the case of a null slice, for which no + -- aggregate can be written. In that case, rewrite the assignment as a + -- null statement, a length check has already been emitted to verify + -- that the range of the left-hand side is empty. + + -- Note that this code is not executed if we have an assignment of a + -- string literal to a non-bit aligned component of a record, a case + -- which cannot be handled by the backend. + + elsif Nkind (Rhs) = N_String_Literal then + if String_Length (Strval (Rhs)) = 0 + and then Is_Bit_Packed_Array (L_Type) + then + Rewrite (N, Make_Null_Statement (Loc)); + Analyze (N); + end if; + + return; + + -- If either operand is bit packed, then we need a loop, since we can't + -- be sure that the slice is byte aligned. Similarly, if either operand + -- is a possibly unaligned slice, then we need a loop (since the back + -- end cannot handle unaligned slices). + + elsif Is_Bit_Packed_Array (L_Type) + or else Is_Bit_Packed_Array (R_Type) + or else Is_Possibly_Unaligned_Slice (Lhs) + or else Is_Possibly_Unaligned_Slice (Rhs) + then + Loop_Required := True; + + -- If we are not bit-packed, and we have only one slice, then no overlap + -- is possible except in the parameter case, so we can let the back end + -- handle things. + + elsif not (L_Slice and R_Slice) then + if Forwards_OK (N) then + return; + end if; + end if; + + -- If the right-hand side is a string literal, introduce a temporary for + -- it, for use in the generated loop that will follow. + + if Nkind (Rhs) = N_String_Literal then + declare + Temp : constant Entity_Id := Make_Temporary (Loc, 'T', Rhs); + Decl : Node_Id; + + begin + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Occurrence_Of (L_Type, Loc), + Expression => Relocate_Node (Rhs)); + + Insert_Action (N, Decl); + Rewrite (Rhs, New_Occurrence_Of (Temp, Loc)); + R_Type := Etype (Temp); + end; + end if; + + -- Come here to complete the analysis + + -- Loop_Required: Set to True if we know that a loop is required + -- regardless of overlap considerations. + + -- Forwards_OK: Set to False if we already know that a forwards + -- move is not safe, else set to True. + + -- Backwards_OK: Set to False if we already know that a backwards + -- move is not safe, else set to True + + -- Our task at this stage is to complete the overlap analysis, which can + -- result in possibly setting Forwards_OK or Backwards_OK to False, and + -- then generating the final code, either by deciding that it is OK + -- after all to let Gigi handle it, or by generating appropriate code + -- in the front end. + + declare + L_Index_Typ : constant Node_Id := Etype (First_Index (L_Type)); + R_Index_Typ : constant Node_Id := Etype (First_Index (R_Type)); + + Left_Lo : constant Node_Id := Type_Low_Bound (L_Index_Typ); + Left_Hi : constant Node_Id := Type_High_Bound (L_Index_Typ); + Right_Lo : constant Node_Id := Type_Low_Bound (R_Index_Typ); + Right_Hi : constant Node_Id := Type_High_Bound (R_Index_Typ); + + Act_L_Array : Node_Id; + Act_R_Array : Node_Id; + + Cleft_Lo : Node_Id; + Cright_Lo : Node_Id; + Condition : Node_Id; + + Cresult : Compare_Result; + + begin + -- Get the expressions for the arrays. If we are dealing with a + -- private type, then convert to the underlying type. We can do + -- direct assignments to an array that is a private type, but we + -- cannot assign to elements of the array without this extra + -- unchecked conversion. + + -- Note: We propagate Parent to the conversion nodes to generate + -- a well-formed subtree. + + if Nkind (Act_Lhs) = N_Slice then + Larray := Prefix (Act_Lhs); + else + Larray := Act_Lhs; + + if Is_Private_Type (Etype (Larray)) then + declare + Par : constant Node_Id := Parent (Larray); + begin + Larray := + Unchecked_Convert_To + (Underlying_Type (Etype (Larray)), Larray); + Set_Parent (Larray, Par); + end; + end if; + end if; + + if Nkind (Act_Rhs) = N_Slice then + Rarray := Prefix (Act_Rhs); + else + Rarray := Act_Rhs; + + if Is_Private_Type (Etype (Rarray)) then + declare + Par : constant Node_Id := Parent (Rarray); + begin + Rarray := + Unchecked_Convert_To + (Underlying_Type (Etype (Rarray)), Rarray); + Set_Parent (Rarray, Par); + end; + end if; + end if; + + -- If both sides are slices, we must figure out whether it is safe + -- to do the move in one direction or the other. It is always safe + -- if there is a change of representation since obviously two arrays + -- with different representations cannot possibly overlap. + + if (not Crep) and L_Slice and R_Slice then + Act_L_Array := Get_Referenced_Object (Prefix (Act_Lhs)); + Act_R_Array := Get_Referenced_Object (Prefix (Act_Rhs)); + + -- If both left and right hand arrays are entity names, and refer + -- to different entities, then we know that the move is safe (the + -- two storage areas are completely disjoint). + + if Is_Entity_Name (Act_L_Array) + and then Is_Entity_Name (Act_R_Array) + and then Entity (Act_L_Array) /= Entity (Act_R_Array) + then + null; + + -- Otherwise, we assume the worst, which is that the two arrays + -- are the same array. There is no need to check if we know that + -- is the case, because if we don't know it, we still have to + -- assume it! + + -- Generally if the same array is involved, then we have an + -- overlapping case. We will have to really assume the worst (i.e. + -- set neither of the OK flags) unless we can determine the lower + -- or upper bounds at compile time and compare them. + + else + Cresult := + Compile_Time_Compare + (Left_Lo, Right_Lo, Assume_Valid => True); + + if Cresult = Unknown then + Cresult := + Compile_Time_Compare + (Left_Hi, Right_Hi, Assume_Valid => True); + end if; + + case Cresult is + when LT | LE | EQ => Set_Backwards_OK (N, False); + when GT | GE => Set_Forwards_OK (N, False); + when NE | Unknown => Set_Backwards_OK (N, False); + Set_Forwards_OK (N, False); + end case; + end if; + end if; + + -- If after that analysis Loop_Required is False, meaning that we + -- have not discovered some non-overlap reason for requiring a loop, + -- then the outcome depends on the capabilities of the back end. + + if not Loop_Required then + + -- The GCC back end can deal with all cases of overlap by falling + -- back to memmove if it cannot use a more efficient approach. + + if VM_Target = No_VM and not AAMP_On_Target then + return; + + -- Assume other back ends can handle it if Forwards_OK is set + + elsif Forwards_OK (N) then + return; + + -- If Forwards_OK is not set, the back end will need something + -- like memmove to handle the move. For now, this processing is + -- activated using the .s debug flag (-gnatd.s). + + elsif Debug_Flag_Dot_S then + return; + end if; + end if; + + -- At this stage we have to generate an explicit loop, and we have + -- the following cases: + + -- Forwards_OK = True + + -- Rnn : right_index := right_index'First; + -- for Lnn in left-index loop + -- left (Lnn) := right (Rnn); + -- Rnn := right_index'Succ (Rnn); + -- end loop; + + -- Note: the above code MUST be analyzed with checks off, because + -- otherwise the Succ could overflow. But in any case this is more + -- efficient! + + -- Forwards_OK = False, Backwards_OK = True + + -- Rnn : right_index := right_index'Last; + -- for Lnn in reverse left-index loop + -- left (Lnn) := right (Rnn); + -- Rnn := right_index'Pred (Rnn); + -- end loop; + + -- Note: the above code MUST be analyzed with checks off, because + -- otherwise the Pred could overflow. But in any case this is more + -- efficient! + + -- Forwards_OK = Backwards_OK = False + + -- This only happens if we have the same array on each side. It is + -- possible to create situations using overlays that violate this, + -- but we simply do not promise to get this "right" in this case. + + -- There are two possible subcases. If the No_Implicit_Conditionals + -- restriction is set, then we generate the following code: + + -- declare + -- T : constant := rhs; + -- begin + -- lhs := T; + -- end; + + -- If implicit conditionals are permitted, then we generate: + + -- if Left_Lo <= Right_Lo then + -- + -- else + -- + -- end if; + + -- In order to detect possible aliasing, we examine the renamed + -- expression when the source or target is a renaming. However, + -- the renaming may be intended to capture an address that may be + -- affected by subsequent code, and therefore we must recover + -- the actual entity for the expansion that follows, not the + -- object it renames. In particular, if source or target designate + -- a portion of a dynamically allocated object, the pointer to it + -- may be reassigned but the renaming preserves the proper location. + + if Is_Entity_Name (Rhs) + and then + Nkind (Parent (Entity (Rhs))) = N_Object_Renaming_Declaration + and then Nkind (Act_Rhs) = N_Slice + then + Rarray := Rhs; + end if; + + if Is_Entity_Name (Lhs) + and then + Nkind (Parent (Entity (Lhs))) = N_Object_Renaming_Declaration + and then Nkind (Act_Lhs) = N_Slice + then + Larray := Lhs; + end if; + + -- Cases where either Forwards_OK or Backwards_OK is true + + if Forwards_OK (N) or else Backwards_OK (N) then + if Needs_Finalization (Component_Type (L_Type)) + and then Base_Type (L_Type) = Base_Type (R_Type) + and then Ndim = 1 + and then not No_Ctrl_Actions (N) + then + declare + Proc : constant Entity_Id := + TSS (Base_Type (L_Type), TSS_Slice_Assign); + Actuals : List_Id; + + begin + Apply_Dereference (Larray); + Apply_Dereference (Rarray); + Actuals := New_List ( + Duplicate_Subexpr (Larray, Name_Req => True), + Duplicate_Subexpr (Rarray, Name_Req => True), + Duplicate_Subexpr (Left_Lo, Name_Req => True), + Duplicate_Subexpr (Left_Hi, Name_Req => True), + Duplicate_Subexpr (Right_Lo, Name_Req => True), + Duplicate_Subexpr (Right_Hi, Name_Req => True)); + + Append_To (Actuals, + New_Occurrence_Of ( + Boolean_Literals (not Forwards_OK (N)), Loc)); + + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => Actuals)); + end; + + else + Rewrite (N, + Expand_Assign_Array_Loop + (N, Larray, Rarray, L_Type, R_Type, Ndim, + Rev => not Forwards_OK (N))); + end if; + + -- Case of both are false with No_Implicit_Conditionals + + elsif Restriction_Active (No_Implicit_Conditionals) then + declare + T : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars => Name_T); + + begin + Rewrite (N, + Make_Block_Statement (Loc, + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => T, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Etype (Rhs), Loc), + Expression => Relocate_Node (Rhs))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => Relocate_Node (Lhs), + Expression => New_Occurrence_Of (T, Loc)))))); + end; + + -- Case of both are false with implicit conditionals allowed + + else + -- Before we generate this code, we must ensure that the left and + -- right side array types are defined. They may be itypes, and we + -- cannot let them be defined inside the if, since the first use + -- in the then may not be executed. + + Ensure_Defined (L_Type, N); + Ensure_Defined (R_Type, N); + + -- We normally compare addresses to find out which way round to + -- do the loop, since this is reliable, and handles the cases of + -- parameters, conversions etc. But we can't do that in the bit + -- packed case or the VM case, because addresses don't work there. + + if not Is_Bit_Packed_Array (L_Type) and then VM_Target = No_VM then + Condition := + Make_Op_Le (Loc, + Left_Opnd => + Unchecked_Convert_To (RTE (RE_Integer_Address), + Make_Attribute_Reference (Loc, + Prefix => + Make_Indexed_Component (Loc, + Prefix => + Duplicate_Subexpr_Move_Checks (Larray, True), + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To + (L_Index_Typ, Loc), + Attribute_Name => Name_First))), + Attribute_Name => Name_Address)), + + Right_Opnd => + Unchecked_Convert_To (RTE (RE_Integer_Address), + Make_Attribute_Reference (Loc, + Prefix => + Make_Indexed_Component (Loc, + Prefix => + Duplicate_Subexpr_Move_Checks (Rarray, True), + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To + (R_Index_Typ, Loc), + Attribute_Name => Name_First))), + Attribute_Name => Name_Address))); + + -- For the bit packed and VM cases we use the bounds. That's OK, + -- because we don't have to worry about parameters, since they + -- cannot cause overlap. Perhaps we should worry about weird slice + -- conversions ??? + + else + -- Copy the bounds + + Cleft_Lo := New_Copy_Tree (Left_Lo); + Cright_Lo := New_Copy_Tree (Right_Lo); + + -- If the types do not match we add an implicit conversion + -- here to ensure proper match + + if Etype (Left_Lo) /= Etype (Right_Lo) then + Cright_Lo := + Unchecked_Convert_To (Etype (Left_Lo), Cright_Lo); + end if; + + -- Reset the Analyzed flag, because the bounds of the index + -- type itself may be universal, and must must be reanalyzed + -- to acquire the proper type for the back end. + + Set_Analyzed (Cleft_Lo, False); + Set_Analyzed (Cright_Lo, False); + + Condition := + Make_Op_Le (Loc, + Left_Opnd => Cleft_Lo, + Right_Opnd => Cright_Lo); + end if; + + if Needs_Finalization (Component_Type (L_Type)) + and then Base_Type (L_Type) = Base_Type (R_Type) + and then Ndim = 1 + and then not No_Ctrl_Actions (N) + then + + -- Call TSS procedure for array assignment, passing the + -- explicit bounds of right and left hand sides. + + declare + Proc : constant Entity_Id := + TSS (Base_Type (L_Type), TSS_Slice_Assign); + Actuals : List_Id; + + begin + Apply_Dereference (Larray); + Apply_Dereference (Rarray); + Actuals := New_List ( + Duplicate_Subexpr (Larray, Name_Req => True), + Duplicate_Subexpr (Rarray, Name_Req => True), + Duplicate_Subexpr (Left_Lo, Name_Req => True), + Duplicate_Subexpr (Left_Hi, Name_Req => True), + Duplicate_Subexpr (Right_Lo, Name_Req => True), + Duplicate_Subexpr (Right_Hi, Name_Req => True)); + + Append_To (Actuals, + Make_Op_Not (Loc, + Right_Opnd => Condition)); + + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => Actuals)); + end; + + else + Rewrite (N, + Make_Implicit_If_Statement (N, + Condition => Condition, + + Then_Statements => New_List ( + Expand_Assign_Array_Loop + (N, Larray, Rarray, L_Type, R_Type, Ndim, + Rev => False)), + + Else_Statements => New_List ( + Expand_Assign_Array_Loop + (N, Larray, Rarray, L_Type, R_Type, Ndim, + Rev => True)))); + end if; + end if; + + Analyze (N, Suppress => All_Checks); + end; + + exception + when RE_Not_Available => + return; + end Expand_Assign_Array; + + ------------------------------ + -- Expand_Assign_Array_Loop -- + ------------------------------ + + -- The following is an example of the loop generated for the case of a + -- two-dimensional array: + + -- declare + -- R2b : Tm1X1 := 1; + -- begin + -- for L1b in 1 .. 100 loop + -- declare + -- R4b : Tm1X2 := 1; + -- begin + -- for L3b in 1 .. 100 loop + -- vm1 (L1b, L3b) := vm2 (R2b, R4b); + -- R4b := Tm1X2'succ(R4b); + -- end loop; + -- end; + -- R2b := Tm1X1'succ(R2b); + -- end loop; + -- end; + + -- Here Rev is False, and Tm1Xn are the subscript types for the right hand + -- side. The declarations of R2b and R4b are inserted before the original + -- assignment statement. + + function Expand_Assign_Array_Loop + (N : Node_Id; + Larray : Entity_Id; + Rarray : Entity_Id; + L_Type : Entity_Id; + R_Type : Entity_Id; + Ndim : Pos; + Rev : Boolean) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + + Lnn : array (1 .. Ndim) of Entity_Id; + Rnn : array (1 .. Ndim) of Entity_Id; + -- Entities used as subscripts on left and right sides + + L_Index_Type : array (1 .. Ndim) of Entity_Id; + R_Index_Type : array (1 .. Ndim) of Entity_Id; + -- Left and right index types + + Assign : Node_Id; + + F_Or_L : Name_Id; + S_Or_P : Name_Id; + + function Build_Step (J : Nat) return Node_Id; + -- The increment step for the index of the right-hand side is written + -- as an attribute reference (Succ or Pred). This function returns + -- the corresponding node, which is placed at the end of the loop body. + + ---------------- + -- Build_Step -- + ---------------- + + function Build_Step (J : Nat) return Node_Id is + Step : Node_Id; + Lim : Name_Id; + + begin + if Rev then + Lim := Name_First; + else + Lim := Name_Last; + end if; + + Step := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Rnn (J), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (R_Index_Type (J), Loc), + Attribute_Name => S_Or_P, + Expressions => New_List ( + New_Occurrence_Of (Rnn (J), Loc)))); + + -- Note that on the last iteration of the loop, the index is increased + -- (or decreased) past the corresponding bound. This is consistent with + -- the C semantics of the back-end, where such an off-by-one value on a + -- dead index variable is OK. However, in CodePeer mode this leads to + -- spurious warnings, and thus we place a guard around the attribute + -- reference. For obvious reasons we only do this for CodePeer. + + if CodePeer_Mode then + Step := + Make_If_Statement (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Occurrence_Of (Lnn (J), Loc), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (L_Index_Type (J), Loc), + Attribute_Name => Lim)), + Then_Statements => New_List (Step)); + end if; + + return Step; + end Build_Step; + + -- Start of processing for Expand_Assign_Array_Loop + + begin + if Rev then + F_Or_L := Name_Last; + S_Or_P := Name_Pred; + else + F_Or_L := Name_First; + S_Or_P := Name_Succ; + end if; + + -- Setup index types and subscript entities + + declare + L_Index : Node_Id; + R_Index : Node_Id; + + begin + L_Index := First_Index (L_Type); + R_Index := First_Index (R_Type); + + for J in 1 .. Ndim loop + Lnn (J) := Make_Temporary (Loc, 'L'); + Rnn (J) := Make_Temporary (Loc, 'R'); + + L_Index_Type (J) := Etype (L_Index); + R_Index_Type (J) := Etype (R_Index); + + Next_Index (L_Index); + Next_Index (R_Index); + end loop; + end; + + -- Now construct the assignment statement + + declare + ExprL : constant List_Id := New_List; + ExprR : constant List_Id := New_List; + + begin + for J in 1 .. Ndim loop + Append_To (ExprL, New_Occurrence_Of (Lnn (J), Loc)); + Append_To (ExprR, New_Occurrence_Of (Rnn (J), Loc)); + end loop; + + Assign := + Make_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => Duplicate_Subexpr (Larray, Name_Req => True), + Expressions => ExprL), + Expression => + Make_Indexed_Component (Loc, + Prefix => Duplicate_Subexpr (Rarray, Name_Req => True), + Expressions => ExprR)); + + -- We set assignment OK, since there are some cases, e.g. in object + -- declarations, where we are actually assigning into a constant. + -- If there really is an illegality, it was caught long before now, + -- and was flagged when the original assignment was analyzed. + + Set_Assignment_OK (Name (Assign)); + + -- Propagate the No_Ctrl_Actions flag to individual assignments + + Set_No_Ctrl_Actions (Assign, No_Ctrl_Actions (N)); + end; + + -- Now construct the loop from the inside out, with the last subscript + -- varying most rapidly. Note that Assign is first the raw assignment + -- statement, and then subsequently the loop that wraps it up. + + for J in reverse 1 .. Ndim loop + Assign := + Make_Block_Statement (Loc, + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Rnn (J), + Object_Definition => + New_Occurrence_Of (R_Index_Type (J), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (R_Index_Type (J), Loc), + Attribute_Name => F_Or_L))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Implicit_Loop_Statement (N, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Lnn (J), + Reverse_Present => Rev, + Discrete_Subtype_Definition => + New_Reference_To (L_Index_Type (J), Loc))), + + Statements => New_List (Assign, Build_Step (J)))))); + end loop; + + return Assign; + end Expand_Assign_Array_Loop; + + -------------------------- + -- Expand_Assign_Record -- + -------------------------- + + procedure Expand_Assign_Record (N : Node_Id) is + Lhs : constant Node_Id := Name (N); + Rhs : Node_Id := Expression (N); + L_Typ : constant Entity_Id := Base_Type (Etype (Lhs)); + + begin + -- If change of representation, then extract the real right hand side + -- from the type conversion, and proceed with component-wise assignment, + -- since the two types are not the same as far as the back end is + -- concerned. + + if Change_Of_Representation (N) then + Rhs := Expression (Rhs); + + -- If this may be a case of a large bit aligned component, then proceed + -- with component-wise assignment, to avoid possible clobbering of other + -- components sharing bits in the first or last byte of the component to + -- be assigned. + + elsif Possible_Bit_Aligned_Component (Lhs) + or + Possible_Bit_Aligned_Component (Rhs) + then + null; + + -- If we have a tagged type that has a complete record representation + -- clause, we must do we must do component-wise assignments, since child + -- types may have used gaps for their components, and we might be + -- dealing with a view conversion. + + elsif Is_Fully_Repped_Tagged_Type (L_Typ) then + null; + + -- If neither condition met, then nothing special to do, the back end + -- can handle assignment of the entire component as a single entity. + + else + return; + end if; + + -- At this stage we know that we must do a component wise assignment + + declare + Loc : constant Source_Ptr := Sloc (N); + R_Typ : constant Entity_Id := Base_Type (Etype (Rhs)); + Decl : constant Node_Id := Declaration_Node (R_Typ); + RDef : Node_Id; + F : Entity_Id; + + function Find_Component + (Typ : Entity_Id; + Comp : Entity_Id) return Entity_Id; + -- Find the component with the given name in the underlying record + -- declaration for Typ. We need to use the actual entity because the + -- type may be private and resolution by identifier alone would fail. + + function Make_Component_List_Assign + (CL : Node_Id; + U_U : Boolean := False) return List_Id; + -- Returns a sequence of statements to assign the components that + -- are referenced in the given component list. The flag U_U is + -- used to force the usage of the inferred value of the variant + -- part expression as the switch for the generated case statement. + + function Make_Field_Assign + (C : Entity_Id; + U_U : Boolean := False) return Node_Id; + -- Given C, the entity for a discriminant or component, build an + -- assignment for the corresponding field values. The flag U_U + -- signals the presence of an Unchecked_Union and forces the usage + -- of the inferred discriminant value of C as the right hand side + -- of the assignment. + + function Make_Field_Assigns (CI : List_Id) return List_Id; + -- Given CI, a component items list, construct series of statements + -- for fieldwise assignment of the corresponding components. + + -------------------- + -- Find_Component -- + -------------------- + + function Find_Component + (Typ : Entity_Id; + Comp : Entity_Id) return Entity_Id + is + Utyp : constant Entity_Id := Underlying_Type (Typ); + C : Entity_Id; + + begin + C := First_Entity (Utyp); + while Present (C) loop + if Chars (C) = Chars (Comp) then + return C; + end if; + + Next_Entity (C); + end loop; + + raise Program_Error; + end Find_Component; + + -------------------------------- + -- Make_Component_List_Assign -- + -------------------------------- + + function Make_Component_List_Assign + (CL : Node_Id; + U_U : Boolean := False) return List_Id + is + CI : constant List_Id := Component_Items (CL); + VP : constant Node_Id := Variant_Part (CL); + + Alts : List_Id; + DC : Node_Id; + DCH : List_Id; + Expr : Node_Id; + Result : List_Id; + V : Node_Id; + + begin + Result := Make_Field_Assigns (CI); + + if Present (VP) then + V := First_Non_Pragma (Variants (VP)); + Alts := New_List; + while Present (V) loop + DCH := New_List; + DC := First (Discrete_Choices (V)); + while Present (DC) loop + Append_To (DCH, New_Copy_Tree (DC)); + Next (DC); + end loop; + + Append_To (Alts, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => DCH, + Statements => + Make_Component_List_Assign (Component_List (V)))); + Next_Non_Pragma (V); + end loop; + + -- If we have an Unchecked_Union, use the value of the inferred + -- discriminant of the variant part expression as the switch + -- for the case statement. The case statement may later be + -- folded. + + if U_U then + Expr := + New_Copy (Get_Discriminant_Value ( + Entity (Name (VP)), + Etype (Rhs), + Discriminant_Constraint (Etype (Rhs)))); + else + Expr := + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Rhs), + Selector_Name => + Make_Identifier (Loc, Chars (Name (VP)))); + end if; + + Append_To (Result, + Make_Case_Statement (Loc, + Expression => Expr, + Alternatives => Alts)); + end if; + + return Result; + end Make_Component_List_Assign; + + ----------------------- + -- Make_Field_Assign -- + ----------------------- + + function Make_Field_Assign + (C : Entity_Id; + U_U : Boolean := False) return Node_Id + is + A : Node_Id; + Expr : Node_Id; + + begin + -- In the case of an Unchecked_Union, use the discriminant + -- constraint value as on the right hand side of the assignment. + + if U_U then + Expr := + New_Copy (Get_Discriminant_Value (C, + Etype (Rhs), + Discriminant_Constraint (Etype (Rhs)))); + else + Expr := + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Rhs), + Selector_Name => New_Occurrence_Of (C, Loc)); + end if; + + A := + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Lhs), + Selector_Name => + New_Occurrence_Of (Find_Component (L_Typ, C), Loc)), + Expression => Expr); + + -- Set Assignment_OK, so discriminants can be assigned + + Set_Assignment_OK (Name (A), True); + + if Componentwise_Assignment (N) + and then Nkind (Name (A)) = N_Selected_Component + and then Chars (Selector_Name (Name (A))) = Name_uParent + then + Set_Componentwise_Assignment (A); + end if; + + return A; + end Make_Field_Assign; + + ------------------------ + -- Make_Field_Assigns -- + ------------------------ + + function Make_Field_Assigns (CI : List_Id) return List_Id is + Item : Node_Id; + Result : List_Id; + + begin + Item := First (CI); + Result := New_List; + + while Present (Item) loop + + -- Look for components, but exclude _tag field assignment if + -- the special Componentwise_Assignment flag is set. + + if Nkind (Item) = N_Component_Declaration + and then not (Is_Tag (Defining_Identifier (Item)) + and then Componentwise_Assignment (N)) + then + Append_To + (Result, Make_Field_Assign (Defining_Identifier (Item))); + end if; + + Next (Item); + end loop; + + return Result; + end Make_Field_Assigns; + + -- Start of processing for Expand_Assign_Record + + begin + -- Note that we use the base types for this processing. This results + -- in some extra work in the constrained case, but the change of + -- representation case is so unusual that it is not worth the effort. + + -- First copy the discriminants. This is done unconditionally. It + -- is required in the unconstrained left side case, and also in the + -- case where this assignment was constructed during the expansion + -- of a type conversion (since initialization of discriminants is + -- suppressed in this case). It is unnecessary but harmless in + -- other cases. + + if Has_Discriminants (L_Typ) then + F := First_Discriminant (R_Typ); + while Present (F) loop + + -- If we are expanding the initialization of a derived record + -- that constrains or renames discriminants of the parent, we + -- must use the corresponding discriminant in the parent. + + declare + CF : Entity_Id; + + begin + if Inside_Init_Proc + and then Present (Corresponding_Discriminant (F)) + then + CF := Corresponding_Discriminant (F); + else + CF := F; + end if; + + if Is_Unchecked_Union (Base_Type (R_Typ)) then + Insert_Action (N, Make_Field_Assign (CF, True)); + else + Insert_Action (N, Make_Field_Assign (CF)); + end if; + + Next_Discriminant (F); + end; + end loop; + end if; + + -- We know the underlying type is a record, but its current view + -- may be private. We must retrieve the usable record declaration. + + if Nkind_In (Decl, N_Private_Type_Declaration, + N_Private_Extension_Declaration) + and then Present (Full_View (R_Typ)) + then + RDef := Type_Definition (Declaration_Node (Full_View (R_Typ))); + else + RDef := Type_Definition (Decl); + end if; + + if Nkind (RDef) = N_Derived_Type_Definition then + RDef := Record_Extension_Part (RDef); + end if; + + if Nkind (RDef) = N_Record_Definition + and then Present (Component_List (RDef)) + then + if Is_Unchecked_Union (R_Typ) then + Insert_Actions (N, + Make_Component_List_Assign (Component_List (RDef), True)); + else + Insert_Actions + (N, Make_Component_List_Assign (Component_List (RDef))); + end if; + + Rewrite (N, Make_Null_Statement (Loc)); + end if; + end; + end Expand_Assign_Record; + + ----------------------------------- + -- Expand_N_Assignment_Statement -- + ----------------------------------- + + -- This procedure implements various cases where an assignment statement + -- cannot just be passed on to the back end in untransformed state. + + procedure Expand_N_Assignment_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Lhs : constant Node_Id := Name (N); + Rhs : constant Node_Id := Expression (N); + Typ : constant Entity_Id := Underlying_Type (Etype (Lhs)); + Exp : Node_Id; + + begin + -- Special case to check right away, if the Componentwise_Assignment + -- flag is set, this is a reanalysis from the expansion of the primitive + -- assignment procedure for a tagged type, and all we need to do is to + -- expand to assignment of components, because otherwise, we would get + -- infinite recursion (since this looks like a tagged assignment which + -- would normally try to *call* the primitive assignment procedure). + + if Componentwise_Assignment (N) then + Expand_Assign_Record (N); + return; + end if; + + -- Defend against invalid subscripts on left side if we are in standard + -- validity checking mode. No need to do this if we are checking all + -- subscripts. + + -- Note that we do this right away, because there are some early return + -- paths in this procedure, and this is required on all paths. + + if Validity_Checks_On + and then Validity_Check_Default + and then not Validity_Check_Subscripts + then + Check_Valid_Lvalue_Subscripts (Lhs); + end if; + + -- Ada 2005 (AI-327): Handle assignment to priority of protected object + + -- Rewrite an assignment to X'Priority into a run-time call + + -- For example: X'Priority := New_Prio_Expr; + -- ...is expanded into Set_Ceiling (X._Object, New_Prio_Expr); + + -- Note that although X'Priority is notionally an object, it is quite + -- deliberately not defined as an aliased object in the RM. This means + -- that it works fine to rewrite it as a call, without having to worry + -- about complications that would other arise from X'Priority'Access, + -- which is illegal, because of the lack of aliasing. + + if Ada_Version >= Ada_2005 then + declare + Call : Node_Id; + Conctyp : Entity_Id; + Ent : Entity_Id; + Subprg : Entity_Id; + RT_Subprg_Name : Node_Id; + + begin + -- Handle chains of renamings + + Ent := Name (N); + while Nkind (Ent) in N_Has_Entity + and then Present (Entity (Ent)) + and then Present (Renamed_Object (Entity (Ent))) + loop + Ent := Renamed_Object (Entity (Ent)); + end loop; + + -- The attribute Priority applied to protected objects has been + -- previously expanded into a call to the Get_Ceiling run-time + -- subprogram. + + if Nkind (Ent) = N_Function_Call + and then (Entity (Name (Ent)) = RTE (RE_Get_Ceiling) + or else + Entity (Name (Ent)) = RTE (RO_PE_Get_Ceiling)) + then + -- Look for the enclosing concurrent type + + Conctyp := Current_Scope; + while not Is_Concurrent_Type (Conctyp) loop + Conctyp := Scope (Conctyp); + end loop; + + pragma Assert (Is_Protected_Type (Conctyp)); + + -- Generate the first actual of the call + + Subprg := Current_Scope; + while not Present (Protected_Body_Subprogram (Subprg)) loop + Subprg := Scope (Subprg); + end loop; + + -- Select the appropriate run-time call + + if Number_Entries (Conctyp) = 0 then + RT_Subprg_Name := + New_Reference_To (RTE (RE_Set_Ceiling), Loc); + else + RT_Subprg_Name := + New_Reference_To (RTE (RO_PE_Set_Ceiling), Loc); + end if; + + Call := + Make_Procedure_Call_Statement (Loc, + Name => RT_Subprg_Name, + Parameter_Associations => New_List ( + New_Copy_Tree (First (Parameter_Associations (Ent))), + Relocate_Node (Expression (N)))); + + Rewrite (N, Call); + Analyze (N); + return; + end if; + end; + end if; + + -- Deal with assignment checks unless suppressed + + if not Suppress_Assignment_Checks (N) then + + -- First deal with generation of range check if required + + if Do_Range_Check (Rhs) then + Set_Do_Range_Check (Rhs, False); + Generate_Range_Check (Rhs, Typ, CE_Range_Check_Failed); + end if; + + -- Then generate predicate check if required + + Apply_Predicate_Check (Rhs, Typ); + end if; + + -- Check for a special case where a high level transformation is + -- required. If we have either of: + + -- P.field := rhs; + -- P (sub) := rhs; + + -- where P is a reference to a bit packed array, then we have to unwind + -- the assignment. The exact meaning of being a reference to a bit + -- packed array is as follows: + + -- An indexed component whose prefix is a bit packed array is a + -- reference to a bit packed array. + + -- An indexed component or selected component whose prefix is a + -- reference to a bit packed array is itself a reference ot a + -- bit packed array. + + -- The required transformation is + + -- Tnn : prefix_type := P; + -- Tnn.field := rhs; + -- P := Tnn; + + -- or + + -- Tnn : prefix_type := P; + -- Tnn (subscr) := rhs; + -- P := Tnn; + + -- Since P is going to be evaluated more than once, any subscripts + -- in P must have their evaluation forced. + + if Nkind_In (Lhs, N_Indexed_Component, N_Selected_Component) + and then Is_Ref_To_Bit_Packed_Array (Prefix (Lhs)) + then + declare + BPAR_Expr : constant Node_Id := Relocate_Node (Prefix (Lhs)); + BPAR_Typ : constant Entity_Id := Etype (BPAR_Expr); + Tnn : constant Entity_Id := + Make_Temporary (Loc, 'T', BPAR_Expr); + + begin + -- Insert the post assignment first, because we want to copy the + -- BPAR_Expr tree before it gets analyzed in the context of the + -- pre assignment. Note that we do not analyze the post assignment + -- yet (we cannot till we have completed the analysis of the pre + -- assignment). As usual, the analysis of this post assignment + -- will happen on its own when we "run into" it after finishing + -- the current assignment. + + Insert_After (N, + Make_Assignment_Statement (Loc, + Name => New_Copy_Tree (BPAR_Expr), + Expression => New_Occurrence_Of (Tnn, Loc))); + + -- At this stage BPAR_Expr is a reference to a bit packed array + -- where the reference was not expanded in the original tree, + -- since it was on the left side of an assignment. But in the + -- pre-assignment statement (the object definition), BPAR_Expr + -- will end up on the right hand side, and must be reexpanded. To + -- achieve this, we reset the analyzed flag of all selected and + -- indexed components down to the actual indexed component for + -- the packed array. + + Exp := BPAR_Expr; + loop + Set_Analyzed (Exp, False); + + if Nkind_In + (Exp, N_Selected_Component, N_Indexed_Component) + then + Exp := Prefix (Exp); + else + exit; + end if; + end loop; + + -- Now we can insert and analyze the pre-assignment + + -- If the right-hand side requires a transient scope, it has + -- already been placed on the stack. However, the declaration is + -- inserted in the tree outside of this scope, and must reflect + -- the proper scope for its variable. This awkward bit is forced + -- by the stricter scope discipline imposed by GCC 2.97. + + declare + Uses_Transient_Scope : constant Boolean := + Scope_Is_Transient + and then N = Node_To_Be_Wrapped; + + begin + if Uses_Transient_Scope then + Push_Scope (Scope (Current_Scope)); + end if; + + Insert_Before_And_Analyze (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Object_Definition => New_Occurrence_Of (BPAR_Typ, Loc), + Expression => BPAR_Expr)); + + if Uses_Transient_Scope then + Pop_Scope; + end if; + end; + + -- Now fix up the original assignment and continue processing + + Rewrite (Prefix (Lhs), + New_Occurrence_Of (Tnn, Loc)); + + -- We do not need to reanalyze that assignment, and we do not need + -- to worry about references to the temporary, but we do need to + -- make sure that the temporary is not marked as a true constant + -- since we now have a generated assignment to it! + + Set_Is_True_Constant (Tnn, False); + end; + end if; + + -- When we have the appropriate type of aggregate in the expression (it + -- has been determined during analysis of the aggregate by setting the + -- delay flag), let's perform in place assignment and thus avoid + -- creating a temporary. + + if Is_Delayed_Aggregate (Rhs) then + Convert_Aggr_In_Assignment (N); + Rewrite (N, Make_Null_Statement (Loc)); + Analyze (N); + return; + end if; + + -- Apply discriminant check if required. If Lhs is an access type to a + -- designated type with discriminants, we must always check. + + if Has_Discriminants (Etype (Lhs)) then + + -- Skip discriminant check if change of representation. Will be + -- done when the change of representation is expanded out. + + if not Change_Of_Representation (N) then + Apply_Discriminant_Check (Rhs, Etype (Lhs), Lhs); + end if; + + -- If the type is private without discriminants, and the full type + -- has discriminants (necessarily with defaults) a check may still be + -- necessary if the Lhs is aliased. The private determinants must be + -- visible to build the discriminant constraints. + -- What is a "determinant"??? + + -- Only an explicit dereference that comes from source indicates + -- aliasing. Access to formals of protected operations and entries + -- create dereferences but are not semantic aliasings. + + elsif Is_Private_Type (Etype (Lhs)) + and then Has_Discriminants (Typ) + and then Nkind (Lhs) = N_Explicit_Dereference + and then Comes_From_Source (Lhs) + then + declare + Lt : constant Entity_Id := Etype (Lhs); + begin + Set_Etype (Lhs, Typ); + Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs)); + Apply_Discriminant_Check (Rhs, Typ, Lhs); + Set_Etype (Lhs, Lt); + end; + + -- If the Lhs has a private type with unknown discriminants, it + -- may have a full view with discriminants, but those are nameable + -- only in the underlying type, so convert the Rhs to it before + -- potential checking. + + elsif Has_Unknown_Discriminants (Base_Type (Etype (Lhs))) + and then Has_Discriminants (Typ) + then + Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs)); + Apply_Discriminant_Check (Rhs, Typ, Lhs); + + -- In the access type case, we need the same discriminant check, and + -- also range checks if we have an access to constrained array. + + elsif Is_Access_Type (Etype (Lhs)) + and then Is_Constrained (Designated_Type (Etype (Lhs))) + then + if Has_Discriminants (Designated_Type (Etype (Lhs))) then + + -- Skip discriminant check if change of representation. Will be + -- done when the change of representation is expanded out. + + if not Change_Of_Representation (N) then + Apply_Discriminant_Check (Rhs, Etype (Lhs)); + end if; + + elsif Is_Array_Type (Designated_Type (Etype (Lhs))) then + Apply_Range_Check (Rhs, Etype (Lhs)); + + if Is_Constrained (Etype (Lhs)) then + Apply_Length_Check (Rhs, Etype (Lhs)); + end if; + + if Nkind (Rhs) = N_Allocator then + declare + Target_Typ : constant Entity_Id := Etype (Expression (Rhs)); + C_Es : Check_Result; + + begin + C_Es := + Get_Range_Checks + (Lhs, + Target_Typ, + Etype (Designated_Type (Etype (Lhs)))); + + Insert_Range_Checks + (C_Es, + N, + Target_Typ, + Sloc (Lhs), + Lhs); + end; + end if; + end if; + + -- Apply range check for access type case + + elsif Is_Access_Type (Etype (Lhs)) + and then Nkind (Rhs) = N_Allocator + and then Nkind (Expression (Rhs)) = N_Qualified_Expression + then + Analyze_And_Resolve (Expression (Rhs)); + Apply_Range_Check + (Expression (Rhs), Designated_Type (Etype (Lhs))); + end if; + + -- Ada 2005 (AI-231): Generate the run-time check + + if Is_Access_Type (Typ) + and then Can_Never_Be_Null (Etype (Lhs)) + and then not Can_Never_Be_Null (Etype (Rhs)) + then + Apply_Constraint_Check (Rhs, Etype (Lhs)); + end if; + + -- Case of assignment to a bit packed array element + + if Nkind (Lhs) = N_Indexed_Component + and then Is_Bit_Packed_Array (Etype (Prefix (Lhs))) + then + Expand_Bit_Packed_Element_Set (N); + return; + + -- Build-in-place function call case. Note that we're not yet doing + -- build-in-place for user-written assignment statements (the assignment + -- here came from an aggregate.) + + elsif Ada_Version >= Ada_2005 + and then Is_Build_In_Place_Function_Call (Rhs) + then + Make_Build_In_Place_Call_In_Assignment (N, Rhs); + + elsif Is_Tagged_Type (Typ) and then Is_Value_Type (Etype (Lhs)) then + + -- Nothing to do for valuetypes + -- ??? Set_Scope_Is_Transient (False); + + return; + + elsif Is_Tagged_Type (Typ) + or else (Needs_Finalization (Typ) and then not Is_Array_Type (Typ)) + then + Tagged_Case : declare + L : List_Id := No_List; + Expand_Ctrl_Actions : constant Boolean := not No_Ctrl_Actions (N); + + begin + -- In the controlled case, we ensure that function calls are + -- evaluated before finalizing the target. In all cases, it makes + -- the expansion easier if the side-effects are removed first. + + Remove_Side_Effects (Lhs); + Remove_Side_Effects (Rhs); + + -- Avoid recursion in the mechanism + + Set_Analyzed (N); + + -- If dispatching assignment, we need to dispatch to _assign + + if Is_Class_Wide_Type (Typ) + + -- If the type is tagged, we may as well use the predefined + -- primitive assignment. This avoids inlining a lot of code + -- and in the class-wide case, the assignment is replaced by + -- dispatch call to _assign. Note that this cannot be done when + -- discriminant checks are locally suppressed (as in extension + -- aggregate expansions) because otherwise the discriminant + -- check will be performed within the _assign call. It is also + -- suppressed for assignments created by the expander that + -- correspond to initializations, where we do want to copy the + -- tag (No_Ctrl_Actions flag set True) by the expander and we + -- do not need to mess with tags ever (Expand_Ctrl_Actions flag + -- is set True in this case). + + or else (Is_Tagged_Type (Typ) + and then not Is_Value_Type (Etype (Lhs)) + and then Chars (Current_Scope) /= Name_uAssign + and then Expand_Ctrl_Actions + and then not Discriminant_Checks_Suppressed (Empty)) + then + -- Fetch the primitive op _assign and proper type to call it. + -- Because of possible conflicts between private and full view, + -- fetch the proper type directly from the operation profile. + + declare + Op : constant Entity_Id := + Find_Prim_Op (Typ, Name_uAssign); + F_Typ : Entity_Id := Etype (First_Formal (Op)); + + begin + -- If the assignment is dispatching, make sure to use the + -- proper type. + + if Is_Class_Wide_Type (Typ) then + F_Typ := Class_Wide_Type (F_Typ); + end if; + + L := New_List; + + -- In case of assignment to a class-wide tagged type, before + -- the assignment we generate run-time check to ensure that + -- the tags of source and target match. + + if Is_Class_Wide_Type (Typ) + and then Is_Tagged_Type (Typ) + and then Is_Tagged_Type (Underlying_Type (Etype (Rhs))) + then + Append_To (L, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Lhs), + Selector_Name => + Make_Identifier (Loc, Name_uTag)), + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Rhs), + Selector_Name => + Make_Identifier (Loc, Name_uTag))), + Reason => CE_Tag_Check_Failed)); + end if; + + declare + Left_N : Node_Id := Duplicate_Subexpr (Lhs); + Right_N : Node_Id := Duplicate_Subexpr (Rhs); + + begin + -- In order to dispatch the call to _assign the type of + -- the actuals must match. Add conversion (if required). + + if Etype (Lhs) /= F_Typ then + Left_N := Unchecked_Convert_To (F_Typ, Left_N); + end if; + + if Etype (Rhs) /= F_Typ then + Right_N := Unchecked_Convert_To (F_Typ, Right_N); + end if; + + Append_To (L, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Op, Loc), + Parameter_Associations => New_List ( + Node1 => Left_N, + Node2 => Right_N))); + end; + end; + + else + L := Make_Tag_Ctrl_Assignment (N); + + -- We can't afford to have destructive Finalization Actions in + -- the Self assignment case, so if the target and the source + -- are not obviously different, code is generated to avoid the + -- self assignment case: + + -- if lhs'address /= rhs'address then + -- + -- end if; + + -- Skip this if Restriction (No_Finalization) is active + + if not Statically_Different (Lhs, Rhs) + and then Expand_Ctrl_Actions + and then not Restriction_Active (No_Finalization) + then + L := New_List ( + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Lhs), + Attribute_Name => Name_Address), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Rhs), + Attribute_Name => Name_Address)), + + Then_Statements => L)); + end if; + + -- We need to set up an exception handler for implementing + -- 7.6.1(18). The remaining adjustments are tackled by the + -- implementation of adjust for record_controllers (see + -- s-finimp.adb). + + -- This is skipped if we have no finalization + + if Expand_Ctrl_Actions + and then not Restriction_Active (No_Finalization) + then + L := New_List ( + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => L, + Exception_Handlers => New_List ( + Make_Handler_For_Ctrl_Operation (Loc))))); + end if; + end if; + + Rewrite (N, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Statements => L))); + + -- If no restrictions on aborts, protect the whole assignment + -- for controlled objects as per 9.8(11). + + if Needs_Finalization (Typ) + and then Expand_Ctrl_Actions + and then Abort_Allowed + then + declare + Blk : constant Entity_Id := + New_Internal_Entity + (E_Block, Current_Scope, Sloc (N), 'B'); + + begin + Set_Scope (Blk, Current_Scope); + Set_Etype (Blk, Standard_Void_Type); + Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N))); + + Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer)); + Set_At_End_Proc (Handled_Statement_Sequence (N), + New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)); + Expand_At_End_Handler + (Handled_Statement_Sequence (N), Blk); + end; + end if; + + -- N has been rewritten to a block statement for which it is + -- known by construction that no checks are necessary: analyze + -- it with all checks suppressed. + + Analyze (N, Suppress => All_Checks); + return; + end Tagged_Case; + + -- Array types + + elsif Is_Array_Type (Typ) then + declare + Actual_Rhs : Node_Id := Rhs; + + begin + while Nkind_In (Actual_Rhs, N_Type_Conversion, + N_Qualified_Expression) + loop + Actual_Rhs := Expression (Actual_Rhs); + end loop; + + Expand_Assign_Array (N, Actual_Rhs); + return; + end; + + -- Record types + + elsif Is_Record_Type (Typ) then + Expand_Assign_Record (N); + return; + + -- Scalar types. This is where we perform the processing related to the + -- requirements of (RM 13.9.1(9-11)) concerning the handling of invalid + -- scalar values. + + elsif Is_Scalar_Type (Typ) then + + -- Case where right side is known valid + + if Expr_Known_Valid (Rhs) then + + -- Here the right side is valid, so it is fine. The case to deal + -- with is when the left side is a local variable reference whose + -- value is not currently known to be valid. If this is the case, + -- and the assignment appears in an unconditional context, then + -- we can mark the left side as now being valid if one of these + -- conditions holds: + + -- The expression of the right side has Do_Range_Check set so + -- that we know a range check will be performed. Note that it + -- can be the case that a range check is omitted because we + -- make the assumption that we can assume validity for operands + -- appearing in the right side in determining whether a range + -- check is required + + -- The subtype of the right side matches the subtype of the + -- left side. In this case, even though we have not checked + -- the range of the right side, we know it is in range of its + -- subtype if the expression is valid. + + if Is_Local_Variable_Reference (Lhs) + and then not Is_Known_Valid (Entity (Lhs)) + and then In_Unconditional_Context (N) + then + if Do_Range_Check (Rhs) + or else Etype (Lhs) = Etype (Rhs) + then + Set_Is_Known_Valid (Entity (Lhs), True); + end if; + end if; + + -- Case where right side may be invalid in the sense of the RM + -- reference above. The RM does not require that we check for the + -- validity on an assignment, but it does require that the assignment + -- of an invalid value not cause erroneous behavior. + + -- The general approach in GNAT is to use the Is_Known_Valid flag + -- to avoid the need for validity checking on assignments. However + -- in some cases, we have to do validity checking in order to make + -- sure that the setting of this flag is correct. + + else + -- Validate right side if we are validating copies + + if Validity_Checks_On + and then Validity_Check_Copies + then + -- Skip this if left hand side is an array or record component + -- and elementary component validity checks are suppressed. + + if Nkind_In (Lhs, N_Selected_Component, N_Indexed_Component) + and then not Validity_Check_Components + then + null; + else + Ensure_Valid (Rhs); + end if; + + -- We can propagate this to the left side where appropriate + + if Is_Local_Variable_Reference (Lhs) + and then not Is_Known_Valid (Entity (Lhs)) + and then In_Unconditional_Context (N) + then + Set_Is_Known_Valid (Entity (Lhs), True); + end if; + + -- Otherwise check to see what should be done + + -- If left side is a local variable, then we just set its flag to + -- indicate that its value may no longer be valid, since we are + -- copying a potentially invalid value. + + elsif Is_Local_Variable_Reference (Lhs) then + Set_Is_Known_Valid (Entity (Lhs), False); + + -- Check for case of a nonlocal variable on the left side which + -- is currently known to be valid. In this case, we simply ensure + -- that the right side is valid. We only play the game of copying + -- validity status for local variables, since we are doing this + -- statically, not by tracing the full flow graph. + + elsif Is_Entity_Name (Lhs) + and then Is_Known_Valid (Entity (Lhs)) + then + -- Note: If Validity_Checking mode is set to none, we ignore + -- the Ensure_Valid call so don't worry about that case here. + + Ensure_Valid (Rhs); + + -- In all other cases, we can safely copy an invalid value without + -- worrying about the status of the left side. Since it is not a + -- variable reference it will not be considered + -- as being known to be valid in any case. + + else + null; + end if; + end if; + end if; + + exception + when RE_Not_Available => + return; + end Expand_N_Assignment_Statement; + + ------------------------------ + -- Expand_N_Block_Statement -- + ------------------------------ + + -- Encode entity names defined in block statement + + procedure Expand_N_Block_Statement (N : Node_Id) is + begin + Qualify_Entity_Names (N); + end Expand_N_Block_Statement; + + ----------------------------- + -- Expand_N_Case_Statement -- + ----------------------------- + + procedure Expand_N_Case_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Expr : constant Node_Id := Expression (N); + Alt : Node_Id; + Len : Nat; + Cond : Node_Id; + Choice : Node_Id; + Chlist : List_Id; + + begin + -- Check for the situation where we know at compile time which branch + -- will be taken + + if Compile_Time_Known_Value (Expr) then + Alt := Find_Static_Alternative (N); + + -- Move statements from this alternative after the case statement. + -- They are already analyzed, so will be skipped by the analyzer. + + Insert_List_After (N, Statements (Alt)); + + -- That leaves the case statement as a shell. So now we can kill all + -- other alternatives in the case statement. + + Kill_Dead_Code (Expression (N)); + + declare + A : Node_Id; + + begin + -- Loop through case alternatives, skipping pragmas, and skipping + -- the one alternative that we select (and therefore retain). + + A := First (Alternatives (N)); + while Present (A) loop + if A /= Alt + and then Nkind (A) = N_Case_Statement_Alternative + then + Kill_Dead_Code (Statements (A), Warn_On_Deleted_Code); + end if; + + Next (A); + end loop; + end; + + Rewrite (N, Make_Null_Statement (Loc)); + return; + end if; + + -- Here if the choice is not determined at compile time + + declare + Last_Alt : constant Node_Id := Last (Alternatives (N)); + + Others_Present : Boolean; + Others_Node : Node_Id; + + Then_Stms : List_Id; + Else_Stms : List_Id; + + begin + if Nkind (First (Discrete_Choices (Last_Alt))) = N_Others_Choice then + Others_Present := True; + Others_Node := Last_Alt; + else + Others_Present := False; + end if; + + -- First step is to worry about possible invalid argument. The RM + -- requires (RM 5.4(13)) that if the result is invalid (e.g. it is + -- outside the base range), then Constraint_Error must be raised. + + -- Case of validity check required (validity checks are on, the + -- expression is not known to be valid, and the case statement + -- comes from source -- no need to validity check internally + -- generated case statements). + + if Validity_Check_Default then + Ensure_Valid (Expr); + end if; + + -- If there is only a single alternative, just replace it with the + -- sequence of statements since obviously that is what is going to + -- be executed in all cases. + + Len := List_Length (Alternatives (N)); + + if Len = 1 then + -- We still need to evaluate the expression if it has any + -- side effects. + + Remove_Side_Effects (Expression (N)); + + Insert_List_After (N, Statements (First (Alternatives (N)))); + + -- That leaves the case statement as a shell. The alternative that + -- will be executed is reset to a null list. So now we can kill + -- the entire case statement. + + Kill_Dead_Code (Expression (N)); + Rewrite (N, Make_Null_Statement (Loc)); + return; + end if; + + -- An optimization. If there are only two alternatives, and only + -- a single choice, then rewrite the whole case statement as an + -- if statement, since this can result in subsequent optimizations. + -- This helps not only with case statements in the source of a + -- simple form, but also with generated code (discriminant check + -- functions in particular) + + if Len = 2 then + Chlist := Discrete_Choices (First (Alternatives (N))); + + if List_Length (Chlist) = 1 then + Choice := First (Chlist); + + Then_Stms := Statements (First (Alternatives (N))); + Else_Stms := Statements (Last (Alternatives (N))); + + -- For TRUE, generate "expression", not expression = true + + if Nkind (Choice) = N_Identifier + and then Entity (Choice) = Standard_True + then + Cond := Expression (N); + + -- For FALSE, generate "expression" and switch then/else + + elsif Nkind (Choice) = N_Identifier + and then Entity (Choice) = Standard_False + then + Cond := Expression (N); + Else_Stms := Statements (First (Alternatives (N))); + Then_Stms := Statements (Last (Alternatives (N))); + + -- For a range, generate "expression in range" + + elsif Nkind (Choice) = N_Range + or else (Nkind (Choice) = N_Attribute_Reference + and then Attribute_Name (Choice) = Name_Range) + or else (Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice))) + or else Nkind (Choice) = N_Subtype_Indication + then + Cond := + Make_In (Loc, + Left_Opnd => Expression (N), + Right_Opnd => Relocate_Node (Choice)); + + -- For any other subexpression "expression = value" + + else + Cond := + Make_Op_Eq (Loc, + Left_Opnd => Expression (N), + Right_Opnd => Relocate_Node (Choice)); + end if; + + -- Now rewrite the case as an IF + + Rewrite (N, + Make_If_Statement (Loc, + Condition => Cond, + Then_Statements => Then_Stms, + Else_Statements => Else_Stms)); + Analyze (N); + return; + end if; + end if; + + -- If the last alternative is not an Others choice, replace it with + -- an N_Others_Choice. Note that we do not bother to call Analyze on + -- the modified case statement, since it's only effect would be to + -- compute the contents of the Others_Discrete_Choices which is not + -- needed by the back end anyway. + + -- The reason we do this is that the back end always needs some + -- default for a switch, so if we have not supplied one in the + -- processing above for validity checking, then we need to supply + -- one here. + + if not Others_Present then + Others_Node := Make_Others_Choice (Sloc (Last_Alt)); + Set_Others_Discrete_Choices + (Others_Node, Discrete_Choices (Last_Alt)); + Set_Discrete_Choices (Last_Alt, New_List (Others_Node)); + end if; + end; + end Expand_N_Case_Statement; + + ----------------------------- + -- Expand_N_Exit_Statement -- + ----------------------------- + + -- The only processing required is to deal with a possible C/Fortran + -- boolean value used as the condition for the exit statement. + + procedure Expand_N_Exit_Statement (N : Node_Id) is + begin + Adjust_Condition (Condition (N)); + end Expand_N_Exit_Statement; + + ----------------------------- + -- Expand_N_Goto_Statement -- + ----------------------------- + + -- Add poll before goto if polling active + + procedure Expand_N_Goto_Statement (N : Node_Id) is + begin + Generate_Poll_Call (N); + end Expand_N_Goto_Statement; + + --------------------------- + -- Expand_N_If_Statement -- + --------------------------- + + -- First we deal with the case of C and Fortran convention boolean values, + -- with zero/non-zero semantics. + + -- Second, we deal with the obvious rewriting for the cases where the + -- condition of the IF is known at compile time to be True or False. + + -- Third, we remove elsif parts which have non-empty Condition_Actions and + -- rewrite as independent if statements. For example: + + -- if x then xs + -- elsif y then ys + -- ... + -- end if; + + -- becomes + -- + -- if x then xs + -- else + -- <> + -- if y then ys + -- ... + -- end if; + -- end if; + + -- This rewriting is needed if at least one elsif part has a non-empty + -- Condition_Actions list. We also do the same processing if there is a + -- constant condition in an elsif part (in conjunction with the first + -- processing step mentioned above, for the recursive call made to deal + -- with the created inner if, this deals with properly optimizing the + -- cases of constant elsif conditions). + + procedure Expand_N_If_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Hed : Node_Id; + E : Node_Id; + New_If : Node_Id; + + Warn_If_Deleted : constant Boolean := + Warn_On_Deleted_Code and then Comes_From_Source (N); + -- Indicates whether we want warnings when we delete branches of the + -- if statement based on constant condition analysis. We never want + -- these warnings for expander generated code. + + begin + Adjust_Condition (Condition (N)); + + -- The following loop deals with constant conditions for the IF. We + -- need a loop because as we eliminate False conditions, we grab the + -- first elsif condition and use it as the primary condition. + + while Compile_Time_Known_Value (Condition (N)) loop + + -- If condition is True, we can simply rewrite the if statement now + -- by replacing it by the series of then statements. + + if Is_True (Expr_Value (Condition (N))) then + + -- All the else parts can be killed + + Kill_Dead_Code (Elsif_Parts (N), Warn_If_Deleted); + Kill_Dead_Code (Else_Statements (N), Warn_If_Deleted); + + Hed := Remove_Head (Then_Statements (N)); + Insert_List_After (N, Then_Statements (N)); + Rewrite (N, Hed); + return; + + -- If condition is False, then we can delete the condition and + -- the Then statements + + else + -- We do not delete the condition if constant condition warnings + -- are enabled, since otherwise we end up deleting the desired + -- warning. Of course the backend will get rid of this True/False + -- test anyway, so nothing is lost here. + + if not Constant_Condition_Warnings then + Kill_Dead_Code (Condition (N)); + end if; + + Kill_Dead_Code (Then_Statements (N), Warn_If_Deleted); + + -- If there are no elsif statements, then we simply replace the + -- entire if statement by the sequence of else statements. + + if No (Elsif_Parts (N)) then + if No (Else_Statements (N)) + or else Is_Empty_List (Else_Statements (N)) + then + Rewrite (N, + Make_Null_Statement (Sloc (N))); + else + Hed := Remove_Head (Else_Statements (N)); + Insert_List_After (N, Else_Statements (N)); + Rewrite (N, Hed); + end if; + + return; + + -- If there are elsif statements, the first of them becomes the + -- if/then section of the rebuilt if statement This is the case + -- where we loop to reprocess this copied condition. + + else + Hed := Remove_Head (Elsif_Parts (N)); + Insert_Actions (N, Condition_Actions (Hed)); + Set_Condition (N, Condition (Hed)); + Set_Then_Statements (N, Then_Statements (Hed)); + + -- Hed might have been captured as the condition determining + -- the current value for an entity. Now it is detached from + -- the tree, so a Current_Value pointer in the condition might + -- need to be updated. + + Set_Current_Value_Condition (N); + + if Is_Empty_List (Elsif_Parts (N)) then + Set_Elsif_Parts (N, No_List); + end if; + end if; + end if; + end loop; + + -- Loop through elsif parts, dealing with constant conditions and + -- possible expression actions that are present. + + if Present (Elsif_Parts (N)) then + E := First (Elsif_Parts (N)); + while Present (E) loop + Adjust_Condition (Condition (E)); + + -- If there are condition actions, then rewrite the if statement + -- as indicated above. We also do the same rewrite for a True or + -- False condition. The further processing of this constant + -- condition is then done by the recursive call to expand the + -- newly created if statement + + if Present (Condition_Actions (E)) + or else Compile_Time_Known_Value (Condition (E)) + then + -- Note this is not an implicit if statement, since it is part + -- of an explicit if statement in the source (or of an implicit + -- if statement that has already been tested). + + New_If := + Make_If_Statement (Sloc (E), + Condition => Condition (E), + Then_Statements => Then_Statements (E), + Elsif_Parts => No_List, + Else_Statements => Else_Statements (N)); + + -- Elsif parts for new if come from remaining elsif's of parent + + while Present (Next (E)) loop + if No (Elsif_Parts (New_If)) then + Set_Elsif_Parts (New_If, New_List); + end if; + + Append (Remove_Next (E), Elsif_Parts (New_If)); + end loop; + + Set_Else_Statements (N, New_List (New_If)); + + if Present (Condition_Actions (E)) then + Insert_List_Before (New_If, Condition_Actions (E)); + end if; + + Remove (E); + + if Is_Empty_List (Elsif_Parts (N)) then + Set_Elsif_Parts (N, No_List); + end if; + + Analyze (New_If); + return; + + -- No special processing for that elsif part, move to next + + else + Next (E); + end if; + end loop; + end if; + + -- Some more optimizations applicable if we still have an IF statement + + if Nkind (N) /= N_If_Statement then + return; + end if; + + -- Another optimization, special cases that can be simplified + + -- if expression then + -- return true; + -- else + -- return false; + -- end if; + + -- can be changed to: + + -- return expression; + + -- and + + -- if expression then + -- return false; + -- else + -- return true; + -- end if; + + -- can be changed to: + + -- return not (expression); + + -- Only do these optimizations if we are at least at -O1 level and + -- do not do them if control flow optimizations are suppressed. + + if Optimization_Level > 0 + and then not Opt.Suppress_Control_Flow_Optimizations + then + if Nkind (N) = N_If_Statement + and then No (Elsif_Parts (N)) + and then Present (Else_Statements (N)) + and then List_Length (Then_Statements (N)) = 1 + and then List_Length (Else_Statements (N)) = 1 + then + declare + Then_Stm : constant Node_Id := First (Then_Statements (N)); + Else_Stm : constant Node_Id := First (Else_Statements (N)); + + begin + if Nkind (Then_Stm) = N_Simple_Return_Statement + and then + Nkind (Else_Stm) = N_Simple_Return_Statement + then + declare + Then_Expr : constant Node_Id := Expression (Then_Stm); + Else_Expr : constant Node_Id := Expression (Else_Stm); + + begin + if Nkind (Then_Expr) = N_Identifier + and then + Nkind (Else_Expr) = N_Identifier + then + if Entity (Then_Expr) = Standard_True + and then Entity (Else_Expr) = Standard_False + then + Rewrite (N, + Make_Simple_Return_Statement (Loc, + Expression => Relocate_Node (Condition (N)))); + Analyze (N); + return; + + elsif Entity (Then_Expr) = Standard_False + and then Entity (Else_Expr) = Standard_True + then + Rewrite (N, + Make_Simple_Return_Statement (Loc, + Expression => + Make_Op_Not (Loc, + Right_Opnd => + Relocate_Node (Condition (N))))); + Analyze (N); + return; + end if; + end if; + end; + end if; + end; + end if; + end if; + end Expand_N_If_Statement; + + -------------------------- + -- Expand_Iterator_Loop -- + -------------------------- + + procedure Expand_Iterator_Loop (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Isc : constant Node_Id := Iteration_Scheme (N); + I_Spec : constant Node_Id := Iterator_Specification (Isc); + Id : constant Entity_Id := Defining_Identifier (I_Spec); + Container : constant Entity_Id := Entity (Name (I_Spec)); + Typ : constant Entity_Id := Etype (Container); + + Cursor : Entity_Id; + New_Loop : Node_Id; + Stats : List_Id; + + begin + if Is_Array_Type (Typ) then + if Of_Present (I_Spec) then + Cursor := Make_Temporary (Loc, 'C'); + + -- for Elem of Arr loop ... + + declare + Decl : constant Node_Id := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Id, + Subtype_Mark => + New_Occurrence_Of (Component_Type (Typ), Loc), + Name => + Make_Indexed_Component (Loc, + Prefix => + New_Occurrence_Of (Container, Loc), + Expressions => + New_List (New_Occurrence_Of (Cursor, Loc)))); + begin + Stats := Statements (N); + Prepend (Decl, Stats); + + New_Loop := + Make_Loop_Statement (Loc, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Cursor, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Container, Loc), + Attribute_Name => Name_Range), + Reverse_Present => Reverse_Present (I_Spec))), + Statements => Stats, + End_Label => Empty); + end; + + else + -- for Index in Array loop ... + + -- The cursor (index into the array) is the source Id + + Cursor := Id; + New_Loop := + Make_Loop_Statement (Loc, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Cursor, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Container, Loc), + Attribute_Name => Name_Range), + Reverse_Present => Reverse_Present (I_Spec))), + Statements => Statements (N), + End_Label => Empty); + end if; + + -- Iterators over containers + + else + -- In both cases these require a cursor of the proper type + + -- Cursor : P.Cursor_Type := Container.First; + -- while Cursor /= P.No_Element loop + + -- Obj : P.Element_Type renames Element (Cursor); + -- -- For the "of" form, the element name renames the element + -- -- designated by the cursor. + + -- Statements; + -- P.Next (Cursor); + -- end loop; + + -- with the obvious replacements if "reverse" is specified. + + declare + Element_Type : constant Entity_Id := Etype (Id); + Pack : constant Entity_Id := Scope (Etype (Container)); + Name_Init : Name_Id; + Name_Step : Name_Id; + Cond : Node_Id; + Cursor_Decl : Node_Id; + Renaming_Decl : Node_Id; + + begin + Stats := Statements (N); + + if Of_Present (I_Spec) then + Cursor := Make_Temporary (Loc, 'C'); + else + Cursor := Id; + end if; + + if Reverse_Present (I_Spec) then + + -- Must verify that the container has a reverse iterator ??? + + Name_Init := Name_Last; + Name_Step := Name_Previous; + + else + Name_Init := Name_First; + Name_Step := Name_Next; + end if; + + -- C : Cursor_Type := Container.First; + + Cursor_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Cursor, + Object_Definition => + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Pack, Loc), + Selector_Name => Make_Identifier (Loc, Name_Cursor)), + Expression => + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Container, Loc), + Selector_Name => Make_Identifier (Loc, Name_Init))); + + Insert_Action (N, Cursor_Decl); + + -- while C /= No_Element loop + + Cond := Make_Op_Ne (Loc, + Left_Opnd => New_Occurrence_Of (Cursor, Loc), + Right_Opnd => Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Pack, Loc), + Selector_Name => + Make_Identifier (Loc, Name_No_Element))); + + if Of_Present (I_Spec) then + + -- Id : Element_Type renames Pack.Element (Cursor); + + Renaming_Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Id, + Subtype_Mark => + New_Occurrence_Of (Element_Type, Loc), + Name => + Make_Indexed_Component (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Pack, Loc), + Selector_Name => + Make_Identifier (Loc, Chars => Name_Element)), + Expressions => + New_List (New_Occurrence_Of (Cursor, Loc)))); + + Prepend (Renaming_Decl, Stats); + end if; + + -- For both iterator forms, add call to step operation (Next or + -- Previous) to advance cursor. + + Append_To (Stats, + Make_Procedure_Call_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Pack, Loc), + Selector_Name => Make_Identifier (Loc, Name_Step)), + Parameter_Associations => + New_List (New_Occurrence_Of (Cursor, Loc)))); + + New_Loop := Make_Loop_Statement (Loc, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, Condition => Cond), + Statements => Stats, + End_Label => Empty); + end; + end if; + + -- Set_Analyzed (I_Spec); + -- Why is this commented out??? + + Rewrite (N, New_Loop); + Analyze (N); + end Expand_Iterator_Loop; + + ----------------------------- + -- Expand_N_Loop_Statement -- + ----------------------------- + + -- 1. Remove null loop entirely + -- 2. Deal with while condition for C/Fortran boolean + -- 3. Deal with loops with a non-standard enumeration type range + -- 4. Deal with while loops where Condition_Actions is set + -- 5. Deal with loops over predicated subtypes + -- 6. Deal with loops with iterators over arrays and containers + -- 7. Insert polling call if required + + procedure Expand_N_Loop_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Isc : constant Node_Id := Iteration_Scheme (N); + + begin + -- Delete null loop + + if Is_Null_Loop (N) then + Rewrite (N, Make_Null_Statement (Loc)); + return; + end if; + + -- Deal with condition for C/Fortran Boolean + + if Present (Isc) then + Adjust_Condition (Condition (Isc)); + end if; + + -- Generate polling call + + if Is_Non_Empty_List (Statements (N)) then + Generate_Poll_Call (First (Statements (N))); + end if; + + -- Nothing more to do for plain loop with no iteration scheme + + if No (Isc) then + null; + + -- Case of for loop (Loop_Parameter_Specification present) + + -- Note: we do not have to worry about validity checking of the for loop + -- range bounds here, since they were frozen with constant declarations + -- and it is during that process that the validity checking is done. + + elsif Present (Loop_Parameter_Specification (Isc)) then + declare + LPS : constant Node_Id := Loop_Parameter_Specification (Isc); + Loop_Id : constant Entity_Id := Defining_Identifier (LPS); + Ltype : constant Entity_Id := Etype (Loop_Id); + Btype : constant Entity_Id := Base_Type (Ltype); + Expr : Node_Id; + New_Id : Entity_Id; + + begin + -- Deal with loop over predicates + + if Is_Discrete_Type (Ltype) + and then Present (Predicate_Function (Ltype)) + then + Expand_Predicated_Loop (N); + + -- Handle the case where we have a for loop with the range type + -- being an enumeration type with non-standard representation. + -- In this case we expand: + + -- for x in [reverse] a .. b loop + -- ... + -- end loop; + + -- to + + -- for xP in [reverse] integer + -- range etype'Pos (a) .. etype'Pos (b) + -- loop + -- declare + -- x : constant etype := Pos_To_Rep (xP); + -- begin + -- ... + -- end; + -- end loop; + + elsif Is_Enumeration_Type (Btype) + and then Present (Enum_Pos_To_Rep (Btype)) + then + New_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Loop_Id), 'P')); + + -- If the type has a contiguous representation, successive + -- values can be generated as offsets from the first literal. + + if Has_Contiguous_Rep (Btype) then + Expr := + Unchecked_Convert_To (Btype, + Make_Op_Add (Loc, + Left_Opnd => + Make_Integer_Literal (Loc, + Enumeration_Rep (First_Literal (Btype))), + Right_Opnd => New_Reference_To (New_Id, Loc))); + else + -- Use the constructed array Enum_Pos_To_Rep + + Expr := + Make_Indexed_Component (Loc, + Prefix => + New_Reference_To (Enum_Pos_To_Rep (Btype), Loc), + Expressions => + New_List (New_Reference_To (New_Id, Loc))); + end if; + + Rewrite (N, + Make_Loop_Statement (Loc, + Identifier => Identifier (N), + + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => New_Id, + Reverse_Present => Reverse_Present (LPS), + + Discrete_Subtype_Definition => + Make_Subtype_Indication (Loc, + + Subtype_Mark => + New_Reference_To (Standard_Natural, Loc), + + Constraint => + Make_Range_Constraint (Loc, + Range_Expression => + Make_Range (Loc, + + Low_Bound => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Btype, Loc), + + Attribute_Name => Name_Pos, + + Expressions => New_List ( + Relocate_Node + (Type_Low_Bound (Ltype)))), + + High_Bound => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Btype, Loc), + + Attribute_Name => Name_Pos, + + Expressions => New_List ( + Relocate_Node + (Type_High_Bound + (Ltype))))))))), + + Statements => New_List ( + Make_Block_Statement (Loc, + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Loop_Id, + Constant_Present => True, + Object_Definition => + New_Reference_To (Ltype, Loc), + Expression => Expr)), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements (N)))), + + End_Label => End_Label (N))); + Analyze (N); + + -- Nothing to do with other cases of for loops + + else + null; + end if; + end; + + -- Second case, if we have a while loop with Condition_Actions set, then + -- we change it into a plain loop: + + -- while C loop + -- ... + -- end loop; + + -- changed to: + + -- loop + -- <> + -- exit when not C; + -- ... + -- end loop + + elsif Present (Isc) + and then Present (Condition_Actions (Isc)) + then + declare + ES : Node_Id; + + begin + ES := + Make_Exit_Statement (Sloc (Condition (Isc)), + Condition => + Make_Op_Not (Sloc (Condition (Isc)), + Right_Opnd => Condition (Isc))); + + Prepend (ES, Statements (N)); + Insert_List_Before (ES, Condition_Actions (Isc)); + + -- This is not an implicit loop, since it is generated in response + -- to the loop statement being processed. If this is itself + -- implicit, the restriction has already been checked. If not, + -- it is an explicit loop. + + Rewrite (N, + Make_Loop_Statement (Sloc (N), + Identifier => Identifier (N), + Statements => Statements (N), + End_Label => End_Label (N))); + + Analyze (N); + end; + + -- Here to deal with iterator case + + elsif Present (Isc) + and then Present (Iterator_Specification (Isc)) + then + Expand_Iterator_Loop (N); + end if; + end Expand_N_Loop_Statement; + + ---------------------------- + -- Expand_Predicated_Loop -- + ---------------------------- + + -- Note: the expander can handle generation of loops over predicated + -- subtypes for both the dynamic and static cases. Depending on what + -- we decide is allowed in Ada 2012 mode and/or extensions allowed + -- mode, the semantic analyzer may disallow one or both forms. + + procedure Expand_Predicated_Loop (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Isc : constant Node_Id := Iteration_Scheme (N); + LPS : constant Node_Id := Loop_Parameter_Specification (Isc); + Loop_Id : constant Entity_Id := Defining_Identifier (LPS); + Ltype : constant Entity_Id := Etype (Loop_Id); + Stat : constant List_Id := Static_Predicate (Ltype); + Stmts : constant List_Id := Statements (N); + + begin + -- Case of iteration over non-static predicate, should not be possible + -- since this is not allowed by the semantics and should have been + -- caught during analysis of the loop statement. + + if No (Stat) then + raise Program_Error; + + -- If the predicate list is empty, that corresponds to a predicate of + -- False, in which case the loop won't run at all, and we rewrite the + -- entire loop as a null statement. + + elsif Is_Empty_List (Stat) then + Rewrite (N, Make_Null_Statement (Loc)); + Analyze (N); + + -- For expansion over a static predicate we generate the following + + -- declare + -- J : Ltype := min-val; + -- begin + -- loop + -- body + -- case J is + -- when endpoint => J := startpoint; + -- when endpoint => J := startpoint; + -- ... + -- when max-val => exit; + -- when others => J := Lval'Succ (J); + -- end case; + -- end loop; + -- end; + + -- To make this a little clearer, let's take a specific example: + + -- type Int is range 1 .. 10; + -- subtype L is Int with + -- predicate => L in 3 | 10 | 5 .. 7; + -- ... + -- for L in StaticP loop + -- Put_Line ("static:" & J'Img); + -- end loop; + + -- In this case, the loop is transformed into + + -- begin + -- J : L := 3; + -- loop + -- body + -- case J is + -- when 3 => J := 5; + -- when 7 => J := 10; + -- when 10 => exit; + -- when others => J := L'Succ (J); + -- end case; + -- end loop; + -- end; + + else + Static_Predicate : declare + S : Node_Id; + D : Node_Id; + P : Node_Id; + Alts : List_Id; + Cstm : Node_Id; + + function Lo_Val (N : Node_Id) return Node_Id; + -- Given static expression or static range, returns an identifier + -- whose value is the low bound of the expression value or range. + + function Hi_Val (N : Node_Id) return Node_Id; + -- Given static expression or static range, returns an identifier + -- whose value is the high bound of the expression value or range. + + ------------ + -- Hi_Val -- + ------------ + + function Hi_Val (N : Node_Id) return Node_Id is + begin + if Is_Static_Expression (N) then + return New_Copy (N); + else + pragma Assert (Nkind (N) = N_Range); + return New_Copy (High_Bound (N)); + end if; + end Hi_Val; + + ------------ + -- Lo_Val -- + ------------ + + function Lo_Val (N : Node_Id) return Node_Id is + begin + if Is_Static_Expression (N) then + return New_Copy (N); + else + pragma Assert (Nkind (N) = N_Range); + return New_Copy (Low_Bound (N)); + end if; + end Lo_Val; + + -- Start of processing for Static_Predicate + + begin + -- Convert loop identifier to normal variable and reanalyze it so + -- that this conversion works. We have to use the same defining + -- identifier, since there may be references in the loop body. + + Set_Analyzed (Loop_Id, False); + Set_Ekind (Loop_Id, E_Variable); + + -- Loop to create branches of case statement + + Alts := New_List; + P := First (Stat); + while Present (P) loop + if No (Next (P)) then + S := Make_Exit_Statement (Loc); + else + S := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Loop_Id, Loc), + Expression => Lo_Val (Next (P))); + Set_Suppress_Assignment_Checks (S); + end if; + + Append_To (Alts, + Make_Case_Statement_Alternative (Loc, + Statements => New_List (S), + Discrete_Choices => New_List (Hi_Val (P)))); + + Next (P); + end loop; + + -- Add others choice + + S := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Loop_Id, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ltype, Loc), + Attribute_Name => Name_Succ, + Expressions => New_List ( + New_Occurrence_Of (Loop_Id, Loc)))); + Set_Suppress_Assignment_Checks (S); + + Append_To (Alts, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List (S))); + + -- Construct case statement and append to body statements + + Cstm := + Make_Case_Statement (Loc, + Expression => New_Occurrence_Of (Loop_Id, Loc), + Alternatives => Alts); + Append_To (Stmts, Cstm); + + -- Rewrite the loop + + D := + Make_Object_Declaration (Loc, + Defining_Identifier => Loop_Id, + Object_Definition => New_Occurrence_Of (Ltype, Loc), + Expression => Lo_Val (First (Stat))); + Set_Suppress_Assignment_Checks (D); + + Rewrite (N, + Make_Block_Statement (Loc, + Declarations => New_List (D), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Loop_Statement (Loc, + Statements => Stmts, + End_Label => Empty))))); + + Analyze (N); + end Static_Predicate; + end if; + end Expand_Predicated_Loop; + + ------------------------------ + -- Make_Tag_Ctrl_Assignment -- + ------------------------------ + + function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (N); + L : constant Node_Id := Name (N); + T : constant Entity_Id := Underlying_Type (Etype (L)); + + Ctrl_Act : constant Boolean := Needs_Finalization (T) + and then not No_Ctrl_Actions (N); + + Component_Assign : constant Boolean := + Is_Fully_Repped_Tagged_Type (T); + + Save_Tag : constant Boolean := Is_Tagged_Type (T) + and then not Component_Assign + and then not No_Ctrl_Actions (N) + and then Tagged_Type_Expansion; + -- Tags are not saved and restored when VM_Target because VM tags are + -- represented implicitly in objects. + + Res : List_Id; + Tag_Tmp : Entity_Id; + + Prev_Tmp : Entity_Id; + Next_Tmp : Entity_Id; + Ctrl_Ref : Node_Id; + + begin + Res := New_List; + + -- Finalize the target of the assignment when controlled + + -- We have two exceptions here: + + -- 1. If we are in an init proc since it is an initialization more + -- than an assignment. + + -- 2. If the left-hand side is a temporary that was not initialized + -- (or the parent part of a temporary since it is the case in + -- extension aggregates). Such a temporary does not come from + -- source. We must examine the original node for the prefix, because + -- it may be a component of an entry formal, in which case it has + -- been rewritten and does not appear to come from source either. + + -- Case of init proc + + if not Ctrl_Act then + null; + + -- The left hand side is an uninitialized temporary object + + elsif Nkind (L) = N_Type_Conversion + and then Is_Entity_Name (Expression (L)) + and then Nkind (Parent (Entity (Expression (L)))) = + N_Object_Declaration + and then No_Initialization (Parent (Entity (Expression (L)))) + then + null; + + else + Append_List_To (Res, + Make_Final_Call + (Ref => Duplicate_Subexpr_No_Checks (L), + Typ => Etype (L), + With_Detach => New_Reference_To (Standard_False, Loc))); + end if; + + -- Save the Tag in a local variable Tag_Tmp + + if Save_Tag then + Tag_Tmp := Make_Temporary (Loc, 'A'); + + Append_To (Res, + Make_Object_Declaration (Loc, + Defining_Identifier => Tag_Tmp, + Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), + Expression => + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr_No_Checks (L), + Selector_Name => New_Reference_To (First_Tag_Component (T), + Loc)))); + + -- Otherwise Tag_Tmp not used + + else + Tag_Tmp := Empty; + end if; + + if Ctrl_Act then + if VM_Target /= No_VM then + + -- Cannot assign part of the object in a VM context, so instead + -- fallback to the previous mechanism, even though it is not + -- completely correct ??? + + -- Save the Finalization Pointers in local variables Prev_Tmp and + -- Next_Tmp. For objects with Has_Controlled_Component set, these + -- pointers are in the Record_Controller + + Ctrl_Ref := Duplicate_Subexpr (L); + + if Has_Controlled_Component (T) then + Ctrl_Ref := + Make_Selected_Component (Loc, + Prefix => Ctrl_Ref, + Selector_Name => + New_Reference_To (Controller_Component (T), Loc)); + end if; + + Prev_Tmp := Make_Temporary (Loc, 'B'); + + Append_To (Res, + Make_Object_Declaration (Loc, + Defining_Identifier => Prev_Tmp, + + Object_Definition => + New_Reference_To (RTE (RE_Finalizable_Ptr), Loc), + + Expression => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_Finalizable), Ctrl_Ref), + Selector_Name => Make_Identifier (Loc, Name_Prev)))); + + Next_Tmp := Make_Temporary (Loc, 'C'); + + Append_To (Res, + Make_Object_Declaration (Loc, + Defining_Identifier => Next_Tmp, + + Object_Definition => + New_Reference_To (RTE (RE_Finalizable_Ptr), Loc), + + Expression => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_Finalizable), + New_Copy_Tree (Ctrl_Ref)), + Selector_Name => Make_Identifier (Loc, Name_Next)))); + + -- Do the Assignment + + Append_To (Res, Relocate_Node (N)); + + else + -- Regular (non VM) processing for controlled types and types with + -- controlled components + + -- Variables of such types contain pointers used to chain them in + -- finalization lists, in addition to user data. These pointers + -- are specific to each object of the type, not to the value being + -- assigned. + + -- Thus they need to be left intact during the assignment. We + -- achieve this by constructing a Storage_Array subtype, and by + -- overlaying objects of this type on the source and target of the + -- assignment. The assignment is then rewritten to assignments of + -- slices of these arrays, copying the user data, and leaving the + -- pointers untouched. + + Controlled_Actions : declare + Prev_Ref : Node_Id; + -- A reference to the Prev component of the record controller + + First_After_Root : Node_Id := Empty; + -- Index of first byte to be copied (used to skip + -- Root_Controlled in controlled objects). + + Last_Before_Hole : Node_Id := Empty; + -- Index of last byte to be copied before outermost record + -- controller data. + + Hole_Length : Node_Id := Empty; + -- Length of record controller data (Prev and Next pointers) + + First_After_Hole : Node_Id := Empty; + -- Index of first byte to be copied after outermost record + -- controller data. + + Expr, Source_Size : Node_Id; + Source_Actual_Subtype : Entity_Id; + -- Used for computation of the size of the data to be copied + + Range_Type : Entity_Id; + Opaque_Type : Entity_Id; + + function Build_Slice + (Rec : Entity_Id; + Lo : Node_Id; + Hi : Node_Id) return Node_Id; + -- Build and return a slice of an array of type S overlaid on + -- object Rec, with bounds specified by Lo and Hi. If either + -- bound is empty, a default of S'First (respectively S'Last) + -- is used. + + ----------------- + -- Build_Slice -- + ----------------- + + function Build_Slice + (Rec : Node_Id; + Lo : Node_Id; + Hi : Node_Id) return Node_Id + is + Lo_Bound : Node_Id; + Hi_Bound : Node_Id; + + Opaque : constant Node_Id := + Unchecked_Convert_To (Opaque_Type, + Make_Attribute_Reference (Loc, + Prefix => Rec, + Attribute_Name => Name_Address)); + -- Access value designating an opaque storage array of type + -- S overlaid on record Rec. + + begin + -- Compute slice bounds using S'First (1) and S'Last as + -- default values when not specified by the caller. + + if No (Lo) then + Lo_Bound := Make_Integer_Literal (Loc, 1); + else + Lo_Bound := Lo; + end if; + + if No (Hi) then + Hi_Bound := Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Range_Type, Loc), + Attribute_Name => Name_Last); + else + Hi_Bound := Hi; + end if; + + return Make_Slice (Loc, + Prefix => + Opaque, + Discrete_Range => Make_Range (Loc, + Lo_Bound, Hi_Bound)); + end Build_Slice; + + -- Start of processing for Controlled_Actions + + begin + -- Create a constrained subtype of Storage_Array whose size + -- corresponds to the value being assigned. + + -- subtype G is Storage_Offset range + -- 1 .. (Expr'Size + Storage_Unit - 1) / Storage_Unit + + Expr := Duplicate_Subexpr_No_Checks (Expression (N)); + + if Nkind (Expr) = N_Qualified_Expression then + Expr := Expression (Expr); + end if; + + Source_Actual_Subtype := Etype (Expr); + + if Has_Discriminants (Source_Actual_Subtype) + and then not Is_Constrained (Source_Actual_Subtype) + then + Append_To (Res, + Build_Actual_Subtype (Source_Actual_Subtype, Expr)); + Source_Actual_Subtype := Defining_Identifier (Last (Res)); + end if; + + Source_Size := + Make_Op_Add (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Source_Actual_Subtype, Loc), + Attribute_Name => Name_Size), + Right_Opnd => + Make_Integer_Literal (Loc, + Intval => System_Storage_Unit - 1)); + + Source_Size := + Make_Op_Divide (Loc, + Left_Opnd => Source_Size, + Right_Opnd => + Make_Integer_Literal (Loc, + Intval => System_Storage_Unit)); + + Range_Type := Make_Temporary (Loc, 'G'); + + Append_To (Res, + Make_Subtype_Declaration (Loc, + Defining_Identifier => Range_Type, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Storage_Offset), Loc), + Constraint => Make_Range_Constraint (Loc, + Range_Expression => + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Source_Size))))); + + -- subtype S is Storage_Array (G) + + Append_To (Res, + Make_Subtype_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'S'), + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Storage_Array), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => + New_List (New_Reference_To (Range_Type, Loc)))))); + + -- type A is access S + + Opaque_Type := Make_Temporary (Loc, 'A'); + + Append_To (Res, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Opaque_Type, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of ( + Defining_Identifier (Last (Res)), Loc)))); + + -- Generate appropriate slice assignments + + First_After_Root := Make_Integer_Literal (Loc, 1); + + -- For controlled object, skip Root_Controlled part + + if Is_Controlled (T) then + First_After_Root := + Make_Op_Add (Loc, + First_After_Root, + Make_Op_Divide (Loc, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Root_Controlled), Loc), + Attribute_Name => Name_Size), + Make_Integer_Literal (Loc, System_Storage_Unit))); + end if; + + -- For the case of a record with controlled components, skip + -- record controller Prev/Next components. These components + -- constitute a 'hole' in the middle of the data to be copied. + + if Has_Controlled_Component (T) then + Prev_Ref := + Make_Selected_Component (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr_No_Checks (L), + Selector_Name => + New_Reference_To (Controller_Component (T), Loc)), + Selector_Name => Make_Identifier (Loc, Name_Prev)); + + -- Last index before hole: determined by position of the + -- _Controller.Prev component. + + Last_Before_Hole := Make_Temporary (Loc, 'L'); + + Append_To (Res, + Make_Object_Declaration (Loc, + Defining_Identifier => Last_Before_Hole, + Object_Definition => New_Occurrence_Of ( + RTE (RE_Storage_Offset), Loc), + Constant_Present => True, + Expression => + Make_Op_Add (Loc, + Make_Attribute_Reference (Loc, + Prefix => Prev_Ref, + Attribute_Name => Name_Position), + Make_Attribute_Reference (Loc, + Prefix => New_Copy_Tree (Prefix (Prev_Ref)), + Attribute_Name => Name_Position)))); + + -- Hole length: size of the Prev and Next components + + Hole_Length := + Make_Op_Multiply (Loc, + Left_Opnd => Make_Integer_Literal (Loc, Uint_2), + Right_Opnd => + Make_Op_Divide (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Copy_Tree (Prev_Ref), + Attribute_Name => Name_Size), + Right_Opnd => + Make_Integer_Literal (Loc, + Intval => System_Storage_Unit))); + + -- First index after hole + + First_After_Hole := Make_Temporary (Loc, 'F'); + + Append_To (Res, + Make_Object_Declaration (Loc, + Defining_Identifier => First_After_Hole, + Object_Definition => New_Occurrence_Of ( + RTE (RE_Storage_Offset), Loc), + Constant_Present => True, + Expression => + Make_Op_Add (Loc, + Left_Opnd => + Make_Op_Add (Loc, + Left_Opnd => + New_Occurrence_Of (Last_Before_Hole, Loc), + Right_Opnd => Hole_Length), + Right_Opnd => Make_Integer_Literal (Loc, 1)))); + + Last_Before_Hole := + New_Occurrence_Of (Last_Before_Hole, Loc); + First_After_Hole := + New_Occurrence_Of (First_After_Hole, Loc); + end if; + + -- Assign the first slice (possibly skipping Root_Controlled, + -- up to the beginning of the record controller if present, + -- up to the end of the object if not). + + Append_To (Res, Make_Assignment_Statement (Loc, + Name => Build_Slice ( + Rec => Duplicate_Subexpr_No_Checks (L), + Lo => First_After_Root, + Hi => Last_Before_Hole), + + Expression => Build_Slice ( + Rec => Expression (N), + Lo => First_After_Root, + Hi => New_Copy_Tree (Last_Before_Hole)))); + + if Present (First_After_Hole) then + + -- If a record controller is present, copy the second slice, + -- from right after the _Controller.Next component up to the + -- end of the object. + + Append_To (Res, Make_Assignment_Statement (Loc, + Name => Build_Slice ( + Rec => Duplicate_Subexpr_No_Checks (L), + Lo => First_After_Hole, + Hi => Empty), + Expression => Build_Slice ( + Rec => Duplicate_Subexpr_No_Checks (Expression (N)), + Lo => New_Copy_Tree (First_After_Hole), + Hi => Empty))); + end if; + end Controlled_Actions; + end if; + + -- Not controlled case + + else + declare + Asn : constant Node_Id := Relocate_Node (N); + + begin + -- If this is the case of a tagged type with a full rep clause, + -- we must expand it into component assignments, so we mark the + -- node as unanalyzed, to get it reanalyzed, but flag it has + -- requiring component-wise assignment so we don't get infinite + -- recursion. + + if Component_Assign then + Set_Analyzed (Asn, False); + Set_Componentwise_Assignment (Asn, True); + end if; + + Append_To (Res, Asn); + end; + end if; + + -- Restore the tag + + if Save_Tag then + Append_To (Res, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr_No_Checks (L), + Selector_Name => New_Reference_To (First_Tag_Component (T), + Loc)), + Expression => New_Reference_To (Tag_Tmp, Loc))); + end if; + + if Ctrl_Act then + if VM_Target /= No_VM then + -- Restore the finalization pointers + + Append_To (Res, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_Finalizable), + New_Copy_Tree (Ctrl_Ref)), + Selector_Name => Make_Identifier (Loc, Name_Prev)), + Expression => New_Reference_To (Prev_Tmp, Loc))); + + Append_To (Res, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_Finalizable), + New_Copy_Tree (Ctrl_Ref)), + Selector_Name => Make_Identifier (Loc, Name_Next)), + Expression => New_Reference_To (Next_Tmp, Loc))); + end if; + + -- Adjust the target after the assignment when controlled (not in the + -- init proc since it is an initialization more than an assignment). + + Append_List_To (Res, + Make_Adjust_Call ( + Ref => Duplicate_Subexpr_Move_Checks (L), + Typ => Etype (L), + Flist_Ref => New_Reference_To (RTE (RE_Global_Final_List), Loc), + With_Attach => Make_Integer_Literal (Loc, 0))); + end if; + + return Res; + + exception + -- Could use comment here ??? + + when RE_Not_Available => + return Empty_List; + end Make_Tag_Ctrl_Assignment; + +end Exp_Ch5; diff --git a/gcc/ada/exp_ch5.ads b/gcc/ada/exp_ch5.ads new file mode 100644 index 000000000..796716472 --- /dev/null +++ b/gcc/ada/exp_ch5.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 5 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for chapter 5 constructs + +with Types; use Types; + +package Exp_Ch5 is + procedure Expand_N_Assignment_Statement (N : Node_Id); + procedure Expand_N_Block_Statement (N : Node_Id); + procedure Expand_N_Case_Statement (N : Node_Id); + procedure Expand_N_Exit_Statement (N : Node_Id); + procedure Expand_N_Goto_Statement (N : Node_Id); + procedure Expand_N_If_Statement (N : Node_Id); + procedure Expand_N_Loop_Statement (N : Node_Id); +end Exp_Ch5; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb new file mode 100644 index 000000000..1a5fd1376 --- /dev/null +++ b/gcc/ada/exp_ch6.adb @@ -0,0 +1,7498 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 6 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Debug; use Debug; +with Einfo; use Einfo; +with Errout; use Errout; +with Elists; use Elists; +with Exp_Atag; use Exp_Atag; +with Exp_Ch2; use Exp_Ch2; +with Exp_Ch3; use Exp_Ch3; +with Exp_Ch7; use Exp_Ch7; +with Exp_Ch9; use Exp_Ch9; +with Exp_Dbug; use Exp_Dbug; +with Exp_Disp; use Exp_Disp; +with Exp_Dist; use Exp_Dist; +with Exp_Intr; use Exp_Intr; +with Exp_Pakd; use Exp_Pakd; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Exp_VFpt; use Exp_VFpt; +with Fname; use Fname; +with Freeze; use Freeze; +with Inline; use Inline; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch12; use Sem_Ch12; +with Sem_Ch13; use Sem_Ch13; +with Sem_Eval; use Sem_Eval; +with Sem_Disp; use Sem_Disp; +with Sem_Dist; use Sem_Dist; +with Sem_Mech; use Sem_Mech; +with Sem_Res; use Sem_Res; +with Sem_SCIL; use Sem_SCIL; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Uintp; use Uintp; +with Validsw; use Validsw; + +package body Exp_Ch6 is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Add_Access_Actual_To_Build_In_Place_Call + (Function_Call : Node_Id; + Function_Id : Entity_Id; + Return_Object : Node_Id; + Is_Access : Boolean := False); + -- Ada 2005 (AI-318-02): Apply the Unrestricted_Access attribute to the + -- object name given by Return_Object and add the attribute to the end of + -- the actual parameter list associated with the build-in-place function + -- call denoted by Function_Call. However, if Is_Access is True, then + -- Return_Object is already an access expression, in which case it's passed + -- along directly to the build-in-place function. Finally, if Return_Object + -- is empty, then pass a null literal as the actual. + + procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call + (Function_Call : Node_Id; + Function_Id : Entity_Id; + Alloc_Form : BIP_Allocation_Form := Unspecified; + Alloc_Form_Exp : Node_Id := Empty); + -- Ada 2005 (AI-318-02): Add an actual indicating the form of allocation, + -- if any, to be done by a build-in-place function. If Alloc_Form_Exp is + -- present, then use it, otherwise pass a literal corresponding to the + -- Alloc_Form parameter (which must not be Unspecified in that case). + + procedure Add_Extra_Actual_To_Call + (Subprogram_Call : Node_Id; + Extra_Formal : Entity_Id; + Extra_Actual : Node_Id); + -- Adds Extra_Actual as a named parameter association for the formal + -- Extra_Formal in Subprogram_Call. + + procedure Add_Final_List_Actual_To_Build_In_Place_Call + (Function_Call : Node_Id; + Function_Id : Entity_Id; + Acc_Type : Entity_Id; + Sel_Comp : Node_Id := Empty); + -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type has + -- controlled parts, add an actual parameter that is a pointer to + -- appropriate finalization list. The finalization list is that of the + -- current scope, except for "new Acc'(F(...))" in which case it's the + -- finalization list of the access type returned by the allocator. Acc_Type + -- is that type in the allocator case; Empty otherwise. If Sel_Comp is + -- not Empty, then it denotes a selected component and the finalization + -- list is obtained from the _controller list of the prefix object. + + procedure Add_Task_Actuals_To_Build_In_Place_Call + (Function_Call : Node_Id; + Function_Id : Entity_Id; + Master_Actual : Node_Id); + -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type + -- contains tasks, add two actual parameters: the master, and a pointer to + -- the caller's activation chain. Master_Actual is the actual parameter + -- expression to pass for the master. In most cases, this is the current + -- master (_master). The two exceptions are: If the function call is the + -- initialization expression for an allocator, we pass the master of the + -- access type. If the function call is the initialization expression for a + -- return object, we pass along the master passed in by the caller. The + -- activation chain to pass is always the local one. Note: Master_Actual + -- can be Empty, but only if there are no tasks. + + procedure Check_Overriding_Operation (Subp : Entity_Id); + -- Subp is a dispatching operation. Check whether it may override an + -- inherited private operation, in which case its DT entry is that of + -- the hidden operation, not the one it may have received earlier. + -- This must be done before emitting the code to set the corresponding + -- DT to the address of the subprogram. The actual placement of Subp in + -- the proper place in the list of primitive operations is done in + -- Declare_Inherited_Private_Subprograms, which also has to deal with + -- implicit operations. This duplication is unavoidable for now??? + + procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id); + -- This procedure is called only if the subprogram body N, whose spec + -- has the given entity Spec, contains a parameterless recursive call. + -- It attempts to generate runtime code to detect if this a case of + -- infinite recursion. + -- + -- The body is scanned to determine dependencies. If the only external + -- dependencies are on a small set of scalar variables, then the values + -- of these variables are captured on entry to the subprogram, and if + -- the values are not changed for the call, we know immediately that + -- we have an infinite recursion. + + procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id); + -- For each actual of an in-out or out parameter which is a numeric + -- (view) conversion of the form T (A), where A denotes a variable, + -- we insert the declaration: + -- + -- Temp : T[ := T (A)]; + -- + -- prior to the call. Then we replace the actual with a reference to Temp, + -- and append the assignment: + -- + -- A := TypeA (Temp); + -- + -- after the call. Here TypeA is the actual type of variable A. For out + -- parameters, the initial declaration has no expression. If A is not an + -- entity name, we generate instead: + -- + -- Var : TypeA renames A; + -- Temp : T := Var; -- omitting expression for out parameter. + -- ... + -- Var := TypeA (Temp); + -- + -- For other in-out parameters, we emit the required constraint checks + -- before and/or after the call. + -- + -- For all parameter modes, actuals that denote components and slices of + -- packed arrays are expanded into suitable temporaries. + -- + -- For non-scalar objects that are possibly unaligned, add call by copy + -- code (copy in for IN and IN OUT, copy out for OUT and IN OUT). + + procedure Expand_Inlined_Call + (N : Node_Id; + Subp : Entity_Id; + Orig_Subp : Entity_Id); + -- If called subprogram can be inlined by the front-end, retrieve the + -- analyzed body, replace formals with actuals and expand call in place. + -- Generate thunks for actuals that are expressions, and insert the + -- corresponding constant declarations before the call. If the original + -- call is to a derived operation, the return type is the one of the + -- derived operation, but the body is that of the original, so return + -- expressions in the body must be converted to the desired type (which + -- is simply not noted in the tree without inline expansion). + + procedure Expand_Non_Function_Return (N : Node_Id); + -- Called by Expand_N_Simple_Return_Statement in case we're returning from + -- a procedure body, entry body, accept statement, or extended return + -- statement. Note that all non-function returns are simple return + -- statements. + + function Expand_Protected_Object_Reference + (N : Node_Id; + Scop : Entity_Id) return Node_Id; + + procedure Expand_Protected_Subprogram_Call + (N : Node_Id; + Subp : Entity_Id; + Scop : Entity_Id); + -- A call to a protected subprogram within the protected object may appear + -- as a regular call. The list of actuals must be expanded to contain a + -- reference to the object itself, and the call becomes a call to the + -- corresponding protected subprogram. + + function Is_Null_Procedure (Subp : Entity_Id) return Boolean; + -- Predicate to recognize stubbed procedures and null procedures, which + -- can be inlined unconditionally in all cases. + + procedure Expand_Simple_Function_Return (N : Node_Id); + -- Expand simple return from function. In the case where we are returning + -- from a function body this is called by Expand_N_Simple_Return_Statement. + + ---------------------------------------------- + -- Add_Access_Actual_To_Build_In_Place_Call -- + ---------------------------------------------- + + procedure Add_Access_Actual_To_Build_In_Place_Call + (Function_Call : Node_Id; + Function_Id : Entity_Id; + Return_Object : Node_Id; + Is_Access : Boolean := False) + is + Loc : constant Source_Ptr := Sloc (Function_Call); + Obj_Address : Node_Id; + Obj_Acc_Formal : Entity_Id; + + begin + -- Locate the implicit access parameter in the called function + + Obj_Acc_Formal := Build_In_Place_Formal (Function_Id, BIP_Object_Access); + + -- If no return object is provided, then pass null + + if not Present (Return_Object) then + Obj_Address := Make_Null (Loc); + Set_Parent (Obj_Address, Function_Call); + + -- If Return_Object is already an expression of an access type, then use + -- it directly, since it must be an access value denoting the return + -- object, and couldn't possibly be the return object itself. + + elsif Is_Access then + Obj_Address := Return_Object; + Set_Parent (Obj_Address, Function_Call); + + -- Apply Unrestricted_Access to caller's return object + + else + Obj_Address := + Make_Attribute_Reference (Loc, + Prefix => Return_Object, + Attribute_Name => Name_Unrestricted_Access); + + Set_Parent (Return_Object, Obj_Address); + Set_Parent (Obj_Address, Function_Call); + end if; + + Analyze_And_Resolve (Obj_Address, Etype (Obj_Acc_Formal)); + + -- Build the parameter association for the new actual and add it to the + -- end of the function's actuals. + + Add_Extra_Actual_To_Call (Function_Call, Obj_Acc_Formal, Obj_Address); + end Add_Access_Actual_To_Build_In_Place_Call; + + -------------------------------------------------- + -- Add_Alloc_Form_Actual_To_Build_In_Place_Call -- + -------------------------------------------------- + + procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call + (Function_Call : Node_Id; + Function_Id : Entity_Id; + Alloc_Form : BIP_Allocation_Form := Unspecified; + Alloc_Form_Exp : Node_Id := Empty) + is + Loc : constant Source_Ptr := Sloc (Function_Call); + Alloc_Form_Actual : Node_Id; + Alloc_Form_Formal : Node_Id; + + begin + -- The allocation form generally doesn't need to be passed in the case + -- of a constrained result subtype, since normally the caller performs + -- the allocation in that case. However this formal is still needed in + -- the case where the function has a tagged result, because generally + -- such functions can be called in a dispatching context and such calls + -- must be handled like calls to class-wide functions. + + if Is_Constrained (Underlying_Type (Etype (Function_Id))) + and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id))) + then + return; + end if; + + -- Locate the implicit allocation form parameter in the called function. + -- Maybe it would be better for each implicit formal of a build-in-place + -- function to have a flag or a Uint attribute to identify it. ??? + + Alloc_Form_Formal := Build_In_Place_Formal (Function_Id, BIP_Alloc_Form); + + if Present (Alloc_Form_Exp) then + pragma Assert (Alloc_Form = Unspecified); + + Alloc_Form_Actual := Alloc_Form_Exp; + + else + pragma Assert (Alloc_Form /= Unspecified); + + Alloc_Form_Actual := + Make_Integer_Literal (Loc, + Intval => UI_From_Int (BIP_Allocation_Form'Pos (Alloc_Form))); + end if; + + Analyze_And_Resolve (Alloc_Form_Actual, Etype (Alloc_Form_Formal)); + + -- Build the parameter association for the new actual and add it to the + -- end of the function's actuals. + + Add_Extra_Actual_To_Call + (Function_Call, Alloc_Form_Formal, Alloc_Form_Actual); + end Add_Alloc_Form_Actual_To_Build_In_Place_Call; + + ------------------------------ + -- Add_Extra_Actual_To_Call -- + ------------------------------ + + procedure Add_Extra_Actual_To_Call + (Subprogram_Call : Node_Id; + Extra_Formal : Entity_Id; + Extra_Actual : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Subprogram_Call); + Param_Assoc : Node_Id; + + begin + Param_Assoc := + Make_Parameter_Association (Loc, + Selector_Name => New_Occurrence_Of (Extra_Formal, Loc), + Explicit_Actual_Parameter => Extra_Actual); + + Set_Parent (Param_Assoc, Subprogram_Call); + Set_Parent (Extra_Actual, Param_Assoc); + + if Present (Parameter_Associations (Subprogram_Call)) then + if Nkind (Last (Parameter_Associations (Subprogram_Call))) = + N_Parameter_Association + then + + -- Find last named actual, and append + + declare + L : Node_Id; + begin + L := First_Actual (Subprogram_Call); + while Present (L) loop + if No (Next_Actual (L)) then + Set_Next_Named_Actual (Parent (L), Extra_Actual); + exit; + end if; + Next_Actual (L); + end loop; + end; + + else + Set_First_Named_Actual (Subprogram_Call, Extra_Actual); + end if; + + Append (Param_Assoc, To => Parameter_Associations (Subprogram_Call)); + + else + Set_Parameter_Associations (Subprogram_Call, New_List (Param_Assoc)); + Set_First_Named_Actual (Subprogram_Call, Extra_Actual); + end if; + end Add_Extra_Actual_To_Call; + + -------------------------------------------------- + -- Add_Final_List_Actual_To_Build_In_Place_Call -- + -------------------------------------------------- + + procedure Add_Final_List_Actual_To_Build_In_Place_Call + (Function_Call : Node_Id; + Function_Id : Entity_Id; + Acc_Type : Entity_Id; + Sel_Comp : Node_Id := Empty) + is + Loc : constant Source_Ptr := Sloc (Function_Call); + Final_List : Node_Id; + Final_List_Actual : Node_Id; + Final_List_Formal : Node_Id; + Is_Ctrl_Result : constant Boolean := + Needs_Finalization + (Underlying_Type (Etype (Function_Id))); + + begin + -- No such extra parameter is needed if there are no controlled parts. + -- The test for Needs_Finalization accounts for class-wide results + -- (which potentially have controlled parts, even if the root type + -- doesn't), and the test for a tagged result type is needed because + -- calls to such a function can in general occur in dispatching + -- contexts, which must be treated the same as a call to class-wide + -- functions. Both of these situations require that a finalization list + -- be passed. + + if not Needs_BIP_Final_List (Function_Id) then + return; + end if; + + -- Locate implicit finalization list parameter in the called function + + Final_List_Formal := Build_In_Place_Formal (Function_Id, BIP_Final_List); + + -- Create the actual which is a pointer to the appropriate finalization + -- list. Acc_Type is present if and only if this call is the + -- initialization of an allocator. Use the Current_Scope or the + -- Acc_Type as appropriate. + + if Present (Acc_Type) + and then (Ekind (Acc_Type) = E_Anonymous_Access_Type + or else + Present (Associated_Final_Chain (Base_Type (Acc_Type)))) + then + Final_List := Find_Final_List (Acc_Type); + + -- If Sel_Comp is present and the function result is controlled, then + -- the finalization list will be obtained from the _controller list of + -- the selected component's prefix object. + + elsif Present (Sel_Comp) and then Is_Ctrl_Result then + Final_List := Find_Final_List (Current_Scope, Sel_Comp); + + else + Final_List := Find_Final_List (Current_Scope); + end if; + + Final_List_Actual := + Make_Attribute_Reference (Loc, + Prefix => Final_List, + Attribute_Name => Name_Unrestricted_Access); + + Analyze_And_Resolve (Final_List_Actual, Etype (Final_List_Formal)); + + -- Build the parameter association for the new actual and add it to the + -- end of the function's actuals. + + Add_Extra_Actual_To_Call + (Function_Call, Final_List_Formal, Final_List_Actual); + end Add_Final_List_Actual_To_Build_In_Place_Call; + + --------------------------------------------- + -- Add_Task_Actuals_To_Build_In_Place_Call -- + --------------------------------------------- + + procedure Add_Task_Actuals_To_Build_In_Place_Call + (Function_Call : Node_Id; + Function_Id : Entity_Id; + Master_Actual : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Function_Call); + Actual : Node_Id := Master_Actual; + + begin + -- No such extra parameters are needed if there are no tasks + + if not Has_Task (Etype (Function_Id)) then + return; + end if; + + -- Use a dummy _master actual in case of No_Task_Hierarchy + + if Restriction_Active (No_Task_Hierarchy) then + Actual := New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc); + end if; + + -- The master + + declare + Master_Formal : Node_Id; + begin + -- Locate implicit master parameter in the called function + + Master_Formal := Build_In_Place_Formal (Function_Id, BIP_Master); + + Analyze_And_Resolve (Actual, Etype (Master_Formal)); + + -- Build the parameter association for the new actual and add it to + -- the end of the function's actuals. + + Add_Extra_Actual_To_Call + (Function_Call, Master_Formal, Actual); + end; + + -- The activation chain + + declare + Activation_Chain_Actual : Node_Id; + Activation_Chain_Formal : Node_Id; + + begin + -- Locate implicit activation chain parameter in the called function + + Activation_Chain_Formal := Build_In_Place_Formal + (Function_Id, BIP_Activation_Chain); + + -- Create the actual which is a pointer to the current activation + -- chain + + Activation_Chain_Actual := + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uChain), + Attribute_Name => Name_Unrestricted_Access); + + Analyze_And_Resolve + (Activation_Chain_Actual, Etype (Activation_Chain_Formal)); + + -- Build the parameter association for the new actual and add it to + -- the end of the function's actuals. + + Add_Extra_Actual_To_Call + (Function_Call, Activation_Chain_Formal, Activation_Chain_Actual); + end; + end Add_Task_Actuals_To_Build_In_Place_Call; + + ----------------------- + -- BIP_Formal_Suffix -- + ----------------------- + + function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String is + begin + case Kind is + when BIP_Alloc_Form => + return "BIPalloc"; + when BIP_Final_List => + return "BIPfinallist"; + when BIP_Master => + return "BIPmaster"; + when BIP_Activation_Chain => + return "BIPactivationchain"; + when BIP_Object_Access => + return "BIPaccess"; + end case; + end BIP_Formal_Suffix; + + --------------------------- + -- Build_In_Place_Formal -- + --------------------------- + + function Build_In_Place_Formal + (Func : Entity_Id; + Kind : BIP_Formal_Kind) return Entity_Id + is + Extra_Formal : Entity_Id := Extra_Formals (Func); + + begin + -- Maybe it would be better for each implicit formal of a build-in-place + -- function to have a flag or a Uint attribute to identify it. ??? + + loop + pragma Assert (Present (Extra_Formal)); + exit when + Chars (Extra_Formal) = + New_External_Name (Chars (Func), BIP_Formal_Suffix (Kind)); + Next_Formal_With_Extras (Extra_Formal); + end loop; + + return Extra_Formal; + end Build_In_Place_Formal; + + -------------------------------- + -- Check_Overriding_Operation -- + -------------------------------- + + procedure Check_Overriding_Operation (Subp : Entity_Id) is + Typ : constant Entity_Id := Find_Dispatching_Type (Subp); + Op_List : constant Elist_Id := Primitive_Operations (Typ); + Op_Elmt : Elmt_Id; + Prim_Op : Entity_Id; + Par_Op : Entity_Id; + + begin + if Is_Derived_Type (Typ) + and then not Is_Private_Type (Typ) + and then In_Open_Scopes (Scope (Etype (Typ))) + and then Is_Base_Type (Typ) + then + -- Subp overrides an inherited private operation if there is an + -- inherited operation with a different name than Subp (see + -- Derive_Subprogram) whose Alias is a hidden subprogram with the + -- same name as Subp. + + Op_Elmt := First_Elmt (Op_List); + while Present (Op_Elmt) loop + Prim_Op := Node (Op_Elmt); + Par_Op := Alias (Prim_Op); + + if Present (Par_Op) + and then not Comes_From_Source (Prim_Op) + and then Chars (Prim_Op) /= Chars (Par_Op) + and then Chars (Par_Op) = Chars (Subp) + and then Is_Hidden (Par_Op) + and then Type_Conformant (Prim_Op, Subp) + then + Set_DT_Position (Subp, DT_Position (Prim_Op)); + end if; + + Next_Elmt (Op_Elmt); + end loop; + end if; + end Check_Overriding_Operation; + + ------------------------------- + -- Detect_Infinite_Recursion -- + ------------------------------- + + procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Var_List : constant Elist_Id := New_Elmt_List; + -- List of globals referenced by body of procedure + + Call_List : constant Elist_Id := New_Elmt_List; + -- List of recursive calls in body of procedure + + Shad_List : constant Elist_Id := New_Elmt_List; + -- List of entity id's for entities created to capture the value of + -- referenced globals on entry to the procedure. + + Scop : constant Uint := Scope_Depth (Spec); + -- This is used to record the scope depth of the current procedure, so + -- that we can identify global references. + + Max_Vars : constant := 4; + -- Do not test more than four global variables + + Count_Vars : Natural := 0; + -- Count variables found so far + + Var : Entity_Id; + Elm : Elmt_Id; + Ent : Entity_Id; + Call : Elmt_Id; + Decl : Node_Id; + Test : Node_Id; + Elm1 : Elmt_Id; + Elm2 : Elmt_Id; + Last : Node_Id; + + function Process (Nod : Node_Id) return Traverse_Result; + -- Function to traverse the subprogram body (using Traverse_Func) + + ------------- + -- Process -- + ------------- + + function Process (Nod : Node_Id) return Traverse_Result is + begin + -- Procedure call + + if Nkind (Nod) = N_Procedure_Call_Statement then + + -- Case of one of the detected recursive calls + + if Is_Entity_Name (Name (Nod)) + and then Has_Recursive_Call (Entity (Name (Nod))) + and then Entity (Name (Nod)) = Spec + then + Append_Elmt (Nod, Call_List); + return Skip; + + -- Any other procedure call may have side effects + + else + return Abandon; + end if; + + -- A call to a pure function can always be ignored + + elsif Nkind (Nod) = N_Function_Call + and then Is_Entity_Name (Name (Nod)) + and then Is_Pure (Entity (Name (Nod))) + then + return Skip; + + -- Case of an identifier reference + + elsif Nkind (Nod) = N_Identifier then + Ent := Entity (Nod); + + -- If no entity, then ignore the reference + + -- Not clear why this can happen. To investigate, remove this + -- test and look at the crash that occurs here in 3401-004 ??? + + if No (Ent) then + return Skip; + + -- Ignore entities with no Scope, again not clear how this + -- can happen, to investigate, look at 4108-008 ??? + + elsif No (Scope (Ent)) then + return Skip; + + -- Ignore the reference if not to a more global object + + elsif Scope_Depth (Scope (Ent)) >= Scop then + return Skip; + + -- References to types, exceptions and constants are always OK + + elsif Is_Type (Ent) + or else Ekind (Ent) = E_Exception + or else Ekind (Ent) = E_Constant + then + return Skip; + + -- If other than a non-volatile scalar variable, we have some + -- kind of global reference (e.g. to a function) that we cannot + -- deal with so we forget the attempt. + + elsif Ekind (Ent) /= E_Variable + or else not Is_Scalar_Type (Etype (Ent)) + or else Treat_As_Volatile (Ent) + then + return Abandon; + + -- Otherwise we have a reference to a global scalar + + else + -- Loop through global entities already detected + + Elm := First_Elmt (Var_List); + loop + -- If not detected before, record this new global reference + + if No (Elm) then + Count_Vars := Count_Vars + 1; + + if Count_Vars <= Max_Vars then + Append_Elmt (Entity (Nod), Var_List); + else + return Abandon; + end if; + + exit; + + -- If recorded before, ignore + + elsif Node (Elm) = Entity (Nod) then + return Skip; + + -- Otherwise keep looking + + else + Next_Elmt (Elm); + end if; + end loop; + + return Skip; + end if; + + -- For all other node kinds, recursively visit syntactic children + + else + return OK; + end if; + end Process; + + function Traverse_Body is new Traverse_Func (Process); + + -- Start of processing for Detect_Infinite_Recursion + + begin + -- Do not attempt detection in No_Implicit_Conditional mode, since we + -- won't be able to generate the code to handle the recursion in any + -- case. + + if Restriction_Active (No_Implicit_Conditionals) then + return; + end if; + + -- Otherwise do traversal and quit if we get abandon signal + + if Traverse_Body (N) = Abandon then + return; + + -- We must have a call, since Has_Recursive_Call was set. If not just + -- ignore (this is only an error check, so if we have a funny situation, + -- due to bugs or errors, we do not want to bomb!) + + elsif Is_Empty_Elmt_List (Call_List) then + return; + end if; + + -- Here is the case where we detect recursion at compile time + + -- Push our current scope for analyzing the declarations and code that + -- we will insert for the checking. + + Push_Scope (Spec); + + -- This loop builds temporary variables for each of the referenced + -- globals, so that at the end of the loop the list Shad_List contains + -- these temporaries in one-to-one correspondence with the elements in + -- Var_List. + + Last := Empty; + Elm := First_Elmt (Var_List); + while Present (Elm) loop + Var := Node (Elm); + Ent := Make_Temporary (Loc, 'S'); + Append_Elmt (Ent, Shad_List); + + -- Insert a declaration for this temporary at the start of the + -- declarations for the procedure. The temporaries are declared as + -- constant objects initialized to the current values of the + -- corresponding temporaries. + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Ent, + Object_Definition => New_Occurrence_Of (Etype (Var), Loc), + Constant_Present => True, + Expression => New_Occurrence_Of (Var, Loc)); + + if No (Last) then + Prepend (Decl, Declarations (N)); + else + Insert_After (Last, Decl); + end if; + + Last := Decl; + Analyze (Decl); + Next_Elmt (Elm); + end loop; + + -- Loop through calls + + Call := First_Elmt (Call_List); + while Present (Call) loop + + -- Build a predicate expression of the form + + -- True + -- and then global1 = temp1 + -- and then global2 = temp2 + -- ... + + -- This predicate determines if any of the global values + -- referenced by the procedure have changed since the + -- current call, if not an infinite recursion is assured. + + Test := New_Occurrence_Of (Standard_True, Loc); + + Elm1 := First_Elmt (Var_List); + Elm2 := First_Elmt (Shad_List); + while Present (Elm1) loop + Test := + Make_And_Then (Loc, + Left_Opnd => Test, + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Node (Elm1), Loc), + Right_Opnd => New_Occurrence_Of (Node (Elm2), Loc))); + + Next_Elmt (Elm1); + Next_Elmt (Elm2); + end loop; + + -- Now we replace the call with the sequence + + -- if no-changes (see above) then + -- raise Storage_Error; + -- else + -- original-call + -- end if; + + Rewrite (Node (Call), + Make_If_Statement (Loc, + Condition => Test, + Then_Statements => New_List ( + Make_Raise_Storage_Error (Loc, + Reason => SE_Infinite_Recursion)), + + Else_Statements => New_List ( + Relocate_Node (Node (Call))))); + + Analyze (Node (Call)); + + Next_Elmt (Call); + end loop; + + -- Remove temporary scope stack entry used for analysis + + Pop_Scope; + end Detect_Infinite_Recursion; + + -------------------- + -- Expand_Actuals -- + -------------------- + + procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Actual : Node_Id; + Formal : Entity_Id; + N_Node : Node_Id; + Post_Call : List_Id; + E_Formal : Entity_Id; + + procedure Add_Call_By_Copy_Code; + -- For cases where the parameter must be passed by copy, this routine + -- generates a temporary variable into which the actual is copied and + -- then passes this as the parameter. For an OUT or IN OUT parameter, + -- an assignment is also generated to copy the result back. The call + -- also takes care of any constraint checks required for the type + -- conversion case (on both the way in and the way out). + + procedure Add_Simple_Call_By_Copy_Code; + -- This is similar to the above, but is used in cases where we know + -- that all that is needed is to simply create a temporary and copy + -- the value in and out of the temporary. + + procedure Check_Fortran_Logical; + -- A value of type Logical that is passed through a formal parameter + -- must be normalized because .TRUE. usually does not have the same + -- representation as True. We assume that .FALSE. = False = 0. + -- What about functions that return a logical type ??? + + function Is_Legal_Copy return Boolean; + -- Check that an actual can be copied before generating the temporary + -- to be used in the call. If the actual is of a by_reference type then + -- the program is illegal (this can only happen in the presence of + -- rep. clauses that force an incorrect alignment). If the formal is + -- a by_reference parameter imposed by a DEC pragma, emit a warning to + -- the effect that this might lead to unaligned arguments. + + function Make_Var (Actual : Node_Id) return Entity_Id; + -- Returns an entity that refers to the given actual parameter, + -- Actual (not including any type conversion). If Actual is an + -- entity name, then this entity is returned unchanged, otherwise + -- a renaming is created to provide an entity for the actual. + + procedure Reset_Packed_Prefix; + -- The expansion of a packed array component reference is delayed in + -- the context of a call. Now we need to complete the expansion, so we + -- unmark the analyzed bits in all prefixes. + + --------------------------- + -- Add_Call_By_Copy_Code -- + --------------------------- + + procedure Add_Call_By_Copy_Code is + Expr : Node_Id; + Init : Node_Id; + Temp : Entity_Id; + Indic : Node_Id; + Var : Entity_Id; + F_Typ : constant Entity_Id := Etype (Formal); + V_Typ : Entity_Id; + Crep : Boolean; + + begin + if not Is_Legal_Copy then + return; + end if; + + Temp := Make_Temporary (Loc, 'T', Actual); + + -- Use formal type for temp, unless formal type is an unconstrained + -- array, in which case we don't have to worry about bounds checks, + -- and we use the actual type, since that has appropriate bounds. + + if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then + Indic := New_Occurrence_Of (Etype (Actual), Loc); + else + Indic := New_Occurrence_Of (Etype (Formal), Loc); + end if; + + if Nkind (Actual) = N_Type_Conversion then + V_Typ := Etype (Expression (Actual)); + + -- If the formal is an (in-)out parameter, capture the name + -- of the variable in order to build the post-call assignment. + + Var := Make_Var (Expression (Actual)); + + Crep := not Same_Representation + (F_Typ, Etype (Expression (Actual))); + + else + V_Typ := Etype (Actual); + Var := Make_Var (Actual); + Crep := False; + end if; + + -- Setup initialization for case of in out parameter, or an out + -- parameter where the formal is an unconstrained array (in the + -- latter case, we have to pass in an object with bounds). + + -- If this is an out parameter, the initial copy is wasteful, so as + -- an optimization for the one-dimensional case we extract the + -- bounds of the actual and build an uninitialized temporary of the + -- right size. + + if Ekind (Formal) = E_In_Out_Parameter + or else (Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ)) + then + if Nkind (Actual) = N_Type_Conversion then + if Conversion_OK (Actual) then + Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); + else + Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); + end if; + + elsif Ekind (Formal) = E_Out_Parameter + and then Is_Array_Type (F_Typ) + and then Number_Dimensions (F_Typ) = 1 + and then not Has_Non_Null_Base_Init_Proc (F_Typ) + then + -- Actual is a one-dimensional array or slice, and the type + -- requires no initialization. Create a temporary of the + -- right size, but do not copy actual into it (optimization). + + Init := Empty; + Indic := + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (F_Typ, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Low_Bound => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Var, Loc), + Attribute_Name => Name_First), + High_Bound => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Var, Loc), + Attribute_Name => Name_Last))))); + + else + Init := New_Occurrence_Of (Var, Loc); + end if; + + -- An initialization is created for packed conversions as + -- actuals for out parameters to enable Make_Object_Declaration + -- to determine the proper subtype for N_Node. Note that this + -- is wasteful because the extra copying on the call side is + -- not required for such out parameters. ??? + + elsif Ekind (Formal) = E_Out_Parameter + and then Nkind (Actual) = N_Type_Conversion + and then (Is_Bit_Packed_Array (F_Typ) + or else + Is_Bit_Packed_Array (Etype (Expression (Actual)))) + then + if Conversion_OK (Actual) then + Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); + else + Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); + end if; + + elsif Ekind (Formal) = E_In_Parameter then + + -- Handle the case in which the actual is a type conversion + + if Nkind (Actual) = N_Type_Conversion then + if Conversion_OK (Actual) then + Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); + else + Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); + end if; + else + Init := New_Occurrence_Of (Var, Loc); + end if; + + else + Init := Empty; + end if; + + N_Node := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => Indic, + Expression => Init); + Set_Assignment_OK (N_Node); + Insert_Action (N, N_Node); + + -- Now, normally the deal here is that we use the defining + -- identifier created by that object declaration. There is + -- one exception to this. In the change of representation case + -- the above declaration will end up looking like: + + -- temp : type := identifier; + + -- And in this case we might as well use the identifier directly + -- and eliminate the temporary. Note that the analysis of the + -- declaration was not a waste of time in that case, since it is + -- what generated the necessary change of representation code. If + -- the change of representation introduced additional code, as in + -- a fixed-integer conversion, the expression is not an identifier + -- and must be kept. + + if Crep + and then Present (Expression (N_Node)) + and then Is_Entity_Name (Expression (N_Node)) + then + Temp := Entity (Expression (N_Node)); + Rewrite (N_Node, Make_Null_Statement (Loc)); + end if; + + -- For IN parameter, all we do is to replace the actual + + if Ekind (Formal) = E_In_Parameter then + Rewrite (Actual, New_Reference_To (Temp, Loc)); + Analyze (Actual); + + -- Processing for OUT or IN OUT parameter + + else + -- Kill current value indications for the temporary variable we + -- created, since we just passed it as an OUT parameter. + + Kill_Current_Values (Temp); + Set_Is_Known_Valid (Temp, False); + + -- If type conversion, use reverse conversion on exit + + if Nkind (Actual) = N_Type_Conversion then + if Conversion_OK (Actual) then + Expr := OK_Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc)); + else + Expr := Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc)); + end if; + else + Expr := New_Occurrence_Of (Temp, Loc); + end if; + + Rewrite (Actual, New_Reference_To (Temp, Loc)); + Analyze (Actual); + + -- If the actual is a conversion of a packed reference, it may + -- already have been expanded by Remove_Side_Effects, and the + -- resulting variable is a temporary which does not designate + -- the proper out-parameter, which may not be addressable. In + -- that case, generate an assignment to the original expression + -- (before expansion of the packed reference) so that the proper + -- expansion of assignment to a packed component can take place. + + declare + Obj : Node_Id; + Lhs : Node_Id; + + begin + if Is_Renaming_Of_Object (Var) + and then Nkind (Renamed_Object (Var)) = N_Selected_Component + and then Is_Entity_Name (Prefix (Renamed_Object (Var))) + and then Nkind (Original_Node (Prefix (Renamed_Object (Var)))) + = N_Indexed_Component + and then + Has_Non_Standard_Rep (Etype (Prefix (Renamed_Object (Var)))) + then + Obj := Renamed_Object (Var); + Lhs := + Make_Selected_Component (Loc, + Prefix => + New_Copy_Tree (Original_Node (Prefix (Obj))), + Selector_Name => New_Copy (Selector_Name (Obj))); + Reset_Analyzed_Flags (Lhs); + + else + Lhs := New_Occurrence_Of (Var, Loc); + end if; + + Set_Assignment_OK (Lhs); + + Append_To (Post_Call, + Make_Assignment_Statement (Loc, + Name => Lhs, + Expression => Expr)); + end; + end if; + end Add_Call_By_Copy_Code; + + ---------------------------------- + -- Add_Simple_Call_By_Copy_Code -- + ---------------------------------- + + procedure Add_Simple_Call_By_Copy_Code is + Temp : Entity_Id; + Decl : Node_Id; + Incod : Node_Id; + Outcod : Node_Id; + Lhs : Node_Id; + Rhs : Node_Id; + Indic : Node_Id; + F_Typ : constant Entity_Id := Etype (Formal); + + begin + if not Is_Legal_Copy then + return; + end if; + + -- Use formal type for temp, unless formal type is an unconstrained + -- array, in which case we don't have to worry about bounds checks, + -- and we use the actual type, since that has appropriate bounds. + + if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then + Indic := New_Occurrence_Of (Etype (Actual), Loc); + else + Indic := New_Occurrence_Of (Etype (Formal), Loc); + end if; + + -- Prepare to generate code + + Reset_Packed_Prefix; + + Temp := Make_Temporary (Loc, 'T', Actual); + Incod := Relocate_Node (Actual); + Outcod := New_Copy_Tree (Incod); + + -- Generate declaration of temporary variable, initializing it + -- with the input parameter unless we have an OUT formal or + -- this is an initialization call. + + -- If the formal is an out parameter with discriminants, the + -- discriminants must be captured even if the rest of the object + -- is in principle uninitialized, because the discriminants may + -- be read by the called subprogram. + + if Ekind (Formal) = E_Out_Parameter then + Incod := Empty; + + if Has_Discriminants (Etype (Formal)) then + Indic := New_Occurrence_Of (Etype (Actual), Loc); + end if; + + elsif Inside_Init_Proc then + + -- Could use a comment here to match comment below ??? + + if Nkind (Actual) /= N_Selected_Component + or else + not Has_Discriminant_Dependent_Constraint + (Entity (Selector_Name (Actual))) + then + Incod := Empty; + + -- Otherwise, keep the component in order to generate the proper + -- actual subtype, that depends on enclosing discriminants. + + else + null; + end if; + end if; + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => Indic, + Expression => Incod); + + if Inside_Init_Proc + and then No (Incod) + then + -- If the call is to initialize a component of a composite type, + -- and the component does not depend on discriminants, use the + -- actual type of the component. This is required in case the + -- component is constrained, because in general the formal of the + -- initialization procedure will be unconstrained. Note that if + -- the component being initialized is constrained by an enclosing + -- discriminant, the presence of the initialization in the + -- declaration will generate an expression for the actual subtype. + + Set_No_Initialization (Decl); + Set_Object_Definition (Decl, + New_Occurrence_Of (Etype (Actual), Loc)); + end if; + + Insert_Action (N, Decl); + + -- The actual is simply a reference to the temporary + + Rewrite (Actual, New_Occurrence_Of (Temp, Loc)); + + -- Generate copy out if OUT or IN OUT parameter + + if Ekind (Formal) /= E_In_Parameter then + Lhs := Outcod; + Rhs := New_Occurrence_Of (Temp, Loc); + + -- Deal with conversion + + if Nkind (Lhs) = N_Type_Conversion then + Lhs := Expression (Lhs); + Rhs := Convert_To (Etype (Actual), Rhs); + end if; + + Append_To (Post_Call, + Make_Assignment_Statement (Loc, + Name => Lhs, + Expression => Rhs)); + Set_Assignment_OK (Name (Last (Post_Call))); + end if; + end Add_Simple_Call_By_Copy_Code; + + --------------------------- + -- Check_Fortran_Logical -- + --------------------------- + + procedure Check_Fortran_Logical is + Logical : constant Entity_Id := Etype (Formal); + Var : Entity_Id; + + -- Note: this is very incomplete, e.g. it does not handle arrays + -- of logical values. This is really not the right approach at all???) + + begin + if Convention (Subp) = Convention_Fortran + and then Root_Type (Etype (Formal)) = Standard_Boolean + and then Ekind (Formal) /= E_In_Parameter + then + Var := Make_Var (Actual); + Append_To (Post_Call, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Var, Loc), + Expression => + Unchecked_Convert_To ( + Logical, + Make_Op_Ne (Loc, + Left_Opnd => New_Occurrence_Of (Var, Loc), + Right_Opnd => + Unchecked_Convert_To ( + Logical, + New_Occurrence_Of (Standard_False, Loc)))))); + end if; + end Check_Fortran_Logical; + + ------------------- + -- Is_Legal_Copy -- + ------------------- + + function Is_Legal_Copy return Boolean is + begin + -- An attempt to copy a value of such a type can only occur if + -- representation clauses give the actual a misaligned address. + + if Is_By_Reference_Type (Etype (Formal)) then + Error_Msg_N + ("misaligned actual cannot be passed by reference", Actual); + return False; + + -- For users of Starlet, we assume that the specification of by- + -- reference mechanism is mandatory. This may lead to unaligned + -- objects but at least for DEC legacy code it is known to work. + -- The warning will alert users of this code that a problem may + -- be lurking. + + elsif Mechanism (Formal) = By_Reference + and then Is_Valued_Procedure (Scope (Formal)) + then + Error_Msg_N + ("by_reference actual may be misaligned?", Actual); + return False; + + else + return True; + end if; + end Is_Legal_Copy; + + -------------- + -- Make_Var -- + -------------- + + function Make_Var (Actual : Node_Id) return Entity_Id is + Var : Entity_Id; + + begin + if Is_Entity_Name (Actual) then + return Entity (Actual); + + else + Var := Make_Temporary (Loc, 'T', Actual); + + N_Node := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Var, + Subtype_Mark => + New_Occurrence_Of (Etype (Actual), Loc), + Name => Relocate_Node (Actual)); + + Insert_Action (N, N_Node); + return Var; + end if; + end Make_Var; + + ------------------------- + -- Reset_Packed_Prefix -- + ------------------------- + + procedure Reset_Packed_Prefix is + Pfx : Node_Id := Actual; + begin + loop + Set_Analyzed (Pfx, False); + exit when + not Nkind_In (Pfx, N_Selected_Component, N_Indexed_Component); + Pfx := Prefix (Pfx); + end loop; + end Reset_Packed_Prefix; + + -- Start of processing for Expand_Actuals + + begin + Post_Call := New_List; + + Formal := First_Formal (Subp); + Actual := First_Actual (N); + while Present (Formal) loop + E_Formal := Etype (Formal); + + if Is_Scalar_Type (E_Formal) + or else Nkind (Actual) = N_Slice + then + Check_Fortran_Logical; + + -- RM 6.4.1 (11) + + elsif Ekind (Formal) /= E_Out_Parameter then + + -- The unusual case of the current instance of a protected type + -- requires special handling. This can only occur in the context + -- of a call within the body of a protected operation. + + if Is_Entity_Name (Actual) + and then Ekind (Entity (Actual)) = E_Protected_Type + and then In_Open_Scopes (Entity (Actual)) + then + if Scope (Subp) /= Entity (Actual) then + Error_Msg_N ("operation outside protected type may not " + & "call back its protected operations?", Actual); + end if; + + Rewrite (Actual, + Expand_Protected_Object_Reference (N, Entity (Actual))); + end if; + + -- Ada 2005 (AI-318-02): If the actual parameter is a call to a + -- build-in-place function, then a temporary return object needs + -- to be created and access to it must be passed to the function. + -- Currently we limit such functions to those with inherently + -- limited result subtypes, but eventually we plan to expand the + -- functions that are treated as build-in-place to include other + -- composite result types. + + if Ada_Version >= Ada_2005 + and then Is_Build_In_Place_Function_Call (Actual) + then + Make_Build_In_Place_Call_In_Anonymous_Context (Actual); + end if; + + Apply_Constraint_Check (Actual, E_Formal); + + -- Out parameter case. No constraint checks on access type + -- RM 6.4.1 (13) + + elsif Is_Access_Type (E_Formal) then + null; + + -- RM 6.4.1 (14) + + elsif Has_Discriminants (Base_Type (E_Formal)) + or else Has_Non_Null_Base_Init_Proc (E_Formal) + then + Apply_Constraint_Check (Actual, E_Formal); + + -- RM 6.4.1 (15) + + else + Apply_Constraint_Check (Actual, Base_Type (E_Formal)); + end if; + + -- Processing for IN-OUT and OUT parameters + + if Ekind (Formal) /= E_In_Parameter then + + -- For type conversions of arrays, apply length/range checks + + if Is_Array_Type (E_Formal) + and then Nkind (Actual) = N_Type_Conversion + then + if Is_Constrained (E_Formal) then + Apply_Length_Check (Expression (Actual), E_Formal); + else + Apply_Range_Check (Expression (Actual), E_Formal); + end if; + end if; + + -- If argument is a type conversion for a type that is passed + -- by copy, then we must pass the parameter by copy. + + if Nkind (Actual) = N_Type_Conversion + and then + (Is_Numeric_Type (E_Formal) + or else Is_Access_Type (E_Formal) + or else Is_Enumeration_Type (E_Formal) + or else Is_Bit_Packed_Array (Etype (Formal)) + or else Is_Bit_Packed_Array (Etype (Expression (Actual))) + + -- Also pass by copy if change of representation + + or else not Same_Representation + (Etype (Formal), + Etype (Expression (Actual)))) + then + Add_Call_By_Copy_Code; + + -- References to components of bit packed arrays are expanded + -- at this point, rather than at the point of analysis of the + -- actuals, to handle the expansion of the assignment to + -- [in] out parameters. + + elsif Is_Ref_To_Bit_Packed_Array (Actual) then + Add_Simple_Call_By_Copy_Code; + + -- If a non-scalar actual is possibly bit-aligned, we need a copy + -- because the back-end cannot cope with such objects. In other + -- cases where alignment forces a copy, the back-end generates + -- it properly. It should not be generated unconditionally in the + -- front-end because it does not know precisely the alignment + -- requirements of the target, and makes too conservative an + -- estimate, leading to superfluous copies or spurious errors + -- on by-reference parameters. + + elsif Nkind (Actual) = N_Selected_Component + and then + Component_May_Be_Bit_Aligned (Entity (Selector_Name (Actual))) + and then not Represented_As_Scalar (Etype (Formal)) + then + Add_Simple_Call_By_Copy_Code; + + -- References to slices of bit packed arrays are expanded + + elsif Is_Ref_To_Bit_Packed_Slice (Actual) then + Add_Call_By_Copy_Code; + + -- References to possibly unaligned slices of arrays are expanded + + elsif Is_Possibly_Unaligned_Slice (Actual) then + Add_Call_By_Copy_Code; + + -- Deal with access types where the actual subtype and the + -- formal subtype are not the same, requiring a check. + + -- It is necessary to exclude tagged types because of "downward + -- conversion" errors. + + elsif Is_Access_Type (E_Formal) + and then not Same_Type (E_Formal, Etype (Actual)) + and then not Is_Tagged_Type (Designated_Type (E_Formal)) + then + Add_Call_By_Copy_Code; + + -- If the actual is not a scalar and is marked for volatile + -- treatment, whereas the formal is not volatile, then pass + -- by copy unless it is a by-reference type. + + -- Note: we use Is_Volatile here rather than Treat_As_Volatile, + -- because this is the enforcement of a language rule that applies + -- only to "real" volatile variables, not e.g. to the address + -- clause overlay case. + + elsif Is_Entity_Name (Actual) + and then Is_Volatile (Entity (Actual)) + and then not Is_By_Reference_Type (Etype (Actual)) + and then not Is_Scalar_Type (Etype (Entity (Actual))) + and then not Is_Volatile (E_Formal) + then + Add_Call_By_Copy_Code; + + elsif Nkind (Actual) = N_Indexed_Component + and then Is_Entity_Name (Prefix (Actual)) + and then Has_Volatile_Components (Entity (Prefix (Actual))) + then + Add_Call_By_Copy_Code; + + -- Add call-by-copy code for the case of scalar out parameters + -- when it is not known at compile time that the subtype of the + -- formal is a subrange of the subtype of the actual (or vice + -- versa for in out parameters), in order to get range checks + -- on such actuals. (Maybe this case should be handled earlier + -- in the if statement???) + + elsif Is_Scalar_Type (E_Formal) + and then + (not In_Subrange_Of (E_Formal, Etype (Actual)) + or else + (Ekind (Formal) = E_In_Out_Parameter + and then not In_Subrange_Of (Etype (Actual), E_Formal))) + then + -- Perhaps the setting back to False should be done within + -- Add_Call_By_Copy_Code, since it could get set on other + -- cases occurring above??? + + if Do_Range_Check (Actual) then + Set_Do_Range_Check (Actual, False); + end if; + + Add_Call_By_Copy_Code; + end if; + + -- Processing for IN parameters + + else + -- For IN parameters is in the packed array case, we expand an + -- indexed component (the circuit in Exp_Ch4 deliberately left + -- indexed components appearing as actuals untouched, so that + -- the special processing above for the OUT and IN OUT cases + -- could be performed. We could make the test in Exp_Ch4 more + -- complex and have it detect the parameter mode, but it is + -- easier simply to handle all cases here.) + + if Nkind (Actual) = N_Indexed_Component + and then Is_Packed (Etype (Prefix (Actual))) + then + Reset_Packed_Prefix; + Expand_Packed_Element_Reference (Actual); + + -- If we have a reference to a bit packed array, we copy it, since + -- the actual must be byte aligned. + + -- Is this really necessary in all cases??? + + elsif Is_Ref_To_Bit_Packed_Array (Actual) then + Add_Simple_Call_By_Copy_Code; + + -- If a non-scalar actual is possibly unaligned, we need a copy + + elsif Is_Possibly_Unaligned_Object (Actual) + and then not Represented_As_Scalar (Etype (Formal)) + then + Add_Simple_Call_By_Copy_Code; + + -- Similarly, we have to expand slices of packed arrays here + -- because the result must be byte aligned. + + elsif Is_Ref_To_Bit_Packed_Slice (Actual) then + Add_Call_By_Copy_Code; + + -- Only processing remaining is to pass by copy if this is a + -- reference to a possibly unaligned slice, since the caller + -- expects an appropriately aligned argument. + + elsif Is_Possibly_Unaligned_Slice (Actual) then + Add_Call_By_Copy_Code; + + -- An unusual case: a current instance of an enclosing task can be + -- an actual, and must be replaced by a reference to self. + + elsif Is_Entity_Name (Actual) + and then Is_Task_Type (Entity (Actual)) + then + if In_Open_Scopes (Entity (Actual)) then + Rewrite (Actual, + (Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Self), Loc)))); + Analyze (Actual); + + -- A task type cannot otherwise appear as an actual + + else + raise Program_Error; + end if; + end if; + end if; + + Next_Formal (Formal); + Next_Actual (Actual); + end loop; + + -- Find right place to put post call stuff if it is present + + if not Is_Empty_List (Post_Call) then + + -- If call is not a list member, it must be the triggering statement + -- of a triggering alternative or an entry call alternative, and we + -- can add the post call stuff to the corresponding statement list. + + if not Is_List_Member (N) then + declare + P : constant Node_Id := Parent (N); + + begin + pragma Assert (Nkind_In (P, N_Triggering_Alternative, + N_Entry_Call_Alternative)); + + if Is_Non_Empty_List (Statements (P)) then + Insert_List_Before_And_Analyze + (First (Statements (P)), Post_Call); + else + Set_Statements (P, Post_Call); + end if; + end; + + -- Otherwise, normal case where N is in a statement sequence, + -- just put the post-call stuff after the call statement. + + else + Insert_Actions_After (N, Post_Call); + end if; + end if; + + -- The call node itself is re-analyzed in Expand_Call + + end Expand_Actuals; + + ----------------- + -- Expand_Call -- + ----------------- + + -- This procedure handles expansion of function calls and procedure call + -- statements (i.e. it serves as the body for Expand_N_Function_Call and + -- Expand_N_Procedure_Call_Statement). Processing for calls includes: + + -- Replace call to Raise_Exception by Raise_Exception_Always if possible + -- Provide values of actuals for all formals in Extra_Formals list + -- Replace "call" to enumeration literal function by literal itself + -- Rewrite call to predefined operator as operator + -- Replace actuals to in-out parameters that are numeric conversions, + -- with explicit assignment to temporaries before and after the call. + -- Remove optional actuals if First_Optional_Parameter specified. + + -- Note that the list of actuals has been filled with default expressions + -- during semantic analysis of the call. Only the extra actuals required + -- for the 'Constrained attribute and for accessibility checks are added + -- at this point. + + procedure Expand_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Call_Node : Node_Id := N; + Extra_Actuals : List_Id := No_List; + Prev : Node_Id := Empty; + + procedure Add_Actual_Parameter (Insert_Param : Node_Id); + -- Adds one entry to the end of the actual parameter list. Used for + -- default parameters and for extra actuals (for Extra_Formals). The + -- argument is an N_Parameter_Association node. + + procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id); + -- Adds an extra actual to the list of extra actuals. Expr is the + -- expression for the value of the actual, EF is the entity for the + -- extra formal. + + function Inherited_From_Formal (S : Entity_Id) return Entity_Id; + -- Within an instance, a type derived from a non-tagged formal derived + -- type inherits from the original parent, not from the actual. The + -- current derivation mechanism has the derived type inherit from the + -- actual, which is only correct outside of the instance. If the + -- subprogram is inherited, we test for this particular case through a + -- convoluted tree traversal before setting the proper subprogram to be + -- called. + + function New_Value (From : Node_Id) return Node_Id; + -- From is the original Expression. New_Value is equivalent to a call + -- to Duplicate_Subexpr with an explicit dereference when From is an + -- access parameter. + + -------------------------- + -- Add_Actual_Parameter -- + -------------------------- + + procedure Add_Actual_Parameter (Insert_Param : Node_Id) is + Actual_Expr : constant Node_Id := + Explicit_Actual_Parameter (Insert_Param); + + begin + -- Case of insertion is first named actual + + if No (Prev) or else + Nkind (Parent (Prev)) /= N_Parameter_Association + then + Set_Next_Named_Actual + (Insert_Param, First_Named_Actual (Call_Node)); + Set_First_Named_Actual (Call_Node, Actual_Expr); + + if No (Prev) then + if No (Parameter_Associations (Call_Node)) then + Set_Parameter_Associations (Call_Node, New_List); + Append (Insert_Param, Parameter_Associations (Call_Node)); + end if; + else + Insert_After (Prev, Insert_Param); + end if; + + -- Case of insertion is not first named actual + + else + Set_Next_Named_Actual + (Insert_Param, Next_Named_Actual (Parent (Prev))); + Set_Next_Named_Actual (Parent (Prev), Actual_Expr); + Append (Insert_Param, Parameter_Associations (Call_Node)); + end if; + + Prev := Actual_Expr; + end Add_Actual_Parameter; + + ---------------------- + -- Add_Extra_Actual -- + ---------------------- + + procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id) is + Loc : constant Source_Ptr := Sloc (Expr); + + begin + if Extra_Actuals = No_List then + Extra_Actuals := New_List; + Set_Parent (Extra_Actuals, Call_Node); + end if; + + Append_To (Extra_Actuals, + Make_Parameter_Association (Loc, + Selector_Name => Make_Identifier (Loc, Chars (EF)), + Explicit_Actual_Parameter => Expr)); + + Analyze_And_Resolve (Expr, Etype (EF)); + + if Nkind (Call_Node) = N_Function_Call then + Set_Is_Accessibility_Actual (Parent (Expr)); + end if; + end Add_Extra_Actual; + + --------------------------- + -- Inherited_From_Formal -- + --------------------------- + + function Inherited_From_Formal (S : Entity_Id) return Entity_Id is + Par : Entity_Id; + Gen_Par : Entity_Id; + Gen_Prim : Elist_Id; + Elmt : Elmt_Id; + Indic : Node_Id; + + begin + -- If the operation is inherited, it is attached to the corresponding + -- type derivation. If the parent in the derivation is a generic + -- actual, it is a subtype of the actual, and we have to recover the + -- original derived type declaration to find the proper parent. + + if Nkind (Parent (S)) /= N_Full_Type_Declaration + or else not Is_Derived_Type (Defining_Identifier (Parent (S))) + or else Nkind (Type_Definition (Original_Node (Parent (S)))) /= + N_Derived_Type_Definition + or else not In_Instance + then + return Empty; + + else + Indic := + Subtype_Indication + (Type_Definition (Original_Node (Parent (S)))); + + if Nkind (Indic) = N_Subtype_Indication then + Par := Entity (Subtype_Mark (Indic)); + else + Par := Entity (Indic); + end if; + end if; + + if not Is_Generic_Actual_Type (Par) + or else Is_Tagged_Type (Par) + or else Nkind (Parent (Par)) /= N_Subtype_Declaration + or else not In_Open_Scopes (Scope (Par)) + then + return Empty; + else + Gen_Par := Generic_Parent_Type (Parent (Par)); + end if; + + -- If the actual has no generic parent type, the formal is not + -- a formal derived type, so nothing to inherit. + + if No (Gen_Par) then + return Empty; + end if; + + -- If the generic parent type is still the generic type, this is a + -- private formal, not a derived formal, and there are no operations + -- inherited from the formal. + + if Nkind (Parent (Gen_Par)) = N_Formal_Type_Declaration then + return Empty; + end if; + + Gen_Prim := Collect_Primitive_Operations (Gen_Par); + + Elmt := First_Elmt (Gen_Prim); + while Present (Elmt) loop + if Chars (Node (Elmt)) = Chars (S) then + declare + F1 : Entity_Id; + F2 : Entity_Id; + + begin + F1 := First_Formal (S); + F2 := First_Formal (Node (Elmt)); + while Present (F1) + and then Present (F2) + loop + if Etype (F1) = Etype (F2) + or else Etype (F2) = Gen_Par + then + Next_Formal (F1); + Next_Formal (F2); + else + Next_Elmt (Elmt); + exit; -- not the right subprogram + end if; + + return Node (Elmt); + end loop; + end; + + else + Next_Elmt (Elmt); + end if; + end loop; + + raise Program_Error; + end Inherited_From_Formal; + + --------------- + -- New_Value -- + --------------- + + function New_Value (From : Node_Id) return Node_Id is + Res : constant Node_Id := Duplicate_Subexpr (From); + begin + if Is_Access_Type (Etype (From)) then + return + Make_Explicit_Dereference (Sloc (From), + Prefix => Res); + else + return Res; + end if; + end New_Value; + + -- Local variables + + Remote : constant Boolean := Is_Remote_Call (Call_Node); + Actual : Node_Id; + Formal : Entity_Id; + Orig_Subp : Entity_Id := Empty; + Param_Count : Natural := 0; + Parent_Formal : Entity_Id; + Parent_Subp : Entity_Id; + Scop : Entity_Id; + Subp : Entity_Id; + + Prev_Orig : Node_Id; + -- Original node for an actual, which may have been rewritten. If the + -- actual is a function call that has been transformed from a selected + -- component, the original node is unanalyzed. Otherwise, it carries + -- semantic information used to generate additional actuals. + + CW_Interface_Formals_Present : Boolean := False; + + -- Start of processing for Expand_Call + + begin + -- Ignore if previous error + + if Nkind (Call_Node) in N_Has_Etype + and then Etype (Call_Node) = Any_Type + then + return; + end if; + + -- Call using access to subprogram with explicit dereference + + if Nkind (Name (Call_Node)) = N_Explicit_Dereference then + Subp := Etype (Name (Call_Node)); + Parent_Subp := Empty; + + -- Case of call to simple entry, where the Name is a selected component + -- whose prefix is the task, and whose selector name is the entry name + + elsif Nkind (Name (Call_Node)) = N_Selected_Component then + Subp := Entity (Selector_Name (Name (Call_Node))); + Parent_Subp := Empty; + + -- Case of call to member of entry family, where Name is an indexed + -- component, with the prefix being a selected component giving the + -- task and entry family name, and the index being the entry index. + + elsif Nkind (Name (Call_Node)) = N_Indexed_Component then + Subp := Entity (Selector_Name (Prefix (Name (Call_Node)))); + Parent_Subp := Empty; + + -- Normal case + + else + Subp := Entity (Name (Call_Node)); + Parent_Subp := Alias (Subp); + + -- Replace call to Raise_Exception by call to Raise_Exception_Always + -- if we can tell that the first parameter cannot possibly be null. + -- This improves efficiency by avoiding a run-time test. + + -- We do not do this if Raise_Exception_Always does not exist, which + -- can happen in configurable run time profiles which provide only a + -- Raise_Exception. + + if Is_RTE (Subp, RE_Raise_Exception) + and then RTE_Available (RE_Raise_Exception_Always) + then + declare + FA : constant Node_Id := + Original_Node (First_Actual (Call_Node)); + + begin + -- The case we catch is where the first argument is obtained + -- using the Identity attribute (which must always be + -- non-null). + + if Nkind (FA) = N_Attribute_Reference + and then Attribute_Name (FA) = Name_Identity + then + Subp := RTE (RE_Raise_Exception_Always); + Set_Name (Call_Node, New_Occurrence_Of (Subp, Loc)); + end if; + end; + end if; + + if Ekind (Subp) = E_Entry then + Parent_Subp := Empty; + end if; + end if; + + -- Ada 2005 (AI-345): We have a procedure call as a triggering + -- alternative in an asynchronous select or as an entry call in + -- a conditional or timed select. Check whether the procedure call + -- is a renaming of an entry and rewrite it as an entry call. + + if Ada_Version >= Ada_2005 + and then Nkind (Call_Node) = N_Procedure_Call_Statement + and then + ((Nkind (Parent (Call_Node)) = N_Triggering_Alternative + and then Triggering_Statement (Parent (Call_Node)) = Call_Node) + or else + (Nkind (Parent (Call_Node)) = N_Entry_Call_Alternative + and then Entry_Call_Statement (Parent (Call_Node)) = Call_Node)) + then + declare + Ren_Decl : Node_Id; + Ren_Root : Entity_Id := Subp; + + begin + -- This may be a chain of renamings, find the root + + if Present (Alias (Ren_Root)) then + Ren_Root := Alias (Ren_Root); + end if; + + if Present (Original_Node (Parent (Parent (Ren_Root)))) then + Ren_Decl := Original_Node (Parent (Parent (Ren_Root))); + + if Nkind (Ren_Decl) = N_Subprogram_Renaming_Declaration then + Rewrite (Call_Node, + Make_Entry_Call_Statement (Loc, + Name => + New_Copy_Tree (Name (Ren_Decl)), + Parameter_Associations => + New_Copy_List_Tree + (Parameter_Associations (Call_Node)))); + + return; + end if; + end if; + end; + end if; + + -- First step, compute extra actuals, corresponding to any Extra_Formals + -- present. Note that we do not access Extra_Formals directly, instead + -- we simply note the presence of the extra formals as we process the + -- regular formals collecting corresponding actuals in Extra_Actuals. + + -- We also generate any required range checks for actuals for in formals + -- as we go through the loop, since this is a convenient place to do it. + -- (Though it seems that this would be better done in Expand_Actuals???) + + Formal := First_Formal (Subp); + Actual := First_Actual (Call_Node); + Param_Count := 1; + while Present (Formal) loop + + -- Generate range check if required + + if Do_Range_Check (Actual) + and then Ekind (Formal) = E_In_Parameter + then + Set_Do_Range_Check (Actual, False); + Generate_Range_Check + (Actual, Etype (Formal), CE_Range_Check_Failed); + end if; + + -- Prepare to examine current entry + + Prev := Actual; + Prev_Orig := Original_Node (Prev); + + -- Ada 2005 (AI-251): Check if any formal is a class-wide interface + -- to expand it in a further round. + + CW_Interface_Formals_Present := + CW_Interface_Formals_Present + or else + (Ekind (Etype (Formal)) = E_Class_Wide_Type + and then Is_Interface (Etype (Etype (Formal)))) + or else + (Ekind (Etype (Formal)) = E_Anonymous_Access_Type + and then Is_Interface (Directly_Designated_Type + (Etype (Etype (Formal))))); + + -- Create possible extra actual for constrained case. Usually, the + -- extra actual is of the form actual'constrained, but since this + -- attribute is only available for unconstrained records, TRUE is + -- expanded if the type of the formal happens to be constrained (for + -- instance when this procedure is inherited from an unconstrained + -- record to a constrained one) or if the actual has no discriminant + -- (its type is constrained). An exception to this is the case of a + -- private type without discriminants. In this case we pass FALSE + -- because the object has underlying discriminants with defaults. + + if Present (Extra_Constrained (Formal)) then + if Ekind (Etype (Prev)) in Private_Kind + and then not Has_Discriminants (Base_Type (Etype (Prev))) + then + Add_Extra_Actual + (New_Occurrence_Of (Standard_False, Loc), + Extra_Constrained (Formal)); + + elsif Is_Constrained (Etype (Formal)) + or else not Has_Discriminants (Etype (Prev)) + then + Add_Extra_Actual + (New_Occurrence_Of (Standard_True, Loc), + Extra_Constrained (Formal)); + + -- Do not produce extra actuals for Unchecked_Union parameters. + -- Jump directly to the end of the loop. + + elsif Is_Unchecked_Union (Base_Type (Etype (Actual))) then + goto Skip_Extra_Actual_Generation; + + else + -- If the actual is a type conversion, then the constrained + -- test applies to the actual, not the target type. + + declare + Act_Prev : Node_Id; + + begin + -- Test for unchecked conversions as well, which can occur + -- as out parameter actuals on calls to stream procedures. + + Act_Prev := Prev; + while Nkind_In (Act_Prev, N_Type_Conversion, + N_Unchecked_Type_Conversion) + loop + Act_Prev := Expression (Act_Prev); + end loop; + + -- If the expression is a conversion of a dereference, this + -- is internally generated code that manipulates addresses, + -- e.g. when building interface tables. No check should + -- occur in this case, and the discriminated object is not + -- directly a hand. + + if not Comes_From_Source (Actual) + and then Nkind (Actual) = N_Unchecked_Type_Conversion + and then Nkind (Act_Prev) = N_Explicit_Dereference + then + Add_Extra_Actual + (New_Occurrence_Of (Standard_False, Loc), + Extra_Constrained (Formal)); + + else + Add_Extra_Actual + (Make_Attribute_Reference (Sloc (Prev), + Prefix => + Duplicate_Subexpr_No_Checks + (Act_Prev, Name_Req => True), + Attribute_Name => Name_Constrained), + Extra_Constrained (Formal)); + end if; + end; + end if; + end if; + + -- Create possible extra actual for accessibility level + + if Present (Extra_Accessibility (Formal)) then + + -- Ada 2005 (AI-252): If the actual was rewritten as an Access + -- attribute, then the original actual may be an aliased object + -- occurring as the prefix in a call using "Object.Operation" + -- notation. In that case we must pass the level of the object, + -- so Prev_Orig is reset to Prev and the attribute will be + -- processed by the code for Access attributes further below. + + if Prev_Orig /= Prev + and then Nkind (Prev) = N_Attribute_Reference + and then + Get_Attribute_Id (Attribute_Name (Prev)) = Attribute_Access + and then Is_Aliased_View (Prev_Orig) + then + Prev_Orig := Prev; + end if; + + -- Ada 2005 (AI-251): Thunks must propagate the extra actuals of + -- accessibility levels. + + if Ekind (Current_Scope) in Subprogram_Kind + and then Is_Thunk (Current_Scope) + then + declare + Parm_Ent : Entity_Id; + + begin + if Is_Controlling_Actual (Actual) then + + -- Find the corresponding actual of the thunk + + Parm_Ent := First_Entity (Current_Scope); + for J in 2 .. Param_Count loop + Next_Entity (Parm_Ent); + end loop; + + else pragma Assert (Is_Entity_Name (Actual)); + Parm_Ent := Entity (Actual); + end if; + + Add_Extra_Actual + (New_Occurrence_Of (Extra_Accessibility (Parm_Ent), Loc), + Extra_Accessibility (Formal)); + end; + + elsif Is_Entity_Name (Prev_Orig) then + + -- When passing an access parameter, or a renaming of an access + -- parameter, as the actual to another access parameter we need + -- to pass along the actual's own access level parameter. This + -- is done if we are within the scope of the formal access + -- parameter (if this is an inlined body the extra formal is + -- irrelevant). + + if (Is_Formal (Entity (Prev_Orig)) + or else + (Present (Renamed_Object (Entity (Prev_Orig))) + and then + Is_Entity_Name (Renamed_Object (Entity (Prev_Orig))) + and then + Is_Formal + (Entity (Renamed_Object (Entity (Prev_Orig)))))) + and then Ekind (Etype (Prev_Orig)) = E_Anonymous_Access_Type + and then In_Open_Scopes (Scope (Entity (Prev_Orig))) + then + declare + Parm_Ent : constant Entity_Id := Param_Entity (Prev_Orig); + + begin + pragma Assert (Present (Parm_Ent)); + + if Present (Extra_Accessibility (Parm_Ent)) then + Add_Extra_Actual + (New_Occurrence_Of + (Extra_Accessibility (Parm_Ent), Loc), + Extra_Accessibility (Formal)); + + -- If the actual access parameter does not have an + -- associated extra formal providing its scope level, + -- then treat the actual as having library-level + -- accessibility. + + else + Add_Extra_Actual + (Make_Integer_Literal (Loc, + Intval => Scope_Depth (Standard_Standard)), + Extra_Accessibility (Formal)); + end if; + end; + + -- The actual is a normal access value, so just pass the level + -- of the actual's access type. + + else + Add_Extra_Actual + (Make_Integer_Literal (Loc, + Intval => Type_Access_Level (Etype (Prev_Orig))), + Extra_Accessibility (Formal)); + end if; + + -- If the actual is an access discriminant, then pass the level + -- of the enclosing object (RM05-3.10.2(12.4/2)). + + elsif Nkind (Prev_Orig) = N_Selected_Component + and then Ekind (Entity (Selector_Name (Prev_Orig))) = + E_Discriminant + and then Ekind (Etype (Entity (Selector_Name (Prev_Orig)))) = + E_Anonymous_Access_Type + then + Add_Extra_Actual + (Make_Integer_Literal (Loc, + Intval => Object_Access_Level (Prefix (Prev_Orig))), + Extra_Accessibility (Formal)); + + -- All other cases + + else + case Nkind (Prev_Orig) is + + when N_Attribute_Reference => + case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is + + -- For X'Access, pass on the level of the prefix X + + when Attribute_Access => + Add_Extra_Actual + (Make_Integer_Literal (Loc, + Intval => + Object_Access_Level + (Prefix (Prev_Orig))), + Extra_Accessibility (Formal)); + + -- Treat the unchecked attributes as library-level + + when Attribute_Unchecked_Access | + Attribute_Unrestricted_Access => + Add_Extra_Actual + (Make_Integer_Literal (Loc, + Intval => Scope_Depth (Standard_Standard)), + Extra_Accessibility (Formal)); + + -- No other cases of attributes returning access + -- values that can be passed to access parameters. + + when others => + raise Program_Error; + + end case; + + -- For allocators we pass the level of the execution of the + -- called subprogram, which is one greater than the current + -- scope level. + + when N_Allocator => + Add_Extra_Actual + (Make_Integer_Literal (Loc, + Intval => Scope_Depth (Current_Scope) + 1), + Extra_Accessibility (Formal)); + + -- For other cases we simply pass the level of the actual's + -- access type. The type is retrieved from Prev rather than + -- Prev_Orig, because in some cases Prev_Orig denotes an + -- original expression that has not been analyzed. + + when others => + Add_Extra_Actual + (Make_Integer_Literal (Loc, + Intval => Type_Access_Level (Etype (Prev))), + Extra_Accessibility (Formal)); + end case; + end if; + end if; + + -- Perform the check of 4.6(49) that prevents a null value from being + -- passed as an actual to an access parameter. Note that the check + -- is elided in the common cases of passing an access attribute or + -- access parameter as an actual. Also, we currently don't enforce + -- this check for expander-generated actuals and when -gnatdj is set. + + if Ada_Version >= Ada_2005 then + + -- Ada 2005 (AI-231): Check null-excluding access types. Note that + -- the intent of 6.4.1(13) is that null-exclusion checks should + -- not be done for 'out' parameters, even though it refers only + -- to constraint checks, and a null_exclusion is not a constraint. + -- Note that AI05-0196-1 corrects this mistake in the RM. + + if Is_Access_Type (Etype (Formal)) + and then Can_Never_Be_Null (Etype (Formal)) + and then Ekind (Formal) /= E_Out_Parameter + and then Nkind (Prev) /= N_Raise_Constraint_Error + and then (Known_Null (Prev) + or else not Can_Never_Be_Null (Etype (Prev))) + then + Install_Null_Excluding_Check (Prev); + end if; + + -- Ada_Version < Ada_2005 + + else + if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type + or else Access_Checks_Suppressed (Subp) + then + null; + + elsif Debug_Flag_J then + null; + + elsif not Comes_From_Source (Prev) then + null; + + elsif Is_Entity_Name (Prev) + and then Ekind (Etype (Prev)) = E_Anonymous_Access_Type + then + null; + + elsif Nkind_In (Prev, N_Allocator, N_Attribute_Reference) then + null; + + -- Suppress null checks when passing to access parameters of Java + -- and CIL subprograms. (Should this be done for other foreign + -- conventions as well ???) + + elsif Convention (Subp) = Convention_Java + or else Convention (Subp) = Convention_CIL + then + null; + + else + Install_Null_Excluding_Check (Prev); + end if; + end if; + + -- Perform appropriate validity checks on parameters that + -- are entities. + + if Validity_Checks_On then + if (Ekind (Formal) = E_In_Parameter + and then Validity_Check_In_Params) + or else + (Ekind (Formal) = E_In_Out_Parameter + and then Validity_Check_In_Out_Params) + then + -- If the actual is an indexed component of a packed type (or + -- is an indexed or selected component whose prefix recursively + -- meets this condition), it has not been expanded yet. It will + -- be copied in the validity code that follows, and has to be + -- expanded appropriately, so reanalyze it. + + -- What we do is just to unset analyzed bits on prefixes till + -- we reach something that does not have a prefix. + + declare + Nod : Node_Id; + + begin + Nod := Actual; + while Nkind_In (Nod, N_Indexed_Component, + N_Selected_Component) + loop + Set_Analyzed (Nod, False); + Nod := Prefix (Nod); + end loop; + end; + + Ensure_Valid (Actual); + end if; + end if; + + -- For IN OUT and OUT parameters, ensure that subscripts are valid + -- since this is a left side reference. We only do this for calls + -- from the source program since we assume that compiler generated + -- calls explicitly generate any required checks. We also need it + -- only if we are doing standard validity checks, since clearly it is + -- not needed if validity checks are off, and in subscript validity + -- checking mode, all indexed components are checked with a call + -- directly from Expand_N_Indexed_Component. + + if Comes_From_Source (Call_Node) + and then Ekind (Formal) /= E_In_Parameter + and then Validity_Checks_On + and then Validity_Check_Default + and then not Validity_Check_Subscripts + then + Check_Valid_Lvalue_Subscripts (Actual); + end if; + + -- Mark any scalar OUT parameter that is a simple variable as no + -- longer known to be valid (unless the type is always valid). This + -- reflects the fact that if an OUT parameter is never set in a + -- procedure, then it can become invalid on the procedure return. + + if Ekind (Formal) = E_Out_Parameter + and then Is_Entity_Name (Actual) + and then Ekind (Entity (Actual)) = E_Variable + and then not Is_Known_Valid (Etype (Actual)) + then + Set_Is_Known_Valid (Entity (Actual), False); + end if; + + -- For an OUT or IN OUT parameter, if the actual is an entity, then + -- clear current values, since they can be clobbered. We are probably + -- doing this in more places than we need to, but better safe than + -- sorry when it comes to retaining bad current values! + + if Ekind (Formal) /= E_In_Parameter + and then Is_Entity_Name (Actual) + and then Present (Entity (Actual)) + then + declare + Ent : constant Entity_Id := Entity (Actual); + Sav : Node_Id; + + begin + -- For an OUT or IN OUT parameter that is an assignable entity, + -- we do not want to clobber the Last_Assignment field, since + -- if it is set, it was precisely because it is indeed an OUT + -- or IN OUT parameter! We do reset the Is_Known_Valid flag + -- since the subprogram could have returned in invalid value. + + if (Ekind (Formal) = E_Out_Parameter + or else + Ekind (Formal) = E_In_Out_Parameter) + and then Is_Assignable (Ent) + then + Sav := Last_Assignment (Ent); + Kill_Current_Values (Ent); + Set_Last_Assignment (Ent, Sav); + Set_Is_Known_Valid (Ent, False); + + -- For all other cases, just kill the current values + + else + Kill_Current_Values (Ent); + end if; + end; + end if; + + -- If the formal is class wide and the actual is an aggregate, force + -- evaluation so that the back end who does not know about class-wide + -- type, does not generate a temporary of the wrong size. + + if not Is_Class_Wide_Type (Etype (Formal)) then + null; + + elsif Nkind (Actual) = N_Aggregate + or else (Nkind (Actual) = N_Qualified_Expression + and then Nkind (Expression (Actual)) = N_Aggregate) + then + Force_Evaluation (Actual); + end if; + + -- In a remote call, if the formal is of a class-wide type, check + -- that the actual meets the requirements described in E.4(18). + + if Remote and then Is_Class_Wide_Type (Etype (Formal)) then + Insert_Action (Actual, + Make_Transportable_Check (Loc, + Duplicate_Subexpr_Move_Checks (Actual))); + end if; + + -- This label is required when skipping extra actual generation for + -- Unchecked_Union parameters. + + <> + + Param_Count := Param_Count + 1; + Next_Actual (Actual); + Next_Formal (Formal); + end loop; + + -- If we are expanding a rhs of an assignment we need to check if tag + -- propagation is needed. You might expect this processing to be in + -- Analyze_Assignment but has to be done earlier (bottom-up) because the + -- assignment might be transformed to a declaration for an unconstrained + -- value if the expression is classwide. + + if Nkind (Call_Node) = N_Function_Call + and then Is_Tag_Indeterminate (Call_Node) + and then Is_Entity_Name (Name (Call_Node)) + then + declare + Ass : Node_Id := Empty; + + begin + if Nkind (Parent (Call_Node)) = N_Assignment_Statement then + Ass := Parent (Call_Node); + + elsif Nkind (Parent (Call_Node)) = N_Qualified_Expression + and then Nkind (Parent (Parent (Call_Node))) = + N_Assignment_Statement + then + Ass := Parent (Parent (Call_Node)); + + elsif Nkind (Parent (Call_Node)) = N_Explicit_Dereference + and then Nkind (Parent (Parent (Call_Node))) = + N_Assignment_Statement + then + Ass := Parent (Parent (Call_Node)); + end if; + + if Present (Ass) + and then Is_Class_Wide_Type (Etype (Name (Ass))) + then + if Is_Access_Type (Etype (Call_Node)) then + if Designated_Type (Etype (Call_Node)) /= + Root_Type (Etype (Name (Ass))) + then + Error_Msg_NE + ("tag-indeterminate expression " + & " must have designated type& (RM 5.2 (6))", + Call_Node, Root_Type (Etype (Name (Ass)))); + else + Propagate_Tag (Name (Ass), Call_Node); + end if; + + elsif Etype (Call_Node) /= Root_Type (Etype (Name (Ass))) then + Error_Msg_NE + ("tag-indeterminate expression must have type&" + & "(RM 5.2 (6))", + Call_Node, Root_Type (Etype (Name (Ass)))); + + else + Propagate_Tag (Name (Ass), Call_Node); + end if; + + -- The call will be rewritten as a dispatching call, and + -- expanded as such. + + return; + end if; + end; + end if; + + -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand + -- it to point to the correct secondary virtual table + + if Nkind_In (Call_Node, N_Function_Call, N_Procedure_Call_Statement) + and then CW_Interface_Formals_Present + then + Expand_Interface_Actuals (Call_Node); + end if; + + -- Deals with Dispatch_Call if we still have a call, before expanding + -- extra actuals since this will be done on the re-analysis of the + -- dispatching call. Note that we do not try to shorten the actual list + -- for a dispatching call, it would not make sense to do so. Expansion + -- of dispatching calls is suppressed when VM_Target, because the VM + -- back-ends directly handle the generation of dispatching calls and + -- would have to undo any expansion to an indirect call. + + if Nkind_In (Call_Node, N_Function_Call, N_Procedure_Call_Statement) + and then Present (Controlling_Argument (Call_Node)) + then + declare + Call_Typ : constant Entity_Id := Etype (Call_Node); + Typ : constant Entity_Id := Find_Dispatching_Type (Subp); + Eq_Prim_Op : Entity_Id := Empty; + New_Call : Node_Id; + Param : Node_Id; + Prev_Call : Node_Id; + + begin + if not Is_Limited_Type (Typ) then + Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); + end if; + + if Tagged_Type_Expansion then + Expand_Dispatching_Call (Call_Node); + + -- The following return is worrisome. Is it really OK to skip + -- all remaining processing in this procedure ??? + + return; + + -- VM targets + + else + Apply_Tag_Checks (Call_Node); + + -- If this is a dispatching "=", we must first compare the + -- tags so we generate: x.tag = y.tag and then x = y + + if Subp = Eq_Prim_Op then + + -- Mark the node as analyzed to avoid reanalizing this + -- dispatching call (which would cause a never-ending loop) + + Prev_Call := Relocate_Node (Call_Node); + Set_Analyzed (Prev_Call); + + Param := First_Actual (Call_Node); + New_Call := + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => New_Value (Param), + Selector_Name => + New_Reference_To (First_Tag_Component (Typ), + Loc)), + + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Typ, + New_Value (Next_Actual (Param))), + Selector_Name => + New_Reference_To + (First_Tag_Component (Typ), Loc))), + Right_Opnd => Prev_Call); + + Rewrite (Call_Node, New_Call); + + Analyze_And_Resolve + (Call_Node, Call_Typ, Suppress => All_Checks); + end if; + + -- Expansion of a dispatching call results in an indirect call, + -- which in turn causes current values to be killed (see + -- Resolve_Call), so on VM targets we do the call here to + -- ensure consistent warnings between VM and non-VM targets. + + Kill_Current_Values; + end if; + + -- If this is a dispatching "=" then we must update the reference + -- to the call node because we generated: + -- x.tag = y.tag and then x = y + + if Subp = Eq_Prim_Op then + Call_Node := Right_Opnd (Call_Node); + end if; + end; + end if; + + -- Similarly, expand calls to RCI subprograms on which pragma + -- All_Calls_Remote applies. The rewriting will be reanalyzed + -- later. Do this only when the call comes from source since we + -- do not want such a rewriting to occur in expanded code. + + if Is_All_Remote_Call (Call_Node) then + Expand_All_Calls_Remote_Subprogram_Call (Call_Node); + + -- Similarly, do not add extra actuals for an entry call whose entity + -- is a protected procedure, or for an internal protected subprogram + -- call, because it will be rewritten as a protected subprogram call + -- and reanalyzed (see Expand_Protected_Subprogram_Call). + + elsif Is_Protected_Type (Scope (Subp)) + and then (Ekind (Subp) = E_Procedure + or else Ekind (Subp) = E_Function) + then + null; + + -- During that loop we gathered the extra actuals (the ones that + -- correspond to Extra_Formals), so now they can be appended. + + else + while Is_Non_Empty_List (Extra_Actuals) loop + Add_Actual_Parameter (Remove_Head (Extra_Actuals)); + end loop; + end if; + + -- At this point we have all the actuals, so this is the point at which + -- the various expansion activities for actuals is carried out. + + Expand_Actuals (Call_Node, Subp); + + -- If the subprogram is a renaming, or if it is inherited, replace it in + -- the call with the name of the actual subprogram being called. If this + -- is a dispatching call, the run-time decides what to call. The Alias + -- attribute does not apply to entries. + + if Nkind (Call_Node) /= N_Entry_Call_Statement + and then No (Controlling_Argument (Call_Node)) + and then Present (Parent_Subp) + then + if Present (Inherited_From_Formal (Subp)) then + Parent_Subp := Inherited_From_Formal (Subp); + else + Parent_Subp := Ultimate_Alias (Parent_Subp); + end if; + + -- The below setting of Entity is suspect, see F109-018 discussion??? + + Set_Entity (Name (Call_Node), Parent_Subp); + + if Is_Abstract_Subprogram (Parent_Subp) + and then not In_Instance + then + Error_Msg_NE + ("cannot call abstract subprogram &!", + Name (Call_Node), Parent_Subp); + end if; + + -- Inspect all formals of derived subprogram Subp. Compare parameter + -- types with the parent subprogram and check whether an actual may + -- need a type conversion to the corresponding formal of the parent + -- subprogram. + + -- Not clear whether intrinsic subprograms need such conversions. ??? + + if not Is_Intrinsic_Subprogram (Parent_Subp) + or else Is_Generic_Instance (Parent_Subp) + then + declare + procedure Convert (Act : Node_Id; Typ : Entity_Id); + -- Rewrite node Act as a type conversion of Act to Typ. Analyze + -- and resolve the newly generated construct. + + ------------- + -- Convert -- + ------------- + + procedure Convert (Act : Node_Id; Typ : Entity_Id) is + begin + Rewrite (Act, OK_Convert_To (Typ, Relocate_Node (Act))); + Analyze (Act); + Resolve (Act, Typ); + end Convert; + + -- Local variables + + Actual_Typ : Entity_Id; + Formal_Typ : Entity_Id; + Parent_Typ : Entity_Id; + + begin + Actual := First_Actual (Call_Node); + Formal := First_Formal (Subp); + Parent_Formal := First_Formal (Parent_Subp); + while Present (Formal) loop + Actual_Typ := Etype (Actual); + Formal_Typ := Etype (Formal); + Parent_Typ := Etype (Parent_Formal); + + -- For an IN parameter of a scalar type, the parent formal + -- type and derived formal type differ or the parent formal + -- type and actual type do not match statically. + + if Is_Scalar_Type (Formal_Typ) + and then Ekind (Formal) = E_In_Parameter + and then Formal_Typ /= Parent_Typ + and then + not Subtypes_Statically_Match (Parent_Typ, Actual_Typ) + and then not Raises_Constraint_Error (Actual) + then + Convert (Actual, Parent_Typ); + Enable_Range_Check (Actual); + + -- If the actual has been marked as requiring a range + -- check, then generate it here. + + if Do_Range_Check (Actual) then + Set_Do_Range_Check (Actual, False); + Generate_Range_Check + (Actual, Etype (Formal), CE_Range_Check_Failed); + end if; + + -- For access types, the parent formal type and actual type + -- differ. + + elsif Is_Access_Type (Formal_Typ) + and then Base_Type (Parent_Typ) /= Base_Type (Actual_Typ) + then + if Ekind (Formal) /= E_In_Parameter then + Convert (Actual, Parent_Typ); + + elsif Ekind (Parent_Typ) = E_Anonymous_Access_Type + and then Designated_Type (Parent_Typ) /= + Designated_Type (Actual_Typ) + and then not Is_Controlling_Formal (Formal) + then + -- This unchecked conversion is not necessary unless + -- inlining is enabled, because in that case the type + -- mismatch may become visible in the body about to be + -- inlined. + + Rewrite (Actual, + Unchecked_Convert_To (Parent_Typ, + Relocate_Node (Actual))); + Analyze (Actual); + Resolve (Actual, Parent_Typ); + end if; + + -- For array and record types, the parent formal type and + -- derived formal type have different sizes or pragma Pack + -- status. + + elsif ((Is_Array_Type (Formal_Typ) + and then Is_Array_Type (Parent_Typ)) + or else + (Is_Record_Type (Formal_Typ) + and then Is_Record_Type (Parent_Typ))) + and then + (Esize (Formal_Typ) /= Esize (Parent_Typ) + or else Has_Pragma_Pack (Formal_Typ) /= + Has_Pragma_Pack (Parent_Typ)) + then + Convert (Actual, Parent_Typ); + end if; + + Next_Actual (Actual); + Next_Formal (Formal); + Next_Formal (Parent_Formal); + end loop; + end; + end if; + + Orig_Subp := Subp; + Subp := Parent_Subp; + end if; + + -- Check for violation of No_Abort_Statements + + if Is_RTE (Subp, RE_Abort_Task) then + Check_Restriction (No_Abort_Statements, Call_Node); + + -- Check for violation of No_Dynamic_Attachment + + elsif RTU_Loaded (Ada_Interrupts) + and then (Is_RTE (Subp, RE_Is_Reserved) or else + Is_RTE (Subp, RE_Is_Attached) or else + Is_RTE (Subp, RE_Current_Handler) or else + Is_RTE (Subp, RE_Attach_Handler) or else + Is_RTE (Subp, RE_Exchange_Handler) or else + Is_RTE (Subp, RE_Detach_Handler) or else + Is_RTE (Subp, RE_Reference)) + then + Check_Restriction (No_Dynamic_Attachment, Call_Node); + end if; + + -- Deal with case where call is an explicit dereference + + if Nkind (Name (Call_Node)) = N_Explicit_Dereference then + + -- Handle case of access to protected subprogram type + + if Is_Access_Protected_Subprogram_Type + (Base_Type (Etype (Prefix (Name (Call_Node))))) + then + -- If this is a call through an access to protected operation, the + -- prefix has the form (object'address, operation'access). Rewrite + -- as a for other protected calls: the object is the 1st parameter + -- of the list of actuals. + + declare + Call : Node_Id; + Parm : List_Id; + Nam : Node_Id; + Obj : Node_Id; + Ptr : constant Node_Id := Prefix (Name (Call_Node)); + + T : constant Entity_Id := + Equivalent_Type (Base_Type (Etype (Ptr))); + + D_T : constant Entity_Id := + Designated_Type (Base_Type (Etype (Ptr))); + + begin + Obj := + Make_Selected_Component (Loc, + Prefix => Unchecked_Convert_To (T, Ptr), + Selector_Name => + New_Occurrence_Of (First_Entity (T), Loc)); + + Nam := + Make_Selected_Component (Loc, + Prefix => Unchecked_Convert_To (T, Ptr), + Selector_Name => + New_Occurrence_Of (Next_Entity (First_Entity (T)), Loc)); + + Nam := + Make_Explicit_Dereference (Loc, + Prefix => Nam); + + if Present (Parameter_Associations (Call_Node)) then + Parm := Parameter_Associations (Call_Node); + else + Parm := New_List; + end if; + + Prepend (Obj, Parm); + + if Etype (D_T) = Standard_Void_Type then + Call := + Make_Procedure_Call_Statement (Loc, + Name => Nam, + Parameter_Associations => Parm); + else + Call := + Make_Function_Call (Loc, + Name => Nam, + Parameter_Associations => Parm); + end if; + + Set_First_Named_Actual (Call, First_Named_Actual (Call_Node)); + Set_Etype (Call, Etype (D_T)); + + -- We do not re-analyze the call to avoid infinite recursion. + -- We analyze separately the prefix and the object, and set + -- the checks on the prefix that would otherwise be emitted + -- when resolving a call. + + Rewrite (Call_Node, Call); + Analyze (Nam); + Apply_Access_Check (Nam); + Analyze (Obj); + return; + end; + end if; + end if; + + -- If this is a call to an intrinsic subprogram, then perform the + -- appropriate expansion to the corresponding tree node and we + -- are all done (since after that the call is gone!) + + -- In the case where the intrinsic is to be processed by the back end, + -- the call to Expand_Intrinsic_Call will do nothing, which is fine, + -- since the idea in this case is to pass the call unchanged. If the + -- intrinsic is an inherited unchecked conversion, and the derived type + -- is the target type of the conversion, we must retain it as the return + -- type of the expression. Otherwise the expansion below, which uses the + -- parent operation, will yield the wrong type. + + if Is_Intrinsic_Subprogram (Subp) then + Expand_Intrinsic_Call (Call_Node, Subp); + + if Nkind (Call_Node) = N_Unchecked_Type_Conversion + and then Parent_Subp /= Orig_Subp + and then Etype (Parent_Subp) /= Etype (Orig_Subp) + then + Set_Etype (Call_Node, Etype (Orig_Subp)); + end if; + + return; + end if; + + if Ekind_In (Subp, E_Function, E_Procedure) then + + -- We perform two simple optimization on calls: + + -- a) replace calls to null procedures unconditionally; + + -- b) for To_Address, just do an unchecked conversion. Not only is + -- this efficient, but it also avoids order of elaboration problems + -- when address clauses are inlined (address expression elaborated + -- at the wrong point). + + -- We perform these optimization regardless of whether we are in the + -- main unit or in a unit in the context of the main unit, to ensure + -- that tree generated is the same in both cases, for Inspector use. + + if Is_RTE (Subp, RE_To_Address) then + Rewrite (Call_Node, + Unchecked_Convert_To + (RTE (RE_Address), Relocate_Node (First_Actual (Call_Node)))); + return; + + elsif Is_Null_Procedure (Subp) then + Rewrite (Call_Node, Make_Null_Statement (Loc)); + return; + end if; + + if Is_Inlined (Subp) then + + Inlined_Subprogram : declare + Bod : Node_Id; + Must_Inline : Boolean := False; + Spec : constant Node_Id := Unit_Declaration_Node (Subp); + Scop : constant Entity_Id := Scope (Subp); + + function In_Unfrozen_Instance return Boolean; + -- If the subprogram comes from an instance in the same unit, + -- and the instance is not yet frozen, inlining might trigger + -- order-of-elaboration problems in gigi. + + -------------------------- + -- In_Unfrozen_Instance -- + -------------------------- + + function In_Unfrozen_Instance return Boolean is + S : Entity_Id; + + begin + S := Scop; + while Present (S) + and then S /= Standard_Standard + loop + if Is_Generic_Instance (S) + and then Present (Freeze_Node (S)) + and then not Analyzed (Freeze_Node (S)) + then + return True; + end if; + + S := Scope (S); + end loop; + + return False; + end In_Unfrozen_Instance; + + -- Start of processing for Inlined_Subprogram + + begin + -- Verify that the body to inline has already been seen, and + -- that if the body is in the current unit the inlining does + -- not occur earlier. This avoids order-of-elaboration problems + -- in the back end. + + -- This should be documented in sinfo/einfo ??? + + if No (Spec) + or else Nkind (Spec) /= N_Subprogram_Declaration + or else No (Body_To_Inline (Spec)) + then + Must_Inline := False; + + -- If this an inherited function that returns a private type, + -- do not inline if the full view is an unconstrained array, + -- because such calls cannot be inlined. + + elsif Present (Orig_Subp) + and then Is_Array_Type (Etype (Orig_Subp)) + and then not Is_Constrained (Etype (Orig_Subp)) + then + Must_Inline := False; + + elsif In_Unfrozen_Instance then + Must_Inline := False; + + else + Bod := Body_To_Inline (Spec); + + if (In_Extended_Main_Code_Unit (Call_Node) + or else In_Extended_Main_Code_Unit (Parent (Call_Node)) + or else Has_Pragma_Inline_Always (Subp)) + and then (not In_Same_Extended_Unit (Sloc (Bod), Loc) + or else + Earlier_In_Extended_Unit (Sloc (Bod), Loc)) + then + Must_Inline := True; + + -- If we are compiling a package body that is not the main + -- unit, it must be for inlining/instantiation purposes, + -- in which case we inline the call to insure that the same + -- temporaries are generated when compiling the body by + -- itself. Otherwise link errors can occur. + + -- If the function being called is itself in the main unit, + -- we cannot inline, because there is a risk of double + -- elaboration and/or circularity: the inlining can make + -- visible a private entity in the body of the main unit, + -- that gigi will see before its sees its proper definition. + + elsif not (In_Extended_Main_Code_Unit (Call_Node)) + and then In_Package_Body + then + Must_Inline := not In_Extended_Main_Source_Unit (Subp); + end if; + end if; + + if Must_Inline then + Expand_Inlined_Call (Call_Node, Subp, Orig_Subp); + + else + -- Let the back end handle it + + Add_Inlined_Body (Subp); + + if Front_End_Inlining + and then Nkind (Spec) = N_Subprogram_Declaration + and then (In_Extended_Main_Code_Unit (Call_Node)) + and then No (Body_To_Inline (Spec)) + and then not Has_Completion (Subp) + and then In_Same_Extended_Unit (Sloc (Spec), Loc) + then + Cannot_Inline + ("cannot inline& (body not seen yet)?", Call_Node, Subp); + end if; + end if; + end Inlined_Subprogram; + end if; + end if; + + -- Check for protected subprogram. This is either an intra-object call, + -- or a protected function call. Protected procedure calls are rewritten + -- as entry calls and handled accordingly. + + -- In Ada 2005, this may be an indirect call to an access parameter that + -- is an access_to_subprogram. In that case the anonymous type has a + -- scope that is a protected operation, but the call is a regular one. + -- In either case do not expand call if subprogram is eliminated. + + Scop := Scope (Subp); + + if Nkind (Call_Node) /= N_Entry_Call_Statement + and then Is_Protected_Type (Scop) + and then Ekind (Subp) /= E_Subprogram_Type + and then not Is_Eliminated (Subp) + then + -- If the call is an internal one, it is rewritten as a call to the + -- corresponding unprotected subprogram. + + Expand_Protected_Subprogram_Call (Call_Node, Subp, Scop); + end if; + + -- Functions returning controlled objects need special attention: + -- if the return type is limited, the context is an initialization + -- and different processing applies. If the call is to a protected + -- function, the expansion above will call Expand_Call recursively. + -- To prevent a double attachment, check that the current call is + -- not a rewriting of a protected function call. + + if Needs_Finalization (Etype (Subp)) then + if not Is_Immutably_Limited_Type (Etype (Subp)) + and then + (No (First_Formal (Subp)) + or else + not Is_Concurrent_Record_Type (Etype (First_Formal (Subp)))) + then + Expand_Ctrl_Function_Call (Call_Node); + + -- Build-in-place function calls which appear in anonymous contexts + -- need a transient scope to ensure the proper finalization of the + -- intermediate result after its use. + + elsif Is_Build_In_Place_Function_Call (Call_Node) + and then Nkind_In (Parent (Call_Node), N_Attribute_Reference, + N_Function_Call, + N_Indexed_Component, + N_Object_Renaming_Declaration, + N_Procedure_Call_Statement, + N_Selected_Component, + N_Slice) + then + Establish_Transient_Scope (Call_Node, Sec_Stack => True); + end if; + end if; + + -- Test for First_Optional_Parameter, and if so, truncate parameter list + -- if there are optional parameters at the trailing end. + -- Note: we never delete procedures for call via a pointer. + + if (Ekind (Subp) = E_Procedure or else Ekind (Subp) = E_Function) + and then Present (First_Optional_Parameter (Subp)) + then + declare + Last_Keep_Arg : Node_Id; + + begin + -- Last_Keep_Arg will hold the last actual that should be kept. + -- If it remains empty at the end, it means that all parameters + -- are optional. + + Last_Keep_Arg := Empty; + + -- Find first optional parameter, must be present since we checked + -- the validity of the parameter before setting it. + + Formal := First_Formal (Subp); + Actual := First_Actual (Call_Node); + while Formal /= First_Optional_Parameter (Subp) loop + Last_Keep_Arg := Actual; + Next_Formal (Formal); + Next_Actual (Actual); + end loop; + + -- We have Formal and Actual pointing to the first potentially + -- droppable argument. We can drop all the trailing arguments + -- whose actual matches the default. Note that we know that all + -- remaining formals have defaults, because we checked that this + -- requirement was met before setting First_Optional_Parameter. + + -- We use Fully_Conformant_Expressions to check for identity + -- between formals and actuals, which may miss some cases, but + -- on the other hand, this is only an optimization (if we fail + -- to truncate a parameter it does not affect functionality). + -- So if the default is 3 and the actual is 1+2, we consider + -- them unequal, which hardly seems worrisome. + + while Present (Formal) loop + if not Fully_Conformant_Expressions + (Actual, Default_Value (Formal)) + then + Last_Keep_Arg := Actual; + end if; + + Next_Formal (Formal); + Next_Actual (Actual); + end loop; + + -- If no arguments, delete entire list, this is the easy case + + if No (Last_Keep_Arg) then + Set_Parameter_Associations (Call_Node, No_List); + Set_First_Named_Actual (Call_Node, Empty); + + -- Case where at the last retained argument is positional. This + -- is also an easy case, since the retained arguments are already + -- in the right form, and we don't need to worry about the order + -- of arguments that get eliminated. + + elsif Is_List_Member (Last_Keep_Arg) then + while Present (Next (Last_Keep_Arg)) loop + Discard_Node (Remove_Next (Last_Keep_Arg)); + end loop; + + Set_First_Named_Actual (Call_Node, Empty); + + -- This is the annoying case where the last retained argument + -- is a named parameter. Since the original arguments are not + -- in declaration order, we may have to delete some fairly + -- random collection of arguments. + + else + declare + Temp : Node_Id; + Passoc : Node_Id; + + begin + -- First step, remove all the named parameters from the + -- list (they are still chained using First_Named_Actual + -- and Next_Named_Actual, so we have not lost them!) + + Temp := First (Parameter_Associations (Call_Node)); + + -- Case of all parameters named, remove them all + + if Nkind (Temp) = N_Parameter_Association then + -- Suppress warnings to avoid warning on possible + -- infinite loop (because Call_Node is not modified). + + pragma Warnings (Off); + while Is_Non_Empty_List + (Parameter_Associations (Call_Node)) + loop + Temp := + Remove_Head (Parameter_Associations (Call_Node)); + end loop; + pragma Warnings (On); + + -- Case of mixed positional/named, remove named parameters + + else + while Nkind (Next (Temp)) /= N_Parameter_Association loop + Next (Temp); + end loop; + + while Present (Next (Temp)) loop + Remove (Next (Temp)); + end loop; + end if; + + -- Now we loop through the named parameters, till we get + -- to the last one to be retained, adding them to the list. + -- Note that the Next_Named_Actual list does not need to be + -- touched since we are only reordering them on the actual + -- parameter association list. + + Passoc := Parent (First_Named_Actual (Call_Node)); + loop + Temp := Relocate_Node (Passoc); + Append_To + (Parameter_Associations (Call_Node), Temp); + exit when + Last_Keep_Arg = Explicit_Actual_Parameter (Passoc); + Passoc := Parent (Next_Named_Actual (Passoc)); + end loop; + + Set_Next_Named_Actual (Temp, Empty); + + loop + Temp := Next_Named_Actual (Passoc); + exit when No (Temp); + Set_Next_Named_Actual + (Passoc, Next_Named_Actual (Parent (Temp))); + end loop; + end; + + end if; + end; + end if; + end Expand_Call; + + -------------------------- + -- Expand_Inlined_Call -- + -------------------------- + + procedure Expand_Inlined_Call + (N : Node_Id; + Subp : Entity_Id; + Orig_Subp : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Is_Predef : constant Boolean := + Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Subp))); + Orig_Bod : constant Node_Id := + Body_To_Inline (Unit_Declaration_Node (Subp)); + + Blk : Node_Id; + Bod : Node_Id; + Decl : Node_Id; + Decls : constant List_Id := New_List; + Exit_Lab : Entity_Id := Empty; + F : Entity_Id; + A : Node_Id; + Lab_Decl : Node_Id; + Lab_Id : Node_Id; + New_A : Node_Id; + Num_Ret : Int := 0; + Ret_Type : Entity_Id; + Targ : Node_Id; + Targ1 : Node_Id; + Temp : Entity_Id; + Temp_Typ : Entity_Id; + + Return_Object : Entity_Id := Empty; + -- Entity in declaration in an extended_return_statement + + Is_Unc : constant Boolean := + Is_Array_Type (Etype (Subp)) + and then not Is_Constrained (Etype (Subp)); + -- If the type returned by the function is unconstrained and the call + -- can be inlined, special processing is required. + + procedure Make_Exit_Label; + -- Build declaration for exit label to be used in Return statements, + -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit + -- declaration). Does nothing if Exit_Lab already set. + + function Process_Formals (N : Node_Id) return Traverse_Result; + -- Replace occurrence of a formal with the corresponding actual, or the + -- thunk generated for it. + + function Process_Sloc (Nod : Node_Id) return Traverse_Result; + -- If the call being expanded is that of an internal subprogram, set the + -- sloc of the generated block to that of the call itself, so that the + -- expansion is skipped by the "next" command in gdb. + -- Same processing for a subprogram in a predefined file, e.g. + -- Ada.Tags. If Debug_Generated_Code is true, suppress this change to + -- simplify our own development. + + procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id); + -- If the function body is a single expression, replace call with + -- expression, else insert block appropriately. + + procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id); + -- If procedure body has no local variables, inline body without + -- creating block, otherwise rewrite call with block. + + function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean; + -- Determine whether a formal parameter is used only once in Orig_Bod + + --------------------- + -- Make_Exit_Label -- + --------------------- + + procedure Make_Exit_Label is + Lab_Ent : Entity_Id; + begin + if No (Exit_Lab) then + Lab_Ent := Make_Temporary (Loc, 'L'); + Lab_Id := New_Reference_To (Lab_Ent, Loc); + Exit_Lab := Make_Label (Loc, Lab_Id); + Lab_Decl := + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Lab_Ent, + Label_Construct => Exit_Lab); + end if; + end Make_Exit_Label; + + --------------------- + -- Process_Formals -- + --------------------- + + function Process_Formals (N : Node_Id) return Traverse_Result is + A : Entity_Id; + E : Entity_Id; + Ret : Node_Id; + + begin + if Is_Entity_Name (N) + and then Present (Entity (N)) + then + E := Entity (N); + + if Is_Formal (E) + and then Scope (E) = Subp + then + A := Renamed_Object (E); + + -- Rewrite the occurrence of the formal into an occurrence of + -- the actual. Also establish visibility on the proper view of + -- the actual's subtype for the body's context (if the actual's + -- subtype is private at the call point but its full view is + -- visible to the body, then the inlined tree here must be + -- analyzed with the full view). + + if Is_Entity_Name (A) then + Rewrite (N, New_Occurrence_Of (Entity (A), Loc)); + Check_Private_View (N); + + elsif Nkind (A) = N_Defining_Identifier then + Rewrite (N, New_Occurrence_Of (A, Loc)); + Check_Private_View (N); + + -- Numeric literal + + else + Rewrite (N, New_Copy (A)); + end if; + end if; + return Skip; + + elsif Is_Entity_Name (N) + and then Present (Return_Object) + and then Chars (N) = Chars (Return_Object) + then + -- Occurrence within an extended return statement. The return + -- object is local to the body been inlined, and thus the generic + -- copy is not analyzed yet, so we match by name, and replace it + -- with target of call. + + if Nkind (Targ) = N_Defining_Identifier then + Rewrite (N, New_Occurrence_Of (Targ, Loc)); + else + Rewrite (N, New_Copy_Tree (Targ)); + end if; + + return Skip; + + elsif Nkind (N) = N_Simple_Return_Statement then + if No (Expression (N)) then + Make_Exit_Label; + Rewrite (N, + Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id))); + + else + if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements + and then Nkind (Parent (Parent (N))) = N_Subprogram_Body + then + -- Function body is a single expression. No need for + -- exit label. + + null; + + else + Num_Ret := Num_Ret + 1; + Make_Exit_Label; + end if; + + -- Because of the presence of private types, the views of the + -- expression and the context may be different, so place an + -- unchecked conversion to the context type to avoid spurious + -- errors, e.g. when the expression is a numeric literal and + -- the context is private. If the expression is an aggregate, + -- use a qualified expression, because an aggregate is not a + -- legal argument of a conversion. + + if Nkind_In (Expression (N), N_Aggregate, N_Null) then + Ret := + Make_Qualified_Expression (Sloc (N), + Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)), + Expression => Relocate_Node (Expression (N))); + else + Ret := + Unchecked_Convert_To + (Ret_Type, Relocate_Node (Expression (N))); + end if; + + if Nkind (Targ) = N_Defining_Identifier then + Rewrite (N, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Targ, Loc), + Expression => Ret)); + else + Rewrite (N, + Make_Assignment_Statement (Loc, + Name => New_Copy (Targ), + Expression => Ret)); + end if; + + Set_Assignment_OK (Name (N)); + + if Present (Exit_Lab) then + Insert_After (N, + Make_Goto_Statement (Loc, + Name => New_Copy (Lab_Id))); + end if; + end if; + + return OK; + + elsif Nkind (N) = N_Extended_Return_Statement then + + -- An extended return becomes a block whose first statement is + -- the assignment of the initial expression of the return object + -- to the target of the call itself. + + declare + Return_Decl : constant Entity_Id := + First (Return_Object_Declarations (N)); + Assign : Node_Id; + + begin + Return_Object := Defining_Identifier (Return_Decl); + + if Present (Expression (Return_Decl)) then + if Nkind (Targ) = N_Defining_Identifier then + Assign := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Targ, Loc), + Expression => Expression (Return_Decl)); + else + Assign := + Make_Assignment_Statement (Loc, + Name => New_Copy (Targ), + Expression => Expression (Return_Decl)); + end if; + + Set_Assignment_OK (Name (Assign)); + Prepend (Assign, + Statements (Handled_Statement_Sequence (N))); + end if; + + Rewrite (N, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Handled_Statement_Sequence (N))); + + return OK; + end; + + -- Remove pragma Unreferenced since it may refer to formals that + -- are not visible in the inlined body, and in any case we will + -- not be posting warnings on the inlined body so it is unneeded. + + elsif Nkind (N) = N_Pragma + and then Pragma_Name (N) = Name_Unreferenced + then + Rewrite (N, Make_Null_Statement (Sloc (N))); + return OK; + + else + return OK; + end if; + end Process_Formals; + + procedure Replace_Formals is new Traverse_Proc (Process_Formals); + + ------------------ + -- Process_Sloc -- + ------------------ + + function Process_Sloc (Nod : Node_Id) return Traverse_Result is + begin + if not Debug_Generated_Code then + Set_Sloc (Nod, Sloc (N)); + Set_Comes_From_Source (Nod, False); + end if; + + return OK; + end Process_Sloc; + + procedure Reset_Slocs is new Traverse_Proc (Process_Sloc); + + --------------------------- + -- Rewrite_Function_Call -- + --------------------------- + + procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is + HSS : constant Node_Id := Handled_Statement_Sequence (Blk); + Fst : constant Node_Id := First (Statements (HSS)); + + begin + -- Optimize simple case: function body is a single return statement, + -- which has been expanded into an assignment. + + if Is_Empty_List (Declarations (Blk)) + and then Nkind (Fst) = N_Assignment_Statement + and then No (Next (Fst)) + then + + -- The function call may have been rewritten as the temporary + -- that holds the result of the call, in which case remove the + -- now useless declaration. + + if Nkind (N) = N_Identifier + and then Nkind (Parent (Entity (N))) = N_Object_Declaration + then + Rewrite (Parent (Entity (N)), Make_Null_Statement (Loc)); + end if; + + Rewrite (N, Expression (Fst)); + + elsif Nkind (N) = N_Identifier + and then Nkind (Parent (Entity (N))) = N_Object_Declaration + then + -- The block assigns the result of the call to the temporary + + Insert_After (Parent (Entity (N)), Blk); + + elsif Nkind (Parent (N)) = N_Assignment_Statement + and then + (Is_Entity_Name (Name (Parent (N))) + or else + (Nkind (Name (Parent (N))) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Name (Parent (N)))))) + then + -- Replace assignment with the block + + declare + Original_Assignment : constant Node_Id := Parent (N); + + begin + -- Preserve the original assignment node to keep the complete + -- assignment subtree consistent enough for Analyze_Assignment + -- to proceed (specifically, the original Lhs node must still + -- have an assignment statement as its parent). + + -- We cannot rely on Original_Node to go back from the block + -- node to the assignment node, because the assignment might + -- already be a rewrite substitution. + + Discard_Node (Relocate_Node (Original_Assignment)); + Rewrite (Original_Assignment, Blk); + end; + + elsif Nkind (Parent (N)) = N_Object_Declaration then + Set_Expression (Parent (N), Empty); + Insert_After (Parent (N), Blk); + + elsif Is_Unc then + Insert_Before (Parent (N), Blk); + end if; + end Rewrite_Function_Call; + + ---------------------------- + -- Rewrite_Procedure_Call -- + ---------------------------- + + procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is + HSS : constant Node_Id := Handled_Statement_Sequence (Blk); + begin + -- If there is a transient scope for N, this will be the scope of the + -- actions for N, and the statements in Blk need to be within this + -- scope. For example, they need to have visibility on the constant + -- declarations created for the formals. + + -- If N needs no transient scope, and if there are no declarations in + -- the inlined body, we can do a little optimization and insert the + -- statements for the body directly after N, and rewrite N to a + -- null statement, instead of rewriting N into a full-blown block + -- statement. + + if not Scope_Is_Transient + and then Is_Empty_List (Declarations (Blk)) + then + Insert_List_After (N, Statements (HSS)); + Rewrite (N, Make_Null_Statement (Loc)); + else + Rewrite (N, Blk); + end if; + end Rewrite_Procedure_Call; + + ------------------------- + -- Formal_Is_Used_Once -- + ------------------------- + + function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is + Use_Counter : Int := 0; + + function Count_Uses (N : Node_Id) return Traverse_Result; + -- Traverse the tree and count the uses of the formal parameter. + -- In this case, for optimization purposes, we do not need to + -- continue the traversal once more than one use is encountered. + + ---------------- + -- Count_Uses -- + ---------------- + + function Count_Uses (N : Node_Id) return Traverse_Result is + begin + -- The original node is an identifier + + if Nkind (N) = N_Identifier + and then Present (Entity (N)) + + -- Original node's entity points to the one in the copied body + + and then Nkind (Entity (N)) = N_Identifier + and then Present (Entity (Entity (N))) + + -- The entity of the copied node is the formal parameter + + and then Entity (Entity (N)) = Formal + then + Use_Counter := Use_Counter + 1; + + if Use_Counter > 1 then + + -- Denote more than one use and abandon the traversal + + Use_Counter := 2; + return Abandon; + + end if; + end if; + + return OK; + end Count_Uses; + + procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses); + + -- Start of processing for Formal_Is_Used_Once + + begin + Count_Formal_Uses (Orig_Bod); + return Use_Counter = 1; + end Formal_Is_Used_Once; + + -- Start of processing for Expand_Inlined_Call + + begin + + -- Check for an illegal attempt to inline a recursive procedure. If the + -- subprogram has parameters this is detected when trying to supply a + -- binding for parameters that already have one. For parameterless + -- subprograms this must be done explicitly. + + if In_Open_Scopes (Subp) then + Error_Msg_N ("call to recursive subprogram cannot be inlined?", N); + Set_Is_Inlined (Subp, False); + return; + end if; + + if Nkind (Orig_Bod) = N_Defining_Identifier + or else Nkind (Orig_Bod) = N_Defining_Operator_Symbol + then + -- Subprogram is renaming_as_body. Calls occurring after the renaming + -- can be replaced with calls to the renamed entity directly, because + -- the subprograms are subtype conformant. If the renamed subprogram + -- is an inherited operation, we must redo the expansion because + -- implicit conversions may be needed. Similarly, if the renamed + -- entity is inlined, expand the call for further optimizations. + + Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc)); + + if Present (Alias (Orig_Bod)) or else Is_Inlined (Orig_Bod) then + Expand_Call (N); + end if; + + return; + end if; + + -- Use generic machinery to copy body of inlined subprogram, as if it + -- were an instantiation, resetting source locations appropriately, so + -- that nested inlined calls appear in the main unit. + + Save_Env (Subp, Empty); + Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod)); + + Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True); + Blk := + Make_Block_Statement (Loc, + Declarations => Declarations (Bod), + Handled_Statement_Sequence => Handled_Statement_Sequence (Bod)); + + if No (Declarations (Bod)) then + Set_Declarations (Blk, New_List); + end if; + + -- For the unconstrained case, capture the name of the local + -- variable that holds the result. This must be the first declaration + -- in the block, because its bounds cannot depend on local variables. + -- Otherwise there is no way to declare the result outside of the + -- block. Needless to say, in general the bounds will depend on the + -- actuals in the call. + + if Is_Unc then + Targ1 := Defining_Identifier (First (Declarations (Blk))); + end if; + + -- If this is a derived function, establish the proper return type + + if Present (Orig_Subp) + and then Orig_Subp /= Subp + then + Ret_Type := Etype (Orig_Subp); + else + Ret_Type := Etype (Subp); + end if; + + -- Create temporaries for the actuals that are expressions, or that + -- are scalars and require copying to preserve semantics. + + F := First_Formal (Subp); + A := First_Actual (N); + while Present (F) loop + if Present (Renamed_Object (F)) then + Error_Msg_N ("cannot inline call to recursive subprogram", N); + return; + end if; + + -- If the argument may be a controlling argument in a call within + -- the inlined body, we must preserve its classwide nature to insure + -- that dynamic dispatching take place subsequently. If the formal + -- has a constraint it must be preserved to retain the semantics of + -- the body. + + if Is_Class_Wide_Type (Etype (F)) + or else (Is_Access_Type (Etype (F)) + and then + Is_Class_Wide_Type (Designated_Type (Etype (F)))) + then + Temp_Typ := Etype (F); + + elsif Base_Type (Etype (F)) = Base_Type (Etype (A)) + and then Etype (F) /= Base_Type (Etype (F)) + then + Temp_Typ := Etype (F); + + else + Temp_Typ := Etype (A); + end if; + + -- If the actual is a simple name or a literal, no need to + -- create a temporary, object can be used directly. + + -- If the actual is a literal and the formal has its address taken, + -- we cannot pass the literal itself as an argument, so its value + -- must be captured in a temporary. + + if (Is_Entity_Name (A) + and then + (not Is_Scalar_Type (Etype (A)) + or else Ekind (Entity (A)) = E_Enumeration_Literal)) + + -- When the actual is an identifier and the corresponding formal + -- is used only once in the original body, the formal can be + -- substituted directly with the actual parameter. + + or else (Nkind (A) = N_Identifier + and then Formal_Is_Used_Once (F)) + + or else + (Nkind_In (A, N_Real_Literal, + N_Integer_Literal, + N_Character_Literal) + and then not Address_Taken (F)) + then + if Etype (F) /= Etype (A) then + Set_Renamed_Object + (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A))); + else + Set_Renamed_Object (F, A); + end if; + + else + Temp := Make_Temporary (Loc, 'C'); + + -- If the actual for an in/in-out parameter is a view conversion, + -- make it into an unchecked conversion, given that an untagged + -- type conversion is not a proper object for a renaming. + + -- In-out conversions that involve real conversions have already + -- been transformed in Expand_Actuals. + + if Nkind (A) = N_Type_Conversion + and then Ekind (F) /= E_In_Parameter + then + New_A := + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Etype (F), Loc), + Expression => Relocate_Node (Expression (A))); + + elsif Etype (F) /= Etype (A) then + New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A)); + Temp_Typ := Etype (F); + + else + New_A := Relocate_Node (A); + end if; + + Set_Sloc (New_A, Sloc (N)); + + -- If the actual has a by-reference type, it cannot be copied, so + -- its value is captured in a renaming declaration. Otherwise + -- declare a local constant initialized with the actual. + + -- We also use a renaming declaration for expressions of an array + -- type that is not bit-packed, both for efficiency reasons and to + -- respect the semantics of the call: in most cases the original + -- call will pass the parameter by reference, and thus the inlined + -- code will have the same semantics. + + if Ekind (F) = E_In_Parameter + and then not Is_Limited_Type (Etype (A)) + and then not Is_Tagged_Type (Etype (A)) + and then + (not Is_Array_Type (Etype (A)) + or else not Is_Object_Reference (A) + or else Is_Bit_Packed_Array (Etype (A))) + then + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Temp_Typ, Loc), + Expression => New_A); + else + Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Temp, + Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc), + Name => New_A); + end if; + + Append (Decl, Decls); + Set_Renamed_Object (F, Temp); + end if; + + Next_Formal (F); + Next_Actual (A); + end loop; + + -- Establish target of function call. If context is not assignment or + -- declaration, create a temporary as a target. The declaration for + -- the temporary may be subsequently optimized away if the body is a + -- single expression, or if the left-hand side of the assignment is + -- simple enough, i.e. an entity or an explicit dereference of one. + + if Ekind (Subp) = E_Function then + if Nkind (Parent (N)) = N_Assignment_Statement + and then Is_Entity_Name (Name (Parent (N))) + then + Targ := Name (Parent (N)); + + elsif Nkind (Parent (N)) = N_Assignment_Statement + and then Nkind (Name (Parent (N))) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Name (Parent (N)))) + then + Targ := Name (Parent (N)); + + elsif Nkind (Parent (N)) = N_Object_Declaration + and then Is_Limited_Type (Etype (Subp)) + then + Targ := Defining_Identifier (Parent (N)); + + else + -- Replace call with temporary and create its declaration + + Temp := Make_Temporary (Loc, 'C'); + Set_Is_Internal (Temp); + + -- For the unconstrained case, the generated temporary has the + -- same constrained declaration as the result variable. It may + -- eventually be possible to remove that temporary and use the + -- result variable directly. + + if Is_Unc then + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => + New_Copy_Tree (Object_Definition (Parent (Targ1)))); + + Replace_Formals (Decl); + + else + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => + New_Occurrence_Of (Ret_Type, Loc)); + + Set_Etype (Temp, Ret_Type); + end if; + + Set_No_Initialization (Decl); + Append (Decl, Decls); + Rewrite (N, New_Occurrence_Of (Temp, Loc)); + Targ := Temp; + end if; + end if; + + Insert_Actions (N, Decls); + + -- Traverse the tree and replace formals with actuals or their thunks. + -- Attach block to tree before analysis and rewriting. + + Replace_Formals (Blk); + Set_Parent (Blk, N); + + if not Comes_From_Source (Subp) + or else Is_Predef + then + Reset_Slocs (Blk); + end if; + + if Present (Exit_Lab) then + + -- If the body was a single expression, the single return statement + -- and the corresponding label are useless. + + if Num_Ret = 1 + and then + Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) = + N_Goto_Statement + then + Remove (Last (Statements (Handled_Statement_Sequence (Blk)))); + else + Append (Lab_Decl, (Declarations (Blk))); + Append (Exit_Lab, Statements (Handled_Statement_Sequence (Blk))); + end if; + end if; + + -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on + -- conflicting private views that Gigi would ignore. If this is a + -- predefined unit, analyze with checks off, as is done in the non- + -- inlined run-time units. + + declare + I_Flag : constant Boolean := In_Inlined_Body; + + begin + In_Inlined_Body := True; + + if Is_Predef then + declare + Style : constant Boolean := Style_Check; + begin + Style_Check := False; + Analyze (Blk, Suppress => All_Checks); + Style_Check := Style; + end; + + else + Analyze (Blk); + end if; + + In_Inlined_Body := I_Flag; + end; + + if Ekind (Subp) = E_Procedure then + Rewrite_Procedure_Call (N, Blk); + else + Rewrite_Function_Call (N, Blk); + + -- For the unconstrained case, the replacement of the call has been + -- made prior to the complete analysis of the generated declarations. + -- Propagate the proper type now. + + if Is_Unc then + if Nkind (N) = N_Identifier then + Set_Etype (N, Etype (Entity (N))); + else + Set_Etype (N, Etype (Targ1)); + end if; + end if; + end if; + + Restore_Env; + + -- Cleanup mapping between formals and actuals for other expansions + + F := First_Formal (Subp); + while Present (F) loop + Set_Renamed_Object (F, Empty); + Next_Formal (F); + end loop; + end Expand_Inlined_Call; + + ---------------------------------------- + -- Expand_N_Extended_Return_Statement -- + ---------------------------------------- + + -- If there is a Handled_Statement_Sequence, we rewrite this: + + -- return Result : T := do + -- + -- end return; + + -- to be: + + -- declare + -- Result : T := ; + -- begin + -- + -- return Result; + -- end; + + -- Otherwise (no Handled_Statement_Sequence), we rewrite this: + + -- return Result : T := ; + + -- to be: + + -- return ; + + -- unless it's build-in-place or there's no , in which case + -- we generate: + + -- declare + -- Result : T := ; + -- begin + -- return Result; + -- end; + + -- Note that this case could have been written by the user as an extended + -- return statement, or could have been transformed to this from a simple + -- return statement. + + -- That is, we need to have a reified return object if there are statements + -- (which might refer to it) or if we're doing build-in-place (so we can + -- set its address to the final resting place or if there is no expression + -- (in which case default initial values might need to be set). + + procedure Expand_N_Extended_Return_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Return_Object_Entity : constant Entity_Id := + First_Entity (Return_Statement_Entity (N)); + Return_Object_Decl : constant Node_Id := + Parent (Return_Object_Entity); + Parent_Function : constant Entity_Id := + Return_Applies_To (Return_Statement_Entity (N)); + Parent_Function_Typ : constant Entity_Id := Etype (Parent_Function); + Is_Build_In_Place : constant Boolean := + Is_Build_In_Place_Function (Parent_Function); + + Return_Stm : Node_Id; + Statements : List_Id; + Handled_Stm_Seq : Node_Id; + Result : Node_Id; + Exp : Node_Id; + + function Has_Controlled_Parts (Typ : Entity_Id) return Boolean; + -- Determine whether type Typ is controlled or contains a controlled + -- subcomponent. + + function Move_Activation_Chain return Node_Id; + -- Construct a call to System.Tasking.Stages.Move_Activation_Chain + -- with parameters: + -- From current activation chain + -- To activation chain passed in by the caller + -- New_Master master passed in by the caller + + function Move_Final_List return Node_Id; + -- Construct call to System.Finalization_Implementation.Move_Final_List + -- with parameters: + -- + -- From finalization list of the return statement + -- To finalization list passed in by the caller + + -------------------------- + -- Has_Controlled_Parts -- + -------------------------- + + function Has_Controlled_Parts (Typ : Entity_Id) return Boolean is + begin + return + Is_Controlled (Typ) + or else Has_Controlled_Component (Typ); + end Has_Controlled_Parts; + + --------------------------- + -- Move_Activation_Chain -- + --------------------------- + + function Move_Activation_Chain return Node_Id is + Activation_Chain_Formal : constant Entity_Id := + Build_In_Place_Formal + (Parent_Function, BIP_Activation_Chain); + To : constant Node_Id := + New_Reference_To + (Activation_Chain_Formal, Loc); + Master_Formal : constant Entity_Id := + Build_In_Place_Formal + (Parent_Function, BIP_Master); + New_Master : constant Node_Id := + New_Reference_To (Master_Formal, Loc); + + Chain_Entity : Entity_Id; + From : Node_Id; + + begin + Chain_Entity := First_Entity (Return_Statement_Entity (N)); + while Chars (Chain_Entity) /= Name_uChain loop + Chain_Entity := Next_Entity (Chain_Entity); + end loop; + + From := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Chain_Entity, Loc), + Attribute_Name => Name_Unrestricted_Access); + -- ??? Not clear why "Make_Identifier (Loc, Name_uChain)" doesn't + -- work, instead of "New_Reference_To (Chain_Entity, Loc)" above. + + return + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Move_Activation_Chain), Loc), + Parameter_Associations => New_List (From, To, New_Master)); + end Move_Activation_Chain; + + --------------------- + -- Move_Final_List -- + --------------------- + + function Move_Final_List return Node_Id is + Flist : constant Entity_Id := + Finalization_Chain_Entity (Return_Statement_Entity (N)); + + From : constant Node_Id := New_Reference_To (Flist, Loc); + + Caller_Final_List : constant Entity_Id := + Build_In_Place_Formal + (Parent_Function, BIP_Final_List); + + To : constant Node_Id := New_Reference_To (Caller_Final_List, Loc); + + begin + -- Catch cases where a finalization chain entity has not been + -- associated with the return statement entity. + + pragma Assert (Present (Flist)); + + -- Build required call + + return + Make_If_Statement (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Copy (From), + Right_Opnd => New_Node (N_Null, Loc)), + Then_Statements => + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Move_Final_List), Loc), + Parameter_Associations => New_List (From, To)))); + end Move_Final_List; + + -- Start of processing for Expand_N_Extended_Return_Statement + + begin + if Nkind (Return_Object_Decl) = N_Object_Declaration then + Exp := Expression (Return_Object_Decl); + else + Exp := Empty; + end if; + + Handled_Stm_Seq := Handled_Statement_Sequence (N); + + -- Build a simple_return_statement that returns the return object when + -- there is a statement sequence, or no expression, or the result will + -- be built in place. Note however that we currently do this for all + -- composite cases, even though nonlimited composite results are not yet + -- built in place (though we plan to do so eventually). + + if Present (Handled_Stm_Seq) + or else Is_Composite_Type (Etype (Parent_Function)) + or else No (Exp) + then + if No (Handled_Stm_Seq) then + Statements := New_List; + + -- If the extended return has a handled statement sequence, then wrap + -- it in a block and use the block as the first statement. + + else + Statements := + New_List (Make_Block_Statement (Loc, + Declarations => New_List, + Handled_Statement_Sequence => Handled_Stm_Seq)); + end if; + + -- If control gets past the above Statements, we have successfully + -- completed the return statement. If the result type has controlled + -- parts and the return is for a build-in-place function, then we + -- call Move_Final_List to transfer responsibility for finalization + -- of the return object to the caller. An alternative would be to + -- declare a Success flag in the function, initialize it to False, + -- and set it to True here. Then move the Move_Final_List call into + -- the cleanup code, and check Success. If Success then make a call + -- to Move_Final_List else do finalization. Then we can remove the + -- abort-deferral and the nulling-out of the From parameter from + -- Move_Final_List. Note that the current method is not quite correct + -- in the rather obscure case of a select-then-abort statement whose + -- abortable part contains the return statement. + + -- Check the type of the function to determine whether to move the + -- finalization list. A special case arises when processing a simple + -- return statement which has been rewritten as an extended return. + -- In that case check the type of the returned object or the original + -- expression. + + if Is_Build_In_Place + and then + (Has_Controlled_Parts (Parent_Function_Typ) + or else (Is_Class_Wide_Type (Parent_Function_Typ) + and then + Has_Controlled_Parts (Root_Type (Parent_Function_Typ))) + or else Has_Controlled_Parts (Etype (Return_Object_Entity)) + or else (Present (Exp) + and then Has_Controlled_Parts (Etype (Exp)))) + then + Append_To (Statements, Move_Final_List); + end if; + + -- Similarly to the above Move_Final_List, if the result type + -- contains tasks, we call Move_Activation_Chain. Later, the cleanup + -- code will call Complete_Master, which will terminate any + -- unactivated tasks belonging to the return statement master. But + -- Move_Activation_Chain updates their master to be that of the + -- caller, so they will not be terminated unless the return statement + -- completes unsuccessfully due to exception, abort, goto, or exit. + -- As a formality, we test whether the function requires the result + -- to be built in place, though that's necessarily true for the case + -- of result types with task parts. + + if Is_Build_In_Place and Has_Task (Etype (Parent_Function)) then + Append_To (Statements, Move_Activation_Chain); + end if; + + -- Build a simple_return_statement that returns the return object + + Return_Stm := + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Return_Object_Entity, Loc)); + Append_To (Statements, Return_Stm); + + Handled_Stm_Seq := + Make_Handled_Sequence_Of_Statements (Loc, Statements); + end if; + + -- Case where we build a block + + if Present (Handled_Stm_Seq) then + Result := + Make_Block_Statement (Loc, + Declarations => Return_Object_Declarations (N), + Handled_Statement_Sequence => Handled_Stm_Seq); + + -- We set the entity of the new block statement to be that of the + -- return statement. This is necessary so that various fields, such + -- as Finalization_Chain_Entity carry over from the return statement + -- to the block. Note that this block is unusual, in that its entity + -- is an E_Return_Statement rather than an E_Block. + + Set_Identifier + (Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc)); + + -- If the object decl was already rewritten as a renaming, then + -- we don't want to do the object allocation and transformation of + -- of the return object declaration to a renaming. This case occurs + -- when the return object is initialized by a call to another + -- build-in-place function, and that function is responsible for the + -- allocation of the return object. + + if Is_Build_In_Place + and then + Nkind (Return_Object_Decl) = N_Object_Renaming_Declaration + then + pragma Assert (Nkind (Original_Node (Return_Object_Decl)) = + N_Object_Declaration + and then Is_Build_In_Place_Function_Call + (Expression (Original_Node (Return_Object_Decl)))); + + Set_By_Ref (Return_Stm); -- Return build-in-place results by ref + + elsif Is_Build_In_Place then + + -- Locate the implicit access parameter associated with the + -- caller-supplied return object and convert the return + -- statement's return object declaration to a renaming of a + -- dereference of the access parameter. If the return object's + -- declaration includes an expression that has not already been + -- expanded as separate assignments, then add an assignment + -- statement to ensure the return object gets initialized. + + -- declare + -- Result : T [:= ]; + -- begin + -- ... + + -- is converted to + + -- declare + -- Result : T renames FuncRA.all; + -- [Result := New_Reference_To (Return_Obj_Id, Loc), + Expression => Relocate_Node (Return_Obj_Expr)); + Set_Etype (Name (Init_Assignment), Etype (Return_Obj_Id)); + Set_Assignment_OK (Name (Init_Assignment)); + Set_No_Ctrl_Actions (Init_Assignment); + + Set_Parent (Name (Init_Assignment), Init_Assignment); + Set_Parent (Expression (Init_Assignment), Init_Assignment); + + Set_Expression (Return_Object_Decl, Empty); + + if Is_Class_Wide_Type (Etype (Return_Obj_Id)) + and then not Is_Class_Wide_Type + (Etype (Expression (Init_Assignment))) + then + Rewrite (Expression (Init_Assignment), + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of + (Etype (Return_Obj_Id), Loc), + Expression => + Relocate_Node (Expression (Init_Assignment)))); + end if; + + -- In the case of functions where the calling context can + -- determine the form of allocation needed, initialization + -- is done with each part of the if statement that handles + -- the different forms of allocation (this is true for + -- unconstrained and tagged result subtypes). + + if Constr_Result + and then not Is_Tagged_Type (Underlying_Type (Result_Subt)) + then + Insert_After (Return_Object_Decl, Init_Assignment); + end if; + end if; + + -- When the function's subtype is unconstrained, a run-time + -- test is needed to determine the form of allocation to use + -- for the return object. The function has an implicit formal + -- parameter indicating this. If the BIP_Alloc_Form formal has + -- the value one, then the caller has passed access to an + -- existing object for use as the return object. If the value + -- is two, then the return object must be allocated on the + -- secondary stack. Otherwise, the object must be allocated in + -- a storage pool (currently only supported for the global + -- heap, user-defined storage pools TBD ???). We generate an + -- if statement to test the implicit allocation formal and + -- initialize a local access value appropriately, creating + -- allocators in the secondary stack and global heap cases. + -- The special formal also exists and must be tested when the + -- function has a tagged result, even when the result subtype + -- is constrained, because in general such functions can be + -- called in dispatching contexts and must be handled similarly + -- to functions with a class-wide result. + + if not Constr_Result + or else Is_Tagged_Type (Underlying_Type (Result_Subt)) + then + Obj_Alloc_Formal := + Build_In_Place_Formal (Parent_Function, BIP_Alloc_Form); + + declare + Ref_Type : Entity_Id; + Ptr_Type_Decl : Node_Id; + Alloc_Obj_Id : Entity_Id; + Alloc_Obj_Decl : Node_Id; + Alloc_If_Stmt : Node_Id; + SS_Allocator : Node_Id; + Heap_Allocator : Node_Id; + + begin + -- Reuse the itype created for the function's implicit + -- access formal. This avoids the need to create a new + -- access type here, plus it allows assigning the access + -- formal directly without applying a conversion. + + -- Ref_Type := Etype (Object_Access); + + -- Create an access type designating the function's + -- result subtype. + + Ref_Type := Make_Temporary (Loc, 'A'); + + Ptr_Type_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ref_Type, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Reference_To (Return_Obj_Typ, Loc))); + + Insert_Before (Return_Object_Decl, Ptr_Type_Decl); + + -- Create an access object that will be initialized to an + -- access value denoting the return object, either coming + -- from an implicit access value passed in by the caller + -- or from the result of an allocator. + + Alloc_Obj_Id := Make_Temporary (Loc, 'R'); + Set_Etype (Alloc_Obj_Id, Ref_Type); + + Alloc_Obj_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Alloc_Obj_Id, + Object_Definition => New_Reference_To + (Ref_Type, Loc)); + + Insert_Before (Return_Object_Decl, Alloc_Obj_Decl); + + -- Create allocators for both the secondary stack and + -- global heap. If there's an initialization expression, + -- then create these as initialized allocators. + + if Present (Return_Obj_Expr) + and then not No_Initialization (Return_Object_Decl) + then + -- Always use the type of the expression for the + -- qualified expression, rather than the result type. + -- In general we cannot always use the result type + -- for the allocator, because the expression might be + -- of a specific type, such as in the case of an + -- aggregate or even a nonlimited object when the + -- result type is a limited class-wide interface type. + + Heap_Allocator := + Make_Allocator (Loc, + Expression => + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Reference_To + (Etype (Return_Obj_Expr), Loc), + Expression => + New_Copy_Tree (Return_Obj_Expr))); + + else + -- If the function returns a class-wide type we cannot + -- use the return type for the allocator. Instead we + -- use the type of the expression, which must be an + -- aggregate of a definite type. + + if Is_Class_Wide_Type (Return_Obj_Typ) then + Heap_Allocator := + Make_Allocator (Loc, + Expression => + New_Reference_To + (Etype (Return_Obj_Expr), Loc)); + else + Heap_Allocator := + Make_Allocator (Loc, + Expression => + New_Reference_To (Return_Obj_Typ, Loc)); + end if; + + -- If the object requires default initialization then + -- that will happen later following the elaboration of + -- the object renaming. If we don't turn it off here + -- then the object will be default initialized twice. + + Set_No_Initialization (Heap_Allocator); + end if; + + -- If the No_Allocators restriction is active, then only + -- an allocator for secondary stack allocation is needed. + -- It's OK for such allocators to have Comes_From_Source + -- set to False, because gigi knows not to flag them as + -- being a violation of No_Implicit_Heap_Allocations. + + if Restriction_Active (No_Allocators) then + SS_Allocator := Heap_Allocator; + Heap_Allocator := Make_Null (Loc); + + -- Otherwise the heap allocator may be needed, so we make + -- another allocator for secondary stack allocation. + + else + SS_Allocator := New_Copy_Tree (Heap_Allocator); + + -- The heap allocator is marked Comes_From_Source + -- since it corresponds to an explicit user-written + -- allocator (that is, it will only be executed on + -- behalf of callers that call the function as + -- initialization for such an allocator). This + -- prevents errors when No_Implicit_Heap_Allocations + -- is in force. + + Set_Comes_From_Source (Heap_Allocator, True); + end if; + + -- The allocator is returned on the secondary stack. We + -- don't do this on VM targets, since the SS is not used. + + if VM_Target = No_VM then + Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool)); + Set_Procedure_To_Call + (SS_Allocator, RTE (RE_SS_Allocate)); + + -- The allocator is returned on the secondary stack, + -- so indicate that the function return, as well as + -- the block that encloses the allocator, must not + -- release it. The flags must be set now because the + -- decision to use the secondary stack is done very + -- late in the course of expanding the return + -- statement, past the point where these flags are + -- normally set. + + Set_Sec_Stack_Needed_For_Return (Parent_Function); + Set_Sec_Stack_Needed_For_Return + (Return_Statement_Entity (N)); + Set_Uses_Sec_Stack (Parent_Function); + Set_Uses_Sec_Stack (Return_Statement_Entity (N)); + end if; + + -- Create an if statement to test the BIP_Alloc_Form + -- formal and initialize the access object to either the + -- BIP_Object_Access formal (BIP_Alloc_Form = 0), the + -- result of allocating the object in the secondary stack + -- (BIP_Alloc_Form = 1), or else an allocator to create + -- the return object in the heap (BIP_Alloc_Form = 2). + + -- ??? An unchecked type conversion must be made in the + -- case of assigning the access object formal to the + -- local access object, because a normal conversion would + -- be illegal in some cases (such as converting access- + -- to-unconstrained to access-to-constrained), but the + -- the unchecked conversion will presumably fail to work + -- right in just such cases. It's not clear at all how to + -- handle this. ??? + + Alloc_If_Stmt := + Make_If_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (Obj_Alloc_Formal, Loc), + Right_Opnd => + Make_Integer_Literal (Loc, + UI_From_Int (BIP_Allocation_Form'Pos + (Caller_Allocation)))), + Then_Statements => + New_List (Make_Assignment_Statement (Loc, + Name => + New_Reference_To + (Alloc_Obj_Id, Loc), + Expression => + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Reference_To (Ref_Type, Loc), + Expression => + New_Reference_To + (Object_Access, Loc)))), + Elsif_Parts => + New_List (Make_Elsif_Part (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To + (Obj_Alloc_Formal, Loc), + Right_Opnd => + Make_Integer_Literal (Loc, + UI_From_Int ( + BIP_Allocation_Form'Pos + (Secondary_Stack)))), + Then_Statements => + New_List + (Make_Assignment_Statement (Loc, + Name => + New_Reference_To + (Alloc_Obj_Id, Loc), + Expression => + SS_Allocator)))), + Else_Statements => + New_List (Make_Assignment_Statement (Loc, + Name => + New_Reference_To + (Alloc_Obj_Id, Loc), + Expression => + Heap_Allocator))); + + -- If a separate initialization assignment was created + -- earlier, append that following the assignment of the + -- implicit access formal to the access object, to ensure + -- that the return object is initialized in that case. + -- In this situation, the target of the assignment must + -- be rewritten to denote a dereference of the access to + -- the return object passed in by the caller. + + if Present (Init_Assignment) then + Rewrite (Name (Init_Assignment), + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Alloc_Obj_Id, Loc))); + Set_Etype + (Name (Init_Assignment), Etype (Return_Obj_Id)); + + Append_To + (Then_Statements (Alloc_If_Stmt), + Init_Assignment); + end if; + + Insert_Before (Return_Object_Decl, Alloc_If_Stmt); + + -- Remember the local access object for use in the + -- dereference of the renaming created below. + + Object_Access := Alloc_Obj_Id; + end; + end if; + + -- Replace the return object declaration with a renaming of a + -- dereference of the access value designating the return + -- object. + + Obj_Acc_Deref := + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Object_Access, Loc)); + + Rewrite (Return_Object_Decl, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Return_Obj_Id, + Access_Definition => Empty, + Subtype_Mark => New_Occurrence_Of + (Return_Obj_Typ, Loc), + Name => Obj_Acc_Deref)); + + Set_Renamed_Object (Return_Obj_Id, Obj_Acc_Deref); + end; + end if; + + -- Case where we do not build a block + + else + -- We're about to drop Return_Object_Declarations on the floor, so + -- we need to insert it, in case it got expanded into useful code. + -- Remove side effects from expression, which may be duplicated in + -- subsequent checks (see Expand_Simple_Function_Return). + + Insert_List_Before (N, Return_Object_Declarations (N)); + Remove_Side_Effects (Exp); + + -- Build simple_return_statement that returns the expression directly + + Return_Stm := Make_Simple_Return_Statement (Loc, Expression => Exp); + + Result := Return_Stm; + end if; + + -- Set the flag to prevent infinite recursion + + Set_Comes_From_Extended_Return_Statement (Return_Stm); + + Rewrite (N, Result); + Analyze (N); + end Expand_N_Extended_Return_Statement; + + ---------------------------- + -- Expand_N_Function_Call -- + ---------------------------- + + procedure Expand_N_Function_Call (N : Node_Id) is + begin + Expand_Call (N); + + -- If the return value of a foreign compiled function is VAX Float, then + -- expand the return (adjusts the location of the return value on + -- Alpha/VMS, no-op everywhere else). + -- Comes_From_Source intercepts recursive expansion. + + if Vax_Float (Etype (N)) + and then Nkind (N) = N_Function_Call + and then Present (Name (N)) + and then Present (Entity (Name (N))) + and then Has_Foreign_Convention (Entity (Name (N))) + and then Comes_From_Source (Parent (N)) + then + Expand_Vax_Foreign_Return (N); + end if; + end Expand_N_Function_Call; + + --------------------------------------- + -- Expand_N_Procedure_Call_Statement -- + --------------------------------------- + + procedure Expand_N_Procedure_Call_Statement (N : Node_Id) is + begin + Expand_Call (N); + end Expand_N_Procedure_Call_Statement; + + -------------------------------------- + -- Expand_N_Simple_Return_Statement -- + -------------------------------------- + + procedure Expand_N_Simple_Return_Statement (N : Node_Id) is + begin + -- Defend against previous errors (i.e. the return statement calls a + -- function that is not available in configurable runtime). + + if Present (Expression (N)) + and then Nkind (Expression (N)) = N_Empty + then + return; + end if; + + -- Distinguish the function and non-function cases: + + case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is + + when E_Function | + E_Generic_Function => + Expand_Simple_Function_Return (N); + + when E_Procedure | + E_Generic_Procedure | + E_Entry | + E_Entry_Family | + E_Return_Statement => + Expand_Non_Function_Return (N); + + when others => + raise Program_Error; + end case; + + exception + when RE_Not_Available => + return; + end Expand_N_Simple_Return_Statement; + + ------------------------------ + -- Expand_N_Subprogram_Body -- + ------------------------------ + + -- Add poll call if ATC polling is enabled, unless the body will be inlined + -- by the back-end. + + -- Add dummy push/pop label nodes at start and end to clear any local + -- exception indications if local-exception-to-goto optimization is active. + + -- Add return statement if last statement in body is not a return statement + -- (this makes things easier on Gigi which does not want to have to handle + -- a missing return). + + -- Add call to Activate_Tasks if body is a task activator + + -- Deal with possible detection of infinite recursion + + -- Eliminate body completely if convention stubbed + + -- Encode entity names within body, since we will not need to reference + -- these entities any longer in the front end. + + -- Initialize scalar out parameters if Initialize/Normalize_Scalars + + -- Reset Pure indication if any parameter has root type System.Address + -- or has any parameters of limited types, where limited means that the + -- run-time view is limited (i.e. the full type is limited). + + -- Wrap thread body + + procedure Expand_N_Subprogram_Body (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + H : constant Node_Id := Handled_Statement_Sequence (N); + Body_Id : Entity_Id; + Except_H : Node_Id; + L : List_Id; + Spec_Id : Entity_Id; + + procedure Add_Return (S : List_Id); + -- Append a return statement to the statement sequence S if the last + -- statement is not already a return or a goto statement. Note that + -- the latter test is not critical, it does not matter if we add a few + -- extra returns, since they get eliminated anyway later on. + + ---------------- + -- Add_Return -- + ---------------- + + procedure Add_Return (S : List_Id) is + Last_Stm : Node_Id; + Loc : Source_Ptr; + + begin + -- Get last statement, ignoring any Pop_xxx_Label nodes, which are + -- not relevant in this context since they are not executable. + + Last_Stm := Last (S); + while Nkind (Last_Stm) in N_Pop_xxx_Label loop + Prev (Last_Stm); + end loop; + + -- Now insert return unless last statement is a transfer + + if not Is_Transfer (Last_Stm) then + + -- The source location for the return is the end label of the + -- procedure if present. Otherwise use the sloc of the last + -- statement in the list. If the list comes from a generated + -- exception handler and we are not debugging generated code, + -- all the statements within the handler are made invisible + -- to the debugger. + + if Nkind (Parent (S)) = N_Exception_Handler + and then not Comes_From_Source (Parent (S)) + then + Loc := Sloc (Last_Stm); + + elsif Present (End_Label (H)) then + Loc := Sloc (End_Label (H)); + + else + Loc := Sloc (Last_Stm); + end if; + + declare + Rtn : constant Node_Id := Make_Simple_Return_Statement (Loc); + + begin + -- Append return statement, and set analyzed manually. We can't + -- call Analyze on this return since the scope is wrong. + + -- Note: it almost works to push the scope and then do the + -- Analyze call, but something goes wrong in some weird cases + -- and it is not worth worrying about ??? + + Append_To (S, Rtn); + Set_Analyzed (Rtn); + + -- Call _Postconditions procedure if appropriate. We need to + -- do this explicitly because we did not analyze the generated + -- return statement above, so the call did not get inserted. + + if Ekind (Spec_Id) = E_Procedure + and then Has_Postconditions (Spec_Id) + then + pragma Assert (Present (Postcondition_Proc (Spec_Id))); + Insert_Action (Rtn, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (Postcondition_Proc (Spec_Id), Loc))); + end if; + end; + end if; + end Add_Return; + + -- Start of processing for Expand_N_Subprogram_Body + + begin + -- Set L to either the list of declarations if present, or to the list + -- of statements if no declarations are present. This is used to insert + -- new stuff at the start. + + if Is_Non_Empty_List (Declarations (N)) then + L := Declarations (N); + else + L := Statements (H); + end if; + + -- If local-exception-to-goto optimization active, insert dummy push + -- statements at start, and dummy pop statements at end. + + if (Debug_Flag_Dot_G + or else Restriction_Active (No_Exception_Propagation)) + and then Is_Non_Empty_List (L) + then + declare + FS : constant Node_Id := First (L); + FL : constant Source_Ptr := Sloc (FS); + LS : Node_Id; + LL : Source_Ptr; + + begin + -- LS points to either last statement, if statements are present + -- or to the last declaration if there are no statements present. + -- It is the node after which the pop's are generated. + + if Is_Non_Empty_List (Statements (H)) then + LS := Last (Statements (H)); + else + LS := Last (L); + end if; + + LL := Sloc (LS); + + Insert_List_Before_And_Analyze (FS, New_List ( + Make_Push_Constraint_Error_Label (FL), + Make_Push_Program_Error_Label (FL), + Make_Push_Storage_Error_Label (FL))); + + Insert_List_After_And_Analyze (LS, New_List ( + Make_Pop_Constraint_Error_Label (LL), + Make_Pop_Program_Error_Label (LL), + Make_Pop_Storage_Error_Label (LL))); + end; + end if; + + -- Find entity for subprogram + + Body_Id := Defining_Entity (N); + + if Present (Corresponding_Spec (N)) then + Spec_Id := Corresponding_Spec (N); + else + Spec_Id := Body_Id; + end if; + + -- Need poll on entry to subprogram if polling enabled. We only do this + -- for non-empty subprograms, since it does not seem necessary to poll + -- for a dummy null subprogram. + + if Is_Non_Empty_List (L) then + + -- Do not add a polling call if the subprogram is to be inlined by + -- the back-end, to avoid repeated calls with multiple inlinings. + + if Is_Inlined (Spec_Id) + and then Front_End_Inlining + and then Optimization_Level > 1 + then + null; + else + Generate_Poll_Call (First (L)); + end if; + end if; + + -- If this is a Pure function which has any parameters whose root type + -- is System.Address, reset the Pure indication, since it will likely + -- cause incorrect code to be generated as the parameter is probably + -- a pointer, and the fact that the same pointer is passed does not mean + -- that the same value is being referenced. + + -- Note that if the programmer gave an explicit Pure_Function pragma, + -- then we believe the programmer, and leave the subprogram Pure. + + -- This code should probably be at the freeze point, so that it happens + -- even on a -gnatc (or more importantly -gnatt) compile, so that the + -- semantic tree has Is_Pure set properly ??? + + if Is_Pure (Spec_Id) + and then Is_Subprogram (Spec_Id) + and then not Has_Pragma_Pure_Function (Spec_Id) + then + declare + F : Entity_Id; + + begin + F := First_Formal (Spec_Id); + while Present (F) loop + if Is_Descendent_Of_Address (Etype (F)) + + -- Note that this test is being made in the body of the + -- subprogram, not the spec, so we are testing the full + -- type for being limited here, as required. + + or else Is_Limited_Type (Etype (F)) + then + Set_Is_Pure (Spec_Id, False); + + if Spec_Id /= Body_Id then + Set_Is_Pure (Body_Id, False); + end if; + + exit; + end if; + + Next_Formal (F); + end loop; + end; + end if; + + -- Initialize any scalar OUT args if Initialize/Normalize_Scalars + + if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then + declare + F : Entity_Id; + + begin + -- Loop through formals + + F := First_Formal (Spec_Id); + while Present (F) loop + if Is_Scalar_Type (Etype (F)) + and then Ekind (F) = E_Out_Parameter + then + Check_Restriction (No_Default_Initialization, F); + + -- Insert the initialization. We turn off validity checks + -- for this assignment, since we do not want any check on + -- the initial value itself (which may well be invalid). + + Insert_Before_And_Analyze (First (L), + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (F, Loc), + Expression => Get_Simple_Init_Val (Etype (F), N)), + Suppress => Validity_Check); + end if; + + Next_Formal (F); + end loop; + end; + end if; + + -- Clear out statement list for stubbed procedure + + if Present (Corresponding_Spec (N)) then + Set_Elaboration_Flag (N, Spec_Id); + + if Convention (Spec_Id) = Convention_Stubbed + or else Is_Eliminated (Spec_Id) + then + Set_Declarations (N, Empty_List); + Set_Handled_Statement_Sequence (N, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Null_Statement (Loc)))); + return; + end if; + end if; + + -- Create a set of discriminals for the next protected subprogram body + + if Is_List_Member (N) + and then Present (Parent (List_Containing (N))) + and then Nkind (Parent (List_Containing (N))) = N_Protected_Body + and then Present (Next_Protected_Operation (N)) + then + Set_Discriminals (Parent (Base_Type (Scope (Spec_Id)))); + end if; + + -- Returns_By_Ref flag is normally set when the subprogram is frozen but + -- subprograms with no specs are not frozen. + + declare + Typ : constant Entity_Id := Etype (Spec_Id); + Utyp : constant Entity_Id := Underlying_Type (Typ); + + begin + if not Acts_As_Spec (N) + and then Nkind (Parent (Parent (Spec_Id))) /= + N_Subprogram_Body_Stub + then + null; + + elsif Is_Immutably_Limited_Type (Typ) then + Set_Returns_By_Ref (Spec_Id); + + elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then + Set_Returns_By_Ref (Spec_Id); + end if; + end; + + -- For a procedure, we add a return for all possible syntactic ends of + -- the subprogram. + + if Ekind_In (Spec_Id, E_Procedure, E_Generic_Procedure) then + Add_Return (Statements (H)); + + if Present (Exception_Handlers (H)) then + Except_H := First_Non_Pragma (Exception_Handlers (H)); + while Present (Except_H) loop + Add_Return (Statements (Except_H)); + Next_Non_Pragma (Except_H); + end loop; + end if; + + -- For a function, we must deal with the case where there is at least + -- one missing return. What we do is to wrap the entire body of the + -- function in a block: + + -- begin + -- ... + -- end; + + -- becomes + + -- begin + -- begin + -- ... + -- end; + + -- raise Program_Error; + -- end; + + -- This approach is necessary because the raise must be signalled to the + -- caller, not handled by any local handler (RM 6.4(11)). + + -- Note: we do not need to analyze the constructed sequence here, since + -- it has no handler, and an attempt to analyze the handled statement + -- sequence twice is risky in various ways (e.g. the issue of expanding + -- cleanup actions twice). + + elsif Has_Missing_Return (Spec_Id) then + declare + Hloc : constant Source_Ptr := Sloc (H); + Blok : constant Node_Id := + Make_Block_Statement (Hloc, + Handled_Statement_Sequence => H); + Rais : constant Node_Id := + Make_Raise_Program_Error (Hloc, + Reason => PE_Missing_Return); + + begin + Set_Handled_Statement_Sequence (N, + Make_Handled_Sequence_Of_Statements (Hloc, + Statements => New_List (Blok, Rais))); + + Push_Scope (Spec_Id); + Analyze (Blok); + Analyze (Rais); + Pop_Scope; + end; + end if; + + -- If subprogram contains a parameterless recursive call, then we may + -- have an infinite recursion, so see if we can generate code to check + -- for this possibility if storage checks are not suppressed. + + if Ekind (Spec_Id) = E_Procedure + and then Has_Recursive_Call (Spec_Id) + and then not Storage_Checks_Suppressed (Spec_Id) + then + Detect_Infinite_Recursion (N, Spec_Id); + end if; + + -- Set to encode entity names in package body before gigi is called + + Qualify_Entity_Names (N); + end Expand_N_Subprogram_Body; + + ----------------------------------- + -- Expand_N_Subprogram_Body_Stub -- + ----------------------------------- + + procedure Expand_N_Subprogram_Body_Stub (N : Node_Id) is + begin + if Present (Corresponding_Body (N)) then + Expand_N_Subprogram_Body ( + Unit_Declaration_Node (Corresponding_Body (N))); + end if; + end Expand_N_Subprogram_Body_Stub; + + ------------------------------------- + -- Expand_N_Subprogram_Declaration -- + ------------------------------------- + + -- If the declaration appears within a protected body, it is a private + -- operation of the protected type. We must create the corresponding + -- protected subprogram an associated formals. For a normal protected + -- operation, this is done when expanding the protected type declaration. + + -- If the declaration is for a null procedure, emit null body + + procedure Expand_N_Subprogram_Declaration (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Subp : constant Entity_Id := Defining_Entity (N); + Scop : constant Entity_Id := Scope (Subp); + Prot_Decl : Node_Id; + Prot_Bod : Node_Id; + Prot_Id : Entity_Id; + + begin + -- Deal with case of protected subprogram. Do not generate protected + -- operation if operation is flagged as eliminated. + + if Is_List_Member (N) + and then Present (Parent (List_Containing (N))) + and then Nkind (Parent (List_Containing (N))) = N_Protected_Body + and then Is_Protected_Type (Scop) + then + if No (Protected_Body_Subprogram (Subp)) + and then not Is_Eliminated (Subp) + then + Prot_Decl := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Protected_Sub_Specification + (N, Scop, Unprotected_Mode)); + + -- The protected subprogram is declared outside of the protected + -- body. Given that the body has frozen all entities so far, we + -- analyze the subprogram and perform freezing actions explicitly. + -- including the generation of an explicit freeze node, to ensure + -- that gigi has the proper order of elaboration. + -- If the body is a subunit, the insertion point is before the + -- stub in the parent. + + Prot_Bod := Parent (List_Containing (N)); + + if Nkind (Parent (Prot_Bod)) = N_Subunit then + Prot_Bod := Corresponding_Stub (Parent (Prot_Bod)); + end if; + + Insert_Before (Prot_Bod, Prot_Decl); + Prot_Id := Defining_Unit_Name (Specification (Prot_Decl)); + Set_Has_Delayed_Freeze (Prot_Id); + + Push_Scope (Scope (Scop)); + Analyze (Prot_Decl); + Freeze_Before (N, Prot_Id); + Set_Protected_Body_Subprogram (Subp, Prot_Id); + + -- Create protected operation as well. Even though the operation + -- is only accessible within the body, it is possible to make it + -- available outside of the protected object by using 'Access to + -- provide a callback, so build protected version in all cases. + + Prot_Decl := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Protected_Sub_Specification (N, Scop, Protected_Mode)); + Insert_Before (Prot_Bod, Prot_Decl); + Analyze (Prot_Decl); + + Pop_Scope; + end if; + + -- Ada 2005 (AI-348): Generate body for a null procedure. + -- In most cases this is superfluous because calls to it + -- will be automatically inlined, but we definitely need + -- the body if preconditions for the procedure are present. + + elsif Nkind (Specification (N)) = N_Procedure_Specification + and then Null_Present (Specification (N)) + then + declare + Bod : constant Node_Id := Body_To_Inline (N); + + begin + Set_Has_Completion (Subp, False); + Append_Freeze_Action (Subp, Bod); + + -- The body now contains raise statements, so calls to it will + -- not be inlined. + + Set_Is_Inlined (Subp, False); + end; + end if; + end Expand_N_Subprogram_Declaration; + + -------------------------------- + -- Expand_Non_Function_Return -- + -------------------------------- + + procedure Expand_Non_Function_Return (N : Node_Id) is + pragma Assert (No (Expression (N))); + + Loc : constant Source_Ptr := Sloc (N); + Scope_Id : Entity_Id := + Return_Applies_To (Return_Statement_Entity (N)); + Kind : constant Entity_Kind := Ekind (Scope_Id); + Call : Node_Id; + Acc_Stat : Node_Id; + Goto_Stat : Node_Id; + Lab_Node : Node_Id; + + begin + -- Call _Postconditions procedure if procedure with active + -- postconditions. Here, we use the Postcondition_Proc attribute, which + -- is needed for implicitly-generated returns. Functions never + -- have implicitly-generated returns, and there's no room for + -- Postcondition_Proc in E_Function, so we look up the identifier + -- Name_uPostconditions for function returns (see + -- Expand_Simple_Function_Return). + + if Ekind (Scope_Id) = E_Procedure + and then Has_Postconditions (Scope_Id) + then + pragma Assert (Present (Postcondition_Proc (Scope_Id))); + Insert_Action (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Postcondition_Proc (Scope_Id), Loc))); + end if; + + -- If it is a return from a procedure do no extra steps + + if Kind = E_Procedure or else Kind = E_Generic_Procedure then + return; + + -- If it is a nested return within an extended one, replace it with a + -- return of the previously declared return object. + + elsif Kind = E_Return_Statement then + Rewrite (N, + Make_Simple_Return_Statement (Loc, + Expression => + New_Occurrence_Of (First_Entity (Scope_Id), Loc))); + Set_Comes_From_Extended_Return_Statement (N); + Set_Return_Statement_Entity (N, Scope_Id); + Expand_Simple_Function_Return (N); + return; + end if; + + pragma Assert (Is_Entry (Scope_Id)); + + -- Look at the enclosing block to see whether the return is from an + -- accept statement or an entry body. + + for J in reverse 0 .. Scope_Stack.Last loop + Scope_Id := Scope_Stack.Table (J).Entity; + exit when Is_Concurrent_Type (Scope_Id); + end loop; + + -- If it is a return from accept statement it is expanded as call to + -- RTS Complete_Rendezvous and a goto to the end of the accept body. + + -- (cf : Expand_N_Accept_Statement, Expand_N_Selective_Accept, + -- Expand_N_Accept_Alternative in exp_ch9.adb) + + if Is_Task_Type (Scope_Id) then + + Call := + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Complete_Rendezvous), Loc)); + Insert_Before (N, Call); + -- why not insert actions here??? + Analyze (Call); + + Acc_Stat := Parent (N); + while Nkind (Acc_Stat) /= N_Accept_Statement loop + Acc_Stat := Parent (Acc_Stat); + end loop; + + Lab_Node := Last (Statements + (Handled_Statement_Sequence (Acc_Stat))); + + Goto_Stat := Make_Goto_Statement (Loc, + Name => New_Occurrence_Of + (Entity (Identifier (Lab_Node)), Loc)); + + Set_Analyzed (Goto_Stat); + + Rewrite (N, Goto_Stat); + Analyze (N); + + -- If it is a return from an entry body, put a Complete_Entry_Body call + -- in front of the return. + + elsif Is_Protected_Type (Scope_Id) then + Call := + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Complete_Entry_Body), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To + (Find_Protection_Object (Current_Scope), Loc), + Attribute_Name => + Name_Unchecked_Access))); + + Insert_Before (N, Call); + Analyze (Call); + end if; + end Expand_Non_Function_Return; + + --------------------------------------- + -- Expand_Protected_Object_Reference -- + --------------------------------------- + + function Expand_Protected_Object_Reference + (N : Node_Id; + Scop : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Corr : Entity_Id; + Rec : Node_Id; + Param : Entity_Id; + Proc : Entity_Id; + + begin + Rec := Make_Identifier (Loc, Name_uObject); + Set_Etype (Rec, Corresponding_Record_Type (Scop)); + + -- Find enclosing protected operation, and retrieve its first parameter, + -- which denotes the enclosing protected object. If the enclosing + -- operation is an entry, we are immediately within the protected body, + -- and we can retrieve the object from the service entries procedure. A + -- barrier function has the same signature as an entry. A barrier + -- function is compiled within the protected object, but unlike + -- protected operations its never needs locks, so that its protected + -- body subprogram points to itself. + + Proc := Current_Scope; + while Present (Proc) + and then Scope (Proc) /= Scop + loop + Proc := Scope (Proc); + end loop; + + Corr := Protected_Body_Subprogram (Proc); + + if No (Corr) then + + -- Previous error left expansion incomplete. + -- Nothing to do on this call. + + return Empty; + end if; + + Param := + Defining_Identifier + (First (Parameter_Specifications (Parent (Corr)))); + + if Is_Subprogram (Proc) + and then Proc /= Corr + then + -- Protected function or procedure + + Set_Entity (Rec, Param); + + -- Rec is a reference to an entity which will not be in scope when + -- the call is reanalyzed, and needs no further analysis. + + Set_Analyzed (Rec); + + else + -- Entry or barrier function for entry body. The first parameter of + -- the entry body procedure is pointer to the object. We create a + -- local variable of the proper type, duplicating what is done to + -- define _object later on. + + declare + Decls : List_Id; + Obj_Ptr : constant Entity_Id := Make_Temporary (Loc, 'T'); + + begin + Decls := New_List ( + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Obj_Ptr, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Reference_To + (Corresponding_Record_Type (Scop), Loc)))); + + Insert_Actions (N, Decls); + Freeze_Before (N, Obj_Ptr); + + Rec := + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (Obj_Ptr, + New_Occurrence_Of (Param, Loc))); + + -- Analyze new actual. Other actuals in calls are already analyzed + -- and the list of actuals is not reanalyzed after rewriting. + + Set_Parent (Rec, N); + Analyze (Rec); + end; + end if; + + return Rec; + end Expand_Protected_Object_Reference; + + -------------------------------------- + -- Expand_Protected_Subprogram_Call -- + -------------------------------------- + + procedure Expand_Protected_Subprogram_Call + (N : Node_Id; + Subp : Entity_Id; + Scop : Entity_Id) + is + Rec : Node_Id; + + begin + -- If the protected object is not an enclosing scope, this is + -- an inter-object function call. Inter-object procedure + -- calls are expanded by Exp_Ch9.Build_Simple_Entry_Call. + -- The call is intra-object only if the subprogram being + -- called is in the protected body being compiled, and if the + -- protected object in the call is statically the enclosing type. + -- The object may be an component of some other data structure, + -- in which case this must be handled as an inter-object call. + + if not In_Open_Scopes (Scop) + or else not Is_Entity_Name (Name (N)) + then + if Nkind (Name (N)) = N_Selected_Component then + Rec := Prefix (Name (N)); + + else + pragma Assert (Nkind (Name (N)) = N_Indexed_Component); + Rec := Prefix (Prefix (Name (N))); + end if; + + Build_Protected_Subprogram_Call (N, + Name => New_Occurrence_Of (Subp, Sloc (N)), + Rec => Convert_Concurrent (Rec, Etype (Rec)), + External => True); + + else + Rec := Expand_Protected_Object_Reference (N, Scop); + + if No (Rec) then + return; + end if; + + Build_Protected_Subprogram_Call (N, + Name => Name (N), + Rec => Rec, + External => False); + + end if; + + -- If it is a function call it can appear in elaboration code and + -- the called entity must be frozen here. + + if Ekind (Subp) = E_Function then + Freeze_Expression (Name (N)); + end if; + + -- Analyze and resolve the new call. The actuals have already been + -- resolved, but expansion of a function call will add extra actuals + -- if needed. Analysis of a procedure call already includes resolution. + + Analyze (N); + + if Ekind (Subp) = E_Function then + Resolve (N, Etype (Subp)); + end if; + end Expand_Protected_Subprogram_Call; + + ----------------------------------- + -- Expand_Simple_Function_Return -- + ----------------------------------- + + -- The "simple" comes from the syntax rule simple_return_statement. + -- The semantics are not at all simple! + + procedure Expand_Simple_Function_Return (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Scope_Id : constant Entity_Id := + Return_Applies_To (Return_Statement_Entity (N)); + -- The function we are returning from + + R_Type : constant Entity_Id := Etype (Scope_Id); + -- The result type of the function + + Utyp : constant Entity_Id := Underlying_Type (R_Type); + + Exp : constant Node_Id := Expression (N); + pragma Assert (Present (Exp)); + + Exptyp : constant Entity_Id := Etype (Exp); + -- The type of the expression (not necessarily the same as R_Type) + + Subtype_Ind : Node_Id; + -- If the result type of the function is class-wide and the + -- expression has a specific type, then we use the expression's + -- type as the type of the return object. In cases where the + -- expression is an aggregate that is built in place, this avoids + -- the need for an expensive conversion of the return object to + -- the specific type on assignments to the individual components. + + begin + if Is_Class_Wide_Type (R_Type) + and then not Is_Class_Wide_Type (Etype (Exp)) + then + Subtype_Ind := New_Occurrence_Of (Etype (Exp), Loc); + else + Subtype_Ind := New_Occurrence_Of (R_Type, Loc); + end if; + + -- For the case of a simple return that does not come from an extended + -- return, in the case of Ada 2005 where we are returning a limited + -- type, we rewrite "return ;" to be: + + -- return _anon_ : := + + -- The expansion produced by Expand_N_Extended_Return_Statement will + -- contain simple return statements (for example, a block containing + -- simple return of the return object), which brings us back here with + -- Comes_From_Extended_Return_Statement set. The reason for the barrier + -- checking for a simple return that does not come from an extended + -- return is to avoid this infinite recursion. + + -- The reason for this design is that for Ada 2005 limited returns, we + -- need to reify the return object, so we can build it "in place", and + -- we need a block statement to hang finalization and tasking stuff. + + -- ??? In order to avoid disruption, we avoid translating to extended + -- return except in the cases where we really need to (Ada 2005 for + -- inherently limited). We might prefer to do this translation in all + -- cases (except perhaps for the case of Ada 95 inherently limited), + -- in order to fully exercise the Expand_N_Extended_Return_Statement + -- code. This would also allow us to do the build-in-place optimization + -- for efficiency even in cases where it is semantically not required. + + -- As before, we check the type of the return expression rather than the + -- return type of the function, because the latter may be a limited + -- class-wide interface type, which is not a limited type, even though + -- the type of the expression may be. + + if not Comes_From_Extended_Return_Statement (N) + and then Is_Immutably_Limited_Type (Etype (Expression (N))) + and then Ada_Version >= Ada_2005 + and then not Debug_Flag_Dot_L + then + declare + Return_Object_Entity : constant Entity_Id := + Make_Temporary (Loc, 'R', Exp); + Obj_Decl : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => Return_Object_Entity, + Object_Definition => Subtype_Ind, + Expression => Exp); + + Ext : constant Node_Id := Make_Extended_Return_Statement (Loc, + Return_Object_Declarations => New_List (Obj_Decl)); + -- Do not perform this high-level optimization if the result type + -- is an interface because the "this" pointer must be displaced. + + begin + Rewrite (N, Ext); + Analyze (N); + return; + end; + end if; + + -- Here we have a simple return statement that is part of the expansion + -- of an extended return statement (either written by the user, or + -- generated by the above code). + + -- Always normalize C/Fortran boolean result. This is not always needed, + -- but it seems a good idea to minimize the passing around of non- + -- normalized values, and in any case this handles the processing of + -- barrier functions for protected types, which turn the condition into + -- a return statement. + + if Is_Boolean_Type (Exptyp) + and then Nonzero_Is_True (Exptyp) + then + Adjust_Condition (Exp); + Adjust_Result_Type (Exp, Exptyp); + end if; + + -- Do validity check if enabled for returns + + if Validity_Checks_On + and then Validity_Check_Returns + then + Ensure_Valid (Exp); + end if; + + -- Check the result expression of a scalar function against the subtype + -- of the function by inserting a conversion. This conversion must + -- eventually be performed for other classes of types, but for now it's + -- only done for scalars. + -- ??? + + if Is_Scalar_Type (Exptyp) then + Rewrite (Exp, Convert_To (R_Type, Exp)); + + -- The expression is resolved to ensure that the conversion gets + -- expanded to generate a possible constraint check. + + Analyze_And_Resolve (Exp, R_Type); + end if; + + -- Deal with returning variable length objects and controlled types + + -- Nothing to do if we are returning by reference, or this is not a + -- type that requires special processing (indicated by the fact that + -- it requires a cleanup scope for the secondary stack case). + + if Is_Immutably_Limited_Type (Exptyp) + or else Is_Limited_Interface (Exptyp) + then + null; + + elsif not Requires_Transient_Scope (R_Type) then + + -- Mutable records with no variable length components are not + -- returned on the sec-stack, so we need to make sure that the + -- backend will only copy back the size of the actual value, and not + -- the maximum size. We create an actual subtype for this purpose. + + declare + Ubt : constant Entity_Id := Underlying_Type (Base_Type (Exptyp)); + Decl : Node_Id; + Ent : Entity_Id; + begin + if Has_Discriminants (Ubt) + and then not Is_Constrained (Ubt) + and then not Has_Unchecked_Union (Ubt) + then + Decl := Build_Actual_Subtype (Ubt, Exp); + Ent := Defining_Identifier (Decl); + Insert_Action (Exp, Decl); + Rewrite (Exp, Unchecked_Convert_To (Ent, Exp)); + Analyze_And_Resolve (Exp); + end if; + end; + + -- Here if secondary stack is used + + else + -- Make sure that no surrounding block will reclaim the secondary + -- stack on which we are going to put the result. Not only may this + -- introduce secondary stack leaks but worse, if the reclamation is + -- done too early, then the result we are returning may get + -- clobbered. + + declare + S : Entity_Id; + begin + S := Current_Scope; + while Ekind (S) = E_Block or else Ekind (S) = E_Loop loop + Set_Sec_Stack_Needed_For_Return (S, True); + S := Enclosing_Dynamic_Scope (S); + end loop; + end; + + -- Optimize the case where the result is a function call. In this + -- case either the result is already on the secondary stack, or is + -- already being returned with the stack pointer depressed and no + -- further processing is required except to set the By_Ref flag to + -- ensure that gigi does not attempt an extra unnecessary copy. + -- (actually not just unnecessary but harmfully wrong in the case + -- of a controlled type, where gigi does not know how to do a copy). + -- To make up for a gcc 2.8.1 deficiency (???), we perform + -- the copy for array types if the constrained status of the + -- target type is different from that of the expression. + + if Requires_Transient_Scope (Exptyp) + and then + (not Is_Array_Type (Exptyp) + or else Is_Constrained (Exptyp) = Is_Constrained (R_Type) + or else CW_Or_Has_Controlled_Part (Utyp)) + and then Nkind (Exp) = N_Function_Call + then + Set_By_Ref (N); + + -- Remove side effects from the expression now so that other parts + -- of the expander do not have to reanalyze this node without this + -- optimization + + Rewrite (Exp, Duplicate_Subexpr_No_Checks (Exp)); + + -- For controlled types, do the allocation on the secondary stack + -- manually in order to call adjust at the right time: + + -- type Anon1 is access R_Type; + -- for Anon1'Storage_pool use ss_pool; + -- Anon2 : anon1 := new R_Type'(expr); + -- return Anon2.all; + + -- We do the same for classwide types that are not potentially + -- controlled (by the virtue of restriction No_Finalization) because + -- gigi is not able to properly allocate class-wide types. + + elsif CW_Or_Has_Controlled_Part (Utyp) then + declare + Loc : constant Source_Ptr := Sloc (N); + Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); + Alloc_Node : Node_Id; + Temp : Entity_Id; + + begin + Set_Ekind (Acc_Typ, E_Access_Type); + + Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool)); + + -- This is an allocator for the secondary stack, and it's fine + -- to have Comes_From_Source set False on it, as gigi knows not + -- to flag it as a violation of No_Implicit_Heap_Allocations. + + Alloc_Node := + Make_Allocator (Loc, + Expression => + Make_Qualified_Expression (Loc, + Subtype_Mark => New_Reference_To (Etype (Exp), Loc), + Expression => Relocate_Node (Exp))); + + -- We do not want discriminant checks on the declaration, + -- given that it gets its value from the allocator. + + Set_No_Initialization (Alloc_Node); + + Temp := Make_Temporary (Loc, 'R', Alloc_Node); + + Insert_List_Before_And_Analyze (N, New_List ( + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Acc_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => Subtype_Ind)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Reference_To (Acc_Typ, Loc), + Expression => Alloc_Node))); + + Rewrite (Exp, + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Temp, Loc))); + + Analyze_And_Resolve (Exp, R_Type); + end; + + -- Otherwise use the gigi mechanism to allocate result on the + -- secondary stack. + + else + Check_Restriction (No_Secondary_Stack, N); + Set_Storage_Pool (N, RTE (RE_SS_Pool)); + + -- If we are generating code for the VM do not use + -- SS_Allocate since everything is heap-allocated anyway. + + if VM_Target = No_VM then + Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); + end if; + end if; + end if; + + -- Implement the rules of 6.5(8-10), which require a tag check in the + -- case of a limited tagged return type, and tag reassignment for + -- nonlimited tagged results. These actions are needed when the return + -- type is a specific tagged type and the result expression is a + -- conversion or a formal parameter, because in that case the tag of the + -- expression might differ from the tag of the specific result type. + + if Is_Tagged_Type (Utyp) + and then not Is_Class_Wide_Type (Utyp) + and then (Nkind_In (Exp, N_Type_Conversion, + N_Unchecked_Type_Conversion) + or else (Is_Entity_Name (Exp) + and then Ekind (Entity (Exp)) in Formal_Kind)) + then + -- When the return type is limited, perform a check that the + -- tag of the result is the same as the tag of the return type. + + if Is_Limited_Type (R_Type) then + Insert_Action (Exp, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Exp), + Selector_Name => Make_Identifier (Loc, Name_uTag)), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Base_Type (Utyp), Loc), + Attribute_Name => Name_Tag)), + Reason => CE_Tag_Check_Failed)); + + -- If the result type is a specific nonlimited tagged type, then we + -- have to ensure that the tag of the result is that of the result + -- type. This is handled by making a copy of the expression in the + -- case where it might have a different tag, namely when the + -- expression is a conversion or a formal parameter. We create a new + -- object of the result type and initialize it from the expression, + -- which will implicitly force the tag to be set appropriately. + + else + declare + ExpR : constant Node_Id := Relocate_Node (Exp); + Result_Id : constant Entity_Id := + Make_Temporary (Loc, 'R', ExpR); + Result_Exp : constant Node_Id := + New_Reference_To (Result_Id, Loc); + Result_Obj : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => Result_Id, + Object_Definition => + New_Reference_To (R_Type, Loc), + Constant_Present => True, + Expression => ExpR); + + begin + Set_Assignment_OK (Result_Obj); + Insert_Action (Exp, Result_Obj); + + Rewrite (Exp, Result_Exp); + Analyze_And_Resolve (Exp, R_Type); + end; + end if; + + -- Ada 2005 (AI-344): If the result type is class-wide, then insert + -- a check that the level of the return expression's underlying type + -- is not deeper than the level of the master enclosing the function. + -- Always generate the check when the type of the return expression + -- is class-wide, when it's a type conversion, or when it's a formal + -- parameter. Otherwise, suppress the check in the case where the + -- return expression has a specific type whose level is known not to + -- be statically deeper than the function's result type. + + -- Note: accessibility check is skipped in the VM case, since there + -- does not seem to be any practical way to implement this check. + + elsif Ada_Version >= Ada_2005 + and then Tagged_Type_Expansion + and then Is_Class_Wide_Type (R_Type) + and then not Scope_Suppress (Accessibility_Check) + and then + (Is_Class_Wide_Type (Etype (Exp)) + or else Nkind_In (Exp, N_Type_Conversion, + N_Unchecked_Type_Conversion) + or else (Is_Entity_Name (Exp) + and then Ekind (Entity (Exp)) in Formal_Kind) + or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) > + Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id))) + then + declare + Tag_Node : Node_Id; + + begin + -- Ada 2005 (AI-251): In class-wide interface objects we displace + -- "this" to reference the base of the object --- required to get + -- access to the TSD of the object. + + if Is_Class_Wide_Type (Etype (Exp)) + and then Is_Interface (Etype (Exp)) + and then Nkind (Exp) = N_Explicit_Dereference + then + Tag_Node := + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Tag_Ptr), + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Base_Address), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), + Duplicate_Subexpr (Prefix (Exp))))))); + else + Tag_Node := + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Exp), + Attribute_Name => Name_Tag); + end if; + + Insert_Action (Exp, + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => + Build_Get_Access_Level (Loc, Tag_Node), + Right_Opnd => + Make_Integer_Literal (Loc, + Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))), + Reason => PE_Accessibility_Check_Failed)); + end; + + -- AI05-0073: If function has a controlling access result, check that + -- the tag of the return value, if it is not null, matches designated + -- type of return type. + -- The return expression is referenced twice in the code below, so + -- it must be made free of side effects. Given that different compilers + -- may evaluate these parameters in different order, both occurrences + -- perform a copy. + + elsif Ekind (R_Type) = E_Anonymous_Access_Type + and then Has_Controlling_Result (Scope_Id) + then + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Ne (Loc, + Left_Opnd => Duplicate_Subexpr (Exp), + Right_Opnd => Make_Null (Loc)), + Right_Opnd => Make_Op_Ne (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Exp), + Selector_Name => Make_Identifier (Loc, Name_uTag)), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Designated_Type (R_Type), Loc), + Attribute_Name => Name_Tag))), + Reason => CE_Tag_Check_Failed), + Suppress => All_Checks); + end if; + + -- If we are returning an object that may not be bit-aligned, then copy + -- the value into a temporary first. This copy may need to expand to a + -- loop of component operations. + + if Is_Possibly_Unaligned_Slice (Exp) + or else Is_Possibly_Unaligned_Object (Exp) + then + declare + ExpR : constant Node_Id := Relocate_Node (Exp); + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR); + begin + Insert_Action (Exp, + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (R_Type, Loc), + Expression => ExpR), + Suppress => All_Checks); + Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); + end; + end if; + + -- Generate call to postcondition checks if they are present + + if Ekind (Scope_Id) = E_Function + and then Has_Postconditions (Scope_Id) + then + -- We are going to reference the returned value twice in this case, + -- once in the call to _Postconditions, and once in the actual return + -- statement, but we can't have side effects happening twice, and in + -- any case for efficiency we don't want to do the computation twice. + + -- If the returned expression is an entity name, we don't need to + -- worry since it is efficient and safe to reference it twice, that's + -- also true for literals other than string literals, and for the + -- case of X.all where X is an entity name. + + if Is_Entity_Name (Exp) + or else Nkind_In (Exp, N_Character_Literal, + N_Integer_Literal, + N_Real_Literal) + or else (Nkind (Exp) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Exp))) + then + null; + + -- Otherwise we are going to need a temporary to capture the value + + else + declare + ExpR : constant Node_Id := Relocate_Node (Exp); + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR); + + begin + -- For a complex expression of an elementary type, capture + -- value in the temporary and use it as the reference. + + if Is_Elementary_Type (R_Type) then + Insert_Action (Exp, + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (R_Type, Loc), + Expression => ExpR), + Suppress => All_Checks); + + Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); + + -- If we have something we can rename, generate a renaming of + -- the object and replace the expression with a reference + + elsif Is_Object_Reference (Exp) then + Insert_Action (Exp, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Tnn, + Subtype_Mark => New_Occurrence_Of (R_Type, Loc), + Name => ExpR), + Suppress => All_Checks); + + Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); + + -- Otherwise we have something like a string literal or an + -- aggregate. We could copy the value, but that would be + -- inefficient. Instead we make a reference to the value and + -- capture this reference with a renaming, the expression is + -- then replaced by a dereference of this renaming. + + else + -- For now, copy the value, since the code below does not + -- seem to work correctly ??? + + Insert_Action (Exp, + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (R_Type, Loc), + Expression => Relocate_Node (Exp)), + Suppress => All_Checks); + + Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); + + -- Insert_Action (Exp, + -- Make_Object_Renaming_Declaration (Loc, + -- Defining_Identifier => Tnn, + -- Access_Definition => + -- Make_Access_Definition (Loc, + -- All_Present => True, + -- Subtype_Mark => New_Occurrence_Of (R_Type, Loc)), + -- Name => + -- Make_Reference (Loc, + -- Prefix => Relocate_Node (Exp))), + -- Suppress => All_Checks); + + -- Rewrite (Exp, + -- Make_Explicit_Dereference (Loc, + -- Prefix => New_Occurrence_Of (Tnn, Loc))); + end if; + end; + end if; + + -- Generate call to _postconditions + + Insert_Action (Exp, + Make_Procedure_Call_Statement (Loc, + Name => Make_Identifier (Loc, Name_uPostconditions), + Parameter_Associations => New_List (Duplicate_Subexpr (Exp)))); + end if; + + -- Ada 2005 (AI-251): If this return statement corresponds with an + -- simple return statement associated with an extended return statement + -- and the type of the returned object is an interface then generate an + -- implicit conversion to force displacement of the "this" pointer. + + if Ada_Version >= Ada_2005 + and then Comes_From_Extended_Return_Statement (N) + and then Nkind (Expression (N)) = N_Identifier + and then Is_Interface (Utyp) + and then Utyp /= Underlying_Type (Exptyp) + then + Rewrite (Exp, Convert_To (Utyp, Relocate_Node (Exp))); + Analyze_And_Resolve (Exp); + end if; + end Expand_Simple_Function_Return; + + -------------------------------- + -- Is_Build_In_Place_Function -- + -------------------------------- + + function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is + begin + -- This function is called from Expand_Subtype_From_Expr during + -- semantic analysis, even when expansion is off. In those cases + -- the build_in_place expansion will not take place. + + if not Expander_Active then + return False; + end if; + + -- For now we test whether E denotes a function or access-to-function + -- type whose result subtype is inherently limited. Later this test may + -- be revised to allow composite nonlimited types. Functions with a + -- foreign convention or whose result type has a foreign convention + -- never qualify. + + if Ekind_In (E, E_Function, E_Generic_Function) + or else (Ekind (E) = E_Subprogram_Type + and then Etype (E) /= Standard_Void_Type) + then + -- Note: If you have Convention (C) on an inherently limited type, + -- you're on your own. That is, the C code will have to be carefully + -- written to know about the Ada conventions. + + if Has_Foreign_Convention (E) + or else Has_Foreign_Convention (Etype (E)) + then + return False; + + -- In Ada 2005 all functions with an inherently limited return type + -- must be handled using a build-in-place profile, including the case + -- of a function with a limited interface result, where the function + -- may return objects of nonlimited descendants. + + else + return Is_Immutably_Limited_Type (Etype (E)) + and then Ada_Version >= Ada_2005 + and then not Debug_Flag_Dot_L; + end if; + + else + return False; + end if; + end Is_Build_In_Place_Function; + + ------------------------------------- + -- Is_Build_In_Place_Function_Call -- + ------------------------------------- + + function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean is + Exp_Node : Node_Id := N; + Function_Id : Entity_Id; + + begin + -- Step past qualification or unchecked conversion (the latter can occur + -- in cases of calls to 'Input). + + if Nkind_In + (Exp_Node, N_Qualified_Expression, N_Unchecked_Type_Conversion) + then + Exp_Node := Expression (N); + end if; + + if Nkind (Exp_Node) /= N_Function_Call then + return False; + + else + if Is_Entity_Name (Name (Exp_Node)) then + Function_Id := Entity (Name (Exp_Node)); + + elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then + Function_Id := Etype (Name (Exp_Node)); + end if; + + return Is_Build_In_Place_Function (Function_Id); + end if; + end Is_Build_In_Place_Function_Call; + + ----------------------- + -- Freeze_Subprogram -- + ----------------------- + + procedure Freeze_Subprogram (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + procedure Register_Predefined_DT_Entry (Prim : Entity_Id); + -- (Ada 2005): Register a predefined primitive in all the secondary + -- dispatch tables of its primitive type. + + ---------------------------------- + -- Register_Predefined_DT_Entry -- + ---------------------------------- + + procedure Register_Predefined_DT_Entry (Prim : Entity_Id) is + Iface_DT_Ptr : Elmt_Id; + Tagged_Typ : Entity_Id; + Thunk_Id : Entity_Id; + Thunk_Code : Node_Id; + + begin + Tagged_Typ := Find_Dispatching_Type (Prim); + + if No (Access_Disp_Table (Tagged_Typ)) + or else not Has_Interfaces (Tagged_Typ) + or else not RTE_Available (RE_Interface_Tag) + or else Restriction_Active (No_Dispatching_Calls) + then + return; + end if; + + -- Skip the first two access-to-dispatch-table pointers since they + -- leads to the primary dispatch table (predefined DT and user + -- defined DT). We are only concerned with the secondary dispatch + -- table pointers. Note that the access-to- dispatch-table pointer + -- corresponds to the first implemented interface retrieved below. + + Iface_DT_Ptr := + Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ)))); + + while Present (Iface_DT_Ptr) + and then Ekind (Node (Iface_DT_Ptr)) = E_Constant + loop + pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); + Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); + + if Present (Thunk_Code) then + Insert_Actions_After (N, New_List ( + Thunk_Code, + + Build_Set_Predefined_Prim_Op_Address (Loc, + Tag_Node => + New_Reference_To (Node (Next_Elmt (Iface_DT_Ptr)), Loc), + Position => DT_Position (Prim), + Address_Node => + Unchecked_Convert_To (RTE (RE_Prim_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Thunk_Id, Loc), + Attribute_Name => Name_Unrestricted_Access))), + + Build_Set_Predefined_Prim_Op_Address (Loc, + Tag_Node => + New_Reference_To + (Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))), + Loc), + Position => DT_Position (Prim), + Address_Node => + Unchecked_Convert_To (RTE (RE_Prim_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim, Loc), + Attribute_Name => Name_Unrestricted_Access))))); + end if; + + -- Skip the tag of the predefined primitives dispatch table + + Next_Elmt (Iface_DT_Ptr); + pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); + + -- Skip the tag of the no-thunks dispatch table + + Next_Elmt (Iface_DT_Ptr); + pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); + + -- Skip the tag of the predefined primitives no-thunks dispatch + -- table + + Next_Elmt (Iface_DT_Ptr); + pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); + + Next_Elmt (Iface_DT_Ptr); + end loop; + end Register_Predefined_DT_Entry; + + -- Local variables + + Subp : constant Entity_Id := Entity (N); + + -- Start of processing for Freeze_Subprogram + + begin + -- We suppress the initialization of the dispatch table entry when + -- VM_Target because the dispatching mechanism is handled internally + -- by the VM. + + if Is_Dispatching_Operation (Subp) + and then not Is_Abstract_Subprogram (Subp) + and then Present (DTC_Entity (Subp)) + and then Present (Scope (DTC_Entity (Subp))) + and then Tagged_Type_Expansion + and then not Restriction_Active (No_Dispatching_Calls) + and then RTE_Available (RE_Tag) + then + declare + Typ : constant Entity_Id := Scope (DTC_Entity (Subp)); + + begin + -- Handle private overridden primitives + + if not Is_CPP_Class (Typ) then + Check_Overriding_Operation (Subp); + end if; + + -- We assume that imported CPP primitives correspond with objects + -- whose constructor is in the CPP side; therefore we don't need + -- to generate code to register them in the dispatch table. + + if Is_CPP_Class (Typ) then + null; + + -- Handle CPP primitives found in derivations of CPP_Class types. + -- These primitives must have been inherited from some parent, and + -- there is no need to register them in the dispatch table because + -- Build_Inherit_Prims takes care of the initialization of these + -- slots. + + elsif Is_Imported (Subp) + and then (Convention (Subp) = Convention_CPP + or else Convention (Subp) = Convention_C) + then + null; + + -- Generate code to register the primitive in non statically + -- allocated dispatch tables + + elsif not Building_Static_DT (Scope (DTC_Entity (Subp))) then + + -- When a primitive is frozen, enter its name in its dispatch + -- table slot. + + if not Is_Interface (Typ) + or else Present (Interface_Alias (Subp)) + then + if Is_Predefined_Dispatching_Operation (Subp) then + Register_Predefined_DT_Entry (Subp); + end if; + + Insert_Actions_After (N, + Register_Primitive (Loc, Prim => Subp)); + end if; + end if; + end; + end if; + + -- Mark functions that return by reference. Note that it cannot be part + -- of the normal semantic analysis of the spec since the underlying + -- returned type may not be known yet (for private types). + + declare + Typ : constant Entity_Id := Etype (Subp); + Utyp : constant Entity_Id := Underlying_Type (Typ); + begin + if Is_Immutably_Limited_Type (Typ) then + Set_Returns_By_Ref (Subp); + elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then + Set_Returns_By_Ref (Subp); + end if; + end; + end Freeze_Subprogram; + + ----------------------- + -- Is_Null_Procedure -- + ----------------------- + + function Is_Null_Procedure (Subp : Entity_Id) return Boolean is + Decl : constant Node_Id := Unit_Declaration_Node (Subp); + + begin + if Ekind (Subp) /= E_Procedure then + return False; + + -- Check if this is a declared null procedure + + elsif Nkind (Decl) = N_Subprogram_Declaration then + if not Null_Present (Specification (Decl)) then + return False; + + elsif No (Body_To_Inline (Decl)) then + return False; + + -- Check if the body contains only a null statement, followed by + -- the return statement added during expansion. + + else + declare + Orig_Bod : constant Node_Id := Body_To_Inline (Decl); + + Stat : Node_Id; + Stat2 : Node_Id; + + begin + if Nkind (Orig_Bod) /= N_Subprogram_Body then + return False; + else + -- We must skip SCIL nodes because they are currently + -- implemented as special N_Null_Statement nodes. + + Stat := + First_Non_SCIL_Node + (Statements (Handled_Statement_Sequence (Orig_Bod))); + Stat2 := Next_Non_SCIL_Node (Stat); + + return + Is_Empty_List (Declarations (Orig_Bod)) + and then Nkind (Stat) = N_Null_Statement + and then + (No (Stat2) + or else + (Nkind (Stat2) = N_Simple_Return_Statement + and then No (Next (Stat2)))); + end if; + end; + end if; + + else + return False; + end if; + end Is_Null_Procedure; + + ------------------------------------------- + -- Make_Build_In_Place_Call_In_Allocator -- + ------------------------------------------- + + procedure Make_Build_In_Place_Call_In_Allocator + (Allocator : Node_Id; + Function_Call : Node_Id) + is + Loc : Source_Ptr; + Func_Call : Node_Id := Function_Call; + Function_Id : Entity_Id; + Result_Subt : Entity_Id; + Acc_Type : constant Entity_Id := Etype (Allocator); + New_Allocator : Node_Id; + Return_Obj_Access : Entity_Id; + + begin + -- Step past qualification or unchecked conversion (the latter can occur + -- in cases of calls to 'Input). + + if Nkind_In (Func_Call, + N_Qualified_Expression, + N_Unchecked_Type_Conversion) + then + Func_Call := Expression (Func_Call); + end if; + + -- If the call has already been processed to add build-in-place actuals + -- then return. This should not normally occur in an allocator context, + -- but we add the protection as a defensive measure. + + if Is_Expanded_Build_In_Place_Call (Func_Call) then + return; + end if; + + -- Mark the call as processed as a build-in-place call + + Set_Is_Expanded_Build_In_Place_Call (Func_Call); + + Loc := Sloc (Function_Call); + + if Is_Entity_Name (Name (Func_Call)) then + Function_Id := Entity (Name (Func_Call)); + + elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then + Function_Id := Etype (Name (Func_Call)); + + else + raise Program_Error; + end if; + + Result_Subt := Etype (Function_Id); + + -- When the result subtype is constrained, the return object must be + -- allocated on the caller side, and access to it is passed to the + -- function. + + -- Here and in related routines, we must examine the full view of the + -- type, because the view at the point of call may differ from that + -- that in the function body, and the expansion mechanism depends on + -- the characteristics of the full view. + + if Is_Constrained (Underlying_Type (Result_Subt)) then + + -- Replace the initialized allocator of form "new T'(Func (...))" + -- with an uninitialized allocator of form "new T", where T is the + -- result subtype of the called function. The call to the function + -- is handled separately further below. + + New_Allocator := + Make_Allocator (Loc, + Expression => New_Reference_To (Result_Subt, Loc)); + Set_No_Initialization (New_Allocator); + + -- Copy attributes to new allocator. Note that the new allocator + -- logically comes from source if the original one did, so copy the + -- relevant flag. This ensures proper treatment of the restriction + -- No_Implicit_Heap_Allocations in this case. + + Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator)); + Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator)); + Set_Comes_From_Source (New_Allocator, Comes_From_Source (Allocator)); + + Rewrite (Allocator, New_Allocator); + + -- Create a new access object and initialize it to the result of the + -- new uninitialized allocator. Note: we do not use Allocator as the + -- Related_Node of Return_Obj_Access in call to Make_Temporary below + -- as this would create a sort of infinite "recursion". + + Return_Obj_Access := Make_Temporary (Loc, 'R'); + Set_Etype (Return_Obj_Access, Acc_Type); + + Insert_Action (Allocator, + Make_Object_Declaration (Loc, + Defining_Identifier => Return_Obj_Access, + Object_Definition => New_Reference_To (Acc_Type, Loc), + Expression => Relocate_Node (Allocator))); + + -- When the function has a controlling result, an allocation-form + -- parameter must be passed indicating that the caller is allocating + -- the result object. This is needed because such a function can be + -- called as a dispatching operation and must be treated similarly + -- to functions with unconstrained result subtypes. + + Add_Alloc_Form_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); + + Add_Final_List_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Acc_Type); + + Add_Task_Actuals_To_Build_In_Place_Call + (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type)); + + -- Add an implicit actual to the function call that provides access + -- to the allocated object. An unchecked conversion to the (specific) + -- result subtype of the function is inserted to handle cases where + -- the access type of the allocator has a class-wide designated type. + + Add_Access_Actual_To_Build_In_Place_Call + (Func_Call, + Function_Id, + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Reference_To (Result_Subt, Loc), + Expression => + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Return_Obj_Access, Loc)))); + + -- When the result subtype is unconstrained, the function itself must + -- perform the allocation of the return object, so we pass parameters + -- indicating that. We don't yet handle the case where the allocation + -- must be done in a user-defined storage pool, which will require + -- passing another actual or two to provide allocation/deallocation + -- operations. ??? + + else + + -- Pass an allocation parameter indicating that the function should + -- allocate its result on the heap. + + Add_Alloc_Form_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Alloc_Form => Global_Heap); + + Add_Final_List_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Acc_Type); + + Add_Task_Actuals_To_Build_In_Place_Call + (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type)); + + -- The caller does not provide the return object in this case, so we + -- have to pass null for the object access actual. + + Add_Access_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Return_Object => Empty); + end if; + + -- Finally, replace the allocator node with a reference to the result + -- of the function call itself (which will effectively be an access + -- to the object created by the allocator). + + Rewrite (Allocator, Make_Reference (Loc, Relocate_Node (Function_Call))); + Analyze_And_Resolve (Allocator, Acc_Type); + end Make_Build_In_Place_Call_In_Allocator; + + --------------------------------------------------- + -- Make_Build_In_Place_Call_In_Anonymous_Context -- + --------------------------------------------------- + + procedure Make_Build_In_Place_Call_In_Anonymous_Context + (Function_Call : Node_Id) + is + Loc : Source_Ptr; + Func_Call : Node_Id := Function_Call; + Function_Id : Entity_Id; + Result_Subt : Entity_Id; + Return_Obj_Id : Entity_Id; + Return_Obj_Decl : Entity_Id; + + begin + -- Step past qualification or unchecked conversion (the latter can occur + -- in cases of calls to 'Input). + + if Nkind_In (Func_Call, N_Qualified_Expression, + N_Unchecked_Type_Conversion) + then + Func_Call := Expression (Func_Call); + end if; + + -- If the call has already been processed to add build-in-place actuals + -- then return. One place this can occur is for calls to build-in-place + -- functions that occur within a call to a protected operation, where + -- due to rewriting and expansion of the protected call there can be + -- more than one call to Expand_Actuals for the same set of actuals. + + if Is_Expanded_Build_In_Place_Call (Func_Call) then + return; + end if; + + -- Mark the call as processed as a build-in-place call + + Set_Is_Expanded_Build_In_Place_Call (Func_Call); + + Loc := Sloc (Function_Call); + + if Is_Entity_Name (Name (Func_Call)) then + Function_Id := Entity (Name (Func_Call)); + + elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then + Function_Id := Etype (Name (Func_Call)); + + else + raise Program_Error; + end if; + + Result_Subt := Etype (Function_Id); + + -- When the result subtype is constrained, an object of the subtype is + -- declared and an access value designating it is passed as an actual. + + if Is_Constrained (Underlying_Type (Result_Subt)) then + + -- Create a temporary object to hold the function result + + Return_Obj_Id := Make_Temporary (Loc, 'R'); + Set_Etype (Return_Obj_Id, Result_Subt); + + Return_Obj_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Return_Obj_Id, + Aliased_Present => True, + Object_Definition => New_Reference_To (Result_Subt, Loc)); + + Set_No_Initialization (Return_Obj_Decl); + + Insert_Action (Func_Call, Return_Obj_Decl); + + -- When the function has a controlling result, an allocation-form + -- parameter must be passed indicating that the caller is allocating + -- the result object. This is needed because such a function can be + -- called as a dispatching operation and must be treated similarly + -- to functions with unconstrained result subtypes. + + Add_Alloc_Form_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); + + Add_Final_List_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Acc_Type => Empty); + + Add_Task_Actuals_To_Build_In_Place_Call + (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); + + -- Add an implicit actual to the function call that provides access + -- to the caller's return object. + + Add_Access_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, New_Reference_To (Return_Obj_Id, Loc)); + + -- When the result subtype is unconstrained, the function must allocate + -- the return object in the secondary stack, so appropriate implicit + -- parameters are added to the call to indicate that. A transient + -- scope is established to ensure eventual cleanup of the result. + + else + -- Pass an allocation parameter indicating that the function should + -- allocate its result on the secondary stack. + + Add_Alloc_Form_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Alloc_Form => Secondary_Stack); + + Add_Final_List_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Acc_Type => Empty); + + Add_Task_Actuals_To_Build_In_Place_Call + (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); + + -- Pass a null value to the function since no return object is + -- available on the caller side. + + Add_Access_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Empty); + end if; + end Make_Build_In_Place_Call_In_Anonymous_Context; + + -------------------------------------------- + -- Make_Build_In_Place_Call_In_Assignment -- + -------------------------------------------- + + procedure Make_Build_In_Place_Call_In_Assignment + (Assign : Node_Id; + Function_Call : Node_Id) + is + Lhs : constant Node_Id := Name (Assign); + Func_Call : Node_Id := Function_Call; + Func_Id : Entity_Id; + Loc : Source_Ptr; + Obj_Decl : Node_Id; + Obj_Id : Entity_Id; + Ptr_Typ : Entity_Id; + Ptr_Typ_Decl : Node_Id; + Result_Subt : Entity_Id; + Target : Node_Id; + + begin + -- Step past qualification or unchecked conversion (the latter can occur + -- in cases of calls to 'Input). + + if Nkind_In (Func_Call, N_Qualified_Expression, + N_Unchecked_Type_Conversion) + then + Func_Call := Expression (Func_Call); + end if; + + -- If the call has already been processed to add build-in-place actuals + -- then return. This should not normally occur in an assignment context, + -- but we add the protection as a defensive measure. + + if Is_Expanded_Build_In_Place_Call (Func_Call) then + return; + end if; + + -- Mark the call as processed as a build-in-place call + + Set_Is_Expanded_Build_In_Place_Call (Func_Call); + + Loc := Sloc (Function_Call); + + if Is_Entity_Name (Name (Func_Call)) then + Func_Id := Entity (Name (Func_Call)); + + elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then + Func_Id := Etype (Name (Func_Call)); + + else + raise Program_Error; + end if; + + Result_Subt := Etype (Func_Id); + + -- When the result subtype is unconstrained, an additional actual must + -- be passed to indicate that the caller is providing the return object. + -- This parameter must also be passed when the called function has a + -- controlling result, because dispatching calls to the function needs + -- to be treated effectively the same as calls to class-wide functions. + + Add_Alloc_Form_Actual_To_Build_In_Place_Call + (Func_Call, Func_Id, Alloc_Form => Caller_Allocation); + + -- If Lhs is a selected component, then pass it along so that its prefix + -- object will be used as the source of the finalization list. + + if Nkind (Lhs) = N_Selected_Component then + Add_Final_List_Actual_To_Build_In_Place_Call + (Func_Call, Func_Id, Acc_Type => Empty, Sel_Comp => Lhs); + else + Add_Final_List_Actual_To_Build_In_Place_Call + (Func_Call, Func_Id, Acc_Type => Empty); + end if; + + Add_Task_Actuals_To_Build_In_Place_Call + (Func_Call, Func_Id, Make_Identifier (Loc, Name_uMaster)); + + -- Add an implicit actual to the function call that provides access to + -- the caller's return object. + + Add_Access_Actual_To_Build_In_Place_Call + (Func_Call, + Func_Id, + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Reference_To (Result_Subt, Loc), + Expression => Relocate_Node (Lhs))); + + -- Create an access type designating the function's result subtype + + Ptr_Typ := Make_Temporary (Loc, 'A'); + + Ptr_Typ_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ptr_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Reference_To (Result_Subt, Loc))); + Insert_After_And_Analyze (Assign, Ptr_Typ_Decl); + + -- Finally, create an access object initialized to a reference to the + -- function call. + + Obj_Id := Make_Temporary (Loc, 'R'); + Set_Etype (Obj_Id, Ptr_Typ); + + Obj_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Obj_Id, + Object_Definition => + New_Reference_To (Ptr_Typ, Loc), + Expression => + Make_Reference (Loc, + Prefix => Relocate_Node (Func_Call))); + Insert_After_And_Analyze (Ptr_Typ_Decl, Obj_Decl); + + Rewrite (Assign, Make_Null_Statement (Loc)); + + -- Retrieve the target of the assignment + + if Nkind (Lhs) = N_Selected_Component then + Target := Selector_Name (Lhs); + elsif Nkind (Lhs) = N_Type_Conversion then + Target := Expression (Lhs); + else + Target := Lhs; + end if; + + -- If we are assigning to a return object or this is an expression of + -- an extension aggregate, the target should either be an identifier + -- or a simple expression. All other cases imply a different scenario. + + if Nkind (Target) in N_Has_Entity then + Target := Entity (Target); + else + return; + end if; + + -- When the target of the assignment is a return object of an enclosing + -- build-in-place function and also requires finalization, the list + -- generated for the assignment must be moved to that of the enclosing + -- function. + + -- function Enclosing_BIP_Function return Ctrl_Typ is + -- begin + -- return (Ctrl_Parent_Part => BIP_Function with ...); + -- end Enclosing_BIP_Function; + + if Is_Return_Object (Target) + and then Needs_Finalization (Etype (Target)) + and then Needs_Finalization (Result_Subt) + then + declare + Obj_List : constant Node_Id := Find_Final_List (Obj_Id); + Encl_List : Node_Id; + Encl_Scop : Entity_Id; + + begin + Encl_Scop := Scope (Target); + + -- Locate the scope of the extended return statement + + while Present (Encl_Scop) + and then Ekind (Encl_Scop) /= E_Return_Statement + loop + Encl_Scop := Scope (Encl_Scop); + end loop; + + -- A return object should always be enclosed by a return statement + -- scope at some level. + + pragma Assert (Present (Encl_Scop)); + + Encl_List := + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To ( + Finalization_Chain_Entity (Encl_Scop), Loc), + Attribute_Name => Name_Unrestricted_Access); + + -- Generate a call to move final list + + Insert_After_And_Analyze (Obj_Decl, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Move_Final_List), Loc), + Parameter_Associations => New_List (Obj_List, Encl_List))); + end; + end if; + end Make_Build_In_Place_Call_In_Assignment; + + ---------------------------------------------------- + -- Make_Build_In_Place_Call_In_Object_Declaration -- + ---------------------------------------------------- + + procedure Make_Build_In_Place_Call_In_Object_Declaration + (Object_Decl : Node_Id; + Function_Call : Node_Id) + is + Loc : Source_Ptr; + Obj_Def_Id : constant Entity_Id := + Defining_Identifier (Object_Decl); + + Func_Call : Node_Id := Function_Call; + Function_Id : Entity_Id; + Result_Subt : Entity_Id; + Caller_Object : Node_Id; + Call_Deref : Node_Id; + Ref_Type : Entity_Id; + Ptr_Typ_Decl : Node_Id; + Def_Id : Entity_Id; + New_Expr : Node_Id; + Enclosing_Func : Entity_Id; + Pass_Caller_Acc : Boolean := False; + + begin + -- Step past qualification or unchecked conversion (the latter can occur + -- in cases of calls to 'Input). + + if Nkind_In (Func_Call, N_Qualified_Expression, + N_Unchecked_Type_Conversion) + then + Func_Call := Expression (Func_Call); + end if; + + -- If the call has already been processed to add build-in-place actuals + -- then return. This should not normally occur in an object declaration, + -- but we add the protection as a defensive measure. + + if Is_Expanded_Build_In_Place_Call (Func_Call) then + return; + end if; + + -- Mark the call as processed as a build-in-place call + + Set_Is_Expanded_Build_In_Place_Call (Func_Call); + + Loc := Sloc (Function_Call); + + if Is_Entity_Name (Name (Func_Call)) then + Function_Id := Entity (Name (Func_Call)); + + elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then + Function_Id := Etype (Name (Func_Call)); + + else + raise Program_Error; + end if; + + Result_Subt := Etype (Function_Id); + + -- In the constrained case, add an implicit actual to the function call + -- that provides access to the declared object. An unchecked conversion + -- to the (specific) result type of the function is inserted to handle + -- the case where the object is declared with a class-wide type. + + if Is_Constrained (Underlying_Type (Result_Subt)) then + Caller_Object := + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Reference_To (Result_Subt, Loc), + Expression => New_Reference_To (Obj_Def_Id, Loc)); + + -- When the function has a controlling result, an allocation-form + -- parameter must be passed indicating that the caller is allocating + -- the result object. This is needed because such a function can be + -- called as a dispatching operation and must be treated similarly + -- to functions with unconstrained result subtypes. + + Add_Alloc_Form_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); + + -- If the function's result subtype is unconstrained and the object is + -- a return object of an enclosing build-in-place function, then the + -- implicit build-in-place parameters of the enclosing function must be + -- passed along to the called function. (Unfortunately, this won't cover + -- the case of extension aggregates where the ancestor part is a build- + -- in-place unconstrained function call that should be passed along the + -- caller's parameters. Currently those get mishandled by reassigning + -- the result of the call to the aggregate return object, when the call + -- result should really be directly built in place in the aggregate and + -- not built in a temporary. ???) + + elsif Is_Return_Object (Defining_Identifier (Object_Decl)) then + Pass_Caller_Acc := True; + + Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id); + + -- If the enclosing function has a constrained result type, then + -- caller allocation will be used. + + if Is_Constrained (Etype (Enclosing_Func)) then + Add_Alloc_Form_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); + + -- Otherwise, when the enclosing function has an unconstrained result + -- type, the BIP_Alloc_Form formal of the enclosing function must be + -- passed along to the callee. + + else + Add_Alloc_Form_Actual_To_Build_In_Place_Call + (Func_Call, + Function_Id, + Alloc_Form_Exp => + New_Reference_To + (Build_In_Place_Formal (Enclosing_Func, BIP_Alloc_Form), + Loc)); + end if; + + -- Retrieve the BIPacc formal from the enclosing function and convert + -- it to the access type of the callee's BIP_Object_Access formal. + + Caller_Object := + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Reference_To + (Etype + (Build_In_Place_Formal (Function_Id, BIP_Object_Access)), + Loc), + Expression => + New_Reference_To + (Build_In_Place_Formal (Enclosing_Func, BIP_Object_Access), + Loc)); + + -- In other unconstrained cases, pass an indication to do the allocation + -- on the secondary stack and set Caller_Object to Empty so that a null + -- value will be passed for the caller's object address. A transient + -- scope is established to ensure eventual cleanup of the result. + + else + Add_Alloc_Form_Actual_To_Build_In_Place_Call + (Func_Call, + Function_Id, + Alloc_Form => Secondary_Stack); + Caller_Object := Empty; + + Establish_Transient_Scope (Object_Decl, Sec_Stack => True); + end if; + + Add_Final_List_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Acc_Type => Empty); + + if Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement + and then Has_Task (Result_Subt) + then + Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id); + + -- Here we're passing along the master that was passed in to this + -- function. + + Add_Task_Actuals_To_Build_In_Place_Call + (Func_Call, Function_Id, + Master_Actual => + New_Reference_To + (Build_In_Place_Formal (Enclosing_Func, BIP_Master), Loc)); + + else + Add_Task_Actuals_To_Build_In_Place_Call + (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); + end if; + + Add_Access_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Caller_Object, Is_Access => Pass_Caller_Acc); + + -- Create an access type designating the function's result subtype. We + -- use the type of the original expression because it may be a call to + -- an inherited operation, which the expansion has replaced with the + -- parent operation that yields the parent type. + + Ref_Type := Make_Temporary (Loc, 'A'); + + Ptr_Typ_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ref_Type, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Reference_To (Etype (Function_Call), Loc))); + + -- The access type and its accompanying object must be inserted after + -- the object declaration in the constrained case, so that the function + -- call can be passed access to the object. In the unconstrained case, + -- the access type and object must be inserted before the object, since + -- the object declaration is rewritten to be a renaming of a dereference + -- of the access object. + + if Is_Constrained (Underlying_Type (Result_Subt)) then + Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl); + else + Insert_Action (Object_Decl, Ptr_Typ_Decl); + end if; + + -- Finally, create an access object initialized to a reference to the + -- function call. + + New_Expr := + Make_Reference (Loc, + Prefix => Relocate_Node (Func_Call)); + + Def_Id := Make_Temporary (Loc, 'R', New_Expr); + Set_Etype (Def_Id, Ref_Type); + + Insert_After_And_Analyze (Ptr_Typ_Decl, + Make_Object_Declaration (Loc, + Defining_Identifier => Def_Id, + Object_Definition => New_Reference_To (Ref_Type, Loc), + Expression => New_Expr)); + + if Is_Constrained (Underlying_Type (Result_Subt)) then + Set_Expression (Object_Decl, Empty); + Set_No_Initialization (Object_Decl); + + -- In case of an unconstrained result subtype, rewrite the object + -- declaration as an object renaming where the renamed object is a + -- dereference of 'reference: + -- + -- Obj : Subt renames 'Ref.all; + + else + Call_Deref := + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Def_Id, Loc)); + + Loc := Sloc (Object_Decl); + Rewrite (Object_Decl, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'D'), + Access_Definition => Empty, + Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc), + Name => Call_Deref)); + + Set_Renamed_Object (Defining_Identifier (Object_Decl), Call_Deref); + + Analyze (Object_Decl); + + -- Replace the internal identifier of the renaming declaration's + -- entity with identifier of the original object entity. We also have + -- to exchange the entities containing their defining identifiers to + -- ensure the correct replacement of the object declaration by the + -- object renaming declaration to avoid homograph conflicts (since + -- the object declaration's defining identifier was already entered + -- in current scope). The Next_Entity links of the two entities also + -- have to be swapped since the entities are part of the return + -- scope's entity list and the list structure would otherwise be + -- corrupted. Finally, the homonym chain must be preserved as well. + + declare + Renaming_Def_Id : constant Entity_Id := + Defining_Identifier (Object_Decl); + Next_Entity_Temp : constant Entity_Id := + Next_Entity (Renaming_Def_Id); + begin + Set_Chars (Renaming_Def_Id, Chars (Obj_Def_Id)); + + -- Swap next entity links in preparation for exchanging entities + + Set_Next_Entity (Renaming_Def_Id, Next_Entity (Obj_Def_Id)); + Set_Next_Entity (Obj_Def_Id, Next_Entity_Temp); + Set_Homonym (Renaming_Def_Id, Homonym (Obj_Def_Id)); + + Exchange_Entities (Renaming_Def_Id, Obj_Def_Id); + + -- Preserve source indication of original declaration, so that + -- xref information is properly generated for the right entity. + + Preserve_Comes_From_Source + (Object_Decl, Original_Node (Object_Decl)); + Set_Comes_From_Source (Obj_Def_Id, True); + Set_Comes_From_Source (Renaming_Def_Id, False); + end; + end if; + + -- If the object entity has a class-wide Etype, then we need to change + -- it to the result subtype of the function call, because otherwise the + -- object will be class-wide without an explicit initialization and + -- won't be allocated properly by the back end. It seems unclean to make + -- such a revision to the type at this point, and we should try to + -- improve this treatment when build-in-place functions with class-wide + -- results are implemented. ??? + + if Is_Class_Wide_Type (Etype (Defining_Identifier (Object_Decl))) then + Set_Etype (Defining_Identifier (Object_Decl), Result_Subt); + end if; + end Make_Build_In_Place_Call_In_Object_Declaration; + + -------------------------- + -- Needs_BIP_Final_List -- + -------------------------- + + function Needs_BIP_Final_List (E : Entity_Id) return Boolean is + pragma Assert (Is_Build_In_Place_Function (E)); + Result_Subt : constant Entity_Id := Underlying_Type (Etype (E)); + + begin + -- We need the BIP_Final_List if the result type needs finalization. We + -- also need it for tagged types, even if not class-wide, because some + -- type extension might need finalization, and all overriding functions + -- must have the same calling conventions. However, if there is a + -- pragma Restrictions (No_Finalization), we never need this parameter. + + return (Needs_Finalization (Result_Subt) + or else Is_Tagged_Type (Underlying_Type (Result_Subt))) + and then not Restriction_Active (No_Finalization); + end Needs_BIP_Final_List; + +end Exp_Ch6; diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads new file mode 100644 index 000000000..e04e217e8 --- /dev/null +++ b/gcc/ada/exp_ch6.ads @@ -0,0 +1,166 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 6 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for chapter 6 constructs + +with Types; use Types; + +package Exp_Ch6 is + + procedure Expand_N_Extended_Return_Statement (N : Node_Id); + procedure Expand_N_Function_Call (N : Node_Id); + procedure Expand_N_Procedure_Call_Statement (N : Node_Id); + procedure Expand_N_Simple_Return_Statement (N : Node_Id); + procedure Expand_N_Subprogram_Body (N : Node_Id); + procedure Expand_N_Subprogram_Body_Stub (N : Node_Id); + procedure Expand_N_Subprogram_Declaration (N : Node_Id); + + procedure Expand_Call (N : Node_Id); + -- This procedure contains common processing for Expand_N_Function_Call, + -- Expand_N_Procedure_Statement, and Expand_N_Entry_Call. + + procedure Freeze_Subprogram (N : Node_Id); + -- generate the appropriate expansions related to Subprogram freeze + -- nodes (e.g. the filling of the corresponding Dispatch Table for + -- Primitive Operations) + + -- The following type defines the various forms of allocation used for the + -- results of build-in-place function calls. + + type BIP_Allocation_Form is + (Unspecified, + Caller_Allocation, + Secondary_Stack, + Global_Heap, + User_Storage_Pool); + + type BIP_Formal_Kind is + -- Ada 2005 (AI-318-02): This type defines the kinds of implicit extra + -- formals created for build-in-place functions. The order of the above + -- enumeration literals matches the order in which the formals are + -- declared. See Sem_Ch6.Create_Extra_Formals. + (BIP_Alloc_Form, + -- Present if result subtype is unconstrained, or if the result type + -- is tagged. Indicates whether the return object is allocated by the + -- caller or callee, and if the callee, whether to use the secondary + -- stack or the heap. See Create_Extra_Formals. + BIP_Final_List, + -- Present if result type needs finalization. Pointer to caller's + -- finalization list. + BIP_Master, + -- Present if result type contains tasks. Master associated with + -- calling context. + BIP_Activation_Chain, + -- Present if result type contains tasks. Caller's activation chain + BIP_Object_Access); + -- Present for all build-in-place functions. Address at which to place + -- the return object, or null if BIP_Alloc_Form indicates + -- allocated by callee. + -- ??? We also need to be able to pass in some way to access a + -- user-defined storage pool at some point. And perhaps a constrained + -- flag. + + function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String; + -- Ada 2005 (AI-318-02): Returns a string to be used as the suffix of names + -- for build-in-place formal parameters of the given kind. + + function Build_In_Place_Formal + (Func : Entity_Id; + Kind : BIP_Formal_Kind) return Entity_Id; + -- Ada 2005 (AI-318-02): Locates and returns the entity for the implicit + -- build-in-place formal parameter of the given kind associated with the + -- function Func, and returns its Entity_Id. It is a bug if not found; the + -- caller should ensure this is called only when the extra formal exists. + + function Is_Build_In_Place_Function (E : Entity_Id) return Boolean; + -- Ada 2005 (AI-318-02): Returns True if E denotes a function, generic + -- function, or access-to-function type whose result must be built in + -- place; otherwise returns False. For Ada 2005, this is currently + -- restricted to the set of functions whose result subtype is an inherently + -- limited type. In Ada 95, this must be False for inherently limited + -- result types (but currently returns False for all Ada 95 functions). + -- Eventually we plan to support build-in-place for nonlimited types. + -- Build-in-place is usually more efficient for large things, and less + -- efficient for small things. However, we never use build-in-place if the + -- convention is other than Ada, because that would disturb mixed-language + -- programs. Note that for the non-inherently-limited cases, we must make + -- the same decision for Ada 95 and 2005, so that mixed-dialect programs + -- will work. + + function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean; + -- Ada 2005 (AI-318-02): Returns True if N denotes a call to a function + -- that requires handling as a build-in-place call or is a qualified + -- expression applied to such a call; otherwise returns False. + + procedure Make_Build_In_Place_Call_In_Allocator + (Allocator : Node_Id; + Function_Call : Node_Id); + -- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that + -- occurs as the expression initializing an allocator, by passing access + -- to the allocated object as an additional parameter of the function call. + -- A new access object is declared that is initialized to the result of the + -- allocator, passed to the function, and the allocator is rewritten to + -- refer to that access object. Function_Call must denote either an + -- N_Function_Call node for which Is_Build_In_Place_Call is True, or else + -- an N_Qualified_Expression node applied to such a function call. + + procedure Make_Build_In_Place_Call_In_Anonymous_Context + (Function_Call : Node_Id); + -- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that + -- occurs in a context that does not provide a separate object. A temporary + -- object is created to act as the return object and an access to the + -- temporary is passed as an additional parameter of the call. This occurs + -- in contexts such as subprogram call actuals and object renamings. + -- Function_Call must denote either an N_Function_Call node for which + -- Is_Build_In_Place_Call is True, or else an N_Qualified_Expression node + -- applied to such a function call. + + procedure Make_Build_In_Place_Call_In_Assignment + (Assign : Node_Id; + Function_Call : Node_Id); + -- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that + -- occurs as the right-hand side of an assignment statement by passing + -- access to the left-hand side as an additional parameter of the function + -- call. Assign must denote a N_Assignment_Statement. Function_Call must + -- denote either an N_Function_Call node for which Is_Build_In_Place_Call + -- is True, or an N_Qualified_Expression node applied to such a function + -- call. + + procedure Make_Build_In_Place_Call_In_Object_Declaration + (Object_Decl : Node_Id; + Function_Call : Node_Id); + -- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that + -- occurs as the expression initializing an object declaration by + -- passing access to the declared object as an additional parameter of the + -- function call. Function_Call must denote either an N_Function_Call node + -- for which Is_Build_In_Place_Call is True, or an N_Qualified_Expression + -- node applied to such a function call. + + function Needs_BIP_Final_List (E : Entity_Id) return Boolean; + -- ???pragma Precondition (Is_Build_In_Place_Function (E)); + -- Ada 2005 (AI-318-02): Returns True if the function needs the + -- BIP_Final_List implicit parameter. + +end Exp_Ch6; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb new file mode 100644 index 000000000..ebfac59d4 --- /dev/null +++ b/gcc/ada/exp_ch7.adb @@ -0,0 +1,3631 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 7 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains virtually all expansion mechanisms related to +-- - controlled types +-- - transient scopes + +with Atree; use Atree; +with Debug; use Debug; +with Einfo; use Einfo; +with Errout; use Errout; +with Exp_Ch9; use Exp_Ch9; +with Exp_Ch11; use Exp_Ch11; +with Exp_Dbug; use Exp_Dbug; +with Exp_Dist; use Exp_Dist; +with Exp_Disp; use Exp_Disp; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Lib; use Lib; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Output; use Output; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sinfo; use Sinfo; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch7; use Sem_Ch7; +with Sem_Ch8; use Sem_Ch8; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Snames; use Snames; +with Stand; use Stand; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +package body Exp_Ch7 is + + -------------------------------- + -- Transient Scope Management -- + -------------------------------- + + -- A transient scope is created when temporary objects are created by the + -- compiler. These temporary objects are allocated on the secondary stack + -- and the transient scope is responsible for finalizing the object when + -- appropriate and reclaiming the memory at the right time. The temporary + -- objects are generally the objects allocated to store the result of a + -- function returning an unconstrained or a tagged value. Expressions + -- needing to be wrapped in a transient scope (functions calls returning + -- unconstrained or tagged values) may appear in 3 different contexts which + -- lead to 3 different kinds of transient scope expansion: + + -- 1. In a simple statement (procedure call, assignment, ...). In + -- this case the instruction is wrapped into a transient block. + -- (See Wrap_Transient_Statement for details) + + -- 2. In an expression of a control structure (test in a IF statement, + -- expression in a CASE statement, ...). + -- (See Wrap_Transient_Expression for details) + + -- 3. In a expression of an object_declaration. No wrapping is possible + -- here, so the finalization actions, if any, are done right after the + -- declaration and the secondary stack deallocation is done in the + -- proper enclosing scope (see Wrap_Transient_Declaration for details) + + -- Note about functions returning tagged types: it has been decided to + -- always allocate their result in the secondary stack, even though is not + -- absolutely mandatory when the tagged type is constrained because the + -- caller knows the size of the returned object and thus could allocate the + -- result in the primary stack. An exception to this is when the function + -- builds its result in place, as is done for functions with inherently + -- limited result types for Ada 2005. In that case, certain callers may + -- pass the address of a constrained object as the target object for the + -- function result. + + -- By allocating tagged results in the secondary stack a number of + -- implementation difficulties are avoided: + + -- - If it is a dispatching function call, the computation of the size of + -- the result is possible but complex from the outside. + + -- - If the returned type is controlled, the assignment of the returned + -- value to the anonymous object involves an Adjust, and we have no + -- easy way to access the anonymous object created by the back end. + + -- - If the returned type is class-wide, this is an unconstrained type + -- anyway. + + -- Furthermore, the small loss in efficiency which is the result of this + -- decision is not such a big deal because functions returning tagged types + -- are not as common in practice compared to functions returning access to + -- a tagged type. + + -------------------------------------------------- + -- Transient Blocks and Finalization Management -- + -------------------------------------------------- + + function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id; + -- N is a node which may generate a transient scope. Loop over the parent + -- pointers of N until it find the appropriate node to wrap. If it returns + -- Empty, it means that no transient scope is needed in this context. + + function Make_Clean + (N : Node_Id; + Clean : Entity_Id; + Mark : Entity_Id; + Flist : Entity_Id; + Is_Task : Boolean; + Is_Master : Boolean; + Is_Protected_Subprogram : Boolean; + Is_Task_Allocation_Block : Boolean; + Is_Asynchronous_Call_Block : Boolean; + Chained_Cleanup_Action : Node_Id) return Node_Id; + -- Expand the clean-up procedure for a controlled and/or transient block, + -- and/or task master or task body, or a block used to implement task + -- allocation or asynchronous entry calls, or a procedure used to implement + -- protected procedures. Clean is the entity for such a procedure. Mark + -- is the entity for the secondary stack mark, if empty only controlled + -- block clean-up will be performed. Flist is the entity for the local + -- final list, if empty only transient scope clean-up will be performed. + -- The flags Is_Task and Is_Master control the calls to the corresponding + -- finalization actions for a task body or for an entity that is a task + -- master. Finally if Chained_Cleanup_Action is present, it is a reference + -- to a previous cleanup procedure, a call to which is appended at the + -- end of the generated one. + + procedure Set_Node_To_Be_Wrapped (N : Node_Id); + -- Set the field Node_To_Be_Wrapped of the current scope + + procedure Insert_Actions_In_Scope_Around (N : Node_Id); + -- Insert the before-actions kept in the scope stack before N, and the + -- after-actions after N, which must be a member of a list. + + function Make_Transient_Block + (Loc : Source_Ptr; + Action : Node_Id) return Node_Id; + -- Create a transient block whose name is Scope, which is also a controlled + -- block if Flist is not empty and whose only code is Action (either a + -- single statement or single declaration). + + type Final_Primitives is (Initialize_Case, Adjust_Case, Finalize_Case); + -- This enumeration type is defined in order to ease sharing code for + -- building finalization procedures for composite types. + + Name_Of : constant array (Final_Primitives) of Name_Id := + (Initialize_Case => Name_Initialize, + Adjust_Case => Name_Adjust, + Finalize_Case => Name_Finalize); + + Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type := + (Initialize_Case => TSS_Deep_Initialize, + Adjust_Case => TSS_Deep_Adjust, + Finalize_Case => TSS_Deep_Finalize); + + procedure Build_Record_Deep_Procs (Typ : Entity_Id); + -- Build the deep Initialize/Adjust/Finalize for a record Typ with + -- Has_Component_Component set and store them using the TSS mechanism. + + procedure Build_Array_Deep_Procs (Typ : Entity_Id); + -- Build the deep Initialize/Adjust/Finalize for a record Typ with + -- Has_Controlled_Component set and store them using the TSS mechanism. + + function Make_Deep_Proc + (Prim : Final_Primitives; + Typ : Entity_Id; + Stmts : List_Id) return Node_Id; + -- This function generates the tree for Deep_Initialize, Deep_Adjust or + -- Deep_Finalize procedures according to the first parameter, these + -- procedures operate on the type Typ. The Stmts parameter gives the body + -- of the procedure. + + function Make_Deep_Array_Body + (Prim : Final_Primitives; + Typ : Entity_Id) return List_Id; + -- This function generates the list of statements for implementing + -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to + -- the first parameter, these procedures operate on the array type Typ. + + function Make_Deep_Record_Body + (Prim : Final_Primitives; + Typ : Entity_Id) return List_Id; + -- This function generates the list of statements for implementing + -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to + -- the first parameter, these procedures operate on the record type Typ. + + procedure Check_Visibly_Controlled + (Prim : Final_Primitives; + Typ : Entity_Id; + E : in out Entity_Id; + Cref : in out Node_Id); + -- The controlled operation declared for a derived type may not be + -- overriding, if the controlled operations of the parent type are + -- hidden, for example when the parent is a private type whose full + -- view is controlled. For other primitive operations we modify the + -- name of the operation to indicate that it is not overriding, but + -- this is not possible for Initialize, etc. because they have to be + -- retrievable by name. Before generating the proper call to one of + -- these operations we check whether Typ is known to be controlled at + -- the point of definition. If it is not then we must retrieve the + -- hidden operation of the parent and use it instead. This is one + -- case that might be solved more cleanly once Overriding pragmas or + -- declarations are in place. + + function Convert_View + (Proc : Entity_Id; + Arg : Node_Id; + Ind : Pos := 1) return Node_Id; + -- Proc is one of the Initialize/Adjust/Finalize operations, and + -- Arg is the argument being passed to it. Ind indicates which + -- formal of procedure Proc we are trying to match. This function + -- will, if necessary, generate an conversion between the partial + -- and full view of Arg to match the type of the formal of Proc, + -- or force a conversion to the class-wide type in the case where + -- the operation is abstract. + + ----------------------------- + -- Finalization Management -- + ----------------------------- + + -- This part describe how Initialization/Adjustment/Finalization procedures + -- are generated and called. Two cases must be considered, types that are + -- Controlled (Is_Controlled flag set) and composite types that contain + -- controlled components (Has_Controlled_Component flag set). In the first + -- case the procedures to call are the user-defined primitive operations + -- Initialize/Adjust/Finalize. In the second case, GNAT generates + -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge + -- of calling the former procedures on the controlled components. + + -- For records with Has_Controlled_Component set, a hidden "controller" + -- component is inserted. This controller component contains its own + -- finalization list on which all controlled components are attached + -- creating an indirection on the upper-level Finalization list. This + -- technique facilitates the management of objects whose number of + -- controlled components changes during execution. This controller + -- component is itself controlled and is attached to the upper-level + -- finalization chain. Its adjust primitive is in charge of calling adjust + -- on the components and adjusting the finalization pointer to match their + -- new location (see a-finali.adb). + + -- It is not possible to use a similar technique for arrays that have + -- Has_Controlled_Component set. In this case, deep procedures are + -- generated that call initialize/adjust/finalize + attachment or + -- detachment on the finalization list for all component. + + -- Initialize calls: they are generated for declarations or dynamic + -- allocations of Controlled objects with no initial value. They are always + -- followed by an attachment to the current Finalization Chain. For the + -- dynamic allocation case this the chain attached to the scope of the + -- access type definition otherwise, this is the chain of the current + -- scope. + + -- Adjust Calls: They are generated on 2 occasions: (1) for + -- declarations or dynamic allocations of Controlled objects with an + -- initial value. (2) after an assignment. In the first case they are + -- followed by an attachment to the final chain, in the second case + -- they are not. + + -- Finalization Calls: They are generated on (1) scope exit, (2) + -- assignments, (3) unchecked deallocations. In case (3) they have to + -- be detached from the final chain, in case (2) they must not and in + -- case (1) this is not important since we are exiting the scope anyway. + + -- Other details: + + -- Type extensions will have a new record controller at each derivation + -- level containing controlled components. The record controller for + -- the parent/ancestor is attached to the finalization list of the + -- extension's record controller (i.e. the parent is like a component + -- of the extension). + + -- For types that are both Is_Controlled and Has_Controlled_Components, + -- the record controller and the object itself are handled separately. + -- It could seem simpler to attach the object at the end of its record + -- controller but this would not tackle view conversions properly. + + -- A classwide type can always potentially have controlled components + -- but the record controller of the corresponding actual type may not + -- be known at compile time so the dispatch table contains a special + -- field that allows to compute the offset of the record controller + -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset. + + -- Here is a simple example of the expansion of a controlled block : + + -- declare + -- X : Controlled; + -- Y : Controlled := Init; + -- + -- type R is record + -- C : Controlled; + -- end record; + -- W : R; + -- Z : R := (C => X); + -- begin + -- X := Y; + -- W := Z; + -- end; + -- + -- is expanded into + -- + -- declare + -- _L : System.FI.Finalizable_Ptr; + + -- procedure _Clean is + -- begin + -- Abort_Defer; + -- System.FI.Finalize_List (_L); + -- Abort_Undefer; + -- end _Clean; + + -- X : Controlled; + -- begin + -- Abort_Defer; + -- Initialize (X); + -- Attach_To_Final_List (_L, Finalizable (X), 1); + -- at end: Abort_Undefer; + -- Y : Controlled := Init; + -- Adjust (Y); + -- Attach_To_Final_List (_L, Finalizable (Y), 1); + -- + -- type R is record + -- _C : Record_Controller; + -- C : Controlled; + -- end record; + -- W : R; + -- begin + -- Abort_Defer; + -- Deep_Initialize (W, _L, 1); + -- at end: Abort_Under; + -- Z : R := (C => X); + -- Deep_Adjust (Z, _L, 1); + + -- begin + -- _Assign (X, Y); + -- Deep_Finalize (W, False); + -- + -- W := Z; + -- + -- Deep_Adjust (W, _L, 0); + -- at end + -- _Clean; + -- end; + + function Global_Flist_Ref (Flist_Ref : Node_Id) return Boolean; + -- Return True if Flist_Ref refers to a global final list, either the + -- object Global_Final_List which is used to attach standalone objects, + -- or any of the list controllers associated with library-level access + -- to controlled objects. + + procedure Clean_Simple_Protected_Objects (N : Node_Id); + -- Protected objects without entries are not controlled types, and the + -- locks have to be released explicitly when such an object goes out + -- of scope. Traverse declarations in scope to determine whether such + -- objects are present. + + ---------------------------- + -- Build_Array_Deep_Procs -- + ---------------------------- + + procedure Build_Array_Deep_Procs (Typ : Entity_Id) is + begin + Set_TSS (Typ, + Make_Deep_Proc ( + Prim => Initialize_Case, + Typ => Typ, + Stmts => Make_Deep_Array_Body (Initialize_Case, Typ))); + + if not Is_Immutably_Limited_Type (Typ) then + Set_TSS (Typ, + Make_Deep_Proc ( + Prim => Adjust_Case, + Typ => Typ, + Stmts => Make_Deep_Array_Body (Adjust_Case, Typ))); + end if; + + Set_TSS (Typ, + Make_Deep_Proc ( + Prim => Finalize_Case, + Typ => Typ, + Stmts => Make_Deep_Array_Body (Finalize_Case, Typ))); + end Build_Array_Deep_Procs; + + ----------------------------- + -- Build_Controlling_Procs -- + ----------------------------- + + procedure Build_Controlling_Procs (Typ : Entity_Id) is + begin + if Is_Array_Type (Typ) then + Build_Array_Deep_Procs (Typ); + + else pragma Assert (Is_Record_Type (Typ)); + Build_Record_Deep_Procs (Typ); + end if; + end Build_Controlling_Procs; + + ---------------------- + -- Build_Final_List -- + ---------------------- + + procedure Build_Final_List (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Decl : Node_Id; + + begin + Set_Associated_Final_Chain (Typ, + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Typ), 'L'))); + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => + Associated_Final_Chain (Typ), + Object_Definition => + New_Reference_To + (RTE (RE_List_Controller), Loc)); + + -- If the type is declared in a package declaration and designates a + -- Taft amendment type that requires finalization, place declaration + -- of finalization list in the body, because no client of the package + -- can create objects of the type and thus make use of this list. This + -- ensures the tree for the spec is identical whenever it is compiled. + + if Has_Completion_In_Body (Directly_Designated_Type (Typ)) + and then In_Package_Body (Current_Scope) + and then Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body + and then + Nkind (Parent (Declaration_Node (Typ))) = N_Package_Specification + then + Insert_Action (Parent (Designated_Type (Typ)), Decl); + + -- The type may have been frozen already, and this is a late freezing + -- action, in which case the declaration must be elaborated at once. + -- If the call is for an allocator, the chain must also be created now, + -- because the freezing of the type does not build one. Otherwise, the + -- declaration is one of the freezing actions for a user-defined type. + + elsif Is_Frozen (Typ) + or else (Nkind (N) = N_Allocator + and then Ekind (Etype (N)) = E_Anonymous_Access_Type) + then + Insert_Action (N, Decl); + + else + Append_Freeze_Action (Typ, Decl); + end if; + end Build_Final_List; + + --------------------- + -- Build_Late_Proc -- + --------------------- + + procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is + begin + for Final_Prim in Name_Of'Range loop + if Name_Of (Final_Prim) = Nam then + Set_TSS (Typ, + Make_Deep_Proc ( + Prim => Final_Prim, + Typ => Typ, + Stmts => Make_Deep_Record_Body (Final_Prim, Typ))); + end if; + end loop; + end Build_Late_Proc; + + ----------------------------- + -- Build_Record_Deep_Procs -- + ----------------------------- + + procedure Build_Record_Deep_Procs (Typ : Entity_Id) is + begin + Set_TSS (Typ, + Make_Deep_Proc ( + Prim => Initialize_Case, + Typ => Typ, + Stmts => Make_Deep_Record_Body (Initialize_Case, Typ))); + + if not Is_Immutably_Limited_Type (Typ) then + Set_TSS (Typ, + Make_Deep_Proc ( + Prim => Adjust_Case, + Typ => Typ, + Stmts => Make_Deep_Record_Body (Adjust_Case, Typ))); + end if; + + Set_TSS (Typ, + Make_Deep_Proc ( + Prim => Finalize_Case, + Typ => Typ, + Stmts => Make_Deep_Record_Body (Finalize_Case, Typ))); + end Build_Record_Deep_Procs; + + ------------------- + -- Cleanup_Array -- + ------------------- + + function Cleanup_Array + (N : Node_Id; + Obj : Node_Id; + Typ : Entity_Id) return List_Id + is + Loc : constant Source_Ptr := Sloc (N); + Index_List : constant List_Id := New_List; + + function Free_Component return List_Id; + -- Generate the code to finalize the task or protected subcomponents + -- of a single component of the array. + + function Free_One_Dimension (Dim : Int) return List_Id; + -- Generate a loop over one dimension of the array + + -------------------- + -- Free_Component -- + -------------------- + + function Free_Component return List_Id is + Stmts : List_Id := New_List; + Tsk : Node_Id; + C_Typ : constant Entity_Id := Component_Type (Typ); + + begin + -- Component type is known to contain tasks or protected objects + + Tsk := + Make_Indexed_Component (Loc, + Prefix => Duplicate_Subexpr_No_Checks (Obj), + Expressions => Index_List); + + Set_Etype (Tsk, C_Typ); + + if Is_Task_Type (C_Typ) then + Append_To (Stmts, Cleanup_Task (N, Tsk)); + + elsif Is_Simple_Protected_Type (C_Typ) then + Append_To (Stmts, Cleanup_Protected_Object (N, Tsk)); + + elsif Is_Record_Type (C_Typ) then + Stmts := Cleanup_Record (N, Tsk, C_Typ); + + elsif Is_Array_Type (C_Typ) then + Stmts := Cleanup_Array (N, Tsk, C_Typ); + end if; + + return Stmts; + end Free_Component; + + ------------------------ + -- Free_One_Dimension -- + ------------------------ + + function Free_One_Dimension (Dim : Int) return List_Id is + Index : Entity_Id; + + begin + if Dim > Number_Dimensions (Typ) then + return Free_Component; + + -- Here we generate the required loop + + else + Index := Make_Temporary (Loc, 'J'); + Append (New_Reference_To (Index, Loc), Index_List); + + return New_List ( + Make_Implicit_Loop_Statement (N, + Identifier => Empty, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Index, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Obj), + Attribute_Name => Name_Range, + Expressions => New_List ( + Make_Integer_Literal (Loc, Dim))))), + Statements => Free_One_Dimension (Dim + 1))); + end if; + end Free_One_Dimension; + + -- Start of processing for Cleanup_Array + + begin + return Free_One_Dimension (1); + end Cleanup_Array; + + -------------------- + -- Cleanup_Record -- + -------------------- + + function Cleanup_Record + (N : Node_Id; + Obj : Node_Id; + Typ : Entity_Id) return List_Id + is + Loc : constant Source_Ptr := Sloc (N); + Tsk : Node_Id; + Comp : Entity_Id; + Stmts : constant List_Id := New_List; + U_Typ : constant Entity_Id := Underlying_Type (Typ); + + begin + if Has_Discriminants (U_Typ) + and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration + and then + Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition + and then + Present + (Variant_Part + (Component_List (Type_Definition (Parent (U_Typ))))) + then + -- For now, do not attempt to free a component that may appear in + -- a variant, and instead issue a warning. Doing this "properly" + -- would require building a case statement and would be quite a + -- mess. Note that the RM only requires that free "work" for the + -- case of a task access value, so already we go way beyond this + -- in that we deal with the array case and non-discriminated + -- record cases. + + Error_Msg_N + ("task/protected object in variant record will not be freed?", N); + return New_List (Make_Null_Statement (Loc)); + end if; + + Comp := First_Component (Typ); + + while Present (Comp) loop + if Has_Task (Etype (Comp)) + or else Has_Simple_Protected_Object (Etype (Comp)) + then + Tsk := + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr_No_Checks (Obj), + Selector_Name => New_Occurrence_Of (Comp, Loc)); + Set_Etype (Tsk, Etype (Comp)); + + if Is_Task_Type (Etype (Comp)) then + Append_To (Stmts, Cleanup_Task (N, Tsk)); + + elsif Is_Simple_Protected_Type (Etype (Comp)) then + Append_To (Stmts, Cleanup_Protected_Object (N, Tsk)); + + elsif Is_Record_Type (Etype (Comp)) then + + -- Recurse, by generating the prefix of the argument to + -- the eventual cleanup call. + + Append_List_To + (Stmts, Cleanup_Record (N, Tsk, Etype (Comp))); + + elsif Is_Array_Type (Etype (Comp)) then + Append_List_To + (Stmts, Cleanup_Array (N, Tsk, Etype (Comp))); + end if; + end if; + + Next_Component (Comp); + end loop; + + return Stmts; + end Cleanup_Record; + + ------------------------------ + -- Cleanup_Protected_Object -- + ------------------------------ + + function Cleanup_Protected_Object + (N : Node_Id; + Ref : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + + begin + return + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Finalize_Protection), Loc), + Parameter_Associations => New_List ( + Concurrent_Ref (Ref))); + end Cleanup_Protected_Object; + + ------------------------------------ + -- Clean_Simple_Protected_Objects -- + ------------------------------------ + + procedure Clean_Simple_Protected_Objects (N : Node_Id) is + Stmts : constant List_Id := Statements (Handled_Statement_Sequence (N)); + Stmt : Node_Id := Last (Stmts); + E : Entity_Id; + + begin + E := First_Entity (Current_Scope); + while Present (E) loop + if (Ekind (E) = E_Variable + or else Ekind (E) = E_Constant) + and then Has_Simple_Protected_Object (Etype (E)) + and then not Has_Task (Etype (E)) + and then Nkind (Parent (E)) /= N_Object_Renaming_Declaration + then + declare + Typ : constant Entity_Id := Etype (E); + Ref : constant Node_Id := New_Occurrence_Of (E, Sloc (Stmt)); + + begin + if Is_Simple_Protected_Type (Typ) then + Append_To (Stmts, Cleanup_Protected_Object (N, Ref)); + + elsif Has_Simple_Protected_Object (Typ) then + if Is_Record_Type (Typ) then + Append_List_To (Stmts, Cleanup_Record (N, Ref, Typ)); + + elsif Is_Array_Type (Typ) then + Append_List_To (Stmts, Cleanup_Array (N, Ref, Typ)); + end if; + end if; + end; + end if; + + Next_Entity (E); + end loop; + + -- Analyze inserted cleanup statements + + if Present (Stmt) then + Stmt := Next (Stmt); + + while Present (Stmt) loop + Analyze (Stmt); + Next (Stmt); + end loop; + end if; + end Clean_Simple_Protected_Objects; + + ------------------ + -- Cleanup_Task -- + ------------------ + + function Cleanup_Task + (N : Node_Id; + Ref : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + begin + return + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Free_Task), Loc), + Parameter_Associations => + New_List (Concurrent_Ref (Ref))); + end Cleanup_Task; + + --------------------------------- + -- Has_Simple_Protected_Object -- + --------------------------------- + + function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is + Comp : Entity_Id; + + begin + if Is_Simple_Protected_Type (T) then + return True; + + elsif Is_Array_Type (T) then + return Has_Simple_Protected_Object (Component_Type (T)); + + elsif Is_Record_Type (T) then + Comp := First_Component (T); + + while Present (Comp) loop + if Has_Simple_Protected_Object (Etype (Comp)) then + return True; + end if; + + Next_Component (Comp); + end loop; + + return False; + + else + return False; + end if; + end Has_Simple_Protected_Object; + + ------------------------------ + -- Is_Simple_Protected_Type -- + ------------------------------ + + function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is + begin + return Is_Protected_Type (T) and then not Has_Entries (T); + end Is_Simple_Protected_Type; + + ------------------------------ + -- Check_Visibly_Controlled -- + ------------------------------ + + procedure Check_Visibly_Controlled + (Prim : Final_Primitives; + Typ : Entity_Id; + E : in out Entity_Id; + Cref : in out Node_Id) + is + Parent_Type : Entity_Id; + Op : Entity_Id; + + begin + if Is_Derived_Type (Typ) + and then Comes_From_Source (E) + and then not Present (Overridden_Operation (E)) + then + -- We know that the explicit operation on the type does not override + -- the inherited operation of the parent, and that the derivation + -- is from a private type that is not visibly controlled. + + Parent_Type := Etype (Typ); + Op := Find_Prim_Op (Parent_Type, Name_Of (Prim)); + + if Present (Op) then + E := Op; + + -- Wrap the object to be initialized into the proper + -- unchecked conversion, to be compatible with the operation + -- to be called. + + if Nkind (Cref) = N_Unchecked_Type_Conversion then + Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref)); + else + Cref := Unchecked_Convert_To (Parent_Type, Cref); + end if; + end if; + end if; + end Check_Visibly_Controlled; + + ------------------------------- + -- CW_Or_Has_Controlled_Part -- + ------------------------------- + + function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is + begin + return Is_Class_Wide_Type (T) or else Needs_Finalization (T); + end CW_Or_Has_Controlled_Part; + + -------------------------- + -- Controller_Component -- + -------------------------- + + function Controller_Component (Typ : Entity_Id) return Entity_Id is + T : Entity_Id := Base_Type (Typ); + Comp : Entity_Id; + Comp_Scop : Entity_Id; + Res : Entity_Id := Empty; + Res_Scop : Entity_Id := Empty; + + begin + if Is_Class_Wide_Type (T) then + T := Root_Type (T); + end if; + + if Is_Private_Type (T) then + T := Underlying_Type (T); + end if; + + -- Fetch the outermost controller + + Comp := First_Entity (T); + while Present (Comp) loop + if Chars (Comp) = Name_uController then + Comp_Scop := Scope (Original_Record_Component (Comp)); + + -- If this controller is at the outermost level, no need to + -- look for another one + + if Comp_Scop = T then + return Comp; + + -- Otherwise record the outermost one and continue looking + + elsif Res = Empty or else Is_Ancestor (Res_Scop, Comp_Scop) then + Res := Comp; + Res_Scop := Comp_Scop; + end if; + end if; + + Next_Entity (Comp); + end loop; + + -- If we fall through the loop, there is no controller component + + return Res; + end Controller_Component; + + ------------------ + -- Convert_View -- + ------------------ + + function Convert_View + (Proc : Entity_Id; + Arg : Node_Id; + Ind : Pos := 1) return Node_Id + is + Fent : Entity_Id := First_Entity (Proc); + Ftyp : Entity_Id; + Atyp : Entity_Id; + + begin + for J in 2 .. Ind loop + Next_Entity (Fent); + end loop; + + Ftyp := Etype (Fent); + + if Nkind_In (Arg, N_Type_Conversion, N_Unchecked_Type_Conversion) then + Atyp := Entity (Subtype_Mark (Arg)); + else + Atyp := Etype (Arg); + end if; + + if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then + return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg); + + elsif Ftyp /= Atyp + and then Present (Atyp) + and then + (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp)) + and then + Base_Type (Underlying_Type (Atyp)) = + Base_Type (Underlying_Type (Ftyp)) + then + return Unchecked_Convert_To (Ftyp, Arg); + + -- If the argument is already a conversion, as generated by + -- Make_Init_Call, set the target type to the type of the formal + -- directly, to avoid spurious typing problems. + + elsif Nkind_In (Arg, N_Unchecked_Type_Conversion, N_Type_Conversion) + and then not Is_Class_Wide_Type (Atyp) + then + Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg))); + Set_Etype (Arg, Ftyp); + return Arg; + + else + return Arg; + end if; + end Convert_View; + + ------------------------------- + -- Establish_Transient_Scope -- + ------------------------------- + + -- This procedure is called each time a transient block has to be inserted + -- that is to say for each call to a function with unconstrained or tagged + -- result. It creates a new scope on the stack scope in order to enclose + -- all transient variables generated + + procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean) is + Loc : constant Source_Ptr := Sloc (N); + Wrap_Node : Node_Id; + + begin + -- Nothing to do for virtual machines where memory is GCed + + if VM_Target /= No_VM then + return; + end if; + + -- Do not create a transient scope if we are already inside one + + for S in reverse Scope_Stack.First .. Scope_Stack.Last loop + if Scope_Stack.Table (S).Is_Transient then + if Sec_Stack then + Set_Uses_Sec_Stack (Scope_Stack.Table (S).Entity); + end if; + + return; + + -- If we have encountered Standard there are no enclosing + -- transient scopes. + + elsif Scope_Stack.Table (S).Entity = Standard_Standard then + exit; + + end if; + end loop; + + Wrap_Node := Find_Node_To_Be_Wrapped (N); + + -- Case of no wrap node, false alert, no transient scope needed + + if No (Wrap_Node) then + null; + + -- If the node to wrap is an iteration_scheme, the expression is + -- one of the bounds, and the expansion will make an explicit + -- declaration for it (see Analyze_Iteration_Scheme, sem_ch5.adb), + -- so do not apply any transformations here. + + elsif Nkind (Wrap_Node) = N_Iteration_Scheme then + null; + + else + Push_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B')); + Set_Scope_Is_Transient; + + if Sec_Stack then + Set_Uses_Sec_Stack (Current_Scope); + Check_Restriction (No_Secondary_Stack, N); + end if; + + Set_Etype (Current_Scope, Standard_Void_Type); + Set_Node_To_Be_Wrapped (Wrap_Node); + + if Debug_Flag_W then + Write_Str (" "); + Write_Eol; + end if; + end if; + end Establish_Transient_Scope; + + ---------------------------- + -- Expand_Cleanup_Actions -- + ---------------------------- + + procedure Expand_Cleanup_Actions (N : Node_Id) is + S : constant Entity_Id := Current_Scope; + Flist : constant Entity_Id := Finalization_Chain_Entity (S); + Is_Task : constant Boolean := Nkind (Original_Node (N)) = N_Task_Body; + + Is_Master : constant Boolean := + Nkind (N) /= N_Entry_Body + and then Is_Task_Master (N); + Is_Protected : constant Boolean := + Nkind (N) = N_Subprogram_Body + and then Is_Protected_Subprogram_Body (N); + Is_Task_Allocation : constant Boolean := + Nkind (N) = N_Block_Statement + and then Is_Task_Allocation_Block (N); + Is_Asynchronous_Call : constant Boolean := + Nkind (N) = N_Block_Statement + and then Is_Asynchronous_Call_Block (N); + + Previous_At_End_Proc : constant Node_Id := + At_End_Proc (Handled_Statement_Sequence (N)); + + Clean : Entity_Id; + Loc : Source_Ptr; + Mark : Entity_Id := Empty; + New_Decls : constant List_Id := New_List; + Blok : Node_Id; + End_Lab : Node_Id; + Wrapped : Boolean; + Chain : Entity_Id := Empty; + Decl : Node_Id; + Old_Poll : Boolean; + + begin + -- If we are generating expanded code for debugging purposes, use + -- the Sloc of the point of insertion for the cleanup code. The Sloc + -- will be updated subsequently to reference the proper line in the + -- .dg file. If we are not debugging generated code, use instead + -- No_Location, so that no debug information is generated for the + -- cleanup code. This makes the behavior of the NEXT command in GDB + -- monotonic, and makes the placement of breakpoints more accurate. + + if Debug_Generated_Code then + Loc := Sloc (S); + else + Loc := No_Location; + end if; + + -- There are cleanup actions only if the secondary stack needs + -- releasing or some finalizations are needed or in the context + -- of tasking + + if Uses_Sec_Stack (Current_Scope) + and then not Sec_Stack_Needed_For_Return (Current_Scope) + then + null; + elsif No (Flist) + and then not Is_Master + and then not Is_Task + and then not Is_Protected + and then not Is_Task_Allocation + and then not Is_Asynchronous_Call + then + Clean_Simple_Protected_Objects (N); + return; + end if; + + -- If the current scope is the subprogram body that is the rewriting + -- of a task body, and the descriptors have not been delayed (due to + -- some nested instantiations) do not generate redundant cleanup + -- actions: the cleanup procedure already exists for this body. + + if Nkind (N) = N_Subprogram_Body + and then Nkind (Original_Node (N)) = N_Task_Body + and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N)) + then + return; + end if; + + -- Set polling off, since we don't need to poll during cleanup + -- actions, and indeed for the cleanup routine, which is executed + -- with aborts deferred, we don't want polling. + + Old_Poll := Polling_Required; + Polling_Required := False; + + -- Make sure we have a declaration list, since we will add to it + + if No (Declarations (N)) then + Set_Declarations (N, New_List); + end if; + + -- The task activation call has already been built for task + -- allocation blocks. + + if not Is_Task_Allocation then + Build_Task_Activation_Call (N); + end if; + + if Is_Master then + Establish_Task_Master (N); + end if; + + -- If secondary stack is in use, expand: + -- _Mxx : constant Mark_Id := SS_Mark; + + -- Suppress calls to SS_Mark and SS_Release if VM_Target, + -- since we never use the secondary stack on the VM. + + if Uses_Sec_Stack (Current_Scope) + and then not Sec_Stack_Needed_For_Return (Current_Scope) + and then VM_Target = No_VM + then + Mark := Make_Temporary (Loc, 'M'); + Append_To (New_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Mark, + Object_Definition => New_Reference_To (RTE (RE_Mark_Id), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_SS_Mark), Loc)))); + + Set_Uses_Sec_Stack (Current_Scope, False); + end if; + + -- If finalization list is present then expand: + -- Local_Final_List : System.FI.Finalizable_Ptr; + + if Present (Flist) then + Append_To (New_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Flist, + Object_Definition => + New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); + end if; + + -- Clean-up procedure definition + + Clean := Make_Defining_Identifier (Loc, Name_uClean); + Set_Suppress_Elaboration_Warnings (Clean); + Append_To (New_Decls, + Make_Clean (N, Clean, Mark, Flist, + Is_Task, + Is_Master, + Is_Protected, + Is_Task_Allocation, + Is_Asynchronous_Call, + Previous_At_End_Proc)); + + -- The previous AT END procedure, if any, has been captured in Clean: + -- reset it to Empty now because we check further on that we never + -- overwrite an existing AT END call. + + Set_At_End_Proc (Handled_Statement_Sequence (N), Empty); + + -- If exception handlers are present, wrap the Sequence of statements in + -- a block because it is not possible to get exception handlers and an + -- AT END call in the same scope. + + if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then + + -- Preserve end label to provide proper cross-reference information + + End_Lab := End_Label (Handled_Statement_Sequence (N)); + Blok := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => Handled_Statement_Sequence (N)); + Set_Handled_Statement_Sequence (N, + Make_Handled_Sequence_Of_Statements (Loc, New_List (Blok))); + Set_End_Label (Handled_Statement_Sequence (N), End_Lab); + Wrapped := True; + + -- Comment needed here, see RH for 1.306 ??? + + if Nkind (N) = N_Subprogram_Body then + Set_Has_Nested_Block_With_Handler (Current_Scope); + end if; + + -- Otherwise we do not wrap + + else + Wrapped := False; + Blok := Empty; + end if; + + -- Don't move the _chain Activation_Chain declaration in task + -- allocation blocks. Task allocation blocks use this object + -- in their cleanup handlers, and gigi complains if it is declared + -- in the sequence of statements of the scope that declares the + -- handler. + + if Is_Task_Allocation then + Chain := Activation_Chain_Entity (N); + + Decl := First (Declarations (N)); + while Nkind (Decl) /= N_Object_Declaration + or else Defining_Identifier (Decl) /= Chain + loop + Next (Decl); + pragma Assert (Present (Decl)); + end loop; + + Remove (Decl); + Prepend_To (New_Decls, Decl); + end if; + + -- Now we move the declarations into the Sequence of statements + -- in order to get them protected by the AT END call. It may seem + -- weird to put declarations in the sequence of statement but in + -- fact nothing forbids that at the tree level. We also set the + -- First_Real_Statement field so that we remember where the real + -- statements (i.e. original statements) begin. Note that if we + -- wrapped the statements, the first real statement is inside the + -- inner block. If the First_Real_Statement is already set (as is + -- the case for subprogram bodies that are expansions of task bodies) + -- then do not reset it, because its declarative part would migrate + -- to the statement part. + + if not Wrapped then + if No (First_Real_Statement (Handled_Statement_Sequence (N))) then + Set_First_Real_Statement (Handled_Statement_Sequence (N), + First (Statements (Handled_Statement_Sequence (N)))); + end if; + + else + Set_First_Real_Statement (Handled_Statement_Sequence (N), Blok); + end if; + + Append_List_To (Declarations (N), + Statements (Handled_Statement_Sequence (N))); + Set_Statements (Handled_Statement_Sequence (N), Declarations (N)); + + -- We need to reset the Sloc of the handled statement sequence to + -- properly reflect the new initial "statement" in the sequence. + + Set_Sloc + (Handled_Statement_Sequence (N), Sloc (First (Declarations (N)))); + + -- The declarations of the _Clean procedure and finalization chain + -- replace the old declarations that have been moved inward. + + Set_Declarations (N, New_Decls); + Analyze_Declarations (New_Decls); + + -- The At_End call is attached to the sequence of statements + + declare + HSS : Node_Id; + + begin + -- If the construct is a protected subprogram, then the call to + -- the corresponding unprotected subprogram appears in a block which + -- is the last statement in the body, and it is this block that must + -- be covered by the At_End handler. + + if Is_Protected then + HSS := Handled_Statement_Sequence + (Last (Statements (Handled_Statement_Sequence (N)))); + else + HSS := Handled_Statement_Sequence (N); + end if; + + -- Never overwrite an existing AT END call + + pragma Assert (No (At_End_Proc (HSS))); + + Set_At_End_Proc (HSS, New_Occurrence_Of (Clean, Loc)); + Expand_At_End_Handler (HSS, Empty); + end; + + -- Restore saved polling mode + + Polling_Required := Old_Poll; + end Expand_Cleanup_Actions; + + ------------------------------- + -- Expand_Ctrl_Function_Call -- + ------------------------------- + + procedure Expand_Ctrl_Function_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Rtype : constant Entity_Id := Etype (N); + Utype : constant Entity_Id := Underlying_Type (Rtype); + Ref : Node_Id; + Action : Node_Id; + Action2 : Node_Id := Empty; + + Attach_Level : Uint := Uint_1; + Len_Ref : Node_Id := Empty; + + function Last_Array_Component + (Ref : Node_Id; + Typ : Entity_Id) return Node_Id; + -- Creates a reference to the last component of the array object + -- designated by Ref whose type is Typ. + + -------------------------- + -- Last_Array_Component -- + -------------------------- + + function Last_Array_Component + (Ref : Node_Id; + Typ : Entity_Id) return Node_Id + is + Index_List : constant List_Id := New_List; + + begin + for N in 1 .. Number_Dimensions (Typ) loop + Append_To (Index_List, + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr_No_Checks (Ref), + Attribute_Name => Name_Last, + Expressions => New_List ( + Make_Integer_Literal (Loc, N)))); + end loop; + + return + Make_Indexed_Component (Loc, + Prefix => Duplicate_Subexpr (Ref), + Expressions => Index_List); + end Last_Array_Component; + + -- Start of processing for Expand_Ctrl_Function_Call + + begin + -- Optimization, if the returned value (which is on the sec-stack) is + -- returned again, no need to copy/readjust/finalize, we can just pass + -- the value thru (see Expand_N_Simple_Return_Statement), and thus no + -- attachment is needed + + if Nkind (Parent (N)) = N_Simple_Return_Statement then + return; + end if; + + -- Resolution is now finished, make sure we don't start analysis again + -- because of the duplication. + + Set_Analyzed (N); + Ref := Duplicate_Subexpr_No_Checks (N); + + -- Now we can generate the Attach Call. Note that this value is always + -- on the (secondary) stack and thus is attached to a singly linked + -- final list: + + -- Resx := F (X)'reference; + -- Attach_To_Final_List (_Lx, Resx.all, 1); + + -- or when there are controlled components: + + -- Attach_To_Final_List (_Lx, Resx._controller, 1); + + -- or when it is both Is_Controlled and Has_Controlled_Components: + + -- Attach_To_Final_List (_Lx, Resx._controller, 1); + -- Attach_To_Final_List (_Lx, Resx, 1); + + -- or if it is an array with Is_Controlled (and Has_Controlled) + + -- Attach_To_Final_List (_Lx, Resx (Resx'last), 3); + + -- An attach level of 3 means that a whole array is to be attached to + -- the finalization list (including the controlled components). + + -- or if it is an array with Has_Controlled_Components but not + -- Is_Controlled: + + -- Attach_To_Final_List (_Lx, Resx (Resx'last)._controller, 3); + + -- Case where type has controlled components + + if Has_Controlled_Component (Rtype) then + declare + T1 : Entity_Id := Rtype; + T2 : Entity_Id := Utype; + + begin + if Is_Array_Type (T2) then + Len_Ref := + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr_Move_Checks + (Unchecked_Convert_To (T2, Ref)), + Attribute_Name => Name_Length); + end if; + + while Is_Array_Type (T2) loop + if T1 /= T2 then + Ref := Unchecked_Convert_To (T2, Ref); + end if; + + Ref := Last_Array_Component (Ref, T2); + Attach_Level := Uint_3; + T1 := Component_Type (T2); + T2 := Underlying_Type (T1); + end loop; + + -- If the type has controlled components, go to the controller + -- except in the case of arrays of controlled objects since in + -- this case objects and their components are already chained + -- and the head of the chain is the last array element. + + if Is_Array_Type (Rtype) and then Is_Controlled (T2) then + null; + + elsif Has_Controlled_Component (T2) then + if T1 /= T2 then + Ref := Unchecked_Convert_To (T2, Ref); + end if; + + Ref := + Make_Selected_Component (Loc, + Prefix => Ref, + Selector_Name => Make_Identifier (Loc, Name_uController)); + end if; + end; + + -- Here we know that 'Ref' has a controller so we may as well attach + -- it directly. + + Action := + Make_Attach_Call ( + Obj_Ref => Ref, + Flist_Ref => Find_Final_List (Current_Scope), + With_Attach => Make_Integer_Literal (Loc, Attach_Level)); + + -- If it is also Is_Controlled we need to attach the global object + + if Is_Controlled (Rtype) then + Action2 := + Make_Attach_Call ( + Obj_Ref => Duplicate_Subexpr_No_Checks (N), + Flist_Ref => Find_Final_List (Current_Scope), + With_Attach => Make_Integer_Literal (Loc, Attach_Level)); + end if; + + -- Here, we have a controlled type that does not seem to have controlled + -- components but it could be a class wide type whose further + -- derivations have controlled components. So we don't know if the + -- object itself needs to be attached or if it has a record controller. + -- We need to call a runtime function (Deep_Tag_Attach) which knows what + -- to do thanks to the RC_Offset in the dispatch table. + + else + Action := + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Deep_Tag_Attach), Loc), + Parameter_Associations => New_List ( + Find_Final_List (Current_Scope), + + Make_Attribute_Reference (Loc, + Prefix => Ref, + Attribute_Name => Name_Address), + + Make_Integer_Literal (Loc, Attach_Level))); + end if; + + if Present (Len_Ref) then + Action := + Make_Implicit_If_Statement (N, + Condition => Make_Op_Gt (Loc, + Left_Opnd => Len_Ref, + Right_Opnd => Make_Integer_Literal (Loc, 0)), + Then_Statements => New_List (Action)); + end if; + + Insert_Action (N, Action); + if Present (Action2) then + Insert_Action (N, Action2); + end if; + end Expand_Ctrl_Function_Call; + + --------------------------- + -- Expand_N_Package_Body -- + --------------------------- + + -- Add call to Activate_Tasks if body is an activator (actual processing + -- is in chapter 9). + + -- Generate subprogram descriptor for elaboration routine + + -- Encode entity names in package body + + procedure Expand_N_Package_Body (N : Node_Id) is + Ent : constant Entity_Id := Corresponding_Spec (N); + + begin + -- This is done only for non-generic packages + + if Ekind (Ent) = E_Package then + Push_Scope (Corresponding_Spec (N)); + + -- Build dispatch tables of library level tagged types + + if Is_Library_Level_Entity (Ent) then + Build_Static_Dispatch_Tables (N); + end if; + + Build_Task_Activation_Call (N); + Pop_Scope; + end if; + + Set_Elaboration_Flag (N, Corresponding_Spec (N)); + Set_In_Package_Body (Ent, False); + + -- Set to encode entity names in package body before gigi is called + + Qualify_Entity_Names (N); + end Expand_N_Package_Body; + + ---------------------------------- + -- Expand_N_Package_Declaration -- + ---------------------------------- + + -- Add call to Activate_Tasks if there are tasks declared and the package + -- has no body. Note that in Ada83, this may result in premature activation + -- of some tasks, given that we cannot tell whether a body will eventually + -- appear. + + procedure Expand_N_Package_Declaration (N : Node_Id) is + Spec : constant Node_Id := Specification (N); + Id : constant Entity_Id := Defining_Entity (N); + Decls : List_Id; + No_Body : Boolean := False; + -- True in the case of a package declaration that is a compilation unit + -- and for which no associated body will be compiled in + -- this compilation. + + begin + -- Case of a package declaration other than a compilation unit + + if Nkind (Parent (N)) /= N_Compilation_Unit then + null; + + -- Case of a compilation unit that does not require a body + + elsif not Body_Required (Parent (N)) + and then not Unit_Requires_Body (Id) + then + No_Body := True; + + -- Special case of generating calling stubs for a remote call interface + -- package: even though the package declaration requires one, the + -- body won't be processed in this compilation (so any stubs for RACWs + -- declared in the package must be generated here, along with the + -- spec). + + elsif Parent (N) = Cunit (Main_Unit) + and then Is_Remote_Call_Interface (Id) + and then Distribution_Stub_Mode = Generate_Caller_Stub_Body + then + No_Body := True; + end if; + + -- For a package declaration that implies no associated body, generate + -- task activation call and RACW supporting bodies now (since we won't + -- have a specific separate compilation unit for that). + + if No_Body then + Push_Scope (Id); + + if Has_RACW (Id) then + + -- Generate RACW subprogram bodies + + Decls := Private_Declarations (Spec); + + if No (Decls) then + Decls := Visible_Declarations (Spec); + end if; + + if No (Decls) then + Decls := New_List; + Set_Visible_Declarations (Spec, Decls); + end if; + + Append_RACW_Bodies (Decls, Id); + Analyze_List (Decls); + end if; + + if Present (Activation_Chain_Entity (N)) then + + -- Generate task activation call as last step of elaboration + + Build_Task_Activation_Call (N); + end if; + + Pop_Scope; + end if; + + -- Build dispatch tables of library level tagged types + + if Is_Compilation_Unit (Id) + or else (Is_Generic_Instance (Id) + and then Is_Library_Level_Entity (Id)) + then + Build_Static_Dispatch_Tables (N); + end if; + + -- Note: it is not necessary to worry about generating a subprogram + -- descriptor, since the only way to get exception handlers into a + -- package spec is to include instantiations, and that would cause + -- generation of subprogram descriptors to be delayed in any case. + + -- Set to encode entity names in package spec before gigi is called + + Qualify_Entity_Names (N); + end Expand_N_Package_Declaration; + + --------------------- + -- Find_Final_List -- + --------------------- + + function Find_Final_List + (E : Entity_Id; + Ref : Node_Id := Empty) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Ref); + S : Entity_Id; + Id : Entity_Id; + R : Node_Id; + + begin + -- If the restriction No_Finalization applies, then there's not any + -- finalization list available to return, so return Empty. + + if Restriction_Active (No_Finalization) then + return Empty; + + -- Case of an internal component. The Final list is the record + -- controller of the enclosing record. + + elsif Present (Ref) then + R := Ref; + loop + case Nkind (R) is + when N_Unchecked_Type_Conversion | N_Type_Conversion => + R := Expression (R); + + when N_Indexed_Component | N_Explicit_Dereference => + R := Prefix (R); + + when N_Selected_Component => + R := Prefix (R); + exit; + + when N_Identifier => + exit; + + when others => + raise Program_Error; + end case; + end loop; + + return + Make_Selected_Component (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => R, + Selector_Name => Make_Identifier (Loc, Name_uController)), + Selector_Name => Make_Identifier (Loc, Name_F)); + + -- Case of a dynamically allocated object whose access type has an + -- Associated_Final_Chain. The final list is the corresponding list + -- controller (the next entity in the scope of the access type with + -- the right type). If the type comes from a With_Type clause, no + -- controller was created, we use the global chain instead. (The code + -- related to with_type clauses should presumably be removed at some + -- point since that feature is obsolete???) + + -- An anonymous access type either has a list created for it when the + -- allocator is a for an access parameter or an access discriminant, + -- or else it uses the list of the enclosing dynamic scope, when the + -- context is a declaration or an assignment. + + elsif Is_Access_Type (E) + and then (Present (Associated_Final_Chain (E)) + or else From_With_Type (E)) + then + if From_With_Type (E) then + return New_Reference_To (RTE (RE_Global_Final_List), Sloc (E)); + + -- Use the access type's associated finalization chain + + else + return + Make_Selected_Component (Loc, + Prefix => + New_Reference_To + (Associated_Final_Chain (Base_Type (E)), Loc), + Selector_Name => Make_Identifier (Loc, Name_F)); + end if; + + else + S := Nearest_Dynamic_Scope (E); + + -- When the finalization chain entity is 'Error', it means that there + -- should not be any chain at that level and that the enclosing one + -- should be used. + + -- This is a nasty kludge, see ??? note in exp_ch11 + + while Finalization_Chain_Entity (S) = Error loop + S := Enclosing_Dynamic_Scope (S); + end loop; + + if S = Standard_Standard then + return New_Reference_To (RTE (RE_Global_Final_List), Sloc (E)); + else + if No (Finalization_Chain_Entity (S)) then + + -- In the case where the scope is a subprogram, retrieve the + -- Sloc of subprogram's body for association with the chain, + -- since using the Sloc of the spec would be confusing during + -- source-line stepping within the debugger. + + declare + Flist_Loc : Source_Ptr := Sloc (S); + Subp_Body : Node_Id; + + begin + if Ekind (S) in Subprogram_Kind then + Subp_Body := Unit_Declaration_Node (S); + + if Nkind (Subp_Body) /= N_Subprogram_Body then + Subp_Body := Corresponding_Body (Subp_Body); + end if; + + if Present (Subp_Body) then + Flist_Loc := Sloc (Subp_Body); + end if; + end if; + + Id := Make_Temporary (Flist_Loc, 'F'); + end; + + Set_Finalization_Chain_Entity (S, Id); + + -- Set momentarily some semantics attributes to allow normal + -- analysis of expansions containing references to this chain. + -- Will be fully decorated during the expansion of the scope + -- itself. + + Set_Ekind (Id, E_Variable); + Set_Etype (Id, RTE (RE_Finalizable_Ptr)); + end if; + + return New_Reference_To (Finalization_Chain_Entity (S), Sloc (E)); + end if; + end if; + end Find_Final_List; + + ----------------------------- + -- Find_Node_To_Be_Wrapped -- + ----------------------------- + + function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is + P : Node_Id; + The_Parent : Node_Id; + + begin + The_Parent := N; + loop + P := The_Parent; + pragma Assert (P /= Empty); + The_Parent := Parent (P); + + case Nkind (The_Parent) is + + -- Simple statement can be wrapped + + when N_Pragma => + return The_Parent; + + -- Usually assignments are good candidate for wrapping + -- except when they have been generated as part of a + -- controlled aggregate where the wrapping should take + -- place more globally. + + when N_Assignment_Statement => + if No_Ctrl_Actions (The_Parent) then + null; + else + return The_Parent; + end if; + + -- An entry call statement is a special case if it occurs in + -- the context of a Timed_Entry_Call. In this case we wrap + -- the entire timed entry call. + + when N_Entry_Call_Statement | + N_Procedure_Call_Statement => + if Nkind (Parent (The_Parent)) = N_Entry_Call_Alternative + and then Nkind_In (Parent (Parent (The_Parent)), + N_Timed_Entry_Call, + N_Conditional_Entry_Call) + then + return Parent (Parent (The_Parent)); + else + return The_Parent; + end if; + + -- Object declarations are also a boundary for the transient scope + -- even if they are not really wrapped + -- (see Wrap_Transient_Declaration) + + when N_Object_Declaration | + N_Object_Renaming_Declaration | + N_Subtype_Declaration => + return The_Parent; + + -- The expression itself is to be wrapped if its parent is a + -- compound statement or any other statement where the expression + -- is known to be scalar + + when N_Accept_Alternative | + N_Attribute_Definition_Clause | + N_Case_Statement | + N_Code_Statement | + N_Delay_Alternative | + N_Delay_Until_Statement | + N_Delay_Relative_Statement | + N_Discriminant_Association | + N_Elsif_Part | + N_Entry_Body_Formal_Part | + N_Exit_Statement | + N_If_Statement | + N_Iteration_Scheme | + N_Terminate_Alternative => + return P; + + when N_Attribute_Reference => + + if Is_Procedure_Attribute_Name + (Attribute_Name (The_Parent)) + then + return The_Parent; + end if; + + -- A raise statement can be wrapped. This will arise when the + -- expression in a raise_with_expression uses the secondary + -- stack, for example. + + when N_Raise_Statement => + return The_Parent; + + -- If the expression is within the iteration scheme of a loop, + -- we must create a declaration for it, followed by an assignment + -- in order to have a usable statement to wrap. + + when N_Loop_Parameter_Specification => + return Parent (The_Parent); + + -- The following nodes contains "dummy calls" which don't + -- need to be wrapped. + + when N_Parameter_Specification | + N_Discriminant_Specification | + N_Component_Declaration => + return Empty; + + -- The return statement is not to be wrapped when the function + -- itself needs wrapping at the outer-level + + when N_Simple_Return_Statement => + declare + Applies_To : constant Entity_Id := + Return_Applies_To + (Return_Statement_Entity (The_Parent)); + Return_Type : constant Entity_Id := Etype (Applies_To); + begin + if Requires_Transient_Scope (Return_Type) then + return Empty; + else + return The_Parent; + end if; + end; + + -- If we leave a scope without having been able to find a node to + -- wrap, something is going wrong but this can happen in error + -- situation that are not detected yet (such as a dynamic string + -- in a pragma export) + + when N_Subprogram_Body | + N_Package_Declaration | + N_Package_Body | + N_Block_Statement => + return Empty; + + -- otherwise continue the search + + when others => + null; + end case; + end loop; + end Find_Node_To_Be_Wrapped; + + ---------------------- + -- Global_Flist_Ref -- + ---------------------- + + function Global_Flist_Ref (Flist_Ref : Node_Id) return Boolean is + Flist : Entity_Id; + + begin + -- Look for the Global_Final_List + + if Is_Entity_Name (Flist_Ref) then + Flist := Entity (Flist_Ref); + + -- Look for the final list associated with an access to controlled + + elsif Nkind (Flist_Ref) = N_Selected_Component + and then Is_Entity_Name (Prefix (Flist_Ref)) + then + Flist := Entity (Prefix (Flist_Ref)); + else + return False; + end if; + + return Present (Flist) + and then Present (Scope (Flist)) + and then Enclosing_Dynamic_Scope (Flist) = Standard_Standard; + end Global_Flist_Ref; + + ---------------------------------- + -- Has_New_Controlled_Component -- + ---------------------------------- + + function Has_New_Controlled_Component (E : Entity_Id) return Boolean is + Comp : Entity_Id; + + begin + if not Is_Tagged_Type (E) then + return Has_Controlled_Component (E); + elsif not Is_Derived_Type (E) then + return Has_Controlled_Component (E); + end if; + + Comp := First_Component (E); + while Present (Comp) loop + + if Chars (Comp) = Name_uParent then + null; + + elsif Scope (Original_Record_Component (Comp)) = E + and then Needs_Finalization (Etype (Comp)) + then + return True; + end if; + + Next_Component (Comp); + end loop; + + return False; + end Has_New_Controlled_Component; + + -------------------------- + -- In_Finalization_Root -- + -------------------------- + + -- It would seem simpler to test Scope (RTE (RE_Root_Controlled)) but + -- the purpose of this function is to avoid a circular call to Rtsfind + -- which would been caused by such a test. + + function In_Finalization_Root (E : Entity_Id) return Boolean is + S : constant Entity_Id := Scope (E); + + begin + return Chars (Scope (S)) = Name_System + and then Chars (S) = Name_Finalization_Root + and then Scope (Scope (S)) = Standard_Standard; + end In_Finalization_Root; + + ------------------------------------ + -- Insert_Actions_In_Scope_Around -- + ------------------------------------ + + procedure Insert_Actions_In_Scope_Around (N : Node_Id) is + SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); + Target : Node_Id; + + begin + -- If the node to be wrapped is the triggering statement of an + -- asynchronous select, it is not part of a statement list. The + -- actions must be inserted before the Select itself, which is + -- part of some list of statements. Note that the triggering + -- alternative includes the triggering statement and an optional + -- statement list. If the node to be wrapped is part of that list, + -- the normal insertion applies. + + if Nkind (Parent (Node_To_Be_Wrapped)) = N_Triggering_Alternative + and then not Is_List_Member (Node_To_Be_Wrapped) + then + Target := Parent (Parent (Node_To_Be_Wrapped)); + else + Target := N; + end if; + + if Present (SE.Actions_To_Be_Wrapped_Before) then + Insert_List_Before (Target, SE.Actions_To_Be_Wrapped_Before); + SE.Actions_To_Be_Wrapped_Before := No_List; + end if; + + if Present (SE.Actions_To_Be_Wrapped_After) then + Insert_List_After (Target, SE.Actions_To_Be_Wrapped_After); + SE.Actions_To_Be_Wrapped_After := No_List; + end if; + end Insert_Actions_In_Scope_Around; + + ----------------------- + -- Make_Adjust_Call -- + ----------------------- + + function Make_Adjust_Call + (Ref : Node_Id; + Typ : Entity_Id; + Flist_Ref : Node_Id; + With_Attach : Node_Id; + Allocator : Boolean := False) return List_Id + is + Loc : constant Source_Ptr := Sloc (Ref); + Res : constant List_Id := New_List; + Utyp : Entity_Id; + Proc : Entity_Id; + Cref : Node_Id := Ref; + Cref2 : Node_Id; + Attach : Node_Id := With_Attach; + + begin + if Is_Class_Wide_Type (Typ) then + Utyp := Underlying_Type (Base_Type (Root_Type (Typ))); + else + Utyp := Underlying_Type (Base_Type (Typ)); + end if; + + Set_Assignment_OK (Cref); + + -- Deal with non-tagged derivation of private views + + if Is_Untagged_Derivation (Typ) then + Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); + Cref := Unchecked_Convert_To (Utyp, Cref); + Set_Assignment_OK (Cref); + -- To prevent problems with UC see 1.156 RH ??? + end if; + + -- If the underlying_type is a subtype, we are dealing with + -- the completion of a private type. We need to access + -- the base type and generate a conversion to it. + + if Utyp /= Base_Type (Utyp) then + pragma Assert (Is_Private_Type (Typ)); + Utyp := Base_Type (Utyp); + Cref := Unchecked_Convert_To (Utyp, Cref); + end if; + + -- If the object is unanalyzed, set its expected type for use + -- in Convert_View in case an additional conversion is needed. + + if No (Etype (Cref)) + and then Nkind (Cref) /= N_Unchecked_Type_Conversion + then + Set_Etype (Cref, Typ); + end if; + + -- We do not need to attach to one of the Global Final Lists + -- the objects whose type is Finalize_Storage_Only + + if Finalize_Storage_Only (Typ) + and then (Global_Flist_Ref (Flist_Ref) + or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) + = Standard_True) + then + Attach := Make_Integer_Literal (Loc, 0); + end if; + + -- Special case for allocators: need initialization of the chain + -- pointers. For the 0 case, reset them to null. + + if Allocator then + pragma Assert (Nkind (Attach) = N_Integer_Literal); + + if Intval (Attach) = 0 then + Set_Intval (Attach, Uint_4); + end if; + end if; + + -- Generate: + -- Deep_Adjust (Flist_Ref, Ref, Attach); + + if Has_Controlled_Component (Utyp) + or else Is_Class_Wide_Type (Typ) + then + if Is_Tagged_Type (Utyp) then + Proc := Find_Prim_Op (Utyp, TSS_Deep_Adjust); + + else + Proc := TSS (Utyp, TSS_Deep_Adjust); + end if; + + Cref := Convert_View (Proc, Cref, 2); + + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => + New_List (Flist_Ref, Cref, Attach))); + + -- Generate: + -- if With_Attach then + -- Attach_To_Final_List (Ref, Flist_Ref); + -- end if; + -- Adjust (Ref); + + else -- Is_Controlled (Utyp) + + Proc := Find_Prim_Op (Utyp, Name_Of (Adjust_Case)); + Cref := Convert_View (Proc, Cref); + Cref2 := New_Copy_Tree (Cref); + + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => New_List (Cref2))); + + Append_To (Res, Make_Attach_Call (Cref, Flist_Ref, Attach)); + end if; + + return Res; + end Make_Adjust_Call; + + ---------------------- + -- Make_Attach_Call -- + ---------------------- + + -- Generate: + -- System.FI.Attach_To_Final_List (Flist, Ref, Nb_Link) + + function Make_Attach_Call + (Obj_Ref : Node_Id; + Flist_Ref : Node_Id; + With_Attach : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Obj_Ref); + + begin + -- Optimization: If the number of links is statically '0', don't + -- call the attach_proc. + + if Nkind (With_Attach) = N_Integer_Literal + and then Intval (With_Attach) = Uint_0 + then + return Make_Null_Statement (Loc); + end if; + + return + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Attach_To_Final_List), Loc), + Parameter_Associations => New_List ( + Flist_Ref, + OK_Convert_To (RTE (RE_Finalizable), Obj_Ref), + With_Attach)); + end Make_Attach_Call; + + ---------------- + -- Make_Clean -- + ---------------- + + function Make_Clean + (N : Node_Id; + Clean : Entity_Id; + Mark : Entity_Id; + Flist : Entity_Id; + Is_Task : Boolean; + Is_Master : Boolean; + Is_Protected_Subprogram : Boolean; + Is_Task_Allocation_Block : Boolean; + Is_Asynchronous_Call_Block : Boolean; + Chained_Cleanup_Action : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Clean); + Stmt : constant List_Id := New_List; + + Sbody : Node_Id; + Spec : Node_Id; + Name : Node_Id; + Param : Node_Id; + Param_Type : Entity_Id; + Pid : Entity_Id := Empty; + Cancel_Param : Entity_Id; + + begin + if Is_Task then + if Restricted_Profile then + Append_To + (Stmt, Build_Runtime_Call (Loc, RE_Complete_Restricted_Task)); + else + Append_To (Stmt, Build_Runtime_Call (Loc, RE_Complete_Task)); + end if; + + elsif Is_Master then + if Restriction_Active (No_Task_Hierarchy) = False then + Append_To (Stmt, Build_Runtime_Call (Loc, RE_Complete_Master)); + end if; + + elsif Is_Protected_Subprogram then + + -- Add statements to the cleanup handler of the (ordinary) + -- subprogram expanded to implement a protected subprogram, + -- unlocking the protected object parameter and undeferring abort. + -- If this is a protected procedure, and the object contains + -- entries, this also calls the entry service routine. + + -- NOTE: This cleanup handler references _object, a parameter + -- to the procedure. + + -- Find the _object parameter representing the protected object + + Spec := Parent (Corresponding_Spec (N)); + + Param := First (Parameter_Specifications (Spec)); + loop + Param_Type := Etype (Parameter_Type (Param)); + + if Ekind (Param_Type) = E_Record_Type then + Pid := Corresponding_Concurrent_Type (Param_Type); + end if; + + exit when No (Param) or else Present (Pid); + Next (Param); + end loop; + + pragma Assert (Present (Param)); + + -- If the associated protected object declares entries, + -- a protected procedure has to service entry queues. + -- In this case, add + + -- Service_Entries (_object._object'Access); + + -- _object is the record used to implement the protected object. + -- It is a parameter to the protected subprogram. + + if Nkind (Specification (N)) = N_Procedure_Specification + and then Has_Entries (Pid) + then + case Corresponding_Runtime_Package (Pid) is + when System_Tasking_Protected_Objects_Entries => + Name := New_Reference_To (RTE (RE_Service_Entries), Loc); + + when System_Tasking_Protected_Objects_Single_Entry => + Name := New_Reference_To (RTE (RE_Service_Entry), Loc); + + when others => + raise Program_Error; + end case; + + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => Name, + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => + New_Reference_To (Defining_Identifier (Param), Loc), + Selector_Name => + Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access)))); + + else + -- Unlock (_object._object'Access); + + -- object is the record used to implement the protected object. + -- It is a parameter to the protected subprogram. + + case Corresponding_Runtime_Package (Pid) is + when System_Tasking_Protected_Objects_Entries => + Name := New_Reference_To (RTE (RE_Unlock_Entries), Loc); + + when System_Tasking_Protected_Objects_Single_Entry => + Name := New_Reference_To (RTE (RE_Unlock_Entry), Loc); + + when System_Tasking_Protected_Objects => + Name := New_Reference_To (RTE (RE_Unlock), Loc); + + when others => + raise Program_Error; + end case; + + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => Name, + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => + New_Reference_To (Defining_Identifier (Param), Loc), + Selector_Name => + Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access)))); + end if; + + if Abort_Allowed then + + -- Abort_Undefer; + + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + RTE (RE_Abort_Undefer), Loc), + Parameter_Associations => Empty_List)); + end if; + + elsif Is_Task_Allocation_Block then + + -- Add a call to Expunge_Unactivated_Tasks to the cleanup + -- handler of a block created for the dynamic allocation of + -- tasks: + + -- Expunge_Unactivated_Tasks (_chain); + + -- where _chain is the list of tasks created by the allocator + -- but not yet activated. This list will be empty unless + -- the block completes abnormally. + + -- This only applies to dynamically allocated tasks; + -- other unactivated tasks are completed by Complete_Task or + -- Complete_Master. + + -- NOTE: This cleanup handler references _chain, a local + -- object. + + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + RTE (RE_Expunge_Unactivated_Tasks), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Activation_Chain_Entity (N), Loc)))); + + elsif Is_Asynchronous_Call_Block then + + -- Add a call to attempt to cancel the asynchronous entry call + -- whenever the block containing the abortable part is exited. + + -- NOTE: This cleanup handler references C, a local object + + -- Get the argument to the Cancel procedure + Cancel_Param := Entry_Cancel_Parameter (Entity (Identifier (N))); + + -- If it is of type Communication_Block, this must be a + -- protected entry call. + + if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then + + Append_To (Stmt, + + -- if Enqueued (Cancel_Parameter) then + + Make_Implicit_If_Statement (Clean, + Condition => Make_Function_Call (Loc, + Name => New_Reference_To ( + RTE (RE_Enqueued), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Cancel_Param, Loc))), + Then_Statements => New_List ( + + -- Cancel_Protected_Entry_Call (Cancel_Param); + + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + RTE (RE_Cancel_Protected_Entry_Call), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Cancel_Param, Loc)))))); + + -- Asynchronous delay + + elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Cancel_Async_Delay), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Cancel_Param, Loc), + Attribute_Name => Name_Unchecked_Access)))); + + -- Task entry call + + else + -- Append call to Cancel_Task_Entry_Call (C); + + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + RTE (RE_Cancel_Task_Entry_Call), + Loc), + Parameter_Associations => New_List ( + New_Reference_To (Cancel_Param, Loc)))); + + end if; + end if; + + if Present (Flist) then + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Finalize_List), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Flist, Loc)))); + end if; + + if Present (Mark) then + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_SS_Release), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Mark, Loc)))); + end if; + + if Present (Chained_Cleanup_Action) then + Append_To (Stmt, + Make_Procedure_Call_Statement (Loc, + Name => Chained_Cleanup_Action)); + end if; + + Sbody := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Clean), + + Declarations => New_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmt)); + + if Present (Flist) or else Is_Task or else Is_Master then + Wrap_Cleanup_Procedure (Sbody); + end if; + + -- We do not want debug information for _Clean routines, + -- since it just confuses the debugging operation unless + -- we are debugging generated code. + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Clean, True); + end if; + + return Sbody; + end Make_Clean; + + -------------------------- + -- Make_Deep_Array_Body -- + -------------------------- + + -- Array components are initialized and adjusted in the normal order + -- and finalized in the reverse order. Exceptions are handled and + -- Program_Error is re-raise in the Adjust and Finalize case + -- (RM 7.6.1(12)). Generate the following code : + -- + -- procedure Deep_

-- with

being Initialize or Adjust or Finalize + -- (L : in out Finalizable_Ptr; + -- V : in out Typ) + -- is + -- begin + -- for J1 in Typ'First (1) .. Typ'Last (1) loop + -- ^ reverse ^ -- in the finalization case + -- ... + -- for J2 in Typ'First (n) .. Typ'Last (n) loop + -- Make_

_Call (Typ, V (J1, .. , Jn), L, V); + -- end loop; + -- ... + -- end loop; + -- exception -- not in the + -- when others => raise Program_Error; -- Initialize case + -- end Deep_

; + + function Make_Deep_Array_Body + (Prim : Final_Primitives; + Typ : Entity_Id) return List_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + + Index_List : constant List_Id := New_List; + -- Stores the list of references to the indexes (one per dimension) + + function One_Component return List_Id; + -- Create one statement to initialize/adjust/finalize one array + -- component, designated by a full set of indexes. + + function One_Dimension (N : Int) return List_Id; + -- Create loop to deal with one dimension of the array. The single + -- statement in the body of the loop initializes the inner dimensions if + -- any, or else a single component. + + ------------------- + -- One_Component -- + ------------------- + + function One_Component return List_Id is + Comp_Typ : constant Entity_Id := Component_Type (Typ); + Comp_Ref : constant Node_Id := + Make_Indexed_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Expressions => Index_List); + + begin + -- Set the etype of the component Reference, which is used to + -- determine whether a conversion to a parent type is needed. + + Set_Etype (Comp_Ref, Comp_Typ); + + case Prim is + when Initialize_Case => + return Make_Init_Call (Comp_Ref, Comp_Typ, + Make_Identifier (Loc, Name_L), + Make_Identifier (Loc, Name_B)); + + when Adjust_Case => + return Make_Adjust_Call (Comp_Ref, Comp_Typ, + Make_Identifier (Loc, Name_L), + Make_Identifier (Loc, Name_B)); + + when Finalize_Case => + return Make_Final_Call (Comp_Ref, Comp_Typ, + Make_Identifier (Loc, Name_B)); + end case; + end One_Component; + + ------------------- + -- One_Dimension -- + ------------------- + + function One_Dimension (N : Int) return List_Id is + Index : Entity_Id; + + begin + if N > Number_Dimensions (Typ) then + return One_Component; + + else + Index := + Make_Defining_Identifier (Loc, New_External_Name ('J', N)); + + Append_To (Index_List, New_Reference_To (Index, Loc)); + + return New_List ( + Make_Implicit_Loop_Statement (Typ, + Identifier => Empty, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Index, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Attribute_Name => Name_Range, + Expressions => New_List ( + Make_Integer_Literal (Loc, N))), + Reverse_Present => Prim = Finalize_Case)), + Statements => One_Dimension (N + 1))); + end if; + end One_Dimension; + + -- Start of processing for Make_Deep_Array_Body + + begin + return One_Dimension (1); + end Make_Deep_Array_Body; + + -------------------- + -- Make_Deep_Proc -- + -------------------- + + -- Generate: + -- procedure DEEP_ + -- (L : IN OUT Finalizable_Ptr; -- not for Finalize + -- V : IN OUT ; + -- B : IN Short_Short_Integer) is + -- begin + -- ; + -- exception -- Finalize and Adjust Cases only + -- raise Program_Error; -- idem + -- end DEEP_; + + function Make_Deep_Proc + (Prim : Final_Primitives; + Typ : Entity_Id; + Stmts : List_Id) return Entity_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Formals : List_Id; + Proc_Name : Entity_Id; + Handler : List_Id := No_List; + Type_B : Entity_Id; + + begin + if Prim = Finalize_Case then + Formals := New_List; + Type_B := Standard_Boolean; + + else + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_L), + In_Present => True, + Out_Present => True, + Parameter_Type => + New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); + Type_B := Standard_Short_Short_Integer; + end if; + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + In_Present => True, + Out_Present => True, + Parameter_Type => New_Reference_To (Typ, Loc))); + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_B), + Parameter_Type => New_Reference_To (Type_B, Loc))); + + if Prim = Finalize_Case or else Prim = Adjust_Case then + Handler := New_List (Make_Handler_For_Ctrl_Operation (Loc)); + end if; + + Proc_Name := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim))); + + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc_Name, + Parameter_Specifications => Formals), + + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts, + Exception_Handlers => Handler))); + + return Proc_Name; + end Make_Deep_Proc; + + --------------------------- + -- Make_Deep_Record_Body -- + --------------------------- + + -- The Deep procedures call the appropriate Controlling proc on the + -- controller component. In the init case, it also attach the + -- controller to the current finalization list. + + function Make_Deep_Record_Body + (Prim : Final_Primitives; + Typ : Entity_Id) return List_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Controller_Typ : Entity_Id; + Obj_Ref : constant Node_Id := Make_Identifier (Loc, Name_V); + Controller_Ref : constant Node_Id := + Make_Selected_Component (Loc, + Prefix => Obj_Ref, + Selector_Name => + Make_Identifier (Loc, Name_uController)); + Res : constant List_Id := New_List; + + begin + if Is_Immutably_Limited_Type (Typ) then + Controller_Typ := RTE (RE_Limited_Record_Controller); + else + Controller_Typ := RTE (RE_Record_Controller); + end if; + + case Prim is + when Initialize_Case => + Append_List_To (Res, + Make_Init_Call ( + Ref => Controller_Ref, + Typ => Controller_Typ, + Flist_Ref => Make_Identifier (Loc, Name_L), + With_Attach => Make_Identifier (Loc, Name_B))); + + -- When the type is also a controlled type by itself, + -- initialize it and attach it to the finalization chain. + + if Is_Controlled (Typ) then + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + Find_Prim_Op (Typ, Name_Of (Prim)), Loc), + Parameter_Associations => + New_List (New_Copy_Tree (Obj_Ref)))); + + Append_To (Res, + Make_Attach_Call + (Obj_Ref => New_Copy_Tree (Obj_Ref), + Flist_Ref => Make_Identifier (Loc, Name_L), + With_Attach => Make_Identifier (Loc, Name_B))); + end if; + + when Adjust_Case => + Append_List_To (Res, + Make_Adjust_Call + (Controller_Ref, Controller_Typ, + Make_Identifier (Loc, Name_L), + Make_Identifier (Loc, Name_B))); + + -- When the type is also a controlled type by itself, + -- adjust it and attach it to the finalization chain. + + if Is_Controlled (Typ) then + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + Find_Prim_Op (Typ, Name_Of (Prim)), Loc), + Parameter_Associations => + New_List (New_Copy_Tree (Obj_Ref)))); + + Append_To (Res, + Make_Attach_Call + (Obj_Ref => New_Copy_Tree (Obj_Ref), + Flist_Ref => Make_Identifier (Loc, Name_L), + With_Attach => Make_Identifier (Loc, Name_B))); + end if; + + when Finalize_Case => + if Is_Controlled (Typ) then + Append_To (Res, + Make_Implicit_If_Statement (Obj_Ref, + Condition => Make_Identifier (Loc, Name_B), + Then_Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Finalize_One), Loc), + Parameter_Associations => New_List ( + OK_Convert_To (RTE (RE_Finalizable), + New_Copy_Tree (Obj_Ref))))), + + Else_Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + Find_Prim_Op (Typ, Name_Of (Prim)), Loc), + Parameter_Associations => + New_List (New_Copy_Tree (Obj_Ref)))))); + end if; + + Append_List_To (Res, + Make_Final_Call + (Controller_Ref, Controller_Typ, + Make_Identifier (Loc, Name_B))); + end case; + + return Res; + end Make_Deep_Record_Body; + + ---------------------- + -- Make_Final_Call -- + ---------------------- + + function Make_Final_Call + (Ref : Node_Id; + Typ : Entity_Id; + With_Detach : Node_Id) return List_Id + is + Loc : constant Source_Ptr := Sloc (Ref); + Res : constant List_Id := New_List; + Cref : Node_Id; + Cref2 : Node_Id; + Proc : Entity_Id; + Utyp : Entity_Id; + + begin + if Is_Class_Wide_Type (Typ) then + Utyp := Root_Type (Typ); + Cref := Ref; + + elsif Is_Concurrent_Type (Typ) then + Utyp := Corresponding_Record_Type (Typ); + Cref := Convert_Concurrent (Ref, Typ); + + elsif Is_Private_Type (Typ) + and then Present (Full_View (Typ)) + and then Is_Concurrent_Type (Full_View (Typ)) + then + Utyp := Corresponding_Record_Type (Full_View (Typ)); + Cref := Convert_Concurrent (Ref, Full_View (Typ)); + else + Utyp := Typ; + Cref := Ref; + end if; + + Utyp := Underlying_Type (Base_Type (Utyp)); + Set_Assignment_OK (Cref); + + -- Deal with non-tagged derivation of private views. If the parent is + -- now known to be protected, the finalization routine is the one + -- defined on the corresponding record of the ancestor (corresponding + -- records do not automatically inherit operations, but maybe they + -- should???) + + if Is_Untagged_Derivation (Typ) then + if Is_Protected_Type (Typ) then + Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ))); + else + Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); + end if; + + Cref := Unchecked_Convert_To (Utyp, Cref); + + -- We need to set Assignment_OK to prevent problems with unchecked + -- conversions, where we do not want them to be converted back in the + -- case of untagged record derivation (see code in Make_*_Call + -- procedures for similar situations). + + Set_Assignment_OK (Cref); + end if; + + -- If the underlying_type is a subtype, we are dealing with + -- the completion of a private type. We need to access + -- the base type and generate a conversion to it. + + if Utyp /= Base_Type (Utyp) then + pragma Assert (Is_Private_Type (Typ)); + Utyp := Base_Type (Utyp); + Cref := Unchecked_Convert_To (Utyp, Cref); + end if; + + -- Generate: + -- Deep_Finalize (Ref, With_Detach); + + if Has_Controlled_Component (Utyp) + or else Is_Class_Wide_Type (Typ) + then + if Is_Tagged_Type (Utyp) then + Proc := Find_Prim_Op (Utyp, TSS_Deep_Finalize); + else + Proc := TSS (Utyp, TSS_Deep_Finalize); + end if; + + Cref := Convert_View (Proc, Cref); + + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => + New_List (Cref, With_Detach))); + + -- Generate: + -- if With_Detach then + -- Finalize_One (Ref); + -- else + -- Finalize (Ref); + -- end if; + + else + Proc := Find_Prim_Op (Utyp, Name_Of (Finalize_Case)); + + if Chars (With_Detach) = Chars (Standard_True) then + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Finalize_One), Loc), + Parameter_Associations => New_List ( + OK_Convert_To (RTE (RE_Finalizable), Cref)))); + + elsif Chars (With_Detach) = Chars (Standard_False) then + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => + New_List (Convert_View (Proc, Cref)))); + + else + Cref2 := New_Copy_Tree (Cref); + Append_To (Res, + Make_Implicit_If_Statement (Ref, + Condition => With_Detach, + Then_Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Finalize_One), Loc), + Parameter_Associations => New_List ( + OK_Convert_To (RTE (RE_Finalizable), Cref)))), + + Else_Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => + New_List (Convert_View (Proc, Cref2)))))); + end if; + end if; + + return Res; + end Make_Final_Call; + + ------------------------------------- + -- Make_Handler_For_Ctrl_Operation -- + ------------------------------------- + + -- Generate: + + -- when E : others => + -- Raise_From_Controlled_Operation (X => E); + + -- or: + + -- when others => + -- raise Program_Error [finalize raised exception]; + + -- depending on whether Raise_From_Controlled_Operation is available + + function Make_Handler_For_Ctrl_Operation + (Loc : Source_Ptr) return Node_Id + is + E_Occ : Entity_Id; + -- Choice parameter (for the first case above) + + Raise_Node : Node_Id; + -- Procedure call or raise statement + + begin + if RTE_Available (RE_Raise_From_Controlled_Operation) then + + -- Standard runtime: add choice parameter E, and pass it to + -- Raise_From_Controlled_Operation so that the original exception + -- name and message can be recorded in the exception message for + -- Program_Error. + + E_Occ := Make_Defining_Identifier (Loc, Name_E); + Raise_Node := Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Raise_From_Controlled_Operation), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (E_Occ, Loc))); + + else + -- Restricted runtime: exception messages are not supported + + E_Occ := Empty; + Raise_Node := Make_Raise_Program_Error (Loc, + Reason => PE_Finalize_Raised_Exception); + end if; + + return Make_Implicit_Exception_Handler (Loc, + Exception_Choices => New_List (Make_Others_Choice (Loc)), + Choice_Parameter => E_Occ, + Statements => New_List (Raise_Node)); + end Make_Handler_For_Ctrl_Operation; + + -------------------- + -- Make_Init_Call -- + -------------------- + + function Make_Init_Call + (Ref : Node_Id; + Typ : Entity_Id; + Flist_Ref : Node_Id; + With_Attach : Node_Id) return List_Id + is + Loc : constant Source_Ptr := Sloc (Ref); + Is_Conc : Boolean; + Res : constant List_Id := New_List; + Proc : Entity_Id; + Utyp : Entity_Id; + Cref : Node_Id; + Cref2 : Node_Id; + Attach : Node_Id := With_Attach; + + begin + if Is_Concurrent_Type (Typ) then + Is_Conc := True; + Utyp := Corresponding_Record_Type (Typ); + Cref := Convert_Concurrent (Ref, Typ); + + elsif Is_Private_Type (Typ) + and then Present (Full_View (Typ)) + and then Is_Concurrent_Type (Underlying_Type (Typ)) + then + Is_Conc := True; + Utyp := Corresponding_Record_Type (Underlying_Type (Typ)); + Cref := Convert_Concurrent (Ref, Underlying_Type (Typ)); + + else + Is_Conc := False; + Utyp := Typ; + Cref := Ref; + end if; + + Utyp := Underlying_Type (Base_Type (Utyp)); + + Set_Assignment_OK (Cref); + + -- Deal with non-tagged derivation of private views + + if Is_Untagged_Derivation (Typ) + and then not Is_Conc + then + Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); + Cref := Unchecked_Convert_To (Utyp, Cref); + Set_Assignment_OK (Cref); + -- To prevent problems with UC see 1.156 RH ??? + end if; + + -- If the underlying_type is a subtype, we are dealing with + -- the completion of a private type. We need to access + -- the base type and generate a conversion to it. + + if Utyp /= Base_Type (Utyp) then + pragma Assert (Is_Private_Type (Typ)); + Utyp := Base_Type (Utyp); + Cref := Unchecked_Convert_To (Utyp, Cref); + end if; + + -- We do not need to attach to one of the Global Final Lists + -- the objects whose type is Finalize_Storage_Only + + if Finalize_Storage_Only (Typ) + and then (Global_Flist_Ref (Flist_Ref) + or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) + = Standard_True) + then + Attach := Make_Integer_Literal (Loc, 0); + end if; + + -- Generate: + -- Deep_Initialize (Ref, Flist_Ref); + + if Has_Controlled_Component (Utyp) then + Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case)); + + Cref := Convert_View (Proc, Cref, 2); + + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => New_List ( + Node1 => Flist_Ref, + Node2 => Cref, + Node3 => Attach))); + + -- Generate: + -- Attach_To_Final_List (Ref, Flist_Ref); + -- Initialize (Ref); + + else -- Is_Controlled (Utyp) + Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case)); + Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Cref); + + Cref := Convert_View (Proc, Cref); + Cref2 := New_Copy_Tree (Cref); + + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => New_List (Cref2))); + + Append_To (Res, + Make_Attach_Call (Cref, Flist_Ref, Attach)); + end if; + + return Res; + end Make_Init_Call; + + -------------------------- + -- Make_Transient_Block -- + -------------------------- + + -- If finalization is involved, this function just wraps the instruction + -- into a block whose name is the transient block entity, and then + -- Expand_Cleanup_Actions (called on the expansion of the handled + -- sequence of statements will do the necessary expansions for + -- cleanups). + + function Make_Transient_Block + (Loc : Source_Ptr; + Action : Node_Id) return Node_Id + is + Flist : constant Entity_Id := Finalization_Chain_Entity (Current_Scope); + Decls : constant List_Id := New_List; + Par : constant Node_Id := Parent (Action); + Instrs : constant List_Id := New_List (Action); + Blk : Node_Id; + + begin + -- Case where only secondary stack use is involved + + if VM_Target = No_VM + and then Uses_Sec_Stack (Current_Scope) + and then No (Flist) + and then Nkind (Action) /= N_Simple_Return_Statement + and then Nkind (Par) /= N_Exception_Handler + then + declare + S : Entity_Id; + K : Entity_Kind; + + begin + S := Scope (Current_Scope); + loop + K := Ekind (S); + + -- At the outer level, no need to release the sec stack + + if S = Standard_Standard then + Set_Uses_Sec_Stack (Current_Scope, False); + exit; + + -- In a function, only release the sec stack if the + -- function does not return on the sec stack otherwise + -- the result may be lost. The caller is responsible for + -- releasing. + + elsif K = E_Function then + Set_Uses_Sec_Stack (Current_Scope, False); + + if not Requires_Transient_Scope (Etype (S)) then + Set_Uses_Sec_Stack (S, True); + Check_Restriction (No_Secondary_Stack, Action); + end if; + + exit; + + -- In a loop or entry we should install a block encompassing + -- all the construct. For now just release right away. + + elsif K = E_Loop or else K = E_Entry then + exit; + + -- In a procedure or a block, we release on exit of the + -- procedure or block. ??? memory leak can be created by + -- recursive calls. + + elsif K = E_Procedure + or else K = E_Block + then + Set_Uses_Sec_Stack (S, True); + Check_Restriction (No_Secondary_Stack, Action); + Set_Uses_Sec_Stack (Current_Scope, False); + exit; + + else + S := Scope (S); + end if; + end loop; + end; + end if; + + -- Insert actions stuck in the transient scopes as well as all + -- freezing nodes needed by those actions + + Insert_Actions_In_Scope_Around (Action); + + declare + Last_Inserted : Node_Id := Prev (Action); + begin + if Present (Last_Inserted) then + Freeze_All (First_Entity (Current_Scope), Last_Inserted); + end if; + end; + + Blk := + Make_Block_Statement (Loc, + Identifier => New_Reference_To (Current_Scope, Loc), + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs), + Has_Created_Identifier => True); + + -- When the transient scope was established, we pushed the entry for + -- the transient scope onto the scope stack, so that the scope was + -- active for the installation of finalizable entities etc. Now we + -- must remove this entry, since we have constructed a proper block. + + Pop_Scope; + + return Blk; + end Make_Transient_Block; + + ------------------------ + -- Needs_Finalization -- + ------------------------ + + function Needs_Finalization (T : Entity_Id) return Boolean is + + function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean; + -- If type is not frozen yet, check explicitly among its components, + -- because the Has_Controlled_Component flag is not necessarily set. + + ----------------------------------- + -- Has_Some_Controlled_Component -- + ----------------------------------- + + function Has_Some_Controlled_Component + (Rec : Entity_Id) return Boolean + is + Comp : Entity_Id; + + begin + if Has_Controlled_Component (Rec) then + return True; + + elsif not Is_Frozen (Rec) then + if Is_Record_Type (Rec) then + Comp := First_Entity (Rec); + + while Present (Comp) loop + if not Is_Type (Comp) + and then Needs_Finalization (Etype (Comp)) + then + return True; + end if; + + Next_Entity (Comp); + end loop; + + return False; + + elsif Is_Array_Type (Rec) then + return Needs_Finalization (Component_Type (Rec)); + + else + return Has_Controlled_Component (Rec); + end if; + else + return False; + end if; + end Has_Some_Controlled_Component; + + -- Start of processing for Needs_Finalization + + begin + return + + -- Class-wide types must be treated as controlled and therefore + -- requiring finalization (because they may be extended with an + -- extension that has controlled components. + + (Is_Class_Wide_Type (T) + + -- However, avoid treating class-wide types as controlled if + -- finalization is not available and in particular CIL value + -- types never have finalization). + + and then not In_Finalization_Root (T) + and then not Restriction_Active (No_Finalization) + and then not Is_Value_Type (Etype (T))) + + -- Controlled types always need finalization + + or else Is_Controlled (T) + or else Has_Some_Controlled_Component (T) + + -- For concurrent types, test the corresponding record type + + or else (Is_Concurrent_Type (T) + and then Present (Corresponding_Record_Type (T)) + and then Needs_Finalization (Corresponding_Record_Type (T))); + end Needs_Finalization; + + ------------------------ + -- Node_To_Be_Wrapped -- + ------------------------ + + function Node_To_Be_Wrapped return Node_Id is + begin + return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped; + end Node_To_Be_Wrapped; + + ---------------------------- + -- Set_Node_To_Be_Wrapped -- + ---------------------------- + + procedure Set_Node_To_Be_Wrapped (N : Node_Id) is + begin + Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N; + end Set_Node_To_Be_Wrapped; + + ---------------------------------- + -- Store_After_Actions_In_Scope -- + ---------------------------------- + + procedure Store_After_Actions_In_Scope (L : List_Id) is + SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); + + begin + if Present (SE.Actions_To_Be_Wrapped_After) then + Insert_List_Before_And_Analyze ( + First (SE.Actions_To_Be_Wrapped_After), L); + + else + SE.Actions_To_Be_Wrapped_After := L; + + if Is_List_Member (SE.Node_To_Be_Wrapped) then + Set_Parent (L, Parent (SE.Node_To_Be_Wrapped)); + else + Set_Parent (L, SE.Node_To_Be_Wrapped); + end if; + + Analyze_List (L); + end if; + end Store_After_Actions_In_Scope; + + ----------------------------------- + -- Store_Before_Actions_In_Scope -- + ----------------------------------- + + procedure Store_Before_Actions_In_Scope (L : List_Id) is + SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); + + begin + if Present (SE.Actions_To_Be_Wrapped_Before) then + Insert_List_After_And_Analyze ( + Last (SE.Actions_To_Be_Wrapped_Before), L); + + else + SE.Actions_To_Be_Wrapped_Before := L; + + if Is_List_Member (SE.Node_To_Be_Wrapped) then + Set_Parent (L, Parent (SE.Node_To_Be_Wrapped)); + else + Set_Parent (L, SE.Node_To_Be_Wrapped); + end if; + + Analyze_List (L); + end if; + end Store_Before_Actions_In_Scope; + + -------------------------------- + -- Wrap_Transient_Declaration -- + -------------------------------- + + -- If a transient scope has been established during the processing of the + -- Expression of an Object_Declaration, it is not possible to wrap the + -- declaration into a transient block as usual case, otherwise the object + -- would be itself declared in the wrong scope. Therefore, all entities (if + -- any) defined in the transient block are moved to the proper enclosing + -- scope, furthermore, if they are controlled variables they are finalized + -- right after the declaration. The finalization list of the transient + -- scope is defined as a renaming of the enclosing one so during their + -- initialization they will be attached to the proper finalization + -- list. For instance, the following declaration : + + -- X : Typ := F (G (A), G (B)); + + -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2) + -- is expanded into : + + -- _local_final_list_1 : Finalizable_Ptr; + -- X : Typ := [ complex Expression-Action ]; + -- Finalize_One(_v1); + -- Finalize_One (_v2); + + procedure Wrap_Transient_Declaration (N : Node_Id) is + S : Entity_Id; + LC : Entity_Id := Empty; + Nodes : List_Id; + Loc : constant Source_Ptr := Sloc (N); + First_Decl_Loc : Source_Ptr; + Enclosing_S : Entity_Id; + Uses_SS : Boolean; + Next_N : constant Node_Id := Next (N); + + begin + S := Current_Scope; + Enclosing_S := Scope (S); + + -- Insert Actions kept in the Scope stack + + Insert_Actions_In_Scope_Around (N); + + -- If the declaration is consuming some secondary stack, mark the + -- Enclosing scope appropriately. + + Uses_SS := Uses_Sec_Stack (S); + Pop_Scope; + + -- Create a List controller and rename the final list to be its + -- internal final pointer: + -- Lxxx : Simple_List_Controller; + -- Fxxx : Finalizable_Ptr renames Lxxx.F; + + if Present (Finalization_Chain_Entity (S)) then + LC := Make_Temporary (Loc, 'L'); + + -- Use the Sloc of the first declaration of N's containing list, to + -- maintain monotonicity of source-line stepping during debugging. + + First_Decl_Loc := Sloc (First (List_Containing (N))); + + Nodes := New_List ( + Make_Object_Declaration (First_Decl_Loc, + Defining_Identifier => LC, + Object_Definition => + New_Reference_To + (RTE (RE_Simple_List_Controller), First_Decl_Loc)), + + Make_Object_Renaming_Declaration (First_Decl_Loc, + Defining_Identifier => Finalization_Chain_Entity (S), + Subtype_Mark => + New_Reference_To (RTE (RE_Finalizable_Ptr), First_Decl_Loc), + Name => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (LC, First_Decl_Loc), + Selector_Name => Make_Identifier (First_Decl_Loc, Name_F)))); + + -- Put the declaration at the beginning of the declaration part + -- to make sure it will be before all other actions that have been + -- inserted before N. + + Insert_List_Before_And_Analyze (First (List_Containing (N)), Nodes); + + -- Generate the Finalization calls by finalizing the list controller + -- right away. It will be re-finalized on scope exit but it doesn't + -- matter. It cannot be done when the call initializes a renaming + -- object though because in this case, the object becomes a pointer + -- to the temporary and thus increases its life span. Ditto if this + -- is a renaming of a component of an expression (such as a function + -- call). + + -- Note that there is a problem if an actual in the call needs + -- finalization, because in that case the call itself is the master, + -- and the actual should be finalized on return from the call ??? + + if Nkind (N) = N_Object_Renaming_Declaration + and then Needs_Finalization (Etype (Defining_Identifier (N))) + then + null; + + elsif Nkind (N) = N_Object_Renaming_Declaration + and then + Nkind_In (Renamed_Object (Defining_Identifier (N)), + N_Selected_Component, + N_Indexed_Component) + and then + Needs_Finalization + (Etype (Prefix (Renamed_Object (Defining_Identifier (N))))) + then + null; + + else + Nodes := + Make_Final_Call + (Ref => New_Reference_To (LC, Loc), + Typ => Etype (LC), + With_Detach => New_Reference_To (Standard_False, Loc)); + + if Present (Next_N) then + Insert_List_Before_And_Analyze (Next_N, Nodes); + else + Append_List_To (List_Containing (N), Nodes); + end if; + end if; + end if; + + -- Put the local entities back in the enclosing scope, and set the + -- Is_Public flag appropriately. + + Transfer_Entities (S, Enclosing_S); + + -- Mark the enclosing dynamic scope so that the sec stack will be + -- released upon its exit unless this is a function that returns on + -- the sec stack in which case this will be done by the caller. + + if VM_Target = No_VM and then Uses_SS then + S := Enclosing_Dynamic_Scope (S); + + if Ekind (S) = E_Function + and then Requires_Transient_Scope (Etype (S)) + then + null; + else + Set_Uses_Sec_Stack (S); + Check_Restriction (No_Secondary_Stack, N); + end if; + end if; + end Wrap_Transient_Declaration; + + ------------------------------- + -- Wrap_Transient_Expression -- + ------------------------------- + + -- Insert actions before : + + -- (lines marked with are expanded only in presence of Controlled + -- objects needing finalization) + + -- _E : Etyp; + -- declare + -- _M : constant Mark_Id := SS_Mark; + -- Local_Final_List : System.FI.Finalizable_Ptr; + + -- procedure _Clean is + -- begin + -- Abort_Defer; + -- System.FI.Finalize_List (Local_Final_List); + -- SS_Release (M); + -- Abort_Undefer; + -- end _Clean; + + -- begin + -- _E := ; + -- at end + -- _Clean; + -- end; + + -- then expression is replaced by _E + + procedure Wrap_Transient_Expression (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + E : constant Entity_Id := Make_Temporary (Loc, 'E', N); + Etyp : constant Entity_Id := Etype (N); + Expr : constant Node_Id := Relocate_Node (N); + + begin + Insert_Actions (N, New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => E, + Object_Definition => New_Reference_To (Etyp, Loc)), + + Make_Transient_Block (Loc, + Action => + Make_Assignment_Statement (Loc, + Name => New_Reference_To (E, Loc), + Expression => Expr)))); + + Rewrite (N, New_Reference_To (E, Loc)); + Analyze_And_Resolve (N, Etyp); + end Wrap_Transient_Expression; + + ------------------------------ + -- Wrap_Transient_Statement -- + ------------------------------ + + -- Transform into + + -- (lines marked with are expanded only in presence of Controlled + -- objects needing finalization) + + -- declare + -- _M : Mark_Id := SS_Mark; + -- Local_Final_List : System.FI.Finalizable_Ptr ; + + -- procedure _Clean is + -- begin + -- Abort_Defer; + -- System.FI.Finalize_List (Local_Final_List); + -- SS_Release (_M); + -- Abort_Undefer; + -- end _Clean; + + -- begin + -- ; + -- at end + -- _Clean; + -- end; + + procedure Wrap_Transient_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + New_Statement : constant Node_Id := Relocate_Node (N); + + begin + Rewrite (N, Make_Transient_Block (Loc, New_Statement)); + + -- With the scope stack back to normal, we can call analyze on the + -- resulting block. At this point, the transient scope is being + -- treated like a perfectly normal scope, so there is nothing + -- special about it. + + -- Note: Wrap_Transient_Statement is called with the node already + -- analyzed (i.e. Analyzed (N) is True). This is important, since + -- otherwise we would get a recursive processing of the node when + -- we do this Analyze call. + + Analyze (N); + end Wrap_Transient_Statement; + +end Exp_Ch7; diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads new file mode 100644 index 000000000..669f998c4 --- /dev/null +++ b/gcc/ada/exp_ch7.ads @@ -0,0 +1,248 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 7 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Namet; use Namet; +with Types; use Types; + +package Exp_Ch7 is + + procedure Expand_N_Package_Body (N : Node_Id); + procedure Expand_N_Package_Declaration (N : Node_Id); + + ----------------------------- + -- Finalization Management -- + ----------------------------- + + function In_Finalization_Root (E : Entity_Id) return Boolean; + -- True if current scope is in package System.Finalization_Root. Used + -- to avoid certain expansions that would involve circularity in the + -- Rtsfind mechanism. + + procedure Build_Final_List (N : Node_Id; Typ : Entity_Id); + -- Build finalization list for anonymous access types, and for access + -- types that are frozen before their designated types are known to + -- be controlled. + + procedure Build_Controlling_Procs (Typ : Entity_Id); + -- Typ is a record, and array type having controlled components. + -- Create the procedures Deep_Initialize, Deep_Adjust and Deep_Finalize + -- that take care of finalization management at run-time. + + procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id); + -- Build one controlling procedure when a late body overrides one of + -- the controlling operations. + + function Controller_Component (Typ : Entity_Id) return Entity_Id; + -- Returns the entity of the component whose name is 'Name_uController' + + function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean; + -- True if T is a class-wide type, or if it has controlled parts ("part" + -- means T or any of its subcomponents). This is the same as + -- Needs_Finalization, except when pragma Restrictions (No_Finalization) + -- applies, in which case we know that class-wide objects do not contain + -- controlled parts. + + procedure Expand_Ctrl_Function_Call (N : Node_Id); + -- Expand a call to a function returning a controlled value. That is to + -- say attach the result of the call to the current finalization list, + -- which is the one of the transient scope created for such constructs. + + function Find_Final_List + (E : Entity_Id; + Ref : Node_Id := Empty) return Node_Id; + -- E is an entity representing a controlled object, a controlled type or a + -- scope. If Ref is not empty, it is a reference to a controlled record, + -- the closest Final list is in the controller component of the record + -- containing Ref, otherwise this function returns a reference to the final + -- list attached to the closest dynamic scope (which can be E itself), + -- creating this final list if necessary. + + function Has_New_Controlled_Component (E : Entity_Id) return Boolean; + -- E is a type entity. Give the same result as Has_Controlled_Component + -- except for tagged extensions where the result is True only if the + -- latest extension contains a controlled component. + + function Make_Attach_Call + (Obj_Ref : Node_Id; + Flist_Ref : Node_Id; + With_Attach : Node_Id) return Node_Id; + -- Attach the referenced object to the referenced Final Chain 'Flist_Ref' + -- With_Attach is an expression of type Short_Short_Integer which can be + -- either '0' to signify no attachment, '1' for attachment to a simply + -- linked list or '2' for attachment to a doubly linked list. + + function Make_Init_Call + (Ref : Node_Id; + Typ : Entity_Id; + Flist_Ref : Node_Id; + With_Attach : Node_Id) return List_Id; + -- Ref is an expression (with no-side effect and is not required to have + -- been previously analyzed) that references the object to be initialized. + -- Typ is the expected type of Ref, which is either a controlled type + -- (Is_Controlled) or a type with controlled components (Has_Controlled). + -- With_Attach is an integer expression which is the attachment level, + -- see System.Finalization_Implementation.Attach_To_Final_List for the + -- documentation of Nb_Link. + -- + -- This function will generate the appropriate calls to make sure that the + -- objects referenced by Ref are initialized. The generated code is quite + -- different for an IS_Controlled type or a HAS_Controlled type, but this + -- is not the problem for the caller, the details are in the body. + + function Make_Adjust_Call + (Ref : Node_Id; + Typ : Entity_Id; + Flist_Ref : Node_Id; + With_Attach : Node_Id; + Allocator : Boolean := False) return List_Id; + -- Ref is an expression (with no-side effect and is not required to have + -- been previously analyzed) that references the object to be adjusted. Typ + -- is the expected type of Ref, which is a controlled type (Is_Controlled) + -- or a type with controlled components (Has_Controlled). With_Attach is an + -- integer expression giving the attachment level (see documentation of + -- Attach_To_Final_List.Nb_Link param documentation in s-finimp.ads. + -- Note: if Typ is Finalize_Storage_Only and the object is at library + -- level, then With_Attach will be ignored, and a zero link level will be + -- passed to Attach_To_Final_List. + -- + -- This function will generate the appropriate calls to make sure that the + -- objects referenced by Ref are adjusted. The generated code is quite + -- different depending on the fact the type IS_Controlled or HAS_Controlled + -- but this is not the problem of the caller, the details are in the body. + -- The objects must be attached when the adjust takes place after an + -- initialization expression but not when it takes place after a regular + -- assignment. + -- + -- If Allocator is True, we are adjusting a newly-created object. The + -- existing chaining pointers should not be left unchanged, because they + -- may come from a bit-for-bit copy of those from an initializing object. + -- So, when this flag is True, if the chaining pointers should otherwise + -- be left unset, instead they are reset to null. + + function Make_Final_Call + (Ref : Node_Id; + Typ : Entity_Id; + With_Detach : Node_Id) return List_Id; + -- Ref is an expression (with no-side effect and is not required to have + -- been previously analyzed) that references the object to be Finalized. + -- Typ is the expected type of Ref, which is a controlled type + -- (Is_Controlled) or a type with controlled components (Has_Controlled). + -- With_Detach is a boolean expression indicating whether to detach the + -- controlled object from whatever finalization list it is currently + -- attached to. + -- + -- This function will generate the appropriate calls to make sure that the + -- objects referenced by Ref are finalized. The generated code is quite + -- different depending on the fact the type IS_Controlled or HAS_Controlled + -- but this is not the problem of the caller, the details are in the body. + -- The objects must be detached when finalizing an unchecked deallocated + -- object but not when finalizing the target of an assignment, it is not + -- necessary either on scope exit. + + function Make_Handler_For_Ctrl_Operation (Loc : Source_Ptr) return Node_Id; + -- Generate an implicit exception handler with an 'others' choice, + -- converting any occurrence to a raise of Program_Error. + + function Needs_Finalization (T : Entity_Id) return Boolean; + -- True if T potentially needs finalization actions. True if T is + -- controlled, or has subcomponents. Also True if T is a class-wide type, + -- because some type extension might add controlled subcomponents, except + -- that if pragma Restrictions (No_Finalization) applies, this is False for + -- class-wide types. + + -------------------------------------------- + -- Task and Protected Object finalization -- + -------------------------------------------- + + function Cleanup_Array + (N : Node_Id; + Obj : Node_Id; + Typ : Entity_Id) return List_Id; + -- Generate loops to finalize any tasks or simple protected objects that + -- are subcomponents of an array. + + function Cleanup_Protected_Object + (N : Node_Id; + Ref : Node_Id) return Node_Id; + -- Generate code to finalize a protected object without entries + + function Cleanup_Record + (N : Node_Id; + Obj : Node_Id; + Typ : Entity_Id) return List_Id; + -- For each subcomponent of a record that contains tasks or simple + -- protected objects, generate the appropriate finalization call. + + function Cleanup_Task + (N : Node_Id; + Ref : Node_Id) return Node_Id; + -- Generate code to finalize a task + + function Has_Simple_Protected_Object (T : Entity_Id) return Boolean; + -- Check whether composite type contains a simple protected component + + function Is_Simple_Protected_Type (T : Entity_Id) return Boolean; + -- Check whether argument is a protected type without entries. Protected + -- types with entries are controlled, and their cleanup is handled by the + -- standard finalization machinery. For simple protected types we generate + -- inline code to release their locks. + + -------------------------------- + -- Transient Scope Management -- + -------------------------------- + + procedure Expand_Cleanup_Actions (N : Node_Id); + -- Expand the necessary stuff into a scope to enable finalization of local + -- objects and deallocation of transient data when exiting the scope. N is + -- a "scope node" that is to say one of the following: N_Block_Statement, + -- N_Subprogram_Body, N_Task_Body, N_Entry_Body. + + procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean); + -- Push a new transient scope on the scope stack. N is the node responsible + -- for the need of a transient scope. If Sec_Stack is True then the + -- secondary stack is brought in, otherwise it isn't. + + function Node_To_Be_Wrapped return Node_Id; + -- return the node to be wrapped if the current scope is transient + + procedure Store_Before_Actions_In_Scope (L : List_Id); + -- Append the list L of actions to the end of the before-actions store in + -- the top of the scope stack. + + procedure Store_After_Actions_In_Scope (L : List_Id); + -- Append the list L of actions to the beginning of the after-actions store + -- in the top of the scope stack. + + procedure Wrap_Transient_Declaration (N : Node_Id); + -- N is an object declaration. Expand the finalization calls after the + -- declaration and make the outer scope being the transient one. + + procedure Wrap_Transient_Expression (N : Node_Id); + -- N is a sub-expression. Expand a transient block around an expression + + procedure Wrap_Transient_Statement (N : Node_Id); + -- N is a statement. Expand a transient block around an instruction + +end Exp_Ch7; diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb new file mode 100644 index 000000000..af33868b7 --- /dev/null +++ b/gcc/ada/exp_ch8.adb @@ -0,0 +1,429 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 8 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Exp_Ch4; use Exp_Ch4; +with Exp_Ch6; use Exp_Ch6; +with Exp_Dbug; use Exp_Dbug; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Namet; use Namet; +with Nmake; use Nmake; +with Nlists; use Nlists; +with Opt; use Opt; +with Sem; use Sem; +with Sem_Ch8; use Sem_Ch8; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Tbuild; use Tbuild; + +package body Exp_Ch8 is + + --------------------------------------------- + -- Expand_N_Exception_Renaming_Declaration -- + --------------------------------------------- + + procedure Expand_N_Exception_Renaming_Declaration (N : Node_Id) is + Decl : constant Node_Id := Debug_Renaming_Declaration (N); + + begin + if Present (Decl) then + Insert_Action (N, Decl); + end if; + end Expand_N_Exception_Renaming_Declaration; + + ------------------------------------------ + -- Expand_N_Object_Renaming_Declaration -- + ------------------------------------------ + + -- Most object renaming cases can be done by just capturing the address + -- of the renamed object. The cases in which this is not true are when + -- this address is not computable, since it involves extraction of a + -- packed array element, or of a record component to which a component + -- clause applies (that can specify an arbitrary bit boundary), or where + -- the enclosing record itself has a non-standard representation. + + -- In these two cases, we pre-evaluate the renaming expression, by + -- extracting and freezing the values of any subscripts, and then we + -- set the flag Is_Renaming_Of_Object which means that any reference + -- to the object will be handled by macro substitution in the front + -- end, and the back end will know to ignore the renaming declaration. + + -- An additional odd case that requires processing by expansion is + -- the renaming of a discriminant of a mutable record type. The object + -- is a constant because it renames something that cannot be assigned to, + -- but in fact the underlying value can change and must be reevaluated + -- at each reference. Gigi does have a notion of a "constant view" of + -- an object, and therefore the front-end must perform the expansion. + -- For simplicity, and to bypass some obscure code-generation problem, + -- we use macro substitution for all renamed discriminants, whether the + -- enclosing type is constrained or not. + + -- The other special processing required is for the case of renaming + -- of an object of a class wide type, where it is necessary to build + -- the appropriate subtype for the renamed object. + -- More comments needed for this para ??? + + procedure Expand_N_Object_Renaming_Declaration (N : Node_Id) is + Nam : constant Node_Id := Name (N); + T : Entity_Id; + Decl : Node_Id; + + procedure Evaluate_Name (Fname : Node_Id); + -- A recursive procedure used to freeze a name in the sense described + -- above, i.e. any variable references or function calls are removed. + -- Of course the outer level variable reference must not be removed. + -- For example in A(J,F(K)), A is left as is, but J and F(K) are + -- evaluated and removed. + + function Evaluation_Required (Nam : Node_Id) return Boolean; + -- Determines whether it is necessary to do static name evaluation + -- for renaming of Nam. It is considered necessary if evaluating the + -- name involves indexing a packed array, or extracting a component + -- of a record to which a component clause applies. Note that we are + -- only interested in these operations if they occur as part of the + -- name itself, subscripts are just values that are computed as part + -- of the evaluation, so their form is unimportant. + + ------------------- + -- Evaluate_Name -- + ------------------- + + procedure Evaluate_Name (Fname : Node_Id) is + K : constant Node_Kind := Nkind (Fname); + E : Node_Id; + + begin + -- For an explicit dereference, we simply force the evaluation + -- of the name expression. The dereference provides a value that + -- is the address for the renamed object, and it is precisely + -- this value that we want to preserve. + + if K = N_Explicit_Dereference then + Force_Evaluation (Prefix (Fname)); + + -- For a selected component, we simply evaluate the prefix + + elsif K = N_Selected_Component then + Evaluate_Name (Prefix (Fname)); + + -- For an indexed component, or an attribute reference, we evaluate + -- the prefix, which is itself a name, recursively, and then force + -- the evaluation of all the subscripts (or attribute expressions). + + elsif Nkind_In (K, N_Indexed_Component, N_Attribute_Reference) then + Evaluate_Name (Prefix (Fname)); + + E := First (Expressions (Fname)); + while Present (E) loop + Force_Evaluation (E); + + if Original_Node (E) /= E then + Set_Do_Range_Check (E, Do_Range_Check (Original_Node (E))); + end if; + + Next (E); + end loop; + + -- For a slice, we evaluate the prefix, as for the indexed component + -- case and then, if there is a range present, either directly or + -- as the constraint of a discrete subtype indication, we evaluate + -- the two bounds of this range. + + elsif K = N_Slice then + Evaluate_Name (Prefix (Fname)); + + declare + DR : constant Node_Id := Discrete_Range (Fname); + Constr : Node_Id; + Rexpr : Node_Id; + + begin + if Nkind (DR) = N_Range then + Force_Evaluation (Low_Bound (DR)); + Force_Evaluation (High_Bound (DR)); + + elsif Nkind (DR) = N_Subtype_Indication then + Constr := Constraint (DR); + + if Nkind (Constr) = N_Range_Constraint then + Rexpr := Range_Expression (Constr); + + Force_Evaluation (Low_Bound (Rexpr)); + Force_Evaluation (High_Bound (Rexpr)); + end if; + end if; + end; + + -- For a type conversion, the expression of the conversion must be + -- the name of an object, and we simply need to evaluate this name. + + elsif K = N_Type_Conversion then + Evaluate_Name (Expression (Fname)); + + -- For a function call, we evaluate the call + + elsif K = N_Function_Call then + Force_Evaluation (Fname); + + -- The remaining cases are direct name, operator symbol and + -- character literal. In all these cases, we do nothing, since + -- we want to reevaluate each time the renamed object is used. + + else + return; + end if; + end Evaluate_Name; + + ------------------------- + -- Evaluation_Required -- + ------------------------- + + function Evaluation_Required (Nam : Node_Id) return Boolean is + begin + if Nkind_In (Nam, N_Indexed_Component, N_Slice) then + if Is_Packed (Etype (Prefix (Nam))) then + return True; + else + return Evaluation_Required (Prefix (Nam)); + end if; + + elsif Nkind (Nam) = N_Selected_Component then + declare + Rec_Type : constant Entity_Id := Etype (Prefix (Nam)); + + begin + if Present (Component_Clause (Entity (Selector_Name (Nam)))) + or else Has_Non_Standard_Rep (Rec_Type) + then + return True; + + elsif Ekind (Entity (Selector_Name (Nam))) = E_Discriminant + and then Is_Record_Type (Rec_Type) + and then not Is_Concurrent_Record_Type (Rec_Type) + then + return True; + + else + return Evaluation_Required (Prefix (Nam)); + end if; + end; + + else + return False; + end if; + end Evaluation_Required; + + -- Start of processing for Expand_N_Object_Renaming_Declaration + + begin + -- Perform name evaluation if required + + if Evaluation_Required (Nam) then + Evaluate_Name (Nam); + Set_Is_Renaming_Of_Object (Defining_Identifier (N)); + end if; + + -- Deal with construction of subtype in class-wide case + + T := Etype (Defining_Identifier (N)); + + if Is_Class_Wide_Type (T) then + Expand_Subtype_From_Expr (N, T, Subtype_Mark (N), Name (N)); + Find_Type (Subtype_Mark (N)); + Set_Etype (Defining_Identifier (N), Entity (Subtype_Mark (N))); + + -- Freeze the class-wide subtype here to ensure that the subtype + -- and equivalent type are frozen before the renaming. + + Freeze_Before (N, Entity (Subtype_Mark (N))); + end if; + + -- Ada 2005 (AI-318-02): If the renamed object is a call to a build-in- + -- place function, then a temporary return object needs to be created + -- and access to it must be passed to the function. Currently we limit + -- such functions to those with inherently limited result subtypes, but + -- eventually we plan to expand the functions that are treated as + -- build-in-place to include other composite result types. + + if Ada_Version >= Ada_2005 + and then Is_Build_In_Place_Function_Call (Nam) + then + Make_Build_In_Place_Call_In_Anonymous_Context (Nam); + end if; + + -- Create renaming entry for debug information + + Decl := Debug_Renaming_Declaration (N); + + if Present (Decl) then + Insert_Action (N, Decl); + end if; + end Expand_N_Object_Renaming_Declaration; + + ------------------------------------------- + -- Expand_N_Package_Renaming_Declaration -- + ------------------------------------------- + + procedure Expand_N_Package_Renaming_Declaration (N : Node_Id) is + Decl : constant Node_Id := Debug_Renaming_Declaration (N); + + begin + if Present (Decl) then + + -- If we are in a compilation unit, then this is an outer + -- level declaration, and must have a scope of Standard + + if Nkind (Parent (N)) = N_Compilation_Unit then + declare + Aux : constant Node_Id := Aux_Decls_Node (Parent (N)); + + begin + Push_Scope (Standard_Standard); + + if No (Actions (Aux)) then + Set_Actions (Aux, New_List (Decl)); + else + Append (Decl, Actions (Aux)); + end if; + + Analyze (Decl); + + -- Enter the debug variable in the qualification list, which + -- must be done at this point because auxiliary declarations + -- occur at the library level and aren't associated with a + -- normal scope. + + Qualify_Entity_Names (Decl); + + Pop_Scope; + end; + + -- Otherwise, just insert after the package declaration + + else + Insert_Action (N, Decl); + end if; + end if; + end Expand_N_Package_Renaming_Declaration; + + ---------------------------------------------- + -- Expand_N_Subprogram_Renaming_Declaration -- + ---------------------------------------------- + + procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id) is + Nam : constant Node_Id := Name (N); + + begin + -- When the prefix of the name is a function call, we must force the + -- call to be made by removing side effects from the call, since we + -- must only call the function once. + + if Nkind (Nam) = N_Selected_Component + and then Nkind (Prefix (Nam)) = N_Function_Call + then + Remove_Side_Effects (Prefix (Nam)); + + -- For an explicit dereference, the prefix must be captured to prevent + -- reevaluation on calls through the renaming, which could result in + -- calling the wrong subprogram if the access value were to be changed. + + elsif Nkind (Nam) = N_Explicit_Dereference then + Force_Evaluation (Prefix (Nam)); + end if; + + -- Check whether this is a renaming of a predefined equality on an + -- untagged record type (AI05-0123). + + if Is_Entity_Name (Nam) + and then Chars (Entity (Nam)) = Name_Op_Eq + and then Scope (Entity (Nam)) = Standard_Standard + and then Ada_Version >= Ada_2012 + then + declare + Loc : constant Source_Ptr := Sloc (N); + Id : constant Entity_Id := Defining_Entity (N); + Typ : constant Entity_Id := Etype (First_Formal (Id)); + + Decl : Node_Id; + Body_Id : constant Entity_Id := + Make_Defining_Identifier (Sloc (N), Chars (Id)); + + begin + if Is_Record_Type (Typ) + and then not Is_Tagged_Type (Typ) + and then not Is_Frozen (Typ) + then + -- Build body for renamed equality, to capture its current + -- meaning. It may be redefined later, but the renaming is + -- elaborated where it occurs. This is technically known as + -- Squirreling semantics. Renaming is rewritten as a subprogram + -- declaration, and the body is inserted at the end of the + -- current declaration list to prevent premature freezing. + + Set_Alias (Id, Empty); + Set_Has_Completion (Id, False); + Rewrite (N, + Make_Subprogram_Declaration (Sloc (N), + Specification => Specification (N))); + Set_Has_Delayed_Freeze (Id); + + Decl := Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Body_Id, + Parameter_Specifications => + Copy_Parameter_List (Id), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)), + Declarations => Empty_List, + Handled_Statement_Sequence => Empty); + + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Expand_Record_Equality + (Id, + Typ => Typ, + Lhs => + Make_Identifier (Loc, Chars (First_Formal (Id))), + Rhs => + Make_Identifier + (Loc, Chars (Next_Formal (First_Formal (Id)))), + Bodies => Declarations (Decl)))))); + + Append (Decl, List_Containing (N)); + Set_Debug_Info_Needed (Body_Id); + end if; + end; + end if; + end Expand_N_Subprogram_Renaming_Declaration; + +end Exp_Ch8; diff --git a/gcc/ada/exp_ch8.ads b/gcc/ada/exp_ch8.ads new file mode 100644 index 000000000..7df54f306 --- /dev/null +++ b/gcc/ada/exp_ch8.ads @@ -0,0 +1,35 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for chapter 8 constructs + +with Types; use Types; + +package Exp_Ch8 is + procedure Expand_N_Exception_Renaming_Declaration (N : Node_Id); + procedure Expand_N_Object_Renaming_Declaration (N : Node_Id); + procedure Expand_N_Package_Renaming_Declaration (N : Node_Id); + procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id); +end Exp_Ch8; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb new file mode 100644 index 000000000..0312187f1 --- /dev/null +++ b/gcc/ada/exp_ch9.adb @@ -0,0 +1,13112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 9 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Ch3; use Exp_Ch3; +with Exp_Ch6; use Exp_Ch6; +with Exp_Ch11; use Exp_Ch11; +with Exp_Dbug; use Exp_Dbug; +with Exp_Disp; use Exp_Disp; +with Exp_Sel; use Exp_Sel; +with Exp_Smem; use Exp_Smem; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Hostparm; +with Itypes; use Itypes; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch11; use Sem_Ch11; +with Sem_Elab; use Sem_Elab; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +package body Exp_Ch9 is + + -- The following constant establishes the upper bound for the index of + -- an entry family. It is used to limit the allocated size of protected + -- types with defaulted discriminant of an integer type, when the bound + -- of some entry family depends on a discriminant. The limitation to + -- entry families of 128K should be reasonable in all cases, and is a + -- documented implementation restriction. It will be lifted when protected + -- entry families are re-implemented as a single ordered queue. + + Entry_Family_Bound : constant Int := 2**16; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Actual_Index_Expression + (Sloc : Source_Ptr; + Ent : Entity_Id; + Index : Node_Id; + Tsk : Entity_Id) return Node_Id; + -- Compute the index position for an entry call. Tsk is the target task. If + -- the bounds of some entry family depend on discriminants, the expression + -- computed by this function uses the discriminants of the target task. + + procedure Add_Object_Pointer + (Loc : Source_Ptr; + Conc_Typ : Entity_Id; + Decls : List_Id); + -- Prepend an object pointer declaration to the declaration list Decls. + -- This object pointer is initialized to a type conversion of the System. + -- Address pointer passed to entry barrier functions and entry body + -- procedures. + + procedure Add_Formal_Renamings + (Spec : Node_Id; + Decls : List_Id; + Ent : Entity_Id; + Loc : Source_Ptr); + -- Create renaming declarations for the formals, inside the procedure that + -- implements an entry body. The renamings make the original names of the + -- formals accessible to gdb, and serve no other purpose. + -- Spec is the specification of the procedure being built. + -- Decls is the list of declarations to be enhanced. + -- Ent is the entity for the original entry body. + + function Build_Accept_Body (Astat : Node_Id) return Node_Id; + -- Transform accept statement into a block with added exception handler. + -- Used both for simple accept statements and for accept alternatives in + -- select statements. Astat is the accept statement. + + function Build_Barrier_Function + (N : Node_Id; + Ent : Entity_Id; + Pid : Node_Id) return Node_Id; + -- Build the function body returning the value of the barrier expression + -- for the specified entry body. + + function Build_Barrier_Function_Specification + (Loc : Source_Ptr; + Def_Id : Entity_Id) return Node_Id; + -- Build a specification for a function implementing the protected entry + -- barrier of the specified entry body. + + function Build_Corresponding_Record + (N : Node_Id; + Ctyp : Node_Id; + Loc : Source_Ptr) return Node_Id; + -- Common to tasks and protected types. Copy discriminant specifications, + -- build record declaration. N is the type declaration, Ctyp is the + -- concurrent entity (task type or protected type). + + function Build_Entry_Count_Expression + (Concurrent_Type : Node_Id; + Component_List : List_Id; + Loc : Source_Ptr) return Node_Id; + -- Compute number of entries for concurrent object. This is a count of + -- simple entries, followed by an expression that computes the length + -- of the range of each entry family. A single array with that size is + -- allocated for each concurrent object of the type. + + function Build_Parameter_Block + (Loc : Source_Ptr; + Actuals : List_Id; + Formals : List_Id; + Decls : List_Id) return Entity_Id; + -- Generate an access type for each actual parameter in the list Actuals. + -- Create an encapsulating record that contains all the actuals and return + -- its type. Generate: + -- type Ann1 is access all + -- ... + -- type AnnN is access all + -- type Pnn is record + -- : Ann1; + -- ... + -- : AnnN; + -- end record; + + procedure Build_PPC_Wrapper (E : Entity_Id; Decl : Node_Id); + -- Build body of wrapper procedure for an entry or entry family that has + -- pre/postconditions. The body gathers the PPC's and expands them in the + -- usual way, and performs the entry call itself. This way preconditions + -- are evaluated before the call is queued. E is the entry in question, + -- and Decl is the enclosing synchronized type declaration at whose + -- freeze point the generated body is analyzed. + + procedure Build_Wrapper_Bodies + (Loc : Source_Ptr; + Typ : Entity_Id; + N : Node_Id); + -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding + -- record of a concurrent type. N is the insertion node where all bodies + -- will be placed. This routine builds the bodies of the subprograms which + -- serve as an indirection mechanism to overriding primitives of concurrent + -- types, entries and protected procedures. Any new body is analyzed. + + procedure Build_Wrapper_Specs + (Loc : Source_Ptr; + Typ : Entity_Id; + N : in out Node_Id); + -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding + -- record of a concurrent type. N is the insertion node where all specs + -- will be placed. This routine builds the specs of the subprograms which + -- serve as an indirection mechanism to overriding primitives of concurrent + -- types, entries and protected procedures. Any new spec is analyzed. + + function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id; + -- Build the function that translates the entry index in the call + -- (which depends on the size of entry families) into an index into the + -- Entry_Bodies_Array, to determine the body and barrier function used + -- in a protected entry call. A pointer to this function appears in every + -- protected object. + + function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id; + -- Build subprogram declaration for previous one + + function Build_Protected_Entry + (N : Node_Id; + Ent : Entity_Id; + Pid : Node_Id) return Node_Id; + -- Build the procedure implementing the statement sequence of the specified + -- entry body. + + function Build_Protected_Entry_Specification + (Loc : Source_Ptr; + Def_Id : Entity_Id; + Ent_Id : Entity_Id) return Node_Id; + -- Build a specification for the procedure implementing the statements of + -- the specified entry body. Add attributes associating it with the entry + -- defining identifier Ent_Id. + + function Build_Protected_Spec + (N : Node_Id; + Obj_Type : Entity_Id; + Ident : Entity_Id; + Unprotected : Boolean := False) return List_Id; + -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_ + -- Subprogram_Type. Builds signature of protected subprogram, adding the + -- formal that corresponds to the object itself. For an access to protected + -- subprogram, there is no object type to specify, so the parameter has + -- type Address and mode In. An indirect call through such a pointer will + -- convert the address to a reference to the actual object. The object is + -- a limited record and therefore a by_reference type. + + function Build_Protected_Subprogram_Body + (N : Node_Id; + Pid : Node_Id; + N_Op_Spec : Node_Id) return Node_Id; + -- This function is used to construct the protected version of a protected + -- subprogram. Its statement sequence first defers abort, then locks + -- the associated protected object, and then enters a block that contains + -- a call to the unprotected version of the subprogram (for details, see + -- Build_Unprotected_Subprogram_Body). This block statement requires + -- a cleanup handler that unlocks the object in all cases. + -- (see Exp_Ch7.Expand_Cleanup_Actions). + + function Build_Selected_Name + (Prefix : Entity_Id; + Selector : Entity_Id; + Append_Char : Character := ' ') return Name_Id; + -- Build a name in the form of Prefix__Selector, with an optional + -- character appended. This is used for internal subprograms generated + -- for operations of protected types, including barrier functions. + -- For the subprograms generated for entry bodies and entry barriers, + -- the generated name includes a sequence number that makes names + -- unique in the presence of entry overloading. This is necessary + -- because entry body procedures and barrier functions all have the + -- same signature. + + procedure Build_Simple_Entry_Call + (N : Node_Id; + Concval : Node_Id; + Ename : Node_Id; + Index : Node_Id); + -- Some comments here would be useful ??? + + function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id; + -- This routine constructs a specification for the procedure that we will + -- build for the task body for task type T. The spec has the form: + -- + -- procedure tnameB (_Task : access tnameV); + -- + -- where name is the character name taken from the task type entity that + -- is passed as the argument to the procedure, and tnameV is the task + -- value type that is associated with the task type. + + function Build_Unprotected_Subprogram_Body + (N : Node_Id; + Pid : Node_Id) return Node_Id; + -- This routine constructs the unprotected version of a protected + -- subprogram body, which is contains all of the code in the + -- original, unexpanded body. This is the version of the protected + -- subprogram that is called from all protected operations on the same + -- object, including the protected version of the same subprogram. + + procedure Collect_Entry_Families + (Loc : Source_Ptr; + Cdecls : List_Id; + Current_Node : in out Node_Id; + Conctyp : Entity_Id); + -- For each entry family in a concurrent type, create an anonymous array + -- type of the right size, and add a component to the corresponding_record. + + function Concurrent_Object + (Spec_Id : Entity_Id; + Conc_Typ : Entity_Id) return Entity_Id; + -- Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return + -- the entity associated with the concurrent object in the Protected_Body_ + -- Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity + -- denotes formal parameter _O, _object or _task. + + function Copy_Result_Type (Res : Node_Id) return Node_Id; + -- Copy the result type of a function specification, when building the + -- internal operation corresponding to a protected function, or when + -- expanding an access to protected function. If the result is an anonymous + -- access to subprogram itself, we need to create a new signature with the + -- same parameter names and the same resolved types, but with new entities + -- for the formals. + + procedure Debug_Private_Data_Declarations (Decls : List_Id); + -- Decls is a list which may contain the declarations created by Install_ + -- Private_Data_Declarations. All generated entities are marked as needing + -- debug info and debug nodes are manually generation where necessary. This + -- step of the expansion must to be done after private data has been moved + -- to its final resting scope to ensure proper visibility of debug objects. + + function Family_Offset + (Loc : Source_Ptr; + Hi : Node_Id; + Lo : Node_Id; + Ttyp : Entity_Id; + Cap : Boolean) return Node_Id; + -- Compute (Hi - Lo) for two entry family indexes. Hi is the index in + -- an accept statement, or the upper bound in the discrete subtype of + -- an entry declaration. Lo is the corresponding lower bound. Ttyp is + -- the concurrent type of the entry. If Cap is true, the result is + -- capped according to Entry_Family_Bound. + + function Family_Size + (Loc : Source_Ptr; + Hi : Node_Id; + Lo : Node_Id; + Ttyp : Entity_Id; + Cap : Boolean) return Node_Id; + -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in + -- a family, and handle properly the superflat case. This is equivalent + -- to the use of 'Length on the index type, but must use Family_Offset + -- to handle properly the case of bounds that depend on discriminants. + -- If Cap is true, the result is capped according to Entry_Family_Bound. + + procedure Extract_Dispatching_Call + (N : Node_Id; + Call_Ent : out Entity_Id; + Object : out Entity_Id; + Actuals : out List_Id; + Formals : out List_Id); + -- Given a dispatching call, extract the entity of the name of the call, + -- its object parameter, its actual parameters and the formal parameters + -- of the overridden interface-level version. + + procedure Extract_Entry + (N : Node_Id; + Concval : out Node_Id; + Ename : out Node_Id; + Index : out Node_Id); + -- Given an entry call, returns the associated concurrent object, + -- the entry name, and the entry family index. + + function Find_Task_Or_Protected_Pragma + (T : Node_Id; + P : Name_Id) return Node_Id; + -- Searches the task or protected definition T for the first occurrence + -- of the pragma whose name is given by P. The caller has ensured that + -- the pragma is present in the task definition. A special case is that + -- when P is Name_uPriority, the call will also find Interrupt_Priority. + -- ??? Should be implemented with the rep item chain mechanism. + + function Index_Object (Spec_Id : Entity_Id) return Entity_Id; + -- Given a subprogram identifier, return the entity which is associated + -- with the protection entry index in the Protected_Body_Subprogram or the + -- Task_Body_Procedure of Spec_Id. The returned entity denotes formal + -- parameter _E. + + function Is_Potentially_Large_Family + (Base_Index : Entity_Id; + Conctyp : Entity_Id; + Lo : Node_Id; + Hi : Node_Id) return Boolean; + + function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean; + -- Determine whether Id is a function or a procedure and is marked as a + -- private primitive. + + function Null_Statements (Stats : List_Id) return Boolean; + -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END. + -- Allows labels, and pragma Warnings/Unreferenced in the sequence as + -- well to still count as null. Returns True for a null sequence. The + -- argument is the list of statements from the DO-END sequence. + + function Parameter_Block_Pack + (Loc : Source_Ptr; + Blk_Typ : Entity_Id; + Actuals : List_Id; + Formals : List_Id; + Decls : List_Id; + Stmts : List_Id) return Entity_Id; + -- Set the components of the generated parameter block with the values of + -- the actual parameters. Generate aliased temporaries to capture the + -- values for types that are passed by copy. Otherwise generate a reference + -- to the actual's value. Return the address of the aggregate block. + -- Generate: + -- Jnn1 : alias ; + -- Jnn1 := ; + -- ... + -- P : Blk_Typ := ( + -- Jnn1'unchecked_access; + -- 'reference; + -- ...); + + function Parameter_Block_Unpack + (Loc : Source_Ptr; + P : Entity_Id; + Actuals : List_Id; + Formals : List_Id) return List_Id; + -- Retrieve the values of the components from the parameter block and + -- assign then to the original actual parameters. Generate: + -- := P.; + -- ... + -- := P.; + + function Trivial_Accept_OK return Boolean; + -- If there is no DO-END block for an accept, or if the DO-END block has + -- only null statements, then it is possible to do the Rendezvous with much + -- less overhead using the Accept_Trivial routine in the run-time library. + -- However, this is not always a valid optimization. Whether it is valid or + -- not depends on the Task_Dispatching_Policy. The issue is whether a full + -- rescheduling action is required or not. In FIFO_Within_Priorities, such + -- a rescheduling is required, so this optimization is not allowed. This + -- function returns True if the optimization is permitted. + + ----------------------------- + -- Actual_Index_Expression -- + ----------------------------- + + function Actual_Index_Expression + (Sloc : Source_Ptr; + Ent : Entity_Id; + Index : Node_Id; + Tsk : Entity_Id) return Node_Id + is + Ttyp : constant Entity_Id := Etype (Tsk); + Expr : Node_Id; + Num : Node_Id; + Lo : Node_Id; + Hi : Node_Id; + Prev : Entity_Id; + S : Node_Id; + + function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id; + -- Compute difference between bounds of entry family + + -------------------------- + -- Actual_Family_Offset -- + -------------------------- + + function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id is + + function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id; + -- Replace a reference to a discriminant with a selected component + -- denoting the discriminant of the target task. + + ----------------------------- + -- Actual_Discriminant_Ref -- + ----------------------------- + + function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is + Typ : constant Entity_Id := Etype (Bound); + B : Node_Id; + + begin + if not Is_Entity_Name (Bound) + or else Ekind (Entity (Bound)) /= E_Discriminant + then + if Nkind (Bound) = N_Attribute_Reference then + return Bound; + else + B := New_Copy_Tree (Bound); + end if; + + else + B := + Make_Selected_Component (Sloc, + Prefix => New_Copy_Tree (Tsk), + Selector_Name => New_Occurrence_Of (Entity (Bound), Sloc)); + + Analyze_And_Resolve (B, Typ); + end if; + + return + Make_Attribute_Reference (Sloc, + Attribute_Name => Name_Pos, + Prefix => New_Occurrence_Of (Etype (Bound), Sloc), + Expressions => New_List (B)); + end Actual_Discriminant_Ref; + + -- Start of processing for Actual_Family_Offset + + begin + return + Make_Op_Subtract (Sloc, + Left_Opnd => Actual_Discriminant_Ref (Hi), + Right_Opnd => Actual_Discriminant_Ref (Lo)); + end Actual_Family_Offset; + + -- Start of processing for Actual_Index_Expression + + begin + -- The queues of entries and entry families appear in textual order in + -- the associated record. The entry index is computed as the sum of the + -- number of queues for all entries that precede the designated one, to + -- which is added the index expression, if this expression denotes a + -- member of a family. + + -- The following is a place holder for the count of simple entries + + Num := Make_Integer_Literal (Sloc, 1); + + -- We construct an expression which is a series of addition operations. + -- See comments in Entry_Index_Expression, which is identical in + -- structure. + + if Present (Index) then + S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent))); + + Expr := + Make_Op_Add (Sloc, + Left_Opnd => Num, + + Right_Opnd => + Actual_Family_Offset ( + Make_Attribute_Reference (Sloc, + Attribute_Name => Name_Pos, + Prefix => New_Reference_To (Base_Type (S), Sloc), + Expressions => New_List (Relocate_Node (Index))), + Type_Low_Bound (S))); + else + Expr := Num; + end if; + + -- Now add lengths of preceding entries and entry families + + Prev := First_Entity (Ttyp); + + while Chars (Prev) /= Chars (Ent) + or else (Ekind (Prev) /= Ekind (Ent)) + or else not Sem_Ch6.Type_Conformant (Ent, Prev) + loop + if Ekind (Prev) = E_Entry then + Set_Intval (Num, Intval (Num) + 1); + + elsif Ekind (Prev) = E_Entry_Family then + S := + Etype (Discrete_Subtype_Definition (Declaration_Node (Prev))); + + -- The need for the following full view retrieval stems from + -- this complex case of nested generics and tasking: + + -- generic + -- type Formal_Index is range <>; + -- ... + -- package Outer is + -- type Index is private; + -- generic + -- ... + -- package Inner is + -- procedure P; + -- end Inner; + -- private + -- type Index is new Formal_Index range 1 .. 10; + -- end Outer; + + -- package body Outer is + -- task type T is + -- entry Fam (Index); -- (2) + -- entry E; + -- end T; + -- package body Inner is -- (3) + -- procedure P is + -- begin + -- T.E; -- (1) + -- end P; + -- end Inner; + -- ... + + -- We are currently building the index expression for the entry + -- call "T.E" (1). Part of the expansion must mention the range + -- of the discrete type "Index" (2) of entry family "Fam". + -- However only the private view of type "Index" is available to + -- the inner generic (3) because there was no prior mention of + -- the type inside "Inner". This visibility requirement is + -- implicit and cannot be detected during the construction of + -- the generic trees and needs special handling. + + if In_Instance_Body + and then Is_Private_Type (S) + and then Present (Full_View (S)) + then + S := Full_View (S); + end if; + + Lo := Type_Low_Bound (S); + Hi := Type_High_Bound (S); + + Expr := + Make_Op_Add (Sloc, + Left_Opnd => Expr, + Right_Opnd => + Make_Op_Add (Sloc, + Left_Opnd => + Actual_Family_Offset (Hi, Lo), + Right_Opnd => + Make_Integer_Literal (Sloc, 1))); + + -- Other components are anonymous types to be ignored + + else + null; + end if; + + Next_Entity (Prev); + end loop; + + return Expr; + end Actual_Index_Expression; + + -------------------------- + -- Add_Formal_Renamings -- + -------------------------- + + procedure Add_Formal_Renamings + (Spec : Node_Id; + Decls : List_Id; + Ent : Entity_Id; + Loc : Source_Ptr) + is + Ptr : constant Entity_Id := + Defining_Identifier + (Next (First (Parameter_Specifications (Spec)))); + -- The name of the formal that holds the address of the parameter block + -- for the call. + + Comp : Entity_Id; + Decl : Node_Id; + Formal : Entity_Id; + New_F : Entity_Id; + + begin + Formal := First_Formal (Ent); + while Present (Formal) loop + Comp := Entry_Component (Formal); + New_F := + Make_Defining_Identifier (Sloc (Formal), + Chars => Chars (Formal)); + Set_Etype (New_F, Etype (Formal)); + Set_Scope (New_F, Ent); + + -- Now we set debug info needed on New_F even though it does not + -- come from source, so that the debugger will get the right + -- information for these generated names. + + Set_Debug_Info_Needed (New_F); + + if Ekind (Formal) = E_In_Parameter then + Set_Ekind (New_F, E_Constant); + else + Set_Ekind (New_F, E_Variable); + Set_Extra_Constrained (New_F, Extra_Constrained (Formal)); + end if; + + Set_Actual_Subtype (New_F, Actual_Subtype (Formal)); + + Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => New_F, + Subtype_Mark => + New_Reference_To (Etype (Formal), Loc), + Name => + Make_Explicit_Dereference (Loc, + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Entry_Parameters_Type (Ent), + Make_Identifier (Loc, Chars (Ptr))), + Selector_Name => New_Reference_To (Comp, Loc)))); + + Append (Decl, Decls); + Set_Renamed_Object (Formal, New_F); + Next_Formal (Formal); + end loop; + end Add_Formal_Renamings; + + ------------------------ + -- Add_Object_Pointer -- + ------------------------ + + procedure Add_Object_Pointer + (Loc : Source_Ptr; + Conc_Typ : Entity_Id; + Decls : List_Id) + is + Rec_Typ : constant Entity_Id := Corresponding_Record_Type (Conc_Typ); + Decl : Node_Id; + Obj_Ptr : Node_Id; + + begin + -- Create the renaming declaration for the Protection object of a + -- protected type. _Object is used by Complete_Entry_Body. + -- ??? An attempt to make this a renaming was unsuccessful. + + -- Build the entity for the access type + + Obj_Ptr := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Rec_Typ), 'P')); + + -- Generate: + -- _object : poVP := poVP!O; + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uObject), + Object_Definition => + New_Reference_To (Obj_Ptr, Loc), + Expression => + Unchecked_Convert_To (Obj_Ptr, Make_Identifier (Loc, Name_uO))); + Set_Debug_Info_Needed (Defining_Identifier (Decl)); + Prepend_To (Decls, Decl); + + -- Generate: + -- type poVP is access poV; + + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => + Obj_Ptr, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Reference_To (Rec_Typ, Loc))); + Set_Debug_Info_Needed (Defining_Identifier (Decl)); + Prepend_To (Decls, Decl); + end Add_Object_Pointer; + + ----------------------- + -- Build_Accept_Body -- + ----------------------- + + function Build_Accept_Body (Astat : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (Astat); + Stats : constant Node_Id := Handled_Statement_Sequence (Astat); + New_S : Node_Id; + Hand : Node_Id; + Call : Node_Id; + Ohandle : Node_Id; + + begin + -- At the end of the statement sequence, Complete_Rendezvous is called. + -- A label skipping the Complete_Rendezvous, and all other accept + -- processing, has already been added for the expansion of requeue + -- statements. The Sloc is copied from the last statement since it + -- is really part of this last statement. + + Call := + Build_Runtime_Call + (Sloc (Last (Statements (Stats))), RE_Complete_Rendezvous); + Insert_Before (Last (Statements (Stats)), Call); + Analyze (Call); + + -- If exception handlers are present, then append Complete_Rendezvous + -- calls to the handlers, and construct the required outer block. As + -- above, the Sloc is copied from the last statement in the sequence. + + if Present (Exception_Handlers (Stats)) then + Hand := First (Exception_Handlers (Stats)); + while Present (Hand) loop + Call := + Build_Runtime_Call + (Sloc (Last (Statements (Hand))), RE_Complete_Rendezvous); + Append (Call, Statements (Hand)); + Analyze (Call); + Next (Hand); + end loop; + + New_S := + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Block_Statement (Loc, + Handled_Statement_Sequence => Stats))); + + else + New_S := Stats; + end if; + + -- At this stage we know that the new statement sequence does not + -- have an exception handler part, so we supply one to call + -- Exceptional_Complete_Rendezvous. This handler is + + -- when all others => + -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); + + -- We handle Abort_Signal to make sure that we properly catch the abort + -- case and wake up the caller. + + Ohandle := Make_Others_Choice (Loc); + Set_All_Others (Ohandle); + + Set_Exception_Handlers (New_S, + New_List ( + Make_Implicit_Exception_Handler (Loc, + Exception_Choices => New_List (Ohandle), + + Statements => New_List ( + Make_Procedure_Call_Statement (Sloc (Stats), + Name => New_Reference_To ( + RTE (RE_Exceptional_Complete_Rendezvous), Sloc (Stats)), + Parameter_Associations => New_List ( + Make_Function_Call (Sloc (Stats), + Name => New_Reference_To ( + RTE (RE_Get_GNAT_Exception), Sloc (Stats))))))))); + + Set_Parent (New_S, Astat); -- temp parent for Analyze call + Analyze_Exception_Handlers (Exception_Handlers (New_S)); + Expand_Exception_Handlers (New_S); + + -- Exceptional_Complete_Rendezvous must be called with abort + -- still deferred, which is the case for a "when all others" handler. + + return New_S; + end Build_Accept_Body; + + ----------------------------------- + -- Build_Activation_Chain_Entity -- + ----------------------------------- + + procedure Build_Activation_Chain_Entity (N : Node_Id) is + P : Node_Id; + Decls : List_Id; + Chain : Entity_Id; + + begin + -- Loop to find enclosing construct containing activation chain variable + -- The construct is a body, a block, or an extended return. + + P := Parent (N); + + while not Nkind_In (P, N_Subprogram_Body, + N_Entry_Body, + N_Package_Declaration, + N_Package_Body, + N_Block_Statement, + N_Task_Body, + N_Extended_Return_Statement) + loop + P := Parent (P); + end loop; + + -- If we are in a package body, the activation chain variable is + -- declared in the body, but the Activation_Chain_Entity is attached + -- to the spec. + + if Nkind (P) = N_Package_Body then + Decls := Declarations (P); + P := Unit_Declaration_Node (Corresponding_Spec (P)); + + elsif Nkind (P) = N_Package_Declaration then + Decls := Visible_Declarations (Specification (P)); + + elsif Nkind (P) = N_Extended_Return_Statement then + Decls := Return_Object_Declarations (P); + + else + Decls := Declarations (P); + end if; + + -- If activation chain entity not already declared, declare it + + if Nkind (P) = N_Extended_Return_Statement + or else No (Activation_Chain_Entity (P)) + then + Chain := Make_Defining_Identifier (Sloc (N), Name_uChain); + + -- Note: An extended return statement is not really a task activator, + -- but it does have an activation chain on which to store the tasks + -- temporarily. On successful return, the tasks on this chain are + -- moved to the chain passed in by the caller. We do not build an + -- Activation_Chain_Entity for an N_Extended_Return_Statement, + -- because we do not want to build a call to Activate_Tasks. Task + -- activation is the responsibility of the caller. + + if Nkind (P) /= N_Extended_Return_Statement then + Set_Activation_Chain_Entity (P, Chain); + end if; + + Prepend_To (Decls, + Make_Object_Declaration (Sloc (P), + Defining_Identifier => Chain, + Aliased_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Activation_Chain), Sloc (P)))); + + Analyze (First (Decls)); + end if; + end Build_Activation_Chain_Entity; + + ---------------------------- + -- Build_Barrier_Function -- + ---------------------------- + + function Build_Barrier_Function + (N : Node_Id; + Ent : Entity_Id; + Pid : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Func_Id : constant Entity_Id := Barrier_Function (Ent); + Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N); + Op_Decls : constant List_Id := New_List; + Func_Body : Node_Id; + + begin + -- Add a declaration for the Protection object, renaming declarations + -- for the discriminals and privals and finally a declaration for the + -- entry family index (if applicable). + + Install_Private_Data_Declarations + (Loc, Func_Id, Pid, N, Op_Decls, True, Ekind (Ent) = E_Entry_Family); + + -- Note: the condition in the barrier function needs to be properly + -- processed for the C/Fortran boolean possibility, but this happens + -- automatically since the return statement does this normalization. + + Func_Body := + Make_Subprogram_Body (Loc, + Specification => + Build_Barrier_Function_Specification (Loc, + Make_Defining_Identifier (Loc, Chars (Func_Id))), + Declarations => Op_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => Condition (Ent_Formals))))); + Set_Is_Entry_Barrier_Function (Func_Body); + + return Func_Body; + end Build_Barrier_Function; + + ------------------------------------------ + -- Build_Barrier_Function_Specification -- + ------------------------------------------ + + function Build_Barrier_Function_Specification + (Loc : Source_Ptr; + Def_Id : Entity_Id) return Node_Id + is + begin + Set_Debug_Info_Needed (Def_Id); + + return Make_Function_Specification (Loc, + Defining_Unit_Name => Def_Id, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uO), + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uE), + Parameter_Type => + New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))), + + Result_Definition => + New_Reference_To (Standard_Boolean, Loc)); + end Build_Barrier_Function_Specification; + + -------------------------- + -- Build_Call_With_Task -- + -------------------------- + + function Build_Call_With_Task + (N : Node_Id; + E : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + begin + return + Make_Function_Call (Loc, + Name => New_Reference_To (E, Loc), + Parameter_Associations => New_List (Concurrent_Ref (N))); + end Build_Call_With_Task; + + -------------------------------- + -- Build_Corresponding_Record -- + -------------------------------- + + function Build_Corresponding_Record + (N : Node_Id; + Ctyp : Entity_Id; + Loc : Source_Ptr) return Node_Id + is + Rec_Ent : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_External_Name (Chars (Ctyp), 'V')); + Disc : Entity_Id; + Dlist : List_Id; + New_Disc : Entity_Id; + Cdecls : List_Id; + + begin + Set_Corresponding_Record_Type (Ctyp, Rec_Ent); + Set_Ekind (Rec_Ent, E_Record_Type); + Set_Has_Delayed_Freeze (Rec_Ent, Has_Delayed_Freeze (Ctyp)); + Set_Is_Concurrent_Record_Type (Rec_Ent, True); + Set_Corresponding_Concurrent_Type (Rec_Ent, Ctyp); + Set_Stored_Constraint (Rec_Ent, No_Elist); + Cdecls := New_List; + + -- Use discriminals to create list of discriminants for record, and + -- create new discriminals for use in default expressions, etc. It is + -- worth noting that a task discriminant gives rise to 5 entities; + + -- a) The original discriminant. + -- b) The discriminal for use in the task. + -- c) The discriminant of the corresponding record. + -- d) The discriminal for the init proc of the corresponding record. + -- e) The local variable that renames the discriminant in the procedure + -- for the task body. + + -- In fact the discriminals b) are used in the renaming declarations + -- for e). See details in einfo (Handling of Discriminants). + + if Present (Discriminant_Specifications (N)) then + Dlist := New_List; + Disc := First_Discriminant (Ctyp); + + while Present (Disc) loop + New_Disc := CR_Discriminant (Disc); + + Append_To (Dlist, + Make_Discriminant_Specification (Loc, + Defining_Identifier => New_Disc, + Discriminant_Type => + New_Occurrence_Of (Etype (Disc), Loc), + Expression => + New_Copy (Discriminant_Default_Value (Disc)))); + + Next_Discriminant (Disc); + end loop; + + else + Dlist := No_List; + end if; + + -- Now we can construct the record type declaration. Note that this + -- record is "limited tagged". It is "limited" to reflect the underlying + -- limitedness of the task or protected object that it represents, and + -- ensuring for example that it is properly passed by reference. It is + -- "tagged" to give support to dispatching calls through interfaces. We + -- propagate here the list of interfaces covered by the concurrent type + -- (Ada 2005: AI-345). + + return + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Rec_Ent, + Discriminant_Specifications => Dlist, + Type_Definition => + Make_Record_Definition (Loc, + Component_List => + Make_Component_List (Loc, + Component_Items => Cdecls), + Tagged_Present => + Ada_Version >= Ada_2005 and then Is_Tagged_Type (Ctyp), + Interface_List => Interface_List (N), + Limited_Present => True)); + end Build_Corresponding_Record; + + ---------------------------------- + -- Build_Entry_Count_Expression -- + ---------------------------------- + + function Build_Entry_Count_Expression + (Concurrent_Type : Node_Id; + Component_List : List_Id; + Loc : Source_Ptr) return Node_Id + is + Eindx : Nat; + Ent : Entity_Id; + Ecount : Node_Id; + Comp : Node_Id; + Lo : Node_Id; + Hi : Node_Id; + Typ : Entity_Id; + Large : Boolean; + + begin + -- Count number of non-family entries + + Eindx := 0; + Ent := First_Entity (Concurrent_Type); + while Present (Ent) loop + if Ekind (Ent) = E_Entry then + Eindx := Eindx + 1; + end if; + + Next_Entity (Ent); + end loop; + + Ecount := Make_Integer_Literal (Loc, Eindx); + + -- Loop through entry families building the addition nodes + + Ent := First_Entity (Concurrent_Type); + Comp := First (Component_List); + while Present (Ent) loop + if Ekind (Ent) = E_Entry_Family then + while Chars (Ent) /= Chars (Defining_Identifier (Comp)) loop + Next (Comp); + end loop; + + Typ := Etype (Discrete_Subtype_Definition (Parent (Ent))); + Hi := Type_High_Bound (Typ); + Lo := Type_Low_Bound (Typ); + Large := Is_Potentially_Large_Family + (Base_Type (Typ), Concurrent_Type, Lo, Hi); + Ecount := + Make_Op_Add (Loc, + Left_Opnd => Ecount, + Right_Opnd => Family_Size + (Loc, Hi, Lo, Concurrent_Type, Large)); + end if; + + Next_Entity (Ent); + end loop; + + return Ecount; + end Build_Entry_Count_Expression; + + ----------------------- + -- Build_Entry_Names -- + ----------------------- + + function Build_Entry_Names (Conc_Typ : Entity_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (Conc_Typ); + B_Decls : List_Id; + B_Stmts : List_Id; + Comp : Node_Id; + Index : Entity_Id; + Index_Typ : RE_Id; + Typ : Entity_Id := Conc_Typ; + + procedure Build_Entry_Family_Name (Id : Entity_Id); + -- Generate: + -- for Lnn in Family_Low .. Family_High loop + -- Inn := Inn + 1; + -- Set_Entry_Name + -- (_init._object _init._task_id, + -- Inn, + -- new String ("(" & Lnn'Img & ")")); + -- end loop; + -- Note that the bounds of the range may reference discriminants. The + -- above construct is added directly to the statements of the block. + + procedure Build_Entry_Name (Id : Entity_Id); + -- Generate: + -- Inn := Inn + 1; + -- Set_Entry_Name + -- (_init._object _init._task_id, + -- Inn, + -- new String (""); + -- The above construct is added directly to the statements of the block. + + function Build_Set_Entry_Name_Call (Arg3 : Node_Id) return Node_Id; + -- Generate the call to the runtime routine Set_Entry_Name with actuals + -- _init._task_id or _init._object, Inn and Arg3. + + function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id; + -- Given a protected type or its corresponding record, find the type of + -- field _object. + + procedure Increment_Index (Stmts : List_Id); + -- Generate the following and add it to Stmts + -- Inn := Inn + 1; + + ----------------------------- + -- Build_Entry_Family_Name -- + ----------------------------- + + procedure Build_Entry_Family_Name (Id : Entity_Id) is + Def : constant Node_Id := + Discrete_Subtype_Definition (Parent (Id)); + L_Id : constant Entity_Id := Make_Temporary (Loc, 'L'); + L_Stmts : constant List_Id := New_List; + Val : Node_Id; + + function Build_Range (Def : Node_Id) return Node_Id; + -- Given a discrete subtype definition of an entry family, generate a + -- range node which covers the range of Def's type. + + ----------------- + -- Build_Range -- + ----------------- + + function Build_Range (Def : Node_Id) return Node_Id is + High : Node_Id := Type_High_Bound (Etype (Def)); + Low : Node_Id := Type_Low_Bound (Etype (Def)); + + begin + -- If a bound references a discriminant, generate an identifier + -- with the same name. Resolution will map it to the formals of + -- the init proc. + + if Is_Entity_Name (Low) + and then Ekind (Entity (Low)) = E_Discriminant + then + Low := Make_Identifier (Loc, Chars (Low)); + else + Low := New_Copy_Tree (Low); + end if; + + if Is_Entity_Name (High) + and then Ekind (Entity (High)) = E_Discriminant + then + High := Make_Identifier (Loc, Chars (High)); + else + High := New_Copy_Tree (High); + end if; + + return + Make_Range (Loc, + Low_Bound => Low, + High_Bound => High); + end Build_Range; + + -- Start of processing for Build_Entry_Family_Name + + begin + Get_Name_String (Chars (Id)); + + -- Add a leading '(' + + Add_Char_To_Name_Buffer ('('); + + -- Generate: + -- new String'("(" & Lnn'Img & ")"); + + -- This is an implicit heap allocation, and Comes_From_Source is + -- False, which ensures that it will get flagged as a violation of + -- No_Implicit_Heap_Allocations when that restriction applies. + + Val := + Make_Allocator (Loc, + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Reference_To (Standard_String, Loc), + Expression => + Make_Op_Concat (Loc, + Left_Opnd => + Make_Op_Concat (Loc, + Left_Opnd => + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (L_Id, Loc), + Attribute_Name => Name_Img)), + Right_Opnd => + Make_String_Literal (Loc, + Strval => ")")))); + + Increment_Index (L_Stmts); + Append_To (L_Stmts, Build_Set_Entry_Name_Call (Val)); + + -- Generate: + -- for Lnn in Family_Low .. Family_High loop + -- Inn := Inn + 1; + -- Set_Entry_Name + -- (_init._object _init._task_id, Inn, ); + -- end loop; + + Append_To (B_Stmts, + Make_Loop_Statement (Loc, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => L_Id, + Discrete_Subtype_Definition => Build_Range (Def))), + Statements => L_Stmts, + End_Label => Empty)); + end Build_Entry_Family_Name; + + ---------------------- + -- Build_Entry_Name -- + ---------------------- + + procedure Build_Entry_Name (Id : Entity_Id) is + Val : Node_Id; + + begin + Get_Name_String (Chars (Id)); + + -- This is an implicit heap allocation, and Comes_From_Source is + -- False, which ensures that it will get flagged as a violation of + -- No_Implicit_Heap_Allocations when that restriction applies. + + Val := + Make_Allocator (Loc, + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Reference_To (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, + String_From_Name_Buffer))); + + Increment_Index (B_Stmts); + Append_To (B_Stmts, Build_Set_Entry_Name_Call (Val)); + end Build_Entry_Name; + + ------------------------------- + -- Build_Set_Entry_Name_Call -- + ------------------------------- + + function Build_Set_Entry_Name_Call (Arg3 : Node_Id) return Node_Id is + Arg1 : Name_Id; + Proc : RE_Id; + + begin + -- Determine the proper name for the first argument and the RTS + -- routine to call. + + if Is_Protected_Type (Typ) then + Arg1 := Name_uObject; + Proc := RO_PE_Set_Entry_Name; + + else pragma Assert (Is_Task_Type (Typ)); + Arg1 := Name_uTask_Id; + Proc := RO_TS_Set_Entry_Name; + end if; + + -- Generate: + -- Set_Entry_Name (_init.Arg1, Inn, Arg3); + + return + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (Proc), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, -- _init._object + Prefix => -- _init._task_id + Make_Identifier (Loc, Name_uInit), + Selector_Name => + Make_Identifier (Loc, Arg1)), + New_Reference_To (Index, Loc), -- Inn + Arg3)); -- Val + end Build_Set_Entry_Name_Call; + + -------------------------- + -- Find_Protection_Type -- + -------------------------- + + function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is + Comp : Entity_Id; + Typ : Entity_Id := Conc_Typ; + + begin + if Is_Concurrent_Type (Typ) then + Typ := Corresponding_Record_Type (Typ); + end if; + + Comp := First_Component (Typ); + while Present (Comp) loop + if Chars (Comp) = Name_uObject then + return Base_Type (Etype (Comp)); + end if; + + Next_Component (Comp); + end loop; + + -- The corresponding record of a protected type should always have an + -- _object field. + + raise Program_Error; + end Find_Protection_Type; + + --------------------- + -- Increment_Index -- + --------------------- + + procedure Increment_Index (Stmts : List_Id) is + begin + -- Generate: + -- Inn := Inn + 1; + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Index, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => + New_Reference_To (Index, Loc), + Right_Opnd => + Make_Integer_Literal (Loc, 1)))); + end Increment_Index; + + -- Start of processing for Build_Entry_Names + + begin + -- Retrieve the original concurrent type + + if Is_Concurrent_Record_Type (Typ) then + Typ := Corresponding_Concurrent_Type (Typ); + end if; + + pragma Assert (Is_Protected_Type (Typ) or else Is_Task_Type (Typ)); + + -- Nothing to do if the type has no entries + + if not Has_Entries (Typ) then + return Empty; + end if; + + -- Avoid generating entry names for a protected type with only one entry + + if Is_Protected_Type (Typ) + and then Find_Protection_Type (Typ) /= RTE (RE_Protection_Entries) + then + return Empty; + end if; + + Index := Make_Temporary (Loc, 'I'); + + -- Step 1: Generate the declaration of the index variable: + -- Inn : Protected_Entry_Index := 0; + -- or + -- Inn : Task_Entry_Index := 0; + + if Is_Protected_Type (Typ) then + Index_Typ := RE_Protected_Entry_Index; + else + Index_Typ := RE_Task_Entry_Index; + end if; + + B_Decls := New_List; + Append_To (B_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Index, + Object_Definition => New_Reference_To (RTE (Index_Typ), Loc), + Expression => Make_Integer_Literal (Loc, 0))); + + B_Stmts := New_List; + + -- Step 2: Generate a call to Set_Entry_Name for each entry and entry + -- family member. + + Comp := First_Entity (Typ); + while Present (Comp) loop + if Ekind (Comp) = E_Entry then + Build_Entry_Name (Comp); + + elsif Ekind (Comp) = E_Entry_Family then + Build_Entry_Family_Name (Comp); + end if; + + Next_Entity (Comp); + end loop; + + -- Step 3: Wrap the statements in a block + + return + Make_Block_Statement (Loc, + Declarations => B_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => B_Stmts)); + end Build_Entry_Names; + + --------------------------- + -- Build_Parameter_Block -- + --------------------------- + + function Build_Parameter_Block + (Loc : Source_Ptr; + Actuals : List_Id; + Formals : List_Id; + Decls : List_Id) return Entity_Id + is + Actual : Entity_Id; + Comp_Nam : Node_Id; + Comps : List_Id; + Formal : Entity_Id; + Has_Comp : Boolean := False; + Rec_Nam : Node_Id; + + begin + Actual := First (Actuals); + Comps := New_List; + Formal := Defining_Identifier (First (Formals)); + + while Present (Actual) loop + if not Is_Controlling_Actual (Actual) then + + -- Generate: + -- type Ann is access all + + Comp_Nam := Make_Temporary (Loc, 'A'); + + Append_To (Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Comp_Nam, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Constant_Present => Ekind (Formal) = E_In_Parameter, + Subtype_Indication => + New_Reference_To (Etype (Actual), Loc)))); + + -- Generate: + -- Param : Ann; + + Append_To (Comps, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Formal)), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => + False, + Subtype_Indication => + New_Reference_To (Comp_Nam, Loc)))); + + Has_Comp := True; + end if; + + Next_Actual (Actual); + Next_Formal_With_Extras (Formal); + end loop; + + Rec_Nam := Make_Temporary (Loc, 'P'); + + if Has_Comp then + + -- Generate: + -- type Pnn is record + -- Param1 : Ann1; + -- ... + -- ParamN : AnnN; + + -- where Pnn is a parameter wrapping record, Param1 .. ParamN are + -- the original parameter names and Ann1 .. AnnN are the access to + -- actual types. + + Append_To (Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => + Rec_Nam, + Type_Definition => + Make_Record_Definition (Loc, + Component_List => + Make_Component_List (Loc, Comps)))); + else + -- Generate: + -- type Pnn is null record; + + Append_To (Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => + Rec_Nam, + Type_Definition => + Make_Record_Definition (Loc, + Null_Present => True, + Component_List => Empty))); + end if; + + return Rec_Nam; + end Build_Parameter_Block; + + ----------------------- + -- Build_PPC_Wrapper -- + ----------------------- + + procedure Build_PPC_Wrapper (E : Entity_Id; Decl : Node_Id) is + Loc : constant Source_Ptr := Sloc (E); + Synch_Type : constant Entity_Id := Scope (E); + + Wrapper_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (E), 'E')); + -- the wrapper procedure name + + Wrapper_Body : Node_Id; + + Synch_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Scope (E)), 'A')); + -- The parameter that designates the synchronized object in the call + + Actuals : constant List_Id := New_List; + -- the actuals in the entry call. + + Decls : constant List_Id := New_List; + + Entry_Call : Node_Id; + Entry_Name : Node_Id; + + Specs : List_Id; + -- The specification of the wrapper procedure + + begin + + -- Only build the wrapper if entry has pre/postconditions. + -- Should this be done unconditionally instead ??? + + declare + P : Node_Id; + + begin + P := Spec_PPC_List (E); + if No (P) then + return; + end if; + + -- Transfer ppc pragmas to the declarations of the wrapper + + while Present (P) loop + if Pragma_Name (P) = Name_Precondition + or else Pragma_Name (P) = Name_Postcondition + then + Append (Relocate_Node (P), Decls); + Set_Analyzed (Last (Decls), False); + end if; + + P := Next_Pragma (P); + end loop; + end; + + -- First formal is synchronized object + + Specs := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Synch_Id, + Out_Present => True, + In_Present => True, + Parameter_Type => New_Occurrence_Of (Scope (E), Loc))); + + Entry_Name := + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Synch_Id, Loc), + Selector_Name => New_Occurrence_Of (E, Loc)); + + -- If entity is entry family, second formal is the corresponding index, + -- and entry name is an indexed component. + + if Ekind (E) = E_Entry_Family then + declare + Index : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_I); + begin + Append_To (Specs, + Make_Parameter_Specification (Loc, + Defining_Identifier => Index, + Parameter_Type => + New_Occurrence_Of (Entry_Index_Type (E), Loc))); + + Entry_Name := + Make_Indexed_Component (Loc, + Prefix => Entry_Name, + Expressions => New_List (New_Occurrence_Of (Index, Loc))); + end; + end if; + + Entry_Call := + Make_Procedure_Call_Statement (Loc, + Name => Entry_Name, + Parameter_Associations => Actuals); + + -- Now add formals that match those of the entry, and build actuals for + -- the nested entry call. + + declare + Form : Entity_Id; + New_Form : Entity_Id; + Parm_Spec : Node_Id; + + begin + Form := First_Formal (E); + while Present (Form) loop + New_Form := Make_Defining_Identifier (Loc, Chars (Form)); + Parm_Spec := + Make_Parameter_Specification (Loc, + Defining_Identifier => New_Form, + Out_Present => Out_Present (Parent (Form)), + In_Present => In_Present (Parent (Form)), + Parameter_Type => New_Occurrence_Of (Etype (Form), Loc)); + + Append (Parm_Spec, Specs); + Append (New_Occurrence_Of (New_Form, Loc), Actuals); + Next_Formal (Form); + end loop; + end; + + -- Add renaming declarations for the discriminants of the enclosing + -- type, which may be visible in the preconditions. + + if Has_Discriminants (Synch_Type) then + declare + D : Entity_Id; + Decl : Node_Id; + + begin + D := First_Discriminant (Synch_Type); + while Present (D) loop + Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (D)), + Subtype_Mark => New_Reference_To (Etype (D), Loc), + Name => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Synch_Id, Loc), + Selector_Name => Make_Identifier (Loc, Chars (D)))); + Prepend (Decl, Decls); + Next_Discriminant (D); + end loop; + end; + end if; + + Set_PPC_Wrapper (E, Wrapper_Id); + Wrapper_Body := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Wrapper_Id, + Parameter_Specifications => Specs), + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Entry_Call))); + + -- The wrapper body is analyzed when the enclosing type is frozen + + Append_Freeze_Action (Defining_Entity (Decl), Wrapper_Body); + end Build_PPC_Wrapper; + + -------------------------- + -- Build_Wrapper_Bodies -- + -------------------------- + + procedure Build_Wrapper_Bodies + (Loc : Source_Ptr; + Typ : Entity_Id; + N : Node_Id) + is + Rec_Typ : Entity_Id; + + function Build_Wrapper_Body + (Loc : Source_Ptr; + Subp_Id : Entity_Id; + Obj_Typ : Entity_Id; + Formals : List_Id) return Node_Id; + -- Ada 2005 (AI-345): Build the body that wraps a primitive operation + -- associated with a protected or task type. Subp_Id is the subprogram + -- name which will be wrapped. Obj_Typ is the type of the new formal + -- parameter which handles dispatching and object notation. Formals are + -- the original formals of Subp_Id which will be explicitly replicated. + + ------------------------ + -- Build_Wrapper_Body -- + ------------------------ + + function Build_Wrapper_Body + (Loc : Source_Ptr; + Subp_Id : Entity_Id; + Obj_Typ : Entity_Id; + Formals : List_Id) return Node_Id + is + Body_Spec : Node_Id; + + begin + Body_Spec := Build_Wrapper_Spec (Subp_Id, Obj_Typ, Formals); + + -- The subprogram is not overriding or is not a primitive declared + -- between two views. + + if No (Body_Spec) then + return Empty; + end if; + + declare + Actuals : List_Id := No_List; + Conv_Id : Node_Id; + First_Form : Node_Id; + Formal : Node_Id; + Nam : Node_Id; + + begin + -- Map formals to actuals. Use the list built for the wrapper + -- spec, skipping the object notation parameter. + + First_Form := First (Parameter_Specifications (Body_Spec)); + + Formal := First_Form; + Next (Formal); + + if Present (Formal) then + Actuals := New_List; + while Present (Formal) loop + Append_To (Actuals, + Make_Identifier (Loc, + Chars => Chars (Defining_Identifier (Formal)))); + Next (Formal); + end loop; + end if; + + -- Special processing for primitives declared between a private + -- type and its completion: the wrapper needs a properly typed + -- parameter if the wrapped operation has a controlling first + -- parameter. Note that this might not be the case for a function + -- with a controlling result. + + if Is_Private_Primitive_Subprogram (Subp_Id) then + if No (Actuals) then + Actuals := New_List; + end if; + + if Is_Controlling_Formal (First_Formal (Subp_Id)) then + Prepend_To (Actuals, + Unchecked_Convert_To + (Corresponding_Concurrent_Type (Obj_Typ), + Make_Identifier (Loc, Name_uO))); + + else + Prepend_To (Actuals, + Make_Identifier (Loc, + Chars => Chars (Defining_Identifier (First_Form)))); + end if; + + Nam := New_Reference_To (Subp_Id, Loc); + else + -- An access-to-variable object parameter requires an explicit + -- dereference in the unchecked conversion. This case occurs + -- when a protected entry wrapper must override an interface + -- level procedure with interface access as first parameter. + + -- O.all.Subp_Id (Formal_1, ..., Formal_N) + + if Nkind (Parameter_Type (First_Form)) = + N_Access_Definition + then + Conv_Id := + Make_Explicit_Dereference (Loc, + Prefix => Make_Identifier (Loc, Name_uO)); + else + Conv_Id := Make_Identifier (Loc, Name_uO); + end if; + + Nam := + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To + (Corresponding_Concurrent_Type (Obj_Typ), Conv_Id), + Selector_Name => New_Reference_To (Subp_Id, Loc)); + end if; + + -- Create the subprogram body. For a function, the call to the + -- actual subprogram has to be converted to the corresponding + -- record if it is a controlling result. + + if Ekind (Subp_Id) = E_Function then + declare + Res : Node_Id; + + begin + Res := + Make_Function_Call (Loc, + Name => Nam, + Parameter_Associations => Actuals); + + if Has_Controlling_Result (Subp_Id) then + Res := + Unchecked_Convert_To + (Corresponding_Record_Type (Etype (Subp_Id)), Res); + end if; + + return + Make_Subprogram_Body (Loc, + Specification => Body_Spec, + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, Res)))); + end; + + else + return + Make_Subprogram_Body (Loc, + Specification => Body_Spec, + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => Nam, + Parameter_Associations => Actuals)))); + end if; + end; + end Build_Wrapper_Body; + + -- Start of processing for Build_Wrapper_Bodies + + begin + if Is_Concurrent_Type (Typ) then + Rec_Typ := Corresponding_Record_Type (Typ); + else + Rec_Typ := Typ; + end if; + + -- Generate wrapper bodies for a concurrent type which implements an + -- interface. + + if Present (Interfaces (Rec_Typ)) then + declare + Insert_Nod : Node_Id; + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + Prim_Decl : Node_Id; + Subp : Entity_Id; + Wrap_Body : Node_Id; + Wrap_Id : Entity_Id; + + begin + Insert_Nod := N; + + -- Examine all primitive operations of the corresponding record + -- type, looking for wrapper specs. Generate bodies in order to + -- complete them. + + Prim_Elmt := First_Elmt (Primitive_Operations (Rec_Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if (Ekind (Prim) = E_Function + or else Ekind (Prim) = E_Procedure) + and then Is_Primitive_Wrapper (Prim) + then + Subp := Wrapped_Entity (Prim); + Prim_Decl := Parent (Parent (Prim)); + + Wrap_Body := + Build_Wrapper_Body (Loc, + Subp_Id => Subp, + Obj_Typ => Rec_Typ, + Formals => Parameter_Specifications (Parent (Subp))); + Wrap_Id := Defining_Unit_Name (Specification (Wrap_Body)); + + Set_Corresponding_Spec (Wrap_Body, Prim); + Set_Corresponding_Body (Prim_Decl, Wrap_Id); + + Insert_After (Insert_Nod, Wrap_Body); + Insert_Nod := Wrap_Body; + + Analyze (Wrap_Body); + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end; + end if; + end Build_Wrapper_Bodies; + + ------------------------ + -- Build_Wrapper_Spec -- + ------------------------ + + function Build_Wrapper_Spec + (Subp_Id : Entity_Id; + Obj_Typ : Entity_Id; + Formals : List_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Subp_Id); + First_Param : Node_Id; + Iface : Entity_Id; + Iface_Elmt : Elmt_Id; + Iface_Op : Entity_Id; + Iface_Op_Elmt : Elmt_Id; + + function Overriding_Possible + (Iface_Op : Entity_Id; + Wrapper : Entity_Id) return Boolean; + -- Determine whether a primitive operation can be overridden by Wrapper. + -- Iface_Op is the candidate primitive operation of an interface type, + -- Wrapper is the generated entry wrapper. + + function Replicate_Formals + (Loc : Source_Ptr; + Formals : List_Id) return List_Id; + -- An explicit parameter replication is required due to the Is_Entry_ + -- Formal flag being set for all the formals of an entry. The explicit + -- replication removes the flag that would otherwise cause a different + -- path of analysis. + + ------------------------- + -- Overriding_Possible -- + ------------------------- + + function Overriding_Possible + (Iface_Op : Entity_Id; + Wrapper : Entity_Id) return Boolean + is + Iface_Op_Spec : constant Node_Id := Parent (Iface_Op); + Wrapper_Spec : constant Node_Id := Parent (Wrapper); + + function Type_Conformant_Parameters + (Iface_Op_Params : List_Id; + Wrapper_Params : List_Id) return Boolean; + -- Determine whether the parameters of the generated entry wrapper + -- and those of a primitive operation are type conformant. During + -- this check, the first parameter of the primitive operation is + -- skipped if it is a controlling argument: protected functions + -- may have a controlling result. + + -------------------------------- + -- Type_Conformant_Parameters -- + -------------------------------- + + function Type_Conformant_Parameters + (Iface_Op_Params : List_Id; + Wrapper_Params : List_Id) return Boolean + is + Iface_Op_Param : Node_Id; + Iface_Op_Typ : Entity_Id; + Wrapper_Param : Node_Id; + Wrapper_Typ : Entity_Id; + + begin + -- Skip the first (controlling) parameter of primitive operation + + Iface_Op_Param := First (Iface_Op_Params); + + if Present (First_Formal (Iface_Op)) + and then Is_Controlling_Formal (First_Formal (Iface_Op)) + then + Iface_Op_Param := Next (Iface_Op_Param); + end if; + + Wrapper_Param := First (Wrapper_Params); + while Present (Iface_Op_Param) + and then Present (Wrapper_Param) + loop + Iface_Op_Typ := Find_Parameter_Type (Iface_Op_Param); + Wrapper_Typ := Find_Parameter_Type (Wrapper_Param); + + -- The two parameters must be mode conformant + + if not Conforming_Types + (Iface_Op_Typ, Wrapper_Typ, Mode_Conformant) + then + return False; + end if; + + Next (Iface_Op_Param); + Next (Wrapper_Param); + end loop; + + -- One of the lists is longer than the other + + if Present (Iface_Op_Param) or else Present (Wrapper_Param) then + return False; + end if; + + return True; + end Type_Conformant_Parameters; + + -- Start of processing for Overriding_Possible + + begin + if Chars (Iface_Op) /= Chars (Wrapper) then + return False; + end if; + + -- If an inherited subprogram is implemented by a protected procedure + -- or an entry, then the first parameter of the inherited subprogram + -- shall be of mode OUT or IN OUT, or access-to-variable parameter. + + if Ekind (Iface_Op) = E_Procedure + and then Present (Parameter_Specifications (Iface_Op_Spec)) + then + declare + Obj_Param : constant Node_Id := + First (Parameter_Specifications (Iface_Op_Spec)); + begin + if not Out_Present (Obj_Param) + and then Nkind (Parameter_Type (Obj_Param)) /= + N_Access_Definition + then + return False; + end if; + end; + end if; + + return + Type_Conformant_Parameters ( + Parameter_Specifications (Iface_Op_Spec), + Parameter_Specifications (Wrapper_Spec)); + end Overriding_Possible; + + ----------------------- + -- Replicate_Formals -- + ----------------------- + + function Replicate_Formals + (Loc : Source_Ptr; + Formals : List_Id) return List_Id + is + New_Formals : constant List_Id := New_List; + Formal : Node_Id; + Param_Type : Node_Id; + + begin + Formal := First (Formals); + + -- Skip the object parameter when dealing with primitives declared + -- between two views. + + if Is_Private_Primitive_Subprogram (Subp_Id) + and then not Has_Controlling_Result (Subp_Id) + then + Formal := Next (Formal); + end if; + + while Present (Formal) loop + + -- Create an explicit copy of the entry parameter + + -- When creating the wrapper subprogram for a primitive operation + -- of a protected interface we must construct an equivalent + -- signature to that of the overriding operation. For regular + -- parameters we can just use the type of the formal, but for + -- access to subprogram parameters we need to reanalyze the + -- parameter type to create local entities for the signature of + -- the subprogram type. Using the entities of the overriding + -- subprogram will result in out-of-scope errors in the back-end. + + if Nkind (Parameter_Type (Formal)) = N_Access_Definition then + Param_Type := Copy_Separate_Tree (Parameter_Type (Formal)); + else + Param_Type := + New_Reference_To (Etype (Parameter_Type (Formal)), Loc); + end if; + + Append_To (New_Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Chars (Defining_Identifier (Formal))), + In_Present => In_Present (Formal), + Out_Present => Out_Present (Formal), + Parameter_Type => Param_Type)); + + Next (Formal); + end loop; + + return New_Formals; + end Replicate_Formals; + + -- Start of processing for Build_Wrapper_Spec + + begin + -- There is no point in building wrappers for non-tagged concurrent + -- types. + + pragma Assert (Is_Tagged_Type (Obj_Typ)); + + -- An entry or a protected procedure can override a routine where the + -- controlling formal is either IN OUT, OUT or is of access-to-variable + -- type. Since the wrapper must have the exact same signature as that of + -- the overridden subprogram, we try to find the overriding candidate + -- and use its controlling formal. + + First_Param := Empty; + + -- Check every implemented interface + + if Present (Interfaces (Obj_Typ)) then + Iface_Elmt := First_Elmt (Interfaces (Obj_Typ)); + Search : while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); + + -- Check every interface primitive + + if Present (Primitive_Operations (Iface)) then + Iface_Op_Elmt := First_Elmt (Primitive_Operations (Iface)); + while Present (Iface_Op_Elmt) loop + Iface_Op := Node (Iface_Op_Elmt); + + -- Ignore predefined primitives + + if not Is_Predefined_Dispatching_Operation (Iface_Op) then + Iface_Op := Ultimate_Alias (Iface_Op); + + -- The current primitive operation can be overridden by + -- the generated entry wrapper. + + if Overriding_Possible (Iface_Op, Subp_Id) then + First_Param := + First (Parameter_Specifications (Parent (Iface_Op))); + + exit Search; + end if; + end if; + + Next_Elmt (Iface_Op_Elmt); + end loop; + end if; + + Next_Elmt (Iface_Elmt); + end loop Search; + end if; + + -- If the subprogram to be wrapped is not overriding anything or is not + -- a primitive declared between two views, do not produce anything. This + -- avoids spurious errors involving overriding. + + if No (First_Param) + and then not Is_Private_Primitive_Subprogram (Subp_Id) + then + return Empty; + end if; + + declare + Wrapper_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars (Subp_Id)); + New_Formals : List_Id; + Obj_Param : Node_Id; + Obj_Param_Typ : Entity_Id; + + begin + -- Minimum decoration is needed to catch the entity in + -- Sem_Ch6.Override_Dispatching_Operation. + + if Ekind (Subp_Id) = E_Function then + Set_Ekind (Wrapper_Id, E_Function); + else + Set_Ekind (Wrapper_Id, E_Procedure); + end if; + + Set_Is_Primitive_Wrapper (Wrapper_Id); + Set_Wrapped_Entity (Wrapper_Id, Subp_Id); + Set_Is_Private_Primitive (Wrapper_Id, + Is_Private_Primitive_Subprogram (Subp_Id)); + + -- Process the formals + + New_Formals := Replicate_Formals (Loc, Formals); + + -- A function with a controlling result and no first controlling + -- formal needs no additional parameter. + + if Has_Controlling_Result (Subp_Id) + and then + (No (First_Formal (Subp_Id)) + or else not Is_Controlling_Formal (First_Formal (Subp_Id))) + then + null; + + -- Routine Subp_Id has been found to override an interface primitive. + -- If the interface operation has an access parameter, create a copy + -- of it, with the same null exclusion indicator if present. + + elsif Present (First_Param) then + if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then + Obj_Param_Typ := + Make_Access_Definition (Loc, + Subtype_Mark => + New_Reference_To (Obj_Typ, Loc)); + Set_Null_Exclusion_Present (Obj_Param_Typ, + Null_Exclusion_Present (Parameter_Type (First_Param))); + + else + Obj_Param_Typ := New_Reference_To (Obj_Typ, Loc); + end if; + + Obj_Param := + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Name_uO), + In_Present => In_Present (First_Param), + Out_Present => Out_Present (First_Param), + Parameter_Type => Obj_Param_Typ); + + Prepend_To (New_Formals, Obj_Param); + + -- If we are dealing with a primitive declared between two views, + -- implemented by a synchronized operation, we need to create + -- a default parameter. The mode of the parameter must match that + -- of the primitive operation. + + else + pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id)); + Obj_Param := + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uO), + In_Present => In_Present (Parent (First_Entity (Subp_Id))), + Out_Present => Ekind (Subp_Id) /= E_Function, + Parameter_Type => New_Reference_To (Obj_Typ, Loc)); + Prepend_To (New_Formals, Obj_Param); + end if; + + -- Build the final spec. If it is a function with a controlling + -- result, it is a primitive operation of the corresponding + -- record type, so mark the spec accordingly. + + if Ekind (Subp_Id) = E_Function then + declare + Res_Def : Node_Id; + + begin + if Has_Controlling_Result (Subp_Id) then + Res_Def := + New_Occurrence_Of + (Corresponding_Record_Type (Etype (Subp_Id)), Loc); + else + Res_Def := New_Copy (Result_Definition (Parent (Subp_Id))); + end if; + + return + Make_Function_Specification (Loc, + Defining_Unit_Name => Wrapper_Id, + Parameter_Specifications => New_Formals, + Result_Definition => Res_Def); + end; + else + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Wrapper_Id, + Parameter_Specifications => New_Formals); + end if; + end; + end Build_Wrapper_Spec; + + ------------------------- + -- Build_Wrapper_Specs -- + ------------------------- + + procedure Build_Wrapper_Specs + (Loc : Source_Ptr; + Typ : Entity_Id; + N : in out Node_Id) + is + Def : Node_Id; + Rec_Typ : Entity_Id; + procedure Scan_Declarations (L : List_Id); + -- Common processing for visible and private declarations + -- of a protected type. + + procedure Scan_Declarations (L : List_Id) is + Decl : Node_Id; + Wrap_Decl : Node_Id; + Wrap_Spec : Node_Id; + + begin + if No (L) then + return; + end if; + + Decl := First (L); + while Present (Decl) loop + Wrap_Spec := Empty; + + if Nkind (Decl) = N_Entry_Declaration + and then Ekind (Defining_Identifier (Decl)) = E_Entry + then + Wrap_Spec := + Build_Wrapper_Spec + (Subp_Id => Defining_Identifier (Decl), + Obj_Typ => Rec_Typ, + Formals => Parameter_Specifications (Decl)); + + elsif Nkind (Decl) = N_Subprogram_Declaration then + Wrap_Spec := + Build_Wrapper_Spec + (Subp_Id => Defining_Unit_Name (Specification (Decl)), + Obj_Typ => Rec_Typ, + Formals => + Parameter_Specifications (Specification (Decl))); + end if; + + if Present (Wrap_Spec) then + Wrap_Decl := + Make_Subprogram_Declaration (Loc, + Specification => Wrap_Spec); + + Insert_After (N, Wrap_Decl); + N := Wrap_Decl; + + Analyze (Wrap_Decl); + end if; + + Next (Decl); + end loop; + end Scan_Declarations; + + -- start of processing for Build_Wrapper_Specs + + begin + if Is_Protected_Type (Typ) then + Def := Protected_Definition (Parent (Typ)); + else pragma Assert (Is_Task_Type (Typ)); + Def := Task_Definition (Parent (Typ)); + end if; + + Rec_Typ := Corresponding_Record_Type (Typ); + + -- Generate wrapper specs for a concurrent type which implements an + -- interface. Operations in both the visible and private parts may + -- implement progenitor operations. + + if Present (Interfaces (Rec_Typ)) + and then Present (Def) + then + Scan_Declarations (Visible_Declarations (Def)); + Scan_Declarations (Private_Declarations (Def)); + end if; + end Build_Wrapper_Specs; + + --------------------------- + -- Build_Find_Body_Index -- + --------------------------- + + function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (Typ); + Ent : Entity_Id; + E_Typ : Entity_Id; + Has_F : Boolean := False; + Index : Nat; + If_St : Node_Id := Empty; + Lo : Node_Id; + Hi : Node_Id; + Decls : List_Id := New_List; + Ret : Node_Id; + Spec : Node_Id; + Siz : Node_Id := Empty; + + procedure Add_If_Clause (Expr : Node_Id); + -- Add test for range of current entry + + function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; + -- If a bound of an entry is given by a discriminant, retrieve the + -- actual value of the discriminant from the enclosing object. + + ------------------- + -- Add_If_Clause -- + ------------------- + + procedure Add_If_Clause (Expr : Node_Id) is + Cond : Node_Id; + Stats : constant List_Id := + New_List ( + Make_Simple_Return_Statement (Loc, + Expression => Make_Integer_Literal (Loc, Index + 1))); + + begin + -- Index for current entry body + + Index := Index + 1; + + -- Compute total length of entry queues so far + + if No (Siz) then + Siz := Expr; + else + Siz := + Make_Op_Add (Loc, + Left_Opnd => Siz, + Right_Opnd => Expr); + end if; + + Cond := + Make_Op_Le (Loc, + Left_Opnd => Make_Identifier (Loc, Name_uE), + Right_Opnd => Siz); + + -- Map entry queue indexes in the range of the current family + -- into the current index, that designates the entry body. + + if No (If_St) then + If_St := + Make_Implicit_If_Statement (Typ, + Condition => Cond, + Then_Statements => Stats, + Elsif_Parts => New_List); + + Ret := If_St; + + else + Append ( + Make_Elsif_Part (Loc, + Condition => Cond, + Then_Statements => Stats), + Elsif_Parts (If_St)); + end if; + end Add_If_Clause; + + ------------------------------ + -- Convert_Discriminant_Ref -- + ------------------------------ + + function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is + B : Node_Id; + + begin + if Is_Entity_Name (Bound) + and then Ekind (Entity (Bound)) = E_Discriminant + then + B := + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Corresponding_Record_Type (Typ), + Make_Explicit_Dereference (Loc, + Make_Identifier (Loc, Name_uObject))), + Selector_Name => Make_Identifier (Loc, Chars (Bound))); + Set_Etype (B, Etype (Entity (Bound))); + else + B := New_Copy_Tree (Bound); + end if; + + return B; + end Convert_Discriminant_Ref; + + -- Start of processing for Build_Find_Body_Index + + begin + Spec := Build_Find_Body_Index_Spec (Typ); + + Ent := First_Entity (Typ); + while Present (Ent) loop + if Ekind (Ent) = E_Entry_Family then + Has_F := True; + exit; + end if; + + Next_Entity (Ent); + end loop; + + if not Has_F then + + -- If the protected type has no entry families, there is a one-one + -- correspondence between entry queue and entry body. + + Ret := + Make_Simple_Return_Statement (Loc, + Expression => Make_Identifier (Loc, Name_uE)); + + else + -- Suppose entries e1, e2, ... have size l1, l2, ... we generate + -- the following: + -- + -- if E <= l1 then return 1; + -- elsif E <= l1 + l2 then return 2; + -- ... + + Index := 0; + Siz := Empty; + Ent := First_Entity (Typ); + + Add_Object_Pointer (Loc, Typ, Decls); + + while Present (Ent) loop + if Ekind (Ent) = E_Entry then + Add_If_Clause (Make_Integer_Literal (Loc, 1)); + + elsif Ekind (Ent) = E_Entry_Family then + E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent))); + Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ)); + Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ)); + Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ, False)); + end if; + + Next_Entity (Ent); + end loop; + + if Index = 1 then + Decls := New_List; + Ret := + Make_Simple_Return_Statement (Loc, + Expression => Make_Integer_Literal (Loc, 1)); + + elsif Nkind (Ret) = N_If_Statement then + + -- Ranges are in increasing order, so last one doesn't need guard + + declare + Nod : constant Node_Id := Last (Elsif_Parts (Ret)); + begin + Remove (Nod); + Set_Else_Statements (Ret, Then_Statements (Nod)); + end; + end if; + end if; + + return + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Ret))); + end Build_Find_Body_Index; + + -------------------------------- + -- Build_Find_Body_Index_Spec -- + -------------------------------- + + function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (Typ); + Id : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), 'F')); + Parm1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uO); + Parm2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uE); + + begin + return + Make_Function_Specification (Loc, + Defining_Unit_Name => Id, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Parm1, + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Parm2, + Parameter_Type => + New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))), + Result_Definition => New_Occurrence_Of ( + RTE (RE_Protected_Entry_Index), Loc)); + end Build_Find_Body_Index_Spec; + + ------------------------- + -- Build_Master_Entity -- + ------------------------- + + procedure Build_Master_Entity (E : Entity_Id) is + Loc : constant Source_Ptr := Sloc (E); + P : Node_Id; + Decl : Node_Id; + S : Entity_Id; + + begin + S := Find_Master_Scope (E); + + -- Nothing to do if we already built a master entity for this scope + -- or if there is no task hierarchy. + + if Has_Master_Entity (S) + or else Restriction_Active (No_Task_Hierarchy) + then + return; + end if; + + -- Otherwise first build the master entity + -- _Master : constant Master_Id := Current_Master.all; + -- and insert it just before the current declaration + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uMaster), + Constant_Present => True, + Object_Definition => New_Reference_To (RTE (RE_Master_Id), Loc), + Expression => + Make_Explicit_Dereference (Loc, + New_Reference_To (RTE (RE_Current_Master), Loc))); + + P := Parent (E); + Insert_Before (P, Decl); + Analyze (Decl); + + Set_Has_Master_Entity (S); + + -- Now mark the containing scope as a task master + + while Nkind (P) /= N_Compilation_Unit loop + P := Parent (P); + + -- If we fall off the top, we are at the outer level, and the + -- environment task is our effective master, so nothing to mark. + + if Nkind_In + (P, N_Task_Body, N_Block_Statement, N_Subprogram_Body) + then + Set_Is_Task_Master (P, True); + return; + + elsif Nkind (Parent (P)) = N_Subunit then + P := Corresponding_Stub (Parent (P)); + end if; + end loop; + end Build_Master_Entity; + + ----------------------------------------- + -- Build_Private_Protected_Declaration -- + ----------------------------------------- + + function Build_Private_Protected_Declaration + (N : Node_Id) return Entity_Id + is + Loc : constant Source_Ptr := Sloc (N); + Body_Id : constant Entity_Id := Defining_Entity (N); + Decl : Node_Id; + Plist : List_Id; + Formal : Entity_Id; + New_Spec : Node_Id; + Spec_Id : Entity_Id; + + begin + Formal := First_Formal (Body_Id); + + -- The protected operation always has at least one formal, namely the + -- object itself, but it is only placed in the parameter list if + -- expansion is enabled. + + if Present (Formal) or else Expander_Active then + Plist := Copy_Parameter_List (Body_Id); + else + Plist := No_List; + end if; + + if Nkind (Specification (N)) = N_Procedure_Specification then + New_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Sloc (Body_Id), + Chars => Chars (Body_Id)), + Parameter_Specifications => + Plist); + else + New_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Sloc (Body_Id), + Chars => Chars (Body_Id)), + Parameter_Specifications => Plist, + Result_Definition => + New_Occurrence_Of (Etype (Body_Id), Loc)); + end if; + + Decl := Make_Subprogram_Declaration (Loc, Specification => New_Spec); + Insert_Before (N, Decl); + Spec_Id := Defining_Unit_Name (New_Spec); + + -- Indicate that the entity comes from source, to ensure that cross- + -- reference information is properly generated. The body itself is + -- rewritten during expansion, and the body entity will not appear in + -- calls to the operation. + + Set_Comes_From_Source (Spec_Id, True); + Analyze (Decl); + Set_Has_Completion (Spec_Id); + Set_Convention (Spec_Id, Convention_Protected); + return Spec_Id; + end Build_Private_Protected_Declaration; + + --------------------------- + -- Build_Protected_Entry -- + --------------------------- + + function Build_Protected_Entry + (N : Node_Id; + Ent : Entity_Id; + Pid : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + + Decls : constant List_Id := Declarations (N); + End_Lab : constant Node_Id := + End_Label (Handled_Statement_Sequence (N)); + End_Loc : constant Source_Ptr := + Sloc (Last (Statements (Handled_Statement_Sequence (N)))); + -- Used for the generated call to Complete_Entry_Body + + Han_Loc : Source_Ptr; + -- Used for the exception handler, inserted at end of the body + + Op_Decls : constant List_Id := New_List; + Complete : Node_Id; + Edef : Entity_Id; + Espec : Node_Id; + Ohandle : Node_Id; + Op_Stats : List_Id; + + begin + -- Set the source location on the exception handler only when debugging + -- the expanded code (see Make_Implicit_Exception_Handler). + + if Debug_Generated_Code then + Han_Loc := End_Loc; + + -- Otherwise the inserted code should not be visible to the debugger + + else + Han_Loc := No_Location; + end if; + + Edef := + Make_Defining_Identifier (Loc, + Chars => Chars (Protected_Body_Subprogram (Ent))); + Espec := + Build_Protected_Entry_Specification (Loc, Edef, Empty); + + -- Add the following declarations: + -- type poVP is access poV; + -- _object : poVP := poVP (_O); + -- + -- where _O is the formal parameter associated with the concurrent + -- object. These declarations are needed for Complete_Entry_Body. + + Add_Object_Pointer (Loc, Pid, Op_Decls); + + -- Add renamings for all formals, the Protection object, discriminals, + -- privals and the entry index constant for use by debugger. + + Add_Formal_Renamings (Espec, Op_Decls, Ent, Loc); + Debug_Private_Data_Declarations (Decls); + + case Corresponding_Runtime_Package (Pid) is + when System_Tasking_Protected_Objects_Entries => + Complete := + New_Reference_To (RTE (RE_Complete_Entry_Body), Loc); + + when System_Tasking_Protected_Objects_Single_Entry => + Complete := + New_Reference_To (RTE (RE_Complete_Single_Entry_Body), Loc); + + when others => + raise Program_Error; + end case; + + Op_Stats := New_List ( + Make_Block_Statement (Loc, + Declarations => Decls, + Handled_Statement_Sequence => + Handled_Statement_Sequence (N)), + + Make_Procedure_Call_Statement (End_Loc, + Name => Complete, + Parameter_Associations => New_List ( + Make_Attribute_Reference (End_Loc, + Prefix => + Make_Selected_Component (End_Loc, + Prefix => Make_Identifier (End_Loc, Name_uObject), + Selector_Name => Make_Identifier (End_Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access)))); + + -- When exceptions can not be propagated, we never need to call + -- Exception_Complete_Entry_Body + + if No_Exception_Handlers_Set then + return + Make_Subprogram_Body (Loc, + Specification => Espec, + Declarations => Op_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Op_Stats, + End_Label => End_Lab)); + + else + Ohandle := Make_Others_Choice (Loc); + Set_All_Others (Ohandle); + + case Corresponding_Runtime_Package (Pid) is + when System_Tasking_Protected_Objects_Entries => + Complete := + New_Reference_To + (RTE (RE_Exceptional_Complete_Entry_Body), Loc); + + when System_Tasking_Protected_Objects_Single_Entry => + Complete := + New_Reference_To + (RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc); + + when others => + raise Program_Error; + end case; + + -- Establish link between subprogram body entity and source entry. + + Set_Corresponding_Protected_Entry (Edef, Ent); + + -- Create body of entry procedure. The renaming declarations are + -- placed ahead of the block that contains the actual entry body. + + return + Make_Subprogram_Body (Loc, + Specification => Espec, + Declarations => Op_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Op_Stats, + End_Label => End_Lab, + Exception_Handlers => New_List ( + Make_Implicit_Exception_Handler (Han_Loc, + Exception_Choices => New_List (Ohandle), + + Statements => New_List ( + Make_Procedure_Call_Statement (Han_Loc, + Name => Complete, + Parameter_Associations => New_List ( + Make_Attribute_Reference (Han_Loc, + Prefix => + Make_Selected_Component (Han_Loc, + Prefix => + Make_Identifier (Han_Loc, Name_uObject), + Selector_Name => + Make_Identifier (Han_Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access), + + Make_Function_Call (Han_Loc, + Name => New_Reference_To ( + RTE (RE_Get_GNAT_Exception), Loc))))))))); + end if; + end Build_Protected_Entry; + + ----------------------------------------- + -- Build_Protected_Entry_Specification -- + ----------------------------------------- + + function Build_Protected_Entry_Specification + (Loc : Source_Ptr; + Def_Id : Entity_Id; + Ent_Id : Entity_Id) return Node_Id + is + P : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uP); + + begin + Set_Debug_Info_Needed (Def_Id); + + if Present (Ent_Id) then + Append_Elmt (P, Accept_Address (Ent_Id)); + end if; + + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Def_Id, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uO), + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => P, + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uE), + Parameter_Type => + New_Reference_To (RTE (RE_Protected_Entry_Index), Loc)))); + end Build_Protected_Entry_Specification; + + -------------------------- + -- Build_Protected_Spec -- + -------------------------- + + function Build_Protected_Spec + (N : Node_Id; + Obj_Type : Entity_Id; + Ident : Entity_Id; + Unprotected : Boolean := False) return List_Id + is + Loc : constant Source_Ptr := Sloc (N); + Decl : Node_Id; + Formal : Entity_Id; + New_Plist : List_Id; + New_Param : Node_Id; + + begin + New_Plist := New_List; + + Formal := First_Formal (Ident); + while Present (Formal) loop + New_Param := + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Sloc (Formal), Chars (Formal)), + In_Present => In_Present (Parent (Formal)), + Out_Present => Out_Present (Parent (Formal)), + Parameter_Type => New_Reference_To (Etype (Formal), Loc)); + + if Unprotected then + Set_Protected_Formal (Formal, Defining_Identifier (New_Param)); + end if; + + Append (New_Param, New_Plist); + Next_Formal (Formal); + end loop; + + -- If the subprogram is a procedure and the context is not an access + -- to protected subprogram, the parameter is in-out. Otherwise it is + -- an in parameter. + + Decl := + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uObject), + In_Present => True, + Out_Present => + (Etype (Ident) = Standard_Void_Type + and then not Is_RTE (Obj_Type, RE_Address)), + Parameter_Type => + New_Reference_To (Obj_Type, Loc)); + Set_Debug_Info_Needed (Defining_Identifier (Decl)); + Prepend_To (New_Plist, Decl); + + return New_Plist; + end Build_Protected_Spec; + + --------------------------------------- + -- Build_Protected_Sub_Specification -- + --------------------------------------- + + function Build_Protected_Sub_Specification + (N : Node_Id; + Prot_Typ : Entity_Id; + Mode : Subprogram_Protection_Mode) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Decl : Node_Id; + Def_Id : Entity_Id; + New_Id : Entity_Id; + New_Plist : List_Id; + New_Spec : Node_Id; + + Append_Chr : constant array (Subprogram_Protection_Mode) of Character := + (Dispatching_Mode => ' ', + Protected_Mode => 'P', + Unprotected_Mode => 'N'); + + begin + if Ekind (Defining_Unit_Name (Specification (N))) = + E_Subprogram_Body + then + Decl := Unit_Declaration_Node (Corresponding_Spec (N)); + else + Decl := N; + end if; + + Def_Id := Defining_Unit_Name (Specification (Decl)); + + New_Plist := + Build_Protected_Spec + (Decl, Corresponding_Record_Type (Prot_Typ), Def_Id, + Mode = Unprotected_Mode); + New_Id := + Make_Defining_Identifier (Loc, + Chars => Build_Selected_Name (Prot_Typ, Def_Id, Append_Chr (Mode))); + + -- The unprotected operation carries the user code, and debugging + -- information must be generated for it, even though this spec does + -- not come from source. It is also convenient to allow gdb to step + -- into the protected operation, even though it only contains lock/ + -- unlock calls. + + Set_Debug_Info_Needed (New_Id); + + -- If a pragma Eliminate applies to the source entity, the internal + -- subprograms will be eliminated as well. + + Set_Is_Eliminated (New_Id, Is_Eliminated (Def_Id)); + + if Nkind (Specification (Decl)) = N_Procedure_Specification then + New_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => New_Id, + Parameter_Specifications => New_Plist); + + -- Create a new specification for the anonymous subprogram type + + else + New_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => New_Id, + Parameter_Specifications => New_Plist, + Result_Definition => + Copy_Result_Type (Result_Definition (Specification (Decl)))); + + Set_Return_Present (Defining_Unit_Name (New_Spec)); + end if; + + return New_Spec; + end Build_Protected_Sub_Specification; + + ------------------------------------- + -- Build_Protected_Subprogram_Body -- + ------------------------------------- + + function Build_Protected_Subprogram_Body + (N : Node_Id; + Pid : Node_Id; + N_Op_Spec : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Op_Spec : Node_Id; + P_Op_Spec : Node_Id; + Uactuals : List_Id; + Pformal : Node_Id; + Unprot_Call : Node_Id; + Sub_Body : Node_Id; + Lock_Name : Node_Id; + Lock_Stmt : Node_Id; + Service_Name : Node_Id; + R : Node_Id; + Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning + Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning + Stmts : List_Id; + Object_Parm : Node_Id; + Exc_Safe : Boolean; + + function Is_Exception_Safe (Subprogram : Node_Id) return Boolean; + -- Tell whether a given subprogram cannot raise an exception + + ----------------------- + -- Is_Exception_Safe -- + ----------------------- + + function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is + + function Has_Side_Effect (N : Node_Id) return Boolean; + -- Return True whenever encountering a subprogram call or raise + -- statement of any kind in the sequence of statements + + --------------------- + -- Has_Side_Effect -- + --------------------- + + -- What is this doing buried two levels down in exp_ch9. It seems + -- like a generally useful function, and indeed there may be code + -- duplication going on here ??? + + function Has_Side_Effect (N : Node_Id) return Boolean is + Stmt : Node_Id; + Expr : Node_Id; + + function Is_Call_Or_Raise (N : Node_Id) return Boolean; + -- Indicate whether N is a subprogram call or a raise statement + + ---------------------- + -- Is_Call_Or_Raise -- + ---------------------- + + function Is_Call_Or_Raise (N : Node_Id) return Boolean is + begin + return Nkind_In (N, N_Procedure_Call_Statement, + N_Function_Call, + N_Raise_Statement, + N_Raise_Constraint_Error, + N_Raise_Program_Error, + N_Raise_Storage_Error); + end Is_Call_Or_Raise; + + -- Start of processing for Has_Side_Effect + + begin + Stmt := N; + while Present (Stmt) loop + if Is_Call_Or_Raise (Stmt) then + return True; + end if; + + -- An object declaration can also contain a function call + -- or a raise statement + + if Nkind (Stmt) = N_Object_Declaration then + Expr := Expression (Stmt); + + if Present (Expr) and then Is_Call_Or_Raise (Expr) then + return True; + end if; + end if; + + Next (Stmt); + end loop; + + return False; + end Has_Side_Effect; + + -- Start of processing for Is_Exception_Safe + + begin + -- If the checks handled by the back end are not disabled, we cannot + -- ensure that no exception will be raised. + + if not Access_Checks_Suppressed (Empty) + or else not Discriminant_Checks_Suppressed (Empty) + or else not Range_Checks_Suppressed (Empty) + or else not Index_Checks_Suppressed (Empty) + or else Opt.Stack_Checking_Enabled + then + return False; + end if; + + if Has_Side_Effect (First (Declarations (Subprogram))) + or else + Has_Side_Effect ( + First (Statements (Handled_Statement_Sequence (Subprogram)))) + then + return False; + else + return True; + end if; + end Is_Exception_Safe; + + -- Start of processing for Build_Protected_Subprogram_Body + + begin + Op_Spec := Specification (N); + Exc_Safe := Is_Exception_Safe (N); + + P_Op_Spec := + Build_Protected_Sub_Specification (N, Pid, Protected_Mode); + + -- Build a list of the formal parameters of the protected version of + -- the subprogram to use as the actual parameters of the unprotected + -- version. + + Uactuals := New_List; + Pformal := First (Parameter_Specifications (P_Op_Spec)); + while Present (Pformal) loop + Append_To (Uactuals, + Make_Identifier (Loc, Chars (Defining_Identifier (Pformal)))); + Next (Pformal); + end loop; + + -- Make a call to the unprotected version of the subprogram built above + -- for use by the protected version built below. + + if Nkind (Op_Spec) = N_Function_Specification then + if Exc_Safe then + R := Make_Temporary (Loc, 'R'); + Unprot_Call := + Make_Object_Declaration (Loc, + Defining_Identifier => R, + Constant_Present => True, + Object_Definition => New_Copy (Result_Definition (N_Op_Spec)), + Expression => + Make_Function_Call (Loc, + Name => Make_Identifier (Loc, + Chars => Chars (Defining_Unit_Name (N_Op_Spec))), + Parameter_Associations => Uactuals)); + + Return_Stmt := + Make_Simple_Return_Statement (Loc, + Expression => New_Reference_To (R, Loc)); + + else + Unprot_Call := Make_Simple_Return_Statement (Loc, + Expression => Make_Function_Call (Loc, + Name => + Make_Identifier (Loc, + Chars => Chars (Defining_Unit_Name (N_Op_Spec))), + Parameter_Associations => Uactuals)); + end if; + + else + Unprot_Call := + Make_Procedure_Call_Statement (Loc, + Name => + Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))), + Parameter_Associations => Uactuals); + end if; + + -- Wrap call in block that will be covered by an at_end handler + + if not Exc_Safe then + Unprot_Call := Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Unprot_Call))); + end if; + + -- Make the protected subprogram body. This locks the protected + -- object and calls the unprotected version of the subprogram. + + case Corresponding_Runtime_Package (Pid) is + when System_Tasking_Protected_Objects_Entries => + Lock_Name := New_Reference_To (RTE (RE_Lock_Entries), Loc); + Service_Name := New_Reference_To (RTE (RE_Service_Entries), Loc); + + when System_Tasking_Protected_Objects_Single_Entry => + Lock_Name := New_Reference_To (RTE (RE_Lock_Entry), Loc); + Service_Name := New_Reference_To (RTE (RE_Service_Entry), Loc); + + when System_Tasking_Protected_Objects => + Lock_Name := New_Reference_To (RTE (RE_Lock), Loc); + Service_Name := New_Reference_To (RTE (RE_Unlock), Loc); + + when others => + raise Program_Error; + end case; + + Object_Parm := + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uObject), + Selector_Name => Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access); + + Lock_Stmt := Make_Procedure_Call_Statement (Loc, + Name => Lock_Name, + Parameter_Associations => New_List (Object_Parm)); + + if Abort_Allowed then + Stmts := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Abort_Defer), Loc), + Parameter_Associations => Empty_List), + Lock_Stmt); + + else + Stmts := New_List (Lock_Stmt); + end if; + + if not Exc_Safe then + Append (Unprot_Call, Stmts); + else + if Nkind (Op_Spec) = N_Function_Specification then + Pre_Stmts := Stmts; + Stmts := Empty_List; + else + Append (Unprot_Call, Stmts); + end if; + + Append ( + Make_Procedure_Call_Statement (Loc, + Name => Service_Name, + Parameter_Associations => + New_List (New_Copy_Tree (Object_Parm))), + Stmts); + + if Abort_Allowed then + Append ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc), + Parameter_Associations => Empty_List), + Stmts); + end if; + + if Nkind (Op_Spec) = N_Function_Specification then + Append (Return_Stmt, Stmts); + Append (Make_Block_Statement (Loc, + Declarations => New_List (Unprot_Call), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)), Pre_Stmts); + Stmts := Pre_Stmts; + end if; + end if; + + Sub_Body := + Make_Subprogram_Body (Loc, + Declarations => Empty_List, + Specification => P_Op_Spec, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)); + + if not Exc_Safe then + Set_Is_Protected_Subprogram_Body (Sub_Body); + end if; + + return Sub_Body; + end Build_Protected_Subprogram_Body; + + ------------------------------------- + -- Build_Protected_Subprogram_Call -- + ------------------------------------- + + procedure Build_Protected_Subprogram_Call + (N : Node_Id; + Name : Node_Id; + Rec : Node_Id; + External : Boolean := True) + is + Loc : constant Source_Ptr := Sloc (N); + Sub : constant Entity_Id := Entity (Name); + New_Sub : Node_Id; + Params : List_Id; + + begin + if External then + New_Sub := New_Occurrence_Of (External_Subprogram (Sub), Loc); + else + New_Sub := + New_Occurrence_Of (Protected_Body_Subprogram (Sub), Loc); + end if; + + if Present (Parameter_Associations (N)) then + Params := New_Copy_List_Tree (Parameter_Associations (N)); + else + Params := New_List; + end if; + + -- If the type is an untagged derived type, convert to the root type, + -- which is the one on which the operations are defined. + + if Nkind (Rec) = N_Unchecked_Type_Conversion + and then not Is_Tagged_Type (Etype (Rec)) + and then Is_Derived_Type (Etype (Rec)) + then + Set_Etype (Rec, Root_Type (Etype (Rec))); + Set_Subtype_Mark (Rec, + New_Occurrence_Of (Root_Type (Etype (Rec)), Sloc (N))); + end if; + + Prepend (Rec, Params); + + if Ekind (Sub) = E_Procedure then + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Sub, + Parameter_Associations => Params)); + + else + pragma Assert (Ekind (Sub) = E_Function); + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Sub, + Parameter_Associations => Params)); + end if; + + if External + and then Nkind (Rec) = N_Unchecked_Type_Conversion + and then Is_Entity_Name (Expression (Rec)) + and then Is_Shared_Passive (Entity (Expression (Rec))) + then + Add_Shared_Var_Lock_Procs (N); + end if; + end Build_Protected_Subprogram_Call; + + ------------------------- + -- Build_Selected_Name -- + ------------------------- + + function Build_Selected_Name + (Prefix : Entity_Id; + Selector : Entity_Id; + Append_Char : Character := ' ') return Name_Id + is + Select_Buffer : String (1 .. Hostparm.Max_Name_Length); + Select_Len : Natural; + + begin + Get_Name_String (Chars (Selector)); + Select_Len := Name_Len; + Select_Buffer (1 .. Select_Len) := Name_Buffer (1 .. Name_Len); + Get_Name_String (Chars (Prefix)); + + -- If scope is anonymous type, discard suffix to recover name of + -- single protected object. Otherwise use protected type name. + + if Name_Buffer (Name_Len) = 'T' then + Name_Len := Name_Len - 1; + end if; + + Add_Str_To_Name_Buffer ("__"); + for J in 1 .. Select_Len loop + Add_Char_To_Name_Buffer (Select_Buffer (J)); + end loop; + + -- Now add the Append_Char if specified. The encoding to follow + -- depends on the type of entity. If Append_Char is either 'N' or 'P', + -- then the entity is associated to a protected type subprogram. + -- Otherwise, it is a protected type entry. For each case, the + -- encoding to follow for the suffix is documented in exp_dbug.ads. + + -- It would be better to encapsulate this as a routine in Exp_Dbug ??? + + if Append_Char /= ' ' then + if Append_Char = 'P' or Append_Char = 'N' then + Add_Char_To_Name_Buffer (Append_Char); + return Name_Find; + else + Add_Str_To_Name_Buffer ((1 => '_', 2 => Append_Char)); + return New_External_Name (Name_Find, ' ', -1); + end if; + else + return Name_Find; + end if; + end Build_Selected_Name; + + ----------------------------- + -- Build_Simple_Entry_Call -- + ----------------------------- + + -- A task entry call is converted to a call to Call_Simple + + -- declare + -- P : parms := (parm, parm, parm); + -- begin + -- Call_Simple (acceptor-task, entry-index, P'Address); + -- parm := P.param; + -- parm := P.param; + -- ... + -- end; + + -- Here Pnn is an aggregate of the type constructed for the entry to hold + -- the parameters, and the constructed aggregate value contains either the + -- parameters or, in the case of non-elementary types, references to these + -- parameters. Then the address of this aggregate is passed to the runtime + -- routine, along with the task id value and the task entry index value. + -- Pnn is only required if parameters are present. + + -- The assignments after the call are present only in the case of in-out + -- or out parameters for elementary types, and are used to assign back the + -- resulting values of such parameters. + + -- Note: the reason that we insert a block here is that in the context + -- of selects, conditional entry calls etc. the entry call statement + -- appears on its own, not as an element of a list. + + -- A protected entry call is converted to a Protected_Entry_Call: + + -- declare + -- P : E1_Params := (param, param, param); + -- Pnn : Boolean; + -- Bnn : Communications_Block; + + -- declare + -- P : E1_Params := (param, param, param); + -- Bnn : Communications_Block; + + -- begin + -- Protected_Entry_Call ( + -- Object => po._object'Access, + -- E => ; + -- Uninterpreted_Data => P'Address; + -- Mode => Simple_Call; + -- Block => Bnn); + -- parm := P.param; + -- parm := P.param; + -- ... + -- end; + + procedure Build_Simple_Entry_Call + (N : Node_Id; + Concval : Node_Id; + Ename : Node_Id; + Index : Node_Id) + is + begin + Expand_Call (N); + + -- If call has been inlined, nothing left to do + + if Nkind (N) = N_Block_Statement then + return; + end if; + + -- Convert entry call to Call_Simple call + + declare + Loc : constant Source_Ptr := Sloc (N); + Parms : constant List_Id := Parameter_Associations (N); + Stats : constant List_Id := New_List; + Actual : Node_Id; + Call : Node_Id; + Comm_Name : Entity_Id; + Conctyp : Node_Id; + Decls : List_Id; + Ent : Entity_Id; + Ent_Acc : Entity_Id; + Formal : Node_Id; + Iface_Tag : Entity_Id; + Iface_Typ : Entity_Id; + N_Node : Node_Id; + N_Var : Node_Id; + P : Entity_Id; + Parm1 : Node_Id; + Parm2 : Node_Id; + Parm3 : Node_Id; + Pdecl : Node_Id; + Plist : List_Id; + X : Entity_Id; + Xdecl : Node_Id; + + begin + -- Simple entry and entry family cases merge here + + Ent := Entity (Ename); + Ent_Acc := Entry_Parameters_Type (Ent); + Conctyp := Etype (Concval); + + -- If prefix is an access type, dereference to obtain the task type + + if Is_Access_Type (Conctyp) then + Conctyp := Designated_Type (Conctyp); + end if; + + -- Special case for protected subprogram calls + + if Is_Protected_Type (Conctyp) + and then Is_Subprogram (Entity (Ename)) + then + if not Is_Eliminated (Entity (Ename)) then + Build_Protected_Subprogram_Call + (N, Ename, Convert_Concurrent (Concval, Conctyp)); + Analyze (N); + end if; + + return; + end if; + + -- First parameter is the Task_Id value from the task value or the + -- Object from the protected object value, obtained by selecting + -- the _Task_Id or _Object from the result of doing an unchecked + -- conversion to convert the value to the corresponding record type. + + if Nkind (Concval) = N_Function_Call + and then Is_Task_Type (Conctyp) + and then Ada_Version >= Ada_2005 + then + declare + ExpR : constant Node_Id := Relocate_Node (Concval); + Obj : constant Entity_Id := Make_Temporary (Loc, 'F', ExpR); + Decl : Node_Id; + + begin + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Obj, + Object_Definition => New_Occurrence_Of (Conctyp, Loc), + Expression => ExpR); + Set_Etype (Obj, Conctyp); + Decls := New_List (Decl); + Rewrite (Concval, New_Occurrence_Of (Obj, Loc)); + end; + + else + Decls := New_List; + end if; + + Parm1 := Concurrent_Ref (Concval); + + -- Second parameter is the entry index, computed by the routine + -- provided for this purpose. The value of this expression is + -- assigned to an intermediate variable to assure that any entry + -- family index expressions are evaluated before the entry + -- parameters. + + if Abort_Allowed + or else Restriction_Active (No_Entry_Queue) = False + or else not Is_Protected_Type (Conctyp) + or else Number_Entries (Conctyp) > 1 + or else (Has_Attach_Handler (Conctyp) + and then not Restricted_Profile) + then + X := Make_Defining_Identifier (Loc, Name_uX); + + Xdecl := + Make_Object_Declaration (Loc, + Defining_Identifier => X, + Object_Definition => + New_Reference_To (RTE (RE_Task_Entry_Index), Loc), + Expression => Actual_Index_Expression ( + Loc, Entity (Ename), Index, Concval)); + + Append_To (Decls, Xdecl); + Parm2 := New_Reference_To (X, Loc); + + else + Xdecl := Empty; + Parm2 := Empty; + end if; + + -- The third parameter is the packaged parameters. If there are + -- none, then it is just the null address, since nothing is passed. + + if No (Parms) then + Parm3 := New_Reference_To (RTE (RE_Null_Address), Loc); + P := Empty; + + -- Case of parameters present, where third argument is the address + -- of a packaged record containing the required parameter values. + + else + -- First build a list of parameter values, which are references to + -- objects of the parameter types. + + Plist := New_List; + + Actual := First_Actual (N); + Formal := First_Formal (Ent); + + while Present (Actual) loop + + -- If it is a by_copy_type, copy it to a new variable. The + -- packaged record has a field that points to this variable. + + if Is_By_Copy_Type (Etype (Actual)) then + N_Node := + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'J'), + Aliased_Present => True, + Object_Definition => + New_Reference_To (Etype (Formal), Loc)); + + -- Mark the object as not needing initialization since the + -- initialization is performed separately, avoiding errors + -- on cases such as formals of null-excluding access types. + + Set_No_Initialization (N_Node); + + -- We must make an assignment statement separate for the + -- case of limited type. We cannot assign it unless the + -- Assignment_OK flag is set first. An out formal of an + -- access type must also be initialized from the actual, + -- as stated in RM 6.4.1 (13). + + if Ekind (Formal) /= E_Out_Parameter + or else Is_Access_Type (Etype (Formal)) + then + N_Var := + New_Reference_To (Defining_Identifier (N_Node), Loc); + Set_Assignment_OK (N_Var); + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => N_Var, + Expression => Relocate_Node (Actual))); + end if; + + Append (N_Node, Decls); + + Append_To (Plist, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Unchecked_Access, + Prefix => + New_Reference_To (Defining_Identifier (N_Node), Loc))); + else + -- Interface class-wide formal + + if Ada_Version >= Ada_2005 + and then Ekind (Etype (Formal)) = E_Class_Wide_Type + and then Is_Interface (Etype (Formal)) + then + Iface_Typ := Etype (Etype (Formal)); + + -- Generate: + -- formal_iface_type! (actual.iface_tag)'reference + + Iface_Tag := + Find_Interface_Tag (Etype (Actual), Iface_Typ); + pragma Assert (Present (Iface_Tag)); + + Append_To (Plist, + Make_Reference (Loc, + Unchecked_Convert_To (Iface_Typ, + Make_Selected_Component (Loc, + Prefix => + Relocate_Node (Actual), + Selector_Name => + New_Reference_To (Iface_Tag, Loc))))); + else + -- Generate: + -- actual'reference + + Append_To (Plist, + Make_Reference (Loc, Relocate_Node (Actual))); + end if; + end if; + + Next_Actual (Actual); + Next_Formal_With_Extras (Formal); + end loop; + + -- Now build the declaration of parameters initialized with the + -- aggregate containing this constructed parameter list. + + P := Make_Defining_Identifier (Loc, Name_uP); + + Pdecl := + Make_Object_Declaration (Loc, + Defining_Identifier => P, + Object_Definition => + New_Reference_To (Designated_Type (Ent_Acc), Loc), + Expression => + Make_Aggregate (Loc, Expressions => Plist)); + + Parm3 := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (P, Loc), + Attribute_Name => Name_Address); + + Append (Pdecl, Decls); + end if; + + -- Now we can create the call, case of protected type + + if Is_Protected_Type (Conctyp) then + case Corresponding_Runtime_Package (Conctyp) is + when System_Tasking_Protected_Objects_Entries => + + -- Change the type of the index declaration + + Set_Object_Definition (Xdecl, + New_Reference_To (RTE (RE_Protected_Entry_Index), Loc)); + + -- Some additional declarations for protected entry calls + + if No (Decls) then + Decls := New_List; + end if; + + -- Bnn : Communications_Block; + + Comm_Name := Make_Temporary (Loc, 'B'); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Comm_Name, + Object_Definition => + New_Reference_To (RTE (RE_Communication_Block), Loc))); + + -- Some additional statements for protected entry calls + + -- Protected_Entry_Call ( + -- Object => po._object'Access, + -- E => ; + -- Uninterpreted_Data => P'Address; + -- Mode => Simple_Call; + -- Block => Bnn); + + Call := + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), + + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Unchecked_Access, + Prefix => Parm1), + Parm2, + Parm3, + New_Reference_To (RTE (RE_Simple_Call), Loc), + New_Occurrence_Of (Comm_Name, Loc))); + + when System_Tasking_Protected_Objects_Single_Entry => + -- Protected_Single_Entry_Call ( + -- Object => po._object'Access, + -- Uninterpreted_Data => P'Address; + -- Mode => Simple_Call); + + Call := + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + RTE (RE_Protected_Single_Entry_Call), Loc), + + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Unchecked_Access, + Prefix => Parm1), + Parm3, + New_Reference_To (RTE (RE_Simple_Call), Loc))); + + when others => + raise Program_Error; + end case; + + -- Case of task type + + else + Call := + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Call_Simple), Loc), + Parameter_Associations => New_List (Parm1, Parm2, Parm3)); + + end if; + + Append_To (Stats, Call); + + -- If there are out or in/out parameters by copy add assignment + -- statements for the result values. + + if Present (Parms) then + Actual := First_Actual (N); + Formal := First_Formal (Ent); + + Set_Assignment_OK (Actual); + while Present (Actual) loop + if Is_By_Copy_Type (Etype (Actual)) + and then Ekind (Formal) /= E_In_Parameter + then + N_Node := + Make_Assignment_Statement (Loc, + Name => New_Copy (Actual), + Expression => + Make_Explicit_Dereference (Loc, + Make_Selected_Component (Loc, + Prefix => New_Reference_To (P, Loc), + Selector_Name => + Make_Identifier (Loc, Chars (Formal))))); + + -- In all cases (including limited private types) we want + -- the assignment to be valid. + + Set_Assignment_OK (Name (N_Node)); + + -- If the call is the triggering alternative in an + -- asynchronous select, or the entry_call alternative of a + -- conditional entry call, the assignments for in-out + -- parameters are incorporated into the statement list that + -- follows, so that there are executed only if the entry + -- call succeeds. + + if (Nkind (Parent (N)) = N_Triggering_Alternative + and then N = Triggering_Statement (Parent (N))) + or else + (Nkind (Parent (N)) = N_Entry_Call_Alternative + and then N = Entry_Call_Statement (Parent (N))) + then + if No (Statements (Parent (N))) then + Set_Statements (Parent (N), New_List); + end if; + + Prepend (N_Node, Statements (Parent (N))); + + else + Insert_After (Call, N_Node); + end if; + end if; + + Next_Actual (Actual); + Next_Formal_With_Extras (Formal); + end loop; + end if; + + -- Finally, create block and analyze it + + Rewrite (N, + Make_Block_Statement (Loc, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stats))); + + Analyze (N); + end; + end Build_Simple_Entry_Call; + + -------------------------------- + -- Build_Task_Activation_Call -- + -------------------------------- + + procedure Build_Task_Activation_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Chain : Entity_Id; + Call : Node_Id; + Name : Node_Id; + P : Node_Id; + + begin + -- Get the activation chain entity. Except in the case of a package + -- body, this is in the node that was passed. For a package body, we + -- have to find the corresponding package declaration node. + + if Nkind (N) = N_Package_Body then + P := Corresponding_Spec (N); + loop + P := Parent (P); + exit when Nkind (P) = N_Package_Declaration; + end loop; + + Chain := Activation_Chain_Entity (P); + + else + Chain := Activation_Chain_Entity (N); + end if; + + if Present (Chain) then + if Restricted_Profile then + Name := New_Reference_To (RTE (RE_Activate_Restricted_Tasks), Loc); + else + Name := New_Reference_To (RTE (RE_Activate_Tasks), Loc); + end if; + + Call := + Make_Procedure_Call_Statement (Loc, + Name => Name, + Parameter_Associations => + New_List (Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Chain, Loc), + Attribute_Name => Name_Unchecked_Access))); + + if Nkind (N) = N_Package_Declaration then + if Present (Corresponding_Body (N)) then + null; + + elsif Present (Private_Declarations (Specification (N))) then + Append (Call, Private_Declarations (Specification (N))); + + else + Append (Call, Visible_Declarations (Specification (N))); + end if; + + else + if Present (Handled_Statement_Sequence (N)) then + + -- The call goes at the start of the statement sequence + -- after the start of exception range label if one is present. + + declare + Stm : Node_Id; + + begin + Stm := First (Statements (Handled_Statement_Sequence (N))); + + -- A special case, skip exception range label if one is + -- present (from front end zcx processing). + + if Nkind (Stm) = N_Label and then Exception_Junk (Stm) then + Next (Stm); + end if; + + -- Another special case, if the first statement is a block + -- from optimization of a local raise to a goto, then the + -- call goes inside this block. + + if Nkind (Stm) = N_Block_Statement + and then Exception_Junk (Stm) + then + Stm := + First (Statements (Handled_Statement_Sequence (Stm))); + end if; + + -- Insertion point is after any exception label pushes, + -- since we want it covered by any local handlers. + + while Nkind (Stm) in N_Push_xxx_Label loop + Next (Stm); + end loop; + + -- Now we have the proper insertion point + + Insert_Before (Stm, Call); + end; + + else + Set_Handled_Statement_Sequence (N, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Call))); + end if; + end if; + + Analyze (Call); + Check_Task_Activation (N); + end if; + end Build_Task_Activation_Call; + + ------------------------------- + -- Build_Task_Allocate_Block -- + ------------------------------- + + procedure Build_Task_Allocate_Block + (Actions : List_Id; + N : Node_Id; + Args : List_Id) + is + T : constant Entity_Id := Entity (Expression (N)); + Init : constant Entity_Id := Base_Init_Proc (T); + Loc : constant Source_Ptr := Sloc (N); + Chain : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_uChain); + Blkent : constant Entity_Id := Make_Temporary (Loc, 'A'); + Block : Node_Id; + + begin + Block := + Make_Block_Statement (Loc, + Identifier => New_Reference_To (Blkent, Loc), + Declarations => New_List ( + + -- _Chain : Activation_Chain; + + Make_Object_Declaration (Loc, + Defining_Identifier => Chain, + Aliased_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Activation_Chain), Loc))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + + Statements => New_List ( + + -- Init (Args); + + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Init, Loc), + Parameter_Associations => Args), + + -- Activate_Tasks (_Chain); + + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Chain, Loc), + Attribute_Name => Name_Unchecked_Access))))), + + Has_Created_Identifier => True, + Is_Task_Allocation_Block => True); + + Append_To (Actions, + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Blkent, + Label_Construct => Block)); + + Append_To (Actions, Block); + + Set_Activation_Chain_Entity (Block, Chain); + end Build_Task_Allocate_Block; + + ----------------------------------------------- + -- Build_Task_Allocate_Block_With_Init_Stmts -- + ----------------------------------------------- + + procedure Build_Task_Allocate_Block_With_Init_Stmts + (Actions : List_Id; + N : Node_Id; + Init_Stmts : List_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Chain : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_uChain); + Blkent : constant Entity_Id := Make_Temporary (Loc, 'A'); + Block : Node_Id; + + begin + Append_To (Init_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Chain, Loc), + Attribute_Name => Name_Unchecked_Access)))); + + Block := + Make_Block_Statement (Loc, + Identifier => New_Reference_To (Blkent, Loc), + Declarations => New_List ( + + -- _Chain : Activation_Chain; + + Make_Object_Declaration (Loc, + Defining_Identifier => Chain, + Aliased_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Activation_Chain), Loc))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Init_Stmts), + + Has_Created_Identifier => True, + Is_Task_Allocation_Block => True); + + Append_To (Actions, + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Blkent, + Label_Construct => Block)); + + Append_To (Actions, Block); + + Set_Activation_Chain_Entity (Block, Chain); + end Build_Task_Allocate_Block_With_Init_Stmts; + + ----------------------------------- + -- Build_Task_Proc_Specification -- + ----------------------------------- + + function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (T); + Spec_Id : Entity_Id; + + begin + -- Case of explicit task type, suffix TB + + if Comes_From_Source (T) then + Spec_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (T), "TB")); + + -- Case of anonymous task type, suffix B + + else + Spec_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (T), 'B')); + end if; + + Set_Is_Internal (Spec_Id); + + -- Associate the procedure with the task, if this is the declaration + -- (and not the body) of the procedure. + + if No (Task_Body_Procedure (T)) then + Set_Task_Body_Procedure (T, Spec_Id); + end if; + + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Spec_Id, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uTask), + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Reference_To (Corresponding_Record_Type (T), Loc))))); + end Build_Task_Proc_Specification; + + --------------------------------------- + -- Build_Unprotected_Subprogram_Body -- + --------------------------------------- + + function Build_Unprotected_Subprogram_Body + (N : Node_Id; + Pid : Node_Id) return Node_Id + is + Decls : constant List_Id := Declarations (N); + + begin + -- Add renamings for the Protection object, discriminals, privals and + -- the entry index constant for use by debugger. + + Debug_Private_Data_Declarations (Decls); + + -- Make an unprotected version of the subprogram for use within the same + -- object, with a new name and an additional parameter representing the + -- object. + + return + Make_Subprogram_Body (Sloc (N), + Specification => + Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode), + Declarations => Decls, + Handled_Statement_Sequence => Handled_Statement_Sequence (N)); + end Build_Unprotected_Subprogram_Body; + + ---------------------------- + -- Collect_Entry_Families -- + ---------------------------- + + procedure Collect_Entry_Families + (Loc : Source_Ptr; + Cdecls : List_Id; + Current_Node : in out Node_Id; + Conctyp : Entity_Id) + is + Efam : Entity_Id; + Efam_Decl : Node_Id; + Efam_Type : Entity_Id; + + begin + Efam := First_Entity (Conctyp); + while Present (Efam) loop + if Ekind (Efam) = E_Entry_Family then + Efam_Type := Make_Temporary (Loc, 'F'); + + declare + Bas : Entity_Id := + Base_Type + (Etype (Discrete_Subtype_Definition (Parent (Efam)))); + + Bas_Decl : Node_Id := Empty; + Lo, Hi : Node_Id; + + begin + Get_Index_Bounds + (Discrete_Subtype_Definition (Parent (Efam)), Lo, Hi); + + if Is_Potentially_Large_Family (Bas, Conctyp, Lo, Hi) then + Bas := Make_Temporary (Loc, 'B'); + + Bas_Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Bas, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Standard_Integer, Loc), + Constraint => + Make_Range_Constraint (Loc, + Range_Expression => Make_Range (Loc, + Make_Integer_Literal + (Loc, -Entry_Family_Bound), + Make_Integer_Literal + (Loc, Entry_Family_Bound - 1))))); + + Insert_After (Current_Node, Bas_Decl); + Current_Node := Bas_Decl; + Analyze (Bas_Decl); + end if; + + Efam_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Efam_Type, + Type_Definition => + Make_Unconstrained_Array_Definition (Loc, + Subtype_Marks => + (New_List (New_Occurrence_Of (Bas, Loc))), + + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Reference_To (Standard_Character, Loc)))); + end; + + Insert_After (Current_Node, Efam_Decl); + Current_Node := Efam_Decl; + Analyze (Efam_Decl); + + Append_To (Cdecls, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Efam)), + + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Efam_Type, Loc), + + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + New_Occurrence_Of + (Etype (Discrete_Subtype_Definition + (Parent (Efam))), Loc))))))); + + end if; + + Next_Entity (Efam); + end loop; + end Collect_Entry_Families; + + ----------------------- + -- Concurrent_Object -- + ----------------------- + + function Concurrent_Object + (Spec_Id : Entity_Id; + Conc_Typ : Entity_Id) return Entity_Id + is + begin + -- Parameter _O or _object + + if Is_Protected_Type (Conc_Typ) then + return First_Formal (Protected_Body_Subprogram (Spec_Id)); + + -- Parameter _task + + else + pragma Assert (Is_Task_Type (Conc_Typ)); + return First_Formal (Task_Body_Procedure (Conc_Typ)); + end if; + end Concurrent_Object; + + ---------------------- + -- Copy_Result_Type -- + ---------------------- + + function Copy_Result_Type (Res : Node_Id) return Node_Id is + New_Res : constant Node_Id := New_Copy_Tree (Res); + Par_Spec : Node_Id; + Formal : Entity_Id; + + begin + -- If the result type is an access_to_subprogram, we must create + -- new entities for its spec. + + if Nkind (New_Res) = N_Access_Definition + and then Present (Access_To_Subprogram_Definition (New_Res)) + then + -- Provide new entities for the formals + + Par_Spec := First (Parameter_Specifications + (Access_To_Subprogram_Definition (New_Res))); + while Present (Par_Spec) loop + Formal := Defining_Identifier (Par_Spec); + Set_Defining_Identifier (Par_Spec, + Make_Defining_Identifier (Sloc (Formal), Chars (Formal))); + Next (Par_Spec); + end loop; + end if; + + return New_Res; + end Copy_Result_Type; + + -------------------- + -- Concurrent_Ref -- + -------------------- + + -- The expression returned for a reference to a concurrent object has the + -- form: + + -- taskV!(name)._Task_Id + + -- for a task, and + + -- objectV!(name)._Object + + -- for a protected object. For the case of an access to a concurrent + -- object, there is an extra explicit dereference: + + -- taskV!(name.all)._Task_Id + -- objectV!(name.all)._Object + + -- here taskV and objectV are the types for the associated records, which + -- contain the required _Task_Id and _Object fields for tasks and protected + -- objects, respectively. + + -- For the case of a task type name, the expression is + + -- Self; + + -- i.e. a call to the Self function which returns precisely this Task_Id + + -- For the case of a protected type name, the expression is + + -- objectR + + -- which is a renaming of the _object field of the current object + -- record, passed into protected operations as a parameter. + + function Concurrent_Ref (N : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + Ntyp : constant Entity_Id := Etype (N); + Dtyp : Entity_Id; + Sel : Name_Id; + + function Is_Current_Task (T : Entity_Id) return Boolean; + -- Check whether the reference is to the immediately enclosing task + -- type, or to an outer one (rare but legal). + + --------------------- + -- Is_Current_Task -- + --------------------- + + function Is_Current_Task (T : Entity_Id) return Boolean is + Scop : Entity_Id; + + begin + Scop := Current_Scope; + while Present (Scop) + and then Scop /= Standard_Standard + loop + + if Scop = T then + return True; + + elsif Is_Task_Type (Scop) then + return False; + + -- If this is a procedure nested within the task type, we must + -- assume that it can be called from an inner task, and therefore + -- cannot treat it as a local reference. + + elsif Is_Overloadable (Scop) + and then In_Open_Scopes (T) + then + return False; + + else + Scop := Scope (Scop); + end if; + end loop; + + -- We know that we are within the task body, so should have found it + -- in scope. + + raise Program_Error; + end Is_Current_Task; + + -- Start of processing for Concurrent_Ref + + begin + if Is_Access_Type (Ntyp) then + Dtyp := Designated_Type (Ntyp); + + if Is_Protected_Type (Dtyp) then + Sel := Name_uObject; + else + Sel := Name_uTask_Id; + end if; + + return + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Corresponding_Record_Type (Dtyp), + Make_Explicit_Dereference (Loc, N)), + Selector_Name => Make_Identifier (Loc, Sel)); + + elsif Is_Entity_Name (N) + and then Is_Concurrent_Type (Entity (N)) + then + if Is_Task_Type (Entity (N)) then + + if Is_Current_Task (Entity (N)) then + return + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Self), Loc)); + + else + declare + Decl : Node_Id; + T_Self : constant Entity_Id := Make_Temporary (Loc, 'T'); + T_Body : constant Node_Id := + Parent (Corresponding_Body (Parent (Entity (N)))); + + begin + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => T_Self, + Object_Definition => + New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Self), Loc))); + Prepend (Decl, Declarations (T_Body)); + Analyze (Decl); + Set_Scope (T_Self, Entity (N)); + return New_Occurrence_Of (T_Self, Loc); + end; + end if; + + else + pragma Assert (Is_Protected_Type (Entity (N))); + + return + New_Reference_To (Find_Protection_Object (Current_Scope), Loc); + end if; + + else + if Is_Protected_Type (Ntyp) then + Sel := Name_uObject; + + elsif Is_Task_Type (Ntyp) then + Sel := Name_uTask_Id; + + else + raise Program_Error; + end if; + + return + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Corresponding_Record_Type (Ntyp), + New_Copy_Tree (N)), + Selector_Name => Make_Identifier (Loc, Sel)); + end if; + end Concurrent_Ref; + + ------------------------ + -- Convert_Concurrent -- + ------------------------ + + function Convert_Concurrent + (N : Node_Id; + Typ : Entity_Id) return Node_Id + is + begin + if not Is_Concurrent_Type (Typ) then + return N; + else + return + Unchecked_Convert_To + (Corresponding_Record_Type (Typ), New_Copy_Tree (N)); + end if; + end Convert_Concurrent; + + ------------------------------------- + -- Debug_Private_Data_Declarations -- + ------------------------------------- + + procedure Debug_Private_Data_Declarations (Decls : List_Id) is + Debug_Nod : Node_Id; + Decl : Node_Id; + + begin + Decl := First (Decls); + while Present (Decl) + and then not Comes_From_Source (Decl) + loop + -- Declaration for concurrent entity _object and its access type, + -- along with the entry index subtype: + -- type prot_typVP is access prot_typV; + -- _object : prot_typVP := prot_typV (_O); + -- subtype Jnn is range Low .. High; + + if Nkind_In (Decl, N_Full_Type_Declaration, N_Object_Declaration) then + Set_Debug_Info_Needed (Defining_Identifier (Decl)); + + -- Declaration for the Protection object, discriminals, privals and + -- entry index constant: + -- conc_typR : protection_typ renames _object._object; + -- discr_nameD : discr_typ renames _object.discr_name; + -- discr_nameD : discr_typ renames _task.discr_name; + -- prival_name : comp_typ renames _object.comp_name; + -- J : constant Jnn := + -- Jnn'Val (_E - + Jnn'Pos (Jnn'First)); + + elsif Nkind (Decl) = N_Object_Renaming_Declaration then + Set_Debug_Info_Needed (Defining_Identifier (Decl)); + Debug_Nod := Debug_Renaming_Declaration (Decl); + + if Present (Debug_Nod) then + Insert_After (Decl, Debug_Nod); + end if; + end if; + + Next (Decl); + end loop; + end Debug_Private_Data_Declarations; + + ---------------------------- + -- Entry_Index_Expression -- + ---------------------------- + + function Entry_Index_Expression + (Sloc : Source_Ptr; + Ent : Entity_Id; + Index : Node_Id; + Ttyp : Entity_Id) return Node_Id + is + Expr : Node_Id; + Num : Node_Id; + Lo : Node_Id; + Hi : Node_Id; + Prev : Entity_Id; + S : Node_Id; + + begin + -- The queues of entries and entry families appear in textual order in + -- the associated record. The entry index is computed as the sum of the + -- number of queues for all entries that precede the designated one, to + -- which is added the index expression, if this expression denotes a + -- member of a family. + + -- The following is a place holder for the count of simple entries + + Num := Make_Integer_Literal (Sloc, 1); + + -- We construct an expression which is a series of addition operations. + -- The first operand is the number of single entries that precede this + -- one, the second operand is the index value relative to the start of + -- the referenced family, and the remaining operands are the lengths of + -- the entry families that precede this entry, i.e. the constructed + -- expression is: + + -- number_simple_entries + + -- (s'pos (index-value) - s'pos (family'first)) + 1 + + -- family'length + ... + + -- where index-value is the given index value, and s is the index + -- subtype (we have to use pos because the subtype might be an + -- enumeration type preventing direct subtraction). Note that the task + -- entry array is one-indexed. + + -- The upper bound of the entry family may be a discriminant, so we + -- retrieve the lower bound explicitly to compute offset, rather than + -- using the index subtype which may mention a discriminant. + + if Present (Index) then + S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent))); + + Expr := + Make_Op_Add (Sloc, + Left_Opnd => Num, + + Right_Opnd => + Family_Offset ( + Sloc, + Make_Attribute_Reference (Sloc, + Attribute_Name => Name_Pos, + Prefix => New_Reference_To (Base_Type (S), Sloc), + Expressions => New_List (Relocate_Node (Index))), + Type_Low_Bound (S), + Ttyp, + False)); + else + Expr := Num; + end if; + + -- Now add lengths of preceding entries and entry families + + Prev := First_Entity (Ttyp); + + while Chars (Prev) /= Chars (Ent) + or else (Ekind (Prev) /= Ekind (Ent)) + or else not Sem_Ch6.Type_Conformant (Ent, Prev) + loop + if Ekind (Prev) = E_Entry then + Set_Intval (Num, Intval (Num) + 1); + + elsif Ekind (Prev) = E_Entry_Family then + S := + Etype (Discrete_Subtype_Definition (Declaration_Node (Prev))); + Lo := Type_Low_Bound (S); + Hi := Type_High_Bound (S); + + Expr := + Make_Op_Add (Sloc, + Left_Opnd => Expr, + Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp, False)); + + -- Other components are anonymous types to be ignored + + else + null; + end if; + + Next_Entity (Prev); + end loop; + + return Expr; + end Entry_Index_Expression; + + --------------------------- + -- Establish_Task_Master -- + --------------------------- + + procedure Establish_Task_Master (N : Node_Id) is + Call : Node_Id; + begin + if Restriction_Active (No_Task_Hierarchy) = False then + Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master); + Prepend_To (Declarations (N), Call); + Analyze (Call); + end if; + end Establish_Task_Master; + + -------------------------------- + -- Expand_Accept_Declarations -- + -------------------------------- + + -- Part of the expansion of an accept statement involves the creation of + -- a declaration that can be referenced from the statement sequence of + -- the accept: + + -- Ann : Address; + + -- This declaration is inserted immediately before the accept statement + -- and it is important that it be inserted before the statements of the + -- statement sequence are analyzed. Thus it would be too late to create + -- this declaration in the Expand_N_Accept_Statement routine, which is + -- why there is a separate procedure to be called directly from Sem_Ch9. + + -- Ann is used to hold the address of the record containing the parameters + -- (see Expand_N_Entry_Call for more details on how this record is built). + -- References to the parameters do an unchecked conversion of this address + -- to a pointer to the required record type, and then access the field that + -- holds the value of the required parameter. The entity for the address + -- variable is held as the top stack element (i.e. the last element) of the + -- Accept_Address stack in the corresponding entry entity, and this element + -- must be set in place before the statements are processed. + + -- The above description applies to the case of a stand alone accept + -- statement, i.e. one not appearing as part of a select alternative. + + -- For the case of an accept that appears as part of a select alternative + -- of a selective accept, we must still create the declaration right away, + -- since Ann is needed immediately, but there is an important difference: + + -- The declaration is inserted before the selective accept, not before + -- the accept statement (which is not part of a list anyway, and so would + -- not accommodate inserted declarations) + + -- We only need one address variable for the entire selective accept. So + -- the Ann declaration is created only for the first accept alternative, + -- and subsequent accept alternatives reference the same Ann variable. + + -- We can distinguish the two cases by seeing whether the accept statement + -- is part of a list. If not, then it must be in an accept alternative. + + -- To expand the requeue statement, a label is provided at the end of the + -- accept statement or alternative of which it is a part, so that the + -- statement can be skipped after the requeue is complete. This label is + -- created here rather than during the expansion of the accept statement, + -- because it will be needed by any requeue statements within the accept, + -- which are expanded before the accept. + + procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Stats : constant Node_Id := Handled_Statement_Sequence (N); + Ann : Entity_Id := Empty; + Adecl : Node_Id; + Lab_Id : Node_Id; + Lab : Node_Id; + Ldecl : Node_Id; + Ldecl2 : Node_Id; + + begin + if Expander_Active then + + -- If we have no handled statement sequence, we may need to build + -- a dummy sequence consisting of a null statement. This can be + -- skipped if the trivial accept optimization is permitted. + + if not Trivial_Accept_OK + and then + (No (Stats) or else Null_Statements (Statements (Stats))) + then + Set_Handled_Statement_Sequence (N, + Make_Handled_Sequence_Of_Statements (Loc, + New_List (Make_Null_Statement (Loc)))); + end if; + + -- Create and declare two labels to be placed at the end of the + -- accept statement. The first label is used to allow requeues to + -- skip the remainder of entry processing. The second label is used + -- to skip the remainder of entry processing if the rendezvous + -- completes in the middle of the accept body. + + if Present (Handled_Statement_Sequence (N)) then + declare + Ent : Entity_Id; + + begin + Ent := Make_Temporary (Loc, 'L'); + Lab_Id := New_Reference_To (Ent, Loc); + Lab := Make_Label (Loc, Lab_Id); + Ldecl := + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Ent, + Label_Construct => Lab); + Append (Lab, Statements (Handled_Statement_Sequence (N))); + + Ent := Make_Temporary (Loc, 'L'); + Lab_Id := New_Reference_To (Ent, Loc); + Lab := Make_Label (Loc, Lab_Id); + Ldecl2 := + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Ent, + Label_Construct => Lab); + Append (Lab, Statements (Handled_Statement_Sequence (N))); + end; + + else + Ldecl := Empty; + Ldecl2 := Empty; + end if; + + -- Case of stand alone accept statement + + if Is_List_Member (N) then + + if Present (Handled_Statement_Sequence (N)) then + Ann := Make_Temporary (Loc, 'A'); + + Adecl := + Make_Object_Declaration (Loc, + Defining_Identifier => Ann, + Object_Definition => + New_Reference_To (RTE (RE_Address), Loc)); + + Insert_Before (N, Adecl); + Analyze (Adecl); + + Insert_Before (N, Ldecl); + Analyze (Ldecl); + + Insert_Before (N, Ldecl2); + Analyze (Ldecl2); + end if; + + -- Case of accept statement which is in an accept alternative + + else + declare + Acc_Alt : constant Node_Id := Parent (N); + Sel_Acc : constant Node_Id := Parent (Acc_Alt); + Alt : Node_Id; + + begin + pragma Assert (Nkind (Acc_Alt) = N_Accept_Alternative); + pragma Assert (Nkind (Sel_Acc) = N_Selective_Accept); + + -- ??? Consider a single label for select statements + + if Present (Handled_Statement_Sequence (N)) then + Prepend (Ldecl2, + Statements (Handled_Statement_Sequence (N))); + Analyze (Ldecl2); + + Prepend (Ldecl, + Statements (Handled_Statement_Sequence (N))); + Analyze (Ldecl); + end if; + + -- Find first accept alternative of the selective accept. A + -- valid selective accept must have at least one accept in it. + + Alt := First (Select_Alternatives (Sel_Acc)); + + while Nkind (Alt) /= N_Accept_Alternative loop + Next (Alt); + end loop; + + -- If we are the first accept statement, then we have to create + -- the Ann variable, as for the stand alone case, except that + -- it is inserted before the selective accept. Similarly, a + -- label for requeue expansion must be declared. + + if N = Accept_Statement (Alt) then + Ann := Make_Temporary (Loc, 'A'); + Adecl := + Make_Object_Declaration (Loc, + Defining_Identifier => Ann, + Object_Definition => + New_Reference_To (RTE (RE_Address), Loc)); + + Insert_Before (Sel_Acc, Adecl); + Analyze (Adecl); + + -- If we are not the first accept statement, then find the Ann + -- variable allocated by the first accept and use it. + + else + Ann := + Node (Last_Elmt (Accept_Address + (Entity (Entry_Direct_Name (Accept_Statement (Alt)))))); + end if; + end; + end if; + + -- Merge here with Ann either created or referenced, and Adecl + -- pointing to the corresponding declaration. Remaining processing + -- is the same for the two cases. + + if Present (Ann) then + Append_Elmt (Ann, Accept_Address (Ent)); + Set_Debug_Info_Needed (Ann); + end if; + + -- Create renaming declarations for the entry formals. Each reference + -- to a formal becomes a dereference of a component of the parameter + -- block, whose address is held in Ann. These declarations are + -- eventually inserted into the accept block, and analyzed there so + -- that they have the proper scope for gdb and do not conflict with + -- other declarations. + + if Present (Parameter_Specifications (N)) + and then Present (Handled_Statement_Sequence (N)) + then + declare + Comp : Entity_Id; + Decl : Node_Id; + Formal : Entity_Id; + New_F : Entity_Id; + + begin + Push_Scope (Ent); + Formal := First_Formal (Ent); + + while Present (Formal) loop + Comp := Entry_Component (Formal); + New_F := + Make_Defining_Identifier (Loc, Chars (Formal)); + + Set_Etype (New_F, Etype (Formal)); + Set_Scope (New_F, Ent); + + -- Now we set debug info needed on New_F even though it does + -- not come from source, so that the debugger will get the + -- right information for these generated names. + + Set_Debug_Info_Needed (New_F); + + if Ekind (Formal) = E_In_Parameter then + Set_Ekind (New_F, E_Constant); + else + Set_Ekind (New_F, E_Variable); + Set_Extra_Constrained (New_F, Extra_Constrained (Formal)); + end if; + + Set_Actual_Subtype (New_F, Actual_Subtype (Formal)); + + Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => + New_F, + Subtype_Mark => + New_Reference_To (Etype (Formal), Loc), + Name => + Make_Explicit_Dereference (Loc, + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To ( + Entry_Parameters_Type (Ent), + New_Reference_To (Ann, Loc)), + Selector_Name => + New_Reference_To (Comp, Loc)))); + + if No (Declarations (N)) then + Set_Declarations (N, New_List); + end if; + + Append (Decl, Declarations (N)); + Set_Renamed_Object (Formal, New_F); + Next_Formal (Formal); + end loop; + + End_Scope; + end; + end if; + end if; + end Expand_Accept_Declarations; + + --------------------------------------------- + -- Expand_Access_Protected_Subprogram_Type -- + --------------------------------------------- + + procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Comps : List_Id; + T : constant Entity_Id := Defining_Identifier (N); + D_T : constant Entity_Id := Designated_Type (T); + D_T2 : constant Entity_Id := Make_Temporary (Loc, 'D'); + E_T : constant Entity_Id := Make_Temporary (Loc, 'E'); + P_List : constant List_Id := Build_Protected_Spec + (N, RTE (RE_Address), D_T, False); + Decl1 : Node_Id; + Decl2 : Node_Id; + Def1 : Node_Id; + + begin + -- Create access to subprogram with full signature + + if Etype (D_T) /= Standard_Void_Type then + Def1 := + Make_Access_Function_Definition (Loc, + Parameter_Specifications => P_List, + Result_Definition => + Copy_Result_Type (Result_Definition (Type_Definition (N)))); + + else + Def1 := + Make_Access_Procedure_Definition (Loc, + Parameter_Specifications => P_List); + end if; + + Decl1 := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => D_T2, + Type_Definition => Def1); + + Insert_After (N, Decl1); + Analyze (Decl1); + + -- Create Equivalent_Type, a record with two components for an access to + -- object and an access to subprogram. + + Comps := New_List ( + Make_Component_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'P'), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Address), Loc))), + + Make_Component_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'S'), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => New_Occurrence_Of (D_T2, Loc)))); + + Decl2 := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => E_T, + Type_Definition => + Make_Record_Definition (Loc, + Component_List => + Make_Component_List (Loc, + Component_Items => Comps))); + + Insert_After (Decl1, Decl2); + Analyze (Decl2); + Set_Equivalent_Type (T, E_T); + end Expand_Access_Protected_Subprogram_Type; + + -------------------------- + -- Expand_Entry_Barrier -- + -------------------------- + + procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is + Cond : constant Node_Id := + Condition (Entry_Body_Formal_Part (N)); + Prot : constant Entity_Id := Scope (Ent); + Spec_Decl : constant Node_Id := Parent (Prot); + Func : Node_Id; + B_F : Node_Id; + Body_Decl : Node_Id; + + begin + if No_Run_Time_Mode then + Error_Msg_CRT ("entry barrier", N); + return; + end if; + + -- The body of the entry barrier must be analyzed in the context of the + -- protected object, but its scope is external to it, just as any other + -- unprotected version of a protected operation. The specification has + -- been produced when the protected type declaration was elaborated. We + -- build the body, insert it in the enclosing scope, but analyze it in + -- the current context. A more uniform approach would be to treat the + -- barrier just as a protected function, and discard the protected + -- version of it because it is never called. + + if Expander_Active then + B_F := Build_Barrier_Function (N, Ent, Prot); + Func := Barrier_Function (Ent); + Set_Corresponding_Spec (B_F, Func); + + Body_Decl := Parent (Corresponding_Body (Spec_Decl)); + + if Nkind (Parent (Body_Decl)) = N_Subunit then + Body_Decl := Corresponding_Stub (Parent (Body_Decl)); + end if; + + Insert_Before_And_Analyze (Body_Decl, B_F); + + Set_Discriminals (Spec_Decl); + Set_Scope (Func, Scope (Prot)); + + else + Analyze_And_Resolve (Cond, Any_Boolean); + end if; + + -- The Ravenscar profile restricts barriers to simple variables declared + -- within the protected object. We also allow Boolean constants, since + -- these appear in several published examples and are also allowed by + -- the Aonix compiler. + + -- Note that after analysis variables in this context will be replaced + -- by the corresponding prival, that is to say a renaming of a selected + -- component of the form _Object.Var. If expansion is disabled, as + -- within a generic, we check that the entity appears in the current + -- scope. + + if Is_Entity_Name (Cond) then + + -- A small optimization of useless renamings. If the scope of the + -- entity of the condition is not the barrier function, then the + -- condition does not reference any of the generated renamings + -- within the function. + + if Expander_Active + and then Scope (Entity (Cond)) /= Func + then + Set_Declarations (B_F, Empty_List); + end if; + + if Entity (Cond) = Standard_False + or else + Entity (Cond) = Standard_True + then + return; + + elsif not Expander_Active + and then Scope (Entity (Cond)) = Current_Scope + then + return; + + -- Check for case of _object.all.field (note that the explicit + -- dereference gets inserted by analyze/expand of _object.field) + + elsif Present (Renamed_Object (Entity (Cond))) + and then + Nkind (Renamed_Object (Entity (Cond))) = N_Selected_Component + and then + Chars + (Prefix + (Prefix (Renamed_Object (Entity (Cond))))) = Name_uObject + then + return; + end if; + end if; + + -- It is not a boolean variable or literal, so check the restriction + + Check_Restriction (Simple_Barriers, Cond); + end Expand_Entry_Barrier; + + ------------------------------ + -- Expand_N_Abort_Statement -- + ------------------------------ + + -- Expand abort T1, T2, .. Tn; into: + -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...)) + + procedure Expand_N_Abort_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Tlist : constant List_Id := Names (N); + Count : Nat; + Aggr : Node_Id; + Tasknm : Node_Id; + + begin + Aggr := Make_Aggregate (Loc, Component_Associations => New_List); + Count := 0; + + Tasknm := First (Tlist); + + while Present (Tasknm) loop + Count := Count + 1; + + -- A task interface class-wide type object is being aborted. + -- Retrieve its _task_id by calling a dispatching routine. + + if Ada_Version >= Ada_2005 + and then Ekind (Etype (Tasknm)) = E_Class_Wide_Type + and then Is_Interface (Etype (Tasknm)) + and then Is_Task_Interface (Etype (Tasknm)) + then + Append_To (Component_Associations (Aggr), + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, Count)), + Expression => + + -- Task_Id (Tasknm._disp_get_task_id) + + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Reference_To (RTE (RO_ST_Task_Id), Loc), + Expression => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Tasknm), + Selector_Name => + Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))); + + else + Append_To (Component_Associations (Aggr), + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, Count)), + Expression => Concurrent_Ref (Tasknm))); + end if; + + Next (Tasknm); + end loop; + + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Abort_Tasks), Loc), + Parameter_Associations => New_List ( + Make_Qualified_Expression (Loc, + Subtype_Mark => New_Reference_To (RTE (RE_Task_List), Loc), + Expression => Aggr)))); + + Analyze (N); + end Expand_N_Abort_Statement; + + ------------------------------- + -- Expand_N_Accept_Statement -- + ------------------------------- + + -- This procedure handles expansion of accept statements that stand + -- alone, i.e. they are not part of an accept alternative. The expansion + -- of accept statement in accept alternatives is handled by the routines + -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The + -- following description applies only to stand alone accept statements. + + -- If there is no handled statement sequence, or only null statements, + -- then this is called a trivial accept, and the expansion is: + + -- Accept_Trivial (entry-index) + + -- If there is a handled statement sequence, then the expansion is: + + -- Ann : Address; + -- {Lnn : Label} + + -- begin + -- begin + -- Accept_Call (entry-index, Ann); + -- Renaming_Declarations for formals + -- + -- Complete_Rendezvous; + -- <> + -- + -- exception + -- when ... => + -- + -- Complete_Rendezvous; + -- when ... => + -- + -- Complete_Rendezvous; + -- ... + -- end; + + -- exception + -- when all others => + -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); + -- end; + + -- The first three declarations were already inserted ahead of the accept + -- statement by the Expand_Accept_Declarations procedure, which was called + -- directly from the semantics during analysis of the accept statement, + -- before analyzing its contained statements. + + -- The declarations from the N_Accept_Statement, as noted in Sinfo, come + -- from possible expansion activity (the original source of course does + -- not have any declarations associated with the accept statement, since + -- an accept statement has no declarative part). In particular, if the + -- expander is active, the first such declaration is the declaration of + -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement). + -- + -- The two blocks are merged into a single block if the inner block has + -- no exception handlers, but otherwise two blocks are required, since + -- exceptions might be raised in the exception handlers of the inner + -- block, and Exceptional_Complete_Rendezvous must be called. + + procedure Expand_N_Accept_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Stats : constant Node_Id := Handled_Statement_Sequence (N); + Ename : constant Node_Id := Entry_Direct_Name (N); + Eindx : constant Node_Id := Entry_Index (N); + Eent : constant Entity_Id := Entity (Ename); + Acstack : constant Elist_Id := Accept_Address (Eent); + Ann : constant Entity_Id := Node (Last_Elmt (Acstack)); + Ttyp : constant Entity_Id := Etype (Scope (Eent)); + Blkent : Entity_Id; + Call : Node_Id; + Block : Node_Id; + + -- Start of processing for Expand_N_Accept_Statement + + begin + -- If accept statement is not part of a list, then its parent must be + -- an accept alternative, and, as described above, we do not do any + -- expansion for such accept statements at this level. + + if not Is_List_Member (N) then + pragma Assert (Nkind (Parent (N)) = N_Accept_Alternative); + return; + + -- Trivial accept case (no statement sequence, or null statements). + -- If the accept statement has declarations, then just insert them + -- before the procedure call. + + elsif Trivial_Accept_OK + and then (No (Stats) or else Null_Statements (Statements (Stats))) + then + -- Remove declarations for renamings, because the parameter block + -- will not be assigned. + + declare + D : Node_Id; + Next_D : Node_Id; + + begin + D := First (Declarations (N)); + + while Present (D) loop + Next_D := Next (D); + if Nkind (D) = N_Object_Renaming_Declaration then + Remove (D); + end if; + + D := Next_D; + end loop; + end; + + if Present (Declarations (N)) then + Insert_Actions (N, Declarations (N)); + end if; + + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Accept_Trivial), Loc), + Parameter_Associations => New_List ( + Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp)))); + + Analyze (N); + + -- Discard Entry_Address that was created for it, so it will not be + -- emitted if this accept statement is in the statement part of a + -- delay alternative. + + if Present (Stats) then + Remove_Last_Elmt (Acstack); + end if; + + -- Case of statement sequence present + + else + -- Construct the block, using the declarations from the accept + -- statement if any to initialize the declarations of the block. + + Blkent := Make_Temporary (Loc, 'A'); + Set_Ekind (Blkent, E_Block); + Set_Etype (Blkent, Standard_Void_Type); + Set_Scope (Blkent, Current_Scope); + + Block := + Make_Block_Statement (Loc, + Identifier => New_Reference_To (Blkent, Loc), + Declarations => Declarations (N), + Handled_Statement_Sequence => Build_Accept_Body (N)); + + -- For the analysis of the generated declarations, the parent node + -- must be properly set. + + Set_Parent (Block, Parent (N)); + + -- Prepend call to Accept_Call to main statement sequence If the + -- accept has exception handlers, the statement sequence is wrapped + -- in a block. Insert call and renaming declarations in the + -- declarations of the block, so they are elaborated before the + -- handlers. + + Call := + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Accept_Call), Loc), + Parameter_Associations => New_List ( + Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp), + New_Reference_To (Ann, Loc))); + + if Parent (Stats) = N then + Prepend (Call, Statements (Stats)); + else + Set_Declarations + (Parent (Stats), + New_List (Call)); + end if; + + Analyze (Call); + + Push_Scope (Blkent); + + declare + D : Node_Id; + Next_D : Node_Id; + Typ : Entity_Id; + + begin + D := First (Declarations (N)); + while Present (D) loop + Next_D := Next (D); + + if Nkind (D) = N_Object_Renaming_Declaration then + + -- The renaming declarations for the formals were created + -- during analysis of the accept statement, and attached to + -- the list of declarations. Place them now in the context + -- of the accept block or subprogram. + + Remove (D); + Typ := Entity (Subtype_Mark (D)); + Insert_After (Call, D); + Analyze (D); + + -- If the formal is class_wide, it does not have an actual + -- subtype. The analysis of the renaming declaration creates + -- one, but we need to retain the class-wide nature of the + -- entity. + + if Is_Class_Wide_Type (Typ) then + Set_Etype (Defining_Identifier (D), Typ); + end if; + + end if; + + D := Next_D; + end loop; + end; + + End_Scope; + + -- Replace the accept statement by the new block + + Rewrite (N, Block); + Analyze (N); + + -- Last step is to unstack the Accept_Address value + + Remove_Last_Elmt (Acstack); + end if; + end Expand_N_Accept_Statement; + + ---------------------------------- + -- Expand_N_Asynchronous_Select -- + ---------------------------------- + + -- This procedure assumes that the trigger statement is an entry call or + -- a dispatching procedure call. A delay alternative should already have + -- been expanded into an entry call to the appropriate delay object Wait + -- entry. + + -- If the trigger is a task entry call, the select is implemented with + -- a Task_Entry_Call: + + -- declare + -- B : Boolean; + -- C : Boolean; + -- P : parms := (parm, parm, parm); + + -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions + + -- procedure _clean is + -- begin + -- ... + -- Cancel_Task_Entry_Call (C); + -- ... + -- end _clean; + + -- begin + -- Abort_Defer; + -- Task_Entry_Call + -- (, -- Acceptor + -- , -- E + -- P'Address, -- Uninterpreted_Data + -- Asynchronous_Call, -- Mode + -- B); -- Rendezvous_Successful + + -- begin + -- begin + -- Abort_Undefer; + -- + -- at end + -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions + -- end; + -- exception + -- when Abort_Signal => Abort_Undefer; + -- end; + + -- parm := P.param; + -- parm := P.param; + -- ... + -- if not C then + -- + -- end if; + -- end; + + -- Note that Build_Simple_Entry_Call is used to expand the entry of the + -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure) + -- as follows: + + -- declare + -- P : parms := (parm, parm, parm); + -- begin + -- Call_Simple (acceptor-task, entry-index, P'Address); + -- parm := P.param; + -- parm := P.param; + -- ... + -- end; + + -- so the task at hand is to convert the latter expansion into the former + + -- If the trigger is a protected entry call, the select is implemented + -- with Protected_Entry_Call: + + -- declare + -- P : E1_Params := (param, param, param); + -- Bnn : Communications_Block; + + -- begin + -- declare + + -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions + + -- procedure _clean is + -- begin + -- ... + -- if Enqueued (Bnn) then + -- Cancel_Protected_Entry_Call (Bnn); + -- end if; + -- ... + -- end _clean; + + -- begin + -- begin + -- Protected_Entry_Call + -- (po._object'Access, -- Object + -- , -- E + -- P'Address, -- Uninterpreted_Data + -- Asynchronous_Call, -- Mode + -- Bnn); -- Block + + -- if Enqueued (Bnn) then + -- + -- end if; + -- at end + -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions + -- end; + -- exception + -- when Abort_Signal => Abort_Undefer; + -- end; + + -- if not Cancelled (Bnn) then + -- + -- end if; + -- end; + + -- Build_Simple_Entry_Call is used to expand the all to a simple protected + -- entry call: + + -- declare + -- P : E1_Params := (param, param, param); + -- Bnn : Communications_Block; + + -- begin + -- Protected_Entry_Call + -- (po._object'Access, -- Object + -- , -- E + -- P'Address, -- Uninterpreted_Data + -- Simple_Call, -- Mode + -- Bnn); -- Block + -- parm := P.param; + -- parm := P.param; + -- ... + -- end; + + -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is + -- expanded into: + + -- declare + -- B : Boolean := False; + -- Bnn : Communication_Block; + -- C : Ada.Tags.Prim_Op_Kind; + -- D : System.Storage_Elements.Dummy_Communication_Block; + -- K : Ada.Tags.Tagged_Kind := + -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag ()); + -- P : Parameters := (Param1 .. ParamN); + -- S : Integer; + -- U : Boolean; + + -- begin + -- if K = Ada.Tags.TK_Limited_Tagged then + -- ; + -- ; + + -- else + -- S := + -- Ada.Tags.Get_Offset_Index + -- (Ada.Tags.Tag (), DT_Position ()); + + -- _Disp_Get_Prim_Op_Kind (, S, C); + + -- if C = POK_Protected_Entry then + -- declare + -- procedure _clean is + -- begin + -- if Enqueued (Bnn) then + -- Cancel_Protected_Entry_Call (Bnn); + -- end if; + -- end _clean; + + -- begin + -- begin + -- _Disp_Asynchronous_Select + -- (, S, P'Address, D, B); + -- Bnn := Communication_Block (D); + + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + + -- if Enqueued (Bnn) then + -- + -- end if; + -- at end + -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions + -- end; + -- exception + -- when Abort_Signal => Abort_Undefer; + -- end; + + -- if not Cancelled (Bnn) then + -- + -- end if; + + -- elsif C = POK_Task_Entry then + -- declare + -- procedure _clean is + -- begin + -- Cancel_Task_Entry_Call (U); + -- end _clean; + + -- begin + -- Abort_Defer; + + -- _Disp_Asynchronous_Select + -- (, S, P'Address, D, B); + -- Bnn := Communication_Bloc (D); + + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + + -- begin + -- begin + -- Abort_Undefer; + -- + -- at end + -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions + -- end; + -- exception + -- when Abort_Signal => Abort_Undefer; + -- end; + + -- if not U then + -- + -- end if; + -- end; + + -- else + -- ; + -- + -- end if; + -- end if; + -- end; + + -- The job is to convert this to the asynchronous form + + -- If the trigger is a delay statement, it will have been expanded into a + -- call to one of the GNARL delay procedures. This routine will convert + -- this into a protected entry call on a delay object and then continue + -- processing as for a protected entry call trigger. This requires + -- declaring a Delay_Block object and adding a pointer to this object to + -- the parameter list of the delay procedure to form the parameter list of + -- the entry call. This object is used by the runtime to queue the delay + -- request. + + -- For a description of the use of P and the assignments after the call, + -- see Expand_N_Entry_Call_Statement. + + procedure Expand_N_Asynchronous_Select (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Abrt : constant Node_Id := Abortable_Part (N); + Astats : constant List_Id := Statements (Abrt); + Trig : constant Node_Id := Triggering_Alternative (N); + Tstats : constant List_Id := Statements (Trig); + + Abort_Block_Ent : Entity_Id; + Abortable_Block : Node_Id; + Actuals : List_Id; + Blk_Ent : Entity_Id; + Blk_Typ : Entity_Id; + Call : Node_Id; + Call_Ent : Entity_Id; + Cancel_Param : Entity_Id; + Cleanup_Block : Node_Id; + Cleanup_Block_Ent : Entity_Id; + Cleanup_Stmts : List_Id; + Conc_Typ_Stmts : List_Id; + Concval : Node_Id; + Dblock_Ent : Entity_Id; + Decl : Node_Id; + Decls : List_Id; + Ecall : Node_Id; + Ename : Node_Id; + Enqueue_Call : Node_Id; + Formals : List_Id; + Hdle : List_Id; + Index : Node_Id; + Lim_Typ_Stmts : List_Id; + N_Orig : Node_Id; + Obj : Entity_Id; + Param : Node_Id; + Params : List_Id; + Pdef : Entity_Id; + ProtE_Stmts : List_Id; + ProtP_Stmts : List_Id; + Stmt : Node_Id; + Stmts : List_Id; + Target_Undefer : RE_Id; + TaskE_Stmts : List_Id; + Undefer_Args : List_Id := No_List; + + B : Entity_Id; -- Call status flag + Bnn : Entity_Id; -- Communication block + C : Entity_Id; -- Call kind + K : Entity_Id; -- Tagged kind + P : Entity_Id; -- Parameter block + S : Entity_Id; -- Primitive operation slot + T : Entity_Id; -- Additional status flag + + begin + Blk_Ent := Make_Temporary (Loc, 'A'); + Ecall := Triggering_Statement (Trig); + + -- The arguments in the call may require dynamic allocation, and the + -- call statement may have been transformed into a block. The block + -- may contain additional declarations for internal entities, and the + -- original call is found by sequential search. + + if Nkind (Ecall) = N_Block_Statement then + Ecall := First (Statements (Handled_Statement_Sequence (Ecall))); + while not Nkind_In (Ecall, N_Procedure_Call_Statement, + N_Entry_Call_Statement) + loop + Next (Ecall); + end loop; + end if; + + -- This is either a dispatching call or a delay statement used as a + -- trigger which was expanded into a procedure call. + + if Nkind (Ecall) = N_Procedure_Call_Statement then + if Ada_Version >= Ada_2005 + and then + (No (Original_Node (Ecall)) + or else not Nkind_In (Original_Node (Ecall), + N_Delay_Relative_Statement, + N_Delay_Until_Statement)) + then + Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals); + + Decls := New_List; + Stmts := New_List; + + -- Call status flag processing, generate: + -- B : Boolean := False; + + B := Build_B (Loc, Decls); + + -- Communication block processing, generate: + -- Bnn : Communication_Block; + + Bnn := Make_Temporary (Loc, 'B'); + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Bnn, + Object_Definition => + New_Reference_To (RTE (RE_Communication_Block), Loc))); + + -- Call kind processing, generate: + -- C : Ada.Tags.Prim_Op_Kind; + + C := Build_C (Loc, Decls); + + -- Tagged kind processing, generate: + -- K : Ada.Tags.Tagged_Kind := + -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag ()); + + -- Dummy communication block, generate: + -- D : Dummy_Communication_Block; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uD), + Object_Definition => + New_Reference_To ( + RTE (RE_Dummy_Communication_Block), Loc))); + + K := Build_K (Loc, Decls, Obj); + + -- Parameter block processing + + Blk_Typ := Build_Parameter_Block + (Loc, Actuals, Formals, Decls); + P := Parameter_Block_Pack + (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); + + -- Dispatch table slot processing, generate: + -- S : Integer; + + S := Build_S (Loc, Decls); + + -- Additional status flag processing, generate: + -- Tnn : Boolean; + + T := Make_Temporary (Loc, 'T'); + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => T, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc))); + + ------------------------------ + -- Protected entry handling -- + ------------------------------ + + -- Generate: + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + + Cleanup_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals); + + -- Generate: + -- Bnn := Communication_Block (D); + + Prepend_To (Cleanup_Stmts, + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Bnn, Loc), + Expression => + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Communication_Block), Loc), + Expression => Make_Identifier (Loc, Name_uD)))); + + -- Generate: + -- _Disp_Asynchronous_Select (, S, P'Address, D, B); + + Prepend_To (Cleanup_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + Find_Prim_Op (Etype (Etype (Obj)), + Name_uDisp_Asynchronous_Select), + Loc), + Parameter_Associations => + New_List ( + New_Copy_Tree (Obj), -- + New_Reference_To (S, Loc), -- S + Make_Attribute_Reference (Loc, -- P'Address + Prefix => + New_Reference_To (P, Loc), + Attribute_Name => + Name_Address), + Make_Identifier (Loc, Name_uD), -- D + New_Reference_To (B, Loc)))); -- B + + -- Generate: + -- if Enqueued (Bnn) then + -- + -- end if; + + Append_To (Cleanup_Stmts, + Make_If_Statement (Loc, + Condition => + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Enqueued), Loc), + Parameter_Associations => + New_List ( + New_Reference_To (Bnn, Loc))), + + Then_Statements => + New_Copy_List_Tree (Astats))); + + -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions + -- will then generate a _clean for the communication block Bnn. + + -- Generate: + -- declare + -- procedure _clean is + -- begin + -- if Enqueued (Bnn) then + -- Cancel_Protected_Entry_Call (Bnn); + -- end if; + -- end _clean; + -- begin + -- Cleanup_Stmts + -- at end + -- _clean; + -- end; + + Cleanup_Block_Ent := Make_Temporary (Loc, 'C'); + Cleanup_Block := + Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, Bnn); + + -- Wrap the cleanup block in an exception handling block + + -- Generate: + -- begin + -- Cleanup_Block + -- exception + -- when Abort_Signal => Abort_Undefer; + -- end; + + Abort_Block_Ent := Make_Temporary (Loc, 'A'); + ProtE_Stmts := + New_List ( + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => + Abort_Block_Ent), + + Build_Abort_Block + (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); + + -- Generate: + -- if not Cancelled (Bnn) then + -- + -- end if; + + Append_To (ProtE_Stmts, + Make_If_Statement (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Cancelled), Loc), + Parameter_Associations => + New_List ( + New_Reference_To (Bnn, Loc)))), + + Then_Statements => + New_Copy_List_Tree (Tstats))); + + ------------------------- + -- Task entry handling -- + ------------------------- + + -- Generate: + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + + TaskE_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals); + + -- Generate: + -- Bnn := Communication_Block (D); + + Append_To (TaskE_Stmts, + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Bnn, Loc), + Expression => + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Communication_Block), Loc), + Expression => Make_Identifier (Loc, Name_uD)))); + + -- Generate: + -- _Disp_Asynchronous_Select (, S, P'Address, D, B); + + Prepend_To (TaskE_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + Find_Prim_Op (Etype (Etype (Obj)), + Name_uDisp_Asynchronous_Select), + Loc), + Parameter_Associations => + New_List ( + New_Copy_Tree (Obj), -- + New_Reference_To (S, Loc), -- S + Make_Attribute_Reference (Loc, -- P'Address + Prefix => + New_Reference_To (P, Loc), + Attribute_Name => + Name_Address), + Make_Identifier (Loc, Name_uD), -- D + New_Reference_To (B, Loc)))); -- B + + -- Generate: + -- Abort_Defer; + + Prepend_To (TaskE_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Abort_Defer), Loc), + Parameter_Associations => + No_List)); + + -- Generate: + -- Abort_Undefer; + -- + + Cleanup_Stmts := New_Copy_List_Tree (Astats); + + Prepend_To (Cleanup_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Abort_Undefer), Loc), + Parameter_Associations => + No_List)); + + -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions + -- will generate a _clean for the additional status flag. + + -- Generate: + -- declare + -- procedure _clean is + -- begin + -- Cancel_Task_Entry_Call (U); + -- end _clean; + -- begin + -- Cleanup_Stmts + -- at end + -- _clean; + -- end; + + Cleanup_Block_Ent := Make_Temporary (Loc, 'C'); + Cleanup_Block := + Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, T); + + -- Wrap the cleanup block in an exception handling block + + -- Generate: + -- begin + -- Cleanup_Block + -- exception + -- when Abort_Signal => Abort_Undefer; + -- end; + + Abort_Block_Ent := Make_Temporary (Loc, 'A'); + + Append_To (TaskE_Stmts, + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Abort_Block_Ent)); + + Append_To (TaskE_Stmts, + Build_Abort_Block + (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); + + -- Generate: + -- if not T then + -- + -- end if; + + Append_To (TaskE_Stmts, + Make_If_Statement (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + New_Reference_To (T, Loc)), + + Then_Statements => + New_Copy_List_Tree (Tstats))); + + ---------------------------------- + -- Protected procedure handling -- + ---------------------------------- + + -- Generate: + -- ; + -- + + ProtP_Stmts := New_Copy_List_Tree (Tstats); + Prepend_To (ProtP_Stmts, New_Copy_Tree (Ecall)); + + -- Generate: + -- S := Ada.Tags.Get_Offset_Index + -- (Ada.Tags.Tag (), DT_Position (Call_Ent)); + + Conc_Typ_Stmts := + New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); + + -- Generate: + -- _Disp_Get_Prim_Op_Kind (, S, C); + + Append_To (Conc_Typ_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + Find_Prim_Op (Etype (Etype (Obj)), + Name_uDisp_Get_Prim_Op_Kind), + Loc), + Parameter_Associations => + New_List ( + New_Copy_Tree (Obj), + New_Reference_To (S, Loc), + New_Reference_To (C, Loc)))); + + -- Generate: + -- if C = POK_Procedure_Entry then + -- ProtE_Stmts + -- elsif C = POK_Task_Entry then + -- TaskE_Stmts + -- else + -- ProtP_Stmts + -- end if; + + Append_To (Conc_Typ_Stmts, + Make_If_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_POK_Protected_Entry), Loc)), + + Then_Statements => + ProtE_Stmts, + + Elsif_Parts => + New_List ( + Make_Elsif_Part (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_POK_Task_Entry), Loc)), + + Then_Statements => + TaskE_Stmts)), + + Else_Statements => + ProtP_Stmts)); + + -- Generate: + -- ; + -- + + Lim_Typ_Stmts := New_Copy_List_Tree (Tstats); + Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Ecall)); + + -- Generate: + -- if K = Ada.Tags.TK_Limited_Tagged then + -- Lim_Typ_Stmts + -- else + -- Conc_Typ_Stmts + -- end if; + + Append_To (Stmts, + Make_If_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (K, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)), + + Then_Statements => + Lim_Typ_Stmts, + + Else_Statements => + Conc_Typ_Stmts)); + + Rewrite (N, + Make_Block_Statement (Loc, + Declarations => + Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts))); + + Analyze (N); + return; + + -- Delay triggering statement processing + + else + -- Add a Delay_Block object to the parameter list of the delay + -- procedure to form the parameter list of the Wait entry call. + + Dblock_Ent := Make_Temporary (Loc, 'D'); + + Pdef := Entity (Name (Ecall)); + + if Is_RTE (Pdef, RO_CA_Delay_For) then + Enqueue_Call := + New_Reference_To (RTE (RE_Enqueue_Duration), Loc); + + elsif Is_RTE (Pdef, RO_CA_Delay_Until) then + Enqueue_Call := + New_Reference_To (RTE (RE_Enqueue_Calendar), Loc); + + else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until)); + Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_RT), Loc); + end if; + + Append_To (Parameter_Associations (Ecall), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Dblock_Ent, Loc), + Attribute_Name => Name_Unchecked_Access)); + + -- Create the inner block to protect the abortable part + + Hdle := New_List ( + Make_Implicit_Exception_Handler (Loc, + Exception_Choices => + New_List (New_Reference_To (Stand.Abort_Signal, Loc)), + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc))))); + + Prepend_To (Astats, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc))); + + Abortable_Block := + Make_Block_Statement (Loc, + Identifier => New_Reference_To (Blk_Ent, Loc), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Astats), + Has_Created_Identifier => True, + Is_Asynchronous_Call_Block => True); + + -- Append call to if Enqueue (When, DB'Unchecked_Access) then + + Rewrite (Ecall, + Make_Implicit_If_Statement (N, + Condition => Make_Function_Call (Loc, + Name => Enqueue_Call, + Parameter_Associations => Parameter_Associations (Ecall)), + Then_Statements => + New_List (Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Blk_Ent, + Label_Construct => Abortable_Block), + Abortable_Block), + Exception_Handlers => Hdle))))); + + Stmts := New_List (Ecall); + + -- Construct statement sequence for new block + + Append_To (Stmts, + Make_Implicit_If_Statement (N, + Condition => Make_Function_Call (Loc, + Name => New_Reference_To ( + RTE (RE_Timed_Out), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Dblock_Ent, Loc), + Attribute_Name => Name_Unchecked_Access))), + Then_Statements => Tstats)); + + -- The result is the new block + + Set_Entry_Cancel_Parameter (Blk_Ent, Dblock_Ent); + + Rewrite (N, + Make_Block_Statement (Loc, + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Dblock_Ent, + Aliased_Present => True, + Object_Definition => New_Reference_To ( + RTE (RE_Delay_Block), Loc))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts))); + + Analyze (N); + return; + end if; + + else + N_Orig := N; + end if; + + Extract_Entry (Ecall, Concval, Ename, Index); + Build_Simple_Entry_Call (Ecall, Concval, Ename, Index); + + Stmts := Statements (Handled_Statement_Sequence (Ecall)); + Decls := Declarations (Ecall); + + if Is_Protected_Type (Etype (Concval)) then + + -- Get the declarations of the block expanded from the entry call + + Decl := First (Decls); + while Present (Decl) + and then + (Nkind (Decl) /= N_Object_Declaration + or else not Is_RTE (Etype (Object_Definition (Decl)), + RE_Communication_Block)) + loop + Next (Decl); + end loop; + + pragma Assert (Present (Decl)); + Cancel_Param := Defining_Identifier (Decl); + + -- Change the mode of the Protected_Entry_Call call + + -- Protected_Entry_Call ( + -- Object => po._object'Access, + -- E => ; + -- Uninterpreted_Data => P'Address; + -- Mode => Asynchronous_Call; + -- Block => Bnn); + + Stmt := First (Stmts); + + -- Skip assignments to temporaries created for in-out parameters + + -- This makes unwarranted assumptions about the shape of the expanded + -- tree for the call, and should be cleaned up ??? + + while Nkind (Stmt) /= N_Procedure_Call_Statement loop + Next (Stmt); + end loop; + + Call := Stmt; + + Param := First (Parameter_Associations (Call)); + while Present (Param) + and then not Is_RTE (Etype (Param), RE_Call_Modes) + loop + Next (Param); + end loop; + + pragma Assert (Present (Param)); + Rewrite (Param, New_Reference_To (RTE (RE_Asynchronous_Call), Loc)); + Analyze (Param); + + -- Append an if statement to execute the abortable part + + -- Generate: + -- if Enqueued (Bnn) then + + Append_To (Stmts, + Make_Implicit_If_Statement (N, + Condition => Make_Function_Call (Loc, + Name => New_Reference_To ( + RTE (RE_Enqueued), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Cancel_Param, Loc))), + Then_Statements => Astats)); + + Abortable_Block := + Make_Block_Statement (Loc, + Identifier => New_Reference_To (Blk_Ent, Loc), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts), + Has_Created_Identifier => True, + Is_Asynchronous_Call_Block => True); + + -- For the VM call Update_Exception instead of Abort_Undefer. + -- See 4jexcept.ads for an explanation. + + if VM_Target = No_VM then + Target_Undefer := RE_Abort_Undefer; + else + Target_Undefer := RE_Update_Exception; + Undefer_Args := + New_List (Make_Function_Call (Loc, + Name => New_Occurrence_Of + (RTE (RE_Current_Target_Exception), Loc))); + end if; + + Stmts := New_List ( + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Blk_Ent, + Label_Construct => Abortable_Block), + Abortable_Block), + + -- exception + + Exception_Handlers => New_List ( + Make_Implicit_Exception_Handler (Loc, + + -- when Abort_Signal => + -- Abort_Undefer.all; + + Exception_Choices => + New_List (New_Reference_To (Stand.Abort_Signal, Loc)), + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + RTE (Target_Undefer), Loc), + Parameter_Associations => Undefer_Args)))))), + + -- if not Cancelled (Bnn) then + -- triggered statements + -- end if; + + Make_Implicit_If_Statement (N, + Condition => Make_Op_Not (Loc, + Right_Opnd => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Cancel_Param, Loc)))), + Then_Statements => Tstats)); + + -- Asynchronous task entry call + + else + if No (Decls) then + Decls := New_List; + end if; + + B := Make_Defining_Identifier (Loc, Name_uB); + + -- Insert declaration of B in declarations of existing block + + Prepend_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => B, + Object_Definition => New_Reference_To (Standard_Boolean, Loc))); + + Cancel_Param := Make_Defining_Identifier (Loc, Name_uC); + + -- Insert declaration of C in declarations of existing block + + Prepend_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Cancel_Param, + Object_Definition => New_Reference_To (Standard_Boolean, Loc))); + + -- Remove and save the call to Call_Simple + + Stmt := First (Stmts); + + -- Skip assignments to temporaries created for in-out parameters. + -- This makes unwarranted assumptions about the shape of the expanded + -- tree for the call, and should be cleaned up ??? + + while Nkind (Stmt) /= N_Procedure_Call_Statement loop + Next (Stmt); + end loop; + + Call := Stmt; + + -- Create the inner block to protect the abortable part + + Hdle := New_List ( + Make_Implicit_Exception_Handler (Loc, + Exception_Choices => + New_List (New_Reference_To (Stand.Abort_Signal, Loc)), + Statements => + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc))))); + + Prepend_To (Astats, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc))); + + Abortable_Block := + Make_Block_Statement (Loc, + Identifier => New_Reference_To (Blk_Ent, Loc), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Astats), + Has_Created_Identifier => True, + Is_Asynchronous_Call_Block => True); + + Insert_After (Call, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => + Blk_Ent, + Label_Construct => + Abortable_Block), + Abortable_Block), + Exception_Handlers => Hdle))); + + -- Create new call statement + + Params := Parameter_Associations (Call); + + Append_To (Params, + New_Reference_To (RTE (RE_Asynchronous_Call), Loc)); + Append_To (Params, + New_Reference_To (B, Loc)); + + Rewrite (Call, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Task_Entry_Call), Loc), + Parameter_Associations => Params)); + + -- Construct statement sequence for new block + + Append_To (Stmts, + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Not (Loc, + New_Reference_To (Cancel_Param, Loc)), + Then_Statements => Tstats)); + + -- Protected the call against abort + + Prepend_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Abort_Defer), Loc), + Parameter_Associations => Empty_List)); + end if; + + Set_Entry_Cancel_Parameter (Blk_Ent, Cancel_Param); + + -- The result is the new block + + Rewrite (N_Orig, + Make_Block_Statement (Loc, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts))); + + Analyze (N_Orig); + end Expand_N_Asynchronous_Select; + + ------------------------------------- + -- Expand_N_Conditional_Entry_Call -- + ------------------------------------- + + -- The conditional task entry call is converted to a call to + -- Task_Entry_Call: + + -- declare + -- B : Boolean; + -- P : parms := (parm, parm, parm); + + -- begin + -- Task_Entry_Call + -- (, -- Acceptor + -- , -- E + -- P'Address, -- Uninterpreted_Data + -- Conditional_Call, -- Mode + -- B); -- Rendezvous_Successful + -- parm := P.param; + -- parm := P.param; + -- ... + -- if B then + -- normal-statements + -- else + -- else-statements + -- end if; + -- end; + + -- For a description of the use of P and the assignments after the call, + -- see Expand_N_Entry_Call_Statement. Note that the entry call of the + -- conditional entry call has already been expanded (by the Expand_N_Entry + -- _Call_Statement procedure) as follows: + + -- declare + -- P : parms := (parm, parm, parm); + -- begin + -- ... info for in-out parameters + -- Call_Simple (acceptor-task, entry-index, P'Address); + -- parm := P.param; + -- parm := P.param; + -- ... + -- end; + + -- so the task at hand is to convert the latter expansion into the former + + -- The conditional protected entry call is converted to a call to + -- Protected_Entry_Call: + + -- declare + -- P : parms := (parm, parm, parm); + -- Bnn : Communications_Block; + + -- begin + -- Protected_Entry_Call + -- (po._object'Access, -- Object + -- , -- E + -- P'Address, -- Uninterpreted_Data + -- Conditional_Call, -- Mode + -- Bnn); -- Block + -- parm := P.param; + -- parm := P.param; + -- ... + -- if Cancelled (Bnn) then + -- else-statements + -- else + -- normal-statements + -- end if; + -- end; + + -- Ada 2005 (AI-345): A dispatching conditional entry call is converted + -- into: + + -- declare + -- B : Boolean := False; + -- C : Ada.Tags.Prim_Op_Kind; + -- K : Ada.Tags.Tagged_Kind := + -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag ()); + -- P : Parameters := (Param1 .. ParamN); + -- S : Integer; + + -- begin + -- if K = Ada.Tags.TK_Limited_Tagged then + -- ; + -- + + -- else + -- S := + -- Ada.Tags.Get_Offset_Index + -- (Ada.Tags.Tag (), DT_Position ()); + + -- _Disp_Conditional_Select (, S, P'Address, C, B); + + -- if C = POK_Protected_Entry + -- or else C = POK_Task_Entry + -- then + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + -- end if; + + -- if B then + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure + -- then + -- ; + -- end if; + + -- + -- else + -- + -- end if; + -- end if; + -- end; + + procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Alt : constant Node_Id := Entry_Call_Alternative (N); + Blk : Node_Id := Entry_Call_Statement (Alt); + + Actuals : List_Id; + Blk_Typ : Entity_Id; + Call : Node_Id; + Call_Ent : Entity_Id; + Conc_Typ_Stmts : List_Id; + Decl : Node_Id; + Decls : List_Id; + Formals : List_Id; + Lim_Typ_Stmts : List_Id; + N_Stats : List_Id; + Obj : Entity_Id; + Param : Node_Id; + Params : List_Id; + Stmt : Node_Id; + Stmts : List_Id; + Transient_Blk : Node_Id; + Unpack : List_Id; + + B : Entity_Id; -- Call status flag + C : Entity_Id; -- Call kind + K : Entity_Id; -- Tagged kind + P : Entity_Id; -- Parameter block + S : Entity_Id; -- Primitive operation slot + + begin + if Ada_Version >= Ada_2005 + and then Nkind (Blk) = N_Procedure_Call_Statement + then + Extract_Dispatching_Call (Blk, Call_Ent, Obj, Actuals, Formals); + + Decls := New_List; + Stmts := New_List; + + -- Call status flag processing, generate: + -- B : Boolean := False; + + B := Build_B (Loc, Decls); + + -- Call kind processing, generate: + -- C : Ada.Tags.Prim_Op_Kind; + + C := Build_C (Loc, Decls); + + -- Tagged kind processing, generate: + -- K : Ada.Tags.Tagged_Kind := + -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag ()); + + K := Build_K (Loc, Decls, Obj); + + -- Parameter block processing + + Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); + P := Parameter_Block_Pack + (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); + + -- Dispatch table slot processing, generate: + -- S : Integer; + + S := Build_S (Loc, Decls); + + -- Generate: + -- S := Ada.Tags.Get_Offset_Index + -- (Ada.Tags.Tag (), DT_Position (Call_Ent)); + + Conc_Typ_Stmts := + New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); + + -- Generate: + -- _Disp_Conditional_Select (, S, P'Address, C, B); + + Append_To (Conc_Typ_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + Find_Prim_Op (Etype (Etype (Obj)), + Name_uDisp_Conditional_Select), + Loc), + Parameter_Associations => + New_List ( + New_Copy_Tree (Obj), -- + New_Reference_To (S, Loc), -- S + Make_Attribute_Reference (Loc, -- P'Address + Prefix => + New_Reference_To (P, Loc), + Attribute_Name => + Name_Address), + New_Reference_To (C, Loc), -- C + New_Reference_To (B, Loc)))); -- B + + -- Generate: + -- if C = POK_Protected_Entry + -- or else C = POK_Task_Entry + -- then + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + -- end if; + + Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals); + + -- Generate the if statement only when the packed parameters need + -- explicit assignments to their corresponding actuals. + + if Present (Unpack) then + Append_To (Conc_Typ_Stmts, + Make_If_Statement (Loc, + + Condition => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE ( + RE_POK_Protected_Entry), Loc)), + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_POK_Task_Entry), Loc))), + + Then_Statements => + Unpack)); + end if; + + -- Generate: + -- if B then + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure + -- then + -- + -- end if; + -- + -- else + -- + -- end if; + + N_Stats := New_Copy_List_Tree (Statements (Alt)); + + Prepend_To (N_Stats, + Make_If_Statement (Loc, + Condition => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_POK_Procedure), Loc)), + + Right_Opnd => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE ( + RE_POK_Protected_Procedure), Loc)), + + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE ( + RE_POK_Task_Procedure), Loc)))), + + Then_Statements => + New_List (Blk))); + + Append_To (Conc_Typ_Stmts, + Make_If_Statement (Loc, + Condition => New_Reference_To (B, Loc), + Then_Statements => N_Stats, + Else_Statements => Else_Statements (N))); + + -- Generate: + -- ; + -- + + Lim_Typ_Stmts := New_Copy_List_Tree (Statements (Alt)); + Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk)); + + -- Generate: + -- if K = Ada.Tags.TK_Limited_Tagged then + -- Lim_Typ_Stmts + -- else + -- Conc_Typ_Stmts + -- end if; + + Append_To (Stmts, + Make_If_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (K, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)), + + Then_Statements => + Lim_Typ_Stmts, + + Else_Statements => + Conc_Typ_Stmts)); + + Rewrite (N, + Make_Block_Statement (Loc, + Declarations => + Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts))); + + -- As described above, The entry alternative is transformed into a + -- block that contains the gnulli call, and possibly assignment + -- statements for in-out parameters. The gnulli call may itself be + -- rewritten into a transient block if some unconstrained parameters + -- require it. We need to retrieve the call to complete its parameter + -- list. + + else + Transient_Blk := + First_Real_Statement (Handled_Statement_Sequence (Blk)); + + if Present (Transient_Blk) + and then Nkind (Transient_Blk) = N_Block_Statement + then + Blk := Transient_Blk; + end if; + + Stmts := Statements (Handled_Statement_Sequence (Blk)); + Stmt := First (Stmts); + while Nkind (Stmt) /= N_Procedure_Call_Statement loop + Next (Stmt); + end loop; + + Call := Stmt; + Params := Parameter_Associations (Call); + + if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then + + -- Substitute Conditional_Entry_Call for Simple_Call parameter + + Param := First (Params); + while Present (Param) + and then not Is_RTE (Etype (Param), RE_Call_Modes) + loop + Next (Param); + end loop; + + pragma Assert (Present (Param)); + Rewrite (Param, New_Reference_To (RTE (RE_Conditional_Call), Loc)); + + Analyze (Param); + + -- Find the Communication_Block parameter for the call to the + -- Cancelled function. + + Decl := First (Declarations (Blk)); + while Present (Decl) + and then not Is_RTE (Etype (Object_Definition (Decl)), + RE_Communication_Block) + loop + Next (Decl); + end loop; + + -- Add an if statement to execute the else part if the call + -- does not succeed (as indicated by the Cancelled predicate). + + Append_To (Stmts, + Make_Implicit_If_Statement (N, + Condition => Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Cancelled), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Defining_Identifier (Decl), Loc))), + Then_Statements => Else_Statements (N), + Else_Statements => Statements (Alt))); + + else + B := Make_Defining_Identifier (Loc, Name_uB); + + -- Insert declaration of B in declarations of existing block + + if No (Declarations (Blk)) then + Set_Declarations (Blk, New_List); + end if; + + Prepend_To (Declarations (Blk), + Make_Object_Declaration (Loc, + Defining_Identifier => B, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc))); + + -- Create new call statement + + Append_To (Params, + New_Reference_To (RTE (RE_Conditional_Call), Loc)); + Append_To (Params, New_Reference_To (B, Loc)); + + Rewrite (Call, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc), + Parameter_Associations => Params)); + + -- Construct statement sequence for new block + + Append_To (Stmts, + Make_Implicit_If_Statement (N, + Condition => New_Reference_To (B, Loc), + Then_Statements => Statements (Alt), + Else_Statements => Else_Statements (N))); + end if; + + -- The result is the new block + + Rewrite (N, + Make_Block_Statement (Loc, + Declarations => Declarations (Blk), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts))); + end if; + + Analyze (N); + end Expand_N_Conditional_Entry_Call; + + --------------------------------------- + -- Expand_N_Delay_Relative_Statement -- + --------------------------------------- + + -- Delay statement is implemented as a procedure call to Delay_For + -- defined in Ada.Calendar.Delays in order to reduce the overhead of + -- simple delays imposed by the use of Protected Objects. + + procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + begin + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RO_CA_Delay_For), Loc), + Parameter_Associations => New_List (Expression (N)))); + Analyze (N); + end Expand_N_Delay_Relative_Statement; + + ------------------------------------ + -- Expand_N_Delay_Until_Statement -- + ------------------------------------ + + -- Delay Until statement is implemented as a procedure call to + -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays. + + procedure Expand_N_Delay_Until_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : Entity_Id; + + begin + if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then + Typ := RTE (RO_CA_Delay_Until); + else + Typ := RTE (RO_RT_Delay_Until); + end if; + + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Typ, Loc), + Parameter_Associations => New_List (Expression (N)))); + + Analyze (N); + end Expand_N_Delay_Until_Statement; + + ------------------------- + -- Expand_N_Entry_Body -- + ------------------------- + + procedure Expand_N_Entry_Body (N : Node_Id) is + begin + -- Associate discriminals with the next protected operation body to be + -- expanded. + + if Present (Next_Protected_Operation (N)) then + Set_Discriminals (Parent (Current_Scope)); + end if; + end Expand_N_Entry_Body; + + ----------------------------------- + -- Expand_N_Entry_Call_Statement -- + ----------------------------------- + + -- An entry call is expanded into GNARLI calls to implement a simple entry + -- call (see Build_Simple_Entry_Call). + + procedure Expand_N_Entry_Call_Statement (N : Node_Id) is + Concval : Node_Id; + Ename : Node_Id; + Index : Node_Id; + + begin + if No_Run_Time_Mode then + Error_Msg_CRT ("entry call", N); + return; + end if; + + -- If this entry call is part of an asynchronous select, don't expand it + -- here; it will be expanded with the select statement. Don't expand + -- timed entry calls either, as they are translated into asynchronous + -- entry calls. + + -- ??? This whole approach is questionable; it may be better to go back + -- to allowing the expansion to take place and then attempting to fix it + -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out + -- whether the expanded call is on a task or protected entry. + + if (Nkind (Parent (N)) /= N_Triggering_Alternative + or else N /= Triggering_Statement (Parent (N))) + and then (Nkind (Parent (N)) /= N_Entry_Call_Alternative + or else N /= Entry_Call_Statement (Parent (N)) + or else Nkind (Parent (Parent (N))) /= N_Timed_Entry_Call) + then + Extract_Entry (N, Concval, Ename, Index); + Build_Simple_Entry_Call (N, Concval, Ename, Index); + end if; + end Expand_N_Entry_Call_Statement; + + -------------------------------- + -- Expand_N_Entry_Declaration -- + -------------------------------- + + -- If there are parameters, then first, each of the formals is marked by + -- setting Is_Entry_Formal. Next a record type is built which is used to + -- hold the parameter values. The name of this record type is entryP where + -- entry is the name of the entry, with an additional corresponding access + -- type called entryPA. The record type has matching components for each + -- formal (the component names are the same as the formal names). For + -- elementary types, the component type matches the formal type. For + -- composite types, an access type is declared (with the name formalA) + -- which designates the formal type, and the type of the component is this + -- access type. Finally the Entry_Component of each formal is set to + -- reference the corresponding record component. + + procedure Expand_N_Entry_Declaration (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Entry_Ent : constant Entity_Id := Defining_Identifier (N); + Components : List_Id; + Formal : Node_Id; + Ftype : Entity_Id; + Last_Decl : Node_Id; + Component : Entity_Id; + Ctype : Entity_Id; + Decl : Node_Id; + Rec_Ent : Entity_Id; + Acc_Ent : Entity_Id; + + begin + Formal := First_Formal (Entry_Ent); + Last_Decl := N; + + -- Most processing is done only if parameters are present + + if Present (Formal) then + Components := New_List; + + -- Loop through formals + + while Present (Formal) loop + Set_Is_Entry_Formal (Formal); + Component := + Make_Defining_Identifier (Sloc (Formal), Chars (Formal)); + Set_Entry_Component (Formal, Component); + Set_Entry_Formal (Component, Formal); + Ftype := Etype (Formal); + + -- Declare new access type and then append + + Ctype := Make_Temporary (Loc, 'A'); + + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ctype, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Constant_Present => Ekind (Formal) = E_In_Parameter, + Subtype_Indication => New_Reference_To (Ftype, Loc))); + + Insert_After (Last_Decl, Decl); + Last_Decl := Decl; + + Append_To (Components, + Make_Component_Declaration (Loc, + Defining_Identifier => Component, + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => New_Reference_To (Ctype, Loc)))); + + Next_Formal_With_Extras (Formal); + end loop; + + -- Create the Entry_Parameter_Record declaration + + Rec_Ent := Make_Temporary (Loc, 'P'); + + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Rec_Ent, + Type_Definition => + Make_Record_Definition (Loc, + Component_List => + Make_Component_List (Loc, + Component_Items => Components))); + + Insert_After (Last_Decl, Decl); + Last_Decl := Decl; + + -- Construct and link in the corresponding access type + + Acc_Ent := Make_Temporary (Loc, 'A'); + + Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent); + + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Acc_Ent, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => New_Reference_To (Rec_Ent, Loc))); + + Insert_After (Last_Decl, Decl); + Last_Decl := Decl; + end if; + end Expand_N_Entry_Declaration; + + ----------------------------- + -- Expand_N_Protected_Body -- + ----------------------------- + + -- Protected bodies are expanded to the completion of the subprograms + -- created for the corresponding protected type. These are a protected and + -- unprotected version of each protected subprogram in the object, a + -- function to calculate each entry barrier, and a procedure to execute the + -- sequence of statements of each protected entry body. For example, for + -- protected type ptype: + + -- function entB + -- (O : System.Address; + -- E : Protected_Entry_Index) + -- return Boolean + -- is + -- + -- + -- begin + -- return ; + -- end entB; + + -- procedure pprocN (_object : in out poV;...) is + -- + -- + -- begin + -- + -- end pprocN; + + -- procedure pprocP (_object : in out poV;...) is + -- procedure _clean is + -- Pn : Boolean; + -- begin + -- ptypeS (_object, Pn); + -- Unlock (_object._object'Access); + -- Abort_Undefer.all; + -- end _clean; + + -- begin + -- Abort_Defer.all; + -- Lock (_object._object'Access); + -- pprocN (_object;...); + -- at end + -- _clean; + -- end pproc; + + -- function pfuncN (_object : poV;...) return Return_Type is + -- + -- + -- begin + -- + -- end pfuncN; + + -- function pfuncP (_object : poV) return Return_Type is + -- procedure _clean is + -- begin + -- Unlock (_object._object'Access); + -- Abort_Undefer.all; + -- end _clean; + + -- begin + -- Abort_Defer.all; + -- Lock (_object._object'Access); + -- return pfuncN (_object); + + -- at end + -- _clean; + -- end pfunc; + + -- procedure entE + -- (O : System.Address; + -- P : System.Address; + -- E : Protected_Entry_Index) + -- is + -- + -- + -- type poVP is access poV; + -- _Object : ptVP := ptVP!(O); + + -- begin + -- begin + -- + -- Complete_Entry_Body (_Object._Object); + -- exception + -- when all others => + -- Exceptional_Complete_Entry_Body ( + -- _Object._Object, Get_GNAT_Exception); + -- end; + -- end entE; + + -- The type poV is the record created for the protected type to hold + -- the state of the protected object. + + procedure Expand_N_Protected_Body (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Pid : constant Entity_Id := Corresponding_Spec (N); + + Current_Node : Node_Id; + Disp_Op_Body : Node_Id; + New_Op_Body : Node_Id; + Num_Entries : Natural := 0; + Op_Body : Node_Id; + Op_Id : Entity_Id; + + Chain : Entity_Id := Empty; + -- Finalization chain that may be attached to new body + + function Build_Dispatching_Subprogram_Body + (N : Node_Id; + Pid : Node_Id; + Prot_Bod : Node_Id) return Node_Id; + -- Build a dispatching version of the protected subprogram body. The + -- newly generated subprogram contains a call to the original protected + -- body. The following code is generated: + -- + -- function (Param1 .. ParamN) return + -- is + -- begin + -- return P (Param1 .. ParamN); + -- end ; + -- + -- or + -- + -- procedure (Param1 .. ParamN) is + -- begin + -- P (Param1 .. ParamN); + -- end + + --------------------------------------- + -- Build_Dispatching_Subprogram_Body -- + --------------------------------------- + + function Build_Dispatching_Subprogram_Body + (N : Node_Id; + Pid : Node_Id; + Prot_Bod : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Actuals : List_Id; + Formal : Node_Id; + Spec : Node_Id; + Stmts : List_Id; + + begin + -- Generate a specification without a letter suffix in order to + -- override an interface function or procedure. + + Spec := Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode); + + -- The formal parameters become the actuals of the protected function + -- or procedure call. + + Actuals := New_List; + Formal := First (Parameter_Specifications (Spec)); + while Present (Formal) loop + Append_To (Actuals, + Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); + + Next (Formal); + end loop; + + if Nkind (Spec) = N_Procedure_Specification then + Stmts := + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (Corresponding_Spec (Prot_Bod), Loc), + Parameter_Associations => Actuals)); + else + pragma Assert (Nkind (Spec) = N_Function_Specification); + + Stmts := + New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => + New_Reference_To (Corresponding_Spec (Prot_Bod), Loc), + Parameter_Associations => Actuals))); + end if; + + return + Make_Subprogram_Body (Loc, + Declarations => Empty_List, + Specification => Spec, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts)); + end Build_Dispatching_Subprogram_Body; + + -- Start of processing for Expand_N_Protected_Body + + begin + if No_Run_Time_Mode then + Error_Msg_CRT ("protected body", N); + return; + end if; + + -- This is the proper body corresponding to a stub. The declarations + -- must be inserted at the point of the stub, which in turn is in the + -- declarative part of the parent unit. + + if Nkind (Parent (N)) = N_Subunit then + Current_Node := Corresponding_Stub (Parent (N)); + else + Current_Node := N; + end if; + + Op_Body := First (Declarations (N)); + + -- The protected body is replaced with the bodies of its + -- protected operations, and the declarations for internal objects + -- that may have been created for entry family bounds. + + Rewrite (N, Make_Null_Statement (Sloc (N))); + Analyze (N); + + while Present (Op_Body) loop + case Nkind (Op_Body) is + when N_Subprogram_Declaration => + null; + + when N_Subprogram_Body => + + -- Do not create bodies for eliminated operations + + if not Is_Eliminated (Defining_Entity (Op_Body)) + and then not Is_Eliminated (Corresponding_Spec (Op_Body)) + then + New_Op_Body := + Build_Unprotected_Subprogram_Body (Op_Body, Pid); + + -- Propagate the finalization chain to the new body. In the + -- unlikely event that the subprogram contains a declaration + -- or allocator for an object that requires finalization, + -- the corresponding chain is created when analyzing the + -- body, and attached to its entity. This entity is not + -- further elaborated, and so the chain properly belongs to + -- the newly created subprogram body. + + Chain := + Finalization_Chain_Entity (Defining_Entity (Op_Body)); + + if Present (Chain) then + Set_Finalization_Chain_Entity + (Protected_Body_Subprogram + (Corresponding_Spec (Op_Body)), Chain); + Set_Analyzed + (Handled_Statement_Sequence (New_Op_Body), False); + end if; + + Insert_After (Current_Node, New_Op_Body); + Current_Node := New_Op_Body; + Analyze (New_Op_Body); + + -- Build the corresponding protected operation. It may + -- appear that this is needed only if this is a visible + -- operation of the type, or if it is an interrupt handler, + -- and this was the strategy used previously in GNAT. + -- However, the operation may be exported through a 'Access + -- to an external caller. This is the common idiom in code + -- that uses the Ada 2005 Timing_Events package. As a result + -- we need to produce the protected body for both visible + -- and private operations, as well as operations that only + -- have a body in the source, and for which we create a + -- declaration in the protected body itself. + + if Present (Corresponding_Spec (Op_Body)) then + New_Op_Body := + Build_Protected_Subprogram_Body ( + Op_Body, Pid, Specification (New_Op_Body)); + + Insert_After (Current_Node, New_Op_Body); + Analyze (New_Op_Body); + + Current_Node := New_Op_Body; + + -- Generate an overriding primitive operation body for + -- this subprogram if the protected type implements an + -- interface. + + if Ada_Version >= Ada_2005 + and then + Present (Interfaces (Corresponding_Record_Type (Pid))) + then + Disp_Op_Body := + Build_Dispatching_Subprogram_Body + (Op_Body, Pid, New_Op_Body); + + Insert_After (Current_Node, Disp_Op_Body); + Analyze (Disp_Op_Body); + + Current_Node := Disp_Op_Body; + end if; + end if; + end if; + + when N_Entry_Body => + Op_Id := Defining_Identifier (Op_Body); + Num_Entries := Num_Entries + 1; + + New_Op_Body := Build_Protected_Entry (Op_Body, Op_Id, Pid); + + Insert_After (Current_Node, New_Op_Body); + Current_Node := New_Op_Body; + Analyze (New_Op_Body); + + when N_Implicit_Label_Declaration => + null; + + when N_Itype_Reference => + Insert_After (Current_Node, New_Copy (Op_Body)); + + when N_Freeze_Entity => + New_Op_Body := New_Copy (Op_Body); + + if Present (Entity (Op_Body)) + and then Freeze_Node (Entity (Op_Body)) = Op_Body + then + Set_Freeze_Node (Entity (Op_Body), New_Op_Body); + end if; + + Insert_After (Current_Node, New_Op_Body); + Current_Node := New_Op_Body; + Analyze (New_Op_Body); + + when N_Pragma => + New_Op_Body := New_Copy (Op_Body); + Insert_After (Current_Node, New_Op_Body); + Current_Node := New_Op_Body; + Analyze (New_Op_Body); + + when N_Object_Declaration => + pragma Assert (not Comes_From_Source (Op_Body)); + New_Op_Body := New_Copy (Op_Body); + Insert_After (Current_Node, New_Op_Body); + Current_Node := New_Op_Body; + Analyze (New_Op_Body); + + when others => + raise Program_Error; + + end case; + + Next (Op_Body); + end loop; + + -- Finally, create the body of the function that maps an entry index + -- into the corresponding body index, except when there is no entry, or + -- in a Ravenscar-like profile. + + if Corresponding_Runtime_Package (Pid) = + System_Tasking_Protected_Objects_Entries + then + New_Op_Body := Build_Find_Body_Index (Pid); + Insert_After (Current_Node, New_Op_Body); + Current_Node := New_Op_Body; + Analyze (New_Op_Body); + end if; + + -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the + -- protected body. At this point all wrapper specs have been created, + -- frozen and included in the dispatch table for the protected type. + + if Ada_Version >= Ada_2005 then + Build_Wrapper_Bodies (Loc, Pid, Current_Node); + end if; + end Expand_N_Protected_Body; + + ----------------------------------------- + -- Expand_N_Protected_Type_Declaration -- + ----------------------------------------- + + -- First we create a corresponding record type declaration used to + -- represent values of this protected type. + -- The general form of this type declaration is + + -- type poV (discriminants) is record + -- _Object : aliased Protection + -- [( [, ])]; + -- [entry_family : array (bounds) of Void;] + -- + -- end record; + + -- The discriminants are present only if the corresponding protected type + -- has discriminants, and they exactly mirror the protected type + -- discriminants. The private data fields similarly mirror the private + -- declarations of the protected type. + + -- The Object field is always present. It contains RTS specific data used + -- to control the protected object. It is declared as Aliased so that it + -- can be passed as a pointer to the RTS. This allows the protected record + -- to be referenced within RTS data structures. An appropriate Protection + -- type and discriminant are generated. + + -- The Service field is present for protected objects with entries. It + -- contains sufficient information to allow the entry service procedure for + -- this object to be called when the object is not known till runtime. + + -- One entry_family component is present for each entry family in the + -- task definition (see Expand_N_Task_Type_Declaration). + + -- When a protected object is declared, an instance of the protected type + -- value record is created. The elaboration of this declaration creates the + -- correct bounds for the entry families, and also evaluates the priority + -- expression if needed. The initialization routine for the protected type + -- itself then calls Initialize_Protection with appropriate parameters to + -- initialize the value of the Task_Id field. Install_Handlers may be also + -- called if a pragma Attach_Handler applies. + + -- Note: this record is passed to the subprograms created by the expansion + -- of protected subprograms and entries. It is an in parameter to protected + -- functions and an in out parameter to procedures and entry bodies. The + -- Entity_Id for this created record type is placed in the + -- Corresponding_Record_Type field of the associated protected type entity. + + -- Next we create a procedure specifications for protected subprograms and + -- entry bodies. For each protected subprograms two subprograms are + -- created, an unprotected and a protected version. The unprotected version + -- is called from within other operations of the same protected object. + + -- We also build the call to register the procedure if a pragma + -- Interrupt_Handler applies. + + -- A single subprogram is created to service all entry bodies; it has an + -- additional boolean out parameter indicating that the previous entry call + -- made by the current task was serviced immediately, i.e. not by proxy. + -- The O parameter contains a pointer to a record object of the type + -- described above. An untyped interface is used here to allow this + -- procedure to be called in places where the type of the object to be + -- serviced is not known. This must be done, for example, when a call that + -- may have been requeued is cancelled; the corresponding object must be + -- serviced, but which object that is not known till runtime. + + -- procedure ptypeS + -- (O : System.Address; P : out Boolean); + -- procedure pprocN (_object : in out poV); + -- procedure pproc (_object : in out poV); + -- function pfuncN (_object : poV); + -- function pfunc (_object : poV); + -- ... + + -- Note that this must come after the record type declaration, since + -- the specs refer to this type. + + procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Prot_Typ : constant Entity_Id := Defining_Identifier (N); + + Pdef : constant Node_Id := Protected_Definition (N); + -- This contains two lists; one for visible and one for private decls + + Rec_Decl : Node_Id; + Cdecls : List_Id; + Discr_Map : constant Elist_Id := New_Elmt_List; + Priv : Node_Id; + New_Priv : Node_Id; + Comp : Node_Id; + Comp_Id : Entity_Id; + Sub : Node_Id; + Current_Node : Node_Id := N; + Bdef : Entity_Id := Empty; -- avoid uninit warning + Edef : Entity_Id := Empty; -- avoid uninit warning + Entries_Aggr : Node_Id; + Body_Id : Entity_Id; + Body_Arr : Node_Id; + E_Count : Int; + Object_Comp : Node_Id; + + procedure Check_Inlining (Subp : Entity_Id); + -- If the original operation has a pragma Inline, propagate the flag + -- to the internal body, for possible inlining later on. The source + -- operation is invisible to the back-end and is never actually called. + + function Static_Component_Size (Comp : Entity_Id) return Boolean; + -- When compiling under the Ravenscar profile, private components must + -- have a static size, or else a protected object will require heap + -- allocation, violating the corresponding restriction. It is preferable + -- to make this check here, because it provides a better error message + -- than the back-end, which refers to the object as a whole. + + procedure Register_Handler; + -- For a protected operation that is an interrupt handler, add the + -- freeze action that will register it as such. + + -------------------- + -- Check_Inlining -- + -------------------- + + procedure Check_Inlining (Subp : Entity_Id) is + begin + if Is_Inlined (Subp) then + Set_Is_Inlined (Protected_Body_Subprogram (Subp)); + Set_Is_Inlined (Subp, False); + end if; + end Check_Inlining; + + --------------------------------- + -- Check_Static_Component_Size -- + --------------------------------- + + function Static_Component_Size (Comp : Entity_Id) return Boolean is + Typ : constant Entity_Id := Etype (Comp); + C : Entity_Id; + + begin + if Is_Scalar_Type (Typ) then + return True; + + elsif Is_Array_Type (Typ) then + return Compile_Time_Known_Bounds (Typ); + + elsif Is_Record_Type (Typ) then + C := First_Component (Typ); + while Present (C) loop + if not Static_Component_Size (C) then + return False; + end if; + + Next_Component (C); + end loop; + + return True; + + -- Any other types will be checked by the back-end + + else + return True; + end if; + end Static_Component_Size; + + ---------------------- + -- Register_Handler -- + ---------------------- + + procedure Register_Handler is + + -- All semantic checks already done in Sem_Prag + + Prot_Proc : constant Entity_Id := + Defining_Unit_Name + (Specification (Current_Node)); + + Proc_Address : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prot_Proc, Loc), + Attribute_Name => Name_Address); + + RTS_Call : constant Entity_Id := + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + RTE (RE_Register_Interrupt_Handler), Loc), + Parameter_Associations => + New_List (Proc_Address)); + begin + Append_Freeze_Action (Prot_Proc, RTS_Call); + end Register_Handler; + + -- Start of processing for Expand_N_Protected_Type_Declaration + + begin + if Present (Corresponding_Record_Type (Prot_Typ)) then + return; + else + Rec_Decl := Build_Corresponding_Record (N, Prot_Typ, Loc); + end if; + + Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl))); + + Qualify_Entity_Names (N); + + -- If the type has discriminants, their occurrences in the declaration + -- have been replaced by the corresponding discriminals. For components + -- that are constrained by discriminants, their homologues in the + -- corresponding record type must refer to the discriminants of that + -- record, so we must apply a new renaming to subtypes_indications: + + -- protected discriminant => discriminal => record discriminant + + -- This replacement is not applied to default expressions, for which + -- the discriminal is correct. + + if Has_Discriminants (Prot_Typ) then + declare + Disc : Entity_Id; + Decl : Node_Id; + + begin + Disc := First_Discriminant (Prot_Typ); + Decl := First (Discriminant_Specifications (Rec_Decl)); + while Present (Disc) loop + Append_Elmt (Discriminal (Disc), Discr_Map); + Append_Elmt (Defining_Identifier (Decl), Discr_Map); + Next_Discriminant (Disc); + Next (Decl); + end loop; + end; + end if; + + -- Fill in the component declarations + + -- Add components for entry families. For each entry family, create an + -- anonymous type declaration with the same size, and analyze the type. + + Collect_Entry_Families (Loc, Cdecls, Current_Node, Prot_Typ); + + -- Prepend the _Object field with the right type to the component list. + -- We need to compute the number of entries, and in some cases the + -- number of Attach_Handler pragmas. + + declare + Ritem : Node_Id; + Num_Attach_Handler : Int := 0; + Protection_Subtype : Node_Id; + Entry_Count_Expr : constant Node_Id := + Build_Entry_Count_Expression + (Prot_Typ, Cdecls, Loc); + + begin + -- Could this be simplified using Corresponding_Runtime_Package??? + + if Has_Attach_Handler (Prot_Typ) then + Ritem := First_Rep_Item (Prot_Typ); + while Present (Ritem) loop + if Nkind (Ritem) = N_Pragma + and then Pragma_Name (Ritem) = Name_Attach_Handler + then + Num_Attach_Handler := Num_Attach_Handler + 1; + end if; + + Next_Rep_Item (Ritem); + end loop; + + if Restricted_Profile then + if Has_Entries (Prot_Typ) then + Protection_Subtype := + New_Reference_To (RTE (RE_Protection_Entry), Loc); + else + Protection_Subtype := + New_Reference_To (RTE (RE_Protection), Loc); + end if; + else + Protection_Subtype := + Make_Subtype_Indication + (Sloc => Loc, + Subtype_Mark => + New_Reference_To + (RTE (RE_Static_Interrupt_Protection), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint ( + Sloc => Loc, + Constraints => New_List ( + Entry_Count_Expr, + Make_Integer_Literal (Loc, Num_Attach_Handler)))); + end if; + + elsif Has_Interrupt_Handler (Prot_Typ) then + Protection_Subtype := + Make_Subtype_Indication ( + Sloc => Loc, + Subtype_Mark => New_Reference_To + (RTE (RE_Dynamic_Interrupt_Protection), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint ( + Sloc => Loc, + Constraints => New_List (Entry_Count_Expr))); + + -- Type has explicit entries or generated primitive entry wrappers + + elsif Has_Entries (Prot_Typ) + or else (Ada_Version >= Ada_2005 + and then Present (Interface_List (N))) + then + case Corresponding_Runtime_Package (Prot_Typ) is + when System_Tasking_Protected_Objects_Entries => + Protection_Subtype := + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Protection_Entries), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint ( + Sloc => Loc, + Constraints => New_List (Entry_Count_Expr))); + + when System_Tasking_Protected_Objects_Single_Entry => + Protection_Subtype := + New_Reference_To (RTE (RE_Protection_Entry), Loc); + + when others => + raise Program_Error; + end case; + + else + Protection_Subtype := New_Reference_To (RTE (RE_Protection), Loc); + end if; + + Object_Comp := + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uObject), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => True, + Subtype_Indication => Protection_Subtype)); + end; + + pragma Assert (Present (Pdef)); + + -- Add private field components + + if Present (Private_Declarations (Pdef)) then + Priv := First (Private_Declarations (Pdef)); + + while Present (Priv) loop + + if Nkind (Priv) = N_Component_Declaration then + if not Static_Component_Size (Defining_Identifier (Priv)) then + + -- When compiling for a restricted profile, the private + -- components must have a static size. If not, this is an + -- error for a single protected declaration, and rates a + -- warning on a protected type declaration. + + if not Comes_From_Source (Prot_Typ) then + Check_Restriction (No_Implicit_Heap_Allocations, Priv); + + elsif Restriction_Active (No_Implicit_Heap_Allocations) then + Error_Msg_N ("component has non-static size?", Priv); + Error_Msg_NE + ("\creation of protected object of type& will violate" + & " restriction No_Implicit_Heap_Allocations?", + Priv, Prot_Typ); + end if; + end if; + + -- The component definition consists of a subtype indication, + -- or (in Ada 2005) an access definition. Make a copy of the + -- proper definition. + + declare + Old_Comp : constant Node_Id := Component_Definition (Priv); + Oent : constant Entity_Id := Defining_Identifier (Priv); + New_Comp : Node_Id; + Nent : constant Entity_Id := + Make_Defining_Identifier (Sloc (Oent), + Chars => Chars (Oent)); + + begin + if Present (Subtype_Indication (Old_Comp)) then + New_Comp := + Make_Component_Definition (Sloc (Oent), + Aliased_Present => False, + Subtype_Indication => + New_Copy_Tree (Subtype_Indication (Old_Comp), + Discr_Map)); + else + New_Comp := + Make_Component_Definition (Sloc (Oent), + Aliased_Present => False, + Access_Definition => + New_Copy_Tree (Access_Definition (Old_Comp), + Discr_Map)); + end if; + + New_Priv := + Make_Component_Declaration (Loc, + Defining_Identifier => Nent, + Component_Definition => New_Comp, + Expression => Expression (Priv)); + + Set_Has_Per_Object_Constraint (Nent, + Has_Per_Object_Constraint (Oent)); + + Append_To (Cdecls, New_Priv); + end; + + elsif Nkind (Priv) = N_Subprogram_Declaration then + + -- Make the unprotected version of the subprogram available + -- for expansion of intra object calls. There is need for + -- a protected version only if the subprogram is an interrupt + -- handler, otherwise this operation can only be called from + -- within the body. + + Sub := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Protected_Sub_Specification + (Priv, Prot_Typ, Unprotected_Mode)); + + Insert_After (Current_Node, Sub); + Analyze (Sub); + + Set_Protected_Body_Subprogram + (Defining_Unit_Name (Specification (Priv)), + Defining_Unit_Name (Specification (Sub))); + Check_Inlining (Defining_Unit_Name (Specification (Priv))); + Current_Node := Sub; + + Sub := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Protected_Sub_Specification + (Priv, Prot_Typ, Protected_Mode)); + + Insert_After (Current_Node, Sub); + Analyze (Sub); + Current_Node := Sub; + + if Is_Interrupt_Handler + (Defining_Unit_Name (Specification (Priv))) + then + if not Restricted_Profile then + Register_Handler; + end if; + end if; + end if; + + Next (Priv); + end loop; + end if; + + -- Put the _Object component after the private component so that it + -- be finalized early as required by 9.4 (20) + + Append_To (Cdecls, Object_Comp); + + Insert_After (Current_Node, Rec_Decl); + Current_Node := Rec_Decl; + + -- Analyze the record declaration immediately after construction, + -- because the initialization procedure is needed for single object + -- declarations before the next entity is analyzed (the freeze call + -- that generates this initialization procedure is found below). + + Analyze (Rec_Decl, Suppress => All_Checks); + + -- Ada 2005 (AI-345): Construct the primitive entry wrappers before + -- the corresponding record is frozen. If any wrappers are generated, + -- Current_Node is updated accordingly. + + if Ada_Version >= Ada_2005 then + Build_Wrapper_Specs (Loc, Prot_Typ, Current_Node); + end if; + + -- Collect pointers to entry bodies and their barriers, to be placed + -- in the Entry_Bodies_Array for the type. For each entry/family we + -- add an expression to the aggregate which is the initial value of + -- this array. The array is declared after all protected subprograms. + + if Has_Entries (Prot_Typ) then + Entries_Aggr := Make_Aggregate (Loc, Expressions => New_List); + else + Entries_Aggr := Empty; + end if; + + -- Build two new procedure specifications for each protected subprogram; + -- one to call from outside the object and one to call from inside. + -- Build a barrier function and an entry body action procedure + -- specification for each protected entry. Initialize the entry body + -- array. If subprogram is flagged as eliminated, do not generate any + -- internal operations. + + E_Count := 0; + + Comp := First (Visible_Declarations (Pdef)); + + while Present (Comp) loop + if Nkind (Comp) = N_Subprogram_Declaration then + Sub := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Protected_Sub_Specification + (Comp, Prot_Typ, Unprotected_Mode)); + + Insert_After (Current_Node, Sub); + Analyze (Sub); + + Set_Protected_Body_Subprogram + (Defining_Unit_Name (Specification (Comp)), + Defining_Unit_Name (Specification (Sub))); + Check_Inlining (Defining_Unit_Name (Specification (Comp))); + + -- Make the protected version of the subprogram available for + -- expansion of external calls. + + Current_Node := Sub; + + Sub := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Protected_Sub_Specification + (Comp, Prot_Typ, Protected_Mode)); + + Insert_After (Current_Node, Sub); + Analyze (Sub); + + Current_Node := Sub; + + -- Generate an overriding primitive operation specification for + -- this subprogram if the protected type implements an interface. + + if Ada_Version >= Ada_2005 + and then + Present (Interfaces (Corresponding_Record_Type (Prot_Typ))) + then + Sub := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Protected_Sub_Specification + (Comp, Prot_Typ, Dispatching_Mode)); + + Insert_After (Current_Node, Sub); + Analyze (Sub); + + Current_Node := Sub; + end if; + + -- If a pragma Interrupt_Handler applies, build and add a call to + -- Register_Interrupt_Handler to the freezing actions of the + -- protected version (Current_Node) of the subprogram: + + -- system.interrupts.register_interrupt_handler + -- (prot_procP'address); + + if not Restricted_Profile + and then Is_Interrupt_Handler + (Defining_Unit_Name (Specification (Comp))) + then + Register_Handler; + end if; + + elsif Nkind (Comp) = N_Entry_Declaration then + E_Count := E_Count + 1; + Comp_Id := Defining_Identifier (Comp); + + Edef := + Make_Defining_Identifier (Loc, + Build_Selected_Name (Prot_Typ, Comp_Id, 'E')); + Sub := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Protected_Entry_Specification (Loc, Edef, Comp_Id)); + + Insert_After (Current_Node, Sub); + Analyze (Sub); + + -- build wrapper procedure for pre/postconditions. + + Build_PPC_Wrapper (Comp_Id, N); + + Set_Protected_Body_Subprogram + (Defining_Identifier (Comp), + Defining_Unit_Name (Specification (Sub))); + + Current_Node := Sub; + + Bdef := + Make_Defining_Identifier (Loc, + Chars => Build_Selected_Name (Prot_Typ, Comp_Id, 'B')); + Sub := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Barrier_Function_Specification (Loc, Bdef)); + + Insert_After (Current_Node, Sub); + Analyze (Sub); + Set_Protected_Body_Subprogram (Bdef, Bdef); + Set_Barrier_Function (Comp_Id, Bdef); + Set_Scope (Bdef, Scope (Comp_Id)); + Current_Node := Sub; + + -- Collect pointers to the protected subprogram and the barrier + -- of the current entry, for insertion into Entry_Bodies_Array. + + Append ( + Make_Aggregate (Loc, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Bdef, Loc), + Attribute_Name => Name_Unrestricted_Access), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Edef, Loc), + Attribute_Name => Name_Unrestricted_Access))), + Expressions (Entries_Aggr)); + + end if; + + Next (Comp); + end loop; + + -- If there are some private entry declarations, expand it as if they + -- were visible entries. + + if Present (Private_Declarations (Pdef)) then + Comp := First (Private_Declarations (Pdef)); + while Present (Comp) loop + if Nkind (Comp) = N_Entry_Declaration then + E_Count := E_Count + 1; + Comp_Id := Defining_Identifier (Comp); + + Edef := + Make_Defining_Identifier (Loc, + Build_Selected_Name (Prot_Typ, Comp_Id, 'E')); + Sub := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Protected_Entry_Specification (Loc, Edef, Comp_Id)); + + Insert_After (Current_Node, Sub); + Analyze (Sub); + + Set_Protected_Body_Subprogram + (Defining_Identifier (Comp), + Defining_Unit_Name (Specification (Sub))); + + Current_Node := Sub; + + Bdef := + Make_Defining_Identifier (Loc, + Chars => Build_Selected_Name (Prot_Typ, Comp_Id, 'E')); + + Sub := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Barrier_Function_Specification (Loc, Bdef)); + + Insert_After (Current_Node, Sub); + Analyze (Sub); + Set_Protected_Body_Subprogram (Bdef, Bdef); + Set_Barrier_Function (Comp_Id, Bdef); + Set_Scope (Bdef, Scope (Comp_Id)); + Current_Node := Sub; + + -- Collect pointers to the protected subprogram and the barrier + -- of the current entry, for insertion into Entry_Bodies_Array. + + Append_To (Expressions (Entries_Aggr), + Make_Aggregate (Loc, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Bdef, Loc), + Attribute_Name => Name_Unrestricted_Access), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Edef, Loc), + Attribute_Name => Name_Unrestricted_Access)))); + end if; + + Next (Comp); + end loop; + end if; + + -- Emit declaration for Entry_Bodies_Array, now that the addresses of + -- all protected subprograms have been collected. + + if Has_Entries (Prot_Typ) then + Body_Id := + Make_Defining_Identifier (Sloc (Prot_Typ), + Chars => New_External_Name (Chars (Prot_Typ), 'A')); + + case Corresponding_Runtime_Package (Prot_Typ) is + when System_Tasking_Protected_Objects_Entries => + Body_Arr := Make_Object_Declaration (Loc, + Defining_Identifier => Body_Id, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To ( + RTE (RE_Protected_Entry_Body_Array), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Make_Integer_Literal (Loc, 1), + Make_Integer_Literal (Loc, E_Count))))), + Expression => Entries_Aggr); + + when System_Tasking_Protected_Objects_Single_Entry => + Body_Arr := Make_Object_Declaration (Loc, + Defining_Identifier => Body_Id, + Aliased_Present => True, + Object_Definition => New_Reference_To + (RTE (RE_Entry_Body), Loc), + Expression => + Make_Aggregate (Loc, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Bdef, Loc), + Attribute_Name => Name_Unrestricted_Access), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Edef, Loc), + Attribute_Name => Name_Unrestricted_Access)))); + + when others => + raise Program_Error; + end case; + + -- A pointer to this array will be placed in the corresponding record + -- by its initialization procedure so this needs to be analyzed here. + + Insert_After (Current_Node, Body_Arr); + Current_Node := Body_Arr; + Analyze (Body_Arr); + + Set_Entry_Bodies_Array (Prot_Typ, Body_Id); + + -- Finally, build the function that maps an entry index into the + -- corresponding body. A pointer to this function is placed in each + -- object of the type. Except for a ravenscar-like profile (no abort, + -- no entry queue, 1 entry) + + if Corresponding_Runtime_Package (Prot_Typ) = + System_Tasking_Protected_Objects_Entries + then + Sub := + Make_Subprogram_Declaration (Loc, + Specification => Build_Find_Body_Index_Spec (Prot_Typ)); + Insert_After (Current_Node, Sub); + Analyze (Sub); + end if; + end if; + end Expand_N_Protected_Type_Declaration; + + -------------------------------- + -- Expand_N_Requeue_Statement -- + -------------------------------- + + -- A non-dispatching requeue statement is expanded into one of four GNARLI + -- operations, depending on the source and destination (task or protected + -- object). A dispatching requeue statement is expanded into a call to the + -- predefined primitive _Disp_Requeue. In addition, code is generated to + -- jump around the remainder of processing for the original entry and, if + -- the destination is (different) protected object, to attempt to service + -- it. The following illustrates the various cases: + + -- procedure entE + -- (O : System.Address; + -- P : System.Address; + -- E : Protected_Entry_Index) + -- is + -- + -- + -- type poVP is access poV; + -- _object : ptVP := ptVP!(O); + + -- begin + -- begin + -- + + -- -- Requeue from one protected entry body to another protected + -- -- entry. + + -- Requeue_Protected_Entry ( + -- _object._object'Access, + -- new._object'Access, + -- E, + -- Abort_Present); + -- return; + + -- + + -- -- Requeue from an entry body to a task entry + + -- Requeue_Protected_To_Task_Entry ( + -- New._task_id, + -- E, + -- Abort_Present); + -- return; + + -- + -- Complete_Entry_Body (_object._object); + + -- exception + -- when all others => + -- Exceptional_Complete_Entry_Body ( + -- _object._object, Get_GNAT_Exception); + -- end; + -- end entE; + + -- Requeue of a task entry call to a task entry + + -- Accept_Call (E, Ann); + -- + -- Requeue_Task_Entry (New._task_id, E, Abort_Present); + -- goto Lnn; + -- + -- <> + -- Complete_Rendezvous; + + -- exception + -- when all others => + -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); + + -- Requeue of a task entry call to a protected entry + + -- Accept_Call (E, Ann); + -- + -- Requeue_Task_To_Protected_Entry ( + -- new._object'Access, + -- E, + -- Abort_Present); + -- newS (new, Pnn); + -- goto Lnn; + -- + -- <> + -- Complete_Rendezvous; + + -- exception + -- when all others => + -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); + + -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive + -- marked by pragma Implemented (XXX, By_Entry). + + -- The requeue is inside a protected entry: + + -- procedure entE + -- (O : System.Address; + -- P : System.Address; + -- E : Protected_Entry_Index) + -- is + -- + -- + -- type poVP is access poV; + -- _object : ptVP := ptVP!(O); + + -- begin + -- begin + -- + + -- _Disp_Requeue + -- (, + -- True, + -- _object'Address, + -- Ada.Tags.Get_Offset_Index + -- (Tag (_object), + -- ), + -- Abort_Present); + -- return; + + -- + -- Complete_Entry_Body (_object._object); + + -- exception + -- when all others => + -- Exceptional_Complete_Entry_Body ( + -- _object._object, Get_GNAT_Exception); + -- end; + -- end entE; + + -- The requeue is inside a task entry: + + -- Accept_Call (E, Ann); + -- + -- _Disp_Requeue + -- (, + -- False, + -- null, + -- Ada.Tags.Get_Offset_Index + -- (Tag (_object), + -- ), + -- Abort_Present); + -- newS (new, Pnn); + -- goto Lnn; + -- + -- <> + -- Complete_Rendezvous; + + -- exception + -- when all others => + -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); + + -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive + -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue + -- statement is replaced by a dispatching call with actual parameters taken + -- from the inner-most accept statement or entry body. + + -- Target.Primitive (Param1, ..., ParamN); + + -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive + -- marked by pragma Implemented (XXX, By_Any) or not marked at all. + + -- declare + -- S : constant Offset_Index := + -- Get_Offset_Index (Tag (Concval), DT_Position (Ename)); + -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S); + + -- begin + -- if C = POK_Protected_Entry + -- or else C = POK_Task_Entry + -- then + -- + + -- elsif C = POK_Protected_Procedure then + -- + + -- else + -- raise Program_Error; + -- end if; + -- end; + + procedure Expand_N_Requeue_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Conc_Typ : Entity_Id; + Concval : Node_Id; + Ename : Node_Id; + Index : Node_Id; + Old_Typ : Entity_Id; + + function Build_Dispatching_Call_Equivalent return Node_Id; + -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of + -- the form Concval.Ename. It is statically known that Ename is allowed + -- to be implemented by a protected procedure. Create a dispatching call + -- equivalent of Concval.Ename taking the actual parameters from the + -- inner-most accept statement or entry body. + + function Build_Dispatching_Requeue return Node_Id; + -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of + -- the form Concval.Ename. It is statically known that Ename is allowed + -- to be implemented by a protected or a task entry. Create a call to + -- primitive _Disp_Requeue which handles the low-level actions. + + function Build_Dispatching_Requeue_To_Any return Node_Id; + -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of + -- the form Concval.Ename. Ename is either marked by pragma Implemented + -- (XXX, By_Any) or not marked at all. Create a block which determines + -- at runtime whether Ename denotes an entry or a procedure and perform + -- the appropriate kind of dispatching select. + + function Build_Normal_Requeue return Node_Id; + -- N denotes a non-dispatching requeue statement to either a task or a + -- protected entry. Build the appropriate runtime call to perform the + -- action. + + function Build_Skip_Statement (Search : Node_Id) return Node_Id; + -- For a protected entry, create a return statement to skip the rest of + -- the entry body. Otherwise, create a goto statement to skip the rest + -- of a task accept statement. The lookup for the enclosing entry body + -- or accept statement starts from Search. + + --------------------------------------- + -- Build_Dispatching_Call_Equivalent -- + --------------------------------------- + + function Build_Dispatching_Call_Equivalent return Node_Id is + Call_Ent : constant Entity_Id := Entity (Ename); + Obj : constant Node_Id := Original_Node (Concval); + Acc_Ent : Node_Id; + Actuals : List_Id; + Formal : Node_Id; + Formals : List_Id; + + begin + -- Climb the parent chain looking for the inner-most entry body or + -- accept statement. + + Acc_Ent := N; + while Present (Acc_Ent) + and then not Nkind_In (Acc_Ent, N_Accept_Statement, + N_Entry_Body) + loop + Acc_Ent := Parent (Acc_Ent); + end loop; + + -- A requeue statement should be housed inside an entry body or an + -- accept statement at some level. If this is not the case, then the + -- tree is malformed. + + pragma Assert (Present (Acc_Ent)); + + -- Recover the list of formal parameters + + if Nkind (Acc_Ent) = N_Entry_Body then + Acc_Ent := Entry_Body_Formal_Part (Acc_Ent); + end if; + + Formals := Parameter_Specifications (Acc_Ent); + + -- Create the actual parameters for the dispatching call. These are + -- simply copies of the entry body or accept statement formals in the + -- same order as they appear. + + Actuals := No_List; + + if Present (Formals) then + Actuals := New_List; + Formal := First (Formals); + while Present (Formal) loop + Append_To (Actuals, + Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); + Next (Formal); + end loop; + end if; + + -- Generate: + -- Obj.Call_Ent (Actuals); + + return + Make_Procedure_Call_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Chars (Obj)), + Selector_Name => Make_Identifier (Loc, Chars (Call_Ent))), + + Parameter_Associations => Actuals); + end Build_Dispatching_Call_Equivalent; + + ------------------------------- + -- Build_Dispatching_Requeue -- + ------------------------------- + + function Build_Dispatching_Requeue return Node_Id is + Params : constant List_Id := New_List; + + begin + -- Process the "with abort" parameter + + Prepend_To (Params, + New_Reference_To (Boolean_Literals (Abort_Present (N)), Loc)); + + -- Process the entry wrapper's position in the primary dispatch + -- table parameter. Generate: + + -- Ada.Tags.Get_Offset_Index + -- (Ada.Tags.Tag (Concval), + -- ) + + Prepend_To (Params, + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Get_Offset_Index), Loc), + + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), Concval), + Make_Integer_Literal (Loc, DT_Position (Entity (Ename)))))); + + -- Specific actuals for protected to XXX requeue + + if Is_Protected_Type (Old_Typ) then + Prepend_To (Params, + Make_Attribute_Reference (Loc, -- _object'Address + Prefix => + Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)), + Attribute_Name => Name_Address)); + + Prepend_To (Params, -- True + New_Reference_To (Standard_True, Loc)); + + -- Specific actuals for task to XXX requeue + + else + pragma Assert (Is_Task_Type (Old_Typ)); + + Prepend_To (Params, -- null + New_Reference_To (RTE (RE_Null_Address), Loc)); + + Prepend_To (Params, -- False + New_Reference_To (Standard_False, Loc)); + end if; + + -- Add the object parameter + + Prepend_To (Params, New_Copy_Tree (Concval)); + + -- Generate: + -- _Disp_Requeue (); + + return + Make_Procedure_Call_Statement (Loc, + Name => Make_Identifier (Loc, Name_uDisp_Requeue), + Parameter_Associations => Params); + end Build_Dispatching_Requeue; + + -------------------------------------- + -- Build_Dispatching_Requeue_To_Any -- + -------------------------------------- + + function Build_Dispatching_Requeue_To_Any return Node_Id is + Call_Ent : constant Entity_Id := Entity (Ename); + Obj : constant Node_Id := Original_Node (Concval); + Skip : constant Node_Id := Build_Skip_Statement (N); + C : Entity_Id; + Decls : List_Id; + S : Entity_Id; + Stmts : List_Id; + + begin + Decls := New_List; + Stmts := New_List; + + -- Dispatch table slot processing, generate: + -- S : Integer; + + S := Build_S (Loc, Decls); + + -- Call kind processing, generate: + -- C : Ada.Tags.Prim_Op_Kind; + + C := Build_C (Loc, Decls); + + -- Generate: + -- S := Ada.Tags.Get_Offset_Index + -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent)); + + Append_To (Stmts, Build_S_Assignment (Loc, S, Obj, Call_Ent)); + + -- Generate: + -- _Disp_Get_Prim_Op_Kind (Obj, S, C); + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + Find_Prim_Op (Etype (Etype (Obj)), + Name_uDisp_Get_Prim_Op_Kind), + Loc), + Parameter_Associations => New_List ( + New_Copy_Tree (Obj), + New_Reference_To (S, Loc), + New_Reference_To (C, Loc)))); + + Append_To (Stmts, + + -- if C = POK_Protected_Entry + -- or else C = POK_Task_Entry + -- then + + Make_If_Statement (Loc, + Condition => + Make_Op_Or (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_POK_Protected_Entry), Loc)), + + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_POK_Task_Entry), Loc))), + + -- Dispatching requeue equivalent + + Then_Statements => New_List ( + Build_Dispatching_Requeue, + Skip), + + -- elsif C = POK_Protected_Procedure then + + Elsif_Parts => New_List ( + Make_Elsif_Part (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To ( + RTE (RE_POK_Protected_Procedure), Loc)), + + -- Dispatching call equivalent + + Then_Statements => New_List ( + Build_Dispatching_Call_Equivalent))), + + -- else + -- raise Program_Error; + -- end if; + + Else_Statements => New_List ( + Make_Raise_Program_Error (Loc, + Reason => PE_Explicit_Raise)))); + + -- Wrap everything into a block + + return + Make_Block_Statement (Loc, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + end Build_Dispatching_Requeue_To_Any; + + -------------------------- + -- Build_Normal_Requeue -- + -------------------------- + + function Build_Normal_Requeue return Node_Id is + Params : constant List_Id := New_List; + Param : Node_Id; + RT_Call : Node_Id; + + begin + -- Process the "with abort" parameter + + Prepend_To (Params, + New_Reference_To (Boolean_Literals (Abort_Present (N)), Loc)); + + -- Add the index expression to the parameters. It is common among all + -- four cases. + + Prepend_To (Params, + Entry_Index_Expression (Loc, Entity (Ename), Index, Conc_Typ)); + + if Is_Protected_Type (Old_Typ) then + declare + Self_Param : Node_Id; + + begin + Self_Param := + Make_Attribute_Reference (Loc, + Prefix => + Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)), + Attribute_Name => + Name_Unchecked_Access); + + -- Protected to protected requeue + + if Is_Protected_Type (Conc_Typ) then + RT_Call := + New_Reference_To ( + RTE (RE_Requeue_Protected_Entry), Loc); + + Param := + Make_Attribute_Reference (Loc, + Prefix => + Concurrent_Ref (Concval), + Attribute_Name => + Name_Unchecked_Access); + + -- Protected to task requeue + + else pragma Assert (Is_Task_Type (Conc_Typ)); + RT_Call := + New_Reference_To ( + RTE (RE_Requeue_Protected_To_Task_Entry), Loc); + + Param := Concurrent_Ref (Concval); + end if; + + Prepend_To (Params, Param); + Prepend_To (Params, Self_Param); + end; + + else pragma Assert (Is_Task_Type (Old_Typ)); + + -- Task to protected requeue + + if Is_Protected_Type (Conc_Typ) then + RT_Call := + New_Reference_To ( + RTE (RE_Requeue_Task_To_Protected_Entry), Loc); + + Param := + Make_Attribute_Reference (Loc, + Prefix => + Concurrent_Ref (Concval), + Attribute_Name => + Name_Unchecked_Access); + + -- Task to task requeue + + else pragma Assert (Is_Task_Type (Conc_Typ)); + RT_Call := + New_Reference_To (RTE (RE_Requeue_Task_Entry), Loc); + + Param := Concurrent_Ref (Concval); + end if; + + Prepend_To (Params, Param); + end if; + + return + Make_Procedure_Call_Statement (Loc, + Name => RT_Call, + Parameter_Associations => Params); + end Build_Normal_Requeue; + + -------------------------- + -- Build_Skip_Statement -- + -------------------------- + + function Build_Skip_Statement (Search : Node_Id) return Node_Id is + Skip_Stmt : Node_Id; + + begin + -- Build a return statement to skip the rest of the entire body + + if Is_Protected_Type (Old_Typ) then + Skip_Stmt := Make_Simple_Return_Statement (Loc); + + -- If the requeue is within a task, find the end label of the + -- enclosing accept statement and create a goto statement to it. + + else + declare + Acc : Node_Id; + Label : Node_Id; + + begin + -- Climb the parent chain looking for the enclosing accept + -- statement. + + Acc := Parent (Search); + while Present (Acc) + and then Nkind (Acc) /= N_Accept_Statement + loop + Acc := Parent (Acc); + end loop; + + -- The last statement is the second label used for completing + -- the rendezvous the usual way. The label we are looking for + -- is right before it. + + Label := + Prev (Last (Statements (Handled_Statement_Sequence (Acc)))); + + pragma Assert (Nkind (Label) = N_Label); + + -- Generate a goto statement to skip the rest of the accept + + Skip_Stmt := + Make_Goto_Statement (Loc, + Name => + New_Occurrence_Of (Entity (Identifier (Label)), Loc)); + end; + end if; + + Set_Analyzed (Skip_Stmt); + + return Skip_Stmt; + end Build_Skip_Statement; + + -- Start of processing for Expand_N_Requeue_Statement + + begin + -- Extract the components of the entry call + + Extract_Entry (N, Concval, Ename, Index); + Conc_Typ := Etype (Concval); + + -- Examine the scope stack in order to find nearest enclosing protected + -- or task type. This will constitute our invocation source. + + Old_Typ := Current_Scope; + while Present (Old_Typ) + and then not Is_Protected_Type (Old_Typ) + and then not Is_Task_Type (Old_Typ) + loop + Old_Typ := Scope (Old_Typ); + end loop; + + -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form + -- Concval.Ename where the type of Concval is class-wide concurrent + -- interface. + + if Ada_Version >= Ada_2012 + and then Present (Concval) + and then Is_Class_Wide_Type (Conc_Typ) + and then Is_Concurrent_Interface (Conc_Typ) + then + declare + Has_Impl : Boolean := False; + Impl_Kind : Name_Id := No_Name; + + begin + -- Check whether the Ename is flagged by pragma Implemented + + if Has_Rep_Pragma (Entity (Ename), Name_Implemented) then + Has_Impl := True; + Impl_Kind := Implementation_Kind (Entity (Ename)); + end if; + + -- The procedure_or_entry_NAME is guaranteed to be overridden by + -- an entry. Create a call to predefined primitive _Disp_Requeue. + + if Has_Impl + and then Impl_Kind = Name_By_Entry + then + Rewrite (N, Build_Dispatching_Requeue); + Analyze (N); + Insert_After (N, Build_Skip_Statement (N)); + + -- The procedure_or_entry_NAME is guaranteed to be overridden by + -- a protected procedure. In this case the requeue is transformed + -- into a dispatching call. + + elsif Has_Impl + and then Impl_Kind = Name_By_Protected_Procedure + then + Rewrite (N, Build_Dispatching_Call_Equivalent); + Analyze (N); + + -- The procedure_or_entry_NAME's implementation kind is either + -- By_Any or pragma Implemented was not applied at all. In this + -- case a runtime test determines whether Ename denotes an entry + -- or a protected procedure and performs the appropriate call. + + else + Rewrite (N, Build_Dispatching_Requeue_To_Any); + Analyze (N); + end if; + end; + + -- Processing for regular (non-dispatching) requeues + + else + Rewrite (N, Build_Normal_Requeue); + Analyze (N); + Insert_After (N, Build_Skip_Statement (N)); + end if; + end Expand_N_Requeue_Statement; + + ------------------------------- + -- Expand_N_Selective_Accept -- + ------------------------------- + + procedure Expand_N_Selective_Accept (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Alts : constant List_Id := Select_Alternatives (N); + + -- Note: in the below declarations a lot of new lists are allocated + -- unconditionally which may well not end up being used. That's + -- not a good idea since it wastes space gratuitously ??? + + Accept_Case : List_Id; + Accept_List : constant List_Id := New_List; + + Alt : Node_Id; + Alt_List : constant List_Id := New_List; + Alt_Stats : List_Id; + Ann : Entity_Id := Empty; + + Block : Node_Id; + Check_Guard : Boolean := True; + + Decls : constant List_Id := New_List; + Stats : constant List_Id := New_List; + Body_List : constant List_Id := New_List; + Trailing_List : constant List_Id := New_List; + + Choices : List_Id; + Else_Present : Boolean := False; + Terminate_Alt : Node_Id := Empty; + Select_Mode : Node_Id; + + Delay_Case : List_Id; + Delay_Count : Integer := 0; + Delay_Val : Entity_Id; + Delay_Index : Entity_Id; + Delay_Min : Entity_Id; + Delay_Num : Int := 1; + Delay_Alt_List : List_Id := New_List; + Delay_List : constant List_Id := New_List; + D : Entity_Id; + M : Entity_Id; + + First_Delay : Boolean := True; + Guard_Open : Entity_Id; + + End_Lab : Node_Id; + Index : Int := 1; + Lab : Node_Id; + Num_Alts : Int; + Num_Accept : Nat := 0; + Proc : Node_Id; + Q : Node_Id; + Time_Type : Entity_Id; + X : Node_Id; + Select_Call : Node_Id; + + Qnam : constant Entity_Id := + Make_Defining_Identifier (Loc, New_External_Name ('S', 0)); + + Xnam : constant Entity_Id := + Make_Defining_Identifier (Loc, New_External_Name ('J', 1)); + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Accept_Or_Raise return List_Id; + -- For the rare case where delay alternatives all have guards, and + -- all of them are closed, it is still possible that there were open + -- accept alternatives with no callers. We must reexamine the + -- Accept_List, and execute a selective wait with no else if some + -- accept is open. If none, we raise program_error. + + procedure Add_Accept (Alt : Node_Id); + -- Process a single accept statement in a select alternative. Build + -- procedure for body of accept, and add entry to dispatch table with + -- expression for guard, in preparation for call to run time select. + + function Make_And_Declare_Label (Num : Int) return Node_Id; + -- Manufacture a label using Num as a serial number and declare it. + -- The declaration is appended to Decls. The label marks the trailing + -- statements of an accept or delay alternative. + + function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id; + -- Build call to Selective_Wait runtime routine + + procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int); + -- Add code to compare value of delay with previous values, and + -- generate case entry for trailing statements. + + procedure Process_Accept_Alternative + (Alt : Node_Id; + Index : Int; + Proc : Node_Id); + -- Add code to call corresponding procedure, and branch to + -- trailing statements, if any. + + --------------------- + -- Accept_Or_Raise -- + --------------------- + + function Accept_Or_Raise return List_Id is + Cond : Node_Id; + Stats : List_Id; + J : constant Entity_Id := Make_Temporary (Loc, 'J'); + + begin + -- We generate the following: + + -- for J in q'range loop + -- if q(J).S /=null_task_entry then + -- selective_wait (simple_mode,...); + -- done := True; + -- exit; + -- end if; + -- end loop; + -- + -- if no rendez_vous then + -- raise program_error; + -- end if; + + -- Note that the code needs to know that the selector name + -- in an Accept_Alternative is named S. + + Cond := Make_Op_Ne (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => + Make_Indexed_Component (Loc, + Prefix => New_Reference_To (Qnam, Loc), + Expressions => New_List (New_Reference_To (J, Loc))), + Selector_Name => Make_Identifier (Loc, Name_S)), + Right_Opnd => + New_Reference_To (RTE (RE_Null_Task_Entry), Loc)); + + Stats := New_List ( + Make_Implicit_Loop_Statement (N, + Identifier => Empty, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => J, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Qnam, Loc), + Attribute_Name => Name_Range, + Expressions => New_List ( + Make_Integer_Literal (Loc, 1))))), + + Statements => New_List ( + Make_Implicit_If_Statement (N, + Condition => Cond, + Then_Statements => New_List ( + Make_Select_Call ( + New_Reference_To (RTE (RE_Simple_Mode), Loc)), + Make_Exit_Statement (Loc)))))); + + Append_To (Stats, + Make_Raise_Program_Error (Loc, + Condition => Make_Op_Eq (Loc, + Left_Opnd => New_Reference_To (Xnam, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_No_Rendezvous), Loc)), + Reason => PE_All_Guards_Closed)); + + return Stats; + end Accept_Or_Raise; + + ---------------- + -- Add_Accept -- + ---------------- + + procedure Add_Accept (Alt : Node_Id) is + Acc_Stm : constant Node_Id := Accept_Statement (Alt); + Ename : constant Node_Id := Entry_Direct_Name (Acc_Stm); + Eloc : constant Source_Ptr := Sloc (Ename); + Eent : constant Entity_Id := Entity (Ename); + Index : constant Node_Id := Entry_Index (Acc_Stm); + Null_Body : Node_Id; + Proc_Body : Node_Id; + PB_Ent : Entity_Id; + Expr : Node_Id; + Call : Node_Id; + + begin + if No (Ann) then + Ann := Node (Last_Elmt (Accept_Address (Eent))); + end if; + + if Present (Condition (Alt)) then + Expr := + Make_Conditional_Expression (Eloc, New_List ( + Condition (Alt), + Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)), + New_Reference_To (RTE (RE_Null_Task_Entry), Eloc))); + else + Expr := + Entry_Index_Expression + (Eloc, Eent, Index, Scope (Eent)); + end if; + + if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then + Null_Body := New_Reference_To (Standard_False, Eloc); + + if Abort_Allowed then + Call := Make_Procedure_Call_Statement (Eloc, + Name => New_Reference_To (RTE (RE_Abort_Undefer), Eloc)); + Insert_Before (First (Statements (Handled_Statement_Sequence ( + Accept_Statement (Alt)))), Call); + Analyze (Call); + end if; + + PB_Ent := + Make_Defining_Identifier (Eloc, + New_External_Name (Chars (Ename), 'A', Num_Accept)); + + if Comes_From_Source (Alt) then + Set_Debug_Info_Needed (PB_Ent); + end if; + + Proc_Body := + Make_Subprogram_Body (Eloc, + Specification => + Make_Procedure_Specification (Eloc, + Defining_Unit_Name => PB_Ent), + Declarations => Declarations (Acc_Stm), + Handled_Statement_Sequence => + Build_Accept_Body (Accept_Statement (Alt))); + + -- During the analysis of the body of the accept statement, any + -- zero cost exception handler records were collected in the + -- Accept_Handler_Records field of the N_Accept_Alternative node. + -- This is where we move them to where they belong, namely the + -- newly created procedure. + + Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt)); + Append (Proc_Body, Body_List); + + else + Null_Body := New_Reference_To (Standard_True, Eloc); + + -- if accept statement has declarations, insert above, given that + -- we are not creating a body for the accept. + + if Present (Declarations (Acc_Stm)) then + Insert_Actions (N, Declarations (Acc_Stm)); + end if; + end if; + + Append_To (Accept_List, + Make_Aggregate (Eloc, Expressions => New_List (Null_Body, Expr))); + + Num_Accept := Num_Accept + 1; + end Add_Accept; + + ---------------------------- + -- Make_And_Declare_Label -- + ---------------------------- + + function Make_And_Declare_Label (Num : Int) return Node_Id is + Lab_Id : Node_Id; + + begin + Lab_Id := Make_Identifier (Loc, New_External_Name ('L', Num)); + Lab := + Make_Label (Loc, Lab_Id); + + Append_To (Decls, + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Lab_Id)), + Label_Construct => Lab)); + + return Lab; + end Make_And_Declare_Label; + + ---------------------- + -- Make_Select_Call -- + ---------------------- + + function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id is + Params : constant List_Id := New_List; + + begin + Append ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Qnam, Loc), + Attribute_Name => Name_Unchecked_Access), + Params); + Append (Select_Mode, Params); + Append (New_Reference_To (Ann, Loc), Params); + Append (New_Reference_To (Xnam, Loc), Params); + + return + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Selective_Wait), Loc), + Parameter_Associations => Params); + end Make_Select_Call; + + -------------------------------- + -- Process_Accept_Alternative -- + -------------------------------- + + procedure Process_Accept_Alternative + (Alt : Node_Id; + Index : Int; + Proc : Node_Id) + is + Choices : List_Id := No_List; + Alt_Stats : List_Id; + + begin + Adjust_Condition (Condition (Alt)); + Alt_Stats := No_List; + + if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then + Choices := New_List ( + Make_Integer_Literal (Loc, Index)); + + Alt_Stats := New_List ( + Make_Procedure_Call_Statement (Sloc (Proc), + Name => New_Reference_To ( + Defining_Unit_Name (Specification (Proc)), Sloc (Proc)))); + end if; + + if Statements (Alt) /= Empty_List then + + if No (Alt_Stats) then + + -- Accept with no body, followed by trailing statements + + Choices := New_List ( + Make_Integer_Literal (Loc, Index)); + + Alt_Stats := New_List; + end if; + + -- After the call, if any, branch to trailing statements. We + -- create a label for each, as well as the corresponding label + -- declaration. + + Lab := Make_And_Declare_Label (Index); + Append_To (Alt_Stats, + Make_Goto_Statement (Loc, + Name => New_Copy (Identifier (Lab)))); + + Append (Lab, Trailing_List); + Append_List (Statements (Alt), Trailing_List); + Append_To (Trailing_List, + Make_Goto_Statement (Loc, + Name => New_Copy (Identifier (End_Lab)))); + end if; + + if Present (Alt_Stats) then + + -- Procedure call. and/or trailing statements + + Append_To (Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => Choices, + Statements => Alt_Stats)); + end if; + end Process_Accept_Alternative; + + ------------------------------- + -- Process_Delay_Alternative -- + ------------------------------- + + procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int) is + Choices : List_Id; + Cond : Node_Id; + Delay_Alt : List_Id; + + begin + -- Deal with C/Fortran boolean as delay condition + + Adjust_Condition (Condition (Alt)); + + -- Determine the smallest specified delay + + -- for each delay alternative generate: + + -- if guard-expression then + -- Delay_Val := delay-expression; + -- Guard_Open := True; + -- if Delay_Val < Delay_Min then + -- Delay_Min := Delay_Val; + -- Delay_Index := Index; + -- end if; + -- end if; + + -- The enclosing if-statement is omitted if there is no guard + + if Delay_Count = 1 + or else First_Delay + then + First_Delay := False; + + Delay_Alt := New_List ( + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Delay_Min, Loc), + Expression => Expression (Delay_Statement (Alt)))); + + if Delay_Count > 1 then + Append_To (Delay_Alt, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Delay_Index, Loc), + Expression => Make_Integer_Literal (Loc, Index))); + end if; + + else + Delay_Alt := New_List ( + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Delay_Val, Loc), + Expression => Expression (Delay_Statement (Alt)))); + + if Time_Type = Standard_Duration then + Cond := + Make_Op_Lt (Loc, + Left_Opnd => New_Reference_To (Delay_Val, Loc), + Right_Opnd => New_Reference_To (Delay_Min, Loc)); + + else + -- The scope of the time type must define a comparison + -- operator. The scope itself may not be visible, so we + -- construct a node with entity information to insure that + -- semantic analysis can find the proper operator. + + Cond := + Make_Function_Call (Loc, + Name => Make_Selected_Component (Loc, + Prefix => New_Reference_To (Scope (Time_Type), Loc), + Selector_Name => + Make_Operator_Symbol (Loc, + Chars => Name_Op_Lt, + Strval => No_String)), + Parameter_Associations => + New_List ( + New_Reference_To (Delay_Val, Loc), + New_Reference_To (Delay_Min, Loc))); + + Set_Entity (Prefix (Name (Cond)), Scope (Time_Type)); + end if; + + Append_To (Delay_Alt, + Make_Implicit_If_Statement (N, + Condition => Cond, + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Delay_Min, Loc), + Expression => New_Reference_To (Delay_Val, Loc)), + + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Delay_Index, Loc), + Expression => Make_Integer_Literal (Loc, Index))))); + end if; + + if Check_Guard then + Append_To (Delay_Alt, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Guard_Open, Loc), + Expression => New_Reference_To (Standard_True, Loc))); + end if; + + if Present (Condition (Alt)) then + Delay_Alt := New_List ( + Make_Implicit_If_Statement (N, + Condition => Condition (Alt), + Then_Statements => Delay_Alt)); + end if; + + Append_List (Delay_Alt, Delay_List); + + -- If the delay alternative has a statement part, add choice to the + -- case statements for delays. + + if Present (Statements (Alt)) then + + if Delay_Count = 1 then + Append_List (Statements (Alt), Delay_Alt_List); + + else + Choices := New_List ( + Make_Integer_Literal (Loc, Index)); + + Append_To (Delay_Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => Choices, + Statements => Statements (Alt))); + end if; + + elsif Delay_Count = 1 then + + -- If the single delay has no trailing statements, add a branch + -- to the exit label to the selective wait. + + Delay_Alt_List := New_List ( + Make_Goto_Statement (Loc, + Name => New_Copy (Identifier (End_Lab)))); + + end if; + end Process_Delay_Alternative; + + -- Start of processing for Expand_N_Selective_Accept + + begin + -- First insert some declarations before the select. The first is: + + -- Ann : Address + + -- This variable holds the parameters passed to the accept body. This + -- declaration has already been inserted by the time we get here by + -- a call to Expand_Accept_Declarations made from the semantics when + -- processing the first accept statement contained in the select. We + -- can find this entity as Accept_Address (E), where E is any of the + -- entries references by contained accept statements. + + -- The first step is to scan the list of Selective_Accept_Statements + -- to find this entity, and also count the number of accepts, and + -- determine if terminated, delay or else is present: + + Num_Alts := 0; + + Alt := First (Alts); + while Present (Alt) loop + + if Nkind (Alt) = N_Accept_Alternative then + Add_Accept (Alt); + + elsif Nkind (Alt) = N_Delay_Alternative then + Delay_Count := Delay_Count + 1; + + -- If the delays are relative delays, the delay expressions have + -- type Standard_Duration. Otherwise they must have some time type + -- recognized by GNAT. + + if Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement then + Time_Type := Standard_Duration; + else + Time_Type := Etype (Expression (Delay_Statement (Alt))); + + if Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) + or else Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time) + then + null; + else + Error_Msg_NE ( + "& is not a time type (RM 9.6(6))", + Expression (Delay_Statement (Alt)), Time_Type); + Time_Type := Standard_Duration; + Set_Etype (Expression (Delay_Statement (Alt)), Any_Type); + end if; + end if; + + if No (Condition (Alt)) then + + -- This guard will always be open + + Check_Guard := False; + end if; + + elsif Nkind (Alt) = N_Terminate_Alternative then + Adjust_Condition (Condition (Alt)); + Terminate_Alt := Alt; + end if; + + Num_Alts := Num_Alts + 1; + Next (Alt); + end loop; + + Else_Present := Present (Else_Statements (N)); + + -- At the same time (see procedure Add_Accept) we build the accept list: + + -- Qnn : Accept_List (1 .. num-select) := ( + -- (null-body, entry-index), + -- (null-body, entry-index), + -- .. + -- (null_body, entry-index)); + + -- In the above declaration, null-body is True if the corresponding + -- accept has no body, and false otherwise. The entry is either the + -- entry index expression if there is no guard, or if a guard is + -- present, then a conditional expression of the form: + + -- (if guard then entry-index else Null_Task_Entry) + + -- If a guard is statically known to be false, the entry can simply + -- be omitted from the accept list. + + Q := + Make_Object_Declaration (Loc, + Defining_Identifier => Qnam, + Object_Definition => + New_Reference_To (RTE (RE_Accept_List), Loc), + Aliased_Present => True, + + Expression => + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Accept_List), Loc), + Expression => + Make_Aggregate (Loc, Expressions => Accept_List))); + + Append (Q, Decls); + + -- Then we declare the variable that holds the index for the accept + -- that will be selected for service: + + -- Xnn : Select_Index; + + X := + Make_Object_Declaration (Loc, + Defining_Identifier => Xnam, + Object_Definition => + New_Reference_To (RTE (RE_Select_Index), Loc), + Expression => + New_Reference_To (RTE (RE_No_Rendezvous), Loc)); + + Append (X, Decls); + + -- After this follow procedure declarations for each accept body + + -- procedure Pnn is + -- begin + -- ... + -- end; + + -- where the ... are statements from the corresponding procedure body. + -- No parameters are involved, since the parameters are passed via Ann + -- and the parameter references have already been expanded to be direct + -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore, + -- any embedded tasking statements (which would normally be illegal in + -- procedures), have been converted to calls to the tasking runtime so + -- there is no problem in putting them into procedures. + + -- The original accept statement has been expanded into a block in + -- the same fashion as for simple accepts (see Build_Accept_Body). + + -- Note: we don't really need to build these procedures for the case + -- where no delay statement is present, but it is just as easy to + -- build them unconditionally, and not significantly inefficient, + -- since if they are short they will be inlined anyway. + + -- The procedure declarations have been assembled in Body_List + + -- If delays are present, we must compute the required delay. + -- We first generate the declarations: + + -- Delay_Index : Boolean := 0; + -- Delay_Min : Some_Time_Type.Time; + -- Delay_Val : Some_Time_Type.Time; + + -- Delay_Index will be set to the index of the minimum delay, i.e. the + -- active delay that is actually chosen as the basis for the possible + -- delay if an immediate rendez-vous is not possible. + + -- In the most common case there is a single delay statement, and this + -- is handled specially. + + if Delay_Count > 0 then + + -- Generate the required declarations + + Delay_Val := + Make_Defining_Identifier (Loc, New_External_Name ('D', 1)); + Delay_Index := + Make_Defining_Identifier (Loc, New_External_Name ('D', 2)); + Delay_Min := + Make_Defining_Identifier (Loc, New_External_Name ('D', 3)); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Delay_Val, + Object_Definition => New_Reference_To (Time_Type, Loc))); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Delay_Index, + Object_Definition => New_Reference_To (Standard_Integer, Loc), + Expression => Make_Integer_Literal (Loc, 0))); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Delay_Min, + Object_Definition => New_Reference_To (Time_Type, Loc), + Expression => + Unchecked_Convert_To (Time_Type, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Underlying_Type (Time_Type), Loc), + Attribute_Name => Name_Last)))); + + -- Create Duration and Delay_Mode objects used for passing a delay + -- value to RTS + + D := Make_Temporary (Loc, 'D'); + M := Make_Temporary (Loc, 'M'); + + declare + Discr : Entity_Id; + + begin + -- Note that these values are defined in s-osprim.ads and must + -- be kept in sync: + -- + -- Relative : constant := 0; + -- Absolute_Calendar : constant := 1; + -- Absolute_RT : constant := 2; + + if Time_Type = Standard_Duration then + Discr := Make_Integer_Literal (Loc, 0); + + elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then + Discr := Make_Integer_Literal (Loc, 1); + + else + pragma Assert + (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); + Discr := Make_Integer_Literal (Loc, 2); + end if; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => D, + Object_Definition => + New_Reference_To (Standard_Duration, Loc))); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => M, + Object_Definition => + New_Reference_To (Standard_Integer, Loc), + Expression => Discr)); + end; + + if Check_Guard then + Guard_Open := + Make_Defining_Identifier (Loc, New_External_Name ('G', 1)); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Guard_Open, + Object_Definition => New_Reference_To (Standard_Boolean, Loc), + Expression => New_Reference_To (Standard_False, Loc))); + end if; + + -- Delay_Count is zero, don't need M and D set (suppress warning) + + else + M := Empty; + D := Empty; + end if; + + if Present (Terminate_Alt) then + + -- If the terminate alternative guard is False, use + -- Simple_Mode; otherwise use Terminate_Mode. + + if Present (Condition (Terminate_Alt)) then + Select_Mode := Make_Conditional_Expression (Loc, + New_List (Condition (Terminate_Alt), + New_Reference_To (RTE (RE_Terminate_Mode), Loc), + New_Reference_To (RTE (RE_Simple_Mode), Loc))); + else + Select_Mode := New_Reference_To (RTE (RE_Terminate_Mode), Loc); + end if; + + elsif Else_Present or Delay_Count > 0 then + Select_Mode := New_Reference_To (RTE (RE_Else_Mode), Loc); + + else + Select_Mode := New_Reference_To (RTE (RE_Simple_Mode), Loc); + end if; + + Select_Call := Make_Select_Call (Select_Mode); + Append (Select_Call, Stats); + + -- Now generate code to act on the result. There is an entry + -- in this case for each accept statement with a non-null body, + -- followed by a branch to the statements that follow the Accept. + -- In the absence of delay alternatives, we generate: + + -- case X is + -- when No_Rendezvous => -- omitted if simple mode + -- goto Lab0; + + -- when 1 => + -- P1n; + -- goto Lab1; + + -- when 2 => + -- P2n; + -- goto Lab2; + + -- when others => + -- goto Exit; + -- end case; + -- + -- Lab0: Else_Statements; + -- goto exit; + + -- Lab1: Trailing_Statements1; + -- goto Exit; + -- + -- Lab2: Trailing_Statements2; + -- goto Exit; + -- ... + -- Exit: + + -- Generate label for common exit + + End_Lab := Make_And_Declare_Label (Num_Alts + 1); + + -- First entry is the default case, when no rendezvous is possible + + Choices := New_List (New_Reference_To (RTE (RE_No_Rendezvous), Loc)); + + if Else_Present then + + -- If no rendezvous is possible, the else part is executed + + Lab := Make_And_Declare_Label (0); + Alt_Stats := New_List ( + Make_Goto_Statement (Loc, + Name => New_Copy (Identifier (Lab)))); + + Append (Lab, Trailing_List); + Append_List (Else_Statements (N), Trailing_List); + Append_To (Trailing_List, + Make_Goto_Statement (Loc, + Name => New_Copy (Identifier (End_Lab)))); + else + Alt_Stats := New_List ( + Make_Goto_Statement (Loc, + Name => New_Copy (Identifier (End_Lab)))); + end if; + + Append_To (Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => Choices, + Statements => Alt_Stats)); + + -- We make use of the fact that Accept_Index is an integer type, and + -- generate successive literals for entries for each accept. Only those + -- for which there is a body or trailing statements get a case entry. + + Alt := First (Select_Alternatives (N)); + Proc := First (Body_List); + while Present (Alt) loop + + if Nkind (Alt) = N_Accept_Alternative then + Process_Accept_Alternative (Alt, Index, Proc); + Index := Index + 1; + + if Present + (Handled_Statement_Sequence (Accept_Statement (Alt))) + then + Next (Proc); + end if; + + elsif Nkind (Alt) = N_Delay_Alternative then + Process_Delay_Alternative (Alt, Delay_Num); + Delay_Num := Delay_Num + 1; + end if; + + Next (Alt); + end loop; + + -- An others choice is always added to the main case, as well + -- as the delay case (to satisfy the compiler). + + Append_To (Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_List (Make_Others_Choice (Loc)), + Statements => + New_List (Make_Goto_Statement (Loc, + Name => New_Copy (Identifier (End_Lab)))))); + + Accept_Case := New_List ( + Make_Case_Statement (Loc, + Expression => New_Reference_To (Xnam, Loc), + Alternatives => Alt_List)); + + Append_List (Trailing_List, Accept_Case); + Append (End_Lab, Accept_Case); + Append_List (Body_List, Decls); + + -- Construct case statement for trailing statements of delay + -- alternatives, if there are several of them. + + if Delay_Count > 1 then + Append_To (Delay_Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_List (Make_Others_Choice (Loc)), + Statements => + New_List (Make_Null_Statement (Loc)))); + + Delay_Case := New_List ( + Make_Case_Statement (Loc, + Expression => New_Reference_To (Delay_Index, Loc), + Alternatives => Delay_Alt_List)); + else + Delay_Case := Delay_Alt_List; + end if; + + -- If there are no delay alternatives, we append the case statement + -- to the statement list. + + if Delay_Count = 0 then + Append_List (Accept_Case, Stats); + + -- Delay alternatives present + + else + -- If delay alternatives are present we generate: + + -- find minimum delay. + -- DX := minimum delay; + -- M := ; + -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P, + -- DX, MX, X); + -- + -- if X = No_Rendezvous then + -- case statement for delay statements. + -- else + -- case statement for accept alternatives. + -- end if; + + declare + Cases : Node_Id; + Stmt : Node_Id; + Parms : List_Id; + Parm : Node_Id; + Conv : Node_Id; + + begin + -- The type of the delay expression is known to be legal + + if Time_Type = Standard_Duration then + Conv := New_Reference_To (Delay_Min, Loc); + + elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then + Conv := Make_Function_Call (Loc, + New_Reference_To (RTE (RO_CA_To_Duration), Loc), + New_List (New_Reference_To (Delay_Min, Loc))); + + else + pragma Assert + (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); + + Conv := Make_Function_Call (Loc, + New_Reference_To (RTE (RO_RT_To_Duration), Loc), + New_List (New_Reference_To (Delay_Min, Loc))); + end if; + + Stmt := Make_Assignment_Statement (Loc, + Name => New_Reference_To (D, Loc), + Expression => Conv); + + -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode) + + Parms := Parameter_Associations (Select_Call); + Parm := First (Parms); + + while Present (Parm) + and then Parm /= Select_Mode + loop + Next (Parm); + end loop; + + pragma Assert (Present (Parm)); + Rewrite (Parm, New_Reference_To (RTE (RE_Delay_Mode), Loc)); + Analyze (Parm); + + -- Prepare two new parameters of Duration and Delay_Mode type + -- which represent the value and the mode of the minimum delay. + + Next (Parm); + Insert_After (Parm, New_Reference_To (M, Loc)); + Insert_After (Parm, New_Reference_To (D, Loc)); + + -- Create a call to RTS + + Rewrite (Select_Call, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Timed_Selective_Wait), Loc), + Parameter_Associations => Parms)); + + -- This new call should follow the calculation of the minimum + -- delay. + + Insert_List_Before (Select_Call, Delay_List); + + if Check_Guard then + Stmt := + Make_Implicit_If_Statement (N, + Condition => New_Reference_To (Guard_Open, Loc), + Then_Statements => + New_List (New_Copy_Tree (Stmt), + New_Copy_Tree (Select_Call)), + Else_Statements => Accept_Or_Raise); + Rewrite (Select_Call, Stmt); + else + Insert_Before (Select_Call, Stmt); + end if; + + Cases := + Make_Implicit_If_Statement (N, + Condition => Make_Op_Eq (Loc, + Left_Opnd => New_Reference_To (Xnam, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_No_Rendezvous), Loc)), + + Then_Statements => Delay_Case, + Else_Statements => Accept_Case); + + Append (Cases, Stats); + end; + end if; + + -- Replace accept statement with appropriate block + + Block := + Make_Block_Statement (Loc, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stats)); + + Rewrite (N, Block); + Analyze (N); + + -- Note: have to worry more about abort deferral in above code ??? + + -- Final step is to unstack the Accept_Address entries for all accept + -- statements appearing in accept alternatives in the select statement + + Alt := First (Alts); + while Present (Alt) loop + if Nkind (Alt) = N_Accept_Alternative then + Remove_Last_Elmt (Accept_Address + (Entity (Entry_Direct_Name (Accept_Statement (Alt))))); + end if; + + Next (Alt); + end loop; + end Expand_N_Selective_Accept; + + -------------------------------------- + -- Expand_N_Single_Task_Declaration -- + -------------------------------------- + + -- Single task declarations should never be present after semantic + -- analysis, since we expect them to be replaced by a declaration of an + -- anonymous task type, followed by a declaration of the task object. We + -- include this routine to make sure that is happening! + + procedure Expand_N_Single_Task_Declaration (N : Node_Id) is + begin + raise Program_Error; + end Expand_N_Single_Task_Declaration; + + ------------------------ + -- Expand_N_Task_Body -- + ------------------------ + + -- Given a task body + + -- task body tname is + -- + -- begin + -- + -- end x; + + -- This expansion routine converts it into a procedure and sets the + -- elaboration flag for the procedure to true, to represent the fact + -- that the task body is now elaborated: + + -- procedure tnameB (_Task : access tnameV) is + -- discriminal : dtype renames _Task.discriminant; + + -- procedure _clean is + -- begin + -- Abort_Defer.all; + -- Complete_Task; + -- Abort_Undefer.all; + -- return; + -- end _clean; + + -- begin + -- Abort_Undefer.all; + -- + -- System.Task_Stages.Complete_Activation; + -- + -- at end + -- _clean; + -- end tnameB; + + -- tnameE := True; + + -- In addition, if the task body is an activator, then a call to activate + -- tasks is added at the start of the statements, before the call to + -- Complete_Activation, and if in addition the task is a master then it + -- must be established as a master. These calls are inserted and analyzed + -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is + -- expanded. + + -- There is one discriminal declaration line generated for each + -- discriminant that is present to provide an easy reference point for + -- discriminant references inside the body (see Exp_Ch2.Expand_Name). + + -- Note on relationship to GNARLI definition. In the GNARLI definition, + -- task body procedures have a profile (Arg : System.Address). That is + -- needed because GNARLI has to use the same access-to-subprogram type + -- for all task types. We depend here on knowing that in GNAT, passing + -- an address argument by value is identical to passing a record value + -- by access (in either case a single pointer is passed), so even though + -- this procedure has the wrong profile. In fact it's all OK, since the + -- callings sequence is identical. + + procedure Expand_N_Task_Body (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ttyp : constant Entity_Id := Corresponding_Spec (N); + Call : Node_Id; + New_N : Node_Id; + + Insert_Nod : Node_Id; + -- Used to determine the proper location of wrapper body insertions + + begin + -- Add renaming declarations for discriminals and a declaration for the + -- entry family index (if applicable). + + Install_Private_Data_Declarations + (Loc, Task_Body_Procedure (Ttyp), Ttyp, N, Declarations (N)); + + -- Add a call to Abort_Undefer at the very beginning of the task + -- body since this body is called with abort still deferred. + + if Abort_Allowed then + Call := Build_Runtime_Call (Loc, RE_Abort_Undefer); + Insert_Before + (First (Statements (Handled_Statement_Sequence (N))), Call); + Analyze (Call); + end if; + + -- The statement part has already been protected with an at_end and + -- cleanup actions. The call to Complete_Activation must be placed + -- at the head of the sequence of statements of that block. The + -- declarations have been merged in this sequence of statements but + -- the first real statement is accessible from the First_Real_Statement + -- field (which was set for exactly this purpose). + + if Restricted_Profile then + Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation); + else + Call := Build_Runtime_Call (Loc, RE_Complete_Activation); + end if; + + Insert_Before + (First_Real_Statement (Handled_Statement_Sequence (N)), Call); + Analyze (Call); + + New_N := + Make_Subprogram_Body (Loc, + Specification => Build_Task_Proc_Specification (Ttyp), + Declarations => Declarations (N), + Handled_Statement_Sequence => Handled_Statement_Sequence (N)); + + -- If the task contains generic instantiations, cleanup actions are + -- delayed until after instantiation. Transfer the activation chain to + -- the subprogram, to insure that the activation call is properly + -- generated. It the task body contains inner tasks, indicate that the + -- subprogram is a task master. + + if Delay_Cleanups (Ttyp) then + Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N)); + Set_Is_Task_Master (New_N, Is_Task_Master (N)); + end if; + + Rewrite (N, New_N); + Analyze (N); + + -- Set elaboration flag immediately after task body. If the body is a + -- subunit, the flag is set in the declarative part containing the stub. + + if Nkind (Parent (N)) /= N_Subunit then + Insert_After (N, + Make_Assignment_Statement (Loc, + Name => + Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')), + Expression => New_Reference_To (Standard_True, Loc))); + end if; + + -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after + -- the task body. At this point all wrapper specs have been created, + -- frozen and included in the dispatch table for the task type. + + if Ada_Version >= Ada_2005 then + if Nkind (Parent (N)) = N_Subunit then + Insert_Nod := Corresponding_Stub (Parent (N)); + else + Insert_Nod := N; + end if; + + Build_Wrapper_Bodies (Loc, Ttyp, Insert_Nod); + end if; + end Expand_N_Task_Body; + + ------------------------------------ + -- Expand_N_Task_Type_Declaration -- + ------------------------------------ + + -- We have several things to do. First we must create a Boolean flag used + -- to mark if the body is elaborated yet. This variable gets set to True + -- when the body of the task is elaborated (we can't rely on the normal + -- ABE mechanism for the task body, since we need to pass an access to + -- this elaboration boolean to the runtime routines). + + -- taskE : aliased Boolean := False; + + -- Next a variable is declared to hold the task stack size (either the + -- default : Unspecified_Size, or a value that is set by a pragma + -- Storage_Size). If the value of the pragma Storage_Size is static, then + -- the variable is initialized with this value: + + -- taskZ : Size_Type := Unspecified_Size; + -- or + -- taskZ : Size_Type := Size_Type (size_expression); + + -- Note: No variable is needed to hold the task relative deadline since + -- its value would never be static because the parameter is of a private + -- type (Ada.Real_Time.Time_Span). + + -- Next we create a corresponding record type declaration used to represent + -- values of this task. The general form of this type declaration is + + -- type taskV (discriminants) is record + -- _Task_Id : Task_Id; + -- entry_family : array (bounds) of Void; + -- _Priority : Integer := priority_expression; + -- _Size : Size_Type := Size_Type (size_expression); + -- _Task_Info : Task_Info_Type := task_info_expression; + -- _CPU : Integer := cpu_range_expression; + -- end record; + + -- The discriminants are present only if the corresponding task type has + -- discriminants, and they exactly mirror the task type discriminants. + + -- The Id field is always present. It contains the Task_Id value, as set by + -- the call to Create_Task. Note that although the task is limited, the + -- task value record type is not limited, so there is no problem in passing + -- this field as an out parameter to Create_Task. + + -- One entry_family component is present for each entry family in the task + -- definition. The bounds correspond to the bounds of the entry family + -- (which may depend on discriminants). The element type is void, since we + -- only need the bounds information for determining the entry index. Note + -- that the use of an anonymous array would normally be illegal in this + -- context, but this is a parser check, and the semantics is quite prepared + -- to handle such a case. + + -- The _Size field is present only if a Storage_Size pragma appears in the + -- task definition. The expression captures the argument that was present + -- in the pragma, and is used to override the task stack size otherwise + -- associated with the task type. + + -- The _Priority field is present only if a Priority or Interrupt_Priority + -- pragma appears in the task definition. The expression captures the + -- argument that was present in the pragma, and is used to provide the Size + -- parameter to the call to Create_Task. + + -- The _Task_Info field is present only if a Task_Info pragma appears in + -- the task definition. The expression captures the argument that was + -- present in the pragma, and is used to provide the Task_Image parameter + -- to the call to Create_Task. + + -- The _CPU field is present only if a CPU pragma appears in the task + -- definition. The expression captures the argument that was present in + -- the pragma, and is used to provide the CPU parameter to the call to + -- Create_Task. + + -- The _Relative_Deadline field is present only if a Relative_Deadline + -- pragma appears in the task definition. The expression captures the + -- argument that was present in the pragma, and is used to provide the + -- Relative_Deadline parameter to the call to Create_Task. + + -- When a task is declared, an instance of the task value record is + -- created. The elaboration of this declaration creates the correct bounds + -- for the entry families, and also evaluates the size, priority, and + -- task_Info expressions if needed. The initialization routine for the task + -- type itself then calls Create_Task with appropriate parameters to + -- initialize the value of the Task_Id field. + + -- Note: the address of this record is passed as the "Discriminants" + -- parameter for Create_Task. Since Create_Task merely passes this onto the + -- body procedure, it does not matter that it does not quite match the + -- GNARLI model of what is being passed (the record contains more than just + -- the discriminants, but the discriminants can be found from the record + -- value). + + -- The Entity_Id for this created record type is placed in the + -- Corresponding_Record_Type field of the associated task type entity. + + -- Next we create a procedure specification for the task body procedure: + + -- procedure taskB (_Task : access taskV); + + -- Note that this must come after the record type declaration, since + -- the spec refers to this type. It turns out that the initialization + -- procedure for the value type references the task body spec, but that's + -- fine, since it won't be generated till the freeze point for the type, + -- which is certainly after the task body spec declaration. + + -- Finally, we set the task index value field of the entry attribute in + -- the case of a simple entry. + + procedure Expand_N_Task_Type_Declaration (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N)); + Tasknm : constant Name_Id := Chars (Tasktyp); + Taskdef : constant Node_Id := Task_Definition (N); + + Proc_Spec : Node_Id; + Rec_Decl : Node_Id; + Rec_Ent : Entity_Id; + Cdecls : List_Id; + Elab_Decl : Node_Id; + Size_Decl : Node_Id; + Body_Decl : Node_Id; + Task_Size : Node_Id; + Ent_Stack : Entity_Id; + Decl_Stack : Node_Id; + + begin + -- If already expanded, nothing to do + + if Present (Corresponding_Record_Type (Tasktyp)) then + return; + end if; + + -- Here we will do the expansion + + Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc); + + Rec_Ent := Defining_Identifier (Rec_Decl); + Cdecls := Component_Items (Component_List + (Type_Definition (Rec_Decl))); + + Qualify_Entity_Names (N); + + -- First create the elaboration variable + + Elab_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Sloc (Tasktyp), + Chars => New_External_Name (Tasknm, 'E')), + Aliased_Present => True, + Object_Definition => New_Reference_To (Standard_Boolean, Loc), + Expression => New_Reference_To (Standard_False, Loc)); + Insert_After (N, Elab_Decl); + + -- Next create the declaration of the size variable (tasknmZ) + + Set_Storage_Size_Variable (Tasktyp, + Make_Defining_Identifier (Sloc (Tasktyp), + Chars => New_External_Name (Tasknm, 'Z'))); + + if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) and then + Is_Static_Expression (Expression (First ( + Pragma_Argument_Associations (Find_Task_Or_Protected_Pragma ( + Taskdef, Name_Storage_Size))))) + then + Size_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Storage_Size_Variable (Tasktyp), + Object_Definition => New_Reference_To (RTE (RE_Size_Type), Loc), + Expression => + Convert_To (RTE (RE_Size_Type), + Relocate_Node ( + Expression (First ( + Pragma_Argument_Associations ( + Find_Task_Or_Protected_Pragma + (Taskdef, Name_Storage_Size))))))); + + else + Size_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Storage_Size_Variable (Tasktyp), + Object_Definition => New_Reference_To (RTE (RE_Size_Type), Loc), + Expression => New_Reference_To (RTE (RE_Unspecified_Size), Loc)); + end if; + + Insert_After (Elab_Decl, Size_Decl); + + -- Next build the rest of the corresponding record declaration. This is + -- done last, since the corresponding record initialization procedure + -- will reference the previously created entities. + + -- Fill in the component declarations -- first the _Task_Id field + + Append_To (Cdecls, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uTask_Id), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => New_Reference_To (RTE (RO_ST_Task_Id), + Loc)))); + + -- Declare static ATCB (that is, created by the expander) if we are + -- using the Restricted run time. + + if Restricted_Profile then + Append_To (Cdecls, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uATCB), + + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => True, + Subtype_Indication => Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of + (RTE (RE_Ada_Task_Control_Block), Loc), + + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => + New_List (Make_Integer_Literal (Loc, 0))))))); + + end if; + + -- Declare static stack (that is, created by the expander) if we are + -- using the Restricted run time on a bare board configuration. + + if Restricted_Profile + and then Preallocated_Stacks_On_Target + then + -- First we need to extract the appropriate stack size + + Ent_Stack := Make_Defining_Identifier (Loc, Name_uStack); + + if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then + declare + Expr_N : constant Node_Id := + Expression (First ( + Pragma_Argument_Associations ( + Find_Task_Or_Protected_Pragma + (Taskdef, Name_Storage_Size)))); + Etyp : constant Entity_Id := Etype (Expr_N); + P : constant Node_Id := Parent (Expr_N); + + begin + -- The stack is defined inside the corresponding record. + -- Therefore if the size of the stack is set by means of + -- a discriminant, we must reference the discriminant of the + -- corresponding record type. + + if Nkind (Expr_N) in N_Has_Entity + and then Present (Discriminal_Link (Entity (Expr_N))) + then + Task_Size := + New_Reference_To + (CR_Discriminant (Discriminal_Link (Entity (Expr_N))), + Loc); + Set_Parent (Task_Size, P); + Set_Etype (Task_Size, Etyp); + Set_Analyzed (Task_Size); + + else + Task_Size := Relocate_Node (Expr_N); + end if; + end; + + else + Task_Size := + New_Reference_To (RTE (RE_Default_Stack_Size), Loc); + end if; + + Decl_Stack := Make_Component_Declaration (Loc, + Defining_Identifier => Ent_Stack, + + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => True, + Subtype_Indication => Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Storage_Array), Loc), + + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List (Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Convert_To (RTE (RE_Storage_Offset), + Task_Size))))))); + + Append_To (Cdecls, Decl_Stack); + + -- The appropriate alignment for the stack is ensured by the run-time + -- code in charge of task creation. + + end if; + + -- Add components for entry families + + Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp); + + -- Add the _Priority component if a Priority pragma is present + + if Present (Taskdef) and then Has_Pragma_Priority (Taskdef) then + declare + Prag : constant Node_Id := + Find_Task_Or_Protected_Pragma (Taskdef, Name_Priority); + Expr : Node_Id; + + begin + Expr := First (Pragma_Argument_Associations (Prag)); + + if Nkind (Expr) = N_Pragma_Argument_Association then + Expr := Expression (Expr); + end if; + + Expr := New_Copy_Tree (Expr); + + -- Add conversion to proper type to do range check if required + -- Note that for runtime units, we allow out of range interrupt + -- priority values to be used in a priority pragma. This is for + -- the benefit of some versions of System.Interrupts which use + -- a special server task with maximum interrupt priority. + + if Pragma_Name (Prag) = Name_Priority + and then not GNAT_Mode + then + Rewrite (Expr, Convert_To (RTE (RE_Priority), Expr)); + else + Rewrite (Expr, Convert_To (RTE (RE_Any_Priority), Expr)); + end if; + + Append_To (Cdecls, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uPriority), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => New_Reference_To (Standard_Integer, + Loc)), + Expression => Expr)); + end; + end if; + + -- Add the _Task_Size component if a Storage_Size pragma is present + + if Present (Taskdef) + and then Has_Storage_Size_Pragma (Taskdef) + then + Append_To (Cdecls, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uSize), + + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => New_Reference_To (RTE (RE_Size_Type), + Loc)), + + Expression => + Convert_To (RTE (RE_Size_Type), + Relocate_Node ( + Expression (First ( + Pragma_Argument_Associations ( + Find_Task_Or_Protected_Pragma + (Taskdef, Name_Storage_Size)))))))); + end if; + + -- Add the _Task_Info component if a Task_Info pragma is present + + if Present (Taskdef) and then Has_Task_Info_Pragma (Taskdef) then + Append_To (Cdecls, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uTask_Info), + + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Reference_To (RTE (RE_Task_Info_Type), Loc)), + + Expression => New_Copy ( + Expression (First ( + Pragma_Argument_Associations ( + Find_Task_Or_Protected_Pragma + (Taskdef, Name_Task_Info))))))); + end if; + + -- Add the _CPU component if a CPU pragma is present + + if Present (Taskdef) and then Has_Pragma_CPU (Taskdef) then + Append_To (Cdecls, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uCPU), + + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Reference_To (RTE (RE_CPU_Range), Loc)), + + Expression => New_Copy ( + Expression (First ( + Pragma_Argument_Associations ( + Find_Task_Or_Protected_Pragma + (Taskdef, Name_CPU))))))); + end if; + + -- Add the _Relative_Deadline component if a Relative_Deadline pragma is + -- present. If we are using a restricted run time this component will + -- not be added (deadlines are not allowed by the Ravenscar profile). + + if not Restricted_Profile + and then Present (Taskdef) + and then Has_Relative_Deadline_Pragma (Taskdef) + then + Append_To (Cdecls, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uRelative_Deadline), + + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Reference_To (RTE (RE_Time_Span), Loc)), + + Expression => + Convert_To (RTE (RE_Time_Span), + Relocate_Node ( + Expression (First ( + Pragma_Argument_Associations ( + Find_Task_Or_Protected_Pragma + (Taskdef, Name_Relative_Deadline)))))))); + end if; + + Insert_After (Size_Decl, Rec_Decl); + + -- Analyze the record declaration immediately after construction, + -- because the initialization procedure is needed for single task + -- declarations before the next entity is analyzed. + + Analyze (Rec_Decl); + + -- Create the declaration of the task body procedure + + Proc_Spec := Build_Task_Proc_Specification (Tasktyp); + Body_Decl := + Make_Subprogram_Declaration (Loc, + Specification => Proc_Spec); + + Insert_After (Rec_Decl, Body_Decl); + + -- The subprogram does not comes from source, so we have to indicate the + -- need for debugging information explicitly. + + if Comes_From_Source (Original_Node (N)) then + Set_Debug_Info_Needed (Defining_Entity (Proc_Spec)); + end if; + + -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before + -- the corresponding record has been frozen. + + if Ada_Version >= Ada_2005 then + Build_Wrapper_Specs (Loc, Tasktyp, Rec_Decl); + end if; + + -- Ada 2005 (AI-345): We must defer freezing to allow further + -- declaration of primitive subprograms covering task interfaces + + if Ada_Version <= Ada_95 then + + -- Now we can freeze the corresponding record. This needs manually + -- freezing, since it is really part of the task type, and the task + -- type is frozen at this stage. We of course need the initialization + -- procedure for this corresponding record type and we won't get it + -- in time if we don't freeze now. + + declare + L : constant List_Id := Freeze_Entity (Rec_Ent, N); + begin + if Is_Non_Empty_List (L) then + Insert_List_After (Body_Decl, L); + end if; + end; + end if; + + -- Complete the expansion of access types to the current task type, if + -- any were declared. + + Expand_Previous_Access_Type (Tasktyp); + + -- Create wrappers for entries that have pre/postconditions + + declare + Ent : Entity_Id; + + begin + Ent := First_Entity (Tasktyp); + while Present (Ent) loop + if Ekind_In (Ent, E_Entry, E_Entry_Family) + and then Present (Spec_PPC_List (Ent)) + then + Build_PPC_Wrapper (Ent, N); + end if; + + Next_Entity (Ent); + end loop; + end; + end Expand_N_Task_Type_Declaration; + + ------------------------------- + -- Expand_N_Timed_Entry_Call -- + ------------------------------- + + -- A timed entry call in normal case is not implemented using ATC mechanism + -- anymore for efficiency reason. + + -- select + -- T.E; + -- S1; + -- or + -- Delay D; + -- S2; + -- end select; + + -- is expanded as follow: + + -- 1) When T.E is a task entry_call; + + -- declare + -- B : Boolean; + -- X : Task_Entry_Index := ; + -- DX : Duration := To_Duration (D); + -- M : Delay_Mode := ; + -- P : parms := (parm, parm, parm); + + -- begin + -- Timed_Protected_Entry_Call + -- (, X, P'Address, DX, M, B); + -- if B then + -- S1; + -- else + -- S2; + -- end if; + -- end; + + -- 2) When T.E is a protected entry_call; + + -- declare + -- B : Boolean; + -- X : Protected_Entry_Index := ; + -- DX : Duration := To_Duration (D); + -- M : Delay_Mode := ; + -- P : parms := (parm, parm, parm); + + -- begin + -- Timed_Protected_Entry_Call + -- ('unchecked_access, X, P'Address, DX, M, B); + -- if B then + -- S1; + -- else + -- S2; + -- end if; + -- end; + + -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call; + + -- declare + -- B : Boolean := False; + -- C : Ada.Tags.Prim_Op_Kind; + -- DX : Duration := To_Duration (D) + -- K : Ada.Tags.Tagged_Kind := + -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag ()); + -- M : Integer :=...; + -- P : Parameters := (Param1 .. ParamN); + -- S : Iteger; + + -- begin + -- if K = Ada.Tags.TK_Limited_Tagged then + -- ; + -- + + -- else + -- S := + -- Ada.Tags.Get_Offset_Index + -- (Ada.Tags.Tag (), DT_Position ()); + + -- _Disp_Timed_Select (, S, P'Address, DX, M, C, B); + + -- if C = POK_Protected_Entry + -- or else C = POK_Task_Entry + -- then + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + -- end if; + + -- if B then + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure + -- then + -- ; + -- end if; + + -- + -- else + -- + -- end if; + -- end if; + -- end; + + procedure Expand_N_Timed_Entry_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + E_Call : Node_Id := + Entry_Call_Statement (Entry_Call_Alternative (N)); + E_Stats : constant List_Id := + Statements (Entry_Call_Alternative (N)); + D_Stat : Node_Id := + Delay_Statement (Delay_Alternative (N)); + D_Stats : constant List_Id := + Statements (Delay_Alternative (N)); + + Actuals : List_Id; + Blk_Typ : Entity_Id; + Call : Node_Id; + Call_Ent : Entity_Id; + Conc_Typ_Stmts : List_Id; + Concval : Node_Id; + D_Conv : Node_Id; + D_Disc : Node_Id; + D_Type : Entity_Id; + Decls : List_Id; + Dummy : Node_Id; + Ename : Node_Id; + Formals : List_Id; + Index : Node_Id; + Is_Disp_Select : Boolean; + Lim_Typ_Stmts : List_Id; + N_Stats : List_Id; + Obj : Entity_Id; + Param : Node_Id; + Params : List_Id; + Stmt : Node_Id; + Stmts : List_Id; + Unpack : List_Id; + + B : Entity_Id; -- Call status flag + C : Entity_Id; -- Call kind + D : Entity_Id; -- Delay + K : Entity_Id; -- Tagged kind + M : Entity_Id; -- Delay mode + P : Entity_Id; -- Parameter block + S : Entity_Id; -- Primitive operation slot + + begin + -- Under the Ravenscar profile, timed entry calls are excluded. An error + -- was already reported on spec, so do not attempt to expand the call. + + if Restriction_Active (No_Select_Statements) then + return; + end if; + + -- The arguments in the call may require dynamic allocation, and the + -- call statement may have been transformed into a block. The block + -- may contain additional declarations for internal entities, and the + -- original call is found by sequential search. + + if Nkind (E_Call) = N_Block_Statement then + E_Call := First (Statements (Handled_Statement_Sequence (E_Call))); + while not Nkind_In (E_Call, N_Procedure_Call_Statement, + N_Entry_Call_Statement) + loop + Next (E_Call); + end loop; + end if; + + Is_Disp_Select := + Ada_Version >= Ada_2005 + and then Nkind (E_Call) = N_Procedure_Call_Statement; + + if Is_Disp_Select then + Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals); + + Decls := New_List; + Stmts := New_List; + + -- Generate: + -- B : Boolean := False; + + B := Build_B (Loc, Decls); + + -- Generate: + -- C : Ada.Tags.Prim_Op_Kind; + + C := Build_C (Loc, Decls); + + -- Because the analysis of all statements was disabled, manually + -- analyze the delay statement. + + Analyze (D_Stat); + D_Stat := Original_Node (D_Stat); + + else + -- Build an entry call using Simple_Entry_Call + + Extract_Entry (E_Call, Concval, Ename, Index); + Build_Simple_Entry_Call (E_Call, Concval, Ename, Index); + + Decls := Declarations (E_Call); + Stmts := Statements (Handled_Statement_Sequence (E_Call)); + + if No (Decls) then + Decls := New_List; + end if; + + -- Generate: + -- B : Boolean; + + B := Make_Defining_Identifier (Loc, Name_uB); + + Prepend_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + B, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc))); + end if; + + -- Duration and mode processing + + D_Type := Base_Type (Etype (Expression (D_Stat))); + + -- Use the type of the delay expression (Calendar or Real_Time) to + -- generate the appropriate conversion. + + if Nkind (D_Stat) = N_Delay_Relative_Statement then + D_Disc := Make_Integer_Literal (Loc, 0); + D_Conv := Relocate_Node (Expression (D_Stat)); + + elsif Is_RTE (D_Type, RO_CA_Time) then + D_Disc := Make_Integer_Literal (Loc, 1); + D_Conv := Make_Function_Call (Loc, + New_Reference_To (RTE (RO_CA_To_Duration), Loc), + New_List (New_Copy (Expression (D_Stat)))); + + else pragma Assert (Is_RTE (D_Type, RO_RT_Time)); + D_Disc := Make_Integer_Literal (Loc, 2); + D_Conv := Make_Function_Call (Loc, + New_Reference_To (RTE (RO_RT_To_Duration), Loc), + New_List (New_Copy (Expression (D_Stat)))); + end if; + + D := Make_Temporary (Loc, 'D'); + + -- Generate: + -- D : Duration; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + D, + Object_Definition => + New_Reference_To (Standard_Duration, Loc))); + + M := Make_Temporary (Loc, 'M'); + + -- Generate: + -- M : Integer := (0 | 1 | 2); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + M, + Object_Definition => + New_Reference_To (Standard_Integer, Loc), + Expression => + D_Disc)); + + -- Do the assignment at this stage only because the evaluation of the + -- expression must not occur before (see ACVC C97302A). + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (D, Loc), + Expression => + D_Conv)); + + -- Parameter block processing + + -- Manually create the parameter block for dispatching calls. In the + -- case of entries, the block has already been created during the call + -- to Build_Simple_Entry_Call. + + if Is_Disp_Select then + + -- Tagged kind processing, generate: + -- K : Ada.Tags.Tagged_Kind := + -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag )); + + K := Build_K (Loc, Decls, Obj); + + Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); + P := Parameter_Block_Pack + (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); + + -- Dispatch table slot processing, generate: + -- S : Integer; + + S := Build_S (Loc, Decls); + + -- Generate: + -- S := Ada.Tags.Get_Offset_Index + -- (Ada.Tags.Tag (), DT_Position (Call_Ent)); + + Conc_Typ_Stmts := + New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); + + -- Generate: + -- _Disp_Timed_Select (, S, P'Address, D, M, C, B); + + -- where Obj is the controlling formal parameter, S is the dispatch + -- table slot number of the dispatching operation, P is the wrapped + -- parameter block, D is the duration, M is the duration mode, C is + -- the call kind and B is the call status. + + Params := New_List; + + Append_To (Params, New_Copy_Tree (Obj)); + Append_To (Params, New_Reference_To (S, Loc)); + Append_To (Params, Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (P, Loc), + Attribute_Name => Name_Address)); + Append_To (Params, New_Reference_To (D, Loc)); + Append_To (Params, New_Reference_To (M, Loc)); + Append_To (Params, New_Reference_To (C, Loc)); + Append_To (Params, New_Reference_To (B, Loc)); + + Append_To (Conc_Typ_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + Find_Prim_Op (Etype (Etype (Obj)), + Name_uDisp_Timed_Select), + Loc), + Parameter_Associations => + Params)); + + -- Generate: + -- if C = POK_Protected_Entry + -- or else C = POK_Task_Entry + -- then + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + -- end if; + + Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals); + + -- Generate the if statement only when the packed parameters need + -- explicit assignments to their corresponding actuals. + + if Present (Unpack) then + Append_To (Conc_Typ_Stmts, + Make_If_Statement (Loc, + + Condition => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE ( + RE_POK_Protected_Entry), Loc)), + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_POK_Task_Entry), Loc))), + + Then_Statements => + Unpack)); + end if; + + -- Generate: + + -- if B then + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure + -- then + -- + -- end if; + -- + -- else + -- + -- end if; + + N_Stats := New_Copy_List_Tree (E_Stats); + + Prepend_To (N_Stats, + Make_If_Statement (Loc, + + Condition => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_POK_Procedure), Loc)), + Right_Opnd => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE ( + RE_POK_Protected_Procedure), Loc)), + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE ( + RE_POK_Task_Procedure), Loc)))), + + Then_Statements => + New_List (E_Call))); + + Append_To (Conc_Typ_Stmts, + Make_If_Statement (Loc, + Condition => New_Reference_To (B, Loc), + Then_Statements => N_Stats, + Else_Statements => D_Stats)); + + -- Generate: + -- ; + -- + + Lim_Typ_Stmts := New_Copy_List_Tree (E_Stats); + Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (E_Call)); + + -- Generate: + -- if K = Ada.Tags.TK_Limited_Tagged then + -- Lim_Typ_Stmts + -- else + -- Conc_Typ_Stmts + -- end if; + + Append_To (Stmts, + Make_If_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (K, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)), + + Then_Statements => + Lim_Typ_Stmts, + + Else_Statements => + Conc_Typ_Stmts)); + + else + -- Skip assignments to temporaries created for in-out parameters. + -- This makes unwarranted assumptions about the shape of the expanded + -- tree for the call, and should be cleaned up ??? + + Stmt := First (Stmts); + while Nkind (Stmt) /= N_Procedure_Call_Statement loop + Next (Stmt); + end loop; + + -- Do the assignment at this stage only because the evaluation + -- of the expression must not occur before (see ACVC C97302A). + + Insert_Before (Stmt, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (D, Loc), + Expression => D_Conv)); + + Call := Stmt; + Params := Parameter_Associations (Call); + + -- For a protected type, we build a Timed_Protected_Entry_Call + + if Is_Protected_Type (Etype (Concval)) then + + -- Create a new call statement + + Param := First (Params); + while Present (Param) + and then not Is_RTE (Etype (Param), RE_Call_Modes) + loop + Next (Param); + end loop; + + Dummy := Remove_Next (Next (Param)); + + -- Remove garbage is following the Cancel_Param if present + + Dummy := Next (Param); + + -- Remove the mode of the Protected_Entry_Call call, then remove + -- the Communication_Block of the Protected_Entry_Call call, and + -- finally add Duration and a Delay_Mode parameter + + pragma Assert (Present (Param)); + Rewrite (Param, New_Reference_To (D, Loc)); + + Rewrite (Dummy, New_Reference_To (M, Loc)); + + -- Add a Boolean flag for successful entry call + + Append_To (Params, New_Reference_To (B, Loc)); + + case Corresponding_Runtime_Package (Etype (Concval)) is + when System_Tasking_Protected_Objects_Entries => + Rewrite (Call, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To + (RTE (RE_Timed_Protected_Entry_Call), Loc), + Parameter_Associations => Params)); + + when System_Tasking_Protected_Objects_Single_Entry => + Param := First (Params); + while Present (Param) + and then not + Is_RTE (Etype (Param), RE_Protected_Entry_Index) + loop + Next (Param); + end loop; + + Remove (Param); + + Rewrite (Call, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + RTE (RE_Timed_Protected_Single_Entry_Call), Loc), + Parameter_Associations => Params)); + + when others => + raise Program_Error; + end case; + + -- For the task case, build a Timed_Task_Entry_Call + + else + -- Create a new call statement + + Append_To (Params, New_Reference_To (D, Loc)); + Append_To (Params, New_Reference_To (M, Loc)); + Append_To (Params, New_Reference_To (B, Loc)); + + Rewrite (Call, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc), + Parameter_Associations => Params)); + end if; + + Append_To (Stmts, + Make_Implicit_If_Statement (N, + Condition => New_Reference_To (B, Loc), + Then_Statements => E_Stats, + Else_Statements => D_Stats)); + end if; + + Rewrite (N, + Make_Block_Statement (Loc, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts))); + + Analyze (N); + end Expand_N_Timed_Entry_Call; + + ---------------------------------------- + -- Expand_Protected_Body_Declarations -- + ---------------------------------------- + + procedure Expand_Protected_Body_Declarations + (N : Node_Id; + Spec_Id : Entity_Id) + is + begin + if No_Run_Time_Mode then + Error_Msg_CRT ("protected body", N); + return; + + elsif Expander_Active then + + -- Associate discriminals with the first subprogram or entry body to + -- be expanded. + + if Present (First_Protected_Operation (Declarations (N))) then + Set_Discriminals (Parent (Spec_Id)); + end if; + end if; + end Expand_Protected_Body_Declarations; + + ------------------------- + -- External_Subprogram -- + ------------------------- + + function External_Subprogram (E : Entity_Id) return Entity_Id is + Subp : constant Entity_Id := Protected_Body_Subprogram (E); + + begin + -- The internal and external subprograms follow each other on the entity + -- chain. Note that previously private operations had no separate + -- external subprogram. We now create one in all cases, because a + -- private operation may actually appear in an external call, through + -- a 'Access reference used for a callback. + + -- If the operation is a function that returns an anonymous access type, + -- the corresponding itype appears before the operation, and must be + -- skipped. + + -- This mechanism is fragile, there should be a real link between the + -- two versions of the operation, but there is no place to put it ??? + + if Is_Access_Type (Next_Entity (Subp)) then + return Next_Entity (Next_Entity (Subp)); + else + return Next_Entity (Subp); + end if; + end External_Subprogram; + + ------------------------------ + -- Extract_Dispatching_Call -- + ------------------------------ + + procedure Extract_Dispatching_Call + (N : Node_Id; + Call_Ent : out Entity_Id; + Object : out Entity_Id; + Actuals : out List_Id; + Formals : out List_Id) + is + Call_Nam : Node_Id; + + begin + pragma Assert (Nkind (N) = N_Procedure_Call_Statement); + + if Present (Original_Node (N)) then + Call_Nam := Name (Original_Node (N)); + else + Call_Nam := Name (N); + end if; + + -- Retrieve the name of the dispatching procedure. It contains the + -- dispatch table slot number. + + loop + case Nkind (Call_Nam) is + when N_Identifier => + exit; + + when N_Selected_Component => + Call_Nam := Selector_Name (Call_Nam); + + when others => + raise Program_Error; + + end case; + end loop; + + Actuals := Parameter_Associations (N); + Call_Ent := Entity (Call_Nam); + Formals := Parameter_Specifications (Parent (Call_Ent)); + Object := First (Actuals); + + if Present (Original_Node (Object)) then + Object := Original_Node (Object); + end if; + end Extract_Dispatching_Call; + + ------------------- + -- Extract_Entry -- + ------------------- + + procedure Extract_Entry + (N : Node_Id; + Concval : out Node_Id; + Ename : out Node_Id; + Index : out Node_Id) + is + Nam : constant Node_Id := Name (N); + + begin + -- For a simple entry, the name is a selected component, with the + -- prefix being the task value, and the selector being the entry. + + if Nkind (Nam) = N_Selected_Component then + Concval := Prefix (Nam); + Ename := Selector_Name (Nam); + Index := Empty; + + -- For a member of an entry family, the name is an indexed component + -- where the prefix is a selected component, whose prefix in turn is + -- the task value, and whose selector is the entry family. The single + -- expression in the expressions list of the indexed component is the + -- subscript for the family. + + else pragma Assert (Nkind (Nam) = N_Indexed_Component); + Concval := Prefix (Prefix (Nam)); + Ename := Selector_Name (Prefix (Nam)); + Index := First (Expressions (Nam)); + end if; + end Extract_Entry; + + ------------------- + -- Family_Offset -- + ------------------- + + function Family_Offset + (Loc : Source_Ptr; + Hi : Node_Id; + Lo : Node_Id; + Ttyp : Entity_Id; + Cap : Boolean) return Node_Id + is + Ityp : Entity_Id; + Real_Hi : Node_Id; + Real_Lo : Node_Id; + + function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; + -- If one of the bounds is a reference to a discriminant, replace with + -- corresponding discriminal of type. Within the body of a task retrieve + -- the renamed discriminant by simple visibility, using its generated + -- name. Within a protected object, find the original discriminant and + -- replace it with the discriminal of the current protected operation. + + ------------------------------ + -- Convert_Discriminant_Ref -- + ------------------------------ + + function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (Bound); + B : Node_Id; + D : Entity_Id; + + begin + if Is_Entity_Name (Bound) + and then Ekind (Entity (Bound)) = E_Discriminant + then + if Is_Task_Type (Ttyp) + and then Has_Completion (Ttyp) + then + B := Make_Identifier (Loc, Chars (Entity (Bound))); + Find_Direct_Name (B); + + elsif Is_Protected_Type (Ttyp) then + D := First_Discriminant (Ttyp); + while Chars (D) /= Chars (Entity (Bound)) loop + Next_Discriminant (D); + end loop; + + B := New_Reference_To (Discriminal (D), Loc); + + else + B := New_Reference_To (Discriminal (Entity (Bound)), Loc); + end if; + + elsif Nkind (Bound) = N_Attribute_Reference then + return Bound; + + else + B := New_Copy_Tree (Bound); + end if; + + return + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Pos, + Prefix => New_Occurrence_Of (Etype (Bound), Loc), + Expressions => New_List (B)); + end Convert_Discriminant_Ref; + + -- Start of processing for Family_Offset + + begin + Real_Hi := Convert_Discriminant_Ref (Hi); + Real_Lo := Convert_Discriminant_Ref (Lo); + + if Cap then + if Is_Task_Type (Ttyp) then + Ityp := RTE (RE_Task_Entry_Index); + else + Ityp := RTE (RE_Protected_Entry_Index); + end if; + + Real_Hi := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ityp, Loc), + Attribute_Name => Name_Min, + Expressions => New_List ( + Real_Hi, + Make_Integer_Literal (Loc, Entry_Family_Bound - 1))); + + Real_Lo := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ityp, Loc), + Attribute_Name => Name_Max, + Expressions => New_List ( + Real_Lo, + Make_Integer_Literal (Loc, -Entry_Family_Bound))); + end if; + + return Make_Op_Subtract (Loc, Real_Hi, Real_Lo); + end Family_Offset; + + ----------------- + -- Family_Size -- + ----------------- + + function Family_Size + (Loc : Source_Ptr; + Hi : Node_Id; + Lo : Node_Id; + Ttyp : Entity_Id; + Cap : Boolean) return Node_Id + is + Ityp : Entity_Id; + + begin + if Is_Task_Type (Ttyp) then + Ityp := RTE (RE_Task_Entry_Index); + else + Ityp := RTE (RE_Protected_Entry_Index); + end if; + + return + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ityp, Loc), + Attribute_Name => Name_Max, + Expressions => New_List ( + Make_Op_Add (Loc, + Left_Opnd => + Family_Offset (Loc, Hi, Lo, Ttyp, Cap), + Right_Opnd => + Make_Integer_Literal (Loc, 1)), + Make_Integer_Literal (Loc, 0))); + end Family_Size; + + ----------------------- + -- Find_Master_Scope -- + ----------------------- + + function Find_Master_Scope (E : Entity_Id) return Entity_Id is + S : Entity_Id; + + begin + -- In Ada2005, the master is the innermost enclosing scope that is not + -- transient. If the enclosing block is the rewriting of a call or the + -- scope is an extended return statement this is valid master. The + -- master in an extended return is only used within the return, and is + -- subsequently overwritten in Move_Activation_Chain, but it must exist + -- now before that overwriting occurs. + + S := Scope (E); + + if Ada_Version >= Ada_2005 then + while Is_Internal (S) loop + if Nkind (Parent (S)) = N_Block_Statement + and then + Nkind (Original_Node (Parent (S))) = N_Procedure_Call_Statement + then + exit; + + elsif Ekind (S) = E_Return_Statement then + exit; + + else + S := Scope (S); + end if; + end loop; + end if; + + return S; + end Find_Master_Scope; + + ----------------------------------- + -- Find_Task_Or_Protected_Pragma -- + ----------------------------------- + + function Find_Task_Or_Protected_Pragma + (T : Node_Id; + P : Name_Id) return Node_Id + is + N : Node_Id; + + begin + N := First (Visible_Declarations (T)); + while Present (N) loop + if Nkind (N) = N_Pragma then + if Pragma_Name (N) = P then + return N; + + elsif P = Name_Priority + and then Pragma_Name (N) = Name_Interrupt_Priority + then + return N; + + else + Next (N); + end if; + + else + Next (N); + end if; + end loop; + + N := First (Private_Declarations (T)); + while Present (N) loop + if Nkind (N) = N_Pragma then + if Pragma_Name (N) = P then + return N; + + elsif P = Name_Priority + and then Pragma_Name (N) = Name_Interrupt_Priority + then + return N; + + else + Next (N); + end if; + + else + Next (N); + end if; + end loop; + + raise Program_Error; + end Find_Task_Or_Protected_Pragma; + + ------------------------------- + -- First_Protected_Operation -- + ------------------------------- + + function First_Protected_Operation (D : List_Id) return Node_Id is + First_Op : Node_Id; + + begin + First_Op := First (D); + while Present (First_Op) + and then not Nkind_In (First_Op, N_Subprogram_Body, N_Entry_Body) + loop + Next (First_Op); + end loop; + + return First_Op; + end First_Protected_Operation; + + --------------------------------------- + -- Install_Private_Data_Declarations -- + --------------------------------------- + + procedure Install_Private_Data_Declarations + (Loc : Source_Ptr; + Spec_Id : Entity_Id; + Conc_Typ : Entity_Id; + Body_Nod : Node_Id; + Decls : List_Id; + Barrier : Boolean := False; + Family : Boolean := False) + is + Is_Protected : constant Boolean := Is_Protected_Type (Conc_Typ); + Decl : Node_Id; + Def : Node_Id; + Insert_Node : Node_Id := Empty; + Obj_Ent : Entity_Id; + + procedure Add (Decl : Node_Id); + -- Add a single declaration after Insert_Node. If this is the first + -- addition, Decl is added to the front of Decls and it becomes the + -- insertion node. + + function Replace_Bound (Bound : Node_Id) return Node_Id; + -- The bounds of an entry index may depend on discriminants, create a + -- reference to the corresponding prival. Otherwise return a duplicate + -- of the original bound. + + --------- + -- Add -- + --------- + + procedure Add (Decl : Node_Id) is + begin + if No (Insert_Node) then + Prepend_To (Decls, Decl); + else + Insert_After (Insert_Node, Decl); + end if; + + Insert_Node := Decl; + end Add; + + -------------------------- + -- Replace_Discriminant -- + -------------------------- + + function Replace_Bound (Bound : Node_Id) return Node_Id is + begin + if Nkind (Bound) = N_Identifier + and then Is_Discriminal (Entity (Bound)) + then + return Make_Identifier (Loc, Chars (Entity (Bound))); + else + return Duplicate_Subexpr (Bound); + end if; + end Replace_Bound; + + -- Start of processing for Install_Private_Data_Declarations + + begin + -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote + -- formal parameter _O, _object or _task depending on the context. + + Obj_Ent := Concurrent_Object (Spec_Id, Conc_Typ); + + -- Special processing of _O for barrier functions, protected entries + -- and families. + + if Barrier + or else + (Is_Protected + and then + (Ekind (Spec_Id) = E_Entry + or else Ekind (Spec_Id) = E_Entry_Family)) + then + declare + Conc_Rec : constant Entity_Id := + Corresponding_Record_Type (Conc_Typ); + Typ_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Conc_Rec), 'P')); + begin + -- Generate: + -- type prot_typVP is access prot_typV; + + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Typ_Id, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Reference_To (Conc_Rec, Loc))); + Add (Decl); + + -- Generate: + -- _object : prot_typVP := prot_typV (_O); + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uObject), + Object_Definition => New_Reference_To (Typ_Id, Loc), + Expression => + Unchecked_Convert_To (Typ_Id, + New_Reference_To (Obj_Ent, Loc))); + Add (Decl); + + -- Set the reference to the concurrent object + + Obj_Ent := Defining_Identifier (Decl); + end; + end if; + + -- Step 2: Create the Protection object and build its declaration for + -- any protected entry (family) of subprogram. + + if Is_Protected then + declare + Prot_Ent : constant Entity_Id := Make_Temporary (Loc, 'R'); + Prot_Typ : RE_Id; + + begin + Set_Protection_Object (Spec_Id, Prot_Ent); + + -- Determine the proper protection type + + if Has_Attach_Handler (Conc_Typ) + and then not Restricted_Profile + then + Prot_Typ := RE_Static_Interrupt_Protection; + + elsif Has_Interrupt_Handler (Conc_Typ) then + Prot_Typ := RE_Dynamic_Interrupt_Protection; + + -- The type has explicit entries or generated primitive entry + -- wrappers. + + elsif Has_Entries (Conc_Typ) + or else + (Ada_Version >= Ada_2005 + and then Present (Interface_List (Parent (Conc_Typ)))) + then + case Corresponding_Runtime_Package (Conc_Typ) is + when System_Tasking_Protected_Objects_Entries => + Prot_Typ := RE_Protection_Entries; + + when System_Tasking_Protected_Objects_Single_Entry => + Prot_Typ := RE_Protection_Entry; + + when others => + raise Program_Error; + end case; + + else + Prot_Typ := RE_Protection; + end if; + + -- Generate: + -- conc_typR : protection_typ renames _object._object; + + Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Prot_Ent, + Subtype_Mark => + New_Reference_To (RTE (Prot_Typ), Loc), + Name => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Obj_Ent, Loc), + Selector_Name => Make_Identifier (Loc, Name_uObject))); + Add (Decl); + end; + end if; + + -- Step 3: Add discriminant renamings (if any) + + if Has_Discriminants (Conc_Typ) then + declare + D : Entity_Id; + + begin + D := First_Discriminant (Conc_Typ); + while Present (D) loop + + -- Adjust the source location + + Set_Sloc (Discriminal (D), Loc); + + -- Generate: + -- discr_name : discr_typ renames _object.discr_name; + -- or + -- discr_name : discr_typ renames _task.discr_name; + + Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Discriminal (D), + Subtype_Mark => New_Reference_To (Etype (D), Loc), + Name => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Obj_Ent, Loc), + Selector_Name => Make_Identifier (Loc, Chars (D)))); + Add (Decl); + + Next_Discriminant (D); + end loop; + end; + end if; + + -- Step 4: Add private component renamings (if any) + + if Is_Protected then + Def := Protected_Definition (Parent (Conc_Typ)); + + if Present (Private_Declarations (Def)) then + declare + Comp : Node_Id; + Comp_Id : Entity_Id; + Decl_Id : Entity_Id; + + begin + Comp := First (Private_Declarations (Def)); + while Present (Comp) loop + if Nkind (Comp) = N_Component_Declaration then + Comp_Id := Defining_Identifier (Comp); + Decl_Id := + Make_Defining_Identifier (Loc, Chars (Comp_Id)); + + -- Minimal decoration + + if Ekind (Spec_Id) = E_Function then + Set_Ekind (Decl_Id, E_Constant); + else + Set_Ekind (Decl_Id, E_Variable); + end if; + + Set_Prival (Comp_Id, Decl_Id); + Set_Prival_Link (Decl_Id, Comp_Id); + Set_Is_Aliased (Decl_Id, Is_Aliased (Comp_Id)); + + -- Generate: + -- comp_name : comp_typ renames _object.comp_name; + + Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Decl_Id, + Subtype_Mark => + New_Reference_To (Etype (Comp_Id), Loc), + Name => + Make_Selected_Component (Loc, + Prefix => + New_Reference_To (Obj_Ent, Loc), + Selector_Name => + Make_Identifier (Loc, Chars (Comp_Id)))); + Add (Decl); + end if; + + Next (Comp); + end loop; + end; + end if; + end if; + + -- Step 5: Add the declaration of the entry index and the associated + -- type for barrier functions and entry families. + + if (Barrier and then Family) + or else Ekind (Spec_Id) = E_Entry_Family + then + declare + E : constant Entity_Id := Index_Object (Spec_Id); + Index : constant Entity_Id := + Defining_Identifier ( + Entry_Index_Specification ( + Entry_Body_Formal_Part (Body_Nod))); + Index_Con : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars (Index)); + High : Node_Id; + Index_Typ : Entity_Id; + Low : Node_Id; + + begin + -- Minimal decoration + + Set_Ekind (Index_Con, E_Constant); + Set_Entry_Index_Constant (Index, Index_Con); + Set_Discriminal_Link (Index_Con, Index); + + -- Retrieve the bounds of the entry family + + High := Type_High_Bound (Etype (Index)); + Low := Type_Low_Bound (Etype (Index)); + + -- In the simple case the entry family is given by a subtype + -- mark and the index constant has the same type. + + if Is_Entity_Name (Original_Node ( + Discrete_Subtype_Definition (Parent (Index)))) + then + Index_Typ := Etype (Index); + + -- Otherwise a new subtype declaration is required + + else + High := Replace_Bound (High); + Low := Replace_Bound (Low); + + Index_Typ := Make_Temporary (Loc, 'J'); + + -- Generate: + -- subtype Jnn is range Low .. High; + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Index_Typ, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To (Base_Type (Etype (Index)), Loc), + Constraint => + Make_Range_Constraint (Loc, + Range_Expression => + Make_Range (Loc, Low, High)))); + Add (Decl); + end if; + + Set_Etype (Index_Con, Index_Typ); + + -- Create the object which designates the index: + -- J : constant Jnn := + -- Jnn'Val (_E - + Jnn'Pos (Jnn'First)); + -- + -- where Jnn is the subtype created above or the original type of + -- the index, _E is a formal of the protected body subprogram and + -- is the index of the first family member. + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Index_Con, + Constant_Present => True, + Object_Definition => + New_Reference_To (Index_Typ, Loc), + + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Index_Typ, Loc), + Attribute_Name => Name_Val, + + Expressions => New_List ( + + Make_Op_Add (Loc, + Left_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => + New_Reference_To (E, Loc), + Right_Opnd => + Entry_Index_Expression (Loc, + Defining_Identifier (Body_Nod), + Empty, Conc_Typ)), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Index_Typ, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Index_Typ, Loc), + Attribute_Name => Name_First))))))); + Add (Decl); + end; + end if; + end Install_Private_Data_Declarations; + + --------------------------------- + -- Is_Potentially_Large_Family -- + --------------------------------- + + function Is_Potentially_Large_Family + (Base_Index : Entity_Id; + Conctyp : Entity_Id; + Lo : Node_Id; + Hi : Node_Id) return Boolean + is + begin + return Scope (Base_Index) = Standard_Standard + and then Base_Index = Base_Type (Standard_Integer) + and then Has_Discriminants (Conctyp) + and then Present + (Discriminant_Default_Value (First_Discriminant (Conctyp))) + and then + (Denotes_Discriminant (Lo, True) + or else Denotes_Discriminant (Hi, True)); + end Is_Potentially_Large_Family; + + ------------------------------------- + -- Is_Private_Primitive_Subprogram -- + ------------------------------------- + + function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean is + begin + return + (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure) + and then Is_Private_Primitive (Id); + end Is_Private_Primitive_Subprogram; + + ------------------ + -- Index_Object -- + ------------------ + + function Index_Object (Spec_Id : Entity_Id) return Entity_Id is + Bod_Subp : constant Entity_Id := Protected_Body_Subprogram (Spec_Id); + Formal : Entity_Id; + + begin + Formal := First_Formal (Bod_Subp); + while Present (Formal) loop + + -- Look for formal parameter _E + + if Chars (Formal) = Name_uE then + return Formal; + end if; + + Next_Formal (Formal); + end loop; + + -- A protected body subprogram should always have the parameter in + -- question. + + raise Program_Error; + end Index_Object; + + -------------------------------- + -- Make_Initialize_Protection -- + -------------------------------- + + function Make_Initialize_Protection + (Protect_Rec : Entity_Id) return List_Id + is + Loc : constant Source_Ptr := Sloc (Protect_Rec); + P_Arr : Entity_Id; + Pdef : Node_Id; + Pdec : Node_Id; + Ptyp : constant Node_Id := + Corresponding_Concurrent_Type (Protect_Rec); + Args : List_Id; + L : constant List_Id := New_List; + Has_Entry : constant Boolean := Has_Entries (Ptyp); + Restricted : constant Boolean := Restricted_Profile; + + begin + -- We may need two calls to properly initialize the object, one to + -- Initialize_Protection, and possibly one to Install_Handlers if we + -- have a pragma Attach_Handler. + + -- Get protected declaration. In the case of a task type declaration, + -- this is simply the parent of the protected type entity. In the single + -- protected object declaration, this parent will be the implicit type, + -- and we can find the corresponding single protected object declaration + -- by searching forward in the declaration list in the tree. + + -- Is the test for N_Single_Protected_Declaration needed here??? Nodes + -- of this type should have been removed during semantic analysis. + + Pdec := Parent (Ptyp); + while not Nkind_In (Pdec, N_Protected_Type_Declaration, + N_Single_Protected_Declaration) + loop + Next (Pdec); + end loop; + + -- Now we can find the object definition from this declaration + + Pdef := Protected_Definition (Pdec); + + -- Build the parameter list for the call. Note that _Init is the name + -- of the formal for the object to be initialized, which is the task + -- value record itself. + + Args := New_List; + + -- Object parameter. This is a pointer to the object of type + -- Protection used by the GNARL to control the protected object. + + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access)); + + -- Priority parameter. Set to Unspecified_Priority unless there is a + -- priority pragma, in which case we take the value from the pragma, + -- or there is an interrupt pragma and no priority pragma, and we + -- set the ceiling to Interrupt_Priority'Last, an implementation- + -- defined value, see D.3(10). + + if Present (Pdef) + and then Has_Pragma_Priority (Pdef) + then + declare + Prio : constant Node_Id := + Expression + (First + (Pragma_Argument_Associations + (Find_Task_Or_Protected_Pragma + (Pdef, Name_Priority)))); + Temp : Entity_Id; + + begin + -- If priority is a static expression, then we can duplicate it + -- with no problem and simply append it to the argument list. + + if Is_Static_Expression (Prio) then + Append_To (Args, + Duplicate_Subexpr_No_Checks (Prio)); + + -- Otherwise, the priority may be a per-object expression, if it + -- depends on a discriminant of the type. In this case, create + -- local variable to capture the expression. Note that it is + -- really necessary to create this variable explicitly. It might + -- be thought that removing side effects would the appropriate + -- approach, but that could generate declarations improperly + -- placed in the enclosing scope. + + -- Note: Use System.Any_Priority as the expected type for the + -- non-static priority expression, in case the expression has not + -- been analyzed yet (as occurs for example with pragma + -- Interrupt_Priority). + + else + Temp := Make_Temporary (Loc, 'R', Prio); + Append_To (L, + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any_Priority), Loc), + Expression => Relocate_Node (Prio))); + + Append_To (Args, New_Occurrence_Of (Temp, Loc)); + end if; + end; + + -- When no priority is specified but an xx_Handler pragma is, we default + -- to System.Interrupts.Default_Interrupt_Priority, see D.3(10). + + elsif Has_Interrupt_Handler (Ptyp) + or else Has_Attach_Handler (Ptyp) + then + Append_To (Args, + New_Reference_To (RTE (RE_Default_Interrupt_Priority), Loc)); + + -- Normal case, no priority or xx_Handler specified, default priority + + else + Append_To (Args, + New_Reference_To (RTE (RE_Unspecified_Priority), Loc)); + end if; + + -- Test for Compiler_Info parameter. This parameter allows entry body + -- procedures and barrier functions to be called from the runtime. It + -- is a pointer to the record generated by the compiler to represent + -- the protected object. + + -- A protected type without entries that covers an interface and + -- overrides the abstract routines with protected procedures is + -- considered equivalent to a protected type with entries in the + -- context of dispatching select statements. + + if Has_Entry + or else Has_Interrupt_Handler (Ptyp) + or else Has_Attach_Handler (Ptyp) + or else Has_Interfaces (Protect_Rec) + then + declare + Pkg_Id : constant RTU_Id := + Corresponding_Runtime_Package (Ptyp); + Called_Subp : RE_Id; + + begin + case Pkg_Id is + when System_Tasking_Protected_Objects_Entries => + Called_Subp := RE_Initialize_Protection_Entries; + + when System_Tasking_Protected_Objects => + Called_Subp := RE_Initialize_Protection; + + when System_Tasking_Protected_Objects_Single_Entry => + Called_Subp := RE_Initialize_Protection_Entry; + + when others => + raise Program_Error; + end case; + + if Has_Entry + or else not Restricted + or else Has_Interfaces (Protect_Rec) + then + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Attribute_Name => Name_Address)); + end if; + + -- Entry_Bodies parameter. This is a pointer to an array of + -- pointers to the entry body procedures and barrier functions of + -- the object. If the protected type has no entries this object + -- will not exist, in this case, pass a null. + + if Has_Entry then + P_Arr := Entry_Bodies_Array (Ptyp); + + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (P_Arr, Loc), + Attribute_Name => Name_Unrestricted_Access)); + + if Pkg_Id = System_Tasking_Protected_Objects_Entries then + + -- Find index mapping function (clumsy but ok for now) + + while Ekind (P_Arr) /= E_Function loop + Next_Entity (P_Arr); + end loop; + + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (P_Arr, Loc), + Attribute_Name => Name_Unrestricted_Access)); + + -- Build_Entry_Names generation flag. When set to true, the + -- runtime will allocate an array to hold the string names + -- of protected entries. + + if not Restricted_Profile then + if Entry_Names_OK then + Append_To (Args, + New_Reference_To (Standard_True, Loc)); + else + Append_To (Args, + New_Reference_To (Standard_False, Loc)); + end if; + end if; + end if; + + elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then + Append_To (Args, Make_Null (Loc)); + + elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then + Append_To (Args, Make_Null (Loc)); + Append_To (Args, Make_Null (Loc)); + Append_To (Args, New_Reference_To (Standard_False, Loc)); + end if; + + Append_To (L, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (Called_Subp), Loc), + Parameter_Associations => Args)); + end; + else + Append_To (L, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Initialize_Protection), Loc), + Parameter_Associations => Args)); + end if; + + if Has_Attach_Handler (Ptyp) then + + -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to + -- make the following call: + + -- Install_Handlers (_object, + -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)); + + -- or, in the case of Ravenscar: + + -- Install_Restricted_Handlers + -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)); + + declare + Args : constant List_Id := New_List; + Table : constant List_Id := New_List; + Ritem : Node_Id := First_Rep_Item (Ptyp); + + begin + -- Build the Attach_Handler table argument + + while Present (Ritem) loop + if Nkind (Ritem) = N_Pragma + and then Pragma_Name (Ritem) = Name_Attach_Handler + then + declare + Handler : constant Node_Id := + First (Pragma_Argument_Associations (Ritem)); + + Interrupt : constant Node_Id := Next (Handler); + Expr : constant Node_Id := Expression (Interrupt); + + begin + Append_To (Table, + Make_Aggregate (Loc, Expressions => New_List ( + Unchecked_Convert_To + (RTE (RE_System_Interrupt_Id), Expr), + Make_Attribute_Reference (Loc, + Prefix => Make_Selected_Component (Loc, + Make_Identifier (Loc, Name_uInit), + Duplicate_Subexpr_No_Checks + (Expression (Handler))), + Attribute_Name => Name_Access)))); + end; + end if; + + Next_Rep_Item (Ritem); + end loop; + + -- Append the table argument we just built + + Append_To (Args, Make_Aggregate (Loc, Table)); + + -- Append the Install_Handlers (or Install_Restricted_Handlers) + -- call to the statements. + + if Restricted then + -- Call a simplified version of Install_Handlers to be used + -- when the Ravenscar restrictions are in effect + -- (Install_Restricted_Handlers). + + Append_To (L, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To + (RTE (RE_Install_Restricted_Handlers), Loc), + Parameter_Associations => Args)); + + else + -- First, prepends the _object argument + + Prepend_To (Args, + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access)); + + -- Then, insert call to Install_Handlers + + Append_To (L, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Install_Handlers), Loc), + Parameter_Associations => Args)); + end if; + end; + end if; + + return L; + end Make_Initialize_Protection; + + --------------------------- + -- Make_Task_Create_Call -- + --------------------------- + + function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (Task_Rec); + Args : List_Id; + Ecount : Node_Id; + Name : Node_Id; + Tdec : Node_Id; + Tdef : Node_Id; + Tnam : Name_Id; + Ttyp : Node_Id; + + begin + Ttyp := Corresponding_Concurrent_Type (Task_Rec); + Tnam := Chars (Ttyp); + + -- Get task declaration. In the case of a task type declaration, this is + -- simply the parent of the task type entity. In the single task + -- declaration, this parent will be the implicit type, and we can find + -- the corresponding single task declaration by searching forward in the + -- declaration list in the tree. + + -- Is the test for N_Single_Task_Declaration needed here??? Nodes of + -- this type should have been removed during semantic analysis. + + Tdec := Parent (Ttyp); + while not Nkind_In (Tdec, N_Task_Type_Declaration, + N_Single_Task_Declaration) + loop + Next (Tdec); + end loop; + + -- Now we can find the task definition from this declaration + + Tdef := Task_Definition (Tdec); + + -- Build the parameter list for the call. Note that _Init is the name + -- of the formal for the object to be initialized, which is the task + -- value record itself. + + Args := New_List; + + -- Priority parameter. Set to Unspecified_Priority unless there is a + -- priority pragma, in which case we take the value from the pragma. + + if Present (Tdef) and then Has_Pragma_Priority (Tdef) then + Append_To (Args, + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => Make_Identifier (Loc, Name_uPriority))); + else + Append_To (Args, + New_Reference_To (RTE (RE_Unspecified_Priority), Loc)); + end if; + + -- Optional Stack parameter + + if Restricted_Profile then + + -- If the stack has been preallocated by the expander then + -- pass its address. Otherwise, pass a null address. + + if Preallocated_Stacks_On_Target then + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => Make_Identifier (Loc, Name_uStack)), + Attribute_Name => Name_Address)); + + else + Append_To (Args, + New_Reference_To (RTE (RE_Null_Address), Loc)); + end if; + end if; + + -- Size parameter. If no Storage_Size pragma is present, then + -- the size is taken from the taskZ variable for the type, which + -- is either Unspecified_Size, or has been reset by the use of + -- a Storage_Size attribute definition clause. If a pragma is + -- present, then the size is taken from the _Size field of the + -- task value record, which was set from the pragma value. + + if Present (Tdef) + and then Has_Storage_Size_Pragma (Tdef) + then + Append_To (Args, + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => Make_Identifier (Loc, Name_uSize))); + + else + Append_To (Args, + New_Reference_To (Storage_Size_Variable (Ttyp), Loc)); + end if; + + -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a + -- Task_Info pragma, in which case we take the value from the pragma. + + if Present (Tdef) + and then Has_Task_Info_Pragma (Tdef) + then + Append_To (Args, + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => Make_Identifier (Loc, Name_uTask_Info))); + + else + Append_To (Args, + New_Reference_To (RTE (RE_Unspecified_Task_Info), Loc)); + end if; + + -- CPU parameter. Set to Unspecified_CPU unless there is a CPU pragma, + -- in which case we take the value from the pragma. The parameter is + -- passed as an Integer because in the case of unspecified CPU the + -- value is not in the range of CPU_Range. + + if Present (Tdef) and then Has_Pragma_CPU (Tdef) then + Append_To (Args, + Convert_To (Standard_Integer, + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => Make_Identifier (Loc, Name_uCPU)))); + + else + Append_To (Args, + New_Reference_To (RTE (RE_Unspecified_CPU), Loc)); + end if; + + if not Restricted_Profile then + + -- Deadline parameter. If no Relative_Deadline pragma is present, + -- then the deadline is Time_Span_Zero. If a pragma is present, then + -- the deadline is taken from the _Relative_Deadline field of the + -- task value record, which was set from the pragma value. Note that + -- this parameter must not be generated for the restricted profiles + -- since Ravenscar does not allow deadlines. + + -- Case where pragma Relative_Deadline applies: use given value + + if Present (Tdef) and then Has_Relative_Deadline_Pragma (Tdef) then + Append_To (Args, + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uInit), + Selector_Name => + Make_Identifier (Loc, Name_uRelative_Deadline))); + + -- No pragma Relative_Deadline apply to the task + + else + Append_To (Args, + New_Reference_To (RTE (RE_Time_Span_Zero), Loc)); + end if; + + -- Number of entries. This is an expression of the form: + + -- n + _Init.a'Length + _Init.a'B'Length + ... + + -- where a,b... are the entry family names for the task definition + + Ecount := + Build_Entry_Count_Expression + (Ttyp, + Component_Items + (Component_List + (Type_Definition + (Parent (Corresponding_Record_Type (Ttyp))))), + Loc); + Append_To (Args, Ecount); + + -- Master parameter. This is a reference to the _Master parameter of + -- the initialization procedure, except in the case of the pragma + -- Restrictions (No_Task_Hierarchy) where the value is fixed to + -- System.Tasking.Library_Task_Level. + + if Restriction_Active (No_Task_Hierarchy) = False then + Append_To (Args, Make_Identifier (Loc, Name_uMaster)); + else + Append_To (Args, + New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc)); + end if; + end if; + + -- State parameter. This is a pointer to the task body procedure. The + -- required value is obtained by taking 'Unrestricted_Access of the task + -- body procedure and converting it (with an unchecked conversion) to + -- the type required by the task kernel. For further details, see the + -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather + -- than 'Address in order to avoid creating trampolines. + + declare + Body_Proc : constant Node_Id := Get_Task_Body_Procedure (Ttyp); + Subp_Ptr_Typ : constant Node_Id := + Create_Itype (E_Access_Subprogram_Type, Tdec); + Ref : constant Node_Id := Make_Itype_Reference (Loc); + + begin + Set_Directly_Designated_Type (Subp_Ptr_Typ, Body_Proc); + Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); + + -- Be sure to freeze a reference to the access-to-subprogram type, + -- otherwise gigi will complain that it's in the wrong scope, because + -- it's actually inside the init procedure for the record type that + -- corresponds to the task type. + + -- This processing is causing a crash in the .NET/JVM back ends that + -- is not yet understood, so skip it in these cases ??? + + if VM_Target = No_VM then + Set_Itype (Ref, Subp_Ptr_Typ); + Append_Freeze_Action (Task_Rec, Ref); + + Append_To (Args, + Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), + Make_Qualified_Expression (Loc, + Subtype_Mark => New_Reference_To (Subp_Ptr_Typ, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Body_Proc, Loc), + Attribute_Name => Name_Unrestricted_Access)))); + + -- For the .NET/JVM cases revert to the original code below ??? + + else + Append_To (Args, + Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Body_Proc, Loc), + Attribute_Name => Name_Address))); + end if; + end; + + -- Discriminants parameter. This is just the address of the task + -- value record itself (which contains the discriminant values + + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Attribute_Name => Name_Address)); + + -- Elaborated parameter. This is an access to the elaboration Boolean + + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, New_External_Name (Tnam, 'E')), + Attribute_Name => Name_Unchecked_Access)); + + -- Chain parameter. This is a reference to the _Chain parameter of + -- the initialization procedure. + + Append_To (Args, Make_Identifier (Loc, Name_uChain)); + + -- Task name parameter. Take this from the _Task_Id parameter to the + -- init call unless there is a Task_Name pragma, in which case we take + -- the value from the pragma. + + if Present (Tdef) + and then Has_Task_Name_Pragma (Tdef) + then + -- Copy expression in full, because it may be dynamic and have + -- side effects. + + Append_To (Args, + New_Copy_Tree + (Expression (First + (Pragma_Argument_Associations + (Find_Task_Or_Protected_Pragma + (Tdef, Name_Task_Name)))))); + + else + Append_To (Args, Make_Identifier (Loc, Name_uTask_Name)); + end if; + + -- Created_Task parameter. This is the _Task_Id field of the task + -- record value + + Append_To (Args, + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => Make_Identifier (Loc, Name_uTask_Id))); + + -- Build_Entry_Names generation flag. When set to true, the runtime + -- will allocate an array to hold the string names of task entries. + + if not Restricted_Profile then + if Has_Entries (Ttyp) + and then Entry_Names_OK + then + Append_To (Args, New_Reference_To (Standard_True, Loc)); + else + Append_To (Args, New_Reference_To (Standard_False, Loc)); + end if; + end if; + + if Restricted_Profile then + Name := New_Reference_To (RTE (RE_Create_Restricted_Task), Loc); + else + Name := New_Reference_To (RTE (RE_Create_Task), Loc); + end if; + + return + Make_Procedure_Call_Statement (Loc, + Name => Name, + Parameter_Associations => Args); + end Make_Task_Create_Call; + + ------------------------------ + -- Next_Protected_Operation -- + ------------------------------ + + function Next_Protected_Operation (N : Node_Id) return Node_Id is + Next_Op : Node_Id; + + begin + Next_Op := Next (N); + while Present (Next_Op) + and then not Nkind_In (Next_Op, N_Subprogram_Body, N_Entry_Body) + loop + Next (Next_Op); + end loop; + + return Next_Op; + end Next_Protected_Operation; + + --------------------- + -- Null_Statements -- + --------------------- + + function Null_Statements (Stats : List_Id) return Boolean is + Stmt : Node_Id; + + begin + Stmt := First (Stats); + while Nkind (Stmt) /= N_Empty + and then (Nkind_In (Stmt, N_Null_Statement, N_Label) + or else + (Nkind (Stmt) = N_Pragma + and then (Pragma_Name (Stmt) = Name_Unreferenced + or else + Pragma_Name (Stmt) = Name_Unmodified + or else + Pragma_Name (Stmt) = Name_Warnings))) + loop + Next (Stmt); + end loop; + + return Nkind (Stmt) = N_Empty; + end Null_Statements; + + -------------------------- + -- Parameter_Block_Pack -- + -------------------------- + + function Parameter_Block_Pack + (Loc : Source_Ptr; + Blk_Typ : Entity_Id; + Actuals : List_Id; + Formals : List_Id; + Decls : List_Id; + Stmts : List_Id) return Node_Id + is + Actual : Entity_Id; + Expr : Node_Id := Empty; + Formal : Entity_Id; + Has_Param : Boolean := False; + P : Entity_Id; + Params : List_Id; + Temp_Asn : Node_Id; + Temp_Nam : Node_Id; + + begin + Actual := First (Actuals); + Formal := Defining_Identifier (First (Formals)); + Params := New_List; + + while Present (Actual) loop + if Is_By_Copy_Type (Etype (Actual)) then + -- Generate: + -- Jnn : aliased + + Temp_Nam := Make_Temporary (Loc, 'J'); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Aliased_Present => + True, + Defining_Identifier => + Temp_Nam, + Object_Definition => + New_Reference_To (Etype (Formal), Loc))); + + if Ekind (Formal) /= E_Out_Parameter then + + -- Generate: + -- Jnn := + + Temp_Asn := + New_Reference_To (Temp_Nam, Loc); + + Set_Assignment_OK (Temp_Asn); + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + Temp_Asn, + Expression => + New_Copy_Tree (Actual))); + end if; + + -- Generate: + -- Jnn'unchecked_access + + Append_To (Params, + Make_Attribute_Reference (Loc, + Attribute_Name => + Name_Unchecked_Access, + Prefix => + New_Reference_To (Temp_Nam, Loc))); + + Has_Param := True; + + -- The controlling parameter is omitted + + else + if not Is_Controlling_Actual (Actual) then + Append_To (Params, + Make_Reference (Loc, New_Copy_Tree (Actual))); + + Has_Param := True; + end if; + end if; + + Next_Actual (Actual); + Next_Formal_With_Extras (Formal); + end loop; + + if Has_Param then + Expr := Make_Aggregate (Loc, Params); + end if; + + -- Generate: + -- P : Ann := ( + -- J1'unchecked_access; + -- 'reference; + -- ...); + + P := Make_Temporary (Loc, 'P'); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + P, + Object_Definition => + New_Reference_To (Blk_Typ, Loc), + Expression => + Expr)); + + return P; + end Parameter_Block_Pack; + + ---------------------------- + -- Parameter_Block_Unpack -- + ---------------------------- + + function Parameter_Block_Unpack + (Loc : Source_Ptr; + P : Entity_Id; + Actuals : List_Id; + Formals : List_Id) return List_Id + is + Actual : Entity_Id; + Asnmt : Node_Id; + Formal : Entity_Id; + Has_Asnmt : Boolean := False; + Result : constant List_Id := New_List; + + begin + Actual := First (Actuals); + Formal := Defining_Identifier (First (Formals)); + while Present (Actual) loop + if Is_By_Copy_Type (Etype (Actual)) + and then Ekind (Formal) /= E_In_Parameter + then + -- Generate: + -- := P.; + + Asnmt := + Make_Assignment_Statement (Loc, + Name => + New_Copy (Actual), + Expression => + Make_Explicit_Dereference (Loc, + Make_Selected_Component (Loc, + Prefix => + New_Reference_To (P, Loc), + Selector_Name => + Make_Identifier (Loc, Chars (Formal))))); + + Set_Assignment_OK (Name (Asnmt)); + Append_To (Result, Asnmt); + + Has_Asnmt := True; + end if; + + Next_Actual (Actual); + Next_Formal_With_Extras (Formal); + end loop; + + if Has_Asnmt then + return Result; + else + return New_List (Make_Null_Statement (Loc)); + end if; + end Parameter_Block_Unpack; + + ---------------------- + -- Set_Discriminals -- + ---------------------- + + procedure Set_Discriminals (Dec : Node_Id) is + D : Entity_Id; + Pdef : Entity_Id; + D_Minal : Entity_Id; + + begin + pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration); + Pdef := Defining_Identifier (Dec); + + if Has_Discriminants (Pdef) then + D := First_Discriminant (Pdef); + while Present (D) loop + D_Minal := + Make_Defining_Identifier (Sloc (D), + Chars => New_External_Name (Chars (D), 'D')); + + Set_Ekind (D_Minal, E_Constant); + Set_Etype (D_Minal, Etype (D)); + Set_Scope (D_Minal, Pdef); + Set_Discriminal (D, D_Minal); + Set_Discriminal_Link (D_Minal, D); + + Next_Discriminant (D); + end loop; + end if; + end Set_Discriminals; + + ----------------------- + -- Trivial_Accept_OK -- + ----------------------- + + function Trivial_Accept_OK return Boolean is + begin + case Opt.Task_Dispatching_Policy is + + -- If we have the default task dispatching policy in effect, we can + -- definitely do the optimization (one way of looking at this is to + -- think of the formal definition of the default policy being allowed + -- to run any task it likes after a rendezvous, so even if notionally + -- a full rescheduling occurs, we can say that our dispatching policy + -- (i.e. the default dispatching policy) reorders the queue to be the + -- same as just before the call. + + when ' ' => + return True; + + -- FIFO_Within_Priorities certainly does not permit this + -- optimization since the Rendezvous is a scheduling action that may + -- require some other task to be run. + + when 'F' => + return False; + + -- For now, disallow the optimization for all other policies. This + -- may be over-conservative, but it is certainly not incorrect. + + when others => + return False; + + end case; + end Trivial_Accept_OK; + +end Exp_Ch9; diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads new file mode 100644 index 000000000..13e3f796e --- /dev/null +++ b/gcc/ada/exp_ch9.ads @@ -0,0 +1,354 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 9 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for chapter 9 constructs + +with Types; use Types; + +package Exp_Ch9 is + + type Subprogram_Protection_Mode is + (Dispatching_Mode, + Protected_Mode, + Unprotected_Mode); + -- This type is used to distinguish the different protection modes of a + -- protected subprogram. + + procedure Build_Activation_Chain_Entity (N : Node_Id); + -- Given a declaration N of an object that is a task, or contains tasks + -- (other than allocators to tasks) this routine ensures that an activation + -- chain has been declared in the appropriate scope, building the required + -- declaration for the chain variable if not. The name of this variable + -- is always _Chain and it is accessed by name. + + function Build_Call_With_Task (N : Node_Id; E : Entity_Id) return Node_Id; + -- N is a node representing the name of a task or an access to a task. + -- The value returned is a call to the function whose name is the entity + -- E (typically a runtime routine entity obtained using RTE) with the + -- Task_Id of the associated task as the parameter. The caller is + -- responsible for analyzing and resolving the resulting tree. + + function Build_Entry_Names (Conc_Typ : Entity_Id) return Node_Id; + -- Create the statements which populate the entry names array of a task or + -- protected type. The statements are wrapped inside a block due to a local + -- declaration. + + procedure Build_Master_Entity (E : Entity_Id); + -- Given an entity E for the declaration of an object containing tasks + -- or of a type declaration for an allocator whose designated type is a + -- task or contains tasks, this routine marks the appropriate enclosing + -- context as a master, and also declares a variable called _Master in + -- the current declarative part which captures the value of Current_Master + -- (if not already built by a prior call). We build this object (instead + -- of just calling Current_Master) for two reasons. First it is clearly + -- more efficient to call Current_Master only once for a bunch of tasks + -- in the same declarative part, and second it makes things easier in + -- generating the initialization routines, since they can just reference + -- the object _Master by name, and they will get the proper Current_Master + -- value at the outer level, and copy in the parameter value for the outer + -- initialization call if the call is for a nested component). Note that + -- in the case of nested packages, we only really need to make one such + -- object at the outer level, but it is much easier to generate one per + -- declarative part. + + function Build_Private_Protected_Declaration (N : Node_Id) return Entity_Id; + -- A subprogram body without a previous spec that appears in a protected + -- body must be expanded separately to create a subprogram declaration + -- for it, in order to resolve internal calls to it from other protected + -- operations. It would seem that no locking version of the operation is + -- needed, but in fact, in Ada 2005 the subprogram may be used in a call- + -- back, and therefore a protected version of the operation must be + -- generated as well. + + function Build_Protected_Sub_Specification + (N : Node_Id; + Prot_Typ : Entity_Id; + Mode : Subprogram_Protection_Mode) return Node_Id; + -- Build the specification for protected subprogram. This is called when + -- expanding a protected type, and also when expanding the declaration for + -- an Access_To_Protected_Subprogram type. In the latter case, Prot_Typ is + -- empty, and the first parameter of the signature of the protected op is + -- of type System.Address. + + procedure Build_Protected_Subprogram_Call + (N : Node_Id; + Name : Node_Id; + Rec : Node_Id; + External : Boolean := True); + -- The node N is a subprogram or entry call to a protected subprogram. This + -- procedure rewrites this call with the appropriate expansion. Name is the + -- subprogram, and Rec is the record corresponding to the protected object. + -- External is False if the call is to another protected subprogram within + -- the same object. + + procedure Build_Task_Activation_Call (N : Node_Id); + -- This procedure is called for constructs that can be task activators, + -- i.e. task bodies, subprogram bodies, package bodies and blocks. If the + -- construct is a task activator (as indicated by the non-empty setting of + -- Activation_Chain_Entity, either in the construct, or, in the case of a + -- package body, in its associated package spec), then a call to + -- Activate_Tasks with this entity as the single parameter is inserted at + -- the start of the statements of the activator. + + procedure Build_Task_Allocate_Block + (Actions : List_Id; + N : Node_Id; + Args : List_Id); + -- This routine is used in the case of allocators where the designated type + -- is a task or contains tasks. In this case, the normal initialize call + -- is replaced by: + -- + -- blockname : label; + -- blockname : declare + -- _Chain : Activation_Chain; + -- + -- procedure _Expunge is + -- begin + -- Expunge_Unactivated_Tasks (_Chain); + -- end; + -- + -- begin + -- Init (Args); + -- Activate_Tasks (_Chain); + -- at end + -- _Expunge; + -- end; + -- + -- to get the task or tasks created and initialized. The expunge call + -- ensures that any tasks that get created but not activated due to an + -- exception are properly expunged (it has no effect in the normal case). + -- The argument N is the allocator, and Args is the list of arguments for + -- the initialization call, constructed by the caller, which uses the + -- Master_Id of the access type as the _Master parameter, and _Chain + -- (defined above) as the _Chain parameter. + + procedure Build_Task_Allocate_Block_With_Init_Stmts + (Actions : List_Id; + N : Node_Id; + Init_Stmts : List_Id); + -- Ada 2005 (AI-287): Similar to previous routine, but used to expand + -- allocated aggregates with default initialized components. Init_Stmts + -- contains the list of statements required to initialize the allocated + -- aggregate. It replaces the call to Init (Args) done by + -- Build_Task_Allocate_Block. + + function Build_Wrapper_Spec + (Subp_Id : Entity_Id; + Obj_Typ : Entity_Id; + Formals : List_Id) return Node_Id; + -- Ada 2005 (AI-345): Build the specification of a primitive operation + -- associated with a protected or task type. This is required to implement + -- dispatching calls through interfaces. Subp_Id is the primitive to be + -- wrapped, Obj_Typ is the type of the newly added formal parameter to + -- handle object notation, Formals are the original entry formals that + -- will be explicitly replicated. + + function Concurrent_Ref (N : Node_Id) return Node_Id; + -- Given the name of a concurrent object (task or protected object), or + -- the name of an access to a concurrent object, this function returns an + -- expression referencing the associated Task_Id or Protection object, + -- respectively. Note that a special case is when the name is a reference + -- to a task type name. This can only happen within a task body, and the + -- meaning is to get the Task_Id for the currently executing task. + + function Convert_Concurrent + (N : Node_Id; + Typ : Entity_Id) return Node_Id; + -- N is an expression of type Typ. If the type is not a concurrent type + -- then it is returned unchanged. If it is a task or protected reference, + -- Convert_Concurrent creates an unchecked conversion node from this + -- expression to the corresponding concurrent record type value. We need + -- this in any situation where the concurrent type is used, because the + -- actual concurrent object is an object of the corresponding concurrent + -- type, and manipulations on the concurrent object actually manipulate the + -- corresponding object of the record type. + + function Entry_Index_Expression + (Sloc : Source_Ptr; + Ent : Entity_Id; + Index : Node_Id; + Ttyp : Entity_Id) + return Node_Id; + -- Returns an expression to compute a task entry index given the name of + -- the entry or entry family. For the case of a task entry family, the + -- Index parameter contains the expression for the subscript. Ttyp is the + -- task type. + + procedure Establish_Task_Master (N : Node_Id); + -- Given a subprogram body, or a block statement, or a task body, this + -- procedure makes the necessary transformations required of a task master + -- (add Enter_Master call at start, and establish a cleanup routine to make + -- sure Complete_Master is called on exit). + + procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id); + -- Build Equivalent_Type for an Access_To_Protected_Subprogram. + -- Equivalent_Type is a record type with two components: a pointer to the + -- protected object, and a pointer to the operation itself. + + procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id); + -- Expand declarations required for accept statement. See bodies of both + -- Expand_Accept_Declarations and Expand_N_Accept_Statement for full + -- details of the nature and use of these declarations, which are inserted + -- immediately before the accept node N. The second argument is the entity + -- for the corresponding entry. + + procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id); + -- Expand the entry barrier into a function. This is called directly + -- from Analyze_Entry_Body so that the discriminals and privals of the + -- barrier can be attached to the function declaration list, and a new + -- set prepared for the entry body procedure, before the entry body + -- statement sequence can be expanded. The resulting function is analyzed + -- now, within the context of the protected object, to resolve calls to + -- other protected functions. + + procedure Expand_N_Abort_Statement (N : Node_Id); + procedure Expand_N_Accept_Statement (N : Node_Id); + procedure Expand_N_Asynchronous_Select (N : Node_Id); + procedure Expand_N_Conditional_Entry_Call (N : Node_Id); + procedure Expand_N_Delay_Relative_Statement (N : Node_Id); + procedure Expand_N_Delay_Until_Statement (N : Node_Id); + procedure Expand_N_Entry_Body (N : Node_Id); + procedure Expand_N_Entry_Call_Statement (N : Node_Id); + procedure Expand_N_Entry_Declaration (N : Node_Id); + procedure Expand_N_Protected_Body (N : Node_Id); + + procedure Expand_N_Protected_Type_Declaration (N : Node_Id); + -- Expands protected type declarations. This results, among other things, + -- in the declaration of a record type for the representation of protected + -- objects and (if there are entries) in an entry service procedure. The + -- Protection value used by the GNARL to control the object will always be + -- the first field of the record, and the entry service procedure spec (if + -- it exists) will always immediately follow the record declaration. This + -- allows these two nodes to be found from the type, without benefit of + -- further attributes, using Corresponding_Record. + + procedure Expand_N_Requeue_Statement (N : Node_Id); + procedure Expand_N_Selective_Accept (N : Node_Id); + procedure Expand_N_Single_Task_Declaration (N : Node_Id); + procedure Expand_N_Task_Body (N : Node_Id); + procedure Expand_N_Task_Type_Declaration (N : Node_Id); + procedure Expand_N_Timed_Entry_Call (N : Node_Id); + + procedure Expand_Protected_Body_Declarations + (N : Node_Id; + Spec_Id : Entity_Id); + -- Expand declarations required for a protected body. See bodies of both + -- Expand_Protected_Body_Declarations and Expand_N_Protected_Body for full + -- details of the nature and use of these declarations. The second argument + -- is the entity for the corresponding protected type declaration. + + function External_Subprogram (E : Entity_Id) return Entity_Id; + -- return the external version of a protected operation, which locks + -- the object before invoking the internal protected subprogram body. + + function Find_Master_Scope (E : Entity_Id) return Entity_Id; + -- When a type includes tasks, a master entity is created in the scope, to + -- be used by the runtime during activation. In general the master is the + -- immediate scope in which the type is declared, but in Ada2005, in the + -- presence of synchronized classwide interfaces, the immediate scope of + -- an anonymous access type may be a transient scope, which has no run-time + -- presence. In this case, the scope of the master is the innermost scope + -- that comes from source. + + function First_Protected_Operation (D : List_Id) return Node_Id; + -- Given the declarations list for a protected body, find the + -- first protected operation body. + + procedure Install_Private_Data_Declarations + (Loc : Source_Ptr; + Spec_Id : Entity_Id; + Conc_Typ : Entity_Id; + Body_Nod : Node_Id; + Decls : List_Id; + Barrier : Boolean := False; + Family : Boolean := False); + -- This routines generates several types, objects and object renamings used + -- in the handling of discriminants and private components of protected and + -- task types. It also generates the entry index for entry families. Formal + -- Spec_Id denotes an entry, entry family or a subprogram, Conc_Typ is the + -- concurrent type where Spec_Id resides, Body_Nod is the corresponding + -- body of Spec_Id, Decls are the declarations of the subprogram or entry. + -- Flag Barrier denotes whether the context is an entry barrier function. + -- Flag Family is used in conjunction with Barrier to denote a barrier for + -- an entry family. + -- + -- The generated types, entities and renamings are: + -- + -- * If flag Barrier is set or Spec_Id denotes a protected entry or an + -- entry family, generate: + -- + -- type prot_typVP is access prot_typV; + -- _object : prot_typVP := prot_typV (_O); + -- + -- where prot_typV is the corresponding record of a protected type and + -- _O is a formal parameter representing the concurrent object of either + -- the barrier function or the entry (family). + -- + -- * If Conc_Typ is a protected type, create a renaming for the Protection + -- field _object: + -- + -- conc_typR : protection_typ renames _object._object; + -- + -- * If Conc_Typ has discriminants, create renamings of the form: + -- + -- discr_nameD : discr_typ renames _object.discr_name; + -- or + -- discr_nameD : discr_typ renames _task.discr_name; + -- + -- * If Conc_Typ denotes a protected type and has private components, + -- generate renamings of the form: + -- + -- comp_name : comp_typ renames _object.comp_name; + -- + -- * Finally, is flag Barrier and Family are set or Spec_Id denotes an + -- entry family, generate the entry index constant: + -- + -- subtype Jnn is range Low .. High; + -- J : constant Jnn := + -- Jnn'Val (_E - + Jnn'Pos (Jnn'First)); + -- + -- All the above declarations are inserted in the order shown to the front + -- of Decls. + + function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id; + -- Given the entity of the record type created for a task type, build + -- the call to Create_Task + + function Make_Initialize_Protection + (Protect_Rec : Entity_Id) return List_Id; + -- Given the entity of the record type created for a protected type, build + -- a list of statements needed for proper initialization of the object. + + function Next_Protected_Operation (N : Node_Id) return Node_Id; + -- Given a protected operation node (a subprogram or entry body), find the + -- following node in the declarations list. + + procedure Set_Discriminals (Dec : Node_Id); + -- Replace discriminals in a protected type for use by the next protected + -- operation on the type. Each operation needs a new set of discriminals, + -- since it needs a unique renaming of the discriminant fields in the + -- record used to implement the protected type. + +end Exp_Ch9; diff --git a/gcc/ada/exp_code.adb b/gcc/ada/exp_code.adb new file mode 100644 index 000000000..2b0275268 --- /dev/null +++ b/gcc/ada/exp_code.adb @@ -0,0 +1,498 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C O D E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1996-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Errout; use Errout; +with Fname; use Fname; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem_Aux; use Sem_Aux; +with Sem_Eval; use Sem_Eval; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Sinfo; use Sinfo; +with Stringt; use Stringt; +with Tbuild; use Tbuild; + +package body Exp_Code is + + ----------------------- + -- Local_Subprograms -- + ----------------------- + + function Asm_Constraint (Operand_Var : Node_Id) return Node_Id; + -- Common processing for Asm_Input_Constraint and Asm_Output_Constraint. + -- Obtains the constraint argument from the global operand variable + -- Operand_Var, which must be non-Empty. + + function Asm_Operand (Operand_Var : Node_Id) return Node_Id; + -- Common processing for Asm_Input_Value and Asm_Output_Variable. Obtains + -- the value/variable argument from Operand_Var, the global operand + -- variable. Returns Empty if no operand available. + + function Get_String_Node (S : Node_Id) return Node_Id; + -- Given S, a static expression node of type String, returns the + -- string literal node. This is needed to deal with the use of constants + -- for these expressions, which is perfectly permissible. + + procedure Next_Asm_Operand (Operand_Var : in out Node_Id); + -- Common processing for Next_Asm_Input and Next_Asm_Output, updates + -- the value of the global operand variable Operand_Var appropriately. + + procedure Setup_Asm_IO_Args (Arg : Node_Id; Operand_Var : out Node_Id); + -- Common processing for Setup_Asm_Inputs and Setup_Asm_Outputs. Arg + -- is the actual parameter from the call, and Operand_Var is the global + -- operand variable to be initialized to the first operand. + + ---------------------- + -- Global Variables -- + ---------------------- + + Current_Input_Operand : Node_Id := Empty; + -- Points to current Asm_Input_Operand attribute reference. Initialized + -- by Setup_Asm_Inputs, updated by Next_Asm_Input, and referenced by + -- Asm_Input_Constraint and Asm_Input_Value. + + Current_Output_Operand : Node_Id := Empty; + -- Points to current Asm_Output_Operand attribute reference. Initialized + -- by Setup_Asm_Outputs, updated by Next_Asm_Output, and referenced by + -- Asm_Output_Constraint and Asm_Output_Variable. + + -------------------- + -- Asm_Constraint -- + -------------------- + + function Asm_Constraint (Operand_Var : Node_Id) return Node_Id is + begin + pragma Assert (Present (Operand_Var)); + return Get_String_Node (First (Expressions (Operand_Var))); + end Asm_Constraint; + + -------------------------- + -- Asm_Input_Constraint -- + -------------------------- + + -- Note: error checking on Asm_Input attribute done in Sem_Attr + + function Asm_Input_Constraint return Node_Id is + begin + return Get_String_Node (Asm_Constraint (Current_Input_Operand)); + end Asm_Input_Constraint; + + --------------------- + -- Asm_Input_Value -- + --------------------- + + -- Note: error checking on Asm_Input attribute done in Sem_Attr + + function Asm_Input_Value return Node_Id is + begin + return Asm_Operand (Current_Input_Operand); + end Asm_Input_Value; + + ----------------- + -- Asm_Operand -- + ----------------- + + function Asm_Operand (Operand_Var : Node_Id) return Node_Id is + begin + if No (Operand_Var) then + return Empty; + elsif Error_Posted (Operand_Var) then + return Error; + else + return Next (First (Expressions (Operand_Var))); + end if; + end Asm_Operand; + + --------------------------- + -- Asm_Output_Constraint -- + --------------------------- + + -- Note: error checking on Asm_Output attribute done in Sem_Attr + + function Asm_Output_Constraint return Node_Id is + begin + return Asm_Constraint (Current_Output_Operand); + end Asm_Output_Constraint; + + ------------------------- + -- Asm_Output_Variable -- + ------------------------- + + -- Note: error checking on Asm_Output attribute done in Sem_Attr + + function Asm_Output_Variable return Node_Id is + begin + return Asm_Operand (Current_Output_Operand); + end Asm_Output_Variable; + + ------------------ + -- Asm_Template -- + ------------------ + + function Asm_Template (N : Node_Id) return Node_Id is + Call : constant Node_Id := Expression (Expression (N)); + Temp : constant Node_Id := First_Actual (Call); + + begin + -- Require static expression for template. We also allow a string + -- literal (this is useful for Ada 83 mode where string expressions + -- are never static). + + if Is_OK_Static_Expression (Temp) + or else (Ada_Version = Ada_83 + and then Nkind (Temp) = N_String_Literal) + then + return Get_String_Node (Temp); + + else + Flag_Non_Static_Expr ("asm template argument is not static!", Temp); + return Empty; + end if; + end Asm_Template; + + ---------------------- + -- Clobber_Get_Next -- + ---------------------- + + Clobber_Node : Node_Id; + -- String literal node for clobber string. Initialized by Clobber_Setup, + -- and not modified by Clobber_Get_Next. Empty if clobber string was in + -- error (resulting in no clobber arguments being returned). + + Clobber_Ptr : Nat; + -- Pointer to current character of string. Initialized to 1 by the call + -- to Clobber_Setup, and then updated by Clobber_Get_Next. + + function Clobber_Get_Next return Address is + Str : constant String_Id := Strval (Clobber_Node); + Len : constant Nat := String_Length (Str); + C : Character; + + begin + if No (Clobber_Node) then + return Null_Address; + end if; + + -- Skip spaces and commas before next register name + + loop + -- Return null string if no more names + + if Clobber_Ptr > Len then + return Null_Address; + end if; + + C := Get_Character (Get_String_Char (Str, Clobber_Ptr)); + exit when C /= ',' and then C /= ' '; + Clobber_Ptr := Clobber_Ptr + 1; + end loop; + + -- Acquire next register name + + Name_Len := 0; + loop + Add_Char_To_Name_Buffer (C); + Clobber_Ptr := Clobber_Ptr + 1; + exit when Clobber_Ptr > Len; + C := Get_Character (Get_String_Char (Str, Clobber_Ptr)); + exit when C = ',' or else C = ' '; + end loop; + + Name_Buffer (Name_Len + 1) := ASCII.NUL; + return Name_Buffer'Address; + end Clobber_Get_Next; + + ------------------- + -- Clobber_Setup -- + ------------------- + + procedure Clobber_Setup (N : Node_Id) is + Call : constant Node_Id := Expression (Expression (N)); + Clob : constant Node_Id := Next_Actual ( + Next_Actual ( + Next_Actual ( + First_Actual (Call)))); + begin + if not Is_OK_Static_Expression (Clob) then + Flag_Non_Static_Expr ("asm clobber argument is not static!", Clob); + Clobber_Node := Empty; + else + Clobber_Node := Get_String_Node (Clob); + Clobber_Ptr := 1; + end if; + end Clobber_Setup; + + --------------------- + -- Expand_Asm_Call -- + --------------------- + + procedure Expand_Asm_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + procedure Check_IO_Operand (N : Node_Id); + -- Check for incorrect input or output operand + + ---------------------- + -- Check_IO_Operand -- + ---------------------- + + procedure Check_IO_Operand (N : Node_Id) is + Err : Node_Id := N; + + begin + -- The only identifier allowed is No_xxput_Operands. Since we + -- know the type is right, it is sufficient to see if the + -- referenced entity is in a runtime routine. + + if Is_Entity_Name (N) + and then + Is_Predefined_File_Name (Unit_File_Name + (Get_Source_Unit (Entity (N)))) + then + return; + + -- An attribute reference is fine, again the analysis reasonably + -- guarantees that the attribute must be subtype'Asm_??put. + + elsif Nkind (N) = N_Attribute_Reference then + return; + + -- The only other allowed form is an array aggregate in which + -- all the entries are positional and are attribute references. + + elsif Nkind (N) = N_Aggregate then + if Present (Component_Associations (N)) then + Err := First (Component_Associations (N)); + + elsif Present (Expressions (N)) then + Err := First (Expressions (N)); + while Present (Err) loop + exit when Nkind (Err) /= N_Attribute_Reference; + Next (Err); + end loop; + + if No (Err) then + return; + end if; + end if; + end if; + + -- If we fall through, Err is pointing to the bad node + + Error_Msg_N ("Asm operand has wrong form", Err); + end Check_IO_Operand; + + -- Start of processing for Expand_Asm_Call + + begin + -- Check that the input and output operands have the right + -- form, as required by the documentation of the Asm feature: + + -- OUTPUT_OPERAND_LIST ::= + -- No_Output_Operands + -- | OUTPUT_OPERAND_ATTRIBUTE + -- | (OUTPUT_OPERAND_ATTRIBUTE @{,OUTPUT_OPERAND_ATTRIBUTE@}) + + -- OUTPUT_OPERAND_ATTRIBUTE ::= + -- SUBTYPE_MARK'Asm_Output (static_string_EXPRESSION, NAME) + + -- INPUT_OPERAND_LIST ::= + -- No_Input_Operands + -- | INPUT_OPERAND_ATTRIBUTE + -- | (INPUT_OPERAND_ATTRIBUTE @{,INPUT_OPERAND_ATTRIBUTE@}) + + -- INPUT_OPERAND_ATTRIBUTE ::= + -- SUBTYPE_MARK'Asm_Input (static_string_EXPRESSION, EXPRESSION) + + declare + Arg_Output : constant Node_Id := Next_Actual (First_Actual (N)); + Arg_Input : constant Node_Id := Next_Actual (Arg_Output); + begin + Check_IO_Operand (Arg_Output); + Check_IO_Operand (Arg_Input); + end; + + -- If we have the function call case, we are inside a code statement, + -- and the tree is already in the necessary form for gigi. + + if Nkind (N) = N_Function_Call then + null; + + -- For the procedure case, we convert the call into a code statement + + else + pragma Assert (Nkind (N) = N_Procedure_Call_Statement); + + -- Note: strictly we should change the procedure call to a function + -- call in the qualified expression, but since we are not going to + -- reanalyze (see below), and the interface subprograms in this + -- package don't care, we can leave it as a procedure call. + + Rewrite (N, + Make_Code_Statement (Loc, + Expression => + Make_Qualified_Expression (Loc, + Subtype_Mark => New_Occurrence_Of (RTE (RE_Asm_Insn), Loc), + Expression => Relocate_Node (N)))); + + -- There is no need to reanalyze this node, it is completely analyzed + -- already, at least sufficiently for the purposes of the abstract + -- procedural interface defined in this package. Furthermore if we + -- let it go through the normal analysis, that would include some + -- inappropriate checks that apply only to explicit code statements + -- in the source, and not to calls to intrinsics. + + Set_Analyzed (N); + Check_Code_Statement (N); + end if; + end Expand_Asm_Call; + + --------------------- + -- Get_String_Node -- + --------------------- + + function Get_String_Node (S : Node_Id) return Node_Id is + begin + if Nkind (S) = N_String_Literal then + return S; + else + pragma Assert (Ekind (Entity (S)) = E_Constant); + return Get_String_Node (Constant_Value (Entity (S))); + end if; + end Get_String_Node; + + --------------------- + -- Is_Asm_Volatile -- + --------------------- + + function Is_Asm_Volatile (N : Node_Id) return Boolean is + Call : constant Node_Id := Expression (Expression (N)); + Vol : constant Node_Id := + Next_Actual ( + Next_Actual ( + Next_Actual ( + Next_Actual ( + First_Actual (Call))))); + begin + if not Is_OK_Static_Expression (Vol) then + Flag_Non_Static_Expr ("asm volatile argument is not static!", Vol); + return False; + else + return Is_True (Expr_Value (Vol)); + end if; + end Is_Asm_Volatile; + + -------------------- + -- Next_Asm_Input -- + -------------------- + + procedure Next_Asm_Input is + begin + Next_Asm_Operand (Current_Input_Operand); + end Next_Asm_Input; + + ---------------------- + -- Next_Asm_Operand -- + ---------------------- + + procedure Next_Asm_Operand (Operand_Var : in out Node_Id) is + begin + pragma Assert (Present (Operand_Var)); + + if Nkind (Parent (Operand_Var)) = N_Aggregate then + Operand_Var := Next (Operand_Var); + else + Operand_Var := Empty; + end if; + end Next_Asm_Operand; + + --------------------- + -- Next_Asm_Output -- + --------------------- + + procedure Next_Asm_Output is + begin + Next_Asm_Operand (Current_Output_Operand); + end Next_Asm_Output; + + ---------------------- + -- Setup_Asm_Inputs -- + ---------------------- + + procedure Setup_Asm_Inputs (N : Node_Id) is + Call : constant Node_Id := Expression (Expression (N)); + begin + Setup_Asm_IO_Args + (Next_Actual (Next_Actual (First_Actual (Call))), + Current_Input_Operand); + end Setup_Asm_Inputs; + + ----------------------- + -- Setup_Asm_IO_Args -- + ----------------------- + + procedure Setup_Asm_IO_Args (Arg : Node_Id; Operand_Var : out Node_Id) is + begin + -- Case of single argument + + if Nkind (Arg) = N_Attribute_Reference then + Operand_Var := Arg; + + -- Case of list of arguments + + elsif Nkind (Arg) = N_Aggregate then + if Expressions (Arg) = No_List then + Operand_Var := Empty; + else + Operand_Var := First (Expressions (Arg)); + end if; + + -- Otherwise must be default (no operands) case + + else + Operand_Var := Empty; + end if; + end Setup_Asm_IO_Args; + + ----------------------- + -- Setup_Asm_Outputs -- + ----------------------- + + procedure Setup_Asm_Outputs (N : Node_Id) is + Call : constant Node_Id := Expression (Expression (N)); + begin + Setup_Asm_IO_Args + (Next_Actual (First_Actual (Call)), + Current_Output_Operand); + end Setup_Asm_Outputs; + +end Exp_Code; diff --git a/gcc/ada/exp_code.ads b/gcc/ada/exp_code.ads new file mode 100644 index 000000000..a9e701a5a --- /dev/null +++ b/gcc/ada/exp_code.ads @@ -0,0 +1,127 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C O D E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1996-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Processing for handling code statements + +with Types; use Types; + +with System; use System; +package Exp_Code is + + procedure Expand_Asm_Call (N : Node_Id); + -- Expands a call to Asm into an equivalent N_Code_Statement node + + -- The following routines provide an abstract interface to analyze + -- code statements, for use by Gigi processing for code statements. + -- Note that the implementations of these routines must not attempt + -- to expand tables that are frozen on entry to Gigi. + + function Is_Asm_Volatile (N : Node_Id) return Boolean; + -- Given an N_Code_Statement node N, return True if Volatile=True is + -- specified, and False if Volatile=False is specified (or set by default). + + function Asm_Template (N : Node_Id) return Node_Id; + -- Given an N_Code_Statement node N, returns string literal node for + -- template in call + + procedure Clobber_Setup (N : Node_Id); + -- Given an N_Code_Statement node N, setup to process the clobber list + -- with subsequent calls to Clobber_Get_Next. + + function Clobber_Get_Next return System.Address; + -- Can only be called after a previous call to Clobber_Setup. The + -- returned value is a pointer to a null terminated (C format) string + -- for the next register argument. Null_Address is returned when there + -- are no more arguments. + + procedure Setup_Asm_Inputs (N : Node_Id); + -- Given an N_Code_Statement node N, setup to read list of Asm_Input + -- arguments. The protocol is to construct a loop as follows: + -- + -- Setup_Asm_Inputs (N); + -- while Present (Asm_Input_Value) + -- body + -- Next_Asm_Input; + -- end loop; + -- + -- where the loop body calls Asm_Input_Constraint or Asm_Input_Value to + -- obtain the constraint string or input value expression from the current + -- Asm_Input argument. + + function Asm_Input_Constraint return Node_Id; + -- Called within a loop initialized by Setup_Asm_Inputs and controlled + -- by Next_Asm_Input as described above. Returns a string literal node + -- for the constraint component of the current Asm_Input_Parameter, or + -- Empty if there are no more Asm_Input parameters. + + function Asm_Input_Value return Node_Id; + -- Called within a loop initialized by Setup_Asm_Inputs and controlled + -- by Next_Asm_Input as described above. Returns the expression node for + -- the value component of the current Asm_Input parameter, or Empty if + -- there are no more Asm_Input parameters, or Error if an error was + -- previously detected in the input parameters (note that the backend + -- need not worry about this case, since it won't be called if there + -- were any such serious errors detected). + + procedure Next_Asm_Input; + -- Step to next Asm_Input parameter. It is an error to call this procedure + -- if there are no more available parameters (which is impossible if the + -- call appears in a loop as in the above example). + + procedure Setup_Asm_Outputs (N : Node_Id); + -- Given an N_Code_Statement node N, setup to read list of Asm_Output + -- arguments. The protocol is to construct a loop as follows: + -- + -- Setup_Asm_Outputs (N); + -- while Present (Asm_Output_Variable) + -- body + -- Next_Asm_Output; + -- end loop; + -- + -- where the loop body calls Asm_Output_Constraint or Asm_Output_Variable + -- to obtain the constraint string or output variable name from the current + -- Asm_Output argument. + + function Asm_Output_Constraint return Node_Id; + -- Called within a loop initialized by Setup_Asm_Outputs and controlled + -- by Next_Asm_Output as described above. Returns a string literal node + -- for the constraint component of the current Asm_Output_Parameter, or + -- Empty if there are no more Asm_Output parameters. + + function Asm_Output_Variable return Node_Id; + -- Called within a loop initialized by Setup_Asm_Outputs and controlled by + -- Next_Asm_Output as described above. Returns the expression node for the + -- output variable component of the current Asm_Output parameter, or Empty + -- if there are no more Asm_Output parameters, or Error if an error was + -- previously detected in the input parameters (note that the backend need + -- not worry about this case, since it won't be called if there were any + -- such serious errors detected). + + procedure Next_Asm_Output; + -- Step to next Asm_Output parameter. It is an error to call this procedure + -- if there are no more available parameters (which is impossible if the + -- call appears in a loop as in the above example). + +end Exp_Code; diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb new file mode 100644 index 000000000..ca36f14ad --- /dev/null +++ b/gcc/ada/exp_dbug.adb @@ -0,0 +1,1445 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ D B U G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1996-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Alloc; use Alloc; +with Atree; use Atree; +with Debug; use Debug; +with Einfo; use Einfo; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Output; use Output; +with Sem_Aux; use Sem_Aux; +with Sem_Eval; use Sem_Eval; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Stand; use Stand; +with Stringt; use Stringt; +with Table; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Urealp; use Urealp; + +package body Exp_Dbug is + + -- The following table is used to queue up the entities passed as + -- arguments to Qualify_Entity_Names for later processing when + -- Qualify_All_Entity_Names is called. + + package Name_Qualify_Units is new Table.Table ( + Table_Component_Type => Node_Id, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => Alloc.Name_Qualify_Units_Initial, + Table_Increment => Alloc.Name_Qualify_Units_Increment, + Table_Name => "Name_Qualify_Units"); + + -------------------------------- + -- Use of Qualification Flags -- + -------------------------------- + + -- There are two flags used to keep track of qualification of entities + + -- Has_Fully_Qualified_Name + -- Has_Qualified_Name + + -- The difference between these is as follows. Has_Qualified_Name is + -- set to indicate that the name has been qualified as required by the + -- spec of this package. As described there, this may involve the full + -- qualification for the name, but for some entities, notably procedure + -- local variables, this full qualification is not required. + + -- The flag Has_Fully_Qualified_Name is set if indeed the name has been + -- fully qualified in the Ada sense. If Has_Fully_Qualified_Name is set, + -- then Has_Qualified_Name is also set, but the other way round is not + -- the case. + + -- Consider the following example: + + -- with ... + -- procedure X is + -- B : Ddd.Ttt; + -- procedure Y is .. + + -- Here B is a procedure local variable, so it does not need fully + -- qualification. The flag Has_Qualified_Name will be set on the + -- first attempt to qualify B, to indicate that the job is done + -- and need not be redone. + + -- But Y is qualified as x__y, since procedures are always fully + -- qualified, so the first time that an attempt is made to qualify + -- the name y, it will be replaced by x__y, and both flags are set. + + -- Why the two flags? Well there are cases where we derive type names + -- from object names. As noted in the spec, type names are always + -- fully qualified. Suppose for example that the backend has to build + -- a padded type for variable B. then it will construct the PAD name + -- from B, but it requires full qualification, so the fully qualified + -- type name will be x__b___PAD. The two flags allow the circuit for + -- building this name to realize efficiently that b needs further + -- qualification. + + -------------------- + -- Homonym_Suffix -- + -------------------- + + -- The string defined here (and its associated length) is used to + -- gather the homonym string that will be appended to Name_Buffer + -- when the name is complete. Strip_Suffixes appends to this string + -- as does Append_Homonym_Number, and Output_Homonym_Numbers_Suffix + -- appends the string to the end of Name_Buffer. + + Homonym_Numbers : String (1 .. 256); + Homonym_Len : Natural := 0; + + ---------------------- + -- Local Procedures -- + ---------------------- + + procedure Add_Uint_To_Buffer (U : Uint); + -- Add image of universal integer to Name_Buffer, updating Name_Len + + procedure Add_Real_To_Buffer (U : Ureal); + -- Add nnn_ddd to Name_Buffer, where nnn and ddd are integer values of + -- the normalized numerator and denominator of the given real value. + + procedure Append_Homonym_Number (E : Entity_Id); + -- If the entity E has homonyms in the same scope, then make an entry + -- in the Homonym_Numbers array, bumping Homonym_Count accordingly. + + function Bounds_Match_Size (E : Entity_Id) return Boolean; + -- Determine whether the bounds of E match the size of the type. This is + -- used to determine whether encoding is required for a discrete type. + + procedure Output_Homonym_Numbers_Suffix; + -- If homonym numbers are stored, then output them into Name_Buffer + + procedure Prepend_String_To_Buffer (S : String); + -- Prepend given string to the contents of the string buffer, updating + -- the value in Name_Len (i.e. string is added at start of buffer). + + procedure Prepend_Uint_To_Buffer (U : Uint); + -- Prepend image of universal integer to Name_Buffer, updating Name_Len + + procedure Qualify_Entity_Name (Ent : Entity_Id); + -- If not already done, replaces the Chars field of the given entity + -- with the appropriate fully qualified name. + + procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean); + -- Given an qualified entity name in Name_Buffer, remove any plain X or + -- X{nb} qualification suffix. The contents of Name_Buffer is not changed + -- but Name_Len may be adjusted on return to remove the suffix. If a + -- BNPE suffix is found and stripped, then BNPE_Suffix_Found is set to + -- True. If no suffix is found, then BNPE_Suffix_Found is not modified. + -- This routine also searches for a homonym suffix, and if one is found + -- it is also stripped, and the entries are added to the global homonym + -- list (Homonym_Numbers) so that they can later be put back. + + ------------------------ + -- Add_Real_To_Buffer -- + ------------------------ + + procedure Add_Real_To_Buffer (U : Ureal) is + begin + Add_Uint_To_Buffer (Norm_Num (U)); + Add_Str_To_Name_Buffer ("_"); + Add_Uint_To_Buffer (Norm_Den (U)); + end Add_Real_To_Buffer; + + ------------------------ + -- Add_Uint_To_Buffer -- + ------------------------ + + procedure Add_Uint_To_Buffer (U : Uint) is + begin + if U < 0 then + Add_Uint_To_Buffer (-U); + Add_Char_To_Name_Buffer ('m'); + else + UI_Image (U, Decimal); + Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length)); + end if; + end Add_Uint_To_Buffer; + + --------------------------- + -- Append_Homonym_Number -- + --------------------------- + + procedure Append_Homonym_Number (E : Entity_Id) is + + procedure Add_Nat_To_H (Nr : Nat); + -- Little procedure to append Nr to Homonym_Numbers + + ------------------ + -- Add_Nat_To_H -- + ------------------ + + procedure Add_Nat_To_H (Nr : Nat) is + begin + if Nr >= 10 then + Add_Nat_To_H (Nr / 10); + end if; + + Homonym_Len := Homonym_Len + 1; + Homonym_Numbers (Homonym_Len) := + Character'Val (Nr mod 10 + Character'Pos ('0')); + end Add_Nat_To_H; + + -- Start of processing for Append_Homonym_Number + + begin + if Has_Homonym (E) then + declare + H : Entity_Id := Homonym (E); + Nr : Nat := 1; + + begin + while Present (H) loop + if Scope (H) = Scope (E) then + Nr := Nr + 1; + end if; + + H := Homonym (H); + end loop; + + if Homonym_Len > 0 then + Homonym_Len := Homonym_Len + 1; + Homonym_Numbers (Homonym_Len) := '_'; + end if; + + Add_Nat_To_H (Nr); + end; + end if; + end Append_Homonym_Number; + + ----------------------- + -- Bounds_Match_Size -- + ----------------------- + + function Bounds_Match_Size (E : Entity_Id) return Boolean is + Siz : Uint; + + begin + if not Is_OK_Static_Subtype (E) then + return False; + + elsif Is_Integer_Type (E) + and then Subtypes_Statically_Match (E, Base_Type (E)) + then + return True; + + -- Here we check if the static bounds match the natural size, which is + -- the size passed through with the debugging information. This is the + -- Esize rounded up to 8, 16, 32 or 64 as appropriate. + + else + declare + Umark : constant Uintp.Save_Mark := Uintp.Mark; + Result : Boolean; + + begin + if Esize (E) <= 8 then + Siz := Uint_8; + elsif Esize (E) <= 16 then + Siz := Uint_16; + elsif Esize (E) <= 32 then + Siz := Uint_32; + else + Siz := Uint_64; + end if; + + if Is_Modular_Integer_Type (E) or else Is_Enumeration_Type (E) then + Result := + Expr_Rep_Value (Type_Low_Bound (E)) = 0 + and then + 2 ** Siz - Expr_Rep_Value (Type_High_Bound (E)) = 1; + + else + Result := + Expr_Rep_Value (Type_Low_Bound (E)) + 2 ** (Siz - 1) = 0 + and then + 2 ** (Siz - 1) - Expr_Rep_Value (Type_High_Bound (E)) = 1; + end if; + + Release (Umark); + return Result; + end; + end if; + end Bounds_Match_Size; + + -------------------------------- + -- Debug_Renaming_Declaration -- + -------------------------------- + + function Debug_Renaming_Declaration (N : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + Ent : constant Node_Id := Defining_Entity (N); + Nam : constant Node_Id := Name (N); + Ren : Node_Id; + Typ : Entity_Id; + Obj : Entity_Id; + Res : Node_Id; + + function Output_Subscript (N : Node_Id; S : String) return Boolean; + -- Outputs a single subscript value as ?nnn (subscript is compile time + -- known value with value nnn) or as ?e (subscript is local constant + -- with name e), where S supplies the proper string to use for ?. + -- Returns False if the subscript is not of an appropriate type to + -- output in one of these two forms. The result is prepended to the + -- name stored in Name_Buffer. + + ---------------------- + -- Output_Subscript -- + ---------------------- + + function Output_Subscript (N : Node_Id; S : String) return Boolean is + begin + if Compile_Time_Known_Value (N) then + Prepend_Uint_To_Buffer (Expr_Value (N)); + + elsif Nkind (N) = N_Identifier + and then Scope (Entity (N)) = Scope (Ent) + and then Ekind (Entity (N)) = E_Constant + then + Prepend_String_To_Buffer (Get_Name_String (Chars (Entity (N)))); + + else + return False; + end if; + + Prepend_String_To_Buffer (S); + return True; + end Output_Subscript; + + -- Start of processing for Debug_Renaming_Declaration + + begin + if not Comes_From_Source (N) + and then not Needs_Debug_Info (Ent) + then + return Empty; + end if; + + -- Do not output those local variables in VM case, as this does not + -- help debugging (they are just unused), and might lead to duplicated + -- local variable names. + + if VM_Target /= No_VM then + return Empty; + end if; + + -- Get renamed entity and compute suffix + + Name_Len := 0; + Ren := Nam; + loop + case Nkind (Ren) is + + when N_Identifier => + exit; + + when N_Expanded_Name => + + -- The entity field for an N_Expanded_Name is on the expanded + -- name node itself, so we are done here too. + + exit; + + when N_Selected_Component => + Prepend_String_To_Buffer + (Get_Name_String (Chars (Selector_Name (Ren)))); + Prepend_String_To_Buffer ("XR"); + Ren := Prefix (Ren); + + when N_Indexed_Component => + declare + X : Node_Id := Last (Expressions (Ren)); + + begin + while Present (X) loop + if not Output_Subscript (X, "XS") then + Set_Materialize_Entity (Ent); + return Empty; + end if; + + Prev (X); + end loop; + end; + + Ren := Prefix (Ren); + + when N_Slice => + + Typ := Etype (First_Index (Etype (Nam))); + + if not Output_Subscript (Type_High_Bound (Typ), "XS") then + Set_Materialize_Entity (Ent); + return Empty; + end if; + + if not Output_Subscript (Type_Low_Bound (Typ), "XL") then + Set_Materialize_Entity (Ent); + return Empty; + end if; + + Ren := Prefix (Ren); + + when N_Explicit_Dereference => + Set_Materialize_Entity (Ent); + Prepend_String_To_Buffer ("XA"); + Ren := Prefix (Ren); + + -- For now, anything else simply results in no translation + + when others => + Set_Materialize_Entity (Ent); + return Empty; + end case; + end loop; + + Prepend_String_To_Buffer ("___XE"); + + -- Include the designation of the form of renaming + + case Nkind (N) is + when N_Object_Renaming_Declaration => + Prepend_String_To_Buffer ("___XR"); + + when N_Exception_Renaming_Declaration => + Prepend_String_To_Buffer ("___XRE"); + + when N_Package_Renaming_Declaration => + Prepend_String_To_Buffer ("___XRP"); + + when others => + return Empty; + end case; + + -- Add the name of the renaming entity to the front + + Prepend_String_To_Buffer (Get_Name_String (Chars (Ent))); + + -- If it is a child unit create a fully qualified name, to disambiguate + -- multiple child units with the same name and different parents. + + if Nkind (N) = N_Package_Renaming_Declaration + and then Is_Child_Unit (Ent) + then + Prepend_String_To_Buffer ("__"); + Prepend_String_To_Buffer + (Get_Name_String (Chars (Scope (Ent)))); + end if; + + -- Create the special object whose name is the debug encoding for the + -- renaming declaration. + + -- For now, the object name contains the suffix encoding for the renamed + -- object, but not the name of the leading entity. The object is linked + -- the renamed entity using the Debug_Renaming_Link field. Then the + -- Qualify_Entity_Name procedure uses this link to create the proper + -- fully qualified name. + + -- The reason we do things this way is that we really need to copy the + -- qualification of the renamed entity, and it is really much easier to + -- do this after the renamed entity has itself been fully qualified. + + Obj := Make_Defining_Identifier (Loc, Chars => Name_Enter); + Res := + Make_Object_Declaration (Loc, + Defining_Identifier => Obj, + Object_Definition => New_Reference_To + (Standard_Debug_Renaming_Type, Loc)); + + Set_Debug_Renaming_Link (Obj, Entity (Ren)); + + Set_Debug_Info_Needed (Obj); + + -- Mark the object as internal so that it won't be initialized when + -- pragma Initialize_Scalars or Normalize_Scalars is in use. + + Set_Is_Internal (Obj); + + return Res; + + -- If we get an exception, just figure it is a case that we cannot + -- successfully handle using our current approach, since this is + -- only for debugging, no need to take the compilation with us! + + exception + when others => + return Make_Null_Statement (Loc); + end Debug_Renaming_Declaration; + + ---------------------- + -- Get_Encoded_Name -- + ---------------------- + + -- Note: see spec for details on encodings + + procedure Get_Encoded_Name (E : Entity_Id) is + Has_Suffix : Boolean; + + begin + -- If not generating code, there is no need to create encoded names, and + -- problems when the back-end is called to annotate types without full + -- code generation. See comments in Get_External_Name_With_Suffix for + -- additional details. + + -- However we do create encoded names if the back end is active, even + -- if Operating_Mode got reset. Otherwise any serious error reported + -- by the backend calling Error_Msg changes the Compilation_Mode to + -- Check_Semantics, which disables the functionality of this routine, + -- causing the generation of spurious additional errors. + + -- Couldn't we just test Original_Operating_Mode here? ??? + + if Operating_Mode /= Generate_Code + and then not Generating_Code + then + return; + end if; + + Get_Name_String (Chars (E)); + + -- Nothing to do if we do not have a type + + if not Is_Type (E) + + -- Or if this is an enumeration base type + + or else (Is_Enumeration_Type (E) and then Is_Base_Type (E)) + + -- Or if this is a dummy type for a renaming + + or else (Name_Len >= 3 and then + Name_Buffer (Name_Len - 2 .. Name_Len) = "_XR") + + or else (Name_Len >= 4 and then + (Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRE" + or else + Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRP")) + + -- For all these cases, just return the name unchanged + + then + Name_Buffer (Name_Len + 1) := ASCII.NUL; + return; + end if; + + Has_Suffix := True; + + -- Fixed-point case + + if Is_Fixed_Point_Type (E) then + Get_External_Name_With_Suffix (E, "XF_"); + Add_Real_To_Buffer (Delta_Value (E)); + + if Small_Value (E) /= Delta_Value (E) then + Add_Str_To_Name_Buffer ("_"); + Add_Real_To_Buffer (Small_Value (E)); + end if; + + -- Vax floating-point case + + elsif Vax_Float (E) then + if Digits_Value (Base_Type (E)) = 6 then + Get_External_Name_With_Suffix (E, "XFF"); + + elsif Digits_Value (Base_Type (E)) = 9 then + Get_External_Name_With_Suffix (E, "XFF"); + + else + pragma Assert (Digits_Value (Base_Type (E)) = 15); + Get_External_Name_With_Suffix (E, "XFG"); + end if; + + -- Discrete case where bounds do not match size + + elsif Is_Discrete_Type (E) + and then not Bounds_Match_Size (E) + then + declare + Lo : constant Node_Id := Type_Low_Bound (E); + Hi : constant Node_Id := Type_High_Bound (E); + + Lo_Con : constant Boolean := Compile_Time_Known_Value (Lo); + Hi_Con : constant Boolean := Compile_Time_Known_Value (Hi); + + Lo_Discr : constant Boolean := + Nkind (Lo) = N_Identifier + and then + Ekind (Entity (Lo)) = E_Discriminant; + + Hi_Discr : constant Boolean := + Nkind (Hi) = N_Identifier + and then + Ekind (Entity (Hi)) = E_Discriminant; + + Lo_Encode : constant Boolean := Lo_Con or Lo_Discr; + Hi_Encode : constant Boolean := Hi_Con or Hi_Discr; + + Biased : constant Boolean := Has_Biased_Representation (E); + + begin + if Biased then + Get_External_Name_With_Suffix (E, "XB"); + else + Get_External_Name_With_Suffix (E, "XD"); + end if; + + if Lo_Encode or Hi_Encode then + if Biased then + Add_Str_To_Name_Buffer ("_"); + else + if Lo_Encode then + if Hi_Encode then + Add_Str_To_Name_Buffer ("LU_"); + else + Add_Str_To_Name_Buffer ("L_"); + end if; + else + Add_Str_To_Name_Buffer ("U_"); + end if; + end if; + + if Lo_Con then + Add_Uint_To_Buffer (Expr_Rep_Value (Lo)); + elsif Lo_Discr then + Get_Name_String_And_Append (Chars (Entity (Lo))); + end if; + + if Lo_Encode and Hi_Encode then + Add_Str_To_Name_Buffer ("__"); + end if; + + if Hi_Con then + Add_Uint_To_Buffer (Expr_Rep_Value (Hi)); + elsif Hi_Discr then + Get_Name_String_And_Append (Chars (Entity (Hi))); + end if; + end if; + end; + + -- For all other cases, the encoded name is the normal type name + + else + Has_Suffix := False; + Get_External_Name (E, Has_Suffix); + end if; + + if Debug_Flag_B and then Has_Suffix then + Write_Str ("**** type "); + Write_Name (Chars (E)); + Write_Str (" is encoded as "); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Eol; + end if; + + Name_Buffer (Name_Len + 1) := ASCII.NUL; + end Get_Encoded_Name; + + ----------------------- + -- Get_External_Name -- + ----------------------- + + procedure Get_External_Name (Entity : Entity_Id; Has_Suffix : Boolean) is + E : Entity_Id := Entity; + Kind : Entity_Kind; + + procedure Get_Qualified_Name_And_Append (Entity : Entity_Id); + -- Appends fully qualified name of given entity to Name_Buffer + + ----------------------------------- + -- Get_Qualified_Name_And_Append -- + ----------------------------------- + + procedure Get_Qualified_Name_And_Append (Entity : Entity_Id) is + begin + -- If the entity is a compilation unit, its scope is Standard, + -- there is no outer scope, and the no further qualification + -- is required. + + -- If the front end has already computed a fully qualified name, + -- then it is also the case that no further qualification is + -- required. + + if Present (Scope (Scope (Entity))) + and then not Has_Fully_Qualified_Name (Entity) + then + Get_Qualified_Name_And_Append (Scope (Entity)); + Add_Str_To_Name_Buffer ("__"); + Get_Name_String_And_Append (Chars (Entity)); + Append_Homonym_Number (Entity); + + else + Get_Name_String_And_Append (Chars (Entity)); + end if; + end Get_Qualified_Name_And_Append; + + -- Start of processing for Get_External_Name + + begin + Name_Len := 0; + Homonym_Len := 0; + + -- If this is a child unit, we want the child + + if Nkind (E) = N_Defining_Program_Unit_Name then + E := Defining_Identifier (Entity); + end if; + + Kind := Ekind (E); + + -- Case of interface name being used + + if (Kind = E_Procedure or else + Kind = E_Function or else + Kind = E_Constant or else + Kind = E_Variable or else + Kind = E_Exception) + and then Present (Interface_Name (E)) + and then No (Address_Clause (E)) + and then not Has_Suffix + then + Add_String_To_Name_Buffer (Strval (Interface_Name (E))); + + -- All other cases besides the interface name case + + else + -- If this is a library level subprogram (i.e. a subprogram that is a + -- compilation unit other than a subunit), then we prepend _ada_ to + -- ensure distinctions required as described in the spec. + + -- Check explicitly for child units, because those are not flagged + -- as Compilation_Units by lib. Should they be ??? + + if Is_Subprogram (E) + and then (Is_Compilation_Unit (E) or Is_Child_Unit (E)) + and then not Has_Suffix + then + Add_Str_To_Name_Buffer ("_ada_"); + end if; + + -- If the entity is a subprogram instance that is not a compilation + -- unit, generate the name of the original Ada entity, which is the + -- one gdb needs. + + if Is_Generic_Instance (E) + and then Is_Subprogram (E) + and then not Is_Compilation_Unit (Scope (E)) + and then (Ekind (Scope (E)) = E_Package + or else + Ekind (Scope (E)) = E_Package_Body) + and then Present (Related_Instance (Scope (E))) + then + E := Related_Instance (Scope (E)); + end if; + + Get_Qualified_Name_And_Append (E); + end if; + + Name_Buffer (Name_Len + 1) := ASCII.NUL; + end Get_External_Name; + + ----------------------------------- + -- Get_External_Name_With_Suffix -- + ----------------------------------- + + procedure Get_External_Name_With_Suffix + (Entity : Entity_Id; + Suffix : String) + is + Has_Suffix : constant Boolean := (Suffix /= ""); + + begin + -- If we are not in code generation mode, this procedure may still be + -- called from Back_End (more specifically - from gigi for doing type + -- representation annotation or some representation-specific checks). + -- But in this mode there is no need to mess with external names. + + -- Furthermore, the call causes difficulties in this case because the + -- string representing the homonym number is not correctly reset as a + -- part of the call to Output_Homonym_Numbers_Suffix (which is not + -- called in gigi). + + if Operating_Mode /= Generate_Code then + return; + end if; + + Get_External_Name (Entity, Has_Suffix); + + if Has_Suffix then + Add_Str_To_Name_Buffer ("___"); + Add_Str_To_Name_Buffer (Suffix); + Name_Buffer (Name_Len + 1) := ASCII.NUL; + end if; + end Get_External_Name_With_Suffix; + + -------------------------- + -- Get_Variant_Encoding -- + -------------------------- + + procedure Get_Variant_Encoding (V : Node_Id) is + Choice : Node_Id; + + procedure Choice_Val (Typ : Character; Choice : Node_Id); + -- Output encoded value for a single choice value. Typ is the key + -- character ('S', 'F', or 'T') that precedes the choice value. + + ---------------- + -- Choice_Val -- + ---------------- + + procedure Choice_Val (Typ : Character; Choice : Node_Id) is + begin + if Nkind (Choice) = N_Integer_Literal then + Add_Char_To_Name_Buffer (Typ); + Add_Uint_To_Buffer (Intval (Choice)); + + -- Character literal with no entity present (this is the case + -- Standard.Character or Standard.Wide_Character as root type) + + elsif Nkind (Choice) = N_Character_Literal + and then No (Entity (Choice)) + then + Add_Char_To_Name_Buffer (Typ); + Add_Uint_To_Buffer (Char_Literal_Value (Choice)); + + else + declare + Ent : constant Entity_Id := Entity (Choice); + + begin + if Ekind (Ent) = E_Enumeration_Literal then + Add_Char_To_Name_Buffer (Typ); + Add_Uint_To_Buffer (Enumeration_Rep (Ent)); + + else + pragma Assert (Ekind (Ent) = E_Constant); + Choice_Val (Typ, Constant_Value (Ent)); + end if; + end; + end if; + end Choice_Val; + + -- Start of processing for Get_Variant_Encoding + + begin + Name_Len := 0; + + Choice := First (Discrete_Choices (V)); + while Present (Choice) loop + if Nkind (Choice) = N_Others_Choice then + Add_Char_To_Name_Buffer ('O'); + + elsif Nkind (Choice) = N_Range then + Choice_Val ('R', Low_Bound (Choice)); + Choice_Val ('T', High_Bound (Choice)); + + elsif Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + then + Choice_Val ('R', Type_Low_Bound (Entity (Choice))); + Choice_Val ('T', Type_High_Bound (Entity (Choice))); + + elsif Nkind (Choice) = N_Subtype_Indication then + declare + Rang : constant Node_Id := + Range_Expression (Constraint (Choice)); + begin + Choice_Val ('R', Low_Bound (Rang)); + Choice_Val ('T', High_Bound (Rang)); + end; + + else + Choice_Val ('S', Choice); + end if; + + Next (Choice); + end loop; + + Name_Buffer (Name_Len + 1) := ASCII.NUL; + + if Debug_Flag_B then + declare + VP : constant Node_Id := Parent (V); -- Variant_Part + CL : constant Node_Id := Parent (VP); -- Component_List + RD : constant Node_Id := Parent (CL); -- Record_Definition + FT : constant Node_Id := Parent (RD); -- Full_Type_Declaration + + begin + Write_Str ("**** variant for type "); + Write_Name (Chars (Defining_Identifier (FT))); + Write_Str (" is encoded as "); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Eol; + end; + end if; + end Get_Variant_Encoding; + + ------------------------------------ + -- Get_Secondary_DT_External_Name -- + ------------------------------------ + + procedure Get_Secondary_DT_External_Name + (Typ : Entity_Id; + Ancestor_Typ : Entity_Id; + Suffix_Index : Int) + is + begin + Get_External_Name (Typ, Has_Suffix => False); + + if Ancestor_Typ /= Typ then + declare + Len : constant Natural := Name_Len; + Save_Str : constant String (1 .. Name_Len) + := Name_Buffer (1 .. Name_Len); + begin + Get_External_Name (Ancestor_Typ, Has_Suffix => False); + + -- Append the extended name of the ancestor to the + -- extended name of Typ + + Name_Buffer (Len + 2 .. Len + Name_Len + 1) := + Name_Buffer (1 .. Name_Len); + Name_Buffer (1 .. Len) := Save_Str; + Name_Buffer (Len + 1) := '_'; + Name_Len := Len + Name_Len + 1; + end; + end if; + + Add_Nat_To_Name_Buffer (Suffix_Index); + end Get_Secondary_DT_External_Name; + + --------------------------------- + -- Make_Packed_Array_Type_Name -- + --------------------------------- + + function Make_Packed_Array_Type_Name + (Typ : Entity_Id; + Csize : Uint) + return Name_Id + is + begin + Get_Name_String (Chars (Typ)); + Add_Str_To_Name_Buffer ("___XP"); + Add_Uint_To_Buffer (Csize); + return Name_Find; + end Make_Packed_Array_Type_Name; + + ----------------------------------- + -- Output_Homonym_Numbers_Suffix -- + ----------------------------------- + + procedure Output_Homonym_Numbers_Suffix is + J : Natural; + + begin + if Homonym_Len > 0 then + + -- Check for all 1's, in which case we do not output + + J := 1; + loop + exit when Homonym_Numbers (J) /= '1'; + + -- If we reached end of string we do not output + + if J = Homonym_Len then + Homonym_Len := 0; + return; + end if; + + exit when Homonym_Numbers (J + 1) /= '_'; + J := J + 2; + end loop; + + -- If we exit the loop then suffix must be output + + Add_Str_To_Name_Buffer ("__"); + Add_Str_To_Name_Buffer (Homonym_Numbers (1 .. Homonym_Len)); + Homonym_Len := 0; + end if; + end Output_Homonym_Numbers_Suffix; + + ------------------------------ + -- Prepend_String_To_Buffer -- + ------------------------------ + + procedure Prepend_String_To_Buffer (S : String) is + N : constant Integer := S'Length; + begin + Name_Buffer (1 + N .. Name_Len + N) := Name_Buffer (1 .. Name_Len); + Name_Buffer (1 .. N) := S; + Name_Len := Name_Len + N; + end Prepend_String_To_Buffer; + + ---------------------------- + -- Prepend_Uint_To_Buffer -- + ---------------------------- + + procedure Prepend_Uint_To_Buffer (U : Uint) is + begin + if U < 0 then + Prepend_String_To_Buffer ("m"); + Prepend_Uint_To_Buffer (-U); + else + UI_Image (U, Decimal); + Prepend_String_To_Buffer (UI_Image_Buffer (1 .. UI_Image_Length)); + end if; + end Prepend_Uint_To_Buffer; + + ------------------------------ + -- Qualify_All_Entity_Names -- + ------------------------------ + + procedure Qualify_All_Entity_Names is + E : Entity_Id; + Ent : Entity_Id; + + begin + for J in Name_Qualify_Units.First .. Name_Qualify_Units.Last loop + E := Defining_Entity (Name_Qualify_Units.Table (J)); + Qualify_Entity_Name (E); + + -- Normally entities in the qualification list are scopes, but in the + -- case of a library-level package renaming there is an associated + -- variable that encodes the debugger name and that variable is + -- entered in the list since it occurs in the Aux_Decls list of the + -- compilation and doesn't have a normal scope. + + if Ekind (E) /= E_Variable then + Ent := First_Entity (E); + while Present (Ent) loop + Qualify_Entity_Name (Ent); + Next_Entity (Ent); + + -- There are odd cases where Last_Entity (E) = E. This happens + -- in the case of renaming of packages. This test avoids + -- getting stuck in such cases. + + exit when Ent = E; + end loop; + end if; + end loop; + end Qualify_All_Entity_Names; + + ------------------------- + -- Qualify_Entity_Name -- + ------------------------- + + procedure Qualify_Entity_Name (Ent : Entity_Id) is + + Full_Qualify_Name : String (1 .. Name_Buffer'Length); + Full_Qualify_Len : Natural := 0; + -- Used to accumulate fully qualified name of subprogram + + procedure Fully_Qualify_Name (E : Entity_Id); + -- Used to qualify a subprogram or type name, where full + -- qualification up to Standard is always used. Name is set + -- in Full_Qualify_Name with the length in Full_Qualify_Len. + -- Note that this routine does not prepend the _ada_ string + -- required for library subprograms (this is done in the back end). + + function Is_BNPE (S : Entity_Id) return Boolean; + -- Determines if S is a BNPE, i.e. Body-Nested Package Entity, which + -- is defined to be a package which is immediately nested within a + -- package body. + + function Qualify_Needed (S : Entity_Id) return Boolean; + -- Given a scope, determines if the scope is to be included in the + -- fully qualified name, True if so, False if not. + + procedure Set_BNPE_Suffix (E : Entity_Id); + -- Recursive routine to append the BNPE qualification suffix. Works + -- from right to left with E being the current entity in the list. + -- The result does NOT have the trailing n's and trailing b stripped. + -- The caller must do this required stripping. + + procedure Set_Entity_Name (E : Entity_Id); + -- Internal recursive routine that does most of the work. This routine + -- leaves the result sitting in Name_Buffer and Name_Len. + + BNPE_Suffix_Needed : Boolean := False; + -- Set true if a body-nested package entity suffix is required + + Save_Chars : constant Name_Id := Chars (Ent); + -- Save original name + + ------------------------ + -- Fully_Qualify_Name -- + ------------------------ + + procedure Fully_Qualify_Name (E : Entity_Id) is + Discard : Boolean := False; + + begin + -- Ignore empty entry (can happen in error cases) + + if No (E) then + return; + + -- If this we are qualifying entities local to a generic + -- instance, use the name of the original instantiation, + -- not that of the anonymous subprogram in the wrapper + -- package, so that gdb doesn't have to know about these. + + elsif Is_Generic_Instance (E) + and then Is_Subprogram (E) + and then not Comes_From_Source (E) + and then not Is_Compilation_Unit (Scope (E)) + then + Fully_Qualify_Name (Related_Instance (Scope (E))); + return; + end if; + + -- If we reached fully qualified name, then just copy it + + if Has_Fully_Qualified_Name (E) then + Get_Name_String (Chars (E)); + Strip_Suffixes (Discard); + Full_Qualify_Name (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); + Full_Qualify_Len := Name_Len; + Set_Has_Fully_Qualified_Name (Ent); + + -- Case of non-fully qualified name + + else + if Scope (E) = Standard_Standard then + Set_Has_Fully_Qualified_Name (Ent); + else + Fully_Qualify_Name (Scope (E)); + Full_Qualify_Name (Full_Qualify_Len + 1) := '_'; + Full_Qualify_Name (Full_Qualify_Len + 2) := '_'; + Full_Qualify_Len := Full_Qualify_Len + 2; + end if; + + if Has_Qualified_Name (E) then + Get_Unqualified_Name_String (Chars (E)); + else + Get_Name_String (Chars (E)); + end if; + + -- Here we do one step of the qualification + + Full_Qualify_Name + (Full_Qualify_Len + 1 .. Full_Qualify_Len + Name_Len) := + Name_Buffer (1 .. Name_Len); + Full_Qualify_Len := Full_Qualify_Len + Name_Len; + Append_Homonym_Number (E); + end if; + + if Is_BNPE (E) then + BNPE_Suffix_Needed := True; + end if; + end Fully_Qualify_Name; + + ------------- + -- Is_BNPE -- + ------------- + + function Is_BNPE (S : Entity_Id) return Boolean is + begin + return + Ekind (S) = E_Package + and then Is_Package_Body_Entity (S); + end Is_BNPE; + + -------------------- + -- Qualify_Needed -- + -------------------- + + function Qualify_Needed (S : Entity_Id) return Boolean is + begin + -- If we got all the way to Standard, then we have certainly + -- fully qualified the name, so set the flag appropriately, + -- and then return False, since we are most certainly done! + + if S = Standard_Standard then + Set_Has_Fully_Qualified_Name (Ent, True); + return False; + + -- Otherwise figure out if further qualification is required + + else + return + Is_Subprogram (Ent) + or else + Ekind (Ent) = E_Subprogram_Body + or else + (Ekind (S) /= E_Block + and then not Is_Dynamic_Scope (S)); + end if; + end Qualify_Needed; + + --------------------- + -- Set_BNPE_Suffix -- + --------------------- + + procedure Set_BNPE_Suffix (E : Entity_Id) is + S : constant Entity_Id := Scope (E); + + begin + if Qualify_Needed (S) then + Set_BNPE_Suffix (S); + + if Is_BNPE (E) then + Add_Char_To_Name_Buffer ('b'); + else + Add_Char_To_Name_Buffer ('n'); + end if; + + else + Add_Char_To_Name_Buffer ('X'); + end if; + end Set_BNPE_Suffix; + + --------------------- + -- Set_Entity_Name -- + --------------------- + + procedure Set_Entity_Name (E : Entity_Id) is + S : constant Entity_Id := Scope (E); + + begin + -- If we reach an already qualified name, just take the encoding + -- except that we strip the package body suffixes, since these + -- will be separately put on later. + + if Has_Qualified_Name (E) then + Get_Name_String_And_Append (Chars (E)); + Strip_Suffixes (BNPE_Suffix_Needed); + + -- If the top level name we are adding is itself fully + -- qualified, then that means that the name that we are + -- preparing for the Fully_Qualify_Name call will also + -- generate a fully qualified name. + + if Has_Fully_Qualified_Name (E) then + Set_Has_Fully_Qualified_Name (Ent); + end if; + + -- Case where upper level name is not encoded yet + + else + -- Recurse if further qualification required + + if Qualify_Needed (S) then + Set_Entity_Name (S); + Add_Str_To_Name_Buffer ("__"); + end if; + + -- Otherwise get name and note if it is a BNPE + + Get_Name_String_And_Append (Chars (E)); + + if Is_BNPE (E) then + BNPE_Suffix_Needed := True; + end if; + + Append_Homonym_Number (E); + end if; + end Set_Entity_Name; + + -- Start of processing for Qualify_Entity_Name + + begin + if Has_Qualified_Name (Ent) then + return; + + -- If the entity is a variable encoding the debug name for an object + -- renaming, then the qualified name of the entity associated with the + -- renamed object can now be incorporated in the debug name. + + elsif Ekind (Ent) = E_Variable + and then Present (Debug_Renaming_Link (Ent)) + then + Name_Len := 0; + Qualify_Entity_Name (Debug_Renaming_Link (Ent)); + Get_Name_String (Chars (Ent)); + + -- Retrieve the now-qualified name of the renamed entity and insert + -- it in the middle of the name, just preceding the suffix encoding + -- describing the renamed object. + + declare + Renamed_Id : constant String := + Get_Name_String (Chars (Debug_Renaming_Link (Ent))); + Insert_Len : constant Integer := Renamed_Id'Length + 1; + Index : Natural := Name_Len - 3; + + begin + -- Loop backwards through the name to find the start of the "___" + -- sequence associated with the suffix. + + while Index >= Name_Buffer'First + and then (Name_Buffer (Index + 1) /= '_' + or else Name_Buffer (Index + 2) /= '_' + or else Name_Buffer (Index + 3) /= '_') + loop + Index := Index - 1; + end loop; + + pragma Assert (Name_Buffer (Index + 1 .. Index + 3) = "___"); + + -- Insert an underscore separator and the entity name just in + -- front of the suffix. + + Name_Buffer (Index + 1 + Insert_Len .. Name_Len + Insert_Len) := + Name_Buffer (Index + 1 .. Name_Len); + Name_Buffer (Index + 1) := '_'; + Name_Buffer (Index + 2 .. Index + Insert_Len) := Renamed_Id; + Name_Len := Name_Len + Insert_Len; + end; + + -- Reset the name of the variable to the new name that includes the + -- name of the renamed entity. + + Set_Chars (Ent, Name_Enter); + + -- If the entity needs qualification by its scope then develop it + -- here, add the variable's name, and again reset the entity name. + + if Qualify_Needed (Scope (Ent)) then + Name_Len := 0; + Set_Entity_Name (Scope (Ent)); + Add_Str_To_Name_Buffer ("__"); + + Get_Name_String_And_Append (Chars (Ent)); + + Set_Chars (Ent, Name_Enter); + end if; + + Set_Has_Qualified_Name (Ent); + return; + + elsif Is_Subprogram (Ent) + or else Ekind (Ent) = E_Subprogram_Body + or else Is_Type (Ent) + then + Fully_Qualify_Name (Ent); + Name_Len := Full_Qualify_Len; + Name_Buffer (1 .. Name_Len) := Full_Qualify_Name (1 .. Name_Len); + + elsif Qualify_Needed (Scope (Ent)) then + Name_Len := 0; + Set_Entity_Name (Ent); + + else + Set_Has_Qualified_Name (Ent); + return; + end if; + + -- Fall through with a fully qualified name in Name_Buffer/Name_Len + + Output_Homonym_Numbers_Suffix; + + -- Add body-nested package suffix if required + + if BNPE_Suffix_Needed + and then Ekind (Ent) /= E_Enumeration_Literal + then + Set_BNPE_Suffix (Ent); + + -- Strip trailing n's and last trailing b as required. note that + -- we know there is at least one b, or no suffix would be generated. + + while Name_Buffer (Name_Len) = 'n' loop + Name_Len := Name_Len - 1; + end loop; + + Name_Len := Name_Len - 1; + end if; + + Set_Chars (Ent, Name_Enter); + Set_Has_Qualified_Name (Ent); + + if Debug_Flag_BB then + Write_Str ("*** "); + Write_Name (Save_Chars); + Write_Str (" qualified as "); + Write_Name (Chars (Ent)); + Write_Eol; + end if; + end Qualify_Entity_Name; + + -------------------------- + -- Qualify_Entity_Names -- + -------------------------- + + procedure Qualify_Entity_Names (N : Node_Id) is + begin + Name_Qualify_Units.Append (N); + end Qualify_Entity_Names; + + -------------------- + -- Strip_Suffixes -- + -------------------- + + procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean) is + SL : Natural; + + pragma Warnings (Off, BNPE_Suffix_Found); + -- Since this procedure only ever sets the flag + + begin + -- Search for and strip BNPE suffix + + for J in reverse 2 .. Name_Len loop + if Name_Buffer (J) = 'X' then + Name_Len := J - 1; + BNPE_Suffix_Found := True; + exit; + end if; + + exit when Name_Buffer (J) /= 'b' and then Name_Buffer (J) /= 'n'; + end loop; + + -- Search for and strip homonym numbers suffix + + for J in reverse 2 .. Name_Len - 2 loop + if Name_Buffer (J) = '_' + and then Name_Buffer (J + 1) = '_' + then + if Name_Buffer (J + 2) in '0' .. '9' then + if Homonym_Len > 0 then + Homonym_Len := Homonym_Len + 1; + Homonym_Numbers (Homonym_Len) := '-'; + end if; + + SL := Name_Len - (J + 1); + + Homonym_Numbers (Homonym_Len + 1 .. Homonym_Len + SL) := + Name_Buffer (J + 2 .. Name_Len); + Name_Len := J - 1; + Homonym_Len := Homonym_Len + SL; + end if; + + exit; + end if; + end loop; + end Strip_Suffixes; + +end Exp_Dbug; diff --git a/gcc/ada/exp_dbug.ads b/gcc/ada/exp_dbug.ads new file mode 100644 index 000000000..5dcbd9148 --- /dev/null +++ b/gcc/ada/exp_dbug.ads @@ -0,0 +1,1592 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ D B U G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1996-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for generation of special declarations used by the +-- debugger. In accordance with the Dwarf 2.2 specification, certain +-- type names are encoded to provide information to the debugger. + +with Namet; use Namet; +with Types; use Types; +with Uintp; use Uintp; + +package Exp_Dbug is + + ----------------------------------------------------- + -- Encoding and Qualification of Names of Entities -- + ----------------------------------------------------- + + -- This section describes how the names of entities are encoded in the + -- generated debugging information. + + -- An entity in Ada has a name of the form X.Y.Z ... E where X,Y,Z are the + -- enclosing scopes (not including Standard at the start). + + -- The encoding of the name follows this basic qualified naming scheme, + -- where the encoding of individual entity names is as described in Namet + -- (i.e. in particular names present in the original source are folded to + -- all lower case, with upper half and wide characters encoded as described + -- in Namet). Upper case letters are used only for entities generated by + -- the compiler. + + -- There are two cases, global entities, and local entities. In more formal + -- terms, local entities are those which have a dynamic enclosing scope, + -- and global entities are at the library level, except that we always + -- consider procedures to be global entities, even if they are nested + -- (that's because at the debugger level a procedure name refers to the + -- code, and the code is indeed a global entity, including the case of + -- nested procedures.) In addition, we also consider all types to be global + -- entities, even if they are defined within a procedure. + + -- The reason for treating all type names as global entities is that a + -- number of our type encodings work by having related type names, and we + -- need the full qualification to keep this unique. + + -- For global entities, the encoded name includes all components of the + -- fully expanded name (but omitting Standard at the start). For example, + -- if a library level child package P.Q has an embedded package R, and + -- there is an entity in this embedded package whose name is S, the encoded + -- name will include the components p.q.r.s. + + -- For local entities, the encoded name only includes the components up to + -- the enclosing dynamic scope (other than a block). At run time, such a + -- dynamic scope is a subprogram, and the debugging formats know about + -- local variables of procedures, so it is not necessary to have full + -- qualification for such entities. In particular this means that direct + -- local variables of a procedure are not qualified. + + -- As an example of the local name convention, consider a procedure V.W + -- with a local variable X, and a nested block Y containing an entity Z. + -- The fully qualified names of the entities X and Z are: + + -- V.W.X + -- V.W.Y.Z + + -- but since V.W is a subprogram, the encoded names will end up + -- encoding only + + -- x + -- y.z + + -- The separating dots are translated into double underscores + + ----------------------------- + -- Handling of Overloading -- + ----------------------------- + + -- The above scheme is incomplete for overloaded subprograms, since + -- overloading can legitimately result in case of two entities with + -- exactly the same fully qualified names. To distinguish between + -- entries in a set of overloaded subprograms, the encoded names are + -- serialized by adding the suffix: + + -- __nn (two underscores) + + -- where nn is a serial number (2 for the second overloaded function, + -- 3 for the third, etc.). A suffix of __1 is always omitted (i.e. no + -- suffix implies the first instance). + + -- These names are prefixed by the normal full qualification. So for + -- example, the third instance of the subprogram qrs in package yz + -- would have the name: + + -- yz__qrs__3 + + -- A more subtle case arises with entities declared within overloaded + -- subprograms. If we have two overloaded subprograms, and both declare + -- an entity xyz, then the fully expanded name of the two xyz's is the + -- same. To distinguish these, we add the same __n suffix at the end of + -- the inner entity names. + + -- In more complex cases, we can have multiple levels of overloading, + -- and we must make sure to distinguish which final declarative region + -- we are talking about. For this purpose, we use a more complex suffix + -- which has the form: + + -- __nn_nn_nn ... + + -- where the nn values are the homonym numbers as needed for any of the + -- qualifying entities, separated by a single underscore. If all the nn + -- values are 1, the suffix is omitted, Otherwise the suffix is present + -- (including any values of 1). The following example shows how this + -- suffixing works. + + -- package body Yz is + -- procedure Qrs is -- Name is yz__qrs + -- procedure Tuv is ... end; -- Name is yz__qrs__tuv + -- begin ... end Qrs; + + -- procedure Qrs (X: Int) is -- Name is yz__qrs__2 + -- procedure Tuv is ... end; -- Name is yz__qrs__tuv__2_1 + -- procedure Tuv (X: Int) is -- Name is yz__qrs__tuv__2_2 + -- begin ... end Tuv; + + -- procedure Tuv (X: Float) is -- Name is yz__qrs__tuv__2_3 + -- type m is new float; -- Name is yz__qrs__tuv__m__2_3 + -- begin ... end Tuv; + -- begin ... end Qrs; + -- end Yz; + + -------------------- + -- Operator Names -- + -------------------- + + -- The above rules applied to operator names would result in names with + -- quotation marks, which are not typically allowed by assemblers and + -- linkers, and even if allowed would be odd and hard to deal with. To + -- avoid this problem, operator names are encoded as follows: + + -- Oabs abs + -- Oand and + -- Omod mod + -- Onot not + -- Oor or + -- Orem rem + -- Oxor xor + -- Oeq = + -- One /= + -- Olt < + -- Ole <= + -- Ogt > + -- Oge >= + -- Oadd + + -- Osubtract - + -- Oconcat & + -- Omultiply * + -- Odivide / + -- Oexpon ** + + -- These names are prefixed by the normal full qualification, and + -- suffixed by the overloading identification. So for example, the + -- second operator "=" defined in package Extra.Messages would have + -- the name: + + -- extra__messages__Oeq__2 + + ---------------------------------- + -- Resolving Other Name Clashes -- + ---------------------------------- + + -- It might be thought that the above scheme is complete, but in Ada 95, + -- full qualification is insufficient to uniquely identify an entity in + -- the program, even if it is not an overloaded subprogram. There are + -- two possible confusions: + + -- a.b + + -- interpretation 1: entity b in body of package a + -- interpretation 2: child procedure b of package a + + -- a.b.c + + -- interpretation 1: entity c in child package a.b + -- interpretation 2: entity c in nested package b in body of a + + -- It is perfectly legal in both cases for both interpretations to be + -- valid within a single program. This is a bit of a surprise since + -- certainly in Ada 83, full qualification was sufficient, but not in + -- Ada 95. The result is that the above scheme can result in duplicate + -- names. This would not be so bad if the effect were just restricted + -- to debugging information, but in fact in both the above cases, it + -- is possible for both symbols to be external names, and so we have + -- a real problem of name clashes. + + -- To deal with this situation, we provide two additional encoding + -- rules for names: + + -- First: all library subprogram names are preceded by the string + -- _ada_ (which causes no duplications, since normal Ada names can + -- never start with an underscore. This not only solves the first + -- case of duplication, but also solves another pragmatic problem + -- which is that otherwise Ada procedures can generate names that + -- clash with existing system function names. Most notably, we can + -- have clashes in the case of procedure Main with the C main that + -- in some systems is always present. + + -- Second, for the case where nested packages declared in package + -- bodies can cause trouble, we add a suffix which shows which + -- entities in the list are body-nested packages, i.e. packages + -- whose spec is within a package body. The rules are as follows, + -- given a list of names in a qualified name name1.name2.... + + -- If none are body-nested package entities, then there is no suffix + + -- If at least one is a body-nested package entity, then the suffix + -- is X followed by a string of b's and n's (b = body-nested package + -- entity, n = not a body-nested package). + + -- There is one element in this string for each entity in the encoded + -- expanded name except the first (the rules are such that the first + -- entity of the encoded expanded name can never be a body-nested' + -- package. Trailing n's are omitted, as is the last b (there must + -- be at least one b, or we would not be generating a suffix at all). + + -- For example, suppose we have + + -- package x is + -- pragma Elaborate_Body; + -- m1 : integer; -- #1 + -- end x; + + -- package body x is + -- package y is m2 : integer; end y; -- #2 + -- package body y is + -- package z is r : integer; end z; -- #3 + -- end; + -- m3 : integer; -- #4 + -- end x; + + -- package x.y is + -- pragma Elaborate_Body; + -- m2 : integer; -- #5 + -- end x.y; + + -- package body x.y is + -- m3 : integer; -- #6 + -- procedure j is -- #7 + -- package k is + -- z : integer; -- #8 + -- end k; + -- begin + -- null; + -- end j; + -- end x.y; + + -- procedure x.m3 is begin null; end; -- #9 + + -- Then the encodings would be: + + -- #1. x__m1 (no BNPE's in sight) + -- #2. x__y__m2X (y is a BNPE) + -- #3. x__y__z__rXb (y is a BNPE, so is z) + -- #4. x__m3 (no BNPE's in sight) + -- #5. x__y__m2 (no BNPE's in sight) + -- #6. x__y__m3 (no BNPE's in signt) + -- #7. x__y__j (no BNPE's in sight) + -- #8. k__z (no BNPE's, only up to procedure) + -- #9 _ada_x__m3 (library level subprogram) + + -- Note that we have instances here of both kind of potential name + -- clashes, and the above examples show how the encodings avoid the + -- clash as follows: + + -- Lines #4 and #9 both refer to the entity x.m3, but #9 is a library + -- level subprogram, so it is preceded by the string _ada_ which acts + -- to distinguish it from the package body entity. + + -- Lines #2 and #5 both refer to the entity x.y.m2, but the first + -- instance is inside the body-nested package y, so there is an X + -- suffix to distinguish it from the child library entity. + + -- Note that enumeration literals never need Xb type suffixes, since + -- they are never referenced using global external names. + + --------------------- + -- Interface Names -- + --------------------- + + -- Note: if an interface name is present, then the external name is + -- taken from the specified interface name. Given current limitations of + -- the gcc backend, this means that the debugging name is also set to + -- the interface name, but conceptually, it would be possible (and + -- indeed desirable) to have the debugging information still use the Ada + -- name as qualified above, so we still fully qualify the name in the + -- front end. + + ------------------------------------- + -- Encodings Related to Task Types -- + ------------------------------------- + + -- Each task object defined by a single task declaration is associated + -- with a prefix that is used to qualify procedures defined in that + -- task. Given + -- + -- package body P is + -- task body TaskObj is + -- procedure F1 is ... end; + -- begin + -- B; + -- end TaskObj; + -- end P; + -- + -- The name of subprogram TaskObj.F1 is encoded as p__taskobjTK__f1. + -- The body, B, is contained in a subprogram whose name is + -- p__taskobjTKB. + + ------------------------------------------ + -- Encodings Related to Protected Types -- + ------------------------------------------ + + -- Each protected type has an associated record type, that describes + -- the actual layout of the private data. In addition to the private + -- components of the type, the Corresponding_Record_Type includes one + -- component of type Protection, which is the actual lock structure. + -- The run-time size of the protected type is the size of the corres- + -- ponding record. + + -- For a protected type prot, the Corresponding_Record_Type is encoded + -- as protV. + + -- The operations of a protected type are encoded as follows: each + -- operation results in two subprograms, a locking one that is called + -- from outside of the object, and a non-locking one that is used for + -- calls from other operations on the same object. The locking operation + -- simply acquires the lock, and then calls the non-locking version. + -- The names of all of these have a prefix constructed from the name of + -- the type, and a suffix which is P or N, depending on whether this is + -- the protected/non-locking version of the operation. + + -- Operations generated for protected entries follow the same encoding. + -- Each entry results in two subprograms: a procedure that holds the + -- entry body, and a function that holds the evaluation of the barrier. + -- The names of these subprograms include the prefix '_E' or '_B' res- + -- pectively. The names also include a numeric suffix to render them + -- unique in the presence of overloaded entries. + + -- Given the declaration: + + -- protected type Lock is + -- function Get return Integer; + -- procedure Set (X: Integer); + -- entry Update (Val : Integer); + -- private + -- Value : Integer := 0; + -- end Lock; + + -- the following operations are created: + + -- lock_getN + -- lock_getP, + + -- lock_setN + -- lock_setP + + -- lock_update_E1s + -- lock_udpate_B2s + + -- If the protected type implements at least one interface, the + -- following additional operations are created: + + -- lock_get + + -- lock_set + + -- These operations are used to ensure overriding of interface level + -- subprograms and proper dispatching on interface class-wide objects. + -- The bodies of these operations contain calls to their respective + -- protected versions: + + -- function lock_get return Integer is + -- begin + -- return lock_getP; + -- end lock_get; + + -- procedure lock_set (X : Integer) is + -- begin + -- lock_setP (X); + -- end lock_set; + + ---------------------------------------------------- + -- Conversion between Entities and External Names -- + ---------------------------------------------------- + + No_Dollar_In_Label : constant Boolean := True; + -- True iff the target does not allow dollar signs ("$") in external names + -- ??? We want to migrate all platforms to use the same convention. As a + -- first step, we force this constant to always be True. This constant will + -- eventually be deleted after we have verified that the migration does not + -- cause any unforeseen adverse impact. We chose "__" because it is + -- supported on all platforms, which is not the case of "$". + + procedure Get_External_Name + (Entity : Entity_Id; + Has_Suffix : Boolean); + -- Set Name_Buffer and Name_Len to the external name of entity E. The + -- external name is the Interface_Name, if specified, unless the entity + -- has an address clause or a suffix. + -- + -- If the Interface is not present, or not used, the external name is the + -- concatenation of: + -- + -- - the string "_ada_", if the entity is a library subprogram, + -- - the names of any enclosing scopes, each followed by "__", + -- or "X_" if the next entity is a subunit) + -- - the name of the entity + -- - the string "$" (or "__" if target does not allow "$"), followed + -- by homonym suffix, if the entity is an overloaded subprogram + -- or is defined within an overloaded subprogram. + + procedure Get_External_Name_With_Suffix + (Entity : Entity_Id; + Suffix : String); + -- Set Name_Buffer and Name_Len to the external name of entity E. If + -- Suffix is the empty string the external name is as above, otherwise + -- the external name is the concatenation of: + -- + -- - the string "_ada_", if the entity is a library subprogram, + -- - the names of any enclosing scopes, each followed by "__", + -- or "X_" if the next entity is a subunit) + -- - the name of the entity + -- - the string "$" (or "__" if target does not allow "$"), followed + -- by homonym suffix, if the entity is an overloaded subprogram + -- or is defined within an overloaded subprogram. + -- - the string "___" followed by Suffix + -- + -- Note that a call to this procedure has no effect if we are not + -- generating code, since the necessary information for computing the + -- proper encoded name is not available in this case. + + -------------------------------------------- + -- Subprograms for Handling Qualification -- + -------------------------------------------- + + procedure Qualify_Entity_Names (N : Node_Id); + -- Given a node N, that represents a block, subprogram body, or package + -- body or spec, or protected or task type, sets a fully qualified name + -- for the defining entity of given construct, and also sets fully + -- qualified names for all enclosed entities of the construct (using + -- First_Entity/Next_Entity). Note that the actual modifications of the + -- names is postponed till a subsequent call to Qualify_All_Entity_Names. + -- Note: this routine does not deal with prepending _ada_ to library + -- subprogram names. The reason for this is that we only prepend _ada_ + -- to the library entity itself, and not to names built from this name. + + procedure Qualify_All_Entity_Names; + -- When Qualify_Entity_Names is called, no actual name changes are made, + -- i.e. the actual calls to Qualify_Entity_Name are deferred until a call + -- is made to this procedure. The reason for this deferral is that when + -- names are changed semantic processing may be affected. By deferring + -- the changes till just before gigi is called, we avoid any concerns + -- about such effects. Gigi itself does not use the names except for + -- output of names for debugging purposes (which is why we are doing + -- the name changes in the first place. + + -- Note: the routines Get_Unqualified_[Decoded]_Name_String in Namet are + -- useful to remove qualification from a name qualified by the call to + -- Qualify_All_Entity_Names. + + -------------------------------- + -- Handling of Numeric Values -- + -------------------------------- + + -- All numeric values here are encoded as strings of decimal digits. Only + -- integer values need to be encoded. A negative value is encoded as the + -- corresponding positive value followed by a lower case m for minus to + -- indicate that the value is negative (e.g. 2m for -2). + + ------------------------- + -- Type Name Encodings -- + ------------------------- + + -- In the following typ is the name of the type as normally encoded by the + -- debugger rules, i.e. a non-qualified name, all in lower case, with + -- standard encoding of upper half and wide characters + + ------------------------ + -- Encapsulated Types -- + ------------------------ + + -- In some cases, the compiler encapsulates a type by wrapping it in a + -- structure. For example, this is used when a size or alignment + -- specification requires a larger type. Consider: + + -- type y is mod 2 ** 64; + -- for y'size use 256; + + -- In this case the compile generates a structure type y___PAD, which + -- has a single field whose name is F. This single field is 64 bits + -- long and contains the actual value. This kind of padding is used + -- when the logical value to be stored is shorter than the object in + -- which it is allocated. For example if a size clause is used to set + -- a size of 256 for a signed integer value, then a typical choice is + -- to wrap a 64-bit integer in a 256 bit PAD structure. + + -- A similar encapsulation is done for some packed array types, in which + -- case the structure type is y___JM and the field name is OBJECT. + -- This is used in the case of a packed array stored using modular + -- representation (see section on representation of packed array + -- objects). In this case the JM wrapping is used to achieve correct + -- positioning of the packed array value (left or right justified in its + -- field depending on endianness. + + -- When the debugger sees an object of a type whose name has a suffix of + -- ___PAD or ___JM, the type will be a record containing a single field, + -- and the name of that field will be all upper case. In this case, it + -- should look inside to get the value of the inner field, and neither + -- the outer structure name, nor the field name should appear when the + -- value is printed. + + -- When the debugger sees a record named REP being a field inside + -- another record, it should treat the fields inside REP as being part + -- of the outer record (this REP field is only present for code + -- generation purposes). The REP record should not appear in the values + -- printed by the debugger. + + ----------------------- + -- Fixed-Point Types -- + ----------------------- + + -- Fixed-point types are encoded using a suffix that indicates the + -- delta and small values. The actual type itself is a normal integer + -- type. + + -- typ___XF_nn_dd + -- typ___XF_nn_dd_nn_dd + + -- The first form is used when small = delta. The value of delta (and + -- small) is given by the rational nn/dd, where nn and dd are decimal + -- integers. + -- + -- The second form is used if the small value is different from the + -- delta. In this case, the first nn/dd rational value is for delta, + -- and the second value is for small. + + ------------------------------ + -- VAX Floating-Point Types -- + ------------------------------ + + -- Vax floating-point types are represented at run time as integer + -- types, which are treated specially by the code generator. Their + -- type names are encoded with the following suffix: + + -- typ___XFF + -- typ___XFD + -- typ___XFG + + -- representing the Vax F Float, D Float, and G Float types. The + -- debugger must treat these specially. In particular, printing these + -- values can be achieved using the debug procedures that are provided + -- in package System.Vax_Float_Operations: + + -- procedure Debug_Output_D (Arg : D); + -- procedure Debug_Output_F (Arg : F); + -- procedure Debug_Output_G (Arg : G); + + -- These three procedures take a Vax floating-point argument, and + -- output a corresponding decimal representation to standard output + -- with no terminating line return. + + -------------------- + -- Discrete Types -- + -------------------- + + -- Discrete types are coded with a suffix indicating the range in the + -- case where one or both of the bounds are discriminants or variable. + + -- Note: at the current time, we also encode compile time known bounds + -- if they do not match the natural machine type bounds, but this may + -- be removed in the future, since it is redundant for most debugging + -- formats. However, we do not ever need XD encoding for enumeration + -- base types, since here it is always clear what the bounds are from + -- the total number of enumeration literals. + + -- typ___XD + -- typ___XDL_lowerbound + -- typ___XDU_upperbound + -- typ___XDLU_lowerbound__upperbound + + -- If a discrete type is a natural machine type (i.e. its bounds + -- correspond in a natural manner to its size), then it is left + -- unencoded. The above encoding forms are used when there is a + -- constrained range that does not correspond to the size or that + -- has discriminant references or other compile time known bounds. + + -- The first form is used if both bounds are dynamic, in which case two + -- constant objects are present whose names are typ___L and typ___U in + -- the same scope as typ, and the values of these constants indicate + -- the bounds. As far as the debugger is concerned, these are simply + -- variables that can be accessed like any other variables. In the + -- enumeration case, these values correspond to the Enum_Rep values for + -- the lower and upper bounds. + + -- The second form is used if the upper bound is dynamic, but the lower + -- bound is either constant or depends on a discriminant of the record + -- with which the type is associated. The upper bound is stored in a + -- constant object of name typ___U as previously described, but the + -- lower bound is encoded directly into the name as either a decimal + -- integer, or as the discriminant name. + + -- The third form is similarly used if the lower bound is dynamic, but + -- the upper bound is compile time known or a discriminant reference, + -- in which case the lower bound is stored in a constant object of name + -- typ___L, and the upper bound is encoded directly into the name as + -- either a decimal integer, or as the discriminant name. + + -- The fourth form is used if both bounds are discriminant references + -- or compile time known values, with the encoding first for the lower + -- bound, then for the upper bound, as previously described. + + ------------------- + -- Modular Types -- + ------------------- + + -- A type declared + + -- type x is mod N; + + -- Is encoded as a subrange of an unsigned base type with lower bound + -- zero and upper bound N. That is, there is no name encoding. We use + -- the standard encodings provided by the debugging format. Thus we + -- give these types a non-standard interpretation: the standard + -- interpretation of our encoding would not, in general, imply that + -- arithmetic on type x was to be performed modulo N (especially not + -- when N is not a power of 2). + + ------------------ + -- Biased Types -- + ------------------ + + -- Only discrete types can be biased, and the fact that they are biased + -- is indicated by a suffix of the form: + + -- typ___XB_lowerbound__upperbound + + -- Here lowerbound and upperbound are decimal integers, with the usual + -- (postfix "m") encoding for negative numbers. Biased types are only + -- possible where the bounds are compile time known, and the values are + -- represented as unsigned offsets from the lower bound given. For + -- example: + + -- type Q is range 10 .. 15; + -- for Q'size use 3; + + -- The size clause will force values of type Q in memory to be stored + -- in biased form (e.g. 11 will be represented by the bit pattern 001). + + ---------------------------------------------- + -- Record Types with Variable-Length Fields -- + ---------------------------------------------- + + -- The debugging formats do not fully support these types, and indeed + -- some formats simply generate no useful information at all for such + -- types. In order to provide information for the debugger, gigi creates + -- a parallel type in the same scope with one of the names + + -- type___XVE + -- type___XVU + + -- The former name is used for a record and the latter for the union + -- that is made for a variant record (see below) if that record or union + -- has a field of variable size or if the record or union itself has a + -- variable size. These encodings suffix any other encodings that that + -- might be suffixed to the type name. + + -- The idea here is to provide all the needed information to interpret + -- objects of the original type in the form of a "fixed up" type, which + -- is representable using the normal debugging information. + + -- There are three cases to be dealt with. First, some fields may have + -- variable positions because they appear after variable-length fields. + -- To deal with this, we encode *all* the field bit positions of the + -- special ___XV type in a non-standard manner. + + -- The idea is to encode not the position, but rather information that + -- allows computing the position of a field from the position of the + -- previous field. The algorithm for computing the actual positions of + -- all fields and the length of the record is as follows. In this + -- description, let P represent the current bit position in the record. + + -- 1. Initialize P to 0 + + -- 2. For each field in the record: + + -- 2a. If an alignment is given (see below), then round P up, if + -- needed, to the next multiple of that alignment. + + -- 2b. If a bit position is given, then increment P by that amount + -- (that is, treat it as an offset from the end of the preceding + -- record). + + -- 2c. Assign P as the actual position of the field + + -- 2d. Compute the length, L, of the represented field (see below) + -- and compute P'=P+L. Unless the field represents a variant part + -- (see below and also Variant Record Encoding), set P to P'. + + -- The alignment, if present, is encoded in the field name of the + -- record, which has a suffix: + + -- fieldname___XVAnn + + -- where the nn after the XVA indicates the alignment value in storage + -- units. This encoding is present only if an alignment is present. + + -- The size of the record described by an XVE-encoded type (in bits) is + -- generally the maximum value attained by P' in step 2d above, rounded + -- up according to the record's alignment. + + -- Second, the variable-length fields themselves are represented by + -- replacing the type by a special access type. The designated type of + -- this access type is the original variable-length type, and the fact + -- that this field has been transformed in this way is signalled by + -- encoding the field name as: + + -- field___XVL + + -- where field is the original field name. If a field is both + -- variable-length and also needs an alignment encoding, then the + -- encodings are combined using: + + -- field___XVLnn + + -- Note: the reason that we change the type is so that the resulting + -- type has no variable-length fields. At least some of the formats used + -- for debugging information simply cannot tolerate variable- length + -- fields, so the encoded information would get lost. + + -- Third, in the case of a variant record, the special union that + -- contains the variants is replaced by a normal C union. In this case, + -- the positions are all zero. + + -- Discriminants appear before any variable-length fields that depend on + -- them, with one exception. In some cases, a discriminant governing the + -- choice of a variant clause may appear in the list of fields of an XVE + -- type after the entry for the variant clause itself (this can happen + -- in the presence of a representation clause for the record type in the + -- source program). However, when this happens, the discriminant's + -- position may be determined by first applying the rules described in + -- this section, ignoring the variant clause. As a result, discriminants + -- can always be located independently of the variable-length fields + -- that depend on them. + + -- The size of the ___XVE or ___XVU record or union is set to the + -- alignment (in bytes) of the original object so that the debugger + -- can calculate the size of the original type. + + -- As an example of this encoding, consider the declarations: + + -- type Q is array (1 .. V1) of Float; -- alignment 4 + -- type R is array (1 .. V2) of Long_Float; -- alignment 8 + + -- type X is record + -- A : Character; + -- B : Float; + -- C : String (1 .. V3); + -- D : Float; + -- E : Q; + -- F : R; + -- G : Float; + -- end record; + + -- The encoded type looks like: + + -- type anonymousQ is access Q; + -- type anonymousR is access R; + + -- type X___XVE is record + -- A : Character; -- position contains 0 + -- B : Float; -- position contains 24 + -- C___XVL : access String (1 .. V3); -- position contains 0 + -- D___XVA4 : Float; -- position contains 0 + -- E___XVL4 : anonymousQ; -- position contains 0 + -- F___XVL8 : anonymousR; -- position contains 0 + -- G : Float; -- position contains 0 + -- end record; + + -- Any bit sizes recorded for fields other than dynamic fields and + -- variants are honored as for ordinary records. + + -- Notes: + + -- 1) The B field could also have been encoded by using a position of + -- zero and an alignment of 4, but in such a case the coding by position + -- is preferred (since it takes up less space). We have used the + -- (illegal) notation access xxx as field types in the example above. + + -- 2) The E field does not actually need the alignment indication but + -- this may not be detected in this case by the conversion routines. + + -- 3) Our conventions do not cover all XVE-encoded records in which + -- some, but not all, fields have representation clauses. Such records + -- may, therefore, be displayed incorrectly by debuggers. This situation + -- is not common. + + ----------------------- + -- Base Record Types -- + ----------------------- + + -- Under certain circumstances, debuggers need two descriptions of a + -- record type, one that gives the actual details of the base type's + -- structure (as described elsewhere in these comments) and one that may + -- be used to obtain information about the particular subtype and the + -- size of the objects being typed. In such cases the compiler will + -- substitute type whose name is typically compiler-generated and + -- irrelevant except as a key for obtaining the actual type. + + -- Specifically, if this name is x, then we produce a record type named + -- x___XVS consisting of one field. The name of this field is that of + -- the actual type being encoded, which we'll call y. The type of this + -- single field can be either an arbitrary non-reference type, e.g. an + -- integer type, or a reference type; in the latter case, the referenced + -- type is also the actual type being encoded y. Both x and y may have + -- corresponding ___XVE types. + + -- The size of the objects typed as x should be obtained from the + -- structure of x (and x___XVE, if applicable) as for ordinary types + -- unless there is a variable named x___XVZ, which, if present, will + -- hold the size (in bytes) of x. In this latter case, the size of the + -- x___XVS type will not be a constant but a reference to x___XVZ. + + -- The type x will either be a subtype of y (see also Subtypes of + -- Variant Records, below) or will contain a single field of type y, + -- or no fields at all. The layout, types, and positions of these + -- fields will be accurate, if present. (Currently, however, the GDB + -- debugger makes no use of x except to determine its size). + + -- Among other uses, XVS types are used to encode unconstrained types. + -- For example, given: + -- + -- subtype Int is INTEGER range 0..10; + -- type T1 (N: Int := 0) is record + -- F1: String (1 .. N); + -- end record; + -- type AT1 is array (INTEGER range <>) of T1; + -- + -- the element type for AT1 might have a type defined as if it had + -- been written: + -- + -- type at1___PAD is record F : T1; end record; + -- for at1___PAD'Size use 16 * 8; + -- + -- and there would also be: + -- + -- type at1___PAD___XVS is record t1: reft1; end record; + -- type t1 is ... + -- type reft1 is + -- + -- Had the subtype Int been dynamic: + -- + -- subtype Int is INTEGER range 0 .. M; -- M a variable + -- + -- Then the compiler would also generate a declaration whose effect + -- would be + -- + -- at1___PAD___XVZ: constant Integer := 32 + M * 8 + padding term; + -- + -- Not all unconstrained types are so encoded; the XVS convention may be + -- unnecessary for unconstrained types of fixed size. However, this + -- encoding is always necessary when a subcomponent type (array + -- element's type or record field's type) is an unconstrained record + -- type some of whose components depend on discriminant values. + + ----------------- + -- Array Types -- + ----------------- + + -- Since there is no way for the debugger to obtain the index subtypes + -- for an array type, we produce a type that has the name of the array + -- type followed by "___XA" and is a record type whose field types are + -- the respective types for the bounds (and whose field names are the + -- names of these types). + + -- To conserve space, we do not produce this type unless one of the + -- index types is either an enumeration type, has a variable upper + -- bound, has a lower bound different from the constant 1, is a biased + -- type, or is wider than "sizetype". + + -- Given the full encoding of these types (see above description for + -- the encoding of discrete types), this means that all necessary + -- information for addressing arrays is available. In some debugging + -- formats, some or all of the bounds information may be available + -- redundantly, particularly in the fixed-point case, but this + -- information can in any case be ignored by the debugger. + + ---------------------------- + -- Note on Implicit Types -- + ---------------------------- + + -- The compiler creates implicit type names in many situations where a + -- type is present semantically, but no specific name is present. For + -- example: + + -- S : Integer range M .. N; + + -- Here the subtype of S is not integer, but rather an anonymous subtype + -- of Integer. Where possible, the compiler generates names for such + -- anonymous types that are related to the type from which the subtype + -- is obtained as follows: + + -- T name suffix + + -- where name is the name from which the subtype is obtained, using + -- lower case letters and underscores, and suffix starts with an upper + -- case letter. For example the name for the above declaration might be: + + -- TintegerS4b + + -- If the debugger is asked to give the type of an entity and the type + -- has the form T name suffix, it is probably appropriate to just use + -- "name" in the response since this is what is meaningful to the + -- programmer. + + ------------------------------------------------- + -- Subprograms for Handling Encoded Type Names -- + ------------------------------------------------- + + procedure Get_Encoded_Name (E : Entity_Id); + -- If the entity is a typename, store the external name of the entity as in + -- Get_External_Name, followed by three underscores plus the type encoding + -- in Name_Buffer with the length in Name_Len, and an ASCII.NUL character + -- stored following the name. Otherwise set Name_Buffer and Name_Len to + -- hold the entity name. Note that a call to this procedure has no effect + -- if we are not generating code, since the necessary information for + -- computing the proper encoded name is not available in this case. + + -------------- + -- Renaming -- + -------------- + + -- Debugging information is generated for exception, object, package, and + -- subprogram renaming (generic renamings are not significant, since + -- generic templates are not relevant at debugging time). + + -- Consider a renaming declaration of the form + + -- x : typ renames y; + + -- There is one case in which no special debugging information is required, + -- namely the case of an object renaming where the back end allocates a + -- reference for the renamed variable, and the entity x is this reference. + -- The debugger can handle this case without any special processing or + -- encoding (it won't know it was a renaming, but that does not matter). + + -- All other cases of renaming generate a dummy variable for an entity + -- whose name is of the form: + + -- x___XR_... for an object renaming + -- x___XRE_... for an exception renaming + -- x___XRP_... for a package renaming + + -- and where the "..." represents a suffix that describes the structure of + -- the object name given in the renaming (see details below). + + -- The name is fully qualified in the usual manner, i.e. qualified in the + -- same manner as the entity x would be. In the case of a package renaming + -- where x is a child unit, the qualification includes the name of the + -- parent unit, to disambiguate child units with the same simple name and + -- (of necessity) different parents. + + -- Note: subprogram renamings are not encoded at the present time + + -- The suffix of the variable name describing the renamed object is defined + -- to use the following encoding: + + -- For the simple entity case, where y is just an entity name, the suffix + -- is of the form: + + -- y___XE + + -- i.e. the suffix has a single field, the first part matching the + -- name y, followed by a "___" separator, ending with sequence XE. + -- The entity name portion is fully qualified in the usual manner. + -- This same naming scheme is followed for all forms of encoded + -- renamings that rename a simple entity. + + -- For the object renaming case where y is a selected component or an + -- indexed component, the variable name is suffixed by additional fields + -- that give details of the components. The name starts as above with a + -- y___XE name indicating the outer level object entity. Then a series of + -- selections and indexing operations can be specified as follows: + + -- Indexed component + + -- A series of subscript values appear in sequence, the number + -- corresponds to the number of dimensions of the array. The + -- subscripts have one of the following two forms: + + -- XSnnn + + -- Here nnn is a constant value, encoded as a decimal integer + -- (pos value for enumeration type case). Negative values have + -- a trailing 'm' as usual. + + -- XSe + + -- Here e is the (unqualified) name of a constant entity in the + -- same scope as the renaming which contains the subscript value. + + -- Slice + + -- For the slice case, we have two entries. The first is for the + -- lower bound of the slice, and has the form: + + -- XLnnn + -- XLe + + -- Specifies the lower bound, using exactly the same encoding as + -- for an XS subscript as described above. + + -- Then the upper bound appears in the usual XSnnn/XSe form + + -- Selected component + + -- For a selected component, we have a single entry + + -- XRf + + -- Here f is the field name for the selection + + -- For an explicit dereference (.all), we have a single entry + + -- XA + + -- As an example, consider the declarations: + + -- package p is + -- type q is record + -- m : string (2 .. 5); + -- end record; + -- + -- type r is array (1 .. 10, 1 .. 20) of q; + -- + -- g : r; + -- + -- z : string renames g (1,5).m(2 ..3) + -- end p; + + -- The generated variable entity would appear as + + -- p__z___XR_p__g___XEXS1XS5XRmXL2XS3 : _renaming_type; + -- p__g___XE--------------------outer entity is g + -- XS1-----------------first subscript for g + -- XS5--------------second subscript for g + -- XRm-----------select field m + -- XL2--------lower bound of slice + -- XS3-----upper bound of slice + + -- Note that the type of the variable is a special internal type named + -- _renaming_type. This type is an arbitrary type of zero size created + -- in package Standard (see cstand.adb) and is ignored by the debugger. + + function Debug_Renaming_Declaration (N : Node_Id) return Node_Id; + -- The argument N is a renaming declaration. The result is a variable + -- declaration as described in the above paragraphs. If N is not a special + -- debug declaration, then Empty is returned. + + --------------------------- + -- Packed Array Encoding -- + --------------------------- + + -- For every constrained packed array, two types are created, and both + -- appear in the debugging output: + + -- The original declared array type is a perfectly normal array type, and + -- its index bounds indicate the original bounds of the array. + + -- The corresponding packed array type, which may be a modular type, or + -- may be an array of bytes type (see Exp_Pakd for full details). This is + -- the type that is actually used in the generated code and for debugging + -- information for all objects of the packed type. + + -- The name of the corresponding packed array type is: + + -- ttt___XPnnn + + -- where + + -- ttt is the name of the original declared array + -- nnn is the component size in bits (1-31) + + -- When the debugger sees that an object is of a type that is encoded in + -- this manner, it can use the original type to determine the bounds and + -- the component type, and the component size to determine the packing + -- details. + + -- For an unconstrained packed array, the corresponding packed array type + -- is neither used in the generated code nor for debugging information, + -- only the original type is used. In order to convey the packing in the + -- debugging information, the compiler generates the associated fat- and + -- thin-pointer types (see the Pointers to Unconstrained Array section + -- below) using the name of the corresponding packed array type as the + -- base name, i.e. ttt___XPnnn___XUP and ttt___XPnnn___XUT respectively. + + -- When the debugger sees that an object is of a type that is encoded in + -- this manner, it can use the type of the fields to determine the bounds + -- and the component type, and the component size to determine the packing + -- details. + + ------------------------------------------- + -- Packed Array Representation in Memory -- + ------------------------------------------- + + -- Packed arrays are represented in tightly packed form, with no extra bits + -- between components. This is true even when the component size is not a + -- factor of the storage unit size, so that as a result it is possible for + -- components to cross storage unit boundaries. + + -- The layout in storage is identical, regardless of whether the + -- implementation type is a modular type or an array-of-bytes type. See + -- Exp_Pakd for details of how these implementation types are used, but for + -- the purpose of the debugger, only the starting address of the object in + -- memory is significant. + + -- The following example should show clearly how the packing works in + -- the little-endian and big-endian cases: + + -- type B is range 0 .. 7; + -- for B'Size use 3; + + -- type BA is array (0 .. 5) of B; + -- pragma Pack (BA); + + -- BV : constant BA := (1,2,3,4,5,6); + + -- Little endian case + + -- BV'Address + 2 BV'Address + 1 BV'Address + 0 + -- +-----------------+-----------------+-----------------+ + -- | ? ? ? ? ? ? 1 1 | 0 1 0 1 1 0 0 0 | 1 1 0 1 0 0 0 1 | + -- +-----------------+-----------------+-----------------+ + -- <---------> <-----> <---> <---> <-----> <---> <---> + -- unused bits BV(5) BV(4) BV(3) BV(2) BV(1) BV(0) + -- + -- Big endian case + -- + -- BV'Address + 0 BV'Address + 1 BV'Address + 2 + -- +-----------------+-----------------+-----------------+ + -- | 0 0 1 0 1 0 0 1 | 1 1 0 0 1 0 1 1 | 1 0 ? ? ? ? ? ? | + -- +-----------------+-----------------+-----------------+ + -- <---> <---> <-----> <---> <---> <-----> <---------> + -- BV(0) BV(1) BV(2) BV(3) BV(4) BV(5) unused bits + + -- Note that if a modular type is used to represent the array, the + -- allocation in memory is not the same as a normal modular type. The + -- difference occurs when the allocated object is larger than the size of + -- the array. For a normal modular type, we extend the value on the left + -- with zeroes. + + -- For example, in the normal modular case, if we have a 6-bit modular + -- type, declared as mod 2**6, and we allocate an 8-bit object for this + -- type, then we extend the value with two bits on the most significant + -- end, and in either the little-endian or big-endian case, the value 63 + -- is represented as 00111111 in binary in memory. + + -- For a modular type used to represent a packed array, the rule is + -- different. In this case, if we have to extend the value, then we do it + -- with undefined bits (which are not initialized and whose value is + -- irrelevant to any generated code). Furthermore these bits are on the + -- right (least significant bits) in the big-endian case, and on the left + -- (most significant bits) in the little-endian case. + + -- For example, if we have a packed boolean array of 6 bits, all set to + -- True, stored in an 8-bit object, then the value in memory in binary is + -- ??111111 in the little-endian case, and 111111?? in the big-endian case. + + -- This is done so that the representation of packed arrays does not + -- depend on whether we use a modular representation or array of bytes + -- as previously described. This ensures that we can pass such values by + -- reference in the case where a subprogram has to be able to handle values + -- stored in either form. + + -- Note that when we extract the value of such a modular packed array, we + -- expect to retrieve only the relevant bits, so in this same example, when + -- we extract the value we get 111111 in both cases, and the code generated + -- by the front end assumes this although it does not assume that any high + -- order bits are defined. + + -- There are opportunities for optimization based on the knowledge that the + -- unused bits are irrelevant for these type of packed arrays. For example + -- if we have two such 6-bit-in-8-bit values and we do an assignment: + + -- a := b; + + -- Then logically, we extract the 6 bits and store only 6 bits in the + -- result, but the back end is free to simply assign the entire 8-bits in + -- this case, since we don't actually care about the undefined bits. + -- However, in the equality case, it is important to ensure that the + -- undefined bits do not participate in an equality test. + + -- If a modular packed array value is assigned to a register then logically + -- it could always be held right justified, to avoid any need to shift, + -- e.g. when doing comparisons. But probably this is a bad choice, as it + -- would mean that an assignment such as a := above would require shifts + -- when one value is in a register and the other value is in memory. + + ------------------------------------------------------ + -- Subprograms for Handling Packed Array Type Names -- + ------------------------------------------------------ + + function Make_Packed_Array_Type_Name + (Typ : Entity_Id; + Csize : Uint) + return Name_Id; + -- This function is used in Exp_Pakd to create the name that is encoded as + -- described above. The entity Typ provides the name ttt, and the value + -- Csize is the component size that provides the nnn value. + + -------------------------------------- + -- Pointers to Unconstrained Arrays -- + -------------------------------------- + + -- There are two kinds of pointers to arrays. The debugger can tell which + -- format is in use by the form of the type of the pointer. + + -- Fat Pointers + + -- Fat pointers are represented as a struct with two fields. This + -- struct has two distinguished field names: + + -- P_ARRAY is a pointer to the array type. The name of this type is + -- the unconstrained type followed by "___XUA". This array will have + -- bounds which are the discriminants, and hence are unparsable, but + -- will give the number of subscripts and the component type. + + -- P_BOUNDS is a pointer to a struct, the name of whose type is the + -- unconstrained array name followed by "___XUB" and which has + -- fields of the form + + -- LBn (n a decimal integer) lower bound of n'th dimension + -- UBn (n a decimal integer) upper bound of n'th dimension + + -- The bounds may be any integral type. In the case of an enumeration + -- type, Enum_Rep values are used. + + -- For a given unconstrained array type, the compiler will generate one + -- fat-pointer type whose name is "arr___XUP", where "arr" is the name + -- of the array type, and use it to represent the array type itself in + -- the debugging information. + + -- For each pointer to this unconstrained array type, the compiler will + -- generate a typedef that points to the above "arr___XUP" fat-pointer + -- type. As a consequence, when it comes to fat-pointer types: + + -- 1. The type name is given by the typedef + + -- 2. If the debugger is asked to output the type, the appropriate + -- form is "access arr", except if the type name is "arr___XUP" + -- for which it is the array definition. + + -- Thin Pointers + + -- The value of a thin pointer is a pointer to the second field of a + -- structure with two fields. The name of this structure's type is + -- "arr___XUT", where "arr" is the name of the unconstrained array + -- type. Even though it actually points into middle of this structure, + -- the thin pointer's type in debugging information is + -- pointer-to-arr___XUT. + + -- The first field of arr___XUT is named BOUNDS, and has a type named + -- arr___XUB, with the structure described for such types in fat + -- pointers, as described above. + + -- The second field of arr___XUT is named ARRAY, and contains the + -- actual array. Because this array has a dynamic size, determined by + -- the BOUNDS field that precedes it, all of the information about + -- arr___XUT is encoded in a parallel type named arr___XUT___XVE, with + -- fields BOUNDS and ARRAY___XVL. As for previously described ___XVE + -- types, ARRAY___XVL has a pointer-to-array type. However, the array + -- type in this case is named arr___XUA and only its element type is + -- meaningful, just as described for fat pointers. + + -------------------------------------- + -- Tagged Types and Type Extensions -- + -------------------------------------- + + -- A type C derived from a tagged type P has a field named "_parent" of + -- type P that contains its inherited fields. The type of this field is + -- usually P (encoded as usual if it has a dynamic size), but may be a more + -- distant ancestor, if P is a null extension of that type. + + -- The type tag of a tagged type is a field named _tag, of type void*. If + -- the type is derived from another tagged type, its _tag field is found in + -- its _parent field. + + ----------------------------- + -- Variant Record Encoding -- + ----------------------------- + + -- The variant part of a variant record is encoded as a single field in the + -- enclosing record, whose name is: + + -- discrim___XVN + + -- where discrim is the unqualified name of the variant. This field name is + -- built by gigi (not by code in this unit). For Unchecked_Union record, + -- this discriminant will not appear in the record (see Unchecked Unions, + -- below). + + -- The type corresponding to this field has a name that is obtained by + -- concatenating the type name with the above string and is similar to a C + -- union, in which each member of the union corresponds to one variant. + -- However, unlike a C union, the size of the type may be variable even if + -- each of the components are fixed size, since it includes a computation + -- of which variant is present. In that case, it will be encoded as above + -- and a type with the suffix "___XVN___XVU" will be present. + + -- The name of the union member is encoded to indicate the choices, and + -- is a string given by the following grammar: + + -- member_name ::= {choice} | others_choice + -- choice ::= simple_choice | range_choice + -- simple_choice ::= S number + -- range_choice ::= R number T number + -- number ::= {decimal_digit} [m] + -- others_choice ::= O (upper case letter O) + + -- The m in a number indicates a negative value. As an example of this + -- encoding scheme, the choice 1 .. 4 | 7 | -10 would be represented by + + -- R1T4S7S10m + + -- In the case of enumeration values, the values used are the actual + -- representation values in the case where an enumeration type has an + -- enumeration representation spec (i.e. they are values that correspond + -- to the use of the Enum_Rep attribute). + + -- The type of the inner record is given by the name of the union type (as + -- above) concatenated with the above string. Since that type may itself be + -- variable-sized, it may also be encoded as above with a new type with a + -- further suffix of "___XVU". + + -- As an example, consider: + + -- type Var (Disc : Boolean := True) is record + -- M : Integer; + + -- case Disc is + -- when True => + -- R : Integer; + -- S : Integer; + + -- when False => + -- T : Integer; + -- end case; + -- end record; + + -- V1 : Var; + + -- In this case, the type var is represented as a struct with three fields. + -- The first two are "disc" and "m", representing the values of these + -- record components. The third field is a union of two types, with field + -- names S1 and O. S1 is a struct with fields "r" and "s", and O is a + -- struct with field "t". + + ---------------------- + -- Unchecked Unions -- + ---------------------- + + -- The encoding for variant records changes somewhat under the influence + -- of a "pragma Unchecked_Union" clause: + + -- 1. The discriminant will not be present in the record, although its + -- name is still used in the encodings. + -- 2. Variants containing a single component named "x" of type "T" may + -- be encoded, as in ordinary C unions, as a single field of the + -- enclosing union type named "x" of type "T", dispensing with the + -- enclosing struct. In this case, of course, the discriminant values + -- corresponding to the variant are unavailable. As for normal + -- variants, the field name "x" may be suffixed with ___XVL if it + -- has dynamic size. + + -- For example, the type Var in the preceding section, if followed by + -- "pragma Unchecked_Union (Var);" may be encoded as a struct with two + -- fields. The first is "m". The second field is a union of two types, + -- with field names S1 and "t". As before, S1 is a struct with fields + -- "r" and "s". "t" is a field of type Integer. + + ------------------------------------------------ + -- Subprograms for Handling Variant Encodings -- + ------------------------------------------------ + + procedure Get_Variant_Encoding (V : Node_Id); + -- This procedure is called by Gigi with V being the variant node. The + -- corresponding encoding string is returned in Name_Buffer with the length + -- of the string in Name_Len, and an ASCII.NUL character stored following + -- the name. + + --------------------------------- + -- Subtypes of Variant Records -- + --------------------------------- + + -- A subtype of a variant record is represented by a type in which the + -- union field from the base type is replaced by one of the possible + -- values. For example, if we have: + + -- type Var (Disc : Boolean := True) is record + -- M : Integer; + + -- case Disc is + -- when True => + -- R : Integer; + -- S : Integer; + + -- when False => + -- T : Integer; + -- end case; + + -- end record; + -- V1 : Var; + -- V2 : Var (True); + -- V3 : Var (False); + + -- Here V2, for example, is represented with a subtype whose name is + -- something like TvarS3b, which is a struct with three fields. The first + -- two fields are "disc" and "m" as for the base type, and the third field + -- is S1, which contains the fields "r" and "s". + + -- The debugger should simply ignore structs with names of the form + -- corresponding to variants, and consider the fields inside as belonging + -- to the containing record. + + ------------------------------------------- + -- Character literals in Character Types -- + ------------------------------------------- + + -- Character types are enumeration types at least one of whose enumeration + -- literals is a character literal. Enumeration literals are usually simply + -- represented using their identifier names. If the enumeration literal is + -- a character literal, the name is encoded as described in the following + -- paragraph. + + -- A name QUhh, where each 'h' is a lower-case hexadecimal digit, stands + -- for a character whose Unicode encoding is hh, and QWhhhh likewise stands + -- for a wide character whose encoding is hhhh. The representation values + -- are encoded as for ordinary enumeration literals (and have no necessary + -- relationship to the values encoded in the names). + + -- For example, given the type declaration + + -- type x is (A, 'C', B); + + -- the second enumeration literal would be named QU43 and the value + -- assigned to it would be 1. + + ----------------------------------------------- + -- Secondary Dispatch tables of tagged types -- + ----------------------------------------------- + + procedure Get_Secondary_DT_External_Name + (Typ : Entity_Id; + Ancestor_Typ : Entity_Id; + Suffix_Index : Int); + -- Set Name_Buffer and Name_Len to the external name of one secondary + -- dispatch table of Typ. If the interface has been inherited from some + -- ancestor then Ancestor_Typ is such node (in this case the secondary DT + -- is needed to handle overridden primitives); if there is no such ancestor + -- then Ancestor_Typ is equal to Typ. + -- + -- Internal rule followed for the generation of the external name: + -- + -- Case 1. If the secondary dispatch has not been inherited from some + -- ancestor of Typ then the external name is composed as + -- follows: + -- External_Name (Typ) + Suffix_Number + 'P' + -- + -- Case 2. if the secondary dispatch table has been inherited from some + -- ancestor then the external name is composed as follows: + -- External_Name (Typ) + '_' + External_Name (Ancestor_Typ) + -- + Suffix_Number + 'P' + -- + -- Note: We have to use the external names (instead of simply their names) + -- to protect the frontend against programs that give the same name to all + -- the interfaces and use the expanded name to reference them. The + -- Suffix_Number is used to differentiate all the secondary dispatch + -- tables of a given type. + -- + -- Examples: + -- + -- package Pkg1 is | package Pkg2 is | package Pkg3 is + -- type Typ is | type Typ is | type Typ is + -- interface; | interface; | interface; + -- end Pkg1; | end Pkg; | end Pkg3; + -- + -- with Pkg1, Pkg2, Pkg3; + -- package Case_1 is + -- type Typ is new Pkg1.Typ and Pkg2.Typ and Pkg3.Typ with ... + -- end Case_1; + -- + -- with Case_1; + -- package Case_2 is + -- type Typ is new Case_1.Typ with ... + -- end Case_2; + -- + -- These are the external names generated for Case_1.Typ (note that + -- Pkg1.Typ is associated with the Primary Dispatch Table, because it + -- is the parent of this type, and hence no external name is + -- generated for it). + -- case_1__typ0P (associated with Pkg2.Typ) + -- case_1__typ1P (associated with Pkg3.Typ) + -- + -- These are the external names generated for Case_2.Typ: + -- case_2__typ_case_1__typ0P + -- case_2__typ_case_1__typ1P + + ---------------------------- + -- Effect of Optimization -- + ---------------------------- + + -- If the program is compiled with optimization on (e.g. -O1 switch + -- specified), then there may be variations in the output from the above + -- specification. In particular, objects may disappear from the output. + -- This includes not only constants and variables that the program declares + -- at the source level, but also the x___L and x___U constants created to + -- describe the lower and upper bounds of subtypes with dynamic bounds. + -- This means for example, that array bounds may disappear if optimization + -- is turned on. The debugger is expected to recognize that these constants + -- are missing and deal as best as it can with the limited information + -- available. + + --------------------------------- + -- GNAT Extensions to DWARF2/3 -- + --------------------------------- + + -- If the compiler switch "-gdwarf+" is specified, GNAT Vendor extensions + -- to DWARF2/3 are generated, with the following variations from the above + -- specification. + + -- Change in the contents of the DW_AT_name attribute + + -- The operators are represented in their natural form. (for example, + -- the addition operator is written as "+" instead of "Oadd"). The + -- component separator is "." instead of "__" + + -- Introduction of DW_AT_GNAT_encoding, encoded with value 0x2301 + + -- Any debugging information entry representing a program entity, named + -- or implicit, may have a DW_AT_GNAT_encoding attribute. The value of + -- this attribute is a string representing the suffix internally added + -- by GNAT for various purposes, mainly for representing debug + -- information compatible with other formats. In particular this is + -- useful for IDEs which need to filter out information internal to + -- GNAT from their graphical interfaces. + + -- If a debugging information entry has multiple encodings, all of them + -- will be listed in DW_AT_GNAT_encoding using the list separator ':'. + + -- Introduction of DW_AT_GNAT_descriptive_type, encoded with value 0x2302 + + -- Any debugging information entry representing a type may have a + -- DW_AT_GNAT_descriptive_type attribute whose value is a reference, + -- pointing to a debugging information entry representing another type + -- associated to the type. + + -- Modification of the contents of the DW_AT_producer string + + -- When emitting full GNAT Vendor extensions to DWARF2/3, "-gdwarf+" + -- is appended to the DW_AT_producer string. + -- + -- When emitting only DW_AT_GNAT_descriptive_type, "-gdwarf+-" is + -- appended to the DW_AT_producer string. + +end Exp_Dbug; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb new file mode 100644 index 000000000..9cf300fd9 --- /dev/null +++ b/gcc/ada/exp_disp.adb @@ -0,0 +1,8090 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ D I S P -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Atag; use Exp_Atag; +with Exp_Ch6; use Exp_Ch6; +with Exp_Ch7; use Exp_Ch7; +with Exp_CG; use Exp_CG; +with Exp_Dbug; use Exp_Dbug; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Itypes; use Itypes; +with Layout; use Layout; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Namet; use Namet; +with Opt; use Opt; +with Output; use Output; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch7; use Sem_Ch7; +with Sem_Ch8; use Sem_Ch8; +with Sem_Disp; use Sem_Disp; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with SCIL_LL; use SCIL_LL; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +package body Exp_Disp is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Default_Prim_Op_Position (E : Entity_Id) return Uint; + -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table + -- of the default primitive operations. + + function Has_DT (Typ : Entity_Id) return Boolean; + pragma Inline (Has_DT); + -- Returns true if we generate a dispatch table for tagged type Typ + + function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean; + -- Returns true if Prim is not a predefined dispatching primitive but it is + -- an alias of a predefined dispatching primitive (i.e. through a renaming) + + function New_Value (From : Node_Id) return Node_Id; + -- From is the original Expression. New_Value is equivalent to a call + -- to Duplicate_Subexpr with an explicit dereference when From is an + -- access parameter. + + function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean; + -- Check if the type has a private view or if the public view appears + -- in the visible part of a package spec. + + function Prim_Op_Kind + (Prim : Entity_Id; + Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Determine the primitive operation kind of Prim + -- according to its type Typ. Return a reference to an RE_Prim_Op_Kind + -- enumeration value. + + function Tagged_Kind (T : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference + -- to an RE_Tagged_Kind enumeration value. + + ---------------------- + -- Apply_Tag_Checks -- + ---------------------- + + procedure Apply_Tag_Checks (Call_Node : Node_Id) is + Loc : constant Source_Ptr := Sloc (Call_Node); + Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node); + Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg)); + Param_List : constant List_Id := Parameter_Associations (Call_Node); + + Subp : Entity_Id; + CW_Typ : Entity_Id; + Param : Node_Id; + Typ : Entity_Id; + Eq_Prim_Op : Entity_Id := Empty; + + begin + if No_Run_Time_Mode then + Error_Msg_CRT ("tagged types", Call_Node); + return; + end if; + + -- Apply_Tag_Checks is called directly from the semantics, so we need + -- a check to see whether expansion is active before proceeding. In + -- addition, there is no need to expand the call when compiling under + -- restriction No_Dispatching_Calls; the semantic analyzer has + -- previously notified the violation of this restriction. + + if not Expander_Active + or else Restriction_Active (No_Dispatching_Calls) + then + return; + end if; + + -- Set subprogram. If this is an inherited operation that was + -- overridden, the body that is being called is its alias. + + Subp := Entity (Name (Call_Node)); + + if Present (Alias (Subp)) + and then Is_Inherited_Operation (Subp) + and then No (DTC_Entity (Subp)) + then + Subp := Alias (Subp); + end if; + + -- Definition of the class-wide type and the tagged type + + -- If the controlling argument is itself a tag rather than a tagged + -- object, then use the class-wide type associated with the subprogram's + -- controlling type. This case can occur when a call to an inherited + -- primitive has an actual that originated from a default parameter + -- given by a tag-indeterminate call and when there is no other + -- controlling argument providing the tag (AI-239 requires dispatching). + -- This capability of dispatching directly by tag is also needed by the + -- implementation of AI-260 (for the generic dispatching constructors). + + if Ctrl_Typ = RTE (RE_Tag) + or else (RTE_Available (RE_Interface_Tag) + and then Ctrl_Typ = RTE (RE_Interface_Tag)) + then + CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp)); + + -- Class_Wide_Type is applied to the expressions used to initialize + -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since + -- there are cases where the controlling type is resolved to a specific + -- type (such as for designated types of arguments such as CW'Access). + + elsif Is_Access_Type (Ctrl_Typ) then + CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ)); + + else + CW_Typ := Class_Wide_Type (Ctrl_Typ); + end if; + + Typ := Root_Type (CW_Typ); + + if Ekind (Typ) = E_Incomplete_Type then + Typ := Non_Limited_View (Typ); + end if; + + if not Is_Limited_Type (Typ) then + Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); + end if; + + -- Dispatching call to C++ primitive + + if Is_CPP_Class (Typ) then + null; + + -- Dispatching call to Ada primitive + + elsif Present (Param_List) then + + -- Generate the Tag checks when appropriate + + Param := First_Actual (Call_Node); + while Present (Param) loop + + -- No tag check with itself + + if Param = Ctrl_Arg then + null; + + -- No tag check for parameter whose type is neither tagged nor + -- access to tagged (for access parameters) + + elsif No (Find_Controlling_Arg (Param)) then + null; + + -- No tag check for function dispatching on result if the + -- Tag given by the context is this one + + elsif Find_Controlling_Arg (Param) = Ctrl_Arg then + null; + + -- "=" is the only dispatching operation allowed to get + -- operands with incompatible tags (it just returns false). + -- We use Duplicate_Subexpr_Move_Checks instead of calling + -- Relocate_Node because the value will be duplicated to + -- check the tags. + + elsif Subp = Eq_Prim_Op then + null; + + -- No check in presence of suppress flags + + elsif Tag_Checks_Suppressed (Etype (Param)) + or else (Is_Access_Type (Etype (Param)) + and then Tag_Checks_Suppressed + (Designated_Type (Etype (Param)))) + then + null; + + -- Optimization: no tag checks if the parameters are identical + + elsif Is_Entity_Name (Param) + and then Is_Entity_Name (Ctrl_Arg) + and then Entity (Param) = Entity (Ctrl_Arg) + then + null; + + -- Now we need to generate the Tag check + + else + -- Generate code for tag equality check + -- Perhaps should have Checks.Apply_Tag_Equality_Check??? + + Insert_Action (Ctrl_Arg, + Make_Implicit_If_Statement (Call_Node, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => New_Value (Ctrl_Arg), + Selector_Name => + New_Reference_To + (First_Tag_Component (Typ), Loc)), + + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Typ, New_Value (Param)), + Selector_Name => + New_Reference_To + (First_Tag_Component (Typ), Loc))), + + Then_Statements => + New_List (New_Constraint_Error (Loc)))); + end if; + + Next_Actual (Param); + end loop; + end if; + end Apply_Tag_Checks; + + ------------------------ + -- Building_Static_DT -- + ------------------------ + + function Building_Static_DT (Typ : Entity_Id) return Boolean is + Root_Typ : Entity_Id := Root_Type (Typ); + + begin + -- Handle private types + + if Present (Full_View (Root_Typ)) then + Root_Typ := Full_View (Root_Typ); + end if; + + return Static_Dispatch_Tables + and then Is_Library_Level_Tagged_Type (Typ) + + -- If the type is derived from a CPP class we cannot statically + -- build the dispatch tables because we must inherit primitives + -- from the CPP side. + + and then not Is_CPP_Class (Root_Typ); + end Building_Static_DT; + + ---------------------------------- + -- Build_Static_Dispatch_Tables -- + ---------------------------------- + + procedure Build_Static_Dispatch_Tables (N : Entity_Id) is + Target_List : List_Id; + + procedure Build_Dispatch_Tables (List : List_Id); + -- Build the static dispatch table of tagged types found in the list of + -- declarations. The generated nodes are added at the end of Target_List + + procedure Build_Package_Dispatch_Tables (N : Node_Id); + -- Build static dispatch tables associated with package declaration N + + --------------------------- + -- Build_Dispatch_Tables -- + --------------------------- + + procedure Build_Dispatch_Tables (List : List_Id) is + D : Node_Id; + + begin + D := First (List); + while Present (D) loop + + -- Handle nested packages and package bodies recursively. The + -- generated code is placed on the Target_List established for + -- the enclosing compilation unit. + + if Nkind (D) = N_Package_Declaration then + Build_Package_Dispatch_Tables (D); + + elsif Nkind (D) = N_Package_Body then + Build_Dispatch_Tables (Declarations (D)); + + elsif Nkind (D) = N_Package_Body_Stub + and then Present (Library_Unit (D)) + then + Build_Dispatch_Tables + (Declarations (Proper_Body (Unit (Library_Unit (D))))); + + -- Handle full type declarations and derivations of library + -- level tagged types + + elsif Nkind_In (D, N_Full_Type_Declaration, + N_Derived_Type_Definition) + and then Is_Library_Level_Tagged_Type (Defining_Entity (D)) + and then Ekind (Defining_Entity (D)) /= E_Record_Subtype + and then not Is_Private_Type (Defining_Entity (D)) + then + -- We do not generate dispatch tables for the internal types + -- created for a type extension with unknown discriminants + -- The needed information is shared with the source type, + -- See Expand_N_Record_Extension. + + if Is_Underlying_Record_View (Defining_Entity (D)) + or else + (not Comes_From_Source (Defining_Entity (D)) + and then + Has_Unknown_Discriminants (Etype (Defining_Entity (D))) + and then + not Comes_From_Source + (First_Subtype (Defining_Entity (D)))) + then + null; + else + Insert_List_After_And_Analyze (Last (Target_List), + Make_DT (Defining_Entity (D))); + end if; + + -- Handle private types of library level tagged types. We must + -- exchange the private and full-view to ensure the correct + -- expansion. If the full view is a synchronized type ignore + -- the type because the table will be built for the corresponding + -- record type, that has its own declaration. + + elsif (Nkind (D) = N_Private_Type_Declaration + or else Nkind (D) = N_Private_Extension_Declaration) + and then Present (Full_View (Defining_Entity (D))) + then + declare + E1 : constant Entity_Id := Defining_Entity (D); + E2 : constant Entity_Id := Full_View (E1); + + begin + if Is_Library_Level_Tagged_Type (E2) + and then Ekind (E2) /= E_Record_Subtype + and then not Is_Concurrent_Type (E2) + then + Exchange_Declarations (E1); + Insert_List_After_And_Analyze (Last (Target_List), + Make_DT (E1)); + Exchange_Declarations (E2); + end if; + end; + end if; + + Next (D); + end loop; + end Build_Dispatch_Tables; + + ----------------------------------- + -- Build_Package_Dispatch_Tables -- + ----------------------------------- + + procedure Build_Package_Dispatch_Tables (N : Node_Id) is + Spec : constant Node_Id := Specification (N); + Id : constant Entity_Id := Defining_Entity (N); + Vis_Decls : constant List_Id := Visible_Declarations (Spec); + Priv_Decls : constant List_Id := Private_Declarations (Spec); + + begin + Push_Scope (Id); + + if Present (Priv_Decls) then + Build_Dispatch_Tables (Vis_Decls); + Build_Dispatch_Tables (Priv_Decls); + + elsif Present (Vis_Decls) then + Build_Dispatch_Tables (Vis_Decls); + end if; + + Pop_Scope; + end Build_Package_Dispatch_Tables; + + -- Start of processing for Build_Static_Dispatch_Tables + + begin + if not Expander_Active + or else not Tagged_Type_Expansion + then + return; + end if; + + if Nkind (N) = N_Package_Declaration then + declare + Spec : constant Node_Id := Specification (N); + Vis_Decls : constant List_Id := Visible_Declarations (Spec); + Priv_Decls : constant List_Id := Private_Declarations (Spec); + + begin + if Present (Priv_Decls) + and then Is_Non_Empty_List (Priv_Decls) + then + Target_List := Priv_Decls; + + elsif not Present (Vis_Decls) then + Target_List := New_List; + Set_Private_Declarations (Spec, Target_List); + else + Target_List := Vis_Decls; + end if; + + Build_Package_Dispatch_Tables (N); + end; + + else pragma Assert (Nkind (N) = N_Package_Body); + Target_List := Declarations (N); + Build_Dispatch_Tables (Target_List); + end if; + end Build_Static_Dispatch_Tables; + + ------------------------------ + -- Convert_Tag_To_Interface -- + ------------------------------ + + function Convert_Tag_To_Interface + (Typ : Entity_Id; + Expr : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Expr); + Anon_Type : Entity_Id; + Result : Node_Id; + + begin + pragma Assert (Is_Class_Wide_Type (Typ) + and then Is_Interface (Typ) + and then + ((Nkind (Expr) = N_Selected_Component + and then Is_Tag (Entity (Selector_Name (Expr)))) + or else + (Nkind (Expr) = N_Function_Call + and then RTE_Available (RE_Displace) + and then Entity (Name (Expr)) = RTE (RE_Displace)))); + + Anon_Type := Create_Itype (E_Anonymous_Access_Type, Expr); + Set_Directly_Designated_Type (Anon_Type, Typ); + Set_Etype (Anon_Type, Anon_Type); + Set_Can_Never_Be_Null (Anon_Type); + + -- Decorate the size and alignment attributes of the anonymous access + -- type, as required by gigi. + + Layout_Type (Anon_Type); + + if Nkind (Expr) = N_Selected_Component + and then Is_Tag (Entity (Selector_Name (Expr))) + then + Result := + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (Anon_Type, + Make_Attribute_Reference (Loc, + Prefix => Expr, + Attribute_Name => Name_Address))); + else + Result := + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (Anon_Type, Expr)); + end if; + + return Result; + end Convert_Tag_To_Interface; + + ------------------- + -- CPP_Num_Prims -- + ------------------- + + function CPP_Num_Prims (Typ : Entity_Id) return Nat is + CPP_Typ : Entity_Id; + Tag_Comp : Entity_Id; + + begin + if not Is_Tagged_Type (Typ) + or else not Is_CPP_Class (Root_Type (Typ)) + then + return 0; + + else + CPP_Typ := Enclosing_CPP_Parent (Typ); + Tag_Comp := First_Tag_Component (CPP_Typ); + + -- If the number of primitives is already set in the tag component + -- then use it + + if Present (Tag_Comp) + and then DT_Entry_Count (Tag_Comp) /= No_Uint + then + return UI_To_Int (DT_Entry_Count (Tag_Comp)); + + -- Otherwise, count the primitives of the enclosing CPP type + + else + declare + Count : Nat := 0; + Elmt : Elmt_Id; + + begin + Elmt := First_Elmt (Primitive_Operations (CPP_Typ)); + while Present (Elmt) loop + Count := Count + 1; + Next_Elmt (Elmt); + end loop; + + return Count; + end; + end if; + end if; + end CPP_Num_Prims; + + ------------------------------ + -- Default_Prim_Op_Position -- + ------------------------------ + + function Default_Prim_Op_Position (E : Entity_Id) return Uint is + TSS_Name : TSS_Name_Type; + + begin + Get_Name_String (Chars (E)); + TSS_Name := + TSS_Name_Type + (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); + + if Chars (E) = Name_uSize then + return Uint_1; + + elsif Chars (E) = Name_uAlignment then + return Uint_2; + + elsif TSS_Name = TSS_Stream_Read then + return Uint_3; + + elsif TSS_Name = TSS_Stream_Write then + return Uint_4; + + elsif TSS_Name = TSS_Stream_Input then + return Uint_5; + + elsif TSS_Name = TSS_Stream_Output then + return Uint_6; + + elsif Chars (E) = Name_Op_Eq then + return Uint_7; + + elsif Chars (E) = Name_uAssign then + return Uint_8; + + elsif TSS_Name = TSS_Deep_Adjust then + return Uint_9; + + elsif TSS_Name = TSS_Deep_Finalize then + return Uint_10; + + elsif Ada_Version >= Ada_2005 then + if Chars (E) = Name_uDisp_Asynchronous_Select then + return Uint_11; + + elsif Chars (E) = Name_uDisp_Conditional_Select then + return Uint_12; + + elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then + return Uint_13; + + elsif Chars (E) = Name_uDisp_Get_Task_Id then + return Uint_14; + + elsif Chars (E) = Name_uDisp_Requeue then + return Uint_15; + + elsif Chars (E) = Name_uDisp_Timed_Select then + return Uint_16; + end if; + end if; + + raise Program_Error; + end Default_Prim_Op_Position; + + ----------------------------- + -- Expand_Dispatching_Call -- + ----------------------------- + + procedure Expand_Dispatching_Call (Call_Node : Node_Id) is + Loc : constant Source_Ptr := Sloc (Call_Node); + Call_Typ : constant Entity_Id := Etype (Call_Node); + + Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node); + Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg)); + Param_List : constant List_Id := Parameter_Associations (Call_Node); + + Subp : Entity_Id; + CW_Typ : Entity_Id; + New_Call : Node_Id; + New_Call_Name : Node_Id; + New_Params : List_Id := No_List; + Param : Node_Id; + Res_Typ : Entity_Id; + Subp_Ptr_Typ : Entity_Id; + Subp_Typ : Entity_Id; + Typ : Entity_Id; + Eq_Prim_Op : Entity_Id := Empty; + Controlling_Tag : Node_Id; + + function New_Value (From : Node_Id) return Node_Id; + -- From is the original Expression. New_Value is equivalent to a call + -- to Duplicate_Subexpr with an explicit dereference when From is an + -- access parameter. + + --------------- + -- New_Value -- + --------------- + + function New_Value (From : Node_Id) return Node_Id is + Res : constant Node_Id := Duplicate_Subexpr (From); + begin + if Is_Access_Type (Etype (From)) then + return + Make_Explicit_Dereference (Sloc (From), + Prefix => Res); + else + return Res; + end if; + end New_Value; + + -- Local variables + + New_Node : Node_Id; + SCIL_Node : Node_Id; + SCIL_Related_Node : Node_Id := Call_Node; + + -- Start of processing for Expand_Dispatching_Call + + begin + if No_Run_Time_Mode then + Error_Msg_CRT ("tagged types", Call_Node); + return; + end if; + + -- Expand_Dispatching_Call is called directly from the semantics, + -- so we need a check to see whether expansion is active before + -- proceeding. In addition, there is no need to expand the call + -- if we are compiling under restriction No_Dispatching_Calls; + -- the semantic analyzer has previously notified the violation + -- of this restriction. + + if not Expander_Active + or else Restriction_Active (No_Dispatching_Calls) + then + return; + end if; + + -- Set subprogram. If this is an inherited operation that was + -- overridden, the body that is being called is its alias. + + Subp := Entity (Name (Call_Node)); + + if Present (Alias (Subp)) + and then Is_Inherited_Operation (Subp) + and then No (DTC_Entity (Subp)) + then + Subp := Alias (Subp); + end if; + + -- Definition of the class-wide type and the tagged type + + -- If the controlling argument is itself a tag rather than a tagged + -- object, then use the class-wide type associated with the subprogram's + -- controlling type. This case can occur when a call to an inherited + -- primitive has an actual that originated from a default parameter + -- given by a tag-indeterminate call and when there is no other + -- controlling argument providing the tag (AI-239 requires dispatching). + -- This capability of dispatching directly by tag is also needed by the + -- implementation of AI-260 (for the generic dispatching constructors). + + if Ctrl_Typ = RTE (RE_Tag) + or else (RTE_Available (RE_Interface_Tag) + and then Ctrl_Typ = RTE (RE_Interface_Tag)) + then + CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp)); + + -- Class_Wide_Type is applied to the expressions used to initialize + -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since + -- there are cases where the controlling type is resolved to a specific + -- type (such as for designated types of arguments such as CW'Access). + + elsif Is_Access_Type (Ctrl_Typ) then + CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ)); + + else + CW_Typ := Class_Wide_Type (Ctrl_Typ); + end if; + + Typ := Root_Type (CW_Typ); + + if Ekind (Typ) = E_Incomplete_Type then + Typ := Non_Limited_View (Typ); + end if; + + if not Is_Limited_Type (Typ) then + Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); + end if; + + -- Dispatching call to C++ primitive. Create a new parameter list + -- with no tag checks. + + New_Params := New_List; + + if Is_CPP_Class (Typ) then + Param := First_Actual (Call_Node); + while Present (Param) loop + Append_To (New_Params, Relocate_Node (Param)); + Next_Actual (Param); + end loop; + + -- Dispatching call to Ada primitive + + elsif Present (Param_List) then + Apply_Tag_Checks (Call_Node); + + Param := First_Actual (Call_Node); + while Present (Param) loop + -- Cases in which we may have generated runtime checks + + if Param = Ctrl_Arg + or else Subp = Eq_Prim_Op + then + Append_To (New_Params, + Duplicate_Subexpr_Move_Checks (Param)); + + elsif Nkind (Parent (Param)) /= N_Parameter_Association + or else not Is_Accessibility_Actual (Parent (Param)) + then + Append_To (New_Params, Relocate_Node (Param)); + end if; + + Next_Actual (Param); + end loop; + end if; + + -- Generate the appropriate subprogram pointer type + + if Etype (Subp) = Typ then + Res_Typ := CW_Typ; + else + Res_Typ := Etype (Subp); + end if; + + Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node); + Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node); + Set_Etype (Subp_Typ, Res_Typ); + Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp)); + + -- Create a new list of parameters which is a copy of the old formal + -- list including the creation of a new set of matching entities. + + declare + Old_Formal : Entity_Id := First_Formal (Subp); + New_Formal : Entity_Id; + Extra : Entity_Id := Empty; + + begin + if Present (Old_Formal) then + New_Formal := New_Copy (Old_Formal); + Set_First_Entity (Subp_Typ, New_Formal); + Param := First_Actual (Call_Node); + + loop + Set_Scope (New_Formal, Subp_Typ); + + -- Change all the controlling argument types to be class-wide + -- to avoid a recursion in dispatching. + + if Is_Controlling_Formal (New_Formal) then + Set_Etype (New_Formal, Etype (Param)); + end if; + + -- If the type of the formal is an itype, there was code here + -- introduced in 1998 in revision 1.46, to create a new itype + -- by copy. This seems useless, and in fact leads to semantic + -- errors when the itype is the completion of a type derived + -- from a private type. + + Extra := New_Formal; + Next_Formal (Old_Formal); + exit when No (Old_Formal); + + Set_Next_Entity (New_Formal, New_Copy (Old_Formal)); + Next_Entity (New_Formal); + Next_Actual (Param); + end loop; + + Set_Next_Entity (New_Formal, Empty); + Set_Last_Entity (Subp_Typ, Extra); + end if; + + -- Now that the explicit formals have been duplicated, any extra + -- formals needed by the subprogram must be created. + + if Present (Extra) then + Set_Extra_Formal (Extra, Empty); + end if; + + Create_Extra_Formals (Subp_Typ); + end; + + -- Complete description of pointer type, including size information, as + -- must be done with itypes to prevent order-of-elaboration anomalies + -- in gigi. + + Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); + Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ); + Set_Convention (Subp_Ptr_Typ, Convention (Subp_Typ)); + Layout_Type (Subp_Ptr_Typ); + + -- If the controlling argument is a value of type Ada.Tag or an abstract + -- interface class-wide type then use it directly. Otherwise, the tag + -- must be extracted from the controlling object. + + if Ctrl_Typ = RTE (RE_Tag) + or else (RTE_Available (RE_Interface_Tag) + and then Ctrl_Typ = RTE (RE_Interface_Tag)) + then + Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); + + -- Extract the tag from an unchecked type conversion. Done to avoid + -- the expansion of additional code just to obtain the value of such + -- tag because the current management of interface type conversions + -- generates in some cases this unchecked type conversion with the + -- tag of the object (see Expand_Interface_Conversion). + + elsif Nkind (Ctrl_Arg) = N_Unchecked_Type_Conversion + and then + (Etype (Expression (Ctrl_Arg)) = RTE (RE_Tag) + or else + (RTE_Available (RE_Interface_Tag) + and then + Etype (Expression (Ctrl_Arg)) = RTE (RE_Interface_Tag))) + then + Controlling_Tag := Duplicate_Subexpr (Expression (Ctrl_Arg)); + + -- Ada 2005 (AI-251): Abstract interface class-wide type + + elsif Is_Interface (Ctrl_Typ) + and then Is_Class_Wide_Type (Ctrl_Typ) + then + Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); + + else + Controlling_Tag := + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg), + Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc)); + end if; + + -- Handle dispatching calls to predefined primitives + + if Is_Predefined_Dispatching_Operation (Subp) + or else Is_Predefined_Dispatching_Alias (Subp) + then + Build_Get_Predefined_Prim_Op_Address (Loc, + Tag_Node => Controlling_Tag, + Position => DT_Position (Subp), + New_Node => New_Node); + + -- Handle dispatching calls to user-defined primitives + + else + Build_Get_Prim_Op_Address (Loc, + Typ => Find_Dispatching_Type (Subp), + Tag_Node => Controlling_Tag, + Position => DT_Position (Subp), + New_Node => New_Node); + end if; + + New_Call_Name := + Unchecked_Convert_To (Subp_Ptr_Typ, New_Node); + + -- Generate the SCIL node for this dispatching call. Done now because + -- attribute SCIL_Controlling_Tag must be set after the new call name + -- is built to reference the nodes that will see the SCIL backend + -- (because Build_Get_Prim_Op_Address generates an unchecked type + -- conversion which relocates the controlling tag node). + + if Generate_SCIL then + SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node)); + Set_SCIL_Entity (SCIL_Node, Typ); + Set_SCIL_Target_Prim (SCIL_Node, Subp); + + -- Common case: the controlling tag is the tag of an object + -- (for example, obj.tag) + + if Nkind (Controlling_Tag) = N_Selected_Component then + Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag); + + -- Handle renaming of selected component + + elsif Nkind (Controlling_Tag) = N_Identifier + and then Nkind (Parent (Entity (Controlling_Tag))) = + N_Object_Renaming_Declaration + and then Nkind (Name (Parent (Entity (Controlling_Tag)))) = + N_Selected_Component + then + Set_SCIL_Controlling_Tag (SCIL_Node, + Name (Parent (Entity (Controlling_Tag)))); + + -- If the controlling tag is an identifier, the SCIL node references + -- the corresponding object or parameter declaration + + elsif Nkind (Controlling_Tag) = N_Identifier + and then Nkind_In (Parent (Entity (Controlling_Tag)), + N_Object_Declaration, + N_Parameter_Specification) + then + Set_SCIL_Controlling_Tag (SCIL_Node, + Parent (Entity (Controlling_Tag))); + + -- If the controlling tag is a dereference, the SCIL node references + -- the corresponding object or parameter declaration + + elsif Nkind (Controlling_Tag) = N_Explicit_Dereference + and then Nkind (Prefix (Controlling_Tag)) = N_Identifier + and then Nkind_In (Parent (Entity (Prefix (Controlling_Tag))), + N_Object_Declaration, + N_Parameter_Specification) + then + Set_SCIL_Controlling_Tag (SCIL_Node, + Parent (Entity (Prefix (Controlling_Tag)))); + + -- For a direct reference of the tag of the type the SCIL node + -- references the internal object declaration containing the tag + -- of the type. + + elsif Nkind (Controlling_Tag) = N_Attribute_Reference + and then Attribute_Name (Controlling_Tag) = Name_Tag + then + Set_SCIL_Controlling_Tag (SCIL_Node, + Parent + (Node + (First_Elmt + (Access_Disp_Table (Entity (Prefix (Controlling_Tag))))))); + + -- Interfaces are not supported. For now we leave the SCIL node + -- decorated with the Controlling_Tag. More work needed here??? + + elsif Is_Interface (Etype (Controlling_Tag)) then + Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag); + + else + pragma Assert (False); + null; + end if; + end if; + + if Nkind (Call_Node) = N_Function_Call then + New_Call := + Make_Function_Call (Loc, + Name => New_Call_Name, + Parameter_Associations => New_Params); + + -- If this is a dispatching "=", we must first compare the tags so + -- we generate: x.tag = y.tag and then x = y + + if Subp = Eq_Prim_Op then + Param := First_Actual (Call_Node); + New_Call := + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => New_Value (Param), + Selector_Name => + New_Reference_To (First_Tag_Component (Typ), + Loc)), + + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Typ, + New_Value (Next_Actual (Param))), + Selector_Name => + New_Reference_To + (First_Tag_Component (Typ), Loc))), + Right_Opnd => New_Call); + + SCIL_Related_Node := Right_Opnd (New_Call); + end if; + + else + New_Call := + Make_Procedure_Call_Statement (Loc, + Name => New_Call_Name, + Parameter_Associations => New_Params); + end if; + + -- Register the dispatching call in the call graph nodes table + + Register_CG_Node (Call_Node); + + Rewrite (Call_Node, New_Call); + + -- Associate the SCIL node of this dispatching call + + if Generate_SCIL then + Set_SCIL_Node (SCIL_Related_Node, SCIL_Node); + end if; + + -- Suppress all checks during the analysis of the expanded code + -- to avoid the generation of spurious warnings under ZFP run-time. + + Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks); + end Expand_Dispatching_Call; + + --------------------------------- + -- Expand_Interface_Conversion -- + --------------------------------- + + procedure Expand_Interface_Conversion + (N : Node_Id; + Is_Static : Boolean := True) + is + Loc : constant Source_Ptr := Sloc (N); + Etyp : constant Entity_Id := Etype (N); + Operand : constant Node_Id := Expression (N); + Operand_Typ : Entity_Id := Etype (Operand); + Func : Node_Id; + Iface_Typ : Entity_Id := Etype (N); + Iface_Tag : Entity_Id; + + begin + -- Ada 2005 (AI-345): Handle synchronized interface type derivations + + if Is_Concurrent_Type (Operand_Typ) then + Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ)); + end if; + + -- Handle access to class-wide interface types + + if Is_Access_Type (Iface_Typ) then + Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ)); + end if; + + -- Handle class-wide interface types. This conversion can appear + -- explicitly in the source code. Example: I'Class (Obj) + + if Is_Class_Wide_Type (Iface_Typ) then + Iface_Typ := Root_Type (Iface_Typ); + end if; + + -- If the target type is a tagged synchronized type, the dispatch table + -- info is in the corresponding record type. + + if Is_Concurrent_Type (Iface_Typ) then + Iface_Typ := Corresponding_Record_Type (Iface_Typ); + end if; + + -- Freeze the entity associated with the target interface to have + -- available the attribute Access_Disp_Table. + + Freeze_Before (N, Iface_Typ); + + pragma Assert (not Is_Static + or else (not Is_Class_Wide_Type (Iface_Typ) + and then Is_Interface (Iface_Typ))); + + if not Tagged_Type_Expansion then + + -- For VM, just do a conversion ??? + + Rewrite (N, Unchecked_Convert_To (Etype (N), N)); + Analyze (N); + return; + end if; + + if not Is_Static then + + -- Give error if configurable run time and Displace not available + + if not RTE_Available (RE_Displace) then + Error_Msg_CRT ("dynamic interface conversion", N); + return; + end if; + + -- Handle conversion of access-to-class-wide interface types. Target + -- can be an access to an object or an access to another class-wide + -- interface (see -1- and -2- in the following example): + + -- type Iface1_Ref is access all Iface1'Class; + -- type Iface2_Ref is access all Iface1'Class; + + -- Acc1 : Iface1_Ref := new ... + -- Obj : Obj_Ref := Obj_Ref (Acc); -- 1 + -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2 + + if Is_Access_Type (Operand_Typ) then + Rewrite (N, + Unchecked_Convert_To (Etype (N), + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Displace), Loc), + Parameter_Associations => New_List ( + + Unchecked_Convert_To (RTE (RE_Address), + Relocate_Node (Expression (N))), + + New_Occurrence_Of + (Node (First_Elmt (Access_Disp_Table (Iface_Typ))), + Loc))))); + + Analyze (N); + return; + end if; + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Displace), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Expression (N)), + Attribute_Name => Name_Address), + + New_Occurrence_Of + (Node (First_Elmt (Access_Disp_Table (Iface_Typ))), + Loc)))); + + Analyze (N); + + -- If the target is a class-wide interface we change the type of the + -- data returned by IW_Convert to indicate that this is a dispatching + -- call. + + declare + New_Itype : Entity_Id; + + begin + New_Itype := Create_Itype (E_Anonymous_Access_Type, N); + Set_Etype (New_Itype, New_Itype); + Set_Directly_Designated_Type (New_Itype, Etyp); + + Rewrite (N, + Make_Explicit_Dereference (Loc, + Prefix => + Unchecked_Convert_To (New_Itype, Relocate_Node (N)))); + Analyze (N); + Freeze_Itype (New_Itype, N); + + return; + end; + end if; + + Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ); + pragma Assert (Iface_Tag /= Empty); + + -- Keep separate access types to interfaces because one internal + -- function is used to handle the null value (see following comments) + + if not Is_Access_Type (Etype (N)) then + + -- Statically displace the pointer to the object to reference + -- the component containing the secondary dispatch table. + + Rewrite (N, + Convert_Tag_To_Interface (Class_Wide_Type (Iface_Typ), + Make_Selected_Component (Loc, + Prefix => Relocate_Node (Expression (N)), + Selector_Name => New_Occurrence_Of (Iface_Tag, Loc)))); + + else + -- Build internal function to handle the case in which the + -- actual is null. If the actual is null returns null because + -- no displacement is required; otherwise performs a type + -- conversion that will be expanded in the code that returns + -- the value of the displaced actual. That is: + + -- function Func (O : Address) return Iface_Typ is + -- type Op_Typ is access all Operand_Typ; + -- Aux : Op_Typ := To_Op_Typ (O); + -- begin + -- if O = Null_Address then + -- return null; + -- else + -- return Iface_Typ!(Aux.Iface_Tag'Address); + -- end if; + -- end Func; + + declare + Desig_Typ : Entity_Id; + Fent : Entity_Id; + New_Typ_Decl : Node_Id; + Stats : List_Id; + + begin + Desig_Typ := Etype (Expression (N)); + + if Is_Access_Type (Desig_Typ) then + Desig_Typ := + Available_View (Directly_Designated_Type (Desig_Typ)); + end if; + + if Is_Concurrent_Type (Desig_Typ) then + Desig_Typ := Base_Type (Corresponding_Record_Type (Desig_Typ)); + end if; + + New_Typ_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'T'), + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Null_Exclusion_Present => False, + Constant_Present => False, + Subtype_Indication => + New_Reference_To (Desig_Typ, Loc))); + + Stats := New_List ( + Make_Simple_Return_Statement (Loc, + Unchecked_Convert_To (Etype (N), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To + (Defining_Identifier (New_Typ_Decl), + Make_Identifier (Loc, Name_uO)), + Selector_Name => + New_Occurrence_Of (Iface_Tag, Loc)), + Attribute_Name => Name_Address)))); + + -- If the type is null-excluding, no need for the null branch. + -- Otherwise we need to check for it and return null. + + if not Can_Never_Be_Null (Etype (N)) then + Stats := New_List ( + Make_If_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => Make_Identifier (Loc, Name_uO), + Right_Opnd => New_Reference_To + (RTE (RE_Null_Address), Loc)), + + Then_Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Make_Null (Loc))), + Else_Statements => Stats)); + end if; + + Fent := Make_Temporary (Loc, 'F'); + Func := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Fent, + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uO), + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc))), + + Result_Definition => + New_Reference_To (Etype (N), Loc)), + + Declarations => New_List (New_Typ_Decl), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stats)); + + -- Place function body before the expression containing the + -- conversion. We suppress all checks because the body of the + -- internally generated function already takes care of the case + -- in which the actual is null; therefore there is no need to + -- double check that the pointer is not null when the program + -- executes the alternative that performs the type conversion). + + Insert_Action (N, Func, Suppress => All_Checks); + + if Is_Access_Type (Etype (Expression (N))) then + + -- Generate: Func (Address!(Expression)) + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (Fent, Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), + Relocate_Node (Expression (N)))))); + + else + -- Generate: Func (Operand_Typ!(Expression)'Address) + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (Fent, Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Unchecked_Convert_To (Operand_Typ, + Relocate_Node (Expression (N))), + Attribute_Name => Name_Address)))); + end if; + end; + end if; + + Analyze (N); + end Expand_Interface_Conversion; + + ------------------------------ + -- Expand_Interface_Actuals -- + ------------------------------ + + procedure Expand_Interface_Actuals (Call_Node : Node_Id) is + Actual : Node_Id; + Actual_Dup : Node_Id; + Actual_Typ : Entity_Id; + Anon : Entity_Id; + Conversion : Node_Id; + Formal : Entity_Id; + Formal_Typ : Entity_Id; + Subp : Entity_Id; + Formal_DDT : Entity_Id; + Actual_DDT : Entity_Id; + + begin + -- This subprogram is called directly from the semantics, so we need a + -- check to see whether expansion is active before proceeding. + + if not Expander_Active then + return; + end if; + + -- Call using access to subprogram with explicit dereference + + if Nkind (Name (Call_Node)) = N_Explicit_Dereference then + Subp := Etype (Name (Call_Node)); + + -- Call using selected component + + elsif Nkind (Name (Call_Node)) = N_Selected_Component then + Subp := Entity (Selector_Name (Name (Call_Node))); + + -- Call using direct name + + else + Subp := Entity (Name (Call_Node)); + end if; + + -- Ada 2005 (AI-251): Look for interface type formals to force "this" + -- displacement + + Formal := First_Formal (Subp); + Actual := First_Actual (Call_Node); + while Present (Formal) loop + Formal_Typ := Etype (Formal); + + if Ekind (Formal_Typ) = E_Record_Type_With_Private then + Formal_Typ := Full_View (Formal_Typ); + end if; + + if Is_Access_Type (Formal_Typ) then + Formal_DDT := Directly_Designated_Type (Formal_Typ); + end if; + + Actual_Typ := Etype (Actual); + + if Is_Access_Type (Actual_Typ) then + Actual_DDT := Directly_Designated_Type (Actual_Typ); + end if; + + if Is_Interface (Formal_Typ) + and then Is_Class_Wide_Type (Formal_Typ) + then + -- No need to displace the pointer if the type of the actual + -- coincides with the type of the formal. + + if Actual_Typ = Formal_Typ then + null; + + -- No need to displace the pointer if the interface type is + -- a parent of the type of the actual because in this case the + -- interface primitives are located in the primary dispatch table. + + elsif Is_Ancestor (Formal_Typ, Actual_Typ) then + null; + + -- Implicit conversion to the class-wide formal type to force + -- the displacement of the pointer. + + else + -- Normally, expansion of actuals for calls to build-in-place + -- functions happens as part of Expand_Actuals, but in this + -- case the call will be wrapped in a conversion and soon after + -- expanded further to handle the displacement for a class-wide + -- interface conversion, so if this is a BIP call then we need + -- to handle it now. + + if Ada_Version >= Ada_2005 + and then Is_Build_In_Place_Function_Call (Actual) + then + Make_Build_In_Place_Call_In_Anonymous_Context (Actual); + end if; + + Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual)); + Rewrite (Actual, Conversion); + Analyze_And_Resolve (Actual, Formal_Typ); + end if; + + -- Access to class-wide interface type + + elsif Is_Access_Type (Formal_Typ) + and then Is_Interface (Formal_DDT) + and then Is_Class_Wide_Type (Formal_DDT) + and then Interface_Present_In_Ancestor + (Typ => Actual_DDT, + Iface => Etype (Formal_DDT)) + then + -- Handle attributes 'Access and 'Unchecked_Access + + if Nkind (Actual) = N_Attribute_Reference + and then + (Attribute_Name (Actual) = Name_Access + or else Attribute_Name (Actual) = Name_Unchecked_Access) + then + -- This case must have been handled by the analysis and + -- expansion of 'Access. The only exception is when types + -- match and no further expansion is required. + + pragma Assert (Base_Type (Etype (Prefix (Actual))) + = Base_Type (Formal_DDT)); + null; + + -- No need to displace the pointer if the type of the actual + -- coincides with the type of the formal. + + elsif Actual_DDT = Formal_DDT then + null; + + -- No need to displace the pointer if the interface type is + -- a parent of the type of the actual because in this case the + -- interface primitives are located in the primary dispatch table. + + elsif Is_Ancestor (Formal_DDT, Actual_DDT) then + null; + + else + Actual_Dup := Relocate_Node (Actual); + + if From_With_Type (Actual_Typ) then + + -- If the type of the actual parameter comes from a limited + -- with-clause and the non-limited view is already available + -- we replace the anonymous access type by a duplicate + -- declaration whose designated type is the non-limited view + + if Ekind (Actual_DDT) = E_Incomplete_Type + and then Present (Non_Limited_View (Actual_DDT)) + then + Anon := New_Copy (Actual_Typ); + + if Is_Itype (Anon) then + Set_Scope (Anon, Current_Scope); + end if; + + Set_Directly_Designated_Type (Anon, + Non_Limited_View (Actual_DDT)); + Set_Etype (Actual_Dup, Anon); + + elsif Is_Class_Wide_Type (Actual_DDT) + and then Ekind (Etype (Actual_DDT)) = E_Incomplete_Type + and then Present (Non_Limited_View (Etype (Actual_DDT))) + then + Anon := New_Copy (Actual_Typ); + + if Is_Itype (Anon) then + Set_Scope (Anon, Current_Scope); + end if; + + Set_Directly_Designated_Type (Anon, + New_Copy (Actual_DDT)); + Set_Class_Wide_Type (Directly_Designated_Type (Anon), + New_Copy (Class_Wide_Type (Actual_DDT))); + Set_Etype (Directly_Designated_Type (Anon), + Non_Limited_View (Etype (Actual_DDT))); + Set_Etype ( + Class_Wide_Type (Directly_Designated_Type (Anon)), + Non_Limited_View (Etype (Actual_DDT))); + Set_Etype (Actual_Dup, Anon); + end if; + end if; + + Conversion := Convert_To (Formal_Typ, Actual_Dup); + Rewrite (Actual, Conversion); + Analyze_And_Resolve (Actual, Formal_Typ); + end if; + end if; + + Next_Actual (Actual); + Next_Formal (Formal); + end loop; + end Expand_Interface_Actuals; + + ---------------------------- + -- Expand_Interface_Thunk -- + ---------------------------- + + procedure Expand_Interface_Thunk + (Prim : Node_Id; + Thunk_Id : out Entity_Id; + Thunk_Code : out Node_Id) + is + Loc : constant Source_Ptr := Sloc (Prim); + Actuals : constant List_Id := New_List; + Decl : constant List_Id := New_List; + Formals : constant List_Id := New_List; + Target : constant Entity_Id := Ultimate_Alias (Prim); + + Controlling_Typ : Entity_Id; + Decl_1 : Node_Id; + Decl_2 : Node_Id; + Expr : Node_Id; + Formal : Node_Id; + Ftyp : Entity_Id; + Iface_Formal : Node_Id; + New_Arg : Node_Id; + Offset_To_Top : Node_Id; + Target_Formal : Entity_Id; + + begin + Thunk_Id := Empty; + Thunk_Code := Empty; + + -- No thunk needed if the primitive has been eliminated + + if Is_Eliminated (Ultimate_Alias (Prim)) then + return; + + -- In case of primitives that are functions without formals and a + -- controlling result there is no need to build the thunk. + + elsif not Present (First_Formal (Target)) then + pragma Assert (Ekind (Target) = E_Function + and then Has_Controlling_Result (Target)); + return; + end if; + + -- Duplicate the formals of the Target primitive. In the thunk, the type + -- of the controlling formal is the covered interface type (instead of + -- the target tagged type). Done to avoid problems with discriminated + -- tagged types because, if the controlling type has discriminants with + -- default values, then the type conversions done inside the body of + -- the thunk (after the displacement of the pointer to the base of the + -- actual object) generate code that modify its contents. + + -- Note: This special management is not done for predefined primitives + -- because??? + + if not Is_Predefined_Dispatching_Operation (Prim) then + Iface_Formal := First_Formal (Interface_Alias (Prim)); + end if; + + Formal := First_Formal (Target); + while Present (Formal) loop + Ftyp := Etype (Formal); + + -- Use the interface type as the type of the controlling formal (see + -- comment above). + + if not Is_Controlling_Formal (Formal) + or else Is_Predefined_Dispatching_Operation (Prim) + then + Ftyp := Etype (Formal); + Expr := New_Copy_Tree (Expression (Parent (Formal))); + else + Ftyp := Etype (Iface_Formal); + Expr := Empty; + end if; + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Sloc (Formal), + Chars => Chars (Formal)), + In_Present => In_Present (Parent (Formal)), + Out_Present => Out_Present (Parent (Formal)), + Parameter_Type => New_Reference_To (Ftyp, Loc), + Expression => Expr)); + + if not Is_Predefined_Dispatching_Operation (Prim) then + Next_Formal (Iface_Formal); + end if; + + Next_Formal (Formal); + end loop; + + Controlling_Typ := Find_Dispatching_Type (Target); + + Target_Formal := First_Formal (Target); + Formal := First (Formals); + while Present (Formal) loop + + -- If the parent is a constrained discriminated type, then the + -- primitive operation will have been defined on a first subtype. + -- For proper matching with controlling type, use base type. + + if Ekind (Target_Formal) = E_In_Parameter + and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type + then + Ftyp := + Base_Type (Directly_Designated_Type (Etype (Target_Formal))); + else + Ftyp := Base_Type (Etype (Target_Formal)); + end if; + + -- For concurrent types, the relevant information is found in the + -- Corresponding_Record_Type, rather than the type entity itself. + + if Is_Concurrent_Type (Ftyp) then + Ftyp := Corresponding_Record_Type (Ftyp); + end if; + + if Ekind (Target_Formal) = E_In_Parameter + and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type + and then Ftyp = Controlling_Typ + then + -- Generate: + -- type T is access all <> + -- S : Storage_Offset := Storage_Offset!(Formal) + -- - Offset_To_Top (address!(Formal)) + + Decl_2 := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'T'), + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Null_Exclusion_Present => False, + Constant_Present => False, + Subtype_Indication => + New_Reference_To (Ftyp, Loc))); + + New_Arg := + Unchecked_Convert_To (RTE (RE_Address), + New_Reference_To (Defining_Identifier (Formal), Loc)); + + if not RTE_Available (RE_Offset_To_Top) then + Offset_To_Top := + Build_Offset_To_Top (Loc, New_Arg); + else + Offset_To_Top := + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc), + Parameter_Associations => New_List (New_Arg)); + end if; + + Decl_1 := + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'S'), + Constant_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Storage_Offset), Loc), + Expression => + Make_Op_Subtract (Loc, + Left_Opnd => + Unchecked_Convert_To + (RTE (RE_Storage_Offset), + New_Reference_To (Defining_Identifier (Formal), Loc)), + Right_Opnd => + Offset_To_Top)); + + Append_To (Decl, Decl_2); + Append_To (Decl, Decl_1); + + -- Reference the new actual. Generate: + -- T!(S) + + Append_To (Actuals, + Unchecked_Convert_To + (Defining_Identifier (Decl_2), + New_Reference_To (Defining_Identifier (Decl_1), Loc))); + + elsif Ftyp = Controlling_Typ then + + -- Generate: + -- S1 : Storage_Offset := Storage_Offset!(Formal'Address) + -- - Offset_To_Top (Formal'Address) + -- S2 : Addr_Ptr := Addr_Ptr!(S1) + + New_Arg := + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Defining_Identifier (Formal), Loc), + Attribute_Name => + Name_Address); + + if not RTE_Available (RE_Offset_To_Top) then + Offset_To_Top := + Build_Offset_To_Top (Loc, New_Arg); + else + Offset_To_Top := + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc), + Parameter_Associations => New_List (New_Arg)); + end if; + + Decl_1 := + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'S'), + Constant_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Storage_Offset), Loc), + Expression => + Make_Op_Subtract (Loc, + Left_Opnd => + Unchecked_Convert_To + (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To + (Defining_Identifier (Formal), Loc), + Attribute_Name => Name_Address)), + Right_Opnd => + Offset_To_Top)); + + Decl_2 := + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'S'), + Constant_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Addr_Ptr), Loc), + Expression => + Unchecked_Convert_To + (RTE (RE_Addr_Ptr), + New_Reference_To (Defining_Identifier (Decl_1), Loc))); + + Append_To (Decl, Decl_1); + Append_To (Decl, Decl_2); + + -- Reference the new actual, generate: + -- Target_Formal (S2.all) + + Append_To (Actuals, + Unchecked_Convert_To (Ftyp, + Make_Explicit_Dereference (Loc, + New_Reference_To (Defining_Identifier (Decl_2), Loc)))); + + -- No special management required for this actual + + else + Append_To (Actuals, + New_Reference_To (Defining_Identifier (Formal), Loc)); + end if; + + Next_Formal (Target_Formal); + Next (Formal); + end loop; + + Thunk_Id := Make_Temporary (Loc, 'T'); + Set_Is_Thunk (Thunk_Id); + + -- Procedure case + + if Ekind (Target) = E_Procedure then + Thunk_Code := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Thunk_Id, + Parameter_Specifications => Formals), + Declarations => Decl, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Target, Loc), + Parameter_Associations => Actuals)))); + + -- Function case + + else pragma Assert (Ekind (Target) = E_Function); + Thunk_Code := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Thunk_Id, + Parameter_Specifications => Formals, + Result_Definition => + New_Copy (Result_Definition (Parent (Target)))), + Declarations => Decl, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Target, Loc), + Parameter_Associations => Actuals))))); + end if; + end Expand_Interface_Thunk; + + -------------------------- + -- Has_CPP_Constructors -- + -------------------------- + + function Has_CPP_Constructors (Typ : Entity_Id) return Boolean is + E : Entity_Id; + + begin + -- Look for the constructor entities + + E := Next_Entity (Typ); + while Present (E) loop + if Ekind (E) = E_Function + and then Is_Constructor (E) + then + return True; + end if; + + Next_Entity (E); + end loop; + + return False; + end Has_CPP_Constructors; + + ------------ + -- Has_DT -- + ------------ + + function Has_DT (Typ : Entity_Id) return Boolean is + begin + return not Is_Interface (Typ) + and then not Restriction_Active (No_Dispatching_Calls); + end Has_DT; + + ----------------------------------------- + -- Is_Predefined_Dispatching_Operation -- + ----------------------------------------- + + function Is_Predefined_Dispatching_Operation + (E : Entity_Id) return Boolean + is + TSS_Name : TSS_Name_Type; + + begin + if not Is_Dispatching_Operation (E) then + return False; + end if; + + Get_Name_String (Chars (E)); + + -- Most predefined primitives have internally generated names. Equality + -- must be treated differently; the predefined operation is recognized + -- as a homogeneous binary operator that returns Boolean. + + if Name_Len > TSS_Name_Type'Last then + TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1 + .. Name_Len)); + if Chars (E) = Name_uSize + or else Chars (E) = Name_uAlignment + or else TSS_Name = TSS_Stream_Read + or else TSS_Name = TSS_Stream_Write + or else TSS_Name = TSS_Stream_Input + or else TSS_Name = TSS_Stream_Output + or else + (Chars (E) = Name_Op_Eq + and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) + or else Chars (E) = Name_uAssign + or else TSS_Name = TSS_Deep_Adjust + or else TSS_Name = TSS_Deep_Finalize + or else Is_Predefined_Interface_Primitive (E) + then + return True; + end if; + end if; + + return False; + end Is_Predefined_Dispatching_Operation; + + --------------------------------------- + -- Is_Predefined_Internal_Operation -- + --------------------------------------- + + function Is_Predefined_Internal_Operation + (E : Entity_Id) return Boolean + is + TSS_Name : TSS_Name_Type; + + begin + if not Is_Dispatching_Operation (E) then + return False; + end if; + + Get_Name_String (Chars (E)); + + -- Most predefined primitives have internally generated names. Equality + -- must be treated differently; the predefined operation is recognized + -- as a homogeneous binary operator that returns Boolean. + + if Name_Len > TSS_Name_Type'Last then + TSS_Name := + TSS_Name_Type + (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); + + if Chars (E) = Name_uSize + or else Chars (E) = Name_uAlignment + or else + (Chars (E) = Name_Op_Eq + and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) + or else Chars (E) = Name_uAssign + or else TSS_Name = TSS_Deep_Adjust + or else TSS_Name = TSS_Deep_Finalize + or else Is_Predefined_Interface_Primitive (E) + then + return True; + end if; + end if; + + return False; + end Is_Predefined_Internal_Operation; + + ------------------------------------- + -- Is_Predefined_Dispatching_Alias -- + ------------------------------------- + + function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean + is + begin + return not Is_Predefined_Dispatching_Operation (Prim) + and then Present (Alias (Prim)) + and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim)); + end Is_Predefined_Dispatching_Alias; + + --------------------------------------- + -- Is_Predefined_Interface_Primitive -- + --------------------------------------- + + function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is + begin + return Ada_Version >= Ada_2005 + and then (Chars (E) = Name_uDisp_Asynchronous_Select or else + Chars (E) = Name_uDisp_Conditional_Select or else + Chars (E) = Name_uDisp_Get_Prim_Op_Kind or else + Chars (E) = Name_uDisp_Get_Task_Id or else + Chars (E) = Name_uDisp_Requeue or else + Chars (E) = Name_uDisp_Timed_Select); + end Is_Predefined_Interface_Primitive; + + ---------------------------------------- + -- Make_Disp_Asynchronous_Select_Body -- + ---------------------------------------- + + -- For interface types, generate: + + -- procedure _Disp_Asynchronous_Select + -- (T : in out ; + -- S : Integer; + -- P : System.Address; + -- B : out System.Storage_Elements.Dummy_Communication_Block; + -- F : out Boolean) + -- is + -- begin + -- null; + -- end _Disp_Asynchronous_Select; + + -- For protected types, generate: + + -- procedure _Disp_Asynchronous_Select + -- (T : in out ; + -- S : Integer; + -- P : System.Address; + -- B : out System.Storage_Elements.Dummy_Communication_Block; + -- F : out Boolean) + -- is + -- I : Integer := + -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (VP, S)); + -- Bnn : System.Tasking.Protected_Objects.Operations. + -- Communication_Block; + -- begin + -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call + -- (T._object'Access, + -- System.Tasking.Protected_Objects.Protected_Entry_Index (I), + -- P, + -- System.Tasking.Asynchronous_Call, + -- Bnn); + -- B := System.Storage_Elements.Dummy_Communication_Block (Bnn); + -- end _Disp_Asynchronous_Select; + + -- For task types, generate: + + -- procedure _Disp_Asynchronous_Select + -- (T : in out ; + -- S : Integer; + -- P : System.Address; + -- B : out System.Storage_Elements.Dummy_Communication_Block; + -- F : out Boolean) + -- is + -- I : Integer := + -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (VP, S)); + -- begin + -- System.Tasking.Rendezvous.Task_Entry_Call + -- (T._task_id, + -- System.Tasking.Task_Entry_Index (I), + -- P, + -- System.Tasking.Asynchronous_Call, + -- F); + -- end _Disp_Asynchronous_Select; + + function Make_Disp_Asynchronous_Select_Body + (Typ : Entity_Id) return Node_Id + is + Com_Block : Entity_Id; + Conc_Typ : Entity_Id := Empty; + Decls : constant List_Id := New_List; + DT_Ptr : Entity_Id; + Loc : constant Source_Ptr := Sloc (Typ); + Obj_Ref : Node_Id; + Stmts : constant List_Id := New_List; + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + -- Null body is generated for interface types + + if Is_Interface (Typ) then + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Asynchronous_Select_Spec (Typ), + Declarations => + New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + New_List (Make_Null_Statement (Loc)))); + end if; + + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); + + if Is_Concurrent_Record_Type (Typ) then + Conc_Typ := Corresponding_Concurrent_Type (Typ); + + -- Generate: + -- I : Integer := + -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (VP), S); + + -- where I will be used to capture the entry index of the primitive + -- wrapper at position S. + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uI), + Object_Definition => + New_Reference_To (Standard_Integer, Loc), + Expression => + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Get_Entry_Index), Loc), + Parameter_Associations => + New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), + Make_Identifier (Loc, Name_uS))))); + + if Ekind (Conc_Typ) = E_Protected_Type then + + -- Generate: + -- Bnn : Communication_Block; + + Com_Block := Make_Temporary (Loc, 'B'); + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Com_Block, + Object_Definition => + New_Reference_To (RTE (RE_Communication_Block), Loc))); + + -- Build T._object'Access for calls below + + Obj_Ref := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Unchecked_Access, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uT), + Selector_Name => Make_Identifier (Loc, Name_uObject))); + + case Corresponding_Runtime_Package (Conc_Typ) is + when System_Tasking_Protected_Objects_Entries => + + -- Generate: + -- Protected_Entry_Call + -- (T._object'Access, -- Object + -- Protected_Entry_Index! (I), -- E + -- P, -- Uninterpreted_Data + -- Asynchronous_Call, -- Mode + -- Bnn); -- Communication_Block + + -- where T is the protected object, I is the entry index, P + -- is the wrapped parameters and B is the name of the + -- communication block. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), + Parameter_Associations => + New_List ( + Obj_Ref, + + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To + (RTE (RE_Protected_Entry_Index), Loc), + Expression => Make_Identifier (Loc, Name_uI)), + + Make_Identifier (Loc, Name_uP), -- parameter block + New_Reference_To -- Asynchronous_Call + (RTE (RE_Asynchronous_Call), Loc), + + New_Reference_To (Com_Block, Loc)))); -- comm block + + when System_Tasking_Protected_Objects_Single_Entry => + + -- Generate: + -- procedure Protected_Single_Entry_Call + -- (Object : Protection_Entry_Access; + -- Uninterpreted_Data : System.Address; + -- Mode : Call_Modes); + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To + (RTE (RE_Protected_Single_Entry_Call), Loc), + Parameter_Associations => + New_List ( + Obj_Ref, + + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uP), + Attribute_Name => Name_Address), + + New_Reference_To + (RTE (RE_Asynchronous_Call), Loc)))); + + when others => + raise Program_Error; + end case; + + -- Generate: + -- B := Dummy_Communication_Block (Bnn); + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uB), + Expression => + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Reference_To ( + RTE (RE_Dummy_Communication_Block), Loc), + Expression => + New_Reference_To (Com_Block, Loc)))); + + else + pragma Assert (Ekind (Conc_Typ) = E_Task_Type); + + -- Generate: + -- Task_Entry_Call + -- (T._task_id, -- Acceptor + -- Task_Entry_Index! (I), -- E + -- P, -- Uninterpreted_Data + -- Asynchronous_Call, -- Mode + -- F); -- Rendezvous_Successful + + -- where T is the task object, I is the entry index, P is the + -- wrapped parameters and F is the status flag. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Task_Entry_Call), Loc), + Parameter_Associations => + New_List ( + Make_Selected_Component (Loc, -- T._task_id + Prefix => Make_Identifier (Loc, Name_uT), + Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), + + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To (RTE (RE_Task_Entry_Index), Loc), + Expression => Make_Identifier (Loc, Name_uI)), + + Make_Identifier (Loc, Name_uP), -- parameter block + New_Reference_To -- Asynchronous_Call + (RTE (RE_Asynchronous_Call), Loc), + Make_Identifier (Loc, Name_uF)))); -- status flag + end if; + + else + -- Ensure that the statements list is non-empty + + Append_To (Stmts, Make_Null_Statement (Loc)); + end if; + + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Asynchronous_Select_Spec (Typ), + Declarations => + Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts)); + end Make_Disp_Asynchronous_Select_Body; + + ---------------------------------------- + -- Make_Disp_Asynchronous_Select_Spec -- + ---------------------------------------- + + function Make_Disp_Asynchronous_Select_Spec + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Def_Id : constant Node_Id := + Make_Defining_Identifier (Loc, + Name_uDisp_Asynchronous_Select); + Params : constant List_Id := New_List; + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + -- T : in out Typ; -- Object parameter + -- S : Integer; -- Primitive operation slot + -- P : Address; -- Wrapped parameters + -- B : out Dummy_Communication_Block; -- Communication block dummy + -- F : out Boolean; -- Status flag + + Append_List_To (Params, New_List ( + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uT), + Parameter_Type => + New_Reference_To (Typ, Loc), + In_Present => True, + Out_Present => True), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uS), + Parameter_Type => + New_Reference_To (Standard_Integer, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uP), + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uB), + Parameter_Type => + New_Reference_To (RTE (RE_Dummy_Communication_Block), Loc), + Out_Present => True), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uF), + Parameter_Type => + New_Reference_To (Standard_Boolean, Loc), + Out_Present => True))); + + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Def_Id, + Parameter_Specifications => Params); + end Make_Disp_Asynchronous_Select_Spec; + + --------------------------------------- + -- Make_Disp_Conditional_Select_Body -- + --------------------------------------- + + -- For interface types, generate: + + -- procedure _Disp_Conditional_Select + -- (T : in out ; + -- S : Integer; + -- P : System.Address; + -- C : out Ada.Tags.Prim_Op_Kind; + -- F : out Boolean) + -- is + -- begin + -- null; + -- end _Disp_Conditional_Select; + + -- For protected types, generate: + + -- procedure _Disp_Conditional_Select + -- (T : in out ; + -- S : Integer; + -- P : System.Address; + -- C : out Ada.Tags.Prim_Op_Kind; + -- F : out Boolean) + -- is + -- I : Integer; + -- Bnn : System.Tasking.Protected_Objects.Operations. + -- Communication_Block; + + -- begin + -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (VP, S)); + + -- if C = Ada.Tags.POK_Procedure + -- or else C = Ada.Tags.POK_Protected_Procedure + -- or else C = Ada.Tags.POK_Task_Procedure + -- then + -- F := True; + -- return; + -- end if; + + -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (VP, S)); + -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call + -- (T.object'Access, + -- System.Tasking.Protected_Objects.Protected_Entry_Index (I), + -- P, + -- System.Tasking.Conditional_Call, + -- Bnn); + -- F := not Cancelled (Bnn); + -- end _Disp_Conditional_Select; + + -- For task types, generate: + + -- procedure _Disp_Conditional_Select + -- (T : in out ; + -- S : Integer; + -- P : System.Address; + -- C : out Ada.Tags.Prim_Op_Kind; + -- F : out Boolean) + -- is + -- I : Integer; + + -- begin + -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (VP, S)); + -- System.Tasking.Rendezvous.Task_Entry_Call + -- (T._task_id, + -- System.Tasking.Task_Entry_Index (I), + -- P, + -- System.Tasking.Conditional_Call, + -- F); + -- end _Disp_Conditional_Select; + + function Make_Disp_Conditional_Select_Body + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Blk_Nam : Entity_Id; + Conc_Typ : Entity_Id := Empty; + Decls : constant List_Id := New_List; + DT_Ptr : Entity_Id; + Obj_Ref : Node_Id; + Stmts : constant List_Id := New_List; + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + -- Null body is generated for interface types + + if Is_Interface (Typ) then + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Conditional_Select_Spec (Typ), + Declarations => + No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + New_List (Make_Null_Statement (Loc)))); + end if; + + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); + + if Is_Concurrent_Record_Type (Typ) then + Conc_Typ := Corresponding_Concurrent_Type (Typ); + + -- Generate: + -- I : Integer; + + -- where I will be used to capture the entry index of the primitive + -- wrapper at position S. + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uI), + Object_Definition => + New_Reference_To (Standard_Integer, Loc))); + + -- Generate: + -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (VP), S); + + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure; + -- then + -- F := True; + -- return; + -- end if; + + Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts); + + -- Generate: + -- Bnn : Communication_Block; + + -- where Bnn is the name of the communication block used in the + -- call to Protected_Entry_Call. + + Blk_Nam := Make_Temporary (Loc, 'B'); + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Blk_Nam, + Object_Definition => + New_Reference_To (RTE (RE_Communication_Block), Loc))); + + -- Generate: + -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (VP), S); + + -- I is the entry index and S is the dispatch table slot + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uI), + Expression => + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Get_Entry_Index), Loc), + Parameter_Associations => + New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), + Make_Identifier (Loc, Name_uS))))); + + if Ekind (Conc_Typ) = E_Protected_Type then + + Obj_Ref := -- T._object'Access + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Unchecked_Access, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uT), + Selector_Name => Make_Identifier (Loc, Name_uObject))); + + case Corresponding_Runtime_Package (Conc_Typ) is + when System_Tasking_Protected_Objects_Entries => + -- Generate: + + -- Protected_Entry_Call + -- (T._object'Access, -- Object + -- Protected_Entry_Index! (I), -- E + -- P, -- Uninterpreted_Data + -- Conditional_Call, -- Mode + -- Bnn); -- Block + + -- where T is the protected object, I is the entry index, P + -- are the wrapped parameters and Bnn is the name of the + -- communication block. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), + Parameter_Associations => + New_List ( + Obj_Ref, + + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To + (RTE (RE_Protected_Entry_Index), Loc), + Expression => Make_Identifier (Loc, Name_uI)), + + Make_Identifier (Loc, Name_uP), -- parameter block + + New_Reference_To ( -- Conditional_Call + RTE (RE_Conditional_Call), Loc), + New_Reference_To ( -- Bnn + Blk_Nam, Loc)))); + + when System_Tasking_Protected_Objects_Single_Entry => + + -- If we are compiling for a restricted run-time, the call + -- uses the simpler form. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To + (RTE (RE_Protected_Single_Entry_Call), Loc), + Parameter_Associations => + New_List ( + Obj_Ref, + + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uP), + Attribute_Name => Name_Address), + + New_Reference_To + (RTE (RE_Conditional_Call), Loc)))); + when others => + raise Program_Error; + end case; + + -- Generate: + -- F := not Cancelled (Bnn); + + -- where F is the success flag. The status of Cancelled is negated + -- in order to match the behaviour of the version for task types. + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uF), + Expression => + Make_Op_Not (Loc, + Right_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Cancelled), Loc), + Parameter_Associations => + New_List ( + New_Reference_To (Blk_Nam, Loc)))))); + else + pragma Assert (Ekind (Conc_Typ) = E_Task_Type); + + -- Generate: + -- Task_Entry_Call + -- (T._task_id, -- Acceptor + -- Task_Entry_Index! (I), -- E + -- P, -- Uninterpreted_Data + -- Conditional_Call, -- Mode + -- F); -- Rendezvous_Successful + + -- where T is the task object, I is the entry index, P are the + -- wrapped parameters and F is the status flag. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Task_Entry_Call), Loc), + Parameter_Associations => + New_List ( + + Make_Selected_Component (Loc, -- T._task_id + Prefix => Make_Identifier (Loc, Name_uT), + Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), + + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To (RTE (RE_Task_Entry_Index), Loc), + Expression => Make_Identifier (Loc, Name_uI)), + + Make_Identifier (Loc, Name_uP), -- parameter block + New_Reference_To -- Conditional_Call + (RTE (RE_Conditional_Call), Loc), + Make_Identifier (Loc, Name_uF)))); -- status flag + end if; + + else + -- Ensure that the statements list is non-empty + + Append_To (Stmts, Make_Null_Statement (Loc)); + end if; + + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Conditional_Select_Spec (Typ), + Declarations => + Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts)); + end Make_Disp_Conditional_Select_Body; + + --------------------------------------- + -- Make_Disp_Conditional_Select_Spec -- + --------------------------------------- + + function Make_Disp_Conditional_Select_Spec + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Def_Id : constant Node_Id := + Make_Defining_Identifier (Loc, + Name_uDisp_Conditional_Select); + Params : constant List_Id := New_List; + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + -- T : in out Typ; -- Object parameter + -- S : Integer; -- Primitive operation slot + -- P : Address; -- Wrapped parameters + -- C : out Prim_Op_Kind; -- Call kind + -- F : out Boolean; -- Status flag + + Append_List_To (Params, New_List ( + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uT), + Parameter_Type => + New_Reference_To (Typ, Loc), + In_Present => True, + Out_Present => True), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uS), + Parameter_Type => + New_Reference_To (Standard_Integer, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uP), + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uC), + Parameter_Type => + New_Reference_To (RTE (RE_Prim_Op_Kind), Loc), + Out_Present => True), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uF), + Parameter_Type => + New_Reference_To (Standard_Boolean, Loc), + Out_Present => True))); + + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Def_Id, + Parameter_Specifications => Params); + end Make_Disp_Conditional_Select_Spec; + + ------------------------------------- + -- Make_Disp_Get_Prim_Op_Kind_Body -- + ------------------------------------- + + function Make_Disp_Get_Prim_Op_Kind_Body + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + DT_Ptr : Entity_Id; + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + if Is_Interface (Typ) then + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Get_Prim_Op_Kind_Spec (Typ), + Declarations => + New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + New_List (Make_Null_Statement (Loc)))); + end if; + + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); + + -- Generate: + -- C := get_prim_op_kind (tag! (VP), S); + + -- where C is the out parameter capturing the call kind and S is the + -- dispatch table slot number. + + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Get_Prim_Op_Kind_Spec (Typ), + Declarations => + New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + New_List ( + Make_Assignment_Statement (Loc, + Name => + Make_Identifier (Loc, Name_uC), + Expression => + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Get_Prim_Op_Kind), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), + Make_Identifier (Loc, Name_uS))))))); + end Make_Disp_Get_Prim_Op_Kind_Body; + + ------------------------------------- + -- Make_Disp_Get_Prim_Op_Kind_Spec -- + ------------------------------------- + + function Make_Disp_Get_Prim_Op_Kind_Spec + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Def_Id : constant Node_Id := + Make_Defining_Identifier (Loc, + Name_uDisp_Get_Prim_Op_Kind); + Params : constant List_Id := New_List; + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + -- T : in out Typ; -- Object parameter + -- S : Integer; -- Primitive operation slot + -- C : out Prim_Op_Kind; -- Call kind + + Append_List_To (Params, New_List ( + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uT), + Parameter_Type => + New_Reference_To (Typ, Loc), + In_Present => True, + Out_Present => True), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uS), + Parameter_Type => + New_Reference_To (Standard_Integer, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uC), + Parameter_Type => + New_Reference_To (RTE (RE_Prim_Op_Kind), Loc), + Out_Present => True))); + + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Def_Id, + Parameter_Specifications => Params); + end Make_Disp_Get_Prim_Op_Kind_Spec; + + -------------------------------- + -- Make_Disp_Get_Task_Id_Body -- + -------------------------------- + + function Make_Disp_Get_Task_Id_Body + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Ret : Node_Id; + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + if Is_Concurrent_Record_Type (Typ) + and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type + then + -- Generate: + -- return To_Address (_T._task_id); + + Ret := + Make_Simple_Return_Statement (Loc, + Expression => + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Address), Loc), + Expression => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uT), + Selector_Name => Make_Identifier (Loc, Name_uTask_Id)))); + + -- A null body is constructed for non-task types + + else + -- Generate: + -- return Null_Address; + + Ret := + Make_Simple_Return_Statement (Loc, + Expression => + New_Reference_To (RTE (RE_Null_Address), Loc)); + end if; + + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Get_Task_Id_Spec (Typ), + Declarations => + New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + New_List (Ret))); + end Make_Disp_Get_Task_Id_Body; + + -------------------------------- + -- Make_Disp_Get_Task_Id_Spec -- + -------------------------------- + + function Make_Disp_Get_Task_Id_Spec + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + return + Make_Function_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Name_uDisp_Get_Task_Id), + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uT), + Parameter_Type => + New_Reference_To (Typ, Loc))), + Result_Definition => + New_Reference_To (RTE (RE_Address), Loc)); + end Make_Disp_Get_Task_Id_Spec; + + ---------------------------- + -- Make_Disp_Requeue_Body -- + ---------------------------- + + function Make_Disp_Requeue_Body + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Conc_Typ : Entity_Id := Empty; + Stmts : constant List_Id := New_List; + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + -- Null body is generated for interface types and non-concurrent + -- tagged types. + + if Is_Interface (Typ) + or else not Is_Concurrent_Record_Type (Typ) + then + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Requeue_Spec (Typ), + Declarations => + No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + New_List (Make_Null_Statement (Loc)))); + end if; + + Conc_Typ := Corresponding_Concurrent_Type (Typ); + + if Ekind (Conc_Typ) = E_Protected_Type then + + -- Generate statements: + -- if F then + -- System.Tasking.Protected_Objects.Operations. + -- Requeue_Protected_Entry + -- (Protection_Entries_Access (P), + -- O._object'Unchecked_Access, + -- Protected_Entry_Index (I), + -- A); + -- else + -- System.Tasking.Protected_Objects.Operations. + -- Requeue_Task_To_Protected_Entry + -- (O._object'Unchecked_Access, + -- Protected_Entry_Index (I), + -- A); + -- end if; + + if Restriction_Active (No_Entry_Queue) then + Append_To (Stmts, Make_Null_Statement (Loc)); + else + Append_To (Stmts, + Make_If_Statement (Loc, + Condition => Make_Identifier (Loc, Name_uF), + + Then_Statements => + New_List ( + + -- Call to Requeue_Protected_Entry + + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + RTE (RE_Requeue_Protected_Entry), Loc), + Parameter_Associations => + New_List ( + + Make_Unchecked_Type_Conversion (Loc, -- PEA (P) + Subtype_Mark => + New_Reference_To ( + RTE (RE_Protection_Entries_Access), Loc), + Expression => + Make_Identifier (Loc, Name_uP)), + + Make_Attribute_Reference (Loc, -- O._object'Acc + Attribute_Name => + Name_Unchecked_Access, + Prefix => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uO), + Selector_Name => + Make_Identifier (Loc, Name_uObject))), + + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To ( + RTE (RE_Protected_Entry_Index), Loc), + Expression => Make_Identifier (Loc, Name_uI)), + + Make_Identifier (Loc, Name_uA)))), -- abort status + + Else_Statements => + New_List ( + + -- Call to Requeue_Task_To_Protected_Entry + + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + RTE (RE_Requeue_Task_To_Protected_Entry), Loc), + Parameter_Associations => + New_List ( + + Make_Attribute_Reference (Loc, -- O._object'Acc + Attribute_Name => + Name_Unchecked_Access, + Prefix => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uO), + Selector_Name => + Make_Identifier (Loc, Name_uObject))), + + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To ( + RTE (RE_Protected_Entry_Index), Loc), + Expression => + Make_Identifier (Loc, Name_uI)), + + Make_Identifier (Loc, Name_uA)))))); -- abort status + end if; + else + pragma Assert (Is_Task_Type (Conc_Typ)); + + -- Generate: + -- if F then + -- System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry + -- (Protection_Entries_Access (P), + -- O._task_id, + -- Task_Entry_Index (I), + -- A); + -- else + -- System.Tasking.Rendezvous.Requeue_Task_Entry + -- (O._task_id, + -- Task_Entry_Index (I), + -- A); + -- end if; + + Append_To (Stmts, + Make_If_Statement (Loc, + Condition => Make_Identifier (Loc, Name_uF), + + Then_Statements => New_List ( + + -- Call to Requeue_Protected_To_Task_Entry + + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To + (RTE (RE_Requeue_Protected_To_Task_Entry), Loc), + + Parameter_Associations => New_List ( + + Make_Unchecked_Type_Conversion (Loc, -- PEA (P) + Subtype_Mark => + New_Reference_To + (RTE (RE_Protection_Entries_Access), Loc), + Expression => Make_Identifier (Loc, Name_uP)), + + Make_Selected_Component (Loc, -- O._task_id + Prefix => Make_Identifier (Loc, Name_uO), + Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), + + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To (RTE (RE_Task_Entry_Index), Loc), + Expression => Make_Identifier (Loc, Name_uI)), + + Make_Identifier (Loc, Name_uA)))), -- abort status + + Else_Statements => New_List ( + + -- Call to Requeue_Task_Entry + + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Requeue_Task_Entry), Loc), + + Parameter_Associations => New_List ( + + Make_Selected_Component (Loc, -- O._task_id + Prefix => Make_Identifier (Loc, Name_uO), + Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), + + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To (RTE (RE_Task_Entry_Index), Loc), + Expression => Make_Identifier (Loc, Name_uI)), + + Make_Identifier (Loc, Name_uA)))))); -- abort status + end if; + + -- Even though no declarations are needed in both cases, we allocate + -- a list for entities added by Freeze. + + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Requeue_Spec (Typ), + Declarations => + New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts)); + end Make_Disp_Requeue_Body; + + ---------------------------- + -- Make_Disp_Requeue_Spec -- + ---------------------------- + + function Make_Disp_Requeue_Spec + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + -- O : in out Typ; - Object parameter + -- F : Boolean; - Protected (True) / task (False) flag + -- P : Address; - Protection_Entries_Access value + -- I : Entry_Index - Index of entry call + -- A : Boolean - Abort flag + + -- Note that the Protection_Entries_Access value is represented as a + -- System.Address in order to avoid dragging in the tasking runtime + -- when compiling sources without tasking constructs. + + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Name_uDisp_Requeue), + + Parameter_Specifications => + New_List ( + + Make_Parameter_Specification (Loc, -- O + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uO), + Parameter_Type => + New_Reference_To (Typ, Loc), + In_Present => True, + Out_Present => True), + + Make_Parameter_Specification (Loc, -- F + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uF), + Parameter_Type => + New_Reference_To (Standard_Boolean, Loc)), + + Make_Parameter_Specification (Loc, -- P + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uP), + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc)), + + Make_Parameter_Specification (Loc, -- I + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uI), + Parameter_Type => + New_Reference_To (Standard_Integer, Loc)), + + Make_Parameter_Specification (Loc, -- A + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uA), + Parameter_Type => + New_Reference_To (Standard_Boolean, Loc)))); + end Make_Disp_Requeue_Spec; + + --------------------------------- + -- Make_Disp_Timed_Select_Body -- + --------------------------------- + + -- For interface types, generate: + + -- procedure _Disp_Timed_Select + -- (T : in out ; + -- S : Integer; + -- P : System.Address; + -- D : Duration; + -- M : Integer; + -- C : out Ada.Tags.Prim_Op_Kind; + -- F : out Boolean) + -- is + -- begin + -- null; + -- end _Disp_Timed_Select; + + -- For protected types, generate: + + -- procedure _Disp_Timed_Select + -- (T : in out ; + -- S : Integer; + -- P : System.Address; + -- D : Duration; + -- M : Integer; + -- C : out Ada.Tags.Prim_Op_Kind; + -- F : out Boolean) + -- is + -- I : Integer; + + -- begin + -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (VP), S); + + -- if C = Ada.Tags.POK_Procedure + -- or else C = Ada.Tags.POK_Protected_Procedure + -- or else C = Ada.Tags.POK_Task_Procedure + -- then + -- F := True; + -- return; + -- end if; + + -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (VP), S); + -- System.Tasking.Protected_Objects.Operations. + -- Timed_Protected_Entry_Call + -- (T._object'Access, + -- System.Tasking.Protected_Objects.Protected_Entry_Index (I), + -- P, + -- D, + -- M, + -- F); + -- end _Disp_Timed_Select; + + -- For task types, generate: + + -- procedure _Disp_Timed_Select + -- (T : in out ; + -- S : Integer; + -- P : System.Address; + -- D : Duration; + -- M : Integer; + -- C : out Ada.Tags.Prim_Op_Kind; + -- F : out Boolean) + -- is + -- I : Integer; + + -- begin + -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (VP), S); + -- System.Tasking.Rendezvous.Timed_Task_Entry_Call + -- (T._task_id, + -- System.Tasking.Task_Entry_Index (I), + -- P, + -- D, + -- M, + -- D); + -- end _Disp_Time_Select; + + function Make_Disp_Timed_Select_Body + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Conc_Typ : Entity_Id := Empty; + Decls : constant List_Id := New_List; + DT_Ptr : Entity_Id; + Obj_Ref : Node_Id; + Stmts : constant List_Id := New_List; + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + -- Null body is generated for interface types + + if Is_Interface (Typ) then + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Timed_Select_Spec (Typ), + Declarations => + New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + New_List (Make_Null_Statement (Loc)))); + end if; + + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); + + if Is_Concurrent_Record_Type (Typ) then + Conc_Typ := Corresponding_Concurrent_Type (Typ); + + -- Generate: + -- I : Integer; + + -- where I will be used to capture the entry index of the primitive + -- wrapper at position S. + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uI), + Object_Definition => + New_Reference_To (Standard_Integer, Loc))); + + -- Generate: + -- C := Get_Prim_Op_Kind (tag! (VP), S); + + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure; + -- then + -- F := True; + -- return; + -- end if; + + Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts); + + -- Generate: + -- I := Get_Entry_Index (tag! (VP), S); + + -- I is the entry index and S is the dispatch table slot + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uI), + Expression => + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Get_Entry_Index), Loc), + Parameter_Associations => + New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), + Make_Identifier (Loc, Name_uS))))); + + -- Protected case + + if Ekind (Conc_Typ) = E_Protected_Type then + + -- Build T._object'Access + + Obj_Ref := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Unchecked_Access, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uT), + Selector_Name => Make_Identifier (Loc, Name_uObject))); + + -- Normal case, No_Entry_Queue restriction not active. In this + -- case we generate: + + -- Timed_Protected_Entry_Call + -- (T._object'access, + -- Protected_Entry_Index! (I), + -- P, D, M, F); + + -- where T is the protected object, I is the entry index, P are + -- the wrapped parameters, D is the delay amount, M is the delay + -- mode and F is the status flag. + + case Corresponding_Runtime_Package (Conc_Typ) is + when System_Tasking_Protected_Objects_Entries => + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To + (RTE (RE_Timed_Protected_Entry_Call), Loc), + Parameter_Associations => + New_List ( + Obj_Ref, + + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To + (RTE (RE_Protected_Entry_Index), Loc), + Expression => + Make_Identifier (Loc, Name_uI)), + + Make_Identifier (Loc, Name_uP), -- parameter block + Make_Identifier (Loc, Name_uD), -- delay + Make_Identifier (Loc, Name_uM), -- delay mode + Make_Identifier (Loc, Name_uF)))); -- status flag + + when System_Tasking_Protected_Objects_Single_Entry => + -- Generate: + + -- Timed_Protected_Single_Entry_Call + -- (T._object'access, P, D, M, F); + + -- where T is the protected object, P is the wrapped + -- parameters, D is the delay amount, M is the delay mode, F + -- is the status flag. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To + (RTE (RE_Timed_Protected_Single_Entry_Call), Loc), + Parameter_Associations => + New_List ( + Obj_Ref, + Make_Identifier (Loc, Name_uP), -- parameter block + Make_Identifier (Loc, Name_uD), -- delay + Make_Identifier (Loc, Name_uM), -- delay mode + Make_Identifier (Loc, Name_uF)))); -- status flag + + when others => + raise Program_Error; + end case; + + -- Task case + + else + pragma Assert (Ekind (Conc_Typ) = E_Task_Type); + + -- Generate: + -- Timed_Task_Entry_Call ( + -- T._task_id, + -- Task_Entry_Index! (I), + -- P, + -- D, + -- M, + -- F); + + -- where T is the task object, I is the entry index, P are the + -- wrapped parameters, D is the delay amount, M is the delay + -- mode and F is the status flag. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc), + Parameter_Associations => + New_List ( + + Make_Selected_Component (Loc, -- T._task_id + Prefix => Make_Identifier (Loc, Name_uT), + Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), + + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To (RTE (RE_Task_Entry_Index), Loc), + Expression => Make_Identifier (Loc, Name_uI)), + + Make_Identifier (Loc, Name_uP), -- parameter block + Make_Identifier (Loc, Name_uD), -- delay + Make_Identifier (Loc, Name_uM), -- delay mode + Make_Identifier (Loc, Name_uF)))); -- status flag + end if; + + else + -- Ensure that the statements list is non-empty + + Append_To (Stmts, Make_Null_Statement (Loc)); + end if; + + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Timed_Select_Spec (Typ), + Declarations => + Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts)); + end Make_Disp_Timed_Select_Body; + + --------------------------------- + -- Make_Disp_Timed_Select_Spec -- + --------------------------------- + + function Make_Disp_Timed_Select_Spec + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Def_Id : constant Node_Id := + Make_Defining_Identifier (Loc, + Name_uDisp_Timed_Select); + Params : constant List_Id := New_List; + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + -- T : in out Typ; -- Object parameter + -- S : Integer; -- Primitive operation slot + -- P : Address; -- Wrapped parameters + -- D : Duration; -- Delay + -- M : Integer; -- Delay Mode + -- C : out Prim_Op_Kind; -- Call kind + -- F : out Boolean; -- Status flag + + Append_List_To (Params, New_List ( + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uT), + Parameter_Type => + New_Reference_To (Typ, Loc), + In_Present => True, + Out_Present => True), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uS), + Parameter_Type => + New_Reference_To (Standard_Integer, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uP), + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uD), + Parameter_Type => + New_Reference_To (Standard_Duration, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uM), + Parameter_Type => + New_Reference_To (Standard_Integer, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uC), + Parameter_Type => + New_Reference_To (RTE (RE_Prim_Op_Kind), Loc), + Out_Present => True))); + + Append_To (Params, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uF), + Parameter_Type => + New_Reference_To (Standard_Boolean, Loc), + Out_Present => True)); + + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Def_Id, + Parameter_Specifications => Params); + end Make_Disp_Timed_Select_Spec; + + ------------- + -- Make_DT -- + ------------- + + -- The frontend supports two models for expanding dispatch tables + -- associated with library-level defined tagged types: statically + -- and non-statically allocated dispatch tables. In the former case + -- the object containing the dispatch table is constant and it is + -- initialized by means of a positional aggregate. In the latter case, + -- the object containing the dispatch table is a variable which is + -- initialized by means of assignments. + + -- In case of locally defined tagged types, the object containing the + -- object containing the dispatch table is always a variable (instead + -- of a constant). This is currently required to give support to late + -- overriding of primitives. For example: + + -- procedure Example is + -- package Pkg is + -- type T1 is tagged null record; + -- procedure Prim (O : T1); + -- end Pkg; + + -- type T2 is new Pkg.T1 with null record; + -- procedure Prim (X : T2) is -- late overriding + -- begin + -- ... + -- ... + -- end; + + function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is + Loc : constant Source_Ptr := Sloc (Typ); + + Max_Predef_Prims : constant Int := + UI_To_Int + (Intval + (Expression + (Parent (RTE (RE_Max_Predef_Prims))))); + + DT_Decl : constant Elist_Id := New_Elmt_List; + DT_Aggr : constant Elist_Id := New_Elmt_List; + -- Entities marked with attribute Is_Dispatch_Table_Entity + + procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id); + -- Verify that all non-tagged types in the profile of a subprogram + -- are frozen at the point the subprogram is frozen. This enforces + -- the rule on RM 13.14 (14) as modified by AI05-019. At the point a + -- subprogram is frozen, enough must be known about it to build the + -- activation record for it, which requires at least that the size of + -- all parameters be known. Controlling arguments are by-reference, + -- and therefore the rule only applies to non-tagged types. + -- Typical violation of the rule involves an object declaration that + -- freezes a tagged type, when one of its primitive operations has a + -- type in its profile whose full view has not been analyzed yet. + + procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0); + -- Export the dispatch table DT of tagged type Typ. Required to generate + -- forward references and statically allocate the table. For primary + -- dispatch tables Index is 0; for secondary dispatch tables the value + -- of index must match the Suffix_Index value assigned to the table by + -- Make_Tags when generating its unique external name, and it is used to + -- retrieve from the Dispatch_Table_Wrappers list associated with Typ + -- the external name generated by Import_DT. + + procedure Make_Secondary_DT + (Typ : Entity_Id; + Iface : Entity_Id; + Suffix_Index : Int; + Num_Iface_Prims : Nat; + Iface_DT_Ptr : Entity_Id; + Predef_Prims_Ptr : Entity_Id; + Build_Thunks : Boolean; + Result : List_Id); + -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch + -- Table of Typ associated with Iface. Each abstract interface of Typ + -- has two secondary dispatch tables: one containing pointers to thunks + -- and another containing pointers to the primitives covering the + -- interface primitives. The former secondary table is generated when + -- Build_Thunks is True, and provides common support for dispatching + -- calls through interface types; the latter secondary table is + -- generated when Build_Thunks is False, and provides support for + -- Generic Dispatching Constructors that dispatch calls through + -- interface types. When constructing this latter table the value + -- of Suffix_Index is -1 to indicate that there is no need to export + -- such table when building statically allocated dispatch tables; a + -- positive value of Suffix_Index must match the Suffix_Index value + -- assigned to this secondary dispatch table by Make_Tags when its + -- unique external name was generated. + + ------------------------------ + -- Check_Premature_Freezing -- + ------------------------------ + + procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id) is + begin + if Present (N) + and then Is_Private_Type (Typ) + and then No (Full_View (Typ)) + and then not Is_Generic_Type (Typ) + and then not Is_Tagged_Type (Typ) + and then not Is_Frozen (Typ) + then + Error_Msg_Sloc := Sloc (Subp); + Error_Msg_NE + ("declaration must appear after completion of type &", N, Typ); + Error_Msg_NE + ("\which is an untagged type in the profile of" + & " primitive operation & declared#", + N, Subp); + end if; + end Check_Premature_Freezing; + + --------------- + -- Export_DT -- + --------------- + + procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0) + is + Count : Nat; + Elmt : Elmt_Id; + + begin + Set_Is_Statically_Allocated (DT); + Set_Is_True_Constant (DT); + Set_Is_Exported (DT); + + Count := 0; + Elmt := First_Elmt (Dispatch_Table_Wrappers (Typ)); + while Count /= Index loop + Next_Elmt (Elmt); + Count := Count + 1; + end loop; + + pragma Assert (Related_Type (Node (Elmt)) = Typ); + + Get_External_Name + (Entity => Node (Elmt), + Has_Suffix => True); + + Set_Interface_Name (DT, + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer)); + + -- Ensure proper Sprint output of this implicit importation + + Set_Is_Internal (DT); + Set_Is_Public (DT); + end Export_DT; + + ----------------------- + -- Make_Secondary_DT -- + ----------------------- + + procedure Make_Secondary_DT + (Typ : Entity_Id; + Iface : Entity_Id; + Suffix_Index : Int; + Num_Iface_Prims : Nat; + Iface_DT_Ptr : Entity_Id; + Predef_Prims_Ptr : Entity_Id; + Build_Thunks : Boolean; + Result : List_Id) + is + Loc : constant Source_Ptr := Sloc (Typ); + Exporting_Table : constant Boolean := + Building_Static_DT (Typ) + and then Suffix_Index > 0; + Iface_DT : constant Entity_Id := Make_Temporary (Loc, 'T'); + Predef_Prims : constant Entity_Id := Make_Temporary (Loc, 'R'); + DT_Constr_List : List_Id; + DT_Aggr_List : List_Id; + Empty_DT : Boolean := False; + Nb_Predef_Prims : Nat := 0; + Nb_Prim : Nat; + New_Node : Node_Id; + OSD : Entity_Id; + OSD_Aggr_List : List_Id; + Pos : Nat; + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + Prim_Ops_Aggr_List : List_Id; + + begin + -- Handle cases in which we do not generate statically allocated + -- dispatch tables. + + if not Building_Static_DT (Typ) then + Set_Ekind (Predef_Prims, E_Variable); + Set_Ekind (Iface_DT, E_Variable); + + -- Statically allocated dispatch tables and related entities are + -- constants. + + else + Set_Ekind (Predef_Prims, E_Constant); + Set_Is_Statically_Allocated (Predef_Prims); + Set_Is_True_Constant (Predef_Prims); + + Set_Ekind (Iface_DT, E_Constant); + Set_Is_Statically_Allocated (Iface_DT); + Set_Is_True_Constant (Iface_DT); + end if; + + -- Calculate the number of slots of the dispatch table. If the number + -- of primitives of Typ is 0 we reserve a dummy single entry for its + -- DT because at run time the pointer to this dummy entry will be + -- used as the tag. + + if Num_Iface_Prims = 0 then + Empty_DT := True; + Nb_Prim := 1; + else + Nb_Prim := Num_Iface_Prims; + end if; + + -- Generate: + + -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) := + -- (predef-prim-op-thunk-1'address, + -- predef-prim-op-thunk-2'address, + -- ... + -- predef-prim-op-thunk-n'address); + -- for Predef_Prims'Alignment use Address'Alignment + + -- Stage 1: Calculate the number of predefined primitives + + if not Building_Static_DT (Typ) then + Nb_Predef_Prims := Max_Predef_Prims; + else + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if Is_Predefined_Dispatching_Operation (Prim) + and then not Is_Abstract_Subprogram (Prim) + then + Pos := UI_To_Int (DT_Position (Prim)); + + if Pos > Nb_Predef_Prims then + Nb_Predef_Prims := Pos; + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end if; + + -- Stage 2: Create the thunks associated with the predefined + -- primitives and save their entity to fill the aggregate. + + declare + Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id; + Decl : Node_Id; + Thunk_Id : Entity_Id; + Thunk_Code : Node_Id; + + begin + Prim_Ops_Aggr_List := New_List; + Prim_Table := (others => Empty); + + if Building_Static_DT (Typ) then + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if Is_Predefined_Dispatching_Operation (Prim) + and then not Is_Abstract_Subprogram (Prim) + and then not Is_Eliminated (Prim) + and then not Present (Prim_Table + (UI_To_Int (DT_Position (Prim)))) + then + if not Build_Thunks then + Prim_Table (UI_To_Int (DT_Position (Prim))) := + Alias (Prim); + + else + Expand_Interface_Thunk + (Ultimate_Alias (Prim), Thunk_Id, Thunk_Code); + + if Present (Thunk_Id) then + Append_To (Result, Thunk_Code); + Prim_Table (UI_To_Int (DT_Position (Prim))) + := Thunk_Id; + end if; + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end if; + + for J in Prim_Table'Range loop + if Present (Prim_Table (J)) then + New_Node := + Unchecked_Convert_To (RTE (RE_Prim_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim_Table (J), Loc), + Attribute_Name => Name_Unrestricted_Access)); + else + New_Node := Make_Null (Loc); + end if; + + Append_To (Prim_Ops_Aggr_List, New_Node); + end loop; + + New_Node := + Make_Aggregate (Loc, + Expressions => Prim_Ops_Aggr_List); + + -- Remember aggregates initializing dispatch tables + + Append_Elmt (New_Node, DT_Aggr); + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'S'), + Subtype_Indication => + New_Reference_To (RTE (RE_Address_Array), Loc)); + + Append_To (Result, Decl); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Predef_Prims, + Constant_Present => Building_Static_DT (Typ), + Aliased_Present => True, + Object_Definition => New_Reference_To + (Defining_Identifier (Decl), Loc), + Expression => New_Node)); + + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (Predef_Prims, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + end; + + -- Generate + + -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) := + -- (OSD_Table => (1 => , + -- ... + -- N => )); + + -- Iface_DT : Dispatch_Table (Nb_Prims) := + -- ([ Signature => ], + -- Tag_Kind => , + -- Predef_Prims => Predef_Prims'Address, + -- Offset_To_Top => 0, + -- OSD => OSD'Address, + -- Prims_Ptr => (prim-op-1'address, + -- prim-op-2'address, + -- ... + -- prim-op-n'address)); + -- for Iface_DT'Alignment use Address'Alignment; + + -- Stage 3: Initialize the discriminant and the record components + + DT_Constr_List := New_List; + DT_Aggr_List := New_List; + + -- Nb_Prim. If the tagged type has no primitives we add a dummy + -- slot whose address will be the tag of this type. + + if Nb_Prim = 0 then + New_Node := Make_Integer_Literal (Loc, 1); + else + New_Node := Make_Integer_Literal (Loc, Nb_Prim); + end if; + + Append_To (DT_Constr_List, New_Node); + Append_To (DT_Aggr_List, New_Copy (New_Node)); + + -- Signature + + if RTE_Record_Component_Available (RE_Signature) then + Append_To (DT_Aggr_List, + New_Reference_To (RTE (RE_Secondary_DT), Loc)); + end if; + + -- Tag_Kind + + if RTE_Record_Component_Available (RE_Tag_Kind) then + Append_To (DT_Aggr_List, Tagged_Kind (Typ)); + end if; + + -- Predef_Prims + + Append_To (DT_Aggr_List, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Predef_Prims, Loc), + Attribute_Name => Name_Address)); + + -- Note: The correct value of Offset_To_Top will be set by the init + -- subprogram + + Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); + + -- Generate the Object Specific Data table required to dispatch calls + -- through synchronized interfaces. + + if Empty_DT + or else Is_Abstract_Type (Typ) + or else Is_Controlled (Typ) + or else Restriction_Active (No_Dispatching_Calls) + or else not Is_Limited_Type (Typ) + or else not Has_Interfaces (Typ) + or else not Build_Thunks + or else not RTE_Record_Component_Available (RE_OSD_Table) + then + -- No OSD table required + + Append_To (DT_Aggr_List, + New_Reference_To (RTE (RE_Null_Address), Loc)); + + else + OSD_Aggr_List := New_List; + + declare + Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; + Prim : Entity_Id; + Prim_Alias : Entity_Id; + Prim_Elmt : Elmt_Id; + E : Entity_Id; + Count : Nat := 0; + Pos : Nat; + + begin + Prim_Table := (others => Empty); + Prim_Alias := Empty; + + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if Present (Interface_Alias (Prim)) + and then Find_Dispatching_Type + (Interface_Alias (Prim)) = Iface + then + Prim_Alias := Interface_Alias (Prim); + E := Ultimate_Alias (Prim); + Pos := UI_To_Int (DT_Position (Prim_Alias)); + + if Present (Prim_Table (Pos)) then + pragma Assert (Prim_Table (Pos) = E); + null; + + else + Prim_Table (Pos) := E; + + Append_To (OSD_Aggr_List, + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, + DT_Position (Prim_Alias))), + Expression => + Make_Integer_Literal (Loc, + DT_Position (Alias (Prim))))); + + Count := Count + 1; + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + pragma Assert (Count = Nb_Prim); + end; + + OSD := Make_Temporary (Loc, 'I'); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => OSD, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Object_Specific_Data), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Integer_Literal (Loc, Nb_Prim)))), + + Expression => + Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of + (RTE_Record_Component (RE_OSD_Num_Prims), Loc)), + Expression => + Make_Integer_Literal (Loc, Nb_Prim)), + + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of + (RTE_Record_Component (RE_OSD_Table), Loc)), + Expression => Make_Aggregate (Loc, + Component_Associations => OSD_Aggr_List)))))); + + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (OSD, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + + -- In secondary dispatch tables the Typeinfo component contains + -- the address of the Object Specific Data (see a-tags.ads) + + Append_To (DT_Aggr_List, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (OSD, Loc), + Attribute_Name => Name_Address)); + end if; + + -- Initialize the table of primitive operations + + Prim_Ops_Aggr_List := New_List; + + if Empty_DT then + Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); + + elsif Is_Abstract_Type (Typ) + or else not Building_Static_DT (Typ) + then + for J in 1 .. Nb_Prim loop + Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); + end loop; + + else + declare + CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ); + E : Entity_Id; + Prim_Pos : Nat; + Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; + Thunk_Code : Node_Id; + Thunk_Id : Entity_Id; + + begin + Prim_Table := (others => Empty); + + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + E := Ultimate_Alias (Prim); + Prim_Pos := UI_To_Int (DT_Position (E)); + + -- Do not reference predefined primitives because they are + -- located in a separate dispatch table; skip abstract and + -- eliminated primitives; skip primitives located in the C++ + -- part of the dispatch table because their slot is set by + -- the IC routine. + + if not Is_Predefined_Dispatching_Operation (Prim) + and then Present (Interface_Alias (Prim)) + and then not Is_Abstract_Subprogram (Alias (Prim)) + and then not Is_Eliminated (Alias (Prim)) + and then (not Is_CPP_Class (Root_Type (Typ)) + or else Prim_Pos > CPP_Nb_Prims) + and then Find_Dispatching_Type + (Interface_Alias (Prim)) = Iface + + -- Generate the code of the thunk only if the abstract + -- interface type is not an immediate ancestor of + -- Tagged_Type. Otherwise the DT associated with the + -- interface is the primary DT. + + and then not Is_Ancestor (Iface, Typ) + then + if not Build_Thunks then + Prim_Pos := + UI_To_Int (DT_Position (Interface_Alias (Prim))); + Prim_Table (Prim_Pos) := Alias (Prim); + + else + Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); + + if Present (Thunk_Id) then + Prim_Pos := + UI_To_Int (DT_Position (Interface_Alias (Prim))); + + Prim_Table (Prim_Pos) := Thunk_Id; + Append_To (Result, Thunk_Code); + end if; + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + for J in Prim_Table'Range loop + if Present (Prim_Table (J)) then + New_Node := + Unchecked_Convert_To (RTE (RE_Prim_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim_Table (J), Loc), + Attribute_Name => Name_Unrestricted_Access)); + + else + New_Node := Make_Null (Loc); + end if; + + Append_To (Prim_Ops_Aggr_List, New_Node); + end loop; + end; + end if; + + New_Node := + Make_Aggregate (Loc, + Expressions => Prim_Ops_Aggr_List); + + Append_To (DT_Aggr_List, New_Node); + + -- Remember aggregates initializing dispatch tables + + Append_Elmt (New_Node, DT_Aggr); + + -- Note: Secondary dispatch tables cannot be declared constant + -- because the component Offset_To_Top is currently initialized + -- by the IP routine. + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Iface_DT, + Aliased_Present => True, + Constant_Present => False, + + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To + (RTE (RE_Dispatch_Table_Wrapper), Loc), + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => DT_Constr_List)), + + Expression => + Make_Aggregate (Loc, + Expressions => DT_Aggr_List))); + + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (Iface_DT, Loc), + Chars => Name_Alignment, + + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + + if Exporting_Table then + Export_DT (Typ, Iface_DT, Suffix_Index); + + -- Generate code to create the pointer to the dispatch table + + -- Iface_DT_Ptr : Tag := Tag!(DT.Prims_Ptr'Address); + + -- Note: This declaration is not added here if the table is exported + -- because in such case Make_Tags has already added this declaration. + + else + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Iface_DT_Ptr, + Constant_Present => True, + + Object_Definition => + New_Reference_To (RTE (RE_Interface_Tag), Loc), + + Expression => + Unchecked_Convert_To (RTE (RE_Interface_Tag), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Iface_DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_Prims_Ptr), Loc)), + Attribute_Name => Name_Address)))); + end if; + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Predef_Prims_Ptr, + Constant_Present => True, + + Object_Definition => + New_Reference_To (RTE (RE_Address), Loc), + + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Iface_DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_Predef_Prims), Loc)), + Attribute_Name => Name_Address))); + + -- Remember entities containing dispatch tables + + Append_Elmt (Predef_Prims, DT_Decl); + Append_Elmt (Iface_DT, DT_Decl); + end Make_Secondary_DT; + + -- Local variables + + Elab_Code : constant List_Id := New_List; + Result : constant List_Id := New_List; + Tname : constant Name_Id := Chars (Typ); + AI : Elmt_Id; + AI_Tag_Elmt : Elmt_Id; + AI_Tag_Comp : Elmt_Id; + DT_Aggr_List : List_Id; + DT_Constr_List : List_Id; + DT_Ptr : Entity_Id; + ITable : Node_Id; + I_Depth : Nat := 0; + Iface_Table_Node : Node_Id; + Name_ITable : Name_Id; + Nb_Predef_Prims : Nat := 0; + Nb_Prim : Nat := 0; + New_Node : Node_Id; + Num_Ifaces : Nat := 0; + Parent_Typ : Entity_Id; + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + Prim_Ops_Aggr_List : List_Id; + Suffix_Index : Int; + Typ_Comps : Elist_Id; + Typ_Ifaces : Elist_Id; + TSD_Aggr_List : List_Id; + TSD_Tags_List : List_Id; + + -- The following name entries are used by Make_DT to generate a number + -- of entities related to a tagged type. These entities may be generated + -- in a scope other than that of the tagged type declaration, and if + -- the entities for two tagged types with the same name happen to be + -- generated in the same scope, we have to take care to use different + -- names. This is achieved by means of a unique serial number appended + -- to each generated entity name. + + Name_DT : constant Name_Id := + New_External_Name (Tname, 'T', Suffix_Index => -1); + Name_Exname : constant Name_Id := + New_External_Name (Tname, 'E', Suffix_Index => -1); + Name_HT_Link : constant Name_Id := + New_External_Name (Tname, 'H', Suffix_Index => -1); + Name_Predef_Prims : constant Name_Id := + New_External_Name (Tname, 'R', Suffix_Index => -1); + Name_SSD : constant Name_Id := + New_External_Name (Tname, 'S', Suffix_Index => -1); + Name_TSD : constant Name_Id := + New_External_Name (Tname, 'B', Suffix_Index => -1); + + -- Entities built with above names + + DT : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_DT); + Exname : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_Exname); + HT_Link : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_HT_Link); + Predef_Prims : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_Predef_Prims); + SSD : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_SSD); + TSD : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_TSD); + + -- Start of processing for Make_DT + + begin + pragma Assert (Is_Frozen (Typ)); + + -- Handle cases in which there is no need to build the dispatch table + + if Has_Dispatch_Table (Typ) + or else No (Access_Disp_Table (Typ)) + or else Is_CPP_Class (Typ) + or else Convention (Typ) = Convention_CIL + or else Convention (Typ) = Convention_Java + then + return Result; + + elsif No_Run_Time_Mode then + Error_Msg_CRT ("tagged types", Typ); + return Result; + + elsif not RTE_Available (RE_Tag) then + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Node (First_Elmt + (Access_Disp_Table (Typ))), + Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), + Constant_Present => True, + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (RTE (RE_Null_Address), Loc)))); + + Analyze_List (Result, Suppress => All_Checks); + Error_Msg_CRT ("tagged types", Typ); + return Result; + end if; + + -- Ensure that the value of Max_Predef_Prims defined in a-tags is + -- correct. Valid values are 10 under configurable runtime or 16 + -- with full runtime. + + if RTE_Available (RE_Interface_Data) then + if Max_Predef_Prims /= 16 then + Error_Msg_N ("run-time library configuration error", Typ); + return Result; + end if; + else + if Max_Predef_Prims /= 10 then + Error_Msg_N ("run-time library configuration error", Typ); + Error_Msg_CRT ("tagged types", Typ); + return Result; + end if; + end if; + + -- Initialize Parent_Typ handling private types + + Parent_Typ := Etype (Typ); + + if Present (Full_View (Parent_Typ)) then + Parent_Typ := Full_View (Parent_Typ); + end if; + + -- Ensure that all the primitives are frozen. This is only required when + -- building static dispatch tables --- the primitives must be frozen to + -- be referenced (otherwise we have problems with the backend). It is + -- not a requirement with nonstatic dispatch tables because in this case + -- we generate now an empty dispatch table; the extra code required to + -- register the primitives in the slots will be generated later --- when + -- each primitive is frozen (see Freeze_Subprogram). + + if Building_Static_DT (Typ) then + declare + Save : constant Boolean := Freezing_Library_Level_Tagged_Type; + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + Frnodes : List_Id; + + begin + Freezing_Library_Level_Tagged_Type := True; + + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + Frnodes := Freeze_Entity (Prim, Typ); + + declare + F : Entity_Id; + + begin + F := First_Formal (Prim); + while Present (F) loop + Check_Premature_Freezing (Prim, Etype (F)); + Next_Formal (F); + end loop; + + Check_Premature_Freezing (Prim, Etype (Prim)); + end; + + if Present (Frnodes) then + Append_List_To (Result, Frnodes); + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + Freezing_Library_Level_Tagged_Type := Save; + end; + end if; + + -- Ada 2005 (AI-251): Build the secondary dispatch tables + + if Has_Interfaces (Typ) then + Collect_Interface_Components (Typ, Typ_Comps); + + -- Each secondary dispatch table is assigned an unique positive + -- suffix index; such value also corresponds with the location of + -- its entity in the Dispatch_Table_Wrappers list (see Make_Tags). + + -- Note: This value must be kept sync with the Suffix_Index values + -- generated by Make_Tags + + Suffix_Index := 1; + AI_Tag_Elmt := + Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); + + AI_Tag_Comp := First_Elmt (Typ_Comps); + while Present (AI_Tag_Comp) loop + pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'P')); + + -- Build the secondary table containing pointers to thunks + + Make_Secondary_DT + (Typ => Typ, + Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))), + Suffix_Index => Suffix_Index, + Num_Iface_Prims => UI_To_Int + (DT_Entry_Count (Node (AI_Tag_Comp))), + Iface_DT_Ptr => Node (AI_Tag_Elmt), + Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)), + Build_Thunks => True, + Result => Result); + + -- Skip secondary dispatch table referencing thunks to predefined + -- primitives. + + Next_Elmt (AI_Tag_Elmt); + pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Y')); + + -- Secondary dispatch table referencing user-defined primitives + -- covered by this interface. + + Next_Elmt (AI_Tag_Elmt); + pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'D')); + + -- Build the secondary table containing pointers to primitives + -- (used to give support to Generic Dispatching Constructors). + + Make_Secondary_DT + (Typ => Typ, + Iface => Base_Type + (Related_Type (Node (AI_Tag_Comp))), + Suffix_Index => -1, + Num_Iface_Prims => UI_To_Int + (DT_Entry_Count (Node (AI_Tag_Comp))), + Iface_DT_Ptr => Node (AI_Tag_Elmt), + Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)), + Build_Thunks => False, + Result => Result); + + -- Skip secondary dispatch table referencing predefined primitives + + Next_Elmt (AI_Tag_Elmt); + pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Z')); + + Suffix_Index := Suffix_Index + 1; + Next_Elmt (AI_Tag_Elmt); + Next_Elmt (AI_Tag_Comp); + end loop; + end if; + + -- Get the _tag entity and number of primitives of its dispatch table + + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); + Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); + + Set_Is_Statically_Allocated (DT, Is_Library_Level_Tagged_Type (Typ)); + Set_Is_Statically_Allocated (SSD, Is_Library_Level_Tagged_Type (Typ)); + Set_Is_Statically_Allocated (TSD, Is_Library_Level_Tagged_Type (Typ)); + Set_Is_Statically_Allocated (Predef_Prims, + Is_Library_Level_Tagged_Type (Typ)); + + -- In case of locally defined tagged type we declare the object + -- containing the dispatch table by means of a variable. Its + -- initialization is done later by means of an assignment. This is + -- required to generate its External_Tag. + + if not Building_Static_DT (Typ) then + + -- Generate: + -- DT : No_Dispatch_Table_Wrapper; + -- for DT'Alignment use Address'Alignment; + -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address); + + if not Has_DT (Typ) then + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT, + Aliased_Present => True, + Constant_Present => False, + Object_Definition => + New_Reference_To + (RTE (RE_No_Dispatch_Table_Wrapper), Loc))); + + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (DT, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT_Ptr, + Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), + Constant_Present => True, + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)), + Attribute_Name => Name_Address)))); + + Set_Is_Statically_Allocated (DT_Ptr, + Is_Library_Level_Tagged_Type (Typ)); + + -- Generate the SCIL node for the previous object declaration + -- because it has a tag initialization. + + if Generate_SCIL then + New_Node := + Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); + Set_SCIL_Entity (New_Node, Typ); + Set_SCIL_Node (Last (Result), New_Node); + end if; + + -- Generate: + -- DT : Dispatch_Table_Wrapper (Nb_Prim); + -- for DT'Alignment use Address'Alignment; + -- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address); + + else + -- If the tagged type has no primitives we add a dummy slot + -- whose address will be the tag of this type. + + if Nb_Prim = 0 then + DT_Constr_List := + New_List (Make_Integer_Literal (Loc, 1)); + else + DT_Constr_List := + New_List (Make_Integer_Literal (Loc, Nb_Prim)); + end if; + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT, + Aliased_Present => True, + Constant_Present => False, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc), + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => DT_Constr_List)))); + + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (DT, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT_Ptr, + Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), + Constant_Present => True, + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_Prims_Ptr), Loc)), + Attribute_Name => Name_Address)))); + + Set_Is_Statically_Allocated (DT_Ptr, + Is_Library_Level_Tagged_Type (Typ)); + + -- Generate the SCIL node for the previous object declaration + -- because it has a tag initialization. + + if Generate_SCIL then + New_Node := + Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); + Set_SCIL_Entity (New_Node, Typ); + Set_SCIL_Node (Last (Result), New_Node); + end if; + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => + Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))), + Constant_Present => True, + Object_Definition => New_Reference_To + (RTE (RE_Address), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_Predef_Prims), Loc)), + Attribute_Name => Name_Address))); + end if; + end if; + + -- Generate: Exname : constant String := full_qualified_name (typ); + -- The type itself may be an anonymous parent type, so use the first + -- subtype to have a user-recognizable name. + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Exname, + Constant_Present => True, + Object_Definition => New_Reference_To (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, + Fully_Qualified_Name_String (First_Subtype (Typ))))); + + Set_Is_Statically_Allocated (Exname); + Set_Is_True_Constant (Exname); + + -- Declare the object used by Ada.Tags.Register_Tag + + if RTE_Available (RE_Register_Tag) then + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => HT_Link, + Object_Definition => New_Reference_To (RTE (RE_Tag), Loc))); + end if; + + -- Generate code to create the storage for the type specific data object + -- with enough space to store the tags of the ancestors plus the tags + -- of all the implemented interfaces (as described in a-tags.adb). + + -- TSD : Type_Specific_Data (I_Depth) := + -- (Idepth => I_Depth, + -- Access_Level => Type_Access_Level (Typ), + -- Expanded_Name => Cstring_Ptr!(Exname'Address)) + -- External_Tag => Cstring_Ptr!(Exname'Address)) + -- HT_Link => HT_Link'Address, + -- Transportable => <>, + -- Type_Is_Abstract => <>, + -- RC_Offset => <>, + -- [ Size_Func => Size_Prim'Access ] + -- [ Interfaces_Table => <> ] + -- [ SSD => SSD_Table'Address ] + -- Tags_Table => (0 => null, + -- 1 => Parent'Tag + -- ...); + -- for TSD'Alignment use Address'Alignment + + TSD_Aggr_List := New_List; + + -- Idepth: Count ancestors to compute the inheritance depth. For private + -- extensions, always go to the full view in order to compute the real + -- inheritance depth. + + declare + Current_Typ : Entity_Id; + Parent_Typ : Entity_Id; + + begin + I_Depth := 0; + Current_Typ := Typ; + loop + Parent_Typ := Etype (Current_Typ); + + if Is_Private_Type (Parent_Typ) then + Parent_Typ := Full_View (Base_Type (Parent_Typ)); + end if; + + exit when Parent_Typ = Current_Typ; + + I_Depth := I_Depth + 1; + Current_Typ := Parent_Typ; + end loop; + end; + + Append_To (TSD_Aggr_List, + Make_Integer_Literal (Loc, I_Depth)); + + -- Access_Level + + Append_To (TSD_Aggr_List, + Make_Integer_Literal (Loc, Type_Access_Level (Typ))); + + -- Expanded_Name + + Append_To (TSD_Aggr_List, + Unchecked_Convert_To (RTE (RE_Cstring_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Exname, Loc), + Attribute_Name => Name_Address))); + + -- External_Tag of a local tagged type + + -- A : constant String := + -- "Internal tag at 16#tag-addr#: "; + + -- The reason we generate this strange name is that we do not want to + -- enter local tagged types in the global hash table used to compute + -- the Internal_Tag attribute for two reasons: + + -- 1. It is hard to avoid a tasking race condition for entering the + -- entry into the hash table. + + -- 2. It would cause a storage leak, unless we rig up considerable + -- mechanism to remove the entry from the hash table on exit. + + -- So what we do is to generate the above external tag name, where the + -- hex address is the address of the local dispatch table (i.e. exactly + -- the value we want if Internal_Tag is computed from this string). + + -- Of course this value will only be valid if the tagged type is still + -- in scope, but it clearly must be erroneous to compute the internal + -- tag of a tagged type that is out of scope! + + -- We don't do this processing if an explicit external tag has been + -- specified. That's an odd case for which we have already issued a + -- warning, where we will not be able to compute the internal tag. + + if not Is_Library_Level_Entity (Typ) + and then not Has_External_Tag_Rep_Clause (Typ) + then + declare + Exname : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Tname, 'A')); + + Full_Name : constant String_Id := + Fully_Qualified_Name_String (First_Subtype (Typ)); + Str1_Id : String_Id; + Str2_Id : String_Id; + + begin + -- Generate: + -- Str1 = "Internal tag at 16#"; + + Start_String; + Store_String_Chars ("Internal tag at 16#"); + Str1_Id := End_String; + + -- Generate: + -- Str2 = "#: "; + + Start_String; + Store_String_Chars ("#: "); + Store_String_Chars (Full_Name); + Str2_Id := End_String; + + -- Generate: + -- Exname : constant String := + -- Str1 & Address_Image (Tag) & Str2; + + if RTE_Available (RE_Address_Image) then + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Exname, + Constant_Present => True, + Object_Definition => New_Reference_To + (Standard_String, Loc), + Expression => + Make_Op_Concat (Loc, + Left_Opnd => + Make_String_Literal (Loc, Str1_Id), + Right_Opnd => + Make_Op_Concat (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To + (RTE (RE_Address_Image), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), + New_Reference_To (DT_Ptr, Loc)))), + Right_Opnd => + Make_String_Literal (Loc, Str2_Id))))); + + else + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Exname, + Constant_Present => True, + Object_Definition => New_Reference_To + (Standard_String, Loc), + Expression => + Make_Op_Concat (Loc, + Left_Opnd => + Make_String_Literal (Loc, Str1_Id), + Right_Opnd => + Make_String_Literal (Loc, Str2_Id)))); + end if; + + New_Node := + Unchecked_Convert_To (RTE (RE_Cstring_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Exname, Loc), + Attribute_Name => Name_Address)); + end; + + -- External tag of a library-level tagged type: Check for a definition + -- of External_Tag. The clause is considered only if it applies to this + -- specific tagged type, as opposed to one of its ancestors. + -- If the type is an unconstrained type extension, we are building the + -- dispatch table of its anonymous base type, so the external tag, if + -- any was specified, must be retrieved from the first subtype. Go to + -- the full view in case the clause is in the private part. + + else + declare + Def : constant Node_Id := Get_Attribute_Definition_Clause + (Underlying_Type (First_Subtype (Typ)), + Attribute_External_Tag); + + Old_Val : String_Id; + New_Val : String_Id; + E : Entity_Id; + + begin + if not Present (Def) + or else Entity (Name (Def)) /= First_Subtype (Typ) + then + New_Node := + Unchecked_Convert_To (RTE (RE_Cstring_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Exname, Loc), + Attribute_Name => Name_Address)); + else + Old_Val := Strval (Expr_Value_S (Expression (Def))); + + -- For the rep clause "for 'external_tag use y" generate: + + -- A : constant string := y; + -- + -- A'Address is used to set the External_Tag component + -- of the TSD + + -- Create a new nul terminated string if it is not already + + if String_Length (Old_Val) > 0 + and then + Get_String_Char (Old_Val, String_Length (Old_Val)) = 0 + then + New_Val := Old_Val; + else + Start_String (Old_Val); + Store_String_Char (Get_Char_Code (ASCII.NUL)); + New_Val := End_String; + end if; + + E := Make_Defining_Identifier (Loc, + New_External_Name (Chars (Typ), 'A')); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => E, + Constant_Present => True, + Object_Definition => + New_Reference_To (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, New_Val))); + + New_Node := + Unchecked_Convert_To (RTE (RE_Cstring_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (E, Loc), + Attribute_Name => Name_Address)); + end if; + end; + end if; + + Append_To (TSD_Aggr_List, New_Node); + + -- HT_Link + + if RTE_Available (RE_Register_Tag) then + Append_To (TSD_Aggr_List, + Unchecked_Convert_To (RTE (RE_Tag_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (HT_Link, Loc), + Attribute_Name => Name_Address))); + else + Append_To (TSD_Aggr_List, + Unchecked_Convert_To (RTE (RE_Tag_Ptr), + New_Reference_To (RTE (RE_Null_Address), Loc))); + end if; + + -- Transportable: Set for types that can be used in remote calls + -- with respect to E.4(18) legality rules. + + declare + Transportable : Entity_Id; + + begin + Transportable := + Boolean_Literals + (Is_Pure (Typ) + or else Is_Shared_Passive (Typ) + or else + ((Is_Remote_Types (Typ) + or else Is_Remote_Call_Interface (Typ)) + and then Original_View_In_Visible_Part (Typ)) + or else not Comes_From_Source (Typ)); + + Append_To (TSD_Aggr_List, + New_Occurrence_Of (Transportable, Loc)); + end; + + -- Type_Is_Abstract (Ada 2012: AI05-0173). This functionality is + -- not available in the HIE runtime. + + if RTE_Record_Component_Available (RE_Type_Is_Abstract) then + declare + Type_Is_Abstract : Entity_Id; + + begin + Type_Is_Abstract := + Boolean_Literals (Is_Abstract_Type (Typ)); + + Append_To (TSD_Aggr_List, + New_Occurrence_Of (Type_Is_Abstract, Loc)); + end; + end if; + + -- RC_Offset: These are the valid values and their meaning: + + -- >0: For simple types with controlled components is + -- type._record_controller'position + + -- 0: For types with no controlled components + + -- -1: For complex types with controlled components where the position + -- of the record controller is not statically computable but there + -- are controlled components at this level. The _Controller field + -- is available right after the _parent. + + -- -2: There are no controlled components at this level. We need to + -- get the position from the parent. + + declare + RC_Offset_Node : Node_Id; + + begin + if not Has_Controlled_Component (Typ) then + RC_Offset_Node := Make_Integer_Literal (Loc, 0); + + elsif Etype (Typ) /= Typ + and then Has_Discriminants (Parent_Typ) + then + if Has_New_Controlled_Component (Typ) then + RC_Offset_Node := Make_Integer_Literal (Loc, -1); + else + RC_Offset_Node := Make_Integer_Literal (Loc, -2); + end if; + else + RC_Offset_Node := + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Typ, Loc), + Selector_Name => + New_Reference_To (Controller_Component (Typ), Loc)), + Attribute_Name => Name_Position); + + -- This is not proper Ada code to use the attribute 'Position + -- on something else than an object but this is supported by + -- the back end (see comment on the Bit_Component attribute in + -- sem_attr). So we avoid semantic checking here. + + -- Is this documented in sinfo.ads??? it should be! + + Set_Analyzed (RC_Offset_Node); + Set_Etype (Prefix (RC_Offset_Node), RTE (RE_Record_Controller)); + Set_Etype (Prefix (Prefix (RC_Offset_Node)), Typ); + Set_Etype (Selector_Name (Prefix (RC_Offset_Node)), + RTE (RE_Record_Controller)); + Set_Etype (RC_Offset_Node, RTE (RE_Storage_Offset)); + end if; + + Append_To (TSD_Aggr_List, RC_Offset_Node); + end; + + -- Size_Func + + if RTE_Record_Component_Available (RE_Size_Func) then + + -- Initialize this field to Null_Address if we are not building + -- static dispatch tables static or if the size function is not + -- available. In the former case we cannot initialize this field + -- until the function is frozen and registered in the dispatch + -- table (see Register_Primitive). + + if not Building_Static_DT (Typ) or else not Has_DT (Typ) then + Append_To (TSD_Aggr_List, + Unchecked_Convert_To (RTE (RE_Size_Ptr), + New_Reference_To (RTE (RE_Null_Address), Loc))); + + else + declare + Prim_Elmt : Elmt_Id; + Prim : Entity_Id; + Size_Comp : Node_Id; + + begin + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if Chars (Prim) = Name_uSize then + Prim := Ultimate_Alias (Prim); + + if Is_Abstract_Subprogram (Prim) then + Size_Comp := + Unchecked_Convert_To (RTE (RE_Size_Ptr), + New_Reference_To (RTE (RE_Null_Address), Loc)); + else + Size_Comp := + Unchecked_Convert_To (RTE (RE_Size_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim, Loc), + Attribute_Name => Name_Unrestricted_Access)); + end if; + + exit; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + pragma Assert (Present (Size_Comp)); + Append_To (TSD_Aggr_List, Size_Comp); + end; + end if; + end if; + + -- Interfaces_Table (required for AI-405) + + if RTE_Record_Component_Available (RE_Interfaces_Table) then + + -- Count the number of interface types implemented by Typ + + Collect_Interfaces (Typ, Typ_Ifaces); + + AI := First_Elmt (Typ_Ifaces); + while Present (AI) loop + Num_Ifaces := Num_Ifaces + 1; + Next_Elmt (AI); + end loop; + + if Num_Ifaces = 0 then + Iface_Table_Node := Make_Null (Loc); + + -- Generate the Interface_Table object + + else + declare + TSD_Ifaces_List : constant List_Id := New_List; + Elmt : Elmt_Id; + Sec_DT_Tag : Node_Id; + + begin + AI := First_Elmt (Typ_Ifaces); + while Present (AI) loop + if Is_Ancestor (Node (AI), Typ) then + Sec_DT_Tag := + New_Reference_To (DT_Ptr, Loc); + else + Elmt := + Next_Elmt + (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); + pragma Assert (Has_Thunks (Node (Elmt))); + + while Is_Tag (Node (Elmt)) + and then not + Is_Ancestor (Node (AI), Related_Type (Node (Elmt))) + loop + pragma Assert (Has_Thunks (Node (Elmt))); + Next_Elmt (Elmt); + pragma Assert (Has_Thunks (Node (Elmt))); + Next_Elmt (Elmt); + pragma Assert (not Has_Thunks (Node (Elmt))); + Next_Elmt (Elmt); + pragma Assert (not Has_Thunks (Node (Elmt))); + Next_Elmt (Elmt); + end loop; + + pragma Assert (Ekind (Node (Elmt)) = E_Constant + and then not + Has_Thunks (Node (Next_Elmt (Next_Elmt (Elmt))))); + Sec_DT_Tag := + New_Reference_To (Node (Next_Elmt (Next_Elmt (Elmt))), + Loc); + end if; + + Append_To (TSD_Ifaces_List, + Make_Aggregate (Loc, + Expressions => New_List ( + + -- Iface_Tag + + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Node (AI)))), + Loc)), + + -- Static_Offset_To_Top + + New_Reference_To (Standard_True, Loc), + + -- Offset_To_Top_Value + + Make_Integer_Literal (Loc, 0), + + -- Offset_To_Top_Func + + Make_Null (Loc), + + -- Secondary_DT + + Unchecked_Convert_To (RTE (RE_Tag), Sec_DT_Tag) + + ))); + + Next_Elmt (AI); + end loop; + + Name_ITable := New_External_Name (Tname, 'I'); + ITable := Make_Defining_Identifier (Loc, Name_ITable); + Set_Is_Statically_Allocated (ITable, + Is_Library_Level_Tagged_Type (Typ)); + + -- The table of interfaces is not constant; its slots are + -- filled at run time by the IP routine using attribute + -- 'Position to know the location of the tag components + -- (and this attribute cannot be safely used before the + -- object is initialized). + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => ITable, + Aliased_Present => True, + Constant_Present => False, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Interface_Data), Loc), + Constraint => Make_Index_Or_Discriminant_Constraint + (Loc, + Constraints => New_List ( + Make_Integer_Literal (Loc, Num_Ifaces)))), + + Expression => Make_Aggregate (Loc, + Expressions => New_List ( + Make_Integer_Literal (Loc, Num_Ifaces), + Make_Aggregate (Loc, + Expressions => TSD_Ifaces_List))))); + + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (ITable, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + + Iface_Table_Node := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (ITable, Loc), + Attribute_Name => Name_Unchecked_Access); + end; + end if; + + Append_To (TSD_Aggr_List, Iface_Table_Node); + end if; + + -- Generate the Select Specific Data table for synchronized types that + -- implement synchronized interfaces. The size of the table is + -- constrained by the number of non-predefined primitive operations. + + if RTE_Record_Component_Available (RE_SSD) then + if Ada_Version >= Ada_2005 + and then Has_DT (Typ) + and then Is_Concurrent_Record_Type (Typ) + and then Has_Interfaces (Typ) + and then Nb_Prim > 0 + and then not Is_Abstract_Type (Typ) + and then not Is_Controlled (Typ) + and then not Restriction_Active (No_Dispatching_Calls) + and then not Restriction_Active (No_Select_Statements) + then + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => SSD, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To ( + RTE (RE_Select_Specific_Data), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Integer_Literal (Loc, Nb_Prim)))))); + + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (SSD, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + + -- This table is initialized by Make_Select_Specific_Data_Table, + -- which calls Set_Entry_Index and Set_Prim_Op_Kind. + + Append_To (TSD_Aggr_List, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (SSD, Loc), + Attribute_Name => Name_Unchecked_Access)); + else + Append_To (TSD_Aggr_List, Make_Null (Loc)); + end if; + end if; + + -- Initialize the table of ancestor tags. In case of interface types + -- this table is not needed. + + TSD_Tags_List := New_List; + + -- If we are not statically allocating the dispatch table then we must + -- fill position 0 with null because we still have not generated the + -- tag of Typ. + + if not Building_Static_DT (Typ) + or else Is_Interface (Typ) + then + Append_To (TSD_Tags_List, + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (RTE (RE_Null_Address), Loc))); + + -- Otherwise we can safely reference the tag + + else + Append_To (TSD_Tags_List, + New_Reference_To (DT_Ptr, Loc)); + end if; + + -- Fill the rest of the table with the tags of the ancestors + + declare + Current_Typ : Entity_Id; + Parent_Typ : Entity_Id; + Pos : Nat; + + begin + Pos := 1; + Current_Typ := Typ; + + loop + Parent_Typ := Etype (Current_Typ); + + if Is_Private_Type (Parent_Typ) then + Parent_Typ := Full_View (Base_Type (Parent_Typ)); + end if; + + exit when Parent_Typ = Current_Typ; + + if Is_CPP_Class (Parent_Typ) then + + -- The tags defined in the C++ side will be inherited when + -- the object is constructed (Exp_Ch3.Build_Init_Procedure) + + Append_To (TSD_Tags_List, + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (RTE (RE_Null_Address), Loc))); + else + Append_To (TSD_Tags_List, + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Parent_Typ))), + Loc)); + end if; + + Pos := Pos + 1; + Current_Typ := Parent_Typ; + end loop; + + pragma Assert (Pos = I_Depth + 1); + end; + + Append_To (TSD_Aggr_List, + Make_Aggregate (Loc, + Expressions => TSD_Tags_List)); + + -- Build the TSD object + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => TSD, + Aliased_Present => True, + Constant_Present => Building_Static_DT (Typ), + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To ( + RTE (RE_Type_Specific_Data), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Integer_Literal (Loc, I_Depth)))), + + Expression => Make_Aggregate (Loc, + Expressions => TSD_Aggr_List))); + + Set_Is_True_Constant (TSD, Building_Static_DT (Typ)); + + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (TSD, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + + -- Initialize or declare the dispatch table object + + if not Has_DT (Typ) then + DT_Constr_List := New_List; + DT_Aggr_List := New_List; + + -- Typeinfo + + New_Node := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (TSD, Loc), + Attribute_Name => Name_Address); + + Append_To (DT_Constr_List, New_Node); + Append_To (DT_Aggr_List, New_Copy (New_Node)); + Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); + + -- In case of locally defined tagged types we have already declared + -- and uninitialized object for the dispatch table, which is now + -- initialized by means of the following assignment: + + -- DT := (TSD'Address, 0); + + if not Building_Static_DT (Typ) then + Append_To (Result, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (DT, Loc), + Expression => Make_Aggregate (Loc, + Expressions => DT_Aggr_List))); + + -- In case of library level tagged types we declare and export now + -- the constant object containing the dummy dispatch table. There + -- is no need to declare the tag here because it has been previously + -- declared by Make_Tags + + -- DT : aliased constant No_Dispatch_Table := + -- (NDT_TSD => TSD'Address; + -- NDT_Prims_Ptr => 0); + -- for DT'Alignment use Address'Alignment; + + else + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT, + Aliased_Present => True, + Constant_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc), + Expression => Make_Aggregate (Loc, + Expressions => DT_Aggr_List))); + + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (DT, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + + Export_DT (Typ, DT); + end if; + + -- Common case: Typ has a dispatch table + + -- Generate: + + -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) := + -- (predef-prim-op-1'address, + -- predef-prim-op-2'address, + -- ... + -- predef-prim-op-n'address); + -- for Predef_Prims'Alignment use Address'Alignment + + -- DT : Dispatch_Table (Nb_Prims) := + -- (Signature => , + -- Tag_Kind => , + -- Predef_Prims => Predef_Prims'First'Address, + -- Offset_To_Top => 0, + -- TSD => TSD'Address; + -- Prims_Ptr => (prim-op-1'address, + -- prim-op-2'address, + -- ... + -- prim-op-n'address)); + -- for DT'Alignment use Address'Alignment + + else + declare + Pos : Nat; + + begin + if not Building_Static_DT (Typ) then + Nb_Predef_Prims := Max_Predef_Prims; + + else + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if Is_Predefined_Dispatching_Operation (Prim) + and then not Is_Abstract_Subprogram (Prim) + then + Pos := UI_To_Int (DT_Position (Prim)); + + if Pos > Nb_Predef_Prims then + Nb_Predef_Prims := Pos; + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end if; + + declare + Prim_Table : array + (Nat range 1 .. Nb_Predef_Prims) of Entity_Id; + Decl : Node_Id; + E : Entity_Id; + + begin + Prim_Ops_Aggr_List := New_List; + + Prim_Table := (others => Empty); + + if Building_Static_DT (Typ) then + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if Is_Predefined_Dispatching_Operation (Prim) + and then not Is_Abstract_Subprogram (Prim) + and then not Is_Eliminated (Prim) + and then not Present (Prim_Table + (UI_To_Int (DT_Position (Prim)))) + then + E := Ultimate_Alias (Prim); + pragma Assert (not Is_Abstract_Subprogram (E)); + Prim_Table (UI_To_Int (DT_Position (Prim))) := E; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end if; + + for J in Prim_Table'Range loop + if Present (Prim_Table (J)) then + New_Node := + Unchecked_Convert_To (RTE (RE_Prim_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim_Table (J), Loc), + Attribute_Name => Name_Unrestricted_Access)); + else + New_Node := Make_Null (Loc); + end if; + + Append_To (Prim_Ops_Aggr_List, New_Node); + end loop; + + New_Node := + Make_Aggregate (Loc, + Expressions => Prim_Ops_Aggr_List); + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'S'), + Subtype_Indication => + New_Reference_To (RTE (RE_Address_Array), Loc)); + + Append_To (Result, Decl); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Predef_Prims, + Aliased_Present => True, + Constant_Present => Building_Static_DT (Typ), + Object_Definition => New_Reference_To + (Defining_Identifier (Decl), Loc), + Expression => New_Node)); + + -- Remember aggregates initializing dispatch tables + + Append_Elmt (New_Node, DT_Aggr); + + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (Predef_Prims, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + end; + end; + + -- Stage 1: Initialize the discriminant and the record components + + DT_Constr_List := New_List; + DT_Aggr_List := New_List; + + -- Num_Prims. If the tagged type has no primitives we add a dummy + -- slot whose address will be the tag of this type. + + if Nb_Prim = 0 then + New_Node := Make_Integer_Literal (Loc, 1); + else + New_Node := Make_Integer_Literal (Loc, Nb_Prim); + end if; + + Append_To (DT_Constr_List, New_Node); + Append_To (DT_Aggr_List, New_Copy (New_Node)); + + -- Signature + + if RTE_Record_Component_Available (RE_Signature) then + Append_To (DT_Aggr_List, + New_Reference_To (RTE (RE_Primary_DT), Loc)); + end if; + + -- Tag_Kind + + if RTE_Record_Component_Available (RE_Tag_Kind) then + Append_To (DT_Aggr_List, Tagged_Kind (Typ)); + end if; + + -- Predef_Prims + + Append_To (DT_Aggr_List, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Predef_Prims, Loc), + Attribute_Name => Name_Address)); + + -- Offset_To_Top + + Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); + + -- Typeinfo + + Append_To (DT_Aggr_List, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (TSD, Loc), + Attribute_Name => Name_Address)); + + -- Stage 2: Initialize the table of primitive operations + + Prim_Ops_Aggr_List := New_List; + + if Nb_Prim = 0 then + Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); + + elsif not Building_Static_DT (Typ) then + for J in 1 .. Nb_Prim loop + Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); + end loop; + + else + declare + CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ); + E : Entity_Id; + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + Prim_Pos : Nat; + Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; + + begin + Prim_Table := (others => Empty); + + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + -- Retrieve the ultimate alias of the primitive for proper + -- handling of renamings and eliminated primitives. + + E := Ultimate_Alias (Prim); + Prim_Pos := UI_To_Int (DT_Position (E)); + + -- Do not reference predefined primitives because they are + -- located in a separate dispatch table; skip entities with + -- attribute Interface_Alias because they are only required + -- to build secondary dispatch tables; skip abstract and + -- eliminated primitives; for derivations of CPP types skip + -- primitives located in the C++ part of the dispatch table + -- because their slot is initialized by the IC routine. + + if not Is_Predefined_Dispatching_Operation (Prim) + and then not Is_Predefined_Dispatching_Operation (E) + and then not Present (Interface_Alias (Prim)) + and then not Is_Abstract_Subprogram (E) + and then not Is_Eliminated (E) + and then (not Is_CPP_Class (Root_Type (Typ)) + or else Prim_Pos > CPP_Nb_Prims) + then + pragma Assert + (UI_To_Int (DT_Position (Prim)) <= Nb_Prim); + + Prim_Table (UI_To_Int (DT_Position (Prim))) := E; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + for J in Prim_Table'Range loop + if Present (Prim_Table (J)) then + New_Node := + Unchecked_Convert_To (RTE (RE_Prim_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim_Table (J), Loc), + Attribute_Name => Name_Unrestricted_Access)); + else + New_Node := Make_Null (Loc); + end if; + + Append_To (Prim_Ops_Aggr_List, New_Node); + end loop; + end; + end if; + + New_Node := + Make_Aggregate (Loc, + Expressions => Prim_Ops_Aggr_List); + + Append_To (DT_Aggr_List, New_Node); + + -- Remember aggregates initializing dispatch tables + + Append_Elmt (New_Node, DT_Aggr); + + -- In case of locally defined tagged types we have already declared + -- and uninitialized object for the dispatch table, which is now + -- initialized by means of an assignment. + + if not Building_Static_DT (Typ) then + Append_To (Result, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (DT, Loc), + Expression => Make_Aggregate (Loc, + Expressions => DT_Aggr_List))); + + -- In case of library level tagged types we declare now and export + -- the constant object containing the dispatch table. + + else + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT, + Aliased_Present => True, + Constant_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To + (RTE (RE_Dispatch_Table_Wrapper), Loc), + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => DT_Constr_List)), + Expression => Make_Aggregate (Loc, + Expressions => DT_Aggr_List))); + + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (DT, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + + Export_DT (Typ, DT); + end if; + end if; + + -- Initialize the table of ancestor tags if not building static + -- dispatch table + + if not Building_Static_DT (Typ) + and then not Is_Interface (Typ) + and then not Is_CPP_Class (Typ) + then + Append_To (Result, + Make_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => + New_Reference_To (TSD, Loc), + Selector_Name => + New_Reference_To + (RTE_Record_Component (RE_Tags_Table), Loc)), + Expressions => + New_List (Make_Integer_Literal (Loc, 0))), + + Expression => + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Typ))), Loc))); + end if; + + -- Inherit the dispatch tables of the parent. There is no need to + -- inherit anything from the parent when building static dispatch tables + -- because the whole dispatch table (including inherited primitives) has + -- been already built. + + if Building_Static_DT (Typ) then + null; + + -- If the ancestor is a CPP_Class type we inherit the dispatch tables + -- in the init proc, and we don't need to fill them in here. + + elsif Is_CPP_Class (Parent_Typ) then + null; + + -- Otherwise we fill in the dispatch tables here + + else + if Typ /= Parent_Typ + and then not Is_Interface (Typ) + and then not Restriction_Active (No_Dispatching_Calls) + then + -- Inherit the dispatch table + + if not Is_Interface (Typ) + and then not Is_Interface (Parent_Typ) + and then not Is_CPP_Class (Parent_Typ) + then + declare + Nb_Prims : constant Int := + UI_To_Int (DT_Entry_Count + (First_Tag_Component (Parent_Typ))); + + begin + Append_To (Elab_Code, + Build_Inherit_Predefined_Prims (Loc, + Old_Tag_Node => + New_Reference_To + (Node + (Next_Elmt + (First_Elmt + (Access_Disp_Table (Parent_Typ)))), Loc), + New_Tag_Node => + New_Reference_To + (Node + (Next_Elmt + (First_Elmt + (Access_Disp_Table (Typ)))), Loc))); + + if Nb_Prims /= 0 then + Append_To (Elab_Code, + Build_Inherit_Prims (Loc, + Typ => Typ, + Old_Tag_Node => + New_Reference_To + (Node + (First_Elmt + (Access_Disp_Table (Parent_Typ))), Loc), + New_Tag_Node => New_Reference_To (DT_Ptr, Loc), + Num_Prims => Nb_Prims)); + end if; + end; + end if; + + -- Inherit the secondary dispatch tables of the ancestor + + if not Is_CPP_Class (Parent_Typ) then + declare + Sec_DT_Ancestor : Elmt_Id := + Next_Elmt + (Next_Elmt + (First_Elmt + (Access_Disp_Table (Parent_Typ)))); + Sec_DT_Typ : Elmt_Id := + Next_Elmt + (Next_Elmt + (First_Elmt + (Access_Disp_Table (Typ)))); + + procedure Copy_Secondary_DTs (Typ : Entity_Id); + -- Local procedure required to climb through the ancestors + -- and copy the contents of all their secondary dispatch + -- tables. + + ------------------------ + -- Copy_Secondary_DTs -- + ------------------------ + + procedure Copy_Secondary_DTs (Typ : Entity_Id) is + E : Entity_Id; + Iface : Elmt_Id; + + begin + -- Climb to the ancestor (if any) handling private types + + if Present (Full_View (Etype (Typ))) then + if Full_View (Etype (Typ)) /= Typ then + Copy_Secondary_DTs (Full_View (Etype (Typ))); + end if; + + elsif Etype (Typ) /= Typ then + Copy_Secondary_DTs (Etype (Typ)); + end if; + + if Present (Interfaces (Typ)) + and then not Is_Empty_Elmt_List (Interfaces (Typ)) + then + Iface := First_Elmt (Interfaces (Typ)); + E := First_Entity (Typ); + while Present (E) + and then Present (Node (Sec_DT_Ancestor)) + and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant + loop + if Is_Tag (E) and then Chars (E) /= Name_uTag then + declare + Num_Prims : constant Int := + UI_To_Int (DT_Entry_Count (E)); + + begin + if not Is_Interface (Etype (Typ)) then + + -- Inherit first secondary dispatch table + + Append_To (Elab_Code, + Build_Inherit_Predefined_Prims (Loc, + Old_Tag_Node => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node + (Next_Elmt (Sec_DT_Ancestor)), + Loc)), + New_Tag_Node => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node (Next_Elmt (Sec_DT_Typ)), + Loc)))); + + if Num_Prims /= 0 then + Append_To (Elab_Code, + Build_Inherit_Prims (Loc, + Typ => Node (Iface), + Old_Tag_Node => + Unchecked_Convert_To + (RTE (RE_Tag), + New_Reference_To + (Node (Sec_DT_Ancestor), + Loc)), + New_Tag_Node => + Unchecked_Convert_To + (RTE (RE_Tag), + New_Reference_To + (Node (Sec_DT_Typ), Loc)), + Num_Prims => Num_Prims)); + end if; + end if; + + Next_Elmt (Sec_DT_Ancestor); + Next_Elmt (Sec_DT_Typ); + + -- Skip the secondary dispatch table of + -- predefined primitives + + Next_Elmt (Sec_DT_Ancestor); + Next_Elmt (Sec_DT_Typ); + + if not Is_Interface (Etype (Typ)) then + + -- Inherit second secondary dispatch table + + Append_To (Elab_Code, + Build_Inherit_Predefined_Prims (Loc, + Old_Tag_Node => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node + (Next_Elmt (Sec_DT_Ancestor)), + Loc)), + New_Tag_Node => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node (Next_Elmt (Sec_DT_Typ)), + Loc)))); + + if Num_Prims /= 0 then + Append_To (Elab_Code, + Build_Inherit_Prims (Loc, + Typ => Node (Iface), + Old_Tag_Node => + Unchecked_Convert_To + (RTE (RE_Tag), + New_Reference_To + (Node (Sec_DT_Ancestor), + Loc)), + New_Tag_Node => + Unchecked_Convert_To + (RTE (RE_Tag), + New_Reference_To + (Node (Sec_DT_Typ), Loc)), + Num_Prims => Num_Prims)); + end if; + end if; + end; + + Next_Elmt (Sec_DT_Ancestor); + Next_Elmt (Sec_DT_Typ); + + -- Skip the secondary dispatch table of + -- predefined primitives + + Next_Elmt (Sec_DT_Ancestor); + Next_Elmt (Sec_DT_Typ); + + Next_Elmt (Iface); + end if; + + Next_Entity (E); + end loop; + end if; + end Copy_Secondary_DTs; + + begin + if Present (Node (Sec_DT_Ancestor)) + and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant + then + -- Handle private types + + if Present (Full_View (Typ)) then + Copy_Secondary_DTs (Full_View (Typ)); + else + Copy_Secondary_DTs (Typ); + end if; + end if; + end; + end if; + end if; + end if; + + -- Generate code to register the Tag in the External_Tag hash table for + -- the pure Ada type only. + + -- Register_Tag (Dt_Ptr); + + -- Skip this action in the following cases: + -- 1) if Register_Tag is not available. + -- 2) in No_Run_Time mode. + -- 3) if Typ is not defined at the library level (this is required + -- to avoid adding concurrency control to the hash table used + -- by the run-time to register the tags). + + if not No_Run_Time_Mode + and then Is_Library_Level_Entity (Typ) + and then RTE_Available (RE_Register_Tag) + then + Append_To (Elab_Code, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Register_Tag), Loc), + Parameter_Associations => + New_List (New_Reference_To (DT_Ptr, Loc)))); + end if; + + if not Is_Empty_List (Elab_Code) then + Append_List_To (Result, Elab_Code); + end if; + + -- Populate the two auxiliary tables used for dispatching asynchronous, + -- conditional and timed selects for synchronized types that implement + -- a limited interface. Skip this step in Ravenscar profile or when + -- general dispatching is forbidden. + + if Ada_Version >= Ada_2005 + and then Is_Concurrent_Record_Type (Typ) + and then Has_Interfaces (Typ) + and then not Restriction_Active (No_Dispatching_Calls) + and then not Restriction_Active (No_Select_Statements) + then + Append_List_To (Result, + Make_Select_Specific_Data_Table (Typ)); + end if; + + -- Remember entities containing dispatch tables + + Append_Elmt (Predef_Prims, DT_Decl); + Append_Elmt (DT, DT_Decl); + + Analyze_List (Result, Suppress => All_Checks); + Set_Has_Dispatch_Table (Typ); + + -- Mark entities containing dispatch tables. Required by the backend to + -- handle them properly. + + if Has_DT (Typ) then + declare + Elmt : Elmt_Id; + + begin + -- Ensure that entities Prim_Ptr and Predef_Prims_Table_Ptr have + -- the decoration required by the backend + + Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr)); + Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr)); + + -- Object declarations + + Elmt := First_Elmt (DT_Decl); + while Present (Elmt) loop + Set_Is_Dispatch_Table_Entity (Node (Elmt)); + pragma Assert (Ekind (Etype (Node (Elmt))) = E_Array_Subtype + or else Ekind (Etype (Node (Elmt))) = E_Record_Subtype); + Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt))); + Next_Elmt (Elmt); + end loop; + + -- Aggregates initializing dispatch tables + + Elmt := First_Elmt (DT_Aggr); + while Present (Elmt) loop + Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt))); + Next_Elmt (Elmt); + end loop; + end; + end if; + + -- Register the tagged type in the call graph nodes table + + Register_CG_Node (Typ); + + return Result; + end Make_DT; + + ------------------------------------- + -- Make_Select_Specific_Data_Table -- + ------------------------------------- + + function Make_Select_Specific_Data_Table + (Typ : Entity_Id) return List_Id + is + Assignments : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Typ); + + Conc_Typ : Entity_Id; + Decls : List_Id; + DT_Ptr : Entity_Id; + Prim : Entity_Id; + Prim_Als : Entity_Id; + Prim_Elmt : Elmt_Id; + Prim_Pos : Uint; + Nb_Prim : Nat := 0; + + type Examined_Array is array (Int range <>) of Boolean; + + function Find_Entry_Index (E : Entity_Id) return Uint; + -- Given an entry, find its index in the visible declarations of the + -- corresponding concurrent type of Typ. + + ---------------------- + -- Find_Entry_Index -- + ---------------------- + + function Find_Entry_Index (E : Entity_Id) return Uint is + Index : Uint := Uint_1; + Subp_Decl : Entity_Id; + + begin + if Present (Decls) + and then not Is_Empty_List (Decls) + then + Subp_Decl := First (Decls); + while Present (Subp_Decl) loop + if Nkind (Subp_Decl) = N_Entry_Declaration then + if Defining_Identifier (Subp_Decl) = E then + return Index; + end if; + + Index := Index + 1; + end if; + + Next (Subp_Decl); + end loop; + end if; + + return Uint_0; + end Find_Entry_Index; + + -- Start of processing for Make_Select_Specific_Data_Table + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); + + if Present (Corresponding_Concurrent_Type (Typ)) then + Conc_Typ := Corresponding_Concurrent_Type (Typ); + + if Present (Full_View (Conc_Typ)) then + Conc_Typ := Full_View (Conc_Typ); + end if; + + if Ekind (Conc_Typ) = E_Protected_Type then + Decls := Visible_Declarations (Protected_Definition ( + Parent (Conc_Typ))); + else + pragma Assert (Ekind (Conc_Typ) = E_Task_Type); + Decls := Visible_Declarations (Task_Definition ( + Parent (Conc_Typ))); + end if; + end if; + + -- Count the non-predefined primitive operations + + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if not (Is_Predefined_Dispatching_Operation (Prim) + or else Is_Predefined_Dispatching_Alias (Prim)) + then + Nb_Prim := Nb_Prim + 1; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + declare + Examined : Examined_Array (1 .. Nb_Prim) := (others => False); + + begin + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + -- Look for primitive overriding an abstract interface subprogram + + if Present (Interface_Alias (Prim)) + and then not + Is_Ancestor + (Find_Dispatching_Type (Interface_Alias (Prim)), Typ) + and then not Examined (UI_To_Int (DT_Position (Alias (Prim)))) + then + Prim_Pos := DT_Position (Alias (Prim)); + pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim); + Examined (UI_To_Int (Prim_Pos)) := True; + + -- Set the primitive operation kind regardless of subprogram + -- type. Generate: + -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, , ); + + Append_To (Assignments, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Set_Prim_Op_Kind), Loc), + Parameter_Associations => New_List ( + New_Reference_To (DT_Ptr, Loc), + Make_Integer_Literal (Loc, Prim_Pos), + Prim_Op_Kind (Alias (Prim), Typ)))); + + -- Retrieve the root of the alias chain + + Prim_Als := Ultimate_Alias (Prim); + + -- In the case of an entry wrapper, set the entry index + + if Ekind (Prim) = E_Procedure + and then Is_Primitive_Wrapper (Prim_Als) + and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry + then + -- Generate: + -- Ada.Tags.Set_Entry_Index + -- (DT_Ptr, , ); + + Append_To (Assignments, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Set_Entry_Index), Loc), + Parameter_Associations => New_List ( + New_Reference_To (DT_Ptr, Loc), + Make_Integer_Literal (Loc, Prim_Pos), + Make_Integer_Literal (Loc, + Find_Entry_Index (Wrapped_Entity (Prim_Als)))))); + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end; + + return Assignments; + end Make_Select_Specific_Data_Table; + + --------------- + -- Make_Tags -- + --------------- + + function Make_Tags (Typ : Entity_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (Typ); + Result : constant List_Id := New_List; + + procedure Import_DT + (Tag_Typ : Entity_Id; + DT : Entity_Id; + Is_Secondary_DT : Boolean); + -- Import the dispatch table DT of tagged type Tag_Typ. Required to + -- generate forward references and statically allocate the table. For + -- primary dispatch tables that require no dispatch table generate: + + -- DT : static aliased constant Non_Dispatch_Table_Wrapper; + -- pragma Import (Ada, DT); + + -- Otherwise generate: + + -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim); + -- pragma Import (Ada, DT); + + --------------- + -- Import_DT -- + --------------- + + procedure Import_DT + (Tag_Typ : Entity_Id; + DT : Entity_Id; + Is_Secondary_DT : Boolean) + is + DT_Constr_List : List_Id; + Nb_Prim : Nat; + + begin + Set_Is_Imported (DT); + Set_Ekind (DT, E_Constant); + Set_Related_Type (DT, Typ); + + -- The scope must be set now to call Get_External_Name + + Set_Scope (DT, Current_Scope); + + Get_External_Name (DT, True); + Set_Interface_Name (DT, + Make_String_Literal (Loc, Strval => String_From_Name_Buffer)); + + -- Ensure proper Sprint output of this implicit importation + + Set_Is_Internal (DT); + + -- Save this entity to allow Make_DT to generate its exportation + + Append_Elmt (DT, Dispatch_Table_Wrappers (Typ)); + + -- No dispatch table required + + if not Is_Secondary_DT and then not Has_DT (Tag_Typ) then + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT, + Aliased_Present => True, + Constant_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc))); + + else + -- Calculate the number of primitives of the dispatch table and + -- the size of the Type_Specific_Data record. + + Nb_Prim := + UI_To_Int (DT_Entry_Count (First_Tag_Component (Tag_Typ))); + + -- If the tagged type has no primitives we add a dummy slot whose + -- address will be the tag of this type. + + if Nb_Prim = 0 then + DT_Constr_List := + New_List (Make_Integer_Literal (Loc, 1)); + else + DT_Constr_List := + New_List (Make_Integer_Literal (Loc, Nb_Prim)); + end if; + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT, + Aliased_Present => True, + Constant_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc), + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => DT_Constr_List)))); + end if; + end Import_DT; + + -- Local variables + + Tname : constant Name_Id := Chars (Typ); + AI_Tag_Comp : Elmt_Id; + DT : Node_Id := Empty; + DT_Ptr : Node_Id; + Predef_Prims_Ptr : Node_Id; + Iface_DT : Node_Id := Empty; + Iface_DT_Ptr : Node_Id; + New_Node : Node_Id; + Suffix_Index : Int; + Typ_Name : Name_Id; + Typ_Comps : Elist_Id; + + -- Start of processing for Make_Tags + + begin + pragma Assert (No (Access_Disp_Table (Typ))); + Set_Access_Disp_Table (Typ, New_Elmt_List); + + -- 1) Generate the primary tag entities + + -- Primary dispatch table containing user-defined primitives + + DT_Ptr := Make_Defining_Identifier (Loc, New_External_Name (Tname, 'P')); + Set_Etype (DT_Ptr, RTE (RE_Tag)); + Append_Elmt (DT_Ptr, Access_Disp_Table (Typ)); + + -- Minimum decoration + + Set_Ekind (DT_Ptr, E_Variable); + Set_Related_Type (DT_Ptr, Typ); + + -- For CPP types there is no need to build the dispatch tables since + -- they are imported from the C++ side. If the CPP type has an IP then + -- we declare now the variable that will store the copy of the C++ tag. + -- If the CPP type is an interface, we need the variable as well because + -- it becomes the pointer to the corresponding secondary table. + + if Is_CPP_Class (Typ) then + if Has_CPP_Constructors (Typ) or else Is_Interface (Typ) then + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT_Ptr, + Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (RTE (RE_Null_Address), Loc)))); + + Set_Is_Statically_Allocated (DT_Ptr, + Is_Library_Level_Tagged_Type (Typ)); + end if; + + -- Ada types + + else + -- Primary dispatch table containing predefined primitives + + Predef_Prims_Ptr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Tname, 'Y')); + Set_Etype (Predef_Prims_Ptr, RTE (RE_Address)); + Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ)); + + -- Import the forward declaration of the Dispatch Table wrapper + -- record (Make_DT will take care of exporting it). + + if Building_Static_DT (Typ) then + Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List); + + DT := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Tname, 'T')); + + Import_DT (Typ, DT, Is_Secondary_DT => False); + + if Has_DT (Typ) then + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT_Ptr, + Constant_Present => True, + Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_Prims_Ptr), Loc)), + Attribute_Name => Name_Address)))); + + -- Generate the SCIL node for the previous object declaration + -- because it has a tag initialization. + + if Generate_SCIL then + New_Node := + Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); + Set_SCIL_Entity (New_Node, Typ); + Set_SCIL_Node (Last (Result), New_Node); + end if; + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Predef_Prims_Ptr, + Constant_Present => True, + Object_Definition => New_Reference_To + (RTE (RE_Address), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_Predef_Prims), Loc)), + Attribute_Name => Name_Address))); + + -- No dispatch table required + + else + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT_Ptr, + Constant_Present => True, + Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)), + Attribute_Name => Name_Address)))); + end if; + + Set_Is_True_Constant (DT_Ptr); + Set_Is_Statically_Allocated (DT_Ptr); + end if; + end if; + + -- 2) Generate the secondary tag entities + + -- Collect the components associated with secondary dispatch tables + + if Has_Interfaces (Typ) then + Collect_Interface_Components (Typ, Typ_Comps); + + -- For each interface type we build a unique external name associated + -- with its secondary dispatch table. This name is used to declare an + -- object that references this secondary dispatch table, whose value + -- will be used for the elaboration of Typ objects, and also for the + -- elaboration of objects of types derived from Typ that do not + -- override the primitives of this interface type. + + Suffix_Index := 1; + + -- Note: The value of Suffix_Index must be in sync with the + -- Suffix_Index values of secondary dispatch tables generated + -- by Make_DT. + + if Is_CPP_Class (Typ) then + AI_Tag_Comp := First_Elmt (Typ_Comps); + while Present (AI_Tag_Comp) loop + Get_Secondary_DT_External_Name + (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index); + Typ_Name := Name_Find; + + -- Declare variables that will store the copy of the C++ + -- secondary tags. + + Iface_DT_Ptr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Typ_Name, 'P')); + Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag)); + Set_Ekind (Iface_DT_Ptr, E_Variable); + Set_Is_Tag (Iface_DT_Ptr); + + Set_Has_Thunks (Iface_DT_Ptr); + Set_Related_Type + (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); + Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Iface_DT_Ptr, + Object_Definition => New_Reference_To + (RTE (RE_Interface_Tag), Loc), + Expression => + Unchecked_Convert_To (RTE (RE_Interface_Tag), + New_Reference_To (RTE (RE_Null_Address), Loc)))); + + Set_Is_Statically_Allocated (Iface_DT_Ptr, + Is_Library_Level_Tagged_Type (Typ)); + + Next_Elmt (AI_Tag_Comp); + end loop; + + -- This is not a CPP_Class type + + else + AI_Tag_Comp := First_Elmt (Typ_Comps); + while Present (AI_Tag_Comp) loop + Get_Secondary_DT_External_Name + (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index); + Typ_Name := Name_Find; + + if Building_Static_DT (Typ) then + Iface_DT := + Make_Defining_Identifier (Loc, + Chars => New_External_Name + (Typ_Name, 'T', Suffix_Index => -1)); + Import_DT + (Tag_Typ => Related_Type (Node (AI_Tag_Comp)), + DT => Iface_DT, + Is_Secondary_DT => True); + end if; + + -- Secondary dispatch table referencing thunks to user-defined + -- primitives covered by this interface. + + Iface_DT_Ptr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Typ_Name, 'P')); + Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag)); + Set_Ekind (Iface_DT_Ptr, E_Constant); + Set_Is_Tag (Iface_DT_Ptr); + Set_Has_Thunks (Iface_DT_Ptr); + Set_Is_Statically_Allocated (Iface_DT_Ptr, + Is_Library_Level_Tagged_Type (Typ)); + Set_Is_True_Constant (Iface_DT_Ptr); + Set_Related_Type + (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); + Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); + + if Building_Static_DT (Typ) then + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Iface_DT_Ptr, + Constant_Present => True, + Object_Definition => New_Reference_To + (RTE (RE_Interface_Tag), Loc), + Expression => + Unchecked_Convert_To (RTE (RE_Interface_Tag), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Iface_DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_Prims_Ptr), Loc)), + Attribute_Name => Name_Address)))); + end if; + + -- Secondary dispatch table referencing thunks to predefined + -- primitives. + + Iface_DT_Ptr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Typ_Name, 'Y')); + Set_Etype (Iface_DT_Ptr, RTE (RE_Address)); + Set_Ekind (Iface_DT_Ptr, E_Constant); + Set_Is_Tag (Iface_DT_Ptr); + Set_Has_Thunks (Iface_DT_Ptr); + Set_Is_Statically_Allocated (Iface_DT_Ptr, + Is_Library_Level_Tagged_Type (Typ)); + Set_Is_True_Constant (Iface_DT_Ptr); + Set_Related_Type + (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); + Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); + + -- Secondary dispatch table referencing user-defined primitives + -- covered by this interface. + + Iface_DT_Ptr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Typ_Name, 'D')); + Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag)); + Set_Ekind (Iface_DT_Ptr, E_Constant); + Set_Is_Tag (Iface_DT_Ptr); + Set_Is_Statically_Allocated (Iface_DT_Ptr, + Is_Library_Level_Tagged_Type (Typ)); + Set_Is_True_Constant (Iface_DT_Ptr); + Set_Related_Type + (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); + Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); + + -- Secondary dispatch table referencing predefined primitives + + Iface_DT_Ptr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Typ_Name, 'Z')); + Set_Etype (Iface_DT_Ptr, RTE (RE_Address)); + Set_Ekind (Iface_DT_Ptr, E_Constant); + Set_Is_Tag (Iface_DT_Ptr); + Set_Is_Statically_Allocated (Iface_DT_Ptr, + Is_Library_Level_Tagged_Type (Typ)); + Set_Is_True_Constant (Iface_DT_Ptr); + Set_Related_Type + (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); + Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); + + Next_Elmt (AI_Tag_Comp); + end loop; + end if; + end if; + + -- 3) At the end of Access_Disp_Table, if the type has user-defined + -- primitives, we add the entity of an access type declaration that + -- is used by Build_Get_Prim_Op_Address to expand dispatching calls + -- through the primary dispatch table. + + if UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))) = 0 then + Analyze_List (Result); + + -- Generate: + -- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr; + -- type Typ_DT_Acc is access Typ_DT; + + else + declare + Name_DT_Prims : constant Name_Id := + New_External_Name (Tname, 'G'); + Name_DT_Prims_Acc : constant Name_Id := + New_External_Name (Tname, 'H'); + DT_Prims : constant Entity_Id := + Make_Defining_Identifier (Loc, + Name_DT_Prims); + DT_Prims_Acc : constant Entity_Id := + Make_Defining_Identifier (Loc, + Name_DT_Prims_Acc); + begin + Append_To (Result, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => DT_Prims, + Type_Definition => + Make_Constrained_Array_Definition (Loc, + Discrete_Subtype_Definitions => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Make_Integer_Literal (Loc, + DT_Entry_Count + (First_Tag_Component (Typ))))), + Component_Definition => + Make_Component_Definition (Loc, + Subtype_Indication => + New_Reference_To (RTE (RE_Prim_Ptr), Loc))))); + + Append_To (Result, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => DT_Prims_Acc, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (DT_Prims, Loc)))); + + Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ)); + + -- Analyze the resulting list and suppress the generation of the + -- Init_Proc associated with the above array declaration because + -- this type is never used in object declarations. It is only used + -- to simplify the expansion associated with dispatching calls. + + Analyze_List (Result); + Set_Suppress_Init_Proc (Base_Type (DT_Prims)); + + -- Disable backend optimizations based on assumptions about the + -- aliasing status of objects designated by the access to the + -- dispatch table. Required to handle dispatch tables imported + -- from C++. + + Set_No_Strict_Aliasing (Base_Type (DT_Prims_Acc)); + + -- Add the freezing nodes of these declarations; required to avoid + -- generating these freezing nodes in wrong scopes (for example in + -- the IC routine of a derivation of Typ). + -- What is an "IC routine"? Is "init_proc" meant here??? + + Append_List_To (Result, Freeze_Entity (DT_Prims, Typ)); + Append_List_To (Result, Freeze_Entity (DT_Prims_Acc, Typ)); + + -- Mark entity of dispatch table. Required by the back end to + -- handle them properly. + + Set_Is_Dispatch_Table_Entity (DT_Prims); + end; + end if; + + -- Mark entities of dispatch table. Required by the back end to handle + -- them properly. + + if Present (DT) then + Set_Is_Dispatch_Table_Entity (DT); + Set_Is_Dispatch_Table_Entity (Etype (DT)); + end if; + + if Present (Iface_DT) then + Set_Is_Dispatch_Table_Entity (Iface_DT); + Set_Is_Dispatch_Table_Entity (Etype (Iface_DT)); + end if; + + if Is_CPP_Class (Root_Type (Typ)) then + Set_Ekind (DT_Ptr, E_Variable); + else + Set_Ekind (DT_Ptr, E_Constant); + end if; + + Set_Is_Tag (DT_Ptr); + Set_Related_Type (DT_Ptr, Typ); + + return Result; + end Make_Tags; + + --------------- + -- New_Value -- + --------------- + + function New_Value (From : Node_Id) return Node_Id is + Res : constant Node_Id := Duplicate_Subexpr (From); + begin + if Is_Access_Type (Etype (From)) then + return + Make_Explicit_Dereference (Sloc (From), + Prefix => Res); + else + return Res; + end if; + end New_Value; + + ----------------------------------- + -- Original_View_In_Visible_Part -- + ----------------------------------- + + function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is + Scop : constant Entity_Id := Scope (Typ); + + begin + -- The scope must be a package + + if not Is_Package_Or_Generic_Package (Scop) then + return False; + end if; + + -- A type with a private declaration has a private view declared in + -- the visible part. + + if Has_Private_Declaration (Typ) then + return True; + end if; + + return List_Containing (Parent (Typ)) = + Visible_Declarations (Specification (Unit_Declaration_Node (Scop))); + end Original_View_In_Visible_Part; + + ------------------ + -- Prim_Op_Kind -- + ------------------ + + function Prim_Op_Kind + (Prim : Entity_Id; + Typ : Entity_Id) return Node_Id + is + Full_Typ : Entity_Id := Typ; + Loc : constant Source_Ptr := Sloc (Prim); + Prim_Op : Entity_Id; + + begin + -- Retrieve the original primitive operation + + Prim_Op := Ultimate_Alias (Prim); + + if Ekind (Typ) = E_Record_Type + and then Present (Corresponding_Concurrent_Type (Typ)) + then + Full_Typ := Corresponding_Concurrent_Type (Typ); + end if; + + -- When a private tagged type is completed by a concurrent type, + -- retrieve the full view. + + if Is_Private_Type (Full_Typ) then + Full_Typ := Full_View (Full_Typ); + end if; + + if Ekind (Prim_Op) = E_Function then + + -- Protected function + + if Ekind (Full_Typ) = E_Protected_Type then + return New_Reference_To (RTE (RE_POK_Protected_Function), Loc); + + -- Task function + + elsif Ekind (Full_Typ) = E_Task_Type then + return New_Reference_To (RTE (RE_POK_Task_Function), Loc); + + -- Regular function + + else + return New_Reference_To (RTE (RE_POK_Function), Loc); + end if; + + else + pragma Assert (Ekind (Prim_Op) = E_Procedure); + + if Ekind (Full_Typ) = E_Protected_Type then + + -- Protected entry + + if Is_Primitive_Wrapper (Prim_Op) + and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry + then + return New_Reference_To (RTE (RE_POK_Protected_Entry), Loc); + + -- Protected procedure + + else + return New_Reference_To (RTE (RE_POK_Protected_Procedure), Loc); + end if; + + elsif Ekind (Full_Typ) = E_Task_Type then + + -- Task entry + + if Is_Primitive_Wrapper (Prim_Op) + and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry + then + return New_Reference_To (RTE (RE_POK_Task_Entry), Loc); + + -- Task "procedure". These are the internally Expander-generated + -- procedures (task body for instance). + + else + return New_Reference_To (RTE (RE_POK_Task_Procedure), Loc); + end if; + + -- Regular procedure + + else + return New_Reference_To (RTE (RE_POK_Procedure), Loc); + end if; + end if; + end Prim_Op_Kind; + + ------------------------ + -- Register_Primitive -- + ------------------------ + + function Register_Primitive + (Loc : Source_Ptr; + Prim : Entity_Id) return List_Id + is + DT_Ptr : Entity_Id; + Iface_Prim : Entity_Id; + Iface_Typ : Entity_Id; + Iface_DT_Ptr : Entity_Id; + Iface_DT_Elmt : Elmt_Id; + L : constant List_Id := New_List; + Pos : Uint; + Tag : Entity_Id; + Tag_Typ : Entity_Id; + Thunk_Id : Entity_Id; + Thunk_Code : Node_Id; + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + -- Do not register in the dispatch table eliminated primitives + + if not RTE_Available (RE_Tag) + or else Is_Eliminated (Ultimate_Alias (Prim)) + then + return L; + end if; + + if not Present (Interface_Alias (Prim)) then + Tag_Typ := Scope (DTC_Entity (Prim)); + Pos := DT_Position (Prim); + Tag := First_Tag_Component (Tag_Typ); + + if Is_Predefined_Dispatching_Operation (Prim) + or else Is_Predefined_Dispatching_Alias (Prim) + then + DT_Ptr := + Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ)))); + + Append_To (L, + Build_Set_Predefined_Prim_Op_Address (Loc, + Tag_Node => New_Reference_To (DT_Ptr, Loc), + Position => Pos, + Address_Node => + Unchecked_Convert_To (RTE (RE_Prim_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim, Loc), + Attribute_Name => Name_Unrestricted_Access)))); + + -- Register copy of the pointer to the 'size primitive in the TSD + + if Chars (Prim) = Name_uSize + and then RTE_Record_Component_Available (RE_Size_Func) + then + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ))); + Append_To (L, + Build_Set_Size_Function (Loc, + Tag_Node => New_Reference_To (DT_Ptr, Loc), + Size_Func => Prim)); + end if; + + else + pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); + + -- Skip registration of primitives located in the C++ part of the + -- dispatch table. Their slot is set by the IC routine. + + if not Is_CPP_Class (Root_Type (Tag_Typ)) + or else Pos > CPP_Num_Prims (Tag_Typ) + then + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ))); + Append_To (L, + Build_Set_Prim_Op_Address (Loc, + Typ => Tag_Typ, + Tag_Node => New_Reference_To (DT_Ptr, Loc), + Position => Pos, + Address_Node => + Unchecked_Convert_To (RTE (RE_Prim_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim, Loc), + Attribute_Name => Name_Unrestricted_Access)))); + end if; + end if; + + -- Ada 2005 (AI-251): Primitive associated with an interface type + -- Generate the code of the thunk only if the interface type is not an + -- immediate ancestor of Typ; otherwise the dispatch table associated + -- with the interface is the primary dispatch table and we have nothing + -- else to do here. + + else + Tag_Typ := Find_Dispatching_Type (Alias (Prim)); + Iface_Typ := Find_Dispatching_Type (Interface_Alias (Prim)); + + pragma Assert (Is_Interface (Iface_Typ)); + + -- No action needed for interfaces that are ancestors of Typ because + -- their primitives are located in the primary dispatch table. + + if Is_Ancestor (Iface_Typ, Tag_Typ) then + return L; + + -- No action needed for primitives located in the C++ part of the + -- dispatch table. Their slot is set by the IC routine. + + elsif Is_CPP_Class (Root_Type (Tag_Typ)) + and then DT_Position (Alias (Prim)) <= CPP_Num_Prims (Tag_Typ) + and then not Is_Predefined_Dispatching_Operation (Prim) + and then not Is_Predefined_Dispatching_Alias (Prim) + then + return L; + end if; + + Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); + + if not Is_Ancestor (Iface_Typ, Tag_Typ) + and then Present (Thunk_Code) + then + -- Generate the code necessary to fill the appropriate entry of + -- the secondary dispatch table of Prim's controlling type with + -- Thunk_Id's address. + + Iface_DT_Elmt := Find_Interface_ADT (Tag_Typ, Iface_Typ); + Iface_DT_Ptr := Node (Iface_DT_Elmt); + pragma Assert (Has_Thunks (Iface_DT_Ptr)); + + Iface_Prim := Interface_Alias (Prim); + Pos := DT_Position (Iface_Prim); + Tag := First_Tag_Component (Iface_Typ); + + Prepend_To (L, Thunk_Code); + + if Is_Predefined_Dispatching_Operation (Prim) + or else Is_Predefined_Dispatching_Alias (Prim) + then + Append_To (L, + Build_Set_Predefined_Prim_Op_Address (Loc, + Tag_Node => + New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc), + Position => Pos, + Address_Node => + Unchecked_Convert_To (RTE (RE_Prim_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Thunk_Id, Loc), + Attribute_Name => Name_Unrestricted_Access)))); + + Next_Elmt (Iface_DT_Elmt); + Next_Elmt (Iface_DT_Elmt); + Iface_DT_Ptr := Node (Iface_DT_Elmt); + pragma Assert (not Has_Thunks (Iface_DT_Ptr)); + + Append_To (L, + Build_Set_Predefined_Prim_Op_Address (Loc, + Tag_Node => + New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc), + Position => Pos, + Address_Node => + Unchecked_Convert_To (RTE (RE_Prim_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Alias (Prim), Loc), + Attribute_Name => Name_Unrestricted_Access)))); + + else + pragma Assert (Pos /= Uint_0 + and then Pos <= DT_Entry_Count (Tag)); + + Append_To (L, + Build_Set_Prim_Op_Address (Loc, + Typ => Iface_Typ, + Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), + Position => Pos, + Address_Node => + Unchecked_Convert_To (RTE (RE_Prim_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Thunk_Id, Loc), + Attribute_Name => Name_Unrestricted_Access)))); + + Next_Elmt (Iface_DT_Elmt); + Next_Elmt (Iface_DT_Elmt); + Iface_DT_Ptr := Node (Iface_DT_Elmt); + pragma Assert (not Has_Thunks (Iface_DT_Ptr)); + + Append_To (L, + Build_Set_Prim_Op_Address (Loc, + Typ => Iface_Typ, + Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), + Position => Pos, + Address_Node => + Unchecked_Convert_To (RTE (RE_Prim_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Alias (Prim), Loc), + Attribute_Name => Name_Unrestricted_Access)))); + + end if; + end if; + end if; + + return L; + end Register_Primitive; + + ------------------------- + -- Set_All_DT_Position -- + ------------------------- + + procedure Set_All_DT_Position (Typ : Entity_Id) is + + procedure Validate_Position (Prim : Entity_Id); + -- Check that the position assigned to Prim is completely safe + -- (it has not been assigned to a previously defined primitive + -- operation of Typ) + + ----------------------- + -- Validate_Position -- + ----------------------- + + procedure Validate_Position (Prim : Entity_Id) is + Op_Elmt : Elmt_Id; + Op : Entity_Id; + + begin + -- Aliased primitives are safe + + if Present (Alias (Prim)) then + return; + end if; + + Op_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Op_Elmt) loop + Op := Node (Op_Elmt); + + -- No need to check against itself + + if Op = Prim then + null; + + -- Primitive operations covering abstract interfaces are + -- allocated later + + elsif Present (Interface_Alias (Op)) then + null; + + -- Predefined dispatching operations are completely safe. They + -- are allocated at fixed positions in a separate table. + + elsif Is_Predefined_Dispatching_Operation (Op) + or else Is_Predefined_Dispatching_Alias (Op) + then + null; + + -- Aliased subprograms are safe + + elsif Present (Alias (Op)) then + null; + + elsif DT_Position (Op) = DT_Position (Prim) + and then not Is_Predefined_Dispatching_Operation (Op) + and then not Is_Predefined_Dispatching_Operation (Prim) + and then not Is_Predefined_Dispatching_Alias (Op) + and then not Is_Predefined_Dispatching_Alias (Prim) + then + + -- Handle aliased subprograms + + declare + Op_1 : Entity_Id; + Op_2 : Entity_Id; + + begin + Op_1 := Op; + loop + if Present (Overridden_Operation (Op_1)) then + Op_1 := Overridden_Operation (Op_1); + elsif Present (Alias (Op_1)) then + Op_1 := Alias (Op_1); + else + exit; + end if; + end loop; + + Op_2 := Prim; + loop + if Present (Overridden_Operation (Op_2)) then + Op_2 := Overridden_Operation (Op_2); + elsif Present (Alias (Op_2)) then + Op_2 := Alias (Op_2); + else + exit; + end if; + end loop; + + if Op_1 /= Op_2 then + raise Program_Error; + end if; + end; + end if; + + Next_Elmt (Op_Elmt); + end loop; + end Validate_Position; + + -- Local variables + + Parent_Typ : constant Entity_Id := Etype (Typ); + First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ)); + The_Tag : constant Entity_Id := First_Tag_Component (Typ); + + Adjusted : Boolean := False; + Finalized : Boolean := False; + + Count_Prim : Nat; + DT_Length : Nat; + Nb_Prim : Nat; + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + + -- Start of processing for Set_All_DT_Position + + begin + pragma Assert (Present (First_Tag_Component (Typ))); + + -- Set the DT_Position for each primitive operation. Perform some sanity + -- checks to avoid building inconsistent dispatch tables. + + -- First stage: Set the DTC entity of all the primitive operations. This + -- is required to properly read the DT_Position attribute in the latter + -- stages. + + Prim_Elmt := First_Prim; + Count_Prim := 0; + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + -- Predefined primitives have a separate dispatch table + + if not (Is_Predefined_Dispatching_Operation (Prim) + or else + Is_Predefined_Dispatching_Alias (Prim)) + then + Count_Prim := Count_Prim + 1; + end if; + + Set_DTC_Entity_Value (Typ, Prim); + + -- Clear any previous value of the DT_Position attribute. In this + -- way we ensure that the final position of all the primitives is + -- established by the following stages of this algorithm. + + Set_DT_Position (Prim, No_Uint); + + Next_Elmt (Prim_Elmt); + end loop; + + declare + Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean := + (others => False); + + E : Entity_Id; + + procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id); + -- Called if Typ is declared in a nested package or a public child + -- package to handle inherited primitives that were inherited by Typ + -- in the visible part, but whose declaration was deferred because + -- the parent operation was private and not visible at that point. + + procedure Set_Fixed_Prim (Pos : Nat); + -- Sets to true an element of the Fixed_Prim table to indicate + -- that this entry of the dispatch table of Typ is occupied. + + ------------------------------------------ + -- Handle_Inherited_Private_Subprograms -- + ------------------------------------------ + + procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id) is + Op_List : Elist_Id; + Op_Elmt : Elmt_Id; + Op_Elmt_2 : Elmt_Id; + Prim_Op : Entity_Id; + Parent_Subp : Entity_Id; + + begin + Op_List := Primitive_Operations (Typ); + + Op_Elmt := First_Elmt (Op_List); + while Present (Op_Elmt) loop + Prim_Op := Node (Op_Elmt); + + -- Search primitives that are implicit operations with an + -- internal name whose parent operation has a normal name. + + if Present (Alias (Prim_Op)) + and then Find_Dispatching_Type (Alias (Prim_Op)) /= Typ + and then not Comes_From_Source (Prim_Op) + and then Is_Internal_Name (Chars (Prim_Op)) + and then not Is_Internal_Name (Chars (Alias (Prim_Op))) + then + Parent_Subp := Alias (Prim_Op); + + -- Check if the type has an explicit overriding for this + -- primitive. + + Op_Elmt_2 := Next_Elmt (Op_Elmt); + while Present (Op_Elmt_2) loop + if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp) + and then Type_Conformant (Prim_Op, Node (Op_Elmt_2)) + then + Set_DT_Position (Prim_Op, DT_Position (Parent_Subp)); + Set_DT_Position (Node (Op_Elmt_2), + DT_Position (Parent_Subp)); + Set_Fixed_Prim (UI_To_Int (DT_Position (Prim_Op))); + + goto Next_Primitive; + end if; + + Next_Elmt (Op_Elmt_2); + end loop; + end if; + + <> + Next_Elmt (Op_Elmt); + end loop; + end Handle_Inherited_Private_Subprograms; + + -------------------- + -- Set_Fixed_Prim -- + -------------------- + + procedure Set_Fixed_Prim (Pos : Nat) is + begin + pragma Assert (Pos <= Count_Prim); + Fixed_Prim (Pos) := True; + exception + when Constraint_Error => + raise Program_Error; + end Set_Fixed_Prim; + + begin + -- In case of nested packages and public child package it may be + -- necessary a special management on inherited subprograms so that + -- the dispatch table is properly filled. + + if Ekind (Scope (Scope (Typ))) = E_Package + and then Scope (Scope (Typ)) /= Standard_Standard + and then ((Is_Derived_Type (Typ) and then not Is_Private_Type (Typ)) + or else + (Nkind (Parent (Typ)) = N_Private_Extension_Declaration + and then Is_Generic_Type (Typ))) + and then In_Open_Scopes (Scope (Etype (Typ))) + and then Is_Base_Type (Typ) + then + Handle_Inherited_Private_Subprograms (Typ); + end if; + + -- Second stage: Register fixed entries + + Nb_Prim := 0; + Prim_Elmt := First_Prim; + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + -- Predefined primitives have a separate table and all its + -- entries are at predefined fixed positions. + + if Is_Predefined_Dispatching_Operation (Prim) then + Set_DT_Position (Prim, Default_Prim_Op_Position (Prim)); + + elsif Is_Predefined_Dispatching_Alias (Prim) then + Set_DT_Position (Prim, + Default_Prim_Op_Position (Ultimate_Alias (Prim))); + + -- Overriding primitives of ancestor abstract interfaces + + elsif Present (Interface_Alias (Prim)) + and then Is_Ancestor + (Find_Dispatching_Type (Interface_Alias (Prim)), Typ) + then + pragma Assert (DT_Position (Prim) = No_Uint + and then Present (DTC_Entity (Interface_Alias (Prim)))); + + E := Interface_Alias (Prim); + Set_DT_Position (Prim, DT_Position (E)); + + pragma Assert + (DT_Position (Alias (Prim)) = No_Uint + or else DT_Position (Alias (Prim)) = DT_Position (E)); + Set_DT_Position (Alias (Prim), DT_Position (E)); + Set_Fixed_Prim (UI_To_Int (DT_Position (Prim))); + + -- Overriding primitives must use the same entry as the + -- overridden primitive. + + elsif not Present (Interface_Alias (Prim)) + and then Present (Alias (Prim)) + and then Chars (Prim) = Chars (Alias (Prim)) + and then Find_Dispatching_Type (Alias (Prim)) /= Typ + and then Is_Ancestor + (Find_Dispatching_Type (Alias (Prim)), Typ) + and then Present (DTC_Entity (Alias (Prim))) + then + E := Alias (Prim); + Set_DT_Position (Prim, DT_Position (E)); + + if not Is_Predefined_Dispatching_Alias (E) then + Set_Fixed_Prim (UI_To_Int (DT_Position (E))); + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + -- Third stage: Fix the position of all the new primitives. + -- Entries associated with primitives covering interfaces + -- are handled in a latter round. + + Prim_Elmt := First_Prim; + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + -- Skip primitives previously set entries + + if DT_Position (Prim) /= No_Uint then + null; + + -- Primitives covering interface primitives are handled later + + elsif Present (Interface_Alias (Prim)) then + null; + + else + -- Take the next available position in the DT + + loop + Nb_Prim := Nb_Prim + 1; + pragma Assert (Nb_Prim <= Count_Prim); + exit when not Fixed_Prim (Nb_Prim); + end loop; + + Set_DT_Position (Prim, UI_From_Int (Nb_Prim)); + Set_Fixed_Prim (Nb_Prim); + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end; + + -- Fourth stage: Complete the decoration of primitives covering + -- interfaces (that is, propagate the DT_Position attribute + -- from the aliased primitive) + + Prim_Elmt := First_Prim; + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if DT_Position (Prim) = No_Uint + and then Present (Interface_Alias (Prim)) + then + pragma Assert (Present (Alias (Prim)) + and then Find_Dispatching_Type (Alias (Prim)) = Typ); + + -- Check if this entry will be placed in the primary DT + + if Is_Ancestor + (Find_Dispatching_Type (Interface_Alias (Prim)), Typ) + then + pragma Assert (DT_Position (Alias (Prim)) /= No_Uint); + Set_DT_Position (Prim, DT_Position (Alias (Prim))); + + -- Otherwise it will be placed in the secondary DT + + else + pragma Assert + (DT_Position (Interface_Alias (Prim)) /= No_Uint); + Set_DT_Position (Prim, + DT_Position (Interface_Alias (Prim))); + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + -- Generate listing showing the contents of the dispatch tables. + -- This action is done before some further static checks because + -- in case of critical errors caused by a wrong dispatch table + -- we need to see the contents of such table. + + if Debug_Flag_ZZ then + Write_DT (Typ); + end if; + + -- Final stage: Ensure that the table is correct plus some further + -- verifications concerning the primitives. + + Prim_Elmt := First_Prim; + DT_Length := 0; + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + -- At this point all the primitives MUST have a position + -- in the dispatch table. + + if DT_Position (Prim) = No_Uint then + raise Program_Error; + end if; + + -- Calculate real size of the dispatch table + + if not (Is_Predefined_Dispatching_Operation (Prim) + or else Is_Predefined_Dispatching_Alias (Prim)) + and then UI_To_Int (DT_Position (Prim)) > DT_Length + then + DT_Length := UI_To_Int (DT_Position (Prim)); + end if; + + -- Ensure that the assigned position to non-predefined + -- dispatching operations in the dispatch table is correct. + + if not (Is_Predefined_Dispatching_Operation (Prim) + or else Is_Predefined_Dispatching_Alias (Prim)) + then + Validate_Position (Prim); + end if; + + if Chars (Prim) = Name_Finalize then + Finalized := True; + end if; + + if Chars (Prim) = Name_Adjust then + Adjusted := True; + end if; + + -- An abstract operation cannot be declared in the private part for a + -- visible abstract type, because it can't be overridden outside this + -- package hierarchy. For explicit declarations this is checked at + -- the point of declaration, but for inherited operations it must be + -- done when building the dispatch table. + + -- Ada 2005 (AI-251): Primitives associated with interfaces are + -- excluded from this check because interfaces must be visible in + -- the public and private part (RM 7.3 (7.3/2)) + + -- We disable this check in CodePeer mode, to accommodate legacy + -- Ada code. + + if not CodePeer_Mode + and then Is_Abstract_Type (Typ) + and then Is_Abstract_Subprogram (Prim) + and then Present (Alias (Prim)) + and then not Is_Interface + (Find_Dispatching_Type (Ultimate_Alias (Prim))) + and then not Present (Interface_Alias (Prim)) + and then Is_Derived_Type (Typ) + and then In_Private_Part (Current_Scope) + and then + List_Containing (Parent (Prim)) = + Private_Declarations + (Specification (Unit_Declaration_Node (Current_Scope))) + and then Original_View_In_Visible_Part (Typ) + then + -- We exclude Input and Output stream operations because + -- Limited_Controlled inherits useless Input and Output + -- stream operations from Root_Controlled, which can + -- never be overridden. + + if not Is_TSS (Prim, TSS_Stream_Input) + and then + not Is_TSS (Prim, TSS_Stream_Output) + then + Error_Msg_NE + ("abstract inherited private operation&" & + " must be overridden (RM 3.9.3(10))", + Parent (Typ), Prim); + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + -- Additional check + + if Is_Controlled (Typ) then + if not Finalized then + Error_Msg_N + ("controlled type has no explicit Finalize method?", Typ); + + elsif not Adjusted then + Error_Msg_N + ("controlled type has no explicit Adjust method?", Typ); + end if; + end if; + + -- Set the final size of the Dispatch Table + + Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length)); + + -- The derived type must have at least as many components as its parent + -- (for root types Etype points to itself and the test cannot fail). + + if DT_Entry_Count (The_Tag) < + DT_Entry_Count (First_Tag_Component (Parent_Typ)) + then + raise Program_Error; + end if; + end Set_All_DT_Position; + + -------------------------- + -- Set_CPP_Constructors -- + -------------------------- + + procedure Set_CPP_Constructors (Typ : Entity_Id) is + + procedure Set_CPP_Constructors_Old (Typ : Entity_Id); + -- For backward compatibility this routine handles CPP constructors + -- of non-tagged types. + + procedure Set_CPP_Constructors_Old (Typ : Entity_Id) is + Loc : Source_Ptr; + Init : Entity_Id; + E : Entity_Id; + Found : Boolean := False; + P : Node_Id; + Parms : List_Id; + + begin + -- Look for the constructor entities + + E := Next_Entity (Typ); + while Present (E) loop + if Ekind (E) = E_Function + and then Is_Constructor (E) + then + -- Create the init procedure + + Found := True; + Loc := Sloc (E); + Init := Make_Defining_Identifier (Loc, + Make_Init_Proc_Name (Typ)); + Parms := + New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_X), + Parameter_Type => + New_Reference_To (Typ, Loc))); + + if Present (Parameter_Specifications (Parent (E))) then + P := First (Parameter_Specifications (Parent (E))); + while Present (P) loop + Append_To (Parms, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars (Defining_Identifier (P))), + Parameter_Type => + New_Copy_Tree (Parameter_Type (P)))); + Next (P); + end loop; + end if; + + Discard_Node ( + Make_Subprogram_Declaration (Loc, + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Init, + Parameter_Specifications => Parms))); + + Set_Init_Proc (Typ, Init); + Set_Is_Imported (Init); + Set_Interface_Name (Init, Interface_Name (E)); + Set_Convention (Init, Convention_C); + Set_Is_Public (Init); + Set_Has_Completion (Init); + end if; + + Next_Entity (E); + end loop; + + -- If there are no constructors, mark the type as abstract since we + -- won't be able to declare objects of that type. + + if not Found then + Set_Is_Abstract_Type (Typ); + end if; + end Set_CPP_Constructors_Old; + + -- Local variables + + Loc : Source_Ptr; + E : Entity_Id; + Found : Boolean := False; + P : Node_Id; + Parms : List_Id; + + Constructor_Decl_Node : Node_Id; + Constructor_Id : Entity_Id; + Wrapper_Id : Entity_Id; + Wrapper_Body_Node : Node_Id; + Actuals : List_Id; + Body_Stmts : List_Id; + Init_Tags_List : List_Id; + + begin + pragma Assert (Is_CPP_Class (Typ)); + + -- For backward compatibility the compiler accepts C++ classes + -- imported through non-tagged record types. In such case the + -- wrapper of the C++ constructor is useless because the _tag + -- component is not available. + + -- Example: + -- type Root is limited record ... + -- pragma Import (CPP, Root); + -- function New_Root return Root; + -- pragma CPP_Constructor (New_Root, ... ); + + if not Is_Tagged_Type (Typ) then + Set_CPP_Constructors_Old (Typ); + return; + end if; + + -- Look for the constructor entities + + E := Next_Entity (Typ); + while Present (E) loop + if Ekind (E) = E_Function + and then Is_Constructor (E) + then + Found := True; + Loc := Sloc (E); + + -- Generate the declaration of the imported C++ constructor + + Parms := + New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uInit), + Parameter_Type => + New_Reference_To (Typ, Loc))); + + if Present (Parameter_Specifications (Parent (E))) then + P := First (Parameter_Specifications (Parent (E))); + while Present (P) loop + Append_To (Parms, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars (Defining_Identifier (P))), + Parameter_Type => New_Copy_Tree (Parameter_Type (P)))); + Next (P); + end loop; + end if; + + Constructor_Id := Make_Temporary (Loc, 'P'); + + Constructor_Decl_Node := + Make_Subprogram_Declaration (Loc, + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Constructor_Id, + Parameter_Specifications => Parms)); + + Set_Is_Imported (Constructor_Id); + Set_Interface_Name (Constructor_Id, Interface_Name (E)); + Set_Convention (Constructor_Id, Convention_C); + Set_Is_Public (Constructor_Id); + Set_Has_Completion (Constructor_Id); + + -- Build the wrapper of this constructor + + Parms := + New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uInit), + Parameter_Type => + New_Reference_To (Typ, Loc))); + + if Present (Parameter_Specifications (Parent (E))) then + P := First (Parameter_Specifications (Parent (E))); + while Present (P) loop + Append_To (Parms, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars (Defining_Identifier (P))), + Parameter_Type => New_Copy_Tree (Parameter_Type (P)))); + Next (P); + end loop; + end if; + + Body_Stmts := New_List; + + -- Invoke the C++ constructor + + Actuals := New_List; + + P := First (Parms); + while Present (P) loop + Append_To (Actuals, + New_Reference_To (Defining_Identifier (P), Loc)); + Next (P); + end loop; + + Append_To (Body_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Constructor_Id, Loc), + Parameter_Associations => Actuals)); + + -- Initialize copies of C++ primary and secondary tags + + Init_Tags_List := New_List; + + declare + Tag_Elmt : Elmt_Id; + Tag_Comp : Node_Id; + + begin + Tag_Elmt := First_Elmt (Access_Disp_Table (Typ)); + Tag_Comp := First_Tag_Component (Typ); + + while Present (Tag_Elmt) + and then Is_Tag (Node (Tag_Elmt)) + loop + -- Skip the following assertion with primary tags because + -- Related_Type is not set on primary tag components + + pragma Assert (Tag_Comp = First_Tag_Component (Typ) + or else Related_Type (Node (Tag_Elmt)) + = Related_Type (Tag_Comp)); + + Append_To (Init_Tags_List, + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Node (Tag_Elmt), Loc), + Expression => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uInit), + Selector_Name => + New_Reference_To (Tag_Comp, Loc)))); + + Tag_Comp := Next_Tag_Component (Tag_Comp); + Next_Elmt (Tag_Elmt); + end loop; + end; + + Append_To (Body_Stmts, + Make_If_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Typ))), + Loc), + Right_Opnd => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (RTE (RE_Null_Address), Loc))), + Then_Statements => Init_Tags_List)); + + Wrapper_Id := Make_Defining_Identifier (Loc, + Make_Init_Proc_Name (Typ)); + + Wrapper_Body_Node := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Wrapper_Id, + Parameter_Specifications => Parms), + Declarations => New_List (Constructor_Decl_Node), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Body_Stmts, + Exception_Handlers => No_List)); + + Discard_Node (Wrapper_Body_Node); + Set_Init_Proc (Typ, Wrapper_Id); + end if; + + Next_Entity (E); + end loop; + + -- If there are no constructors, mark the type as abstract since we + -- won't be able to declare objects of that type. + + if not Found then + Set_Is_Abstract_Type (Typ); + end if; + + -- If the CPP type has constructors then it must import also the default + -- C++ constructor. It is required for default initialization of objects + -- of the type. It is also required to elaborate objects of Ada types + -- that are defined as derivations of this CPP type. + + if Has_CPP_Constructors (Typ) + and then No (Init_Proc (Typ)) + then + Error_Msg_N ("?default constructor must be imported from C++", Typ); + end if; + end Set_CPP_Constructors; + + -------------------------- + -- Set_DTC_Entity_Value -- + -------------------------- + + procedure Set_DTC_Entity_Value + (Tagged_Type : Entity_Id; + Prim : Entity_Id) + is + begin + if Present (Interface_Alias (Prim)) + and then Is_Interface + (Find_Dispatching_Type (Interface_Alias (Prim))) + then + Set_DTC_Entity (Prim, + Find_Interface_Tag + (T => Tagged_Type, + Iface => Find_Dispatching_Type (Interface_Alias (Prim)))); + else + Set_DTC_Entity (Prim, + First_Tag_Component (Tagged_Type)); + end if; + end Set_DTC_Entity_Value; + + ----------------- + -- Tagged_Kind -- + ----------------- + + function Tagged_Kind (T : Entity_Id) return Node_Id is + Conc_Typ : Entity_Id; + Loc : constant Source_Ptr := Sloc (T); + + begin + pragma Assert + (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind)); + + -- Abstract kinds + + if Is_Abstract_Type (T) then + if Is_Limited_Record (T) then + return New_Reference_To (RTE (RE_TK_Abstract_Limited_Tagged), Loc); + else + return New_Reference_To (RTE (RE_TK_Abstract_Tagged), Loc); + end if; + + -- Concurrent kinds + + elsif Is_Concurrent_Record_Type (T) then + Conc_Typ := Corresponding_Concurrent_Type (T); + + if Present (Full_View (Conc_Typ)) then + Conc_Typ := Full_View (Conc_Typ); + end if; + + if Ekind (Conc_Typ) = E_Protected_Type then + return New_Reference_To (RTE (RE_TK_Protected), Loc); + else + pragma Assert (Ekind (Conc_Typ) = E_Task_Type); + return New_Reference_To (RTE (RE_TK_Task), Loc); + end if; + + -- Regular tagged kinds + + else + if Is_Limited_Record (T) then + return New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc); + else + return New_Reference_To (RTE (RE_TK_Tagged), Loc); + end if; + end if; + end Tagged_Kind; + + -------------- + -- Write_DT -- + -------------- + + procedure Write_DT (Typ : Entity_Id) is + Elmt : Elmt_Id; + Prim : Node_Id; + + begin + -- Protect this procedure against wrong usage. Required because it will + -- be used directly from GDB + + if not (Typ <= Last_Node_Id) + or else not Is_Tagged_Type (Typ) + then + Write_Str ("wrong usage: Write_DT must be used with tagged types"); + Write_Eol; + return; + end if; + + Write_Int (Int (Typ)); + Write_Str (": "); + Write_Name (Chars (Typ)); + + if Is_Interface (Typ) then + Write_Str (" is interface"); + end if; + + Write_Eol; + + Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Elmt) loop + Prim := Node (Elmt); + Write_Str (" - "); + + -- Indicate if this primitive will be allocated in the primary + -- dispatch table or in a secondary dispatch table associated + -- with an abstract interface type + + if Present (DTC_Entity (Prim)) then + if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then + Write_Str ("[P] "); + else + Write_Str ("[s] "); + end if; + end if; + + -- Output the node of this primitive operation and its name + + Write_Int (Int (Prim)); + Write_Str (": "); + + if Is_Predefined_Dispatching_Operation (Prim) then + Write_Str ("(predefined) "); + end if; + + -- Prefix the name of the primitive with its corresponding tagged + -- type to facilitate seeing inherited primitives. + + if Present (Alias (Prim)) then + Write_Name + (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim)))); + else + Write_Name (Chars (Typ)); + end if; + + Write_Str ("."); + Write_Name (Chars (Prim)); + + -- Indicate if this primitive has an aliased primitive + + if Present (Alias (Prim)) then + Write_Str (" (alias = "); + Write_Int (Int (Alias (Prim))); + + -- If the DTC_Entity attribute is already set we can also output + -- the name of the interface covered by this primitive (if any). + + if Present (DTC_Entity (Alias (Prim))) + and then Is_Interface (Scope (DTC_Entity (Alias (Prim)))) + then + Write_Str (" from interface "); + Write_Name (Chars (Scope (DTC_Entity (Alias (Prim))))); + end if; + + if Present (Interface_Alias (Prim)) then + Write_Str (", AI_Alias of "); + + if Is_Null_Interface_Primitive (Interface_Alias (Prim)) then + Write_Str ("null primitive "); + end if; + + Write_Name + (Chars (Find_Dispatching_Type (Interface_Alias (Prim)))); + Write_Char (':'); + Write_Int (Int (Interface_Alias (Prim))); + end if; + + Write_Str (")"); + end if; + + -- Display the final position of this primitive in its associated + -- (primary or secondary) dispatch table + + if Present (DTC_Entity (Prim)) + and then DT_Position (Prim) /= No_Uint + then + Write_Str (" at #"); + Write_Int (UI_To_Int (DT_Position (Prim))); + end if; + + if Is_Abstract_Subprogram (Prim) then + Write_Str (" is abstract;"); + + -- Check if this is a null primitive + + elsif Comes_From_Source (Prim) + and then Ekind (Prim) = E_Procedure + and then Null_Present (Parent (Prim)) + then + Write_Str (" is null;"); + end if; + + if Is_Eliminated (Ultimate_Alias (Prim)) then + Write_Str (" (eliminated)"); + end if; + + if Is_Imported (Prim) + and then Convention (Prim) = Convention_CPP + then + Write_Str (" (C++)"); + end if; + + Write_Eol; + + Next_Elmt (Elmt); + end loop; + end Write_DT; + +end Exp_Disp; diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads new file mode 100644 index 000000000..d2dd7760d --- /dev/null +++ b/gcc/ada/exp_disp.ads @@ -0,0 +1,391 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ D I S P -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 involved in tagged types and dynamic +-- dispatching expansion. + +with Types; use Types; + +package Exp_Disp is + + ------------------------------------- + -- Predefined primitive operations -- + ------------------------------------- + + -- The predefined primitive operations (PPOs) are subprograms generated + -- by GNAT for a particular tagged type. Their role is to provide support + -- for different Ada language features such as the attribute 'Size or + -- handling of dispatching triggers in select statements. PPOs are created + -- when a tagged type is expanded or frozen. These subprograms are later + -- collected and inserted into the dispatch table of a tagged type at + -- fixed positions. Some of the PPOs that manipulate data in tagged objects + -- require the generation of thunks. + + -- List of predefined primitive operations + + -- Leading underscores designate reserved names. Bracketed numerical + -- values represent dispatch table slot numbers. + + -- _Size (1) - implementation of the attribute 'Size for any tagged + -- type. Constructs of the form Prefix'Size are converted into + -- Prefix._Size. + + -- _Alignment (2) - implementation of the attribute 'Alignment for + -- any tagged type. Constructs of the form Prefix'Alignment are + -- converted into Prefix._Alignment. + + -- TSS_Stream_Read (3) - implementation of the stream attribute Read + -- for any tagged type. + + -- TSS_Stream_Write (4) - implementation of the stream attribute Write + -- for any tagged type. + + -- TSS_Stream_Input (5) - implementation of the stream attribute Input + -- for any tagged type. + + -- TSS_Stream_Output (6) - implementation of the stream attribute + -- Output for any tagged type. + + -- Op_Eq (7) - implementation of the equality operator for any non- + -- limited tagged type. + + -- _Assign (8) - implementation of the assignment operator for any + -- non-limited tagged type. + + -- TSS_Deep_Adjust (9) - implementation of the finalization operation + -- Adjust for any non-limited tagged type. + + -- TSS_Deep_Finalize (10) - implementation of the finalization + -- operation Finalize for any non-limited tagged type. + + -- _Disp_Asynchronous_Select (11) - used in the expansion of ATC with + -- dispatching triggers. Null implementation for limited interfaces, + -- full body generation for types that implement limited interfaces, + -- not generated for the rest of the cases. See Expand_N_Asynchronous_ + -- Select in Exp_Ch9 for more information. + + -- _Disp_Conditional_Select (12) - used in the expansion of conditional + -- selects with dispatching triggers. Null implementation for limited + -- interfaces, full body generation for types that implement limited + -- interfaces, not generated for the rest of the cases. See Expand_N_ + -- Conditional_Entry_Call in Exp_Ch9 for more information. + + -- _Disp_Get_Prim_Op_Kind (13) - helper routine used in the expansion + -- of ATC with dispatching triggers. Null implementation for limited + -- interfaces, full body generation for types that implement limited + -- interfaces, not generated for the rest of the cases. + + -- _Disp_Get_Task_Id (14) - helper routine used in the expansion of + -- Abort, attributes 'Callable and 'Terminated for task interface + -- class-wide types. Full body generation for task types, null + -- implementation for limited interfaces, not generated for the rest + -- of the cases. See Expand_N_Attribute_Reference in Exp_Attr and + -- Expand_N_Abort_Statement in Exp_Ch9 for more information. + + -- _Disp_Requeue (15) - used in the expansion of dispatching requeue + -- statements. Null implementation is provided for protected, task + -- and synchronized interfaces. Protected and task types implementing + -- concurrent interfaces receive full bodies. See Expand_N_Requeue_ + -- Statement in Exp_Ch9 for more information. + + -- _Disp_Timed_Select (16) - used in the expansion of timed selects + -- with dispatching triggers. Null implementation for limited + -- interfaces, full body generation for types that implement limited + -- interfaces, not generated for the rest of the cases. See Expand_N_ + -- Timed_Entry_Call for more information. + + -- Life cycle of predefined primitive operations + + -- The specifications and bodies of the PPOs are created by + -- Make_Predefined_Primitive_Specs and Predefined_Primitive_Bodies + -- in Exp_Ch3. The generated specifications are immediately analyzed, + -- while the bodies are left as freeze actions to the tagged type for + -- which they are created. + + -- PPOs are collected and added to the Primitive_Operations list of + -- a type by the regular analysis mechanism. + + -- PPOs are frozen by Exp_Ch3.Predefined_Primitive_Freeze + + -- Thunks for PPOs are created by Make_DT + + -- Dispatch table positions of PPOs are set by Set_All_DT_Position + + -- Calls to PPOs proceed as regular dispatching calls. If the PPO + -- has a thunk, a call proceeds as a regular dispatching call with + -- a thunk. + + -- Guidelines for addition of new predefined primitive operations + + -- Update the value of constant Max_Predef_Prims in a-tags.ads to + -- indicate the new number of PPOs. + + -- Introduce a new predefined name for the new PPO in Snames.ads and + -- Snames.adb. + + -- Categorize the new PPO name as predefined by adding an entry in + -- Is_Predefined_Dispatching_Operation in Exp_Disp. + + -- Generate the specification of the new PPO in Make_Predefined_ + -- Primitive_Spec in Exp_Ch3.adb. The Is_Internal flag of the defining + -- identifier of the specification must be set to True. + + -- Generate the body of the new PPO in Predefined_Primitive_Bodies in + -- Exp_Ch3.adb. The Is_Internal flag of the defining identifier of the + -- specification must be set to True. + + -- If the new PPO requires a thunk, add an entry in Freeze_Subprogram + -- in Exp_Ch6.adb. + + -- When generating calls to a PPO, use Find_Prim_Op from Exp_Util.ads + -- to retrieve the entity of the operation directly. + + -- Number of predefined primitive operations added by the Expander + -- for a tagged type. If more predefined primitive operations are + -- added, the following items must be changed: + + -- Ada.Tags.Max_Predef_Prims - indirect use + -- Exp_Disp.Default_Prim_Op_Position - indirect use + -- Exp_Disp.Set_All_DT_Position - direct use + + procedure Apply_Tag_Checks (Call_Node : Node_Id); + -- Generate checks required on dispatching calls + + function Building_Static_DT (Typ : Entity_Id) return Boolean; + pragma Inline (Building_Static_DT); + -- Returns true when building statically allocated dispatch tables + + procedure Build_Static_Dispatch_Tables (N : Node_Id); + -- N is a library level package declaration or package body. Build the + -- static dispatch table of the tagged types defined at library level. In + -- case of package declarations with private part the generated nodes are + -- added at the end of the list of private declarations. Otherwise they are + -- added to the end of the list of public declarations. In case of package + -- bodies they are added to the end of the list of declarations of the + -- package body. + + function Convert_Tag_To_Interface + (Typ : Entity_Id; Expr : Node_Id) return Node_Id; + pragma Inline (Convert_Tag_To_Interface); + -- This function is used in class-wide interface conversions; the expanded + -- code generated to convert a tagged object to a class-wide interface type + -- involves referencing the tag component containing the secondary dispatch + -- table associated with the interface. Given the expression Expr that + -- references a tag component, we cannot generate an unchecked conversion + -- to leave the expression decorated with the class-wide interface type Typ + -- because an unchecked conversion cannot be seen as a no-op. An unchecked + -- conversion is conceptually a function call and therefore the RM allows + -- the backend to obtain a copy of the value of the actual object and store + -- it in some other place (like a register); in such case the interface + -- conversion is not equivalent to a displacement of the pointer to the + -- interface and any further displacement fails. Although the functionality + -- of this function is simple and could be done directly, the purpose of + -- this routine is to leave well documented in the sources these + -- occurrences. + + -- If Expr is an N_Selected_Component that references a tag generate: + -- type ityp is non null access Typ; + -- ityp!(Expr'Address).all + + -- if Expr is an N_Function_Call to Ada.Tags.Displace then generate: + -- type ityp is non null access Typ; + -- ityp!(Expr).all + + function CPP_Num_Prims (Typ : Entity_Id) return Nat; + -- Return the number of primitives of the C++ part of the dispatch table. + -- For types that are not derivations of CPP types return 0. + + procedure Expand_Dispatching_Call (Call_Node : Node_Id); + -- Expand the call to the operation through the dispatch table and perform + -- the required tag checks when appropriate. For CPP types tag checks are + -- not relevant. + + procedure Expand_Interface_Actuals (Call_Node : Node_Id); + -- Ada 2005 (AI-251): Displace all the actuals corresponding to class-wide + -- interfaces to reference the interface tag of the actual object + + procedure Expand_Interface_Conversion + (N : Node_Id; + Is_Static : Boolean := True); + -- Ada 2005 (AI-251): N is a type-conversion node. Reference the base of + -- the object to give access to the interface tag associated with the + -- secondary dispatch table. + + procedure Expand_Interface_Thunk + (Prim : Node_Id; + Thunk_Id : out Entity_Id; + Thunk_Code : out Node_Id); + -- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we + -- generate additional subprograms (thunks) associated with each primitive + -- Prim to have a layout compatible with the C++ ABI. The thunk displaces + -- the pointers to the actuals that depend on the controlling type before + -- transferring control to the target subprogram. If there is no need to + -- generate the thunk then Thunk_Id and Thunk_Code are set to Empty. + -- Otherwise they are set to the defining identifier and the subprogram + -- body of the generated thunk. + + function Has_CPP_Constructors (Typ : Entity_Id) return Boolean; + -- Returns true if the type has CPP constructors + + function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean; + -- Ada 2005 (AI-251): Determines if E is a predefined primitive operation + + function Is_Predefined_Internal_Operation (E : Entity_Id) return Boolean; + -- Similar to the previous one, but excludes stream operations, because + -- these may be overridden, and need extra formals, like user-defined + -- operations. + + function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean; + -- Ada 2005 (AI-345): Returns True if E is one of the predefined primitives + -- required to implement interfaces. + + function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id; + -- Expand the declarations for the Dispatch Table. The node N is the + -- declaration that forces the generation of the table. It is used to place + -- error messages when the declaration leads to the freezing of a given + -- primitive operation that has an incomplete non- tagged formal. + + function Make_Disp_Asynchronous_Select_Body + (Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Generate the body of the primitive operation of type + -- Typ used for dispatching in asynchronous selects. Generate a null body + -- if Typ is an interface type. + + function Make_Disp_Asynchronous_Select_Spec + (Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Generate the specification of the primitive operation + -- of type Typ used for dispatching in asynchronous selects. + + function Make_Disp_Conditional_Select_Body + (Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Generate the body of the primitive operation of type + -- Typ used for dispatching in conditional selects. Generate a null body + -- if Typ is an interface type. + + function Make_Disp_Conditional_Select_Spec + (Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Generate the specification of the primitive operation + -- of type Typ used for dispatching in conditional selects. + + function Make_Disp_Get_Prim_Op_Kind_Body + (Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Generate the body of the primitive operation of type + -- Typ used for retrieving the callable entity kind during dispatching in + -- asynchronous selects. Generate a null body if Typ is an interface type. + + function Make_Disp_Get_Prim_Op_Kind_Spec + (Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Generate the specification of the primitive operation + -- of the type Typ use for retrieving the callable entity kind during + -- dispatching in asynchronous selects. + + function Make_Disp_Get_Task_Id_Body + (Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Generate body of the primitive operation of type Typ + -- used for retrieving the _task_id field of a task interface class- wide + -- type. Generate a null body if Typ is an interface or a non-task type. + + function Make_Disp_Get_Task_Id_Spec + (Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Generate the specification of the primitive operation + -- of type Typ used for retrieving the _task_id field of a task interface + -- class-wide type. + + function Make_Disp_Requeue_Body + (Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI05-0030): Generate the body of the primitive operation of + -- type Typ used for dispatching on requeue statements. Generate a body + -- containing a single null-statement if Typ is an interface type. + + function Make_Disp_Requeue_Spec + (Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI05-0030): Generate the specification of the primitive + -- operation of type Typ used for dispatching requeue statements. + + function Make_Disp_Timed_Select_Body + (Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Generate the body of the primitive operation of type + -- Typ used for dispatching in timed selects. Generate a body containing + -- a single null-statement if Typ is an interface type. + + function Make_Disp_Timed_Select_Spec + (Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Generate the specification of the primitive operation + -- of type Typ used for dispatching in timed selects. + + function Make_Select_Specific_Data_Table + (Typ : Entity_Id) return List_Id; + -- Ada 2005 (AI-345): Create and populate the auxiliary table in the TSD + -- of Typ used for dispatching in asynchronous, conditional and timed + -- selects. Generate code to set the primitive operation kinds and entry + -- indexes of primitive operations and primitive wrappers. + + function Make_Tags (Typ : Entity_Id) return List_Id; + -- Generate the entities associated with the primary and secondary tags of + -- Typ and fill the contents of Access_Disp_Table. In case of library level + -- tagged types this routine imports the forward declaration of the tag + -- entity, that will be declared and exported by Make_DT. + + function Register_Primitive + (Loc : Source_Ptr; + Prim : Entity_Id) return List_Id; + -- Build code to register Prim in the primary or secondary dispatch table. + -- If Prim is associated with a secondary dispatch table then generate also + -- its thunk and register it in the associated secondary dispatch table. + -- In general the dispatch tables are always generated by Make_DT and + -- Make_Secondary_DT; this routine is only used in two corner cases: + -- + -- 1) To construct the dispatch table of a tagged type whose parent + -- is a CPP_Class (see Build_Init_Procedure). + -- 2) To handle late overriding of dispatching operations (see + -- Check_Dispatching_Operation and Make_DT). + -- + -- The caller is responsible for inserting the generated code in the + -- proper place. + + procedure Set_All_DT_Position (Typ : Entity_Id); + -- Set the DT_Position field for each primitive operation. In the CPP + -- Class case check that no pragma CPP_Virtual is missing and that the + -- DT_Position are coherent + + procedure Set_CPP_Constructors (Typ : Entity_Id); + -- Typ is a CPP_Class type. Create the Init procedures of that type + -- required to handle its default and non-default constructors. The + -- functions to which pragma CPP_Constructor is applied in the sources + -- are functions returning this type, and having an implicit access to the + -- target object in its first argument; such implicit argument is explicit + -- in the IP procedures built here. + + procedure Set_DTC_Entity_Value + (Tagged_Type : Entity_Id; + Prim : Entity_Id); + -- Set the definite value of the DTC_Entity value associated with a given + -- primitive of a tagged type. + + procedure Write_DT (Typ : Entity_Id); + pragma Export (Ada, Write_DT); + -- Debugging procedure (to be called within gdb) + +end Exp_Disp; diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb new file mode 100644 index 000000000..82d5898bd --- /dev/null +++ b/gcc/ada/exp_dist.adb @@ -0,0 +1,11604 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P_ D I S T -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Elists; use Elists; +with Exp_Atag; use Exp_Atag; +with Exp_Disp; use Exp_Disp; +with Exp_Strm; use Exp_Strm; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Lib; use Lib; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Cat; use Sem_Cat; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch12; use Sem_Ch12; +with Sem_Dist; use Sem_Dist; +with Sem_Eval; use Sem_Eval; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Stand; use Stand; +with Stringt; use Stringt; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; + +with GNAT.HTable; use GNAT.HTable; + +package body Exp_Dist is + + -- The following model has been used to implement distributed objects: + -- given a designated type D and a RACW type R, then a record of the form: + + -- type Stub is tagged record + -- [...declaration similar to s-parint.ads RACW_Stub_Type...] + -- end record; + + -- is built. This type has two properties: + + -- 1) Since it has the same structure as RACW_Stub_Type, it can + -- be converted to and from this type to make it suitable for + -- System.Partition_Interface.Get_Unique_Remote_Pointer in order + -- to avoid memory leaks when the same remote object arrives on the + -- same partition through several paths; + + -- 2) It also has the same dispatching table as the designated type D, + -- and thus can be used as an object designated by a value of type + -- R on any partition other than the one on which the object has + -- been created, since only dispatching calls will be performed and + -- the fields themselves will not be used. We call Derive_Subprograms + -- to fake half a derivation to ensure that the subprograms do have + -- the same dispatching table. + + First_RCI_Subprogram_Id : constant := 2; + -- RCI subprograms are numbered starting at 2. The RCI receiver for + -- an RCI package can thus identify calls received through remote + -- access-to-subprogram dereferences by the fact that they have a + -- (primitive) subprogram id of 0, and 1 is used for the internal RAS + -- information lookup operation. (This is for the Garlic code generation, + -- where subprograms are identified by numbers; in the PolyORB version, + -- they are identified by name, with a numeric suffix for homonyms.) + + type Hash_Index is range 0 .. 50; + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Hash (F : Entity_Id) return Hash_Index; + -- DSA expansion associates stubs to distributed object types using a hash + -- table on entity ids. + + function Hash (F : Name_Id) return Hash_Index; + -- The generation of subprogram identifiers requires an overload counter + -- to be associated with each remote subprogram name. These counters are + -- maintained in a hash table on name ids. + + type Subprogram_Identifiers is record + Str_Identifier : String_Id; + Int_Identifier : Int; + end record; + + package Subprogram_Identifier_Table is + new Simple_HTable (Header_Num => Hash_Index, + Element => Subprogram_Identifiers, + No_Element => (No_String, 0), + Key => Entity_Id, + Hash => Hash, + Equal => "="); + -- Mapping between a remote subprogram and the corresponding subprogram + -- identifiers. + + package Overload_Counter_Table is + new Simple_HTable (Header_Num => Hash_Index, + Element => Int, + No_Element => 0, + Key => Name_Id, + Hash => Hash, + Equal => "="); + -- Mapping between a subprogram name and an integer that counts the number + -- of defining subprogram names with that Name_Id encountered so far in a + -- given context (an interface). + + function Get_Subprogram_Ids (Def : Entity_Id) return Subprogram_Identifiers; + function Get_Subprogram_Id (Def : Entity_Id) return String_Id; + function Get_Subprogram_Id (Def : Entity_Id) return Int; + -- Given a subprogram defined in a RCI package, get its distribution + -- subprogram identifiers (the distribution identifiers are a unique + -- subprogram number, and the non-qualified subprogram name, in the + -- casing used for the subprogram declaration; if the name is overloaded, + -- a double underscore and a serial number are appended. + -- + -- The integer identifier is used to perform remote calls with GARLIC; + -- the string identifier is used in the case of PolyORB. + -- + -- Although the PolyORB DSA receiving stubs will make a caseless comparison + -- when receiving a call, the calling stubs will create requests with the + -- exact casing of the defining unit name of the called subprogram, so as + -- to allow calls to subprograms on distributed nodes that do distinguish + -- between casings. + -- + -- NOTE: Another design would be to allow a representation clause on + -- subprogram specs: for Subp'Distribution_Identifier use "fooBar"; + + pragma Warnings (Off, Get_Subprogram_Id); + -- One homonym only is unreferenced (specific to the GARLIC version) + + procedure Add_RAS_Dereference_TSS (N : Node_Id); + -- Add a subprogram body for RAS Dereference TSS + + procedure Add_RAS_Proxy_And_Analyze + (Decls : List_Id; + Vis_Decl : Node_Id; + All_Calls_Remote_E : Entity_Id; + Proxy_Object_Addr : out Entity_Id); + -- Add the proxy type required, on the receiving (server) side, to handle + -- calls to the subprogram declared by Vis_Decl through a remote access + -- to subprogram type. All_Calls_Remote_E must be Standard_True if a pragma + -- All_Calls_Remote applies, Standard_False otherwise. The new proxy type + -- is appended to Decls. Proxy_Object_Addr is a constant of type + -- System.Address that designates an instance of the proxy object. + + function Build_Remote_Subprogram_Proxy_Type + (Loc : Source_Ptr; + ACR_Expression : Node_Id) return Node_Id; + -- Build and return a tagged record type definition for an RCI subprogram + -- proxy type. ACR_Expression is used as the initialization value for the + -- All_Calls_Remote component. + + function Build_Get_Unique_RP_Call + (Loc : Source_Ptr; + Pointer : Entity_Id; + Stub_Type : Entity_Id) return List_Id; + -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a + -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to + -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type). + + function Build_Stub_Tag + (Loc : Source_Ptr; + RACW_Type : Entity_Id) return Node_Id; + -- Return an expression denoting the tag of the stub type associated with + -- RACW_Type. + + function Build_Subprogram_Calling_Stubs + (Vis_Decl : Node_Id; + Subp_Id : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Locator : Entity_Id := Empty; + New_Name : Name_Id := No_Name) return Node_Id; + -- Build the calling stub for a given subprogram with the subprogram ID + -- being Subp_Id. If Stub_Type is given, then the "addr" field of + -- parameters of this type will be marshalled instead of the object itself. + -- It will then be converted into Stub_Type before performing the real + -- call. If Dynamically_Asynchronous is True, then it will be computed at + -- run time whether the call is asynchronous or not. Otherwise, the value + -- of the formal Asynchronous will be used. If Locator is not Empty, it + -- will be used instead of RCI_Cache. If New_Name is given, then it will + -- be used instead of the original name. + + function Build_RPC_Receiver_Specification + (RPC_Receiver : Entity_Id; + Request_Parameter : Entity_Id) return Node_Id; + -- Make a subprogram specification for an RPC receiver, with the given + -- defining unit name and formal parameter. + + function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id; + -- Return an ordered parameter list: unconstrained parameters are put + -- at the beginning of the list and constrained ones are put after. If + -- there are no parameters, an empty list is returned. Special case: + -- the controlling formal of the equivalent RACW operation for a RAS + -- type is always left in first position. + + function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean; + -- True when Typ is an unconstrained type, or a null-excluding access type. + -- In either case, this means stubs cannot contain a default-initialized + -- object declaration of such type. + + procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id); + -- Add calling stubs to the declarative part + + function Could_Be_Asynchronous (Spec : Node_Id) return Boolean; + -- Return True if nothing prevents the program whose specification is + -- given to be asynchronous (i.e. no [IN] OUT parameters). + + function Pack_Entity_Into_Stream_Access + (Loc : Source_Ptr; + Stream : Node_Id; + Object : Entity_Id; + Etyp : Entity_Id := Empty) return Node_Id; + -- Pack Object (of type Etyp) into Stream. If Etyp is not given, + -- then Etype (Object) will be used if present. If the type is + -- constrained, then 'Write will be used to output the object, + -- If the type is unconstrained, 'Output will be used. + + function Pack_Node_Into_Stream + (Loc : Source_Ptr; + Stream : Entity_Id; + Object : Node_Id; + Etyp : Entity_Id) return Node_Id; + -- Similar to above, with an arbitrary node instead of an entity + + function Pack_Node_Into_Stream_Access + (Loc : Source_Ptr; + Stream : Node_Id; + Object : Node_Id; + Etyp : Entity_Id) return Node_Id; + -- Similar to above, with Stream instead of Stream'Access + + function Make_Selected_Component + (Loc : Source_Ptr; + Prefix : Entity_Id; + Selector_Name : Name_Id) return Node_Id; + -- Return a selected_component whose prefix denotes the given entity, and + -- with the given Selector_Name. + + function Scope_Of_Spec (Spec : Node_Id) return Entity_Id; + -- Return the scope represented by a given spec + + procedure Set_Renaming_TSS + (Typ : Entity_Id; + Nam : Entity_Id; + TSS_Nam : TSS_Name_Type); + -- Create a renaming declaration of subprogram Nam, and register it as a + -- TSS for Typ with name TSS_Nam. + + function Need_Extra_Constrained (Parameter : Node_Id) return Boolean; + -- Return True if the current parameter needs an extra formal to reflect + -- its constrained status. + + function Is_RACW_Controlling_Formal + (Parameter : Node_Id; + Stub_Type : Entity_Id) return Boolean; + -- Return True if the current parameter is a controlling formal argument + -- of type Stub_Type or access to Stub_Type. + + procedure Declare_Create_NVList + (Loc : Source_Ptr; + NVList : Entity_Id; + Decls : List_Id; + Stmts : List_Id); + -- Append the declaration of NVList to Decls, and its + -- initialization to Stmts. + + function Add_Parameter_To_NVList + (Loc : Source_Ptr; + NVList : Entity_Id; + Parameter : Entity_Id; + Constrained : Boolean; + RACW_Ctrl : Boolean := False; + Any : Entity_Id) return Node_Id; + -- Return a call to Add_Item to add the Any corresponding to the designated + -- formal Parameter (with the indicated Constrained status) to NVList. + -- RACW_Ctrl must be set to True for controlling formals of distributed + -- object primitive operations. + + -------------------- + -- Stub_Structure -- + -------------------- + + -- This record describes various tree fragments associated with the + -- generation of RACW calling stubs. One such record exists for every + -- distributed object type, i.e. each tagged type that is the designated + -- type of one or more RACW type. + + type Stub_Structure is record + Stub_Type : Entity_Id; + -- Stub type: this type has the same primitive operations as the + -- designated types, but the provided bodies for these operations + -- a remote call to an actual target object potentially located on + -- another partition; each value of the stub type encapsulates a + -- reference to a remote object. + + Stub_Type_Access : Entity_Id; + -- A local access type designating the stub type (this is not an RACW + -- type). + + RPC_Receiver_Decl : Node_Id; + -- Declaration for the RPC receiver entity associated with the + -- designated type. As an exception, for the case of an RACW that + -- implements a RAS, no object RPC receiver is generated. Instead, + -- RPC_Receiver_Decl is the declaration after which the RPC receiver + -- would have been inserted. + + Body_Decls : List_Id; + -- List of subprogram bodies to be included in generated code: bodies + -- for the RACW's stream attributes, and for the primitive operations + -- of the stub type. + + RACW_Type : Entity_Id; + -- One of the RACW types designating this distributed object type + -- (they are all interchangeable; we use any one of them in order to + -- avoid having to create various anonymous access types). + + end record; + + Empty_Stub_Structure : constant Stub_Structure := + (Empty, Empty, Empty, No_List, Empty); + + package Stubs_Table is + new Simple_HTable (Header_Num => Hash_Index, + Element => Stub_Structure, + No_Element => Empty_Stub_Structure, + Key => Entity_Id, + Hash => Hash, + Equal => "="); + -- Mapping between a RACW designated type and its stub type + + package Asynchronous_Flags_Table is + new Simple_HTable (Header_Num => Hash_Index, + Element => Entity_Id, + No_Element => Empty, + Key => Entity_Id, + Hash => Hash, + Equal => "="); + -- Mapping between a RACW type and a constant having the value True + -- if the RACW is asynchronous and False otherwise. + + package RCI_Locator_Table is + new Simple_HTable (Header_Num => Hash_Index, + Element => Entity_Id, + No_Element => Empty, + Key => Entity_Id, + Hash => Hash, + Equal => "="); + -- Mapping between a RCI package on which All_Calls_Remote applies and + -- the generic instantiation of RCI_Locator for this package. + + package RCI_Calling_Stubs_Table is + new Simple_HTable (Header_Num => Hash_Index, + Element => Entity_Id, + No_Element => Empty, + Key => Entity_Id, + Hash => Hash, + Equal => "="); + -- Mapping between a RCI subprogram and the corresponding calling stubs + + function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure; + -- Return the stub information associated with the given RACW type + + procedure Add_Stub_Type + (Designated_Type : Entity_Id; + RACW_Type : Entity_Id; + Decls : List_Id; + Stub_Type : out Entity_Id; + Stub_Type_Access : out Entity_Id; + RPC_Receiver_Decl : out Node_Id; + Body_Decls : out List_Id; + Existing : out Boolean); + -- Add the declaration of the stub type, the access to stub type and the + -- object RPC receiver at the end of Decls. If these already exist, + -- then nothing is added in the tree but the right values are returned + -- anyhow and Existing is set to True. + + function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id; + -- Retrieve the Body_Decls list associated to RACW_Type in the stub + -- structure table, reset it to No_List, and return the previous value. + + procedure Add_RACW_Asynchronous_Flag + (Declarations : List_Id; + RACW_Type : Entity_Id); + -- Declare a boolean constant associated with RACW_Type whose value + -- indicates at run time whether a pragma Asynchronous applies to it. + + procedure Assign_Subprogram_Identifier + (Def : Entity_Id; + Spn : Int; + Id : out String_Id); + -- Determine the distribution subprogram identifier to + -- be used for remote subprogram Def, return it in Id and + -- store it in a hash table for later retrieval by + -- Get_Subprogram_Id. Spn is the subprogram number. + + function RCI_Package_Locator + (Loc : Source_Ptr; + Package_Spec : Node_Id) return Node_Id; + -- Instantiate the generic package RCI_Locator in order to locate the + -- RCI package whose spec is given as argument. + + function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id; + -- Surround a node N by a tag check, as in: + -- begin + -- ; + -- exception + -- when E : Ada.Tags.Tag_Error => + -- Raise_Exception (Program_Error'Identity, + -- Exception_Message (E)); + -- end; + + function Input_With_Tag_Check + (Loc : Source_Ptr; + Var_Type : Entity_Id; + Stream : Node_Id) return Node_Id; + -- Return a function with the following form: + -- function R return Var_Type is + -- begin + -- return Var_Type'Input (S); + -- exception + -- when E : Ada.Tags.Tag_Error => + -- Raise_Exception (Program_Error'Identity, + -- Exception_Message (E)); + -- end R; + + procedure Build_Actual_Object_Declaration + (Object : Entity_Id; + Etyp : Entity_Id; + Variable : Boolean; + Expr : Node_Id; + Decls : List_Id); + -- Build the declaration of an object with the given defining identifier, + -- initialized with Expr if provided, to serve as actual parameter in a + -- server stub. If Variable is true, the declared object will be a variable + -- (case of an out or in out formal), else it will be a constant. Object's + -- Ekind is set accordingly. The declaration, as well as any other + -- declarations it requires, are appended to Decls. + + -------------------------------------------- + -- Hooks for PCS-specific code generation -- + -------------------------------------------- + + -- Part of the code generation circuitry for distribution needs to be + -- tailored for each implementation of the PCS. For each routine that + -- needs to be specialized, a Specific_ wrapper is created, + -- which calls the corresponding in package + -- _Support. + + procedure Specific_Add_RACW_Features + (RACW_Type : Entity_Id; + Desig : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver_Decl : Node_Id; + Body_Decls : List_Id); + -- Add declaration for TSSs for a given RACW type. The declarations are + -- added just after the declaration of the RACW type itself. If the RACW + -- appears in the main unit, Body_Decls is a list of declarations to which + -- the bodies are appended. Else Body_Decls is No_List. + -- PCS-specific ancillary subprogram for Add_RACW_Features. + + procedure Specific_Add_RAST_Features + (Vis_Decl : Node_Id; + RAS_Type : Entity_Id); + -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary + -- subprogram for Add_RAST_Features. + + -- An RPC_Target record is used during construction of calling stubs + -- to pass PCS-specific tree fragments corresponding to the information + -- necessary to locate the target of a remote subprogram call. + + type RPC_Target (PCS_Kind : PCS_Names) is record + case PCS_Kind is + when Name_PolyORB_DSA => + Object : Node_Id; + -- An expression whose value is a PolyORB reference to the target + -- object. + + when others => + Partition : Entity_Id; + -- A variable containing the Partition_ID of the target partition + + RPC_Receiver : Node_Id; + -- An expression whose value is the address of the target RPC + -- receiver. + end case; + end record; + + procedure Specific_Build_General_Calling_Stubs + (Decls : List_Id; + Statements : List_Id; + Target : RPC_Target; + Subprogram_Id : Node_Id; + Asynchronous : Node_Id := Empty; + Is_Known_Asynchronous : Boolean := False; + Is_Known_Non_Asynchronous : Boolean := False; + Is_Function : Boolean; + Spec : Node_Id; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Nod : Node_Id); + -- Build calling stubs for general purpose. The parameters are: + -- Decls : a place to put declarations + -- Statements : a place to put statements + -- Target : PCS-specific target information (see details + -- in RPC_Target declaration). + -- Subprogram_Id : a node containing the subprogram ID + -- Asynchronous : True if an APC must be made instead of an RPC. + -- The value needs not be supplied if one of the + -- Is_Known_... is True. + -- Is_Known_Async... : True if we know that this is asynchronous + -- Is_Known_Non_A... : True if we know that this is not asynchronous + -- Spec : a node with a Parameter_Specifications and + -- a Result_Definition if applicable + -- Stub_Type : in case of RACW stubs, parameters of type access + -- to Stub_Type will be marshalled using the + -- address of the object (the addr field) rather + -- than using the 'Write on the stub itself + -- Nod : used to provide sloc for generated code + + function Specific_Build_Stub_Target + (Loc : Source_Ptr; + Decls : List_Id; + RCI_Locator : Entity_Id; + Controlling_Parameter : Entity_Id) return RPC_Target; + -- Build call target information nodes for use within calling stubs. In the + -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If + -- for an RACW, Controlling_Parameter is the entity for the controlling + -- formal parameter used to determine the location of the target of the + -- call. Decls provides a location where variable declarations can be + -- appended to construct the necessary values. + + procedure Specific_Build_Stub_Type + (RACW_Type : Entity_Id; + Stub_Type_Comps : out List_Id; + RPC_Receiver_Decl : out Node_Id); + -- Build a components list for the stub type associated with an RACW type, + -- and build the necessary RPC receiver, if applicable. PCS-specific + -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration + -- is generated, then RPC_Receiver_Decl is set to Empty. + + procedure Specific_Build_RPC_Receiver_Body + (RPC_Receiver : Entity_Id; + Request : out Entity_Id; + Subp_Id : out Entity_Id; + Subp_Index : out Entity_Id; + Stmts : out List_Id; + Decl : out Node_Id); + -- Make a subprogram body for an RPC receiver, with the given + -- defining unit name. On return: + -- - Subp_Id is the subprogram identifier from the PCS. + -- - Subp_Index is the index in the list of subprograms + -- used for dispatching (a variable of type Subprogram_Id). + -- - Stmts is the place where the request dispatching + -- statements can occur, + -- - Decl is the subprogram body declaration. + + function Specific_Build_Subprogram_Receiving_Stubs + (Vis_Decl : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Parent_Primitive : Entity_Id := Empty) return Node_Id; + -- Build the receiving stub for a given subprogram. The subprogram + -- declaration is also built by this procedure, and the value returned + -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is + -- found in the specification, then its address is read from the stream + -- instead of the object itself and converted into an access to + -- class-wide type before doing the real call using any of the RACW type + -- pointing on the designated type. + + procedure Specific_Add_Obj_RPC_Receiver_Completion + (Loc : Source_Ptr; + Decls : List_Id; + RPC_Receiver : Entity_Id; + Stub_Elements : Stub_Structure); + -- Add the necessary code to Decls after the completion of generation + -- of the RACW RPC receiver described by Stub_Elements. + + procedure Specific_Add_Receiving_Stubs_To_Declarations + (Pkg_Spec : Node_Id; + Decls : List_Id; + Stmts : List_Id); + -- Add receiving stubs to the declarative part of an RCI unit + + -------------------- + -- GARLIC_Support -- + -------------------- + + package GARLIC_Support is + + -- Support for generating DSA code that uses the GARLIC PCS + + -- The subprograms below provide the GARLIC versions of the + -- corresponding Specific_ routine declared above. + + procedure Add_RACW_Features + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver_Decl : Node_Id; + Body_Decls : List_Id); + + procedure Add_RAST_Features + (Vis_Decl : Node_Id; + RAS_Type : Entity_Id); + + procedure Build_General_Calling_Stubs + (Decls : List_Id; + Statements : List_Id; + Target_Partition : Entity_Id; -- From RPC_Target + Target_RPC_Receiver : Node_Id; -- From RPC_Target + Subprogram_Id : Node_Id; + Asynchronous : Node_Id := Empty; + Is_Known_Asynchronous : Boolean := False; + Is_Known_Non_Asynchronous : Boolean := False; + Is_Function : Boolean; + Spec : Node_Id; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Nod : Node_Id); + + function Build_Stub_Target + (Loc : Source_Ptr; + Decls : List_Id; + RCI_Locator : Entity_Id; + Controlling_Parameter : Entity_Id) return RPC_Target; + + procedure Build_Stub_Type + (RACW_Type : Entity_Id; + Stub_Type_Comps : out List_Id; + RPC_Receiver_Decl : out Node_Id); + + function Build_Subprogram_Receiving_Stubs + (Vis_Decl : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Parent_Primitive : Entity_Id := Empty) return Node_Id; + + procedure Add_Obj_RPC_Receiver_Completion + (Loc : Source_Ptr; + Decls : List_Id; + RPC_Receiver : Entity_Id; + Stub_Elements : Stub_Structure); + + procedure Add_Receiving_Stubs_To_Declarations + (Pkg_Spec : Node_Id; + Decls : List_Id; + Stmts : List_Id); + + procedure Build_RPC_Receiver_Body + (RPC_Receiver : Entity_Id; + Request : out Entity_Id; + Subp_Id : out Entity_Id; + Subp_Index : out Entity_Id; + Stmts : out List_Id; + Decl : out Node_Id); + + end GARLIC_Support; + + --------------------- + -- PolyORB_Support -- + --------------------- + + package PolyORB_Support is + + -- Support for generating DSA code that uses the PolyORB PCS + + -- The subprograms below provide the PolyORB versions of the + -- corresponding Specific_ routine declared above. + + procedure Add_RACW_Features + (RACW_Type : Entity_Id; + Desig : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver_Decl : Node_Id; + Body_Decls : List_Id); + + procedure Add_RAST_Features + (Vis_Decl : Node_Id; + RAS_Type : Entity_Id); + + procedure Build_General_Calling_Stubs + (Decls : List_Id; + Statements : List_Id; + Target_Object : Node_Id; -- From RPC_Target + Subprogram_Id : Node_Id; + Asynchronous : Node_Id := Empty; + Is_Known_Asynchronous : Boolean := False; + Is_Known_Non_Asynchronous : Boolean := False; + Is_Function : Boolean; + Spec : Node_Id; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Nod : Node_Id); + + function Build_Stub_Target + (Loc : Source_Ptr; + Decls : List_Id; + RCI_Locator : Entity_Id; + Controlling_Parameter : Entity_Id) return RPC_Target; + + procedure Build_Stub_Type + (RACW_Type : Entity_Id; + Stub_Type_Comps : out List_Id; + RPC_Receiver_Decl : out Node_Id); + + function Build_Subprogram_Receiving_Stubs + (Vis_Decl : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Parent_Primitive : Entity_Id := Empty) return Node_Id; + + procedure Add_Obj_RPC_Receiver_Completion + (Loc : Source_Ptr; + Decls : List_Id; + RPC_Receiver : Entity_Id; + Stub_Elements : Stub_Structure); + + procedure Add_Receiving_Stubs_To_Declarations + (Pkg_Spec : Node_Id; + Decls : List_Id; + Stmts : List_Id); + + procedure Build_RPC_Receiver_Body + (RPC_Receiver : Entity_Id; + Request : out Entity_Id; + Subp_Id : out Entity_Id; + Subp_Index : out Entity_Id; + Stmts : out List_Id; + Decl : out Node_Id); + + procedure Reserve_NamingContext_Methods; + -- Mark the method names for interface NamingContext as already used in + -- the overload table, so no clashes occur with user code (with the + -- PolyORB PCS, RCIs Implement The NamingContext interface to allow + -- their methods to be accessed as objects, for the implementation of + -- remote access-to-subprogram types). + + ------------- + -- Helpers -- + ------------- + + package Helpers is + + -- Routines to build distribution helper subprograms for user-defined + -- types. For implementation of the Distributed systems annex (DSA) + -- over the PolyORB generic middleware components, it is necessary to + -- generate several supporting subprograms for each application data + -- type used in inter-partition communication. These subprograms are: + + -- A Typecode function returning a high-level description of the + -- type's structure; + + -- Two conversion functions allowing conversion of values of the + -- type from and to the generic data containers used by PolyORB. + -- These generic containers are called 'Any' type values after the + -- CORBA terminology, and hence the conversion subprograms are + -- named To_Any and From_Any. + + function Build_From_Any_Call + (Typ : Entity_Id; + N : Node_Id; + Decls : List_Id) return Node_Id; + -- Build call to From_Any attribute function of type Typ with + -- expression N as actual parameter. Decls is the declarations list + -- for an appropriate enclosing scope of the point where the call + -- will be inserted; if the From_Any attribute for Typ needs to be + -- generated at this point, its declaration is appended to Decls. + + procedure Build_From_Any_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id); + -- Build From_Any attribute function for Typ. Loc is the reference + -- location for generated nodes, Typ is the type for which the + -- conversion function is generated. On return, Decl and Fnam contain + -- the declaration and entity for the newly-created function. + + function Build_To_Any_Call + (N : Node_Id; + Decls : List_Id) return Node_Id; + -- Build call to To_Any attribute function with expression as actual + -- parameter. Decls is the declarations list for an appropriate + -- enclosing scope of the point where the call will be inserted; if + -- the To_Any attribute for Typ needs to be generated at this point, + -- its declaration is appended to Decls. + + procedure Build_To_Any_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id); + -- Build To_Any attribute function for Typ. Loc is the reference + -- location for generated nodes, Typ is the type for which the + -- conversion function is generated. On return, Decl and Fnam contain + -- the declaration and entity for the newly-created function. + + function Build_TypeCode_Call + (Loc : Source_Ptr; + Typ : Entity_Id; + Decls : List_Id) return Node_Id; + -- Build call to TypeCode attribute function for Typ. Decls is the + -- declarations list for an appropriate enclosing scope of the point + -- where the call will be inserted; if the To_Any attribute for Typ + -- needs to be generated at this point, its declaration is appended + -- to Decls. + + procedure Build_TypeCode_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id); + -- Build TypeCode attribute function for Typ. Loc is the reference + -- location for generated nodes, Typ is the type for which the + -- conversion function is generated. On return, Decl and Fnam contain + -- the declaration and entity for the newly-created function. + + procedure Build_Name_And_Repository_Id + (E : Entity_Id; + Name_Str : out String_Id; + Repo_Id_Str : out String_Id); + -- In the PolyORB distribution model, each distributed object type + -- and each distributed operation has a globally unique identifier, + -- its Repository Id. This subprogram builds and returns two strings + -- for entity E (a distributed object type or operation): one + -- containing the name of E, the second containing its repository id. + + procedure Assign_Opaque_From_Any + (Loc : Source_Ptr; + Stms : List_Id; + Typ : Entity_Id; + N : Node_Id; + Target : Entity_Id); + -- For a Target object of type Typ, which has opaque representation + -- as a sequence of octets determined by stream attributes (which + -- includes all limited types), append code to Stmts performing the + -- equivalent of: + -- Target := Typ'From_Any (N) + -- + -- or, if Target is Empty: + -- return Typ'From_Any (N) + + end Helpers; + + end PolyORB_Support; + + -- The following PolyORB-specific subprograms are made visible to Exp_Attr: + + function Build_From_Any_Call + (Typ : Entity_Id; + N : Node_Id; + Decls : List_Id) return Node_Id + renames PolyORB_Support.Helpers.Build_From_Any_Call; + + function Build_To_Any_Call + (N : Node_Id; + Decls : List_Id) return Node_Id + renames PolyORB_Support.Helpers.Build_To_Any_Call; + + function Build_TypeCode_Call + (Loc : Source_Ptr; + Typ : Entity_Id; + Decls : List_Id) return Node_Id + renames PolyORB_Support.Helpers.Build_TypeCode_Call; + + ------------------------------------ + -- Local variables and structures -- + ------------------------------------ + + RCI_Cache : Node_Id; + -- Needs comments ??? + + Output_From_Constrained : constant array (Boolean) of Name_Id := + (False => Name_Output, + True => Name_Write); + -- The attribute to choose depending on the fact that the parameter + -- is constrained or not. There is no such thing as Input_From_Constrained + -- since this require separate mechanisms ('Input is a function while + -- 'Read is a procedure). + + generic + with procedure Process_Subprogram_Declaration (Decl : Node_Id); + -- Generate calling or receiving stub for this subprogram declaration + + procedure Build_Package_Stubs (Pkg_Spec : Node_Id); + -- Recursively visit the given RCI Package_Specification, calling + -- Process_Subprogram_Declaration for each remote subprogram. + + ------------------------- + -- Build_Package_Stubs -- + ------------------------- + + procedure Build_Package_Stubs (Pkg_Spec : Node_Id) is + Decls : constant List_Id := Visible_Declarations (Pkg_Spec); + Decl : Node_Id; + + procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id); + -- Recurse for the given nested package declaration + + ----------------------- + -- Visit_Nested_Spec -- + ----------------------- + + procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id) is + Nested_Pkg_Spec : constant Node_Id := Specification (Nested_Pkg_Decl); + begin + Push_Scope (Scope_Of_Spec (Nested_Pkg_Spec)); + Build_Package_Stubs (Nested_Pkg_Spec); + Pop_Scope; + end Visit_Nested_Pkg; + + -- Start of processing for Build_Package_Stubs + + begin + Decl := First (Decls); + while Present (Decl) loop + case Nkind (Decl) is + when N_Subprogram_Declaration => + + -- Note: we test Comes_From_Source on Spec, not Decl, because + -- in the case of a subprogram instance, only the specification + -- (not the declaration) is marked as coming from source. + + if Comes_From_Source (Specification (Decl)) then + Process_Subprogram_Declaration (Decl); + end if; + + when N_Package_Declaration => + + -- Case of a nested package or package instantiation coming + -- from source. Note that the anonymous wrapper package for + -- subprogram instances is not flagged Is_Generic_Instance at + -- this point, so there is a distinct circuit to handle them + -- (see case N_Subprogram_Instantiation below). + + declare + Pkg_Ent : constant Entity_Id := + Defining_Unit_Name (Specification (Decl)); + begin + if Comes_From_Source (Decl) + or else + (Is_Generic_Instance (Pkg_Ent) + and then Comes_From_Source + (Get_Package_Instantiation_Node (Pkg_Ent))) + then + Visit_Nested_Pkg (Decl); + end if; + end; + + when N_Subprogram_Instantiation => + + -- The subprogram declaration for an instance of a generic + -- subprogram is wrapped in a package that does not come from + -- source, so we need to explicitly traverse it here. + + if Comes_From_Source (Decl) then + Visit_Nested_Pkg (Instance_Spec (Decl)); + end if; + + when others => + null; + end case; + Next (Decl); + end loop; + end Build_Package_Stubs; + + --------------------------------------- + -- Add_Calling_Stubs_To_Declarations -- + --------------------------------------- + + procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id) is + Loc : constant Source_Ptr := Sloc (Pkg_Spec); + + Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; + -- Subprogram id 0 is reserved for calls received from + -- remote access-to-subprogram dereferences. + + RCI_Instantiation : Node_Id; + + procedure Visit_Subprogram (Decl : Node_Id); + -- Generate calling stub for one remote subprogram + + ---------------------- + -- Visit_Subprogram -- + ---------------------- + + procedure Visit_Subprogram (Decl : Node_Id) is + Loc : constant Source_Ptr := Sloc (Decl); + Spec : constant Node_Id := Specification (Decl); + Subp_Stubs : Node_Id; + + Subp_Str : String_Id; + pragma Warnings (Off, Subp_Str); + + begin + Assign_Subprogram_Identifier + (Defining_Unit_Name (Spec), Current_Subprogram_Number, Subp_Str); + + Subp_Stubs := + Build_Subprogram_Calling_Stubs + (Vis_Decl => Decl, + Subp_Id => + Build_Subprogram_Id (Loc, Defining_Unit_Name (Spec)), + Asynchronous => + Nkind (Spec) = N_Procedure_Specification + and then Is_Asynchronous (Defining_Unit_Name (Spec))); + + Append_To (List_Containing (Decl), Subp_Stubs); + Analyze (Subp_Stubs); + + Current_Subprogram_Number := Current_Subprogram_Number + 1; + end Visit_Subprogram; + + procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram); + + -- Start of processing for Add_Calling_Stubs_To_Declarations + + begin + Push_Scope (Scope_Of_Spec (Pkg_Spec)); + + -- The first thing added is an instantiation of the generic package + -- System.Partition_Interface.RCI_Locator with the name of this remote + -- package. This will act as an interface with the name server to + -- determine the Partition_ID and the RPC_Receiver for the receiver + -- of this package. + + RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec); + RCI_Cache := Defining_Unit_Name (RCI_Instantiation); + + Append_To (Visible_Declarations (Pkg_Spec), RCI_Instantiation); + Analyze (RCI_Instantiation); + + -- For each subprogram declaration visible in the spec, we do build a + -- body. We also increment a counter to assign a different Subprogram_Id + -- to each subprogram. The receiving stubs processing uses the same + -- mechanism and will thus assign the same Id and do the correct + -- dispatching. + + Overload_Counter_Table.Reset; + PolyORB_Support.Reserve_NamingContext_Methods; + + Visit_Spec (Pkg_Spec); + + Pop_Scope; + end Add_Calling_Stubs_To_Declarations; + + ----------------------------- + -- Add_Parameter_To_NVList -- + ----------------------------- + + function Add_Parameter_To_NVList + (Loc : Source_Ptr; + NVList : Entity_Id; + Parameter : Entity_Id; + Constrained : Boolean; + RACW_Ctrl : Boolean := False; + Any : Entity_Id) return Node_Id + is + Parameter_Name_String : String_Id; + Parameter_Mode : Node_Id; + + function Parameter_Passing_Mode + (Loc : Source_Ptr; + Parameter : Entity_Id; + Constrained : Boolean) return Node_Id; + -- Return an expression that denotes the parameter passing mode to be + -- used for Parameter in distribution stubs, where Constrained is + -- Parameter's constrained status. + + ---------------------------- + -- Parameter_Passing_Mode -- + ---------------------------- + + function Parameter_Passing_Mode + (Loc : Source_Ptr; + Parameter : Entity_Id; + Constrained : Boolean) return Node_Id + is + Lib_RE : RE_Id; + + begin + if Out_Present (Parameter) then + if In_Present (Parameter) + or else not Constrained + then + -- Unconstrained formals must be translated + -- to 'in' or 'inout', not 'out', because + -- they need to be constrained by the actual. + + Lib_RE := RE_Mode_Inout; + else + Lib_RE := RE_Mode_Out; + end if; + + else + Lib_RE := RE_Mode_In; + end if; + + return New_Occurrence_Of (RTE (Lib_RE), Loc); + end Parameter_Passing_Mode; + + -- Start of processing for Add_Parameter_To_NVList + + begin + if Nkind (Parameter) = N_Defining_Identifier then + Get_Name_String (Chars (Parameter)); + else + Get_Name_String (Chars (Defining_Identifier (Parameter))); + end if; + + Parameter_Name_String := String_From_Name_Buffer; + + if RACW_Ctrl or else Nkind (Parameter) = N_Defining_Identifier then + + -- When the parameter passed to Add_Parameter_To_NVList is an + -- Extra_Constrained parameter, Parameter is an N_Defining_ + -- Identifier, instead of a complete N_Parameter_Specification. + -- Thus, we explicitly set 'in' mode in this case. + + Parameter_Mode := New_Occurrence_Of (RTE (RE_Mode_In), Loc); + + else + Parameter_Mode := + Parameter_Passing_Mode (Loc, Parameter, Constrained); + end if; + + return + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (RTE (RE_NVList_Add_Item), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (NVList, Loc), + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (RTE (RE_To_PolyORB_String), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, + Strval => Parameter_Name_String))), + New_Occurrence_Of (Any, Loc), + Parameter_Mode)); + end Add_Parameter_To_NVList; + + -------------------------------- + -- Add_RACW_Asynchronous_Flag -- + -------------------------------- + + procedure Add_RACW_Asynchronous_Flag + (Declarations : List_Id; + RACW_Type : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (RACW_Type); + + Asynchronous_Flag : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (RACW_Type), 'A')); + + begin + -- Declare the asynchronous flag. This flag will be changed to True + -- whenever it is known that the RACW type is asynchronous. + + Append_To (Declarations, + Make_Object_Declaration (Loc, + Defining_Identifier => Asynchronous_Flag, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), + Expression => New_Occurrence_Of (Standard_False, Loc))); + + Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag); + end Add_RACW_Asynchronous_Flag; + + ----------------------- + -- Add_RACW_Features -- + ----------------------- + + procedure Add_RACW_Features (RACW_Type : Entity_Id) is + Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type)); + Same_Scope : constant Boolean := Scope (Desig) = Scope (RACW_Type); + + Pkg_Spec : Node_Id; + Decls : List_Id; + Body_Decls : List_Id; + + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver_Decl : Node_Id; + + Existing : Boolean; + -- True when appropriate stubs have already been generated (this is the + -- case when another RACW with the same designated type has already been + -- encountered), in which case we reuse the previous stubs rather than + -- generating new ones. + + begin + if not Expander_Active then + return; + end if; + + -- Mark the current package declaration as containing an RACW, so that + -- the bodies for the calling stubs and the RACW stream subprograms + -- are attached to the tree when the corresponding body is encountered. + + Set_Has_RACW (Current_Scope); + + -- Look for place to declare the RACW stub type and RACW operations + + Pkg_Spec := Empty; + + if Same_Scope then + + -- Case of declaring the RACW in the same package as its designated + -- type: we know that the designated type is a private type, so we + -- use the private declarations list. + + Pkg_Spec := Package_Specification_Of_Scope (Current_Scope); + + if Present (Private_Declarations (Pkg_Spec)) then + Decls := Private_Declarations (Pkg_Spec); + else + Decls := Visible_Declarations (Pkg_Spec); + end if; + + else + -- Case of declaring the RACW in another package than its designated + -- type: use the private declarations list if present; otherwise + -- use the visible declarations. + + Decls := List_Containing (Declaration_Node (RACW_Type)); + + end if; + + -- If we were unable to find the declarations, that means that the + -- completion of the type was missing. We can safely return and let the + -- error be caught by the semantic analysis. + + if No (Decls) then + return; + end if; + + Add_Stub_Type + (Designated_Type => Desig, + RACW_Type => RACW_Type, + Decls => Decls, + Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + RPC_Receiver_Decl => RPC_Receiver_Decl, + Body_Decls => Body_Decls, + Existing => Existing); + + -- If this RACW is not in the main unit, do not generate primitive or + -- TSS bodies. + + if not Entity_Is_In_Main_Unit (RACW_Type) then + Body_Decls := No_List; + end if; + + Add_RACW_Asynchronous_Flag + (Declarations => Decls, + RACW_Type => RACW_Type); + + Specific_Add_RACW_Features + (RACW_Type => RACW_Type, + Desig => Desig, + Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + RPC_Receiver_Decl => RPC_Receiver_Decl, + Body_Decls => Body_Decls); + + -- If we already have stubs for this designated type, nothing to do + + if Existing then + return; + end if; + + if Is_Frozen (Desig) then + Validate_RACW_Primitives (RACW_Type); + Add_RACW_Primitive_Declarations_And_Bodies + (Designated_Type => Desig, + Insertion_Node => RPC_Receiver_Decl, + Body_Decls => Body_Decls); + + else + -- Validate_RACW_Primitives requires the list of all primitives of + -- the designated type, so defer processing until Desig is frozen. + -- See Exp_Ch3.Freeze_Type. + + Add_Access_Type_To_Process (E => Desig, A => RACW_Type); + end if; + end Add_RACW_Features; + + ------------------------------------------------ + -- Add_RACW_Primitive_Declarations_And_Bodies -- + ------------------------------------------------ + + procedure Add_RACW_Primitive_Declarations_And_Bodies + (Designated_Type : Entity_Id; + Insertion_Node : Node_Id; + Body_Decls : List_Id) + is + Loc : constant Source_Ptr := Sloc (Insertion_Node); + -- Set Sloc of generated declaration copy of insertion node Sloc, so + -- the declarations are recognized as belonging to the current package. + + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Designated_Type); + + pragma Assert (Stub_Elements /= Empty_Stub_Structure); + + Is_RAS : constant Boolean := + not Comes_From_Source (Stub_Elements.RACW_Type); + -- Case of the RACW generated to implement a remote access-to- + -- subprogram type. + + Build_Bodies : constant Boolean := + In_Extended_Main_Code_Unit (Stub_Elements.Stub_Type); + -- True when bodies must be prepared in Body_Decls. Bodies are generated + -- only when the main unit is the unit that contains the stub type. + + Current_Insertion_Node : Node_Id := Insertion_Node; + + RPC_Receiver : Entity_Id; + RPC_Receiver_Statements : List_Id; + RPC_Receiver_Case_Alternatives : constant List_Id := New_List; + RPC_Receiver_Elsif_Parts : List_Id; + RPC_Receiver_Request : Entity_Id; + RPC_Receiver_Subp_Id : Entity_Id; + RPC_Receiver_Subp_Index : Entity_Id; + + Subp_Str : String_Id; + + Current_Primitive_Elmt : Elmt_Id; + Current_Primitive : Entity_Id; + Current_Primitive_Body : Node_Id; + Current_Primitive_Spec : Node_Id; + Current_Primitive_Decl : Node_Id; + Current_Primitive_Number : Int := 0; + Current_Primitive_Alias : Node_Id; + Current_Receiver : Entity_Id; + Current_Receiver_Body : Node_Id; + RPC_Receiver_Decl : Node_Id; + Possibly_Asynchronous : Boolean; + + begin + if not Expander_Active then + return; + end if; + + if not Is_RAS then + RPC_Receiver := Make_Temporary (Loc, 'P'); + + Specific_Build_RPC_Receiver_Body + (RPC_Receiver => RPC_Receiver, + Request => RPC_Receiver_Request, + Subp_Id => RPC_Receiver_Subp_Id, + Subp_Index => RPC_Receiver_Subp_Index, + Stmts => RPC_Receiver_Statements, + Decl => RPC_Receiver_Decl); + + if Get_PCS_Name = Name_PolyORB_DSA then + + -- For the case of PolyORB, we need to map a textual operation + -- name into a primitive index. Currently we do so using a simple + -- sequence of string comparisons. + + RPC_Receiver_Elsif_Parts := New_List; + end if; + end if; + + -- Build callers, receivers for every primitive operations and a RPC + -- receiver for this type. Note that we use Direct_Primitive_Operations, + -- not Primitive_Operations, because we really want just the primitives + -- of the tagged type itself, and in the case of a tagged synchronized + -- type we do not want to get the primitives of the corresponding + -- record type). + + if Present (Direct_Primitive_Operations (Designated_Type)) then + Overload_Counter_Table.Reset; + + Current_Primitive_Elmt := + First_Elmt (Direct_Primitive_Operations (Designated_Type)); + while Current_Primitive_Elmt /= No_Elmt loop + Current_Primitive := Node (Current_Primitive_Elmt); + + -- Copy the primitive of all the parents, except predefined ones + -- that are not remotely dispatching. Also omit hidden primitives + -- (occurs in the case of primitives of interface progenitors + -- other than immediate ancestors of the Designated_Type). + + if Chars (Current_Primitive) /= Name_uSize + and then Chars (Current_Primitive) /= Name_uAlignment + and then not + (Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else + Is_TSS (Current_Primitive, TSS_Stream_Input) or else + Is_TSS (Current_Primitive, TSS_Stream_Output) or else + Is_TSS (Current_Primitive, TSS_Stream_Read) or else + Is_TSS (Current_Primitive, TSS_Stream_Write) + or else + Is_Predefined_Interface_Primitive (Current_Primitive)) + and then not Is_Hidden (Current_Primitive) + then + -- The first thing to do is build an up-to-date copy of the + -- spec with all the formals referencing Controlling_Type + -- transformed into formals referencing Stub_Type. Since this + -- primitive may have been inherited, go back the alias chain + -- until the real primitive has been found. + + Current_Primitive_Alias := Ultimate_Alias (Current_Primitive); + + -- Copy the spec from the original declaration for the purpose + -- of declaring an overriding subprogram: we need to replace + -- the type of each controlling formal with Stub_Type. The + -- primitive may have been declared for Controlling_Type or + -- inherited from some ancestor type for which we do not have + -- an easily determined Entity_Id. We have no systematic way + -- of knowing which type to substitute Stub_Type for. Instead, + -- Copy_Specification relies on the flag Is_Controlling_Formal + -- to determine which formals to change. + + Current_Primitive_Spec := + Copy_Specification (Loc, + Spec => Parent (Current_Primitive_Alias), + Ctrl_Type => Stub_Elements.Stub_Type); + + Current_Primitive_Decl := + Make_Subprogram_Declaration (Loc, + Specification => Current_Primitive_Spec); + + Insert_After_And_Analyze (Current_Insertion_Node, + Current_Primitive_Decl); + Current_Insertion_Node := Current_Primitive_Decl; + + Possibly_Asynchronous := + Nkind (Current_Primitive_Spec) = N_Procedure_Specification + and then Could_Be_Asynchronous (Current_Primitive_Spec); + + Assign_Subprogram_Identifier ( + Defining_Unit_Name (Current_Primitive_Spec), + Current_Primitive_Number, + Subp_Str); + + if Build_Bodies then + Current_Primitive_Body := + Build_Subprogram_Calling_Stubs + (Vis_Decl => Current_Primitive_Decl, + Subp_Id => + Build_Subprogram_Id (Loc, + Defining_Unit_Name (Current_Primitive_Spec)), + Asynchronous => Possibly_Asynchronous, + Dynamically_Asynchronous => Possibly_Asynchronous, + Stub_Type => Stub_Elements.Stub_Type, + RACW_Type => Stub_Elements.RACW_Type); + Append_To (Body_Decls, Current_Primitive_Body); + + -- Analyzing the body here would cause the Stub type to + -- be frozen, thus preventing subsequent primitive + -- declarations. For this reason, it will be analyzed + -- later in the regular flow (and in the context of the + -- appropriate unit body, see Append_RACW_Bodies). + + end if; + + -- Build the receiver stubs + + if Build_Bodies and then not Is_RAS then + Current_Receiver_Body := + Specific_Build_Subprogram_Receiving_Stubs + (Vis_Decl => Current_Primitive_Decl, + Asynchronous => Possibly_Asynchronous, + Dynamically_Asynchronous => Possibly_Asynchronous, + Stub_Type => Stub_Elements.Stub_Type, + RACW_Type => Stub_Elements.RACW_Type, + Parent_Primitive => Current_Primitive); + + Current_Receiver := + Defining_Unit_Name (Specification (Current_Receiver_Body)); + + Append_To (Body_Decls, Current_Receiver_Body); + + -- Add a case alternative to the receiver + + if Get_PCS_Name = Name_PolyORB_DSA then + Append_To (RPC_Receiver_Elsif_Parts, + Make_Elsif_Part (Loc, + Condition => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Caseless_String_Eq), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc), + Make_String_Literal (Loc, Subp_Str))), + + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of ( + RPC_Receiver_Subp_Index, Loc), + Expression => + Make_Integer_Literal (Loc, + Intval => Current_Primitive_Number))))); + end if; + + Append_To (RPC_Receiver_Case_Alternatives, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List ( + Make_Integer_Literal (Loc, Current_Primitive_Number)), + + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (Current_Receiver, Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (RPC_Receiver_Request, Loc)))))); + end if; + + -- Increment the index of current primitive + + Current_Primitive_Number := Current_Primitive_Number + 1; + end if; + + Next_Elmt (Current_Primitive_Elmt); + end loop; + end if; + + -- Build the case statement and the heart of the subprogram + + if Build_Bodies and then not Is_RAS then + if Get_PCS_Name = Name_PolyORB_DSA + and then Present (First (RPC_Receiver_Elsif_Parts)) + then + Append_To (RPC_Receiver_Statements, + Make_Implicit_If_Statement (Designated_Type, + Condition => New_Occurrence_Of (Standard_False, Loc), + Then_Statements => New_List, + Elsif_Parts => RPC_Receiver_Elsif_Parts)); + end if; + + Append_To (RPC_Receiver_Case_Alternatives, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List (Make_Null_Statement (Loc)))); + + Append_To (RPC_Receiver_Statements, + Make_Case_Statement (Loc, + Expression => + New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc), + Alternatives => RPC_Receiver_Case_Alternatives)); + + Append_To (Body_Decls, RPC_Receiver_Decl); + Specific_Add_Obj_RPC_Receiver_Completion (Loc, + Body_Decls, RPC_Receiver, Stub_Elements); + + -- Do not analyze RPC receiver body at this stage since it references + -- subprograms that have not been analyzed yet. It will be analyzed in + -- the regular flow (see Append_RACW_Bodies). + + end if; + end Add_RACW_Primitive_Declarations_And_Bodies; + + ----------------------------- + -- Add_RAS_Dereference_TSS -- + ----------------------------- + + procedure Add_RAS_Dereference_TSS (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Type_Def : constant Node_Id := Type_Definition (N); + RAS_Type : constant Entity_Id := Defining_Identifier (N); + Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type); + RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type); + + RACW_Primitive_Name : Node_Id; + + Proc : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference)); + + Proc_Spec : Node_Id; + Param_Specs : List_Id; + Param_Assoc : constant List_Id := New_List; + Stmts : constant List_Id := New_List; + + RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'P'); + + Is_Function : constant Boolean := + Nkind (Type_Def) = N_Access_Function_Definition; + + Is_Degenerate : Boolean; + -- Set to True if the subprogram_specification for this RAS has an + -- anonymous access parameter (see Process_Remote_AST_Declaration). + + Spec : constant Node_Id := Type_Def; + + Current_Parameter : Node_Id; + + -- Start of processing for Add_RAS_Dereference_TSS + + begin + -- The Dereference TSS for a remote access-to-subprogram type has the + -- form: + + -- [function|procedure] ras_typeRD (RAS_Value, ) + -- [return <>] + + -- This is called whenever a value of a RAS type is dereferenced + + -- First construct a list of parameter specifications: + + -- The first formal is the RAS values + + Param_Specs := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => RAS_Parameter, + In_Present => True, + Parameter_Type => + New_Occurrence_Of (Fat_Type, Loc))); + + -- The following formals are copied from the type declaration + + Is_Degenerate := False; + Current_Parameter := First (Parameter_Specifications (Type_Def)); + Parameters : while Present (Current_Parameter) loop + if Nkind (Parameter_Type (Current_Parameter)) = + N_Access_Definition + then + Is_Degenerate := True; + end if; + + Append_To (Param_Specs, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Chars (Defining_Identifier (Current_Parameter))), + In_Present => In_Present (Current_Parameter), + Out_Present => Out_Present (Current_Parameter), + Parameter_Type => + New_Copy_Tree (Parameter_Type (Current_Parameter)), + Expression => + New_Copy_Tree (Expression (Current_Parameter)))); + + Append_To (Param_Assoc, + Make_Identifier (Loc, + Chars => Chars (Defining_Identifier (Current_Parameter)))); + + Next (Current_Parameter); + end loop Parameters; + + if Is_Degenerate then + Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc)); + + -- Generate a dummy body. This code will never actually be executed, + -- because null is the only legal value for a degenerate RAS type. + -- For legality's sake (in order to avoid generating a function that + -- does not contain a return statement), we include a dummy recursive + -- call on the TSS itself. + + Append_To (Stmts, + Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise)); + RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc); + + else + -- For a normal RAS type, we cast the RAS formal to the corresponding + -- tagged type, and perform a dispatching call to its Call primitive + -- operation. + + Prepend_To (Param_Assoc, + Unchecked_Convert_To (RACW_Type, + New_Occurrence_Of (RAS_Parameter, Loc))); + + RACW_Primitive_Name := + Make_Selected_Component (Loc, + Prefix => Scope (RACW_Type), + Selector_Name => Name_uCall); + end if; + + if Is_Function then + Append_To (Stmts, + Make_Simple_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => RACW_Primitive_Name, + Parameter_Associations => Param_Assoc))); + + else + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => RACW_Primitive_Name, + Parameter_Associations => Param_Assoc)); + end if; + + -- Build the complete subprogram + + if Is_Function then + Proc_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Proc, + Parameter_Specifications => Param_Specs, + Result_Definition => + New_Occurrence_Of ( + Entity (Result_Definition (Spec)), Loc)); + + Set_Ekind (Proc, E_Function); + Set_Etype (Proc, + New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc)); + + else + Proc_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc, + Parameter_Specifications => Param_Specs); + + Set_Ekind (Proc, E_Procedure); + Set_Etype (Proc, Standard_Void_Type); + end if; + + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => Proc_Spec, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts))); + + Set_TSS (Fat_Type, Proc); + end Add_RAS_Dereference_TSS; + + ------------------------------- + -- Add_RAS_Proxy_And_Analyze -- + ------------------------------- + + procedure Add_RAS_Proxy_And_Analyze + (Decls : List_Id; + Vis_Decl : Node_Id; + All_Calls_Remote_E : Entity_Id; + Proxy_Object_Addr : out Entity_Id) + is + Loc : constant Source_Ptr := Sloc (Vis_Decl); + + Subp_Name : constant Entity_Id := + Defining_Unit_Name (Specification (Vis_Decl)); + + Pkg_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Subp_Name), 'P', -1)); + + Proxy_Type : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name + (Related_Id => Chars (Subp_Name), + Suffix => 'P')); + + Proxy_Type_Full_View : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars (Proxy_Type)); + + Subp_Decl_Spec : constant Node_Id := + Build_RAS_Primitive_Specification + (Subp_Spec => Specification (Vis_Decl), + Remote_Object_Type => Proxy_Type); + + Subp_Body_Spec : constant Node_Id := + Build_RAS_Primitive_Specification + (Subp_Spec => Specification (Vis_Decl), + Remote_Object_Type => Proxy_Type); + + Vis_Decls : constant List_Id := New_List; + Pvt_Decls : constant List_Id := New_List; + Actuals : constant List_Id := New_List; + Formal : Node_Id; + Perform_Call : Node_Id; + + begin + -- type subpP is tagged limited private; + + Append_To (Vis_Decls, + Make_Private_Type_Declaration (Loc, + Defining_Identifier => Proxy_Type, + Tagged_Present => True, + Limited_Present => True)); + + -- [subprogram] Call + -- (Self : access subpP; + -- ...other-formals...) + -- [return T]; + + Append_To (Vis_Decls, + Make_Subprogram_Declaration (Loc, + Specification => Subp_Decl_Spec)); + + -- A : constant System.Address; + + Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA); + + Append_To (Vis_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Proxy_Object_Addr, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc))); + + -- private + + -- type subpP is tagged limited record + -- All_Calls_Remote : Boolean := [All_Calls_Remote?]; + -- ... + -- end record; + + Append_To (Pvt_Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Proxy_Type_Full_View, + Type_Definition => + Build_Remote_Subprogram_Proxy_Type (Loc, + New_Occurrence_Of (All_Calls_Remote_E, Loc)))); + + -- Trick semantic analysis into swapping the public and full view when + -- freezing the public view. + + Set_Comes_From_Source (Proxy_Type_Full_View, True); + + -- procedure Call + -- (Self : access O; + -- ...other-formals...) is + -- begin + -- P (...other-formals...); + -- end Call; + + -- function Call + -- (Self : access O; + -- ...other-formals...) + -- return T is + -- begin + -- return F (...other-formals...); + -- end Call; + + if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then + Perform_Call := + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Subp_Name, Loc), + Parameter_Associations => Actuals); + else + Perform_Call := + Make_Simple_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Subp_Name, Loc), + Parameter_Associations => Actuals)); + end if; + + Formal := First (Parameter_Specifications (Subp_Decl_Spec)); + pragma Assert (Present (Formal)); + loop + Next (Formal); + exit when No (Formal); + Append_To (Actuals, + New_Occurrence_Of (Defining_Identifier (Formal), Loc)); + end loop; + + -- O : aliased subpP; + + Append_To (Pvt_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), + Aliased_Present => True, + Object_Definition => New_Occurrence_Of (Proxy_Type, Loc))); + + -- A : constant System.Address := O'Address; + + Append_To (Pvt_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Proxy_Object_Addr)), + Constant_Present => True, + Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of ( + Defining_Identifier (Last (Pvt_Decls)), Loc), + Attribute_Name => Name_Address))); + + Append_To (Decls, + Make_Package_Declaration (Loc, + Specification => Make_Package_Specification (Loc, + Defining_Unit_Name => Pkg_Name, + Visible_Declarations => Vis_Decls, + Private_Declarations => Pvt_Decls, + End_Label => Empty))); + Analyze (Last (Decls)); + + Append_To (Decls, + Make_Package_Body (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Chars (Pkg_Name)), + Declarations => New_List ( + Make_Subprogram_Body (Loc, + Specification => Subp_Body_Spec, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Perform_Call)))))); + Analyze (Last (Decls)); + end Add_RAS_Proxy_And_Analyze; + + ----------------------- + -- Add_RAST_Features -- + ----------------------- + + procedure Add_RAST_Features (Vis_Decl : Node_Id) is + RAS_Type : constant Entity_Id := + Equivalent_Type (Defining_Identifier (Vis_Decl)); + begin + pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access))); + Add_RAS_Dereference_TSS (Vis_Decl); + Specific_Add_RAST_Features (Vis_Decl, RAS_Type); + end Add_RAST_Features; + + ------------------- + -- Add_Stub_Type -- + ------------------- + + procedure Add_Stub_Type + (Designated_Type : Entity_Id; + RACW_Type : Entity_Id; + Decls : List_Id; + Stub_Type : out Entity_Id; + Stub_Type_Access : out Entity_Id; + RPC_Receiver_Decl : out Node_Id; + Body_Decls : out List_Id; + Existing : out Boolean) + is + Loc : constant Source_Ptr := Sloc (RACW_Type); + + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Designated_Type); + Stub_Type_Comps : List_Id; + Stub_Type_Decl : Node_Id; + Stub_Type_Access_Decl : Node_Id; + + begin + if Stub_Elements /= Empty_Stub_Structure then + Stub_Type := Stub_Elements.Stub_Type; + Stub_Type_Access := Stub_Elements.Stub_Type_Access; + RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl; + Body_Decls := Stub_Elements.Body_Decls; + Existing := True; + return; + end if; + + Existing := False; + Stub_Type := Make_Temporary (Loc, 'S'); + Set_Ekind (Stub_Type, E_Record_Type); + Set_Is_RACW_Stub_Type (Stub_Type); + Stub_Type_Access := + Make_Defining_Identifier (Loc, + Chars => New_External_Name + (Related_Id => Chars (Stub_Type), Suffix => 'A')); + + Specific_Build_Stub_Type (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl); + + Stub_Type_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Stub_Type, + Type_Definition => + Make_Record_Definition (Loc, + Tagged_Present => True, + Limited_Present => True, + Component_List => + Make_Component_List (Loc, + Component_Items => Stub_Type_Comps))); + + -- Does the stub type need to explicitly implement interfaces from the + -- designated type??? + + -- In particular are there issues in the case where the designated type + -- is a synchronized interface??? + + Stub_Type_Access_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Stub_Type_Access, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc))); + + Append_To (Decls, Stub_Type_Decl); + Analyze (Last (Decls)); + Append_To (Decls, Stub_Type_Access_Decl); + Analyze (Last (Decls)); + + -- We can't directly derive the stub type from the designated type, + -- because we don't want any components or discriminants from the real + -- type, so instead we manually fake a derivation to get an appropriate + -- dispatch table. + + Derive_Subprograms (Parent_Type => Designated_Type, + Derived_Type => Stub_Type); + + if Present (RPC_Receiver_Decl) then + Append_To (Decls, RPC_Receiver_Decl); + else + RPC_Receiver_Decl := Last (Decls); + end if; + + Body_Decls := New_List; + + Stubs_Table.Set (Designated_Type, + (Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + RPC_Receiver_Decl => RPC_Receiver_Decl, + Body_Decls => Body_Decls, + RACW_Type => RACW_Type)); + end Add_Stub_Type; + + ------------------------ + -- Append_RACW_Bodies -- + ------------------------ + + procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is + E : Entity_Id; + + begin + E := First_Entity (Spec_Id); + while Present (E) loop + if Is_Remote_Access_To_Class_Wide_Type (E) then + Append_List_To (Decls, Get_And_Reset_RACW_Bodies (E)); + end if; + + Next_Entity (E); + end loop; + end Append_RACW_Bodies; + + ---------------------------------- + -- Assign_Subprogram_Identifier -- + ---------------------------------- + + procedure Assign_Subprogram_Identifier + (Def : Entity_Id; + Spn : Int; + Id : out String_Id) + is + N : constant Name_Id := Chars (Def); + + Overload_Order : constant Int := + Overload_Counter_Table.Get (N) + 1; + + begin + Overload_Counter_Table.Set (N, Overload_Order); + + Get_Name_String (N); + + -- Homonym handling: as in Exp_Dbug, but much simpler, because the only + -- entities for which we have to generate names here need only to be + -- disambiguated within their own scope. + + if Overload_Order > 1 then + Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__"; + Name_Len := Name_Len + 2; + Add_Nat_To_Name_Buffer (Overload_Order); + end if; + + Id := String_From_Name_Buffer; + Subprogram_Identifier_Table.Set + (Def, + Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn)); + end Assign_Subprogram_Identifier; + + ------------------------------------- + -- Build_Actual_Object_Declaration -- + ------------------------------------- + + procedure Build_Actual_Object_Declaration + (Object : Entity_Id; + Etyp : Entity_Id; + Variable : Boolean; + Expr : Node_Id; + Decls : List_Id) + is + Loc : constant Source_Ptr := Sloc (Object); + + begin + -- Declare a temporary object for the actual, possibly initialized with + -- a 'Input/From_Any call. + + -- Complication arises in the case of limited types, for which such a + -- declaration is illegal in Ada 95. In that case, we first generate a + -- renaming declaration of the 'Input call, and then if needed we + -- generate an overlaid non-constant view. + + if Ada_Version <= Ada_95 + and then Is_Limited_Type (Etyp) + and then Present (Expr) + then + + -- Object : Etyp renames + + Append_To (Decls, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Object, + Subtype_Mark => New_Occurrence_Of (Etyp, Loc), + Name => Expr)); + + if Variable then + + -- The name defined by the renaming declaration denotes a + -- constant view; create a non-constant object at the same address + -- to be used as the actual. + + declare + Constant_Object : constant Entity_Id := + Make_Temporary (Loc, 'P'); + + begin + Set_Defining_Identifier + (Last (Decls), Constant_Object); + + -- We have an unconstrained Etyp: build the actual constrained + -- subtype for the value we just read from the stream. + + -- subtype S is ; + + Append_To (Decls, + Build_Actual_Subtype (Etyp, + New_Occurrence_Of (Constant_Object, Loc))); + + -- Object : S; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Object, + Object_Definition => + New_Occurrence_Of + (Defining_Identifier (Last (Decls)), Loc))); + Set_Ekind (Object, E_Variable); + + -- Suppress default initialization: + -- pragma Import (Ada, Object); + + Append_To (Decls, + Make_Pragma (Loc, + Chars => Name_Import, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Chars => Name_Convention, + Expression => Make_Identifier (Loc, Name_Ada)), + Make_Pragma_Argument_Association (Loc, + Chars => Name_Entity, + Expression => New_Occurrence_Of (Object, Loc))))); + + -- for Object'Address use Constant_Object'Address; + + Append_To (Decls, + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (Object, Loc), + Chars => Name_Address, + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Constant_Object, Loc), + Attribute_Name => Name_Address))); + end; + end if; + + else + -- General case of a regular object declaration. Object is flagged + -- constant unless it has mode out or in out, to allow the backend + -- to optimize where possible. + + -- Object : [constant] Etyp [:= ]; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Object, + Constant_Present => Present (Expr) and then not Variable, + Object_Definition => New_Occurrence_Of (Etyp, Loc), + Expression => Expr)); + + if Constant_Present (Last (Decls)) then + Set_Ekind (Object, E_Constant); + else + Set_Ekind (Object, E_Variable); + end if; + end if; + end Build_Actual_Object_Declaration; + + ------------------------------ + -- Build_Get_Unique_RP_Call -- + ------------------------------ + + function Build_Get_Unique_RP_Call + (Loc : Source_Ptr; + Pointer : Entity_Id; + Stub_Type : Entity_Id) return List_Id + is + begin + return New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), + New_Occurrence_Of (Pointer, Loc)))), + + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Pointer, Loc), + Selector_Name => + New_Occurrence_Of (First_Tag_Component + (Designated_Type (Etype (Pointer))), Loc)), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stub_Type, Loc), + Attribute_Name => Name_Tag))); + + -- Note: The assignment to Pointer._Tag is safe here because + -- we carefully ensured that Stub_Type has exactly the same layout + -- as System.Partition_Interface.RACW_Stub_Type. + + end Build_Get_Unique_RP_Call; + + ----------------------------------- + -- Build_Ordered_Parameters_List -- + ----------------------------------- + + function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is + Constrained_List : List_Id; + Unconstrained_List : List_Id; + Current_Parameter : Node_Id; + Ptyp : Node_Id; + + First_Parameter : Node_Id; + For_RAS : Boolean := False; + + begin + if No (Parameter_Specifications (Spec)) then + return New_List; + end if; + + Constrained_List := New_List; + Unconstrained_List := New_List; + First_Parameter := First (Parameter_Specifications (Spec)); + + if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition + and then Chars (Defining_Identifier (First_Parameter)) = Name_uS + then + For_RAS := True; + end if; + + -- Loop through the parameters and add them to the right list. Note that + -- we treat a parameter of a null-excluding access type as unconstrained + -- because we can't declare an object of such a type with default + -- initialization. + + Current_Parameter := First_Parameter; + while Present (Current_Parameter) loop + Ptyp := Parameter_Type (Current_Parameter); + + if (Nkind (Ptyp) = N_Access_Definition + or else not Transmit_As_Unconstrained (Etype (Ptyp))) + and then not (For_RAS and then Current_Parameter = First_Parameter) + then + Append_To (Constrained_List, New_Copy (Current_Parameter)); + else + Append_To (Unconstrained_List, New_Copy (Current_Parameter)); + end if; + + Next (Current_Parameter); + end loop; + + -- Unconstrained parameters are returned first + + Append_List_To (Unconstrained_List, Constrained_List); + + return Unconstrained_List; + end Build_Ordered_Parameters_List; + + ---------------------------------- + -- Build_Passive_Partition_Stub -- + ---------------------------------- + + procedure Build_Passive_Partition_Stub (U : Node_Id) is + Pkg_Spec : Node_Id; + Pkg_Name : String_Id; + L : List_Id; + Reg : Node_Id; + Loc : constant Source_Ptr := Sloc (U); + + begin + -- Verify that the implementation supports distribution, by accessing + -- a type defined in the proper version of system.rpc + + declare + Dist_OK : Entity_Id; + pragma Warnings (Off, Dist_OK); + begin + Dist_OK := RTE (RE_Params_Stream_Type); + end; + + -- Use body if present, spec otherwise + + if Nkind (U) = N_Package_Declaration then + Pkg_Spec := Specification (U); + L := Visible_Declarations (Pkg_Spec); + else + Pkg_Spec := Parent (Corresponding_Spec (U)); + L := Declarations (U); + end if; + + Get_Library_Unit_Name_String (Pkg_Spec); + Pkg_Name := String_From_Name_Buffer; + Reg := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, Pkg_Name), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), + Attribute_Name => Name_Version))); + Append_To (L, Reg); + Analyze (Reg); + end Build_Passive_Partition_Stub; + + -------------------------------------- + -- Build_RPC_Receiver_Specification -- + -------------------------------------- + + function Build_RPC_Receiver_Specification + (RPC_Receiver : Entity_Id; + Request_Parameter : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (RPC_Receiver); + begin + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => RPC_Receiver, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Request_Parameter, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Request_Access), Loc)))); + end Build_RPC_Receiver_Specification; + + ---------------------------------------- + -- Build_Remote_Subprogram_Proxy_Type -- + ---------------------------------------- + + function Build_Remote_Subprogram_Proxy_Type + (Loc : Source_Ptr; + ACR_Expression : Node_Id) return Node_Id + is + begin + return + Make_Record_Definition (Loc, + Tagged_Present => True, + Limited_Present => True, + Component_List => + Make_Component_List (Loc, + + Component_Items => New_List ( + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Name_All_Calls_Remote), + Component_Definition => + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (Standard_Boolean, Loc)), + Expression => + ACR_Expression), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Name_Receiver), + Component_Definition => + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Address), Loc)), + Expression => + New_Occurrence_Of (RTE (RE_Null_Address), Loc)), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Name_Subp_Id), + Component_Definition => + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)))))); + end Build_Remote_Subprogram_Proxy_Type; + + -------------------- + -- Build_Stub_Tag -- + -------------------- + + function Build_Stub_Tag + (Loc : Source_Ptr; + RACW_Type : Entity_Id) return Node_Id + is + Stub_Type : constant Entity_Id := Corresponding_Stub_Type (RACW_Type); + begin + return + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stub_Type, Loc), + Attribute_Name => Name_Tag); + end Build_Stub_Tag; + + ------------------------------------ + -- Build_Subprogram_Calling_Stubs -- + ------------------------------------ + + function Build_Subprogram_Calling_Stubs + (Vis_Decl : Node_Id; + Subp_Id : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Locator : Entity_Id := Empty; + New_Name : Name_Id := No_Name) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Vis_Decl); + + Decls : constant List_Id := New_List; + Statements : constant List_Id := New_List; + + Subp_Spec : Node_Id; + -- The specification of the body + + Controlling_Parameter : Entity_Id := Empty; + + Asynchronous_Expr : Node_Id := Empty; + + RCI_Locator : Entity_Id; + + Spec_To_Use : Node_Id; + + procedure Insert_Partition_Check (Parameter : Node_Id); + -- Check that the parameter has been elaborated on the same partition + -- than the controlling parameter (E.4(19)). + + ---------------------------- + -- Insert_Partition_Check -- + ---------------------------- + + procedure Insert_Partition_Check (Parameter : Node_Id) is + Parameter_Entity : constant Entity_Id := + Defining_Identifier (Parameter); + begin + -- The expression that will be built is of the form: + + -- if not Same_Partition (Parameter, Controlling_Parameter) then + -- raise Constraint_Error; + -- end if; + + -- We do not check that Parameter is in Stub_Type since such a check + -- has been inserted at the point of call already (a tag check since + -- we have multiple controlling operands). + + Append_To (Decls, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Same_Partition), Loc), + Parameter_Associations => + New_List ( + Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), + New_Occurrence_Of (Parameter_Entity, Loc)), + Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), + New_Occurrence_Of (Controlling_Parameter, Loc))))), + Reason => CE_Partition_Check_Failed)); + end Insert_Partition_Check; + + -- Start of processing for Build_Subprogram_Calling_Stubs + + begin + Subp_Spec := + Copy_Specification (Loc, + Spec => Specification (Vis_Decl), + New_Name => New_Name); + + if Locator = Empty then + RCI_Locator := RCI_Cache; + Spec_To_Use := Specification (Vis_Decl); + else + RCI_Locator := Locator; + Spec_To_Use := Subp_Spec; + end if; + + -- Find a controlling argument if we have a stub type. Also check + -- if this subprogram can be made asynchronous. + + if Present (Stub_Type) + and then Present (Parameter_Specifications (Spec_To_Use)) + then + declare + Current_Parameter : Node_Id := + First (Parameter_Specifications + (Spec_To_Use)); + begin + while Present (Current_Parameter) loop + if + Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) + then + if Controlling_Parameter = Empty then + Controlling_Parameter := + Defining_Identifier (Current_Parameter); + else + Insert_Partition_Check (Current_Parameter); + end if; + end if; + + Next (Current_Parameter); + end loop; + end; + end if; + + pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter)); + + if Dynamically_Asynchronous then + Asynchronous_Expr := Make_Selected_Component (Loc, + Prefix => Controlling_Parameter, + Selector_Name => Name_Asynchronous); + end if; + + Specific_Build_General_Calling_Stubs + (Decls => Decls, + Statements => Statements, + Target => Specific_Build_Stub_Target (Loc, + Decls, RCI_Locator, Controlling_Parameter), + Subprogram_Id => Subp_Id, + Asynchronous => Asynchronous_Expr, + Is_Known_Asynchronous => Asynchronous + and then not Dynamically_Asynchronous, + Is_Known_Non_Asynchronous + => not Asynchronous + and then not Dynamically_Asynchronous, + Is_Function => Nkind (Spec_To_Use) = + N_Function_Specification, + Spec => Spec_To_Use, + Stub_Type => Stub_Type, + RACW_Type => RACW_Type, + Nod => Vis_Decl); + + RCI_Calling_Stubs_Table.Set + (Defining_Unit_Name (Specification (Vis_Decl)), + Defining_Unit_Name (Spec_To_Use)); + + return + Make_Subprogram_Body (Loc, + Specification => Subp_Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Statements)); + end Build_Subprogram_Calling_Stubs; + + ------------------------- + -- Build_Subprogram_Id -- + ------------------------- + + function Build_Subprogram_Id + (Loc : Source_Ptr; + E : Entity_Id) return Node_Id + is + begin + if Get_Subprogram_Ids (E).Str_Identifier = No_String then + declare + Current_Declaration : Node_Id; + Current_Subp : Entity_Id; + Current_Subp_Str : String_Id; + Current_Subp_Number : Int := First_RCI_Subprogram_Id; + + pragma Warnings (Off, Current_Subp_Str); + + begin + -- Build_Subprogram_Id is called outside of the context of + -- generating calling or receiving stubs. Hence we are processing + -- an 'Access attribute_reference for an RCI subprogram, for the + -- purpose of obtaining a RAS value. + + pragma Assert + (Is_Remote_Call_Interface (Scope (E)) + and then + (Nkind (Parent (E)) = N_Procedure_Specification + or else + Nkind (Parent (E)) = N_Function_Specification)); + + Current_Declaration := + First (Visible_Declarations + (Package_Specification_Of_Scope (Scope (E)))); + while Present (Current_Declaration) loop + if Nkind (Current_Declaration) = N_Subprogram_Declaration + and then Comes_From_Source (Current_Declaration) + then + Current_Subp := Defining_Unit_Name (Specification ( + Current_Declaration)); + + Assign_Subprogram_Identifier + (Current_Subp, Current_Subp_Number, Current_Subp_Str); + + Current_Subp_Number := Current_Subp_Number + 1; + end if; + + Next (Current_Declaration); + end loop; + end; + end if; + + case Get_PCS_Name is + when Name_PolyORB_DSA => + return Make_String_Literal (Loc, Get_Subprogram_Id (E)); + when others => + return Make_Integer_Literal (Loc, Get_Subprogram_Id (E)); + end case; + end Build_Subprogram_Id; + + ------------------------ + -- Copy_Specification -- + ------------------------ + + function Copy_Specification + (Loc : Source_Ptr; + Spec : Node_Id; + Ctrl_Type : Entity_Id := Empty; + New_Name : Name_Id := No_Name) return Node_Id + is + Parameters : List_Id := No_List; + + Current_Parameter : Node_Id; + Current_Identifier : Entity_Id; + Current_Type : Node_Id; + + Name_For_New_Spec : Name_Id; + + New_Identifier : Entity_Id; + + -- Comments needed in body below ??? + + begin + if New_Name = No_Name then + pragma Assert (Nkind (Spec) = N_Function_Specification + or else Nkind (Spec) = N_Procedure_Specification); + + Name_For_New_Spec := Chars (Defining_Unit_Name (Spec)); + else + Name_For_New_Spec := New_Name; + end if; + + if Present (Parameter_Specifications (Spec)) then + Parameters := New_List; + Current_Parameter := First (Parameter_Specifications (Spec)); + while Present (Current_Parameter) loop + Current_Identifier := Defining_Identifier (Current_Parameter); + Current_Type := Parameter_Type (Current_Parameter); + + if Nkind (Current_Type) = N_Access_Definition then + if Present (Ctrl_Type) then + pragma Assert (Is_Controlling_Formal (Current_Identifier)); + Current_Type := + Make_Access_Definition (Loc, + Subtype_Mark => New_Occurrence_Of (Ctrl_Type, Loc), + Null_Exclusion_Present => + Null_Exclusion_Present (Current_Type)); + + else + Current_Type := + Make_Access_Definition (Loc, + Subtype_Mark => + New_Copy_Tree (Subtype_Mark (Current_Type)), + Null_Exclusion_Present => + Null_Exclusion_Present (Current_Type)); + end if; + + else + if Present (Ctrl_Type) + and then Is_Controlling_Formal (Current_Identifier) + then + Current_Type := New_Occurrence_Of (Ctrl_Type, Loc); + else + Current_Type := New_Copy_Tree (Current_Type); + end if; + end if; + + New_Identifier := Make_Defining_Identifier (Loc, + Chars (Current_Identifier)); + + Append_To (Parameters, + Make_Parameter_Specification (Loc, + Defining_Identifier => New_Identifier, + Parameter_Type => Current_Type, + In_Present => In_Present (Current_Parameter), + Out_Present => Out_Present (Current_Parameter), + Expression => + New_Copy_Tree (Expression (Current_Parameter)))); + + -- For a regular formal parameter (that needs to be marshalled + -- in the context of remote calls), set the Etype now, because + -- marshalling processing might need it. + + if Is_Entity_Name (Current_Type) then + Set_Etype (New_Identifier, Entity (Current_Type)); + + -- Current_Type is an access definition, special processing + -- (not requiring etype) will occur for marshalling. + + else + null; + end if; + + Next (Current_Parameter); + end loop; + end if; + + case Nkind (Spec) is + + when N_Function_Specification | N_Access_Function_Definition => + return + Make_Function_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => Name_For_New_Spec), + Parameter_Specifications => Parameters, + Result_Definition => + New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc)); + + when N_Procedure_Specification | N_Access_Procedure_Definition => + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => Name_For_New_Spec), + Parameter_Specifications => Parameters); + + when others => + raise Program_Error; + end case; + end Copy_Specification; + + ----------------------------- + -- Corresponding_Stub_Type -- + ----------------------------- + + function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id is + Desig : constant Entity_Id := + Etype (Designated_Type (RACW_Type)); + Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig); + begin + return Stub_Elements.Stub_Type; + end Corresponding_Stub_Type; + + --------------------------- + -- Could_Be_Asynchronous -- + --------------------------- + + function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is + Current_Parameter : Node_Id; + + begin + if Present (Parameter_Specifications (Spec)) then + Current_Parameter := First (Parameter_Specifications (Spec)); + while Present (Current_Parameter) loop + if Out_Present (Current_Parameter) then + return False; + end if; + + Next (Current_Parameter); + end loop; + end if; + + return True; + end Could_Be_Asynchronous; + + --------------------------- + -- Declare_Create_NVList -- + --------------------------- + + procedure Declare_Create_NVList + (Loc : Source_Ptr; + NVList : Entity_Id; + Decls : List_Id; + Stmts : List_Id) + is + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => NVList, + Aliased_Present => False, + Object_Definition => + New_Occurrence_Of (RTE (RE_NVList_Ref), Loc))); + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_NVList_Create), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (NVList, Loc)))); + end Declare_Create_NVList; + + --------------------------------------------- + -- Expand_All_Calls_Remote_Subprogram_Call -- + --------------------------------------------- + + procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Called_Subprogram : constant Entity_Id := Entity (Name (N)); + RCI_Package : constant Entity_Id := Scope (Called_Subprogram); + RCI_Locator_Decl : Node_Id; + RCI_Locator : Entity_Id; + Calling_Stubs : Node_Id; + E_Calling_Stubs : Entity_Id; + + begin + E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram); + + if E_Calling_Stubs = Empty then + RCI_Locator := RCI_Locator_Table.Get (RCI_Package); + + -- The RCI_Locator package and calling stub are is inserted at the + -- top level in the current unit, and must appear in the proper scope + -- so that it is not prematurely removed by the GCC back end. + + declare + Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); + begin + if Ekind (Scop) = E_Package_Body then + Push_Scope (Spec_Entity (Scop)); + elsif Ekind (Scop) = E_Subprogram_Body then + Push_Scope + (Corresponding_Spec (Unit_Declaration_Node (Scop))); + else + Push_Scope (Scop); + end if; + end; + + if RCI_Locator = Empty then + RCI_Locator_Decl := + RCI_Package_Locator + (Loc, Specification (Unit_Declaration_Node (RCI_Package))); + Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl); + Analyze (RCI_Locator_Decl); + RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl); + + else + RCI_Locator_Decl := Parent (RCI_Locator); + end if; + + Calling_Stubs := Build_Subprogram_Calling_Stubs + (Vis_Decl => Parent (Parent (Called_Subprogram)), + Subp_Id => + Build_Subprogram_Id (Loc, Called_Subprogram), + Asynchronous => Nkind (N) = N_Procedure_Call_Statement + and then + Is_Asynchronous (Called_Subprogram), + Locator => RCI_Locator, + New_Name => New_Internal_Name ('S')); + Insert_After (RCI_Locator_Decl, Calling_Stubs); + Analyze (Calling_Stubs); + Pop_Scope; + + E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs)); + end if; + + Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc)); + end Expand_All_Calls_Remote_Subprogram_Call; + + --------------------------------- + -- Expand_Calling_Stubs_Bodies -- + --------------------------------- + + procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is + Spec : constant Node_Id := Specification (Unit_Node); + begin + Add_Calling_Stubs_To_Declarations (Spec); + end Expand_Calling_Stubs_Bodies; + + ----------------------------------- + -- Expand_Receiving_Stubs_Bodies -- + ----------------------------------- + + procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is + Spec : Node_Id; + Decls : List_Id; + Stubs_Decls : List_Id; + Stubs_Stmts : List_Id; + + begin + if Nkind (Unit_Node) = N_Package_Declaration then + Spec := Specification (Unit_Node); + Decls := Private_Declarations (Spec); + + if No (Decls) then + Decls := Visible_Declarations (Spec); + end if; + + Push_Scope (Scope_Of_Spec (Spec)); + Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls, Decls); + + else + Spec := + Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node)); + Decls := Declarations (Unit_Node); + + Push_Scope (Scope_Of_Spec (Unit_Node)); + Stubs_Decls := New_List; + Stubs_Stmts := New_List; + Specific_Add_Receiving_Stubs_To_Declarations + (Spec, Stubs_Decls, Stubs_Stmts); + + Insert_List_Before (First (Decls), Stubs_Decls); + + declare + HSS_Stmts : constant List_Id := + Statements (Handled_Statement_Sequence (Unit_Node)); + + First_HSS_Stmt : constant Node_Id := First (HSS_Stmts); + + begin + if No (First_HSS_Stmt) then + Append_List_To (HSS_Stmts, Stubs_Stmts); + else + Insert_List_Before (First_HSS_Stmt, Stubs_Stmts); + end if; + end; + end if; + + Pop_Scope; + end Expand_Receiving_Stubs_Bodies; + + -------------------- + -- GARLIC_Support -- + -------------------- + + package body GARLIC_Support is + + -- Local subprograms + + procedure Add_RACW_Read_Attribute + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Body_Decls : List_Id); + -- Add Read attribute for the RACW type. The declaration and attribute + -- definition clauses are inserted right after the declaration of + -- RACW_Type. If Body_Decls is not No_List, the subprogram body is + -- appended to it (case where the RACW declaration is in the main unit). + + procedure Add_RACW_Write_Attribute + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver : Node_Id; + Body_Decls : List_Id); + -- Same as above for the Write attribute + + function Stream_Parameter return Node_Id; + function Result return Node_Id; + function Object return Node_Id renames Result; + -- Functions to create occurrences of the formal parameter names of the + -- 'Read and 'Write attributes. + + Loc : Source_Ptr; + -- Shared source location used by Add_{Read,Write}_Read_Attribute and + -- their ancillary subroutines (set on entry by Add_RACW_Features). + + procedure Add_RAS_Access_TSS (N : Node_Id); + -- Add a subprogram body for RAS Access TSS + + ------------------------------------- + -- Add_Obj_RPC_Receiver_Completion -- + ------------------------------------- + + procedure Add_Obj_RPC_Receiver_Completion + (Loc : Source_Ptr; + Decls : List_Id; + RPC_Receiver : Entity_Id; + Stub_Elements : Stub_Structure) + is + begin + -- The RPC receiver body should not be the completion of the + -- declaration recorded in the stub structure, because then the + -- occurrences of the formal parameters within the body should refer + -- to the entities from the declaration, not from the completion, to + -- which we do not have easy access. Instead, the RPC receiver body + -- acts as its own declaration, and the RPC receiver declaration is + -- completed by a renaming-as-body. + + Append_To (Decls, + Make_Subprogram_Renaming_Declaration (Loc, + Specification => + Copy_Specification (Loc, + Specification (Stub_Elements.RPC_Receiver_Decl)), + Name => New_Occurrence_Of (RPC_Receiver, Loc))); + end Add_Obj_RPC_Receiver_Completion; + + ----------------------- + -- Add_RACW_Features -- + ----------------------- + + procedure Add_RACW_Features + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver_Decl : Node_Id; + Body_Decls : List_Id) + is + RPC_Receiver : Node_Id; + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + + begin + Loc := Sloc (RACW_Type); + + if Is_RAS then + + -- For a RAS, the RPC receiver is that of the RCI unit, not that + -- of the corresponding distributed object type. We retrieve its + -- address from the local proxy object. + + RPC_Receiver := Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object), + Selector_Name => Make_Identifier (Loc, Name_Receiver)); + + else + RPC_Receiver := Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of ( + Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc), + Attribute_Name => Name_Address); + end if; + + Add_RACW_Write_Attribute + (RACW_Type, + Stub_Type, + Stub_Type_Access, + RPC_Receiver, + Body_Decls); + + Add_RACW_Read_Attribute + (RACW_Type, + Stub_Type, + Stub_Type_Access, + Body_Decls); + end Add_RACW_Features; + + ----------------------------- + -- Add_RACW_Read_Attribute -- + ----------------------------- + + procedure Add_RACW_Read_Attribute + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Body_Decls : List_Id) + is + Proc_Decl : Node_Id; + Attr_Decl : Node_Id; + + Body_Node : Node_Id; + + Statements : constant List_Id := New_List; + Decls : List_Id; + Local_Statements : List_Id; + Remote_Statements : List_Id; + -- Various parts of the procedure + + Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); + Asynchronous_Flag : constant Entity_Id := + Asynchronous_Flags_Table.Get (RACW_Type); + pragma Assert (Present (Asynchronous_Flag)); + + -- Prepare local identifiers + + Source_Partition : Entity_Id; + Source_Receiver : Entity_Id; + Source_Address : Entity_Id; + Local_Stub : Entity_Id; + Stubbed_Result : Entity_Id; + + -- Start of processing for Add_RACW_Read_Attribute + + begin + Build_Stream_Procedure (Loc, + RACW_Type, Body_Node, Pnam, Statements, Outp => True); + Proc_Decl := Make_Subprogram_Declaration (Loc, + Copy_Specification (Loc, Specification (Body_Node))); + + Attr_Decl := + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (RACW_Type, Loc), + Chars => Name_Read, + Expression => + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Proc_Decl)), Loc)); + + Insert_After (Declaration_Node (RACW_Type), Proc_Decl); + Insert_After (Proc_Decl, Attr_Decl); + + if No (Body_Decls) then + + -- Case of processing an RACW type from another unit than the + -- main one: do not generate a body. + + return; + end if; + + -- Prepare local identifiers + + Source_Partition := Make_Temporary (Loc, 'P'); + Source_Receiver := Make_Temporary (Loc, 'S'); + Source_Address := Make_Temporary (Loc, 'P'); + Local_Stub := Make_Temporary (Loc, 'L'); + Stubbed_Result := Make_Temporary (Loc, 'S'); + + -- Generate object declarations + + Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Source_Partition, + Object_Definition => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Source_Receiver, + Object_Definition => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Source_Address, + Object_Definition => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Local_Stub, + Aliased_Present => True, + Object_Definition => New_Occurrence_Of (Stub_Type, Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Stubbed_Result, + Object_Definition => + New_Occurrence_Of (Stub_Type_Access, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Local_Stub, Loc), + Attribute_Name => + Name_Unchecked_Access))); + + -- Read the source Partition_ID and RPC_Receiver from incoming stream + + Append_List_To (Statements, New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Stream_Parameter, + New_Occurrence_Of (Source_Partition, Loc))), + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), + Attribute_Name => + Name_Read, + Expressions => New_List ( + Stream_Parameter, + New_Occurrence_Of (Source_Receiver, Loc))), + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), + Attribute_Name => + Name_Read, + Expressions => New_List ( + Stream_Parameter, + New_Occurrence_Of (Source_Address, Loc))))); + + -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result + + Set_Etype (Stubbed_Result, Stub_Type_Access); + + -- If the Address is Null_Address, then return a null object, unless + -- RACW_Type is null-excluding, in which case unconditionally raise + -- CONSTRAINT_ERROR instead. + + declare + Zero_Statements : List_Id; + -- Statements executed when a zero value is received + + begin + if Can_Never_Be_Null (RACW_Type) then + Zero_Statements := New_List ( + Make_Raise_Constraint_Error (Loc, + Reason => CE_Null_Not_Allowed)); + else + Zero_Statements := New_List ( + Make_Assignment_Statement (Loc, + Name => Result, + Expression => Make_Null (Loc)), + Make_Simple_Return_Statement (Loc)); + end if; + + Append_To (Statements, + Make_Implicit_If_Statement (RACW_Type, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Source_Address, Loc), + Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), + Then_Statements => Zero_Statements)); + end; + + -- If the RACW denotes an object created on the current partition, + -- Local_Statements will be executed. The real object will be used. + + Local_Statements := New_List ( + Make_Assignment_Statement (Loc, + Name => Result, + Expression => + Unchecked_Convert_To (RACW_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Source_Address, Loc))))); + + -- If the object is located on another partition, then a stub object + -- will be created with all the information needed to rebuild the + -- real object at the other end. + + Remote_Statements := New_List ( + + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => Stubbed_Result, + Selector_Name => Name_Origin), + Expression => + New_Occurrence_Of (Source_Partition, Loc)), + + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => Stubbed_Result, + Selector_Name => Name_Receiver), + Expression => + New_Occurrence_Of (Source_Receiver, Loc)), + + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => Stubbed_Result, + Selector_Name => Name_Addr), + Expression => + New_Occurrence_Of (Source_Address, Loc))); + + Append_To (Remote_Statements, + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => Stubbed_Result, + Selector_Name => Name_Asynchronous), + Expression => + New_Occurrence_Of (Asynchronous_Flag, Loc))); + + Append_List_To (Remote_Statements, + Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type)); + -- ??? Issue with asynchronous calls here: the Asynchronous flag is + -- set on the stub type if, and only if, the RACW type has a pragma + -- Asynchronous. This is incorrect for RACWs that implement RAS + -- types, because in that case the /designated subprogram/ (not the + -- type) might be asynchronous, and that causes the stub to need to + -- be asynchronous too. A solution is to transport a RAS as a struct + -- containing a RACW and an asynchronous flag, and to properly alter + -- the Asynchronous component in the stub type in the RAS's Input + -- TSS. + + Append_To (Remote_Statements, + Make_Assignment_Statement (Loc, + Name => Result, + Expression => Unchecked_Convert_To (RACW_Type, + New_Occurrence_Of (Stubbed_Result, Loc)))); + + -- Distinguish between the local and remote cases, and execute the + -- appropriate piece of code. + + Append_To (Statements, + Make_Implicit_If_Statement (RACW_Type, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Get_Local_Partition_Id), Loc)), + Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)), + Then_Statements => Local_Statements, + Else_Statements => Remote_Statements)); + + Set_Declarations (Body_Node, Decls); + Append_To (Body_Decls, Body_Node); + end Add_RACW_Read_Attribute; + + ------------------------------ + -- Add_RACW_Write_Attribute -- + ------------------------------ + + procedure Add_RACW_Write_Attribute + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver : Node_Id; + Body_Decls : List_Id) + is + Body_Node : Node_Id; + Proc_Decl : Node_Id; + Attr_Decl : Node_Id; + + Statements : constant List_Id := New_List; + Local_Statements : List_Id; + Remote_Statements : List_Id; + Null_Statements : List_Id; + + Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); + + begin + Build_Stream_Procedure + (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False); + + Proc_Decl := Make_Subprogram_Declaration (Loc, + Copy_Specification (Loc, Specification (Body_Node))); + + Attr_Decl := + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (RACW_Type, Loc), + Chars => Name_Write, + Expression => + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Proc_Decl)), Loc)); + + Insert_After (Declaration_Node (RACW_Type), Proc_Decl); + Insert_After (Proc_Decl, Attr_Decl); + + if No (Body_Decls) then + return; + end if; + + -- Build the code fragment corresponding to the marshalling of a + -- local object. + + Local_Statements := New_List ( + + Pack_Entity_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => RTE (RE_Get_Local_Partition_Id)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver), + Etyp => RTE (RE_Unsigned_64)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => OK_Convert_To (RTE (RE_Unsigned_64), + Make_Attribute_Reference (Loc, + Prefix => + Make_Explicit_Dereference (Loc, + Prefix => Object), + Attribute_Name => Name_Address)), + Etyp => RTE (RE_Unsigned_64))); + + -- Build the code fragment corresponding to the marshalling of + -- a remote object. + + Remote_Statements := New_List ( + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Stub_Type_Access, Object), + Selector_Name => Make_Identifier (Loc, Name_Origin)), + Etyp => RTE (RE_Partition_ID)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Stub_Type_Access, Object), + Selector_Name => Make_Identifier (Loc, Name_Receiver)), + Etyp => RTE (RE_Unsigned_64)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Stub_Type_Access, Object), + Selector_Name => Make_Identifier (Loc, Name_Addr)), + Etyp => RTE (RE_Unsigned_64))); + + -- Build code fragment corresponding to marshalling of a null object + + Null_Statements := New_List ( + + Pack_Entity_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => RTE (RE_Get_Local_Partition_Id)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver), + Etyp => RTE (RE_Unsigned_64)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => Make_Integer_Literal (Loc, Uint_0), + Etyp => RTE (RE_Unsigned_64))); + + Append_To (Statements, + Make_Implicit_If_Statement (RACW_Type, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => Object, + Right_Opnd => Make_Null (Loc)), + + Then_Statements => Null_Statements, + + Elsif_Parts => New_List ( + Make_Elsif_Part (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => Object, + Attribute_Name => Name_Tag), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stub_Type, Loc), + Attribute_Name => Name_Tag)), + Then_Statements => Remote_Statements)), + Else_Statements => Local_Statements)); + + Append_To (Body_Decls, Body_Node); + end Add_RACW_Write_Attribute; + + ------------------------ + -- Add_RAS_Access_TSS -- + ------------------------ + + procedure Add_RAS_Access_TSS (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Ras_Type : constant Entity_Id := Defining_Identifier (N); + Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type); + -- Ras_Type is the access to subprogram type while Fat_Type is the + -- corresponding record type. + + RACW_Type : constant Entity_Id := + Underlying_RACW_Type (Ras_Type); + Desig : constant Entity_Id := + Etype (Designated_Type (RACW_Type)); + + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Desig); + pragma Assert (Stub_Elements /= Empty_Stub_Structure); + + Proc : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access)); + + Proc_Spec : Node_Id; + + -- Formal parameters + + Package_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_P); + -- Target package + + Subp_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_S); + -- Target subprogram + + Asynch_P : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_Asynchronous); + -- Is the procedure to which the 'Access applies asynchronous? + + All_Calls_Remote : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_All_Calls_Remote); + -- True if an All_Calls_Remote pragma applies to the RCI unit + -- that contains the subprogram. + + -- Common local variables + + Proc_Decls : List_Id; + Proc_Statements : List_Id; + + Origin : constant Entity_Id := Make_Temporary (Loc, 'P'); + + -- Additional local variables for the local case + + Proxy_Addr : constant Entity_Id := Make_Temporary (Loc, 'P'); + + -- Additional local variables for the remote case + + Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L'); + Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S'); + + function Set_Field + (Field_Name : Name_Id; + Value : Node_Id) return Node_Id; + -- Construct an assignment that sets the named component in the + -- returned record + + --------------- + -- Set_Field -- + --------------- + + function Set_Field + (Field_Name : Name_Id; + Value : Node_Id) return Node_Id + is + begin + return + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Stub_Ptr, + Selector_Name => Field_Name), + Expression => Value); + end Set_Field; + + -- Start of processing for Add_RAS_Access_TSS + + begin + Proc_Decls := New_List ( + + -- Common declarations + + Make_Object_Declaration (Loc, + Defining_Identifier => Origin, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Package_Name, Loc)))), + + -- Declaration use only in the local case: proxy address + + Make_Object_Declaration (Loc, + Defining_Identifier => Proxy_Addr, + Object_Definition => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + + -- Declarations used only in the remote case: stub object and + -- stub pointer. + + Make_Object_Declaration (Loc, + Defining_Identifier => Local_Stub, + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => + Stub_Ptr, + Object_Definition => + New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Local_Stub, Loc), + Attribute_Name => Name_Unchecked_Access))); + + Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access); + + -- Build_Get_Unique_RP_Call needs above information + + -- Note: Here we assume that the Fat_Type is a record + -- containing just a pointer to a proxy or stub object. + + Proc_Statements := New_List ( + + -- Generate: + + -- Get_RAS_Info (Pkg, Subp, PA); + -- if Origin = Local_Partition_Id + -- and then not All_Calls_Remote + -- then + -- return Fat_Type!(PA); + -- end if; + + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Package_Name, Loc), + New_Occurrence_Of (Subp_Id, Loc), + New_Occurrence_Of (Proxy_Addr, Loc))), + + Make_Implicit_If_Statement (N, + Condition => + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Occurrence_Of (Origin, Loc), + Right_Opnd => + Make_Function_Call (Loc, + New_Occurrence_Of ( + RTE (RE_Get_Local_Partition_Id), Loc))), + + Right_Opnd => + Make_Op_Not (Loc, + New_Occurrence_Of (All_Calls_Remote, Loc))), + + Then_Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Unchecked_Convert_To (Fat_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Proxy_Addr, Loc)))))), + + Set_Field (Name_Origin, + New_Occurrence_Of (Origin, Loc)), + + Set_Field (Name_Receiver, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Package_Name, Loc)))), + + Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)), + + -- E.4.1(9) A remote call is asynchronous if it is a call to + -- a procedure or a call through a value of an access-to-procedure + -- type to which a pragma Asynchronous applies. + + -- Asynch_P is true when the procedure is asynchronous; + -- Asynch_T is true when the type is asynchronous. + + Set_Field (Name_Asynchronous, + Make_Or_Else (Loc, + New_Occurrence_Of (Asynch_P, Loc), + New_Occurrence_Of (Boolean_Literals ( + Is_Asynchronous (Ras_Type)), Loc)))); + + Append_List_To (Proc_Statements, + Build_Get_Unique_RP_Call + (Loc, Stub_Ptr, Stub_Elements.Stub_Type)); + + -- Return the newly created value + + Append_To (Proc_Statements, + Make_Simple_Return_Statement (Loc, + Expression => + Unchecked_Convert_To (Fat_Type, + New_Occurrence_Of (Stub_Ptr, Loc)))); + + Proc_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Proc, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Package_Name, + Parameter_Type => + New_Occurrence_Of (Standard_String, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Subp_Id, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Asynch_P, + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => All_Calls_Remote, + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc))), + + Result_Definition => + New_Occurrence_Of (Fat_Type, Loc)); + + -- Set the kind and return type of the function to prevent + -- ambiguities between Ras_Type and Fat_Type in subsequent analysis. + + Set_Ekind (Proc, E_Function); + Set_Etype (Proc, Fat_Type); + + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => Proc_Spec, + Declarations => Proc_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Proc_Statements))); + + Set_TSS (Fat_Type, Proc); + end Add_RAS_Access_TSS; + + ----------------------- + -- Add_RAST_Features -- + ----------------------- + + procedure Add_RAST_Features + (Vis_Decl : Node_Id; + RAS_Type : Entity_Id) + is + pragma Unreferenced (RAS_Type); + begin + Add_RAS_Access_TSS (Vis_Decl); + end Add_RAST_Features; + + ----------------------------------------- + -- Add_Receiving_Stubs_To_Declarations -- + ----------------------------------------- + + procedure Add_Receiving_Stubs_To_Declarations + (Pkg_Spec : Node_Id; + Decls : List_Id; + Stmts : List_Id) + is + Loc : constant Source_Ptr := Sloc (Pkg_Spec); + + Request_Parameter : Node_Id; + + Pkg_RPC_Receiver : constant Entity_Id := + Make_Temporary (Loc, 'H'); + Pkg_RPC_Receiver_Statements : List_Id; + Pkg_RPC_Receiver_Cases : constant List_Id := New_List; + Pkg_RPC_Receiver_Body : Node_Id; + -- A Pkg_RPC_Receiver is built to decode the request + + Lookup_RAS : Node_Id; + Lookup_RAS_Info : constant Entity_Id := Make_Temporary (Loc, 'R'); + -- A remote subprogram is created to allow peers to look up RAS + -- information using subprogram ids. + + Subp_Id : Entity_Id; + Subp_Index : Entity_Id; + -- Subprogram_Id as read from the incoming stream + + Current_Subp_Number : Int := First_RCI_Subprogram_Id; + Current_Stubs : Node_Id; + + Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I'); + Subp_Info_List : constant List_Id := New_List; + + Register_Pkg_Actuals : constant List_Id := New_List; + + All_Calls_Remote_E : Entity_Id; + Proxy_Object_Addr : Entity_Id; + + procedure Append_Stubs_To + (RPC_Receiver_Cases : List_Id; + Stubs : Node_Id; + Subprogram_Number : Int); + -- Add one case to the specified RPC receiver case list + -- associating Subprogram_Number with the subprogram declared + -- by Declaration, for which we have receiving stubs in Stubs. + + procedure Visit_Subprogram (Decl : Node_Id); + -- Generate receiving stub for one remote subprogram + + --------------------- + -- Append_Stubs_To -- + --------------------- + + procedure Append_Stubs_To + (RPC_Receiver_Cases : List_Id; + Stubs : Node_Id; + Subprogram_Number : Int) + is + begin + Append_To (RPC_Receiver_Cases, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_List (Make_Integer_Literal (Loc, Subprogram_Number)), + Statements => + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (Defining_Entity (Stubs), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Request_Parameter, Loc)))))); + end Append_Stubs_To; + + ---------------------- + -- Visit_Subprogram -- + ---------------------- + + procedure Visit_Subprogram (Decl : Node_Id) is + Loc : constant Source_Ptr := Sloc (Decl); + Spec : constant Node_Id := Specification (Decl); + Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec); + + Subp_Val : String_Id; + pragma Warnings (Off, Subp_Val); + + begin + -- Build receiving stub + + Current_Stubs := + Build_Subprogram_Receiving_Stubs + (Vis_Decl => Decl, + Asynchronous => + Nkind (Spec) = N_Procedure_Specification + and then Is_Asynchronous (Subp_Def)); + + Append_To (Decls, Current_Stubs); + Analyze (Current_Stubs); + + -- Build RAS proxy + + Add_RAS_Proxy_And_Analyze (Decls, + Vis_Decl => Decl, + All_Calls_Remote_E => All_Calls_Remote_E, + Proxy_Object_Addr => Proxy_Object_Addr); + + -- Compute distribution identifier + + Assign_Subprogram_Identifier + (Subp_Def, Current_Subp_Number, Subp_Val); + + pragma Assert (Current_Subp_Number = Get_Subprogram_Id (Subp_Def)); + + -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms + -- table for this receiver. This aggregate must be kept consistent + -- with the declaration of RCI_Subp_Info in + -- System.Partition_Interface. + + Append_To (Subp_Info_List, + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, Current_Subp_Number)), + + Expression => + Make_Aggregate (Loc, + Component_Associations => New_List ( + + -- Addr => + + Make_Component_Association (Loc, + Choices => + New_List (Make_Identifier (Loc, Name_Addr)), + Expression => + New_Occurrence_Of (Proxy_Object_Addr, Loc)))))); + + Append_Stubs_To (Pkg_RPC_Receiver_Cases, + Stubs => Current_Stubs, + Subprogram_Number => Current_Subp_Number); + + Current_Subp_Number := Current_Subp_Number + 1; + end Visit_Subprogram; + + procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram); + + -- Start of processing for Add_Receiving_Stubs_To_Declarations + + begin + -- Building receiving stubs consist in several operations: + + -- - a package RPC receiver must be built. This subprogram + -- will get a Subprogram_Id from the incoming stream + -- and will dispatch the call to the right subprogram; + + -- - a receiving stub for each subprogram visible in the package + -- spec. This stub will read all the parameters from the stream, + -- and put the result as well as the exception occurrence in the + -- output stream; + + -- - a dummy package with an empty spec and a body made of an + -- elaboration part, whose job is to register the receiving + -- part of this RCI package on the name server. This is done + -- by calling System.Partition_Interface.Register_Receiving_Stub. + + Build_RPC_Receiver_Body ( + RPC_Receiver => Pkg_RPC_Receiver, + Request => Request_Parameter, + Subp_Id => Subp_Id, + Subp_Index => Subp_Index, + Stmts => Pkg_RPC_Receiver_Statements, + Decl => Pkg_RPC_Receiver_Body); + pragma Assert (Subp_Id = Subp_Index); + + -- A null subp_id denotes a call through a RAS, in which case the + -- next Uint_64 element in the stream is the address of the local + -- proxy object, from which we can retrieve the actual subprogram id. + + Append_To (Pkg_RPC_Receiver_Statements, + Make_Implicit_If_Statement (Pkg_Spec, + Condition => + Make_Op_Eq (Loc, + New_Occurrence_Of (Subp_Id, Loc), + Make_Integer_Literal (Loc, 0)), + + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of (Subp_Id, Loc), + + Expression => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), + OK_Convert_To (RTE (RE_Address), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), + Attribute_Name => + Name_Input, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Params))))), + + Selector_Name => Make_Identifier (Loc, Name_Subp_Id)))))); + + -- Build a subprogram for RAS information lookups + + Lookup_RAS := + Make_Subprogram_Declaration (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => + Lookup_RAS_Info, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Subp_Id), + In_Present => + True, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))), + Result_Definition => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))); + Append_To (Decls, Lookup_RAS); + Analyze (Lookup_RAS); + + Current_Stubs := Build_Subprogram_Receiving_Stubs + (Vis_Decl => Lookup_RAS, + Asynchronous => False); + Append_To (Decls, Current_Stubs); + Analyze (Current_Stubs); + + Append_Stubs_To (Pkg_RPC_Receiver_Cases, + Stubs => Current_Stubs, + Subprogram_Number => 1); + + -- For each subprogram, the receiving stub will be built and a + -- case statement will be made on the Subprogram_Id to dispatch + -- to the right subprogram. + + All_Calls_Remote_E := + Boolean_Literals + (Has_All_Calls_Remote (Defining_Entity (Pkg_Spec))); + + Overload_Counter_Table.Reset; + + Visit_Spec (Pkg_Spec); + + -- If we receive an invalid Subprogram_Id, it is best to do nothing + -- rather than raising an exception since we do not want someone + -- to crash a remote partition by sending invalid subprogram ids. + -- This is consistent with the other parts of the case statement + -- since even in presence of incorrect parameters in the stream, + -- every exception will be caught and (if the subprogram is not an + -- APC) put into the result stream and sent away. + + Append_To (Pkg_RPC_Receiver_Cases, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List (Make_Null_Statement (Loc)))); + + Append_To (Pkg_RPC_Receiver_Statements, + Make_Case_Statement (Loc, + Expression => New_Occurrence_Of (Subp_Id, Loc), + Alternatives => Pkg_RPC_Receiver_Cases)); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Info_Array, + Constant_Present => True, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, + First_RCI_Subprogram_Id), + High_Bound => + Make_Integer_Literal (Loc, + Intval => + First_RCI_Subprogram_Id + + List_Length (Subp_Info_List) - 1))))))); + + -- For a degenerate RCI with no visible subprograms, Subp_Info_List + -- has zero length, and the declaration is for an empty array, in + -- which case no initialization aggregate must be generated. + + if Present (First (Subp_Info_List)) then + Set_Expression (Last (Decls), + Make_Aggregate (Loc, + Component_Associations => Subp_Info_List)); + + -- No initialization provided: remove CONSTANT so that the + -- declaration is not an incomplete deferred constant. + + else + Set_Constant_Present (Last (Decls), False); + end if; + + Analyze (Last (Decls)); + + declare + Subp_Info_Addr : Node_Id; + -- Return statement for Lookup_RAS_Info: address of the subprogram + -- information record for the requested subprogram id. + + begin + if Present (First (Subp_Info_List)) then + Subp_Info_Addr := + Make_Selected_Component (Loc, + Prefix => + Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), + Expressions => New_List ( + Convert_To (Standard_Integer, + Make_Identifier (Loc, Name_Subp_Id)))), + Selector_Name => Make_Identifier (Loc, Name_Addr)); + + -- Case of no visible subprogram: just raise Constraint_Error, we + -- know for sure we got junk from a remote partition. + + else + Subp_Info_Addr := + Make_Raise_Constraint_Error (Loc, + Reason => CE_Range_Check_Failed); + Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64)); + end if; + + Append_To (Decls, + Make_Subprogram_Body (Loc, + Specification => + Copy_Specification (Loc, Parent (Lookup_RAS_Info)), + Declarations => No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + OK_Convert_To + (RTE (RE_Unsigned_64), Subp_Info_Addr)))))); + end; + + Analyze (Last (Decls)); + + Append_To (Decls, Pkg_RPC_Receiver_Body); + Analyze (Last (Decls)); + + Get_Library_Unit_Name_String (Pkg_Spec); + + -- Name + + Append_To (Register_Pkg_Actuals, + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer)); + + -- Receiver + + Append_To (Register_Pkg_Actuals, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc), + Attribute_Name => Name_Unrestricted_Access)); + + -- Version + + Append_To (Register_Pkg_Actuals, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), + Attribute_Name => Name_Version)); + + -- Subp_Info + + Append_To (Register_Pkg_Actuals, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => Name_Address)); + + -- Subp_Info_Len + + Append_To (Register_Pkg_Actuals, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => Name_Length)); + + -- Generate the call + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc), + Parameter_Associations => Register_Pkg_Actuals)); + Analyze (Last (Stmts)); + end Add_Receiving_Stubs_To_Declarations; + + --------------------------------- + -- Build_General_Calling_Stubs -- + --------------------------------- + + procedure Build_General_Calling_Stubs + (Decls : List_Id; + Statements : List_Id; + Target_Partition : Entity_Id; + Target_RPC_Receiver : Node_Id; + Subprogram_Id : Node_Id; + Asynchronous : Node_Id := Empty; + Is_Known_Asynchronous : Boolean := False; + Is_Known_Non_Asynchronous : Boolean := False; + Is_Function : Boolean; + Spec : Node_Id; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Nod : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Nod); + + Stream_Parameter : Node_Id; + -- Name of the stream used to transmit parameters to the remote + -- package. + + Result_Parameter : Node_Id; + -- Name of the result parameter (in non-APC cases) which get the + -- result of the remote subprogram. + + Exception_Return_Parameter : Node_Id; + -- Name of the parameter which will hold the exception sent by the + -- remote subprogram. + + Current_Parameter : Node_Id; + -- Current parameter being handled + + Ordered_Parameters_List : constant List_Id := + Build_Ordered_Parameters_List (Spec); + + Asynchronous_Statements : List_Id := No_List; + Non_Asynchronous_Statements : List_Id := No_List; + -- Statements specifics to the Asynchronous/Non-Asynchronous cases + + Extra_Formal_Statements : constant List_Id := New_List; + -- List of statements for extra formal parameters. It will appear + -- after the regular statements for writing out parameters. + + pragma Unreferenced (RACW_Type); + -- Used only for the PolyORB case + + begin + -- The general form of a calling stub for a given subprogram is: + + -- procedure X (...) is P : constant Partition_ID := + -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased + -- System.RPC.Params_Stream_Type (0); begin + -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver + -- comes from RCI_Cache.Get_RCI_Package_Receiver) + -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC + -- (Stream, Result); Read_Exception_Occurrence_From_Result; + -- Raise_It; + -- Read_Out_Parameters_And_Function_Return_From_Stream; end X; + + -- There are some variations: Do_APC is called for an asynchronous + -- procedure and the part after the call is completely ommitted as + -- well as the declaration of Result. For a function call, 'Input is + -- always used to read the result even if it is constrained. + + Stream_Parameter := Make_Temporary (Loc, 'S'); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Stream_Parameter, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => + New_List (Make_Integer_Literal (Loc, 0)))))); + + if not Is_Known_Asynchronous then + Result_Parameter := Make_Temporary (Loc, 'R'); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Result_Parameter, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => + New_List (Make_Integer_Literal (Loc, 0)))))); + + Exception_Return_Parameter := Make_Temporary (Loc, 'E'); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Exception_Return_Parameter, + Object_Definition => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc))); + + else + Result_Parameter := Empty; + Exception_Return_Parameter := Empty; + end if; + + -- Put first the RPC receiver corresponding to the remote package + + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + Target_RPC_Receiver))); + + -- Then put the Subprogram_Id of the subprogram we want to call in + -- the stream. + + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + Subprogram_Id))); + + Current_Parameter := First (Ordered_Parameters_List); + while Present (Current_Parameter) loop + declare + Typ : constant Node_Id := + Parameter_Type (Current_Parameter); + Etyp : Entity_Id; + Constrained : Boolean; + Value : Node_Id; + Extra_Parameter : Entity_Id; + + begin + if Is_RACW_Controlling_Formal + (Current_Parameter, Stub_Type) + then + -- In the case of a controlling formal argument, we marshall + -- its addr field rather than the local stub. + + Append_To (Statements, + Pack_Node_Into_Stream (Loc, + Stream => Stream_Parameter, + Object => + Make_Selected_Component (Loc, + Prefix => + Defining_Identifier (Current_Parameter), + Selector_Name => Name_Addr), + Etyp => RTE (RE_Unsigned_64))); + + else + Value := + New_Occurrence_Of + (Defining_Identifier (Current_Parameter), Loc); + + -- Access type parameters are transmitted as in out + -- parameters. However, a dereference is needed so that + -- we marshall the designated object. + + if Nkind (Typ) = N_Access_Definition then + Value := Make_Explicit_Dereference (Loc, Value); + Etyp := Etype (Subtype_Mark (Typ)); + else + Etyp := Etype (Typ); + end if; + + Constrained := not Transmit_As_Unconstrained (Etyp); + + -- Any parameter but unconstrained out parameters are + -- transmitted to the peer. + + if In_Present (Current_Parameter) + or else not Out_Present (Current_Parameter) + or else not Constrained + then + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => + Output_From_Constrained (Constrained), + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + Value))); + end if; + end if; + + -- If the current parameter has a dynamic constrained status, + -- then this status is transmitted as well. + -- This should be done for accessibility as well ??? + + if Nkind (Typ) /= N_Access_Definition + and then Need_Extra_Constrained (Current_Parameter) + then + -- In this block, we do not use the extra formal that has + -- been created because it does not exist at the time of + -- expansion when building calling stubs for remote access + -- to subprogram types. We create an extra variable of this + -- type and push it in the stream after the regular + -- parameters. + + Extra_Parameter := Make_Temporary (Loc, 'P'); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Extra_Parameter, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Attribute_Name => Name_Constrained))); + + Append_To (Extra_Formal_Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Stream_Parameter, Loc), Attribute_Name => + Name_Access), + New_Occurrence_Of (Extra_Parameter, Loc)))); + end if; + + Next (Current_Parameter); + end; + end loop; + + -- Append the formal statements list to the statements + + Append_List_To (Statements, Extra_Formal_Statements); + + if not Is_Known_Non_Asynchronous then + + -- Build the call to System.RPC.Do_APC + + Asynchronous_Statements := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Do_Apc), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Target_Partition, Loc), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access)))); + else + Asynchronous_Statements := No_List; + end if; + + if not Is_Known_Asynchronous then + + -- Build the call to System.RPC.Do_RPC + + Non_Asynchronous_Statements := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Do_Rpc), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Target_Partition, Loc), + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Result_Parameter, Loc), + Attribute_Name => Name_Access)))); + + -- Read the exception occurrence from the result stream and + -- reraise it. It does no harm if this is a Null_Occurrence since + -- this does nothing. + + Append_To (Non_Asynchronous_Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), + + Attribute_Name => Name_Read, + + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Result_Parameter, Loc), + Attribute_Name => Name_Access), + New_Occurrence_Of (Exception_Return_Parameter, Loc)))); + + Append_To (Non_Asynchronous_Statements, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Exception_Return_Parameter, Loc)))); + + if Is_Function then + + -- If this is a function call, then read the value and return + -- it. The return value is written/read using 'Output/'Input. + + Append_To (Non_Asynchronous_Statements, + Make_Tag_Check (Loc, + Make_Simple_Return_Statement (Loc, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of ( + Etype (Result_Definition (Spec)), Loc), + + Attribute_Name => Name_Input, + + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Result_Parameter, Loc), + Attribute_Name => Name_Access)))))); + + else + -- Loop around parameters and assign out (or in out) + -- parameters. In the case of RACW, controlling arguments + -- cannot possibly have changed since they are remote, so + -- we do not read them from the stream. + + Current_Parameter := First (Ordered_Parameters_List); + while Present (Current_Parameter) loop + declare + Typ : constant Node_Id := + Parameter_Type (Current_Parameter); + Etyp : Entity_Id; + Value : Node_Id; + + begin + Value := + New_Occurrence_Of + (Defining_Identifier (Current_Parameter), Loc); + + if Nkind (Typ) = N_Access_Definition then + Value := Make_Explicit_Dereference (Loc, Value); + Etyp := Etype (Subtype_Mark (Typ)); + else + Etyp := Etype (Typ); + end if; + + if (Out_Present (Current_Parameter) + or else Nkind (Typ) = N_Access_Definition) + and then Etyp /= Stub_Type + then + Append_To (Non_Asynchronous_Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Etyp, Loc), + + Attribute_Name => Name_Read, + + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Result_Parameter, Loc), + Attribute_Name => Name_Access), + Value))); + end if; + end; + + Next (Current_Parameter); + end loop; + end if; + end if; + + if Is_Known_Asynchronous then + Append_List_To (Statements, Asynchronous_Statements); + + elsif Is_Known_Non_Asynchronous then + Append_List_To (Statements, Non_Asynchronous_Statements); + + else + pragma Assert (Present (Asynchronous)); + Prepend_To (Asynchronous_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + New_Occurrence_Of (Standard_True, Loc)))); + + Prepend_To (Non_Asynchronous_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + New_Occurrence_Of (Standard_False, Loc)))); + + Append_To (Statements, + Make_Implicit_If_Statement (Nod, + Condition => Asynchronous, + Then_Statements => Asynchronous_Statements, + Else_Statements => Non_Asynchronous_Statements)); + end if; + end Build_General_Calling_Stubs; + + ----------------------------- + -- Build_RPC_Receiver_Body -- + ----------------------------- + + procedure Build_RPC_Receiver_Body + (RPC_Receiver : Entity_Id; + Request : out Entity_Id; + Subp_Id : out Entity_Id; + Subp_Index : out Entity_Id; + Stmts : out List_Id; + Decl : out Node_Id) + is + Loc : constant Source_Ptr := Sloc (RPC_Receiver); + + RPC_Receiver_Spec : Node_Id; + RPC_Receiver_Decls : List_Id; + + begin + Request := Make_Defining_Identifier (Loc, Name_R); + + RPC_Receiver_Spec := + Build_RPC_Receiver_Specification + (RPC_Receiver => RPC_Receiver, + Request_Parameter => Request); + + Subp_Id := Make_Temporary (Loc, 'P'); + Subp_Index := Subp_Id; + + -- Subp_Id may not be a constant, because in the case of the RPC + -- receiver for an RCI package, when a call is received from a RAS + -- dereference, it will be assigned during subsequent processing. + + RPC_Receiver_Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Id, + Object_Definition => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Attribute_Name => Name_Input, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request, + Selector_Name => Name_Params))))); + + Stmts := New_List; + + Decl := + Make_Subprogram_Body (Loc, + Specification => RPC_Receiver_Spec, + Declarations => RPC_Receiver_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + end Build_RPC_Receiver_Body; + + ----------------------- + -- Build_Stub_Target -- + ----------------------- + + function Build_Stub_Target + (Loc : Source_Ptr; + Decls : List_Id; + RCI_Locator : Entity_Id; + Controlling_Parameter : Entity_Id) return RPC_Target + is + Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA); + + begin + Target_Info.Partition := Make_Temporary (Loc, 'P'); + + if Present (Controlling_Parameter) then + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Target_Info.Partition, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + + Expression => + Make_Selected_Component (Loc, + Prefix => Controlling_Parameter, + Selector_Name => Name_Origin))); + + Target_Info.RPC_Receiver := + Make_Selected_Component (Loc, + Prefix => Controlling_Parameter, + Selector_Name => Name_Receiver); + + else + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Target_Info.Partition, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + + Expression => + Make_Function_Call (Loc, + Name => Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Chars (RCI_Locator)), + Selector_Name => + Make_Identifier (Loc, + Name_Get_Active_Partition_ID))))); + + Target_Info.RPC_Receiver := + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Chars (RCI_Locator)), + Selector_Name => + Make_Identifier (Loc, Name_Get_RCI_Package_Receiver)); + end if; + return Target_Info; + end Build_Stub_Target; + + --------------------- + -- Build_Stub_Type -- + --------------------- + + procedure Build_Stub_Type + (RACW_Type : Entity_Id; + Stub_Type_Comps : out List_Id; + RPC_Receiver_Decl : out Node_Id) + is + Loc : constant Source_Ptr := Sloc (RACW_Type); + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + + begin + Stub_Type_Comps := New_List ( + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Origin), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc))), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Receiver), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Addr), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Asynchronous), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (Standard_Boolean, Loc)))); + + if Is_RAS then + RPC_Receiver_Decl := Empty; + else + declare + RPC_Receiver_Request : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_R); + begin + RPC_Receiver_Decl := + Make_Subprogram_Declaration (Loc, + Build_RPC_Receiver_Specification + (RPC_Receiver => Make_Temporary (Loc, 'R'), + Request_Parameter => RPC_Receiver_Request)); + end; + end if; + end Build_Stub_Type; + + -------------------------------------- + -- Build_Subprogram_Receiving_Stubs -- + -------------------------------------- + + function Build_Subprogram_Receiving_Stubs + (Vis_Decl : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Parent_Primitive : Entity_Id := Empty) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Vis_Decl); + + Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R'); + -- Formal parameter for receiving stubs: a descriptor for an incoming + -- request. + + Decls : constant List_Id := New_List; + -- All the parameters will get declared before calling the real + -- subprograms. Also the out parameters will be declared. + + Statements : constant List_Id := New_List; + + Extra_Formal_Statements : constant List_Id := New_List; + -- Statements concerning extra formal parameters + + After_Statements : constant List_Id := New_List; + -- Statements to be executed after the subprogram call + + Inner_Decls : List_Id := No_List; + -- In case of a function, the inner declarations are needed since + -- the result may be unconstrained. + + Excep_Handlers : List_Id := No_List; + Excep_Choice : Entity_Id; + Excep_Code : List_Id; + + Parameter_List : constant List_Id := New_List; + -- List of parameters to be passed to the subprogram + + Current_Parameter : Node_Id; + + Ordered_Parameters_List : constant List_Id := + Build_Ordered_Parameters_List + (Specification (Vis_Decl)); + + Subp_Spec : Node_Id; + -- Subprogram specification + + Called_Subprogram : Node_Id; + -- The subprogram to call + + Null_Raise_Statement : Node_Id; + + Dynamic_Async : Entity_Id; + + begin + if Present (RACW_Type) then + Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc); + else + Called_Subprogram := + New_Occurrence_Of + (Defining_Unit_Name (Specification (Vis_Decl)), Loc); + end if; + + if Dynamically_Asynchronous then + Dynamic_Async := Make_Temporary (Loc, 'S'); + else + Dynamic_Async := Empty; + end if; + + if not Asynchronous or Dynamically_Asynchronous then + + -- The first statement after the subprogram call is a statement to + -- write a Null_Occurrence into the result stream. + + Null_Raise_Statement := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Result), + New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc))); + + if Dynamically_Asynchronous then + Null_Raise_Statement := + Make_Implicit_If_Statement (Vis_Decl, + Condition => + Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)), + Then_Statements => New_List (Null_Raise_Statement)); + end if; + + Append_To (After_Statements, Null_Raise_Statement); + end if; + + -- Loop through every parameter and get its value from the stream. If + -- the parameter is unconstrained, then the parameter is read using + -- 'Input at the point of declaration. + + Current_Parameter := First (Ordered_Parameters_List); + while Present (Current_Parameter) loop + declare + Etyp : Entity_Id; + Constrained : Boolean; + + Need_Extra_Constrained : Boolean; + -- True when an Extra_Constrained actual is required + + Object : constant Entity_Id := Make_Temporary (Loc, 'P'); + + Expr : Node_Id := Empty; + + Is_Controlling_Formal : constant Boolean := + Is_RACW_Controlling_Formal + (Current_Parameter, Stub_Type); + + begin + if Is_Controlling_Formal then + + -- We have a controlling formal parameter. Read its address + -- rather than a real object. The address is in Unsigned_64 + -- form. + + Etyp := RTE (RE_Unsigned_64); + else + Etyp := Etype (Parameter_Type (Current_Parameter)); + end if; + + Constrained := not Transmit_As_Unconstrained (Etyp); + + if In_Present (Current_Parameter) + or else not Out_Present (Current_Parameter) + or else not Constrained + or else Is_Controlling_Formal + then + -- If an input parameter is constrained, then the read of + -- the parameter is deferred until the beginning of the + -- subprogram body. If it is unconstrained, then an + -- expression is built for the object declaration and the + -- variable is set using 'Input instead of 'Read. Note that + -- this deferral does not change the order in which the + -- actuals are read because Build_Ordered_Parameter_List + -- puts them unconstrained first. + + if Constrained then + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Params), + New_Occurrence_Of (Object, Loc)))); + + else + + -- Build and append Input_With_Tag_Check function + + Append_To (Decls, + Input_With_Tag_Check (Loc, + Var_Type => Etyp, + Stream => + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Params))); + + -- Prepare function call expression + + Expr := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (Defining_Unit_Name + (Specification (Last (Decls))), Loc)); + end if; + end if; + + Need_Extra_Constrained := + Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition + and then + Ekind (Defining_Identifier (Current_Parameter)) /= E_Void + and then + Present (Extra_Constrained + (Defining_Identifier (Current_Parameter))); + + -- We may not associate an extra constrained actual to a + -- constant object, so if one is needed, declare the actual + -- as a variable even if it won't be modified. + + Build_Actual_Object_Declaration + (Object => Object, + Etyp => Etyp, + Variable => Need_Extra_Constrained + or else Out_Present (Current_Parameter), + Expr => Expr, + Decls => Decls); + + -- An out parameter may be written back using a 'Write + -- attribute instead of a 'Output because it has been + -- constrained by the parameter given to the caller. Note that + -- out controlling arguments in the case of a RACW are not put + -- back in the stream because the pointer on them has not + -- changed. + + if Out_Present (Current_Parameter) + and then + Etype (Parameter_Type (Current_Parameter)) /= Stub_Type + then + Append_To (After_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Result), + New_Occurrence_Of (Object, Loc)))); + end if; + + -- For RACW controlling formals, the Etyp of Object is always + -- an RACW, even if the parameter is not of an anonymous access + -- type. In such case, we need to dereference it at call time. + + if Is_Controlling_Formal then + if Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition + then + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RACW_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Object, Loc)))))); + + else + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + Unchecked_Convert_To (RACW_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Object, Loc))))); + end if; + + else + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + New_Occurrence_Of (Object, Loc))); + end if; + + -- If the current parameter needs an extra formal, then read it + -- from the stream and set the corresponding semantic field in + -- the variable. If the kind of the parameter identifier is + -- E_Void, then this is a compiler generated parameter that + -- doesn't need an extra constrained status. + + -- The case of Extra_Accessibility should also be handled ??? + + if Need_Extra_Constrained then + declare + Extra_Parameter : constant Entity_Id := + Extra_Constrained + (Defining_Identifier + (Current_Parameter)); + + Formal_Entity : constant Entity_Id := + Make_Defining_Identifier + (Loc, Chars (Extra_Parameter)); + + Formal_Type : constant Entity_Id := + Etype (Extra_Parameter); + + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Formal_Entity, + Object_Definition => + New_Occurrence_Of (Formal_Type, Loc))); + + Append_To (Extra_Formal_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of ( + Formal_Type, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Params), + New_Occurrence_Of (Formal_Entity, Loc)))); + + -- Note: the call to Set_Extra_Constrained below relies + -- on the fact that Object's Ekind has been set by + -- Build_Actual_Object_Declaration. + + Set_Extra_Constrained (Object, Formal_Entity); + end; + end if; + end; + + Next (Current_Parameter); + end loop; + + -- Append the formal statements list at the end of regular statements + + Append_List_To (Statements, Extra_Formal_Statements); + + if Nkind (Specification (Vis_Decl)) = N_Function_Specification then + + -- The remote subprogram is a function. We build an inner block to + -- be able to hold a potentially unconstrained result in a + -- variable. + + declare + Etyp : constant Entity_Id := + Etype (Result_Definition (Specification (Vis_Decl))); + Result : constant Node_Id := Make_Temporary (Loc, 'R'); + + begin + Inner_Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Result, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Etyp, Loc), + Expression => + Make_Function_Call (Loc, + Name => Called_Subprogram, + Parameter_Associations => Parameter_List))); + + if Is_Class_Wide_Type (Etyp) then + + -- For a remote call to a function with a class-wide type, + -- check that the returned value satisfies the requirements + -- of E.4(18). + + Append_To (Inner_Decls, + Make_Transportable_Check (Loc, + New_Occurrence_Of (Result, Loc))); + + end if; + + Append_To (After_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Name_Output, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Result), + New_Occurrence_Of (Result, Loc)))); + end; + + Append_To (Statements, + Make_Block_Statement (Loc, + Declarations => Inner_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => After_Statements))); + + else + -- The remote subprogram is a procedure. We do not need any inner + -- block in this case. + + if Dynamically_Asynchronous then + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Dynamic_Async, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc))); + + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Params), + New_Occurrence_Of (Dynamic_Async, Loc)))); + end if; + + Append_To (Statements, + Make_Procedure_Call_Statement (Loc, + Name => Called_Subprogram, + Parameter_Associations => Parameter_List)); + + Append_List_To (Statements, After_Statements); + end if; + + if Asynchronous and then not Dynamically_Asynchronous then + + -- For an asynchronous procedure, add a null exception handler + + Excep_Handlers := New_List ( + Make_Implicit_Exception_Handler (Loc, + Exception_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List (Make_Null_Statement (Loc)))); + + else + -- In the other cases, if an exception is raised, then the + -- exception occurrence is copied into the output stream and + -- no other output parameter is written. + + Excep_Choice := Make_Temporary (Loc, 'E'); + + Excep_Code := New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Result), + New_Occurrence_Of (Excep_Choice, Loc)))); + + if Dynamically_Asynchronous then + Excep_Code := New_List ( + Make_Implicit_If_Statement (Vis_Decl, + Condition => Make_Op_Not (Loc, + New_Occurrence_Of (Dynamic_Async, Loc)), + Then_Statements => Excep_Code)); + end if; + + Excep_Handlers := New_List ( + Make_Implicit_Exception_Handler (Loc, + Choice_Parameter => Excep_Choice, + Exception_Choices => New_List (Make_Others_Choice (Loc)), + Statements => Excep_Code)); + + end if; + + Subp_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Make_Temporary (Loc, 'F'), + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Request_Parameter, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Request_Access), Loc)))); + + return + Make_Subprogram_Body (Loc, + Specification => Subp_Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements, + Exception_Handlers => Excep_Handlers)); + end Build_Subprogram_Receiving_Stubs; + + ------------ + -- Result -- + ------------ + + function Result return Node_Id is + begin + return Make_Identifier (Loc, Name_V); + end Result; + + ---------------------- + -- Stream_Parameter -- + ---------------------- + + function Stream_Parameter return Node_Id is + begin + return Make_Identifier (Loc, Name_S); + end Stream_Parameter; + + end GARLIC_Support; + + ------------------------------- + -- Get_And_Reset_RACW_Bodies -- + ------------------------------- + + function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is + Desig : constant Entity_Id := + Etype (Designated_Type (RACW_Type)); + + Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig); + + Body_Decls : List_Id; + -- Returned list of declarations + + begin + if Stub_Elements = Empty_Stub_Structure then + + -- Stub elements may be missing as a consequence of a previously + -- detected error. + + return No_List; + end if; + + Body_Decls := Stub_Elements.Body_Decls; + Stub_Elements.Body_Decls := No_List; + Stubs_Table.Set (Desig, Stub_Elements); + return Body_Decls; + end Get_And_Reset_RACW_Bodies; + + ----------------------- + -- Get_Stub_Elements -- + ----------------------- + + function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure is + Desig : constant Entity_Id := + Etype (Designated_Type (RACW_Type)); + Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig); + begin + pragma Assert (Stub_Elements /= Empty_Stub_Structure); + return Stub_Elements; + end Get_Stub_Elements; + + ----------------------- + -- Get_Subprogram_Id -- + ----------------------- + + function Get_Subprogram_Id (Def : Entity_Id) return String_Id is + Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier; + begin + pragma Assert (Result /= No_String); + return Result; + end Get_Subprogram_Id; + + ----------------------- + -- Get_Subprogram_Id -- + ----------------------- + + function Get_Subprogram_Id (Def : Entity_Id) return Int is + begin + return Get_Subprogram_Ids (Def).Int_Identifier; + end Get_Subprogram_Id; + + ------------------------ + -- Get_Subprogram_Ids -- + ------------------------ + + function Get_Subprogram_Ids + (Def : Entity_Id) return Subprogram_Identifiers + is + begin + return Subprogram_Identifier_Table.Get (Def); + end Get_Subprogram_Ids; + + ---------- + -- Hash -- + ---------- + + function Hash (F : Entity_Id) return Hash_Index is + begin + return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1)); + end Hash; + + function Hash (F : Name_Id) return Hash_Index is + begin + return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1)); + end Hash; + + -------------------------- + -- Input_With_Tag_Check -- + -------------------------- + + function Input_With_Tag_Check + (Loc : Source_Ptr; + Var_Type : Entity_Id; + Stream : Node_Id) return Node_Id + is + begin + return + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Make_Temporary (Loc, 'S'), + Result_Definition => New_Occurrence_Of (Var_Type, Loc)), + Declarations => No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, New_List ( + Make_Tag_Check (Loc, + Make_Simple_Return_Statement (Loc, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Var_Type, Loc), + Attribute_Name => Name_Input, + Expressions => + New_List (Stream))))))); + end Input_With_Tag_Check; + + -------------------------------- + -- Is_RACW_Controlling_Formal -- + -------------------------------- + + function Is_RACW_Controlling_Formal + (Parameter : Node_Id; + Stub_Type : Entity_Id) return Boolean + is + Typ : Entity_Id; + + begin + -- If the kind of the parameter is E_Void, then it is not a controlling + -- formal (this can happen in the context of RAS). + + if Ekind (Defining_Identifier (Parameter)) = E_Void then + return False; + end if; + + -- If the parameter is not a controlling formal, then it cannot be + -- possibly a RACW_Controlling_Formal. + + if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then + return False; + end if; + + Typ := Parameter_Type (Parameter); + return (Nkind (Typ) = N_Access_Definition + and then Etype (Subtype_Mark (Typ)) = Stub_Type) + or else Etype (Typ) = Stub_Type; + end Is_RACW_Controlling_Formal; + + ------------------------------ + -- Make_Transportable_Check -- + ------------------------------ + + function Make_Transportable_Check + (Loc : Source_Ptr; + Expr : Node_Id) return Node_Id is + begin + return + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Not (Loc, + Build_Get_Transportable (Loc, + Make_Selected_Component (Loc, + Prefix => Expr, + Selector_Name => Make_Identifier (Loc, Name_uTag)))), + Reason => PE_Non_Transportable_Actual); + end Make_Transportable_Check; + + ----------------------------- + -- Make_Selected_Component -- + ----------------------------- + + function Make_Selected_Component + (Loc : Source_Ptr; + Prefix : Entity_Id; + Selector_Name : Name_Id) return Node_Id + is + begin + return Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Prefix, Loc), + Selector_Name => Make_Identifier (Loc, Selector_Name)); + end Make_Selected_Component; + + -------------------- + -- Make_Tag_Check -- + -------------------- + + function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is + Occ : constant Entity_Id := Make_Temporary (Loc, 'E'); + + begin + return Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (N), + + Exception_Handlers => New_List ( + Make_Implicit_Exception_Handler (Loc, + Choice_Parameter => Occ, + + Exception_Choices => + New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)), + + Statements => + New_List (Make_Procedure_Call_Statement (Loc, + New_Occurrence_Of + (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc), + New_List (New_Occurrence_Of (Occ, Loc)))))))); + end Make_Tag_Check; + + ---------------------------- + -- Need_Extra_Constrained -- + ---------------------------- + + function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is + Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter)); + begin + return Out_Present (Parameter) + and then Has_Discriminants (Etyp) + and then not Is_Constrained (Etyp) + and then not Is_Indefinite_Subtype (Etyp); + end Need_Extra_Constrained; + + ------------------------------------ + -- Pack_Entity_Into_Stream_Access -- + ------------------------------------ + + function Pack_Entity_Into_Stream_Access + (Loc : Source_Ptr; + Stream : Node_Id; + Object : Entity_Id; + Etyp : Entity_Id := Empty) return Node_Id + is + Typ : Entity_Id; + + begin + if Present (Etyp) then + Typ := Etyp; + else + Typ := Etype (Object); + end if; + + return + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream, + Object => New_Occurrence_Of (Object, Loc), + Etyp => Typ); + end Pack_Entity_Into_Stream_Access; + + --------------------------- + -- Pack_Node_Into_Stream -- + --------------------------- + + function Pack_Node_Into_Stream + (Loc : Source_Ptr; + Stream : Entity_Id; + Object : Node_Id; + Etyp : Entity_Id) return Node_Id + is + Write_Attribute : Name_Id := Name_Write; + + begin + if not Is_Constrained (Etyp) then + Write_Attribute := Name_Output; + end if; + + return + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Write_Attribute, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stream, Loc), + Attribute_Name => Name_Access), + Object)); + end Pack_Node_Into_Stream; + + ---------------------------------- + -- Pack_Node_Into_Stream_Access -- + ---------------------------------- + + function Pack_Node_Into_Stream_Access + (Loc : Source_Ptr; + Stream : Node_Id; + Object : Node_Id; + Etyp : Entity_Id) return Node_Id + is + Write_Attribute : Name_Id := Name_Write; + + begin + if not Is_Constrained (Etyp) then + Write_Attribute := Name_Output; + end if; + + return + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Write_Attribute, + Expressions => New_List ( + Stream, + Object)); + end Pack_Node_Into_Stream_Access; + + --------------------- + -- PolyORB_Support -- + --------------------- + + package body PolyORB_Support is + + -- Local subprograms + + procedure Add_RACW_Read_Attribute + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Body_Decls : List_Id); + -- Add Read attribute for the RACW type. The declaration and attribute + -- definition clauses are inserted right after the declaration of + -- RACW_Type. If Body_Decls is not No_List, the subprogram body is + -- appended to it (case where the RACW declaration is in the main unit). + + procedure Add_RACW_Write_Attribute + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Body_Decls : List_Id); + -- Same as above for the Write attribute + + procedure Add_RACW_From_Any + (RACW_Type : Entity_Id; + Body_Decls : List_Id); + -- Add the From_Any TSS for this RACW type + + procedure Add_RACW_To_Any + (RACW_Type : Entity_Id; + Body_Decls : List_Id); + -- Add the To_Any TSS for this RACW type + + procedure Add_RACW_TypeCode + (Designated_Type : Entity_Id; + RACW_Type : Entity_Id; + Body_Decls : List_Id); + -- Add the TypeCode TSS for this RACW type + + procedure Add_RAS_From_Any (RAS_Type : Entity_Id); + -- Add the From_Any TSS for this RAS type + + procedure Add_RAS_To_Any (RAS_Type : Entity_Id); + -- Add the To_Any TSS for this RAS type + + procedure Add_RAS_TypeCode (RAS_Type : Entity_Id); + -- Add the TypeCode TSS for this RAS type + + procedure Add_RAS_Access_TSS (N : Node_Id); + -- Add a subprogram body for RAS Access TSS + + ------------------------------------- + -- Add_Obj_RPC_Receiver_Completion -- + ------------------------------------- + + procedure Add_Obj_RPC_Receiver_Completion + (Loc : Source_Ptr; + Decls : List_Id; + RPC_Receiver : Entity_Id; + Stub_Elements : Stub_Structure) + is + Desig : constant Entity_Id := + Etype (Designated_Type (Stub_Elements.RACW_Type)); + begin + Append_To (Decls, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Register_Obj_Receiving_Stub), Loc), + + Parameter_Associations => New_List ( + + -- Name + + Make_String_Literal (Loc, + Fully_Qualified_Name_String (Desig)), + + -- Handler + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of ( + Defining_Unit_Name (Parent (RPC_Receiver)), Loc), + Attribute_Name => + Name_Access), + + -- Receiver + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of ( + Defining_Identifier ( + Stub_Elements.RPC_Receiver_Decl), Loc), + Attribute_Name => + Name_Access)))); + end Add_Obj_RPC_Receiver_Completion; + + ----------------------- + -- Add_RACW_Features -- + ----------------------- + + procedure Add_RACW_Features + (RACW_Type : Entity_Id; + Desig : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver_Decl : Node_Id; + Body_Decls : List_Id) + is + pragma Unreferenced (RPC_Receiver_Decl); + + begin + Add_RACW_From_Any + (RACW_Type => RACW_Type, + Body_Decls => Body_Decls); + + Add_RACW_To_Any + (RACW_Type => RACW_Type, + Body_Decls => Body_Decls); + + Add_RACW_Write_Attribute + (RACW_Type => RACW_Type, + Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + Body_Decls => Body_Decls); + + Add_RACW_Read_Attribute + (RACW_Type => RACW_Type, + Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + Body_Decls => Body_Decls); + + Add_RACW_TypeCode + (Designated_Type => Desig, + RACW_Type => RACW_Type, + Body_Decls => Body_Decls); + end Add_RACW_Features; + + ----------------------- + -- Add_RACW_From_Any -- + ----------------------- + + procedure Add_RACW_From_Any + (RACW_Type : Entity_Id; + Body_Decls : List_Id) + is + Loc : constant Source_Ptr := Sloc (RACW_Type); + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + Fnam : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (RACW_Type), 'F')); + + Func_Spec : Node_Id; + Func_Decl : Node_Id; + Func_Body : Node_Id; + + Statements : List_Id; + -- Various parts of the subprogram + + Any_Parameter : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_A); + + Asynchronous_Flag : constant Entity_Id := + Asynchronous_Flags_Table.Get (RACW_Type); + -- The flag object declared in Add_RACW_Asynchronous_Flag + + begin + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => + Fnam, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Any_Parameter, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Any), Loc))), + Result_Definition => New_Occurrence_Of (RACW_Type, Loc)); + + -- NOTE: The usage occurrences of RACW_Parameter must refer to the + -- entity in the declaration spec, not those of the body spec. + + Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); + Insert_After (Declaration_Node (RACW_Type), Func_Decl); + Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any); + + if No (Body_Decls) then + return; + end if; + + -- ??? Issue with asynchronous calls here: the Asynchronous flag is + -- set on the stub type if, and only if, the RACW type has a pragma + -- Asynchronous. This is incorrect for RACWs that implement RAS + -- types, because in that case the /designated subprogram/ (not the + -- type) might be asynchronous, and that causes the stub to need to + -- be asynchronous too. A solution is to transport a RAS as a struct + -- containing a RACW and an asynchronous flag, and to properly alter + -- the Asynchronous component in the stub type in the RAS's _From_Any + -- TSS. + + Statements := New_List ( + Make_Simple_Return_Statement (Loc, + Expression => Unchecked_Convert_To (RACW_Type, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_RACW), Loc), + Parameter_Associations => New_List ( + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any_Parameter, Loc))), + Build_Stub_Tag (Loc, RACW_Type), + New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), + New_Occurrence_Of (Asynchronous_Flag, Loc)))))); + + Func_Body := + Make_Subprogram_Body (Loc, + Specification => Copy_Specification (Loc, Func_Spec), + Declarations => No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements)); + + Append_To (Body_Decls, Func_Body); + end Add_RACW_From_Any; + + ----------------------------- + -- Add_RACW_Read_Attribute -- + ----------------------------- + + procedure Add_RACW_Read_Attribute + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Body_Decls : List_Id) + is + pragma Unreferenced (Stub_Type, Stub_Type_Access); + + Loc : constant Source_Ptr := Sloc (RACW_Type); + + Proc_Decl : Node_Id; + Attr_Decl : Node_Id; + + Body_Node : Node_Id; + + Decls : constant List_Id := New_List; + Statements : constant List_Id := New_List; + Reference : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_R); + -- Various parts of the procedure + + Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); + + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + + Asynchronous_Flag : constant Entity_Id := + Asynchronous_Flags_Table.Get (RACW_Type); + pragma Assert (Present (Asynchronous_Flag)); + + function Stream_Parameter return Node_Id; + function Result return Node_Id; + + -- Functions to create occurrences of the formal parameter names + + ------------ + -- Result -- + ------------ + + function Result return Node_Id is + begin + return Make_Identifier (Loc, Name_V); + end Result; + + ---------------------- + -- Stream_Parameter -- + ---------------------- + + function Stream_Parameter return Node_Id is + begin + return Make_Identifier (Loc, Name_S); + end Stream_Parameter; + + -- Start of processing for Add_RACW_Read_Attribute + + begin + Build_Stream_Procedure + (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => True); + + Proc_Decl := Make_Subprogram_Declaration (Loc, + Copy_Specification (Loc, Specification (Body_Node))); + + Attr_Decl := + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (RACW_Type, Loc), + Chars => Name_Read, + Expression => + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Proc_Decl)), Loc)); + + Insert_After (Declaration_Node (RACW_Type), Proc_Decl); + Insert_After (Proc_Decl, Attr_Decl); + + if No (Body_Decls) then + return; + end if; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Reference, + Object_Definition => + New_Occurrence_Of (RTE (RE_Object_Ref), Loc))); + + Append_List_To (Statements, New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Object_Ref), Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Stream_Parameter, + New_Occurrence_Of (Reference, Loc))), + + Make_Assignment_Statement (Loc, + Name => + Result, + Expression => + Unchecked_Convert_To (RACW_Type, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_RACW), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Reference, Loc), + Build_Stub_Tag (Loc, RACW_Type), + New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), + New_Occurrence_Of (Asynchronous_Flag, Loc))))))); + + Set_Declarations (Body_Node, Decls); + Append_To (Body_Decls, Body_Node); + end Add_RACW_Read_Attribute; + + --------------------- + -- Add_RACW_To_Any -- + --------------------- + + procedure Add_RACW_To_Any + (RACW_Type : Entity_Id; + Body_Decls : List_Id) + is + Loc : constant Source_Ptr := Sloc (RACW_Type); + + Fnam : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (RACW_Type), 'T')); + + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + + Stub_Elements : constant Stub_Structure := + Get_Stub_Elements (RACW_Type); + + Func_Spec : Node_Id; + Func_Decl : Node_Id; + Func_Body : Node_Id; + + Decls : List_Id; + Statements : List_Id; + -- Various parts of the subprogram + + RACW_Parameter : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_R); + + Reference : constant Entity_Id := Make_Temporary (Loc, 'R'); + Any : constant Entity_Id := Make_Temporary (Loc, 'A'); + + begin + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => + Fnam, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + RACW_Parameter, + Parameter_Type => + New_Occurrence_Of (RACW_Type, Loc))), + Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); + + -- NOTE: The usage occurrences of RACW_Parameter must refer to the + -- entity in the declaration spec, not in the body spec. + + Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); + + Insert_After (Declaration_Node (RACW_Type), Func_Decl); + Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any); + + if No (Body_Decls) then + return; + end if; + + -- Generate: + + -- R : constant Object_Ref := + -- Get_Reference + -- (Address!(RACW), + -- "typ", + -- Stub_Type'Tag, + -- Is_RAS, + -- RPC_Receiver'Access); + -- A : Any; + + Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Reference, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Object_Ref), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), + New_Occurrence_Of (RACW_Parameter, Loc)), + Make_String_Literal (Loc, + Strval => Fully_Qualified_Name_String + (Etype (Designated_Type (RACW_Type)))), + Build_Stub_Tag (Loc, RACW_Type), + New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Defining_Identifier + (Stub_Elements.RPC_Receiver_Decl), Loc), + Attribute_Name => Name_Access)))), + + Make_Object_Declaration (Loc, + Defining_Identifier => Any, + Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc))); + + -- Generate: + + -- Any := TA_ObjRef (Reference); + -- Set_TC (Any, RPC_Receiver.Obj_TypeCode); + -- return Any; + + Statements := New_List ( + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Any, Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Reference, Loc)))), + + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + Make_Selected_Component (Loc, + Prefix => + Defining_Identifier ( + Stub_Elements.RPC_Receiver_Decl), + Selector_Name => Name_Obj_TypeCode))), + + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Any, Loc))); + + Func_Body := + Make_Subprogram_Body (Loc, + Specification => Copy_Specification (Loc, Func_Spec), + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements)); + Append_To (Body_Decls, Func_Body); + end Add_RACW_To_Any; + + ----------------------- + -- Add_RACW_TypeCode -- + ----------------------- + + procedure Add_RACW_TypeCode + (Designated_Type : Entity_Id; + RACW_Type : Entity_Id; + Body_Decls : List_Id) + is + Loc : constant Source_Ptr := Sloc (RACW_Type); + + Fnam : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (RACW_Type), 'Y')); + + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Designated_Type); + pragma Assert (Stub_Elements /= Empty_Stub_Structure); + + Func_Spec : Node_Id; + Func_Decl : Node_Id; + Func_Body : Node_Id; + + begin + -- The spec for this subprogram has a dummy 'access RACW' argument, + -- which serves only for overloading purposes. + + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Fnam, + Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); + + -- NOTE: The usage occurrences of RACW_Parameter must refer to the + -- entity in the declaration spec, not those of the body spec. + + Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); + Insert_After (Declaration_Node (RACW_Type), Func_Decl); + Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode); + + if No (Body_Decls) then + return; + end if; + + Func_Body := + Make_Subprogram_Body (Loc, + Specification => Copy_Specification (Loc, Func_Spec), + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Selected_Component (Loc, + Prefix => + Defining_Identifier + (Stub_Elements.RPC_Receiver_Decl), + Selector_Name => Name_Obj_TypeCode))))); + + Append_To (Body_Decls, Func_Body); + end Add_RACW_TypeCode; + + ------------------------------ + -- Add_RACW_Write_Attribute -- + ------------------------------ + + procedure Add_RACW_Write_Attribute + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Body_Decls : List_Id) + is + pragma Unreferenced (Stub_Type, Stub_Type_Access); + + Loc : constant Source_Ptr := Sloc (RACW_Type); + + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + + Stub_Elements : constant Stub_Structure := + Get_Stub_Elements (RACW_Type); + + Body_Node : Node_Id; + Proc_Decl : Node_Id; + Attr_Decl : Node_Id; + + Statements : constant List_Id := New_List; + Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); + + function Stream_Parameter return Node_Id; + function Object return Node_Id; + -- Functions to create occurrences of the formal parameter names + + ------------ + -- Object -- + ------------ + + function Object return Node_Id is + begin + return Make_Identifier (Loc, Name_V); + end Object; + + ---------------------- + -- Stream_Parameter -- + ---------------------- + + function Stream_Parameter return Node_Id is + begin + return Make_Identifier (Loc, Name_S); + end Stream_Parameter; + + -- Start of processing for Add_RACW_Write_Attribute + + begin + Build_Stream_Procedure + (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False); + + Proc_Decl := + Make_Subprogram_Declaration (Loc, + Copy_Specification (Loc, Specification (Body_Node))); + + Attr_Decl := + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (RACW_Type, Loc), + Chars => Name_Write, + Expression => + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Proc_Decl)), Loc)); + + Insert_After (Declaration_Node (RACW_Type), Proc_Decl); + Insert_After (Proc_Decl, Attr_Decl); + + if No (Body_Decls) then + return; + end if; + + Append_To (Statements, + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), Object), + Make_String_Literal (Loc, + Strval => Fully_Qualified_Name_String + (Etype (Designated_Type (RACW_Type)))), + Build_Stub_Tag (Loc, RACW_Type), + New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Defining_Identifier + (Stub_Elements.RPC_Receiver_Decl), Loc), + Attribute_Name => Name_Access))), + + Etyp => RTE (RE_Object_Ref))); + + Append_To (Body_Decls, Body_Node); + end Add_RACW_Write_Attribute; + + ----------------------- + -- Add_RAST_Features -- + ----------------------- + + procedure Add_RAST_Features + (Vis_Decl : Node_Id; + RAS_Type : Entity_Id) + is + begin + Add_RAS_Access_TSS (Vis_Decl); + + Add_RAS_From_Any (RAS_Type); + Add_RAS_TypeCode (RAS_Type); + + -- To_Any uses TypeCode, and therefore needs to be generated last + + Add_RAS_To_Any (RAS_Type); + end Add_RAST_Features; + + ------------------------ + -- Add_RAS_Access_TSS -- + ------------------------ + + procedure Add_RAS_Access_TSS (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Ras_Type : constant Entity_Id := Defining_Identifier (N); + Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type); + -- Ras_Type is the access to subprogram type; Fat_Type is the + -- corresponding record type. + + RACW_Type : constant Entity_Id := + Underlying_RACW_Type (Ras_Type); + + Stub_Elements : constant Stub_Structure := + Get_Stub_Elements (RACW_Type); + + Proc : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access)); + + Proc_Spec : Node_Id; + + -- Formal parameters + + Package_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_P); + + -- Target package + + Subp_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_S); + + -- Target subprogram + + Asynch_P : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_Asynchronous); + -- Is the procedure to which the 'Access applies asynchronous? + + All_Calls_Remote : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_All_Calls_Remote); + -- True if an All_Calls_Remote pragma applies to the RCI unit + -- that contains the subprogram. + + -- Common local variables + + Proc_Decls : List_Id; + Proc_Statements : List_Id; + + Subp_Ref : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_R); + -- Reference that designates the target subprogram (returned + -- by Get_RAS_Info). + + Is_Local : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_L); + Local_Addr : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_A); + -- For the call to Get_Local_Address + + Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L'); + Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S'); + -- Additional local variables for the remote case + + function Set_Field + (Field_Name : Name_Id; + Value : Node_Id) return Node_Id; + -- Construct an assignment that sets the named component in the + -- returned record + + --------------- + -- Set_Field -- + --------------- + + function Set_Field + (Field_Name : Name_Id; + Value : Node_Id) return Node_Id + is + begin + return + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Stub_Ptr, + Selector_Name => Field_Name), + Expression => Value); + end Set_Field; + + -- Start of processing for Add_RAS_Access_TSS + + begin + Proc_Decls := New_List ( + + -- Common declarations + + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Ref, + Object_Definition => + New_Occurrence_Of (RTE (RE_Object_Ref), Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Is_Local, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Local_Addr, + Object_Definition => + New_Occurrence_Of (RTE (RE_Address), Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Local_Stub, + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Stub_Ptr, + Object_Definition => + New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Local_Stub, Loc), + Attribute_Name => Name_Unchecked_Access))); + + Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access); + -- Build_Get_Unique_RP_Call needs this information + + -- Get_RAS_Info (Pkg, Subp, R); + -- Obtain a reference to the target subprogram + + Proc_Statements := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Package_Name, Loc), + New_Occurrence_Of (Subp_Id, Loc), + New_Occurrence_Of (Subp_Ref, Loc))), + + -- Get_Local_Address (R, L, A); + -- Determine whether the subprogram is local (L), and if so + -- obtain the local address of its proxy (A). + + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Subp_Ref, Loc), + New_Occurrence_Of (Is_Local, Loc), + New_Occurrence_Of (Local_Addr, Loc)))); + + -- Note: Here we assume that the Fat_Type is a record containing just + -- an access to a proxy or stub object. + + Append_To (Proc_Statements, + + -- if L then + + Make_Implicit_If_Statement (N, + Condition => New_Occurrence_Of (Is_Local, Loc), + + Then_Statements => New_List ( + + -- if A.Target = null then + + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Eq (Loc, + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To + (RTE (RE_RAS_Proxy_Type_Access), + New_Occurrence_Of (Local_Addr, Loc)), + Selector_Name => Make_Identifier (Loc, Name_Target)), + Make_Null (Loc)), + + Then_Statements => New_List ( + + -- A.Target := Entity_Of (Ref); + + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To + (RTE (RE_RAS_Proxy_Type_Access), + New_Occurrence_Of (Local_Addr, Loc)), + Selector_Name => Make_Identifier (Loc, Name_Target)), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Subp_Ref, Loc)))), + + -- Inc_Usage (A.Target); + -- end if; + + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To + (RTE (RE_RAS_Proxy_Type_Access), + New_Occurrence_Of (Local_Addr, Loc)), + Selector_Name => + Make_Identifier (Loc, Name_Target)))))), + + -- if not All_Calls_Remote then + -- return Fat_Type!(A); + -- end if; + + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + New_Occurrence_Of (All_Calls_Remote, Loc)), + + Then_Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Unchecked_Convert_To + (Fat_Type, New_Occurrence_Of (Local_Addr, Loc)))))))); + + Append_List_To (Proc_Statements, New_List ( + + -- Stub.Target := Entity_Of (Ref); + + Set_Field (Name_Target, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Subp_Ref, Loc)))), + + -- Inc_Usage (Stub.Target); + + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, + Prefix => Stub_Ptr, + Selector_Name => Name_Target))), + + -- E.4.1(9) A remote call is asynchronous if it is a call to + -- a procedure, or a call through a value of an access-to-procedure + -- type, to which a pragma Asynchronous applies. + + -- Parameter Asynch_P is true when the procedure is asynchronous; + -- Expression Asynch_T is true when the type is asynchronous. + + Set_Field (Name_Asynchronous, + Make_Or_Else (Loc, + Left_Opnd => New_Occurrence_Of (Asynch_P, Loc), + Right_Opnd => + New_Occurrence_Of + (Boolean_Literals (Is_Asynchronous (Ras_Type)), Loc))))); + + Append_List_To (Proc_Statements, + Build_Get_Unique_RP_Call (Loc, Stub_Ptr, Stub_Elements.Stub_Type)); + + Append_To (Proc_Statements, + Make_Simple_Return_Statement (Loc, + Expression => + Unchecked_Convert_To (Fat_Type, + New_Occurrence_Of (Stub_Ptr, Loc)))); + + Proc_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Proc, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Package_Name, + Parameter_Type => + New_Occurrence_Of (Standard_String, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Subp_Id, + Parameter_Type => + New_Occurrence_Of (Standard_String, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Asynch_P, + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => All_Calls_Remote, + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc))), + + Result_Definition => + New_Occurrence_Of (Fat_Type, Loc)); + + -- Set the kind and return type of the function to prevent + -- ambiguities between Ras_Type and Fat_Type in subsequent analysis. + + Set_Ekind (Proc, E_Function); + Set_Etype (Proc, Fat_Type); + + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => Proc_Spec, + Declarations => Proc_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Proc_Statements))); + + Set_TSS (Fat_Type, Proc); + end Add_RAS_Access_TSS; + + ---------------------- + -- Add_RAS_From_Any -- + ---------------------- + + procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is + Loc : constant Source_Ptr := Sloc (RAS_Type); + + Fnam : constant Entity_Id := Make_Defining_Identifier (Loc, + Make_TSS_Name (RAS_Type, TSS_From_Any)); + + Func_Spec : Node_Id; + + Statements : List_Id; + + Any_Parameter : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_A); + + begin + Statements := New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List (Make_Identifier (Loc, Name_Ras)), + Expression => + PolyORB_Support.Helpers.Build_From_Any_Call ( + Underlying_RACW_Type (RAS_Type), + New_Occurrence_Of (Any_Parameter, Loc), + No_List)))))); + + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Fnam, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Any_Parameter, + Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))), + Result_Definition => New_Occurrence_Of (RAS_Type, Loc)); + + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => Func_Spec, + Declarations => No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements))); + Set_TSS (RAS_Type, Fnam); + end Add_RAS_From_Any; + + -------------------- + -- Add_RAS_To_Any -- + -------------------- + + procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is + Loc : constant Source_Ptr := Sloc (RAS_Type); + + Fnam : constant Entity_Id := Make_Defining_Identifier (Loc, + Make_TSS_Name (RAS_Type, TSS_To_Any)); + + Decls : List_Id; + Statements : List_Id; + + Func_Spec : Node_Id; + + Any : constant Entity_Id := Make_Temporary (Loc, 'A'); + RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R'); + RACW_Parameter : constant Node_Id := + Make_Selected_Component (Loc, + Prefix => RAS_Parameter, + Selector_Name => Name_Ras); + + begin + -- Object declarations + + Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type)); + Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Any, + Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + PolyORB_Support.Helpers.Build_To_Any_Call + (RACW_Parameter, No_List))); + + Statements := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + PolyORB_Support.Helpers.Build_TypeCode_Call (Loc, + RAS_Type, Decls))), + + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Any, Loc))); + + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Fnam, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => RAS_Parameter, + Parameter_Type => New_Occurrence_Of (RAS_Type, Loc))), + Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); + + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => Func_Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements))); + Set_TSS (RAS_Type, Fnam); + end Add_RAS_To_Any; + + ---------------------- + -- Add_RAS_TypeCode -- + ---------------------- + + procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is + Loc : constant Source_Ptr := Sloc (RAS_Type); + + Fnam : constant Entity_Id := Make_Defining_Identifier (Loc, + Make_TSS_Name (RAS_Type, TSS_TypeCode)); + + Func_Spec : Node_Id; + Decls : constant List_Id := New_List; + Name_String : String_Id; + Repo_Id_String : String_Id; + + begin + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Fnam, + Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); + + PolyORB_Support.Helpers.Build_Name_And_Repository_Id + (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String); + + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => Func_Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_TC_Build), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (RTE (RE_TC_Object), Loc), + Make_Aggregate (Loc, + Expressions => + New_List ( + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (RTE (RE_TA_Std_String), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, Name_String))), + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (RTE (RE_TA_Std_String), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, + Strval => Repo_Id_String)))))))))))); + Set_TSS (RAS_Type, Fnam); + end Add_RAS_TypeCode; + + ----------------------------------------- + -- Add_Receiving_Stubs_To_Declarations -- + ----------------------------------------- + + procedure Add_Receiving_Stubs_To_Declarations + (Pkg_Spec : Node_Id; + Decls : List_Id; + Stmts : List_Id) + is + Loc : constant Source_Ptr := Sloc (Pkg_Spec); + + Pkg_RPC_Receiver : constant Entity_Id := + Make_Temporary (Loc, 'H'); + Pkg_RPC_Receiver_Object : Node_Id; + Pkg_RPC_Receiver_Body : Node_Id; + Pkg_RPC_Receiver_Decls : List_Id; + Pkg_RPC_Receiver_Statements : List_Id; + + Pkg_RPC_Receiver_Cases : constant List_Id := New_List; + -- A Pkg_RPC_Receiver is built to decode the request + + Request : Node_Id; + -- Request object received from neutral layer + + Subp_Id : Entity_Id; + -- Subprogram identifier as received from the neutral distribution + -- core. + + Subp_Index : Entity_Id; + -- Internal index as determined by matching either the method name + -- from the request structure, or the local subprogram address (in + -- case of a RAS). + + Is_Local : constant Entity_Id := Make_Temporary (Loc, 'L'); + + Local_Address : constant Entity_Id := Make_Temporary (Loc, 'A'); + -- Address of a local subprogram designated by a reference + -- corresponding to a RAS. + + Dispatch_On_Address : constant List_Id := New_List; + Dispatch_On_Name : constant List_Id := New_List; + + Current_Subp_Number : Int := First_RCI_Subprogram_Id; + + Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I'); + Subp_Info_List : constant List_Id := New_List; + + Register_Pkg_Actuals : constant List_Id := New_List; + + All_Calls_Remote_E : Entity_Id; + + procedure Append_Stubs_To + (RPC_Receiver_Cases : List_Id; + Declaration : Node_Id; + Stubs : Node_Id; + Subp_Number : Int; + Subp_Dist_Name : Entity_Id; + Subp_Proxy_Addr : Entity_Id); + -- Add one case to the specified RPC receiver case list associating + -- Subprogram_Number with the subprogram declared by Declaration, for + -- which we have receiving stubs in Stubs. Subp_Number is an internal + -- subprogram index. Subp_Dist_Name is the string used to call the + -- subprogram by name, and Subp_Dist_Addr is the address of the proxy + -- object, used in the context of calls through remote + -- access-to-subprogram types. + + procedure Visit_Subprogram (Decl : Node_Id); + -- Generate receiving stub for one remote subprogram + + --------------------- + -- Append_Stubs_To -- + --------------------- + + procedure Append_Stubs_To + (RPC_Receiver_Cases : List_Id; + Declaration : Node_Id; + Stubs : Node_Id; + Subp_Number : Int; + Subp_Dist_Name : Entity_Id; + Subp_Proxy_Addr : Entity_Id) + is + Case_Stmts : List_Id; + begin + Case_Stmts := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + Defining_Entity (Stubs), Loc), + Parameter_Associations => + New_List (New_Occurrence_Of (Request, Loc)))); + + if Nkind (Specification (Declaration)) = N_Function_Specification + or else not + Is_Asynchronous (Defining_Entity (Specification (Declaration))) + then + Append_To (Case_Stmts, Make_Simple_Return_Statement (Loc)); + end if; + + Append_To (RPC_Receiver_Cases, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_List (Make_Integer_Literal (Loc, Subp_Number)), + Statements => Case_Stmts)); + + Append_To (Dispatch_On_Name, + Make_Elsif_Part (Loc, + Condition => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Subp_Id, Loc), + New_Occurrence_Of (Subp_Dist_Name, Loc))), + + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + New_Occurrence_Of (Subp_Index, Loc), + Make_Integer_Literal (Loc, Subp_Number))))); + + Append_To (Dispatch_On_Address, + Make_Elsif_Part (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Local_Address, Loc), + Right_Opnd => New_Occurrence_Of (Subp_Proxy_Addr, Loc)), + + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + New_Occurrence_Of (Subp_Index, Loc), + Make_Integer_Literal (Loc, Subp_Number))))); + end Append_Stubs_To; + + ---------------------- + -- Visit_Subprogram -- + ---------------------- + + procedure Visit_Subprogram (Decl : Node_Id) is + Loc : constant Source_Ptr := Sloc (Decl); + Spec : constant Node_Id := Specification (Decl); + Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec); + + Subp_Val : String_Id; + + Subp_Dist_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name + (Related_Id => Chars (Subp_Def), + Suffix => 'D', + Suffix_Index => -1)); + + Current_Stubs : Node_Id; + Proxy_Obj_Addr : Entity_Id; + + begin + -- Build receiving stub + + Current_Stubs := + Build_Subprogram_Receiving_Stubs + (Vis_Decl => Decl, + Asynchronous => Nkind (Spec) = N_Procedure_Specification + and then Is_Asynchronous (Subp_Def)); + + Append_To (Decls, Current_Stubs); + Analyze (Current_Stubs); + + -- Build RAS proxy + + Add_RAS_Proxy_And_Analyze (Decls, + Vis_Decl => Decl, + All_Calls_Remote_E => All_Calls_Remote_E, + Proxy_Object_Addr => Proxy_Obj_Addr); + + -- Compute distribution identifier + + Assign_Subprogram_Identifier + (Subp_Def, Current_Subp_Number, Subp_Val); + + pragma Assert + (Current_Subp_Number = Get_Subprogram_Id (Subp_Def)); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Dist_Name, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, Subp_Val))); + Analyze (Last (Decls)); + + -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms + -- table for this receiver. The aggregate below must be kept + -- consistent with the declaration of RCI_Subp_Info in + -- System.Partition_Interface. + + Append_To (Subp_Info_List, + Make_Component_Association (Loc, + Choices => + New_List (Make_Integer_Literal (Loc, Current_Subp_Number)), + + Expression => + Make_Aggregate (Loc, + Expressions => New_List ( + + -- Name => + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Subp_Dist_Name, Loc), + Attribute_Name => Name_Address), + + -- Name_Length => + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Subp_Dist_Name, Loc), + Attribute_Name => Name_Length), + + -- Addr => + + New_Occurrence_Of (Proxy_Obj_Addr, Loc))))); + + Append_Stubs_To (Pkg_RPC_Receiver_Cases, + Declaration => Decl, + Stubs => Current_Stubs, + Subp_Number => Current_Subp_Number, + Subp_Dist_Name => Subp_Dist_Name, + Subp_Proxy_Addr => Proxy_Obj_Addr); + + Current_Subp_Number := Current_Subp_Number + 1; + end Visit_Subprogram; + + procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram); + + -- Start of processing for Add_Receiving_Stubs_To_Declarations + + begin + -- Building receiving stubs consist in several operations: + + -- - a package RPC receiver must be built. This subprogram will get + -- a Subprogram_Id from the incoming stream and will dispatch the + -- call to the right subprogram; + + -- - a receiving stub for each subprogram visible in the package + -- spec. This stub will read all the parameters from the stream, + -- and put the result as well as the exception occurrence in the + -- output stream; + + Build_RPC_Receiver_Body ( + RPC_Receiver => Pkg_RPC_Receiver, + Request => Request, + Subp_Id => Subp_Id, + Subp_Index => Subp_Index, + Stmts => Pkg_RPC_Receiver_Statements, + Decl => Pkg_RPC_Receiver_Body); + Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body); + + -- Extract local address information from the target reference: + -- if non-null, that means that this is a reference that denotes + -- one particular operation, and hence that the operation name + -- must not be taken into account for dispatching. + + Append_To (Pkg_RPC_Receiver_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Is_Local, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc))); + + Append_To (Pkg_RPC_Receiver_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Local_Address, + Object_Definition => + New_Occurrence_Of (RTE (RE_Address), Loc))); + + Append_To (Pkg_RPC_Receiver_Statements, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, + Prefix => Request, + Selector_Name => Name_Target), + New_Occurrence_Of (Is_Local, Loc), + New_Occurrence_Of (Local_Address, Loc)))); + + -- For each subprogram, the receiving stub will be built and a case + -- statement will be made on the Subprogram_Id to dispatch to the + -- right subprogram. + + All_Calls_Remote_E := Boolean_Literals ( + Has_All_Calls_Remote (Defining_Entity (Pkg_Spec))); + + Overload_Counter_Table.Reset; + Reserve_NamingContext_Methods; + + Visit_Spec (Pkg_Spec); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Info_Array, + Constant_Present => True, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + New_List ( + Make_Range (Loc, + Low_Bound => + Make_Integer_Literal (Loc, + Intval => First_RCI_Subprogram_Id), + High_Bound => + Make_Integer_Literal (Loc, + Intval => + First_RCI_Subprogram_Id + + List_Length (Subp_Info_List) - 1))))))); + + if Present (First (Subp_Info_List)) then + Set_Expression (Last (Decls), + Make_Aggregate (Loc, + Component_Associations => Subp_Info_List)); + + -- Generate the dispatch statement to determine the subprogram id + -- of the called subprogram. + + -- We first test whether the reference that was used to make the + -- call was the base RCI reference (in which case Local_Address is + -- zero, and the method identifier from the request must be used + -- to determine which subprogram is called) or a reference + -- identifying one particular subprogram (in which case + -- Local_Address is the address of that subprogram, and the + -- method name from the request is ignored). The latter occurs + -- for the case of a call through a remote access-to-subprogram. + + -- In each case, cascaded elsifs are used to determine the proper + -- subprogram index. Using hash tables might be more efficient. + + Append_To (Pkg_RPC_Receiver_Statements, + Make_Implicit_If_Statement (Pkg_Spec, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Occurrence_Of (Local_Address, Loc), + Right_Opnd => New_Occurrence_Of + (RTE (RE_Null_Address), Loc)), + + Then_Statements => New_List ( + Make_Implicit_If_Statement (Pkg_Spec, + Condition => New_Occurrence_Of (Standard_False, Loc), + Then_Statements => New_List ( + Make_Null_Statement (Loc)), + Elsif_Parts => Dispatch_On_Address)), + + Else_Statements => New_List ( + Make_Implicit_If_Statement (Pkg_Spec, + Condition => New_Occurrence_Of (Standard_False, Loc), + Then_Statements => New_List (Make_Null_Statement (Loc)), + Elsif_Parts => Dispatch_On_Name)))); + + else + -- For a degenerate RCI with no visible subprograms, + -- Subp_Info_List has zero length, and the declaration is for an + -- empty array, in which case no initialization aggregate must be + -- generated. We do not generate a Dispatch_Statement either. + + -- No initialization provided: remove CONSTANT so that the + -- declaration is not an incomplete deferred constant. + + Set_Constant_Present (Last (Decls), False); + end if; + + -- Analyze Subp_Info_Array declaration + + Analyze (Last (Decls)); + + -- If we receive an invalid Subprogram_Id, it is best to do nothing + -- rather than raising an exception since we do not want someone + -- to crash a remote partition by sending invalid subprogram ids. + -- This is consistent with the other parts of the case statement + -- since even in presence of incorrect parameters in the stream, + -- every exception will be caught and (if the subprogram is not an + -- APC) put into the result stream and sent away. + + Append_To (Pkg_RPC_Receiver_Cases, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List (Make_Null_Statement (Loc)))); + + Append_To (Pkg_RPC_Receiver_Statements, + Make_Case_Statement (Loc, + Expression => New_Occurrence_Of (Subp_Index, Loc), + Alternatives => Pkg_RPC_Receiver_Cases)); + + -- Pkg_RPC_Receiver body is now complete: insert it into the tree and + -- analyze it. + + Append_To (Decls, Pkg_RPC_Receiver_Body); + Analyze (Last (Decls)); + + Pkg_RPC_Receiver_Object := + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'R'), + Aliased_Present => True, + Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc)); + Append_To (Decls, Pkg_RPC_Receiver_Object); + Analyze (Last (Decls)); + + Get_Library_Unit_Name_String (Pkg_Spec); + + -- Name + + Append_To (Register_Pkg_Actuals, + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer)); + + -- Version + + Append_To (Register_Pkg_Actuals, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Defining_Entity (Pkg_Spec), Loc), + Attribute_Name => Name_Version)); + + -- Handler + + Append_To (Register_Pkg_Actuals, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Pkg_RPC_Receiver, Loc), + Attribute_Name => Name_Access)); + + -- Receiver + + Append_To (Register_Pkg_Actuals, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of ( + Defining_Identifier (Pkg_RPC_Receiver_Object), Loc), + Attribute_Name => Name_Access)); + + -- Subp_Info + + Append_To (Register_Pkg_Actuals, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => Name_Address)); + + -- Subp_Info_Len + + Append_To (Register_Pkg_Actuals, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => Name_Length)); + + -- Is_All_Calls_Remote + + Append_To (Register_Pkg_Actuals, + New_Occurrence_Of (All_Calls_Remote_E, Loc)); + + -- Finally call Register_Pkg_Receiving_Stub with the above parameters + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc), + Parameter_Associations => Register_Pkg_Actuals)); + Analyze (Last (Stmts)); + end Add_Receiving_Stubs_To_Declarations; + + --------------------------------- + -- Build_General_Calling_Stubs -- + --------------------------------- + + procedure Build_General_Calling_Stubs + (Decls : List_Id; + Statements : List_Id; + Target_Object : Node_Id; + Subprogram_Id : Node_Id; + Asynchronous : Node_Id := Empty; + Is_Known_Asynchronous : Boolean := False; + Is_Known_Non_Asynchronous : Boolean := False; + Is_Function : Boolean; + Spec : Node_Id; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Nod : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Nod); + + Request : constant Entity_Id := Make_Temporary (Loc, 'R'); + -- The request object constructed by these stubs + -- Could we use Name_R instead??? (see GLADE client stubs) + + function Make_Request_RTE_Call + (RE : RE_Id; + Actuals : List_Id := New_List) return Node_Id; + -- Generate a procedure call statement calling RE with the given + -- actuals. Request'Access is appended to the list. + + --------------------------- + -- Make_Request_RTE_Call -- + --------------------------- + + function Make_Request_RTE_Call + (RE : RE_Id; + Actuals : List_Id := New_List) return Node_Id + is + begin + Append_To (Actuals, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Request, Loc), + Attribute_Name => Name_Access)); + return Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE), Loc), + Parameter_Associations => Actuals); + end Make_Request_RTE_Call; + + Arguments : Node_Id; + -- Name of the named values list used to transmit parameters + -- to the remote package + + Result : Node_Id; + -- Name of the result named value (in non-APC cases) which get the + -- result of the remote subprogram. + + Result_TC : Node_Id; + -- Typecode expression for the result of the request (void + -- typecode for procedures). + + Exception_Return_Parameter : Node_Id; + -- Name of the parameter which will hold the exception sent by the + -- remote subprogram. + + Current_Parameter : Node_Id; + -- Current parameter being handled + + Ordered_Parameters_List : constant List_Id := + Build_Ordered_Parameters_List (Spec); + + Asynchronous_P : Node_Id; + -- A Boolean expression indicating whether this call is asynchronous + + Asynchronous_Statements : List_Id := No_List; + Non_Asynchronous_Statements : List_Id := No_List; + -- Statements specifics to the Asynchronous/Non-Asynchronous cases + + Extra_Formal_Statements : constant List_Id := New_List; + -- List of statements for extra formal parameters. It will appear + -- after the regular statements for writing out parameters. + + After_Statements : constant List_Id := New_List; + -- Statements to be executed after call returns (to assign IN OUT or + -- OUT parameter values). + + Etyp : Entity_Id; + -- The type of the formal parameter being processed + + Is_Controlling_Formal : Boolean; + Is_First_Controlling_Formal : Boolean; + First_Controlling_Formal_Seen : Boolean := False; + -- Controlling formal parameters of distributed object primitives + -- require special handling, and the first such parameter needs even + -- more special handling. + + begin + -- ??? document general form of stub subprograms for the PolyORB case + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Request, + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Request), Loc))); + + Result := Make_Temporary (Loc, 'R'); + + if Is_Function then + Result_TC := + PolyORB_Support.Helpers.Build_TypeCode_Call + (Loc, Etype (Result_Definition (Spec)), Decls); + else + Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc); + end if; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Result, + Aliased_Present => False, + Object_Definition => + New_Occurrence_Of (RTE (RE_NamedValue), Loc), + Expression => + Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List (Make_Identifier (Loc, Name_Name)), + Expression => + New_Occurrence_Of (RTE (RE_Result_Name), Loc)), + Make_Component_Association (Loc, + Choices => New_List ( + Make_Identifier (Loc, Name_Argument)), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List (Result_TC))), + Make_Component_Association (Loc, + Choices => New_List ( + Make_Identifier (Loc, Name_Arg_Modes)), + Expression => Make_Integer_Literal (Loc, 0)))))); + + if not Is_Known_Asynchronous then + Exception_Return_Parameter := Make_Temporary (Loc, 'E'); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Exception_Return_Parameter, + Object_Definition => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc))); + + else + Exception_Return_Parameter := Empty; + end if; + + -- Initialize and fill in arguments list + + Arguments := Make_Temporary (Loc, 'A'); + Declare_Create_NVList (Loc, Arguments, Decls, Statements); + + Current_Parameter := First (Ordered_Parameters_List); + while Present (Current_Parameter) loop + if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then + Is_Controlling_Formal := True; + Is_First_Controlling_Formal := + not First_Controlling_Formal_Seen; + First_Controlling_Formal_Seen := True; + + else + Is_Controlling_Formal := False; + Is_First_Controlling_Formal := False; + end if; + + if Is_Controlling_Formal then + + -- For a controlling formal argument, we send its reference + + Etyp := RACW_Type; + + else + Etyp := Etype (Parameter_Type (Current_Parameter)); + end if; + + -- The first controlling formal parameter is treated specially: + -- it is used to set the target object of the call. + + if not Is_First_Controlling_Formal then + declare + Constrained : constant Boolean := + Is_Constrained (Etyp) + or else Is_Elementary_Type (Etyp); + + Any : constant Entity_Id := Make_Temporary (Loc, 'A'); + + Actual_Parameter : Node_Id := + New_Occurrence_Of ( + Defining_Identifier ( + Current_Parameter), Loc); + + Expr : Node_Id; + + begin + if Is_Controlling_Formal then + + -- For a controlling formal parameter (other than the + -- first one), use the corresponding RACW. If the + -- parameter is not an anonymous access parameter, that + -- involves taking its 'Unrestricted_Access. + + if Nkind (Parameter_Type (Current_Parameter)) + = N_Access_Definition + then + Actual_Parameter := OK_Convert_To + (Etyp, Actual_Parameter); + else + Actual_Parameter := OK_Convert_To (Etyp, + Make_Attribute_Reference (Loc, + Prefix => Actual_Parameter, + Attribute_Name => Name_Unrestricted_Access)); + end if; + + end if; + + if In_Present (Current_Parameter) + or else not Out_Present (Current_Parameter) + or else not Constrained + or else Is_Controlling_Formal + then + -- The parameter has an input value, is constrained at + -- runtime by an input value, or is a controlling formal + -- parameter (always passed as a reference) other than + -- the first one. + + Expr := PolyORB_Support.Helpers.Build_To_Any_Call + (Actual_Parameter, Decls); + + else + Expr := Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List ( + PolyORB_Support.Helpers.Build_TypeCode_Call + (Loc, Etyp, Decls))); + end if; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Any, + Aliased_Present => False, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => Expr)); + + Append_To (Statements, + Add_Parameter_To_NVList (Loc, + Parameter => Current_Parameter, + NVList => Arguments, + Constrained => Constrained, + Any => Any)); + + if Out_Present (Current_Parameter) + and then not Is_Controlling_Formal + then + if Is_Limited_Type (Etyp) then + Helpers.Assign_Opaque_From_Any (Loc, + Stms => After_Statements, + Typ => Etyp, + N => New_Occurrence_Of (Any, Loc), + Target => + Defining_Identifier (Current_Parameter)); + else + Append_To (After_Statements, + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Expression => + PolyORB_Support.Helpers.Build_From_Any_Call + (Etyp, + New_Occurrence_Of (Any, Loc), + Decls))); + end if; + end if; + end; + end if; + + -- If the current parameter has a dynamic constrained status, then + -- this status is transmitted as well. + -- This should be done for accessibility as well ??? + + if Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition + and then Need_Extra_Constrained (Current_Parameter) + then + -- In this block, we do not use the extra formal that has been + -- created because it does not exist at the time of expansion + -- when building calling stubs for remote access to subprogram + -- types. We create an extra variable of this type and push it + -- in the stream after the regular parameters. + + declare + Extra_Any_Parameter : constant Entity_Id := + Make_Temporary (Loc, 'P'); + + Parameter_Exp : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Attribute_Name => Name_Constrained); + + begin + Set_Etype (Parameter_Exp, Etype (Standard_Boolean)); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Extra_Any_Parameter, + Aliased_Present => False, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + PolyORB_Support.Helpers.Build_To_Any_Call + (Parameter_Exp, Decls))); + + Append_To (Extra_Formal_Statements, + Add_Parameter_To_NVList (Loc, + Parameter => Extra_Any_Parameter, + NVList => Arguments, + Constrained => True, + Any => Extra_Any_Parameter)); + end; + end if; + + Next (Current_Parameter); + end loop; + + -- Append the formal statements list to the statements + + Append_List_To (Statements, Extra_Formal_Statements); + + Append_To (Statements, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Request_Setup), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Request, Loc), + Target_Object, + Subprogram_Id, + New_Occurrence_Of (Arguments, Loc), + New_Occurrence_Of (Result, Loc), + New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc)))); + + pragma Assert + (not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous)); + + if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then + Asynchronous_P := + New_Occurrence_Of + (Boolean_Literals (Is_Known_Asynchronous), Loc); + + else + pragma Assert (Present (Asynchronous)); + Asynchronous_P := New_Copy_Tree (Asynchronous); + + -- The expression node Asynchronous will be used to build an 'if' + -- statement at the end of Build_General_Calling_Stubs: we need to + -- make a copy here. + end if; + + Append_To (Parameter_Associations (Last (Statements)), + Make_Indexed_Component (Loc, + Prefix => + New_Occurrence_Of ( + RTE (RE_Asynchronous_P_To_Sync_Scope), Loc), + Expressions => New_List (Asynchronous_P))); + + Append_To (Statements, Make_Request_RTE_Call (RE_Request_Invoke)); + + -- Asynchronous case + + if not Is_Known_Non_Asynchronous then + Asynchronous_Statements := New_List (Make_Null_Statement (Loc)); + end if; + + -- Non-asynchronous case + + if not Is_Known_Asynchronous then + -- Reraise an exception occurrence from the completed request. + -- If the exception occurrence is empty, this is a no-op. + + Non_Asynchronous_Statements := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Request, Loc)))); + + if Is_Function then + -- If this is a function call, read the value and return it + + Append_To (Non_Asynchronous_Statements, + Make_Tag_Check (Loc, + Make_Simple_Return_Statement (Loc, + PolyORB_Support.Helpers.Build_From_Any_Call + (Etype (Result_Definition (Spec)), + Make_Selected_Component (Loc, + Prefix => Result, + Selector_Name => Name_Argument), + Decls)))); + + else + + -- Case of a procedure: deal with IN OUT and OUT formals + + Append_List_To (Non_Asynchronous_Statements, After_Statements); + end if; + end if; + + if Is_Known_Asynchronous then + Append_List_To (Statements, Asynchronous_Statements); + + elsif Is_Known_Non_Asynchronous then + Append_List_To (Statements, Non_Asynchronous_Statements); + + else + pragma Assert (Present (Asynchronous)); + Append_To (Statements, + Make_Implicit_If_Statement (Nod, + Condition => Asynchronous, + Then_Statements => Asynchronous_Statements, + Else_Statements => Non_Asynchronous_Statements)); + end if; + end Build_General_Calling_Stubs; + + ----------------------- + -- Build_Stub_Target -- + ----------------------- + + function Build_Stub_Target + (Loc : Source_Ptr; + Decls : List_Id; + RCI_Locator : Entity_Id; + Controlling_Parameter : Entity_Id) return RPC_Target + is + Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA); + Target_Reference : constant Entity_Id := Make_Temporary (Loc, 'T'); + + begin + if Present (Controlling_Parameter) then + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Target_Reference, + + Object_Definition => + New_Occurrence_Of (RTE (RE_Object_Ref), Loc), + + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Make_Ref), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, + Prefix => Controlling_Parameter, + Selector_Name => Name_Target))))); + + -- Note: Controlling_Parameter has the same components as + -- System.Partition_Interface.RACW_Stub_Type. + + Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc); + + else + Target_Info.Object := + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Chars (RCI_Locator)), + Selector_Name => + Make_Identifier (Loc, Name_Get_RCI_Package_Ref)); + end if; + + return Target_Info; + end Build_Stub_Target; + + --------------------- + -- Build_Stub_Type -- + --------------------- + + procedure Build_Stub_Type + (RACW_Type : Entity_Id; + Stub_Type_Comps : out List_Id; + RPC_Receiver_Decl : out Node_Id) + is + Loc : constant Source_Ptr := Sloc (RACW_Type); + + begin + Stub_Type_Comps := New_List ( + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Target), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Asynchronous), + + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (Standard_Boolean, Loc)))); + + RPC_Receiver_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'R'), + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Servant), Loc)); + end Build_Stub_Type; + + ----------------------------- + -- Build_RPC_Receiver_Body -- + ----------------------------- + + procedure Build_RPC_Receiver_Body + (RPC_Receiver : Entity_Id; + Request : out Entity_Id; + Subp_Id : out Entity_Id; + Subp_Index : out Entity_Id; + Stmts : out List_Id; + Decl : out Node_Id) + is + Loc : constant Source_Ptr := Sloc (RPC_Receiver); + + RPC_Receiver_Spec : Node_Id; + RPC_Receiver_Decls : List_Id; + + begin + Request := Make_Defining_Identifier (Loc, Name_R); + + RPC_Receiver_Spec := + Build_RPC_Receiver_Specification + (RPC_Receiver => RPC_Receiver, + Request_Parameter => Request); + + Subp_Id := Make_Defining_Identifier (Loc, Name_P); + Subp_Index := Make_Defining_Identifier (Loc, Name_I); + + RPC_Receiver_Decls := New_List ( + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Subp_Id, + Subtype_Mark => New_Occurrence_Of (Standard_String, Loc), + Name => + Make_Explicit_Dereference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Request, + Selector_Name => Name_Operation))), + + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Index, + Object_Definition => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Attribute_Name => Name_Last))); + + Stmts := New_List; + + Decl := + Make_Subprogram_Body (Loc, + Specification => RPC_Receiver_Spec, + Declarations => RPC_Receiver_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + end Build_RPC_Receiver_Body; + + -------------------------------------- + -- Build_Subprogram_Receiving_Stubs -- + -------------------------------------- + + function Build_Subprogram_Receiving_Stubs + (Vis_Decl : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Parent_Primitive : Entity_Id := Empty) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Vis_Decl); + + Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R'); + -- Formal parameter for receiving stubs: a descriptor for an incoming + -- request. + + Outer_Decls : constant List_Id := New_List; + -- At the outermost level, an NVList and Any's are declared for all + -- parameters. The Dynamic_Async flag also needs to be declared there + -- to be visible from the exception handling code. + + Outer_Statements : constant List_Id := New_List; + -- Statements that occur prior to the declaration of the actual + -- parameter variables. + + Outer_Extra_Formal_Statements : constant List_Id := New_List; + -- Statements concerning extra formal parameters, prior to the + -- declaration of the actual parameter variables. + + Decls : constant List_Id := New_List; + -- All the parameters will get declared before calling the real + -- subprograms. Also the out parameters will be declared. At this + -- level, parameters may be unconstrained. + + Statements : constant List_Id := New_List; + + After_Statements : constant List_Id := New_List; + -- Statements to be executed after the subprogram call + + Inner_Decls : List_Id := No_List; + -- In case of a function, the inner declarations are needed since + -- the result may be unconstrained. + + Excep_Handlers : List_Id := No_List; + + Parameter_List : constant List_Id := New_List; + -- List of parameters to be passed to the subprogram + + First_Controlling_Formal_Seen : Boolean := False; + + Current_Parameter : Node_Id; + + Ordered_Parameters_List : constant List_Id := + Build_Ordered_Parameters_List + (Specification (Vis_Decl)); + + Arguments : constant Entity_Id := Make_Temporary (Loc, 'A'); + -- Name of the named values list used to retrieve parameters + + Subp_Spec : Node_Id; + -- Subprogram specification + + Called_Subprogram : Node_Id; + -- The subprogram to call + + begin + if Present (RACW_Type) then + Called_Subprogram := + New_Occurrence_Of (Parent_Primitive, Loc); + else + Called_Subprogram := + New_Occurrence_Of + (Defining_Unit_Name (Specification (Vis_Decl)), Loc); + end if; + + Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements); + + -- Loop through every parameter and get its value from the stream. If + -- the parameter is unconstrained, then the parameter is read using + -- 'Input at the point of declaration. + + Current_Parameter := First (Ordered_Parameters_List); + while Present (Current_Parameter) loop + declare + Etyp : Entity_Id; + Constrained : Boolean; + Any : Entity_Id := Empty; + Object : constant Entity_Id := Make_Temporary (Loc, 'P'); + Expr : Node_Id := Empty; + + Is_Controlling_Formal : constant Boolean := + Is_RACW_Controlling_Formal + (Current_Parameter, Stub_Type); + + Is_First_Controlling_Formal : Boolean := False; + + Need_Extra_Constrained : Boolean; + -- True when an extra constrained actual is required + + begin + if Is_Controlling_Formal then + + -- Controlling formals in distributed object primitive + -- operations are handled specially: + + -- - the first controlling formal is used as the + -- target of the call; + + -- - the remaining controlling formals are transmitted + -- as RACWs. + + Etyp := RACW_Type; + Is_First_Controlling_Formal := + not First_Controlling_Formal_Seen; + First_Controlling_Formal_Seen := True; + + else + Etyp := Etype (Parameter_Type (Current_Parameter)); + end if; + + Constrained := + Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); + + if not Is_First_Controlling_Formal then + Any := Make_Temporary (Loc, 'A'); + + Append_To (Outer_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Any, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List ( + PolyORB_Support.Helpers.Build_TypeCode_Call + (Loc, Etyp, Outer_Decls))))); + + Append_To (Outer_Statements, + Add_Parameter_To_NVList (Loc, + Parameter => Current_Parameter, + NVList => Arguments, + Constrained => Constrained, + Any => Any)); + end if; + + if Is_First_Controlling_Formal then + declare + Addr : constant Entity_Id := Make_Temporary (Loc, 'A'); + + Is_Local : constant Entity_Id := + Make_Temporary (Loc, 'L'); + + begin + -- Special case: obtain the first controlling formal + -- from the target of the remote call, instead of the + -- argument list. + + Append_To (Outer_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Addr, + Object_Definition => + New_Occurrence_Of (RTE (RE_Address), Loc))); + + Append_To (Outer_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Is_Local, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc))); + + Append_To (Outer_Statements, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of ( + Request_Parameter, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Target)), + New_Occurrence_Of (Is_Local, Loc), + New_Occurrence_Of (Addr, Loc)))); + + Expr := Unchecked_Convert_To (RACW_Type, + New_Occurrence_Of (Addr, Loc)); + end; + + elsif In_Present (Current_Parameter) + or else not Out_Present (Current_Parameter) + or else not Constrained + then + -- If an input parameter is constrained, then its reading is + -- deferred until the beginning of the subprogram body. If + -- it is unconstrained, then an expression is built for + -- the object declaration and the variable is set using + -- 'Input instead of 'Read. + + if Constrained and then Is_Limited_Type (Etyp) then + Helpers.Assign_Opaque_From_Any (Loc, + Stms => Statements, + Typ => Etyp, + N => New_Occurrence_Of (Any, Loc), + Target => Object); + + else + Expr := Helpers.Build_From_Any_Call + (Etyp, New_Occurrence_Of (Any, Loc), Decls); + + if Constrained then + Append_To (Statements, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Object, Loc), + Expression => Expr)); + Expr := Empty; + + else + -- Expr will be used to initialize (and constrain) the + -- parameter when it is declared. + null; + end if; + + null; + end if; + end if; + + Need_Extra_Constrained := + Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition + and then + Ekind (Defining_Identifier (Current_Parameter)) /= E_Void + and then + Present (Extra_Constrained + (Defining_Identifier (Current_Parameter))); + + -- We may not associate an extra constrained actual to a + -- constant object, so if one is needed, declare the actual + -- as a variable even if it won't be modified. + + Build_Actual_Object_Declaration + (Object => Object, + Etyp => Etyp, + Variable => Need_Extra_Constrained + or else Out_Present (Current_Parameter), + Expr => Expr, + Decls => Decls); + Set_Etype (Object, Etyp); + + -- An out parameter may be written back using a 'Write + -- attribute instead of a 'Output because it has been + -- constrained by the parameter given to the caller. Note that + -- out controlling arguments in the case of a RACW are not put + -- back in the stream because the pointer on them has not + -- changed. + + if Out_Present (Current_Parameter) + and then not Is_Controlling_Formal + then + Append_To (After_Statements, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + PolyORB_Support.Helpers.Build_To_Any_Call + (New_Occurrence_Of (Object, Loc), Decls)))); + end if; + + -- For RACW controlling formals, the Etyp of Object is always + -- an RACW, even if the parameter is not of an anonymous access + -- type. In such case, we need to dereference it at call time. + + if Is_Controlling_Formal then + if Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition + then + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of + (Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Object, Loc)))); + + else + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of + (Defining_Identifier (Current_Parameter), Loc), + + Explicit_Actual_Parameter => + New_Occurrence_Of (Object, Loc))); + end if; + + else + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + New_Occurrence_Of (Object, Loc))); + end if; + + -- If the current parameter needs an extra formal, then read it + -- from the stream and set the corresponding semantic field in + -- the variable. If the kind of the parameter identifier is + -- E_Void, then this is a compiler generated parameter that + -- doesn't need an extra constrained status. + + -- The case of Extra_Accessibility should also be handled ??? + + if Need_Extra_Constrained then + declare + Extra_Parameter : constant Entity_Id := + Extra_Constrained + (Defining_Identifier + (Current_Parameter)); + + Extra_Any : constant Entity_Id := + Make_Temporary (Loc, 'A'); + + Formal_Entity : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Chars (Extra_Parameter)); + + Formal_Type : constant Entity_Id := + Etype (Extra_Parameter); + + begin + Append_To (Outer_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Extra_Any, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List ( + PolyORB_Support.Helpers.Build_TypeCode_Call + (Loc, Formal_Type, Outer_Decls))))); + + Append_To (Outer_Extra_Formal_Statements, + Add_Parameter_To_NVList (Loc, + Parameter => Extra_Parameter, + NVList => Arguments, + Constrained => True, + Any => Extra_Any)); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Formal_Entity, + Object_Definition => + New_Occurrence_Of (Formal_Type, Loc))); + + Append_To (Statements, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Formal_Entity, Loc), + Expression => + PolyORB_Support.Helpers.Build_From_Any_Call + (Formal_Type, + New_Occurrence_Of (Extra_Any, Loc), + Decls))); + Set_Extra_Constrained (Object, Formal_Entity); + end; + end if; + end; + + Next (Current_Parameter); + end loop; + + -- Extra Formals should go after all the other parameters + + Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements); + + Append_To (Outer_Statements, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Request_Arguments), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Request_Parameter, Loc), + New_Occurrence_Of (Arguments, Loc)))); + + if Nkind (Specification (Vis_Decl)) = N_Function_Specification then + + -- The remote subprogram is a function: Build an inner block to be + -- able to hold a potentially unconstrained result in a variable. + + declare + Etyp : constant Entity_Id := + Etype (Result_Definition (Specification (Vis_Decl))); + Result : constant Node_Id := Make_Temporary (Loc, 'R'); + + begin + Inner_Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Result, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Etyp, Loc), + Expression => + Make_Function_Call (Loc, + Name => Called_Subprogram, + Parameter_Associations => Parameter_List))); + + if Is_Class_Wide_Type (Etyp) then + + -- For a remote call to a function with a class-wide type, + -- check that the returned value satisfies the requirements + -- of (RM E.4(18)). + + Append_To (Inner_Decls, + Make_Transportable_Check (Loc, + New_Occurrence_Of (Result, Loc))); + + end if; + + Set_Etype (Result, Etyp); + Append_To (After_Statements, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Set_Result), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Request_Parameter, Loc), + PolyORB_Support.Helpers.Build_To_Any_Call + (New_Occurrence_Of (Result, Loc), Decls)))); + + -- A DSA function does not have out or inout arguments + end; + + Append_To (Statements, + Make_Block_Statement (Loc, + Declarations => Inner_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => After_Statements))); + + else + -- The remote subprogram is a procedure. We do not need any inner + -- block in this case. No specific processing is required here for + -- the dynamically asynchronous case: the indication of whether + -- call is asynchronous or not is managed by the Sync_Scope + -- attibute of the request, and is handled entirely in the + -- protocol layer. + + Append_To (After_Statements, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Request_Parameter, Loc)))); + + Append_To (Statements, + Make_Procedure_Call_Statement (Loc, + Name => Called_Subprogram, + Parameter_Associations => Parameter_List)); + + Append_List_To (Statements, After_Statements); + end if; + + Subp_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Make_Temporary (Loc, 'F'), + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Request_Parameter, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Request_Access), Loc)))); + + -- An exception raised during the execution of an incoming remote + -- subprogram call and that needs to be sent back to the caller is + -- propagated by the receiving stubs, and will be handled by the + -- caller (the distribution runtime). + + if Asynchronous and then not Dynamically_Asynchronous then + + -- For an asynchronous procedure, add a null exception handler + + Excep_Handlers := New_List ( + Make_Implicit_Exception_Handler (Loc, + Exception_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List (Make_Null_Statement (Loc)))); + + else + -- In the other cases, if an exception is raised, then the + -- exception occurrence is propagated. + + null; + end if; + + Append_To (Outer_Statements, + Make_Block_Statement (Loc, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements))); + + return + Make_Subprogram_Body (Loc, + Specification => Subp_Spec, + Declarations => Outer_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Outer_Statements, + Exception_Handlers => Excep_Handlers)); + end Build_Subprogram_Receiving_Stubs; + + ------------- + -- Helpers -- + ------------- + + package body Helpers is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Find_Numeric_Representation + (Typ : Entity_Id) return Entity_Id; + -- Given a numeric type Typ, return the smallest integer or floating + -- point type from Standard, or the smallest unsigned (modular) type + -- from System.Unsigned_Types, whose range encompasses that of Typ. + + function Make_Helper_Function_Name + (Loc : Source_Ptr; + Typ : Entity_Id; + Nam : Name_Id) return Entity_Id; + -- Return the name to be assigned for helper subprogram Nam of Typ + + ------------------------------------------------------------ + -- Common subprograms for building various tree fragments -- + ------------------------------------------------------------ + + function Build_Get_Aggregate_Element + (Loc : Source_Ptr; + Any : Entity_Id; + TC : Node_Id; + Idx : Node_Id) return Node_Id; + -- Build a call to Get_Aggregate_Element on Any for typecode TC, + -- returning the Idx'th element. + + generic + Subprogram : Entity_Id; + -- Reference location for constructed nodes + + Arry : Entity_Id; + -- For 'Range and Etype + + Indexes : List_Id; + -- For the construction of the innermost element expression + + with procedure Add_Process_Element + (Stmts : List_Id; + Any : Entity_Id; + Counter : Entity_Id; + Datum : Node_Id); + + procedure Append_Array_Traversal + (Stmts : List_Id; + Any : Entity_Id; + Counter : Entity_Id := Empty; + Depth : Pos := 1); + -- Build nested loop statements that iterate over the elements of an + -- array Arry. The statement(s) built by Add_Process_Element are + -- executed for each element; Indexes is the list of indexes to be + -- used in the construction of the indexed component that denotes the + -- current element. Subprogram is the entity for the subprogram for + -- which this iterator is generated. The generated statements are + -- appended to Stmts. + + generic + Rec : Entity_Id; + -- The record entity being dealt with + + with procedure Add_Process_Element + (Stmts : List_Id; + Container : Node_Or_Entity_Id; + Counter : in out Int; + Rec : Entity_Id; + Field : Node_Id); + -- Rec is the instance of the record type, or Empty. + -- Field is either the N_Defining_Identifier for a component, + -- or an N_Variant_Part. + + procedure Append_Record_Traversal + (Stmts : List_Id; + Clist : Node_Id; + Container : Node_Or_Entity_Id; + Counter : in out Int); + -- Process component list Clist. Individual fields are passed + -- to Field_Processing. Each variant part is also processed. + -- Container is the outer Any (for From_Any/To_Any), + -- the outer typecode (for TC) to which the operation applies. + + ----------------------------- + -- Append_Record_Traversal -- + ----------------------------- + + procedure Append_Record_Traversal + (Stmts : List_Id; + Clist : Node_Id; + Container : Node_Or_Entity_Id; + Counter : in out Int) + is + CI : List_Id; + VP : Node_Id; + -- Clist's Component_Items and Variant_Part + + Item : Node_Id; + Def : Entity_Id; + + begin + if No (Clist) then + return; + end if; + + CI := Component_Items (Clist); + VP := Variant_Part (Clist); + + Item := First (CI); + while Present (Item) loop + Def := Defining_Identifier (Item); + + if not Is_Internal_Name (Chars (Def)) then + Add_Process_Element + (Stmts, Container, Counter, Rec, Def); + end if; + + Next (Item); + end loop; + + if Present (VP) then + Add_Process_Element (Stmts, Container, Counter, Rec, VP); + end if; + end Append_Record_Traversal; + + ----------------------------- + -- Assign_Opaque_From_Any -- + ----------------------------- + + procedure Assign_Opaque_From_Any + (Loc : Source_Ptr; + Stms : List_Id; + Typ : Entity_Id; + N : Node_Id; + Target : Entity_Id) + is + Strm : constant Entity_Id := Make_Temporary (Loc, 'S'); + Expr : Node_Id; + + Read_Call_List : List_Id; + -- List on which to place the 'Read attribute reference + + begin + -- Strm : Buffer_Stream_Type; + + Append_To (Stms, + Make_Object_Declaration (Loc, + Defining_Identifier => Strm, + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); + + -- Any_To_BS (Strm, A); + + Append_To (Stms, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc), + Parameter_Associations => New_List ( + N, + New_Occurrence_Of (Strm, Loc)))); + + if Transmit_As_Unconstrained (Typ) then + Expr := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Input, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Strm, Loc), + Attribute_Name => Name_Access))); + + -- Target := Typ'Input (Strm'Access) + + if Present (Target) then + Append_To (Stms, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Target, Loc), + Expression => Expr)); + + -- return Typ'Input (Strm'Access); + + else + Append_To (Stms, + Make_Simple_Return_Statement (Loc, + Expression => Expr)); + end if; + + else + if Present (Target) then + Read_Call_List := Stms; + Expr := New_Occurrence_Of (Target, Loc); + + else + declare + Temp : constant Entity_Id := Make_Temporary (Loc, 'R'); + + begin + Read_Call_List := New_List; + Expr := New_Occurrence_Of (Temp, Loc); + + Append_To (Stms, Make_Block_Statement (Loc, + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => + Temp, + Object_Definition => + New_Occurrence_Of (Typ, Loc))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Read_Call_List))); + end; + end if; + + -- Typ'Read (Strm'Access, [Target|Temp]) + + Append_To (Read_Call_List, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Strm, Loc), + Attribute_Name => Name_Access), + Expr))); + + if No (Target) then + + -- return Temp + + Append_To (Read_Call_List, + Make_Simple_Return_Statement (Loc, + Expression => New_Copy (Expr))); + end if; + end if; + end Assign_Opaque_From_Any; + + ------------------------- + -- Build_From_Any_Call -- + ------------------------- + + function Build_From_Any_Call + (Typ : Entity_Id; + N : Node_Id; + Decls : List_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + + U_Type : Entity_Id := Underlying_Type (Typ); + + Fnam : Entity_Id := Empty; + Lib_RE : RE_Id := RE_Null; + Result : Node_Id; + + begin + -- First simple case where the From_Any function is present + -- in the type's TSS. + + Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any); + + -- For the subtype representing a generic actual type, go to the + -- actual type. + + if Is_Generic_Actual_Type (U_Type) then + U_Type := Underlying_Type (Base_Type (U_Type)); + end if; + + -- For a standard subtype, go to the base type + + if Sloc (U_Type) <= Standard_Location then + U_Type := Base_Type (U_Type); + end if; + + -- Check first for Boolean and Character. These are enumeration + -- types, but we treat them specially, since they may require + -- special handling in the transfer protocol. However, this + -- special handling only applies if they have standard + -- representation, otherwise they are treated like any other + -- enumeration type. + + if Present (Fnam) then + null; + + elsif U_Type = Standard_Boolean then + Lib_RE := RE_FA_B; + + elsif U_Type = Standard_Character then + Lib_RE := RE_FA_C; + + elsif U_Type = Standard_Wide_Character then + Lib_RE := RE_FA_WC; + + elsif U_Type = Standard_Wide_Wide_Character then + Lib_RE := RE_FA_WWC; + + -- Floating point types + + elsif U_Type = Standard_Short_Float then + Lib_RE := RE_FA_SF; + + elsif U_Type = Standard_Float then + Lib_RE := RE_FA_F; + + elsif U_Type = Standard_Long_Float then + Lib_RE := RE_FA_LF; + + elsif U_Type = Standard_Long_Long_Float then + Lib_RE := RE_FA_LLF; + + -- Integer types + + elsif U_Type = Etype (Standard_Short_Short_Integer) then + Lib_RE := RE_FA_SSI; + + elsif U_Type = Etype (Standard_Short_Integer) then + Lib_RE := RE_FA_SI; + + elsif U_Type = Etype (Standard_Integer) then + Lib_RE := RE_FA_I; + + elsif U_Type = Etype (Standard_Long_Integer) then + Lib_RE := RE_FA_LI; + + elsif U_Type = Etype (Standard_Long_Long_Integer) then + Lib_RE := RE_FA_LLI; + + -- Unsigned integer types + + elsif U_Type = RTE (RE_Short_Short_Unsigned) then + Lib_RE := RE_FA_SSU; + + elsif U_Type = RTE (RE_Short_Unsigned) then + Lib_RE := RE_FA_SU; + + elsif U_Type = RTE (RE_Unsigned) then + Lib_RE := RE_FA_U; + + elsif U_Type = RTE (RE_Long_Unsigned) then + Lib_RE := RE_FA_LU; + + elsif U_Type = RTE (RE_Long_Long_Unsigned) then + Lib_RE := RE_FA_LLU; + + elsif Is_RTE (U_Type, RE_Unbounded_String) then + Lib_RE := RE_FA_String; + + -- Special DSA types + + elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then + Lib_RE := RE_FA_A; + + -- Other (non-primitive) types + + else + declare + Decl : Entity_Id; + + begin + Build_From_Any_Function (Loc, U_Type, Decl, Fnam); + Append_To (Decls, Decl); + end; + end if; + + -- Call the function + + if Lib_RE /= RE_Null then + pragma Assert (No (Fnam)); + Fnam := RTE (Lib_RE); + end if; + + Result := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Fnam, Loc), + Parameter_Associations => New_List (N)); + + -- We must set the type of Result, so the unchecked conversion + -- from the underlying type to the base type is properly done. + + Set_Etype (Result, U_Type); + + return Unchecked_Convert_To (Typ, Result); + end Build_From_Any_Call; + + ----------------------------- + -- Build_From_Any_Function -- + ----------------------------- + + procedure Build_From_Any_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id) + is + Spec : Node_Id; + Decls : constant List_Id := New_List; + Stms : constant List_Id := New_List; + + Any_Parameter : constant Entity_Id := Make_Temporary (Loc, 'A'); + + Use_Opaque_Representation : Boolean; + + begin + -- For a derived type, we can't go past the base type (to the + -- parent type) here, because that would cause the attribute's + -- formal parameter to have the wrong type; hence the Base_Type + -- check here. + + if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then + Build_From_Any_Function + (Loc => Loc, + Typ => Etype (Typ), + Decl => Decl, + Fnam => Fnam); + return; + end if; + + Fnam := Make_Helper_Function_Name (Loc, Typ, Name_From_Any); + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Fnam, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Any_Parameter, + Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))), + Result_Definition => New_Occurrence_Of (Typ, Loc)); + + -- The RACW case is taken care of by Exp_Dist.Add_RACW_From_Any + + pragma Assert + (not (Is_Remote_Access_To_Class_Wide_Type (Typ))); + + Use_Opaque_Representation := False; + + if Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Output, At_Any_Place => True) + or else + Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Write, At_Any_Place => True) + then + -- If user-defined stream attributes are specified for this + -- type, use them and transmit data as an opaque sequence of + -- stream elements. + + Use_Opaque_Representation := True; + + elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then + Append_To (Stms, + Make_Simple_Return_Statement (Loc, + Expression => + OK_Convert_To (Typ, + Build_From_Any_Call + (Root_Type (Typ), + New_Occurrence_Of (Any_Parameter, Loc), + Decls)))); + + elsif Is_Record_Type (Typ) + and then not Is_Derived_Type (Typ) + and then not Is_Tagged_Type (Typ) + then + if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then + Append_To (Stms, + Make_Simple_Return_Statement (Loc, + Expression => + Build_From_Any_Call + (Etype (Typ), + New_Occurrence_Of (Any_Parameter, Loc), + Decls))); + + else + declare + Disc : Entity_Id := Empty; + Discriminant_Associations : List_Id; + Rdef : constant Node_Id := + Type_Definition + (Declaration_Node (Typ)); + Component_Counter : Int := 0; + + -- The returned object + + Res : constant Entity_Id := Make_Temporary (Loc, 'R'); + + Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc); + + procedure FA_Rec_Add_Process_Element + (Stmts : List_Id; + Any : Entity_Id; + Counter : in out Int; + Rec : Entity_Id; + Field : Node_Id); + + procedure FA_Append_Record_Traversal is + new Append_Record_Traversal + (Rec => Res, + Add_Process_Element => FA_Rec_Add_Process_Element); + + -------------------------------- + -- FA_Rec_Add_Process_Element -- + -------------------------------- + + procedure FA_Rec_Add_Process_Element + (Stmts : List_Id; + Any : Entity_Id; + Counter : in out Int; + Rec : Entity_Id; + Field : Node_Id) + is + Ctyp : Entity_Id; + begin + if Nkind (Field) = N_Defining_Identifier then + -- A regular component + + Ctyp := Etype (Field); + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Rec, Loc), + Selector_Name => + New_Occurrence_Of (Field, Loc)), + + Expression => + Build_From_Any_Call (Ctyp, + Build_Get_Aggregate_Element (Loc, + Any => Any, + TC => + Build_TypeCode_Call (Loc, Ctyp, Decls), + Idx => + Make_Integer_Literal (Loc, Counter)), + Decls))); + + else + -- A variant part + + declare + Variant : Node_Id; + Struct_Counter : Int := 0; + + Block_Decls : constant List_Id := New_List; + Block_Stmts : constant List_Id := New_List; + VP_Stmts : List_Id; + + Alt_List : constant List_Id := New_List; + Choice_List : List_Id; + + Struct_Any : constant Entity_Id := + Make_Temporary (Loc, 'S'); + + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Struct_Any, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Extract_Union_Value), Loc), + + Parameter_Associations => New_List ( + Build_Get_Aggregate_Element (Loc, + Any => Any, + TC => + Make_Function_Call (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Any_Member_Type), Loc), + Parameter_Associations => + New_List ( + New_Occurrence_Of (Any, Loc), + Make_Integer_Literal (Loc, + Intval => Counter))), + Idx => + Make_Integer_Literal (Loc, + Intval => Counter)))))); + + Append_To (Stmts, + Make_Block_Statement (Loc, + Declarations => Block_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Block_Stmts))); + + Append_To (Block_Stmts, + Make_Case_Statement (Loc, + Expression => + Make_Selected_Component (Loc, + Prefix => Rec, + Selector_Name => Chars (Name (Field))), + Alternatives => Alt_List)); + + Variant := First_Non_Pragma (Variants (Field)); + while Present (Variant) loop + Choice_List := + New_Copy_List_Tree + (Discrete_Choices (Variant)); + + VP_Stmts := New_List; + + -- Struct_Counter should be reset before + -- handling a variant part. Indeed only one + -- of the case statement alternatives will be + -- executed at run time, so the counter must + -- start at 0 for every case statement. + + Struct_Counter := 0; + + FA_Append_Record_Traversal ( + Stmts => VP_Stmts, + Clist => Component_List (Variant), + Container => Struct_Any, + Counter => Struct_Counter); + + Append_To (Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => Choice_List, + Statements => VP_Stmts)); + Next_Non_Pragma (Variant); + end loop; + end; + end if; + + Counter := Counter + 1; + end FA_Rec_Add_Process_Element; + + begin + -- First all discriminants + + if Has_Discriminants (Typ) then + Discriminant_Associations := New_List; + + Disc := First_Discriminant (Typ); + while Present (Disc) loop + declare + Disc_Var_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Chars (Disc)); + Disc_Type : constant Entity_Id := + Etype (Disc); + + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Disc_Var_Name, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Disc_Type, Loc), + + Expression => + Build_From_Any_Call (Disc_Type, + Build_Get_Aggregate_Element (Loc, + Any => Any_Parameter, + TC => Build_TypeCode_Call + (Loc, Disc_Type, Decls), + Idx => Make_Integer_Literal (Loc, + Intval => Component_Counter)), + Decls))); + + Component_Counter := Component_Counter + 1; + + Append_To (Discriminant_Associations, + Make_Discriminant_Association (Loc, + Selector_Names => New_List ( + New_Occurrence_Of (Disc, Loc)), + Expression => + New_Occurrence_Of (Disc_Var_Name, Loc))); + end; + Next_Discriminant (Disc); + end loop; + + Res_Definition := + Make_Subtype_Indication (Loc, + Subtype_Mark => Res_Definition, + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Discriminant_Associations)); + end if; + + -- Now we have all the discriminants in variables, we can + -- declared a constrained object. Note that we are not + -- initializing (non-discriminant) components directly in + -- the object declarations, because which fields to + -- initialize depends (at run time) on the discriminant + -- values. + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Res, + Object_Definition => Res_Definition)); + + -- ... then all components + + FA_Append_Record_Traversal (Stms, + Clist => Component_List (Rdef), + Container => Any_Parameter, + Counter => Component_Counter); + + Append_To (Stms, + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Res, Loc))); + end; + end if; + + elsif Is_Array_Type (Typ) then + declare + Constrained : constant Boolean := Is_Constrained (Typ); + + procedure FA_Ary_Add_Process_Element + (Stmts : List_Id; + Any : Entity_Id; + Counter : Entity_Id; + Datum : Node_Id); + -- Assign the current element (as identified by Counter) of + -- Any to the variable denoted by name Datum, and advance + -- Counter by 1. If Datum is not an Any, a call to From_Any + -- for its type is inserted. + + -------------------------------- + -- FA_Ary_Add_Process_Element -- + -------------------------------- + + procedure FA_Ary_Add_Process_Element + (Stmts : List_Id; + Any : Entity_Id; + Counter : Entity_Id; + Datum : Node_Id) + is + Assignment : constant Node_Id := + Make_Assignment_Statement (Loc, + Name => Datum, + Expression => Empty); + + Element_Any : Node_Id; + + begin + declare + Element_TC : Node_Id; + + begin + if Etype (Datum) = RTE (RE_Any) then + + -- When Datum is an Any the Etype field is not + -- sufficient to determine the typecode of Datum + -- (which can be a TC_SEQUENCE or TC_ARRAY + -- depending on the value of Constrained). + + -- Therefore we retrieve the typecode which has + -- been constructed in Append_Array_Traversal with + -- a call to Get_Any_Type. + + Element_TC := + Make_Function_Call (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Get_Any_Type), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Entity (Datum), Loc))); + else + -- For non Any Datum we simply construct a typecode + -- matching the Etype of the Datum. + + Element_TC := Build_TypeCode_Call + (Loc, Etype (Datum), Decls); + end if; + + Element_Any := + Build_Get_Aggregate_Element (Loc, + Any => Any, + TC => Element_TC, + Idx => New_Occurrence_Of (Counter, Loc)); + end; + + -- Note: here we *prepend* statements to Stmts, so + -- we must do it in reverse order. + + Prepend_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of (Counter, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (Counter, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1)))); + + if Nkind (Datum) /= N_Attribute_Reference then + + -- We ignore the value of the length of each + -- dimension, since the target array has already + -- been constrained anyway. + + if Etype (Datum) /= RTE (RE_Any) then + Set_Expression (Assignment, + Build_From_Any_Call + (Component_Type (Typ), Element_Any, Decls)); + else + Set_Expression (Assignment, Element_Any); + end if; + + Prepend_To (Stmts, Assignment); + end if; + end FA_Ary_Add_Process_Element; + + ------------------------ + -- Local Declarations -- + ------------------------ + + Counter : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_J); + + Initial_Counter_Value : Int := 0; + + Component_TC : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_T); + + Res : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_R); + + procedure Append_From_Any_Array_Iterator is + new Append_Array_Traversal ( + Subprogram => Fnam, + Arry => Res, + Indexes => New_List, + Add_Process_Element => FA_Ary_Add_Process_Element); + + Res_Subtype_Indication : Node_Id := + New_Occurrence_Of (Typ, Loc); + + begin + if not Constrained then + declare + Ndim : constant Int := Number_Dimensions (Typ); + Lnam : Name_Id; + Hnam : Name_Id; + Indx : Node_Id := First_Index (Typ); + Indt : Entity_Id; + + Ranges : constant List_Id := New_List; + + begin + for J in 1 .. Ndim loop + Lnam := New_External_Name ('L', J); + Hnam := New_External_Name ('H', J); + + -- Note, for empty arrays bounds may be out of + -- the range of Etype (Indx). + + Indt := Base_Type (Etype (Indx)); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Lnam), + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Indt, Loc), + Expression => + Build_From_Any_Call + (Indt, + Build_Get_Aggregate_Element (Loc, + Any => Any_Parameter, + TC => Build_TypeCode_Call + (Loc, Indt, Decls), + Idx => + Make_Integer_Literal (Loc, J - 1)), + Decls))); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Hnam), + + Constant_Present => True, + + Object_Definition => + New_Occurrence_Of (Indt, Loc), + + Expression => Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Indt, Loc), + + Attribute_Name => Name_Val, + + Expressions => New_List ( + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Op_Add (Loc, + Left_Opnd => + OK_Convert_To + (Standard_Long_Integer, + Make_Identifier (Loc, Lnam)), + + Right_Opnd => + OK_Convert_To + (Standard_Long_Integer, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE ( + RE_Get_Nested_Sequence_Length + ), Loc), + Parameter_Associations => + New_List ( + New_Occurrence_Of ( + Any_Parameter, Loc), + Make_Integer_Literal (Loc, + Intval => J))))), + + Right_Opnd => + Make_Integer_Literal (Loc, 1)))))); + + Append_To (Ranges, + Make_Range (Loc, + Low_Bound => Make_Identifier (Loc, Lnam), + High_Bound => Make_Identifier (Loc, Hnam))); + + Next_Index (Indx); + end loop; + + -- Now we have all the necessary bound information: + -- apply the set of range constraints to the + -- (unconstrained) nominal subtype of Res. + + Initial_Counter_Value := Ndim; + Res_Subtype_Indication := Make_Subtype_Indication (Loc, + Subtype_Mark => Res_Subtype_Indication, + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Ranges)); + end; + end if; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Res, + Object_Definition => Res_Subtype_Indication)); + Set_Etype (Res, Typ); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Counter, + Object_Definition => + New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc), + Expression => + Make_Integer_Literal (Loc, Initial_Counter_Value))); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Component_TC, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_TypeCode), Loc), + Expression => + Build_TypeCode_Call (Loc, + Component_Type (Typ), Decls))); + + Append_From_Any_Array_Iterator + (Stms, Any_Parameter, Counter); + + Append_To (Stms, + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Res, Loc))); + end; + + elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then + Append_To (Stms, + Make_Simple_Return_Statement (Loc, + Expression => + Unchecked_Convert_To (Typ, + Build_From_Any_Call + (Find_Numeric_Representation (Typ), + New_Occurrence_Of (Any_Parameter, Loc), + Decls)))); + + else + Use_Opaque_Representation := True; + end if; + + if Use_Opaque_Representation then + Assign_Opaque_From_Any (Loc, + Stms => Stms, + Typ => Typ, + N => New_Occurrence_Of (Any_Parameter, Loc), + Target => Empty); + end if; + + Decl := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stms)); + end Build_From_Any_Function; + + --------------------------------- + -- Build_Get_Aggregate_Element -- + --------------------------------- + + function Build_Get_Aggregate_Element + (Loc : Source_Ptr; + Any : Entity_Id; + TC : Node_Id; + Idx : Node_Id) return Node_Id + is + begin + return Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_Aggregate_Element), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + TC, + Idx)); + end Build_Get_Aggregate_Element; + + ------------------------- + -- Build_Reposiroty_Id -- + ------------------------- + + procedure Build_Name_And_Repository_Id + (E : Entity_Id; + Name_Str : out String_Id; + Repo_Id_Str : out String_Id) + is + begin + Start_String; + Store_String_Chars ("DSA:"); + Get_Library_Unit_Name_String (Scope (E)); + Store_String_Chars + (Name_Buffer (Name_Buffer'First .. + Name_Buffer'First + Name_Len - 1)); + Store_String_Char ('.'); + Get_Name_String (Chars (E)); + Store_String_Chars + (Name_Buffer (Name_Buffer'First .. + Name_Buffer'First + Name_Len - 1)); + Store_String_Chars (":1.0"); + Repo_Id_Str := End_String; + Name_Str := String_From_Name_Buffer; + end Build_Name_And_Repository_Id; + + ----------------------- + -- Build_To_Any_Call -- + ----------------------- + + function Build_To_Any_Call + (N : Node_Id; + Decls : List_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + + Typ : Entity_Id := Etype (N); + U_Type : Entity_Id; + C_Type : Entity_Id; + Fnam : Entity_Id := Empty; + Lib_RE : RE_Id := RE_Null; + + begin + -- If N is a selected component, then maybe its Etype has not been + -- set yet: try to use Etype of the selector_name in that case. + + if No (Typ) and then Nkind (N) = N_Selected_Component then + Typ := Etype (Selector_Name (N)); + end if; + + pragma Assert (Present (Typ)); + + -- Get full view for private type, completion for incomplete type + + U_Type := Underlying_Type (Typ); + + -- First simple case where the To_Any function is present in the + -- type's TSS. + + Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any); + + -- For the subtype representing a generic actual type, go to the + -- actual type. + + if Is_Generic_Actual_Type (U_Type) then + U_Type := Underlying_Type (Base_Type (U_Type)); + end if; + + -- For a standard subtype, go to the base type + + if Sloc (U_Type) <= Standard_Location then + U_Type := Base_Type (U_Type); + end if; + + if Present (Fnam) then + null; + + -- Check first for Boolean and Character. These are enumeration + -- types, but we treat them specially, since they may require + -- special handling in the transfer protocol. However, this + -- special handling only applies if they have standard + -- representation, otherwise they are treated like any other + -- enumeration type. + + elsif U_Type = Standard_Boolean then + Lib_RE := RE_TA_B; + + elsif U_Type = Standard_Character then + Lib_RE := RE_TA_C; + + elsif U_Type = Standard_Wide_Character then + Lib_RE := RE_TA_WC; + + elsif U_Type = Standard_Wide_Wide_Character then + Lib_RE := RE_TA_WWC; + + -- Floating point types + + elsif U_Type = Standard_Short_Float then + Lib_RE := RE_TA_SF; + + elsif U_Type = Standard_Float then + Lib_RE := RE_TA_F; + + elsif U_Type = Standard_Long_Float then + Lib_RE := RE_TA_LF; + + elsif U_Type = Standard_Long_Long_Float then + Lib_RE := RE_TA_LLF; + + -- Integer types + + elsif U_Type = Etype (Standard_Short_Short_Integer) then + Lib_RE := RE_TA_SSI; + + elsif U_Type = Etype (Standard_Short_Integer) then + Lib_RE := RE_TA_SI; + + elsif U_Type = Etype (Standard_Integer) then + Lib_RE := RE_TA_I; + + elsif U_Type = Etype (Standard_Long_Integer) then + Lib_RE := RE_TA_LI; + + elsif U_Type = Etype (Standard_Long_Long_Integer) then + Lib_RE := RE_TA_LLI; + + -- Unsigned integer types + + elsif U_Type = RTE (RE_Short_Short_Unsigned) then + Lib_RE := RE_TA_SSU; + + elsif U_Type = RTE (RE_Short_Unsigned) then + Lib_RE := RE_TA_SU; + + elsif U_Type = RTE (RE_Unsigned) then + Lib_RE := RE_TA_U; + + elsif U_Type = RTE (RE_Long_Unsigned) then + Lib_RE := RE_TA_LU; + + elsif U_Type = RTE (RE_Long_Long_Unsigned) then + Lib_RE := RE_TA_LLU; + + elsif Is_RTE (U_Type, RE_Unbounded_String) then + Lib_RE := RE_TA_String; + + -- Special DSA types + + elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then + Lib_RE := RE_TA_A; + U_Type := Typ; + + elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then + + -- No corresponding FA_TC ??? + + Lib_RE := RE_TA_TC; + + -- Other (non-primitive) types + + else + declare + Decl : Entity_Id; + begin + Build_To_Any_Function (Loc, U_Type, Decl, Fnam); + Append_To (Decls, Decl); + end; + end if; + + -- Call the function + + if Lib_RE /= RE_Null then + pragma Assert (No (Fnam)); + Fnam := RTE (Lib_RE); + end if; + + -- If Fnam is already analyzed, find the proper expected type, + -- else we have a newly constructed To_Any function and we know + -- that the expected type of its parameter is U_Type. + + if Ekind (Fnam) = E_Function + and then Present (First_Formal (Fnam)) + then + C_Type := Etype (First_Formal (Fnam)); + else + C_Type := U_Type; + end if; + + return + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Fnam, Loc), + Parameter_Associations => + New_List (OK_Convert_To (C_Type, N))); + end Build_To_Any_Call; + + --------------------------- + -- Build_To_Any_Function -- + --------------------------- + + procedure Build_To_Any_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id) + is + Spec : Node_Id; + Decls : constant List_Id := New_List; + Stms : constant List_Id := New_List; + + Expr_Parameter : Entity_Id; + Any : Entity_Id; + Result_TC : Node_Id; + + Any_Decl : Node_Id; + + Use_Opaque_Representation : Boolean; + -- When True, use stream attributes and represent type as an + -- opaque sequence of bytes. + + begin + -- For a derived type, we can't go past the base type (to the + -- parent type) here, because that would cause the attribute's + -- formal parameter to have the wrong type; hence the Base_Type + -- check here. + + if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then + Build_To_Any_Function + (Loc => Loc, + Typ => Etype (Typ), + Decl => Decl, + Fnam => Fnam); + return; + end if; + + Expr_Parameter := Make_Defining_Identifier (Loc, Name_E); + Any := Make_Defining_Identifier (Loc, Name_A); + Result_TC := Build_TypeCode_Call (Loc, Typ, Decls); + + Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any); + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Fnam, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Expr_Parameter, + Parameter_Type => New_Occurrence_Of (Typ, Loc))), + Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); + Set_Etype (Expr_Parameter, Typ); + + Any_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Any, + Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); + + Use_Opaque_Representation := False; + + if Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Output, At_Any_Place => True) + or else + Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Write, At_Any_Place => True) + then + -- If user-defined stream attributes are specified for this + -- type, use them and transmit data as an opaque sequence of + -- stream elements. + + Use_Opaque_Representation := True; + + elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then + + -- Non-tagged derived type: convert to root type + + declare + Rt_Type : constant Entity_Id := Root_Type (Typ); + Expr : constant Node_Id := + OK_Convert_To + (Rt_Type, + New_Occurrence_Of (Expr_Parameter, Loc)); + begin + Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls)); + end; + + elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then + + -- Non-tagged record type + + if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then + declare + Rt_Type : constant Entity_Id := Etype (Typ); + Expr : constant Node_Id := + OK_Convert_To (Rt_Type, + New_Occurrence_Of (Expr_Parameter, Loc)); + + begin + Set_Expression + (Any_Decl, Build_To_Any_Call (Expr, Decls)); + end; + + -- Comment needed here (and label on declare block ???) + + else + declare + Disc : Entity_Id := Empty; + Rdef : constant Node_Id := + Type_Definition (Declaration_Node (Typ)); + Counter : Int := 0; + Elements : constant List_Id := New_List; + + procedure TA_Rec_Add_Process_Element + (Stmts : List_Id; + Container : Node_Or_Entity_Id; + Counter : in out Int; + Rec : Entity_Id; + Field : Node_Id); + -- Processing routine for traversal below + + procedure TA_Append_Record_Traversal is + new Append_Record_Traversal + (Rec => Expr_Parameter, + Add_Process_Element => TA_Rec_Add_Process_Element); + + -------------------------------- + -- TA_Rec_Add_Process_Element -- + -------------------------------- + + procedure TA_Rec_Add_Process_Element + (Stmts : List_Id; + Container : Node_Or_Entity_Id; + Counter : in out Int; + Rec : Entity_Id; + Field : Node_Id) + is + Field_Ref : Node_Id; + + begin + if Nkind (Field) = N_Defining_Identifier then + + -- A regular component + + Field_Ref := Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Rec, Loc), + Selector_Name => New_Occurrence_Of (Field, Loc)); + Set_Etype (Field_Ref, Etype (Field)); + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Add_Aggregate_Element), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Container, Loc), + Build_To_Any_Call (Field_Ref, Decls)))); + + else + -- A variant part + + Variant_Part : declare + Variant : Node_Id; + Struct_Counter : Int := 0; + + Block_Decls : constant List_Id := New_List; + Block_Stmts : constant List_Id := New_List; + VP_Stmts : List_Id; + + Alt_List : constant List_Id := New_List; + Choice_List : List_Id; + + Union_Any : constant Entity_Id := + Make_Temporary (Loc, 'V'); + + Struct_Any : constant Entity_Id := + Make_Temporary (Loc, 'S'); + + function Make_Discriminant_Reference + return Node_Id; + -- Build reference to the discriminant for this + -- variant part. + + --------------------------------- + -- Make_Discriminant_Reference -- + --------------------------------- + + function Make_Discriminant_Reference + return Node_Id + is + Nod : constant Node_Id := + Make_Selected_Component (Loc, + Prefix => Rec, + Selector_Name => + Chars (Name (Field))); + begin + Set_Etype (Nod, Etype (Name (Field))); + return Nod; + end Make_Discriminant_Reference; + + -- Start of processing for Variant_Part + + begin + Append_To (Stmts, + Make_Block_Statement (Loc, + Declarations => + Block_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Block_Stmts))); + + -- Declare variant part aggregate (Union_Any). + -- Knowing the position of this VP in the + -- variant record, we can fetch the VP typecode + -- from Container. + + Append_To (Block_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Union_Any, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List ( + Make_Function_Call (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Any_Member_Type), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Container, Loc), + Make_Integer_Literal (Loc, + Counter))))))); + + -- Declare inner struct aggregate (which + -- contains the components of this VP). + + Append_To (Block_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Struct_Any, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List ( + Make_Function_Call (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Any_Member_Type), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Union_Any, Loc), + Make_Integer_Literal (Loc, + Uint_1))))))); + + -- Build case statement + + Append_To (Block_Stmts, + Make_Case_Statement (Loc, + Expression => Make_Discriminant_Reference, + Alternatives => Alt_List)); + + Variant := First_Non_Pragma (Variants (Field)); + while Present (Variant) loop + Choice_List := New_Copy_List_Tree + (Discrete_Choices (Variant)); + + VP_Stmts := New_List; + + -- Append discriminant val to union aggregate + + Append_To (VP_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Add_Aggregate_Element), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Union_Any, Loc), + Build_To_Any_Call + (Make_Discriminant_Reference, + Block_Decls)))); + + -- Populate inner struct aggregate + + -- Struct_Counter should be reset before + -- handling a variant part. Indeed only one + -- of the case statement alternatives will be + -- executed at run time, so the counter must + -- start at 0 for every case statement. + + Struct_Counter := 0; + + TA_Append_Record_Traversal + (Stmts => VP_Stmts, + Clist => Component_List (Variant), + Container => Struct_Any, + Counter => Struct_Counter); + + -- Append inner struct to union aggregate + + Append_To (VP_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Add_Aggregate_Element), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Union_Any, Loc), + New_Occurrence_Of (Struct_Any, Loc)))); + + -- Append union to outer aggregate + + Append_To (VP_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Add_Aggregate_Element), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Container, Loc), + New_Occurrence_Of + (Union_Any, Loc)))); + + Append_To (Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => Choice_List, + Statements => VP_Stmts)); + + Next_Non_Pragma (Variant); + end loop; + end Variant_Part; + end if; + + Counter := Counter + 1; + end TA_Rec_Add_Process_Element; + + begin + -- Records are encoded in a TC_STRUCT aggregate: + + -- -- Outer aggregate (TC_STRUCT) + -- | [discriminant1] + -- | [discriminant2] + -- | ... + -- | + -- | [component1] + -- | [component2] + -- | ... + + -- A component can be a common component or variant part + + -- A variant part is encoded as a TC_UNION aggregate: + + -- -- Variant Part Aggregate (TC_UNION) + -- | [discriminant choice for this Variant Part] + -- | + -- | -- Inner struct (TC_STRUCT) + -- | | [component1] + -- | | [component2] + -- | | ... + + -- Let's start by building the outer aggregate. First we + -- construct Elements array containing all discriminants. + + if Has_Discriminants (Typ) then + Disc := First_Discriminant (Typ); + while Present (Disc) loop + declare + Discriminant : constant Entity_Id := + Make_Selected_Component (Loc, + Prefix => + Expr_Parameter, + Selector_Name => + Chars (Disc)); + + begin + Set_Etype (Discriminant, Etype (Disc)); + + Append_To (Elements, + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, Counter)), + Expression => + Build_To_Any_Call (Discriminant, Decls))); + end; + + Counter := Counter + 1; + Next_Discriminant (Disc); + end loop; + + else + -- If there are no discriminants, we declare an empty + -- Elements array. + + declare + Dummy_Any : constant Entity_Id := + Make_Temporary (Loc, 'A'); + + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Dummy_Any, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc))); + + Append_To (Elements, + Make_Component_Association (Loc, + Choices => New_List ( + Make_Range (Loc, + Low_Bound => + Make_Integer_Literal (Loc, 1), + High_Bound => + Make_Integer_Literal (Loc, 0))), + Expression => + New_Occurrence_Of (Dummy_Any, Loc))); + end; + end if; + + -- We build the result aggregate with discriminants + -- as the first elements. + + Set_Expression (Any_Decl, + Make_Function_Call (Loc, + Name => New_Occurrence_Of + (RTE (RE_Any_Aggregate_Build), Loc), + Parameter_Associations => New_List ( + Result_TC, + Make_Aggregate (Loc, + Component_Associations => Elements)))); + Result_TC := Empty; + + -- Then we append all the components to the result + -- aggregate. + + TA_Append_Record_Traversal (Stms, + Clist => Component_List (Rdef), + Container => Any, + Counter => Counter); + end; + end if; + + elsif Is_Array_Type (Typ) then + + -- Constrained and unconstrained array types + + declare + Constrained : constant Boolean := Is_Constrained (Typ); + + procedure TA_Ary_Add_Process_Element + (Stmts : List_Id; + Any : Entity_Id; + Counter : Entity_Id; + Datum : Node_Id); + + -------------------------------- + -- TA_Ary_Add_Process_Element -- + -------------------------------- + + procedure TA_Ary_Add_Process_Element + (Stmts : List_Id; + Any : Entity_Id; + Counter : Entity_Id; + Datum : Node_Id) + is + pragma Unreferenced (Counter); + + Element_Any : Node_Id; + + begin + if Etype (Datum) = RTE (RE_Any) then + Element_Any := Datum; + else + Element_Any := Build_To_Any_Call (Datum, Decls); + end if; + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Add_Aggregate_Element), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + Element_Any))); + end TA_Ary_Add_Process_Element; + + procedure Append_To_Any_Array_Iterator is + new Append_Array_Traversal ( + Subprogram => Fnam, + Arry => Expr_Parameter, + Indexes => New_List, + Add_Process_Element => TA_Ary_Add_Process_Element); + + Index : Node_Id; + + begin + Set_Expression (Any_Decl, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List (Result_TC))); + Result_TC := Empty; + + if not Constrained then + Index := First_Index (Typ); + for J in 1 .. Number_Dimensions (Typ) loop + Append_To (Stms, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Add_Aggregate_Element), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + Build_To_Any_Call ( + OK_Convert_To (Etype (Index), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Expr_Parameter, Loc), + Attribute_Name => Name_First, + Expressions => New_List ( + Make_Integer_Literal (Loc, J)))), + Decls)))); + Next_Index (Index); + end loop; + end if; + + Append_To_Any_Array_Iterator (Stms, Any); + end; + + elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then + + -- Integer types + + Set_Expression (Any_Decl, + Build_To_Any_Call ( + OK_Convert_To ( + Find_Numeric_Representation (Typ), + New_Occurrence_Of (Expr_Parameter, Loc)), + Decls)); + + else + -- Default case, including tagged types: opaque representation + + Use_Opaque_Representation := True; + end if; + + if Use_Opaque_Representation then + declare + Strm : constant Entity_Id := Make_Temporary (Loc, 'S'); + -- Stream used to store data representation produced by + -- stream attribute. + + begin + -- Generate: + -- Strm : aliased Buffer_Stream_Type; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Strm, + Aliased_Present => + True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); + + -- Generate: + -- T'Output (Strm'Access, E); + + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Output, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Strm, Loc), + Attribute_Name => Name_Access), + New_Occurrence_Of (Expr_Parameter, Loc)))); + + -- Generate: + -- BS_To_Any (Strm, A); + + Append_To (Stms, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_BS_To_Any), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Strm, Loc), + New_Occurrence_Of (Any, Loc)))); + + -- Generate: + -- Release_Buffer (Strm); + + Append_To (Stms, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Release_Buffer), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Strm, Loc)))); + end; + end if; + + Append_To (Decls, Any_Decl); + + if Present (Result_TC) then + Append_To (Stms, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + Result_TC))); + end if; + + Append_To (Stms, + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Any, Loc))); + + Decl := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stms)); + end Build_To_Any_Function; + + ------------------------- + -- Build_TypeCode_Call -- + ------------------------- + + function Build_TypeCode_Call + (Loc : Source_Ptr; + Typ : Entity_Id; + Decls : List_Id) return Node_Id + is + U_Type : Entity_Id := Underlying_Type (Typ); + -- The full view, if Typ is private; the completion, + -- if Typ is incomplete. + + Fnam : Entity_Id := Empty; + Lib_RE : RE_Id := RE_Null; + Expr : Node_Id; + + begin + -- Special case System.PolyORB.Interface.Any: its primitives have + -- not been set yet, so can't call Find_Inherited_TSS. + + if Typ = RTE (RE_Any) then + Fnam := RTE (RE_TC_A); + + else + -- First simple case where the TypeCode is present + -- in the type's TSS. + + Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode); + end if; + + -- For the subtype representing a generic actual type, go to the + -- actual type. + + if Is_Generic_Actual_Type (U_Type) then + U_Type := Underlying_Type (Base_Type (U_Type)); + end if; + + -- For a standard subtype, go to the base type + + if Sloc (U_Type) <= Standard_Location then + U_Type := Base_Type (U_Type); + end if; + + if No (Fnam) then + if U_Type = Standard_Boolean then + Lib_RE := RE_TC_B; + + elsif U_Type = Standard_Character then + Lib_RE := RE_TC_C; + + elsif U_Type = Standard_Wide_Character then + Lib_RE := RE_TC_WC; + + elsif U_Type = Standard_Wide_Wide_Character then + Lib_RE := RE_TC_WWC; + + -- Floating point types + + elsif U_Type = Standard_Short_Float then + Lib_RE := RE_TC_SF; + + elsif U_Type = Standard_Float then + Lib_RE := RE_TC_F; + + elsif U_Type = Standard_Long_Float then + Lib_RE := RE_TC_LF; + + elsif U_Type = Standard_Long_Long_Float then + Lib_RE := RE_TC_LLF; + + -- Integer types (walk back to the base type) + + elsif U_Type = Etype (Standard_Short_Short_Integer) then + Lib_RE := RE_TC_SSI; + + elsif U_Type = Etype (Standard_Short_Integer) then + Lib_RE := RE_TC_SI; + + elsif U_Type = Etype (Standard_Integer) then + Lib_RE := RE_TC_I; + + elsif U_Type = Etype (Standard_Long_Integer) then + Lib_RE := RE_TC_LI; + + elsif U_Type = Etype (Standard_Long_Long_Integer) then + Lib_RE := RE_TC_LLI; + + -- Unsigned integer types + + elsif U_Type = RTE (RE_Short_Short_Unsigned) then + Lib_RE := RE_TC_SSU; + + elsif U_Type = RTE (RE_Short_Unsigned) then + Lib_RE := RE_TC_SU; + + elsif U_Type = RTE (RE_Unsigned) then + Lib_RE := RE_TC_U; + + elsif U_Type = RTE (RE_Long_Unsigned) then + Lib_RE := RE_TC_LU; + + elsif U_Type = RTE (RE_Long_Long_Unsigned) then + Lib_RE := RE_TC_LLU; + + elsif Is_RTE (U_Type, RE_Unbounded_String) then + Lib_RE := RE_TC_String; + + -- Special DSA types + + elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then + Lib_RE := RE_TC_A; + + -- Other (non-primitive) types + + else + declare + Decl : Entity_Id; + begin + Build_TypeCode_Function (Loc, U_Type, Decl, Fnam); + Append_To (Decls, Decl); + end; + end if; + + if Lib_RE /= RE_Null then + Fnam := RTE (Lib_RE); + end if; + end if; + + -- Call the function + + Expr := + Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc)); + + -- Allow Expr to be used as arg to Build_To_Any_Call immediately + + Set_Etype (Expr, RTE (RE_TypeCode)); + + return Expr; + end Build_TypeCode_Call; + + ----------------------------- + -- Build_TypeCode_Function -- + ----------------------------- + + procedure Build_TypeCode_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id) + is + Spec : Node_Id; + Decls : constant List_Id := New_List; + Stms : constant List_Id := New_List; + + TCNam : constant Entity_Id := + Make_Helper_Function_Name (Loc, Typ, Name_TypeCode); + + Parameters : List_Id; + + procedure Add_String_Parameter + (S : String_Id; + Parameter_List : List_Id); + -- Add a literal for S to Parameters + + procedure Add_TypeCode_Parameter + (TC_Node : Node_Id; + Parameter_List : List_Id); + -- Add the typecode for Typ to Parameters + + procedure Add_Long_Parameter + (Expr_Node : Node_Id; + Parameter_List : List_Id); + -- Add a signed long integer expression to Parameters + + procedure Initialize_Parameter_List + (Name_String : String_Id; + Repo_Id_String : String_Id; + Parameter_List : out List_Id); + -- Return a list that contains the first two parameters + -- for a parameterized typecode: name and repository id. + + function Make_Constructed_TypeCode + (Kind : Entity_Id; + Parameters : List_Id) return Node_Id; + -- Call TC_Build with the given kind and parameters + + procedure Return_Constructed_TypeCode (Kind : Entity_Id); + -- Make a return statement that calls TC_Build with the given + -- typecode kind, and the constructed parameters list. + + procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id); + -- Return a typecode that is a TC_Alias for the given typecode + + -------------------------- + -- Add_String_Parameter -- + -------------------------- + + procedure Add_String_Parameter + (S : String_Id; + Parameter_List : List_Id) + is + begin + Append_To (Parameter_List, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_TA_Std_String), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, S)))); + end Add_String_Parameter; + + ---------------------------- + -- Add_TypeCode_Parameter -- + ---------------------------- + + procedure Add_TypeCode_Parameter + (TC_Node : Node_Id; + Parameter_List : List_Id) + is + begin + Append_To (Parameter_List, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_TA_TC), Loc), + Parameter_Associations => New_List (TC_Node))); + end Add_TypeCode_Parameter; + + ------------------------ + -- Add_Long_Parameter -- + ------------------------ + + procedure Add_Long_Parameter + (Expr_Node : Node_Id; + Parameter_List : List_Id) + is + begin + Append_To (Parameter_List, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_TA_LI), Loc), + Parameter_Associations => New_List (Expr_Node))); + end Add_Long_Parameter; + + ------------------------------- + -- Initialize_Parameter_List -- + ------------------------------- + + procedure Initialize_Parameter_List + (Name_String : String_Id; + Repo_Id_String : String_Id; + Parameter_List : out List_Id) + is + begin + Parameter_List := New_List; + Add_String_Parameter (Name_String, Parameter_List); + Add_String_Parameter (Repo_Id_String, Parameter_List); + end Initialize_Parameter_List; + + --------------------------- + -- Return_Alias_TypeCode -- + --------------------------- + + procedure Return_Alias_TypeCode + (Base_TypeCode : Node_Id) + is + begin + Add_TypeCode_Parameter (Base_TypeCode, Parameters); + Return_Constructed_TypeCode (RTE (RE_TC_Alias)); + end Return_Alias_TypeCode; + + ------------------------------- + -- Make_Constructed_TypeCode -- + ------------------------------- + + function Make_Constructed_TypeCode + (Kind : Entity_Id; + Parameters : List_Id) return Node_Id + is + Constructed_TC : constant Node_Id := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_TC_Build), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Kind, Loc), + Make_Aggregate (Loc, + Expressions => Parameters))); + begin + Set_Etype (Constructed_TC, RTE (RE_TypeCode)); + return Constructed_TC; + end Make_Constructed_TypeCode; + + --------------------------------- + -- Return_Constructed_TypeCode -- + --------------------------------- + + procedure Return_Constructed_TypeCode (Kind : Entity_Id) is + begin + Append_To (Stms, + Make_Simple_Return_Statement (Loc, + Expression => + Make_Constructed_TypeCode (Kind, Parameters))); + end Return_Constructed_TypeCode; + + ------------------ + -- Record types -- + ------------------ + + procedure TC_Rec_Add_Process_Element + (Params : List_Id; + Any : Entity_Id; + Counter : in out Int; + Rec : Entity_Id; + Field : Node_Id); + + procedure TC_Append_Record_Traversal is + new Append_Record_Traversal ( + Rec => Empty, + Add_Process_Element => TC_Rec_Add_Process_Element); + + -------------------------------- + -- TC_Rec_Add_Process_Element -- + -------------------------------- + + procedure TC_Rec_Add_Process_Element + (Params : List_Id; + Any : Entity_Id; + Counter : in out Int; + Rec : Entity_Id; + Field : Node_Id) + is + pragma Unreferenced (Any, Counter, Rec); + + begin + if Nkind (Field) = N_Defining_Identifier then + + -- A regular component + + Add_TypeCode_Parameter + (Build_TypeCode_Call (Loc, Etype (Field), Decls), Params); + Get_Name_String (Chars (Field)); + Add_String_Parameter (String_From_Name_Buffer, Params); + + else + + -- A variant part + + declare + Discriminant_Type : constant Entity_Id := + Etype (Name (Field)); + + Is_Enum : constant Boolean := + Is_Enumeration_Type (Discriminant_Type); + + Union_TC_Params : List_Id; + + U_Name : constant Name_Id := + New_External_Name (Chars (Typ), 'V', -1); + + Name_Str : String_Id; + Struct_TC_Params : List_Id; + + Variant : Node_Id; + Choice : Node_Id; + Default : constant Node_Id := + Make_Integer_Literal (Loc, -1); + + Dummy_Counter : Int := 0; + + Choice_Index : Int := 0; + + procedure Add_Params_For_Variant_Components; + -- Add a struct TypeCode and a corresponding member name + -- to the union parameter list. + + -- Ordering of declarations is a complete mess in this + -- area, it is supposed to be types/variables, then + -- subprogram specs, then subprogram bodies ??? + + --------------------------------------- + -- Add_Params_For_Variant_Components -- + --------------------------------------- + + procedure Add_Params_For_Variant_Components + is + S_Name : constant Name_Id := + New_External_Name (U_Name, 'S', -1); + + begin + Get_Name_String (S_Name); + Name_Str := String_From_Name_Buffer; + Initialize_Parameter_List + (Name_Str, Name_Str, Struct_TC_Params); + + -- Build struct parameters + + TC_Append_Record_Traversal (Struct_TC_Params, + Component_List (Variant), + Empty, + Dummy_Counter); + + Add_TypeCode_Parameter + (Make_Constructed_TypeCode + (RTE (RE_TC_Struct), Struct_TC_Params), + Union_TC_Params); + + Add_String_Parameter (Name_Str, Union_TC_Params); + end Add_Params_For_Variant_Components; + + begin + Get_Name_String (U_Name); + Name_Str := String_From_Name_Buffer; + + Initialize_Parameter_List + (Name_Str, Name_Str, Union_TC_Params); + + -- Add union in enclosing parameter list + + Add_TypeCode_Parameter + (Make_Constructed_TypeCode + (RTE (RE_TC_Union), Union_TC_Params), + Params); + + Add_String_Parameter (Name_Str, Params); + + -- Build union parameters + + Add_TypeCode_Parameter + (Build_TypeCode_Call + (Loc, Discriminant_Type, Decls), + Union_TC_Params); + + Add_Long_Parameter (Default, Union_TC_Params); + + Variant := First_Non_Pragma (Variants (Field)); + while Present (Variant) loop + Choice := First (Discrete_Choices (Variant)); + while Present (Choice) loop + case Nkind (Choice) is + when N_Range => + declare + L : constant Uint := + Expr_Value (Low_Bound (Choice)); + H : constant Uint := + Expr_Value (High_Bound (Choice)); + J : Uint := L; + -- 3.8.1(8) guarantees that the bounds of + -- this range are static. + + Expr : Node_Id; + + begin + while J <= H loop + if Is_Enum then + Expr := New_Occurrence_Of ( + Get_Enum_Lit_From_Pos ( + Discriminant_Type, J, Loc), Loc); + else + Expr := + Make_Integer_Literal (Loc, J); + end if; + Append_To (Union_TC_Params, + Build_To_Any_Call (Expr, Decls)); + + Add_Params_For_Variant_Components; + J := J + Uint_1; + end loop; + end; + + when N_Others_Choice => + + -- This variant possess a default choice. + -- We must therefore set the default + -- parameter to the current choice index. The + -- default parameter is by construction the + -- fourth in the Union_TC_Params list. + + declare + Default_Node : constant Node_Id := + Pick (Union_TC_Params, 4); + + New_Default_Node : constant Node_Id := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (RTE (RE_TA_LI), Loc), + Parameter_Associations => + New_List ( + Make_Integer_Literal + (Loc, Choice_Index))); + begin + Insert_Before ( + Default_Node, + New_Default_Node); + + Remove (Default_Node); + end; + + -- Add a placeholder member label + -- for the default case. + -- It must be of the discriminant type. + + declare + Exp : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of + (Discriminant_Type, Loc), + Attribute_Name => Name_First); + begin + Set_Etype (Exp, Discriminant_Type); + Append_To (Union_TC_Params, + Build_To_Any_Call (Exp, Decls)); + end; + + Add_Params_For_Variant_Components; + + when others => + + -- Case of an explicit choice + + declare + Exp : constant Node_Id := + New_Copy_Tree (Choice); + begin + Append_To (Union_TC_Params, + Build_To_Any_Call (Exp, Decls)); + end; + + Add_Params_For_Variant_Components; + end case; + + Next (Choice); + Choice_Index := Choice_Index + 1; + end loop; + + Next_Non_Pragma (Variant); + end loop; + end; + end if; + end TC_Rec_Add_Process_Element; + + Type_Name_Str : String_Id; + Type_Repo_Id_Str : String_Id; + + -- Start of processing for Build_TypeCode_Function + + begin + -- For a derived type, we can't go past the base type (to the + -- parent type) here, because that would cause the attribute's + -- formal parameter to have the wrong type; hence the Base_Type + -- check here. + + if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then + Build_TypeCode_Function + (Loc => Loc, + Typ => Etype (Typ), + Decl => Decl, + Fnam => Fnam); + return; + end if; + + Fnam := TCNam; + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Fnam, + Parameter_Specifications => Empty_List, + Result_Definition => + New_Occurrence_Of (RTE (RE_TypeCode), Loc)); + + Build_Name_And_Repository_Id (Typ, + Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str); + + Initialize_Parameter_List + (Type_Name_Str, Type_Repo_Id_Str, Parameters); + + if Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Output, At_Any_Place => True) + or else + Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Write, At_Any_Place => True) + then + -- If user-defined stream attributes are specified for this + -- type, use them and transmit data as an opaque sequence of + -- stream elements. + + Return_Alias_TypeCode + (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc)); + + elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then + Return_Alias_TypeCode ( + Build_TypeCode_Call (Loc, Etype (Typ), Decls)); + + elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then + Return_Alias_TypeCode ( + Build_TypeCode_Call (Loc, + Find_Numeric_Representation (Typ), Decls)); + + elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then + + -- Record typecodes are encoded as follows: + -- -- TC_STRUCT + -- | + -- | [Name] + -- | [Repository Id] + -- + -- Then for each discriminant: + -- + -- | [Discriminant Type Code] + -- | [Discriminant Name] + -- | ... + -- + -- Then for each component: + -- + -- | [Component Type Code] + -- | [Component Name] + -- | ... + -- + -- Variants components type codes are encoded as follows: + -- -- TC_UNION + -- | + -- | [Name] + -- | [Repository Id] + -- | [Discriminant Type Code] + -- | [Index of Default Variant Part or -1 for no default] + -- + -- Then for each Variant Part : + -- + -- | [VP Label] + -- | + -- | -- TC_STRUCT + -- | | [Variant Part Name] + -- | | [Variant Part Repository Id] + -- | | + -- | Then for each VP component: + -- | | [VP component Typecode] + -- | | [VP component Name] + -- | | ... + -- | -- + -- | + -- | [VP Name] + + if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then + Return_Alias_TypeCode + (Build_TypeCode_Call (Loc, Etype (Typ), Decls)); + + else + declare + Disc : Entity_Id := Empty; + Rdef : constant Node_Id := + Type_Definition (Declaration_Node (Typ)); + Dummy_Counter : Int := 0; + + begin + -- Construct the discriminants typecodes + + if Has_Discriminants (Typ) then + Disc := First_Discriminant (Typ); + end if; + + while Present (Disc) loop + Add_TypeCode_Parameter ( + Build_TypeCode_Call (Loc, Etype (Disc), Decls), + Parameters); + Get_Name_String (Chars (Disc)); + Add_String_Parameter ( + String_From_Name_Buffer, + Parameters); + Next_Discriminant (Disc); + end loop; + + -- then the components typecodes + + TC_Append_Record_Traversal + (Parameters, Component_List (Rdef), + Empty, Dummy_Counter); + Return_Constructed_TypeCode (RTE (RE_TC_Struct)); + end; + end if; + + elsif Is_Array_Type (Typ) then + declare + Ndim : constant Pos := Number_Dimensions (Typ); + Inner_TypeCode : Node_Id; + Constrained : constant Boolean := Is_Constrained (Typ); + Indx : Node_Id := First_Index (Typ); + + begin + Inner_TypeCode := + Build_TypeCode_Call (Loc, Component_Type (Typ), Decls); + + for J in 1 .. Ndim loop + if Constrained then + Inner_TypeCode := Make_Constructed_TypeCode + (RTE (RE_TC_Array), New_List ( + Build_To_Any_Call ( + OK_Convert_To (RTE (RE_Long_Unsigned), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Length, + Expressions => New_List ( + Make_Integer_Literal (Loc, + Intval => Ndim - J + 1)))), + Decls), + Build_To_Any_Call (Inner_TypeCode, Decls))); + + else + -- Unconstrained case: add low bound for each + -- dimension. + + Add_TypeCode_Parameter + (Build_TypeCode_Call (Loc, Etype (Indx), Decls), + Parameters); + Get_Name_String (New_External_Name ('L', J)); + Add_String_Parameter ( + String_From_Name_Buffer, + Parameters); + Next_Index (Indx); + + Inner_TypeCode := Make_Constructed_TypeCode + (RTE (RE_TC_Sequence), New_List ( + Build_To_Any_Call ( + OK_Convert_To (RTE (RE_Long_Unsigned), + Make_Integer_Literal (Loc, 0)), + Decls), + Build_To_Any_Call (Inner_TypeCode, Decls))); + end if; + end loop; + + if Constrained then + Return_Alias_TypeCode (Inner_TypeCode); + else + Add_TypeCode_Parameter (Inner_TypeCode, Parameters); + Start_String; + Store_String_Char ('V'); + Add_String_Parameter (End_String, Parameters); + Return_Constructed_TypeCode (RTE (RE_TC_Struct)); + end if; + end; + + else + -- Default: type is represented as an opaque sequence of bytes + + Return_Alias_TypeCode + (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc)); + end if; + + Decl := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stms)); + end Build_TypeCode_Function; + + --------------------------------- + -- Find_Numeric_Representation -- + --------------------------------- + + function Find_Numeric_Representation + (Typ : Entity_Id) return Entity_Id + is + FST : constant Entity_Id := First_Subtype (Typ); + P_Size : constant Uint := Esize (FST); + + begin + if Is_Unsigned_Type (Typ) then + if P_Size <= Standard_Short_Short_Integer_Size then + return RTE (RE_Short_Short_Unsigned); + + elsif P_Size <= Standard_Short_Integer_Size then + return RTE (RE_Short_Unsigned); + + elsif P_Size <= Standard_Integer_Size then + return RTE (RE_Unsigned); + + elsif P_Size <= Standard_Long_Integer_Size then + return RTE (RE_Long_Unsigned); + + else + return RTE (RE_Long_Long_Unsigned); + end if; + + elsif Is_Integer_Type (Typ) then + if P_Size <= Standard_Short_Short_Integer_Size then + return Standard_Short_Short_Integer; + + elsif P_Size <= Standard_Short_Integer_Size then + return Standard_Short_Integer; + + elsif P_Size <= Standard_Integer_Size then + return Standard_Integer; + + elsif P_Size <= Standard_Long_Integer_Size then + return Standard_Long_Integer; + + else + return Standard_Long_Long_Integer; + end if; + + elsif Is_Floating_Point_Type (Typ) then + if P_Size <= Standard_Short_Float_Size then + return Standard_Short_Float; + + elsif P_Size <= Standard_Float_Size then + return Standard_Float; + + elsif P_Size <= Standard_Long_Float_Size then + return Standard_Long_Float; + + else + return Standard_Long_Long_Float; + end if; + + else + raise Program_Error; + end if; + + -- TBD: fixed point types??? + -- TBverified numeric types with a biased representation??? + + end Find_Numeric_Representation; + + --------------------------- + -- Append_Array_Traversal -- + --------------------------- + + procedure Append_Array_Traversal + (Stmts : List_Id; + Any : Entity_Id; + Counter : Entity_Id := Empty; + Depth : Pos := 1) + is + Loc : constant Source_Ptr := Sloc (Subprogram); + Typ : constant Entity_Id := Etype (Arry); + Constrained : constant Boolean := Is_Constrained (Typ); + Ndim : constant Pos := Number_Dimensions (Typ); + + Inner_Any, Inner_Counter : Entity_Id; + + Loop_Stm : Node_Id; + Inner_Stmts : constant List_Id := New_List; + + begin + if Depth > Ndim then + + -- Processing for one element of an array + + declare + Element_Expr : constant Node_Id := + Make_Indexed_Component (Loc, + New_Occurrence_Of (Arry, Loc), + Indexes); + begin + Set_Etype (Element_Expr, Component_Type (Typ)); + Add_Process_Element (Stmts, + Any => Any, + Counter => Counter, + Datum => Element_Expr); + end; + + return; + end if; + + Append_To (Indexes, + Make_Identifier (Loc, New_External_Name ('L', Depth))); + + if not Constrained or else Depth > 1 then + Inner_Any := Make_Defining_Identifier (Loc, + New_External_Name ('A', Depth)); + Set_Etype (Inner_Any, RTE (RE_Any)); + else + Inner_Any := Empty; + end if; + + if Present (Counter) then + Inner_Counter := Make_Defining_Identifier (Loc, + New_External_Name ('J', Depth)); + else + Inner_Counter := Empty; + end if; + + declare + Loop_Any : Node_Id := Inner_Any; + + begin + -- For the first dimension of a constrained array, we add + -- elements directly in the corresponding Any; there is no + -- intervening inner Any. + + if No (Loop_Any) then + Loop_Any := Any; + end if; + + Append_Array_Traversal (Inner_Stmts, + Any => Loop_Any, + Counter => Inner_Counter, + Depth => Depth + 1); + end; + + Loop_Stm := + Make_Implicit_Loop_Statement (Subprogram, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => New_External_Name ('L', Depth)), + + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Arry, Loc), + Attribute_Name => Name_Range, + + Expressions => New_List ( + Make_Integer_Literal (Loc, Depth))))), + Statements => Inner_Stmts); + + declare + Decls : constant List_Id := New_List; + Dimen_Stmts : constant List_Id := New_List; + Length_Node : Node_Id; + + Inner_Any_TypeCode : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_External_Name ('T', Depth)); + + Inner_Any_TypeCode_Expr : Node_Id; + + begin + if Depth = 1 then + if Constrained then + Inner_Any_TypeCode_Expr := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc))); + + else + Inner_Any_TypeCode_Expr := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + Make_Integer_Literal (Loc, Ndim))); + end if; + + else + Inner_Any_TypeCode_Expr := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Content_Type), Loc), + Parameter_Associations => New_List ( + Make_Identifier (Loc, + Chars => New_External_Name ('T', Depth - 1)))); + end if; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Inner_Any_TypeCode, + Constant_Present => True, + Object_Definition => New_Occurrence_Of ( + RTE (RE_TypeCode), Loc), + Expression => Inner_Any_TypeCode_Expr)); + + if Present (Inner_Any) then + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Inner_Any, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Inner_Any_TypeCode, Loc))))); + end if; + + if Present (Inner_Counter) then + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Inner_Counter, + Object_Definition => + New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc), + Expression => + Make_Integer_Literal (Loc, 0))); + end if; + + if not Constrained then + Length_Node := Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Arry, Loc), + Attribute_Name => Name_Length, + Expressions => + New_List (Make_Integer_Literal (Loc, Depth))); + Set_Etype (Length_Node, RTE (RE_Long_Unsigned)); + + Add_Process_Element (Dimen_Stmts, + Datum => Length_Node, + Any => Inner_Any, + Counter => Inner_Counter); + end if; + + -- Loop_Stm does appropriate processing for each element + -- of Inner_Any. + + Append_To (Dimen_Stmts, Loop_Stm); + + -- Link outer and inner any + + if Present (Inner_Any) then + Add_Process_Element (Dimen_Stmts, + Any => Any, + Counter => Counter, + Datum => New_Occurrence_Of (Inner_Any, Loc)); + end if; + + Append_To (Stmts, + Make_Block_Statement (Loc, + Declarations => + Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Dimen_Stmts))); + end; + end Append_Array_Traversal; + + ------------------------------- + -- Make_Helper_Function_Name -- + ------------------------------- + + function Make_Helper_Function_Name + (Loc : Source_Ptr; + Typ : Entity_Id; + Nam : Name_Id) return Entity_Id + is + begin + declare + Serial : Nat := 0; + -- For tagged types that aren't frozen yet, generate the helper + -- under its canonical name so that it matches the primitive + -- spec. For all other cases, we use a serialized name so that + -- multiple generations of the same procedure do not clash. + + begin + if Is_Tagged_Type (Typ) and then not Is_Frozen (Typ) then + null; + else + Serial := Increment_Serial_Number; + end if; + + -- Use prefixed underscore to avoid potential clash with user + -- identifier (we use attribute names for Nam). + + return + Make_Defining_Identifier (Loc, + Chars => + New_External_Name + (Related_Id => Nam, + Suffix => ' ', + Suffix_Index => Serial, + Prefix => '_')); + end; + end Make_Helper_Function_Name; + end Helpers; + + ----------------------------------- + -- Reserve_NamingContext_Methods -- + ----------------------------------- + + procedure Reserve_NamingContext_Methods is + Str_Resolve : constant String := "resolve"; + begin + Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve; + Name_Len := Str_Resolve'Length; + Overload_Counter_Table.Set (Name_Find, 1); + end Reserve_NamingContext_Methods; + + end PolyORB_Support; + + ------------------------------- + -- RACW_Type_Is_Asynchronous -- + ------------------------------- + + procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is + Asynchronous_Flag : constant Entity_Id := + Asynchronous_Flags_Table.Get (RACW_Type); + begin + Replace (Expression (Parent (Asynchronous_Flag)), + New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag))); + end RACW_Type_Is_Asynchronous; + + ------------------------- + -- RCI_Package_Locator -- + ------------------------- + + function RCI_Package_Locator + (Loc : Source_Ptr; + Package_Spec : Node_Id) return Node_Id + is + Inst : Node_Id; + Pkg_Name : String_Id; + + begin + Get_Library_Unit_Name_String (Package_Spec); + Pkg_Name := String_From_Name_Buffer; + Inst := + Make_Package_Instantiation (Loc, + Defining_Unit_Name => Make_Temporary (Loc, 'R'), + + Name => + New_Occurrence_Of (RTE (RE_RCI_Locator), Loc), + + Generic_Associations => New_List ( + Make_Generic_Association (Loc, + Selector_Name => + Make_Identifier (Loc, Name_RCI_Name), + Explicit_Generic_Actual_Parameter => + Make_String_Literal (Loc, + Strval => Pkg_Name)), + + Make_Generic_Association (Loc, + Selector_Name => + Make_Identifier (Loc, Name_Version), + Explicit_Generic_Actual_Parameter => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Defining_Entity (Package_Spec), Loc), + Attribute_Name => + Name_Version)))); + + RCI_Locator_Table.Set + (Defining_Unit_Name (Package_Spec), + Defining_Unit_Name (Inst)); + return Inst; + end RCI_Package_Locator; + + ----------------------------------------------- + -- Remote_Types_Tagged_Full_View_Encountered -- + ----------------------------------------------- + + procedure Remote_Types_Tagged_Full_View_Encountered + (Full_View : Entity_Id) + is + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Full_View); + + begin + -- For an RACW encountered before the freeze point of its designated + -- type, the stub type is generated at the point of the RACW declaration + -- but the primitives are generated only once the designated type is + -- frozen. That freeze can occur in another scope, for example when the + -- RACW is declared in a nested package. In that case we need to + -- reestablish the stub type's scope prior to generating its primitive + -- operations. + + if Stub_Elements /= Empty_Stub_Structure then + declare + Saved_Scope : constant Entity_Id := Current_Scope; + Stubs_Scope : constant Entity_Id := + Scope (Stub_Elements.Stub_Type); + + begin + if Current_Scope /= Stubs_Scope then + Push_Scope (Stubs_Scope); + end if; + + Add_RACW_Primitive_Declarations_And_Bodies + (Full_View, + Stub_Elements.RPC_Receiver_Decl, + Stub_Elements.Body_Decls); + + if Current_Scope /= Saved_Scope then + Pop_Scope; + end if; + end; + end if; + end Remote_Types_Tagged_Full_View_Encountered; + + ------------------- + -- Scope_Of_Spec -- + ------------------- + + function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is + Unit_Name : Node_Id; + + begin + Unit_Name := Defining_Unit_Name (Spec); + while Nkind (Unit_Name) /= N_Defining_Identifier loop + Unit_Name := Defining_Identifier (Unit_Name); + end loop; + + return Unit_Name; + end Scope_Of_Spec; + + ---------------------- + -- Set_Renaming_TSS -- + ---------------------- + + procedure Set_Renaming_TSS + (Typ : Entity_Id; + Nam : Entity_Id; + TSS_Nam : TSS_Name_Type) + is + Loc : constant Source_Ptr := Sloc (Nam); + Spec : constant Node_Id := Parent (Nam); + + TSS_Node : constant Node_Id := + Make_Subprogram_Renaming_Declaration (Loc, + Specification => + Copy_Specification (Loc, + Spec => Spec, + New_Name => Make_TSS_Name (Typ, TSS_Nam)), + Name => New_Occurrence_Of (Nam, Loc)); + + Snam : constant Entity_Id := + Defining_Unit_Name (Specification (TSS_Node)); + + begin + if Nkind (Spec) = N_Function_Specification then + Set_Ekind (Snam, E_Function); + Set_Etype (Snam, Entity (Result_Definition (Spec))); + else + Set_Ekind (Snam, E_Procedure); + Set_Etype (Snam, Standard_Void_Type); + end if; + + Set_TSS (Typ, Snam); + end Set_Renaming_TSS; + + ---------------------------------------------- + -- Specific_Add_Obj_RPC_Receiver_Completion -- + ---------------------------------------------- + + procedure Specific_Add_Obj_RPC_Receiver_Completion + (Loc : Source_Ptr; + Decls : List_Id; + RPC_Receiver : Entity_Id; + Stub_Elements : Stub_Structure) + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + PolyORB_Support.Add_Obj_RPC_Receiver_Completion + (Loc, Decls, RPC_Receiver, Stub_Elements); + when others => + GARLIC_Support.Add_Obj_RPC_Receiver_Completion + (Loc, Decls, RPC_Receiver, Stub_Elements); + end case; + end Specific_Add_Obj_RPC_Receiver_Completion; + + -------------------------------- + -- Specific_Add_RACW_Features -- + -------------------------------- + + procedure Specific_Add_RACW_Features + (RACW_Type : Entity_Id; + Desig : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver_Decl : Node_Id; + Body_Decls : List_Id) + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + PolyORB_Support.Add_RACW_Features + (RACW_Type, + Desig, + Stub_Type, + Stub_Type_Access, + RPC_Receiver_Decl, + Body_Decls); + + when others => + GARLIC_Support.Add_RACW_Features + (RACW_Type, + Stub_Type, + Stub_Type_Access, + RPC_Receiver_Decl, + Body_Decls); + end case; + end Specific_Add_RACW_Features; + + -------------------------------- + -- Specific_Add_RAST_Features -- + -------------------------------- + + procedure Specific_Add_RAST_Features + (Vis_Decl : Node_Id; + RAS_Type : Entity_Id) + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type); + when others => + GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type); + end case; + end Specific_Add_RAST_Features; + + -------------------------------------------------- + -- Specific_Add_Receiving_Stubs_To_Declarations -- + -------------------------------------------------- + + procedure Specific_Add_Receiving_Stubs_To_Declarations + (Pkg_Spec : Node_Id; + Decls : List_Id; + Stmts : List_Id) + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + PolyORB_Support.Add_Receiving_Stubs_To_Declarations + (Pkg_Spec, Decls, Stmts); + when others => + GARLIC_Support.Add_Receiving_Stubs_To_Declarations + (Pkg_Spec, Decls, Stmts); + end case; + end Specific_Add_Receiving_Stubs_To_Declarations; + + ------------------------------------------ + -- Specific_Build_General_Calling_Stubs -- + ------------------------------------------ + + procedure Specific_Build_General_Calling_Stubs + (Decls : List_Id; + Statements : List_Id; + Target : RPC_Target; + Subprogram_Id : Node_Id; + Asynchronous : Node_Id := Empty; + Is_Known_Asynchronous : Boolean := False; + Is_Known_Non_Asynchronous : Boolean := False; + Is_Function : Boolean; + Spec : Node_Id; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Nod : Node_Id) + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + PolyORB_Support.Build_General_Calling_Stubs + (Decls, + Statements, + Target.Object, + Subprogram_Id, + Asynchronous, + Is_Known_Asynchronous, + Is_Known_Non_Asynchronous, + Is_Function, + Spec, + Stub_Type, + RACW_Type, + Nod); + + when others => + GARLIC_Support.Build_General_Calling_Stubs + (Decls, + Statements, + Target.Partition, + Target.RPC_Receiver, + Subprogram_Id, + Asynchronous, + Is_Known_Asynchronous, + Is_Known_Non_Asynchronous, + Is_Function, + Spec, + Stub_Type, + RACW_Type, + Nod); + end case; + end Specific_Build_General_Calling_Stubs; + + -------------------------------------- + -- Specific_Build_RPC_Receiver_Body -- + -------------------------------------- + + procedure Specific_Build_RPC_Receiver_Body + (RPC_Receiver : Entity_Id; + Request : out Entity_Id; + Subp_Id : out Entity_Id; + Subp_Index : out Entity_Id; + Stmts : out List_Id; + Decl : out Node_Id) + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + PolyORB_Support.Build_RPC_Receiver_Body + (RPC_Receiver, + Request, + Subp_Id, + Subp_Index, + Stmts, + Decl); + + when others => + GARLIC_Support.Build_RPC_Receiver_Body + (RPC_Receiver, + Request, + Subp_Id, + Subp_Index, + Stmts, + Decl); + end case; + end Specific_Build_RPC_Receiver_Body; + + -------------------------------- + -- Specific_Build_Stub_Target -- + -------------------------------- + + function Specific_Build_Stub_Target + (Loc : Source_Ptr; + Decls : List_Id; + RCI_Locator : Entity_Id; + Controlling_Parameter : Entity_Id) return RPC_Target + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + return + PolyORB_Support.Build_Stub_Target + (Loc, Decls, RCI_Locator, Controlling_Parameter); + + when others => + return + GARLIC_Support.Build_Stub_Target + (Loc, Decls, RCI_Locator, Controlling_Parameter); + end case; + end Specific_Build_Stub_Target; + + ------------------------------ + -- Specific_Build_Stub_Type -- + ------------------------------ + + procedure Specific_Build_Stub_Type + (RACW_Type : Entity_Id; + Stub_Type_Comps : out List_Id; + RPC_Receiver_Decl : out Node_Id) + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + PolyORB_Support.Build_Stub_Type + (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl); + + when others => + GARLIC_Support.Build_Stub_Type + (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl); + end case; + end Specific_Build_Stub_Type; + + ----------------------------------------------- + -- Specific_Build_Subprogram_Receiving_Stubs -- + ----------------------------------------------- + + function Specific_Build_Subprogram_Receiving_Stubs + (Vis_Decl : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Parent_Primitive : Entity_Id := Empty) return Node_Id + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + return + PolyORB_Support.Build_Subprogram_Receiving_Stubs + (Vis_Decl, + Asynchronous, + Dynamically_Asynchronous, + Stub_Type, + RACW_Type, + Parent_Primitive); + + when others => + return + GARLIC_Support.Build_Subprogram_Receiving_Stubs + (Vis_Decl, + Asynchronous, + Dynamically_Asynchronous, + Stub_Type, + RACW_Type, + Parent_Primitive); + end case; + end Specific_Build_Subprogram_Receiving_Stubs; + + ------------------------------- + -- Transmit_As_Unconstrained -- + ------------------------------- + + function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean is + begin + return + not (Is_Elementary_Type (Typ) or else Is_Constrained (Typ)) + or else (Is_Access_Type (Typ) and then Can_Never_Be_Null (Typ)); + end Transmit_As_Unconstrained; + + -------------------------- + -- Underlying_RACW_Type -- + -------------------------- + + function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is + Record_Type : Entity_Id; + + begin + if Ekind (RAS_Typ) = E_Record_Type then + Record_Type := RAS_Typ; + else + pragma Assert (Present (Equivalent_Type (RAS_Typ))); + Record_Type := Equivalent_Type (RAS_Typ); + end if; + + return + Etype (Subtype_Indication + (Component_Definition + (First (Component_Items + (Component_List + (Type_Definition + (Declaration_Node (Record_Type)))))))); + end Underlying_RACW_Type; + +end Exp_Dist; diff --git a/gcc/ada/exp_dist.ads b/gcc/ada/exp_dist.ads new file mode 100644 index 000000000..382f77a02 --- /dev/null +++ b/gcc/ada/exp_dist.ads @@ -0,0 +1,165 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ D I S T -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains utility routines used for the generation of the +-- stubs relevant to the distribution annex. + +with Namet; use Namet; +with Snames; use Snames; +with Types; use Types; + +package Exp_Dist is + + PCS_Version_Number : constant array (PCS_Names) of Int := + (Name_No_DSA => 1, + Name_GARLIC_DSA => 1, + Name_PolyORB_DSA => 4); + -- PCS interface version. This is used to check for consistency between the + -- compiler used to generate distribution stubs and the PCS implementation. + -- It must be incremented whenever a change is made to the generated code + -- for distribution stubs that would result in the compiler being + -- incompatible with an older version of the PCS, or vice versa. + + procedure Add_RAST_Features (Vis_Decl : Node_Id); + -- Build and add bodies for dereference and 'Access subprograms for a + -- remote access to subprogram type. Vis_Decl is the declaration node for + -- the RAS type. + + procedure Add_RACW_Features (RACW_Type : Entity_Id); + -- Add RACW features. If the RACW and the designated type are not in the + -- same scope, then Add_RACW_Primitive_Declarations_And_Bodies is called + -- automatically since we do know the primitive list already. + + procedure Add_RACW_Primitive_Declarations_And_Bodies + (Designated_Type : Entity_Id; + Insertion_Node : Node_Id; + Body_Decls : List_Id); + -- Add primitive for the stub type, and the RPC receiver. The declarations + -- are inserted after Insertion_Node, while the bodies are appended at the + -- end of Body_Decls. + + procedure Remote_Types_Tagged_Full_View_Encountered + (Full_View : Entity_Id); + -- When a full view with a private view is encountered in a Remote_Types + -- package and corresponds to a tagged type, then this procedure is called + -- to generate the needed RACW features if it is needed. + + procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id); + -- This subprogram must be called when it is detected that the RACW type + -- is asynchronous. + + procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id); + -- Call the expansion phase for the calling stubs. The code will be added + -- at the end of the compilation unit, which is a package spec. + + procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id); + -- Call the expansion phase for the receiving stubs. The code will be added + -- at the end of the compilation unit, which may be either a package spec + -- or a package body. + + procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id); + -- Rewrite a call to a subprogram located in a Remote_Call_Interface + -- package to which the pragma All_Calls_Remote applies so that it + -- goes through the PCS. N is either an N_Procedure_Call_Statement + -- or an N_Function_Call node. + + procedure Build_Passive_Partition_Stub (U : Node_Id); + -- Build stub for a shared passive package. U is the analyzed + -- compilation unit for a package declaration. + + function Build_Subprogram_Id + (Loc : Source_Ptr; + E : Entity_Id) return Node_Id; + -- Build a literal representing the remote subprogram identifier of E + + function Copy_Specification + (Loc : Source_Ptr; + Spec : Node_Id; + Ctrl_Type : Entity_Id := Empty; + New_Name : Name_Id := No_Name) return Node_Id; + -- Build a subprogram specification from another one, or from an + -- access-to-subprogram definition. If Ctrl_Type is not Empty, and any + -- controlling formal of an anonymous access type is found, then it is + -- replaced by an access to Ctrl_Type. If New_Name is given, then it will + -- be used as the name for the newly created spec. + + function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id; + -- Return the stub type associated with the given RACW type + + function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id; + -- Given a remote access-to-subprogram type or its equivalent + -- record type, return the RACW type generated to implement it. + + procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id); + -- Append the unanalyzed subprogram bodies generated to support RACWs + -- declared in the given package spec (RACW stream subprograms, calling + -- stubs primitive operations) to the given list (which is expected to be + -- the declarations list for the corresponding package body, if there is + -- one). In the case where a body is present, the subprogram bodies must + -- not be generated in the package spec because this would cause an + -- incorrect attempt to freeze Taft amendment types declared in the spec. + + function Make_Transportable_Check + (Loc : Source_Ptr; + Expr : Node_Id) return Node_Id; + -- Generate a check that the given expression (an actual in a remote + -- subprogram call, or the return value of a function in the context of + -- a remote call) satisfies the requirements for being transportable + -- across partitions, raising Program_Error if it does not. + + ---------------------------------------------------------------- + -- Functions for expansion of PolyORB/DSA specific attributes -- + ---------------------------------------------------------------- + + function Build_From_Any_Call + (Typ : Entity_Id; + N : Node_Id; + Decls : List_Id) return Node_Id; + -- Build call to From_Any attribute function of type Typ with expression + -- N as actual parameter. Decls is the declarations list for an appropriate + -- enclosing scope of the point where the call will be inserted; if the + -- From_Any attribute for Typ needs to be generated at this point, its + -- declaration is appended to Decls. + + function Build_To_Any_Call + (N : Node_Id; + Decls : List_Id) return Node_Id; + -- Build call to To_Any attribute function with expression as actual + -- parameter. Decls is the declarations list for an appropriate + -- enclosing scope of the point where the call will be inserted; if + -- the To_Any attribute for Typ needs to be generated at this point, + -- its declaration is appended to Decls. + + function Build_TypeCode_Call + (Loc : Source_Ptr; + Typ : Entity_Id; + Decls : List_Id) return Node_Id; + -- Build call to TypeCode attribute function for Typ. Decls is the + -- declarations list for an appropriate enclosing scope of the point + -- where the call will be inserted; if the To_Any attribute for Typ + -- needs to be generated at this point, its declaration is appended + -- to Decls. + +end Exp_Dist; diff --git a/gcc/ada/exp_fixd.adb b/gcc/ada/exp_fixd.adb new file mode 100644 index 000000000..28b93b5f8 --- /dev/null +++ b/gcc/ada/exp_fixd.adb @@ -0,0 +1,2391 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ F I X D -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Einfo; use Einfo; +with Exp_Util; use Exp_Util; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Stand; use Stand; +with Tbuild; use Tbuild; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package body Exp_Fixd is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + -- General note; in this unit, a number of routines are driven by the + -- types (Etype) of their operands. Since we are dealing with unanalyzed + -- expressions as they are constructed, the Etypes would not normally be + -- set, but the construction routines that we use in this unit do in fact + -- set the Etype values correctly. In addition, setting the Etype ensures + -- that the analyzer does not try to redetermine the type when the node + -- is analyzed (which would be wrong, since in the case where we set the + -- Treat_Fixed_As_Integer or Conversion_OK flags, it would think it was + -- still dealing with a normal fixed-point operation and mess it up). + + function Build_Conversion + (N : Node_Id; + Typ : Entity_Id; + Expr : Node_Id; + Rchk : Boolean := False; + Trunc : Boolean := False) return Node_Id; + -- Build an expression that converts the expression Expr to type Typ, + -- taking the source location from Sloc (N). If the conversions involve + -- fixed-point types, then the Conversion_OK flag will be set so that the + -- resulting conversions do not get re-expanded. On return the resulting + -- node has its Etype set. If Rchk is set, then Do_Range_Check is set + -- in the resulting conversion node. If Trunc is set, then the + -- Float_Truncate flag is set on the conversion, which must be from + -- a floating-point type to an integer type. + + function Build_Divide (N : Node_Id; L, R : Node_Id) return Node_Id; + -- Builds an N_Op_Divide node from the given left and right operand + -- expressions, using the source location from Sloc (N). The operands are + -- either both Universal_Real, in which case Build_Divide differs from + -- Make_Op_Divide only in that the Etype of the resulting node is set (to + -- Universal_Real), or they can be integer types. In this case the integer + -- types need not be the same, and Build_Divide converts the operand with + -- the smaller sized type to match the type of the other operand and sets + -- this as the result type. The Rounded_Result flag of the result in this + -- case is set from the Rounded_Result flag of node N. On return, the + -- resulting node is analyzed, and has its Etype set. + + function Build_Double_Divide + (N : Node_Id; + X, Y, Z : Node_Id) return Node_Id; + -- Returns a node corresponding to the value X/(Y*Z) using the source + -- location from Sloc (N). The division is rounded if the Rounded_Result + -- flag of N is set. The integer types of X, Y, Z may be different. On + -- return the resulting node is analyzed, and has its Etype set. + + procedure Build_Double_Divide_Code + (N : Node_Id; + X, Y, Z : Node_Id; + Qnn, Rnn : out Entity_Id; + Code : out List_Id); + -- Generates a sequence of code for determining the quotient and remainder + -- of the division X/(Y*Z), using the source location from Sloc (N). + -- Entities of appropriate types are allocated for the quotient and + -- remainder and returned in Qnn and Rnn. The result is rounded if the + -- Rounded_Result flag of N is set. The Etype fields of Qnn and Rnn are + -- appropriately set on return. + + function Build_Multiply (N : Node_Id; L, R : Node_Id) return Node_Id; + -- Builds an N_Op_Multiply node from the given left and right operand + -- expressions, using the source location from Sloc (N). The operands are + -- either both Universal_Real, in which case Build_Multiply differs from + -- Make_Op_Multiply only in that the Etype of the resulting node is set (to + -- Universal_Real), or they can be integer types. In this case the integer + -- types need not be the same, and Build_Multiply chooses a type long + -- enough to hold the product (i.e. twice the size of the longer of the two + -- operand types), and both operands are converted to this type. The Etype + -- of the result is also set to this value. However, the result can never + -- overflow Integer_64, so this is the largest type that is ever generated. + -- On return, the resulting node is analyzed and has its Etype set. + + function Build_Rem (N : Node_Id; L, R : Node_Id) return Node_Id; + -- Builds an N_Op_Rem node from the given left and right operand + -- expressions, using the source location from Sloc (N). The operands are + -- both integer types, which need not be the same. Build_Rem converts the + -- operand with the smaller sized type to match the type of the other + -- operand and sets this as the result type. The result is never rounded + -- (rem operations cannot be rounded in any case!) On return, the resulting + -- node is analyzed and has its Etype set. + + function Build_Scaled_Divide + (N : Node_Id; + X, Y, Z : Node_Id) return Node_Id; + -- Returns a node corresponding to the value X*Y/Z using the source + -- location from Sloc (N). The division is rounded if the Rounded_Result + -- flag of N is set. The integer types of X, Y, Z may be different. On + -- return the resulting node is analyzed and has is Etype set. + + procedure Build_Scaled_Divide_Code + (N : Node_Id; + X, Y, Z : Node_Id; + Qnn, Rnn : out Entity_Id; + Code : out List_Id); + -- Generates a sequence of code for determining the quotient and remainder + -- of the division X*Y/Z, using the source location from Sloc (N). Entities + -- of appropriate types are allocated for the quotient and remainder and + -- returned in Qnn and Rrr. The integer types for X, Y, Z may be different. + -- The division is rounded if the Rounded_Result flag of N is set. The + -- Etype fields of Qnn and Rnn are appropriately set on return. + + procedure Do_Divide_Fixed_Fixed (N : Node_Id); + -- Handles expansion of divide for case of two fixed-point operands + -- (neither of them universal), with an integer or fixed-point result. + -- N is the N_Op_Divide node to be expanded. + + procedure Do_Divide_Fixed_Universal (N : Node_Id); + -- Handles expansion of divide for case of a fixed-point operand divided + -- by a universal real operand, with an integer or fixed-point result. N + -- is the N_Op_Divide node to be expanded. + + procedure Do_Divide_Universal_Fixed (N : Node_Id); + -- Handles expansion of divide for case of a universal real operand + -- divided by a fixed-point operand, with an integer or fixed-point + -- result. N is the N_Op_Divide node to be expanded. + + procedure Do_Multiply_Fixed_Fixed (N : Node_Id); + -- Handles expansion of multiply for case of two fixed-point operands + -- (neither of them universal), with an integer or fixed-point result. + -- N is the N_Op_Multiply node to be expanded. + + procedure Do_Multiply_Fixed_Universal (N : Node_Id; Left, Right : Node_Id); + -- Handles expansion of multiply for case of a fixed-point operand + -- multiplied by a universal real operand, with an integer or fixed- + -- point result. N is the N_Op_Multiply node to be expanded, and + -- Left, Right are the operands (which may have been switched). + + procedure Expand_Convert_Fixed_Static (N : Node_Id); + -- This routine is called where the node N is a conversion of a literal + -- or other static expression of a fixed-point type to some other type. + -- In such cases, we simply rewrite the operand as a real literal and + -- reanalyze. This avoids problems which would otherwise result from + -- attempting to build and fold expressions involving constants. + + function Fpt_Value (N : Node_Id) return Node_Id; + -- Given an operand of fixed-point operation, return an expression that + -- represents the corresponding Universal_Real value. The expression + -- can be of integer type, floating-point type, or fixed-point type. + -- The expression returned is neither analyzed and resolved. The Etype + -- of the result is properly set (to Universal_Real). + + function Integer_Literal + (N : Node_Id; + V : Uint; + Negative : Boolean := False) return Node_Id; + -- Given a non-negative universal integer value, build a typed integer + -- literal node, using the smallest applicable standard integer type. If + -- and only if Negative is true a negative literal is built. If V exceeds + -- 2**63-1, the largest value allowed for perfect result set scaling + -- factors (see RM G.2.3(22)), then Empty is returned. The node N provides + -- the Sloc value for the constructed literal. The Etype of the resulting + -- literal is correctly set, and it is marked as analyzed. + + function Real_Literal (N : Node_Id; V : Ureal) return Node_Id; + -- Build a real literal node from the given value, the Etype of the + -- returned node is set to Universal_Real, since all floating-point + -- arithmetic operations that we construct use Universal_Real + + function Rounded_Result_Set (N : Node_Id) return Boolean; + -- Returns True if N is a node that contains the Rounded_Result flag + -- and if the flag is true or the target type is an integer type. + + procedure Set_Result + (N : Node_Id; + Expr : Node_Id; + Rchk : Boolean := False; + Trunc : Boolean := False); + -- N is the node for the current conversion, division or multiplication + -- operation, and Expr is an expression representing the result. Expr may + -- be of floating-point or integer type. If the operation result is fixed- + -- point, then the value of Expr is in units of small of the result type + -- (i.e. small's have already been dealt with). The result of the call is + -- to replace N by an appropriate conversion to the result type, dealing + -- with rounding for the decimal types case. The node is then analyzed and + -- resolved using the result type. If Rchk or Trunc are True, then + -- respectively Do_Range_Check and Float_Truncate are set in the + -- resulting conversion. + + ---------------------- + -- Build_Conversion -- + ---------------------- + + function Build_Conversion + (N : Node_Id; + Typ : Entity_Id; + Expr : Node_Id; + Rchk : Boolean := False; + Trunc : Boolean := False) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Result : Node_Id; + Rcheck : Boolean := Rchk; + + begin + -- A special case, if the expression is an integer literal and the + -- target type is an integer type, then just retype the integer + -- literal to the desired target type. Don't do this if we need + -- a range check. + + if Nkind (Expr) = N_Integer_Literal + and then Is_Integer_Type (Typ) + and then not Rchk + then + Result := Expr; + + -- Cases where we end up with a conversion. Note that we do not use the + -- Convert_To abstraction here, since we may be decorating the resulting + -- conversion with Rounded_Result and/or Conversion_OK, so we want the + -- conversion node present, even if it appears to be redundant. + + else + -- Remove inner conversion if both inner and outer conversions are + -- to integer types, since the inner one serves no purpose (except + -- perhaps to set rounding, so we preserve the Rounded_Result flag) + -- and also we preserve the range check flag on the inner operand + + if Is_Integer_Type (Typ) + and then Is_Integer_Type (Etype (Expr)) + and then Nkind (Expr) = N_Type_Conversion + then + Result := + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Expression => Expression (Expr)); + Set_Rounded_Result (Result, Rounded_Result_Set (Expr)); + Rcheck := Rcheck or Do_Range_Check (Expr); + + -- For all other cases, a simple type conversion will work + + else + Result := + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Expression => Expr); + + Set_Float_Truncate (Result, Trunc); + end if; + + -- Set Conversion_OK if either result or expression type is a + -- fixed-point type, since from a semantic point of view, we are + -- treating fixed-point values as integers at this stage. + + if Is_Fixed_Point_Type (Typ) + or else Is_Fixed_Point_Type (Etype (Expression (Result))) + then + Set_Conversion_OK (Result); + end if; + + -- Set Do_Range_Check if either it was requested by the caller, + -- or if an eliminated inner conversion had a range check. + + if Rcheck then + Enable_Range_Check (Result); + else + Set_Do_Range_Check (Result, False); + end if; + end if; + + Set_Etype (Result, Typ); + return Result; + end Build_Conversion; + + ------------------ + -- Build_Divide -- + ------------------ + + function Build_Divide (N : Node_Id; L, R : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + Left_Type : constant Entity_Id := Base_Type (Etype (L)); + Right_Type : constant Entity_Id := Base_Type (Etype (R)); + Result_Type : Entity_Id; + Rnode : Node_Id; + + begin + -- Deal with floating-point case first + + if Is_Floating_Point_Type (Left_Type) then + pragma Assert (Left_Type = Universal_Real); + pragma Assert (Right_Type = Universal_Real); + + Rnode := Make_Op_Divide (Loc, L, R); + Result_Type := Universal_Real; + + -- Integer and fixed-point cases + + else + -- An optimization. If the right operand is the literal 1, then we + -- can just return the left hand operand. Putting the optimization + -- here allows us to omit the check at the call site. + + if Nkind (R) = N_Integer_Literal and then Intval (R) = 1 then + return L; + end if; + + -- If left and right types are the same, no conversion needed + + if Left_Type = Right_Type then + Result_Type := Left_Type; + Rnode := + Make_Op_Divide (Loc, + Left_Opnd => L, + Right_Opnd => R); + + -- Use left type if it is the larger of the two + + elsif Esize (Left_Type) >= Esize (Right_Type) then + Result_Type := Left_Type; + Rnode := + Make_Op_Divide (Loc, + Left_Opnd => L, + Right_Opnd => Build_Conversion (N, Left_Type, R)); + + -- Otherwise right type is larger of the two, us it + + else + Result_Type := Right_Type; + Rnode := + Make_Op_Divide (Loc, + Left_Opnd => Build_Conversion (N, Right_Type, L), + Right_Opnd => R); + end if; + end if; + + -- We now have a divide node built with Result_Type set. First + -- set Etype of result, as required for all Build_xxx routines + + Set_Etype (Rnode, Base_Type (Result_Type)); + + -- Set Treat_Fixed_As_Integer if operation on fixed-point type + -- since this is a literal arithmetic operation, to be performed + -- by Gigi without any consideration of small values. + + if Is_Fixed_Point_Type (Result_Type) then + Set_Treat_Fixed_As_Integer (Rnode); + end if; + + -- The result is rounded if the target of the operation is decimal + -- and Rounded_Result is set, or if the target of the operation + -- is an integer type. + + if Is_Integer_Type (Etype (N)) + or else Rounded_Result_Set (N) + then + Set_Rounded_Result (Rnode); + end if; + + return Rnode; + end Build_Divide; + + ------------------------- + -- Build_Double_Divide -- + ------------------------- + + function Build_Double_Divide + (N : Node_Id; + X, Y, Z : Node_Id) return Node_Id + is + Y_Size : constant Int := UI_To_Int (Esize (Etype (Y))); + Z_Size : constant Int := UI_To_Int (Esize (Etype (Z))); + Expr : Node_Id; + + begin + -- If denominator fits in 64 bits, we can build the operations directly + -- without causing any intermediate overflow, so that's what we do! + + if Int'Max (Y_Size, Z_Size) <= 32 then + return + Build_Divide (N, X, Build_Multiply (N, Y, Z)); + + -- Otherwise we use the runtime routine + + -- [Qnn : Interfaces.Integer_64, + -- Rnn : Interfaces.Integer_64; + -- Double_Divide (X, Y, Z, Qnn, Rnn, Round); + -- Qnn] + + else + declare + Loc : constant Source_Ptr := Sloc (N); + Qnn : Entity_Id; + Rnn : Entity_Id; + Code : List_Id; + + pragma Warnings (Off, Rnn); + + begin + Build_Double_Divide_Code (N, X, Y, Z, Qnn, Rnn, Code); + Insert_Actions (N, Code); + Expr := New_Occurrence_Of (Qnn, Loc); + + -- Set type of result in case used elsewhere (see note at start) + + Set_Etype (Expr, Etype (Qnn)); + + -- Set result as analyzed (see note at start on build routines) + + return Expr; + end; + end if; + end Build_Double_Divide; + + ------------------------------ + -- Build_Double_Divide_Code -- + ------------------------------ + + -- If the denominator can be computed in 64-bits, we build + + -- [Nnn : constant typ := typ (X); + -- Dnn : constant typ := typ (Y) * typ (Z) + -- Qnn : constant typ := Nnn / Dnn; + -- Rnn : constant typ := Nnn / Dnn; + + -- If the numerator cannot be computed in 64 bits, we build + + -- [Qnn : typ; + -- Rnn : typ; + -- Double_Divide (X, Y, Z, Qnn, Rnn, Round);] + + procedure Build_Double_Divide_Code + (N : Node_Id; + X, Y, Z : Node_Id; + Qnn, Rnn : out Entity_Id; + Code : out List_Id) + is + Loc : constant Source_Ptr := Sloc (N); + + X_Size : constant Int := UI_To_Int (Esize (Etype (X))); + Y_Size : constant Int := UI_To_Int (Esize (Etype (Y))); + Z_Size : constant Int := UI_To_Int (Esize (Etype (Z))); + + QR_Siz : Int; + QR_Typ : Entity_Id; + + Nnn : Entity_Id; + Dnn : Entity_Id; + + Quo : Node_Id; + Rnd : Entity_Id; + + begin + -- Find type that will allow computation of numerator + + QR_Siz := Int'Max (X_Size, 2 * Int'Max (Y_Size, Z_Size)); + + if QR_Siz <= 16 then + QR_Typ := Standard_Integer_16; + elsif QR_Siz <= 32 then + QR_Typ := Standard_Integer_32; + elsif QR_Siz <= 64 then + QR_Typ := Standard_Integer_64; + + -- For more than 64, bits, we use the 64-bit integer defined in + -- Interfaces, so that it can be handled by the runtime routine + + else + QR_Typ := RTE (RE_Integer_64); + end if; + + -- Define quotient and remainder, and set their Etypes, so + -- that they can be picked up by Build_xxx routines. + + Qnn := Make_Temporary (Loc, 'S'); + Rnn := Make_Temporary (Loc, 'R'); + + Set_Etype (Qnn, QR_Typ); + Set_Etype (Rnn, QR_Typ); + + -- Case that we can compute the denominator in 64 bits + + if QR_Siz <= 64 then + + -- Create temporaries for numerator and denominator and set Etypes, + -- so that New_Occurrence_Of picks them up for Build_xxx calls. + + Nnn := Make_Temporary (Loc, 'N'); + Dnn := Make_Temporary (Loc, 'D'); + + Set_Etype (Nnn, QR_Typ); + Set_Etype (Dnn, QR_Typ); + + Code := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Nnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => Build_Conversion (N, QR_Typ, X)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Dnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => + Build_Multiply (N, + Build_Conversion (N, QR_Typ, Y), + Build_Conversion (N, QR_Typ, Z)))); + + Quo := + Build_Divide (N, + New_Occurrence_Of (Nnn, Loc), + New_Occurrence_Of (Dnn, Loc)); + + Set_Rounded_Result (Quo, Rounded_Result_Set (N)); + + Append_To (Code, + Make_Object_Declaration (Loc, + Defining_Identifier => Qnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => Quo)); + + Append_To (Code, + Make_Object_Declaration (Loc, + Defining_Identifier => Rnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => + Build_Rem (N, + New_Occurrence_Of (Nnn, Loc), + New_Occurrence_Of (Dnn, Loc)))); + + -- Case where denominator does not fit in 64 bits, so we have to + -- call the runtime routine to compute the quotient and remainder + + else + Rnd := Boolean_Literals (Rounded_Result_Set (N)); + + Code := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Qnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Rnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc)), + + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Double_Divide), Loc), + Parameter_Associations => New_List ( + Build_Conversion (N, QR_Typ, X), + Build_Conversion (N, QR_Typ, Y), + Build_Conversion (N, QR_Typ, Z), + New_Occurrence_Of (Qnn, Loc), + New_Occurrence_Of (Rnn, Loc), + New_Occurrence_Of (Rnd, Loc)))); + end if; + end Build_Double_Divide_Code; + + -------------------- + -- Build_Multiply -- + -------------------- + + function Build_Multiply (N : Node_Id; L, R : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + Left_Type : constant Entity_Id := Etype (L); + Right_Type : constant Entity_Id := Etype (R); + Left_Size : Int; + Right_Size : Int; + Rsize : Int; + Result_Type : Entity_Id; + Rnode : Node_Id; + + begin + -- Deal with floating-point case first + + if Is_Floating_Point_Type (Left_Type) then + pragma Assert (Left_Type = Universal_Real); + pragma Assert (Right_Type = Universal_Real); + + Result_Type := Universal_Real; + Rnode := Make_Op_Multiply (Loc, L, R); + + -- Integer and fixed-point cases + + else + -- An optimization. If the right operand is the literal 1, then we + -- can just return the left hand operand. Putting the optimization + -- here allows us to omit the check at the call site. Similarly, if + -- the left operand is the integer 1 we can return the right operand. + + if Nkind (R) = N_Integer_Literal and then Intval (R) = 1 then + return L; + elsif Nkind (L) = N_Integer_Literal and then Intval (L) = 1 then + return R; + end if; + + -- Otherwise we need to figure out the correct result type size + -- First figure out the effective sizes of the operands. Normally + -- the effective size of an operand is the RM_Size of the operand. + -- But a special case arises with operands whose size is known at + -- compile time. In this case, we can use the actual value of the + -- operand to get its size if it would fit signed in 8 or 16 bits. + + Left_Size := UI_To_Int (RM_Size (Left_Type)); + + if Compile_Time_Known_Value (L) then + declare + Val : constant Uint := Expr_Value (L); + begin + if Val < Int'(2 ** 7) then + Left_Size := 8; + elsif Val < Int'(2 ** 15) then + Left_Size := 16; + end if; + end; + end if; + + Right_Size := UI_To_Int (RM_Size (Right_Type)); + + if Compile_Time_Known_Value (R) then + declare + Val : constant Uint := Expr_Value (R); + begin + if Val <= Int'(2 ** 7) then + Right_Size := 8; + elsif Val <= Int'(2 ** 15) then + Right_Size := 16; + end if; + end; + end if; + + -- Now the result size must be at least twice the longer of + -- the two sizes, to accommodate all possible results. + + Rsize := 2 * Int'Max (Left_Size, Right_Size); + + if Rsize <= 8 then + Result_Type := Standard_Integer_8; + + elsif Rsize <= 16 then + Result_Type := Standard_Integer_16; + + elsif Rsize <= 32 then + Result_Type := Standard_Integer_32; + + else + Result_Type := Standard_Integer_64; + end if; + + Rnode := + Make_Op_Multiply (Loc, + Left_Opnd => Build_Conversion (N, Result_Type, L), + Right_Opnd => Build_Conversion (N, Result_Type, R)); + end if; + + -- We now have a multiply node built with Result_Type set. First + -- set Etype of result, as required for all Build_xxx routines + + Set_Etype (Rnode, Base_Type (Result_Type)); + + -- Set Treat_Fixed_As_Integer if operation on fixed-point type + -- since this is a literal arithmetic operation, to be performed + -- by Gigi without any consideration of small values. + + if Is_Fixed_Point_Type (Result_Type) then + Set_Treat_Fixed_As_Integer (Rnode); + end if; + + return Rnode; + end Build_Multiply; + + --------------- + -- Build_Rem -- + --------------- + + function Build_Rem (N : Node_Id; L, R : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + Left_Type : constant Entity_Id := Etype (L); + Right_Type : constant Entity_Id := Etype (R); + Result_Type : Entity_Id; + Rnode : Node_Id; + + begin + if Left_Type = Right_Type then + Result_Type := Left_Type; + Rnode := + Make_Op_Rem (Loc, + Left_Opnd => L, + Right_Opnd => R); + + -- If left size is larger, we do the remainder operation using the + -- size of the left type (i.e. the larger of the two integer types). + + elsif Esize (Left_Type) >= Esize (Right_Type) then + Result_Type := Left_Type; + Rnode := + Make_Op_Rem (Loc, + Left_Opnd => L, + Right_Opnd => Build_Conversion (N, Left_Type, R)); + + -- Similarly, if the right size is larger, we do the remainder + -- operation using the right type. + + else + Result_Type := Right_Type; + Rnode := + Make_Op_Rem (Loc, + Left_Opnd => Build_Conversion (N, Right_Type, L), + Right_Opnd => R); + end if; + + -- We now have an N_Op_Rem node built with Result_Type set. First + -- set Etype of result, as required for all Build_xxx routines + + Set_Etype (Rnode, Base_Type (Result_Type)); + + -- Set Treat_Fixed_As_Integer if operation on fixed-point type + -- since this is a literal arithmetic operation, to be performed + -- by Gigi without any consideration of small values. + + if Is_Fixed_Point_Type (Result_Type) then + Set_Treat_Fixed_As_Integer (Rnode); + end if; + + -- One more check. We did the rem operation using the larger of the + -- two types, which is reasonable. However, in the case where the + -- two types have unequal sizes, it is impossible for the result of + -- a remainder operation to be larger than the smaller of the two + -- types, so we can put a conversion round the result to keep the + -- evolving operation size as small as possible. + + if Esize (Left_Type) >= Esize (Right_Type) then + Rnode := Build_Conversion (N, Right_Type, Rnode); + elsif Esize (Right_Type) >= Esize (Left_Type) then + Rnode := Build_Conversion (N, Left_Type, Rnode); + end if; + + return Rnode; + end Build_Rem; + + ------------------------- + -- Build_Scaled_Divide -- + ------------------------- + + function Build_Scaled_Divide + (N : Node_Id; + X, Y, Z : Node_Id) return Node_Id + is + X_Size : constant Int := UI_To_Int (Esize (Etype (X))); + Y_Size : constant Int := UI_To_Int (Esize (Etype (Y))); + Expr : Node_Id; + + begin + -- If numerator fits in 64 bits, we can build the operations directly + -- without causing any intermediate overflow, so that's what we do! + + if Int'Max (X_Size, Y_Size) <= 32 then + return + Build_Divide (N, Build_Multiply (N, X, Y), Z); + + -- Otherwise we use the runtime routine + + -- [Qnn : Integer_64, + -- Rnn : Integer_64; + -- Scaled_Divide (X, Y, Z, Qnn, Rnn, Round); + -- Qnn] + + else + declare + Loc : constant Source_Ptr := Sloc (N); + Qnn : Entity_Id; + Rnn : Entity_Id; + Code : List_Id; + + pragma Warnings (Off, Rnn); + + begin + Build_Scaled_Divide_Code (N, X, Y, Z, Qnn, Rnn, Code); + Insert_Actions (N, Code); + Expr := New_Occurrence_Of (Qnn, Loc); + + -- Set type of result in case used elsewhere (see note at start) + + Set_Etype (Expr, Etype (Qnn)); + return Expr; + end; + end if; + end Build_Scaled_Divide; + + ------------------------------ + -- Build_Scaled_Divide_Code -- + ------------------------------ + + -- If the numerator can be computed in 64-bits, we build + + -- [Nnn : constant typ := typ (X) * typ (Y); + -- Dnn : constant typ := typ (Z) + -- Qnn : constant typ := Nnn / Dnn; + -- Rnn : constant typ := Nnn / Dnn; + + -- If the numerator cannot be computed in 64 bits, we build + + -- [Qnn : Interfaces.Integer_64; + -- Rnn : Interfaces.Integer_64; + -- Scaled_Divide (X, Y, Z, Qnn, Rnn, Round);] + + procedure Build_Scaled_Divide_Code + (N : Node_Id; + X, Y, Z : Node_Id; + Qnn, Rnn : out Entity_Id; + Code : out List_Id) + is + Loc : constant Source_Ptr := Sloc (N); + + X_Size : constant Int := UI_To_Int (Esize (Etype (X))); + Y_Size : constant Int := UI_To_Int (Esize (Etype (Y))); + Z_Size : constant Int := UI_To_Int (Esize (Etype (Z))); + + QR_Siz : Int; + QR_Typ : Entity_Id; + + Nnn : Entity_Id; + Dnn : Entity_Id; + + Quo : Node_Id; + Rnd : Entity_Id; + + begin + -- Find type that will allow computation of numerator + + QR_Siz := Int'Max (X_Size, 2 * Int'Max (Y_Size, Z_Size)); + + if QR_Siz <= 16 then + QR_Typ := Standard_Integer_16; + elsif QR_Siz <= 32 then + QR_Typ := Standard_Integer_32; + elsif QR_Siz <= 64 then + QR_Typ := Standard_Integer_64; + + -- For more than 64, bits, we use the 64-bit integer defined in + -- Interfaces, so that it can be handled by the runtime routine + + else + QR_Typ := RTE (RE_Integer_64); + end if; + + -- Define quotient and remainder, and set their Etypes, so + -- that they can be picked up by Build_xxx routines. + + Qnn := Make_Temporary (Loc, 'S'); + Rnn := Make_Temporary (Loc, 'R'); + + Set_Etype (Qnn, QR_Typ); + Set_Etype (Rnn, QR_Typ); + + -- Case that we can compute the numerator in 64 bits + + if QR_Siz <= 64 then + Nnn := Make_Temporary (Loc, 'N'); + Dnn := Make_Temporary (Loc, 'D'); + + -- Set Etypes, so that they can be picked up by New_Occurrence_Of + + Set_Etype (Nnn, QR_Typ); + Set_Etype (Dnn, QR_Typ); + + Code := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Nnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => + Build_Multiply (N, + Build_Conversion (N, QR_Typ, X), + Build_Conversion (N, QR_Typ, Y))), + + Make_Object_Declaration (Loc, + Defining_Identifier => Dnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => Build_Conversion (N, QR_Typ, Z))); + + Quo := + Build_Divide (N, + New_Occurrence_Of (Nnn, Loc), + New_Occurrence_Of (Dnn, Loc)); + + Append_To (Code, + Make_Object_Declaration (Loc, + Defining_Identifier => Qnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => Quo)); + + Append_To (Code, + Make_Object_Declaration (Loc, + Defining_Identifier => Rnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc), + Constant_Present => True, + Expression => + Build_Rem (N, + New_Occurrence_Of (Nnn, Loc), + New_Occurrence_Of (Dnn, Loc)))); + + -- Case where numerator does not fit in 64 bits, so we have to + -- call the runtime routine to compute the quotient and remainder + + else + Rnd := Boolean_Literals (Rounded_Result_Set (N)); + + Code := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Qnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Rnn, + Object_Definition => New_Occurrence_Of (QR_Typ, Loc)), + + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Scaled_Divide), Loc), + Parameter_Associations => New_List ( + Build_Conversion (N, QR_Typ, X), + Build_Conversion (N, QR_Typ, Y), + Build_Conversion (N, QR_Typ, Z), + New_Occurrence_Of (Qnn, Loc), + New_Occurrence_Of (Rnn, Loc), + New_Occurrence_Of (Rnd, Loc)))); + end if; + + -- Set type of result, for use in caller + + Set_Etype (Qnn, QR_Typ); + end Build_Scaled_Divide_Code; + + --------------------------- + -- Do_Divide_Fixed_Fixed -- + --------------------------- + + -- We have: + + -- (Result_Value * Result_Small) = + -- (Left_Value * Left_Small) / (Right_Value * Right_Small) + + -- Result_Value = (Left_Value / Right_Value) * + -- (Left_Small / (Right_Small * Result_Small)); + + -- we can do the operation in integer arithmetic if this fraction is an + -- integer or the reciprocal of an integer, as detailed in (RM G.2.3(21)). + -- Otherwise the result is in the close result set and our approach is to + -- use floating-point to compute this close result. + + procedure Do_Divide_Fixed_Fixed (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + Left_Type : constant Entity_Id := Etype (Left); + Right_Type : constant Entity_Id := Etype (Right); + Result_Type : constant Entity_Id := Etype (N); + Right_Small : constant Ureal := Small_Value (Right_Type); + Left_Small : constant Ureal := Small_Value (Left_Type); + + Result_Small : Ureal; + Frac : Ureal; + Frac_Num : Uint; + Frac_Den : Uint; + Lit_Int : Node_Id; + + begin + -- Rounding is required if the result is integral + + if Is_Integer_Type (Result_Type) then + Set_Rounded_Result (N); + end if; + + -- Get result small. If the result is an integer, treat it as though + -- it had a small of 1.0, all other processing is identical. + + if Is_Integer_Type (Result_Type) then + Result_Small := Ureal_1; + else + Result_Small := Small_Value (Result_Type); + end if; + + -- Get small ratio + + Frac := Left_Small / (Right_Small * Result_Small); + Frac_Num := Norm_Num (Frac); + Frac_Den := Norm_Den (Frac); + + -- If the fraction is an integer, then we get the result by multiplying + -- the left operand by the integer, and then dividing by the right + -- operand (the order is important, if we did the divide first, we + -- would lose precision). + + if Frac_Den = 1 then + Lit_Int := Integer_Literal (N, Frac_Num); -- always positive + + if Present (Lit_Int) then + Set_Result (N, Build_Scaled_Divide (N, Left, Lit_Int, Right)); + return; + end if; + + -- If the fraction is the reciprocal of an integer, then we get the + -- result by first multiplying the divisor by the integer, and then + -- doing the division with the adjusted divisor. + + -- Note: this is much better than doing two divisions: multiplications + -- are much faster than divisions (and certainly faster than rounded + -- divisions), and we don't get inaccuracies from double rounding. + + elsif Frac_Num = 1 then + Lit_Int := Integer_Literal (N, Frac_Den); -- always positive + + if Present (Lit_Int) then + Set_Result (N, Build_Double_Divide (N, Left, Right, Lit_Int)); + return; + end if; + end if; + + -- If we fall through, we use floating-point to compute the result + + Set_Result (N, + Build_Multiply (N, + Build_Divide (N, Fpt_Value (Left), Fpt_Value (Right)), + Real_Literal (N, Frac))); + end Do_Divide_Fixed_Fixed; + + ------------------------------- + -- Do_Divide_Fixed_Universal -- + ------------------------------- + + -- We have: + + -- (Result_Value * Result_Small) = (Left_Value * Left_Small) / Lit_Value; + -- Result_Value = Left_Value * Left_Small /(Lit_Value * Result_Small); + + -- The result is required to be in the perfect result set if the literal + -- can be factored so that the resulting small ratio is an integer or the + -- reciprocal of an integer (RM G.2.3(21-22)). We now give a detailed + -- analysis of these RM requirements: + + -- We must factor the literal, finding an integer K: + + -- Lit_Value = K * Right_Small + -- Right_Small = Lit_Value / K + + -- such that the small ratio: + + -- Left_Small + -- ------------------------------ + -- (Lit_Value / K) * Result_Small + + -- Left_Small + -- = ------------------------ * K + -- Lit_Value * Result_Small + + -- is an integer or the reciprocal of an integer, and for + -- implementation efficiency we need the smallest such K. + + -- First we reduce the left fraction to lowest terms + + -- If numerator = 1, then for K = 1, the small ratio is the reciprocal + -- of an integer, and this is clearly the minimum K case, so set K = 1, + -- Right_Small = Lit_Value. + + -- If numerator > 1, then set K to the denominator of the fraction so + -- that the resulting small ratio is an integer (the numerator value). + + procedure Do_Divide_Fixed_Universal (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + Left_Type : constant Entity_Id := Etype (Left); + Result_Type : constant Entity_Id := Etype (N); + Left_Small : constant Ureal := Small_Value (Left_Type); + Lit_Value : constant Ureal := Realval (Right); + + Result_Small : Ureal; + Frac : Ureal; + Frac_Num : Uint; + Frac_Den : Uint; + Lit_K : Node_Id; + Lit_Int : Node_Id; + + begin + -- Get result small. If the result is an integer, treat it as though + -- it had a small of 1.0, all other processing is identical. + + if Is_Integer_Type (Result_Type) then + Result_Small := Ureal_1; + else + Result_Small := Small_Value (Result_Type); + end if; + + -- Determine if literal can be rewritten successfully + + Frac := Left_Small / (Lit_Value * Result_Small); + Frac_Num := Norm_Num (Frac); + Frac_Den := Norm_Den (Frac); + + -- Case where fraction is the reciprocal of an integer (K = 1, integer + -- = denominator). If this integer is not too large, this is the case + -- where the result can be obtained by dividing by this integer value. + + if Frac_Num = 1 then + Lit_Int := Integer_Literal (N, Frac_Den, UR_Is_Negative (Frac)); + + if Present (Lit_Int) then + Set_Result (N, Build_Divide (N, Left, Lit_Int)); + return; + end if; + + -- Case where we choose K to make fraction an integer (K = denominator + -- of fraction, integer = numerator of fraction). If both K and the + -- numerator are small enough, this is the case where the result can + -- be obtained by first multiplying by the integer value and then + -- dividing by K (the order is important, if we divided first, we + -- would lose precision). + + else + Lit_Int := Integer_Literal (N, Frac_Num, UR_Is_Negative (Frac)); + Lit_K := Integer_Literal (N, Frac_Den, False); + + if Present (Lit_Int) and then Present (Lit_K) then + Set_Result (N, Build_Scaled_Divide (N, Left, Lit_Int, Lit_K)); + return; + end if; + end if; + + -- Fall through if the literal cannot be successfully rewritten, or if + -- the small ratio is out of range of integer arithmetic. In the former + -- case it is fine to use floating-point to get the close result set, + -- and in the latter case, it means that the result is zero or raises + -- constraint error, and we can do that accurately in floating-point. + + -- If we end up using floating-point, then we take the right integer + -- to be one, and its small to be the value of the original right real + -- literal. That way, we need only one floating-point multiplication. + + Set_Result (N, + Build_Multiply (N, Fpt_Value (Left), Real_Literal (N, Frac))); + end Do_Divide_Fixed_Universal; + + ------------------------------- + -- Do_Divide_Universal_Fixed -- + ------------------------------- + + -- We have: + + -- (Result_Value * Result_Small) = + -- Lit_Value / (Right_Value * Right_Small) + -- Result_Value = + -- (Lit_Value / (Right_Small * Result_Small)) / Right_Value + + -- The result is required to be in the perfect result set if the literal + -- can be factored so that the resulting small ratio is an integer or the + -- reciprocal of an integer (RM G.2.3(21-22)). We now give a detailed + -- analysis of these RM requirements: + + -- We must factor the literal, finding an integer K: + + -- Lit_Value = K * Left_Small + -- Left_Small = Lit_Value / K + + -- such that the small ratio: + + -- (Lit_Value / K) + -- -------------------------- + -- Right_Small * Result_Small + + -- Lit_Value 1 + -- = -------------------------- * - + -- Right_Small * Result_Small K + + -- is an integer or the reciprocal of an integer, and for + -- implementation efficiency we need the smallest such K. + + -- First we reduce the left fraction to lowest terms + + -- If denominator = 1, then for K = 1, the small ratio is an integer + -- (the numerator) and this is clearly the minimum K case, so set K = 1, + -- and Left_Small = Lit_Value. + + -- If denominator > 1, then set K to the numerator of the fraction so + -- that the resulting small ratio is the reciprocal of an integer (the + -- numerator value). + + procedure Do_Divide_Universal_Fixed (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + Right_Type : constant Entity_Id := Etype (Right); + Result_Type : constant Entity_Id := Etype (N); + Right_Small : constant Ureal := Small_Value (Right_Type); + Lit_Value : constant Ureal := Realval (Left); + + Result_Small : Ureal; + Frac : Ureal; + Frac_Num : Uint; + Frac_Den : Uint; + Lit_K : Node_Id; + Lit_Int : Node_Id; + + begin + -- Get result small. If the result is an integer, treat it as though + -- it had a small of 1.0, all other processing is identical. + + if Is_Integer_Type (Result_Type) then + Result_Small := Ureal_1; + else + Result_Small := Small_Value (Result_Type); + end if; + + -- Determine if literal can be rewritten successfully + + Frac := Lit_Value / (Right_Small * Result_Small); + Frac_Num := Norm_Num (Frac); + Frac_Den := Norm_Den (Frac); + + -- Case where fraction is an integer (K = 1, integer = numerator). If + -- this integer is not too large, this is the case where the result + -- can be obtained by dividing this integer by the right operand. + + if Frac_Den = 1 then + Lit_Int := Integer_Literal (N, Frac_Num, UR_Is_Negative (Frac)); + + if Present (Lit_Int) then + Set_Result (N, Build_Divide (N, Lit_Int, Right)); + return; + end if; + + -- Case where we choose K to make the fraction the reciprocal of an + -- integer (K = numerator of fraction, integer = numerator of fraction). + -- If both K and the integer are small enough, this is the case where + -- the result can be obtained by multiplying the right operand by K + -- and then dividing by the integer value. The order of the operations + -- is important (if we divided first, we would lose precision). + + else + Lit_Int := Integer_Literal (N, Frac_Den, UR_Is_Negative (Frac)); + Lit_K := Integer_Literal (N, Frac_Num, False); + + if Present (Lit_Int) and then Present (Lit_K) then + Set_Result (N, Build_Double_Divide (N, Lit_K, Right, Lit_Int)); + return; + end if; + end if; + + -- Fall through if the literal cannot be successfully rewritten, or if + -- the small ratio is out of range of integer arithmetic. In the former + -- case it is fine to use floating-point to get the close result set, + -- and in the latter case, it means that the result is zero or raises + -- constraint error, and we can do that accurately in floating-point. + + -- If we end up using floating-point, then we take the right integer + -- to be one, and its small to be the value of the original right real + -- literal. That way, we need only one floating-point division. + + Set_Result (N, + Build_Divide (N, Real_Literal (N, Frac), Fpt_Value (Right))); + end Do_Divide_Universal_Fixed; + + ----------------------------- + -- Do_Multiply_Fixed_Fixed -- + ----------------------------- + + -- We have: + + -- (Result_Value * Result_Small) = + -- (Left_Value * Left_Small) * (Right_Value * Right_Small) + + -- Result_Value = (Left_Value * Right_Value) * + -- (Left_Small * Right_Small) / Result_Small; + + -- we can do the operation in integer arithmetic if this fraction is an + -- integer or the reciprocal of an integer, as detailed in (RM G.2.3(21)). + -- Otherwise the result is in the close result set and our approach is to + -- use floating-point to compute this close result. + + procedure Do_Multiply_Fixed_Fixed (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + + Left_Type : constant Entity_Id := Etype (Left); + Right_Type : constant Entity_Id := Etype (Right); + Result_Type : constant Entity_Id := Etype (N); + Right_Small : constant Ureal := Small_Value (Right_Type); + Left_Small : constant Ureal := Small_Value (Left_Type); + + Result_Small : Ureal; + Frac : Ureal; + Frac_Num : Uint; + Frac_Den : Uint; + Lit_Int : Node_Id; + + begin + -- Get result small. If the result is an integer, treat it as though + -- it had a small of 1.0, all other processing is identical. + + if Is_Integer_Type (Result_Type) then + Result_Small := Ureal_1; + else + Result_Small := Small_Value (Result_Type); + end if; + + -- Get small ratio + + Frac := (Left_Small * Right_Small) / Result_Small; + Frac_Num := Norm_Num (Frac); + Frac_Den := Norm_Den (Frac); + + -- If the fraction is an integer, then we get the result by multiplying + -- the operands, and then multiplying the result by the integer value. + + if Frac_Den = 1 then + Lit_Int := Integer_Literal (N, Frac_Num); -- always positive + + if Present (Lit_Int) then + Set_Result (N, + Build_Multiply (N, Build_Multiply (N, Left, Right), + Lit_Int)); + return; + end if; + + -- If the fraction is the reciprocal of an integer, then we get the + -- result by multiplying the operands, and then dividing the result by + -- the integer value. The order of the operations is important, if we + -- divided first, we would lose precision. + + elsif Frac_Num = 1 then + Lit_Int := Integer_Literal (N, Frac_Den); -- always positive + + if Present (Lit_Int) then + Set_Result (N, Build_Scaled_Divide (N, Left, Right, Lit_Int)); + return; + end if; + end if; + + -- If we fall through, we use floating-point to compute the result + + Set_Result (N, + Build_Multiply (N, + Build_Multiply (N, Fpt_Value (Left), Fpt_Value (Right)), + Real_Literal (N, Frac))); + end Do_Multiply_Fixed_Fixed; + + --------------------------------- + -- Do_Multiply_Fixed_Universal -- + --------------------------------- + + -- We have: + + -- (Result_Value * Result_Small) = (Left_Value * Left_Small) * Lit_Value; + -- Result_Value = Left_Value * (Left_Small * Lit_Value) / Result_Small; + + -- The result is required to be in the perfect result set if the literal + -- can be factored so that the resulting small ratio is an integer or the + -- reciprocal of an integer (RM G.2.3(21-22)). We now give a detailed + -- analysis of these RM requirements: + + -- We must factor the literal, finding an integer K: + + -- Lit_Value = K * Right_Small + -- Right_Small = Lit_Value / K + + -- such that the small ratio: + + -- Left_Small * (Lit_Value / K) + -- ---------------------------- + -- Result_Small + + -- Left_Small * Lit_Value 1 + -- = ---------------------- * - + -- Result_Small K + + -- is an integer or the reciprocal of an integer, and for + -- implementation efficiency we need the smallest such K. + + -- First we reduce the left fraction to lowest terms + + -- If denominator = 1, then for K = 1, the small ratio is an integer, and + -- this is clearly the minimum K case, so set + + -- K = 1, Right_Small = Lit_Value + + -- If denominator > 1, then set K to the numerator of the fraction, so + -- that the resulting small ratio is the reciprocal of the integer (the + -- denominator value). + + procedure Do_Multiply_Fixed_Universal + (N : Node_Id; + Left, Right : Node_Id) + is + Left_Type : constant Entity_Id := Etype (Left); + Result_Type : constant Entity_Id := Etype (N); + Left_Small : constant Ureal := Small_Value (Left_Type); + Lit_Value : constant Ureal := Realval (Right); + + Result_Small : Ureal; + Frac : Ureal; + Frac_Num : Uint; + Frac_Den : Uint; + Lit_K : Node_Id; + Lit_Int : Node_Id; + + begin + -- Get result small. If the result is an integer, treat it as though + -- it had a small of 1.0, all other processing is identical. + + if Is_Integer_Type (Result_Type) then + Result_Small := Ureal_1; + else + Result_Small := Small_Value (Result_Type); + end if; + + -- Determine if literal can be rewritten successfully + + Frac := (Left_Small * Lit_Value) / Result_Small; + Frac_Num := Norm_Num (Frac); + Frac_Den := Norm_Den (Frac); + + -- Case where fraction is an integer (K = 1, integer = numerator). If + -- this integer is not too large, this is the case where the result can + -- be obtained by multiplying by this integer value. + + if Frac_Den = 1 then + Lit_Int := Integer_Literal (N, Frac_Num, UR_Is_Negative (Frac)); + + if Present (Lit_Int) then + Set_Result (N, Build_Multiply (N, Left, Lit_Int)); + return; + end if; + + -- Case where we choose K to make fraction the reciprocal of an integer + -- (K = numerator of fraction, integer = denominator of fraction). If + -- both K and the denominator are small enough, this is the case where + -- the result can be obtained by first multiplying by K, and then + -- dividing by the integer value. + + else + Lit_Int := Integer_Literal (N, Frac_Den, UR_Is_Negative (Frac)); + Lit_K := Integer_Literal (N, Frac_Num); + + if Present (Lit_Int) and then Present (Lit_K) then + Set_Result (N, Build_Scaled_Divide (N, Left, Lit_K, Lit_Int)); + return; + end if; + end if; + + -- Fall through if the literal cannot be successfully rewritten, or if + -- the small ratio is out of range of integer arithmetic. In the former + -- case it is fine to use floating-point to get the close result set, + -- and in the latter case, it means that the result is zero or raises + -- constraint error, and we can do that accurately in floating-point. + + -- If we end up using floating-point, then we take the right integer + -- to be one, and its small to be the value of the original right real + -- literal. That way, we need only one floating-point multiplication. + + Set_Result (N, + Build_Multiply (N, Fpt_Value (Left), Real_Literal (N, Frac))); + end Do_Multiply_Fixed_Universal; + + --------------------------------- + -- Expand_Convert_Fixed_Static -- + --------------------------------- + + procedure Expand_Convert_Fixed_Static (N : Node_Id) is + begin + Rewrite (N, + Convert_To (Etype (N), + Make_Real_Literal (Sloc (N), Expr_Value_R (Expression (N))))); + Analyze_And_Resolve (N); + end Expand_Convert_Fixed_Static; + + ----------------------------------- + -- Expand_Convert_Fixed_To_Fixed -- + ----------------------------------- + + -- We have: + + -- Result_Value * Result_Small = Source_Value * Source_Small + -- Result_Value = Source_Value * (Source_Small / Result_Small) + + -- If the small ratio (Source_Small / Result_Small) is a sufficiently small + -- integer, then the perfect result set is obtained by a single integer + -- multiplication. + + -- If the small ratio is the reciprocal of a sufficiently small integer, + -- then the perfect result set is obtained by a single integer division. + + -- In other cases, we obtain the close result set by calculating the + -- result in floating-point. + + procedure Expand_Convert_Fixed_To_Fixed (N : Node_Id) is + Rng_Check : constant Boolean := Do_Range_Check (N); + Expr : constant Node_Id := Expression (N); + Result_Type : constant Entity_Id := Etype (N); + Source_Type : constant Entity_Id := Etype (Expr); + Small_Ratio : Ureal; + Ratio_Num : Uint; + Ratio_Den : Uint; + Lit : Node_Id; + + begin + if Is_OK_Static_Expression (Expr) then + Expand_Convert_Fixed_Static (N); + return; + end if; + + Small_Ratio := Small_Value (Source_Type) / Small_Value (Result_Type); + Ratio_Num := Norm_Num (Small_Ratio); + Ratio_Den := Norm_Den (Small_Ratio); + + if Ratio_Den = 1 then + if Ratio_Num = 1 then + Set_Result (N, Expr); + return; + + else + Lit := Integer_Literal (N, Ratio_Num); + + if Present (Lit) then + Set_Result (N, Build_Multiply (N, Expr, Lit)); + return; + end if; + end if; + + elsif Ratio_Num = 1 then + Lit := Integer_Literal (N, Ratio_Den); + + if Present (Lit) then + Set_Result (N, Build_Divide (N, Expr, Lit), Rng_Check); + return; + end if; + end if; + + -- Fall through to use floating-point for the close result set case + -- either as a result of the small ratio not being an integer or the + -- reciprocal of an integer, or if the integer is out of range. + + Set_Result (N, + Build_Multiply (N, + Fpt_Value (Expr), + Real_Literal (N, Small_Ratio)), + Rng_Check); + end Expand_Convert_Fixed_To_Fixed; + + ----------------------------------- + -- Expand_Convert_Fixed_To_Float -- + ----------------------------------- + + -- If the small of the fixed type is 1.0, then we simply convert the + -- integer value directly to the target floating-point type, otherwise + -- we first have to multiply by the small, in Universal_Real, and then + -- convert the result to the target floating-point type. + + procedure Expand_Convert_Fixed_To_Float (N : Node_Id) is + Rng_Check : constant Boolean := Do_Range_Check (N); + Expr : constant Node_Id := Expression (N); + Source_Type : constant Entity_Id := Etype (Expr); + Small : constant Ureal := Small_Value (Source_Type); + + begin + if Is_OK_Static_Expression (Expr) then + Expand_Convert_Fixed_Static (N); + return; + end if; + + if Small = Ureal_1 then + Set_Result (N, Expr); + + else + Set_Result (N, + Build_Multiply (N, + Fpt_Value (Expr), + Real_Literal (N, Small)), + Rng_Check); + end if; + end Expand_Convert_Fixed_To_Float; + + ------------------------------------- + -- Expand_Convert_Fixed_To_Integer -- + ------------------------------------- + + -- We have: + + -- Result_Value = Source_Value * Source_Small + + -- If the small value is a sufficiently small integer, then the perfect + -- result set is obtained by a single integer multiplication. + + -- If the small value is the reciprocal of a sufficiently small integer, + -- then the perfect result set is obtained by a single integer division. + + -- In other cases, we obtain the close result set by calculating the + -- result in floating-point. + + procedure Expand_Convert_Fixed_To_Integer (N : Node_Id) is + Rng_Check : constant Boolean := Do_Range_Check (N); + Expr : constant Node_Id := Expression (N); + Source_Type : constant Entity_Id := Etype (Expr); + Small : constant Ureal := Small_Value (Source_Type); + Small_Num : constant Uint := Norm_Num (Small); + Small_Den : constant Uint := Norm_Den (Small); + Lit : Node_Id; + + begin + if Is_OK_Static_Expression (Expr) then + Expand_Convert_Fixed_Static (N); + return; + end if; + + if Small_Den = 1 then + Lit := Integer_Literal (N, Small_Num); + + if Present (Lit) then + Set_Result (N, Build_Multiply (N, Expr, Lit), Rng_Check); + return; + end if; + + elsif Small_Num = 1 then + Lit := Integer_Literal (N, Small_Den); + + if Present (Lit) then + Set_Result (N, Build_Divide (N, Expr, Lit), Rng_Check); + return; + end if; + end if; + + -- Fall through to use floating-point for the close result set case + -- either as a result of the small value not being an integer or the + -- reciprocal of an integer, or if the integer is out of range. + + Set_Result (N, + Build_Multiply (N, + Fpt_Value (Expr), + Real_Literal (N, Small)), + Rng_Check); + end Expand_Convert_Fixed_To_Integer; + + ----------------------------------- + -- Expand_Convert_Float_To_Fixed -- + ----------------------------------- + + -- We have + + -- Result_Value * Result_Small = Operand_Value + + -- so compute: + + -- Result_Value = Operand_Value * (1.0 / Result_Small) + + -- We do the small scaling in floating-point, and we do a multiplication + -- rather than a division, since it is accurate enough for the perfect + -- result cases, and faster. + + procedure Expand_Convert_Float_To_Fixed (N : Node_Id) is + Rng_Check : constant Boolean := Do_Range_Check (N); + Expr : constant Node_Id := Expression (N); + Result_Type : constant Entity_Id := Etype (N); + Small : constant Ureal := Small_Value (Result_Type); + + begin + -- Optimize small = 1, where we can avoid the multiply completely + + if Small = Ureal_1 then + Set_Result (N, Expr, Rng_Check, Trunc => True); + + -- Normal case where multiply is required + -- Rounding is truncating for decimal fixed point types only, + -- see RM 4.6(29). + + else + Set_Result (N, + Build_Multiply (N, + Fpt_Value (Expr), + Real_Literal (N, Ureal_1 / Small)), + Rng_Check, Trunc => Is_Decimal_Fixed_Point_Type (Result_Type)); + end if; + end Expand_Convert_Float_To_Fixed; + + ------------------------------------- + -- Expand_Convert_Integer_To_Fixed -- + ------------------------------------- + + -- We have + + -- Result_Value * Result_Small = Operand_Value + -- Result_Value = Operand_Value / Result_Small + + -- If the small value is a sufficiently small integer, then the perfect + -- result set is obtained by a single integer division. + + -- If the small value is the reciprocal of a sufficiently small integer, + -- the perfect result set is obtained by a single integer multiplication. + + -- In other cases, we obtain the close result set by calculating the + -- result in floating-point using a multiplication by the reciprocal + -- of the Result_Small. + + procedure Expand_Convert_Integer_To_Fixed (N : Node_Id) is + Rng_Check : constant Boolean := Do_Range_Check (N); + Expr : constant Node_Id := Expression (N); + Result_Type : constant Entity_Id := Etype (N); + Small : constant Ureal := Small_Value (Result_Type); + Small_Num : constant Uint := Norm_Num (Small); + Small_Den : constant Uint := Norm_Den (Small); + Lit : Node_Id; + + begin + if Small_Den = 1 then + Lit := Integer_Literal (N, Small_Num); + + if Present (Lit) then + Set_Result (N, Build_Divide (N, Expr, Lit), Rng_Check); + return; + end if; + + elsif Small_Num = 1 then + Lit := Integer_Literal (N, Small_Den); + + if Present (Lit) then + Set_Result (N, Build_Multiply (N, Expr, Lit), Rng_Check); + return; + end if; + end if; + + -- Fall through to use floating-point for the close result set case + -- either as a result of the small value not being an integer or the + -- reciprocal of an integer, or if the integer is out of range. + + Set_Result (N, + Build_Multiply (N, + Fpt_Value (Expr), + Real_Literal (N, Ureal_1 / Small)), + Rng_Check); + end Expand_Convert_Integer_To_Fixed; + + -------------------------------- + -- Expand_Decimal_Divide_Call -- + -------------------------------- + + -- We have four operands + + -- Dividend + -- Divisor + -- Quotient + -- Remainder + + -- All of which are decimal types, and which thus have associated + -- decimal scales. + + -- Computing the quotient is a similar problem to that faced by the + -- normal fixed-point division, except that it is simpler, because + -- we always have compatible smalls. + + -- Quotient = (Dividend / Divisor) * 10**q + + -- where 10 ** q = Dividend'Small / (Divisor'Small * Quotient'Small) + -- so q = Divisor'Scale + Quotient'Scale - Dividend'Scale + + -- For q >= 0, we compute + + -- Numerator := Dividend * 10 ** q + -- Denominator := Divisor + -- Quotient := Numerator / Denominator + + -- For q < 0, we compute + + -- Numerator := Dividend + -- Denominator := Divisor * 10 ** q + -- Quotient := Numerator / Denominator + + -- Both these divisions are done in truncated mode, and the remainder + -- from these divisions is used to compute the result Remainder. This + -- remainder has the effective scale of the numerator of the division, + + -- For q >= 0, the remainder scale is Dividend'Scale + q + -- For q < 0, the remainder scale is Dividend'Scale + + -- The result Remainder is then computed by a normal truncating decimal + -- conversion from this scale to the scale of the remainder, i.e. by a + -- division or multiplication by the appropriate power of 10. + + procedure Expand_Decimal_Divide_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Dividend : Node_Id := First_Actual (N); + Divisor : Node_Id := Next_Actual (Dividend); + Quotient : Node_Id := Next_Actual (Divisor); + Remainder : Node_Id := Next_Actual (Quotient); + + Dividend_Type : constant Entity_Id := Etype (Dividend); + Divisor_Type : constant Entity_Id := Etype (Divisor); + Quotient_Type : constant Entity_Id := Etype (Quotient); + Remainder_Type : constant Entity_Id := Etype (Remainder); + + Dividend_Scale : constant Uint := Scale_Value (Dividend_Type); + Divisor_Scale : constant Uint := Scale_Value (Divisor_Type); + Quotient_Scale : constant Uint := Scale_Value (Quotient_Type); + Remainder_Scale : constant Uint := Scale_Value (Remainder_Type); + + Q : Uint; + Numerator_Scale : Uint; + Stmts : List_Id; + Qnn : Entity_Id; + Rnn : Entity_Id; + Computed_Remainder : Node_Id; + Adjusted_Remainder : Node_Id; + Scale_Adjust : Uint; + + begin + -- Relocate the operands, since they are now list elements, and we + -- need to reference them separately as operands in the expanded code. + + Dividend := Relocate_Node (Dividend); + Divisor := Relocate_Node (Divisor); + Quotient := Relocate_Node (Quotient); + Remainder := Relocate_Node (Remainder); + + -- Now compute Q, the adjustment scale + + Q := Divisor_Scale + Quotient_Scale - Dividend_Scale; + + -- If Q is non-negative then we need a scaled divide + + if Q >= 0 then + Build_Scaled_Divide_Code + (N, + Dividend, + Integer_Literal (N, Uint_10 ** Q), + Divisor, + Qnn, Rnn, Stmts); + + Numerator_Scale := Dividend_Scale + Q; + + -- If Q is negative, then we need a double divide + + else + Build_Double_Divide_Code + (N, + Dividend, + Divisor, + Integer_Literal (N, Uint_10 ** (-Q)), + Qnn, Rnn, Stmts); + + Numerator_Scale := Dividend_Scale; + end if; + + -- Add statement to set quotient value + + -- Quotient := quotient-type!(Qnn); + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Quotient, + Expression => + Unchecked_Convert_To (Quotient_Type, + Build_Conversion (N, Quotient_Type, + New_Occurrence_Of (Qnn, Loc))))); + + -- Now we need to deal with computing and setting the remainder. The + -- scale of the remainder is in Numerator_Scale, and the desired + -- scale is the scale of the given Remainder argument. There are + -- three cases: + + -- Numerator_Scale > Remainder_Scale + + -- in this case, there are extra digits in the computed remainder + -- which must be eliminated by an extra division: + + -- computed-remainder := Numerator rem Denominator + -- scale_adjust = Numerator_Scale - Remainder_Scale + -- adjusted-remainder := computed-remainder / 10 ** scale_adjust + + -- Numerator_Scale = Remainder_Scale + + -- in this case, the we have the remainder we need + + -- computed-remainder := Numerator rem Denominator + -- adjusted-remainder := computed-remainder + + -- Numerator_Scale < Remainder_Scale + + -- in this case, we have insufficient digits in the computed + -- remainder, which must be eliminated by an extra multiply + + -- computed-remainder := Numerator rem Denominator + -- scale_adjust = Remainder_Scale - Numerator_Scale + -- adjusted-remainder := computed-remainder * 10 ** scale_adjust + + -- Finally we assign the adjusted-remainder to the result Remainder + -- with conversions to get the proper fixed-point type representation. + + Computed_Remainder := New_Occurrence_Of (Rnn, Loc); + + if Numerator_Scale > Remainder_Scale then + Scale_Adjust := Numerator_Scale - Remainder_Scale; + Adjusted_Remainder := + Build_Divide + (N, Computed_Remainder, Integer_Literal (N, 10 ** Scale_Adjust)); + + elsif Numerator_Scale = Remainder_Scale then + Adjusted_Remainder := Computed_Remainder; + + else -- Numerator_Scale < Remainder_Scale + Scale_Adjust := Remainder_Scale - Numerator_Scale; + Adjusted_Remainder := + Build_Multiply + (N, Computed_Remainder, Integer_Literal (N, 10 ** Scale_Adjust)); + end if; + + -- Assignment of remainder result + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Remainder, + Expression => + Unchecked_Convert_To (Remainder_Type, Adjusted_Remainder))); + + -- Final step is to rewrite the call with a block containing the + -- above sequence of constructed statements for the divide operation. + + Rewrite (N, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts))); + + Analyze (N); + end Expand_Decimal_Divide_Call; + + ----------------------------------------------- + -- Expand_Divide_Fixed_By_Fixed_Giving_Fixed -- + ----------------------------------------------- + + procedure Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + + begin + -- Suppress expansion of a fixed-by-fixed division if the + -- operation is supported directly by the target. + + if Target_Has_Fixed_Ops (Etype (Left), Etype (Right), Etype (N)) then + return; + end if; + + if Etype (Left) = Universal_Real then + Do_Divide_Universal_Fixed (N); + + elsif Etype (Right) = Universal_Real then + Do_Divide_Fixed_Universal (N); + + else + Do_Divide_Fixed_Fixed (N); + end if; + end Expand_Divide_Fixed_By_Fixed_Giving_Fixed; + + ----------------------------------------------- + -- Expand_Divide_Fixed_By_Fixed_Giving_Float -- + ----------------------------------------------- + + -- The division is done in Universal_Real, and the result is multiplied + -- by the small ratio, which is Small (Right) / Small (Left). Special + -- treatment is required for universal operands, which represent their + -- own value and do not require conversion. + + procedure Expand_Divide_Fixed_By_Fixed_Giving_Float (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + + Left_Type : constant Entity_Id := Etype (Left); + Right_Type : constant Entity_Id := Etype (Right); + + begin + -- Case of left operand is universal real, the result we want is: + + -- Left_Value / (Right_Value * Right_Small) + + -- so we compute this as: + + -- (Left_Value / Right_Small) / Right_Value + + if Left_Type = Universal_Real then + Set_Result (N, + Build_Divide (N, + Real_Literal (N, Realval (Left) / Small_Value (Right_Type)), + Fpt_Value (Right))); + + -- Case of right operand is universal real, the result we want is + + -- (Left_Value * Left_Small) / Right_Value + + -- so we compute this as: + + -- Left_Value * (Left_Small / Right_Value) + + -- Note we invert to a multiplication since usually floating-point + -- multiplication is much faster than floating-point division. + + elsif Right_Type = Universal_Real then + Set_Result (N, + Build_Multiply (N, + Fpt_Value (Left), + Real_Literal (N, Small_Value (Left_Type) / Realval (Right)))); + + -- Both operands are fixed, so the value we want is + + -- (Left_Value * Left_Small) / (Right_Value * Right_Small) + + -- which we compute as: + + -- (Left_Value / Right_Value) * (Left_Small / Right_Small) + + else + Set_Result (N, + Build_Multiply (N, + Build_Divide (N, Fpt_Value (Left), Fpt_Value (Right)), + Real_Literal (N, + Small_Value (Left_Type) / Small_Value (Right_Type)))); + end if; + end Expand_Divide_Fixed_By_Fixed_Giving_Float; + + ------------------------------------------------- + -- Expand_Divide_Fixed_By_Fixed_Giving_Integer -- + ------------------------------------------------- + + procedure Expand_Divide_Fixed_By_Fixed_Giving_Integer (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + begin + if Etype (Left) = Universal_Real then + Do_Divide_Universal_Fixed (N); + elsif Etype (Right) = Universal_Real then + Do_Divide_Fixed_Universal (N); + else + Do_Divide_Fixed_Fixed (N); + end if; + end Expand_Divide_Fixed_By_Fixed_Giving_Integer; + + ------------------------------------------------- + -- Expand_Divide_Fixed_By_Integer_Giving_Fixed -- + ------------------------------------------------- + + -- Since the operand and result fixed-point type is the same, this is + -- a straight divide by the right operand, the small can be ignored. + + procedure Expand_Divide_Fixed_By_Integer_Giving_Fixed (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + begin + Set_Result (N, Build_Divide (N, Left, Right)); + end Expand_Divide_Fixed_By_Integer_Giving_Fixed; + + ------------------------------------------------- + -- Expand_Multiply_Fixed_By_Fixed_Giving_Fixed -- + ------------------------------------------------- + + procedure Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + + procedure Rewrite_Non_Static_Universal (Opnd : Node_Id); + -- The operand may be a non-static universal value, such an + -- exponentiation with a non-static exponent. In that case, treat + -- as a fixed * fixed multiplication, and convert the argument to + -- the target fixed type. + + ---------------------------------- + -- Rewrite_Non_Static_Universal -- + ---------------------------------- + + procedure Rewrite_Non_Static_Universal (Opnd : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + begin + Rewrite (Opnd, + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Etype (N), Loc), + Expression => Expression (Opnd))); + Analyze_And_Resolve (Opnd, Etype (N)); + end Rewrite_Non_Static_Universal; + + -- Start of processing for Expand_Multiply_Fixed_By_Fixed_Giving_Fixed + + begin + -- Suppress expansion of a fixed-by-fixed multiplication if the + -- operation is supported directly by the target. + + if Target_Has_Fixed_Ops (Etype (Left), Etype (Right), Etype (N)) then + return; + end if; + + if Etype (Left) = Universal_Real then + if Nkind (Left) = N_Real_Literal then + Do_Multiply_Fixed_Universal (N, Left => Right, Right => Left); + + elsif Nkind (Left) = N_Type_Conversion then + Rewrite_Non_Static_Universal (Left); + Do_Multiply_Fixed_Fixed (N); + end if; + + elsif Etype (Right) = Universal_Real then + if Nkind (Right) = N_Real_Literal then + Do_Multiply_Fixed_Universal (N, Left, Right); + + elsif Nkind (Right) = N_Type_Conversion then + Rewrite_Non_Static_Universal (Right); + Do_Multiply_Fixed_Fixed (N); + end if; + + else + Do_Multiply_Fixed_Fixed (N); + end if; + end Expand_Multiply_Fixed_By_Fixed_Giving_Fixed; + + ------------------------------------------------- + -- Expand_Multiply_Fixed_By_Fixed_Giving_Float -- + ------------------------------------------------- + + -- The multiply is done in Universal_Real, and the result is multiplied + -- by the adjustment for the smalls which is Small (Right) * Small (Left). + -- Special treatment is required for universal operands. + + procedure Expand_Multiply_Fixed_By_Fixed_Giving_Float (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + + Left_Type : constant Entity_Id := Etype (Left); + Right_Type : constant Entity_Id := Etype (Right); + + begin + -- Case of left operand is universal real, the result we want is + + -- Left_Value * (Right_Value * Right_Small) + + -- so we compute this as: + + -- (Left_Value * Right_Small) * Right_Value; + + if Left_Type = Universal_Real then + Set_Result (N, + Build_Multiply (N, + Real_Literal (N, Realval (Left) * Small_Value (Right_Type)), + Fpt_Value (Right))); + + -- Case of right operand is universal real, the result we want is + + -- (Left_Value * Left_Small) * Right_Value + + -- so we compute this as: + + -- Left_Value * (Left_Small * Right_Value) + + elsif Right_Type = Universal_Real then + Set_Result (N, + Build_Multiply (N, + Fpt_Value (Left), + Real_Literal (N, Small_Value (Left_Type) * Realval (Right)))); + + -- Both operands are fixed, so the value we want is + + -- (Left_Value * Left_Small) * (Right_Value * Right_Small) + + -- which we compute as: + + -- (Left_Value * Right_Value) * (Right_Small * Left_Small) + + else + Set_Result (N, + Build_Multiply (N, + Build_Multiply (N, Fpt_Value (Left), Fpt_Value (Right)), + Real_Literal (N, + Small_Value (Right_Type) * Small_Value (Left_Type)))); + end if; + end Expand_Multiply_Fixed_By_Fixed_Giving_Float; + + --------------------------------------------------- + -- Expand_Multiply_Fixed_By_Fixed_Giving_Integer -- + --------------------------------------------------- + + procedure Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + begin + if Etype (Left) = Universal_Real then + Do_Multiply_Fixed_Universal (N, Left => Right, Right => Left); + elsif Etype (Right) = Universal_Real then + Do_Multiply_Fixed_Universal (N, Left, Right); + else + Do_Multiply_Fixed_Fixed (N); + end if; + end Expand_Multiply_Fixed_By_Fixed_Giving_Integer; + + --------------------------------------------------- + -- Expand_Multiply_Fixed_By_Integer_Giving_Fixed -- + --------------------------------------------------- + + -- Since the operand and result fixed-point type is the same, this is + -- a straight multiply by the right operand, the small can be ignored. + + procedure Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N : Node_Id) is + begin + Set_Result (N, + Build_Multiply (N, Left_Opnd (N), Right_Opnd (N))); + end Expand_Multiply_Fixed_By_Integer_Giving_Fixed; + + --------------------------------------------------- + -- Expand_Multiply_Integer_By_Fixed_Giving_Fixed -- + --------------------------------------------------- + + -- Since the operand and result fixed-point type is the same, this is + -- a straight multiply by the right operand, the small can be ignored. + + procedure Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N : Node_Id) is + begin + Set_Result (N, + Build_Multiply (N, Left_Opnd (N), Right_Opnd (N))); + end Expand_Multiply_Integer_By_Fixed_Giving_Fixed; + + --------------- + -- Fpt_Value -- + --------------- + + function Fpt_Value (N : Node_Id) return Node_Id is + Typ : constant Entity_Id := Etype (N); + + begin + if Is_Integer_Type (Typ) + or else Is_Floating_Point_Type (Typ) + then + return Build_Conversion (N, Universal_Real, N); + + -- Fixed-point case, must get integer value first + + else + return Build_Conversion (N, Universal_Real, N); + end if; + end Fpt_Value; + + --------------------- + -- Integer_Literal -- + --------------------- + + function Integer_Literal + (N : Node_Id; + V : Uint; + Negative : Boolean := False) return Node_Id + is + T : Entity_Id; + L : Node_Id; + + begin + if V < Uint_2 ** 7 then + T := Standard_Integer_8; + + elsif V < Uint_2 ** 15 then + T := Standard_Integer_16; + + elsif V < Uint_2 ** 31 then + T := Standard_Integer_32; + + elsif V < Uint_2 ** 63 then + T := Standard_Integer_64; + + else + return Empty; + end if; + + if Negative then + L := Make_Integer_Literal (Sloc (N), UI_Negate (V)); + else + L := Make_Integer_Literal (Sloc (N), V); + end if; + + -- Set type of result in case used elsewhere (see note at start) + + Set_Etype (L, T); + Set_Is_Static_Expression (L); + + -- We really need to set Analyzed here because we may be creating a + -- very strange beast, namely an integer literal typed as fixed-point + -- and the analyzer won't like that. Probably we should allow the + -- Treat_Fixed_As_Integer flag to appear on integer literal nodes + -- and teach the analyzer how to handle them ??? + + Set_Analyzed (L); + return L; + end Integer_Literal; + + ------------------ + -- Real_Literal -- + ------------------ + + function Real_Literal (N : Node_Id; V : Ureal) return Node_Id is + L : Node_Id; + + begin + L := Make_Real_Literal (Sloc (N), V); + + -- Set type of result in case used elsewhere (see note at start) + + Set_Etype (L, Universal_Real); + return L; + end Real_Literal; + + ------------------------ + -- Rounded_Result_Set -- + ------------------------ + + function Rounded_Result_Set (N : Node_Id) return Boolean is + K : constant Node_Kind := Nkind (N); + begin + if (K = N_Type_Conversion or else + K = N_Op_Divide or else + K = N_Op_Multiply) + and then + (Rounded_Result (N) or else Is_Integer_Type (Etype (N))) + then + return True; + else + return False; + end if; + end Rounded_Result_Set; + + ---------------- + -- Set_Result -- + ---------------- + + procedure Set_Result + (N : Node_Id; + Expr : Node_Id; + Rchk : Boolean := False; + Trunc : Boolean := False) + is + Cnode : Node_Id; + + Expr_Type : constant Entity_Id := Etype (Expr); + Result_Type : constant Entity_Id := Etype (N); + + begin + -- No conversion required if types match and no range check or truncate + + if Result_Type = Expr_Type and then not (Rchk or Trunc) then + Cnode := Expr; + + -- Else perform required conversion + + else + Cnode := Build_Conversion (N, Result_Type, Expr, Rchk, Trunc); + end if; + + Rewrite (N, Cnode); + Analyze_And_Resolve (N, Result_Type); + end Set_Result; + +end Exp_Fixd; diff --git a/gcc/ada/exp_fixd.ads b/gcc/ada/exp_fixd.ads new file mode 100644 index 000000000..c1dc847a2 --- /dev/null +++ b/gcc/ada/exp_fixd.ads @@ -0,0 +1,140 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ F I X D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for fixed-point convert, divide and multiply operations + +with Types; use Types; + +package Exp_Fixd is + + -- General note on universal fixed. In the routines below, a fixed-point + -- type is always a specific fixed-point type or universal real, never + -- universal fixed. Universal fixed only appears as the result type of a + -- division or multiplication and in all such cases, the parent node, which + -- must be either a conversion node or a 'Round attribute reference node, + -- has the specific type information. In both cases, the parent node is + -- removed from the tree, and the appropriate routine in this package is + -- called with a multiply or divide node with all types (and also possibly + -- the Rounded_Result flag) set. + + ---------------------------- + -- Fixed-Point Conversion -- + ---------------------------- + + procedure Expand_Convert_Fixed_To_Fixed (N : Node_Id); + -- This routine expands the conversion of one fixed-point type to another, + -- N is the N_Op_Conversion node with the result and expression types (and + -- possibly the Rounded_Result flag) set. + + procedure Expand_Convert_Fixed_To_Float (N : Node_Id); + -- This routine expands the conversion from a fixed-point type to a + -- floating-point type. N is an N_Type_Conversion node with the result + -- and expression types set. + + procedure Expand_Convert_Fixed_To_Integer (N : Node_Id); + -- This routine expands the conversion from a fixed-point type to an + -- integer type. N is an N_Type_Conversion node with the result and + -- operand types set. + + procedure Expand_Convert_Float_To_Fixed (N : Node_Id); + -- This routine expands the conversion from a floating-point type to + -- a fixed-point type. N is an N_Type_Conversion node with the result + -- and operand types (and possibly the Rounded_Result flag) set. + + procedure Expand_Convert_Integer_To_Fixed (N : Node_Id); + -- This routine expands the conversion from an integer type to a + -- fixed-point type. N is an N_Type_Conversion node with the result + -- and operand types (and possibly the Rounded_Result flag) set. + + -------------------------- + -- Fixed-Point Division -- + -------------------------- + + procedure Expand_Decimal_Divide_Call (N : Node_Id); + -- This routine expands a call to the procedure Decimal.Divide. The + -- argument N is the N_Function_Call node. + + procedure Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N : Node_Id); + -- This routine expands the division between fixed-point types, with + -- a fixed-point type result. N is an N_Op_Divide node with operand + -- and result types (and possibly the Rounded_Result flag) set. Either + -- (but not both) of the operands may be universal real. + + procedure Expand_Divide_Fixed_By_Fixed_Giving_Float (N : Node_Id); + -- This routine expands the division between two fixed-point types with + -- a floating-point result. N is an N_Op_Divide node with the result + -- and operand types set. Either (but not both) of the operands may be + -- universal real. + + procedure Expand_Divide_Fixed_By_Fixed_Giving_Integer (N : Node_Id); + -- This routine expands the division between two fixed-point types with + -- an integer type result. N is an N_Op_Divide node with the result and + -- operand types set. Either (but not both) of the operands may be + -- universal real. + + procedure Expand_Divide_Fixed_By_Integer_Giving_Fixed (N : Node_Id); + -- This routine expands the division between a fixed-point type and + -- standard integer type. The result type is the same fixed-point type + -- as the operand type. N is an N_Op_Divide node with the result and + -- left operand types being the fixed-point type, and the right operand + -- type being standard integer (and possibly Rounded_Result set). + + -------------------------------- + -- Fixed-Point Multiplication -- + -------------------------------- + + procedure Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N : Node_Id); + -- This routine expands the multiplication between fixed-point types + -- with a fixed-point type result. N is an N_Op_Multiply node with the + -- result and operand types set. Either (but not both) of the operands + -- may be universal real. + + procedure Expand_Multiply_Fixed_By_Fixed_Giving_Float (N : Node_Id); + -- This routine expands the multiplication between two fixed-point types + -- with a floating-point result. N is an N_Op_Multiply node with the + -- result and operand types set. Either (but not both) of the operands + -- may be universal real. + + procedure Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N : Node_Id); + -- This routine expands the multiplication between two fixed-point types + -- with an integer result. N is an N_Op_Multiply node with the result + -- and operand types set. Either (but not both) of the operands may be + -- be universal real. + + procedure Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N : Node_Id); + -- This routine expands the multiplication between a fixed-point type and + -- a standard integer type. The result type is the same fixed-point type + -- as the fixed operand type. N is an N_Op_Multiply node whose result type + -- and left operand types are the fixed-point type, and whose right operand + -- type is always standard integer. + + procedure Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N : Node_Id); + -- This routine expands the multiplication between standard integer and a + -- fixed-point type. The result type is the same fixed-point type as the + -- fixed operand type. N is an N_Op_Multiply node whose result type + -- and right operand types are the fixed-point type, and whose left operand + -- type is always standard integer. + +end Exp_Fixd; diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb new file mode 100644 index 000000000..78d9b006a --- /dev/null +++ b/gcc/ada/exp_imgv.adb @@ -0,0 +1,1274 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ I M G V -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Casing; use Casing; +with Checks; use Checks; +with Einfo; use Einfo; +with Exp_Util; use Exp_Util; +with Lib; use Lib; +with Namet; use Namet; +with Nmake; use Nmake; +with Nlists; use Nlists; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem_Aux; use Sem_Aux; +with Sem_Res; use Sem_Res; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package body Exp_Imgv is + + function Has_Decimal_Small (E : Entity_Id) return Boolean; + -- Applies to all entities. True for a Decimal_Fixed_Point_Type, or an + -- Ordinary_Fixed_Point_Type with a small that is a negative power of ten. + -- Shouldn't this be in einfo.adb or sem_aux.adb??? + + ------------------------------------ + -- Build_Enumeration_Image_Tables -- + ------------------------------------ + + procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is + Loc : constant Source_Ptr := Sloc (E); + Str : String_Id; + Ind : List_Id; + Lit : Entity_Id; + Nlit : Nat; + Len : Nat; + Estr : Entity_Id; + Eind : Entity_Id; + Ityp : Node_Id; + + begin + -- Nothing to do for other than a root enumeration type + + if E /= Root_Type (E) then + return; + + -- Nothing to do if pragma Discard_Names applies + + elsif Discard_Names (E) then + return; + end if; + + -- Otherwise tables need constructing + + Start_String; + Ind := New_List; + Lit := First_Literal (E); + Len := 1; + Nlit := 0; + + loop + Append_To (Ind, + Make_Integer_Literal (Loc, UI_From_Int (Len))); + + exit when No (Lit); + Nlit := Nlit + 1; + + Get_Unqualified_Decoded_Name_String (Chars (Lit)); + + if Name_Buffer (1) /= ''' then + Set_Casing (All_Upper_Case); + end if; + + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + Len := Len + Int (Name_Len); + Next_Literal (Lit); + end loop; + + if Len < Int (2 ** (8 - 1)) then + Ityp := Standard_Integer_8; + elsif Len < Int (2 ** (16 - 1)) then + Ityp := Standard_Integer_16; + else + Ityp := Standard_Integer_32; + end if; + + Str := End_String; + + Estr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (E), 'S')); + + Eind := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (E), 'N')); + + Set_Lit_Strings (E, Estr); + Set_Lit_Indexes (E, Eind); + + Insert_Actions (N, + New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Estr, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, + Strval => Str)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Eind, + Constant_Present => True, + + Object_Definition => + Make_Constrained_Array_Definition (Loc, + Discrete_Subtype_Definitions => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 0), + High_Bound => Make_Integer_Literal (Loc, Nlit))), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => New_Occurrence_Of (Ityp, Loc))), + + Expression => + Make_Aggregate (Loc, + Expressions => Ind))), + Suppress => All_Checks); + end Build_Enumeration_Image_Tables; + + ---------------------------- + -- Expand_Image_Attribute -- + ---------------------------- + + -- For all cases other than user defined enumeration types, the scheme + -- is as follows. First we insert the following code: + + -- Snn : String (1 .. rt'Width); + -- Pnn : Natural; + -- Image_xx (tv, Snn, Pnn [,pm]); + -- + -- and then Expr is replaced by Snn (1 .. Pnn) + + -- In the above expansion: + + -- rt is the root type of the expression + -- tv is the expression with the value, usually a type conversion + -- pm is an extra parameter present in some cases + + -- The following table shows tv, xx, and (if used) pm for the various + -- possible types of the argument: + + -- For types whose root type is Character + -- xx = Character + -- tv = Character (Expr) + + -- For types whose root type is Boolean + -- xx = Boolean + -- tv = Boolean (Expr) + + -- For signed integer types with size <= Integer'Size + -- xx = Integer + -- tv = Integer (Expr) + + -- For other signed integer types + -- xx = Long_Long_Integer + -- tv = Long_Long_Integer (Expr) + + -- For modular types with modulus <= System.Unsigned_Types.Unsigned + -- xx = Unsigned + -- tv = System.Unsigned_Types.Unsigned (Expr) + + -- For other modular integer types + -- xx = Long_Long_Unsigned + -- tv = System.Unsigned_Types.Long_Long_Unsigned (Expr) + + -- For types whose root type is Wide_Character + -- xx = Wide_Character + -- tv = Wide_Character (Expr) + -- pm = Boolean, true if Ada 2005 mode, False otherwise + + -- For types whose root type is Wide_Wide_Character + -- xx = Wide_Wide_Character + -- tv = Wide_Wide_Character (Expr) + + -- For floating-point types + -- xx = Floating_Point + -- tv = Long_Long_Float (Expr) + -- pm = typ'Digits (typ = subtype of expression) + + -- For ordinary fixed-point types + -- xx = Ordinary_Fixed_Point + -- tv = Long_Long_Float (Expr) + -- pm = typ'Aft (typ = subtype of expression) + + -- For decimal fixed-point types with size = Integer'Size + -- xx = Decimal + -- tv = Integer (Expr) + -- pm = typ'Scale (typ = subtype of expression) + + -- For decimal fixed-point types with size > Integer'Size + -- xx = Long_Long_Decimal + -- tv = Long_Long_Integer?(Expr) [convert with no scaling] + -- pm = typ'Scale (typ = subtype of expression) + + -- For enumeration types other than those declared packages Standard + -- or System, Snn, Pnn, are expanded as above, but the call looks like: + + -- Image_Enumeration_NN (rt'Pos (X), Snn, Pnn, typS, typI'Address) + + -- where rt is the root type of the expression, and typS and typI are + -- the entities constructed as described in the spec for the procedure + -- Build_Enumeration_Image_Tables and NN is 32/16/8 depending on the + -- element type of Lit_Indexes. The rewriting of the expression to + -- Snn (1 .. Pnn) then occurs as in the other cases. A special case is + -- when pragma Discard_Names applies, in which case we replace expr by: + + -- Missing ??? + + procedure Expand_Image_Attribute (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Exprs : constant List_Id := Expressions (N); + Pref : constant Node_Id := Prefix (N); + Ptyp : constant Entity_Id := Entity (Pref); + Rtyp : constant Entity_Id := Root_Type (Ptyp); + Expr : constant Node_Id := Relocate_Node (First (Exprs)); + Imid : RE_Id; + Tent : Entity_Id; + Ttyp : Entity_Id; + Proc_Ent : Entity_Id; + Enum_Case : Boolean; + + Arg_List : List_Id; + -- List of arguments for run-time procedure call + + Ins_List : List_Id; + -- List of actions to be inserted + + Snn : constant Entity_Id := Make_Temporary (Loc, 'S'); + Pnn : constant Entity_Id := Make_Temporary (Loc, 'P'); + + begin + -- Build declarations of Snn and Pnn to be inserted + + Ins_List := New_List ( + + -- Snn : String (1 .. typ'Width); + + Make_Object_Declaration (Loc, + Defining_Identifier => Snn, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Standard_String, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Rtyp, Loc), + Attribute_Name => Name_Width)))))), + + -- Pnn : Natural; + + Make_Object_Declaration (Loc, + Defining_Identifier => Pnn, + Object_Definition => New_Occurrence_Of (Standard_Natural, Loc))); + + -- Set Imid (RE_Id of procedure to call), and Tent, target for the + -- type conversion of the first argument for all possibilities. + + Enum_Case := False; + + if Rtyp = Standard_Boolean then + Imid := RE_Image_Boolean; + Tent := Rtyp; + + -- For standard character, we have to select the version which handles + -- soft hyphen correctly, based on the version of Ada in use (ugly!) + + elsif Rtyp = Standard_Character then + if Ada_Version < Ada_2005 then + Imid := RE_Image_Character; + else + Imid := RE_Image_Character_05; + end if; + + Tent := Rtyp; + + elsif Rtyp = Standard_Wide_Character then + Imid := RE_Image_Wide_Character; + Tent := Rtyp; + + elsif Rtyp = Standard_Wide_Wide_Character then + Imid := RE_Image_Wide_Wide_Character; + Tent := Rtyp; + + elsif Is_Signed_Integer_Type (Rtyp) then + if Esize (Rtyp) <= Esize (Standard_Integer) then + Imid := RE_Image_Integer; + Tent := Standard_Integer; + else + Imid := RE_Image_Long_Long_Integer; + Tent := Standard_Long_Long_Integer; + end if; + + elsif Is_Modular_Integer_Type (Rtyp) then + if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then + Imid := RE_Image_Unsigned; + Tent := RTE (RE_Unsigned); + else + Imid := RE_Image_Long_Long_Unsigned; + Tent := RTE (RE_Long_Long_Unsigned); + end if; + + elsif Is_Fixed_Point_Type (Rtyp) and then Has_Decimal_Small (Rtyp) then + if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then + Imid := RE_Image_Decimal; + Tent := Standard_Integer; + else + Imid := RE_Image_Long_Long_Decimal; + Tent := Standard_Long_Long_Integer; + end if; + + elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then + Imid := RE_Image_Ordinary_Fixed_Point; + Tent := Standard_Long_Long_Float; + + elsif Is_Floating_Point_Type (Rtyp) then + Imid := RE_Image_Floating_Point; + Tent := Standard_Long_Long_Float; + + -- Only other possibility is user defined enumeration type + + else + if Discard_Names (First_Subtype (Ptyp)) + or else No (Lit_Strings (Root_Type (Ptyp))) + then + -- When pragma Discard_Names applies to the first subtype, build + -- (Pref'Pos)'Img. + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => + Make_Attribute_Reference (Loc, + Prefix => Pref, + Attribute_Name => Name_Pos, + Expressions => New_List (Expr)), + Attribute_Name => + Name_Img)); + Analyze_And_Resolve (N, Standard_String); + return; + + else + -- Here for enumeration type case + + Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); + + if Ttyp = Standard_Integer_8 then + Imid := RE_Image_Enumeration_8; + + elsif Ttyp = Standard_Integer_16 then + Imid := RE_Image_Enumeration_16; + + else + Imid := RE_Image_Enumeration_32; + end if; + + -- Apply a validity check, since it is a bit drastic to get a + -- completely junk image value for an invalid value. + + if not Expr_Known_Valid (Expr) then + Insert_Valid_Check (Expr); + end if; + + Enum_Case := True; + end if; + end if; + + -- Build first argument for call + + if Enum_Case then + Arg_List := New_List ( + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Pos, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Expressions => New_List (Expr))); + + else + Arg_List := New_List (Convert_To (Tent, Expr)); + end if; + + -- Append Snn, Pnn arguments + + Append_To (Arg_List, New_Occurrence_Of (Snn, Loc)); + Append_To (Arg_List, New_Occurrence_Of (Pnn, Loc)); + + -- Get entity of procedure to call + + Proc_Ent := RTE (Imid); + + -- If the procedure entity is empty, that means we have a case in + -- no run time mode where the operation is not allowed, and an + -- appropriate diagnostic has already been issued. + + if No (Proc_Ent) then + return; + end if; + + -- Otherwise complete preparation of arguments for run-time call + + -- Add extra arguments for Enumeration case + + if Enum_Case then + Append_To (Arg_List, New_Occurrence_Of (Lit_Strings (Rtyp), Loc)); + Append_To (Arg_List, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc), + Attribute_Name => Name_Address)); + + -- For floating-point types, append Digits argument + + elsif Is_Floating_Point_Type (Rtyp) then + Append_To (Arg_List, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_Digits)); + + -- For ordinary fixed-point types, append Aft parameter + + elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then + Append_To (Arg_List, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_Aft)); + + if Has_Decimal_Small (Rtyp) then + Set_Conversion_OK (First (Arg_List)); + Set_Etype (First (Arg_List), Tent); + end if; + + -- For decimal, append Scale and also set to do literal conversion + + elsif Is_Decimal_Fixed_Point_Type (Rtyp) then + Append_To (Arg_List, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_Scale)); + + Set_Conversion_OK (First (Arg_List)); + Set_Etype (First (Arg_List), Tent); + + -- For Wide_Character, append Ada 2005 indication + + elsif Rtyp = Standard_Wide_Character then + Append_To (Arg_List, + New_Reference_To (Boolean_Literals (Ada_Version >= Ada_2005), Loc)); + end if; + + -- Now append the procedure call to the insert list + + Append_To (Ins_List, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc_Ent, Loc), + Parameter_Associations => Arg_List)); + + -- Insert declarations of Snn, Pnn, and the procedure call. We suppress + -- checks because we are sure that everything is in range at this stage. + + Insert_Actions (N, Ins_List, Suppress => All_Checks); + + -- Final step is to rewrite the expression as a slice and analyze, + -- again with no checks, since we are sure that everything is OK. + + Rewrite (N, + Make_Slice (Loc, + Prefix => New_Occurrence_Of (Snn, Loc), + Discrete_Range => + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => New_Occurrence_Of (Pnn, Loc)))); + + Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks); + end Expand_Image_Attribute; + + ---------------------------- + -- Expand_Value_Attribute -- + ---------------------------- + + -- For scalar types derived from Boolean, Character and integer types + -- in package Standard, typ'Value (X) expands into: + + -- btyp (Value_xx (X)) + + -- where btyp is he base type of the prefix + + -- For types whose root type is Character + -- xx = Character + + -- For types whose root type is Wide_Character + -- xx = Wide_Character + + -- For types whose root type is Wide_Wide_Character + -- xx = Wide_Wide_Character + + -- For types whose root type is Boolean + -- xx = Boolean + + -- For signed integer types with size <= Integer'Size + -- xx = Integer + + -- For other signed integer types + -- xx = Long_Long_Integer + + -- For modular types with modulus <= System.Unsigned_Types.Unsigned + -- xx = Unsigned + + -- For other modular integer types + -- xx = Long_Long_Unsigned + + -- For floating-point types and ordinary fixed-point types + -- xx = Real + + -- For Wide_[Wide_]Character types, typ'Value (X) expands into: + + -- btyp (Value_xx (X, EM)) + + -- where btyp is the base type of the prefix, and EM is the encoding method + + -- For decimal types with size <= Integer'Size, typ'Value (X) + -- expands into + + -- btyp?(Value_Decimal (X, typ'Scale)); + + -- For all other decimal types, typ'Value (X) expands into + + -- btyp?(Value_Long_Long_Decimal (X, typ'Scale)) + + -- For enumeration types other than those derived from types Boolean, + -- Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to: + + -- Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X)) + + -- where typS and typI and the Lit_Strings and Lit_Indexes entities + -- from T's root type entity, and Num is Enum'Pos (Enum'Last). The + -- Value_Enumeration_NN function will search the tables looking for + -- X and return the position number in the table if found which is + -- used to provide the result of 'Value (using Enum'Val). If the + -- value is not found Constraint_Error is raised. The suffix _NN + -- depends on the element type of typI. + + procedure Expand_Value_Attribute (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Btyp : constant Entity_Id := Base_Type (Typ); + Rtyp : constant Entity_Id := Root_Type (Typ); + Exprs : constant List_Id := Expressions (N); + Vid : RE_Id; + Args : List_Id; + Func : RE_Id; + Ttyp : Entity_Id; + + begin + Args := Exprs; + + if Rtyp = Standard_Character then + Vid := RE_Value_Character; + + elsif Rtyp = Standard_Boolean then + Vid := RE_Value_Boolean; + + elsif Rtyp = Standard_Wide_Character then + Vid := RE_Value_Wide_Character; + + Append_To (Args, + Make_Integer_Literal (Loc, + Intval => Int (Wide_Character_Encoding_Method))); + + elsif Rtyp = Standard_Wide_Wide_Character then + Vid := RE_Value_Wide_Wide_Character; + + Append_To (Args, + Make_Integer_Literal (Loc, + Intval => Int (Wide_Character_Encoding_Method))); + + elsif Rtyp = Base_Type (Standard_Short_Short_Integer) + or else Rtyp = Base_Type (Standard_Short_Integer) + or else Rtyp = Base_Type (Standard_Integer) + then + Vid := RE_Value_Integer; + + elsif Is_Signed_Integer_Type (Rtyp) then + Vid := RE_Value_Long_Long_Integer; + + elsif Is_Modular_Integer_Type (Rtyp) then + if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then + Vid := RE_Value_Unsigned; + else + Vid := RE_Value_Long_Long_Unsigned; + end if; + + elsif Is_Decimal_Fixed_Point_Type (Rtyp) then + if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then + Vid := RE_Value_Decimal; + else + Vid := RE_Value_Long_Long_Decimal; + end if; + + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Typ, Loc), + Attribute_Name => Name_Scale)); + + Rewrite (N, + OK_Convert_To (Btyp, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (Vid), Loc), + Parameter_Associations => Args))); + + Set_Etype (N, Btyp); + Analyze_And_Resolve (N, Btyp); + return; + + elsif Is_Real_Type (Rtyp) then + Vid := RE_Value_Real; + + -- Only other possibility is user defined enumeration type + + else + pragma Assert (Is_Enumeration_Type (Rtyp)); + + -- Case of pragma Discard_Names, transform the Value + -- attribute to Btyp'Val (Long_Long_Integer'Value (Args)) + + if Discard_Names (First_Subtype (Typ)) + or else No (Lit_Strings (Rtyp)) + then + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Btyp, Loc), + Attribute_Name => Name_Val, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Standard_Long_Long_Integer, Loc), + Attribute_Name => Name_Value, + Expressions => Args)))); + + Analyze_And_Resolve (N, Btyp); + + -- Here for normal case where we have enumeration tables, this + -- is where we build + + -- T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X)) + + else + Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); + + if Ttyp = Standard_Integer_8 then + Func := RE_Value_Enumeration_8; + elsif Ttyp = Standard_Integer_16 then + Func := RE_Value_Enumeration_16; + else + Func := RE_Value_Enumeration_32; + end if; + + Prepend_To (Args, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Rtyp, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Rtyp, Loc), + Attribute_Name => Name_Last)))); + + Prepend_To (Args, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc), + Attribute_Name => Name_Address)); + + Prepend_To (Args, + New_Occurrence_Of (Lit_Strings (Rtyp), Loc)); + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Typ, Loc), + Attribute_Name => Name_Val, + Expressions => New_List ( + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (Func), Loc), + Parameter_Associations => Args)))); + + Analyze_And_Resolve (N, Btyp); + end if; + + return; + end if; + + -- Fall through for all cases except user defined enumeration type + -- and decimal types, with Vid set to the Id of the entity for the + -- Value routine and Args set to the list of parameters for the call. + + -- Compiling package Ada.Tags under No_Run_Time_Mode we disable the + -- expansion of the attribute into the function call statement to avoid + -- generating spurious errors caused by the use of Integer_Address'Value + -- in our implementation of Ada.Tags.Internal_Tag + + -- Seems like a bit of a kludge, there should be a better way ??? + + -- There is a better way, you should also test RTE_Available ??? + + if No_Run_Time_Mode + and then Rtyp = RTE (RE_Integer_Address) + and then RTU_Loaded (Ada_Tags) + and then Cunit_Entity (Current_Sem_Unit) + = Body_Entity (RTU_Entity (Ada_Tags)) + then + Rewrite (N, + Unchecked_Convert_To (Rtyp, + Make_Integer_Literal (Loc, Uint_0))); + else + Rewrite (N, + Convert_To (Btyp, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (Vid), Loc), + Parameter_Associations => Args))); + end if; + + Analyze_And_Resolve (N, Btyp); + end Expand_Value_Attribute; + + --------------------------------- + -- Expand_Wide_Image_Attribute -- + --------------------------------- + + -- We expand typ'Wide_Image (X) as follows. First we insert this code: + + -- Rnn : Wide_String (1 .. rt'Wide_Width); + -- Lnn : Natural; + -- String_To_Wide_String + -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method); + + -- where rt is the root type of the prefix type + + -- Now we replace the Wide_Image reference by + + -- Rnn (1 .. Lnn) + + -- This works in all cases because String_To_Wide_String converts any + -- wide character escape sequences resulting from the Image call to the + -- proper Wide_Character equivalent + + -- not quite right for typ = Wide_Character ??? + + procedure Expand_Wide_Image_Attribute (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N))); + Rnn : constant Entity_Id := Make_Temporary (Loc, 'S'); + Lnn : constant Entity_Id := Make_Temporary (Loc, 'P'); + + begin + Insert_Actions (N, New_List ( + + -- Rnn : Wide_String (1 .. base_typ'Width); + + Make_Object_Declaration (Loc, + Defining_Identifier => Rnn, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Standard_Wide_String, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Rtyp, Loc), + Attribute_Name => Name_Wide_Width)))))), + + -- Lnn : Natural; + + Make_Object_Declaration (Loc, + Defining_Identifier => Lnn, + Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)), + + -- String_To_Wide_String + -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method); + + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_String_To_Wide_String), Loc), + + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Prefix (N), + Attribute_Name => Name_Image, + Expressions => Expressions (N)), + New_Reference_To (Rnn, Loc), + New_Reference_To (Lnn, Loc), + Make_Integer_Literal (Loc, + Intval => Int (Wide_Character_Encoding_Method))))), + + -- Suppress checks because we know everything is properly in range + + Suppress => All_Checks); + + -- Final step is to rewrite the expression as a slice and analyze, + -- again with no checks, since we are sure that everything is OK. + + Rewrite (N, + Make_Slice (Loc, + Prefix => New_Occurrence_Of (Rnn, Loc), + Discrete_Range => + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => New_Occurrence_Of (Lnn, Loc)))); + + Analyze_And_Resolve (N, Standard_Wide_String, Suppress => All_Checks); + end Expand_Wide_Image_Attribute; + + -------------------------------------- + -- Expand_Wide_Wide_Image_Attribute -- + -------------------------------------- + + -- We expand typ'Wide_Wide_Image (X) as follows. First we insert this code: + + -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width); + -- Lnn : Natural; + -- String_To_Wide_Wide_String + -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method); + + -- where rt is the root type of the prefix type + + -- Now we replace the Wide_Wide_Image reference by + + -- Rnn (1 .. Lnn) + + -- This works in all cases because String_To_Wide_Wide_String converts any + -- wide character escape sequences resulting from the Image call to the + -- proper Wide_Wide_Character equivalent + + -- not quite right for typ = Wide_Wide_Character ??? + + procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N))); + + Rnn : constant Entity_Id := Make_Temporary (Loc, 'S'); + Lnn : constant Entity_Id := Make_Temporary (Loc, 'P'); + + begin + Insert_Actions (N, New_List ( + + -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width); + + Make_Object_Declaration (Loc, + Defining_Identifier => Rnn, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Standard_Wide_Wide_String, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Rtyp, Loc), + Attribute_Name => Name_Wide_Wide_Width)))))), + + -- Lnn : Natural; + + Make_Object_Declaration (Loc, + Defining_Identifier => Lnn, + Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)), + + -- String_To_Wide_Wide_String + -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method); + + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_String_To_Wide_Wide_String), Loc), + + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Prefix (N), + Attribute_Name => Name_Image, + Expressions => Expressions (N)), + New_Reference_To (Rnn, Loc), + New_Reference_To (Lnn, Loc), + Make_Integer_Literal (Loc, + Intval => Int (Wide_Character_Encoding_Method))))), + + -- Suppress checks because we know everything is properly in range + + Suppress => All_Checks); + + -- Final step is to rewrite the expression as a slice and analyze, + -- again with no checks, since we are sure that everything is OK. + + Rewrite (N, + Make_Slice (Loc, + Prefix => New_Occurrence_Of (Rnn, Loc), + Discrete_Range => + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => New_Occurrence_Of (Lnn, Loc)))); + + Analyze_And_Resolve + (N, Standard_Wide_Wide_String, Suppress => All_Checks); + end Expand_Wide_Wide_Image_Attribute; + + ---------------------------- + -- Expand_Width_Attribute -- + ---------------------------- + + -- The processing here also handles the case of Wide_[Wide_]Width. With the + -- exceptions noted, the processing is identical + + -- For scalar types derived from Boolean, character and integer types + -- in package Standard. Note that the Width attribute is computed at + -- compile time for all cases except those involving non-static sub- + -- types. For such subtypes, typ'[Wide_[Wide_]]Width expands into: + + -- Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last))) + + -- where + + -- For types whose root type is Character + -- xx = Width_Character + -- yy = Character + + -- For types whose root type is Wide_Character + -- xx = Wide_Width_Character + -- yy = Character + + -- For types whose root type is Wide_Wide_Character + -- xx = Wide_Wide_Width_Character + -- yy = Character + + -- For types whose root type is Boolean + -- xx = Width_Boolean + -- yy = Boolean + + -- For signed integer types + -- xx = Width_Long_Long_Integer + -- yy = Long_Long_Integer + + -- For modular integer types + -- xx = Width_Long_Long_Unsigned + -- yy = Long_Long_Unsigned + + -- For types derived from Wide_Character, typ'Width expands into + + -- Result_Type (Width_Wide_Character ( + -- Wide_Character (typ'First), + -- Wide_Character (typ'Last), + + -- and typ'Wide_Width expands into: + + -- Result_Type (Wide_Width_Wide_Character ( + -- Wide_Character (typ'First), + -- Wide_Character (typ'Last)); + + -- and typ'Wide_Wide_Width expands into + + -- Result_Type (Wide_Wide_Width_Wide_Character ( + -- Wide_Character (typ'First), + -- Wide_Character (typ'Last)); + + -- For types derived from Wide_Wide_Character, typ'Width expands into + + -- Result_Type (Width_Wide_Wide_Character ( + -- Wide_Wide_Character (typ'First), + -- Wide_Wide_Character (typ'Last), + + -- and typ'Wide_Width expands into: + + -- Result_Type (Wide_Width_Wide_Wide_Character ( + -- Wide_Wide_Character (typ'First), + -- Wide_Wide_Character (typ'Last)); + + -- and typ'Wide_Wide_Width expands into + + -- Result_Type (Wide_Wide_Width_Wide_Wide_Char ( + -- Wide_Wide_Character (typ'First), + -- Wide_Wide_Character (typ'Last)); + + -- For real types, typ'Width and typ'Wide_[Wide_]Width expand into + + -- if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if + + -- where btyp is the base type. This looks recursive but it isn't + -- because the base type is always static, and hence the expression + -- in the else is reduced to an integer literal. + + -- For user defined enumeration types, typ'Width expands into + + -- Result_Type (Width_Enumeration_NN + -- (typS, + -- typI'Address, + -- typ'Pos (typ'First), + -- typ'Pos (Typ'Last))); + + -- and typ'Wide_Width expands into: + + -- Result_Type (Wide_Width_Enumeration_NN + -- (typS, + -- typI, + -- typ'Pos (typ'First), + -- typ'Pos (Typ'Last)) + -- Wide_Character_Encoding_Method); + + -- and typ'Wide_Wide_Width expands into: + + -- Result_Type (Wide_Wide_Width_Enumeration_NN + -- (typS, + -- typI, + -- typ'Pos (typ'First), + -- typ'Pos (Typ'Last)) + -- Wide_Character_Encoding_Method); + + -- where typS and typI are the enumeration image strings and + -- indexes table, as described in Build_Enumeration_Image_Tables. + -- NN is 8/16/32 for depending on the element type for typI. + + procedure Expand_Width_Attribute (N : Node_Id; Attr : Atype := Normal) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Pref : constant Node_Id := Prefix (N); + Ptyp : constant Entity_Id := Etype (Pref); + Rtyp : constant Entity_Id := Root_Type (Ptyp); + XX : RE_Id; + YY : Entity_Id; + Arglist : List_Id; + Ttyp : Entity_Id; + + begin + -- Types derived from Standard.Boolean + + if Rtyp = Standard_Boolean then + XX := RE_Width_Boolean; + YY := Rtyp; + + -- Types derived from Standard.Character + + elsif Rtyp = Standard_Character then + case Attr is + when Normal => XX := RE_Width_Character; + when Wide => XX := RE_Wide_Width_Character; + when Wide_Wide => XX := RE_Wide_Wide_Width_Character; + end case; + + YY := Rtyp; + + -- Types derived from Standard.Wide_Character + + elsif Rtyp = Standard_Wide_Character then + case Attr is + when Normal => XX := RE_Width_Wide_Character; + when Wide => XX := RE_Wide_Width_Wide_Character; + when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Character; + end case; + + YY := Rtyp; + + -- Types derived from Standard.Wide_Wide_Character + + elsif Rtyp = Standard_Wide_Wide_Character then + case Attr is + when Normal => XX := RE_Width_Wide_Wide_Character; + when Wide => XX := RE_Wide_Width_Wide_Wide_Character; + when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Wide_Char; + end case; + + YY := Rtyp; + + -- Signed integer types + + elsif Is_Signed_Integer_Type (Rtyp) then + XX := RE_Width_Long_Long_Integer; + YY := Standard_Long_Long_Integer; + + -- Modular integer types + + elsif Is_Modular_Integer_Type (Rtyp) then + XX := RE_Width_Long_Long_Unsigned; + YY := RTE (RE_Long_Long_Unsigned); + + -- Real types + + elsif Is_Real_Type (Rtyp) then + + Rewrite (N, + Make_Conditional_Expression (Loc, + Expressions => New_List ( + + Make_Op_Gt (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_First), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_Last)), + + Make_Integer_Literal (Loc, 0), + + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Base_Type (Ptyp), Loc), + Attribute_Name => Name_Width)))); + + Analyze_And_Resolve (N, Typ); + return; + + -- User defined enumeration types + + else + pragma Assert (Is_Enumeration_Type (Rtyp)); + + if Discard_Names (Rtyp) then + + -- This is a configurable run-time, or else a restriction is in + -- effect. In either case the attribute cannot be supported. Force + -- a load error from Rtsfind to generate an appropriate message, + -- as is done with other ZFP violations. + + declare + Discard : constant Entity_Id := RTE (RE_Null); + pragma Unreferenced (Discard); + begin + return; + end; + end if; + + Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); + + case Attr is + when Normal => + if Ttyp = Standard_Integer_8 then + XX := RE_Width_Enumeration_8; + elsif Ttyp = Standard_Integer_16 then + XX := RE_Width_Enumeration_16; + else + XX := RE_Width_Enumeration_32; + end if; + + when Wide => + if Ttyp = Standard_Integer_8 then + XX := RE_Wide_Width_Enumeration_8; + elsif Ttyp = Standard_Integer_16 then + XX := RE_Wide_Width_Enumeration_16; + else + XX := RE_Wide_Width_Enumeration_32; + end if; + + when Wide_Wide => + if Ttyp = Standard_Integer_8 then + XX := RE_Wide_Wide_Width_Enumeration_8; + elsif Ttyp = Standard_Integer_16 then + XX := RE_Wide_Wide_Width_Enumeration_16; + else + XX := RE_Wide_Wide_Width_Enumeration_32; + end if; + end case; + + Arglist := + New_List ( + New_Occurrence_Of (Lit_Strings (Rtyp), Loc), + + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc), + Attribute_Name => Name_Address), + + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_Pos, + + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_First))), + + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_Pos, + + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_Last)))); + + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (XX), Loc), + Parameter_Associations => Arglist))); + + Analyze_And_Resolve (N, Typ); + return; + end if; + + -- If we fall through XX and YY are set + + Arglist := New_List ( + Convert_To (YY, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_First)), + + Convert_To (YY, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_Last))); + + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (XX), Loc), + Parameter_Associations => Arglist))); + + Analyze_And_Resolve (N, Typ); + end Expand_Width_Attribute; + + ----------------------- + -- Has_Decimal_Small -- + ----------------------- + + function Has_Decimal_Small (E : Entity_Id) return Boolean is + begin + return Is_Decimal_Fixed_Point_Type (E) + or else + (Is_Ordinary_Fixed_Point_Type (E) + and then Ureal_10**Aft_Value (E) * Small_Value (E) = Ureal_1); + end Has_Decimal_Small; + +end Exp_Imgv; diff --git a/gcc/ada/exp_imgv.ads b/gcc/ada/exp_imgv.ads new file mode 100644 index 000000000..27b2452ab --- /dev/null +++ b/gcc/ada/exp_imgv.ads @@ -0,0 +1,96 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ I M G V -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for Image, Value and Width attributes. These are the +-- attributes that make use of enumeration type image tables. + +with Types; use Types; + +package Exp_Imgv is + + procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id); + -- Build the enumeration image tables for E, which is an enumeration + -- base type. The node N is the point in the tree where the resulting + -- declarations are to be inserted. + -- + -- The form of the tables generated is as follows: + -- + -- xxxS : string := "chars"; + -- xxxI : array (0 .. N) of Natural_8/16/32 := (1, n, .., n); + -- + -- Here xxxS is a string obtained by concatenating all the names + -- of the enumeration literals in sequence, representing any wide + -- characters according to the current wide character encoding + -- method, and with all letters forced to upper case. + -- + -- The array xxxI is an array of ones origin indexes to the start + -- of each name, with one extra entry at the end, which is the index + -- to the character just past the end of the last literal, i.e. it is + -- the length of xxxS + 1. The element type is the shortest of the + -- possible types that will hold all the values. + -- + -- For example, for the type + -- + -- type x is (hello,'!',goodbye); + -- + -- the generated tables would consist of + -- + -- xxxS : String := "hello'!'goodbye"; + -- xxxI : array (0 .. 3) of Natural_8 := (1, 6, 9, 16); + -- + -- Here Natural_8 is used since 16 < 2**(8-1) + -- + -- If the entity E needs the tables constructing, the necessary + -- declarations are constructed, and the fields Lit_Strings and + -- Lit_Indexes of E are set to point to the corresponding entities. + -- If no tables are needed (E is not a user defined enumeration + -- root type, or pragma Discard_Names is in effect, then the + -- declarations are not constructed, and the fields remain Empty. + + procedure Expand_Image_Attribute (N : Node_Id); + -- This procedure is called from Exp_Attr to expand an occurrence + -- of the attribute Image. + + procedure Expand_Wide_Image_Attribute (N : Node_Id); + -- This procedure is called from Exp_Attr to expand an occurrence + -- of the attribute Wide_Image. + + procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id); + -- This procedure is called from Exp_Attr to expand an occurrence + -- of the attribute Wide_Wide_Image. + + procedure Expand_Value_Attribute (N : Node_Id); + -- This procedure is called from Exp_Attr to expand an occurrence + -- of the attribute Value. + + type Atype is (Normal, Wide, Wide_Wide); + -- Type of attribute in call to Expand_Width_Attribute + + procedure Expand_Width_Attribute (N : Node_Id; Attr : Atype := Normal); + -- This procedure is called from Exp_Attr to expand an occurrence of the + -- attributes Width (Attr = Normal), or Wide_Width (Attr Wide), or + -- Wide_Wide_Width (Attr = Wide_Wide). + +end Exp_Imgv; diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb new file mode 100644 index 000000000..977e33556 --- /dev/null +++ b/gcc/ada/exp_intr.adb @@ -0,0 +1,1226 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ I N T 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Atag; use Exp_Atag; +with Exp_Ch4; use Exp_Ch4; +with Exp_Ch7; use Exp_Ch7; +with Exp_Ch11; use Exp_Ch11; +with Exp_Code; use Exp_Code; +with Exp_Fixd; use Exp_Fixd; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Namet; use Namet; +with Nmake; use Nmake; +with Nlists; use Nlists; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Tbuild; use Tbuild; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package body Exp_Intr is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Expand_Binary_Operator_Call (N : Node_Id); + -- Expand a call to an intrinsic arithmetic operator when the operand + -- types or sizes are not identical. + + procedure Expand_Is_Negative (N : Node_Id); + -- Expand a call to the intrinsic Is_Negative function + + procedure Expand_Dispatching_Constructor_Call (N : Node_Id); + -- Expand a call to an instantiation of Generic_Dispatching_Constructor + -- into a dispatching call to the actual subprogram associated with the + -- Constructor formal subprogram, passing it the Parameters actual of + -- the call to the instantiation and dispatching based on call's Tag + -- parameter. + + procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id); + -- Expand a call to Exception_Information/Message/Name. The first + -- parameter, N, is the node for the function call, and Ent is the + -- entity for the corresponding routine in the Ada.Exceptions package. + + procedure Expand_Import_Call (N : Node_Id); + -- Expand a call to Import_Address/Longest_Integer/Value. The parameter + -- N is the node for the function call. + + procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind); + -- Expand an intrinsic shift operation, N and E are from the call to + -- Expand_Intrinsic_Call (call node and subprogram spec entity) and + -- K is the kind for the shift node + + procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id); + -- Expand a call to an instantiation of Unchecked_Conversion into a node + -- N_Unchecked_Type_Conversion. + + procedure Expand_Unc_Deallocation (N : Node_Id); + -- Expand a call to an instantiation of Unchecked_Deallocation into a node + -- N_Free_Statement and appropriate context. + + procedure Expand_To_Address (N : Node_Id); + procedure Expand_To_Pointer (N : Node_Id); + -- Expand a call to corresponding function, declared in an instance of + -- System.Address_To_Access_Conversions. + + procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id); + -- Rewrite the node by the appropriate string or positive constant. + -- Nam can be one of the following: + -- Name_File - expand string that is the name of source file + -- Name_Line - expand integer line number + -- Name_Source_Location - expand string of form file:line + -- Name_Enclosing_Entity - expand string with name of enclosing entity + + --------------------------------- + -- Expand_Binary_Operator_Call -- + --------------------------------- + + procedure Expand_Binary_Operator_Call (N : Node_Id) is + T1 : constant Entity_Id := Underlying_Type (Etype (Left_Opnd (N))); + T2 : constant Entity_Id := Underlying_Type (Etype (Right_Opnd (N))); + TR : constant Entity_Id := Etype (N); + T3 : Entity_Id; + Res : Node_Id; + + Siz : constant Uint := UI_Max (Esize (T1), Esize (T2)); + -- Maximum of operand sizes + + begin + -- Nothing to do if the operands have the same modular type + + if Base_Type (T1) = Base_Type (T2) + and then Is_Modular_Integer_Type (T1) + then + return; + end if; + + -- Use Unsigned_32 for sizes of 32 or below, else Unsigned_64 + + if Siz > 32 then + T3 := RTE (RE_Unsigned_64); + else + T3 := RTE (RE_Unsigned_32); + end if; + + -- Copy operator node, and reset type and entity fields, for + -- subsequent reanalysis. + + Res := New_Copy (N); + Set_Etype (Res, T3); + + case Nkind (N) is + when N_Op_And => + Set_Entity (Res, Standard_Op_And); + when N_Op_Or => + Set_Entity (Res, Standard_Op_Or); + when N_Op_Xor => + Set_Entity (Res, Standard_Op_Xor); + when others => + raise Program_Error; + end case; + + -- Convert operands to large enough intermediate type + + Set_Left_Opnd (Res, + Unchecked_Convert_To (T3, Relocate_Node (Left_Opnd (N)))); + Set_Right_Opnd (Res, + Unchecked_Convert_To (T3, Relocate_Node (Right_Opnd (N)))); + + -- Analyze and resolve result formed by conversion to target type + + Rewrite (N, Unchecked_Convert_To (TR, Res)); + Analyze_And_Resolve (N, TR); + end Expand_Binary_Operator_Call; + + ----------------------------------------- + -- Expand_Dispatching_Constructor_Call -- + ----------------------------------------- + + -- Transform a call to an instantiation of Generic_Dispatching_Constructor + -- of the form: + + -- GDC_Instance (The_Tag, Parameters'Access) + + -- to a class-wide conversion of a dispatching call to the actual + -- associated with the formal subprogram Construct, designating The_Tag + -- as the controlling tag of the call: + + -- T'Class (Construct'Actual (Params)) -- Controlling tag is The_Tag + + -- which will eventually be expanded to the following: + + -- T'Class (The_Tag.all (Construct'Actual'Index).all (Params)) + + -- A class-wide membership test is also generated, preceding the call, to + -- ensure that the controlling tag denotes a type in T'Class. + + procedure Expand_Dispatching_Constructor_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Tag_Arg : constant Node_Id := First_Actual (N); + Param_Arg : constant Node_Id := Next_Actual (Tag_Arg); + Subp_Decl : constant Node_Id := Parent (Parent (Entity (Name (N)))); + Inst_Pkg : constant Node_Id := Parent (Subp_Decl); + Act_Rename : Node_Id; + Act_Constr : Entity_Id; + Iface_Tag : Node_Id := Empty; + Cnstr_Call : Node_Id; + Result_Typ : Entity_Id; + + begin + -- The subprogram is the third actual in the instantiation, and is + -- retrieved from the corresponding renaming declaration. However, + -- freeze nodes may appear before, so we retrieve the declaration + -- with an explicit loop. + + Act_Rename := First (Visible_Declarations (Inst_Pkg)); + while Nkind (Act_Rename) /= N_Subprogram_Renaming_Declaration loop + Next (Act_Rename); + end loop; + + Act_Constr := Entity (Name (Act_Rename)); + Result_Typ := Class_Wide_Type (Etype (Act_Constr)); + + -- Ada 2005 (AI-251): If the result is an interface type, the function + -- returns a class-wide interface type (otherwise the resulting object + -- would be abstract!) + + if Is_Interface (Etype (Act_Constr)) then + Set_Etype (Act_Constr, Result_Typ); + + -- If the result type is not parent of Tag_Arg then we need to + -- locate the tag of the secondary dispatch table. + + if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg)) then + pragma Assert (not Is_Interface (Etype (Tag_Arg))); + + Iface_Tag := + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'V'), + Object_Definition => + New_Reference_To (RTE (RE_Tag), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Secondary_Tag), Loc), + Parameter_Associations => New_List ( + Relocate_Node (Tag_Arg), + New_Reference_To + (Node (First_Elmt (Access_Disp_Table + (Etype (Etype (Act_Constr))))), + Loc)))); + Insert_Action (N, Iface_Tag); + end if; + end if; + + -- Create the call to the actual Constructor function + + Cnstr_Call := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Act_Constr, Loc), + Parameter_Associations => New_List (Relocate_Node (Param_Arg))); + + -- Establish its controlling tag from the tag passed to the instance + -- The tag may be given by a function call, in which case a temporary + -- should be generated now, to prevent out-of-order insertions during + -- the expansion of that call when stack-checking is enabled. + + if Present (Iface_Tag) then + Set_Controlling_Argument (Cnstr_Call, + New_Occurrence_Of (Defining_Identifier (Iface_Tag), Loc)); + else + Remove_Side_Effects (Tag_Arg); + Set_Controlling_Argument (Cnstr_Call, + Relocate_Node (Tag_Arg)); + end if; + + -- Rewrite and analyze the call to the instance as a class-wide + -- conversion of the call to the actual constructor. + + Rewrite (N, Convert_To (Result_Typ, Cnstr_Call)); + Analyze_And_Resolve (N, Etype (Act_Constr)); + + -- Do not generate a run-time check on the built object if tag + -- checks are suppressed for the result type or VM_Target /= No_VM + + if Tag_Checks_Suppressed (Etype (Result_Typ)) + or else not Tagged_Type_Expansion + then + null; + + -- Generate a class-wide membership test to ensure that the call's tag + -- argument denotes a type within the class. We must keep separate the + -- case in which the Result_Type of the constructor function is a tagged + -- type from the case in which it is an abstract interface because the + -- run-time subprogram required to check these cases differ (and have + -- one difference in their parameters profile). + + -- Call CW_Membership if the Result_Type is a tagged type to look for + -- the tag in the table of ancestor tags. + + elsif not Is_Interface (Result_Typ) then + declare + Obj_Tag_Node : Node_Id := Duplicate_Subexpr (Tag_Arg); + CW_Test_Node : Node_Id; + + begin + Build_CW_Membership (Loc, + Obj_Tag_Node => Obj_Tag_Node, + Typ_Tag_Node => + New_Reference_To ( + Node (First_Elmt (Access_Disp_Table ( + Root_Type (Result_Typ)))), Loc), + Related_Nod => N, + New_Node => CW_Test_Node); + + Insert_Action (N, + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Not (Loc, CW_Test_Node), + Then_Statements => + New_List (Make_Raise_Statement (Loc, + New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); + end; + + -- Call IW_Membership test if the Result_Type is an abstract interface + -- to look for the tag in the table of interface tags. + + else + Insert_Action (N, + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Not (Loc, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Tag_Arg), + Attribute_Name => Name_Address), + + New_Reference_To ( + Node (First_Elmt (Access_Disp_Table ( + Root_Type (Result_Typ)))), Loc)))), + Then_Statements => + New_List ( + Make_Raise_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); + end if; + end Expand_Dispatching_Constructor_Call; + + --------------------------- + -- Expand_Exception_Call -- + --------------------------- + + -- If the function call is not within an exception handler, then the call + -- is replaced by a null string. Otherwise the appropriate routine in + -- Ada.Exceptions is called passing the choice parameter specification + -- from the enclosing handler. If the enclosing handler lacks a choice + -- parameter, then one is supplied. + + procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id) is + Loc : constant Source_Ptr := Sloc (N); + P : Node_Id; + E : Entity_Id; + + begin + -- Climb up parents to see if we are in exception handler + + P := Parent (N); + loop + -- Case of not in exception handler, replace by null string + + if No (P) then + Rewrite (N, + Make_String_Literal (Loc, + Strval => "")); + exit; + + -- Case of in exception handler + + elsif Nkind (P) = N_Exception_Handler then + + -- Handler cannot be used for a local raise, and furthermore, this + -- is a violation of the No_Exception_Propagation restriction. + + Set_Local_Raise_Not_OK (P); + Check_Restriction (No_Exception_Propagation, N); + + -- If no choice parameter present, then put one there. Note that + -- we do not need to put it on the entity chain, since no one will + -- be referencing it by normal visibility methods. + + if No (Choice_Parameter (P)) then + E := Make_Temporary (Loc, 'E'); + Set_Choice_Parameter (P, E); + Set_Ekind (E, E_Variable); + Set_Etype (E, RTE (RE_Exception_Occurrence)); + Set_Scope (E, Current_Scope); + end if; + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Ent), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Choice_Parameter (P), Loc)))); + exit; + + -- Keep climbing! + + else + P := Parent (P); + end if; + end loop; + + Analyze_And_Resolve (N, Standard_String); + end Expand_Exception_Call; + + ------------------------ + -- Expand_Import_Call -- + ------------------------ + + -- The function call must have a static string as its argument. We create + -- a dummy variable which uses this string as the external name in an + -- Import pragma. The result is then obtained as the address of this + -- dummy variable, converted to the appropriate target type. + + procedure Expand_Import_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ent : constant Entity_Id := Entity (Name (N)); + Str : constant Node_Id := First_Actual (N); + Dum : constant Entity_Id := Make_Temporary (Loc, 'D'); + + begin + Insert_Actions (N, New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Dum, + Object_Definition => + New_Occurrence_Of (Standard_Character, Loc)), + + Make_Pragma (Loc, + Chars => Name_Import, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_Ada)), + + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Chars (Dum))), + + Make_Pragma_Argument_Association (Loc, + Chars => Name_Link_Name, + Expression => Relocate_Node (Str)))))); + + Rewrite (N, + Unchecked_Convert_To (Etype (Ent), + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Chars (Dum)), + Attribute_Name => Name_Address))); + + Analyze_And_Resolve (N, Etype (Ent)); + end Expand_Import_Call; + + --------------------------- + -- Expand_Intrinsic_Call -- + --------------------------- + + procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id) is + Nam : Name_Id; + + begin + -- If an external name is specified for the intrinsic, it is handled + -- by the back-end: leave the call node unchanged for now. + + if Present (Interface_Name (E)) then + return; + end if; + + -- If the intrinsic subprogram is generic, gets its original name + + if Present (Parent (E)) + and then Present (Generic_Parent (Parent (E))) + then + Nam := Chars (Generic_Parent (Parent (E))); + else + Nam := Chars (E); + end if; + + if Nam = Name_Asm then + Expand_Asm_Call (N); + + elsif Nam = Name_Divide then + Expand_Decimal_Divide_Call (N); + + elsif Nam = Name_Exception_Information then + Expand_Exception_Call (N, RE_Exception_Information); + + elsif Nam = Name_Exception_Message then + Expand_Exception_Call (N, RE_Exception_Message); + + elsif Nam = Name_Exception_Name then + Expand_Exception_Call (N, RE_Exception_Name_Simple); + + elsif Nam = Name_Generic_Dispatching_Constructor then + Expand_Dispatching_Constructor_Call (N); + + elsif Nam = Name_Import_Address + or else + Nam = Name_Import_Largest_Value + or else + Nam = Name_Import_Value + then + Expand_Import_Call (N); + + elsif Nam = Name_Is_Negative then + Expand_Is_Negative (N); + + elsif Nam = Name_Rotate_Left then + Expand_Shift (N, E, N_Op_Rotate_Left); + + elsif Nam = Name_Rotate_Right then + Expand_Shift (N, E, N_Op_Rotate_Right); + + elsif Nam = Name_Shift_Left then + Expand_Shift (N, E, N_Op_Shift_Left); + + elsif Nam = Name_Shift_Right then + Expand_Shift (N, E, N_Op_Shift_Right); + + elsif Nam = Name_Shift_Right_Arithmetic then + Expand_Shift (N, E, N_Op_Shift_Right_Arithmetic); + + elsif Nam = Name_Unchecked_Conversion then + Expand_Unc_Conversion (N, E); + + elsif Nam = Name_Unchecked_Deallocation then + Expand_Unc_Deallocation (N); + + elsif Nam = Name_To_Address then + Expand_To_Address (N); + + elsif Nam = Name_To_Pointer then + Expand_To_Pointer (N); + + elsif Nam = Name_File + or else Nam = Name_Line + or else Nam = Name_Source_Location + or else Nam = Name_Enclosing_Entity + then + Expand_Source_Info (N, Nam); + + -- If we have a renaming, expand the call to the original operation, + -- which must itself be intrinsic, since renaming requires matching + -- conventions and this has already been checked. + + elsif Present (Alias (E)) then + Expand_Intrinsic_Call (N, Alias (E)); + + elsif Nkind (N) in N_Binary_Op then + Expand_Binary_Operator_Call (N); + + -- The only other case is where an external name was specified, + -- since this is the only way that an otherwise unrecognized + -- name could escape the checking in Sem_Prag. Nothing needs + -- to be done in such a case, since we pass such a call to the + -- back end unchanged. + + else + null; + end if; + end Expand_Intrinsic_Call; + + ------------------------ + -- Expand_Is_Negative -- + ------------------------ + + procedure Expand_Is_Negative (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Opnd : constant Node_Id := Relocate_Node (First_Actual (N)); + + begin + + -- We replace the function call by the following expression + + -- if Opnd < 0.0 then + -- True + -- else + -- if Opnd > 0.0 then + -- False; + -- else + -- Float_Unsigned!(Float (Opnd)) /= 0 + -- end if; + -- end if; + + Rewrite (N, + Make_Conditional_Expression (Loc, + Expressions => New_List ( + Make_Op_Lt (Loc, + Left_Opnd => Duplicate_Subexpr (Opnd), + Right_Opnd => Make_Real_Literal (Loc, Ureal_0)), + + New_Occurrence_Of (Standard_True, Loc), + + Make_Conditional_Expression (Loc, + Expressions => New_List ( + Make_Op_Gt (Loc, + Left_Opnd => Duplicate_Subexpr_No_Checks (Opnd), + Right_Opnd => Make_Real_Literal (Loc, Ureal_0)), + + New_Occurrence_Of (Standard_False, Loc), + + Make_Op_Ne (Loc, + Left_Opnd => + Unchecked_Convert_To + (RTE (RE_Float_Unsigned), + Convert_To + (Standard_Float, + Duplicate_Subexpr_No_Checks (Opnd))), + Right_Opnd => + Make_Integer_Literal (Loc, 0))))))); + + Analyze_And_Resolve (N, Standard_Boolean); + end Expand_Is_Negative; + + ------------------ + -- Expand_Shift -- + ------------------ + + -- This procedure is used to convert a call to a shift function to the + -- corresponding operator node. This conversion is not done by the usual + -- circuit for converting calls to operator functions (e.g. "+"(1,2)) to + -- operator nodes, because shifts are not predefined operators. + + -- As a result, whenever a shift is used in the source program, it will + -- remain as a call until converted by this routine to the operator node + -- form which Gigi is expecting to see. + + -- Note: it is possible for the expander to generate shift operator nodes + -- directly, which will be analyzed in the normal manner by calling Analyze + -- and Resolve. Such shift operator nodes will not be seen by Expand_Shift. + + procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Left : constant Node_Id := First_Actual (N); + Right : constant Node_Id := Next_Actual (Left); + Ltyp : constant Node_Id := Etype (Left); + Rtyp : constant Node_Id := Etype (Right); + Snode : Node_Id; + + begin + Snode := New_Node (K, Loc); + Set_Left_Opnd (Snode, Relocate_Node (Left)); + Set_Right_Opnd (Snode, Relocate_Node (Right)); + Set_Chars (Snode, Chars (E)); + Set_Etype (Snode, Base_Type (Typ)); + Set_Entity (Snode, E); + + if Compile_Time_Known_Value (Type_High_Bound (Rtyp)) + and then Expr_Value (Type_High_Bound (Rtyp)) < Esize (Ltyp) + then + Set_Shift_Count_OK (Snode, True); + end if; + + -- Do the rewrite. Note that we don't call Analyze and Resolve on + -- this node, because it already got analyzed and resolved when + -- it was a function call! + + Rewrite (N, Snode); + Set_Analyzed (N); + end Expand_Shift; + + ------------------------ + -- Expand_Source_Info -- + ------------------------ + + procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ent : Entity_Id; + + procedure Write_Entity_Name (E : Entity_Id); + -- Recursive procedure to construct string for qualified name of + -- enclosing program unit. The qualification stops at an enclosing + -- scope has no source name (block or loop). If entity is a subprogram + -- instance, skip enclosing wrapper package. + + ----------------------- + -- Write_Entity_Name -- + ----------------------- + + procedure Write_Entity_Name (E : Entity_Id) is + SDef : Source_Ptr; + TDef : constant Source_Buffer_Ptr := + Source_Text (Get_Source_File_Index (Sloc (E))); + + begin + -- Nothing to do if at outer level + + if Scope (E) = Standard_Standard then + null; + + -- If scope comes from source, write its name + + elsif Comes_From_Source (Scope (E)) then + Write_Entity_Name (Scope (E)); + Add_Char_To_Name_Buffer ('.'); + + -- If in wrapper package skip past it + + elsif Is_Wrapper_Package (Scope (E)) then + Write_Entity_Name (Scope (Scope (E))); + Add_Char_To_Name_Buffer ('.'); + + -- Otherwise nothing to output (happens in unnamed block statements) + + else + null; + end if; + + -- Loop to output the name + + -- is this right wrt wide char encodings ??? (no!) + + SDef := Sloc (E); + while TDef (SDef) in '0' .. '9' + or else TDef (SDef) >= 'A' + or else TDef (SDef) = ASCII.ESC + loop + Add_Char_To_Name_Buffer (TDef (SDef)); + SDef := SDef + 1; + end loop; + end Write_Entity_Name; + + -- Start of processing for Expand_Source_Info + + begin + -- Integer cases + + if Nam = Name_Line then + Rewrite (N, + Make_Integer_Literal (Loc, + Intval => UI_From_Int (Int (Get_Logical_Line_Number (Loc))))); + Analyze_And_Resolve (N, Standard_Positive); + + -- String cases + + else + Name_Len := 0; + + case Nam is + when Name_File => + Get_Decoded_Name_String + (Reference_Name (Get_Source_File_Index (Loc))); + + when Name_Source_Location => + Build_Location_String (Loc); + + when Name_Enclosing_Entity => + + -- Skip enclosing blocks to reach enclosing unit + + Ent := Current_Scope; + while Present (Ent) loop + exit when Ekind (Ent) /= E_Block + and then Ekind (Ent) /= E_Loop; + Ent := Scope (Ent); + end loop; + + -- Ent now points to the relevant defining entity + + Write_Entity_Name (Ent); + + when others => + raise Program_Error; + end case; + + Rewrite (N, + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer)); + Analyze_And_Resolve (N, Standard_String); + end if; + + Set_Is_Static_Expression (N); + end Expand_Source_Info; + + --------------------------- + -- Expand_Unc_Conversion -- + --------------------------- + + procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id) is + Func : constant Entity_Id := Entity (Name (N)); + Conv : Node_Id; + Ftyp : Entity_Id; + Ttyp : Entity_Id; + + begin + -- Rewrite as unchecked conversion node. Note that we must convert + -- the operand to the formal type of the input parameter of the + -- function, so that the resulting N_Unchecked_Type_Conversion + -- call indicates the correct types for Gigi. + + -- Right now, we only do this if a scalar type is involved. It is + -- not clear if it is needed in other cases. If we do attempt to + -- do the conversion unconditionally, it crashes 3411-018. To be + -- investigated further ??? + + Conv := Relocate_Node (First_Actual (N)); + Ftyp := Etype (First_Formal (Func)); + + if Is_Scalar_Type (Ftyp) then + Conv := Convert_To (Ftyp, Conv); + Set_Parent (Conv, N); + Analyze_And_Resolve (Conv); + end if; + + -- The instantiation of Unchecked_Conversion creates a wrapper package, + -- and the target type is declared as a subtype of the actual. Recover + -- the actual, which is the subtype indic. in the subtype declaration + -- for the target type. This is semantically correct, and avoids + -- anomalies with access subtypes. For entities, leave type as is. + + -- We do the analysis here, because we do not want the compiler + -- to try to optimize or otherwise reorganize the unchecked + -- conversion node. + + Ttyp := Etype (E); + + if Is_Entity_Name (Conv) then + null; + + elsif Nkind (Parent (Ttyp)) = N_Subtype_Declaration then + Ttyp := Entity (Subtype_Indication (Parent (Etype (E)))); + + elsif Is_Itype (Ttyp) then + Ttyp := + Entity (Subtype_Indication (Associated_Node_For_Itype (Ttyp))); + else + raise Program_Error; + end if; + + Rewrite (N, Unchecked_Convert_To (Ttyp, Conv)); + Set_Etype (N, Ttyp); + Set_Analyzed (N); + + if Nkind (N) = N_Unchecked_Type_Conversion then + Expand_N_Unchecked_Type_Conversion (N); + end if; + end Expand_Unc_Conversion; + + ----------------------------- + -- Expand_Unc_Deallocation -- + ----------------------------- + + -- Generate the following Code : + + -- if Arg /= null then + -- (.., T'Class(Arg.all), ..); -- for controlled types + -- Free (Arg); + -- Arg := Null; + -- end if; + + -- For a task, we also generate a call to Free_Task to ensure that the + -- task itself is freed if it is terminated, ditto for a simple protected + -- object, with a call to Finalize_Protection. For composite types that + -- have tasks or simple protected objects as components, we traverse the + -- structures to find and terminate those components. + + procedure Expand_Unc_Deallocation (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Arg : constant Node_Id := First_Actual (N); + Typ : constant Entity_Id := Etype (Arg); + Stmts : constant List_Id := New_List; + Rtyp : constant Entity_Id := Underlying_Type (Root_Type (Typ)); + Pool : constant Entity_Id := Associated_Storage_Pool (Rtyp); + + Desig_T : constant Entity_Id := Designated_Type (Typ); + Gen_Code : Node_Id; + Free_Node : Node_Id; + Deref : Node_Id; + Free_Arg : Node_Id; + Free_Cod : List_Id; + Blk : Node_Id; + + Arg_Known_Non_Null : constant Boolean := Known_Non_Null (N); + -- This captures whether we know the argument to be non-null so that + -- we can avoid the test. The reason that we need to capture this is + -- that we analyze some generated statements before properly attaching + -- them to the tree, and that can disturb current value settings. + + begin + -- Nothing to do if we know the argument is null + + if Known_Null (N) then + return; + end if; + + -- Processing for pointer to controlled type + + if Needs_Finalization (Desig_T) then + Deref := + Make_Explicit_Dereference (Loc, + Prefix => Duplicate_Subexpr_No_Checks (Arg)); + + -- If the type is tagged, then we must force dispatching on the + -- finalization call because the designated type may not be the + -- actual type of the object. + + if Is_Tagged_Type (Desig_T) + and then not Is_Class_Wide_Type (Desig_T) + then + Deref := Unchecked_Convert_To (Class_Wide_Type (Desig_T), Deref); + + elsif not Is_Tagged_Type (Desig_T) then + + -- Set type of result, to force a conversion when needed (see + -- exp_ch7, Convert_View), given that Deep_Finalize may be + -- inherited from the parent type, and we need the type of the + -- expression to see whether the conversion is in fact needed. + + Set_Etype (Deref, Desig_T); + end if; + + Free_Cod := + Make_Final_Call + (Ref => Deref, + Typ => Desig_T, + With_Detach => New_Reference_To (Standard_True, Loc)); + + if Abort_Allowed then + Prepend_To (Free_Cod, + Build_Runtime_Call (Loc, RE_Abort_Defer)); + + Blk := + Make_Block_Statement (Loc, Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Free_Cod, + At_End_Proc => + New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc))); + + -- We now expand the exception (at end) handler. We set a + -- temporary parent pointer since we have not attached Blk + -- to the tree yet. + + Set_Parent (Blk, N); + Analyze (Blk); + Expand_At_End_Handler + (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk))); + Append (Blk, Stmts); + + -- We kill saved current values, since analyzing statements not + -- properly attached to the tree can set wrong current values. + + Kill_Current_Values; + + else + Append_List_To (Stmts, Free_Cod); + end if; + end if; + + -- For a task type, call Free_Task before freeing the ATCB + + if Is_Task_Type (Desig_T) then + declare + Stat : Node_Id := Prev (N); + Nam1 : Node_Id; + Nam2 : Node_Id; + + begin + -- An Abort followed by a Free will not do what the user + -- expects, because the abort is not immediate. This is + -- worth a friendly warning. + + while Present (Stat) + and then not Comes_From_Source (Original_Node (Stat)) + loop + Prev (Stat); + end loop; + + if Present (Stat) + and then Nkind (Original_Node (Stat)) = N_Abort_Statement + then + Stat := Original_Node (Stat); + Nam1 := First (Names (Stat)); + Nam2 := Original_Node (First (Parameter_Associations (N))); + + if Nkind (Nam1) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Nam1)) + and then Is_Entity_Name (Nam2) + and then Entity (Prefix (Nam1)) = Entity (Nam2) + then + Error_Msg_N ("abort may take time to complete?", N); + Error_Msg_N ("\deallocation might have no effect?", N); + Error_Msg_N ("\safer to wait for termination.?", N); + end if; + end if; + end; + + Append_To + (Stmts, Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg))); + + -- For composite types that contain tasks, recurse over the structure + -- to build the selectors for the task subcomponents. + + elsif Has_Task (Desig_T) then + if Is_Record_Type (Desig_T) then + Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T)); + + elsif Is_Array_Type (Desig_T) then + Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T)); + end if; + end if; + + -- Same for simple protected types. Eventually call Finalize_Protection + -- before freeing the PO for each protected component. + + if Is_Simple_Protected_Type (Desig_T) then + Append_To (Stmts, + Cleanup_Protected_Object (N, Duplicate_Subexpr_No_Checks (Arg))); + + elsif Has_Simple_Protected_Object (Desig_T) then + if Is_Record_Type (Desig_T) then + Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T)); + elsif Is_Array_Type (Desig_T) then + Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T)); + end if; + end if; + + -- Normal processing for non-controlled types + + Free_Arg := Duplicate_Subexpr_No_Checks (Arg); + Free_Node := Make_Free_Statement (Loc, Empty); + Append_To (Stmts, Free_Node); + Set_Storage_Pool (Free_Node, Pool); + + -- Attach to tree before analysis of generated subtypes below. + + Set_Parent (Stmts, Parent (N)); + + -- Deal with storage pool + + if Present (Pool) then + + -- Freeing the secondary stack is meaningless + + if Is_RTE (Pool, RE_SS_Pool) then + null; + + elsif Is_Class_Wide_Type (Etype (Pool)) then + + -- Case of a class-wide pool type: make a dispatching call + -- to Deallocate through the class-wide Deallocate_Any. + + Set_Procedure_To_Call (Free_Node, + RTE (RE_Deallocate_Any)); + + else + -- Case of a specific pool type: make a statically bound call + + Set_Procedure_To_Call (Free_Node, + Find_Prim_Op (Etype (Pool), Name_Deallocate)); + end if; + end if; + + if Present (Procedure_To_Call (Free_Node)) then + + -- For all cases of a Deallocate call, the back-end needs to be + -- able to compute the size of the object being freed. This may + -- require some adjustments for objects of dynamic size. + -- + -- If the type is class wide, we generate an implicit type with the + -- right dynamic size, so that the deallocate call gets the right + -- size parameter computed by GIGI. Same for an access to + -- unconstrained packed array. + + if Is_Class_Wide_Type (Desig_T) + or else + (Is_Array_Type (Desig_T) + and then not Is_Constrained (Desig_T) + and then Is_Packed (Desig_T)) + then + declare + Deref : constant Node_Id := + Make_Explicit_Dereference (Loc, + Duplicate_Subexpr_No_Checks (Arg)); + D_Subtyp : Node_Id; + D_Type : Entity_Id; + + begin + Set_Etype (Deref, Typ); + Set_Parent (Deref, Free_Node); + D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_T); + + if Nkind (D_Subtyp) in N_Has_Entity then + D_Type := Entity (D_Subtyp); + + else + D_Type := Make_Temporary (Loc, 'A'); + Insert_Action (Deref, + Make_Subtype_Declaration (Loc, + Defining_Identifier => D_Type, + Subtype_Indication => D_Subtyp)); + end if; + + -- Force freezing at the point of the dereference. For the + -- class wide case, this avoids having the subtype frozen + -- before the equivalent type. + + Freeze_Itype (D_Type, Deref); + + Set_Actual_Designated_Subtype (Free_Node, D_Type); + end; + + end if; + end if; + + -- Ada 2005 (AI-251): In case of abstract interface type we must + -- displace the pointer to reference the base of the object to + -- deallocate its memory, unless we're targetting a VM, in which case + -- no special processing is required. + + -- Generate: + -- free (Base_Address (Obj_Ptr)) + + if Is_Interface (Directly_Designated_Type (Typ)) + and then Tagged_Type_Expansion + then + Set_Expression (Free_Node, + Unchecked_Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Base_Address), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), Free_Arg))))); + + -- Generate: + -- free (Obj_Ptr) + + else + Set_Expression (Free_Node, Free_Arg); + end if; + + -- Only remaining step is to set result to null, or generate a + -- raise of constraint error if the target object is "not null". + + if Can_Never_Be_Null (Etype (Arg)) then + Append_To (Stmts, + Make_Raise_Constraint_Error (Loc, + Reason => CE_Access_Check_Failed)); + + else + declare + Lhs : constant Node_Id := Duplicate_Subexpr_No_Checks (Arg); + begin + Set_Assignment_OK (Lhs); + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Lhs, + Expression => Make_Null (Loc))); + end; + end if; + + -- If we know the argument is non-null, then make a block statement + -- that contains the required statements, no need for a test. + + if Arg_Known_Non_Null then + Gen_Code := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + + -- If the argument may be null, wrap the statements inside an IF that + -- does an explicit test to exclude the null case. + + else + Gen_Code := + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => Duplicate_Subexpr (Arg), + Right_Opnd => Make_Null (Loc)), + Then_Statements => Stmts); + end if; + + -- Rewrite the call + + Rewrite (N, Gen_Code); + Analyze (N); + end Expand_Unc_Deallocation; + + ----------------------- + -- Expand_To_Address -- + ----------------------- + + procedure Expand_To_Address (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Arg : constant Node_Id := First_Actual (N); + Obj : Node_Id; + + begin + Remove_Side_Effects (Arg); + + Obj := Make_Explicit_Dereference (Loc, Relocate_Node (Arg)); + + Rewrite (N, + Make_Conditional_Expression (Loc, + Expressions => New_List ( + Make_Op_Eq (Loc, + Left_Opnd => New_Copy_Tree (Arg), + Right_Opnd => Make_Null (Loc)), + New_Occurrence_Of (RTE (RE_Null_Address), Loc), + Make_Attribute_Reference (Loc, + Prefix => Obj, + Attribute_Name => Name_Address)))); + + Analyze_And_Resolve (N, RTE (RE_Address)); + end Expand_To_Address; + + ----------------------- + -- Expand_To_Pointer -- + ----------------------- + + procedure Expand_To_Pointer (N : Node_Id) is + Arg : constant Node_Id := First_Actual (N); + + begin + Rewrite (N, Unchecked_Convert_To (Etype (N), Arg)); + Analyze (N); + end Expand_To_Pointer; + +end Exp_Intr; diff --git a/gcc/ada/exp_intr.ads b/gcc/ada/exp_intr.ads new file mode 100644 index 000000000..a9d8a3919 --- /dev/null +++ b/gcc/ada/exp_intr.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ I N T 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Processing for expanding intrinsic subprogram calls + +with Types; use Types; + +package Exp_Intr is + + procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id); + -- N is either a function call node, a procedure call statement node, or + -- an operator where the corresponding subprogram is intrinsic (i.e. was + -- the subject of a Import or Interface pragma specifying the subprogram + -- as intrinsic. The effect is to replace the call with appropriate + -- specialized nodes. The second argument is the entity for the + -- subprogram spec. + +end Exp_Intr; diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb new file mode 100644 index 000000000..4d3ea0688 --- /dev/null +++ b/gcc/ada/exp_pakd.adb @@ -0,0 +1,2744 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ P A K D -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Einfo; use Einfo; +with Errout; use Errout; +with Exp_Dbug; use Exp_Dbug; +with Exp_Util; use Exp_Util; +with Layout; use Layout; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch13; use Sem_Ch13; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; + +package body Exp_Pakd is + + --------------------------- + -- Endian Considerations -- + --------------------------- + + -- As described in the specification, bit numbering in a packed array + -- is consistent with bit numbering in a record representation clause, + -- and hence dependent on the endianness of the machine: + + -- For little-endian machines, element zero is at the right hand end + -- (low order end) of a bit field. + + -- For big-endian machines, element zero is at the left hand end + -- (high order end) of a bit field. + + -- The shifts that are used to right justify a field therefore differ in + -- the two cases. For the little-endian case, we can simply use the bit + -- number (i.e. the element number * element size) as the count for a right + -- shift. For the big-endian case, we have to subtract the shift count from + -- an appropriate constant to use in the right shift. We use rotates + -- instead of shifts (which is necessary in the store case to preserve + -- other fields), and we expect that the backend will be able to change the + -- right rotate into a left rotate, avoiding the subtract, if the machine + -- architecture provides such an instruction. + + ---------------------------------------------- + -- Entity Tables for Packed Access Routines -- + ---------------------------------------------- + + -- For the cases of component size = 3,5-7,9-15,17-31,33-63 we call library + -- routines. This table provides the entity for the proper routine. + + type E_Array is array (Int range 01 .. 63) of RE_Id; + + -- Array of Bits_nn entities. Note that we do not use library routines + -- for the 8-bit and 16-bit cases, but we still fill in the table, using + -- entries from System.Unsigned, because we also use this table for + -- certain special unchecked conversions in the big-endian case. + + Bits_Id : constant E_Array := + (01 => RE_Bits_1, + 02 => RE_Bits_2, + 03 => RE_Bits_03, + 04 => RE_Bits_4, + 05 => RE_Bits_05, + 06 => RE_Bits_06, + 07 => RE_Bits_07, + 08 => RE_Unsigned_8, + 09 => RE_Bits_09, + 10 => RE_Bits_10, + 11 => RE_Bits_11, + 12 => RE_Bits_12, + 13 => RE_Bits_13, + 14 => RE_Bits_14, + 15 => RE_Bits_15, + 16 => RE_Unsigned_16, + 17 => RE_Bits_17, + 18 => RE_Bits_18, + 19 => RE_Bits_19, + 20 => RE_Bits_20, + 21 => RE_Bits_21, + 22 => RE_Bits_22, + 23 => RE_Bits_23, + 24 => RE_Bits_24, + 25 => RE_Bits_25, + 26 => RE_Bits_26, + 27 => RE_Bits_27, + 28 => RE_Bits_28, + 29 => RE_Bits_29, + 30 => RE_Bits_30, + 31 => RE_Bits_31, + 32 => RE_Unsigned_32, + 33 => RE_Bits_33, + 34 => RE_Bits_34, + 35 => RE_Bits_35, + 36 => RE_Bits_36, + 37 => RE_Bits_37, + 38 => RE_Bits_38, + 39 => RE_Bits_39, + 40 => RE_Bits_40, + 41 => RE_Bits_41, + 42 => RE_Bits_42, + 43 => RE_Bits_43, + 44 => RE_Bits_44, + 45 => RE_Bits_45, + 46 => RE_Bits_46, + 47 => RE_Bits_47, + 48 => RE_Bits_48, + 49 => RE_Bits_49, + 50 => RE_Bits_50, + 51 => RE_Bits_51, + 52 => RE_Bits_52, + 53 => RE_Bits_53, + 54 => RE_Bits_54, + 55 => RE_Bits_55, + 56 => RE_Bits_56, + 57 => RE_Bits_57, + 58 => RE_Bits_58, + 59 => RE_Bits_59, + 60 => RE_Bits_60, + 61 => RE_Bits_61, + 62 => RE_Bits_62, + 63 => RE_Bits_63); + + -- Array of Get routine entities. These are used to obtain an element from + -- a packed array. The N'th entry is used to obtain elements from a packed + -- array whose component size is N. RE_Null is used as a null entry, for + -- the cases where a library routine is not used. + + Get_Id : constant E_Array := + (01 => RE_Null, + 02 => RE_Null, + 03 => RE_Get_03, + 04 => RE_Null, + 05 => RE_Get_05, + 06 => RE_Get_06, + 07 => RE_Get_07, + 08 => RE_Null, + 09 => RE_Get_09, + 10 => RE_Get_10, + 11 => RE_Get_11, + 12 => RE_Get_12, + 13 => RE_Get_13, + 14 => RE_Get_14, + 15 => RE_Get_15, + 16 => RE_Null, + 17 => RE_Get_17, + 18 => RE_Get_18, + 19 => RE_Get_19, + 20 => RE_Get_20, + 21 => RE_Get_21, + 22 => RE_Get_22, + 23 => RE_Get_23, + 24 => RE_Get_24, + 25 => RE_Get_25, + 26 => RE_Get_26, + 27 => RE_Get_27, + 28 => RE_Get_28, + 29 => RE_Get_29, + 30 => RE_Get_30, + 31 => RE_Get_31, + 32 => RE_Null, + 33 => RE_Get_33, + 34 => RE_Get_34, + 35 => RE_Get_35, + 36 => RE_Get_36, + 37 => RE_Get_37, + 38 => RE_Get_38, + 39 => RE_Get_39, + 40 => RE_Get_40, + 41 => RE_Get_41, + 42 => RE_Get_42, + 43 => RE_Get_43, + 44 => RE_Get_44, + 45 => RE_Get_45, + 46 => RE_Get_46, + 47 => RE_Get_47, + 48 => RE_Get_48, + 49 => RE_Get_49, + 50 => RE_Get_50, + 51 => RE_Get_51, + 52 => RE_Get_52, + 53 => RE_Get_53, + 54 => RE_Get_54, + 55 => RE_Get_55, + 56 => RE_Get_56, + 57 => RE_Get_57, + 58 => RE_Get_58, + 59 => RE_Get_59, + 60 => RE_Get_60, + 61 => RE_Get_61, + 62 => RE_Get_62, + 63 => RE_Get_63); + + -- Array of Get routine entities to be used in the case where the packed + -- array is itself a component of a packed structure, and therefore may not + -- be fully aligned. This only affects the even sizes, since for the odd + -- sizes, we do not get any fixed alignment in any case. + + GetU_Id : constant E_Array := + (01 => RE_Null, + 02 => RE_Null, + 03 => RE_Get_03, + 04 => RE_Null, + 05 => RE_Get_05, + 06 => RE_GetU_06, + 07 => RE_Get_07, + 08 => RE_Null, + 09 => RE_Get_09, + 10 => RE_GetU_10, + 11 => RE_Get_11, + 12 => RE_GetU_12, + 13 => RE_Get_13, + 14 => RE_GetU_14, + 15 => RE_Get_15, + 16 => RE_Null, + 17 => RE_Get_17, + 18 => RE_GetU_18, + 19 => RE_Get_19, + 20 => RE_GetU_20, + 21 => RE_Get_21, + 22 => RE_GetU_22, + 23 => RE_Get_23, + 24 => RE_GetU_24, + 25 => RE_Get_25, + 26 => RE_GetU_26, + 27 => RE_Get_27, + 28 => RE_GetU_28, + 29 => RE_Get_29, + 30 => RE_GetU_30, + 31 => RE_Get_31, + 32 => RE_Null, + 33 => RE_Get_33, + 34 => RE_GetU_34, + 35 => RE_Get_35, + 36 => RE_GetU_36, + 37 => RE_Get_37, + 38 => RE_GetU_38, + 39 => RE_Get_39, + 40 => RE_GetU_40, + 41 => RE_Get_41, + 42 => RE_GetU_42, + 43 => RE_Get_43, + 44 => RE_GetU_44, + 45 => RE_Get_45, + 46 => RE_GetU_46, + 47 => RE_Get_47, + 48 => RE_GetU_48, + 49 => RE_Get_49, + 50 => RE_GetU_50, + 51 => RE_Get_51, + 52 => RE_GetU_52, + 53 => RE_Get_53, + 54 => RE_GetU_54, + 55 => RE_Get_55, + 56 => RE_GetU_56, + 57 => RE_Get_57, + 58 => RE_GetU_58, + 59 => RE_Get_59, + 60 => RE_GetU_60, + 61 => RE_Get_61, + 62 => RE_GetU_62, + 63 => RE_Get_63); + + -- Array of Set routine entities. These are used to assign an element of a + -- packed array. The N'th entry is used to assign elements for a packed + -- array whose component size is N. RE_Null is used as a null entry, for + -- the cases where a library routine is not used. + + Set_Id : constant E_Array := + (01 => RE_Null, + 02 => RE_Null, + 03 => RE_Set_03, + 04 => RE_Null, + 05 => RE_Set_05, + 06 => RE_Set_06, + 07 => RE_Set_07, + 08 => RE_Null, + 09 => RE_Set_09, + 10 => RE_Set_10, + 11 => RE_Set_11, + 12 => RE_Set_12, + 13 => RE_Set_13, + 14 => RE_Set_14, + 15 => RE_Set_15, + 16 => RE_Null, + 17 => RE_Set_17, + 18 => RE_Set_18, + 19 => RE_Set_19, + 20 => RE_Set_20, + 21 => RE_Set_21, + 22 => RE_Set_22, + 23 => RE_Set_23, + 24 => RE_Set_24, + 25 => RE_Set_25, + 26 => RE_Set_26, + 27 => RE_Set_27, + 28 => RE_Set_28, + 29 => RE_Set_29, + 30 => RE_Set_30, + 31 => RE_Set_31, + 32 => RE_Null, + 33 => RE_Set_33, + 34 => RE_Set_34, + 35 => RE_Set_35, + 36 => RE_Set_36, + 37 => RE_Set_37, + 38 => RE_Set_38, + 39 => RE_Set_39, + 40 => RE_Set_40, + 41 => RE_Set_41, + 42 => RE_Set_42, + 43 => RE_Set_43, + 44 => RE_Set_44, + 45 => RE_Set_45, + 46 => RE_Set_46, + 47 => RE_Set_47, + 48 => RE_Set_48, + 49 => RE_Set_49, + 50 => RE_Set_50, + 51 => RE_Set_51, + 52 => RE_Set_52, + 53 => RE_Set_53, + 54 => RE_Set_54, + 55 => RE_Set_55, + 56 => RE_Set_56, + 57 => RE_Set_57, + 58 => RE_Set_58, + 59 => RE_Set_59, + 60 => RE_Set_60, + 61 => RE_Set_61, + 62 => RE_Set_62, + 63 => RE_Set_63); + + -- Array of Set routine entities to be used in the case where the packed + -- array is itself a component of a packed structure, and therefore may not + -- be fully aligned. This only affects the even sizes, since for the odd + -- sizes, we do not get any fixed alignment in any case. + + SetU_Id : constant E_Array := + (01 => RE_Null, + 02 => RE_Null, + 03 => RE_Set_03, + 04 => RE_Null, + 05 => RE_Set_05, + 06 => RE_SetU_06, + 07 => RE_Set_07, + 08 => RE_Null, + 09 => RE_Set_09, + 10 => RE_SetU_10, + 11 => RE_Set_11, + 12 => RE_SetU_12, + 13 => RE_Set_13, + 14 => RE_SetU_14, + 15 => RE_Set_15, + 16 => RE_Null, + 17 => RE_Set_17, + 18 => RE_SetU_18, + 19 => RE_Set_19, + 20 => RE_SetU_20, + 21 => RE_Set_21, + 22 => RE_SetU_22, + 23 => RE_Set_23, + 24 => RE_SetU_24, + 25 => RE_Set_25, + 26 => RE_SetU_26, + 27 => RE_Set_27, + 28 => RE_SetU_28, + 29 => RE_Set_29, + 30 => RE_SetU_30, + 31 => RE_Set_31, + 32 => RE_Null, + 33 => RE_Set_33, + 34 => RE_SetU_34, + 35 => RE_Set_35, + 36 => RE_SetU_36, + 37 => RE_Set_37, + 38 => RE_SetU_38, + 39 => RE_Set_39, + 40 => RE_SetU_40, + 41 => RE_Set_41, + 42 => RE_SetU_42, + 43 => RE_Set_43, + 44 => RE_SetU_44, + 45 => RE_Set_45, + 46 => RE_SetU_46, + 47 => RE_Set_47, + 48 => RE_SetU_48, + 49 => RE_Set_49, + 50 => RE_SetU_50, + 51 => RE_Set_51, + 52 => RE_SetU_52, + 53 => RE_Set_53, + 54 => RE_SetU_54, + 55 => RE_Set_55, + 56 => RE_SetU_56, + 57 => RE_Set_57, + 58 => RE_SetU_58, + 59 => RE_Set_59, + 60 => RE_SetU_60, + 61 => RE_Set_61, + 62 => RE_SetU_62, + 63 => RE_Set_63); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Compute_Linear_Subscript + (Atyp : Entity_Id; + N : Node_Id; + Subscr : out Node_Id); + -- Given a constrained array type Atyp, and an indexed component node N + -- referencing an array object of this type, build an expression of type + -- Standard.Integer representing the zero-based linear subscript value. + -- This expression includes any required range checks. + + procedure Convert_To_PAT_Type (Aexp : Node_Id); + -- Given an expression of a packed array type, builds a corresponding + -- expression whose type is the implementation type used to represent + -- the packed array. Aexp is analyzed and resolved on entry and on exit. + + procedure Get_Base_And_Bit_Offset + (N : Node_Id; + Base : out Node_Id; + Offset : out Node_Id); + -- Given a node N for a name which involves a packed array reference, + -- return the base object of the reference and build an expression of + -- type Standard.Integer representing the zero-based offset in bits + -- from Base'Address to the first bit of the reference. + + function Known_Aligned_Enough (Obj : Node_Id; Csiz : Nat) return Boolean; + -- There are two versions of the Set routines, the ones used when the + -- object is known to be sufficiently well aligned given the number of + -- bits, and the ones used when the object is not known to be aligned. + -- This routine is used to determine which set to use. Obj is a reference + -- to the object, and Csiz is the component size of the packed array. + -- True is returned if the alignment of object is known to be sufficient, + -- defined as 1 for odd bit sizes, 4 for bit sizes divisible by 4, and + -- 2 otherwise. + + function Make_Shift_Left (N : Node_Id; S : Node_Id) return Node_Id; + -- Build a left shift node, checking for the case of a shift count of zero + + function Make_Shift_Right (N : Node_Id; S : Node_Id) return Node_Id; + -- Build a right shift node, checking for the case of a shift count of zero + + function RJ_Unchecked_Convert_To + (Typ : Entity_Id; + Expr : Node_Id) return Node_Id; + -- The packed array code does unchecked conversions which in some cases + -- may involve non-discrete types with differing sizes. The semantics of + -- such conversions is potentially endian dependent, and the effect we + -- want here for such a conversion is to do the conversion in size as + -- though numeric items are involved, and we extend or truncate on the + -- left side. This happens naturally in the little-endian case, but in + -- the big endian case we can get left justification, when what we want + -- is right justification. This routine does the unchecked conversion in + -- a stepwise manner to ensure that it gives the expected result. Hence + -- the name (RJ = Right justified). The parameters Typ and Expr are as + -- for the case of a normal Unchecked_Convert_To call. + + procedure Setup_Enumeration_Packed_Array_Reference (N : Node_Id); + -- This routine is called in the Get and Set case for arrays that are + -- packed but not bit-packed, meaning that they have at least one + -- subscript that is of an enumeration type with a non-standard + -- representation. This routine modifies the given node to properly + -- reference the corresponding packed array type. + + procedure Setup_Inline_Packed_Array_Reference + (N : Node_Id; + Atyp : Entity_Id; + Obj : in out Node_Id; + Cmask : out Uint; + Shift : out Node_Id); + -- This procedure performs common processing on the N_Indexed_Component + -- parameter given as N, whose prefix is a reference to a packed array. + -- This is used for the get and set when the component size is 1,2,4 + -- or for other component sizes when the packed array type is a modular + -- type (i.e. the cases that are handled with inline code). + -- + -- On entry: + -- + -- N is the N_Indexed_Component node for the packed array reference + -- + -- Atyp is the constrained array type (the actual subtype has been + -- computed if necessary to obtain the constraints, but this is still + -- the original array type, not the Packed_Array_Type value). + -- + -- Obj is the object which is to be indexed. It is always of type Atyp. + -- + -- On return: + -- + -- Obj is the object containing the desired bit field. It is of type + -- Unsigned, Long_Unsigned, or Long_Long_Unsigned, and is either the + -- entire value, for the small static case, or the proper selected byte + -- from the array in the large or dynamic case. This node is analyzed + -- and resolved on return. + -- + -- Shift is a node representing the shift count to be used in the + -- rotate right instruction that positions the field for access. + -- This node is analyzed and resolved on return. + -- + -- Cmask is a mask corresponding to the width of the component field. + -- Its value is 2 ** Csize - 1 (e.g. 2#1111# for component size of 4). + -- + -- Note: in some cases the call to this routine may generate actions + -- (for handling multi-use references and the generation of the packed + -- array type on the fly). Such actions are inserted into the tree + -- directly using Insert_Action. + + ------------------------------ + -- Compute_Linear_Subscript -- + ------------------------------ + + procedure Compute_Linear_Subscript + (Atyp : Entity_Id; + N : Node_Id; + Subscr : out Node_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Oldsub : Node_Id; + Newsub : Node_Id; + Indx : Node_Id; + Styp : Entity_Id; + + begin + Subscr := Empty; + + -- Loop through dimensions + + Indx := First_Index (Atyp); + Oldsub := First (Expressions (N)); + + while Present (Indx) loop + Styp := Etype (Indx); + Newsub := Relocate_Node (Oldsub); + + -- Get expression for the subscript value. First, if Do_Range_Check + -- is set on a subscript, then we must do a range check against the + -- original bounds (not the bounds of the packed array type). We do + -- this by introducing a subtype conversion. + + if Do_Range_Check (Newsub) + and then Etype (Newsub) /= Styp + then + Newsub := Convert_To (Styp, Newsub); + end if; + + -- Now evolve the expression for the subscript. First convert + -- the subscript to be zero based and of an integer type. + + -- Case of integer type, where we just subtract to get lower bound + + if Is_Integer_Type (Styp) then + + -- If length of integer type is smaller than standard integer, + -- then we convert to integer first, then do the subtract + + -- Integer (subscript) - Integer (Styp'First) + + if Esize (Styp) < Esize (Standard_Integer) then + Newsub := + Make_Op_Subtract (Loc, + Left_Opnd => Convert_To (Standard_Integer, Newsub), + Right_Opnd => + Convert_To (Standard_Integer, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Styp, Loc), + Attribute_Name => Name_First))); + + -- For larger integer types, subtract first, then convert to + -- integer, this deals with strange long long integer bounds. + + -- Integer (subscript - Styp'First) + + else + Newsub := + Convert_To (Standard_Integer, + Make_Op_Subtract (Loc, + Left_Opnd => Newsub, + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Styp, Loc), + Attribute_Name => Name_First))); + end if; + + -- For the enumeration case, we have to use 'Pos to get the value + -- to work with before subtracting the lower bound. + + -- Integer (Styp'Pos (subscr)) - Integer (Styp'Pos (Styp'First)); + + -- This is not quite right for bizarre cases where the size of the + -- enumeration type is > Integer'Size bits due to rep clause ??? + + else + pragma Assert (Is_Enumeration_Type (Styp)); + + Newsub := + Make_Op_Subtract (Loc, + Left_Opnd => Convert_To (Standard_Integer, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Styp, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List (Newsub))), + + Right_Opnd => + Convert_To (Standard_Integer, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Styp, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Styp, Loc), + Attribute_Name => Name_First))))); + end if; + + Set_Paren_Count (Newsub, 1); + + -- For the first subscript, we just copy that subscript value + + if No (Subscr) then + Subscr := Newsub; + + -- Otherwise, we must multiply what we already have by the current + -- stride and then add in the new value to the evolving subscript. + + else + Subscr := + Make_Op_Add (Loc, + Left_Opnd => + Make_Op_Multiply (Loc, + Left_Opnd => Subscr, + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Range_Length, + Prefix => New_Occurrence_Of (Styp, Loc))), + Right_Opnd => Newsub); + end if; + + -- Move to next subscript + + Next_Index (Indx); + Next (Oldsub); + end loop; + end Compute_Linear_Subscript; + + ------------------------- + -- Convert_To_PAT_Type -- + ------------------------- + + -- The PAT is always obtained from the actual subtype + + procedure Convert_To_PAT_Type (Aexp : Node_Id) is + Act_ST : Entity_Id; + + begin + Convert_To_Actual_Subtype (Aexp); + Act_ST := Underlying_Type (Etype (Aexp)); + Create_Packed_Array_Type (Act_ST); + + -- Just replace the etype with the packed array type. This works because + -- the expression will not be further analyzed, and Gigi considers the + -- two types equivalent in any case. + + -- This is not strictly the case ??? If the reference is an actual in + -- call, the expansion of the prefix is delayed, and must be reanalyzed, + -- see Reset_Packed_Prefix. On the other hand, if the prefix is a simple + -- array reference, reanalysis can produce spurious type errors when the + -- PAT type is replaced again with the original type of the array. Same + -- for the case of a dereference. The following is correct and minimal, + -- but the handling of more complex packed expressions in actuals is + -- confused. Probably the problem only remains for actuals in calls. + + Set_Etype (Aexp, Packed_Array_Type (Act_ST)); + + if Is_Entity_Name (Aexp) + or else + (Nkind (Aexp) = N_Indexed_Component + and then Is_Entity_Name (Prefix (Aexp))) + or else Nkind (Aexp) = N_Explicit_Dereference + then + Set_Analyzed (Aexp); + end if; + end Convert_To_PAT_Type; + + ------------------------------ + -- Create_Packed_Array_Type -- + ------------------------------ + + procedure Create_Packed_Array_Type (Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); + Ctyp : constant Entity_Id := Component_Type (Typ); + Csize : constant Uint := Component_Size (Typ); + + Ancest : Entity_Id; + PB_Type : Entity_Id; + PASize : Uint; + Decl : Node_Id; + PAT : Entity_Id; + Len_Dim : Node_Id; + Len_Expr : Node_Id; + Len_Bits : Uint; + Bits_U1 : Node_Id; + PAT_High : Node_Id; + Btyp : Entity_Id; + Lit : Node_Id; + + procedure Install_PAT; + -- This procedure is called with Decl set to the declaration for the + -- packed array type. It creates the type and installs it as required. + + procedure Set_PB_Type; + -- Sets PB_Type to Packed_Bytes{1,2,4} as required by the alignment + -- requirements (see documentation in the spec of this package). + + ----------------- + -- Install_PAT -- + ----------------- + + procedure Install_PAT is + Pushed_Scope : Boolean := False; + + begin + -- We do not want to put the declaration we have created in the tree + -- since it is often hard, and sometimes impossible to find a proper + -- place for it (the impossible case arises for a packed array type + -- with bounds depending on the discriminant, a declaration cannot + -- be put inside the record, and the reference to the discriminant + -- cannot be outside the record). + + -- The solution is to analyze the declaration while temporarily + -- attached to the tree at an appropriate point, and then we install + -- the resulting type as an Itype in the packed array type field of + -- the original type, so that no explicit declaration is required. + + -- Note: the packed type is created in the scope of its parent + -- type. There are at least some cases where the current scope + -- is deeper, and so when this is the case, we temporarily reset + -- the scope for the definition. This is clearly safe, since the + -- first use of the packed array type will be the implicit + -- reference from the corresponding unpacked type when it is + -- elaborated. + + if Is_Itype (Typ) then + Set_Parent (Decl, Associated_Node_For_Itype (Typ)); + else + Set_Parent (Decl, Declaration_Node (Typ)); + end if; + + if Scope (Typ) /= Current_Scope then + Push_Scope (Scope (Typ)); + Pushed_Scope := True; + end if; + + Set_Is_Itype (PAT, True); + Set_Packed_Array_Type (Typ, PAT); + Analyze (Decl, Suppress => All_Checks); + + if Pushed_Scope then + Pop_Scope; + end if; + + -- Set Esize and RM_Size to the actual size of the packed object + -- Do not reset RM_Size if already set, as happens in the case of + -- a modular type. + + if Unknown_Esize (PAT) then + Set_Esize (PAT, PASize); + end if; + + if Unknown_RM_Size (PAT) then + Set_RM_Size (PAT, PASize); + end if; + + Adjust_Esize_Alignment (PAT); + + -- Set remaining fields of packed array type + + Init_Alignment (PAT); + Set_Parent (PAT, Empty); + Set_Associated_Node_For_Itype (PAT, Typ); + Set_Is_Packed_Array_Type (PAT, True); + Set_Original_Array_Type (PAT, Typ); + + -- We definitely do not want to delay freezing for packed array + -- types. This is of particular importance for the itypes that + -- are generated for record components depending on discriminants + -- where there is no place to put the freeze node. + + Set_Has_Delayed_Freeze (PAT, False); + Set_Has_Delayed_Freeze (Etype (PAT), False); + + -- If we did allocate a freeze node, then clear out the reference + -- since it is obsolete (should we delete the freeze node???) + + Set_Freeze_Node (PAT, Empty); + Set_Freeze_Node (Etype (PAT), Empty); + end Install_PAT; + + ----------------- + -- Set_PB_Type -- + ----------------- + + procedure Set_PB_Type is + begin + -- If the user has specified an explicit alignment for the + -- type or component, take it into account. + + if Csize <= 2 or else Csize = 4 or else Csize mod 2 /= 0 + or else Alignment (Typ) = 1 + or else Component_Alignment (Typ) = Calign_Storage_Unit + then + PB_Type := RTE (RE_Packed_Bytes1); + + elsif Csize mod 4 /= 0 + or else Alignment (Typ) = 2 + then + PB_Type := RTE (RE_Packed_Bytes2); + + else + PB_Type := RTE (RE_Packed_Bytes4); + end if; + end Set_PB_Type; + + -- Start of processing for Create_Packed_Array_Type + + begin + -- If we already have a packed array type, nothing to do + + if Present (Packed_Array_Type (Typ)) then + return; + end if; + + -- If our immediate ancestor subtype is constrained, and it already + -- has a packed array type, then just share the same type, since the + -- bounds must be the same. If the ancestor is not an array type but + -- a private type, as can happen with multiple instantiations, create + -- a new packed type, to avoid privacy issues. + + if Ekind (Typ) = E_Array_Subtype then + Ancest := Ancestor_Subtype (Typ); + + if Present (Ancest) + and then Is_Array_Type (Ancest) + and then Is_Constrained (Ancest) + and then Present (Packed_Array_Type (Ancest)) + then + Set_Packed_Array_Type (Typ, Packed_Array_Type (Ancest)); + return; + end if; + end if; + + -- We preset the result type size from the size of the original array + -- type, since this size clearly belongs to the packed array type. The + -- size of the conceptual unpacked type is always set to unknown. + + PASize := RM_Size (Typ); + + -- Case of an array where at least one index is of an enumeration + -- type with a non-standard representation, but the component size + -- is not appropriate for bit packing. This is the case where we + -- have Is_Packed set (we would never be in this unit otherwise), + -- but Is_Bit_Packed_Array is false. + + -- Note that if the component size is appropriate for bit packing, + -- then the circuit for the computation of the subscript properly + -- deals with the non-standard enumeration type case by taking the + -- Pos anyway. + + if not Is_Bit_Packed_Array (Typ) then + + -- Here we build a declaration: + + -- type tttP is array (index1, index2, ...) of component_type + + -- where index1, index2, are the index types. These are the same + -- as the index types of the original array, except for the non- + -- standard representation enumeration type case, where we have + -- two subcases. + + -- For the unconstrained array case, we use + + -- Natural range <> + + -- For the constrained case, we use + + -- Natural range Enum_Type'Pos (Enum_Type'First) .. + -- Enum_Type'Pos (Enum_Type'Last); + + PAT := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), 'P')); + + Set_Packed_Array_Type (Typ, PAT); + + declare + Indexes : constant List_Id := New_List; + Indx : Node_Id; + Indx_Typ : Entity_Id; + Enum_Case : Boolean; + Typedef : Node_Id; + + begin + Indx := First_Index (Typ); + + while Present (Indx) loop + Indx_Typ := Etype (Indx); + + Enum_Case := Is_Enumeration_Type (Indx_Typ) + and then Has_Non_Standard_Rep (Indx_Typ); + + -- Unconstrained case + + if not Is_Constrained (Typ) then + if Enum_Case then + Indx_Typ := Standard_Natural; + end if; + + Append_To (Indexes, New_Occurrence_Of (Indx_Typ, Loc)); + + -- Constrained case + + else + if not Enum_Case then + Append_To (Indexes, New_Occurrence_Of (Indx_Typ, Loc)); + + else + Append_To (Indexes, + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Standard_Natural, Loc), + Constraint => + Make_Range_Constraint (Loc, + Range_Expression => + Make_Range (Loc, + Low_Bound => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Indx_Typ, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Indx_Typ, Loc), + Attribute_Name => Name_First))), + + High_Bound => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Indx_Typ, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Indx_Typ, Loc), + Attribute_Name => Name_Last))))))); + + end if; + end if; + + Next_Index (Indx); + end loop; + + if not Is_Constrained (Typ) then + Typedef := + Make_Unconstrained_Array_Definition (Loc, + Subtype_Marks => Indexes, + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (Ctyp, Loc))); + + else + Typedef := + Make_Constrained_Array_Definition (Loc, + Discrete_Subtype_Definitions => Indexes, + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (Ctyp, Loc))); + end if; + + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => PAT, + Type_Definition => Typedef); + end; + + -- Set type as packed array type and install it + + Set_Is_Packed_Array_Type (PAT); + Install_PAT; + return; + + -- Case of bit-packing required for unconstrained array. We create + -- a subtype that is equivalent to use Packed_Bytes{1,2,4} as needed. + + elsif not Is_Constrained (Typ) then + PAT := + Make_Defining_Identifier (Loc, + Chars => Make_Packed_Array_Type_Name (Typ, Csize)); + + Set_Packed_Array_Type (Typ, PAT); + Set_PB_Type; + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => PAT, + Subtype_Indication => New_Occurrence_Of (PB_Type, Loc)); + Install_PAT; + return; + + -- Remaining code is for the case of bit-packing for constrained array + + -- The name of the packed array subtype is + + -- ttt___Xsss + + -- where sss is the component size in bits and ttt is the name of + -- the parent packed type. + + else + PAT := + Make_Defining_Identifier (Loc, + Chars => Make_Packed_Array_Type_Name (Typ, Csize)); + + Set_Packed_Array_Type (Typ, PAT); + + -- Build an expression for the length of the array in bits. + -- This is the product of the length of each of the dimensions + + declare + J : Nat := 1; + + begin + Len_Expr := Empty; -- suppress junk warning + + loop + Len_Dim := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => New_Occurrence_Of (Typ, Loc), + Expressions => New_List ( + Make_Integer_Literal (Loc, J))); + + if J = 1 then + Len_Expr := Len_Dim; + + else + Len_Expr := + Make_Op_Multiply (Loc, + Left_Opnd => Len_Expr, + Right_Opnd => Len_Dim); + end if; + + J := J + 1; + exit when J > Number_Dimensions (Typ); + end loop; + end; + + -- Temporarily attach the length expression to the tree and analyze + -- and resolve it, so that we can test its value. We assume that the + -- total length fits in type Integer. This expression may involve + -- discriminants, so we treat it as a default/per-object expression. + + Set_Parent (Len_Expr, Typ); + Preanalyze_Spec_Expression (Len_Expr, Standard_Long_Long_Integer); + + -- Use a modular type if possible. We can do this if we have + -- static bounds, and the length is small enough, and the length + -- is not zero. We exclude the zero length case because the size + -- of things is always at least one, and the zero length object + -- would have an anomalous size. + + if Compile_Time_Known_Value (Len_Expr) then + Len_Bits := Expr_Value (Len_Expr) * Csize; + + -- Check for size known to be too large + + if Len_Bits > + Uint_2 ** (Standard_Integer_Size - 1) * System_Storage_Unit + then + if System_Storage_Unit = 8 then + Error_Msg_N + ("packed array size cannot exceed " & + "Integer''Last bytes", Typ); + else + Error_Msg_N + ("packed array size cannot exceed " & + "Integer''Last storage units", Typ); + end if; + + -- Reset length to arbitrary not too high value to continue + + Len_Expr := Make_Integer_Literal (Loc, 65535); + Analyze_And_Resolve (Len_Expr, Standard_Long_Long_Integer); + end if; + + -- We normally consider small enough to mean no larger than the + -- value of System_Max_Binary_Modulus_Power, checking that in the + -- case of values longer than word size, we have long shifts. + + if Len_Bits > 0 + and then + (Len_Bits <= System_Word_Size + or else (Len_Bits <= System_Max_Binary_Modulus_Power + and then Support_Long_Shifts_On_Target)) + then + -- We can use the modular type, it has the form: + + -- subtype tttPn is btyp + -- range 0 .. 2 ** ((Typ'Length (1) + -- * ... * Typ'Length (n)) * Csize) - 1; + + -- The bounds are statically known, and btyp is one of the + -- unsigned types, depending on the length. + + if Len_Bits <= Standard_Short_Short_Integer_Size then + Btyp := RTE (RE_Short_Short_Unsigned); + + elsif Len_Bits <= Standard_Short_Integer_Size then + Btyp := RTE (RE_Short_Unsigned); + + elsif Len_Bits <= Standard_Integer_Size then + Btyp := RTE (RE_Unsigned); + + elsif Len_Bits <= Standard_Long_Integer_Size then + Btyp := RTE (RE_Long_Unsigned); + + else + Btyp := RTE (RE_Long_Long_Unsigned); + end if; + + Lit := Make_Integer_Literal (Loc, 2 ** Len_Bits - 1); + Set_Print_In_Hex (Lit); + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => PAT, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Btyp, Loc), + + Constraint => + Make_Range_Constraint (Loc, + Range_Expression => + Make_Range (Loc, + Low_Bound => + Make_Integer_Literal (Loc, 0), + High_Bound => Lit)))); + + if PASize = Uint_0 then + PASize := Len_Bits; + end if; + + Install_PAT; + + -- Propagate a given alignment to the modular type. This can + -- cause it to be under-aligned, but that's OK. + + if Present (Alignment_Clause (Typ)) then + Set_Alignment (PAT, Alignment (Typ)); + end if; + + return; + end if; + end if; + + -- Could not use a modular type, for all other cases, we build + -- a packed array subtype: + + -- subtype tttPn is + -- System.Packed_Bytes{1,2,4} (0 .. (Bits + 7) / 8 - 1); + + -- Bits is the length of the array in bits + + Set_PB_Type; + + Bits_U1 := + Make_Op_Add (Loc, + Left_Opnd => + Make_Op_Multiply (Loc, + Left_Opnd => + Make_Integer_Literal (Loc, Csize), + Right_Opnd => Len_Expr), + + Right_Opnd => + Make_Integer_Literal (Loc, 7)); + + Set_Paren_Count (Bits_U1, 1); + + PAT_High := + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Op_Divide (Loc, + Left_Opnd => Bits_U1, + Right_Opnd => Make_Integer_Literal (Loc, 8)), + Right_Opnd => Make_Integer_Literal (Loc, 1)); + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => PAT, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (PB_Type, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Low_Bound => + Make_Integer_Literal (Loc, 0), + High_Bound => + Convert_To (Standard_Integer, PAT_High)))))); + + Install_PAT; + + -- Currently the code in this unit requires that packed arrays + -- represented by non-modular arrays of bytes be on a byte + -- boundary for bit sizes handled by System.Pack_nn units. + -- That's because these units assume the array being accessed + -- starts on a byte boundary. + + if Get_Id (UI_To_Int (Csize)) /= RE_Null then + Set_Must_Be_On_Byte_Boundary (Typ); + end if; + end if; + end Create_Packed_Array_Type; + + ----------------------------------- + -- Expand_Bit_Packed_Element_Set -- + ----------------------------------- + + procedure Expand_Bit_Packed_Element_Set (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Lhs : constant Node_Id := Name (N); + + Ass_OK : constant Boolean := Assignment_OK (Lhs); + -- Used to preserve assignment OK status when assignment is rewritten + + Rhs : Node_Id := Expression (N); + -- Initially Rhs is the right hand side value, it will be replaced + -- later by an appropriate unchecked conversion for the assignment. + + Obj : Node_Id; + Atyp : Entity_Id; + PAT : Entity_Id; + Ctyp : Entity_Id; + Csiz : Int; + Cmask : Uint; + + Shift : Node_Id; + -- The expression for the shift value that is required + + Shift_Used : Boolean := False; + -- Set True if Shift has been used in the generated code at least + -- once, so that it must be duplicated if used again + + New_Lhs : Node_Id; + New_Rhs : Node_Id; + + Rhs_Val_Known : Boolean; + Rhs_Val : Uint; + -- If the value of the right hand side as an integer constant is + -- known at compile time, Rhs_Val_Known is set True, and Rhs_Val + -- contains the value. Otherwise Rhs_Val_Known is set False, and + -- the Rhs_Val is undefined. + + function Get_Shift return Node_Id; + -- Function used to get the value of Shift, making sure that it + -- gets duplicated if the function is called more than once. + + --------------- + -- Get_Shift -- + --------------- + + function Get_Shift return Node_Id is + begin + -- If we used the shift value already, then duplicate it. We + -- set a temporary parent in case actions have to be inserted. + + if Shift_Used then + Set_Parent (Shift, N); + return Duplicate_Subexpr_No_Checks (Shift); + + -- If first time, use Shift unchanged, and set flag for first use + + else + Shift_Used := True; + return Shift; + end if; + end Get_Shift; + + -- Start of processing for Expand_Bit_Packed_Element_Set + + begin + pragma Assert (Is_Bit_Packed_Array (Etype (Prefix (Lhs)))); + + Obj := Relocate_Node (Prefix (Lhs)); + Convert_To_Actual_Subtype (Obj); + Atyp := Etype (Obj); + PAT := Packed_Array_Type (Atyp); + Ctyp := Component_Type (Atyp); + Csiz := UI_To_Int (Component_Size (Atyp)); + + -- We remove side effects, in case the rhs modifies the lhs, because we + -- are about to transform the rhs into an expression that first READS + -- the lhs, so we can do the necessary shifting and masking. Example: + -- "X(2) := F(...);" where F modifies X(3). Otherwise, the side effect + -- will be lost. + + Remove_Side_Effects (Rhs); + + -- We convert the right hand side to the proper subtype to ensure + -- that an appropriate range check is made (since the normal range + -- check from assignment will be lost in the transformations). This + -- conversion is analyzed immediately so that subsequent processing + -- can work with an analyzed Rhs (and e.g. look at its Etype) + + -- If the right-hand side is a string literal, create a temporary for + -- it, constant-folding is not ready to wrap the bit representation + -- of a string literal. + + if Nkind (Rhs) = N_String_Literal then + declare + Decl : Node_Id; + begin + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'T', Rhs), + Object_Definition => New_Occurrence_Of (Ctyp, Loc), + Expression => New_Copy_Tree (Rhs)); + + Insert_Actions (N, New_List (Decl)); + Rhs := New_Occurrence_Of (Defining_Identifier (Decl), Loc); + end; + end if; + + Rhs := Convert_To (Ctyp, Rhs); + Set_Parent (Rhs, N); + + -- If we are building the initialization procedure for a packed array, + -- and Initialize_Scalars is enabled, each component assignment is an + -- out-of-range value by design. Compile this value without checks, + -- because a call to the array init_proc must not raise an exception. + + if Within_Init_Proc + and then Initialize_Scalars + then + Analyze_And_Resolve (Rhs, Ctyp, Suppress => All_Checks); + else + Analyze_And_Resolve (Rhs, Ctyp); + end if; + + -- For the AAMP target, indexing of certain packed array is passed + -- through to the back end without expansion, because the expansion + -- results in very inefficient code on that target. This allows the + -- GNAAMP back end to generate specialized macros that support more + -- efficient indexing of packed arrays with components having sizes + -- that are small powers of two. + + if AAMP_On_Target + and then (Csiz = 1 or else Csiz = 2 or else Csiz = 4) + then + return; + end if; + + -- Case of component size 1,2,4 or any component size for the modular + -- case. These are the cases for which we can inline the code. + + if Csiz = 1 or else Csiz = 2 or else Csiz = 4 + or else (Present (PAT) and then Is_Modular_Integer_Type (PAT)) + then + Setup_Inline_Packed_Array_Reference (Lhs, Atyp, Obj, Cmask, Shift); + + -- The statement to be generated is: + + -- Obj := atyp!((Obj and Mask1) or (shift_left (rhs, Shift))) + + -- where Mask1 is obtained by shifting Cmask left Shift bits + -- and then complementing the result. + + -- the "and Mask1" is omitted if rhs is constant and all 1 bits + + -- the "or ..." is omitted if rhs is constant and all 0 bits + + -- rhs is converted to the appropriate type + + -- The result is converted back to the array type, since + -- otherwise we lose knowledge of the packed nature. + + -- Determine if right side is all 0 bits or all 1 bits + + if Compile_Time_Known_Value (Rhs) then + Rhs_Val := Expr_Rep_Value (Rhs); + Rhs_Val_Known := True; + + -- The following test catches the case of an unchecked conversion + -- of an integer literal. This results from optimizing aggregates + -- of packed types. + + elsif Nkind (Rhs) = N_Unchecked_Type_Conversion + and then Compile_Time_Known_Value (Expression (Rhs)) + then + Rhs_Val := Expr_Rep_Value (Expression (Rhs)); + Rhs_Val_Known := True; + + else + Rhs_Val := No_Uint; + Rhs_Val_Known := False; + end if; + + -- Some special checks for the case where the right hand value is + -- known at compile time. Basically we have to take care of the + -- implicit conversion to the subtype of the component object. + + if Rhs_Val_Known then + + -- If we have a biased component type then we must manually do the + -- biasing, since we are taking responsibility in this case for + -- constructing the exact bit pattern to be used. + + if Has_Biased_Representation (Ctyp) then + Rhs_Val := Rhs_Val - Expr_Rep_Value (Type_Low_Bound (Ctyp)); + end if; + + -- For a negative value, we manually convert the two's complement + -- value to a corresponding unsigned value, so that the proper + -- field width is maintained. If we did not do this, we would + -- get too many leading sign bits later on. + + if Rhs_Val < 0 then + Rhs_Val := 2 ** UI_From_Int (Csiz) + Rhs_Val; + end if; + end if; + + -- Now create copies removing side effects. Note that in some + -- complex cases, this may cause the fact that we have already + -- set a packed array type on Obj to get lost. So we save the + -- type of Obj, and make sure it is reset properly. + + declare + T : constant Entity_Id := Etype (Obj); + begin + New_Lhs := Duplicate_Subexpr (Obj, True); + New_Rhs := Duplicate_Subexpr_No_Checks (Obj); + Set_Etype (Obj, T); + Set_Etype (New_Lhs, T); + Set_Etype (New_Rhs, T); + end; + + -- First we deal with the "and" + + if not Rhs_Val_Known or else Rhs_Val /= Cmask then + declare + Mask1 : Node_Id; + Lit : Node_Id; + + begin + if Compile_Time_Known_Value (Shift) then + Mask1 := + Make_Integer_Literal (Loc, + Modulus (Etype (Obj)) - 1 - + (Cmask * (2 ** Expr_Value (Get_Shift)))); + Set_Print_In_Hex (Mask1); + + else + Lit := Make_Integer_Literal (Loc, Cmask); + Set_Print_In_Hex (Lit); + Mask1 := + Make_Op_Not (Loc, + Right_Opnd => Make_Shift_Left (Lit, Get_Shift)); + end if; + + New_Rhs := + Make_Op_And (Loc, + Left_Opnd => New_Rhs, + Right_Opnd => Mask1); + end; + end if; + + -- Then deal with the "or" + + if not Rhs_Val_Known or else Rhs_Val /= 0 then + declare + Or_Rhs : Node_Id; + + procedure Fixup_Rhs; + -- Adjust Rhs by bias if biased representation for components + -- or remove extraneous high order sign bits if signed. + + procedure Fixup_Rhs is + Etyp : constant Entity_Id := Etype (Rhs); + + begin + -- For biased case, do the required biasing by simply + -- converting to the biased subtype (the conversion + -- will generate the required bias). + + if Has_Biased_Representation (Ctyp) then + Rhs := Convert_To (Ctyp, Rhs); + + -- For a signed integer type that is not biased, generate + -- a conversion to unsigned to strip high order sign bits. + + elsif Is_Signed_Integer_Type (Ctyp) then + Rhs := Unchecked_Convert_To (RTE (Bits_Id (Csiz)), Rhs); + end if; + + -- Set Etype, since it can be referenced before the node is + -- completely analyzed. + + Set_Etype (Rhs, Etyp); + + -- We now need to do an unchecked conversion of the + -- result to the target type, but it is important that + -- this conversion be a right justified conversion and + -- not a left justified conversion. + + Rhs := RJ_Unchecked_Convert_To (Etype (Obj), Rhs); + + end Fixup_Rhs; + + begin + if Rhs_Val_Known + and then Compile_Time_Known_Value (Get_Shift) + then + Or_Rhs := + Make_Integer_Literal (Loc, + Rhs_Val * (2 ** Expr_Value (Get_Shift))); + Set_Print_In_Hex (Or_Rhs); + + else + -- We have to convert the right hand side to Etype (Obj). + -- A special case arises if what we have now is a Val + -- attribute reference whose expression type is Etype (Obj). + -- This happens for assignments of fields from the same + -- array. In this case we get the required right hand side + -- by simply removing the inner attribute reference. + + if Nkind (Rhs) = N_Attribute_Reference + and then Attribute_Name (Rhs) = Name_Val + and then Etype (First (Expressions (Rhs))) = Etype (Obj) + then + Rhs := Relocate_Node (First (Expressions (Rhs))); + Fixup_Rhs; + + -- If the value of the right hand side is a known integer + -- value, then just replace it by an untyped constant, + -- which will be properly retyped when we analyze and + -- resolve the expression. + + elsif Rhs_Val_Known then + + -- Note that Rhs_Val has already been normalized to + -- be an unsigned value with the proper number of bits. + + Rhs := + Make_Integer_Literal (Loc, Rhs_Val); + + -- Otherwise we need an unchecked conversion + + else + Fixup_Rhs; + end if; + + Or_Rhs := Make_Shift_Left (Rhs, Get_Shift); + end if; + + if Nkind (New_Rhs) = N_Op_And then + Set_Paren_Count (New_Rhs, 1); + end if; + + New_Rhs := + Make_Op_Or (Loc, + Left_Opnd => New_Rhs, + Right_Opnd => Or_Rhs); + end; + end if; + + -- Now do the rewrite + + Rewrite (N, + Make_Assignment_Statement (Loc, + Name => New_Lhs, + Expression => + Unchecked_Convert_To (Etype (New_Lhs), New_Rhs))); + Set_Assignment_OK (Name (N), Ass_OK); + + -- All other component sizes for non-modular case + + else + -- We generate + + -- Set_nn (Arr'address, Subscr, Bits_nn!(Rhs)) + + -- where Subscr is the computed linear subscript + + declare + Bits_nn : constant Entity_Id := RTE (Bits_Id (Csiz)); + Set_nn : Entity_Id; + Subscr : Node_Id; + Atyp : Entity_Id; + + begin + if No (Bits_nn) then + + -- Error, most likely High_Integrity_Mode restriction + + return; + end if; + + -- Acquire proper Set entity. We use the aligned or unaligned + -- case as appropriate. + + if Known_Aligned_Enough (Obj, Csiz) then + Set_nn := RTE (Set_Id (Csiz)); + else + Set_nn := RTE (SetU_Id (Csiz)); + end if; + + -- Now generate the set reference + + Obj := Relocate_Node (Prefix (Lhs)); + Convert_To_Actual_Subtype (Obj); + Atyp := Etype (Obj); + Compute_Linear_Subscript (Atyp, Lhs, Subscr); + + -- Below we must make the assumption that Obj is + -- at least byte aligned, since otherwise its address + -- cannot be taken. The assumption holds since the + -- only arrays that can be misaligned are small packed + -- arrays which are implemented as a modular type, and + -- that is not the case here. + + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Set_nn, Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Obj, + Attribute_Name => Name_Address), + Subscr, + Unchecked_Convert_To (Bits_nn, + Convert_To (Ctyp, Rhs))))); + + end; + end if; + + Analyze (N, Suppress => All_Checks); + end Expand_Bit_Packed_Element_Set; + + ------------------------------------- + -- Expand_Packed_Address_Reference -- + ------------------------------------- + + procedure Expand_Packed_Address_Reference (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Base : Node_Id; + Offset : Node_Id; + + begin + -- We build an expression that has the form + + -- outer_object'Address + -- + (linear-subscript * component_size for each array reference + -- + field'Bit_Position for each record field + -- + ... + -- + ...) / Storage_Unit; + + Get_Base_And_Bit_Offset (Prefix (N), Base, Offset); + + Rewrite (N, + Unchecked_Convert_To (RTE (RE_Address), + Make_Op_Add (Loc, + Left_Opnd => + Unchecked_Convert_To (RTE (RE_Integer_Address), + Make_Attribute_Reference (Loc, + Prefix => Base, + Attribute_Name => Name_Address)), + + Right_Opnd => + Unchecked_Convert_To (RTE (RE_Integer_Address), + Make_Op_Divide (Loc, + Left_Opnd => Offset, + Right_Opnd => + Make_Integer_Literal (Loc, System_Storage_Unit)))))); + + Analyze_And_Resolve (N, RTE (RE_Address)); + end Expand_Packed_Address_Reference; + + --------------------------------- + -- Expand_Packed_Bit_Reference -- + --------------------------------- + + procedure Expand_Packed_Bit_Reference (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Base : Node_Id; + Offset : Node_Id; + + begin + -- We build an expression that has the form + + -- (linear-subscript * component_size for each array reference + -- + field'Bit_Position for each record field + -- + ... + -- + ...) mod Storage_Unit; + + Get_Base_And_Bit_Offset (Prefix (N), Base, Offset); + + Rewrite (N, + Unchecked_Convert_To (Universal_Integer, + Make_Op_Mod (Loc, + Left_Opnd => Offset, + Right_Opnd => Make_Integer_Literal (Loc, System_Storage_Unit)))); + + Analyze_And_Resolve (N, Universal_Integer); + end Expand_Packed_Bit_Reference; + + ------------------------------------ + -- Expand_Packed_Boolean_Operator -- + ------------------------------------ + + -- This routine expands "a op b" for the packed cases + + procedure Expand_Packed_Boolean_Operator (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + L : constant Node_Id := Relocate_Node (Left_Opnd (N)); + R : constant Node_Id := Relocate_Node (Right_Opnd (N)); + + Ltyp : Entity_Id; + Rtyp : Entity_Id; + PAT : Entity_Id; + + begin + Convert_To_Actual_Subtype (L); + Convert_To_Actual_Subtype (R); + + Ensure_Defined (Etype (L), N); + Ensure_Defined (Etype (R), N); + + Apply_Length_Check (R, Etype (L)); + + Ltyp := Etype (L); + Rtyp := Etype (R); + + -- Deal with silly case of XOR where the subcomponent has a range + -- True .. True where an exception must be raised. + + if Nkind (N) = N_Op_Xor then + Silly_Boolean_Array_Xor_Test (N, Rtyp); + end if; + + -- Now that that silliness is taken care of, get packed array type + + Convert_To_PAT_Type (L); + Convert_To_PAT_Type (R); + + PAT := Etype (L); + + -- For the modular case, we expand a op b into + + -- rtyp!(pat!(a) op pat!(b)) + + -- where rtyp is the Etype of the left operand. Note that we do not + -- convert to the base type, since this would be unconstrained, and + -- hence not have a corresponding packed array type set. + + -- Note that both operands must be modular for this code to be used + + if Is_Modular_Integer_Type (PAT) + and then + Is_Modular_Integer_Type (Etype (R)) + then + declare + P : Node_Id; + + begin + if Nkind (N) = N_Op_And then + P := Make_Op_And (Loc, L, R); + + elsif Nkind (N) = N_Op_Or then + P := Make_Op_Or (Loc, L, R); + + else -- Nkind (N) = N_Op_Xor + P := Make_Op_Xor (Loc, L, R); + end if; + + Rewrite (N, Unchecked_Convert_To (Ltyp, P)); + end; + + -- For the array case, we insert the actions + + -- Result : Ltype; + + -- System.Bit_Ops.Bit_And/Or/Xor + -- (Left'Address, + -- Ltype'Length * Ltype'Component_Size; + -- Right'Address, + -- Rtype'Length * Rtype'Component_Size + -- Result'Address); + + -- where Left and Right are the Packed_Bytes{1,2,4} operands and + -- the second argument and fourth arguments are the lengths of the + -- operands in bits. Then we replace the expression by a reference + -- to Result. + + -- Note that if we are mixing a modular and array operand, everything + -- works fine, since we ensure that the modular representation has the + -- same physical layout as the array representation (that's what the + -- left justified modular stuff in the big-endian case is about). + + else + declare + Result_Ent : constant Entity_Id := Make_Temporary (Loc, 'T'); + E_Id : RE_Id; + + begin + if Nkind (N) = N_Op_And then + E_Id := RE_Bit_And; + + elsif Nkind (N) = N_Op_Or then + E_Id := RE_Bit_Or; + + else -- Nkind (N) = N_Op_Xor + E_Id := RE_Bit_Xor; + end if; + + Insert_Actions (N, New_List ( + + Make_Object_Declaration (Loc, + Defining_Identifier => Result_Ent, + Object_Definition => New_Occurrence_Of (Ltyp, Loc)), + + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (E_Id), Loc), + Parameter_Associations => New_List ( + + Make_Byte_Aligned_Attribute_Reference (Loc, + Prefix => L, + Attribute_Name => Name_Address), + + Make_Op_Multiply (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Etype (First_Index (Ltyp)), Loc), + Attribute_Name => Name_Range_Length), + + Right_Opnd => + Make_Integer_Literal (Loc, Component_Size (Ltyp))), + + Make_Byte_Aligned_Attribute_Reference (Loc, + Prefix => R, + Attribute_Name => Name_Address), + + Make_Op_Multiply (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Etype (First_Index (Rtyp)), Loc), + Attribute_Name => Name_Range_Length), + + Right_Opnd => + Make_Integer_Literal (Loc, Component_Size (Rtyp))), + + Make_Byte_Aligned_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Result_Ent, Loc), + Attribute_Name => Name_Address))))); + + Rewrite (N, + New_Occurrence_Of (Result_Ent, Loc)); + end; + end if; + + Analyze_And_Resolve (N, Typ, Suppress => All_Checks); + end Expand_Packed_Boolean_Operator; + + ------------------------------------- + -- Expand_Packed_Element_Reference -- + ------------------------------------- + + procedure Expand_Packed_Element_Reference (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Obj : Node_Id; + Atyp : Entity_Id; + PAT : Entity_Id; + Ctyp : Entity_Id; + Csiz : Int; + Shift : Node_Id; + Cmask : Uint; + Lit : Node_Id; + Arg : Node_Id; + + begin + -- If not bit packed, we have the enumeration case, which is easily + -- dealt with (just adjust the subscripts of the indexed component) + + -- Note: this leaves the result as an indexed component, which is + -- still a variable, so can be used in the assignment case, as is + -- required in the enumeration case. + + if not Is_Bit_Packed_Array (Etype (Prefix (N))) then + Setup_Enumeration_Packed_Array_Reference (N); + return; + end if; + + -- Remaining processing is for the bit-packed case + + Obj := Relocate_Node (Prefix (N)); + Convert_To_Actual_Subtype (Obj); + Atyp := Etype (Obj); + PAT := Packed_Array_Type (Atyp); + Ctyp := Component_Type (Atyp); + Csiz := UI_To_Int (Component_Size (Atyp)); + + -- For the AAMP target, indexing of certain packed array is passed + -- through to the back end without expansion, because the expansion + -- results in very inefficient code on that target. This allows the + -- GNAAMP back end to generate specialized macros that support more + -- efficient indexing of packed arrays with components having sizes + -- that are small powers of two. + + if AAMP_On_Target + and then (Csiz = 1 or else Csiz = 2 or else Csiz = 4) + then + return; + end if; + + -- Case of component size 1,2,4 or any component size for the modular + -- case. These are the cases for which we can inline the code. + + if Csiz = 1 or else Csiz = 2 or else Csiz = 4 + or else (Present (PAT) and then Is_Modular_Integer_Type (PAT)) + then + Setup_Inline_Packed_Array_Reference (N, Atyp, Obj, Cmask, Shift); + Lit := Make_Integer_Literal (Loc, Cmask); + Set_Print_In_Hex (Lit); + + -- We generate a shift right to position the field, followed by a + -- masking operation to extract the bit field, and we finally do an + -- unchecked conversion to convert the result to the required target. + + -- Note that the unchecked conversion automatically deals with the + -- bias if we are dealing with a biased representation. What will + -- happen is that we temporarily generate the biased representation, + -- but almost immediately that will be converted to the original + -- unbiased component type, and the bias will disappear. + + Arg := + Make_Op_And (Loc, + Left_Opnd => Make_Shift_Right (Obj, Shift), + Right_Opnd => Lit); + + -- We needed to analyze this before we do the unchecked convert + -- below, but we need it temporarily attached to the tree for + -- this analysis (hence the temporary Set_Parent call). + + Set_Parent (Arg, Parent (N)); + Analyze_And_Resolve (Arg); + + Rewrite (N, RJ_Unchecked_Convert_To (Ctyp, Arg)); + + -- All other component sizes for non-modular case + + else + -- We generate + + -- Component_Type!(Get_nn (Arr'address, Subscr)) + + -- where Subscr is the computed linear subscript + + declare + Get_nn : Entity_Id; + Subscr : Node_Id; + + begin + -- Acquire proper Get entity. We use the aligned or unaligned + -- case as appropriate. + + if Known_Aligned_Enough (Obj, Csiz) then + Get_nn := RTE (Get_Id (Csiz)); + else + Get_nn := RTE (GetU_Id (Csiz)); + end if; + + -- Now generate the get reference + + Compute_Linear_Subscript (Atyp, N, Subscr); + + -- Below we make the assumption that Obj is at least byte + -- aligned, since otherwise its address cannot be taken. + -- The assumption holds since the only arrays that can be + -- misaligned are small packed arrays which are implemented + -- as a modular type, and that is not the case here. + + Rewrite (N, + Unchecked_Convert_To (Ctyp, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Get_nn, Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Obj, + Attribute_Name => Name_Address), + Subscr)))); + end; + end if; + + Analyze_And_Resolve (N, Ctyp, Suppress => All_Checks); + + end Expand_Packed_Element_Reference; + + ---------------------- + -- Expand_Packed_Eq -- + ---------------------- + + -- Handles expansion of "=" on packed array types + + procedure Expand_Packed_Eq (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + L : constant Node_Id := Relocate_Node (Left_Opnd (N)); + R : constant Node_Id := Relocate_Node (Right_Opnd (N)); + + LLexpr : Node_Id; + RLexpr : Node_Id; + + Ltyp : Entity_Id; + Rtyp : Entity_Id; + PAT : Entity_Id; + + begin + Convert_To_Actual_Subtype (L); + Convert_To_Actual_Subtype (R); + Ltyp := Underlying_Type (Etype (L)); + Rtyp := Underlying_Type (Etype (R)); + + Convert_To_PAT_Type (L); + Convert_To_PAT_Type (R); + PAT := Etype (L); + + LLexpr := + Make_Op_Multiply (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ltyp, Loc), + Attribute_Name => Name_Length), + Right_Opnd => + Make_Integer_Literal (Loc, Component_Size (Ltyp))); + + RLexpr := + Make_Op_Multiply (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Rtyp, Loc), + Attribute_Name => Name_Length), + Right_Opnd => + Make_Integer_Literal (Loc, Component_Size (Rtyp))); + + -- For the modular case, we transform the comparison to: + + -- Ltyp'Length = Rtyp'Length and then PAT!(L) = PAT!(R) + + -- where PAT is the packed array type. This works fine, since in the + -- modular case we guarantee that the unused bits are always zeroes. + -- We do have to compare the lengths because we could be comparing + -- two different subtypes of the same base type. + + if Is_Modular_Integer_Type (PAT) then + Rewrite (N, + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => LLexpr, + Right_Opnd => RLexpr), + + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => L, + Right_Opnd => R))); + + -- For the non-modular case, we call a runtime routine + + -- System.Bit_Ops.Bit_Eq + -- (L'Address, L_Length, R'Address, R_Length) + + -- where PAT is the packed array type, and the lengths are the lengths + -- in bits of the original packed arrays. This routine takes care of + -- not comparing the unused bits in the last byte. + + else + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Bit_Eq), Loc), + Parameter_Associations => New_List ( + Make_Byte_Aligned_Attribute_Reference (Loc, + Prefix => L, + Attribute_Name => Name_Address), + + LLexpr, + + Make_Byte_Aligned_Attribute_Reference (Loc, + Prefix => R, + Attribute_Name => Name_Address), + + RLexpr))); + end if; + + Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); + end Expand_Packed_Eq; + + ----------------------- + -- Expand_Packed_Not -- + ----------------------- + + -- Handles expansion of "not" on packed array types + + procedure Expand_Packed_Not (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Opnd : constant Node_Id := Relocate_Node (Right_Opnd (N)); + + Rtyp : Entity_Id; + PAT : Entity_Id; + Lit : Node_Id; + + begin + Convert_To_Actual_Subtype (Opnd); + Rtyp := Etype (Opnd); + + -- Deal with silly False..False and True..True subtype case + + Silly_Boolean_Array_Not_Test (N, Rtyp); + + -- Now that the silliness is taken care of, get packed array type + + Convert_To_PAT_Type (Opnd); + PAT := Etype (Opnd); + + -- For the case where the packed array type is a modular type, "not A" + -- expands simply into: + + -- Rtyp!(PAT!(A) xor Mask) + + -- where PAT is the packed array type, Mask is a mask of all 1 bits of + -- length equal to the size of this packed type, and Rtyp is the actual + -- actual subtype of the operand. + + Lit := Make_Integer_Literal (Loc, 2 ** RM_Size (PAT) - 1); + Set_Print_In_Hex (Lit); + + if not Is_Array_Type (PAT) then + Rewrite (N, + Unchecked_Convert_To (Rtyp, + Make_Op_Xor (Loc, + Left_Opnd => Opnd, + Right_Opnd => Lit))); + + -- For the array case, we insert the actions + + -- Result : Typ; + + -- System.Bit_Ops.Bit_Not + -- (Opnd'Address, + -- Typ'Length * Typ'Component_Size, + -- Result'Address); + + -- where Opnd is the Packed_Bytes{1,2,4} operand and the second argument + -- is the length of the operand in bits. We then replace the expression + -- with a reference to Result. + + else + declare + Result_Ent : constant Entity_Id := Make_Temporary (Loc, 'T'); + + begin + Insert_Actions (N, New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Result_Ent, + Object_Definition => New_Occurrence_Of (Rtyp, Loc)), + + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Bit_Not), Loc), + Parameter_Associations => New_List ( + Make_Byte_Aligned_Attribute_Reference (Loc, + Prefix => Opnd, + Attribute_Name => Name_Address), + + Make_Op_Multiply (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Etype (First_Index (Rtyp)), Loc), + Attribute_Name => Name_Range_Length), + + Right_Opnd => + Make_Integer_Literal (Loc, Component_Size (Rtyp))), + + Make_Byte_Aligned_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Result_Ent, Loc), + Attribute_Name => Name_Address))))); + + Rewrite (N, New_Occurrence_Of (Result_Ent, Loc)); + end; + end if; + + Analyze_And_Resolve (N, Typ, Suppress => All_Checks); + end Expand_Packed_Not; + + ----------------------------- + -- Get_Base_And_Bit_Offset -- + ----------------------------- + + procedure Get_Base_And_Bit_Offset + (N : Node_Id; + Base : out Node_Id; + Offset : out Node_Id) + is + Loc : Source_Ptr; + Term : Node_Id; + Atyp : Entity_Id; + Subscr : Node_Id; + + begin + Base := N; + Offset := Empty; + + -- We build up an expression serially that has the form + + -- linear-subscript * component_size for each array reference + -- + field'Bit_Position for each record field + -- + ... + + loop + Loc := Sloc (Base); + + if Nkind (Base) = N_Indexed_Component then + Convert_To_Actual_Subtype (Prefix (Base)); + Atyp := Etype (Prefix (Base)); + Compute_Linear_Subscript (Atyp, Base, Subscr); + + Term := + Make_Op_Multiply (Loc, + Left_Opnd => Subscr, + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Atyp, Loc), + Attribute_Name => Name_Component_Size)); + + elsif Nkind (Base) = N_Selected_Component then + Term := + Make_Attribute_Reference (Loc, + Prefix => Selector_Name (Base), + Attribute_Name => Name_Bit_Position); + + else + return; + end if; + + if No (Offset) then + Offset := Term; + + else + Offset := + Make_Op_Add (Loc, + Left_Opnd => Offset, + Right_Opnd => Term); + end if; + + Base := Prefix (Base); + end loop; + end Get_Base_And_Bit_Offset; + + ------------------------------------- + -- Involves_Packed_Array_Reference -- + ------------------------------------- + + function Involves_Packed_Array_Reference (N : Node_Id) return Boolean is + begin + if Nkind (N) = N_Indexed_Component + and then Is_Bit_Packed_Array (Etype (Prefix (N))) + then + return True; + + elsif Nkind (N) = N_Selected_Component then + return Involves_Packed_Array_Reference (Prefix (N)); + + else + return False; + end if; + end Involves_Packed_Array_Reference; + + -------------------------- + -- Known_Aligned_Enough -- + -------------------------- + + function Known_Aligned_Enough (Obj : Node_Id; Csiz : Nat) return Boolean is + Typ : constant Entity_Id := Etype (Obj); + + function In_Partially_Packed_Record (Comp : Entity_Id) return Boolean; + -- If the component is in a record that contains previous packed + -- components, consider it unaligned because the back-end might + -- choose to pack the rest of the record. Lead to less efficient code, + -- but safer vis-a-vis of back-end choices. + + -------------------------------- + -- In_Partially_Packed_Record -- + -------------------------------- + + function In_Partially_Packed_Record (Comp : Entity_Id) return Boolean is + Rec_Type : constant Entity_Id := Scope (Comp); + Prev_Comp : Entity_Id; + + begin + Prev_Comp := First_Entity (Rec_Type); + while Present (Prev_Comp) loop + if Is_Packed (Etype (Prev_Comp)) then + return True; + + elsif Prev_Comp = Comp then + return False; + end if; + + Next_Entity (Prev_Comp); + end loop; + + return False; + end In_Partially_Packed_Record; + + -- Start of processing for Known_Aligned_Enough + + begin + -- Odd bit sizes don't need alignment anyway + + if Csiz mod 2 = 1 then + return True; + + -- If we have a specified alignment, see if it is sufficient, if not + -- then we can't possibly be aligned enough in any case. + + elsif Known_Alignment (Etype (Obj)) then + -- Alignment required is 4 if size is a multiple of 4, and + -- 2 otherwise (e.g. 12 bits requires 4, 10 bits requires 2) + + if Alignment (Etype (Obj)) < 4 - (Csiz mod 4) then + return False; + end if; + end if; + + -- OK, alignment should be sufficient, if object is aligned + + -- If object is strictly aligned, then it is definitely aligned + + if Strict_Alignment (Typ) then + return True; + + -- Case of subscripted array reference + + elsif Nkind (Obj) = N_Indexed_Component then + + -- If we have a pointer to an array, then this is definitely + -- aligned, because pointers always point to aligned versions. + + if Is_Access_Type (Etype (Prefix (Obj))) then + return True; + + -- Otherwise, go look at the prefix + + else + return Known_Aligned_Enough (Prefix (Obj), Csiz); + end if; + + -- Case of record field + + elsif Nkind (Obj) = N_Selected_Component then + + -- What is significant here is whether the record type is packed + + if Is_Record_Type (Etype (Prefix (Obj))) + and then Is_Packed (Etype (Prefix (Obj))) + then + return False; + + -- Or the component has a component clause which might cause + -- the component to become unaligned (we can't tell if the + -- backend is doing alignment computations). + + elsif Present (Component_Clause (Entity (Selector_Name (Obj)))) then + return False; + + elsif In_Partially_Packed_Record (Entity (Selector_Name (Obj))) then + return False; + + -- In all other cases, go look at prefix + + else + return Known_Aligned_Enough (Prefix (Obj), Csiz); + end if; + + elsif Nkind (Obj) = N_Type_Conversion then + return Known_Aligned_Enough (Expression (Obj), Csiz); + + -- For a formal parameter, it is safer to assume that it is not + -- aligned, because the formal may be unconstrained while the actual + -- is constrained. In this situation, a small constrained packed + -- array, represented in modular form, may be unaligned. + + elsif Is_Entity_Name (Obj) then + return not Is_Formal (Entity (Obj)); + else + + -- If none of the above, must be aligned + return True; + end if; + end Known_Aligned_Enough; + + --------------------- + -- Make_Shift_Left -- + --------------------- + + function Make_Shift_Left (N : Node_Id; S : Node_Id) return Node_Id is + Nod : Node_Id; + + begin + if Compile_Time_Known_Value (S) and then Expr_Value (S) = 0 then + return N; + else + Nod := + Make_Op_Shift_Left (Sloc (N), + Left_Opnd => N, + Right_Opnd => S); + Set_Shift_Count_OK (Nod, True); + return Nod; + end if; + end Make_Shift_Left; + + ---------------------- + -- Make_Shift_Right -- + ---------------------- + + function Make_Shift_Right (N : Node_Id; S : Node_Id) return Node_Id is + Nod : Node_Id; + + begin + if Compile_Time_Known_Value (S) and then Expr_Value (S) = 0 then + return N; + else + Nod := + Make_Op_Shift_Right (Sloc (N), + Left_Opnd => N, + Right_Opnd => S); + Set_Shift_Count_OK (Nod, True); + return Nod; + end if; + end Make_Shift_Right; + + ----------------------------- + -- RJ_Unchecked_Convert_To -- + ----------------------------- + + function RJ_Unchecked_Convert_To + (Typ : Entity_Id; + Expr : Node_Id) return Node_Id + is + Source_Typ : constant Entity_Id := Etype (Expr); + Target_Typ : constant Entity_Id := Typ; + + Src : Node_Id := Expr; + + Source_Siz : Nat; + Target_Siz : Nat; + + begin + Source_Siz := UI_To_Int (RM_Size (Source_Typ)); + Target_Siz := UI_To_Int (RM_Size (Target_Typ)); + + -- First step, if the source type is not a discrete type, then we first + -- convert to a modular type of the source length, since otherwise, on + -- a big-endian machine, we get left-justification. We do it for little- + -- endian machines as well, because there might be junk bits that are + -- not cleared if the type is not numeric. + + if Source_Siz /= Target_Siz + and then not Is_Discrete_Type (Source_Typ) + then + Src := Unchecked_Convert_To (RTE (Bits_Id (Source_Siz)), Src); + end if; + + -- In the big endian case, if the lengths of the two types differ, then + -- we must worry about possible left justification in the conversion, + -- and avoiding that is what this is all about. + + if Bytes_Big_Endian and then Source_Siz /= Target_Siz then + + -- Next step. If the target is not a discrete type, then we first + -- convert to a modular type of the target length, since otherwise, + -- on a big-endian machine, we get left-justification. + + if not Is_Discrete_Type (Target_Typ) then + Src := Unchecked_Convert_To (RTE (Bits_Id (Target_Siz)), Src); + end if; + end if; + + -- And now we can do the final conversion to the target type + + return Unchecked_Convert_To (Target_Typ, Src); + end RJ_Unchecked_Convert_To; + + ---------------------------------------------- + -- Setup_Enumeration_Packed_Array_Reference -- + ---------------------------------------------- + + -- All we have to do here is to find the subscripts that correspond to the + -- index positions that have non-standard enumeration types and insert a + -- Pos attribute to get the proper subscript value. + + -- Finally the prefix must be uncheck-converted to the corresponding packed + -- array type. + + -- Note that the component type is unchanged, so we do not need to fiddle + -- with the types (Gigi always automatically takes the packed array type if + -- it is set, as it will be in this case). + + procedure Setup_Enumeration_Packed_Array_Reference (N : Node_Id) is + Pfx : constant Node_Id := Prefix (N); + Typ : constant Entity_Id := Etype (N); + Exprs : constant List_Id := Expressions (N); + Expr : Node_Id; + + begin + -- If the array is unconstrained, then we replace the array reference + -- with its actual subtype. This actual subtype will have a packed array + -- type with appropriate bounds. + + if not Is_Constrained (Packed_Array_Type (Etype (Pfx))) then + Convert_To_Actual_Subtype (Pfx); + end if; + + Expr := First (Exprs); + while Present (Expr) loop + declare + Loc : constant Source_Ptr := Sloc (Expr); + Expr_Typ : constant Entity_Id := Etype (Expr); + + begin + if Is_Enumeration_Type (Expr_Typ) + and then Has_Non_Standard_Rep (Expr_Typ) + then + Rewrite (Expr, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Expr_Typ, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List (Relocate_Node (Expr)))); + Analyze_And_Resolve (Expr, Standard_Natural); + end if; + end; + + Next (Expr); + end loop; + + Rewrite (N, + Make_Indexed_Component (Sloc (N), + Prefix => + Unchecked_Convert_To (Packed_Array_Type (Etype (Pfx)), Pfx), + Expressions => Exprs)); + + Analyze_And_Resolve (N, Typ); + end Setup_Enumeration_Packed_Array_Reference; + + ----------------------------------------- + -- Setup_Inline_Packed_Array_Reference -- + ----------------------------------------- + + procedure Setup_Inline_Packed_Array_Reference + (N : Node_Id; + Atyp : Entity_Id; + Obj : in out Node_Id; + Cmask : out Uint; + Shift : out Node_Id) + is + Loc : constant Source_Ptr := Sloc (N); + PAT : Entity_Id; + Otyp : Entity_Id; + Csiz : Uint; + Osiz : Uint; + + begin + Csiz := Component_Size (Atyp); + + Convert_To_PAT_Type (Obj); + PAT := Etype (Obj); + + Cmask := 2 ** Csiz - 1; + + if Is_Array_Type (PAT) then + Otyp := Component_Type (PAT); + Osiz := Component_Size (PAT); + + else + Otyp := PAT; + + -- In the case where the PAT is a modular type, we want the actual + -- size in bits of the modular value we use. This is neither the + -- Object_Size nor the Value_Size, either of which may have been + -- reset to strange values, but rather the minimum size. Note that + -- since this is a modular type with full range, the issue of + -- biased representation does not arise. + + Osiz := UI_From_Int (Minimum_Size (Otyp)); + end if; + + Compute_Linear_Subscript (Atyp, N, Shift); + + -- If the component size is not 1, then the subscript must be multiplied + -- by the component size to get the shift count. + + if Csiz /= 1 then + Shift := + Make_Op_Multiply (Loc, + Left_Opnd => Make_Integer_Literal (Loc, Csiz), + Right_Opnd => Shift); + end if; + + -- If we have the array case, then this shift count must be broken down + -- into a byte subscript, and a shift within the byte. + + if Is_Array_Type (PAT) then + + declare + New_Shift : Node_Id; + + begin + -- We must analyze shift, since we will duplicate it + + Set_Parent (Shift, N); + Analyze_And_Resolve + (Shift, Standard_Integer, Suppress => All_Checks); + + -- The shift count within the word is + -- shift mod Osiz + + New_Shift := + Make_Op_Mod (Loc, + Left_Opnd => Duplicate_Subexpr (Shift), + Right_Opnd => Make_Integer_Literal (Loc, Osiz)); + + -- The subscript to be used on the PAT array is + -- shift / Osiz + + Obj := + Make_Indexed_Component (Loc, + Prefix => Obj, + Expressions => New_List ( + Make_Op_Divide (Loc, + Left_Opnd => Duplicate_Subexpr (Shift), + Right_Opnd => Make_Integer_Literal (Loc, Osiz)))); + + Shift := New_Shift; + end; + + -- For the modular integer case, the object to be manipulated is the + -- entire array, so Obj is unchanged. Note that we will reset its type + -- to PAT before returning to the caller. + + else + null; + end if; + + -- The one remaining step is to modify the shift count for the + -- big-endian case. Consider the following example in a byte: + + -- xxxxxxxx bits of byte + -- vvvvvvvv bits of value + -- 33221100 little-endian numbering + -- 00112233 big-endian numbering + + -- Here we have the case of 2-bit fields + + -- For the little-endian case, we already have the proper shift count + -- set, e.g. for element 2, the shift count is 2*2 = 4. + + -- For the big endian case, we have to adjust the shift count, computing + -- it as (N - F) - Shift, where N is the number of bits in an element of + -- the array used to implement the packed array, F is the number of bits + -- in a source array element, and Shift is the count so far computed. + + if Bytes_Big_Endian then + Shift := + Make_Op_Subtract (Loc, + Left_Opnd => Make_Integer_Literal (Loc, Osiz - Csiz), + Right_Opnd => Shift); + end if; + + Set_Parent (Shift, N); + Set_Parent (Obj, N); + Analyze_And_Resolve (Obj, Otyp, Suppress => All_Checks); + Analyze_And_Resolve (Shift, Standard_Integer, Suppress => All_Checks); + + -- Make sure final type of object is the appropriate packed type + + Set_Etype (Obj, Otyp); + + end Setup_Inline_Packed_Array_Reference; + +end Exp_Pakd; diff --git a/gcc/ada/exp_pakd.ads b/gcc/ada/exp_pakd.ads new file mode 100644 index 000000000..bd21a30ef --- /dev/null +++ b/gcc/ada/exp_pakd.ads @@ -0,0 +1,280 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ P A K D -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for manipulation of packed arrays + +with Types; use Types; + +package Exp_Pakd is + + ------------------------------------- + -- Implementation of Packed Arrays -- + ------------------------------------- + + -- When a packed array (sub)type is frozen, we create a corresponding + -- type that will be used to hold the bits of the packed value, and + -- store the entity for this type in the Packed_Array_Type field of the + -- E_Array_Type or E_Array_Subtype entity for the packed array. + + -- This packed array type has the name xxxPn, where xxx is the name + -- of the packed type, and n is the component size. The expanded + -- declaration declares a type that is one of the following: + + -- For an unconstrained array with component size 1,2,4 or any other + -- odd component size. These are the cases in which we do not need + -- to align the underlying array. + + -- type xxxPn is new Packed_Bytes1; + + -- For an unconstrained array with component size that is divisible + -- by 2, but not divisible by 4 (other than 2 itself). These are the + -- cases in which we can generate better code if the underlying array + -- is 2-byte aligned (see System.Pack_14 in file s-pack14 for example). + + -- type xxxPn is new Packed_Bytes2; + + -- For an unconstrained array with component size that is divisible + -- by 4, other than powers of 2 (which either come under the 1,2,4 + -- exception above, or are not packed at all). These are cases where + -- we can generate better code if the underlying array is 4-byte + -- aligned (see System.Pack_20 in file s-pack20 for example). + + -- type xxxPn is new Packed_Bytes4; + + -- For a constrained array with a static index type where the number + -- of bits does not exceed the size of Unsigned: + + -- type xxxPn is new Unsigned range 0 .. 2 ** nbits - 1; + + -- For a constrained array with a static index type where the number + -- of bits is greater than the size of Unsigned, but does not exceed + -- the size of Long_Long_Unsigned: + + -- type xxxPn is new Long_Long_Unsigned range 0 .. 2 ** nbits - 1; + + -- For all other constrained arrays, we use one of + + -- type xxxPn is new Packed_Bytes1 (0 .. m); + -- type xxxPn is new Packed_Bytes2 (0 .. m); + -- type xxxPn is new Packed_Bytes4 (0 .. m); + + -- where m is calculated (from the length of the original packed array) + -- to hold the required number of bits, and the choice of the particular + -- Packed_Bytes{1,2,4} type is made on the basis of alignment needs as + -- described above for the unconstrained case. + + -- When a variable of packed array type is allocated, gigi will allocate + -- the amount of space indicated by the corresponding packed array type. + -- However, we do NOT attempt to rewrite the types of any references or + -- to retype the variable itself, since this would cause all kinds of + -- semantic problems in the front end (remember that expansion proceeds + -- at the same time as analysis). + + -- For an indexed reference to a packed array, we simply convert the + -- reference to the appropriate equivalent reference to the object + -- of the packed array type (using unchecked conversion). + + -- In some cases (for internally generated types, and for the subtypes + -- for record fields that depend on a discriminant), the corresponding + -- packed type cannot be easily generated in advance. In these cases, + -- we generate the required subtype on the fly at the reference point. + + -- For the modular case, any unused bits are initialized to zero, and + -- all operations maintain these bits as zero (where necessary all + -- unchecked conversions from corresponding array values require + -- these bits to be clear, which is done automatically by gigi). + + -- For the array cases, there can be unused bits in the last byte, and + -- these are neither initialized, nor treated specially in operations + -- (i.e. it is allowable for these bits to be clobbered, e.g. by not). + + --------------------------- + -- Endian Considerations -- + --------------------------- + + -- The standard does not specify the way in which bits are numbered in + -- a packed array. There are two reasonable rules for deciding this: + + -- Store the first bit at right end (low order) word. This means + -- that the scaled subscript can be used directly as a left shift + -- count (if we put bit 0 at the left end, then we need an extra + -- subtract to compute the shift count). + + -- Layout the bits so that if the packed boolean array is overlaid on + -- a record, using unchecked conversion, then bit 0 of the array is + -- the same as the bit numbered bit 0 in a record representation + -- clause applying to the record. For example: + + -- type Rec is record + -- C : Bits4; + -- D : Bits7; + -- E : Bits5; + -- end record; + + -- for Rec use record + -- C at 0 range 0 .. 3; + -- D at 0 range 4 .. 10; + -- E at 0 range 11 .. 15; + -- end record; + + -- type P16 is array (0 .. 15) of Boolean; + -- pragma Pack (P16); + + -- Now if we use unchecked conversion to convert a value of the record + -- type to the packed array type, according to this second criterion, + -- we would expect field D to occupy bits 4..10 of the Boolean array. + + -- Although not required, this correspondence seems a highly desirable + -- property, and is one that GNAT decides to guarantee. For a little + -- endian machine, we can also meet the first requirement, but for a + -- big endian machine, it will be necessary to store the first bit of + -- a Boolean array in the left end (most significant) bit of the word. + -- This may cost an extra instruction on some machines, but we consider + -- that a worthwhile price to pay for the consistency. + + -- One more important point arises in the case where we have a constrained + -- subtype of an unconstrained array. Take the case of 20 bits. For the + -- unconstrained representation, we would use an array of bytes: + + -- Little-endian case + -- 8-7-6-5-4-3-2-1 16-15-14-13-12-11-10-9 x-x-x-x-20-19-18-17 + + -- Big-endian case + -- 1-2-3-4-5-6-7-8 9-10-11-12-13-14-15-16 17-18-19-20-x-x-x-x + + -- For the constrained case, we use a 20-bit modular value, but in + -- general this value may well be stored in 32 bits. Let's look at + -- what it looks like: + + -- Little-endian case + + -- x-x-x-x-x-x-x-x-x-x-x-x-20-19-18-17-...-10-9-8-7-6-5-4-3-2-1 + + -- which stored in memory looks like + + -- 8-7-...-2-1 16-15-...-10-9 x-x-x-x-20-19-18-17 x-x-x-x-x-x-x + + -- An important rule is that the constrained and unconstrained cases + -- must have the same bit representation in memory, since we will often + -- convert from one to the other (e.g. when calling a procedure whose + -- formal is unconstrained). As we see, that criterion is met for the + -- little-endian case above. Now let's look at the big-endian case: + + -- Big-endian case + + -- x-x-x-x-x-x-x-x-x-x-x-x-1-2-3-4-5-6-7-8-9-10-...-17-18-19-20 + + -- which stored in memory looks like + + -- x-x-x-x-x-x-x-x x-x-x-x-1-2-3-4 5-6-...11-12 13-14-...-19-20 + + -- That won't do, the representation value in memory is NOT the same in + -- the constrained and unconstrained case. The solution is to store the + -- modular value left-justified: + + -- 1-2-3-4-5-6-7-8-9-10-...-17-18-19-20-x-x-x-x-x-x-x-x-x-x-x + + -- which stored in memory looks like + + -- 1-2-...-7-8 9-10-...15-16 17-18-19-20-x-x-x-x x-x-x-x-x-x-x-x + + -- and now, we do indeed have the same representation for the memory + -- version in the constrained and unconstrained cases. + + ----------------- + -- Subprograms -- + ----------------- + + procedure Create_Packed_Array_Type (Typ : Entity_Id); + -- Typ is a array type or subtype to which pragma Pack applies. If the + -- Packed_Array_Type field of Typ is already set, then the call has no + -- effect, otherwise a suitable type or subtype is created and stored + -- in the Packed_Array_Type field of Typ. This created type is an Itype + -- so that Gigi will simply elaborate and freeze the type on first use + -- (which is typically the definition of the corresponding array type). + -- + -- Note: although this routine is included in the expander package for + -- packed types, it is actually called unconditionally from Freeze, + -- whether or not expansion (and code generation) is enabled. We do this + -- since we want gigi to be able to properly compute type characteristics + -- (for the Data Decomposition Annex of ASIS, and possible other future + -- uses) even if code generation is not active. Strictly this means that + -- this procedure is not part of the expander, but it seems appropriate + -- to keep it together with the other expansion routines that have to do + -- with packed array types. + + procedure Expand_Packed_Boolean_Operator (N : Node_Id); + -- N is an N_Op_And, N_Op_Or or N_Op_Xor node whose operand type is a + -- packed boolean array. This routine expands the appropriate operations + -- to carry out the logical operation on the packed arrays. It handles + -- both the modular and array representation cases. + + procedure Expand_Packed_Element_Reference (N : Node_Id); + -- N is an N_Indexed_Component node whose prefix is a packed array. In + -- the bit packed case, this routine can only be used for the expression + -- evaluation case, not the assignment case, since the result is not a + -- variable. See Expand_Bit_Packed_Element_Set for how the assignment case + -- is handled in the bit packed case. For the enumeration case, the result + -- of this call is always a variable, so the call can be used for both the + -- expression evaluation and assignment cases. + + procedure Expand_Bit_Packed_Element_Set (N : Node_Id); + -- N is an N_Assignment_Statement node whose name is an indexed + -- component of a bit-packed array. This procedure rewrites the entire + -- assignment statement with appropriate code to set the referenced + -- bits of the packed array type object. Note that this procedure is + -- used only for the bit-packed case, not for the enumeration case. + + procedure Expand_Packed_Eq (N : Node_Id); + -- N is an N_Op_Eq node where the operands are packed arrays whose + -- representation is an array-of-bytes type (the case where a modular + -- type is used for the representation does not require any special + -- handling, because in the modular case, unused bits are zeroes. + + procedure Expand_Packed_Not (N : Node_Id); + -- N is an N_Op_Not node where the operand is packed array of Boolean + -- in standard representation (i.e. component size is one bit). This + -- procedure expands the corresponding not operation. Note that the + -- non-standard representation case is handled by using a loop through + -- elements generated by the normal non-packed circuitry. + + function Involves_Packed_Array_Reference (N : Node_Id) return Boolean; + -- N is the node for a name. This function returns true if the name + -- involves a packed array reference. A node involves a packed array + -- reference if it is itself an indexed component referring to a bit- + -- packed array, or it is a selected component whose prefix involves + -- a packed array reference. + + procedure Expand_Packed_Address_Reference (N : Node_Id); + -- The node N is an attribute reference for the 'Address reference, where + -- the prefix involves a packed array reference. This routine expands the + -- necessary code for performing the address reference in this case. + + procedure Expand_Packed_Bit_Reference (N : Node_Id); + -- The node N is an attribute reference for the 'Bit reference, where the + -- prefix involves a packed array reference. This routine expands the + -- necessary code for performing the bit reference in this case. + +end Exp_Pakd; diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb new file mode 100644 index 000000000..7e1f4208b --- /dev/null +++ b/gcc/ada/exp_prag.adb @@ -0,0 +1,829 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ P R A G -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Casing; use Casing; +with Debug; use Debug; +with Einfo; use Einfo; +with Errout; use Errout; +with Exp_Ch11; use Exp_Ch11; +with Exp_Util; use Exp_Util; +with Expander; use Expander; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with Stringt; use Stringt; +with Stand; use Stand; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +package body Exp_Prag is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Arg1 (N : Node_Id) return Node_Id; + function Arg2 (N : Node_Id) return Node_Id; + function Arg3 (N : Node_Id) return Node_Id; + -- Obtain specified pragma argument expression + + procedure Expand_Pragma_Abort_Defer (N : Node_Id); + procedure Expand_Pragma_Check (N : Node_Id); + procedure Expand_Pragma_Common_Object (N : Node_Id); + procedure Expand_Pragma_Import_Or_Interface (N : Node_Id); + procedure Expand_Pragma_Import_Export_Exception (N : Node_Id); + procedure Expand_Pragma_Inspection_Point (N : Node_Id); + procedure Expand_Pragma_Interrupt_Priority (N : Node_Id); + procedure Expand_Pragma_Psect_Object (N : Node_Id); + procedure Expand_Pragma_Relative_Deadline (N : Node_Id); + + ---------- + -- Arg1 -- + ---------- + + function Arg1 (N : Node_Id) return Node_Id is + Arg : constant Node_Id := First (Pragma_Argument_Associations (N)); + begin + if Present (Arg) + and then Nkind (Arg) = N_Pragma_Argument_Association + then + return Expression (Arg); + else + return Arg; + end if; + end Arg1; + + ---------- + -- Arg2 -- + ---------- + + function Arg2 (N : Node_Id) return Node_Id is + Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); + + begin + if No (Arg1) then + return Empty; + + else + declare + Arg : constant Node_Id := Next (Arg1); + begin + if Present (Arg) + and then Nkind (Arg) = N_Pragma_Argument_Association + then + return Expression (Arg); + else + return Arg; + end if; + end; + end if; + end Arg2; + + ---------- + -- Arg3 -- + ---------- + + function Arg3 (N : Node_Id) return Node_Id is + Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); + + begin + if No (Arg1) then + return Empty; + + else + declare + Arg : Node_Id := Next (Arg1); + begin + if No (Arg) then + return Empty; + + else + Next (Arg); + + if Present (Arg) + and then Nkind (Arg) = N_Pragma_Argument_Association + then + return Expression (Arg); + else + return Arg; + end if; + end if; + end; + end if; + end Arg3; + + --------------------- + -- Expand_N_Pragma -- + --------------------- + + procedure Expand_N_Pragma (N : Node_Id) is + Pname : constant Name_Id := Pragma_Name (N); + + begin + -- Note: we may have a pragma whose Pragma_Identifier field is not a + -- recognized pragma, and we must ignore it at this stage. + + if Is_Pragma_Name (Pname) then + case Get_Pragma_Id (Pname) is + + -- Pragmas requiring special expander action + + when Pragma_Abort_Defer => + Expand_Pragma_Abort_Defer (N); + + when Pragma_Check => + Expand_Pragma_Check (N); + + when Pragma_Common_Object => + Expand_Pragma_Common_Object (N); + + when Pragma_Export_Exception => + Expand_Pragma_Import_Export_Exception (N); + + when Pragma_Import => + Expand_Pragma_Import_Or_Interface (N); + + when Pragma_Import_Exception => + Expand_Pragma_Import_Export_Exception (N); + + when Pragma_Inspection_Point => + Expand_Pragma_Inspection_Point (N); + + when Pragma_Interface => + Expand_Pragma_Import_Or_Interface (N); + + when Pragma_Interrupt_Priority => + Expand_Pragma_Interrupt_Priority (N); + + when Pragma_Psect_Object => + Expand_Pragma_Psect_Object (N); + + when Pragma_Relative_Deadline => + Expand_Pragma_Relative_Deadline (N); + + -- All other pragmas need no expander action + + when others => null; + end case; + end if; + + end Expand_N_Pragma; + + ------------------------------- + -- Expand_Pragma_Abort_Defer -- + ------------------------------- + + -- An Abort_Defer pragma appears as the first statement in a handled + -- statement sequence (right after the begin). It defers aborts for + -- the entire statement sequence, but not for any declarations or + -- handlers (if any) associated with this statement sequence. + + -- The transformation is to transform + + -- pragma Abort_Defer; + -- statements; + + -- into + + -- begin + -- Abort_Defer.all; + -- statements + -- exception + -- when all others => + -- Abort_Undefer.all; + -- raise; + -- at end + -- Abort_Undefer_Direct; + -- end; + + procedure Expand_Pragma_Abort_Defer (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Stm : Node_Id; + Stms : List_Id; + HSS : Node_Id; + Blk : constant Entity_Id := + New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B'); + + begin + Stms := New_List (Build_Runtime_Call (Loc, RE_Abort_Defer)); + + loop + Stm := Remove_Next (N); + exit when No (Stm); + Append (Stm, Stms); + end loop; + + HSS := + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stms, + At_End_Proc => + New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)); + + Rewrite (N, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => HSS)); + + Set_Scope (Blk, Current_Scope); + Set_Etype (Blk, Standard_Void_Type); + Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N))); + Expand_At_End_Handler (HSS, Blk); + Analyze (N); + end Expand_Pragma_Abort_Defer; + + -------------------------- + -- Expand_Pragma_Check -- + -------------------------- + + procedure Expand_Pragma_Check (N : Node_Id) is + Cond : constant Node_Id := Arg2 (N); + Loc : constant Source_Ptr := Sloc (Cond); + Nam : constant Name_Id := Chars (Arg1 (N)); + Msg : Node_Id; + + begin + -- We already know that this check is enabled, because otherwise the + -- semantic pass dealt with rewriting the assertion (see Sem_Prag) + + -- Since this check is enabled, we rewrite the pragma into a + -- corresponding if statement, and then analyze the statement + + -- The normal case expansion transforms: + + -- pragma Check (name, condition [,message]); + + -- into + + -- if not condition then + -- System.Assertions.Raise_Assert_Failure (Str); + -- end if; + + -- where Str is the message if one is present, or the default of + -- name failed at file:line if no message is given (the "name failed + -- at" is omitted for name = Assertion, since it is redundant, given + -- that the name of the exception is Assert_Failure.) + + -- An alternative expansion is used when the No_Exception_Propagation + -- restriction is active and there is a local Assert_Failure handler. + -- This is not a common combination of circumstances, but it occurs in + -- the context of Aunit and the zero footprint profile. In this case we + -- generate: + + -- if not condition then + -- raise Assert_Failure; + -- end if; + + -- This will then be transformed into a goto, and the local handler will + -- be able to handle the assert error (which would not be the case if a + -- call is made to the Raise_Assert_Failure procedure). + + -- We also generate the direct raise if the Suppress_Exception_Locations + -- is active, since we don't want to generate messages in this case. + + -- Note that the reason we do not always generate a direct raise is that + -- the form in which the procedure is called allows for more efficient + -- breakpointing of assertion errors. + + -- Generate the appropriate if statement. Note that we consider this to + -- be an explicit conditional in the source, not an implicit if, so we + -- do not call Make_Implicit_If_Statement. + + -- Case where we generate a direct raise + + if ((Debug_Flag_Dot_G + or else Restriction_Active (No_Exception_Propagation)) + and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N))) + or else (Opt.Exception_Locations_Suppressed and then No (Arg3 (N))) + then + Rewrite (N, + Make_If_Statement (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => Cond), + Then_Statements => New_List ( + Make_Raise_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Assert_Failure), Loc))))); + + -- Case where we call the procedure + + else + -- If we have a message given, use it + + if Present (Arg3 (N)) then + Msg := Get_Pragma_Arg (Arg3 (N)); + + -- Here we have no string, so prepare one + + else + declare + Msg_Loc : constant String := Build_Location_String (Loc); + + begin + Name_Len := 0; + + -- For Assert, we just use the location + + if Nam = Name_Assertion then + null; + + -- For predicate, we generate the string "predicate failed + -- at yyy". We prefer all lower case for predicate. + + elsif Nam = Name_Predicate then + Add_Str_To_Name_Buffer ("predicate failed at "); + + -- For special case of Precondition/Postcondition the string is + -- "failed xx from yy" where xx is precondition/postcondition + -- in all lower case. The reason for this different wording is + -- that the failure is not at the point of occurrence of the + -- pragma, unlike the other Check cases. + + elsif Nam = Name_Precondition + or else + Nam = Name_Postcondition + then + Get_Name_String (Nam); + Insert_Str_In_Name_Buffer ("failed ", 1); + Add_Str_To_Name_Buffer (" from "); + + -- For all other checks, the string is "xxx failed at yyy" + -- where xxx is the check name with current source file casing. + + else + Get_Name_String (Nam); + Set_Casing (Identifier_Casing (Current_Source_File)); + Add_Str_To_Name_Buffer (" failed at "); + end if; + + -- In all cases, add location string + + Add_Str_To_Name_Buffer (Msg_Loc); + + -- Build the message + + Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len)); + end; + end if; + + -- Now rewrite as an if statement + + Rewrite (N, + Make_If_Statement (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => Cond), + Then_Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc), + Parameter_Associations => New_List (Relocate_Node (Msg)))))); + end if; + + Analyze (N); + + -- If new condition is always false, give a warning + + if Warn_On_Assertion_Failure + and then Nkind (N) = N_Procedure_Call_Statement + and then Is_RTE (Entity (Name (N)), RE_Raise_Assert_Failure) + then + -- If original condition was a Standard.False, we assume that this is + -- indeed intended to raise assert error and no warning is required. + + if Is_Entity_Name (Original_Node (Cond)) + and then Entity (Original_Node (Cond)) = Standard_False + then + return; + elsif Nam = Name_Assertion then + Error_Msg_N ("?assertion will fail at run time", N); + else + Error_Msg_N ("?check will fail at run time", N); + end if; + end if; + end Expand_Pragma_Check; + + --------------------------------- + -- Expand_Pragma_Common_Object -- + --------------------------------- + + -- Use a machine attribute to replicate semantic effect in DEC Ada + + -- pragma Machine_Attribute (intern_name, "common_object", extern_name); + + -- For now we do nothing with the size attribute ??? + + -- Note: Psect_Object shares this processing + + procedure Expand_Pragma_Common_Object (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Internal : constant Node_Id := Arg1 (N); + External : constant Node_Id := Arg2 (N); + + Psect : Node_Id; + -- Psect value upper cased as string literal + + Iloc : constant Source_Ptr := Sloc (Internal); + Eloc : constant Source_Ptr := Sloc (External); + Ploc : Source_Ptr; + + begin + -- Acquire Psect value and fold to upper case + + if Present (External) then + if Nkind (External) = N_String_Literal then + String_To_Name_Buffer (Strval (External)); + else + Get_Name_String (Chars (External)); + end if; + + Set_All_Upper_Case; + + Psect := + Make_String_Literal (Eloc, + Strval => String_From_Name_Buffer); + + else + Get_Name_String (Chars (Internal)); + Set_All_Upper_Case; + Psect := + Make_String_Literal (Iloc, + Strval => String_From_Name_Buffer); + end if; + + Ploc := Sloc (Psect); + + -- Insert the pragma + + Insert_After_And_Analyze (N, + Make_Pragma (Loc, + Chars => Name_Machine_Attribute, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Iloc, + Expression => New_Copy_Tree (Internal)), + Make_Pragma_Argument_Association (Eloc, + Expression => + Make_String_Literal (Sloc => Ploc, + Strval => "common_object")), + Make_Pragma_Argument_Association (Ploc, + Expression => New_Copy_Tree (Psect))))); + + end Expand_Pragma_Common_Object; + + --------------------------------------- + -- Expand_Pragma_Import_Or_Interface -- + --------------------------------------- + + -- When applied to a variable, the default initialization must not be + -- done. As it is already done when the pragma is found, we just get rid + -- of the call the initialization procedure which followed the object + -- declaration. The call is inserted after the declaration, but validity + -- checks may also have been inserted and the initialization call does + -- not necessarily appear immediately after the object declaration. + + -- We can't use the freezing mechanism for this purpose, since we + -- have to elaborate the initialization expression when it is first + -- seen (i.e. this elaboration cannot be deferred to the freeze point). + + procedure Expand_Pragma_Import_Or_Interface (N : Node_Id) is + Def_Id : constant Entity_Id := Entity (Arg2 (N)); + Init_Call : Node_Id; + + begin + if Ekind (Def_Id) = E_Variable then + + -- Find generated initialization call for object, if any + + Init_Call := Find_Init_Call (Def_Id, Rep_Clause => N); + if Present (Init_Call) then + Remove (Init_Call); + end if; + + -- Any default initialization expression should be removed + -- (e.g., null defaults for access objects, zero initialization + -- of packed bit arrays). Imported objects aren't allowed to + -- have explicit initialization, so the expression must have + -- been generated by the compiler. + + if No (Init_Call) and then Present (Expression (Parent (Def_Id))) then + Set_Expression (Parent (Def_Id), Empty); + end if; + end if; + end Expand_Pragma_Import_Or_Interface; + + ------------------------------------------- + -- Expand_Pragma_Import_Export_Exception -- + ------------------------------------------- + + -- For a VMS exception fix up the language field with "VMS" + -- instead of "Ada" (gigi needs this), create a constant that will be the + -- value of the VMS condition code and stuff the Interface_Name field + -- with the unexpanded name of the exception (if not already set). + -- For a Ada exception, just stuff the Interface_Name field + -- with the unexpanded name of the exception (if not already set). + + procedure Expand_Pragma_Import_Export_Exception (N : Node_Id) is + begin + -- This pragma is only effective on OpenVMS systems, it was ignored + -- on non-VMS systems, and we need to ignore it here as well. + + if not OpenVMS_On_Target then + return; + end if; + + declare + Id : constant Entity_Id := Entity (Arg1 (N)); + Call : constant Node_Id := Register_Exception_Call (Id); + Loc : constant Source_Ptr := Sloc (N); + + begin + if Present (Call) then + declare + Excep_Internal : constant Node_Id := Make_Temporary (Loc, 'V'); + Export_Pragma : Node_Id; + Excep_Alias : Node_Id; + Excep_Object : Node_Id; + Excep_Image : String_Id; + Exdata : List_Id; + Lang_Char : Node_Id; + Code : Node_Id; + + begin + if Present (Interface_Name (Id)) then + Excep_Image := Strval (Interface_Name (Id)); + else + Get_Name_String (Chars (Id)); + Set_All_Upper_Case; + Excep_Image := String_From_Name_Buffer; + end if; + + Exdata := Component_Associations (Expression (Parent (Id))); + + if Is_VMS_Exception (Id) then + Lang_Char := Next (First (Exdata)); + + -- Change the one-character language designator to 'V' + + Rewrite (Expression (Lang_Char), + Make_Character_Literal (Loc, + Chars => Name_uV, + Char_Literal_Value => + UI_From_Int (Character'Pos ('V')))); + Analyze (Expression (Lang_Char)); + + if Exception_Code (Id) /= No_Uint then + Code := + Make_Integer_Literal (Loc, + Intval => Exception_Code (Id)); + + Excep_Object := + Make_Object_Declaration (Loc, + Defining_Identifier => Excep_Internal, + Object_Definition => + New_Reference_To (RTE (RE_Exception_Code), Loc)); + + Insert_Action (N, Excep_Object); + Analyze (Excep_Object); + + Start_String; + Store_String_Int + (UI_To_Int (Exception_Code (Id)) / 8 * 8); + + Excep_Alias := + Make_Pragma + (Loc, + Name_Linker_Alias, + New_List + (Make_Pragma_Argument_Association + (Sloc => Loc, + Expression => + New_Reference_To (Excep_Internal, Loc)), + + Make_Pragma_Argument_Association + (Sloc => Loc, + Expression => + Make_String_Literal + (Sloc => Loc, + Strval => End_String)))); + + Insert_Action (N, Excep_Alias); + Analyze (Excep_Alias); + + Export_Pragma := + Make_Pragma + (Loc, + Name_Export, + New_List + (Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_C)), + + Make_Pragma_Argument_Association (Loc, + Expression => + New_Reference_To (Excep_Internal, Loc)), + + Make_Pragma_Argument_Association (Loc, + Expression => + Make_String_Literal (Loc, Excep_Image)), + + Make_Pragma_Argument_Association (Loc, + Expression => + Make_String_Literal (Loc, Excep_Image)))); + + Insert_Action (N, Export_Pragma); + Analyze (Export_Pragma); + + else + Code := + Unchecked_Convert_To (RTE (RE_Exception_Code), + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Import_Value), Loc), + Parameter_Associations => New_List + (Make_String_Literal (Loc, + Strval => Excep_Image)))); + end if; + + Rewrite (Call, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To + (RTE (RE_Register_VMS_Exception), Loc), + Parameter_Associations => New_List ( + Code, + Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Id, Loc), + Attribute_Name => Name_Unrestricted_Access))))); + + Analyze_And_Resolve (Code, RTE (RE_Exception_Code)); + Analyze (Call); + end if; + + if No (Interface_Name (Id)) then + Set_Interface_Name (Id, + Make_String_Literal + (Sloc => Loc, + Strval => Excep_Image)); + end if; + end; + end if; + end; + end Expand_Pragma_Import_Export_Exception; + + ------------------------------------ + -- Expand_Pragma_Inspection_Point -- + ------------------------------------ + + -- If no argument is given, then we supply a default argument list that + -- includes all objects declared at the source level in all subprograms + -- that enclose the inspection point pragma. + + procedure Expand_Pragma_Inspection_Point (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + A : List_Id; + Assoc : Node_Id; + S : Entity_Id; + E : Entity_Id; + + begin + if No (Pragma_Argument_Associations (N)) then + A := New_List; + S := Current_Scope; + + while S /= Standard_Standard loop + E := First_Entity (S); + while Present (E) loop + if Comes_From_Source (E) + and then Is_Object (E) + and then not Is_Entry_Formal (E) + and then Ekind (E) /= E_Component + and then Ekind (E) /= E_Discriminant + and then Ekind (E) /= E_Generic_In_Parameter + and then Ekind (E) /= E_Generic_In_Out_Parameter + then + Append_To (A, + Make_Pragma_Argument_Association (Loc, + Expression => New_Occurrence_Of (E, Loc))); + end if; + + Next_Entity (E); + end loop; + + S := Scope (S); + end loop; + + Set_Pragma_Argument_Associations (N, A); + end if; + + -- Expand the arguments of the pragma. Expanding an entity reference + -- is a noop, except in a protected operation, where a reference may + -- have to be transformed into a reference to the corresponding prival. + -- Are there other pragmas that may require this ??? + + Assoc := First (Pragma_Argument_Associations (N)); + + while Present (Assoc) loop + Expand (Expression (Assoc)); + Next (Assoc); + end loop; + end Expand_Pragma_Inspection_Point; + + -------------------------------------- + -- Expand_Pragma_Interrupt_Priority -- + -------------------------------------- + + -- Supply default argument if none exists (System.Interrupt_Priority'Last) + + procedure Expand_Pragma_Interrupt_Priority (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + begin + if No (Pragma_Argument_Associations (N)) then + Set_Pragma_Argument_Associations (N, New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Interrupt_Priority), Loc), + Attribute_Name => Name_Last)))); + end if; + end Expand_Pragma_Interrupt_Priority; + + -------------------------------- + -- Expand_Pragma_Psect_Object -- + -------------------------------- + + -- Convert to Common_Object, and expand the resulting pragma + + procedure Expand_Pragma_Psect_Object (N : Node_Id) + renames Expand_Pragma_Common_Object; + + ------------------------------------- + -- Expand_Pragma_Relative_Deadline -- + ------------------------------------- + + procedure Expand_Pragma_Relative_Deadline (N : Node_Id) is + P : constant Node_Id := Parent (N); + Loc : constant Source_Ptr := Sloc (N); + + begin + -- Expand the pragma only in the case of the main subprogram. For tasks + -- the expansion is done in exp_ch9. Generate a call to Set_Deadline + -- at Clock plus the relative deadline specified in the pragma. Time + -- values are translated into Duration to allow for non-private + -- addition operation. + + if Nkind (P) = N_Subprogram_Body then + Rewrite + (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Set_Deadline), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RO_RT_Time), + Make_Op_Add (Loc, + Left_Opnd => + Make_Function_Call (Loc, + New_Reference_To (RTE (RO_RT_To_Duration), Loc), + New_List (Make_Function_Call (Loc, + New_Reference_To (RTE (RE_Clock), Loc)))), + Right_Opnd => + Unchecked_Convert_To (Standard_Duration, Arg1 (N))))))); + + Analyze (N); + end if; + end Expand_Pragma_Relative_Deadline; + +end Exp_Prag; diff --git a/gcc/ada/exp_prag.ads b/gcc/ada/exp_prag.ads new file mode 100644 index 000000000..e99550127 --- /dev/null +++ b/gcc/ada/exp_prag.ads @@ -0,0 +1,34 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ P R A G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for pragmas + +with Types; use Types; + +package Exp_Prag is + + procedure Expand_N_Pragma (N : Node_Id); + +end Exp_Prag; diff --git a/gcc/ada/exp_sel.adb b/gcc/ada/exp_sel.adb new file mode 100644 index 000000000..8250516a0 --- /dev/null +++ b/gcc/ada/exp_sel.adb @@ -0,0 +1,201 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ S E L -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Einfo; use Einfo; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Rtsfind; use Rtsfind; +with Stand; use Stand; +with Tbuild; use Tbuild; + +package body Exp_Sel is + + ----------------------- + -- Build_Abort_Block -- + ----------------------- + + function Build_Abort_Block + (Loc : Source_Ptr; + Abr_Blk_Ent : Entity_Id; + Cln_Blk_Ent : Entity_Id; + Blk : Node_Id) return Node_Id + is + begin + return + Make_Block_Statement (Loc, + Identifier => New_Reference_To (Abr_Blk_Ent, Loc), + + Declarations => No_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => + New_List ( + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => + Cln_Blk_Ent, + Label_Construct => + Blk), + Blk), + + Exception_Handlers => + New_List ( + Make_Implicit_Exception_Handler (Loc, + Exception_Choices => + New_List ( + New_Reference_To (Stand.Abort_Signal, Loc)), + Statements => + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE ( + RE_Abort_Undefer), Loc), + Parameter_Associations => No_List)))))); + end Build_Abort_Block; + + ------------- + -- Build_B -- + ------------- + + function Build_B + (Loc : Source_Ptr; + Decls : List_Id) return Entity_Id + is + B : constant Entity_Id := Make_Temporary (Loc, 'B'); + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => B, + Object_Definition => New_Reference_To (Standard_Boolean, Loc), + Expression => New_Reference_To (Standard_False, Loc))); + return B; + end Build_B; + + ------------- + -- Build_C -- + ------------- + + function Build_C + (Loc : Source_Ptr; + Decls : List_Id) return Entity_Id + is + C : constant Entity_Id := Make_Temporary (Loc, 'C'); + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => C, + Object_Definition => New_Reference_To (RTE (RE_Prim_Op_Kind), Loc))); + return C; + end Build_C; + + ------------------------- + -- Build_Cleanup_Block -- + ------------------------- + + function Build_Cleanup_Block + (Loc : Source_Ptr; + Blk_Ent : Entity_Id; + Stmts : List_Id; + Clean_Ent : Entity_Id) return Node_Id + is + Cleanup_Block : constant Node_Id := + Make_Block_Statement (Loc, + Identifier => New_Reference_To (Blk_Ent, Loc), + Declarations => No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts), + Is_Asynchronous_Call_Block => True); + + begin + Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent); + + return Cleanup_Block; + end Build_Cleanup_Block; + + ------------- + -- Build_K -- + ------------- + + function Build_K + (Loc : Source_Ptr; + Decls : List_Id; + Obj : Entity_Id) return Entity_Id + is + K : constant Entity_Id := Make_Temporary (Loc, 'K'); + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => K, + Object_Definition => + New_Reference_To (RTE (RE_Tagged_Kind), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Get_Tagged_Kind), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), Obj))))); + return K; + end Build_K; + + ------------- + -- Build_S -- + ------------- + + function Build_S + (Loc : Source_Ptr; + Decls : List_Id) return Entity_Id + is + S : constant Entity_Id := Make_Temporary (Loc, 'S'); + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => S, + Object_Definition => New_Reference_To (Standard_Integer, Loc))); + return S; + end Build_S; + + ------------------------ + -- Build_S_Assignment -- + ------------------------ + + function Build_S_Assignment + (Loc : Source_Ptr; + S : Entity_Id; + Obj : Entity_Id; + Call_Ent : Entity_Id) return Node_Id + is + begin + return + Make_Assignment_Statement (Loc, + Name => New_Reference_To (S, Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), Obj), + Make_Integer_Literal (Loc, DT_Position (Call_Ent))))); + end Build_S_Assignment; + +end Exp_Sel; diff --git a/gcc/ada/exp_sel.ads b/gcc/ada/exp_sel.ads new file mode 100644 index 000000000..a68459de9 --- /dev/null +++ b/gcc/ada/exp_sel.ads @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ S E L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Routines used in Chapter 9 for the expansion of dispatching triggers in +-- select statements (Ada 2005: AI-345) + +with Types; use Types; + +package Exp_Sel is + + function Build_Abort_Block + (Loc : Source_Ptr; + Abr_Blk_Ent : Entity_Id; + Cln_Blk_Ent : Entity_Id; + Blk : Node_Id) return Node_Id; + -- Generate: + -- begin + -- Blk + -- exception + -- when Abort_Signal => Abort_Undefer; + -- end; + -- Abr_Blk_Ent is the name of the generated block, Cln_Blk_Ent is the name + -- of the encapsulated cleanup block, Blk is the actual block name. + + function Build_B + (Loc : Source_Ptr; + Decls : List_Id) return Entity_Id; + -- Generate: + -- B : Boolean := False; + -- Append the object declaration to the list and return its defining + -- identifier. + + function Build_C + (Loc : Source_Ptr; + Decls : List_Id) return Entity_Id; + -- Generate: + -- C : Ada.Tags.Prim_Op_Kind; + -- Append the object declaration to the list and return its defining + -- identifier. + + function Build_Cleanup_Block + (Loc : Source_Ptr; + Blk_Ent : Entity_Id; + Stmts : List_Id; + Clean_Ent : Entity_Id) return Node_Id; + -- Generate: + -- declare + -- procedure _clean is + -- begin + -- ... + -- end _clean; + -- begin + -- Stmts + -- at end + -- _clean; + -- end; + -- Blk_Ent is the name of the generated block, Stmts is the list of + -- encapsulated statements and Clean_Ent is the parameter to the + -- _clean procedure. + + function Build_K + (Loc : Source_Ptr; + Decls : List_Id; + Obj : Entity_Id) return Entity_Id; + -- Generate + -- K : Ada.Tags.Tagged_Kind := + -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (Obj)); + -- where Obj is the pointer to a secondary table. Append the object + -- declaration to the list and return its defining identifier. + + function Build_S + (Loc : Source_Ptr; + Decls : List_Id) return Entity_Id; + -- Generate: + -- S : Integer; + -- Append the object declaration to the list and return its defining + -- identifier. + + function Build_S_Assignment + (Loc : Source_Ptr; + S : Entity_Id; + Obj : Entity_Id; + Call_Ent : Entity_Id) return Node_Id; + -- Generate: + -- S := Ada.Tags.Get_Offset_Index ( + -- Ada.Tags.Tag (Obj), DT_Position (Call_Ent)); + -- where Obj is the pointer to a secondary table, Call_Ent is the entity + -- of the dispatching call name. Return the generated assignment. + +end Exp_Sel; diff --git a/gcc/ada/exp_smem.adb b/gcc/ada/exp_smem.adb new file mode 100644 index 000000000..1f23ac1f9 --- /dev/null +++ b/gcc/ada/exp_smem.adb @@ -0,0 +1,391 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ S M E M -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Exp_Ch9; use Exp_Ch9; +with Exp_Util; use Exp_Util; +with Nmake; use Nmake; +with Namet; use Namet; +with Nlists; use Nlists; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Tbuild; use Tbuild; + +package body Exp_Smem is + + Insert_Node : Node_Id; + -- Node after which a write call is to be inserted + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Add_Read_Before (N : Node_Id); + -- Insert a Shared_Var_ROpen call for variable before node N + + procedure Add_Write_After (N : Node_Id); + -- Insert a Shared_Var_WOpen call for variable after the node + -- Insert_Node, as recorded by On_Lhs_Of_Assignment (where it points + -- to the assignment statement) or Is_Out_Actual (where it points to + -- the procedure call statement). + + procedure Build_Full_Name (E : Entity_Id; N : out String_Id); + -- Build the fully qualified string name of a shared variable + + function On_Lhs_Of_Assignment (N : Node_Id) return Boolean; + -- Determines if N is on the left hand of the assignment. This means + -- that either it is a simple variable, or it is a record or array + -- variable with a corresponding selected or indexed component on + -- the left side of an assignment. If the result is True, then + -- Insert_Node is set to point to the assignment + + function Is_Out_Actual (N : Node_Id) return Boolean; + -- In a similar manner, this function determines if N appears as an + -- OUT or IN OUT parameter to a procedure call. If the result is + -- True, then Insert_Node is set to point to the call. + + function Build_Shared_Var_Proc_Call + (Loc : Source_Ptr; + E : Node_Id; + N : Name_Id) return Node_Id; + -- Build a call to support procedure N for shared object E (provided by + -- the instance of System.Shared_Storage.Shared_Var_Procs associated to E). + + -------------------------------- + -- Build_Shared_Var_Proc_Call -- + -------------------------------- + + function Build_Shared_Var_Proc_Call + (Loc : Source_Ptr; + E : Entity_Id; + N : Name_Id) return Node_Id is + begin + return Make_Procedure_Call_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Shared_Var_Procs_Instance (E), Loc), + Selector_Name => Make_Identifier (Loc, N))); + end Build_Shared_Var_Proc_Call; + + --------------------- + -- Add_Read_Before -- + --------------------- + + procedure Add_Read_Before (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ent : constant Node_Id := Entity (N); + begin + if Present (Shared_Var_Procs_Instance (Ent)) then + Insert_Action (N, Build_Shared_Var_Proc_Call (Loc, Ent, Name_Read)); + end if; + end Add_Read_Before; + + ------------------------------- + -- Add_Shared_Var_Lock_Procs -- + ------------------------------- + + procedure Add_Shared_Var_Lock_Procs (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Obj : constant Entity_Id := Entity (Expression (First_Actual (N))); + Inode : Node_Id; + Vnm : String_Id; + + begin + -- We have to add Shared_Var_Lock and Shared_Var_Unlock calls around + -- the procedure or function call node. First we locate the right + -- place to do the insertion, which is the call itself in the + -- procedure call case, or else the nearest non subexpression + -- node that contains the function call. + + Inode := N; + while Nkind (Inode) /= N_Procedure_Call_Statement + and then Nkind (Inode) in N_Subexpr + loop + Inode := Parent (Inode); + end loop; + + -- Now insert the Lock and Unlock calls and the read/write calls + + -- Two concerns here. First we are not dealing with the exception + -- case, really we need some kind of cleanup routine to do the + -- Unlock. Second, these lock calls should be inside the protected + -- object processing, not outside, otherwise they can be done at + -- the wrong priority, resulting in dead lock situations ??? + + Build_Full_Name (Obj, Vnm); + + -- First insert the Lock call before + + Insert_Before_And_Analyze (Inode, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Shared_Var_Lock), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, Vnm)))); + + -- Now, right after the Lock, insert a call to read the object + + Insert_Before_And_Analyze (Inode, + Build_Shared_Var_Proc_Call (Loc, Obj, Name_Read)); + + -- Now insert the Unlock call after + + Insert_After_And_Analyze (Inode, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Shared_Var_Unlock), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, Vnm)))); + + -- Now for a procedure call, but not a function call, insert the + -- call to write the object just before the unlock. + + if Nkind (N) = N_Procedure_Call_Statement then + Insert_After_And_Analyze (Inode, + Build_Shared_Var_Proc_Call (Loc, Obj, Name_Write)); + end if; + + end Add_Shared_Var_Lock_Procs; + + --------------------- + -- Add_Write_After -- + --------------------- + + procedure Add_Write_After (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ent : constant Node_Id := Entity (N); + + begin + if Present (Shared_Var_Procs_Instance (Ent)) then + Insert_After_And_Analyze (Insert_Node, + Build_Shared_Var_Proc_Call (Loc, Ent, Name_Write)); + end if; + end Add_Write_After; + + --------------------- + -- Build_Full_Name -- + --------------------- + + procedure Build_Full_Name (E : Entity_Id; N : out String_Id) is + + procedure Build_Name (E : Entity_Id); + -- This is a recursive routine used to construct the fully qualified + -- string name of the package corresponding to the shared variable. + + ---------------- + -- Build_Name -- + ---------------- + + procedure Build_Name (E : Entity_Id) is + begin + if Scope (E) /= Standard_Standard then + Build_Name (Scope (E)); + Store_String_Char ('.'); + end if; + + Get_Decoded_Name_String (Chars (E)); + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + end Build_Name; + + -- Start of processing for Build_Full_Name + + begin + Start_String; + Build_Name (E); + N := End_String; + end Build_Full_Name; + + ------------------------------------ + -- Expand_Shared_Passive_Variable -- + ------------------------------------ + + procedure Expand_Shared_Passive_Variable (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + + begin + -- Nothing to do for protected or limited objects + + if Is_Limited_Type (Typ) or else Is_Concurrent_Type (Typ) then + return; + + -- If we are on the left hand side of an assignment, then we add + -- the write call after the assignment. + + elsif On_Lhs_Of_Assignment (N) then + Add_Write_After (N); + + -- If we are a parameter for an out or in out formal, then put + -- the read before and the write after. + + elsif Is_Out_Actual (N) then + Add_Read_Before (N); + Add_Write_After (N); + + -- All other cases are simple reads + + else + Add_Read_Before (N); + end if; + end Expand_Shared_Passive_Variable; + + ------------------- + -- Is_Out_Actual -- + ------------------- + + function Is_Out_Actual (N : Node_Id) return Boolean is + Formal : Entity_Id; + Call : Node_Id; + + begin + Find_Actual (N, Formal, Call); + + if No (Formal) then + return False; + + else + if Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter) then + Insert_Node := Call; + return True; + else + return False; + end if; + end if; + end Is_Out_Actual; + + --------------------------- + -- Make_Shared_Var_Procs -- + --------------------------- + + function Make_Shared_Var_Procs (N : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + Ent : constant Entity_Id := Defining_Identifier (N); + Typ : constant Entity_Id := Etype (Ent); + Vnm : String_Id; + Obj : Node_Id; + Obj_Typ : Entity_Id; + + After : constant Node_Id := Next (N); + -- Node located right after N originally (after insertion of the SV + -- procs this node is right after the last inserted node). + + SVP_Instance : constant Entity_Id := Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Ent), 'G')); + -- Instance of System.Shared_Storage.Shared_Var_Procs associated + -- with Ent. + + Instantiation : Node_Id; + -- Package instantiation node for SVP_Instance + + -- Start of processing for Make_Shared_Var_Procs + + begin + Build_Full_Name (Ent, Vnm); + + -- We turn off Shared_Passive during construction and analysis of + -- the generic package instantiation, to avoid improper attempts to + -- process the variable references within these instantiation. + + Set_Is_Shared_Passive (Ent, False); + + -- Construct generic package instantiation + + -- package varG is new Shared_Var_Procs (typ, var, "pkg.var"); + + Obj := New_Occurrence_Of (Ent, Loc); + Obj_Typ := Typ; + if Is_Concurrent_Type (Typ) then + Obj := Convert_Concurrent (N => Obj, Typ => Typ); + Obj_Typ := Corresponding_Record_Type (Typ); + end if; + + Instantiation := + Make_Package_Instantiation (Loc, + Defining_Unit_Name => SVP_Instance, + Name => + New_Occurrence_Of (RTE (RE_Shared_Var_Procs), Loc), + Generic_Associations => New_List ( + Make_Generic_Association (Loc, + Explicit_Generic_Actual_Parameter => + New_Occurrence_Of (Obj_Typ, Loc)), + Make_Generic_Association (Loc, + Explicit_Generic_Actual_Parameter => Obj), + Make_Generic_Association (Loc, + Explicit_Generic_Actual_Parameter => + Make_String_Literal (Loc, Vnm)))); + + Insert_After_And_Analyze (N, Instantiation); + + Set_Is_Shared_Passive (Ent, True); + Set_Shared_Var_Procs_Instance + (Ent, Defining_Entity (Instance_Spec (Instantiation))); + + -- Return last node before After + + declare + Nod : Node_Id := Next (N); + + begin + while Next (Nod) /= After loop + Nod := Next (Nod); + end loop; + + return Nod; + end; + end Make_Shared_Var_Procs; + + -------------------------- + -- On_Lhs_Of_Assignment -- + -------------------------- + + function On_Lhs_Of_Assignment (N : Node_Id) return Boolean is + P : constant Node_Id := Parent (N); + + begin + if Nkind (P) = N_Assignment_Statement then + if N = Name (P) then + Insert_Node := P; + return True; + else + return False; + end if; + + elsif (Nkind (P) = N_Indexed_Component + or else + Nkind (P) = N_Selected_Component) + and then N = Prefix (P) + then + return On_Lhs_Of_Assignment (P); + + else + return False; + end if; + end On_Lhs_Of_Assignment; + +end Exp_Smem; diff --git a/gcc/ada/exp_smem.ads b/gcc/ada/exp_smem.ads new file mode 100644 index 000000000..d17382551 --- /dev/null +++ b/gcc/ada/exp_smem.ads @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ S M E M -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 involved in the required expansions for +-- handling shared memory accesses for variables in Shared_Passive packages. + +-- See detailed documentation in System.Shared_Storage spec for a full +-- description of the approach that is taken for handling distributed +-- shared memory. This expansion unit in the compiler is responsible +-- for generating the calls to routines in System.Shared_Storage. + +with Types; use Types; +package Exp_Smem is + + procedure Expand_Shared_Passive_Variable (N : Node_Id); + -- N is the identifier for a shared passive variable. This routine is + -- responsible for determining if this is an assigned to N, or a + -- reference to N, and generating the required calls to the shared + -- memory read/write procedures. + + procedure Add_Shared_Var_Lock_Procs (N : Node_Id); + -- The argument is a protected subprogram call, before it is rewritten + -- by Exp_Ch9.Build_Protected_Subprogram_Call. This routine, which is + -- called only in the case of an external call to a protected object + -- that has Is_Shared_Passive set, deals with installing the required + -- global lock calls for this case. It also generates the necessary + -- read/write calls for the protected object within the lock region. + + function Make_Shared_Var_Procs (N : Node_Id) return Node_Id; + -- N is the node for the declaration of a shared passive variable. + -- This procedure constructs an instantiation of + -- System.Shared_Storage.Shared_Var_Procs that contains the read and + -- assignment procedures for the shared memory variable. + -- See System.Shared_Storage for a full description of these procedures + -- and how they are used. The last inserted node is returned. + +end Exp_Smem; diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb new file mode 100644 index 000000000..0a22b0117 --- /dev/null +++ b/gcc/ada/exp_strm.adb @@ -0,0 +1,1753 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ S T R 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem_Aux; use Sem_Aux; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; + +package body Exp_Strm is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Build_Array_Read_Write_Procedure + (Nod : Node_Id; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : Entity_Id; + Nam : Name_Id); + -- Common routine shared to build either an array Read procedure or an + -- array Write procedure, Nam is Name_Read or Name_Write to select which. + -- Pnam is the defining identifier for the constructed procedure. The + -- other parameters are as for Build_Array_Read_Procedure except that + -- the first parameter Nod supplies the Sloc to be used to generate code. + + procedure Build_Record_Read_Write_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : Entity_Id; + Nam : Name_Id); + -- Common routine shared to build a record Read Write procedure, Nam + -- is Name_Read or Name_Write to select which. Pnam is the defining + -- identifier for the constructed procedure. The other parameters are + -- as for Build_Record_Read_Procedure. + + procedure Build_Stream_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : Entity_Id; + Decls : List_Id; + Stms : List_Id); + -- Called to build an array or record stream function. The first three + -- arguments are the same as Build_Record_Or_Elementary_Input_Function. + -- Decls and Stms are the declarations and statements for the body and + -- The parameter Fnam is the name of the constructed function. + + function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean; + -- This function is used to test the type U_Type, to determine if it has + -- a standard representation from a streaming point of view. Standard means + -- that it has a standard representation (e.g. no enumeration rep clause), + -- and the size of the root type is the same as the streaming size (which + -- is defined as value specified by a Stream_Size clause if present, or + -- the Esize of U_Type if not). + + function Make_Stream_Subprogram_Name + (Loc : Source_Ptr; + Typ : Entity_Id; + Nam : TSS_Name_Type) return Entity_Id; + -- Return the entity that identifies the stream subprogram for type Typ + -- that is identified by the given Nam. This procedure deals with the + -- difference between tagged types (where a single subprogram associated + -- with the type is generated) and all other cases (where a subprogram + -- is generated at the point of the stream attribute reference). The + -- Loc parameter is used as the Sloc of the created entity. + + function Stream_Base_Type (E : Entity_Id) return Entity_Id; + -- Stream attributes work on the basis of the base type except for the + -- array case. For the array case, we do not go to the base type, but + -- to the first subtype if it is constrained. This avoids problems with + -- incorrect conversions in the packed array case. Stream_Base_Type is + -- exactly this function (returns the base type, unless we have an array + -- type whose first subtype is constrained, in which case it returns the + -- first subtype). + + -------------------------------- + -- Build_Array_Input_Function -- + -------------------------------- + + -- The function we build looks like + + -- function typSI[_nnn] (S : access RST) return Typ is + -- L1 : constant Index_Type_1 := Index_Type_1'Input (S); + -- H1 : constant Index_Type_1 := Index_Type_1'Input (S); + -- L2 : constant Index_Type_2 := Index_Type_2'Input (S); + -- H2 : constant Index_Type_2 := Index_Type_2'Input (S); + -- .. + -- Ln : constant Index_Type_n := Index_Type_n'Input (S); + -- Hn : constant Index_Type_n := Index_Type_n'Input (S); + -- + -- V : Typ'Base (L1 .. H1, L2 .. H2, ... Ln .. Hn) + + -- begin + -- Typ'Read (S, V); + -- return V; + -- end typSI[_nnn] + + -- Note: the suffix [_nnn] is present for non-tagged types, where we + -- generate a local subprogram at the point of the occurrence of the + -- attribute reference, so the name must be unique. + + procedure Build_Array_Input_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id) + is + Dim : constant Pos := Number_Dimensions (Typ); + Lnam : Name_Id; + Hnam : Name_Id; + Decls : List_Id; + Ranges : List_Id; + Stms : List_Id; + Indx : Node_Id; + + begin + Decls := New_List; + Ranges := New_List; + Indx := First_Index (Typ); + + for J in 1 .. Dim loop + Lnam := New_External_Name ('L', J); + Hnam := New_External_Name ('H', J); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Lnam), + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Etype (Indx), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc), + Attribute_Name => Name_Input, + Expressions => New_List (Make_Identifier (Loc, Name_S))))); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Hnam), + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc), + Attribute_Name => Name_Input, + Expressions => New_List (Make_Identifier (Loc, Name_S))))); + + Append_To (Ranges, + Make_Range (Loc, + Low_Bound => Make_Identifier (Loc, Lnam), + High_Bound => Make_Identifier (Loc, Hnam))); + + Next_Index (Indx); + end loop; + + -- If the first subtype is constrained, use it directly. Otherwise + -- build a subtype indication with the proper bounds. + + if Is_Constrained (Stream_Base_Type (Typ)) then + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Object_Definition => + New_Occurrence_Of (Stream_Base_Type (Typ), Loc))); + else + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Stream_Base_Type (Typ), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Ranges)))); + end if; + + Stms := New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Identifier (Loc, Name_V))), + + Make_Simple_Return_Statement (Loc, + Expression => Make_Identifier (Loc, Name_V))); + + Fnam := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Input)); + + Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms); + end Build_Array_Input_Function; + + ---------------------------------- + -- Build_Array_Output_Procedure -- + ---------------------------------- + + procedure Build_Array_Output_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + Stms : List_Id; + Indx : Node_Id; + + begin + -- Build series of statements to output bounds + + Indx := First_Index (Typ); + Stms := New_List; + + for J in 1 .. Number_Dimensions (Typ) loop + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Attribute_Name => Name_First, + Expressions => New_List ( + Make_Integer_Literal (Loc, J)))))); + + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Attribute_Name => Name_Last, + Expressions => New_List ( + Make_Integer_Literal (Loc, J)))))); + + Next_Index (Indx); + end loop; + + -- Append Write attribute to write array elements + + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Identifier (Loc, Name_V)))); + + Pnam := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Output)); + + Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False); + end Build_Array_Output_Procedure; + + -------------------------------- + -- Build_Array_Read_Procedure -- + -------------------------------- + + procedure Build_Array_Read_Procedure + (Nod : Node_Id; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + Loc : constant Source_Ptr := Sloc (Nod); + + begin + Pnam := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read)); + Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Read); + end Build_Array_Read_Procedure; + + -------------------------------------- + -- Build_Array_Read_Write_Procedure -- + -------------------------------------- + + -- The form of the array read/write procedure is as follows: + + -- procedure pnam (S : access RST, V : [out] Typ) is + -- begin + -- for L1 in V'Range (1) loop + -- for L2 in V'Range (2) loop + -- ... + -- for Ln in V'Range (n) loop + -- Component_Type'Read/Write (S, V (L1, L2, .. Ln)); + -- end loop; + -- .. + -- end loop; + -- end loop + -- end pnam; + + -- The out keyword for V is supplied in the Read case + + procedure Build_Array_Read_Write_Procedure + (Nod : Node_Id; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : Entity_Id; + Nam : Name_Id) + is + Loc : constant Source_Ptr := Sloc (Nod); + Ndim : constant Pos := Number_Dimensions (Typ); + Ctyp : constant Entity_Id := Component_Type (Typ); + + Stm : Node_Id; + Exl : List_Id; + RW : Entity_Id; + + begin + -- First build the inner attribute call + + Exl := New_List; + + for J in 1 .. Ndim loop + Append_To (Exl, Make_Identifier (Loc, New_External_Name ('L', J))); + end loop; + + Stm := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stream_Base_Type (Ctyp), Loc), + Attribute_Name => Nam, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Indexed_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Expressions => Exl))); + + -- The corresponding stream attribute for the component type of the + -- array may be user-defined, and be frozen after the type for which + -- we are generating the stream subprogram. In that case, freeze the + -- stream attribute of the component type, whose declaration could not + -- generate any additional freezing actions in any case. + + if Nam = Name_Read then + RW := TSS (Base_Type (Ctyp), TSS_Stream_Read); + else + RW := TSS (Base_Type (Ctyp), TSS_Stream_Write); + end if; + + if Present (RW) + and then not Is_Frozen (RW) + then + Set_Is_Frozen (RW); + end if; + + -- Now this is the big loop to wrap that statement up in a sequence + -- of loops. The first time around, Stm is the attribute call. The + -- second and subsequent times, Stm is an inner loop. + + for J in 1 .. Ndim loop + Stm := + Make_Implicit_Loop_Statement (Nod, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => New_External_Name ('L', Ndim - J + 1)), + + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Attribute_Name => Name_Range, + + Expressions => New_List ( + Make_Integer_Literal (Loc, Ndim - J + 1))))), + + Statements => New_List (Stm)); + + end loop; + + Build_Stream_Procedure + (Loc, Typ, Decl, Pnam, New_List (Stm), Nam = Name_Read); + end Build_Array_Read_Write_Procedure; + + --------------------------------- + -- Build_Array_Write_Procedure -- + --------------------------------- + + procedure Build_Array_Write_Procedure + (Nod : Node_Id; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + Loc : constant Source_Ptr := Sloc (Nod); + + begin + Pnam := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write)); + Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Write); + end Build_Array_Write_Procedure; + + --------------------------------- + -- Build_Elementary_Input_Call -- + --------------------------------- + + function Build_Elementary_Input_Call (N : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + P_Type : constant Entity_Id := Entity (Prefix (N)); + U_Type : constant Entity_Id := Underlying_Type (P_Type); + Rt_Type : constant Entity_Id := Root_Type (U_Type); + FST : constant Entity_Id := First_Subtype (U_Type); + Strm : constant Node_Id := First (Expressions (N)); + Targ : constant Node_Id := Next (Strm); + P_Size : Uint; + Res : Node_Id; + Lib_RE : RE_Id; + + begin + Check_Restriction (No_Default_Stream_Attributes, N); + + -- Compute the size of the stream element. This is either the size of + -- the first subtype or if given the size of the Stream_Size attribute. + + if Has_Stream_Size_Clause (FST) then + P_Size := Static_Integer (Expression (Stream_Size_Clause (FST))); + else + P_Size := Esize (FST); + end if; + + -- Check first for Boolean and Character. These are enumeration types, + -- but we treat them specially, since they may require special handling + -- in the transfer protocol. However, this special handling only applies + -- if they have standard representation, otherwise they are treated like + -- any other enumeration type. + + if Rt_Type = Standard_Boolean + and then Has_Stream_Standard_Rep (U_Type) + then + Lib_RE := RE_I_B; + + elsif Rt_Type = Standard_Character + and then Has_Stream_Standard_Rep (U_Type) + then + Lib_RE := RE_I_C; + + elsif Rt_Type = Standard_Wide_Character + and then Has_Stream_Standard_Rep (U_Type) + then + Lib_RE := RE_I_WC; + + elsif Rt_Type = Standard_Wide_Wide_Character + and then Has_Stream_Standard_Rep (U_Type) + then + Lib_RE := RE_I_WWC; + + -- Floating point types + + elsif Is_Floating_Point_Type (U_Type) then + + -- Question: should we use P_Size or Rt_Type to distinguish between + -- possible floating point types? If a non-standard size or a stream + -- size is specified, then we should certainly use the size. But if + -- we have two types the same (notably Short_Float_Size = Float_Size + -- which is close to universally true, and Long_Long_Float_Size = + -- Long_Float_Size, true on most targets except the x86), then we + -- would really rather use the root type, so that if people want to + -- fiddle with System.Stream_Attributes to get inter-target portable + -- streams, they get the size they expect. Consider in particular the + -- case of a stream written on an x86, with 96-bit Long_Long_Float + -- being read into a non-x86 target with 64 bit Long_Long_Float. A + -- special version of System.Stream_Attributes can deal with this + -- provided the proper type is always used. + + -- To deal with these two requirements we add the special checks + -- on equal sizes and use the root type to distinguish. + + if P_Size <= Standard_Short_Float_Size + and then (Standard_Short_Float_Size /= Standard_Float_Size + or else Rt_Type = Standard_Short_Float) + then + Lib_RE := RE_I_SF; + + elsif P_Size <= Standard_Float_Size then + Lib_RE := RE_I_F; + + elsif P_Size <= Standard_Long_Float_Size + and then (Standard_Long_Float_Size /= Standard_Long_Long_Float_Size + or else Rt_Type = Standard_Long_Float) + then + Lib_RE := RE_I_LF; + + else + Lib_RE := RE_I_LLF; + end if; + + -- Signed integer types. Also includes signed fixed-point types and + -- enumeration types with a signed representation. + + -- Note on signed integer types. We do not consider types as signed for + -- this purpose if they have no negative numbers, or if they have biased + -- representation. The reason is that the value in either case basically + -- represents an unsigned value. + + -- For example, consider: + + -- type W is range 0 .. 2**32 - 1; + -- for W'Size use 32; + + -- This is a signed type, but the representation is unsigned, and may + -- be outside the range of a 32-bit signed integer, so this must be + -- treated as 32-bit unsigned. + + -- Similarly, if we have + + -- type W is range -1 .. +254; + -- for W'Size use 8; + + -- then the representation is unsigned + + elsif not Is_Unsigned_Type (FST) + and then + (Is_Fixed_Point_Type (U_Type) + or else + Is_Enumeration_Type (U_Type) + or else + (Is_Signed_Integer_Type (U_Type) + and then not Has_Biased_Representation (FST))) + then + if P_Size <= Standard_Short_Short_Integer_Size then + Lib_RE := RE_I_SSI; + + elsif P_Size <= Standard_Short_Integer_Size then + Lib_RE := RE_I_SI; + + elsif P_Size <= Standard_Integer_Size then + Lib_RE := RE_I_I; + + elsif P_Size <= Standard_Long_Integer_Size then + Lib_RE := RE_I_LI; + + else + Lib_RE := RE_I_LLI; + end if; + + -- Unsigned integer types, also includes unsigned fixed-point types + -- and enumeration types with an unsigned representation (note that + -- we know they are unsigned because we already tested for signed). + + -- Also includes signed integer types that are unsigned in the sense + -- that they do not include negative numbers. See above for details. + + elsif Is_Modular_Integer_Type (U_Type) + or else Is_Fixed_Point_Type (U_Type) + or else Is_Enumeration_Type (U_Type) + or else Is_Signed_Integer_Type (U_Type) + then + if P_Size <= Standard_Short_Short_Integer_Size then + Lib_RE := RE_I_SSU; + + elsif P_Size <= Standard_Short_Integer_Size then + Lib_RE := RE_I_SU; + + elsif P_Size <= Standard_Integer_Size then + Lib_RE := RE_I_U; + + elsif P_Size <= Standard_Long_Integer_Size then + Lib_RE := RE_I_LU; + + else + Lib_RE := RE_I_LLU; + end if; + + else pragma Assert (Is_Access_Type (U_Type)); + if P_Size > System_Address_Size then + Lib_RE := RE_I_AD; + else + Lib_RE := RE_I_AS; + end if; + end if; + + -- Call the function, and do an unchecked conversion of the result + -- to the actual type of the prefix. If the target is a discriminant, + -- and we are in the body of the default implementation of a 'Read + -- attribute, set target type to force a constraint check (13.13.2(35)). + -- If the type of the discriminant is currently private, add another + -- unchecked conversion from the full view. + + if Nkind (Targ) = N_Identifier + and then Is_Internal_Name (Chars (Targ)) + and then Is_TSS (Scope (Entity (Targ)), TSS_Stream_Read) + then + Res := + Unchecked_Convert_To (Base_Type (U_Type), + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Lib_RE), Loc), + Parameter_Associations => New_List ( + Relocate_Node (Strm)))); + + Set_Do_Range_Check (Res); + if Base_Type (P_Type) /= Base_Type (U_Type) then + Res := Unchecked_Convert_To (Base_Type (P_Type), Res); + end if; + + return Res; + + else + return + Unchecked_Convert_To (P_Type, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Lib_RE), Loc), + Parameter_Associations => New_List ( + Relocate_Node (Strm)))); + end if; + end Build_Elementary_Input_Call; + + --------------------------------- + -- Build_Elementary_Write_Call -- + --------------------------------- + + function Build_Elementary_Write_Call (N : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + P_Type : constant Entity_Id := Entity (Prefix (N)); + U_Type : constant Entity_Id := Underlying_Type (P_Type); + Rt_Type : constant Entity_Id := Root_Type (U_Type); + FST : constant Entity_Id := First_Subtype (U_Type); + Strm : constant Node_Id := First (Expressions (N)); + Item : constant Node_Id := Next (Strm); + P_Size : Uint; + Lib_RE : RE_Id; + Libent : Entity_Id; + + begin + Check_Restriction (No_Default_Stream_Attributes, N); + + -- Compute the size of the stream element. This is either the size of + -- the first subtype or if given the size of the Stream_Size attribute. + + if Has_Stream_Size_Clause (FST) then + P_Size := Static_Integer (Expression (Stream_Size_Clause (FST))); + else + P_Size := Esize (FST); + end if; + + -- Find the routine to be called + + -- Check for First Boolean and Character. These are enumeration types, + -- but we treat them specially, since they may require special handling + -- in the transfer protocol. However, this special handling only applies + -- if they have standard representation, otherwise they are treated like + -- any other enumeration type. + + if Rt_Type = Standard_Boolean + and then Has_Stream_Standard_Rep (U_Type) + then + Lib_RE := RE_W_B; + + elsif Rt_Type = Standard_Character + and then Has_Stream_Standard_Rep (U_Type) + then + Lib_RE := RE_W_C; + + elsif Rt_Type = Standard_Wide_Character + and then Has_Stream_Standard_Rep (U_Type) + then + Lib_RE := RE_W_WC; + + elsif Rt_Type = Standard_Wide_Wide_Character + and then Has_Stream_Standard_Rep (U_Type) + then + Lib_RE := RE_W_WWC; + + -- Floating point types + + elsif Is_Floating_Point_Type (U_Type) then + + -- Question: should we use P_Size or Rt_Type to distinguish between + -- possible floating point types? If a non-standard size or a stream + -- size is specified, then we should certainly use the size. But if + -- we have two types the same (notably Short_Float_Size = Float_Size + -- which is close to universally true, and Long_Long_Float_Size = + -- Long_Float_Size, true on most targets except the x86), then we + -- would really rather use the root type, so that if people want to + -- fiddle with System.Stream_Attributes to get inter-target portable + -- streams, they get the size they expect. Consider in particular the + -- case of a stream written on an x86, with 96-bit Long_Long_Float + -- being read into a non-x86 target with 64 bit Long_Long_Float. A + -- special version of System.Stream_Attributes can deal with this + -- provided the proper type is always used. + + -- To deal with these two requirements we add the special checks + -- on equal sizes and use the root type to distinguish. + + if P_Size <= Standard_Short_Float_Size + and then (Standard_Short_Float_Size /= Standard_Float_Size + or else Rt_Type = Standard_Short_Float) + then + Lib_RE := RE_W_SF; + + elsif P_Size <= Standard_Float_Size then + Lib_RE := RE_W_F; + + elsif P_Size <= Standard_Long_Float_Size + and then (Standard_Long_Float_Size /= Standard_Long_Long_Float_Size + or else Rt_Type = Standard_Long_Float) + then + Lib_RE := RE_W_LF; + + else + Lib_RE := RE_W_LLF; + end if; + + -- Signed integer types. Also includes signed fixed-point types and + -- signed enumeration types share this circuitry. + + -- Note on signed integer types. We do not consider types as signed for + -- this purpose if they have no negative numbers, or if they have biased + -- representation. The reason is that the value in either case basically + -- represents an unsigned value. + + -- For example, consider: + + -- type W is range 0 .. 2**32 - 1; + -- for W'Size use 32; + + -- This is a signed type, but the representation is unsigned, and may + -- be outside the range of a 32-bit signed integer, so this must be + -- treated as 32-bit unsigned. + + -- Similarly, the representation is also unsigned if we have: + + -- type W is range -1 .. +254; + -- for W'Size use 8; + + -- forcing a biased and unsigned representation + + elsif not Is_Unsigned_Type (FST) + and then + (Is_Fixed_Point_Type (U_Type) + or else + Is_Enumeration_Type (U_Type) + or else + (Is_Signed_Integer_Type (U_Type) + and then not Has_Biased_Representation (FST))) + then + if P_Size <= Standard_Short_Short_Integer_Size then + Lib_RE := RE_W_SSI; + elsif P_Size <= Standard_Short_Integer_Size then + Lib_RE := RE_W_SI; + elsif P_Size <= Standard_Integer_Size then + Lib_RE := RE_W_I; + elsif P_Size <= Standard_Long_Integer_Size then + Lib_RE := RE_W_LI; + else + Lib_RE := RE_W_LLI; + end if; + + -- Unsigned integer types, also includes unsigned fixed-point types + -- and unsigned enumeration types (note we know they are unsigned + -- because we already tested for signed above). + + -- Also includes signed integer types that are unsigned in the sense + -- that they do not include negative numbers. See above for details. + + elsif Is_Modular_Integer_Type (U_Type) + or else Is_Fixed_Point_Type (U_Type) + or else Is_Enumeration_Type (U_Type) + or else Is_Signed_Integer_Type (U_Type) + then + if P_Size <= Standard_Short_Short_Integer_Size then + Lib_RE := RE_W_SSU; + elsif P_Size <= Standard_Short_Integer_Size then + Lib_RE := RE_W_SU; + elsif P_Size <= Standard_Integer_Size then + Lib_RE := RE_W_U; + elsif P_Size <= Standard_Long_Integer_Size then + Lib_RE := RE_W_LU; + else + Lib_RE := RE_W_LLU; + end if; + + else pragma Assert (Is_Access_Type (U_Type)); + + if P_Size > System_Address_Size then + Lib_RE := RE_W_AD; + else + Lib_RE := RE_W_AS; + end if; + end if; + + -- Unchecked-convert parameter to the required type (i.e. the type of + -- the corresponding parameter, and call the appropriate routine. + + Libent := RTE (Lib_RE); + + return + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Libent, Loc), + Parameter_Associations => New_List ( + Relocate_Node (Strm), + Unchecked_Convert_To (Etype (Next_Formal (First_Formal (Libent))), + Relocate_Node (Item)))); + end Build_Elementary_Write_Call; + + ----------------------------------------- + -- Build_Mutable_Record_Read_Procedure -- + ----------------------------------------- + + procedure Build_Mutable_Record_Read_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + Out_Formal : Node_Id; + -- Expression denoting the out formal parameter + + Dcls : constant List_Id := New_List; + -- Declarations for the 'Read body + + Stms : List_Id := New_List; + -- Statements for the 'Read body + + Disc : Entity_Id; + -- Entity of the discriminant being processed + + Tmp_For_Disc : Entity_Id; + -- Temporary object used to read the value of Disc + + Tmps_For_Discs : constant List_Id := New_List; + -- List of object declarations for temporaries holding the read values + -- for the discriminants. + + Cstr : constant List_Id := New_List; + -- List of constraints to be applied on temporary record + + Discriminant_Checks : constant List_Id := New_List; + -- List of discriminant checks to be performed if the actual object + -- is constrained. + + Tmp : constant Entity_Id := Make_Defining_Identifier (Loc, Name_V); + -- Temporary record must hide formal (assignments to components of the + -- record are always generated with V as the identifier for the record). + + Constrained_Stms : List_Id := New_List; + -- Statements within the block where we have the constrained temporary + + begin + + Disc := First_Discriminant (Typ); + + -- A mutable type cannot be a tagged type, so we generate a new name + -- for the stream procedure. + + Pnam := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read)); + + Out_Formal := + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Pnam, Loc), + Selector_Name => Make_Identifier (Loc, Name_V)); + + -- Generate Reads for the discriminants of the type. The discriminants + -- need to be read before the rest of the components, so that + -- variants are initialized correctly. The discriminants must be read + -- into temporary variables so an incomplete Read (interrupted by an + -- exception, for example) does not alter the passed object. + + while Present (Disc) loop + Tmp_For_Disc := Make_Defining_Identifier (Loc, + New_External_Name (Chars (Disc), "D")); + + Append_To (Tmps_For_Discs, + Make_Object_Declaration (Loc, + Defining_Identifier => Tmp_For_Disc, + Object_Definition => New_Occurrence_Of (Etype (Disc), Loc))); + Set_No_Initialization (Last (Tmps_For_Discs)); + + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etype (Disc), Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + New_Occurrence_Of (Tmp_For_Disc, Loc)))); + + Append_To (Cstr, + Make_Discriminant_Association (Loc, + Selector_Names => New_List (New_Occurrence_Of (Disc, Loc)), + Expression => New_Occurrence_Of (Tmp_For_Disc, Loc))); + + Append_To (Discriminant_Checks, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Occurrence_Of (Tmp_For_Disc, Loc), + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Out_Formal), + Selector_Name => New_Occurrence_Of (Disc, Loc))), + Reason => CE_Discriminant_Check_Failed)); + Next_Discriminant (Disc); + end loop; + + -- Generate reads for the components of the record (including + -- those that depend on discriminants). + + Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read); + + -- If Typ has controlled components (i.e. if it is classwide + -- or Has_Controlled), or components constrained using the discriminants + -- of Typ, then we need to ensure that all component assignments + -- are performed on an object that has been appropriately constrained + -- prior to being initialized. To this effect, we wrap the component + -- assignments in a block where V is a constrained temporary. + + Append_To (Dcls, + Make_Object_Declaration (Loc, + Defining_Identifier => Tmp, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Cstr)))); + + Constrained_Stms := Statements (Handled_Statement_Sequence (Decl)); + Append_To (Stms, + Make_Block_Statement (Loc, + Declarations => Dcls, + Handled_Statement_Sequence => Parent (Constrained_Stms))); + + Append_To (Constrained_Stms, + Make_Implicit_If_Statement (Pnam, + Condition => + Make_Attribute_Reference (Loc, + Prefix => New_Copy_Tree (Out_Formal), + Attribute_Name => Name_Constrained), + Then_Statements => Discriminant_Checks)); + + Append_To (Constrained_Stms, + Make_Assignment_Statement (Loc, + Name => Out_Formal, + Expression => Make_Identifier (Loc, Name_V))); + + if Is_Unchecked_Union (Typ) then + + -- If this is an unchecked union, the stream procedure is erroneous, + -- because there are no discriminants to read. + + -- This should generate a warning ??? + + Stms := + New_List ( + Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction)); + end if; + + Set_Declarations (Decl, Tmps_For_Discs); + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stms)); + end Build_Mutable_Record_Read_Procedure; + + ------------------------------------------ + -- Build_Mutable_Record_Write_Procedure -- + ------------------------------------------ + + procedure Build_Mutable_Record_Write_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + Stms : List_Id; + Disc : Entity_Id; + D_Ref : Node_Id; + + begin + Stms := New_List; + Disc := First_Discriminant (Typ); + + -- Generate Writes for the discriminants of the type + -- If the type is an unchecked union, use the default values of + -- the discriminants, because they are not stored. + + while Present (Disc) loop + if Is_Unchecked_Union (Typ) then + D_Ref := + New_Copy_Tree (Discriminant_Default_Value (Disc)); + else + D_Ref := + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Selector_Name => New_Occurrence_Of (Disc, Loc)); + end if; + + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etype (Disc), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + D_Ref))); + + Next_Discriminant (Disc); + end loop; + + -- A mutable type cannot be a tagged type, so we generate a new name + -- for the stream procedure. + + Pnam := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write)); + Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write); + + -- Write the discriminants before the rest of the components, so + -- that discriminant values are properly set of variants, etc. + + if Is_Non_Empty_List ( + Statements (Handled_Statement_Sequence (Decl))) + then + Insert_List_Before + (First (Statements (Handled_Statement_Sequence (Decl))), Stms); + else + Set_Statements (Handled_Statement_Sequence (Decl), Stms); + end if; + end Build_Mutable_Record_Write_Procedure; + + ----------------------------------------------- + -- Build_Record_Or_Elementary_Input_Function -- + ----------------------------------------------- + + -- The function we build looks like + + -- function InputN (S : access RST) return Typ is + -- C1 : constant Disc_Type_1; + -- Discr_Type_1'Read (S, C1); + -- C2 : constant Disc_Type_2; + -- Discr_Type_2'Read (S, C2); + -- ... + -- Cn : constant Disc_Type_n; + -- Discr_Type_n'Read (S, Cn); + -- V : Typ (C1, C2, .. Cn) + + -- begin + -- Typ'Read (S, V); + -- return V; + -- end InputN + + -- The discriminants are of course only present in the case of a record + -- with discriminants. In the case of a record with no discriminants, or + -- an elementary type, then no Cn constants are defined. + + procedure Build_Record_Or_Elementary_Input_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id) + is + Cn : Name_Id; + J : Pos; + Decls : List_Id; + Constr : List_Id; + Obj_Decl : Node_Id; + Stms : List_Id; + Discr : Entity_Id; + Odef : Node_Id; + + begin + Decls := New_List; + Constr := New_List; + + J := 1; + + if Has_Discriminants (Typ) then + Discr := First_Discriminant (Typ); + + while Present (Discr) loop + Cn := New_External_Name ('C', J); + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Cn), + Object_Definition => + New_Occurrence_Of (Etype (Discr), Loc)); + + -- If this is an access discriminant, do not perform default + -- initialization. The discriminant is about to get its value + -- from Read, and if the type is null excluding we do not want + -- spurious warnings on an initial null value. + + if Is_Access_Type (Etype (Discr)) then + Set_No_Initialization (Decl); + end if; + + Append_To (Decls, Decl); + Append_To (Decls, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etype (Discr), Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Identifier (Loc, Cn)))); + + Append_To (Constr, Make_Identifier (Loc, Cn)); + + Next_Discriminant (Discr); + J := J + 1; + end loop; + + Odef := + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Constr)); + + -- If no discriminants, then just use the type with no constraint + + else + Odef := New_Occurrence_Of (Typ, Loc); + end if; + + -- For Ada 2005 we create an extended return statement encapsulating + -- the result object and 'Read call, which is needed in general for + -- proper handling of build-in-place results (such as when the result + -- type is inherently limited). + + -- Perhaps we should just generate an extended return in all cases??? + + Obj_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Object_Definition => Odef); + + -- If the type is an access type, do not perform default initialization. + -- The object is about to get its value from Read, and if the type is + -- null excluding we do not want spurious warnings on an initial null. + + if Is_Access_Type (Typ) then + Set_No_Initialization (Obj_Decl); + end if; + + if Ada_Version >= Ada_2005 then + Stms := New_List ( + Make_Extended_Return_Statement (Loc, + Return_Object_Declarations => New_List (Obj_Decl), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + New_List (Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Identifier (Loc, Name_V))))))); + + else + Append_To (Decls, Obj_Decl); + + Stms := New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Identifier (Loc, Name_V))), + + Make_Simple_Return_Statement (Loc, + Expression => Make_Identifier (Loc, Name_V))); + end if; + + Fnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Input); + + Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms); + end Build_Record_Or_Elementary_Input_Function; + + ------------------------------------------------- + -- Build_Record_Or_Elementary_Output_Procedure -- + ------------------------------------------------- + + procedure Build_Record_Or_Elementary_Output_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + Stms : List_Id; + Disc : Entity_Id; + Disc_Ref : Node_Id; + + begin + Stms := New_List; + + -- Note that of course there will be no discriminants for the + -- elementary type case, so Has_Discriminants will be False. + + if Has_Discriminants (Typ) then + Disc := First_Discriminant (Typ); + + while Present (Disc) loop + + -- If the type is an unchecked union, it must have default + -- discriminants (this is checked earlier), and those defaults + -- are written out to the stream. + + if Is_Unchecked_Union (Typ) then + Disc_Ref := New_Copy_Tree (Discriminant_Default_Value (Disc)); + + else + Disc_Ref := + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Selector_Name => New_Occurrence_Of (Disc, Loc)); + end if; + + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Base_Type (Etype (Disc)), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Disc_Ref))); + + Next_Discriminant (Disc); + end loop; + end if; + + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Identifier (Loc, Name_V)))); + + Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Output); + + Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False); + end Build_Record_Or_Elementary_Output_Procedure; + + --------------------------------- + -- Build_Record_Read_Procedure -- + --------------------------------- + + procedure Build_Record_Read_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + begin + Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Read); + Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read); + end Build_Record_Read_Procedure; + + --------------------------------------- + -- Build_Record_Read_Write_Procedure -- + --------------------------------------- + + -- The form of the record read/write procedure is as shown by the + -- following example for a case with one discriminant case variant: + + -- procedure pnam (S : access RST, V : [out] Typ) is + -- begin + -- Component_Type'Read/Write (S, V.component); + -- Component_Type'Read/Write (S, V.component); + -- ... + -- Component_Type'Read/Write (S, V.component); + -- + -- case V.discriminant is + -- when choices => + -- Component_Type'Read/Write (S, V.component); + -- Component_Type'Read/Write (S, V.component); + -- ... + -- Component_Type'Read/Write (S, V.component); + -- + -- when choices => + -- Component_Type'Read/Write (S, V.component); + -- Component_Type'Read/Write (S, V.component); + -- ... + -- Component_Type'Read/Write (S, V.component); + -- ... + -- end case; + -- end pnam; + + -- The out keyword for V is supplied in the Read case + + procedure Build_Record_Read_Write_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : Entity_Id; + Nam : Name_Id) + is + Rdef : Node_Id; + Stms : List_Id; + Typt : Entity_Id; + + In_Limited_Extension : Boolean := False; + -- Set to True while processing the record extension definition + -- for an extension of a limited type (for which an ancestor type + -- has an explicit Nam attribute definition). + + function Make_Component_List_Attributes (CL : Node_Id) return List_Id; + -- Returns a sequence of attributes to process the components that + -- are referenced in the given component list. + + function Make_Field_Attribute (C : Entity_Id) return Node_Id; + -- Given C, the entity for a discriminant or component, build + -- an attribute for the corresponding field values. + + function Make_Field_Attributes (Clist : List_Id) return List_Id; + -- Given Clist, a component items list, construct series of attributes + -- for fieldwise processing of the corresponding components. + + ------------------------------------ + -- Make_Component_List_Attributes -- + ------------------------------------ + + function Make_Component_List_Attributes (CL : Node_Id) return List_Id is + CI : constant List_Id := Component_Items (CL); + VP : constant Node_Id := Variant_Part (CL); + + Result : List_Id; + Alts : List_Id; + V : Node_Id; + DC : Node_Id; + DCH : List_Id; + D_Ref : Node_Id; + + begin + Result := Make_Field_Attributes (CI); + + if Present (VP) then + Alts := New_List; + + V := First_Non_Pragma (Variants (VP)); + while Present (V) loop + DCH := New_List; + + DC := First (Discrete_Choices (V)); + while Present (DC) loop + Append_To (DCH, New_Copy_Tree (DC)); + Next (DC); + end loop; + + Append_To (Alts, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => DCH, + Statements => + Make_Component_List_Attributes (Component_List (V)))); + Next_Non_Pragma (V); + end loop; + + -- Note: in the following, we make sure that we use new occurrence + -- of for the selector, since there are cases in which we make a + -- reference to a hidden discriminant that is not visible. + + -- If the enclosing record is an unchecked_union, we use the + -- default expressions for the discriminant (it must exist) + -- because we cannot generate a reference to it, given that + -- it is not stored. + + if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then + D_Ref := + New_Copy_Tree + (Discriminant_Default_Value (Entity (Name (VP)))); + else + D_Ref := + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Selector_Name => + New_Occurrence_Of (Entity (Name (VP)), Loc)); + end if; + + Append_To (Result, + Make_Case_Statement (Loc, + Expression => D_Ref, + Alternatives => Alts)); + end if; + + return Result; + end Make_Component_List_Attributes; + + -------------------------- + -- Make_Field_Attribute -- + -------------------------- + + function Make_Field_Attribute (C : Entity_Id) return Node_Id is + Field_Typ : constant Entity_Id := Stream_Base_Type (Etype (C)); + + TSS_Names : constant array (Name_Input .. Name_Write) of + TSS_Name_Type := + (Name_Read => TSS_Stream_Read, + Name_Write => TSS_Stream_Write, + Name_Input => TSS_Stream_Input, + Name_Output => TSS_Stream_Output, + others => TSS_Null); + pragma Assert (TSS_Names (Nam) /= TSS_Null); + + begin + if In_Limited_Extension + and then Is_Limited_Type (Field_Typ) + and then No (Find_Inherited_TSS (Field_Typ, TSS_Names (Nam))) + then + -- The declaration is illegal per 13.13.2(9/1), and this is + -- enforced in Exp_Ch3.Check_Stream_Attributes. Keep the caller + -- happy by returning a null statement. + + return Make_Null_Statement (Loc); + end if; + + return + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Field_Typ, Loc), + Attribute_Name => Nam, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Selector_Name => New_Occurrence_Of (C, Loc)))); + end Make_Field_Attribute; + + --------------------------- + -- Make_Field_Attributes -- + --------------------------- + + function Make_Field_Attributes (Clist : List_Id) return List_Id is + Item : Node_Id; + Result : List_Id; + + begin + Result := New_List; + + if Present (Clist) then + Item := First (Clist); + + -- Loop through components, skipping all internal components, + -- which are not part of the value (e.g. _Tag), except that we + -- don't skip the _Parent, since we do want to process that + -- recursively. If _Parent is an interface type, being abstract + -- with no components there is no need to handle it. + + while Present (Item) loop + if Nkind (Item) = N_Component_Declaration + and then + ((Chars (Defining_Identifier (Item)) = Name_uParent + and then not Is_Interface + (Etype (Defining_Identifier (Item)))) + or else + not Is_Internal_Name (Chars (Defining_Identifier (Item)))) + then + Append_To + (Result, + Make_Field_Attribute (Defining_Identifier (Item))); + end if; + + Next (Item); + end loop; + end if; + + return Result; + end Make_Field_Attributes; + + -- Start of processing for Build_Record_Read_Write_Procedure + + begin + -- For the protected type case, use corresponding record + + if Is_Protected_Type (Typ) then + Typt := Corresponding_Record_Type (Typ); + else + Typt := Typ; + end if; + + -- Note that we do nothing with the discriminants, since Read and + -- Write do not read or write the discriminant values. All handling + -- of discriminants occurs in the Input and Output subprograms. + + Rdef := Type_Definition + (Declaration_Node (Base_Type (Underlying_Type (Typt)))); + Stms := Empty_List; + + -- In record extension case, the fields we want, including the _Parent + -- field representing the parent type, are to be found in the extension. + -- Note that we will naturally process the _Parent field using the type + -- of the parent, and hence its stream attributes, which is appropriate. + + if Nkind (Rdef) = N_Derived_Type_Definition then + Rdef := Record_Extension_Part (Rdef); + + if Is_Limited_Type (Typt) then + In_Limited_Extension := True; + end if; + end if; + + if Present (Component_List (Rdef)) then + Append_List_To (Stms, + Make_Component_List_Attributes (Component_List (Rdef))); + end if; + + Build_Stream_Procedure + (Loc, Typ, Decl, Pnam, Stms, Nam = Name_Read); + end Build_Record_Read_Write_Procedure; + + ---------------------------------- + -- Build_Record_Write_Procedure -- + ---------------------------------- + + procedure Build_Record_Write_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + begin + Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Write); + Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write); + end Build_Record_Write_Procedure; + + ------------------------------- + -- Build_Stream_Attr_Profile -- + ------------------------------- + + function Build_Stream_Attr_Profile + (Loc : Source_Ptr; + Typ : Entity_Id; + Nam : TSS_Name_Type) return List_Id + is + Profile : List_Id; + + begin + -- (Ada 2005: AI-441): Set the null-excluding attribute because it has + -- no semantic meaning in Ada 95 but it is a requirement in Ada2005. + + Profile := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_S), + Parameter_Type => + Make_Access_Definition (Loc, + Null_Exclusion_Present => True, + Subtype_Mark => New_Reference_To ( + Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))); + + if Nam /= TSS_Stream_Input then + Append_To (Profile, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Out_Present => (Nam = TSS_Stream_Read), + Parameter_Type => New_Reference_To (Typ, Loc))); + end if; + + return Profile; + end Build_Stream_Attr_Profile; + + --------------------------- + -- Build_Stream_Function -- + --------------------------- + + procedure Build_Stream_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : Entity_Id; + Decls : List_Id; + Stms : List_Id) + is + Spec : Node_Id; + + begin + -- Construct function specification + + -- (Ada 2005: AI-441): Set the null-excluding attribute because it has + -- no semantic meaning in Ada 95 but it is a requirement in Ada2005. + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Fnam, + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_S), + Parameter_Type => + Make_Access_Definition (Loc, + Null_Exclusion_Present => True, + Subtype_Mark => New_Reference_To ( + Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))), + + Result_Definition => New_Occurrence_Of (Typ, Loc)); + + Decl := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stms)); + end Build_Stream_Function; + + ---------------------------- + -- Build_Stream_Procedure -- + ---------------------------- + + procedure Build_Stream_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : Entity_Id; + Stms : List_Id; + Outp : Boolean) + is + Spec : Node_Id; + + begin + -- Construct procedure specification + + -- (Ada 2005: AI-441): Set the null-excluding attribute because it has + -- no semantic meaning in Ada 95 but it is a requirement in Ada2005. + + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Pnam, + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_S), + Parameter_Type => + Make_Access_Definition (Loc, + Null_Exclusion_Present => True, + Subtype_Mark => New_Reference_To ( + Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Out_Present => Outp, + Parameter_Type => New_Occurrence_Of (Typ, Loc)))); + + Decl := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stms)); + end Build_Stream_Procedure; + + ----------------------------- + -- Has_Stream_Standard_Rep -- + ----------------------------- + + function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean is + Siz : Uint; + + begin + if Has_Non_Standard_Rep (U_Type) then + return False; + end if; + + if Has_Stream_Size_Clause (U_Type) then + Siz := Static_Integer (Expression (Stream_Size_Clause (U_Type))); + else + Siz := Esize (First_Subtype (U_Type)); + end if; + + return Siz = Esize (Root_Type (U_Type)); + end Has_Stream_Standard_Rep; + + --------------------------------- + -- Make_Stream_Subprogram_Name -- + --------------------------------- + + function Make_Stream_Subprogram_Name + (Loc : Source_Ptr; + Typ : Entity_Id; + Nam : TSS_Name_Type) return Entity_Id + is + Sname : Name_Id; + + begin + -- For tagged types, we are dealing with a TSS associated with the + -- declaration, so we use the standard primitive function name. For + -- other types, generate a local TSS name since we are generating + -- the subprogram at the point of use. + + if Is_Tagged_Type (Typ) then + Sname := Make_TSS_Name (Typ, Nam); + else + Sname := Make_TSS_Name_Local (Typ, Nam); + end if; + + return Make_Defining_Identifier (Loc, Sname); + end Make_Stream_Subprogram_Name; + + ---------------------- + -- Stream_Base_Type -- + ---------------------- + + function Stream_Base_Type (E : Entity_Id) return Entity_Id is + begin + if Is_Array_Type (E) + and then Is_First_Subtype (E) + then + return E; + else + return Base_Type (E); + end if; + end Stream_Base_Type; + +end Exp_Strm; diff --git a/gcc/ada/exp_strm.ads b/gcc/ada/exp_strm.ads new file mode 100644 index 000000000..97cb37bbd --- /dev/null +++ b/gcc/ada/exp_strm.ads @@ -0,0 +1,154 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ S T R M -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Routines to build stream subprograms for composite types + +with Exp_Tss; use Exp_Tss; +with Types; use Types; + +package Exp_Strm is + + function Build_Elementary_Input_Call (N : Node_Id) return Node_Id; + -- Build call to Read attribute function for elementary type. Also used + -- for Input attributes for elementary types with an appropriate extra + -- assignment statement. N is the attribute reference node. + + function Build_Elementary_Write_Call (N : Node_Id) return Node_Id; + -- Build call to Write attribute function for elementary type. Also used + -- for Output attributes for elementary types (since the effect of the + -- two attributes is identical for elementary types). N is the attribute + -- reference node. + + function Build_Stream_Attr_Profile + (Loc : Source_Ptr; + Typ : Entity_Id; + Nam : TSS_Name_Type) return List_Id; + -- Builds the parameter profile for the stream attribute identified by + -- the given name. This is used for the tagged case to build the spec + -- for the primitive operation. + + -- The following routines build procedures and functions for stream + -- attributes applied to composite types. For each of these routines, + -- Loc is used to provide the location for the constructed subprogram + -- declaration. Typ is the base type to which the subprogram applies + -- (i.e. the base type of the stream attribute prefix). The returned + -- results are the declaration and name (entity) of the subprogram. + + procedure Build_Array_Input_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id); + -- Build function for Input attribute for array type + + procedure Build_Array_Output_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id); + -- Build procedure for Output attribute for array type + + procedure Build_Array_Read_Procedure + (Nod : Node_Id; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id); + -- Build procedure for Read attribute for array type. Nod provides the + -- Sloc value for generated code. + + procedure Build_Array_Write_Procedure + (Nod : Node_Id; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id); + -- Build procedure for Write attribute for array type. Nod provides the + -- Sloc value for generated code. + + procedure Build_Mutable_Record_Read_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id); + -- Build procedure to Read a record with default discriminants. + -- Discriminants must be read explicitly (RM 13.13.2(9)) in the + -- same manner as is done for 'Input. + + procedure Build_Mutable_Record_Write_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id); + -- Build procedure to write a record with default discriminants. + -- Discriminants must be written explicitly (RM 13.13.2(9)) in + -- the same manner as is done for 'Output. + + procedure Build_Record_Or_Elementary_Input_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id); + -- Build function for Input attribute for record type or for an + -- elementary type (the latter is used only in the case where a + -- user defined Read routine is defined, since in other cases, + -- Input calls the appropriate runtime library routine directly. + + procedure Build_Record_Or_Elementary_Output_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id); + -- Build procedure for Output attribute for record type or for an + -- elementary type (the latter is used only in the case where a + -- user defined Write routine is defined, since in other cases, + -- Output calls the appropriate runtime library routine directly. + + procedure Build_Record_Read_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id); + -- Build procedure for Read attribute for record type + + procedure Build_Record_Write_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id); + -- Build procedure for Write attribute for record type + + procedure Build_Stream_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : Entity_Id; + Stms : List_Id; + Outp : Boolean); + -- Called to build an array or record stream procedure. The first three + -- arguments are the same as Build_Record_Or_Elementary_Output_Procedure. + -- Stms is the list of statements for the body (the declaration list is + -- always null), and Pnam is the name of the constructed procedure. + -- Used by Exp_Dist to generate stream-oriented attributes for RACWs. + +end Exp_Strm; diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb new file mode 100644 index 000000000..8b19f9190 --- /dev/null +++ b/gcc/ada/exp_tss.adb @@ -0,0 +1,547 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ T S 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Elists; use Elists; +with Exp_Util; use Exp_Util; +with Nlists; use Nlists; +with Lib; use Lib; +with Restrict; use Restrict; +with Rident; use Rident; +with Sem_Aux; use Sem_Aux; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; + +package body Exp_Tss is + + -------------------- + -- Base_Init_Proc -- + -------------------- + + function Base_Init_Proc + (Typ : Entity_Id; + Ref : Entity_Id := Empty) return Entity_Id + is + Full_Type : E; + Proc : Entity_Id; + + begin + pragma Assert (Is_Type (Typ)); + + if Is_Private_Type (Typ) then + Full_Type := Underlying_Type (Base_Type (Typ)); + else + Full_Type := Typ; + end if; + + if No (Full_Type) then + return Empty; + + elsif Is_Concurrent_Type (Full_Type) + and then Present (Corresponding_Record_Type (Base_Type (Full_Type))) + then + -- The initialization routine to be called is that of the base type + -- of the corresponding record type, which may itself be a subtype + -- and possibly an itype. + + return Init_Proc + (Base_Type (Corresponding_Record_Type (Base_Type (Full_Type))), + Ref); + + else + Proc := Init_Proc (Base_Type (Full_Type), Ref); + + if No (Proc) + and then Is_Composite_Type (Full_Type) + and then Is_Derived_Type (Full_Type) + then + return Init_Proc (Root_Type (Full_Type), Ref); + else + return Proc; + end if; + end if; + end Base_Init_Proc; + + -------------- + -- Copy_TSS -- + -------------- + + -- Note: internally this routine is also used to initially set up + -- a TSS entry for a new type (case of being called from Set_TSS) + + procedure Copy_TSS (TSS : Entity_Id; Typ : Entity_Id) is + FN : Node_Id; + + begin + Ensure_Freeze_Node (Typ); + FN := Freeze_Node (Typ); + + if No (TSS_Elist (FN)) then + Set_TSS_Elist (FN, New_Elmt_List); + end if; + + -- We prepend here, so that a second call overrides the first, it + -- is not clear that this is required, but it seems reasonable. + + Prepend_Elmt (TSS, TSS_Elist (FN)); + end Copy_TSS; + + ------------------- + -- CPP_Init_Proc -- + ------------------- + + function CPP_Init_Proc (Typ : Entity_Id) return Entity_Id is + FN : constant Node_Id := Freeze_Node (Typ); + Elmt : Elmt_Id; + + begin + if not Is_CPP_Class (Root_Type (Typ)) + or else No (FN) + or else No (TSS_Elist (FN)) + then + return Empty; + + else + Elmt := First_Elmt (TSS_Elist (FN)); + while Present (Elmt) loop + if Is_CPP_Init_Proc (Node (Elmt)) then + return Node (Elmt); + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + return Empty; + end CPP_Init_Proc; + + ------------------------ + -- Find_Inherited_TSS -- + ------------------------ + + function Find_Inherited_TSS + (Typ : Entity_Id; + Nam : TSS_Name_Type) return Entity_Id + is + Btyp : Entity_Id := Typ; + Proc : Entity_Id; + + begin + loop + Btyp := Base_Type (Btyp); + Proc := TSS (Btyp, Nam); + + exit when Present (Proc) + or else not Is_Derived_Type (Btyp); + + -- If Typ is a derived type, it may inherit attributes from some + -- ancestor. + + Btyp := Etype (Btyp); + end loop; + + if No (Proc) then + + -- If nothing else, use the TSS of the root type + + Proc := TSS (Base_Type (Underlying_Type (Typ)), Nam); + end if; + + return Proc; + end Find_Inherited_TSS; + + ----------------------- + -- Get_TSS_Name_Type -- + ----------------------- + + function Get_TSS_Name (E : Entity_Id) return TSS_Name_Type is + C1 : Character; + C2 : Character; + Nm : TSS_Name_Type; + + begin + Get_Last_Two_Chars (Chars (E), C1, C2); + + if C1 in 'A' .. 'Z' and then C2 in 'A' .. 'Z' then + Nm := (C1, C2); + + for J in TSS_Names'Range loop + if Nm = TSS_Names (J) then + return Nm; + end if; + end loop; + end if; + + return TSS_Null; + end Get_TSS_Name; + + --------------------------------- + -- Has_Non_Null_Base_Init_Proc -- + --------------------------------- + + -- Note: if a base Init_Proc is present, and No_Default_Initialization is + -- present, then we must avoid testing for a null init proc, since there + -- is no init proc present in this case. + + function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean is + BIP : constant Entity_Id := Base_Init_Proc (Typ); + begin + return Present (BIP) + and then (Restriction_Active (No_Default_Initialization) + or else not Is_Null_Init_Proc (BIP)); + end Has_Non_Null_Base_Init_Proc; + + --------------- + -- Init_Proc -- + --------------- + + function Init_Proc + (Typ : Entity_Id; + Ref : Entity_Id := Empty) return Entity_Id + is + FN : constant Node_Id := Freeze_Node (Typ); + Elmt : Elmt_Id; + E1 : Entity_Id; + E2 : Entity_Id; + + begin + if No (FN) then + return Empty; + + elsif No (TSS_Elist (FN)) then + return Empty; + + elsif No (Ref) then + Elmt := First_Elmt (TSS_Elist (FN)); + while Present (Elmt) loop + if Is_Init_Proc (Node (Elmt)) then + if not Is_CPP_Class (Typ) then + return Node (Elmt); + + -- For CPP classes, we are looking for the default constructor, + -- and so we must skip any non-default constructor. + + elsif + No (Next + (First + (Parameter_Specifications (Parent (Node (Elmt)))))) + then + return Node (Elmt); + end if; + end if; + + Next_Elmt (Elmt); + end loop; + + -- Non-default constructors are currently supported only in the context + -- of interfacing with C++. + + else pragma Assert (Is_CPP_Class (Typ)); + + -- Use the referenced function to locate the init_proc matching + -- the C++ constructor. + + Elmt := First_Elmt (TSS_Elist (FN)); + while Present (Elmt) loop + if Is_Init_Proc (Node (Elmt)) then + E1 := Next_Formal (First_Formal (Node (Elmt))); + E2 := First_Formal (Ref); + while Present (E1) and then Present (E2) loop + if Chars (E1) /= Chars (E2) + or else Ekind (E1) /= Ekind (E2) + then + exit; + + elsif Ekind (Etype (E1)) /= E_Anonymous_Access_Type + and then Ekind (Etype (E2)) /= E_Anonymous_Access_Type + and then Etype (E1) /= Etype (E2) + then + exit; + + elsif Ekind (Etype (E1)) = E_Anonymous_Access_Type + and then Ekind (Etype (E2)) = E_Anonymous_Access_Type + and then Directly_Designated_Type (Etype (E1)) + /= Directly_Designated_Type (Etype (E2)) + then + exit; + end if; + + E1 := Next_Formal (E1); + E2 := Next_Formal (E2); + end loop; + + if No (E1) and then No (E2) then + return Node (Elmt); + end if; + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + return Empty; + end Init_Proc; + + ---------------------- + -- Is_CPP_Init_Proc -- + ---------------------- + + function Is_CPP_Init_Proc (E : Entity_Id) return Boolean is + C1 : Character; + C2 : Character; + begin + Get_Last_Two_Chars (Chars (E), C1, C2); + return C1 = TSS_CPP_Init_Proc (1) and then C2 = TSS_CPP_Init_Proc (2); + end Is_CPP_Init_Proc; + + ------------------ + -- Is_Init_Proc -- + ------------------ + + function Is_Init_Proc (E : Entity_Id) return Boolean is + C1 : Character; + C2 : Character; + begin + Get_Last_Two_Chars (Chars (E), C1, C2); + return C1 = TSS_Init_Proc (1) and then C2 = TSS_Init_Proc (2); + end Is_Init_Proc; + + ------------ + -- Is_TSS -- + ------------ + + function Is_TSS (E : Entity_Id; Nam : TSS_Name_Type) return Boolean is + C1 : Character; + C2 : Character; + begin + Get_Last_Two_Chars (Chars (E), C1, C2); + return C1 = Nam (1) and then C2 = Nam (2); + end Is_TSS; + + function Is_TSS (N : Name_Id; Nam : TSS_Name_Type) return Boolean is + C1 : Character; + C2 : Character; + begin + Get_Last_Two_Chars (N, C1, C2); + return C1 = Nam (1) and then C2 = Nam (2); + end Is_TSS; + + ------------------------- + -- Make_Init_Proc_Name -- + ------------------------- + + function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id is + begin + return Make_TSS_Name (Typ, TSS_Init_Proc); + end Make_Init_Proc_Name; + + ------------------- + -- Make_TSS_Name -- + ------------------- + + function Make_TSS_Name + (Typ : Entity_Id; + Nam : TSS_Name_Type) return Name_Id + is + begin + Get_Name_String (Chars (Typ)); + Add_Char_To_Name_Buffer (Nam (1)); + Add_Char_To_Name_Buffer (Nam (2)); + return Name_Find; + end Make_TSS_Name; + + ------------------------- + -- Make_TSS_Name_Local -- + ------------------------- + + function Make_TSS_Name_Local + (Typ : Entity_Id; + Nam : TSS_Name_Type) return Name_Id + is + begin + Get_Name_String (Chars (Typ)); + Add_Char_To_Name_Buffer ('_'); + Add_Nat_To_Name_Buffer (Increment_Serial_Number); + Add_Char_To_Name_Buffer (Nam (1)); + Add_Char_To_Name_Buffer (Nam (2)); + return Name_Find; + end Make_TSS_Name_Local; + + -------------- + -- Same_TSS -- + -------------- + + function Same_TSS (E1, E2 : Entity_Id) return Boolean is + E1C1 : Character; + E1C2 : Character; + E2C1 : Character; + E2C2 : Character; + + begin + Get_Last_Two_Chars (Chars (E1), E1C1, E1C2); + Get_Last_Two_Chars (Chars (E2), E2C1, E2C2); + + return + E1C1 = E2C1 + and then + E1C2 = E2C2 + and then + E1C1 in 'A' .. 'Z' + and then + E1C2 in 'A' .. 'Z'; + end Same_TSS; + + ------------------- + -- Set_Init_Proc -- + ------------------- + + procedure Set_Init_Proc (Typ : Entity_Id; Init : Entity_Id) is + begin + Set_TSS (Typ, Init); + end Set_Init_Proc; + + ------------- + -- Set_TSS -- + ------------- + + procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is + begin + -- Make sure body of subprogram is frozen + + -- Skip this for Init_Proc with No_Default_Initialization, since the + -- Init proc is a dummy void entity in this case to be ignored. + + if (Is_Init_Proc (TSS) or else Is_CPP_Init_Proc (TSS)) + and then Restriction_Active (No_Default_Initialization) + then + null; + + -- Skip this if not in the same code unit (since it means we are using + -- an already existing TSS in another unit) + + elsif not In_Same_Code_Unit (Typ, TSS) then + null; + + -- Otherwise make sure body is frozen + + else + Append_Freeze_Action (Typ, Unit_Declaration_Node (TSS)); + end if; + + -- Set TSS entry + + Copy_TSS (TSS, Typ); + end Set_TSS; + + --------- + -- TSS -- + --------- + + function TSS (Typ : Entity_Id; Nam : TSS_Name_Type) return Entity_Id is + FN : constant Node_Id := Freeze_Node (Typ); + Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + if No (FN) then + return Empty; + + elsif No (TSS_Elist (FN)) then + return Empty; + + else + Elmt := First_Elmt (TSS_Elist (FN)); + while Present (Elmt) loop + if Is_TSS (Node (Elmt), Nam) then + Subp := Node (Elmt); + + -- For stream subprograms, the TSS entity may be a renaming- + -- as-body of an already generated entity. Use that one rather + -- the one introduced by the renaming, which is an artifact of + -- current stream handling. + + if Nkind (Parent (Parent (Subp))) = + N_Subprogram_Renaming_Declaration + and then + Present (Corresponding_Spec (Parent (Parent (Subp)))) + then + return Corresponding_Spec (Parent (Parent (Subp))); + else + return Subp; + end if; + + else + Next_Elmt (Elmt); + end if; + end loop; + end if; + + return Empty; + end TSS; + + function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is + FN : constant Node_Id := Freeze_Node (Typ); + Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + if No (FN) then + return Empty; + + elsif No (TSS_Elist (FN)) then + return Empty; + + else + Elmt := First_Elmt (TSS_Elist (FN)); + while Present (Elmt) loop + if Chars (Node (Elmt)) = Nam then + Subp := Node (Elmt); + + -- For stream subprograms, the TSS entity may be a renaming- + -- as-body of an already generated entity. Use that one rather + -- the one introduced by the renaming, which is an artifact of + -- current stream handling. + + if Nkind (Parent (Parent (Subp))) = + N_Subprogram_Renaming_Declaration + and then + Present (Corresponding_Spec (Parent (Parent (Subp)))) + then + return Corresponding_Spec (Parent (Parent (Subp))); + else + return Subp; + end if; + + else + Next_Elmt (Elmt); + end if; + end loop; + end if; + + return Empty; + end TSS; + +end Exp_Tss; diff --git a/gcc/ada/exp_tss.ads b/gcc/ada/exp_tss.ads new file mode 100644 index 000000000..d6a18fb1b --- /dev/null +++ b/gcc/ada/exp_tss.ads @@ -0,0 +1,248 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ T S S -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Type Support Subprogram (TSS) handling + +with Namet; use Namet; +with Types; use Types; + +package Exp_Tss is + + -- A type support subprogram (TSS) is an internally generated function or + -- procedure that is associated with a particular type. Examples are the + -- implicit initialization procedure, and subprograms for the Input and + -- Output attributes. + + -- A given TSS is either generated once at the point of the declaration of + -- the type, or it is generated as needed in clients, but only one copy is + -- required in any one generated object file. The choice between these two + -- possibilities is made on a TSS-by-TSS basis depending on the estimation + -- of how likely the TSS is to be used. Initialization procedures fall in + -- the first category, for example, since it is likely that any declared + -- type will be used in a context requiring initialization, but the stream + -- attributes use the second approach, since it is more likely that they + -- will not be used at all, or will only be used in one client in any case. + + ------------------------- + -- Current Limitations -- + ------------------------- + + -- In the current version of this package, only the case of generating a + -- TSS at the point of declaration of the type is accommodated. A clear + -- improvement would be to follow through with the full implementation + -- as described above, and also accommodate the requirement of generating + -- only one copy in a given object file. + + -- For now, we deal with the local case by generating duplicate versions + -- of the TSS routine, which is clearly rather inefficient in space usage. + -- This is done by using Make_TSS_Name_Local to generate unique names + -- for the different instances of TSS routines in a given scope. + + ---------------- + -- TSS Naming -- + ---------------- + + -- A TSS is identified by its Chars name. The name has the form typXY or + -- typ_XY, where typ is the type name, and XY are two characters + -- that identify the particular TSS routine. A unique serial number is + -- included for the case where several local instances of the same TSS + -- must be generated (see discussion under Make_TSS_Name_Local). + + -- The following codes are used to denote TSSs: + + -- Note: When making additions to this list, make the corresponding change + -- to the list in snames.adb-tmpl. + + type TSS_Name_Type is new String (1 .. 2); + subtype TNT is TSS_Name_Type; + + TSS_Deep_Adjust : constant TNT := "DA"; -- Deep Adjust + TSS_Deep_Finalize : constant TNT := "DF"; -- Deep Finalize + TSS_Deep_Initialize : constant TNT := "DI"; -- Deep Initialize + TSS_Composite_Equality : constant TNT := "EQ"; -- Composite Equality + TSS_From_Any : constant TNT := "FA"; -- PolyORB/DSA From_Any + TSS_Init_Proc : constant TNT := "IP"; -- Initialization Procedure + TSS_CPP_Init_Proc : constant TNT := "IC"; -- Init C++ dispatch tables + TSS_RAS_Access : constant TNT := "RA"; -- RAS type access + TSS_RAS_Dereference : constant TNT := "RD"; -- RAS type dereference + TSS_Rep_To_Pos : constant TNT := "RP"; -- Rep to Pos conversion + TSS_Slice_Assign : constant TNT := "SA"; -- Slice assignment + TSS_Stream_Input : constant TNT := "SI"; -- Stream Input attribute + TSS_Stream_Output : constant TNT := "SO"; -- Stream Output attribute + TSS_Stream_Read : constant TNT := "SR"; -- Stream Read attribute + TSS_Stream_Write : constant TNT := "SW"; -- Stream Write attribute + TSS_To_Any : constant TNT := "TA"; -- PolyORB/DSA To_Any + TSS_TypeCode : constant TNT := "TC"; -- PolyORB/DSA TypeCode + + -- The array below contains all valid TSS names + + TSS_Names : constant array (Natural range <>) of TSS_Name_Type := + (TSS_Deep_Adjust, + TSS_Deep_Finalize, + TSS_Deep_Initialize, + TSS_Composite_Equality, + TSS_From_Any, + TSS_Init_Proc, + TSS_CPP_Init_Proc, + TSS_RAS_Access, + TSS_RAS_Dereference, + TSS_Rep_To_Pos, + TSS_Slice_Assign, + TSS_Stream_Input, + TSS_Stream_Output, + TSS_Stream_Read, + TSS_Stream_Write, + TSS_To_Any, + TSS_TypeCode); + + TSS_Null : constant TNT := " "; + -- Dummy entry used to indicated that this is not really a TSS + + function Get_TSS_Name (E : Entity_Id) return TSS_Name_Type; + -- Given an entity, if it is a TSS, then return the corresponding TSS + -- name type, otherwise return TSS_Null. + + function Make_TSS_Name + (Typ : Entity_Id; + Nam : TSS_Name_Type) return Name_Id; + -- Construct the name as described above for the given TSS routine + -- identified by Nam for the type identified by Typ. + + function Make_TSS_Name_Local + (Typ : Entity_Id; + Nam : TSS_Name_Type) return Name_Id; + -- Similar to the above call, but a string of the form _nnn is inserted + -- before the TSS code suffix, where nnn is a unique serial number. This + -- is used when multiple instances of the same TSS routine may be + -- generated in the same scope (see also discussion above of current + -- limitations). + + function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id; + -- Version for init procs, same as Make_TSS_Name (Typ, TSS_Init_Proc) + + function Is_CPP_Init_Proc (E : Entity_Id) return Boolean; + -- Version for CPP init procs, same as Is_TSS (E, TSS_CPP_Init_Proc); + + function Is_Init_Proc (E : Entity_Id) return Boolean; + -- Version for init procs, same as Is_TSS (E, TSS_Init_Proc); + + function Is_TSS (E : Entity_Id; Nam : TSS_Name_Type) return Boolean; + -- Determines if given entity (E) is the name of a TSS identified by Nam + + function Is_TSS (N : Name_Id; Nam : TSS_Name_Type) return Boolean; + -- Same test applied directly to a Name_Id value + + ----------------------------------------- + -- TSS Data structures and Subprograms -- + ----------------------------------------- + + -- The TSS's for a given type are stored in an element list associated with + -- the type, and referenced from the TSS_Elist field of the N_Freeze_Entity + -- node associated with the type (all types that need TSS's always need to + -- be explicitly frozen, so the N_Freeze_Entity node always exists). + + function TSS (Typ : Entity_Id; Nam : TSS_Name_Type) return Entity_Id; + -- Finds the TSS with the given name associated with the given type + -- If no such TSS exists, then Empty is returned; + + function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id; + -- Finds the TSS with the given name associated with the given type. If + -- no such TSS exists, then Empty is returned. + + function Same_TSS (E1, E2 : Entity_Id) return Boolean; + -- Returns True if E1 and E2 are the same kind of TSS, even if the names + -- are different (i.e. if the names of E1 and E2 end with two upper case + -- letters that are the same). + + procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id); + -- This procedure is used to install a newly created TSS. The second + -- argument is the entity for such a new TSS. This entity is placed in the + -- TSS list for the type given as the first argument, replacing an old + -- entry of the same name if one was present. The tree for the body of this + -- TSS, which is not analyzed yet, is placed in the actions field of the + -- freeze node for the type. All such bodies are inserted into the main + -- tree and analyzed at the point at which the freeze node itself is + -- expanded. + + procedure Copy_TSS (TSS : Entity_Id; Typ : Entity_Id); + -- Given an existing TSS for another type (which is already installed, + -- analyzed and expanded), install it as the corresponding TSS for Typ. + -- Note that this just copies a reference, not the tree. This can also be + -- used to initially install a TSS in the case where the subprogram for the + -- TSS has already been created and its declaration processed. + + function CPP_Init_Proc (Typ : Entity_Id) return Entity_Id; + -- Obtains the CPP_Init TSS entity the given type. The CPP_Init TSS is a + -- procedure used to initialize the C++ part of the primary and secondary + -- dispatch tables of a tagged type derived from CPP types. + + function Init_Proc + (Typ : Entity_Id; + Ref : Entity_Id := Empty) return Entity_Id; + -- Obtains the _init TSS entry for the given type. This function call is + -- equivalent to TSS (Typ, Name_uInit). The _init TSS is the procedure + -- used to initialize otherwise uninitialized instances of a type. If + -- there is no _init TSS, then the type requires no initialization. Note + -- that subtypes and implicit types never have an _init TSS since subtype + -- objects are always initialized using the initialization procedure for + -- the corresponding base type (see Base_Init_Proc function). A special + -- case arises for concurrent types. Such types do not themselves have an + -- init proc TSS, but initialization is required. The init proc used is + -- the one for the corresponding record type (see Base_Init_Proc). If + -- Ref is present it is call to a subprogram whose profile matches the + -- profile of the required constructor (this argument is used to handle + -- non-default CPP constructors). + + function Base_Init_Proc + (Typ : Entity_Id; + Ref : Entity_Id := Empty) return Entity_Id; + -- Obtains the _Init TSS entry from the base type of the entity, and also + -- deals with going indirect through the Corresponding_Record_Type field + -- for concurrent objects (which are initialized with the initialization + -- routine for the corresponding record type). Returns Empty if there is no + -- _Init TSS entry for the base type. If Ref is present it is a call to a + -- subprogram whose profile matches the profile of the required constructor + -- (this argument is used to handle non-default CPP constructors). + + procedure Set_Init_Proc (Typ : Entity_Id; Init : Entity_Id); + pragma Inline (Set_Init_Proc); + -- The second argument is the _init TSS to be established for the type + -- given as the first argument. Equivalent to Set_TSS (Typ, Init). + + function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean; + -- Returns true if the given type has a defined Base_Init_Proc and + -- this init proc is not a null init proc (null init procs occur as + -- a result of the processing for Initialize_Scalars). This function + -- is used to test for the presence of an init proc in cases where + -- a null init proc is considered equivalent to no init proc. + + function Find_Inherited_TSS + (Typ : Entity_Id; + Nam : TSS_Name_Type) return Entity_Id; + -- Returns the TSS of name Nam of Typ, or of its closest ancestor defining + -- such a TSS. Empty is returned is neither Typ nor any of its ancestors + -- have such a TSS. + +end Exp_Tss; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb new file mode 100644 index 000000000..2740bd124 --- /dev/null +++ b/gcc/ada/exp_util.adb @@ -0,0 +1,5846 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ U T I L -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Casing; use Casing; +with Checks; use Checks; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Aggr; use Exp_Aggr; +with Exp_Ch6; use Exp_Ch6; +with Exp_Ch7; use Exp_Ch7; +with Inline; use Inline; +with Itypes; use Itypes; +with Lib; use Lib; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch8; use Sem_Ch8; +with Sem_Eval; use Sem_Eval; +with Sem_Prag; use Sem_Prag; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; +with Urealp; use Urealp; +with Validsw; use Validsw; + +package body Exp_Util is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Build_Task_Array_Image + (Loc : Source_Ptr; + Id_Ref : Node_Id; + A_Type : Entity_Id; + Dyn : Boolean := False) return Node_Id; + -- Build function to generate the image string for a task that is an + -- array component, concatenating the images of each index. To avoid + -- storage leaks, the string is built with successive slice assignments. + -- The flag Dyn indicates whether this is called for the initialization + -- procedure of an array of tasks, or for the name of a dynamically + -- created task that is assigned to an indexed component. + + function Build_Task_Image_Function + (Loc : Source_Ptr; + Decls : List_Id; + Stats : List_Id; + Res : Entity_Id) return Node_Id; + -- Common processing for Task_Array_Image and Task_Record_Image. + -- Build function body that computes image. + + procedure Build_Task_Image_Prefix + (Loc : Source_Ptr; + Len : out Entity_Id; + Res : out Entity_Id; + Pos : out Entity_Id; + Prefix : Entity_Id; + Sum : Node_Id; + Decls : List_Id; + Stats : List_Id); + -- Common processing for Task_Array_Image and Task_Record_Image. + -- Create local variables and assign prefix of name to result string. + + function Build_Task_Record_Image + (Loc : Source_Ptr; + Id_Ref : Node_Id; + Dyn : Boolean := False) return Node_Id; + -- Build function to generate the image string for a task that is a + -- record component. Concatenate name of variable with that of selector. + -- The flag Dyn indicates whether this is called for the initialization + -- procedure of record with task components, or for a dynamically + -- created task that is assigned to a selected component. + + function Make_CW_Equivalent_Type + (T : Entity_Id; + E : Node_Id) return Entity_Id; + -- T is a class-wide type entity, E is the initial expression node that + -- constrains T in case such as: " X: T := E" or "new T'(E)" + -- This function returns the entity of the Equivalent type and inserts + -- on the fly the necessary declaration such as: + -- + -- type anon is record + -- _parent : Root_Type (T); constrained with E discriminants (if any) + -- Extension : String (1 .. expr to match size of E); + -- end record; + -- + -- This record is compatible with any object of the class of T thanks + -- to the first field and has the same size as E thanks to the second. + + function Make_Literal_Range + (Loc : Source_Ptr; + Literal_Typ : Entity_Id) return Node_Id; + -- Produce a Range node whose bounds are: + -- Low_Bound (Literal_Type) .. + -- Low_Bound (Literal_Type) + (Length (Literal_Typ) - 1) + -- this is used for expanding declarations like X : String := "sdfgdfg"; + -- + -- If the index type of the target array is not integer, we generate: + -- Low_Bound (Literal_Type) .. + -- Literal_Type'Val + -- (Literal_Type'Pos (Low_Bound (Literal_Type)) + -- + (Length (Literal_Typ) -1)) + + function Make_Non_Empty_Check + (Loc : Source_Ptr; + N : Node_Id) return Node_Id; + -- Produce a boolean expression checking that the unidimensional array + -- node N is not empty. + + function New_Class_Wide_Subtype + (CW_Typ : Entity_Id; + N : Node_Id) return Entity_Id; + -- Create an implicit subtype of CW_Typ attached to node N + + ---------------------- + -- Adjust_Condition -- + ---------------------- + + procedure Adjust_Condition (N : Node_Id) is + begin + if No (N) then + return; + end if; + + declare + Loc : constant Source_Ptr := Sloc (N); + T : constant Entity_Id := Etype (N); + Ti : Entity_Id; + + begin + -- For now, we simply ignore a call where the argument has no + -- type (probably case of unanalyzed condition), or has a type + -- that is not Boolean. This is because this is a pretty marginal + -- piece of functionality, and violations of these rules are + -- likely to be truly marginal (how much code uses Fortran Logical + -- as the barrier to a protected entry?) and we do not want to + -- blow up existing programs. We can change this to an assertion + -- after 3.12a is released ??? + + if No (T) or else not Is_Boolean_Type (T) then + return; + end if; + + -- Apply validity checking if needed + + if Validity_Checks_On and Validity_Check_Tests then + Ensure_Valid (N); + end if; + + -- Immediate return if standard boolean, the most common case, + -- where nothing needs to be done. + + if Base_Type (T) = Standard_Boolean then + return; + end if; + + -- Case of zero/non-zero semantics or non-standard enumeration + -- representation. In each case, we rewrite the node as: + + -- ityp!(N) /= False'Enum_Rep + + -- where ityp is an integer type with large enough size to hold + -- any value of type T. + + if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then + if Esize (T) <= Esize (Standard_Integer) then + Ti := Standard_Integer; + else + Ti := Standard_Long_Long_Integer; + end if; + + Rewrite (N, + Make_Op_Ne (Loc, + Left_Opnd => Unchecked_Convert_To (Ti, N), + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Enum_Rep, + Prefix => + New_Occurrence_Of (First_Literal (T), Loc)))); + Analyze_And_Resolve (N, Standard_Boolean); + + else + Rewrite (N, Convert_To (Standard_Boolean, N)); + Analyze_And_Resolve (N, Standard_Boolean); + end if; + end; + end Adjust_Condition; + + ------------------------ + -- Adjust_Result_Type -- + ------------------------ + + procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is + begin + -- Ignore call if current type is not Standard.Boolean + + if Etype (N) /= Standard_Boolean then + return; + end if; + + -- If result is already of correct type, nothing to do. Note that + -- this will get the most common case where everything has a type + -- of Standard.Boolean. + + if Base_Type (T) = Standard_Boolean then + return; + + else + declare + KP : constant Node_Kind := Nkind (Parent (N)); + + begin + -- If result is to be used as a Condition in the syntax, no need + -- to convert it back, since if it was changed to Standard.Boolean + -- using Adjust_Condition, that is just fine for this usage. + + if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then + return; + + -- If result is an operand of another logical operation, no need + -- to reset its type, since Standard.Boolean is just fine, and + -- such operations always do Adjust_Condition on their operands. + + elsif KP in N_Op_Boolean + or else KP in N_Short_Circuit + or else KP = N_Op_Not + then + return; + + -- Otherwise we perform a conversion from the current type, + -- which must be Standard.Boolean, to the desired type. + + else + Set_Analyzed (N); + Rewrite (N, Convert_To (T, N)); + Analyze_And_Resolve (N, T); + end if; + end; + end if; + end Adjust_Result_Type; + + -------------------------- + -- Append_Freeze_Action -- + -------------------------- + + procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is + Fnode : Node_Id; + + begin + Ensure_Freeze_Node (T); + Fnode := Freeze_Node (T); + + if No (Actions (Fnode)) then + Set_Actions (Fnode, New_List); + end if; + + Append (N, Actions (Fnode)); + end Append_Freeze_Action; + + --------------------------- + -- Append_Freeze_Actions -- + --------------------------- + + procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is + Fnode : constant Node_Id := Freeze_Node (T); + + begin + if No (L) then + return; + + else + if No (Actions (Fnode)) then + Set_Actions (Fnode, L); + else + Append_List (L, Actions (Fnode)); + end if; + end if; + end Append_Freeze_Actions; + + ------------------------ + -- Build_Runtime_Call -- + ------------------------ + + function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is + begin + -- If entity is not available, we can skip making the call (this avoids + -- junk duplicated error messages in a number of cases). + + if not RTE_Available (RE) then + return Make_Null_Statement (Loc); + else + return + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE), Loc)); + end if; + end Build_Runtime_Call; + + ---------------------------- + -- Build_Task_Array_Image -- + ---------------------------- + + -- This function generates the body for a function that constructs the + -- image string for a task that is an array component. The function is + -- local to the init proc for the array type, and is called for each one + -- of the components. The constructed image has the form of an indexed + -- component, whose prefix is the outer variable of the array type. + -- The n-dimensional array type has known indexes Index, Index2... + -- Id_Ref is an indexed component form created by the enclosing init proc. + -- Its successive indexes are Val1, Val2, ... which are the loop variables + -- in the loops that call the individual task init proc on each component. + + -- The generated function has the following structure: + + -- function F return String is + -- Pref : string renames Task_Name; + -- T1 : String := Index1'Image (Val1); + -- ... + -- Tn : String := indexn'image (Valn); + -- Len : Integer := T1'Length + ... + Tn'Length + n + 1; + -- -- Len includes commas and the end parentheses. + -- Res : String (1..Len); + -- Pos : Integer := Pref'Length; + -- + -- begin + -- Res (1 .. Pos) := Pref; + -- Pos := Pos + 1; + -- Res (Pos) := '('; + -- Pos := Pos + 1; + -- Res (Pos .. Pos + T1'Length - 1) := T1; + -- Pos := Pos + T1'Length; + -- Res (Pos) := '.'; + -- Pos := Pos + 1; + -- ... + -- Res (Pos .. Pos + Tn'Length - 1) := Tn; + -- Res (Len) := ')'; + -- + -- return Res; + -- end F; + -- + -- Needless to say, multidimensional arrays of tasks are rare enough + -- that the bulkiness of this code is not really a concern. + + function Build_Task_Array_Image + (Loc : Source_Ptr; + Id_Ref : Node_Id; + A_Type : Entity_Id; + Dyn : Boolean := False) return Node_Id + is + Dims : constant Nat := Number_Dimensions (A_Type); + -- Number of dimensions for array of tasks + + Temps : array (1 .. Dims) of Entity_Id; + -- Array of temporaries to hold string for each index + + Indx : Node_Id; + -- Index expression + + Len : Entity_Id; + -- Total length of generated name + + Pos : Entity_Id; + -- Running index for substring assignments + + Pref : constant Entity_Id := Make_Temporary (Loc, 'P'); + -- Name of enclosing variable, prefix of resulting name + + Res : Entity_Id; + -- String to hold result + + Val : Node_Id; + -- Value of successive indexes + + Sum : Node_Id; + -- Expression to compute total size of string + + T : Entity_Id; + -- Entity for name at one index position + + Decls : constant List_Id := New_List; + Stats : constant List_Id := New_List; + + begin + -- For a dynamic task, the name comes from the target variable. + -- For a static one it is a formal of the enclosing init proc. + + if Dyn then + Get_Name_String (Chars (Entity (Prefix (Id_Ref)))); + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Pref, + Object_Definition => New_Occurrence_Of (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer))); + + else + Append_To (Decls, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Pref, + Subtype_Mark => New_Occurrence_Of (Standard_String, Loc), + Name => Make_Identifier (Loc, Name_uTask_Name))); + end if; + + Indx := First_Index (A_Type); + Val := First (Expressions (Id_Ref)); + + for J in 1 .. Dims loop + T := Make_Temporary (Loc, 'T'); + Temps (J) := T; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => T, + Object_Definition => New_Occurrence_Of (Standard_String, Loc), + Expression => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Image, + Prefix => New_Occurrence_Of (Etype (Indx), Loc), + Expressions => New_List (New_Copy_Tree (Val))))); + + Next_Index (Indx); + Next (Val); + end loop; + + Sum := Make_Integer_Literal (Loc, Dims + 1); + + Sum := + Make_Op_Add (Loc, + Left_Opnd => Sum, + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => + New_Occurrence_Of (Pref, Loc), + Expressions => New_List (Make_Integer_Literal (Loc, 1)))); + + for J in 1 .. Dims loop + Sum := + Make_Op_Add (Loc, + Left_Opnd => Sum, + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => + New_Occurrence_Of (Temps (J), Loc), + Expressions => New_List (Make_Integer_Literal (Loc, 1)))); + end loop; + + Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats); + + Set_Character_Literal_Name (Char_Code (Character'Pos ('('))); + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (Res, Loc), + Expressions => New_List (New_Occurrence_Of (Pos, Loc))), + Expression => + Make_Character_Literal (Loc, + Chars => Name_Find, + Char_Literal_Value => + UI_From_Int (Character'Pos ('('))))); + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Pos, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (Pos, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1)))); + + for J in 1 .. Dims loop + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => Make_Slice (Loc, + Prefix => New_Occurrence_Of (Res, Loc), + Discrete_Range => + Make_Range (Loc, + Low_Bound => New_Occurrence_Of (Pos, Loc), + High_Bound => Make_Op_Subtract (Loc, + Left_Opnd => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (Pos, Loc), + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => + New_Occurrence_Of (Temps (J), Loc), + Expressions => + New_List (Make_Integer_Literal (Loc, 1)))), + Right_Opnd => Make_Integer_Literal (Loc, 1)))), + + Expression => New_Occurrence_Of (Temps (J), Loc))); + + if J < Dims then + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Pos, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (Pos, Loc), + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => New_Occurrence_Of (Temps (J), Loc), + Expressions => + New_List (Make_Integer_Literal (Loc, 1)))))); + + Set_Character_Literal_Name (Char_Code (Character'Pos (','))); + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (Res, Loc), + Expressions => New_List (New_Occurrence_Of (Pos, Loc))), + Expression => + Make_Character_Literal (Loc, + Chars => Name_Find, + Char_Literal_Value => + UI_From_Int (Character'Pos (','))))); + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Pos, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (Pos, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1)))); + end if; + end loop; + + Set_Character_Literal_Name (Char_Code (Character'Pos (')'))); + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (Res, Loc), + Expressions => New_List (New_Occurrence_Of (Len, Loc))), + Expression => + Make_Character_Literal (Loc, + Chars => Name_Find, + Char_Literal_Value => + UI_From_Int (Character'Pos (')'))))); + return Build_Task_Image_Function (Loc, Decls, Stats, Res); + end Build_Task_Array_Image; + + ---------------------------- + -- Build_Task_Image_Decls -- + ---------------------------- + + function Build_Task_Image_Decls + (Loc : Source_Ptr; + Id_Ref : Node_Id; + A_Type : Entity_Id; + In_Init_Proc : Boolean := False) return List_Id + is + Decls : constant List_Id := New_List; + T_Id : Entity_Id := Empty; + Decl : Node_Id; + Expr : Node_Id := Empty; + Fun : Node_Id := Empty; + Is_Dyn : constant Boolean := + Nkind (Parent (Id_Ref)) = N_Assignment_Statement + and then + Nkind (Expression (Parent (Id_Ref))) = N_Allocator; + + begin + -- If Discard_Names or No_Implicit_Heap_Allocations are in effect, + -- generate a dummy declaration only. + + if Restriction_Active (No_Implicit_Heap_Allocations) + or else Global_Discard_Names + then + T_Id := Make_Temporary (Loc, 'J'); + Name_Len := 0; + + return + New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => T_Id, + Object_Definition => New_Occurrence_Of (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer))); + + else + if Nkind (Id_Ref) = N_Identifier + or else Nkind (Id_Ref) = N_Defining_Identifier + then + -- For a simple variable, the image of the task is built from + -- the name of the variable. To avoid possible conflict with + -- the anonymous type created for a single protected object, + -- add a numeric suffix. + + T_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Id_Ref), 'T', 1)); + + Get_Name_String (Chars (Id_Ref)); + + Expr := + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer); + + elsif Nkind (Id_Ref) = N_Selected_Component then + T_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Selector_Name (Id_Ref)), 'T')); + Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn); + + elsif Nkind (Id_Ref) = N_Indexed_Component then + T_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (A_Type), 'N')); + + Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn); + end if; + end if; + + if Present (Fun) then + Append (Fun, Decls); + Expr := Make_Function_Call (Loc, + Name => New_Occurrence_Of (Defining_Entity (Fun), Loc)); + + if not In_Init_Proc and then VM_Target = No_VM then + Set_Uses_Sec_Stack (Defining_Entity (Fun)); + end if; + end if; + + Decl := Make_Object_Declaration (Loc, + Defining_Identifier => T_Id, + Object_Definition => New_Occurrence_Of (Standard_String, Loc), + Constant_Present => True, + Expression => Expr); + + Append (Decl, Decls); + return Decls; + end Build_Task_Image_Decls; + + ------------------------------- + -- Build_Task_Image_Function -- + ------------------------------- + + function Build_Task_Image_Function + (Loc : Source_Ptr; + Decls : List_Id; + Stats : List_Id; + Res : Entity_Id) return Node_Id + is + Spec : Node_Id; + + begin + Append_To (Stats, + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Res, Loc))); + + Spec := Make_Function_Specification (Loc, + Defining_Unit_Name => Make_Temporary (Loc, 'F'), + Result_Definition => New_Occurrence_Of (Standard_String, Loc)); + + -- Calls to 'Image use the secondary stack, which must be cleaned + -- up after the task name is built. + + return Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats)); + end Build_Task_Image_Function; + + ----------------------------- + -- Build_Task_Image_Prefix -- + ----------------------------- + + procedure Build_Task_Image_Prefix + (Loc : Source_Ptr; + Len : out Entity_Id; + Res : out Entity_Id; + Pos : out Entity_Id; + Prefix : Entity_Id; + Sum : Node_Id; + Decls : List_Id; + Stats : List_Id) + is + begin + Len := Make_Temporary (Loc, 'L', Sum); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Len, + Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), + Expression => Sum)); + + Res := Make_Temporary (Loc, 'R'); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Res, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Standard_String, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => + New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => New_Occurrence_Of (Len, Loc))))))); + + Pos := Make_Temporary (Loc, 'P'); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Pos, + Object_Definition => New_Occurrence_Of (Standard_Integer, Loc))); + + -- Pos := Prefix'Length; + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Pos, Loc), + Expression => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => New_Occurrence_Of (Prefix, Loc), + Expressions => New_List (Make_Integer_Literal (Loc, 1))))); + + -- Res (1 .. Pos) := Prefix; + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => + Make_Slice (Loc, + Prefix => New_Occurrence_Of (Res, Loc), + Discrete_Range => + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => New_Occurrence_Of (Pos, Loc))), + + Expression => New_Occurrence_Of (Prefix, Loc))); + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Pos, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (Pos, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1)))); + end Build_Task_Image_Prefix; + + ----------------------------- + -- Build_Task_Record_Image -- + ----------------------------- + + function Build_Task_Record_Image + (Loc : Source_Ptr; + Id_Ref : Node_Id; + Dyn : Boolean := False) return Node_Id + is + Len : Entity_Id; + -- Total length of generated name + + Pos : Entity_Id; + -- Index into result + + Res : Entity_Id; + -- String to hold result + + Pref : constant Entity_Id := Make_Temporary (Loc, 'P'); + -- Name of enclosing variable, prefix of resulting name + + Sum : Node_Id; + -- Expression to compute total size of string + + Sel : Entity_Id; + -- Entity for selector name + + Decls : constant List_Id := New_List; + Stats : constant List_Id := New_List; + + begin + -- For a dynamic task, the name comes from the target variable. For a + -- static one it is a formal of the enclosing init proc. + + if Dyn then + Get_Name_String (Chars (Entity (Prefix (Id_Ref)))); + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Pref, + Object_Definition => New_Occurrence_Of (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer))); + + else + Append_To (Decls, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Pref, + Subtype_Mark => New_Occurrence_Of (Standard_String, Loc), + Name => Make_Identifier (Loc, Name_uTask_Name))); + end if; + + Sel := Make_Temporary (Loc, 'S'); + + Get_Name_String (Chars (Selector_Name (Id_Ref))); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Sel, + Object_Definition => New_Occurrence_Of (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer))); + + Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1)); + + Sum := + Make_Op_Add (Loc, + Left_Opnd => Sum, + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => + New_Occurrence_Of (Pref, Loc), + Expressions => New_List (Make_Integer_Literal (Loc, 1)))); + + Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats); + + Set_Character_Literal_Name (Char_Code (Character'Pos ('.'))); + + -- Res (Pos) := '.'; + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (Res, Loc), + Expressions => New_List (New_Occurrence_Of (Pos, Loc))), + Expression => + Make_Character_Literal (Loc, + Chars => Name_Find, + Char_Literal_Value => + UI_From_Int (Character'Pos ('.'))))); + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Pos, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (Pos, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1)))); + + -- Res (Pos .. Len) := Selector; + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => Make_Slice (Loc, + Prefix => New_Occurrence_Of (Res, Loc), + Discrete_Range => + Make_Range (Loc, + Low_Bound => New_Occurrence_Of (Pos, Loc), + High_Bound => New_Occurrence_Of (Len, Loc))), + Expression => New_Occurrence_Of (Sel, Loc))); + + return Build_Task_Image_Function (Loc, Decls, Stats, Res); + end Build_Task_Record_Image; + + ---------------------------------- + -- Component_May_Be_Bit_Aligned -- + ---------------------------------- + + function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is + UT : Entity_Id; + + begin + -- If no component clause, then everything is fine, since the back end + -- never bit-misaligns by default, even if there is a pragma Packed for + -- the record. + + if No (Comp) or else No (Component_Clause (Comp)) then + return False; + end if; + + UT := Underlying_Type (Etype (Comp)); + + -- It is only array and record types that cause trouble + + if not Is_Record_Type (UT) + and then not Is_Array_Type (UT) + then + return False; + + -- If we know that we have a small (64 bits or less) record or small + -- bit-packed array, then everything is fine, since the back end can + -- handle these cases correctly. + + elsif Esize (Comp) <= 64 + and then (Is_Record_Type (UT) + or else Is_Bit_Packed_Array (UT)) + then + return False; + + -- Otherwise if the component is not byte aligned, we know we have the + -- nasty unaligned case. + + elsif Normalized_First_Bit (Comp) /= Uint_0 + or else Esize (Comp) mod System_Storage_Unit /= Uint_0 + then + return True; + + -- If we are large and byte aligned, then OK at this level + + else + return False; + end if; + end Component_May_Be_Bit_Aligned; + + ----------------------------------- + -- Corresponding_Runtime_Package -- + ----------------------------------- + + function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is + Pkg_Id : RTU_Id := RTU_Null; + + begin + pragma Assert (Is_Concurrent_Type (Typ)); + + if Ekind (Typ) in Protected_Kind then + if Has_Entries (Typ) + or else Has_Interrupt_Handler (Typ) + or else (Has_Attach_Handler (Typ) + and then not Restricted_Profile) + + -- A protected type without entries that covers an interface and + -- overrides the abstract routines with protected procedures is + -- considered equivalent to a protected type with entries in the + -- context of dispatching select statements. It is sufficient to + -- check for the presence of an interface list in the declaration + -- node to recognize this case. + + or else Present (Interface_List (Parent (Typ))) + then + if Abort_Allowed + or else Restriction_Active (No_Entry_Queue) = False + or else Number_Entries (Typ) > 1 + or else (Has_Attach_Handler (Typ) + and then not Restricted_Profile) + then + Pkg_Id := System_Tasking_Protected_Objects_Entries; + else + Pkg_Id := System_Tasking_Protected_Objects_Single_Entry; + end if; + + else + Pkg_Id := System_Tasking_Protected_Objects; + end if; + end if; + + return Pkg_Id; + end Corresponding_Runtime_Package; + + ------------------------------- + -- Convert_To_Actual_Subtype -- + ------------------------------- + + procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is + Act_ST : Entity_Id; + + begin + Act_ST := Get_Actual_Subtype (Exp); + + if Act_ST = Etype (Exp) then + return; + + else + Rewrite (Exp, + Convert_To (Act_ST, Relocate_Node (Exp))); + Analyze_And_Resolve (Exp, Act_ST); + end if; + end Convert_To_Actual_Subtype; + + ----------------------------------- + -- Current_Sem_Unit_Declarations -- + ----------------------------------- + + function Current_Sem_Unit_Declarations return List_Id is + U : Node_Id := Unit (Cunit (Current_Sem_Unit)); + Decls : List_Id; + + begin + -- If the current unit is a package body, locate the visible + -- declarations of the package spec. + + if Nkind (U) = N_Package_Body then + U := Unit (Library_Unit (Cunit (Current_Sem_Unit))); + end if; + + if Nkind (U) = N_Package_Declaration then + U := Specification (U); + Decls := Visible_Declarations (U); + + if No (Decls) then + Decls := New_List; + Set_Visible_Declarations (U, Decls); + end if; + + else + Decls := Declarations (U); + + if No (Decls) then + Decls := New_List; + Set_Declarations (U, Decls); + end if; + end if; + + return Decls; + end Current_Sem_Unit_Declarations; + + ----------------------- + -- Duplicate_Subexpr -- + ----------------------- + + function Duplicate_Subexpr + (Exp : Node_Id; + Name_Req : Boolean := False) return Node_Id + is + begin + Remove_Side_Effects (Exp, Name_Req); + return New_Copy_Tree (Exp); + end Duplicate_Subexpr; + + --------------------------------- + -- Duplicate_Subexpr_No_Checks -- + --------------------------------- + + function Duplicate_Subexpr_No_Checks + (Exp : Node_Id; + Name_Req : Boolean := False) return Node_Id + is + New_Exp : Node_Id; + + begin + Remove_Side_Effects (Exp, Name_Req); + New_Exp := New_Copy_Tree (Exp); + Remove_Checks (New_Exp); + return New_Exp; + end Duplicate_Subexpr_No_Checks; + + ----------------------------------- + -- Duplicate_Subexpr_Move_Checks -- + ----------------------------------- + + function Duplicate_Subexpr_Move_Checks + (Exp : Node_Id; + Name_Req : Boolean := False) return Node_Id + is + New_Exp : Node_Id; + + begin + Remove_Side_Effects (Exp, Name_Req); + New_Exp := New_Copy_Tree (Exp); + Remove_Checks (Exp); + return New_Exp; + end Duplicate_Subexpr_Move_Checks; + + -------------------- + -- Ensure_Defined -- + -------------------- + + procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is + IR : Node_Id; + + begin + -- An itype reference must only be created if this is a local itype, so + -- that gigi can elaborate it on the proper objstack. + + if Is_Itype (Typ) + and then Scope (Typ) = Current_Scope + then + IR := Make_Itype_Reference (Sloc (N)); + Set_Itype (IR, Typ); + Insert_Action (N, IR); + end if; + end Ensure_Defined; + + -------------------- + -- Entry_Names_OK -- + -------------------- + + function Entry_Names_OK return Boolean is + begin + return + not Restricted_Profile + and then not Global_Discard_Names + and then not Restriction_Active (No_Implicit_Heap_Allocations) + and then not Restriction_Active (No_Local_Allocators); + end Entry_Names_OK; + + --------------------- + -- Evolve_And_Then -- + --------------------- + + procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is + begin + if No (Cond) then + Cond := Cond1; + else + Cond := + Make_And_Then (Sloc (Cond1), + Left_Opnd => Cond, + Right_Opnd => Cond1); + end if; + end Evolve_And_Then; + + -------------------- + -- Evolve_Or_Else -- + -------------------- + + procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is + begin + if No (Cond) then + Cond := Cond1; + else + Cond := + Make_Or_Else (Sloc (Cond1), + Left_Opnd => Cond, + Right_Opnd => Cond1); + end if; + end Evolve_Or_Else; + + ------------------------------ + -- Expand_Subtype_From_Expr -- + ------------------------------ + + -- This function is applicable for both static and dynamic allocation of + -- objects which are constrained by an initial expression. Basically it + -- transforms an unconstrained subtype indication into a constrained one. + -- The expression may also be transformed in certain cases in order to + -- avoid multiple evaluation. In the static allocation case, the general + -- scheme is: + + -- Val : T := Expr; + + -- is transformed into + + -- Val : Constrained_Subtype_of_T := Maybe_Modified_Expr; + -- + -- Here are the main cases : + -- + -- + -- Val : T ([Index_Subtype (Expr)]) := Expr; + -- + -- + -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr; + -- + -- + -- subtype T is Type_Of_Expr + -- Val : T := Expr; + -- + -- + -- Val : T (constraints taken from Expr) := Expr; + -- + -- + -- type Axxx is access all T; + -- Rval : Axxx := Expr'ref; + -- Val : T (constraints taken from Rval) := Rval.all; + + -- ??? note: when the Expression is allocated in the secondary stack + -- we could use it directly instead of copying it by declaring + -- Val : T (...) renames Rval.all + + procedure Expand_Subtype_From_Expr + (N : Node_Id; + Unc_Type : Entity_Id; + Subtype_Indic : Node_Id; + Exp : Node_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Exp_Typ : constant Entity_Id := Etype (Exp); + T : Entity_Id; + + begin + -- In general we cannot build the subtype if expansion is disabled, + -- because internal entities may not have been defined. However, to + -- avoid some cascaded errors, we try to continue when the expression is + -- an array (or string), because it is safe to compute the bounds. It is + -- in fact required to do so even in a generic context, because there + -- may be constants that depend on the bounds of a string literal, both + -- standard string types and more generally arrays of characters. + + if not Expander_Active + and then (No (Etype (Exp)) + or else not Is_String_Type (Etype (Exp))) + then + return; + end if; + + if Nkind (Exp) = N_Slice then + declare + Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ)); + + begin + Rewrite (Subtype_Indic, + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (Unc_Type, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List + (New_Reference_To (Slice_Type, Loc))))); + + -- This subtype indication may be used later for constraint checks + -- we better make sure that if a variable was used as a bound of + -- of the original slice, its value is frozen. + + Force_Evaluation (Low_Bound (Scalar_Range (Slice_Type))); + Force_Evaluation (High_Bound (Scalar_Range (Slice_Type))); + end; + + elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then + Rewrite (Subtype_Indic, + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (Unc_Type, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Literal_Range (Loc, + Literal_Typ => Exp_Typ))))); + + elsif Is_Constrained (Exp_Typ) + and then not Is_Class_Wide_Type (Unc_Type) + then + if Is_Itype (Exp_Typ) then + + -- Within an initialization procedure, a selected component + -- denotes a component of the enclosing record, and it appears + -- as an actual in a call to its own initialization procedure. + -- If this component depends on the outer discriminant, we must + -- generate the proper actual subtype for it. + + if Nkind (Exp) = N_Selected_Component + and then Within_Init_Proc + then + declare + Decl : constant Node_Id := + Build_Actual_Subtype_Of_Component (Exp_Typ, Exp); + begin + if Present (Decl) then + Insert_Action (N, Decl); + T := Defining_Identifier (Decl); + else + T := Exp_Typ; + end if; + end; + + -- No need to generate a new one (new what???) + + else + T := Exp_Typ; + end if; + + else + T := Make_Temporary (Loc, 'T'); + + Insert_Action (N, + Make_Subtype_Declaration (Loc, + Defining_Identifier => T, + Subtype_Indication => New_Reference_To (Exp_Typ, Loc))); + + -- This type is marked as an itype even though it has an + -- explicit declaration because otherwise it can be marked + -- with Is_Generic_Actual_Type and generate spurious errors. + -- (see sem_ch8.Analyze_Package_Renaming and sem_type.covers) + + Set_Is_Itype (T); + Set_Associated_Node_For_Itype (T, Exp); + end if; + + Rewrite (Subtype_Indic, New_Reference_To (T, Loc)); + + -- Nothing needs to be done for private types with unknown discriminants + -- if the underlying type is not an unconstrained composite type or it + -- is an unchecked union. + + elsif Is_Private_Type (Unc_Type) + and then Has_Unknown_Discriminants (Unc_Type) + and then (not Is_Composite_Type (Underlying_Type (Unc_Type)) + or else Is_Constrained (Underlying_Type (Unc_Type)) + or else Is_Unchecked_Union (Underlying_Type (Unc_Type))) + then + null; + + -- Case of derived type with unknown discriminants where the parent type + -- also has unknown discriminants. + + elsif Is_Record_Type (Unc_Type) + and then not Is_Class_Wide_Type (Unc_Type) + and then Has_Unknown_Discriminants (Unc_Type) + and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type)) + then + -- Nothing to be done if no underlying record view available + + if No (Underlying_Record_View (Unc_Type)) then + null; + + -- Otherwise use the Underlying_Record_View to create the proper + -- constrained subtype for an object of a derived type with unknown + -- discriminants. + + else + Remove_Side_Effects (Exp); + Rewrite (Subtype_Indic, + Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type))); + end if; + + -- Renamings of class-wide interface types require no equivalent + -- constrained type declarations because we only need to reference + -- the tag component associated with the interface. + + elsif Present (N) + and then Nkind (N) = N_Object_Renaming_Declaration + and then Is_Interface (Unc_Type) + then + pragma Assert (Is_Class_Wide_Type (Unc_Type)); + null; + + -- In Ada95 nothing to be done if the type of the expression is limited, + -- because in this case the expression cannot be copied, and its use can + -- only be by reference. + + -- In Ada2005, the context can be an object declaration whose expression + -- is a function that returns in place. If the nominal subtype has + -- unknown discriminants, the call still provides constraints on the + -- object, and we have to create an actual subtype from it. + + -- If the type is class-wide, the expression is dynamically tagged and + -- we do not create an actual subtype either. Ditto for an interface. + + elsif Is_Limited_Type (Exp_Typ) + and then + (Is_Class_Wide_Type (Exp_Typ) + or else Is_Interface (Exp_Typ) + or else not Has_Unknown_Discriminants (Exp_Typ) + or else not Is_Composite_Type (Unc_Type)) + then + null; + + -- For limited objects initialized with build in place function calls, + -- nothing to be done; otherwise we prematurely introduce an N_Reference + -- node in the expression initializing the object, which breaks the + -- circuitry that detects and adds the additional arguments to the + -- called function. + + elsif Is_Build_In_Place_Function_Call (Exp) then + null; + + else + Remove_Side_Effects (Exp); + Rewrite (Subtype_Indic, + Make_Subtype_From_Expr (Exp, Unc_Type)); + end if; + end Expand_Subtype_From_Expr; + + -------------------- + -- Find_Init_Call -- + -------------------- + + function Find_Init_Call + (Var : Entity_Id; + Rep_Clause : Node_Id) return Node_Id + is + Typ : constant Entity_Id := Etype (Var); + + Init_Proc : Entity_Id; + -- Initialization procedure for Typ + + function Find_Init_Call_In_List (From : Node_Id) return Node_Id; + -- Look for init call for Var starting at From and scanning the + -- enclosing list until Rep_Clause or the end of the list is reached. + + ---------------------------- + -- Find_Init_Call_In_List -- + ---------------------------- + + function Find_Init_Call_In_List (From : Node_Id) return Node_Id is + Init_Call : Node_Id; + begin + Init_Call := From; + + while Present (Init_Call) and then Init_Call /= Rep_Clause loop + if Nkind (Init_Call) = N_Procedure_Call_Statement + and then Is_Entity_Name (Name (Init_Call)) + and then Entity (Name (Init_Call)) = Init_Proc + then + return Init_Call; + end if; + Next (Init_Call); + end loop; + + return Empty; + end Find_Init_Call_In_List; + + Init_Call : Node_Id; + + -- Start of processing for Find_Init_Call + + begin + if not Has_Non_Null_Base_Init_Proc (Typ) then + -- No init proc for the type, so obviously no call to be found + + return Empty; + end if; + + Init_Proc := Base_Init_Proc (Typ); + + -- First scan the list containing the declaration of Var + + Init_Call := Find_Init_Call_In_List (From => Next (Parent (Var))); + + -- If not found, also look on Var's freeze actions list, if any, since + -- the init call may have been moved there (case of an address clause + -- applying to Var). + + if No (Init_Call) and then Present (Freeze_Node (Var)) then + Init_Call := Find_Init_Call_In_List + (First (Actions (Freeze_Node (Var)))); + end if; + + return Init_Call; + end Find_Init_Call; + + ------------------------ + -- Find_Interface_ADT -- + ------------------------ + + function Find_Interface_ADT + (T : Entity_Id; + Iface : Entity_Id) return Elmt_Id + is + ADT : Elmt_Id; + Typ : Entity_Id := T; + + begin + pragma Assert (Is_Interface (Iface)); + + -- Handle private types + + if Has_Private_Declaration (Typ) + and then Present (Full_View (Typ)) + then + Typ := Full_View (Typ); + end if; + + -- Handle access types + + if Is_Access_Type (Typ) then + Typ := Designated_Type (Typ); + end if; + + -- Handle task and protected types implementing interfaces + + if Is_Concurrent_Type (Typ) then + Typ := Corresponding_Record_Type (Typ); + end if; + + pragma Assert + (not Is_Class_Wide_Type (Typ) + and then Ekind (Typ) /= E_Incomplete_Type); + + if Is_Ancestor (Iface, Typ) then + return First_Elmt (Access_Disp_Table (Typ)); + + else + ADT := + Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); + while Present (ADT) + and then Present (Related_Type (Node (ADT))) + and then Related_Type (Node (ADT)) /= Iface + and then not Is_Ancestor (Iface, Related_Type (Node (ADT))) + loop + Next_Elmt (ADT); + end loop; + + pragma Assert (Present (Related_Type (Node (ADT)))); + return ADT; + end if; + end Find_Interface_ADT; + + ------------------------ + -- Find_Interface_Tag -- + ------------------------ + + function Find_Interface_Tag + (T : Entity_Id; + Iface : Entity_Id) return Entity_Id + is + AI_Tag : Entity_Id; + Found : Boolean := False; + Typ : Entity_Id := T; + + procedure Find_Tag (Typ : Entity_Id); + -- Internal subprogram used to recursively climb to the ancestors + + -------------- + -- Find_Tag -- + -------------- + + procedure Find_Tag (Typ : Entity_Id) is + AI_Elmt : Elmt_Id; + AI : Node_Id; + + begin + -- This routine does not handle the case in which the interface is an + -- ancestor of Typ. That case is handled by the enclosing subprogram. + + pragma Assert (Typ /= Iface); + + -- Climb to the root type handling private types + + if Present (Full_View (Etype (Typ))) then + if Full_View (Etype (Typ)) /= Typ then + Find_Tag (Full_View (Etype (Typ))); + end if; + + elsif Etype (Typ) /= Typ then + Find_Tag (Etype (Typ)); + end if; + + -- Traverse the list of interfaces implemented by the type + + if not Found + and then Present (Interfaces (Typ)) + and then not (Is_Empty_Elmt_List (Interfaces (Typ))) + then + -- Skip the tag associated with the primary table + + pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag)); + AI_Tag := Next_Tag_Component (First_Tag_Component (Typ)); + pragma Assert (Present (AI_Tag)); + + AI_Elmt := First_Elmt (Interfaces (Typ)); + while Present (AI_Elmt) loop + AI := Node (AI_Elmt); + + if AI = Iface or else Is_Ancestor (Iface, AI) then + Found := True; + return; + end if; + + AI_Tag := Next_Tag_Component (AI_Tag); + Next_Elmt (AI_Elmt); + end loop; + end if; + end Find_Tag; + + -- Start of processing for Find_Interface_Tag + + begin + pragma Assert (Is_Interface (Iface)); + + -- Handle access types + + if Is_Access_Type (Typ) then + Typ := Designated_Type (Typ); + end if; + + -- Handle class-wide types + + if Is_Class_Wide_Type (Typ) then + Typ := Root_Type (Typ); + end if; + + -- Handle private types + + if Has_Private_Declaration (Typ) + and then Present (Full_View (Typ)) + then + Typ := Full_View (Typ); + end if; + + -- Handle entities from the limited view + + if Ekind (Typ) = E_Incomplete_Type then + pragma Assert (Present (Non_Limited_View (Typ))); + Typ := Non_Limited_View (Typ); + end if; + + -- Handle task and protected types implementing interfaces + + if Is_Concurrent_Type (Typ) then + Typ := Corresponding_Record_Type (Typ); + end if; + + -- If the interface is an ancestor of the type, then it shared the + -- primary dispatch table. + + if Is_Ancestor (Iface, Typ) then + pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag)); + return First_Tag_Component (Typ); + + -- Otherwise we need to search for its associated tag component + + else + Find_Tag (Typ); + pragma Assert (Found); + return AI_Tag; + end if; + end Find_Interface_Tag; + + ------------------ + -- Find_Prim_Op -- + ------------------ + + function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id is + Prim : Elmt_Id; + Typ : Entity_Id := T; + Op : Entity_Id; + + begin + if Is_Class_Wide_Type (Typ) then + Typ := Root_Type (Typ); + end if; + + Typ := Underlying_Type (Typ); + + -- Loop through primitive operations + + Prim := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim) loop + Op := Node (Prim); + + -- We can retrieve primitive operations by name if it is an internal + -- name. For equality we must check that both of its operands have + -- the same type, to avoid confusion with user-defined equalities + -- than may have a non-symmetric signature. + + exit when Chars (Op) = Name + and then + (Name /= Name_Op_Eq + or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op))); + + Next_Elmt (Prim); + + -- Raise Program_Error if no primitive found + + if No (Prim) then + raise Program_Error; + end if; + end loop; + + return Node (Prim); + end Find_Prim_Op; + + ------------------ + -- Find_Prim_Op -- + ------------------ + + function Find_Prim_Op + (T : Entity_Id; + Name : TSS_Name_Type) return Entity_Id + is + Prim : Elmt_Id; + Typ : Entity_Id := T; + + begin + if Is_Class_Wide_Type (Typ) then + Typ := Root_Type (Typ); + end if; + + Typ := Underlying_Type (Typ); + + Prim := First_Elmt (Primitive_Operations (Typ)); + while not Is_TSS (Node (Prim), Name) loop + Next_Elmt (Prim); + + -- Raise program error if no primitive found + + if No (Prim) then + raise Program_Error; + end if; + end loop; + + return Node (Prim); + end Find_Prim_Op; + + ---------------------------- + -- Find_Protection_Object -- + ---------------------------- + + function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is + S : Entity_Id; + + begin + S := Scop; + while Present (S) loop + if (Ekind (S) = E_Entry + or else Ekind (S) = E_Entry_Family + or else Ekind (S) = E_Function + or else Ekind (S) = E_Procedure) + and then Present (Protection_Object (S)) + then + return Protection_Object (S); + end if; + + S := Scope (S); + end loop; + + -- If we do not find a Protection object in the scope chain, then + -- something has gone wrong, most likely the object was never created. + + raise Program_Error; + end Find_Protection_Object; + + ---------------------- + -- Force_Evaluation -- + ---------------------- + + procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False) is + begin + Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True); + end Force_Evaluation; + + --------------------------------- + -- Fully_Qualified_Name_String -- + --------------------------------- + + function Fully_Qualified_Name_String (E : Entity_Id) return String_Id is + procedure Internal_Full_Qualified_Name (E : Entity_Id); + -- Compute recursively the qualified name without NUL at the end, adding + -- it to the currently started string being generated + + ---------------------------------- + -- Internal_Full_Qualified_Name -- + ---------------------------------- + + procedure Internal_Full_Qualified_Name (E : Entity_Id) is + Ent : Entity_Id; + + begin + -- Deal properly with child units + + if Nkind (E) = N_Defining_Program_Unit_Name then + Ent := Defining_Identifier (E); + else + Ent := E; + end if; + + -- Compute qualification recursively (only "Standard" has no scope) + + if Present (Scope (Scope (Ent))) then + Internal_Full_Qualified_Name (Scope (Ent)); + Store_String_Char (Get_Char_Code ('.')); + end if; + + -- Every entity should have a name except some expanded blocks + -- don't bother about those. + + if Chars (Ent) = No_Name then + return; + end if; + + -- Generates the entity name in upper case + + Get_Decoded_Name_String (Chars (Ent)); + Set_All_Upper_Case; + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + return; + end Internal_Full_Qualified_Name; + + -- Start of processing for Full_Qualified_Name + + begin + Start_String; + Internal_Full_Qualified_Name (E); + Store_String_Char (Get_Char_Code (ASCII.NUL)); + return End_String; + end Fully_Qualified_Name_String; + + ------------------------ + -- Generate_Poll_Call -- + ------------------------ + + procedure Generate_Poll_Call (N : Node_Id) is + begin + -- No poll call if polling not active + + if not Polling_Required then + return; + + -- Otherwise generate require poll call + + else + Insert_Before_And_Analyze (N, + Make_Procedure_Call_Statement (Sloc (N), + Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N)))); + end if; + end Generate_Poll_Call; + + --------------------------------- + -- Get_Current_Value_Condition -- + --------------------------------- + + -- Note: the implementation of this procedure is very closely tied to the + -- implementation of Set_Current_Value_Condition. In the Get procedure, we + -- interpret Current_Value fields set by the Set procedure, so the two + -- procedures need to be closely coordinated. + + procedure Get_Current_Value_Condition + (Var : Node_Id; + Op : out Node_Kind; + Val : out Node_Id) + is + Loc : constant Source_Ptr := Sloc (Var); + Ent : constant Entity_Id := Entity (Var); + + procedure Process_Current_Value_Condition + (N : Node_Id; + S : Boolean); + -- N is an expression which holds either True (S = True) or False (S = + -- False) in the condition. This procedure digs out the expression and + -- if it refers to Ent, sets Op and Val appropriately. + + ------------------------------------- + -- Process_Current_Value_Condition -- + ------------------------------------- + + procedure Process_Current_Value_Condition + (N : Node_Id; + S : Boolean) + is + Cond : Node_Id; + Sens : Boolean; + + begin + Cond := N; + Sens := S; + + -- Deal with NOT operators, inverting sense + + while Nkind (Cond) = N_Op_Not loop + Cond := Right_Opnd (Cond); + Sens := not Sens; + end loop; + + -- Deal with AND THEN and AND cases + + if Nkind (Cond) = N_And_Then + or else Nkind (Cond) = N_Op_And + then + -- Don't ever try to invert a condition that is of the form of an + -- AND or AND THEN (since we are not doing sufficiently general + -- processing to allow this). + + if Sens = False then + Op := N_Empty; + Val := Empty; + return; + end if; + + -- Recursively process AND and AND THEN branches + + Process_Current_Value_Condition (Left_Opnd (Cond), True); + + if Op /= N_Empty then + return; + end if; + + Process_Current_Value_Condition (Right_Opnd (Cond), True); + return; + + -- Case of relational operator + + elsif Nkind (Cond) in N_Op_Compare then + Op := Nkind (Cond); + + -- Invert sense of test if inverted test + + if Sens = False then + case Op is + when N_Op_Eq => Op := N_Op_Ne; + when N_Op_Ne => Op := N_Op_Eq; + when N_Op_Lt => Op := N_Op_Ge; + when N_Op_Gt => Op := N_Op_Le; + when N_Op_Le => Op := N_Op_Gt; + when N_Op_Ge => Op := N_Op_Lt; + when others => raise Program_Error; + end case; + end if; + + -- Case of entity op value + + if Is_Entity_Name (Left_Opnd (Cond)) + and then Ent = Entity (Left_Opnd (Cond)) + and then Compile_Time_Known_Value (Right_Opnd (Cond)) + then + Val := Right_Opnd (Cond); + + -- Case of value op entity + + elsif Is_Entity_Name (Right_Opnd (Cond)) + and then Ent = Entity (Right_Opnd (Cond)) + and then Compile_Time_Known_Value (Left_Opnd (Cond)) + then + Val := Left_Opnd (Cond); + + -- We are effectively swapping operands + + case Op is + when N_Op_Eq => null; + when N_Op_Ne => null; + when N_Op_Lt => Op := N_Op_Gt; + when N_Op_Gt => Op := N_Op_Lt; + when N_Op_Le => Op := N_Op_Ge; + when N_Op_Ge => Op := N_Op_Le; + when others => raise Program_Error; + end case; + + else + Op := N_Empty; + end if; + + return; + + -- Case of Boolean variable reference, return as though the + -- reference had said var = True. + + else + if Is_Entity_Name (Cond) + and then Ent = Entity (Cond) + then + Val := New_Occurrence_Of (Standard_True, Sloc (Cond)); + + if Sens = False then + Op := N_Op_Ne; + else + Op := N_Op_Eq; + end if; + end if; + end if; + end Process_Current_Value_Condition; + + -- Start of processing for Get_Current_Value_Condition + + begin + Op := N_Empty; + Val := Empty; + + -- Immediate return, nothing doing, if this is not an object + + if Ekind (Ent) not in Object_Kind then + return; + end if; + + -- Otherwise examine current value + + declare + CV : constant Node_Id := Current_Value (Ent); + Sens : Boolean; + Stm : Node_Id; + + begin + -- If statement. Condition is known true in THEN section, known False + -- in any ELSIF or ELSE part, and unknown outside the IF statement. + + if Nkind (CV) = N_If_Statement then + + -- Before start of IF statement + + if Loc < Sloc (CV) then + return; + + -- After end of IF statement + + elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then + return; + end if; + + -- At this stage we know that we are within the IF statement, but + -- unfortunately, the tree does not record the SLOC of the ELSE so + -- we cannot use a simple SLOC comparison to distinguish between + -- the then/else statements, so we have to climb the tree. + + declare + N : Node_Id; + + begin + N := Parent (Var); + while Parent (N) /= CV loop + N := Parent (N); + + -- If we fall off the top of the tree, then that's odd, but + -- perhaps it could occur in some error situation, and the + -- safest response is simply to assume that the outcome of + -- the condition is unknown. No point in bombing during an + -- attempt to optimize things. + + if No (N) then + return; + end if; + end loop; + + -- Now we have N pointing to a node whose parent is the IF + -- statement in question, so now we can tell if we are within + -- the THEN statements. + + if Is_List_Member (N) + and then List_Containing (N) = Then_Statements (CV) + then + Sens := True; + + -- If the variable reference does not come from source, we + -- cannot reliably tell whether it appears in the else part. + -- In particular, if it appears in generated code for a node + -- that requires finalization, it may be attached to a list + -- that has not been yet inserted into the code. For now, + -- treat it as unknown. + + elsif not Comes_From_Source (N) then + return; + + -- Otherwise we must be in ELSIF or ELSE part + + else + Sens := False; + end if; + end; + + -- ELSIF part. Condition is known true within the referenced + -- ELSIF, known False in any subsequent ELSIF or ELSE part, + -- and unknown before the ELSE part or after the IF statement. + + elsif Nkind (CV) = N_Elsif_Part then + + -- if the Elsif_Part had condition_actions, the elsif has been + -- rewritten as a nested if, and the original elsif_part is + -- detached from the tree, so there is no way to obtain useful + -- information on the current value of the variable. + -- Can this be improved ??? + + if No (Parent (CV)) then + return; + end if; + + Stm := Parent (CV); + + -- Before start of ELSIF part + + if Loc < Sloc (CV) then + return; + + -- After end of IF statement + + elsif Loc >= Sloc (Stm) + + Text_Ptr (UI_To_Int (End_Span (Stm))) + then + return; + end if; + + -- Again we lack the SLOC of the ELSE, so we need to climb the + -- tree to see if we are within the ELSIF part in question. + + declare + N : Node_Id; + + begin + N := Parent (Var); + while Parent (N) /= Stm loop + N := Parent (N); + + -- If we fall off the top of the tree, then that's odd, but + -- perhaps it could occur in some error situation, and the + -- safest response is simply to assume that the outcome of + -- the condition is unknown. No point in bombing during an + -- attempt to optimize things. + + if No (N) then + return; + end if; + end loop; + + -- Now we have N pointing to a node whose parent is the IF + -- statement in question, so see if is the ELSIF part we want. + -- the THEN statements. + + if N = CV then + Sens := True; + + -- Otherwise we must be in subsequent ELSIF or ELSE part + + else + Sens := False; + end if; + end; + + -- Iteration scheme of while loop. The condition is known to be + -- true within the body of the loop. + + elsif Nkind (CV) = N_Iteration_Scheme then + declare + Loop_Stmt : constant Node_Id := Parent (CV); + + begin + -- Before start of body of loop + + if Loc < Sloc (Loop_Stmt) then + return; + + -- After end of LOOP statement + + elsif Loc >= Sloc (End_Label (Loop_Stmt)) then + return; + + -- We are within the body of the loop + + else + Sens := True; + end if; + end; + + -- All other cases of Current_Value settings + + else + return; + end if; + + -- If we fall through here, then we have a reportable condition, Sens + -- is True if the condition is true and False if it needs inverting. + + Process_Current_Value_Condition (Condition (CV), Sens); + end; + end Get_Current_Value_Condition; + + --------------------------------- + -- Has_Controlled_Coextensions -- + --------------------------------- + + function Has_Controlled_Coextensions (Typ : Entity_Id) return Boolean is + D_Typ : Entity_Id; + Discr : Entity_Id; + + begin + -- Only consider record types + + if not Ekind_In (Typ, E_Record_Type, E_Record_Subtype) then + return False; + end if; + + if Has_Discriminants (Typ) then + Discr := First_Discriminant (Typ); + while Present (Discr) loop + D_Typ := Etype (Discr); + + if Ekind (D_Typ) = E_Anonymous_Access_Type + and then + (Is_Controlled (Designated_Type (D_Typ)) + or else + Is_Concurrent_Type (Designated_Type (D_Typ))) + then + return True; + end if; + + Next_Discriminant (Discr); + end loop; + end if; + + return False; + end Has_Controlled_Coextensions; + + ------------------------ + -- Has_Address_Clause -- + ------------------------ + + -- Should this function check the private part in a package ??? + + function Has_Following_Address_Clause (D : Node_Id) return Boolean is + Id : constant Entity_Id := Defining_Identifier (D); + Decl : Node_Id; + + begin + Decl := Next (D); + while Present (Decl) loop + if Nkind (Decl) = N_At_Clause + and then Chars (Identifier (Decl)) = Chars (Id) + then + return True; + + elsif Nkind (Decl) = N_Attribute_Definition_Clause + and then Chars (Decl) = Name_Address + and then Chars (Name (Decl)) = Chars (Id) + then + return True; + end if; + + Next (Decl); + end loop; + + return False; + end Has_Following_Address_Clause; + + -------------------- + -- Homonym_Number -- + -------------------- + + function Homonym_Number (Subp : Entity_Id) return Nat is + Count : Nat; + Hom : Entity_Id; + + begin + Count := 1; + Hom := Homonym (Subp); + while Present (Hom) loop + if Scope (Hom) = Scope (Subp) then + Count := Count + 1; + end if; + + Hom := Homonym (Hom); + end loop; + + return Count; + end Homonym_Number; + + ------------------------------ + -- In_Unconditional_Context -- + ------------------------------ + + function In_Unconditional_Context (Node : Node_Id) return Boolean is + P : Node_Id; + + begin + P := Node; + while Present (P) loop + case Nkind (P) is + when N_Subprogram_Body => + return True; + + when N_If_Statement => + return False; + + when N_Loop_Statement => + return False; + + when N_Case_Statement => + return False; + + when others => + P := Parent (P); + end case; + end loop; + + return False; + end In_Unconditional_Context; + + ------------------- + -- Insert_Action -- + ------------------- + + procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is + begin + if Present (Ins_Action) then + Insert_Actions (Assoc_Node, New_List (Ins_Action)); + end if; + end Insert_Action; + + -- Version with check(s) suppressed + + procedure Insert_Action + (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id) + is + begin + Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress); + end Insert_Action; + + -------------------- + -- Insert_Actions -- + -------------------- + + procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is + N : Node_Id; + P : Node_Id; + + Wrapped_Node : Node_Id := Empty; + + begin + if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then + return; + end if; + + -- Ignore insert of actions from inside default expression (or other + -- similar "spec expression") in the special spec-expression analyze + -- mode. Any insertions at this point have no relevance, since we are + -- only doing the analyze to freeze the types of any static expressions. + -- See section "Handling of Default Expressions" in the spec of package + -- Sem for further details. + + if In_Spec_Expression then + return; + end if; + + -- If the action derives from stuff inside a record, then the actions + -- are attached to the current scope, to be inserted and analyzed on + -- exit from the scope. The reason for this is that we may also + -- be generating freeze actions at the same time, and they must + -- eventually be elaborated in the correct order. + + if Is_Record_Type (Current_Scope) + and then not Is_Frozen (Current_Scope) + then + if No (Scope_Stack.Table + (Scope_Stack.Last).Pending_Freeze_Actions) + then + Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions := + Ins_Actions; + else + Append_List + (Ins_Actions, + Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions); + end if; + + return; + end if; + + -- We now intend to climb up the tree to find the right point to + -- insert the actions. We start at Assoc_Node, unless this node is + -- a subexpression in which case we start with its parent. We do this + -- for two reasons. First it speeds things up. Second, if Assoc_Node + -- is itself one of the special nodes like N_And_Then, then we assume + -- that an initial request to insert actions for such a node does not + -- expect the actions to get deposited in the node for later handling + -- when the node is expanded, since clearly the node is being dealt + -- with by the caller. Note that in the subexpression case, N is + -- always the child we came from. + + -- N_Raise_xxx_Error is an annoying special case, it is a statement + -- if it has type Standard_Void_Type, and a subexpression otherwise. + -- otherwise. Procedure attribute references are also statements. + + if Nkind (Assoc_Node) in N_Subexpr + and then (Nkind (Assoc_Node) in N_Raise_xxx_Error + or else Etype (Assoc_Node) /= Standard_Void_Type) + and then (Nkind (Assoc_Node) /= N_Attribute_Reference + or else + not Is_Procedure_Attribute_Name + (Attribute_Name (Assoc_Node))) + then + P := Assoc_Node; -- ??? does not agree with above! + N := Parent (Assoc_Node); + + -- Non-subexpression case. Note that N is initially Empty in this + -- case (N is only guaranteed Non-Empty in the subexpr case). + + else + P := Assoc_Node; + N := Empty; + end if; + + -- Capture root of the transient scope + + if Scope_Is_Transient then + Wrapped_Node := Node_To_Be_Wrapped; + end if; + + loop + pragma Assert (Present (P)); + + case Nkind (P) is + + -- Case of right operand of AND THEN or OR ELSE. Put the actions + -- in the Actions field of the right operand. They will be moved + -- out further when the AND THEN or OR ELSE operator is expanded. + -- Nothing special needs to be done for the left operand since + -- in that case the actions are executed unconditionally. + + when N_Short_Circuit => + if N = Right_Opnd (P) then + + -- We are now going to either append the actions to the + -- actions field of the short-circuit operation. We will + -- also analyze the actions now. + + -- This analysis is really too early, the proper thing would + -- be to just park them there now, and only analyze them if + -- we find we really need them, and to it at the proper + -- final insertion point. However attempting to this proved + -- tricky, so for now we just kill current values before and + -- after the analyze call to make sure we avoid peculiar + -- optimizations from this out of order insertion. + + Kill_Current_Values; + + if Present (Actions (P)) then + Insert_List_After_And_Analyze + (Last (Actions (P)), Ins_Actions); + else + Set_Actions (P, Ins_Actions); + Analyze_List (Actions (P)); + end if; + + Kill_Current_Values; + + return; + end if; + + -- Then or Else operand of conditional expression. Add actions to + -- Then_Actions or Else_Actions field as appropriate. The actions + -- will be moved further out when the conditional is expanded. + + when N_Conditional_Expression => + declare + ThenX : constant Node_Id := Next (First (Expressions (P))); + ElseX : constant Node_Id := Next (ThenX); + + begin + -- If the enclosing expression is already analyzed, as + -- is the case for nested elaboration checks, insert the + -- conditional further out. + + if Analyzed (P) then + null; + + -- Actions belong to the then expression, temporarily place + -- them as Then_Actions of the conditional expr. They will + -- be moved to the proper place later when the conditional + -- expression is expanded. + + elsif N = ThenX then + if Present (Then_Actions (P)) then + Insert_List_After_And_Analyze + (Last (Then_Actions (P)), Ins_Actions); + else + Set_Then_Actions (P, Ins_Actions); + Analyze_List (Then_Actions (P)); + end if; + + return; + + -- Actions belong to the else expression, temporarily + -- place them as Else_Actions of the conditional expr. + -- They will be moved to the proper place later when + -- the conditional expression is expanded. + + elsif N = ElseX then + if Present (Else_Actions (P)) then + Insert_List_After_And_Analyze + (Last (Else_Actions (P)), Ins_Actions); + else + Set_Else_Actions (P, Ins_Actions); + Analyze_List (Else_Actions (P)); + end if; + + return; + + -- Actions belong to the condition. In this case they are + -- unconditionally executed, and so we can continue the + -- search for the proper insert point. + + else + null; + end if; + end; + + -- Alternative of case expression, we place the action in the + -- Actions field of the case expression alternative, this will + -- be handled when the case expression is expanded. + + when N_Case_Expression_Alternative => + if Present (Actions (P)) then + Insert_List_After_And_Analyze + (Last (Actions (P)), Ins_Actions); + else + Set_Actions (P, Ins_Actions); + Analyze_List (Then_Actions (P)); + end if; + + return; + + -- Case of appearing within an Expressions_With_Actions node. We + -- prepend the actions to the list of actions already there, if + -- the node has not been analyzed yet. Otherwise find insertion + -- location further up the tree. + + when N_Expression_With_Actions => + if not Analyzed (P) then + Prepend_List (Ins_Actions, Actions (P)); + return; + end if; + + -- Case of appearing in the condition of a while expression or + -- elsif. We insert the actions into the Condition_Actions field. + -- They will be moved further out when the while loop or elsif + -- is analyzed. + + when N_Iteration_Scheme | + N_Elsif_Part + => + if N = Condition (P) then + if Present (Condition_Actions (P)) then + Insert_List_After_And_Analyze + (Last (Condition_Actions (P)), Ins_Actions); + else + Set_Condition_Actions (P, Ins_Actions); + + -- Set the parent of the insert actions explicitly. This + -- is not a syntactic field, but we need the parent field + -- set, in particular so that freeze can understand that + -- it is dealing with condition actions, and properly + -- insert the freezing actions. + + Set_Parent (Ins_Actions, P); + Analyze_List (Condition_Actions (P)); + end if; + + return; + end if; + + -- Statements, declarations, pragmas, representation clauses + + when + -- Statements + + N_Procedure_Call_Statement | + N_Statement_Other_Than_Procedure_Call | + + -- Pragmas + + N_Pragma | + + -- Representation_Clause + + N_At_Clause | + N_Attribute_Definition_Clause | + N_Enumeration_Representation_Clause | + N_Record_Representation_Clause | + + -- Declarations + + N_Abstract_Subprogram_Declaration | + N_Entry_Body | + N_Exception_Declaration | + N_Exception_Renaming_Declaration | + N_Formal_Abstract_Subprogram_Declaration | + N_Formal_Concrete_Subprogram_Declaration | + N_Formal_Object_Declaration | + N_Formal_Type_Declaration | + N_Full_Type_Declaration | + N_Function_Instantiation | + N_Generic_Function_Renaming_Declaration | + N_Generic_Package_Declaration | + N_Generic_Package_Renaming_Declaration | + N_Generic_Procedure_Renaming_Declaration | + N_Generic_Subprogram_Declaration | + N_Implicit_Label_Declaration | + N_Incomplete_Type_Declaration | + N_Number_Declaration | + N_Object_Declaration | + N_Object_Renaming_Declaration | + N_Package_Body | + N_Package_Body_Stub | + N_Package_Declaration | + N_Package_Instantiation | + N_Package_Renaming_Declaration | + N_Parameterized_Expression | + N_Private_Extension_Declaration | + N_Private_Type_Declaration | + N_Procedure_Instantiation | + N_Protected_Body | + N_Protected_Body_Stub | + N_Protected_Type_Declaration | + N_Single_Task_Declaration | + N_Subprogram_Body | + N_Subprogram_Body_Stub | + N_Subprogram_Declaration | + N_Subprogram_Renaming_Declaration | + N_Subtype_Declaration | + N_Task_Body | + N_Task_Body_Stub | + N_Task_Type_Declaration | + + -- Freeze entity behaves like a declaration or statement + + N_Freeze_Entity + => + -- Do not insert here if the item is not a list member (this + -- happens for example with a triggering statement, and the + -- proper approach is to insert before the entire select). + + if not Is_List_Member (P) then + null; + + -- Do not insert if parent of P is an N_Component_Association + -- node (i.e. we are in the context of an N_Aggregate or + -- N_Extension_Aggregate node. In this case we want to insert + -- before the entire aggregate. + + elsif Nkind (Parent (P)) = N_Component_Association then + null; + + -- Do not insert if the parent of P is either an N_Variant + -- node or an N_Record_Definition node, meaning in either + -- case that P is a member of a component list, and that + -- therefore the actions should be inserted outside the + -- complete record declaration. + + elsif Nkind (Parent (P)) = N_Variant + or else Nkind (Parent (P)) = N_Record_Definition + then + null; + + -- Do not insert freeze nodes within the loop generated for + -- an aggregate, because they may be elaborated too late for + -- subsequent use in the back end: within a package spec the + -- loop is part of the elaboration procedure and is only + -- elaborated during the second pass. + + -- If the loop comes from source, or the entity is local to + -- the loop itself it must remain within. + + elsif Nkind (Parent (P)) = N_Loop_Statement + and then not Comes_From_Source (Parent (P)) + and then Nkind (First (Ins_Actions)) = N_Freeze_Entity + and then + Scope (Entity (First (Ins_Actions))) /= Current_Scope + then + null; + + -- Otherwise we can go ahead and do the insertion + + elsif P = Wrapped_Node then + Store_Before_Actions_In_Scope (Ins_Actions); + return; + + else + Insert_List_Before_And_Analyze (P, Ins_Actions); + return; + end if; + + -- A special case, N_Raise_xxx_Error can act either as a statement + -- or a subexpression. We tell the difference by looking at the + -- Etype. It is set to Standard_Void_Type in the statement case. + + when + N_Raise_xxx_Error => + if Etype (P) = Standard_Void_Type then + if P = Wrapped_Node then + Store_Before_Actions_In_Scope (Ins_Actions); + else + Insert_List_Before_And_Analyze (P, Ins_Actions); + end if; + + return; + + -- In the subexpression case, keep climbing + + else + null; + end if; + + -- If a component association appears within a loop created for + -- an array aggregate, attach the actions to the association so + -- they can be subsequently inserted within the loop. For other + -- component associations insert outside of the aggregate. For + -- an association that will generate a loop, its Loop_Actions + -- attribute is already initialized (see exp_aggr.adb). + + -- The list of loop_actions can in turn generate additional ones, + -- that are inserted before the associated node. If the associated + -- node is outside the aggregate, the new actions are collected + -- at the end of the loop actions, to respect the order in which + -- they are to be elaborated. + + when + N_Component_Association => + if Nkind (Parent (P)) = N_Aggregate + and then Present (Loop_Actions (P)) + then + if Is_Empty_List (Loop_Actions (P)) then + Set_Loop_Actions (P, Ins_Actions); + Analyze_List (Ins_Actions); + + else + declare + Decl : Node_Id; + + begin + -- Check whether these actions were generated by a + -- declaration that is part of the loop_ actions + -- for the component_association. + + Decl := Assoc_Node; + while Present (Decl) loop + exit when Parent (Decl) = P + and then Is_List_Member (Decl) + and then + List_Containing (Decl) = Loop_Actions (P); + Decl := Parent (Decl); + end loop; + + if Present (Decl) then + Insert_List_Before_And_Analyze + (Decl, Ins_Actions); + else + Insert_List_After_And_Analyze + (Last (Loop_Actions (P)), Ins_Actions); + end if; + end; + end if; + + return; + + else + null; + end if; + + -- Another special case, an attribute denoting a procedure call + + when + N_Attribute_Reference => + if Is_Procedure_Attribute_Name (Attribute_Name (P)) then + if P = Wrapped_Node then + Store_Before_Actions_In_Scope (Ins_Actions); + else + Insert_List_Before_And_Analyze (P, Ins_Actions); + end if; + + return; + + -- In the subexpression case, keep climbing + + else + null; + end if; + + -- For all other node types, keep climbing tree + + when + N_Abortable_Part | + N_Accept_Alternative | + N_Access_Definition | + N_Access_Function_Definition | + N_Access_Procedure_Definition | + N_Access_To_Object_Definition | + N_Aggregate | + N_Allocator | + N_Aspect_Specification | + N_Case_Expression | + N_Case_Statement_Alternative | + N_Character_Literal | + N_Compilation_Unit | + N_Compilation_Unit_Aux | + N_Component_Clause | + N_Component_Declaration | + N_Component_Definition | + N_Component_List | + N_Constrained_Array_Definition | + N_Decimal_Fixed_Point_Definition | + N_Defining_Character_Literal | + N_Defining_Identifier | + N_Defining_Operator_Symbol | + N_Defining_Program_Unit_Name | + N_Delay_Alternative | + N_Delta_Constraint | + N_Derived_Type_Definition | + N_Designator | + N_Digits_Constraint | + N_Discriminant_Association | + N_Discriminant_Specification | + N_Empty | + N_Entry_Body_Formal_Part | + N_Entry_Call_Alternative | + N_Entry_Declaration | + N_Entry_Index_Specification | + N_Enumeration_Type_Definition | + N_Error | + N_Exception_Handler | + N_Expanded_Name | + N_Explicit_Dereference | + N_Extension_Aggregate | + N_Floating_Point_Definition | + N_Formal_Decimal_Fixed_Point_Definition | + N_Formal_Derived_Type_Definition | + N_Formal_Discrete_Type_Definition | + N_Formal_Floating_Point_Definition | + N_Formal_Modular_Type_Definition | + N_Formal_Ordinary_Fixed_Point_Definition | + N_Formal_Package_Declaration | + N_Formal_Private_Type_Definition | + N_Formal_Signed_Integer_Type_Definition | + N_Function_Call | + N_Function_Specification | + N_Generic_Association | + N_Handled_Sequence_Of_Statements | + N_Identifier | + N_In | + N_Index_Or_Discriminant_Constraint | + N_Indexed_Component | + N_Integer_Literal | + N_Iterator_Specification | + N_Itype_Reference | + N_Label | + N_Loop_Parameter_Specification | + N_Mod_Clause | + N_Modular_Type_Definition | + N_Not_In | + N_Null | + N_Op_Abs | + N_Op_Add | + N_Op_And | + N_Op_Concat | + N_Op_Divide | + N_Op_Eq | + N_Op_Expon | + N_Op_Ge | + N_Op_Gt | + N_Op_Le | + N_Op_Lt | + N_Op_Minus | + N_Op_Mod | + N_Op_Multiply | + N_Op_Ne | + N_Op_Not | + N_Op_Or | + N_Op_Plus | + N_Op_Rem | + N_Op_Rotate_Left | + N_Op_Rotate_Right | + N_Op_Shift_Left | + N_Op_Shift_Right | + N_Op_Shift_Right_Arithmetic | + N_Op_Subtract | + N_Op_Xor | + N_Operator_Symbol | + N_Ordinary_Fixed_Point_Definition | + N_Others_Choice | + N_Package_Specification | + N_Parameter_Association | + N_Parameter_Specification | + N_Pop_Constraint_Error_Label | + N_Pop_Program_Error_Label | + N_Pop_Storage_Error_Label | + N_Pragma_Argument_Association | + N_Procedure_Specification | + N_Protected_Definition | + N_Push_Constraint_Error_Label | + N_Push_Program_Error_Label | + N_Push_Storage_Error_Label | + N_Qualified_Expression | + N_Quantified_Expression | + N_Range | + N_Range_Constraint | + N_Real_Literal | + N_Real_Range_Specification | + N_Record_Definition | + N_Reference | + N_SCIL_Dispatch_Table_Tag_Init | + N_SCIL_Dispatching_Call | + N_SCIL_Membership_Test | + N_Selected_Component | + N_Signed_Integer_Type_Definition | + N_Single_Protected_Declaration | + N_Slice | + N_String_Literal | + N_Subprogram_Info | + N_Subtype_Indication | + N_Subunit | + N_Task_Definition | + N_Terminate_Alternative | + N_Triggering_Alternative | + N_Type_Conversion | + N_Unchecked_Expression | + N_Unchecked_Type_Conversion | + N_Unconstrained_Array_Definition | + N_Unused_At_End | + N_Unused_At_Start | + N_Use_Package_Clause | + N_Use_Type_Clause | + N_Variant | + N_Variant_Part | + N_Validate_Unchecked_Conversion | + N_With_Clause + => + null; + + end case; + + -- Make sure that inserted actions stay in the transient scope + + if P = Wrapped_Node then + Store_Before_Actions_In_Scope (Ins_Actions); + return; + end if; + + -- If we fall through above tests, keep climbing tree + + N := P; + + if Nkind (Parent (N)) = N_Subunit then + + -- This is the proper body corresponding to a stub. Insertion must + -- be done at the point of the stub, which is in the declarative + -- part of the parent unit. + + P := Corresponding_Stub (Parent (N)); + + else + P := Parent (N); + end if; + end loop; + end Insert_Actions; + + -- Version with check(s) suppressed + + procedure Insert_Actions + (Assoc_Node : Node_Id; + Ins_Actions : List_Id; + Suppress : Check_Id) + is + begin + if Suppress = All_Checks then + declare + Svg : constant Suppress_Array := Scope_Suppress; + begin + Scope_Suppress := (others => True); + Insert_Actions (Assoc_Node, Ins_Actions); + Scope_Suppress := Svg; + end; + + else + declare + Svg : constant Boolean := Scope_Suppress (Suppress); + begin + Scope_Suppress (Suppress) := True; + Insert_Actions (Assoc_Node, Ins_Actions); + Scope_Suppress (Suppress) := Svg; + end; + end if; + end Insert_Actions; + + -------------------------- + -- Insert_Actions_After -- + -------------------------- + + procedure Insert_Actions_After + (Assoc_Node : Node_Id; + Ins_Actions : List_Id) + is + begin + if Scope_Is_Transient + and then Assoc_Node = Node_To_Be_Wrapped + then + Store_After_Actions_In_Scope (Ins_Actions); + else + Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions); + end if; + end Insert_Actions_After; + + --------------------------------- + -- Insert_Library_Level_Action -- + --------------------------------- + + procedure Insert_Library_Level_Action (N : Node_Id) is + Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit)); + + begin + Push_Scope (Cunit_Entity (Main_Unit)); + -- ??? should this be Current_Sem_Unit instead of Main_Unit? + + if No (Actions (Aux)) then + Set_Actions (Aux, New_List (N)); + else + Append (N, Actions (Aux)); + end if; + + Analyze (N); + Pop_Scope; + end Insert_Library_Level_Action; + + ---------------------------------- + -- Insert_Library_Level_Actions -- + ---------------------------------- + + procedure Insert_Library_Level_Actions (L : List_Id) is + Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit)); + + begin + if Is_Non_Empty_List (L) then + Push_Scope (Cunit_Entity (Main_Unit)); + -- ??? should this be Current_Sem_Unit instead of Main_Unit? + + if No (Actions (Aux)) then + Set_Actions (Aux, L); + Analyze_List (L); + else + Insert_List_After_And_Analyze (Last (Actions (Aux)), L); + end if; + + Pop_Scope; + end if; + end Insert_Library_Level_Actions; + + ---------------------- + -- Inside_Init_Proc -- + ---------------------- + + function Inside_Init_Proc return Boolean is + S : Entity_Id; + + begin + S := Current_Scope; + while Present (S) + and then S /= Standard_Standard + loop + if Is_Init_Proc (S) then + return True; + else + S := Scope (S); + end if; + end loop; + + return False; + end Inside_Init_Proc; + + ---------------------------- + -- Is_All_Null_Statements -- + ---------------------------- + + function Is_All_Null_Statements (L : List_Id) return Boolean is + Stm : Node_Id; + + begin + Stm := First (L); + while Present (Stm) loop + if Nkind (Stm) /= N_Null_Statement then + return False; + end if; + + Next (Stm); + end loop; + + return True; + end Is_All_Null_Statements; + + --------------------------------- + -- Is_Fully_Repped_Tagged_Type -- + --------------------------------- + + function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean is + U : constant Entity_Id := Underlying_Type (T); + Comp : Entity_Id; + + begin + if No (U) or else not Is_Tagged_Type (U) then + return False; + elsif Has_Discriminants (U) then + return False; + elsif not Has_Specified_Layout (U) then + return False; + end if; + + -- Here we have a tagged type, see if it has any unlayed out fields + -- other than a possible tag and parent fields. If so, we return False. + + Comp := First_Component (U); + while Present (Comp) loop + if not Is_Tag (Comp) + and then Chars (Comp) /= Name_uParent + and then No (Component_Clause (Comp)) + then + return False; + else + Next_Component (Comp); + end if; + end loop; + + -- All components are layed out + + return True; + end Is_Fully_Repped_Tagged_Type; + + ---------------------------------- + -- Is_Library_Level_Tagged_Type -- + ---------------------------------- + + function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean is + begin + return Is_Tagged_Type (Typ) + and then Is_Library_Level_Entity (Typ); + end Is_Library_Level_Tagged_Type; + + ---------------------------------- + -- Is_Possibly_Unaligned_Object -- + ---------------------------------- + + function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is + T : constant Entity_Id := Etype (N); + + begin + -- If renamed object, apply test to underlying object + + if Is_Entity_Name (N) + and then Is_Object (Entity (N)) + and then Present (Renamed_Object (Entity (N))) + then + return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N))); + end if; + + -- Tagged and controlled types and aliased types are always aligned, + -- as are concurrent types. + + if Is_Aliased (T) + or else Has_Controlled_Component (T) + or else Is_Concurrent_Type (T) + or else Is_Tagged_Type (T) + or else Is_Controlled (T) + then + return False; + end if; + + -- If this is an element of a packed array, may be unaligned + + if Is_Ref_To_Bit_Packed_Array (N) then + return True; + end if; + + -- Case of component reference + + if Nkind (N) = N_Selected_Component then + declare + P : constant Node_Id := Prefix (N); + C : constant Entity_Id := Entity (Selector_Name (N)); + M : Nat; + S : Nat; + + begin + -- If component reference is for an array with non-static bounds, + -- then it is always aligned: we can only process unaligned + -- arrays with static bounds (more accurately bounds known at + -- compile time). + + if Is_Array_Type (T) + and then not Compile_Time_Known_Bounds (T) + then + return False; + end if; + + -- If component is aliased, it is definitely properly aligned + + if Is_Aliased (C) then + return False; + end if; + + -- If component is for a type implemented as a scalar, and the + -- record is packed, and the component is other than the first + -- component of the record, then the component may be unaligned. + + if Is_Packed (Etype (P)) + and then Represented_As_Scalar (Etype (C)) + and then First_Entity (Scope (C)) /= C + then + return True; + end if; + + -- Compute maximum possible alignment for T + + -- If alignment is known, then that settles things + + if Known_Alignment (T) then + M := UI_To_Int (Alignment (T)); + + -- If alignment is not known, tentatively set max alignment + + else + M := Ttypes.Maximum_Alignment; + + -- We can reduce this if the Esize is known since the default + -- alignment will never be more than the smallest power of 2 + -- that does not exceed this Esize value. + + if Known_Esize (T) then + S := UI_To_Int (Esize (T)); + + while (M / 2) >= S loop + M := M / 2; + end loop; + end if; + end if; + + -- The following code is historical, it used to be present but it + -- is too cautious, because the front-end does not know the proper + -- default alignments for the target. Also, if the alignment is + -- not known, the front end can't know in any case! If a copy is + -- needed, the back-end will take care of it. This whole section + -- including this comment can be removed later ??? + + -- If the component reference is for a record that has a specified + -- alignment, and we either know it is too small, or cannot tell, + -- then the component may be unaligned. + + -- if Known_Alignment (Etype (P)) + -- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment + -- and then M > Alignment (Etype (P)) + -- then + -- return True; + -- end if; + + -- Case of component clause present which may specify an + -- unaligned position. + + if Present (Component_Clause (C)) then + + -- Otherwise we can do a test to make sure that the actual + -- start position in the record, and the length, are both + -- consistent with the required alignment. If not, we know + -- that we are unaligned. + + declare + Align_In_Bits : constant Nat := M * System_Storage_Unit; + begin + if Component_Bit_Offset (C) mod Align_In_Bits /= 0 + or else Esize (C) mod Align_In_Bits /= 0 + then + return True; + end if; + end; + end if; + + -- Otherwise, for a component reference, test prefix + + return Is_Possibly_Unaligned_Object (P); + end; + + -- If not a component reference, must be aligned + + else + return False; + end if; + end Is_Possibly_Unaligned_Object; + + --------------------------------- + -- Is_Possibly_Unaligned_Slice -- + --------------------------------- + + function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is + begin + -- Go to renamed object + + if Is_Entity_Name (N) + and then Is_Object (Entity (N)) + and then Present (Renamed_Object (Entity (N))) + then + return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N))); + end if; + + -- The reference must be a slice + + if Nkind (N) /= N_Slice then + return False; + end if; + + -- Always assume the worst for a nested record component with a + -- component clause, which gigi/gcc does not appear to handle well. + -- It is not clear why this special test is needed at all ??? + + if Nkind (Prefix (N)) = N_Selected_Component + and then Nkind (Prefix (Prefix (N))) = N_Selected_Component + and then + Present (Component_Clause (Entity (Selector_Name (Prefix (N))))) + then + return True; + end if; + + -- We only need to worry if the target has strict alignment + + if not Target_Strict_Alignment then + return False; + end if; + + -- If it is a slice, then look at the array type being sliced + + declare + Sarr : constant Node_Id := Prefix (N); + -- Prefix of the slice, i.e. the array being sliced + + Styp : constant Entity_Id := Etype (Prefix (N)); + -- Type of the array being sliced + + Pref : Node_Id; + Ptyp : Entity_Id; + + begin + -- The problems arise if the array object that is being sliced + -- is a component of a record or array, and we cannot guarantee + -- the alignment of the array within its containing object. + + -- To investigate this, we look at successive prefixes to see + -- if we have a worrisome indexed or selected component. + + Pref := Sarr; + loop + -- Case of array is part of an indexed component reference + + if Nkind (Pref) = N_Indexed_Component then + Ptyp := Etype (Prefix (Pref)); + + -- The only problematic case is when the array is packed, + -- in which case we really know nothing about the alignment + -- of individual components. + + if Is_Bit_Packed_Array (Ptyp) then + return True; + end if; + + -- Case of array is part of a selected component reference + + elsif Nkind (Pref) = N_Selected_Component then + Ptyp := Etype (Prefix (Pref)); + + -- We are definitely in trouble if the record in question + -- has an alignment, and either we know this alignment is + -- inconsistent with the alignment of the slice, or we + -- don't know what the alignment of the slice should be. + + if Known_Alignment (Ptyp) + and then (Unknown_Alignment (Styp) + or else Alignment (Styp) > Alignment (Ptyp)) + then + return True; + end if; + + -- We are in potential trouble if the record type is packed. + -- We could special case when we know that the array is the + -- first component, but that's not such a simple case ??? + + if Is_Packed (Ptyp) then + return True; + end if; + + -- We are in trouble if there is a component clause, and + -- either we do not know the alignment of the slice, or + -- the alignment of the slice is inconsistent with the + -- bit position specified by the component clause. + + declare + Field : constant Entity_Id := Entity (Selector_Name (Pref)); + begin + if Present (Component_Clause (Field)) + and then + (Unknown_Alignment (Styp) + or else + (Component_Bit_Offset (Field) mod + (System_Storage_Unit * Alignment (Styp))) /= 0) + then + return True; + end if; + end; + + -- For cases other than selected or indexed components we + -- know we are OK, since no issues arise over alignment. + + else + return False; + end if; + + -- We processed an indexed component or selected component + -- reference that looked safe, so keep checking prefixes. + + Pref := Prefix (Pref); + end loop; + end; + end Is_Possibly_Unaligned_Slice; + + -------------------------------- + -- Is_Ref_To_Bit_Packed_Array -- + -------------------------------- + + function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is + Result : Boolean; + Expr : Node_Id; + + begin + if Is_Entity_Name (N) + and then Is_Object (Entity (N)) + and then Present (Renamed_Object (Entity (N))) + then + return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N))); + end if; + + if Nkind (N) = N_Indexed_Component + or else + Nkind (N) = N_Selected_Component + then + if Is_Bit_Packed_Array (Etype (Prefix (N))) then + Result := True; + else + Result := Is_Ref_To_Bit_Packed_Array (Prefix (N)); + end if; + + if Result and then Nkind (N) = N_Indexed_Component then + Expr := First (Expressions (N)); + while Present (Expr) loop + Force_Evaluation (Expr); + Next (Expr); + end loop; + end if; + + return Result; + + else + return False; + end if; + end Is_Ref_To_Bit_Packed_Array; + + -------------------------------- + -- Is_Ref_To_Bit_Packed_Slice -- + -------------------------------- + + function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is + begin + if Nkind (N) = N_Type_Conversion then + return Is_Ref_To_Bit_Packed_Slice (Expression (N)); + + elsif Is_Entity_Name (N) + and then Is_Object (Entity (N)) + and then Present (Renamed_Object (Entity (N))) + then + return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N))); + + elsif Nkind (N) = N_Slice + and then Is_Bit_Packed_Array (Etype (Prefix (N))) + then + return True; + + elsif Nkind (N) = N_Indexed_Component + or else + Nkind (N) = N_Selected_Component + then + return Is_Ref_To_Bit_Packed_Slice (Prefix (N)); + + else + return False; + end if; + end Is_Ref_To_Bit_Packed_Slice; + + ----------------------- + -- Is_Renamed_Object -- + ----------------------- + + function Is_Renamed_Object (N : Node_Id) return Boolean is + Pnod : constant Node_Id := Parent (N); + Kind : constant Node_Kind := Nkind (Pnod); + begin + if Kind = N_Object_Renaming_Declaration then + return True; + elsif Nkind_In (Kind, N_Indexed_Component, N_Selected_Component) then + return Is_Renamed_Object (Pnod); + else + return False; + end if; + end Is_Renamed_Object; + + ---------------------------- + -- Is_Untagged_Derivation -- + ---------------------------- + + function Is_Untagged_Derivation (T : Entity_Id) return Boolean is + begin + return (not Is_Tagged_Type (T) and then Is_Derived_Type (T)) + or else + (Is_Private_Type (T) and then Present (Full_View (T)) + and then not Is_Tagged_Type (Full_View (T)) + and then Is_Derived_Type (Full_View (T)) + and then Etype (Full_View (T)) /= T); + end Is_Untagged_Derivation; + + --------------------------- + -- Is_Volatile_Reference -- + --------------------------- + + function Is_Volatile_Reference (N : Node_Id) return Boolean is + begin + if Nkind (N) in N_Has_Etype + and then Present (Etype (N)) + and then Treat_As_Volatile (Etype (N)) + then + return True; + + elsif Is_Entity_Name (N) then + return Treat_As_Volatile (Entity (N)); + + elsif Nkind (N) = N_Slice then + return Is_Volatile_Reference (Prefix (N)); + + elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then + if (Is_Entity_Name (Prefix (N)) + and then Has_Volatile_Components (Entity (Prefix (N)))) + or else (Present (Etype (Prefix (N))) + and then Has_Volatile_Components (Etype (Prefix (N)))) + then + return True; + else + return Is_Volatile_Reference (Prefix (N)); + end if; + + else + return False; + end if; + end Is_Volatile_Reference; + + -------------------- + -- Kill_Dead_Code -- + -------------------- + + procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is + W : Boolean := Warn; + -- Set False if warnings suppressed + + begin + if Present (N) then + Remove_Warning_Messages (N); + + -- Generate warning if appropriate + + if W then + + -- We suppress the warning if this code is under control of an + -- if statement, whose condition is a simple identifier, and + -- either we are in an instance, or warnings off is set for this + -- identifier. The reason for killing it in the instance case is + -- that it is common and reasonable for code to be deleted in + -- instances for various reasons. + + if Nkind (Parent (N)) = N_If_Statement then + declare + C : constant Node_Id := Condition (Parent (N)); + begin + if Nkind (C) = N_Identifier + and then + (In_Instance + or else (Present (Entity (C)) + and then Has_Warnings_Off (Entity (C)))) + then + W := False; + end if; + end; + end if; + + -- Generate warning if not suppressed + + if W then + Error_Msg_F + ("?this code can never be executed and has been deleted!", N); + end if; + end if; + + -- Recurse into block statements and bodies to process declarations + -- and statements. + + if Nkind (N) = N_Block_Statement + or else Nkind (N) = N_Subprogram_Body + or else Nkind (N) = N_Package_Body + then + Kill_Dead_Code (Declarations (N), False); + Kill_Dead_Code (Statements (Handled_Statement_Sequence (N))); + + if Nkind (N) = N_Subprogram_Body then + Set_Is_Eliminated (Defining_Entity (N)); + end if; + + elsif Nkind (N) = N_Package_Declaration then + Kill_Dead_Code (Visible_Declarations (Specification (N))); + Kill_Dead_Code (Private_Declarations (Specification (N))); + + -- ??? After this point, Delete_Tree has been called on all + -- declarations in Specification (N), so references to + -- entities therein look suspicious. + + declare + E : Entity_Id := First_Entity (Defining_Entity (N)); + begin + while Present (E) loop + if Ekind (E) = E_Operator then + Set_Is_Eliminated (E); + end if; + + Next_Entity (E); + end loop; + end; + + -- Recurse into composite statement to kill individual statements, + -- in particular instantiations. + + elsif Nkind (N) = N_If_Statement then + Kill_Dead_Code (Then_Statements (N)); + Kill_Dead_Code (Elsif_Parts (N)); + Kill_Dead_Code (Else_Statements (N)); + + elsif Nkind (N) = N_Loop_Statement then + Kill_Dead_Code (Statements (N)); + + elsif Nkind (N) = N_Case_Statement then + declare + Alt : Node_Id; + begin + Alt := First (Alternatives (N)); + while Present (Alt) loop + Kill_Dead_Code (Statements (Alt)); + Next (Alt); + end loop; + end; + + elsif Nkind (N) = N_Case_Statement_Alternative then + Kill_Dead_Code (Statements (N)); + + -- Deal with dead instances caused by deleting instantiations + + elsif Nkind (N) in N_Generic_Instantiation then + Remove_Dead_Instance (N); + end if; + end if; + end Kill_Dead_Code; + + -- Case where argument is a list of nodes to be killed + + procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is + N : Node_Id; + W : Boolean; + begin + W := Warn; + if Is_Non_Empty_List (L) then + N := First (L); + while Present (N) loop + Kill_Dead_Code (N, W); + W := False; + Next (N); + end loop; + end if; + end Kill_Dead_Code; + + ------------------------ + -- Known_Non_Negative -- + ------------------------ + + function Known_Non_Negative (Opnd : Node_Id) return Boolean is + begin + if Is_OK_Static_Expression (Opnd) + and then Expr_Value (Opnd) >= 0 + then + return True; + + else + declare + Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd)); + + begin + return + Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0; + end; + end if; + end Known_Non_Negative; + + -------------------- + -- Known_Non_Null -- + -------------------- + + function Known_Non_Null (N : Node_Id) return Boolean is + begin + -- Checks for case where N is an entity reference + + if Is_Entity_Name (N) and then Present (Entity (N)) then + declare + E : constant Entity_Id := Entity (N); + Op : Node_Kind; + Val : Node_Id; + + begin + -- First check if we are in decisive conditional + + Get_Current_Value_Condition (N, Op, Val); + + if Known_Null (Val) then + if Op = N_Op_Eq then + return False; + elsif Op = N_Op_Ne then + return True; + end if; + end if; + + -- If OK to do replacement, test Is_Known_Non_Null flag + + if OK_To_Do_Constant_Replacement (E) then + return Is_Known_Non_Null (E); + + -- Otherwise if not safe to do replacement, then say so + + else + return False; + end if; + end; + + -- True if access attribute + + elsif Nkind (N) = N_Attribute_Reference + and then (Attribute_Name (N) = Name_Access + or else + Attribute_Name (N) = Name_Unchecked_Access + or else + Attribute_Name (N) = Name_Unrestricted_Access) + then + return True; + + -- True if allocator + + elsif Nkind (N) = N_Allocator then + return True; + + -- For a conversion, true if expression is known non-null + + elsif Nkind (N) = N_Type_Conversion then + return Known_Non_Null (Expression (N)); + + -- Above are all cases where the value could be determined to be + -- non-null. In all other cases, we don't know, so return False. + + else + return False; + end if; + end Known_Non_Null; + + ---------------- + -- Known_Null -- + ---------------- + + function Known_Null (N : Node_Id) return Boolean is + begin + -- Checks for case where N is an entity reference + + if Is_Entity_Name (N) and then Present (Entity (N)) then + declare + E : constant Entity_Id := Entity (N); + Op : Node_Kind; + Val : Node_Id; + + begin + -- Constant null value is for sure null + + if Ekind (E) = E_Constant + and then Known_Null (Constant_Value (E)) + then + return True; + end if; + + -- First check if we are in decisive conditional + + Get_Current_Value_Condition (N, Op, Val); + + if Known_Null (Val) then + if Op = N_Op_Eq then + return True; + elsif Op = N_Op_Ne then + return False; + end if; + end if; + + -- If OK to do replacement, test Is_Known_Null flag + + if OK_To_Do_Constant_Replacement (E) then + return Is_Known_Null (E); + + -- Otherwise if not safe to do replacement, then say so + + else + return False; + end if; + end; + + -- True if explicit reference to null + + elsif Nkind (N) = N_Null then + return True; + + -- For a conversion, true if expression is known null + + elsif Nkind (N) = N_Type_Conversion then + return Known_Null (Expression (N)); + + -- Above are all cases where the value could be determined to be null. + -- In all other cases, we don't know, so return False. + + else + return False; + end if; + end Known_Null; + + ----------------------------- + -- Make_CW_Equivalent_Type -- + ----------------------------- + + -- Create a record type used as an equivalent of any member of the class + -- which takes its size from exp. + + -- Generate the following code: + + -- type Equiv_T is record + -- _parent : T (List of discriminant constraints taken from Exp); + -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8); + -- end Equiv_T; + -- + -- ??? Note that this type does not guarantee same alignment as all + -- derived types + + function Make_CW_Equivalent_Type + (T : Entity_Id; + E : Node_Id) return Entity_Id + is + Loc : constant Source_Ptr := Sloc (E); + Root_Typ : constant Entity_Id := Root_Type (T); + List_Def : constant List_Id := Empty_List; + Comp_List : constant List_Id := New_List; + Equiv_Type : Entity_Id; + Range_Type : Entity_Id; + Str_Type : Entity_Id; + Constr_Root : Entity_Id; + Sizexpr : Node_Id; + + begin + -- If the root type is already constrained, there are no discriminants + -- in the expression. + + if not Has_Discriminants (Root_Typ) + or else Is_Constrained (Root_Typ) + then + Constr_Root := Root_Typ; + else + Constr_Root := Make_Temporary (Loc, 'R'); + + -- subtype cstr__n is T (List of discr constraints taken from Exp) + + Append_To (List_Def, + Make_Subtype_Declaration (Loc, + Defining_Identifier => Constr_Root, + Subtype_Indication => Make_Subtype_From_Expr (E, Root_Typ))); + end if; + + -- Generate the range subtype declaration + + Range_Type := Make_Temporary (Loc, 'G'); + + if not Is_Interface (Root_Typ) then + + -- subtype rg__xx is + -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit + + Sizexpr := + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)), + Attribute_Name => Name_Size), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Constr_Root, Loc), + Attribute_Name => Name_Object_Size)); + else + -- subtype rg__xx is + -- Storage_Offset range 1 .. Expr'size / Storage_Unit + + Sizexpr := + Make_Attribute_Reference (Loc, + Prefix => + OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)), + Attribute_Name => Name_Size); + end if; + + Set_Paren_Count (Sizexpr, 1); + + Append_To (List_Def, + Make_Subtype_Declaration (Loc, + Defining_Identifier => Range_Type, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (RTE (RE_Storage_Offset), Loc), + Constraint => Make_Range_Constraint (Loc, + Range_Expression => + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => + Make_Op_Divide (Loc, + Left_Opnd => Sizexpr, + Right_Opnd => Make_Integer_Literal (Loc, + Intval => System_Storage_Unit))))))); + + -- subtype str__nn is Storage_Array (rg__x); + + Str_Type := Make_Temporary (Loc, 'S'); + Append_To (List_Def, + Make_Subtype_Declaration (Loc, + Defining_Identifier => Str_Type, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => + New_List (New_Reference_To (Range_Type, Loc)))))); + + -- type Equiv_T is record + -- [ _parent : Tnn; ] + -- E : Str_Type; + -- end Equiv_T; + + Equiv_Type := Make_Temporary (Loc, 'T'); + Set_Ekind (Equiv_Type, E_Record_Type); + Set_Parent_Subtype (Equiv_Type, Constr_Root); + + -- Set Is_Class_Wide_Equivalent_Type very early to trigger the special + -- treatment for this type. In particular, even though _parent's type + -- is a controlled type or contains controlled components, we do not + -- want to set Has_Controlled_Component on it to avoid making it gain + -- an unwanted _controller component. + + Set_Is_Class_Wide_Equivalent_Type (Equiv_Type); + + if not Is_Interface (Root_Typ) then + Append_To (Comp_List, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uParent), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => New_Reference_To (Constr_Root, Loc)))); + end if; + + Append_To (Comp_List, + Make_Component_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'C'), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => New_Reference_To (Str_Type, Loc)))); + + Append_To (List_Def, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Equiv_Type, + Type_Definition => + Make_Record_Definition (Loc, + Component_List => + Make_Component_List (Loc, + Component_Items => Comp_List, + Variant_Part => Empty)))); + + -- Suppress all checks during the analysis of the expanded code + -- to avoid the generation of spurious warnings under ZFP run-time. + + Insert_Actions (E, List_Def, Suppress => All_Checks); + return Equiv_Type; + end Make_CW_Equivalent_Type; + + ------------------------- + -- Make_Invariant_Call -- + ------------------------- + + function Make_Invariant_Call (Expr : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (Expr); + Typ : constant Entity_Id := Etype (Expr); + + begin + pragma Assert + (Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ))); + + if Check_Enabled (Name_Invariant) + or else + Check_Enabled (Name_Assertion) + then + return + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (Invariant_Procedure (Typ), Loc), + Parameter_Associations => New_List (Relocate_Node (Expr))); + + else + return + Make_Null_Statement (Loc); + end if; + end Make_Invariant_Call; + + ------------------------ + -- Make_Literal_Range -- + ------------------------ + + function Make_Literal_Range + (Loc : Source_Ptr; + Literal_Typ : Entity_Id) return Node_Id + is + Lo : constant Node_Id := + New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ)); + Index : constant Entity_Id := Etype (Lo); + + Hi : Node_Id; + Length_Expr : constant Node_Id := + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Integer_Literal (Loc, + Intval => String_Literal_Length (Literal_Typ)), + Right_Opnd => + Make_Integer_Literal (Loc, 1)); + + begin + Set_Analyzed (Lo, False); + + if Is_Integer_Type (Index) then + Hi := + Make_Op_Add (Loc, + Left_Opnd => New_Copy_Tree (Lo), + Right_Opnd => Length_Expr); + else + Hi := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Val, + Prefix => New_Occurrence_Of (Index, Loc), + Expressions => New_List ( + Make_Op_Add (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Pos, + Prefix => New_Occurrence_Of (Index, Loc), + Expressions => New_List (New_Copy_Tree (Lo))), + Right_Opnd => Length_Expr))); + end if; + + return + Make_Range (Loc, + Low_Bound => Lo, + High_Bound => Hi); + end Make_Literal_Range; + + -------------------------- + -- Make_Non_Empty_Check -- + -------------------------- + + function Make_Non_Empty_Check + (Loc : Source_Ptr; + N : Node_Id) return Node_Id + is + begin + return + Make_Op_Ne (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => Duplicate_Subexpr_No_Checks (N, Name_Req => True)), + Right_Opnd => + Make_Integer_Literal (Loc, 0)); + end Make_Non_Empty_Check; + + ------------------------- + -- Make_Predicate_Call -- + ------------------------- + + function Make_Predicate_Call + (Typ : Entity_Id; + Expr : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Expr); + + begin + pragma Assert (Present (Predicate_Function (Typ))); + + return + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Predicate_Function (Typ), Loc), + Parameter_Associations => New_List (Relocate_Node (Expr))); + end Make_Predicate_Call; + + -------------------------- + -- Make_Predicate_Check -- + -------------------------- + + function Make_Predicate_Check + (Typ : Entity_Id; + Expr : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Expr); + + begin + return + Make_Pragma (Loc, + Pragma_Identifier => Make_Identifier (Loc, Name_Check), + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_Predicate)), + Make_Pragma_Argument_Association (Loc, + Expression => Make_Predicate_Call (Typ, Expr)))); + end Make_Predicate_Check; + + ---------------------------- + -- Make_Subtype_From_Expr -- + ---------------------------- + + -- 1. If Expr is an unconstrained array expression, creates + -- Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n)) + + -- 2. If Expr is a unconstrained discriminated type expression, creates + -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n) + + -- 3. If Expr is class-wide, creates an implicit class wide subtype + + function Make_Subtype_From_Expr + (E : Node_Id; + Unc_Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (E); + List_Constr : constant List_Id := New_List; + D : Entity_Id; + + Full_Subtyp : Entity_Id; + Priv_Subtyp : Entity_Id; + Utyp : Entity_Id; + Full_Exp : Node_Id; + + begin + if Is_Private_Type (Unc_Typ) + and then Has_Unknown_Discriminants (Unc_Typ) + then + -- Prepare the subtype completion, Go to base type to + -- find underlying type, because the type may be a generic + -- actual or an explicit subtype. + + Utyp := Underlying_Type (Base_Type (Unc_Typ)); + Full_Subtyp := Make_Temporary (Loc, 'C'); + Full_Exp := + Unchecked_Convert_To (Utyp, Duplicate_Subexpr_No_Checks (E)); + Set_Parent (Full_Exp, Parent (E)); + + Priv_Subtyp := Make_Temporary (Loc, 'P'); + + Insert_Action (E, + Make_Subtype_Declaration (Loc, + Defining_Identifier => Full_Subtyp, + Subtype_Indication => Make_Subtype_From_Expr (Full_Exp, Utyp))); + + -- Define the dummy private subtype + + Set_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ))); + Set_Etype (Priv_Subtyp, Base_Type (Unc_Typ)); + Set_Scope (Priv_Subtyp, Full_Subtyp); + Set_Is_Constrained (Priv_Subtyp); + Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ)); + Set_Is_Itype (Priv_Subtyp); + Set_Associated_Node_For_Itype (Priv_Subtyp, E); + + if Is_Tagged_Type (Priv_Subtyp) then + Set_Class_Wide_Type + (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ)); + Set_Direct_Primitive_Operations (Priv_Subtyp, + Direct_Primitive_Operations (Unc_Typ)); + end if; + + Set_Full_View (Priv_Subtyp, Full_Subtyp); + + return New_Reference_To (Priv_Subtyp, Loc); + + elsif Is_Array_Type (Unc_Typ) then + for J in 1 .. Number_Dimensions (Unc_Typ) loop + Append_To (List_Constr, + Make_Range (Loc, + Low_Bound => + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr_No_Checks (E), + Attribute_Name => Name_First, + Expressions => New_List ( + Make_Integer_Literal (Loc, J))), + + High_Bound => + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr_No_Checks (E), + Attribute_Name => Name_Last, + Expressions => New_List ( + Make_Integer_Literal (Loc, J))))); + end loop; + + elsif Is_Class_Wide_Type (Unc_Typ) then + declare + CW_Subtype : Entity_Id; + EQ_Typ : Entity_Id := Empty; + + begin + -- A class-wide equivalent type is not needed when VM_Target + -- because the VM back-ends handle the class-wide object + -- initialization itself (and doesn't need or want the + -- additional intermediate type to handle the assignment). + + if Expander_Active and then Tagged_Type_Expansion then + + -- If this is the class_wide type of a completion that is + -- a record subtype, set the type of the class_wide type + -- to be the full base type, for use in the expanded code + -- for the equivalent type. Should this be done earlier when + -- the completion is analyzed ??? + + if Is_Private_Type (Etype (Unc_Typ)) + and then + Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype + then + Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ)))); + end if; + + EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E); + end if; + + CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E); + Set_Equivalent_Type (CW_Subtype, EQ_Typ); + Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ)); + + return New_Occurrence_Of (CW_Subtype, Loc); + end; + + -- Indefinite record type with discriminants + + else + D := First_Discriminant (Unc_Typ); + while Present (D) loop + Append_To (List_Constr, + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr_No_Checks (E), + Selector_Name => New_Reference_To (D, Loc))); + + Next_Discriminant (D); + end loop; + end if; + + return + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (Unc_Typ, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => List_Constr)); + end Make_Subtype_From_Expr; + + ----------------------------- + -- May_Generate_Large_Temp -- + ----------------------------- + + -- At the current time, the only types that we return False for (i.e. + -- where we decide we know they cannot generate large temps) are ones + -- where we know the size is 256 bits or less at compile time, and we + -- are still not doing a thorough job on arrays and records ??? + + function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is + begin + if not Size_Known_At_Compile_Time (Typ) then + return False; + + elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then + return False; + + elsif Is_Array_Type (Typ) + and then Present (Packed_Array_Type (Typ)) + then + return May_Generate_Large_Temp (Packed_Array_Type (Typ)); + + -- We could do more here to find other small types ??? + + else + return True; + end if; + end May_Generate_Large_Temp; + + ---------------------------- + -- Needs_Constant_Address -- + ---------------------------- + + function Needs_Constant_Address + (Decl : Node_Id; + Typ : Entity_Id) return Boolean + is + begin + + -- If we have no initialization of any kind, then we don't need to + -- place any restrictions on the address clause, because the object + -- will be elaborated after the address clause is evaluated. This + -- happens if the declaration has no initial expression, or the type + -- has no implicit initialization, or the object is imported. + + -- The same holds for all initialized scalar types and all access + -- types. Packed bit arrays of size up to 64 are represented using a + -- modular type with an initialization (to zero) and can be processed + -- like other initialized scalar types. + + -- If the type is controlled, code to attach the object to a + -- finalization chain is generated at the point of declaration, + -- and therefore the elaboration of the object cannot be delayed: + -- the address expression must be a constant. + + if No (Expression (Decl)) + and then not Needs_Finalization (Typ) + and then + (not Has_Non_Null_Base_Init_Proc (Typ) + or else Is_Imported (Defining_Identifier (Decl))) + then + return False; + + elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ)) + or else Is_Access_Type (Typ) + or else + (Is_Bit_Packed_Array (Typ) + and then Is_Modular_Integer_Type (Packed_Array_Type (Typ))) + then + return False; + + else + + -- Otherwise, we require the address clause to be constant because + -- the call to the initialization procedure (or the attach code) has + -- to happen at the point of the declaration. + + -- Actually the IP call has been moved to the freeze actions + -- anyway, so maybe we can relax this restriction??? + + return True; + end if; + end Needs_Constant_Address; + + ---------------------------- + -- New_Class_Wide_Subtype -- + ---------------------------- + + function New_Class_Wide_Subtype + (CW_Typ : Entity_Id; + N : Node_Id) return Entity_Id + is + Res : constant Entity_Id := Create_Itype (E_Void, N); + Res_Name : constant Name_Id := Chars (Res); + Res_Scope : constant Entity_Id := Scope (Res); + + begin + Copy_Node (CW_Typ, Res); + Set_Comes_From_Source (Res, False); + Set_Sloc (Res, Sloc (N)); + Set_Is_Itype (Res); + Set_Associated_Node_For_Itype (Res, N); + Set_Is_Public (Res, False); -- By default, may be changed below. + Set_Public_Status (Res); + Set_Chars (Res, Res_Name); + Set_Scope (Res, Res_Scope); + Set_Ekind (Res, E_Class_Wide_Subtype); + Set_Next_Entity (Res, Empty); + Set_Etype (Res, Base_Type (CW_Typ)); + Set_Is_Frozen (Res, False); + Set_Freeze_Node (Res, Empty); + return (Res); + end New_Class_Wide_Subtype; + + -------------------------------- + -- Non_Limited_Designated_Type -- + --------------------------------- + + function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id is + Desig : constant Entity_Id := Designated_Type (T); + begin + if Ekind (Desig) = E_Incomplete_Type + and then Present (Non_Limited_View (Desig)) + then + return Non_Limited_View (Desig); + else + return Desig; + end if; + end Non_Limited_Designated_Type; + + ----------------------------------- + -- OK_To_Do_Constant_Replacement -- + ----------------------------------- + + function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean is + ES : constant Entity_Id := Scope (E); + CS : Entity_Id; + + begin + -- Do not replace statically allocated objects, because they may be + -- modified outside the current scope. + + if Is_Statically_Allocated (E) then + return False; + + -- Do not replace aliased or volatile objects, since we don't know what + -- else might change the value. + + elsif Is_Aliased (E) or else Treat_As_Volatile (E) then + return False; + + -- Debug flag -gnatdM disconnects this optimization + + elsif Debug_Flag_MM then + return False; + + -- Otherwise check scopes + + else + CS := Current_Scope; + + loop + -- If we are in right scope, replacement is safe + + if CS = ES then + return True; + + -- Packages do not affect the determination of safety + + elsif Ekind (CS) = E_Package then + exit when CS = Standard_Standard; + CS := Scope (CS); + + -- Blocks do not affect the determination of safety + + elsif Ekind (CS) = E_Block then + CS := Scope (CS); + + -- Loops do not affect the determination of safety. Note that we + -- kill all current values on entry to a loop, so we are just + -- talking about processing within a loop here. + + elsif Ekind (CS) = E_Loop then + CS := Scope (CS); + + -- Otherwise, the reference is dubious, and we cannot be sure that + -- it is safe to do the replacement. + + else + exit; + end if; + end loop; + + return False; + end if; + end OK_To_Do_Constant_Replacement; + + ------------------------------------ + -- Possible_Bit_Aligned_Component -- + ------------------------------------ + + function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is + begin + case Nkind (N) is + + -- Case of indexed component + + when N_Indexed_Component => + declare + P : constant Node_Id := Prefix (N); + Ptyp : constant Entity_Id := Etype (P); + + begin + -- If we know the component size and it is less than 64, then + -- we are definitely OK. The back end always does assignment of + -- misaligned small objects correctly. + + if Known_Static_Component_Size (Ptyp) + and then Component_Size (Ptyp) <= 64 + then + return False; + + -- Otherwise, we need to test the prefix, to see if we are + -- indexing from a possibly unaligned component. + + else + return Possible_Bit_Aligned_Component (P); + end if; + end; + + -- Case of selected component + + when N_Selected_Component => + declare + P : constant Node_Id := Prefix (N); + Comp : constant Entity_Id := Entity (Selector_Name (N)); + + begin + -- If there is no component clause, then we are in the clear + -- since the back end will never misalign a large component + -- unless it is forced to do so. In the clear means we need + -- only the recursive test on the prefix. + + if Component_May_Be_Bit_Aligned (Comp) then + return True; + else + return Possible_Bit_Aligned_Component (P); + end if; + end; + + -- For a slice, test the prefix, if that is possibly misaligned, + -- then for sure the slice is! + + when N_Slice => + return Possible_Bit_Aligned_Component (Prefix (N)); + + -- If we have none of the above, it means that we have fallen off the + -- top testing prefixes recursively, and we now have a stand alone + -- object, where we don't have a problem. + + when others => + return False; + + end case; + end Possible_Bit_Aligned_Component; + + ------------------------- + -- Remove_Side_Effects -- + ------------------------- + + procedure Remove_Side_Effects + (Exp : Node_Id; + Name_Req : Boolean := False; + Variable_Ref : Boolean := False) + is + Loc : constant Source_Ptr := Sloc (Exp); + Exp_Type : constant Entity_Id := Etype (Exp); + Svg_Suppress : constant Suppress_Array := Scope_Suppress; + Def_Id : Entity_Id; + Ref_Type : Entity_Id; + Res : Node_Id; + Ptr_Typ_Decl : Node_Id; + New_Exp : Node_Id; + E : Node_Id; + + function Side_Effect_Free (N : Node_Id) return Boolean; + -- Determines if the tree N represents an expression that is known not + -- to have side effects, and for which no processing is required. + + function Side_Effect_Free (L : List_Id) return Boolean; + -- Determines if all elements of the list L are side effect free + + function Safe_Prefixed_Reference (N : Node_Id) return Boolean; + -- The argument N is a construct where the Prefix is dereferenced if it + -- is an access type and the result is a variable. The call returns True + -- if the construct is side effect free (not considering side effects in + -- other than the prefix which are to be tested by the caller). + + function Within_In_Parameter (N : Node_Id) return Boolean; + -- Determines if N is a subcomponent of a composite in-parameter. If so, + -- N is not side-effect free when the actual is global and modifiable + -- indirectly from within a subprogram, because it may be passed by + -- reference. The front-end must be conservative here and assume that + -- this may happen with any array or record type. On the other hand, we + -- cannot create temporaries for all expressions for which this + -- condition is true, for various reasons that might require clearing up + -- ??? For example, discriminant references that appear out of place, or + -- spurious type errors with class-wide expressions. As a result, we + -- limit the transformation to loop bounds, which is so far the only + -- case that requires it. + + ----------------------------- + -- Safe_Prefixed_Reference -- + ----------------------------- + + function Safe_Prefixed_Reference (N : Node_Id) return Boolean is + begin + -- If prefix is not side effect free, definitely not safe + + if not Side_Effect_Free (Prefix (N)) then + return False; + + -- If the prefix is of an access type that is not access-to-constant, + -- then this construct is a variable reference, which means it is to + -- be considered to have side effects if Variable_Ref is set True + -- Exception is an access to an entity that is a constant or an + -- in-parameter which does not come from source, and is the result + -- of a previous removal of side-effects. + + elsif Is_Access_Type (Etype (Prefix (N))) + and then not Is_Access_Constant (Etype (Prefix (N))) + and then Variable_Ref + then + if not Is_Entity_Name (Prefix (N)) then + return False; + else + return Ekind (Entity (Prefix (N))) = E_Constant + or else Ekind (Entity (Prefix (N))) = E_In_Parameter; + end if; + + -- If the prefix is an explicit dereference then this construct is a + -- variable reference, which means it is to be considered to have + -- side effects if Variable_Ref is True. + + -- We do NOT exclude dereferences of access-to-constant types because + -- we handle them as constant view of variables. + + -- Exception is an access to an entity that is a constant or an + -- in-parameter. + + elsif Nkind (Prefix (N)) = N_Explicit_Dereference + and then Variable_Ref + then + declare + DDT : constant Entity_Id := + Designated_Type (Etype (Prefix (Prefix (N)))); + begin + return Ekind_In (DDT, E_Constant, E_In_Parameter); + end; + + -- The following test is the simplest way of solving a complex + -- problem uncovered by BB08-010: Side effect on loop bound that + -- is a subcomponent of a global variable: + -- If a loop bound is a subcomponent of a global variable, a + -- modification of that variable within the loop may incorrectly + -- affect the execution of the loop. + + elsif not + (Nkind (Parent (Parent (N))) /= N_Loop_Parameter_Specification + or else not Within_In_Parameter (Prefix (N))) + then + return False; + + -- All other cases are side effect free + + else + return True; + end if; + end Safe_Prefixed_Reference; + + ---------------------- + -- Side_Effect_Free -- + ---------------------- + + function Side_Effect_Free (N : Node_Id) return Boolean is + begin + -- Note on checks that could raise Constraint_Error. Strictly, if we + -- take advantage of 11.6, these checks do not count as side effects. + -- However, we would prefer to consider that they are side effects, + -- since the backend CSE does not work very well on expressions which + -- can raise Constraint_Error. On the other hand if we don't consider + -- them to be side effect free, then we get some awkward expansions + -- in -gnato mode, resulting in code insertions at a point where we + -- do not have a clear model for performing the insertions. + + -- Special handling for entity names + + if Is_Entity_Name (N) then + + -- If the entity is a constant, it is definitely side effect + -- free. Note that the test of Is_Variable (N) below might + -- be expected to catch this case, but it does not, because + -- this test goes to the original tree, and we may have + -- already rewritten a variable node with a constant as + -- a result of an earlier Force_Evaluation call. + + if Ekind_In (Entity (N), E_Constant, E_In_Parameter) then + return True; + + -- Functions are not side effect free + + elsif Ekind (Entity (N)) = E_Function then + return False; + + -- Variables are considered to be a side effect if Variable_Ref + -- is set or if we have a volatile reference and Name_Req is off. + -- If Name_Req is True then we can't help returning a name which + -- effectively allows multiple references in any case. + + elsif Is_Variable (N) then + return not Variable_Ref + and then (not Is_Volatile_Reference (N) or else Name_Req); + + -- Any other entity (e.g. a subtype name) is definitely side + -- effect free. + + else + return True; + end if; + + -- A value known at compile time is always side effect free + + elsif Compile_Time_Known_Value (N) then + return True; + + -- A variable renaming is not side-effect free, because the + -- renaming will function like a macro in the front-end in + -- some cases, and an assignment can modify the component + -- designated by N, so we need to create a temporary for it. + + -- The guard testing for Entity being present is needed at least + -- in the case of rewritten predicate expressions, and may be + -- appropriate elsewhere. Obviously we can't go testing the entity + -- field if it does not exist, so it's reasonable to say that this + -- is not the renaming case if it does not exist. + + elsif Is_Entity_Name (Original_Node (N)) + and then Present (Entity (Original_Node (N))) + and then Is_Renaming_Of_Object (Entity (Original_Node (N))) + and then Ekind (Entity (Original_Node (N))) /= E_Constant + then + return False; + + -- Remove_Side_Effects generates an object renaming declaration to + -- capture the expression of a class-wide expression. In VM targets + -- the frontend performs no expansion for dispatching calls to + -- class-wide types since they are handled by the VM. Hence, we must + -- locate here if this node corresponds to a previous invocation of + -- Remove_Side_Effects to avoid a never ending loop in the frontend. + + elsif VM_Target /= No_VM + and then not Comes_From_Source (N) + and then Nkind (Parent (N)) = N_Object_Renaming_Declaration + and then Is_Class_Wide_Type (Etype (N)) + then + return True; + end if; + + -- For other than entity names and compile time known values, + -- check the node kind for special processing. + + case Nkind (N) is + + -- An attribute reference is side effect free if its expressions + -- are side effect free and its prefix is side effect free or + -- is an entity reference. + + -- Is this right? what about x'first where x is a variable??? + + when N_Attribute_Reference => + return Side_Effect_Free (Expressions (N)) + and then Attribute_Name (N) /= Name_Input + and then (Is_Entity_Name (Prefix (N)) + or else Side_Effect_Free (Prefix (N))); + + -- A binary operator is side effect free if and both operands + -- are side effect free. For this purpose binary operators + -- include membership tests and short circuit forms + + when N_Binary_Op | N_Membership_Test | N_Short_Circuit => + return Side_Effect_Free (Left_Opnd (N)) + and then + Side_Effect_Free (Right_Opnd (N)); + + -- An explicit dereference is side effect free only if it is + -- a side effect free prefixed reference. + + when N_Explicit_Dereference => + return Safe_Prefixed_Reference (N); + + -- A call to _rep_to_pos is side effect free, since we generate + -- this pure function call ourselves. Moreover it is critically + -- important to make this exception, since otherwise we can + -- have discriminants in array components which don't look + -- side effect free in the case of an array whose index type + -- is an enumeration type with an enumeration rep clause. + + -- All other function calls are not side effect free + + when N_Function_Call => + return Nkind (Name (N)) = N_Identifier + and then Is_TSS (Name (N), TSS_Rep_To_Pos) + and then + Side_Effect_Free (First (Parameter_Associations (N))); + + -- An indexed component is side effect free if it is a side + -- effect free prefixed reference and all the indexing + -- expressions are side effect free. + + when N_Indexed_Component => + return Side_Effect_Free (Expressions (N)) + and then Safe_Prefixed_Reference (N); + + -- A type qualification is side effect free if the expression + -- is side effect free. + + when N_Qualified_Expression => + return Side_Effect_Free (Expression (N)); + + -- A selected component is side effect free only if it is a + -- side effect free prefixed reference. If it designates a + -- component with a rep. clause it must be treated has having + -- a potential side effect, because it may be modified through + -- a renaming, and a subsequent use of the renaming as a macro + -- will yield the wrong value. This complex interaction between + -- renaming and removing side effects is a reminder that the + -- latter has become a headache to maintain, and that it should + -- be removed in favor of the gcc mechanism to capture values ??? + + when N_Selected_Component => + if Nkind (Parent (N)) = N_Explicit_Dereference + and then Has_Non_Standard_Rep (Designated_Type (Etype (N))) + then + return False; + else + return Safe_Prefixed_Reference (N); + end if; + + -- A range is side effect free if the bounds are side effect free + + when N_Range => + return Side_Effect_Free (Low_Bound (N)) + and then Side_Effect_Free (High_Bound (N)); + + -- A slice is side effect free if it is a side effect free + -- prefixed reference and the bounds are side effect free. + + when N_Slice => + return Side_Effect_Free (Discrete_Range (N)) + and then Safe_Prefixed_Reference (N); + + -- A type conversion is side effect free if the expression to be + -- converted is side effect free. + + when N_Type_Conversion => + return Side_Effect_Free (Expression (N)); + + -- A unary operator is side effect free if the operand + -- is side effect free. + + when N_Unary_Op => + return Side_Effect_Free (Right_Opnd (N)); + + -- An unchecked type conversion is side effect free only if it + -- is safe and its argument is side effect free. + + when N_Unchecked_Type_Conversion => + return Safe_Unchecked_Type_Conversion (N) + and then Side_Effect_Free (Expression (N)); + + -- An unchecked expression is side effect free if its expression + -- is side effect free. + + when N_Unchecked_Expression => + return Side_Effect_Free (Expression (N)); + + -- A literal is side effect free + + when N_Character_Literal | + N_Integer_Literal | + N_Real_Literal | + N_String_Literal => + return True; + + -- We consider that anything else has side effects. This is a bit + -- crude, but we are pretty close for most common cases, and we + -- are certainly correct (i.e. we never return True when the + -- answer should be False). + + when others => + return False; + end case; + end Side_Effect_Free; + + -- A list is side effect free if all elements of the list are + -- side effect free. + + function Side_Effect_Free (L : List_Id) return Boolean is + N : Node_Id; + + begin + if L = No_List or else L = Error_List then + return True; + + else + N := First (L); + while Present (N) loop + if not Side_Effect_Free (N) then + return False; + else + Next (N); + end if; + end loop; + + return True; + end if; + end Side_Effect_Free; + + ------------------------- + -- Within_In_Parameter -- + ------------------------- + + function Within_In_Parameter (N : Node_Id) return Boolean is + begin + if not Comes_From_Source (N) then + return False; + + elsif Is_Entity_Name (N) then + return Ekind (Entity (N)) = E_In_Parameter; + + elsif Nkind (N) = N_Indexed_Component + or else Nkind (N) = N_Selected_Component + then + return Within_In_Parameter (Prefix (N)); + else + + return False; + end if; + end Within_In_Parameter; + + -- Start of processing for Remove_Side_Effects + + begin + -- If we are side effect free already or expansion is disabled, + -- there is nothing to do. + + if Side_Effect_Free (Exp) or else not Expander_Active then + return; + end if; + + -- All this must not have any checks + + Scope_Suppress := (others => True); + + -- If it is a scalar type and we need to capture the value, just make + -- a copy. Likewise for a function call, an attribute reference, an + -- allocator, or an operator. And if we have a volatile reference and + -- Name_Req is not set (see comments above for Side_Effect_Free). + + if Is_Elementary_Type (Exp_Type) + and then (Variable_Ref + or else Nkind (Exp) = N_Function_Call + or else Nkind (Exp) = N_Attribute_Reference + or else Nkind (Exp) = N_Allocator + or else Nkind (Exp) in N_Op + or else (not Name_Req and then Is_Volatile_Reference (Exp))) + then + Def_Id := Make_Temporary (Loc, 'R', Exp); + Set_Etype (Def_Id, Exp_Type); + Res := New_Reference_To (Def_Id, Loc); + + -- If the expression is a packed reference, it must be reanalyzed + -- and expanded, depending on context. This is the case for actuals + -- where a constraint check may capture the actual before expansion + -- of the call is complete. + + if Nkind (Exp) = N_Indexed_Component + and then Is_Packed (Etype (Prefix (Exp))) + then + Set_Analyzed (Exp, False); + Set_Analyzed (Prefix (Exp), False); + end if; + + E := + Make_Object_Declaration (Loc, + Defining_Identifier => Def_Id, + Object_Definition => New_Reference_To (Exp_Type, Loc), + Constant_Present => True, + Expression => Relocate_Node (Exp)); + + Set_Assignment_OK (E); + Insert_Action (Exp, E); + + -- If the expression has the form v.all then we can just capture + -- the pointer, and then do an explicit dereference on the result. + + elsif Nkind (Exp) = N_Explicit_Dereference then + Def_Id := Make_Temporary (Loc, 'R', Exp); + Res := + Make_Explicit_Dereference (Loc, New_Reference_To (Def_Id, Loc)); + + Insert_Action (Exp, + Make_Object_Declaration (Loc, + Defining_Identifier => Def_Id, + Object_Definition => + New_Reference_To (Etype (Prefix (Exp)), Loc), + Constant_Present => True, + Expression => Relocate_Node (Prefix (Exp)))); + + -- Similar processing for an unchecked conversion of an expression + -- of the form v.all, where we want the same kind of treatment. + + elsif Nkind (Exp) = N_Unchecked_Type_Conversion + and then Nkind (Expression (Exp)) = N_Explicit_Dereference + then + Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref); + Scope_Suppress := Svg_Suppress; + return; + + -- If this is a type conversion, leave the type conversion and remove + -- the side effects in the expression. This is important in several + -- circumstances: for change of representations, and also when this is + -- a view conversion to a smaller object, where gigi can end up creating + -- its own temporary of the wrong size. + + elsif Nkind (Exp) = N_Type_Conversion then + Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref); + Scope_Suppress := Svg_Suppress; + return; + + -- If this is an unchecked conversion that Gigi can't handle, make + -- a copy or a use a renaming to capture the value. + + elsif Nkind (Exp) = N_Unchecked_Type_Conversion + and then not Safe_Unchecked_Type_Conversion (Exp) + then + if CW_Or_Has_Controlled_Part (Exp_Type) then + + -- Use a renaming to capture the expression, rather than create + -- a controlled temporary. + + Def_Id := Make_Temporary (Loc, 'R', Exp); + Res := New_Reference_To (Def_Id, Loc); + + Insert_Action (Exp, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Def_Id, + Subtype_Mark => New_Reference_To (Exp_Type, Loc), + Name => Relocate_Node (Exp))); + + else + Def_Id := Make_Temporary (Loc, 'R', Exp); + Set_Etype (Def_Id, Exp_Type); + Res := New_Reference_To (Def_Id, Loc); + + E := + Make_Object_Declaration (Loc, + Defining_Identifier => Def_Id, + Object_Definition => New_Reference_To (Exp_Type, Loc), + Constant_Present => not Is_Variable (Exp), + Expression => Relocate_Node (Exp)); + + Set_Assignment_OK (E); + Insert_Action (Exp, E); + end if; + + -- For expressions that denote objects, we can use a renaming scheme. + -- This is needed for correctness in the case of a volatile object + -- of a non-volatile type because the Make_Reference call of the + -- "default" approach would generate an illegal access value (an access + -- value cannot designate such an object - see Analyze_Reference). + -- We skip using this scheme if we have an object of a volatile type + -- and we do not have Name_Req set true (see comments above for + -- Side_Effect_Free). + + elsif Is_Object_Reference (Exp) + and then Nkind (Exp) /= N_Function_Call + and then (Name_Req or else not Treat_As_Volatile (Exp_Type)) + then + Def_Id := Make_Temporary (Loc, 'R', Exp); + + if Nkind (Exp) = N_Selected_Component + and then Nkind (Prefix (Exp)) = N_Function_Call + and then Is_Array_Type (Exp_Type) + then + -- Avoid generating a variable-sized temporary, by generating + -- the renaming declaration just for the function call. The + -- transformation could be refined to apply only when the array + -- component is constrained by a discriminant??? + + Res := + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Def_Id, Loc), + Selector_Name => Selector_Name (Exp)); + + Insert_Action (Exp, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Def_Id, + Subtype_Mark => + New_Reference_To (Base_Type (Etype (Prefix (Exp))), Loc), + Name => Relocate_Node (Prefix (Exp)))); + + else + Res := New_Reference_To (Def_Id, Loc); + + Insert_Action (Exp, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Def_Id, + Subtype_Mark => New_Reference_To (Exp_Type, Loc), + Name => Relocate_Node (Exp))); + end if; + + -- If this is a packed reference, or a selected component with a + -- non-standard representation, a reference to the temporary will + -- be replaced by a copy of the original expression (see + -- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be + -- elaborated by gigi, and is of course not to be replaced in-line + -- by the expression it renames, which would defeat the purpose of + -- removing the side-effect. + + if (Nkind (Exp) = N_Selected_Component + or else Nkind (Exp) = N_Indexed_Component) + and then Has_Non_Standard_Rep (Etype (Prefix (Exp))) + then + null; + else + Set_Is_Renaming_Of_Object (Def_Id, False); + end if; + + -- Otherwise we generate a reference to the value + + else + -- Special processing for function calls that return a limited type. + -- We need to build a declaration that will enable build-in-place + -- expansion of the call. This is not done if the context is already + -- an object declaration, to prevent infinite recursion. + + -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have + -- to accommodate functions returning limited objects by reference. + + if Nkind (Exp) = N_Function_Call + and then Is_Immutably_Limited_Type (Etype (Exp)) + and then Nkind (Parent (Exp)) /= N_Object_Declaration + and then Ada_Version >= Ada_2005 + then + declare + Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp); + Decl : Node_Id; + + begin + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Obj, + Object_Definition => New_Occurrence_Of (Exp_Type, Loc), + Expression => Relocate_Node (Exp)); + + Insert_Action (Exp, Decl); + Set_Etype (Obj, Exp_Type); + Rewrite (Exp, New_Occurrence_Of (Obj, Loc)); + return; + end; + end if; + + Ref_Type := Make_Temporary (Loc, 'A'); + + Ptr_Typ_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ref_Type, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Reference_To (Exp_Type, Loc))); + + E := Exp; + Insert_Action (Exp, Ptr_Typ_Decl); + + Def_Id := Make_Temporary (Loc, 'R', Exp); + Set_Etype (Def_Id, Exp_Type); + + Res := + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Def_Id, Loc)); + + if Nkind (E) = N_Explicit_Dereference then + New_Exp := Relocate_Node (Prefix (E)); + else + E := Relocate_Node (E); + New_Exp := Make_Reference (Loc, E); + end if; + + if Is_Delayed_Aggregate (E) then + + -- The expansion of nested aggregates is delayed until the + -- enclosing aggregate is expanded. As aggregates are often + -- qualified, the predicate applies to qualified expressions + -- as well, indicating that the enclosing aggregate has not + -- been expanded yet. At this point the aggregate is part of + -- a stand-alone declaration, and must be fully expanded. + + if Nkind (E) = N_Qualified_Expression then + Set_Expansion_Delayed (Expression (E), False); + Set_Analyzed (Expression (E), False); + else + Set_Expansion_Delayed (E, False); + end if; + + Set_Analyzed (E, False); + end if; + + Insert_Action (Exp, + Make_Object_Declaration (Loc, + Defining_Identifier => Def_Id, + Object_Definition => New_Reference_To (Ref_Type, Loc), + Constant_Present => True, + Expression => New_Exp)); + end if; + + -- Preserve the Assignment_OK flag in all copies, since at least + -- one copy may be used in a context where this flag must be set + -- (otherwise why would the flag be set in the first place). + + Set_Assignment_OK (Res, Assignment_OK (Exp)); + + -- Finally rewrite the original expression and we are done + + Rewrite (Exp, Res); + Analyze_And_Resolve (Exp, Exp_Type); + Scope_Suppress := Svg_Suppress; + end Remove_Side_Effects; + + --------------------------- + -- Represented_As_Scalar -- + --------------------------- + + function Represented_As_Scalar (T : Entity_Id) return Boolean is + UT : constant Entity_Id := Underlying_Type (T); + begin + return Is_Scalar_Type (UT) + or else (Is_Bit_Packed_Array (UT) + and then Is_Scalar_Type (Packed_Array_Type (UT))); + end Represented_As_Scalar; + + ------------------------------------ + -- Safe_Unchecked_Type_Conversion -- + ------------------------------------ + + -- Note: this function knows quite a bit about the exact requirements + -- of Gigi with respect to unchecked type conversions, and its code + -- must be coordinated with any changes in Gigi in this area. + + -- The above requirements should be documented in Sinfo ??? + + function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is + Otyp : Entity_Id; + Ityp : Entity_Id; + Oalign : Uint; + Ialign : Uint; + Pexp : constant Node_Id := Parent (Exp); + + begin + -- If the expression is the RHS of an assignment or object declaration + -- we are always OK because there will always be a target. + + -- Object renaming declarations, (generated for view conversions of + -- actuals in inlined calls), like object declarations, provide an + -- explicit type, and are safe as well. + + if (Nkind (Pexp) = N_Assignment_Statement + and then Expression (Pexp) = Exp) + or else Nkind (Pexp) = N_Object_Declaration + or else Nkind (Pexp) = N_Object_Renaming_Declaration + then + return True; + + -- If the expression is the prefix of an N_Selected_Component + -- we should also be OK because GCC knows to look inside the + -- conversion except if the type is discriminated. We assume + -- that we are OK anyway if the type is not set yet or if it is + -- controlled since we can't afford to introduce a temporary in + -- this case. + + elsif Nkind (Pexp) = N_Selected_Component + and then Prefix (Pexp) = Exp + then + if No (Etype (Pexp)) then + return True; + else + return + not Has_Discriminants (Etype (Pexp)) + or else Is_Constrained (Etype (Pexp)); + end if; + end if; + + -- Set the output type, this comes from Etype if it is set, otherwise + -- we take it from the subtype mark, which we assume was already + -- fully analyzed. + + if Present (Etype (Exp)) then + Otyp := Etype (Exp); + else + Otyp := Entity (Subtype_Mark (Exp)); + end if; + + -- The input type always comes from the expression, and we assume + -- this is indeed always analyzed, so we can simply get the Etype. + + Ityp := Etype (Expression (Exp)); + + -- Initialize alignments to unknown so far + + Oalign := No_Uint; + Ialign := No_Uint; + + -- Replace a concurrent type by its corresponding record type + -- and each type by its underlying type and do the tests on those. + -- The original type may be a private type whose completion is a + -- concurrent type, so find the underlying type first. + + if Present (Underlying_Type (Otyp)) then + Otyp := Underlying_Type (Otyp); + end if; + + if Present (Underlying_Type (Ityp)) then + Ityp := Underlying_Type (Ityp); + end if; + + if Is_Concurrent_Type (Otyp) then + Otyp := Corresponding_Record_Type (Otyp); + end if; + + if Is_Concurrent_Type (Ityp) then + Ityp := Corresponding_Record_Type (Ityp); + end if; + + -- If the base types are the same, we know there is no problem since + -- this conversion will be a noop. + + if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then + return True; + + -- Same if this is an upwards conversion of an untagged type, and there + -- are no constraints involved (could be more general???) + + elsif Etype (Ityp) = Otyp + and then not Is_Tagged_Type (Ityp) + and then not Has_Discriminants (Ityp) + and then No (First_Rep_Item (Base_Type (Ityp))) + then + return True; + + -- If the expression has an access type (object or subprogram) we + -- assume that the conversion is safe, because the size of the target + -- is safe, even if it is a record (which might be treated as having + -- unknown size at this point). + + elsif Is_Access_Type (Ityp) then + return True; + + -- If the size of output type is known at compile time, there is + -- never a problem. Note that unconstrained records are considered + -- to be of known size, but we can't consider them that way here, + -- because we are talking about the actual size of the object. + + -- We also make sure that in addition to the size being known, we do + -- not have a case which might generate an embarrassingly large temp + -- in stack checking mode. + + elsif Size_Known_At_Compile_Time (Otyp) + and then + (not Stack_Checking_Enabled + or else not May_Generate_Large_Temp (Otyp)) + and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp)) + then + return True; + + -- If either type is tagged, then we know the alignment is OK so + -- Gigi will be able to use pointer punning. + + elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then + return True; + + -- If either type is a limited record type, we cannot do a copy, so + -- say safe since there's nothing else we can do. + + elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then + return True; + + -- Conversions to and from packed array types are always ignored and + -- hence are safe. + + elsif Is_Packed_Array_Type (Otyp) + or else Is_Packed_Array_Type (Ityp) + then + return True; + end if; + + -- The only other cases known to be safe is if the input type's + -- alignment is known to be at least the maximum alignment for the + -- target or if both alignments are known and the output type's + -- alignment is no stricter than the input's. We can use the alignment + -- of the component type of an array if a type is an unpacked + -- array type. + + if Present (Alignment_Clause (Otyp)) then + Oalign := Expr_Value (Expression (Alignment_Clause (Otyp))); + + elsif Is_Array_Type (Otyp) + and then Present (Alignment_Clause (Component_Type (Otyp))) + then + Oalign := Expr_Value (Expression (Alignment_Clause + (Component_Type (Otyp)))); + end if; + + if Present (Alignment_Clause (Ityp)) then + Ialign := Expr_Value (Expression (Alignment_Clause (Ityp))); + + elsif Is_Array_Type (Ityp) + and then Present (Alignment_Clause (Component_Type (Ityp))) + then + Ialign := Expr_Value (Expression (Alignment_Clause + (Component_Type (Ityp)))); + end if; + + if Ialign /= No_Uint and then Ialign > Maximum_Alignment then + return True; + + elsif Ialign /= No_Uint and then Oalign /= No_Uint + and then Ialign <= Oalign + then + return True; + + -- Otherwise, Gigi cannot handle this and we must make a temporary + + else + return False; + end if; + end Safe_Unchecked_Type_Conversion; + + --------------------------------- + -- Set_Current_Value_Condition -- + --------------------------------- + + -- Note: the implementation of this procedure is very closely tied to the + -- implementation of Get_Current_Value_Condition. Here we set required + -- Current_Value fields, and in Get_Current_Value_Condition, we interpret + -- them, so they must have a consistent view. + + procedure Set_Current_Value_Condition (Cnode : Node_Id) is + + procedure Set_Entity_Current_Value (N : Node_Id); + -- If N is an entity reference, where the entity is of an appropriate + -- kind, then set the current value of this entity to Cnode, unless + -- there is already a definite value set there. + + procedure Set_Expression_Current_Value (N : Node_Id); + -- If N is of an appropriate form, sets an appropriate entry in current + -- value fields of relevant entities. Multiple entities can be affected + -- in the case of an AND or AND THEN. + + ------------------------------ + -- Set_Entity_Current_Value -- + ------------------------------ + + procedure Set_Entity_Current_Value (N : Node_Id) is + begin + if Is_Entity_Name (N) then + declare + Ent : constant Entity_Id := Entity (N); + + begin + -- Don't capture if not safe to do so + + if not Safe_To_Capture_Value (N, Ent, Cond => True) then + return; + end if; + + -- Here we have a case where the Current_Value field may + -- need to be set. We set it if it is not already set to a + -- compile time expression value. + + -- Note that this represents a decision that one condition + -- blots out another previous one. That's certainly right + -- if they occur at the same level. If the second one is + -- nested, then the decision is neither right nor wrong (it + -- would be equally OK to leave the outer one in place, or + -- take the new inner one. Really we should record both, but + -- our data structures are not that elaborate. + + if Nkind (Current_Value (Ent)) not in N_Subexpr then + Set_Current_Value (Ent, Cnode); + end if; + end; + end if; + end Set_Entity_Current_Value; + + ---------------------------------- + -- Set_Expression_Current_Value -- + ---------------------------------- + + procedure Set_Expression_Current_Value (N : Node_Id) is + Cond : Node_Id; + + begin + Cond := N; + + -- Loop to deal with (ignore for now) any NOT operators present. The + -- presence of NOT operators will be handled properly when we call + -- Get_Current_Value_Condition. + + while Nkind (Cond) = N_Op_Not loop + Cond := Right_Opnd (Cond); + end loop; + + -- For an AND or AND THEN, recursively process operands + + if Nkind (Cond) = N_Op_And or else Nkind (Cond) = N_And_Then then + Set_Expression_Current_Value (Left_Opnd (Cond)); + Set_Expression_Current_Value (Right_Opnd (Cond)); + return; + end if; + + -- Check possible relational operator + + if Nkind (Cond) in N_Op_Compare then + if Compile_Time_Known_Value (Right_Opnd (Cond)) then + Set_Entity_Current_Value (Left_Opnd (Cond)); + elsif Compile_Time_Known_Value (Left_Opnd (Cond)) then + Set_Entity_Current_Value (Right_Opnd (Cond)); + end if; + + -- Check possible boolean variable reference + + else + Set_Entity_Current_Value (Cond); + end if; + end Set_Expression_Current_Value; + + -- Start of processing for Set_Current_Value_Condition + + begin + Set_Expression_Current_Value (Condition (Cnode)); + end Set_Current_Value_Condition; + + -------------------------- + -- Set_Elaboration_Flag -- + -------------------------- + + procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ent : constant Entity_Id := Elaboration_Entity (Spec_Id); + Asn : Node_Id; + + begin + if Present (Ent) then + + -- Nothing to do if at the compilation unit level, because in this + -- case the flag is set by the binder generated elaboration routine. + + if Nkind (Parent (N)) = N_Compilation_Unit then + null; + + -- Here we do need to generate an assignment statement + + else + Check_Restriction (No_Elaboration_Code, N); + Asn := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Ent, Loc), + Expression => New_Occurrence_Of (Standard_True, Loc)); + + if Nkind (Parent (N)) = N_Subunit then + Insert_After (Corresponding_Stub (Parent (N)), Asn); + else + Insert_After (N, Asn); + end if; + + Analyze (Asn); + + -- Kill current value indication. This is necessary because the + -- tests of this flag are inserted out of sequence and must not + -- pick up bogus indications of the wrong constant value. + + Set_Current_Value (Ent, Empty); + end if; + end if; + end Set_Elaboration_Flag; + + ---------------------------- + -- Set_Renamed_Subprogram -- + ---------------------------- + + procedure Set_Renamed_Subprogram (N : Node_Id; E : Entity_Id) is + begin + -- If input node is an identifier, we can just reset it + + if Nkind (N) = N_Identifier then + Set_Chars (N, Chars (E)); + Set_Entity (N, E); + + -- Otherwise we have to do a rewrite, preserving Comes_From_Source + + else + declare + CS : constant Boolean := Comes_From_Source (N); + begin + Rewrite (N, Make_Identifier (Sloc (N), Chars (E))); + Set_Entity (N, E); + Set_Comes_From_Source (N, CS); + Set_Analyzed (N, True); + end; + end if; + end Set_Renamed_Subprogram; + + ---------------------------------- + -- Silly_Boolean_Array_Not_Test -- + ---------------------------------- + + -- This procedure implements an odd and silly test. We explicitly check + -- for the case where the 'First of the component type is equal to the + -- 'Last of this component type, and if this is the case, we make sure + -- that constraint error is raised. The reason is that the NOT is bound + -- to cause CE in this case, and we will not otherwise catch it. + + -- No such check is required for AND and OR, since for both these cases + -- False op False = False, and True op True = True. For the XOR case, + -- see Silly_Boolean_Array_Xor_Test. + + -- Believe it or not, this was reported as a bug. Note that nearly + -- always, the test will evaluate statically to False, so the code will + -- be statically removed, and no extra overhead caused. + + procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + CT : constant Entity_Id := Component_Type (T); + + begin + -- The check we install is + + -- constraint_error when + -- component_type'first = component_type'last + -- and then array_type'Length /= 0) + + -- We need the last guard because we don't want to raise CE for empty + -- arrays since no out of range values result. (Empty arrays with a + -- component type of True .. True -- very useful -- even the ACATS + -- does not test that marginal case!) + + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (CT, Loc), + Attribute_Name => Name_First), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (CT, Loc), + Attribute_Name => Name_Last)), + + Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))), + Reason => CE_Range_Check_Failed)); + end Silly_Boolean_Array_Not_Test; + + ---------------------------------- + -- Silly_Boolean_Array_Xor_Test -- + ---------------------------------- + + -- This procedure implements an odd and silly test. We explicitly check + -- for the XOR case where the component type is True .. True, since this + -- will raise constraint error. A special check is required since CE + -- will not be generated otherwise (cf Expand_Packed_Not). + + -- No such check is required for AND and OR, since for both these cases + -- False op False = False, and True op True = True, and no check is + -- required for the case of False .. False, since False xor False = False. + -- See also Silly_Boolean_Array_Not_Test + + procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + CT : constant Entity_Id := Component_Type (T); + + begin + -- The check we install is + + -- constraint_error when + -- Boolean (component_type'First) + -- and then Boolean (component_type'Last) + -- and then array_type'Length /= 0) + + -- We need the last guard because we don't want to raise CE for empty + -- arrays since no out of range values result (Empty arrays with a + -- component type of True .. True -- very useful -- even the ACATS + -- does not test that marginal case!). + + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_And_Then (Loc, + Left_Opnd => + Make_And_Then (Loc, + Left_Opnd => + Convert_To (Standard_Boolean, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (CT, Loc), + Attribute_Name => Name_First)), + + Right_Opnd => + Convert_To (Standard_Boolean, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (CT, Loc), + Attribute_Name => Name_Last))), + + Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))), + Reason => CE_Range_Check_Failed)); + end Silly_Boolean_Array_Xor_Test; + + -------------------------- + -- Target_Has_Fixed_Ops -- + -------------------------- + + Integer_Sized_Small : Ureal; + -- Set to 2.0 ** -(Integer'Size - 1) the first time that this + -- function is called (we don't want to compute it more than once!) + + Long_Integer_Sized_Small : Ureal; + -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this + -- function is called (we don't want to compute it more than once) + + First_Time_For_THFO : Boolean := True; + -- Set to False after first call (if Fractional_Fixed_Ops_On_Target) + + function Target_Has_Fixed_Ops + (Left_Typ : Entity_Id; + Right_Typ : Entity_Id; + Result_Typ : Entity_Id) return Boolean + is + function Is_Fractional_Type (Typ : Entity_Id) return Boolean; + -- Return True if the given type is a fixed-point type with a small + -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have + -- an absolute value less than 1.0. This is currently limited + -- to fixed-point types that map to Integer or Long_Integer. + + ------------------------ + -- Is_Fractional_Type -- + ------------------------ + + function Is_Fractional_Type (Typ : Entity_Id) return Boolean is + begin + if Esize (Typ) = Standard_Integer_Size then + return Small_Value (Typ) = Integer_Sized_Small; + + elsif Esize (Typ) = Standard_Long_Integer_Size then + return Small_Value (Typ) = Long_Integer_Sized_Small; + + else + return False; + end if; + end Is_Fractional_Type; + + -- Start of processing for Target_Has_Fixed_Ops + + begin + -- Return False if Fractional_Fixed_Ops_On_Target is false + + if not Fractional_Fixed_Ops_On_Target then + return False; + end if; + + -- Here the target has Fractional_Fixed_Ops, if first time, compute + -- standard constants used by Is_Fractional_Type. + + if First_Time_For_THFO then + First_Time_For_THFO := False; + + Integer_Sized_Small := + UR_From_Components + (Num => Uint_1, + Den => UI_From_Int (Standard_Integer_Size - 1), + Rbase => 2); + + Long_Integer_Sized_Small := + UR_From_Components + (Num => Uint_1, + Den => UI_From_Int (Standard_Long_Integer_Size - 1), + Rbase => 2); + end if; + + -- Return True if target supports fixed-by-fixed multiply/divide + -- for fractional fixed-point types (see Is_Fractional_Type) and + -- the operand and result types are equivalent fractional types. + + return Is_Fractional_Type (Base_Type (Left_Typ)) + and then Is_Fractional_Type (Base_Type (Right_Typ)) + and then Is_Fractional_Type (Base_Type (Result_Typ)) + and then Esize (Left_Typ) = Esize (Right_Typ) + and then Esize (Left_Typ) = Esize (Result_Typ); + end Target_Has_Fixed_Ops; + + ------------------------------------------ + -- Type_May_Have_Bit_Aligned_Components -- + ------------------------------------------ + + function Type_May_Have_Bit_Aligned_Components + (Typ : Entity_Id) return Boolean + is + begin + -- Array type, check component type + + if Is_Array_Type (Typ) then + return + Type_May_Have_Bit_Aligned_Components (Component_Type (Typ)); + + -- Record type, check components + + elsif Is_Record_Type (Typ) then + declare + E : Entity_Id; + + begin + E := First_Component_Or_Discriminant (Typ); + while Present (E) loop + if Component_May_Be_Bit_Aligned (E) + or else Type_May_Have_Bit_Aligned_Components (Etype (E)) + then + return True; + end if; + + Next_Component_Or_Discriminant (E); + end loop; + + return False; + end; + + -- Type other than array or record is always OK + + else + return False; + end if; + end Type_May_Have_Bit_Aligned_Components; + + ---------------------------- + -- Wrap_Cleanup_Procedure -- + ---------------------------- + + procedure Wrap_Cleanup_Procedure (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Stseq : constant Node_Id := Handled_Statement_Sequence (N); + Stmts : constant List_Id := Statements (Stseq); + + begin + if Abort_Allowed then + Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); + Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer)); + end if; + end Wrap_Cleanup_Procedure; + +end Exp_Util; diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads new file mode 100644 index 000000000..4dee22950 --- /dev/null +++ b/gcc/ada/exp_util.ads @@ -0,0 +1,727 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ U T I L -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Package containing utility procedures used throughout the expander + +with Exp_Tss; use Exp_Tss; +with Namet; use Namet; +with Rtsfind; use Rtsfind; +with Sinfo; use Sinfo; +with Types; use Types; + +package Exp_Util is + + ----------------------------------------------- + -- Handling of Actions Associated with Nodes -- + ----------------------------------------------- + + -- The evaluation of certain expression nodes involves the elaboration + -- of associated types and other declarations, and the execution of + -- statement sequences. Expansion routines generating such actions must + -- find an appropriate place in the tree to hang the actions so that + -- they will be evaluated at the appropriate point. + + -- Some cases are simple: + + -- For an expression occurring in a simple statement that is in a list + -- of statements, the actions are simply inserted into the list before + -- the associated statement. + + -- For an expression occurring in a declaration (declarations always + -- appear in lists), the actions are similarly inserted into the list + -- just before the associated declaration. + + -- The following special cases arise: + + -- For actions associated with the right operand of a short circuit + -- form, the actions are first stored in the short circuit form node + -- in the Actions field. The expansion of these forms subsequently + -- expands the short circuit forms into if statements which can then + -- be moved as described above. + + -- For actions appearing in the Condition expression of a while loop, + -- or an elsif clause, the actions are similarly temporarily stored in + -- in the node (N_Elsif_Part or N_Iteration_Scheme) associated with + -- the expression using the Condition_Actions field. Subsequently, the + -- expansion of these nodes rewrites the control structures involved to + -- reposition the actions in normal statement sequence. + + -- For actions appearing in the then or else expression of a conditional + -- expression, these actions are similarly placed in the node, using the + -- Then_Actions or Else_Actions field as appropriate. Once again the + -- expansion of the N_Conditional_Expression node rewrites the node so + -- that the actions can be normally positioned. + + -- Basically what we do is to climb up to the tree looking for the + -- proper insertion point, as described by one of the above cases, + -- and then insert the appropriate action or actions. + + -- Note if more than one insert call is made specifying the same + -- Assoc_Node, then the actions are elaborated in the order of the + -- calls, and this guarantee is preserved for the special cases above. + + procedure Insert_Action + (Assoc_Node : Node_Id; + Ins_Action : Node_Id); + -- Insert the action Ins_Action at the appropriate point as described + -- above. The action is analyzed using the default checks after it is + -- inserted. Assoc_Node is the node with which the action is associated. + + procedure Insert_Action + (Assoc_Node : Node_Id; + Ins_Action : Node_Id; + Suppress : Check_Id); + -- Insert the action Ins_Action at the appropriate point as described + -- above. The action is analyzed using the default checks as modified + -- by the given Suppress argument after it is inserted. Assoc_Node is + -- the node with which the action is associated. + + procedure Insert_Actions + (Assoc_Node : Node_Id; + Ins_Actions : List_Id); + -- Insert the list of action Ins_Actions at the appropriate point as + -- described above. The actions are analyzed using the default checks + -- after they are inserted. Assoc_Node is the node with which the actions + -- are associated. Ins_Actions may be No_List, in which case the call has + -- no effect. + + procedure Insert_Actions + (Assoc_Node : Node_Id; + Ins_Actions : List_Id; + Suppress : Check_Id); + -- Insert the list of action Ins_Actions at the appropriate point as + -- described above. The actions are analyzed using the default checks + -- as modified by the given Suppress argument after they are inserted. + -- Assoc_Node is the node with which the actions are associated. + -- Ins_Actions may be No_List, in which case the call has no effect. + + procedure Insert_Actions_After + (Assoc_Node : Node_Id; + Ins_Actions : List_Id); + -- Assoc_Node must be a node in a list. Same as Insert_Actions but + -- actions will be inserted after N in a manner that is compatible with + -- the transient scope mechanism. This procedure must be used instead + -- of Insert_List_After if Assoc_Node may be in a transient scope. + -- + -- Implementation limitation: Assoc_Node must be a statement. We can + -- generalize to expressions if there is a need but this is tricky to + -- implement because of short-circuits (among other things).??? + + procedure Insert_Library_Level_Action (N : Node_Id); + -- This procedure inserts and analyzes the node N as an action at the + -- library level for the current unit (i.e. it is attached to the + -- Actions field of the N_Compilation_Aux node for the main unit). + + procedure Insert_Library_Level_Actions (L : List_Id); + -- Similar, but inserts a list of actions + + ----------------------- + -- Other Subprograms -- + ----------------------- + + procedure Adjust_Condition (N : Node_Id); + -- The node N is an expression whose root-type is Boolean, and which + -- represents a boolean value used as a condition (i.e. a True/False + -- value). This routine handles the case of C and Fortran convention + -- boolean types, which have zero/non-zero semantics rather than the normal + -- 0/1 semantics, and also the case of an enumeration rep clause that + -- specifies a non-standard representation. On return, node N always has + -- the type Standard.Boolean, with a value that is a standard Boolean + -- values of 0/1 for False/True. This procedure is used in two situations. + -- First, the processing for a condition field always calls + -- Adjust_Condition, so that the boolean value presented to the backend is + -- a standard value. Second, for the code for boolean operations such as + -- AND, Adjust_Condition is called on both operands, and then the operation + -- is done in the domain of Standard_Boolean, then Adjust_Result_Type is + -- called on the result to possibly reset the original type. This procedure + -- also takes care of validity checking if Validity_Checks = Tests. + + procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id); + -- The processing of boolean operations like AND uses the procedure + -- Adjust_Condition so that it can operate on Standard.Boolean, which is + -- the only boolean type on which the backend needs to be able to implement + -- such operators. This means that the result is also of type + -- Standard.Boolean. In general the type must be reset back to the original + -- type to get proper semantics, and that is the purpose of this procedure. + -- N is the node (of type Standard.Boolean), and T is the desired type. As + -- an optimization, this procedure leaves the type as Standard.Boolean in + -- contexts where this is permissible (in particular for Condition fields, + -- and for operands of other logical operations higher up the tree). The + -- call to this procedure is completely ignored if the argument N is not of + -- type Boolean. + + procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id); + -- Add a new freeze action for the given type. The freeze action is + -- attached to the freeze node for the type. Actions will be elaborated in + -- the order in which they are added. Note that the added node is not + -- analyzed. The analyze call is found in Exp_Ch13.Expand_N_Freeze_Entity. + + procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id); + -- Adds the given list of freeze actions (declarations or statements) for + -- the given type. The freeze actions are attached to the freeze node for + -- the type. Actions will be elaborated in the order in which they are + -- added, and the actions within the list will be elaborated in list order. + -- Note that the added nodes are not analyzed. The analyze call is found in + -- Exp_Ch13.Expand_N_Freeze_Entity. + + function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id; + -- Build an N_Procedure_Call_Statement calling the given runtime entity. + -- The call has no parameters. The first argument provides the location + -- information for the tree and for error messages. The call node is not + -- analyzed on return, the caller is responsible for analyzing it. + + function Build_Task_Image_Decls + (Loc : Source_Ptr; + Id_Ref : Node_Id; + A_Type : Entity_Id; + In_Init_Proc : Boolean := False) return List_Id; + -- Build declaration for a variable that holds an identifying string to be + -- used as a task name. Id_Ref is an identifier if the task is a variable, + -- and a selected or indexed component if the task is component of an + -- object. If it is an indexed component, A_Type is the corresponding array + -- type. Its index types are used to build the string as an image of the + -- index values. For composite types, the result includes two declarations: + -- one for a generated function that computes the image without using + -- concatenation, and one for the variable that holds the result. + -- + -- If In_Init_Proc is true, the call is part of the initialization of + -- a component of a composite type, and the enclosing initialization + -- procedure must be flagged as using the secondary stack. If In_Init_Proc + -- is false, the call is for a stand-alone object, and the generated + -- function itself must do its own cleanups. + + function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean; + -- This function is in charge of detecting record components that may + -- cause trouble in the back end if an attempt is made to assign the + -- component. The back end can handle such assignments with no problem if + -- the components involved are small (64-bits or less) records or scalar + -- items (including bit-packed arrays represented with modular types) or + -- are both aligned on a byte boundary (starting on a byte boundary, and + -- occupying an integral number of bytes). + -- + -- However, problems arise for records larger than 64 bits, or for arrays + -- (other than bit-packed arrays represented with a modular type) if the + -- component starts on a non-byte boundary, or does not occupy an integral + -- number of bytes (i.e. there are some bits possibly shared with fields + -- at the start or beginning of the component). The back end cannot handle + -- loading and storing such components in a single operation. + -- + -- This function is used to detect the troublesome situation. it is + -- conservative in the sense that it produces True unless it knows for + -- sure that the component is safe (as outlined in the first paragraph + -- above). The code generation for record and array assignment checks for + -- trouble using this function, and if so the assignment is generated + -- component-wise, which the back end is required to handle correctly. + -- + -- Note that in GNAT 3, the back end will reject such components anyway, + -- so the hard work in checking for this case is wasted in GNAT 3, but + -- it is harmless, so it is easier to do it in all cases, rather than + -- conditionalize it in GNAT 5 or beyond. + + procedure Convert_To_Actual_Subtype (Exp : Node_Id); + -- The Etype of an expression is the nominal type of the expression, + -- not the actual subtype. Often these are the same, but not always. + -- For example, a reference to a formal of unconstrained type has the + -- unconstrained type as its Etype, but the actual subtype is obtained by + -- applying the actual bounds. This routine is given an expression, Exp, + -- and (if necessary), replaces it using Rewrite, with a conversion to + -- the actual subtype, building the actual subtype if necessary. If the + -- expression is already of the requested type, then it is unchanged. + + function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id; + -- Return the id of the runtime package that will provide support for + -- concurrent type Typ. Currently only protected types are supported, + -- and the returned value is one of the following: + -- System_Tasking_Protected_Objects + -- System_Tasking_Protected_Objects_Entries + -- System_Tasking_Protected_Objects_Single_Entry + + function Current_Sem_Unit_Declarations return List_Id; + -- Return the place where it is fine to insert declarations for the + -- current semantic unit. If the unit is a package body, return the + -- visible declarations of the corresponding spec. For RCI stubs, this + -- is necessary because the point at which they are generated may not + -- be the earliest point at which they are used. + + function Duplicate_Subexpr + (Exp : Node_Id; + Name_Req : Boolean := False) return Node_Id; + -- Given the node for a subexpression, this function makes a logical copy + -- of the subexpression, and returns it. This is intended for use when the + -- expansion of an expression needs to repeat part of it. For example, + -- replacing a**2 by a*a requires two references to a which may be a + -- complex subexpression. Duplicate_Subexpr guarantees not to duplicate + -- side effects. If necessary, it generates actions to save the expression + -- value in a temporary, inserting these actions into the tree using + -- Insert_Actions with Exp as the insertion location. The original + -- expression and the returned result then become references to this saved + -- value. Exp must be analyzed on entry. On return, Exp is analyzed, but + -- the caller is responsible for analyzing the returned copy after it is + -- attached to the tree. The Name_Req flag is set to ensure that the result + -- is suitable for use in a context requiring name (e.g. the prefix of an + -- attribute reference). + -- + -- Note that if there are any run time checks in Exp, these same checks + -- will be duplicated in the returned duplicated expression. The two + -- following functions allow this behavior to be modified. + + function Duplicate_Subexpr_No_Checks + (Exp : Node_Id; + Name_Req : Boolean := False) return Node_Id; + -- Identical in effect to Duplicate_Subexpr, except that Remove_Checks + -- is called on the result, so that the duplicated expression does not + -- include checks. This is appropriate for use when Exp, the original + -- expression is unconditionally elaborated before the duplicated + -- expression, so that there is no need to repeat any checks. + + function Duplicate_Subexpr_Move_Checks + (Exp : Node_Id; + Name_Req : Boolean := False) return Node_Id; + -- Identical in effect to Duplicate_Subexpr, except that Remove_Checks is + -- called on Exp after the duplication is complete, so that the original + -- expression does not include checks. In this case the result returned + -- (the duplicated expression) will retain the original checks. This is + -- appropriate for use when the duplicated expression is sure to be + -- elaborated before the original expression Exp, so that there is no need + -- to repeat the checks. + + procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id); + -- This procedure ensures that type referenced by Typ is defined. For the + -- case of a type other than an Itype, nothing needs to be done, since + -- all such types have declaration nodes. For Itypes, an N_Itype_Reference + -- node is generated and inserted at the given node N. This is typically + -- used to ensure that an Itype is properly defined outside a conditional + -- construct when it is referenced in more than one branch. + + function Entry_Names_OK return Boolean; + -- Determine whether it is appropriate to dynamically allocate strings + -- which represent entry [family member] names. These strings are created + -- by the compiler and used by GDB. + + procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id); + -- Rewrites Cond with the expression: Cond and then Cond1. If Cond is + -- Empty, then simply returns Cond1 (this allows the use of Empty to + -- initialize a series of checks evolved by this routine, with a final + -- result of Empty indicating that no checks were required). The Sloc field + -- of the constructed N_And_Then node is copied from Cond1. + + procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id); + -- Rewrites Cond with the expression: Cond or else Cond1. If Cond is Empty, + -- then simply returns Cond1 (this allows the use of Empty to initialize a + -- series of checks evolved by this routine, with a final result of Empty + -- indicating that no checks were required). The Sloc field of the + -- constructed N_Or_Else node is copied from Cond1. + + procedure Expand_Subtype_From_Expr + (N : Node_Id; + Unc_Type : Entity_Id; + Subtype_Indic : Node_Id; + Exp : Node_Id); + -- Build a constrained subtype from the initial value in object + -- declarations and/or allocations when the type is indefinite (including + -- class-wide). + + function Find_Init_Call + (Var : Entity_Id; + Rep_Clause : Node_Id) return Node_Id; + -- Look for init_proc call for variable Var, either among declarations + -- between that of Var and a subsequent Rep_Clause applying to Var, or + -- in the list of freeze actions associated with Var, and if found, return + -- that call node. + + function Find_Interface_ADT + (T : Entity_Id; + Iface : Entity_Id) return Elmt_Id; + -- Ada 2005 (AI-251): Given a type T implementing the interface Iface, + -- return the element of Access_Disp_Table containing the tag of the + -- interface. + + function Find_Interface_Tag + (T : Entity_Id; + Iface : Entity_Id) return Entity_Id; + -- Ada 2005 (AI-251): Given a type T implementing the interface Iface, + -- return the record component containing the tag of Iface. + + function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id; + -- Find the first primitive operation of type T whose name is 'Name'. + -- This function allows the use of a primitive operation which is not + -- directly visible. If T is a class wide type, then the reference is + -- to an operation of the corresponding root type. Raises Program_Error + -- exception if no primitive operation is found. This is normally an + -- internal error, but in some cases is an expected consequence of + -- illegalities elsewhere. + + function Find_Prim_Op + (T : Entity_Id; + Name : TSS_Name_Type) return Entity_Id; + -- Find the first primitive operation of type T whose name has the form + -- indicated by the name parameter (i.e. is a type support subprogram + -- with the indicated suffix). This function allows use of a primitive + -- operation which is not directly visible. If T is a class wide type, + -- then the reference is to an operation of the corresponding root type. + -- Raises Program_Error exception if no primitive operation is found. + -- This is normally an internal error, but in some cases is an expected + -- consequence of illegalities elsewhere. + + function Find_Protection_Object (Scop : Entity_Id) return Entity_Id; + -- Traverse the scope stack starting from Scop and look for an entry, + -- entry family, or a subprogram that has a Protection_Object and return + -- it. Raises Program_Error if no such entity is found since the context + -- in which this routine is invoked should always have a protection + -- object. + + procedure Force_Evaluation + (Exp : Node_Id; + Name_Req : Boolean := False); + -- Force the evaluation of the expression right away. Similar behavior + -- to Remove_Side_Effects when Variable_Ref is set to TRUE. That is to + -- say, it removes the side-effects and captures the values of the + -- variables. Remove_Side_Effects guarantees that multiple evaluations + -- of the same expression won't generate multiple side effects, whereas + -- Force_Evaluation further guarantees that all evaluations will yield + -- the same result. + + function Fully_Qualified_Name_String (E : Entity_Id) return String_Id; + -- Generates the string literal corresponding to the fully qualified name + -- of entity E with an ASCII.NUL appended at the end of the name. + + procedure Generate_Poll_Call (N : Node_Id); + -- If polling is active, then a call to the Poll routine is built, + -- and then inserted before the given node N and analyzed. + + procedure Get_Current_Value_Condition + (Var : Node_Id; + Op : out Node_Kind; + Val : out Node_Id); + -- This routine processes the Current_Value field of the variable Var. If + -- the Current_Value field is null or if it represents a known value, then + -- on return Cond is set to N_Empty, and Val is set to Empty. + -- + -- The other case is when Current_Value points to an N_If_Statement or an + -- N_Elsif_Part or a N_Iteration_Scheme node (see description in Einfo for + -- exact details). In this case, Get_Current_Condition digs out the + -- condition, and then checks if the condition is known false, known true, + -- or not known at all. In the first two cases, Get_Current_Condition will + -- return with Op set to the appropriate conditional operator (inverted if + -- the condition is known false), and Val set to the constant value. If the + -- condition is not known, then Op and Val are set for the empty case + -- (N_Empty and Empty). + -- + -- The check for whether the condition is true/false unknown depends + -- on the case: + -- + -- For an IF, the condition is known true in the THEN part, known false + -- in any ELSIF or ELSE part, and not known outside the IF statement in + -- question. + -- + -- For an ELSIF, the condition is known true in the ELSIF part, known + -- FALSE in any subsequent ELSIF, or ELSE part, and not known before the + -- ELSIF, or after the end of the IF statement. + -- + -- The caller can use this result to determine the value (for the case of + -- N_Op_Eq), or to determine the result of some other test in other cases + -- (e.g. no access check required if N_Op_Ne Null). + + function Has_Controlled_Coextensions (Typ : Entity_Id) return Boolean; + -- Determine whether a record type has anonymous access discriminants with + -- a controlled designated type. + + function Has_Following_Address_Clause (D : Node_Id) return Boolean; + -- D is the node for an object declaration. This function searches the + -- current declarative part to look for an address clause for the object + -- being declared, and returns True if one is found. + + function Homonym_Number (Subp : Entity_Id) return Nat; + -- Here subp is the entity for a subprogram. This routine returns the + -- homonym number used to disambiguate overloaded subprograms in the same + -- scope (the number is used as part of constructed names to make sure that + -- they are unique). The number is the ordinal position on the Homonym + -- chain, counting only entries in the current scope. If an entity is not + -- overloaded, the returned number will be one. + + function Inside_Init_Proc return Boolean; + -- Returns True if current scope is within an init proc + + function In_Unconditional_Context (Node : Node_Id) return Boolean; + -- Node is the node for a statement or a component of a statement. This + -- function determines if the statement appears in a context that is + -- unconditionally executed, i.e. it is not within a loop or a conditional + -- or a case statement etc. + + function Is_All_Null_Statements (L : List_Id) return Boolean; + -- Return True if all the items of the list are N_Null_Statement nodes. + -- False otherwise. True for an empty list. It is an error to call this + -- routine with No_List as the argument. + + function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean; + -- Tests given type T, and returns True if T is a non-discriminated tagged + -- type which has a record representation clause that specifies the layout + -- of all the components, including recursively components in all parent + -- types. We exclude discriminated types for convenience, it is extremely + -- unlikely that the special processing associated with the use of this + -- routine is useful for the case of a discriminated type, and testing for + -- component overlap would be a pain. + + function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean; + -- Return True if Typ is a library level tagged type. Currently we use + -- this information to build statically allocated dispatch tables. + + function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean; + -- Determine whether the node P is a reference to a bit packed array, i.e. + -- whether the designated object is a component of a bit packed array, or a + -- subcomponent of such a component. If so, then all subscripts in P are + -- evaluated with a call to Force_Evaluation, and True is returned. + -- Otherwise False is returned, and P is not affected. + + function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean; + -- Determine whether the node P is a reference to a bit packed slice, i.e. + -- whether the designated object is bit packed slice or a component of a + -- bit packed slice. Return True if so. + + function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean; + -- Determine whether the node P is a slice of an array where the slice + -- result may cause alignment problems because it has an alignment that + -- is not compatible with the type. Return True if so. + + function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean; + -- Node N is an object reference. This function returns True if it is + -- possible that the object may not be aligned according to the normal + -- default alignment requirement for its type (e.g. if it appears in a + -- packed record, or as part of a component that has a component clause.) + + function Is_Renamed_Object (N : Node_Id) return Boolean; + -- Returns True if the node N is a renamed object. An expression is + -- considered to be a renamed object if either it is the Name of an object + -- renaming declaration, or is the prefix of a name which is a renamed + -- object. For example, in: + -- + -- x : r renames a (1 .. 2) (1); + -- + -- We consider that a (1 .. 2) is a renamed object since it is the prefix + -- of the name in the renaming declaration. + + function Is_Untagged_Derivation (T : Entity_Id) return Boolean; + -- Returns true if type T is not tagged and is a derived type, + -- or is a private type whose completion is such a type. + + function Is_Volatile_Reference (N : Node_Id) return Boolean; + -- Checks if the node N represents a volatile reference, which can be + -- either a direct reference to a variable treated as volatile, or an + -- indexed/selected component where the prefix is treated as volatile, + -- or has Volatile_Components set. A slice of a volatile variable is + -- also volatile. + + procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False); + -- N represents a node for a section of code that is known to be dead. Any + -- exception handler references and warning messages relating to this code + -- are removed. If Warn is True, a warning will be output at the start of N + -- indicating the deletion of the code. Note that the tree for the deleted + -- code is left intact so that e.g. cross-reference data is still valid. + + procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False); + -- Like the above procedure, but applies to every element in the given + -- list. If Warn is True, a warning will be output at the start of N + -- indicating the deletion of the code. + + function Known_Non_Negative (Opnd : Node_Id) return Boolean; + -- Given a node for a subexpression, determines if it represents a value + -- that cannot possibly be negative, and if so returns True. A value of + -- False means that it is not known if the value is positive or negative. + + function Known_Non_Null (N : Node_Id) return Boolean; + -- Given a node N for a subexpression of an access type, determines if + -- this subexpression yields a value that is known at compile time to + -- be non-null and returns True if so. Returns False otherwise. It is + -- an error to call this function if N is not of an access type. + + function Known_Null (N : Node_Id) return Boolean; + -- Given a node N for a subexpression of an access type, determines if this + -- subexpression yields a value that is known at compile time to be null + -- and returns True if so. Returns False otherwise. It is an error to call + -- this function if N is not of an access type. + + function Make_Invariant_Call (Expr : Node_Id) return Node_Id; + -- Expr is an object of a type which Has_Invariants set (and which thus + -- also has an Invariant_Procedure set). If invariants are enabled, this + -- function returns a call to the Invariant procedure passing Expr as the + -- argument, and returns it unanalyzed. If invariants are not enabled, + -- returns a null statement. + + function Make_Predicate_Call + (Typ : Entity_Id; + Expr : Node_Id) return Node_Id; + -- Typ is a type with Predicate_Function set. This routine builds a call to + -- this function passing Expr as the argument, and returns it unanalyzed. + + function Make_Predicate_Check + (Typ : Entity_Id; + Expr : Node_Id) return Node_Id; + -- Typ is a type with Predicate_Function set. This routine builds a Check + -- pragma whose first argument is Predicate, and the second argument is a + -- call to the this predicate function with Expr as the argument. + + function Make_Subtype_From_Expr + (E : Node_Id; + Unc_Typ : Entity_Id) return Node_Id; + -- Returns a subtype indication corresponding to the actual type of an + -- expression E. Unc_Typ is an unconstrained array or record, or + -- a classwide type. + + function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean; + -- Determines if the given type, Typ, may require a large temporary of the + -- kind that causes back-end trouble if stack checking is enabled. The + -- result is True only the size of the type is known at compile time and + -- large, where large is defined heuristically by the body of this routine. + -- The purpose of this routine is to help avoid generating troublesome + -- temporaries that interfere with stack checking mechanism. Note that the + -- caller has to check whether stack checking is actually enabled in order + -- to guide the expansion (typically of a function call). + + function Needs_Constant_Address + (Decl : Node_Id; + Typ : Entity_Id) return Boolean; + -- Check whether the expression in an address clause is restricted to + -- consist of constants, when the object has a non-trivial initialization + -- or is controlled. + + function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id; + -- An anonymous access type may designate a limited view. Check whether + -- non-limited view is available during expansion, to examine components + -- or other characteristics of the full type. + + function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean; + -- This function is used when testing whether or not to replace a reference + -- to entity E by a known constant value. Such replacement must be done + -- only in a scope known to be safe for such replacements. In particular, + -- if we are within a subprogram and the entity E is declared outside the + -- subprogram then we cannot do the replacement, since we do not attempt to + -- trace subprogram call flow. It is also unsafe to replace statically + -- allocated values (since they can be modified outside the scope), and we + -- also inhibit replacement of Volatile or aliased objects since their + -- address might be captured in a way we do not detect. A value of True is + -- returned only if the replacement is safe. + + function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean; + -- This function is used during processing the assignment of a record or + -- indexed component. The argument N is either the left hand or right hand + -- side of an assignment, and this function determines if there is a record + -- component reference where the record may be bit aligned in a manner that + -- causes trouble for the back end (see Component_May_Be_Bit_Aligned for + -- further details). + + procedure Remove_Side_Effects + (Exp : Node_Id; + Name_Req : Boolean := False; + Variable_Ref : Boolean := False); + -- Given the node for a subexpression, this function replaces the node if + -- necessary by an equivalent subexpression that is guaranteed to be side + -- effect free. This is done by extracting any actions that could cause + -- side effects, and inserting them using Insert_Actions into the tree to + -- which Exp is attached. Exp must be analyzed and resolved before the call + -- and is analyzed and resolved on return. The Name_Req may only be set to + -- True if Exp has the form of a name, and the effect is to guarantee that + -- any replacement maintains the form of name. If Variable_Ref is set to + -- TRUE, a variable is considered as side effect (used in implementing + -- Force_Evaluation). Note: after call to Remove_Side_Effects, it is safe + -- to call New_Copy_Tree to obtain a copy of the resulting expression. + + function Represented_As_Scalar (T : Entity_Id) return Boolean; + -- Returns True iff the implementation of this type in code generation + -- terms is scalar. This is true for scalars in the Ada sense, and for + -- packed arrays which are represented by a scalar (modular) type. + + function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean; + -- Given the node for an N_Unchecked_Type_Conversion, return True if this + -- is an unchecked conversion that Gigi can handle directly. Otherwise + -- return False if it is one for which the front end must provide a + -- temporary. Note that the node need not be analyzed, and thus the Etype + -- field may not be set, but in that case it must be the case that the + -- Subtype_Mark field of the node is set/analyzed. + + procedure Set_Current_Value_Condition (Cnode : Node_Id); + -- Cnode is N_If_Statement, N_Elsif_Part, or N_Iteration_Scheme (the latter + -- when a WHILE condition is present). This call checks whether Condition + -- (Cnode) has embedded expressions of a form that should result in setting + -- the Current_Value field of one or more entities, and if so sets these + -- fields to point to Cnode. + + procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id); + -- N is the node for a subprogram or generic body, and Spec_Id is the + -- entity for the corresponding spec. If an elaboration entity is defined, + -- then this procedure generates an assignment statement to set it True, + -- immediately after the body is elaborated. However, no assignment is + -- generated in the case of library level procedures, since the setting of + -- the flag in this case is generated in the binder. We do that so that we + -- can detect cases where this is the only elaboration action that is + -- required. + + procedure Set_Renamed_Subprogram (N : Node_Id; E : Entity_Id); + -- N is an node which is an entity name that represents the name of a + -- renamed subprogram. The node is rewritten to be an identifier that + -- refers directly to the renamed subprogram, given by entity E. + + procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id); + -- N is the node for a boolean array NOT operation, and T is the type of + -- the array. This routine deals with the silly case where the subtype of + -- the boolean array is False..False or True..True, where it is required + -- that a Constraint_Error exception be raised (RM 4.5.6(6)). + + procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id); + -- N is the node for a boolean array XOR operation, and T is the type of + -- the array. This routine deals with the silly case where the subtype of + -- the boolean array is True..True, where a raise of a Constraint_Error + -- exception is required (RM 4.5.6(6)). + + function Target_Has_Fixed_Ops + (Left_Typ : Entity_Id; + Right_Typ : Entity_Id; + Result_Typ : Entity_Id) return Boolean; + -- Returns True if and only if the target machine has direct support + -- for fixed-by-fixed multiplications and divisions for the given + -- operand and result types. This is called in package Exp_Fixd to + -- determine whether to expand such operations. + + function Type_May_Have_Bit_Aligned_Components + (Typ : Entity_Id) return Boolean; + -- Determines if Typ is a composite type that has within it (looking down + -- recursively at any subcomponents), a record type which has component + -- that may be bit aligned (see Possible_Bit_Aligned_Component). The result + -- is conservative, in that a result of False is decisive. A result of True + -- means that such a component may or may not be present. + + procedure Wrap_Cleanup_Procedure (N : Node_Id); + -- Given an N_Subprogram_Body node, this procedure adds an Abort_Defer call + -- at the start of the statement sequence, and an Abort_Undefer call at the + -- end of the statement sequence. All cleanup routines (i.e. those that are + -- called from "at end" handlers) must defer abort on entry and undefer + -- abort on exit. Note that it is assumed that the code for the procedure + -- does not contain any return statements which would allow the flow of + -- control to escape doing the undefer call. + +private + pragma Inline (Duplicate_Subexpr); + pragma Inline (Force_Evaluation); + pragma Inline (Is_Library_Level_Tagged_Type); +end Exp_Util; diff --git a/gcc/ada/exp_vfpt.adb b/gcc/ada/exp_vfpt.adb new file mode 100644 index 000000000..592114cf1 --- /dev/null +++ b/gcc/ada/exp_vfpt.adb @@ -0,0 +1,606 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ V F P T -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Rtsfind; use Rtsfind; +with Sem_Res; use Sem_Res; +with Sinfo; use Sinfo; +with Stand; use Stand; +with Tbuild; use Tbuild; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package body Exp_VFpt is + + VAXFF_Digits : constant := 6; + VAXDF_Digits : constant := 9; + VAXGF_Digits : constant := 15; + + ---------------------- + -- Expand_Vax_Arith -- + ---------------------- + + procedure Expand_Vax_Arith (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Base_Type (Etype (N)); + Typc : Character; + Atyp : Entity_Id; + Func : RE_Id; + Args : List_Id; + + begin + -- Get arithmetic type, note that we do D stuff in G + + if Digits_Value (Typ) = VAXFF_Digits then + Typc := 'F'; + Atyp := RTE (RE_F); + else + Typc := 'G'; + Atyp := RTE (RE_G); + end if; + + case Nkind (N) is + + when N_Op_Abs => + if Typc = 'F' then + Func := RE_Abs_F; + else + Func := RE_Abs_G; + end if; + + when N_Op_Add => + if Typc = 'F' then + Func := RE_Add_F; + else + Func := RE_Add_G; + end if; + + when N_Op_Divide => + if Typc = 'F' then + Func := RE_Div_F; + else + Func := RE_Div_G; + end if; + + when N_Op_Multiply => + if Typc = 'F' then + Func := RE_Mul_F; + else + Func := RE_Mul_G; + end if; + + when N_Op_Minus => + if Typc = 'F' then + Func := RE_Neg_F; + else + Func := RE_Neg_G; + end if; + + when N_Op_Subtract => + if Typc = 'F' then + Func := RE_Sub_F; + else + Func := RE_Sub_G; + end if; + + when others => + Func := RE_Null; + raise Program_Error; + + end case; + + Args := New_List; + + if Nkind (N) in N_Binary_Op then + Append_To (Args, + Convert_To (Atyp, Left_Opnd (N))); + end if; + + Append_To (Args, + Convert_To (Atyp, Right_Opnd (N))); + + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Func), Loc), + Parameter_Associations => Args))); + + Analyze_And_Resolve (N, Typ, Suppress => All_Checks); + end Expand_Vax_Arith; + + --------------------------- + -- Expand_Vax_Comparison -- + --------------------------- + + procedure Expand_Vax_Comparison (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Base_Type (Etype (Left_Opnd (N))); + Typc : Character; + Func : RE_Id; + Atyp : Entity_Id; + Revrs : Boolean := False; + Args : List_Id; + + begin + -- Get arithmetic type, note that we do D stuff in G + + if Digits_Value (Typ) = VAXFF_Digits then + Typc := 'F'; + Atyp := RTE (RE_F); + else + Typc := 'G'; + Atyp := RTE (RE_G); + end if; + + case Nkind (N) is + + when N_Op_Eq => + if Typc = 'F' then + Func := RE_Eq_F; + else + Func := RE_Eq_G; + end if; + + when N_Op_Ge => + if Typc = 'F' then + Func := RE_Le_F; + else + Func := RE_Le_G; + end if; + + Revrs := True; + + when N_Op_Gt => + if Typc = 'F' then + Func := RE_Lt_F; + else + Func := RE_Lt_G; + end if; + + Revrs := True; + + when N_Op_Le => + if Typc = 'F' then + Func := RE_Le_F; + else + Func := RE_Le_G; + end if; + + when N_Op_Lt => + if Typc = 'F' then + Func := RE_Lt_F; + else + Func := RE_Lt_G; + end if; + + when N_Op_Ne => + if Typc = 'F' then + Func := RE_Ne_F; + else + Func := RE_Ne_G; + end if; + + when others => + Func := RE_Null; + raise Program_Error; + + end case; + + if not Revrs then + Args := New_List ( + Convert_To (Atyp, Left_Opnd (N)), + Convert_To (Atyp, Right_Opnd (N))); + + else + Args := New_List ( + Convert_To (Atyp, Right_Opnd (N)), + Convert_To (Atyp, Left_Opnd (N))); + end if; + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Func), Loc), + Parameter_Associations => Args)); + + Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); + end Expand_Vax_Comparison; + + --------------------------- + -- Expand_Vax_Conversion -- + --------------------------- + + procedure Expand_Vax_Conversion (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Expr : constant Node_Id := Expression (N); + S_Typ : constant Entity_Id := Base_Type (Etype (Expr)); + T_Typ : constant Entity_Id := Base_Type (Etype (N)); + + CallS : RE_Id; + CallT : RE_Id; + Func : RE_Id; + + function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id; + -- Given one of the two types T, determines the corresponding call + -- type, i.e. the type to be used for the call (or the result of + -- the call). The actual operand is converted to (or from) this type. + -- Otyp is the other type, which is useful in figuring out the result. + -- The result returned is the RE_Id value for the type entity. + + function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id; + -- Find the predefined integer type that has the same size as the + -- fixed-point type T, for use in fixed/float conversions. + + --------------- + -- Call_Type -- + --------------- + + function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id is + begin + -- Vax float formats + + if Vax_Float (T) then + if Digits_Value (T) = VAXFF_Digits then + return RE_F; + + elsif Digits_Value (T) = VAXGF_Digits then + return RE_G; + + -- For D_Float, leave it as D float if the other operand is + -- G_Float, since this is the one conversion that is properly + -- supported for D_Float, but otherwise, use G_Float. + + else pragma Assert (Digits_Value (T) = VAXDF_Digits); + + if Vax_Float (Otyp) + and then Digits_Value (Otyp) = VAXGF_Digits + then + return RE_D; + else + return RE_G; + end if; + end if; + + -- For all discrete types, use 64-bit integer + + elsif Is_Discrete_Type (T) then + return RE_Q; + + -- For all real types (other than Vax float format), we use the + -- IEEE float-type which corresponds in length to the other type + -- (which is Vax Float). + + else pragma Assert (Is_Real_Type (T)); + + if Digits_Value (Otyp) = VAXFF_Digits then + return RE_S; + else + return RE_T; + end if; + end if; + end Call_Type; + + ------------------------------------------------- + -- Expand_Multiply_Fixed_By_Fixed_Giving_Fixed -- + ------------------------------------------------- + + function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id is + begin + if Esize (T) = Esize (Standard_Long_Long_Integer) then + return Standard_Long_Long_Integer; + elsif Esize (T) = Esize (Standard_Long_Integer) then + return Standard_Long_Integer; + else + return Standard_Integer; + end if; + end Equivalent_Integer_Type; + + -- Start of processing for Expand_Vax_Conversion; + + begin + -- If input and output are the same Vax type, we change the + -- conversion to be an unchecked conversion and that's it. + + if Vax_Float (S_Typ) and then Vax_Float (T_Typ) + and then Digits_Value (S_Typ) = Digits_Value (T_Typ) + then + Rewrite (N, + Unchecked_Convert_To (T_Typ, Expr)); + + -- Case of conversion of fixed-point type to Vax_Float type + + elsif Is_Fixed_Point_Type (S_Typ) then + + -- If Conversion_OK set, then we introduce an intermediate IEEE + -- target type since we are expecting the code generator to handle + -- the case of integer to IEEE float. + + if Conversion_OK (N) then + Rewrite (N, + Convert_To (T_Typ, OK_Convert_To (Universal_Real, Expr))); + + -- Otherwise, convert the scaled integer value to the target type, + -- and multiply by 'Small of type. + + else + Rewrite (N, + Make_Op_Multiply (Loc, + Left_Opnd => + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (T_Typ, Loc), + Expression => + Unchecked_Convert_To ( + Equivalent_Integer_Type (S_Typ), Expr)), + Right_Opnd => + Make_Real_Literal (Loc, Realval => Small_Value (S_Typ)))); + end if; + + -- Case of conversion of Vax_Float type to fixed-point type + + elsif Is_Fixed_Point_Type (T_Typ) then + + -- If Conversion_OK set, then we introduce an intermediate IEEE + -- target type, since we are expecting the code generator to handle + -- the case of IEEE float to integer. + + if Conversion_OK (N) then + Rewrite (N, + OK_Convert_To (T_Typ, Convert_To (Universal_Real, Expr))); + + -- Otherwise, multiply value by 'small of type, and convert to the + -- corresponding integer type. + + else + Rewrite (N, + Unchecked_Convert_To (T_Typ, + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Equivalent_Integer_Type (T_Typ), Loc), + Expression => + Make_Op_Multiply (Loc, + Left_Opnd => Expr, + Right_Opnd => + Make_Real_Literal (Loc, + Realval => Ureal_1 / Small_Value (T_Typ)))))); + end if; + + -- All other cases + + else + -- Compute types for call + + CallS := Call_Type (S_Typ, T_Typ); + CallT := Call_Type (T_Typ, S_Typ); + + -- Get function and its types + + if CallS = RE_D and then CallT = RE_G then + Func := RE_D_To_G; + + elsif CallS = RE_G and then CallT = RE_D then + Func := RE_G_To_D; + + elsif CallS = RE_G and then CallT = RE_F then + Func := RE_G_To_F; + + elsif CallS = RE_F and then CallT = RE_G then + Func := RE_F_To_G; + + elsif CallS = RE_F and then CallT = RE_S then + Func := RE_F_To_S; + + elsif CallS = RE_S and then CallT = RE_F then + Func := RE_S_To_F; + + elsif CallS = RE_G and then CallT = RE_T then + Func := RE_G_To_T; + + elsif CallS = RE_T and then CallT = RE_G then + Func := RE_T_To_G; + + elsif CallS = RE_F and then CallT = RE_Q then + Func := RE_F_To_Q; + + elsif CallS = RE_Q and then CallT = RE_F then + Func := RE_Q_To_F; + + elsif CallS = RE_G and then CallT = RE_Q then + Func := RE_G_To_Q; + + else pragma Assert (CallS = RE_Q and then CallT = RE_G); + Func := RE_Q_To_G; + end if; + + Rewrite (N, + Convert_To (T_Typ, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Func), Loc), + Parameter_Associations => New_List ( + Convert_To (RTE (CallS), Expr))))); + end if; + + Analyze_And_Resolve (N, T_Typ, Suppress => All_Checks); + end Expand_Vax_Conversion; + + ------------------------------- + -- Expand_Vax_Foreign_Return -- + ------------------------------- + + procedure Expand_Vax_Foreign_Return (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Base_Type (Etype (N)); + Func : RE_Id; + Args : List_Id; + Atyp : Entity_Id; + Rtyp : constant Entity_Id := Etype (N); + + begin + if Digits_Value (Typ) = VAXFF_Digits then + Func := RE_Return_F; + Atyp := RTE (RE_F); + elsif Digits_Value (Typ) = VAXDF_Digits then + Func := RE_Return_D; + Atyp := RTE (RE_D); + else pragma Assert (Digits_Value (Typ) = VAXGF_Digits); + Func := RE_Return_G; + Atyp := RTE (RE_G); + end if; + + Args := New_List (Convert_To (Atyp, N)); + + Rewrite (N, + Convert_To (Rtyp, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Func), Loc), + Parameter_Associations => Args))); + + Analyze_And_Resolve (N, Typ, Suppress => All_Checks); + end Expand_Vax_Foreign_Return; + + ----------------------------- + -- Expand_Vax_Real_Literal -- + ----------------------------- + + procedure Expand_Vax_Real_Literal (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Btyp : constant Entity_Id := Base_Type (Typ); + Stat : constant Boolean := Is_Static_Expression (N); + Nod : Node_Id; + + RE_Source : RE_Id; + RE_Target : RE_Id; + RE_Fncall : RE_Id; + -- Entities for source, target and function call in conversion + + begin + -- We do not know how to convert Vax format real literals, so what + -- we do is to convert these to be IEEE literals, and introduce the + -- necessary conversion operation. + + if Vax_Float (Btyp) then + -- What we want to construct here is + + -- x!(y_to_z (1.0E0)) + + -- where + + -- x is the base type of the literal (Btyp) + + -- y_to_z is + + -- s_to_f for F_Float + -- t_to_g for G_Float + -- t_to_d for D_Float + + -- The literal is typed as S (for F_Float) or T otherwise + + -- We do all our own construction, analysis, and expansion here, + -- since things are at too low a level to use Analyze or Expand + -- to get this built (we get circularities and other strange + -- problems if we try!) + + if Digits_Value (Btyp) = VAXFF_Digits then + RE_Source := RE_S; + RE_Target := RE_F; + RE_Fncall := RE_S_To_F; + + elsif Digits_Value (Btyp) = VAXDF_Digits then + RE_Source := RE_T; + RE_Target := RE_D; + RE_Fncall := RE_T_To_D; + + else pragma Assert (Digits_Value (Btyp) = VAXGF_Digits); + RE_Source := RE_T; + RE_Target := RE_G; + RE_Fncall := RE_T_To_G; + end if; + + Nod := Relocate_Node (N); + + Set_Etype (Nod, RTE (RE_Source)); + Set_Analyzed (Nod, True); + + Nod := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Fncall), Loc), + Parameter_Associations => New_List (Nod)); + + Set_Etype (Nod, RTE (RE_Target)); + Set_Analyzed (Nod, True); + + Nod := + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Expression => Nod); + + Set_Etype (Nod, Typ); + Set_Analyzed (Nod, True); + Rewrite (N, Nod); + + -- This odd expression is still a static expression. Note that + -- the routine Sem_Eval.Expr_Value_R understands this. + + Set_Is_Static_Expression (N, Stat); + end if; + end Expand_Vax_Real_Literal; + + ---------------------- + -- Expand_Vax_Valid -- + ---------------------- + + procedure Expand_Vax_Valid (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Pref : constant Node_Id := Prefix (N); + Ptyp : constant Entity_Id := Root_Type (Etype (Pref)); + Rtyp : constant Entity_Id := Etype (N); + Vtyp : RE_Id; + Func : RE_Id; + + begin + if Digits_Value (Ptyp) = VAXFF_Digits then + Func := RE_Valid_F; + Vtyp := RE_F; + elsif Digits_Value (Ptyp) = VAXDF_Digits then + Func := RE_Valid_D; + Vtyp := RE_D; + else pragma Assert (Digits_Value (Ptyp) = VAXGF_Digits); + Func := RE_Valid_G; + Vtyp := RE_G; + end if; + + Rewrite (N, + Convert_To (Rtyp, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Func), Loc), + Parameter_Associations => New_List ( + Convert_To (RTE (Vtyp), Pref))))); + + Analyze_And_Resolve (N); + end Expand_Vax_Valid; + +end Exp_VFpt; diff --git a/gcc/ada/exp_vfpt.ads b/gcc/ada/exp_vfpt.ads new file mode 100644 index 000000000..fdca701cf --- /dev/null +++ b/gcc/ada/exp_vfpt.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ V F P T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains specialized routines for handling the expansion +-- of arithmetic and conversion operations involving Vax format floating- +-- point formats as used on the Vax and the Alpha and the ia64. + +with Types; use Types; + +package Exp_VFpt is + + procedure Expand_Vax_Arith (N : Node_Id); + -- The node N is an arithmetic node (N_Op_Abs, N_Op_Add, N_Op_Sub, + -- N_Op_Div, N_Op_Mul, N_Op_Minus where the operands are in Vax float + -- format. This procedure expands the necessary call. + + procedure Expand_Vax_Comparison (N : Node_Id); + -- The node N is an arithmetic comparison node where the types to be + -- compared are in Vax float format. This procedure expands the necessary + -- call. + + procedure Expand_Vax_Conversion (N : Node_Id); + -- The node N is a type conversion node where either the source or the + -- target type, or both, are Vax floating-point type. + + procedure Expand_Vax_Foreign_Return (N : Node_Id); + -- The node N is a call to a foreign function that returns a Vax float + -- value in a floating point register. Wraps the call in an asm stub + -- that moves the return value to an integer location on Alpha/VMS, + -- noop everywhere else. + + procedure Expand_Vax_Real_Literal (N : Node_Id); + -- The node N is a real literal node where the type is a Vax floating-point + -- type. This procedure rewrites the node to eliminate the occurrence of + -- such constants. + + procedure Expand_Vax_Valid (N : Node_Id); + -- The node N is an attribute reference node for the Valid attribute where + -- the prefix is of a Vax floating-point type. This procedure expands the + -- necessary call for the validity test. + +end Exp_VFpt; diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb new file mode 100644 index 000000000..23d2aef83 --- /dev/null +++ b/gcc/ada/expander.adb @@ -0,0 +1,528 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P A N D E 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Debug_A; use Debug_A; +with Errout; use Errout; +with Exp_Aggr; use Exp_Aggr; +with Exp_Attr; use Exp_Attr; +with Exp_Ch2; use Exp_Ch2; +with Exp_Ch3; use Exp_Ch3; +with Exp_Ch4; use Exp_Ch4; +with Exp_Ch5; use Exp_Ch5; +with Exp_Ch6; use Exp_Ch6; +with Exp_Ch7; use Exp_Ch7; +with Exp_Ch8; use Exp_Ch8; +with Exp_Ch9; use Exp_Ch9; +with Exp_Ch11; use Exp_Ch11; +with Exp_Ch12; use Exp_Ch12; +with Exp_Ch13; use Exp_Ch13; +with Exp_Prag; use Exp_Prag; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Ch8; use Sem_Ch8; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Table; + +package body Expander is + + ---------------- + -- Local Data -- + ---------------- + + -- The following table is used to save values of the Expander_Active flag + -- when they are saved by Expander_Mode_Save_And_Set. We use an extendible + -- table (which is a bit of overkill) because it is easier than figuring + -- out a maximum value or bothering with range checks! + + package Expander_Flags is new Table.Table ( + Table_Component_Type => Boolean, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 32, + Table_Increment => 200, + Table_Name => "Expander_Flags"); + + ------------ + -- Expand -- + ------------ + + procedure Expand (N : Node_Id) is + begin + -- If we were analyzing a default expression (or other spec expression) + -- the Full_Analysis flag must be off. If we are in expansion mode then + -- we must be performing a full analysis. If we are analyzing a generic + -- then Expansion must be off. + + pragma Assert + (not (Full_Analysis and then In_Spec_Expression) + and then (Full_Analysis or else not Expander_Active) + and then not (Inside_A_Generic and then Expander_Active)); + + -- There are three reasons for the Expander_Active flag to be false + -- + -- The first is when are not generating code. In this mode the + -- Full_Analysis flag indicates whether we are performing a complete + -- analysis, in which case Full_Analysis = True or a pre-analysis in + -- which case Full_Analysis = False. See the spec of Sem for more + -- info on this. + -- + -- The second reason for the Expander_Active flag to be False is that + -- we are performing a pre-analysis. During pre-analysis all expansion + -- activity is turned off to make sure nodes are semantically decorated + -- but no extra nodes are generated. This is for instance needed for + -- the first pass of aggregate semantic processing. Note that in this + -- case the Full_Analysis flag is set to False because the node will + -- subsequently be re-analyzed with expansion on (see the spec of sem). + + -- Finally, expansion is turned off in a regular compilation if there + -- are serious errors. In that case there will be no further expansion, + -- but one cleanup action may be required: if a transient scope was + -- created (e.g. for a function that returns an unconstrained type) the + -- scope may still be on the stack, and must be removed explicitly, + -- given that the expansion actions that would normally process it will + -- not take place. This prevents cascaded errors due to stack mismatch. + + if not Expander_Active then + Set_Analyzed (N, Full_Analysis); + + if Serious_Errors_Detected > 0 + and then Scope_Is_Transient + then + Scope_Stack.Table + (Scope_Stack.Last).Actions_To_Be_Wrapped_Before := No_List; + Scope_Stack.Table + (Scope_Stack.Last).Actions_To_Be_Wrapped_After := No_List; + + Pop_Scope; + end if; + + return; + + else + Debug_A_Entry ("expanding ", N); + + -- Processing depends on node kind. For full details on the expansion + -- activity required in each case, see bodies of corresponding expand + -- routines. + + begin + case Nkind (N) is + + when N_Abort_Statement => + Expand_N_Abort_Statement (N); + + when N_Accept_Statement => + Expand_N_Accept_Statement (N); + + when N_Aggregate => + Expand_N_Aggregate (N); + + when N_Allocator => + Expand_N_Allocator (N); + + when N_And_Then => + Expand_N_And_Then (N); + + when N_Assignment_Statement => + Expand_N_Assignment_Statement (N); + + when N_Asynchronous_Select => + Expand_N_Asynchronous_Select (N); + + when N_Attribute_Definition_Clause => + Expand_N_Attribute_Definition_Clause (N); + + when N_Attribute_Reference => + Expand_N_Attribute_Reference (N); + + when N_Block_Statement => + Expand_N_Block_Statement (N); + + when N_Case_Expression => + Expand_N_Case_Expression (N); + + when N_Case_Statement => + Expand_N_Case_Statement (N); + + when N_Conditional_Entry_Call => + Expand_N_Conditional_Entry_Call (N); + + when N_Conditional_Expression => + Expand_N_Conditional_Expression (N); + + when N_Delay_Relative_Statement => + Expand_N_Delay_Relative_Statement (N); + + when N_Delay_Until_Statement => + Expand_N_Delay_Until_Statement (N); + + when N_Entry_Body => + Expand_N_Entry_Body (N); + + when N_Entry_Call_Statement => + Expand_N_Entry_Call_Statement (N); + + when N_Entry_Declaration => + Expand_N_Entry_Declaration (N); + + when N_Exception_Declaration => + Expand_N_Exception_Declaration (N); + + when N_Exception_Renaming_Declaration => + Expand_N_Exception_Renaming_Declaration (N); + + when N_Exit_Statement => + Expand_N_Exit_Statement (N); + + when N_Expanded_Name => + Expand_N_Expanded_Name (N); + + when N_Explicit_Dereference => + Expand_N_Explicit_Dereference (N); + + when N_Extended_Return_Statement => + Expand_N_Extended_Return_Statement (N); + + when N_Extension_Aggregate => + Expand_N_Extension_Aggregate (N); + + when N_Freeze_Entity => + Expand_N_Freeze_Entity (N); + + when N_Full_Type_Declaration => + Expand_N_Full_Type_Declaration (N); + + when N_Function_Call => + Expand_N_Function_Call (N); + + when N_Generic_Instantiation => + Expand_N_Generic_Instantiation (N); + + when N_Goto_Statement => + Expand_N_Goto_Statement (N); + + when N_Handled_Sequence_Of_Statements => + Expand_N_Handled_Sequence_Of_Statements (N); + + when N_Identifier => + Expand_N_Identifier (N); + + when N_Indexed_Component => + Expand_N_Indexed_Component (N); + + when N_If_Statement => + Expand_N_If_Statement (N); + + when N_In => + Expand_N_In (N); + + when N_Loop_Statement => + Expand_N_Loop_Statement (N); + + when N_Not_In => + Expand_N_Not_In (N); + + when N_Null => + Expand_N_Null (N); + + when N_Object_Declaration => + Expand_N_Object_Declaration (N); + + when N_Object_Renaming_Declaration => + Expand_N_Object_Renaming_Declaration (N); + + when N_Op_Add => + Expand_N_Op_Add (N); + + when N_Op_Abs => + Expand_N_Op_Abs (N); + + when N_Op_And => + Expand_N_Op_And (N); + + when N_Op_Concat => + Expand_N_Op_Concat (N); + + when N_Op_Divide => + Expand_N_Op_Divide (N); + + when N_Op_Eq => + Expand_N_Op_Eq (N); + + when N_Op_Expon => + Expand_N_Op_Expon (N); + + when N_Op_Ge => + Expand_N_Op_Ge (N); + + when N_Op_Gt => + Expand_N_Op_Gt (N); + + when N_Op_Le => + Expand_N_Op_Le (N); + + when N_Op_Lt => + Expand_N_Op_Lt (N); + + when N_Op_Minus => + Expand_N_Op_Minus (N); + + when N_Op_Mod => + Expand_N_Op_Mod (N); + + when N_Op_Multiply => + Expand_N_Op_Multiply (N); + + when N_Op_Ne => + Expand_N_Op_Ne (N); + + when N_Op_Not => + Expand_N_Op_Not (N); + + when N_Op_Or => + Expand_N_Op_Or (N); + + when N_Op_Plus => + Expand_N_Op_Plus (N); + + when N_Op_Rem => + Expand_N_Op_Rem (N); + + when N_Op_Rotate_Left => + Expand_N_Op_Rotate_Left (N); + + when N_Op_Rotate_Right => + Expand_N_Op_Rotate_Right (N); + + when N_Op_Shift_Left => + Expand_N_Op_Shift_Left (N); + + when N_Op_Shift_Right => + Expand_N_Op_Shift_Right (N); + + when N_Op_Shift_Right_Arithmetic => + Expand_N_Op_Shift_Right_Arithmetic (N); + + when N_Op_Subtract => + Expand_N_Op_Subtract (N); + + when N_Op_Xor => + Expand_N_Op_Xor (N); + + when N_Or_Else => + Expand_N_Or_Else (N); + + when N_Package_Body => + Expand_N_Package_Body (N); + + when N_Package_Declaration => + Expand_N_Package_Declaration (N); + + when N_Package_Renaming_Declaration => + Expand_N_Package_Renaming_Declaration (N); + + when N_Subprogram_Renaming_Declaration => + Expand_N_Subprogram_Renaming_Declaration (N); + + when N_Pragma => + Expand_N_Pragma (N); + + when N_Procedure_Call_Statement => + Expand_N_Procedure_Call_Statement (N); + + when N_Protected_Type_Declaration => + Expand_N_Protected_Type_Declaration (N); + + when N_Protected_Body => + Expand_N_Protected_Body (N); + + when N_Qualified_Expression => + Expand_N_Qualified_Expression (N); + + when N_Quantified_Expression => + Expand_N_Quantified_Expression (N); + + when N_Raise_Statement => + Expand_N_Raise_Statement (N); + + when N_Raise_Constraint_Error => + Expand_N_Raise_Constraint_Error (N); + + when N_Raise_Program_Error => + Expand_N_Raise_Program_Error (N); + + when N_Raise_Storage_Error => + Expand_N_Raise_Storage_Error (N); + + when N_Real_Literal => + Expand_N_Real_Literal (N); + + when N_Record_Representation_Clause => + Expand_N_Record_Representation_Clause (N); + + when N_Requeue_Statement => + Expand_N_Requeue_Statement (N); + + when N_Simple_Return_Statement => + Expand_N_Simple_Return_Statement (N); + + when N_Selected_Component => + Expand_N_Selected_Component (N); + + when N_Selective_Accept => + Expand_N_Selective_Accept (N); + + when N_Single_Task_Declaration => + Expand_N_Single_Task_Declaration (N); + + when N_Slice => + Expand_N_Slice (N); + + when N_Subtype_Indication => + Expand_N_Subtype_Indication (N); + + when N_Subprogram_Body => + Expand_N_Subprogram_Body (N); + + when N_Subprogram_Body_Stub => + Expand_N_Subprogram_Body_Stub (N); + + when N_Subprogram_Declaration => + Expand_N_Subprogram_Declaration (N); + + when N_Subprogram_Info => + Expand_N_Subprogram_Info (N); + + when N_Task_Body => + Expand_N_Task_Body (N); + + when N_Task_Type_Declaration => + Expand_N_Task_Type_Declaration (N); + + when N_Timed_Entry_Call => + Expand_N_Timed_Entry_Call (N); + + when N_Type_Conversion => + Expand_N_Type_Conversion (N); + + when N_Unchecked_Expression => + Expand_N_Unchecked_Expression (N); + + when N_Unchecked_Type_Conversion => + Expand_N_Unchecked_Type_Conversion (N); + + when N_Variant_Part => + Expand_N_Variant_Part (N); + + -- For all other node kinds, no expansion activity is required + + when others => null; + + end case; + + exception + when RE_Not_Available => + return; + end; + + -- Set result as analyzed and then do a possible transient wrap. The + -- transient wrap must be done after the Analyzed flag is set on, so + -- that we do not get a recursive attempt to expand the node N. + + Set_Analyzed (N); + + -- Deal with transient scopes + + if Scope_Is_Transient and then N = Node_To_Be_Wrapped then + + case Nkind (N) is + when N_Statement_Other_Than_Procedure_Call | + N_Procedure_Call_Statement => + Wrap_Transient_Statement (N); + + when N_Object_Declaration | + N_Object_Renaming_Declaration | + N_Subtype_Declaration => + Wrap_Transient_Declaration (N); + + when others => Wrap_Transient_Expression (N); + end case; + end if; + + Debug_A_Exit ("expanding ", N, " (done)"); + end if; + end Expand; + + --------------------------- + -- Expander_Mode_Restore -- + --------------------------- + + procedure Expander_Mode_Restore is + begin + -- Not active (has no effect) in ASIS mode (see comments in spec of + -- Expander_Mode_Save_And_Set). + + if ASIS_Mode then + return; + end if; + + -- Otherwise restore the flag + + Expander_Active := Expander_Flags.Table (Expander_Flags.Last); + Expander_Flags.Decrement_Last; + + -- Keep expander off if serious errors detected. In this case we do not + -- need expansion, and continued expansion may cause cascaded errors or + -- compiler bombs. + + if Serious_Errors_Detected /= 0 then + Expander_Active := False; + end if; + end Expander_Mode_Restore; + + -------------------------------- + -- Expander_Mode_Save_And_Set -- + -------------------------------- + + procedure Expander_Mode_Save_And_Set (Status : Boolean) is + begin + -- Not active (has no effect) in ASIS mode (see comments in spec of + -- Expander_Mode_Save_And_Set). + + if ASIS_Mode then + return; + end if; + + -- Otherwise save and set the flag + + Expander_Flags.Increment_Last; + Expander_Flags.Table (Expander_Flags.Last) := Expander_Active; + Expander_Active := Status; + end Expander_Mode_Save_And_Set; + +end Expander; diff --git a/gcc/ada/expander.ads b/gcc/ada/expander.ads new file mode 100644 index 000000000..df5944218 --- /dev/null +++ b/gcc/ada/expander.ads @@ -0,0 +1,167 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P A N D E R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This procedure performs any required expansion for the specified node. +-- The argument is the node that is a candidate for possible expansion. +-- If no expansion is required, then Expand returns without doing anything. + +-- If the node does need expansion, then the subtree is replaced by the +-- tree corresponding to the required rewriting. This tree is a syntactic +-- tree, except that all Entity fields must be correctly set on all +-- direct names, since the expander presumably knows what it wants, and in +-- any case it doesn't work to have the semantic analyzer perform visibility +-- analysis on these trees (they may have references to non-visible runtime +-- routines etc.) There are a few exceptions to this rule in special cases, +-- but they must be documented clearly. + +-- Expand is called in two different situations: + +-- Nodes that are not subexpressions (Nkind not in N_Subexpr) + +-- In this case, Expand is called from the body of Sem, immediately +-- after completing semantic analysis by calling the corresponding +-- Analyze_N_xxx procedure. If expansion occurs, the given node must +-- be replaced with another node that is also not a subexpression. +-- This seems naturally to be the case, since it is hard to imagine any +-- situation in which it would make sense to replace a non-expression +-- subtree with an expression. Once the substitution is completed, the +-- Expand routine must call Analyze on the resulting node to do any +-- required semantic analysis. Note that references to children copied +-- from the old tree won't be reanalyzed, since their Analyzed flag +-- is set. + +-- Nodes that are subexpressions (Nkind in N_Subexpr) + +-- In this case, Expand is called from Sem_Res.Resolve after completing +-- the resolution of the subexpression (this means that the expander sees +-- the fully typed subtree). If expansion occurs, the given node must be +-- replaced by a node that is also a subexpression. Again it is hard +-- to see how this restriction could possibly be violated. Once the +-- substitution is completed, the Expand routine must first call Analyze +-- on the resulting node to do any required semantic analysis, and then +-- call Resolve on the node to set the type (typically the type will be +-- the same as the original type of the input node, but this is not +-- always the case). + +-- In both these cases, Replace or Rewrite must be used to achieve the +-- of the node, since the Expander routine is only passed the Node_Id +-- of the node to be expanded, and the resulting expanded Node_Id must +-- be the same (the parameter to Expand is mode in, not mode in-out). + +-- For nodes other than subexpressions, it is not necessary to preserve the +-- original tree in the Expand routines, unlike the case for modifications +-- to the tree made in the semantic analyzer. This is because anyone who is +-- interested in working with the original tree (like ASIS) is required to +-- compile in semantics checks only mode. Thus Replace may be freely used +-- in such instances. + +-- For subexpressions, preservation of the original tree is required because +-- of the need for conformance checking of default expressions, which occurs +-- on expanded trees. This means that Replace should not ever be used on +-- on subexpression nodes. Instead use Rewrite. + +-- Note: the front end avoids calls to any of the expand routines if code +-- is not being generated. This is done for three reasons: + +-- 1. Make sure tree does not get mucked up by the expander if no +-- code is being generated, and is thus usable by ASIS etc. + +-- 2. Save time, since expansion is not needed if a compilation is +-- being done only to check the semantics, or if code generation +-- has been canceled due to previously detected errors. + +-- 3. Allow the expand routines to assume that the tree is error free. +-- This results from the fact that code generation mode is always +-- cancelled when any error occurs. + +-- If we ever decide to implement a feature allowing object modules to be +-- generated even if errors have been detected, then point 3 will no longer +-- hold, and the expand routines will have to be modified to operate properly +-- in the presence of errors (for many reasons this is not currently true). + +-- Note: a consequence of this approach is that error messages must never +-- be generated in the expander, since this would mean that such error +-- messages are not generated when the expander is not being called. + +-- Expansion is the last stage of analyzing a node, so Expand sets the +-- Analyzed flag of the node being analyzed as its last action. This is +-- done even if expansion is off (in this case, the only effect of the +-- call to Expand is to set the Analyzed flag to True). + +with Types; use Types; + +package Expander is + + -- The flag Opt.Expander_Active controls whether expansion is active + -- (True) or deactivated (False). When expansion is deactivated all + -- calls to expander routines have no effect. To temporarily disable + -- expansion, always call the routines defined below, do NOT change + -- Expander_Active directly. + -- + -- You should not use this flag to test if you are currently processing + -- a generic spec or body. Use the flag Inside_A_Generic instead (see + -- the spec of package Sem). + -- + -- There is no good reason for permanently changing the value of this flag + -- except after detecting a syntactic or semantic error. In this event + -- this flag is set to False to disable all subsequent expansion activity. + -- + -- In general this flag should be used as a read only value. The only + -- exceptions where it makes sense to temporarily change its value are: + -- + -- (a) when starting/completing the processing of a generic definition + -- or declaration (see routines Start_Generic_Processing and + -- End_Generic_Processing in Sem_Ch12) + -- + -- (b) when starting/completing the pre-analysis of an expression + -- (see the spec of package Sem for more info on pre-analysis.) + -- + -- Note that when processing a spec expression (In_Spec_Expression + -- is True) or performing semantic analysis of a generic spec or body + -- (Inside_A_Generic) or when performing pre-analysis (Full_Analysis is + -- False) the Expander_Active flag is False. + + procedure Expand (N : Node_Id); + -- Expand node N, as described above + + procedure Expander_Mode_Save_And_Set (Status : Boolean); + -- Saves the current setting of the Expander_Active flag on an internal + -- stack and then sets the flag to the given value. + -- + -- Note: this routine has no effect in ASIS_Mode. In ASIS_Mode, all + -- expansion activity is always off, since we want the original semantic + -- tree for ASIS purposes without any expansion. This is achieved by + -- setting Expander_Active False in ASIS_Mode. In situations such as + -- the call to Instantiate_Bodies in Frontend, Expander_Mode_Save_And_Set + -- may be called to temporarily turn the expander on, but this will have + -- no effect in ASIS mode. + + procedure Expander_Mode_Restore; + -- Restores the setting of the Expander_Active flag using the top entry + -- pushed onto the stack by Expander_Mode_Save_And_Reset, popping the + -- stack, except that if any errors have been detected, then the state + -- of the flag is left set to False. Disabled for ASIS_Mode (see above). + +end Expander; diff --git a/gcc/ada/expect.c b/gcc/ada/expect.c new file mode 100644 index 000000000..4f0f73fd1 --- /dev/null +++ b/gcc/ada/expect.c @@ -0,0 +1,513 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * E X P E C T * + * * + * C Implementation File * + * * + * 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 2, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING. If not, write * + * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * + * Boston, MA 02110-1301, USA. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion does not however invalidate any other reasons why the executable * + * file might be covered by the GNU Public License. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +#ifdef __alpha_vxworks +#include "vxWorks.h" +#endif + +#ifdef IN_RTS +#define POSIX +#include "tconfig.h" +#include "tsystem.h" +#else +#include "config.h" +#include "system.h" +#endif + +#include + +#ifdef __MINGW32__ +#if OLD_MINGW +#include +#endif +#elif defined (__vxworks) && defined (__RTP__) +#include +#elif defined (__Lynx__) +/* ??? See comment in adaint.c. */ +#define GCC_RESOURCE_H +#include +#elif defined (__nucleus__) +/* No wait.h available on Nucleus */ +#else +#include +#endif + +/* This file provides the low level functionalities needed to implement Expect + capabilities in GNAT.Expect. + Implementations for unix and windows systems is provided. + Dummy stubs are also provided for other systems. */ + +#ifdef _AIX +/* Work around the fact that gcc/cpp does not define "__unix__" under AiX. */ +#define __unix__ +#endif + +#ifdef __APPLE__ +/* Work around the fact that gcc/cpp does not define "__unix__" on Darwin. */ +#define __unix__ +#endif + +#ifdef _WIN32 + +#include +#include +#include +#include +#include "mingw32.h" + +void +__gnat_kill (int pid, int sig, int close) +{ + HANDLE h = OpenProcess (PROCESS_ALL_ACCESS, FALSE, pid); + if (h == NULL) + return; + if (sig == 9) + { + TerminateProcess (h, 0); + __gnat_win32_remove_handle (NULL, pid); + } + else if (sig == SIGINT) + GenerateConsoleCtrlEvent (CTRL_C_EVENT, pid); + else if (sig == SIGBREAK) + GenerateConsoleCtrlEvent (CTRL_BREAK_EVENT, pid); + /* ??? The last two alternatives don't really work. SIGBREAK requires setting + up process groups at start time which we don't do; treating SIGINT is just + not possible apparently. So we really only support signal 9. Fortunately + that's all we use in GNAT.Expect */ + + CloseHandle (h); +} + +int +__gnat_waitpid (int pid) +{ + HANDLE h = OpenProcess (PROCESS_ALL_ACCESS, FALSE, pid); + DWORD exitcode = 1; + DWORD res; + + if (h != NULL) + { + res = WaitForSingleObject (h, INFINITE); + GetExitCodeProcess (h, &exitcode); + CloseHandle (h); + } + + __gnat_win32_remove_handle (NULL, pid); + return (int) exitcode; +} + +int +__gnat_expect_fork (void) +{ + return 0; +} + +void +__gnat_expect_portable_execvp (int *pid, char *cmd, char *argv[]) +{ + *pid = __gnat_portable_no_block_spawn (argv); +} + +int +__gnat_pipe (int *fd) +{ + HANDLE read, write; + + CreatePipe (&read, &write, NULL, 0); + fd[0]=_open_osfhandle ((intptr_t)read, 0); + fd[1]=_open_osfhandle ((intptr_t)write, 0); + return 0; /* always success */ +} + +int +__gnat_expect_poll (int *fd, int num_fd, int timeout, int *is_set) +{ +#define MAX_DELAY 100 + + int i, delay, infinite = 0; + DWORD avail; + HANDLE handles[num_fd]; + + for (i = 0; i < num_fd; i++) + is_set[i] = 0; + + for (i = 0; i < num_fd; i++) + handles[i] = (HANDLE) _get_osfhandle (fd [i]); + + /* Start with small delays, and then increase them, to avoid polling too + much when waiting a long time */ + delay = 5; + + if (timeout < 0) + infinite = 1; + + while (1) + { + for (i = 0; i < num_fd; i++) + { + if (!PeekNamedPipe (handles [i], NULL, 0, NULL, &avail, NULL)) + return -1; + + if (avail > 0) + { + is_set[i] = 1; + return 1; + } + } + + if (!infinite && timeout <= 0) + return 0; + + Sleep (delay); + timeout -= delay; + + if (delay < MAX_DELAY) + delay += 10; + } +} + +#elif defined (VMS) +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +void +__gnat_kill (int pid, int sig, int close) +{ + kill (pid, sig); +} + +int +__gnat_waitpid (int pid) +{ + int status = 0; + + waitpid (pid, &status, 0); + status = WEXITSTATUS (status); + + return status; +} + +int +__gnat_pipe (int *fd) +{ + return pipe (fd); +} + +int +__gnat_expect_fork (void) +{ + return -1; +} + +void +__gnat_expect_portable_execvp (int *pid, char *cmd, char *argv[]) +{ + *pid = (int) getpid (); + /* Since cmd is fully qualified, it is incorrect to call execvp */ + execv (cmd, argv); + _exit (1); +} + +int +__gnat_expect_poll (int *fd, int num_fd, int timeout, int *is_set) +{ + int i, num, ready = 0; + unsigned int status; + int mbxchans [num_fd]; + struct dsc$descriptor_s mbxname; + struct io_status_block { + short int condition; + short int count; + int dev; + } iosb; + char buf [256]; + + for (i = 0; i < num_fd; i++) + is_set[i] = 0; + + for (i = 0; i < num_fd; i++) + { + + /* Get name of the mailbox used in the pipe */ + getname (fd [i], buf); + + /* Assign a channel to the mailbox */ + if (strlen (buf) > 0) + { + mbxname.dsc$w_length = strlen (buf); + mbxname.dsc$b_dtype = DSC$K_DTYPE_T; + mbxname.dsc$b_class = DSC$K_CLASS_S; + mbxname.dsc$a_pointer = buf; + + status = SYS$ASSIGN (&mbxname, &mbxchans[i], 0, 0, 0); + + if ((status & 1) != 1) + { + ready = -1; + return ready; + } + } + } + + num = timeout / 100; + + while (1) + { + for (i = 0; i < num_fd; i++) + { + if (mbxchans[i] > 0) + { + + /* Peek in the mailbox to see if there's data */ + status = SYS$QIOW + (0, mbxchans[i], IO$_SENSEMODE|IO$M_READERCHECK, + &iosb, 0, 0, 0, 0, 0, 0, 0, 0); + + if ((status & 1) != 1) + { + ready = -1; + goto deassign; + } + + if (iosb.count > 0) + { + is_set[i] = 1; + ready = 1; + goto deassign; + } + } + } + + if (timeout > 0 && num == 0) + { + ready = 0; + goto deassign; + } + + usleep (100000); + num--; + } + + deassign: + + /* Deassign channels assigned above */ + for (i = 0; i < num_fd; i++) + { + if (mbxchans[i] > 0) + status = SYS$DASSGN (mbxchans[i]); + } + + return ready; +} +#elif defined (__unix__) && !defined (__nucleus__) + +#ifdef __hpux__ +#include +#endif + +#include + +#ifndef NO_FD_SET +#define SELECT_MASK fd_set +#else /* !NO_FD_SET */ +#ifndef _AIX +typedef long fd_mask; +#endif /* _AIX */ +#ifdef _IBMR2 +#define SELECT_MASK void +#else /* !_IBMR2 */ +#define SELECT_MASK int +#endif /* !_IBMR2 */ +#endif /* !NO_FD_SET */ + +void +__gnat_kill (int pid, int sig, int close) +{ + kill (pid, sig); +} + +int +__gnat_waitpid (int pid) +{ + int status = 0; + + waitpid (pid, &status, 0); + status = WEXITSTATUS (status); + + return status; +} + +int +__gnat_pipe (int *fd) +{ + return pipe (fd); +} + +int +__gnat_expect_fork (void) +{ + return fork (); +} + +void +__gnat_expect_portable_execvp (int *pid, char *cmd, char *argv[]) +{ + *pid = (int) getpid (); + /* Since cmd is fully qualified, it is incorrect to call execvp */ + execv (cmd, argv); + _exit (1); +} + +int +__gnat_expect_poll (int *fd, int num_fd, int timeout, int *is_set) +{ + struct timeval tv; + SELECT_MASK rset; + SELECT_MASK eset; + + int max_fd = 0; + int ready; + int i; + int received; + + tv.tv_sec = timeout / 1000; + tv.tv_usec = (timeout % 1000) * 1000; + + do { + FD_ZERO (&rset); + FD_ZERO (&eset); + + for (i = 0; i < num_fd; i++) + { + FD_SET (fd[i], &rset); + FD_SET (fd[i], &eset); + + if (fd[i] > max_fd) + max_fd = fd[i]; + } + + ready = + select (max_fd + 1, &rset, NULL, &eset, timeout == -1 ? NULL : &tv); + + if (ready > 0) + { + received = 0; + + for (i = 0; i < num_fd; i++) + { + if (FD_ISSET (fd[i], &rset)) + { + is_set[i] = 1; + received = 1; + } + else + is_set[i] = 0; + } + +#ifdef __hpux__ + for (i = 0; i < num_fd; i++) + { + if (FD_ISSET (fd[i], &eset)) + { + struct request_info ei; + + /* Only query and reset error state if no file descriptor + is ready to be read, otherwise we will be signalling a + died process too early */ + + if (!received) + { + ioctl (fd[i], TIOCREQCHECK, &ei); + + if (ei.request == TIOCCLOSE) + { + ioctl (fd[i], TIOCREQSET, &ei); + return -1; + } + + ioctl (fd[i], TIOCREQSET, &ei); + } + ready--; + } + } +#endif + } + } while (timeout == -1 && ready == 0); + + return ready; +} + +#else + +void +__gnat_kill (int pid, int sig, int close) +{ +} + +int +__gnat_waitpid (int pid, int sig) +{ + return 0; +} + +int +__gnat_pipe (int *fd) +{ + return -1; +} + +int +__gnat_expect_fork (void) +{ + return -1; +} + +void +__gnat_expect_portable_execvp (int *pid, char *cmd, char *argv[]) +{ + *pid = 0; +} + +int +__gnat_expect_poll (int *fd, int num_fd, int timeout, int *is_set) +{ + return -1; +} +#endif diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h new file mode 100644 index 000000000..e9adbfffc --- /dev/null +++ b/gcc/ada/fe.h @@ -0,0 +1,253 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * FE * + * * + * C Header File * + * * + * 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. * + * * + ****************************************************************************/ + +/* This file contains definitions to access front-end functions and + variables used by gigi. */ + +/* comperr: */ + +#define Compiler_Abort comperr__compiler_abort +extern int Compiler_Abort (Fat_Pointer, int, Fat_Pointer) ATTRIBUTE_NORETURN; + +/* csets: */ + +#define Fold_Lower(C) csets__fold_lower[C] +#define Fold_Upper(C) csets__fold_upper[C] +extern char Fold_Lower[], Fold_Upper[]; + +/* debug: */ + +#define Debug_Flag_NN debug__debug_flag_nn +extern Boolean Debug_Flag_NN; + +/* einfo: We will be setting Esize for types, Component_Bit_Offset for fields, + Alignment for types and objects, Component_Size for array types, and + Present_Expr for N_Variant nodes. */ + +#define Set_Alignment einfo__set_alignment +#define Set_Component_Bit_Offset einfo__set_component_bit_offset +#define Set_Component_Size einfo__set_component_size +#define Set_Esize einfo__set_esize +#define Set_Mechanism einfo__set_mechanism +#define Set_RM_Size einfo__set_rm_size +#define Set_Present_Expr sinfo__set_present_expr + +extern void Set_Alignment (Entity_Id, Uint); +extern void Set_Component_Bit_Offset (Entity_Id, Uint); +extern void Set_Component_Size (Entity_Id, Uint); +extern void Set_Esize (Entity_Id, Uint); +extern void Set_Mechanism (Entity_Id, Mechanism_Type); +extern void Set_RM_Size (Entity_Id, Uint); +extern void Set_Present_Expr (Node_Id, Uint); + +/* Test if the node N is the name of an entity (i.e. is an identifier, + expanded name, or an attribute reference that returns an entity). */ +#define Is_Entity_Name einfo__is_entity_name +extern Boolean Is_Entity_Name (Node_Id); + +#define Get_Attribute_Definition_Clause einfo__get_attribute_definition_clause +extern Node_Id Get_Attribute_Definition_Clause (Entity_Id, char); + +/* errout: */ + +#define Error_Msg_N errout__error_msg_n +#define Error_Msg_NE errout__error_msg_ne +#define Set_Identifier_Casing errout__set_identifier_casing + +extern void Error_Msg_N (Fat_Pointer, Node_Id); +extern void Error_Msg_NE (Fat_Pointer, Node_Id, Entity_Id); +extern void Set_Identifier_Casing (Char *, const Char *); + +/* err_vars: */ + +#define Error_Msg_Node_2 err_vars__error_msg_node_2 +#define Error_Msg_Uint_1 err_vars__error_msg_uint_1 +#define Error_Msg_Uint_2 err_vars__error_msg_uint_2 + +extern Entity_Id Error_Msg_Node_2; +extern Uint Error_Msg_Uint_1; +extern Uint Error_Msg_Uint_2; + +/* exp_ch11: */ + +#define Get_Local_Raise_Call_Entity exp_ch11__get_local_raise_call_entity +#define Get_RT_Exception_Entity exp_ch11__get_rt_exception_entity + +extern Entity_Id Get_Local_Raise_Call_Entity (void); +extern Entity_Id Get_RT_Exception_Entity (int); + +/* exp_code: */ + +#define Asm_Input_Constraint exp_code__asm_input_constraint +#define Asm_Input_Value exp_code__asm_input_value +#define Asm_Output_Constraint exp_code__asm_output_constraint +#define Asm_Output_Variable exp_code__asm_output_variable +#define Asm_Template exp_code__asm_template +#define Clobber_Get_Next exp_code__clobber_get_next +#define Clobber_Setup exp_code__clobber_setup +#define Is_Asm_Volatile exp_code__is_asm_volatile +#define Next_Asm_Input exp_code__next_asm_input +#define Next_Asm_Output exp_code__next_asm_output +#define Setup_Asm_Inputs exp_code__setup_asm_inputs +#define Setup_Asm_Outputs exp_code__setup_asm_outputs + +extern Node_Id Asm_Input_Constraint (void); +extern Node_Id Asm_Input_Value (void); +extern Node_Id Asm_Output_Constraint (void); +extern Node_Id Asm_Output_Variable (void); +extern Node_Id Asm_Template (Node_Id); +extern char *Clobber_Get_Next (void); +extern void Clobber_Setup (Node_Id); +extern Boolean Is_Asm_Volatile (Node_Id); +extern void Next_Asm_Input (void); +extern void Next_Asm_Output (void); +extern void Setup_Asm_Inputs (Node_Id); +extern void Setup_Asm_Outputs (Node_Id); + +/* exp_dbug: */ + +#define Get_Encoded_Name exp_dbug__get_encoded_name +#define Get_External_Name exp_dbug__get_external_name +#define Get_External_Name_With_Suffix exp_dbug__get_external_name_with_suffix + +extern void Get_Encoded_Name (Entity_Id); +extern void Get_External_Name (Entity_Id, Boolean); +extern void Get_External_Name_With_Suffix (Entity_Id, Fat_Pointer); + +/* exp_util: */ + +#define Is_Fully_Repped_Tagged_Type exp_util__is_fully_repped_tagged_type + +extern Boolean Is_Fully_Repped_Tagged_Type (Entity_Id); + +/* lib: */ + +#define Cunit lib__cunit +#define Ident_String lib__ident_string +#define In_Extended_Main_Code_Unit lib__in_extended_main_code_unit +#define In_Same_Source_Unit lib__in_same_source_unit + +extern Node_Id Cunit (Unit_Number_Type); +extern Node_Id Ident_String (Unit_Number_Type); +extern Boolean In_Extended_Main_Code_Unit (Entity_Id); +extern Boolean In_Same_Source_Unit (Node_Id, Node_Id); + +/* opt: */ + +#define Global_Discard_Names opt__global_discard_names +#define Exception_Extra_Info opt__exception_extra_info +#define Exception_Locations_Suppressed opt__exception_locations_suppressed +#define Exception_Mechanism opt__exception_mechanism +#define Back_Annotate_Rep_Info opt__back_annotate_rep_info + +typedef enum {Setjmp_Longjmp, Back_End_Exceptions} Exception_Mechanism_Type; + +extern Boolean Global_Discard_Names; +extern Boolean Exception_Extra_Info; +extern Boolean Exception_Locations_Suppressed; +extern Exception_Mechanism_Type Exception_Mechanism; +extern Boolean Back_Annotate_Rep_Info; + +/* restrict: */ + +#define No_Exception_Handlers_Set restrict__no_exception_handlers_set +#define Check_No_Implicit_Heap_Alloc restrict__check_no_implicit_heap_alloc +#define Check_Elaboration_Code_Allowed restrict__check_elaboration_code_allowed +#define Check_Implicit_Dynamic_Code_Allowed restrict__check_implicit_dynamic_code_allowed + +extern Boolean No_Exception_Handlers_Set (void); +extern void Check_No_Implicit_Heap_Alloc (Node_Id); +extern void Check_Elaboration_Code_Allowed (Node_Id); +extern void Check_Implicit_Dynamic_Code_Allowed (Node_Id); + +/* sem_aux: */ + +#define Ancestor_Subtype sem_aux__ancestor_subtype +#define First_Discriminant sem_aux__first_discriminant +#define First_Stored_Discriminant sem_aux__first_stored_discriminant +#define First_Subtype sem_aux__first_subtype +#define Is_By_Reference_Type sem_aux__is_by_reference_type +#define Is_Derived_Type sem_aux__is_derived_type + +extern Entity_Id Ancestor_Subtype (Entity_Id); +extern Entity_Id First_Discriminant (Entity_Id); +extern Entity_Id First_Stored_Discriminant (Entity_Id); +extern Entity_Id First_Subtype (Entity_Id); +extern Boolean Is_By_Reference_Type (Entity_Id); +extern Boolean Is_Derived_Type (Entity_Id); + +/* sem_elim: */ + +#define Eliminate_Error_Msg sem_elim__eliminate_error_msg + +extern void Eliminate_Error_Msg (Node_Id, Entity_Id); + +/* sem_eval: */ + +#define Compile_Time_Known_Value sem_eval__compile_time_known_value +#define Expr_Value sem_eval__expr_value +#define Expr_Value_S sem_eval__expr_value_s +#define Is_OK_Static_Expression sem_eval__is_ok_static_expression +#define Is_OK_Static_Subtype sem_eval__is_ok_static_subtype + +extern Uint Expr_Value (Node_Id); +extern Node_Id Expr_Value_S (Node_Id); +extern Boolean Compile_Time_Known_Value (Node_Id); +extern Boolean Is_OK_Static_Expression (Node_Id); +extern Boolean Is_OK_Static_Subtype (Entity_Id); + +/* sem_util: */ + +#define Defining_Entity sem_util__defining_entity +#define First_Actual sem_util__first_actual +#define Next_Actual sem_util__next_actual +#define Requires_Transient_Scope sem_util__requires_transient_scope + +extern Entity_Id Defining_Entity (Node_Id); +extern Node_Id First_Actual (Node_Id); +extern Node_Id Next_Actual (Node_Id); +extern Boolean Requires_Transient_Scope (Entity_Id); + +/* sinfo: These functions aren't in sinfo.h since we don't make the + setting functions, just the retrieval functions. */ + +#define Set_Has_No_Elaboration_Code sinfo__set_has_no_elaboration_code +extern void Set_Has_No_Elaboration_Code (Node_Id, Boolean); + +/* targparm: */ + +#define Backend_Overflow_Checks_On_Target targparm__backend_overflow_checks_on_target +#define Stack_Check_Probes_On_Target targparm__stack_check_probes_on_target +#define Stack_Check_Limits_On_Target targparm__stack_check_limits_on_target + +extern Boolean Backend_Overflow_Checks_On_Target; +extern Boolean Stack_Check_Probes_On_Target; +extern Boolean Stack_Check_Limits_On_Target; diff --git a/gcc/ada/final.c b/gcc/ada/final.c new file mode 100644 index 000000000..bfd519e40 --- /dev/null +++ b/gcc/ada/final.c @@ -0,0 +1,42 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * F I N A L * + * * + * C Implementation File * + * * + * Copyright (C) 1992-2009 Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. * + * * + * As a special exception under Section 7 of GPL version 3, you are granted * + * additional permissions described in the GCC Runtime Library Exception, * + * version 3.1, as published by the Free Software Foundation. * + * * + * You should have received a copy of the GNU General Public License and * + * a copy of the GCC Runtime Library Exception along with this program; * + * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +extern void __gnat_finalize (void); + +/* This routine is called at the extreme end of execution of an Ada program + (the call is generated by the binder). The standard routine does nothing + at all, the intention is that this be replaced by system specific code + where finalization is required. */ + +void +__gnat_finalize (void) +{ +} diff --git a/gcc/ada/fmap.adb b/gcc/ada/fmap.adb new file mode 100644 index 000000000..171f7a18e --- /dev/null +++ b/gcc/ada/fmap.adb @@ -0,0 +1,535 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F M A P -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; +with Table; +with Types; use Types; + +pragma Warnings (Off); +-- This package is used also by gnatcoll +with System.OS_Lib; use System.OS_Lib; +pragma Warnings (On); + +with Unchecked_Conversion; + +with GNAT.HTable; + +package body Fmap is + + No_Mapping_File : Boolean := False; + -- Set to True when the specified mapping file cannot be read in + -- procedure Initialize, so that no attempt is made to open the mapping + -- file in procedure Update_Mapping_File. + + function To_Big_String_Ptr is new Unchecked_Conversion + (Source_Buffer_Ptr, Big_String_Ptr); + + Max_Buffer : constant := 1_500; + Buffer : String (1 .. Max_Buffer); + -- Used to bufferize output when writing to a new mapping file + + Buffer_Last : Natural := 0; + -- Index of last valid character in Buffer + + type Mapping is record + Uname : Unit_Name_Type; + Fname : File_Name_Type; + end record; + + package File_Mapping is new Table.Table ( + Table_Component_Type => Mapping, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 1_000, + Table_Increment => 1_000, + Table_Name => "Fmap.File_Mapping"); + -- Mapping table to map unit names to file names + + package Path_Mapping is new Table.Table ( + Table_Component_Type => Mapping, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 1_000, + Table_Increment => 1_000, + Table_Name => "Fmap.Path_Mapping"); + -- Mapping table to map file names to path names + + type Header_Num is range 0 .. 1_000; + + function Hash (F : Unit_Name_Type) return Header_Num; + -- Function used to compute hash of unit name + + No_Entry : constant Int := -1; + -- Signals no entry in following table + + package Unit_Hash_Table is new GNAT.HTable.Simple_HTable ( + Header_Num => Header_Num, + Element => Int, + No_Element => No_Entry, + Key => Unit_Name_Type, + Hash => Hash, + Equal => "="); + -- Hash table to map unit names to file names. Used in conjunction with + -- table File_Mapping above. + + function Hash (F : File_Name_Type) return Header_Num; + -- Function used to compute hash of file name + + package File_Hash_Table is new GNAT.HTable.Simple_HTable ( + Header_Num => Header_Num, + Element => Int, + No_Element => No_Entry, + Key => File_Name_Type, + Hash => Hash, + Equal => "="); + -- Hash table to map file names to path names. Used in conjunction with + -- table Path_Mapping above. + + Last_In_Table : Int := 0; + + package Forbidden_Names is new GNAT.HTable.Simple_HTable ( + Header_Num => Header_Num, + Element => Boolean, + No_Element => False, + Key => File_Name_Type, + Hash => Hash, + Equal => "="); + + ----------------------------- + -- Add_Forbidden_File_Name -- + ----------------------------- + + procedure Add_Forbidden_File_Name (Name : File_Name_Type) is + begin + Forbidden_Names.Set (Name, True); + end Add_Forbidden_File_Name; + + --------------------- + -- Add_To_File_Map -- + --------------------- + + procedure Add_To_File_Map + (Unit_Name : Unit_Name_Type; + File_Name : File_Name_Type; + Path_Name : File_Name_Type) + is + Unit_Entry : constant Int := Unit_Hash_Table.Get (Unit_Name); + File_Entry : constant Int := File_Hash_Table.Get (File_Name); + begin + if Unit_Entry = No_Entry or else + File_Mapping.Table (Unit_Entry).Fname /= File_Name + then + File_Mapping.Increment_Last; + Unit_Hash_Table.Set (Unit_Name, File_Mapping.Last); + File_Mapping.Table (File_Mapping.Last) := + (Uname => Unit_Name, Fname => File_Name); + end if; + + if File_Entry = No_Entry or else + Path_Mapping.Table (File_Entry).Fname /= Path_Name + then + Path_Mapping.Increment_Last; + File_Hash_Table.Set (File_Name, Path_Mapping.Last); + Path_Mapping.Table (Path_Mapping.Last) := + (Uname => Unit_Name, Fname => Path_Name); + end if; + end Add_To_File_Map; + + ---------- + -- Hash -- + ---------- + + function Hash (F : File_Name_Type) return Header_Num is + begin + return Header_Num (Int (F) rem Header_Num'Range_Length); + end Hash; + + function Hash (F : Unit_Name_Type) return Header_Num is + begin + return Header_Num (Int (F) rem Header_Num'Range_Length); + end Hash; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (File_Name : String) is + Src : Source_Buffer_Ptr; + Hi : Source_Ptr; + BS : Big_String_Ptr; + SP : String_Ptr; + + First : Positive := 1; + Last : Natural := 0; + + Uname : Unit_Name_Type; + Fname : File_Name_Type; + Pname : File_Name_Type; + + procedure Empty_Tables; + -- Remove all entries in case of incorrect mapping file + + function Find_File_Name return File_Name_Type; + -- Return Error_File_Name if the name buffer contains "/", otherwise + -- call Name_Find. "/" is the path name in the mapping file to indicate + -- that a source has been suppressed, and thus should not be found by + -- the compiler. + + function Find_Unit_Name return Unit_Name_Type; + -- Return the unit name in the name buffer. Return Error_Unit_Name if + -- the name buffer contains "/". + + procedure Get_Line; + -- Get a line from the mapping file, where a line is SP (First .. Last) + + procedure Report_Truncated; + -- Report a warning when the mapping file is truncated + -- (number of lines is not a multiple of 3). + + ------------------ + -- Empty_Tables -- + ------------------ + + procedure Empty_Tables is + begin + Unit_Hash_Table.Reset; + File_Hash_Table.Reset; + Path_Mapping.Set_Last (0); + File_Mapping.Set_Last (0); + Last_In_Table := 0; + end Empty_Tables; + + -------------------- + -- Find_File_Name -- + -------------------- + + function Find_File_Name return File_Name_Type is + begin + if Name_Buffer (1 .. Name_Len) = "/" then + + -- A path name of "/" is the indication that the source has been + -- "suppressed". Return Error_File_Name so that the compiler does + -- not find the source, even if it is in the include path. + + return Error_File_Name; + + else + return Name_Find; + end if; + end Find_File_Name; + + -------------------- + -- Find_Unit_Name -- + -------------------- + + function Find_Unit_Name return Unit_Name_Type is + begin + return Unit_Name_Type (Find_File_Name); + end Find_Unit_Name; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line is + use ASCII; + + begin + First := Last + 1; + + -- If not at the end of file, skip the end of line + + while First < SP'Last + and then (SP (First) = CR + or else SP (First) = LF + or else SP (First) = EOF) + loop + First := First + 1; + end loop; + + -- If not at the end of file, find the end of this new line + + if First < SP'Last and then SP (First) /= EOF then + Last := First; + + while Last < SP'Last + and then SP (Last + 1) /= CR + and then SP (Last + 1) /= LF + and then SP (Last + 1) /= EOF + loop + Last := Last + 1; + end loop; + + end if; + end Get_Line; + + ---------------------- + -- Report_Truncated -- + ---------------------- + + procedure Report_Truncated is + begin + Write_Str ("warning: mapping file """); + Write_Str (File_Name); + Write_Line (""" is truncated"); + end Report_Truncated; + + -- Start of processing for Initialize + + begin + Empty_Tables; + Name_Len := File_Name'Length; + Name_Buffer (1 .. Name_Len) := File_Name; + Read_Source_File (Name_Enter, 0, Hi, Src, Config); + + if Src = null then + Write_Str ("warning: could not read mapping file """); + Write_Str (File_Name); + Write_Line (""""); + No_Mapping_File := True; + + else + BS := To_Big_String_Ptr (Src); + SP := BS (1 .. Natural (Hi))'Unrestricted_Access; + + loop + -- Get the unit name + + Get_Line; + + -- Exit if end of file has been reached + + exit when First > Last; + + if (Last < First + 2) or else (SP (Last - 1) /= '%') + or else (SP (Last) /= 's' and then SP (Last) /= 'b') + then + Write_Line + ("warning: mapping file """ & File_Name & + """ is incorrectly formatted"); + Write_Line ("Line = """ & SP (First .. Last) & '"'); + Empty_Tables; + return; + end if; + + Name_Len := Last - First + 1; + Name_Buffer (1 .. Name_Len) := SP (First .. Last); + Uname := Find_Unit_Name; + + -- Get the file name + + Get_Line; + + -- If end of line has been reached, file is truncated + + if First > Last then + Report_Truncated; + Empty_Tables; + return; + end if; + + Name_Len := Last - First + 1; + Name_Buffer (1 .. Name_Len) := SP (First .. Last); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Fname := Find_File_Name; + + -- Get the path name + + Get_Line; + + -- If end of line has been reached, file is truncated + + if First > Last then + Report_Truncated; + Empty_Tables; + return; + end if; + + Name_Len := Last - First + 1; + Name_Buffer (1 .. Name_Len) := SP (First .. Last); + Pname := Find_File_Name; + + -- Add the mappings for this unit name + + Add_To_File_Map (Uname, Fname, Pname); + end loop; + end if; + + -- Record the length of the two mapping tables + + Last_In_Table := File_Mapping.Last; + end Initialize; + + ---------------------- + -- Mapped_File_Name -- + ---------------------- + + function Mapped_File_Name (Unit : Unit_Name_Type) return File_Name_Type is + The_Index : constant Int := Unit_Hash_Table.Get (Unit); + + begin + if The_Index = No_Entry then + return No_File; + else + return File_Mapping.Table (The_Index).Fname; + end if; + end Mapped_File_Name; + + ---------------------- + -- Mapped_Path_Name -- + ---------------------- + + function Mapped_Path_Name (File : File_Name_Type) return File_Name_Type is + Index : Int := No_Entry; + + begin + if Forbidden_Names.Get (File) then + return Error_File_Name; + end if; + + Index := File_Hash_Table.Get (File); + + if Index = No_Entry then + return No_File; + else + return Path_Mapping.Table (Index).Fname; + end if; + end Mapped_Path_Name; + + ------------------ + -- Reset_Tables -- + ------------------ + + procedure Reset_Tables is + begin + File_Mapping.Init; + Path_Mapping.Init; + Unit_Hash_Table.Reset; + File_Hash_Table.Reset; + Forbidden_Names.Reset; + Last_In_Table := 0; + end Reset_Tables; + + ------------------------- + -- Update_Mapping_File -- + ------------------------- + + procedure Update_Mapping_File (File_Name : String) is + File : File_Descriptor; + N_Bytes : Integer; + + File_Entry : Int; + + Status : Boolean; + -- For the call to Close + + procedure Put_Line (Name : Name_Id); + -- Put Name as a line in the Mapping File + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (Name : Name_Id) is + begin + Get_Name_String (Name); + + -- If the Buffer is full, write it to the file + + if Buffer_Last + Name_Len + 1 > Buffer'Last then + N_Bytes := Write (File, Buffer (1)'Address, Buffer_Last); + + if N_Bytes < Buffer_Last then + Fail ("disk full"); + end if; + + Buffer_Last := 0; + end if; + + -- Add the line to the Buffer + + Buffer (Buffer_Last + 1 .. Buffer_Last + Name_Len) := + Name_Buffer (1 .. Name_Len); + Buffer_Last := Buffer_Last + Name_Len + 1; + Buffer (Buffer_Last) := ASCII.LF; + end Put_Line; + + -- Start of Update_Mapping_File + + begin + -- If the mapping file could not be read, then it will not be possible + -- to update it. + + if No_Mapping_File then + return; + end if; + -- Only Update if there are new entries in the mappings + + if Last_In_Table < File_Mapping.Last then + + File := Open_Read_Write (Name => File_Name, Fmode => Binary); + + if File /= Invalid_FD then + if Last_In_Table > 0 then + Lseek (File, 0, Seek_End); + end if; + + for Unit in Last_In_Table + 1 .. File_Mapping.Last loop + Put_Line (Name_Id (File_Mapping.Table (Unit).Uname)); + Put_Line (Name_Id (File_Mapping.Table (Unit).Fname)); + File_Entry := + File_Hash_Table.Get (File_Mapping.Table (Unit).Fname); + Put_Line (Name_Id (Path_Mapping.Table (File_Entry).Fname)); + end loop; + + -- Before closing the file, write the buffer to the file. It is + -- guaranteed that the Buffer is not empty, because Put_Line has + -- been called at least 3 times, and after a call to Put_Line, the + -- Buffer is not empty. + + N_Bytes := Write (File, Buffer (1)'Address, Buffer_Last); + + if N_Bytes < Buffer_Last then + Fail ("disk full"); + end if; + + Close (File, Status); + + if not Status then + Fail ("disk full"); + end if; + + elsif not Quiet_Output then + Write_Str ("warning: could not open mapping file """); + Write_Str (File_Name); + Write_Line (""" for update"); + end if; + + end if; + end Update_Mapping_File; + +end Fmap; diff --git a/gcc/ada/fmap.ads b/gcc/ada/fmap.ads new file mode 100644 index 000000000..f1d54db47 --- /dev/null +++ b/gcc/ada/fmap.ads @@ -0,0 +1,81 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F M A P -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package keeps two mappings: from unit names to file names, +-- and from file names to path names. +-- +-- This mapping is used to communicate between the builder (gnatmake or +-- gprbuild) and the compiler. The format of this mapping file is the +-- following: +-- For each source file, there are three lines in the mapping file: +-- Unit name with %b or %s added depending on whether it is a body or a spec +-- This line is omitted for file-based languages +-- File name +-- Path name (set to '/' if the file should be ignored in fact, ie for +-- a Locally_Removed_File in a project) + +with Namet; use Namet; + +package Fmap is + + procedure Initialize (File_Name : String); + -- Initialize the mappings from the mapping file File_Name. + -- If the mapping file is incorrect (non existent file, truncated file, + -- duplicate entries), output a warning and do not initialize the mappings. + -- Record the state of the mapping tables in case Update is called + -- later on. + + function Mapped_Path_Name (File : File_Name_Type) return File_Name_Type; + -- Return the path name mapped to the file name File. + -- Return No_File if File is not mapped. + + function Mapped_File_Name (Unit : Unit_Name_Type) return File_Name_Type; + -- Return the file name mapped to the unit name Unit. + -- Return No_File if Unit is not mapped. + -- Return Error_Name if it is forbidden. + + procedure Add_To_File_Map + (Unit_Name : Unit_Name_Type; + File_Name : File_Name_Type; + Path_Name : File_Name_Type); + -- Add mapping of Unit_Name to File_Name and of File_Name to Path_Name + + procedure Update_Mapping_File (File_Name : String); + -- If Add_To_File_Map has been called (after Initialize or any time + -- if Initialize has not been called), append the new entries to the + -- mapping file whose file name is File_Name. + + procedure Reset_Tables; + -- Initialize all the internal data structures. This procedure is used + -- when several compilations are performed by the same process (by GNSA + -- for ASIS, for example) to remove any existing mappings from a previous + -- compilation. + + procedure Add_Forbidden_File_Name (Name : File_Name_Type); + -- Indicate that a source file name is forbidden. This is used when there + -- are excluded sources in projects (attributes Excluded_Source_Files or + -- Locally_Removed_Files). + +end Fmap; diff --git a/gcc/ada/fname-sf.adb b/gcc/ada/fname-sf.adb new file mode 100644 index 000000000..f967c1658 --- /dev/null +++ b/gcc/ada/fname-sf.adb @@ -0,0 +1,139 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F N A M E . S F -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Casing; use Casing; +with Fname; use Fname; +with Fname.UF; use Fname.UF; +with SFN_Scan; use SFN_Scan; +with Osint; use Osint; +with Types; use Types; + +with Unchecked_Conversion; + +package body Fname.SF is + + function To_Big_String_Ptr is new Unchecked_Conversion + (Source_Buffer_Ptr, Big_String_Ptr); + + ---------------------- + -- Local Procedures -- + ---------------------- + + procedure Set_File_Name + (Typ : Character; + U : String; + F : String; + Index : Natural); + -- This is a transfer function that is called from Scan_SFN_Pragmas, + -- and reformats its parameters appropriately for the version of + -- Set_File_Name found in Fname.SF. + + procedure Set_File_Name_Pattern + (Pat : String; + Typ : Character; + Dot : String; + Cas : Character); + -- This is a transfer function that is called from Scan_SFN_Pragmas, + -- and reformats its parameters appropriately for the version of + -- Set_File_Name_Pattern found in Fname.SF. + + ----------------------------------- + -- Read_Source_File_Name_Pragmas -- + ----------------------------------- + + procedure Read_Source_File_Name_Pragmas is + Src : Source_Buffer_Ptr; + Hi : Source_Ptr; + BS : Big_String_Ptr; + SP : String_Ptr; + + begin + Name_Buffer (1 .. 8) := "gnat.adc"; + Name_Len := 8; + Read_Source_File (Name_Enter, 0, Hi, Src); + + if Src /= null then + BS := To_Big_String_Ptr (Src); + SP := BS (1 .. Natural (Hi))'Unrestricted_Access; + Scan_SFN_Pragmas + (SP.all, + Set_File_Name'Access, + Set_File_Name_Pattern'Access); + end if; + end Read_Source_File_Name_Pragmas; + + ------------------- + -- Set_File_Name -- + ------------------- + + procedure Set_File_Name + (Typ : Character; + U : String; + F : String; + Index : Natural) + is + Unm : Unit_Name_Type; + Fnm : File_Name_Type; + begin + Name_Buffer (1 .. U'Length) := U; + Name_Len := U'Length; + Set_Casing (All_Lower_Case); + Name_Buffer (Name_Len + 1) := '%'; + Name_Buffer (Name_Len + 2) := Typ; + Name_Len := Name_Len + 2; + Unm := Name_Find; + Name_Buffer (1 .. F'Length) := F; + Name_Len := F'Length; + Fnm := Name_Find; + Fname.UF.Set_File_Name (Unm, Fnm, Nat (Index)); + end Set_File_Name; + + --------------------------- + -- Set_File_Name_Pattern -- + --------------------------- + + procedure Set_File_Name_Pattern + (Pat : String; + Typ : Character; + Dot : String; + Cas : Character) + is + Ctyp : Casing_Type; + Patp : constant String_Ptr := new String'(Pat); + Dotp : constant String_Ptr := new String'(Dot); + + begin + if Cas = 'l' then + Ctyp := All_Lower_Case; + elsif Cas = 'u' then + Ctyp := All_Upper_Case; + else -- Cas = 'm' + Ctyp := Mixed_Case; + end if; + + Fname.UF.Set_File_Name_Pattern (Patp, Typ, Dotp, Ctyp); + end Set_File_Name_Pattern; + +end Fname.SF; diff --git a/gcc/ada/fname-sf.ads b/gcc/ada/fname-sf.ads new file mode 100644 index 000000000..b4dbc55ab --- /dev/null +++ b/gcc/ada/fname-sf.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F N A M E . S F -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This child package contains a routine to read and process Source_File_Name +-- pragmas from the gnat.adc file in the current directory. In order to use +-- the routines in package Fname.UF, it is required that Source_File_Name +-- pragmas be processed. There are two places where such processing takes +-- place: + +-- The compiler front end (par-prag.adb), which is the general circuit +-- for processing all pragmas, including Source_File_Name. + +-- The stand alone routine in this unit, which is convenient to use +-- from tools that do not want to include the compiler front end. + +-- Note that this unit does depend on several of the compiler front-end +-- sources, including osint. If it is necessary to scan source file name +-- pragmas with less dependence on such sources, look at unit SFN_Scan. + +package Fname.SF is + + procedure Read_Source_File_Name_Pragmas; + -- This procedure is called to read the gnat.adc file and process any + -- Source_File_Name pragmas contained in this file. All other pragmas + -- are ignored. The result is appropriate calls to routines in the + -- package Fname.UF to register the pragmas so that subsequent calls + -- to Get_File_Name work correctly. + -- + -- Note: The caller must have made an appropriate call to the + -- Osint.Initialize routine to initialize Osint before calling + -- this procedure. + -- + -- If a syntax error is detected while scanning the gnat.adc file, + -- then the exception SFN_Scan.Syntax_Error_In_GNAT_ADC is raised + -- and SFN_Scan.Cursor contains the approximate index relative to + -- the start of the gnat.adc file of the error. + +end Fname.SF; diff --git a/gcc/ada/fname-uf.adb b/gcc/ada/fname-uf.adb new file mode 100644 index 000000000..8f4e66f85 --- /dev/null +++ b/gcc/ada/fname-uf.adb @@ -0,0 +1,612 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F N A M E . U F -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Alloc; +with Debug; use Debug; +with Fmap; use Fmap; +with Krunch; +with Opt; use Opt; +with Osint; use Osint; +with Table; +with Targparm; use Targparm; +with Uname; use Uname; +with Widechar; use Widechar; + +with GNAT.HTable; + +package body Fname.UF is + + -------------------------------------------------------- + -- Declarations for Handling Source_File_Name pragmas -- + -------------------------------------------------------- + + type SFN_Entry is record + U : Unit_Name_Type; -- Unit name + F : File_Name_Type; -- Spec/Body file name + Index : Nat; -- Index from SFN pragma (0 if none) + end record; + -- Record single Unit_Name type call to Set_File_Name + + package SFN_Table is new Table.Table ( + Table_Component_Type => SFN_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.SFN_Table_Initial, + Table_Increment => Alloc.SFN_Table_Increment, + Table_Name => "SFN_Table"); + -- Table recording all Unit_Name calls to Set_File_Name + + type SFN_Header_Num is range 0 .. 100; + + function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num; + -- Compute hash index for use by Simple_HTable + + No_Entry : constant Int := -1; + -- Signals no entry in following table + + package SFN_HTable is new GNAT.HTable.Simple_HTable ( + Header_Num => SFN_Header_Num, + Element => Int, + No_Element => No_Entry, + Key => Unit_Name_Type, + Hash => SFN_Hash, + Equal => "="); + -- Hash table allowing rapid access to SFN_Table, the element value + -- is an index into this table. + + type SFN_Pattern_Entry is record + Pat : String_Ptr; -- File name pattern (with asterisk in it) + Typ : Character; -- 'S'/'B'/'U' for spec/body/subunit + Dot : String_Ptr; -- Dot_Separator string + Cas : Casing_Type; -- Upper/Lower/Mixed + end record; + -- Records single call to Set_File_Name_Patterm + + package SFN_Patterns is new Table.Table ( + Table_Component_Type => SFN_Pattern_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "SFN_Patterns"); + -- Table recording all calls to Set_File_Name_Pattern. Note that the + -- first two entries are set to represent the standard GNAT rules + -- for file naming. + + ----------------------- + -- File_Name_Of_Body -- + ----------------------- + + function File_Name_Of_Body (Name : Name_Id) return File_Name_Type is + begin + Get_Name_String (Name); + Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%b"; + Name_Len := Name_Len + 2; + return Get_File_Name (Name_Enter, Subunit => False); + end File_Name_Of_Body; + + ----------------------- + -- File_Name_Of_Spec -- + ----------------------- + + function File_Name_Of_Spec (Name : Name_Id) return File_Name_Type is + begin + Get_Name_String (Name); + Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%s"; + Name_Len := Name_Len + 2; + return Get_File_Name (Name_Enter, Subunit => False); + end File_Name_Of_Spec; + + ---------------------------- + -- Get_Expected_Unit_Type -- + ---------------------------- + + function Get_Expected_Unit_Type + (Fname : File_Name_Type) return Expected_Unit_Type + is + begin + -- In syntax checking only mode or in multiple unit per file mode, + -- there can be more than one unit in a file, so the file name is + -- not a useful guide to the nature of the unit. + + if Operating_Mode = Check_Syntax + or else Multiple_Unit_Index /= 0 + then + return Unknown; + end if; + + -- Search the file mapping table, if we find an entry for this + -- file we know whether it is a spec or a body. + + for J in SFN_Table.First .. SFN_Table.Last loop + if Fname = SFN_Table.Table (J).F then + if Is_Body_Name (SFN_Table.Table (J).U) then + return Expect_Body; + else + return Expect_Spec; + end if; + end if; + end loop; + + -- If no entry in file naming table, assume .ads/.adb for spec/body + -- and return unknown if we have neither of these two cases. + + Get_Name_String (Fname); + + if Name_Len > 4 then + if Name_Buffer (Name_Len - 3 .. Name_Len) = ".ads" then + return Expect_Spec; + elsif Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb" then + return Expect_Body; + end if; + end if; + + return Unknown; + end Get_Expected_Unit_Type; + + ------------------- + -- Get_File_Name -- + ------------------- + + function Get_File_Name + (Uname : Unit_Name_Type; + Subunit : Boolean; + May_Fail : Boolean := False) return File_Name_Type + is + Unit_Char : Character; + -- Set to 's' or 'b' for spec or body or to 'u' for a subunit + + Unit_Char_Search : Character; + -- Same as Unit_Char, except that in the case of 'u' for a subunit, + -- we set Unit_Char_Search to 'b' if we do not find a subunit match. + + N : Int; + + Pname : File_Name_Type := No_File; + Fname : File_Name_Type := No_File; + -- Path name and File name for mapping + + begin + -- Null or error name means that some previous error occurred + -- This is an unrecoverable error, so signal it. + + if Uname in Error_Unit_Name_Or_No_Unit_Name then + raise Unrecoverable_Error; + end if; + + -- Look in the map from unit names to file names + + Fname := Mapped_File_Name (Uname); + + -- If the unit name is already mapped, return the corresponding + -- file name from the map. + + if Fname /= No_File then + return Fname; + end if; + + -- If there is a specific SFN pragma, return the corresponding file name + + N := SFN_HTable.Get (Uname); + + if N /= No_Entry then + return SFN_Table.Table (N).F; + end if; + + -- Here for the case where the name was not found in the table + + Get_Decoded_Name_String (Uname); + + -- A special fudge, normally we don't have operator symbols present, + -- since it is always an error to do so. However, if we do, at this + -- stage it has a leading double quote. + + -- What we do in this case is to go back to the undecoded name, which + -- is of the form, for example: + + -- Oand%s + + -- and build a file name that looks like: + + -- _and_.ads + + -- which is bit peculiar, but we keep it that way. This means that + -- we avoid bombs due to writing a bad file name, and w get expected + -- error processing downstream, e.g. a compilation following gnatchop. + + if Name_Buffer (1) = '"' then + Get_Name_String (Uname); + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Name_Buffer (Name_Len - 1); + Name_Buffer (Name_Len - 1) := Name_Buffer (Name_Len - 2); + Name_Buffer (Name_Len - 2) := '_'; + Name_Buffer (1) := '_'; + end if; + + -- Deal with spec or body suffix + + Unit_Char := Name_Buffer (Name_Len); + pragma Assert (Unit_Char = 'b' or else Unit_Char = 's'); + pragma Assert (Name_Len >= 3 and then Name_Buffer (Name_Len - 1) = '%'); + Name_Len := Name_Len - 2; + + if Subunit then + Unit_Char := 'u'; + end if; + + -- Now we need to find the proper translation of the name + + declare + Uname : constant String (1 .. Name_Len) := + Name_Buffer (1 .. Name_Len); + + Pent : Nat; + Plen : Natural; + Fnam : File_Name_Type := No_File; + J : Natural; + Dot : String_Ptr; + Dotl : Natural; + + Is_Predef : Boolean; + -- Set True for predefined file + + function C (N : Natural) return Character; + -- Return N'th character of pattern + + function C (N : Natural) return Character is + begin + return SFN_Patterns.Table (Pent).Pat (N); + end C; + + -- Start of search through pattern table + + begin + -- Search pattern table to find a matching entry. In the general + -- case we do two complete searches. The first time through we + -- stop only if a matching file is found, the second time through + -- we accept the first match regardless. Note that there will + -- always be a match the second time around, because of the + -- default entries at the end of the table. + + for No_File_Check in False .. True loop + Unit_Char_Search := Unit_Char; + + <> + -- The search is repeated with Unit_Char_Search set to b, if an + -- initial search for the subunit case fails to find any match. + + Pent := SFN_Patterns.First; + while Pent <= SFN_Patterns.Last loop + if SFN_Patterns.Table (Pent).Typ = Unit_Char_Search then + Name_Len := 0; + + -- Determine if we have a predefined file name + + Name_Len := Uname'Length; + Name_Buffer (1 .. Name_Len) := Uname; + Is_Predef := + Is_Predefined_File_Name (Renamings_Included => True); + + -- Found a match, execute the pattern + + Name_Len := Uname'Length; + Name_Buffer (1 .. Name_Len) := Uname; + + -- Apply casing, except that we do not do this for the case + -- of a predefined library file. For the latter, we always + -- use the all lower case name, regardless of the setting. + + if not Is_Predef then + Set_Casing (SFN_Patterns.Table (Pent).Cas); + end if; + + -- If dot translation required do it + + Dot := SFN_Patterns.Table (Pent).Dot; + Dotl := Dot.all'Length; + + if Dot.all /= "." then + J := 1; + + while J <= Name_Len loop + if Name_Buffer (J) = '.' then + + if Dotl = 1 then + Name_Buffer (J) := Dot (Dot'First); + + else + Name_Buffer (J + Dotl .. Name_Len + Dotl - 1) := + Name_Buffer (J + 1 .. Name_Len); + Name_Buffer (J .. J + Dotl - 1) := Dot.all; + Name_Len := Name_Len + Dotl - 1; + end if; + + J := J + Dotl; + + -- Skip past wide char sequences to avoid messing + -- with dot characters that are part of a sequence. + + elsif Name_Buffer (J) = ASCII.ESC + or else (Upper_Half_Encoding + and then + Name_Buffer (J) in Upper_Half_Character) + then + Skip_Wide (Name_Buffer, J); + else + J := J + 1; + end if; + end loop; + end if; + + -- Here move result to right if preinsertion before * + + Plen := SFN_Patterns.Table (Pent).Pat'Length; + for K in 1 .. Plen loop + if C (K) = '*' then + if K /= 1 then + Name_Buffer (1 + K - 1 .. Name_Len + K - 1) := + Name_Buffer (1 .. Name_Len); + + for L in 1 .. K - 1 loop + Name_Buffer (L) := C (L); + end loop; + + Name_Len := Name_Len + K - 1; + end if; + + for L in K + 1 .. Plen loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := C (L); + end loop; + + exit; + end if; + end loop; + + -- Execute possible crunch on constructed name. The krunch + -- operation excludes any extension that may be present. + + J := Name_Len; + while J > 1 loop + exit when Name_Buffer (J) = '.'; + J := J - 1; + end loop; + + -- Case of extension present + + if J > 1 then + declare + Ext : constant String := Name_Buffer (J .. Name_Len); + + begin + -- Remove extension + + Name_Len := J - 1; + + -- Krunch what's left + + Krunch + (Name_Buffer, + Name_Len, + Integer (Maximum_File_Name_Length), + Debug_Flag_4, + OpenVMS_On_Target); + + -- Replace extension + + Name_Buffer + (Name_Len + 1 .. Name_Len + Ext'Length) := Ext; + Name_Len := Name_Len + Ext'Length; + end; + + -- Case of no extension present, straight krunch on + -- the entire file name. + + else + Krunch + (Name_Buffer, + Name_Len, + Integer (Maximum_File_Name_Length), + Debug_Flag_4); + end if; + + Fnam := Name_Find; + + -- If we are in the second search of the table, we accept + -- the file name without checking, because we know that + -- the file does not exist, except when May_Fail is True, + -- in which case we return No_File. + + if No_File_Check then + if May_Fail then + return No_File; + else + return Fnam; + end if; + + -- Otherwise we check if the file exists + + else + Pname := Find_File (Fnam, Source); + + -- If it does exist, we add it to the mappings and + -- return the file name. + + if Pname /= No_File then + + -- Add to mapping, so that we don't do another + -- path search in Find_File for this file name + -- and, if we use a mapping file, we are ready + -- to update it at the end of this compilation + -- for the benefit of other compilation processes. + + Add_To_File_Map (Get_File_Name.Uname, Fnam, Pname); + return Fnam; + + -- If there are only two entries, they are those of + -- the default GNAT naming scheme. The file does + -- not exist, but there is no point doing the + -- second search, because we will end up with the + -- same file name. Just return the file name. + + elsif SFN_Patterns.Last = 2 then + return Fnam; + + -- The file does not exist, but there may be other + -- naming scheme. Keep on searching. + + else + Fnam := No_File; + end if; + end if; + end if; + + Pent := Pent + 1; + end loop; + + -- If search failed, and was for a subunit, repeat the search + -- with Unit_Char_Search reset to 'b', since in the normal case + -- we simply treat subunits as bodies. + + if Fnam = No_File and then Unit_Char_Search = 'u' then + Unit_Char_Search := 'b'; + goto Repeat_Search; + end if; + + -- Repeat entire search in No_File_Check mode if necessary + + end loop; + + -- Something is wrong if search fails completely, since the + -- default entries should catch all possibilities at this stage. + + raise Program_Error; + end; + end Get_File_Name; + + -------------------- + -- Get_Unit_Index -- + -------------------- + + function Get_Unit_Index (Uname : Unit_Name_Type) return Nat is + N : constant Int := SFN_HTable.Get (Uname); + begin + if N /= No_Entry then + return SFN_Table.Table (N).Index; + else + return 0; + end if; + end Get_Unit_Index; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + SFN_Table.Init; + SFN_Patterns.Init; + + -- Add default entries to SFN_Patterns.Table to represent the + -- standard default GNAT rules for file name translation. + + SFN_Patterns.Append (New_Val => + (Pat => new String'("*.ads"), + Typ => 's', + Dot => new String'("-"), + Cas => All_Lower_Case)); + + SFN_Patterns.Append (New_Val => + (Pat => new String'("*.adb"), + Typ => 'b', + Dot => new String'("-"), + Cas => All_Lower_Case)); + end Initialize; + + ---------- + -- Lock -- + ---------- + + procedure Lock is + begin + SFN_Table.Locked := True; + SFN_Table.Release; + end Lock; + + ------------------- + -- Set_File_Name -- + ------------------- + + procedure Set_File_Name + (U : Unit_Name_Type; + F : File_Name_Type; + Index : Nat) + is + begin + SFN_Table.Increment_Last; + SFN_Table.Table (SFN_Table.Last) := (U, F, Index); + SFN_HTable.Set (U, SFN_Table.Last); + end Set_File_Name; + + --------------------------- + -- Set_File_Name_Pattern -- + --------------------------- + + procedure Set_File_Name_Pattern + (Pat : String_Ptr; + Typ : Character; + Dot : String_Ptr; + Cas : Casing_Type) + is + L : constant Nat := SFN_Patterns.Last; + + begin + SFN_Patterns.Increment_Last; + + -- Move up the last two entries (the default ones) and then + -- put the new entry into the table just before them (we + -- always have the default entries be the last ones). + + SFN_Patterns.Table (L + 1) := SFN_Patterns.Table (L); + SFN_Patterns.Table (L) := SFN_Patterns.Table (L - 1); + SFN_Patterns.Table (L - 1) := (Pat, Typ, Dot, Cas); + end Set_File_Name_Pattern; + + -------------- + -- SFN_Hash -- + -------------- + + function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num is + begin + return SFN_Header_Num (Int (F) rem SFN_Header_Num'Range_Length); + end SFN_Hash; + +begin + + -- We call the initialization routine from the package body, so that + -- Fname.Init only needs to be called explicitly to reinitialize. + + Fname.UF.Initialize; +end Fname.UF; diff --git a/gcc/ada/fname-uf.ads b/gcc/ada/fname-uf.ads new file mode 100644 index 000000000..7f7e37bf8 --- /dev/null +++ b/gcc/ada/fname-uf.ads @@ -0,0 +1,114 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F N A M E . U F -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This child package contains the routines to translate a unit name to +-- a file name taking into account Source_File_Name pragmas. It also +-- contains the auxiliary routines used to record data from the pragmas. + +-- Note: the reason we split this into a child unit is that the routines +-- for unit name translation have a significant number of additional +-- dependencies, including osint, and hence sdefault. There are a number +-- of tools that use utility subprograms in the Fname parent, but do not +-- need the functionality in this child package (and certainly do not want +-- to deal with the extra dependencies). + +with Casing; use Casing; +with Types; use Types; + +package Fname.UF is + + ----------------- + -- Subprograms -- + ----------------- + + type Expected_Unit_Type is (Expect_Body, Expect_Spec, Unknown); + -- Return value from Get_Expected_Unit_Type + + function Get_Expected_Unit_Type + (Fname : File_Name_Type) return Expected_Unit_Type; + -- If possible, determine whether the given file name corresponds to a unit + -- that is a spec or body (e.g. by examining the extension). If this cannot + -- be determined with the file naming conventions in use, then the returned + -- value is set to Unknown. + + function Get_File_Name + (Uname : Unit_Name_Type; + Subunit : Boolean; + May_Fail : Boolean := False) return File_Name_Type; + -- This function returns the file name that corresponds to a given unit + -- name, Uname. The Subunit parameter is set True for subunits, and false + -- for all other kinds of units. The caller must ensure that the unit name + -- meets the requirements given in package Uname. + -- + -- When May_Fail is True, if the file cannot be found, this function + -- returns No_File. When it is False, if the file cannot be found, + -- a file name compatible with one pattern Source_File_Name pragma is + -- returned. + + function Get_Unit_Index (Uname : Unit_Name_Type) return Nat; + -- If there is a specific Source_File_Name pragma for this unit, then + -- return the corresponding unit index value. Return 0 if no index given. + + procedure Initialize; + -- Initialize internal tables. This is called automatically when the + -- package body is elaborated, so an explicit call to Initialize is + -- only required if it is necessary to reinitialize the source file + -- name pragma tables. + + procedure Lock; + -- Lock tables before calling back end + + function File_Name_Of_Spec (Name : Name_Id) return File_Name_Type; + -- Returns the file name that corresponds to the spec of a given unit + -- name. The unit name here is not encoded as a Unit_Name_Type, but is + -- rather just a normal form name in lower case, e.g. "xyz.def". + + function File_Name_Of_Body (Name : Name_Id) return File_Name_Type; + -- Returns the file name that corresponds to the body of a given unit + -- name. The unit name here is not encoded as a Unit_Name_Type, but is + -- rather just a normal form name in lower case, e.g. "xyz.def". + + procedure Set_File_Name + (U : Unit_Name_Type; + F : File_Name_Type; + Index : Nat); + -- Make association between given unit name, U, and the given file name, + -- F. This is the routine called to process a Source_File_Name pragma. + -- Index is the value from the index parameter of the pragma if present + -- and zero if no index parameter is present. + + procedure Set_File_Name_Pattern + (Pat : String_Ptr; + Typ : Character; + Dot : String_Ptr; + Cas : Casing_Type); + -- This is called to process a Source_File_Name pragma whose first + -- argument is a file name pattern string. Pat is this pattern string, + -- which contains an asterisk to correspond to the unit. Typ is one of + -- 'b'/'s'/'u' for body/spec/subunit, Dot is the separator string + -- for child/subunit names, and Cas is one of Lower/Upper/Mixed + -- indicating the required case for the file name. + +end Fname.UF; diff --git a/gcc/ada/fname.adb b/gcc/ada/fname.adb new file mode 100644 index 000000000..48cb20705 --- /dev/null +++ b/gcc/ada/fname.adb @@ -0,0 +1,204 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F N A M 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 Alloc; +with Hostparm; use Hostparm; +with Table; +with Types; use Types; + +package body Fname is + + ----------------------------- + -- Dummy Table Definitions -- + ----------------------------- + + -- The following table was used in old versions of the compiler. We retain + -- the declarations here for compatibility with old tree files. The new + -- version of the compiler does not use this table, and will write out a + -- dummy empty table for Tree_Write. + + type SFN_Entry is record + U : Unit_Name_Type; + F : File_Name_Type; + end record; + + package SFN_Table is new Table.Table ( + Table_Component_Type => SFN_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.SFN_Table_Initial, + Table_Increment => Alloc.SFN_Table_Increment, + Table_Name => "Fname_Dummy_Table"); + + --------------------------- + -- Is_Internal_File_Name -- + --------------------------- + + function Is_Internal_File_Name + (Fname : File_Name_Type; + Renamings_Included : Boolean := True) return Boolean + is + begin + if Is_Predefined_File_Name (Fname, Renamings_Included) then + return True; + + -- Once Is_Predefined_File_Name has been called and returns False, + -- Name_Buffer contains Fname and Name_Len is set to 8. + + elsif Name_Buffer (1 .. 2) = "g-" + or else Name_Buffer (1 .. 8) = "gnat " + then + return True; + + elsif OpenVMS + and then + (Name_Buffer (1 .. 4) = "dec-" + or else Name_Buffer (1 .. 8) = "dec ") + then + return True; + + else + return False; + end if; + end Is_Internal_File_Name; + + ----------------------------- + -- Is_Predefined_File_Name -- + ----------------------------- + + -- This should really be a test of unit name, given the possibility of + -- pragma Source_File_Name setting arbitrary file names for any files??? + + -- Once Is_Predefined_File_Name has been called and returns False, + -- Name_Buffer contains Fname and Name_Len is set to 8. This is used + -- only by Is_Internal_File_Name, and is not part of the official + -- external interface of this function. + + function Is_Predefined_File_Name + (Fname : File_Name_Type; + Renamings_Included : Boolean := True) return Boolean + is + begin + Get_Name_String (Fname); + return Is_Predefined_File_Name (Renamings_Included); + end Is_Predefined_File_Name; + + function Is_Predefined_File_Name + (Renamings_Included : Boolean := True) return Boolean + is + subtype Str8 is String (1 .. 8); + + Predef_Names : constant array (1 .. 11) of Str8 := + ("ada ", -- Ada + "interfac", -- Interfaces + "system ", -- System + + -- Remaining entries are only considered if Renamings_Included true + + "calendar", -- Calendar + "machcode", -- Machine_Code + "unchconv", -- Unchecked_Conversion + "unchdeal", -- Unchecked_Deallocation + "directio", -- Direct_IO + "ioexcept", -- IO_Exceptions + "sequenio", -- Sequential_IO + "text_io "); -- Text_IO + + Num_Entries : constant Natural := + 3 + 8 * Boolean'Pos (Renamings_Included); + + begin + -- Remove extension (if present) + + if Name_Len > 4 and then Name_Buffer (Name_Len - 3) = '.' then + Name_Len := Name_Len - 4; + end if; + + -- Definitely false if longer than 12 characters (8.3) + + if Name_Len > 8 then + return False; + + -- Definitely predefined if prefix is a- i- or s- followed by letter + + elsif Name_Len >= 3 + and then Name_Buffer (2) = '-' + and then (Name_Buffer (1) = 'a' + or else + Name_Buffer (1) = 'i' + or else + Name_Buffer (1) = 's') + and then (Name_Buffer (3) in 'a' .. 'z' + or else + Name_Buffer (3) in 'A' .. 'Z') + then + return True; + end if; + + -- Otherwise check against special list, first padding to 8 characters + + while Name_Len < 8 loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ' '; + end loop; + + for J in 1 .. Num_Entries loop + if Name_Buffer (1 .. 8) = Predef_Names (J) then + return True; + end if; + end loop; + + -- Note: when we return False here, the Name_Buffer contains the + -- padded file name. This is not defined for clients of the package, + -- but is used by Is_Internal_File_Name. + + return False; + end Is_Predefined_File_Name; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + begin + SFN_Table.Tree_Read; + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + begin + SFN_Table.Tree_Write; + end Tree_Write; + +end Fname; diff --git a/gcc/ada/fname.ads b/gcc/ada/fname.ads new file mode 100644 index 000000000..74523c098 --- /dev/null +++ b/gcc/ada/fname.ads @@ -0,0 +1,99 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F N A M E -- +-- -- +-- 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, together with its child package Fname.UF define the +-- association between source file names and unit names as defined +-- (see package Uname for definition of format of unit names). + +with Namet; use Namet; + +package Fname is + + -- Note: this package spec does not depend on the Uname spec in the Ada + -- sense, but the comments and description of the semantics do depend on + -- the conventions established by Uname. + + --------------------------- + -- File Name Conventions -- + --------------------------- + + -- GNAT requires that there be a one to one correspondence between source + -- file names (as used in the Osint package interface) and unit names as + -- defined by the Uname package. This correspondence is defined by the + -- two subprograms defined here in the Fname package. + + -- For full rules of file naming, see GNAT User's Guide. Note that the + -- naming rules are affected by the presence of Source_File_Name pragmas + -- that have been previously processed. + + -- Note that the file name does *not* include the directory name. The + -- management of directories is provided by Osint, and full file names + -- are used only for error message purposes within GNAT itself. + + ----------------- + -- Subprograms -- + ----------------- + + function Is_Predefined_File_Name + (Fname : File_Name_Type; + Renamings_Included : Boolean := True) return Boolean; + -- This function determines if the given file name (which must be a simple + -- file name with no directory information) is the file name for one of the + -- predefined library units (i.e. part of the Ada, System, or Interface + -- hierarchies). Note that units in the GNAT hierarchy are not considered + -- predefined (see Is_Internal_File_Name below). On return, Name_Buffer + -- contains the file name. The Renamings_Included parameter indicates + -- whether annex J renamings such as Text_IO are to be considered as + -- predefined. If Renamings_Included is True, then Text_IO will return + -- True, otherwise only children of Ada, Interfaces and System return True. + + function Is_Predefined_File_Name + (Renamings_Included : Boolean := True) return Boolean; + -- This version is called with the file name already in Name_Buffer + + function Is_Internal_File_Name + (Fname : File_Name_Type; + Renamings_Included : Boolean := True) return Boolean; + -- Similar to Is_Predefined_File_Name. The internal file set is a superset + -- of the predefined file set including children of GNAT, and also children + -- of DEC for the VMS case. + + procedure Tree_Read; + -- Dummy procedure (reads dummy table values from tree file) + + procedure Tree_Write; + -- Writes out internal tables to current tree file using Tree_Write + -- This is actually a dummy routine, since the relevant table is + -- no longer used, but we retain it for now, to avoid a tree file + -- incompatibility with the 3.13 compiler. Should be removed for + -- the 3.14a release ??? + +end Fname; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb new file mode 100644 index 000000000..9ef3a55a5 --- /dev/null +++ b/gcc/ada/freeze.adb @@ -0,0 +1,5889 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F R E E Z E -- +-- -- +-- 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. -- +-- -- +-- You should have received a copy of the GNU General Public License along -- +-- with this program; see file COPYING3. If not see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Ch3; use Exp_Ch3; +with Exp_Ch7; use Exp_Ch7; +with Exp_Disp; use Exp_Disp; +with Exp_Pakd; use Exp_Pakd; +with Exp_Util; use Exp_Util; +with Exp_Tss; use Exp_Tss; +with Layout; use Layout; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Cat; use Sem_Cat; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch7; use Sem_Ch7; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch13; use Sem_Ch13; +with Sem_Eval; use Sem_Eval; +with Sem_Mech; use Sem_Mech; +with Sem_Prag; use Sem_Prag; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package body Freeze is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Adjust_Esize_For_Alignment (Typ : Entity_Id); + -- Typ is a type that is being frozen. If no size clause is given, + -- but a default Esize has been computed, then this default Esize is + -- adjusted up if necessary to be consistent with a given alignment, + -- but never to a value greater than Long_Long_Integer'Size. This + -- is used for all discrete types and for fixed-point types. + + procedure Build_And_Analyze_Renamed_Body + (Decl : Node_Id; + New_S : Entity_Id; + After : in out Node_Id); + -- Build body for a renaming declaration, insert in tree and analyze + + procedure Check_Address_Clause (E : Entity_Id); + -- Apply legality checks to address clauses for object declarations, + -- at the point the object is frozen. + + procedure Check_Strict_Alignment (E : Entity_Id); + -- E is a base type. If E is tagged or has a component that is aliased + -- or tagged or contains something this is aliased or tagged, set + -- Strict_Alignment. + + procedure Check_Unsigned_Type (E : Entity_Id); + pragma Inline (Check_Unsigned_Type); + -- If E is a fixed-point or discrete type, then all the necessary work + -- to freeze it is completed except for possible setting of the flag + -- Is_Unsigned_Type, which is done by this procedure. The call has no + -- effect if the entity E is not a discrete or fixed-point type. + + procedure Freeze_And_Append + (Ent : Entity_Id; + N : Node_Id; + Result : in out List_Id); + -- Freezes Ent using Freeze_Entity, and appends the resulting list of + -- nodes to Result, modifying Result from No_List if necessary. N has + -- the same usage as in Freeze_Entity. + + procedure Freeze_Enumeration_Type (Typ : Entity_Id); + -- Freeze enumeration type. The Esize field is set as processing + -- proceeds (i.e. set by default when the type is declared and then + -- adjusted by rep clauses. What this procedure does is to make sure + -- that if a foreign convention is specified, and no specific size + -- is given, then the size must be at least Integer'Size. + + procedure Freeze_Static_Object (E : Entity_Id); + -- If an object is frozen which has Is_Statically_Allocated set, then + -- all referenced types must also be marked with this flag. This routine + -- is in charge of meeting this requirement for the object entity E. + + procedure Freeze_Subprogram (E : Entity_Id); + -- Perform freezing actions for a subprogram (create extra formals, + -- and set proper default mechanism values). Note that this routine + -- is not called for internal subprograms, for which neither of these + -- actions is needed (or desirable, we do not want for example to have + -- these extra formals present in initialization procedures, where they + -- would serve no purpose). In this call E is either a subprogram or + -- a subprogram type (i.e. an access to a subprogram). + + function Is_Fully_Defined (T : Entity_Id) return Boolean; + -- True if T is not private and has no private components, or has a full + -- view. Used to determine whether the designated type of an access type + -- should be frozen when the access type is frozen. This is done when an + -- allocator is frozen, or an expression that may involve attributes of + -- the designated type. Otherwise freezing the access type does not freeze + -- the designated type. + + procedure Process_Default_Expressions + (E : Entity_Id; + After : in out Node_Id); + -- This procedure is called for each subprogram to complete processing of + -- default expressions at the point where all types are known to be frozen. + -- The expressions must be analyzed in full, to make sure that all error + -- processing is done (they have only been pre-analyzed). If the expression + -- is not an entity or literal, its analysis may generate code which must + -- not be executed. In that case we build a function body to hold that + -- code. This wrapper function serves no other purpose (it used to be + -- called to evaluate the default, but now the default is inlined at each + -- point of call). + + procedure Set_Component_Alignment_If_Not_Set (Typ : Entity_Id); + -- Typ is a record or array type that is being frozen. This routine sets + -- the default component alignment from the scope stack values if the + -- alignment is otherwise not specified. + + procedure Check_Debug_Info_Needed (T : Entity_Id); + -- As each entity is frozen, this routine is called to deal with the + -- setting of Debug_Info_Needed for the entity. This flag is set if + -- the entity comes from source, or if we are in Debug_Generated_Code + -- mode or if the -gnatdV debug flag is set. However, it never sets + -- the flag if Debug_Info_Off is set. This procedure also ensures that + -- subsidiary entities have the flag set as required. + + procedure Undelay_Type (T : Entity_Id); + -- T is a type of a component that we know to be an Itype. We don't want + -- this to have a Freeze_Node, so ensure it doesn't. Do the same for any + -- Full_View or Corresponding_Record_Type. + + procedure Warn_Overlay + (Expr : Node_Id; + Typ : Entity_Id; + Nam : Node_Id); + -- Expr is the expression for an address clause for entity Nam whose type + -- is Typ. If Typ has a default initialization, and there is no explicit + -- initialization in the source declaration, check whether the address + -- clause might cause overlaying of an entity, and emit a warning on the + -- side effect that the initialization will cause. + + ------------------------------- + -- Adjust_Esize_For_Alignment -- + ------------------------------- + + procedure Adjust_Esize_For_Alignment (Typ : Entity_Id) is + Align : Uint; + + begin + if Known_Esize (Typ) and then Known_Alignment (Typ) then + Align := Alignment_In_Bits (Typ); + + if Align > Esize (Typ) + and then Align <= Standard_Long_Long_Integer_Size + then + Set_Esize (Typ, Align); + end if; + end if; + end Adjust_Esize_For_Alignment; + + ------------------------------------ + -- Build_And_Analyze_Renamed_Body -- + ------------------------------------ + + procedure Build_And_Analyze_Renamed_Body + (Decl : Node_Id; + New_S : Entity_Id; + After : in out Node_Id) + is + Body_Decl : constant Node_Id := Unit_Declaration_Node (New_S); + Ent : constant Entity_Id := Defining_Entity (Decl); + Body_Node : Node_Id; + Renamed_Subp : Entity_Id; + + begin + -- If the renamed subprogram is intrinsic, there is no need for a + -- wrapper body: we set the alias that will be called and expanded which + -- completes the declaration. This transformation is only legal if the + -- renamed entity has already been elaborated. + + -- Note that it is legal for a renaming_as_body to rename an intrinsic + -- subprogram, as long as the renaming occurs before the new entity + -- is frozen. See RM 8.5.4 (5). + + if Nkind (Body_Decl) = N_Subprogram_Renaming_Declaration + and then Is_Entity_Name (Name (Body_Decl)) + then + Renamed_Subp := Entity (Name (Body_Decl)); + else + Renamed_Subp := Empty; + end if; + + if Present (Renamed_Subp) + and then Is_Intrinsic_Subprogram (Renamed_Subp) + and then + (not In_Same_Source_Unit (Renamed_Subp, Ent) + or else Sloc (Renamed_Subp) < Sloc (Ent)) + + -- We can make the renaming entity intrinsic if the renamed function + -- has an interface name, or if it is one of the shift/rotate + -- operations known to the compiler. + + and then (Present (Interface_Name (Renamed_Subp)) + or else Chars (Renamed_Subp) = Name_Rotate_Left + or else Chars (Renamed_Subp) = Name_Rotate_Right + or else Chars (Renamed_Subp) = Name_Shift_Left + or else Chars (Renamed_Subp) = Name_Shift_Right + or else Chars (Renamed_Subp) = Name_Shift_Right_Arithmetic) + then + Set_Interface_Name (Ent, Interface_Name (Renamed_Subp)); + + if Present (Alias (Renamed_Subp)) then + Set_Alias (Ent, Alias (Renamed_Subp)); + else + Set_Alias (Ent, Renamed_Subp); + end if; + + Set_Is_Intrinsic_Subprogram (Ent); + Set_Has_Completion (Ent); + + else + Body_Node := Build_Renamed_Body (Decl, New_S); + Insert_After (After, Body_Node); + Mark_Rewrite_Insertion (Body_Node); + Analyze (Body_Node); + After := Body_Node; + end if; + end Build_And_Analyze_Renamed_Body; + + ------------------------ + -- Build_Renamed_Body -- + ------------------------ + + function Build_Renamed_Body + (Decl : Node_Id; + New_S : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (New_S); + -- We use for the source location of the renamed body, the location of + -- the spec entity. It might seem more natural to use the location of + -- the renaming declaration itself, but that would be wrong, since then + -- the body we create would look as though it was created far too late, + -- and this could cause problems with elaboration order analysis, + -- particularly in connection with instantiations. + + N : constant Node_Id := Unit_Declaration_Node (New_S); + Nam : constant Node_Id := Name (N); + Old_S : Entity_Id; + Spec : constant Node_Id := New_Copy_Tree (Specification (Decl)); + Actuals : List_Id := No_List; + Call_Node : Node_Id; + Call_Name : Node_Id; + Body_Node : Node_Id; + Formal : Entity_Id; + O_Formal : Entity_Id; + Param_Spec : Node_Id; + + Pref : Node_Id := Empty; + -- If the renamed entity is a primitive operation given in prefix form, + -- the prefix is the target object and it has to be added as the first + -- actual in the generated call. + + begin + -- Determine the entity being renamed, which is the target of the call + -- statement. If the name is an explicit dereference, this is a renaming + -- of a subprogram type rather than a subprogram. The name itself is + -- fully analyzed. + + if Nkind (Nam) = N_Selected_Component then + Old_S := Entity (Selector_Name (Nam)); + + elsif Nkind (Nam) = N_Explicit_Dereference then + Old_S := Etype (Nam); + + elsif Nkind (Nam) = N_Indexed_Component then + if Is_Entity_Name (Prefix (Nam)) then + Old_S := Entity (Prefix (Nam)); + else + Old_S := Entity (Selector_Name (Prefix (Nam))); + end if; + + elsif Nkind (Nam) = N_Character_Literal then + Old_S := Etype (New_S); + + else + Old_S := Entity (Nam); + end if; + + if Is_Entity_Name (Nam) then + + -- If the renamed entity is a predefined operator, retain full name + -- to ensure its visibility. + + if Ekind (Old_S) = E_Operator + and then Nkind (Nam) = N_Expanded_Name + then + Call_Name := New_Copy (Name (N)); + else + Call_Name := New_Reference_To (Old_S, Loc); + end if; + + else + if Nkind (Nam) = N_Selected_Component + and then Present (First_Formal (Old_S)) + and then + (Is_Controlling_Formal (First_Formal (Old_S)) + or else Is_Class_Wide_Type (Etype (First_Formal (Old_S)))) + then + + -- Retrieve the target object, to be added as a first actual + -- in the call. + + Call_Name := New_Occurrence_Of (Old_S, Loc); + Pref := Prefix (Nam); + + else + Call_Name := New_Copy (Name (N)); + end if; + + -- Original name may have been overloaded, but is fully resolved now + + Set_Is_Overloaded (Call_Name, False); + end if; + + -- For simple renamings, subsequent calls can be expanded directly as + -- calls to the renamed entity. The body must be generated in any case + -- for calls that may appear elsewhere. + + if Ekind_In (Old_S, E_Function, E_Procedure) + and then Nkind (Decl) = N_Subprogram_Declaration + then + Set_Body_To_Inline (Decl, Old_S); + end if; + + -- The body generated for this renaming is an internal artifact, and + -- does not constitute a freeze point for the called entity. + + Set_Must_Not_Freeze (Call_Name); + + Formal := First_Formal (Defining_Entity (Decl)); + + if Present (Pref) then + declare + Pref_Type : constant Entity_Id := Etype (Pref); + Form_Type : constant Entity_Id := Etype (First_Formal (Old_S)); + + begin + -- The controlling formal may be an access parameter, or the + -- actual may be an access value, so adjust accordingly. + + if Is_Access_Type (Pref_Type) + and then not Is_Access_Type (Form_Type) + then + Actuals := New_List + (Make_Explicit_Dereference (Loc, Relocate_Node (Pref))); + + elsif Is_Access_Type (Form_Type) + and then not Is_Access_Type (Pref) + then + Actuals := New_List + (Make_Attribute_Reference (Loc, + Attribute_Name => Name_Access, + Prefix => Relocate_Node (Pref))); + else + Actuals := New_List (Pref); + end if; + end; + + elsif Present (Formal) then + Actuals := New_List; + + else + Actuals := No_List; + end if; + + if Present (Formal) then + while Present (Formal) loop + Append (New_Reference_To (Formal, Loc), Actuals); + Next_Formal (Formal); + end loop; + end if; + + -- If the renamed entity is an entry, inherit its profile. For other + -- renamings as bodies, both profiles must be subtype conformant, so it + -- is not necessary to replace the profile given in the declaration. + -- However, default values that are aggregates are rewritten when + -- partially analyzed, so we recover the original aggregate to insure + -- that subsequent conformity checking works. Similarly, if the default + -- expression was constant-folded, recover the original expression. + + Formal := First_Formal (Defining_Entity (Decl)); + + if Present (Formal) then + O_Formal := First_Formal (Old_S); + Param_Spec := First (Parameter_Specifications (Spec)); + while Present (Formal) loop + if Is_Entry (Old_S) then + if Nkind (Parameter_Type (Param_Spec)) /= + N_Access_Definition + then + Set_Etype (Formal, Etype (O_Formal)); + Set_Entity (Parameter_Type (Param_Spec), Etype (O_Formal)); + end if; + + elsif Nkind (Default_Value (O_Formal)) = N_Aggregate + or else Nkind (Original_Node (Default_Value (O_Formal))) /= + Nkind (Default_Value (O_Formal)) + then + Set_Expression (Param_Spec, + New_Copy_Tree (Original_Node (Default_Value (O_Formal)))); + end if; + + Next_Formal (Formal); + Next_Formal (O_Formal); + Next (Param_Spec); + end loop; + end if; + + -- If the renamed entity is a function, the generated body contains a + -- return statement. Otherwise, build a procedure call. If the entity is + -- an entry, subsequent analysis of the call will transform it into the + -- proper entry or protected operation call. If the renamed entity is + -- a character literal, return it directly. + + if Ekind (Old_S) = E_Function + or else Ekind (Old_S) = E_Operator + or else (Ekind (Old_S) = E_Subprogram_Type + and then Etype (Old_S) /= Standard_Void_Type) + then + Call_Node := + Make_Simple_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => Call_Name, + Parameter_Associations => Actuals)); + + elsif Ekind (Old_S) = E_Enumeration_Literal then + Call_Node := + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Old_S, Loc)); + + elsif Nkind (Nam) = N_Character_Literal then + Call_Node := + Make_Simple_Return_Statement (Loc, + Expression => Call_Name); + + else + Call_Node := + Make_Procedure_Call_Statement (Loc, + Name => Call_Name, + Parameter_Associations => Actuals); + end if; + + -- Create entities for subprogram body and formals + + Set_Defining_Unit_Name (Spec, + Make_Defining_Identifier (Loc, Chars => Chars (New_S))); + + Param_Spec := First (Parameter_Specifications (Spec)); + while Present (Param_Spec) loop + Set_Defining_Identifier (Param_Spec, + Make_Defining_Identifier (Loc, + Chars => Chars (Defining_Identifier (Param_Spec)))); + Next (Param_Spec); + end loop; + + Body_Node := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Call_Node))); + + if Nkind (Decl) /= N_Subprogram_Declaration then + Rewrite (N, + Make_Subprogram_Declaration (Loc, + Specification => Specification (N))); + end if; + + -- Link the body to the entity whose declaration it completes. If + -- the body is analyzed when the renamed entity is frozen, it may + -- be necessary to restore the proper scope (see package Exp_Ch13). + + if Nkind (N) = N_Subprogram_Renaming_Declaration + and then Present (Corresponding_Spec (N)) + then + Set_Corresponding_Spec (Body_Node, Corresponding_Spec (N)); + else + Set_Corresponding_Spec (Body_Node, New_S); + end if; + + return Body_Node; + end Build_Renamed_Body; + + -------------------------- + -- Check_Address_Clause -- + -------------------------- + + procedure Check_Address_Clause (E : Entity_Id) is + Addr : constant Node_Id := Address_Clause (E); + Expr : Node_Id; + Decl : constant Node_Id := Declaration_Node (E); + Typ : constant Entity_Id := Etype (E); + + begin + if Present (Addr) then + Expr := Expression (Addr); + + if Needs_Constant_Address (Decl, Typ) then + Check_Constant_Address_Clause (Expr, E); + + -- Has_Delayed_Freeze was set on E when the address clause was + -- analyzed. Reset the flag now unless freeze actions were + -- attached to it in the mean time. + + if No (Freeze_Node (E)) then + Set_Has_Delayed_Freeze (E, False); + end if; + end if; + + -- If Rep_Clauses are to be ignored, remove address clause from + -- list attached to entity, because it may be illegal for gigi, + -- for example by breaking order of elaboration.. + + if Ignore_Rep_Clauses then + declare + Rep : Node_Id; + + begin + Rep := First_Rep_Item (E); + + if Rep = Addr then + Set_First_Rep_Item (E, Next_Rep_Item (Addr)); + + else + while Present (Rep) + and then Next_Rep_Item (Rep) /= Addr + loop + Rep := Next_Rep_Item (Rep); + end loop; + end if; + + if Present (Rep) then + Set_Next_Rep_Item (Rep, Next_Rep_Item (Addr)); + end if; + end; + + Rewrite (Addr, Make_Null_Statement (Sloc (E))); + + elsif not Error_Posted (Expr) + and then not Needs_Finalization (Typ) + then + Warn_Overlay (Expr, Typ, Name (Addr)); + end if; + end if; + end Check_Address_Clause; + + ----------------------------- + -- Check_Compile_Time_Size -- + ----------------------------- + + procedure Check_Compile_Time_Size (T : Entity_Id) is + + procedure Set_Small_Size (T : Entity_Id; S : Uint); + -- Sets the compile time known size (32 bits or less) in the Esize + -- field, of T checking for a size clause that was given which attempts + -- to give a smaller size, and also checking for an alignment clause. + + function Size_Known (T : Entity_Id) return Boolean; + -- Recursive function that does all the work + + function Static_Discriminated_Components (T : Entity_Id) return Boolean; + -- If T is a constrained subtype, its size is not known if any of its + -- discriminant constraints is not static and it is not a null record. + -- The test is conservative and doesn't check that the components are + -- in fact constrained by non-static discriminant values. Could be made + -- more precise ??? + + -------------------- + -- Set_Small_Size -- + -------------------- + + procedure Set_Small_Size (T : Entity_Id; S : Uint) is + begin + if S > 32 then + return; + + -- Don't bother if alignment clause with a value other than 1 is + -- present, because size may be padded up to meet back end alignment + -- requirements, and only the back end knows the rules! + + elsif Known_Alignment (T) and then Alignment (T) /= 1 then + return; + + -- Check for bad size clause given + + elsif Has_Size_Clause (T) then + if RM_Size (T) < S then + Error_Msg_Uint_1 := S; + Error_Msg_NE + ("size for& too small, minimum allowed is ^", + Size_Clause (T), T); + + elsif Unknown_Esize (T) then + Set_Esize (T, S); + end if; + + -- Set sizes if not set already + + else + if Unknown_Esize (T) then + Set_Esize (T, S); + end if; + + if Unknown_RM_Size (T) then + Set_RM_Size (T, S); + end if; + end if; + end Set_Small_Size; + + ---------------- + -- Size_Known -- + ---------------- + + function Size_Known (T : Entity_Id) return Boolean is + Index : Entity_Id; + Comp : Entity_Id; + Ctyp : Entity_Id; + Low : Node_Id; + High : Node_Id; + + begin + if Size_Known_At_Compile_Time (T) then + return True; + + -- Always True for scalar types. This is true even for generic formal + -- scalar types. We used to return False in the latter case, but the + -- size is known at compile time, even in the template, we just do + -- not know the exact size but that's not the point of this routine. + + elsif Is_Scalar_Type (T) + or else Is_Task_Type (T) + then + return True; + + -- Array types + + elsif Is_Array_Type (T) then + + -- String literals always have known size, and we can set it + + if Ekind (T) = E_String_Literal_Subtype then + Set_Small_Size (T, Component_Size (T) + * String_Literal_Length (T)); + return True; + + -- Unconstrained types never have known at compile time size + + elsif not Is_Constrained (T) then + return False; + + -- Don't do any recursion on type with error posted, since we may + -- have a malformed type that leads us into a loop. + + elsif Error_Posted (T) then + return False; + + -- Otherwise if component size unknown, then array size unknown + + elsif not Size_Known (Component_Type (T)) then + return False; + end if; + + -- Check for all indexes static, and also compute possible size + -- (in case it is less than 32 and may be packable). + + declare + Esiz : Uint := Component_Size (T); + Dim : Uint; + + begin + Index := First_Index (T); + while Present (Index) loop + if Nkind (Index) = N_Range then + Get_Index_Bounds (Index, Low, High); + + elsif Error_Posted (Scalar_Range (Etype (Index))) then + return False; + + else + Low := Type_Low_Bound (Etype (Index)); + High := Type_High_Bound (Etype (Index)); + end if; + + if not Compile_Time_Known_Value (Low) + or else not Compile_Time_Known_Value (High) + or else Etype (Index) = Any_Type + then + return False; + + else + Dim := Expr_Value (High) - Expr_Value (Low) + 1; + + if Dim >= 0 then + Esiz := Esiz * Dim; + else + Esiz := Uint_0; + end if; + end if; + + Next_Index (Index); + end loop; + + Set_Small_Size (T, Esiz); + return True; + end; + + -- Access types always have known at compile time sizes + + elsif Is_Access_Type (T) then + return True; + + -- For non-generic private types, go to underlying type if present + + elsif Is_Private_Type (T) + and then not Is_Generic_Type (T) + and then Present (Underlying_Type (T)) + then + -- Don't do any recursion on type with error posted, since we may + -- have a malformed type that leads us into a loop. + + if Error_Posted (T) then + return False; + else + return Size_Known (Underlying_Type (T)); + end if; + + -- Record types + + elsif Is_Record_Type (T) then + + -- A class-wide type is never considered to have a known size + + if Is_Class_Wide_Type (T) then + return False; + + -- A subtype of a variant record must not have non-static + -- discriminated components. + + elsif T /= Base_Type (T) + and then not Static_Discriminated_Components (T) + then + return False; + + -- Don't do any recursion on type with error posted, since we may + -- have a malformed type that leads us into a loop. + + elsif Error_Posted (T) then + return False; + end if; + + -- Now look at the components of the record + + declare + -- The following two variables are used to keep track of the + -- size of packed records if we can tell the size of the packed + -- record in the front end. Packed_Size_Known is True if so far + -- we can figure out the size. It is initialized to True for a + -- packed record, unless the record has discriminants. The + -- reason we eliminate the discriminated case is that we don't + -- know the way the back end lays out discriminated packed + -- records. If Packed_Size_Known is True, then Packed_Size is + -- the size in bits so far. + + Packed_Size_Known : Boolean := + Is_Packed (T) + and then not Has_Discriminants (T); + + Packed_Size : Uint := Uint_0; + + begin + -- Test for variant part present + + if Has_Discriminants (T) + and then Present (Parent (T)) + and then Nkind (Parent (T)) = N_Full_Type_Declaration + and then Nkind (Type_Definition (Parent (T))) = + N_Record_Definition + and then not Null_Present (Type_Definition (Parent (T))) + and then Present (Variant_Part + (Component_List (Type_Definition (Parent (T))))) + then + -- If variant part is present, and type is unconstrained, + -- then we must have defaulted discriminants, or a size + -- clause must be present for the type, or else the size + -- is definitely not known at compile time. + + if not Is_Constrained (T) + and then + No (Discriminant_Default_Value (First_Discriminant (T))) + and then Unknown_Esize (T) + then + return False; + end if; + end if; + + -- Loop through components + + Comp := First_Component_Or_Discriminant (T); + while Present (Comp) loop + Ctyp := Etype (Comp); + + -- We do not know the packed size if there is a component + -- clause present (we possibly could, but this would only + -- help in the case of a record with partial rep clauses. + -- That's because in the case of full rep clauses, the + -- size gets figured out anyway by a different circuit). + + if Present (Component_Clause (Comp)) then + Packed_Size_Known := False; + end if; + + -- We need to identify a component that is an array where + -- the index type is an enumeration type with non-standard + -- representation, and some bound of the type depends on a + -- discriminant. + + -- This is because gigi computes the size by doing a + -- substitution of the appropriate discriminant value in + -- the size expression for the base type, and gigi is not + -- clever enough to evaluate the resulting expression (which + -- involves a call to rep_to_pos) at compile time. + + -- It would be nice if gigi would either recognize that + -- this expression can be computed at compile time, or + -- alternatively figured out the size from the subtype + -- directly, where all the information is at hand ??? + + if Is_Array_Type (Etype (Comp)) + and then Present (Packed_Array_Type (Etype (Comp))) + then + declare + Ocomp : constant Entity_Id := + Original_Record_Component (Comp); + OCtyp : constant Entity_Id := Etype (Ocomp); + Ind : Node_Id; + Indtyp : Entity_Id; + Lo, Hi : Node_Id; + + begin + Ind := First_Index (OCtyp); + while Present (Ind) loop + Indtyp := Etype (Ind); + + if Is_Enumeration_Type (Indtyp) + and then Has_Non_Standard_Rep (Indtyp) + then + Lo := Type_Low_Bound (Indtyp); + Hi := Type_High_Bound (Indtyp); + + if Is_Entity_Name (Lo) + and then Ekind (Entity (Lo)) = E_Discriminant + then + return False; + + elsif Is_Entity_Name (Hi) + and then Ekind (Entity (Hi)) = E_Discriminant + then + return False; + end if; + end if; + + Next_Index (Ind); + end loop; + end; + end if; + + -- Clearly size of record is not known if the size of one of + -- the components is not known. + + if not Size_Known (Ctyp) then + return False; + end if; + + -- Accumulate packed size if possible + + if Packed_Size_Known then + + -- We can only deal with elementary types, since for + -- non-elementary components, alignment enters into the + -- picture, and we don't know enough to handle proper + -- alignment in this context. Packed arrays count as + -- elementary if the representation is a modular type. + + if Is_Elementary_Type (Ctyp) + or else (Is_Array_Type (Ctyp) + and then Present (Packed_Array_Type (Ctyp)) + and then Is_Modular_Integer_Type + (Packed_Array_Type (Ctyp))) + then + -- If RM_Size is known and static, then we can keep + -- accumulating the packed size. + + if Known_Static_RM_Size (Ctyp) then + + -- A little glitch, to be removed sometime ??? + -- gigi does not understand zero sizes yet. + + if RM_Size (Ctyp) = Uint_0 then + Packed_Size_Known := False; + + -- Normal case where we can keep accumulating the + -- packed array size. + + else + Packed_Size := Packed_Size + RM_Size (Ctyp); + end if; + + -- If we have a field whose RM_Size is not known then + -- we can't figure out the packed size here. + + else + Packed_Size_Known := False; + end if; + + -- If we have a non-elementary type we can't figure out + -- the packed array size (alignment issues). + + else + Packed_Size_Known := False; + end if; + end if; + + Next_Component_Or_Discriminant (Comp); + end loop; + + if Packed_Size_Known then + Set_Small_Size (T, Packed_Size); + end if; + + return True; + end; + + -- All other cases, size not known at compile time + + else + return False; + end if; + end Size_Known; + + ------------------------------------- + -- Static_Discriminated_Components -- + ------------------------------------- + + function Static_Discriminated_Components + (T : Entity_Id) return Boolean + is + Constraint : Elmt_Id; + + begin + if Has_Discriminants (T) + and then Present (Discriminant_Constraint (T)) + and then Present (First_Component (T)) + then + Constraint := First_Elmt (Discriminant_Constraint (T)); + while Present (Constraint) loop + if not Compile_Time_Known_Value (Node (Constraint)) then + return False; + end if; + + Next_Elmt (Constraint); + end loop; + end if; + + return True; + end Static_Discriminated_Components; + + -- Start of processing for Check_Compile_Time_Size + + begin + Set_Size_Known_At_Compile_Time (T, Size_Known (T)); + end Check_Compile_Time_Size; + + ----------------------------- + -- Check_Debug_Info_Needed -- + ----------------------------- + + procedure Check_Debug_Info_Needed (T : Entity_Id) is + begin + if Debug_Info_Off (T) then + return; + + elsif Comes_From_Source (T) + or else Debug_Generated_Code + or else Debug_Flag_VV + or else Needs_Debug_Info (T) + then + Set_Debug_Info_Needed (T); + end if; + end Check_Debug_Info_Needed; + + ---------------------------- + -- Check_Strict_Alignment -- + ---------------------------- + + procedure Check_Strict_Alignment (E : Entity_Id) is + Comp : Entity_Id; + + begin + if Is_Tagged_Type (E) or else Is_Concurrent_Type (E) then + Set_Strict_Alignment (E); + + elsif Is_Array_Type (E) then + Set_Strict_Alignment (E, Strict_Alignment (Component_Type (E))); + + elsif Is_Record_Type (E) then + if Is_Limited_Record (E) then + Set_Strict_Alignment (E); + return; + end if; + + Comp := First_Component (E); + while Present (Comp) loop + if not Is_Type (Comp) + and then (Strict_Alignment (Etype (Comp)) + or else Is_Aliased (Comp)) + then + Set_Strict_Alignment (E); + return; + end if; + + Next_Component (Comp); + end loop; + end if; + end Check_Strict_Alignment; + + ------------------------- + -- Check_Unsigned_Type -- + ------------------------- + + procedure Check_Unsigned_Type (E : Entity_Id) is + Ancestor : Entity_Id; + Lo_Bound : Node_Id; + Btyp : Entity_Id; + + begin + if not Is_Discrete_Or_Fixed_Point_Type (E) then + return; + end if; + + -- Do not attempt to analyze case where range was in error + + if No (Scalar_Range (E)) + or else Error_Posted (Scalar_Range (E)) + then + return; + end if; + + -- The situation that is non trivial is something like + + -- subtype x1 is integer range -10 .. +10; + -- subtype x2 is x1 range 0 .. V1; + -- subtype x3 is x2 range V2 .. V3; + -- subtype x4 is x3 range V4 .. V5; + + -- where Vn are variables. Here the base type is signed, but we still + -- know that x4 is unsigned because of the lower bound of x2. + + -- The only way to deal with this is to look up the ancestor chain + + Ancestor := E; + loop + if Ancestor = Any_Type or else Etype (Ancestor) = Any_Type then + return; + end if; + + Lo_Bound := Type_Low_Bound (Ancestor); + + if Compile_Time_Known_Value (Lo_Bound) then + + if Expr_Rep_Value (Lo_Bound) >= 0 then + Set_Is_Unsigned_Type (E, True); + end if; + + return; + + else + Ancestor := Ancestor_Subtype (Ancestor); + + -- If no ancestor had a static lower bound, go to base type + + if No (Ancestor) then + + -- Note: the reason we still check for a compile time known + -- value for the base type is that at least in the case of + -- generic formals, we can have bounds that fail this test, + -- and there may be other cases in error situations. + + Btyp := Base_Type (E); + + if Btyp = Any_Type or else Etype (Btyp) = Any_Type then + return; + end if; + + Lo_Bound := Type_Low_Bound (Base_Type (E)); + + if Compile_Time_Known_Value (Lo_Bound) + and then Expr_Rep_Value (Lo_Bound) >= 0 + then + Set_Is_Unsigned_Type (E, True); + end if; + + return; + end if; + end if; + end loop; + end Check_Unsigned_Type; + + ------------------------- + -- Is_Atomic_Aggregate -- + ------------------------- + + function Is_Atomic_Aggregate + (E : Entity_Id; + Typ : Entity_Id) return Boolean + is + Loc : constant Source_Ptr := Sloc (E); + New_N : Node_Id; + Par : Node_Id; + Temp : Entity_Id; + + begin + Par := Parent (E); + + -- Array may be qualified, so find outer context + + if Nkind (Par) = N_Qualified_Expression then + Par := Parent (Par); + end if; + + if Nkind_In (Par, N_Object_Declaration, N_Assignment_Statement) + and then Comes_From_Source (Par) + then + Temp := Make_Temporary (Loc, 'T', E); + New_N := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (E)); + Insert_Before (Par, New_N); + Analyze (New_N); + + Set_Expression (Par, New_Occurrence_Of (Temp, Loc)); + return True; + + else + return False; + end if; + end Is_Atomic_Aggregate; + + ---------------- + -- Freeze_All -- + ---------------- + + -- Note: the easy coding for this procedure would be to just build a + -- single list of freeze nodes and then insert them and analyze them + -- all at once. This won't work, because the analysis of earlier freeze + -- nodes may recursively freeze types which would otherwise appear later + -- on in the freeze list. So we must analyze and expand the freeze nodes + -- as they are generated. + + procedure Freeze_All (From : Entity_Id; After : in out Node_Id) is + E : Entity_Id; + Decl : Node_Id; + + procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id); + -- This is the internal recursive routine that does freezing of entities + -- (but NOT the analysis of default expressions, which should not be + -- recursive, we don't want to analyze those till we are sure that ALL + -- the types are frozen). + + -------------------- + -- Freeze_All_Ent -- + -------------------- + + procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id) is + E : Entity_Id; + Flist : List_Id; + Lastn : Node_Id; + + procedure Process_Flist; + -- If freeze nodes are present, insert and analyze, and reset cursor + -- for next insertion. + + ------------------- + -- Process_Flist -- + ------------------- + + procedure Process_Flist is + begin + if Is_Non_Empty_List (Flist) then + Lastn := Next (After); + Insert_List_After_And_Analyze (After, Flist); + + if Present (Lastn) then + After := Prev (Lastn); + else + After := Last (List_Containing (After)); + end if; + end if; + end Process_Flist; + + -- Start or processing for Freeze_All_Ent + + begin + E := From; + while Present (E) loop + + -- If the entity is an inner package which is not a package + -- renaming, then its entities must be frozen at this point. Note + -- that such entities do NOT get frozen at the end of the nested + -- package itself (only library packages freeze). + + -- Same is true for task declarations, where anonymous records + -- created for entry parameters must be frozen. + + if Ekind (E) = E_Package + and then No (Renamed_Object (E)) + and then not Is_Child_Unit (E) + and then not Is_Frozen (E) + then + Push_Scope (E); + Install_Visible_Declarations (E); + Install_Private_Declarations (E); + + Freeze_All (First_Entity (E), After); + + End_Package_Scope (E); + + elsif Ekind (E) in Task_Kind + and then + (Nkind (Parent (E)) = N_Task_Type_Declaration + or else + Nkind (Parent (E)) = N_Single_Task_Declaration) + then + Push_Scope (E); + Freeze_All (First_Entity (E), After); + End_Scope; + + -- For a derived tagged type, we must ensure that all the + -- primitive operations of the parent have been frozen, so that + -- their addresses will be in the parent's dispatch table at the + -- point it is inherited. + + elsif Ekind (E) = E_Record_Type + and then Is_Tagged_Type (E) + and then Is_Tagged_Type (Etype (E)) + and then Is_Derived_Type (E) + then + declare + Prim_List : constant Elist_Id := + Primitive_Operations (Etype (E)); + + Prim : Elmt_Id; + Subp : Entity_Id; + + begin + Prim := First_Elmt (Prim_List); + while Present (Prim) loop + Subp := Node (Prim); + + if Comes_From_Source (Subp) + and then not Is_Frozen (Subp) + then + Flist := Freeze_Entity (Subp, After); + Process_Flist; + end if; + + Next_Elmt (Prim); + end loop; + end; + end if; + + if not Is_Frozen (E) then + Flist := Freeze_Entity (E, After); + Process_Flist; + end if; + + -- If an incomplete type is still not frozen, this may be a + -- premature freezing because of a body declaration that follows. + -- Indicate where the freezing took place. + + -- If the freezing is caused by the end of the current declarative + -- part, it is a Taft Amendment type, and there is no error. + + if not Is_Frozen (E) + and then Ekind (E) = E_Incomplete_Type + then + declare + Bod : constant Node_Id := Next (After); + + begin + if (Nkind_In (Bod, N_Subprogram_Body, + N_Entry_Body, + N_Package_Body, + N_Protected_Body, + N_Task_Body) + or else Nkind (Bod) in N_Body_Stub) + and then + List_Containing (After) = List_Containing (Parent (E)) + then + Error_Msg_Sloc := Sloc (Next (After)); + Error_Msg_NE + ("type& is frozen# before its full declaration", + Parent (E), E); + end if; + end; + end if; + + Next_Entity (E); + end loop; + end Freeze_All_Ent; + + -- Start of processing for Freeze_All + + begin + Freeze_All_Ent (From, After); + + -- Now that all types are frozen, we can deal with default expressions + -- that require us to build a default expression functions. This is the + -- point at which such functions are constructed (after all types that + -- might be used in such expressions have been frozen). + + -- For subprograms that are renaming_as_body, we create the wrapper + -- bodies as needed. + + -- We also add finalization chains to access types whose designated + -- types are controlled. This is normally done when freezing the type, + -- but this misses recursive type definitions where the later members + -- of the recursion introduce controlled components. + + -- Loop through entities + + E := From; + while Present (E) loop + if Is_Subprogram (E) then + + if not Default_Expressions_Processed (E) then + Process_Default_Expressions (E, After); + end if; + + if not Has_Completion (E) then + Decl := Unit_Declaration_Node (E); + + if Nkind (Decl) = N_Subprogram_Renaming_Declaration then + Build_And_Analyze_Renamed_Body (Decl, E, After); + + elsif Nkind (Decl) = N_Subprogram_Declaration + and then Present (Corresponding_Body (Decl)) + and then + Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) + = N_Subprogram_Renaming_Declaration + then + Build_And_Analyze_Renamed_Body + (Decl, Corresponding_Body (Decl), After); + end if; + end if; + + elsif Ekind (E) in Task_Kind + and then + (Nkind (Parent (E)) = N_Task_Type_Declaration + or else + Nkind (Parent (E)) = N_Single_Task_Declaration) + then + declare + Ent : Entity_Id; + + begin + Ent := First_Entity (E); + while Present (Ent) loop + if Is_Entry (Ent) + and then not Default_Expressions_Processed (Ent) + then + Process_Default_Expressions (Ent, After); + end if; + + Next_Entity (Ent); + end loop; + end; + + elsif Is_Access_Type (E) + and then Comes_From_Source (E) + and then Ekind (Directly_Designated_Type (E)) = E_Incomplete_Type + and then Needs_Finalization (Designated_Type (E)) + and then No (Associated_Final_Chain (E)) + then + Build_Final_List (Parent (E), E); + end if; + + Next_Entity (E); + end loop; + end Freeze_All; + + ----------------------- + -- Freeze_And_Append -- + ----------------------- + + procedure Freeze_And_Append + (Ent : Entity_Id; + N : Node_Id; + Result : in out List_Id) + is + L : constant List_Id := Freeze_Entity (Ent, N); + begin + if Is_Non_Empty_List (L) then + if Result = No_List then + Result := L; + else + Append_List (L, Result); + end if; + end if; + end Freeze_And_Append; + + ------------------- + -- Freeze_Before -- + ------------------- + + procedure Freeze_Before (N : Node_Id; T : Entity_Id) is + Freeze_Nodes : constant List_Id := Freeze_Entity (T, N); + begin + if Is_Non_Empty_List (Freeze_Nodes) then + Insert_Actions (N, Freeze_Nodes); + end if; + end Freeze_Before; + + ------------------- + -- Freeze_Entity -- + ------------------- + + function Freeze_Entity (E : Entity_Id; N : Node_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (N); + Test_E : Entity_Id := E; + Comp : Entity_Id; + F_Node : Node_Id; + Result : List_Id; + Indx : Node_Id; + Formal : Entity_Id; + Atype : Entity_Id; + + Has_Default_Initialization : Boolean := False; + -- This flag gets set to true for a variable with default initialization + + procedure Check_Current_Instance (Comp_Decl : Node_Id); + -- Check that an Access or Unchecked_Access attribute with a prefix + -- which is the current instance type can only be applied when the type + -- is limited. + + procedure Check_Suspicious_Modulus (Utype : Entity_Id); + -- Give warning for modulus of 8, 16, 32, or 64 given as an explicit + -- integer literal without an explicit corresponding size clause. The + -- caller has checked that Utype is a modular integer type. + + function After_Last_Declaration return Boolean; + -- If Loc is a freeze_entity that appears after the last declaration + -- in the scope, inhibit error messages on late completion. + + procedure Freeze_Record_Type (Rec : Entity_Id); + -- Freeze each component, handle some representation clauses, and freeze + -- primitive operations if this is a tagged type. + + ---------------------------- + -- After_Last_Declaration -- + ---------------------------- + + function After_Last_Declaration return Boolean is + Spec : constant Node_Id := Parent (Current_Scope); + begin + if Nkind (Spec) = N_Package_Specification then + if Present (Private_Declarations (Spec)) then + return Loc >= Sloc (Last (Private_Declarations (Spec))); + elsif Present (Visible_Declarations (Spec)) then + return Loc >= Sloc (Last (Visible_Declarations (Spec))); + else + return False; + end if; + else + return False; + end if; + end After_Last_Declaration; + + ---------------------------- + -- Check_Current_Instance -- + ---------------------------- + + procedure Check_Current_Instance (Comp_Decl : Node_Id) is + + Rec_Type : constant Entity_Id := + Scope (Defining_Identifier (Comp_Decl)); + + Decl : constant Node_Id := Parent (Rec_Type); + + function Process (N : Node_Id) return Traverse_Result; + -- Process routine to apply check to given node + + ------------- + -- Process -- + ------------- + + function Process (N : Node_Id) return Traverse_Result is + begin + case Nkind (N) is + when N_Attribute_Reference => + if (Attribute_Name (N) = Name_Access + or else + Attribute_Name (N) = Name_Unchecked_Access) + and then Is_Entity_Name (Prefix (N)) + and then Is_Type (Entity (Prefix (N))) + and then Entity (Prefix (N)) = E + then + Error_Msg_N + ("current instance must be a limited type", Prefix (N)); + return Abandon; + else + return OK; + end if; + + when others => return OK; + end case; + end Process; + + procedure Traverse is new Traverse_Proc (Process); + + -- Start of processing for Check_Current_Instance + + begin + -- In Ada95, the (imprecise) rule is that the current instance of a + -- limited type is aliased. In Ada2005, limitedness must be explicit: + -- either a tagged type, or a limited record. + + if Is_Limited_Type (Rec_Type) + and then (Ada_Version < Ada_2005 or else Is_Tagged_Type (Rec_Type)) + then + return; + + elsif Nkind (Decl) = N_Full_Type_Declaration + and then Limited_Present (Type_Definition (Decl)) + then + return; + + else + Traverse (Comp_Decl); + end if; + end Check_Current_Instance; + + ------------------------------ + -- Check_Suspicious_Modulus -- + ------------------------------ + + procedure Check_Suspicious_Modulus (Utype : Entity_Id) is + Decl : constant Node_Id := Declaration_Node (Underlying_Type (Utype)); + + begin + if Nkind (Decl) = N_Full_Type_Declaration then + declare + Tdef : constant Node_Id := Type_Definition (Decl); + begin + if Nkind (Tdef) = N_Modular_Type_Definition then + declare + Modulus : constant Node_Id := + Original_Node (Expression (Tdef)); + begin + if Nkind (Modulus) = N_Integer_Literal then + declare + Modv : constant Uint := Intval (Modulus); + Sizv : constant Uint := RM_Size (Utype); + + begin + -- First case, modulus and size are the same. This + -- happens if you have something like mod 32, with + -- an explicit size of 32, this is for sure a case + -- where the warning is given, since it is seems + -- very unlikely that someone would want e.g. a + -- five bit type stored in 32 bits. It is much + -- more likely they wanted a 32-bit type. + + if Modv = Sizv then + null; + + -- Second case, the modulus is 32 or 64 and no + -- size clause is present. This is a less clear + -- case for giving the warning, but in the case + -- of 32/64 (5-bit or 6-bit types) these seem rare + -- enough that it is a likely error (and in any + -- case using 2**5 or 2**6 in these cases seems + -- clearer. We don't include 8 or 16 here, simply + -- because in practice 3-bit and 4-bit types are + -- more common and too many false positives if + -- we warn in these cases. + + elsif not Has_Size_Clause (Utype) + and then (Modv = Uint_32 or else Modv = Uint_64) + then + null; + + -- No warning needed + + else + return; + end if; + + -- If we fall through, give warning + + Error_Msg_Uint_1 := Modv; + Error_Msg_N + ("?2 '*'*^' may have been intended here", + Modulus); + end; + end if; + end; + end if; + end; + end if; + end Check_Suspicious_Modulus; + + ------------------------ + -- Freeze_Record_Type -- + ------------------------ + + procedure Freeze_Record_Type (Rec : Entity_Id) is + Comp : Entity_Id; + IR : Node_Id; + ADC : Node_Id; + Prev : Entity_Id; + + Junk : Boolean; + pragma Warnings (Off, Junk); + + Unplaced_Component : Boolean := False; + -- Set True if we find at least one component with no component + -- clause (used to warn about useless Pack pragmas). + + Placed_Component : Boolean := False; + -- Set True if we find at least one component with a component + -- clause (used to warn about useless Bit_Order pragmas, and also + -- to detect cases where Implicit_Packing may have an effect). + + All_Scalar_Components : Boolean := True; + -- Set False if we encounter a component of a non-scalar type + + Scalar_Component_Total_RM_Size : Uint := Uint_0; + Scalar_Component_Total_Esize : Uint := Uint_0; + -- Accumulates total RM_Size values and total Esize values of all + -- scalar components. Used for processing of Implicit_Packing. + + function Check_Allocator (N : Node_Id) return Node_Id; + -- If N is an allocator, possibly wrapped in one or more level of + -- qualified expression(s), return the inner allocator node, else + -- return Empty. + + procedure Check_Itype (Typ : Entity_Id); + -- If the component subtype is an access to a constrained subtype of + -- an already frozen type, make the subtype frozen as well. It might + -- otherwise be frozen in the wrong scope, and a freeze node on + -- subtype has no effect. Similarly, if the component subtype is a + -- regular (not protected) access to subprogram, set the anonymous + -- subprogram type to frozen as well, to prevent an out-of-scope + -- freeze node at some eventual point of call. Protected operations + -- are handled elsewhere. + + --------------------- + -- Check_Allocator -- + --------------------- + + function Check_Allocator (N : Node_Id) return Node_Id is + Inner : Node_Id; + begin + Inner := N; + loop + if Nkind (Inner) = N_Allocator then + return Inner; + elsif Nkind (Inner) = N_Qualified_Expression then + Inner := Expression (Inner); + else + return Empty; + end if; + end loop; + end Check_Allocator; + + ----------------- + -- Check_Itype -- + ----------------- + + procedure Check_Itype (Typ : Entity_Id) is + Desig : constant Entity_Id := Designated_Type (Typ); + + begin + if not Is_Frozen (Desig) + and then Is_Frozen (Base_Type (Desig)) + then + Set_Is_Frozen (Desig); + + -- In addition, add an Itype_Reference to ensure that the + -- access subtype is elaborated early enough. This cannot be + -- done if the subtype may depend on discriminants. + + if Ekind (Comp) = E_Component + and then Is_Itype (Etype (Comp)) + and then not Has_Discriminants (Rec) + then + IR := Make_Itype_Reference (Sloc (Comp)); + Set_Itype (IR, Desig); + + if No (Result) then + Result := New_List (IR); + else + Append (IR, Result); + end if; + end if; + + elsif Ekind (Typ) = E_Anonymous_Access_Subprogram_Type + and then Convention (Desig) /= Convention_Protected + then + Set_Is_Frozen (Desig); + end if; + end Check_Itype; + + -- Start of processing for Freeze_Record_Type + + begin + -- If this is a subtype of a controlled type, declared without a + -- constraint, the _controller may not appear in the component list + -- if the parent was not frozen at the point of subtype declaration. + -- Inherit the _controller component now. + + if Rec /= Base_Type (Rec) + and then Has_Controlled_Component (Rec) + then + if Nkind (Parent (Rec)) = N_Subtype_Declaration + and then Is_Entity_Name (Subtype_Indication (Parent (Rec))) + then + Set_First_Entity (Rec, First_Entity (Base_Type (Rec))); + + -- If this is an internal type without a declaration, as for + -- record component, the base type may not yet be frozen, and its + -- controller has not been created. Add an explicit freeze node + -- for the itype, so it will be frozen after the base type. This + -- freeze node is used to communicate with the expander, in order + -- to create the controller for the enclosing record, and it is + -- deleted afterwards (see exp_ch3). It must not be created when + -- expansion is off, because it might appear in the wrong context + -- for the back end. + + elsif Is_Itype (Rec) + and then Has_Delayed_Freeze (Base_Type (Rec)) + and then + Nkind (Associated_Node_For_Itype (Rec)) = + N_Component_Declaration + and then Expander_Active + then + Ensure_Freeze_Node (Rec); + end if; + end if; + + -- Freeze components and embedded subtypes + + Comp := First_Entity (Rec); + Prev := Empty; + while Present (Comp) loop + + -- First handle the component case + + if Ekind (Comp) = E_Component + or else Ekind (Comp) = E_Discriminant + then + declare + CC : constant Node_Id := Component_Clause (Comp); + + begin + -- Freezing a record type freezes the type of each of its + -- components. However, if the type of the component is + -- part of this record, we do not want or need a separate + -- Freeze_Node. Note that Is_Itype is wrong because that's + -- also set in private type cases. We also can't check for + -- the Scope being exactly Rec because of private types and + -- record extensions. + + if Is_Itype (Etype (Comp)) + and then Is_Record_Type (Underlying_Type + (Scope (Etype (Comp)))) + then + Undelay_Type (Etype (Comp)); + end if; + + Freeze_And_Append (Etype (Comp), N, Result); + + -- Check for error of component clause given for variable + -- sized type. We have to delay this test till this point, + -- since the component type has to be frozen for us to know + -- if it is variable length. We omit this test in a generic + -- context, it will be applied at instantiation time. + + if Present (CC) then + Placed_Component := True; + + if Inside_A_Generic then + null; + + elsif not + Size_Known_At_Compile_Time + (Underlying_Type (Etype (Comp))) + then + Error_Msg_N + ("component clause not allowed for variable " & + "length component", CC); + end if; + + else + Unplaced_Component := True; + end if; + + -- Case of component requires byte alignment + + if Must_Be_On_Byte_Boundary (Etype (Comp)) then + + -- Set the enclosing record to also require byte align + + Set_Must_Be_On_Byte_Boundary (Rec); + + -- Check for component clause that is inconsistent with + -- the required byte boundary alignment. + + if Present (CC) + and then Normalized_First_Bit (Comp) mod + System_Storage_Unit /= 0 + then + Error_Msg_N + ("component & must be byte aligned", + Component_Name (Component_Clause (Comp))); + end if; + end if; + end; + end if; + + -- Gather data for possible Implicit_Packing later. Note that at + -- this stage we might be dealing with a real component, or with + -- an implicit subtype declaration. + + if not Is_Scalar_Type (Etype (Comp)) then + All_Scalar_Components := False; + else + Scalar_Component_Total_RM_Size := + Scalar_Component_Total_RM_Size + RM_Size (Etype (Comp)); + Scalar_Component_Total_Esize := + Scalar_Component_Total_Esize + Esize (Etype (Comp)); + end if; + + -- If the component is an Itype with Delayed_Freeze and is either + -- a record or array subtype and its base type has not yet been + -- frozen, we must remove this from the entity list of this record + -- and put it on the entity list of the scope of its base type. + -- Note that we know that this is not the type of a component + -- since we cleared Has_Delayed_Freeze for it in the previous + -- loop. Thus this must be the Designated_Type of an access type, + -- which is the type of a component. + + if Is_Itype (Comp) + and then Is_Type (Scope (Comp)) + and then Is_Composite_Type (Comp) + and then Base_Type (Comp) /= Comp + and then Has_Delayed_Freeze (Comp) + and then not Is_Frozen (Base_Type (Comp)) + then + declare + Will_Be_Frozen : Boolean := False; + S : Entity_Id; + + begin + -- We have a pretty bad kludge here. Suppose Rec is subtype + -- being defined in a subprogram that's created as part of + -- the freezing of Rec'Base. In that case, we know that + -- Comp'Base must have already been frozen by the time we + -- get to elaborate this because Gigi doesn't elaborate any + -- bodies until it has elaborated all of the declarative + -- part. But Is_Frozen will not be set at this point because + -- we are processing code in lexical order. + + -- We detect this case by going up the Scope chain of Rec + -- and seeing if we have a subprogram scope before reaching + -- the top of the scope chain or that of Comp'Base. If we + -- do, then mark that Comp'Base will actually be frozen. If + -- so, we merely undelay it. + + S := Scope (Rec); + while Present (S) loop + if Is_Subprogram (S) then + Will_Be_Frozen := True; + exit; + elsif S = Scope (Base_Type (Comp)) then + exit; + end if; + + S := Scope (S); + end loop; + + if Will_Be_Frozen then + Undelay_Type (Comp); + else + if Present (Prev) then + Set_Next_Entity (Prev, Next_Entity (Comp)); + else + Set_First_Entity (Rec, Next_Entity (Comp)); + end if; + + -- Insert in entity list of scope of base type (which + -- must be an enclosing scope, because still unfrozen). + + Append_Entity (Comp, Scope (Base_Type (Comp))); + end if; + end; + + -- If the component is an access type with an allocator as default + -- value, the designated type will be frozen by the corresponding + -- expression in init_proc. In order to place the freeze node for + -- the designated type before that for the current record type, + -- freeze it now. + + -- Same process if the component is an array of access types, + -- initialized with an aggregate. If the designated type is + -- private, it cannot contain allocators, and it is premature + -- to freeze the type, so we check for this as well. + + elsif Is_Access_Type (Etype (Comp)) + and then Present (Parent (Comp)) + and then Present (Expression (Parent (Comp))) + then + declare + Alloc : constant Node_Id := + Check_Allocator (Expression (Parent (Comp))); + + begin + if Present (Alloc) then + + -- If component is pointer to a classwide type, freeze + -- the specific type in the expression being allocated. + -- The expression may be a subtype indication, in which + -- case freeze the subtype mark. + + if Is_Class_Wide_Type + (Designated_Type (Etype (Comp))) + then + if Is_Entity_Name (Expression (Alloc)) then + Freeze_And_Append + (Entity (Expression (Alloc)), N, Result); + elsif + Nkind (Expression (Alloc)) = N_Subtype_Indication + then + Freeze_And_Append + (Entity (Subtype_Mark (Expression (Alloc))), + N, Result); + end if; + + elsif Is_Itype (Designated_Type (Etype (Comp))) then + Check_Itype (Etype (Comp)); + + else + Freeze_And_Append + (Designated_Type (Etype (Comp)), N, Result); + end if; + end if; + end; + + elsif Is_Access_Type (Etype (Comp)) + and then Is_Itype (Designated_Type (Etype (Comp))) + then + Check_Itype (Etype (Comp)); + + elsif Is_Array_Type (Etype (Comp)) + and then Is_Access_Type (Component_Type (Etype (Comp))) + and then Present (Parent (Comp)) + and then Nkind (Parent (Comp)) = N_Component_Declaration + and then Present (Expression (Parent (Comp))) + and then Nkind (Expression (Parent (Comp))) = N_Aggregate + and then Is_Fully_Defined + (Designated_Type (Component_Type (Etype (Comp)))) + then + Freeze_And_Append + (Designated_Type + (Component_Type (Etype (Comp))), N, Result); + end if; + + Prev := Comp; + Next_Entity (Comp); + end loop; + + -- Deal with pragma Bit_Order setting non-standard bit order + + if Reverse_Bit_Order (Rec) and then Base_Type (Rec) = Rec then + if not Placed_Component then + ADC := + Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order); + Error_Msg_N ("?Bit_Order specification has no effect", ADC); + Error_Msg_N + ("\?since no component clauses were specified", ADC); + + -- Here is where we do the processing for reversed bit order + + else + Adjust_Record_For_Reverse_Bit_Order (Rec); + end if; + end if; + + -- Complete error checking on record representation clause (e.g. + -- overlap of components). This is called after adjusting the + -- record for reverse bit order. + + declare + RRC : constant Node_Id := Get_Record_Representation_Clause (Rec); + begin + if Present (RRC) then + Check_Record_Representation_Clause (RRC); + end if; + end; + + -- Set OK_To_Reorder_Components depending on debug flags + + if Is_Base_Type (Rec) and then Convention (Rec) = Convention_Ada then + if (Has_Discriminants (Rec) and then Debug_Flag_Dot_V) + or else + (not Has_Discriminants (Rec) and then Debug_Flag_Dot_R) + then + Set_OK_To_Reorder_Components (Rec); + end if; + end if; + + -- Check for useless pragma Pack when all components placed. We only + -- do this check for record types, not subtypes, since a subtype may + -- have all its components placed, and it still makes perfectly good + -- sense to pack other subtypes or the parent type. We do not give + -- this warning if Optimize_Alignment is set to Space, since the + -- pragma Pack does have an effect in this case (it always resets + -- the alignment to one). + + if Ekind (Rec) = E_Record_Type + and then Is_Packed (Rec) + and then not Unplaced_Component + and then Optimize_Alignment /= 'S' + then + -- Reset packed status. Probably not necessary, but we do it so + -- that there is no chance of the back end doing something strange + -- with this redundant indication of packing. + + Set_Is_Packed (Rec, False); + + -- Give warning if redundant constructs warnings on + + if Warn_On_Redundant_Constructs then + Error_Msg_N -- CODEFIX + ("?pragma Pack has no effect, no unplaced components", + Get_Rep_Pragma (Rec, Name_Pack)); + end if; + end if; + + -- If this is the record corresponding to a remote type, freeze the + -- remote type here since that is what we are semantically freezing. + -- This prevents the freeze node for that type in an inner scope. + + -- Also, Check for controlled components and unchecked unions. + -- Finally, enforce the restriction that access attributes with a + -- current instance prefix can only apply to limited types. + + if Ekind (Rec) = E_Record_Type then + if Present (Corresponding_Remote_Type (Rec)) then + Freeze_And_Append (Corresponding_Remote_Type (Rec), N, Result); + end if; + + Comp := First_Component (Rec); + while Present (Comp) loop + + -- Do not set Has_Controlled_Component on a class-wide + -- equivalent type. See Make_CW_Equivalent_Type. + + if not Is_Class_Wide_Equivalent_Type (Rec) + and then (Has_Controlled_Component (Etype (Comp)) + or else (Chars (Comp) /= Name_uParent + and then Is_Controlled (Etype (Comp))) + or else (Is_Protected_Type (Etype (Comp)) + and then Present + (Corresponding_Record_Type + (Etype (Comp))) + and then Has_Controlled_Component + (Corresponding_Record_Type + (Etype (Comp))))) + then + Set_Has_Controlled_Component (Rec); + exit; + end if; + + if Has_Unchecked_Union (Etype (Comp)) then + Set_Has_Unchecked_Union (Rec); + end if; + + if Has_Per_Object_Constraint (Comp) then + + -- Scan component declaration for likely misuses of current + -- instance, either in a constraint or a default expression. + + Check_Current_Instance (Parent (Comp)); + end if; + + Next_Component (Comp); + end loop; + end if; + + Set_Component_Alignment_If_Not_Set (Rec); + + -- For first subtypes, check if there are any fixed-point fields with + -- component clauses, where we must check the size. This is not done + -- till the freeze point, since for fixed-point types, we do not know + -- the size until the type is frozen. Similar processing applies to + -- bit packed arrays. + + if Is_First_Subtype (Rec) then + Comp := First_Component (Rec); + while Present (Comp) loop + if Present (Component_Clause (Comp)) + and then (Is_Fixed_Point_Type (Etype (Comp)) + or else + Is_Bit_Packed_Array (Etype (Comp))) + then + Check_Size + (Component_Name (Component_Clause (Comp)), + Etype (Comp), + Esize (Comp), + Junk); + end if; + + Next_Component (Comp); + end loop; + end if; + + -- Generate warning for applying C or C++ convention to a record + -- with discriminants. This is suppressed for the unchecked union + -- case, since the whole point in this case is interface C. We also + -- do not generate this within instantiations, since we will have + -- generated a message on the template. + + if Has_Discriminants (E) + and then not Is_Unchecked_Union (E) + and then (Convention (E) = Convention_C + or else + Convention (E) = Convention_CPP) + and then Comes_From_Source (E) + and then not In_Instance + and then not Has_Warnings_Off (E) + and then not Has_Warnings_Off (Base_Type (E)) + then + declare + Cprag : constant Node_Id := Get_Rep_Pragma (E, Name_Convention); + A2 : Node_Id; + + begin + if Present (Cprag) then + A2 := Next (First (Pragma_Argument_Associations (Cprag))); + + if Convention (E) = Convention_C then + Error_Msg_N + ("?variant record has no direct equivalent in C", A2); + else + Error_Msg_N + ("?variant record has no direct equivalent in C++", A2); + end if; + + Error_Msg_NE + ("\?use of convention for type& is dubious", A2, E); + end if; + end; + end if; + + -- See if Size is too small as is (and implicit packing might help) + + if not Is_Packed (Rec) + + -- No implicit packing if even one component is explicitly placed + + and then not Placed_Component + + -- Must have size clause and all scalar components + + and then Has_Size_Clause (Rec) + and then All_Scalar_Components + + -- Do not try implicit packing on records with discriminants, too + -- complicated, especially in the variant record case. + + and then not Has_Discriminants (Rec) + + -- We can implicitly pack if the specified size of the record is + -- less than the sum of the object sizes (no point in packing if + -- this is not the case). + + and then Esize (Rec) < Scalar_Component_Total_Esize + + -- And the total RM size cannot be greater than the specified size + -- since otherwise packing will not get us where we have to be! + + and then Esize (Rec) >= Scalar_Component_Total_RM_Size + + -- Never do implicit packing in CodePeer mode since we don't do + -- any packing in this mode, since this generates over-complex + -- code that confuses CodePeer, and in general, CodePeer does not + -- care about the internal representation of objects. + + and then not CodePeer_Mode + then + -- If implicit packing enabled, do it + + if Implicit_Packing then + Set_Is_Packed (Rec); + + -- Otherwise flag the size clause + + else + declare + Sz : constant Node_Id := Size_Clause (Rec); + begin + Error_Msg_NE -- CODEFIX + ("size given for& too small", Sz, Rec); + Error_Msg_N -- CODEFIX + ("\use explicit pragma Pack " + & "or use pragma Implicit_Packing", Sz); + end; + end if; + end if; + end Freeze_Record_Type; + + -- Start of processing for Freeze_Entity + + begin + -- We are going to test for various reasons why this entity need not be + -- frozen here, but in the case of an Itype that's defined within a + -- record, that test actually applies to the record. + + if Is_Itype (E) and then Is_Record_Type (Scope (E)) then + Test_E := Scope (E); + elsif Is_Itype (E) and then Present (Underlying_Type (Scope (E))) + and then Is_Record_Type (Underlying_Type (Scope (E))) + then + Test_E := Underlying_Type (Scope (E)); + end if; + + -- Do not freeze if already frozen since we only need one freeze node + + if Is_Frozen (E) then + return No_List; + + -- It is improper to freeze an external entity within a generic because + -- its freeze node will appear in a non-valid context. The entity will + -- be frozen in the proper scope after the current generic is analyzed. + + elsif Inside_A_Generic and then External_Ref_In_Generic (Test_E) then + return No_List; + + -- Do not freeze a global entity within an inner scope created during + -- expansion. A call to subprogram E within some internal procedure + -- (a stream attribute for example) might require freezing E, but the + -- freeze node must appear in the same declarative part as E itself. + -- The two-pass elaboration mechanism in gigi guarantees that E will + -- be frozen before the inner call is elaborated. We exclude constants + -- from this test, because deferred constants may be frozen early, and + -- must be diagnosed (e.g. in the case of a deferred constant being used + -- in a default expression). If the enclosing subprogram comes from + -- source, or is a generic instance, then the freeze point is the one + -- mandated by the language, and we freeze the entity. A subprogram that + -- is a child unit body that acts as a spec does not have a spec that + -- comes from source, but can only come from source. + + elsif In_Open_Scopes (Scope (Test_E)) + and then Scope (Test_E) /= Current_Scope + and then Ekind (Test_E) /= E_Constant + then + declare + S : Entity_Id; + + begin + S := Current_Scope; + while Present (S) loop + if Is_Overloadable (S) then + if Comes_From_Source (S) + or else Is_Generic_Instance (S) + or else Is_Child_Unit (S) + then + exit; + else + return No_List; + end if; + end if; + + S := Scope (S); + end loop; + end; + + -- Similarly, an inlined instance body may make reference to global + -- entities, but these references cannot be the proper freezing point + -- for them, and in the absence of inlining freezing will take place in + -- their own scope. Normally instance bodies are analyzed after the + -- enclosing compilation, and everything has been frozen at the proper + -- place, but with front-end inlining an instance body is compiled + -- before the end of the enclosing scope, and as a result out-of-order + -- freezing must be prevented. + + elsif Front_End_Inlining + and then In_Instance_Body + and then Present (Scope (Test_E)) + then + declare + S : Entity_Id; + + begin + S := Scope (Test_E); + while Present (S) loop + if Is_Generic_Instance (S) then + exit; + else + S := Scope (S); + end if; + end loop; + + if No (S) then + return No_List; + end if; + end; + end if; + + -- Deal with delayed aspect specifications. At the point of occurrence + -- of the aspect definition, we preanalyzed the argument, to capture + -- the visibility at that point, but the actual analysis of the aspect + -- is required to be delayed to the freeze point, so we evaluate the + -- pragma or attribute definition clause in the tree at this point. + + if Has_Delayed_Aspects (E) then + declare + Ritem : Node_Id; + Aitem : Node_Id; + + begin + Ritem := First_Rep_Item (E); + while Present (Ritem) loop + if Nkind (Ritem) = N_Aspect_Specification then + Aitem := Aspect_Rep_Item (Ritem); + pragma Assert (Is_Delayed_Aspect (Aitem)); + Set_Parent (Aitem, Ritem); + Analyze (Aitem); + end if; + + Next_Rep_Item (Ritem); + end loop; + end; + end if; + + -- Here to freeze the entity + + Result := No_List; + Set_Is_Frozen (E); + + -- Case of entity being frozen is other than a type + + if not Is_Type (E) then + + -- If entity is exported or imported and does not have an external + -- name, now is the time to provide the appropriate default name. + -- Skip this if the entity is stubbed, since we don't need a name + -- for any stubbed routine. For the case on intrinsics, if no + -- external name is specified, then calls will be handled in + -- Exp_Intr.Expand_Intrinsic_Call, and no name is needed. If an + -- external name is provided, then Expand_Intrinsic_Call leaves + -- calls in place for expansion by GIGI. + + if (Is_Imported (E) or else Is_Exported (E)) + and then No (Interface_Name (E)) + and then Convention (E) /= Convention_Stubbed + and then Convention (E) /= Convention_Intrinsic + then + Set_Encoded_Interface_Name + (E, Get_Default_External_Name (E)); + + -- If entity is an atomic object appearing in a declaration and + -- the expression is an aggregate, assign it to a temporary to + -- ensure that the actual assignment is done atomically rather + -- than component-wise (the assignment to the temp may be done + -- component-wise, but that is harmless). + + elsif Is_Atomic (E) + and then Nkind (Parent (E)) = N_Object_Declaration + and then Present (Expression (Parent (E))) + and then Nkind (Expression (Parent (E))) = N_Aggregate + and then + Is_Atomic_Aggregate (Expression (Parent (E)), Etype (E)) + then + null; + end if; + + -- For a subprogram, freeze all parameter types and also the return + -- type (RM 13.14(14)). However skip this for internal subprograms. + -- This is also the point where any extra formal parameters are + -- created since we now know whether the subprogram will use a + -- foreign convention. + + if Is_Subprogram (E) then + if not Is_Internal (E) then + declare + F_Type : Entity_Id; + R_Type : Entity_Id; + Warn_Node : Node_Id; + + begin + -- Loop through formals + + Formal := First_Formal (E); + while Present (Formal) loop + F_Type := Etype (Formal); + Freeze_And_Append (F_Type, N, Result); + + if Is_Private_Type (F_Type) + and then Is_Private_Type (Base_Type (F_Type)) + and then No (Full_View (Base_Type (F_Type))) + and then not Is_Generic_Type (F_Type) + and then not Is_Derived_Type (F_Type) + then + -- If the type of a formal is incomplete, subprogram + -- is being frozen prematurely. Within an instance + -- (but not within a wrapper package) this is an + -- artifact of our need to regard the end of an + -- instantiation as a freeze point. Otherwise it is + -- a definite error. + + if In_Instance then + Set_Is_Frozen (E, False); + return No_List; + + elsif not After_Last_Declaration + and then not Freezing_Library_Level_Tagged_Type + then + Error_Msg_Node_1 := F_Type; + Error_Msg + ("type& must be fully defined before this point", + Loc); + end if; + end if; + + -- Check suspicious parameter for C function. These tests + -- apply only to exported/imported subprograms. + + if Warn_On_Export_Import + and then Comes_From_Source (E) + and then (Convention (E) = Convention_C + or else + Convention (E) = Convention_CPP) + and then (Is_Imported (E) or else Is_Exported (E)) + and then Convention (E) /= Convention (Formal) + and then not Has_Warnings_Off (E) + and then not Has_Warnings_Off (F_Type) + and then not Has_Warnings_Off (Formal) + then + -- Qualify mention of formals with subprogram name + + Error_Msg_Qual_Level := 1; + + -- Check suspicious use of fat C pointer + + if Is_Access_Type (F_Type) + and then Esize (F_Type) > Ttypes.System_Address_Size + then + Error_Msg_N + ("?type of & does not correspond to C pointer!", + Formal); + + -- Check suspicious return of boolean + + elsif Root_Type (F_Type) = Standard_Boolean + and then Convention (F_Type) = Convention_Ada + and then not Has_Warnings_Off (F_Type) + and then not Has_Size_Clause (F_Type) + and then VM_Target = No_VM + then + Error_Msg_N ("& is an 8-bit Ada Boolean?", Formal); + Error_Msg_N + ("\use appropriate corresponding type in C " + & "(e.g. char)?", Formal); + + -- Check suspicious tagged type + + elsif (Is_Tagged_Type (F_Type) + or else (Is_Access_Type (F_Type) + and then + Is_Tagged_Type + (Designated_Type (F_Type)))) + and then Convention (E) = Convention_C + then + Error_Msg_N + ("?& involves a tagged type which does not " + & "correspond to any C type!", Formal); + + -- Check wrong convention subprogram pointer + + elsif Ekind (F_Type) = E_Access_Subprogram_Type + and then not Has_Foreign_Convention (F_Type) + then + Error_Msg_N + ("?subprogram pointer & should " + & "have foreign convention!", Formal); + Error_Msg_Sloc := Sloc (F_Type); + Error_Msg_NE + ("\?add Convention pragma to declaration of &#", + Formal, F_Type); + end if; + + -- Turn off name qualification after message output + + Error_Msg_Qual_Level := 0; + end if; + + -- Check for unconstrained array in exported foreign + -- convention case. + + if Has_Foreign_Convention (E) + and then not Is_Imported (E) + and then Is_Array_Type (F_Type) + and then not Is_Constrained (F_Type) + and then Warn_On_Export_Import + + -- Exclude VM case, since both .NET and JVM can handle + -- unconstrained arrays without a problem. + + and then VM_Target = No_VM + then + Error_Msg_Qual_Level := 1; + + -- If this is an inherited operation, place the + -- warning on the derived type declaration, rather + -- than on the original subprogram. + + if Nkind (Original_Node (Parent (E))) = + N_Full_Type_Declaration + then + Warn_Node := Parent (E); + + if Formal = First_Formal (E) then + Error_Msg_NE + ("?in inherited operation&", Warn_Node, E); + end if; + else + Warn_Node := Formal; + end if; + + Error_Msg_NE + ("?type of argument& is unconstrained array", + Warn_Node, Formal); + Error_Msg_NE + ("?foreign caller must pass bounds explicitly", + Warn_Node, Formal); + Error_Msg_Qual_Level := 0; + end if; + + if not From_With_Type (F_Type) then + if Is_Access_Type (F_Type) then + F_Type := Designated_Type (F_Type); + end if; + + -- If the formal is an anonymous_access_to_subprogram + -- freeze the subprogram type as well, to prevent + -- scope anomalies in gigi, because there is no other + -- clear point at which it could be frozen. + + if Is_Itype (Etype (Formal)) + and then Ekind (F_Type) = E_Subprogram_Type + then + Freeze_And_Append (F_Type, N, Result); + end if; + end if; + + Next_Formal (Formal); + end loop; + + -- Case of function: similar checks on return type + + if Ekind (E) = E_Function then + + -- Freeze return type + + R_Type := Etype (E); + Freeze_And_Append (R_Type, N, Result); + + -- Check suspicious return type for C function + + if Warn_On_Export_Import + and then (Convention (E) = Convention_C + or else + Convention (E) = Convention_CPP) + and then (Is_Imported (E) or else Is_Exported (E)) + then + -- Check suspicious return of fat C pointer + + if Is_Access_Type (R_Type) + and then Esize (R_Type) > Ttypes.System_Address_Size + and then not Has_Warnings_Off (E) + and then not Has_Warnings_Off (R_Type) + then + Error_Msg_N + ("?return type of& does not " + & "correspond to C pointer!", E); + + -- Check suspicious return of boolean + + elsif Root_Type (R_Type) = Standard_Boolean + and then Convention (R_Type) = Convention_Ada + and then VM_Target = No_VM + and then not Has_Warnings_Off (E) + and then not Has_Warnings_Off (R_Type) + and then not Has_Size_Clause (R_Type) + then + declare + N : constant Node_Id := + Result_Definition (Declaration_Node (E)); + begin + Error_Msg_NE + ("return type of & is an 8-bit Ada Boolean?", + N, E); + Error_Msg_NE + ("\use appropriate corresponding type in C " + & "(e.g. char)?", N, E); + end; + + -- Check suspicious return tagged type + + elsif (Is_Tagged_Type (R_Type) + or else (Is_Access_Type (R_Type) + and then + Is_Tagged_Type + (Designated_Type (R_Type)))) + and then Convention (E) = Convention_C + and then not Has_Warnings_Off (E) + and then not Has_Warnings_Off (R_Type) + then + Error_Msg_N + ("?return type of & does not " + & "correspond to C type!", E); + + -- Check return of wrong convention subprogram pointer + + elsif Ekind (R_Type) = E_Access_Subprogram_Type + and then not Has_Foreign_Convention (R_Type) + and then not Has_Warnings_Off (E) + and then not Has_Warnings_Off (R_Type) + then + Error_Msg_N + ("?& should return a foreign " + & "convention subprogram pointer", E); + Error_Msg_Sloc := Sloc (R_Type); + Error_Msg_NE + ("\?add Convention pragma to declaration of& #", + E, R_Type); + end if; + end if; + + -- Give warning for suspicious return of a result of an + -- unconstrained array type in a foreign convention + -- function. + + if Has_Foreign_Convention (E) + + -- We are looking for a return of unconstrained array + + and then Is_Array_Type (R_Type) + and then not Is_Constrained (R_Type) + + -- Exclude imported routines, the warning does not + -- belong on the import, but on the routine definition. + + and then not Is_Imported (E) + + -- Exclude VM case, since both .NET and JVM can handle + -- return of unconstrained arrays without a problem. + + and then VM_Target = No_VM + + -- Check that general warning is enabled, and that it + -- is not suppressed for this particular case. + + and then Warn_On_Export_Import + and then not Has_Warnings_Off (E) + and then not Has_Warnings_Off (R_Type) + then + Error_Msg_N + ("?foreign convention function& should not " & + "return unconstrained array!", E); + end if; + end if; + end; + end if; + + -- Must freeze its parent first if it is a derived subprogram + + if Present (Alias (E)) then + Freeze_And_Append (Alias (E), N, Result); + end if; + + -- We don't freeze internal subprograms, because we don't normally + -- want addition of extra formals or mechanism setting to happen + -- for those. However we do pass through predefined dispatching + -- cases, since extra formals may be needed in some cases, such as + -- for the stream 'Input function (build-in-place formals). + + if not Is_Internal (E) + or else Is_Predefined_Dispatching_Operation (E) + then + Freeze_Subprogram (E); + end if; + + -- Here for other than a subprogram or type + + else + -- If entity has a type, and it is not a generic unit, then + -- freeze it first (RM 13.14(10)). + + if Present (Etype (E)) + and then Ekind (E) /= E_Generic_Function + then + Freeze_And_Append (Etype (E), N, Result); + end if; + + -- Special processing for objects created by object declaration + + if Nkind (Declaration_Node (E)) = N_Object_Declaration then + + -- Abstract type allowed only for C++ imported variables or + -- constants. + + -- Note: we inhibit this check for objects that do not come + -- from source because there is at least one case (the + -- expansion of x'class'input where x is abstract) where we + -- legitimately generate an abstract object. + + if Is_Abstract_Type (Etype (E)) + and then Comes_From_Source (Parent (E)) + and then not (Is_Imported (E) + and then Is_CPP_Class (Etype (E))) + then + Error_Msg_N ("type of object cannot be abstract", + Object_Definition (Parent (E))); + + if Is_CPP_Class (Etype (E)) then + Error_Msg_NE + ("\} may need a cpp_constructor", + Object_Definition (Parent (E)), Etype (E)); + end if; + end if; + + -- For object created by object declaration, perform required + -- categorization (preelaborate and pure) checks. Defer these + -- checks to freeze time since pragma Import inhibits default + -- initialization and thus pragma Import affects these checks. + + Validate_Object_Declaration (Declaration_Node (E)); + + -- If there is an address clause, check that it is valid + + Check_Address_Clause (E); + + -- If the object needs any kind of default initialization, an + -- error must be issued if No_Default_Initialization applies. + -- The check doesn't apply to imported objects, which are not + -- ever default initialized, and is why the check is deferred + -- until freezing, at which point we know if Import applies. + -- Deferred constants are also exempted from this test because + -- their completion is explicit, or through an import pragma. + + if Ekind (E) = E_Constant + and then Present (Full_View (E)) + then + null; + + elsif Comes_From_Source (E) + and then not Is_Imported (E) + and then not Has_Init_Expression (Declaration_Node (E)) + and then + ((Has_Non_Null_Base_Init_Proc (Etype (E)) + and then not No_Initialization (Declaration_Node (E)) + and then not Is_Value_Type (Etype (E)) + and then not Suppress_Init_Proc (Etype (E))) + or else + (Needs_Simple_Initialization (Etype (E)) + and then not Is_Internal (E))) + then + Has_Default_Initialization := True; + Check_Restriction + (No_Default_Initialization, Declaration_Node (E)); + end if; + + -- Check that a Thread_Local_Storage variable does not have + -- default initialization, and any explicit initialization must + -- either be the null constant or a static constant. + + if Has_Pragma_Thread_Local_Storage (E) then + declare + Decl : constant Node_Id := Declaration_Node (E); + begin + if Has_Default_Initialization + or else + (Has_Init_Expression (Decl) + and then + (No (Expression (Decl)) + or else not + (Is_Static_Expression (Expression (Decl)) + or else + Nkind (Expression (Decl)) = N_Null))) + then + Error_Msg_NE + ("Thread_Local_Storage variable& is " + & "improperly initialized", Decl, E); + Error_Msg_NE + ("\only allowed initialization is explicit " + & "NULL or static expression", Decl, E); + end if; + end; + end if; + + -- For imported objects, set Is_Public unless there is also an + -- address clause, which means that there is no external symbol + -- needed for the Import (Is_Public may still be set for other + -- unrelated reasons). Note that we delayed this processing + -- till freeze time so that we can be sure not to set the flag + -- if there is an address clause. If there is such a clause, + -- then the only purpose of the Import pragma is to suppress + -- implicit initialization. + + if Is_Imported (E) + and then No (Address_Clause (E)) + then + Set_Is_Public (E); + end if; + + -- For convention C objects of an enumeration type, warn if + -- the size is not integer size and no explicit size given. + -- Skip warning for Boolean, and Character, assume programmer + -- expects 8-bit sizes for these cases. + + if (Convention (E) = Convention_C + or else + Convention (E) = Convention_CPP) + and then Is_Enumeration_Type (Etype (E)) + and then not Is_Character_Type (Etype (E)) + and then not Is_Boolean_Type (Etype (E)) + and then Esize (Etype (E)) < Standard_Integer_Size + and then not Has_Size_Clause (E) + then + Error_Msg_Uint_1 := UI_From_Int (Standard_Integer_Size); + Error_Msg_N + ("?convention C enumeration object has size less than ^", + E); + Error_Msg_N ("\?use explicit size clause to set size", E); + end if; + end if; + + -- Check that a constant which has a pragma Volatile[_Components] + -- or Atomic[_Components] also has a pragma Import (RM C.6(13)). + + -- Note: Atomic[_Components] also sets Volatile[_Components] + + if Ekind (E) = E_Constant + and then (Has_Volatile_Components (E) or else Is_Volatile (E)) + and then not Is_Imported (E) + then + -- Make sure we actually have a pragma, and have not merely + -- inherited the indication from elsewhere (e.g. an address + -- clause, which is not good enough in RM terms!) + + if Has_Rep_Pragma (E, Name_Atomic) + or else + Has_Rep_Pragma (E, Name_Atomic_Components) + then + Error_Msg_N + ("stand alone atomic constant must be " & + "imported (RM C.6(13))", E); + + elsif Has_Rep_Pragma (E, Name_Volatile) + or else + Has_Rep_Pragma (E, Name_Volatile_Components) + then + Error_Msg_N + ("stand alone volatile constant must be " & + "imported (RM C.6(13))", E); + end if; + end if; + + -- Static objects require special handling + + if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) + and then Is_Statically_Allocated (E) + then + Freeze_Static_Object (E); + end if; + + -- Remaining step is to layout objects + + if Ekind (E) = E_Variable + or else + Ekind (E) = E_Constant + or else + Ekind (E) = E_Loop_Parameter + or else + Is_Formal (E) + then + Layout_Object (E); + end if; + end if; + + -- Case of a type or subtype being frozen + + else + -- We used to check here that a full type must have preelaborable + -- initialization if it completes a private type specified with + -- pragma Preelaborable_Initialization, but that missed cases where + -- the types occur within a generic package, since the freezing + -- that occurs within a containing scope generally skips traversal + -- of a generic unit's declarations (those will be frozen within + -- instances). This check was moved to Analyze_Package_Specification. + + -- The type may be defined in a generic unit. This can occur when + -- freezing a generic function that returns the type (which is + -- defined in a parent unit). It is clearly meaningless to freeze + -- this type. However, if it is a subtype, its size may be determi- + -- nable and used in subsequent checks, so might as well try to + -- compute it. + + if Present (Scope (E)) + and then Is_Generic_Unit (Scope (E)) + then + Check_Compile_Time_Size (E); + return No_List; + end if; + + -- Deal with special cases of freezing for subtype + + if E /= Base_Type (E) then + + -- Before we do anything else, a specialized test for the case of + -- a size given for an array where the array needs to be packed, + -- but was not so the size cannot be honored. This would of course + -- be caught by the backend, and indeed we don't catch all cases. + -- The point is that we can give a better error message in those + -- cases that we do catch with the circuitry here. Also if pragma + -- Implicit_Packing is set, this is where the packing occurs. + + -- The reason we do this so early is that the processing in the + -- automatic packing case affects the layout of the base type, so + -- it must be done before we freeze the base type. + + if Is_Array_Type (E) then + declare + Lo, Hi : Node_Id; + Ctyp : constant Entity_Id := Component_Type (E); + + begin + -- Check enabling conditions. These are straightforward + -- except for the test for a limited composite type. This + -- eliminates the rare case of a array of limited components + -- where there are issues of whether or not we can go ahead + -- and pack the array (since we can't freely pack and unpack + -- arrays if they are limited). + + -- Note that we check the root type explicitly because the + -- whole point is we are doing this test before we have had + -- a chance to freeze the base type (and it is that freeze + -- action that causes stuff to be inherited). + + if Present (Size_Clause (E)) + and then Known_Static_Esize (E) + and then not Is_Packed (E) + and then not Has_Pragma_Pack (E) + and then Number_Dimensions (E) = 1 + and then not Has_Component_Size_Clause (E) + and then Known_Static_Esize (Ctyp) + and then not Is_Limited_Composite (E) + and then not Is_Packed (Root_Type (E)) + and then not Has_Component_Size_Clause (Root_Type (E)) + and then not CodePeer_Mode + then + Get_Index_Bounds (First_Index (E), Lo, Hi); + + if Compile_Time_Known_Value (Lo) + and then Compile_Time_Known_Value (Hi) + and then Known_Static_RM_Size (Ctyp) + and then RM_Size (Ctyp) < 64 + then + declare + Lov : constant Uint := Expr_Value (Lo); + Hiv : constant Uint := Expr_Value (Hi); + Len : constant Uint := UI_Max + (Uint_0, + Hiv - Lov + 1); + Rsiz : constant Uint := RM_Size (Ctyp); + SZ : constant Node_Id := Size_Clause (E); + Btyp : constant Entity_Id := Base_Type (E); + + -- What we are looking for here is the situation where + -- the RM_Size given would be exactly right if there + -- was a pragma Pack (resulting in the component size + -- being the same as the RM_Size). Furthermore, the + -- component type size must be an odd size (not a + -- multiple of storage unit). If the component RM size + -- is an exact number of storage units that is a power + -- of two, the array is not packed and has a standard + -- representation. + + begin + if RM_Size (E) = Len * Rsiz + and then Rsiz mod System_Storage_Unit /= 0 + then + -- For implicit packing mode, just set the + -- component size silently. + + if Implicit_Packing then + Set_Component_Size (Btyp, Rsiz); + Set_Is_Bit_Packed_Array (Btyp); + Set_Is_Packed (Btyp); + Set_Has_Non_Standard_Rep (Btyp); + + -- Otherwise give an error message + + else + Error_Msg_NE + ("size given for& too small", SZ, E); + Error_Msg_N -- CODEFIX + ("\use explicit pragma Pack " + & "or use pragma Implicit_Packing", SZ); + end if; + + elsif RM_Size (E) = Len * Rsiz + and then Implicit_Packing + and then + (Rsiz / System_Storage_Unit = 1 + or else Rsiz / System_Storage_Unit = 2 + or else Rsiz / System_Storage_Unit = 4) + then + + -- Not a packed array, but indicate the desired + -- component size, for the back-end. + + Set_Component_Size (Btyp, Rsiz); + end if; + end; + end if; + end if; + end; + end if; + + -- If ancestor subtype present, freeze that first. Note that this + -- will also get the base type frozen. Need RM reference ??? + + Atype := Ancestor_Subtype (E); + + if Present (Atype) then + Freeze_And_Append (Atype, N, Result); + + -- No ancestor subtype present + + else + -- See if we have a nearest ancestor that has a predicate. + -- That catches the case of derived type with a predicate. + -- Need RM reference here ??? + + Atype := Nearest_Ancestor (E); + + if Present (Atype) and then Has_Predicates (Atype) then + Freeze_And_Append (Atype, N, Result); + end if; + + -- Freeze base type before freezing the entity (RM 13.14(15)) + + if E /= Base_Type (E) then + Freeze_And_Append (Base_Type (E), N, Result); + end if; + end if; + + -- For a derived type, freeze its parent type first (RM 13.14(15)) + + elsif Is_Derived_Type (E) then + Freeze_And_Append (Etype (E), N, Result); + Freeze_And_Append (First_Subtype (Etype (E)), N, Result); + end if; + + -- For array type, freeze index types and component type first + -- before freezing the array (RM 13.14(15)). + + if Is_Array_Type (E) then + declare + FS : constant Entity_Id := First_Subtype (E); + Ctyp : constant Entity_Id := Component_Type (E); + Clause : Entity_Id; + + Non_Standard_Enum : Boolean := False; + -- Set true if any of the index types is an enumeration type + -- with a non-standard representation. + + begin + Freeze_And_Append (Ctyp, N, Result); + + Indx := First_Index (E); + while Present (Indx) loop + Freeze_And_Append (Etype (Indx), N, Result); + + if Is_Enumeration_Type (Etype (Indx)) + and then Has_Non_Standard_Rep (Etype (Indx)) + then + Non_Standard_Enum := True; + end if; + + Next_Index (Indx); + end loop; + + -- Processing that is done only for base types + + if Ekind (E) = E_Array_Type then + + -- Propagate flags for component type + + if Is_Controlled (Component_Type (E)) + or else Has_Controlled_Component (Ctyp) + then + Set_Has_Controlled_Component (E); + end if; + + if Has_Unchecked_Union (Component_Type (E)) then + Set_Has_Unchecked_Union (E); + end if; + + -- If packing was requested or if the component size was set + -- explicitly, then see if bit packing is required. This + -- processing is only done for base types, since all the + -- representation aspects involved are type-related. This + -- is not just an optimization, if we start processing the + -- subtypes, they interfere with the settings on the base + -- type (this is because Is_Packed has a slightly different + -- meaning before and after freezing). + + declare + Csiz : Uint; + Esiz : Uint; + + begin + if (Is_Packed (E) or else Has_Pragma_Pack (E)) + and then Known_Static_RM_Size (Ctyp) + and then not Has_Component_Size_Clause (E) + then + Csiz := UI_Max (RM_Size (Ctyp), 1); + + elsif Known_Component_Size (E) then + Csiz := Component_Size (E); + + elsif not Known_Static_Esize (Ctyp) then + Csiz := Uint_0; + + else + Esiz := Esize (Ctyp); + + -- We can set the component size if it is less than + -- 16, rounding it up to the next storage unit size. + + if Esiz <= 8 then + Csiz := Uint_8; + elsif Esiz <= 16 then + Csiz := Uint_16; + else + Csiz := Uint_0; + end if; + + -- Set component size up to match alignment if it + -- would otherwise be less than the alignment. This + -- deals with cases of types whose alignment exceeds + -- their size (padded types). + + if Csiz /= 0 then + declare + A : constant Uint := Alignment_In_Bits (Ctyp); + begin + if Csiz < A then + Csiz := A; + end if; + end; + end if; + end if; + + -- Case of component size that may result in packing + + if 1 <= Csiz and then Csiz <= 64 then + declare + Ent : constant Entity_Id := + First_Subtype (E); + Pack_Pragma : constant Node_Id := + Get_Rep_Pragma (Ent, Name_Pack); + Comp_Size_C : constant Node_Id := + Get_Attribute_Definition_Clause + (Ent, Attribute_Component_Size); + begin + -- Warn if we have pack and component size so that + -- the pack is ignored. + + -- Note: here we must check for the presence of a + -- component size before checking for a Pack pragma + -- to deal with the case where the array type is a + -- derived type whose parent is currently private. + + if Present (Comp_Size_C) + and then Has_Pragma_Pack (Ent) + and then Warn_On_Redundant_Constructs + then + Error_Msg_Sloc := Sloc (Comp_Size_C); + Error_Msg_NE + ("?pragma Pack for& ignored!", + Pack_Pragma, Ent); + Error_Msg_N + ("\?explicit component size given#!", + Pack_Pragma); + Set_Is_Packed (Base_Type (Ent), False); + Set_Is_Bit_Packed_Array (Base_Type (Ent), False); + end if; + + -- Set component size if not already set by a + -- component size clause. + + if not Present (Comp_Size_C) then + Set_Component_Size (E, Csiz); + end if; + + -- Check for base type of 8, 16, 32 bits, where an + -- unsigned subtype has a length one less than the + -- base type (e.g. Natural subtype of Integer). + + -- In such cases, if a component size was not set + -- explicitly, then generate a warning. + + if Has_Pragma_Pack (E) + and then not Present (Comp_Size_C) + and then + (Csiz = 7 or else Csiz = 15 or else Csiz = 31) + and then Esize (Base_Type (Ctyp)) = Csiz + 1 + then + Error_Msg_Uint_1 := Csiz; + + if Present (Pack_Pragma) then + Error_Msg_N + ("?pragma Pack causes component size " + & "to be ^!", Pack_Pragma); + Error_Msg_N + ("\?use Component_Size to set " + & "desired value!", Pack_Pragma); + end if; + end if; + + -- Actual packing is not needed for 8, 16, 32, 64. + -- Also not needed for 24 if alignment is 1. + + if Csiz = 8 + or else Csiz = 16 + or else Csiz = 32 + or else Csiz = 64 + or else (Csiz = 24 and then Alignment (Ctyp) = 1) + then + -- Here the array was requested to be packed, + -- but the packing request had no effect, so + -- Is_Packed is reset. + + -- Note: semantically this means that we lose + -- track of the fact that a derived type + -- inherited a pragma Pack that was non- + -- effective, but that seems fine. + + -- We regard a Pack pragma as a request to set + -- a representation characteristic, and this + -- request may be ignored. + + Set_Is_Packed (Base_Type (E), False); + Set_Is_Bit_Packed_Array (Base_Type (E), False); + + if Known_Static_Esize (Component_Type (E)) + and then Esize (Component_Type (E)) = Csiz + then + Set_Has_Non_Standard_Rep + (Base_Type (E), False); + end if; + + -- In all other cases, packing is indeed needed + + else + Set_Has_Non_Standard_Rep (Base_Type (E), True); + Set_Is_Bit_Packed_Array (Base_Type (E), True); + Set_Is_Packed (Base_Type (E), True); + end if; + end; + end if; + end; + + -- Check for Atomic_Components or Aliased with unsuitable + -- packing or explicit component size clause given. + + if (Has_Atomic_Components (E) + or else Has_Aliased_Components (E)) + and then (Has_Component_Size_Clause (E) + or else Is_Packed (E)) + then + Alias_Atomic_Check : declare + + procedure Complain_CS (T : String); + -- Outputs error messages for incorrect CS clause or + -- pragma Pack for aliased or atomic components (T is + -- "aliased" or "atomic"); + + ----------------- + -- Complain_CS -- + ----------------- + + procedure Complain_CS (T : String) is + begin + if Has_Component_Size_Clause (E) then + Clause := + Get_Attribute_Definition_Clause + (FS, Attribute_Component_Size); + + if Known_Static_Esize (Ctyp) then + Error_Msg_N + ("incorrect component size for " + & T & " components", Clause); + Error_Msg_Uint_1 := Esize (Ctyp); + Error_Msg_N + ("\only allowed value is^", Clause); + + else + Error_Msg_N + ("component size cannot be given for " + & T & " components", Clause); + end if; + + else + Error_Msg_N + ("cannot pack " & T & " components", + Get_Rep_Pragma (FS, Name_Pack)); + end if; + + return; + end Complain_CS; + + -- Start of processing for Alias_Atomic_Check + + begin + -- Case where component size has no effect + + if Known_Static_Esize (Ctyp) + and then Known_Static_RM_Size (Ctyp) + and then Esize (Ctyp) = RM_Size (Ctyp) + and then Esize (Ctyp) mod 8 = 0 + then + null; + + elsif Has_Aliased_Components (E) + or else Is_Aliased (Ctyp) + then + Complain_CS ("aliased"); + + elsif Has_Atomic_Components (E) + or else Is_Atomic (Ctyp) + then + Complain_CS ("atomic"); + end if; + end Alias_Atomic_Check; + end if; + + -- Warn for case of atomic type + + Clause := Get_Rep_Pragma (FS, Name_Atomic); + + if Present (Clause) + and then not Addressable (Component_Size (FS)) + then + Error_Msg_NE + ("non-atomic components of type& may not be " + & "accessible by separate tasks?", Clause, E); + + if Has_Component_Size_Clause (E) then + Error_Msg_Sloc := + Sloc + (Get_Attribute_Definition_Clause + (FS, Attribute_Component_Size)); + Error_Msg_N + ("\because of component size clause#?", + Clause); + + elsif Has_Pragma_Pack (E) then + Error_Msg_Sloc := + Sloc (Get_Rep_Pragma (FS, Name_Pack)); + Error_Msg_N + ("\because of pragma Pack#?", Clause); + end if; + end if; + + -- Processing that is done only for subtypes + + else + -- Acquire alignment from base type + + if Unknown_Alignment (E) then + Set_Alignment (E, Alignment (Base_Type (E))); + Adjust_Esize_Alignment (E); + end if; + end if; + + -- For bit-packed arrays, check the size + + if Is_Bit_Packed_Array (E) and then Known_RM_Size (E) then + declare + SizC : constant Node_Id := Size_Clause (E); + + Discard : Boolean; + pragma Warnings (Off, Discard); + + begin + -- It is not clear if it is possible to have no size + -- clause at this stage, but it is not worth worrying + -- about. Post error on the entity name in the size + -- clause if present, else on the type entity itself. + + if Present (SizC) then + Check_Size (Name (SizC), E, RM_Size (E), Discard); + else + Check_Size (E, E, RM_Size (E), Discard); + end if; + end; + end if; + + -- If any of the index types was an enumeration type with a + -- non-standard rep clause, then we indicate that the array + -- type is always packed (even if it is not bit packed). + + if Non_Standard_Enum then + Set_Has_Non_Standard_Rep (Base_Type (E)); + Set_Is_Packed (Base_Type (E)); + end if; + + Set_Component_Alignment_If_Not_Set (E); + + -- If the array is packed, we must create the packed array + -- type to be used to actually implement the type. This is + -- only needed for real array types (not for string literal + -- types, since they are present only for the front end). + + if Is_Packed (E) + and then Ekind (E) /= E_String_Literal_Subtype + then + Create_Packed_Array_Type (E); + Freeze_And_Append (Packed_Array_Type (E), N, Result); + + -- Size information of packed array type is copied to the + -- array type, since this is really the representation. But + -- do not override explicit existing size values. If the + -- ancestor subtype is constrained the packed_array_type + -- will be inherited from it, but the size may have been + -- provided already, and must not be overridden either. + + if not Has_Size_Clause (E) + and then + (No (Ancestor_Subtype (E)) + or else not Has_Size_Clause (Ancestor_Subtype (E))) + then + Set_Esize (E, Esize (Packed_Array_Type (E))); + Set_RM_Size (E, RM_Size (Packed_Array_Type (E))); + end if; + + if not Has_Alignment_Clause (E) then + Set_Alignment (E, Alignment (Packed_Array_Type (E))); + end if; + end if; + + -- For non-packed arrays set the alignment of the array to the + -- alignment of the component type if it is unknown. Skip this + -- in atomic case (atomic arrays may need larger alignments). + + if not Is_Packed (E) + and then Unknown_Alignment (E) + and then Known_Alignment (Ctyp) + and then Known_Static_Component_Size (E) + and then Known_Static_Esize (Ctyp) + and then Esize (Ctyp) = Component_Size (E) + and then not Is_Atomic (E) + then + Set_Alignment (E, Alignment (Component_Type (E))); + end if; + end; + + -- For a class-wide type, the corresponding specific type is + -- frozen as well (RM 13.14(15)) + + elsif Is_Class_Wide_Type (E) then + Freeze_And_Append (Root_Type (E), N, Result); + + -- If the base type of the class-wide type is still incomplete, + -- the class-wide remains unfrozen as well. This is legal when + -- E is the formal of a primitive operation of some other type + -- which is being frozen. + + if not Is_Frozen (Root_Type (E)) then + Set_Is_Frozen (E, False); + return Result; + end if; + + -- If the Class_Wide_Type is an Itype (when type is the anonymous + -- parent of a derived type) and it is a library-level entity, + -- generate an itype reference for it. Otherwise, its first + -- explicit reference may be in an inner scope, which will be + -- rejected by the back-end. + + if Is_Itype (E) + and then Is_Compilation_Unit (Scope (E)) + then + declare + Ref : constant Node_Id := Make_Itype_Reference (Loc); + + begin + Set_Itype (Ref, E); + if No (Result) then + Result := New_List (Ref); + else + Append (Ref, Result); + end if; + end; + end if; + + -- The equivalent type associated with a class-wide subtype needs + -- to be frozen to ensure that its layout is done. + + if Ekind (E) = E_Class_Wide_Subtype + and then Present (Equivalent_Type (E)) + then + Freeze_And_Append (Equivalent_Type (E), N, Result); + end if; + + -- For a record (sub)type, freeze all the component types (RM + -- 13.14(15). We test for E_Record_(sub)Type here, rather than using + -- Is_Record_Type, because we don't want to attempt the freeze for + -- the case of a private type with record extension (we will do that + -- later when the full type is frozen). + + elsif Ekind (E) = E_Record_Type + or else Ekind (E) = E_Record_Subtype + then + Freeze_Record_Type (E); + + -- For a concurrent type, freeze corresponding record type. This + -- does not correspond to any specific rule in the RM, but the + -- record type is essentially part of the concurrent type. + -- Freeze as well all local entities. This includes record types + -- created for entry parameter blocks, and whatever local entities + -- may appear in the private part. + + elsif Is_Concurrent_Type (E) then + if Present (Corresponding_Record_Type (E)) then + Freeze_And_Append + (Corresponding_Record_Type (E), N, Result); + end if; + + Comp := First_Entity (E); + while Present (Comp) loop + if Is_Type (Comp) then + Freeze_And_Append (Comp, N, Result); + + elsif (Ekind (Comp)) /= E_Function then + if Is_Itype (Etype (Comp)) + and then Underlying_Type (Scope (Etype (Comp))) = E + then + Undelay_Type (Etype (Comp)); + end if; + + Freeze_And_Append (Etype (Comp), N, Result); + end if; + + Next_Entity (Comp); + end loop; + + -- Private types are required to point to the same freeze node as + -- their corresponding full views. The freeze node itself has to + -- point to the partial view of the entity (because from the partial + -- view, we can retrieve the full view, but not the reverse). + -- However, in order to freeze correctly, we need to freeze the full + -- view. If we are freezing at the end of a scope (or within the + -- scope of the private type), the partial and full views will have + -- been swapped, the full view appears first in the entity chain and + -- the swapping mechanism ensures that the pointers are properly set + -- (on scope exit). + + -- If we encounter the partial view before the full view (e.g. when + -- freezing from another scope), we freeze the full view, and then + -- set the pointers appropriately since we cannot rely on swapping to + -- fix things up (subtypes in an outer scope might not get swapped). + + elsif Is_Incomplete_Or_Private_Type (E) + and then not Is_Generic_Type (E) + then + -- The construction of the dispatch table associated with library + -- level tagged types forces freezing of all the primitives of the + -- type, which may cause premature freezing of the partial view. + -- For example: + + -- package Pkg is + -- type T is tagged private; + -- type DT is new T with private; + -- procedure Prim (X : in out T; Y : in out DT'class); + -- private + -- type T is tagged null record; + -- Obj : T; + -- type DT is new T with null record; + -- end; + + -- In this case the type will be frozen later by the usual + -- mechanism: an object declaration, an instantiation, or the + -- end of a declarative part. + + if Is_Library_Level_Tagged_Type (E) + and then not Present (Full_View (E)) + then + Set_Is_Frozen (E, False); + return Result; + + -- Case of full view present + + elsif Present (Full_View (E)) then + + -- If full view has already been frozen, then no further + -- processing is required + + if Is_Frozen (Full_View (E)) then + Set_Has_Delayed_Freeze (E, False); + Set_Freeze_Node (E, Empty); + Check_Debug_Info_Needed (E); + + -- Otherwise freeze full view and patch the pointers so that + -- the freeze node will elaborate both views in the back-end. + + else + declare + Full : constant Entity_Id := Full_View (E); + + begin + if Is_Private_Type (Full) + and then Present (Underlying_Full_View (Full)) + then + Freeze_And_Append + (Underlying_Full_View (Full), N, Result); + end if; + + Freeze_And_Append (Full, N, Result); + + if Has_Delayed_Freeze (E) then + F_Node := Freeze_Node (Full); + + if Present (F_Node) then + Set_Freeze_Node (E, F_Node); + Set_Entity (F_Node, E); + + else + -- {Incomplete,Private}_Subtypes with Full_Views + -- constrained by discriminants. + + Set_Has_Delayed_Freeze (E, False); + Set_Freeze_Node (E, Empty); + end if; + end if; + end; + + Check_Debug_Info_Needed (E); + end if; + + -- AI-117 requires that the convention of a partial view be the + -- same as the convention of the full view. Note that this is a + -- recognized breach of privacy, but it's essential for logical + -- consistency of representation, and the lack of a rule in + -- RM95 was an oversight. + + Set_Convention (E, Convention (Full_View (E))); + + Set_Size_Known_At_Compile_Time (E, + Size_Known_At_Compile_Time (Full_View (E))); + + -- Size information is copied from the full view to the + -- incomplete or private view for consistency. + + -- We skip this is the full view is not a type. This is very + -- strange of course, and can only happen as a result of + -- certain illegalities, such as a premature attempt to derive + -- from an incomplete type. + + if Is_Type (Full_View (E)) then + Set_Size_Info (E, Full_View (E)); + Set_RM_Size (E, RM_Size (Full_View (E))); + end if; + + return Result; + + -- Case of no full view present. If entity is derived or subtype, + -- it is safe to freeze, correctness depends on the frozen status + -- of parent. Otherwise it is either premature usage, or a Taft + -- amendment type, so diagnosis is at the point of use and the + -- type might be frozen later. + + elsif E /= Base_Type (E) + or else Is_Derived_Type (E) + then + null; + + else + Set_Is_Frozen (E, False); + return No_List; + end if; + + -- For access subprogram, freeze types of all formals, the return + -- type was already frozen, since it is the Etype of the function. + -- Formal types can be tagged Taft amendment types, but otherwise + -- they cannot be incomplete. + + elsif Ekind (E) = E_Subprogram_Type then + Formal := First_Formal (E); + while Present (Formal) loop + if Ekind (Etype (Formal)) = E_Incomplete_Type + and then No (Full_View (Etype (Formal))) + and then not Is_Value_Type (Etype (Formal)) + then + if Is_Tagged_Type (Etype (Formal)) then + null; + + -- AI05-151: Incomplete types are allowed in access to + -- subprogram specifications. + + elsif Ada_Version < Ada_2012 then + Error_Msg_NE + ("invalid use of incomplete type&", E, Etype (Formal)); + end if; + end if; + + Freeze_And_Append (Etype (Formal), N, Result); + Next_Formal (Formal); + end loop; + + Freeze_Subprogram (E); + + -- For access to a protected subprogram, freeze the equivalent type + -- (however this is not set if we are not generating code or if this + -- is an anonymous type used just for resolution). + + elsif Is_Access_Protected_Subprogram_Type (E) then + if Present (Equivalent_Type (E)) then + Freeze_And_Append (Equivalent_Type (E), N, Result); + end if; + end if; + + -- Generic types are never seen by the back-end, and are also not + -- processed by the expander (since the expander is turned off for + -- generic processing), so we never need freeze nodes for them. + + if Is_Generic_Type (E) then + return Result; + end if; + + -- Some special processing for non-generic types to complete + -- representation details not known till the freeze point. + + if Is_Fixed_Point_Type (E) then + Freeze_Fixed_Point_Type (E); + + -- Some error checks required for ordinary fixed-point type. Defer + -- these till the freeze-point since we need the small and range + -- values. We only do these checks for base types + + if Is_Ordinary_Fixed_Point_Type (E) and then Is_Base_Type (E) then + if Small_Value (E) < Ureal_2_M_80 then + Error_Msg_Name_1 := Name_Small; + Error_Msg_N + ("`&''%` too small, minimum allowed is 2.0'*'*(-80)", E); + + elsif Small_Value (E) > Ureal_2_80 then + Error_Msg_Name_1 := Name_Small; + Error_Msg_N + ("`&''%` too large, maximum allowed is 2.0'*'*80", E); + end if; + + if Expr_Value_R (Type_Low_Bound (E)) < Ureal_M_10_36 then + Error_Msg_Name_1 := Name_First; + Error_Msg_N + ("`&''%` too small, minimum allowed is -10.0'*'*36", E); + end if; + + if Expr_Value_R (Type_High_Bound (E)) > Ureal_10_36 then + Error_Msg_Name_1 := Name_Last; + Error_Msg_N + ("`&''%` too large, maximum allowed is 10.0'*'*36", E); + end if; + end if; + + elsif Is_Enumeration_Type (E) then + Freeze_Enumeration_Type (E); + + elsif Is_Integer_Type (E) then + Adjust_Esize_For_Alignment (E); + + if Is_Modular_Integer_Type (E) + and then Warn_On_Suspicious_Modulus_Value + then + Check_Suspicious_Modulus (E); + end if; + + elsif Is_Access_Type (E) then + + -- If a pragma Default_Storage_Pool applies, and this type has no + -- Storage_Pool or Storage_Size clause (which must have occurred + -- before the freezing point), then use the default. This applies + -- only to base types. + + if Present (Default_Pool) + and then Is_Base_Type (E) + and then not Has_Storage_Size_Clause (E) + and then No (Associated_Storage_Pool (E)) + then + -- Case of pragma Default_Storage_Pool (null) + + if Nkind (Default_Pool) = N_Null then + Set_No_Pool_Assigned (E); + + -- Case of pragma Default_Storage_Pool (storage_pool_NAME) + + else + Set_Associated_Storage_Pool (E, Entity (Default_Pool)); + end if; + end if; + + -- Check restriction for standard storage pool + + if No (Associated_Storage_Pool (E)) then + Check_Restriction (No_Standard_Storage_Pools, E); + end if; + + -- Deal with error message for pure access type. This is not an + -- error in Ada 2005 if there is no pool (see AI-366). + + if Is_Pure_Unit_Access_Type (E) + and then (Ada_Version < Ada_2005 + or else not No_Pool_Assigned (E)) + then + Error_Msg_N ("named access type not allowed in pure unit", E); + + if Ada_Version >= Ada_2005 then + Error_Msg_N + ("\would be legal if Storage_Size of 0 given?", E); + + elsif No_Pool_Assigned (E) then + Error_Msg_N + ("\would be legal in Ada 2005?", E); + + else + Error_Msg_N + ("\would be legal in Ada 2005 if " + & "Storage_Size of 0 given?", E); + end if; + end if; + end if; + + -- Case of composite types + + if Is_Composite_Type (E) then + + -- AI-117 requires that all new primitives of a tagged type must + -- inherit the convention of the full view of the type. Inherited + -- and overriding operations are defined to inherit the convention + -- of their parent or overridden subprogram (also specified in + -- AI-117), which will have occurred earlier (in Derive_Subprogram + -- and New_Overloaded_Entity). Here we set the convention of + -- primitives that are still convention Ada, which will ensure + -- that any new primitives inherit the type's convention. Class- + -- wide types can have a foreign convention inherited from their + -- specific type, but are excluded from this since they don't have + -- any associated primitives. + + if Is_Tagged_Type (E) + and then not Is_Class_Wide_Type (E) + and then Convention (E) /= Convention_Ada + then + declare + Prim_List : constant Elist_Id := Primitive_Operations (E); + Prim : Elmt_Id; + + begin + Prim := First_Elmt (Prim_List); + while Present (Prim) loop + if Convention (Node (Prim)) = Convention_Ada then + Set_Convention (Node (Prim), Convention (E)); + end if; + + Next_Elmt (Prim); + end loop; + end; + end if; + end if; + + -- Now that all types from which E may depend are frozen, see if the + -- size is known at compile time, if it must be unsigned, or if + -- strict alignment is required + + Check_Compile_Time_Size (E); + Check_Unsigned_Type (E); + + if Base_Type (E) = E then + Check_Strict_Alignment (E); + end if; + + -- Do not allow a size clause for a type which does not have a size + -- that is known at compile time + + if Has_Size_Clause (E) + and then not Size_Known_At_Compile_Time (E) + then + -- Suppress this message if errors posted on E, even if we are + -- in all errors mode, since this is often a junk message + + if not Error_Posted (E) then + Error_Msg_N + ("size clause not allowed for variable length type", + Size_Clause (E)); + end if; + end if; + + -- Remaining process is to set/verify the representation information, + -- in particular the size and alignment values. This processing is + -- not required for generic types, since generic types do not play + -- any part in code generation, and so the size and alignment values + -- for such types are irrelevant. + + if Is_Generic_Type (E) then + return Result; + + -- Otherwise we call the layout procedure + + else + Layout_Type (E); + end if; + + -- End of freeze processing for type entities + end if; + + -- Here is where we logically freeze the current entity. If it has a + -- freeze node, then this is the point at which the freeze node is + -- linked into the result list. + + if Has_Delayed_Freeze (E) then + + -- If a freeze node is already allocated, use it, otherwise allocate + -- a new one. The preallocation happens in the case of anonymous base + -- types, where we preallocate so that we can set First_Subtype_Link. + -- Note that we reset the Sloc to the current freeze location. + + if Present (Freeze_Node (E)) then + F_Node := Freeze_Node (E); + Set_Sloc (F_Node, Loc); + + else + F_Node := New_Node (N_Freeze_Entity, Loc); + Set_Freeze_Node (E, F_Node); + Set_Access_Types_To_Process (F_Node, No_Elist); + Set_TSS_Elist (F_Node, No_Elist); + Set_Actions (F_Node, No_List); + end if; + + Set_Entity (F_Node, E); + + if Result = No_List then + Result := New_List (F_Node); + else + Append (F_Node, Result); + end if; + + -- A final pass over record types with discriminants. If the type + -- has an incomplete declaration, there may be constrained access + -- subtypes declared elsewhere, which do not depend on the discrimi- + -- nants of the type, and which are used as component types (i.e. + -- the full view is a recursive type). The designated types of these + -- subtypes can only be elaborated after the type itself, and they + -- need an itype reference. + + if Ekind (E) = E_Record_Type + and then Has_Discriminants (E) + then + declare + Comp : Entity_Id; + IR : Node_Id; + Typ : Entity_Id; + + begin + Comp := First_Component (E); + while Present (Comp) loop + Typ := Etype (Comp); + + if Ekind (Comp) = E_Component + and then Is_Access_Type (Typ) + and then Scope (Typ) /= E + and then Base_Type (Designated_Type (Typ)) = E + and then Is_Itype (Designated_Type (Typ)) + then + IR := Make_Itype_Reference (Sloc (Comp)); + Set_Itype (IR, Designated_Type (Typ)); + Append (IR, Result); + end if; + + Next_Component (Comp); + end loop; + end; + end if; + end if; + + -- When a type is frozen, the first subtype of the type is frozen as + -- well (RM 13.14(15)). This has to be done after freezing the type, + -- since obviously the first subtype depends on its own base type. + + if Is_Type (E) then + Freeze_And_Append (First_Subtype (E), N, Result); + + -- If we just froze a tagged non-class wide record, then freeze the + -- corresponding class-wide type. This must be done after the tagged + -- type itself is frozen, because the class-wide type refers to the + -- tagged type which generates the class. + + if Is_Tagged_Type (E) + and then not Is_Class_Wide_Type (E) + and then Present (Class_Wide_Type (E)) + then + Freeze_And_Append (Class_Wide_Type (E), N, Result); + end if; + end if; + + Check_Debug_Info_Needed (E); + + -- Special handling for subprograms + + if Is_Subprogram (E) then + + -- If subprogram has address clause then reset Is_Public flag, since + -- we do not want the backend to generate external references. + + if Present (Address_Clause (E)) + and then not Is_Library_Level_Entity (E) + then + Set_Is_Public (E, False); + + -- If no address clause and not intrinsic, then for imported + -- subprogram in main unit, generate descriptor if we are in + -- Propagate_Exceptions mode. + + elsif Propagate_Exceptions + and then Is_Imported (E) + and then not Is_Intrinsic_Subprogram (E) + and then Convention (E) /= Convention_Stubbed + then + if Result = No_List then + Result := Empty_List; + end if; + end if; + end if; + + return Result; + end Freeze_Entity; + + ----------------------------- + -- Freeze_Enumeration_Type -- + ----------------------------- + + procedure Freeze_Enumeration_Type (Typ : Entity_Id) is + begin + -- By default, if no size clause is present, an enumeration type with + -- Convention C is assumed to interface to a C enum, and has integer + -- size. This applies to types. For subtypes, verify that its base + -- type has no size clause either. + + if Has_Foreign_Convention (Typ) + and then not Has_Size_Clause (Typ) + and then not Has_Size_Clause (Base_Type (Typ)) + and then Esize (Typ) < Standard_Integer_Size + then + Init_Esize (Typ, Standard_Integer_Size); + + else + -- If the enumeration type interfaces to C, and it has a size clause + -- that specifies less than int size, it warrants a warning. The + -- user may intend the C type to be an enum or a char, so this is + -- not by itself an error that the Ada compiler can detect, but it + -- it is a worth a heads-up. For Boolean and Character types we + -- assume that the programmer has the proper C type in mind. + + if Convention (Typ) = Convention_C + and then Has_Size_Clause (Typ) + and then Esize (Typ) /= Esize (Standard_Integer) + and then not Is_Boolean_Type (Typ) + and then not Is_Character_Type (Typ) + then + Error_Msg_N + ("C enum types have the size of a C int?", Size_Clause (Typ)); + end if; + + Adjust_Esize_For_Alignment (Typ); + end if; + end Freeze_Enumeration_Type; + + ----------------------- + -- Freeze_Expression -- + ----------------------- + + procedure Freeze_Expression (N : Node_Id) is + In_Spec_Exp : constant Boolean := In_Spec_Expression; + Typ : Entity_Id; + Nam : Entity_Id; + Desig_Typ : Entity_Id; + P : Node_Id; + Parent_P : Node_Id; + + Freeze_Outside : Boolean := False; + -- This flag is set true if the entity must be frozen outside the + -- current subprogram. This happens in the case of expander generated + -- subprograms (_Init_Proc, _Input, _Output, _Read, _Write) which do + -- not freeze all entities like other bodies, but which nevertheless + -- may reference entities that have to be frozen before the body and + -- obviously cannot be frozen inside the body. + + function In_Exp_Body (N : Node_Id) return Boolean; + -- Given an N_Handled_Sequence_Of_Statements node N, determines whether + -- it is the handled statement sequence of an expander-generated + -- subprogram (init proc, stream subprogram, or renaming as body). + -- If so, this is not a freezing context. + + ----------------- + -- In_Exp_Body -- + ----------------- + + function In_Exp_Body (N : Node_Id) return Boolean is + P : Node_Id; + Id : Entity_Id; + + begin + if Nkind (N) = N_Subprogram_Body then + P := N; + else + P := Parent (N); + end if; + + if Nkind (P) /= N_Subprogram_Body then + return False; + + else + Id := Defining_Unit_Name (Specification (P)); + + if Nkind (Id) = N_Defining_Identifier + and then (Is_Init_Proc (Id) or else + Is_TSS (Id, TSS_Stream_Input) or else + Is_TSS (Id, TSS_Stream_Output) or else + Is_TSS (Id, TSS_Stream_Read) or else + Is_TSS (Id, TSS_Stream_Write) or else + Nkind (Original_Node (P)) = + N_Subprogram_Renaming_Declaration) + then + return True; + else + return False; + end if; + end if; + end In_Exp_Body; + + -- Start of processing for Freeze_Expression + + begin + -- Immediate return if freezing is inhibited. This flag is set by the + -- analyzer to stop freezing on generated expressions that would cause + -- freezing if they were in the source program, but which are not + -- supposed to freeze, since they are created. + + if Must_Not_Freeze (N) then + return; + end if; + + -- If expression is non-static, then it does not freeze in a default + -- expression, see section "Handling of Default Expressions" in the + -- spec of package Sem for further details. Note that we have to + -- make sure that we actually have a real expression (if we have + -- a subtype indication, we can't test Is_Static_Expression!) + + if In_Spec_Exp + and then Nkind (N) in N_Subexpr + and then not Is_Static_Expression (N) + then + return; + end if; + + -- Freeze type of expression if not frozen already + + Typ := Empty; + + if Nkind (N) in N_Has_Etype then + if not Is_Frozen (Etype (N)) then + Typ := Etype (N); + + -- Base type may be an derived numeric type that is frozen at + -- the point of declaration, but first_subtype is still unfrozen. + + elsif not Is_Frozen (First_Subtype (Etype (N))) then + Typ := First_Subtype (Etype (N)); + end if; + end if; + + -- For entity name, freeze entity if not frozen already. A special + -- exception occurs for an identifier that did not come from source. + -- We don't let such identifiers freeze a non-internal entity, i.e. + -- an entity that did come from source, since such an identifier was + -- generated by the expander, and cannot have any semantic effect on + -- the freezing semantics. For example, this stops the parameter of + -- an initialization procedure from freezing the variable. + + if Is_Entity_Name (N) + and then not Is_Frozen (Entity (N)) + and then (Nkind (N) /= N_Identifier + or else Comes_From_Source (N) + or else not Comes_From_Source (Entity (N))) + then + Nam := Entity (N); + else + Nam := Empty; + end if; + + -- For an allocator freeze designated type if not frozen already + + -- For an aggregate whose component type is an access type, freeze the + -- designated type now, so that its freeze does not appear within the + -- loop that might be created in the expansion of the aggregate. If the + -- designated type is a private type without full view, the expression + -- cannot contain an allocator, so the type is not frozen. + + -- For a function, we freeze the entity when the subprogram declaration + -- is frozen, but a function call may appear in an initialization proc. + -- before the declaration is frozen. We need to generate the extra + -- formals, if any, to ensure that the expansion of the call includes + -- the proper actuals. This only applies to Ada subprograms, not to + -- imported ones. + + Desig_Typ := Empty; + + case Nkind (N) is + when N_Allocator => + Desig_Typ := Designated_Type (Etype (N)); + + when N_Aggregate => + if Is_Array_Type (Etype (N)) + and then Is_Access_Type (Component_Type (Etype (N))) + then + Desig_Typ := Designated_Type (Component_Type (Etype (N))); + end if; + + when N_Selected_Component | + N_Indexed_Component | + N_Slice => + + if Is_Access_Type (Etype (Prefix (N))) then + Desig_Typ := Designated_Type (Etype (Prefix (N))); + end if; + + when N_Identifier => + if Present (Nam) + and then Ekind (Nam) = E_Function + and then Nkind (Parent (N)) = N_Function_Call + and then Convention (Nam) = Convention_Ada + then + Create_Extra_Formals (Nam); + end if; + + when others => + null; + end case; + + if Desig_Typ /= Empty + and then (Is_Frozen (Desig_Typ) + or else (not Is_Fully_Defined (Desig_Typ))) + then + Desig_Typ := Empty; + end if; + + -- All done if nothing needs freezing + + if No (Typ) + and then No (Nam) + and then No (Desig_Typ) + then + return; + end if; + + -- Loop for looking at the right place to insert the freeze nodes, + -- exiting from the loop when it is appropriate to insert the freeze + -- node before the current node P. + + -- Also checks some special exceptions to the freezing rules. These + -- cases result in a direct return, bypassing the freeze action. + + P := N; + loop + Parent_P := Parent (P); + + -- If we don't have a parent, then we are not in a well-formed tree. + -- This is an unusual case, but there are some legitimate situations + -- in which this occurs, notably when the expressions in the range of + -- a type declaration are resolved. We simply ignore the freeze + -- request in this case. Is this right ??? + + if No (Parent_P) then + return; + end if; + + -- See if we have got to an appropriate point in the tree + + case Nkind (Parent_P) is + + -- A special test for the exception of (RM 13.14(8)) for the case + -- of per-object expressions (RM 3.8(18)) occurring in component + -- definition or a discrete subtype definition. Note that we test + -- for a component declaration which includes both cases we are + -- interested in, and furthermore the tree does not have explicit + -- nodes for either of these two constructs. + + when N_Component_Declaration => + + -- The case we want to test for here is an identifier that is + -- a per-object expression, this is either a discriminant that + -- appears in a context other than the component declaration + -- or it is a reference to the type of the enclosing construct. + + -- For either of these cases, we skip the freezing + + if not In_Spec_Expression + and then Nkind (N) = N_Identifier + and then (Present (Entity (N))) + then + -- We recognize the discriminant case by just looking for + -- a reference to a discriminant. It can only be one for + -- the enclosing construct. Skip freezing in this case. + + if Ekind (Entity (N)) = E_Discriminant then + return; + + -- For the case of a reference to the enclosing record, + -- (or task or protected type), we look for a type that + -- matches the current scope. + + elsif Entity (N) = Current_Scope then + return; + end if; + end if; + + -- If we have an enumeration literal that appears as the choice in + -- the aggregate of an enumeration representation clause, then + -- freezing does not occur (RM 13.14(10)). + + when N_Enumeration_Representation_Clause => + + -- The case we are looking for is an enumeration literal + + if (Nkind (N) = N_Identifier or Nkind (N) = N_Character_Literal) + and then Is_Enumeration_Type (Etype (N)) + then + -- If enumeration literal appears directly as the choice, + -- do not freeze (this is the normal non-overloaded case) + + if Nkind (Parent (N)) = N_Component_Association + and then First (Choices (Parent (N))) = N + then + return; + + -- If enumeration literal appears as the name of function + -- which is the choice, then also do not freeze. This + -- happens in the overloaded literal case, where the + -- enumeration literal is temporarily changed to a function + -- call for overloading analysis purposes. + + elsif Nkind (Parent (N)) = N_Function_Call + and then + Nkind (Parent (Parent (N))) = N_Component_Association + and then + First (Choices (Parent (Parent (N)))) = Parent (N) + then + return; + end if; + end if; + + -- Normally if the parent is a handled sequence of statements, + -- then the current node must be a statement, and that is an + -- appropriate place to insert a freeze node. + + when N_Handled_Sequence_Of_Statements => + + -- An exception occurs when the sequence of statements is for + -- an expander generated body that did not do the usual freeze + -- all operation. In this case we usually want to freeze + -- outside this body, not inside it, and we skip past the + -- subprogram body that we are inside. + + if In_Exp_Body (Parent_P) then + + -- However, we *do* want to freeze at this point if we have + -- an entity to freeze, and that entity is declared *inside* + -- the body of the expander generated procedure. This case + -- is recognized by the scope of the type, which is either + -- the spec for some enclosing body, or (in the case of + -- init_procs, for which there are no separate specs) the + -- current scope. + + declare + Subp : constant Node_Id := Parent (Parent_P); + Cspc : Entity_Id; + + begin + if Nkind (Subp) = N_Subprogram_Body then + Cspc := Corresponding_Spec (Subp); + + if (Present (Typ) and then Scope (Typ) = Cspc) + or else + (Present (Nam) and then Scope (Nam) = Cspc) + then + exit; + + elsif Present (Typ) + and then Scope (Typ) = Current_Scope + and then Current_Scope = Defining_Entity (Subp) + then + exit; + end if; + end if; + end; + + -- If not that exception to the exception, then this is + -- where we delay the freeze till outside the body. + + Parent_P := Parent (Parent_P); + Freeze_Outside := True; + + -- Here if normal case where we are in handled statement + -- sequence and want to do the insertion right there. + + else + exit; + end if; + + -- If parent is a body or a spec or a block, then the current node + -- is a statement or declaration and we can insert the freeze node + -- before it. + + when N_Package_Specification | + N_Package_Body | + N_Subprogram_Body | + N_Task_Body | + N_Protected_Body | + N_Entry_Body | + N_Block_Statement => exit; + + -- The expander is allowed to define types in any statements list, + -- so any of the following parent nodes also mark a freezing point + -- if the actual node is in a list of statements or declarations. + + when N_Exception_Handler | + N_If_Statement | + N_Elsif_Part | + N_Case_Statement_Alternative | + N_Compilation_Unit_Aux | + N_Selective_Accept | + N_Accept_Alternative | + N_Delay_Alternative | + N_Conditional_Entry_Call | + N_Entry_Call_Alternative | + N_Triggering_Alternative | + N_Abortable_Part | + N_And_Then | + N_Or_Else | + N_Freeze_Entity => + + exit when Is_List_Member (P); + + -- Note: The N_Loop_Statement is a special case. A type that + -- appears in the source can never be frozen in a loop (this + -- occurs only because of a loop expanded by the expander), so we + -- keep on going. Otherwise we terminate the search. Same is true + -- of any entity which comes from source. (if they have predefined + -- type, that type does not appear to come from source, but the + -- entity should not be frozen here). + + when N_Loop_Statement => + exit when not Comes_From_Source (Etype (N)) + and then (No (Nam) or else not Comes_From_Source (Nam)); + + -- For all other cases, keep looking at parents + + when others => + null; + end case; + + -- We fall through the case if we did not yet find the proper + -- place in the free for inserting the freeze node, so climb! + + P := Parent_P; + end loop; + + -- If the expression appears in a record or an initialization procedure, + -- the freeze nodes are collected and attached to the current scope, to + -- be inserted and analyzed on exit from the scope, to insure that + -- generated entities appear in the correct scope. If the expression is + -- a default for a discriminant specification, the scope is still void. + -- The expression can also appear in the discriminant part of a private + -- or concurrent type. + + -- If the expression appears in a constrained subcomponent of an + -- enclosing record declaration, the freeze nodes must be attached to + -- the outer record type so they can eventually be placed in the + -- enclosing declaration list. + + -- The other case requiring this special handling is if we are in a + -- default expression, since in that case we are about to freeze a + -- static type, and the freeze scope needs to be the outer scope, not + -- the scope of the subprogram with the default parameter. + + -- For default expressions and other spec expressions in generic units, + -- the Move_Freeze_Nodes mechanism (see sem_ch12.adb) takes care of + -- placing them at the proper place, after the generic unit. + + if (In_Spec_Exp and not Inside_A_Generic) + or else Freeze_Outside + or else (Is_Type (Current_Scope) + and then (not Is_Concurrent_Type (Current_Scope) + or else not Has_Completion (Current_Scope))) + or else Ekind (Current_Scope) = E_Void + then + declare + N : constant Node_Id := Current_Scope; + Freeze_Nodes : List_Id := No_List; + Pos : Int := Scope_Stack.Last; + + begin + if Present (Desig_Typ) then + Freeze_And_Append (Desig_Typ, N, Freeze_Nodes); + end if; + + if Present (Typ) then + Freeze_And_Append (Typ, N, Freeze_Nodes); + end if; + + if Present (Nam) then + Freeze_And_Append (Nam, N, Freeze_Nodes); + end if; + + -- The current scope may be that of a constrained component of + -- an enclosing record declaration, which is above the current + -- scope in the scope stack. + -- If the expression is within a top-level pragma, as for a pre- + -- condition on a library-level subprogram, nothing to do. + + if not Is_Compilation_Unit (Current_Scope) + and then Is_Record_Type (Scope (Current_Scope)) + then + Pos := Pos - 1; + end if; + + if Is_Non_Empty_List (Freeze_Nodes) then + if No (Scope_Stack.Table (Pos).Pending_Freeze_Actions) then + Scope_Stack.Table (Pos).Pending_Freeze_Actions := + Freeze_Nodes; + else + Append_List (Freeze_Nodes, + Scope_Stack.Table (Pos).Pending_Freeze_Actions); + end if; + end if; + end; + + return; + end if; + + -- Now we have the right place to do the freezing. First, a special + -- adjustment, if we are in spec-expression analysis mode, these freeze + -- actions must not be thrown away (normally all inserted actions are + -- thrown away in this mode. However, the freeze actions are from static + -- expressions and one of the important reasons we are doing this + -- special analysis is to get these freeze actions. Therefore we turn + -- off the In_Spec_Expression mode to propagate these freeze actions. + -- This also means they get properly analyzed and expanded. + + In_Spec_Expression := False; + + -- Freeze the designated type of an allocator (RM 13.14(13)) + + if Present (Desig_Typ) then + Freeze_Before (P, Desig_Typ); + end if; + + -- Freeze type of expression (RM 13.14(10)). Note that we took care of + -- the enumeration representation clause exception in the loop above. + + if Present (Typ) then + Freeze_Before (P, Typ); + end if; + + -- Freeze name if one is present (RM 13.14(11)) + + if Present (Nam) then + Freeze_Before (P, Nam); + end if; + + -- Restore In_Spec_Expression flag + + In_Spec_Expression := In_Spec_Exp; + end Freeze_Expression; + + ----------------------------- + -- Freeze_Fixed_Point_Type -- + ----------------------------- + + -- Certain fixed-point types and subtypes, including implicit base types + -- and declared first subtypes, have not yet set up a range. This is + -- because the range cannot be set until the Small and Size values are + -- known, and these are not known till the type is frozen. + + -- To signal this case, Scalar_Range contains an unanalyzed syntactic range + -- whose bounds are unanalyzed real literals. This routine will recognize + -- this case, and transform this range node into a properly typed range + -- with properly analyzed and resolved values. + + procedure Freeze_Fixed_Point_Type (Typ : Entity_Id) is + Rng : constant Node_Id := Scalar_Range (Typ); + Lo : constant Node_Id := Low_Bound (Rng); + Hi : constant Node_Id := High_Bound (Rng); + Btyp : constant Entity_Id := Base_Type (Typ); + Brng : constant Node_Id := Scalar_Range (Btyp); + BLo : constant Node_Id := Low_Bound (Brng); + BHi : constant Node_Id := High_Bound (Brng); + Small : constant Ureal := Small_Value (Typ); + Loval : Ureal; + Hival : Ureal; + Atype : Entity_Id; + + Actual_Size : Nat; + + function Fsize (Lov, Hiv : Ureal) return Nat; + -- Returns size of type with given bounds. Also leaves these + -- bounds set as the current bounds of the Typ. + + ----------- + -- Fsize -- + ----------- + + function Fsize (Lov, Hiv : Ureal) return Nat is + begin + Set_Realval (Lo, Lov); + Set_Realval (Hi, Hiv); + return Minimum_Size (Typ); + end Fsize; + + -- Start of processing for Freeze_Fixed_Point_Type + + begin + -- If Esize of a subtype has not previously been set, set it now + + if Unknown_Esize (Typ) then + Atype := Ancestor_Subtype (Typ); + + if Present (Atype) then + Set_Esize (Typ, Esize (Atype)); + else + Set_Esize (Typ, Esize (Base_Type (Typ))); + end if; + end if; + + -- Immediate return if the range is already analyzed. This means that + -- the range is already set, and does not need to be computed by this + -- routine. + + if Analyzed (Rng) then + return; + end if; + + -- Immediate return if either of the bounds raises Constraint_Error + + if Raises_Constraint_Error (Lo) + or else Raises_Constraint_Error (Hi) + then + return; + end if; + + Loval := Realval (Lo); + Hival := Realval (Hi); + + -- Ordinary fixed-point case + + if Is_Ordinary_Fixed_Point_Type (Typ) then + + -- For the ordinary fixed-point case, we are allowed to fudge the + -- end-points up or down by small. Generally we prefer to fudge up, + -- i.e. widen the bounds for non-model numbers so that the end points + -- are included. However there are cases in which this cannot be + -- done, and indeed cases in which we may need to narrow the bounds. + -- The following circuit makes the decision. + + -- Note: our terminology here is that Incl_EP means that the bounds + -- are widened by Small if necessary to include the end points, and + -- Excl_EP means that the bounds are narrowed by Small to exclude the + -- end-points if this reduces the size. + + -- Note that in the Incl case, all we care about is including the + -- end-points. In the Excl case, we want to narrow the bounds as + -- much as permitted by the RM, to give the smallest possible size. + + Fudge : declare + Loval_Incl_EP : Ureal; + Hival_Incl_EP : Ureal; + + Loval_Excl_EP : Ureal; + Hival_Excl_EP : Ureal; + + Size_Incl_EP : Nat; + Size_Excl_EP : Nat; + + Model_Num : Ureal; + First_Subt : Entity_Id; + Actual_Lo : Ureal; + Actual_Hi : Ureal; + + begin + -- First step. Base types are required to be symmetrical. Right + -- now, the base type range is a copy of the first subtype range. + -- This will be corrected before we are done, but right away we + -- need to deal with the case where both bounds are non-negative. + -- In this case, we set the low bound to the negative of the high + -- bound, to make sure that the size is computed to include the + -- required sign. Note that we do not need to worry about the + -- case of both bounds negative, because the sign will be dealt + -- with anyway. Furthermore we can't just go making such a bound + -- symmetrical, since in a twos-complement system, there is an + -- extra negative value which could not be accommodated on the + -- positive side. + + if Typ = Btyp + and then not UR_Is_Negative (Loval) + and then Hival > Loval + then + Loval := -Hival; + Set_Realval (Lo, Loval); + end if; + + -- Compute the fudged bounds. If the number is a model number, + -- then we do nothing to include it, but we are allowed to backoff + -- to the next adjacent model number when we exclude it. If it is + -- not a model number then we straddle the two values with the + -- model numbers on either side. + + Model_Num := UR_Trunc (Loval / Small) * Small; + + if Loval = Model_Num then + Loval_Incl_EP := Model_Num; + else + Loval_Incl_EP := Model_Num - Small; + end if; + + -- The low value excluding the end point is Small greater, but + -- we do not do this exclusion if the low value is positive, + -- since it can't help the size and could actually hurt by + -- crossing the high bound. + + if UR_Is_Negative (Loval_Incl_EP) then + Loval_Excl_EP := Loval_Incl_EP + Small; + + -- If the value went from negative to zero, then we have the + -- case where Loval_Incl_EP is the model number just below + -- zero, so we want to stick to the negative value for the + -- base type to maintain the condition that the size will + -- include signed values. + + if Typ = Btyp + and then UR_Is_Zero (Loval_Excl_EP) + then + Loval_Excl_EP := Loval_Incl_EP; + end if; + + else + Loval_Excl_EP := Loval_Incl_EP; + end if; + + -- Similar processing for upper bound and high value + + Model_Num := UR_Trunc (Hival / Small) * Small; + + if Hival = Model_Num then + Hival_Incl_EP := Model_Num; + else + Hival_Incl_EP := Model_Num + Small; + end if; + + if UR_Is_Positive (Hival_Incl_EP) then + Hival_Excl_EP := Hival_Incl_EP - Small; + else + Hival_Excl_EP := Hival_Incl_EP; + end if; + + -- One further adjustment is needed. In the case of subtypes, we + -- cannot go outside the range of the base type, or we get + -- peculiarities, and the base type range is already set. This + -- only applies to the Incl values, since clearly the Excl values + -- are already as restricted as they are allowed to be. + + if Typ /= Btyp then + Loval_Incl_EP := UR_Max (Loval_Incl_EP, Realval (BLo)); + Hival_Incl_EP := UR_Min (Hival_Incl_EP, Realval (BHi)); + end if; + + -- Get size including and excluding end points + + Size_Incl_EP := Fsize (Loval_Incl_EP, Hival_Incl_EP); + Size_Excl_EP := Fsize (Loval_Excl_EP, Hival_Excl_EP); + + -- No need to exclude end-points if it does not reduce size + + if Fsize (Loval_Incl_EP, Hival_Excl_EP) = Size_Excl_EP then + Loval_Excl_EP := Loval_Incl_EP; + end if; + + if Fsize (Loval_Excl_EP, Hival_Incl_EP) = Size_Excl_EP then + Hival_Excl_EP := Hival_Incl_EP; + end if; + + -- Now we set the actual size to be used. We want to use the + -- bounds fudged up to include the end-points but only if this + -- can be done without violating a specifically given size + -- size clause or causing an unacceptable increase in size. + + -- Case of size clause given + + if Has_Size_Clause (Typ) then + + -- Use the inclusive size only if it is consistent with + -- the explicitly specified size. + + if Size_Incl_EP <= RM_Size (Typ) then + Actual_Lo := Loval_Incl_EP; + Actual_Hi := Hival_Incl_EP; + Actual_Size := Size_Incl_EP; + + -- If the inclusive size is too large, we try excluding + -- the end-points (will be caught later if does not work). + + else + Actual_Lo := Loval_Excl_EP; + Actual_Hi := Hival_Excl_EP; + Actual_Size := Size_Excl_EP; + end if; + + -- Case of size clause not given + + else + -- If we have a base type whose corresponding first subtype + -- has an explicit size that is large enough to include our + -- end-points, then do so. There is no point in working hard + -- to get a base type whose size is smaller than the specified + -- size of the first subtype. + + First_Subt := First_Subtype (Typ); + + if Has_Size_Clause (First_Subt) + and then Size_Incl_EP <= Esize (First_Subt) + then + Actual_Size := Size_Incl_EP; + Actual_Lo := Loval_Incl_EP; + Actual_Hi := Hival_Incl_EP; + + -- If excluding the end-points makes the size smaller and + -- results in a size of 8,16,32,64, then we take the smaller + -- size. For the 64 case, this is compulsory. For the other + -- cases, it seems reasonable. We like to include end points + -- if we can, but not at the expense of moving to the next + -- natural boundary of size. + + elsif Size_Incl_EP /= Size_Excl_EP + and then Addressable (Size_Excl_EP) + then + Actual_Size := Size_Excl_EP; + Actual_Lo := Loval_Excl_EP; + Actual_Hi := Hival_Excl_EP; + + -- Otherwise we can definitely include the end points + + else + Actual_Size := Size_Incl_EP; + Actual_Lo := Loval_Incl_EP; + Actual_Hi := Hival_Incl_EP; + end if; + + -- One pathological case: normally we never fudge a low bound + -- down, since it would seem to increase the size (if it has + -- any effect), but for ranges containing single value, or no + -- values, the high bound can be small too large. Consider: + + -- type t is delta 2.0**(-14) + -- range 131072.0 .. 0; + + -- That lower bound is *just* outside the range of 32 bits, and + -- does need fudging down in this case. Note that the bounds + -- will always have crossed here, since the high bound will be + -- fudged down if necessary, as in the case of: + + -- type t is delta 2.0**(-14) + -- range 131072.0 .. 131072.0; + + -- So we detect the situation by looking for crossed bounds, + -- and if the bounds are crossed, and the low bound is greater + -- than zero, we will always back it off by small, since this + -- is completely harmless. + + if Actual_Lo > Actual_Hi then + if UR_Is_Positive (Actual_Lo) then + Actual_Lo := Loval_Incl_EP - Small; + Actual_Size := Fsize (Actual_Lo, Actual_Hi); + + -- And of course, we need to do exactly the same parallel + -- fudge for flat ranges in the negative region. + + elsif UR_Is_Negative (Actual_Hi) then + Actual_Hi := Hival_Incl_EP + Small; + Actual_Size := Fsize (Actual_Lo, Actual_Hi); + end if; + end if; + end if; + + Set_Realval (Lo, Actual_Lo); + Set_Realval (Hi, Actual_Hi); + end Fudge; + + -- For the decimal case, none of this fudging is required, since there + -- are no end-point problems in the decimal case (the end-points are + -- always included). + + else + Actual_Size := Fsize (Loval, Hival); + end if; + + -- At this stage, the actual size has been calculated and the proper + -- required bounds are stored in the low and high bounds. + + if Actual_Size > 64 then + Error_Msg_Uint_1 := UI_From_Int (Actual_Size); + Error_Msg_N + ("size required (^) for type& too large, maximum allowed is 64", + Typ); + Actual_Size := 64; + end if; + + -- Check size against explicit given size + + if Has_Size_Clause (Typ) then + if Actual_Size > RM_Size (Typ) then + Error_Msg_Uint_1 := RM_Size (Typ); + Error_Msg_Uint_2 := UI_From_Int (Actual_Size); + Error_Msg_NE + ("size given (^) for type& too small, minimum allowed is ^", + Size_Clause (Typ), Typ); + + else + Actual_Size := UI_To_Int (Esize (Typ)); + end if; + + -- Increase size to next natural boundary if no size clause given + + else + if Actual_Size <= 8 then + Actual_Size := 8; + elsif Actual_Size <= 16 then + Actual_Size := 16; + elsif Actual_Size <= 32 then + Actual_Size := 32; + else + Actual_Size := 64; + end if; + + Init_Esize (Typ, Actual_Size); + Adjust_Esize_For_Alignment (Typ); + end if; + + -- If we have a base type, then expand the bounds so that they extend to + -- the full width of the allocated size in bits, to avoid junk range + -- checks on intermediate computations. + + if Base_Type (Typ) = Typ then + Set_Realval (Lo, -(Small * (Uint_2 ** (Actual_Size - 1)))); + Set_Realval (Hi, (Small * (Uint_2 ** (Actual_Size - 1) - 1))); + end if; + + -- Final step is to reanalyze the bounds using the proper type + -- and set the Corresponding_Integer_Value fields of the literals. + + Set_Etype (Lo, Empty); + Set_Analyzed (Lo, False); + Analyze (Lo); + + -- Resolve with universal fixed if the base type, and the base type if + -- it is a subtype. Note we can't resolve the base type with itself, + -- that would be a reference before definition. + + if Typ = Btyp then + Resolve (Lo, Universal_Fixed); + else + Resolve (Lo, Btyp); + end if; + + -- Set corresponding integer value for bound + + Set_Corresponding_Integer_Value + (Lo, UR_To_Uint (Realval (Lo) / Small)); + + -- Similar processing for high bound + + Set_Etype (Hi, Empty); + Set_Analyzed (Hi, False); + Analyze (Hi); + + if Typ = Btyp then + Resolve (Hi, Universal_Fixed); + else + Resolve (Hi, Btyp); + end if; + + Set_Corresponding_Integer_Value + (Hi, UR_To_Uint (Realval (Hi) / Small)); + + -- Set type of range to correspond to bounds + + Set_Etype (Rng, Etype (Lo)); + + -- Set Esize to calculated size if not set already + + if Unknown_Esize (Typ) then + Init_Esize (Typ, Actual_Size); + end if; + + -- Set RM_Size if not already set. If already set, check value + + declare + Minsiz : constant Uint := UI_From_Int (Minimum_Size (Typ)); + + begin + if RM_Size (Typ) /= Uint_0 then + if RM_Size (Typ) < Minsiz then + Error_Msg_Uint_1 := RM_Size (Typ); + Error_Msg_Uint_2 := Minsiz; + Error_Msg_NE + ("size given (^) for type& too small, minimum allowed is ^", + Size_Clause (Typ), Typ); + end if; + + else + Set_RM_Size (Typ, Minsiz); + end if; + end; + end Freeze_Fixed_Point_Type; + + ------------------ + -- Freeze_Itype -- + ------------------ + + procedure Freeze_Itype (T : Entity_Id; N : Node_Id) is + L : List_Id; + + begin + Set_Has_Delayed_Freeze (T); + L := Freeze_Entity (T, N); + + if Is_Non_Empty_List (L) then + Insert_Actions (N, L); + end if; + end Freeze_Itype; + + -------------------------- + -- Freeze_Static_Object -- + -------------------------- + + procedure Freeze_Static_Object (E : Entity_Id) is + + Cannot_Be_Static : exception; + -- Exception raised if the type of a static object cannot be made + -- static. This happens if the type depends on non-global objects. + + procedure Ensure_Expression_Is_SA (N : Node_Id); + -- Called to ensure that an expression used as part of a type definition + -- is statically allocatable, which means that the expression type is + -- statically allocatable, and the expression is either static, or a + -- reference to a library level constant. + + procedure Ensure_Type_Is_SA (Typ : Entity_Id); + -- Called to mark a type as static, checking that it is possible + -- to set the type as static. If it is not possible, then the + -- exception Cannot_Be_Static is raised. + + ----------------------------- + -- Ensure_Expression_Is_SA -- + ----------------------------- + + procedure Ensure_Expression_Is_SA (N : Node_Id) is + Ent : Entity_Id; + + begin + Ensure_Type_Is_SA (Etype (N)); + + if Is_Static_Expression (N) then + return; + + elsif Nkind (N) = N_Identifier then + Ent := Entity (N); + + if Present (Ent) + and then Ekind (Ent) = E_Constant + and then Is_Library_Level_Entity (Ent) + then + return; + end if; + end if; + + raise Cannot_Be_Static; + end Ensure_Expression_Is_SA; + + ----------------------- + -- Ensure_Type_Is_SA -- + ----------------------- + + procedure Ensure_Type_Is_SA (Typ : Entity_Id) is + N : Node_Id; + C : Entity_Id; + + begin + -- If type is library level, we are all set + + if Is_Library_Level_Entity (Typ) then + return; + end if; + + -- We are also OK if the type already marked as statically allocated, + -- which means we processed it before. + + if Is_Statically_Allocated (Typ) then + return; + end if; + + -- Mark type as statically allocated + + Set_Is_Statically_Allocated (Typ); + + -- Check that it is safe to statically allocate this type + + if Is_Scalar_Type (Typ) or else Is_Real_Type (Typ) then + Ensure_Expression_Is_SA (Type_Low_Bound (Typ)); + Ensure_Expression_Is_SA (Type_High_Bound (Typ)); + + elsif Is_Array_Type (Typ) then + N := First_Index (Typ); + while Present (N) loop + Ensure_Type_Is_SA (Etype (N)); + Next_Index (N); + end loop; + + Ensure_Type_Is_SA (Component_Type (Typ)); + + elsif Is_Access_Type (Typ) then + if Ekind (Designated_Type (Typ)) = E_Subprogram_Type then + + declare + F : Entity_Id; + T : constant Entity_Id := Etype (Designated_Type (Typ)); + + begin + if T /= Standard_Void_Type then + Ensure_Type_Is_SA (T); + end if; + + F := First_Formal (Designated_Type (Typ)); + while Present (F) loop + Ensure_Type_Is_SA (Etype (F)); + Next_Formal (F); + end loop; + end; + + else + Ensure_Type_Is_SA (Designated_Type (Typ)); + end if; + + elsif Is_Record_Type (Typ) then + C := First_Entity (Typ); + while Present (C) loop + if Ekind (C) = E_Discriminant + or else Ekind (C) = E_Component + then + Ensure_Type_Is_SA (Etype (C)); + + elsif Is_Type (C) then + Ensure_Type_Is_SA (C); + end if; + + Next_Entity (C); + end loop; + + elsif Ekind (Typ) = E_Subprogram_Type then + Ensure_Type_Is_SA (Etype (Typ)); + + C := First_Formal (Typ); + while Present (C) loop + Ensure_Type_Is_SA (Etype (C)); + Next_Formal (C); + end loop; + + else + raise Cannot_Be_Static; + end if; + end Ensure_Type_Is_SA; + + -- Start of processing for Freeze_Static_Object + + begin + Ensure_Type_Is_SA (Etype (E)); + + exception + when Cannot_Be_Static => + + -- If the object that cannot be static is imported or exported, then + -- issue an error message saying that this object cannot be imported + -- or exported. If it has an address clause it is an overlay in the + -- current partition and the static requirement is not relevant. + -- Do not issue any error message when ignoring rep clauses. + + if Ignore_Rep_Clauses then + null; + + elsif Is_Imported (E) then + if No (Address_Clause (E)) then + Error_Msg_N + ("& cannot be imported (local type is not constant)", E); + end if; + + -- Otherwise must be exported, something is wrong if compiler + -- is marking something as statically allocated which cannot be). + + else pragma Assert (Is_Exported (E)); + Error_Msg_N + ("& cannot be exported (local type is not constant)", E); + end if; + end Freeze_Static_Object; + + ----------------------- + -- Freeze_Subprogram -- + ----------------------- + + procedure Freeze_Subprogram (E : Entity_Id) is + Retype : Entity_Id; + F : Entity_Id; + + begin + -- Subprogram may not have an address clause unless it is imported + + if Present (Address_Clause (E)) then + if not Is_Imported (E) then + Error_Msg_N + ("address clause can only be given " & + "for imported subprogram", + Name (Address_Clause (E))); + end if; + end if; + + -- Reset the Pure indication on an imported subprogram unless an + -- explicit Pure_Function pragma was present. We do this because + -- otherwise it is an insidious error to call a non-pure function from + -- pure unit and have calls mysteriously optimized away. What happens + -- here is that the Import can bypass the normal check to ensure that + -- pure units call only pure subprograms. + + if Is_Imported (E) + and then Is_Pure (E) + and then not Has_Pragma_Pure_Function (E) + then + Set_Is_Pure (E, False); + end if; + + -- For non-foreign convention subprograms, this is where we create + -- the extra formals (for accessibility level and constrained bit + -- information). We delay this till the freeze point precisely so + -- that we know the convention! + + if not Has_Foreign_Convention (E) then + Create_Extra_Formals (E); + Set_Mechanisms (E); + + -- If this is convention Ada and a Valued_Procedure, that's odd + + if Ekind (E) = E_Procedure + and then Is_Valued_Procedure (E) + and then Convention (E) = Convention_Ada + and then Warn_On_Export_Import + then + Error_Msg_N + ("?Valued_Procedure has no effect for convention Ada", E); + Set_Is_Valued_Procedure (E, False); + end if; + + -- Case of foreign convention + + else + Set_Mechanisms (E); + + -- For foreign conventions, warn about return of an + -- unconstrained array. + + -- Note: we *do* allow a return by descriptor for the VMS case, + -- though here there is probably more to be done ??? + + if Ekind (E) = E_Function then + Retype := Underlying_Type (Etype (E)); + + -- If no return type, probably some other error, e.g. a + -- missing full declaration, so ignore. + + if No (Retype) then + null; + + -- If the return type is generic, we have emitted a warning + -- earlier on, and there is nothing else to check here. Specific + -- instantiations may lead to erroneous behavior. + + elsif Is_Generic_Type (Etype (E)) then + null; + + -- Display warning if returning unconstrained array + + elsif Is_Array_Type (Retype) + and then not Is_Constrained (Retype) + + -- Exclude cases where descriptor mechanism is set, since the + -- VMS descriptor mechanisms allow such unconstrained returns. + + and then Mechanism (E) not in Descriptor_Codes + + -- Check appropriate warning is enabled (should we check for + -- Warnings (Off) on specific entities here, probably so???) + + and then Warn_On_Export_Import + + -- Exclude the VM case, since return of unconstrained arrays + -- is properly handled in both the JVM and .NET cases. + + and then VM_Target = No_VM + then + Error_Msg_N + ("?foreign convention function& should not return " & + "unconstrained array", E); + return; + end if; + end if; + + -- If any of the formals for an exported foreign convention + -- subprogram have defaults, then emit an appropriate warning since + -- this is odd (default cannot be used from non-Ada code) + + if Is_Exported (E) then + F := First_Formal (E); + while Present (F) loop + if Warn_On_Export_Import + and then Present (Default_Value (F)) + then + Error_Msg_N + ("?parameter cannot be defaulted in non-Ada call", + Default_Value (F)); + end if; + + Next_Formal (F); + end loop; + end if; + end if; + + -- For VMS, descriptor mechanisms for parameters are allowed only for + -- imported/exported subprograms. Moreover, the NCA descriptor is not + -- allowed for parameters of exported subprograms. + + if OpenVMS_On_Target then + if Is_Exported (E) then + F := First_Formal (E); + while Present (F) loop + if Mechanism (F) = By_Descriptor_NCA then + Error_Msg_N + ("'N'C'A' descriptor for parameter not permitted", F); + Error_Msg_N + ("\can only be used for imported subprogram", F); + end if; + + Next_Formal (F); + end loop; + + elsif not Is_Imported (E) then + F := First_Formal (E); + while Present (F) loop + if Mechanism (F) in Descriptor_Codes then + Error_Msg_N + ("descriptor mechanism for parameter not permitted", F); + Error_Msg_N + ("\can only be used for imported/exported subprogram", F); + end if; + + Next_Formal (F); + end loop; + end if; + end if; + + -- Pragma Inline_Always is disallowed for dispatching subprograms + -- because the address of such subprograms is saved in the dispatch + -- table to support dispatching calls, and dispatching calls cannot + -- be inlined. This is consistent with the restriction against using + -- 'Access or 'Address on an Inline_Always subprogram. + + if Is_Dispatching_Operation (E) + and then Has_Pragma_Inline_Always (E) + then + Error_Msg_N + ("pragma Inline_Always not allowed for dispatching subprograms", E); + end if; + + -- Because of the implicit representation of inherited predefined + -- operators in the front-end, the overriding status of the operation + -- may be affected when a full view of a type is analyzed, and this is + -- not captured by the analysis of the corresponding type declaration. + -- Therefore the correctness of a not-overriding indicator must be + -- rechecked when the subprogram is frozen. + + if Nkind (E) = N_Defining_Operator_Symbol + and then not Error_Posted (Parent (E)) + then + Check_Overriding_Indicator (E, Empty, Is_Primitive (E)); + end if; + end Freeze_Subprogram; + + ---------------------- + -- Is_Fully_Defined -- + ---------------------- + + function Is_Fully_Defined (T : Entity_Id) return Boolean is + begin + if Ekind (T) = E_Class_Wide_Type then + return Is_Fully_Defined (Etype (T)); + + elsif Is_Array_Type (T) then + return Is_Fully_Defined (Component_Type (T)); + + elsif Is_Record_Type (T) + and not Is_Private_Type (T) + then + -- Verify that the record type has no components with private types + -- without completion. + + declare + Comp : Entity_Id; + + begin + Comp := First_Component (T); + while Present (Comp) loop + if not Is_Fully_Defined (Etype (Comp)) then + return False; + end if; + + Next_Component (Comp); + end loop; + return True; + end; + + -- For the designated type of an access to subprogram, all types in + -- the profile must be fully defined. + + elsif Ekind (T) = E_Subprogram_Type then + declare + F : Entity_Id; + + begin + F := First_Formal (T); + while Present (F) loop + if not Is_Fully_Defined (Etype (F)) then + return False; + end if; + + Next_Formal (F); + end loop; + + return Is_Fully_Defined (Etype (T)); + end; + + else + return not Is_Private_Type (T) + or else Present (Full_View (Base_Type (T))); + end if; + end Is_Fully_Defined; + + --------------------------------- + -- Process_Default_Expressions -- + --------------------------------- + + procedure Process_Default_Expressions + (E : Entity_Id; + After : in out Node_Id) + is + Loc : constant Source_Ptr := Sloc (E); + Dbody : Node_Id; + Formal : Node_Id; + Dcopy : Node_Id; + Dnam : Entity_Id; + + begin + Set_Default_Expressions_Processed (E); + + -- A subprogram instance and its associated anonymous subprogram share + -- their signature. The default expression functions are defined in the + -- wrapper packages for the anonymous subprogram, and should not be + -- generated again for the instance. + + if Is_Generic_Instance (E) + and then Present (Alias (E)) + and then Default_Expressions_Processed (Alias (E)) + then + return; + end if; + + Formal := First_Formal (E); + while Present (Formal) loop + if Present (Default_Value (Formal)) then + + -- We work with a copy of the default expression because we + -- do not want to disturb the original, since this would mess + -- up the conformance checking. + + Dcopy := New_Copy_Tree (Default_Value (Formal)); + + -- The analysis of the expression may generate insert actions, + -- which of course must not be executed. We wrap those actions + -- in a procedure that is not called, and later on eliminated. + -- The following cases have no side-effects, and are analyzed + -- directly. + + if Nkind (Dcopy) = N_Identifier + or else Nkind (Dcopy) = N_Expanded_Name + or else Nkind (Dcopy) = N_Integer_Literal + or else (Nkind (Dcopy) = N_Real_Literal + and then not Vax_Float (Etype (Dcopy))) + or else Nkind (Dcopy) = N_Character_Literal + or else Nkind (Dcopy) = N_String_Literal + or else Known_Null (Dcopy) + or else (Nkind (Dcopy) = N_Attribute_Reference + and then + Attribute_Name (Dcopy) = Name_Null_Parameter) + then + + -- If there is no default function, we must still do a full + -- analyze call on the default value, to ensure that all error + -- checks are performed, e.g. those associated with static + -- evaluation. Note: this branch will always be taken if the + -- analyzer is turned off (but we still need the error checks). + + -- Note: the setting of parent here is to meet the requirement + -- that we can only analyze the expression while attached to + -- the tree. Really the requirement is that the parent chain + -- be set, we don't actually need to be in the tree. + + Set_Parent (Dcopy, Declaration_Node (Formal)); + Analyze (Dcopy); + + -- Default expressions are resolved with their own type if the + -- context is generic, to avoid anomalies with private types. + + if Ekind (Scope (E)) = E_Generic_Package then + Resolve (Dcopy); + else + Resolve (Dcopy, Etype (Formal)); + end if; + + -- If that resolved expression will raise constraint error, + -- then flag the default value as raising constraint error. + -- This allows a proper error message on the calls. + + if Raises_Constraint_Error (Dcopy) then + Set_Raises_Constraint_Error (Default_Value (Formal)); + end if; + + -- If the default is a parameterless call, we use the name of + -- the called function directly, and there is no body to build. + + elsif Nkind (Dcopy) = N_Function_Call + and then No (Parameter_Associations (Dcopy)) + then + null; + + -- Else construct and analyze the body of a wrapper procedure + -- that contains an object declaration to hold the expression. + -- Given that this is done only to complete the analysis, it + -- simpler to build a procedure than a function which might + -- involve secondary stack expansion. + + else + Dnam := Make_Temporary (Loc, 'D'); + + Dbody := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Dnam), + + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('T')), + Object_Definition => + New_Occurrence_Of (Etype (Formal), Loc), + Expression => New_Copy_Tree (Dcopy))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List)); + + Set_Scope (Dnam, Scope (E)); + Set_Assignment_OK (First (Declarations (Dbody))); + Set_Is_Eliminated (Dnam); + Insert_After (After, Dbody); + Analyze (Dbody); + After := Dbody; + end if; + end if; + + Next_Formal (Formal); + end loop; + end Process_Default_Expressions; + + ---------------------------------------- + -- Set_Component_Alignment_If_Not_Set -- + ---------------------------------------- + + procedure Set_Component_Alignment_If_Not_Set (Typ : Entity_Id) is + begin + -- Ignore if not base type, subtypes don't need anything + + if Typ /= Base_Type (Typ) then + return; + end if; + + -- Do not override existing representation + + if Is_Packed (Typ) then + return; + + elsif Has_Specified_Layout (Typ) then + return; + + elsif Component_Alignment (Typ) /= Calign_Default then + return; + + else + Set_Component_Alignment + (Typ, Scope_Stack.Table + (Scope_Stack.Last).Component_Alignment_Default); + end if; + end Set_Component_Alignment_If_Not_Set; + + ------------------ + -- Undelay_Type -- + ------------------ + + procedure Undelay_Type (T : Entity_Id) is + begin + Set_Has_Delayed_Freeze (T, False); + Set_Freeze_Node (T, Empty); + + -- Since we don't want T to have a Freeze_Node, we don't want its + -- Full_View or Corresponding_Record_Type to have one either. + + -- ??? Fundamentally, this whole handling is a kludge. What we really + -- want is to be sure that for an Itype that's part of record R and is a + -- subtype of type T, that it's frozen after the later of the freeze + -- points of R and T. We have no way of doing that directly, so what we + -- do is force most such Itypes to be frozen as part of freezing R via + -- this procedure and only delay the ones that need to be delayed + -- (mostly the designated types of access types that are defined as part + -- of the record). + + if Is_Private_Type (T) + and then Present (Full_View (T)) + and then Is_Itype (Full_View (T)) + and then Is_Record_Type (Scope (Full_View (T))) + then + Undelay_Type (Full_View (T)); + end if; + + if Is_Concurrent_Type (T) + and then Present (Corresponding_Record_Type (T)) + and then Is_Itype (Corresponding_Record_Type (T)) + and then Is_Record_Type (Scope (Corresponding_Record_Type (T))) + then + Undelay_Type (Corresponding_Record_Type (T)); + end if; + end Undelay_Type; + + ------------------ + -- Warn_Overlay -- + ------------------ + + procedure Warn_Overlay + (Expr : Node_Id; + Typ : Entity_Id; + Nam : Entity_Id) + is + Ent : constant Entity_Id := Entity (Nam); + -- The object to which the address clause applies + + Init : Node_Id; + Old : Entity_Id := Empty; + Decl : Node_Id; + + begin + -- No warning if address clause overlay warnings are off + + if not Address_Clause_Overlay_Warnings then + return; + end if; + + -- No warning if there is an explicit initialization + + Init := Original_Node (Expression (Declaration_Node (Ent))); + + if Present (Init) and then Comes_From_Source (Init) then + return; + end if; + + -- We only give the warning for non-imported entities of a type for + -- which a non-null base init proc is defined, or for objects of access + -- types with implicit null initialization, or when Normalize_Scalars + -- applies and the type is scalar or a string type (the latter being + -- tested for because predefined String types are initialized by inline + -- code rather than by an init_proc). Note that we do not give the + -- warning for Initialize_Scalars, since we suppressed initialization + -- in this case. + + if Present (Expr) + and then not Is_Imported (Ent) + and then (Has_Non_Null_Base_Init_Proc (Typ) + or else Is_Access_Type (Typ) + or else (Normalize_Scalars + and then (Is_Scalar_Type (Typ) + or else Is_String_Type (Typ)))) + then + if Nkind (Expr) = N_Attribute_Reference + and then Is_Entity_Name (Prefix (Expr)) + then + Old := Entity (Prefix (Expr)); + + elsif Is_Entity_Name (Expr) + and then Ekind (Entity (Expr)) = E_Constant + then + Decl := Declaration_Node (Entity (Expr)); + + if Nkind (Decl) = N_Object_Declaration + and then Present (Expression (Decl)) + and then Nkind (Expression (Decl)) = N_Attribute_Reference + and then Is_Entity_Name (Prefix (Expression (Decl))) + then + Old := Entity (Prefix (Expression (Decl))); + + elsif Nkind (Expr) = N_Function_Call then + return; + end if; + + -- A function call (most likely to To_Address) is probably not an + -- overlay, so skip warning. Ditto if the function call was inlined + -- and transformed into an entity. + + elsif Nkind (Original_Node (Expr)) = N_Function_Call then + return; + end if; + + Decl := Next (Parent (Expr)); + + -- If a pragma Import follows, we assume that it is for the current + -- target of the address clause, and skip the warning. + + if Present (Decl) + and then Nkind (Decl) = N_Pragma + and then Pragma_Name (Decl) = Name_Import + then + return; + end if; + + if Present (Old) then + Error_Msg_Node_2 := Old; + Error_Msg_N + ("default initialization of & may modify &?", + Nam); + else + Error_Msg_N + ("default initialization of & may modify overlaid storage?", + Nam); + end if; + + -- Add friendly warning if initialization comes from a packed array + -- component. + + if Is_Record_Type (Typ) then + declare + Comp : Entity_Id; + + begin + Comp := First_Component (Typ); + while Present (Comp) loop + if Nkind (Parent (Comp)) = N_Component_Declaration + and then Present (Expression (Parent (Comp))) + then + exit; + elsif Is_Array_Type (Etype (Comp)) + and then Present (Packed_Array_Type (Etype (Comp))) + then + Error_Msg_NE + ("\packed array component& " & + "will be initialized to zero?", + Nam, Comp); + exit; + else + Next_Component (Comp); + end if; + end loop; + end; + end if; + + Error_Msg_N + ("\use pragma Import for & to " & + "suppress initialization (RM B.1(24))?", + Nam); + end if; + end Warn_Overlay; + +end Freeze; diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads new file mode 100644 index 000000000..d4dd1a125 --- /dev/null +++ b/gcc/ada/freeze.ads @@ -0,0 +1,243 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F R E E Z E -- +-- -- +-- 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. -- +-- -- +-- You should have received a copy of the GNU General Public License along -- +-- with this program; see file COPYING3. If not see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Types; use Types; + +package Freeze is + + -------------------------- + -- Handling of Freezing -- + -------------------------- + + -- In the formal Ada semantics, freezing of entities occurs at a well + -- defined point, described in (RM 13.14). The model in GNAT of freezing + -- is that a Freeze_Entity node is generated at the point where an entity + -- is frozen, and the entity contains a pointer (Freeze_Node) to this + -- generated freeze node. + + -- The freeze node is processed in the expander to generate associated + -- data and subprograms (e.g. an initialization procedure) which must + -- be delayed until the type is frozen and its representation can be + -- fully determined. Subsequently the freeze node is used by Gigi to + -- determine the point at which it should elaborate the corresponding + -- entity (this elaboration also requires the representation of the + -- entity to be fully determinable). The freeze node is also used to + -- provide additional diagnostic information (pinpointing the freeze + -- point), when order of freezing errors are detected. + + -- If we were fully faithful to the Ada model, we would generate freeze + -- nodes for all entities, but that is a bit heavy so we optimize (that + -- is the nice word) or cut corners (which is a bit more honest). For + -- many entities, we do not need to delay the freeze and instead can + -- freeze them at the point of declaration. The conditions for this + -- early freezing being permissible are as follows: + + -- There is no associated expander activity that needs to be delayed + + -- Gigi can fully elaborate the entity at the point of occurrence (or, + -- equivalently, no real elaboration is required for the entity). + + -- In order for these conditions to be met (especially the second), it + -- must be the case that all representation characteristics of the entity + -- can be determined at declaration time. + + -- The following indicates how freezing is handled for all entity kinds: + + -- Types + + -- All declared types have freeze nodes, as well as anonymous base + -- types created for type declarations where the defining identifier + -- is a first subtype of the anonymous type. + + -- Subtypes + + -- All first subtypes have freeze nodes. Other subtypes need freeze + -- nodes if the corresponding base type has not yet been frozen. If + -- the base type has been frozen, then there is no need for a freeze + -- node, since no rep clauses can appear for the subtype in any case. + + -- Implicit types and subtypes + + -- As noted above, implicit base types always have freeze nodes. Other + -- implicit types and subtypes typically do not require freeze nodes, + -- because there is no possibility of delaying any information about + -- their representation. + + -- Subprograms + -- + -- Are frozen at the point of declaration unless one or more of the + -- formal types or return type themselves have delayed freezing and + -- are not yet frozen. This includes the case of a formal access type + -- where the designated type is not frozen. Note that we are talking + -- about subprogram specs here (subprogram body entities have no + -- relevance), and in any case, subprogram bodies freeze everything. + + -- Objects with dynamic address clauses + -- + -- These have a delayed freeze. Gigi will generate code to evaluate + -- the initialization expression if present and store it in a temp. + -- The actual object is created at the point of the freeze, and if + -- necessary initialized by copying the value of this temporary. + + -- Formal Parameters + -- + -- Are frozen when the associated subprogram is frozen, so there is + -- never any need for them to have delayed freezing. + + -- Other Objects + -- + -- Are always frozen at the point of declaration + + -- All Other Entities + + -- Are always frozen at the point of declaration + + -- The flag Has_Delayed_Freeze is used for to indicate that delayed + -- freezing is required. Usually the associated freeze node is allocated + -- at the freezing point. One special exception occurs with anonymous + -- base types, where the freeze node is preallocated at the point of + -- declaration, so that the First_Subtype_Link field can be set. + + Freezing_Library_Level_Tagged_Type : Boolean := False; + -- Flag used to indicate that we are freezing the primitives of a library + -- level tagged types. Used to disable checks on premature freezing. + -- More documentation needed??? why is this flag needed? what are these + -- checks? why do they need disabling in some cases? + + ----------------- + -- Subprograms -- + ----------------- + + function Build_Renamed_Body + (Decl : Node_Id; + New_S : Entity_Id) return Node_Id; + -- Rewrite renaming declaration as a subprogram body, whose single + -- statement is a call to the renamed entity. New_S is the entity that + -- appears in the renaming declaration. If this is a Renaming_As_Body, + -- then Decl is the original subprogram declaration that is completed + -- by the renaming, otherwise it is the renaming declaration itself. + -- The caller inserts the body where required. If this call comes + -- from a freezing action, the resulting body is analyzed at once. + + procedure Check_Compile_Time_Size (T : Entity_Id); + -- Check to see whether the size of the type T is known at compile time. + -- There are three possible cases: + -- + -- Size is not known at compile time. In this case, the call has no + -- effect. Note that the processing is conservative here, in the sense + -- that this routine may decide that the size is not known even if in + -- fact Gigi decides it is known, but the opposite situation can never + -- occur. + -- + -- Size is known at compile time, but the actual value of the size is + -- not known to the front end or is definitely 32 or more. In this case + -- Size_Known_At_Compile_Time is set, but the Esize field is left set + -- to zero (to be set by Gigi). + -- + -- Size is known at compile time, and the actual value of the size is + -- known to the front end and is less than 32. In this case, the flag + -- Size_Known_At_Compile_Time is set, and in addition Esize is set to + -- the required size, allowing for possible front end packing of an + -- array using this type as a component type. + -- + -- Note: the flag Size_Known_At_Compile_Time is used to determine if the + -- secondary stack must be used to return a value of the type, and also + -- to determine whether a component clause is allowed for a component + -- of the given type. + -- + -- Note: this is public because of one dubious use in Sem_Res??? + -- + -- Note: Check_Compile_Time_Size does not test the case of the size being + -- known because a size clause is specifically given. That is because we + -- do not allow a size clause if the size would not otherwise be known at + -- compile time in any case. + + function Is_Atomic_Aggregate + (E : Entity_Id; + Typ : Entity_Id) return Boolean; + + -- If an atomic object is initialized with an aggregate or is assigned an + -- aggregate, we have to prevent a piecemeal access or assignment to the + -- object, even if the aggregate is to be expanded. We create a temporary + -- for the aggregate, and assign the temporary instead, so that the back + -- end can generate an atomic move for it. This is only done in the context + -- of an object declaration or an assignment. Function is a noop and + -- returns false in other contexts. + + function Freeze_Entity (E : Entity_Id; N : Node_Id) return List_Id; + -- Freeze an entity, and return Freeze nodes, to be inserted at the point + -- of call. N is a node whose source location corresponds to the freeze + -- point. This is used in placing warning messages in the situation where + -- it appears that a type has been frozen too early, e.g. when a primitive + -- operation is declared after the freezing point of its tagged type. + -- Returns No_List if no freeze nodes needed. + + procedure Freeze_All (From : Entity_Id; After : in out Node_Id); + -- Before a non-instance body, or at the end of a declarative part + -- freeze all entities therein that are not yet frozen. Calls itself + -- recursively to catch types in inner packages that were not frozen + -- at the inner level because they were not yet completely defined. + -- This routine also analyzes and freezes default parameter expressions + -- in subprogram specifications (this has to be delayed until all the + -- types are frozen). The resulting freeze nodes are inserted just + -- after node After (which is a list node) and analyzed. On return, + -- 'After' is updated to point to the last node inserted (or is returned + -- unchanged if no nodes were inserted). 'From' is the last entity frozen + -- in the scope. It is used to prevent a quadratic traversal over already + -- frozen entities. + + procedure Freeze_Before (N : Node_Id; T : Entity_Id); + -- Freeze T then Insert the generated Freeze nodes before the node N + + procedure Freeze_Expression (N : Node_Id); + -- Freezes the required entities when the Expression N causes freezing. + -- The node N here is either a subexpression node (a "real" expression) + -- or a subtype mark, or a subtype indication. The latter two cases are + -- not really expressions, but they can appear within expressions and + -- so need to be similarly treated. Freeze_Expression takes care of + -- determining the proper insertion point for generated freeze actions. + + procedure Freeze_Fixed_Point_Type (Typ : Entity_Id); + -- Freeze fixed point type. For fixed-point types, we have to defer + -- setting the size and bounds till the freeze point, since they are + -- potentially affected by the presence of size and small clauses. + + procedure Freeze_Itype (T : Entity_Id; N : Node_Id); + -- This routine is called when an Itype is created and must be frozen + -- immediately at the point of creation (for the sake of the expansion + -- activities in Exp_Ch3 (for example, the creation of packed array + -- types). We can't just let Freeze_Expression do this job since it + -- goes out of its way to make sure that the freeze node occurs at a + -- point outside the current construct, e.g. outside the expression or + -- outside the initialization procedure. That's normally right, but + -- not in this case, since if we create an Itype in an expression it + -- may be the case that it is not always elaborated (for example it + -- may result from the right operand of a short circuit). In this case + -- we want the freeze node to be inserted at the same point as the Itype. + -- The node N provides both the location for the freezing and also the + -- insertion point for the resulting freeze nodes. + +end Freeze; diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb new file mode 100644 index 000000000..fd83b5d5b --- /dev/null +++ b/gcc/ada/frontend.adb @@ -0,0 +1,426 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F R O N T E N D -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Strings; use System.Strings; + +with Atree; use Atree; +with Checks; +with CStand; +with Debug; use Debug; +with Elists; +with Exp_Dbug; +with Fmap; +with Fname.UF; +with Inline; use Inline; +with Lib; use Lib; +with Lib.Load; use Lib.Load; +with Live; use Live; +with Namet; use Namet; +with Nlists; use Nlists; +with Opt; use Opt; +with Osint; +with Par; +with Prep; +with Prepcomp; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Snames; use Snames; +with Sprint; +with Scn; use Scn; +with Sem; use Sem; +with Sem_Aux; +with Sem_Ch8; use Sem_Ch8; +with Sem_SCIL; +with Sem_Elab; use Sem_Elab; +with Sem_Prag; use Sem_Prag; +with Sem_Warn; use Sem_Warn; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Sinput.L; use Sinput.L; +with SCIL_LL; use SCIL_LL; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Types; use Types; + +procedure Frontend is + Config_Pragmas : List_Id; + -- Gather configuration pragmas + +begin + -- Carry out package initializations. These are initializations which might + -- logically be performed at elaboration time, were it not for the fact + -- that we may be doing things more than once in the big loop over files. + -- Like elaboration, the order in which these calls are made is in some + -- cases important. For example, Lib cannot be initialized before Namet, + -- since it uses names table entries. + + Rtsfind.Initialize; + Atree.Initialize; + Nlists.Initialize; + Elists.Initialize; + Lib.Load.Initialize; + Sem_Aux.Initialize; + Sem_Ch8.Initialize; + Sem_Prag.Initialize; + Fname.UF.Initialize; + Checks.Initialize; + Sem_Warn.Initialize; + Prep.Initialize; + + if Generate_SCIL then + SCIL_LL.Initialize; + end if; + + -- Create package Standard + + CStand.Create_Standard; + + -- Check possible symbol definitions specified by -gnateD switches + + Prepcomp.Process_Command_Line_Symbol_Definitions; + + -- If -gnatep= was specified, parse the preprocessing data file + + if Preprocessing_Data_File /= null then + Name_Len := Preprocessing_Data_File'Length; + Name_Buffer (1 .. Name_Len) := Preprocessing_Data_File.all; + Prepcomp.Parse_Preprocessing_Data_File (Name_Find); + + -- Otherwise, check if there were preprocessing symbols on the command + -- line and set preprocessing if there are. + + else + Prepcomp.Check_Symbols; + end if; + + -- We set Parsing_Main_Extended_Source true here to cover processing of all + -- the configuration pragma files, as well as the main source unit itself. + + Parsing_Main_Extended_Source := True; + + -- Now that the preprocessing situation is established, we are able to + -- load the main source (this is no longer done by Lib.Load.Initialize). + + Lib.Load.Load_Main_Source; + + -- Return immediately if the main source could not be found + + if Sinput.Main_Source_File = No_Source_File then + return; + end if; + + -- Read and process configuration pragma files if present + + declare + Save_Style_Check : constant Boolean := Opt.Style_Check; + -- Save style check mode so it can be restored later + + Source_Config_File : Source_File_Index; + -- Source reference for -gnatec configuration file + + Prag : Node_Id; + + begin + -- We always analyze config files with style checks off, since + -- we don't want a miscellaneous gnat.adc that is around to + -- discombobulate intended -gnatg or -gnaty compilations. We + -- also disconnect checking for maximum line length. + + Opt.Style_Check := False; + Style_Check := False; + + -- Capture current suppress options, which may get modified + + Scope_Suppress := Opt.Suppress_Options; + + -- First deal with gnat.adc file + + if Opt.Config_File then + Name_Buffer (1 .. 8) := "gnat.adc"; + Name_Len := 8; + Source_gnat_adc := Load_Config_File (Name_Enter); + + if Source_gnat_adc /= No_Source_File then + Initialize_Scanner (No_Unit, Source_gnat_adc); + Config_Pragmas := Par (Configuration_Pragmas => True); + else + Config_Pragmas := Empty_List; + end if; + + else + Config_Pragmas := Empty_List; + end if; + + -- Now deal with specified config pragmas files if there are any + + if Opt.Config_File_Names /= null then + for Index in Opt.Config_File_Names'Range loop + Name_Len := Config_File_Names (Index)'Length; + Name_Buffer (1 .. Name_Len) := Config_File_Names (Index).all; + Source_Config_File := Load_Config_File (Name_Enter); + + if Source_Config_File = No_Source_File then + Osint.Fail + ("cannot find configuration pragmas file " + & Config_File_Names (Index).all); + end if; + + Initialize_Scanner (No_Unit, Source_Config_File); + Append_List_To + (Config_Pragmas, Par (Configuration_Pragmas => True)); + end loop; + end if; + + -- Now analyze all pragmas except those whose analysis must be + -- deferred till after the main unit is analyzed. + + if Config_Pragmas /= Error_List + and then Operating_Mode /= Check_Syntax + then + Prag := First (Config_Pragmas); + while Present (Prag) loop + if not Delay_Config_Pragma_Analyze (Prag) then + Analyze_Pragma (Prag); + end if; + + Next (Prag); + end loop; + end if; + + -- Restore style check, but if config file turned on checks, leave on! + + Opt.Style_Check := Save_Style_Check or Style_Check; + + -- Capture any modifications to suppress options from config pragmas + + Opt.Suppress_Options := Scope_Suppress; + end; + + -- If there was a -gnatem switch, initialize the mappings of unit names to + -- file names and of file names to path names from the mapping file. + + if Mapping_File_Name /= null then + Fmap.Initialize (Mapping_File_Name.all); + end if; + + -- Adjust Optimize_Alignment mode from debug switches if necessary + + if Debug_Flag_Dot_SS then + Optimize_Alignment := 'S'; + elsif Debug_Flag_Dot_TT then + Optimize_Alignment := 'T'; + end if; + + -- We have now processed the command line switches, and the configuration + -- pragma files, so this is the point at which we want to capture the + -- values of the configuration switches (see Opt for further details). + + Opt.Register_Opt_Config_Switches; + + -- Check for file which contains No_Body pragma + + if Source_File_Is_No_Body (Source_Index (Main_Unit)) then + Change_Main_Unit_To_Spec; + end if; + + -- Initialize the scanner. Note that we do this after the call to + -- Create_Standard, which uses the scanner in its processing of + -- floating-point bounds. + + Initialize_Scanner (Main_Unit, Source_Index (Main_Unit)); + + -- Here we call the parser to parse the compilation unit (or units in + -- the check syntax mode, but in that case we won't go on to the + -- semantics in any case). + + Discard_List (Par (Configuration_Pragmas => False)); + Parsing_Main_Extended_Source := False; + + -- The main unit is now loaded, and subunits of it can be loaded, + -- without reporting spurious loading circularities. + + Set_Loading (Main_Unit, False); + + -- Now that the main unit is installed, we can complete the analysis + -- of the pragmas in gnat.adc and the configuration file, that require + -- a context for their semantic processing. + + if Config_Pragmas /= Error_List + and then Operating_Mode /= Check_Syntax + then + -- Pragmas that require some semantic activity, such as + -- Interrupt_State, cannot be processed until the main unit + -- is installed, because they require a compilation unit on + -- which to attach with_clauses, etc. So analyze them now. + + declare + Prag : Node_Id; + + begin + Prag := First (Config_Pragmas); + while Present (Prag) loop + if Delay_Config_Pragma_Analyze (Prag) then + Analyze_Pragma (Prag); + end if; + + Next (Prag); + end loop; + end; + end if; + + -- If we have restriction No_Exception_Propagation, and we did not have an + -- explicit switch turning off Warn_On_Non_Local_Exception, then turn on + -- this warning by default if we have encountered an exception handler. + + if Restriction_Check_Required (No_Exception_Propagation) + and then not No_Warn_On_Non_Local_Exception + and then Exception_Handler_Encountered + then + Warn_On_Non_Local_Exception := True; + end if; + + -- Now on to the semantics. Skip if in syntax only mode + + if Operating_Mode /= Check_Syntax then + + -- Install the configuration pragmas in the tree + + Set_Config_Pragmas (Aux_Decls_Node (Cunit (Main_Unit)), Config_Pragmas); + + -- Following steps are skipped if we had a fatal error during parsing + + if not Fatal_Error (Main_Unit) then + + -- Reset Operating_Mode to Check_Semantics for subunits. We cannot + -- actually generate code for subunits, so we suppress expansion. + -- This also corrects certain problems that occur if we try to + -- incorporate subunits at a lower level. + + if Operating_Mode = Generate_Code + and then Nkind (Unit (Cunit (Main_Unit))) = N_Subunit + then + Operating_Mode := Check_Semantics; + end if; + + -- Analyze (and possibly expand) main unit + + Scope_Suppress := Suppress_Options; + Semantics (Cunit (Main_Unit)); + + -- Cleanup processing after completing main analysis + + if Operating_Mode = Generate_Code + or else (Operating_Mode = Check_Semantics + and then ASIS_Mode) + then + Instantiate_Bodies; + end if; + + if Operating_Mode = Generate_Code then + if Inline_Processing_Required then + Analyze_Inlined_Bodies; + end if; + + -- Remove entities from program that do not have any + -- execution time references. + + if Debug_Flag_UU then + Collect_Garbage_Entities; + end if; + + Check_Elab_Calls; + end if; + + -- List library units if requested + + if List_Units then + Lib.List; + end if; + + -- Output waiting warning messages + + Sem_Warn.Output_Non_Modified_In_Out_Warnings; + Sem_Warn.Output_Unreferenced_Messages; + Sem_Warn.Check_Unused_Withs; + Sem_Warn.Output_Unused_Warnings_Off_Warnings; + end if; + end if; + + -- Qualify all entity names in inner packages, package bodies, etc., + -- except when compiling for the VM back-ends, which depend on + -- having unqualified names in certain cases and handles the + -- generation of qualified names when needed. + + if VM_Target = No_VM then + Exp_Dbug.Qualify_All_Entity_Names; + end if; + + -- SCIL backend requirement. Check that SCIL nodes associated with + -- dispatching calls reference subprogram calls. + + if Generate_SCIL then + pragma Debug (Sem_SCIL.Check_SCIL_Nodes (Cunit (Main_Unit))); + null; + end if; + + -- Dump the source now. Note that we do this as soon as the analysis + -- of the tree is complete, because it is not just a dump in the case + -- of -gnatD, where it rewrites all source locations in the tree. + + Sprint.Source_Dump; + + -- Check again for configuration pragmas that appear in the context of + -- the main unit. These pragmas only affect the main unit, and the + -- corresponding flag is reset after each call to Semantics, but they + -- may affect the generated ali for the unit, and therefore the flag + -- must be set properly after compilation. Currently we only check for + -- Initialize_Scalars, but others should be checked: as well??? + + declare + Item : Node_Id; + + begin + Item := First (Context_Items (Cunit (Main_Unit))); + while Present (Item) loop + if Nkind (Item) = N_Pragma + and then Pragma_Name (Item) = Name_Initialize_Scalars + then + Initialize_Scalars := True; + end if; + + Next (Item); + end loop; + end; + + -- If a mapping file has been specified by a -gnatem switch, update + -- it if there has been some sources that were not in the mappings. + + if Mapping_File_Name /= null then + Fmap.Update_Mapping_File (Mapping_File_Name.all); + end if; + + return; +end Frontend; diff --git a/gcc/ada/frontend.ads b/gcc/ada/frontend.ads new file mode 100644 index 000000000..2171069bc --- /dev/null +++ b/gcc/ada/frontend.ads @@ -0,0 +1,29 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F R O N T E N D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Top level of the front-end. This procedure is used by the different +-- gnat drivers. + +procedure Frontend; diff --git a/gcc/ada/g-allein.ads b/gcc/ada/g-allein.ads new file mode 100644 index 000000000..8007630e3 --- /dev/null +++ b/gcc/ada/g-allein.ads @@ -0,0 +1,1354 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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. + +-- The set of "services" includes: +-- +-- o Imports to the low level routines for which a direct binding is +-- mandatory (or just possible when analyzed as such). +-- +-- o Conversion routines (unchecked) between low level types, or between +-- various pointer representations. + +with GNAT.Altivec.Vector_Types; +with GNAT.Altivec.Low_Level_Vectors; + +with Ada.Unchecked_Conversion; + +package GNAT.Altivec.Low_Level_Interface is + + ---------------------------------------------------------------------------- + -- Imports for "argument must be literal" constraints in the Hard binding -- + ---------------------------------------------------------------------------- + + use GNAT.Altivec.Vector_Types; + + -- vec_ctf -- + + function vec_ctf_vui_cint_r_vf + (A : vector_unsigned_int; + B : c_int) return vector_float; + + pragma Import + (LL_Altivec, vec_ctf_vui_cint_r_vf, "__builtin_altivec_vcfux"); + + function vec_ctf_vsi_cint_r_vf + (A : vector_signed_int; + B : c_int) return vector_float; + + pragma Import + (LL_Altivec, vec_ctf_vsi_cint_r_vf, "__builtin_altivec_vcfsx"); + + -- vec_vcfsx -- + + function vec_vcfsx_vsi_cint_r_vf + (A : vector_signed_int; + B : c_int) return vector_float; + + pragma Import + (LL_Altivec, vec_vcfsx_vsi_cint_r_vf, "__builtin_altivec_vcfsx"); + + -- vec_vcfux -- + + function vec_vcfux_vui_cint_r_vf + (A : vector_unsigned_int; + B : c_int) return vector_float; + + pragma Import + (LL_Altivec, vec_vcfux_vui_cint_r_vf, "__builtin_altivec_vcfux"); + + -- vec_cts -- + + function vec_cts_vf_cint_r_vsi + (A : vector_float; + B : c_int) return vector_signed_int; + + pragma Import + (LL_Altivec, vec_cts_vf_cint_r_vsi, "__builtin_altivec_vctsxs"); + + -- vec_ctu -- + + function vec_ctu_vf_cint_r_vui + (A : vector_float; + B : c_int) return vector_unsigned_int; + + pragma Import + (LL_Altivec, vec_ctu_vf_cint_r_vui, "__builtin_altivec_vctuxs"); + + -- vec_dss -- + + procedure vec_dss_cint + (A : c_int); + + pragma Import + (LL_Altivec, vec_dss_cint, "__builtin_altivec_dss"); + + -- vec_dst -- + + procedure vec_dst_kvucp_cint_cint + (A : const_vector_unsigned_char_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dst_kvucp_cint_cint, "__builtin_altivec_dst"); + + procedure vec_dst_kvscp_cint_cint + (A : const_vector_signed_char_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dst_kvscp_cint_cint, "__builtin_altivec_dst"); + + procedure vec_dst_kvbcp_cint_cint + (A : const_vector_bool_char_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dst_kvbcp_cint_cint, "__builtin_altivec_dst"); + + procedure vec_dst_kvusp_cint_cint + (A : const_vector_unsigned_short_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dst_kvusp_cint_cint, "__builtin_altivec_dst"); + + procedure vec_dst_kvssp_cint_cint + (A : const_vector_signed_short_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dst_kvssp_cint_cint, "__builtin_altivec_dst"); + + procedure vec_dst_kvbsp_cint_cint + (A : const_vector_bool_short_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dst_kvbsp_cint_cint, "__builtin_altivec_dst"); + + procedure vec_dst_kvxp_cint_cint + (A : const_vector_pixel_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dst_kvxp_cint_cint, "__builtin_altivec_dst"); + + procedure vec_dst_kvuip_cint_cint + (A : const_vector_unsigned_int_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dst_kvuip_cint_cint, "__builtin_altivec_dst"); + + procedure vec_dst_kvsip_cint_cint + (A : const_vector_signed_int_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dst_kvsip_cint_cint, "__builtin_altivec_dst"); + + procedure vec_dst_kvbip_cint_cint + (A : const_vector_bool_int_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dst_kvbip_cint_cint, "__builtin_altivec_dst"); + + procedure vec_dst_kvfp_cint_cint + (A : const_vector_float_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dst_kvfp_cint_cint, "__builtin_altivec_dst"); + + procedure vec_dst_kucp_cint_cint + (A : const_unsigned_char_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dst_kucp_cint_cint, "__builtin_altivec_dst"); + + procedure vec_dst_kscp_cint_cint + (A : const_signed_char_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dst_kscp_cint_cint, "__builtin_altivec_dst"); + + procedure vec_dst_kusp_cint_cint + (A : const_unsigned_short_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dst_kusp_cint_cint, "__builtin_altivec_dst"); + + procedure vec_dst_ksp_cint_cint + (A : const_short_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dst_ksp_cint_cint, "__builtin_altivec_dst"); + + procedure vec_dst_kuip_cint_cint + (A : const_unsigned_int_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dst_kuip_cint_cint, "__builtin_altivec_dst"); + + procedure vec_dst_kip_cint_cint + (A : const_int_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dst_kip_cint_cint, "__builtin_altivec_dst"); + + procedure vec_dst_kulongp_cint_cint + (A : const_unsigned_long_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dst_kulongp_cint_cint, "__builtin_altivec_dst"); + + procedure vec_dst_klongp_cint_cint + (A : const_long_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dst_klongp_cint_cint, "__builtin_altivec_dst"); + + procedure vec_dst_kfp_cint_cint + (A : const_float_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dst_kfp_cint_cint, "__builtin_altivec_dst"); + + -- vec_dstst -- + + procedure vec_dstst_kvucp_cint_cint + (A : const_vector_unsigned_char_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstst_kvucp_cint_cint, "__builtin_altivec_dstst"); + + procedure vec_dstst_kvscp_cint_cint + (A : const_vector_signed_char_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstst_kvscp_cint_cint, "__builtin_altivec_dstst"); + + procedure vec_dstst_kvbcp_cint_cint + (A : const_vector_bool_char_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstst_kvbcp_cint_cint, "__builtin_altivec_dstst"); + + procedure vec_dstst_kvusp_cint_cint + (A : const_vector_unsigned_short_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstst_kvusp_cint_cint, "__builtin_altivec_dstst"); + + procedure vec_dstst_kvssp_cint_cint + (A : const_vector_signed_short_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstst_kvssp_cint_cint, "__builtin_altivec_dstst"); + + procedure vec_dstst_kvbsp_cint_cint + (A : const_vector_bool_short_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstst_kvbsp_cint_cint, "__builtin_altivec_dstst"); + + procedure vec_dstst_kvxp_cint_cint + (A : const_vector_pixel_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstst_kvxp_cint_cint, "__builtin_altivec_dstst"); + + procedure vec_dstst_kvuip_cint_cint + (A : const_vector_unsigned_int_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstst_kvuip_cint_cint, "__builtin_altivec_dstst"); + + procedure vec_dstst_kvsip_cint_cint + (A : const_vector_signed_int_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstst_kvsip_cint_cint, "__builtin_altivec_dstst"); + + procedure vec_dstst_kvbip_cint_cint + (A : const_vector_bool_int_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstst_kvbip_cint_cint, "__builtin_altivec_dstst"); + + procedure vec_dstst_kvfp_cint_cint + (A : const_vector_float_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstst_kvfp_cint_cint, "__builtin_altivec_dstst"); + + procedure vec_dstst_kucp_cint_cint + (A : const_unsigned_char_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstst_kucp_cint_cint, "__builtin_altivec_dstst"); + + procedure vec_dstst_kscp_cint_cint + (A : const_signed_char_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstst_kscp_cint_cint, "__builtin_altivec_dstst"); + + procedure vec_dstst_kusp_cint_cint + (A : const_unsigned_short_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstst_kusp_cint_cint, "__builtin_altivec_dstst"); + + procedure vec_dstst_ksp_cint_cint + (A : const_short_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstst_ksp_cint_cint, "__builtin_altivec_dstst"); + + procedure vec_dstst_kuip_cint_cint + (A : const_unsigned_int_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstst_kuip_cint_cint, "__builtin_altivec_dstst"); + + procedure vec_dstst_kip_cint_cint + (A : const_int_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstst_kip_cint_cint, "__builtin_altivec_dstst"); + + procedure vec_dstst_kulongp_cint_cint + (A : const_unsigned_long_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstst_kulongp_cint_cint, "__builtin_altivec_dstst"); + + procedure vec_dstst_klongp_cint_cint + (A : const_long_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstst_klongp_cint_cint, "__builtin_altivec_dstst"); + + procedure vec_dstst_kfp_cint_cint + (A : const_float_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstst_kfp_cint_cint, "__builtin_altivec_dstst"); + + -- vec_dststt -- + + procedure vec_dststt_kvucp_cint_cint + (A : const_vector_unsigned_char_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dststt_kvucp_cint_cint, "__builtin_altivec_dststt"); + + procedure vec_dststt_kvscp_cint_cint + (A : const_vector_signed_char_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dststt_kvscp_cint_cint, "__builtin_altivec_dststt"); + + procedure vec_dststt_kvbcp_cint_cint + (A : const_vector_bool_char_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dststt_kvbcp_cint_cint, "__builtin_altivec_dststt"); + + procedure vec_dststt_kvusp_cint_cint + (A : const_vector_unsigned_short_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dststt_kvusp_cint_cint, "__builtin_altivec_dststt"); + + procedure vec_dststt_kvssp_cint_cint + (A : const_vector_signed_short_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dststt_kvssp_cint_cint, "__builtin_altivec_dststt"); + + procedure vec_dststt_kvbsp_cint_cint + (A : const_vector_bool_short_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dststt_kvbsp_cint_cint, "__builtin_altivec_dststt"); + + procedure vec_dststt_kvxp_cint_cint + (A : const_vector_pixel_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dststt_kvxp_cint_cint, "__builtin_altivec_dststt"); + + procedure vec_dststt_kvuip_cint_cint + (A : const_vector_unsigned_int_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dststt_kvuip_cint_cint, "__builtin_altivec_dststt"); + + procedure vec_dststt_kvsip_cint_cint + (A : const_vector_signed_int_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dststt_kvsip_cint_cint, "__builtin_altivec_dststt"); + + procedure vec_dststt_kvbip_cint_cint + (A : const_vector_bool_int_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dststt_kvbip_cint_cint, "__builtin_altivec_dststt"); + + procedure vec_dststt_kvfp_cint_cint + (A : const_vector_float_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dststt_kvfp_cint_cint, "__builtin_altivec_dststt"); + + procedure vec_dststt_kucp_cint_cint + (A : const_unsigned_char_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dststt_kucp_cint_cint, "__builtin_altivec_dststt"); + + procedure vec_dststt_kscp_cint_cint + (A : const_signed_char_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dststt_kscp_cint_cint, "__builtin_altivec_dststt"); + + procedure vec_dststt_kusp_cint_cint + (A : const_unsigned_short_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dststt_kusp_cint_cint, "__builtin_altivec_dststt"); + + procedure vec_dststt_ksp_cint_cint + (A : const_short_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dststt_ksp_cint_cint, "__builtin_altivec_dststt"); + + procedure vec_dststt_kuip_cint_cint + (A : const_unsigned_int_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dststt_kuip_cint_cint, "__builtin_altivec_dststt"); + + procedure vec_dststt_kip_cint_cint + (A : const_int_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dststt_kip_cint_cint, "__builtin_altivec_dststt"); + + procedure vec_dststt_kulongp_cint_cint + (A : const_unsigned_long_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dststt_kulongp_cint_cint, "__builtin_altivec_dststt"); + + procedure vec_dststt_klongp_cint_cint + (A : const_long_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dststt_klongp_cint_cint, "__builtin_altivec_dststt"); + + procedure vec_dststt_kfp_cint_cint + (A : const_float_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dststt_kfp_cint_cint, "__builtin_altivec_dststt"); + + -- vec_dstt -- + + procedure vec_dstt_kvucp_cint_cint + (A : const_vector_unsigned_char_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstt_kvucp_cint_cint, "__builtin_altivec_dstt"); + + procedure vec_dstt_kvscp_cint_cint + (A : const_vector_signed_char_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstt_kvscp_cint_cint, "__builtin_altivec_dstt"); + + procedure vec_dstt_kvbcp_cint_cint + (A : const_vector_bool_char_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstt_kvbcp_cint_cint, "__builtin_altivec_dstt"); + + procedure vec_dstt_kvusp_cint_cint + (A : const_vector_unsigned_short_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstt_kvusp_cint_cint, "__builtin_altivec_dstt"); + + procedure vec_dstt_kvssp_cint_cint + (A : const_vector_signed_short_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstt_kvssp_cint_cint, "__builtin_altivec_dstt"); + + procedure vec_dstt_kvbsp_cint_cint + (A : const_vector_bool_short_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstt_kvbsp_cint_cint, "__builtin_altivec_dstt"); + + procedure vec_dstt_kvxp_cint_cint + (A : const_vector_pixel_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstt_kvxp_cint_cint, "__builtin_altivec_dstt"); + + procedure vec_dstt_kvuip_cint_cint + (A : const_vector_unsigned_int_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstt_kvuip_cint_cint, "__builtin_altivec_dstt"); + + procedure vec_dstt_kvsip_cint_cint + (A : const_vector_signed_int_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstt_kvsip_cint_cint, "__builtin_altivec_dstt"); + + procedure vec_dstt_kvbip_cint_cint + (A : const_vector_bool_int_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstt_kvbip_cint_cint, "__builtin_altivec_dstt"); + + procedure vec_dstt_kvfp_cint_cint + (A : const_vector_float_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstt_kvfp_cint_cint, "__builtin_altivec_dstt"); + + procedure vec_dstt_kucp_cint_cint + (A : const_unsigned_char_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstt_kucp_cint_cint, "__builtin_altivec_dstt"); + + procedure vec_dstt_kscp_cint_cint + (A : const_signed_char_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstt_kscp_cint_cint, "__builtin_altivec_dstt"); + + procedure vec_dstt_kusp_cint_cint + (A : const_unsigned_short_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstt_kusp_cint_cint, "__builtin_altivec_dstt"); + + procedure vec_dstt_ksp_cint_cint + (A : const_short_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstt_ksp_cint_cint, "__builtin_altivec_dstt"); + + procedure vec_dstt_kuip_cint_cint + (A : const_unsigned_int_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstt_kuip_cint_cint, "__builtin_altivec_dstt"); + + procedure vec_dstt_kip_cint_cint + (A : const_int_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstt_kip_cint_cint, "__builtin_altivec_dstt"); + + procedure vec_dstt_kulongp_cint_cint + (A : const_unsigned_long_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstt_kulongp_cint_cint, "__builtin_altivec_dstt"); + + procedure vec_dstt_klongp_cint_cint + (A : const_long_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstt_klongp_cint_cint, "__builtin_altivec_dstt"); + + procedure vec_dstt_kfp_cint_cint + (A : const_float_ptr; + B : c_int; + C : c_int); + + pragma Import + (LL_Altivec, vec_dstt_kfp_cint_cint, "__builtin_altivec_dstt"); + + -- vec_sld -- + + -- ??? The base GCC implementation maps everything to vsldoi_4si, while + -- it defines builtin variants for all the modes. Adjust here, to avoid + -- the infamous argument mode mismatch. + + function vec_sld_vf_vf_cint_r_vf + (A : vector_float; + B : vector_float; + C : c_int) return vector_float; + + pragma Import + (LL_Altivec, vec_sld_vf_vf_cint_r_vf, "__builtin_altivec_vsldoi_4sf"); + + function vec_sld_vsi_vsi_cint_r_vsi + (A : vector_signed_int; + B : vector_signed_int; + C : c_int) return vector_signed_int; + + pragma Import + (LL_Altivec, vec_sld_vsi_vsi_cint_r_vsi, "__builtin_altivec_vsldoi_4si"); + + function vec_sld_vui_vui_cint_r_vui + (A : vector_unsigned_int; + B : vector_unsigned_int; + C : c_int) return vector_unsigned_int; + + pragma Import + (LL_Altivec, vec_sld_vui_vui_cint_r_vui, "__builtin_altivec_vsldoi_4si"); + + function vec_sld_vbi_vbi_cint_r_vbi + (A : vector_bool_int; + B : vector_bool_int; + C : c_int) return vector_bool_int; + + pragma Import + (LL_Altivec, vec_sld_vbi_vbi_cint_r_vbi, "__builtin_altivec_vsldoi_4si"); + + function vec_sld_vss_vss_cint_r_vss + (A : vector_signed_short; + B : vector_signed_short; + C : c_int) return vector_signed_short; + + pragma Import + (LL_Altivec, vec_sld_vss_vss_cint_r_vss, "__builtin_altivec_vsldoi_8hi"); + + function vec_sld_vus_vus_cint_r_vus + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : c_int) return vector_unsigned_short; + + pragma Import + (LL_Altivec, vec_sld_vus_vus_cint_r_vus, "__builtin_altivec_vsldoi_8hi"); + + function vec_sld_vbs_vbs_cint_r_vbs + (A : vector_bool_short; + B : vector_bool_short; + C : c_int) return vector_bool_short; + + pragma Import + (LL_Altivec, vec_sld_vbs_vbs_cint_r_vbs, "__builtin_altivec_vsldoi_8hi"); + + function vec_sld_vx_vx_cint_r_vx + (A : vector_pixel; + B : vector_pixel; + C : c_int) return vector_pixel; + + pragma Import + (LL_Altivec, vec_sld_vx_vx_cint_r_vx, "__builtin_altivec_vsldoi_4si"); + + function vec_sld_vsc_vsc_cint_r_vsc + (A : vector_signed_char; + B : vector_signed_char; + C : c_int) return vector_signed_char; + + pragma Import + (LL_Altivec, vec_sld_vsc_vsc_cint_r_vsc, "__builtin_altivec_vsldoi_16qi"); + + function vec_sld_vuc_vuc_cint_r_vuc + (A : vector_unsigned_char; + B : vector_unsigned_char; + C : c_int) return vector_unsigned_char; + + pragma Import + (LL_Altivec, vec_sld_vuc_vuc_cint_r_vuc, "__builtin_altivec_vsldoi_16qi"); + + function vec_sld_vbc_vbc_cint_r_vbc + (A : vector_bool_char; + B : vector_bool_char; + C : c_int) return vector_bool_char; + + pragma Import + (LL_Altivec, vec_sld_vbc_vbc_cint_r_vbc, "__builtin_altivec_vsldoi_16qi"); + + -- vec_splat -- + + function vec_splat_vsc_cint_r_vsc + (A : vector_signed_char; + B : c_int) return vector_signed_char; + + pragma Import + (LL_Altivec, vec_splat_vsc_cint_r_vsc, "__builtin_altivec_vspltb"); + + function vec_splat_vuc_cint_r_vuc + (A : vector_unsigned_char; + B : c_int) return vector_unsigned_char; + + pragma Import + (LL_Altivec, vec_splat_vuc_cint_r_vuc, "__builtin_altivec_vspltb"); + + function vec_splat_vbc_cint_r_vbc + (A : vector_bool_char; + B : c_int) return vector_bool_char; + + pragma Import + (LL_Altivec, vec_splat_vbc_cint_r_vbc, "__builtin_altivec_vspltb"); + + function vec_splat_vss_cint_r_vss + (A : vector_signed_short; + B : c_int) return vector_signed_short; + + pragma Import + (LL_Altivec, vec_splat_vss_cint_r_vss, "__builtin_altivec_vsplth"); + + function vec_splat_vus_cint_r_vus + (A : vector_unsigned_short; + B : c_int) return vector_unsigned_short; + + pragma Import + (LL_Altivec, vec_splat_vus_cint_r_vus, "__builtin_altivec_vsplth"); + + function vec_splat_vbs_cint_r_vbs + (A : vector_bool_short; + B : c_int) return vector_bool_short; + + pragma Import + (LL_Altivec, vec_splat_vbs_cint_r_vbs, "__builtin_altivec_vsplth"); + + function vec_splat_vx_cint_r_vx + (A : vector_pixel; + B : c_int) return vector_pixel; + + pragma Import + (LL_Altivec, vec_splat_vx_cint_r_vx, "__builtin_altivec_vsplth"); + + function vec_splat_vf_cint_r_vf + (A : vector_float; + B : c_int) return vector_float; + + pragma Import + (LL_Altivec, vec_splat_vf_cint_r_vf, "__builtin_altivec_vspltw"); + + function vec_splat_vsi_cint_r_vsi + (A : vector_signed_int; + B : c_int) return vector_signed_int; + + pragma Import + (LL_Altivec, vec_splat_vsi_cint_r_vsi, "__builtin_altivec_vspltw"); + + function vec_splat_vui_cint_r_vui + (A : vector_unsigned_int; + B : c_int) return vector_unsigned_int; + + pragma Import + (LL_Altivec, vec_splat_vui_cint_r_vui, "__builtin_altivec_vspltw"); + + function vec_splat_vbi_cint_r_vbi + (A : vector_bool_int; + B : c_int) return vector_bool_int; + + pragma Import + (LL_Altivec, vec_splat_vbi_cint_r_vbi, "__builtin_altivec_vspltw"); + + -- vec_vspltw -- + + function vec_vspltw_vf_cint_r_vf + (A : vector_float; + B : c_int) return vector_float; + + pragma Import + (LL_Altivec, vec_vspltw_vf_cint_r_vf, "__builtin_altivec_vspltw"); + + function vec_vspltw_vsi_cint_r_vsi + (A : vector_signed_int; + B : c_int) return vector_signed_int; + + pragma Import + (LL_Altivec, vec_vspltw_vsi_cint_r_vsi, "__builtin_altivec_vspltw"); + + function vec_vspltw_vui_cint_r_vui + (A : vector_unsigned_int; + B : c_int) return vector_unsigned_int; + + pragma Import + (LL_Altivec, vec_vspltw_vui_cint_r_vui, "__builtin_altivec_vspltw"); + + function vec_vspltw_vbi_cint_r_vbi + (A : vector_bool_int; + B : c_int) return vector_bool_int; + + pragma Import + (LL_Altivec, vec_vspltw_vbi_cint_r_vbi, "__builtin_altivec_vspltw"); + + -- vec_vsplth -- + + function vec_vsplth_vbs_cint_r_vbs + (A : vector_bool_short; + B : c_int) return vector_bool_short; + + pragma Import + (LL_Altivec, vec_vsplth_vbs_cint_r_vbs, "__builtin_altivec_vsplth"); + + function vec_vsplth_vss_cint_r_vss + (A : vector_signed_short; + B : c_int) return vector_signed_short; + + pragma Import + (LL_Altivec, vec_vsplth_vss_cint_r_vss, "__builtin_altivec_vsplth"); + + function vec_vsplth_vus_cint_r_vus + (A : vector_unsigned_short; + B : c_int) return vector_unsigned_short; + + pragma Import + (LL_Altivec, vec_vsplth_vus_cint_r_vus, "__builtin_altivec_vsplth"); + + function vec_vsplth_vx_cint_r_vx + (A : vector_pixel; + B : c_int) return vector_pixel; + + pragma Import + (LL_Altivec, vec_vsplth_vx_cint_r_vx, "__builtin_altivec_vsplth"); + + -- vec_vspltb -- + + function vec_vspltb_vsc_cint_r_vsc + (A : vector_signed_char; + B : c_int) return vector_signed_char; + + pragma Import + (LL_Altivec, vec_vspltb_vsc_cint_r_vsc, "__builtin_altivec_vspltb"); + + function vec_vspltb_vuc_cint_r_vuc + (A : vector_unsigned_char; + B : c_int) return vector_unsigned_char; + + pragma Import + (LL_Altivec, vec_vspltb_vuc_cint_r_vuc, "__builtin_altivec_vspltb"); + + function vec_vspltb_vbc_cint_r_vbc + (A : vector_bool_char; + B : c_int) return vector_bool_char; + + pragma Import + (LL_Altivec, vec_vspltb_vbc_cint_r_vbc, "__builtin_altivec_vspltb"); + + -- vec_splat_s8 -- + + function vec_splat_s8_cint_r_vsc + (A : c_int) return vector_signed_char; + + pragma Import + (LL_Altivec, vec_splat_s8_cint_r_vsc, "__builtin_altivec_vspltisb"); + + -- vec_splat_s16 -- + + function vec_splat_s16_cint_r_vss + (A : c_int) return vector_signed_short; + + pragma Import + (LL_Altivec, vec_splat_s16_cint_r_vss, "__builtin_altivec_vspltish"); + + -- vec_splat_s32 -- + + function vec_splat_s32_cint_r_vsi + (A : c_int) return vector_signed_int; + + pragma Import + (LL_Altivec, vec_splat_s32_cint_r_vsi, "__builtin_altivec_vspltisw"); + + -- vec_splat_u8 -- + + function vec_splat_u8_cint_r_vuc + (A : c_int) return vector_unsigned_char; + + pragma Import + (LL_Altivec, vec_splat_u8_cint_r_vuc, "__builtin_altivec_vspltisb"); + + -- vec_splat_u16 -- + + function vec_splat_u16_cint_r_vus + (A : c_int) return vector_unsigned_short; + + pragma Import + (LL_Altivec, vec_splat_u16_cint_r_vus, "__builtin_altivec_vspltish"); + + -- vec_splat_u32 -- + + function vec_splat_u32_cint_r_vui + (A : c_int) return vector_unsigned_int; + + pragma Import + (LL_Altivec, vec_splat_u32_cint_r_vui, "__builtin_altivec_vspltisw"); + + ------------------------------------------------------------ + -- Imports for low-level signature consistent subprograms -- + ------------------------------------------------------------ + + -- vec_dssall -- + + procedure vec_dssall; + + pragma Import + (LL_Altivec, vec_dssall, "__builtin_altivec_dssall"); + + ----------------------------------------- + -- Conversions between low level types -- + ----------------------------------------- + + use GNAT.Altivec.Low_Level_Vectors; + + -- Something like... + -- + -- TYPES="LL_VBC LL_VUC LL_VSC LL_VBS LL_VUS LL_VSS \ + -- LL_VBI LL_VUI LL_VSI LL_VF LL_VP" + -- for TT in `echo $TYPES`; do + -- for ST in `echo $TYPES`; do + -- echo "function To_$TT is new Ada.Unchecked_Conversion ($ST, $TT);" + -- done + -- echo "" + -- done + + 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 new file mode 100644 index 000000000..39d0b7240 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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_VSI; B : c_int) return LL_VF is + D : VF_View; + VA : constant VUI_View := To_View (To_LL_VUI (A)); + 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_VSI 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_LL_VSI (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 new file mode 100644 index 000000000..8c46dab65 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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_VSI; 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_VSI; + + 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 new file mode 100644 index 000000000..edd6c9847 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..93d291e2e --- /dev/null +++ b/gcc/ada/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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit provides the Vector/Views conversions + +with GNAT.Altivec.Vector_Types; use GNAT.Altivec.Vector_Types; +with GNAT.Altivec.Vector_Views; use GNAT.Altivec.Vector_Views; + +package GNAT.Altivec.Conversions is + + --------------------- + -- char components -- + --------------------- + + function To_Vector (S : VUC_View) return VUC; + function To_Vector (S : VSC_View) return VSC; + function To_Vector (S : VBC_View) return VBC; + + function To_View (S : VUC) return VUC_View; + function To_View (S : VSC) return VSC_View; + function To_View (S : VBC) return VBC_View; + + ---------------------- + -- short components -- + ---------------------- + + function To_Vector (S : VUS_View) return VUS; + function To_Vector (S : VSS_View) return VSS; + function To_Vector (S : VBS_View) return VBS; + + function To_View (S : VUS) return VUS_View; + function To_View (S : VSS) return VSS_View; + function To_View (S : VBS) return VBS_View; + + -------------------- + -- int components -- + -------------------- + + function To_Vector (S : VUI_View) return VUI; + function To_Vector (S : VSI_View) return VSI; + function To_Vector (S : VBI_View) return VBI; + + function To_View (S : VUI) return VUI_View; + function To_View (S : VSI) return VSI_View; + function To_View (S : VBI) return VBI_View; + + ---------------------- + -- float components -- + ---------------------- + + function To_Vector (S : VF_View) return VF; + + function To_View (S : VF) return VF_View; + + ---------------------- + -- pixel components -- + ---------------------- + + function To_Vector (S : VP_View) return VP; + + function To_View (S : VP) return VP_View; + +private + + -- We want the above subprograms to always be inlined in the case of the + -- hard PowerPC AltiVec support in order to avoid the unnecessary function + -- call. On the other hand there is no problem with inlining these + -- subprograms on little-endian targets. + + pragma Inline_Always (To_Vector); + pragma Inline_Always (To_View); + +end GNAT.Altivec.Conversions; diff --git a/gcc/ada/g-altive.ads b/gcc/ada/g-altive.ads new file mode 100644 index 000000000..392b7908d --- /dev/null +++ b/gcc/ada/g-altive.ads @@ -0,0 +1,477 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A L T I V E C -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +------------------------- +-- General description -- +------------------------- + +-- This is the root of a package hierarchy offering an Ada binding to the +-- PowerPC AltiVec extensions. These extensions basically consist in a set of +-- 128bit vector types together with a set of subprograms operating on such +-- vectors. On a real Altivec capable target, vector objects map to hardware +-- vector registers and the subprograms map to a set of specific hardware +-- instructions. + +-- Relevant documents are: + +-- o AltiVec Technology, Programming Interface Manual (1999-06) +-- to which we will refer as [PIM], describes the data types, the +-- functional interface and the ABI conventions. + +-- o AltiVec Technology, Programming Environments Manual (2002-02) +-- to which we will refer as [PEM], describes the hardware architecture +-- and instruction set. + +-- These documents, as well as a number of others of general interest on the +-- AltiVec technology, are available from the Motorola/AltiVec Web site at + +-- http://www.motorola.com/altivec + +-- We offer two versions of this binding: one for real AltiVec capable +-- targets, and one for other targets. In the latter case, everything is +-- emulated in software. We will refer to the two bindings as: + +-- o The Hard binding for AltiVec capable targets (with the appropriate +-- hardware support and corresponding instruction set) + +-- o The Soft binding for other targets (with the low level primitives +-- emulated in software). + +-- The two versions of the binding are expected to be equivalent from the +-- functional standpoint. The same client application code should observe no +-- difference in operation results, even if the Soft version is used on a +-- non-powerpc target. The Hard binding is naturally expected to run faster +-- than the Soft version on the same target. + +-- We also offer interfaces not strictly part of the base AltiVec API, such +-- as vector conversions to/from array representations, which are of interest +-- for client applications (e.g. for vector initialization purposes) and may +-- also be used as implementation facilities. + +----------------------------------------- +-- General package architecture survey -- +----------------------------------------- + +-- The various vector representations are all "containers" of elementary +-- values, the possible types of which are declared in this root package to +-- be generally accessible. + +-- From the user standpoint, the two versions of the binding are available +-- through a consistent hierarchy of units providing identical services: + +-- GNAT.Altivec +-- (component types) +-- | +-- o----------------o----------------o-------------o +-- | | | | +-- Vector_Types Vector_Operations Vector_Views Conversions + +-- The user can manipulate vectors through two families of types: Vector +-- types and View types. + +-- Vector types are defined in the GNAT.Altivec.Vector_Types package + +-- On these types, the user can apply the Altivec operations defined in +-- GNAT.Altivec.Vector_Operations. Their layout is opaque and may vary across +-- configurations, for it is typically target-endianness dependant. + +-- Vector_Types and Vector_Operations implement the core binding to the +-- AltiVec API, as described in [PIM-2.1 data types] and [PIM-4 AltiVec +-- operations and predicates]. + +-- View types are defined in the GNAT.Altivec.Vector_Views package + +-- These types do not represent Altivec vectors per se, in the sense that the +-- Altivec_Operations are not available for them. They are intended to allow +-- Vector initializations as well as access to the Vector component values. + +-- The GNAT.Altivec.Conversions package is provided to convert a View to the +-- corresponding Vector and vice-versa. + +-- The two versions of the binding rely on a low level internal interface, +-- and switching from one version to the other amounts to select one low +-- level implementation instead of the other. + +-- The bindings are provided as a set of sources together with a project file +-- (altivec.gpr). The hard/soft binding selection is controlled by a project +-- variable on targets where switching makes sense. See the example usage +-- section below. + +--------------------------- +-- Underlying principles -- +--------------------------- + +-- The general organization sketched above has been devised from a number +-- of driving ideas: + +-- o From the clients standpoint, the two versions of the binding should be +-- as easily exchangeable as possible, + +-- o From the maintenance standpoint, we want to avoid as much code +-- duplication as possible. + +-- o From both standpoints above, we want to maintain a clear interface +-- separation between the base bindings to the Motorola API and the +-- additional facilities. + +-- The identification of the low level interface is directly inspired by the +-- base API organization, basically consisting of a rich set of functions +-- around a core of low level primitives mapping to AltiVec instructions. + +-- See for instance "vec_add" in [PIM-4.4 Generic and Specific AltiVec +-- operations]: no less than six result/arguments combinations of byte vector +-- types map to "vaddubm". + +-- The "hard" version of the low level primitives map to real AltiVec +-- instructions via the corresponding GCC builtins. The "soft" version is +-- a software emulation of those. + +------------------- +-- Example usage -- +------------------- + +-- Here is a sample program declaring and initializing two vectors, 'add'ing +-- them and displaying the result components: + +-- with GNAT.Altivec.Vector_Types; use GNAT.Altivec.Vector_Types; +-- with GNAT.Altivec.Vector_Operations; use GNAT.Altivec.Vector_Operations; +-- with GNAT.Altivec.Vector_Views; use GNAT.Altivec.Vector_Views; +-- with GNAT.Altivec.Conversions; use GNAT.Altivec.Conversions; + +-- use GNAT.Altivec; + +-- procedure Sample is +-- Va : Vector_Unsigned_Int := To_Vector ((Values => (1, 2, 3, 4))); +-- Vb : Vector_Unsigned_Int := To_Vector ((Values => (1, 2, 3, 4))); + +-- Vs : Vector_Unsigned_Int; +-- Vs_View : VUI_View; +-- begin +-- Vs := Vec_Add (Va, Vb); +-- Vs_View := To_View (Vs); + +-- for I in Vs_View.Values'Range loop +-- Put_Line (Unsigned_Int'Image (Vs_View.Values (I))); +-- end loop; +-- end; + +-- This currently requires the GNAT project management facilities to compile, +-- to automatically retrieve the set of necessary sources and switches +-- depending on your configuration. For the example above, customizing the +-- switches to include -g also, this would be something like: + +-- sample.gpr +-- +-- with "altivec.gpr"; +-- +-- project Sample is + +-- for Source_Dirs use ("."); +-- for Main use ("sample"); + +-- package Compiler is +-- for Default_Switches ("Ada") use +-- Altivec.Compiler'Default_Switches ("Ada") & "-g"; +-- end Compiler; + +-- end Sample; + +-- $ gnatmake -Psample +-- [...] +-- $ ./sample +-- 2 +-- 4 +-- 6 +-- 8 + +------------------------------------------------------------------------------ + +with System; + +package GNAT.Altivec is + + -- Definitions of constants and vector/array component types common to all + -- the versions of the binding. + + -- All the vector types are 128bits + + VECTOR_BIT : constant := 128; + + ------------------------------------------- + -- [PIM-2.3.1 Alignment of vector types] -- + ------------------------------------------- + + -- "A defined data item of any vector data type in memory is always + -- aligned on a 16-byte boundary. A pointer to any vector data type always + -- points to a 16-byte boundary. The compiler is responsible for aligning + -- vector data types on 16-byte boundaries." + + VECTOR_ALIGNMENT : constant := Natural'Min (16, Standard'Maximum_Alignment); + -- This value is used to set the alignment of vector datatypes in both the + -- hard and the soft binding implementations. + -- + -- We want this value to never be greater than 16, because none of the + -- binding implementations requires larger alignments and such a value + -- would cause useless space to be allocated/wasted for vector objects. + -- Furthermore, the alignment of 16 matches the hard binding leading to + -- a more faithful emulation. + -- + -- It needs to be exactly 16 for the hard binding, and the initializing + -- expression is just right for this purpose since Maximum_Alignment is + -- expected to be 16 for the real Altivec ABI. + -- + -- The soft binding doesn't rely on strict 16byte alignment, and we want + -- the value to be no greater than Standard'Maximum_Alignment in this case + -- to ensure it is supported on every possible target. + + ------------------------------------------------------- + -- [PIM-2.1] Data Types - Interpretation of contents -- + ------------------------------------------------------- + + --------------------- + -- char components -- + --------------------- + + CHAR_BIT : constant := 8; + SCHAR_MIN : constant := -2 ** (CHAR_BIT - 1); + SCHAR_MAX : constant := 2 ** (CHAR_BIT - 1) - 1; + UCHAR_MAX : constant := 2 ** CHAR_BIT - 1; + + type unsigned_char is mod UCHAR_MAX + 1; + for unsigned_char'Size use CHAR_BIT; + + type signed_char is range SCHAR_MIN .. SCHAR_MAX; + for signed_char'Size use CHAR_BIT; + + subtype bool_char is unsigned_char; + -- ??? There is a difference here between what the Altivec Technology + -- Programming Interface Manual says and what GCC says. In the manual, + -- vector_bool_char is a vector_unsigned_char, while in altivec.h it + -- is a vector_signed_char. + + bool_char_True : constant bool_char := bool_char'Last; + bool_char_False : constant bool_char := 0; + + ---------------------- + -- short components -- + ---------------------- + + SHORT_BIT : constant := 16; + SSHORT_MIN : constant := -2 ** (SHORT_BIT - 1); + SSHORT_MAX : constant := 2 ** (SHORT_BIT - 1) - 1; + USHORT_MAX : constant := 2 ** SHORT_BIT - 1; + + type unsigned_short is mod USHORT_MAX + 1; + for unsigned_short'Size use SHORT_BIT; + + subtype unsigned_short_int is unsigned_short; + + type signed_short is range SSHORT_MIN .. SSHORT_MAX; + for signed_short'Size use SHORT_BIT; + + subtype signed_short_int is signed_short; + + subtype bool_short is unsigned_short; + -- ??? See bool_char + + bool_short_True : constant bool_short := bool_short'Last; + bool_short_False : constant bool_short := 0; + + subtype bool_short_int is bool_short; + + -------------------- + -- int components -- + -------------------- + + INT_BIT : constant := 32; + SINT_MIN : constant := -2 ** (INT_BIT - 1); + SINT_MAX : constant := 2 ** (INT_BIT - 1) - 1; + UINT_MAX : constant := 2 ** INT_BIT - 1; + + type unsigned_int is mod UINT_MAX + 1; + for unsigned_int'Size use INT_BIT; + + type signed_int is range SINT_MIN .. SINT_MAX; + for signed_int'Size use INT_BIT; + + subtype bool_int is unsigned_int; + -- ??? See bool_char + + bool_int_True : constant bool_int := bool_int'Last; + bool_int_False : constant bool_int := 0; + + ---------------------- + -- float components -- + ---------------------- + + FLOAT_BIT : constant := 32; + FLOAT_DIGIT : constant := 6; + FLOAT_MIN : constant := -16#0.FFFF_FF#E+32; + FLOAT_MAX : constant := 16#0.FFFF_FF#E+32; + + type C_float is digits FLOAT_DIGIT range FLOAT_MIN .. FLOAT_MAX; + for C_float'Size use FLOAT_BIT; + -- Altivec operations always use the standard native floating-point + -- support of the target. Note that this means that there may be + -- minor differences in results between targets when the floating- + -- point implementations are slightly different, as would happen + -- with normal non-Altivec floating-point operations. In particular + -- the Altivec simulations may yield slightly different results + -- from those obtained on a true hardware Altivec target if the + -- floating-point implementation is not 100% compatible. + + ---------------------- + -- pixel components -- + ---------------------- + + subtype pixel is unsigned_short; + + ----------------------------------------------------------- + -- Subtypes for variants found in the GCC implementation -- + ----------------------------------------------------------- + + subtype c_int is signed_int; + subtype c_short is c_int; + + LONG_BIT : constant := 32; + -- Some of the GCC builtins are built with "long" arguments and + -- expect SImode to come in. + + SLONG_MIN : constant := -2 ** (LONG_BIT - 1); + SLONG_MAX : constant := 2 ** (LONG_BIT - 1) - 1; + ULONG_MAX : constant := 2 ** LONG_BIT - 1; + + type signed_long is range SLONG_MIN .. SLONG_MAX; + type unsigned_long is mod ULONG_MAX + 1; + + subtype c_long is signed_long; + + subtype c_ptr is System.Address; + + --------------------------------------------------------- + -- Access types, for the sake of some argument passing -- + --------------------------------------------------------- + + type signed_char_ptr is access all signed_char; + type unsigned_char_ptr is access all unsigned_char; + + type short_ptr is access all c_short; + type signed_short_ptr is access all signed_short; + type unsigned_short_ptr is access all unsigned_short; + + type int_ptr is access all c_int; + type signed_int_ptr is access all signed_int; + type unsigned_int_ptr is access all unsigned_int; + + type long_ptr is access all c_long; + type signed_long_ptr is access all signed_long; + type unsigned_long_ptr is access all unsigned_long; + + type float_ptr is access all Float; + + -- + + type const_signed_char_ptr is access constant signed_char; + type const_unsigned_char_ptr is access constant unsigned_char; + + type const_short_ptr is access constant c_short; + type const_signed_short_ptr is access constant signed_short; + type const_unsigned_short_ptr is access constant unsigned_short; + + type const_int_ptr is access constant c_int; + type const_signed_int_ptr is access constant signed_int; + type const_unsigned_int_ptr is access constant unsigned_int; + + type const_long_ptr is access constant c_long; + type const_signed_long_ptr is access constant signed_long; + type const_unsigned_long_ptr is access constant unsigned_long; + + type const_float_ptr is access constant Float; + + -- Access to const volatile arguments need specialized types + + type volatile_float is new Float; + pragma Volatile (volatile_float); + + type volatile_signed_char is new signed_char; + pragma Volatile (volatile_signed_char); + + type volatile_unsigned_char is new unsigned_char; + pragma Volatile (volatile_unsigned_char); + + type volatile_signed_short is new signed_short; + pragma Volatile (volatile_signed_short); + + type volatile_unsigned_short is new unsigned_short; + pragma Volatile (volatile_unsigned_short); + + type volatile_signed_int is new signed_int; + pragma Volatile (volatile_signed_int); + + type volatile_unsigned_int is new unsigned_int; + pragma Volatile (volatile_unsigned_int); + + type volatile_signed_long is new signed_long; + pragma Volatile (volatile_signed_long); + + type volatile_unsigned_long is new unsigned_long; + pragma Volatile (volatile_unsigned_long); + + type constv_char_ptr is access constant volatile_signed_char; + type constv_signed_char_ptr is access constant volatile_signed_char; + type constv_unsigned_char_ptr is access constant volatile_unsigned_char; + + type constv_short_ptr is access constant volatile_signed_short; + type constv_signed_short_ptr is access constant volatile_signed_short; + type constv_unsigned_short_ptr is access constant volatile_unsigned_short; + + type constv_int_ptr is access constant volatile_signed_int; + type constv_signed_int_ptr is access constant volatile_signed_int; + type constv_unsigned_int_ptr is access constant volatile_unsigned_int; + + type constv_long_ptr is access constant volatile_signed_long; + type constv_signed_long_ptr is access constant volatile_signed_long; + type constv_unsigned_long_ptr is access constant volatile_unsigned_long; + + type constv_float_ptr is access constant volatile_float; + +private + + ----------------------- + -- Various constants -- + ----------------------- + + CR6_EQ : constant := 0; + CR6_EQ_REV : constant := 1; + CR6_LT : constant := 2; + CR6_LT_REV : constant := 3; + +end GNAT.Altivec; diff --git a/gcc/ada/g-alveop.adb b/gcc/ada/g-alveop.adb new file mode 100644 index 000000000..6a01b6e95 --- /dev/null +++ b/gcc/ada/g-alveop.adb @@ -0,0 +1,9702 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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_Vectors; use GNAT.Altivec.Low_Level_Vectors; + +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_upklsh -- + + 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; + + ----------------------------------- + -- Bodies for Altivec predicates -- + ----------------------------------- + + -- 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 new file mode 100644 index 000000000..eb4db7927 --- /dev/null +++ b/gcc/ada/g-alveop.ads @@ -0,0 +1,8103 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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_Interface; use GNAT.Altivec.Low_Level_Interface; + +package GNAT.Altivec.Vector_Operations is + + -- The vast majority of the operations exposed here are overloads over a + -- much smaller set of low level primitives with type conversions around. + -- + -- In some cases, a direct binding without any intermediate body is + -- possible or even mandatory for technical reasons. What we provide + -- here for such cases are renamings of straight imports exposed by + -- Altivec.Low_Level_Interface. See the comments in the private part for + -- additional details. + + ------------------------------------------------------- + -- [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; + + -- vec_cmpeq -- + + 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_ctf -- + + function vec_ctf + (A : vector_unsigned_int; + B : c_int) return vector_float + renames Low_Level_Interface.vec_ctf_vui_cint_r_vf; + + function vec_ctf + (A : vector_signed_int; + B : c_int) return vector_float + renames Low_Level_Interface.vec_ctf_vsi_cint_r_vf; + + -- vec_vcfsx -- + + function vec_vcfsx + (A : vector_signed_int; + B : c_int) return vector_float + renames Low_Level_Interface.vec_vcfsx_vsi_cint_r_vf; + + -- vec_vcfux -- + + function vec_vcfux + (A : vector_unsigned_int; + B : c_int) return vector_float + renames Low_Level_Interface.vec_vcfux_vui_cint_r_vf; + + -- vec_cts -- + + function vec_cts + (A : vector_float; + B : c_int) return vector_signed_int + renames Low_Level_Interface.vec_cts_vf_cint_r_vsi; + + -- vec_ctu -- + + function vec_ctu + (A : vector_float; + B : c_int) return vector_unsigned_int + renames Low_Level_Interface.vec_ctu_vf_cint_r_vui; + + -- vec_dss -- + + procedure vec_dss + (A : c_int) + renames Low_Level_Interface.vec_dss_cint; + + -- vec_dssall -- + + procedure vec_dssall + renames Low_Level_Interface.vec_dssall; + + -- vec_dst -- + + procedure vec_dst + (A : const_vector_unsigned_char_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dst_kvucp_cint_cint; + + procedure vec_dst + (A : const_vector_signed_char_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dst_kvscp_cint_cint; + + procedure vec_dst + (A : const_vector_bool_char_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dst_kvbcp_cint_cint; + + procedure vec_dst + (A : const_vector_unsigned_short_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dst_kvusp_cint_cint; + + procedure vec_dst + (A : const_vector_signed_short_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dst_kvssp_cint_cint; + + procedure vec_dst + (A : const_vector_bool_short_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dst_kvbsp_cint_cint; + + procedure vec_dst + (A : const_vector_pixel_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dst_kvxp_cint_cint; + + procedure vec_dst + (A : const_vector_unsigned_int_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dst_kvuip_cint_cint; + + procedure vec_dst + (A : const_vector_signed_int_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dst_kvsip_cint_cint; + + procedure vec_dst + (A : const_vector_bool_int_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dst_kvbip_cint_cint; + + procedure vec_dst + (A : const_vector_float_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dst_kvfp_cint_cint; + + procedure vec_dst + (A : const_unsigned_char_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dst_kucp_cint_cint; + + procedure vec_dst + (A : const_signed_char_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dst_kscp_cint_cint; + + procedure vec_dst + (A : const_unsigned_short_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dst_kusp_cint_cint; + + procedure vec_dst + (A : const_short_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dst_ksp_cint_cint; + + procedure vec_dst + (A : const_unsigned_int_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dst_kuip_cint_cint; + + procedure vec_dst + (A : const_int_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dst_kip_cint_cint; + + procedure vec_dst + (A : const_unsigned_long_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dst_kulongp_cint_cint; + + procedure vec_dst + (A : const_long_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dst_klongp_cint_cint; + + procedure vec_dst + (A : const_float_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dst_kfp_cint_cint; + + -- vec_dstst -- + + procedure vec_dstst + (A : const_vector_unsigned_char_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstst_kvucp_cint_cint; + + procedure vec_dstst + (A : const_vector_signed_char_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstst_kvscp_cint_cint; + + procedure vec_dstst + (A : const_vector_bool_char_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstst_kvbcp_cint_cint; + + procedure vec_dstst + (A : const_vector_unsigned_short_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstst_kvusp_cint_cint; + + procedure vec_dstst + (A : const_vector_signed_short_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstst_kvssp_cint_cint; + + procedure vec_dstst + (A : const_vector_bool_short_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstst_kvbsp_cint_cint; + + procedure vec_dstst + (A : const_vector_pixel_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstst_kvxp_cint_cint; + + procedure vec_dstst + (A : const_vector_unsigned_int_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstst_kvuip_cint_cint; + + procedure vec_dstst + (A : const_vector_signed_int_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstst_kvsip_cint_cint; + + procedure vec_dstst + (A : const_vector_bool_int_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstst_kvbip_cint_cint; + + procedure vec_dstst + (A : const_vector_float_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstst_kvfp_cint_cint; + + procedure vec_dstst + (A : const_unsigned_char_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstst_kucp_cint_cint; + + procedure vec_dstst + (A : const_signed_char_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstst_kscp_cint_cint; + + procedure vec_dstst + (A : const_unsigned_short_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstst_kusp_cint_cint; + + procedure vec_dstst + (A : const_short_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstst_ksp_cint_cint; + + procedure vec_dstst + (A : const_unsigned_int_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstst_kuip_cint_cint; + + procedure vec_dstst + (A : const_int_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstst_kip_cint_cint; + + procedure vec_dstst + (A : const_unsigned_long_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstst_kulongp_cint_cint; + + procedure vec_dstst + (A : const_long_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstst_klongp_cint_cint; + + procedure vec_dstst + (A : const_float_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstst_kfp_cint_cint; + + -- vec_dststt -- + + procedure vec_dststt + (A : const_vector_unsigned_char_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dststt_kvucp_cint_cint; + + procedure vec_dststt + (A : const_vector_signed_char_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dststt_kvscp_cint_cint; + + procedure vec_dststt + (A : const_vector_bool_char_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dststt_kvbcp_cint_cint; + + procedure vec_dststt + (A : const_vector_unsigned_short_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dststt_kvusp_cint_cint; + + procedure vec_dststt + (A : const_vector_signed_short_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dststt_kvssp_cint_cint; + + procedure vec_dststt + (A : const_vector_bool_short_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dststt_kvbsp_cint_cint; + + procedure vec_dststt + (A : const_vector_pixel_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dststt_kvxp_cint_cint; + + procedure vec_dststt + (A : const_vector_unsigned_int_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dststt_kvuip_cint_cint; + + procedure vec_dststt + (A : const_vector_signed_int_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dststt_kvsip_cint_cint; + + procedure vec_dststt + (A : const_vector_bool_int_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dststt_kvbip_cint_cint; + + procedure vec_dststt + (A : const_vector_float_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dststt_kvfp_cint_cint; + + procedure vec_dststt + (A : const_unsigned_char_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dststt_kucp_cint_cint; + + procedure vec_dststt + (A : const_signed_char_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dststt_kscp_cint_cint; + + procedure vec_dststt + (A : const_unsigned_short_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dststt_kusp_cint_cint; + + procedure vec_dststt + (A : const_short_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dststt_ksp_cint_cint; + + procedure vec_dststt + (A : const_unsigned_int_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dststt_kuip_cint_cint; + + procedure vec_dststt + (A : const_int_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dststt_kip_cint_cint; + + procedure vec_dststt + (A : const_unsigned_long_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dststt_kulongp_cint_cint; + + procedure vec_dststt + (A : const_long_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dststt_klongp_cint_cint; + + procedure vec_dststt + (A : const_float_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dststt_kfp_cint_cint; + + -- vec_dstt -- + + procedure vec_dstt + (A : const_vector_unsigned_char_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstt_kvucp_cint_cint; + + procedure vec_dstt + (A : const_vector_signed_char_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstt_kvscp_cint_cint; + + procedure vec_dstt + (A : const_vector_bool_char_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstt_kvbcp_cint_cint; + + procedure vec_dstt + (A : const_vector_unsigned_short_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstt_kvusp_cint_cint; + + procedure vec_dstt + (A : const_vector_signed_short_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstt_kvssp_cint_cint; + + procedure vec_dstt + (A : const_vector_bool_short_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstt_kvbsp_cint_cint; + + procedure vec_dstt + (A : const_vector_pixel_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstt_kvxp_cint_cint; + + procedure vec_dstt + (A : const_vector_unsigned_int_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstt_kvuip_cint_cint; + + procedure vec_dstt + (A : const_vector_signed_int_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstt_kvsip_cint_cint; + + procedure vec_dstt + (A : const_vector_bool_int_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstt_kvbip_cint_cint; + + procedure vec_dstt + (A : const_vector_float_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstt_kvfp_cint_cint; + + procedure vec_dstt + (A : const_unsigned_char_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstt_kucp_cint_cint; + + procedure vec_dstt + (A : const_signed_char_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstt_kscp_cint_cint; + + procedure vec_dstt + (A : const_unsigned_short_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstt_kusp_cint_cint; + + procedure vec_dstt + (A : const_short_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstt_ksp_cint_cint; + + procedure vec_dstt + (A : const_unsigned_int_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstt_kuip_cint_cint; + + procedure vec_dstt + (A : const_int_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstt_kip_cint_cint; + + procedure vec_dstt + (A : const_unsigned_long_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstt_kulongp_cint_cint; + + procedure vec_dstt + (A : const_long_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstt_klongp_cint_cint; + + procedure vec_dstt + (A : const_float_ptr; + B : c_int; + C : c_int) + renames Low_Level_Interface.vec_dstt_kfp_cint_cint; + + -- 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; + + -- vec_vmsumshs -- + + 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_float; + B : vector_float; + C : c_int) return vector_float + renames Low_Level_Interface.vec_sld_vf_vf_cint_r_vf; + + function vec_sld + (A : vector_signed_int; + B : vector_signed_int; + C : c_int) return vector_signed_int + renames Low_Level_Interface.vec_sld_vsi_vsi_cint_r_vsi; + + function vec_sld + (A : vector_unsigned_int; + B : vector_unsigned_int; + C : c_int) return vector_unsigned_int + renames Low_Level_Interface.vec_sld_vui_vui_cint_r_vui; + + function vec_sld + (A : vector_bool_int; + B : vector_bool_int; + C : c_int) return vector_bool_int + renames Low_Level_Interface.vec_sld_vbi_vbi_cint_r_vbi; + + function vec_sld + (A : vector_signed_short; + B : vector_signed_short; + C : c_int) return vector_signed_short + renames Low_Level_Interface.vec_sld_vss_vss_cint_r_vss; + + function vec_sld + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : c_int) return vector_unsigned_short + renames Low_Level_Interface.vec_sld_vus_vus_cint_r_vus; + + function vec_sld + (A : vector_bool_short; + B : vector_bool_short; + C : c_int) return vector_bool_short + renames Low_Level_Interface.vec_sld_vbs_vbs_cint_r_vbs; + + function vec_sld + (A : vector_pixel; + B : vector_pixel; + C : c_int) return vector_pixel + renames Low_Level_Interface.vec_sld_vx_vx_cint_r_vx; + + function vec_sld + (A : vector_signed_char; + B : vector_signed_char; + C : c_int) return vector_signed_char + renames Low_Level_Interface.vec_sld_vsc_vsc_cint_r_vsc; + + function vec_sld + (A : vector_unsigned_char; + B : vector_unsigned_char; + C : c_int) return vector_unsigned_char + renames Low_Level_Interface.vec_sld_vuc_vuc_cint_r_vuc; + + function vec_sld + (A : vector_bool_char; + B : vector_bool_char; + C : c_int) return vector_bool_char + renames Low_Level_Interface.vec_sld_vbc_vbc_cint_r_vbc; + + -- 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_splat -- + + function vec_splat + (A : vector_signed_char; + B : c_int) return vector_signed_char + renames Low_Level_Interface.vec_splat_vsc_cint_r_vsc; + + function vec_splat + (A : vector_unsigned_char; + B : c_int) return vector_unsigned_char + renames Low_Level_Interface.vec_splat_vuc_cint_r_vuc; + + function vec_splat + (A : vector_bool_char; + B : c_int) return vector_bool_char + renames Low_Level_Interface.vec_splat_vbc_cint_r_vbc; + + function vec_splat + (A : vector_signed_short; + B : c_int) return vector_signed_short + renames Low_Level_Interface.vec_splat_vss_cint_r_vss; + + function vec_splat + (A : vector_unsigned_short; + B : c_int) return vector_unsigned_short + renames Low_Level_Interface.vec_splat_vus_cint_r_vus; + + function vec_splat + (A : vector_bool_short; + B : c_int) return vector_bool_short + renames Low_Level_Interface.vec_splat_vbs_cint_r_vbs; + + function vec_splat + (A : vector_pixel; + B : c_int) return vector_pixel + renames Low_Level_Interface.vec_splat_vx_cint_r_vx; + + function vec_splat + (A : vector_float; + B : c_int) return vector_float + renames Low_Level_Interface.vec_splat_vf_cint_r_vf; + + function vec_splat + (A : vector_signed_int; + B : c_int) return vector_signed_int + renames Low_Level_Interface.vec_splat_vsi_cint_r_vsi; + + function vec_splat + (A : vector_unsigned_int; + B : c_int) return vector_unsigned_int + renames Low_Level_Interface.vec_splat_vui_cint_r_vui; + + function vec_splat + (A : vector_bool_int; + B : c_int) return vector_bool_int + renames Low_Level_Interface.vec_splat_vbi_cint_r_vbi; + + -- vec_vspltw -- + + function vec_vspltw + (A : vector_float; + B : c_int) return vector_float + renames Low_Level_Interface.vec_vspltw_vf_cint_r_vf; + + function vec_vspltw + (A : vector_signed_int; + B : c_int) return vector_signed_int + renames Low_Level_Interface.vec_vspltw_vsi_cint_r_vsi; + + function vec_vspltw + (A : vector_unsigned_int; + B : c_int) return vector_unsigned_int + renames Low_Level_Interface.vec_vspltw_vui_cint_r_vui; + + function vec_vspltw + (A : vector_bool_int; + B : c_int) return vector_bool_int + renames Low_Level_Interface.vec_vspltw_vbi_cint_r_vbi; + + -- vec_vsplth -- + + function vec_vsplth + (A : vector_bool_short; + B : c_int) return vector_bool_short + renames Low_Level_Interface.vec_vsplth_vbs_cint_r_vbs; + + function vec_vsplth + (A : vector_signed_short; + B : c_int) return vector_signed_short + renames Low_Level_Interface.vec_vsplth_vss_cint_r_vss; + + function vec_vsplth + (A : vector_unsigned_short; + B : c_int) return vector_unsigned_short + renames Low_Level_Interface.vec_vsplth_vus_cint_r_vus; + + function vec_vsplth + (A : vector_pixel; + B : c_int) return vector_pixel + renames Low_Level_Interface.vec_vsplth_vx_cint_r_vx; + + -- vec_vspltb -- + + function vec_vspltb + (A : vector_signed_char; + B : c_int) return vector_signed_char + renames Low_Level_Interface.vec_vspltb_vsc_cint_r_vsc; + + function vec_vspltb + (A : vector_unsigned_char; + B : c_int) return vector_unsigned_char + renames Low_Level_Interface.vec_vspltb_vuc_cint_r_vuc; + + function vec_vspltb + (A : vector_bool_char; + B : c_int) return vector_bool_char + renames Low_Level_Interface.vec_vspltb_vbc_cint_r_vbc; + + -- vec_splat_s8 -- + + function vec_splat_s8 + (A : c_int) return vector_signed_char + renames Low_Level_Interface.vec_splat_s8_cint_r_vsc; + + -- vec_splat_s16 -- + + function vec_splat_s16 + (A : c_int) return vector_signed_short + renames Low_Level_Interface.vec_splat_s16_cint_r_vss; + + -- vec_splat_s32 -- + + function vec_splat_s32 + (A : c_int) return vector_signed_int + renames Low_Level_Interface.vec_splat_s32_cint_r_vsi; + + -- vec_splat_u8 -- + + function vec_splat_u8 + (A : c_int) return vector_unsigned_char + renames Low_Level_Interface.vec_splat_u8_cint_r_vuc; + + -- vec_splat_u16 -- + + function vec_splat_u16 + (A : c_int) return vector_unsigned_short + renames Low_Level_Interface.vec_splat_u16_cint_r_vus; + + -- vec_splat_u32 -- + + function vec_splat_u32 + (A : c_int) return vector_unsigned_int + renames Low_Level_Interface.vec_splat_u32_cint_r_vui; + + -- 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; + + -- vec_vsrah -- + + 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; + + -- vec_vsrab -- + + 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; + + -- vec_sro -- + + 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; + + -- vec_st -- + + 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); + + -- vec_stvehx -- + + 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); + + -- vec_stvebx -- + + 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); + + -- vec_stl -- + + 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; + + -- vec_trunc -- + + function vec_trunc + (A : vector_float) return vector_float; + + -- vec_unpackh -- + + 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; + + -- vec_vupkhsh -- + + function vec_vupkhsh + (A : vector_bool_short) return vector_bool_int; + + function vec_vupkhsh + (A : vector_signed_short) return vector_signed_int; + + -- vec_vupkhpx -- + + function vec_vupkhpx + (A : vector_pixel) return vector_unsigned_int; + + -- vec_vupkhsb -- + + function vec_vupkhsb + (A : vector_bool_char) return vector_bool_short; + + function vec_vupkhsb + (A : vector_signed_char) return vector_signed_short; + + -- vec_unpackl -- + + 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; + + -- vec_vupklpx -- + + function vec_vupklpx + (A : vector_pixel) return vector_unsigned_int; + + -- vec_upklsh -- + + 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; + + ---------------------------------- + -- [PIM-4.5 AltiVec predicates] -- + ---------------------------------- + + -- 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; + + -- vec_any_le -- + + 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; + + -- vec_any_lt -- + + 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; + + -- vec_any_nan -- + + function vec_any_nan + (A : vector_float) return c_int; + + -- vec_any_ne -- + + 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; + + -- vec_any_ngt -- + + function vec_any_ngt + (A : vector_float; + B : vector_float) return c_int; + + -- vec_any_nle -- + + function vec_any_nle + (A : vector_float; + B : vector_float) return c_int; + + -- vec_any_nlt -- + + function vec_any_nlt + (A : vector_float; + B : vector_float) return c_int; + + -- vec_any_numeric -- + + function vec_any_numeric + (A : vector_float) return c_int; + + -- vec_any_out -- + + function vec_any_out + (A : vector_float; + B : vector_float) return c_int; + + ------------------------------------------- + -- Straight overloads of routines aboves -- + ------------------------------------------- + + -- vec_vaddcuw -- + + function vec_vaddcuw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + renames vec_addc; + + -- vec_vand -- + + 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; + + -- vec_vcmpgefp -- + + function vec_vcmpgefp + (A : vector_float; + B : vector_float) return vector_bool_int + renames vec_cmpge; + + -- vec_vctsxs -- + + function vec_vctsxs + (A : vector_float; + B : c_int) return vector_signed_int + renames vec_cts; + + -- vec_vctuxs -- + + function vec_vctuxs + (A : vector_float; + B : c_int) return vector_unsigned_int + renames vec_ctu; + + -- vec_vexptefp -- + + 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; + + -- vec_lvx -- + + 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; + + -- vec_lvxl -- + + 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; + + -- vec_vlogefp -- + + 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; + + -- vec_vrsqrtefp -- + + function vec_vrsqrtefp + (A : vector_float) return vector_float + renames vec_rsqrte; + + -- vec_vsel -- + + 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; + + -- vec_vspltisb -- + + function vec_vspltisb + (A : c_int) return vector_signed_char + renames vec_splat_s8; + + -- vec_vspltish -- + + function vec_vspltish + (A : c_int) return vector_signed_short + renames vec_splat_s16; + + -- vec_vspltisw -- + + function vec_vspltisw + (A : c_int) return vector_signed_int + renames vec_splat_s32; + + -- vec_vsr -- + + 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; + + -- vec_vsro -- + + 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; + + -- vec_vsubcuw -- + + 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; + + -- vec_vsumsws -- + + function vec_vsumsws + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + renames vec_sums; + + -- vec_vrfiz -- + + 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; + + ---------------------------------------------- + -- [PIM 2.5.3 Value for adjusting pointers] -- + ---------------------------------------------- + + -- "At compile time, vec_step (vec_data) produces the integer value + -- representing the amount by which a pointer to a component of an AltiVec + -- data type should increment to cause a pointer increment to increment by + -- 16 bytes". + + 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 + + ------------------------------------- + -- 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; + -- + -- Conversely, a direct (without wrapper) binding is sometimes mandatory + -- in the Hard binding case, because the corresponding low level code + -- accept only literal values for some arguments. Inlined calls to the + -- wrapper with proper arguments would be fine, but the wrapper body + -- itself would not be compilable. These can of course also be used in the + -- Soft binding, and so are naturally in this common unit. + -- + -- Fortunately, the sets of operations for which a wrapper is required + -- and the set of operations for which a wrapper would not be compilable + -- do not intersect. + + ----------------------------- + -- 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 the user visible subprograms shall be + -- inlined. 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, so... + + 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); + + -- Similarly, vec_step is expected to be turned into a compile time + -- constant, so ... + + pragma Inline_Always (vec_step); + +end GNAT.Altivec.Vector_Operations; diff --git a/gcc/ada/g-alvety.ads b/gcc/ada/g-alvety.ads new file mode 100644 index 000000000..06e824eb1 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 new file mode 100644 index 000000000..8d8d85608 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 new file mode 100644 index 000000000..a897b13f9 --- /dev/null +++ b/gcc/ada/g-arrspl.adb @@ -0,0 +1,313 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A R R A Y _ S P L I T -- +-- -- +-- 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 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); + + procedure Free is + new Ada.Unchecked_Deallocation (Element_Sequence, Element_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.Ref_Counter.all := S.Ref_Counter.all + 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 + begin + Free (S.Source); + S.Source := new Element_Sequence'(From); + Set (S, Separators, Mode); + 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 (Natural, Counter); + + begin + S.Ref_Counter.all := S.Ref_Counter.all - 1; + + if S.Ref_Counter.all = 0 then + Free (S.Source); + Free (S.Indexes); + Free (S.Slices); + Free (S.Ref_Counter); + end if; + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (S : in out Slice_Set) is + begin + S.Ref_Counter := new Natural'(1); + end Initialize; + + ---------------- + -- Separators -- + ---------------- + + function Separators + (S : Slice_Set; + Index : Slice_Number) return Slice_Separators + is + begin + if Index > S.N_Slice then + raise Index_Error; + + elsif Index = 0 + or else (Index = 1 and then S.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.Source (S.Slices (Index).Stop + 1)); + + elsif Index = S.N_Slice then + return (Before => S.Source (S.Slices (Index).Start - 1), + After => Array_End); + + else + return (Before => S.Source (S.Slices (Index).Start - 1), + After => S.Source (S.Slices (Index).Stop + 1)); + end if; + end Separators; + + ---------------- + -- Separators -- + ---------------- + + function Separators (S : Slice_Set) return Separators_Indexes is + begin + return S.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 + Count_Sep : constant Natural := Count (S.Source.all, Separators); + J : Positive; + begin + -- Free old structure + Free (S.Indexes); + Free (S.Slices); + + -- Compute all separator's indexes + + S.Indexes := new Separators_Indexes (1 .. Count_Sep); + J := S.Indexes'First; + + for K in S.Source'Range loop + if Is_In (S.Source (K), Separators) then + S.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.N_Slice := 0; + + Start := S.Source'First; + Stop := 0; + + loop + if K > Count_Sep then + + -- No more separators, last slice ends at end of source string + + Stop := S.Source'Last; + + else + Stop := S.Indexes (K) - 1; + end if; + + -- Add slice to the table + + S.N_Slice := S.N_Slice + 1; + S_Info (S.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.Indexes (K) + 1; + K := K + 1; + + when Multiple => + + -- In this mode skip separators following each other + + loop + Start := S.Indexes (K) + 1; + K := K + 1; + exit when K > Count_Sep + or else S.Indexes (K) > S.Indexes (K - 1) + 1; + end loop; + + end case; + end loop; + + S.Slices := new Slices_Indexes'(S_Info (1 .. S.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.Source.all; + + elsif Index > S.N_Slice then + raise Index_Error; + + else + return S.Source (S.Slices (Index).Start .. S.Slices (Index).Stop); + end if; + end Slice; + + ----------------- + -- Slice_Count -- + ----------------- + + function Slice_Count (S : Slice_Set) return Slice_Number is + begin + return S.N_Slice; + end Slice_Count; + +end GNAT.Array_Split; diff --git a/gcc/ada/g-arrspl.ads b/gcc/ada/g-arrspl.ads new file mode 100644 index 000000000..ac71af5a4 --- /dev/null +++ b/gcc/ada/g-arrspl.ads @@ -0,0 +1,187 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A R R A Y _ S P L I T -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 defined 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 string 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 Counter is access Natural; + + 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 Slice_Set is new Ada.Finalization.Controlled with record + Ref_Counter : Counter; -- 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; + + 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 new file mode 100644 index 000000000..6c8fa1a8b --- /dev/null +++ b/gcc/ada/g-awk.adb @@ -0,0 +1,1510 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A W K -- +-- -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_95; +-- This is needed because the pragmas Warnings (Off) in Current_Session and +-- Default_Session (see below) do not work when compiling clients of this +-- package that instantiate generic units herein. + +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 Session_Type is + begin + pragma Warnings (Off); + return Cur_Session; + -- ???The above return statement violates the Ada 2005 rule forbidding + -- copying of limited objects (see RM-7.5(2.8/2)). When compiled with + -- -gnatg, the compiler gives a warning instead of an error, so we can + -- turn it off. + pragma Warnings (On); + end Current_Session; + + --------------------- + -- Default_Session -- + --------------------- + + function Default_Session return Session_Type is + begin + pragma Warnings (Off); + return Def_Session; + -- ???The above return statement violates the Ada 2005 rule forbidding + -- copying of limited objects (see RM-7.5(2.8/2)). When compiled with + -- -gnatg, the compiler gives a warning instead of an error, so we can + -- turn it off. + pragma Warnings (On); + 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; + pragma Unreferenced (Discard); + 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 new file mode 100644 index 000000000..a854489a8 --- /dev/null +++ b/gcc/ada/g-awk.ads @@ -0,0 +1,643 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A W K -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2006, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is 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 above). + + ---------------------------- + -- 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 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 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 analyse 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; + 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-boubuf.adb b/gcc/ada/g-boubuf.adb new file mode 100644 index 000000000..a8ac5f1a9 --- /dev/null +++ b/gcc/ada/g-boubuf.adb @@ -0,0 +1,92 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . B O U N D E D _ B U F F E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2006, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Bounded_Buffers is + + -------------------- + -- Bounded_Buffer -- + -------------------- + + protected body Bounded_Buffer is + + ------------ + -- Insert -- + ------------ + + entry Insert (Item : Element) when Count /= Capacity is + begin + Values (Next_In) := Item; + Next_In := (Next_In mod Capacity) + 1; + Count := Count + 1; + end Insert; + + ------------ + -- Remove -- + ------------ + + entry Remove (Item : out Element) when Count > 0 is + begin + Item := Values (Next_Out); + Next_Out := (Next_Out mod Capacity) + 1; + Count := Count - 1; + end Remove; + + ----------- + -- Empty -- + ----------- + + function Empty return Boolean is + begin + return Count = 0; + end Empty; + + ---------- + -- Full -- + ---------- + + function Full return Boolean is + begin + return Count = Capacity; + end Full; + + ------------ + -- Extent -- + ------------ + + function Extent return Natural is + begin + return Count; + end Extent; + + end Bounded_Buffer; + +end GNAT.Bounded_Buffers; diff --git a/gcc/ada/g-boubuf.ads b/gcc/ada/g-boubuf.ads new file mode 100644 index 000000000..19d477f35 --- /dev/null +++ b/gcc/ada/g-boubuf.ads @@ -0,0 +1,103 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . B O U N D E D _ B U F F E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2003-2006, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a thread-safe generic bounded buffer abstraction. +-- Instances are useful directly or as parts of the implementations of other +-- abstractions, such as mailboxes. + +-- Bounded_Buffer is declared explicitly as a protected type, rather than as +-- a simple limited private type completed as a protected type, so that +-- clients may make calls accordingly (i.e., conditional/timed entry calls). + +with System; + +generic + type Element is private; + -- The type of the values contained within buffer objects + +package GNAT.Bounded_Buffers is + pragma Pure; + + type Content is array (Positive range <>) of Element; + -- Content is an internal artefact that cannot be hidden because protected + -- types cannot contain type declarations. + + Default_Ceiling : constant System.Priority := System.Default_Priority; + -- A convenience value for the Ceiling discriminant + + protected type Bounded_Buffer + (Capacity : Positive; + -- Objects of type Bounded_Buffer specify the maximum number of Element + -- values they can hold via the discriminant Capacity. + + Ceiling : System.Priority) + -- Users must specify the ceiling priority for the object. If the + -- Real-Time Systems Annex is not in use this value is not important. + is + pragma Priority (Ceiling); + + entry Insert (Item : Element); + -- Insert Item into the buffer, blocks caller until space is available + + entry Remove (Item : out Element); + -- Remove next available Element from buffer. Blocks caller until an + -- Element is available. + + function Empty return Boolean; + -- Returns whether the instance contains any Elements. + -- Note: State may change immediately after call returns. + + function Full return Boolean; + -- Returns whether any space remains within the instance. + -- Note: State may change immediately after call returns. + + function Extent return Natural; + -- Returns the number of Element values currently held + -- within the instance. + -- Note: State may change immediately after call returns. + + private + Values : Content (1 .. Capacity); + -- The container for the values held by the buffer instance + + Next_In : Positive := 1; + -- The index of the next Element inserted. Wraps around + + Next_Out : Positive := 1; + -- The index of the next Element removed. Wraps around + + Count : Natural := 0; + -- The number of Elements currently held + end Bounded_Buffer; + +end GNAT.Bounded_Buffers; diff --git a/gcc/ada/g-boumai.ads b/gcc/ada/g-boumai.ads new file mode 100644 index 000000000..bcadf34b9 --- /dev/null +++ b/gcc/ada/g-boumai.ads @@ -0,0 +1,98 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . B O U N D E D _ M A I L B O X E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2003-2006, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a thread-safe asynchronous communication facility +-- in the form of mailboxes. Individual mailbox objects are bounded in size +-- to a value specified by their Capacity discriminants. + +-- Mailboxes actually hold references to messages, not the message values +-- themselves. + +-- Type Mailbox is defined explicitly as a protected type (via derivation +-- from a protected type) so that clients may treat them accordingly (for +-- example, by making conditional/timed entry calls). + +with System; +with GNAT.Bounded_Buffers; + +generic + type Message (<>) is limited private; + type Message_Reference is access all Message; + -- Mailboxes hold references to Message values, of this type + +package GNAT.Bounded_Mailboxes is + pragma Preelaborate; + + package Message_Refs is + new GNAT.Bounded_Buffers (Message_Reference); + + type Mailbox is new Message_Refs.Bounded_Buffer; + + -- Type Mailbox has two inherited discriminants: + + -- Capacity : Positive; + -- Capacity is the maximum number of Message references + -- possibly contained at any given instant. + + -- Ceiling : System.Priority; + -- Users must specify the ceiling priority for the object. + -- If the Real-Time Systems Annex is not in use this value + -- is not important. + + -- Protected type Mailbox has the following inherited interface: + + -- entry Insert (Item : Message_Reference); + -- Insert Item into the Mailbox. Blocks caller + -- until space is available. + + -- entry Remove (Item : out Message_Reference); + -- Remove next available Message_Reference from Mailbox. + -- Blocks caller until a Message_Reference is available. + + -- function Empty return Boolean; + -- Returns whether the Mailbox contains any Message_References. + -- Note: State may change immediately after call returns. + + -- function Full return Boolean; + -- Returns whether any space remains within the Mailbox. + -- Note: State may change immediately after call returns. + + -- function Extent return Natural; + -- Returns the number of Message_Reference values currently held + -- within the Mailbox. + -- Note: State may change immediately after call returns. + + Default_Ceiling : constant System.Priority := Message_Refs.Default_Ceiling; + -- A convenience value for the Ceiling discriminant + +end GNAT.Bounded_Mailboxes; diff --git a/gcc/ada/g-bubsor.adb b/gcc/ada/g-bubsor.adb new file mode 100644 index 000000000..2537f7039 --- /dev/null +++ b/gcc/ada/g-bubsor.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-2005, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package 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 new file mode 100644 index 000000000..d88a1753e --- /dev/null +++ b/gcc/ada/g-bubsor.ads @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2006, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 new file mode 100644 index 000000000..5d21e97b8 --- /dev/null +++ b/gcc/ada/g-busora.adb @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2005, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package 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 new file mode 100644 index 000000000..b3e3b6070 --- /dev/null +++ b/gcc/ada/g-busora.ads @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2005, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 new file mode 100644 index 000000000..c9d9daefb --- /dev/null +++ b/gcc/ada/g-busorg.adb @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2005, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package 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 new file mode 100644 index 000000000..05566807c --- /dev/null +++ b/gcc/ada/g-busorg.ads @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 new file mode 100755 index 000000000..27138b463 --- /dev/null +++ b/gcc/ada/g-byorma.adb @@ -0,0 +1,197 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit; + +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 new file mode 100755 index 000000000..d01404e6e --- /dev/null +++ b/gcc/ada/g-byorma.ads @@ -0,0 +1,102 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a 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; + +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-x86.adb b/gcc/ada/g-bytswa-x86.adb new file mode 100644 index 000000000..3af951617 --- /dev/null +++ b/gcc/ada/g-bytswa-x86.adb @@ -0,0 +1,194 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2007, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a machine-specific version of this package. +-- It uses instructions available on Intel 486 processors (or later). + +with Interfaces; use Interfaces; +with System.Machine_Code; use System.Machine_Code; +with Ada.Unchecked_Conversion; + +package body GNAT.Byte_Swapping is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Swapped32 (Value : Unsigned_32) return Unsigned_32; + pragma Inline_Always (Swapped32); + + -------------- + -- Swapped2 -- + -------------- + + function Swapped2 (Input : Item) return Item is + + function As_U16 is new Ada.Unchecked_Conversion + (Source => Item, Target => Unsigned_16); + + function As_Item is new Ada.Unchecked_Conversion + (Source => Unsigned_16, Target => Item); + + X : Unsigned_16 := As_U16 (Input); + + begin + Asm ("xchgb %b0,%h0", + Unsigned_16'Asm_Output ("=q", X), + Unsigned_16'Asm_Input ("0", X)); + return As_Item (X); + end Swapped2; + + -------------- + -- Swapped4 -- + -------------- + + function Swapped4 (Input : Item) return Item is + + function As_U32 is new Ada.Unchecked_Conversion + (Source => Item, Target => Unsigned_32); + + function As_Item is new Ada.Unchecked_Conversion + (Source => Unsigned_32, Target => Item); + + X : Unsigned_32 := As_U32 (Input); + + begin + Asm ("bswap %0", + Unsigned_32'Asm_Output ("=r", X), + Unsigned_32'Asm_Input ("0", X)); + return As_Item (X); + end Swapped4; + + -------------- + -- Swapped8 -- + -------------- + + function Swapped8 (Input : Item) return Item is + + function As_U64 is new Ada.Unchecked_Conversion + (Source => Item, Target => Unsigned_64); + + X : constant Unsigned_64 := As_U64 (Input); + + type Two_Words is array (0 .. 1) of Unsigned_32; + for Two_Words'Component_Size use Unsigned_32'Size; + + function As_Item is new Ada.Unchecked_Conversion + (Source => Two_Words, Target => Item); + + Result : Two_Words; + + begin + Asm ("xchgl %0,%1", + Outputs => + (Unsigned_32'Asm_Output ("=r", Result (0)), + Unsigned_32'Asm_Output ("=r", Result (1))), + Inputs => + (Unsigned_32'Asm_Input ("0", + Swapped32 (Unsigned_32 (X and 16#0000_0000_FFFF_FFFF#))), + Unsigned_32'Asm_Input ("1", + Swapped32 (Unsigned_32 (Shift_Right (X, 32)))))); + return As_Item (Result); + end Swapped8; + + ----------- + -- Swap2 -- + ----------- + + procedure Swap2 (Location : System.Address) is + + X : Unsigned_16; + for X'Address use Location; + + begin + Asm ("xchgb %b0,%h0", + Unsigned_16'Asm_Output ("=q", X), + Unsigned_16'Asm_Input ("0", X)); + end Swap2; + + ----------- + -- Swap4 -- + ----------- + + procedure Swap4 (Location : System.Address) is + + X : Unsigned_32; + for X'Address use Location; + + begin + Asm ("bswap %0", + Unsigned_32'Asm_Output ("=r", X), + Unsigned_32'Asm_Input ("0", X)); + end Swap4; + + --------------- + -- Swapped32 -- + --------------- + + function Swapped32 (Value : Unsigned_32) return Unsigned_32 is + X : Unsigned_32 := Value; + begin + Asm ("bswap %0", + Unsigned_32'Asm_Output ("=r", X), + Unsigned_32'Asm_Input ("0", X)); + return X; + end Swapped32; + + ----------- + -- Swap8 -- + ----------- + + procedure Swap8 (Location : System.Address) is + + X : Unsigned_64; + for X'Address use Location; + + type Two_Words is array (0 .. 1) of Unsigned_32; + for Two_Words'Component_Size use Unsigned_32'Size; + + Words : Two_Words; + for Words'Address use Location; + + begin + Asm ("xchgl %0,%1", + Outputs => + (Unsigned_32'Asm_Output ("=r", Words (0)), + Unsigned_32'Asm_Output ("=r", Words (1))), + Inputs => + (Unsigned_32'Asm_Input ("0", + Swapped32 (Unsigned_32 (X and 16#0000_0000_FFFF_FFFF#))), + Unsigned_32'Asm_Input ("1", + Swapped32 (Unsigned_32 (Shift_Right (X, 32)))))); + end Swap8; + +end GNAT.Byte_Swapping; diff --git a/gcc/ada/g-bytswa.adb b/gcc/ada/g-bytswa.adb new file mode 100644 index 000000000..36eb12dcf --- /dev/null +++ b/gcc/ada/g-bytswa.adb @@ -0,0 +1,151 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2007, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a general implementation that does not take advantage of +-- any machine-specific instructions. + +with Interfaces; use Interfaces; +with Ada.Unchecked_Conversion; + +package body GNAT.Byte_Swapping is + + -------------- + -- Swapped2 -- + -------------- + + function Swapped2 (Input : Item) return Item is + + function As_U16 is new Ada.Unchecked_Conversion + (Source => Item, Target => Unsigned_16); + + function As_Item is new Ada.Unchecked_Conversion + (Source => Unsigned_16, Target => Item); + + X : constant Unsigned_16 := As_U16 (Input); + + begin + return As_Item ((Shift_Left (X, 8) and 16#FF00#) or + (Shift_Right (X, 8) and 16#00FF#)); + end Swapped2; + + -------------- + -- Swapped4 -- + -------------- + + function Swapped4 (Input : Item) return Item is + + function As_U32 is new Ada.Unchecked_Conversion + (Source => Item, Target => Unsigned_32); + + function As_Item is new Ada.Unchecked_Conversion + (Source => Unsigned_32, Target => Item); + + X : constant Unsigned_32 := As_U32 (Input); + + begin + return As_Item ((Shift_Right (X, 24) and 16#0000_00FF#) or + (Shift_Right (X, 8) and 16#0000_FF00#) or + (Shift_Left (X, 8) and 16#00FF_0000#) or + (Shift_Left (X, 24) and 16#FF00_0000#)); + end Swapped4; + + -------------- + -- Swapped8 -- + -------------- + + function Swapped8 (Input : Item) return Item is + + function As_U64 is new Ada.Unchecked_Conversion + (Source => Item, Target => Unsigned_64); + + function As_Item is new Ada.Unchecked_Conversion + (Source => Unsigned_64, Target => Item); + + X : constant Unsigned_64 := As_U64 (Input); + + Low, High : aliased Unsigned_32; + + begin + Low := Unsigned_32 (X and 16#0000_0000_FFFF_FFFF#); + Swap4 (Low'Address); + High := Unsigned_32 (Shift_Right (X, 32)); + Swap4 (High'Address); + return As_Item + (Shift_Left (Unsigned_64 (Low), 32) or Unsigned_64 (High)); + end Swapped8; + + ----------- + -- Swap2 -- + ----------- + + procedure Swap2 (Location : System.Address) is + X : Unsigned_16; + for X'Address use Location; + begin + X := (Shift_Left (X, 8) and 16#FF00#) or + (Shift_Right (X, 8) and 16#00FF#); + end Swap2; + + ----------- + -- Swap4 -- + ----------- + + procedure Swap4 (Location : System.Address) is + X : Unsigned_32; + for X'Address use Location; + begin + X := (Shift_Right (X, 24) and 16#0000_00FF#) or + (Shift_Right (X, 8) and 16#0000_FF00#) or + (Shift_Left (X, 8) and 16#00FF_0000#) or + (Shift_Left (X, 24) and 16#FF00_0000#); + end Swap4; + + ----------- + -- Swap8 -- + ----------- + + procedure Swap8 (Location : System.Address) is + X : Unsigned_64; + for X'Address use Location; + + Low, High : aliased Unsigned_32; + + begin + Low := Unsigned_32 (X and 16#0000_0000_FFFF_FFFF#); + Swap4 (Low'Address); + High := Unsigned_32 (Shift_Right (X, 32)); + Swap4 (High'Address); + X := Shift_Left (Unsigned_64 (Low), 32) or Unsigned_64 (High); + end Swap8; + +end GNAT.Byte_Swapping; diff --git a/gcc/ada/g-bytswa.ads b/gcc/ada/g-bytswa.ads new file mode 100644 index 000000000..a8d2d9c4d --- /dev/null +++ b/gcc/ada/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-2007, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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"; +-- 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'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 new file mode 100644 index 000000000..46d647f8a --- /dev/null +++ b/gcc/ada/g-calend.adb @@ -0,0 +1,549 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C A L E N D A R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package 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; + + ---------------- + -- 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; + + ----------------- + -- 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.long; + usec : not null access C.long); + pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); + + Micro : constant := 10**6; + sec : aliased C.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.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.long; + usec : C.long; + + begin + if D = 0.0 then + sec := 0; + usec := 0; + else + sec := C.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 new file mode 100644 index 000000000..9dd5ae00a --- /dev/null +++ b/gcc/ada/g-calend.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C A L E N D A R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1999-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; +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 the standard Ada.Calendar.Time data in date data (Year, Month, + -- Day) and Time data (Hour, Minute, Second, Sub_Second) + + 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 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 .. 2) 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.Time_Of + (Ada.Calendar.Year_Number'First, + Ada.Calendar.Month_Number'First, + Ada.Calendar.Day_Number'First); + +end GNAT.Calendar; diff --git a/gcc/ada/g-casuti.adb b/gcc/ada/g-casuti.adb new file mode 100644 index 000000000..be72488b3 --- /dev/null +++ b/gcc/ada/g-casuti.adb @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C A S E _ U T I L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2005, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is 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 new file mode 100644 index 000000000..b32036d67 --- /dev/null +++ b/gcc/ada/g-casuti.ads @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C A S E _ U T I L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Simple casing functions + +-- This package provides simple casing functions that do not require the +-- overhead of the full casing tables found in Ada.Characters.Handling. + +-- Note: actual code is found in System.Case_Util, which is used internally +-- by the GNAT run time. Applications programs should always use this package +-- rather than using System.Case_Util directly. + +with System.Case_Util; + +package GNAT.Case_Util is + pragma Pure; + pragma Elaborate_Body; + -- The elaborate body is because we have a dummy body to deal with + -- bootstrap path problems (we used to have a real body, and now we don't + -- need it any more, but the bootstrap requires that we have a dummy body, + -- since otherwise the old body gets picked up. + + -- Note: all the following functions handle the full Latin-1 set + + function To_Upper (A : Character) return Character + renames System.Case_Util.To_Upper; + -- Converts A to upper case if it is a lower case letter, otherwise + -- returns the input argument unchanged. + + procedure To_Upper (A : in out String) + renames System.Case_Util.To_Upper; + -- Folds all characters of string A to upper case + + function To_Lower (A : Character) return Character + renames System.Case_Util.To_Lower; + -- Converts A to lower case if it is an upper case letter, otherwise + -- returns the input argument unchanged. + + procedure To_Lower (A : in out String) + renames System.Case_Util.To_Lower; + -- Folds all characters of string A to lower case + + procedure To_Mixed (A : in out String) + renames System.Case_Util.To_Mixed; + -- Converts A to mixed case (i.e. lower case, except for initial + -- character and any character after an underscore, which are + -- converted to upper case. + +end GNAT.Case_Util; diff --git a/gcc/ada/g-catiio.adb b/gcc/ada/g-catiio.adb new file mode 100644 index 000000000..66a6480b3 --- /dev/null +++ b/gcc/ada/g-catiio.adb @@ -0,0 +1,827 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C A L E N D A R . T I M E _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Calendar; use Ada.Calendar; +with Ada.Characters.Handling; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Text_IO; + +with GNAT.Case_Util; + +package body GNAT.Calendar.Time_IO is + + type Month_Name is + (January, + February, + March, + April, + May, + June, + July, + August, + September, + October, + November, + December); + + function Month_Name_To_Number + (Str : String) return Ada.Calendar.Month_Number; + -- Converts a string that contains an abbreviated month name to a month + -- number. Constraint_Error is raised if Str is not a valid month name. + -- Comparison is case insensitive + + type Padding_Mode is (None, Zero, Space); + + type Sec_Number is mod 2 ** 64; + -- Type used to compute the number of seconds since 01/01/1970. A 32 bit + -- number will cover only a period of 136 years. This means that for date + -- past 2106 the computation is not possible. A 64 bits number should be + -- enough for a very large period of time. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Am_Pm (H : Natural) return String; + -- Return AM or PM depending on the hour H + + function Hour_12 (H : Natural) return Positive; + -- Convert a 1-24h format to a 0-12 hour format + + function Image (Str : String; Length : Natural := 0) return String; + -- Return Str capitalized and cut to length number of characters. If + -- length is 0, then no cut operation is performed. + + function Image + (N : Sec_Number; + Padding : Padding_Mode := Zero; + Length : Natural := 0) return String; + -- Return image of N. This number is eventually padded with zeros or spaces + -- depending of the length required. If length is 0 then no padding occurs. + + function Image + (N : Natural; + Padding : Padding_Mode := Zero; + Length : Natural := 0) return String; + -- As above with N provided in Integer format + + ----------- + -- Am_Pm -- + ----------- + + function Am_Pm (H : Natural) return String is + begin + if H = 0 or else H > 12 then + return "PM"; + else + return "AM"; + end if; + end Am_Pm; + + ------------- + -- Hour_12 -- + ------------- + + function Hour_12 (H : Natural) return Positive is + begin + if H = 0 then + return 12; + elsif H <= 12 then + return H; + else -- H > 12 + return H - 12; + end if; + end Hour_12; + + ----------- + -- Image -- + ----------- + + function Image + (Str : String; + Length : Natural := 0) return String + is + use Ada.Characters.Handling; + Local : constant String := + To_Upper (Str (Str'First)) & + To_Lower (Str (Str'First + 1 .. Str'Last)); + begin + if Length = 0 then + return Local; + else + return Local (1 .. Length); + end if; + end Image; + + ----------- + -- Image -- + ----------- + + function Image + (N : Natural; + Padding : Padding_Mode := Zero; + Length : Natural := 0) return String + is + begin + return Image (Sec_Number (N), Padding, Length); + end Image; + + function Image + (N : Sec_Number; + Padding : Padding_Mode := Zero; + Length : Natural := 0) return String + is + function Pad_Char return String; + + -------------- + -- Pad_Char -- + -------------- + + function Pad_Char return String is + begin + case Padding is + when None => return ""; + when Zero => return "00"; + when Space => return " "; + end case; + end Pad_Char; + + -- Local Declarations + + NI : constant String := Sec_Number'Image (N); + NIP : constant String := Pad_Char & NI (2 .. NI'Last); + + -- Start of processing for Image + + begin + if Length = 0 or else Padding = None then + return NI (2 .. NI'Last); + else + return NIP (NIP'Last - Length + 1 .. NIP'Last); + end if; + end Image; + + ----------- + -- Image -- + ----------- + + function Image + (Date : Ada.Calendar.Time; + Picture : Picture_String) return String + is + Padding : Padding_Mode := Zero; + -- Padding is set for one directive + + Result : Unbounded_String; + + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Second_Duration; + + P : Positive; + + begin + -- Get current time in split format + + Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); + + -- Null picture string is error + + if Picture = "" then + raise Picture_Error with "null picture string"; + end if; + + -- Loop through characters of picture string, building result + + Result := Null_Unbounded_String; + P := Picture'First; + while P <= Picture'Last loop + + -- A directive has the following format "%[-_]." + + if Picture (P) = '%' then + Padding := Zero; + + if P = Picture'Last then + raise Picture_Error with "picture string ends with '%"; + end if; + + -- Check for GNU extension to change the padding + + if Picture (P + 1) = '-' then + Padding := None; + P := P + 1; + + elsif Picture (P + 1) = '_' then + Padding := Space; + P := P + 1; + end if; + + if P = Picture'Last then + raise Picture_Error with "picture string ends with '- or '_"; + end if; + + case Picture (P + 1) is + + -- Literal % + + when '%' => + Result := Result & '%'; + + -- A newline + + when 'n' => + Result := Result & ASCII.LF; + + -- A horizontal tab + + when 't' => + Result := Result & ASCII.HT; + + -- Hour (00..23) + + when 'H' => + Result := Result & Image (Hour, Padding, 2); + + -- Hour (01..12) + + when 'I' => + Result := Result & Image (Hour_12 (Hour), Padding, 2); + + -- Hour ( 0..23) + + when 'k' => + Result := Result & Image (Hour, Space, 2); + + -- Hour ( 1..12) + + when 'l' => + Result := Result & Image (Hour_12 (Hour), Space, 2); + + -- Minute (00..59) + + when 'M' => + Result := Result & Image (Minute, Padding, 2); + + -- AM/PM + + when 'p' => + Result := Result & Am_Pm (Hour); + + -- Time, 12-hour (hh:mm:ss [AP]M) + + when 'r' => + Result := Result & + Image (Hour_12 (Hour), Padding, Length => 2) & ':' & + Image (Minute, Padding, Length => 2) & ':' & + Image (Second, Padding, Length => 2) & ' ' & + Am_Pm (Hour); + + -- Seconds since 1970-01-01 00:00:00 UTC + -- (a nonstandard extension) + + when 's' => + declare + -- Compute the number of seconds using Ada.Calendar.Time + -- values rather than Julian days to account for Daylight + -- Savings Time. + + Neg : Boolean := False; + Sec : Duration := Date - Time_Of (1970, 1, 1, 0.0); + + begin + -- Avoid rounding errors and perform special processing + -- for dates earlier than the Unix Epoc. + + if Sec > 0.0 then + Sec := Sec - 0.5; + elsif Sec < 0.0 then + Neg := True; + Sec := abs (Sec + 0.5); + end if; + + -- Prepend a minus sign to the result since Sec_Number + -- cannot handle negative numbers. + + if Neg then + Result := + Result & "-" & Image (Sec_Number (Sec), None); + else + Result := Result & Image (Sec_Number (Sec), None); + end if; + end; + + -- Second (00..59) + + when 'S' => + Result := Result & Image (Second, Padding, Length => 2); + + -- Milliseconds (3 digits) + -- Microseconds (6 digits) + -- Nanoseconds (9 digits) + + when 'i' | 'e' | 'o' => + declare + Sub_Sec : constant Long_Integer := + Long_Integer (Sub_Second * 1_000_000_000); + + Img1 : constant String := Sub_Sec'Img; + Img2 : constant String := + "00000000" & Img1 (Img1'First + 1 .. Img1'Last); + Nanos : constant String := + Img2 (Img2'Last - 8 .. Img2'Last); + + begin + case Picture (P + 1) is + when 'i' => + Result := Result & + Nanos (Nanos'First .. Nanos'First + 2); + + when 'e' => + Result := Result & + Nanos (Nanos'First .. Nanos'First + 5); + + when 'o' => + Result := Result & Nanos; + + when others => + null; + end case; + end; + + -- Time, 24-hour (hh:mm:ss) + + when 'T' => + Result := Result & + Image (Hour, Padding, Length => 2) & ':' & + Image (Minute, Padding, Length => 2) & ':' & + Image (Second, Padding, Length => 2); + + -- Locale's abbreviated weekday name (Sun..Sat) + + when 'a' => + Result := Result & + Image (Day_Name'Image (Day_Of_Week (Date)), 3); + + -- Locale's full weekday name, variable length + -- (Sunday..Saturday) + + when 'A' => + Result := Result & + Image (Day_Name'Image (Day_Of_Week (Date))); + + -- Locale's abbreviated month name (Jan..Dec) + + when 'b' | 'h' => + Result := Result & + Image (Month_Name'Image (Month_Name'Val (Month - 1)), 3); + + -- Locale's full month name, variable length + -- (January..December). + + when 'B' => + Result := Result & + Image (Month_Name'Image (Month_Name'Val (Month - 1))); + + -- Locale's date and time (Sat Nov 04 12:02:33 EST 1989) + + when 'c' => + case Padding is + when Zero => + Result := Result & Image (Date, "%a %b %d %T %Y"); + when Space => + Result := Result & Image (Date, "%a %b %_d %_T %Y"); + when None => + Result := Result & Image (Date, "%a %b %-d %-T %Y"); + end case; + + -- Day of month (01..31) + + when 'd' => + Result := Result & Image (Day, Padding, 2); + + -- Date (mm/dd/yy) + + when 'D' | 'x' => + Result := Result & + Image (Month, Padding, 2) & '/' & + Image (Day, Padding, 2) & '/' & + Image (Year, Padding, 2); + + -- Day of year (001..366) + + when 'j' => + Result := Result & Image (Day_In_Year (Date), Padding, 3); + + -- Month (01..12) + + when 'm' => + Result := Result & Image (Month, Padding, 2); + + -- Week number of year with Sunday as first day of week + -- (00..53) + + when 'U' => + declare + Offset : constant Natural := + (Julian_Day (Year, 1, 1) + 1) mod 7; + + Week : constant Natural := + 1 + ((Day_In_Year (Date) - 1) + Offset) / 7; + + begin + Result := Result & Image (Week, Padding, 2); + end; + + -- Day of week (0..6) with 0 corresponding to Sunday + + when 'w' => + declare + DOW : constant Natural range 0 .. 6 := + (if Day_Of_Week (Date) = Sunday + then 0 + else Day_Name'Pos (Day_Of_Week (Date))); + begin + Result := Result & Image (DOW, Length => 1); + end; + + -- Week number of year with Monday as first day of week + -- (00..53) + + when 'W' => + Result := Result & Image (Week_In_Year (Date), Padding, 2); + + -- Last two digits of year (00..99) + + when 'y' => + declare + Y : constant Natural := Year - (Year / 100) * 100; + begin + Result := Result & Image (Y, Padding, 2); + end; + + -- Year (1970...) + + when 'Y' => + Result := Result & Image (Year, None, 4); + + when others => + raise Picture_Error with + "unknown format character in picture string"; + + end case; + + -- Skip past % and format character + + P := P + 2; + + -- Character other than % is copied into the result + + else + Result := Result & Picture (P); + P := P + 1; + end if; + end loop; + + return To_String (Result); + end Image; + + -------------------------- + -- Month_Name_To_Number -- + -------------------------- + + function Month_Name_To_Number + (Str : String) return Ada.Calendar.Month_Number + is + subtype String3 is String (1 .. 3); + Abbrev_Upper_Month_Names : + constant array (Ada.Calendar.Month_Number) of String3 := + ("JAN", "FEB", "MAR", "APR", "MAY", "JUN", + "JUL", "AUG", "SEP", "OCT", "NOV", "DEC"); + -- Short version of the month names, used when parsing date strings + + S : String := Str; + + begin + GNAT.Case_Util.To_Upper (S); + + for J in Abbrev_Upper_Month_Names'Range loop + if Abbrev_Upper_Month_Names (J) = S then + return J; + end if; + end loop; + + return Abbrev_Upper_Month_Names'First; + end Month_Name_To_Number; + + ----------- + -- Value -- + ----------- + + function Value (Date : String) return Ada.Calendar.Time is + D : String (1 .. 21); + D_Length : constant Natural := Date'Length; + + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + + procedure Extract_Date + (Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Time_Start : out Natural); + -- Try and extract a date value from string D. Time_Start is set to the + -- first character that could be the start of time data. + + procedure Extract_Time + (Index : Positive; + Hour : out Hour_Number; + Minute : out Minute_Number; + Second : out Second_Number; + Check_Space : Boolean := False); + -- Try and extract a time value from string D starting from position + -- Index. Set Check_Space to True to check whether the character at + -- Index - 1 is a space. Raise Constraint_Error if the portion of D + -- corresponding to the date is not well formatted. + + ------------------ + -- Extract_Date -- + ------------------ + + procedure Extract_Date + (Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Time_Start : out Natural) + is + begin + if D (3) = '-' or else D (3) = '/' then + if D_Length = 8 or else D_Length = 17 then + + -- Formats are "yy*mm*dd" or "yy*mm*dd hh:mm:ss" + + if D (6) /= D (3) then + raise Constraint_Error; + end if; + + Year := Year_Number'Value ("20" & D (1 .. 2)); + Month := Month_Number'Value (D (4 .. 5)); + Day := Day_Number'Value (D (7 .. 8)); + Time_Start := 10; + + elsif D_Length = 10 or else D_Length = 19 then + + -- Formats are "mm*dd*yyyy" or "mm*dd*yyyy hh:mm:ss" + + if D (6) /= D (3) then + raise Constraint_Error; + end if; + + Year := Year_Number'Value (D (7 .. 10)); + Month := Month_Number'Value (D (1 .. 2)); + Day := Day_Number'Value (D (4 .. 5)); + Time_Start := 12; + + elsif D_Length = 11 or else D_Length = 20 then + + -- Formats are "dd*mmm*yyyy" or "dd*mmm*yyyy hh:mm:ss" + + if D (7) /= D (3) then + raise Constraint_Error; + end if; + + Year := Year_Number'Value (D (8 .. 11)); + Month := Month_Name_To_Number (D (4 .. 6)); + Day := Day_Number'Value (D (1 .. 2)); + Time_Start := 13; + + else + raise Constraint_Error; + end if; + + elsif D (3) = ' ' then + if D_Length = 11 or else D_Length = 20 then + + -- Possible formats are "dd mmm yyyy", "dd mmm yyyy hh:mm:ss" + + if D (7) /= ' ' then + raise Constraint_Error; + end if; + + Year := Year_Number'Value (D (8 .. 11)); + Month := Month_Name_To_Number (D (4 .. 6)); + Day := Day_Number'Value (D (1 .. 2)); + Time_Start := 13; + + else + raise Constraint_Error; + end if; + + else + if D_Length = 8 or else D_Length = 17 then + + -- Possible formats are "yyyymmdd" or "yyyymmdd hh:mm:ss" + + Year := Year_Number'Value (D (1 .. 4)); + Month := Month_Number'Value (D (5 .. 6)); + Day := Day_Number'Value (D (7 .. 8)); + Time_Start := 10; + + elsif D_Length = 10 or else D_Length = 19 then + + -- Possible formats are "yyyy*mm*dd" or "yyyy*mm*dd hh:mm:ss" + + if (D (5) /= '-' and then D (5) /= '/') + or else D (8) /= D (5) + then + raise Constraint_Error; + end if; + + Year := Year_Number'Value (D (1 .. 4)); + Month := Month_Number'Value (D (6 .. 7)); + Day := Day_Number'Value (D (9 .. 10)); + Time_Start := 12; + + elsif D_Length = 11 or else D_Length = 20 then + + -- Possible formats are "yyyy*mmm*dd" + + if (D (5) /= '-' and then D (5) /= '/') + or else D (9) /= D (5) + then + raise Constraint_Error; + end if; + + Year := Year_Number'Value (D (1 .. 4)); + Month := Month_Name_To_Number (D (6 .. 8)); + Day := Day_Number'Value (D (10 .. 11)); + Time_Start := 13; + + elsif D_Length = 12 or else D_Length = 21 then + + -- Formats are "mmm dd, yyyy" or "mmm dd, yyyy hh:mm:ss" + + if D (4) /= ' ' + or else D (7) /= ',' + or else D (8) /= ' ' + then + raise Constraint_Error; + end if; + + Year := Year_Number'Value (D (9 .. 12)); + Month := Month_Name_To_Number (D (1 .. 3)); + Day := Day_Number'Value (D (5 .. 6)); + Time_Start := 14; + + else + raise Constraint_Error; + end if; + end if; + end Extract_Date; + + ------------------ + -- Extract_Time -- + ------------------ + + procedure Extract_Time + (Index : Positive; + Hour : out Hour_Number; + Minute : out Minute_Number; + Second : out Second_Number; + Check_Space : Boolean := False) + is + begin + -- If no time was specified in the string (do not allow trailing + -- character either) + + if Index = D_Length + 2 then + Hour := 0; + Minute := 0; + Second := 0; + + else + -- Not enough characters left ? + + if Index /= D_Length - 7 then + raise Constraint_Error; + end if; + + if Check_Space and then D (Index - 1) /= ' ' then + raise Constraint_Error; + end if; + + if D (Index + 2) /= ':' or else D (Index + 5) /= ':' then + raise Constraint_Error; + end if; + + Hour := Hour_Number'Value (D (Index .. Index + 1)); + Minute := Minute_Number'Value (D (Index + 3 .. Index + 4)); + Second := Second_Number'Value (D (Index + 6 .. Index + 7)); + end if; + end Extract_Time; + + -- Local Declarations + + Time_Start : Natural := 1; + + -- Start of processing for Value + + begin + -- Length checks + + if D_Length /= 8 + and then D_Length /= 10 + and then D_Length /= 11 + and then D_Length /= 12 + and then D_Length /= 17 + and then D_Length /= 19 + and then D_Length /= 20 + and then D_Length /= 21 + then + raise Constraint_Error; + end if; + + -- After the correct length has been determined, it is safe to create + -- a local string copy in order to avoid String'First N arithmetic. + + D (1 .. D_Length) := Date; + + if D_Length /= 8 or else D (3) /= ':' then + Extract_Date (Year, Month, Day, Time_Start); + Extract_Time (Time_Start, Hour, Minute, Second, Check_Space => True); + + else + declare + Discard : Second_Duration; + pragma Unreferenced (Discard); + begin + Split (Clock, Year, Month, Day, Hour, Minute, Second, + Sub_Second => Discard); + end; + + Extract_Time (1, Hour, Minute, Second, Check_Space => False); + end if; + + -- Sanity checks + + if not Year'Valid + or else not Month'Valid + or else not Day'Valid + or else not Hour'Valid + or else not Minute'Valid + or else not Second'Valid + then + raise Constraint_Error; + end if; + + return Time_Of (Year, Month, Day, Hour, Minute, Second); + end Value; + + -------------- + -- Put_Time -- + -------------- + + procedure Put_Time (Date : Ada.Calendar.Time; Picture : Picture_String) is + begin + Ada.Text_IO.Put (Image (Date, Picture)); + end Put_Time; + +end GNAT.Calendar.Time_IO; diff --git a/gcc/ada/g-catiio.ads b/gcc/ada/g-catiio.ads new file mode 100644 index 000000000..1f73c2198 --- /dev/null +++ b/gcc/ada/g-catiio.ads @@ -0,0 +1,156 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C A L E N D A R . T I M E _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1999-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package augments standard Ada.Text_IO with facilities for input +-- and output of time values in standardized format. + +package GNAT.Calendar.Time_IO is + + Picture_Error : exception; + -- Exception raised for incorrect picture + + type Picture_String is new String; + -- This is a string to describe date and time output format. The string is + -- a set of standard character and special tag that are replaced by the + -- corresponding values. It follows the GNU Date specification. Here are + -- the recognized directives : + -- + -- % a literal % + -- n a newline + -- t a horizontal tab + -- + -- Time fields: + -- + -- %H hour (00..23) + -- %I hour (01..12) + -- %k hour ( 0..23) + -- %l hour ( 1..12) + -- %M minute (00..59) + -- %p locale's AM or PM + -- %r time, 12-hour (hh:mm:ss [AP]M) + -- %s seconds since 1970-01-01 00:00:00 UTC + -- (a nonstandard extension) + -- %S second (00..59) + -- %T time, 24-hour (hh:mm:ss) + -- + -- Date fields: + -- + -- %a locale's abbreviated weekday name (Sun..Sat) + -- %A locale's full weekday name, variable length + -- (Sunday..Saturday) + -- %b locale's abbreviated month name (Jan..Dec) + -- %B locale's full month name, variable length + -- (January..December) + -- %c locale's date and time (Sat Nov 04 12:02:33 EST 1989) + -- %d day of month (01..31) + -- %D date (mm/dd/yy) + -- %h same as %b + -- %j day of year (001..366) + -- %m month (01..12) + -- %U week number of year with Sunday as first day of week + -- (00..53) + -- %w day of week (0..6) with 0 corresponding to Sunday + -- %W week number of year with Monday as first day of week + -- (00..53) + -- %x locale's date representation (mm/dd/yy) + -- %y last two digits of year (00..99) + -- %Y year (1970...) + -- + -- By default, date pads numeric fields with zeroes. GNU date + -- recognizes the following nonstandard numeric modifiers: + -- + -- - (hyphen) do not pad the field + -- _ (underscore) pad the field with spaces + -- + -- Here are some GNAT extensions to the GNU Date specification: + -- + -- %i milliseconds (3 digits) + -- %e microseconds (6 digits) + -- %o nanoseconds (9 digits) + + ISO_Date : constant Picture_String; + -- This format follow the ISO 8601 standard. The format is "YYYY-MM-DD", + -- four digits year, month and day number separated by minus. + + US_Date : constant Picture_String; + -- This format is the common US date format: "MM/DD/YY", + -- month and day number, two digits year separated by slashes. + + European_Date : constant Picture_String; + -- This format is the common European date format: "DD/MM/YY", + -- day and month number, two digits year separated by slashes. + + function Image + (Date : Ada.Calendar.Time; + Picture : Picture_String) return String; + -- Return Date as a string with format Picture. Raise Picture_Error if + -- picture string is null or has an incorrect format. + + function Value (Date : String) return Ada.Calendar.Time; + -- Parse the string Date and return its equivalent as a Time value. The + -- following time format is supported: + -- + -- hh:mm:ss - Date is the current date + -- + -- The following formats are also supported. They all accept an optional + -- time with the format "hh:mm:ss". The time is separated from the date by + -- exactly one space character. + -- + -- When the time is not specified, it is set to 00:00:00. The delimiter '*' + -- must be either '-' and '/' and both occurrences must use the same + -- character. + -- + -- Trailing characters (in particular spaces) are not allowed + -- + -- yyyy*mm*dd - ISO format + -- yy*mm*dd - Year is assumed to be 20yy + -- mm*dd*yyyy - (US date format) + -- dd*mmm*yyyy - month spelled out + -- yyyy*mmm*dd - month spelled out + -- yyyymmdd - Iso format, no separator + -- mmm dd, yyyy - month spelled out + -- dd mmm yyyy - month spelled out + -- + -- Constraint_Error is raised if the input string is malformed (does not + -- conform to one of the above dates, or has an invalid time string), or + -- the resulting time is not valid. + + procedure Put_Time (Date : Ada.Calendar.Time; Picture : Picture_String); + -- Put Date with format Picture. Raise Picture_Error if bad picture string + +private + ISO_Date : constant Picture_String := "%Y-%m-%d"; + US_Date : constant Picture_String := "%m/%d/%y"; + European_Date : constant Picture_String := "%d/%m/%y"; + +end GNAT.Calendar.Time_IO; diff --git a/gcc/ada/g-cgi.adb b/gcc/ada/g-cgi.adb new file mode 100644 index 000000000..dad373811 --- /dev/null +++ b/gcc/ada/g-cgi.adb @@ -0,0 +1,496 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C G I -- +-- -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; +with Ada.Strings.Fixed; +with Ada.Characters.Handling; +with Ada.Strings.Maps; + +with GNAT.OS_Lib; +with GNAT.Table; + +package body GNAT.CGI is + + use Ada; + + Valid_Environment : Boolean := True; + -- This boolean will be set to False if the initialization was not + -- completed correctly. It must be set to true there because the + -- Initialize routine (called during elaboration) will use some of the + -- services exported by this unit. + + Current_Method : Method_Type; + -- This is the current method used to pass CGI parameters + + Header_Sent : Boolean := False; + -- Will be set to True when the header will be sent + + -- Key/Value table declaration + + type String_Access is access String; + + type Key_Value is record + Key : String_Access; + Value : String_Access; + end record; + + package Key_Value_Table is new Table (Key_Value, Positive, 1, 1, 50); + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Check_Environment; + pragma Inline (Check_Environment); + -- This procedure will raise Data_Error if Valid_Environment is False + + procedure Initialize; + -- Initialize CGI package by reading the runtime environment. This + -- procedure is called during elaboration. All exceptions raised during + -- this procedure are deferred. + + -------------------- + -- Argument_Count -- + -------------------- + + function Argument_Count return Natural is + begin + Check_Environment; + return Key_Value_Table.Last; + end Argument_Count; + + ----------------------- + -- Check_Environment -- + ----------------------- + + procedure Check_Environment is + begin + if not Valid_Environment then + raise Data_Error; + end if; + end Check_Environment; + + ------------ + -- Decode -- + ------------ + + function Decode (S : String) return String is + Result : String (S'Range); + K : Positive := S'First; + J : Positive := Result'First; + + begin + while K <= S'Last loop + if K + 2 <= S'Last + and then S (K) = '%' + and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 1)) + and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 2)) + then + -- Here we have '%HH' which is an encoded character where 'HH' is + -- the character number in hexadecimal. + + Result (J) := Character'Val + (Natural'Value ("16#" & S (K + 1 .. K + 2) & '#')); + K := K + 3; + + -- Plus sign is decoded as a space + + elsif S (K) = '+' then + Result (J) := ' '; + K := K + 1; + + else + Result (J) := S (K); + K := K + 1; + end if; + + J := J + 1; + end loop; + + return Result (Result'First .. J - 1); + end Decode; + + ------------------------- + -- For_Every_Parameter -- + ------------------------- + + procedure For_Every_Parameter is + Quit : Boolean; + + begin + Check_Environment; + + for K in 1 .. Key_Value_Table.Last loop + + Quit := False; + + Action (Key_Value_Table.Table (K).Key.all, + Key_Value_Table.Table (K).Value.all, + K, + Quit); + + exit when Quit; + + end loop; + end For_Every_Parameter; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + + Request_Method : constant String := + Characters.Handling.To_Upper + (Metavariable (CGI.Request_Method)); + + procedure Initialize_GET; + -- Read CGI parameters for a GET method. In this case the parameters + -- are passed into QUERY_STRING environment variable. + + procedure Initialize_POST; + -- Read CGI parameters for a POST method. In this case the parameters + -- are passed with the standard input. The total number of characters + -- for the data is passed in CONTENT_LENGTH environment variable. + + procedure Set_Parameter_Table (Data : String); + -- Parse the parameter data and set the parameter table + + -------------------- + -- Initialize_GET -- + -------------------- + + procedure Initialize_GET is + Data : constant String := Metavariable (Query_String); + begin + Current_Method := Get; + + if Data /= "" then + Set_Parameter_Table (Data); + end if; + end Initialize_GET; + + --------------------- + -- Initialize_POST -- + --------------------- + + procedure Initialize_POST is + Content_Length : constant Natural := + Natural'Value (Metavariable (CGI.Content_Length)); + Data : String (1 .. Content_Length); + + begin + Current_Method := Post; + + if Content_Length /= 0 then + Text_IO.Get (Data); + Set_Parameter_Table (Data); + end if; + end Initialize_POST; + + ------------------------- + -- Set_Parameter_Table -- + ------------------------- + + procedure Set_Parameter_Table (Data : String) is + + procedure Add_Parameter (K : Positive; P : String); + -- Add a single parameter into the table at index K. The parameter + -- format is "key=value". + + Count : constant Positive := + 1 + Strings.Fixed.Count (Data, Strings.Maps.To_Set ("&")); + -- Count is the number of parameters in the string. Parameters are + -- separated by ampersand character. + + Index : Positive := Data'First; + Amp : Natural; + + ------------------- + -- Add_Parameter -- + ------------------- + + procedure Add_Parameter (K : Positive; P : String) is + Equal : constant Natural := Strings.Fixed.Index (P, "="); + + begin + if Equal = 0 then + raise Data_Error; + + else + Key_Value_Table.Table (K) := + Key_Value'(new String'(Decode (P (P'First .. Equal - 1))), + new String'(Decode (P (Equal + 1 .. P'Last)))); + end if; + end Add_Parameter; + + -- Start of processing for Set_Parameter_Table + + begin + Key_Value_Table.Set_Last (Count); + + for K in 1 .. Count - 1 loop + Amp := Strings.Fixed.Index (Data (Index .. Data'Last), "&"); + + Add_Parameter (K, Data (Index .. Amp - 1)); + + Index := Amp + 1; + end loop; + + -- add last parameter + + Add_Parameter (Count, Data (Index .. Data'Last)); + end Set_Parameter_Table; + + -- Start of processing for Initialize + + begin + if Request_Method = "GET" then + Initialize_GET; + + elsif Request_Method = "POST" then + Initialize_POST; + + else + Valid_Environment := False; + end if; + + exception + when others => + + -- If we have an exception during initialization of this unit we + -- just declare it invalid. + + Valid_Environment := False; + end Initialize; + + --------- + -- Key -- + --------- + + function Key (Position : Positive) return String is + begin + Check_Environment; + + if Position <= Key_Value_Table.Last then + return Key_Value_Table.Table (Position).Key.all; + else + raise Parameter_Not_Found; + end if; + end Key; + + ---------------- + -- Key_Exists -- + ---------------- + + function Key_Exists (Key : String) return Boolean is + begin + Check_Environment; + + for K in 1 .. Key_Value_Table.Last loop + if Key_Value_Table.Table (K).Key.all = Key then + return True; + end if; + end loop; + + return False; + end Key_Exists; + + ------------------ + -- Metavariable -- + ------------------ + + function Metavariable + (Name : Metavariable_Name; + Required : Boolean := False) return String + is + function Get_Environment (Variable_Name : String) return String; + -- Returns the environment variable content + + --------------------- + -- Get_Environment -- + --------------------- + + function Get_Environment (Variable_Name : String) return String is + Value : OS_Lib.String_Access := OS_Lib.Getenv (Variable_Name); + Result : constant String := Value.all; + begin + OS_Lib.Free (Value); + return Result; + end Get_Environment; + + Result : constant String := + Get_Environment (Metavariable_Name'Image (Name)); + + -- Start of processing for Metavariable + + begin + Check_Environment; + + if Result = "" and then Required then + raise Parameter_Not_Found; + else + return Result; + end if; + end Metavariable; + + ------------------------- + -- Metavariable_Exists -- + ------------------------- + + function Metavariable_Exists (Name : Metavariable_Name) return Boolean is + begin + Check_Environment; + + if Metavariable (Name) = "" then + return False; + else + return True; + end if; + end Metavariable_Exists; + + ------------ + -- Method -- + ------------ + + function Method return Method_Type is + begin + Check_Environment; + return Current_Method; + end Method; + + -------- + -- Ok -- + -------- + + function Ok return Boolean is + begin + return Valid_Environment; + end Ok; + + ---------------- + -- Put_Header -- + ---------------- + + procedure Put_Header + (Header : String := Default_Header; + Force : Boolean := False) + is + begin + if Header_Sent = False or else Force then + Check_Environment; + Text_IO.Put_Line (Header); + Text_IO.New_Line; + Header_Sent := True; + end if; + end Put_Header; + + --------- + -- URL -- + --------- + + function URL return String is + + function Exists_And_Not_80 (Server_Port : String) return String; + -- Returns ':' & Server_Port if Server_Port is not "80" and the empty + -- string otherwise (80 is the default sever port). + + ----------------------- + -- Exists_And_Not_80 -- + ----------------------- + + function Exists_And_Not_80 (Server_Port : String) return String is + begin + if Server_Port = "80" then + return ""; + else + return ':' & Server_Port; + end if; + end Exists_And_Not_80; + + -- Start of processing for URL + + begin + Check_Environment; + + return "http://" + & Metavariable (Server_Name) + & Exists_And_Not_80 (Metavariable (Server_Port)) + & Metavariable (Script_Name); + end URL; + + ----------- + -- Value -- + ----------- + + function Value + (Key : String; + Required : Boolean := False) + return String + is + begin + Check_Environment; + + for K in 1 .. Key_Value_Table.Last loop + if Key_Value_Table.Table (K).Key.all = Key then + return Key_Value_Table.Table (K).Value.all; + end if; + end loop; + + if Required then + raise Parameter_Not_Found; + else + return ""; + end if; + end Value; + + ----------- + -- Value -- + ----------- + + function Value (Position : Positive) return String is + begin + Check_Environment; + + if Position <= Key_Value_Table.Last then + return Key_Value_Table.Table (Position).Value.all; + else + raise Parameter_Not_Found; + end if; + end Value; + +begin + + Initialize; + +end GNAT.CGI; diff --git a/gcc/ada/g-cgi.ads b/gcc/ada/g-cgi.ads new file mode 100644 index 000000000..b444b586e --- /dev/null +++ b/gcc/ada/g-cgi.ads @@ -0,0 +1,257 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C G I -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is 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 new file mode 100644 index 000000000..50c9ce864 --- /dev/null +++ b/gcc/ada/g-cgicoo.adb @@ -0,0 +1,407 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C G I . C O O K I E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2000-2005, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +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 new file mode 100644 index 000000000..c8d56cbf5 --- /dev/null +++ b/gcc/ada/g-cgicoo.ads @@ -0,0 +1,122 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C G I . C O O K I E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2005, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is 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 new file mode 100644 index 000000000..863599b16 --- /dev/null +++ b/gcc/ada/g-cgideb.adb @@ -0,0 +1,316 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C G I . D E B U G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2000-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +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 new file mode 100644 index 000000000..7192ed227 --- /dev/null +++ b/gcc/ada/g-cgideb.ads @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C G I . D E B U G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2005, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a package to help debugging CGI (Common Gateway Interface) +-- programs written in Ada. + +package GNAT.CGI.Debug is + + -- Both functions below output all possible CGI parameters set. These are + -- the form field and all CGI environment variables which make the CGI + -- environment at runtime. + + function Text_Output return String; + -- Returns a plain text version of the CGI runtime environment + + function HTML_Output return String; + -- Returns an HTML version of the CGI runtime environment + +end GNAT.CGI.Debug; diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb new file mode 100644 index 000000000..e93042d96 --- /dev/null +++ b/gcc/ada/g-comlin.adb @@ -0,0 +1,3432 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C O M M A N D _ L I N E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-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.Characters.Handling; use Ada.Characters.Handling; +with Ada.Strings.Unbounded; +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Unchecked_Deallocation; + +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.OS_Lib; use GNAT.OS_Lib; + +package body GNAT.Command_Line is + + package CL renames Ada.Command_Line; + + type Switch_Parameter_Type is + (Parameter_None, + Parameter_With_Optional_Space, -- ':' in getopt + Parameter_With_Space_Or_Equal, -- '=' in getopt + Parameter_No_Space, -- '!' in getopt + Parameter_Optional); -- '?' in getopt + + procedure Set_Parameter + (Variable : out Parameter_Type; + Arg_Num : Positive; + First : Positive; + Last : Positive; + Extra : Character := ASCII.NUL); + pragma Inline (Set_Parameter); + -- Set the parameter that will be returned by Parameter below + -- Parameters need to be defined ??? + + function Goto_Next_Argument_In_Section (Parser : Opt_Parser) return Boolean; + -- Go to the next argument on the command line. If we are at the end of + -- the current section, we want to make sure there is no other identical + -- section on the command line (there might be multiple instances of + -- -largs). Returns True iff there is another argument. + + function Get_File_Names_Case_Sensitive return Integer; + pragma Import (C, Get_File_Names_Case_Sensitive, + "__gnat_get_file_names_case_sensitive"); + + File_Names_Case_Sensitive : constant Boolean := + Get_File_Names_Case_Sensitive /= 0; + + procedure Canonical_Case_File_Name (S : in out String); + -- Given a file name, converts it to canonical case form. For systems where + -- file names are case sensitive, this procedure has no effect. If file + -- names are not case sensitive (i.e. for example if you have the file + -- "xyz.adb", you can refer to it as XYZ.adb or XyZ.AdB), then this call + -- converts the given string to canonical all lower case form, so that two + -- file names compare equal if they refer to the same file. + + procedure Internal_Initialize_Option_Scan + (Parser : Opt_Parser; + Switch_Char : Character; + Stop_At_First_Non_Switch : Boolean; + Section_Delimiters : String); + -- Initialize Parser, which must have been allocated already + + function Argument (Parser : Opt_Parser; Index : Integer) return String; + -- Return the index-th command line argument + + procedure Find_Longest_Matching_Switch + (Switches : String; + Arg : String; + Index_In_Switches : out Integer; + Switch_Length : out Integer; + Param : out Switch_Parameter_Type); + -- Return the Longest switch from Switches that at least partially + -- partially Arg. Index_In_Switches is set to 0 if none matches. + -- What are other parameters??? in particular Param is not always set??? + + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Argument_List, Argument_List_Access); + + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Command_Line_Configuration_Record, Command_Line_Configuration); + + procedure Remove (Line : in out Argument_List_Access; Index : Integer); + -- Remove a specific element from Line + + procedure Add + (Line : in out Argument_List_Access; + Str : String_Access; + Before : Boolean := False); + -- Add a new element to Line. If Before is True, the item is inserted at + -- the beginning, else it is appended. + + procedure Add + (Config : in out Command_Line_Configuration; + Switch : Switch_Definition); + procedure Add + (Def : in out Alias_Definitions_List; + Alias : Alias_Definition); + -- Add a new element to Def. + + procedure Initialize_Switch_Def + (Def : out Switch_Definition; + Switch : String := ""; + Long_Switch : String := ""; + Help : String := ""; + Section : String := ""); + -- Initialize [Def] with the contents of the other parameters. + -- This also checks consistency of the switch parameters, and will raise + -- Invalid_Switch if they do not match. + + procedure Decompose_Switch + (Switch : String; + Parameter_Type : out Switch_Parameter_Type; + Switch_Last : out Integer); + -- Given a switch definition ("name:" for instance), extracts the type of + -- parameter that is expected, and the name of the switch + + function Can_Have_Parameter (S : String) return Boolean; + -- True if S can have a parameter + + function Require_Parameter (S : String) return Boolean; + -- True if S requires a parameter + + function Actual_Switch (S : String) return String; + -- Remove any possible trailing '!', ':', '?' and '=' + + generic + with procedure Callback + (Simple_Switch : String; + Separator : String; + Parameter : String; + Index : Integer); -- Index in Config.Switches, or -1 + procedure For_Each_Simple_Switch + (Config : Command_Line_Configuration; + Section : String; + Switch : String; + Parameter : String := ""; + Unalias : Boolean := True); + -- Breaks Switch into as simple switches as possible (expanding aliases and + -- ungrouping common prefixes when possible), and call Callback for each of + -- these. + + procedure Sort_Sections + (Line : GNAT.OS_Lib.Argument_List_Access; + Sections : GNAT.OS_Lib.Argument_List_Access; + Params : GNAT.OS_Lib.Argument_List_Access); + -- Reorder the command line switches so that the switches belonging to a + -- section are grouped together. + + procedure Group_Switches + (Cmd : Command_Line; + Result : Argument_List_Access; + Sections : Argument_List_Access; + Params : Argument_List_Access); + -- Group switches with common prefixes whenever possible. Once they have + -- been grouped, we also check items for possible aliasing. + + procedure Alias_Switches + (Cmd : Command_Line; + Result : Argument_List_Access; + Params : Argument_List_Access); + -- When possible, replace one or more switches by an alias, i.e. a shorter + -- version. + + function Looking_At + (Type_Str : String; + Index : Natural; + Substring : String) return Boolean; + -- Return True if the characters starting at Index in Type_Str are + -- equivalent to Substring. + + generic + with function Callback (S : String; Index : Integer) return Boolean; + procedure Foreach_Switch + (Config : Command_Line_Configuration; + Section : String); + -- Iterate over all switches defined in Config, for a specific section. + -- Index is set to the index in Config.Switches + + -------------- + -- Argument -- + -------------- + + function Argument (Parser : Opt_Parser; Index : Integer) return String is + begin + if Parser.Arguments /= null then + return Parser.Arguments (Index + Parser.Arguments'First - 1).all; + else + return CL.Argument (Index); + end if; + end Argument; + + ------------------------------ + -- Canonical_Case_File_Name -- + ------------------------------ + + procedure Canonical_Case_File_Name (S : in out String) is + begin + if not File_Names_Case_Sensitive then + for J in S'Range loop + if S (J) in 'A' .. 'Z' then + S (J) := Character'Val + (Character'Pos (S (J)) + + Character'Pos ('a') - + Character'Pos ('A')); + end if; + end loop; + end if; + end Canonical_Case_File_Name; + + --------------- + -- Expansion -- + --------------- + + function Expansion (Iterator : Expansion_Iterator) return String is + type Pointer is access all Expansion_Iterator; + + It : constant Pointer := Iterator'Unrestricted_Access; + S : String (1 .. 1024); + Last : Natural; + + Current : Depth := It.Current_Depth; + NL : Positive; + + begin + -- It is assumed that a directory is opened at the current level. + -- Otherwise GNAT.Directory_Operations.Directory_Error will be raised + -- at the first call to Read. + + loop + Read (It.Levels (Current).Dir, S, Last); + + -- If we have exhausted the directory, close it and go back one level + + if Last = 0 then + Close (It.Levels (Current).Dir); + + -- If we are at level 1, we are finished; return an empty string + + if Current = 1 then + return String'(1 .. 0 => ' '); + + -- Otherwise continue with the directory at the previous level + + else + Current := Current - 1; + It.Current_Depth := Current; + end if; + + -- If this is a directory, that is neither "." or "..", attempt to + -- go to the next level. + + elsif Is_Directory + (It.Dir_Name (1 .. It.Levels (Current).Name_Last) & S (1 .. Last)) + and then S (1 .. Last) /= "." + and then S (1 .. Last) /= ".." + then + -- We can go to the next level only if we have not reached the + -- maximum depth, + + if Current < It.Maximum_Depth then + NL := It.Levels (Current).Name_Last; + + -- And if relative path of this new directory is not too long + + if NL + Last + 1 < Max_Path_Length then + Current := Current + 1; + It.Current_Depth := Current; + It.Dir_Name (NL + 1 .. NL + Last) := S (1 .. Last); + NL := NL + Last + 1; + It.Dir_Name (NL) := Directory_Separator; + It.Levels (Current).Name_Last := NL; + Canonical_Case_File_Name (It.Dir_Name (1 .. NL)); + + -- Open the new directory, and read from it + + GNAT.Directory_Operations.Open + (It.Levels (Current).Dir, It.Dir_Name (1 .. NL)); + end if; + end if; + end if; + + -- Check the relative path against the pattern + + -- Note that we try to match also against directory names, since + -- clients of this function may expect to retrieve directories. + + declare + Name : String := + It.Dir_Name (It.Start .. It.Levels (Current).Name_Last) + & S (1 .. Last); + + begin + Canonical_Case_File_Name (Name); + + -- If it matches return the relative path + + if GNAT.Regexp.Match (Name, Iterator.Regexp) then + return Name; + end if; + end; + end loop; + end Expansion; + + --------------------- + -- Current_Section -- + --------------------- + + function Current_Section + (Parser : Opt_Parser := Command_Line_Parser) return String + is + begin + if Parser.Current_Section = 1 then + return ""; + end if; + + for Index in reverse 1 .. Integer'Min (Parser.Current_Argument - 1, + Parser.Section'Last) + loop + if Parser.Section (Index) = 0 then + return Argument (Parser, Index); + end if; + end loop; + + return ""; + end Current_Section; + + ----------------- + -- Full_Switch -- + ----------------- + + function Full_Switch + (Parser : Opt_Parser := Command_Line_Parser) return String + is + begin + if Parser.The_Switch.Extra = ASCII.NUL then + return Argument (Parser, Parser.The_Switch.Arg_Num) + (Parser.The_Switch.First .. Parser.The_Switch.Last); + else + return Parser.The_Switch.Extra + & Argument (Parser, Parser.The_Switch.Arg_Num) + (Parser.The_Switch.First .. Parser.The_Switch.Last); + end if; + end Full_Switch; + + ------------------ + -- Get_Argument -- + ------------------ + + function Get_Argument + (Do_Expansion : Boolean := False; + Parser : Opt_Parser := Command_Line_Parser) return String + is + begin + if Parser.In_Expansion then + declare + S : constant String := Expansion (Parser.Expansion_It); + begin + if S'Length /= 0 then + return S; + else + Parser.In_Expansion := False; + end if; + end; + end if; + + if Parser.Current_Argument > Parser.Arg_Count then + + -- If this is the first time this function is called + + if Parser.Current_Index = 1 then + Parser.Current_Argument := 1; + while Parser.Current_Argument <= Parser.Arg_Count + and then Parser.Section (Parser.Current_Argument) /= + Parser.Current_Section + loop + Parser.Current_Argument := Parser.Current_Argument + 1; + end loop; + else + return String'(1 .. 0 => ' '); + end if; + + elsif Parser.Section (Parser.Current_Argument) = 0 then + while Parser.Current_Argument <= Parser.Arg_Count + and then Parser.Section (Parser.Current_Argument) /= + Parser.Current_Section + loop + Parser.Current_Argument := Parser.Current_Argument + 1; + end loop; + end if; + + Parser.Current_Index := Integer'Last; + + while Parser.Current_Argument <= Parser.Arg_Count + and then Parser.Is_Switch (Parser.Current_Argument) + loop + Parser.Current_Argument := Parser.Current_Argument + 1; + end loop; + + if Parser.Current_Argument > Parser.Arg_Count then + return String'(1 .. 0 => ' '); + elsif Parser.Section (Parser.Current_Argument) = 0 then + return Get_Argument (Do_Expansion); + end if; + + Parser.Current_Argument := Parser.Current_Argument + 1; + + -- Could it be a file name with wild cards to expand? + + if Do_Expansion then + declare + Arg : constant String := + Argument (Parser, Parser.Current_Argument - 1); + Index : Positive; + + begin + Index := Arg'First; + while Index <= Arg'Last loop + if Arg (Index) = '*' + or else Arg (Index) = '?' + or else Arg (Index) = '[' + then + Parser.In_Expansion := True; + Start_Expansion (Parser.Expansion_It, Arg); + return Get_Argument (Do_Expansion); + end if; + + Index := Index + 1; + end loop; + end; + end if; + + return Argument (Parser, Parser.Current_Argument - 1); + end Get_Argument; + + ---------------------- + -- Decompose_Switch -- + ---------------------- + + procedure Decompose_Switch + (Switch : String; + Parameter_Type : out Switch_Parameter_Type; + Switch_Last : out Integer) + is + begin + if Switch = "" then + Parameter_Type := Parameter_None; + Switch_Last := Switch'Last; + return; + end if; + + case Switch (Switch'Last) is + when ':' => + Parameter_Type := Parameter_With_Optional_Space; + Switch_Last := Switch'Last - 1; + when '=' => + Parameter_Type := Parameter_With_Space_Or_Equal; + Switch_Last := Switch'Last - 1; + when '!' => + Parameter_Type := Parameter_No_Space; + Switch_Last := Switch'Last - 1; + when '?' => + Parameter_Type := Parameter_Optional; + Switch_Last := Switch'Last - 1; + when others => + Parameter_Type := Parameter_None; + Switch_Last := Switch'Last; + end case; + end Decompose_Switch; + + ---------------------------------- + -- Find_Longest_Matching_Switch -- + ---------------------------------- + + procedure Find_Longest_Matching_Switch + (Switches : String; + Arg : String; + Index_In_Switches : out Integer; + Switch_Length : out Integer; + Param : out Switch_Parameter_Type) + is + Index : Natural; + Length : Natural := 1; + Last : Natural; + P : Switch_Parameter_Type; + + begin + Index_In_Switches := 0; + Switch_Length := 0; + + -- Remove all leading spaces first to make sure that Index points + -- at the start of the first switch. + + Index := Switches'First; + while Index <= Switches'Last and then Switches (Index) = ' ' loop + Index := Index + 1; + end loop; + + while Index <= Switches'Last loop + + -- Search the length of the parameter at this position in Switches + + Length := Index; + while Length <= Switches'Last + and then Switches (Length) /= ' ' + loop + Length := Length + 1; + end loop; + + -- Length now marks the separator after the current switch + -- Last will mark the last character of the name of the switch + + if Length = Index + 1 then + P := Parameter_None; + Last := Index; + else + Decompose_Switch (Switches (Index .. Length - 1), P, Last); + end if; + + -- If it is the one we searched, it may be a candidate + + if Arg'First + Last - Index <= Arg'Last + and then Switches (Index .. Last) = + Arg (Arg'First .. Arg'First + Last - Index) + and then Last - Index + 1 > Switch_Length + then + Param := P; + Index_In_Switches := Index; + Switch_Length := Last - Index + 1; + end if; + + -- Look for the next switch in Switches + + while Index <= Switches'Last + and then Switches (Index) /= ' ' + loop + Index := Index + 1; + end loop; + + Index := Index + 1; + end loop; + end Find_Longest_Matching_Switch; + + ------------ + -- Getopt -- + ------------ + + function Getopt + (Switches : String; + Concatenate : Boolean := True; + Parser : Opt_Parser := Command_Line_Parser) return Character + is + Dummy : Boolean; + pragma Unreferenced (Dummy); + + begin + <> + + -- If we have finished parsing the current command line item (there + -- might be multiple switches in a single item), then go to the next + -- element + + if Parser.Current_Argument > Parser.Arg_Count + or else (Parser.Current_Index > + Argument (Parser, Parser.Current_Argument)'Last + and then not Goto_Next_Argument_In_Section (Parser)) + then + return ASCII.NUL; + end if; + + -- By default, the switch will not have a parameter + + Parser.The_Parameter := + (Integer'Last, Integer'Last, Integer'Last - 1, ASCII.NUL); + Parser.The_Separator := ASCII.NUL; + + declare + Arg : constant String := + Argument (Parser, Parser.Current_Argument); + Index_Switches : Natural := 0; + Max_Length : Natural := 0; + End_Index : Natural; + Param : Switch_Parameter_Type; + begin + -- If we are on a new item, test if this might be a switch + + if Parser.Current_Index = Arg'First then + if Arg (Arg'First) /= Parser.Switch_Character then + + -- If it isn't a switch, return it immediately. We also know it + -- isn't the parameter to a previous switch, since that has + -- already been handled + + if Switches (Switches'First) = '*' then + Set_Parameter + (Parser.The_Switch, + Arg_Num => Parser.Current_Argument, + First => Arg'First, + Last => Arg'Last); + Parser.Is_Switch (Parser.Current_Argument) := True; + Dummy := Goto_Next_Argument_In_Section (Parser); + return '*'; + end if; + + if Parser.Stop_At_First then + Parser.Current_Argument := Positive'Last; + return ASCII.NUL; + + elsif not Goto_Next_Argument_In_Section (Parser) then + return ASCII.NUL; + + else + -- Recurse to get the next switch on the command line + + goto Restart; + end if; + end if; + + -- We are on the first character of a new command line argument, + -- which starts with Switch_Character. Further analysis is needed. + + Parser.Current_Index := Parser.Current_Index + 1; + Parser.Is_Switch (Parser.Current_Argument) := True; + end if; + + Find_Longest_Matching_Switch + (Switches => Switches, + Arg => Arg (Parser.Current_Index .. Arg'Last), + Index_In_Switches => Index_Switches, + Switch_Length => Max_Length, + Param => Param); + + -- If switch is not accepted, it is either invalid or is returned + -- in the context of '*'. + + if Index_Switches = 0 then + + -- Depending on the value of Concatenate, the full switch is + -- a single character or the rest of the argument. + + End_Index := + (if Concatenate then Parser.Current_Index else Arg'Last); + + if Switches (Switches'First) = '*' then + + -- Always prepend the switch character, so that users know that + -- this comes from a switch on the command line. This is + -- especially important when Concatenate is False, since + -- otherwise the current argument first character is lost. + + Set_Parameter + (Parser.The_Switch, + Arg_Num => Parser.Current_Argument, + First => Parser.Current_Index, + Last => Arg'Last, + Extra => Parser.Switch_Character); + Parser.Is_Switch (Parser.Current_Argument) := True; + Dummy := Goto_Next_Argument_In_Section (Parser); + return '*'; + end if; + + Set_Parameter + (Parser.The_Switch, + Arg_Num => Parser.Current_Argument, + First => Parser.Current_Index, + Last => End_Index); + Parser.Current_Index := End_Index + 1; + + raise Invalid_Switch; + end if; + + End_Index := Parser.Current_Index + Max_Length - 1; + Set_Parameter + (Parser.The_Switch, + Arg_Num => Parser.Current_Argument, + First => Parser.Current_Index, + Last => End_Index); + + case Param is + when Parameter_With_Optional_Space => + if End_Index < Arg'Last then + Set_Parameter + (Parser.The_Parameter, + Arg_Num => Parser.Current_Argument, + First => End_Index + 1, + Last => Arg'Last); + Dummy := Goto_Next_Argument_In_Section (Parser); + + elsif Parser.Current_Argument < Parser.Arg_Count + and then Parser.Section (Parser.Current_Argument + 1) /= 0 + then + Parser.Current_Argument := Parser.Current_Argument + 1; + Parser.The_Separator := ' '; + Set_Parameter + (Parser.The_Parameter, + Arg_Num => Parser.Current_Argument, + First => Argument (Parser, Parser.Current_Argument)'First, + Last => Argument (Parser, Parser.Current_Argument)'Last); + Parser.Is_Switch (Parser.Current_Argument) := True; + Dummy := Goto_Next_Argument_In_Section (Parser); + + else + Parser.Current_Index := End_Index + 1; + raise Invalid_Parameter; + end if; + + when Parameter_With_Space_Or_Equal => + + -- If the switch is of the form =xxx + + if End_Index < Arg'Last then + if Arg (End_Index + 1) = '=' + and then End_Index + 1 < Arg'Last + then + Parser.The_Separator := '='; + Set_Parameter + (Parser.The_Parameter, + Arg_Num => Parser.Current_Argument, + First => End_Index + 2, + Last => Arg'Last); + Dummy := Goto_Next_Argument_In_Section (Parser); + else + Parser.Current_Index := End_Index + 1; + raise Invalid_Parameter; + end if; + + -- If the switch is of the form xxx + + elsif Parser.Current_Argument < Parser.Arg_Count + and then Parser.Section (Parser.Current_Argument + 1) /= 0 + then + Parser.Current_Argument := Parser.Current_Argument + 1; + Parser.The_Separator := ' '; + Set_Parameter + (Parser.The_Parameter, + Arg_Num => Parser.Current_Argument, + First => Argument (Parser, Parser.Current_Argument)'First, + Last => Argument (Parser, Parser.Current_Argument)'Last); + Parser.Is_Switch (Parser.Current_Argument) := True; + Dummy := Goto_Next_Argument_In_Section (Parser); + + else + Parser.Current_Index := End_Index + 1; + raise Invalid_Parameter; + end if; + + when Parameter_No_Space => + if End_Index < Arg'Last then + Set_Parameter + (Parser.The_Parameter, + Arg_Num => Parser.Current_Argument, + First => End_Index + 1, + Last => Arg'Last); + Dummy := Goto_Next_Argument_In_Section (Parser); + + else + Parser.Current_Index := End_Index + 1; + raise Invalid_Parameter; + end if; + + when Parameter_Optional => + if End_Index < Arg'Last then + Set_Parameter + (Parser.The_Parameter, + Arg_Num => Parser.Current_Argument, + First => End_Index + 1, + Last => Arg'Last); + end if; + + Dummy := Goto_Next_Argument_In_Section (Parser); + + when Parameter_None => + if Concatenate or else End_Index = Arg'Last then + Parser.Current_Index := End_Index + 1; + + else + -- If Concatenate is False and the full argument is not + -- recognized as a switch, this is an invalid switch. + + if Switches (Switches'First) = '*' then + Set_Parameter + (Parser.The_Switch, + Arg_Num => Parser.Current_Argument, + First => Arg'First, + Last => Arg'Last); + Parser.Is_Switch (Parser.Current_Argument) := True; + Dummy := Goto_Next_Argument_In_Section (Parser); + return '*'; + end if; + + Set_Parameter + (Parser.The_Switch, + Arg_Num => Parser.Current_Argument, + First => Parser.Current_Index, + Last => Arg'Last); + Parser.Current_Index := Arg'Last + 1; + raise Invalid_Switch; + end if; + end case; + + return Switches (Index_Switches); + end; + end Getopt; + + ----------------------------------- + -- Goto_Next_Argument_In_Section -- + ----------------------------------- + + function Goto_Next_Argument_In_Section + (Parser : Opt_Parser) return Boolean + is + begin + Parser.Current_Argument := Parser.Current_Argument + 1; + + if Parser.Current_Argument > Parser.Arg_Count + or else Parser.Section (Parser.Current_Argument) = 0 + then + loop + Parser.Current_Argument := Parser.Current_Argument + 1; + + if Parser.Current_Argument > Parser.Arg_Count then + Parser.Current_Index := 1; + return False; + end if; + + exit when Parser.Section (Parser.Current_Argument) = + Parser.Current_Section; + end loop; + end if; + + Parser.Current_Index := + Argument (Parser, Parser.Current_Argument)'First; + + return True; + end Goto_Next_Argument_In_Section; + + ------------------ + -- Goto_Section -- + ------------------ + + procedure Goto_Section + (Name : String := ""; + Parser : Opt_Parser := Command_Line_Parser) + is + Index : Integer; + + begin + Parser.In_Expansion := False; + + if Name = "" then + Parser.Current_Argument := 1; + Parser.Current_Index := 1; + Parser.Current_Section := 1; + return; + end if; + + Index := 1; + while Index <= Parser.Arg_Count loop + if Parser.Section (Index) = 0 + and then Argument (Parser, Index) = Parser.Switch_Character & Name + then + Parser.Current_Argument := Index + 1; + Parser.Current_Index := 1; + + if Parser.Current_Argument <= Parser.Arg_Count then + Parser.Current_Section := + Parser.Section (Parser.Current_Argument); + end if; + return; + end if; + + Index := Index + 1; + end loop; + + Parser.Current_Argument := Positive'Last; + Parser.Current_Index := 2; -- so that Get_Argument returns nothing + end Goto_Section; + + ---------------------------- + -- Initialize_Option_Scan -- + ---------------------------- + + procedure Initialize_Option_Scan + (Switch_Char : Character := '-'; + Stop_At_First_Non_Switch : Boolean := False; + Section_Delimiters : String := "") + is + begin + Internal_Initialize_Option_Scan + (Parser => Command_Line_Parser, + Switch_Char => Switch_Char, + Stop_At_First_Non_Switch => Stop_At_First_Non_Switch, + Section_Delimiters => Section_Delimiters); + end Initialize_Option_Scan; + + ---------------------------- + -- Initialize_Option_Scan -- + ---------------------------- + + procedure Initialize_Option_Scan + (Parser : out Opt_Parser; + Command_Line : GNAT.OS_Lib.Argument_List_Access; + Switch_Char : Character := '-'; + Stop_At_First_Non_Switch : Boolean := False; + Section_Delimiters : String := "") + is + begin + Free (Parser); + + if Command_Line = null then + Parser := new Opt_Parser_Data (CL.Argument_Count); + Internal_Initialize_Option_Scan + (Parser => Parser, + Switch_Char => Switch_Char, + Stop_At_First_Non_Switch => Stop_At_First_Non_Switch, + Section_Delimiters => Section_Delimiters); + else + Parser := new Opt_Parser_Data (Command_Line'Length); + Parser.Arguments := Command_Line; + Internal_Initialize_Option_Scan + (Parser => Parser, + Switch_Char => Switch_Char, + Stop_At_First_Non_Switch => Stop_At_First_Non_Switch, + Section_Delimiters => Section_Delimiters); + end if; + end Initialize_Option_Scan; + + ------------------------------------- + -- Internal_Initialize_Option_Scan -- + ------------------------------------- + + procedure Internal_Initialize_Option_Scan + (Parser : Opt_Parser; + Switch_Char : Character; + Stop_At_First_Non_Switch : Boolean; + Section_Delimiters : String) + is + Section_Num : Section_Number; + Section_Index : Integer; + Last : Integer; + Delimiter_Found : Boolean; + + Discard : Boolean; + pragma Warnings (Off, Discard); + + begin + Parser.Current_Argument := 0; + Parser.Current_Index := 0; + Parser.In_Expansion := False; + Parser.Switch_Character := Switch_Char; + Parser.Stop_At_First := Stop_At_First_Non_Switch; + Parser.Section := (others => 1); + + -- If we are using sections, we have to preprocess the command line + -- to delimit them. A section can be repeated, so we just give each + -- item on the command line a section number + + Section_Num := 1; + Section_Index := Section_Delimiters'First; + while Section_Index <= Section_Delimiters'Last loop + Last := Section_Index; + while Last <= Section_Delimiters'Last + and then Section_Delimiters (Last) /= ' ' + loop + Last := Last + 1; + end loop; + + Delimiter_Found := False; + Section_Num := Section_Num + 1; + + for Index in 1 .. Parser.Arg_Count loop + if Argument (Parser, Index)(1) = Parser.Switch_Character + and then + Argument (Parser, Index) = Parser.Switch_Character & + Section_Delimiters + (Section_Index .. Last - 1) + then + Parser.Section (Index) := 0; + Delimiter_Found := True; + + elsif Parser.Section (Index) = 0 then + Delimiter_Found := False; + + elsif Delimiter_Found then + Parser.Section (Index) := Section_Num; + end if; + end loop; + + Section_Index := Last + 1; + while Section_Index <= Section_Delimiters'Last + and then Section_Delimiters (Section_Index) = ' ' + loop + Section_Index := Section_Index + 1; + end loop; + end loop; + + Discard := Goto_Next_Argument_In_Section (Parser); + end Internal_Initialize_Option_Scan; + + --------------- + -- Parameter -- + --------------- + + function Parameter + (Parser : Opt_Parser := Command_Line_Parser) return String + is + begin + if Parser.The_Parameter.First > Parser.The_Parameter.Last then + return String'(1 .. 0 => ' '); + else + return Argument (Parser, Parser.The_Parameter.Arg_Num) + (Parser.The_Parameter.First .. Parser.The_Parameter.Last); + end if; + end Parameter; + + --------------- + -- Separator -- + --------------- + + function Separator + (Parser : Opt_Parser := Command_Line_Parser) return Character + is + begin + return Parser.The_Separator; + end Separator; + + ------------------- + -- Set_Parameter -- + ------------------- + + procedure Set_Parameter + (Variable : out Parameter_Type; + Arg_Num : Positive; + First : Positive; + Last : Positive; + Extra : Character := ASCII.NUL) + is + begin + Variable.Arg_Num := Arg_Num; + Variable.First := First; + Variable.Last := Last; + Variable.Extra := Extra; + end Set_Parameter; + + --------------------- + -- Start_Expansion -- + --------------------- + + procedure Start_Expansion + (Iterator : out Expansion_Iterator; + Pattern : String; + Directory : String := ""; + Basic_Regexp : Boolean := True) + is + Directory_Separator : Character; + pragma Import (C, Directory_Separator, "__gnat_dir_separator"); + + First : Positive := Pattern'First; + Pat : String := Pattern; + + begin + Canonical_Case_File_Name (Pat); + Iterator.Current_Depth := 1; + + -- If Directory is unspecified, use the current directory ("./" or ".\") + + if Directory = "" then + Iterator.Dir_Name (1 .. 2) := "." & Directory_Separator; + Iterator.Start := 3; + + else + Iterator.Dir_Name (1 .. Directory'Length) := Directory; + Iterator.Start := Directory'Length + 1; + Canonical_Case_File_Name (Iterator.Dir_Name (1 .. Directory'Length)); + + -- Make sure that the last character is a directory separator + + if Directory (Directory'Last) /= Directory_Separator then + Iterator.Dir_Name (Iterator.Start) := Directory_Separator; + Iterator.Start := Iterator.Start + 1; + end if; + end if; + + Iterator.Levels (1).Name_Last := Iterator.Start - 1; + + -- Open the initial Directory, at depth 1 + + GNAT.Directory_Operations.Open + (Iterator.Levels (1).Dir, Iterator.Dir_Name (1 .. Iterator.Start - 1)); + + -- If in the current directory and the pattern starts with "./" or ".\", + -- drop the "./" or ".\" from the pattern. + + if Directory = "" and then Pat'Length > 2 + and then Pat (Pat'First) = '.' + and then Pat (Pat'First + 1) = Directory_Separator + then + First := Pat'First + 2; + end if; + + Iterator.Regexp := + GNAT.Regexp.Compile (Pat (First .. Pat'Last), Basic_Regexp, True); + + Iterator.Maximum_Depth := 1; + + -- Maximum_Depth is equal to 1 plus the number of directory separators + -- in the pattern. + + for Index in First .. Pat'Last loop + if Pat (Index) = Directory_Separator then + Iterator.Maximum_Depth := Iterator.Maximum_Depth + 1; + exit when Iterator.Maximum_Depth = Max_Depth; + end if; + end loop; + end Start_Expansion; + + ---------- + -- Free -- + ---------- + + procedure Free (Parser : in out Opt_Parser) is + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Opt_Parser_Data, Opt_Parser); + begin + if Parser /= null + and then Parser /= Command_Line_Parser + then + Free (Parser.Arguments); + Unchecked_Free (Parser); + end if; + end Free; + + ------------------ + -- Define_Alias -- + ------------------ + + procedure Define_Alias + (Config : in out Command_Line_Configuration; + Switch : String; + Expanded : String; + Section : String := "") + is + Def : Alias_Definition; + begin + if Config = null then + Config := new Command_Line_Configuration_Record; + end if; + + Def.Alias := new String'(Switch); + Def.Expansion := new String'(Expanded); + Def.Section := new String'(Section); + Add (Config.Aliases, Def); + end Define_Alias; + + ------------------- + -- Define_Prefix -- + ------------------- + + procedure Define_Prefix + (Config : in out Command_Line_Configuration; + Prefix : String) + is + begin + if Config = null then + Config := new Command_Line_Configuration_Record; + end if; + + Add (Config.Prefixes, new String'(Prefix)); + end Define_Prefix; + + --------- + -- Add -- + --------- + + procedure Add (Config : in out Command_Line_Configuration; + Switch : Switch_Definition) + is + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Switch_Definitions, Switch_Definitions_List); + Tmp : Switch_Definitions_List; + + begin + if Config = null then + Config := new Command_Line_Configuration_Record; + end if; + + Tmp := Config.Switches; + + if Tmp = null then + Config.Switches := new Switch_Definitions (1 .. 1); + else + Config.Switches := new Switch_Definitions (1 .. Tmp'Length + 1); + Config.Switches (1 .. Tmp'Length) := Tmp.all; + Unchecked_Free (Tmp); + end if; + + Config.Switches (Config.Switches'Last) := Switch; + end Add; + + --------- + -- Add -- + --------- + + procedure Add (Def : in out Alias_Definitions_List; + Alias : Alias_Definition) + is + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Alias_Definitions, Alias_Definitions_List); + Tmp : Alias_Definitions_List := Def; + + begin + if Tmp = null then + Def := new Alias_Definitions (1 .. 1); + else + Def := new Alias_Definitions (1 .. Tmp'Length + 1); + Def (1 .. Tmp'Length) := Tmp.all; + Unchecked_Free (Tmp); + end if; + + Def (Def'Last) := Alias; + end Add; + + --------------------------- + -- Initialize_Switch_Def -- + --------------------------- + + procedure Initialize_Switch_Def + (Def : out Switch_Definition; + Switch : String := ""; + Long_Switch : String := ""; + Help : String := ""; + Section : String := "") + is + P1, P2 : Switch_Parameter_Type := Parameter_None; + Last1, Last2 : Integer; + + begin + if Switch /= "" then + Def.Switch := new String'(Switch); + Decompose_Switch (Switch, P1, Last1); + end if; + + if Long_Switch /= "" then + Def.Long_Switch := new String'(Long_Switch); + Decompose_Switch (Long_Switch, P2, Last2); + end if; + + if Switch /= "" and then Long_Switch /= "" then + if (P1 = Parameter_None and then P2 /= P1) + or else (P2 = Parameter_None and then P1 /= P2) + or else (P1 = Parameter_Optional and then P2 /= P1) + or else (P2 = Parameter_Optional and then P2 /= P1) + then + raise Invalid_Switch + with "Inconsistent parameter types for " + & Switch & " and " & Long_Switch; + end if; + end if; + + if Section /= "" then + Def.Section := new String'(Section); + end if; + + if Help /= "" then + Def.Help := new String'(Help); + end if; + end Initialize_Switch_Def; + + ------------------- + -- Define_Switch -- + ------------------- + + procedure Define_Switch + (Config : in out Command_Line_Configuration; + Switch : String := ""; + Long_Switch : String := ""; + Help : String := ""; + Section : String := "") + is + Def : Switch_Definition; + begin + if Switch /= "" or else Long_Switch /= "" then + Initialize_Switch_Def (Def, Switch, Long_Switch, Help, Section); + Add (Config, Def); + end if; + end Define_Switch; + + ------------------- + -- Define_Switch -- + ------------------- + + procedure Define_Switch + (Config : in out Command_Line_Configuration; + Output : access Boolean; + Switch : String := ""; + Long_Switch : String := ""; + Help : String := ""; + Section : String := ""; + Value : Boolean := True) + is + Def : Switch_Definition (Switch_Boolean); + begin + if Switch /= "" or else Long_Switch /= "" then + Initialize_Switch_Def (Def, Switch, Long_Switch, Help, Section); + Def.Boolean_Output := Output.all'Unchecked_Access; + Def.Boolean_Value := Value; + Add (Config, Def); + end if; + end Define_Switch; + + ------------------- + -- Define_Switch -- + ------------------- + + procedure Define_Switch + (Config : in out Command_Line_Configuration; + Output : access Integer; + Switch : String := ""; + Long_Switch : String := ""; + Help : String := ""; + Section : String := ""; + Initial : Integer := 0; + Default : Integer := 1) + is + Def : Switch_Definition (Switch_Integer); + begin + if Switch /= "" or else Long_Switch /= "" then + Initialize_Switch_Def (Def, Switch, Long_Switch, Help, Section); + Def.Integer_Output := Output.all'Unchecked_Access; + Def.Integer_Default := Default; + Def.Integer_Initial := Initial; + Add (Config, Def); + end if; + end Define_Switch; + + ------------------- + -- Define_Switch -- + ------------------- + + procedure Define_Switch + (Config : in out Command_Line_Configuration; + Output : access GNAT.Strings.String_Access; + Switch : String := ""; + Long_Switch : String := ""; + Help : String := ""; + Section : String := "") + is + Def : Switch_Definition (Switch_String); + begin + if Switch /= "" or else Long_Switch /= "" then + Initialize_Switch_Def (Def, Switch, Long_Switch, Help, Section); + Def.String_Output := Output.all'Unchecked_Access; + Add (Config, Def); + end if; + end Define_Switch; + + -------------------- + -- Define_Section -- + -------------------- + + procedure Define_Section + (Config : in out Command_Line_Configuration; + Section : String) + is + begin + if Config = null then + Config := new Command_Line_Configuration_Record; + end if; + + Add (Config.Sections, new String'(Section)); + end Define_Section; + + -------------------- + -- Foreach_Switch -- + -------------------- + + procedure Foreach_Switch + (Config : Command_Line_Configuration; + Section : String) + is + begin + if Config /= null and then Config.Switches /= null then + for J in Config.Switches'Range loop + if (Section = "" and then Config.Switches (J).Section = null) + or else + (Config.Switches (J).Section /= null + and then Config.Switches (J).Section.all = Section) + then + exit when Config.Switches (J).Switch /= null + and then not Callback (Config.Switches (J).Switch.all, J); + + exit when Config.Switches (J).Long_Switch /= null + and then + not Callback (Config.Switches (J).Long_Switch.all, J); + end if; + end loop; + end if; + end Foreach_Switch; + + ------------------ + -- Get_Switches -- + ------------------ + + function Get_Switches + (Config : Command_Line_Configuration; + Switch_Char : Character := '-'; + Section : String := "") return String + is + Ret : Ada.Strings.Unbounded.Unbounded_String; + use Ada.Strings.Unbounded; + + function Add_Switch (S : String; Index : Integer) return Boolean; + -- Add a switch to Ret + + ---------------- + -- Add_Switch -- + ---------------- + + function Add_Switch (S : String; Index : Integer) return Boolean is + pragma Unreferenced (Index); + begin + if S = "*" then + Ret := "*" & Ret; -- Always first + elsif S (S'First) = Switch_Char then + Append (Ret, " " & S (S'First + 1 .. S'Last)); + else + Append (Ret, " " & S); + end if; + return True; + end Add_Switch; + + Tmp : Boolean; + pragma Unreferenced (Tmp); + + procedure Foreach is new Foreach_Switch (Add_Switch); + + -- Start of processing for Get_Switches + + begin + if Config = null then + return ""; + end if; + + Foreach (Config, Section => Section); + + -- Adding relevant aliases + + if Config.Aliases /= null then + for A in Config.Aliases'Range loop + if Config.Aliases (A).Section.all = Section then + Tmp := Add_Switch (Config.Aliases (A).Alias.all, -1); + end if; + end loop; + end if; + + return To_String (Ret); + end Get_Switches; + + ------------------------ + -- Section_Delimiters -- + ------------------------ + + function Section_Delimiters + (Config : Command_Line_Configuration) return String + is + use Ada.Strings.Unbounded; + Result : Unbounded_String; + + begin + if Config /= null and then Config.Sections /= null then + for S in Config.Sections'Range loop + Append (Result, " " & Config.Sections (S).all); + end loop; + end if; + + return To_String (Result); + end Section_Delimiters; + + ----------------------- + -- Set_Configuration -- + ----------------------- + + procedure Set_Configuration + (Cmd : in out Command_Line; + Config : Command_Line_Configuration) + is + begin + Cmd.Config := Config; + end Set_Configuration; + + ----------------------- + -- Get_Configuration -- + ----------------------- + + function Get_Configuration + (Cmd : Command_Line) return Command_Line_Configuration + is + begin + return Cmd.Config; + end Get_Configuration; + + ---------------------- + -- Set_Command_Line -- + ---------------------- + + procedure Set_Command_Line + (Cmd : in out Command_Line; + Switches : String; + Getopt_Description : String := ""; + Switch_Char : Character := '-') + is + Tmp : Argument_List_Access; + Parser : Opt_Parser; + S : Character; + Section : String_Access := null; + + function Real_Full_Switch + (S : Character; + Parser : Opt_Parser) return String; + -- Ensure that the returned switch value contains the + -- Switch_Char prefix if needed. + + ---------------------- + -- Real_Full_Switch -- + ---------------------- + + function Real_Full_Switch + (S : Character; + Parser : Opt_Parser) return String + is + begin + if S = '*' then + return Full_Switch (Parser); + else + return Switch_Char & Full_Switch (Parser); + end if; + end Real_Full_Switch; + + -- Start of processing for Set_Command_Line + + begin + Free (Cmd.Expanded); + Free (Cmd.Params); + + if Switches /= "" then + Tmp := Argument_String_To_List (Switches); + Initialize_Option_Scan (Parser, Tmp, Switch_Char); + + loop + begin + S := Getopt (Switches => "* " & Getopt_Description, + Concatenate => False, + Parser => Parser); + exit when S = ASCII.NUL; + + declare + Sw : constant String := + Real_Full_Switch (S, Parser); + Is_Section : Boolean := False; + + begin + if Cmd.Config /= null + and then Cmd.Config.Sections /= null + then + Section_Search : + for S in Cmd.Config.Sections'Range loop + if Sw = Cmd.Config.Sections (S).all then + Section := Cmd.Config.Sections (S); + Is_Section := True; + + exit Section_Search; + end if; + end loop Section_Search; + end if; + + if not Is_Section then + if Section = null then + Add_Switch (Cmd, Sw, Parameter (Parser)); + else + Add_Switch + (Cmd, Sw, Parameter (Parser), + Section => Section.all); + end if; + end if; + end; + + exception + when Invalid_Parameter => + + -- Add it with no parameter, if that's the way the user + -- wants it. + + -- Specify the separator in all cases, as the switch might + -- need to be unaliased, and the alias might contain + -- switches with parameters. + + if Section = null then + Add_Switch + (Cmd, Switch_Char & Full_Switch (Parser)); + else + Add_Switch + (Cmd, Switch_Char & Full_Switch (Parser), + Section => Section.all); + end if; + end; + end loop; + + Free (Parser); + end if; + end Set_Command_Line; + + ---------------- + -- Looking_At -- + ---------------- + + function Looking_At + (Type_Str : String; + Index : Natural; + Substring : String) return Boolean + is + begin + return Index + Substring'Length - 1 <= Type_Str'Last + and then Type_Str (Index .. Index + Substring'Length - 1) = Substring; + end Looking_At; + + ------------------------ + -- Can_Have_Parameter -- + ------------------------ + + function Can_Have_Parameter (S : String) return Boolean is + begin + if S'Length <= 1 then + return False; + end if; + + case S (S'Last) is + when '!' | ':' | '?' | '=' => + return True; + when others => + return False; + end case; + end Can_Have_Parameter; + + ----------------------- + -- Require_Parameter -- + ----------------------- + + function Require_Parameter (S : String) return Boolean is + begin + if S'Length <= 1 then + return False; + end if; + + case S (S'Last) is + when '!' | ':' | '=' => + return True; + when others => + return False; + end case; + end Require_Parameter; + + ------------------- + -- Actual_Switch -- + ------------------- + + function Actual_Switch (S : String) return String is + begin + if S'Length <= 1 then + return S; + end if; + + case S (S'Last) is + when '!' | ':' | '?' | '=' => + return S (S'First .. S'Last - 1); + when others => + return S; + end case; + end Actual_Switch; + + ---------------------------- + -- For_Each_Simple_Switch -- + ---------------------------- + + procedure For_Each_Simple_Switch + (Config : Command_Line_Configuration; + Section : String; + Switch : String; + Parameter : String := ""; + Unalias : Boolean := True) + is + function Group_Analysis + (Prefix : String; + Group : String) return Boolean; + -- Perform the analysis of a group of switches + + Found_In_Config : Boolean := False; + function Is_In_Config + (Config_Switch : String; Index : Integer) return Boolean; + -- If Switch is the same as Config_Switch, run the callback and sets + -- Found_In_Config to True + + function Starts_With + (Config_Switch : String; Index : Integer) return Boolean; + -- if Switch starts with Config_Switch, sets Found_In_Config to True. + -- The return value is for the Foreach_Switch iterator + + -------------------- + -- Group_Analysis -- + -------------------- + + function Group_Analysis + (Prefix : String; + Group : String) return Boolean + is + Idx : Natural; + Found : Boolean; + + function Analyze_Simple_Switch + (Switch : String; Index : Integer) return Boolean; + + --------------------------- + -- Analyze_Simple_Switch -- + --------------------------- + + function Analyze_Simple_Switch + (Switch : String; Index : Integer) return Boolean + is + pragma Unreferenced (Index); + + Full : constant String := Prefix & Group (Idx .. Group'Last); + Sw : constant String := Actual_Switch (Switch); + Last : Natural; + Param : Natural; + + begin + if Sw'Length >= Prefix'Length + + -- Verify that sw starts with Prefix + + and then Looking_At (Sw, Sw'First, Prefix) + + -- Verify that the group starts with sw + + and then Looking_At (Full, Full'First, Sw) + then + Last := Idx + Sw'Length - Prefix'Length - 1; + Param := Last + 1; + + if Can_Have_Parameter (Switch) then + + -- Include potential parameter to the recursive call. + -- Only numbers are allowed. + + while Last < Group'Last + and then Group (Last + 1) in '0' .. '9' + loop + Last := Last + 1; + end loop; + end if; + + if not Require_Parameter (Switch) + or else Last >= Param + then + if Idx = Group'First + and then Last = Group'Last + and then Last < Param + then + -- The group only concerns a single switch. Do not + -- perform recursive call. + + -- Note that we still perform a recursive call if + -- a parameter is detected in the switch, as this + -- is a way to correctly identify such a parameter + -- in aliases. + + return False; + end if; + + Found := True; + + -- Recursive call, using the detected parameter if any + + if Last >= Param then + For_Each_Simple_Switch + (Config, + Section, + Prefix & Group (Idx .. Param - 1), + Group (Param .. Last)); + else + For_Each_Simple_Switch + (Config, Section, Prefix & Group (Idx .. Last), ""); + end if; + + Idx := Last + 1; + return False; + end if; + end if; + return True; + end Analyze_Simple_Switch; + + procedure Foreach is new Foreach_Switch (Analyze_Simple_Switch); + + -- Start of processing for Group_Analysis + + begin + Idx := Group'First; + while Idx <= Group'Last loop + Found := False; + + Foreach (Config, Section); + + if not Found then + For_Each_Simple_Switch + (Config, Section, Prefix & Group (Idx), ""); + Idx := Idx + 1; + end if; + end loop; + + return True; + end Group_Analysis; + + ------------------ + -- Is_In_Config -- + ------------------ + + function Is_In_Config + (Config_Switch : String; Index : Integer) return Boolean + is + Last : Natural; + P : Switch_Parameter_Type; + + begin + Decompose_Switch (Config_Switch, P, Last); + + if Config_Switch (Config_Switch'First .. Last) = Switch then + case P is + when Parameter_None => + if Parameter = "" then + Callback (Switch, "", "", Index => Index); + Found_In_Config := True; + return False; + end if; + + when Parameter_With_Optional_Space => + if Parameter /= "" then + Callback (Switch, " ", Parameter, Index => Index); + Found_In_Config := True; + return False; + end if; + + when Parameter_With_Space_Or_Equal => + if Parameter /= "" then + Callback (Switch, "=", Parameter, Index => Index); + Found_In_Config := True; + return False; + end if; + + when Parameter_No_Space => + if Parameter /= "" then + Callback (Switch, "", Parameter, Index); + Found_In_Config := True; + return False; + end if; + + when Parameter_Optional => + Callback (Switch, "", Parameter, Index); + Found_In_Config := True; + return False; + end case; + end if; + + return True; + end Is_In_Config; + + ----------------- + -- Starts_With -- + ----------------- + + function Starts_With + (Config_Switch : String; Index : Integer) return Boolean + is + Last : Natural; + Param : Natural; + P : Switch_Parameter_Type; + + begin + -- This function is called when we believe the parameter was + -- specified as part of the switch, instead of separately. Thus we + -- look in the config to find all possible switches. + + Decompose_Switch (Config_Switch, P, Last); + + if Looking_At + (Switch, Switch'First, Config_Switch (Config_Switch'First .. Last)) + then + -- Set first char of Param, and last char of Switch + + Param := Switch'First + Last; + Last := Switch'First + Last - Config_Switch'First; + + case P is + + -- None is already handled in Is_In_Config + + when Parameter_None => + null; + + when Parameter_With_Space_Or_Equal => + if Param <= Switch'Last + and then + (Switch (Param) = ' ' or else Switch (Param) = '=') + then + Callback (Switch (Switch'First .. Last), + "=", Switch (Param + 1 .. Switch'Last), Index); + Found_In_Config := True; + return False; + end if; + + when Parameter_With_Optional_Space => + if Param <= Switch'Last and then Switch (Param) = ' ' then + Param := Param + 1; + end if; + + Callback (Switch (Switch'First .. Last), + " ", Switch (Param .. Switch'Last), Index); + Found_In_Config := True; + return False; + + when Parameter_No_Space | Parameter_Optional => + Callback (Switch (Switch'First .. Last), + "", Switch (Param .. Switch'Last), Index); + Found_In_Config := True; + return False; + end case; + end if; + return True; + end Starts_With; + + procedure Foreach_In_Config is new Foreach_Switch (Is_In_Config); + procedure Foreach_Starts_With is new Foreach_Switch (Starts_With); + + -- Start of processing for For_Each_Simple_Switch + + begin + -- First determine if the switch corresponds to one belonging to the + -- configuration. If so, run callback and exit. + + Foreach_In_Config (Config, Section); + + if Found_In_Config then + return; + end if; + + -- If adding a switch that can in fact be expanded through aliases, + -- add separately each of its expansions. + + -- This takes care of expansions like "-T" -> "-gnatwrs", where the + -- alias and its expansion do not have the same prefix. Given the order + -- in which we do things here, the expansion of the alias will itself + -- be checked for a common prefix and split into simple switches. + + if Unalias + and then Config /= null + and then Config.Aliases /= null + then + for A in Config.Aliases'Range loop + if Config.Aliases (A).Section.all = Section + and then Config.Aliases (A).Alias.all = Switch + and then Parameter = "" + then + For_Each_Simple_Switch + (Config, Section, Config.Aliases (A).Expansion.all, ""); + return; + end if; + end loop; + end if; + + -- If adding a switch grouping several switches, add each of the simple + -- switches instead. + + if Config /= null and then Config.Prefixes /= null then + for P in Config.Prefixes'Range loop + if Switch'Length > Config.Prefixes (P)'Length + 1 + and then Looking_At + (Switch, Switch'First, Config.Prefixes (P).all) + then + -- Alias expansion will be done recursively + + if Config.Switches = null then + for S in Switch'First + Config.Prefixes (P)'Length + .. Switch'Last + loop + For_Each_Simple_Switch + (Config, Section, + Config.Prefixes (P).all & Switch (S), ""); + end loop; + + return; + + elsif Group_Analysis + (Config.Prefixes (P).all, + Switch + (Switch'First + Config.Prefixes (P)'Length .. Switch'Last)) + then + -- Recursive calls already done on each switch of the group: + -- Return without executing Callback. + return; + end if; + end if; + end loop; + end if; + + -- Test if added switch is a known switch with parameter attached + -- instead of being specified separately + + if Parameter = "" + and then Config /= null + and then Config.Switches /= null + then + Found_In_Config := False; + Foreach_Starts_With (Config, Section); + if Found_In_Config then + return; + end if; + end if; + + -- The switch is invalid in the config, but we still want to report it. + -- The config could, for instance, include "*" to specify it accepts + -- all switches. + + Callback (Switch, " ", Parameter, Index => -1); + end For_Each_Simple_Switch; + + ---------------- + -- Add_Switch -- + ---------------- + + procedure Add_Switch + (Cmd : in out Command_Line; + Switch : String; + Parameter : String := ""; + Separator : Character := ' '; + Section : String := ""; + Add_Before : Boolean := False) + is + Success : Boolean; + pragma Unreferenced (Success); + begin + Add_Switch (Cmd, Switch, Parameter, Separator, + Section, Add_Before, Success); + end Add_Switch; + + ---------------- + -- Add_Switch -- + ---------------- + + procedure Add_Switch + (Cmd : in out Command_Line; + Switch : String; + Parameter : String := ""; + Separator : Character := ' '; + Section : String := ""; + Add_Before : Boolean := False; + Success : out Boolean) + is + pragma Unreferenced (Separator); -- ??? Should be removed eventually + + procedure Add_Simple_Switch + (Simple : String; + Separator : String; + Param : String; + Index : Integer); + -- Add a new switch that has had all its aliases expanded, and switches + -- ungrouped. We know there are no more aliases in Switches. + + ----------------------- + -- Add_Simple_Switch -- + ----------------------- + + procedure Add_Simple_Switch + (Simple : String; + Separator : String; + Param : String; + Index : Integer) + is + pragma Unreferenced (Index); + Sep : Character; + + begin + if Separator = "" then + Sep := ASCII.NUL; + else + Sep := Separator (Separator'First); + end if; + + if Cmd.Expanded = null then + Cmd.Expanded := new Argument_List'(1 .. 1 => new String'(Simple)); + + if Param /= "" then + Cmd.Params := + new Argument_List'(1 .. 1 => new String'(Sep & Param)); + else + Cmd.Params := new Argument_List'(1 .. 1 => null); + end if; + + if Section = "" then + Cmd.Sections := new Argument_List'(1 .. 1 => null); + else + Cmd.Sections := + new Argument_List'(1 .. 1 => new String'(Section)); + end if; + + else + -- Do we already have this switch? + + for C in Cmd.Expanded'Range loop + if Cmd.Expanded (C).all = Simple + and then + ((Cmd.Params (C) = null and then Param = "") + or else + (Cmd.Params (C) /= null + and then Cmd.Params (C).all = Sep & Param)) + and then + ((Cmd.Sections (C) = null and then Section = "") + or else + (Cmd.Sections (C) /= null + and then Cmd.Sections (C).all = Section)) + then + return; + end if; + end loop; + + -- Inserting at least one switch + + Success := True; + Add (Cmd.Expanded, new String'(Simple), Add_Before); + + if Param /= "" then + Add + (Cmd.Params, + new String'(Sep & Param), + Add_Before); + else + Add + (Cmd.Params, + null, + Add_Before); + end if; + + if Section = "" then + Add + (Cmd.Sections, + null, + Add_Before); + else + Add + (Cmd.Sections, + new String'(Section), + Add_Before); + end if; + end if; + end Add_Simple_Switch; + + procedure Add_Simple_Switches is + new For_Each_Simple_Switch (Add_Simple_Switch); + + -- Local Variables + + Section_Valid : Boolean := False; + + -- Start of processing for Add_Switch + + begin + if Section /= "" and then Cmd.Config /= null then + for S in Cmd.Config.Sections'Range loop + if Section = Cmd.Config.Sections (S).all then + Section_Valid := True; + exit; + end if; + end loop; + + if not Section_Valid then + raise Invalid_Section; + end if; + end if; + + Success := False; + Add_Simple_Switches (Cmd.Config, Section, Switch, Parameter); + Free (Cmd.Coalesce); + end Add_Switch; + + ------------ + -- Remove -- + ------------ + + procedure Remove (Line : in out Argument_List_Access; Index : Integer) is + Tmp : Argument_List_Access := Line; + + begin + Line := new Argument_List (Tmp'First .. Tmp'Last - 1); + + if Index /= Tmp'First then + Line (Tmp'First .. Index - 1) := Tmp (Tmp'First .. Index - 1); + end if; + + Free (Tmp (Index)); + + if Index /= Tmp'Last then + Line (Index .. Tmp'Last - 1) := Tmp (Index + 1 .. Tmp'Last); + end if; + + Unchecked_Free (Tmp); + end Remove; + + --------- + -- Add -- + --------- + + procedure Add + (Line : in out Argument_List_Access; + Str : String_Access; + Before : Boolean := False) + is + Tmp : Argument_List_Access := Line; + + begin + if Tmp /= null then + Line := new Argument_List (Tmp'First .. Tmp'Last + 1); + + if Before then + Line (Tmp'First) := Str; + Line (Tmp'First + 1 .. Tmp'Last + 1) := Tmp.all; + else + Line (Tmp'Range) := Tmp.all; + Line (Tmp'Last + 1) := Str; + end if; + + Unchecked_Free (Tmp); + + else + Line := new Argument_List'(1 .. 1 => Str); + end if; + end Add; + + ------------------- + -- Remove_Switch -- + ------------------- + + procedure Remove_Switch + (Cmd : in out Command_Line; + Switch : String; + Remove_All : Boolean := False; + Has_Parameter : Boolean := False; + Section : String := "") + is + Success : Boolean; + pragma Unreferenced (Success); + begin + Remove_Switch (Cmd, Switch, Remove_All, Has_Parameter, Section, Success); + end Remove_Switch; + + ------------------- + -- Remove_Switch -- + ------------------- + + procedure Remove_Switch + (Cmd : in out Command_Line; + Switch : String; + Remove_All : Boolean := False; + Has_Parameter : Boolean := False; + Section : String := ""; + Success : out Boolean) + is + procedure Remove_Simple_Switch + (Simple, Separator, Param : String; Index : Integer); + -- Removes a simple switch, with no aliasing or grouping + + -------------------------- + -- Remove_Simple_Switch -- + -------------------------- + + procedure Remove_Simple_Switch + (Simple, Separator, Param : String; Index : Integer) + is + C : Integer; + pragma Unreferenced (Param, Separator, Index); + + begin + if Cmd.Expanded /= null then + C := Cmd.Expanded'First; + while C <= Cmd.Expanded'Last loop + if Cmd.Expanded (C).all = Simple + and then + (Remove_All + or else (Cmd.Sections (C) = null + and then Section = "") + or else (Cmd.Sections (C) /= null + and then Section = Cmd.Sections (C).all)) + and then (not Has_Parameter or else Cmd.Params (C) /= null) + then + Remove (Cmd.Expanded, C); + Remove (Cmd.Params, C); + Remove (Cmd.Sections, C); + Success := True; + + if not Remove_All then + return; + end if; + + else + C := C + 1; + end if; + end loop; + end if; + end Remove_Simple_Switch; + + procedure Remove_Simple_Switches is + new For_Each_Simple_Switch (Remove_Simple_Switch); + + -- Start of processing for Remove_Switch + + begin + Success := False; + Remove_Simple_Switches + (Cmd.Config, Section, Switch, "", Unalias => not Has_Parameter); + Free (Cmd.Coalesce); + end Remove_Switch; + + ------------------- + -- Remove_Switch -- + ------------------- + + procedure Remove_Switch + (Cmd : in out Command_Line; + Switch : String; + Parameter : String; + Section : String := "") + is + procedure Remove_Simple_Switch + (Simple, Separator, Param : String; Index : Integer); + -- Removes a simple switch, with no aliasing or grouping + + -------------------------- + -- Remove_Simple_Switch -- + -------------------------- + + procedure Remove_Simple_Switch + (Simple, Separator, Param : String; Index : Integer) + is + pragma Unreferenced (Separator, Index); + C : Integer; + + begin + if Cmd.Expanded /= null then + C := Cmd.Expanded'First; + while C <= Cmd.Expanded'Last loop + if Cmd.Expanded (C).all = Simple + and then + ((Cmd.Sections (C) = null + and then Section = "") + or else + (Cmd.Sections (C) /= null + and then Section = Cmd.Sections (C).all)) + and then + ((Cmd.Params (C) = null and then Param = "") + or else + (Cmd.Params (C) /= null + and then + + -- Ignore the separator stored in Parameter + + Cmd.Params (C) (Cmd.Params (C)'First + 1 + .. Cmd.Params (C)'Last) = + Param)) + then + Remove (Cmd.Expanded, C); + Remove (Cmd.Params, C); + Remove (Cmd.Sections, C); + + -- The switch is necessarily unique by construction of + -- Add_Switch. + + return; + + else + C := C + 1; + end if; + end loop; + end if; + end Remove_Simple_Switch; + + procedure Remove_Simple_Switches is + new For_Each_Simple_Switch (Remove_Simple_Switch); + + -- Start of processing for Remove_Switch + + begin + Remove_Simple_Switches (Cmd.Config, Section, Switch, Parameter); + Free (Cmd.Coalesce); + end Remove_Switch; + + -------------------- + -- Group_Switches -- + -------------------- + + procedure Group_Switches + (Cmd : Command_Line; + Result : Argument_List_Access; + Sections : Argument_List_Access; + Params : Argument_List_Access) + is + function Compatible_Parameter (Param : String_Access) return Boolean; + -- True when the parameter can be part of a group + + -------------------------- + -- Compatible_Parameter -- + -------------------------- + + function Compatible_Parameter (Param : String_Access) return Boolean is + begin + -- No parameter OK + + if Param = null then + return True; + + -- We need parameters without separators + + elsif Param (Param'First) /= ASCII.NUL then + return False; + + -- Parameters must be all digits + + else + for J in Param'First + 1 .. Param'Last loop + if Param (J) not in '0' .. '9' then + return False; + end if; + end loop; + + return True; + end if; + end Compatible_Parameter; + + -- Local declarations + + Group : Ada.Strings.Unbounded.Unbounded_String; + First : Natural; + use type Ada.Strings.Unbounded.Unbounded_String; + + -- Start of processing for Group_Switches + + begin + if Cmd.Config = null + or else Cmd.Config.Prefixes = null + then + return; + end if; + + for P in Cmd.Config.Prefixes'Range loop + Group := Ada.Strings.Unbounded.Null_Unbounded_String; + First := 0; + + for C in Result'Range loop + if Result (C) /= null + and then Compatible_Parameter (Params (C)) + and then Looking_At + (Result (C).all, Result (C)'First, Cmd.Config.Prefixes (P).all) + then + -- If we are still in the same section, group the switches + + if First = 0 + or else + (Sections (C) = null + and then Sections (First) = null) + or else + (Sections (C) /= null + and then Sections (First) /= null + and then Sections (C).all = Sections (First).all) + then + Group := + Group & + Result (C) + (Result (C)'First + Cmd.Config.Prefixes (P)'Length .. + Result (C)'Last); + + if Params (C) /= null then + Group := + Group & + Params (C) (Params (C)'First + 1 .. Params (C)'Last); + Free (Params (C)); + end if; + + if First = 0 then + First := C; + end if; + + Free (Result (C)); + + -- We changed section: we put the grouped switches to the first + -- place, on continue with the new section. + + else + Result (First) := + new String' + (Cmd.Config.Prefixes (P).all & + Ada.Strings.Unbounded.To_String (Group)); + Group := + Ada.Strings.Unbounded.To_Unbounded_String + (Result (C) + (Result (C)'First + Cmd.Config.Prefixes (P)'Length .. + Result (C)'Last)); + First := C; + end if; + end if; + end loop; + + if First > 0 then + Result (First) := + new String' + (Cmd.Config.Prefixes (P).all & + Ada.Strings.Unbounded.To_String (Group)); + end if; + end loop; + end Group_Switches; + + -------------------- + -- Alias_Switches -- + -------------------- + + procedure Alias_Switches + (Cmd : Command_Line; + Result : Argument_List_Access; + Params : Argument_List_Access) + is + Found : Boolean; + First : Natural; + + procedure Check_Cb (Switch, Separator, Param : String; Index : Integer); + -- Checks whether the command line contains [Switch]. + -- Sets the global variable [Found] appropriately. + -- This will be called for each simple switch that make up an alias, to + -- know whether the alias should be applied. + + procedure Remove_Cb (Switch, Separator, Param : String; Index : Integer); + -- Remove the simple switch [Switch] from the command line, since it is + -- part of a simpler alias + + -------------- + -- Check_Cb -- + -------------- + + procedure Check_Cb + (Switch, Separator, Param : String; Index : Integer) + is + pragma Unreferenced (Separator, Index); + + begin + if Found then + for E in Result'Range loop + if Result (E) /= null + and then + (Params (E) = null + or else Params (E) (Params (E)'First + 1 + .. Params (E)'Last) = Param) + and then Result (E).all = Switch + then + return; + end if; + end loop; + + Found := False; + end if; + end Check_Cb; + + --------------- + -- Remove_Cb -- + --------------- + + procedure Remove_Cb (Switch, Separator, Param : String; Index : Integer) + is + pragma Unreferenced (Separator, Index); + + begin + for E in Result'Range loop + if Result (E) /= null + and then + (Params (E) = null + or else Params (E) (Params (E)'First + 1 + .. Params (E)'Last) = Param) + and then Result (E).all = Switch + then + if First > E then + First := E; + end if; + + Free (Result (E)); + Free (Params (E)); + return; + end if; + end loop; + end Remove_Cb; + + procedure Check_All is new For_Each_Simple_Switch (Check_Cb); + procedure Remove_All is new For_Each_Simple_Switch (Remove_Cb); + + -- Start of processing for Alias_Switches + + begin + if Cmd.Config = null + or else Cmd.Config.Aliases = null + then + return; + end if; + + for A in Cmd.Config.Aliases'Range loop + + -- Compute the various simple switches that make up the alias. We + -- split the expansion into as many simple switches as possible, and + -- then check whether the expanded command line has all of them. + + Found := True; + Check_All (Cmd.Config, + Switch => Cmd.Config.Aliases (A).Expansion.all, + Section => Cmd.Config.Aliases (A).Section.all); + + if Found then + First := Integer'Last; + Remove_All (Cmd.Config, + Switch => Cmd.Config.Aliases (A).Expansion.all, + Section => Cmd.Config.Aliases (A).Section.all); + Result (First) := new String'(Cmd.Config.Aliases (A).Alias.all); + end if; + end loop; + end Alias_Switches; + + ------------------- + -- Sort_Sections -- + ------------------- + + procedure Sort_Sections + (Line : GNAT.OS_Lib.Argument_List_Access; + Sections : GNAT.OS_Lib.Argument_List_Access; + Params : GNAT.OS_Lib.Argument_List_Access) + is + Sections_List : Argument_List_Access := + new Argument_List'(1 .. 1 => null); + Found : Boolean; + Old_Line : constant Argument_List := Line.all; + Old_Sections : constant Argument_List := Sections.all; + Old_Params : constant Argument_List := Params.all; + Index : Natural; + + begin + if Line = null then + return; + end if; + + -- First construct a list of all sections + + for E in Line'Range loop + if Sections (E) /= null then + Found := False; + for S in Sections_List'Range loop + if (Sections_List (S) = null and then Sections (E) = null) + or else + (Sections_List (S) /= null + and then Sections (E) /= null + and then Sections_List (S).all = Sections (E).all) + then + Found := True; + exit; + end if; + end loop; + + if not Found then + Add (Sections_List, Sections (E)); + end if; + end if; + end loop; + + Index := Line'First; + + for S in Sections_List'Range loop + for E in Old_Line'Range loop + if (Sections_List (S) = null and then Old_Sections (E) = null) + or else + (Sections_List (S) /= null + and then Old_Sections (E) /= null + and then Sections_List (S).all = Old_Sections (E).all) + then + Line (Index) := Old_Line (E); + Sections (Index) := Old_Sections (E); + Params (Index) := Old_Params (E); + Index := Index + 1; + end if; + end loop; + end loop; + + Unchecked_Free (Sections_List); + end Sort_Sections; + + ----------- + -- Start -- + ----------- + + procedure Start + (Cmd : in out Command_Line; + Iter : in out Command_Line_Iterator; + Expanded : Boolean := False) + is + begin + if Cmd.Expanded = null then + Iter.List := null; + return; + end if; + + -- Reorder the expanded line so that sections are grouped + + Sort_Sections (Cmd.Expanded, Cmd.Sections, Cmd.Params); + + -- Coalesce the switches as much as possible + + if not Expanded + and then Cmd.Coalesce = null + then + Cmd.Coalesce := new Argument_List (Cmd.Expanded'Range); + for E in Cmd.Expanded'Range loop + Cmd.Coalesce (E) := new String'(Cmd.Expanded (E).all); + end loop; + + Free (Cmd.Coalesce_Sections); + Cmd.Coalesce_Sections := new Argument_List (Cmd.Sections'Range); + for E in Cmd.Sections'Range loop + Cmd.Coalesce_Sections (E) := + (if Cmd.Sections (E) = null then null + else new String'(Cmd.Sections (E).all)); + end loop; + + Free (Cmd.Coalesce_Params); + Cmd.Coalesce_Params := new Argument_List (Cmd.Params'Range); + for E in Cmd.Params'Range loop + Cmd.Coalesce_Params (E) := + (if Cmd.Params (E) = null then null + else new String'(Cmd.Params (E).all)); + end loop; + + -- Not a clone, since we will not modify the parameters anyway + + Alias_Switches (Cmd, Cmd.Coalesce, Cmd.Coalesce_Params); + Group_Switches + (Cmd, Cmd.Coalesce, Cmd.Coalesce_Sections, Cmd.Coalesce_Params); + end if; + + if Expanded then + Iter.List := Cmd.Expanded; + Iter.Params := Cmd.Params; + Iter.Sections := Cmd.Sections; + else + Iter.List := Cmd.Coalesce; + Iter.Params := Cmd.Coalesce_Params; + Iter.Sections := Cmd.Coalesce_Sections; + end if; + + if Iter.List = null then + Iter.Current := Integer'Last; + else + Iter.Current := Iter.List'First; + + while Iter.Current <= Iter.List'Last + and then Iter.List (Iter.Current) = null + loop + Iter.Current := Iter.Current + 1; + end loop; + end if; + end Start; + + -------------------- + -- Current_Switch -- + -------------------- + + function Current_Switch (Iter : Command_Line_Iterator) return String is + begin + return Iter.List (Iter.Current).all; + end Current_Switch; + + -------------------- + -- Is_New_Section -- + -------------------- + + function Is_New_Section (Iter : Command_Line_Iterator) return Boolean is + Section : constant String := Current_Section (Iter); + begin + if Iter.Sections = null then + return False; + elsif Iter.Current = Iter.Sections'First + or else Iter.Sections (Iter.Current - 1) = null + then + return Section /= ""; + end if; + + return Section /= Iter.Sections (Iter.Current - 1).all; + end Is_New_Section; + + --------------------- + -- Current_Section -- + --------------------- + + function Current_Section (Iter : Command_Line_Iterator) return String is + begin + if Iter.Sections = null + or else Iter.Current > Iter.Sections'Last + or else Iter.Sections (Iter.Current) = null + then + return ""; + end if; + + return Iter.Sections (Iter.Current).all; + end Current_Section; + + ----------------------- + -- Current_Separator -- + ----------------------- + + function Current_Separator (Iter : Command_Line_Iterator) return String is + begin + if Iter.Params = null + or else Iter.Current > Iter.Params'Last + or else Iter.Params (Iter.Current) = null + then + return ""; + + else + declare + Sep : constant Character := + Iter.Params (Iter.Current) (Iter.Params (Iter.Current)'First); + begin + if Sep = ASCII.NUL then + return ""; + else + return "" & Sep; + end if; + end; + end if; + end Current_Separator; + + ----------------------- + -- Current_Parameter -- + ----------------------- + + function Current_Parameter (Iter : Command_Line_Iterator) return String is + begin + if Iter.Params = null + or else Iter.Current > Iter.Params'Last + or else Iter.Params (Iter.Current) = null + then + return ""; + + else + declare + P : constant String := Iter.Params (Iter.Current).all; + + begin + -- Skip separator + + return P (P'First + 1 .. P'Last); + end; + end if; + end Current_Parameter; + + -------------- + -- Has_More -- + -------------- + + function Has_More (Iter : Command_Line_Iterator) return Boolean is + begin + return Iter.List /= null and then Iter.Current <= Iter.List'Last; + end Has_More; + + ---------- + -- Next -- + ---------- + + procedure Next (Iter : in out Command_Line_Iterator) is + begin + Iter.Current := Iter.Current + 1; + while Iter.Current <= Iter.List'Last + and then Iter.List (Iter.Current) = null + loop + Iter.Current := Iter.Current + 1; + end loop; + end Next; + + ---------- + -- Free -- + ---------- + + procedure Free (Config : in out Command_Line_Configuration) is + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Switch_Definitions, Switch_Definitions_List); + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Alias_Definitions, Alias_Definitions_List); + begin + if Config /= null then + Free (Config.Prefixes); + Free (Config.Sections); + Free (Config.Usage); + Free (Config.Help); + + if Config.Aliases /= null then + for A in Config.Aliases'Range loop + Free (Config.Aliases (A).Alias); + Free (Config.Aliases (A).Expansion); + Free (Config.Aliases (A).Section); + end loop; + Unchecked_Free (Config.Aliases); + end if; + + if Config.Switches /= null then + for S in Config.Switches'Range loop + Free (Config.Switches (S).Switch); + Free (Config.Switches (S).Long_Switch); + Free (Config.Switches (S).Help); + Free (Config.Switches (S).Section); + end loop; + + Unchecked_Free (Config.Switches); + end if; + + Unchecked_Free (Config); + end if; + end Free; + + ---------- + -- Free -- + ---------- + + procedure Free (Cmd : in out Command_Line) is + begin + Free (Cmd.Expanded); + Free (Cmd.Coalesce); + Free (Cmd.Coalesce_Sections); + Free (Cmd.Coalesce_Params); + Free (Cmd.Params); + Free (Cmd.Sections); + end Free; + + --------------- + -- Set_Usage -- + --------------- + + procedure Set_Usage + (Config : in out Command_Line_Configuration; + Usage : String := "[switches] [arguments]"; + Help : String := "") + is + begin + if Config = null then + Config := new Command_Line_Configuration_Record; + end if; + + Free (Config.Usage); + Config.Usage := new String'(Usage); + Config.Help := new String'(Help); + end Set_Usage; + + ------------------ + -- Display_Help -- + ------------------ + + procedure Display_Help (Config : Command_Line_Configuration) is + function Switch_Name + (Def : Switch_Definition; + Section : String) return String; + -- Return the "-short, --long=ARG" string for Def. + -- Returns "" if the switch is not in the section. + + function Param_Name + (P : Switch_Parameter_Type; + Name : String := "ARG") return String; + -- Return the display for a switch parameter + + procedure Display_Section_Help (Section : String); + -- Display the help for a specific section ("" is the default section) + + -------------------------- + -- Display_Section_Help -- + -------------------------- + + procedure Display_Section_Help (Section : String) is + Max_Len : Natural := 0; + begin + -- ??? Special display for "*" + + New_Line; + + if Section /= "" then + Put_Line ("Switches after " & Section); + end if; + + -- Compute size of the switches column + + for S in Config.Switches'Range loop + Max_Len := Natural'Max + (Max_Len, Switch_Name (Config.Switches (S), Section)'Length); + end loop; + + if Config.Aliases /= null then + for A in Config.Aliases'Range loop + if Config.Aliases (A).Section.all = Section then + Max_Len := Natural'Max + (Max_Len, Config.Aliases (A).Alias'Length); + end if; + end loop; + end if; + + -- Display the switches + + for S in Config.Switches'Range loop + declare + N : constant String := + Switch_Name (Config.Switches (S), Section); + begin + if N /= "" then + Put (" "); + Put (N); + Put ((1 .. Max_Len - N'Length + 1 => ' ')); + + if Config.Switches (S).Help /= null then + Put (Config.Switches (S).Help.all); + end if; + + New_Line; + end if; + end; + end loop; + + -- Display the aliases + + if Config.Aliases /= null then + for A in Config.Aliases'Range loop + if Config.Aliases (A).Section.all = Section then + Put (" "); + Put (Config.Aliases (A).Alias.all); + Put ((1 .. Max_Len - Config.Aliases (A).Alias'Length + 1 + => ' ')); + Put ("Equivalent to " & Config.Aliases (A).Expansion.all); + New_Line; + end if; + end loop; + end if; + end Display_Section_Help; + + ---------------- + -- Param_Name -- + ---------------- + + function Param_Name + (P : Switch_Parameter_Type; + Name : String := "ARG") return String + is + begin + case P is + when Parameter_None => + return ""; + + when Parameter_With_Optional_Space => + return " " & To_Upper (Name); + + when Parameter_With_Space_Or_Equal => + return "=" & To_Upper (Name); + + when Parameter_No_Space => + return To_Upper (Name); + + when Parameter_Optional => + return '[' & To_Upper (Name) & ']'; + end case; + end Param_Name; + + ----------------- + -- Switch_Name -- + ----------------- + + function Switch_Name + (Def : Switch_Definition; + Section : String) return String + is + use Ada.Strings.Unbounded; + Result : Unbounded_String; + P1, P2 : Switch_Parameter_Type; + Last1, Last2 : Integer := 0; + + begin + if (Section = "" and then Def.Section = null) + or else (Def.Section /= null and then Def.Section.all = Section) + then + if Def.Switch /= null + and then Def.Switch.all = "*" + then + return "[any switch]"; + end if; + + if Def.Switch /= null then + Decompose_Switch (Def.Switch.all, P1, Last1); + Append (Result, Def.Switch (Def.Switch'First .. Last1)); + + if Def.Long_Switch /= null then + Decompose_Switch (Def.Long_Switch.all, P2, Last2); + Append (Result, ", " + & Def.Long_Switch (Def.Long_Switch'First .. Last2)); + Append (Result, Param_Name (P2, "ARG")); + + else + Append (Result, Param_Name (P1, "ARG")); + end if; + + else -- Long_Switch necessarily not null + Decompose_Switch (Def.Long_Switch.all, P2, Last2); + Append (Result, + Def.Long_Switch (Def.Long_Switch'First .. Last2)); + Append (Result, Param_Name (P2, "ARG")); + end if; + end if; + + return To_String (Result); + end Switch_Name; + + -- Start of processing for Display_Help + + begin + if Config = null then + return; + end if; + + if Config.Usage /= null then + Put_Line ("Usage: " + & Base_Name + (Ada.Command_Line.Command_Name) & " " & Config.Usage.all); + else + Put_Line ("Usage: " & Base_Name (Ada.Command_Line.Command_Name) + & " [switches] [arguments]"); + end if; + + if Config.Help /= null and then Config.Help.all /= "" then + Put_Line (Config.Help.all); + end if; + + Display_Section_Help (""); + + if Config.Sections /= null and then Config.Switches /= null then + for S in Config.Sections'Range loop + Display_Section_Help (Config.Sections (S).all); + end loop; + end if; + end Display_Help; + + ------------ + -- Getopt -- + ------------ + + procedure Getopt + (Config : Command_Line_Configuration; + Callback : Switch_Handler := null; + Parser : Opt_Parser := Command_Line_Parser) + is + Getopt_Switches : String_Access; + C : Character := ASCII.NUL; + + Empty_Name : aliased constant String := ""; + Current_Section : Integer := -1; + Section_Name : not null access constant String := Empty_Name'Access; + + procedure Simple_Callback + (Simple_Switch : String; + Separator : String; + Parameter : String; + Index : Integer); + -- Needs comments ??? + + procedure Do_Callback (Switch, Parameter : String; Index : Integer); + + ----------------- + -- Do_Callback -- + ----------------- + + procedure Do_Callback (Switch, Parameter : String; Index : Integer) is + begin + -- Do automatic handling when possible + + if Index /= -1 then + case Config.Switches (Index).Typ is + when Switch_Untyped => + null; -- no automatic handling + + when Switch_Boolean => + Config.Switches (Index).Boolean_Output.all := + Config.Switches (Index).Boolean_Value; + return; + + when Switch_Integer => + begin + if Parameter = "" then + Config.Switches (Index).Integer_Output.all := + Config.Switches (Index).Integer_Default; + else + Config.Switches (Index).Integer_Output.all := + Integer'Value (Parameter); + end if; + exception + when Constraint_Error => + raise Invalid_Parameter + with "Expected integer parameter for '" + & Switch & "'"; + end; + + when Switch_String => + Free (Config.Switches (Index).String_Output.all); + Config.Switches (Index).String_Output.all := + new String'(Parameter); + end case; + end if; + + -- Otherwise calls the user callback if one was defined + + if Callback /= null then + Callback (Switch => Switch, + Parameter => Parameter, + Section => Section_Name.all); + end if; + end Do_Callback; + + procedure For_Each_Simple + is new For_Each_Simple_Switch (Simple_Callback); + + --------------------- + -- Simple_Callback -- + --------------------- + + procedure Simple_Callback + (Simple_Switch : String; + Separator : String; + Parameter : String; + Index : Integer) + is + pragma Unreferenced (Separator); + begin + Do_Callback (Switch => Simple_Switch, + Parameter => Parameter, + Index => Index); + end Simple_Callback; + + -- Start of processing for Getopt + + begin + -- Initialize sections + + if Config.Sections = null then + Config.Sections := new Argument_List'(1 .. 0 => null); + end if; + + Internal_Initialize_Option_Scan + (Parser => Parser, + Switch_Char => Parser.Switch_Character, + Stop_At_First_Non_Switch => Parser.Stop_At_First, + Section_Delimiters => Section_Delimiters (Config)); + + Getopt_Switches := new String' + (Get_Switches (Config, Parser.Switch_Character, Section_Name.all) + & " h -help"); + + -- Initialize output values for automatically handled switches + + for S in Config.Switches'Range loop + case Config.Switches (S).Typ is + when Switch_Untyped => + null; -- Nothing to do + + when Switch_Boolean => + Config.Switches (S).Boolean_Output.all := + not Config.Switches (S).Boolean_Value; + + when Switch_Integer => + Config.Switches (S).Integer_Output.all := + Config.Switches (S).Integer_Initial; + + when Switch_String => + Config.Switches (S).String_Output.all := new String'(""); + end case; + end loop; + + -- For all sections, and all switches within those sections + + loop + C := Getopt (Switches => Getopt_Switches.all, + Concatenate => True, + Parser => Parser); + + if C = '*' then + -- Full_Switch already includes the leading '-' + + Do_Callback (Switch => Full_Switch (Parser), + Parameter => Parameter (Parser), + Index => -1); + + elsif C /= ASCII.NUL then + if Full_Switch (Parser) = "h" + or else Full_Switch (Parser) = "-help" + then + Display_Help (Config); + raise Exit_From_Command_Line; + end if; + + -- Do switch expansion if needed + For_Each_Simple + (Config, + Section => Section_Name.all, + Switch => Parser.Switch_Character & Full_Switch (Parser), + Parameter => Parameter (Parser)); + + else + if Current_Section = -1 then + Current_Section := Config.Sections'First; + else + Current_Section := Current_Section + 1; + end if; + + exit when Current_Section > Config.Sections'Last; + + Section_Name := Config.Sections (Current_Section); + Goto_Section (Section_Name.all, Parser); + + Free (Getopt_Switches); + Getopt_Switches := new String' + (Get_Switches + (Config, Parser.Switch_Character, Section_Name.all)); + end if; + end loop; + + Free (Getopt_Switches); + + exception + when Invalid_Switch => + Free (Getopt_Switches); + + -- Message inspired by "ls" on Unix + + Put_Line (Standard_Error, + Base_Name (Ada.Command_Line.Command_Name) + & ": unrecognized option '" + & Parser.Switch_Character & Full_Switch (Parser) + & "'"); + Put_Line (Standard_Error, + "Try `" + & Base_Name (Ada.Command_Line.Command_Name) + & " --help` for more information."); + + raise; + + when others => + Free (Getopt_Switches); + raise; + end Getopt; + + ----------- + -- Build -- + ----------- + + procedure Build + (Line : in out Command_Line; + Args : out GNAT.OS_Lib.Argument_List_Access; + Expanded : Boolean := False; + Switch_Char : Character := '-') + is + Iter : Command_Line_Iterator; + Count : Natural := 0; + + begin + Start (Line, Iter, Expanded => Expanded); + while Has_More (Iter) loop + if Is_New_Section (Iter) then + Count := Count + 1; + end if; + + Count := Count + 1; + Next (Iter); + end loop; + + Args := new Argument_List (1 .. Count); + Count := Args'First; + + Start (Line, Iter, Expanded => Expanded); + while Has_More (Iter) loop + if Is_New_Section (Iter) then + Args (Count) := new String' + (Switch_Char & Current_Section (Iter)); + Count := Count + 1; + end if; + + Args (Count) := new String'(Current_Switch (Iter) + & Current_Separator (Iter) + & Current_Parameter (Iter)); + Count := Count + 1; + Next (Iter); + end loop; + end Build; + +end GNAT.Command_Line; diff --git a/gcc/ada/g-comlin.ads b/gcc/ada/g-comlin.ads new file mode 100644 index 000000000..4ee683a49 --- /dev/null +++ b/gcc/ada/g-comlin.ads @@ -0,0 +1,1125 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 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. + + procedure Define_Switch + (Config : in out Command_Line_Configuration; + Switch : String := ""; + Long_Switch : String := ""; + Help : String := ""; + Section : String := ""); + -- 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). + -- They should all start with the same character, though. If this + -- character is not '-', you will 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). + + 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 erroneous memory + -- access may happen. + + 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); + -- 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. + + procedure Define_Switch + (Config : in out Command_Line_Configuration; + Output : access GNAT.Strings.String_Access; + Switch : String := ""; + Long_Switch : String := ""; + Help : String := ""; + Section : String := ""); + -- 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. + + procedure Set_Usage + (Config : in out Command_Line_Configuration; + Usage : String := "[switches] [arguments]"; + Help : String := ""); + -- Defines the general format of the call to the application, and a short + -- help text. These are both displayed by Display_Help + + 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); + -- Similar to the standard Getopt function. + -- For each switch found on the command line, this calls Callback. + -- + -- 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. + -- + -- 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 + + 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). + -- + -- 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. + + procedure Add_Switch + (Cmd : in out Command_Line; + Switch : String; + Parameter : String := ""; + Separator : Character := ' '; + 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] is ignored, and kept for backward compatibility only. + -- ??? It might be removed in future versions. + -- + -- 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 := ' '; + 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. + +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 : Positive; + 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; + + 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 + + Aliases : Alias_Definitions_List; + Usage : GNAT.OS_Lib.String_Access; + Help : GNAT.OS_Lib.String_Access; + Switches : Switch_Definitions_List; + -- List of expected switches (Used when expanding switch groups) + end record; + type Command_Line_Configuration is access Command_Line_Configuration_Record; + + type Command_Line is record + Config : Command_Line_Configuration; + Expanded : GNAT.OS_Lib.Argument_List_Access; + + Params : GNAT.OS_Lib.Argument_List_Access; + -- Parameter for the corresponding switch in Expanded. The first + -- character is the separator (or ASCII.NUL if there is no separator). + + Sections : GNAT.OS_Lib.Argument_List_Access; + -- The list of sections + + Coalesce : GNAT.OS_Lib.Argument_List_Access; + Coalesce_Params : GNAT.OS_Lib.Argument_List_Access; + Coalesce_Sections : GNAT.OS_Lib.Argument_List_Access; + -- Cached version of the command line. This is recomputed every time + -- the command line changes. Switches are grouped as much as possible, + -- and aliases are used to reduce the length of the command line. The + -- parameters are not allocated, they point into Params, so they must + -- not be freed. + end record; + + type Command_Line_Iterator is record + List : GNAT.OS_Lib.Argument_List_Access; + Sections : GNAT.OS_Lib.Argument_List_Access; + Params : GNAT.OS_Lib.Argument_List_Access; + Current : Natural; + end record; + +end GNAT.Command_Line; diff --git a/gcc/ada/g-comver.adb b/gcc/ada/g-comver.adb new file mode 100644 index 000000000..ac096f463 --- /dev/null +++ b/gcc/ada/g-comver.adb @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C O M P I L E R _ V E R S I O N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2010, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a routine for obtaining the version number of the +-- GNAT compiler used to compile the program. It relies on the generated +-- constant in the binder generated package that records this information. + +package body GNAT.Compiler_Version is + + Ver_Len_Max : constant := 256; + -- This is logically a reference to Gnatvsn.Ver_Len_Max but we cannot + -- import this directly since run-time units cannot WITH compiler units. + + Ver_Prefix : constant String := "GNAT Version: "; + -- This is logically a reference to Gnatvsn.Ver_Prefix but we cannot + -- import this directly since run-time units cannot WITH compiler units. + + GNAT_Version : constant String (1 .. Ver_Len_Max + Ver_Prefix'Length); + pragma Import (C, GNAT_Version, "__gnat_version"); + + ------------- + -- Version -- + ------------- + + function Version return String is + begin + -- Search for terminating right paren or NUL ending the string + + for J in Ver_Prefix'Length + 1 .. GNAT_Version'Last loop + if GNAT_Version (J) = ')' then + return GNAT_Version (Ver_Prefix'Length + 1 .. J); + end if; + + if GNAT_Version (J) = Character'Val (0) then + return GNAT_Version (Ver_Prefix'Length + 1 .. J - 1); + end if; + end loop; + + -- This should not happen (no right paren or NUL found) + + return GNAT_Version; + end Version; + +end GNAT.Compiler_Version; diff --git a/gcc/ada/g-comver.ads b/gcc/ada/g-comver.ads new file mode 100644 index 000000000..33494202f --- /dev/null +++ b/gcc/ada/g-comver.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2005, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a 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-crc32.adb b/gcc/ada/g-crc32.adb new file mode 100644 index 000000000..49c9734ce --- /dev/null +++ b/gcc/ada/g-crc32.adb @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . C R C 3 2 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2007, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +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 new file mode 100644 index 000000000..dac4c4278 --- /dev/null +++ b/gcc/ada/g-crc32.ads @@ -0,0 +1,113 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . C R C 3 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2005, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides 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 new file mode 100644 index 000000000..17b1a9fda --- /dev/null +++ b/gcc/ada/g-ctrl_c.adb @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C T R L _ C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2007, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package 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); + + procedure C_Handler is + begin + Ada_Handler.all; + end C_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 new file mode 100644 index 000000000..b7360866a --- /dev/null +++ b/gcc/ada/g-ctrl_c.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C T R L _ C -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2007, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package 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 new file mode 100644 index 000000000..ac5b93a2b --- /dev/null +++ b/gcc/ada/g-curexc.ads @@ -0,0 +1,114 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides routines for obtaining the current exception +-- information in Ada 83 style. In Ada 83, there was no official method +-- for obtaining exception information, but a number of vendors supplied +-- routines for this purpose, and this package closely approximates the +-- interfaces supplied by DEC Ada 83 and VADS Ada. + +-- The routines in this package are associated with a particular exception +-- handler, and can only be called from within an exception handler. See +-- also the package GNAT.Most_Recent_Exception, which provides access to +-- the most recently raised exception, and is not limited to static calls +-- from an exception handler. + +package GNAT.Current_Exception is + pragma Pure; + + ----------------- + -- Subprograms -- + ----------------- + + -- Note: the lower bound of returned String values is always one + + function Exception_Information return String; + -- Returns the result of calling Ada.Exceptions.Exception_Information + -- with an argument that is the Exception_Occurrence corresponding to + -- the current exception. Returns the null string if called from outside + -- an exception handler. + + function Exception_Message return String; + -- Returns the result of calling Ada.Exceptions.Exception_Message with + -- an argument that is the Exception_Occurrence corresponding to the + -- current exception. Returns the null string if called from outside an + -- exception handler. + + function Exception_Name return String; + -- Returns the result of calling Ada.Exceptions.Exception_Name with + -- an argument that is the Exception_Occurrence corresponding to the + -- current exception. Returns the null string if called from outside + -- an exception handler. + + -- Note: all these functions return useful information only if + -- called statically from within an exception handler, and they + -- return information about the exception corresponding to the + -- handler in which they appear. This is NOT the same as the most + -- recently raised exception. Consider the example: + + -- exception + -- when Constraint_Error => + -- begin + -- ... + -- exception + -- when Tasking_Error => ... + -- end; + -- + -- -- Exception_xxx at this point returns the information about + -- -- the constraint error, not about any exception raised within + -- -- the nested block since it is the static nesting that counts. + + ----------------------------------- + -- Use of Library Level Renaming -- + ----------------------------------- + + -- For greater compatibility with existing legacy software, library + -- level renaming may be used to create a function with a name matching + -- one that is in use. For example, some versions of VADS Ada provided + -- a function called Current_Exception whose semantics was identical to + -- that of GNAT. The following library level renaming declaration: + + -- with GNAT.Current_Exception; + -- function Current_Exception + -- renames GNAT.Current_Exception.Exception_Name; + + -- placed in a file called current_exception.ads and compiled into the + -- application compilation environment, will make the function available + -- in a manner exactly compatible with that in VADS Ada 83. + +private + pragma Import (Intrinsic, Exception_Information); + pragma Import (intrinsic, Exception_Message); + pragma Import (Intrinsic, Exception_Name); + +end GNAT.Current_Exception; diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb new file mode 100644 index 000000000..ef7ce9e3d --- /dev/null +++ b/gcc/ada/g-debpoo.adb @@ -0,0 +1,1724 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . D E B U G _ P O O L 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.Exceptions.Traceback; +with GNAT.IO; use GNAT.IO; + +with System.Address_Image; +with System.Memory; use System.Memory; +with System.Soft_Links; use System.Soft_Links; + +with System.Traceback_Entries; use System.Traceback_Entries; + +with GNAT.HTable; +with GNAT.Traceback; use GNAT.Traceback; + +with Ada.Unchecked_Conversion; + +package body GNAT.Debug_Pools is + + Default_Alignment : constant := Standard'Maximum_Alignment; + -- Alignment used for the memory chunks returned by Allocate. Using this + -- value guarantees that this alignment will be compatible with all types + -- and at the same time makes it easy to find the location of the extra + -- header allocated for each chunk. + + Max_Ignored_Levels : constant Natural := 10; + -- Maximum number of levels that will be ignored in backtraces. This is so + -- that we still have enough significant levels in the tracebacks returned + -- to the user. + -- + -- The value 10 is chosen as being greater than the maximum callgraph + -- in this package. Its actual value is not really relevant, as long as it + -- is high enough to make sure we still have enough frames to return to + -- the user after we have hidden the frames internal to this package. + + --------------------------- + -- Back Trace Hash Table -- + --------------------------- + + -- This package needs to store one set of tracebacks for each allocation + -- point (when was it allocated or deallocated). This would use too much + -- memory, so the tracebacks are actually stored in a hash table, and + -- we reference elements in this hash table instead. + + -- This hash-table will remain empty if the discriminant Stack_Trace_Depth + -- for the pools is set to 0. + + -- This table is a global table, that can be shared among all debug pools + -- with no problems. + + type Header is range 1 .. 1023; + -- Number of elements in the hash-table + + type Tracebacks_Array_Access + is access GNAT.Traceback.Tracebacks_Array; + + type Traceback_Kind is (Alloc, Dealloc, Indirect_Alloc, Indirect_Dealloc); + + type Traceback_Htable_Elem; + type Traceback_Htable_Elem_Ptr + is access Traceback_Htable_Elem; + + type Traceback_Htable_Elem is record + Traceback : Tracebacks_Array_Access; + Kind : Traceback_Kind; + Count : Natural; + Total : Byte_Count; + Next : Traceback_Htable_Elem_Ptr; + end record; + + -- Subprograms used for the Backtrace_Htable instantiation + + procedure Set_Next + (E : Traceback_Htable_Elem_Ptr; + Next : Traceback_Htable_Elem_Ptr); + pragma Inline (Set_Next); + + function Next + (E : Traceback_Htable_Elem_Ptr) return Traceback_Htable_Elem_Ptr; + pragma Inline (Next); + + function Get_Key + (E : Traceback_Htable_Elem_Ptr) return Tracebacks_Array_Access; + pragma Inline (Get_Key); + + function Hash (T : Tracebacks_Array_Access) return Header; + pragma Inline (Hash); + + function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean; + -- Why is this not inlined??? + + -- The hash table for back traces + + package Backtrace_Htable is new GNAT.HTable.Static_HTable + (Header_Num => Header, + Element => Traceback_Htable_Elem, + Elmt_Ptr => Traceback_Htable_Elem_Ptr, + Null_Ptr => null, + Set_Next => Set_Next, + Next => Next, + Key => Tracebacks_Array_Access, + Get_Key => Get_Key, + Hash => Hash, + Equal => Equal); + + ----------------------- + -- Allocations table -- + ----------------------- + + type Allocation_Header; + type Allocation_Header_Access is access Allocation_Header; + + type Traceback_Ptr_Or_Address is new System.Address; + -- A type that acts as a C union, and is either a System.Address or a + -- Traceback_Htable_Elem_Ptr. + + -- The following record stores extra information that needs to be + -- memorized for each block allocated with the special debug pool. + + type Allocation_Header is record + Allocation_Address : System.Address; + -- Address of the block returned by malloc, possibly unaligned + + Block_Size : Storage_Offset; + -- Needed only for advanced freeing algorithms (traverse all allocated + -- blocks for potential references). This value is negated when the + -- chunk of memory has been logically freed by the application. This + -- chunk has not been physically released yet. + + Alloc_Traceback : Traceback_Htable_Elem_Ptr; + -- ??? comment required + + Dealloc_Traceback : Traceback_Ptr_Or_Address; + -- Pointer to the traceback for the allocation (if the memory chunk is + -- still valid), or to the first deallocation otherwise. Make sure this + -- is a thin pointer to save space. + -- + -- Dealloc_Traceback is also for blocks that are still allocated to + -- point to the previous block in the list. This saves space in this + -- header, and make manipulation of the lists of allocated pointers + -- faster. + + Next : System.Address; + -- Point to the next block of the same type (either allocated or + -- logically freed) in memory. This points to the beginning of the user + -- data, and does not include the header of that block. + end record; + + function Header_Of (Address : System.Address) + return Allocation_Header_Access; + pragma Inline (Header_Of); + -- Return the header corresponding to a previously allocated address + + function To_Address is new Ada.Unchecked_Conversion + (Traceback_Ptr_Or_Address, System.Address); + + function To_Address is new Ada.Unchecked_Conversion + (System.Address, Traceback_Ptr_Or_Address); + + function To_Traceback is new Ada.Unchecked_Conversion + (Traceback_Ptr_Or_Address, Traceback_Htable_Elem_Ptr); + + function To_Traceback is new Ada.Unchecked_Conversion + (Traceback_Htable_Elem_Ptr, Traceback_Ptr_Or_Address); + + Header_Offset : constant Storage_Count := + Default_Alignment * + ((Allocation_Header'Size / System.Storage_Unit + + Default_Alignment - 1) / Default_Alignment); + -- Offset of user data after allocation header + + Minimum_Allocation : constant Storage_Count := + Default_Alignment - 1 + Header_Offset; + -- Minimal allocation: size of allocation_header rounded up to next + -- multiple of default alignment + worst-case padding. + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Find_Or_Create_Traceback + (Pool : Debug_Pool; + Kind : Traceback_Kind; + Size : Storage_Count; + Ignored_Frame_Start : System.Address; + Ignored_Frame_End : System.Address) return Traceback_Htable_Elem_Ptr; + -- Return an element matching the current traceback (omitting the frames + -- that are in the current package). If this traceback already existed in + -- the htable, a pointer to this is returned to spare memory. Null is + -- returned if the pool is set not to store tracebacks. If the traceback + -- already existed in the table, the count is incremented so that + -- Dump_Tracebacks returns useful results. All addresses up to, and + -- including, an address between Ignored_Frame_Start .. Ignored_Frame_End + -- are ignored. + + function Output_File (Pool : Debug_Pool) return File_Type; + pragma Inline (Output_File); + -- Returns file_type on which error messages have to be generated for Pool + + procedure Put_Line + (File : File_Type; + Depth : Natural; + Traceback : Tracebacks_Array_Access; + Ignored_Frame_Start : System.Address := System.Null_Address; + Ignored_Frame_End : System.Address := System.Null_Address); + -- Print Traceback to File. If Traceback is null, print the call_chain + -- at the current location, up to Depth levels, ignoring all addresses + -- up to the first one in the range: + -- Ignored_Frame_Start .. Ignored_Frame_End + + package Validity is + function Is_Valid (Storage : System.Address) return Boolean; + pragma Inline (Is_Valid); + -- Return True if Storage is the address of a block that the debug pool + -- has under its control, in which case Header_Of may be used to access + -- the associated allocation header. + + procedure Set_Valid (Storage : System.Address; Value : Boolean); + pragma Inline (Set_Valid); + -- Mark the address Storage as being under control of the memory pool + -- (if Value is True), or not (if Value is False). + end Validity; + + use Validity; + + procedure Set_Dead_Beef + (Storage_Address : System.Address; + Size_In_Storage_Elements : Storage_Count); + -- Set the contents of the memory block pointed to by Storage_Address to + -- the 16#DEADBEEF# pattern. If Size_In_Storage_Elements is not a multiple + -- of the length of this pattern, the last instance may be partial. + + procedure Free_Physically (Pool : in out Debug_Pool); + -- Start to physically release some memory to the system, until the amount + -- of logically (but not physically) freed memory is lower than the + -- expected amount in Pool. + + procedure Allocate_End; + procedure Deallocate_End; + procedure Dereference_End; + -- These procedures are used as markers when computing the stacktraces, + -- so that addresses in the debug pool itself are not reported to the user. + + Code_Address_For_Allocate_End : System.Address; + Code_Address_For_Deallocate_End : System.Address; + Code_Address_For_Dereference_End : System.Address; + -- Taking the address of the above procedures will not work on some + -- architectures (HPUX and VMS for instance). Thus we do the same thing + -- that is done in a-except.adb, and get the address of labels instead + + procedure Skip_Levels + (Depth : Natural; + Trace : Tracebacks_Array; + Start : out Natural; + Len : in out Natural; + Ignored_Frame_Start : System.Address; + Ignored_Frame_End : System.Address); + -- Set Start .. Len to the range of values from Trace that should be output + -- to the user. This range of values excludes any address prior to the + -- first one in Ignored_Frame_Start .. Ignored_Frame_End (basically + -- addresses internal to this package). Depth is the number of levels that + -- the user is interested in. + + --------------- + -- Header_Of -- + --------------- + + function Header_Of (Address : System.Address) + return Allocation_Header_Access + is + function Convert is new Ada.Unchecked_Conversion + (System.Address, Allocation_Header_Access); + begin + return Convert (Address - Header_Offset); + end Header_Of; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next + (E : Traceback_Htable_Elem_Ptr; + Next : Traceback_Htable_Elem_Ptr) + is + begin + E.Next := Next; + end Set_Next; + + ---------- + -- Next -- + ---------- + + function Next + (E : Traceback_Htable_Elem_Ptr) return Traceback_Htable_Elem_Ptr is + begin + return E.Next; + end Next; + + ----------- + -- Equal -- + ----------- + + function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean is + use Ada.Exceptions.Traceback; + begin + return K1.all = K2.all; + end Equal; + + ------------- + -- Get_Key -- + ------------- + + function Get_Key + (E : Traceback_Htable_Elem_Ptr) return Tracebacks_Array_Access + is + begin + return E.Traceback; + end Get_Key; + + ---------- + -- Hash -- + ---------- + + function Hash (T : Tracebacks_Array_Access) return Header is + Result : Integer_Address := 0; + + begin + for X in T'Range loop + Result := Result + To_Integer (PC_For (T (X))); + end loop; + + return Header (1 + Result mod Integer_Address (Header'Last)); + end Hash; + + ----------------- + -- Output_File -- + ----------------- + + function Output_File (Pool : Debug_Pool) return File_Type is + begin + if Pool.Errors_To_Stdout then + return Standard_Output; + else + return Standard_Error; + end if; + end Output_File; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line + (File : File_Type; + Depth : Natural; + Traceback : Tracebacks_Array_Access; + Ignored_Frame_Start : System.Address := System.Null_Address; + Ignored_Frame_End : System.Address := System.Null_Address) + is + procedure Print (Tr : Tracebacks_Array); + -- Print the traceback to standard_output + + ----------- + -- Print -- + ----------- + + procedure Print (Tr : Tracebacks_Array) is + begin + for J in Tr'Range loop + Put (File, "0x" & Address_Image (PC_For (Tr (J))) & ' '); + end loop; + Put (File, ASCII.LF); + end Print; + + -- Start of processing for Put_Line + + begin + if Traceback = null then + declare + Tr : aliased Tracebacks_Array (1 .. Depth + Max_Ignored_Levels); + Start, Len : Natural; + + begin + Call_Chain (Tr, Len); + Skip_Levels (Depth, Tr, Start, Len, + Ignored_Frame_Start, Ignored_Frame_End); + Print (Tr (Start .. Len)); + end; + + else + Print (Traceback.all); + end if; + end Put_Line; + + ----------------- + -- Skip_Levels -- + ----------------- + + procedure Skip_Levels + (Depth : Natural; + Trace : Tracebacks_Array; + Start : out Natural; + Len : in out Natural; + Ignored_Frame_Start : System.Address; + Ignored_Frame_End : System.Address) + is + begin + Start := Trace'First; + + while Start <= Len + and then (PC_For (Trace (Start)) < Ignored_Frame_Start + or else PC_For (Trace (Start)) > Ignored_Frame_End) + loop + Start := Start + 1; + end loop; + + Start := Start + 1; + + -- Just in case: make sure we have a traceback even if Ignore_Till + -- wasn't found. + + if Start > Len then + Start := 1; + end if; + + if Len - Start + 1 > Depth then + Len := Depth + Start - 1; + end if; + end Skip_Levels; + + ------------------------------ + -- Find_Or_Create_Traceback -- + ------------------------------ + + function Find_Or_Create_Traceback + (Pool : Debug_Pool; + Kind : Traceback_Kind; + Size : Storage_Count; + Ignored_Frame_Start : System.Address; + Ignored_Frame_End : System.Address) return Traceback_Htable_Elem_Ptr + is + begin + if Pool.Stack_Trace_Depth = 0 then + return null; + end if; + + declare + Trace : aliased Tracebacks_Array + (1 .. Integer (Pool.Stack_Trace_Depth) + Max_Ignored_Levels); + Len, Start : Natural; + Elem : Traceback_Htable_Elem_Ptr; + + begin + Call_Chain (Trace, Len); + Skip_Levels (Pool.Stack_Trace_Depth, Trace, Start, Len, + Ignored_Frame_Start, Ignored_Frame_End); + + -- Check if the traceback is already in the table + + Elem := + Backtrace_Htable.Get (Trace (Start .. Len)'Unrestricted_Access); + + -- If not, insert it + + if Elem = null then + Elem := new Traceback_Htable_Elem' + (Traceback => new Tracebacks_Array'(Trace (Start .. Len)), + Count => 1, + Kind => Kind, + Total => Byte_Count (Size), + Next => null); + Backtrace_Htable.Set (Elem); + + else + Elem.Count := Elem.Count + 1; + Elem.Total := Elem.Total + Byte_Count (Size); + end if; + + return Elem; + end; + end Find_Or_Create_Traceback; + + -------------- + -- Validity -- + -------------- + + package body Validity is + + -- The validity bits of the allocated blocks are kept in a has table. + -- Each component of the hash table contains the validity bits for a + -- 16 Mbyte memory chunk. + + -- The reason the validity bits are kept for chunks of memory rather + -- than in a big array is that on some 64 bit platforms, it may happen + -- that two chunk of allocated data are very far from each other. + + Memory_Chunk_Size : constant Integer_Address := 2 ** 24; -- 16 MB + Validity_Divisor : constant := Default_Alignment * System.Storage_Unit; + + Max_Validity_Byte_Index : constant := + Memory_Chunk_Size / Validity_Divisor; + + subtype Validity_Byte_Index is Integer_Address + range 0 .. Max_Validity_Byte_Index - 1; + + type Byte is mod 2 ** System.Storage_Unit; + + type Validity_Bits is array (Validity_Byte_Index) of Byte; + + type Validity_Bits_Ref is access all Validity_Bits; + No_Validity_Bits : constant Validity_Bits_Ref := null; + + Max_Header_Num : constant := 1023; + + type Header_Num is range 0 .. Max_Header_Num - 1; + + function Hash (F : Integer_Address) return Header_Num; + + package Validy_Htable is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Validity_Bits_Ref, + No_Element => No_Validity_Bits, + Key => Integer_Address, + Hash => Hash, + Equal => "="); + -- Table to keep the validity bit blocks for the allocated data + + function To_Pointer is new Ada.Unchecked_Conversion + (System.Address, Validity_Bits_Ref); + + procedure Memset (A : Address; C : Integer; N : size_t); + pragma Import (C, Memset, "memset"); + + ---------- + -- Hash -- + ---------- + + function Hash (F : Integer_Address) return Header_Num is + begin + return Header_Num (F mod Max_Header_Num); + end Hash; + + -------------- + -- Is_Valid -- + -------------- + + function Is_Valid (Storage : System.Address) return Boolean is + Int_Storage : constant Integer_Address := To_Integer (Storage); + + begin + -- The pool only returns addresses aligned on Default_Alignment so + -- anything off cannot be a valid block address and we can return + -- early in this case. We actually have to since our data structures + -- map validity bits for such aligned addresses only. + + if Int_Storage mod Default_Alignment /= 0 then + return False; + end if; + + declare + Block_Number : constant Integer_Address := + Int_Storage / Memory_Chunk_Size; + Ptr : constant Validity_Bits_Ref := + Validy_Htable.Get (Block_Number); + Offset : constant Integer_Address := + (Int_Storage - + (Block_Number * Memory_Chunk_Size)) / + Default_Alignment; + Bit : constant Byte := + 2 ** Natural (Offset mod System.Storage_Unit); + begin + if Ptr = No_Validity_Bits then + return False; + else + return (Ptr (Offset / System.Storage_Unit) and Bit) /= 0; + end if; + end; + end Is_Valid; + + --------------- + -- Set_Valid -- + --------------- + + procedure Set_Valid (Storage : System.Address; Value : Boolean) is + Int_Storage : constant Integer_Address := To_Integer (Storage); + Block_Number : constant Integer_Address := + Int_Storage / Memory_Chunk_Size; + Ptr : Validity_Bits_Ref := Validy_Htable.Get (Block_Number); + Offset : constant Integer_Address := + (Int_Storage - (Block_Number * Memory_Chunk_Size)) / + Default_Alignment; + Bit : constant Byte := + 2 ** Natural (Offset mod System.Storage_Unit); + + begin + if Ptr = No_Validity_Bits then + + -- First time in this memory area: allocate a new block and put + -- it in the table. + + if Value then + Ptr := To_Pointer (Alloc (size_t (Max_Validity_Byte_Index))); + Validy_Htable.Set (Block_Number, Ptr); + Memset (Ptr.all'Address, 0, size_t (Max_Validity_Byte_Index)); + Ptr (Offset / System.Storage_Unit) := Bit; + end if; + + else + if Value then + Ptr (Offset / System.Storage_Unit) := + Ptr (Offset / System.Storage_Unit) or Bit; + + else + Ptr (Offset / System.Storage_Unit) := + Ptr (Offset / System.Storage_Unit) and (not Bit); + end if; + end if; + end Set_Valid; + + end Validity; + + -------------- + -- Allocate -- + -------------- + + procedure Allocate + (Pool : in out Debug_Pool; + Storage_Address : out Address; + Size_In_Storage_Elements : Storage_Count; + Alignment : Storage_Count) + is + pragma Unreferenced (Alignment); + -- Ignored, we always force 'Default_Alignment + + type Local_Storage_Array is new Storage_Array + (1 .. Size_In_Storage_Elements + Minimum_Allocation); + + type Ptr is access Local_Storage_Array; + -- On some systems, we might want to physically protect pages against + -- writing when they have been freed (of course, this is expensive in + -- terms of wasted memory). To do that, all we should have to do it to + -- set the size of this array to the page size. See mprotect(). + + P : Ptr; + + Current : Byte_Count; + Trace : Traceback_Htable_Elem_Ptr; + + begin + <> + Lock_Task.all; + + -- If necessary, start physically releasing memory. The reason this is + -- done here, although Pool.Logically_Deallocated has not changed above, + -- is so that we do this only after a series of deallocations (e.g loop + -- that deallocates a big array). If we were doing that in Deallocate, + -- we might be physically freeing memory several times during the loop, + -- which is expensive. + + if Pool.Logically_Deallocated > + Byte_Count (Pool.Maximum_Logically_Freed_Memory) + then + Free_Physically (Pool); + end if; + + -- Use standard (i.e. through malloc) allocations. This automatically + -- raises Storage_Error if needed. We also try once more to physically + -- release memory, so that even marked blocks, in the advanced scanning, + -- are freed. + + begin + P := new Local_Storage_Array; + + exception + when Storage_Error => + Free_Physically (Pool); + P := new Local_Storage_Array; + end; + + Storage_Address := + To_Address + (Default_Alignment * + ((To_Integer (P.all'Address) + Default_Alignment - 1) + / Default_Alignment) + + Integer_Address (Header_Offset)); + -- Computation is done in Integer_Address, not Storage_Offset, because + -- the range of Storage_Offset may not be large enough. + + pragma Assert ((Storage_Address - System.Null_Address) + mod Default_Alignment = 0); + pragma Assert (Storage_Address + Size_In_Storage_Elements + <= P.all'Address + P'Length); + + Trace := Find_Or_Create_Traceback + (Pool, Alloc, Size_In_Storage_Elements, + Allocate_Label'Address, Code_Address_For_Allocate_End); + + pragma Warnings (Off); + -- Turn warning on alignment for convert call off. We know that in fact + -- this conversion is safe since P itself is always aligned on + -- Default_Alignment. + + Header_Of (Storage_Address).all := + (Allocation_Address => P.all'Address, + Alloc_Traceback => Trace, + Dealloc_Traceback => To_Traceback (null), + Next => Pool.First_Used_Block, + Block_Size => Size_In_Storage_Elements); + + pragma Warnings (On); + + -- Link this block in the list of used blocks. This will be used to list + -- memory leaks in Print_Info, and for the advanced schemes of + -- Physical_Free, where we want to traverse all allocated blocks and + -- search for possible references. + + -- We insert in front, since most likely we'll be freeing the most + -- recently allocated blocks first (the older one might stay allocated + -- for the whole life of the application). + + if Pool.First_Used_Block /= System.Null_Address then + Header_Of (Pool.First_Used_Block).Dealloc_Traceback := + To_Address (Storage_Address); + end if; + + Pool.First_Used_Block := Storage_Address; + + -- Mark the new address as valid + + Set_Valid (Storage_Address, True); + + if Pool.Low_Level_Traces then + Put (Output_File (Pool), + "info: Allocated" + & Storage_Count'Image (Size_In_Storage_Elements) + & " bytes at 0x" & Address_Image (Storage_Address) + & " (physically:" + & Storage_Count'Image (Local_Storage_Array'Length) + & " bytes at 0x" & Address_Image (P.all'Address) + & "), at "); + Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, + Allocate_Label'Address, + Code_Address_For_Deallocate_End); + end if; + + -- Update internal data + + Pool.Allocated := + Pool.Allocated + Byte_Count (Size_In_Storage_Elements); + + Current := Pool.Allocated - + Pool.Logically_Deallocated - + Pool.Physically_Deallocated; + + if Current > Pool.High_Water then + Pool.High_Water := Current; + end if; + + Unlock_Task.all; + + exception + when others => + Unlock_Task.all; + raise; + end Allocate; + + ------------------ + -- Allocate_End -- + ------------------ + + -- DO NOT MOVE, this must be right after Allocate. This is similar to what + -- is done in a-except, so that we can hide the traceback frames internal + -- to this package + + procedure Allocate_End is + begin + <> + Code_Address_For_Allocate_End := Allocate_End_Label'Address; + end Allocate_End; + + ------------------- + -- Set_Dead_Beef -- + ------------------- + + procedure Set_Dead_Beef + (Storage_Address : System.Address; + Size_In_Storage_Elements : Storage_Count) + is + Dead_Bytes : constant := 4; + + type Data is mod 2 ** (Dead_Bytes * 8); + for Data'Size use Dead_Bytes * 8; + + Dead : constant Data := 16#DEAD_BEEF#; + + type Dead_Memory is array + (1 .. Size_In_Storage_Elements / Dead_Bytes) of Data; + type Mem_Ptr is access Dead_Memory; + + type Byte is mod 2 ** 8; + for Byte'Size use 8; + + type Dead_Memory_Bytes is array (0 .. 2) of Byte; + type Dead_Memory_Bytes_Ptr is access Dead_Memory_Bytes; + + function From_Ptr is new Ada.Unchecked_Conversion + (System.Address, Mem_Ptr); + + function From_Ptr is new Ada.Unchecked_Conversion + (System.Address, Dead_Memory_Bytes_Ptr); + + M : constant Mem_Ptr := From_Ptr (Storage_Address); + M2 : Dead_Memory_Bytes_Ptr; + Modulo : constant Storage_Count := + Size_In_Storage_Elements mod Dead_Bytes; + begin + M.all := (others => Dead); + + -- Any bytes left (up to three of them) + + if Modulo /= 0 then + M2 := From_Ptr (Storage_Address + M'Length * Dead_Bytes); + + M2 (0) := 16#DE#; + if Modulo >= 2 then + M2 (1) := 16#AD#; + + if Modulo >= 3 then + M2 (2) := 16#BE#; + end if; + end if; + end if; + end Set_Dead_Beef; + + --------------------- + -- Free_Physically -- + --------------------- + + procedure Free_Physically (Pool : in out Debug_Pool) is + type Byte is mod 256; + type Byte_Access is access Byte; + + function To_Byte is new Ada.Unchecked_Conversion + (System.Address, Byte_Access); + + type Address_Access is access System.Address; + + function To_Address_Access is new Ada.Unchecked_Conversion + (System.Address, Address_Access); + + In_Use_Mark : constant Byte := 16#D#; + Free_Mark : constant Byte := 16#F#; + + Total_Freed : Storage_Count := 0; + + procedure Reset_Marks; + -- Unmark all the logically freed blocks, so that they are considered + -- for physical deallocation + + procedure Mark + (H : Allocation_Header_Access; A : System.Address; In_Use : Boolean); + -- Mark the user data block starting at A. For a block of size zero, + -- nothing is done. For a block with a different size, the first byte + -- is set to either "D" (in use) or "F" (free). + + function Marked (A : System.Address) return Boolean; + -- Return true if the user data block starting at A might be in use + -- somewhere else + + procedure Mark_Blocks; + -- Traverse all allocated blocks, and search for possible references + -- to logically freed blocks. Mark them appropriately + + procedure Free_Blocks (Ignore_Marks : Boolean); + -- Physically release blocks. Only the blocks that haven't been marked + -- will be released, unless Ignore_Marks is true. + + ----------------- + -- Free_Blocks -- + ----------------- + + procedure Free_Blocks (Ignore_Marks : Boolean) is + Header : Allocation_Header_Access; + Tmp : System.Address := Pool.First_Free_Block; + Next : System.Address; + Previous : System.Address := System.Null_Address; + + begin + while Tmp /= System.Null_Address + and then Total_Freed < Pool.Minimum_To_Free + loop + Header := Header_Of (Tmp); + + -- If we know, or at least assume, the block is no longer + -- referenced anywhere, we can free it physically. + + if Ignore_Marks or else not Marked (Tmp) then + + declare + pragma Suppress (All_Checks); + -- Suppress the checks on this section. If they are overflow + -- errors, it isn't critical, and we'd rather avoid a + -- Constraint_Error in that case. + begin + -- Note that block_size < zero for freed blocks + + Pool.Physically_Deallocated := + Pool.Physically_Deallocated - + Byte_Count (Header.Block_Size); + + Pool.Logically_Deallocated := + Pool.Logically_Deallocated + + Byte_Count (Header.Block_Size); + + Total_Freed := Total_Freed - Header.Block_Size; + end; + + Next := Header.Next; + + if Pool.Low_Level_Traces then + Put_Line + (Output_File (Pool), + "info: Freeing physical memory " + & Storage_Count'Image + ((abs Header.Block_Size) + Minimum_Allocation) + & " bytes at 0x" + & Address_Image (Header.Allocation_Address)); + end if; + + System.Memory.Free (Header.Allocation_Address); + Set_Valid (Tmp, False); + + -- Remove this block from the list + + if Previous = System.Null_Address then + Pool.First_Free_Block := Next; + else + Header_Of (Previous).Next := Next; + end if; + + Tmp := Next; + + else + Previous := Tmp; + Tmp := Header.Next; + end if; + end loop; + end Free_Blocks; + + ---------- + -- Mark -- + ---------- + + procedure Mark + (H : Allocation_Header_Access; + A : System.Address; + In_Use : Boolean) + is + begin + if H.Block_Size /= 0 then + To_Byte (A).all := (if In_Use then In_Use_Mark else Free_Mark); + end if; + end Mark; + + ----------------- + -- Mark_Blocks -- + ----------------- + + procedure Mark_Blocks is + Tmp : System.Address := Pool.First_Used_Block; + Previous : System.Address; + Last : System.Address; + Pointed : System.Address; + Header : Allocation_Header_Access; + + begin + -- For each allocated block, check its contents. Things that look + -- like a possible address are used to mark the blocks so that we try + -- and keep them, for better detection in case of invalid access. + -- This mechanism is far from being fool-proof: it doesn't check the + -- stacks of the threads, doesn't check possible memory allocated not + -- under control of this debug pool. But it should allow us to catch + -- more cases. + + while Tmp /= System.Null_Address loop + Previous := Tmp; + Last := Tmp + Header_Of (Tmp).Block_Size; + while Previous < Last loop + -- ??? Should we move byte-per-byte, or consider that addresses + -- are always aligned on 4-bytes boundaries ? Let's use the + -- fastest for now. + + Pointed := To_Address_Access (Previous).all; + if Is_Valid (Pointed) then + Header := Header_Of (Pointed); + + -- Do not even attempt to mark blocks in use. That would + -- screw up the whole application, of course. + + if Header.Block_Size < 0 then + Mark (Header, Pointed, In_Use => True); + end if; + end if; + + Previous := Previous + System.Address'Size; + end loop; + + Tmp := Header_Of (Tmp).Next; + end loop; + end Mark_Blocks; + + ------------ + -- Marked -- + ------------ + + function Marked (A : System.Address) return Boolean is + begin + return To_Byte (A).all = In_Use_Mark; + end Marked; + + ----------------- + -- Reset_Marks -- + ----------------- + + procedure Reset_Marks is + Current : System.Address := Pool.First_Free_Block; + Header : Allocation_Header_Access; + begin + while Current /= System.Null_Address loop + Header := Header_Of (Current); + Mark (Header, Current, False); + Current := Header.Next; + end loop; + end Reset_Marks; + + -- Start of processing for Free_Physically + + begin + Lock_Task.all; + + if Pool.Advanced_Scanning then + + -- Reset the mark for each freed block + + Reset_Marks; + + Mark_Blocks; + end if; + + Free_Blocks (Ignore_Marks => not Pool.Advanced_Scanning); + + -- The contract is that we need to free at least Minimum_To_Free bytes, + -- even if this means freeing marked blocks in the advanced scheme + + if Total_Freed < Pool.Minimum_To_Free + and then Pool.Advanced_Scanning + then + Pool.Marked_Blocks_Deallocated := True; + Free_Blocks (Ignore_Marks => True); + end if; + + Unlock_Task.all; + + exception + when others => + Unlock_Task.all; + raise; + end Free_Physically; + + ---------------- + -- Deallocate -- + ---------------- + + procedure Deallocate + (Pool : in out Debug_Pool; + Storage_Address : Address; + Size_In_Storage_Elements : Storage_Count; + Alignment : Storage_Count) + is + pragma Unreferenced (Alignment); + + Header : constant Allocation_Header_Access := + Header_Of (Storage_Address); + Valid : Boolean; + Previous : System.Address; + + begin + <> + Lock_Task.all; + Valid := Is_Valid (Storage_Address); + + if not Valid then + Unlock_Task.all; + if Pool.Raise_Exceptions then + raise Freeing_Not_Allocated_Storage; + else + Put (Output_File (Pool), + "error: Freeing not allocated storage, at "); + Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, + Deallocate_Label'Address, + Code_Address_For_Deallocate_End); + end if; + + elsif Header.Block_Size < 0 then + Unlock_Task.all; + if Pool.Raise_Exceptions then + raise Freeing_Deallocated_Storage; + else + Put (Output_File (Pool), + "error: Freeing already deallocated storage, at "); + Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, + Deallocate_Label'Address, + Code_Address_For_Deallocate_End); + Put (Output_File (Pool), " Memory already deallocated at "); + Put_Line + (Output_File (Pool), 0, + To_Traceback (Header.Dealloc_Traceback).Traceback); + Put (Output_File (Pool), " Memory was allocated at "); + Put_Line (Output_File (Pool), 0, Header.Alloc_Traceback.Traceback); + end if; + + else + -- Some sort of codegen problem or heap corruption caused the + -- Size_In_Storage_Elements to be wrongly computed. + -- The code below is all based on the assumption that Header.all + -- is not corrupted, such that the error is non-fatal. + + if Header.Block_Size /= Size_In_Storage_Elements then + Put_Line (Output_File (Pool), + "error: Deallocate size " + & Storage_Count'Image (Size_In_Storage_Elements) + & " does not match allocate size " + & Storage_Count'Image (Header.Block_Size)); + end if; + + if Pool.Low_Level_Traces then + Put (Output_File (Pool), + "info: Deallocated" + & Storage_Count'Image (Size_In_Storage_Elements) + & " bytes at 0x" & Address_Image (Storage_Address) + & " (physically" + & Storage_Count'Image (Header.Block_Size + Minimum_Allocation) + & " bytes at 0x" & Address_Image (Header.Allocation_Address) + & "), at "); + Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, + Deallocate_Label'Address, + Code_Address_For_Deallocate_End); + Put (Output_File (Pool), " Memory was allocated at "); + Put_Line (Output_File (Pool), 0, Header.Alloc_Traceback.Traceback); + end if; + + -- Remove this block from the list of used blocks + + Previous := + To_Address (Header.Dealloc_Traceback); + + if Previous = System.Null_Address then + Pool.First_Used_Block := Header_Of (Pool.First_Used_Block).Next; + + if Pool.First_Used_Block /= System.Null_Address then + Header_Of (Pool.First_Used_Block).Dealloc_Traceback := + To_Traceback (null); + end if; + + else + Header_Of (Previous).Next := Header.Next; + + if Header.Next /= System.Null_Address then + Header_Of + (Header.Next).Dealloc_Traceback := To_Address (Previous); + end if; + end if; + + -- Update the header + + Header.all := + (Allocation_Address => Header.Allocation_Address, + Alloc_Traceback => Header.Alloc_Traceback, + Dealloc_Traceback => To_Traceback + (Find_Or_Create_Traceback + (Pool, Dealloc, + Size_In_Storage_Elements, + Deallocate_Label'Address, + Code_Address_For_Deallocate_End)), + Next => System.Null_Address, + Block_Size => -Header.Block_Size); + + if Pool.Reset_Content_On_Free then + Set_Dead_Beef (Storage_Address, -Header.Block_Size); + end if; + + Pool.Logically_Deallocated := + Pool.Logically_Deallocated + Byte_Count (-Header.Block_Size); + + -- Link this free block with the others (at the end of the list, so + -- that we can start releasing the older blocks first later on). + + if Pool.First_Free_Block = System.Null_Address then + Pool.First_Free_Block := Storage_Address; + Pool.Last_Free_Block := Storage_Address; + + else + Header_Of (Pool.Last_Free_Block).Next := Storage_Address; + Pool.Last_Free_Block := Storage_Address; + end if; + + -- Do not physically release the memory here, but in Alloc. + -- See comment there for details. + + Unlock_Task.all; + end if; + + exception + when others => + Unlock_Task.all; + raise; + end Deallocate; + + -------------------- + -- Deallocate_End -- + -------------------- + + -- DO NOT MOVE, this must be right after Deallocate + + -- See Allocate_End + + -- This is making assumptions about code order that may be invalid ??? + + procedure Deallocate_End is + begin + <> + Code_Address_For_Deallocate_End := Deallocate_End_Label'Address; + end Deallocate_End; + + ----------------- + -- Dereference -- + ----------------- + + procedure Dereference + (Pool : in out Debug_Pool; + Storage_Address : Address; + Size_In_Storage_Elements : Storage_Count; + Alignment : Storage_Count) + is + pragma Unreferenced (Alignment, Size_In_Storage_Elements); + + Valid : constant Boolean := Is_Valid (Storage_Address); + Header : Allocation_Header_Access; + + begin + -- Locking policy: we do not do any locking in this procedure. The + -- tables are only read, not written to, and although a problem might + -- appear if someone else is modifying the tables at the same time, this + -- race condition is not intended to be detected by this storage_pool (a + -- now invalid pointer would appear as valid). Instead, we prefer + -- optimum performance for dereferences. + + <> + + if not Valid then + if Pool.Raise_Exceptions then + raise Accessing_Not_Allocated_Storage; + else + Put (Output_File (Pool), + "error: Accessing not allocated storage, at "); + Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, + Dereference_Label'Address, + Code_Address_For_Dereference_End); + end if; + + else + Header := Header_Of (Storage_Address); + + if Header.Block_Size < 0 then + if Pool.Raise_Exceptions then + raise Accessing_Deallocated_Storage; + else + Put (Output_File (Pool), + "error: Accessing deallocated storage, at "); + Put_Line + (Output_File (Pool), Pool.Stack_Trace_Depth, null, + Dereference_Label'Address, + Code_Address_For_Dereference_End); + Put (Output_File (Pool), " First deallocation at "); + Put_Line + (Output_File (Pool), + 0, To_Traceback (Header.Dealloc_Traceback).Traceback); + Put (Output_File (Pool), " Initial allocation at "); + Put_Line + (Output_File (Pool), + 0, Header.Alloc_Traceback.Traceback); + end if; + end if; + end if; + end Dereference; + + --------------------- + -- Dereference_End -- + --------------------- + + -- DO NOT MOVE: this must be right after Dereference + + -- See Allocate_End + + -- This is making assumptions about code order that may be invalid ??? + + procedure Dereference_End is + begin + <> + Code_Address_For_Dereference_End := Dereference_End_Label'Address; + end Dereference_End; + + ---------------- + -- Print_Info -- + ---------------- + + procedure Print_Info + (Pool : Debug_Pool; + Cumulate : Boolean := False; + Display_Slots : Boolean := False; + Display_Leaks : Boolean := False) + is + + package Backtrace_Htable_Cumulate is new GNAT.HTable.Static_HTable + (Header_Num => Header, + Element => Traceback_Htable_Elem, + Elmt_Ptr => Traceback_Htable_Elem_Ptr, + Null_Ptr => null, + Set_Next => Set_Next, + Next => Next, + Key => Tracebacks_Array_Access, + Get_Key => Get_Key, + Hash => Hash, + Equal => Equal); + -- This needs a comment ??? probably some of the ones below do too??? + + Data : Traceback_Htable_Elem_Ptr; + Elem : Traceback_Htable_Elem_Ptr; + Current : System.Address; + Header : Allocation_Header_Access; + K : Traceback_Kind; + + begin + Put_Line + ("Total allocated bytes : " & + Byte_Count'Image (Pool.Allocated)); + + Put_Line + ("Total logically deallocated bytes : " & + Byte_Count'Image (Pool.Logically_Deallocated)); + + Put_Line + ("Total physically deallocated bytes : " & + Byte_Count'Image (Pool.Physically_Deallocated)); + + if Pool.Marked_Blocks_Deallocated then + Put_Line ("Marked blocks were physically deallocated. This is"); + Put_Line ("potentially dangerous, and you might want to run"); + Put_Line ("again with a lower value of Minimum_To_Free"); + end if; + + Put_Line + ("Current Water Mark: " & + Byte_Count'Image + (Pool.Allocated - Pool.Logically_Deallocated + - Pool.Physically_Deallocated)); + + Put_Line + ("High Water Mark: " & + Byte_Count'Image (Pool.High_Water)); + + Put_Line (""); + + if Display_Slots then + Data := Backtrace_Htable.Get_First; + while Data /= null loop + if Data.Kind in Alloc .. Dealloc then + Elem := + new Traceback_Htable_Elem' + (Traceback => new Tracebacks_Array'(Data.Traceback.all), + Count => Data.Count, + Kind => Data.Kind, + Total => Data.Total, + Next => null); + Backtrace_Htable_Cumulate.Set (Elem); + + if Cumulate then + K := (if Data.Kind = Alloc then Indirect_Alloc + else Indirect_Dealloc); + + -- Propagate the direct call to all its parents + + for T in Data.Traceback'First + 1 .. Data.Traceback'Last loop + Elem := Backtrace_Htable_Cumulate.Get + (Data.Traceback + (T .. Data.Traceback'Last)'Unrestricted_Access); + + -- If not, insert it + + if Elem = null then + Elem := new Traceback_Htable_Elem' + (Traceback => new Tracebacks_Array' + (Data.Traceback (T .. Data.Traceback'Last)), + Count => Data.Count, + Kind => K, + Total => Data.Total, + Next => null); + Backtrace_Htable_Cumulate.Set (Elem); + + -- Properly take into account that the subprograms + -- indirectly called might be doing either allocations + -- or deallocations. This needs to be reflected in the + -- counts. + + else + Elem.Count := Elem.Count + Data.Count; + + if K = Elem.Kind then + Elem.Total := Elem.Total + Data.Total; + + elsif Elem.Total > Data.Total then + Elem.Total := Elem.Total - Data.Total; + + else + Elem.Kind := K; + Elem.Total := Data.Total - Elem.Total; + end if; + end if; + end loop; + end if; + + Data := Backtrace_Htable.Get_Next; + end if; + end loop; + + Put_Line ("List of allocations/deallocations: "); + + Data := Backtrace_Htable_Cumulate.Get_First; + while Data /= null loop + case Data.Kind is + when Alloc => Put ("alloc (count:"); + when Indirect_Alloc => Put ("indirect alloc (count:"); + when Dealloc => Put ("free (count:"); + when Indirect_Dealloc => Put ("indirect free (count:"); + end case; + + Put (Natural'Image (Data.Count) & ", total:" & + Byte_Count'Image (Data.Total) & ") "); + + for T in Data.Traceback'Range loop + Put ("0x" & Address_Image (PC_For (Data.Traceback (T))) & ' '); + end loop; + + Put_Line (""); + + Data := Backtrace_Htable_Cumulate.Get_Next; + end loop; + + Backtrace_Htable_Cumulate.Reset; + end if; + + if Display_Leaks then + Put_Line (""); + Put_Line ("List of not deallocated blocks:"); + + -- Do not try to group the blocks with the same stack traces + -- together. This is done by the gnatmem output. + + Current := Pool.First_Used_Block; + while Current /= System.Null_Address loop + Header := Header_Of (Current); + + Put ("Size: " & Storage_Count'Image (Header.Block_Size) & " at: "); + + for T in Header.Alloc_Traceback.Traceback'Range loop + Put ("0x" & Address_Image + (PC_For (Header.Alloc_Traceback.Traceback (T))) & ' '); + end loop; + + Put_Line (""); + Current := Header.Next; + end loop; + end if; + end Print_Info; + + ------------------ + -- Storage_Size -- + ------------------ + + function Storage_Size (Pool : Debug_Pool) return Storage_Count is + pragma Unreferenced (Pool); + begin + return Storage_Count'Last; + end Storage_Size; + + --------------- + -- Configure -- + --------------- + + procedure Configure + (Pool : in out Debug_Pool; + Stack_Trace_Depth : Natural := Default_Stack_Trace_Depth; + Maximum_Logically_Freed_Memory : SSC := Default_Max_Freed; + Minimum_To_Free : SSC := Default_Min_Freed; + Reset_Content_On_Free : Boolean := Default_Reset_Content; + Raise_Exceptions : Boolean := Default_Raise_Exceptions; + Advanced_Scanning : Boolean := Default_Advanced_Scanning; + Errors_To_Stdout : Boolean := Default_Errors_To_Stdout; + Low_Level_Traces : Boolean := Default_Low_Level_Traces) + is + begin + Pool.Stack_Trace_Depth := Stack_Trace_Depth; + Pool.Maximum_Logically_Freed_Memory := Maximum_Logically_Freed_Memory; + Pool.Reset_Content_On_Free := Reset_Content_On_Free; + Pool.Raise_Exceptions := Raise_Exceptions; + Pool.Minimum_To_Free := Minimum_To_Free; + Pool.Advanced_Scanning := Advanced_Scanning; + Pool.Errors_To_Stdout := Errors_To_Stdout; + Pool.Low_Level_Traces := Low_Level_Traces; + end Configure; + + ---------------- + -- Print_Pool -- + ---------------- + + procedure Print_Pool (A : System.Address) is + Storage : constant Address := A; + Valid : constant Boolean := Is_Valid (Storage); + Header : Allocation_Header_Access; + + begin + -- We might get Null_Address if the call from gdb was done + -- incorrectly. For instance, doing a "print_pool(my_var)" passes 0x0, + -- instead of passing the value of my_var + + if A = System.Null_Address then + Put_Line + (Standard_Output, "Memory not under control of the storage pool"); + return; + end if; + + if not Valid then + Put_Line + (Standard_Output, "Memory not under control of the storage pool"); + + else + Header := Header_Of (Storage); + Put_Line (Standard_Output, "0x" & Address_Image (A) + & " allocated at:"); + Put_Line (Standard_Output, 0, Header.Alloc_Traceback.Traceback); + + if To_Traceback (Header.Dealloc_Traceback) /= null then + Put_Line (Standard_Output, "0x" & Address_Image (A) + & " logically freed memory, deallocated at:"); + Put_Line + (Standard_Output, 0, + To_Traceback (Header.Dealloc_Traceback).Traceback); + end if; + end if; + end Print_Pool; + + ----------------------- + -- Print_Info_Stdout -- + ----------------------- + + procedure Print_Info_Stdout + (Pool : Debug_Pool; + Cumulate : Boolean := False; + Display_Slots : Boolean := False; + Display_Leaks : Boolean := False) + is + procedure Stdout_Put (S : String); + procedure Stdout_Put_Line (S : String); + -- Wrappers for Put and Put_Line that ensure we always write to stdout + -- instead of the current output file defined in GNAT.IO. + + procedure Internal is new Print_Info + (Put_Line => Stdout_Put_Line, + Put => Stdout_Put); + + ---------------- + -- Stdout_Put -- + ---------------- + + procedure Stdout_Put (S : String) is + begin + Put_Line (Standard_Output, S); + end Stdout_Put; + + --------------------- + -- Stdout_Put_Line -- + --------------------- + + procedure Stdout_Put_Line (S : String) is + begin + Put_Line (Standard_Output, S); + end Stdout_Put_Line; + + -- Start of processing for Print_Info_Stdout + + begin + Internal (Pool, Cumulate, Display_Slots, Display_Leaks); + end Print_Info_Stdout; + + ------------------ + -- Dump_Gnatmem -- + ------------------ + + procedure Dump_Gnatmem (Pool : Debug_Pool; File_Name : String) is + type File_Ptr is new System.Address; + + function fopen (Path : String; Mode : String) return File_Ptr; + pragma Import (C, fopen); + + procedure fwrite + (Ptr : System.Address; + Size : size_t; + Nmemb : size_t; + Stream : File_Ptr); + + procedure fwrite + (Str : String; + Size : size_t; + Nmemb : size_t; + Stream : File_Ptr); + pragma Import (C, fwrite); + + procedure fputc (C : Integer; Stream : File_Ptr); + pragma Import (C, fputc); + + procedure fclose (Stream : File_Ptr); + pragma Import (C, fclose); + + Address_Size : constant size_t := + System.Address'Max_Size_In_Storage_Elements; + -- Size in bytes of a pointer + + File : File_Ptr; + Current : System.Address; + Header : Allocation_Header_Access; + Actual_Size : size_t; + Num_Calls : Integer; + Tracebk : Tracebacks_Array_Access; + Dummy_Time : Duration := 1.0; + + begin + File := fopen (File_Name & ASCII.NUL, "wb" & ASCII.NUL); + fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, File); + fwrite (Dummy_Time'Address, Duration'Max_Size_In_Storage_Elements, 1, + File); + + -- List of not deallocated blocks (see Print_Info) + + Current := Pool.First_Used_Block; + while Current /= System.Null_Address loop + Header := Header_Of (Current); + + Actual_Size := size_t (Header.Block_Size); + Tracebk := Header.Alloc_Traceback.Traceback; + Num_Calls := Tracebk'Length; + + -- (Code taken from memtrack.adb in GNAT's sources) + + -- Logs allocation call using the format: + + -- 'A' ... + + fputc (Character'Pos ('A'), File); + fwrite (Current'Address, Address_Size, 1, File); + fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, 1, + File); + fwrite (Dummy_Time'Address, Duration'Max_Size_In_Storage_Elements, 1, + File); + fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1, + File); + + for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop + declare + Ptr : System.Address := PC_For (Tracebk (J)); + begin + fwrite (Ptr'Address, Address_Size, 1, File); + end; + end loop; + + Current := Header.Next; + end loop; + + fclose (File); + end Dump_Gnatmem; + +-- Package initialization + +begin + Allocate_End; + Deallocate_End; + Dereference_End; +end GNAT.Debug_Pools; diff --git a/gcc/ada/g-debpoo.ads b/gcc/ada/g-debpoo.ads new file mode 100644 index 000000000..7e610c240 --- /dev/null +++ b/gcc/ada/g-debpoo.ads @@ -0,0 +1,341 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . D E B U G _ P O O L 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 packages provides a special implementation of the Ada95 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. + +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 Byte_Count is mod System.Max_Binary_Modulus; + -- Type used for maintaining byte counts, needs to be large enough + -- to accommodate counts allowing for repeated use of the same memory. + + 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; + + 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 new file mode 100644 index 000000000..20731fb0c --- /dev/null +++ b/gcc/ada/g-debuti.adb @@ -0,0 +1,190 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +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 new file mode 100644 index 000000000..07932f266 --- /dev/null +++ b/gcc/ada/g-debuti.ads @@ -0,0 +1,83 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2005, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 new file mode 100755 index 000000000..e7c8a2612 --- /dev/null +++ b/gcc/ada/g-decstr.adb @@ -0,0 +1,972 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a 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; + 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; + 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; + + 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; + + 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 + begin + if Ptr < Input'First 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) and returns code in U as + -- Unsigned_32 value. On return Ptr is bumped past the character. + + procedure Skip_UTF_Byte; + pragma Inline (Skip_UTF_Byte); + -- Skips past one encoded byte which must be 2#10xxxxxx# + + ---------- + -- Getc -- + ---------- + + procedure Getc is + begin + if Ptr > Input'Last then + Past_End; + else + U := Unsigned_32 (Character'Pos (Input (Ptr))); + Ptr := Ptr + 1; + end if; + end Getc; + + ------------------- + -- Skip_UTF_Byte -- + ------------------- + + procedure Skip_UTF_Byte is + begin + Getc; + + if (U and 2#11000000#) /= 2#10_000000# then + 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 + + elsif (U and 2#11100000#) = 2#110_00000# then + Skip_UTF_Byte; + + -- 16#00_0800#-16#00_ffff#: 1110xxxx 10xxxxxx 10xxxxxx + + elsif (U and 2#11110000#) = 2#1110_0000# then + Skip_UTF_Byte; + Skip_UTF_Byte; + + -- 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 UTF8; + + -- Non-UTF-8 case + + else + declare + Discard : Wide_Character; + begin + Decode_Wide_Character (Input, Ptr, Discard); + end; + end if; + end Next_Wide_Character; + + ------------------------------ + -- Next_Wide_Wide_Character -- + ------------------------------ + + procedure Next_Wide_Wide_Character (Input : String; Ptr : in out Natural) is + begin + -- 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) and returns code in U as + -- Unsigned_32 value. On return Ptr is bumped past the character. + + procedure Skip_UTF_Byte; + pragma Inline (Skip_UTF_Byte); + -- Skips past one encoded byte which must be 2#10xxxxxx# + + ---------- + -- Getc -- + ---------- + + procedure Getc is + begin + if Ptr > Input'Last then + Past_End; + else + U := Unsigned_32 (Character'Pos (Input (Ptr))); + Ptr := Ptr + 1; + end if; + end Getc; + + ------------------- + -- Skip_UTF_Byte -- + ------------------- + + procedure Skip_UTF_Byte is + begin + Getc; + + if (U and 2#11000000#) /= 2#10_000000# then + Bad; + end if; + end Skip_UTF_Byte; + + -- Start of processing for UTF-8 case + + begin + if Ptr < Input'First then + Past_End; + end if; + + -- 16#00_0000#-16#00_007F#: 0xxxxxxx + + Getc; + + if (U and 2#10000000#) = 2#00000000# then + null; + + -- 16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx + + elsif (U and 2#11100000#) = 2#110_00000# then + Skip_UTF_Byte; + + -- 16#00_0800#-16#00_ffff#: 1110xxxx 10xxxxxx 10xxxxxx + + elsif (U and 2#11110000#) = 2#1110_0000# then + Skip_UTF_Byte; + Skip_UTF_Byte; + + -- 16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx + + elsif (U and 2#11111000#) = 2#11110_000# then + for K in 1 .. 3 loop + Skip_UTF_Byte; + end loop; + + -- 16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx 10xxxxxx + -- 10xxxxxx 10xxxxxx + + elsif (U and 2#11111100#) = 2#111110_00# then + for K in 1 .. 4 loop + Skip_UTF_Byte; + end loop; + + -- 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 > 16#03FF_FFFF# + + else + Bad; + end if; + end UTF8; + + -- Non-UTF-8 case + + else + declare + Discard : Wide_Wide_Character; + begin + Decode_Wide_Wide_Character (Input, Ptr, Discard); + end; + end if; + 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 new file mode 100755 index 000000000..07d501552 --- /dev/null +++ b/gcc/ada/g-decstr.ads @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- 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, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This 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. + +-- 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; + pragma Inline (Decode_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); + -- Same as above procedure but with Wide_Wide_Character input + + procedure Next_Wide_Character (Input : String; Ptr : in out Natural); + -- 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. This call may be more + -- efficient than calling Decode_Wide_Character and discarding the result. + + 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. + + procedure Next_Wide_Wide_Character (Input : String; Ptr : in out Natural); + -- 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 new file mode 100644 index 000000000..ca03ace52 --- /dev/null +++ b/gcc/ada/g-deutst.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- 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, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a 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 new file mode 100644 index 000000000..ccab560f9 --- /dev/null +++ b/gcc/ada/g-diopit.adb @@ -0,0 +1,398 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +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 it will go + -- down one more directory level by calling Next_Level routine above. + + 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 new file mode 100644 index 000000000..42afcd1ee --- /dev/null +++ b/gcc/ada/g-diopit.ads @@ -0,0 +1,94 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2005, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Iterators among files + +package GNAT.Directory_Operations.Iteration is + + generic + with procedure Action + (Item : String; + Index : Positive; + Quit : in out Boolean); + procedure Find + (Root_Directory : Dir_Name_Str; + File_Pattern : String); + -- Recursively searches the directory structure rooted at Root_Directory. + -- This provides functionality similar to the UNIX 'find' command. + -- Action will be called for every item matching the regular expression + -- File_Pattern (see GNAT.Regexp). Item is the full pathname to the file + -- starting with Root_Directory that has been matched. Index is set to one + -- for the first call and is incremented by one at each call. The iterator + -- will pass in the value False on each call to Action. The iterator will + -- terminate after passing the last matched path to Action or after + -- returning from a call to Action which sets Quit to True. + -- Raises GNAT.Regexp.Error_In_Regexp if File_Pattern is ill formed. + + generic + with procedure Action + (Item : String; + Index : Positive; + Quit : in out Boolean); + procedure Wildcard_Iterator (Path : Path_Name); + -- Calls Action for each path matching Path. Path can include wildcards '*' + -- and '?' and [...]. The rules are: + -- + -- * can be replaced by any sequence of characters + -- ? can be replaced by a single character + -- [a-z] match one character in the range 'a' through 'z' + -- [abc] match either character 'a', 'b' or 'c' + -- + -- Item is the filename that has been matched. Index is set to one for the + -- first call and is incremented by one at each call. The iterator's + -- termination can be controlled by setting Quit to True. It is by default + -- set to False. + -- + -- For example, if we have the following directory structure: + -- /boo/ + -- foo.ads + -- /sed/ + -- foo.ads + -- file/ + -- foo.ads + -- /sid/ + -- foo.ads + -- file/ + -- foo.ads + -- /life/ + -- + -- A call with expression "/s*/file/*" will call Action for the following + -- items: + -- /sed/file/foo.ads + -- /sid/file/foo.ads + +end GNAT.Directory_Operations.Iteration; diff --git a/gcc/ada/g-dirope.adb b/gcc/ada/g-dirope.adb new file mode 100644 index 000000000..50e8b4785 --- /dev/null +++ b/gcc/ada/g-dirope.adb @@ -0,0 +1,775 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . D I R E C T O R Y _ O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; +with Ada.Strings.Fixed; + +with Ada.Unchecked_Deallocation; +with Ada.Unchecked_Conversion; + +with System; use System; +with System.CRTL; use System.CRTL; + +with GNAT.OS_Lib; + +package body GNAT.Directory_Operations is + + use Ada; + + Filename_Max : constant Integer := 1024; + -- 1024 is the value of FILENAME_MAX in stdio.h + + procedure Free is new + Ada.Unchecked_Deallocation (Dir_Type_Value, Dir_Type); + + On_Windows : constant Boolean := GNAT.OS_Lib.Directory_Separator = '\'; + -- An indication that we are on Windows. Used in Get_Current_Dir, to + -- deal with drive letters in the beginning of absolute paths. + + --------------- + -- Base_Name -- + --------------- + + function Base_Name + (Path : Path_Name; + Suffix : String := "") return String + is + function Get_File_Names_Case_Sensitive return Integer; + pragma Import + (C, Get_File_Names_Case_Sensitive, + "__gnat_get_file_names_case_sensitive"); + + Case_Sensitive_File_Name : constant Boolean := + Get_File_Names_Case_Sensitive = 1; + + function Basename + (Path : Path_Name; + Suffix : String := "") return String; + -- This function does the job. The only difference between Basename + -- and Base_Name (the parent function) is that the former is case + -- sensitive, while the latter is not. Path and Suffix are adjusted + -- appropriately before calling Basename under platforms where the + -- file system is not case sensitive. + + -------------- + -- Basename -- + -------------- + + function Basename + (Path : Path_Name; + Suffix : String := "") return String + is + Cut_Start : Natural := + Strings.Fixed.Index + (Path, Dir_Seps, Going => Strings.Backward); + Cut_End : Natural; + + begin + -- Cut_Start point to the first basename character + + Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1); + + -- Cut_End point to the last basename character + + Cut_End := Path'Last; + + -- If basename ends with Suffix, adjust Cut_End + + if Suffix /= "" + and then Path (Path'Last - Suffix'Length + 1 .. Cut_End) = Suffix + then + Cut_End := Path'Last - Suffix'Length; + end if; + + Check_For_Standard_Dirs : declare + Offset : constant Integer := Path'First - Base_Name.Path'First; + BN : constant String := + Base_Name.Path (Cut_Start - Offset .. Cut_End - Offset); + -- Here we use Base_Name.Path to keep the original casing + + Has_Drive_Letter : constant Boolean := + OS_Lib.Path_Separator /= ':'; + -- If Path separator is not ':' then we are on a DOS based OS + -- where this character is used as a drive letter separator. + + begin + if BN = "." or else BN = ".." then + return ""; + + elsif Has_Drive_Letter + and then BN'Length > 2 + and then Characters.Handling.Is_Letter (BN (BN'First)) + and then BN (BN'First + 1) = ':' + then + -- We have a DOS drive letter prefix, remove it + + return BN (BN'First + 2 .. BN'Last); + + else + return BN; + end if; + end Check_For_Standard_Dirs; + end Basename; + + -- Start of processing for Base_Name + + begin + if Path'Length <= Suffix'Length then + return Path; + end if; + + if Case_Sensitive_File_Name then + return Basename (Path, Suffix); + else + return Basename + (Characters.Handling.To_Lower (Path), + Characters.Handling.To_Lower (Suffix)); + end if; + end Base_Name; + + ---------------- + -- Change_Dir -- + ---------------- + + procedure Change_Dir (Dir_Name : Dir_Name_Str) is + C_Dir_Name : constant String := Dir_Name & ASCII.NUL; + begin + if chdir (C_Dir_Name) /= 0 then + raise Directory_Error; + end if; + end Change_Dir; + + ----------- + -- Close -- + ----------- + + procedure Close (Dir : in out Dir_Type) is + Discard : Integer; + pragma Warnings (Off, Discard); + + function closedir (directory : DIRs) return Integer; + pragma Import (C, closedir, "__gnat_closedir"); + + begin + if not Is_Open (Dir) then + raise Directory_Error; + end if; + + Discard := closedir (DIRs (Dir.all)); + Free (Dir); + end Close; + + -------------- + -- Dir_Name -- + -------------- + + function Dir_Name (Path : Path_Name) return Dir_Name_Str is + Last_DS : constant Natural := + Strings.Fixed.Index + (Path, Dir_Seps, Going => Strings.Backward); + + begin + if Last_DS = 0 then + + -- There is no directory separator, returns current working directory + + return "." & Dir_Separator; + + else + return Path (Path'First .. Last_DS); + end if; + end Dir_Name; + + ----------------- + -- Expand_Path -- + ----------------- + + function Expand_Path + (Path : Path_Name; + Mode : Environment_Style := System_Default) return Path_Name + is + Environment_Variable_Char : Character; + pragma Import (C, Environment_Variable_Char, "__gnat_environment_char"); + + Result : OS_Lib.String_Access := new String (1 .. 200); + Result_Last : Natural := 0; + + procedure Append (C : Character); + procedure Append (S : String); + -- Append to Result + + procedure Double_Result_Size; + -- Reallocate Result, doubling its size + + function Is_Var_Prefix (C : Character) return Boolean; + pragma Inline (Is_Var_Prefix); + + procedure Read (K : in out Positive); + -- Update Result while reading current Path starting at position K. If + -- a variable is found, call Var below. + + procedure Var (K : in out Positive); + -- Translate variable name starting at position K with the associated + -- environment value. + + ------------ + -- Append -- + ------------ + + procedure Append (C : Character) is + begin + if Result_Last = Result'Last then + Double_Result_Size; + end if; + + Result_Last := Result_Last + 1; + Result (Result_Last) := C; + end Append; + + procedure Append (S : String) is + begin + while Result_Last + S'Length - 1 > Result'Last loop + Double_Result_Size; + end loop; + + Result (Result_Last + 1 .. Result_Last + S'Length) := S; + Result_Last := Result_Last + S'Length; + end Append; + + ------------------------ + -- Double_Result_Size -- + ------------------------ + + procedure Double_Result_Size is + New_Result : constant OS_Lib.String_Access := + new String (1 .. 2 * Result'Last); + begin + New_Result (1 .. Result_Last) := Result (1 .. Result_Last); + OS_Lib.Free (Result); + Result := New_Result; + end Double_Result_Size; + + ------------------- + -- Is_Var_Prefix -- + ------------------- + + function Is_Var_Prefix (C : Character) return Boolean is + begin + return (C = Environment_Variable_Char and then Mode = System_Default) + or else + (C = '$' and then (Mode = UNIX or else Mode = Both)) + or else + (C = '%' and then (Mode = DOS or else Mode = Both)); + end Is_Var_Prefix; + + ---------- + -- Read -- + ---------- + + procedure Read (K : in out Positive) is + P : Character; + + begin + For_All_Characters : loop + if Is_Var_Prefix (Path (K)) then + P := Path (K); + + -- Could be a variable + + if K < Path'Last then + if Path (K + 1) = P then + + -- Not a variable after all, this is a double $ or %, + -- just insert one in the result string. + + Append (P); + K := K + 1; + + else + -- Let's parse the variable + + Var (K); + end if; + + else + -- We have an ending $ or % sign + + Append (P); + end if; + + else + -- This is a standard character, just add it to the result + + Append (Path (K)); + end if; + + -- Skip to next character + + K := K + 1; + + exit For_All_Characters when K > Path'Last; + end loop For_All_Characters; + end Read; + + --------- + -- Var -- + --------- + + procedure Var (K : in out Positive) is + P : constant Character := Path (K); + T : Character; + E : Positive; + + begin + K := K + 1; + + if P = '%' or else Path (K) = '{' then + + -- Set terminator character + + if P = '%' then + T := '%'; + else + T := '}'; + K := K + 1; + end if; + + -- Look for terminator character, k point to the first character + -- for the variable name. + + E := K; + + loop + E := E + 1; + exit when Path (E) = T or else E = Path'Last; + end loop; + + if Path (E) = T then + + -- OK found, translate with environment value + + declare + Env : OS_Lib.String_Access := + OS_Lib.Getenv (Path (K .. E - 1)); + + begin + Append (Env.all); + OS_Lib.Free (Env); + end; + + else + -- No terminator character, not a variable after all or a + -- syntax error, ignore it, insert string as-is. + + Append (P); -- Add prefix character + + if T = '}' then -- If we were looking for curly bracket + Append ('{'); -- terminator, add the curly bracket + end if; + + Append (Path (K .. E)); + end if; + + else + -- The variable name is everything from current position to first + -- non letter/digit character. + + E := K; + + -- Check that first character is a letter + + if Characters.Handling.Is_Letter (Path (E)) then + E := E + 1; + + Var_Name : loop + exit Var_Name when E > Path'Last; + + if Characters.Handling.Is_Letter (Path (E)) + or else Characters.Handling.Is_Digit (Path (E)) + then + E := E + 1; + else + exit Var_Name; + end if; + end loop Var_Name; + + E := E - 1; + + declare + Env : OS_Lib.String_Access := OS_Lib.Getenv (Path (K .. E)); + + begin + Append (Env.all); + OS_Lib.Free (Env); + end; + + else + -- This is not a variable after all + + Append ('$'); + Append (Path (E)); + end if; + + end if; + + K := E; + end Var; + + -- Start of processing for Expand_Path + + begin + declare + K : Positive := Path'First; + + begin + Read (K); + + declare + Returned_Value : constant String := Result (1 .. Result_Last); + + begin + OS_Lib.Free (Result); + return Returned_Value; + end; + end; + end Expand_Path; + + -------------------- + -- File_Extension -- + -------------------- + + function File_Extension (Path : Path_Name) return String is + First : Natural := + Strings.Fixed.Index + (Path, Dir_Seps, Going => Strings.Backward); + + Dot : Natural; + + begin + if First = 0 then + First := Path'First; + end if; + + Dot := Strings.Fixed.Index (Path (First .. Path'Last), + ".", + Going => Strings.Backward); + + if Dot = 0 or else Dot = Path'Last then + return ""; + else + return Path (Dot .. Path'Last); + end if; + end File_Extension; + + --------------- + -- File_Name -- + --------------- + + function File_Name (Path : Path_Name) return String is + begin + return Base_Name (Path); + end File_Name; + + --------------------- + -- Format_Pathname -- + --------------------- + + function Format_Pathname + (Path : Path_Name; + Style : Path_Style := System_Default) return String + is + N_Path : String := Path; + K : Positive := N_Path'First; + Prev_Dirsep : Boolean := False; + + begin + if Dir_Separator = '\' + and then Path'Length > 1 + and then Path (K .. K + 1) = "\\" + then + if Style = UNIX then + N_Path (K .. K + 1) := "//"; + end if; + + K := K + 2; + end if; + + for J in K .. Path'Last loop + if Strings.Maps.Is_In (Path (J), Dir_Seps) then + if not Prev_Dirsep then + case Style is + when UNIX => N_Path (K) := '/'; + when DOS => N_Path (K) := '\'; + when System_Default => N_Path (K) := Dir_Separator; + end case; + + K := K + 1; + end if; + + Prev_Dirsep := True; + + else + N_Path (K) := Path (J); + K := K + 1; + Prev_Dirsep := False; + end if; + end loop; + + return N_Path (N_Path'First .. K - 1); + end Format_Pathname; + + --------------------- + -- Get_Current_Dir -- + --------------------- + + Max_Path : Integer; + pragma Import (C, Max_Path, "__gnat_max_path_len"); + + function Get_Current_Dir return Dir_Name_Str is + Current_Dir : String (1 .. Max_Path + 1); + Last : Natural; + begin + Get_Current_Dir (Current_Dir, Last); + return Current_Dir (1 .. Last); + end Get_Current_Dir; + + procedure Get_Current_Dir (Dir : out Dir_Name_Str; Last : out Natural) is + Path_Len : Natural := Max_Path; + Buffer : String (Dir'First .. Dir'First + Max_Path + 1); + + procedure Local_Get_Current_Dir + (Dir : System.Address; + Length : System.Address); + pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir"); + + begin + Local_Get_Current_Dir (Buffer'Address, Path_Len'Address); + + Last := + (if Dir'Length > Path_Len then Dir'First + Path_Len - 1 else Dir'Last); + + Dir (Buffer'First .. Last) := Buffer (Buffer'First .. Last); + + -- By default, the drive letter on Windows is in upper case + + if On_Windows and then Last > Dir'First and then + Dir (Dir'First + 1) = ':' + then + Dir (Dir'First) := + Ada.Characters.Handling.To_Upper (Dir (Dir'First)); + end if; + end Get_Current_Dir; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (Dir : Dir_Type) return Boolean is + begin + return Dir /= Null_Dir + and then System.Address (Dir.all) /= System.Null_Address; + end Is_Open; + + -------------- + -- Make_Dir -- + -------------- + + procedure Make_Dir (Dir_Name : Dir_Name_Str) is + C_Dir_Name : constant String := Dir_Name & ASCII.NUL; + + function mkdir (Dir_Name : String) return Integer; + pragma Import (C, mkdir, "__gnat_mkdir"); + + begin + if mkdir (C_Dir_Name) /= 0 then + raise Directory_Error; + end if; + end Make_Dir; + + ---------- + -- Open -- + ---------- + + procedure Open + (Dir : out Dir_Type; + Dir_Name : Dir_Name_Str) + is + function opendir (file_name : String) return DIRs; + pragma Import (C, opendir, "__gnat_opendir"); + + C_File_Name : constant String := Dir_Name & ASCII.NUL; + + begin + Dir := new Dir_Type_Value'(Dir_Type_Value (opendir (C_File_Name))); + + if not Is_Open (Dir) then + Free (Dir); + Dir := Null_Dir; + raise Directory_Error; + end if; + end Open; + + ---------- + -- Read -- + ---------- + + procedure Read + (Dir : Dir_Type; + Str : out String; + Last : out Natural) + is + Filename_Addr : Address; + Filename_Len : aliased Integer; + + Buffer : array (0 .. Filename_Max + 12) of Character; + -- 12 is the size of the dirent structure (see dirent.h), without the + -- field for the filename. + + function readdir_gnat + (Directory : System.Address; + Buffer : System.Address; + Last : not null access Integer) return System.Address; + pragma Import (C, readdir_gnat, "__gnat_readdir"); + + begin + if not Is_Open (Dir) then + raise Directory_Error; + end if; + + Filename_Addr := + readdir_gnat + (System.Address (Dir.all), Buffer'Address, Filename_Len'Access); + + if Filename_Addr = System.Null_Address then + Last := 0; + return; + end if; + + Last := + (if Str'Length > Filename_Len then Str'First + Filename_Len - 1 + else Str'Last); + + declare + subtype Path_String is String (1 .. Filename_Len); + type Path_String_Access is access Path_String; + + function Address_To_Access is new + Ada.Unchecked_Conversion + (Source => Address, + Target => Path_String_Access); + + Path_Access : constant Path_String_Access := + Address_To_Access (Filename_Addr); + + begin + for J in Str'First .. Last loop + Str (J) := Path_Access (J - Str'First + 1); + end loop; + end; + end Read; + + ------------------------- + -- Read_Is_Thread_Sage -- + ------------------------- + + function Read_Is_Thread_Safe return Boolean is + function readdir_is_thread_safe return Integer; + pragma Import + (C, readdir_is_thread_safe, "__gnat_readdir_is_thread_safe"); + begin + return (readdir_is_thread_safe /= 0); + end Read_Is_Thread_Safe; + + ---------------- + -- Remove_Dir -- + ---------------- + + procedure Remove_Dir + (Dir_Name : Dir_Name_Str; + Recursive : Boolean := False) + is + C_Dir_Name : constant String := Dir_Name & ASCII.NUL; + Last : Integer; + Str : String (1 .. Filename_Max); + Success : Boolean; + Current_Dir : Dir_Type; + + begin + -- Remove the directory only if it is empty + + if not Recursive then + if rmdir (C_Dir_Name) /= 0 then + raise Directory_Error; + end if; + + -- Remove directory and all files and directories that it may contain + + else + Open (Current_Dir, Dir_Name); + + loop + Read (Current_Dir, Str, Last); + exit when Last = 0; + + if GNAT.OS_Lib.Is_Directory + (Dir_Name & Dir_Separator & Str (1 .. Last)) + then + if Str (1 .. Last) /= "." + and then + Str (1 .. Last) /= ".." + then + -- Recursive call to remove a subdirectory and all its + -- files. + + Remove_Dir + (Dir_Name & Dir_Separator & Str (1 .. Last), + True); + end if; + + else + GNAT.OS_Lib.Delete_File + (Dir_Name & Dir_Separator & Str (1 .. Last), + Success); + + if not Success then + raise Directory_Error; + end if; + end if; + end loop; + + Close (Current_Dir); + Remove_Dir (Dir_Name); + end if; + end Remove_Dir; + +end GNAT.Directory_Operations; diff --git a/gcc/ada/g-dirope.ads b/gcc/ada/g-dirope.ads new file mode 100644 index 000000000..32b914bdf --- /dev/null +++ b/gcc/ada/g-dirope.ads @@ -0,0 +1,277 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 + +-- Note: support on OpenVMS is limited to the support of Unix-style +-- directory names (OpenVMS native directory format is not supported). +-- Read individual entries for more specific notes on OpenVMS support. + +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. + -- On OpenVMS, only Unix style path names are supported, not VMS style, + -- but the directory and file names are not case sensitive. + + 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, and OpenVMS). + + 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 such as Windows + -- and VMS 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: + -- + -- UNIX + -- Use '/' as the directory separator. The default on Unix systems + -- and on OpenVMS. + -- + -- DOS + -- Use '\' as the directory separator. The default on Windows. + -- + -- 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 (or logical names on OpenVMS) + -- 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 exists 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 and OpenVMS logical names 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 UNIX on Unix and OpenVMS systems, or DOS on Windows, + -- depending on the running environment. What about other OS's??? + + --------------- + -- 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 + -- + -- Note that we used to define this type in the body of this package, + -- but this was causing troubles in the context of .NET code generation + -- (because Taft amendment types are not fully implemented and cause + -- undefined references to the class), so we moved the type declaration + -- to the spec's private part, which is no problem in any case here. + + type Dir_Type is access Dir_Type_Value; + + Null_Dir : constant Dir_Type := null; + + pragma Import (C, Dir_Separator, "__gnat_dir_separator"); + + Dir_Seps : constant Ada.Strings.Maps.Character_Set := + Ada.Strings.Maps.To_Set ("/\"); + -- UNIX and DOS style directory separators + +end GNAT.Directory_Operations; diff --git a/gcc/ada/g-dynhta.adb b/gcc/ada/g-dynhta.adb new file mode 100644 index 000000000..e423bab38 --- /dev/null +++ b/gcc/ada/g-dynhta.adb @@ -0,0 +1,348 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . D Y N A M I C _ H T A B L E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2006, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Dynamic_HTables is + + ------------------- + -- Static_HTable -- + ------------------- + + package body Static_HTable is + + type Table_Type is array (Header_Num) of Elmt_Ptr; + + type Instance_Data is record + Table : Table_Type; + Iterator_Index : Header_Num; + Iterator_Ptr : Elmt_Ptr; + Iterator_Started : Boolean := False; + end record; + + function Get_Non_Null (T : Instance) return Elmt_Ptr; + -- Returns Null_Ptr if Iterator_Started is False or if the Table is + -- empty. Returns Iterator_Ptr if non null, or the next non null + -- element in table if any. + + --------- + -- Get -- + --------- + + function Get (T : Instance; K : Key) return Elmt_Ptr is + Elmt : Elmt_Ptr; + + begin + if T = null then + return Null_Ptr; + end if; + + Elmt := T.Table (Hash (K)); + + loop + if Elmt = Null_Ptr then + return Null_Ptr; + + elsif Equal (Get_Key (Elmt), K) then + return Elmt; + + else + Elmt := Next (Elmt); + end if; + end loop; + end Get; + + --------------- + -- Get_First -- + --------------- + + function Get_First (T : Instance) return Elmt_Ptr is + begin + if T = null then + return Null_Ptr; + end if; + + T.Iterator_Started := True; + T.Iterator_Index := T.Table'First; + T.Iterator_Ptr := T.Table (T.Iterator_Index); + return Get_Non_Null (T); + end Get_First; + + -------------- + -- Get_Next -- + -------------- + + function Get_Next (T : Instance) return Elmt_Ptr is + begin + if T = null or else not T.Iterator_Started then + return Null_Ptr; + end if; + + T.Iterator_Ptr := Next (T.Iterator_Ptr); + return Get_Non_Null (T); + end Get_Next; + + ------------------ + -- Get_Non_Null -- + ------------------ + + function Get_Non_Null (T : Instance) return Elmt_Ptr is + begin + if T = null then + return Null_Ptr; + end if; + + while T.Iterator_Ptr = Null_Ptr loop + if T.Iterator_Index = T.Table'Last then + T.Iterator_Started := False; + return Null_Ptr; + end if; + + T.Iterator_Index := T.Iterator_Index + 1; + T.Iterator_Ptr := T.Table (T.Iterator_Index); + end loop; + + return T.Iterator_Ptr; + end Get_Non_Null; + + ------------ + -- Remove -- + ------------ + + procedure Remove (T : Instance; K : Key) is + Index : constant Header_Num := Hash (K); + Elmt : Elmt_Ptr; + Next_Elmt : Elmt_Ptr; + + begin + if T = null then + return; + end if; + + Elmt := T.Table (Index); + + if Elmt = Null_Ptr then + return; + + elsif Equal (Get_Key (Elmt), K) then + T.Table (Index) := Next (Elmt); + + else + loop + Next_Elmt := Next (Elmt); + + if Next_Elmt = Null_Ptr then + return; + + elsif Equal (Get_Key (Next_Elmt), K) then + Set_Next (Elmt, Next (Next_Elmt)); + return; + + else + Elmt := Next_Elmt; + end if; + end loop; + end if; + end Remove; + + ----------- + -- Reset -- + ----------- + + procedure Reset (T : in out Instance) is + procedure Free is + new Ada.Unchecked_Deallocation (Instance_Data, Instance); + + begin + if T = null then + return; + end if; + + for J in T.Table'Range loop + T.Table (J) := Null_Ptr; + end loop; + + Free (T); + end Reset; + + --------- + -- Set -- + --------- + + procedure Set (T : in out Instance; E : Elmt_Ptr) is + Index : Header_Num; + + begin + if T = null then + T := new Instance_Data; + end if; + + Index := Hash (Get_Key (E)); + Set_Next (E, T.Table (Index)); + T.Table (Index) := E; + end Set; + + end Static_HTable; + + ------------------- + -- Simple_HTable -- + ------------------- + + package body Simple_HTable is + + --------- + -- Get -- + --------- + + function Get (T : Instance; K : Key) return Element is + Tmp : Elmt_Ptr; + + begin + if T = Nil then + return No_Element; + end if; + + Tmp := Tab.Get (Tab.Instance (T), K); + + if Tmp = null then + return No_Element; + else + return Tmp.E; + end if; + end Get; + + --------------- + -- Get_First -- + --------------- + + function Get_First (T : Instance) return Element is + Tmp : constant Elmt_Ptr := Tab.Get_First (Tab.Instance (T)); + + begin + if Tmp = null then + return No_Element; + else + return Tmp.E; + end if; + end Get_First; + + ------------- + -- Get_Key -- + ------------- + + function Get_Key (E : Elmt_Ptr) return Key is + begin + return E.K; + end Get_Key; + + -------------- + -- Get_Next -- + -------------- + + function Get_Next (T : Instance) return Element is + Tmp : constant Elmt_Ptr := Tab.Get_Next (Tab.Instance (T)); + begin + if Tmp = null then + return No_Element; + else + return Tmp.E; + end if; + end Get_Next; + + ---------- + -- Next -- + ---------- + + function Next (E : Elmt_Ptr) return Elmt_Ptr is + begin + return E.Next; + end Next; + + ------------ + -- Remove -- + ------------ + + procedure Remove (T : Instance; K : Key) is + Tmp : Elmt_Ptr; + + begin + Tmp := Tab.Get (Tab.Instance (T), K); + + if Tmp /= null then + Tab.Remove (Tab.Instance (T), K); + Free (Tmp); + end if; + end Remove; + + ----------- + -- Reset -- + ----------- + + procedure Reset (T : in out Instance) is + E1, E2 : Elmt_Ptr; + + begin + E1 := Tab.Get_First (Tab.Instance (T)); + while E1 /= null loop + E2 := Tab.Get_Next (Tab.Instance (T)); + Free (E1); + E1 := E2; + end loop; + + Tab.Reset (Tab.Instance (T)); + end Reset; + + --------- + -- Set -- + --------- + + procedure Set (T : in out Instance; K : Key; E : Element) is + Tmp : constant Elmt_Ptr := Tab.Get (Tab.Instance (T), K); + begin + if Tmp = null then + Tab.Set (Tab.Instance (T), new Element_Wrapper'(K, E, null)); + else + Tmp.E := E; + end if; + end Set; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is + begin + E.Next := Next; + end Set_Next; + + end Simple_HTable; + +end GNAT.Dynamic_HTables; diff --git a/gcc/ada/g-dynhta.ads b/gcc/ada/g-dynhta.ads new file mode 100644 index 000000000..f679d10de --- /dev/null +++ b/gcc/ada/g-dynhta.ads @@ -0,0 +1,242 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . D Y N A M I C _ H T A B L E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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. + +-- This package provides a facility similar to that of GNAT.HTable, except +-- that this package declares types that can be used to define dynamic +-- instances of hash tables, while instantiations in GNAT.HTable creates a +-- single instance of the hash table. + +-- Note that this interface should remain synchronized with those in +-- GNAT.HTable to keep as much coherency as possible between these two +-- related units. + +with Ada.Unchecked_Deallocation; +package GNAT.Dynamic_HTables is + + ------------------- + -- 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 + + type Elmt_Ptr is private; + -- The type used to reference an element (will usually be an access + -- type, but could be some other form of type such as an integer type). + + Null_Ptr : Elmt_Ptr; + -- The null value of the Elmt_Ptr type + + with procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); + with function Next (E : Elmt_Ptr) return Elmt_Ptr; + -- The type must provide an internal link for the sake of the + -- staticness of the HTable. + + type Key is limited private; + with function Get_Key (E : Elmt_Ptr) return Key; + with function Hash (F : Key) return Header_Num; + with function Equal (F1, F2 : Key) return Boolean; + + package Static_HTable is + + type Instance is private; + Nil : constant Instance; + + procedure Reset (T : in out Instance); + -- Resets the hash table by releasing all memory associated with + -- it. The hash table can safely be reused after this call. For the + -- most common case where Elmt_Ptr is an access type, and Null_Ptr is + -- null, this is only needed if the same table is reused in a new + -- context. If Elmt_Ptr is other than an access type, or Null_Ptr is + -- other than null, then Reset must be called before the first use of + -- the hash table. + + procedure Set (T : in out Instance; E : Elmt_Ptr); + -- Insert the element pointer in the HTable + + function Get (T : Instance; K : Key) return Elmt_Ptr; + -- Returns the latest inserted element pointer with the given Key + -- or null if none. + + procedure Remove (T : Instance; K : Key); + -- Removes the latest inserted element pointer associated with the + -- given key if any, does nothing if none. + + function Get_First (T : Instance) return Elmt_Ptr; + -- Returns Null_Ptr if the Htable is empty, otherwise returns one + -- non specified element. There is no guarantee that 2 calls to this + -- function will return the same element. + + function Get_Next (T : Instance) return Elmt_Ptr; + -- Returns 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. + + private + + type Instance_Data; + type Instance is access all Instance_Data; + Nil : constant Instance := null; + + end Static_HTable; + + ------------------- + -- Simple_HTable -- + ------------------- + + -- A simple hash table abstraction, easy to instantiate, easy to use. + -- The table associates one element to one key with the procedure Set. + -- Get retrieves the Element stored for a given Key. The efficiency of + -- retrieval is function of the size of the Table parameterized by + -- Header_Num and the hashing function Hash. + + generic + type Header_Num is range <>; + -- An integer type indicating the number and range of hash headers + + type Element is private; + -- The type of element to be stored + + No_Element : Element; + -- The object that is returned by Get when no element has been set for + -- a given key + + type Key is private; + with function Hash (F : Key) return Header_Num; + with function Equal (F1, F2 : Key) return Boolean; + + package Simple_HTable is + + type Instance is private; + Nil : constant Instance; + + procedure Set (T : in out Instance; K : Key; E : Element); + -- Associates an element with a given key. Overrides any previously + -- associated element. + + procedure Reset (T : in out Instance); + -- Releases all memory associated with the table. The table can be + -- reused after this call (it is automatically allocated on the first + -- access to the table). + + function Get (T : Instance; K : Key) return Element; + -- Returns the Element associated with a key or No_Element if the + -- given key has not associated element + + procedure Remove (T : Instance; K : Key); + -- Removes the latest inserted element pointer associated with the + -- given key if any, does nothing if none. + + function Get_First (T : Instance) return Element; + -- Returns No_Element if the Htable is empty, otherwise returns one + -- non specified element. There is no guarantee that two calls to this + -- function will return the same element, if the Htable has been + -- modified between the two calls. + + function Get_Next (T : Instance) 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. + -- To guarantee that all the elements of the Htable will be traversed, + -- no modification of the Htable (Set, Reset, Remove) should occur + -- between a call to Get_First and subsequent consecutive calls to + -- Get_Next, until one of these calls returns No_Element. + + private + + type Element_Wrapper; + type Elmt_Ptr is access all Element_Wrapper; + type Element_Wrapper is record + K : Key; + E : Element; + Next : Elmt_Ptr; + end record; + + procedure Free is new + Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr); + + procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); + function Next (E : Elmt_Ptr) return Elmt_Ptr; + function Get_Key (E : Elmt_Ptr) return Key; + + package Tab is new Static_HTable + (Header_Num => Header_Num, + Element => Element_Wrapper, + Elmt_Ptr => Elmt_Ptr, + Null_Ptr => null, + Set_Next => Set_Next, + Next => Next, + Key => Key, + Get_Key => Get_Key, + Hash => Hash, + Equal => Equal); + + type Instance is new Tab.Instance; + Nil : constant Instance := Instance (Tab.Nil); + + end Simple_HTable; + +end GNAT.Dynamic_HTables; diff --git a/gcc/ada/g-dyntab.adb b/gcc/ada/g-dyntab.adb new file mode 100644 index 000000000..2c3ae4fcd --- /dev/null +++ b/gcc/ada/g-dyntab.adb @@ -0,0 +1,406 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . D Y N A M I C _ T A B L E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2000-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit; + +with GNAT.Heap_Sort_G; +with System; use System; +with System.Memory; use System.Memory; + +with Ada.Unchecked_Conversion; + +package body GNAT.Dynamic_Tables is + + Min : constant Integer := Integer (Table_Low_Bound); + -- Subscript of the minimum entry in the currently allocated table + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Reallocate (T : in out Instance); + -- Reallocate the existing table according to the current value stored + -- in Max. Works correctly to do an initial allocation if the table + -- is currently null. + + pragma Warnings (Off); + -- These unchecked conversions are in fact safe, since they never + -- generate improperly aliased pointer values. + + function To_Address is new Ada.Unchecked_Conversion (Table_Ptr, Address); + function To_Pointer is new Ada.Unchecked_Conversion (Address, Table_Ptr); + + pragma Warnings (On); + + -------------- + -- Allocate -- + -------------- + + procedure Allocate (T : in out Instance; Num : Integer := 1) is + begin + T.P.Last_Val := T.P.Last_Val + Num; + + if T.P.Last_Val > T.P.Max then + Reallocate (T); + end if; + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append (T : in out Instance; New_Val : Table_Component_Type) is + begin + Set_Item (T, Table_Index_Type (T.P.Last_Val + 1), New_Val); + end Append; + + ---------------- + -- Append_All -- + ---------------- + + procedure Append_All (T : in out Instance; New_Vals : Table_Type) is + begin + for J in New_Vals'Range loop + Append (T, New_Vals (J)); + end loop; + end Append_All; + + -------------------- + -- Decrement_Last -- + -------------------- + + procedure Decrement_Last (T : in out Instance) is + begin + T.P.Last_Val := T.P.Last_Val - 1; + end Decrement_Last; + + -------------- + -- For_Each -- + -------------- + + procedure For_Each (Table : Instance) is + Quit : Boolean := False; + begin + for Index in Table_Low_Bound .. Table_Index_Type (Table.P.Last_Val) loop + Action (Index, Table.Table (Index), Quit); + exit when Quit; + end loop; + end For_Each; + + ---------- + -- Free -- + ---------- + + procedure Free (T : in out Instance) is + begin + Free (To_Address (T.Table)); + T.Table := null; + T.P.Length := 0; + end Free; + + -------------------- + -- Increment_Last -- + -------------------- + + procedure Increment_Last (T : in out Instance) is + begin + T.P.Last_Val := T.P.Last_Val + 1; + + if T.P.Last_Val > T.P.Max then + Reallocate (T); + end if; + end Increment_Last; + + ---------- + -- Init -- + ---------- + + procedure Init (T : in out Instance) is + Old_Length : constant Integer := T.P.Length; + + begin + T.P.Last_Val := Min - 1; + T.P.Max := Min + Table_Initial - 1; + T.P.Length := T.P.Max - Min + 1; + + -- If table is same size as before (happens when table is never + -- expanded which is a common case), then simply reuse it. Note + -- that this also means that an explicit Init call right after + -- the implicit one in the package body is harmless. + + if Old_Length = T.P.Length then + return; + + -- Otherwise we can use Reallocate to get a table of the right size. + -- Note that Reallocate works fine to allocate a table of the right + -- initial size when it is first allocated. + + else + Reallocate (T); + end if; + end Init; + + ---------- + -- Last -- + ---------- + + function Last (T : Instance) return Table_Index_Type is + begin + return Table_Index_Type (T.P.Last_Val); + end Last; + + ---------------- + -- Reallocate -- + ---------------- + + procedure Reallocate (T : in out Instance) is + New_Length : Integer; + New_Size : size_t; + + begin + if T.P.Max < T.P.Last_Val then + while T.P.Max < T.P.Last_Val loop + New_Length := T.P.Length * (100 + Table_Increment) / 100; + + if New_Length > T.P.Length then + T.P.Length := New_Length; + else + T.P.Length := T.P.Length + 1; + end if; + + T.P.Max := Min + T.P.Length - 1; + end loop; + end if; + + New_Size := + size_t ((T.P.Max - Min + 1) * + (Table_Type'Component_Size / Storage_Unit)); + + if T.Table = null then + T.Table := To_Pointer (Alloc (New_Size)); + + elsif New_Size > 0 then + T.Table := + To_Pointer (Realloc (Ptr => To_Address (T.Table), + Size => New_Size)); + end if; + + if T.P.Length /= 0 and then T.Table = null then + raise Storage_Error; + end if; + end Reallocate; + + ------------- + -- Release -- + ------------- + + procedure Release (T : in out Instance) is + begin + T.P.Length := T.P.Last_Val - Integer (Table_Low_Bound) + 1; + T.P.Max := T.P.Last_Val; + Reallocate (T); + end Release; + + -------------- + -- Set_Item -- + -------------- + + procedure Set_Item + (T : in out Instance; + Index : Table_Index_Type; + Item : Table_Component_Type) + is + -- If Item is a value within the current allocation, and we are going to + -- reallocate, then we must preserve an intermediate copy here before + -- calling Increment_Last. Otherwise, if Table_Component_Type is passed + -- by reference, we are going to end up copying from storage that might + -- have been deallocated from Increment_Last calling Reallocate. + + subtype Allocated_Table_T is + Table_Type (T.Table'First .. Table_Index_Type (T.P.Max + 1)); + -- A constrained table subtype one element larger than the currently + -- allocated table. + + Allocated_Table_Address : constant System.Address := + T.Table.all'Address; + -- Used for address clause below (we can't use non-static expression + -- Table.all'Address directly in the clause because some older versions + -- of the compiler do not allow it). + + Allocated_Table : Allocated_Table_T; + pragma Import (Ada, Allocated_Table); + pragma Suppress (Range_Check, On => Allocated_Table); + for Allocated_Table'Address use Allocated_Table_Address; + -- Allocated_Table represents the currently allocated array, plus one + -- element (the supplementary element is used to have a convenient way + -- to the address just past the end of the current allocation). Range + -- checks are suppressed because this unit uses direct calls to + -- System.Memory for allocation, and this can yield misaligned storage + -- (and we cannot rely on the bootstrap compiler supporting specifically + -- disabling alignment checks, so we need to suppress all range checks). + -- It is safe to suppress this check here because we know that a + -- (possibly misaligned) object of that type does actually exist at that + -- address. + -- ??? We should really improve the allocation circuitry here to + -- guarantee proper alignment. + + Need_Realloc : constant Boolean := Integer (Index) > T.P.Max; + -- True if this operation requires storage reallocation (which may + -- involve moving table contents around). + + begin + -- If we're going to reallocate, check whether Item references an + -- element of the currently allocated table. + + if Need_Realloc + and then Allocated_Table'Address <= Item'Address + and then Item'Address < + Allocated_Table (Table_Index_Type (T.P.Max + 1))'Address + then + -- If so, save a copy on the stack because Increment_Last will + -- reallocate storage and might deallocate the current table. + + declare + Item_Copy : constant Table_Component_Type := Item; + begin + Set_Last (T, Index); + T.Table (Index) := Item_Copy; + end; + + else + -- Here we know that either we won't reallocate (case of Index < Max) + -- or that Item is not in the currently allocated table. + + if Integer (Index) > T.P.Last_Val then + Set_Last (T, Index); + end if; + + T.Table (Index) := Item; + end if; + end Set_Item; + + -------------- + -- Set_Last -- + -------------- + + procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type) is + begin + if Integer (New_Val) < T.P.Last_Val then + T.P.Last_Val := Integer (New_Val); + + else + T.P.Last_Val := Integer (New_Val); + + if T.P.Last_Val > T.P.Max then + Reallocate (T); + end if; + end if; + end Set_Last; + + ---------------- + -- Sort_Table -- + ---------------- + + procedure Sort_Table (Table : in out Instance) is + + Temp : Table_Component_Type; + -- A temporary position to simulate index 0 + + -- Local subprograms + + function Index_Of (Idx : Natural) return Table_Index_Type; + -- Return index of Idx'th element of table + + function Lower_Than (Op1, Op2 : Natural) return Boolean; + -- Compare two components + + procedure Move (From : Natural; To : Natural); + -- Move one component + + package Heap_Sort is new GNAT.Heap_Sort_G (Move, Lower_Than); + + -------------- + -- Index_Of -- + -------------- + + function Index_Of (Idx : Natural) return Table_Index_Type is + J : constant Integer'Base := + Table_Index_Type'Pos (First) + Idx - 1; + begin + return Table_Index_Type'Val (J); + end Index_Of; + + ---------- + -- Move -- + ---------- + + procedure Move (From : Natural; To : Natural) is + begin + if From = 0 then + Table.Table (Index_Of (To)) := Temp; + + elsif To = 0 then + Temp := Table.Table (Index_Of (From)); + + else + Table.Table (Index_Of (To)) := + Table.Table (Index_Of (From)); + end if; + end Move; + + ---------------- + -- Lower_Than -- + ---------------- + + function Lower_Than (Op1, Op2 : Natural) return Boolean is + begin + if Op1 = 0 then + return Lt (Temp, Table.Table (Index_Of (Op2))); + + elsif Op2 = 0 then + return Lt (Table.Table (Index_Of (Op1)), Temp); + + else + return + Lt (Table.Table (Index_Of (Op1)), + Table.Table (Index_Of (Op2))); + end if; + end Lower_Than; + + -- Start of processing for Sort_Table + + begin + Heap_Sort.Sort (Natural (Last (Table) - First) + 1); + end Sort_Table; + +end GNAT.Dynamic_Tables; diff --git a/gcc/ada/g-dyntab.ads b/gcc/ada/g-dyntab.ads new file mode 100644 index 000000000..89634554a --- /dev/null +++ b/gcc/ada/g-dyntab.ads @@ -0,0 +1,225 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . D Y N A M I C _ T A B L E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Resizable one dimensional array support + +-- This package provides an implementation of dynamically resizable one +-- dimensional arrays. The idea is to mimic the normal Ada semantics for +-- arrays as closely as possible with the one additional capability of +-- dynamically modifying the value of the Last attribute. + +-- This package provides a facility similar to that of GNAT.Table, except +-- that this package declares a type that can be used to define dynamic +-- instances of the table, while an instantiation of GNAT.Table creates a +-- single instance of the table type. + +-- Note that this interface should remain synchronized with those in +-- GNAT.Table and the GNAT compiler source unit Table to keep as much +-- coherency as possible between these three related units. + +pragma Compiler_Unit; + +generic + type Table_Component_Type is private; + type Table_Index_Type is range <>; + + Table_Low_Bound : Table_Index_Type; + Table_Initial : Positive; + Table_Increment : Natural; + +package GNAT.Dynamic_Tables is + + -- Table_Component_Type and Table_Index_Type specify the type of the + -- array, Table_Low_Bound is the lower bound. Index_type must be an + -- integer type. The effect is roughly to declare: + + -- Table : array (Table_Low_Bound .. <>) of Table_Component_Type; + + -- Note: since the upper bound can be one less than the lower + -- bound for an empty array, the table index type must be able + -- to cover this range, e.g. if the lower bound is 1, then the + -- Table_Index_Type should be Natural rather than Positive. + + -- Table_Component_Type may be any Ada type, except that controlled + -- types are not supported. Note however that default initialization + -- will NOT occur for array components. + + -- The Table_Initial values controls the allocation of the table when + -- it is first allocated, either by default, or by an explicit Init + -- call. + + -- The Table_Increment value controls the amount of increase, if the + -- table has to be increased in size. The value given is a percentage + -- value (e.g. 100 = increase table size by 100%, i.e. double it). + + -- The Last and Set_Last subprograms provide control over the current + -- logical allocation. They are quite efficient, so they can be used + -- freely (expensive reallocation occurs only at major granularity + -- chunks controlled by the allocation parameters). + + -- Note: we do not make the table components aliased, since this would + -- restrict the use of table for discriminated types. If it is necessary + -- to take the access of a table element, use Unrestricted_Access. + + type Table_Type is + array (Table_Index_Type range <>) of Table_Component_Type; + subtype Big_Table_Type is + Table_Type (Table_Low_Bound .. Table_Index_Type'Last); + -- We work with pointers to a bogus array type that is constrained with + -- the maximum possible range bound. This means that the pointer is a thin + -- pointer, which is more efficient. Since subscript checks in any case + -- must be on the logical, rather than physical bounds, safety is not + -- compromised by this approach. These types should not be used by the + -- client. + + type Table_Ptr is access all Big_Table_Type; + for Table_Ptr'Storage_Size use 0; + -- The table is actually represented as a pointer to allow reallocation. + -- This type should not be used by the client. + + type Table_Private is private; + -- Table private data that is not exported in Instance + + type Instance is record + Table : aliased Table_Ptr := null; + -- The table itself. The lower bound is the value of Low_Bound. + -- Logically the upper bound is the current value of Last (although + -- the actual size of the allocated table may be larger than this). + -- The program may only access and modify Table entries in the + -- range First .. Last. + + P : Table_Private; + end record; + + procedure Init (T : in out Instance); + -- This procedure allocates a new table of size Initial (freeing any + -- previously allocated larger table). Init must be called before using + -- the table. Init is convenient in reestablishing a table for new use. + + function Last (T : Instance) return Table_Index_Type; + pragma Inline (Last); + -- Returns the current value of the last used entry in the table, + -- which can then be used as a subscript for Table. Note that the + -- only way to modify Last is to call the Set_Last procedure. Last + -- must always be used to determine the logically last entry. + + procedure Release (T : in out Instance); + -- Storage is allocated in chunks according to the values given in the + -- Initial and Increment parameters. A call to Release releases all + -- storage that is allocated, but is not logically part of the current + -- array value. Current array values are not affected by this call. + + procedure Free (T : in out Instance); + -- Free all allocated memory for the table. A call to init is required + -- before any use of this table after calling Free. + + First : constant Table_Index_Type := Table_Low_Bound; + -- Export First as synonym for Low_Bound (parallel with use of Last) + + procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type); + pragma Inline (Set_Last); + -- This procedure sets Last to the indicated value. If necessary the + -- table is reallocated to accommodate the new value (i.e. on return + -- the allocated table has an upper bound of at least Last). If + -- Set_Last reduces the size of the table, then logically entries are + -- removed from the table. If Set_Last increases the size of the + -- table, then new entries are logically added to the table. + + procedure Increment_Last (T : in out Instance); + pragma Inline (Increment_Last); + -- Adds 1 to Last (same as Set_Last (Last + 1) + + procedure Decrement_Last (T : in out Instance); + pragma Inline (Decrement_Last); + -- Subtracts 1 from Last (same as Set_Last (Last - 1) + + procedure Append (T : in out Instance; New_Val : Table_Component_Type); + pragma Inline (Append); + -- Equivalent to: + -- Increment_Last (T); + -- T.Table (T.Last) := New_Val; + -- i.e. the table size is increased by one, and the given new item + -- stored in the newly created table element. + + procedure Append_All (T : in out Instance; New_Vals : Table_Type); + -- Appends all components of New_Vals + + procedure Set_Item + (T : in out Instance; + Index : Table_Index_Type; + Item : Table_Component_Type); + pragma Inline (Set_Item); + -- Put Item in the table at position Index. The table is expanded if + -- current table length is less than Index and in that case Last is set to + -- Index. Item will replace any value already present in the table at this + -- position. + + procedure Allocate (T : in out Instance; Num : Integer := 1); + pragma Inline (Allocate); + -- Adds Num to Last + + generic + with procedure Action + (Index : Table_Index_Type; + Item : Table_Component_Type; + Quit : in out Boolean) is <>; + procedure For_Each (Table : Instance); + -- Calls procedure Action for each component of the table Table, or until + -- one of these calls set Quit to True. + + generic + with function Lt (Comp1, Comp2 : Table_Component_Type) return Boolean; + procedure Sort_Table (Table : in out Instance); + -- This procedure sorts the components of table Table into ascending + -- order making calls to Lt to do required comparisons, and using + -- assignments to move components around. The Lt function returns True + -- if Comp1 is less than Comp2 (in the sense of the desired sort), and + -- False if Comp1 is greater than Comp2. For equal objects it does not + -- matter if True or False is returned (it is slightly more efficient + -- to return False). The sort is not stable (the order of equal items + -- in the table is not preserved). + +private + type Table_Private is record + Max : Integer; + -- Subscript of the maximum entry in the currently allocated table + + Length : Integer := 0; + -- Number of entries in currently allocated table. The value of zero + -- ensures that we initially allocate the table. + + Last_Val : Integer; + -- Current value of Last + end record; + +end GNAT.Dynamic_Tables; diff --git a/gcc/ada/g-eacodu-vms.adb b/gcc/ada/g-eacodu-vms.adb new file mode 100644 index 000000000..ae7646eb2 --- /dev/null +++ b/gcc/ada/g-eacodu-vms.adb @@ -0,0 +1,71 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 VMS version + +with System; +with System.Aux_DEC; +separate (GNAT.Exception_Actions) +procedure Core_Dump (Occurrence : Exception_Occurrence) is + + use System; + use System.Aux_DEC; + + pragma Unreferenced (Occurrence); + + SS_IMGDMP : constant := 1276; + + subtype Cond_Value_Type is Unsigned_Longword; + subtype Access_Mode_Type is + Unsigned_Word range 0 .. 3; + Access_Mode_Zero : constant Access_Mode_Type := 0; + + Status : Cond_Value_Type; + + procedure Setexv ( + Status : out Cond_Value_Type; + Vector : Unsigned_Longword := 0; + Addres : Address := Address_Zero; + Acmode : Access_Mode_Type := Access_Mode_Zero; + Prvhnd : Unsigned_Longword := 0); + pragma Interface (External, Setexv); + pragma Import_Valued_Procedure (Setexv, "SYS$SETEXV", + (Cond_Value_Type, Unsigned_Longword, Address, Access_Mode_Type, + Unsigned_Longword), + (Value, Value, Value, Value, Value)); + + procedure Lib_Signal (I : Integer); + pragma Interface (C, Lib_Signal); + pragma Import_Procedure (Lib_Signal, "LIB$SIGNAL", Mechanism => (Value)); +begin + Setexv (Status, 1, Address_Zero, 3); + Lib_Signal (SS_IMGDMP); +end Core_Dump; diff --git a/gcc/ada/g-eacodu.adb b/gcc/ada/g-eacodu.adb new file mode 100644 index 000000000..f622552c8 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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-enblsp-vms-alpha.adb b/gcc/ada/g-enblsp-vms-alpha.adb new file mode 100644 index 000000000..64af051d8 --- /dev/null +++ b/gcc/ada/g-enblsp-vms-alpha.adb @@ -0,0 +1,130 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . E X P E C T . N O N _ B L O C K I N G _ S P A W N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2005-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a target dependent non-blocking spawn function +-- for use by the VMS GNAT.Expect package (g-expect-vms.adb). This package +-- should not be directly with'ed by an application program. + +-- This version is for Alpha/VMS + +separate (GNAT.Expect) +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 Alloc_Vfork_Blocks return Integer; + pragma Import (C, Alloc_Vfork_Blocks, "decc$$alloc_vfork_blocks"); + + function Get_Vfork_Jmpbuf return System.Address; + pragma Import (C, Get_Vfork_Jmpbuf, "decc$$get_vfork_jmpbuf"); + + function Get_Current_Invo_Context + (Addr : System.Address) return Process_Id; + pragma Import (C, Get_Current_Invo_Context, + "LIB$GET_CURRENT_INVO_CONTEXT"); + + Pipe1, Pipe2, Pipe3 : aliased Pipe_Type; + + Arg : String_Access; + Arg_List : aliased array (1 .. Args'Length + 2) of System.Address; + + Command_With_Path : String_Access; + +begin + -- Create the rest of the pipes + + Set_Up_Communications + (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access); + + Command_With_Path := Locate_Exec_On_Path (Command); + + if Command_With_Path = null then + raise Invalid_Process; + end if; + + -- Fork a new process (it is not possible to do this in a subprogram) + + Descriptor.Pid := + (if Alloc_Vfork_Blocks >= 0 + then Get_Current_Invo_Context (Get_Vfork_Jmpbuf) else -1); + + -- Are we now in the child + + 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.all'Address; + + 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'Address; + end loop; + + Arg_List (Arg_List'Last) := System.Null_Address; + + -- This does not return on Unix systems + + Set_Up_Child_Communications + (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all, + 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; +end Non_Blocking_Spawn; diff --git a/gcc/ada/g-enblsp-vms-ia64.adb b/gcc/ada/g-enblsp-vms-ia64.adb new file mode 100644 index 000000000..6ac7c5a08 --- /dev/null +++ b/gcc/ada/g-enblsp-vms-ia64.adb @@ -0,0 +1,127 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . E X P E C T . N O N _ B L O C K I N G _ S P A W N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2005-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a target dependent non-blocking spawn function +-- for use by the VMS GNAT.Expect package (g-expect-vms.adb). This package +-- should not be directly with'ed by an application program. + +-- This version is for IA64/VMS + +separate (GNAT.Expect) +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 Alloc_Vfork_Blocks return Integer; + pragma Import (C, Alloc_Vfork_Blocks, "decc$$alloc_vfork_blocks"); + + function Get_Vfork_Jmpbuf return System.Address; + pragma Import (C, Get_Vfork_Jmpbuf, "decc$$get_vfork_jmpbuf"); + + function Setjmp1 (Addr : System.Address) return Process_Id; + pragma Import (C, Setjmp1, "decc$setjmp1"); + + Pipe1, Pipe2, Pipe3 : aliased Pipe_Type; + + Arg : String_Access; + Arg_List : aliased array (1 .. Args'Length + 2) of System.Address; + + Command_With_Path : String_Access; + +begin + -- Create the rest of the pipes + + Set_Up_Communications + (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access); + + Command_With_Path := Locate_Exec_On_Path (Command); + + if Command_With_Path = null then + raise Invalid_Process; + end if; + + -- Fork a new process (it is not possible to do this in a subprogram) + + Descriptor.Pid := + (if Alloc_Vfork_Blocks >= 0 then Setjmp1 (Get_Vfork_Jmpbuf) else -1); + + -- Are we now in the child + + 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.all'Address; + + 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'Address; + end loop; + + Arg_List (Arg_List'Last) := System.Null_Address; + + -- This does not return on Unix systems + + Set_Up_Child_Communications + (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all, + 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; +end Non_Blocking_Spawn; diff --git a/gcc/ada/g-encstr.adb b/gcc/ada/g-encstr.adb new file mode 100755 index 000000000..6f1411693 --- /dev/null +++ b/gcc/ada/g-encstr.adb @@ -0,0 +1,260 @@ +------------------------------------------------------------------------------ +-- -- +-- 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, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +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 new file mode 100755 index 000000000..59321dc50 --- /dev/null +++ b/gcc/ada/g-encstr.ads @@ -0,0 +1,111 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This 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 new file mode 100644 index 000000000..3c4632866 --- /dev/null +++ b/gcc/ada/g-enutst.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- 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, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a 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 new file mode 100644 index 000000000..1ba4cf8d6 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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, 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 new file mode 100644 index 000000000..77abadac8 --- /dev/null +++ b/gcc/ada/g-excact.ads @@ -0,0 +1,116 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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), and abort execution + -- of the application. + +end GNAT.Exception_Actions; diff --git a/gcc/ada/g-except.ads b/gcc/ada/g-except.ads new file mode 100644 index 000000000..dd89467a1 --- /dev/null +++ b/gcc/ada/g-except.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . E X C E P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface for raising predefined exceptions +-- with an exception message. It can be used from Pure units. + +-- There is no prohibition in Ada that prevents exceptions being raised +-- from within pure units. The raise statement is perfectly acceptable. + +-- However, it is not normally possible to raise an exception with a +-- message because the routine Ada.Exceptions.Raise_Exception is not in +-- a Pure unit. This is an annoying and unnecessary restriction and this +-- package allows for raising the standard predefined exceptions at least. + +package GNAT.Exceptions is + pragma Pure; + + type Exception_Type is limited null record; + -- Type used to specify which exception to raise + + -- Really Exception_Type is Exception_Id, but Exception_Id can't be + -- used directly since it is declared in the non-pure unit Ada.Exceptions, + + -- Exception_Id is in fact simply a pointer to the type Exception_Data + -- declared in System.Standard_Library (which is also non-pure). So what + -- we do is to define it here as a by reference type (any by reference + -- type would do), and then Import the definitions from Standard_Library. + -- Since this is a by reference type, these will be passed by reference, + -- which has the same effect as passing a pointer. + + -- This type is not private because keeping it by reference would require + -- defining it in a way (e.g a tagged type) that would drag other run time + -- files, which is unwanted in the case of e.g ravenscar where we want to + -- minimize the number of run time files needed by default. + + CE : constant Exception_Type; -- Constraint_Error + PE : constant Exception_Type; -- Program_Error + SE : constant Exception_Type; -- Storage_Error + TE : constant Exception_Type; -- Tasking_Error + -- One of these constants is used in the call to specify the exception + + procedure Raise_Exception (E : Exception_Type; Message : String); + pragma Import (Ada, Raise_Exception, "__gnat_raise_exception"); + pragma No_Return (Raise_Exception); + -- Raise specified exception with specified message + +private + pragma Import (C, CE, "constraint_error"); + pragma Import (C, PE, "program_error"); + pragma Import (C, SE, "storage_error"); + pragma Import (C, TE, "tasking_error"); + -- References to the exception structures in the standard library + +end GNAT.Exceptions; diff --git a/gcc/ada/g-exctra.adb b/gcc/ada/g-exctra.adb new file mode 100644 index 000000000..8534bbbb4 --- /dev/null +++ b/gcc/ada/g-exctra.adb @@ -0,0 +1,119 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Standard_Library; use System.Standard_Library; +with System.Soft_Links; use System.Soft_Links; + +package body GNAT.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 shall + -- accept 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 + Decorator_Traceback : Tracebacks_Array (1 .. Len); + for Decorator_Traceback'Address use Traceback; + + -- Handle the "transition" from the array stored in the exception + -- occurrence to the array expected by the decorator. + + pragma Import (Ada, Decorator_Traceback); + + begin + return Current_Decorator.all (Decorator_Traceback); + 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; + end case; + end Trace_On; + +end GNAT.Exception_Traces; diff --git a/gcc/ada/g-exctra.ads b/gcc/ada/g-exctra.ads new file mode 100644 index 000000000..00b474538 --- /dev/null +++ b/gcc/ada/g-exctra.ads @@ -0,0 +1,98 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface allowing to control *automatic* output +-- to standard error upon exception occurrences (as opposed to explicit +-- generation of traceback information using GNAT.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 GNAT.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. + +with GNAT.Traceback; use GNAT.Traceback; + +package GNAT.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, in particular, when a task dies due to an + -- unhandled exception. + ); + + -- 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 : 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 (output of raw addresses) if the provided + -- access value is null. + -- + -- Note: GNAT.Traceback.Symbolic.Symbolic_Traceback may be used as the + -- Decorator, to get a symbolic traceback. This will cause a significant + -- cpu and memory overhead. + +end GNAT.Exception_Traces; diff --git a/gcc/ada/g-expect-vms.adb b/gcc/ada/g-expect-vms.adb new file mode 100644 index 000000000..4d1a77082 --- /dev/null +++ b/gcc/ada/g-expect-vms.adb @@ -0,0 +1,1306 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . E X P E C T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2010, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VMS version + +with System; use System; +with Ada.Calendar; use Ada.Calendar; + +with 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; + + Save_Input : File_Descriptor; + Save_Output : File_Descriptor; + Save_Error : File_Descriptor; + + 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 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, "decc$dup"); + + procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); + pragma Import (C, Dup2, "decc$dup2"); + + procedure Kill (Pid : Process_Id; Sig_Num : Integer); + pragma Import (C, Kill, "decc$kill"); + + 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; + Is_Set : System.Address) return Integer; + pragma Import (C, Poll, "__gnat_expect_poll"); + -- Check whether there is any data waiting on the file descriptor + -- Out_fd, 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. + -- + -- Out_Is_Set is set to 1 if data was available, 0 otherwise. + + 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 + 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); + end if; + + GNAT.OS_Lib.Free (Descriptor.Buffer); + Descriptor.Buffer_Size := 0; + + -- 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; + 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); + + 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_Timeout | Expect_Full_Buffer => + 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); + + 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); + + 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); + + 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_Timeout | Expect_Full_Buffer => + 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_Timeout | Expect_Full_Buffer => + 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 : Integer; + -- Index in Descriptors + + begin + -- Loop until we match or we have a timeout + + loop + Num_Descriptors := + Poll (Fds'Address, Fds_Count, Timeout, Is_Set'Address); + + case Num_Descriptors is + + -- Error? + + when -1 => + Result := Expect_Internal_Error; + 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 + + 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 : 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, 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); + + if Input'Length > 0 then + Send (Process, Input); + end if; + + GNAT.OS_Lib.Close (Get_Input_Fd (Process)); + + declare + Result : Expect_Match; + + begin + -- This loop runs until the call to Expect raises Process_Died + + loop + Expect (Process, Result, ".+"); + + declare + NOutput : String_Access; + S : constant String := Expect_Out (Process); + pragma Assert (S'Length > 0); + + begin + -- Expand buffer if we need more space + + if Last + S'Length > Output'Last then + NOutput := new String (1 .. 2 * Output'Last); + 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 + 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 separate; + + ------------------------- + -- 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 + Full_Str : constant String := Str & ASCII.LF; + Last : Natural; + Result : Expect_Match; + Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); + + Discard : Natural; + pragma Unreferenced (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; + + Last := (if Add_LF then Full_Str'Last else Full_Str'Last - 1); + + Call_Filters (Descriptor, Full_Str (Full_Str'First .. Last), Input); + + Discard := + Write (Descriptor.Input_Fd, + Full_Str'Address, + Last - Full_Str'First + 1); + -- Shouldn't we at least have a pragma Assert on the result ??? + 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); + -- ??? 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); + + begin + -- Since the code between fork and exec on VMS executes + -- in the context of the parent process, 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. + + Save_Input := Dup (GNAT.OS_Lib.Standin); + Save_Output := Dup (GNAT.OS_Lib.Standout); + Save_Error := Dup (GNAT.OS_Lib.Standerr); + + -- 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); + 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 + begin + -- Create the pipes + + if Create_Pipe (Pipe1) /= 0 then + return; + end if; + + if Create_Pipe (Pipe2) /= 0 then + return; + end if; + + Pid.Input_Fd := Pipe1.Output; + Pid.Output_Fd := Pipe2.Input; + + if Err_To_Out then + Pipe3.all := Pipe2.all; + else + if Create_Pipe (Pipe3) /= 0 then + return; + end if; + end if; + + Pid.Error_Fd := Pipe3.Input; + 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 + + Dup2 (Save_Input, GNAT.OS_Lib.Standin); + Dup2 (Save_Output, GNAT.OS_Lib.Standout); + Dup2 (Save_Error, GNAT.OS_Lib.Standerr); + + Close (Save_Input); + Close (Save_Output); + Close (Save_Error); + + Close (Pipe1.Input); + Close (Pipe2.Output); + Close (Pipe3.Output); + 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.adb b/gcc/ada/g-expect.adb new file mode 100644 index 000000000..c8b368fc5 --- /dev/null +++ b/gcc/ada/g-expect.adb @@ -0,0 +1,1453 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . E X P E C T -- +-- -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; +with System.OS_Constants; use System.OS_Constants; +with Ada.Calendar; use Ada.Calendar; + +with 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; + Is_Set : System.Address) return Integer; + pragma Import (C, Poll, "__gnat_expect_poll"); + -- Check whether there is any data waiting on the file descriptor + -- Out_fd, 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. + -- + -- Out_Is_Set is set to 1 if data was available, 0 otherwise. + + 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_Timeout | Expect_Full_Buffer => + 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_Timeout | Expect_Full_Buffer => + 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_Timeout | Expect_Full_Buffer => + 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 : Integer; + -- Index in Descriptors + + begin + -- Loop until we match or we have a timeout + + loop + Num_Descriptors := + Poll (Fds'Address, Fds_Count, Timeout, Is_Set'Address); + + case Num_Descriptors is + + -- Error? + + when -1 => + Result := Expect_Internal_Error; + 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 + + 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 : 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, 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); + + 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, ".+"); + + 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 + 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 + -- Create the rest of the pipes + + Set_Up_Communications + (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access); + + Command_With_Path := Locate_Exec_On_Path (Command); + + if Command_With_Path = null then + raise Invalid_Process; + end if; + + -- 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 commands are not executed on Unix systems, and are only + -- required for Windows systems. We are now in the parent process. + + -- 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 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 + 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 + return; + 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 new file mode 100644 index 000000000..18cf99589 --- /dev/null +++ b/gcc/ada/g-expect.ads @@ -0,0 +1,649 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . E X P E C T -- +-- -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Currently this package is implemented on all native GNAT ports except +-- for VMS. 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 Except + -- 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-flocon.ads b/gcc/ada/g-flocon.ads new file mode 100644 index 000000000..ea60768db --- /dev/null +++ b/gcc/ada/g-flocon.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2005 AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Control functions for floating-point unit + +package GNAT.Float_Control is + + procedure 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. + +private + pragma Import (C, Reset, "__gnat_init_float"); + +end GNAT.Float_Control; diff --git a/gcc/ada/g-heasor.adb b/gcc/ada/g-heasor.adb new file mode 100644 index 000000000..caa2dacc9 --- /dev/null +++ b/gcc/ada/g-heasor.adb @@ -0,0 +1,132 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . H E A P _ S O R T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package 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 new file mode 100644 index 000000000..177f40ce7 --- /dev/null +++ b/gcc/ada/g-heasor.ads @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . H E A P _ S O R T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 new file mode 100644 index 000000000..60f307bba --- /dev/null +++ b/gcc/ada/g-hesora.adb @@ -0,0 +1,136 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . H E A P _ S O R T _ A -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit; + +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 new file mode 100644 index 000000000..11b896919 --- /dev/null +++ b/gcc/ada/g-hesora.ads @@ -0,0 +1,71 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . H E A P _ S O R T _ A -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + +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 new file mode 100644 index 000000000..3bcc01c0b --- /dev/null +++ b/gcc/ada/g-hesorg.adb @@ -0,0 +1,144 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . H E A P _ S O R T _ G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package 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 new file mode 100644 index 000000000..e7b38808c --- /dev/null +++ b/gcc/ada/g-hesorg.ads @@ -0,0 +1,90 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . H E A P _ S O R T _ G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2006, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 new file mode 100644 index 000000000..aa6c6b7bc --- /dev/null +++ b/gcc/ada/g-htable.adb @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . H T A B L E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is 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; + +package body GNAT.HTable is +end GNAT.HTable; diff --git a/gcc/ada/g-htable.ads b/gcc/ada/g-htable.ads new file mode 100644 index 000000000..a080ee831 --- /dev/null +++ b/gcc/ada/g-htable.ads @@ -0,0 +1,229 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . H T A B L E -- +-- -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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. + +-- Note: actual code is found in System.HTable (s-htable.ads/adb) since +-- this facility is accessed from run time routines, but clients should +-- always access the version supplied via GNAT.HTable. + +pragma Compiler_Unit; + +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. + + ------------------- + -- 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 package Simple_HTable renames System.HTable.Simple_HTable; + + -- For convenience of reference here is what this package has in it: + + -- 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 not 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 : 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. + + -- procedure Get_Next (K : 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 undefined. + -- -- 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 package Static_HTable renames System.HTable.Static_HTable; + + -- For convenience of reference here is what this package has in it: + + -- generic + -- type Header_Num is range <>; + -- -- An integer type indicating the number and range of hash headers. + + -- type Element (<>) is limited private; + -- -- The type of element to be stored + + -- type Elmt_Ptr is private; + -- -- The type used to reference an element (will usually be an + -- -- access type, but could be some other form of type such as + -- -- an integer type). + + -- Null_Ptr : Elmt_Ptr; + -- -- The null value of the Elmt_Ptr type. + + -- with procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); + -- with function Next (E : Elmt_Ptr) return Elmt_Ptr; + -- -- The type must provide an internal link for the sake of the + -- -- staticness of the HTable. + + -- type Key is limited private; + -- with function Get_Key (E : Elmt_Ptr) return Key; + -- with function Hash (F : Key) return Header_Num; + -- with function Equal (F1, F2 : Key) return Boolean; + + -- package Static_HTable is + + -- 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. + + -- 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 function Hash renames System.HTable.Hash; + + -- generic + -- type Header_Num is range <>; + -- function Hash (Key : String) return Header_Num; + +end GNAT.HTable; diff --git a/gcc/ada/g-io-put-vxworks.adb b/gcc/ada/g-io-put-vxworks.adb new file mode 100644 index 000000000..2fb89fd26 --- /dev/null +++ b/gcc/ada/g-io-put-vxworks.adb @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2006, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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-put.adb b/gcc/ada/g-io-put.adb new file mode 100644 index 000000000..1f1c31900 --- /dev/null +++ b/gcc/ada/g-io-put.adb @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2006, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- zfp version of Put (C : Character) + +separate (GNAT.IO) +procedure Put (C : Character) is + procedure Putchar (C : Character); + pragma Import (C, Putchar, "putchar"); +begin + Putchar (C); +end Put; diff --git a/gcc/ada/g-io.adb b/gcc/ada/g-io.adb new file mode 100644 index 000000000..d7b5b1fc0 --- /dev/null +++ b/gcc/ada/g-io.adb @@ -0,0 +1,193 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2006, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package 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 new file mode 100644 index 000000000..89aaa992e --- /dev/null +++ b/gcc/ada/g-io.ads @@ -0,0 +1,93 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2005, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 new file mode 100644 index 000000000..0df6e5951 --- /dev/null +++ b/gcc/ada/g-io_aux.adb @@ -0,0 +1,107 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . I O _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2005, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +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 new file mode 100644 index 000000000..91a7153b6 --- /dev/null +++ b/gcc/ada/g-io_aux.ads @@ -0,0 +1,56 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . I O _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2005, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 new file mode 100644 index 000000000..5449dc6e3 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..9dde8fb45 --- /dev/null +++ b/gcc/ada/g-locfil.ads @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . L O C K _ F I L E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package 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 specified + -- 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 new file mode 100644 index 000000000..44937f9d6 --- /dev/null +++ b/gcc/ada/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-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; + +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 new file mode 100644 index 000000000..c415a24cf --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..1d59069d1 --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..4deac482b --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..f8a462bc2 --- /dev/null +++ b/gcc/ada/g-md5.adb @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . M D 5 -- +-- -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package 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 new file mode 100644 index 000000000..70eb007b3 --- /dev/null +++ b/gcc/ada/g-md5.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . M D 5 -- +-- -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package 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 new file mode 100644 index 000000000..5b8b3c05b --- /dev/null +++ b/gcc/ada/g-memdum.adb @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2007, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; +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 : System.Address; Count : Natural) is + Ctr : Natural := Count; + -- Count of bytes left to output + + Adr : Address := Addr; + -- Current address + + N : Natural := 0; + -- Number of bytes output on current line + + C : Character; + -- Character at current storage address + + AIL : constant := Address_Image_Length - 4 + 2; + -- Number of chars in initial address + colon + space + + Line_Len : constant Natural := AIL + 3 * 16 + 2 + 16; + -- Line length for entire line + + Line_Buf : String (1 .. Line_Len); + + 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 + while Ctr /= 0 loop + + -- Start of line processing + + if N = 0 then + declare + S : constant String := Image (Adr); + begin + Line_Buf (1 .. AIL) := S (4 .. S'Length - 1) & ": "; + Line_Buf (AIL + 1 .. Line_Buf'Last) := (others => ' '); + Line_Buf (AIL + 3 * 16 + 1) := '"'; + end; + 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; + + return; + end Dump; + +end GNAT.Memory_Dump; diff --git a/gcc/ada/g-memdum.ads b/gcc/ada/g-memdum.ads new file mode 100644 index 000000000..36b13e7cc --- /dev/null +++ b/gcc/ada/g-memdum.ads @@ -0,0 +1,56 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + 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. + +end GNAT.Memory_Dump; diff --git a/gcc/ada/g-moreex.adb b/gcc/ada/g-moreex.adb new file mode 100644 index 000000000..ab3a30655 --- /dev/null +++ b/gcc/ada/g-moreex.adb @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +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 new file mode 100644 index 000000000..7412b074f --- /dev/null +++ b/gcc/ada/g-moreex.ads @@ -0,0 +1,76 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides 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 new file mode 100644 index 000000000..efec74af1 --- /dev/null +++ b/gcc/ada/g-os_lib.adb @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . O S _ L I B -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package 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 new file mode 100644 index 000000000..dafd090d4 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..c637d1c0d --- /dev/null +++ b/gcc/ada/g-pehage.adb @@ -0,0 +1,2599 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +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); + 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 + Free_Word (WT.Table (W)); + 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; + + --------------- + -- Free_Word -- + --------------- + + procedure Free_Word (W : in out Word_Type) is + begin + if W /= null then + Free (W); + end if; + end Free_Word; + + ---------------------------- + -- 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)); + 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 new file mode 100644 index 000000000..8e72088e3 --- /dev/null +++ b/gcc/ada/g-pehage.ads @@ -0,0 +1,240 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a 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 to define 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 new file mode 100644 index 000000000..e35c86cb2 --- /dev/null +++ b/gcc/ada/g-rannum.adb @@ -0,0 +1,308 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 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 -- + ------------ + + 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 new file mode 100644 index 000000000..353e21cd0 --- /dev/null +++ b/gcc/ada/g-rannum.ads @@ -0,0 +1,138 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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. + +with System.Random_Numbers; +with Interfaces; use Interfaces; + +package GNAT.Random_Numbers 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 digits <>; + function Random_Float (Gen : Generator) return Result_Subtype; + -- Returns pseudo-random numbers uniformly distributed on [0 .. 1) + + 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 new file mode 100644 index 000000000..d0ca5d494 --- /dev/null +++ b/gcc/ada/g-regexp.adb @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . R E G E X P -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package 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 new file mode 100644 index 000000000..4300ebf40 --- /dev/null +++ b/gcc/ada/g-regexp.ads @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . R E G E X P -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 new file mode 100644 index 000000000..ba63b3c83 --- /dev/null +++ b/gcc/ada/g-regist.adb @@ -0,0 +1,545 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . R E G I S T 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 -- +-- . -- +-- -- +-- 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#; + + begin + case Mode is + when Read_Only => + return KEY_READ; + + when Read_Write => + return KEY_READ + KEY_WRITE; + end case; + end To_C_Mode; + +end GNAT.Registry; diff --git a/gcc/ada/g-regist.ads b/gcc/ada/g-regist.ads new file mode 100644 index 000000000..52dc6aadb --- /dev/null +++ b/gcc/ada/g-regist.ads @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . R E G I S T R Y -- +-- -- +-- 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 -- +-- . -- +-- -- +-- 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); + -- Access mode for the registry key + + 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 ** Integer'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 new file mode 100644 index 000000000..92ab7c3a7 --- /dev/null +++ b/gcc/ada/g-regpat.adb @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package 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 new file mode 100644 index 000000000..2290df8a6 --- /dev/null +++ b/gcc/ada/g-regpat.ads @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package 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-sechas.adb b/gcc/ada/g-sechas.adb new file mode 100644 index 000000000..78eddc3a2 --- /dev/null +++ b/gcc/ada/g-sechas.adb @@ -0,0 +1,366 @@ +------------------------------------------------------------------------------ +-- -- +-- 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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 + + use Ada.Streams; + + 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; + + ----------- + -- 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); + end Final; + + ------------ + -- Update -- + ------------ + + procedure Update + (C : in out Context; + S : String; + Fill_Buffer : Fill_Buffer_Access) + is + Last : Natural := S'First - 1; + + begin + C.M_State.Length := C.M_State.Length + S'Length; + + 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; + + end H; + + ------------------------- + -- Hash_Function_State -- + ------------------------- + + package body Hash_Function_State is + + ------------- + -- To_Hash -- + ------------- + + procedure To_Hash (H : State; H_Bits : out Stream_Element_Array) is + Hash_Words : constant Natural := H'Size / Word'Size; + Result : State (1 .. Hash_Words) := + H (H'Last - Hash_Words + 1 .. H'Last); + + R_SEA : Stream_Element_Array (1 .. Result'Size / 8); + for R_SEA'Address use Result'Address; + pragma Import (Ada, R_SEA); + + begin + if System.Default_Bit_Order /= Hash_Bit_Order then + for J in Result'Range loop + Swap (Result (J)'Address); + end loop; + end if; + + -- Return truncated hash + + pragma Assert (H_Bits'Length <= R_SEA'Length); + H_Bits := R_SEA (R_SEA'First .. R_SEA'First + H_Bits'Length - 1); + end To_Hash; + + end Hash_Function_State; + +end GNAT.Secure_Hashes; diff --git a/gcc/ada/g-sechas.ads b/gcc/ada/g-sechas.ads new file mode 100644 index 000000000..7fe34b172 --- /dev/null +++ b/gcc/ada/g-sechas.ads @@ -0,0 +1,193 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S E C U R E _ H A S H E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides common supporting code for a family of secure +-- hash functions (including MD5 and the FIPS PUB 180-3 functions SHA-1, +-- SHA-224, SHA-256, SHA-384 and SHA-512). + +-- This is an internal unit and should be not used directly in applications. +-- Use GNAT.MD5 and GNAT.SHA* instead. + +with Ada.Streams; +with Interfaces; +with System; + +package GNAT.Secure_Hashes is + + type Buffer_Type is new String; + for Buffer_Type'Alignment use 8; + -- Secure hash functions use a string buffer that is also accessed as an + -- array of words, which may require up to 64 bit alignment. + + -- The function-independent part of processing state: A buffer of data + -- being accumulated until a complete block is ready for hashing. + + type Message_State (Block_Length : Natural) is record + Last : Natural := 0; + -- Index of last used element in Buffer + + Length : Interfaces.Unsigned_64 := 0; + -- Total length of processed data + + Buffer : Buffer_Type (1 .. Block_Length); + -- Data buffer + end record; + + -- The function-specific part of processing state: + + -- Each hash function maintains an internal state as an array of words, + -- which is ultimately converted to a stream representation with the + -- appropriate bit order. + + generic + type Word is mod <>; + -- Either 32 or 64 bits + + with procedure Swap (X : System.Address); + -- Byte swapping function for a Word at X + + Hash_Bit_Order : System.Bit_Order; + -- Bit order of the produced hash + + package Hash_Function_State is + + type State is array (Natural range <>) of Word; + -- Used to store a hash function's internal state + + procedure To_Hash + (H : State; + H_Bits : out Ada.Streams.Stream_Element_Array); + -- Convert H to stream representation with the given bit order. + -- If H_Bits is smaller than the internal hash state, then the state + -- is truncated. + + end Hash_Function_State; + + -- Generic hashing framework: + -- The user interface for each implemented secure hash function is an + -- instance of this generic package. + + generic + Block_Words : Natural; + -- Number of words in each block + + State_Words : Natural; + -- Number of words in internal state + + Hash_Words : Natural; + -- Number of words in the final hash (must be no greater than + -- State_Words). + + Hash_Bit_Order : System.Bit_Order; + -- Bit order used for conversion between bit representation and word + -- representation. + + with package Hash_State is new Hash_Function_State (<>); + -- Hash function state package + + Initial_State : Hash_State.State; + -- Initial value of the hash function state + + with procedure Transform + (H : in out Hash_State.State; + M : in out Message_State); + -- Transformation function updating H by processing a complete data + -- block from M. + + package H is + + -- The visible part of H is the interface to secure hashing functions + -- that is exposed to user applications, and is intended to remain + -- a stable interface. + + pragma Assert (Hash_Words <= State_Words); + + type Context is private; + -- The internal processing state of the hashing function + + function "=" (L, R : Context) return Boolean is abstract; + -- Context is the internal, implementation defined intermediate state + -- in a hash computation, and no specific semantics can be expected on + -- equality of context values. Only equality of final hash values (as + -- returned by the [Wide_]Digest functions below) is meaningful. + + Initial_Context : constant Context; + -- Initial value of a Context object. May be used to reinitialize + -- a Context value by simple assignment of this value to the object. + + procedure Update (C : in out Context; Input : String); + procedure Wide_Update (C : in out Context; Input : Wide_String); + procedure Update + (C : in out Context; + Input : Ada.Streams.Stream_Element_Array); + -- Update C to process the given input. Successive calls to Update are + -- equivalent to a single call with the concatenation of the inputs. For + -- the Wide_String version, each Wide_Character is processed low order + -- byte first. + + Word_Length : constant Natural := Hash_State.Word'Size / 8; + Hash_Length : constant Natural := Hash_Words * Word_Length; + + subtype Message_Digest is String (1 .. 2 * Hash_Length); + -- The fixed-length string returned by Digest, providing the hash in + -- hexadecimal representation. + + function Digest (C : Context) return Message_Digest; + -- Return hash for the data accumulated with C in hexadecimal + -- representation. + + function Digest (S : String) return Message_Digest; + function Wide_Digest (W : Wide_String) return Message_Digest; + function Digest + (A : Ada.Streams.Stream_Element_Array) return Message_Digest; + -- These functions are equivalent to the corresponding Update (or + -- Wide_Update) on a default initialized Context, followed by Digest + -- on the resulting Context. + + private + + Block_Length : constant Natural := Block_Words * Word_Length; + -- Length in bytes of a data block + + type Context is record + H_State : Hash_State.State (0 .. State_Words - 1) := Initial_State; + -- Function-specific state + + M_State : Message_State (Block_Length); + -- Function-independent state (block buffer) + end record; + + Initial_Context : constant Context := (others => <>); + -- Initial values are provided by default initialization of Context + + end H; + +end GNAT.Secure_Hashes; diff --git a/gcc/ada/g-sehamd.adb b/gcc/ada/g-sehamd.adb new file mode 100644 index 000000000..cd8a1f516 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 new file mode 100644 index 000000000..234063632 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..b5e968953 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..898f2adfa --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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-semaph.adb b/gcc/ada/g-semaph.adb new file mode 100644 index 000000000..13793a862 --- /dev/null +++ b/gcc/ada/g-semaph.adb @@ -0,0 +1,86 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S E M A P H O R E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2005, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Semaphores is + + ------------------------ + -- Counting_Semaphore -- + ------------------------ + + protected body Counting_Semaphore is + + ----------- + -- Seize -- + ----------- + + entry Seize when Count > 0 is + begin + Count := Count - 1; + end Seize; + + ------------- + -- Release -- + ------------- + + procedure Release is + begin + Count := Count + 1; + end Release; + end Counting_Semaphore; + + ---------------------- + -- Binary_Semaphore -- + ---------------------- + + protected body Binary_Semaphore is + + ----------- + -- Seize -- + ----------- + + entry Seize when Available is + begin + Available := False; + end Seize; + + ------------- + -- Release -- + ------------- + + procedure Release is + begin + Available := True; + end Release; + end Binary_Semaphore; + +end GNAT.Semaphores; diff --git a/gcc/ada/g-semaph.ads b/gcc/ada/g-semaph.ads new file mode 100644 index 000000000..a1ed4e9e7 --- /dev/null +++ b/gcc/ada/g-semaph.ads @@ -0,0 +1,99 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S E M A P H O R E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2003-2005, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides classic counting semaphores and binary semaphores. +-- Both types are visibly defined as protected types so that users can make +-- conditional and timed calls when appropriate. + +with System; + +package GNAT.Semaphores is + + Default_Ceiling : constant System.Priority := System.Default_Priority; + -- A convenient value for the priority discriminants that follow + + ------------------------ + -- Counting_Semaphore -- + ------------------------ + + protected type Counting_Semaphore + (Initial_Value : Natural; + -- A counting semaphore contains an internal counter. The initial + -- value of this counter is set by clients via the discriminant. + + Ceiling : System.Priority) + -- Users must specify the ceiling priority for the object. If the + -- Real-Time Systems Annex is not in use this value is not important. + is + pragma Priority (Ceiling); + + entry Seize; + -- Blocks caller until/unless the semaphore's internal counter is + -- greater than zero. Decrements the semaphore's internal counter when + -- executed. + + procedure Release; + -- Increments the semaphore's internal counter + + private + Count : Natural := Initial_Value; + end Counting_Semaphore; + + ---------------------- + -- Binary_Semaphore -- + ---------------------- + + protected type Binary_Semaphore + (Initially_Available : Boolean; + -- Binary semaphores are either available or not; there is no internal + -- count involved. The discriminant value determines whether the + -- individual object is initially available. + + Ceiling : System.Priority) + -- Users must specify the ceiling priority for the object. If the + -- Real-Time Systems Annex is not in use this value is not important. + is + pragma Priority (Ceiling); + + entry Seize; + -- Blocks the caller unless/until semaphore is available. After + -- execution the semaphore is no longer available. + + procedure Release; + -- Makes the semaphore available + + private + Available : Boolean := Initially_Available; + end Binary_Semaphore; + +end GNAT.Semaphores; diff --git a/gcc/ada/g-sercom-linux.adb b/gcc/ada/g-sercom-linux.adb new file mode 100644 index 000000000..3432f86b3 --- /dev/null +++ b/gcc/ada/g-sercom-linux.adb @@ -0,0 +1,302 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the 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 GNAT.OS_Lib; use GNAT.OS_Lib; + +package body GNAT.Serial_Communications is + + 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"); + + O_RDWR : constant := 8#02#; + O_NOCTTY : constant := 8#0400#; + O_NDELAY : constant := 8#04000#; + FNDELAY : constant := O_NDELAY; + F_SETFL : constant := 4; + TCSANOW : constant := 0; + TCIFLUSH : constant := 0; + CLOCAL : constant := 8#04000#; + CREAD : constant := 8#0200#; + CSTOPB : constant := 8#0100#; + CRTSCTS : constant := 8#020000000000#; + PARENB : constant := 8#00400#; + PARODD : constant := 8#01000#; + + -- c_cc indexes + + VTIME : constant := 5; + VMIN : constant := 6; + + C_Data_Rate : constant array (Data_Rate) of unsigned := + (B1200 => 8#000011#, + B2400 => 8#000013#, + B4800 => 8#000014#, + B9600 => 8#000015#, + B19200 => 8#000016#, + B38400 => 8#000017#, + B57600 => 8#010001#, + B115200 => 8#010002#); + + C_Bits : constant array (Data_Bits) of unsigned := + (CS7 => 8#040#, CS8 => 8#060#); + + C_Stop_Bits : constant array (Stop_Bits_Number) of unsigned := + (One => 0, Two => CSTOPB); + + C_Parity : constant array (Parity_Check) of unsigned := + (None => 0, Odd => PARENB or PARODD, Even => 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 + 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 & " (" & Integer'Image (Error) & ')'; + 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; + Timeout : Duration := 10.0) + is + 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 CLOCAL + or CREAD + or CRTSCTS; + Current.c_lflag := 0; + Current.c_iflag := 0; + Current.c_oflag := 0; + 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 new file mode 100644 index 000000000..cc6123bbc --- /dev/null +++ b/gcc/ada/g-sercom-mingw.adb @@ -0,0 +1,273 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Windows implementation of this package + +with Ada.Unchecked_Deallocation; use Ada; +with Ada.Streams; use Ada.Streams; + +with System; use System; +with System.Communication; use System.Communication; +with System.CRTL; use System.CRTL; +with System.Win32; use System.Win32; +with System.Win32.Ext; use System.Win32.Ext; + +package body GNAT.Serial_Communications is + + -- 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 + return Port_Name ("COM" & N_Img (N_Img'First + 1 .. N_Img'Last) & ':'); + 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 = 0 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 & " (" & DWORD'Image (Error) & ')'; + 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; + Timeout : Duration := 10.0) + is + 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.fOutxCtsFlow := 0; + Com_Settings.fOutxDsrFlow := 0; + Com_Settings.fDsrSensitivity := 0; + Com_Settings.fDtrControl := DTR_CONTROL_DISABLE; + Com_Settings.fOutX := 0; + Com_Settings.fInX := 0; + Com_Settings.fRtsControl := RTS_CONTROL_DISABLE; + 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 + + if Block then + Com_Time_Out := (others => 0); + 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 new file mode 100644 index 000000000..a39d4dbbc --- /dev/null +++ b/gcc/ada/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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + 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 new file mode 100644 index 000000000..c891cc87a --- /dev/null +++ b/gcc/ada/g-sercom.ads @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Serial communications package, implemented on Windows and GNU/Linux + +with Ada.Streams; +with Interfaces.C; + +package GNAT.Serial_Communications is + + 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 + (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 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; + 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. Note that the timeout precision + -- may be limited on some implementation (e.g. on GNU/Linux the maximum + -- precision is a tenth of seconds). + + 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 := + (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 new file mode 100644 index 000000000..900ec7220 --- /dev/null +++ b/gcc/ada/g-sestin.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2005 AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides 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 new file mode 100644 index 000000000..edc6b43d9 --- /dev/null +++ b/gcc/ada/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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..06fe9bc8e --- /dev/null +++ b/gcc/ada/g-sha1.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S H A 1 -- +-- -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package 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 new file mode 100644 index 000000000..4b81112bb --- /dev/null +++ b/gcc/ada/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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..a638ff974 --- /dev/null +++ b/gcc/ada/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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..7a63d7e6e --- /dev/null +++ b/gcc/ada/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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..331db7d34 --- /dev/null +++ b/gcc/ada/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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..c9845f14d --- /dev/null +++ b/gcc/ada/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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..4495a150d --- /dev/null +++ b/gcc/ada/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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..330337ceb --- /dev/null +++ b/gcc/ada/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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..4b27c7db1 --- /dev/null +++ b/gcc/ada/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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..dcdb23690 --- /dev/null +++ b/gcc/ada/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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..e2f9f9137 --- /dev/null +++ b/gcc/ada/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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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-signal.adb b/gcc/ada/g-signal.adb new file mode 100644 index 000000000..37ba59465 --- /dev/null +++ b/gcc/ada/g-signal.adb @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . S I G N A L 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 System.Interrupts; + +package body GNAT.Signals is + + package SI renames System.Interrupts; + + ------------------ + -- Block_Signal -- + ------------------ + + procedure Block_Signal (Signal : Ada.Interrupts.Interrupt_ID) is + begin + SI.Block_Interrupt (SI.Interrupt_ID (Signal)); + end Block_Signal; + + ---------------- + -- Is_Blocked -- + ---------------- + + function Is_Blocked (Signal : Ada.Interrupts.Interrupt_ID) return Boolean is + begin + return SI.Is_Blocked (SI.Interrupt_ID (Signal)); + end Is_Blocked; + + -------------------- + -- Unblock_Signal -- + -------------------- + + procedure Unblock_Signal (Signal : Ada.Interrupts.Interrupt_ID) is + begin + SI.Unblock_Interrupt (SI.Interrupt_ID (Signal)); + end Unblock_Signal; + +end GNAT.Signals; diff --git a/gcc/ada/g-signal.ads b/gcc/ada/g-signal.ads new file mode 100644 index 000000000..2a2780469 --- /dev/null +++ b/gcc/ada/g-signal.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . S I G N A L S -- +-- -- +-- S p e c -- +-- -- +-- 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 package provides operations for querying and setting the blocked +-- status of signals. + +-- This package is supported only on targets where Ada.Interrupts.Interrupt_ID +-- corresponds to software signals on the target, and where System.Interrupts +-- provides the ability to block and unblock signals. + +with Ada.Interrupts; + +package GNAT.Signals is + + procedure Block_Signal (Signal : Ada.Interrupts.Interrupt_ID); + -- Block "Signal" at the process level + + procedure Unblock_Signal (Signal : Ada.Interrupts.Interrupt_ID); + -- Unblock "Signal" at the process level + + function Is_Blocked (Signal : Ada.Interrupts.Interrupt_ID) return Boolean; + -- "Signal" blocked at the process level? + +end GNAT.Signals; diff --git a/gcc/ada/g-soccon.ads b/gcc/ada/g-soccon.ads new file mode 100644 index 000000000..4b904d911 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..14f392e71 --- /dev/null +++ b/gcc/ada/g-socket-dummy.adb @@ -0,0 +1,34 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma No_Body; diff --git a/gcc/ada/g-socket-dummy.ads b/gcc/ada/g-socket-dummy.ads new file mode 100644 index 000000000..6536472ce --- /dev/null +++ b/gcc/ada/g-socket-dummy.ads @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is a placeholder for the sockets binding for platforms where +-- it is not implemented. + +package GNAT.Sockets is + pragma Unimplemented_Unit; +end GNAT.Sockets; diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb new file mode 100644 index 000000000..6bca4909a --- /dev/null +++ b/gcc/ada/g-socket.adb @@ -0,0 +1,2577 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Streams; use Ada.Streams; +with Ada.Exceptions; use Ada.Exceptions; +with Ada.Finalization; +with Ada.Unchecked_Conversion; + +with Interfaces.C.Strings; + +with GNAT.Sockets.Thin_Common; use GNAT.Sockets.Thin_Common; +with GNAT.Sockets.Thin; use GNAT.Sockets.Thin; + +with GNAT.Sockets.Linker_Options; +pragma Warnings (Off, GNAT.Sockets.Linker_Options); +-- Need to include pragma Linker_Options which is platform dependent + +with System; use System; +with System.Communication; use System.Communication; +with System.CRTL; use System.CRTL; +with System.Task_Lock; + +package body GNAT.Sockets is + + package C renames Interfaces.C; + + use type C.int; + + ENOERROR : constant := 0; + + Netdb_Buffer_Size : constant := SOSC.Need_Netdb_Buffer * 1024; + Need_Netdb_Lock : constant Boolean := SOSC.Need_Netdb_Lock /= 0; + -- The network database functions gethostbyname, gethostbyaddr, + -- getservbyname and getservbyport can either be guaranteed task safe by + -- the operating system, or else return data through a user-provided buffer + -- to ensure concurrent uses do not interfere. + + -- Correspondence tables + + Levels : constant array (Level_Type) of C.int := + (Socket_Level => SOSC.SOL_SOCKET, + IP_Protocol_For_IP_Level => SOSC.IPPROTO_IP, + IP_Protocol_For_UDP_Level => SOSC.IPPROTO_UDP, + IP_Protocol_For_TCP_Level => SOSC.IPPROTO_TCP); + + Modes : constant array (Mode_Type) of C.int := + (Socket_Stream => SOSC.SOCK_STREAM, + Socket_Datagram => SOSC.SOCK_DGRAM); + + Shutmodes : constant array (Shutmode_Type) of C.int := + (Shut_Read => SOSC.SHUT_RD, + Shut_Write => SOSC.SHUT_WR, + Shut_Read_Write => SOSC.SHUT_RDWR); + + Requests : constant array (Request_Name) of C.int := + (Non_Blocking_IO => SOSC.FIONBIO, + N_Bytes_To_Read => SOSC.FIONREAD); + + Options : constant array (Option_Name) of C.int := + (Keep_Alive => SOSC.SO_KEEPALIVE, + Reuse_Address => SOSC.SO_REUSEADDR, + Broadcast => SOSC.SO_BROADCAST, + Send_Buffer => SOSC.SO_SNDBUF, + Receive_Buffer => SOSC.SO_RCVBUF, + Linger => SOSC.SO_LINGER, + Error => SOSC.SO_ERROR, + No_Delay => SOSC.TCP_NODELAY, + Add_Membership => SOSC.IP_ADD_MEMBERSHIP, + Drop_Membership => SOSC.IP_DROP_MEMBERSHIP, + Multicast_If => SOSC.IP_MULTICAST_IF, + Multicast_TTL => SOSC.IP_MULTICAST_TTL, + Multicast_Loop => SOSC.IP_MULTICAST_LOOP, + Receive_Packet_Info => SOSC.IP_PKTINFO, + Send_Timeout => SOSC.SO_SNDTIMEO, + Receive_Timeout => SOSC.SO_RCVTIMEO); + -- ??? Note: for OpenSolaris, Receive_Packet_Info should be IP_RECVPKTINFO, + -- but for Linux compatibility this constant is the same as IP_PKTINFO. + + Flags : constant array (0 .. 3) of C.int := + (0 => SOSC.MSG_OOB, -- Process_Out_Of_Band_Data + 1 => SOSC.MSG_PEEK, -- Peek_At_Incoming_Data + 2 => SOSC.MSG_WAITALL, -- Wait_For_A_Full_Reception + 3 => SOSC.MSG_EOR); -- Send_End_Of_Record + + Socket_Error_Id : constant Exception_Id := Socket_Error'Identity; + Host_Error_Id : constant Exception_Id := Host_Error'Identity; + + Hex_To_Char : constant String (1 .. 16) := "0123456789ABCDEF"; + -- Use to print in hexadecimal format + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Resolve_Error + (Error_Value : Integer; + From_Errno : Boolean := True) return Error_Type; + -- Associate an enumeration value (error_type) to en error value (errno). + -- From_Errno prevents from mixing h_errno with errno. + + function To_Name (N : String) return Name_Type; + function To_String (HN : Name_Type) return String; + -- Conversion functions + + function To_Int (F : Request_Flag_Type) return C.int; + -- Return the int value corresponding to the specified flags combination + + function Set_Forced_Flags (F : C.int) return C.int; + -- Return F with the bits from SOSC.MSG_Forced_Flags forced set + + function Short_To_Network + (S : C.unsigned_short) return C.unsigned_short; + pragma Inline (Short_To_Network); + -- Convert a port number into a network port number + + function Network_To_Short + (S : C.unsigned_short) return C.unsigned_short + renames Short_To_Network; + -- Symmetric operation + + function Image + (Val : Inet_Addr_VN_Type; + Hex : Boolean := False) return String; + -- Output an array of inet address components in hex or decimal mode + + function Is_IP_Address (Name : String) return Boolean; + -- Return true when Name is an IP address in standard dot notation + + procedure Netdb_Lock; + pragma Inline (Netdb_Lock); + procedure Netdb_Unlock; + pragma Inline (Netdb_Unlock); + -- Lock/unlock operation used to protect netdb access for platforms that + -- require such protection. + + function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr; + procedure To_Inet_Addr + (Addr : In_Addr; + Result : out Inet_Addr_Type); + -- Conversion functions + + function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type; + -- Conversion function + + function To_Service_Entry (E : Servent_Access) return Service_Entry_Type; + -- Conversion function + + function Value (S : System.Address) return String; + -- Same as Interfaces.C.Strings.Value but taking a System.Address (on VMS, + -- chars_ptr is a 32-bit pointer, and here we need a 64-bit version). + + function To_Timeval (Val : Timeval_Duration) return Timeval; + -- Separate Val in seconds and microseconds + + function To_Duration (Val : Timeval) return Timeval_Duration; + -- Reconstruct a Duration value from a Timeval record (seconds and + -- microseconds). + + procedure Raise_Socket_Error (Error : Integer); + -- Raise Socket_Error with an exception message describing the error code + -- from errno. + + procedure Raise_Host_Error (H_Error : Integer); + -- Raise Host_Error exception with message describing error code (note + -- hstrerror seems to be obsolete) from h_errno. + + procedure Narrow (Item : in out Socket_Set_Type); + -- Update Last as it may be greater than the real last socket + + -- Types needed for Datagram_Socket_Stream_Type + + type Datagram_Socket_Stream_Type is new Root_Stream_Type with record + Socket : Socket_Type; + To : Sock_Addr_Type; + From : Sock_Addr_Type; + end record; + + type Datagram_Socket_Stream_Access is + access all Datagram_Socket_Stream_Type; + + procedure Read + (Stream : in out Datagram_Socket_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + + procedure Write + (Stream : in out Datagram_Socket_Stream_Type; + Item : Ada.Streams.Stream_Element_Array); + + -- Types needed for Stream_Socket_Stream_Type + + type Stream_Socket_Stream_Type is new Root_Stream_Type with record + Socket : Socket_Type; + end record; + + type Stream_Socket_Stream_Access is + access all Stream_Socket_Stream_Type; + + procedure Read + (Stream : in out Stream_Socket_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + + procedure Write + (Stream : in out Stream_Socket_Stream_Type; + Item : Ada.Streams.Stream_Element_Array); + + procedure Stream_Write + (Socket : Socket_Type; + Item : Ada.Streams.Stream_Element_Array; + To : access Sock_Addr_Type); + -- Common implementation for the Write operation of Datagram_Socket_Stream_ + -- Type and Stream_Socket_Stream_Type. + + procedure Wait_On_Socket + (Socket : Socket_Type; + For_Read : Boolean; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status); + -- Common code for variants of socket operations supporting a timeout: + -- block in Check_Selector on Socket for at most the indicated timeout. + -- If For_Read is True, Socket is added to the read set for this call, else + -- it is added to the write set. If no selector is provided, a local one is + -- created for this call and destroyed prior to returning. + + type Sockets_Library_Controller is new Ada.Finalization.Limited_Controlled + with null record; + -- This type is used to generate automatic calls to Initialize and Finalize + -- during the elaboration and finalization of this package. A single object + -- of this type must exist at library level. + + function Err_Code_Image (E : Integer) return String; + -- Return the value of E surrounded with brackets + + procedure Initialize (X : in out Sockets_Library_Controller); + procedure Finalize (X : in out Sockets_Library_Controller); + + procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type); + -- If S is the empty set (detected by Last = No_Socket), make sure its + -- fd_set component is actually cleared. Note that the case where it is + -- not can occur for an uninitialized Socket_Set_Type object. + + function Is_Open (S : Selector_Type) return Boolean; + -- Return True for an "open" Selector_Type object, i.e. one for which + -- Create_Selector has been called and Close_Selector has not been called, + -- or the null selector. + + --------- + -- "+" -- + --------- + + function "+" (L, R : Request_Flag_Type) return Request_Flag_Type is + begin + return L or R; + end "+"; + + -------------------- + -- Abort_Selector -- + -------------------- + + procedure Abort_Selector (Selector : Selector_Type) is + Res : C.int; + + begin + if not Is_Open (Selector) then + raise Program_Error with "closed selector"; + + elsif Selector.Is_Null then + raise Program_Error with "null selector"; + + end if; + + -- Send one byte to unblock select system call + + Res := Signalling_Fds.Write (C.int (Selector.W_Sig_Socket)); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Abort_Selector; + + ------------------- + -- Accept_Socket -- + ------------------- + + procedure Accept_Socket + (Server : Socket_Type; + Socket : out Socket_Type; + Address : out Sock_Addr_Type) + is + Res : C.int; + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + + begin + Res := C_Accept (C.int (Server), Sin'Address, Len'Access); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Socket := Socket_Type (Res); + + To_Inet_Addr (Sin.Sin_Addr, Address.Addr); + Address.Port := Port_Type (Network_To_Short (Sin.Sin_Port)); + end Accept_Socket; + + ------------------- + -- Accept_Socket -- + ------------------- + + procedure Accept_Socket + (Server : Socket_Type; + Socket : out Socket_Type; + Address : out Sock_Addr_Type; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status) + is + begin + if Selector /= null and then not Is_Open (Selector.all) then + raise Program_Error with "closed selector"; + end if; + + -- Wait for socket to become available for reading + + Wait_On_Socket + (Socket => Server, + For_Read => True, + Timeout => Timeout, + Selector => Selector, + Status => Status); + + -- Accept connection if available + + if Status = Completed then + Accept_Socket (Server, Socket, Address); + else + Socket := No_Socket; + end if; + end Accept_Socket; + + --------------- + -- Addresses -- + --------------- + + function Addresses + (E : Host_Entry_Type; + N : Positive := 1) return Inet_Addr_Type + is + begin + return E.Addresses (N); + end Addresses; + + ---------------------- + -- Addresses_Length -- + ---------------------- + + function Addresses_Length (E : Host_Entry_Type) return Natural is + begin + return E.Addresses_Length; + end Addresses_Length; + + ------------- + -- Aliases -- + ------------- + + function Aliases + (E : Host_Entry_Type; + N : Positive := 1) return String + is + begin + return To_String (E.Aliases (N)); + end Aliases; + + ------------- + -- Aliases -- + ------------- + + function Aliases + (S : Service_Entry_Type; + N : Positive := 1) return String + is + begin + return To_String (S.Aliases (N)); + end Aliases; + + -------------------- + -- Aliases_Length -- + -------------------- + + function Aliases_Length (E : Host_Entry_Type) return Natural is + begin + return E.Aliases_Length; + end Aliases_Length; + + -------------------- + -- Aliases_Length -- + -------------------- + + function Aliases_Length (S : Service_Entry_Type) return Natural is + begin + return S.Aliases_Length; + end Aliases_Length; + + ----------------- + -- Bind_Socket -- + ----------------- + + procedure Bind_Socket + (Socket : Socket_Type; + Address : Sock_Addr_Type) + is + Res : C.int; + Sin : aliased Sockaddr_In; + Len : constant C.int := Sin'Size / 8; + -- This assumes that Address.Family = Family_Inet??? + + begin + if Address.Family = Family_Inet6 then + raise Socket_Error with "IPv6 not supported"; + end if; + + Set_Family (Sin.Sin_Family, Address.Family); + Set_Address (Sin'Unchecked_Access, To_In_Addr (Address.Addr)); + Set_Port + (Sin'Unchecked_Access, + Short_To_Network (C.unsigned_short (Address.Port))); + + Res := C_Bind (C.int (Socket), Sin'Address, Len); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Bind_Socket; + + -------------------- + -- Check_Selector -- + -------------------- + + procedure Check_Selector + (Selector : Selector_Type; + R_Socket_Set : in out Socket_Set_Type; + W_Socket_Set : in out Socket_Set_Type; + Status : out Selector_Status; + Timeout : Selector_Duration := Forever) + is + E_Socket_Set : Socket_Set_Type; + begin + Check_Selector + (Selector, R_Socket_Set, W_Socket_Set, E_Socket_Set, Status, Timeout); + end Check_Selector; + + -------------------- + -- Check_Selector -- + -------------------- + + procedure Check_Selector + (Selector : Selector_Type; + R_Socket_Set : in out Socket_Set_Type; + W_Socket_Set : in out Socket_Set_Type; + E_Socket_Set : in out Socket_Set_Type; + Status : out Selector_Status; + Timeout : Selector_Duration := Forever) + is + Res : C.int; + Last : C.int; + RSig : Socket_Type := No_Socket; + TVal : aliased Timeval; + TPtr : Timeval_Access; + + begin + if not Is_Open (Selector) then + raise Program_Error with "closed selector"; + end if; + + Status := Completed; + + -- No timeout or Forever is indicated by a null timeval pointer + + if Timeout = Forever then + TPtr := null; + else + TVal := To_Timeval (Timeout); + TPtr := TVal'Unchecked_Access; + end if; + + -- Add read signalling socket, if present + + if not Selector.Is_Null then + RSig := Selector.R_Sig_Socket; + Set (R_Socket_Set, RSig); + end if; + + Last := C.int'Max (C.int'Max (C.int (R_Socket_Set.Last), + C.int (W_Socket_Set.Last)), + C.int (E_Socket_Set.Last)); + + -- Zero out fd_set for empty Socket_Set_Type objects + + Normalize_Empty_Socket_Set (R_Socket_Set); + Normalize_Empty_Socket_Set (W_Socket_Set); + Normalize_Empty_Socket_Set (E_Socket_Set); + + Res := + C_Select + (Last + 1, + R_Socket_Set.Set'Access, + W_Socket_Set.Set'Access, + E_Socket_Set.Set'Access, + TPtr); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + -- If Select was resumed because of read signalling socket, read this + -- data and remove socket from set. + + if RSig /= No_Socket and then Is_Set (R_Socket_Set, RSig) then + Clear (R_Socket_Set, RSig); + + Res := Signalling_Fds.Read (C.int (RSig)); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Status := Aborted; + + elsif Res = 0 then + Status := Expired; + end if; + + -- Update socket sets in regard to their new contents + + Narrow (R_Socket_Set); + Narrow (W_Socket_Set); + Narrow (E_Socket_Set); + end Check_Selector; + + ----------- + -- Clear -- + ----------- + + procedure Clear + (Item : in out Socket_Set_Type; + Socket : Socket_Type) + is + Last : aliased C.int := C.int (Item.Last); + begin + if Item.Last /= No_Socket then + Remove_Socket_From_Set (Item.Set'Access, C.int (Socket)); + Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access); + Item.Last := Socket_Type (Last); + end if; + end Clear; + + -------------------- + -- Close_Selector -- + -------------------- + + procedure Close_Selector (Selector : in out Selector_Type) is + begin + -- Nothing to do if selector already in closed state + + if Selector.Is_Null or else not Is_Open (Selector) then + return; + end if; + + -- Close the signalling file descriptors used internally for the + -- implementation of Abort_Selector. + + Signalling_Fds.Close (C.int (Selector.R_Sig_Socket)); + Signalling_Fds.Close (C.int (Selector.W_Sig_Socket)); + + -- Reset R_Sig_Socket and W_Sig_Socket to No_Socket to ensure that any + -- (erroneous) subsequent attempt to use this selector properly fails. + + Selector.R_Sig_Socket := No_Socket; + Selector.W_Sig_Socket := No_Socket; + end Close_Selector; + + ------------------ + -- Close_Socket -- + ------------------ + + procedure Close_Socket (Socket : Socket_Type) is + Res : C.int; + + begin + Res := C_Close (C.int (Socket)); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Close_Socket; + + -------------------- + -- Connect_Socket -- + -------------------- + + procedure Connect_Socket + (Socket : Socket_Type; + Server : Sock_Addr_Type) + is + Res : C.int; + Sin : aliased Sockaddr_In; + Len : constant C.int := Sin'Size / 8; + + begin + if Server.Family = Family_Inet6 then + raise Socket_Error with "IPv6 not supported"; + end if; + + Set_Family (Sin.Sin_Family, Server.Family); + Set_Address (Sin'Unchecked_Access, To_In_Addr (Server.Addr)); + Set_Port + (Sin'Unchecked_Access, + Short_To_Network (C.unsigned_short (Server.Port))); + + Res := C_Connect (C.int (Socket), Sin'Address, Len); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Connect_Socket; + + -------------------- + -- Connect_Socket -- + -------------------- + + procedure Connect_Socket + (Socket : Socket_Type; + Server : Sock_Addr_Type; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status) + is + Req : Request_Type; + -- Used to set Socket to non-blocking I/O + + begin + if Selector /= null and then not Is_Open (Selector.all) then + raise Program_Error with "closed selector"; + end if; + + -- Set the socket to non-blocking I/O + + Req := (Name => Non_Blocking_IO, Enabled => True); + Control_Socket (Socket, Request => Req); + + -- Start operation (non-blocking), will raise Socket_Error with + -- EINPROGRESS. + + begin + Connect_Socket (Socket, Server); + exception + when E : Socket_Error => + if Resolve_Exception (E) = Operation_Now_In_Progress then + null; + else + raise; + end if; + end; + + -- Wait for socket to become available for writing + + Wait_On_Socket + (Socket => Socket, + For_Read => False, + Timeout => Timeout, + Selector => Selector, + Status => Status); + + -- Reset the socket to blocking I/O + + Req := (Name => Non_Blocking_IO, Enabled => False); + Control_Socket (Socket, Request => Req); + end Connect_Socket; + + -------------------- + -- Control_Socket -- + -------------------- + + procedure Control_Socket + (Socket : Socket_Type; + Request : in out Request_Type) + is + Arg : aliased C.int; + Res : C.int; + + begin + case Request.Name is + when Non_Blocking_IO => + Arg := C.int (Boolean'Pos (Request.Enabled)); + + when N_Bytes_To_Read => + null; + end case; + + Res := Socket_Ioctl + (C.int (Socket), Requests (Request.Name), Arg'Unchecked_Access); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + case Request.Name is + when Non_Blocking_IO => + null; + + when N_Bytes_To_Read => + Request.Size := Natural (Arg); + end case; + end Control_Socket; + + ---------- + -- Copy -- + ---------- + + procedure Copy + (Source : Socket_Set_Type; + Target : out Socket_Set_Type) + is + begin + Target := Source; + end Copy; + + --------------------- + -- Create_Selector -- + --------------------- + + procedure Create_Selector (Selector : out Selector_Type) is + Two_Fds : aliased Fd_Pair; + Res : C.int; + + begin + if Is_Open (Selector) then + -- Raise exception to prevent socket descriptor leak + + raise Program_Error with "selector already open"; + end if; + + -- We open two signalling file descriptors. One of them is used to send + -- data to the other, which is included in a C_Select socket set. The + -- communication is used to force a call to C_Select to complete, and + -- the waiting task to resume its execution. + + Res := Signalling_Fds.Create (Two_Fds'Access); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Selector.R_Sig_Socket := Socket_Type (Two_Fds (Read_End)); + Selector.W_Sig_Socket := Socket_Type (Two_Fds (Write_End)); + end Create_Selector; + + ------------------- + -- Create_Socket -- + ------------------- + + procedure Create_Socket + (Socket : out Socket_Type; + Family : Family_Type := Family_Inet; + Mode : Mode_Type := Socket_Stream) + is + Res : C.int; + + begin + Res := C_Socket (Families (Family), Modes (Mode), 0); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Socket := Socket_Type (Res); + end Create_Socket; + + ----------- + -- Empty -- + ----------- + + procedure Empty (Item : out Socket_Set_Type) is + begin + Reset_Socket_Set (Item.Set'Access); + Item.Last := No_Socket; + end Empty; + + -------------------- + -- Err_Code_Image -- + -------------------- + + function Err_Code_Image (E : Integer) return String is + Msg : String := E'Img & "] "; + begin + Msg (Msg'First) := '['; + return Msg; + end Err_Code_Image; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (X : in out Sockets_Library_Controller) is + pragma Unreferenced (X); + + begin + -- Finalization operation for the GNAT.Sockets package + + Thin.Finalize; + end Finalize; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + begin + -- This is a dummy placeholder for an obsolete API. + -- The real finalization actions are in Initialize primitive operation + -- of Sockets_Library_Controller. + + null; + end Finalize; + + --------- + -- Get -- + --------- + + procedure Get + (Item : in out Socket_Set_Type; + Socket : out Socket_Type) + is + S : aliased C.int; + L : aliased C.int := C.int (Item.Last); + + begin + if Item.Last /= No_Socket then + Get_Socket_From_Set + (Item.Set'Access, Last => L'Access, Socket => S'Access); + Item.Last := Socket_Type (L); + Socket := Socket_Type (S); + else + Socket := No_Socket; + end if; + end Get; + + ----------------- + -- Get_Address -- + ----------------- + + function Get_Address + (Stream : not null Stream_Access) return Sock_Addr_Type + is + begin + if Stream.all in Datagram_Socket_Stream_Type then + return Datagram_Socket_Stream_Type (Stream.all).From; + else + return Get_Peer_Name (Stream_Socket_Stream_Type (Stream.all).Socket); + end if; + end Get_Address; + + ------------------------- + -- Get_Host_By_Address -- + ------------------------- + + function Get_Host_By_Address + (Address : Inet_Addr_Type; + Family : Family_Type := Family_Inet) return Host_Entry_Type + is + pragma Unreferenced (Family); + + HA : aliased In_Addr := To_In_Addr (Address); + Buflen : constant C.int := Netdb_Buffer_Size; + Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); + Res : aliased Hostent; + Err : aliased C.int; + + begin + Netdb_Lock; + + if C_Gethostbyaddr (HA'Address, HA'Size / 8, SOSC.AF_INET, + Res'Access, Buf'Address, Buflen, Err'Access) /= 0 + then + Netdb_Unlock; + Raise_Host_Error (Integer (Err)); + end if; + + return H : constant Host_Entry_Type := + To_Host_Entry (Res'Unchecked_Access) + do + Netdb_Unlock; + end return; + end Get_Host_By_Address; + + ---------------------- + -- Get_Host_By_Name -- + ---------------------- + + function Get_Host_By_Name (Name : String) return Host_Entry_Type is + begin + -- Detect IP address name and redirect to Inet_Addr + + if Is_IP_Address (Name) then + return Get_Host_By_Address (Inet_Addr (Name)); + end if; + + declare + HN : constant C.char_array := C.To_C (Name); + Buflen : constant C.int := Netdb_Buffer_Size; + Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); + Res : aliased Hostent; + Err : aliased C.int; + + begin + Netdb_Lock; + + if C_Gethostbyname + (HN, Res'Access, Buf'Address, Buflen, Err'Access) /= 0 + then + Netdb_Unlock; + Raise_Host_Error (Integer (Err)); + end if; + + return H : constant Host_Entry_Type := + To_Host_Entry (Res'Unchecked_Access) + do + Netdb_Unlock; + end return; + end; + end Get_Host_By_Name; + + ------------------- + -- Get_Peer_Name -- + ------------------- + + function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type is + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + Res : Sock_Addr_Type (Family_Inet); + + begin + if C_Getpeername (C.int (Socket), Sin'Address, Len'Access) = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + To_Inet_Addr (Sin.Sin_Addr, Res.Addr); + Res.Port := Port_Type (Network_To_Short (Sin.Sin_Port)); + + return Res; + end Get_Peer_Name; + + ------------------------- + -- Get_Service_By_Name -- + ------------------------- + + function Get_Service_By_Name + (Name : String; + Protocol : String) return Service_Entry_Type + is + SN : constant C.char_array := C.To_C (Name); + SP : constant C.char_array := C.To_C (Protocol); + Buflen : constant C.int := Netdb_Buffer_Size; + Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); + Res : aliased Servent; + + begin + Netdb_Lock; + + if C_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then + Netdb_Unlock; + raise Service_Error with "Service not found"; + end if; + + -- Translate from the C format to the API format + + return S : constant Service_Entry_Type := + To_Service_Entry (Res'Unchecked_Access) + do + Netdb_Unlock; + end return; + end Get_Service_By_Name; + + ------------------------- + -- Get_Service_By_Port -- + ------------------------- + + function Get_Service_By_Port + (Port : Port_Type; + Protocol : String) return Service_Entry_Type + is + SP : constant C.char_array := C.To_C (Protocol); + Buflen : constant C.int := Netdb_Buffer_Size; + Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); + Res : aliased Servent; + + begin + Netdb_Lock; + + if C_Getservbyport + (C.int (Short_To_Network (C.unsigned_short (Port))), SP, + Res'Access, Buf'Address, Buflen) /= 0 + then + Netdb_Unlock; + raise Service_Error with "Service not found"; + end if; + + -- Translate from the C format to the API format + + return S : constant Service_Entry_Type := + To_Service_Entry (Res'Unchecked_Access) + do + Netdb_Unlock; + end return; + end Get_Service_By_Port; + + --------------------- + -- Get_Socket_Name -- + --------------------- + + function Get_Socket_Name + (Socket : Socket_Type) return Sock_Addr_Type + is + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + Res : C.int; + Addr : Sock_Addr_Type := No_Sock_Addr; + + begin + Res := C_Getsockname (C.int (Socket), Sin'Address, Len'Access); + + if Res /= Failure then + To_Inet_Addr (Sin.Sin_Addr, Addr.Addr); + Addr.Port := Port_Type (Network_To_Short (Sin.Sin_Port)); + end if; + + return Addr; + end Get_Socket_Name; + + ----------------------- + -- Get_Socket_Option -- + ----------------------- + + function Get_Socket_Option + (Socket : Socket_Type; + Level : Level_Type := Socket_Level; + Name : Option_Name) return Option_Type + is + use type C.unsigned_char; + + V8 : aliased Two_Ints; + V4 : aliased C.int; + V1 : aliased C.unsigned_char; + VT : aliased Timeval; + Len : aliased C.int; + Add : System.Address; + Res : C.int; + Opt : Option_Type (Name); + + begin + case Name is + when Multicast_Loop | + Multicast_TTL | + Receive_Packet_Info => + Len := V1'Size / 8; + Add := V1'Address; + + when Keep_Alive | + Reuse_Address | + Broadcast | + No_Delay | + Send_Buffer | + Receive_Buffer | + Multicast_If | + Error => + Len := V4'Size / 8; + Add := V4'Address; + + when Send_Timeout | + Receive_Timeout => + Len := VT'Size / 8; + Add := VT'Address; + + when Linger | + Add_Membership | + Drop_Membership => + Len := V8'Size / 8; + Add := V8'Address; + + end case; + + Res := + C_Getsockopt + (C.int (Socket), + Levels (Level), + Options (Name), + Add, Len'Access); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + case Name is + when Keep_Alive | + Reuse_Address | + Broadcast | + No_Delay => + Opt.Enabled := (V4 /= 0); + + when Linger => + Opt.Enabled := (V8 (V8'First) /= 0); + Opt.Seconds := Natural (V8 (V8'Last)); + + when Send_Buffer | + Receive_Buffer => + Opt.Size := Natural (V4); + + when Error => + Opt.Error := Resolve_Error (Integer (V4)); + + when Add_Membership | + Drop_Membership => + To_Inet_Addr (To_In_Addr (V8 (V8'First)), Opt.Multicast_Address); + To_Inet_Addr (To_In_Addr (V8 (V8'Last)), Opt.Local_Interface); + + when Multicast_If => + To_Inet_Addr (To_In_Addr (V4), Opt.Outgoing_If); + + when Multicast_TTL => + Opt.Time_To_Live := Integer (V1); + + when Multicast_Loop | + Receive_Packet_Info => + Opt.Enabled := (V1 /= 0); + + when Send_Timeout | + Receive_Timeout => + Opt.Timeout := To_Duration (VT); + end case; + + return Opt; + end Get_Socket_Option; + + --------------- + -- Host_Name -- + --------------- + + function Host_Name return String is + Name : aliased C.char_array (1 .. 64); + Res : C.int; + + begin + Res := C_Gethostname (Name'Address, Name'Length); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + return C.To_Ada (Name); + end Host_Name; + + ----------- + -- Image -- + ----------- + + function Image + (Val : Inet_Addr_VN_Type; + Hex : Boolean := False) return String + is + -- The largest Inet_Addr_Comp_Type image occurs with IPv4. It + -- has at most a length of 3 plus one '.' character. + + Buffer : String (1 .. 4 * Val'Length); + Length : Natural := 1; + Separator : Character; + + procedure Img10 (V : Inet_Addr_Comp_Type); + -- Append to Buffer image of V in decimal format + + procedure Img16 (V : Inet_Addr_Comp_Type); + -- Append to Buffer image of V in hexadecimal format + + ----------- + -- Img10 -- + ----------- + + procedure Img10 (V : Inet_Addr_Comp_Type) is + Img : constant String := V'Img; + Len : constant Natural := Img'Length - 1; + begin + Buffer (Length .. Length + Len - 1) := Img (2 .. Img'Last); + Length := Length + Len; + end Img10; + + ----------- + -- Img16 -- + ----------- + + procedure Img16 (V : Inet_Addr_Comp_Type) is + begin + Buffer (Length) := Hex_To_Char (Natural (V / 16) + 1); + Buffer (Length + 1) := Hex_To_Char (Natural (V mod 16) + 1); + Length := Length + 2; + end Img16; + + -- Start of processing for Image + + begin + Separator := (if Hex then ':' else '.'); + + for J in Val'Range loop + if Hex then + Img16 (Val (J)); + else + Img10 (Val (J)); + end if; + + if J /= Val'Last then + Buffer (Length) := Separator; + Length := Length + 1; + end if; + end loop; + + return Buffer (1 .. Length - 1); + end Image; + + ----------- + -- Image -- + ----------- + + function Image (Value : Inet_Addr_Type) return String is + begin + if Value.Family = Family_Inet then + return Image (Inet_Addr_VN_Type (Value.Sin_V4), Hex => False); + else + return Image (Inet_Addr_VN_Type (Value.Sin_V6), Hex => True); + end if; + end Image; + + ----------- + -- Image -- + ----------- + + function Image (Value : Sock_Addr_Type) return String is + Port : constant String := Value.Port'Img; + begin + return Image (Value.Addr) & ':' & Port (2 .. Port'Last); + end Image; + + ----------- + -- Image -- + ----------- + + function Image (Socket : Socket_Type) return String is + begin + return Socket'Img; + end Image; + + ----------- + -- Image -- + ----------- + + function Image (Item : Socket_Set_Type) return String is + Socket_Set : Socket_Set_Type := Item; + + begin + declare + Last_Img : constant String := Socket_Set.Last'Img; + Buffer : String + (1 .. (Integer (Socket_Set.Last) + 1) * Last_Img'Length); + Index : Positive := 1; + Socket : Socket_Type; + + begin + while not Is_Empty (Socket_Set) loop + Get (Socket_Set, Socket); + + declare + Socket_Img : constant String := Socket'Img; + begin + Buffer (Index .. Index + Socket_Img'Length - 1) := Socket_Img; + Index := Index + Socket_Img'Length; + end; + end loop; + + return "[" & Last_Img & "]" & Buffer (1 .. Index - 1); + end; + end Image; + + --------------- + -- Inet_Addr -- + --------------- + + function Inet_Addr (Image : String) return Inet_Addr_Type is + use Interfaces.C; + use Interfaces.C.Strings; + + Img : aliased char_array := To_C (Image); + Addr : aliased C.int; + Res : C.int; + Result : Inet_Addr_Type; + + begin + -- Special case for an empty Image as on some platforms (e.g. Windows) + -- calling Inet_Addr("") will not return an error. + + if Image = "" then + Raise_Socket_Error (SOSC.EINVAL); + end if; + + Res := Inet_Pton (SOSC.AF_INET, Img'Address, Addr'Address); + + if Res < 0 then + Raise_Socket_Error (Socket_Errno); + + elsif Res = 0 then + Raise_Socket_Error (SOSC.EINVAL); + end if; + + To_Inet_Addr (To_In_Addr (Addr), Result); + return Result; + end Inet_Addr; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (X : in out Sockets_Library_Controller) is + pragma Unreferenced (X); + + begin + Thin.Initialize; + end Initialize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Process_Blocking_IO : Boolean) is + Expected : constant Boolean := not SOSC.Thread_Blocking_IO; + + begin + if Process_Blocking_IO /= Expected then + raise Socket_Error with + "incorrect Process_Blocking_IO setting, expected " & Expected'Img; + end if; + + -- This is a dummy placeholder for an obsolete API + + -- Real initialization actions are in Initialize primitive operation + -- of Sockets_Library_Controller. + + null; + end Initialize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + -- This is a dummy placeholder for an obsolete API + + -- Real initialization actions are in Initialize primitive operation + -- of Sockets_Library_Controller. + + null; + end Initialize; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Item : Socket_Set_Type) return Boolean is + begin + return Item.Last = No_Socket; + end Is_Empty; + + ------------------- + -- Is_IP_Address -- + ------------------- + + function Is_IP_Address (Name : String) return Boolean is + begin + for J in Name'Range loop + if Name (J) /= '.' + and then Name (J) not in '0' .. '9' + then + return False; + end if; + end loop; + + return True; + end Is_IP_Address; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (S : Selector_Type) return Boolean is + begin + if S.Is_Null then + return True; + + else + -- Either both controlling socket descriptors are valid (case of an + -- open selector) or neither (case of a closed selector). + + pragma Assert ((S.R_Sig_Socket /= No_Socket) + = + (S.W_Sig_Socket /= No_Socket)); + + return S.R_Sig_Socket /= No_Socket; + end if; + end Is_Open; + + ------------ + -- Is_Set -- + ------------ + + function Is_Set + (Item : Socket_Set_Type; + Socket : Socket_Type) return Boolean + is + begin + return Item.Last /= No_Socket + and then Socket <= Item.Last + and then Is_Socket_In_Set (Item.Set'Access, C.int (Socket)) /= 0; + end Is_Set; + + ------------------- + -- Listen_Socket -- + ------------------- + + procedure Listen_Socket + (Socket : Socket_Type; + Length : Natural := 15) + is + Res : constant C.int := C_Listen (C.int (Socket), C.int (Length)); + begin + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Listen_Socket; + + ------------ + -- Narrow -- + ------------ + + procedure Narrow (Item : in out Socket_Set_Type) is + Last : aliased C.int := C.int (Item.Last); + begin + if Item.Last /= No_Socket then + Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access); + Item.Last := Socket_Type (Last); + end if; + end Narrow; + + ---------------- + -- Netdb_Lock -- + ---------------- + + procedure Netdb_Lock is + begin + if Need_Netdb_Lock then + System.Task_Lock.Lock; + end if; + end Netdb_Lock; + + ------------------ + -- Netdb_Unlock -- + ------------------ + + procedure Netdb_Unlock is + begin + if Need_Netdb_Lock then + System.Task_Lock.Unlock; + end if; + end Netdb_Unlock; + + -------------------------------- + -- Normalize_Empty_Socket_Set -- + -------------------------------- + + procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type) is + begin + if S.Last = No_Socket then + Reset_Socket_Set (S.Set'Access); + end if; + end Normalize_Empty_Socket_Set; + + ------------------- + -- Official_Name -- + ------------------- + + function Official_Name (E : Host_Entry_Type) return String is + begin + return To_String (E.Official); + end Official_Name; + + ------------------- + -- Official_Name -- + ------------------- + + function Official_Name (S : Service_Entry_Type) return String is + begin + return To_String (S.Official); + end Official_Name; + + -------------------- + -- Wait_On_Socket -- + -------------------- + + procedure Wait_On_Socket + (Socket : Socket_Type; + For_Read : Boolean; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status) + is + type Local_Selector_Access is access Selector_Type; + for Local_Selector_Access'Storage_Size use Selector_Type'Size; + + S : Selector_Access; + -- Selector to use for waiting + + R_Fd_Set : Socket_Set_Type; + W_Fd_Set : Socket_Set_Type; + + begin + -- Create selector if not provided by the user + + if Selector = null then + declare + Local_S : constant Local_Selector_Access := new Selector_Type; + begin + S := Local_S.all'Unchecked_Access; + Create_Selector (S.all); + end; + + else + S := Selector.all'Access; + end if; + + if For_Read then + Set (R_Fd_Set, Socket); + else + Set (W_Fd_Set, Socket); + end if; + + Check_Selector (S.all, R_Fd_Set, W_Fd_Set, Status, Timeout); + + if Selector = null then + Close_Selector (S.all); + end if; + end Wait_On_Socket; + + ----------------- + -- Port_Number -- + ----------------- + + function Port_Number (S : Service_Entry_Type) return Port_Type is + begin + return S.Port; + end Port_Number; + + ------------------- + -- Protocol_Name -- + ------------------- + + function Protocol_Name (S : Service_Entry_Type) return String is + begin + return To_String (S.Protocol); + end Protocol_Name; + + ---------------------- + -- Raise_Host_Error -- + ---------------------- + + procedure Raise_Host_Error (H_Error : Integer) is + begin + raise Host_Error with + Err_Code_Image (H_Error) + & C.Strings.Value (Host_Error_Messages.Host_Error_Message (H_Error)); + end Raise_Host_Error; + + ------------------------ + -- Raise_Socket_Error -- + ------------------------ + + procedure Raise_Socket_Error (Error : Integer) is + use type C.Strings.chars_ptr; + begin + raise Socket_Error with + Err_Code_Image (Error) + & C.Strings.Value (Socket_Error_Message (Error)); + end Raise_Socket_Error; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : in out Datagram_Socket_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + First : Ada.Streams.Stream_Element_Offset := Item'First; + Index : Ada.Streams.Stream_Element_Offset := First - 1; + Max : constant Ada.Streams.Stream_Element_Offset := Item'Last; + + begin + loop + Receive_Socket + (Stream.Socket, + Item (First .. Max), + Index, + Stream.From); + + Last := Index; + + -- Exit when all or zero data received. Zero means that the socket + -- peer is closed. + + exit when Index < First or else Index = Max; + + First := Index + 1; + end loop; + end Read; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : in out Stream_Socket_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + pragma Warnings (Off, Stream); + + First : Ada.Streams.Stream_Element_Offset := Item'First; + Index : Ada.Streams.Stream_Element_Offset := First - 1; + Max : constant Ada.Streams.Stream_Element_Offset := Item'Last; + + begin + loop + Receive_Socket (Stream.Socket, Item (First .. Max), Index); + Last := Index; + + -- Exit when all or zero data received. Zero means that the socket + -- peer is closed. + + exit when Index < First or else Index = Max; + + First := Index + 1; + end loop; + end Read; + + -------------------- + -- Receive_Socket -- + -------------------- + + procedure Receive_Socket + (Socket : Socket_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Flags : Request_Flag_Type := No_Request_Flag) + is + Res : C.int; + + begin + Res := + C_Recv (C.int (Socket), Item'Address, Item'Length, To_Int (Flags)); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Last := Last_Index (First => Item'First, Count => size_t (Res)); + end Receive_Socket; + + -------------------- + -- Receive_Socket -- + -------------------- + + procedure Receive_Socket + (Socket : Socket_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + From : out Sock_Addr_Type; + Flags : Request_Flag_Type := No_Request_Flag) + is + Res : C.int; + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + + begin + Res := + C_Recvfrom + (C.int (Socket), + Item'Address, + Item'Length, + To_Int (Flags), + Sin'Address, + Len'Access); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Last := Last_Index (First => Item'First, Count => size_t (Res)); + + To_Inet_Addr (Sin.Sin_Addr, From.Addr); + From.Port := Port_Type (Network_To_Short (Sin.Sin_Port)); + end Receive_Socket; + + -------------------- + -- Receive_Vector -- + -------------------- + + procedure Receive_Vector + (Socket : Socket_Type; + Vector : Vector_Type; + Count : out Ada.Streams.Stream_Element_Count; + Flags : Request_Flag_Type := No_Request_Flag) + is + Res : ssize_t; + + Msg : Msghdr := + (Msg_Name => System.Null_Address, + Msg_Namelen => 0, + Msg_Iov => Vector'Address, + + -- recvmsg(2) returns EMSGSIZE on Linux (and probably on other + -- platforms) when the supplied vector is longer than IOV_MAX, + -- so use minimum of the two lengths. + + Msg_Iovlen => SOSC.Msg_Iovlen_T'Min + (Vector'Length, SOSC.IOV_MAX), + + Msg_Control => System.Null_Address, + Msg_Controllen => 0, + Msg_Flags => 0); + + begin + Res := + C_Recvmsg + (C.int (Socket), + Msg'Address, + To_Int (Flags)); + + if Res = ssize_t (Failure) then + Raise_Socket_Error (Socket_Errno); + end if; + + Count := Ada.Streams.Stream_Element_Count (Res); + end Receive_Vector; + + ------------------- + -- Resolve_Error -- + ------------------- + + function Resolve_Error + (Error_Value : Integer; + From_Errno : Boolean := True) return Error_Type + is + use GNAT.Sockets.SOSC; + + begin + if not From_Errno then + case Error_Value is + when SOSC.HOST_NOT_FOUND => return Unknown_Host; + when SOSC.TRY_AGAIN => return Host_Name_Lookup_Failure; + when SOSC.NO_RECOVERY => return Non_Recoverable_Error; + when SOSC.NO_DATA => return Unknown_Server_Error; + when others => return Cannot_Resolve_Error; + end case; + end if; + + -- Special case: EAGAIN may be the same value as EWOULDBLOCK, so we + -- can't include it in the case statement below. + + pragma Warnings (Off); + -- Condition "EAGAIN /= EWOULDBLOCK" is known at compile time + + if EAGAIN /= EWOULDBLOCK and then Error_Value = EAGAIN then + return Resource_Temporarily_Unavailable; + end if; + + -- This is not a case statement because if a particular error + -- number constant is not defined, s-oscons-tmplt.c defines + -- it to -1. If multiple constants are not defined, they + -- would each be -1 and result in a "duplicate value in case" error. + -- + -- But we have to leave warnings off because the compiler is also + -- smart enough to note that when two errnos have the same value, + -- the second if condition is useless. + if Error_Value = ENOERROR then + return Success; + elsif Error_Value = EACCES then + return Permission_Denied; + elsif Error_Value = EADDRINUSE then + return Address_Already_In_Use; + elsif Error_Value = EADDRNOTAVAIL then + return Cannot_Assign_Requested_Address; + elsif Error_Value = EAFNOSUPPORT then + return Address_Family_Not_Supported_By_Protocol; + elsif Error_Value = EALREADY then + return Operation_Already_In_Progress; + elsif Error_Value = EBADF then + return Bad_File_Descriptor; + elsif Error_Value = ECONNABORTED then + return Software_Caused_Connection_Abort; + elsif Error_Value = ECONNREFUSED then + return Connection_Refused; + elsif Error_Value = ECONNRESET then + return Connection_Reset_By_Peer; + elsif Error_Value = EDESTADDRREQ then + return Destination_Address_Required; + elsif Error_Value = EFAULT then + return Bad_Address; + elsif Error_Value = EHOSTDOWN then + return Host_Is_Down; + elsif Error_Value = EHOSTUNREACH then + return No_Route_To_Host; + elsif Error_Value = EINPROGRESS then + return Operation_Now_In_Progress; + elsif Error_Value = EINTR then + return Interrupted_System_Call; + elsif Error_Value = EINVAL then + return Invalid_Argument; + elsif Error_Value = EIO then + return Input_Output_Error; + elsif Error_Value = EISCONN then + return Transport_Endpoint_Already_Connected; + elsif Error_Value = ELOOP then + return Too_Many_Symbolic_Links; + elsif Error_Value = EMFILE then + return Too_Many_Open_Files; + elsif Error_Value = EMSGSIZE then + return Message_Too_Long; + elsif Error_Value = ENAMETOOLONG then + return File_Name_Too_Long; + elsif Error_Value = ENETDOWN then + return Network_Is_Down; + elsif Error_Value = ENETRESET then + return Network_Dropped_Connection_Because_Of_Reset; + elsif Error_Value = ENETUNREACH then + return Network_Is_Unreachable; + elsif Error_Value = ENOBUFS then + return No_Buffer_Space_Available; + elsif Error_Value = ENOPROTOOPT then + return Protocol_Not_Available; + elsif Error_Value = ENOTCONN then + return Transport_Endpoint_Not_Connected; + elsif Error_Value = ENOTSOCK then + return Socket_Operation_On_Non_Socket; + elsif Error_Value = EOPNOTSUPP then + return Operation_Not_Supported; + elsif Error_Value = EPFNOSUPPORT then + return Protocol_Family_Not_Supported; + elsif Error_Value = EPIPE then + return Broken_Pipe; + elsif Error_Value = EPROTONOSUPPORT then + return Protocol_Not_Supported; + elsif Error_Value = EPROTOTYPE then + return Protocol_Wrong_Type_For_Socket; + elsif Error_Value = ESHUTDOWN then + return Cannot_Send_After_Transport_Endpoint_Shutdown; + elsif Error_Value = ESOCKTNOSUPPORT then + return Socket_Type_Not_Supported; + elsif Error_Value = ETIMEDOUT then + return Connection_Timed_Out; + elsif Error_Value = ETOOMANYREFS then + return Too_Many_References; + elsif Error_Value = EWOULDBLOCK then + return Resource_Temporarily_Unavailable; + else + return Cannot_Resolve_Error; + end if; + pragma Warnings (On); + + end Resolve_Error; + + ----------------------- + -- Resolve_Exception -- + ----------------------- + + function Resolve_Exception + (Occurrence : Exception_Occurrence) return Error_Type + is + Id : constant Exception_Id := Exception_Identity (Occurrence); + Msg : constant String := Exception_Message (Occurrence); + First : Natural; + Last : Natural; + Val : Integer; + + begin + First := Msg'First; + while First <= Msg'Last + and then Msg (First) not in '0' .. '9' + loop + First := First + 1; + end loop; + + if First > Msg'Last then + return Cannot_Resolve_Error; + end if; + + Last := First; + while Last < Msg'Last + and then Msg (Last + 1) in '0' .. '9' + loop + Last := Last + 1; + end loop; + + Val := Integer'Value (Msg (First .. Last)); + + if Id = Socket_Error_Id then + return Resolve_Error (Val); + + elsif Id = Host_Error_Id then + return Resolve_Error (Val, False); + + else + return Cannot_Resolve_Error; + end if; + end Resolve_Exception; + + ----------------- + -- Send_Socket -- + ----------------- + + procedure Send_Socket + (Socket : Socket_Type; + Item : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Flags : Request_Flag_Type := No_Request_Flag) + is + begin + Send_Socket (Socket, Item, Last, To => null, Flags => Flags); + end Send_Socket; + + ----------------- + -- Send_Socket -- + ----------------- + + procedure Send_Socket + (Socket : Socket_Type; + Item : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + To : Sock_Addr_Type; + Flags : Request_Flag_Type := No_Request_Flag) + is + begin + Send_Socket + (Socket, Item, Last, To => To'Unrestricted_Access, Flags => Flags); + end Send_Socket; + + ----------------- + -- Send_Socket -- + ----------------- + + procedure Send_Socket + (Socket : Socket_Type; + Item : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + To : access Sock_Addr_Type; + Flags : Request_Flag_Type := No_Request_Flag) + is + Res : C.int; + + Sin : aliased Sockaddr_In; + C_To : System.Address; + Len : C.int; + + begin + if To /= null then + Set_Family (Sin.Sin_Family, To.Family); + Set_Address (Sin'Unchecked_Access, To_In_Addr (To.Addr)); + Set_Port + (Sin'Unchecked_Access, + Short_To_Network (C.unsigned_short (To.Port))); + C_To := Sin'Address; + Len := Sin'Size / 8; + + else + C_To := System.Null_Address; + Len := 0; + end if; + + Res := C_Sendto + (C.int (Socket), + Item'Address, + Item'Length, + Set_Forced_Flags (To_Int (Flags)), + C_To, + Len); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Last := Last_Index (First => Item'First, Count => size_t (Res)); + end Send_Socket; + + ----------------- + -- Send_Vector -- + ----------------- + + procedure Send_Vector + (Socket : Socket_Type; + Vector : Vector_Type; + Count : out Ada.Streams.Stream_Element_Count; + Flags : Request_Flag_Type := No_Request_Flag) + is + use SOSC; + use Interfaces.C; + + Res : ssize_t; + Iov_Count : SOSC.Msg_Iovlen_T; + This_Iov_Count : SOSC.Msg_Iovlen_T; + Msg : Msghdr; + + begin + Count := 0; + Iov_Count := 0; + while Iov_Count < Vector'Length loop + + pragma Warnings (Off); + -- Following test may be compile time known on some targets + + This_Iov_Count := + (if Vector'Length - Iov_Count > SOSC.IOV_MAX + then SOSC.IOV_MAX + else Vector'Length - Iov_Count); + + pragma Warnings (On); + + Msg := + (Msg_Name => System.Null_Address, + Msg_Namelen => 0, + Msg_Iov => Vector + (Vector'First + Integer (Iov_Count))'Address, + Msg_Iovlen => This_Iov_Count, + Msg_Control => System.Null_Address, + Msg_Controllen => 0, + Msg_Flags => 0); + + Res := + C_Sendmsg + (C.int (Socket), + Msg'Address, + Set_Forced_Flags (To_Int (Flags))); + + if Res = ssize_t (Failure) then + Raise_Socket_Error (Socket_Errno); + end if; + + Count := Count + Ada.Streams.Stream_Element_Count (Res); + Iov_Count := Iov_Count + This_Iov_Count; + end loop; + end Send_Vector; + + --------- + -- Set -- + --------- + + procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is + begin + if Item.Last = No_Socket then + + -- Uninitialized socket set, make sure it is properly zeroed out + + Reset_Socket_Set (Item.Set'Access); + Item.Last := Socket; + + elsif Item.Last < Socket then + Item.Last := Socket; + end if; + + Insert_Socket_In_Set (Item.Set'Access, C.int (Socket)); + end Set; + + ---------------------- + -- Set_Forced_Flags -- + ---------------------- + + function Set_Forced_Flags (F : C.int) return C.int is + use type C.unsigned; + function To_unsigned is + new Ada.Unchecked_Conversion (C.int, C.unsigned); + function To_int is + new Ada.Unchecked_Conversion (C.unsigned, C.int); + begin + return To_int (To_unsigned (F) or SOSC.MSG_Forced_Flags); + end Set_Forced_Flags; + + ----------------------- + -- Set_Socket_Option -- + ----------------------- + + procedure Set_Socket_Option + (Socket : Socket_Type; + Level : Level_Type := Socket_Level; + Option : Option_Type) + is + V8 : aliased Two_Ints; + V4 : aliased C.int; + V1 : aliased C.unsigned_char; + VT : aliased Timeval; + Len : C.int; + Add : System.Address := Null_Address; + Res : C.int; + + begin + case Option.Name is + when Keep_Alive | + Reuse_Address | + Broadcast | + No_Delay => + V4 := C.int (Boolean'Pos (Option.Enabled)); + Len := V4'Size / 8; + Add := V4'Address; + + when Linger => + V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled)); + V8 (V8'Last) := C.int (Option.Seconds); + Len := V8'Size / 8; + Add := V8'Address; + + when Send_Buffer | + Receive_Buffer => + V4 := C.int (Option.Size); + Len := V4'Size / 8; + Add := V4'Address; + + when Error => + V4 := C.int (Boolean'Pos (True)); + Len := V4'Size / 8; + Add := V4'Address; + + when Add_Membership | + Drop_Membership => + V8 (V8'First) := To_Int (To_In_Addr (Option.Multicast_Address)); + V8 (V8'Last) := To_Int (To_In_Addr (Option.Local_Interface)); + Len := V8'Size / 8; + Add := V8'Address; + + when Multicast_If => + V4 := To_Int (To_In_Addr (Option.Outgoing_If)); + Len := V4'Size / 8; + Add := V4'Address; + + when Multicast_TTL => + V1 := C.unsigned_char (Option.Time_To_Live); + Len := V1'Size / 8; + Add := V1'Address; + + when Multicast_Loop | + Receive_Packet_Info => + V1 := C.unsigned_char (Boolean'Pos (Option.Enabled)); + Len := V1'Size / 8; + Add := V1'Address; + + when Send_Timeout | + Receive_Timeout => + VT := To_Timeval (Option.Timeout); + Len := VT'Size / 8; + Add := VT'Address; + + end case; + + Res := C_Setsockopt + (C.int (Socket), + Levels (Level), + Options (Option.Name), + Add, Len); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Set_Socket_Option; + + ---------------------- + -- Short_To_Network -- + ---------------------- + + function Short_To_Network (S : C.unsigned_short) return C.unsigned_short is + use type C.unsigned_short; + + begin + -- Big-endian case. No conversion needed. On these platforms, + -- htons() defaults to a null procedure. + + pragma Warnings (Off); + -- Since the test can generate "always True/False" warning + + if Default_Bit_Order = High_Order_First then + return S; + + pragma Warnings (On); + + -- Little-endian case. We must swap the high and low bytes of this + -- short to make the port number network compliant. + + else + return (S / 256) + (S mod 256) * 256; + end if; + end Short_To_Network; + + --------------------- + -- Shutdown_Socket -- + --------------------- + + procedure Shutdown_Socket + (Socket : Socket_Type; + How : Shutmode_Type := Shut_Read_Write) + is + Res : C.int; + + begin + Res := C_Shutdown (C.int (Socket), Shutmodes (How)); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Shutdown_Socket; + + ------------ + -- Stream -- + ------------ + + function Stream + (Socket : Socket_Type; + Send_To : Sock_Addr_Type) return Stream_Access + is + S : Datagram_Socket_Stream_Access; + + begin + S := new Datagram_Socket_Stream_Type; + S.Socket := Socket; + S.To := Send_To; + S.From := Get_Socket_Name (Socket); + return Stream_Access (S); + end Stream; + + ------------ + -- Stream -- + ------------ + + function Stream (Socket : Socket_Type) return Stream_Access is + S : Stream_Socket_Stream_Access; + begin + S := new Stream_Socket_Stream_Type; + S.Socket := Socket; + return Stream_Access (S); + end Stream; + + ------------------ + -- Stream_Write -- + ------------------ + + procedure Stream_Write + (Socket : Socket_Type; + Item : Ada.Streams.Stream_Element_Array; + To : access Sock_Addr_Type) + is + First : Ada.Streams.Stream_Element_Offset; + Index : Ada.Streams.Stream_Element_Offset; + Max : constant Ada.Streams.Stream_Element_Offset := Item'Last; + + begin + First := Item'First; + Index := First - 1; + while First <= Max loop + Send_Socket (Socket, Item (First .. Max), Index, To); + + -- Exit when all or zero data sent. Zero means that the socket has + -- been closed by peer. + + exit when Index < First or else Index = Max; + + First := Index + 1; + end loop; + + -- For an empty array, we have First > Max, and hence Index >= Max (no + -- error, the loop above is never executed). After a successful send, + -- Index = Max. The only remaining case, Index < Max, is therefore + -- always an actual send failure. + + if Index < Max then + Raise_Socket_Error (Socket_Errno); + end if; + end Stream_Write; + + ---------- + -- To_C -- + ---------- + + function To_C (Socket : Socket_Type) return Integer is + begin + return Integer (Socket); + end To_C; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (Val : Timeval) return Timeval_Duration is + begin + return Natural (Val.Tv_Sec) * 1.0 + Natural (Val.Tv_Usec) * 1.0E-6; + end To_Duration; + + ------------------- + -- To_Host_Entry -- + ------------------- + + function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type is + use type C.size_t; + use C.Strings; + + Aliases_Count, Addresses_Count : Natural; + + -- H_Length is not used because it is currently only set to 4 + -- H_Addrtype is always AF_INET + + begin + Aliases_Count := 0; + while Hostent_H_Alias (E, C.int (Aliases_Count)) /= Null_Address loop + Aliases_Count := Aliases_Count + 1; + end loop; + + Addresses_Count := 0; + while Hostent_H_Addr (E, C.int (Addresses_Count)) /= Null_Address loop + Addresses_Count := Addresses_Count + 1; + end loop; + + return Result : Host_Entry_Type + (Aliases_Length => Aliases_Count, + Addresses_Length => Addresses_Count) + do + Result.Official := To_Name (Value (Hostent_H_Name (E))); + + for J in Result.Aliases'Range loop + Result.Aliases (J) := + To_Name (Value (Hostent_H_Alias + (E, C.int (J - Result.Aliases'First)))); + end loop; + + for J in Result.Addresses'Range loop + declare + Addr : In_Addr; + for Addr'Address use + Hostent_H_Addr (E, C.int (J - Result.Addresses'First)); + pragma Import (Ada, Addr); + begin + To_Inet_Addr (Addr, Result.Addresses (J)); + end; + end loop; + end return; + end To_Host_Entry; + + ---------------- + -- To_In_Addr -- + ---------------- + + function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr is + begin + if Addr.Family = Family_Inet then + return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)), + S_B2 => C.unsigned_char (Addr.Sin_V4 (2)), + S_B3 => C.unsigned_char (Addr.Sin_V4 (3)), + S_B4 => C.unsigned_char (Addr.Sin_V4 (4))); + end if; + + raise Socket_Error with "IPv6 not supported"; + end To_In_Addr; + + ------------------ + -- To_Inet_Addr -- + ------------------ + + procedure To_Inet_Addr + (Addr : In_Addr; + Result : out Inet_Addr_Type) is + begin + Result.Sin_V4 (1) := Inet_Addr_Comp_Type (Addr.S_B1); + Result.Sin_V4 (2) := Inet_Addr_Comp_Type (Addr.S_B2); + Result.Sin_V4 (3) := Inet_Addr_Comp_Type (Addr.S_B3); + Result.Sin_V4 (4) := Inet_Addr_Comp_Type (Addr.S_B4); + end To_Inet_Addr; + + ------------ + -- To_Int -- + ------------ + + function To_Int (F : Request_Flag_Type) return C.int + is + Current : Request_Flag_Type := F; + Result : C.int := 0; + + begin + for J in Flags'Range loop + exit when Current = 0; + + if Current mod 2 /= 0 then + if Flags (J) = -1 then + Raise_Socket_Error (SOSC.EOPNOTSUPP); + end if; + + Result := Result + Flags (J); + end if; + + Current := Current / 2; + end loop; + + return Result; + end To_Int; + + ------------- + -- To_Name -- + ------------- + + function To_Name (N : String) return Name_Type is + begin + return Name_Type'(N'Length, N); + end To_Name; + + ---------------------- + -- To_Service_Entry -- + ---------------------- + + function To_Service_Entry (E : Servent_Access) return Service_Entry_Type is + use C.Strings; + use type C.size_t; + + Aliases_Count : Natural; + + begin + Aliases_Count := 0; + while Servent_S_Alias (E, C.int (Aliases_Count)) /= Null_Address loop + Aliases_Count := Aliases_Count + 1; + end loop; + + return Result : Service_Entry_Type (Aliases_Length => Aliases_Count) do + Result.Official := To_Name (Value (Servent_S_Name (E))); + + for J in Result.Aliases'Range loop + Result.Aliases (J) := + To_Name (Value (Servent_S_Alias + (E, C.int (J - Result.Aliases'First)))); + end loop; + + Result.Protocol := To_Name (Value (Servent_S_Proto (E))); + Result.Port := + Port_Type (Network_To_Short (Servent_S_Port (E))); + end return; + end To_Service_Entry; + + --------------- + -- To_String -- + --------------- + + function To_String (HN : Name_Type) return String is + begin + return HN.Name (1 .. HN.Length); + end To_String; + + ---------------- + -- To_Timeval -- + ---------------- + + function To_Timeval (Val : Timeval_Duration) return Timeval is + S : time_t; + uS : suseconds_t; + + begin + -- If zero, set result as zero (otherwise it gets rounded down to -1) + + if Val = 0.0 then + S := 0; + uS := 0; + + -- Normal case where we do round down + + else + S := time_t (Val - 0.5); + uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S))); + end if; + + return (S, uS); + end To_Timeval; + + ----------- + -- Value -- + ----------- + + function Value (S : System.Address) return String is + Str : String (1 .. Positive'Last); + for Str'Address use S; + pragma Import (Ada, Str); + + Terminator : Positive := Str'First; + + begin + while Str (Terminator) /= ASCII.NUL loop + Terminator := Terminator + 1; + end loop; + + return Str (1 .. Terminator - 1); + end Value; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : in out Datagram_Socket_Stream_Type; + Item : Ada.Streams.Stream_Element_Array) + is + begin + Stream_Write (Stream.Socket, Item, To => Stream.To'Unrestricted_Access); + end Write; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : in out Stream_Socket_Stream_Type; + Item : Ada.Streams.Stream_Element_Array) + is + begin + Stream_Write (Stream.Socket, Item, To => null); + end Write; + + Sockets_Library_Controller_Object : Sockets_Library_Controller; + pragma Unreferenced (Sockets_Library_Controller_Object); + -- The elaboration and finalization of this object perform the required + -- initialization and cleanup actions for the sockets library. + +end GNAT.Sockets; diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads new file mode 100644 index 000000000..169538a4d --- /dev/null +++ b/gcc/ada/g-socket.ads @@ -0,0 +1,1252 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface to the sockets communication facility +-- provided on many operating systems. This is implemented on the following +-- platforms: + +-- All native ports, with restrictions as follows + +-- Multicast is available only on systems which provide support for this +-- feature, so it is not available if Multicast is not supported, or not +-- installed. + +-- The VMS implementation was implemented using the DECC RTL Socket API, +-- and is thus subject to limitations in the implementation of this API. + +-- VxWorks cross ports fully implement this package + +-- This package is not yet implemented on LynxOS or other cross ports + +with Ada.Exceptions; +with Ada.Streams; +with Ada.Unchecked_Deallocation; + +with Interfaces.C; + +with System.OS_Constants; +with System.Storage_Elements; + +package GNAT.Sockets is + + -- Sockets are designed to provide a consistent communication facility + -- between applications. This package provides an Ada binding to the + -- de-facto standard BSD sockets API. The documentation below covers + -- only the specific binding provided by this package. It assumes that + -- the reader is already familiar with general network programming and + -- sockets usage. A useful reference on this matter is W. Richard Stevens' + -- "UNIX Network Programming: The Sockets Networking API" + -- (ISBN: 0131411551). + + -- GNAT.Sockets has been designed with several ideas in mind + + -- This is a system independent interface. Therefore, we try as much as + -- possible to mask system incompatibilities. Some functionalities are not + -- available because there are not fully supported on some systems. + + -- This is a thick binding. For instance, a major effort has been done to + -- avoid using memory addresses or untyped ints. We preferred to define + -- streams and enumeration types. Errors are not returned as returned + -- values but as exceptions. + + -- This package provides a POSIX-compliant interface (between two + -- different implementations of the same routine, we adopt the one closest + -- to the POSIX specification). For instance, using select(), the + -- notification of an asynchronous connect failure is delivered in the + -- write socket set (POSIX) instead of the exception socket set (NT). + + -- The example below demonstrates various features of GNAT.Sockets: + + -- with GNAT.Sockets; use GNAT.Sockets; + + -- with Ada.Text_IO; + -- with Ada.Exceptions; use Ada.Exceptions; + + -- procedure PingPong is + + -- Group : constant String := "239.255.128.128"; + -- -- Multicast group: administratively scoped IP address + + -- task Pong is + -- entry Start; + -- entry Stop; + -- end Pong; + + -- task body Pong is + -- Address : Sock_Addr_Type; + -- Server : Socket_Type; + -- Socket : Socket_Type; + -- Channel : Stream_Access; + + -- begin + -- accept Start; + -- + -- -- Get an Internet address of a host (here the local host name). + -- -- Note that a host can have several addresses. Here we get + -- -- the first one which is supposed to be the official one. + + -- Address.Addr := Addresses (Get_Host_By_Name (Host_Name), 1); + + -- -- Get a socket address that is an Internet address and a port + + -- Address.Port := 5876; + + -- -- The first step is to create a socket. Once created, this + -- -- socket must be associated to with an address. Usually only a + -- -- server (Pong here) needs to bind an address explicitly. Most + -- -- of the time clients can skip this step because the socket + -- -- routines will bind an arbitrary address to an unbound socket. + + -- Create_Socket (Server); + + -- -- Allow reuse of local addresses + + -- Set_Socket_Option + -- (Server, + -- Socket_Level, + -- (Reuse_Address, True)); + + -- Bind_Socket (Server, Address); + + -- -- A server marks a socket as willing to receive connect events + + -- Listen_Socket (Server); + + -- -- Once a server calls Listen_Socket, incoming connects events + -- -- can be accepted. The returned Socket is a new socket that + -- -- represents the server side of the connection. Server remains + -- -- available to receive further connections. + + -- Accept_Socket (Server, Socket, Address); + + -- -- Return a stream associated to the connected socket + + -- Channel := Stream (Socket); + + -- -- Force Pong to block + + -- delay 0.2; + + -- -- Receive and print message from client Ping + + -- declare + -- Message : String := String'Input (Channel); + + -- begin + -- Ada.Text_IO.Put_Line (Message); + + -- -- Send same message back to client Ping + + -- String'Output (Channel, Message); + -- end; + + -- Close_Socket (Server); + -- Close_Socket (Socket); + + -- -- Part of the multicast example + + -- -- Create a datagram socket to send connectionless, unreliable + -- -- messages of a fixed maximum length. + + -- Create_Socket (Socket, Family_Inet, Socket_Datagram); + + -- -- Allow reuse of local addresses + + -- Set_Socket_Option + -- (Socket, + -- Socket_Level, + -- (Reuse_Address, True)); + + -- -- Controls the live time of the datagram to avoid it being + -- -- looped forever due to routing errors. Routers decrement + -- -- the TTL of every datagram as it traverses from one network + -- -- to another and when its value reaches 0 the packet is + -- -- dropped. Default is 1. + + -- Set_Socket_Option + -- (Socket, + -- IP_Protocol_For_IP_Level, + -- (Multicast_TTL, 1)); + + -- -- Want the data you send to be looped back to your host + + -- Set_Socket_Option + -- (Socket, + -- IP_Protocol_For_IP_Level, + -- (Multicast_Loop, True)); + + -- -- If this socket is intended to receive messages, bind it + -- -- to a given socket address. + + -- Address.Addr := Any_Inet_Addr; + -- Address.Port := 55505; + + -- Bind_Socket (Socket, Address); + + -- -- Join a multicast group + + -- -- Portability note: On Windows, this option may be set only + -- -- on a bound socket. + + -- Set_Socket_Option + -- (Socket, + -- IP_Protocol_For_IP_Level, + -- (Add_Membership, Inet_Addr (Group), Any_Inet_Addr)); + + -- -- If this socket is intended to send messages, provide the + -- -- receiver socket address. + + -- Address.Addr := Inet_Addr (Group); + -- Address.Port := 55506; + + -- Channel := Stream (Socket, Address); + + -- -- Receive and print message from client Ping + + -- declare + -- Message : String := String'Input (Channel); + + -- begin + -- -- Get the address of the sender + + -- Address := Get_Address (Channel); + -- Ada.Text_IO.Put_Line (Message & " from " & Image (Address)); + + -- -- Send same message back to client Ping + + -- String'Output (Channel, Message); + -- end; + + -- Close_Socket (Socket); + + -- accept Stop; + + -- exception when E : others => + -- Ada.Text_IO.Put_Line + -- (Exception_Name (E) & ": " & Exception_Message (E)); + -- end Pong; + + -- task Ping is + -- entry Start; + -- entry Stop; + -- end Ping; + + -- task body Ping is + -- Address : Sock_Addr_Type; + -- Socket : Socket_Type; + -- Channel : Stream_Access; + + -- begin + -- accept Start; + + -- -- See comments in Ping section for the first steps + + -- Address.Addr := Addresses (Get_Host_By_Name (Host_Name), 1); + -- Address.Port := 5876; + -- Create_Socket (Socket); + + -- Set_Socket_Option + -- (Socket, + -- Socket_Level, + -- (Reuse_Address, True)); + + -- -- Force Pong to block + + -- delay 0.2; + + -- -- If the client's socket is not bound, Connect_Socket will + -- -- bind to an unused address. The client uses Connect_Socket to + -- -- create a logical connection between the client's socket and + -- -- a server's socket returned by Accept_Socket. + + -- Connect_Socket (Socket, Address); + + -- Channel := Stream (Socket); + + -- -- Send message to server Pong + + -- String'Output (Channel, "Hello world"); + + -- -- Force Ping to block + + -- delay 0.2; + + -- -- Receive and print message from server Pong + + -- Ada.Text_IO.Put_Line (String'Input (Channel)); + -- Close_Socket (Socket); + + -- -- Part of multicast example. Code similar to Pong's one + + -- Create_Socket (Socket, Family_Inet, Socket_Datagram); + + -- Set_Socket_Option + -- (Socket, + -- Socket_Level, + -- (Reuse_Address, True)); + + -- Set_Socket_Option + -- (Socket, + -- IP_Protocol_For_IP_Level, + -- (Multicast_TTL, 1)); + + -- Set_Socket_Option + -- (Socket, + -- IP_Protocol_For_IP_Level, + -- (Multicast_Loop, True)); + + -- Address.Addr := Any_Inet_Addr; + -- Address.Port := 55506; + + -- Bind_Socket (Socket, Address); + + -- Set_Socket_Option + -- (Socket, + -- IP_Protocol_For_IP_Level, + -- (Add_Membership, Inet_Addr (Group), Any_Inet_Addr)); + + -- Address.Addr := Inet_Addr (Group); + -- Address.Port := 55505; + + -- Channel := Stream (Socket, Address); + + -- -- Send message to server Pong + + -- String'Output (Channel, "Hello world"); + + -- -- Receive and print message from server Pong + + -- declare + -- Message : String := String'Input (Channel); + + -- begin + -- Address := Get_Address (Channel); + -- Ada.Text_IO.Put_Line (Message & " from " & Image (Address)); + -- end; + + -- Close_Socket (Socket); + + -- accept Stop; + + -- exception when E : others => + -- Ada.Text_IO.Put_Line + -- (Exception_Name (E) & ": " & Exception_Message (E)); + -- end Ping; + + -- begin + -- Initialize; + -- Ping.Start; + -- Pong.Start; + -- Ping.Stop; + -- Pong.Stop; + -- Finalize; + -- end PingPong; + + package SOSC renames System.OS_Constants; + -- Renaming used to provide short-hand notations throughout the sockets + -- binding. Note that System.OS_Constants is an internal unit, and the + -- entities declared therein are not meant for direct access by users, + -- including through this renaming. + + procedure Initialize; + pragma Obsolescent + (Entity => Initialize, + Message => "explicit initialization is no longer required"); + -- Initialize must be called before using any other socket routines. + -- Note that this operation is a no-op on UNIX platforms, but applications + -- should make sure to call it if portability is expected: some platforms + -- (such as Windows) require initialization before any socket operation. + -- This is now a no-op (initialization and finalization are done + -- automatically). + + procedure Initialize (Process_Blocking_IO : Boolean); + pragma Obsolescent + (Entity => Initialize, + Message => "passing a parameter to Initialize is no longer supported"); + -- Previous versions of GNAT.Sockets used to require the user to indicate + -- whether socket I/O was process- or thread-blocking on the platform. + -- This property is now determined automatically when the run-time library + -- is built. The old version of Initialize, taking a parameter, is kept + -- for compatibility reasons, but this interface is obsolete (and if the + -- value given is wrong, an exception will be raised at run time). + -- This is now a no-op (initialization and finalization are done + -- automatically). + + procedure Finalize; + pragma Obsolescent + (Entity => Finalize, + Message => "explicit finalization is no longer required"); + -- After Finalize is called it is not possible to use any routines + -- exported in by this package. This procedure is idempotent. + -- This is now a no-op (initialization and finalization are done + -- automatically). + + type Socket_Type is private; + -- Sockets are used to implement a reliable bi-directional point-to-point, + -- stream-based connections between hosts. No_Socket provides a special + -- value to denote uninitialized sockets. + + No_Socket : constant Socket_Type; + + type Selector_Type is limited private; + type Selector_Access is access all Selector_Type; + -- Selector objects are used to wait for i/o events to occur on sockets + + Null_Selector : constant Selector_Type; + -- The Null_Selector can be used in place of a normal selector without + -- having to call Create_Selector if the use of Abort_Selector is not + -- required. + + -- Timeval_Duration is a subtype of Standard.Duration because the full + -- range of Standard.Duration cannot be represented in the equivalent C + -- structure. Moreover, negative values are not allowed to avoid system + -- incompatibilities. + + Immediate : constant Duration := 0.0; + + Timeval_Forever : constant := 2.0 ** (SOSC.SIZEOF_tv_sec * 8 - 1) - 1.0; + Forever : constant Duration := + Duration'Min (Duration'Last, Timeval_Forever); + + subtype Timeval_Duration is Duration range Immediate .. Forever; + + subtype Selector_Duration is Timeval_Duration; + -- Timeout value for selector operations + + type Selector_Status is (Completed, Expired, Aborted); + -- Completion status of a selector operation, indicated as follows: + -- Complete: one of the expected events occurred + -- Expired: no event occurred before the expiration of the timeout + -- Aborted: an external action cancelled the wait operation before + -- any event occurred. + + Socket_Error : exception; + -- There is only one exception in this package to deal with an error during + -- a socket routine. Once raised, its message contains a string describing + -- the error code. + + function Image (Socket : Socket_Type) return String; + -- Return a printable string for Socket + + function To_C (Socket : Socket_Type) return Integer; + -- Return a file descriptor to be used by external subprograms. This is + -- useful for C functions that are not yet interfaced in this package. + + type Family_Type is (Family_Inet, Family_Inet6); + -- Address family (or protocol family) identifies the communication domain + -- and groups protocols with similar address formats. + + type Mode_Type is (Socket_Stream, Socket_Datagram); + -- Stream sockets provide connection-oriented byte streams. Datagram + -- sockets support unreliable connectionless message based communication. + + type Shutmode_Type is (Shut_Read, Shut_Write, Shut_Read_Write); + -- When a process closes a socket, the policy is to retain any data queued + -- until either a delivery or a timeout expiration (in this case, the data + -- are discarded). A finer control is available through shutdown. With + -- Shut_Read, no more data can be received from the socket. With_Write, no + -- more data can be transmitted. Neither transmission nor reception can be + -- performed with Shut_Read_Write. + + type Port_Type is range 0 .. 16#ffff#; + -- TCP/UDP port number + + Any_Port : constant Port_Type; + -- All ports + + No_Port : constant Port_Type; + -- Uninitialized port number + + type Inet_Addr_Type (Family : Family_Type := Family_Inet) is private; + -- An Internet address depends on an address family (IPv4 contains 4 octets + -- and IPv6 contains 16 octets). Any_Inet_Addr is a special value treated + -- like a wildcard enabling all addresses. No_Inet_Addr provides a special + -- value to denote uninitialized inet addresses. + + Any_Inet_Addr : constant Inet_Addr_Type; + No_Inet_Addr : constant Inet_Addr_Type; + Broadcast_Inet_Addr : constant Inet_Addr_Type; + Loopback_Inet_Addr : constant Inet_Addr_Type; + + -- Useful constants for IPv4 multicast addresses + + Unspecified_Group_Inet_Addr : constant Inet_Addr_Type; + All_Hosts_Group_Inet_Addr : constant Inet_Addr_Type; + All_Routers_Group_Inet_Addr : constant Inet_Addr_Type; + + type Sock_Addr_Type (Family : Family_Type := Family_Inet) is record + Addr : Inet_Addr_Type (Family); + Port : Port_Type; + end record; + -- Socket addresses fully define a socket connection with protocol family, + -- an Internet address and a port. No_Sock_Addr provides a special value + -- for uninitialized socket addresses. + + No_Sock_Addr : constant Sock_Addr_Type; + + function Image (Value : Inet_Addr_Type) return String; + -- Return an image of an Internet address. IPv4 notation consists in 4 + -- octets in decimal format separated by dots. IPv6 notation consists in + -- 16 octets in hexadecimal format separated by colons (and possibly + -- dots). + + function Image (Value : Sock_Addr_Type) return String; + -- Return inet address image and port image separated by a colon + + function Inet_Addr (Image : String) return Inet_Addr_Type; + -- Convert address image from numbers-and-dots notation into an + -- inet address. + + -- Host entries provide complete information on a given host: the official + -- name, an array of alternative names or aliases and array of network + -- addresses. + + type Host_Entry_Type + (Aliases_Length, Addresses_Length : Natural) is private; + + function Official_Name (E : Host_Entry_Type) return String; + -- Return official name in host entry + + function Aliases_Length (E : Host_Entry_Type) return Natural; + -- Return number of aliases in host entry + + function Addresses_Length (E : Host_Entry_Type) return Natural; + -- Return number of addresses in host entry + + function Aliases + (E : Host_Entry_Type; + N : Positive := 1) return String; + -- Return N'th aliases in host entry. The first index is 1 + + function Addresses + (E : Host_Entry_Type; + N : Positive := 1) return Inet_Addr_Type; + -- Return N'th addresses in host entry. The first index is 1 + + Host_Error : exception; + -- Exception raised by the two following procedures. Once raised, its + -- message contains a string describing the error code. This exception is + -- raised when an host entry cannot be retrieved. + + function Get_Host_By_Address + (Address : Inet_Addr_Type; + Family : Family_Type := Family_Inet) return Host_Entry_Type; + -- Return host entry structure for the given Inet address. Note that no + -- result will be returned if there is no mapping of this IP address to a + -- host name in the system tables (host database, DNS or otherwise). + + function Get_Host_By_Name + (Name : String) return Host_Entry_Type; + -- Return host entry structure for the given host name. Here name is + -- either a host name, or an IP address. If Name is an IP address, this + -- is equivalent to Get_Host_By_Address (Inet_Addr (Name)). + + function Host_Name return String; + -- Return the name of the current host + + type Service_Entry_Type (Aliases_Length : Natural) is private; + -- Service entries provide complete information on a given service: the + -- official name, an array of alternative names or aliases and the port + -- number. + + function Official_Name (S : Service_Entry_Type) return String; + -- Return official name in service entry + + function Port_Number (S : Service_Entry_Type) return Port_Type; + -- Return port number in service entry + + function Protocol_Name (S : Service_Entry_Type) return String; + -- Return Protocol in service entry (usually UDP or TCP) + + function Aliases_Length (S : Service_Entry_Type) return Natural; + -- Return number of aliases in service entry + + function Aliases + (S : Service_Entry_Type; + N : Positive := 1) return String; + -- Return N'th aliases in service entry (the first index is 1) + + function Get_Service_By_Name + (Name : String; + Protocol : String) return Service_Entry_Type; + -- Return service entry structure for the given service name + + function Get_Service_By_Port + (Port : Port_Type; + Protocol : String) return Service_Entry_Type; + -- Return service entry structure for the given service port number + + Service_Error : exception; + -- Comment required ??? + + -- Errors are described by an enumeration type. There is only one exception + -- Socket_Error in this package to deal with an error during a socket + -- routine. Once raised, its message contains the error code between + -- brackets and a string describing the error code. + + -- The name of the enumeration constant documents the error condition + -- Note that on some platforms, a single error value is used for both + -- EWOULDBLOCK and EAGAIN. Both errors are therefore always reported as + -- Resource_Temporarily_Unavailable. + + type Error_Type is + (Success, + Permission_Denied, + Address_Already_In_Use, + Cannot_Assign_Requested_Address, + Address_Family_Not_Supported_By_Protocol, + Operation_Already_In_Progress, + Bad_File_Descriptor, + Software_Caused_Connection_Abort, + Connection_Refused, + Connection_Reset_By_Peer, + Destination_Address_Required, + Bad_Address, + Host_Is_Down, + No_Route_To_Host, + Operation_Now_In_Progress, + Interrupted_System_Call, + Invalid_Argument, + Input_Output_Error, + Transport_Endpoint_Already_Connected, + Too_Many_Symbolic_Links, + Too_Many_Open_Files, + Message_Too_Long, + File_Name_Too_Long, + Network_Is_Down, + Network_Dropped_Connection_Because_Of_Reset, + Network_Is_Unreachable, + No_Buffer_Space_Available, + Protocol_Not_Available, + Transport_Endpoint_Not_Connected, + Socket_Operation_On_Non_Socket, + Operation_Not_Supported, + Protocol_Family_Not_Supported, + Protocol_Not_Supported, + Protocol_Wrong_Type_For_Socket, + Cannot_Send_After_Transport_Endpoint_Shutdown, + Socket_Type_Not_Supported, + Connection_Timed_Out, + Too_Many_References, + Resource_Temporarily_Unavailable, + Broken_Pipe, + Unknown_Host, + Host_Name_Lookup_Failure, + Non_Recoverable_Error, + Unknown_Server_Error, + Cannot_Resolve_Error); + + -- Get_Socket_Options and Set_Socket_Options manipulate options associated + -- with a socket. Options may exist at multiple protocol levels in the + -- communication stack. Socket_Level is the uppermost socket level. + + type Level_Type is + (Socket_Level, + IP_Protocol_For_IP_Level, + IP_Protocol_For_UDP_Level, + IP_Protocol_For_TCP_Level); + + -- There are several options available to manipulate sockets. Each option + -- has a name and several values available. Most of the time, the value is + -- a boolean to enable or disable this option. + + type Option_Name is + (Keep_Alive, -- Enable sending of keep-alive messages + Reuse_Address, -- Allow bind to reuse local address + Broadcast, -- Enable datagram sockets to recv/send broadcasts + Send_Buffer, -- Set/get the maximum socket send buffer in bytes + Receive_Buffer, -- Set/get the maximum socket recv buffer in bytes + Linger, -- Shutdown wait for msg to be sent or timeout occur + Error, -- Get and clear the pending socket error + No_Delay, -- Do not delay send to coalesce data (TCP_NODELAY) + Add_Membership, -- Join a multicast group + Drop_Membership, -- Leave a multicast group + Multicast_If, -- Set default out interface for multicast packets + Multicast_TTL, -- Set the time-to-live of sent multicast packets + Multicast_Loop, -- Sent multicast packets are looped to local socket + Receive_Packet_Info, -- Receive low level packet info as ancillary data + Send_Timeout, -- Set timeout value for output + Receive_Timeout); -- Set timeout value for input + + type Option_Type (Name : Option_Name := Keep_Alive) is record + case Name is + when Keep_Alive | + Reuse_Address | + Broadcast | + Linger | + No_Delay | + Receive_Packet_Info | + Multicast_Loop => + Enabled : Boolean; + + case Name is + when Linger => + Seconds : Natural; + when others => + null; + end case; + + when Send_Buffer | + Receive_Buffer => + Size : Natural; + + when Error => + Error : Error_Type; + + when Add_Membership | + Drop_Membership => + Multicast_Address : Inet_Addr_Type; + Local_Interface : Inet_Addr_Type; + + when Multicast_If => + Outgoing_If : Inet_Addr_Type; + + when Multicast_TTL => + Time_To_Live : Natural; + + when Send_Timeout | + Receive_Timeout => + Timeout : Timeval_Duration; + + end case; + end record; + + -- There are several controls available to manipulate sockets. Each option + -- has a name and several values available. These controls differ from the + -- socket options in that they are not specific to sockets but are + -- available for any device. + + type Request_Name is + (Non_Blocking_IO, -- Cause a caller not to wait on blocking operations + N_Bytes_To_Read); -- Return the number of bytes available to read + + type Request_Type (Name : Request_Name := Non_Blocking_IO) is record + case Name is + when Non_Blocking_IO => + Enabled : Boolean; + + when N_Bytes_To_Read => + Size : Natural; + + end case; + end record; + + -- A request flag allows to specify the type of message transmissions or + -- receptions. A request flag can be combination of zero or more + -- predefined request flags. + + type Request_Flag_Type is private; + + No_Request_Flag : constant Request_Flag_Type; + -- This flag corresponds to the normal execution of an operation + + Process_Out_Of_Band_Data : constant Request_Flag_Type; + -- This flag requests that the receive or send function operates on + -- out-of-band data when the socket supports this notion (e.g. + -- Socket_Stream). + + Peek_At_Incoming_Data : constant Request_Flag_Type; + -- This flag causes the receive operation to return data from the beginning + -- of the receive queue without removing that data from the queue. A + -- subsequent receive call will return the same data. + + Wait_For_A_Full_Reception : constant Request_Flag_Type; + -- This flag requests that the operation block until the full request is + -- satisfied. However, the call may still return less data than requested + -- if a signal is caught, an error or disconnect occurs, or the next data + -- to be received is of a different type than that returned. Note that + -- this flag depends on support in the underlying sockets implementation, + -- and is not supported under Windows. + + Send_End_Of_Record : constant Request_Flag_Type; + -- This flag indicates that the entire message has been sent and so this + -- terminates the record. + + function "+" (L, R : Request_Flag_Type) return Request_Flag_Type; + -- Combine flag L with flag R + + type Stream_Element_Reference is access all Ada.Streams.Stream_Element; + + type Vector_Element is record + Base : Stream_Element_Reference; + Length : Ada.Streams.Stream_Element_Count; + end record; + + type Vector_Type is array (Integer range <>) of Vector_Element; + + procedure Create_Socket + (Socket : out Socket_Type; + Family : Family_Type := Family_Inet; + Mode : Mode_Type := Socket_Stream); + -- Create an endpoint for communication. Raises Socket_Error on error + + procedure Accept_Socket + (Server : Socket_Type; + Socket : out Socket_Type; + Address : out Sock_Addr_Type); + -- Extracts the first connection request on the queue of pending + -- connections, creates a new connected socket with mostly the same + -- properties as Server, and allocates a new socket. The returned Address + -- is filled in with the address of the connection. Raises Socket_Error on + -- error. + + procedure Accept_Socket + (Server : Socket_Type; + Socket : out Socket_Type; + Address : out Sock_Addr_Type; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status); + -- Accept a new connection on Server using Accept_Socket, waiting no longer + -- than the given timeout duration. Status is set to indicate whether the + -- operation completed successfully, timed out, or was aborted. If Selector + -- is not null, the designated selector is used to wait for the socket to + -- become available, else a private selector object is created by this + -- procedure and destroyed before it returns. + + procedure Bind_Socket + (Socket : Socket_Type; + Address : Sock_Addr_Type); + -- Once a socket is created, assign a local address to it. Raise + -- Socket_Error on error. + + procedure Close_Socket (Socket : Socket_Type); + -- Close a socket and more specifically a non-connected socket + + procedure Connect_Socket + (Socket : Socket_Type; + Server : Sock_Addr_Type); + -- Make a connection to another socket which has the address of Server. + -- Raises Socket_Error on error. + + procedure Connect_Socket + (Socket : Socket_Type; + Server : Sock_Addr_Type; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status); + -- Connect Socket to the given Server address using Connect_Socket, waiting + -- no longer than the given timeout duration. Status is set to indicate + -- whether the operation completed successfully, timed out, or was aborted. + -- If Selector is not null, the designated selector is used to wait for the + -- socket to become available, else a private selector object is created + -- by this procedure and destroyed before it returns. + + procedure Control_Socket + (Socket : Socket_Type; + Request : in out Request_Type); + -- Obtain or set parameter values that control the socket. This control + -- differs from the socket options in that they are not specific to sockets + -- but are available for any device. + + function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type; + -- Return the peer or remote socket address of a socket. Raise + -- Socket_Error on error. + + function Get_Socket_Name (Socket : Socket_Type) return Sock_Addr_Type; + -- Return the local or current socket address of a socket. Return + -- No_Sock_Addr on error (e.g. socket closed or not locally bound). + + function Get_Socket_Option + (Socket : Socket_Type; + Level : Level_Type := Socket_Level; + Name : Option_Name) return Option_Type; + -- Get the options associated with a socket. Raises Socket_Error on error + + procedure Listen_Socket + (Socket : Socket_Type; + Length : Natural := 15); + -- To accept connections, a socket is first created with Create_Socket, + -- a willingness to accept incoming connections and a queue Length for + -- incoming connections are specified. Raise Socket_Error on error. + -- The queue length of 15 is an example value that should be appropriate + -- in usual cases. It can be adjusted according to each application's + -- particular requirements. + + procedure Receive_Socket + (Socket : Socket_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Flags : Request_Flag_Type := No_Request_Flag); + -- Receive message from Socket. Last is the index value such that Item + -- (Last) is the last character assigned. Note that Last is set to + -- Item'First - 1 when the socket has been closed by peer. This is not + -- an error, and no exception is raised in this case unless Item'First + -- is Stream_Element_Offset'First, in which case Constraint_Error is + -- raised. Flags allows to control the reception. Raise Socket_Error on + -- error. + + procedure Receive_Socket + (Socket : Socket_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + From : out Sock_Addr_Type; + Flags : Request_Flag_Type := No_Request_Flag); + -- Receive message from Socket. If Socket is not connection-oriented, the + -- source address From of the message is filled in. Last is the index + -- value such that Item (Last) is the last character assigned. Flags + -- allows to control the reception. Raises Socket_Error on error. + + procedure Receive_Vector + (Socket : Socket_Type; + Vector : Vector_Type; + Count : out Ada.Streams.Stream_Element_Count; + Flags : Request_Flag_Type := No_Request_Flag); + -- Receive data from a socket and scatter it into the set of vector + -- elements Vector. Count is set to the count of received stream elements. + -- Flags allow control over reception. + + function Resolve_Exception + (Occurrence : Ada.Exceptions.Exception_Occurrence) return Error_Type; + -- When Socket_Error or Host_Error are raised, the exception message + -- contains the error code between brackets and a string describing the + -- error code. Resolve_Error extracts the error code from an exception + -- message and translate it into an enumeration value. + + procedure Send_Socket + (Socket : Socket_Type; + Item : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + To : access Sock_Addr_Type; + Flags : Request_Flag_Type := No_Request_Flag); + pragma Inline (Send_Socket); + -- Transmit a message over a socket. For a datagram socket, the address + -- is given by To.all. For a stream socket, To must be null. Last + -- is the index value such that Item (Last) is the last character + -- sent. Note that Last is set to Item'First - 1 if the socket has been + -- closed by the peer (unless Item'First is Stream_Element_Offset'First, + -- in which case Constraint_Error is raised instead). This is not an error, + -- and Socket_Error is not raised in that case. Flags allows control of the + -- transmission. Raises exception Socket_Error on error. Note: this + -- subprogram is inlined because it is also used to implement the two + -- variants below. + + procedure Send_Socket + (Socket : Socket_Type; + Item : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Flags : Request_Flag_Type := No_Request_Flag); + -- Transmit a message over a socket. Upon return, Last is set to the index + -- within Item of the last element transmitted. Flags allows to control + -- the transmission. Raises Socket_Error on any detected error condition. + + procedure Send_Socket + (Socket : Socket_Type; + Item : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + To : Sock_Addr_Type; + Flags : Request_Flag_Type := No_Request_Flag); + -- Transmit a message over a datagram socket. The destination address is + -- To. Flags allows to control the transmission. Raises Socket_Error on + -- error. + + procedure Send_Vector + (Socket : Socket_Type; + Vector : Vector_Type; + Count : out Ada.Streams.Stream_Element_Count; + Flags : Request_Flag_Type := No_Request_Flag); + -- Transmit data gathered from the set of vector elements Vector to a + -- socket. Count is set to the count of transmitted stream elements. Flags + -- allow control over transmission. + + procedure Set_Socket_Option + (Socket : Socket_Type; + Level : Level_Type := Socket_Level; + Option : Option_Type); + -- Manipulate socket options. Raises Socket_Error on error + + procedure Shutdown_Socket + (Socket : Socket_Type; + How : Shutmode_Type := Shut_Read_Write); + -- Shutdown a connected socket. If How is Shut_Read further receives will + -- be disallowed. If How is Shut_Write further sends will be disallowed. + -- If How is Shut_Read_Write further sends and receives will be disallowed. + + type Stream_Access is access all Ada.Streams.Root_Stream_Type'Class; + -- Same interface as Ada.Streams.Stream_IO + + function Stream (Socket : Socket_Type) return Stream_Access; + -- Create a stream associated with an already connected stream-based socket + + function Stream + (Socket : Socket_Type; + Send_To : Sock_Addr_Type) return Stream_Access; + -- Create a stream associated with an already bound datagram-based socket. + -- Send_To is the destination address to which messages are being sent. + + function Get_Address + (Stream : not null Stream_Access) return Sock_Addr_Type; + -- Return the socket address from which the last message was received + + procedure Free is new Ada.Unchecked_Deallocation + (Ada.Streams.Root_Stream_Type'Class, Stream_Access); + -- Destroy a stream created by one of the Stream functions above, releasing + -- the corresponding resources. The user is responsible for calling this + -- subprogram when the stream is not needed anymore. + + type Socket_Set_Type is limited private; + -- This type allows to manipulate sets of sockets. It allows to wait for + -- events on multiple endpoints at one time. This type has default + -- initialization, and the default value is the empty set. + -- + -- Note: This type used to contain a pointer to dynamically allocated + -- storage, but this is not the case anymore, and no special precautions + -- are required to avoid memory leaks. + + procedure Clear (Item : in out Socket_Set_Type; Socket : Socket_Type); + -- Remove Socket from Item + + procedure Copy (Source : Socket_Set_Type; Target : out Socket_Set_Type); + -- Copy Source into Target as Socket_Set_Type is limited private + + procedure Empty (Item : out Socket_Set_Type); + -- Remove all Sockets from Item + + procedure Get (Item : in out Socket_Set_Type; Socket : out Socket_Type); + -- Extract a Socket from socket set Item. Socket is set to + -- No_Socket when the set is empty. + + function Is_Empty (Item : Socket_Set_Type) return Boolean; + -- Return True iff Item is empty + + function Is_Set + (Item : Socket_Set_Type; + Socket : Socket_Type) return Boolean; + -- Return True iff Socket is present in Item + + procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type); + -- Insert Socket into Item + + function Image (Item : Socket_Set_Type) return String; + -- Return a printable image of Item, for debugging purposes + + -- The select(2) system call waits for events to occur on any of a set of + -- file descriptors. Usually, three independent sets of descriptors are + -- watched (read, write and exception). A timeout gives an upper bound + -- on the amount of time elapsed before select returns. This function + -- blocks until an event occurs. On some platforms, the select(2) system + -- can block the full process (not just the calling thread). + -- + -- Check_Selector provides the very same behaviour. The only difference is + -- that it does not watch for exception events. Note that on some platforms + -- it is kept process blocking on purpose. The timeout parameter allows the + -- user to have the behaviour he wants. Abort_Selector allows to safely + -- abort a blocked Check_Selector call. A special socket is opened by + -- Create_Selector and included in each call to Check_Selector. + -- + -- Abort_Selector causes an event to occur on this descriptor in order to + -- unblock Check_Selector. Note that each call to Abort_Selector will cause + -- exactly one call to Check_Selector to return with Aborted status. The + -- special socket created by Create_Selector is closed when Close_Selector + -- is called. + -- + -- A typical case where it is useful to abort a Check_Selector operation is + -- the situation where a change to the monitored sockets set must be made. + + procedure Create_Selector (Selector : out Selector_Type); + -- Initialize (open) a new selector + + procedure Close_Selector (Selector : in out Selector_Type); + -- Close Selector and all internal descriptors associated; deallocate any + -- associated resources. This subprogram may be called only when there is + -- no other task still using Selector (i.e. still executing Check_Selector + -- or Abort_Selector on this Selector). Has no effect if Selector is + -- already closed. + + procedure Check_Selector + (Selector : Selector_Type; + R_Socket_Set : in out Socket_Set_Type; + W_Socket_Set : in out Socket_Set_Type; + Status : out Selector_Status; + Timeout : Selector_Duration := Forever); + -- Return when one Socket in R_Socket_Set has some data to be read or if + -- one Socket in W_Socket_Set is ready to transmit some data. In these + -- cases Status is set to Completed and sockets that are ready are set in + -- R_Socket_Set or W_Socket_Set. Status is set to Expired if no socket was + -- ready after a Timeout expiration. Status is set to Aborted if an abort + -- signal has been received while checking socket status. + -- + -- Note that two different Socket_Set_Type objects must be passed as + -- R_Socket_Set and W_Socket_Set (even if they denote the same set of + -- Sockets), or some event may be lost. + -- + -- Socket_Error is raised when the select(2) system call returns an error + -- condition, or when a read error occurs on the signalling socket used for + -- the implementation of Abort_Selector. + + procedure Check_Selector + (Selector : Selector_Type; + R_Socket_Set : in out Socket_Set_Type; + W_Socket_Set : in out Socket_Set_Type; + E_Socket_Set : in out Socket_Set_Type; + Status : out Selector_Status; + Timeout : Selector_Duration := Forever); + -- This refined version of Check_Selector allows watching for exception + -- events (i.e. notifications of out-of-band transmission and reception). + -- As above, all of R_Socket_Set, W_Socket_Set and E_Socket_Set must be + -- different objects. + + procedure Abort_Selector (Selector : Selector_Type); + -- Send an abort signal to the selector. The Selector may not be the + -- Null_Selector. + + type Fd_Set is private; + -- ??? This type must not be used directly, it needs to be visible because + -- it is used in the visible part of GNAT.Sockets.Thin_Common. This is + -- really an inversion of abstraction. The private part of GNAT.Sockets + -- needs to have visibility on this type, but since Thin_Common is a child + -- of Sockets, the type can't be declared there. The correct fix would + -- be to move the thin sockets binding outside of GNAT.Sockets altogether, + -- e.g. by renaming it to GNAT.Sockets_Thin. + +private + + type Socket_Type is new Integer; + No_Socket : constant Socket_Type := -1; + + -- A selector is either a null selector, which is always "open" and can + -- never be aborted, or a regular selector, which is created "closed", + -- becomes "open" when Create_Selector is called, and "closed" again when + -- Close_Selector is called. + + type Selector_Type (Is_Null : Boolean := False) is limited record + case Is_Null is + when True => + null; + + when False => + R_Sig_Socket : Socket_Type := No_Socket; + W_Sig_Socket : Socket_Type := No_Socket; + -- Signalling sockets used to abort a select operation + + end case; + end record; + + pragma Volatile (Selector_Type); + + Null_Selector : constant Selector_Type := (Is_Null => True); + + type Fd_Set is + new System.Storage_Elements.Storage_Array (1 .. SOSC.SIZEOF_fd_set); + for Fd_Set'Alignment use Interfaces.C.long'Alignment; + -- Set conservative alignment so that our Fd_Sets are always adequately + -- aligned for the underlying data type (which is implementation defined + -- and may be an array of C long integers). + + type Fd_Set_Access is access all Fd_Set; + pragma Convention (C, Fd_Set_Access); + No_Fd_Set_Access : constant Fd_Set_Access := null; + + type Socket_Set_Type is record + Last : Socket_Type := No_Socket; + -- Highest socket in set. Last = No_Socket denotes an empty set (which + -- is the default initial value). + + Set : aliased Fd_Set; + -- Underlying socket set. Note that the contents of this component is + -- undefined if Last = No_Socket. + end record; + + subtype Inet_Addr_Comp_Type is Natural range 0 .. 255; + -- Octet for Internet address + + type Inet_Addr_VN_Type is array (Natural range <>) of Inet_Addr_Comp_Type; + + subtype Inet_Addr_V4_Type is Inet_Addr_VN_Type (1 .. 4); + subtype Inet_Addr_V6_Type is Inet_Addr_VN_Type (1 .. 16); + + type Inet_Addr_Type (Family : Family_Type := Family_Inet) is record + case Family is + when Family_Inet => + Sin_V4 : Inet_Addr_V4_Type := (others => 0); + + when Family_Inet6 => + Sin_V6 : Inet_Addr_V6_Type := (others => 0); + end case; + end record; + + Any_Port : constant Port_Type := 0; + No_Port : constant Port_Type := 0; + + Any_Inet_Addr : constant Inet_Addr_Type := + (Family_Inet, (others => 0)); + No_Inet_Addr : constant Inet_Addr_Type := + (Family_Inet, (others => 0)); + Broadcast_Inet_Addr : constant Inet_Addr_Type := + (Family_Inet, (others => 255)); + Loopback_Inet_Addr : constant Inet_Addr_Type := + (Family_Inet, (127, 0, 0, 1)); + + Unspecified_Group_Inet_Addr : constant Inet_Addr_Type := + (Family_Inet, (224, 0, 0, 0)); + All_Hosts_Group_Inet_Addr : constant Inet_Addr_Type := + (Family_Inet, (224, 0, 0, 1)); + All_Routers_Group_Inet_Addr : constant Inet_Addr_Type := + (Family_Inet, (224, 0, 0, 2)); + + No_Sock_Addr : constant Sock_Addr_Type := (Family_Inet, No_Inet_Addr, 0); + + Max_Name_Length : constant := 64; + -- The constant MAXHOSTNAMELEN is usually set to 64 + + subtype Name_Index is Natural range 1 .. Max_Name_Length; + + type Name_Type (Length : Name_Index := Max_Name_Length) is record + Name : String (1 .. Length); + end record; + -- We need fixed strings to avoid access types in host entry type + + type Name_Array is array (Natural range <>) of Name_Type; + type Inet_Addr_Array is array (Natural range <>) of Inet_Addr_Type; + + type Host_Entry_Type (Aliases_Length, Addresses_Length : Natural) is record + Official : Name_Type; + Aliases : Name_Array (1 .. Aliases_Length); + Addresses : Inet_Addr_Array (1 .. Addresses_Length); + end record; + + type Service_Entry_Type (Aliases_Length : Natural) is record + Official : Name_Type; + Aliases : Name_Array (1 .. Aliases_Length); + Port : Port_Type; + Protocol : Name_Type; + end record; + + type Request_Flag_Type is mod 2 ** 8; + No_Request_Flag : constant Request_Flag_Type := 0; + Process_Out_Of_Band_Data : constant Request_Flag_Type := 1; + Peek_At_Incoming_Data : constant Request_Flag_Type := 2; + Wait_For_A_Full_Reception : constant Request_Flag_Type := 4; + Send_End_Of_Record : constant Request_Flag_Type := 8; + +end GNAT.Sockets; diff --git a/gcc/ada/g-socthi-dummy.adb b/gcc/ada/g-socthi-dummy.adb new file mode 100644 index 000000000..5d366655b --- /dev/null +++ b/gcc/ada/g-socthi-dummy.adb @@ -0,0 +1,34 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma No_Body; diff --git a/gcc/ada/g-socthi-dummy.ads b/gcc/ada/g-socthi-dummy.ads new file mode 100644 index 000000000..ba87024de --- /dev/null +++ b/gcc/ada/g-socthi-dummy.ads @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package 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 new file mode 100644 index 000000000..f57353dbf --- /dev/null +++ b/gcc/ada/g-socthi-mingw.adb @@ -0,0 +1,635 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a target dependent thin interface to the sockets +-- layer for use by the GNAT.Sockets package (g-socket.ads). This package +-- should not be directly with'ed by an applications program. + +-- This version is for NT + +with Ada.Streams; use Ada.Streams; +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; + use type C.int; + + 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 : C.int; + 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 (Stream_Element_Count (Res) <= Current_Iovec.Length); + + Count := Count + Res; + Current_Iovec.Length := + Current_Iovec.Length - Stream_Element_Count (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 Stream_Element_Count (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 C.Strings.chars_ptr + 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 C.Strings.chars_ptr + is + use GNAT.Sockets.SOSC; + + begin + case Errno is + when EINTR => return Error_Messages (N_EINTR); + when EBADF => return Error_Messages (N_EBADF); + when EACCES => return Error_Messages (N_EACCES); + when EFAULT => return Error_Messages (N_EFAULT); + when EINVAL => return Error_Messages (N_EINVAL); + when EMFILE => return Error_Messages (N_EMFILE); + when EWOULDBLOCK => return Error_Messages (N_EWOULDBLOCK); + when EINPROGRESS => return Error_Messages (N_EINPROGRESS); + when EALREADY => return Error_Messages (N_EALREADY); + when ENOTSOCK => return Error_Messages (N_ENOTSOCK); + when EDESTADDRREQ => return Error_Messages (N_EDESTADDRREQ); + when EMSGSIZE => return Error_Messages (N_EMSGSIZE); + when EPROTOTYPE => return Error_Messages (N_EPROTOTYPE); + when ENOPROTOOPT => return Error_Messages (N_ENOPROTOOPT); + when EPROTONOSUPPORT => return Error_Messages (N_EPROTONOSUPPORT); + when ESOCKTNOSUPPORT => return Error_Messages (N_ESOCKTNOSUPPORT); + when EOPNOTSUPP => return Error_Messages (N_EOPNOTSUPP); + when EPFNOSUPPORT => return Error_Messages (N_EPFNOSUPPORT); + when EAFNOSUPPORT => return Error_Messages (N_EAFNOSUPPORT); + when EADDRINUSE => return Error_Messages (N_EADDRINUSE); + when EADDRNOTAVAIL => return Error_Messages (N_EADDRNOTAVAIL); + when ENETDOWN => return Error_Messages (N_ENETDOWN); + when ENETUNREACH => return Error_Messages (N_ENETUNREACH); + when ENETRESET => return Error_Messages (N_ENETRESET); + when ECONNABORTED => return Error_Messages (N_ECONNABORTED); + when ECONNRESET => return Error_Messages (N_ECONNRESET); + when ENOBUFS => return Error_Messages (N_ENOBUFS); + when EISCONN => return Error_Messages (N_EISCONN); + when ENOTCONN => return Error_Messages (N_ENOTCONN); + when ESHUTDOWN => return Error_Messages (N_ESHUTDOWN); + when ETOOMANYREFS => return Error_Messages (N_ETOOMANYREFS); + when ETIMEDOUT => return Error_Messages (N_ETIMEDOUT); + when ECONNREFUSED => return Error_Messages (N_ECONNREFUSED); + when ELOOP => return Error_Messages (N_ELOOP); + when ENAMETOOLONG => return Error_Messages (N_ENAMETOOLONG); + when EHOSTDOWN => return Error_Messages (N_EHOSTDOWN); + when EHOSTUNREACH => return Error_Messages (N_EHOSTUNREACH); + + -- Windows-specific error codes + + when WSASYSNOTREADY => return Error_Messages (N_WSASYSNOTREADY); + when WSAVERNOTSUPPORTED => + return Error_Messages (N_WSAVERNOTSUPPORTED); + when WSANOTINITIALISED => + return Error_Messages (N_WSANOTINITIALISED); + when WSAEDISCON => return Error_Messages (N_WSAEDISCON); + + -- h_errno values + + when HOST_NOT_FOUND => return Error_Messages (N_HOST_NOT_FOUND); + when TRY_AGAIN => return Error_Messages (N_TRY_AGAIN); + when NO_RECOVERY => return Error_Messages (N_NO_RECOVERY); + when NO_DATA => return Error_Messages (N_NO_DATA); + + when others => return Error_Messages (N_OTHERS); + end case; + end Socket_Error_Message; + +end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi-mingw.ads b/gcc/ada/g-socthi-mingw.ads new file mode 100644 index 000000000..bc1f25649 --- /dev/null +++ b/gcc/ada/g-socthi-mingw.ads @@ -0,0 +1,245 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a target dependent thin interface to the sockets +-- layer for use by the GNAT.Sockets package (g-socket.ads). This package +-- should not be directly with'ed by an applications program. + +-- This version is for NT + +with Interfaces.C.Strings; + +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 C.Strings.chars_ptr; + -- 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 C.Strings.chars_ptr; + -- 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 : C.int; + 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-vms.adb b/gcc/ada/g-socthi-vms.adb new file mode 100644 index 000000000..133182144 --- /dev/null +++ b/gcc/ada/g-socthi-vms.adb @@ -0,0 +1,478 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the version for OpenVMS + +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Task_Lock; + +with Interfaces.C; use Interfaces.C; + +package body GNAT.Sockets.Thin is + + type VMS_Msghdr is new Msghdr; + pragma Pack (VMS_Msghdr); + -- On VMS (unlike other platforms), struct msghdr is packed, so a specific + -- derived type is required. + + 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. Note that 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 to non-blocking + -- mode and we spend a period of time Quantum between two attempts on a + -- blocking operation. + + Unknown_System_Error : constant C.Strings.chars_ptr := + C.Strings.New_String ("Unknown system error"); + + 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_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, Typ, Protocol : C.int) return C.int; + pragma Import (C, Syscall_Socket, "socket"); + + function Non_Blocking_Socket (S : C.int) return Boolean; + procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean); + + -------------- + -- C_Accept -- + -------------- + + function C_Accept + (S : C.int; + Addr : System.Address; + Addrlen : 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 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)); + Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access); + end if; + + return R; + end C_Accept; + + --------------- + -- C_Connect -- + --------------- + + function C_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) return C.int + is + Res : C.int; + + begin + Res := Syscall_Connect (S, Name, Namelen); + + if 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 : C.int; + 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; + + GNAT_Msg : Msghdr; + for GNAT_Msg'Address use Msg; + pragma Import (Ada, GNAT_Msg); + + VMS_Msg : aliased VMS_Msghdr := VMS_Msghdr (GNAT_Msg); + + begin + loop + Res := Syscall_Recvmsg (S, VMS_Msg'Address, 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; + + GNAT_Msg := Msghdr (VMS_Msg); + + 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; + + GNAT_Msg : Msghdr; + for GNAT_Msg'Address use Msg; + pragma Import (Ada, GNAT_Msg); + + VMS_Msg : aliased VMS_Msghdr := VMS_Msghdr (GNAT_Msg); + + begin + loop + Res := Syscall_Sendmsg (S, VMS_Msg'Address, 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; + + GNAT_Msg := Msghdr (VMS_Msg); + + 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 + 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; + pragma Unreferenced (Discard); + + 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; + + 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 C.Strings.chars_ptr + is separate; + +end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi-vms.ads b/gcc/ada/g-socthi-vms.ads new file mode 100644 index 000000000..3a443ac65 --- /dev/null +++ b/gcc/ada/g-socthi-vms.ads @@ -0,0 +1,260 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a target dependent thin interface to the sockets +-- layer for use by the GNAT.Sockets package (g-socket.ads). This package +-- should not be directly with'ed by an applications program. + +-- This is the Alpha/VMS version + +with Interfaces.C.Strings; + +with GNAT.OS_Lib; +with GNAT.Sockets.Thin_Common; + +with System; +with System.CRTL; + +package GNAT.Sockets.Thin is + + -- ??? more comments needed ??? + + 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 C.Strings.chars_ptr; + -- 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 C.Strings.chars_ptr; + -- 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 : C.int; + 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 -- + ------------------------------------------- + + 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, "DECC$BIND"); + pragma Import (C, C_Close, "DECC$CLOSE"); + pragma Import (C, C_Gethostname, "DECC$GETHOSTNAME"); + pragma Import (C, C_Getpeername, "DECC$GETPEERNAME"); + pragma Import (C, C_Getsockname, "DECC$GETSOCKNAME"); + pragma Import (C, C_Getsockopt, "DECC$GETSOCKOPT"); + pragma Import (C, C_Listen, "DECC$LISTEN"); + pragma Import (C, C_Select, "DECC$SELECT"); + pragma Import (C, C_Setsockopt, "DECC$SETSOCKOPT"); + pragma Import (C, C_Shutdown, "DECC$SHUTDOWN"); + pragma Import (C, C_System, "DECC$SYSTEM"); + + pragma Import (C, Nonreentrant_Gethostbyname, "DECC$GETHOSTBYNAME"); + pragma Import (C, Nonreentrant_Gethostbyaddr, "DECC$GETHOSTBYADDR"); + pragma Import (C, Nonreentrant_Getservbyname, "DECC$GETSERVBYNAME"); + pragma Import (C, Nonreentrant_Getservbyport, "DECC$GETSERVBYPORT"); + +end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi-vxworks.adb b/gcc/ada/g-socthi-vxworks.adb new file mode 100644 index 000000000..8c119661e --- /dev/null +++ b/gcc/ada/g-socthi-vxworks.adb @@ -0,0 +1,494 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a target dependent thin interface to the sockets +-- layer for use by the GNAT.Sockets package (g-socket.ads). This package +-- should not be directly with'ed by an applications program. + +-- This version is for VxWorks + +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Task_Lock; + +with Interfaces.C; use Interfaces.C; + +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. + + Unknown_System_Error : constant C.Strings.chars_ptr := + C.Strings.New_String ("Unknown system error"); + + ----------------------- + -- 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 : C.int; + 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 C.Strings.chars_ptr + is separate; + +end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi-vxworks.ads b/gcc/ada/g-socthi-vxworks.ads new file mode 100644 index 000000000..64cc87668 --- /dev/null +++ b/gcc/ada/g-socthi-vxworks.ads @@ -0,0 +1,231 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a target dependent thin interface to the sockets +-- layer for use by the GNAT.Sockets package (g-socket.ads). This package +-- should not be directly with'ed by an applications program. + +-- This is the version for VxWorks + +with Interfaces.C.Strings; + +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 C.Strings.chars_ptr; + -- 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 C.Strings.chars_ptr; + -- 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 : C.int; + 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 new file mode 100644 index 000000000..301d8be45 --- /dev/null +++ b/gcc/ada/g-socthi.adb @@ -0,0 +1,499 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a target dependent thin interface to the sockets +-- layer for use by the GNAT.Sockets package (g-socket.ads). This package +-- should not be directly with'ed by an applications program. + +-- This is the 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. + + Unknown_System_Error : constant C.Strings.chars_ptr := + C.Strings.New_String ("Unknown system error"); + + -- 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 : C.int; + 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; + pragma Unreferenced (Discard); + + 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 C.Strings.chars_ptr + is separate; + +end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi.ads b/gcc/ada/g-socthi.ads new file mode 100644 index 000000000..32013c35e --- /dev/null +++ b/gcc/ada/g-socthi.ads @@ -0,0 +1,262 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a target dependent thin interface to the sockets +-- layer for use by the GNAT.Sockets package (g-socket.ads). This package +-- should not be directly with'ed by an applications program. + +-- This is the default version + +with Interfaces.C.Strings; + +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 C.Strings.chars_ptr; + -- 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 C.Strings.chars_ptr; + -- 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 : C.int; + 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 new file mode 100644 index 000000000..d28db1859 --- /dev/null +++ b/gcc/ada/g-soliop-mingw.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package 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 new file mode 100644 index 000000000..43fd27305 --- /dev/null +++ b/gcc/ada/g-soliop-solaris.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package 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 new file mode 100644 index 000000000..4016ab11b --- /dev/null +++ b/gcc/ada/g-soliop.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package 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 new file mode 100644 index 000000000..c4b8e0bbd --- /dev/null +++ b/gcc/ada/g-sothco-dummy.adb @@ -0,0 +1,34 @@ +------------------------------------------------------------------------------ +-- -- +-- 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, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma No_Body; diff --git a/gcc/ada/g-sothco-dummy.ads b/gcc/ada/g-sothco-dummy.ads new file mode 100644 index 000000000..9970e9ee8 --- /dev/null +++ b/gcc/ada/g-sothco-dummy.ads @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- 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, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package 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 new file mode 100644 index 000000000..7a8b5a13e --- /dev/null +++ b/gcc/ada/g-sothco.adb @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- 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, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package 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 new file mode 100644 index 000000000..c71a7ddf4 --- /dev/null +++ b/gcc/ada/g-sothco.ads @@ -0,0 +1,419 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the 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; + + use type C.int; + -- This is so we can declare the Failure constant below + + 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 + + -- Note: the hostent and servent accessors that return char* + -- values are compiled with GCC, and on VMS they always return + -- 64-bit pointers, so we can't use C.Strings.chars_ptr, which + -- on VMS is 32 bits. + + 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 : C.int; + 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 new file mode 100644 index 000000000..b49fa807b --- /dev/null +++ b/gcc/ada/g-souinf.ads @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2005 AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides 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 Pure; + + function File return String; + -- 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; + -- Return the current input line number. The result is considered to be a + -- static expression. + + function Source_Location return String; + -- 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; + -- 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. + +private + pragma Import (Intrinsic, File); + pragma Import (Intrinsic, Line); + pragma Import (Intrinsic, Source_Location); + pragma Import (Intrinsic, Enclosing_Entity); +end GNAT.Source_Info; diff --git a/gcc/ada/g-spchge.adb b/gcc/ada/g-spchge.adb new file mode 100755 index 000000000..b1278a648 --- /dev/null +++ b/gcc/ada/g-spchge.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit; + +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 new file mode 100755 index 000000000..786213bf1 --- /dev/null +++ b/gcc/ada/g-spchge.ads @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + +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 new file mode 100644 index 000000000..cd66efee7 --- /dev/null +++ b/gcc/ada/g-speche.adb @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit; + +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 new file mode 100644 index 000000000..0f9b39a62 --- /dev/null +++ b/gcc/ada/g-speche.ads @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Spelling checker + +-- This package provides a utility routine for checking for bad spellings +-- for the case of String arguments. + +pragma Compiler_Unit; + +package GNAT.Spelling_Checker is + pragma Pure; + + function Is_Bad_Spelling_Of + (Found : String; + Expect : String) return Boolean; + -- Determines if the string Found is a plausible misspelling of the string + -- Expect. Returns True for an exact match or a probably misspelling, False + -- if no near match is detected. This routine is case sensitive, so the + -- caller should fold both strings to get a case insensitive match. + -- + -- Note: the spec of this routine is deliberately rather vague. It is used + -- by GNAT itself to detect misspelled keywords and identifiers, and is + -- heuristically adjusted to be appropriate to this usage. It will work + -- well in any similar case of named entities. + +end GNAT.Spelling_Checker; diff --git a/gcc/ada/g-spipat.adb b/gcc/ada/g-spipat.adb new file mode 100644 index 000000000..a85697507 --- /dev/null +++ b/gcc/ada/g-spipat.adb @@ -0,0 +1,6452 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S P I T B O L . P A T T E R N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the data structures and general approach used in this implementation +-- are derived from the original MINIMAL sources for SPITBOL. The code is not +-- a direct translation, but the approach is followed closely. In particular, +-- we use the one stack approach developed in the SPITBOL implementation. + +with Ada.Strings.Unbounded.Aux; use Ada.Strings.Unbounded.Aux; + +with GNAT.Debug_Utilities; use GNAT.Debug_Utilities; + +with System; use System; + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +package body GNAT.Spitbol.Patterns is + + ------------------------ + -- Internal Debugging -- + ------------------------ + + Internal_Debug : constant Boolean := False; + -- Set this flag to True to activate some built-in debugging traceback + -- These are all lines output with PutD and Put_LineD. + + procedure New_LineD; + pragma Inline (New_LineD); + -- Output new blank line with New_Line if Internal_Debug is True + + procedure PutD (Str : String); + pragma Inline (PutD); + -- Output string with Put if Internal_Debug is True + + procedure Put_LineD (Str : String); + pragma Inline (Put_LineD); + -- Output string with Put_Line if Internal_Debug is True + + ----------------------------- + -- Local Type Declarations -- + ----------------------------- + + subtype String_Ptr is Ada.Strings.Unbounded.String_Access; + subtype File_Ptr is Ada.Text_IO.File_Access; + + function To_Address is new Ada.Unchecked_Conversion (PE_Ptr, Address); + -- Used only for debugging output purposes + + subtype AFC is Ada.Finalization.Controlled; + + N : constant PE_Ptr := null; + -- Shorthand used to initialize Copy fields to null + + type Natural_Ptr is access all Natural; + type Pattern_Ptr is access all Pattern; + + -------------------------------------------------- + -- Description of Algorithm and Data Structures -- + -------------------------------------------------- + + -- A pattern structure is represented as a linked graph of nodes + -- with the following structure: + + -- +------------------------------------+ + -- I Pcode I + -- +------------------------------------+ + -- I Index I + -- +------------------------------------+ + -- I Pthen I + -- +------------------------------------+ + -- I parameter(s) I + -- +------------------------------------+ + + -- Pcode is a code value indicating the type of the pattern node. This + -- code is used both as the discriminant value for the record, and as + -- the case index in the main match routine that branches to the proper + -- match code for the given element. + + -- Index is a serial index number. The use of these serial index + -- numbers is described in a separate section. + + -- Pthen is a pointer to the successor node, i.e the node to be matched + -- if the attempt to match the node succeeds. If this is the last node + -- of the pattern to be matched, then Pthen points to a dummy node + -- of kind PC_EOP (end of pattern), which initializes pattern exit. + + -- The parameter or parameters are present for certain node types, + -- and the type varies with the pattern code. + + type Pattern_Code is ( + PC_Arb_Y, + PC_Assign, + PC_Bal, + PC_BreakX_X, + PC_Cancel, + PC_EOP, + PC_Fail, + PC_Fence, + PC_Fence_X, + PC_Fence_Y, + PC_R_Enter, + PC_R_Remove, + PC_R_Restore, + PC_Rest, + PC_Succeed, + PC_Unanchored, + + PC_Alt, + PC_Arb_X, + PC_Arbno_S, + PC_Arbno_X, + + PC_Rpat, + + PC_Pred_Func, + + PC_Assign_Imm, + PC_Assign_OnM, + PC_Any_VP, + PC_Break_VP, + PC_BreakX_VP, + PC_NotAny_VP, + PC_NSpan_VP, + PC_Span_VP, + PC_String_VP, + + PC_Write_Imm, + PC_Write_OnM, + + PC_Null, + PC_String, + + PC_String_2, + PC_String_3, + PC_String_4, + PC_String_5, + PC_String_6, + + PC_Setcur, + + PC_Any_CH, + PC_Break_CH, + PC_BreakX_CH, + PC_Char, + PC_NotAny_CH, + PC_NSpan_CH, + PC_Span_CH, + + PC_Any_CS, + PC_Break_CS, + PC_BreakX_CS, + PC_NotAny_CS, + PC_NSpan_CS, + PC_Span_CS, + + PC_Arbno_Y, + PC_Len_Nat, + PC_Pos_Nat, + PC_RPos_Nat, + PC_RTab_Nat, + PC_Tab_Nat, + + PC_Pos_NF, + PC_Len_NF, + PC_RPos_NF, + PC_RTab_NF, + PC_Tab_NF, + + PC_Pos_NP, + PC_Len_NP, + PC_RPos_NP, + PC_RTab_NP, + PC_Tab_NP, + + PC_Any_VF, + PC_Break_VF, + PC_BreakX_VF, + PC_NotAny_VF, + PC_NSpan_VF, + PC_Span_VF, + PC_String_VF); + + type IndexT is range 0 .. +(2 **15 - 1); + + type PE (Pcode : Pattern_Code) is record + + Index : IndexT; + -- Serial index number of pattern element within pattern + + Pthen : PE_Ptr; + -- Successor element, to be matched after this one + + case Pcode is + + when PC_Arb_Y | + PC_Assign | + PC_Bal | + PC_BreakX_X | + PC_Cancel | + PC_EOP | + PC_Fail | + PC_Fence | + PC_Fence_X | + PC_Fence_Y | + PC_Null | + PC_R_Enter | + PC_R_Remove | + PC_R_Restore | + PC_Rest | + PC_Succeed | + PC_Unanchored => null; + + when PC_Alt | + PC_Arb_X | + PC_Arbno_S | + PC_Arbno_X => Alt : PE_Ptr; + + when PC_Rpat => PP : Pattern_Ptr; + + when PC_Pred_Func => BF : Boolean_Func; + + when PC_Assign_Imm | + PC_Assign_OnM | + PC_Any_VP | + PC_Break_VP | + PC_BreakX_VP | + PC_NotAny_VP | + PC_NSpan_VP | + PC_Span_VP | + PC_String_VP => VP : VString_Ptr; + + when PC_Write_Imm | + PC_Write_OnM => FP : File_Ptr; + + when PC_String => Str : String_Ptr; + + when PC_String_2 => Str2 : String (1 .. 2); + + when PC_String_3 => Str3 : String (1 .. 3); + + when PC_String_4 => Str4 : String (1 .. 4); + + when PC_String_5 => Str5 : String (1 .. 5); + + when PC_String_6 => Str6 : String (1 .. 6); + + when PC_Setcur => Var : Natural_Ptr; + + when PC_Any_CH | + PC_Break_CH | + PC_BreakX_CH | + PC_Char | + PC_NotAny_CH | + PC_NSpan_CH | + PC_Span_CH => Char : Character; + + when PC_Any_CS | + PC_Break_CS | + PC_BreakX_CS | + PC_NotAny_CS | + PC_NSpan_CS | + PC_Span_CS => CS : Character_Set; + + when PC_Arbno_Y | + PC_Len_Nat | + PC_Pos_Nat | + PC_RPos_Nat | + PC_RTab_Nat | + PC_Tab_Nat => Nat : Natural; + + when PC_Pos_NF | + PC_Len_NF | + PC_RPos_NF | + PC_RTab_NF | + PC_Tab_NF => NF : Natural_Func; + + when PC_Pos_NP | + PC_Len_NP | + PC_RPos_NP | + PC_RTab_NP | + PC_Tab_NP => NP : Natural_Ptr; + + when PC_Any_VF | + PC_Break_VF | + PC_BreakX_VF | + PC_NotAny_VF | + PC_NSpan_VF | + PC_Span_VF | + PC_String_VF => VF : VString_Func; + + end case; + end record; + + subtype PC_Has_Alt is Pattern_Code range PC_Alt .. PC_Arbno_X; + -- Range of pattern codes that has an Alt field. This is used in the + -- recursive traversals, since these links must be followed. + + EOP_Element : aliased constant PE := (PC_EOP, 0, N); + -- This is the end of pattern element, and is thus the representation of + -- a null pattern. It has a zero index element since it is never placed + -- inside a pattern. Furthermore it does not need a successor, since it + -- marks the end of the pattern, so that no more successors are needed. + + EOP : constant PE_Ptr := EOP_Element'Unrestricted_Access; + -- This is the end of pattern pointer, that is used in the Pthen pointer + -- of other nodes to signal end of pattern. + + -- The following array is used to determine if a pattern used as an + -- argument for Arbno is eligible for treatment using the simple Arbno + -- structure (i.e. it is a pattern that is guaranteed to match at least + -- one character on success, and not to make any entries on the stack. + + OK_For_Simple_Arbno : constant array (Pattern_Code) of Boolean := + (PC_Any_CS | + PC_Any_CH | + PC_Any_VF | + PC_Any_VP | + PC_Char | + PC_Len_Nat | + PC_NotAny_CS | + PC_NotAny_CH | + PC_NotAny_VF | + PC_NotAny_VP | + PC_Span_CS | + PC_Span_CH | + PC_Span_VF | + PC_Span_VP | + PC_String | + PC_String_2 | + PC_String_3 | + PC_String_4 | + PC_String_5 | + PC_String_6 => True, + others => False); + + ------------------------------- + -- The Pattern History Stack -- + ------------------------------- + + -- The pattern history stack is used for controlling backtracking when + -- a match fails. The idea is to stack entries that give a cursor value + -- to be restored, and a node to be reestablished as the current node to + -- attempt an appropriate rematch operation. The processing for a pattern + -- element that has rematch alternatives pushes an appropriate entry or + -- entry on to the stack, and the proceeds. If a match fails at any point, + -- the top element of the stack is popped off, resetting the cursor and + -- the match continues by accessing the node stored with this entry. + + type Stack_Entry is record + + Cursor : Integer; + -- Saved cursor value that is restored when this entry is popped + -- from the stack if a match attempt fails. Occasionally, this + -- field is used to store a history stack pointer instead of a + -- cursor. Such cases are noted in the documentation and the value + -- stored is negative since stack pointer values are always negative. + + Node : PE_Ptr; + -- This pattern element reference is reestablished as the current + -- Node to be matched (which will attempt an appropriate rematch). + + end record; + + subtype Stack_Range is Integer range -Stack_Size .. -1; + + type Stack_Type is array (Stack_Range) of Stack_Entry; + -- The type used for a history stack. The actual instance of the stack + -- is declared as a local variable in the Match routine, to properly + -- handle recursive calls to Match. All stack pointer values are negative + -- to distinguish them from normal cursor values. + + -- Note: the pattern matching stack is used only to handle backtracking. + -- If no backtracking occurs, its entries are never accessed, and never + -- popped off, and in particular it is normal for a successful match + -- to terminate with entries on the stack that are simply discarded. + + -- Note: in subsequent diagrams of the stack, we always place element + -- zero (the deepest element) at the top of the page, then build the + -- stack down on the page with the most recent (top of stack) element + -- being the bottom-most entry on the page. + + -- Stack checking is handled by labeling every pattern with the maximum + -- number of stack entries that are required, so a single check at the + -- start of matching the pattern suffices. There are two exceptions. + + -- First, the count does not include entries for recursive pattern + -- references. Such recursions must therefore perform a specific + -- stack check with respect to the number of stack entries required + -- by the recursive pattern that is accessed and the amount of stack + -- that remains unused. + + -- Second, the count includes only one iteration of an Arbno pattern, + -- so a specific check must be made on subsequent iterations that there + -- is still enough stack space left. The Arbno node has a field that + -- records the number of stack entries required by its argument for + -- this purpose. + + --------------------------------------------------- + -- Use of Serial Index Field in Pattern Elements -- + --------------------------------------------------- + + -- The serial index numbers for the pattern elements are assigned as + -- a pattern is constructed from its constituent elements. Note that there + -- is never any sharing of pattern elements between patterns (copies are + -- always made), so the serial index numbers are unique to a particular + -- pattern as referenced from the P field of a value of type Pattern. + + -- The index numbers meet three separate invariants, which are used for + -- various purposes as described in this section. + + -- First, the numbers uniquely identify the pattern elements within a + -- pattern. If Num is the number of elements in a given pattern, then + -- the serial index numbers for the elements of this pattern will range + -- from 1 .. Num, so that each element has a separate value. + + -- The purpose of this assignment is to provide a convenient auxiliary + -- data structure mechanism during operations which must traverse a + -- pattern (e.g. copy and finalization processing). Once constructed + -- patterns are strictly read only. This is necessary to allow sharing + -- of patterns between tasks. This means that we cannot go marking the + -- pattern (e.g. with a visited bit). Instead we construct a separate + -- vector that contains the necessary information indexed by the Index + -- values in the pattern elements. For this purpose the only requirement + -- is that they be uniquely assigned. + + -- Second, the pattern element referenced directly, i.e. the leading + -- pattern element, is always the maximum numbered element and therefore + -- indicates the total number of elements in the pattern. More precisely, + -- the element referenced by the P field of a pattern value, or the + -- element returned by any of the internal pattern construction routines + -- in the body (that return a value of type PE_Ptr) always is this + -- maximum element, + + -- The purpose of this requirement is to allow an immediate determination + -- of the number of pattern elements within a pattern. This is used to + -- properly size the vectors used to contain auxiliary information for + -- traversal as described above. + + -- Third, as compound pattern structures are constructed, the way in which + -- constituent parts of the pattern are constructed is stylized. This is + -- an automatic consequence of the way that these compound structures + -- are constructed, and basically what we are doing is simply documenting + -- and specifying the natural result of the pattern construction. The + -- section describing compound pattern structures gives details of the + -- numbering of each compound pattern structure. + + -- The purpose of specifying the stylized numbering structures for the + -- compound patterns is to help simplify the processing in the Image + -- function, since it eases the task of retrieving the original recursive + -- structure of the pattern from the flat graph structure of elements. + -- This use in the Image function is the only point at which the code + -- makes use of the stylized structures. + + type Ref_Array is array (IndexT range <>) of PE_Ptr; + -- This type is used to build an array whose N'th entry references the + -- element in a pattern whose Index value is N. See Build_Ref_Array. + + procedure Build_Ref_Array (E : PE_Ptr; RA : out Ref_Array); + -- Given a pattern element which is the leading element of a pattern + -- structure, and a Ref_Array with bounds 1 .. E.Index, fills in the + -- Ref_Array so that its N'th entry references the element of the + -- referenced pattern whose Index value is N. + + ------------------------------- + -- Recursive Pattern Matches -- + ------------------------------- + + -- The pattern primitive (+P) where P is a Pattern_Ptr or Pattern_Func + -- causes a recursive pattern match. This cannot be handled by an actual + -- recursive call to the outer level Match routine, since this would not + -- allow for possible backtracking into the region matched by the inner + -- pattern. Indeed this is the classical clash between recursion and + -- backtracking, and a simple recursive stack structure does not suffice. + + -- This section describes how this recursion and the possible associated + -- backtracking is handled. We still use a single stack, but we establish + -- the concept of nested regions on this stack, each of which has a stack + -- base value pointing to the deepest stack entry of the region. The base + -- value for the outer level is zero. + + -- When a recursive match is established, two special stack entries are + -- made. The first entry is used to save the original node that starts + -- the recursive match. This is saved so that the successor field of + -- this node is accessible at the end of the match, but it is never + -- popped and executed. + + -- The second entry corresponds to a standard new region action. A + -- PC_R_Remove node is stacked, whose cursor field is used to store + -- the outer stack base, and the stack base is reset to point to + -- this PC_R_Remove node. Then the recursive pattern is matched and + -- it can make history stack entries in the normal matter, so now + -- the stack looks like: + + -- (stack entries made by outer level) + + -- (Special entry, node is (+P) successor + -- cursor entry is not used) + + -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack base + -- saved base value for the enclosing region) + + -- (stack entries made by inner level) + + -- If a subsequent failure occurs and pops the PC_R_Remove node, it + -- removes itself and the special entry immediately underneath it, + -- restores the stack base value for the enclosing region, and then + -- again signals failure to look for alternatives that were stacked + -- before the recursion was initiated. + + -- Now we need to consider what happens if the inner pattern succeeds, as + -- signalled by accessing the special PC_EOP pattern primitive. First we + -- recognize the nested case by looking at the Base value. If this Base + -- value is Stack'First, then the entire match has succeeded, but if the + -- base value is greater than Stack'First, then we have successfully + -- matched an inner pattern, and processing continues at the outer level. + + -- There are two cases. The simple case is when the inner pattern has made + -- no stack entries, as recognized by the fact that the current stack + -- pointer is equal to the current base value. In this case it is fine to + -- remove all trace of the recursion by restoring the outer base value and + -- using the special entry to find the appropriate successor node. + + -- The more complex case arises when the inner match does make stack + -- entries. In this case, the PC_EOP processing stacks a special entry + -- whose cursor value saves the saved inner base value (the one that + -- references the corresponding PC_R_Remove value), and whose node + -- pointer references a PC_R_Restore node, so the stack looks like: + + -- (stack entries made by outer level) + + -- (Special entry, node is (+P) successor, + -- cursor entry is not used) + + -- (PC_R_Remove entry, "cursor" value is (negative) + -- saved base value for the enclosing region) + + -- (stack entries made by inner level) + + -- (PC_Region_Replace entry, "cursor" value is (negative) + -- stack pointer value referencing the PC_R_Remove entry). + + -- If the entire match succeeds, then these stack entries are, as usual, + -- ignored and abandoned. If on the other hand a subsequent failure + -- causes the PC_Region_Replace entry to be popped, it restores the + -- inner base value from its saved "cursor" value and then fails again. + -- Note that it is OK that the cursor is temporarily clobbered by this + -- pop, since the second failure will reestablish a proper cursor value. + + --------------------------------- + -- Compound Pattern Structures -- + --------------------------------- + + -- This section discusses the compound structures used to represent + -- constructed patterns. It shows the graph structures of pattern + -- elements that are constructed, and in the case of patterns that + -- provide backtracking possibilities, describes how the history + -- stack is used to control the backtracking. Finally, it notes the + -- way in which the Index numbers are assigned to the structure. + + -- In all diagrams, solid lines (built with minus signs or vertical + -- bars, represent successor pointers (Pthen fields) with > or V used + -- to indicate the direction of the pointer. The initial node of the + -- structure is in the upper left of the diagram. A dotted line is an + -- alternative pointer from the element above it to the element below + -- it. See individual sections for details on how alternatives are used. + + ------------------- + -- Concatenation -- + ------------------- + + -- In the pattern structures listed in this section, a line that looks + -- like ----> with nothing to the right indicates an end of pattern + -- (EOP) pointer that represents the end of the match. + + -- When a pattern concatenation (L & R) occurs, the resulting structure + -- is obtained by finding all such EOP pointers in L, and replacing + -- them to point to R. This is the most important flattening that + -- occurs in constructing a pattern, and it means that the pattern + -- matching circuitry does not have to keep track of the structure + -- of a pattern with respect to concatenation, since the appropriate + -- successor is always at hand. + + -- Concatenation itself generates no additional possibilities for + -- backtracking, but the constituent patterns of the concatenated + -- structure will make stack entries as usual. The maximum amount + -- of stack required by the structure is thus simply the sum of the + -- maximums required by L and R. + + -- The index numbering of a concatenation structure works by leaving + -- the numbering of the right hand pattern, R, unchanged and adjusting + -- the numbers in the left hand pattern, L up by the count of elements + -- in R. This ensures that the maximum numbered element is the leading + -- element as required (given that it was the leading element in L). + + ----------------- + -- Alternation -- + ----------------- + + -- A pattern (L or R) constructs the structure: + + -- +---+ +---+ + -- | A |---->| L |----> + -- +---+ +---+ + -- . + -- . + -- +---+ + -- | R |----> + -- +---+ + + -- The A element here is a PC_Alt node, and the dotted line represents + -- the contents of the Alt field. When the PC_Alt element is matched, + -- it stacks a pointer to the leading element of R on the history stack + -- so that on subsequent failure, a match of R is attempted. + + -- The A node is the highest numbered element in the pattern. The + -- original index numbers of R are unchanged, but the index numbers + -- of the L pattern are adjusted up by the count of elements in R. + + -- Note that the difference between the index of the L leading element + -- the index of the R leading element (after building the alt structure) + -- indicates the number of nodes in L, and this is true even after the + -- structure is incorporated into some larger structure. For example, + -- if the A node has index 16, and L has index 15 and R has index + -- 5, then we know that L has 10 (15-5) elements in it. + + -- Suppose that we now concatenate this structure to another pattern + -- with 9 elements in it. We will now have the A node with an index + -- of 25, L with an index of 24 and R with an index of 14. We still + -- know that L has 10 (24-14) elements in it, numbered 15-24, and + -- consequently the successor of the alternation structure has an + -- index with a value less than 15. This is used in Image to figure + -- out the original recursive structure of a pattern. + + -- To clarify the interaction of the alternation and concatenation + -- structures, here is a more complex example of the structure built + -- for the pattern: + + -- (V or W or X) (Y or Z) + + -- where A,B,C,D,E are all single element patterns: + + -- +---+ +---+ +---+ +---+ + -- I A I---->I V I---+-->I A I---->I Y I----> + -- +---+ +---+ I +---+ +---+ + -- . I . + -- . I . + -- +---+ +---+ I +---+ + -- I A I---->I W I-->I I Z I----> + -- +---+ +---+ I +---+ + -- . I + -- . I + -- +---+ I + -- I X I------------>+ + -- +---+ + + -- The numbering of the nodes would be as follows: + + -- +---+ +---+ +---+ +---+ + -- I 8 I---->I 7 I---+-->I 3 I---->I 2 I----> + -- +---+ +---+ I +---+ +---+ + -- . I . + -- . I . + -- +---+ +---+ I +---+ + -- I 6 I---->I 5 I-->I I 1 I----> + -- +---+ +---+ I +---+ + -- . I + -- . I + -- +---+ I + -- I 4 I------------>+ + -- +---+ + + -- Note: The above structure actually corresponds to + + -- (A or (B or C)) (D or E) + + -- rather than + + -- ((A or B) or C) (D or E) + + -- which is the more natural interpretation, but in fact alternation + -- is associative, and the construction of an alternative changes the + -- left grouped pattern to the right grouped pattern in any case, so + -- that the Image function produces a more natural looking output. + + --------- + -- Arb -- + --------- + + -- An Arb pattern builds the structure + + -- +---+ + -- | X |----> + -- +---+ + -- . + -- . + -- +---+ + -- | Y |----> + -- +---+ + + -- The X node is a PC_Arb_X node, which matches null, and stacks a + -- pointer to Y node, which is the PC_Arb_Y node that matches one + -- extra character and restacks itself. + + -- The PC_Arb_X node is numbered 2, and the PC_Arb_Y node is 1 + + ------------------------- + -- Arbno (simple case) -- + ------------------------- + + -- The simple form of Arbno can be used where the pattern always + -- matches at least one character if it succeeds, and it is known + -- not to make any history stack entries. In this case, Arbno (P) + -- can construct the following structure: + + -- +-------------+ + -- | ^ + -- V | + -- +---+ | + -- | S |----> | + -- +---+ | + -- . | + -- . | + -- +---+ | + -- | P |---------->+ + -- +---+ + + -- The S (PC_Arbno_S) node matches null stacking a pointer to the + -- pattern P. If a subsequent failure causes P to be matched and + -- this match succeeds, then node A gets restacked to try another + -- instance if needed by a subsequent failure. + + -- The node numbering of the constituent pattern P is not affected. + -- The S node has a node number of P.Index + 1. + + -------------------------- + -- Arbno (complex case) -- + -------------------------- + + -- A call to Arbno (P), where P can match null (or at least is not + -- known to require a non-null string) and/or P requires pattern stack + -- entries, constructs the following structure: + + -- +--------------------------+ + -- | ^ + -- V | + -- +---+ | + -- | X |----> | + -- +---+ | + -- . | + -- . | + -- +---+ +---+ +---+ | + -- | E |---->| P |---->| Y |--->+ + -- +---+ +---+ +---+ + + -- The node X (PC_Arbno_X) matches null, stacking a pointer to the + -- E-P-X structure used to match one Arbno instance. + + -- Here E is the PC_R_Enter node which matches null and creates two + -- stack entries. The first is a special entry whose node field is + -- not used at all, and whose cursor field has the initial cursor. + + -- The second entry corresponds to a standard new region action. A + -- PC_R_Remove node is stacked, whose cursor field is used to store + -- the outer stack base, and the stack base is reset to point to + -- this PC_R_Remove node. Then the pattern P is matched, and it can + -- make history stack entries in the normal manner, so now the stack + -- looks like: + + -- (stack entries made before assign pattern) + + -- (Special entry, node field not used, + -- used only to save initial cursor) + + -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base + -- saved base value for the enclosing region) + + -- (stack entries made by matching P) + + -- If the match of P fails, then the PC_R_Remove entry is popped and + -- it removes both itself and the special entry underneath it, + -- restores the outer stack base, and signals failure. + + -- If the match of P succeeds, then node Y, the PC_Arbno_Y node, pops + -- the inner region. There are two possibilities. If matching P left + -- no stack entries, then all traces of the inner region can be removed. + -- If there are stack entries, then we push an PC_Region_Replace stack + -- entry whose "cursor" value is the inner stack base value, and then + -- restore the outer stack base value, so the stack looks like: + + -- (stack entries made before assign pattern) + + -- (Special entry, node field not used, + -- used only to save initial cursor) + + -- (PC_R_Remove entry, "cursor" value is (negative) + -- saved base value for the enclosing region) + + -- (stack entries made by matching P) + + -- (PC_Region_Replace entry, "cursor" value is (negative) + -- stack pointer value referencing the PC_R_Remove entry). + + -- Now that we have matched another instance of the Arbno pattern, + -- we need to move to the successor. There are two cases. If the + -- Arbno pattern matched null, then there is no point in seeking + -- alternatives, since we would just match a whole bunch of nulls. + -- In this case we look through the alternative node, and move + -- directly to its successor (i.e. the successor of the Arbno + -- pattern). If on the other hand a non-null string was matched, + -- we simply follow the successor to the alternative node, which + -- sets up for another possible match of the Arbno pattern. + + -- As noted in the section on stack checking, the stack count (and + -- hence the stack check) for a pattern includes only one iteration + -- of the Arbno pattern. To make sure that multiple iterations do not + -- overflow the stack, the Arbno node saves the stack count required + -- by a single iteration, and the Concat function increments this to + -- include stack entries required by any successor. The PC_Arbno_Y + -- node uses this count to ensure that sufficient stack remains + -- before proceeding after matching each new instance. + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the Y node is numbered N + 1, + -- the E node is N + 2, and the X node is N + 3. + + ---------------------- + -- Assign Immediate -- + ---------------------- + + -- Immediate assignment (P * V) constructs the following structure + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| A |----> + -- +---+ +---+ +---+ + + -- Here E is the PC_R_Enter node which matches null and creates two + -- stack entries. The first is a special entry whose node field is + -- not used at all, and whose cursor field has the initial cursor. + + -- The second entry corresponds to a standard new region action. A + -- PC_R_Remove node is stacked, whose cursor field is used to store + -- the outer stack base, and the stack base is reset to point to + -- this PC_R_Remove node. Then the pattern P is matched, and it can + -- make history stack entries in the normal manner, so now the stack + -- looks like: + + -- (stack entries made before assign pattern) + + -- (Special entry, node field not used, + -- used only to save initial cursor) + + -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base + -- saved base value for the enclosing region) + + -- (stack entries made by matching P) + + -- If the match of P fails, then the PC_R_Remove entry is popped + -- and it removes both itself and the special entry underneath it, + -- restores the outer stack base, and signals failure. + + -- If the match of P succeeds, then node A, which is the actual + -- PC_Assign_Imm node, executes the assignment (using the stack + -- base to locate the entry with the saved starting cursor value), + -- and the pops the inner region. There are two possibilities, if + -- matching P left no stack entries, then all traces of the inner + -- region can be removed. If there are stack entries, then we push + -- an PC_Region_Replace stack entry whose "cursor" value is the + -- inner stack base value, and then restore the outer stack base + -- value, so the stack looks like: + + -- (stack entries made before assign pattern) + + -- (Special entry, node field not used, + -- used only to save initial cursor) + + -- (PC_R_Remove entry, "cursor" value is (negative) + -- saved base value for the enclosing region) + + -- (stack entries made by matching P) + + -- (PC_Region_Replace entry, "cursor" value is the (negative) + -- stack pointer value referencing the PC_R_Remove entry). + + -- If a subsequent failure occurs, the PC_Region_Replace node restores + -- the inner stack base value and signals failure to explore rematches + -- of the pattern P. + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the A node is numbered N + 1, + -- and the E node is N + 2. + + --------------------- + -- Assign On Match -- + --------------------- + + -- The assign on match (**) pattern is quite similar to the assign + -- immediate pattern, except that the actual assignment has to be + -- delayed. The following structure is constructed: + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| A |----> + -- +---+ +---+ +---+ + + -- The operation of this pattern is identical to that described above + -- for deferred assignment, up to the point where P has been matched. + + -- The A node, which is the PC_Assign_OnM node first pushes a + -- PC_Assign node onto the history stack. This node saves the ending + -- cursor and acts as a flag for the final assignment, as further + -- described below. + + -- It then stores a pointer to itself in the special entry node field. + -- This was otherwise unused, and is now used to retrieve the address + -- of the variable to be assigned at the end of the pattern. + + -- After that the inner region is terminated in the usual manner, + -- by stacking a PC_R_Restore entry as described for the assign + -- immediate case. Note that the optimization of completely + -- removing the inner region does not happen in this case, since + -- we have at least one stack entry (the PC_Assign one we just made). + -- The stack now looks like: + + -- (stack entries made before assign pattern) + + -- (Special entry, node points to copy of + -- the PC_Assign_OnM node, and the + -- cursor field saves the initial cursor). + + -- (PC_R_Remove entry, "cursor" value is (negative) + -- saved base value for the enclosing region) + + -- (stack entries made by matching P) + + -- (PC_Assign entry, saves final cursor) + + -- (PC_Region_Replace entry, "cursor" value is (negative) + -- stack pointer value referencing the PC_R_Remove entry). + + -- If a subsequent failure causes the PC_Assign node to execute it + -- simply removes itself and propagates the failure. + + -- If the match succeeds, then the history stack is scanned for + -- PC_Assign nodes, and the assignments are executed (examination + -- of the above diagram will show that all the necessary data is + -- at hand for the assignment). + + -- To optimize the common case where no assign-on-match operations + -- are present, a global flag Assign_OnM is maintained which is + -- initialize to False, and gets set True as part of the execution + -- of the PC_Assign_OnM node. The scan of the history stack for + -- PC_Assign entries is done only if this flag is set. + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the A node is numbered N + 1, + -- and the E node is N + 2. + + --------- + -- Bal -- + --------- + + -- Bal builds a single node: + + -- +---+ + -- | B |----> + -- +---+ + + -- The node B is the PC_Bal node which matches a parentheses balanced + -- string, starting at the current cursor position. It then updates + -- the cursor past this matched string, and stacks a pointer to itself + -- with this updated cursor value on the history stack, to extend the + -- matched string on a subsequent failure. + + -- Since this is a single node it is numbered 1 (the reason we include + -- it in the compound patterns section is that it backtracks). + + ------------ + -- BreakX -- + ------------ + + -- BreakX builds the structure + + -- +---+ +---+ + -- | B |---->| A |----> + -- +---+ +---+ + -- ^ . + -- | . + -- | +---+ + -- +<------| X | + -- +---+ + + -- Here the B node is the BreakX_xx node that performs a normal Break + -- function. The A node is an alternative (PC_Alt) node that matches + -- null, but stacks a pointer to node X (the PC_BreakX_X node) which + -- extends the match one character (to eat up the previously detected + -- break character), and then rematches the break. + + -- The B node is numbered 3, the alternative node is 1, and the X + -- node is 2. + + ----------- + -- Fence -- + ----------- + + -- Fence builds a single node: + + -- +---+ + -- | F |----> + -- +---+ + + -- The element F, PC_Fence, matches null, and stacks a pointer to a + -- PC_Cancel element which will abort the match on a subsequent failure. + + -- Since this is a single element it is numbered 1 (the reason we + -- include it in the compound patterns section is that it backtracks). + + -------------------- + -- Fence Function -- + -------------------- + + -- A call to the Fence function builds the structure: + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| X |----> + -- +---+ +---+ +---+ + + -- Here E is the PC_R_Enter node which matches null and creates two + -- stack entries. The first is a special entry which is not used at + -- all in the fence case (it is present merely for uniformity with + -- other cases of region enter operations). + + -- The second entry corresponds to a standard new region action. A + -- PC_R_Remove node is stacked, whose cursor field is used to store + -- the outer stack base, and the stack base is reset to point to + -- this PC_R_Remove node. Then the pattern P is matched, and it can + -- make history stack entries in the normal manner, so now the stack + -- looks like: + + -- (stack entries made before fence pattern) + + -- (Special entry, not used at all) + + -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base + -- saved base value for the enclosing region) + + -- (stack entries made by matching P) + + -- If the match of P fails, then the PC_R_Remove entry is popped + -- and it removes both itself and the special entry underneath it, + -- restores the outer stack base, and signals failure. + + -- If the match of P succeeds, then node X, the PC_Fence_X node, gets + -- control. One might be tempted to think that at this point, the + -- history stack entries made by matching P can just be removed since + -- they certainly are not going to be used for rematching (that is + -- whole point of Fence after all!) However, this is wrong, because + -- it would result in the loss of possible assign-on-match entries + -- for deferred pattern assignments. + + -- Instead what we do is to make a special entry whose node references + -- PC_Fence_Y, and whose cursor saves the inner stack base value, i.e. + -- the pointer to the PC_R_Remove entry. Then the outer stack base + -- pointer is restored, so the stack looks like: + + -- (stack entries made before assign pattern) + + -- (Special entry, not used at all) + + -- (PC_R_Remove entry, "cursor" value is (negative) + -- saved base value for the enclosing region) + + -- (stack entries made by matching P) + + -- (PC_Fence_Y entry, "cursor" value is (negative) stack + -- pointer value referencing the PC_R_Remove entry). + + -- If a subsequent failure occurs, then the PC_Fence_Y entry removes + -- the entire inner region, including all entries made by matching P, + -- and alternatives prior to the Fence pattern are sought. + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the X node is numbered N + 1, + -- and the E node is N + 2. + + ------------- + -- Succeed -- + ------------- + + -- Succeed builds a single node: + + -- +---+ + -- | S |----> + -- +---+ + + -- The node S is the PC_Succeed node which matches null, and stacks + -- a pointer to itself on the history stack, so that a subsequent + -- failure repeats the same match. + + -- Since this is a single node it is numbered 1 (the reason we include + -- it in the compound patterns section is that it backtracks). + + --------------------- + -- Write Immediate -- + --------------------- + + -- The structure built for a write immediate operation (P * F, where + -- F is a file access value) is: + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| W |----> + -- +---+ +---+ +---+ + + -- Here E is the PC_R_Enter node and W is the PC_Write_Imm node. The + -- handling is identical to that described above for Assign Immediate, + -- except that at the point where a successful match occurs, the matched + -- substring is written to the referenced file. + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the W node is numbered N + 1, + -- and the E node is N + 2. + + -------------------- + -- Write On Match -- + -------------------- + + -- The structure built for a write on match operation (P ** F, where + -- F is a file access value) is: + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| W |----> + -- +---+ +---+ +---+ + + -- Here E is the PC_R_Enter node and W is the PC_Write_OnM node. The + -- handling is identical to that described above for Assign On Match, + -- except that at the point where a successful match has completed, + -- the matched substring is written to the referenced file. + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the W node is numbered N + 1, + -- and the E node is N + 2. + ----------------------- + -- Constant Patterns -- + ----------------------- + + -- The following pattern elements are referenced only from the pattern + -- history stack. In each case the processing for the pattern element + -- results in pattern match abort, or further failure, so there is no + -- need for a successor and no need for a node number + + CP_Assign : aliased PE := (PC_Assign, 0, N); + CP_Cancel : aliased PE := (PC_Cancel, 0, N); + CP_Fence_Y : aliased PE := (PC_Fence_Y, 0, N); + CP_R_Remove : aliased PE := (PC_R_Remove, 0, N); + CP_R_Restore : aliased PE := (PC_R_Restore, 0, N); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Alternate (L, R : PE_Ptr) return PE_Ptr; + function "or" (L, R : PE_Ptr) return PE_Ptr renames Alternate; + -- Build pattern structure corresponding to the alternation of L, R. + -- (i.e. try to match L, and if that fails, try to match R). + + function Arbno_Simple (P : PE_Ptr) return PE_Ptr; + -- Build simple Arbno pattern, P is a pattern that is guaranteed to + -- match at least one character if it succeeds and to require no + -- stack entries under all circumstances. The result returned is + -- a simple Arbno structure as previously described. + + function Bracket (E, P, A : PE_Ptr) return PE_Ptr; + -- Given two single node pattern elements E and A, and a (possible + -- complex) pattern P, construct the concatenation E-->P-->A and + -- return a pointer to E. The concatenation does not affect the + -- node numbering in P. A has a number one higher than the maximum + -- number in P, and E has a number two higher than the maximum + -- number in P (see for example the Assign_Immediate structure to + -- understand a typical use of this function). + + function BreakX_Make (B : PE_Ptr) return Pattern; + -- Given a pattern element for a Break pattern, returns the + -- corresponding BreakX compound pattern structure. + + function Concat (L, R : PE_Ptr; Incr : Natural) return PE_Ptr; + -- Creates a pattern element that represents a concatenation of the + -- two given pattern elements (i.e. the pattern L followed by R). + -- The result returned is always the same as L, but the pattern + -- referenced by L is modified to have R as a successor. This + -- procedure does not copy L or R, so if a copy is required, it + -- is the responsibility of the caller. The Incr parameter is an + -- amount to be added to the Nat field of any P_Arbno_Y node that is + -- in the left operand, it represents the additional stack space + -- required by the right operand. + + function C_To_PE (C : PChar) return PE_Ptr; + -- Given a character, constructs a pattern element that matches + -- the single character. + + function Copy (P : PE_Ptr) return PE_Ptr; + -- Creates a copy of the pattern element referenced by the given + -- pattern element reference. This is a deep copy, which means that + -- it follows the Next and Alt pointers. + + function Image (P : PE_Ptr) return String; + -- Returns the image of the address of the referenced pattern element. + -- This is equivalent to Image (To_Address (P)); + + function Is_In (C : Character; Str : String) return Boolean; + pragma Inline (Is_In); + -- Determines if the character C is in string Str + + procedure Logic_Error; + -- Called to raise Program_Error with an appropriate message if an + -- internal logic error is detected. + + function Str_BF (A : Boolean_Func) return String; + function Str_FP (A : File_Ptr) return String; + function Str_NF (A : Natural_Func) return String; + function Str_NP (A : Natural_Ptr) return String; + function Str_PP (A : Pattern_Ptr) return String; + function Str_VF (A : VString_Func) return String; + function Str_VP (A : VString_Ptr) return String; + -- These are debugging routines, which return a representation of the + -- given access value (they are called only by Image and Dump) + + procedure Set_Successor (Pat : PE_Ptr; Succ : PE_Ptr); + -- Adjusts all EOP pointers in Pat to point to Succ. No other changes + -- are made. In particular, Succ is unchanged, and no index numbers + -- are modified. Note that Pat may not be equal to EOP on entry. + + function S_To_PE (Str : PString) return PE_Ptr; + -- Given a string, constructs a pattern element that matches the string + + procedure Uninitialized_Pattern; + pragma No_Return (Uninitialized_Pattern); + -- Called to raise Program_Error with an appropriate error message if + -- an uninitialized pattern is used in any pattern construction or + -- pattern matching operation. + + procedure XMatch + (Subject : String; + Pat_P : PE_Ptr; + Pat_S : Natural; + Start : out Natural; + Stop : out Natural); + -- This is the common pattern match routine. It is passed a string and + -- a pattern, and it indicates success or failure, and on success the + -- section of the string matched. It does not perform any assignments + -- to the subject string, so pattern replacement is for the caller. + -- + -- Subject The subject string. The lower bound is always one. In the + -- Match procedures, it is fine to use strings whose lower bound + -- is not one, but we perform a one time conversion before the + -- call to XMatch, so that XMatch does not have to be bothered + -- with strange lower bounds. + -- + -- Pat_P Points to initial pattern element of pattern to be matched + -- + -- Pat_S Maximum required stack entries for pattern to be matched + -- + -- Start If match is successful, starting index of matched section. + -- This value is always non-zero. A value of zero is used to + -- indicate a failed match. + -- + -- Stop If match is successful, ending index of matched section. + -- This can be zero if we match the null string at the start, + -- in which case Start is set to zero, and Stop to one. If the + -- Match fails, then the contents of Stop is undefined. + + procedure XMatchD + (Subject : String; + Pat_P : PE_Ptr; + Pat_S : Natural; + Start : out Natural; + Stop : out Natural); + -- Identical in all respects to XMatch, except that trace information is + -- output on Standard_Output during execution of the match. This is the + -- version that is called if the original Match call has Debug => True. + + --------- + -- "&" -- + --------- + + function "&" (L : PString; R : Pattern) return Pattern is + begin + return (AFC with R.Stk, Concat (S_To_PE (L), Copy (R.P), R.Stk)); + end "&"; + + function "&" (L : Pattern; R : PString) return Pattern is + begin + return (AFC with L.Stk, Concat (Copy (L.P), S_To_PE (R), 0)); + end "&"; + + function "&" (L : PChar; R : Pattern) return Pattern is + begin + return (AFC with R.Stk, Concat (C_To_PE (L), Copy (R.P), R.Stk)); + end "&"; + + function "&" (L : Pattern; R : PChar) return Pattern is + begin + return (AFC with L.Stk, Concat (Copy (L.P), C_To_PE (R), 0)); + end "&"; + + function "&" (L : Pattern; R : Pattern) return Pattern is + begin + return (AFC with L.Stk + R.Stk, Concat (Copy (L.P), Copy (R.P), R.Stk)); + end "&"; + + --------- + -- "*" -- + --------- + + -- Assign immediate + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| A |----> + -- +---+ +---+ +---+ + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the A node is numbered N + 1, + -- and the E node is N + 2. + + function "*" (P : Pattern; Var : VString_Var) return Pattern is + Pat : constant PE_Ptr := Copy (P.P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + A : constant PE_Ptr := + new PE'(PC_Assign_Imm, 0, EOP, Var'Unrestricted_Access); + begin + return (AFC with P.Stk + 3, Bracket (E, Pat, A)); + end "*"; + + function "*" (P : PString; Var : VString_Var) return Pattern is + Pat : constant PE_Ptr := S_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + A : constant PE_Ptr := + new PE'(PC_Assign_Imm, 0, EOP, Var'Unrestricted_Access); + begin + return (AFC with 3, Bracket (E, Pat, A)); + end "*"; + + function "*" (P : PChar; Var : VString_Var) return Pattern is + Pat : constant PE_Ptr := C_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + A : constant PE_Ptr := + new PE'(PC_Assign_Imm, 0, EOP, Var'Unrestricted_Access); + begin + return (AFC with 3, Bracket (E, Pat, A)); + end "*"; + + -- Write immediate + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| W |----> + -- +---+ +---+ +---+ + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the W node is numbered N + 1, + -- and the E node is N + 2. + + function "*" (P : Pattern; Fil : File_Access) return Pattern is + Pat : constant PE_Ptr := Copy (P.P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + W : constant PE_Ptr := new PE'(PC_Write_Imm, 0, EOP, Fil); + begin + return (AFC with 3, Bracket (E, Pat, W)); + end "*"; + + function "*" (P : PString; Fil : File_Access) return Pattern is + Pat : constant PE_Ptr := S_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + W : constant PE_Ptr := new PE'(PC_Write_Imm, 0, EOP, Fil); + begin + return (AFC with 3, Bracket (E, Pat, W)); + end "*"; + + function "*" (P : PChar; Fil : File_Access) return Pattern is + Pat : constant PE_Ptr := C_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + W : constant PE_Ptr := new PE'(PC_Write_Imm, 0, EOP, Fil); + begin + return (AFC with 3, Bracket (E, Pat, W)); + end "*"; + + ---------- + -- "**" -- + ---------- + + -- Assign on match + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| A |----> + -- +---+ +---+ +---+ + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the A node is numbered N + 1, + -- and the E node is N + 2. + + function "**" (P : Pattern; Var : VString_Var) return Pattern is + Pat : constant PE_Ptr := Copy (P.P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + A : constant PE_Ptr := + new PE'(PC_Assign_OnM, 0, EOP, Var'Unrestricted_Access); + begin + return (AFC with P.Stk + 3, Bracket (E, Pat, A)); + end "**"; + + function "**" (P : PString; Var : VString_Var) return Pattern is + Pat : constant PE_Ptr := S_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + A : constant PE_Ptr := + new PE'(PC_Assign_OnM, 0, EOP, Var'Unrestricted_Access); + begin + return (AFC with 3, Bracket (E, Pat, A)); + end "**"; + + function "**" (P : PChar; Var : VString_Var) return Pattern is + Pat : constant PE_Ptr := C_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + A : constant PE_Ptr := + new PE'(PC_Assign_OnM, 0, EOP, Var'Unrestricted_Access); + begin + return (AFC with 3, Bracket (E, Pat, A)); + end "**"; + + -- Write on match + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| W |----> + -- +---+ +---+ +---+ + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the W node is numbered N + 1, + -- and the E node is N + 2. + + function "**" (P : Pattern; Fil : File_Access) return Pattern is + Pat : constant PE_Ptr := Copy (P.P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + W : constant PE_Ptr := new PE'(PC_Write_OnM, 0, EOP, Fil); + begin + return (AFC with P.Stk + 3, Bracket (E, Pat, W)); + end "**"; + + function "**" (P : PString; Fil : File_Access) return Pattern is + Pat : constant PE_Ptr := S_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + W : constant PE_Ptr := new PE'(PC_Write_OnM, 0, EOP, Fil); + begin + return (AFC with 3, Bracket (E, Pat, W)); + end "**"; + + function "**" (P : PChar; Fil : File_Access) return Pattern is + Pat : constant PE_Ptr := C_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + W : constant PE_Ptr := new PE'(PC_Write_OnM, 0, EOP, Fil); + begin + return (AFC with 3, Bracket (E, Pat, W)); + end "**"; + + --------- + -- "+" -- + --------- + + function "+" (Str : VString_Var) return Pattern is + begin + return + (AFC with 0, + new PE'(PC_String_VP, 1, EOP, Str'Unrestricted_Access)); + end "+"; + + function "+" (Str : VString_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_String_VF, 1, EOP, Str)); + end "+"; + + function "+" (P : Pattern_Var) return Pattern is + begin + return + (AFC with 3, + new PE'(PC_Rpat, 1, EOP, P'Unrestricted_Access)); + end "+"; + + function "+" (P : Boolean_Func) return Pattern is + begin + return (AFC with 3, new PE'(PC_Pred_Func, 1, EOP, P)); + end "+"; + + ---------- + -- "or" -- + ---------- + + function "or" (L : PString; R : Pattern) return Pattern is + begin + return (AFC with R.Stk + 1, S_To_PE (L) or Copy (R.P)); + end "or"; + + function "or" (L : Pattern; R : PString) return Pattern is + begin + return (AFC with L.Stk + 1, Copy (L.P) or S_To_PE (R)); + end "or"; + + function "or" (L : PString; R : PString) return Pattern is + begin + return (AFC with 1, S_To_PE (L) or S_To_PE (R)); + end "or"; + + function "or" (L : Pattern; R : Pattern) return Pattern is + begin + return (AFC with + Natural'Max (L.Stk, R.Stk) + 1, Copy (L.P) or Copy (R.P)); + end "or"; + + function "or" (L : PChar; R : Pattern) return Pattern is + begin + return (AFC with 1, C_To_PE (L) or Copy (R.P)); + end "or"; + + function "or" (L : Pattern; R : PChar) return Pattern is + begin + return (AFC with 1, Copy (L.P) or C_To_PE (R)); + end "or"; + + function "or" (L : PChar; R : PChar) return Pattern is + begin + return (AFC with 1, C_To_PE (L) or C_To_PE (R)); + end "or"; + + function "or" (L : PString; R : PChar) return Pattern is + begin + return (AFC with 1, S_To_PE (L) or C_To_PE (R)); + end "or"; + + function "or" (L : PChar; R : PString) return Pattern is + begin + return (AFC with 1, C_To_PE (L) or S_To_PE (R)); + end "or"; + + ------------ + -- Adjust -- + ------------ + + -- No two patterns share the same pattern elements, so the adjust + -- procedure for a Pattern assignment must do a deep copy of the + -- pattern element structure. + + procedure Adjust (Object : in out Pattern) is + begin + Object.P := Copy (Object.P); + end Adjust; + + --------------- + -- Alternate -- + --------------- + + function Alternate (L, R : PE_Ptr) return PE_Ptr is + begin + -- If the left pattern is null, then we just add the alternation + -- node with an index one greater than the right hand pattern. + + if L = EOP then + return new PE'(PC_Alt, R.Index + 1, EOP, R); + + -- If the left pattern is non-null, then build a reference vector + -- for its elements, and adjust their index values to accommodate + -- the right hand elements. Then add the alternation node. + + else + declare + Refs : Ref_Array (1 .. L.Index); + + begin + Build_Ref_Array (L, Refs); + + for J in Refs'Range loop + Refs (J).Index := Refs (J).Index + R.Index; + end loop; + end; + + return new PE'(PC_Alt, L.Index + 1, L, R); + end if; + end Alternate; + + --------- + -- Any -- + --------- + + function Any (Str : String) return Pattern is + begin + return (AFC with 0, new PE'(PC_Any_CS, 1, EOP, To_Set (Str))); + end Any; + + function Any (Str : VString) return Pattern is + begin + return Any (S (Str)); + end Any; + + function Any (Str : Character) return Pattern is + begin + return (AFC with 0, new PE'(PC_Any_CH, 1, EOP, Str)); + end Any; + + function Any (Str : Character_Set) return Pattern is + begin + return (AFC with 0, new PE'(PC_Any_CS, 1, EOP, Str)); + end Any; + + function Any (Str : not null access VString) return Pattern is + begin + return (AFC with 0, new PE'(PC_Any_VP, 1, EOP, VString_Ptr (Str))); + end Any; + + function Any (Str : VString_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_Any_VF, 1, EOP, Str)); + end Any; + + --------- + -- Arb -- + --------- + + -- +---+ + -- | X |----> + -- +---+ + -- . + -- . + -- +---+ + -- | Y |----> + -- +---+ + + -- The PC_Arb_X element is numbered 2, and the PC_Arb_Y element is 1 + + function Arb return Pattern is + Y : constant PE_Ptr := new PE'(PC_Arb_Y, 1, EOP); + X : constant PE_Ptr := new PE'(PC_Arb_X, 2, EOP, Y); + begin + return (AFC with 1, X); + end Arb; + + ----------- + -- Arbno -- + ----------- + + function Arbno (P : PString) return Pattern is + begin + if P'Length = 0 then + return (AFC with 0, EOP); + else + return (AFC with 0, Arbno_Simple (S_To_PE (P))); + end if; + end Arbno; + + function Arbno (P : PChar) return Pattern is + begin + return (AFC with 0, Arbno_Simple (C_To_PE (P))); + end Arbno; + + function Arbno (P : Pattern) return Pattern is + Pat : constant PE_Ptr := Copy (P.P); + + begin + if P.Stk = 0 + and then OK_For_Simple_Arbno (Pat.Pcode) + then + return (AFC with 0, Arbno_Simple (Pat)); + end if; + + -- This is the complex case, either the pattern makes stack entries + -- or it is possible for the pattern to match the null string (more + -- accurately, we don't know that this is not the case). + + -- +--------------------------+ + -- | ^ + -- V | + -- +---+ | + -- | X |----> | + -- +---+ | + -- . | + -- . | + -- +---+ +---+ +---+ | + -- | E |---->| P |---->| Y |--->+ + -- +---+ +---+ +---+ + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the Y node is numbered N + 1, + -- the E node is N + 2, and the X node is N + 3. + + declare + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + X : constant PE_Ptr := new PE'(PC_Arbno_X, 0, EOP, E); + Y : constant PE_Ptr := new PE'(PC_Arbno_Y, 0, X, P.Stk + 3); + EPY : constant PE_Ptr := Bracket (E, Pat, Y); + begin + X.Alt := EPY; + X.Index := EPY.Index + 1; + return (AFC with P.Stk + 3, X); + end; + end Arbno; + + ------------------ + -- Arbno_Simple -- + ------------------ + + -- +-------------+ + -- | ^ + -- V | + -- +---+ | + -- | S |----> | + -- +---+ | + -- . | + -- . | + -- +---+ | + -- | P |---------->+ + -- +---+ + + -- The node numbering of the constituent pattern P is not affected. + -- The S node has a node number of P.Index + 1. + + -- Note that we know that P cannot be EOP, because a null pattern + -- does not meet the requirements for simple Arbno. + + function Arbno_Simple (P : PE_Ptr) return PE_Ptr is + S : constant PE_Ptr := new PE'(PC_Arbno_S, P.Index + 1, EOP, P); + begin + Set_Successor (P, S); + return S; + end Arbno_Simple; + + --------- + -- Bal -- + --------- + + function Bal return Pattern is + begin + return (AFC with 1, new PE'(PC_Bal, 1, EOP)); + end Bal; + + ------------- + -- Bracket -- + ------------- + + function Bracket (E, P, A : PE_Ptr) return PE_Ptr is + begin + if P = EOP then + E.Pthen := A; + E.Index := 2; + A.Index := 1; + + else + E.Pthen := P; + Set_Successor (P, A); + E.Index := P.Index + 2; + A.Index := P.Index + 1; + end if; + + return E; + end Bracket; + + ----------- + -- Break -- + ----------- + + function Break (Str : String) return Pattern is + begin + return (AFC with 0, new PE'(PC_Break_CS, 1, EOP, To_Set (Str))); + end Break; + + function Break (Str : VString) return Pattern is + begin + return Break (S (Str)); + end Break; + + function Break (Str : Character) return Pattern is + begin + return (AFC with 0, new PE'(PC_Break_CH, 1, EOP, Str)); + end Break; + + function Break (Str : Character_Set) return Pattern is + begin + return (AFC with 0, new PE'(PC_Break_CS, 1, EOP, Str)); + end Break; + + function Break (Str : not null access VString) return Pattern is + begin + return (AFC with 0, + new PE'(PC_Break_VP, 1, EOP, Str.all'Unchecked_Access)); + end Break; + + function Break (Str : VString_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_Break_VF, 1, EOP, Str)); + end Break; + + ------------ + -- BreakX -- + ------------ + + function BreakX (Str : String) return Pattern is + begin + return BreakX_Make (new PE'(PC_BreakX_CS, 3, N, To_Set (Str))); + end BreakX; + + function BreakX (Str : VString) return Pattern is + begin + return BreakX (S (Str)); + end BreakX; + + function BreakX (Str : Character) return Pattern is + begin + return BreakX_Make (new PE'(PC_BreakX_CH, 3, N, Str)); + end BreakX; + + function BreakX (Str : Character_Set) return Pattern is + begin + return BreakX_Make (new PE'(PC_BreakX_CS, 3, N, Str)); + end BreakX; + + function BreakX (Str : not null access VString) return Pattern is + begin + return BreakX_Make (new PE'(PC_BreakX_VP, 3, N, VString_Ptr (Str))); + end BreakX; + + function BreakX (Str : VString_Func) return Pattern is + begin + return BreakX_Make (new PE'(PC_BreakX_VF, 3, N, Str)); + end BreakX; + + ----------------- + -- BreakX_Make -- + ----------------- + + -- +---+ +---+ + -- | B |---->| A |----> + -- +---+ +---+ + -- ^ . + -- | . + -- | +---+ + -- +<------| X | + -- +---+ + + -- The B node is numbered 3, the alternative node is 1, and the X + -- node is 2. + + function BreakX_Make (B : PE_Ptr) return Pattern is + X : constant PE_Ptr := new PE'(PC_BreakX_X, 2, B); + A : constant PE_Ptr := new PE'(PC_Alt, 1, EOP, X); + begin + B.Pthen := A; + return (AFC with 2, B); + end BreakX_Make; + + --------------------- + -- Build_Ref_Array -- + --------------------- + + procedure Build_Ref_Array (E : PE_Ptr; RA : out Ref_Array) is + + procedure Record_PE (E : PE_Ptr); + -- Record given pattern element if not already recorded in RA, + -- and also record any referenced pattern elements recursively. + + --------------- + -- Record_PE -- + --------------- + + procedure Record_PE (E : PE_Ptr) is + begin + PutD (" Record_PE called with PE_Ptr = " & Image (E)); + + if E = EOP or else RA (E.Index) /= null then + Put_LineD (", nothing to do"); + return; + + else + Put_LineD (", recording" & IndexT'Image (E.Index)); + RA (E.Index) := E; + Record_PE (E.Pthen); + + if E.Pcode in PC_Has_Alt then + Record_PE (E.Alt); + end if; + end if; + end Record_PE; + + -- Start of processing for Build_Ref_Array + + begin + New_LineD; + Put_LineD ("Entering Build_Ref_Array"); + Record_PE (E); + New_LineD; + end Build_Ref_Array; + + ------------- + -- C_To_PE -- + ------------- + + function C_To_PE (C : PChar) return PE_Ptr is + begin + return new PE'(PC_Char, 1, EOP, C); + end C_To_PE; + + ------------ + -- Cancel -- + ------------ + + function Cancel return Pattern is + begin + return (AFC with 0, new PE'(PC_Cancel, 1, EOP)); + end Cancel; + + ------------ + -- Concat -- + ------------ + + -- Concat needs to traverse the left operand performing the following + -- set of fixups: + + -- a) Any successor pointers (Pthen fields) that are set to EOP are + -- reset to point to the second operand. + + -- b) Any PC_Arbno_Y node has its stack count field incremented + -- by the parameter Incr provided for this purpose. + + -- d) Num fields of all pattern elements in the left operand are + -- adjusted to include the elements of the right operand. + + -- Note: we do not use Set_Successor in the processing for Concat, since + -- there is no point in doing two traversals, we may as well do everything + -- at the same time. + + function Concat (L, R : PE_Ptr; Incr : Natural) return PE_Ptr is + begin + if L = EOP then + return R; + + elsif R = EOP then + return L; + + else + declare + Refs : Ref_Array (1 .. L.Index); + -- We build a reference array for L whose N'th element points to + -- the pattern element of L whose original Index value is N. + + P : PE_Ptr; + + begin + Build_Ref_Array (L, Refs); + + for J in Refs'Range loop + P := Refs (J); + + P.Index := P.Index + R.Index; + + if P.Pcode = PC_Arbno_Y then + P.Nat := P.Nat + Incr; + end if; + + if P.Pthen = EOP then + P.Pthen := R; + end if; + + if P.Pcode in PC_Has_Alt and then P.Alt = EOP then + P.Alt := R; + end if; + end loop; + end; + + return L; + end if; + end Concat; + + ---------- + -- Copy -- + ---------- + + function Copy (P : PE_Ptr) return PE_Ptr is + begin + if P = null then + Uninitialized_Pattern; + + else + declare + Refs : Ref_Array (1 .. P.Index); + -- References to elements in P, indexed by Index field + + Copy : Ref_Array (1 .. P.Index); + -- Holds copies of elements of P, indexed by Index field + + E : PE_Ptr; + + begin + Build_Ref_Array (P, Refs); + + -- Now copy all nodes + + for J in Refs'Range loop + Copy (J) := new PE'(Refs (J).all); + end loop; + + -- Adjust all internal references + + for J in Copy'Range loop + E := Copy (J); + + -- Adjust successor pointer to point to copy + + if E.Pthen /= EOP then + E.Pthen := Copy (E.Pthen.Index); + end if; + + -- Adjust Alt pointer if there is one to point to copy + + if E.Pcode in PC_Has_Alt and then E.Alt /= EOP then + E.Alt := Copy (E.Alt.Index); + end if; + + -- Copy referenced string + + if E.Pcode = PC_String then + E.Str := new String'(E.Str.all); + end if; + end loop; + + return Copy (P.Index); + end; + end if; + end Copy; + + ---------- + -- Dump -- + ---------- + + procedure Dump (P : Pattern) is + + subtype Count is Ada.Text_IO.Count; + Scol : Count; + -- Used to keep track of column in dump output + + Refs : Ref_Array (1 .. P.P.Index); + -- We build a reference array whose N'th element points to the + -- pattern element whose Index value is N. + + Cols : Natural := 2; + -- Number of columns used for pattern numbers, minimum is 2 + + E : PE_Ptr; + + procedure Write_Node_Id (E : PE_Ptr); + -- Writes out a string identifying the given pattern element + + ------------------- + -- Write_Node_Id -- + ------------------- + + procedure Write_Node_Id (E : PE_Ptr) is + begin + if E = EOP then + Put ("EOP"); + + for J in 4 .. Cols loop + Put (' '); + end loop; + + else + declare + Str : String (1 .. Cols); + N : Natural := Natural (E.Index); + + begin + Put ("#"); + + for J in reverse Str'Range loop + Str (J) := Character'Val (48 + N mod 10); + N := N / 10; + end loop; + + Put (Str); + end; + end if; + end Write_Node_Id; + + -- Start of processing for Dump + + begin + New_Line; + Put ("Pattern Dump Output (pattern at " & + Image (P'Address) & + ", S = " & Natural'Image (P.Stk) & ')'); + + Scol := Col; + New_Line; + + while Col < Scol loop + Put ('-'); + end loop; + + New_Line; + + -- If uninitialized pattern, dump line and we are done + + if P.P = null then + Put_Line ("Uninitialized pattern value"); + return; + end if; + + -- If null pattern, just dump it and we are all done + + if P.P = EOP then + Put_Line ("EOP (null pattern)"); + return; + end if; + + Build_Ref_Array (P.P, Refs); + + -- Set number of columns required for node numbers + + while 10 ** Cols - 1 < Integer (P.P.Index) loop + Cols := Cols + 1; + end loop; + + -- Now dump the nodes in reverse sequence. We output them in reverse + -- sequence since this corresponds to the natural order used to + -- construct the patterns. + + for J in reverse Refs'Range loop + E := Refs (J); + Write_Node_Id (E); + Set_Col (Count (Cols) + 4); + Put (Image (E)); + Put (" "); + Put (Pattern_Code'Image (E.Pcode)); + Put (" "); + Set_Col (21 + Count (Cols) + Address_Image_Length); + Write_Node_Id (E.Pthen); + Set_Col (24 + 2 * Count (Cols) + Address_Image_Length); + + case E.Pcode is + + when PC_Alt | + PC_Arb_X | + PC_Arbno_S | + PC_Arbno_X => + Write_Node_Id (E.Alt); + + when PC_Rpat => + Put (Str_PP (E.PP)); + + when PC_Pred_Func => + Put (Str_BF (E.BF)); + + when PC_Assign_Imm | + PC_Assign_OnM | + PC_Any_VP | + PC_Break_VP | + PC_BreakX_VP | + PC_NotAny_VP | + PC_NSpan_VP | + PC_Span_VP | + PC_String_VP => + Put (Str_VP (E.VP)); + + when PC_Write_Imm | + PC_Write_OnM => + Put (Str_FP (E.FP)); + + when PC_String => + Put (Image (E.Str.all)); + + when PC_String_2 => + Put (Image (E.Str2)); + + when PC_String_3 => + Put (Image (E.Str3)); + + when PC_String_4 => + Put (Image (E.Str4)); + + when PC_String_5 => + Put (Image (E.Str5)); + + when PC_String_6 => + Put (Image (E.Str6)); + + when PC_Setcur => + Put (Str_NP (E.Var)); + + when PC_Any_CH | + PC_Break_CH | + PC_BreakX_CH | + PC_Char | + PC_NotAny_CH | + PC_NSpan_CH | + PC_Span_CH => + Put (''' & E.Char & '''); + + when PC_Any_CS | + PC_Break_CS | + PC_BreakX_CS | + PC_NotAny_CS | + PC_NSpan_CS | + PC_Span_CS => + Put ('"' & To_Sequence (E.CS) & '"'); + + when PC_Arbno_Y | + PC_Len_Nat | + PC_Pos_Nat | + PC_RPos_Nat | + PC_RTab_Nat | + PC_Tab_Nat => + Put (S (E.Nat)); + + when PC_Pos_NF | + PC_Len_NF | + PC_RPos_NF | + PC_RTab_NF | + PC_Tab_NF => + Put (Str_NF (E.NF)); + + when PC_Pos_NP | + PC_Len_NP | + PC_RPos_NP | + PC_RTab_NP | + PC_Tab_NP => + Put (Str_NP (E.NP)); + + when PC_Any_VF | + PC_Break_VF | + PC_BreakX_VF | + PC_NotAny_VF | + PC_NSpan_VF | + PC_Span_VF | + PC_String_VF => + Put (Str_VF (E.VF)); + + when others => null; + + end case; + + New_Line; + end loop; + + New_Line; + end Dump; + + ---------- + -- Fail -- + ---------- + + function Fail return Pattern is + begin + return (AFC with 0, new PE'(PC_Fail, 1, EOP)); + end Fail; + + ----------- + -- Fence -- + ----------- + + -- Simple case + + function Fence return Pattern is + begin + return (AFC with 1, new PE'(PC_Fence, 1, EOP)); + end Fence; + + -- Function case + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| X |----> + -- +---+ +---+ +---+ + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the X node is numbered N + 1, + -- and the E node is N + 2. + + function Fence (P : Pattern) return Pattern is + Pat : constant PE_Ptr := Copy (P.P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + X : constant PE_Ptr := new PE'(PC_Fence_X, 0, EOP); + begin + return (AFC with P.Stk + 1, Bracket (E, Pat, X)); + end Fence; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Pattern) is + + procedure Free is new Ada.Unchecked_Deallocation (PE, PE_Ptr); + procedure Free is new Ada.Unchecked_Deallocation (String, String_Ptr); + + begin + -- Nothing to do if already freed + + if Object.P = null then + return; + + -- Otherwise we must free all elements + + else + declare + Refs : Ref_Array (1 .. Object.P.Index); + -- References to elements in pattern to be finalized + + begin + Build_Ref_Array (Object.P, Refs); + + for J in Refs'Range loop + if Refs (J).Pcode = PC_String then + Free (Refs (J).Str); + end if; + + Free (Refs (J)); + end loop; + + Object.P := null; + end; + end if; + end Finalize; + + ----------- + -- Image -- + ----------- + + function Image (P : PE_Ptr) return String is + begin + return Image (To_Address (P)); + end Image; + + function Image (P : Pattern) return String is + begin + return S (Image (P)); + end Image; + + function Image (P : Pattern) return VString is + + Kill_Ampersand : Boolean := False; + -- Set True to delete next & to be output to Result + + Result : VString := Nul; + -- The result is accumulated here, using Append + + Refs : Ref_Array (1 .. P.P.Index); + -- We build a reference array whose N'th element points to the + -- pattern element whose Index value is N. + + procedure Delete_Ampersand; + -- Deletes the ampersand at the end of Result + + procedure Image_Seq (E : PE_Ptr; Succ : PE_Ptr; Paren : Boolean); + -- E refers to a pattern structure whose successor is given by Succ. + -- This procedure appends to Result a representation of this pattern. + -- The Paren parameter indicates whether parentheses are required if + -- the output is more than one element. + + procedure Image_One (E : in out PE_Ptr); + -- E refers to a pattern structure. This procedure appends to Result + -- a representation of the single simple or compound pattern structure + -- at the start of E and updates E to point to its successor. + + ---------------------- + -- Delete_Ampersand -- + ---------------------- + + procedure Delete_Ampersand is + L : constant Natural := Length (Result); + begin + if L > 2 then + Delete (Result, L - 1, L); + end if; + end Delete_Ampersand; + + --------------- + -- Image_One -- + --------------- + + procedure Image_One (E : in out PE_Ptr) is + + ER : PE_Ptr := E.Pthen; + -- Successor set as result in E unless reset + + begin + case E.Pcode is + + when PC_Cancel => + Append (Result, "Cancel"); + + when PC_Alt => Alt : declare + + Elmts_In_L : constant IndexT := E.Pthen.Index - E.Alt.Index; + -- Number of elements in left pattern of alternation + + Lowest_In_L : constant IndexT := E.Index - Elmts_In_L; + -- Number of lowest index in elements of left pattern + + E1 : PE_Ptr; + + begin + -- The successor of the alternation node must have a lower + -- index than any node that is in the left pattern or a + -- higher index than the alternation node itself. + + while ER /= EOP + and then ER.Index >= Lowest_In_L + and then ER.Index < E.Index + loop + ER := ER.Pthen; + end loop; + + Append (Result, '('); + + E1 := E; + loop + Image_Seq (E1.Pthen, ER, False); + Append (Result, " or "); + E1 := E1.Alt; + exit when E1.Pcode /= PC_Alt; + end loop; + + Image_Seq (E1, ER, False); + Append (Result, ')'); + end Alt; + + when PC_Any_CS => + Append (Result, "Any (" & Image (To_Sequence (E.CS)) & ')'); + + when PC_Any_VF => + Append (Result, "Any (" & Str_VF (E.VF) & ')'); + + when PC_Any_VP => + Append (Result, "Any (" & Str_VP (E.VP) & ')'); + + when PC_Arb_X => + Append (Result, "Arb"); + + when PC_Arbno_S => + Append (Result, "Arbno ("); + Image_Seq (E.Alt, E, False); + Append (Result, ')'); + + when PC_Arbno_X => + Append (Result, "Arbno ("); + Image_Seq (E.Alt.Pthen, Refs (E.Index - 2), False); + Append (Result, ')'); + + when PC_Assign_Imm => + Delete_Ampersand; + Append (Result, "* " & Str_VP (Refs (E.Index).VP)); + + when PC_Assign_OnM => + Delete_Ampersand; + Append (Result, "** " & Str_VP (Refs (E.Index).VP)); + + when PC_Any_CH => + Append (Result, "Any ('" & E.Char & "')"); + + when PC_Bal => + Append (Result, "Bal"); + + when PC_Break_CH => + Append (Result, "Break ('" & E.Char & "')"); + + when PC_Break_CS => + Append (Result, "Break (" & Image (To_Sequence (E.CS)) & ')'); + + when PC_Break_VF => + Append (Result, "Break (" & Str_VF (E.VF) & ')'); + + when PC_Break_VP => + Append (Result, "Break (" & Str_VP (E.VP) & ')'); + + when PC_BreakX_CH => + Append (Result, "BreakX ('" & E.Char & "')"); + ER := ER.Pthen; + + when PC_BreakX_CS => + Append (Result, "BreakX (" & Image (To_Sequence (E.CS)) & ')'); + ER := ER.Pthen; + + when PC_BreakX_VF => + Append (Result, "BreakX (" & Str_VF (E.VF) & ')'); + ER := ER.Pthen; + + when PC_BreakX_VP => + Append (Result, "BreakX (" & Str_VP (E.VP) & ')'); + ER := ER.Pthen; + + when PC_Char => + Append (Result, ''' & E.Char & '''); + + when PC_Fail => + Append (Result, "Fail"); + + when PC_Fence => + Append (Result, "Fence"); + + when PC_Fence_X => + Append (Result, "Fence ("); + Image_Seq (E.Pthen, Refs (E.Index - 1), False); + Append (Result, ")"); + ER := Refs (E.Index - 1).Pthen; + + when PC_Len_Nat => + Append (Result, "Len (" & E.Nat & ')'); + + when PC_Len_NF => + Append (Result, "Len (" & Str_NF (E.NF) & ')'); + + when PC_Len_NP => + Append (Result, "Len (" & Str_NP (E.NP) & ')'); + + when PC_NotAny_CH => + Append (Result, "NotAny ('" & E.Char & "')"); + + when PC_NotAny_CS => + Append (Result, "NotAny (" & Image (To_Sequence (E.CS)) & ')'); + + when PC_NotAny_VF => + Append (Result, "NotAny (" & Str_VF (E.VF) & ')'); + + when PC_NotAny_VP => + Append (Result, "NotAny (" & Str_VP (E.VP) & ')'); + + when PC_NSpan_CH => + Append (Result, "NSpan ('" & E.Char & "')"); + + when PC_NSpan_CS => + Append (Result, "NSpan (" & Image (To_Sequence (E.CS)) & ')'); + + when PC_NSpan_VF => + Append (Result, "NSpan (" & Str_VF (E.VF) & ')'); + + when PC_NSpan_VP => + Append (Result, "NSpan (" & Str_VP (E.VP) & ')'); + + when PC_Null => + Append (Result, """"""); + + when PC_Pos_Nat => + Append (Result, "Pos (" & E.Nat & ')'); + + when PC_Pos_NF => + Append (Result, "Pos (" & Str_NF (E.NF) & ')'); + + when PC_Pos_NP => + Append (Result, "Pos (" & Str_NP (E.NP) & ')'); + + when PC_R_Enter => + Kill_Ampersand := True; + + when PC_Rest => + Append (Result, "Rest"); + + when PC_Rpat => + Append (Result, "(+ " & Str_PP (E.PP) & ')'); + + when PC_Pred_Func => + Append (Result, "(+ " & Str_BF (E.BF) & ')'); + + when PC_RPos_Nat => + Append (Result, "RPos (" & E.Nat & ')'); + + when PC_RPos_NF => + Append (Result, "RPos (" & Str_NF (E.NF) & ')'); + + when PC_RPos_NP => + Append (Result, "RPos (" & Str_NP (E.NP) & ')'); + + when PC_RTab_Nat => + Append (Result, "RTab (" & E.Nat & ')'); + + when PC_RTab_NF => + Append (Result, "RTab (" & Str_NF (E.NF) & ')'); + + when PC_RTab_NP => + Append (Result, "RTab (" & Str_NP (E.NP) & ')'); + + when PC_Setcur => + Append (Result, "Setcur (" & Str_NP (E.Var) & ')'); + + when PC_Span_CH => + Append (Result, "Span ('" & E.Char & "')"); + + when PC_Span_CS => + Append (Result, "Span (" & Image (To_Sequence (E.CS)) & ')'); + + when PC_Span_VF => + Append (Result, "Span (" & Str_VF (E.VF) & ')'); + + when PC_Span_VP => + Append (Result, "Span (" & Str_VP (E.VP) & ')'); + + when PC_String => + Append (Result, Image (E.Str.all)); + + when PC_String_2 => + Append (Result, Image (E.Str2)); + + when PC_String_3 => + Append (Result, Image (E.Str3)); + + when PC_String_4 => + Append (Result, Image (E.Str4)); + + when PC_String_5 => + Append (Result, Image (E.Str5)); + + when PC_String_6 => + Append (Result, Image (E.Str6)); + + when PC_String_VF => + Append (Result, "(+" & Str_VF (E.VF) & ')'); + + when PC_String_VP => + Append (Result, "(+" & Str_VP (E.VP) & ')'); + + when PC_Succeed => + Append (Result, "Succeed"); + + when PC_Tab_Nat => + Append (Result, "Tab (" & E.Nat & ')'); + + when PC_Tab_NF => + Append (Result, "Tab (" & Str_NF (E.NF) & ')'); + + when PC_Tab_NP => + Append (Result, "Tab (" & Str_NP (E.NP) & ')'); + + when PC_Write_Imm => + Append (Result, '('); + Image_Seq (E, Refs (E.Index - 1), True); + Append (Result, " * " & Str_FP (Refs (E.Index - 1).FP)); + ER := Refs (E.Index - 1).Pthen; + + when PC_Write_OnM => + Append (Result, '('); + Image_Seq (E.Pthen, Refs (E.Index - 1), True); + Append (Result, " ** " & Str_FP (Refs (E.Index - 1).FP)); + ER := Refs (E.Index - 1).Pthen; + + -- Other pattern codes should not appear as leading elements + + when PC_Arb_Y | + PC_Arbno_Y | + PC_Assign | + PC_BreakX_X | + PC_EOP | + PC_Fence_Y | + PC_R_Remove | + PC_R_Restore | + PC_Unanchored => + Append (Result, "???"); + + end case; + + E := ER; + end Image_One; + + --------------- + -- Image_Seq -- + --------------- + + procedure Image_Seq (E : PE_Ptr; Succ : PE_Ptr; Paren : Boolean) is + Indx : constant Natural := Length (Result); + E1 : PE_Ptr := E; + Mult : Boolean := False; + + begin + -- The image of EOP is "" (the null string) + + if E = EOP then + Append (Result, """"""); + + -- Else generate appropriate concatenation sequence + + else + loop + Image_One (E1); + exit when E1 = Succ; + exit when E1 = EOP; + Mult := True; + + if Kill_Ampersand then + Kill_Ampersand := False; + else + Append (Result, " & "); + end if; + end loop; + end if; + + if Mult and Paren then + Insert (Result, Indx + 1, "("); + Append (Result, ")"); + end if; + end Image_Seq; + + -- Start of processing for Image + + begin + Build_Ref_Array (P.P, Refs); + Image_Seq (P.P, EOP, False); + return Result; + end Image; + + ----------- + -- Is_In -- + ----------- + + function Is_In (C : Character; Str : String) return Boolean is + begin + for J in Str'Range loop + if Str (J) = C then + return True; + end if; + end loop; + + return False; + end Is_In; + + --------- + -- Len -- + --------- + + function Len (Count : Natural) return Pattern is + begin + -- Note, the following is not just an optimization, it is needed + -- to ensure that Arbno (Len (0)) does not generate an infinite + -- matching loop (since PC_Len_Nat is OK_For_Simple_Arbno). + + if Count = 0 then + return (AFC with 0, new PE'(PC_Null, 1, EOP)); + + else + return (AFC with 0, new PE'(PC_Len_Nat, 1, EOP, Count)); + end if; + end Len; + + function Len (Count : Natural_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_Len_NF, 1, EOP, Count)); + end Len; + + function Len (Count : not null access Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_Len_NP, 1, EOP, Natural_Ptr (Count))); + end Len; + + ----------------- + -- Logic_Error -- + ----------------- + + procedure Logic_Error is + begin + raise Program_Error with + "Internal logic error in GNAT.Spitbol.Patterns"; + end Logic_Error; + + ----------- + -- Match -- + ----------- + + function Match + (Subject : VString; + Pat : Pattern) return Boolean + is + S : Big_String_Access; + L : Natural; + Start : Natural; + Stop : Natural; + pragma Unreferenced (Stop); + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + else + XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + end if; + + return Start /= 0; + end Match; + + function Match + (Subject : String; + Pat : Pattern) return Boolean + is + Start, Stop : Natural; + pragma Unreferenced (Stop); + + subtype String1 is String (1 .. Subject'Length); + + begin + if Debug_Mode then + XMatchD (String1 (Subject), Pat.P, Pat.Stk, Start, Stop); + else + XMatch (String1 (Subject), Pat.P, Pat.Stk, Start, Stop); + end if; + + return Start /= 0; + end Match; + + function Match + (Subject : VString_Var; + Pat : Pattern; + Replace : VString) return Boolean + is + Start : Natural; + Stop : Natural; + S : Big_String_Access; + L : Natural; + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + else + XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + end if; + + if Start = 0 then + return False; + else + Get_String (Replace, S, L); + Replace_Slice + (Subject'Unrestricted_Access.all, Start, Stop, S (1 .. L)); + return True; + end if; + end Match; + + function Match + (Subject : VString_Var; + Pat : Pattern; + Replace : String) return Boolean + is + Start : Natural; + Stop : Natural; + S : Big_String_Access; + L : Natural; + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + else + XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + end if; + + if Start = 0 then + return False; + else + Replace_Slice + (Subject'Unrestricted_Access.all, Start, Stop, Replace); + return True; + end if; + end Match; + + procedure Match + (Subject : VString; + Pat : Pattern) + is + S : Big_String_Access; + L : Natural; + + Start : Natural; + Stop : Natural; + pragma Unreferenced (Start, Stop); + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + else + XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + end if; + end Match; + + procedure Match + (Subject : String; + Pat : Pattern) + is + Start, Stop : Natural; + pragma Unreferenced (Start, Stop); + + subtype String1 is String (1 .. Subject'Length); + + begin + if Debug_Mode then + XMatchD (String1 (Subject), Pat.P, Pat.Stk, Start, Stop); + else + XMatch (String1 (Subject), Pat.P, Pat.Stk, Start, Stop); + end if; + end Match; + + procedure Match + (Subject : in out VString; + Pat : Pattern; + Replace : VString) + is + Start : Natural; + Stop : Natural; + S : Big_String_Access; + L : Natural; + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + else + XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + end if; + + if Start /= 0 then + Get_String (Replace, S, L); + Replace_Slice (Subject, Start, Stop, S (1 .. L)); + end if; + end Match; + + procedure Match + (Subject : in out VString; + Pat : Pattern; + Replace : String) + is + Start : Natural; + Stop : Natural; + S : Big_String_Access; + L : Natural; + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + else + XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + end if; + + if Start /= 0 then + Replace_Slice (Subject, Start, Stop, Replace); + end if; + end Match; + + function Match + (Subject : VString; + Pat : PString) return Boolean + is + Pat_Len : constant Natural := Pat'Length; + S : Big_String_Access; + L : Natural; + + begin + Get_String (Subject, S, L); + + if Anchored_Mode then + if Pat_Len > L then + return False; + else + return Pat = S (1 .. Pat_Len); + end if; + + else + for J in 1 .. L - Pat_Len + 1 loop + if Pat = S (J .. J + (Pat_Len - 1)) then + return True; + end if; + end loop; + + return False; + end if; + end Match; + + function Match + (Subject : String; + Pat : PString) return Boolean + is + Pat_Len : constant Natural := Pat'Length; + Sub_Len : constant Natural := Subject'Length; + SFirst : constant Natural := Subject'First; + + begin + if Anchored_Mode then + if Pat_Len > Sub_Len then + return False; + else + return Pat = Subject (SFirst .. SFirst + Pat_Len - 1); + end if; + + else + for J in SFirst .. SFirst + Sub_Len - Pat_Len loop + if Pat = Subject (J .. J + (Pat_Len - 1)) then + return True; + end if; + end loop; + + return False; + end if; + end Match; + + function Match + (Subject : VString_Var; + Pat : PString; + Replace : VString) return Boolean + is + Start : Natural; + Stop : Natural; + S : Big_String_Access; + L : Natural; + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); + else + XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); + end if; + + if Start = 0 then + return False; + else + Get_String (Replace, S, L); + Replace_Slice + (Subject'Unrestricted_Access.all, Start, Stop, S (1 .. L)); + return True; + end if; + end Match; + + function Match + (Subject : VString_Var; + Pat : PString; + Replace : String) return Boolean + is + Start : Natural; + Stop : Natural; + S : Big_String_Access; + L : Natural; + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); + else + XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); + end if; + + if Start = 0 then + return False; + else + Replace_Slice + (Subject'Unrestricted_Access.all, Start, Stop, Replace); + return True; + end if; + end Match; + + procedure Match + (Subject : VString; + Pat : PString) + is + S : Big_String_Access; + L : Natural; + + Start : Natural; + Stop : Natural; + pragma Unreferenced (Start, Stop); + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); + else + XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); + end if; + end Match; + + procedure Match + (Subject : String; + Pat : PString) + is + Start, Stop : Natural; + pragma Unreferenced (Start, Stop); + + subtype String1 is String (1 .. Subject'Length); + + begin + if Debug_Mode then + XMatchD (String1 (Subject), S_To_PE (Pat), 0, Start, Stop); + else + XMatch (String1 (Subject), S_To_PE (Pat), 0, Start, Stop); + end if; + end Match; + + procedure Match + (Subject : in out VString; + Pat : PString; + Replace : VString) + is + Start : Natural; + Stop : Natural; + S : Big_String_Access; + L : Natural; + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); + else + XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); + end if; + + if Start /= 0 then + Get_String (Replace, S, L); + Replace_Slice (Subject, Start, Stop, S (1 .. L)); + end if; + end Match; + + procedure Match + (Subject : in out VString; + Pat : PString; + Replace : String) + is + Start : Natural; + Stop : Natural; + S : Big_String_Access; + L : Natural; + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); + else + XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); + end if; + + if Start /= 0 then + Replace_Slice (Subject, Start, Stop, Replace); + end if; + end Match; + + function Match + (Subject : VString_Var; + Pat : Pattern; + Result : Match_Result_Var) return Boolean + is + Start : Natural; + Stop : Natural; + S : Big_String_Access; + L : Natural; + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + else + XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + end if; + + if Start = 0 then + Result'Unrestricted_Access.all.Var := null; + return False; + + else + Result'Unrestricted_Access.all.Var := Subject'Unrestricted_Access; + Result'Unrestricted_Access.all.Start := Start; + Result'Unrestricted_Access.all.Stop := Stop; + return True; + end if; + end Match; + + procedure Match + (Subject : in out VString; + Pat : Pattern; + Result : out Match_Result) + is + Start : Natural; + Stop : Natural; + S : Big_String_Access; + L : Natural; + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + else + XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + end if; + + if Start = 0 then + Result.Var := null; + else + Result.Var := Subject'Unrestricted_Access; + Result.Start := Start; + Result.Stop := Stop; + end if; + end Match; + + --------------- + -- New_LineD -- + --------------- + + procedure New_LineD is + begin + if Internal_Debug then + New_Line; + end if; + end New_LineD; + + ------------ + -- NotAny -- + ------------ + + function NotAny (Str : String) return Pattern is + begin + return (AFC with 0, new PE'(PC_NotAny_CS, 1, EOP, To_Set (Str))); + end NotAny; + + function NotAny (Str : VString) return Pattern is + begin + return NotAny (S (Str)); + end NotAny; + + function NotAny (Str : Character) return Pattern is + begin + return (AFC with 0, new PE'(PC_NotAny_CH, 1, EOP, Str)); + end NotAny; + + function NotAny (Str : Character_Set) return Pattern is + begin + return (AFC with 0, new PE'(PC_NotAny_CS, 1, EOP, Str)); + end NotAny; + + function NotAny (Str : not null access VString) return Pattern is + begin + return (AFC with 0, new PE'(PC_NotAny_VP, 1, EOP, VString_Ptr (Str))); + end NotAny; + + function NotAny (Str : VString_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_NotAny_VF, 1, EOP, Str)); + end NotAny; + + ----------- + -- NSpan -- + ----------- + + function NSpan (Str : String) return Pattern is + begin + return (AFC with 0, new PE'(PC_NSpan_CS, 1, EOP, To_Set (Str))); + end NSpan; + + function NSpan (Str : VString) return Pattern is + begin + return NSpan (S (Str)); + end NSpan; + + function NSpan (Str : Character) return Pattern is + begin + return (AFC with 0, new PE'(PC_NSpan_CH, 1, EOP, Str)); + end NSpan; + + function NSpan (Str : Character_Set) return Pattern is + begin + return (AFC with 0, new PE'(PC_NSpan_CS, 1, EOP, Str)); + end NSpan; + + function NSpan (Str : not null access VString) return Pattern is + begin + return (AFC with 0, new PE'(PC_NSpan_VP, 1, EOP, VString_Ptr (Str))); + end NSpan; + + function NSpan (Str : VString_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_NSpan_VF, 1, EOP, Str)); + end NSpan; + + --------- + -- Pos -- + --------- + + function Pos (Count : Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_Pos_Nat, 1, EOP, Count)); + end Pos; + + function Pos (Count : Natural_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_Pos_NF, 1, EOP, Count)); + end Pos; + + function Pos (Count : not null access Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_Pos_NP, 1, EOP, Natural_Ptr (Count))); + end Pos; + + ---------- + -- PutD -- + ---------- + + procedure PutD (Str : String) is + begin + if Internal_Debug then + Put (Str); + end if; + end PutD; + + --------------- + -- Put_LineD -- + --------------- + + procedure Put_LineD (Str : String) is + begin + if Internal_Debug then + Put_Line (Str); + end if; + end Put_LineD; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Result : in out Match_Result; + Replace : VString) + is + S : Big_String_Access; + L : Natural; + + begin + Get_String (Replace, S, L); + + if Result.Var /= null then + Replace_Slice (Result.Var.all, Result.Start, Result.Stop, S (1 .. L)); + Result.Var := null; + end if; + end Replace; + + ---------- + -- Rest -- + ---------- + + function Rest return Pattern is + begin + return (AFC with 0, new PE'(PC_Rest, 1, EOP)); + end Rest; + + ---------- + -- Rpos -- + ---------- + + function Rpos (Count : Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_RPos_Nat, 1, EOP, Count)); + end Rpos; + + function Rpos (Count : Natural_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_RPos_NF, 1, EOP, Count)); + end Rpos; + + function Rpos (Count : not null access Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_RPos_NP, 1, EOP, Natural_Ptr (Count))); + end Rpos; + + ---------- + -- Rtab -- + ---------- + + function Rtab (Count : Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_RTab_Nat, 1, EOP, Count)); + end Rtab; + + function Rtab (Count : Natural_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_RTab_NF, 1, EOP, Count)); + end Rtab; + + function Rtab (Count : not null access Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_RTab_NP, 1, EOP, Natural_Ptr (Count))); + end Rtab; + + ------------- + -- S_To_PE -- + ------------- + + function S_To_PE (Str : PString) return PE_Ptr is + Len : constant Natural := Str'Length; + + begin + case Len is + when 0 => + return new PE'(PC_Null, 1, EOP); + + when 1 => + return new PE'(PC_Char, 1, EOP, Str (Str'First)); + + when 2 => + return new PE'(PC_String_2, 1, EOP, Str); + + when 3 => + return new PE'(PC_String_3, 1, EOP, Str); + + when 4 => + return new PE'(PC_String_4, 1, EOP, Str); + + when 5 => + return new PE'(PC_String_5, 1, EOP, Str); + + when 6 => + return new PE'(PC_String_6, 1, EOP, Str); + + when others => + return new PE'(PC_String, 1, EOP, new String'(Str)); + + end case; + end S_To_PE; + + ------------------- + -- Set_Successor -- + ------------------- + + -- Note: this procedure is not used by the normal concatenation circuit, + -- since other fixups are required on the left operand in this case, and + -- they might as well be done all together. + + procedure Set_Successor (Pat : PE_Ptr; Succ : PE_Ptr) is + begin + if Pat = null then + Uninitialized_Pattern; + + elsif Pat = EOP then + Logic_Error; + + else + declare + Refs : Ref_Array (1 .. Pat.Index); + -- We build a reference array for L whose N'th element points to + -- the pattern element of L whose original Index value is N. + + P : PE_Ptr; + + begin + Build_Ref_Array (Pat, Refs); + + for J in Refs'Range loop + P := Refs (J); + + if P.Pthen = EOP then + P.Pthen := Succ; + end if; + + if P.Pcode in PC_Has_Alt and then P.Alt = EOP then + P.Alt := Succ; + end if; + end loop; + end; + end if; + end Set_Successor; + + ------------ + -- Setcur -- + ------------ + + function Setcur (Var : not null access Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_Setcur, 1, EOP, Natural_Ptr (Var))); + end Setcur; + + ---------- + -- Span -- + ---------- + + function Span (Str : String) return Pattern is + begin + return (AFC with 0, new PE'(PC_Span_CS, 1, EOP, To_Set (Str))); + end Span; + + function Span (Str : VString) return Pattern is + begin + return Span (S (Str)); + end Span; + + function Span (Str : Character) return Pattern is + begin + return (AFC with 0, new PE'(PC_Span_CH, 1, EOP, Str)); + end Span; + + function Span (Str : Character_Set) return Pattern is + begin + return (AFC with 0, new PE'(PC_Span_CS, 1, EOP, Str)); + end Span; + + function Span (Str : not null access VString) return Pattern is + begin + return (AFC with 0, new PE'(PC_Span_VP, 1, EOP, VString_Ptr (Str))); + end Span; + + function Span (Str : VString_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_Span_VF, 1, EOP, Str)); + end Span; + + ------------ + -- Str_BF -- + ------------ + + function Str_BF (A : Boolean_Func) return String is + function To_A is new Ada.Unchecked_Conversion (Boolean_Func, Address); + begin + return "BF(" & Image (To_A (A)) & ')'; + end Str_BF; + + ------------ + -- Str_FP -- + ------------ + + function Str_FP (A : File_Ptr) return String is + begin + return "FP(" & Image (A.all'Address) & ')'; + end Str_FP; + + ------------ + -- Str_NF -- + ------------ + + function Str_NF (A : Natural_Func) return String is + function To_A is new Ada.Unchecked_Conversion (Natural_Func, Address); + begin + return "NF(" & Image (To_A (A)) & ')'; + end Str_NF; + + ------------ + -- Str_NP -- + ------------ + + function Str_NP (A : Natural_Ptr) return String is + begin + return "NP(" & Image (A.all'Address) & ')'; + end Str_NP; + + ------------ + -- Str_PP -- + ------------ + + function Str_PP (A : Pattern_Ptr) return String is + begin + return "PP(" & Image (A.all'Address) & ')'; + end Str_PP; + + ------------ + -- Str_VF -- + ------------ + + function Str_VF (A : VString_Func) return String is + function To_A is new Ada.Unchecked_Conversion (VString_Func, Address); + begin + return "VF(" & Image (To_A (A)) & ')'; + end Str_VF; + + ------------ + -- Str_VP -- + ------------ + + function Str_VP (A : VString_Ptr) return String is + begin + return "VP(" & Image (A.all'Address) & ')'; + end Str_VP; + + ------------- + -- Succeed -- + ------------- + + function Succeed return Pattern is + begin + return (AFC with 1, new PE'(PC_Succeed, 1, EOP)); + end Succeed; + + --------- + -- Tab -- + --------- + + function Tab (Count : Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_Tab_Nat, 1, EOP, Count)); + end Tab; + + function Tab (Count : Natural_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_Tab_NF, 1, EOP, Count)); + end Tab; + + function Tab (Count : not null access Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_Tab_NP, 1, EOP, Natural_Ptr (Count))); + end Tab; + + --------------------------- + -- Uninitialized_Pattern -- + --------------------------- + + procedure Uninitialized_Pattern is + begin + raise Program_Error with + "uninitialized value of type GNAT.Spitbol.Patterns.Pattern"; + end Uninitialized_Pattern; + + ------------ + -- XMatch -- + ------------ + + procedure XMatch + (Subject : String; + Pat_P : PE_Ptr; + Pat_S : Natural; + Start : out Natural; + Stop : out Natural) + is + Node : PE_Ptr; + -- Pointer to current pattern node. Initialized from Pat_P, and then + -- updated as the match proceeds through its constituent elements. + + Length : constant Natural := Subject'Length; + -- Length of string (= Subject'Last, since Subject'First is always 1) + + Cursor : Integer := 0; + -- If the value is non-negative, then this value is the index showing + -- the current position of the match in the subject string. The next + -- character to be matched is at Subject (Cursor + 1). Note that since + -- our view of the subject string in XMatch always has a lower bound + -- of one, regardless of original bounds, that this definition exactly + -- corresponds to the cursor value as referenced by functions like Pos. + -- + -- If the value is negative, then this is a saved stack pointer, + -- typically a base pointer of an inner or outer region. Cursor + -- temporarily holds such a value when it is popped from the stack + -- by Fail. In all cases, Cursor is reset to a proper non-negative + -- cursor value before the match proceeds (e.g. by propagating the + -- failure and popping a "real" cursor value from the stack. + + PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P); + -- Dummy pattern element used in the unanchored case + + Stack : Stack_Type; + -- The pattern matching failure stack for this call to Match + + Stack_Ptr : Stack_Range; + -- Current stack pointer. This points to the top element of the stack + -- that is currently in use. At the outer level this is the special + -- entry placed on the stack according to the anchor mode. + + Stack_Init : constant Stack_Range := Stack'First + 1; + -- This is the initial value of the Stack_Ptr and Stack_Base. The + -- initial (Stack'First) element of the stack is not used so that + -- when we pop the last element off, Stack_Ptr is still in range. + + Stack_Base : Stack_Range; + -- This value is the stack base value, i.e. the stack pointer for the + -- first history stack entry in the current stack region. See separate + -- section on handling of recursive pattern matches. + + Assign_OnM : Boolean := False; + -- Set True if assign-on-match or write-on-match operations may be + -- present in the history stack, which must then be scanned on a + -- successful match. + + procedure Pop_Region; + pragma Inline (Pop_Region); + -- Used at the end of processing of an inner region. If the inner + -- region left no stack entries, then all trace of it is removed. + -- Otherwise a PC_Restore_Region entry is pushed to ensure proper + -- handling of alternatives in the inner region. + + procedure Push (Node : PE_Ptr); + pragma Inline (Push); + -- Make entry in pattern matching stack with current cursor value + + procedure Push_Region; + pragma Inline (Push_Region); + -- This procedure makes a new region on the history stack. The + -- caller first establishes the special entry on the stack, but + -- does not push the stack pointer. Then this call stacks a + -- PC_Remove_Region node, on top of this entry, using the cursor + -- field of the PC_Remove_Region entry to save the outer level + -- stack base value, and resets the stack base to point to this + -- PC_Remove_Region node. + + ---------------- + -- Pop_Region -- + ---------------- + + procedure Pop_Region is + begin + -- If nothing was pushed in the inner region, we can just get + -- rid of it entirely, leaving no traces that it was ever there + + if Stack_Ptr = Stack_Base then + Stack_Ptr := Stack_Base - 2; + Stack_Base := Stack (Stack_Ptr + 2).Cursor; + + -- If stuff was pushed in the inner region, then we have to + -- push a PC_R_Restore node so that we properly handle possible + -- rematches within the region. + + else + Stack_Ptr := Stack_Ptr + 1; + Stack (Stack_Ptr).Cursor := Stack_Base; + Stack (Stack_Ptr).Node := CP_R_Restore'Access; + Stack_Base := Stack (Stack_Base).Cursor; + end if; + end Pop_Region; + + ---------- + -- Push -- + ---------- + + procedure Push (Node : PE_Ptr) is + begin + Stack_Ptr := Stack_Ptr + 1; + Stack (Stack_Ptr).Cursor := Cursor; + Stack (Stack_Ptr).Node := Node; + end Push; + + ----------------- + -- Push_Region -- + ----------------- + + procedure Push_Region is + begin + Stack_Ptr := Stack_Ptr + 2; + Stack (Stack_Ptr).Cursor := Stack_Base; + Stack (Stack_Ptr).Node := CP_R_Remove'Access; + Stack_Base := Stack_Ptr; + end Push_Region; + + -- Start of processing for XMatch + + begin + if Pat_P = null then + Uninitialized_Pattern; + end if; + + -- Check we have enough stack for this pattern. This check deals with + -- every possibility except a match of a recursive pattern, where we + -- make a check at each recursion level. + + if Pat_S >= Stack_Size - 1 then + raise Pattern_Stack_Overflow; + end if; + + -- In anchored mode, the bottom entry on the stack is an abort entry + + if Anchored_Mode then + Stack (Stack_Init).Node := CP_Cancel'Access; + Stack (Stack_Init).Cursor := 0; + + -- In unanchored more, the bottom entry on the stack references + -- the special pattern element PE_Unanchored, whose Pthen field + -- points to the initial pattern element. The cursor value in this + -- entry is the number of anchor moves so far. + + else + Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access; + Stack (Stack_Init).Cursor := 0; + end if; + + Stack_Ptr := Stack_Init; + Stack_Base := Stack_Ptr; + Cursor := 0; + Node := Pat_P; + goto Match; + + ----------------------------------------- + -- Main Pattern Matching State Control -- + ----------------------------------------- + + -- This is a state machine which uses gotos to change state. The + -- initial state is Match, to initiate the matching of the first + -- element, so the goto Match above starts the match. In the + -- following descriptions, we indicate the global values that + -- are relevant for the state transition. + + -- Come here if entire match fails + + <> + Start := 0; + Stop := 0; + return; + + -- Come here if entire match succeeds + + -- Cursor current position in subject string + + <> + Start := Stack (Stack_Init).Cursor + 1; + Stop := Cursor; + + -- Scan history stack for deferred assignments or writes + + if Assign_OnM then + for S in Stack_Init .. Stack_Ptr loop + if Stack (S).Node = CP_Assign'Access then + declare + Inner_Base : constant Stack_Range := + Stack (S + 1).Cursor; + Special_Entry : constant Stack_Range := + Inner_Base - 1; + Node_OnM : constant PE_Ptr := + Stack (Special_Entry).Node; + Start : constant Natural := + Stack (Special_Entry).Cursor + 1; + Stop : constant Natural := Stack (S).Cursor; + + begin + if Node_OnM.Pcode = PC_Assign_OnM then + Set_String (Node_OnM.VP.all, Subject (Start .. Stop)); + + elsif Node_OnM.Pcode = PC_Write_OnM then + Put_Line (Node_OnM.FP.all, Subject (Start .. Stop)); + + else + Logic_Error; + end if; + end; + end if; + end loop; + end if; + + return; + + -- Come here if attempt to match current element fails + + -- Stack_Base current stack base + -- Stack_Ptr current stack pointer + + <> + Cursor := Stack (Stack_Ptr).Cursor; + Node := Stack (Stack_Ptr).Node; + Stack_Ptr := Stack_Ptr - 1; + goto Match; + + -- Come here if attempt to match current element succeeds + + -- Cursor current position in subject string + -- Node pointer to node successfully matched + -- Stack_Base current stack base + -- Stack_Ptr current stack pointer + + <> + Node := Node.Pthen; + + -- Come here to match the next pattern element + + -- Cursor current position in subject string + -- Node pointer to node to be matched + -- Stack_Base current stack base + -- Stack_Ptr current stack pointer + + <> + + -------------------------------------------------- + -- Main Pattern Match Element Matching Routines -- + -------------------------------------------------- + + -- Here is the case statement that processes the current node. The + -- processing for each element does one of five things: + + -- goto Succeed to move to the successor + -- goto Match_Succeed if the entire match succeeds + -- goto Match_Fail if the entire match fails + -- goto Fail to signal failure of current match + + -- Processing is NOT allowed to fall through + + case Node.Pcode is + + -- Cancel + + when PC_Cancel => + goto Match_Fail; + + -- Alternation + + when PC_Alt => + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Any (one character case) + + when PC_Any_CH => + if Cursor < Length + and then Subject (Cursor + 1) = Node.Char + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- Any (character set case) + + when PC_Any_CS => + if Cursor < Length + and then Is_In (Subject (Cursor + 1), Node.CS) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- Any (string function case) + + when PC_Any_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + if Cursor < Length + and then Is_In (Subject (Cursor + 1), S (1 .. L)) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Any (string pointer case) + + when PC_Any_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + if Cursor < Length + and then Is_In (Subject (Cursor + 1), S (1 .. L)) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Arb (initial match) + + when PC_Arb_X => + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Arb (extension) + + when PC_Arb_Y => + if Cursor < Length then + Cursor := Cursor + 1; + Push (Node); + goto Succeed; + else + goto Fail; + end if; + + -- Arbno_S (simple Arbno initialize). This is the node that + -- initiates the match of a simple Arbno structure. + + when PC_Arbno_S => + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Arbno_X (Arbno initialize). This is the node that initiates + -- the match of a complex Arbno structure. + + when PC_Arbno_X => + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Arbno_Y (Arbno rematch). This is the node that is executed + -- following successful matching of one instance of a complex + -- Arbno pattern. + + when PC_Arbno_Y => declare + Null_Match : constant Boolean := + Cursor = Stack (Stack_Base - 1).Cursor; + + begin + Pop_Region; + + -- If arbno extension matched null, then immediately fail + + if Null_Match then + goto Fail; + end if; + + -- Here we must do a stack check to make sure enough stack + -- is left. This check will happen once for each instance of + -- the Arbno pattern that is matched. The Nat field of a + -- PC_Arbno pattern contains the maximum stack entries needed + -- for the Arbno with one instance and the successor pattern + + if Stack_Ptr + Node.Nat >= Stack'Last then + raise Pattern_Stack_Overflow; + end if; + + goto Succeed; + end; + + -- Assign. If this node is executed, it means the assign-on-match + -- or write-on-match operation will not happen after all, so we + -- is propagate the failure, removing the PC_Assign node. + + when PC_Assign => + goto Fail; + + -- Assign immediate. This node performs the actual assignment + + when PC_Assign_Imm => + Set_String + (Node.VP.all, + Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)); + Pop_Region; + goto Succeed; + + -- Assign on match. This node sets up for the eventual assignment + + when PC_Assign_OnM => + Stack (Stack_Base - 1).Node := Node; + Push (CP_Assign'Access); + Pop_Region; + Assign_OnM := True; + goto Succeed; + + -- Bal + + when PC_Bal => + if Cursor >= Length or else Subject (Cursor + 1) = ')' then + goto Fail; + + elsif Subject (Cursor + 1) = '(' then + declare + Paren_Count : Natural := 1; + + begin + loop + Cursor := Cursor + 1; + + if Cursor >= Length then + goto Fail; + + elsif Subject (Cursor + 1) = '(' then + Paren_Count := Paren_Count + 1; + + elsif Subject (Cursor + 1) = ')' then + Paren_Count := Paren_Count - 1; + exit when Paren_Count = 0; + end if; + end loop; + end; + end if; + + Cursor := Cursor + 1; + Push (Node); + goto Succeed; + + -- Break (one character case) + + when PC_Break_CH => + while Cursor < Length loop + if Subject (Cursor + 1) = Node.Char then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- Break (character set case) + + when PC_Break_CS => + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), Node.CS) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- Break (string function case) + + when PC_Break_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), S (1 .. L)) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- Break (string pointer case) + + when PC_Break_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), S (1 .. L)) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- BreakX (one character case) + + when PC_BreakX_CH => + while Cursor < Length loop + if Subject (Cursor + 1) = Node.Char then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- BreakX (character set case) + + when PC_BreakX_CS => + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), Node.CS) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- BreakX (string function case) + + when PC_BreakX_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), S (1 .. L)) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- BreakX (string pointer case) + + when PC_BreakX_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), S (1 .. L)) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- BreakX_X (BreakX extension). See section on "Compound Pattern + -- Structures". This node is the alternative that is stacked to + -- skip past the break character and extend the break. + + when PC_BreakX_X => + Cursor := Cursor + 1; + goto Succeed; + + -- Character (one character string) + + when PC_Char => + if Cursor < Length + and then Subject (Cursor + 1) = Node.Char + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- End of Pattern + + when PC_EOP => + if Stack_Base = Stack_Init then + goto Match_Succeed; + + -- End of recursive inner match. See separate section on + -- handing of recursive pattern matches for details. + + else + Node := Stack (Stack_Base - 1).Node; + Pop_Region; + goto Match; + end if; + + -- Fail + + when PC_Fail => + goto Fail; + + -- Fence (built in pattern) + + when PC_Fence => + Push (CP_Cancel'Access); + goto Succeed; + + -- Fence function node X. This is the node that gets control + -- after a successful match of the fenced pattern. + + when PC_Fence_X => + Stack_Ptr := Stack_Ptr + 1; + Stack (Stack_Ptr).Cursor := Stack_Base; + Stack (Stack_Ptr).Node := CP_Fence_Y'Access; + Stack_Base := Stack (Stack_Base).Cursor; + goto Succeed; + + -- Fence function node Y. This is the node that gets control on + -- a failure that occurs after the fenced pattern has matched. + + -- Note: the Cursor at this stage is actually the inner stack + -- base value. We don't reset this, but we do use it to strip + -- off all the entries made by the fenced pattern. + + when PC_Fence_Y => + Stack_Ptr := Cursor - 2; + goto Fail; + + -- Len (integer case) + + when PC_Len_Nat => + if Cursor + Node.Nat > Length then + goto Fail; + else + Cursor := Cursor + Node.Nat; + goto Succeed; + end if; + + -- Len (Integer function case) + + when PC_Len_NF => declare + N : constant Natural := Node.NF.all; + begin + if Cursor + N > Length then + goto Fail; + else + Cursor := Cursor + N; + goto Succeed; + end if; + end; + + -- Len (integer pointer case) + + when PC_Len_NP => + if Cursor + Node.NP.all > Length then + goto Fail; + else + Cursor := Cursor + Node.NP.all; + goto Succeed; + end if; + + -- NotAny (one character case) + + when PC_NotAny_CH => + if Cursor < Length + and then Subject (Cursor + 1) /= Node.Char + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- NotAny (character set case) + + when PC_NotAny_CS => + if Cursor < Length + and then not Is_In (Subject (Cursor + 1), Node.CS) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- NotAny (string function case) + + when PC_NotAny_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + if Cursor < Length + and then + not Is_In (Subject (Cursor + 1), S (1 .. L)) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- NotAny (string pointer case) + + when PC_NotAny_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + if Cursor < Length + and then + not Is_In (Subject (Cursor + 1), S (1 .. L)) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- NSpan (one character case) + + when PC_NSpan_CH => + while Cursor < Length + and then Subject (Cursor + 1) = Node.Char + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + + -- NSpan (character set case) + + when PC_NSpan_CS => + while Cursor < Length + and then Is_In (Subject (Cursor + 1), Node.CS) + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + + -- NSpan (string function case) + + when PC_NSpan_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + while Cursor < Length + and then Is_In (Subject (Cursor + 1), S (1 .. L)) + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + end; + + -- NSpan (string pointer case) + + when PC_NSpan_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + while Cursor < Length + and then Is_In (Subject (Cursor + 1), S (1 .. L)) + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + end; + + -- Null string + + when PC_Null => + goto Succeed; + + -- Pos (integer case) + + when PC_Pos_Nat => + if Cursor = Node.Nat then + goto Succeed; + else + goto Fail; + end if; + + -- Pos (Integer function case) + + when PC_Pos_NF => declare + N : constant Natural := Node.NF.all; + begin + if Cursor = N then + goto Succeed; + else + goto Fail; + end if; + end; + + -- Pos (integer pointer case) + + when PC_Pos_NP => + if Cursor = Node.NP.all then + goto Succeed; + else + goto Fail; + end if; + + -- Predicate function + + when PC_Pred_Func => + if Node.BF.all then + goto Succeed; + else + goto Fail; + end if; + + -- Region Enter. Initiate new pattern history stack region + + when PC_R_Enter => + Stack (Stack_Ptr + 1).Cursor := Cursor; + Push_Region; + goto Succeed; + + -- Region Remove node. This is the node stacked by an R_Enter. + -- It removes the special format stack entry right underneath, and + -- then restores the outer level stack base and signals failure. + + -- Note: the cursor value at this stage is actually the (negative) + -- stack base value for the outer level. + + when PC_R_Remove => + Stack_Base := Cursor; + Stack_Ptr := Stack_Ptr - 1; + goto Fail; + + -- Region restore node. This is the node stacked at the end of an + -- inner level match. Its function is to restore the inner level + -- region, so that alternatives in this region can be sought. + + -- Note: the Cursor at this stage is actually the negative of the + -- inner stack base value, which we use to restore the inner region. + + when PC_R_Restore => + Stack_Base := Cursor; + goto Fail; + + -- Rest + + when PC_Rest => + Cursor := Length; + goto Succeed; + + -- Initiate recursive match (pattern pointer case) + + when PC_Rpat => + Stack (Stack_Ptr + 1).Node := Node.Pthen; + Push_Region; + + if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then + raise Pattern_Stack_Overflow; + else + Node := Node.PP.all.P; + goto Match; + end if; + + -- RPos (integer case) + + when PC_RPos_Nat => + if Cursor = (Length - Node.Nat) then + goto Succeed; + else + goto Fail; + end if; + + -- RPos (integer function case) + + when PC_RPos_NF => declare + N : constant Natural := Node.NF.all; + begin + if Length - Cursor = N then + goto Succeed; + else + goto Fail; + end if; + end; + + -- RPos (integer pointer case) + + when PC_RPos_NP => + if Cursor = (Length - Node.NP.all) then + goto Succeed; + else + goto Fail; + end if; + + -- RTab (integer case) + + when PC_RTab_Nat => + if Cursor <= (Length - Node.Nat) then + Cursor := Length - Node.Nat; + goto Succeed; + else + goto Fail; + end if; + + -- RTab (integer function case) + + when PC_RTab_NF => declare + N : constant Natural := Node.NF.all; + begin + if Length - Cursor >= N then + Cursor := Length - N; + goto Succeed; + else + goto Fail; + end if; + end; + + -- RTab (integer pointer case) + + when PC_RTab_NP => + if Cursor <= (Length - Node.NP.all) then + Cursor := Length - Node.NP.all; + goto Succeed; + else + goto Fail; + end if; + + -- Cursor assignment + + when PC_Setcur => + Node.Var.all := Cursor; + goto Succeed; + + -- Span (one character case) + + when PC_Span_CH => declare + P : Natural; + + begin + P := Cursor; + while P < Length + and then Subject (P + 1) = Node.Char + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Span (character set case) + + when PC_Span_CS => declare + P : Natural; + + begin + P := Cursor; + while P < Length + and then Is_In (Subject (P + 1), Node.CS) + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Span (string function case) + + when PC_Span_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + P : Natural; + + begin + Get_String (U, S, L); + + P := Cursor; + while P < Length + and then Is_In (Subject (P + 1), S (1 .. L)) + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Span (string pointer case) + + when PC_Span_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + P : Natural; + + begin + Get_String (U, S, L); + + P := Cursor; + while P < Length + and then Is_In (Subject (P + 1), S (1 .. L)) + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- String (two character case) + + when PC_String_2 => + if (Length - Cursor) >= 2 + and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2 + then + Cursor := Cursor + 2; + goto Succeed; + else + goto Fail; + end if; + + -- String (three character case) + + when PC_String_3 => + if (Length - Cursor) >= 3 + and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3 + then + Cursor := Cursor + 3; + goto Succeed; + else + goto Fail; + end if; + + -- String (four character case) + + when PC_String_4 => + if (Length - Cursor) >= 4 + and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4 + then + Cursor := Cursor + 4; + goto Succeed; + else + goto Fail; + end if; + + -- String (five character case) + + when PC_String_5 => + if (Length - Cursor) >= 5 + and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5 + then + Cursor := Cursor + 5; + goto Succeed; + else + goto Fail; + end if; + + -- String (six character case) + + when PC_String_6 => + if (Length - Cursor) >= 6 + and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6 + then + Cursor := Cursor + 6; + goto Succeed; + else + goto Fail; + end if; + + -- String (case of more than six characters) + + when PC_String => declare + Len : constant Natural := Node.Str'Length; + begin + if (Length - Cursor) >= Len + and then Node.Str.all = Subject (Cursor + 1 .. Cursor + Len) + then + Cursor := Cursor + Len; + goto Succeed; + else + goto Fail; + end if; + end; + + -- String (function case) + + when PC_String_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + if (Length - Cursor) >= L + and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L) + then + Cursor := Cursor + L; + goto Succeed; + else + goto Fail; + end if; + end; + + -- String (pointer case) + + when PC_String_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + if (Length - Cursor) >= L + and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L) + then + Cursor := Cursor + L; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Succeed + + when PC_Succeed => + Push (Node); + goto Succeed; + + -- Tab (integer case) + + when PC_Tab_Nat => + if Cursor <= Node.Nat then + Cursor := Node.Nat; + goto Succeed; + else + goto Fail; + end if; + + -- Tab (integer function case) + + when PC_Tab_NF => declare + N : constant Natural := Node.NF.all; + begin + if Cursor <= N then + Cursor := N; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Tab (integer pointer case) + + when PC_Tab_NP => + if Cursor <= Node.NP.all then + Cursor := Node.NP.all; + goto Succeed; + else + goto Fail; + end if; + + -- Unanchored movement + + when PC_Unanchored => + + -- All done if we tried every position + + if Cursor > Length then + goto Match_Fail; + + -- Otherwise extend the anchor point, and restack ourself + + else + Cursor := Cursor + 1; + Push (Node); + goto Succeed; + end if; + + -- Write immediate. This node performs the actual write + + when PC_Write_Imm => + Put_Line + (Node.FP.all, + Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)); + Pop_Region; + goto Succeed; + + -- Write on match. This node sets up for the eventual write + + when PC_Write_OnM => + Stack (Stack_Base - 1).Node := Node; + Push (CP_Assign'Access); + Pop_Region; + Assign_OnM := True; + goto Succeed; + + end case; + + -- We are NOT allowed to fall though this case statement, since every + -- match routine must end by executing a goto to the appropriate point + -- in the finite state machine model. + + pragma Warnings (Off); + Logic_Error; + pragma Warnings (On); + end XMatch; + + ------------- + -- XMatchD -- + ------------- + + -- Maintenance note: There is a LOT of code duplication between XMatch + -- and XMatchD. This is quite intentional, the point is to avoid any + -- unnecessary debugging overhead in the XMatch case, but this does mean + -- that any changes to XMatchD must be mirrored in XMatch. In case of + -- any major changes, the proper approach is to delete XMatch, make the + -- changes to XMatchD, and then make a copy of XMatchD, removing all + -- calls to Dout, and all Put and Put_Line operations. This copy becomes + -- the new XMatch. + + procedure XMatchD + (Subject : String; + Pat_P : PE_Ptr; + Pat_S : Natural; + Start : out Natural; + Stop : out Natural) + is + Node : PE_Ptr; + -- Pointer to current pattern node. Initialized from Pat_P, and then + -- updated as the match proceeds through its constituent elements. + + Length : constant Natural := Subject'Length; + -- Length of string (= Subject'Last, since Subject'First is always 1) + + Cursor : Integer := 0; + -- If the value is non-negative, then this value is the index showing + -- the current position of the match in the subject string. The next + -- character to be matched is at Subject (Cursor + 1). Note that since + -- our view of the subject string in XMatch always has a lower bound + -- of one, regardless of original bounds, that this definition exactly + -- corresponds to the cursor value as referenced by functions like Pos. + -- + -- If the value is negative, then this is a saved stack pointer, + -- typically a base pointer of an inner or outer region. Cursor + -- temporarily holds such a value when it is popped from the stack + -- by Fail. In all cases, Cursor is reset to a proper non-negative + -- cursor value before the match proceeds (e.g. by propagating the + -- failure and popping a "real" cursor value from the stack. + + PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P); + -- Dummy pattern element used in the unanchored case + + Region_Level : Natural := 0; + -- Keeps track of recursive region level. This is used only for + -- debugging, it is the number of saved history stack base values. + + Stack : Stack_Type; + -- The pattern matching failure stack for this call to Match + + Stack_Ptr : Stack_Range; + -- Current stack pointer. This points to the top element of the stack + -- that is currently in use. At the outer level this is the special + -- entry placed on the stack according to the anchor mode. + + Stack_Init : constant Stack_Range := Stack'First + 1; + -- This is the initial value of the Stack_Ptr and Stack_Base. The + -- initial (Stack'First) element of the stack is not used so that + -- when we pop the last element off, Stack_Ptr is still in range. + + Stack_Base : Stack_Range; + -- This value is the stack base value, i.e. the stack pointer for the + -- first history stack entry in the current stack region. See separate + -- section on handling of recursive pattern matches. + + Assign_OnM : Boolean := False; + -- Set True if assign-on-match or write-on-match operations may be + -- present in the history stack, which must then be scanned on a + -- successful match. + + procedure Dout (Str : String); + -- Output string to standard error with bars indicating region level + + procedure Dout (Str : String; A : Character); + -- Calls Dout with the string S ('A') + + procedure Dout (Str : String; A : Character_Set); + -- Calls Dout with the string S ("A") + + procedure Dout (Str : String; A : Natural); + -- Calls Dout with the string S (A) + + procedure Dout (Str : String; A : String); + -- Calls Dout with the string S ("A") + + function Img (P : PE_Ptr) return String; + -- Returns a string of the form #nnn where nnn is P.Index + + procedure Pop_Region; + pragma Inline (Pop_Region); + -- Used at the end of processing of an inner region. If the inner + -- region left no stack entries, then all trace of it is removed. + -- Otherwise a PC_Restore_Region entry is pushed to ensure proper + -- handling of alternatives in the inner region. + + procedure Push (Node : PE_Ptr); + pragma Inline (Push); + -- Make entry in pattern matching stack with current cursor value + + procedure Push_Region; + pragma Inline (Push_Region); + -- This procedure makes a new region on the history stack. The + -- caller first establishes the special entry on the stack, but + -- does not push the stack pointer. Then this call stacks a + -- PC_Remove_Region node, on top of this entry, using the cursor + -- field of the PC_Remove_Region entry to save the outer level + -- stack base value, and resets the stack base to point to this + -- PC_Remove_Region node. + + ---------- + -- Dout -- + ---------- + + procedure Dout (Str : String) is + begin + for J in 1 .. Region_Level loop + Put ("| "); + end loop; + + Put_Line (Str); + end Dout; + + procedure Dout (Str : String; A : Character) is + begin + Dout (Str & " ('" & A & "')"); + end Dout; + + procedure Dout (Str : String; A : Character_Set) is + begin + Dout (Str & " (" & Image (To_Sequence (A)) & ')'); + end Dout; + + procedure Dout (Str : String; A : Natural) is + begin + Dout (Str & " (" & A & ')'); + end Dout; + + procedure Dout (Str : String; A : String) is + begin + Dout (Str & " (" & Image (A) & ')'); + end Dout; + + --------- + -- Img -- + --------- + + function Img (P : PE_Ptr) return String is + begin + return "#" & Integer (P.Index) & " "; + end Img; + + ---------------- + -- Pop_Region -- + ---------------- + + procedure Pop_Region is + begin + Region_Level := Region_Level - 1; + + -- If nothing was pushed in the inner region, we can just get + -- rid of it entirely, leaving no traces that it was ever there + + if Stack_Ptr = Stack_Base then + Stack_Ptr := Stack_Base - 2; + Stack_Base := Stack (Stack_Ptr + 2).Cursor; + + -- If stuff was pushed in the inner region, then we have to + -- push a PC_R_Restore node so that we properly handle possible + -- rematches within the region. + + else + Stack_Ptr := Stack_Ptr + 1; + Stack (Stack_Ptr).Cursor := Stack_Base; + Stack (Stack_Ptr).Node := CP_R_Restore'Access; + Stack_Base := Stack (Stack_Base).Cursor; + end if; + end Pop_Region; + + ---------- + -- Push -- + ---------- + + procedure Push (Node : PE_Ptr) is + begin + Stack_Ptr := Stack_Ptr + 1; + Stack (Stack_Ptr).Cursor := Cursor; + Stack (Stack_Ptr).Node := Node; + end Push; + + ----------------- + -- Push_Region -- + ----------------- + + procedure Push_Region is + begin + Region_Level := Region_Level + 1; + Stack_Ptr := Stack_Ptr + 2; + Stack (Stack_Ptr).Cursor := Stack_Base; + Stack (Stack_Ptr).Node := CP_R_Remove'Access; + Stack_Base := Stack_Ptr; + end Push_Region; + + -- Start of processing for XMatchD + + begin + New_Line; + Put_Line ("Initiating pattern match, subject = " & Image (Subject)); + Put ("--------------------------------------"); + + for J in 1 .. Length loop + Put ('-'); + end loop; + + New_Line; + Put_Line ("subject length = " & Length); + + if Pat_P = null then + Uninitialized_Pattern; + end if; + + -- Check we have enough stack for this pattern. This check deals with + -- every possibility except a match of a recursive pattern, where we + -- make a check at each recursion level. + + if Pat_S >= Stack_Size - 1 then + raise Pattern_Stack_Overflow; + end if; + + -- In anchored mode, the bottom entry on the stack is an abort entry + + if Anchored_Mode then + Stack (Stack_Init).Node := CP_Cancel'Access; + Stack (Stack_Init).Cursor := 0; + + -- In unanchored more, the bottom entry on the stack references + -- the special pattern element PE_Unanchored, whose Pthen field + -- points to the initial pattern element. The cursor value in this + -- entry is the number of anchor moves so far. + + else + Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access; + Stack (Stack_Init).Cursor := 0; + end if; + + Stack_Ptr := Stack_Init; + Stack_Base := Stack_Ptr; + Cursor := 0; + Node := Pat_P; + goto Match; + + ----------------------------------------- + -- Main Pattern Matching State Control -- + ----------------------------------------- + + -- This is a state machine which uses gotos to change state. The + -- initial state is Match, to initiate the matching of the first + -- element, so the goto Match above starts the match. In the + -- following descriptions, we indicate the global values that + -- are relevant for the state transition. + + -- Come here if entire match fails + + <> + Dout ("match fails"); + New_Line; + Start := 0; + Stop := 0; + return; + + -- Come here if entire match succeeds + + -- Cursor current position in subject string + + <> + Dout ("match succeeds"); + Start := Stack (Stack_Init).Cursor + 1; + Stop := Cursor; + Dout ("first matched character index = " & Start); + Dout ("last matched character index = " & Stop); + Dout ("matched substring = " & Image (Subject (Start .. Stop))); + + -- Scan history stack for deferred assignments or writes + + if Assign_OnM then + for S in Stack'First .. Stack_Ptr loop + if Stack (S).Node = CP_Assign'Access then + declare + Inner_Base : constant Stack_Range := + Stack (S + 1).Cursor; + Special_Entry : constant Stack_Range := + Inner_Base - 1; + Node_OnM : constant PE_Ptr := + Stack (Special_Entry).Node; + Start : constant Natural := + Stack (Special_Entry).Cursor + 1; + Stop : constant Natural := Stack (S).Cursor; + + begin + if Node_OnM.Pcode = PC_Assign_OnM then + Set_String (Node_OnM.VP.all, Subject (Start .. Stop)); + Dout + (Img (Stack (S).Node) & + "deferred assignment of " & + Image (Subject (Start .. Stop))); + + elsif Node_OnM.Pcode = PC_Write_OnM then + Put_Line (Node_OnM.FP.all, Subject (Start .. Stop)); + Dout + (Img (Stack (S).Node) & + "deferred write of " & + Image (Subject (Start .. Stop))); + + else + Logic_Error; + end if; + end; + end if; + end loop; + end if; + + New_Line; + return; + + -- Come here if attempt to match current element fails + + -- Stack_Base current stack base + -- Stack_Ptr current stack pointer + + <> + Cursor := Stack (Stack_Ptr).Cursor; + Node := Stack (Stack_Ptr).Node; + Stack_Ptr := Stack_Ptr - 1; + + if Cursor >= 0 then + Dout ("failure, cursor reset to " & Cursor); + end if; + + goto Match; + + -- Come here if attempt to match current element succeeds + + -- Cursor current position in subject string + -- Node pointer to node successfully matched + -- Stack_Base current stack base + -- Stack_Ptr current stack pointer + + <> + Dout ("success, cursor = " & Cursor); + Node := Node.Pthen; + + -- Come here to match the next pattern element + + -- Cursor current position in subject string + -- Node pointer to node to be matched + -- Stack_Base current stack base + -- Stack_Ptr current stack pointer + + <> + + -------------------------------------------------- + -- Main Pattern Match Element Matching Routines -- + -------------------------------------------------- + + -- Here is the case statement that processes the current node. The + -- processing for each element does one of five things: + + -- goto Succeed to move to the successor + -- goto Match_Succeed if the entire match succeeds + -- goto Match_Fail if the entire match fails + -- goto Fail to signal failure of current match + + -- Processing is NOT allowed to fall through + + case Node.Pcode is + + -- Cancel + + when PC_Cancel => + Dout (Img (Node) & "matching Cancel"); + goto Match_Fail; + + -- Alternation + + when PC_Alt => + Dout + (Img (Node) & "setting up alternative " & Img (Node.Alt)); + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Any (one character case) + + when PC_Any_CH => + Dout (Img (Node) & "matching Any", Node.Char); + + if Cursor < Length + and then Subject (Cursor + 1) = Node.Char + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- Any (character set case) + + when PC_Any_CS => + Dout (Img (Node) & "matching Any", Node.CS); + + if Cursor < Length + and then Is_In (Subject (Cursor + 1), Node.CS) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- Any (string function case) + + when PC_Any_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + Dout (Img (Node) & "matching Any", S (1 .. L)); + + if Cursor < Length + and then Is_In (Subject (Cursor + 1), S (1 .. L)) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Any (string pointer case) + + when PC_Any_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching Any", S (1 .. L)); + + if Cursor < Length + and then Is_In (Subject (Cursor + 1), S (1 .. L)) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Arb (initial match) + + when PC_Arb_X => + Dout (Img (Node) & "matching Arb"); + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Arb (extension) + + when PC_Arb_Y => + Dout (Img (Node) & "extending Arb"); + + if Cursor < Length then + Cursor := Cursor + 1; + Push (Node); + goto Succeed; + else + goto Fail; + end if; + + -- Arbno_S (simple Arbno initialize). This is the node that + -- initiates the match of a simple Arbno structure. + + when PC_Arbno_S => + Dout (Img (Node) & + "setting up Arbno alternative " & Img (Node.Alt)); + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Arbno_X (Arbno initialize). This is the node that initiates + -- the match of a complex Arbno structure. + + when PC_Arbno_X => + Dout (Img (Node) & + "setting up Arbno alternative " & Img (Node.Alt)); + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Arbno_Y (Arbno rematch). This is the node that is executed + -- following successful matching of one instance of a complex + -- Arbno pattern. + + when PC_Arbno_Y => declare + Null_Match : constant Boolean := + Cursor = Stack (Stack_Base - 1).Cursor; + + begin + Dout (Img (Node) & "extending Arbno"); + Pop_Region; + + -- If arbno extension matched null, then immediately fail + + if Null_Match then + Dout ("Arbno extension matched null, so fails"); + goto Fail; + end if; + + -- Here we must do a stack check to make sure enough stack + -- is left. This check will happen once for each instance of + -- the Arbno pattern that is matched. The Nat field of a + -- PC_Arbno pattern contains the maximum stack entries needed + -- for the Arbno with one instance and the successor pattern + + if Stack_Ptr + Node.Nat >= Stack'Last then + raise Pattern_Stack_Overflow; + end if; + + goto Succeed; + end; + + -- Assign. If this node is executed, it means the assign-on-match + -- or write-on-match operation will not happen after all, so we + -- is propagate the failure, removing the PC_Assign node. + + when PC_Assign => + Dout (Img (Node) & "deferred assign/write cancelled"); + goto Fail; + + -- Assign immediate. This node performs the actual assignment + + when PC_Assign_Imm => + Dout + (Img (Node) & "executing immediate assignment of " & + Image (Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor))); + Set_String + (Node.VP.all, + Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)); + Pop_Region; + goto Succeed; + + -- Assign on match. This node sets up for the eventual assignment + + when PC_Assign_OnM => + Dout (Img (Node) & "registering deferred assignment"); + Stack (Stack_Base - 1).Node := Node; + Push (CP_Assign'Access); + Pop_Region; + Assign_OnM := True; + goto Succeed; + + -- Bal + + when PC_Bal => + Dout (Img (Node) & "matching or extending Bal"); + if Cursor >= Length or else Subject (Cursor + 1) = ')' then + goto Fail; + + elsif Subject (Cursor + 1) = '(' then + declare + Paren_Count : Natural := 1; + + begin + loop + Cursor := Cursor + 1; + + if Cursor >= Length then + goto Fail; + + elsif Subject (Cursor + 1) = '(' then + Paren_Count := Paren_Count + 1; + + elsif Subject (Cursor + 1) = ')' then + Paren_Count := Paren_Count - 1; + exit when Paren_Count = 0; + end if; + end loop; + end; + end if; + + Cursor := Cursor + 1; + Push (Node); + goto Succeed; + + -- Break (one character case) + + when PC_Break_CH => + Dout (Img (Node) & "matching Break", Node.Char); + + while Cursor < Length loop + if Subject (Cursor + 1) = Node.Char then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- Break (character set case) + + when PC_Break_CS => + Dout (Img (Node) & "matching Break", Node.CS); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), Node.CS) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- Break (string function case) + + when PC_Break_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching Break", S (1 .. L)); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), S (1 .. L)) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- Break (string pointer case) + + when PC_Break_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching Break", S (1 .. L)); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), S (1 .. L)) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- BreakX (one character case) + + when PC_BreakX_CH => + Dout (Img (Node) & "matching BreakX", Node.Char); + + while Cursor < Length loop + if Subject (Cursor + 1) = Node.Char then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- BreakX (character set case) + + when PC_BreakX_CS => + Dout (Img (Node) & "matching BreakX", Node.CS); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), Node.CS) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- BreakX (string function case) + + when PC_BreakX_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching BreakX", S (1 .. L)); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), S (1 .. L)) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- BreakX (string pointer case) + + when PC_BreakX_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching BreakX", S (1 .. L)); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), S (1 .. L)) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- BreakX_X (BreakX extension). See section on "Compound Pattern + -- Structures". This node is the alternative that is stacked + -- to skip past the break character and extend the break. + + when PC_BreakX_X => + Dout (Img (Node) & "extending BreakX"); + Cursor := Cursor + 1; + goto Succeed; + + -- Character (one character string) + + when PC_Char => + Dout (Img (Node) & "matching '" & Node.Char & '''); + + if Cursor < Length + and then Subject (Cursor + 1) = Node.Char + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- End of Pattern + + when PC_EOP => + if Stack_Base = Stack_Init then + Dout ("end of pattern"); + goto Match_Succeed; + + -- End of recursive inner match. See separate section on + -- handing of recursive pattern matches for details. + + else + Dout ("terminating recursive match"); + Node := Stack (Stack_Base - 1).Node; + Pop_Region; + goto Match; + end if; + + -- Fail + + when PC_Fail => + Dout (Img (Node) & "matching Fail"); + goto Fail; + + -- Fence (built in pattern) + + when PC_Fence => + Dout (Img (Node) & "matching Fence"); + Push (CP_Cancel'Access); + goto Succeed; + + -- Fence function node X. This is the node that gets control + -- after a successful match of the fenced pattern. + + when PC_Fence_X => + Dout (Img (Node) & "matching Fence function"); + Stack_Ptr := Stack_Ptr + 1; + Stack (Stack_Ptr).Cursor := Stack_Base; + Stack (Stack_Ptr).Node := CP_Fence_Y'Access; + Stack_Base := Stack (Stack_Base).Cursor; + Region_Level := Region_Level - 1; + goto Succeed; + + -- Fence function node Y. This is the node that gets control on + -- a failure that occurs after the fenced pattern has matched. + + -- Note: the Cursor at this stage is actually the inner stack + -- base value. We don't reset this, but we do use it to strip + -- off all the entries made by the fenced pattern. + + when PC_Fence_Y => + Dout (Img (Node) & "pattern matched by Fence caused failure"); + Stack_Ptr := Cursor - 2; + goto Fail; + + -- Len (integer case) + + when PC_Len_Nat => + Dout (Img (Node) & "matching Len", Node.Nat); + + if Cursor + Node.Nat > Length then + goto Fail; + else + Cursor := Cursor + Node.Nat; + goto Succeed; + end if; + + -- Len (Integer function case) + + when PC_Len_NF => declare + N : constant Natural := Node.NF.all; + + begin + Dout (Img (Node) & "matching Len", N); + + if Cursor + N > Length then + goto Fail; + else + Cursor := Cursor + N; + goto Succeed; + end if; + end; + + -- Len (integer pointer case) + + when PC_Len_NP => + Dout (Img (Node) & "matching Len", Node.NP.all); + + if Cursor + Node.NP.all > Length then + goto Fail; + else + Cursor := Cursor + Node.NP.all; + goto Succeed; + end if; + + -- NotAny (one character case) + + when PC_NotAny_CH => + Dout (Img (Node) & "matching NotAny", Node.Char); + + if Cursor < Length + and then Subject (Cursor + 1) /= Node.Char + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- NotAny (character set case) + + when PC_NotAny_CS => + Dout (Img (Node) & "matching NotAny", Node.CS); + + if Cursor < Length + and then not Is_In (Subject (Cursor + 1), Node.CS) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- NotAny (string function case) + + when PC_NotAny_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching NotAny", S (1 .. L)); + + if Cursor < Length + and then + not Is_In (Subject (Cursor + 1), S (1 .. L)) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- NotAny (string pointer case) + + when PC_NotAny_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching NotAny", S (1 .. L)); + + if Cursor < Length + and then + not Is_In (Subject (Cursor + 1), S (1 .. L)) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- NSpan (one character case) + + when PC_NSpan_CH => + Dout (Img (Node) & "matching NSpan", Node.Char); + + while Cursor < Length + and then Subject (Cursor + 1) = Node.Char + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + + -- NSpan (character set case) + + when PC_NSpan_CS => + Dout (Img (Node) & "matching NSpan", Node.CS); + + while Cursor < Length + and then Is_In (Subject (Cursor + 1), Node.CS) + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + + -- NSpan (string function case) + + when PC_NSpan_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching NSpan", S (1 .. L)); + + while Cursor < Length + and then Is_In (Subject (Cursor + 1), S (1 .. L)) + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + end; + + -- NSpan (string pointer case) + + when PC_NSpan_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching NSpan", S (1 .. L)); + + while Cursor < Length + and then Is_In (Subject (Cursor + 1), S (1 .. L)) + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + end; + + when PC_Null => + Dout (Img (Node) & "matching null"); + goto Succeed; + + -- Pos (integer case) + + when PC_Pos_Nat => + Dout (Img (Node) & "matching Pos", Node.Nat); + + if Cursor = Node.Nat then + goto Succeed; + else + goto Fail; + end if; + + -- Pos (Integer function case) + + when PC_Pos_NF => declare + N : constant Natural := Node.NF.all; + + begin + Dout (Img (Node) & "matching Pos", N); + + if Cursor = N then + goto Succeed; + else + goto Fail; + end if; + end; + + -- Pos (integer pointer case) + + when PC_Pos_NP => + Dout (Img (Node) & "matching Pos", Node.NP.all); + + if Cursor = Node.NP.all then + goto Succeed; + else + goto Fail; + end if; + + -- Predicate function + + when PC_Pred_Func => + Dout (Img (Node) & "matching predicate function"); + + if Node.BF.all then + goto Succeed; + else + goto Fail; + end if; + + -- Region Enter. Initiate new pattern history stack region + + when PC_R_Enter => + Dout (Img (Node) & "starting match of nested pattern"); + Stack (Stack_Ptr + 1).Cursor := Cursor; + Push_Region; + goto Succeed; + + -- Region Remove node. This is the node stacked by an R_Enter. + -- It removes the special format stack entry right underneath, and + -- then restores the outer level stack base and signals failure. + + -- Note: the cursor value at this stage is actually the (negative) + -- stack base value for the outer level. + + when PC_R_Remove => + Dout ("failure, match of nested pattern terminated"); + Stack_Base := Cursor; + Region_Level := Region_Level - 1; + Stack_Ptr := Stack_Ptr - 1; + goto Fail; + + -- Region restore node. This is the node stacked at the end of an + -- inner level match. Its function is to restore the inner level + -- region, so that alternatives in this region can be sought. + + -- Note: the Cursor at this stage is actually the negative of the + -- inner stack base value, which we use to restore the inner region. + + when PC_R_Restore => + Dout ("failure, search for alternatives in nested pattern"); + Region_Level := Region_Level + 1; + Stack_Base := Cursor; + goto Fail; + + -- Rest + + when PC_Rest => + Dout (Img (Node) & "matching Rest"); + Cursor := Length; + goto Succeed; + + -- Initiate recursive match (pattern pointer case) + + when PC_Rpat => + Stack (Stack_Ptr + 1).Node := Node.Pthen; + Push_Region; + Dout (Img (Node) & "initiating recursive match"); + + if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then + raise Pattern_Stack_Overflow; + else + Node := Node.PP.all.P; + goto Match; + end if; + + -- RPos (integer case) + + when PC_RPos_Nat => + Dout (Img (Node) & "matching RPos", Node.Nat); + + if Cursor = (Length - Node.Nat) then + goto Succeed; + else + goto Fail; + end if; + + -- RPos (integer function case) + + when PC_RPos_NF => declare + N : constant Natural := Node.NF.all; + + begin + Dout (Img (Node) & "matching RPos", N); + + if Length - Cursor = N then + goto Succeed; + else + goto Fail; + end if; + end; + + -- RPos (integer pointer case) + + when PC_RPos_NP => + Dout (Img (Node) & "matching RPos", Node.NP.all); + + if Cursor = (Length - Node.NP.all) then + goto Succeed; + else + goto Fail; + end if; + + -- RTab (integer case) + + when PC_RTab_Nat => + Dout (Img (Node) & "matching RTab", Node.Nat); + + if Cursor <= (Length - Node.Nat) then + Cursor := Length - Node.Nat; + goto Succeed; + else + goto Fail; + end if; + + -- RTab (integer function case) + + when PC_RTab_NF => declare + N : constant Natural := Node.NF.all; + + begin + Dout (Img (Node) & "matching RPos", N); + + if Length - Cursor >= N then + Cursor := Length - N; + goto Succeed; + else + goto Fail; + end if; + end; + + -- RTab (integer pointer case) + + when PC_RTab_NP => + Dout (Img (Node) & "matching RPos", Node.NP.all); + + if Cursor <= (Length - Node.NP.all) then + Cursor := Length - Node.NP.all; + goto Succeed; + else + goto Fail; + end if; + + -- Cursor assignment + + when PC_Setcur => + Dout (Img (Node) & "matching Setcur"); + Node.Var.all := Cursor; + goto Succeed; + + -- Span (one character case) + + when PC_Span_CH => declare + P : Natural := Cursor; + + begin + Dout (Img (Node) & "matching Span", Node.Char); + + while P < Length + and then Subject (P + 1) = Node.Char + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Span (character set case) + + when PC_Span_CS => declare + P : Natural := Cursor; + + begin + Dout (Img (Node) & "matching Span", Node.CS); + + while P < Length + and then Is_In (Subject (P + 1), Node.CS) + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Span (string function case) + + when PC_Span_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + P : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching Span", S (1 .. L)); + + P := Cursor; + while P < Length + and then Is_In (Subject (P + 1), S (1 .. L)) + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Span (string pointer case) + + when PC_Span_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + P : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching Span", S (1 .. L)); + + P := Cursor; + while P < Length + and then Is_In (Subject (P + 1), S (1 .. L)) + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- String (two character case) + + when PC_String_2 => + Dout (Img (Node) & "matching " & Image (Node.Str2)); + + if (Length - Cursor) >= 2 + and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2 + then + Cursor := Cursor + 2; + goto Succeed; + else + goto Fail; + end if; + + -- String (three character case) + + when PC_String_3 => + Dout (Img (Node) & "matching " & Image (Node.Str3)); + + if (Length - Cursor) >= 3 + and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3 + then + Cursor := Cursor + 3; + goto Succeed; + else + goto Fail; + end if; + + -- String (four character case) + + when PC_String_4 => + Dout (Img (Node) & "matching " & Image (Node.Str4)); + + if (Length - Cursor) >= 4 + and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4 + then + Cursor := Cursor + 4; + goto Succeed; + else + goto Fail; + end if; + + -- String (five character case) + + when PC_String_5 => + Dout (Img (Node) & "matching " & Image (Node.Str5)); + + if (Length - Cursor) >= 5 + and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5 + then + Cursor := Cursor + 5; + goto Succeed; + else + goto Fail; + end if; + + -- String (six character case) + + when PC_String_6 => + Dout (Img (Node) & "matching " & Image (Node.Str6)); + + if (Length - Cursor) >= 6 + and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6 + then + Cursor := Cursor + 6; + goto Succeed; + else + goto Fail; + end if; + + -- String (case of more than six characters) + + when PC_String => declare + Len : constant Natural := Node.Str'Length; + + begin + Dout (Img (Node) & "matching " & Image (Node.Str.all)); + + if (Length - Cursor) >= Len + and then Node.Str.all = Subject (Cursor + 1 .. Cursor + Len) + then + Cursor := Cursor + Len; + goto Succeed; + else + goto Fail; + end if; + end; + + -- String (function case) + + when PC_String_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching " & Image (S (1 .. L))); + + if (Length - Cursor) >= L + and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L) + then + Cursor := Cursor + L; + goto Succeed; + else + goto Fail; + end if; + end; + + -- String (vstring pointer case) + + when PC_String_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching " & Image (S (1 .. L))); + + if (Length - Cursor) >= L + and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L) + then + Cursor := Cursor + L; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Succeed + + when PC_Succeed => + Dout (Img (Node) & "matching Succeed"); + Push (Node); + goto Succeed; + + -- Tab (integer case) + + when PC_Tab_Nat => + Dout (Img (Node) & "matching Tab", Node.Nat); + + if Cursor <= Node.Nat then + Cursor := Node.Nat; + goto Succeed; + else + goto Fail; + end if; + + -- Tab (integer function case) + + when PC_Tab_NF => declare + N : constant Natural := Node.NF.all; + + begin + Dout (Img (Node) & "matching Tab ", N); + + if Cursor <= N then + Cursor := N; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Tab (integer pointer case) + + when PC_Tab_NP => + Dout (Img (Node) & "matching Tab ", Node.NP.all); + + if Cursor <= Node.NP.all then + Cursor := Node.NP.all; + goto Succeed; + else + goto Fail; + end if; + + -- Unanchored movement + + when PC_Unanchored => + Dout ("attempting to move anchor point"); + + -- All done if we tried every position + + if Cursor > Length then + goto Match_Fail; + + -- Otherwise extend the anchor point, and restack ourself + + else + Cursor := Cursor + 1; + Push (Node); + goto Succeed; + end if; + + -- Write immediate. This node performs the actual write + + when PC_Write_Imm => + Dout (Img (Node) & "executing immediate write of " & + Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)); + + Put_Line + (Node.FP.all, + Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)); + Pop_Region; + goto Succeed; + + -- Write on match. This node sets up for the eventual write + + when PC_Write_OnM => + Dout (Img (Node) & "registering deferred write"); + Stack (Stack_Base - 1).Node := Node; + Push (CP_Assign'Access); + Pop_Region; + Assign_OnM := True; + goto Succeed; + + end case; + + -- We are NOT allowed to fall though this case statement, since every + -- match routine must end by executing a goto to the appropriate point + -- in the finite state machine model. + + pragma Warnings (Off); + Logic_Error; + pragma Warnings (On); + end XMatchD; + +end GNAT.Spitbol.Patterns; diff --git a/gcc/ada/g-spipat.ads b/gcc/ada/g-spipat.ads new file mode 100644 index 000000000..0ea2d3a3e --- /dev/null +++ b/gcc/ada/g-spipat.ads @@ -0,0 +1,1189 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 S. 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 new file mode 100644 index 000000000..4769fa302 --- /dev/null +++ b/gcc/ada/g-spitbo.adb @@ -0,0 +1,771 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S P I T B O L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +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 > 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 -- + ------------ + + 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 -- + -------------- + + 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 new file mode 100644 index 000000000..c87a20ea8 --- /dev/null +++ b/gcc/ada/g-spitbo.ads @@ -0,0 +1,396 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S P I T B O L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1997-2006, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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. Indexing_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); + + 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. + + 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 new file mode 100644 index 000000000..659a2a1ff --- /dev/null +++ b/gcc/ada/g-sptabo.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2005, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 new file mode 100644 index 000000000..3ac15d1a2 --- /dev/null +++ b/gcc/ada/g-sptain.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2005, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 new file mode 100644 index 000000000..afa1575a2 --- /dev/null +++ b/gcc/ada/g-sptavs.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2005, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 new file mode 100644 index 000000000..706516b98 --- /dev/null +++ b/gcc/ada/g-sse.ads @@ -0,0 +1,137 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S S E -- +-- -- +-- 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 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 + +-- 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 new file mode 100644 index 000000000..c40706474 --- /dev/null +++ b/gcc/ada/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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 new file mode 100644 index 000000000..8d118d550 --- /dev/null +++ b/gcc/ada/g-stheme.adb @@ -0,0 +1,76 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- GNAT.SOCKETS.THIN.HOST_ERROR_MESSAGES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the 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 + + package Messages is + HOST_NOT_FOUND : aliased char_array := "Host not found" & nul; + TRY_AGAIN : aliased char_array := "Try again" & nul; + NO_RECOVERY : aliased char_array := "No recovery" & nul; + NO_DATA : aliased char_array := "No address" & nul; + Unknown_Error : aliased char_array := "Unknown error" & nul; + end Messages; + + function Host_Error_Message (H_Errno : Integer) return C.Strings.chars_ptr + is + use Interfaces.C.Strings; + function TCP + (P : char_array_access; Nul_Check : Boolean := False) return chars_ptr + renames To_Chars_Ptr; + + begin + case H_Errno is + when SOSC.HOST_NOT_FOUND => + return TCP (Messages.HOST_NOT_FOUND'Access); + + when SOSC.TRY_AGAIN => + return TCP (Messages.TRY_AGAIN'Access); + + when SOSC.NO_RECOVERY => + return TCP (Messages.NO_RECOVERY'Access); + + when SOSC.NO_DATA => + return TCP (Messages.NO_DATA'Access); + + when others => + return TCP (Messages.Unknown_Error'Access); + + end case; + end Host_Error_Message; + +end Host_Error_Messages; diff --git a/gcc/ada/g-string.adb b/gcc/ada/g-string.adb new file mode 100644 index 000000000..970ef2cd1 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..a25938ed2 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..746ab8302 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..2e797b09a --- /dev/null +++ b/gcc/ada/g-stseme.adb @@ -0,0 +1,58 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- GNAT.SOCKETS.THIN.SOCKET_ERROR_MESSAGE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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. + +with System.CRTL.Runtime; + +separate (GNAT.Sockets.Thin) + +-------------------------- +-- Socket_Error_Message -- +-------------------------- + +function Socket_Error_Message + (Errno : Integer) return C.Strings.chars_ptr +is + use type Interfaces.C.Strings.chars_ptr; + C_Msg : constant C.Strings.chars_ptr := + System.CRTL.Runtime.strerror (Errno); + +begin + if C_Msg = C.Strings.Null_Ptr then + return Unknown_System_Error; + else + return C_Msg; + end if; +end Socket_Error_Message; diff --git a/gcc/ada/g-stsifd-sockets.adb b/gcc/ada/g-stsifd-sockets.adb new file mode 100644 index 000000000..3e3f45188 --- /dev/null +++ b/gcc/ada/g-stsifd-sockets.adb @@ -0,0 +1,236 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Portable sockets-based implementation of GNAT.Sockets.Thin.Signalling_Fds +-- used for platforms that do not support UNIX pipes. + +-- Note: this code used to be in GNAT.Sockets, but has been moved to a +-- platform-specific file. It is now used only for non-UNIX platforms. + +separate (GNAT.Sockets.Thin) +package body Signalling_Fds is + + ----------- + -- Close -- + ----------- + + procedure Close (Sig : C.int) is + Res : C.int; + pragma Unreferenced (Res); + -- Res is assigned but never read, because we purposefully ignore + -- any error returned by the C_Close system call, as per the spec + -- of this procedure. + begin + Res := C_Close (Sig); + end Close; + + ------------ + -- Create -- + ------------ + + function Create (Fds : not null access Fd_Pair) return C.int is + L_Sock, R_Sock, W_Sock : C.int := Failure; + -- Listening socket, read socket and write socket + + Sin : aliased Sockaddr_In; + Len : aliased C.int; + -- Address of listening socket + + Res : C.int; + pragma Warnings (Off, Res); + -- Return status of system calls (usually ignored, hence warnings off) + + begin + Fds.all := (Read_End | Write_End => Failure); + + -- We open two signalling sockets. One of them is used to send data + -- to the other, which is included in a C_Select socket set. The + -- communication is used to force the call to C_Select to complete, + -- and the waiting task to resume its execution. + + loop + -- Retry loop, in case the C_Connect below fails + + -- Create a listening socket + + L_Sock := C_Socket (SOSC.AF_INET, SOSC.SOCK_STREAM, 0); + + if L_Sock = Failure then + goto Fail; + end if; + + -- Bind the socket to an available port on localhost + + Set_Family (Sin.Sin_Family, Family_Inet); + Sin.Sin_Addr.S_B1 := 127; + Sin.Sin_Addr.S_B2 := 0; + Sin.Sin_Addr.S_B3 := 0; + Sin.Sin_Addr.S_B4 := 1; + Sin.Sin_Port := 0; + + Len := C.int (Lengths (Family_Inet)); + Res := C_Bind (L_Sock, Sin'Address, Len); + + if Res = Failure then + goto Fail; + end if; + + -- Get assigned port + + Res := C_Getsockname (L_Sock, Sin'Address, Len'Access); + if Res = Failure then + goto Fail; + end if; + + -- Set socket to listen mode, with a backlog of 1 to guarantee that + -- exactly one call to connect(2) succeeds. + + Res := C_Listen (L_Sock, 1); + + if Res = Failure then + goto Fail; + end if; + + -- Create read end (client) socket + + R_Sock := C_Socket (SOSC.AF_INET, SOSC.SOCK_STREAM, 0); + + if R_Sock = Failure then + goto Fail; + end if; + + -- Connect listening socket + + Res := C_Connect (R_Sock, Sin'Address, Len); + + exit when Res /= Failure; + + if Socket_Errno /= SOSC.EADDRINUSE then + goto Fail; + end if; + + -- In rare cases, the above C_Bind chooses a port that is still + -- marked "in use", even though it has been closed (perhaps by some + -- other process that has already exited). This causes the above + -- C_Connect to fail with EADDRINUSE. In this case, we close the + -- ports, and loop back to try again. This mysterious Windows + -- behavior is documented. See, for example: + -- http://msdn2.microsoft.com/en-us/library/ms737625.aspx + -- In an experiment with 2000 calls, 21 required exactly one retry, 7 + -- required two, and none required three or more. Note that no delay + -- is needed between retries; retrying C_Bind will typically produce + -- a different port. + + pragma Assert (Res = Failure + and then + Socket_Errno = SOSC.EADDRINUSE); + Res := C_Close (W_Sock); + W_Sock := Failure; + Res := C_Close (R_Sock); + R_Sock := Failure; + end loop; + + -- Since the call to connect(2) has succeeded and the backlog limit on + -- the listening socket is 1, we know that there is now exactly one + -- pending connection on L_Sock, which is the one from R_Sock. + + W_Sock := C_Accept (L_Sock, Sin'Address, Len'Access); + + if W_Sock = Failure then + goto Fail; + end if; + + -- Set TCP_NODELAY on W_Sock, since we always want to send the data out + -- immediately. + + Set_Socket_Option + (Socket => Socket_Type (W_Sock), + Level => IP_Protocol_For_TCP_Level, + Option => (Name => No_Delay, Enabled => True)); + + -- Close listening socket (ignore exit status) + + Res := C_Close (L_Sock); + + Fds.all := (Read_End => R_Sock, Write_End => W_Sock); + + return Thin_Common.Success; + + <> + declare + Saved_Errno : constant Integer := Socket_Errno; + + begin + if W_Sock /= Failure then + Res := C_Close (W_Sock); + end if; + + if R_Sock /= Failure then + Res := C_Close (R_Sock); + end if; + + if L_Sock /= Failure then + Res := C_Close (L_Sock); + end if; + + Set_Socket_Errno (Saved_Errno); + end; + + return Failure; + end Create; + + ---------- + -- Read -- + ---------- + + function Read (Rsig : C.int) return C.int is + Buf : aliased Character; + begin + return C_Recv (Rsig, Buf'Address, 1, SOSC.MSG_Forced_Flags); + end Read; + + ----------- + -- Write -- + ----------- + + function Write (Wsig : C.int) return C.int is + Buf : aliased Character := ASCII.NUL; + begin + return C_Sendto + (Wsig, Buf'Address, 1, + Flags => SOSC.MSG_Forced_Flags, + To => System.Null_Address, + Tolen => 0); + end Write; + +end Signalling_Fds; diff --git a/gcc/ada/g-table.adb b/gcc/ada/g-table.adb new file mode 100644 index 000000000..bcc025f42 --- /dev/null +++ b/gcc/ada/g-table.adb @@ -0,0 +1,331 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T A B L E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; +with System.Memory; use System.Memory; + +with Ada.Unchecked_Conversion; + +package body GNAT.Table is + + Min : constant Integer := Integer (Table_Low_Bound); + -- Subscript of the minimum entry in the currently allocated table + + Max : Integer; + -- Subscript of the maximum entry in the currently allocated table + + Length : Integer := 0; + -- Number of entries in currently allocated table. The value of zero + -- ensures that we initially allocate the table. + + Last_Val : Integer; + -- Current value of Last + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Reallocate; + -- Reallocate the existing table according to the current value stored + -- in Max. Works correctly to do an initial allocation if the table + -- is currently null. + + pragma Warnings (Off); + -- Turn off warnings. The following unchecked conversions are only used + -- internally in this package, and cannot never result in any instances + -- of improperly aliased pointers for the client of the package. + + function To_Address is new Ada.Unchecked_Conversion (Table_Ptr, Address); + function To_Pointer is new Ada.Unchecked_Conversion (Address, Table_Ptr); + + pragma Warnings (On); + + -------------- + -- Allocate -- + -------------- + + function Allocate (Num : Integer := 1) return Table_Index_Type is + Old_Last : constant Integer := Last_Val; + + begin + Last_Val := Last_Val + Num; + + if Last_Val > Max then + Reallocate; + end if; + + return Table_Index_Type (Old_Last + 1); + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append (New_Val : Table_Component_Type) is + begin + Set_Item (Table_Index_Type (Last_Val + 1), New_Val); + end Append; + + ---------------- + -- Append_All -- + ---------------- + + procedure Append_All (New_Vals : Table_Type) is + begin + for J in New_Vals'Range loop + Append (New_Vals (J)); + end loop; + end Append_All; + + -------------------- + -- Decrement_Last -- + -------------------- + + procedure Decrement_Last is + begin + Last_Val := Last_Val - 1; + end Decrement_Last; + + ---------- + -- Free -- + ---------- + + procedure Free is + begin + Free (To_Address (Table)); + Table := null; + Length := 0; + end Free; + + -------------------- + -- Increment_Last -- + -------------------- + + procedure Increment_Last is + begin + Last_Val := Last_Val + 1; + + if Last_Val > Max then + Reallocate; + end if; + end Increment_Last; + + ---------- + -- Init -- + ---------- + + procedure Init is + Old_Length : constant Integer := Length; + + begin + Last_Val := Min - 1; + Max := Min + Table_Initial - 1; + Length := Max - Min + 1; + + -- If table is same size as before (happens when table is never + -- expanded which is a common case), then simply reuse it. Note + -- that this also means that an explicit Init call right after + -- the implicit one in the package body is harmless. + + if Old_Length = Length then + return; + + -- Otherwise we can use Reallocate to get a table of the right size. + -- Note that Reallocate works fine to allocate a table of the right + -- initial size when it is first allocated. + + else + Reallocate; + end if; + end Init; + + ---------- + -- Last -- + ---------- + + function Last return Table_Index_Type is + begin + return Table_Index_Type (Last_Val); + end Last; + + ---------------- + -- Reallocate -- + ---------------- + + procedure Reallocate is + New_Size : size_t; + + begin + if Max < Last_Val then + pragma Assert (not Locked); + + while Max < Last_Val loop + + -- Increase length using the table increment factor, but make + -- sure that we add at least ten elements (this avoids a loop + -- for silly small increment values) + + Length := Integer'Max + (Length * (100 + Table_Increment) / 100, + Length + 10); + Max := Min + Length - 1; + end loop; + end if; + + New_Size := + size_t ((Max - Min + 1) * + (Table_Type'Component_Size / Storage_Unit)); + + if Table = null then + Table := To_Pointer (Alloc (New_Size)); + + elsif New_Size > 0 then + Table := + To_Pointer (Realloc (Ptr => To_Address (Table), + Size => New_Size)); + end if; + + if Length /= 0 and then Table = null then + raise Storage_Error; + end if; + + end Reallocate; + + ------------- + -- Release -- + ------------- + + procedure Release is + begin + Length := Last_Val - Integer (Table_Low_Bound) + 1; + Max := Last_Val; + Reallocate; + end Release; + + -------------- + -- Set_Item -- + -------------- + + procedure Set_Item + (Index : Table_Index_Type; + Item : Table_Component_Type) + is + -- If Item is a value within the current allocation, and we are going to + -- reallocate, then we must preserve an intermediate copy here before + -- calling Increment_Last. Otherwise, if Table_Component_Type is passed + -- by reference, we are going to end up copying from storage that might + -- have been deallocated from Increment_Last calling Reallocate. + + subtype Allocated_Table_T is + Table_Type (Table'First .. Table_Index_Type (Max + 1)); + -- A constrained table subtype one element larger than the currently + -- allocated table. + + Allocated_Table_Address : constant System.Address := + Table.all'Address; + -- Used for address clause below (we can't use non-static expression + -- Table.all'Address directly in the clause because some older versions + -- of the compiler do not allow it). + + Allocated_Table : Allocated_Table_T; + pragma Import (Ada, Allocated_Table); + pragma Suppress (Range_Check, On => Allocated_Table); + for Allocated_Table'Address use Allocated_Table_Address; + -- Allocated_Table represents the currently allocated array, plus + -- one element (the supplementary element is used to have a + -- convenient way of computing the address just past the end of the + -- current allocation). Range checks are suppressed because this unit + -- uses direct calls to System.Memory for allocation, and this can + -- yield misaligned storage (and we cannot rely on the bootstrap + -- compiler supporting specifically disabling alignment checks, so we + -- need to suppress all range checks). It is safe to suppress this check + -- here because we know that a (possibly misaligned) object of that type + -- does actually exist at that address. + -- ??? We should really improve the allocation circuitry here to + -- guarantee proper alignment. + + Need_Realloc : constant Boolean := Integer (Index) > Max; + -- True if this operation requires storage reallocation (which may + -- involve moving table contents around). + + begin + -- If we're going to reallocate, check whether Item references an + -- element of the currently allocated table. + + if Need_Realloc + and then Allocated_Table'Address <= Item'Address + and then Item'Address < + Allocated_Table (Table_Index_Type (Max + 1))'Address + then + -- If so, save a copy on the stack because Increment_Last will + -- reallocate storage and might deallocate the current table. + + declare + Item_Copy : constant Table_Component_Type := Item; + begin + Set_Last (Index); + Table (Index) := Item_Copy; + end; + + else + -- Here we know that either we won't reallocate (case of Index < Max) + -- or that Item is not in the currently allocated table. + + if Integer (Index) > Last_Val then + Set_Last (Index); + end if; + + Table (Index) := Item; + end if; + end Set_Item; + + -------------- + -- Set_Last -- + -------------- + + procedure Set_Last (New_Val : Table_Index_Type) is + begin + if Integer (New_Val) < Last_Val then + Last_Val := Integer (New_Val); + else + Last_Val := Integer (New_Val); + + if Last_Val > Max then + Reallocate; + end if; + end if; + end Set_Last; + +begin + Init; +end GNAT.Table; diff --git a/gcc/ada/g-table.ads b/gcc/ada/g-table.ads new file mode 100644 index 000000000..3a344a532 --- /dev/null +++ b/gcc/ada/g-table.ads @@ -0,0 +1,206 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T A B L E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Resizable one dimensional array support + +-- This package provides an implementation of dynamically resizable one +-- dimensional arrays. The idea is to mimic the normal Ada semantics for +-- arrays as closely as possible with the one additional capability of +-- dynamically modifying the value of the Last attribute. + +-- This package provides a facility similar to that of GNAT.Dynamic_Tables, +-- except that this package declares a single instance of the table type, +-- while an instantiation of GNAT.Dynamic_Tables creates a type that can be +-- used to define dynamic instances of the table. + +-- Note that this interface should remain synchronized with those in +-- GNAT.Dynamic_Tables and the GNAT compiler source unit Table to keep +-- as much coherency as possible between these three related units. + +generic + type Table_Component_Type is private; + type Table_Index_Type is range <>; + + Table_Low_Bound : Table_Index_Type; + Table_Initial : Positive; + Table_Increment : Natural; + +package GNAT.Table is + pragma Elaborate_Body; + + -- Table_Component_Type and Table_Index_Type specify the type of the + -- array, Table_Low_Bound is the lower bound. Index_type must be an + -- integer type. The effect is roughly to declare: + + -- Table : array (Table_Index_Type range Table_Low_Bound .. <>) + -- of Table_Component_Type; + + -- Note: since the upper bound can be one less than the lower + -- bound for an empty array, the table index type must be able + -- to cover this range, e.g. if the lower bound is 1, then the + -- Table_Index_Type should be Natural rather than Positive. + + -- Table_Component_Type may be any Ada type, except that controlled + -- types are not supported. Note however that default initialization + -- will NOT occur for array components. + + -- The Table_Initial values controls the allocation of the table when + -- it is first allocated, either by default, or by an explicit Init call. + + -- The Table_Increment value controls the amount of increase, if the + -- table has to be increased in size. The value given is a percentage + -- value (e.g. 100 = increase table size by 100%, i.e. double it). + + -- The Last and Set_Last subprograms provide control over the current + -- logical allocation. They are quite efficient, so they can be used + -- freely (expensive reallocation occurs only at major granularity + -- chunks controlled by the allocation parameters). + + -- Note: we do not make the table components aliased, since this would + -- restrict the use of table for discriminated types. If it is necessary + -- to take the access of a table element, use Unrestricted_Access. + + -- WARNING: On HPPA, the virtual addressing approach used in this unit + -- is incompatible with the indexing instructions on the HPPA. So when + -- using this unit, compile your application with -mdisable-indexing. + + -- WARNING: If the table is reallocated, then the address of all its + -- components will change. So do not capture the address of an element + -- and then use the address later after the table may be reallocated. + -- One tricky case of this is passing an element of the table to a + -- subprogram by reference where the table gets reallocated during + -- the execution of the subprogram. The best rule to follow is never + -- to pass a table element as a parameter except for the case of IN + -- mode parameters with scalar values. + + type Table_Type is + array (Table_Index_Type range <>) of Table_Component_Type; + subtype Big_Table_Type is + Table_Type (Table_Low_Bound .. Table_Index_Type'Last); + -- We work with pointers to a bogus array type that is constrained + -- with the maximum possible range bound. This means that the pointer + -- is a thin pointer, which is more efficient. Since subscript checks + -- in any case must be on the logical, rather than physical bounds, + -- safety is not compromised by this approach. These types should never + -- be used by the client. + + type Table_Ptr is access all Big_Table_Type; + for Table_Ptr'Storage_Size use 0; + -- The table is actually represented as a pointer to allow reallocation. + -- This type should never be used by the client. + + Table : aliased Table_Ptr := null; + -- The table itself. The lower bound is the value of Low_Bound. + -- Logically the upper bound is the current value of Last (although + -- the actual size of the allocated table may be larger than this). + -- The program may only access and modify Table entries in the range + -- First .. Last. + + Locked : Boolean := False; + -- Table expansion is permitted only if this switch is set to False. A + -- client may set Locked to True, in which case any attempt to expand + -- the table will cause an assertion failure. Note that while a table + -- is locked, its address in memory remains fixed and unchanging. + + procedure Init; + -- This procedure allocates a new table of size Initial (freeing any + -- previously allocated larger table). It is not necessary to call + -- Init when a table is first instantiated (since the instantiation does + -- the same initialization steps). However, it is harmless to do so, and + -- Init is convenient in reestablishing a table for new use. + + function Last return Table_Index_Type; + pragma Inline (Last); + -- Returns the current value of the last used entry in the table, which + -- can then be used as a subscript for Table. Note that the only way to + -- modify Last is to call the Set_Last procedure. Last must always be + -- used to determine the logically last entry. + + procedure Release; + -- Storage is allocated in chunks according to the values given in the + -- Initial and Increment parameters. A call to Release releases all + -- storage that is allocated, but is not logically part of the current + -- array value. Current array values are not affected by this call. + + procedure Free; + -- Free all allocated memory for the table. A call to Init is required + -- before any use of this table after calling Free. + + First : constant Table_Index_Type := Table_Low_Bound; + -- Export First as synonym for Low_Bound (parallel with use of Last) + + procedure Set_Last (New_Val : Table_Index_Type); + pragma Inline (Set_Last); + -- This procedure sets Last to the indicated value. If necessary the + -- table is reallocated to accommodate the new value (i.e. on return + -- the allocated table has an upper bound of at least Last). If Set_Last + -- reduces the size of the table, then logically entries are removed + -- from the table. If Set_Last increases the size of the table, then + -- new entries are logically added to the table. + + procedure Increment_Last; + pragma Inline (Increment_Last); + -- Adds 1 to Last (same as Set_Last (Last + 1) + + procedure Decrement_Last; + pragma Inline (Decrement_Last); + -- Subtracts 1 from Last (same as Set_Last (Last - 1) + + procedure Append (New_Val : Table_Component_Type); + pragma Inline (Append); + -- Equivalent to: + -- x.Increment_Last; + -- x.Table (x.Last) := New_Val; + -- i.e. the table size is increased by one, and the given new item + -- stored in the newly created table element. + + procedure Append_All (New_Vals : Table_Type); + -- Appends all components of New_Vals + + procedure Set_Item + (Index : Table_Index_Type; + Item : Table_Component_Type); + pragma Inline (Set_Item); + -- Put Item in the table at position Index. The table is expanded if the + -- current table length is less than Index and in that case Last is set to + -- Index. Item will replace any value already present in the table at this + -- position. + + function Allocate (Num : Integer := 1) return Table_Index_Type; + pragma Inline (Allocate); + -- Adds Num to Last, and returns the old value of Last + 1. Note that + -- this function has the possible side effect of reallocating the table. + -- This means that a reference X.Table (X.Allocate) is incorrect, since + -- the call to X.Allocate may modify the results of calling X.Table. + +end GNAT.Table; diff --git a/gcc/ada/g-tasloc.adb b/gcc/ada/g-tasloc.adb new file mode 100644 index 000000000..92563ccf7 --- /dev/null +++ b/gcc/ada/g-tasloc.adb @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T A S K _ L O C K -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package 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 new file mode 100644 index 000000000..ce49667c8 --- /dev/null +++ b/gcc/ada/g-tasloc.ads @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T A S K _ L O C K -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2007, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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-tastus.ads b/gcc/ada/g-tastus.ads new file mode 100644 index 000000000..ccfdf456b --- /dev/null +++ b/gcc/ada/g-tastus.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . T A S K _ S T A C K _ U S A G E -- +-- -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an API to query for tasks stack usage at runtime +-- and during debug. + +-- See file s-stusta.ads for full documentation of the interface + +with System.Stack_Usage.Tasking; + +package GNAT.Task_Stack_Usage renames System.Stack_Usage.Tasking; diff --git a/gcc/ada/g-thread.adb b/gcc/ada/g-thread.adb new file mode 100644 index 000000000..94719ce9b --- /dev/null +++ b/gcc/ada/g-thread.adb @@ -0,0 +1,188 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T H R E A D S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2007, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Task_Identification; use Ada.Task_Identification; +with System.Task_Primitives.Operations; +with System.Tasking; +with System.Tasking.Stages; use System.Tasking.Stages; +with System.OS_Interface; use System.OS_Interface; +with System.Soft_Links; use System.Soft_Links; +with Ada.Unchecked_Conversion; + +package body GNAT.Threads is + + use System; + + package STPO renames System.Task_Primitives.Operations; + + type Thread_Id_Ptr is access all Thread_Id; + + pragma Warnings (Off); + -- The following unchecked conversions are aliasing safe, since they + -- are never used to create pointers to improperly aliased data. + + function To_Addr is new Ada.Unchecked_Conversion (Task_Id, Address); + function To_Id is new Ada.Unchecked_Conversion (Address, Task_Id); + function To_Id is new Ada.Unchecked_Conversion (Address, Tasking.Task_Id); + function To_Tid is new Ada.Unchecked_Conversion + (Address, Ada.Task_Identification.Task_Id); + function To_Thread is new Ada.Unchecked_Conversion (Address, Thread_Id_Ptr); + + pragma Warnings (On); + + type Code_Proc is access procedure (Id : Address; Parm : Void_Ptr); + + task type Thread + (Stsz : Natural; + Prio : Any_Priority; + Parm : Void_Ptr; + Code : Code_Proc) + is + pragma Priority (Prio); + pragma Storage_Size (Stsz); + end Thread; + + task body Thread is + begin + Code.all (To_Addr (Current_Task), Parm); + end Thread; + + type Tptr is access Thread; + + ------------------- + -- Create_Thread -- + ------------------- + + function Create_Thread + (Code : Address; + Parm : Void_Ptr; + Size : Natural; + Prio : Integer) return System.Address + is + TP : Tptr; + + function To_CP is new Ada.Unchecked_Conversion (Address, Code_Proc); + + begin + TP := new Thread (Size, Prio, Parm, To_CP (Code)); + return To_Addr (TP'Identity); + end Create_Thread; + + --------------------- + -- Register_Thread -- + --------------------- + + function Register_Thread return System.Address is + begin + return Task_Primitives.Operations.Register_Foreign_Thread.all'Address; + end Register_Thread; + + ----------------------- + -- Unregister_Thread -- + ----------------------- + + procedure Unregister_Thread is + Self_Id : constant Tasking.Task_Id := Task_Primitives.Operations.Self; + begin + Self_Id.Common.State := Tasking.Terminated; + Destroy_TSD (Self_Id.Common.Compiler_Data); + Free_Task (Self_Id); + end Unregister_Thread; + + -------------------------- + -- Unregister_Thread_Id -- + -------------------------- + + procedure Unregister_Thread_Id (Thread : System.Address) is + Thr : constant Thread_Id := To_Thread (Thread).all; + T : Tasking.Task_Id; + + use type Tasking.Task_Id; + -- This use clause should be removed once a visibility problem + -- with the MaRTE run time has been fixed. ??? + + pragma Warnings (Off); + use type System.OS_Interface.Thread_Id; + pragma Warnings (On); + + begin + STPO.Lock_RTS; + + T := Tasking.All_Tasks_List; + loop + exit when T = null or else STPO.Get_Thread_Id (T) = Thr; + + T := T.Common.All_Tasks_Link; + end loop; + + STPO.Unlock_RTS; + + if T /= null then + T.Common.State := Tasking.Terminated; + Destroy_TSD (T.Common.Compiler_Data); + Free_Task (T); + end if; + end Unregister_Thread_Id; + + -------------------- + -- Destroy_Thread -- + -------------------- + + procedure Destroy_Thread (Id : Address) is + Tid : constant Task_Id := To_Id (Id); + begin + Abort_Task (Tid); + end Destroy_Thread; + + ---------------- + -- Get_Thread -- + ---------------- + + procedure Get_Thread (Id : Address; Thread : Address) is + Thr : constant Thread_Id_Ptr := To_Thread (Thread); + begin + Thr.all := Task_Primitives.Operations.Get_Thread_Id (To_Id (Id)); + end Get_Thread; + + ---------------- + -- To_Task_Id -- + ---------------- + + function To_Task_Id + (Id : System.Address) return Ada.Task_Identification.Task_Id + is + begin + return To_Tid (Id); + end To_Task_Id; + +end GNAT.Threads; diff --git a/gcc/ada/g-thread.ads b/gcc/ada/g-thread.ads new file mode 100644 index 000000000..b5825f39f --- /dev/null +++ b/gcc/ada/g-thread.ads @@ -0,0 +1,151 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T H R E A D S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2007, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides facilities for creation or registration of foreign +-- threads for use as Ada tasks. In order to execute general Ada code, the +-- run-time system must know about all tasks. This package allows foreign +-- code, e.g. a C program, to create a thread that the Ada run-time knows +-- about, or to register the current thread. + +-- For some implementations of GNAT Pro, the registration of foreign threads +-- is automatic. However, in such implementations, if the Ada program has no +-- tasks at all and no tasking constructs other than delay, then by default +-- the non-tasking version of the Ada run-time will be loaded. If foreign +-- threads are present, it is important to ensure that the tasking version +-- of the Ada run time is loaded. This may be achieved by adding "with +-- GNAT.Threads" to any unit in the partition. + +with System; +with Ada.Task_Identification; + +package GNAT.Threads is + + type Void_Ptr is access all Integer; + + function Create_Thread + (Code : System.Address; -- pointer + Parm : Void_Ptr; -- pointer + Size : Natural; -- int + Prio : Integer) -- int + return System.Address; + pragma Export (C, Create_Thread, "__gnat_create_thread"); + -- Creates a thread with the given (Size) stack size in bytes, and + -- the given (Prio) priority. The task will execute a call to the + -- procedure whose address is given by Code. This procedure has + -- the prototype + -- + -- void thread_code (void *id, void *parm); + -- + -- where id is the id of the created task, and parm is the parameter + -- passed to Create_Thread. The called procedure is the body of the + -- code for the task, the task will be automatically terminated when + -- the procedure returns. + -- + -- This function returns the Ada Id of the created task that can then be + -- used as a parameter to the procedures below. + -- + -- C declaration: + -- + -- extern void *__gnat_create_thread + -- (void (*code)(void *, void *), void *parm, int size, int prio); + + function Register_Thread return System.Address; + pragma Export (C, Register_Thread, "__gnat_register_thread"); + -- Create an Ada task Id for the current thread if needed. + -- If the thread could not be registered, System.Null_Address is returned. + -- + -- This function returns the Ada Id of the current task that can then be + -- used as a parameter to the procedures below. + -- + -- C declaration: + -- + -- extern void *__gnat_register_thread (); + -- + -- Here is a typical usage of the Register/Unregister_Thread procedures: + -- + -- void thread_body () + -- { + -- void *task_id = __gnat_register_thread (); + -- ... thread body ... + -- __gnat_unregister_thread (); + -- } + + procedure Unregister_Thread; + pragma Export (C, Unregister_Thread, "__gnat_unregister_thread"); + -- Unregister the current task from the GNAT run time and destroy the + -- memory allocated for its task id. + -- + -- C declaration: + -- + -- extern void __gnat_unregister_thread (); + + procedure Unregister_Thread_Id (Thread : System.Address); + pragma Export (C, Unregister_Thread_Id, "__gnat_unregister_thread_id"); + -- Unregister the task associated with Thread from the GNAT run time and + -- destroy the memory allocated for its task id. + -- If no task id is associated with Thread, do nothing. + -- + -- C declaration: + -- + -- extern void __gnat_unregister_thread_id (pthread_t *thread); + + procedure Destroy_Thread (Id : System.Address); + pragma Export (C, Destroy_Thread, "__gnat_destroy_thread"); + -- This procedure may be used to prematurely abort the created thread. + -- The value Id is the value that was passed to the thread code procedure + -- at activation time. + -- + -- C declaration: + -- + -- extern void __gnat_destroy_thread (void *id); + + procedure Get_Thread (Id : System.Address; Thread : System.Address); + pragma Export (C, Get_Thread, "__gnat_get_thread"); + -- This procedure is used to retrieve the thread id of a given task. + -- The value Id is the value that was passed to the thread code procedure + -- at activation time. + -- Thread is a pointer to a thread id that will be updated by this + -- procedure. + -- + -- C declaration: + -- + -- extern void __gnat_get_thread (void *id, pthread_t *thread); + + function To_Task_Id + (Id : System.Address) + return Ada.Task_Identification.Task_Id; + -- Ada interface only. + -- Given a low level Id, as returned by Create_Thread, return a Task_Id, + -- so that operations in Ada.Task_Identification can be used. + +end GNAT.Threads; diff --git a/gcc/ada/g-timsta.adb b/gcc/ada/g-timsta.adb new file mode 100644 index 000000000..f188b68bc --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 new file mode 100644 index 000000000..094ccb5bf --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..be068d6bd --- /dev/null +++ b/gcc/ada/g-traceb.adb @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T R A C E B A C K -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2005, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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'Address, Traceback'Length, Len); + end Call_Chain; + +end GNAT.Traceback; diff --git a/gcc/ada/g-traceb.ads b/gcc/ada/g-traceb.ads new file mode 100644 index 000000000..d9f304054 --- /dev/null +++ b/gcc/ada/g-traceb.ads @@ -0,0 +1,103 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T R A C E B A C K -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1999-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 +-- HP-UX +-- GNU/Linux x86 +-- Irix MIPS +-- LynxOS x86 +-- Solaris x86 +-- Solaris sparc +-- Tru64 alpha +-- OpenVMS/Alpha +-- OpenVMS/ia64 +-- VxWorks PowerPC +-- VxWorks x86 +-- Windows NT/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-unimplemented.adb b/gcc/ada/g-trasym-unimplemented.adb new file mode 100644 index 000000000..5432eaf9d --- /dev/null +++ b/gcc/ada/g-trasym-unimplemented.adb @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Version used on unimplemented targets + +-- Run-time symbolic traceback is currently supported on the following +-- targets: + +-- HP-UX +-- IRIX +-- GNU/Linux x86 +-- AIX +-- Solaris sparc +-- Tru64 +-- OpenVMS/Alpha +-- Windows NT/XP/Vista + +-- This version is used on all other targets, it generates a warning at +-- compile time if it is with'ed, and the bodies generate messages saying +-- that the functions are not implemented. + +package body GNAT.Traceback.Symbolic is + + ------------------------ + -- Symbolic_Traceback -- + ------------------------ + + function Symbolic_Traceback (Traceback : Tracebacks_Array) return String + is + pragma Unreferenced (Traceback); + begin + return "Symbolic_Traceback not implemented on this target"; + end Symbolic_Traceback; + + function Symbolic_Traceback (E : Exception_Occurrence) return String + is + pragma Unreferenced (E); + begin + return "Symbolic_Traceback not implemented on this target"; + end Symbolic_Traceback; + +end GNAT.Traceback.Symbolic; diff --git a/gcc/ada/g-trasym-unimplemented.ads b/gcc/ada/g-trasym-unimplemented.ads new file mode 100644 index 000000000..d03db88e2 --- /dev/null +++ b/gcc/ada/g-trasym-unimplemented.ads @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Version used on unimplemented targets + +-- Run-time symbolic traceback is currently supported on the following +-- targets: + +-- HP-UX hppa and ia64 +-- IRIX +-- GNU/Linux x86, x86_64, ia64 +-- AIX +-- Solaris sparc and x86 +-- Tru64 +-- OpenVMS/Alpha +-- Windows NT/XP/Vista + +-- This version is used on all other targets, it generates a warning at +-- compile time if it is with'ed, and the bodies generate messages saying +-- that the functions are not implemented. + +with Ada.Exceptions; use Ada.Exceptions; + +package GNAT.Traceback.Symbolic is + pragma Elaborate_Body; + +-- pragma Compile_Time_Warning +-- (True, "symbolic traceback not implemented on this target"); + + function Symbolic_Traceback (Traceback : Tracebacks_Array) return String; + -- Build a string containing a symbolic traceback of the given call chain + + function Symbolic_Traceback (E : Exception_Occurrence) return String; + -- Build string containing symbolic traceback of given exception occurrence + +end GNAT.Traceback.Symbolic; diff --git a/gcc/ada/g-trasym-vms-alpha.adb b/gcc/ada/g-trasym-vms-alpha.adb new file mode 100644 index 000000000..c58c5610b --- /dev/null +++ b/gcc/ada/g-trasym-vms-alpha.adb @@ -0,0 +1,303 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Run-time symbolic traceback support for Alpha/VMS + +with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; +with Interfaces.C; +with System; +with System.Aux_DEC; +with System.Soft_Links; +with System.Traceback_Entries; + +package body GNAT.Traceback.Symbolic is + + pragma Warnings (Off); -- Needs comment ??? + pragma Linker_Options ("--for-linker=sys$library:trace.exe"); + + use Interfaces.C; + use System; + use System.Aux_DEC; + use System.Traceback_Entries; + + subtype User_Arg_Type is Unsigned_Longword; + subtype Cond_Value_Type is Unsigned_Longword; + + type ASCIC is record + Count : unsigned_char; + Data : char_array (1 .. 255); + end record; + pragma Convention (C, ASCIC); + + for ASCIC use record + Count at 0 range 0 .. 7; + Data at 1 range 0 .. 8 * 255 - 1; + end record; + for ASCIC'Size use 8 * 256; + + function Fetch_ASCIC is new Fetch_From_Address (ASCIC); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Dummy_User_Act_Proc + (Msgvec : Address := Null_Address; + Actrtn : Address := Null_Address; + Facnam : Address := Null_Address; + Actprm : User_Arg_Type := 0) return Cond_Value_Type; + -- Dummy routine with SYS$PUTMSG signature + + procedure Symbolize + (Status : out Cond_Value_Type; + Current_PC : Address; + Adjusted_PC : Address; + Current_FP : Address; + Current_R26 : Address; + Image_Name : out Address; + Module_Name : out Address; + Routine_Name : out Address; + Line_Number : out Integer; + Relative_PC : out Address; + Absolute_PC : out Address; + PC_Is_Valid : out Long_Integer; + User_Act_Proc : Address := Dummy_User_Act_Proc'Address; + User_Arg_Value : User_Arg_Type := 0); + -- Comment on above procedure required ??? + + pragma Interface (External, Symbolize); + + pragma Import_Valued_Procedure + (Symbolize, "TBK$SYMBOLIZE", + (Cond_Value_Type, Address, Address, Address, Address, + Address, Address, Address, Integer, + Address, Address, Long_Integer, + Address, User_Arg_Type), + (Value, Value, Value, Value, Value, + Reference, Reference, Reference, Reference, + Reference, Reference, Reference, + Value, Value)); + + function Decode_Ada_Name (Encoded_Name : String) return String; + -- Decodes an Ada identifier name. Removes leading "_ada_" and trailing + -- __{DIGIT}+ or ${DIGIT}+, converts other "__" to '.' + + --------------------- + -- Decode_Ada_Name -- + --------------------- + + function Decode_Ada_Name (Encoded_Name : String) return String is + Decoded_Name : String (1 .. Encoded_Name'Length); + Pos : Integer := Encoded_Name'First; + Last : Integer := Encoded_Name'Last; + DPos : Integer := 1; + + begin + if Pos > Last then + return ""; + end if; + + -- Skip leading _ada_ + + if Encoded_Name'Length > 4 + and then Encoded_Name (Pos .. Pos + 4) = "_ada_" + then + Pos := Pos + 5; + end if; + + -- Skip trailing __{DIGIT}+ or ${DIGIT}+ + + if Encoded_Name (Last) in '0' .. '9' then + for J in reverse Pos + 2 .. Last - 1 loop + case Encoded_Name (J) is + when '0' .. '9' => + null; + when '$' => + Last := J - 1; + exit; + when '_' => + if Encoded_Name (J - 1) = '_' then + Last := J - 2; + end if; + exit; + when others => + exit; + end case; + end loop; + end if; + + -- Now just copy encoded name to decoded name, converting "__" to '.' + + while Pos <= Last loop + if Encoded_Name (Pos) = '_' and then Encoded_Name (Pos + 1) = '_' + and then Pos /= Encoded_Name'First + then + Decoded_Name (DPos) := '.'; + Pos := Pos + 2; + + else + Decoded_Name (DPos) := Encoded_Name (Pos); + Pos := Pos + 1; + end if; + + DPos := DPos + 1; + end loop; + + return Decoded_Name (1 .. DPos - 1); + end Decode_Ada_Name; + + ------------------------- + -- Dummy_User_Act_Proc -- + ------------------------- + + function Dummy_User_Act_Proc + (Msgvec : Address := Null_Address; + Actrtn : Address := Null_Address; + Facnam : Address := Null_Address; + Actprm : User_Arg_Type := 0) return Cond_Value_Type + is + begin + return 0; + end Dummy_User_Act_Proc; + + ------------------------ + -- Symbolic_Traceback -- + ------------------------ + + function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is + Status : Cond_Value_Type; + Image_Name : ASCIC; + Image_Name_Addr : Address; + Module_Name : ASCIC; + Module_Name_Addr : Address; + Routine_Name : ASCIC; + Routine_Name_Addr : Address; + Line_Number : Integer; + Relative_PC : Address; + Absolute_PC : Address; + PC_Is_Valid : Long_Integer; + Return_Address : Address; + Res : String (1 .. 256 * Traceback'Length); + Len : Integer; + + begin + if Traceback'Length > 0 then + Len := 0; + + -- Since image computation is not thread-safe we need task lockout + + System.Soft_Links.Lock_Task.all; + + for J in Traceback'Range loop + Return_Address := + (if J = Traceback'Last then Address_Zero + else PC_For (Traceback (J + 1))); + + Symbolize + (Status, + PC_For (Traceback (J)), + PC_For (Traceback (J)), + PV_For (Traceback (J)), + Return_Address, + Image_Name_Addr, + Module_Name_Addr, + Routine_Name_Addr, + Line_Number, + Relative_PC, + Absolute_PC, + PC_Is_Valid); + + Image_Name := Fetch_ASCIC (Image_Name_Addr); + Module_Name := Fetch_ASCIC (Module_Name_Addr); + Routine_Name := Fetch_ASCIC (Routine_Name_Addr); + + declare + First : Integer := Len + 1; + Last : Integer := First + 80 - 1; + Pos : Integer; + Routine_Name_D : String := Decode_Ada_Name + (To_Ada + (Routine_Name.Data (1 .. size_t (Routine_Name.Count)), + False)); + + begin + Res (First .. Last) := (others => ' '); + + Res (First .. First + Integer (Image_Name.Count) - 1) := + To_Ada + (Image_Name.Data (1 .. size_t (Image_Name.Count)), + False); + + Res (First + 10 .. + First + 10 + Integer (Module_Name.Count) - 1) := + To_Ada + (Module_Name.Data (1 .. size_t (Module_Name.Count)), + False); + + Res (First + 30 .. + First + 30 + Routine_Name_D'Length - 1) := + Routine_Name_D; + + -- If routine name doesn't fit 20 characters, output + -- the line number on next line at 50th position + + if Routine_Name_D'Length > 20 then + Pos := First + 30 + Routine_Name_D'Length; + Res (Pos) := ASCII.LF; + Last := Pos + 80; + Res (Pos + 1 .. Last) := (others => ' '); + Pos := Pos + 51; + else + Pos := First + 50; + end if; + + Res (Pos .. Pos + Integer'Image (Line_Number)'Length - 1) := + Integer'Image (Line_Number); + + Res (Last) := ASCII.LF; + Len := Last; + end; + end loop; + + System.Soft_Links.Unlock_Task.all; + return Res (1 .. Len); + + else + return ""; + end if; + end Symbolic_Traceback; + + function Symbolic_Traceback (E : Exception_Occurrence) return String is + begin + return Symbolic_Traceback (Tracebacks (E)); + end Symbolic_Traceback; + +end GNAT.Traceback.Symbolic; diff --git a/gcc/ada/g-trasym-vms-ia64.adb b/gcc/ada/g-trasym-vms-ia64.adb new file mode 100644 index 000000000..897e2ebb2 --- /dev/null +++ b/gcc/ada/g-trasym-vms-ia64.adb @@ -0,0 +1,345 @@ +------------------------------------------------------------------------------ +-- -- +-- 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) 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Run-time symbolic traceback support for IA64/VMS + +with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; +with System; +with System.Aux_DEC; +with System.Soft_Links; +with System.Traceback_Entries; + +package body GNAT.Traceback.Symbolic is + + use System; + use System.Aux_DEC; + use System.Traceback_Entries; + + subtype Var_String_Buf is String (1 .. 254); + + type Var_String is record + Curlen : Unsigned_Word := 0; + Buf : Var_String_Buf; + end record; + pragma Convention (C, Var_String); + for Var_String'Size use 8 * 256; + + type Descriptor64 is record + Mbo : Unsigned_Word; + Dtype : Unsigned_Byte; + Class : Unsigned_Byte; + Mbmo : Unsigned_Longword; + Maxstrlen : Integer_64; + Pointer : Address; + end record; + pragma Convention (C, Descriptor64); + + subtype Cond_Value_Type is Unsigned_Longword; + + -- TBK_API_PARAM as defined in TBKDEF + + type Tbk_Api_Param is record + Length : Unsigned_Word; + T_Type : Unsigned_Byte; + Version : Unsigned_Byte; + Reserveda : Unsigned_Longword; + Faulting_Pc : Address; + Faulting_Fp : Address; + Filename_Desc : Address; + Library_Module_Desc : Address; + Record_Number : Address; + Image_Desc : Address; + Module_Desc : Address; + Routine_Desc : Address; + Listing_Lineno : Address; + Rel_Pc : Address; + Image_Base_Addr : Address; + Module_Base_Addr : Address; + Malloc_Rtn : Address; + Free_Rtn : Address; + Symbolize_Flags : Address; + Reserved0 : Unsigned_Quadword; + Reserved1 : Unsigned_Quadword; + Reserved2 : Unsigned_Quadword; + end record; + pragma Convention (C, Tbk_Api_Param); + + K_Version : constant Unsigned_Byte := 1; + -- Current API version + + K_Length : constant Unsigned_Word := 152; + -- Length of the parameter + + pragma Compile_Time_Error (Tbk_Api_Param'Size = K_Length * 8, + "Bad length for tbk_api_param"); + -- Sanity check + + function Symbolize (Param : Address) return Cond_Value_Type; + pragma Import (C, Symbolize, "TBK$I64_SYMBOLIZE"); + + function Decode_Ada_Name (Encoded_Name : String) return String; + -- Decodes an Ada identifier name. Removes leading "_ada_" and trailing + -- __{DIGIT}+ or ${DIGIT}+, converts other "__" to '.' + + procedure Setup_Descriptor64_Vs (Desc : out Descriptor64; Var : Address); + -- Setup descriptor Desc for address Var + + --------------------- + -- Decode_Ada_Name -- + --------------------- + + function Decode_Ada_Name (Encoded_Name : String) return String is + Decoded_Name : String (1 .. Encoded_Name'Length); + Pos : Integer := Encoded_Name'First; + Last : Integer := Encoded_Name'Last; + DPos : Integer := 1; + + begin + if Pos > Last then + return ""; + end if; + + -- Skip leading _ada_ + + if Encoded_Name'Length > 4 + and then Encoded_Name (Pos .. Pos + 4) = "_ada_" + then + Pos := Pos + 5; + end if; + + -- Skip trailing __{DIGIT}+ or ${DIGIT}+ + + if Encoded_Name (Last) in '0' .. '9' then + for J in reverse Pos + 2 .. Last - 1 loop + case Encoded_Name (J) is + when '0' .. '9' => + null; + + when '$' => + Last := J - 1; + exit; + + when '_' => + if Encoded_Name (J - 1) = '_' then + Last := J - 2; + end if; + exit; + + when others => + exit; + end case; + end loop; + end if; + + -- Now just copy encoded name to decoded name, converting "__" to '.' + + while Pos <= Last loop + if Encoded_Name (Pos) = '_' and then Encoded_Name (Pos + 1) = '_' + and then Pos /= Encoded_Name'First + then + Decoded_Name (DPos) := '.'; + Pos := Pos + 2; + else + Decoded_Name (DPos) := Encoded_Name (Pos); + Pos := Pos + 1; + end if; + + DPos := DPos + 1; + end loop; + + return Decoded_Name (1 .. DPos - 1); + end Decode_Ada_Name; + + --------------------------- + -- Setup_Descriptor64_Vs -- + --------------------------- + + procedure Setup_Descriptor64_Vs (Desc : out Descriptor64; Var : Address) is + K_Dtype_Vt : constant Unsigned_Byte := 37; + K_Class_Vs : constant Unsigned_Byte := 11; + begin + Desc.Mbo := 1; + Desc.Dtype := K_Dtype_Vt; + Desc.Class := K_Class_Vs; + Desc.Mbmo := -1; + Desc.Maxstrlen := Integer_64 (Var_String_Buf'Length); + Desc.Pointer := Var; + end Setup_Descriptor64_Vs; + + ------------------------ + -- Symbolic_Traceback -- + ------------------------ + + function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is + Param : Tbk_Api_Param; + Status : Cond_Value_Type; + Record_Number : Unsigned_Longword; + Image_Name : Var_String; + Image_Dsc : Descriptor64; + Module_Name : Var_String; + Module_Dsc : Descriptor64; + Routine_Name : Var_String; + Routine_Dsc : Descriptor64; + Line_Number : Unsigned_Longword; + Res : String (1 .. 256 * Traceback'Length); + Len : Integer; + + begin + if Traceback'Length = 0 then + return ""; + end if; + + Len := 0; + + -- Since image computation is not thread-safe we need task lockout + + System.Soft_Links.Lock_Task.all; + + -- Initialize descriptors + + Setup_Descriptor64_Vs (Image_Dsc, Image_Name'Address); + Setup_Descriptor64_Vs (Module_Dsc, Module_Name'Address); + Setup_Descriptor64_Vs (Routine_Dsc, Routine_Name'Address); + + for J in Traceback'Range loop + -- Initialize fields in case they are not written + + Record_Number := 0; + Line_Number := 0; + Image_Name.Curlen := 0; + Module_Name.Curlen := 0; + Routine_Name.Curlen := 0; + + -- Symbolize + + Param := (Length => K_Length, + T_Type => 0, + Version => K_Version, + Reserveda => 0, + Faulting_Pc => PC_For (Traceback (J)), + Faulting_Fp => 0, + Filename_Desc => Null_Address, + Library_Module_Desc => Null_Address, + Record_Number => Record_Number'Address, + Image_Desc => Image_Dsc'Address, + Module_Desc => Module_Dsc'Address, + Routine_Desc => Routine_Dsc'Address, + Listing_Lineno => Line_Number'Address, + Rel_Pc => Null_Address, + Image_Base_Addr => Null_Address, + Module_Base_Addr => Null_Address, + Malloc_Rtn => Null_Address, + Free_Rtn => Null_Address, + Symbolize_Flags => Null_Address, + Reserved0 => (0, 0), + Reserved1 => (0, 0), + Reserved2 => (0, 0)); + + Status := Symbolize (Param'Address); + + -- Check for success (marked by bit 0) + + if (Status rem 2) = 1 then + + -- Success + + if Line_Number = 0 then + + -- As GCC doesn't emit source file correlation, use record + -- number of line number is not set + + Line_Number := Record_Number; + end if; + + declare + First : constant Integer := Len + 1; + Last : Integer := First + 80 - 1; + Pos : Integer; + + Routine_Name_D : constant String := + Decode_Ada_Name + (Routine_Name.Buf + (1 .. Natural (Routine_Name.Curlen))); + + Lineno : constant String := + Unsigned_Longword'Image (Line_Number); + + begin + Res (First .. Last) := (others => ' '); + + Res (First .. First + Natural (Image_Name.Curlen) - 1) := + Image_Name.Buf (1 .. Natural (Image_Name.Curlen)); + + Res (First + 10 .. + First + 10 + Natural (Module_Name.Curlen) - 1) := + Module_Name.Buf (1 .. Natural (Module_Name.Curlen)); + + Res (First + 30 .. + First + 30 + Routine_Name_D'Length - 1) := + Routine_Name_D; + + -- If routine name doesn't fit 20 characters, output the line + -- number on next line at 50th position. + + if Routine_Name_D'Length > 20 then + Pos := First + 30 + Routine_Name_D'Length; + Res (Pos) := ASCII.LF; + Last := Pos + 80; + Res (Pos + 1 .. Last) := (others => ' '); + Pos := Pos + 51; + else + Pos := First + 50; + end if; + + Res (Pos .. Pos + Lineno'Length - 1) := Lineno; + + Res (Last) := ASCII.LF; + Len := Last; + end; + + -- Failure (bit 0 clear) + + else + Res (Len + 1 .. Len + 6) := "ERROR" & ASCII.LF; + Len := Len + 6; + end if; + end loop; + + System.Soft_Links.Unlock_Task.all; + return Res (1 .. Len); + end Symbolic_Traceback; + + function Symbolic_Traceback (E : Exception_Occurrence) return String is + begin + return Symbolic_Traceback (Tracebacks (E)); + end Symbolic_Traceback; + +end GNAT.Traceback.Symbolic; diff --git a/gcc/ada/g-trasym.adb b/gcc/ada/g-trasym.adb new file mode 100644 index 000000000..105001ddc --- /dev/null +++ b/gcc/ada/g-trasym.adb @@ -0,0 +1,154 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Run-time symbolic traceback support + +with System.Soft_Links; +with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; + +package body GNAT.Traceback.Symbolic is + + pragma Linker_Options ("-laddr2line"); + pragma Linker_Options ("-lbfd"); + pragma Linker_Options ("-liberty"); + + package TSL renames System.Soft_Links; + + -- To perform the raw addresses to symbolic form translation we rely on a + -- libaddr2line symbolizer which examines debug info from a provided + -- executable file name, and an absolute path is needed to ensure the file + -- is always found. This is "__gnat_locate_exec_on_path (gnat_argv [0])" + -- for our executable file, a fairly heavy operation so we cache the + -- result. + + Exename : System.Address; + -- Pointer to the name of the executable file to be used on all + -- invocations of the libaddr2line symbolization service. + + Exename_Resolved : Boolean := False; + -- Flag to indicate whether we have performed the executable file name + -- resolution already. Relying on a not null Exename for this purpose + -- would be potentially inefficient as this is what we will get if the + -- resolution attempt fails. + + ------------------------ + -- Symbolic_Traceback -- + ------------------------ + + function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is + + procedure convert_addresses + (filename : System.Address; + addrs : System.Address; + n_addrs : Integer; + buf : System.Address; + len : System.Address); + pragma Import (C, convert_addresses, "convert_addresses"); + -- This is the procedure version of the Ada-aware addr2line. It places + -- in BUF a string representing the symbolic translation of the N_ADDRS + -- raw addresses provided in ADDRS, looked up in debug information from + -- FILENAME. LEN points to an integer which contains the size of the + -- BUF buffer at input and the result length at output. + -- + -- This procedure is provided by libaddr2line on targets that support + -- it. A dummy version is in adaint.c for other targets so that build + -- of shared libraries doesn't generate unresolved symbols. + -- + -- Note that this procedure is *not* thread-safe. + + type Argv_Array is array (0 .. 0) of System.Address; + gnat_argv : access Argv_Array; + pragma Import (C, gnat_argv, "gnat_argv"); + + function locate_exec_on_path + (c_exename : System.Address) return System.Address; + pragma Import (C, locate_exec_on_path, "__gnat_locate_exec_on_path"); + + Res : String (1 .. 256 * Traceback'Length); + Len : Integer; + + use type System.Address; + + begin + -- The symbolic translation of an empty set of addresses is an empty + -- string. + + if Traceback'Length = 0 then + return ""; + end if; + + -- If our input set of raw addresses is not empty, resort to the + -- libaddr2line service to symbolize it all. + + -- Compute, cache and provide the absolute path to our executable file + -- name as the binary file where the relevant debug information is to be + -- found. If the executable file name resolution fails, we have no + -- sensible basis to invoke the symbolizer at all. + + -- Protect all this against concurrent accesses explicitly, as the + -- underlying services are potentially thread unsafe. + + TSL.Lock_Task.all; + + if not Exename_Resolved then + Exename := locate_exec_on_path (gnat_argv (0)); + Exename_Resolved := True; + end if; + + if Exename /= System.Null_Address then + Len := Res'Length; + convert_addresses + (Exename, Traceback'Address, Traceback'Length, + Res (1)'Address, Len'Address); + end if; + + TSL.Unlock_Task.all; + + -- Return what the addr2line symbolizer has produced if we have called + -- it (the executable name resolution succeeded), or an empty string + -- otherwise. + + if Exename /= System.Null_Address then + return Res (1 .. Len); + else + return ""; + end if; + + end Symbolic_Traceback; + + function Symbolic_Traceback (E : Exception_Occurrence) return String is + begin + return Symbolic_Traceback (Tracebacks (E)); + end Symbolic_Traceback; + +end GNAT.Traceback.Symbolic; diff --git a/gcc/ada/g-trasym.ads b/gcc/ada/g-trasym.ads new file mode 100644 index 000000000..89362318e --- /dev/null +++ b/gcc/ada/g-trasym.ads @@ -0,0 +1,96 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Run-time symbolic traceback support + +-- This capability is currently supported on the following targets: + +-- HP-UX hppa and ia64 +-- IRIX +-- GNU/Linux x86, x86_64, ia64 +-- AIX +-- Solaris sparc and x86 +-- Tru64 +-- OpenVMS/Alpha +-- Windows NT/XP/Vista + +-- 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), and load them in memory, +-- causing a significant cpu and memory overhead. + +-- On all platforms except VMS, this package is not intended to be used +-- within a shared library, symbolic tracebacks are only supported for the +-- main executable and not for shared libraries. You should consider using +-- gdb to obtain symbolic traceback in such cases. + +-- On VMS, there is no restriction on using this facility with shared +-- libraries. However, the OS should be at least v7.3-1 and OS patch +-- VMS731_TRACE-V0100 must be applied in order to use this package. + +with Ada.Exceptions; use Ada.Exceptions; + +package GNAT.Traceback.Symbolic is + pragma Elaborate_Body; + + function Symbolic_Traceback (Traceback : Tracebacks_Array) return String; + -- Build a string containing a symbolic traceback of the given call chain + -- + -- Note: This procedure may be installed by Set_Trace_Decorator, to get a + -- symbolic traceback on all exceptions raised (see GNAT.Exception_Traces). + + function Symbolic_Traceback (E : Exception_Occurrence) return String; + -- Build string containing symbolic traceback of given exception occurrence + +end GNAT.Traceback.Symbolic; diff --git a/gcc/ada/g-u3spch.adb b/gcc/ada/g-u3spch.adb new file mode 100755 index 000000000..febe0b435 --- /dev/null +++ b/gcc/ada/g-u3spch.adb @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit; + +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 new file mode 100755 index 000000000..773a253b0 --- /dev/null +++ b/gcc/ada/g-u3spch.ads @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + +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 new file mode 100644 index 000000000..3f566f1af --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..062cea457 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100755 index 000000000..0fc0ff6f2 --- /dev/null +++ b/gcc/ada/g-wispch.adb @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2007, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +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 new file mode 100755 index 000000000..09c57ed41 --- /dev/null +++ b/gcc/ada/g-wispch.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2007, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 new file mode 100644 index 000000000..7fceb17d7 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100755 index 000000000..1b7b3ff29 --- /dev/null +++ b/gcc/ada/g-zspche.adb @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2007, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +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 new file mode 100755 index 000000000..217eab6f5 --- /dev/null +++ b/gcc/ada/g-zspche.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2007, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 new file mode 100644 index 000000000..f3af56811 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..7f37381f3 --- /dev/null +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -0,0 +1,4464 @@ +# Top level -*- makefile -*- fragment for GNU Ada (GNAT). +# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, +# 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 +# Free Software Foundation, Inc. + +#This file is part of GCC. + +#GCC is free software; you can redistribute it and/or modify +#it under the terms of the GNU General Public License as published by +#the Free Software Foundation; either version 3, or (at your option) +#any later version. + +#GCC is distributed in the hope that it will be useful, +#but WITHOUT ANY WARRANTY; without even the implied warranty of +#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +#GNU General Public License for more details. + +#You should have received a copy of the GNU General Public License +#along with GCC; see the file COPYING3. If not see +#. + +# This file provides the language dependent support in the main Makefile. +# Each language makefile fragment must provide the following targets: +# +# foo.all.cross, foo.start.encap, foo.rest.encap, +# foo.install-common, foo.install-man, foo.install-info, foo.install-pdf, +# foo.install-html, foo.info, foo.dvi, foo.pdf, foo.html, foo.uninstall, +# foo.mostlyclean, foo.clean, foo.distclean, +# foo.maintainer-clean, foo.stage1, foo.stage2, foo.stage3, foo.stage4 +# +# where `foo' is the name of the language. +# +# It should also provide rules for: +# +# - making any compiler driver (eg: g++) +# - the compiler proper (eg: cc1plus) +# - define the names for selecting the language in LANGUAGES. +# tool definitions +CP = cp -p +ECHO = echo +MV = mv +MKDIR = mkdir -p +RM = rm -f +RMDIR = rm -rf + + +# Extra flags to pass to recursive makes. +COMMON_ADAFLAGS= -gnatpg -gnata +BOOT_ADAFLAGS= $(COMMON_ADAFLAGS) + +ifeq ($(CROSS),) +# If not in cross context we are probably doing a bootstrap +# so disable warnings during stage1 +ADAFLAGS= $(COMMON_ADAFLAGS) -gnatwns +else +ADAFLAGS= $(COMMON_ADAFLAGS) +endif + +ALL_ADAFLAGS = $(CFLAGS) $(ADA_CFLAGS) $(ADAFLAGS) +FORCE_DEBUG_ADAFLAGS = -g +ADA_CFLAGS = +ADA_INCLUDES = -nostdinc -I- -I. -Iada -I$(srcdir)/ada -I$(srcdir)/ada/gcc-interface +ADA_INCLUDE_DIR = $(libsubdir)/adainclude +ADA_RTL_OBJ_DIR = $(libsubdir)/adalib +ADA_FLAGS_TO_PASS = \ + "ADA_FOR_BUILD=$(ADA_FOR_BUILD)" \ + "ADA_INCLUDE_DIR=$(ADA_INCLUDE_DIR)" \ + "ADA_RTL_OBJ_DIR=$(ADA_RTL_OBJ_DIR)" \ + "ADAFLAGS=$(ADAFLAGS)" \ + "ADA_FOR_TARGET=$(ADA_FOR_TARGET)" \ + "INSTALL=$(INSTALL)" \ + "INSTALL_DATA=$(INSTALL_DATA)" \ + "INSTALL_PROGRAM=$(INSTALL_PROGRAM)" + +# Say how to compile Ada programs. +.SUFFIXES: .ada .adb .ads + +# FIXME: need to add $(ADA_CFLAGS) to .c.o suffix rule +# Use mildly strict warnings for this front end and add special flags. +ada-warn = $(ADA_CFLAGS) $(filter-out -pedantic, $(STRICT_WARN)) +# Unresolved warnings in specific files. +ada/adaint.o-warn = -Wno-error + +.adb.o: + $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) +.ads.o: + $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + +# Define the names for selecting Ada in LANGUAGES. +ada: gnat1$(exeext) gnatbind$(exeext) + +# Tell GNU Make to ignore these, if they exist. +.PHONY: ada + +# There are too many Ada sources to check against here. Let's +# always force the recursive make. +ADA_TOOLS_FLAGS_TO_PASS=\ + "CC=../../xgcc -B../../" \ + "CFLAGS=$(CFLAGS)" \ + "exeext=$(exeext)" \ + "ADAFLAGS=$(ADAFLAGS)" \ + "ADA_INCLUDES=-I../rts" \ + "GNATMAKE=../../gnatmake" \ + "GNATLINK=../../gnatlink" \ + "GNATBIND=../../gnatbind" + +GCC_LINK=$(CC) -static-libgcc $(LDFLAGS) + +# Lists of files for various purposes. + +# Languages-specific object files for Ada. +# Object files for gnat1 from C sources. +GNAT1_C_OBJS = ada/b_gnat1.o ada/adadecode.o ada/adaint.o ada/cstreams.o \ + ada/cio.o ada/targtyps.o ada/decl.o ada/misc.o ada/utils.o ada/utils2.o \ + ada/trans.o ada/cuintp.o ada/argv.o ada/raise.o ada/init.o ada/tracebak.o \ + ada/initialize.o ada/env.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-ioexce.o \ + ada/ada.o \ + ada/ali.o \ + ada/alloc.o \ + ada/aspects.o \ + ada/atree.o \ + ada/butil.o \ + ada/casing.o \ + ada/checks.o \ + ada/comperr.o \ + ada/csets.o \ + ada/cstand.o \ + ada/debug.o \ + ada/debug_a.o \ + ada/einfo.o \ + ada/elists.o \ + ada/err_vars.o \ + ada/errout.o \ + ada/erroutc.o \ + ada/eval_fat.o \ + ada/exp_aggr.o \ + ada/exp_atag.o \ + ada/exp_attr.o \ + ada/exp_cg.o \ + ada/exp_ch11.o \ + ada/exp_ch12.o \ + ada/exp_ch13.o \ + ada/exp_ch2.o \ + ada/exp_ch3.o \ + ada/exp_ch4.o \ + ada/exp_ch5.o \ + ada/exp_ch6.o \ + ada/exp_ch7.o \ + ada/exp_ch8.o \ + ada/exp_ch9.o \ + ada/exp_code.o \ + ada/exp_dbug.o \ + ada/exp_disp.o \ + ada/exp_dist.o \ + ada/exp_fixd.o \ + ada/exp_imgv.o \ + ada/exp_intr.o \ + ada/exp_pakd.o \ + ada/exp_prag.o \ + ada/exp_sel.o \ + ada/exp_smem.o \ + ada/exp_strm.o \ + ada/exp_tss.o \ + ada/exp_util.o \ + ada/exp_vfpt.o \ + ada/expander.o \ + ada/fmap.o \ + ada/fname-uf.o \ + 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/get_scos.o \ + ada/get_targ.o \ + ada/gnat.o \ + ada/gnatvsn.o \ + ada/hlo.o \ + ada/hostparm.o \ + ada/impunit.o \ + ada/inline.o \ + ada/interfac.o \ + ada/itypes.o \ + ada/krunch.o \ + ada/layout.o \ + ada/lib-load.o \ + ada/lib-util.o \ + ada/lib-writ.o \ + ada/lib-xref.o \ + ada/lib.o \ + ada/live.o \ + ada/namet-sp.o \ + ada/namet.o \ + ada/nlists.o \ + ada/nmake.o \ + ada/opt.o \ + ada/osint-c.o \ + ada/osint.o \ + ada/output.o \ + ada/par.o \ + ada/par_sco.o \ + ada/prep.o \ + ada/prepcomp.o \ + ada/put_scos.o \ + ada/repinfo.o \ + ada/restrict.o \ + ada/rident.o \ + ada/rtsfind.o \ + ada/s-addope.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-except.o \ + ada/s-exctab.o \ + ada/s-htable.o \ + ada/s-imenne.o \ + ada/s-imgenu.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-unstyp.o \ + ada/s-utf_32.o \ + ada/s-wchcnv.o \ + ada/s-wchcon.o \ + ada/s-wchjis.o \ + ada/scans.o \ + ada/scil_ll.o \ + ada/scn.o \ + ada/scng.o \ + ada/scos.o \ + ada/sdefault.o \ + ada/seh_init.o \ + ada/sem.o \ + ada/sem_aggr.o \ + ada/sem_attr.o \ + ada/sem_aux.o \ + ada/sem_case.o \ + ada/sem_cat.o \ + ada/sem_ch10.o \ + ada/sem_ch11.o \ + ada/sem_ch12.o \ + ada/sem_ch13.o \ + ada/sem_ch2.o \ + ada/sem_ch3.o \ + ada/sem_ch4.o \ + ada/sem_ch5.o \ + ada/sem_ch6.o \ + ada/sem_ch7.o \ + ada/sem_ch8.o \ + ada/sem_ch9.o \ + ada/sem_disp.o \ + ada/sem_dist.o \ + ada/sem_elab.o \ + ada/sem_elim.o \ + ada/sem_eval.o \ + ada/sem_intr.o \ + ada/sem_mech.o \ + ada/sem_prag.o \ + ada/sem_res.o \ + ada/sem_scil.o \ + ada/sem_smem.o \ + ada/sem_type.o \ + ada/sem_util.o \ + ada/sem_vfpt.o \ + ada/sem_warn.o \ + ada/sinfo-cn.o \ + ada/sinfo.o \ + ada/sinput-d.o \ + ada/sinput-l.o \ + ada/sinput.o \ + ada/snames.o \ + ada/sprint.o \ + ada/stand.o \ + ada/stringt.o \ + ada/style.o \ + ada/styleg.o \ + ada/stylesw.o \ + ada/switch-c.o \ + ada/switch.o \ + ada/system.o \ + ada/table.o \ + ada/targext.o \ + ada/targparm.o \ + ada/tbuild.o \ + ada/tree_gen.o \ + ada/tree_in.o \ + ada/tree_io.o \ + ada/treepr.o \ + ada/treeprs.o \ + ada/ttypes.o \ + ada/types.o \ + ada/uintp.o \ + ada/uname.o \ + ada/urealp.o \ + ada/usage.o \ + ada/validsw.o \ + ada/widechar.o + +# Object files for gnat executables +GNAT1_ADA_OBJS = $(GNAT_ADA_OBJS) ada/back_end.o ada/gnat1drv.o + +GNAT1_OBJS = $(GNAT1_C_OBJS) $(GNAT1_ADA_OBJS) $(EXTRA_GNAT1_OBJS) + +GNATBIND_OBJS = \ + ada/adaint.o \ + ada/argv.o \ + ada/exit.o \ + ada/cio.o \ + ada/cstreams.o \ + ada/env.o \ + ada/final.o \ + ada/init.o \ + ada/initialize.o \ + ada/seh_init.o \ + ada/link.o \ + ada/targext.o \ + ada/raise.o \ + ada/tracebak.o \ + ada/ada.o \ + ada/a-clrefi.o \ + ada/a-comlin.o \ + ada/a-elchha.o \ + ada/a-except.o \ + ada/ali-util.o \ + ada/ali.o \ + ada/alloc.o \ + ada/aspects.o \ + ada/atree.o \ + ada/bcheck.o \ + ada/binde.o \ + ada/binderr.o \ + ada/bindgen.o \ + ada/bindusg.o \ + ada/butil.o \ + ada/casing.o \ + ada/csets.o \ + ada/debug.o \ + ada/einfo.o \ + ada/elists.o \ + ada/err_vars.o \ + ada/errout.o \ + ada/erroutc.o \ + ada/fmap.o \ + ada/fname.o \ + ada/g-hesora.o \ + ada/g-htable.o \ + ada/s-os_lib.o \ + ada/s-string.o \ + ada/gnat.o \ + ada/gnatbind.o \ + ada/gnatvsn.o \ + ada/hostparm.o \ + ada/interfac.o \ + ada/lib.o \ + ada/namet.o \ + ada/nlists.o \ + ada/opt.o \ + ada/osint-b.o \ + ada/osint.o \ + ada/output.o \ + ada/rident.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-except.o \ + ada/s-exctab.o \ + ada/s-htable.o \ + ada/s-imenne.o \ + ada/s-imgenu.o \ + ada/s-mastop.o \ + ada/s-memory.o \ + ada/s-parame.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-strops.o \ + ada/s-traceb.o \ + ada/s-traent.o \ + ada/s-unstyp.o \ + ada/s-utf_32.o \ + ada/s-wchcnv.o \ + ada/s-wchcon.o \ + ada/s-wchjis.o \ + ada/scng.o \ + ada/scans.o \ + ada/scil_ll.o \ + ada/sdefault.o \ + ada/sem_aux.o \ + ada/sinfo.o \ + ada/sinput.o \ + ada/sinput-c.o \ + ada/snames.o \ + ada/stand.o \ + ada/stringt.o \ + ada/switch-b.o \ + ada/switch.o \ + ada/style.o \ + ada/styleg.o \ + ada/stylesw.o \ + ada/system.o \ + ada/table.o \ + ada/targparm.o \ + ada/tree_io.o \ + ada/types.o \ + ada/uintp.o \ + ada/uname.o \ + ada/urealp.o \ + ada/widechar.o \ + $(EXTRA_GNATBIND_OBJS) + +# List of extra object files linked in with various programs. +EXTRA_GNAT1_OBJS = prefix.o +EXTRA_GNATBIND_OBJS = prefix.o version.o + +# Language-independent object files. +ADA_BACKEND = $(BACKEND) attribs.o + +# List of target dependent sources, overridden below as necessary +TARGET_ADA_SRCS = + +# Needs to be built with CC=gcc +# Since the RTL should be built with the latest compiler, remove the +# stamp target in the parent directory whenever gnat1 is rebuilt +gnat1$(exeext): $(TARGET_ADA_SRCS) $(GNAT1_OBJS) $(ADA_BACKEND) $(LIBDEPS) + +$(GCC_LINK) -o $@ $(GNAT1_OBJS) $(ADA_BACKEND) $(LIBS) $(SYSLIBS) $(BACKENDLIBS) $(CFLAGS) + $(RM) stamp-gnatlib2-rts stamp-tools + +gnatbind$(exeext): ada/b_gnatb.o $(CONFIG_H) $(GNATBIND_OBJS) + +$(GCC_LINK) -o $@ ada/b_gnatb.o $(GNATBIND_OBJS) $(LIBS) $(SYSLIBS) $(CFLAGS) + +# use cross-gcc +gnat-cross: force + make $(GNAT1_ADA_OBJS) CC="gcc -B../stage1/" CFLAGS="-S -gnatp" \ + $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) HOST_CFLAGS= HOST_CC=cc + +# Build hooks: + +ada.all.cross: + -if [ -f gnatbind$(exeext) ] ; \ + then \ + $(MV) gnatbind$(exeext) gnatbind-cross$(exeext); \ + fi + -if [ -f gnatchop$(exeext) ] ; \ + then \ + $(MV) gnatchop$(exeext) gnatchop-cross$(exeext); \ + fi + -if [ -f gnat$(exeext) ] ; \ + then \ + $(MV) gnat$(exeext) gnat-cross$(exeext); \ + fi + -if [ -f gnatkr$(exeext) ] ; \ + then \ + $(MV) gnatkr$(exeext) gnatkr-cross$(exeext); \ + fi + -if [ -f gnatlink$(exeext) ] ; \ + then \ + $(MV) gnatlink$(exeext) gnatlink-cross$(exeext); \ + fi + -if [ -f gnatls$(exeext) ] ; \ + then \ + $(MV) gnatls$(exeext) gnatls-cross$(exeext); \ + fi + -if [ -f gnatmake$(exeext) ] ; \ + then \ + $(MV) gnatmake$(exeext) gnatmake-cross$(exeext); \ + fi + -if [ -f gnatname$(exeext) ] ; \ + then \ + $(MV) gnatname$(exeext) gnatname-cross$(exeext); \ + fi + -if [ -f gnatprep$(exeext) ] ; \ + then \ + $(MV) gnatprep$(exeext) gnatprep-cross$(exeext); \ + fi + -if [ -f gnatxref$(exeext) ] ; \ + then \ + $(MV) gnatxref$(exeext) gnatxref-cross$(exeext); \ + fi + -if [ -f gnatfind$(exeext) ] ; \ + then \ + $(MV) gnatfind$(exeext) gnatfind-cross$(exeext); \ + fi + -if [ -f gnatclean$(exeext) ] ; \ + then \ + $(MV) gnatclean$(exeext) gnatclean-cross$(exeext); \ + fi + -if [ -f gnatsym$(exeext) ] ; \ + then \ + $(MV) gnatsym$(exeext) gnatsym-cross$(exeext); \ + fi + +ada.start.encap: +ada.rest.encap: +ada.man: +ada.srcextra: +ada.srcman: + +ada.tags: force + cd $(srcdir)/ada && etags -o TAGS.sub *.c *.h *.ads *.adb && \ + etags --include TAGS.sub --include ../TAGS.sub + + +# Generate documentation. + +ada/doctools/xgnatugn$(build_exeext): ada/xgnatugn.adb + -$(MKDIR) ada/doctools + $(CP) $^ ada/doctools + cd ada/doctools && $(GNATMAKE) -q xgnatugn + +# Note that doc/gnat_ugn.texi and doc/projects.texi do not depend on +# xgnatugn being built so we can distribute a pregenerated doc/gnat_ugn.info + +doc/gnat_ugn.texi: $(srcdir)/ada/gnat_ugn.texi $(srcdir)/ada/ug_words \ + doc/projects.texi $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi + ada/doctools/xgnatugn unw $(srcdir)/ada/gnat_ugn.texi \ + $(srcdir)/ada/ug_words doc/gnat_ugn.texi + +doc/projects.texi: $(srcdir)/ada/projects.texi + $(MAKE) ada/doctools/xgnatugn$(build_exeext) + ada/doctools/xgnatugn unw $(srcdir)/ada/projects.texi \ + $(srcdir)/ada/ug_words doc/projects.texi + +doc/gnat_ugn.info: doc/gnat_ugn.texi \ + $(gcc_docdir)/include/fdl.texi $(gcc_docdir)/include/gcc-common.texi \ + gcc-vers.texi + if [ x$(BUILD_INFO) = xinfo ]; then \ + rm -f $(@)*; \ + $(MAKEINFO) $(MAKEINFOFLAGS) -I$(gcc_docdir)/include \ + -I$(srcdir)/ada -o $@ $<; \ + else true; fi + +doc/gnat_rm.info: ada/gnat_rm.texi $(gcc_docdir)/include/fdl.texi \ + $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi + if [ x$(BUILD_INFO) = xinfo ]; then \ + rm -f $(@)*; \ + $(MAKEINFO) $(MAKEINFOFLAGS) -I$(gcc_docdir)/include \ + -I$(srcdir)/ada -o $@ $<; \ + else true; fi + +doc/gnat-style.info: ada/gnat-style.texi $(gcc_docdir)/include/fdl.texi \ + $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi + if [ x$(BUILD_INFO) = xinfo ]; then \ + rm -f $(@)*; \ + $(MAKEINFO) $(MAKEINFOFLAGS) -I$(gcc_docdir)/include \ + -I$(srcdir)/ada -o $@ $<; \ + else true; fi + +ADA_INFOFILES = doc/gnat_ugn.info doc/gnat_ugn.texi \ + doc/gnat_rm.info doc/gnat-style.info + +ada.info: $(ADA_INFOFILES) + +ada.srcinfo: $(ADA_INFOFILES) + -$(CP) $^ $(srcdir)/doc + +ada.install-info: $(DESTDIR)$(infodir)/gnat_ugn.info \ + $(DESTDIR)$(infodir)/gnat_rm.info \ + $(DESTDIR)$(infodir)/gnat-style.info + +ada.dvi: doc/gnat_ugn.dvi \ + doc/gnat_rm.dvi doc/gnat-style.dvi + +ADA_PDFFILES = doc/gnat_ugn.pdf \ + doc/gnat_rm.pdf doc/gnat-style.pdf + +ada.pdf: $(ADA_PDFFILES) + +ada.install-pdf: $(ADA_PDFFILES) + @$(NORMAL_INSTALL) + test -z "$(pdfdir)/gcc" || $(mkinstalldirs) "$(DESTDIR)$(pdfdir)/gcc" + @list='$(ADA_PDFFILES)'; for p in $$list; do \ + if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ + f=$(pdf__strip_dir) \ + echo " $(INSTALL_DATA) '$$d$$p' '$(DESTDIR)$(pdfdir)/gcc/$$f'"; \ + $(INSTALL_DATA) "$$d$$p" "$(DESTDIR)$(pdfdir)/gcc/$$f"; \ + done + +ada.html: + +ada.install-html: + +doc/gnat_ugn.dvi: doc/gnat_ugn.texi $(gcc_docdir)/include/fdl.texi \ + $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi + $(TEXI2DVI) -c -I $(abs_docdir)/include -o $@ $< + +doc/gnat_rm.dvi: ada/gnat_rm.texi $(gcc_docdir)/include/fdl.texi \ + $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi + $(TEXI2DVI) -c -I $(abs_docdir)/include -o $@ $< + +doc/gnat-style.dvi: ada/gnat-style.texi $(gcc_docdir)/include/fdl.texi + $(TEXI2DVI) -c -I $(abs_docdir)/include -o $@ $< + +doc/gnat_ugn.pdf: doc/gnat_ugn.texi $(gcc_docdir)/include/fdl.texi \ + $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi + $(TEXI2PDF) -c -I $(abs_docdir)/include -o $@ $< + +doc/gnat_rm.pdf: ada/gnat_rm.texi $(gcc_docdir)/include/fdl.texi \ + $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi + $(TEXI2PDF) -c -I $(abs_docdir)/include -o $@ $< + +doc/gnat-style.pdf: ada/gnat-style.texi $(gcc_docdir)/include/fdl.texi + $(TEXI2PDF) -c -I $(abs_docdir)/include -o $@ $< + + +# Install hooks: +# gnat1 is installed elsewhere as part of $(COMPILERS). + +# Install the binder program as $(target_noncanonical)-gnatbind +# and also as either gnatbind (if native) or $(tooldir)/bin/gnatbind +# likewise for gnatf, gnatchop, and gnatlink, gnatkr, gnatmake, gnat, +# gnatprep, gnatls, gnatxref, gnatfind, gnatname, gnatclean, +# gnatsym +ada.install-common: + $(MKDIR) $(DESTDIR)$(bindir) + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatbind-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatbind$(exeext); \ + $(INSTALL_PROGRAM) gnatbind-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatbind$(exeext); \ + if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ + rm -f $(DESTDIR)$(tooldir)/bin/gnatbind$(exeext); \ + $(INSTALL_PROGRAM) gnatbind-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnatbind$(exeext); \ + fi; \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnatbind$(exeext); \ + $(INSTALL_PROGRAM) gnatbind$(exeext) $(DESTDIR)$(bindir)/gnatbind$(exeext); \ + fi ; \ + fi + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatchop-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatchop$(exeext); \ + $(INSTALL_PROGRAM) gnatchop-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatchop$(exeext); \ + if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ + rm -f $(DESTDIR)$(tooldir)/bin/gnatchop$(exeext); \ + $(INSTALL_PROGRAM) gnatchop-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnatchop$(exeext); \ + fi ; \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnatchop$(exeext); \ + $(INSTALL_PROGRAM) gnatchop$(exeext) $(DESTDIR)$(bindir)/gnatchop$(exeext); \ + fi ; \ + fi + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnat-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnat$(exeext); \ + $(INSTALL_PROGRAM) gnat-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnat$(exeext); \ + if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ + rm -f $(DESTDIR)$(tooldir)/bin/gnat$(exeext); \ + $(INSTALL_PROGRAM) gnat-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnat$(exeext); \ + fi; \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnat$(exeext); \ + $(INSTALL_PROGRAM) gnat$(exeext) $(DESTDIR)$(bindir)/gnat$(exeext); \ + fi ; \ + fi + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatkr-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatkr$(exeext); \ + $(INSTALL_PROGRAM) gnatkr-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatkr$(exeext); \ + if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ + rm -f $(DESTDIR)$(tooldir)/bin/gnatkr$(exeext); \ + $(INSTALL_PROGRAM) gnatkr-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnatkr$(exeext); \ + fi; \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnatkr$(exeext); \ + $(INSTALL_PROGRAM) gnatkr$(exeext) $(DESTDIR)$(bindir)/gnatkr$(exeext); \ + fi ; \ + fi + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatlink-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatlink$(exeext); \ + $(INSTALL_PROGRAM) gnatlink-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatlink$(exeext); \ + if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ + rm -f $(DESTDIR)$(tooldir)/bin/gnatlink$(exeext); \ + $(INSTALL_PROGRAM) gnatlink-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnatlink$(exeext); \ + fi; \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnatlink$(exeext); \ + $(INSTALL_PROGRAM) gnatlink$(exeext) $(DESTDIR)$(bindir)/gnatlink$(exeext); \ + fi ; \ + fi + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatls-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatls$(exeext); \ + $(INSTALL_PROGRAM) gnatls-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatls$(exeext); \ + if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ + rm -f $(DESTDIR)$(tooldir)/bin/gnatls$(exeext); \ + $(INSTALL_PROGRAM) gnatls-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnatls$(exeext); \ + fi; \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnatls$(exeext); \ + $(INSTALL_PROGRAM) gnatls$(exeext) $(DESTDIR)$(bindir)/gnatls$(exeext); \ + fi ; \ + fi + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatmake-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatmake$(exeext); \ + $(INSTALL_PROGRAM) gnatmake-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatmake$(exeext); \ + if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ + rm -f $(DESTDIR)$(tooldir)/bin/gnatmake$(exeext); \ + $(INSTALL_PROGRAM) gnatmake-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnatmake$(exeext); \ + fi; \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnatmake$(exeext); \ + $(INSTALL_PROGRAM) gnatmake$(exeext) $(DESTDIR)$(bindir)/gnatmake$(exeext); \ + fi ; \ + fi + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatname-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatname$(exeext); \ + $(INSTALL_PROGRAM) gnatname-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatname$(exeext); \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnatname$(exeext); \ + $(INSTALL_PROGRAM) gnatname$(exeext) $(DESTDIR)$(bindir)/gnatname$(exeext); \ + fi ; \ + fi + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatprep-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatprep$(exeext); \ + $(INSTALL_PROGRAM) gnatprep-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatprep$(exeext); \ + if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \ + rm -f $(DESTDIR)$(tooldir)/bin/gnatprep$(exeext); \ + $(INSTALL_PROGRAM) gnatprep-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnatprep$(exeext); \ + fi; \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnatprep$(exeext); \ + $(INSTALL_PROGRAM) gnatprep$(exeext) $(DESTDIR)$(bindir)/gnatprep$(exeext); \ + fi ; \ + fi + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatxref-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatxref$(exeext); \ + $(INSTALL_PROGRAM) gnatxref-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatxref$(exeext); \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnatxref$(exeext); \ + $(INSTALL_PROGRAM) gnatxref$(exeext) $(DESTDIR)$(bindir)/gnatxref$(exeext); \ + fi ; \ + fi + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatfind-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatfind$(exeext); \ + $(INSTALL_PROGRAM) gnatfind-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatfind$(exeext); \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnatfind$(exeext); \ + $(INSTALL_PROGRAM) gnatfind$(exeext) $(DESTDIR)$(bindir)/gnatfind$(exeext); \ + fi ; \ + fi + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatclean-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatclean$(exeext); \ + $(INSTALL_PROGRAM) gnatclean-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatclean$(exeext); \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnatclean$(exeext); \ + $(INSTALL_PROGRAM) gnatclean$(exeext) $(DESTDIR)$(bindir)/gnatclean$(exeext); \ + fi ; \ + fi +# +# Gnatsym is only built on some platforms, including VMS +# + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f gnatsym-cross$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatsym$(exeext); \ + $(INSTALL_PROGRAM) gnatsym-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatsym$(exeext); \ + else \ + $(RM) $(DESTDIR)$(bindir)/gnatsym$(exeext); \ + $(INSTALL_PROGRAM) gnatsym$(exeext) $(DESTDIR)$(bindir)/gnatsym$(exeext); \ + fi ; \ + fi +# +# Gnatdll is only used on Windows. +# + -if [ -f gnat1$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/gnatdll$(exeext); \ + $(INSTALL_PROGRAM) gnatdll$(exeext) $(DESTDIR)$(bindir)/gnatdll$(exeext); \ + fi +# +# vxaddr2line is only used for cross ports (it calls the underlying cross +# addr2line). +# + -if [ -f gnat1$(exeext) ] ; \ + then \ + if [ -f vxaddr2line$(exeext) ] ; \ + then \ + $(RM) $(DESTDIR)$(bindir)/vxaddr2line$(exeext); \ + $(INSTALL_PROGRAM) vxaddr2line$(exeext) $(DESTDIR)$(bindir)/vxaddr2line$(exeext); \ + fi ; \ + fi + +# +# Finally, install the library +# + -if [ -f gnat1$(exeext) ] ; \ + then \ + $(MAKE) $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) install-gnatlib; \ + fi + +install-gnatlib: + $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) install-gnatlib$(LIBGNAT_TARGET) + +install-gnatlib-obj: + $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) install-gnatlib-obj + +ada.install-man: +ada.install-plugin: + +ada.uninstall: + -$(RM) $(DESTDIR)$(bindir)/gnatbind$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatchop$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnat$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatfind$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatdll$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatkr$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatlink$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatls$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatmake$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatname$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatprep$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatxref$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatclean$(exeext) + -$(RM) $(DESTDIR)$(bindir)/gnatsym$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatbind$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatchop$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnat$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatfind$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatdll$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatkr$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatlink$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatls$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatmake$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatname$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatprep$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatxref$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatclean$(exeext) + -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatsym$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatbind$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatchop$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnat$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatfind$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatdll$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatkr$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatlink$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatls$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatmake$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatname$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatprep$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatxref$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatclean$(exeext) + -$(RM) $(DESTDIR)$(tooldir)/bin/gnatsym$(exeext) +# Gnatchop is only used on VMS + -$(RM) $(DESTDIR)$(bindir)/gnatchop$(exeext) + +# Clean hooks: +# A lot of the ancillary files are deleted by the main makefile. +# We just have to delete files specific to us. + +ada.mostlyclean: + -$(RM) ada/*$(objext) ada/*.ali ada/b_*.c + -$(RM) ada/*$(coverageexts) + -$(RM) ada/sdefault.adb ada/stamp-sdefault ada/stamp-snames + -$(RMDIR) ada/tools +ada.clean: +ada.distclean: + -$(RM) ada/Makefile + -$(RM) gnatchop$(exeext) + -$(RM) gnat$(exeext) + -$(RM) gnatdll$(exeext) + -$(RM) gnatkr$(exeext) + -$(RM) gnatlink$(exeext) + -$(RM) gnatls$(exeext) + -$(RM) gnatmake$(exeext) + -$(RM) gnatname$(exeext) + -$(RM) gnatprep$(exeext) + -$(RM) gnatfind$(exeext) + -$(RM) gnatxref$(exeext) + -$(RM) gnatclean$(exeext) + -$(RM) gnatsym$(exeext) + -$(RM) ada/rts/* + -$(RMDIR) ada/rts + -$(RM) ada/tools/* + -$(RMDIR) ada/tools +ada.maintainer-clean: + -$(RM) ada/sinfo.h + -$(RM) ada/einfo.h + -$(RM) ada/nmake.adb + -$(RM) ada/nmake.ads + -$(RM) ada/treeprs.ads + -$(RM) ada/snames.ads ada/snames.adb ada/snames.h + +# Stage hooks: +# The main makefile has already created stage?/ada + +ada.stage1: stage1-start + -$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stage1/ada + -$(MV) ada/stamp-* stage1/ada +ada.stage2: stage2-start + -$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stage2/ada + -$(MV) ada/stamp-* stage2/ada +ada.stage3: stage3-start + -$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stage3/ada + -$(MV) ada/stamp-* stage3/ada +ada.stage4: stage4-start + -$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stage4/ada + -$(MV) ada/stamp-* stage4/ada +ada.stageprofile: stageprofile-start + -$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stageprofile/ada + -$(MV) ada/stamp-* stageprofile/ada +ada.stagefeedback: stagefeedback-start + -$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stagefeedback/ada + -$(MV) ada/stamp-* stagefeedback/ada + +lang_checks += check-gnat + +check-ada: check-acats check-gnat +check-ada-subtargets: check-acats-subtargets check-gnat-subtargets + +ACATSDIR = $(TESTSUITEDIR)/ada/acats + +check_acats_targets = $(patsubst %,check-acats%, 0 1 2) + +check-acats: + @test -d $(ACATSDIR) || mkdir -p $(ACATSDIR); \ + rootme=`${PWD_COMMAND}`; export rootme; \ + EXPECT=$(EXPECT); export EXPECT; \ + if [ -z "$(CHAPTERS)" ] && [ "$(filter -j, $(MFLAGS))" = "-j" ]; \ + then \ + $(MAKE) $(check_acats_targets); \ + for idx in 0 1 2; do \ + mv -f $(ACATSDIR)$$idx/acats.sum $(ACATSDIR)$$idx/acats.sum.sep; \ + mv -f $(ACATSDIR)$$idx/acats.log $(ACATSDIR)$$idx/acats.log.sep; \ + done; \ + $(SHELL) $(srcdir)/../contrib/dg-extract-results.sh \ + $(ACATSDIR)0/acats.sum.sep $(ACATSDIR)1/acats.sum.sep \ + $(ACATSDIR)2/acats.sum.sep > $(ACATSDIR)/acats.sum; \ + $(SHELL) $(srcdir)/../contrib/dg-extract-results.sh -L \ + $(ACATSDIR)0/acats.log.sep $(ACATSDIR)1/acats.log.sep \ + $(ACATSDIR)2/acats.log.sep > $(ACATSDIR)/acats.log; \ + exit 0; \ + fi; \ + testdir=`cd ${srcdir}/${ACATSDIR} && ${PWD_COMMAND}`; \ + export testdir; cd $(ACATSDIR) && $(SHELL) $${testdir}/run_acats $(CHAPTERS) + +check-acats-subtargets: + @echo $(check_acats_targets) + +# Parallelized check-acats +$(check_acats_targets): check-acats%: + test -d $(ACATSDIR)$* || mkdir -p $(ACATSDIR)$*; \ + testdir=`cd ${srcdir}/${ACATSDIR} && ${PWD_COMMAND}`; \ + case "$*" in \ + 0) chapters="`cd $$testdir/tests; echo [a-b]* c[0-4]*`";; \ + 1) chapters="`cd $$testdir/tests; echo c[5-9ab]*`";; \ + 2) chapters="`cd $$testdir/tests; echo c[c-z]* [d-z]*`";; \ + esac; \ + export testdir; cd $(ACATSDIR)$* && $(SHELL) $${testdir}/run_acats $$chapters + +.PHONY: check-acats $(check_acats_targets) + + +# Bootstrapping targets for just GNAT - use the same stage directories +gnatboot: force + -$(RM) gnatboot3 + $(MAKE) gnat1$(exeext) gnatbind$(exeext) CC="$(CC)" \ + CFLAGS="$(CFLAGS)" + $(MAKE) gnatboot2 BOOT_CFLAGS="$(BOOT_CFLAGS)" \ + BOOT_ADAFLAGS="$(BOOT_ADAFLAGS)" \ + LDFLAGS="$(BOOT_LDFLAGS)" + +gnatboot2: force + $(MAKE) gnatstage1 + $(MAKE) gnat1$(exeext) gnatbind$(exeext) CC="gcc -B../stage1/"\ + CFLAGS="$(BOOT_CFLAGS)" \ + ADAFLAGS="$(BOOT_ADAFLAGS)"\ + LDFLAGS="$(BOOT_LDFLAGS)" \ + GNATBIND="../stage1/gnatbind" + $(MAKE) gnatboot3 BOOT_CFLAGS="$(BOOT_CFLAGS)" \ + BOOT_ADAFLAGS="$(BOOT_ADAFLAGS)" \ + LDFLAGS="$(BOOT_LDFLAGS)" + +gnatboot3: + $(MAKE) gnatstage2 + $(MAKE) gnat1$(exeext) gnatbind$(exeext) CC="gcc -B../stage2/"\ + CFLAGS="$(BOOT_CFLAGS)" \ + ADAFLAGS="$(BOOT_ADAFLAGS)"\ + LDFLAGS="$(BOOT_LDFLAGS)" \ + GNATBIND="../stage2/gnatbind" + +gnatstage1: force + -$(MKDIR) stage1 + -$(MKDIR) stage1/ada + -$(MV) gnat1$(exeext) gnatbind$(exeext) stage1 + -$(MV) ada/*$(objext) ada/*.ali stage1/ada + -$(MV) ada/stamp-* stage1/ada + +gnatstage2: force + -$(MKDIR) stage2 + -$(MKDIR) stage2/ada + -$(MV) gnat1$(exeext) gnatbind$(exeext) stage2 + -$(MV) ada/*$(objext) ada/*.ali stage2/ada + -$(MV) ada/stamp-* stage2/ada + +# Compiling object files from source files. + +# Note that dependencies on obstack.h are not written +# because that file is not part of GCC. +# Dependencies on gvarargs.h are not written +# because all that file does, when not compiling with GCC, +# is include the system varargs.h. + +# Ada language specific files. + +ada/b_gnat1.c : $(GNAT1_ADA_OBJS) + $(GNATBIND) -C $(ADA_INCLUDES) -o ada/b_gnat1.c -n ada/gnat1drv.ali +ada/b_gnat1.o : ada/b_gnat1.c + +ada/b_gnatb.c : $(GNATBIND_OBJS) ada/gnatbind.o ada/interfac.o + $(GNATBIND) -C $(ADA_INCLUDES) -o ada/b_gnatb.c ada/gnatbind.ali +ada/b_gnatb.o : ada/b_gnatb.c + +include $(srcdir)/ada/Make-generated.in + +update-sources : ada/treeprs.ads ada/einfo.h ada/sinfo.h ada/nmake.adb \ + ada/nmake.ads + $(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/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_TREE_H = ada/gcc-interface/ada-tree.h + +# force debugging information on s-tasdeb.o so that it is always +# possible to set conditional breakpoints on tasks. + +ada/s-tasdeb.o : ada/s-tasdeb.adb ada/s-tasdeb.ads + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) \ + $< $(OUTPUT_OPTION) + +# force debugging information on s-vaflop.o so that it is always +# possible to call the VAX float debug print routines. +# force at least -O so that the inline assembly works. + +ada/s-vaflop.o : ada/s-vaflop.adb ada/s-vaflop.ads + $(CC) -c -O $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(ADA_INCLUDES) \ + $(OUTPUT_OPTION) $< + +# force debugging information on a-except.o so that it is always +# possible to set conditional breakpoints on exceptions. +# use -O1 otherwise gdb isn't able to get a full backtrace on mips targets. + +ada/a-except.o : ada/a-except.adb ada/a-except.ads + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O1 -fno-inline \ + $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + +# compile s-except.o without optimization and with debug info to let the +# debugger set breakpoints and inspect subprogram parameters on exception +# related events. + +ada/s-except.o : ada/s-except.adb ada/s-except.ads + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \ + $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + +# force debugging information on s-assert.o so that it is always +# possible to set breakpoint on assert failures. + +ada/s-assert.o : ada/s-assert.adb ada/s-assert.ads ada/a-except.ads + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O2 \ + $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + +# 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) + +ada/mdll-fil.o : ada/mdll-fil.adb ada/mdll.ads ada/mdll-fil.ads + $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(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) + +# force debugging information and no optimization on s-memory.o so that it +# is always possible to set breakpoint on __gnat_malloc and __gnat_free +# this is important for gnatmem using GDB. memtrack.o is built from +# memtrack.adb, and used by the post-mortem analysis with gnatmem. + +ada/s-memory.o : ada/s-memory.adb ada/s-memory.ads + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \ + $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + +ada/memtrack.o : ada/memtrack.adb ada/s-memory.ads + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \ + $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + +ada/adadecode.o : ada/adadecode.c $(CONFIG_H) $(SYSTEM_H) ada/adadecode.h +ada/adaint.o : ada/adaint.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h +ada/argv.o : ada/argv.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h +ada/cstreams.o : ada/cstreams.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h +ada/exit.o : ada/exit.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h +ada/final.o : ada/final.c $(CONFIG_H) $(SYSTEM_H) ada/raise.h +ada/link.o : ada/link.c + + +ada/targext.o : ada/targext.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) + $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) \ + $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) + +ada/cio.o : ada/cio.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h + $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) \ + $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) + +ada/init.o : ada/init.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h ada/raise.h + $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) \ + $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) + +ada/initialize.o : ada/initialize.c + $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) \ + $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) + +ada/raise.o : ada/raise.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h ada/raise.h + $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) \ + $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) + +# Need to keep the frame pointer to unwind the stack properly for some targets. +ada/tracebak.o : ada/tracebak.c $(CONFIG_H) $(SYSTEM_H) + $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) $(ALL_CPPFLAGS) \ + $(INCLUDES) -fno-omit-frame-pointer $< $(OUTPUT_OPTION) + +ada/cuintp.o : ada/gcc-interface/cuintp.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ + $(TM_H) $(TREE_H) ada/gcc-interface/ada.h ada/types.h ada/uintp.h \ + ada/atree.h ada/elists.h ada/nlists.h ada/stringt.h ada/fe.h $(ADA_TREE_H) \ + ada/gcc-interface/gigi.h + $(COMPILER) -c $(ALL_COMPILERFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ + +ada/decl.o : ada/gcc-interface/decl.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ + $(TM_H) $(TREE_H) $(FLAGS_H) toplev.h $(TARGET_H) $(TREE_INLINE_H) \ + ada/gcc-interface/ada.h ada/types.h ada/atree.h \ + ada/elists.h ada/namet.h ada/nlists.h ada/repinfo.h ada/snames.h \ + ada/stringt.h ada/uintp.h ada/fe.h ada/sinfo.h ada/einfo.h $(ADA_TREE_H) \ + ada/gcc-interface/gigi.h gt-ada-decl.h + $(COMPILER) -c $(ALL_COMPILERFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ + +ada/misc.o : ada/gcc-interface/misc.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ + $(TM_H) $(TREE_H) $(DIAGNOSTIC_H) $(TARGET_H) $(FUNCTION_H) \ + $(FLAGS_H) debug.h toplev.h langhooks.h \ + $(LANGHOOKS_DEF_H) $(OPTS_H) $(OPTIONS_H) $(TREE_INLINE_H) $(PLUGIN_H) \ + ada/gcc-interface/ada.h ada/adadecode.h ada/types.h ada/atree.h \ + ada/elists.h ada/namet.h ada/nlists.h ada/stringt.h ada/uintp.h ada/fe.h \ + ada/sinfo.h ada/einfo.h $(ADA_TREE_H) ada/gcc-interface/gigi.h \ + gt-ada-misc.h + $(COMPILER) -c $(ALL_COMPILERFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ + +ada/targtyps.o : ada/gcc-interface/targtyps.c $(CONFIG_H) $(SYSTEM_H) \ + coretypes.h $(TM_H) $(TM_P_H) $(TREE_H) ada/gcc-interface/ada.h \ + ada/types.h ada/atree.h ada/elists.h ada/namet.h ada/nlists.h \ + ada/snames.h ada/stringt.h ada/uintp.h ada/urealp.h ada/fe.h ada/sinfo.h \ + ada/einfo.h $(ADA_TREE_H) ada/gcc-interface/gigi.h + $(COMPILER) -c $(ALL_COMPILERFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ + +ada/trans.o : ada/gcc-interface/trans.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ + $(TM_H) $(TREE_H) $(FLAGS_H) output.h tree-iterator.h \ + $(GIMPLE_H) ada/gcc-interface/ada.h ada/adadecode.h ada/types.h \ + ada/atree.h ada/elists.h ada/namet.h ada/nlists.h ada/snames.h \ + ada/stringt.h ada/uintp.h ada/urealp.h ada/fe.h ada/sinfo.h ada/einfo.h \ + ada/gcc-interface/gadaint.h $(ADA_TREE_H) ada/gcc-interface/gigi.h \ + gt-ada-trans.h + $(COMPILER) -c $(ALL_COMPILERFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ + +ada/utils.o : ada/gcc-interface/utils.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ + $(TM_H) $(TREE_H) $(FLAGS_H) toplev.h $(RTL_H) output.h debug.h convert.h \ + $(TARGET_H) function.h langhooks.h $(CGRAPH_H) \ + $(TREE_DUMP_H) $(TREE_INLINE_H) tree-iterator.h \ + ada/gcc-interface/ada.h ada/types.h ada/atree.h ada/elists.h ada/namet.h \ + ada/nlists.h ada/stringt.h ada/uintp.h ada/fe.h ada/sinfo.h ada/einfo.h \ + $(ADA_TREE_H) ada/gcc-interface/gigi.h gt-ada-utils.h gtype-ada.h + $(COMPILER) -c $(ALL_COMPILERFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ + +ada/utils2.o : ada/gcc-interface/utils2.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ + $(TM_H) $(TREE_H) $(FLAGS_H) output.h $(TREE_INLINE_H) \ + ada/gcc-interface/ada.h ada/types.h ada/atree.h ada/elists.h ada/namet.h \ + ada/nlists.h ada/snames.h ada/stringt.h ada/uintp.h ada/fe.h ada/sinfo.h \ + ada/einfo.h $(ADA_TREE_H) ada/gcc-interface/gigi.h + $(COMPILER) -c $(ALL_COMPILERFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ + +# +# DO NOT PUT SPECIAL RULES BELOW, THIS SECTION IS UPDATED AUTOMATICALLY +# +# GNAT DEPENDENCIES +# regular dependencies +ada/a-charac.o : ada/ada.ads ada/a-charac.ads ada/system.ads + +ada/a-chlat1.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \ + ada/system.ads + +ada/a-clrefi.o : ada/ada.ads ada/a-comlin.ads ada/a-clrefi.ads \ + ada/a-clrefi.adb ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ + ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads + +ada/a-comlin.o : ada/ada.ads ada/a-comlin.ads ada/a-comlin.adb \ + ada/a-unccon.ads ada/system.ads ada/s-secsta.ads ada/s-stoele.ads \ + ada/s-stoele.adb + +ada/a-elchha.o : ada/ada.ads ada/a-except.ads ada/a-elchha.ads \ + ada/a-elchha.adb ada/a-unccon.ads ada/system.ads ada/s-parame.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-traent.ads + +ada/a-except.o : ada/ada.ads ada/a-except.ads ada/a-except.adb \ + ada/a-exexda.adb ada/a-exextr.adb ada/a-elchha.ads ada/a-excpol.adb \ + ada/a-exstat.adb ada/a-unccon.ads ada/system.ads ada/s-exctab.ads \ + ada/s-except.ads ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-traent.ads + +ada/a-ioexce.o : ada/ada.ads ada/a-except.ads ada/a-ioexce.ads \ + ada/a-unccon.ads ada/system.ads ada/s-exctab.ads ada/s-exctab.adb \ + ada/s-htable.ads ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads + +ada/ada.o : ada/ada.ads ada/system.ads + +ada/ali-util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/ali.ads ada/ali-util.ads ada/ali-util.adb \ + ada/alloc.ads ada/aspects.ads ada/atree.ads ada/atree.adb \ + ada/binderr.ads ada/casing.ads ada/csets.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/err_vars.ads ada/gnat.ads \ + ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/opt.ads \ + ada/osint.ads ada/output.ads ada/rident.ads ada/scans.ads ada/scng.ads \ + ada/scng.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/sinput-c.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/stringt.adb ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-crc32.adb \ + ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-utf_32.adb \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/widechar.ads + +ada/ali.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ + ada/ali.ads ada/ali.adb ada/alloc.ads ada/butil.ads ada/casing.ads \ + ada/debug.ads ada/fname.ads ada/gnat.ads ada/g-htable.ads \ + ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/namet.ads \ + ada/namet.adb ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \ + ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ + ada/s-htable.adb ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads + +ada/alloc.o : ada/alloc.ads ada/system.ads + +ada/aspects.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/aspects.adb \ + ada/atree.ads ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads + +ada/atree.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads \ + ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/system.ads ada/s-exctab.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + +ada/back_end.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/back_end.ads ada/back_end.adb ada/casing.ads \ + ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \ + ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/gnatvsn.ads \ + ada/hostparm.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/opt.ads ada/osint.ads ada/osint-c.ads ada/output.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/switch.ads ada/switch-c.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/widechar.ads + +ada/bcheck.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/ali.ads ada/ali-util.ads ada/ali-util.adb \ + ada/alloc.ads ada/atree.ads ada/bcheck.ads ada/bcheck.adb \ + ada/binderr.ads ada/butil.ads ada/casing.ads ada/csets.ads \ + ada/debug.ads ada/einfo.ads ada/err_vars.ads ada/fname.ads ada/gnat.ads \ + ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads \ + ada/namet.ads ada/namet.adb ada/opt.ads ada/osint.ads ada/output.ads \ + ada/rident.ads ada/scans.ads ada/scng.ads ada/scng.adb ada/sinfo.ads \ + ada/sinput.ads ada/sinput-c.ads ada/snames.ads ada/stringt.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/binde.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/ali.ads ada/alloc.ads ada/binde.ads ada/binde.adb \ + ada/binderr.ads ada/butil.ads ada/casing.ads ada/debug.ads \ + ada/fname.ads ada/gnat.ads ada/g-htable.ads ada/gnatvsn.ads \ + ada/hostparm.ads ada/interfac.ads ada/namet.ads ada/namet.adb \ + ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads ada/system.ads \ + ada/s-casuti.ads ada/s-exctab.ads ada/s-htable.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/widechar.ads + +ada/binderr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/binderr.ads ada/binderr.adb \ + ada/butil.ads ada/debug.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \ + ada/output.ads ada/system.ads ada/s-exctab.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads + +ada/bindgen.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/ali.ads ada/alloc.ads ada/binde.ads \ + ada/bindgen.ads ada/bindgen.adb ada/casing.ads ada/debug.ads \ + ada/fname.ads ada/gnat.ads ada/g-hesora.ads ada/g-htable.ads \ + ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \ + ada/osint.ads ada/osint-b.ads ada/output.ads ada/rident.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads + +ada/bindusg.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/bindusg.ads ada/bindusg.adb \ + ada/debug.ads ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads \ + ada/output.ads ada/system.ads ada/s-exctab.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads + +ada/butil.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/butil.ads ada/butil.adb \ + ada/debug.ads ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \ + ada/rident.ads ada/system.ads ada/s-exctab.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tree_io.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads + +ada/casing.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/casing.adb \ + ada/csets.ads ada/csets.adb ada/debug.ads ada/hostparm.ads \ + ada/namet.ads ada/opt.ads ada/output.ads ada/system.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads + +ada/checks.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ + ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/eval_fat.ads ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads \ + ada/exp_ch4.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads \ + ada/exp_dist.ads ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/exp_util.adb ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ + ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ + ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads ada/sem.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch3.ads \ + ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_prag.ads \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ + ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/urealp.adb ada/validsw.ads ada/widechar.ads + +ada/comperr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/comperr.ads ada/comperr.adb \ + ada/debug.ads ada/einfo.ads ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/opt.ads ada/osint.ads ada/output.ads \ + ada/output.adb ada/rident.ads ada/sdefault.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \ + ada/system.ads ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tree_io.ads ada/treepr.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + +ada/csets.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads ada/csets.ads \ + ada/csets.adb ada/hostparm.ads ada/opt.ads ada/system.ads \ + ada/s-exctab.ads ada/s-stalib.ads ada/s-string.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads + +ada/cstand.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads \ + ada/cstand.ads ada/cstand.adb ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/exp_ch11.ads ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/layout.ads \ + ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads ada/sem_mech.ads \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/urealp.adb ada/widechar.ads + +ada/debug.o : ada/debug.ads ada/debug.adb ada/system.ads + +ada/debug_a.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/debug_a.ads \ + ada/debug_a.adb ada/einfo.ads ada/hostparm.ads ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/system.ads \ + ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads + +ada/einfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/snames.adb \ + ada/stand.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/urealp.adb + +ada/elists.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/elists.ads \ + ada/elists.adb ada/hostparm.ads ada/opt.ads ada/output.ads \ + ada/system.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads + +ada/err_vars.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/err_vars.ads \ + ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \ + ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads + +ada/errout.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/err_vars.ads ada/errout.ads ada/errout.adb \ + ada/erroutc.ads ada/fname.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads \ + ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads ada/scans.ads \ + ada/sem_aux.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/stylesw.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/erroutc.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads \ + ada/err_vars.ads ada/erroutc.ads ada/erroutc.adb ada/hostparm.ads \ + ada/interfac.ads ada/namet.ads ada/namet.adb ada/nlists.ads ada/opt.ads \ + ada/output.ads ada/output.adb ada/rident.ads ada/sinfo.ads \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/system.ads \ + ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads + +ada/eval_fat.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/einfo.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ + ada/eval_fat.adb ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/namet.ads ada/opt.ads ada/output.ads ada/rident.ads ada/snames.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/urealp.adb + +ada/exp_aggr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ + ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/eval_fat.ads ada/exp_aggr.ads ada/exp_aggr.adb ada/exp_ch11.ads \ + ada/exp_ch2.ads ada/exp_ch3.ads ada/exp_ch4.ads ada/exp_ch6.ads \ + ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_disp.ads ada/exp_dist.ads \ + ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ + ada/expander.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ + ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ + ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads ada/sem.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch3.ads \ + ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_prag.ads \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ + ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-exctab.ads ada/s-exctab.adb \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads + +ada/exp_atag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_atag.ads ada/exp_atag.adb \ + ada/exp_disp.ads ada/exp_dist.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/fname.ads ada/fname-uf.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/lib.ads ada/lib-load.ads ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ + ada/rtsfind.adb ada/sem.ads ada/sem_aux.ads ada/sem_aux.adb \ + ada/sem_ch7.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_util.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads + +ada/exp_attr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads \ + ada/exp_atag.ads ada/exp_attr.ads ada/exp_attr.adb ada/exp_ch11.ads \ + ada/exp_ch2.ads ada/exp_ch3.ads ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_ch9.ads ada/exp_disp.ads ada/exp_dist.ads ada/exp_imgv.ads \ + ada/exp_pakd.ads ada/exp_strm.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/exp_util.adb ada/exp_vfpt.ads ada/fname.ads ada/fname-uf.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \ + ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/restrict.adb \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/sem.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch6.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads ada/sem_prag.ads \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ + ada/widechar.ads + +ada/exp_cg.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/elists.adb ada/exp_cg.ads ada/exp_cg.adb \ + ada/exp_dbug.ads ada/exp_disp.ads ada/exp_tss.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/lib.ads ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ + ada/sem_aux.ads ada/sem_aux.adb ada/sem_disp.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + +ada/exp_ch11.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/casing.adb ada/csets.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads \ + ada/exp_ch11.adb ada/exp_ch7.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/fname.ads ada/fname-uf.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/lib.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ + ada/sem.ads ada/sem_aux.ads ada/sem_ch8.ads ada/sem_res.ads \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/exp_ch12.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/exp_ch12.ads ada/exp_ch12.adb \ + ada/exp_tss.ads ada/exp_util.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/lib.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem_aux.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads + +ada/exp_ch13.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/exp_ch13.ads ada/exp_ch13.adb \ + ada/exp_ch3.ads ada/exp_ch6.ads ada/exp_imgv.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/rtsfind.ads ada/sem.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_eval.ads ada/sem_util.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tbuild.ads ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads + +ada/exp_ch2.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/exp_ch2.ads ada/exp_ch2.adb ada/exp_smem.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/exp_vfpt.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/rtsfind.ads ada/sem.ads ada/sem_eval.ads ada/sem_res.ads \ + ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tbuild.ads ada/tree_io.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads + +ada/exp_ch3.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ + ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ + ada/exp_aggr.ads ada/exp_atag.ads ada/exp_cg.ads ada/exp_ch11.ads \ + ada/exp_ch2.ads ada/exp_ch3.ads ada/exp_ch3.adb ada/exp_ch4.ads \ + ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_dbug.ads \ + ada/exp_disp.ads ada/exp_disp.adb ada/exp_dist.ads ada/exp_pakd.ads \ + ada/exp_smem.ads ada/exp_strm.ads ada/exp_tss.ads ada/exp_tss.adb \ + ada/exp_util.ads ada/exp_util.adb ada/fname.ads ada/fname-uf.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/layout.ads \ + ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scil_ll.ads \ + ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb \ + ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads ada/sem_mech.ads \ + ada/sem_prag.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/validsw.ads + +ada/exp_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ + ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/eval_fat.ads ada/exp_aggr.ads ada/exp_atag.ads ada/exp_ch11.ads \ + ada/exp_ch2.ads ada/exp_ch3.ads ada/exp_ch4.ads ada/exp_ch4.adb \ + ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_disp.ads \ + ada/exp_fixd.ads ada/exp_intr.ads ada/exp_pakd.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/exp_util.adb ada/exp_vfpt.ads ada/fname.ads \ + ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ + ada/itypes.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/par_sco.ads ada/restrict.ads ada/restrict.adb \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scil_ll.ads \ + ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ + ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch8.ads \ + ada/sem_disp.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_prag.ads \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ + ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-exctab.ads ada/s-exctab.adb \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/validsw.ads \ + ada/widechar.ads + +ada/exp_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ + ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ + ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads \ + ada/exp_ch5.ads ada/exp_ch5.adb ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_dbug.ads ada/exp_disp.ads ada/exp_pakd.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/exp_util.adb ada/fname.ads ada/fname-uf.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ + ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ + ada/scans.ads ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads ada/sem_eval.adb \ + ada/sem_prag.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads + +ada/exp_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ + ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/eval_fat.ads ada/exp_aggr.ads ada/exp_atag.ads ada/exp_cg.ads \ + ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch3.ads ada/exp_ch4.ads \ + ada/exp_ch6.ads ada/exp_ch6.adb ada/exp_ch7.ads ada/exp_ch9.ads \ + ada/exp_dbug.ads ada/exp_disp.ads ada/exp_disp.adb ada/exp_dist.ads \ + ada/exp_intr.ads ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/exp_util.adb ada/exp_vfpt.ads ada/fname.ads ada/fname-uf.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ + ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/restrict.adb \ + ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads \ + ada/scil_ll.ads ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_aux.adb ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch3.ads \ + ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_eval.ads ada/sem_mech.ads ada/sem_prag.ads \ + ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/validsw.ads ada/widechar.ads + +ada/exp_ch7.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch6.ads \ + ada/exp_ch7.ads ada/exp_ch7.adb ada/exp_ch9.ads ada/exp_dbug.ads \ + ada/exp_disp.ads ada/exp_dist.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/exp_util.adb ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ + ada/sem.ads ada/sem_aux.ads ada/sem_ch3.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_eval.ads ada/sem_prag.ads ada/sem_res.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads + +ada/exp_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/exp_aggr.ads ada/exp_ch4.ads ada/exp_ch6.ads \ + ada/exp_ch7.ads ada/exp_ch8.ads ada/exp_ch8.adb ada/exp_dbug.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/inline.ads ada/itypes.ads ada/lib.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \ + ada/sem_aux.ads ada/sem_ch8.ads ada/sem_eval.ads ada/sem_prag.ads \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads + +ada/exp_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads \ + ada/exp_ch11.ads ada/exp_ch3.ads ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_ch9.ads ada/exp_ch9.adb ada/exp_dbug.ads ada/exp_disp.ads \ + ada/exp_sel.ads ada/exp_smem.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/exp_util.adb ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/inline.ads ada/interfac.ads ada/itypes.ads ada/lib.ads \ + ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ + ada/scans.ads ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_aux.adb ada/sem_ch11.ads ada/sem_ch6.ads ada/sem_ch8.ads \ + ada/sem_disp.ads ada/sem_elab.ads ada/sem_eval.ads ada/sem_prag.ads \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/validsw.ads ada/widechar.ads + +ada/exp_code.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/eval_fat.ads ada/exp_ch11.ads \ + ada/exp_code.ads ada/exp_code.adb ada/exp_disp.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/fname.ads ada/freeze.ads ada/get_targ.ads \ + ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ + ada/interfac.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/sem.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch6.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads ada/sem_eval.adb \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-carun8.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ + ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/widechar.ads + +ada/exp_dbug.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/exp_dbug.ads ada/exp_dbug.adb ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/interfac.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/rident.ads ada/sem_aux.ads ada/sem_eval.ads \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/urealp.adb ada/widechar.ads + +ada/exp_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads \ + ada/exp_atag.ads ada/exp_cg.ads ada/exp_ch11.ads ada/exp_ch6.ads \ + ada/exp_ch7.ads ada/exp_dbug.ads ada/exp_disp.ads ada/exp_disp.adb \ + ada/exp_tss.ads ada/exp_tss.adb ada/exp_util.ads ada/exp_util.adb \ + ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ + ada/interfac.ads ada/itypes.ads ada/layout.ads ada/lib.ads \ + ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ + ada/scans.ads ada/scil_ll.ads ada/sem.ads ada/sem_attr.ads \ + ada/sem_aux.ads ada/sem_aux.adb ada/sem_ch6.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads ada/sem_prag.ads \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ + ada/widechar.ads + +ada/exp_dist.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/elists.adb ada/exp_atag.ads ada/exp_disp.ads \ + ada/exp_dist.ads ada/exp_dist.adb ada/exp_strm.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/fname.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ + ada/sem.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads \ + ada/sem_ch12.ads ada/sem_ch3.ads ada/sem_ch8.ads ada/sem_dist.ads \ + ada/sem_eval.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/stringt.adb ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads + +ada/exp_fixd.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/eval_fat.ads ada/exp_ch11.ads \ + ada/exp_disp.ads ada/exp_fixd.ads ada/exp_fixd.adb ada/exp_tss.ads \ + ada/exp_util.ads ada/fname.ads ada/freeze.ads ada/get_targ.ads \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ + ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/sem.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch6.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads ada/sem_eval.adb \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/widechar.ads + +ada/exp_imgv.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_dist.ads ada/exp_imgv.ads \ + ada/exp_imgv.adb ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ + ada/fname-uf.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/hostparm.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ + ada/rtsfind.adb ada/sem.ads ada/sem_aux.ads ada/sem_ch7.ads \ + ada/sem_dist.ads ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb + +ada/exp_intr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads ada/exp_atag.ads \ + ada/exp_ch11.ads ada/exp_ch4.ads ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_code.ads ada/exp_fixd.ads ada/exp_intr.ads ada/exp_intr.adb \ + ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/fname.ads \ + ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ + ada/itypes.ads ada/lib.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ + ada/sem.ads ada/sem_aux.ads ada/sem_ch8.ads ada/sem_eval.ads \ + ada/sem_prag.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/validsw.ads ada/widechar.ads + +ada/exp_pakd.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ + ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ + ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads \ + ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dbug.ads ada/exp_pakd.ads \ + ada/exp_pakd.adb ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/layout.ads \ + ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_aux.ads \ + ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch8.ads ada/sem_eval.ads \ + ada/sem_prag.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads + +ada/exp_prag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/casing.adb ada/csets.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/exp_ch11.ads ada/exp_prag.ads ada/exp_prag.adb \ + ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ + ada/fname-uf.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \ + ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/snames.adb \ + ada/stand.ads ada/stringt.ads ada/stringt.adb ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads + +ada/exp_sel.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/exp_sel.ads ada/exp_sel.adb ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/lib.ads ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ + ada/sem_aux.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + +ada/exp_smem.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/exp_ch9.ads ada/exp_smem.ads ada/exp_smem.adb ada/exp_tss.ads \ + ada/exp_util.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/rtsfind.ads ada/sem.ads ada/sem_aux.ads \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tbuild.ads ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads + +ada/exp_strm.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/exp_strm.ads ada/exp_strm.adb ada/exp_tss.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/sem_aux.ads ada/sem_util.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads + +ada/exp_tss.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/exp_tss.ads ada/exp_tss.adb ada/exp_util.ads \ + ada/fname.ads ada/fname-uf.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ + ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ + ada/rtsfind.ads ada/sem_aux.ads ada/sem_util.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/widechar.ads + +ada/exp_util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/casing.adb ada/checks.ads \ + ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/eval_fat.ads ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch6.ads \ + ada/exp_ch7.ads ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/exp_util.adb ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ + ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ + ada/scans.ads ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_eval.ads ada/sem_eval.adb ada/sem_prag.ads ada/sem_res.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/validsw.ads ada/widechar.ads + +ada/exp_vfpt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/exp_vfpt.ads ada/exp_vfpt.adb ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/rtsfind.ads \ + ada/sem_res.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/urealp.adb + +ada/expander.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/debug_a.ads \ + ada/debug_a.adb ada/einfo.ads ada/elists.ads ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads ada/exp_attr.ads \ + ada/exp_ch11.ads ada/exp_ch12.ads ada/exp_ch13.ads ada/exp_ch2.ads \ + ada/exp_ch3.ads ada/exp_ch4.ads ada/exp_ch5.ads ada/exp_ch6.ads \ + ada/exp_ch7.ads ada/exp_ch8.ads ada/exp_ch9.ads ada/exp_prag.ads \ + ada/expander.ads ada/expander.adb ada/hostparm.ads ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ + ada/rtsfind.ads ada/sem.ads ada/sem_ch8.ads ada/sem_util.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ + ada/system.ads ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + +ada/fmap.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/fmap.ads ada/fmap.adb \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/namet.ads \ + ada/opt.ads ada/osint.ads ada/output.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads + +ada/fname-uf.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/debug.ads \ + ada/fmap.ads ada/fname.ads ada/fname-uf.ads ada/fname-uf.adb \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/krunch.ads \ + ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tree_io.ads \ + ada/types.ads ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/widechar.ads + +ada/fname.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/fname.ads \ + ada/fname.adb ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \ + ada/system.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads + +ada/freeze.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch3.ads ada/exp_ch6.ads \ + ada/exp_ch7.ads ada/exp_disp.ads ada/exp_pakd.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/exp_util.adb ada/expander.ads ada/fname.ads \ + ada/freeze.ads ada/freeze.adb ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ + ada/interfac.ads ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem_aggr.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads \ + ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ + ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads \ + ada/sem_eval.ads ada/sem_intr.ads ada/sem_mech.ads ada/sem_prag.ads \ + ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinfo-cn.ads ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-exctab.ads ada/s-exctab.adb \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/validsw.ads ada/widechar.ads + +ada/frontend.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads \ + ada/cstand.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_dbug.ads \ + ada/fmap.ads ada/fname.ads ada/fname-uf.ads ada/frontend.ads \ + ada/frontend.adb ada/gnat.ads ada/g-dyntab.ads ada/g-dyntab.adb \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ + ada/interfac.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-load.ads ada/lib-sort.adb ada/live.ads ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/osint.ads ada/output.ads ada/par.ads ada/prep.ads ada/prepcomp.ads \ + ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ + ada/scans.ads ada/scil_ll.ads ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sem.ads ada/sem_aux.ads ada/sem_ch8.ads ada/sem_elab.ads \ + ada/sem_prag.ads ada/sem_scil.ads ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/sinput-l.ads \ + ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/g-byorma.o : ada/gnat.ads ada/g-byorma.ads ada/g-byorma.adb \ + ada/system.ads + +ada/g-hesora.o : ada/gnat.ads ada/g-hesora.ads ada/g-hesora.adb \ + ada/system.ads + +ada/g-htable.o : ada/gnat.ads ada/g-htable.ads ada/g-htable.adb \ + ada/system.ads ada/s-htable.ads + +ada/g-spchge.o : ada/gnat.ads ada/g-spchge.ads ada/g-spchge.adb \ + ada/system.ads + +ada/g-speche.o : ada/gnat.ads ada/g-speche.ads ada/g-speche.adb \ + ada/g-spchge.ads ada/g-spchge.adb ada/system.ads + +ada/g-u3spch.o : ada/gnat.ads ada/g-spchge.ads ada/g-spchge.adb \ + ada/g-u3spch.ads ada/g-u3spch.adb ada/system.ads ada/s-wchcnv.ads \ + ada/s-wchcon.ads + +ada/get_scos.o : ada/ada.ads ada/a-ioexce.ads ada/a-unccon.ads \ + ada/get_scos.ads ada/get_scos.adb ada/gnat.ads ada/g-table.ads \ + ada/g-table.adb ada/scos.ads ada/system.ads ada/s-exctab.ads \ + ada/s-memory.ads ada/s-stalib.ads ada/s-unstyp.ads ada/types.ads \ + ada/unchconv.ads ada/unchdeal.ads + +ada/get_targ.o : ada/ada.ads ada/a-unccon.ads ada/get_targ.ads \ + ada/get_targ.adb ada/system.ads ada/s-exctab.ads ada/s-stalib.ads \ + ada/s-unstyp.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads + +ada/gnat.o : ada/gnat.ads ada/system.ads + +ada/gnat1drv.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/back_end.ads ada/casing.ads ada/comperr.ads \ + ada/csets.ads ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/exp_cg.ads ada/exp_tss.ads ada/expander.ads \ + ada/fmap.ads ada/fname.ads ada/fname-uf.ads ada/frontend.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/g-table.ads ada/g-table.adb ada/gnat1drv.ads ada/gnat1drv.adb \ + ada/gnatvsn.ads ada/hlo.ads ada/hostparm.ads ada/inline.ads ada/lib.ads \ + ada/lib.adb ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb \ + ada/lib-writ.ads ada/lib-xref.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/opt.ads ada/osint.ads ada/output.ads \ + ada/par_sco.ads ada/prepcomp.ads ada/repinfo.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/scos.ads ada/sem.ads ada/sem.adb \ + ada/sem_attr.ads ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads \ + ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads ada/sem_ch4.ads \ + ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ + ada/sem_ch9.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_prag.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/sinput-l.ads ada/snames.ads \ + ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stylesw.ads \ + ada/system.ads ada/s-assert.ads ada/s-bitops.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tree_gen.ads \ + ada/tree_io.ads ada/treepr.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/usage.ads ada/validsw.ads \ + ada/widechar.ads + +ada/gnatbind.o : ada/ada.ads ada/a-comlin.ads ada/a-clrefi.ads \ + ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads ada/ali.ads \ + ada/ali-util.ads ada/alloc.ads ada/bcheck.ads ada/binde.ads \ + ada/binderr.ads ada/bindgen.ads ada/bindusg.ads ada/butil.ads \ + ada/casing.ads ada/csets.ads ada/debug.ads ada/fmap.ads ada/fname.ads \ + ada/gnat.ads ada/g-htable.ads ada/gnatbind.ads ada/gnatbind.adb \ + ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \ + ada/osint.ads ada/osint-b.ads ada/output.ads ada/rident.ads \ + ada/snames.ads ada/switch.ads ada/switch.adb ada/switch-b.ads \ + ada/system.ads ada/s-casuti.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tree_io.ads ada/types.ads \ + ada/unchconv.ads ada/unchdeal.ads + +ada/gnatvsn.o : ada/ada.ads ada/a-unccon.ads ada/gnatvsn.ads \ + ada/gnatvsn.adb ada/system.ads ada/s-secsta.ads ada/s-stoele.ads \ + ada/s-stoele.adb + +ada/hlo.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads ada/hlo.ads \ + ada/hlo.adb ada/hostparm.ads ada/output.ads ada/system.ads \ + ada/s-exctab.ads ada/s-os_lib.ads ada/s-stalib.ads ada/s-string.ads \ + ada/s-unstyp.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads + +ada/hostparm.o : ada/ada.ads ada/a-unccon.ads ada/hostparm.ads \ + ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads + +ada/impunit.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \ + ada/fname-uf.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/impunit.ads ada/impunit.adb ada/interfac.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/inline.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/exp_ch7.ads ada/exp_tss.ads ada/fname.ads \ + ada/fname-uf.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/inline.adb ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads ada/sem.ads \ + ada/sem_aux.ads ada/sem_ch10.ads ada/sem_ch12.ads ada/sem_ch8.ads \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + +ada/instpar.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads \ + ada/gnatvsn.ads ada/hostparm.ads ada/instpar.ads ada/instpar.adb \ + ada/interfac.ads ada/namet.ads ada/nlists.ads ada/opt.ads \ + ada/output.ads ada/sdefault.ads ada/sinfo.ads ada/sinput.ads \ + ada/sinput.adb ada/sinput-l.ads ada/snames.ads ada/system.ads \ + ada/s-carun8.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/interfac.o : ada/interfac.ads ada/system.ads + +ada/itypes.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/itypes.ads \ + ada/itypes.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/opt.ads ada/output.ads ada/rident.ads ada/sem.ads \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tree_io.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads + +ada/krunch.o : ada/ada.ads ada/a-unccon.ads ada/hostparm.ads \ + ada/krunch.ads ada/krunch.adb ada/system.ads ada/s-exctab.ads \ + ada/s-stalib.ads ada/s-unstyp.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads + +ada/layout.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads ada/exp_ch3.ads \ + ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/interfac.ads ada/layout.ads ada/layout.adb \ + ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/repinfo.ads ada/repinfo.adb ada/restrict.ads ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem_attr.ads \ + ada/sem_aux.ads ada/sem_ch13.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/lib-load.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/fname.ads ada/fname-uf.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ + ada/lib-load.adb ada/lib-sort.adb ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/osint.ads \ + ada/osint-c.ads ada/output.ads ada/par.ads ada/restrict.ads \ + ada/rident.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sem_aux.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/sinput.adb ada/sinput-l.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-crc32.adb \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/lib-util.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/lib.ads ada/lib-util.ads ada/lib-util.adb ada/namet.ads ada/opt.ads \ + ada/osint.ads ada/osint-c.ads ada/output.ads ada/stringt.ads \ + ada/stringt.adb ada/system.ads ada/s-carun8.ads ada/s-exctab.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/types.adb ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads + +ada/lib-writ.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/ali.ads ada/alloc.ads ada/aspects.ads \ + ada/atree.ads ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/fname.ads ada/fname-uf.ads \ + ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/gnatvsn.ads \ + ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/lib-util.ads ada/lib-util.adb \ + ada/lib-writ.ads ada/lib-writ.adb ada/lib-xref.ads ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/osint.ads ada/osint-c.ads ada/output.ads ada/par.ads \ + ada/par_sco.ads ada/restrict.ads ada/rident.ads ada/scans.ads \ + ada/scn.ads ada/scng.ads ada/scng.adb ada/sem_aux.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-casuti.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads + +ada/lib-xref.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/fname.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-hesorg.adb ada/g-htable.ads ada/hostparm.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ + ada/lib-util.ads ada/lib-util.adb ada/lib-xref.ads ada/lib-xref.adb \ + ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads \ + ada/osint.ads ada/osint-c.ads ada/output.ads ada/restrict.ads \ + ada/rident.ads ada/sem.ads ada/sem_aux.ads ada/sem_aux.adb \ + ada/sem_prag.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/lib.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ + ada/alloc.ads ada/aspects.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/fname.ads \ + ada/gnat.ads ada/g-hesorg.ads ada/g-hesorg.adb ada/g-htable.ads \ + ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/live.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/fname.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-sort.adb ada/live.ads ada/live.adb ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + +ada/namet-sp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnat.ads \ + ada/g-u3spch.ads ada/hostparm.ads ada/interfac.ads ada/namet.ads \ + ada/namet.adb ada/namet-sp.ads ada/namet-sp.adb ada/opt.ads \ + ada/output.ads ada/system.ads ada/s-carun8.ads ada/s-exctab.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcnv.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/types.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads + +ada/namet.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/interfac.ads ada/namet.ads ada/namet.adb ada/opt.ads ada/output.ads \ + ada/system.ads ada/s-carun8.ads ada/s-exctab.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/types.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/widechar.ads + +ada/nlists.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads \ + ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/system.ads ada/s-exctab.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + +ada/nmake.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads \ + ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/system.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads + +ada/opt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ + ada/gnatvsn.ads ada/hostparm.ads ada/opt.ads ada/opt.adb ada/system.ads \ + ada/s-exctab.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/tree_io.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads + +ada/osint-b.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/opt.ads ada/osint.ads ada/osint-b.ads ada/osint-b.adb \ + ada/output.ads ada/rident.ads ada/system.ads ada/s-exctab.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tree_io.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads + +ada/osint-c.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/interfac.ads ada/namet.ads ada/namet.adb ada/opt.ads ada/osint.ads \ + ada/osint-c.ads ada/osint-c.adb ada/output.ads ada/system.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/widechar.ads + +ada/osint.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/fmap.ads ada/gnat.ads \ + ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads \ + ada/namet.ads ada/namet.adb ada/opt.ads ada/osint.ads ada/osint.adb \ + ada/output.ads ada/rident.ads ada/sdefault.ads ada/system.ads \ + ada/s-casuti.ads ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tree_io.ads ada/types.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads + +ada/output.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/hostparm.ads ada/output.ads ada/output.adb \ + ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads + +ada/par.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ + ada/alloc.ads ada/aspects.ads ada/aspects.adb ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/fname.ads ada/fname-uf.ads \ + ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/g-speche.ads \ + ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/namet.ads \ + ada/namet.adb ada/namet-sp.ads ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/nmake.adb ada/opt.ads ada/osint.ads ada/output.ads \ + ada/par.ads ada/par.adb ada/par-ch10.adb ada/par-ch11.adb \ + ada/par-ch12.adb ada/par-ch13.adb ada/par-ch2.adb ada/par-ch3.adb \ + ada/par-ch4.adb ada/par-ch5.adb ada/par-ch6.adb ada/par-ch7.adb \ + ada/par-ch8.adb ada/par-ch9.adb ada/par-endh.adb ada/par-labl.adb \ + ada/par-load.adb ada/par-prag.adb ada/par-sync.adb ada/par-tchk.adb \ + ada/par-util.adb ada/par_sco.ads ada/restrict.ads ada/rident.ads \ + ada/scans.ads ada/scans.adb ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sem_aux.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ + ada/sinput.ads ada/sinput.adb ada/sinput-l.ads ada/snames.ads \ + ada/snames.adb ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-crc32.adb \ + ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ + ada/widechar.ads + +ada/par_sco.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/fname.ads ada/gnat.ads ada/g-hesorg.ads ada/g-hesorg.adb \ + ada/g-htable.ads ada/g-table.ads ada/g-table.adb ada/hostparm.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ + ada/lib-util.ads ada/lib-util.adb ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/opt.ads ada/osint.ads ada/osint-c.ads ada/output.ads \ + ada/par_sco.ads ada/par_sco.adb ada/put_scos.ads ada/put_scos.adb \ + ada/scos.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads + +ada/prep.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/csets.ads \ + ada/debug.ads ada/err_vars.ads ada/gnat.ads ada/g-dyntab.ads \ + ada/g-dyntab.adb ada/g-hesorg.ads ada/g-hesorg.adb ada/hostparm.ads \ + ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads ada/prep.ads \ + ada/prep.adb ada/scans.ads ada/sinput.ads ada/snames.ads \ + ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-carun8.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads + +ada/prepcomp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/gnat.ads \ + ada/g-dyntab.ads ada/g-dyntab.adb ada/g-hesorg.ads ada/hostparm.ads \ + ada/interfac.ads ada/lib.ads ada/lib-writ.ads ada/namet.ads \ + ada/nlists.ads ada/opt.ads ada/osint.ads ada/output.ads ada/prep.ads \ + ada/prepcomp.ads ada/prepcomp.adb ada/scans.ads ada/scn.ads \ + ada/scng.ads ada/scng.adb ada/sinfo.ads ada/sinput.ads ada/sinput.adb \ + ada/sinput-l.ads ada/snames.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/put_scos.o : ada/ada.ads ada/a-unccon.ads ada/gnat.ads ada/g-table.ads \ + ada/g-table.adb ada/put_scos.ads ada/put_scos.adb ada/scos.ads \ + ada/system.ads ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads \ + ada/s-unstyp.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads + +ada/repinfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/fname.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/opt.ads ada/output.ads ada/output.adb ada/repinfo.ads \ + ada/repinfo.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/restrict.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \ + ada/fname-uf.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/restrict.adb ada/rident.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads + +ada/rident.o : ada/rident.ads ada/system.ads ada/s-rident.ads + +ada/rtsfind.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_dist.ads ada/fname.ads \ + ada/fname-uf.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ + ada/rtsfind.ads ada/rtsfind.adb ada/sem.ads ada/sem_ch7.ads \ + ada/sem_dist.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tbuild.ads ada/tree_io.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/s-addope.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-addope.ads ada/s-addope.adb + +ada/s-assert.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/system.ads ada/s-assert.ads ada/s-assert.adb ada/s-exctab.ads \ + ada/s-exctab.adb ada/s-except.ads ada/s-htable.ads ada/s-parame.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-traent.ads + +ada/s-bitops.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/system.ads ada/s-bitops.ads ada/s-bitops.adb ada/s-parame.ads \ + ada/s-stalib.ads ada/s-traent.ads ada/s-unstyp.ads + +ada/s-carun8.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-addope.ads ada/s-addope.adb ada/s-carun8.ads ada/s-carun8.adb + +ada/s-casuti.o : ada/system.ads ada/s-casuti.ads ada/s-casuti.adb + +ada/s-conca2.o : ada/system.ads ada/s-conca2.ads ada/s-conca2.adb + +ada/s-conca3.o : ada/system.ads ada/s-conca2.ads ada/s-conca3.ads \ + ada/s-conca3.adb + +ada/s-conca4.o : ada/system.ads ada/s-conca3.ads ada/s-conca4.ads \ + ada/s-conca4.adb + +ada/s-conca5.o : ada/system.ads ada/s-conca4.ads ada/s-conca5.ads \ + ada/s-conca5.adb + +ada/s-conca6.o : ada/system.ads ada/s-conca5.ads ada/s-conca6.ads \ + ada/s-conca6.adb + +ada/s-conca7.o : ada/system.ads ada/s-conca6.ads ada/s-conca7.ads \ + ada/s-conca7.adb + +ada/s-conca8.o : ada/system.ads ada/s-conca7.ads ada/s-conca8.ads \ + ada/s-conca8.adb + +ada/s-conca9.o : ada/system.ads ada/s-conca8.ads ada/s-conca9.ads \ + ada/s-conca9.adb + +ada/s-crc32.o : ada/interfac.ads ada/system.ads ada/s-crc32.ads \ + ada/s-crc32.adb + +ada/s-crtl.o : ada/system.ads ada/s-crtl.ads ada/s-parame.ads + +ada/s-except.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-except.ads ada/s-except.adb ada/s-stalib.ads + +ada/s-exctab.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/system.ads ada/s-exctab.ads ada/s-exctab.adb \ + ada/s-htable.ads ada/s-htable.adb ada/s-parame.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strhas.ads ada/s-traent.ads + +ada/s-htable.o : ada/ada.ads ada/a-uncdea.ads ada/system.ads \ + ada/s-htable.ads ada/s-htable.adb ada/s-strhas.ads + +ada/s-imenne.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-imenne.ads ada/s-imenne.adb + +ada/s-imgenu.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-imgenu.ads ada/s-imgenu.adb ada/s-secsta.ads ada/s-stoele.ads \ + ada/s-stoele.adb + +ada/s-mastop.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-mastop.ads ada/s-mastop.adb ada/s-stoele.ads ada/s-stoele.adb + +ada/s-memory.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/system.ads ada/s-crtl.ads ada/s-memory.ads ada/s-memory.adb \ + ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads + +ada/s-os_lib.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/system.ads ada/s-casuti.ads ada/s-crtl.ads \ + ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-os_lib.ads \ + ada/s-os_lib.adb ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads + +ada/s-parame.o : ada/system.ads ada/s-parame.ads ada/s-parame.adb + +ada/s-purexc.o : ada/system.ads ada/s-purexc.ads + +ada/s-restri.o : ada/system.ads ada/s-restri.ads ada/s-restri.adb \ + ada/s-rident.ads + +ada/s-secsta.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/system.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-secsta.adb ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads + +ada/s-soflin.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/system.ads ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-soflin.adb ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-traent.ads + +ada/s-sopco3.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-secsta.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-sopco3.ads \ + ada/s-sopco3.adb + +ada/s-sopco4.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-secsta.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-sopco4.ads \ + ada/s-sopco4.adb + +ada/s-sopco5.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-secsta.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-sopco5.ads \ + ada/s-sopco5.adb + +ada/s-stache.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-stache.ads ada/s-stache.adb ada/s-stoele.ads ada/s-stoele.adb + +ada/s-stalib.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/system.ads ada/s-memory.ads ada/s-parame.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stalib.adb ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-traent.ads + +ada/s-stoele.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-stoele.ads ada/s-stoele.adb + +ada/s-strcom.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-strcom.ads ada/s-strcom.adb + +ada/s-strhas.o : ada/system.ads ada/s-strhas.ads ada/s-strhas.adb + +ada/s-string.o : ada/ada.ads ada/a-uncdea.ads ada/system.ads \ + ada/s-string.ads ada/s-string.adb + +ada/s-strops.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ + ada/s-secsta.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-strops.adb + +ada/s-traceb.o : ada/system.ads ada/s-traceb.ads ada/s-traceb.adb + +ada/s-traent.o : ada/system.ads ada/s-traent.ads ada/s-traent.adb + +ada/s-unstyp.o : ada/system.ads ada/s-unstyp.ads + +ada/s-utf_32.o : ada/system.ads ada/s-utf_32.ads ada/s-utf_32.adb + +ada/s-wchcnv.o : ada/interfac.ads ada/system.ads ada/s-wchcnv.ads \ + ada/s-wchcnv.adb ada/s-wchcon.ads ada/s-wchjis.ads + +ada/s-wchcon.o : ada/system.ads ada/s-wchcon.ads ada/s-wchcon.adb + +ada/s-wchjis.o : ada/system.ads ada/s-wchjis.ads ada/s-wchjis.adb + +ada/scans.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/interfac.ads ada/namet.ads ada/namet.adb ada/opt.ads ada/output.ads \ + ada/scans.ads ada/scans.adb ada/snames.ads ada/system.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/scil_ll.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads \ + ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/opt.ads ada/output.ads ada/scil_ll.ads ada/scil_ll.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ + ada/system.ads ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + +ada/scn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ + ada/alloc.ads ada/aspects.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/gnat.ads \ + ada/g-byorma.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/scans.ads ada/scn.ads ada/scn.adb \ + ada/scng.ads ada/scng.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/sinput.adb ada/snames.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-crc32.adb \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-utf_32.adb ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/types.adb ada/uintp.ads \ + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/urealp.adb ada/widechar.ads + +ada/scng.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/csets.ads \ + ada/debug.ads ada/err_vars.ads ada/hostparm.ads ada/interfac.ads \ + ada/namet.ads ada/opt.ads ada/output.ads ada/scans.ads ada/scng.ads \ + ada/scng.adb ada/sinput.ads ada/snames.ads ada/stringt.ads \ + ada/styleg.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/scos.o : ada/ada.ads ada/a-unccon.ads ada/gnat.ads ada/g-table.ads \ + ada/g-table.adb ada/scos.ads ada/scos.adb ada/system.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads ada/s-unstyp.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads + +ada/sem.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ + ada/alloc.ads ada/aspects.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/debug_a.ads ada/debug_a.adb \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_tss.ads \ + ada/expander.ads ada/fname.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/hlo.ads ada/hostparm.ads ada/inline.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ + ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/rident.ads ada/sem.ads ada/sem.adb ada/sem_attr.ads \ + ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads ada/sem_ch13.ads \ + ada/sem_ch2.ads ada/sem_ch2.adb ada/sem_ch3.ads ada/sem_ch4.ads \ + ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ + ada/sem_ch9.ads ada/sem_prag.ads ada/sem_util.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-carun8.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/types.adb ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads + +ada/sem_aggr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ + ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/eval_fat.ads ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads \ + ada/exp_ch4.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads \ + ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ + ada/expander.ads ada/fname.ads ada/freeze.ads ada/get_targ.ads \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ + ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/namet-sp.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/sem.ads ada/sem_aggr.ads ada/sem_aggr.adb ada/sem_attr.ads \ + ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch3.ads \ + ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads \ + ada/sem_eval.adb ada/sem_prag.ads ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ + ada/widechar.ads + +ada/sem_attr.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \ + ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads ada/alloc.ads \ + ada/aspects.ads ada/atree.ads ada/atree.adb ada/casing.ads \ + ada/checks.ads ada/checks.adb ada/csets.ads ada/debug.ads \ + ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ + ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads \ + ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads ada/exp_dist.ads \ + ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ + ada/expander.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/gnatvsn.ads \ + ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ + ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ + ada/scans.ads ada/sdefault.ads ada/sem.ads ada/sem_aggr.ads \ + ada/sem_attr.ads ada/sem_attr.adb ada/sem_aux.ads ada/sem_aux.adb \ + ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch13.ads ada/sem_ch3.ads \ + ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads \ + ada/sem_eval.adb ada/sem_intr.ads ada/sem_prag.ads ada/sem_res.ads \ + ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/snames.adb \ + ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-carun8.ads ada/s-exctab.ads ada/s-exctab.adb \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/validsw.ads ada/widechar.ads + +ada/sem_aux.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ + ada/sem_aux.ads ada/sem_aux.adb ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + +ada/sem_case.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-hesorg.adb ada/g-htable.ads ada/hostparm.ads \ + ada/interfac.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/sem.ads ada/sem_aux.ads ada/sem_case.ads ada/sem_case.adb \ + ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tbuild.ads ada/tree_io.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads + +ada/sem_cat.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads \ + ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ + ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/opt.ads ada/output.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ + ada/sem_cat.adb ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/sem_ch10.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads \ + ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ + ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/impunit.ads \ + ada/inline.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/par_sco.ads \ + ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ + ada/scans.ads ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_ch10.ads ada/sem_ch10.adb ada/sem_ch3.ads ada/sem_ch6.ads \ + ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ + ada/sem_eval.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/sem_ch11.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/exp_code.ads ada/fname.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/par_sco.ads ada/restrict.ads ada/rident.ads \ + ada/rtsfind.ads ada/sem.ads ada/sem_aux.ads ada/sem_ch11.ads \ + ada/sem_ch11.adb ada/sem_ch13.ads ada/sem_ch5.ads ada/sem_ch8.ads \ + ada/sem_eval.ads ada/sem_res.ads ada/sem_util.ads ada/sem_warn.ads \ + ada/sem_warn.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + +ada/sem_ch12.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads \ + ada/exp_disp.ads ada/exp_dist.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/expander.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ + ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ + ada/rtsfind.adb ada/scans.ads ada/sem.ads ada/sem_attr.ads \ + ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch12.ads \ + ada/sem_ch12.adb ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads \ + ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ + ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_res.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads \ + ada/sinput-l.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ + ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/widechar.ads + +ada/sem_ch13.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/aspects.adb \ + ada/atree.ads ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads \ + ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ + ada/exp_ch11.ads ada/exp_disp.ads ada/exp_dist.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-hesorg.adb \ + ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ + ada/lib.adb ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb \ + ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ + ada/scans.ads ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch13.adb ada/sem_ch3.ads \ + ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-exctab.ads \ + ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/widechar.ads + +ada/sem_ch2.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/hostparm.ads \ + ada/namet.ads ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/sem_ch2.ads ada/sem_ch2.adb \ + ada/sem_ch8.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/system.ads ada/s-carun8.ads \ + ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/types.adb ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + +ada/sem_ch3.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ + ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/eval_fat.ads ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads \ + ada/exp_ch3.ads ada/exp_ch4.ads ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_ch9.ads ada/exp_disp.ads ada/exp_dist.ads ada/exp_pakd.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/fname.ads \ + ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ + ada/interfac.ads ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/restrict.adb \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/sem.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_case.ads \ + ada/sem_case.adb ada/sem_cat.ads ada/sem_cat.adb ada/sem_ch13.ads \ + ada/sem_ch3.ads ada/sem_ch3.adb ada/sem_ch6.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elim.ads \ + ada/sem_eval.ads ada/sem_eval.adb ada/sem_mech.ads ada/sem_prag.ads \ + ada/sem_res.ads ada/sem_smem.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/validsw.ads \ + ada/widechar.ads + +ada/sem_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/expander.ads \ + ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ + ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ + ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/namet-sp.ads ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_case.ads ada/sem_case.adb ada/sem_cat.ads ada/sem_ch13.ads \ + ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch4.adb ada/sem_ch5.ads \ + ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ + ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb \ + ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/sem_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ + ada/csets.ads ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads \ + ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_code.ads ada/exp_disp.ads \ + ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads ada/expander.ads \ + ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ + ada/itypes.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/par_sco.ads ada/restrict.ads ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem_aggr.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_case.ads ada/sem_case.adb \ + ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads \ + ada/sem_ch5.ads ada/sem_ch5.adb ada/sem_ch6.ads ada/sem_ch8.ads \ + ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads \ + ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads ada/sem_res.ads \ + ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sem_warn.adb ada/sinfo.ads ada/sinfo.adb \ + ada/sinfo-cn.ads ada/sinput.ads ada/snames.ads ada/sprint.ads \ + ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads + +ada/sem_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads \ + ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_disp.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ + ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ + ada/interfac.ads ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/restrict.adb \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/sem.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads \ + ada/sem_ch10.ads ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch3.ads \ + ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch6.adb \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elim.ads \ + ada/sem_eval.ads ada/sem_mech.ads ada/sem_prag.ads ada/sem_res.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads \ + ada/sinput.adb ada/snames.ads ada/snames.adb ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ + ada/widechar.ads + +ada/sem_ch7.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads \ + ada/exp_dbug.ads ada/exp_disp.ads ada/exp_dist.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/fname.ads ada/freeze.ads ada/get_targ.ads \ + ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ + ada/inline.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ + ada/sem_ch10.ads ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch3.ads \ + ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch7.adb ada/sem_ch8.ads \ + ada/sem_disp.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/snames.adb ada/stand.ads ada/stringt.ads ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/sem_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads \ + ada/exp_dist.ads ada/exp_tss.ads ada/exp_util.ads ada/expander.ads \ + ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ + ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ + ada/impunit.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ + ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/namet-sp.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads \ + ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_cat.ads ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch3.ads \ + ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ + ada/sem_ch8.adb ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \ + ada/sem_elim.ads ada/sem_eval.ads ada/sem_intr.ads ada/sem_res.ads \ + ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/sem_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ + ada/csets.ads ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads \ + ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_disp.ads \ + ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads ada/expander.ads \ + ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ + ada/itypes.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem_aggr.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads \ + ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads \ + ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_ch9.adb ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads \ + ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ + ada/widechar.ads + +ada/sem_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads \ + ada/exp_atag.ads ada/exp_cg.ads ada/exp_ch11.ads ada/exp_ch6.ads \ + ada/exp_ch7.ads ada/exp_dbug.ads ada/exp_disp.ads ada/exp_disp.adb \ + ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/fname.ads \ + ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ + ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/scil_ll.ads ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_aux.adb ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_disp.adb ada/sem_eval.ads \ + ada/sem_prag.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads + +ada/sem_dist.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_dist.ads \ + ada/exp_tss.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/rtsfind.ads ada/sem.ads ada/sem_aux.ads \ + ada/sem_disp.ads ada/sem_dist.ads ada/sem_dist.adb ada/sem_eval.ads \ + ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/stringt.adb ada/system.ads ada/s-carun8.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/types.adb \ + ada/uintp.ads ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads + +ada/sem_elab.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads \ + ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/expander.ads \ + ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ + ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ + ada/interfac.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/restrict.adb \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/sem.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_elab.ads ada/sem_elab.adb \ + ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/sem_elim.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \ + ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ + ada/sem.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_elim.ads \ + ada/sem_elim.adb ada/sem_prag.ads ada/sem_util.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/widechar.ads + +ada/sem_eval.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/expander.ads \ + ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/itypes.ads \ + ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_aux.adb ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch4.ads \ + ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ + ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb \ + ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/widechar.ads + +ada/sem_intr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \ + ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ + ada/rident.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_eval.ads \ + ada/sem_intr.ads ada/sem_intr.adb ada/sem_util.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tree_io.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads + +ada/sem_mech.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads ada/rident.ads \ + ada/sem.ads ada/sem_aux.ads ada/sem_mech.ads ada/sem_mech.adb \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tree_io.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads + +ada/sem_prag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_disp.ads ada/exp_dist.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/expander.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ + ada/lib-writ.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/namet-sp.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/par_sco.ads \ + ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ + ada/scans.ads ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads \ + ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads ada/sem_ch12.ads \ + ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch6.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \ + ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads \ + ada/sem_mech.ads ada/sem_prag.ads ada/sem_prag.adb ada/sem_res.ads \ + ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_vfpt.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/snames.adb ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-carun8.ads ada/s-exctab.ads ada/s-exctab.adb \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/validsw.ads ada/widechar.ads + +ada/sem_res.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ + ada/csets.ads ada/debug.ads ada/debug_a.ads ada/debug_a.adb \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ + ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads \ + ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads ada/exp_dist.ads \ + ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ + ada/expander.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ + ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ + ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads ada/sem.ads \ + ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ + ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch6.ads \ + ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ + ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb \ + ada/sem_intr.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_res.adb \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads \ + ada/sinput.adb ada/snames.ads ada/sprint.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/validsw.ads ada/widechar.ads + +ada/sem_scil.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ + ada/rtsfind.ads ada/scil_ll.ads ada/sem_aux.ads ada/sem_scil.ads \ + ada/sem_scil.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + +ada/sem_smem.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/opt.ads ada/output.ads ada/sem_aux.ads \ + ada/sem_smem.ads ada/sem_smem.adb ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + +ada/sem_type.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads \ + ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ + ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem_attr.ads \ + ada/sem_aux.ads ada/sem_ch12.ads ada/sem_ch6.ads ada/sem_ch8.ads \ + ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_res.ads \ + ada/sem_type.ads ada/sem_type.adb ada/sem_util.ads ada/sem_util.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/sem_util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ + ada/exp_ch11.ads ada/exp_disp.ads ada/exp_dist.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads \ + ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ + ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/widechar.ads + +ada/sem_vfpt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/cstand.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/namet.ads ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ + ada/rident.ads ada/sem_vfpt.ads ada/sem_vfpt.adb ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + +ada/sem_warn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads ada/exp_code.ads \ + ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ + ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/opt.ads ada/output.ads ada/par_sco.ads ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem_attr.ads \ + ada/sem_aux.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sem_warn.adb ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/sinfo-cn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads \ + ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/opt.ads \ + ada/output.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ + ada/sinfo-cn.adb ada/sinput.ads ada/snames.ads ada/system.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads + +ada/sinfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + +ada/sinput-c.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/debug.ads \ + ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \ + ada/sinput.ads ada/sinput-c.ads ada/sinput-c.adb ada/system.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads + +ada/sinput-d.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/debug.ads \ + ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads \ + ada/osint-c.ads ada/output.ads ada/sinput.ads ada/sinput-d.ads \ + ada/sinput-d.adb ada/system.ads ada/s-exctab.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads + +ada/sinput-l.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \ + ada/gnat.ads ada/g-dyntab.ads ada/g-dyntab.adb ada/g-hesorg.ads \ + ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/opt.ads ada/osint.ads ada/output.ads \ + ada/prep.ads ada/prepcomp.ads ada/scans.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/sinput-l.ads ada/sinput-l.adb ada/snames.ads ada/stringt.ads \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/sinput.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads \ + ada/hostparm.ads ada/interfac.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/system.ads ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/snames.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/interfac.ads ada/namet.ads ada/namet.adb ada/opt.ads ada/output.ads \ + ada/snames.ads ada/snames.adb ada/system.ads ada/s-exctab.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/widechar.ads + +ada/sprint.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/fname.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ + ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads \ + ada/output.ads ada/output.adb ada/rtsfind.ads ada/sem_eval.ads \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/sinput.adb ada/sinput-d.ads ada/snames.ads ada/sprint.ads \ + ada/sprint.adb ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/widechar.ads + +ada/stand.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads ada/stand.ads \ + ada/stand.adb ada/system.ads ada/s-exctab.ads ada/s-os_lib.ads \ + ada/s-stalib.ads ada/s-string.ads ada/s-unstyp.ads ada/tree_io.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads + +ada/stringt.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/opt.ads ada/output.ads ada/stringt.ads \ + ada/stringt.adb ada/system.ads ada/s-carun8.ads ada/s-exctab.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/types.adb \ + ada/unchconv.ads ada/unchdeal.ads + +ada/style.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/opt.ads \ + ada/output.ads ada/scans.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/sinput.adb ada/snames.ads ada/stand.ads ada/style.ads ada/style.adb \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/styleg.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/casing.ads \ + ada/csets.ads ada/debug.ads ada/einfo.ads ada/err_vars.ads \ + ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads ada/scans.ads \ + ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-exctab.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + +ada/stylesw.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads \ + ada/hostparm.ads ada/opt.ads ada/stylesw.ads ada/stylesw.adb \ + ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-string.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads + +ada/switch-b.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnatvsn.ads \ + ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads \ + ada/switch.ads ada/switch-b.ads ada/switch-b.adb ada/system.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads + +ada/switch-c.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnatvsn.ads \ + ada/hostparm.ads ada/lib.ads ada/namet.ads ada/opt.ads ada/osint.ads \ + ada/output.ads ada/prepcomp.ads ada/sem_warn.ads ada/stylesw.ads \ + ada/switch.ads ada/switch-c.ads ada/switch-c.adb ada/system.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/validsw.ads + +ada/switch.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnatvsn.ads \ + ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads \ + ada/switch.ads ada/switch.adb ada/system.ads ada/s-exctab.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads + +ada/system.o : ada/system.ads + +ada/table.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads ada/debug.ads \ + ada/hostparm.ads ada/opt.ads ada/output.ads ada/system.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-stalib.ads \ + ada/s-string.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads + +ada/targparm.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/csets.ads ada/debug.ads \ + ada/hostparm.ads ada/interfac.ads ada/namet.ads ada/namet.adb \ + ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads ada/system.ads \ + ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/targparm.adb \ + ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/widechar.ads + +ada/tbuild.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/elists.adb ada/fname.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ + ada/sem_aux.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/widechar.ads + +ada/tree_gen.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/elists.ads ada/fname.ads \ + ada/hostparm.ads ada/lib.ads ada/namet.ads ada/nlists.ads ada/opt.ads \ + ada/osint.ads ada/osint-c.ads ada/output.ads ada/repinfo.ads \ + ada/sem_aux.ads ada/sinfo.ads ada/sinput.ads ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_gen.ads ada/tree_gen.adb ada/tree_in.ads ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads + +ada/tree_in.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/elists.ads \ + ada/fname.ads ada/hostparm.ads ada/lib.ads ada/namet.ads ada/nlists.ads \ + ada/opt.ads ada/output.ads ada/repinfo.ads ada/sem_aux.ads \ + ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_in.ads ada/tree_in.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads + +ada/tree_io.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/debug.ads ada/hostparm.ads ada/output.ads \ + ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/tree_io.ads ada/tree_io.adb \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads + +ada/treepr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/elists.adb ada/fname.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/lib.ads \ + ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads ada/output.adb \ + ada/scil_ll.ads ada/sem_mech.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/treepr.ads ada/treepr.adb ada/treeprs.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + +ada/treeprs.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/opt.ads ada/output.ads ada/sinfo.ads ada/system.ads \ + ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/treeprs.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads + +ada/ttypes.o : ada/ada.ads ada/a-unccon.ads ada/get_targ.ads \ + ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \ + ada/ttypes.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads + +ada/types.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/system.ads \ + ada/s-carun8.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ + ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \ + ada/types.ads ada/types.adb ada/unchconv.ads ada/unchdeal.ads + +ada/uintp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/opt.ads ada/output.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ + ada/unchdeal.ads + +ada/uname.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/fname.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/uname.ads ada/uname.adb ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads + +ada/urealp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/opt.ads ada/output.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb + +ada/usage.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/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \ + ada/system.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/usage.ads ada/usage.adb + +ada/validsw.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads \ + ada/hostparm.ads ada/opt.ads ada/system.ads ada/s-exctab.ads \ + ada/s-stalib.ads ada/s-string.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/validsw.ads \ + ada/validsw.adb + +ada/widechar.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/hostparm.ads ada/interfac.ads ada/opt.ads \ + ada/system.ads ada/s-exctab.ads ada/s-parame.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcnv.ads \ + ada/s-wchcnv.adb ada/s-wchcon.ads ada/s-wchjis.ads ada/types.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads ada/widechar.adb + +# end of regular dependencies diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in new file mode 100644 index 000000000..77027dd82 --- /dev/null +++ b/gcc/ada/gcc-interface/Makefile.in @@ -0,0 +1,2836 @@ +# Makefile for GNU Ada Compiler (GNAT). +# Copyright (C) 1994-2010 Free Software Foundation, Inc. + +#This file is part of GCC. + +#GCC is free software; you can redistribute it and/or modify +#it under the terms of the GNU General Public License as published by +#the Free Software Foundation; either version 3, or (at your option) +#any later version. + +#GCC is distributed in the hope that it will be useful, +#but WITHOUT ANY WARRANTY; without even the implied warranty of +#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +#GNU General Public License for more details. + +#You should have received a copy of the GNU General Public License +#along with GCC; see the file COPYING3. If not see +#. + +# The makefile built from this file lives in the language subdirectory. +# Its purpose is to provide support for: +# +# 1) recursion where necessary, and only then (building .o's), and +# 2) building and debugging cc1 from the language subdirectory, and +# 3) nothing else. +# +# The parent makefile handles all other chores, with help from the +# language makefile fragment, of course. +# +# The targets for external use are: +# all, TAGS, ???mostlyclean, ???clean. + +# This makefile will only work with Gnu make. +# The rules are written assuming a minimum subset of tools are available: +# +# Required: +# MAKE: Only Gnu make will work. +# MV: Must accept (at least) one, maybe wildcard, source argument, +# a file or directory destination, and support creation/ +# modification date preservation. Gnu mv -f works. +# RM: Must accept an arbitrary number of space separated file +# arguments, or one wildcard argument. Gnu rm works. +# RMDIR: Must delete a directory and all its contents. Gnu rm -rf works. +# ECHO: Must support command line redirection. Any Unix-like +# shell will typically provide this, otherwise a custom version +# is trivial to write. +# AR: Gnu ar works. +# MKDIR: Gnu mkdir works. +# CHMOD: Gnu chmod works. +# true: Does nothing and returns a normal successful return code. +# pwd: Prints the current directory on stdout. +# cd: Change directory. +# +# Optional: +# BISON: Gnu bison works. +# FLEX: Gnu flex works. +# Other miscellaneous tools for obscure targets. + +# Suppress smart makes who think they know how to automake Yacc files +.y.c: + +# Variables that exist for you to override. +# See below for how to change them for certain systems. + +# Various ways of specifying flags for compilations: +# CFLAGS is for the user to override to, e.g., do a bootstrap with -O2. +# BOOT_CFLAGS is the value of CFLAGS to pass +# to the stage2 and stage3 compilations +CFLAGS = -g +BOOT_CFLAGS = -O $(CFLAGS) +# These exists to be overridden by the t-* files, respectively. +T_CFLAGS = + +CC = cc +BISON = bison +BISONFLAGS = +ECHO = echo +LEX = flex +LEXFLAGS = +CHMOD = chmod +LN = ln +LN_S = ln -s +CP = cp -p +MV = mv -f +RM = rm -f +RMDIR = rm -rf +MKDIR = mkdir -p +AR = ar +AR_FLAGS = rc +LS = ls +RANLIB = @RANLIB@ +RANLIB_FLAGS = @ranlib_flags@ +AWK = @AWK@ + +COMPILER = $(CC) +COMPILER_FLAGS = $(CFLAGS) + +SHELL = @SHELL@ +PWD_COMMAND = $${PWDCMD-pwd} +# How to copy preserving the date +INSTALL_DATA_DATE = cp -p +MAKEINFO = makeinfo +TEXI2DVI = texi2dvi +TEXI2PDF = texi2pdf +GNATBIND_FLAGS = -static -x +ADA_CFLAGS = +ADAFLAGS = -W -Wall -gnatpg -gnata +SOME_ADAFLAGS =-gnata +FORCE_DEBUG_ADAFLAGS = -g +GNATLIBFLAGS = -gnatpg -nostdinc +GNATLIBCFLAGS = -g -O2 +# Pretend that _Unwind_GetIPInfo is available for the target by default. This +# should be autodetected during the configuration of libada and passed down to +# here, but we need something for --disable-libada and hope for the best. +GNATLIBCFLAGS_FOR_C = $(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS) -fexceptions \ + -DIN_RTS -DHAVE_GETIPINFO +ALL_ADAFLAGS = $(CFLAGS) $(ADA_CFLAGS) $(ADAFLAGS) +MOST_ADAFLAGS = $(CFLAGS) $(ADA_CFLAGS) $(SOME_ADAFLAGS) +THREAD_KIND = native +THREADSLIB = +GMEM_LIB = +MISCLIB = +SYMDEPS = $(LIBINTL_DEP) +OUTPUT_OPTION = @OUTPUT_OPTION@ + +objext = .o +exeext = +arext = .a +soext = .so +shext = +hyphen = - + +# Define this as & to perform parallel make on a Sequent. +# Note that this has some bugs, and it seems currently necessary +# to compile all the gen* files first by hand to avoid erroneous results. +P = + +# This is used instead of ALL_CFLAGS when compiling with GCC_FOR_TARGET. +# It specifies -B./. +# It also specifies -B$(tooldir)/ to find as and ld for a cross compiler. +GCC_CFLAGS = $(INTERNAL_CFLAGS) $(T_CFLAGS) $(CFLAGS) + +# Tools to use when building a cross-compiler. +# These are used because `configure' appends `cross-make' +# to the makefile when making a cross-compiler. + +# We don't use cross-make. Instead we use the tools from the build tree, +# if they are available. +# program_transform_name and objdir are set by configure.in. +program_transform_name = +objdir = . + +target_alias=@target_alias@ +target=@target@ +xmake_file = @xmake_file@ +tmake_file = @tmake_file@ +host_canonical=@host@ +target_cpu_default=@target_cpu_default@ +#version=`sed -e 's/.*\"\([^ \"]*\)[ \"].*/\1/' < $(srcdir)/version.c` +#mainversion=`sed -e 's/.*\"\([0-9]*\.[0-9]*\).*/\1/' < $(srcdir)/version.c` + +# Directory where sources are, from where we are. +VPATH = $(srcdir)/ada + +fsrcdir := $(shell cd $(srcdir);${PWD_COMMAND}) +fsrcpfx := $(shell cd $(srcdir);${PWD_COMMAND})/ +fcurdir := $(shell ${PWD_COMMAND}) +fcurpfx := $(shell ${PWD_COMMAND})/ + +# Top build directory, relative to here. +top_builddir = ../.. + +# Internationalization library. +LIBINTL = @LIBINTL@ +LIBINTL_DEP = @LIBINTL_DEP@ + +# Any system libraries needed just for GNAT. +SYSLIBS = @GNAT_LIBEXC@ + +# List of extra object files linked in with various programs. +EXTRA_GNATTOOLS_OBJS = ../../prefix.o ../../version.o + +# List of target dependent sources, overridden below as necessary +TARGET_ADA_SRCS = + +# Type of tools build we are doing; default is not compiling tools. +TOOLSCASE = + +# Multilib handling +MULTISUBDIR = +RTSDIR = rts$(subst /,_,$(MULTISUBDIR)) + +# Link flags used to build gnat tools. By default we prefer to statically +# link with libgcc to avoid a dependency on shared libgcc (which is tricky +# to deal with as it may conflict with the libgcc provided by the system). +GCC_LINK_FLAGS=-static-libgcc + +# End of variables for you to override. + +all: all.indirect + +# This tells GNU Make version 3 not to put all variables in the environment. +.NOEXPORT: + +# target overrides +ifneq ($(tmake_file),) +include $(tmake_file) +endif + +# host overrides +ifneq ($(xmake_file),) +include $(xmake_file) +endif + +# Now figure out from those variables how to compile and link. + +all.indirect: Makefile ../gnat1$(exeext) + +# IN_GCC distinguishes between code compiled into GCC itself and other +# programs built during a bootstrap. +# autoconf inserts -DCROSS_DIRECTORY_STRUCTURE if we are building a cross +# compiler which does not use the native libraries and headers. +INTERNAL_CFLAGS = @CROSS@ -DIN_GCC + +# This is the variable actually used when we compile. +LOOSE_CFLAGS = `echo $(CFLAGS) $(WARN2_CFLAGS)|sed -e 's/-pedantic//g' -e 's/-Wtraditional//g'` +ALL_CFLAGS = $(INTERNAL_CFLAGS) $(T_CFLAGS) $(LOOSE_CFLAGS) + +# Likewise. +ALL_CPPFLAGS = $(CPPFLAGS) + +# Used with $(COMPILER). +ALL_COMPILERFLAGS = $(ALL_CFLAGS) + +# This is where we get libiberty.a from. +LIBIBERTY = ../../libiberty/libiberty.a + +# How to link with both our special library facilities +# and the system's installed libraries. +LIBS = $(LIBINTL) $(LIBIBERTY) $(SYSLIBS) +LIBDEPS = $(LIBINTL_DEP) $(LIBIBERTY) +# Default is no TGT_LIB; one might be passed down or something +TGT_LIB = +TOOLS_LIBS = $(EXTRA_GNATTOOLS_OBJS) targext.o link.o $(LIBGNAT) ../../../libiberty/libiberty.a $(SYSLIBS) $(TGT_LIB) + +# Specify the directories to be searched for header files. +# Both . and srcdir are used, in that order, +# so that tm.h and config.h will be found in the compilation +# subdirectory rather than in the source directory. +INCLUDES = -I- -I. -I.. -I$(srcdir)/ada -I$(srcdir) -I$(srcdir)/config \ + -I$(srcdir)/../include + +ADA_INCLUDES = -I- -I. -I$(srcdir)/ada + +INCLUDES_FOR_SUBDIR = -I. -I.. -I../.. -I$(fsrcdir)/ada \ + -I$(fsrcdir)/../include -I$(fsrcdir) +ADA_INCLUDES_FOR_SUBDIR = -I. -I$(fsrcdir)/ada + +# Avoid a lot of time thinking about remaking Makefile.in and *.def. +.SUFFIXES: .in .def + +# Say how to compile Ada programs. +.SUFFIXES: .ada .adb .ads .asm + +# Always use -I$(srcdir)/config when compiling. +.asm.o: + $(CC) -c -x assembler $< $(OUTPUT_OPTION) + +.c.o: + $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) $(ALL_CPPFLAGS) \ + $(INCLUDES) $< $(OUTPUT_OPTION) + +.adb.o: + $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + +.ads.o: + $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + +# how to regenerate this file +Makefile: ../config.status $(srcdir)/ada/gcc-interface/Makefile.in $(srcdir)/ada/Makefile.in $(srcdir)/version.c + cd ..; \ + LANGUAGES="$(CONFIG_LANGUAGES)" \ + CONFIG_HEADERS= \ + CONFIG_FILES="ada/gcc-interface/Makefile ada/Makefile" $(SHELL) config.status + +# This tells GNU make version 3 not to export all the variables +# defined in this file into the environment. +.NOEXPORT: + +# Lists of files for various purposes. + +GNATLINK_OBJS = gnatlink.o \ + a-except.o ali.o alloc.o butil.o casing.o csets.o debug.o fmap.o fname.o \ + gnatvsn.o hostparm.o indepsw.o interfac.o i-c.o i-cstrin.o namet.o opt.o \ + osint.o output.o rident.o s-exctab.o s-secsta.o s-stalib.o s-stoele.o \ + sdefault.o snames.o stylesw.o switch.o system.o table.o targparm.o tree_io.o \ + types.o validsw.o widechar.o + +GNATMAKE_OBJS = a-except.o ali.o ali-util.o aspects.o s-casuti.o \ + alloc.o atree.o binderr.o butil.o casing.o csets.o debug.o elists.o einfo.o\ + erroutc.o errutil.o err_vars.o fmap.o fname.o fname-uf.o fname-sf.o \ + gnatmake.o gnatvsn.o hostparm.o interfac.o i-c.o i-cstrin.o krunch.o lib.o \ + make.o makeusg.o makeutl.o mlib.o mlib-fil.o mlib-prj.o mlib-tgt.o \ + mlib-tgt-specific.o mlib-utl.o namet.o nlists.o opt.o osint.o osint-m.o \ + output.o prj.o prj-attr.o prj-attr-pm.o prj-com.o prj-dect.o prj-env.o \ + prj-conf.o prj-pp.o \ + prj-err.o prj-ext.o prj-nmsc.o prj-pars.o prj-part.o prj-proc.o prj-strt.o \ + prj-tree.o prj-util.o rident.o s-exctab.o s-secsta.o s-stalib.o s-stoele.o \ + scans.o scng.o sdefault.o sfn_scan.o s-purexc.o s-htable.o sinfo.o sinput.o \ + sinput-c.o sinput-p.o snames.o stand.o stringt.o styleg.o stylesw.o system.o \ + validsw.o switch.o switch-m.o table.o targparm.o tempdir.o tree_io.o types.o \ + uintp.o uname.o urealp.o usage.o widechar.o scil_ll.o \ + $(EXTRA_GNATMAKE_OBJS) + +# Convert the target variable into a space separated list of architecture, +# manufacturer, and operating system and assign each of those to its own +# variable. + +host:=$(subst -, ,$(host_canonical)) +targ:=$(subst -, ,$(target)) +arch:=$(word 1,$(targ)) +ifeq ($(words $(targ)),2) + manu:= + osys:=$(word 2,$(targ)) +else + manu:=$(word 2,$(targ)) + osys:=$(word 3,$(targ)) +endif + +# Make arch match the current multilib so that the RTS selection code +# picks up the right files. For a given target this must be coherent +# with MULTILIB_DIRNAMES defined in gcc/config/target/t-*. + +ifeq ($(strip $(filter-out %x86_64, $(arch))),) + ifeq ($(strip $(MULTISUBDIR)),/32) + arch:=i686 + endif +endif + +# ???: handle more multilib targets + +# LIBGNAT_TARGET_PAIRS is a list of pairs of filenames. +# The members of each pair must be separated by a '<' and no whitespace. +# Each pair must be separated by some amount of whitespace from the following +# pair. + +# Non-tasking case: + +LIBGNAT_TARGET_PAIRS = \ +a-intnam.ads s-oscons-tmplt.s + +else +# GCC_FOR_TARGET has paths relative to the gcc directory, so we need to adjust +# for running it from $(RTSDIR) +OSCONS_CC=`echo "$(GCC_FOR_TARGET)" \ + | sed -e 's^\./xgcc^../../xgcc^' -e 's^-B./^-B../../^'` +OSCONS_CPP=$(OSCONS_CC) $(GNATLIBCFLAGS) -E -C \ + -DTARGET=\"$(target)\" $(fsrcpfx)ada/s-oscons-tmplt.c > s-oscons-tmplt.i +OSCONS_EXTRACT=$(OSCONS_CC) -S s-oscons-tmplt.i +endif + +./bldtools/oscons/xoscons: xoscons.adb xutil.ads xutil.adb + -$(MKDIR) ./bldtools/oscons + $(RM) $(addprefix ./bldtools/oscons/,$(notdir $^)) + $(CP) $^ ./bldtools/oscons + (cd ./bldtools/oscons ; gnatmake -q xoscons) + +$(RTSDIR)/s-oscons.ads: ../stamp-gnatlib1-$(RTSDIR) s-oscons-tmplt.c gsocket.h ./bldtools/oscons/xoscons + $(RM) $(RTSDIR)/s-oscons-tmplt.i $(RTSDIR)/s-oscons-tmplt.s + (cd $(RTSDIR) ; \ + $(OSCONS_CPP) ; \ + $(OSCONS_EXTRACT) ; \ + ../bldtools/oscons/xoscons) + +# Don't use semicolon separated shell commands that involve list expansions. +# The semicolon triggers a call to DCL on VMS and DCL can't handle command +# line lengths in excess of 256 characters. +# Example: cd $(RTSDIR); ar rc libfoo.a $(LONG_LIST_OF_OBJS) +# is guaranteed to overflow the buffer. + +gnatlib: ../stamp-gnatlib1-$(RTSDIR) ../stamp-gnatlib2-$(RTSDIR) $(RTSDIR)/s-oscons.ads + $(MAKE) -C $(RTSDIR) \ + CC="`echo \"$(GCC_FOR_TARGET)\" \ + | sed -e 's,\./xgcc,../../xgcc,' -e 's,-B\./,-B../../,'`" \ + INCLUDES="$(INCLUDES_FOR_SUBDIR) -I./../.." \ + CFLAGS="$(GNATLIBCFLAGS_FOR_C)" \ + FORCE_DEBUG_ADAFLAGS="$(FORCE_DEBUG_ADAFLAGS)" \ + srcdir=$(fsrcdir) \ + -f ../Makefile $(LIBGNAT_OBJS) + $(MAKE) -C $(RTSDIR) \ + CC="`echo \"$(GCC_FOR_TARGET)\" \ + | sed -e 's,\./xgcc,../../xgcc,' -e 's,-B\./,-B../../,'`" \ + ADA_INCLUDES="" \ + CFLAGS="$(GNATLIBCFLAGS)" \ + ADAFLAGS="$(GNATLIBFLAGS)" \ + FORCE_DEBUG_ADAFLAGS="$(FORCE_DEBUG_ADAFLAGS)" \ + srcdir=$(fsrcdir) \ + -f ../Makefile \ + $(GNATRTL_OBJS) + $(RM) $(RTSDIR)/libgnat$(arext) $(RTSDIR)/libgnarl$(arext) + $(AR_FOR_TARGET) $(AR_FLAGS) $(RTSDIR)/libgnat$(arext) \ + $(addprefix $(RTSDIR)/,$(GNATRTL_NONTASKING_OBJS) $(LIBGNAT_OBJS)) + $(RANLIB_FOR_TARGET) $(RTSDIR)/libgnat$(arext) + $(AR_FOR_TARGET) $(AR_FLAGS) $(RTSDIR)/libgnarl$(arext) \ + $(addprefix $(RTSDIR)/,$(GNATRTL_TASKING_OBJS)) + $(RANLIB_FOR_TARGET) $(RTSDIR)/libgnarl$(arext) + $(AR_FOR_TARGET) $(AR_FLAGS) $(RTSDIR)/libgnala$(arext) \ + $(addprefix $(RTSDIR)/,$(GNATRTL_LINEARALGEBRA_OBJS)) + $(RANLIB_FOR_TARGET) $(RTSDIR)/libgnala$(arext) + ifeq ($(GMEM_LIB),gmemlib) + $(AR_FOR_TARGET) $(AR_FLAGS) $(RTSDIR)/libgmem$(arext) \ + $(RTSDIR)/memtrack.o + $(RANLIB_FOR_TARGET) $(RTSDIR)/libgmem$(arext) + endif + $(CHMOD) a-wx $(RTSDIR)/*.ali + touch ../stamp-gnatlib-$(RTSDIR) + +# Warning: this target assumes that LIBRARY_VERSION has been set correctly. +gnatlib-shared-default: + $(MAKE) $(FLAGS_TO_PASS) \ + GNATLIBFLAGS="$(GNATLIBFLAGS)" \ + GNATLIBCFLAGS="$(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS)" \ + GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C)" \ + MULTISUBDIR="$(MULTISUBDIR)" \ + THREAD_KIND="$(THREAD_KIND)" \ + gnatlib + $(RM) $(RTSDIR)/libgna*$(soext) + cd $(RTSDIR); ../../xgcc -B../../ -shared $(GNATLIBCFLAGS) \ + $(TARGET_LIBGCC2_CFLAGS) \ + -o libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) \ + $(GNATRTL_NONTASKING_OBJS) $(LIBGNAT_OBJS) \ + $(SO_OPTS)libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) \ + $(MISCLIB) -lm + cd $(RTSDIR); ../../xgcc -B../../ -shared $(GNATLIBCFLAGS) \ + $(TARGET_LIBGCC2_CFLAGS) \ + -o libgnarl$(hyphen)$(LIBRARY_VERSION)$(soext) \ + $(GNATRTL_TASKING_OBJS) \ + $(SO_OPTS)libgnarl$(hyphen)$(LIBRARY_VERSION)$(soext) \ + $(THREADSLIB) + cd $(RTSDIR); $(LN_S) libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) \ + libgnat$(soext) + cd $(RTSDIR); $(LN_S) libgnarl$(hyphen)$(LIBRARY_VERSION)$(soext) \ + libgnarl$(soext) + +gnatlib-shared-dual: + $(MAKE) $(FLAGS_TO_PASS) \ + GNATLIBFLAGS="$(GNATLIBFLAGS)" \ + GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ + GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C)" \ + MULTISUBDIR="$(MULTISUBDIR)" \ + THREAD_KIND="$(THREAD_KIND)" \ + gnatlib-shared-default + $(MV) $(RTSDIR)/libgna*$(soext) . + $(RM) ../stamp-gnatlib2-$(RTSDIR) + $(MAKE) $(FLAGS_TO_PASS) \ + GNATLIBFLAGS="$(GNATLIBFLAGS)" \ + GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ + GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C)" \ + MULTISUBDIR="$(MULTISUBDIR)" \ + THREAD_KIND="$(THREAD_KIND)" \ + gnatlib + $(MV) libgna*$(soext) $(RTSDIR) + +gnatlib-shared-dual-win32: + $(MAKE) $(FLAGS_TO_PASS) \ + GNATLIBFLAGS="$(GNATLIBFLAGS)" \ + GNATLIBCFLAGS="$(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS)" \ + GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C)" \ + MULTISUBDIR="$(MULTISUBDIR)" \ + THREAD_KIND="$(THREAD_KIND)" \ + gnatlib-shared-win32 + $(MV) $(RTSDIR)/libgna*$(soext) . + $(RM) ../stamp-gnatlib2-$(RTSDIR) + $(MAKE) $(FLAGS_TO_PASS) \ + GNATLIBFLAGS="$(GNATLIBFLAGS)" \ + GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ + GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C)" \ + MULTISUBDIR="$(MULTISUBDIR)" \ + THREAD_KIND="$(THREAD_KIND)" \ + gnatlib + $(MV) libgna*$(soext) $(RTSDIR) + +# ??? we need to add the option to support auto-import of arrays/records to +# the GNATLIBFLAGS when this will be supported by GNAT. At this point we will +# use the gnatlib-shared-dual-win32 target to build the GNAT runtimes on +# Windows. +gnatlib-shared-win32: + $(MAKE) $(FLAGS_TO_PASS) \ + GNATLIBFLAGS="$(GNATLIBFLAGS)" \ + GNATLIBCFLAGS="$(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS)" \ + GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C)" \ + MULTISUBDIR="$(MULTISUBDIR)" \ + THREAD_KIND="$(THREAD_KIND)" \ + gnatlib + $(RM) $(RTSDIR)/libgna*$(soext) + cd $(RTSDIR); ../../xgcc -B../../ -shared -shared-libgcc \ + $(TARGET_LIBGCC2_CFLAGS) \ + -o libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) \ + $(GNATRTL_NONTASKING_OBJS) $(LIBGNAT_OBJS) \ + $(SO_OPTS)libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) $(MISCLIB) + cd $(RTSDIR); ../../xgcc -B../../ -shared -shared-libgcc \ + $(TARGET_LIBGCC2_CFLAGS) \ + -o libgnarl$(hyphen)$(LIBRARY_VERSION)$(soext) \ + $(GNATRTL_TASKING_OBJS) \ + $(SO_OPTS)libgnarl$(hyphen)$(LIBRARY_VERSION)$(soext) \ + $(THREADSLIB) -Wl,libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) + +gnatlib-shared-darwin: + $(MAKE) $(FLAGS_TO_PASS) \ + GNATLIBFLAGS="$(GNATLIBFLAGS)" \ + GNATLIBCFLAGS="$(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS)" \ + GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C) -fno-common" \ + MULTISUBDIR="$(MULTISUBDIR)" \ + THREAD_KIND="$(THREAD_KIND)" \ + gnatlib + $(RM) $(RTSDIR)/libgnat$(soext) $(RTSDIR)/libgnarl$(soext) + cd $(RTSDIR); ../../xgcc -B../../ -dynamiclib $(TARGET_LIBGCC2_CFLAGS) \ + -o libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) \ + $(GNATRTL_NONTASKING_OBJS) $(LIBGNAT_OBJS) \ + $(SO_OPTS) \ + -Wl,-install_name,@rpath/libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) \ + $(MISCLIB) -lm + cd $(RTSDIR); ../../xgcc -B../../ -dynamiclib $(TARGET_LIBGCC2_CFLAGS) \ + -o libgnarl$(hyphen)$(LIBRARY_VERSION)$(soext) \ + $(GNATRTL_TASKING_OBJS) \ + $(SO_OPTS) \ + -Wl,-install_name,@rpath/libgnarl$(hyphen)$(LIBRARY_VERSION)$(soext) \ + $(THREADSLIB) -Wl,libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) + cd $(RTSDIR); $(LN_S) libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) \ + libgnat$(soext) + cd $(RTSDIR); $(LN_S) libgnarl$(hyphen)$(LIBRARY_VERSION)$(soext) \ + libgnarl$(soext) + cd $(RTSDIR); dsymutil libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) + cd $(RTSDIR); dsymutil libgnarl$(hyphen)$(LIBRARY_VERSION)$(soext) + +gnatlib-shared-vms: + $(MAKE) $(FLAGS_TO_PASS) \ + GNATLIBFLAGS="$(GNATLIBFLAGS)" \ + GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ + GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C)" \ + MULTISUBDIR="$(MULTISUBDIR)" \ + THREAD_KIND="$(THREAD_KIND)" \ + gnatlib + $(RM) $(RTSDIR)/libgna*$(soext) + cd $(RTSDIR) && \ + ../../gnatsym -s SYMVEC_$$$$.opt \ + $(LIBGNAT_OBJS) $(GNATRTL_NONTASKING_OBJS) && \ + ../../xgcc -g -B../../ -shared -shared-libgcc \ + -o libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) libgnat.a \ + sys\$$library:trace.exe \ + --for-linker=/noinform \ + --for-linker=SYMVEC_$$$$.opt \ + --for-linker=gsmatch=equal,$(GSMATCH_VERSION) + cd $(RTSDIR) && \ + ../../gnatsym -s SYMVEC_$$$$.opt \ + $(GNATRTL_TASKING_OBJS) && \ + ../../xgcc -g -B../../ -shared -shared-libgcc \ + -o libgnarl$(hyphen)$(LIBRARY_VERSION)$(soext) \ + libgnarl.a libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) \ + sys\$$library:trace.exe \ + --for-linker=/noinform \ + --for-linker=SYMVEC_$$$$.opt \ + --for-linker=gsmatch=equal,$(GSMATCH_VERSION) + +gnatlib-shared: + $(MAKE) $(FLAGS_TO_PASS) \ + GNATLIBFLAGS="$(GNATLIBFLAGS)" \ + GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ + GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C)" \ + MULTISUBDIR="$(MULTISUBDIR)" \ + THREAD_KIND="$(THREAD_KIND)" \ + TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" \ + $(GNATLIB_SHARED) + +gnatlib-sjlj: + $(MAKE) $(FLAGS_TO_PASS) EH_MECHANISM="" \ + THREAD_KIND="$(THREAD_KIND)" ../stamp-gnatlib1-$(RTSDIR) + sed -e 's/ZCX_By_Default.*/ZCX_By_Default : constant Boolean := False;/' $(RTSDIR)/system.ads > $(RTSDIR)/s.ads + $(MV) $(RTSDIR)/s.ads $(RTSDIR)/system.ads + $(MAKE) $(FLAGS_TO_PASS) \ + EH_MECHANISM="" \ + GNATLIBFLAGS="$(GNATLIBFLAGS)" \ + GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ + GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C)" \ + MULTISUBDIR="$(MULTISUBDIR)" \ + THREAD_KIND="$(THREAD_KIND)" \ + TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" gnatlib + +gnatlib-zcx: + $(MAKE) $(FLAGS_TO_PASS) EH_MECHANISM="-gcc" \ + THREAD_KIND="$(THREAD_KIND)" ../stamp-gnatlib1-$(RTSDIR) + sed -e 's/ZCX_By_Default.*/ZCX_By_Default : constant Boolean := True;/' $(RTSDIR)/system.ads > $(RTSDIR)/s.ads + $(MV) $(RTSDIR)/s.ads $(RTSDIR)/system.ads + $(MAKE) $(FLAGS_TO_PASS) \ + EH_MECHANISM="-gcc" \ + GNATLIBFLAGS="$(GNATLIBFLAGS)" \ + GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ + GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C)" \ + MULTISUBDIR="$(MULTISUBDIR)" \ + THREAD_KIND="$(THREAD_KIND)" \ + TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" gnatlib + +# .s files for cross-building +gnat-cross: force + make $(GNAT1_ADA_OBJS) CC="gcc -B../stage1/" CFLAGS="-S -gnatp" + +# Compiling object files from source files. + +# Note that dependencies on obstack.h are not written +# because that file is not part of GCC. +# Dependencies on gvarargs.h are not written +# because all that file does, when not compiling with GCC, +# is include the system varargs.h. + +b_gnatl.c : $(GNATLINK_OBJS) + $(GNATBIND) -C $(ADA_INCLUDES) -o b_gnatl.c gnatlink.ali +b_gnatl.o : b_gnatl.c + +b_gnatm.c : $(GNATMAKE_OBJS) + $(GNATBIND) -C $(ADA_INCLUDES) -o b_gnatm.c gnatmake.ali +b_gnatm.o : b_gnatm.c + +ADA_INCLUDE_DIR = $(libsubdir)/adainclude +ADA_RTL_OBJ_DIR = $(libsubdir)/adalib + +# force no sibling call optimization on s-traceb.o so the number of stack +# frames to be skipped when computing a call chain is not modified by +# optimization. However we can do that only when building the runtime +# (not the compiler) because the -fno-optimize-sibling-calls option exists +# only in GCC 3 and above. + +ifneq (,$(findstring xgcc,$(CC))) +NO_SIBLING_ADAFLAGS=-fno-optimize-sibling-calls +else +NO_SIBLING_ADAFLAGS= +endif + +s-traceb.o : s-traceb.adb + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) \ + $(NO_SIBLING_ADAFLAGS) $(ADA_INCLUDES) \ + $< $(OUTPUT_OPTION) + +# force debugging information on s-tasdeb.o so that it is always +# possible to set conditional breakpoints on tasks. + +s-tasdeb.o : s-tasdeb.adb s-tasdeb.ads + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) \ + $< $(OUTPUT_OPTION) + +# force no function reordering on a-except.o because of the exclusion bounds +# mechanism (see the source file for more detailed information). + +NO_REORDER_ADAFLAGS=-fno-toplevel-reorder + +# force debugging information on a-except.o so that it is always +# possible to set conditional breakpoints on exceptions. +# use -O1 otherwise gdb isn't able to get a full backtrace on mips targets. + +a-except.o : a-except.adb a-except.ads + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O1 -fno-inline \ + $(NO_REORDER_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + +# compile s-except.o without optimization and with debug info to let the +# debugger set breakpoints and inspect subprogram parameters on exception +# related events. + +s-except.o : s-except.adb s-except.ads + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) \ + $< $(OUTPUT_OPTION) + +# force debugging information on s-assert.o so that it is always +# possible to set breakpoint on assert failures. + +s-assert.o : s-assert.adb s-assert.ads a-except.ads + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O2 $(ADA_INCLUDES) \ + $< $(OUTPUT_OPTION) + +adadecode.o : adadecode.c adadecode.h +aux-io.o : aux-io.c +argv.o : argv.c +cal.o : cal.c +deftarg.o : deftarg.c +errno.o : errno.c +exit.o : adaint.h exit.c +expect.o : expect.c +final.o : final.c +link.o : link.c +locales.o : locales.c +mkdir.o : mkdir.c +socket.o : socket.c gsocket.h +sysdep.o : sysdep.c +raise-gcc.o : raise-gcc.c raise.h +raise.o : raise.c raise.h +vx_stack_info.o : vx_stack_info.c + +cio.o : cio.c + $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) \ + $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) + +init.o : init.c adaint.h raise.h + $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) \ + $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) + +initialize.o : initialize.c raise.h + $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) \ + $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) + +targext.o : targext.c + $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) \ + $(ALL_CPPFLAGS) $(INCLUDES_FOR_SUBDIR) \ + $< $(OUTPUT_OPTION) + +# Need to keep the frame pointer in this file to pop the stack properly on +# some targets. +tracebak.o : tracebak.c tb-alvms.c tb-alvxw.c tb-gcc.c + $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) $(ALL_CPPFLAGS) \ + $(INCLUDES) -fno-omit-frame-pointer $< $(OUTPUT_OPTION) + +# In GNU Make, ignore whether `stage*' exists. +.PHONY: stage1 stage2 stage3 stage4 clean realclean TAGS bootstrap +.PHONY: risky-stage1 risky-stage2 risky-stage3 risky-stage4 + +force: diff --git a/gcc/ada/gcc-interface/ada-tree.def b/gcc/ada/gcc-interface/ada-tree.def new file mode 100644 index 000000000..93967b58c --- /dev/null +++ b/gcc/ada/gcc-interface/ada-tree.def @@ -0,0 +1,74 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * GNAT-SPECIFIC GCC TREE CODES * + * * + * Specification * + * * + * Copyright (C) 1992-2009, Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License along with GCC; see the file COPYING3. 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 type that is an unconstrained array. This node is never passed to GCC. + TREE_TYPE is the type of the fat pointer and TYPE_OBJECT_RECORD_TYPE is + the type of a record containing the template and data. */ +DEFTREECODE (UNCONSTRAINED_ARRAY_TYPE, "unconstrained_array_type", tcc_type, 0) + +/* A reference to an unconstrained array. This node only exists as an + intermediate node during the translation of a GNAT tree to a GCC tree; + it is never passed to GCC. The only field used is operand 0, which + is the fat pointer object. */ +DEFTREECODE (UNCONSTRAINED_ARRAY_REF, "unconstrained_array_ref", + tcc_reference, 1) + +/* An expression that returns an RTL suitable for its type. Operand 0 + is an expression to be evaluated for side effects only. */ +DEFTREECODE (NULL_EXPR, "null_expr", tcc_expression, 1) + +/* Same as PLUS_EXPR, except that no modulo reduction is applied. + This is used for loops and never shows up in the tree. */ +DEFTREECODE (PLUS_NOMOD_EXPR, "plus_nomod_expr", tcc_binary, 2) + +/* Same as MINUS_EXPR, except that no modulo reduction is applied. + This is used for loops and never shows up in the tree. */ +DEFTREECODE (MINUS_NOMOD_EXPR, "minus_nomod_expr", tcc_binary, 2) + +/* Same as ADDR_EXPR, except that if the operand represents a bit field, + return the address of the byte containing the bit. This is used + for the Address attribute and never shows up in the tree. */ +DEFTREECODE (ATTR_ADDR_EXPR, "attr_addr_expr", tcc_reference, 1) + +/* Here are the tree codes for the statement types known to Ada. These + must be at the end of this file to allow IS_ADA_STMT to work. */ + +/* This is how record_code_position and insert_code_for work. The former + makes this tree node, whose operand is a statement. The latter inserts + the actual statements into this node. Gimplification consists of + just returning the inner statement. */ +DEFTREECODE (STMT_STMT, "stmt_stmt", tcc_statement, 1) + +/* A loop. LOOP_STMT_COND is the test to exit the loop. LOOP_STMT_UPDATE + is the statement to update the loop iteration variable at the continue + point. LOOP_STMT_BODY are the statements in the body of the loop. And + LOOP_STMT_LABEL points to the LABEL_DECL of the end label of the loop. */ +DEFTREECODE (LOOP_STMT, "loop_stmt", tcc_statement, 4) + +/* Conditionally exit a loop. EXIT_STMT_COND is the condition, which, if + true, will cause the loop to be exited. If no condition is specified, + the loop is unconditionally exited. EXIT_STMT_LABEL is the end label + corresponding to the loop to exit. */ +DEFTREECODE (EXIT_STMT, "exit_stmt", tcc_statement, 2) diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h new file mode 100644 index 000000000..9002fa1c7 --- /dev/null +++ b/gcc/ada/gcc-interface/ada-tree.h @@ -0,0 +1,454 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * A D A - T R E E * + * * + * C Header File * + * * + * 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. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License along with GCC; see the file COPYING3. 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 resulting tree type. */ +union GTY((desc ("0"), + chain_next ("(union lang_tree_node *)TREE_CHAIN (&%h.generic)"))) + lang_tree_node +{ + union tree_node GTY((tag ("0"), + desc ("tree_node_structure (&%h)"))) generic; +}; + +/* Ada uses the lang_decl and lang_type fields to hold a tree. + + FIXME: the variable_size annotation here is needed because these types are + variable-sized in some other front-ends. Due to gengtype deficiency, the + GTY options of such types have to agree across all front-ends. */ +struct GTY((variable_size)) lang_type { tree t; }; +struct GTY((variable_size)) lang_decl { tree t; }; + +/* Macros to get and set the tree in TYPE_LANG_SPECIFIC. */ +#define GET_TYPE_LANG_SPECIFIC(NODE) \ + (TYPE_LANG_SPECIFIC (NODE) ? TYPE_LANG_SPECIFIC (NODE)->t : NULL_TREE) + +#define SET_TYPE_LANG_SPECIFIC(NODE, X) \ +do { \ + tree tmp = (X); \ + if (!TYPE_LANG_SPECIFIC (NODE)) \ + TYPE_LANG_SPECIFIC (NODE) \ + = ggc_alloc_lang_type (sizeof (struct lang_type)); \ + TYPE_LANG_SPECIFIC (NODE)->t = tmp; \ +} while (0) + +/* Macros to get and set the tree in DECL_LANG_SPECIFIC. */ +#define GET_DECL_LANG_SPECIFIC(NODE) \ + (DECL_LANG_SPECIFIC (NODE) ? DECL_LANG_SPECIFIC (NODE)->t : NULL_TREE) + +#define SET_DECL_LANG_SPECIFIC(NODE, X) \ +do { \ + tree tmp = (X); \ + if (!DECL_LANG_SPECIFIC (NODE)) \ + DECL_LANG_SPECIFIC (NODE) \ + = ggc_alloc_lang_decl (sizeof (struct lang_decl)); \ + DECL_LANG_SPECIFIC (NODE)->t = tmp; \ +} while (0) + + +/* Flags added to type nodes. */ + +/* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this is a + record being used as a fat pointer (only true for RECORD_TYPE). */ +#define TYPE_FAT_POINTER_P(NODE) \ + TYPE_LANG_FLAG_0 (RECORD_OR_UNION_CHECK (NODE)) + +#define TYPE_IS_FAT_POINTER_P(NODE) \ + (TREE_CODE (NODE) == RECORD_TYPE && TYPE_FAT_POINTER_P (NODE)) + +/* For integral types and array types, nonzero if this is a packed array type + used for bit-packed types. Such types should not be extended to a larger + size or validated against a specified size. */ +#define TYPE_PACKED_ARRAY_TYPE_P(NODE) TYPE_LANG_FLAG_0 (NODE) + +#define TYPE_IS_PACKED_ARRAY_TYPE_P(NODE) \ + ((TREE_CODE (NODE) == INTEGER_TYPE || TREE_CODE (NODE) == ARRAY_TYPE) \ + && TYPE_PACKED_ARRAY_TYPE_P (NODE)) + +/* For INTEGER_TYPE, nonzero if this is a modular type with a modulus that + is not equal to two to the power of its mode's size. */ +#define TYPE_MODULAR_P(NODE) TYPE_LANG_FLAG_1 (INTEGER_TYPE_CHECK (NODE)) + +/* For ARRAY_TYPE, nonzero if this type corresponds to a dimension of + an Ada array other than the first. */ +#define TYPE_MULTI_ARRAY_P(NODE) TYPE_LANG_FLAG_1 (ARRAY_TYPE_CHECK (NODE)) + +/* For FUNCTION_TYPE, nonzero if this denotes a function returning an + unconstrained array or record. */ +#define TYPE_RETURN_UNCONSTRAINED_P(NODE) \ + TYPE_LANG_FLAG_1 (FUNCTION_TYPE_CHECK (NODE)) + +/* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this denotes + a justified modular type (will only be true for RECORD_TYPE). */ +#define TYPE_JUSTIFIED_MODULAR_P(NODE) \ + TYPE_LANG_FLAG_1 (RECORD_OR_UNION_CHECK (NODE)) + +/* Nonzero in an arithmetic subtype if this is a subtype not known to the + front-end. */ +#define TYPE_EXTRA_SUBTYPE_P(NODE) TYPE_LANG_FLAG_2 (NODE) + +/* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this is the + type for an object whose type includes its template in addition to + its value (only true for RECORD_TYPE). */ +#define TYPE_CONTAINS_TEMPLATE_P(NODE) \ + TYPE_LANG_FLAG_3 (RECORD_OR_UNION_CHECK (NODE)) + +/* For INTEGER_TYPE, nonzero if this really represents a VAX + floating-point type. */ +#define TYPE_VAX_FLOATING_POINT_P(NODE) \ + TYPE_LANG_FLAG_3 (INTEGER_TYPE_CHECK (NODE)) + +/* True if NODE is a thin pointer. */ +#define TYPE_IS_THIN_POINTER_P(NODE) \ + (POINTER_TYPE_P (NODE) \ + && TREE_CODE (TREE_TYPE (NODE)) == RECORD_TYPE \ + && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (NODE))) + +/* True if TYPE is either a fat or thin pointer to an unconstrained + array. */ +#define TYPE_IS_FAT_OR_THIN_POINTER_P(NODE) \ + (TYPE_IS_FAT_POINTER_P (NODE) || TYPE_IS_THIN_POINTER_P (NODE)) + +/* For INTEGER_TYPEs, nonzero if the type has a biased representation. */ +#define TYPE_BIASED_REPRESENTATION_P(NODE) \ + TYPE_LANG_FLAG_4 (INTEGER_TYPE_CHECK (NODE)) + +/* For ARRAY_TYPEs, nonzero if the array type has Convention_Fortran. */ +#define TYPE_CONVENTION_FORTRAN_P(NODE) \ + TYPE_LANG_FLAG_4 (ARRAY_TYPE_CHECK (NODE)) + +/* For FUNCTION_TYPEs, nonzero if the function returns by direct reference, + i.e. the callee returns a pointer to a memory location it has allocated + and the caller only needs to dereference the pointer. */ +#define TYPE_RETURN_BY_DIRECT_REF_P(NODE) \ + TYPE_LANG_FLAG_4 (FUNCTION_TYPE_CHECK (NODE)) + +/* For VOID_TYPE, ENUMERAL_TYPE, UNION_TYPE, and RECORD_TYPE, nonzero if this + is a dummy type, made to correspond to a private or incomplete type. */ +#define TYPE_DUMMY_P(NODE) TYPE_LANG_FLAG_4 (NODE) + +#define TYPE_IS_DUMMY_P(NODE) \ + ((TREE_CODE (NODE) == VOID_TYPE || TREE_CODE (NODE) == RECORD_TYPE \ + || TREE_CODE (NODE) == UNION_TYPE || TREE_CODE (NODE) == ENUMERAL_TYPE) \ + && TYPE_DUMMY_P (NODE)) + +/* For an INTEGER_TYPE, nonzero if TYPE_ACTUAL_BOUNDS is present. */ +#define TYPE_HAS_ACTUAL_BOUNDS_P(NODE) \ + TYPE_LANG_FLAG_5 (INTEGER_TYPE_CHECK (NODE)) + +/* For a RECORD_TYPE, nonzero if this was made just to supply needed + padding or alignment. */ +#define TYPE_PADDING_P(NODE) TYPE_LANG_FLAG_5 (RECORD_TYPE_CHECK (NODE)) + +#define TYPE_IS_PADDING_P(NODE) \ + (TREE_CODE (NODE) == RECORD_TYPE && TYPE_PADDING_P (NODE)) + +/* True if TYPE can alias any other types. */ +#define TYPE_UNIVERSAL_ALIASING_P(NODE) TYPE_LANG_FLAG_6 (NODE) + +/* In an UNCONSTRAINED_ARRAY_TYPE, this is the record containing both the + template and the object. + + ??? We also put this on an ENUMERAL_TYPE that is dummy. Technically, + this is a conflict on the minval field, but there doesn't seem to be + simple fix, so we'll live with this kludge for now. */ +#define TYPE_OBJECT_RECORD_TYPE(NODE) \ + (TREE_CHECK2 ((NODE), UNCONSTRAINED_ARRAY_TYPE, ENUMERAL_TYPE)->type.minval) + +/* For numerical types, this is the GCC lower bound of the type. The GCC + type system is based on the invariant that an object X of a given type + cannot hold at run time a value smaller than its lower bound; otherwise + the behavior is undefined. The optimizer takes advantage of this and + considers that the assertion X >= LB is always true. */ +#define TYPE_GCC_MIN_VALUE(NODE) (NUMERICAL_TYPE_CHECK (NODE)->type.minval) + +/* For numerical types, this is the GCC upper bound of the type. The GCC + type system is based on the invariant that an object X of a given type + cannot hold at run time a value larger than its upper bound; otherwise + the behavior is undefined. The optimizer takes advantage of this and + considers that the assertion X <= UB is always true. */ +#define TYPE_GCC_MAX_VALUE(NODE) (NUMERICAL_TYPE_CHECK (NODE)->type.maxval) + +/* For a FUNCTION_TYPE, if the subprogram has parameters passed by copy in/ + copy out, this is the list of nodes used to specify the return values of + the out (or in out) parameters that are passed by copy in/copy out. For + a full description of the copy in/copy out parameter passing mechanism + refer to the routine gnat_to_gnu_entity. */ +#define TYPE_CI_CO_LIST(NODE) TYPE_LANG_SLOT_1 (FUNCTION_TYPE_CHECK (NODE)) + +/* For a VECTOR_TYPE, this is the representative array type. */ +#define TYPE_REPRESENTATIVE_ARRAY(NODE) \ + TYPE_LANG_SLOT_1 (VECTOR_TYPE_CHECK (NODE)) + +/* For numerical types, this holds various RM-defined values. */ +#define TYPE_RM_VALUES(NODE) TYPE_LANG_SLOT_1 (NUMERICAL_TYPE_CHECK (NODE)) + +/* Macros to get and set the individual values in TYPE_RM_VALUES. */ +#define TYPE_RM_VALUE(NODE, N) \ + (TYPE_RM_VALUES (NODE) \ + ? TREE_VEC_ELT (TYPE_RM_VALUES (NODE), (N)) : NULL_TREE) + +#define SET_TYPE_RM_VALUE(NODE, N, X) \ +do { \ + tree tmp = (X); \ + if (!TYPE_RM_VALUES (NODE)) \ + TYPE_RM_VALUES (NODE) = make_tree_vec (3); \ + /* ??? The field is not visited by the generic \ + code so we need to mark it manually. */ \ + MARK_VISITED (tmp); \ + TREE_VEC_ELT (TYPE_RM_VALUES (NODE), (N)) = tmp; \ +} while (0) + +/* For numerical types, this is the RM size of the type, aka its precision. + There is a discrepancy between what is called precision here (and more + generally throughout gigi) and what is called precision in the GCC type + system: in the former case it's TYPE_RM_SIZE whereas it's TYPE_PRECISION + in the latter case. They are not identical because of the need to support + invalid values. + + These values can be outside the range of values allowed by the RM size + but they must nevertheless be valid in the GCC type system, otherwise + the optimizer can pretend that they simply don't exist. Therefore they + must be within the range of values allowed by the precision in the GCC + sense, hence TYPE_PRECISION be set to the Esize, not the RM size. */ +#define TYPE_RM_SIZE(NODE) TYPE_RM_VALUE ((NODE), 0) +#define SET_TYPE_RM_SIZE(NODE, X) SET_TYPE_RM_VALUE ((NODE), 0, (X)) + +/* For numerical types, this is the RM lower bound of the type. There is + again a discrepancy between this lower bound and the GCC lower bound, + again because of the need to support invalid values. + + These values can be outside the range of values allowed by the RM lower + bound but they must nevertheless be valid in the GCC type system, otherwise + the optimizer can pretend that they simply don't exist. Therefore they + must be within the range of values allowed by the lower bound in the GCC + sense, hence the GCC lower bound be set to that of the base type. */ +#define TYPE_RM_MIN_VALUE(NODE) TYPE_RM_VALUE ((NODE), 1) +#define SET_TYPE_RM_MIN_VALUE(NODE, X) SET_TYPE_RM_VALUE ((NODE), 1, (X)) + +/* For numerical types, this is the RM upper bound of the type. There is + again a discrepancy between this upper bound and the GCC upper bound, + again because of the need to support invalid values. + + These values can be outside the range of values allowed by the RM upper + bound but they must nevertheless be valid in the GCC type system, otherwise + the optimizer can pretend that they simply don't exist. Therefore they + must be within the range of values allowed by the upper bound in the GCC + sense, hence the GCC upper bound be set to that of the base type. */ +#define TYPE_RM_MAX_VALUE(NODE) TYPE_RM_VALUE ((NODE), 2) +#define SET_TYPE_RM_MAX_VALUE(NODE, X) SET_TYPE_RM_VALUE ((NODE), 2, (X)) + +/* For numerical types, this is the lower bound of the type, i.e. the RM lower + bound for language-defined types and the GCC lower bound for others. */ +#undef TYPE_MIN_VALUE +#define TYPE_MIN_VALUE(NODE) \ + (TYPE_RM_MIN_VALUE (NODE) \ + ? TYPE_RM_MIN_VALUE (NODE) : TYPE_GCC_MIN_VALUE (NODE)) + +/* For numerical types, this is the upper bound of the type, i.e. the RM upper + bound for language-defined types and the GCC upper bound for others. */ +#undef TYPE_MAX_VALUE +#define TYPE_MAX_VALUE(NODE) \ + (TYPE_RM_MAX_VALUE (NODE) \ + ? TYPE_RM_MAX_VALUE (NODE) : TYPE_GCC_MAX_VALUE (NODE)) + +/* For an INTEGER_TYPE with TYPE_MODULAR_P, this is the value of the + modulus. */ +#define TYPE_MODULUS(NODE) GET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) +#define SET_TYPE_MODULUS(NODE, X) \ + SET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE), X) + +/* For an INTEGER_TYPE with TYPE_VAX_FLOATING_POINT_P, this is the + Digits_Value. */ +#define TYPE_DIGITS_VALUE(NODE) \ + GET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) +#define SET_TYPE_DIGITS_VALUE(NODE, X) \ + SET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE), X) + +/* For an INTEGER_TYPE that is the TYPE_DOMAIN of some ARRAY_TYPE, this is + the type corresponding to the Ada index type. */ +#define TYPE_INDEX_TYPE(NODE) \ + GET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) +#define SET_TYPE_INDEX_TYPE(NODE, X) \ + SET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE), X) + +/* For an INTEGER_TYPE with TYPE_HAS_ACTUAL_BOUNDS_P or an ARRAY_TYPE, this is + the index type that should be used when the actual bounds are required for + a template. This is used in the case of packed arrays. */ +#define TYPE_ACTUAL_BOUNDS(NODE) \ + GET_TYPE_LANG_SPECIFIC (TREE_CHECK2 (NODE, INTEGER_TYPE, ARRAY_TYPE)) +#define SET_TYPE_ACTUAL_BOUNDS(NODE, X) \ + SET_TYPE_LANG_SPECIFIC (TREE_CHECK2 (NODE, INTEGER_TYPE, ARRAY_TYPE), X) + +/* For a RECORD_TYPE that is a fat pointer, this is the type for the + unconstrained object. Likewise for a RECORD_TYPE that is pointed + to by a thin pointer. */ +#define TYPE_UNCONSTRAINED_ARRAY(NODE) \ + GET_TYPE_LANG_SPECIFIC (RECORD_TYPE_CHECK (NODE)) +#define SET_TYPE_UNCONSTRAINED_ARRAY(NODE, X) \ + SET_TYPE_LANG_SPECIFIC (RECORD_TYPE_CHECK (NODE), X) + +/* For other RECORD_TYPEs and all UNION_TYPEs and QUAL_UNION_TYPEs, this is + the Ada size of the object. This differs from the GCC size in that it + does not include any rounding up to the alignment of the type. */ +#define TYPE_ADA_SIZE(NODE) \ + GET_TYPE_LANG_SPECIFIC (RECORD_OR_UNION_CHECK (NODE)) +#define SET_TYPE_ADA_SIZE(NODE, X) \ + SET_TYPE_LANG_SPECIFIC (RECORD_OR_UNION_CHECK (NODE), X) + + +/* Flags added to decl nodes. */ + +/* Nonzero in a FUNCTION_DECL that represents a stubbed function + discriminant. */ +#define DECL_STUBBED_P(NODE) DECL_LANG_FLAG_0 (FUNCTION_DECL_CHECK (NODE)) + +/* Nonzero in a VAR_DECL if it is guaranteed to be constant after having + been elaborated and TREE_READONLY is not set on it. */ +#define DECL_READONLY_ONCE_ELAB(NODE) DECL_LANG_FLAG_0 (VAR_DECL_CHECK (NODE)) + +/* Nonzero in a CONST_DECL if its value is (essentially) the address of a + constant CONSTRUCTOR. */ +#define DECL_CONST_ADDRESS_P(NODE) DECL_LANG_FLAG_0 (CONST_DECL_CHECK (NODE)) + +/* Nonzero in a PARM_DECL if it is always used by double reference, i.e. a + pair of INDIRECT_REFs is needed to access the object. */ +#define DECL_BY_DOUBLE_REF_P(NODE) DECL_LANG_FLAG_0 (PARM_DECL_CHECK (NODE)) + +/* Nonzero in a DECL if it is always used by reference, i.e. an INDIRECT_REF + is needed to access the object. */ +#define DECL_BY_REF_P(NODE) DECL_LANG_FLAG_1 (NODE) + +/* Nonzero in a FIELD_DECL that is a dummy built for some internal reason. */ +#define DECL_INTERNAL_P(NODE) DECL_LANG_FLAG_3 (FIELD_DECL_CHECK (NODE)) + +/* Nonzero in a PARM_DECL if it is made for an Ada array being passed to a + foreign convention subprogram. */ +#define DECL_BY_COMPONENT_PTR_P(NODE) DECL_LANG_FLAG_3 (PARM_DECL_CHECK (NODE)) + +/* Nonzero in a FUNCTION_DECL that corresponds to an elaboration procedure. */ +#define DECL_ELABORATION_PROC_P(NODE) \ + DECL_LANG_FLAG_3 (FUNCTION_DECL_CHECK (NODE)) + +/* Nonzero in a DECL if it is made for a pointer that points to something which + is readonly. Used mostly for fat pointers. */ +#define DECL_POINTS_TO_READONLY_P(NODE) DECL_LANG_FLAG_4 (NODE) + +/* Nonzero in a PARM_DECL if we are to pass by descriptor. */ +#define DECL_BY_DESCRIPTOR_P(NODE) DECL_LANG_FLAG_5 (PARM_DECL_CHECK (NODE)) + +/* Nonzero in a VAR_DECL if it is a pointer renaming a global object. */ +#define DECL_RENAMING_GLOBAL_P(NODE) DECL_LANG_FLAG_5 (VAR_DECL_CHECK (NODE)) + +/* In a FIELD_DECL corresponding to a discriminant, contains the + discriminant number. */ +#define DECL_DISCRIMINANT_NUMBER(NODE) DECL_INITIAL (FIELD_DECL_CHECK (NODE)) + +/* In a CONST_DECL, points to a VAR_DECL that is allocatable to + memory. Used when a scalar constant is aliased or has its + address taken. */ +#define DECL_CONST_CORRESPONDING_VAR(NODE) \ + GET_DECL_LANG_SPECIFIC (CONST_DECL_CHECK (NODE)) +#define SET_DECL_CONST_CORRESPONDING_VAR(NODE, X) \ + SET_DECL_LANG_SPECIFIC (CONST_DECL_CHECK (NODE), X) + +/* In a FIELD_DECL, points to the FIELD_DECL that was the ultimate + source of the decl. */ +#define DECL_ORIGINAL_FIELD(NODE) \ + GET_DECL_LANG_SPECIFIC (FIELD_DECL_CHECK (NODE)) +#define SET_DECL_ORIGINAL_FIELD(NODE, X) \ + SET_DECL_LANG_SPECIFIC (FIELD_DECL_CHECK (NODE), X) + +/* Set DECL_ORIGINAL_FIELD of FIELD1 to (that of) FIELD2. */ +#define SET_DECL_ORIGINAL_FIELD_TO_FIELD(FIELD1, FIELD2) \ + SET_DECL_ORIGINAL_FIELD ((FIELD1), \ + DECL_ORIGINAL_FIELD (FIELD2) \ + ? DECL_ORIGINAL_FIELD (FIELD2) : (FIELD2)) + +/* Return true if FIELD1 and FIELD2 represent the same field. */ +#define SAME_FIELD_P(FIELD1, FIELD2) \ + ((FIELD1) == (FIELD2) \ + || DECL_ORIGINAL_FIELD (FIELD1) == (FIELD2) \ + || (FIELD1) == DECL_ORIGINAL_FIELD (FIELD2) \ + || (DECL_ORIGINAL_FIELD (FIELD1) \ + && (DECL_ORIGINAL_FIELD (FIELD1) == DECL_ORIGINAL_FIELD (FIELD2)))) + +/* In a VAR_DECL, points to the object being renamed if the VAR_DECL is a + renaming pointer, otherwise 0. Note that this object is guaranteed to + be protected against multiple evaluations. */ +#define DECL_RENAMED_OBJECT(NODE) \ + GET_DECL_LANG_SPECIFIC (VAR_DECL_CHECK (NODE)) +#define SET_DECL_RENAMED_OBJECT(NODE, X) \ + SET_DECL_LANG_SPECIFIC (VAR_DECL_CHECK (NODE), X) + +/* In a TYPE_DECL, points to the parallel type if any, otherwise 0. */ +#define DECL_PARALLEL_TYPE(NODE) \ + GET_DECL_LANG_SPECIFIC (TYPE_DECL_CHECK (NODE)) +#define SET_DECL_PARALLEL_TYPE(NODE, X) \ + SET_DECL_LANG_SPECIFIC (TYPE_DECL_CHECK (NODE), X) + +/* In a FUNCTION_DECL, points to the stub associated with the function + if any, otherwise 0. */ +#define DECL_FUNCTION_STUB(NODE) \ + GET_DECL_LANG_SPECIFIC (FUNCTION_DECL_CHECK (NODE)) +#define SET_DECL_FUNCTION_STUB(NODE, X) \ + SET_DECL_LANG_SPECIFIC (FUNCTION_DECL_CHECK (NODE), X) + +/* In a PARM_DECL, points to the alternate TREE_TYPE. */ +#define DECL_PARM_ALT_TYPE(NODE) \ + GET_DECL_LANG_SPECIFIC (PARM_DECL_CHECK (NODE)) +#define SET_DECL_PARM_ALT_TYPE(NODE, X) \ + SET_DECL_LANG_SPECIFIC (PARM_DECL_CHECK (NODE), X) + + +/* Fields and macros for statements. */ +#define IS_ADA_STMT(NODE) \ + (STATEMENT_CLASS_P (NODE) && TREE_CODE (NODE) >= STMT_STMT) + +#define STMT_STMT_STMT(NODE) TREE_OPERAND_CHECK_CODE (NODE, STMT_STMT, 0) + +#define LOOP_STMT_COND(NODE) TREE_OPERAND_CHECK_CODE (NODE, LOOP_STMT, 0) +#define LOOP_STMT_UPDATE(NODE) TREE_OPERAND_CHECK_CODE (NODE, LOOP_STMT, 1) +#define LOOP_STMT_BODY(NODE) TREE_OPERAND_CHECK_CODE (NODE, LOOP_STMT, 2) +#define LOOP_STMT_LABEL(NODE) TREE_OPERAND_CHECK_CODE (NODE, LOOP_STMT, 3) + +/* A loop statement is conceptually made up of 6 sub-statements: + + loop: + TOP_CONDITION + TOP_UPDATE + BODY + BOTTOM_CONDITION + BOTTOM_UPDATE + GOTO loop + + However, only 4 of them can exist for a given loop, the pair of conditions + and the pair of updates being mutually exclusive. The default setting is + TOP_CONDITION and BOTTOM_UPDATE and the following couple of flags are used + to toggle the individual settings. */ +#define LOOP_STMT_BOTTOM_COND_P(NODE) TREE_LANG_FLAG_0 (LOOP_STMT_CHECK (NODE)) +#define LOOP_STMT_TOP_UPDATE_P(NODE) TREE_LANG_FLAG_1 (LOOP_STMT_CHECK (NODE)) + +#define EXIT_STMT_COND(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXIT_STMT, 0) +#define EXIT_STMT_LABEL(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXIT_STMT, 1) diff --git a/gcc/ada/gcc-interface/ada.h b/gcc/ada/gcc-interface/ada.h new file mode 100644 index 000000000..095dec3d6 --- /dev/null +++ b/gcc/ada/gcc-interface/ada.h @@ -0,0 +1,73 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * A D A * + * * + * C Header File * + * * + * Copyright (C) 1992-2009, Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING3. If 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 contains some standard macros for performing Ada-like + operations. These are used to aid in the translation of other headers. */ + +#ifndef GCC_ADA_H +#define GCC_ADA_H + +/* Inlined functions in header are preceded by INLINE, which is normally set + to extern inline for GCC, but may be set to static for use in standard + ANSI-C. */ + +#ifndef INLINE +#ifdef __GNUC__ +#define INLINE static inline +#else +#define INLINE static +#endif +#endif + +/* Define a macro to concatenate two strings. Write it for ANSI C and + for traditional C. */ + +#ifdef __STDC__ +#define CAT(A,B) A##B +#else +#define _ECHO(A) A +#define CAT(A,B) ECHO(A)B +#endif + +/* The following macro definition simulates the effect of a declaration of + a subtype, where the first two parameters give the name of the type and + subtype, and the third and fourth parameters give the subtype range. The + effect is to compile a typedef defining the subtype as a synonym for the + type, together with two constants defining the end points. */ + +#define SUBTYPE(SUBTYPE,TYPE,FIRST,LAST) \ + typedef TYPE SUBTYPE; \ + enum { CAT (SUBTYPE,__First) = FIRST, \ + CAT (SUBTYPE,__Last) = LAST }; + +/* The following definition provides the equivalent of the Ada IN operator, + assuming that the subtype involved has been defined using the SUBTYPE + macro defined above. */ + +#define IN(VALUE,SUBTYPE) \ + (((VALUE) >= (SUBTYPE) CAT (SUBTYPE,__First)) \ + && ((VALUE) <= (SUBTYPE) CAT (SUBTYPE,__Last))) + +#endif diff --git a/gcc/ada/gcc-interface/config-lang.in b/gcc/ada/gcc-interface/config-lang.in new file mode 100644 index 000000000..b4a28be14 --- /dev/null +++ b/gcc/ada/gcc-interface/config-lang.in @@ -0,0 +1,43 @@ +# Top level configure fragment for GNU Ada (GNAT). +# Copyright (C) 1994-2008 Free Software Foundation, Inc. + +#This file is part of GCC. + +#GCC is free software; you can redistribute it and/or modify +#it under the terms of the GNU General Public License as published by +#the Free Software Foundation; either version 3, or (at your option) +#any later version. + +#GCC is distributed in the hope that it will be useful, +#but WITHOUT ANY WARRANTY; without even the implied warranty of +#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +#GNU General Public License for more details. + +#You should have received a copy of the GNU General Public License +#along with GCC; see the file COPYING3. If not see +#. + +# Configure looks for the existence of this file to auto-config each language. +# We define several parameters used by configure: +# +# language - name of language as it would appear in $(LANGUAGES) +# boot_language - "yes" if we need to build this language in stage1 +# compilers - value to add to $(COMPILERS) + +language="ada" +gcc_subdir="ada/gcc-interface" + +boot_language=yes +boot_language_boot_flags='ADAFLAGS="$(BOOT_ADAFLAGS)"' + +compilers="gnat1\$(exeext)" + +gtfiles="\$(srcdir)/ada/gcc-interface/ada-tree.h \$(srcdir)/ada/gcc-interface/gigi.h \$(srcdir)/ada/gcc-interface/decl.c \$(srcdir)/ada/gcc-interface/trans.c \$(srcdir)/ada/gcc-interface/utils.c \$(srcdir)/ada/gcc-interface/misc.c" + +outputs="ada/gcc-interface/Makefile ada/Makefile" + +target_libs="target-libada" +lang_dirs="gnattools" + +# Ada is not enabled by default for the time being. +build_by_default=no diff --git a/gcc/ada/gcc-interface/cuintp.c b/gcc/ada/gcc-interface/cuintp.c new file mode 100644 index 000000000..31ed801e6 --- /dev/null +++ b/gcc/ada/gcc-interface/cuintp.c @@ -0,0 +1,202 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * C U I N T P * + * * + * C Implementation File * + * * + * 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. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License along with GCC; see the file COPYING3. If 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 corresponds to the Ada package body Uintp. It was created + manually from the files uintp.ads and uintp.adb. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tm.h" +#include "tree.h" + +#include "ada.h" +#include "types.h" +#include "uintp.h" +#include "atree.h" +#include "elists.h" +#include "nlists.h" +#include "stringt.h" +#include "fe.h" +#include "ada-tree.h" +#include "gigi.h" + +/* Universal integers are represented by the Uint type which is an index into + the Uints_Ptr table containing Uint_Entry values. A Uint_Entry contains an + index and length for getting the "digits" of the universal integer from the + Udigits_Ptr table. + + For efficiency, this method is used only for integer values larger than the + constant Uint_Bias. If a Uint is less than this constant, then it contains + the integer value itself. The origin of the Uints_Ptr table is adjusted so + that a Uint value of Uint_Bias indexes the first element. + + First define a utility function that operates like build_int_cst for + integral types and does a conversion to floating-point for real types. */ + +static tree +build_cst_from_int (tree type, HOST_WIDE_INT low) +{ + if (TREE_CODE (type) == REAL_TYPE) + return convert (type, build_int_cst (NULL_TREE, low)); + else + return build_int_cst_type (type, low); +} + +/* Similar to UI_To_Int, but return a GCC INTEGER_CST or REAL_CST node, + depending on whether TYPE is an integral or real type. Overflow is tested + by the constant-folding used to build the node. TYPE is the GCC type of + the resulting node. */ + +tree +UI_To_gnu (Uint Input, tree type) +{ + tree gnu_ret; + + /* We might have a TYPE with biased representation and be passed an + unbiased value that doesn't fit. We always use an unbiased type able + to hold any such possible value for intermediate computations, and + then rely on a conversion back to TYPE to perform the bias adjustment + when need be. */ + + int biased_type_p + = (TREE_CODE (type) == INTEGER_TYPE + && TYPE_BIASED_REPRESENTATION_P (type)); + + tree comp_type = biased_type_p ? get_base_type (type) : type; + + if (Input <= Uint_Direct_Last) + gnu_ret = build_cst_from_int (comp_type, Input - Uint_Direct_Bias); + else + { + Int Idx = Uints_Ptr[Input].Loc; + Pos Length = Uints_Ptr[Input].Length; + Int First = Udigits_Ptr[Idx]; + tree gnu_base; + + gcc_assert (Length > 0); + + /* The computations we perform below always require a type at least as + large as an integer not to overflow. REAL types are always fine, but + INTEGER or ENUMERAL types we are handed may be too short. We use a + base integer type node for the computations in this case and will + convert the final result back to the incoming type later on. + The base integer precision must be superior than 16. */ + + if (TREE_CODE (comp_type) != REAL_TYPE + && TYPE_PRECISION (comp_type) + < TYPE_PRECISION (long_integer_type_node)) + { + comp_type = long_integer_type_node; + gcc_assert (TYPE_PRECISION (comp_type) > 16); + } + + gnu_base = build_cst_from_int (comp_type, Base); + + gnu_ret = build_cst_from_int (comp_type, First); + if (First < 0) + for (Idx++, Length--; Length; Idx++, Length--) + gnu_ret = fold_build2 (MINUS_EXPR, comp_type, + fold_build2 (MULT_EXPR, comp_type, + gnu_ret, gnu_base), + build_cst_from_int (comp_type, + Udigits_Ptr[Idx])); + else + for (Idx++, Length--; Length; Idx++, Length--) + gnu_ret = fold_build2 (PLUS_EXPR, comp_type, + fold_build2 (MULT_EXPR, comp_type, + gnu_ret, gnu_base), + build_cst_from_int (comp_type, + Udigits_Ptr[Idx])); + } + + gnu_ret = convert (type, gnu_ret); + + /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RET. */ + while ((TREE_CODE (gnu_ret) == NOP_EXPR + || TREE_CODE (gnu_ret) == NON_LVALUE_EXPR) + && TREE_TYPE (TREE_OPERAND (gnu_ret, 0)) == TREE_TYPE (gnu_ret)) + gnu_ret = TREE_OPERAND (gnu_ret, 0); + + return gnu_ret; +} + +/* Similar to UI_From_Int, but take a GCC INTEGER_CST. We use UI_From_Int + when possible, i.e. for a 32-bit signed value, to take advantage of its + built-in caching mechanism. For values of larger magnitude, we compute + digits into a vector and call Vector_To_Uint. */ + +Uint +UI_From_gnu (tree Input) +{ + tree gnu_type = TREE_TYPE (Input), gnu_base, gnu_temp; + /* UI_Base is defined so that 5 Uint digits is sufficient to hold the + largest possible signed 64-bit value. */ + const int Max_For_Dint = 5; + int v[Max_For_Dint], i; + Vector_Template temp; + Int_Vector vec; + +#if HOST_BITS_PER_WIDE_INT == 64 + /* On 64-bit hosts, host_integerp tells whether the input fits in a + signed 64-bit integer. Then a truncation tells whether it fits + in a signed 32-bit integer. */ + if (host_integerp (Input, 0)) + { + HOST_WIDE_INT hw_input = TREE_INT_CST_LOW (Input); + if (hw_input == (int) hw_input) + return UI_From_Int (hw_input); + } + else + return No_Uint; +#else + /* On 32-bit hosts, host_integerp tells whether the input fits in a + signed 32-bit integer. Then a sign test tells whether it fits + in a signed 64-bit integer. */ + if (host_integerp (Input, 0)) + return UI_From_Int (TREE_INT_CST_LOW (Input)); + else if (TREE_INT_CST_HIGH (Input) < 0 + && TYPE_UNSIGNED (gnu_type) + && !(TREE_CODE (gnu_type) == INTEGER_TYPE + && TYPE_IS_SIZETYPE (gnu_type))) + return No_Uint; +#endif + + gnu_base = build_int_cst (gnu_type, UI_Base); + gnu_temp = Input; + + for (i = Max_For_Dint - 1; i >= 0; i--) + { + v[i] = tree_low_cst (fold_build1 (ABS_EXPR, gnu_type, + fold_build2 (TRUNC_MOD_EXPR, gnu_type, + gnu_temp, gnu_base)), + 0); + gnu_temp = fold_build2 (TRUNC_DIV_EXPR, gnu_type, gnu_temp, gnu_base); + } + + temp.Low_Bound = 1, temp.High_Bound = Max_For_Dint; + vec.Array = v, vec.Bounds = &temp; + return Vector_To_Uint (vec, tree_int_cst_sgn (Input) < 0); +} diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c new file mode 100644 index 000000000..239483425 --- /dev/null +++ b/gcc/ada/gcc-interface/decl.c @@ -0,0 +1,8853 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * D E C L * + * * + * C Implementation File * + * * + * 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. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License along with GCC; see the file COPYING3. If not see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tm.h" +#include "tree.h" +#include "flags.h" +#include "toplev.h" +#include "ggc.h" +#include "target.h" +#include "tree-inline.h" + +#include "ada.h" +#include "types.h" +#include "atree.h" +#include "elists.h" +#include "namet.h" +#include "nlists.h" +#include "repinfo.h" +#include "snames.h" +#include "stringt.h" +#include "uintp.h" +#include "fe.h" +#include "sinfo.h" +#include "einfo.h" +#include "ada-tree.h" +#include "gigi.h" + +/* Convention_Stdcall should be processed in a specific way on 32 bits + Windows targets only. The macro below is a helper to avoid having to + check for a Windows specific attribute throughout this unit. */ + +#if TARGET_DLLIMPORT_DECL_ATTRIBUTES +#ifdef TARGET_64BIT +#define Has_Stdcall_Convention(E) \ + (!TARGET_64BIT && Convention (E) == Convention_Stdcall) +#else +#define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall) +#endif +#else +#define Has_Stdcall_Convention(E) 0 +#endif + +/* Stack realignment is necessary for functions with foreign conventions when + the ABI doesn't mandate as much as what the compiler assumes - that is, up + to PREFERRED_STACK_BOUNDARY. + + Such realignment can be requested with a dedicated function type attribute + on the targets that support it. We define FOREIGN_FORCE_REALIGN_STACK to + characterize the situations where the attribute should be set. We rely on + compiler configuration settings for 'main' to decide. */ + +#ifdef MAIN_STACK_BOUNDARY +#define FOREIGN_FORCE_REALIGN_STACK \ + (MAIN_STACK_BOUNDARY < PREFERRED_STACK_BOUNDARY) +#else +#define FOREIGN_FORCE_REALIGN_STACK 0 +#endif + +struct incomplete +{ + struct incomplete *next; + tree old_type; + Entity_Id full_type; +}; + +/* These variables are used to defer recursively expanding incomplete types + while we are processing an array, a record or a subprogram type. */ +static int defer_incomplete_level = 0; +static struct incomplete *defer_incomplete_list; + +/* This variable is used to delay expanding From_With_Type types until the + end of the spec. */ +static struct incomplete *defer_limited_with; + +/* These variables are used to defer finalizing types. The element of the + list is the TYPE_DECL associated with the type. */ +static int defer_finalize_level = 0; +static VEC (tree,heap) *defer_finalize_list; + +typedef struct subst_pair_d { + tree discriminant; + tree replacement; +} subst_pair; + +DEF_VEC_O(subst_pair); +DEF_VEC_ALLOC_O(subst_pair,heap); + +typedef struct variant_desc_d { + /* The type of the variant. */ + tree type; + + /* The associated field. */ + tree field; + + /* The value of the qualifier. */ + tree qual; + + /* The type of the variant after transformation. */ + tree new_type; +} variant_desc; + +DEF_VEC_O(variant_desc); +DEF_VEC_ALLOC_O(variant_desc,heap); + +/* A hash table used to cache the result of annotate_value. */ +static GTY ((if_marked ("tree_int_map_marked_p"), + param_is (struct tree_int_map))) htab_t annotate_value_cache; + +enum alias_set_op +{ + ALIAS_SET_COPY, + ALIAS_SET_SUBSET, + ALIAS_SET_SUPERSET +}; + +static void relate_alias_sets (tree, tree, enum alias_set_op); + +static bool allocatable_size_p (tree, bool); +static void prepend_one_attribute_to (struct attrib **, + enum attr_type, tree, tree, Node_Id); +static void prepend_attributes (Entity_Id, struct attrib **); +static tree elaborate_expression (Node_Id, Entity_Id, tree, bool, bool, bool); +static bool is_variable_size (tree); +static tree elaborate_expression_1 (tree, Entity_Id, tree, bool, bool); +static tree elaborate_expression_2 (tree, Entity_Id, tree, bool, bool, + unsigned int); +static tree make_packable_type (tree, bool); +static tree gnat_to_gnu_component_type (Entity_Id, bool, bool); +static tree gnat_to_gnu_param (Entity_Id, Mechanism_Type, Entity_Id, bool, + bool *); +static tree gnat_to_gnu_field (Entity_Id, tree, int, bool, bool); +static bool same_discriminant_p (Entity_Id, Entity_Id); +static bool array_type_has_nonaliased_component (tree, Entity_Id); +static bool compile_time_known_address_p (Node_Id); +static bool cannot_be_superflat_p (Node_Id); +static bool constructor_address_p (tree); +static void components_to_record (tree, Node_Id, tree, int, bool, tree *, + bool, bool, bool, bool, bool); +static Uint annotate_value (tree); +static void annotate_rep (Entity_Id, tree); +static tree build_position_list (tree, bool, tree, tree, unsigned int, tree); +static VEC(subst_pair,heap) *build_subst_list (Entity_Id, Entity_Id, bool); +static VEC(variant_desc,heap) *build_variant_list (tree, + VEC(subst_pair,heap) *, + VEC(variant_desc,heap) *); +static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool); +static void set_rm_size (Uint, tree, Entity_Id); +static tree make_type_from_size (tree, tree, bool); +static unsigned int validate_alignment (Uint, Entity_Id, unsigned int); +static unsigned int ceil_alignment (unsigned HOST_WIDE_INT); +static void check_ok_for_atomic (tree, Entity_Id, bool); +static tree create_field_decl_from (tree, tree, tree, tree, tree, + VEC(subst_pair,heap) *); +static tree get_rep_part (tree); +static tree create_variant_part_from (tree, VEC(variant_desc,heap) *, tree, + tree, VEC(subst_pair,heap) *); +static void copy_and_substitute_in_size (tree, tree, VEC(subst_pair,heap) *); +static void rest_of_type_decl_compilation_no_defer (tree); +static void finish_fat_pointer_type (tree, tree); + +/* The relevant constituents of a subprogram binding to a GCC builtin. Used + to pass around calls performing profile compatibility checks. */ + +typedef struct { + Entity_Id gnat_entity; /* The Ada subprogram entity. */ + tree ada_fntype; /* The corresponding GCC type node. */ + tree btin_fntype; /* The GCC builtin function type node. */ +} intrin_binding_t; + +static bool intrin_profiles_compatible_p (intrin_binding_t *); + +/* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada + entity, return the equivalent GCC tree for that entity (a ..._DECL node) + and associate the ..._DECL node with the input GNAT defining identifier. + + If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its + initial value (in GCC tree form). This is optional for a variable. For + a renamed entity, GNU_EXPR gives the object being renamed. + + DEFINITION is nonzero if this call is intended for a definition. This is + used for separate compilation where it is necessary to know whether an + external declaration or a definition must be created if the GCC equivalent + was not created previously. The value of 1 is normally used for a nonzero + DEFINITION, but a value of 2 is used in special circumstances, defined in + the code. */ + +tree +gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) +{ + /* Contains the kind of the input GNAT node. */ + const Entity_Kind kind = Ekind (gnat_entity); + /* True if this is a type. */ + const bool is_type = IN (kind, Type_Kind); + /* True if debug info is requested for this entity. */ + const bool debug_info_p = Needs_Debug_Info (gnat_entity); + /* True if this entity is to be considered as imported. */ + const bool imported_p + = (Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity))); + /* For a type, contains the equivalent GNAT node to be used in gigi. */ + Entity_Id gnat_equiv_type = Empty; + /* Temporary used to walk the GNAT tree. */ + Entity_Id gnat_temp; + /* Contains the GCC DECL node which is equivalent to the input GNAT node. + This node will be associated with the GNAT node by calling at the end + of the `switch' statement. */ + tree gnu_decl = NULL_TREE; + /* Contains the GCC type to be used for the GCC node. */ + tree gnu_type = NULL_TREE; + /* Contains the GCC size tree to be used for the GCC node. */ + tree gnu_size = NULL_TREE; + /* Contains the GCC name to be used for the GCC node. */ + tree gnu_entity_name; + /* True if we have already saved gnu_decl as a GNAT association. */ + bool saved = false; + /* True if we incremented defer_incomplete_level. */ + bool this_deferred = false; + /* True if we incremented force_global. */ + bool this_global = false; + /* True if we should check to see if elaborated during processing. */ + bool maybe_present = false; + /* True if we made GNU_DECL and its type here. */ + bool this_made_decl = false; + /* Size and alignment of the GCC node, if meaningful. */ + unsigned int esize = 0, align = 0; + /* Contains the list of attributes directly attached to the entity. */ + struct attrib *attr_list = NULL; + + /* Since a use of an Itype is a definition, process it as such if it + is not in a with'ed unit. */ + if (!definition + && is_type + && Is_Itype (gnat_entity) + && !present_gnu_tree (gnat_entity) + && In_Extended_Main_Code_Unit (gnat_entity)) + { + /* Ensure that we are in a subprogram mentioned in the Scope chain of + this entity, our current scope is global, or we encountered a task + or entry (where we can't currently accurately check scoping). */ + if (!current_function_decl + || DECL_ELABORATION_PROC_P (current_function_decl)) + { + process_type (gnat_entity); + return get_gnu_tree (gnat_entity); + } + + for (gnat_temp = Scope (gnat_entity); + Present (gnat_temp); + gnat_temp = Scope (gnat_temp)) + { + if (Is_Type (gnat_temp)) + gnat_temp = Underlying_Type (gnat_temp); + + if (Ekind (gnat_temp) == E_Subprogram_Body) + gnat_temp + = Corresponding_Spec (Parent (Declaration_Node (gnat_temp))); + + if (IN (Ekind (gnat_temp), Subprogram_Kind) + && Present (Protected_Body_Subprogram (gnat_temp))) + gnat_temp = Protected_Body_Subprogram (gnat_temp); + + if (Ekind (gnat_temp) == E_Entry + || Ekind (gnat_temp) == E_Entry_Family + || Ekind (gnat_temp) == E_Task_Type + || (IN (Ekind (gnat_temp), Subprogram_Kind) + && present_gnu_tree (gnat_temp) + && (current_function_decl + == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0)))) + { + process_type (gnat_entity); + return get_gnu_tree (gnat_entity); + } + } + + /* This abort means the Itype has an incorrect scope, i.e. that its + scope does not correspond to the subprogram it is declared in. */ + gcc_unreachable (); + } + + /* If we've already processed this entity, return what we got last time. + If we are defining the node, we should not have already processed it. + In that case, we will abort below when we try to save a new GCC tree + for this object. We also need to handle the case of getting a dummy + type when a Full_View exists. */ + if ((!definition || (is_type && imported_p)) + && present_gnu_tree (gnat_entity)) + { + gnu_decl = get_gnu_tree (gnat_entity); + + if (TREE_CODE (gnu_decl) == TYPE_DECL + && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)) + && IN (kind, Incomplete_Or_Private_Kind) + && Present (Full_View (gnat_entity))) + { + gnu_decl + = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 0); + save_gnu_tree (gnat_entity, NULL_TREE, false); + save_gnu_tree (gnat_entity, gnu_decl, false); + } + + return gnu_decl; + } + + /* If this is a numeric or enumeral type, or an access type, a nonzero + Esize must be specified unless it was specified by the programmer. */ + gcc_assert (!Unknown_Esize (gnat_entity) + || Has_Size_Clause (gnat_entity) + || (!IN (kind, Numeric_Kind) + && !IN (kind, Enumeration_Kind) + && (!IN (kind, Access_Kind) + || kind == E_Access_Protected_Subprogram_Type + || kind == E_Anonymous_Access_Protected_Subprogram_Type + || kind == E_Access_Subtype))); + + /* The RM size must be specified for all discrete and fixed-point types. */ + gcc_assert (!(IN (kind, Discrete_Or_Fixed_Point_Kind) + && Unknown_RM_Size (gnat_entity))); + + /* If we get here, it means we have not yet done anything with this entity. + If we are not defining it, it must be a type or an entity that is defined + elsewhere or externally, otherwise we should have defined it already. */ + gcc_assert (definition + || type_annotate_only + || is_type + || kind == E_Discriminant + || kind == E_Component + || kind == E_Label + || (kind == E_Constant && Present (Full_View (gnat_entity))) + || Is_Public (gnat_entity)); + + /* Get the name of the entity and set up the line number and filename of + the original definition for use in any decl we make. */ + gnu_entity_name = get_entity_name (gnat_entity); + Sloc_to_locus (Sloc (gnat_entity), &input_location); + + /* For cases when we are not defining (i.e., we are referencing from + another compilation unit) public entities, show we are at global level + for the purpose of computing scopes. Don't do this for components or + discriminants since the relevant test is whether or not the record is + being defined. Don't do this for constants either as we'll look into + their defining expression in the local context. */ + if (!definition + && kind != E_Component + && kind != E_Discriminant + && kind != E_Constant + && Is_Public (gnat_entity) + && !Is_Statically_Allocated (gnat_entity)) + force_global++, this_global = true; + + /* Handle any attributes directly attached to the entity. */ + if (Has_Gigi_Rep_Item (gnat_entity)) + prepend_attributes (gnat_entity, &attr_list); + + /* Do some common processing for types. */ + if (is_type) + { + /* Compute the equivalent type to be used in gigi. */ + gnat_equiv_type = Gigi_Equivalent_Type (gnat_entity); + + /* Machine_Attributes on types are expected to be propagated to + subtypes. The corresponding Gigi_Rep_Items are only attached + to the first subtype though, so we handle the propagation here. */ + if (Base_Type (gnat_entity) != gnat_entity + && !Is_First_Subtype (gnat_entity) + && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity)))) + prepend_attributes (First_Subtype (Base_Type (gnat_entity)), + &attr_list); + + /* Compute a default value for the size of the type. */ + if (Known_Esize (gnat_entity) + && UI_Is_In_Int_Range (Esize (gnat_entity))) + { + unsigned int max_esize; + esize = UI_To_Int (Esize (gnat_entity)); + + if (IN (kind, Float_Kind)) + max_esize = fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE); + else if (IN (kind, Access_Kind)) + max_esize = POINTER_SIZE * 2; + else + max_esize = LONG_LONG_TYPE_SIZE; + + if (esize > max_esize) + esize = max_esize; + } + else + esize = LONG_LONG_TYPE_SIZE; + } + + switch (kind) + { + case E_Constant: + /* If this is a use of a deferred constant without address clause, + get its full definition. */ + if (!definition + && No (Address_Clause (gnat_entity)) + && Present (Full_View (gnat_entity))) + { + gnu_decl + = gnat_to_gnu_entity (Full_View (gnat_entity), gnu_expr, 0); + saved = true; + break; + } + + /* If we have an external constant that we are not defining, get the + expression that is was defined to represent. We may throw it away + later if it is not a constant. But do not retrieve the expression + if it is an allocator because the designated type might be dummy + at this point. */ + if (!definition + && !No_Initialization (Declaration_Node (gnat_entity)) + && Present (Expression (Declaration_Node (gnat_entity))) + && Nkind (Expression (Declaration_Node (gnat_entity))) + != N_Allocator) + { + bool went_into_elab_proc = false; + + /* The expression may contain N_Expression_With_Actions nodes and + thus object declarations from other units. In this case, even + though the expression will eventually be discarded since not a + constant, the declarations would be stuck either in the global + varpool or in the current scope. Therefore we force the local + context and create a fake scope that we'll zap at the end. */ + if (!current_function_decl) + { + current_function_decl = get_elaboration_procedure (); + went_into_elab_proc = true; + } + gnat_pushlevel (); + + gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity))); + + gnat_zaplevel (); + if (went_into_elab_proc) + current_function_decl = NULL_TREE; + } + + /* Ignore deferred constant definitions without address clause since + they are processed fully in the front-end. If No_Initialization + is set, this is not a deferred constant but a constant whose value + is built manually. And constants that are renamings are handled + like variables. */ + if (definition + && !gnu_expr + && No (Address_Clause (gnat_entity)) + && !No_Initialization (Declaration_Node (gnat_entity)) + && No (Renamed_Object (gnat_entity))) + { + gnu_decl = error_mark_node; + saved = true; + break; + } + + /* Ignore constant definitions already marked with the error node. See + the N_Object_Declaration case of gnat_to_gnu for the rationale. */ + if (definition + && gnu_expr + && present_gnu_tree (gnat_entity) + && get_gnu_tree (gnat_entity) == error_mark_node) + { + maybe_present = true; + break; + } + + goto object; + + case E_Exception: + /* We used to special case VMS exceptions here to directly map them to + their associated condition code. Since this code had to be masked + dynamically to strip off the severity bits, this caused trouble in + the GCC/ZCX case because the "type" pointers we store in the tables + have to be static. We now don't special case here anymore, and let + the regular processing take place, which leaves us with a regular + exception data object for VMS exceptions too. The condition code + mapping is taken care of by the front end and the bitmasking by the + run-time library. */ + goto object; + + case E_Discriminant: + case E_Component: + { + /* The GNAT record where the component was defined. */ + Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity)); + + /* If the variable is an inherited record component (in the case of + extended record types), just return the inherited entity, which + must be a FIELD_DECL. Likewise for discriminants. + For discriminants of untagged records which have explicit + stored discriminants, return the entity for the corresponding + stored discriminant. Also use Original_Record_Component + if the record has a private extension. */ + if (Present (Original_Record_Component (gnat_entity)) + && Original_Record_Component (gnat_entity) != gnat_entity) + { + gnu_decl + = gnat_to_gnu_entity (Original_Record_Component (gnat_entity), + gnu_expr, definition); + saved = true; + break; + } + + /* If the enclosing record has explicit stored discriminants, + then it is an untagged record. If the Corresponding_Discriminant + is not empty then this must be a renamed discriminant and its + Original_Record_Component must point to the corresponding explicit + stored discriminant (i.e. we should have taken the previous + branch). */ + else if (Present (Corresponding_Discriminant (gnat_entity)) + && Is_Tagged_Type (gnat_record)) + { + /* A tagged record has no explicit stored discriminants. */ + gcc_assert (First_Discriminant (gnat_record) + == First_Stored_Discriminant (gnat_record)); + gnu_decl + = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity), + gnu_expr, definition); + saved = true; + break; + } + + else if (Present (CR_Discriminant (gnat_entity)) + && type_annotate_only) + { + gnu_decl = gnat_to_gnu_entity (CR_Discriminant (gnat_entity), + gnu_expr, definition); + saved = true; + break; + } + + /* If the enclosing record has explicit stored discriminants, then + it is an untagged record. If the Corresponding_Discriminant + is not empty then this must be a renamed discriminant and its + Original_Record_Component must point to the corresponding explicit + stored discriminant (i.e. we should have taken the first + branch). */ + else if (Present (Corresponding_Discriminant (gnat_entity)) + && (First_Discriminant (gnat_record) + != First_Stored_Discriminant (gnat_record))) + gcc_unreachable (); + + /* Otherwise, if we are not defining this and we have no GCC type + for the containing record, make one for it. Then we should + have made our own equivalent. */ + else if (!definition && !present_gnu_tree (gnat_record)) + { + /* ??? If this is in a record whose scope is a protected + type and we have an Original_Record_Component, use it. + This is a workaround for major problems in protected type + handling. */ + Entity_Id Scop = Scope (Scope (gnat_entity)); + if ((Is_Protected_Type (Scop) + || (Is_Private_Type (Scop) + && Present (Full_View (Scop)) + && Is_Protected_Type (Full_View (Scop)))) + && Present (Original_Record_Component (gnat_entity))) + { + gnu_decl + = gnat_to_gnu_entity (Original_Record_Component + (gnat_entity), + gnu_expr, 0); + saved = true; + break; + } + + gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0); + gnu_decl = get_gnu_tree (gnat_entity); + saved = true; + break; + } + + else + /* Here we have no GCC type and this is a reference rather than a + definition. This should never happen. Most likely the cause is + reference before declaration in the gnat tree for gnat_entity. */ + gcc_unreachable (); + } + + case E_Loop_Parameter: + case E_Out_Parameter: + case E_Variable: + + /* Simple variables, loop variables, Out parameters and exceptions. */ + object: + { + bool const_flag + = ((kind == E_Constant || kind == E_Variable) + && Is_True_Constant (gnat_entity) + && !Treat_As_Volatile (gnat_entity) + && (((Nkind (Declaration_Node (gnat_entity)) + == N_Object_Declaration) + && Present (Expression (Declaration_Node (gnat_entity)))) + || Present (Renamed_Object (gnat_entity)) + || imported_p)); + bool inner_const_flag = const_flag; + bool static_p = Is_Statically_Allocated (gnat_entity); + bool mutable_p = false; + bool used_by_ref = false; + tree gnu_ext_name = NULL_TREE; + tree renamed_obj = NULL_TREE; + tree gnu_object_size; + + if (Present (Renamed_Object (gnat_entity)) && !definition) + { + if (kind == E_Exception) + gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity), + NULL_TREE, 0); + else + gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity)); + } + + /* Get the type after elaborating the renamed object. */ + gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); + + /* If this is a standard exception definition, then use the standard + exception type. This is necessary to make sure that imported and + exported views of exceptions are properly merged in LTO mode. */ + if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL + && DECL_NAME (TYPE_NAME (gnu_type)) == exception_data_name_id) + gnu_type = except_type_node; + + /* For a debug renaming declaration, build a debug-only entity. */ + if (Present (Debug_Renaming_Link (gnat_entity))) + { + /* Force a non-null value to make sure the symbol is retained. */ + tree value = build1 (INDIRECT_REF, gnu_type, + build1 (NOP_EXPR, + build_pointer_type (gnu_type), + integer_minus_one_node)); + gnu_decl = build_decl (input_location, + VAR_DECL, gnu_entity_name, gnu_type); + SET_DECL_VALUE_EXPR (gnu_decl, value); + DECL_HAS_VALUE_EXPR_P (gnu_decl) = 1; + gnat_pushdecl (gnu_decl, gnat_entity); + break; + } + + /* If this is a loop variable, its type should be the base type. + This is because the code for processing a loop determines whether + a normal loop end test can be done by comparing the bounds of the + loop against those of the base type, which is presumed to be the + size used for computation. But this is not correct when the size + of the subtype is smaller than the type. */ + if (kind == E_Loop_Parameter) + gnu_type = get_base_type (gnu_type); + + /* Reject non-renamed objects whose type is an unconstrained array or + any object whose type is a dummy type or void. */ + if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE + && No (Renamed_Object (gnat_entity))) + || TYPE_IS_DUMMY_P (gnu_type) + || TREE_CODE (gnu_type) == VOID_TYPE) + { + gcc_assert (type_annotate_only); + if (this_global) + force_global--; + return error_mark_node; + } + + /* If an alignment is specified, use it if valid. Note that exceptions + are objects but don't have an alignment. We must do this before we + validate the size, since the alignment can affect the size. */ + if (kind != E_Exception && Known_Alignment (gnat_entity)) + { + gcc_assert (Present (Alignment (gnat_entity))); + align = validate_alignment (Alignment (gnat_entity), gnat_entity, + TYPE_ALIGN (gnu_type)); + + /* No point in changing the type if there is an address clause + as the final type of the object will be a reference type. */ + if (Present (Address_Clause (gnat_entity))) + align = 0; + else + gnu_type + = maybe_pad_type (gnu_type, NULL_TREE, align, gnat_entity, + false, false, definition, true); + } + + /* If we are defining the object, see if it has a Size and validate it + if so. If we are not defining the object and a Size clause applies, + simply retrieve the value. We don't want to ignore the clause and + it is expected to have been validated already. Then get the new + type, if any. */ + if (definition) + gnu_size = validate_size (Esize (gnat_entity), gnu_type, + gnat_entity, VAR_DECL, false, + Has_Size_Clause (gnat_entity)); + else if (Has_Size_Clause (gnat_entity)) + gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype); + + if (gnu_size) + { + gnu_type + = make_type_from_size (gnu_type, gnu_size, + Has_Biased_Representation (gnat_entity)); + + if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)) + gnu_size = NULL_TREE; + } + + /* If this object has self-referential size, it must be a record with + a default discriminant. We are supposed to allocate an object of + the maximum size in this case, unless it is a constant with an + initializing expression, in which case we can get the size from + that. Note that the resulting size may still be a variable, so + this may end up with an indirect allocation. */ + if (No (Renamed_Object (gnat_entity)) + && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))) + { + if (gnu_expr && kind == E_Constant) + { + tree size = TYPE_SIZE (TREE_TYPE (gnu_expr)); + if (CONTAINS_PLACEHOLDER_P (size)) + { + /* If the initializing expression is itself a constant, + despite having a nominal type with self-referential + size, we can get the size directly from it. */ + if (TREE_CODE (gnu_expr) == COMPONENT_REF + && TYPE_IS_PADDING_P + (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))) + && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == VAR_DECL + && (TREE_READONLY (TREE_OPERAND (gnu_expr, 0)) + || DECL_READONLY_ONCE_ELAB + (TREE_OPERAND (gnu_expr, 0)))) + gnu_size = DECL_SIZE (TREE_OPERAND (gnu_expr, 0)); + else + gnu_size + = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, gnu_expr); + } + else + gnu_size = size; + } + /* We may have no GNU_EXPR because No_Initialization is + set even though there's an Expression. */ + else if (kind == E_Constant + && (Nkind (Declaration_Node (gnat_entity)) + == N_Object_Declaration) + && Present (Expression (Declaration_Node (gnat_entity)))) + gnu_size + = TYPE_SIZE (gnat_to_gnu_type + (Etype + (Expression (Declaration_Node (gnat_entity))))); + else + { + gnu_size = max_size (TYPE_SIZE (gnu_type), true); + mutable_p = true; + } + } + + /* If the size is zero byte, make it one byte since some linkers have + troubles with zero-sized objects. If the object will have a + template, that will make it nonzero so don't bother. Also avoid + doing that for an object renaming or an object with an address + clause, as we would lose useful information on the view size + (e.g. for null array slices) and we are not allocating the object + here anyway. */ + if (((gnu_size + && integer_zerop (gnu_size) + && !TREE_OVERFLOW (gnu_size)) + || (TYPE_SIZE (gnu_type) + && integer_zerop (TYPE_SIZE (gnu_type)) + && !TREE_OVERFLOW (TYPE_SIZE (gnu_type)))) + && (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity)) + || !Is_Array_Type (Etype (gnat_entity))) + && No (Renamed_Object (gnat_entity)) + && No (Address_Clause (gnat_entity))) + gnu_size = bitsize_unit_node; + + /* If this is an object with no specified size and alignment, and + if either it is atomic or we are not optimizing alignment for + space and it is composite and not an exception, an Out parameter + or a reference to another object, and the size of its type is a + constant, set the alignment to the smallest one which is not + smaller than the size, with an appropriate cap. */ + if (!gnu_size && align == 0 + && (Is_Atomic (gnat_entity) + || (!Optimize_Alignment_Space (gnat_entity) + && kind != E_Exception + && kind != E_Out_Parameter + && Is_Composite_Type (Etype (gnat_entity)) + && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity)) + && !Is_Exported (gnat_entity) + && !imported_p + && No (Renamed_Object (gnat_entity)) + && No (Address_Clause (gnat_entity)))) + && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST) + { + unsigned int size_cap, align_cap; + + /* No point in promoting the alignment if this doesn't prevent + BLKmode access to the object, in particular block copy, as + this will for example disable the NRV optimization for it. + No point in jumping through all the hoops needed in order + to support BIGGEST_ALIGNMENT if we don't really have to. + So we cap to the smallest alignment that corresponds to + a known efficient memory access pattern of the target. */ + if (Is_Atomic (gnat_entity)) + { + size_cap = UINT_MAX; + align_cap = BIGGEST_ALIGNMENT; + } + else + { + size_cap = MAX_FIXED_MODE_SIZE; + align_cap = get_mode_alignment (ptr_mode); + } + + if (!host_integerp (TYPE_SIZE (gnu_type), 1) + || compare_tree_int (TYPE_SIZE (gnu_type), size_cap) > 0) + align = 0; + else if (compare_tree_int (TYPE_SIZE (gnu_type), align_cap) > 0) + align = align_cap; + else + align = ceil_alignment (tree_low_cst (TYPE_SIZE (gnu_type), 1)); + + /* But make sure not to under-align the object. */ + if (align <= TYPE_ALIGN (gnu_type)) + align = 0; + + /* And honor the minimum valid atomic alignment, if any. */ +#ifdef MINIMUM_ATOMIC_ALIGNMENT + else if (align < MINIMUM_ATOMIC_ALIGNMENT) + align = MINIMUM_ATOMIC_ALIGNMENT; +#endif + } + + /* If the object is set to have atomic components, find the component + type and validate it. + + ??? Note that we ignore Has_Volatile_Components on objects; it's + not at all clear what to do in that case. */ + if (Has_Atomic_Components (gnat_entity)) + { + tree gnu_inner = (TREE_CODE (gnu_type) == ARRAY_TYPE + ? TREE_TYPE (gnu_type) : gnu_type); + + while (TREE_CODE (gnu_inner) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (gnu_inner)) + gnu_inner = TREE_TYPE (gnu_inner); + + check_ok_for_atomic (gnu_inner, gnat_entity, true); + } + + /* Now check if the type of the object allows atomic access. Note + that we must test the type, even if this object has size and + alignment to allow such access, because we will be going inside + the padded record to assign to the object. We could fix this by + always copying via an intermediate value, but it's not clear it's + worth the effort. */ + if (Is_Atomic (gnat_entity)) + check_ok_for_atomic (gnu_type, gnat_entity, false); + + /* If this is an aliased object with an unconstrained nominal subtype, + make a type that includes the template. */ + if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity)) + && Is_Array_Type (Etype (gnat_entity)) + && !type_annotate_only) + { + tree gnu_fat + = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity)))); + + gnu_type + = build_unc_object_type_from_ptr (gnu_fat, gnu_type, + concat_name (gnu_entity_name, + "UNC"), + debug_info_p); + } + +#ifdef MINIMUM_ATOMIC_ALIGNMENT + /* If the size is a constant and no alignment is specified, force + the alignment to be the minimum valid atomic alignment. The + restriction on constant size avoids problems with variable-size + temporaries; if the size is variable, there's no issue with + atomic access. Also don't do this for a constant, since it isn't + necessary and can interfere with constant replacement. Finally, + do not do it for Out parameters since that creates an + size inconsistency with In parameters. */ + if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type) + && !FLOAT_TYPE_P (gnu_type) + && !const_flag && No (Renamed_Object (gnat_entity)) + && !imported_p && No (Address_Clause (gnat_entity)) + && kind != E_Out_Parameter + && (gnu_size ? TREE_CODE (gnu_size) == INTEGER_CST + : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)) + align = MINIMUM_ATOMIC_ALIGNMENT; +#endif + + /* Make a new type with the desired size and alignment, if needed. + But do not take into account alignment promotions to compute the + size of the object. */ + gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type); + if (gnu_size || align > 0) + gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity, + false, false, definition, + gnu_size ? true : false); + + /* If this is a renaming, avoid as much as possible to create a new + object. However, in several cases, creating it is required. + This processing needs to be applied to the raw expression so + as to make it more likely to rename the underlying object. */ + if (Present (Renamed_Object (gnat_entity))) + { + bool create_normal_object = false; + + /* If the renamed object had padding, strip off the reference + to the inner object and reset our type. */ + if ((TREE_CODE (gnu_expr) == COMPONENT_REF + && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))) + /* Strip useless conversions around the object. */ + || (TREE_CODE (gnu_expr) == NOP_EXPR + && gnat_types_compatible_p + (TREE_TYPE (gnu_expr), + TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))) + { + gnu_expr = TREE_OPERAND (gnu_expr, 0); + gnu_type = TREE_TYPE (gnu_expr); + } + + /* Case 1: If this is a constant renaming stemming from a function + call, treat it as a normal object whose initial value is what + is being renamed. RM 3.3 says that the result of evaluating a + function call is a constant object. As a consequence, it can + be the inner object of a constant renaming. In this case, the + renaming must be fully instantiated, i.e. it cannot be a mere + reference to (part of) an existing object. */ + if (const_flag) + { + tree inner_object = gnu_expr; + while (handled_component_p (inner_object)) + inner_object = TREE_OPERAND (inner_object, 0); + if (TREE_CODE (inner_object) == CALL_EXPR) + create_normal_object = true; + } + + /* Otherwise, see if we can proceed with a stabilized version of + the renamed entity or if we need to make a new object. */ + if (!create_normal_object) + { + tree maybe_stable_expr = NULL_TREE; + bool stable = false; + + /* Case 2: If the renaming entity need not be materialized and + the renamed expression is something we can stabilize, use + that for the renaming. At the global level, we can only do + this if we know no SAVE_EXPRs need be made, because the + expression we return might be used in arbitrary conditional + branches so we must force the evaluation of the SAVE_EXPRs + immediately and this requires a proper function context. + Note that an external constant is at the global level. */ + if (!Materialize_Entity (gnat_entity) + && (!((!definition && kind == E_Constant) + || global_bindings_p ()) + || (staticp (gnu_expr) + && !TREE_SIDE_EFFECTS (gnu_expr)))) + { + maybe_stable_expr + = gnat_stabilize_reference (gnu_expr, true, &stable); + + if (stable) + { + /* ??? No DECL_EXPR is created so we need to mark + the expression manually lest it is shared. */ + if ((!definition && kind == E_Constant) + || global_bindings_p ()) + MARK_VISITED (maybe_stable_expr); + gnu_decl = maybe_stable_expr; + save_gnu_tree (gnat_entity, gnu_decl, true); + saved = true; + annotate_object (gnat_entity, gnu_type, NULL_TREE, + false, false); + break; + } + + /* The stabilization failed. Keep maybe_stable_expr + untouched here to let the pointer case below know + about that failure. */ + } + + /* Case 3: If this is a constant renaming and creating a + new object is allowed and cheap, treat it as a normal + object whose initial value is what is being renamed. */ + if (const_flag + && !Is_Composite_Type + (Underlying_Type (Etype (gnat_entity)))) + ; + + /* Case 4: Make this into a constant pointer to the object we + are to rename and attach the object to the pointer if it is + something we can stabilize. + + From the proper scope, attached objects will be referenced + directly instead of indirectly via the pointer to avoid + subtle aliasing problems with non-addressable entities. + They have to be stable because we must not evaluate the + variables in the expression every time the renaming is used. + The pointer is called a "renaming" pointer in this case. + + In the rare cases where we cannot stabilize the renamed + object, we just make a "bare" pointer, and the renamed + entity is always accessed indirectly through it. */ + else + { + /* We need to preserve the volatileness of the renamed + object through the indirection. */ + if (TREE_THIS_VOLATILE (gnu_expr) + && !TYPE_VOLATILE (gnu_type)) + gnu_type + = build_qualified_type (gnu_type, + (TYPE_QUALS (gnu_type) + | TYPE_QUAL_VOLATILE)); + gnu_type = build_reference_type (gnu_type); + inner_const_flag = TREE_READONLY (gnu_expr); + const_flag = true; + + /* If the previous attempt at stabilizing failed, there + is no point in trying again and we reuse the result + without attaching it to the pointer. In this case it + will only be used as the initializing expression of + the pointer and thus needs no special treatment with + regard to multiple evaluations. */ + if (maybe_stable_expr) + ; + + /* Otherwise, try to stabilize and attach the expression + to the pointer if the stabilization succeeds. + + Note that this might introduce SAVE_EXPRs and we don't + check whether we're at the global level or not. This + is fine since we are building a pointer initializer and + neither the pointer nor the initializing expression can + be accessed before the pointer elaboration has taken + place in a correct program. + + These SAVE_EXPRs will be evaluated at the right place + by either the evaluation of the initializer for the + non-global case or the elaboration code for the global + case, and will be attached to the elaboration procedure + in the latter case. */ + else + { + maybe_stable_expr + = gnat_stabilize_reference (gnu_expr, true, &stable); + + if (stable) + renamed_obj = maybe_stable_expr; + + /* Attaching is actually performed downstream, as soon + as we have a VAR_DECL for the pointer we make. */ + } + + gnu_expr = build_unary_op (ADDR_EXPR, gnu_type, + maybe_stable_expr); + + gnu_size = NULL_TREE; + used_by_ref = true; + } + } + } + + /* Make a volatile version of this object's type if we are to make + the object volatile. We also interpret 13.3(19) conservatively + and disallow any optimizations for such a non-constant object. */ + if ((Treat_As_Volatile (gnat_entity) + || (!const_flag + && gnu_type != except_type_node + && (Is_Exported (gnat_entity) + || imported_p + || Present (Address_Clause (gnat_entity))))) + && !TYPE_VOLATILE (gnu_type)) + gnu_type = build_qualified_type (gnu_type, + (TYPE_QUALS (gnu_type) + | TYPE_QUAL_VOLATILE)); + + /* If we are defining an aliased object whose nominal subtype is + unconstrained, the object is a record that contains both the + template and the object. If there is an initializer, it will + have already been converted to the right type, but we need to + create the template if there is no initializer. */ + if (definition + && !gnu_expr + && TREE_CODE (gnu_type) == RECORD_TYPE + && (TYPE_CONTAINS_TEMPLATE_P (gnu_type) + /* Beware that padding might have been introduced above. */ + || (TYPE_PADDING_P (gnu_type) + && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) + == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P + (TREE_TYPE (TYPE_FIELDS (gnu_type)))))) + { + tree template_field + = TYPE_PADDING_P (gnu_type) + ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type))) + : TYPE_FIELDS (gnu_type); + VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 1); + tree t = build_template (TREE_TYPE (template_field), + TREE_TYPE (DECL_CHAIN (template_field)), + NULL_TREE); + CONSTRUCTOR_APPEND_ELT (v, template_field, t); + gnu_expr = gnat_build_constructor (gnu_type, v); + } + + /* Convert the expression to the type of the object except in the + case where the object's type is unconstrained or the object's type + is a padded record whose field is of self-referential size. In + the former case, converting will generate unnecessary evaluations + of the CONSTRUCTOR to compute the size and in the latter case, we + want to only copy the actual data. */ + if (gnu_expr + && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE + && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)) + && !(TYPE_IS_PADDING_P (gnu_type) + && CONTAINS_PLACEHOLDER_P + (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))) + gnu_expr = convert (gnu_type, gnu_expr); + + /* If this is a pointer that doesn't have an initializing expression, + initialize it to NULL, unless the object is imported. */ + if (definition + && (POINTER_TYPE_P (gnu_type) || TYPE_IS_FAT_POINTER_P (gnu_type)) + && !gnu_expr + && !Is_Imported (gnat_entity)) + gnu_expr = integer_zero_node; + + /* If we are defining the object and it has an Address clause, we must + either get the address expression from the saved GCC tree for the + object if it has a Freeze node, or elaborate the address expression + here since the front-end has guaranteed that the elaboration has no + effects in this case. */ + if (definition && Present (Address_Clause (gnat_entity))) + { + Node_Id gnat_expr = Expression (Address_Clause (gnat_entity)); + tree gnu_address + = present_gnu_tree (gnat_entity) + ? get_gnu_tree (gnat_entity) : gnat_to_gnu (gnat_expr); + + save_gnu_tree (gnat_entity, NULL_TREE, false); + + /* Ignore the size. It's either meaningless or was handled + above. */ + gnu_size = NULL_TREE; + /* Convert the type of the object to a reference type that can + alias everything as per 13.3(19). */ + gnu_type + = build_reference_type_for_mode (gnu_type, ptr_mode, true); + gnu_address = convert (gnu_type, gnu_address); + used_by_ref = true; + const_flag + = !Is_Public (gnat_entity) + || compile_time_known_address_p (gnat_expr); + + /* If this is a deferred constant, the initializer is attached to + the full view. */ + if (kind == E_Constant && Present (Full_View (gnat_entity))) + gnu_expr + = gnat_to_gnu + (Expression (Declaration_Node (Full_View (gnat_entity)))); + + /* If we don't have an initializing expression for the underlying + variable, the initializing expression for the pointer is the + specified address. Otherwise, we have to make a COMPOUND_EXPR + to assign both the address and the initial value. */ + if (!gnu_expr) + gnu_expr = gnu_address; + else + gnu_expr + = build2 (COMPOUND_EXPR, gnu_type, + build_binary_op + (MODIFY_EXPR, NULL_TREE, + build_unary_op (INDIRECT_REF, NULL_TREE, + gnu_address), + gnu_expr), + gnu_address); + } + + /* If it has an address clause and we are not defining it, mark it + as an indirect object. Likewise for Stdcall objects that are + imported. */ + if ((!definition && Present (Address_Clause (gnat_entity))) + || (Is_Imported (gnat_entity) + && Has_Stdcall_Convention (gnat_entity))) + { + /* Convert the type of the object to a reference type that can + alias everything as per 13.3(19). */ + gnu_type + = build_reference_type_for_mode (gnu_type, ptr_mode, true); + gnu_size = NULL_TREE; + + /* No point in taking the address of an initializing expression + that isn't going to be used. */ + gnu_expr = NULL_TREE; + + /* If it has an address clause whose value is known at compile + time, make the object a CONST_DECL. This will avoid a + useless dereference. */ + if (Present (Address_Clause (gnat_entity))) + { + Node_Id gnat_address + = Expression (Address_Clause (gnat_entity)); + + if (compile_time_known_address_p (gnat_address)) + { + gnu_expr = gnat_to_gnu (gnat_address); + const_flag = true; + } + } + + used_by_ref = true; + } + + /* If we are at top level and this object is of variable size, + make the actual type a hidden pointer to the real type and + make the initializer be a memory allocation and initialization. + Likewise for objects we aren't defining (presumed to be + external references from other packages), but there we do + not set up an initialization. + + If the object's size overflows, make an allocator too, so that + Storage_Error gets raised. Note that we will never free + such memory, so we presume it never will get allocated. */ + if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type), + global_bindings_p () + || !definition + || static_p) + || (gnu_size && !allocatable_size_p (gnu_size, + global_bindings_p () + || !definition + || static_p))) + { + gnu_type = build_reference_type (gnu_type); + gnu_size = NULL_TREE; + used_by_ref = true; + + /* In case this was a aliased object whose nominal subtype is + unconstrained, the pointer above will be a thin pointer and + build_allocator will automatically make the template. + + If we have a template initializer only (that we made above), + pretend there is none and rely on what build_allocator creates + again anyway. Otherwise (if we have a full initializer), get + the data part and feed that to build_allocator. + + If we are elaborating a mutable object, tell build_allocator to + ignore a possibly simpler size from the initializer, if any, as + we must allocate the maximum possible size in this case. */ + if (definition && !imported_p) + { + tree gnu_alloc_type = TREE_TYPE (gnu_type); + + if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type)) + { + gnu_alloc_type + = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_alloc_type))); + + if (TREE_CODE (gnu_expr) == CONSTRUCTOR + && 1 == VEC_length (constructor_elt, + CONSTRUCTOR_ELTS (gnu_expr))) + gnu_expr = 0; + else + gnu_expr + = build_component_ref + (gnu_expr, NULL_TREE, + DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))), + false); + } + + if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST + && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type))) + post_error ("?`Storage_Error` will be raised at run time!", + gnat_entity); + + gnu_expr + = build_allocator (gnu_alloc_type, gnu_expr, gnu_type, + Empty, Empty, gnat_entity, mutable_p); + const_flag = true; + } + else + { + gnu_expr = NULL_TREE; + const_flag = false; + } + } + + /* If this object would go into the stack and has an alignment larger + than the largest stack alignment the back-end can honor, resort to + a variable of "aligning type". */ + if (!global_bindings_p () && !static_p && definition + && !imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT) + { + /* Create the new variable. No need for extra room before the + aligned field as this is in automatic storage. */ + tree gnu_new_type + = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type), + TYPE_SIZE_UNIT (gnu_type), + BIGGEST_ALIGNMENT, 0); + tree gnu_new_var + = create_var_decl (create_concat_name (gnat_entity, "ALIGN"), + NULL_TREE, gnu_new_type, NULL_TREE, false, + false, false, false, NULL, gnat_entity); + + /* Initialize the aligned field if we have an initializer. */ + if (gnu_expr) + add_stmt_with_node + (build_binary_op (MODIFY_EXPR, NULL_TREE, + build_component_ref + (gnu_new_var, NULL_TREE, + TYPE_FIELDS (gnu_new_type), false), + gnu_expr), + gnat_entity); + + /* And setup this entity as a reference to the aligned field. */ + gnu_type = build_reference_type (gnu_type); + gnu_expr + = build_unary_op + (ADDR_EXPR, gnu_type, + build_component_ref (gnu_new_var, NULL_TREE, + TYPE_FIELDS (gnu_new_type), false)); + + gnu_size = NULL_TREE; + used_by_ref = true; + const_flag = true; + } + + if (const_flag) + gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type) + | TYPE_QUAL_CONST)); + + /* Convert the expression to the type of the object except in the + case where the object's type is unconstrained or the object's type + is a padded record whose field is of self-referential size. In + the former case, converting will generate unnecessary evaluations + of the CONSTRUCTOR to compute the size and in the latter case, we + want to only copy the actual data. */ + if (gnu_expr + && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE + && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)) + && !(TYPE_IS_PADDING_P (gnu_type) + && CONTAINS_PLACEHOLDER_P + (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))) + gnu_expr = convert (gnu_type, gnu_expr); + + /* If this name is external or there was a name specified, use it, + unless this is a VMS exception object since this would conflict + with the symbol we need to export in addition. Don't use the + Interface_Name if there is an address clause (see CD30005). */ + if (!Is_VMS_Exception (gnat_entity) + && ((Present (Interface_Name (gnat_entity)) + && No (Address_Clause (gnat_entity))) + || (Is_Public (gnat_entity) + && (!Is_Imported (gnat_entity) + || Is_Exported (gnat_entity))))) + gnu_ext_name = create_concat_name (gnat_entity, NULL); + + /* If this is an aggregate constant initialized to a constant, force it + to be statically allocated. This saves an initialization copy. */ + if (!static_p + && const_flag + && gnu_expr && TREE_CONSTANT (gnu_expr) + && AGGREGATE_TYPE_P (gnu_type) + && host_integerp (TYPE_SIZE_UNIT (gnu_type), 1) + && !(TYPE_IS_PADDING_P (gnu_type) + && !host_integerp (TYPE_SIZE_UNIT + (TREE_TYPE (TYPE_FIELDS (gnu_type))), 1))) + static_p = true; + + /* Now create the variable or the constant and set various flags. */ + gnu_decl + = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type, + gnu_expr, const_flag, Is_Public (gnat_entity), + imported_p || !definition, static_p, attr_list, + gnat_entity); + DECL_BY_REF_P (gnu_decl) = used_by_ref; + DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag; + + /* If we are defining an Out parameter and optimization isn't enabled, + create a fake PARM_DECL for debugging purposes and make it point to + the VAR_DECL. Suppress debug info for the latter but make sure it + will live on the stack so that it can be accessed from within the + debugger through the PARM_DECL. */ + if (kind == E_Out_Parameter && definition && !optimize && debug_info_p) + { + tree param = create_param_decl (gnu_entity_name, gnu_type, false); + gnat_pushdecl (param, gnat_entity); + SET_DECL_VALUE_EXPR (param, gnu_decl); + DECL_HAS_VALUE_EXPR_P (param) = 1; + DECL_IGNORED_P (gnu_decl) = 1; + TREE_ADDRESSABLE (gnu_decl) = 1; + } + + /* If this is a renaming pointer, attach the renamed object to it and + register it if we are at the global level. Note that an external + constant is at the global level. */ + if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj) + { + SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj); + if ((!definition && kind == E_Constant) || global_bindings_p ()) + { + DECL_RENAMING_GLOBAL_P (gnu_decl) = 1; + record_global_renaming_pointer (gnu_decl); + } + } + + /* If this is a constant and we are defining it or it generates a real + symbol at the object level and we are referencing it, we may want + or need to have a true variable to represent it: + - if optimization isn't enabled, for debugging purposes, + - if the constant is public and not overlaid on something else, + - if its address is taken, + - if either itself or its type is aliased. */ + if (TREE_CODE (gnu_decl) == CONST_DECL + && (definition || Sloc (gnat_entity) > Standard_Location) + && ((!optimize && debug_info_p) + || (Is_Public (gnat_entity) + && No (Address_Clause (gnat_entity))) + || Address_Taken (gnat_entity) + || Is_Aliased (gnat_entity) + || Is_Aliased (Etype (gnat_entity)))) + { + tree gnu_corr_var + = create_true_var_decl (gnu_entity_name, gnu_ext_name, gnu_type, + gnu_expr, true, Is_Public (gnat_entity), + !definition, static_p, attr_list, + gnat_entity); + + SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var); + + /* As debugging information will be generated for the variable, + do not generate debugging information for the constant. */ + if (debug_info_p) + DECL_IGNORED_P (gnu_decl) = 1; + else + DECL_IGNORED_P (gnu_corr_var) = 1; + } + + /* If this is a constant, even if we don't need a true variable, we + may need to avoid returning the initializer in every case. That + can happen for the address of a (constant) constructor because, + upon dereferencing it, the constructor will be reinjected in the + tree, which may not be valid in every case; see lvalue_required_p + for more details. */ + if (TREE_CODE (gnu_decl) == CONST_DECL) + DECL_CONST_ADDRESS_P (gnu_decl) = constructor_address_p (gnu_expr); + + /* If this object is declared in a block that contains a block with an + exception handler, and we aren't using the GCC exception mechanism, + we must force this variable in memory in order to avoid an invalid + optimization. */ + if (Exception_Mechanism != Back_End_Exceptions + && Has_Nested_Block_With_Handler (Scope (gnat_entity))) + TREE_ADDRESSABLE (gnu_decl) = 1; + + /* If we are defining an object with variable size or an object with + fixed size that will be dynamically allocated, and we are using the + setjmp/longjmp exception mechanism, update the setjmp buffer. */ + if (definition + && Exception_Mechanism == Setjmp_Longjmp + && get_block_jmpbuf_decl () + && DECL_SIZE_UNIT (gnu_decl) + && (TREE_CODE (DECL_SIZE_UNIT (gnu_decl)) != INTEGER_CST + || (flag_stack_check == GENERIC_STACK_CHECK + && compare_tree_int (DECL_SIZE_UNIT (gnu_decl), + STACK_CHECK_MAX_VAR_SIZE) > 0))) + add_stmt_with_node (build_call_1_expr + (update_setjmp_buf_decl, + build_unary_op (ADDR_EXPR, NULL_TREE, + get_block_jmpbuf_decl ())), + gnat_entity); + + /* Back-annotate Esize and Alignment of the object if not already + known. Note that we pick the values of the type, not those of + the object, to shield ourselves from low-level platform-dependent + adjustments like alignment promotion. This is both consistent with + all the treatment above, where alignment and size are set on the + type of the object and not on the object directly, and makes it + possible to support all confirming representation clauses. */ + annotate_object (gnat_entity, TREE_TYPE (gnu_decl), gnu_object_size, + used_by_ref, false); + } + break; + + case E_Void: + /* Return a TYPE_DECL for "void" that we previously made. */ + gnu_decl = TYPE_NAME (void_type_node); + break; + + case E_Enumeration_Type: + /* A special case: for the types Character and Wide_Character in + Standard, we do not list all the literals. So if the literals + are not specified, make this an unsigned type. */ + if (No (First_Literal (gnat_entity))) + { + gnu_type = make_unsigned_type (esize); + TYPE_NAME (gnu_type) = gnu_entity_name; + + /* Set TYPE_STRING_FLAG for Character and Wide_Character types. + This is needed by the DWARF-2 back-end to distinguish between + unsigned integer types and character types. */ + TYPE_STRING_FLAG (gnu_type) = 1; + break; + } + + { + /* We have a list of enumeral constants in First_Literal. We make a + CONST_DECL for each one and build into GNU_LITERAL_LIST the list to + be placed into TYPE_FIELDS. Each node in the list is a TREE_LIST + whose TREE_VALUE is the literal name and whose TREE_PURPOSE is the + value of the literal. But when we have a regular boolean type, we + simplify this a little by using a BOOLEAN_TYPE. */ + bool is_boolean = Is_Boolean_Type (gnat_entity) + && !Has_Non_Standard_Rep (gnat_entity); + tree gnu_literal_list = NULL_TREE; + Entity_Id gnat_literal; + + if (Is_Unsigned_Type (gnat_entity)) + gnu_type = make_unsigned_type (esize); + else + gnu_type = make_signed_type (esize); + + TREE_SET_CODE (gnu_type, is_boolean ? BOOLEAN_TYPE : ENUMERAL_TYPE); + + for (gnat_literal = First_Literal (gnat_entity); + Present (gnat_literal); + gnat_literal = Next_Literal (gnat_literal)) + { + tree gnu_value + = UI_To_gnu (Enumeration_Rep (gnat_literal), gnu_type); + tree gnu_literal + = create_var_decl (get_entity_name (gnat_literal), NULL_TREE, + gnu_type, gnu_value, true, false, false, + false, NULL, gnat_literal); + /* Do not generate debug info for individual enumerators. */ + DECL_IGNORED_P (gnu_literal) = 1; + save_gnu_tree (gnat_literal, gnu_literal, false); + gnu_literal_list = tree_cons (DECL_NAME (gnu_literal), + gnu_value, gnu_literal_list); + } + + if (!is_boolean) + TYPE_VALUES (gnu_type) = nreverse (gnu_literal_list); + + /* Note that the bounds are updated at the end of this function + to avoid an infinite recursion since they refer to the type. */ + } + goto discrete_type; + + case E_Signed_Integer_Type: + case E_Ordinary_Fixed_Point_Type: + case E_Decimal_Fixed_Point_Type: + /* For integer types, just make a signed type the appropriate number + of bits. */ + gnu_type = make_signed_type (esize); + goto discrete_type; + + case E_Modular_Integer_Type: + { + /* For modular types, make the unsigned type of the proper number + of bits and then set up the modulus, if required. */ + tree gnu_modulus, gnu_high = NULL_TREE; + + /* Packed array types are supposed to be subtypes only. */ + gcc_assert (!Is_Packed_Array_Type (gnat_entity)); + + gnu_type = make_unsigned_type (esize); + + /* Get the modulus in this type. If it overflows, assume it is because + it is equal to 2**Esize. Note that there is no overflow checking + done on unsigned type, so we detect the overflow by looking for + a modulus of zero, which is otherwise invalid. */ + gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type); + + if (!integer_zerop (gnu_modulus)) + { + TYPE_MODULAR_P (gnu_type) = 1; + SET_TYPE_MODULUS (gnu_type, gnu_modulus); + gnu_high = fold_build2 (MINUS_EXPR, gnu_type, gnu_modulus, + convert (gnu_type, integer_one_node)); + } + + /* If the upper bound is not maximal, make an extra subtype. */ + if (gnu_high + && !tree_int_cst_equal (gnu_high, TYPE_MAX_VALUE (gnu_type))) + { + tree gnu_subtype = make_unsigned_type (esize); + SET_TYPE_RM_MAX_VALUE (gnu_subtype, gnu_high); + TREE_TYPE (gnu_subtype) = gnu_type; + TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1; + TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT"); + gnu_type = gnu_subtype; + } + } + goto discrete_type; + + case E_Signed_Integer_Subtype: + case E_Enumeration_Subtype: + case E_Modular_Integer_Subtype: + case E_Ordinary_Fixed_Point_Subtype: + case E_Decimal_Fixed_Point_Subtype: + + /* For integral subtypes, we make a new INTEGER_TYPE. Note that we do + not want to call create_range_type since we would like each subtype + node to be distinct. ??? Historically this was in preparation for + when memory aliasing is implemented, but that's obsolete now given + the call to relate_alias_sets below. + + The TREE_TYPE field of the INTEGER_TYPE points to the base type; + this fact is used by the arithmetic conversion functions. + + We elaborate the Ancestor_Subtype if it is not in the current unit + and one of our bounds is non-static. We do this to ensure consistent + naming in the case where several subtypes share the same bounds, by + elaborating the first such subtype first, thus using its name. */ + + if (!definition + && Present (Ancestor_Subtype (gnat_entity)) + && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity)) + && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity)) + || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity)))) + gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, 0); + + /* Set the precision to the Esize except for bit-packed arrays. */ + if (Is_Packed_Array_Type (gnat_entity) + && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity))) + esize = UI_To_Int (RM_Size (gnat_entity)); + + /* This should be an unsigned type if the base type is unsigned or + if the lower bound is constant and non-negative or if the type + is biased. */ + if (Is_Unsigned_Type (Etype (gnat_entity)) + || Is_Unsigned_Type (gnat_entity) + || Has_Biased_Representation (gnat_entity)) + gnu_type = make_unsigned_type (esize); + else + gnu_type = make_signed_type (esize); + TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity)); + + SET_TYPE_RM_MIN_VALUE + (gnu_type, + convert (TREE_TYPE (gnu_type), + elaborate_expression (Type_Low_Bound (gnat_entity), + gnat_entity, get_identifier ("L"), + definition, true, + Needs_Debug_Info (gnat_entity)))); + + SET_TYPE_RM_MAX_VALUE + (gnu_type, + convert (TREE_TYPE (gnu_type), + elaborate_expression (Type_High_Bound (gnat_entity), + gnat_entity, get_identifier ("U"), + definition, true, + Needs_Debug_Info (gnat_entity)))); + + /* One of the above calls might have caused us to be elaborated, + so don't blow up if so. */ + if (present_gnu_tree (gnat_entity)) + { + maybe_present = true; + break; + } + + TYPE_BIASED_REPRESENTATION_P (gnu_type) + = Has_Biased_Representation (gnat_entity); + + /* Attach the TYPE_STUB_DECL in case we have a parallel type. */ + TYPE_STUB_DECL (gnu_type) + = create_type_stub_decl (gnu_entity_name, gnu_type); + + /* Inherit our alias set from what we're a subtype of. Subtypes + are not different types and a pointer can designate any instance + within a subtype hierarchy. */ + relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY); + + /* For a packed array, make the original array type a parallel type. */ + if (debug_info_p + && Is_Packed_Array_Type (gnat_entity) + && present_gnu_tree (Original_Array_Type (gnat_entity))) + add_parallel_type (TYPE_STUB_DECL (gnu_type), + gnat_to_gnu_type + (Original_Array_Type (gnat_entity))); + + discrete_type: + + /* We have to handle clauses that under-align the type specially. */ + if ((Present (Alignment_Clause (gnat_entity)) + || (Is_Packed_Array_Type (gnat_entity) + && Present + (Alignment_Clause (Original_Array_Type (gnat_entity))))) + && UI_Is_In_Int_Range (Alignment (gnat_entity))) + { + align = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT; + if (align >= TYPE_ALIGN (gnu_type)) + align = 0; + } + + /* If the type we are dealing with represents a bit-packed array, + we need to have the bits left justified on big-endian targets + and right justified on little-endian targets. We also need to + ensure that when the value is read (e.g. for comparison of two + such values), we only get the good bits, since the unused bits + are uninitialized. Both goals are accomplished by wrapping up + the modular type in an enclosing record type. */ + if (Is_Packed_Array_Type (gnat_entity) + && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity))) + { + tree gnu_field_type, gnu_field; + + /* Set the RM size before wrapping up the original type. */ + SET_TYPE_RM_SIZE (gnu_type, + UI_To_gnu (RM_Size (gnat_entity), bitsizetype)); + TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1; + + /* Create a stripped-down declaration, mainly for debugging. */ + create_type_decl (gnu_entity_name, gnu_type, NULL, true, + debug_info_p, gnat_entity); + + /* Now save it and build the enclosing record type. */ + gnu_field_type = gnu_type; + + gnu_type = make_node (RECORD_TYPE); + TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM"); + TYPE_PACKED (gnu_type) = 1; + TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type); + TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type); + SET_TYPE_ADA_SIZE (gnu_type, TYPE_RM_SIZE (gnu_field_type)); + + /* Propagate the alignment of the modular type to the record type, + unless there is an alignment clause that under-aligns the type. + This means that bit-packed arrays are given "ceil" alignment for + their size by default, which may seem counter-intuitive but makes + it possible to overlay them on modular types easily. */ + TYPE_ALIGN (gnu_type) + = align > 0 ? align : TYPE_ALIGN (gnu_field_type); + + relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY); + + /* Don't declare the field as addressable since we won't be taking + its address and this would prevent create_field_decl from making + a bitfield. */ + gnu_field + = create_field_decl (get_identifier ("OBJECT"), gnu_field_type, + gnu_type, NULL_TREE, bitsize_zero_node, 1, 0); + + /* Do not emit debug info until after the parallel type is added. */ + finish_record_type (gnu_type, gnu_field, 2, false); + compute_record_mode (gnu_type); + TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1; + + if (debug_info_p) + { + /* Make the original array type a parallel type. */ + if (present_gnu_tree (Original_Array_Type (gnat_entity))) + add_parallel_type (TYPE_STUB_DECL (gnu_type), + gnat_to_gnu_type + (Original_Array_Type (gnat_entity))); + + rest_of_record_type_compilation (gnu_type); + } + } + + /* If the type we are dealing with has got a smaller alignment than the + natural one, we need to wrap it up in a record type and under-align + the latter. We reuse the padding machinery for this purpose. */ + else if (align > 0) + { + tree gnu_field_type, gnu_field; + + /* Set the RM size before wrapping up the type. */ + SET_TYPE_RM_SIZE (gnu_type, + UI_To_gnu (RM_Size (gnat_entity), bitsizetype)); + + /* Create a stripped-down declaration, mainly for debugging. */ + create_type_decl (gnu_entity_name, gnu_type, NULL, true, + debug_info_p, gnat_entity); + + /* Now save it and build the enclosing record type. */ + gnu_field_type = gnu_type; + + gnu_type = make_node (RECORD_TYPE); + TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "PAD"); + TYPE_PACKED (gnu_type) = 1; + TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type); + TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type); + SET_TYPE_ADA_SIZE (gnu_type, TYPE_RM_SIZE (gnu_field_type)); + TYPE_ALIGN (gnu_type) = align; + relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY); + + /* Don't declare the field as addressable since we won't be taking + its address and this would prevent create_field_decl from making + a bitfield. */ + gnu_field + = create_field_decl (get_identifier ("F"), gnu_field_type, + gnu_type, NULL_TREE, bitsize_zero_node, 1, 0); + + finish_record_type (gnu_type, gnu_field, 2, debug_info_p); + compute_record_mode (gnu_type); + TYPE_PADDING_P (gnu_type) = 1; + } + + break; + + case E_Floating_Point_Type: + /* If this is a VAX floating-point type, use an integer of the proper + size. All the operations will be handled with ASM statements. */ + if (Vax_Float (gnat_entity)) + { + gnu_type = make_signed_type (esize); + TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1; + SET_TYPE_DIGITS_VALUE (gnu_type, + UI_To_gnu (Digits_Value (gnat_entity), + sizetype)); + break; + } + + /* The type of the Low and High bounds can be our type if this is + a type from Standard, so set them at the end of the function. */ + gnu_type = make_node (REAL_TYPE); + TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize); + layout_type (gnu_type); + break; + + case E_Floating_Point_Subtype: + if (Vax_Float (gnat_entity)) + { + gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); + break; + } + + { + if (!definition + && Present (Ancestor_Subtype (gnat_entity)) + && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity)) + && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity)) + || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity)))) + gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), + gnu_expr, 0); + + gnu_type = make_node (REAL_TYPE); + TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity)); + TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize); + TYPE_GCC_MIN_VALUE (gnu_type) + = TYPE_GCC_MIN_VALUE (TREE_TYPE (gnu_type)); + TYPE_GCC_MAX_VALUE (gnu_type) + = TYPE_GCC_MAX_VALUE (TREE_TYPE (gnu_type)); + layout_type (gnu_type); + + SET_TYPE_RM_MIN_VALUE + (gnu_type, + convert (TREE_TYPE (gnu_type), + elaborate_expression (Type_Low_Bound (gnat_entity), + gnat_entity, get_identifier ("L"), + definition, true, + Needs_Debug_Info (gnat_entity)))); + + SET_TYPE_RM_MAX_VALUE + (gnu_type, + convert (TREE_TYPE (gnu_type), + elaborate_expression (Type_High_Bound (gnat_entity), + gnat_entity, get_identifier ("U"), + definition, true, + Needs_Debug_Info (gnat_entity)))); + + /* One of the above calls might have caused us to be elaborated, + so don't blow up if so. */ + if (present_gnu_tree (gnat_entity)) + { + maybe_present = true; + break; + } + + /* Inherit our alias set from what we're a subtype of, as for + integer subtypes. */ + relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY); + } + break; + + /* Array and String Types and Subtypes + + Unconstrained array types are represented by E_Array_Type and + constrained array types are represented by E_Array_Subtype. There + are no actual objects of an unconstrained array type; all we have + are pointers to that type. + + The following fields are defined on array types and subtypes: + + Component_Type Component type of the array. + Number_Dimensions Number of dimensions (an int). + First_Index Type of first index. */ + + case E_String_Type: + case E_Array_Type: + { + Entity_Id gnat_index, gnat_name; + const bool convention_fortran_p + = (Convention (gnat_entity) == Convention_Fortran); + const int ndim = Number_Dimensions (gnat_entity); + tree gnu_template_fields = NULL_TREE; + tree gnu_template_type = make_node (RECORD_TYPE); + tree gnu_template_reference; + tree gnu_ptr_template = build_pointer_type (gnu_template_type); + tree gnu_fat_type = make_node (RECORD_TYPE); + tree *gnu_index_types = XALLOCAVEC (tree, ndim); + tree *gnu_temp_fields = XALLOCAVEC (tree, ndim); + tree gnu_max_size = size_one_node, gnu_max_size_unit, tem; + int index; + + TYPE_NAME (gnu_template_type) + = create_concat_name (gnat_entity, "XUB"); + + /* Make a node for the array. If we are not defining the array + suppress expanding incomplete types. */ + gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE); + + if (!definition) + { + defer_incomplete_level++; + this_deferred = true; + } + + /* Build the fat pointer type. Use a "void *" object instead of + a pointer to the array type since we don't have the array type + yet (it will reference the fat pointer via the bounds). */ + tem + = create_field_decl (get_identifier ("P_ARRAY"), ptr_void_type_node, + gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0); + TREE_CHAIN (tem) + = create_field_decl (get_identifier ("P_BOUNDS"), gnu_ptr_template, + gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0); + finish_fat_pointer_type (gnu_fat_type, tem); + + /* Build a reference to the template from a PLACEHOLDER_EXPR that + is the fat pointer. This will be used to access the individual + fields once we build them. */ + tem = build3 (COMPONENT_REF, gnu_ptr_template, + build0 (PLACEHOLDER_EXPR, gnu_fat_type), + DECL_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE); + gnu_template_reference + = build_unary_op (INDIRECT_REF, gnu_template_type, tem); + TREE_READONLY (gnu_template_reference) = 1; + + /* Now create the GCC type for each index and add the fields for that + index to the template. */ + for (index = (convention_fortran_p ? ndim - 1 : 0), + gnat_index = First_Index (gnat_entity); + 0 <= index && index < ndim; + index += (convention_fortran_p ? - 1 : 1), + gnat_index = Next_Index (gnat_index)) + { + char field_name[16]; + tree gnu_index_base_type + = get_unpadded_type (Base_Type (Etype (gnat_index))); + tree gnu_lb_field, gnu_hb_field, gnu_orig_min, gnu_orig_max; + tree gnu_min, gnu_max, gnu_high; + + /* Make the FIELD_DECLs for the low and high bounds of this + type and then make extractions of these fields from the + template. */ + sprintf (field_name, "LB%d", index); + gnu_lb_field = create_field_decl (get_identifier (field_name), + gnu_index_base_type, + gnu_template_type, NULL_TREE, + NULL_TREE, 0, 0); + Sloc_to_locus (Sloc (gnat_entity), + &DECL_SOURCE_LOCATION (gnu_lb_field)); + + field_name[0] = 'U'; + gnu_hb_field = create_field_decl (get_identifier (field_name), + gnu_index_base_type, + gnu_template_type, NULL_TREE, + NULL_TREE, 0, 0); + Sloc_to_locus (Sloc (gnat_entity), + &DECL_SOURCE_LOCATION (gnu_hb_field)); + + gnu_temp_fields[index] = chainon (gnu_lb_field, gnu_hb_field); + + /* We can't use build_component_ref here since the template type + isn't complete yet. */ + gnu_orig_min = build3 (COMPONENT_REF, gnu_index_base_type, + gnu_template_reference, gnu_lb_field, + NULL_TREE); + gnu_orig_max = build3 (COMPONENT_REF, gnu_index_base_type, + gnu_template_reference, gnu_hb_field, + NULL_TREE); + TREE_READONLY (gnu_orig_min) = TREE_READONLY (gnu_orig_max) = 1; + + gnu_min = convert (sizetype, gnu_orig_min); + gnu_max = convert (sizetype, gnu_orig_max); + + /* Compute the size of this dimension. See the E_Array_Subtype + case below for the rationale. */ + gnu_high + = build3 (COND_EXPR, sizetype, + build2 (GE_EXPR, boolean_type_node, + gnu_orig_max, gnu_orig_min), + gnu_max, + size_binop (MINUS_EXPR, gnu_min, size_one_node)); + + /* Make a range type with the new range in the Ada base type. + Then make an index type with the size range in sizetype. */ + gnu_index_types[index] + = create_index_type (gnu_min, gnu_high, + create_range_type (gnu_index_base_type, + gnu_orig_min, + gnu_orig_max), + gnat_entity); + + /* Update the maximum size of the array in elements. */ + if (gnu_max_size) + { + tree gnu_index_type = get_unpadded_type (Etype (gnat_index)); + tree gnu_min + = convert (sizetype, TYPE_MIN_VALUE (gnu_index_type)); + tree gnu_max + = convert (sizetype, TYPE_MAX_VALUE (gnu_index_type)); + tree gnu_this_max + = size_binop (MAX_EXPR, + size_binop (PLUS_EXPR, size_one_node, + size_binop (MINUS_EXPR, + gnu_max, gnu_min)), + size_zero_node); + + if (TREE_CODE (gnu_this_max) == INTEGER_CST + && TREE_OVERFLOW (gnu_this_max)) + gnu_max_size = NULL_TREE; + else + gnu_max_size + = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max); + } + + TYPE_NAME (gnu_index_types[index]) + = create_concat_name (gnat_entity, field_name); + } + + for (index = 0; index < ndim; index++) + gnu_template_fields + = chainon (gnu_template_fields, gnu_temp_fields[index]); + + /* Install all the fields into the template. */ + finish_record_type (gnu_template_type, gnu_template_fields, 0, + debug_info_p); + TYPE_READONLY (gnu_template_type) = 1; + + /* Now make the array of arrays and update the pointer to the array + in the fat pointer. Note that it is the first field. */ + tem = gnat_to_gnu_component_type (gnat_entity, definition, + debug_info_p); + + /* If Component_Size is not already specified, annotate it with the + size of the component. */ + if (Unknown_Component_Size (gnat_entity)) + Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem))); + + /* Compute the maximum size of the array in units and bits. */ + if (gnu_max_size) + { + gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size, + TYPE_SIZE_UNIT (tem)); + gnu_max_size = size_binop (MULT_EXPR, + convert (bitsizetype, gnu_max_size), + TYPE_SIZE (tem)); + } + else + gnu_max_size_unit = NULL_TREE; + + /* Now build the array type. */ + for (index = ndim - 1; index >= 0; index--) + { + tem = build_nonshared_array_type (tem, gnu_index_types[index]); + TYPE_MULTI_ARRAY_P (tem) = (index > 0); + if (array_type_has_nonaliased_component (tem, gnat_entity)) + TYPE_NONALIASED_COMPONENT (tem) = 1; + } + + /* If an alignment is specified, use it if valid. But ignore it + for the original type of packed array types. If the alignment + was requested with an explicit alignment clause, state so. */ + if (No (Packed_Array_Type (gnat_entity)) + && Known_Alignment (gnat_entity)) + { + TYPE_ALIGN (tem) + = validate_alignment (Alignment (gnat_entity), gnat_entity, + TYPE_ALIGN (tem)); + if (Present (Alignment_Clause (gnat_entity))) + TYPE_USER_ALIGN (tem) = 1; + } + + TYPE_CONVENTION_FORTRAN_P (tem) = convention_fortran_p; + TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem); + + /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the + corresponding fat pointer. */ + TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) + = TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type; + SET_TYPE_MODE (gnu_type, BLKmode); + TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem); + SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type); + + /* If the maximum size doesn't overflow, use it. */ + if (gnu_max_size + && TREE_CODE (gnu_max_size) == INTEGER_CST + && !TREE_OVERFLOW (gnu_max_size) + && TREE_CODE (gnu_max_size_unit) == INTEGER_CST + && !TREE_OVERFLOW (gnu_max_size_unit)) + { + TYPE_SIZE (tem) = size_binop (MIN_EXPR, gnu_max_size, + TYPE_SIZE (tem)); + TYPE_SIZE_UNIT (tem) = size_binop (MIN_EXPR, gnu_max_size_unit, + TYPE_SIZE_UNIT (tem)); + } + + create_type_decl (create_concat_name (gnat_entity, "XUA"), + tem, NULL, !Comes_From_Source (gnat_entity), + debug_info_p, gnat_entity); + + /* Give the fat pointer type a name. If this is a packed type, tell + the debugger how to interpret the underlying bits. */ + if (Present (Packed_Array_Type (gnat_entity))) + gnat_name = Packed_Array_Type (gnat_entity); + else + gnat_name = gnat_entity; + create_type_decl (create_concat_name (gnat_name, "XUP"), + gnu_fat_type, NULL, true, + debug_info_p, gnat_entity); + + /* Create the type to be used as what a thin pointer designates: + a record type for the object and its template with the fields + shifted to have the template at a negative offset. */ + tem = build_unc_object_type (gnu_template_type, tem, + create_concat_name (gnat_name, "XUT"), + debug_info_p); + shift_unc_components_for_thin_pointers (tem); + + SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type); + TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem; + } + break; + + case E_String_Subtype: + case E_Array_Subtype: + + /* This is the actual data type for array variables. Multidimensional + arrays are implemented as arrays of arrays. Note that arrays which + have sparse enumeration subtypes as index components create sparse + arrays, which is obviously space inefficient but so much easier to + code for now. + + Also note that the subtype never refers to the unconstrained array + type, which is somewhat at variance with Ada semantics. + + First check to see if this is simply a renaming of the array type. + If so, the result is the array type. */ + + gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); + if (!Is_Constrained (gnat_entity)) + ; + else + { + Entity_Id gnat_index, gnat_base_index; + const bool convention_fortran_p + = (Convention (gnat_entity) == Convention_Fortran); + const int ndim = Number_Dimensions (gnat_entity); + tree gnu_base_type = gnu_type; + tree *gnu_index_types = XALLOCAVEC (tree, ndim); + tree gnu_max_size = size_one_node, gnu_max_size_unit; + bool need_index_type_struct = false; + int index; + + /* First create the GCC type for each index and find out whether + special types are needed for debugging information. */ + for (index = (convention_fortran_p ? ndim - 1 : 0), + gnat_index = First_Index (gnat_entity), + gnat_base_index + = First_Index (Implementation_Base_Type (gnat_entity)); + 0 <= index && index < ndim; + index += (convention_fortran_p ? - 1 : 1), + gnat_index = Next_Index (gnat_index), + gnat_base_index = Next_Index (gnat_base_index)) + { + tree gnu_index_type = get_unpadded_type (Etype (gnat_index)); + tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type); + tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type); + tree gnu_min = convert (sizetype, gnu_orig_min); + tree gnu_max = convert (sizetype, gnu_orig_max); + tree gnu_base_index_type + = get_unpadded_type (Etype (gnat_base_index)); + tree gnu_base_orig_min = TYPE_MIN_VALUE (gnu_base_index_type); + tree gnu_base_orig_max = TYPE_MAX_VALUE (gnu_base_index_type); + tree gnu_high; + + /* See if the base array type is already flat. If it is, we + are probably compiling an ACATS test but it will cause the + code below to malfunction if we don't handle it specially. */ + if (TREE_CODE (gnu_base_orig_min) == INTEGER_CST + && TREE_CODE (gnu_base_orig_max) == INTEGER_CST + && tree_int_cst_lt (gnu_base_orig_max, gnu_base_orig_min)) + { + gnu_min = size_one_node; + gnu_max = size_zero_node; + gnu_high = gnu_max; + } + + /* Similarly, if one of the values overflows in sizetype and the + range is null, use 1..0 for the sizetype bounds. */ + else if (TREE_CODE (gnu_min) == INTEGER_CST + && TREE_CODE (gnu_max) == INTEGER_CST + && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max)) + && tree_int_cst_lt (gnu_orig_max, gnu_orig_min)) + { + gnu_min = size_one_node; + gnu_max = size_zero_node; + gnu_high = gnu_max; + } + + /* If the minimum and maximum values both overflow in sizetype, + but the difference in the original type does not overflow in + sizetype, ignore the overflow indication. */ + else if (TREE_CODE (gnu_min) == INTEGER_CST + && TREE_CODE (gnu_max) == INTEGER_CST + && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max) + && !TREE_OVERFLOW + (convert (sizetype, + fold_build2 (MINUS_EXPR, gnu_index_type, + gnu_orig_max, + gnu_orig_min)))) + { + TREE_OVERFLOW (gnu_min) = 0; + TREE_OVERFLOW (gnu_max) = 0; + gnu_high = gnu_max; + } + + /* Compute the size of this dimension in the general case. We + need to provide GCC with an upper bound to use but have to + deal with the "superflat" case. There are three ways to do + this. If we can prove that the array can never be superflat, + we can just use the high bound of the index type. */ + else if ((Nkind (gnat_index) == N_Range + && cannot_be_superflat_p (gnat_index)) + /* Packed Array Types are never superflat. */ + || Is_Packed_Array_Type (gnat_entity)) + gnu_high = gnu_max; + + /* Otherwise, if the high bound is constant but the low bound is + not, we use the expression (hb >= lb) ? lb : hb + 1 for the + lower bound. Note that the comparison must be done in the + original type to avoid any overflow during the conversion. */ + else if (TREE_CODE (gnu_max) == INTEGER_CST + && TREE_CODE (gnu_min) != INTEGER_CST) + { + gnu_high = gnu_max; + gnu_min + = build_cond_expr (sizetype, + build_binary_op (GE_EXPR, + boolean_type_node, + gnu_orig_max, + gnu_orig_min), + gnu_min, + size_binop (PLUS_EXPR, gnu_max, + size_one_node)); + } + + /* Finally we use (hb >= lb) ? hb : lb - 1 for the upper bound + in all the other cases. Note that, here as well as above, + the condition used in the comparison must be equivalent to + the condition (length != 0). This is relied upon in order + to optimize array comparisons in compare_arrays. */ + else + gnu_high + = build_cond_expr (sizetype, + build_binary_op (GE_EXPR, + boolean_type_node, + gnu_orig_max, + gnu_orig_min), + gnu_max, + size_binop (MINUS_EXPR, gnu_min, + size_one_node)); + + /* Reuse the index type for the range type. Then make an index + type with the size range in sizetype. */ + gnu_index_types[index] + = create_index_type (gnu_min, gnu_high, gnu_index_type, + gnat_entity); + + /* Update the maximum size of the array in elements. Here we + see if any constraint on the index type of the base type + can be used in the case of self-referential bound on the + index type of the subtype. We look for a non-"infinite" + and non-self-referential bound from any type involved and + handle each bound separately. */ + if (gnu_max_size) + { + tree gnu_base_min = convert (sizetype, gnu_base_orig_min); + tree gnu_base_max = convert (sizetype, gnu_base_orig_max); + tree gnu_base_index_base_type + = get_base_type (gnu_base_index_type); + tree gnu_base_base_min + = convert (sizetype, + TYPE_MIN_VALUE (gnu_base_index_base_type)); + tree gnu_base_base_max + = convert (sizetype, + TYPE_MAX_VALUE (gnu_base_index_base_type)); + + if (!CONTAINS_PLACEHOLDER_P (gnu_min) + || !(TREE_CODE (gnu_base_min) == INTEGER_CST + && !TREE_OVERFLOW (gnu_base_min))) + gnu_base_min = gnu_min; + + if (!CONTAINS_PLACEHOLDER_P (gnu_max) + || !(TREE_CODE (gnu_base_max) == INTEGER_CST + && !TREE_OVERFLOW (gnu_base_max))) + gnu_base_max = gnu_max; + + if ((TREE_CODE (gnu_base_min) == INTEGER_CST + && TREE_OVERFLOW (gnu_base_min)) + || operand_equal_p (gnu_base_min, gnu_base_base_min, 0) + || (TREE_CODE (gnu_base_max) == INTEGER_CST + && TREE_OVERFLOW (gnu_base_max)) + || operand_equal_p (gnu_base_max, gnu_base_base_max, 0)) + gnu_max_size = NULL_TREE; + else + { + tree gnu_this_max + = size_binop (MAX_EXPR, + size_binop (PLUS_EXPR, size_one_node, + size_binop (MINUS_EXPR, + gnu_base_max, + gnu_base_min)), + size_zero_node); + + if (TREE_CODE (gnu_this_max) == INTEGER_CST + && TREE_OVERFLOW (gnu_this_max)) + gnu_max_size = NULL_TREE; + else + gnu_max_size + = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max); + } + } + + /* We need special types for debugging information to point to + the index types if they have variable bounds, are not integer + types, are biased or are wider than sizetype. */ + if (!integer_onep (gnu_orig_min) + || TREE_CODE (gnu_orig_max) != INTEGER_CST + || TREE_CODE (gnu_index_type) != INTEGER_TYPE + || (TREE_TYPE (gnu_index_type) + && TREE_CODE (TREE_TYPE (gnu_index_type)) + != INTEGER_TYPE) + || TYPE_BIASED_REPRESENTATION_P (gnu_index_type) + || compare_tree_int (rm_size (gnu_index_type), + TYPE_PRECISION (sizetype)) > 0) + need_index_type_struct = true; + } + + /* Then flatten: create the array of arrays. For an array type + used to implement a packed array, get the component type from + the original array type since the representation clauses that + can affect it are on the latter. */ + if (Is_Packed_Array_Type (gnat_entity) + && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity))) + { + gnu_type = gnat_to_gnu_type (Original_Array_Type (gnat_entity)); + for (index = ndim - 1; index >= 0; index--) + gnu_type = TREE_TYPE (gnu_type); + + /* One of the above calls might have caused us to be elaborated, + so don't blow up if so. */ + if (present_gnu_tree (gnat_entity)) + { + maybe_present = true; + break; + } + } + else + { + gnu_type = gnat_to_gnu_component_type (gnat_entity, definition, + debug_info_p); + + /* One of the above calls might have caused us to be elaborated, + so don't blow up if so. */ + if (present_gnu_tree (gnat_entity)) + { + maybe_present = true; + break; + } + } + + /* Compute the maximum size of the array in units and bits. */ + if (gnu_max_size) + { + gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size, + TYPE_SIZE_UNIT (gnu_type)); + gnu_max_size = size_binop (MULT_EXPR, + convert (bitsizetype, gnu_max_size), + TYPE_SIZE (gnu_type)); + } + else + gnu_max_size_unit = NULL_TREE; + + /* Now build the array type. */ + for (index = ndim - 1; index >= 0; index --) + { + gnu_type = build_nonshared_array_type (gnu_type, + gnu_index_types[index]); + TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0); + if (array_type_has_nonaliased_component (gnu_type, gnat_entity)) + TYPE_NONALIASED_COMPONENT (gnu_type) = 1; + } + + /* Attach the TYPE_STUB_DECL in case we have a parallel type. */ + TYPE_STUB_DECL (gnu_type) + = create_type_stub_decl (gnu_entity_name, gnu_type); + + /* If we are at file level and this is a multi-dimensional array, + we need to make a variable corresponding to the stride of the + inner dimensions. */ + if (global_bindings_p () && ndim > 1) + { + tree gnu_st_name = get_identifier ("ST"); + tree gnu_arr_type; + + for (gnu_arr_type = TREE_TYPE (gnu_type); + TREE_CODE (gnu_arr_type) == ARRAY_TYPE; + gnu_arr_type = TREE_TYPE (gnu_arr_type), + gnu_st_name = concat_name (gnu_st_name, "ST")) + { + tree eltype = TREE_TYPE (gnu_arr_type); + + TYPE_SIZE (gnu_arr_type) + = elaborate_expression_1 (TYPE_SIZE (gnu_arr_type), + gnat_entity, gnu_st_name, + definition, false); + + /* ??? For now, store the size as a multiple of the + alignment of the element type in bytes so that we + can see the alignment from the tree. */ + TYPE_SIZE_UNIT (gnu_arr_type) + = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_arr_type), + gnat_entity, + concat_name (gnu_st_name, "A_U"), + definition, false, + TYPE_ALIGN (eltype)); + + /* ??? create_type_decl is not invoked on the inner types so + the MULT_EXPR node built above will never be marked. */ + MARK_VISITED (TYPE_SIZE_UNIT (gnu_arr_type)); + } + } + + /* If we need to write out a record type giving the names of the + bounds for debugging purposes, do it now and make the record + type a parallel type. This is not needed for a packed array + since the bounds are conveyed by the original array type. */ + if (need_index_type_struct + && debug_info_p + && !Is_Packed_Array_Type (gnat_entity)) + { + tree gnu_bound_rec = make_node (RECORD_TYPE); + tree gnu_field_list = NULL_TREE; + tree gnu_field; + + TYPE_NAME (gnu_bound_rec) + = create_concat_name (gnat_entity, "XA"); + + for (index = ndim - 1; index >= 0; index--) + { + tree gnu_index = TYPE_INDEX_TYPE (gnu_index_types[index]); + tree gnu_index_name = TYPE_NAME (gnu_index); + + if (TREE_CODE (gnu_index_name) == TYPE_DECL) + gnu_index_name = DECL_NAME (gnu_index_name); + + /* Make sure to reference the types themselves, and not just + their names, as the debugger may fall back on them. */ + gnu_field = create_field_decl (gnu_index_name, gnu_index, + gnu_bound_rec, NULL_TREE, + NULL_TREE, 0, 0); + DECL_CHAIN (gnu_field) = gnu_field_list; + gnu_field_list = gnu_field; + } + + finish_record_type (gnu_bound_rec, gnu_field_list, 0, true); + add_parallel_type (TYPE_STUB_DECL (gnu_type), gnu_bound_rec); + } + + /* Otherwise, for a packed array, make the original array type a + parallel type. */ + else if (debug_info_p + && Is_Packed_Array_Type (gnat_entity) + && present_gnu_tree (Original_Array_Type (gnat_entity))) + add_parallel_type (TYPE_STUB_DECL (gnu_type), + gnat_to_gnu_type + (Original_Array_Type (gnat_entity))); + + TYPE_CONVENTION_FORTRAN_P (gnu_type) = convention_fortran_p; + TYPE_PACKED_ARRAY_TYPE_P (gnu_type) + = (Is_Packed_Array_Type (gnat_entity) + && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity))); + + /* If the size is self-referential and the maximum size doesn't + overflow, use it. */ + if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)) + && gnu_max_size + && !(TREE_CODE (gnu_max_size) == INTEGER_CST + && TREE_OVERFLOW (gnu_max_size)) + && !(TREE_CODE (gnu_max_size_unit) == INTEGER_CST + && TREE_OVERFLOW (gnu_max_size_unit))) + { + TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size, + TYPE_SIZE (gnu_type)); + TYPE_SIZE_UNIT (gnu_type) + = size_binop (MIN_EXPR, gnu_max_size_unit, + TYPE_SIZE_UNIT (gnu_type)); + } + + /* Set our alias set to that of our base type. This gives all + array subtypes the same alias set. */ + relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY); + + /* If this is a packed type, make this type the same as the packed + array type, but do some adjusting in the type first. */ + if (Present (Packed_Array_Type (gnat_entity))) + { + Entity_Id gnat_index; + tree gnu_inner; + + /* First finish the type we had been making so that we output + debugging information for it. */ + if (Treat_As_Volatile (gnat_entity)) + gnu_type + = build_qualified_type (gnu_type, + TYPE_QUALS (gnu_type) + | TYPE_QUAL_VOLATILE); + + /* Make it artificial only if the base type was artificial too. + That's sort of "morally" true and will make it possible for + the debugger to look it up by name in DWARF, which is needed + in order to decode the packed array type. */ + gnu_decl + = create_type_decl (gnu_entity_name, gnu_type, attr_list, + !Comes_From_Source (Etype (gnat_entity)) + && !Comes_From_Source (gnat_entity), + debug_info_p, gnat_entity); + + /* Save it as our equivalent in case the call below elaborates + this type again. */ + save_gnu_tree (gnat_entity, gnu_decl, false); + + gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity), + NULL_TREE, 0); + this_made_decl = true; + gnu_type = TREE_TYPE (gnu_decl); + save_gnu_tree (gnat_entity, NULL_TREE, false); + + gnu_inner = gnu_type; + while (TREE_CODE (gnu_inner) == RECORD_TYPE + && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner) + || TYPE_PADDING_P (gnu_inner))) + gnu_inner = TREE_TYPE (TYPE_FIELDS (gnu_inner)); + + /* We need to attach the index type to the type we just made so + that the actual bounds can later be put into a template. */ + if ((TREE_CODE (gnu_inner) == ARRAY_TYPE + && !TYPE_ACTUAL_BOUNDS (gnu_inner)) + || (TREE_CODE (gnu_inner) == INTEGER_TYPE + && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner))) + { + if (TREE_CODE (gnu_inner) == INTEGER_TYPE) + { + /* The TYPE_ACTUAL_BOUNDS field is overloaded with the + TYPE_MODULUS for modular types so we make an extra + subtype if necessary. */ + if (TYPE_MODULAR_P (gnu_inner)) + { + tree gnu_subtype + = make_unsigned_type (TYPE_PRECISION (gnu_inner)); + TREE_TYPE (gnu_subtype) = gnu_inner; + TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1; + SET_TYPE_RM_MIN_VALUE (gnu_subtype, + TYPE_MIN_VALUE (gnu_inner)); + SET_TYPE_RM_MAX_VALUE (gnu_subtype, + TYPE_MAX_VALUE (gnu_inner)); + gnu_inner = gnu_subtype; + } + + TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner) = 1; + +#ifdef ENABLE_CHECKING + /* Check for other cases of overloading. */ + gcc_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner)); +#endif + } + + for (gnat_index = First_Index (gnat_entity); + Present (gnat_index); + gnat_index = Next_Index (gnat_index)) + SET_TYPE_ACTUAL_BOUNDS + (gnu_inner, + tree_cons (NULL_TREE, + get_unpadded_type (Etype (gnat_index)), + TYPE_ACTUAL_BOUNDS (gnu_inner))); + + if (Convention (gnat_entity) != Convention_Fortran) + SET_TYPE_ACTUAL_BOUNDS + (gnu_inner, nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner))); + + if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (gnu_type)) + TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner; + } + } + + else + /* Abort if packed array with no Packed_Array_Type field set. */ + gcc_assert (!Is_Packed (gnat_entity)); + } + break; + + case E_String_Literal_Subtype: + /* Create the type for a string literal. */ + { + Entity_Id gnat_full_type + = (IN (Ekind (Etype (gnat_entity)), Private_Kind) + && Present (Full_View (Etype (gnat_entity))) + ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity)); + tree gnu_string_type = get_unpadded_type (gnat_full_type); + tree gnu_string_array_type + = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type)))); + tree gnu_string_index_type + = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE + (TYPE_DOMAIN (gnu_string_array_type)))); + tree gnu_lower_bound + = convert (gnu_string_index_type, + gnat_to_gnu (String_Literal_Low_Bound (gnat_entity))); + int length = UI_To_Int (String_Literal_Length (gnat_entity)); + tree gnu_length = ssize_int (length - 1); + tree gnu_upper_bound + = build_binary_op (PLUS_EXPR, gnu_string_index_type, + gnu_lower_bound, + convert (gnu_string_index_type, gnu_length)); + tree gnu_index_type + = create_index_type (convert (sizetype, gnu_lower_bound), + convert (sizetype, gnu_upper_bound), + create_range_type (gnu_string_index_type, + gnu_lower_bound, + gnu_upper_bound), + gnat_entity); + + gnu_type + = build_nonshared_array_type (gnat_to_gnu_type + (Component_Type (gnat_entity)), + gnu_index_type); + if (array_type_has_nonaliased_component (gnu_type, gnat_entity)) + TYPE_NONALIASED_COMPONENT (gnu_type) = 1; + relate_alias_sets (gnu_type, gnu_string_type, ALIAS_SET_COPY); + } + break; + + /* Record Types and Subtypes + + The following fields are defined on record types: + + Has_Discriminants True if the record has discriminants + First_Discriminant Points to head of list of discriminants + First_Entity Points to head of list of fields + Is_Tagged_Type True if the record is tagged + + Implementation of Ada records and discriminated records: + + A record type definition is transformed into the equivalent of a C + struct definition. The fields that are the discriminants which are + found in the Full_Type_Declaration node and the elements of the + Component_List found in the Record_Type_Definition node. The + Component_List can be a recursive structure since each Variant of + the Variant_Part of the Component_List has a Component_List. + + Processing of a record type definition comprises starting the list of + field declarations here from the discriminants and the calling the + function components_to_record to add the rest of the fields from the + component list and return the gnu type node. The function + components_to_record will call itself recursively as it traverses + the tree. */ + + case E_Record_Type: + if (Has_Complex_Representation (gnat_entity)) + { + gnu_type + = build_complex_type + (get_unpadded_type + (Etype (Defining_Entity + (First (Component_Items + (Component_List + (Type_Definition + (Declaration_Node (gnat_entity))))))))); + + break; + } + + { + Node_Id full_definition = Declaration_Node (gnat_entity); + Node_Id record_definition = Type_Definition (full_definition); + Entity_Id gnat_field; + tree gnu_field, gnu_field_list = NULL_TREE, gnu_get_parent; + /* Set PACKED in keeping with gnat_to_gnu_field. */ + int packed + = Is_Packed (gnat_entity) + ? 1 + : Component_Alignment (gnat_entity) == Calign_Storage_Unit + ? -1 + : (Known_Alignment (gnat_entity) + || (Strict_Alignment (gnat_entity) + && Known_Static_Esize (gnat_entity))) + ? -2 + : 0; + bool has_discr = Has_Discriminants (gnat_entity); + bool has_rep = Has_Specified_Layout (gnat_entity); + bool all_rep = has_rep; + bool is_extension + = (Is_Tagged_Type (gnat_entity) + && Nkind (record_definition) == N_Derived_Type_Definition); + bool is_unchecked_union = Is_Unchecked_Union (gnat_entity); + + /* See if all fields have a rep clause. Stop when we find one + that doesn't. */ + if (all_rep) + for (gnat_field = First_Entity (gnat_entity); + Present (gnat_field); + gnat_field = Next_Entity (gnat_field)) + if ((Ekind (gnat_field) == E_Component + || Ekind (gnat_field) == E_Discriminant) + && No (Component_Clause (gnat_field))) + { + all_rep = false; + break; + } + + /* If this is a record extension, go a level further to find the + record definition. Also, verify we have a Parent_Subtype. */ + if (is_extension) + { + if (!type_annotate_only + || Present (Record_Extension_Part (record_definition))) + record_definition = Record_Extension_Part (record_definition); + + gcc_assert (type_annotate_only + || Present (Parent_Subtype (gnat_entity))); + } + + /* Make a node for the record. If we are not defining the record, + suppress expanding incomplete types. */ + gnu_type = make_node (tree_code_for_record_type (gnat_entity)); + TYPE_NAME (gnu_type) = gnu_entity_name; + TYPE_PACKED (gnu_type) = (packed != 0) || has_rep; + + if (!definition) + { + defer_incomplete_level++; + this_deferred = true; + } + + /* If both a size and rep clause was specified, put the size in + the record type now so that it can get the proper mode. */ + if (has_rep && Known_Esize (gnat_entity)) + TYPE_SIZE (gnu_type) = UI_To_gnu (Esize (gnat_entity), sizetype); + + /* Always set the alignment here so that it can be used to + set the mode, if it is making the alignment stricter. If + it is invalid, it will be checked again below. If this is to + be Atomic, choose a default alignment of a word unless we know + the size and it's smaller. */ + if (Known_Alignment (gnat_entity)) + TYPE_ALIGN (gnu_type) + = validate_alignment (Alignment (gnat_entity), gnat_entity, 0); + else if (Is_Atomic (gnat_entity)) + TYPE_ALIGN (gnu_type) + = esize >= BITS_PER_WORD ? BITS_PER_WORD : ceil_alignment (esize); + /* If a type needs strict alignment, the minimum size will be the + type size instead of the RM size (see validate_size). Cap the + alignment, lest it causes this type size to become too large. */ + else if (Strict_Alignment (gnat_entity) + && Known_Static_Esize (gnat_entity)) + { + unsigned int raw_size = UI_To_Int (Esize (gnat_entity)); + unsigned int raw_align = raw_size & -raw_size; + if (raw_align < BIGGEST_ALIGNMENT) + TYPE_ALIGN (gnu_type) = raw_align; + } + else + TYPE_ALIGN (gnu_type) = 0; + + /* If we have a Parent_Subtype, make a field for the parent. If + this record has rep clauses, force the position to zero. */ + if (Present (Parent_Subtype (gnat_entity))) + { + Entity_Id gnat_parent = Parent_Subtype (gnat_entity); + tree gnu_parent; + + /* A major complexity here is that the parent subtype will + reference our discriminants in its Discriminant_Constraint + list. But those must reference the parent component of this + record which is of the parent subtype we have not built yet! + To break the circle we first build a dummy COMPONENT_REF which + represents the "get to the parent" operation and initialize + each of those discriminants to a COMPONENT_REF of the above + dummy parent referencing the corresponding discriminant of the + base type of the parent subtype. */ + gnu_get_parent = build3 (COMPONENT_REF, void_type_node, + build0 (PLACEHOLDER_EXPR, gnu_type), + build_decl (input_location, + FIELD_DECL, NULL_TREE, + void_type_node), + NULL_TREE); + + if (has_discr) + for (gnat_field = First_Stored_Discriminant (gnat_entity); + Present (gnat_field); + gnat_field = Next_Stored_Discriminant (gnat_field)) + if (Present (Corresponding_Discriminant (gnat_field))) + { + tree gnu_field + = gnat_to_gnu_field_decl (Corresponding_Discriminant + (gnat_field)); + save_gnu_tree + (gnat_field, + build3 (COMPONENT_REF, TREE_TYPE (gnu_field), + gnu_get_parent, gnu_field, NULL_TREE), + true); + } + + /* Then we build the parent subtype. If it has discriminants but + the type itself has unknown discriminants, this means that it + doesn't contain information about how the discriminants are + derived from those of the ancestor type, so it cannot be used + directly. Instead it is built by cloning the parent subtype + of the underlying record view of the type, for which the above + derivation of discriminants has been made explicit. */ + if (Has_Discriminants (gnat_parent) + && Has_Unknown_Discriminants (gnat_entity)) + { + Entity_Id gnat_uview = Underlying_Record_View (gnat_entity); + + /* If we are defining the type, the underlying record + view must already have been elaborated at this point. + Otherwise do it now as its parent subtype cannot be + technically elaborated on its own. */ + if (definition) + gcc_assert (present_gnu_tree (gnat_uview)); + else + gnat_to_gnu_entity (gnat_uview, NULL_TREE, 0); + + gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_uview)); + + /* Substitute the "get to the parent" of the type for that + of its underlying record view in the cloned type. */ + for (gnat_field = First_Stored_Discriminant (gnat_uview); + Present (gnat_field); + gnat_field = Next_Stored_Discriminant (gnat_field)) + if (Present (Corresponding_Discriminant (gnat_field))) + { + tree gnu_field = gnat_to_gnu_field_decl (gnat_field); + tree gnu_ref + = build3 (COMPONENT_REF, TREE_TYPE (gnu_field), + gnu_get_parent, gnu_field, NULL_TREE); + gnu_parent + = substitute_in_type (gnu_parent, gnu_field, gnu_ref); + } + } + else + gnu_parent = gnat_to_gnu_type (gnat_parent); + + /* Finally we fix up both kinds of twisted COMPONENT_REF we have + initially built. The discriminants must reference the fields + of the parent subtype and not those of its base type for the + placeholder machinery to properly work. */ + if (has_discr) + { + /* The actual parent subtype is the full view. */ + if (IN (Ekind (gnat_parent), Private_Kind)) + { + if (Present (Full_View (gnat_parent))) + gnat_parent = Full_View (gnat_parent); + else + gnat_parent = Underlying_Full_View (gnat_parent); + } + + for (gnat_field = First_Stored_Discriminant (gnat_entity); + Present (gnat_field); + gnat_field = Next_Stored_Discriminant (gnat_field)) + if (Present (Corresponding_Discriminant (gnat_field))) + { + Entity_Id field = Empty; + for (field = First_Stored_Discriminant (gnat_parent); + Present (field); + field = Next_Stored_Discriminant (field)) + if (same_discriminant_p (gnat_field, field)) + break; + gcc_assert (Present (field)); + TREE_OPERAND (get_gnu_tree (gnat_field), 1) + = gnat_to_gnu_field_decl (field); + } + } + + /* The "get to the parent" COMPONENT_REF must be given its + proper type... */ + TREE_TYPE (gnu_get_parent) = gnu_parent; + + /* ...and reference the _Parent field of this record. */ + gnu_field + = create_field_decl (parent_name_id, + gnu_parent, gnu_type, + has_rep + ? TYPE_SIZE (gnu_parent) : NULL_TREE, + has_rep + ? bitsize_zero_node : NULL_TREE, + 0, 1); + DECL_INTERNAL_P (gnu_field) = 1; + TREE_OPERAND (gnu_get_parent, 1) = gnu_field; + TYPE_FIELDS (gnu_type) = gnu_field; + } + + /* Make the fields for the discriminants and put them into the record + unless it's an Unchecked_Union. */ + if (has_discr) + for (gnat_field = First_Stored_Discriminant (gnat_entity); + Present (gnat_field); + gnat_field = Next_Stored_Discriminant (gnat_field)) + { + /* If this is a record extension and this discriminant is the + renaming of another discriminant, we've handled it above. */ + if (Present (Parent_Subtype (gnat_entity)) + && Present (Corresponding_Discriminant (gnat_field))) + continue; + + gnu_field + = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition, + debug_info_p); + + /* Make an expression using a PLACEHOLDER_EXPR from the + FIELD_DECL node just created and link that with the + corresponding GNAT defining identifier. */ + save_gnu_tree (gnat_field, + build3 (COMPONENT_REF, TREE_TYPE (gnu_field), + build0 (PLACEHOLDER_EXPR, gnu_type), + gnu_field, NULL_TREE), + true); + + if (!is_unchecked_union) + { + DECL_CHAIN (gnu_field) = gnu_field_list; + gnu_field_list = gnu_field; + } + } + + /* Add the fields into the record type and finish it up. */ + components_to_record (gnu_type, Component_List (record_definition), + gnu_field_list, packed, definition, NULL, + false, all_rep, is_unchecked_union, + debug_info_p, false); + + /* If it is passed by reference, force BLKmode to ensure that objects + of this type will always be put in memory. */ + if (Is_By_Reference_Type (gnat_entity)) + SET_TYPE_MODE (gnu_type, BLKmode); + + /* We used to remove the associations of the discriminants and _Parent + for validity checking but we may need them if there's a Freeze_Node + for a subtype used in this record. */ + TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity); + + /* Fill in locations of fields. */ + annotate_rep (gnat_entity, gnu_type); + + /* If there are any entities in the chain corresponding to components + that we did not elaborate, ensure we elaborate their types if they + are Itypes. */ + for (gnat_temp = First_Entity (gnat_entity); + Present (gnat_temp); + gnat_temp = Next_Entity (gnat_temp)) + if ((Ekind (gnat_temp) == E_Component + || Ekind (gnat_temp) == E_Discriminant) + && Is_Itype (Etype (gnat_temp)) + && !present_gnu_tree (gnat_temp)) + gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0); + + /* If this is a record type associated with an exception definition, + equate its fields to those of the standard exception type. This + will make it possible to convert between them. */ + if (gnu_entity_name == exception_data_name_id) + { + tree gnu_std_field; + for (gnu_field = TYPE_FIELDS (gnu_type), + gnu_std_field = TYPE_FIELDS (except_type_node); + gnu_field; + gnu_field = DECL_CHAIN (gnu_field), + gnu_std_field = DECL_CHAIN (gnu_std_field)) + SET_DECL_ORIGINAL_FIELD_TO_FIELD (gnu_field, gnu_std_field); + gcc_assert (!gnu_std_field); + } + } + break; + + case E_Class_Wide_Subtype: + /* If an equivalent type is present, that is what we should use. + Otherwise, fall through to handle this like a record subtype + since it may have constraints. */ + if (gnat_equiv_type != gnat_entity) + { + gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0); + maybe_present = true; + break; + } + + /* ... fall through ... */ + + case E_Record_Subtype: + /* If Cloned_Subtype is Present it means this record subtype has + identical layout to that type or subtype and we should use + that GCC type for this one. The front end guarantees that + the component list is shared. */ + if (Present (Cloned_Subtype (gnat_entity))) + { + gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity), + NULL_TREE, 0); + maybe_present = true; + break; + } + + /* Otherwise, first ensure the base type is elaborated. Then, if we are + changing the type, make a new type with each field having the type of + the field in the new subtype but the position computed by transforming + every discriminant reference according to the constraints. We don't + see any difference between private and non-private type here since + derivations from types should have been deferred until the completion + of the private type. */ + else + { + Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity); + tree gnu_base_type; + + if (!definition) + { + defer_incomplete_level++; + this_deferred = true; + } + + gnu_base_type = gnat_to_gnu_type (gnat_base_type); + + if (present_gnu_tree (gnat_entity)) + { + maybe_present = true; + break; + } + + /* If this is a record subtype associated with a dispatch table, + strip the suffix. This is necessary to make sure 2 different + subtypes associated with the imported and exported views of a + dispatch table are properly merged in LTO mode. */ + if (Is_Dispatch_Table_Entity (gnat_entity)) + { + char *p; + Get_Encoded_Name (gnat_entity); + p = strchr (Name_Buffer, '_'); + gcc_assert (p); + strcpy (p+2, "dtS"); + gnu_entity_name = get_identifier (Name_Buffer); + } + + /* When the subtype has discriminants and these discriminants affect + the initial shape it has inherited, factor them in. But for an + Unchecked_Union (it must be an Itype), just return the type. + We can't just test Is_Constrained because private subtypes without + discriminants of types with discriminants with default expressions + are Is_Constrained but aren't constrained! */ + if (IN (Ekind (gnat_base_type), Record_Kind) + && !Is_Unchecked_Union (gnat_base_type) + && !Is_For_Access_Subtype (gnat_entity) + && Is_Constrained (gnat_entity) + && Has_Discriminants (gnat_entity) + && Present (Discriminant_Constraint (gnat_entity)) + && Stored_Constraint (gnat_entity) != No_Elist) + { + VEC(subst_pair,heap) *gnu_subst_list + = build_subst_list (gnat_entity, gnat_base_type, definition); + tree gnu_unpad_base_type, gnu_rep_part, gnu_variant_part, t; + tree gnu_pos_list, gnu_field_list = NULL_TREE; + bool selected_variant = false; + Entity_Id gnat_field; + VEC(variant_desc,heap) *gnu_variant_list; + + gnu_type = make_node (RECORD_TYPE); + TYPE_NAME (gnu_type) = gnu_entity_name; + + /* Set the size, alignment and alias set of the new type to + match that of the old one, doing required substitutions. */ + copy_and_substitute_in_size (gnu_type, gnu_base_type, + gnu_subst_list); + + if (TYPE_IS_PADDING_P (gnu_base_type)) + gnu_unpad_base_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type)); + else + gnu_unpad_base_type = gnu_base_type; + + /* Look for a REP part in the base type. */ + gnu_rep_part = get_rep_part (gnu_unpad_base_type); + + /* Look for a variant part in the base type. */ + gnu_variant_part = get_variant_part (gnu_unpad_base_type); + + /* If there is a variant part, we must compute whether the + constraints statically select a particular variant. If + so, we simply drop the qualified union and flatten the + list of fields. Otherwise we'll build a new qualified + union for the variants that are still relevant. */ + if (gnu_variant_part) + { + variant_desc *v; + unsigned ix; + + gnu_variant_list + = build_variant_list (TREE_TYPE (gnu_variant_part), + gnu_subst_list, NULL); + + /* If all the qualifiers are unconditionally true, the + innermost variant is statically selected. */ + selected_variant = true; + FOR_EACH_VEC_ELT_REVERSE (variant_desc, gnu_variant_list, + ix, v) + if (!integer_onep (v->qual)) + { + selected_variant = false; + break; + } + + /* Otherwise, create the new variants. */ + if (!selected_variant) + FOR_EACH_VEC_ELT_REVERSE (variant_desc, gnu_variant_list, + ix, v) + { + tree old_variant = v->type; + tree new_variant = make_node (RECORD_TYPE); + tree suffix + = concat_name (DECL_NAME (gnu_variant_part), + IDENTIFIER_POINTER + (DECL_NAME (v->field))); + TYPE_NAME (new_variant) + = concat_name (TYPE_NAME (gnu_type), + IDENTIFIER_POINTER (suffix)); + copy_and_substitute_in_size (new_variant, old_variant, + gnu_subst_list); + v->new_type = new_variant; + } + } + else + { + gnu_variant_list = NULL; + selected_variant = false; + } + + gnu_pos_list + = build_position_list (gnu_unpad_base_type, + gnu_variant_list && !selected_variant, + size_zero_node, bitsize_zero_node, + BIGGEST_ALIGNMENT, NULL_TREE); + + for (gnat_field = First_Entity (gnat_entity); + Present (gnat_field); + gnat_field = Next_Entity (gnat_field)) + if ((Ekind (gnat_field) == E_Component + || Ekind (gnat_field) == E_Discriminant) + && !(Present (Corresponding_Discriminant (gnat_field)) + && Is_Tagged_Type (gnat_base_type)) + && Underlying_Type (Scope (Original_Record_Component + (gnat_field))) + == gnat_base_type) + { + Name_Id gnat_name = Chars (gnat_field); + Entity_Id gnat_old_field + = Original_Record_Component (gnat_field); + tree gnu_old_field + = gnat_to_gnu_field_decl (gnat_old_field); + tree gnu_context = DECL_CONTEXT (gnu_old_field); + tree gnu_field, gnu_field_type, gnu_size; + tree gnu_cont_type, gnu_last = NULL_TREE; + + /* If the type is the same, retrieve the GCC type from the + old field to take into account possible adjustments. */ + if (Etype (gnat_field) == Etype (gnat_old_field)) + gnu_field_type = TREE_TYPE (gnu_old_field); + else + gnu_field_type = gnat_to_gnu_type (Etype (gnat_field)); + + /* If there was a component clause, the field types must be + the same for the type and subtype, so copy the data from + the old field to avoid recomputation here. Also if the + field is justified modular and the optimization in + gnat_to_gnu_field was applied. */ + if (Present (Component_Clause (gnat_old_field)) + || (TREE_CODE (gnu_field_type) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type) + && TREE_TYPE (TYPE_FIELDS (gnu_field_type)) + == TREE_TYPE (gnu_old_field))) + { + gnu_size = DECL_SIZE (gnu_old_field); + gnu_field_type = TREE_TYPE (gnu_old_field); + } + + /* If the old field was packed and of constant size, we + have to get the old size here, as it might differ from + what the Etype conveys and the latter might overlap + onto the following field. Try to arrange the type for + possible better packing along the way. */ + else if (DECL_PACKED (gnu_old_field) + && TREE_CODE (DECL_SIZE (gnu_old_field)) + == INTEGER_CST) + { + gnu_size = DECL_SIZE (gnu_old_field); + if (TREE_CODE (gnu_field_type) == RECORD_TYPE + && !TYPE_FAT_POINTER_P (gnu_field_type) + && host_integerp (TYPE_SIZE (gnu_field_type), 1)) + gnu_field_type + = make_packable_type (gnu_field_type, true); + } + + else + gnu_size = TYPE_SIZE (gnu_field_type); + + /* If the context of the old field is the base type or its + REP part (if any), put the field directly in the new + type; otherwise look up the context in the variant list + and put the field either in the new type if there is a + selected variant or in one of the new variants. */ + if (gnu_context == gnu_unpad_base_type + || (gnu_rep_part + && gnu_context == TREE_TYPE (gnu_rep_part))) + gnu_cont_type = gnu_type; + else + { + variant_desc *v; + unsigned ix; + + t = NULL_TREE; + FOR_EACH_VEC_ELT_REVERSE (variant_desc, + gnu_variant_list, ix, v) + if (v->type == gnu_context) + { + t = v->type; + break; + } + if (t) + { + if (selected_variant) + gnu_cont_type = gnu_type; + else + gnu_cont_type = v->new_type; + } + else + /* The front-end may pass us "ghost" components if + it fails to recognize that a constrained subtype + is statically constrained. Discard them. */ + continue; + } + + /* Now create the new field modeled on the old one. */ + gnu_field + = create_field_decl_from (gnu_old_field, gnu_field_type, + gnu_cont_type, gnu_size, + gnu_pos_list, gnu_subst_list); + + /* Put it in one of the new variants directly. */ + if (gnu_cont_type != gnu_type) + { + DECL_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type); + TYPE_FIELDS (gnu_cont_type) = gnu_field; + } + + /* To match the layout crafted in components_to_record, + if this is the _Tag or _Parent field, put it before + any other fields. */ + else if (gnat_name == Name_uTag + || gnat_name == Name_uParent) + gnu_field_list = chainon (gnu_field_list, gnu_field); + + /* Similarly, if this is the _Controller field, put + it before the other fields except for the _Tag or + _Parent field. */ + else if (gnat_name == Name_uController && gnu_last) + { + TREE_CHAIN (gnu_field) = TREE_CHAIN (gnu_last); + TREE_CHAIN (gnu_last) = gnu_field; + } + + /* Otherwise, if this is a regular field, put it after + the other fields. */ + else + { + DECL_CHAIN (gnu_field) = gnu_field_list; + gnu_field_list = gnu_field; + if (!gnu_last) + gnu_last = gnu_field; + } + + save_gnu_tree (gnat_field, gnu_field, false); + } + + /* If there is a variant list and no selected variant, we need + to create the nest of variant parts from the old nest. */ + if (gnu_variant_list && !selected_variant) + { + tree new_variant_part + = create_variant_part_from (gnu_variant_part, + gnu_variant_list, gnu_type, + gnu_pos_list, gnu_subst_list); + DECL_CHAIN (new_variant_part) = gnu_field_list; + gnu_field_list = new_variant_part; + } + + /* Now go through the entities again looking for Itypes that + we have not elaborated but should (e.g., Etypes of fields + that have Original_Components). */ + for (gnat_field = First_Entity (gnat_entity); + Present (gnat_field); gnat_field = Next_Entity (gnat_field)) + if ((Ekind (gnat_field) == E_Discriminant + || Ekind (gnat_field) == E_Component) + && !present_gnu_tree (Etype (gnat_field))) + gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, 0); + + /* Do not emit debug info for the type yet since we're going to + modify it below. */ + gnu_field_list = nreverse (gnu_field_list); + finish_record_type (gnu_type, gnu_field_list, 2, false); + + /* See the E_Record_Type case for the rationale. */ + if (Is_By_Reference_Type (gnat_entity)) + SET_TYPE_MODE (gnu_type, BLKmode); + else + compute_record_mode (gnu_type); + + TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity); + + /* Fill in locations of fields. */ + annotate_rep (gnat_entity, gnu_type); + + /* If debugging information is being written for the type, write + a record that shows what we are a subtype of and also make a + variable that indicates our size, if still variable. */ + if (debug_info_p) + { + tree gnu_subtype_marker = make_node (RECORD_TYPE); + tree gnu_unpad_base_name = TYPE_NAME (gnu_unpad_base_type); + tree gnu_size_unit = TYPE_SIZE_UNIT (gnu_type); + + if (TREE_CODE (gnu_unpad_base_name) == TYPE_DECL) + gnu_unpad_base_name = DECL_NAME (gnu_unpad_base_name); + + TYPE_NAME (gnu_subtype_marker) + = create_concat_name (gnat_entity, "XVS"); + finish_record_type (gnu_subtype_marker, + create_field_decl (gnu_unpad_base_name, + build_reference_type + (gnu_unpad_base_type), + gnu_subtype_marker, + NULL_TREE, NULL_TREE, + 0, 0), + 0, true); + + add_parallel_type (TYPE_STUB_DECL (gnu_type), + gnu_subtype_marker); + + if (definition + && TREE_CODE (gnu_size_unit) != INTEGER_CST + && !CONTAINS_PLACEHOLDER_P (gnu_size_unit)) + TYPE_SIZE_UNIT (gnu_subtype_marker) + = create_var_decl (create_concat_name (gnat_entity, + "XVZ"), + NULL_TREE, sizetype, gnu_size_unit, + false, false, false, false, NULL, + gnat_entity); + } + + VEC_free (variant_desc, heap, gnu_variant_list); + VEC_free (subst_pair, heap, gnu_subst_list); + + /* Now we can finalize it. */ + rest_of_record_type_compilation (gnu_type); + } + + /* Otherwise, go down all the components in the new type and make + them equivalent to those in the base type. */ + else + { + gnu_type = gnu_base_type; + + for (gnat_temp = First_Entity (gnat_entity); + Present (gnat_temp); + gnat_temp = Next_Entity (gnat_temp)) + if ((Ekind (gnat_temp) == E_Discriminant + && !Is_Unchecked_Union (gnat_base_type)) + || Ekind (gnat_temp) == E_Component) + save_gnu_tree (gnat_temp, + gnat_to_gnu_field_decl + (Original_Record_Component (gnat_temp)), + false); + } + } + break; + + case E_Access_Subprogram_Type: + /* Use the special descriptor type for dispatch tables if needed, + that is to say for the Prim_Ptr of a-tags.ads and its clones. + Note that we are only required to do so for static tables in + order to be compatible with the C++ ABI, but Ada 2005 allows + to extend library level tagged types at the local level so + we do it in the non-static case as well. */ + if (TARGET_VTABLE_USES_DESCRIPTORS + && Is_Dispatch_Table_Entity (gnat_entity)) + { + gnu_type = fdesc_type_node; + gnu_size = TYPE_SIZE (gnu_type); + break; + } + + /* ... fall through ... */ + + case E_Anonymous_Access_Subprogram_Type: + /* If we are not defining this entity, and we have incomplete + entities being processed above us, make a dummy type and + fill it in later. */ + if (!definition && defer_incomplete_level != 0) + { + struct incomplete *p + = (struct incomplete *) xmalloc (sizeof (struct incomplete)); + + gnu_type + = build_pointer_type + (make_dummy_type (Directly_Designated_Type (gnat_entity))); + gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list, + !Comes_From_Source (gnat_entity), + debug_info_p, gnat_entity); + this_made_decl = true; + gnu_type = TREE_TYPE (gnu_decl); + save_gnu_tree (gnat_entity, gnu_decl, false); + saved = true; + + p->old_type = TREE_TYPE (gnu_type); + p->full_type = Directly_Designated_Type (gnat_entity); + p->next = defer_incomplete_list; + defer_incomplete_list = p; + break; + } + + /* ... fall through ... */ + + case E_Allocator_Type: + case E_Access_Type: + case E_Access_Attribute_Type: + case E_Anonymous_Access_Type: + case E_General_Access_Type: + { + /* The designated type and its equivalent type for gigi. */ + Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity); + Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type); + /* Whether it comes from a limited with. */ + bool is_from_limited_with + = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind) + && From_With_Type (gnat_desig_equiv)); + /* The "full view" of the designated type. If this is an incomplete + entity from a limited with, treat its non-limited view as the full + view. Otherwise, if this is an incomplete or private type, use the + full view. In the former case, we might point to a private type, + in which case, we need its full view. Also, we want to look at the + actual type used for the representation, so this takes a total of + three steps. */ + Entity_Id gnat_desig_full_direct_first + = (is_from_limited_with + ? Non_Limited_View (gnat_desig_equiv) + : (IN (Ekind (gnat_desig_equiv), Incomplete_Or_Private_Kind) + ? Full_View (gnat_desig_equiv) : Empty)); + Entity_Id gnat_desig_full_direct + = ((is_from_limited_with + && Present (gnat_desig_full_direct_first) + && IN (Ekind (gnat_desig_full_direct_first), Private_Kind)) + ? Full_View (gnat_desig_full_direct_first) + : gnat_desig_full_direct_first); + Entity_Id gnat_desig_full + = Gigi_Equivalent_Type (gnat_desig_full_direct); + /* The type actually used to represent the designated type, either + gnat_desig_full or gnat_desig_equiv. */ + Entity_Id gnat_desig_rep; + /* True if this is a pointer to an unconstrained array. */ + bool is_unconstrained_array; + /* We want to know if we'll be seeing the freeze node for any + incomplete type we may be pointing to. */ + bool in_main_unit + = (Present (gnat_desig_full) + ? In_Extended_Main_Code_Unit (gnat_desig_full) + : In_Extended_Main_Code_Unit (gnat_desig_type)); + /* True if we make a dummy type here. */ + bool made_dummy = false; + /* True if the dummy type is a fat pointer. */ + bool got_fat_p = false; + /* The mode to be used for the pointer type. */ + enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0); + /* The GCC type used for the designated type. */ + tree gnu_desig_type = NULL_TREE; + + if (!targetm.valid_pointer_mode (p_mode)) + p_mode = ptr_mode; + + /* If either the designated type or its full view is an unconstrained + array subtype, replace it with the type it's a subtype of. This + avoids problems with multiple copies of unconstrained array types. + Likewise, if the designated type is a subtype of an incomplete + record type, use the parent type to avoid order of elaboration + issues. This can lose some code efficiency, but there is no + alternative. */ + if (Ekind (gnat_desig_equiv) == E_Array_Subtype + && !Is_Constrained (gnat_desig_equiv)) + gnat_desig_equiv = Etype (gnat_desig_equiv); + if (Present (gnat_desig_full) + && ((Ekind (gnat_desig_full) == E_Array_Subtype + && !Is_Constrained (gnat_desig_full)) + || (Ekind (gnat_desig_full) == E_Record_Subtype + && Ekind (Etype (gnat_desig_full)) == E_Record_Type))) + gnat_desig_full = Etype (gnat_desig_full); + + /* Set the type that's actually the representation of the designated + type and also flag whether we have a unconstrained array. */ + gnat_desig_rep + = Present (gnat_desig_full) ? gnat_desig_full : gnat_desig_equiv; + is_unconstrained_array + = Is_Array_Type (gnat_desig_rep) && !Is_Constrained (gnat_desig_rep); + + /* If we are pointing to an incomplete type whose completion is an + unconstrained array, make a fat pointer type. The two types in our + fields will be pointers to dummy nodes and will be replaced in + update_pointer_to. Similarly, if the type itself is a dummy type or + an unconstrained array. Also make a dummy TYPE_OBJECT_RECORD_TYPE + in case we have any thin pointers to it. */ + if (is_unconstrained_array + && (Present (gnat_desig_full) + || (present_gnu_tree (gnat_desig_equiv) + && TYPE_IS_DUMMY_P + (TREE_TYPE (get_gnu_tree (gnat_desig_equiv)))) + || (!in_main_unit + && defer_incomplete_level != 0 + && !present_gnu_tree (gnat_desig_equiv)) + || (in_main_unit + && is_from_limited_with + && Present (Freeze_Node (gnat_desig_equiv))))) + { + if (present_gnu_tree (gnat_desig_rep)) + gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_rep)); + else + { + gnu_desig_type = make_dummy_type (gnat_desig_rep); + /* Show the dummy we get will be a fat pointer. */ + got_fat_p = made_dummy = true; + } + + /* If the call above got something that has a pointer, the pointer + is our type. This could have happened either because the type + was elaborated or because somebody else executed the code. */ + gnu_type = TYPE_POINTER_TO (gnu_desig_type); + if (!gnu_type) + { + tree gnu_template_type = make_node (RECORD_TYPE); + tree gnu_ptr_template = build_pointer_type (gnu_template_type); + tree gnu_array_type = make_node (ENUMERAL_TYPE); + tree gnu_ptr_array = build_pointer_type (gnu_array_type); + tree fields; + + TYPE_NAME (gnu_template_type) + = create_concat_name (gnat_desig_equiv, "XUB"); + TYPE_DUMMY_P (gnu_template_type) = 1; + + TYPE_NAME (gnu_array_type) + = create_concat_name (gnat_desig_equiv, "XUA"); + TYPE_DUMMY_P (gnu_array_type) = 1; + + gnu_type = make_node (RECORD_TYPE); + /* Build a stub DECL to trigger the special processing for fat + pointer types in gnat_pushdecl. */ + TYPE_NAME (gnu_type) + = create_type_stub_decl + (create_concat_name (gnat_desig_equiv, "XUP"), gnu_type); + SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type, gnu_desig_type); + TYPE_POINTER_TO (gnu_desig_type) = gnu_type; + + fields + = create_field_decl (get_identifier ("P_ARRAY"), + gnu_ptr_array, gnu_type, + NULL_TREE, NULL_TREE, 0, 0); + DECL_CHAIN (fields) + = create_field_decl (get_identifier ("P_BOUNDS"), + gnu_ptr_template, gnu_type, + NULL_TREE, NULL_TREE, 0, 0); + finish_fat_pointer_type (gnu_type, fields); + + TYPE_OBJECT_RECORD_TYPE (gnu_desig_type) + = make_node (RECORD_TYPE); + TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_desig_type)) + = create_concat_name (gnat_desig_equiv, "XUT"); + TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_desig_type)) = 1; + } + } + + /* If we already know what the full type is, use it. */ + else if (Present (gnat_desig_full) + && present_gnu_tree (gnat_desig_full)) + gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full)); + + /* Get the type of the thing we are to point to and build a pointer to + it. If it is a reference to an incomplete or private type with a + full view that is a record, make a dummy type node and get the + actual type later when we have verified it is safe. */ + else if ((!in_main_unit + && !present_gnu_tree (gnat_desig_equiv) + && Present (gnat_desig_full) + && !present_gnu_tree (gnat_desig_full) + && Is_Record_Type (gnat_desig_full)) + /* Likewise if we are pointing to a record or array and we are + to defer elaborating incomplete types. We do this as this + access type may be the full view of a private type. Note + that the unconstrained array case is handled above. */ + || ((!in_main_unit || imported_p) + && defer_incomplete_level != 0 + && !present_gnu_tree (gnat_desig_equiv) + && (Is_Record_Type (gnat_desig_rep) + || Is_Array_Type (gnat_desig_rep))) + /* If this is a reference from a limited_with type back to our + main unit and there's a freeze node for it, either we have + already processed the declaration and made the dummy type, + in which case we just reuse the latter, or we have not yet, + in which case we make the dummy type and it will be reused + when the declaration is finally processed. In both cases, + the pointer eventually created below will be automatically + adjusted when the freeze node is processed. Note that the + unconstrained array case is handled above. */ + || (in_main_unit + && is_from_limited_with + && Present (Freeze_Node (gnat_desig_rep)))) + { + gnu_desig_type = make_dummy_type (gnat_desig_equiv); + made_dummy = true; + } + + /* Otherwise handle the case of a pointer to itself. */ + else if (gnat_desig_equiv == gnat_entity) + { + gnu_type + = build_pointer_type_for_mode (void_type_node, p_mode, + No_Strict_Aliasing (gnat_entity)); + TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type; + } + + /* If expansion is disabled, the equivalent type of a concurrent type + is absent, so build a dummy pointer type. */ + else if (type_annotate_only && No (gnat_desig_equiv)) + gnu_type = ptr_void_type_node; + + /* Finally, handle the default case where we can just elaborate our + designated type. */ + else + gnu_desig_type = gnat_to_gnu_type (gnat_desig_equiv); + + /* It is possible that a call to gnat_to_gnu_type above resolved our + type. If so, just return it. */ + if (present_gnu_tree (gnat_entity)) + { + maybe_present = true; + break; + } + + /* If we have not done it yet, build the pointer type the usual way. */ + if (!gnu_type) + { + /* Modify the designated type if we are pointing only to constant + objects, but don't do it for unconstrained arrays. */ + if (Is_Access_Constant (gnat_entity) + && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE) + { + gnu_desig_type + = build_qualified_type + (gnu_desig_type, + TYPE_QUALS (gnu_desig_type) | TYPE_QUAL_CONST); + + /* Some extra processing is required if we are building a + pointer to an incomplete type (in the GCC sense). We might + have such a type if we just made a dummy, or directly out + of the call to gnat_to_gnu_type above if we are processing + an access type for a record component designating the + record type itself. */ + if (TYPE_MODE (gnu_desig_type) == VOIDmode) + { + /* We must ensure that the pointer to variant we make will + be processed by update_pointer_to when the initial type + is completed. Pretend we made a dummy and let further + processing act as usual. */ + made_dummy = true; + + /* We must ensure that update_pointer_to will not retrieve + the dummy variant when building a properly qualified + version of the complete type. We take advantage of the + fact that get_qualified_type is requiring TYPE_NAMEs to + match to influence build_qualified_type and then also + update_pointer_to here. */ + TYPE_NAME (gnu_desig_type) + = create_concat_name (gnat_desig_type, "INCOMPLETE_CST"); + } + } + + gnu_type + = build_pointer_type_for_mode (gnu_desig_type, p_mode, + No_Strict_Aliasing (gnat_entity)); + } + + /* If we are not defining this object and we have made a dummy pointer, + save our current definition, evaluate the actual type, and replace + the tentative type we made with the actual one. If we are to defer + actually looking up the actual type, make an entry in the deferred + list. If this is from a limited with, we have to defer to the end + of the current spec in two cases: first if the designated type is + in the current unit and second if the access type itself is. */ + if ((!in_main_unit || is_from_limited_with) && made_dummy) + { + bool is_from_limited_with_in_main_unit + = (is_from_limited_with + && (in_main_unit + || In_Extended_Main_Code_Unit (gnat_entity))); + tree gnu_old_desig_type + = TYPE_IS_FAT_POINTER_P (gnu_type) + ? TYPE_UNCONSTRAINED_ARRAY (gnu_type) : TREE_TYPE (gnu_type); + + if (esize == POINTER_SIZE + && (got_fat_p || TYPE_IS_FAT_POINTER_P (gnu_type))) + gnu_type + = build_pointer_type + (TYPE_OBJECT_RECORD_TYPE + (TYPE_UNCONSTRAINED_ARRAY (gnu_type))); + + gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list, + !Comes_From_Source (gnat_entity), + debug_info_p, gnat_entity); + this_made_decl = true; + gnu_type = TREE_TYPE (gnu_decl); + save_gnu_tree (gnat_entity, gnu_decl, false); + saved = true; + + /* Note that the call to gnat_to_gnu_type on gnat_desig_equiv might + update gnu_old_desig_type directly, in which case it will not be + a dummy type any more when we get into update_pointer_to. + + This can happen e.g. when the designated type is a record type, + because their elaboration starts with an initial node from + make_dummy_type, which may be the same node as the one we got. + + Besides, variants of this non-dummy type might have been created + along the way. update_pointer_to is expected to properly take + care of those situations. */ + if (defer_incomplete_level == 0 + && !is_from_limited_with_in_main_unit) + update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_desig_type), + gnat_to_gnu_type (gnat_desig_equiv)); + else + { + struct incomplete *p = XNEW (struct incomplete); + struct incomplete **head + = (is_from_limited_with_in_main_unit + ? &defer_limited_with : &defer_incomplete_list); + p->old_type = gnu_old_desig_type; + p->full_type = gnat_desig_equiv; + p->next = *head; + *head = p; + } + } + } + break; + + case E_Access_Protected_Subprogram_Type: + case E_Anonymous_Access_Protected_Subprogram_Type: + if (type_annotate_only && No (gnat_equiv_type)) + gnu_type = ptr_void_type_node; + else + { + /* The run-time representation is the equivalent type. */ + gnu_type = gnat_to_gnu_type (gnat_equiv_type); + maybe_present = true; + } + + if (Is_Itype (Directly_Designated_Type (gnat_entity)) + && !present_gnu_tree (Directly_Designated_Type (gnat_entity)) + && No (Freeze_Node (Directly_Designated_Type (gnat_entity))) + && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity)))) + gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity), + NULL_TREE, 0); + + break; + + case E_Access_Subtype: + + /* We treat this as identical to its base type; any constraint is + meaningful only to the front end. + + The designated type must be elaborated as well, if it does + not have its own freeze node. Designated (sub)types created + for constrained components of records with discriminants are + not frozen by the front end and thus not elaborated by gigi, + because their use may appear before the base type is frozen, + and because it is not clear that they are needed anywhere in + Gigi. With the current model, there is no correct place where + they could be elaborated. */ + + gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); + if (Is_Itype (Directly_Designated_Type (gnat_entity)) + && !present_gnu_tree (Directly_Designated_Type (gnat_entity)) + && Is_Frozen (Directly_Designated_Type (gnat_entity)) + && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))) + { + /* If we are not defining this entity, and we have incomplete + entities being processed above us, make a dummy type and + elaborate it later. */ + if (!definition && defer_incomplete_level != 0) + { + struct incomplete *p + = (struct incomplete *) xmalloc (sizeof (struct incomplete)); + tree gnu_ptr_type + = build_pointer_type + (make_dummy_type (Directly_Designated_Type (gnat_entity))); + + p->old_type = TREE_TYPE (gnu_ptr_type); + p->full_type = Directly_Designated_Type (gnat_entity); + p->next = defer_incomplete_list; + defer_incomplete_list = p; + } + else if (!IN (Ekind (Base_Type + (Directly_Designated_Type (gnat_entity))), + Incomplete_Or_Private_Kind)) + gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity), + NULL_TREE, 0); + } + + maybe_present = true; + break; + + /* Subprogram Entities + + The following access functions are defined for subprograms: + + Etype Return type or Standard_Void_Type. + First_Formal The first formal parameter. + Is_Imported Indicates that the subprogram has appeared in + an INTERFACE or IMPORT pragma. For now we + assume that the external language is C. + Is_Exported Likewise but for an EXPORT pragma. + Is_Inlined True if the subprogram is to be inlined. + + Each parameter is first checked by calling must_pass_by_ref on its + type to determine if it is passed by reference. For parameters which + are copied in, if they are Ada In Out or Out parameters, their return + value becomes part of a record which becomes the return type of the + function (C function - note that this applies only to Ada procedures + so there is no Ada return type). Additional code to store back the + parameters will be generated on the caller side. This transformation + is done here, not in the front-end. + + The intended result of the transformation can be seen from the + equivalent source rewritings that follow: + + struct temp {int a,b}; + procedure P (A,B: In Out ...) is temp P (int A,B) + begin { + .. .. + end P; return {A,B}; + } + + temp t; + P(X,Y); t = P(X,Y); + X = t.a , Y = t.b; + + For subprogram types we need to perform mainly the same conversions to + GCC form that are needed for procedures and function declarations. The + only difference is that at the end, we make a type declaration instead + of a function declaration. */ + + case E_Subprogram_Type: + case E_Function: + case E_Procedure: + { + /* The type returned by a function or else Standard_Void_Type for a + procedure. */ + Entity_Id gnat_return_type = Etype (gnat_entity); + tree gnu_return_type; + /* The first GCC parameter declaration (a PARM_DECL node). The + PARM_DECL nodes are chained through the TREE_CHAIN field, so this + actually is the head of this parameter list. */ + tree gnu_param_list = NULL_TREE; + /* Likewise for the stub associated with an exported procedure. */ + tree gnu_stub_param_list = NULL_TREE; + /* Non-null for subprograms containing parameters passed by copy-in + copy-out (Ada In Out or Out parameters not passed by reference), + in which case it is the list of nodes used to specify the values + of the In Out/Out parameters that are returned as a record upon + procedure return. The TREE_PURPOSE of an element of this list is + a field of the record and the TREE_VALUE is the PARM_DECL + corresponding to that field. This list will be saved in the + TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */ + tree gnu_cico_list = NULL_TREE; + /* List of fields in return type of procedure with copy-in copy-out + parameters. */ + tree gnu_field_list = NULL_TREE; + /* If an import pragma asks to map this subprogram to a GCC builtin, + this is the builtin DECL node. */ + tree gnu_builtin_decl = NULL_TREE; + /* For the stub associated with an exported procedure. */ + tree gnu_stub_type = NULL_TREE, gnu_stub_name = NULL_TREE; + tree gnu_ext_name = create_concat_name (gnat_entity, NULL); + Entity_Id gnat_param; + bool inline_flag = Is_Inlined (gnat_entity); + bool public_flag = Is_Public (gnat_entity) || imported_p; + bool extern_flag + = (Is_Public (gnat_entity) && !definition) || imported_p; + /* The semantics of "pure" in Ada essentially matches that of "const" + in the back-end. In particular, both properties are orthogonal to + the "nothrow" property if the EH circuitry is explicit in the + internal representation of the back-end. If we are to completely + hide the EH circuitry from it, we need to declare that calls to pure + Ada subprograms that can throw have side effects since they can + trigger an "abnormal" transfer of control flow; thus they can be + neither "const" nor "pure" in the back-end sense. */ + bool const_flag + = (Exception_Mechanism == Back_End_Exceptions + && Is_Pure (gnat_entity)); + bool volatile_flag = No_Return (gnat_entity); + bool return_by_direct_ref_p = false; + bool return_by_invisi_ref_p = false; + bool return_unconstrained_p = false; + bool has_stub = false; + int parmnum; + + /* A parameter may refer to this type, so defer completion of any + incomplete types. */ + if (kind == E_Subprogram_Type && !definition) + { + defer_incomplete_level++; + this_deferred = true; + } + + /* If the subprogram has an alias, it is probably inherited, so + we can use the original one. If the original "subprogram" + is actually an enumeration literal, it may be the first use + of its type, so we must elaborate that type now. */ + if (Present (Alias (gnat_entity))) + { + if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal) + gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0); + + gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity), gnu_expr, 0); + + /* Elaborate any Itypes in the parameters of this entity. */ + for (gnat_temp = First_Formal_With_Extras (gnat_entity); + Present (gnat_temp); + gnat_temp = Next_Formal_With_Extras (gnat_temp)) + if (Is_Itype (Etype (gnat_temp))) + gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0); + + break; + } + + /* If this subprogram is expectedly bound to a GCC builtin, fetch the + corresponding DECL node. Proper generation of calls later on need + proper parameter associations so we don't "break;" here. */ + if (Convention (gnat_entity) == Convention_Intrinsic + && Present (Interface_Name (gnat_entity))) + { + gnu_builtin_decl = builtin_decl_for (gnu_ext_name); + + /* Inability to find the builtin decl most often indicates a + genuine mistake, but imports of unregistered intrinsics are + sometimes issued on purpose to allow hooking in alternate + bodies. We post a warning conditioned on Wshadow in this case, + to let developers be notified on demand without risking false + positives with common default sets of options. */ + + if (gnu_builtin_decl == NULL_TREE && warn_shadow) + post_error ("?gcc intrinsic not found for&!", gnat_entity); + } + + /* ??? What if we don't find the builtin node above ? warn ? err ? + In the current state we neither warn nor err, and calls will just + be handled as for regular subprograms. */ + + /* Look into the return type and get its associated GCC tree. If it + is not void, compute various flags for the subprogram type. */ + if (Ekind (gnat_return_type) == E_Void) + gnu_return_type = void_type_node; + else + { + gnu_return_type = gnat_to_gnu_type (gnat_return_type); + + /* If this function returns by reference, make the actual return + type the pointer type and make a note of that. */ + if (Returns_By_Ref (gnat_entity)) + { + gnu_return_type = build_pointer_type (gnu_return_type); + return_by_direct_ref_p = true; + } + + /* If we are supposed to return an unconstrained array type, make + the actual return type the fat pointer type. */ + else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE) + { + gnu_return_type = TREE_TYPE (gnu_return_type); + return_unconstrained_p = true; + } + + /* Likewise, if the return type requires a transient scope, the + return value will be allocated on the secondary stack so the + actual return type is the pointer type. */ + else if (Requires_Transient_Scope (gnat_return_type)) + { + gnu_return_type = build_pointer_type (gnu_return_type); + return_unconstrained_p = true; + } + + /* If the Mechanism is By_Reference, ensure this function uses the + target's by-invisible-reference mechanism, which may not be the + same as above (e.g. it might be passing an extra parameter). */ + else if (kind == E_Function + && Mechanism (gnat_entity) == By_Reference) + return_by_invisi_ref_p = true; + + /* Likewise, if the return type is itself By_Reference. */ + else if (TREE_ADDRESSABLE (gnu_return_type)) + return_by_invisi_ref_p = true; + + /* If the type is a padded type and the underlying type would not + be passed by reference or the function has a foreign convention, + return the underlying type. */ + else if (TYPE_IS_PADDING_P (gnu_return_type) + && (!default_pass_by_ref + (TREE_TYPE (TYPE_FIELDS (gnu_return_type))) + || Has_Foreign_Convention (gnat_entity))) + gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type)); + + /* If the return type is unconstrained, that means it must have a + maximum size. Use the padded type as the effective return type. + And ensure the function uses the target's by-invisible-reference + mechanism to avoid copying too much data when it returns. */ + if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type))) + { + gnu_return_type + = maybe_pad_type (gnu_return_type, + max_size (TYPE_SIZE (gnu_return_type), + true), + 0, gnat_entity, false, false, false, true); + return_by_invisi_ref_p = true; + } + + /* If the return type has a size that overflows, we cannot have + a function that returns that type. This usage doesn't make + sense anyway, so give an error here. */ + if (TYPE_SIZE_UNIT (gnu_return_type) + && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type)) + && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type))) + { + post_error ("cannot return type whose size overflows", + gnat_entity); + gnu_return_type = copy_node (gnu_return_type); + TYPE_SIZE (gnu_return_type) = bitsize_zero_node; + TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node; + TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type; + TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE; + } + } + + /* Loop over the parameters and get their associated GCC tree. While + doing this, build a copy-in copy-out structure if we need one. */ + for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0; + Present (gnat_param); + gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++) + { + tree gnu_param_name = get_entity_name (gnat_param); + tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param)); + tree gnu_param, gnu_field; + bool copy_in_copy_out = false; + Mechanism_Type mech = Mechanism (gnat_param); + + /* Builtins are expanded inline and there is no real call sequence + involved. So the type expected by the underlying expander is + always the type of each argument "as is". */ + if (gnu_builtin_decl) + mech = By_Copy; + /* Handle the first parameter of a valued procedure specially. */ + else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0) + mech = By_Copy_Return; + /* Otherwise, see if a Mechanism was supplied that forced this + parameter to be passed one way or another. */ + else if (mech == Default + || mech == By_Copy || mech == By_Reference) + ; + else if (By_Descriptor_Last <= mech && mech <= By_Descriptor) + mech = By_Descriptor; + + else if (By_Short_Descriptor_Last <= mech && + mech <= By_Short_Descriptor) + mech = By_Short_Descriptor; + + else if (mech > 0) + { + if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE + || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST + || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type), + mech)) + mech = By_Reference; + else + mech = By_Copy; + } + else + { + post_error ("unsupported mechanism for&", gnat_param); + mech = Default; + } + + gnu_param + = gnat_to_gnu_param (gnat_param, mech, gnat_entity, + Has_Foreign_Convention (gnat_entity), + ©_in_copy_out); + + /* We are returned either a PARM_DECL or a type if no parameter + needs to be passed; in either case, adjust the type. */ + if (DECL_P (gnu_param)) + gnu_param_type = TREE_TYPE (gnu_param); + else + { + gnu_param_type = gnu_param; + gnu_param = NULL_TREE; + } + + /* The failure of this assertion will very likely come from an + order of elaboration issue for the type of the parameter. */ + gcc_assert (kind == E_Subprogram_Type + || !TYPE_IS_DUMMY_P (gnu_param_type)); + + if (gnu_param) + { + /* If it's an exported subprogram, we build a parameter list + in parallel, in case we need to emit a stub for it. */ + if (Is_Exported (gnat_entity)) + { + gnu_stub_param_list + = chainon (gnu_param, gnu_stub_param_list); + /* Change By_Descriptor parameter to By_Reference for + the internal version of an exported subprogram. */ + if (mech == By_Descriptor || mech == By_Short_Descriptor) + { + gnu_param + = gnat_to_gnu_param (gnat_param, By_Reference, + gnat_entity, false, + ©_in_copy_out); + has_stub = true; + } + else + gnu_param = copy_node (gnu_param); + } + + gnu_param_list = chainon (gnu_param, gnu_param_list); + Sloc_to_locus (Sloc (gnat_param), + &DECL_SOURCE_LOCATION (gnu_param)); + save_gnu_tree (gnat_param, gnu_param, false); + + /* If a parameter is a pointer, this function may modify + memory through it and thus shouldn't be considered + a const function. Also, the memory may be modified + between two calls, so they can't be CSE'ed. The latter + case also handles by-ref parameters. */ + if (POINTER_TYPE_P (gnu_param_type) + || TYPE_IS_FAT_POINTER_P (gnu_param_type)) + const_flag = false; + } + + if (copy_in_copy_out) + { + if (!gnu_cico_list) + { + tree gnu_new_ret_type = make_node (RECORD_TYPE); + + /* If this is a function, we also need a field for the + return value to be placed. */ + if (TREE_CODE (gnu_return_type) != VOID_TYPE) + { + gnu_field + = create_field_decl (get_identifier ("RETVAL"), + gnu_return_type, + gnu_new_ret_type, NULL_TREE, + NULL_TREE, 0, 0); + Sloc_to_locus (Sloc (gnat_entity), + &DECL_SOURCE_LOCATION (gnu_field)); + gnu_field_list = gnu_field; + gnu_cico_list + = tree_cons (gnu_field, void_type_node, NULL_TREE); + } + + gnu_return_type = gnu_new_ret_type; + TYPE_NAME (gnu_return_type) = get_identifier ("RETURN"); + /* Set a default alignment to speed up accesses. */ + TYPE_ALIGN (gnu_return_type) + = get_mode_alignment (ptr_mode); + } + + gnu_field + = create_field_decl (gnu_param_name, gnu_param_type, + gnu_return_type, NULL_TREE, NULL_TREE, + 0, 0); + Sloc_to_locus (Sloc (gnat_param), + &DECL_SOURCE_LOCATION (gnu_field)); + DECL_CHAIN (gnu_field) = gnu_field_list; + gnu_field_list = gnu_field; + gnu_cico_list + = tree_cons (gnu_field, gnu_param, gnu_cico_list); + } + } + + /* Do not compute record for out parameters if subprogram is + stubbed since structures are incomplete for the back-end. */ + if (gnu_field_list && Convention (gnat_entity) != Convention_Stubbed) + finish_record_type (gnu_return_type, nreverse (gnu_field_list), + 0, debug_info_p); + + /* If we have a CICO list but it has only one entry, we convert + this function into a function that simply returns that one + object. */ + if (list_length (gnu_cico_list) == 1) + gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_cico_list)); + + if (Has_Stdcall_Convention (gnat_entity)) + prepend_one_attribute_to + (&attr_list, ATTR_MACHINE_ATTRIBUTE, + get_identifier ("stdcall"), NULL_TREE, + gnat_entity); + + /* If we should request stack realignment for a foreign convention + subprogram, do so. Note that this applies to task entry points in + particular. */ + if (FOREIGN_FORCE_REALIGN_STACK + && Has_Foreign_Convention (gnat_entity)) + prepend_one_attribute_to + (&attr_list, ATTR_MACHINE_ATTRIBUTE, + get_identifier ("force_align_arg_pointer"), NULL_TREE, + gnat_entity); + + /* The lists have been built in reverse. */ + gnu_param_list = nreverse (gnu_param_list); + if (has_stub) + gnu_stub_param_list = nreverse (gnu_stub_param_list); + gnu_cico_list = nreverse (gnu_cico_list); + + if (kind == E_Function) + Set_Mechanism (gnat_entity, return_unconstrained_p + || return_by_direct_ref_p + || return_by_invisi_ref_p + ? By_Reference : By_Copy); + gnu_type + = create_subprog_type (gnu_return_type, gnu_param_list, + gnu_cico_list, return_unconstrained_p, + return_by_direct_ref_p, + return_by_invisi_ref_p); + + if (has_stub) + gnu_stub_type + = create_subprog_type (gnu_return_type, gnu_stub_param_list, + gnu_cico_list, return_unconstrained_p, + return_by_direct_ref_p, + return_by_invisi_ref_p); + + /* A subprogram (something that doesn't return anything) shouldn't + be considered const since there would be no reason for such a + subprogram. Note that procedures with Out (or In Out) parameters + have already been converted into a function with a return type. */ + if (TREE_CODE (gnu_return_type) == VOID_TYPE) + const_flag = false; + + gnu_type + = build_qualified_type (gnu_type, + TYPE_QUALS (gnu_type) + | (TYPE_QUAL_CONST * const_flag) + | (TYPE_QUAL_VOLATILE * volatile_flag)); + + if (has_stub) + gnu_stub_type + = build_qualified_type (gnu_stub_type, + TYPE_QUALS (gnu_stub_type) + | (TYPE_QUAL_CONST * const_flag) + | (TYPE_QUAL_VOLATILE * volatile_flag)); + + /* If we have a builtin decl for that function, use it. Check if the + profiles are compatible and warn if they are not. The checker is + expected to post extra diagnostics in this case. */ + if (gnu_builtin_decl) + { + intrin_binding_t inb; + + inb.gnat_entity = gnat_entity; + inb.ada_fntype = gnu_type; + inb.btin_fntype = TREE_TYPE (gnu_builtin_decl); + + if (!intrin_profiles_compatible_p (&inb)) + post_error + ("?profile of& doesn''t match the builtin it binds!", + gnat_entity); + + gnu_decl = gnu_builtin_decl; + gnu_type = TREE_TYPE (gnu_builtin_decl); + break; + } + + /* If there was no specified Interface_Name and the external and + internal names of the subprogram are the same, only use the + internal name to allow disambiguation of nested subprograms. */ + if (No (Interface_Name (gnat_entity)) + && gnu_ext_name == gnu_entity_name) + gnu_ext_name = NULL_TREE; + + /* If we are defining the subprogram and it has an Address clause + we must get the address expression from the saved GCC tree for the + subprogram if it has a Freeze_Node. Otherwise, we elaborate + the address expression here since the front-end has guaranteed + in that case that the elaboration has no effects. If there is + an Address clause and we are not defining the object, just + make it a constant. */ + if (Present (Address_Clause (gnat_entity))) + { + tree gnu_address = NULL_TREE; + + if (definition) + gnu_address + = (present_gnu_tree (gnat_entity) + ? get_gnu_tree (gnat_entity) + : gnat_to_gnu (Expression (Address_Clause (gnat_entity)))); + + save_gnu_tree (gnat_entity, NULL_TREE, false); + + /* Convert the type of the object to a reference type that can + alias everything as per 13.3(19). */ + gnu_type + = build_reference_type_for_mode (gnu_type, ptr_mode, true); + if (gnu_address) + gnu_address = convert (gnu_type, gnu_address); + + gnu_decl + = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type, + gnu_address, false, Is_Public (gnat_entity), + extern_flag, false, NULL, gnat_entity); + DECL_BY_REF_P (gnu_decl) = 1; + } + + else if (kind == E_Subprogram_Type) + gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list, + !Comes_From_Source (gnat_entity), + debug_info_p, gnat_entity); + else + { + if (has_stub) + { + gnu_stub_name = gnu_ext_name; + gnu_ext_name = create_concat_name (gnat_entity, "internal"); + public_flag = false; + } + + gnu_decl = create_subprog_decl (gnu_entity_name, gnu_ext_name, + gnu_type, gnu_param_list, + inline_flag, public_flag, + extern_flag, attr_list, + gnat_entity); + if (has_stub) + { + tree gnu_stub_decl + = create_subprog_decl (gnu_entity_name, gnu_stub_name, + gnu_stub_type, gnu_stub_param_list, + inline_flag, true, + extern_flag, attr_list, + gnat_entity); + SET_DECL_FUNCTION_STUB (gnu_decl, gnu_stub_decl); + } + + /* This is unrelated to the stub built right above. */ + DECL_STUBBED_P (gnu_decl) + = Convention (gnat_entity) == Convention_Stubbed; + } + } + break; + + case E_Incomplete_Type: + case E_Incomplete_Subtype: + case E_Private_Type: + case E_Private_Subtype: + case E_Limited_Private_Type: + case E_Limited_Private_Subtype: + case E_Record_Type_With_Private: + case E_Record_Subtype_With_Private: + { + /* Get the "full view" of this entity. If this is an incomplete + entity from a limited with, treat its non-limited view as the + full view. Otherwise, use either the full view or the underlying + full view, whichever is present. This is used in all the tests + below. */ + Entity_Id full_view + = (IN (kind, Incomplete_Kind) && From_With_Type (gnat_entity)) + ? Non_Limited_View (gnat_entity) + : Present (Full_View (gnat_entity)) + ? Full_View (gnat_entity) + : Underlying_Full_View (gnat_entity); + + /* If this is an incomplete type with no full view, it must be a Taft + Amendment type, in which case we return a dummy type. Otherwise, + just get the type from its Etype. */ + if (No (full_view)) + { + if (kind == E_Incomplete_Type) + { + gnu_type = make_dummy_type (gnat_entity); + gnu_decl = TYPE_STUB_DECL (gnu_type); + } + else + { + gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity), + NULL_TREE, 0); + maybe_present = true; + } + break; + } + + /* If we already made a type for the full view, reuse it. */ + else if (present_gnu_tree (full_view)) + { + gnu_decl = get_gnu_tree (full_view); + break; + } + + /* Otherwise, if we are not defining the type now, get the type + from the full view. But always get the type from the full view + for define on use types, since otherwise we won't see them! */ + else if (!definition + || (Is_Itype (full_view) + && No (Freeze_Node (gnat_entity))) + || (Is_Itype (gnat_entity) + && No (Freeze_Node (full_view)))) + { + gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0); + maybe_present = true; + break; + } + + /* For incomplete types, make a dummy type entry which will be + replaced later. Save it as the full declaration's type so + we can do any needed updates when we see it. */ + gnu_type = make_dummy_type (gnat_entity); + gnu_decl = TYPE_STUB_DECL (gnu_type); + save_gnu_tree (full_view, gnu_decl, 0); + break; + } + + case E_Class_Wide_Type: + /* Class-wide types are always transformed into their root type. */ + gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0); + maybe_present = true; + break; + + case E_Task_Type: + case E_Task_Subtype: + case E_Protected_Type: + case E_Protected_Subtype: + /* Concurrent types are always transformed into their record type. */ + if (type_annotate_only && No (gnat_equiv_type)) + gnu_type = void_type_node; + else + gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0); + maybe_present = true; + break; + + case E_Label: + gnu_decl = create_label_decl (gnu_entity_name); + break; + + case E_Block: + case E_Loop: + /* Nothing at all to do here, so just return an ERROR_MARK and claim + we've already saved it, so we don't try to. */ + gnu_decl = error_mark_node; + saved = true; + break; + + default: + gcc_unreachable (); + } + + /* If we had a case where we evaluated another type and it might have + defined this one, handle it here. */ + if (maybe_present && present_gnu_tree (gnat_entity)) + { + gnu_decl = get_gnu_tree (gnat_entity); + saved = true; + } + + /* If we are processing a type and there is either no decl for it or + we just made one, do some common processing for the type, such as + handling alignment and possible padding. */ + if (is_type && (!gnu_decl || this_made_decl)) + { + /* Tell the middle-end that objects of tagged types are guaranteed to + be properly aligned. This is necessary because conversions to the + class-wide type are translated into conversions to the root type, + which can be less aligned than some of its derived types. */ + if (Is_Tagged_Type (gnat_entity) + || Is_Class_Wide_Equivalent_Type (gnat_entity)) + TYPE_ALIGN_OK (gnu_type) = 1; + + /* If the type is passed by reference, objects of this type must be + fully addressable and cannot be copied. */ + if (Is_By_Reference_Type (gnat_entity)) + TREE_ADDRESSABLE (gnu_type) = 1; + + /* ??? Don't set the size for a String_Literal since it is either + confirming or we don't handle it properly (if the low bound is + non-constant). */ + if (!gnu_size && kind != E_String_Literal_Subtype) + gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity, + TYPE_DECL, false, + Has_Size_Clause (gnat_entity)); + + /* If a size was specified, see if we can make a new type of that size + by rearranging the type, for example from a fat to a thin pointer. */ + if (gnu_size) + { + gnu_type + = make_type_from_size (gnu_type, gnu_size, + Has_Biased_Representation (gnat_entity)); + + if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0) + && operand_equal_p (rm_size (gnu_type), gnu_size, 0)) + gnu_size = 0; + } + + /* If the alignment hasn't already been processed and this is + not an unconstrained array, see if an alignment is specified. + If not, we pick a default alignment for atomic objects. */ + if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) + ; + else if (Known_Alignment (gnat_entity)) + { + align = validate_alignment (Alignment (gnat_entity), gnat_entity, + TYPE_ALIGN (gnu_type)); + + /* Warn on suspiciously large alignments. This should catch + errors about the (alignment,byte)/(size,bit) discrepancy. */ + if (align > BIGGEST_ALIGNMENT && Has_Alignment_Clause (gnat_entity)) + { + tree size; + + /* If a size was specified, take it into account. Otherwise + use the RM size for records as the type size has already + been adjusted to the alignment. */ + if (gnu_size) + size = gnu_size; + else if ((TREE_CODE (gnu_type) == RECORD_TYPE + || TREE_CODE (gnu_type) == UNION_TYPE + || TREE_CODE (gnu_type) == QUAL_UNION_TYPE) + && !TYPE_FAT_POINTER_P (gnu_type)) + size = rm_size (gnu_type); + else + size = TYPE_SIZE (gnu_type); + + /* Consider an alignment as suspicious if the alignment/size + ratio is greater or equal to the byte/bit ratio. */ + if (host_integerp (size, 1) + && align >= TREE_INT_CST_LOW (size) * BITS_PER_UNIT) + post_error_ne ("?suspiciously large alignment specified for&", + Expression (Alignment_Clause (gnat_entity)), + gnat_entity); + } + } + else if (Is_Atomic (gnat_entity) && !gnu_size + && host_integerp (TYPE_SIZE (gnu_type), 1) + && integer_pow2p (TYPE_SIZE (gnu_type))) + align = MIN (BIGGEST_ALIGNMENT, + tree_low_cst (TYPE_SIZE (gnu_type), 1)); + else if (Is_Atomic (gnat_entity) && gnu_size + && host_integerp (gnu_size, 1) + && integer_pow2p (gnu_size)) + align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1)); + + /* See if we need to pad the type. If we did, and made a record, + the name of the new type may be changed. So get it back for + us when we make the new TYPE_DECL below. */ + if (gnu_size || align > 0) + gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity, + false, !gnu_decl, definition, false); + + if (TYPE_IS_PADDING_P (gnu_type)) + { + gnu_entity_name = TYPE_NAME (gnu_type); + if (TREE_CODE (gnu_entity_name) == TYPE_DECL) + gnu_entity_name = DECL_NAME (gnu_entity_name); + } + + set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity); + + /* If we are at global level, GCC will have applied variable_size to + the type, but that won't have done anything. So, if it's not + a constant or self-referential, call elaborate_expression_1 to + make a variable for the size rather than calculating it each time. + Handle both the RM size and the actual size. */ + if (global_bindings_p () + && TYPE_SIZE (gnu_type) + && !TREE_CONSTANT (TYPE_SIZE (gnu_type)) + && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))) + { + tree size = TYPE_SIZE (gnu_type); + + TYPE_SIZE (gnu_type) + = elaborate_expression_1 (size, gnat_entity, + get_identifier ("SIZE"), + definition, false); + + /* ??? For now, store the size as a multiple of the alignment in + bytes so that we can see the alignment from the tree. */ + TYPE_SIZE_UNIT (gnu_type) + = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_type), gnat_entity, + get_identifier ("SIZE_A_UNIT"), + definition, false, + TYPE_ALIGN (gnu_type)); + + /* ??? gnu_type may come from an existing type so the MULT_EXPR node + may not be marked by the call to create_type_decl below. */ + MARK_VISITED (TYPE_SIZE_UNIT (gnu_type)); + + if (TREE_CODE (gnu_type) == RECORD_TYPE) + { + tree variant_part = get_variant_part (gnu_type); + tree ada_size = TYPE_ADA_SIZE (gnu_type); + + if (variant_part) + { + tree union_type = TREE_TYPE (variant_part); + tree offset = DECL_FIELD_OFFSET (variant_part); + + /* If the position of the variant part is constant, subtract + it from the size of the type of the parent to get the new + size. This manual CSE reduces the data size. */ + if (TREE_CODE (offset) == INTEGER_CST) + { + tree bitpos = DECL_FIELD_BIT_OFFSET (variant_part); + TYPE_SIZE (union_type) + = size_binop (MINUS_EXPR, TYPE_SIZE (gnu_type), + bit_from_pos (offset, bitpos)); + TYPE_SIZE_UNIT (union_type) + = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (gnu_type), + byte_from_pos (offset, bitpos)); + } + else + { + TYPE_SIZE (union_type) + = elaborate_expression_1 (TYPE_SIZE (union_type), + gnat_entity, + get_identifier ("VSIZE"), + definition, false); + + /* ??? For now, store the size as a multiple of the + alignment in bytes so that we can see the alignment + from the tree. */ + TYPE_SIZE_UNIT (union_type) + = elaborate_expression_2 (TYPE_SIZE_UNIT (union_type), + gnat_entity, + get_identifier + ("VSIZE_A_UNIT"), + definition, false, + TYPE_ALIGN (union_type)); + + /* ??? For now, store the offset as a multiple of the + alignment in bytes so that we can see the alignment + from the tree. */ + DECL_FIELD_OFFSET (variant_part) + = elaborate_expression_2 (offset, + gnat_entity, + get_identifier ("VOFFSET"), + definition, false, + DECL_OFFSET_ALIGN + (variant_part)); + } + + DECL_SIZE (variant_part) = TYPE_SIZE (union_type); + DECL_SIZE_UNIT (variant_part) = TYPE_SIZE_UNIT (union_type); + } + + if (operand_equal_p (ada_size, size, 0)) + ada_size = TYPE_SIZE (gnu_type); + else + ada_size + = elaborate_expression_1 (ada_size, gnat_entity, + get_identifier ("RM_SIZE"), + definition, false); + SET_TYPE_ADA_SIZE (gnu_type, ada_size); + } + } + + /* If this is a record type or subtype, call elaborate_expression_1 on + any field position. Do this for both global and local types. + Skip any fields that we haven't made trees for to avoid problems with + class wide types. */ + if (IN (kind, Record_Kind)) + for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp); + gnat_temp = Next_Entity (gnat_temp)) + if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp)) + { + tree gnu_field = get_gnu_tree (gnat_temp); + + /* ??? For now, store the offset as a multiple of the alignment + in bytes so that we can see the alignment from the tree. */ + if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field))) + { + DECL_FIELD_OFFSET (gnu_field) + = elaborate_expression_2 (DECL_FIELD_OFFSET (gnu_field), + gnat_temp, + get_identifier ("OFFSET"), + definition, false, + DECL_OFFSET_ALIGN (gnu_field)); + + /* ??? The context of gnu_field is not necessarily gnu_type + so the MULT_EXPR node built above may not be marked by + the call to create_type_decl below. */ + if (global_bindings_p ()) + MARK_VISITED (DECL_FIELD_OFFSET (gnu_field)); + } + } + + if (Treat_As_Volatile (gnat_entity)) + gnu_type + = build_qualified_type (gnu_type, + TYPE_QUALS (gnu_type) | TYPE_QUAL_VOLATILE); + + if (Is_Atomic (gnat_entity)) + check_ok_for_atomic (gnu_type, gnat_entity, false); + + if (Present (Alignment_Clause (gnat_entity))) + TYPE_USER_ALIGN (gnu_type) = 1; + + if (Universal_Aliasing (gnat_entity)) + TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type)) = 1; + + if (!gnu_decl) + gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list, + !Comes_From_Source (gnat_entity), + debug_info_p, gnat_entity); + else + { + TREE_TYPE (gnu_decl) = gnu_type; + TYPE_STUB_DECL (gnu_type) = gnu_decl; + } + } + + if (is_type && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))) + { + gnu_type = TREE_TYPE (gnu_decl); + + /* If this is a derived type, relate its alias set to that of its parent + to avoid troubles when a call to an inherited primitive is inlined in + a context where a derived object is accessed. The inlined code works + on the parent view so the resulting code may access the same object + using both the parent and the derived alias sets, which thus have to + conflict. As the same issue arises with component references, the + parent alias set also has to conflict with composite types enclosing + derived components. For instance, if we have: + + type D is new T; + type R is record + Component : D; + end record; + + we want T to conflict with both D and R, in addition to R being a + superset of D by record/component construction. + + One way to achieve this is to perform an alias set copy from the + parent to the derived type. This is not quite appropriate, though, + as we don't want separate derived types to conflict with each other: + + type I1 is new Integer; + type I2 is new Integer; + + We want I1 and I2 to both conflict with Integer but we do not want + I1 to conflict with I2, and an alias set copy on derivation would + have that effect. + + The option chosen is to make the alias set of the derived type a + superset of that of its parent type. It trivially fulfills the + simple requirement for the Integer derivation example above, and + the component case as well by superset transitivity: + + superset superset + R ----------> D ----------> T + + However, for composite types, conversions between derived types are + translated into VIEW_CONVERT_EXPRs so a sequence like: + + type Comp1 is new Comp; + type Comp2 is new Comp; + procedure Proc (C : Comp1); + + C : Comp2; + Proc (Comp1 (C)); + + is translated into: + + C : Comp2; + Proc ((Comp1 &) &VIEW_CONVERT_EXPR (C)); + + and gimplified into: + + C : Comp2; + Comp1 *C.0; + C.0 = (Comp1 *) &C; + Proc (C.0); + + i.e. generates code involving type punning. Therefore, Comp1 needs + to conflict with Comp2 and an alias set copy is required. + + The language rules ensure the parent type is already frozen here. */ + if (Is_Derived_Type (gnat_entity)) + { + tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_entity)); + relate_alias_sets (gnu_type, gnu_parent_type, + Is_Composite_Type (gnat_entity) + ? ALIAS_SET_COPY : ALIAS_SET_SUPERSET); + } + + /* Back-annotate the Alignment of the type if not already in the + tree. Likewise for sizes. */ + if (Unknown_Alignment (gnat_entity)) + { + unsigned int double_align, align; + bool is_capped_double, align_clause; + + /* If the default alignment of "double" or larger scalar types is + specifically capped and this is not an array with an alignment + clause on the component type, return the cap. */ + if ((double_align = double_float_alignment) > 0) + is_capped_double + = is_double_float_or_array (gnat_entity, &align_clause); + else if ((double_align = double_scalar_alignment) > 0) + is_capped_double + = is_double_scalar_or_array (gnat_entity, &align_clause); + else + is_capped_double = align_clause = false; + + if (is_capped_double && !align_clause) + align = double_align; + else + align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT; + + Set_Alignment (gnat_entity, UI_From_Int (align)); + } + + if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type)) + { + tree gnu_size = TYPE_SIZE (gnu_type); + + /* If the size is self-referential, annotate the maximum value. */ + if (CONTAINS_PLACEHOLDER_P (gnu_size)) + gnu_size = max_size (gnu_size, true); + + if (type_annotate_only && Is_Tagged_Type (gnat_entity)) + { + /* In this mode, the tag and the parent components are not + generated by the front-end so the sizes must be adjusted. */ + tree pointer_size = bitsize_int (POINTER_SIZE), offset; + Uint uint_size; + + if (Is_Derived_Type (gnat_entity)) + { + offset = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))), + bitsizetype); + Set_Alignment (gnat_entity, + Alignment (Etype (Base_Type (gnat_entity)))); + } + else + offset = pointer_size; + + gnu_size = size_binop (PLUS_EXPR, gnu_size, offset); + gnu_size = size_binop (MULT_EXPR, pointer_size, + size_binop (CEIL_DIV_EXPR, + gnu_size, + pointer_size)); + uint_size = annotate_value (gnu_size); + Set_Esize (gnat_entity, uint_size); + Set_RM_Size (gnat_entity, uint_size); + } + else + Set_Esize (gnat_entity, annotate_value (gnu_size)); + } + + if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type)) + Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type))); + } + + /* If we really have a ..._DECL node, set a couple of flags on it. But we + cannot do that if we are reusing the ..._DECL node made for a renamed + object, since the predicates don't apply to it but to GNAT_ENTITY. */ + if (DECL_P (gnu_decl) && !(Present (Renamed_Object (gnat_entity)) && saved)) + { + if (!Comes_From_Source (gnat_entity)) + DECL_ARTIFICIAL (gnu_decl) = 1; + + if (!debug_info_p && TREE_CODE (gnu_decl) != FUNCTION_DECL) + DECL_IGNORED_P (gnu_decl) = 1; + } + + /* If we haven't already, associate the ..._DECL node that we just made with + the input GNAT entity node. */ + if (!saved) + save_gnu_tree (gnat_entity, gnu_decl, false); + + /* If this is an enumeration or floating-point type, we were not able to set + the bounds since they refer to the type. These are always static. */ + if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity))) + || (kind == E_Floating_Point_Type && !Vax_Float (gnat_entity))) + { + tree gnu_scalar_type = gnu_type; + tree gnu_low_bound, gnu_high_bound; + + /* If this is a padded type, we need to use the underlying type. */ + if (TYPE_IS_PADDING_P (gnu_scalar_type)) + gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type)); + + /* If this is a floating point type and we haven't set a floating + point type yet, use this in the evaluation of the bounds. */ + if (!longest_float_type_node && kind == E_Floating_Point_Type) + longest_float_type_node = gnu_scalar_type; + + gnu_low_bound = gnat_to_gnu (Type_Low_Bound (gnat_entity)); + gnu_high_bound = gnat_to_gnu (Type_High_Bound (gnat_entity)); + + if (kind == E_Enumeration_Type) + { + /* Enumeration types have specific RM bounds. */ + SET_TYPE_RM_MIN_VALUE (gnu_scalar_type, gnu_low_bound); + SET_TYPE_RM_MAX_VALUE (gnu_scalar_type, gnu_high_bound); + + /* Write full debugging information. Since this has both a + typedef and a tag, avoid outputting the name twice. */ + DECL_ARTIFICIAL (gnu_decl) = 1; + rest_of_type_decl_compilation (gnu_decl); + } + + else + { + /* Floating-point types don't have specific RM bounds. */ + TYPE_GCC_MIN_VALUE (gnu_scalar_type) = gnu_low_bound; + TYPE_GCC_MAX_VALUE (gnu_scalar_type) = gnu_high_bound; + } + } + + /* If we deferred processing of incomplete types, re-enable it. If there + were no other disables and we have some to process, do so. */ + if (this_deferred && --defer_incomplete_level == 0) + { + if (defer_incomplete_list) + { + struct incomplete *incp, *next; + + /* We are back to level 0 for the deferring of incomplete types. + But processing these incomplete types below may itself require + deferring, so preserve what we have and restart from scratch. */ + incp = defer_incomplete_list; + defer_incomplete_list = NULL; + + /* For finalization, however, all types must be complete so we + cannot do the same because deferred incomplete types may end up + referencing each other. Process them all recursively first. */ + defer_finalize_level++; + + for (; incp; incp = next) + { + next = incp->next; + + if (incp->old_type) + update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type), + gnat_to_gnu_type (incp->full_type)); + free (incp); + } + + defer_finalize_level--; + } + + /* All the deferred incomplete types have been processed so we can + now proceed with the finalization of the deferred types. */ + if (defer_finalize_level == 0 && defer_finalize_list) + { + unsigned int i; + tree t; + + FOR_EACH_VEC_ELT (tree, defer_finalize_list, i, t) + rest_of_type_decl_compilation_no_defer (t); + + VEC_free (tree, heap, defer_finalize_list); + } + } + + /* If we are not defining this type, see if it's in the incomplete list. + If so, handle that list entry now. */ + else if (!definition) + { + struct incomplete *incp; + + for (incp = defer_incomplete_list; incp; incp = incp->next) + if (incp->old_type && incp->full_type == gnat_entity) + { + update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type), + TREE_TYPE (gnu_decl)); + incp->old_type = NULL_TREE; + } + } + + if (this_global) + force_global--; + + /* If this is a packed array type whose original array type is itself + an Itype without freeze node, make sure the latter is processed. */ + if (Is_Packed_Array_Type (gnat_entity) + && Is_Itype (Original_Array_Type (gnat_entity)) + && No (Freeze_Node (Original_Array_Type (gnat_entity))) + && !present_gnu_tree (Original_Array_Type (gnat_entity))) + gnat_to_gnu_entity (Original_Array_Type (gnat_entity), NULL_TREE, 0); + + return gnu_decl; +} + +/* Similar, but if the returned value is a COMPONENT_REF, return the + FIELD_DECL. */ + +tree +gnat_to_gnu_field_decl (Entity_Id gnat_entity) +{ + tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0); + + if (TREE_CODE (gnu_field) == COMPONENT_REF) + gnu_field = TREE_OPERAND (gnu_field, 1); + + return gnu_field; +} + +/* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return + the GCC type corresponding to that entity. */ + +tree +gnat_to_gnu_type (Entity_Id gnat_entity) +{ + tree gnu_decl; + + /* The back end never attempts to annotate generic types. */ + if (Is_Generic_Type (gnat_entity) && type_annotate_only) + return void_type_node; + + gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0); + gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL); + + return TREE_TYPE (gnu_decl); +} + +/* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return + the unpadded version of the GCC type corresponding to that entity. */ + +tree +get_unpadded_type (Entity_Id gnat_entity) +{ + tree type = gnat_to_gnu_type (gnat_entity); + + if (TYPE_IS_PADDING_P (type)) + type = TREE_TYPE (TYPE_FIELDS (type)); + + return type; +} + +/* Wrap up compilation of DECL, a TYPE_DECL, possibly deferring it. + Every TYPE_DECL generated for a type definition must be passed + to this function once everything else has been done for it. */ + +void +rest_of_type_decl_compilation (tree decl) +{ + /* We need to defer finalizing the type if incomplete types + are being deferred or if they are being processed. */ + if (defer_incomplete_level != 0 || defer_finalize_level != 0) + VEC_safe_push (tree, heap, defer_finalize_list, decl); + else + rest_of_type_decl_compilation_no_defer (decl); +} + +/* Same as above but without deferring the compilation. This + function should not be invoked directly on a TYPE_DECL. */ + +static void +rest_of_type_decl_compilation_no_defer (tree decl) +{ + const int toplev = global_bindings_p (); + tree t = TREE_TYPE (decl); + + rest_of_decl_compilation (decl, toplev, 0); + + /* Now process all the variants. This is needed for STABS. */ + for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t)) + { + if (t == TREE_TYPE (decl)) + continue; + + if (!TYPE_STUB_DECL (t)) + TYPE_STUB_DECL (t) = create_type_stub_decl (DECL_NAME (decl), t); + + rest_of_type_compilation (t, toplev); + } +} + +/* Given a record type RECORD_TYPE and a list of FIELD_DECL nodes FIELD_LIST, + finish constructing the record type as a fat pointer type. */ + +static void +finish_fat_pointer_type (tree record_type, tree field_list) +{ + /* Make sure we can put it into a register. */ + TYPE_ALIGN (record_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE); + + /* Show what it really is. */ + TYPE_FAT_POINTER_P (record_type) = 1; + + /* Do not emit debug info for it since the types of its fields may still be + incomplete at this point. */ + finish_record_type (record_type, field_list, 0, false); + + /* Force type_contains_placeholder_p to return true on it. Although the + PLACEHOLDER_EXPRs are referenced only indirectly, this isn't a pointer + type but the representation of the unconstrained array. */ + TYPE_CONTAINS_PLACEHOLDER_INTERNAL (record_type) = 2; +} + +/* Finalize any From_With_Type incomplete types. We do this after processing + our compilation unit and after processing its spec, if this is a body. */ + +void +finalize_from_with_types (void) +{ + struct incomplete *incp = defer_limited_with; + struct incomplete *next; + + defer_limited_with = 0; + for (; incp; incp = next) + { + next = incp->next; + + if (incp->old_type != 0) + update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type), + gnat_to_gnu_type (incp->full_type)); + free (incp); + } +} + +/* Return the equivalent type to be used for GNAT_ENTITY, if it's a + kind of type (such E_Task_Type) that has a different type which Gigi + uses for its representation. If the type does not have a special type + for its representation, return GNAT_ENTITY. If a type is supposed to + exist, but does not, abort unless annotating types, in which case + return Empty. If GNAT_ENTITY is Empty, return Empty. */ + +Entity_Id +Gigi_Equivalent_Type (Entity_Id gnat_entity) +{ + Entity_Id gnat_equiv = gnat_entity; + + if (No (gnat_entity)) + return gnat_entity; + + switch (Ekind (gnat_entity)) + { + case E_Class_Wide_Subtype: + if (Present (Equivalent_Type (gnat_entity))) + gnat_equiv = Equivalent_Type (gnat_entity); + break; + + case E_Access_Protected_Subprogram_Type: + case E_Anonymous_Access_Protected_Subprogram_Type: + gnat_equiv = Equivalent_Type (gnat_entity); + break; + + case E_Class_Wide_Type: + gnat_equiv = Root_Type (gnat_entity); + break; + + case E_Task_Type: + case E_Task_Subtype: + case E_Protected_Type: + case E_Protected_Subtype: + gnat_equiv = Corresponding_Record_Type (gnat_entity); + break; + + default: + break; + } + + gcc_assert (Present (gnat_equiv) || type_annotate_only); + return gnat_equiv; +} + +/* Return a GCC tree for a type corresponding to the component type of the + array type or subtype GNAT_ARRAY. DEFINITION is true if this component + is for an array being defined. DEBUG_INFO_P is true if we need to write + debug information for other types that we may create in the process. */ + +static tree +gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition, + bool debug_info_p) +{ + tree gnu_type = gnat_to_gnu_type (Component_Type (gnat_array)); + tree gnu_comp_size; + + /* Try to get a smaller form of the component if needed. */ + if ((Is_Packed (gnat_array) + || Has_Component_Size_Clause (gnat_array)) + && !Is_Bit_Packed_Array (gnat_array) + && !Has_Aliased_Components (gnat_array) + && !Strict_Alignment (Component_Type (gnat_array)) + && TREE_CODE (gnu_type) == RECORD_TYPE + && !TYPE_FAT_POINTER_P (gnu_type) + && host_integerp (TYPE_SIZE (gnu_type), 1)) + gnu_type = make_packable_type (gnu_type, false); + + if (Has_Atomic_Components (gnat_array)) + check_ok_for_atomic (gnu_type, gnat_array, true); + + /* Get and validate any specified Component_Size. */ + gnu_comp_size + = validate_size (Component_Size (gnat_array), gnu_type, gnat_array, + Is_Bit_Packed_Array (gnat_array) ? TYPE_DECL : VAR_DECL, + true, Has_Component_Size_Clause (gnat_array)); + + /* If the array has aliased components and the component size can be zero, + force at least unit size to ensure that the components have distinct + addresses. */ + if (!gnu_comp_size + && Has_Aliased_Components (gnat_array) + && (integer_zerop (TYPE_SIZE (gnu_type)) + || (TREE_CODE (gnu_type) == ARRAY_TYPE + && !TREE_CONSTANT (TYPE_SIZE (gnu_type))))) + gnu_comp_size + = size_binop (MAX_EXPR, TYPE_SIZE (gnu_type), bitsize_unit_node); + + /* If the component type is a RECORD_TYPE that has a self-referential size, + then use the maximum size for the component size. */ + if (!gnu_comp_size + && TREE_CODE (gnu_type) == RECORD_TYPE + && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))) + gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true); + + /* Honor the component size. This is not needed for bit-packed arrays. */ + if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_array)) + { + tree orig_type = gnu_type; + unsigned int max_align; + + /* If an alignment is specified, use it as a cap on the component type + so that it can be honored for the whole type. But ignore it for the + original type of packed array types. */ + if (No (Packed_Array_Type (gnat_array)) && Known_Alignment (gnat_array)) + max_align = validate_alignment (Alignment (gnat_array), gnat_array, 0); + else + max_align = 0; + + gnu_type = make_type_from_size (gnu_type, gnu_comp_size, false); + if (max_align > 0 && TYPE_ALIGN (gnu_type) > max_align) + gnu_type = orig_type; + else + orig_type = gnu_type; + + gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0, gnat_array, + true, false, definition, true); + + /* If a padding record was made, declare it now since it will never be + declared otherwise. This is necessary to ensure that its subtrees + are properly marked. */ + if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type))) + create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL, true, + debug_info_p, gnat_array); + } + + if (Has_Volatile_Components (Base_Type (gnat_array))) + gnu_type + = build_qualified_type (gnu_type, + TYPE_QUALS (gnu_type) | TYPE_QUAL_VOLATILE); + + return gnu_type; +} + +/* Return a GCC tree for a parameter corresponding to GNAT_PARAM and + using MECH as its passing mechanism, to be placed in the parameter + list built for GNAT_SUBPROG. Assume a foreign convention for the + latter if FOREIGN is true. Also set CICO to true if the parameter + must use the copy-in copy-out implementation mechanism. + + The returned tree is a PARM_DECL, except for those cases where no + parameter needs to be actually passed to the subprogram; the type + of this "shadow" parameter is then returned instead. */ + +static tree +gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, + Entity_Id gnat_subprog, bool foreign, bool *cico) +{ + tree gnu_param_name = get_entity_name (gnat_param); + tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param)); + tree gnu_param_type_alt = NULL_TREE; + bool in_param = (Ekind (gnat_param) == E_In_Parameter); + /* The parameter can be indirectly modified if its address is taken. */ + bool ro_param = in_param && !Address_Taken (gnat_param); + bool by_return = false, by_component_ptr = false; + bool by_ref = false, by_double_ref = false; + tree gnu_param; + + /* Copy-return is used only for the first parameter of a valued procedure. + It's a copy mechanism for which a parameter is never allocated. */ + if (mech == By_Copy_Return) + { + gcc_assert (Ekind (gnat_param) == E_Out_Parameter); + mech = By_Copy; + by_return = true; + } + + /* If this is either a foreign function or if the underlying type won't + be passed by reference, strip off possible padding type. */ + if (TYPE_IS_PADDING_P (gnu_param_type)) + { + tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type)); + + if (mech == By_Reference + || foreign + || (!must_pass_by_ref (unpadded_type) + && (mech == By_Copy || !default_pass_by_ref (unpadded_type)))) + gnu_param_type = unpadded_type; + } + + /* If this is a read-only parameter, make a variant of the type that is + read-only. ??? However, if this is an unconstrained array, that type + can be very complex, so skip it for now. Likewise for any other + self-referential type. */ + if (ro_param + && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE + && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type))) + gnu_param_type = build_qualified_type (gnu_param_type, + (TYPE_QUALS (gnu_param_type) + | TYPE_QUAL_CONST)); + + /* For foreign conventions, pass arrays as pointers to the element type. + First check for unconstrained array and get the underlying array. */ + if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE) + gnu_param_type + = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type)))); + + /* For GCC builtins, pass Address integer types as (void *) */ + if (Convention (gnat_subprog) == Convention_Intrinsic + && Present (Interface_Name (gnat_subprog)) + && Is_Descendent_Of_Address (Etype (gnat_param))) + gnu_param_type = ptr_void_type_node; + + /* VMS descriptors are themselves passed by reference. */ + if (mech == By_Short_Descriptor || + (mech == By_Descriptor && TARGET_ABI_OPEN_VMS && !TARGET_MALLOC64)) + gnu_param_type + = build_pointer_type (build_vms_descriptor32 (gnu_param_type, + Mechanism (gnat_param), + gnat_subprog)); + else if (mech == By_Descriptor) + { + /* Build both a 32-bit and 64-bit descriptor, one of which will be + chosen in fill_vms_descriptor. */ + gnu_param_type_alt + = build_pointer_type (build_vms_descriptor32 (gnu_param_type, + Mechanism (gnat_param), + gnat_subprog)); + gnu_param_type + = build_pointer_type (build_vms_descriptor (gnu_param_type, + Mechanism (gnat_param), + gnat_subprog)); + } + + /* Arrays are passed as pointers to element type for foreign conventions. */ + else if (foreign + && mech != By_Copy + && TREE_CODE (gnu_param_type) == ARRAY_TYPE) + { + /* Strip off any multi-dimensional entries, then strip + off the last array to get the component type. */ + while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type))) + gnu_param_type = TREE_TYPE (gnu_param_type); + + by_component_ptr = true; + gnu_param_type = TREE_TYPE (gnu_param_type); + + if (ro_param) + gnu_param_type = build_qualified_type (gnu_param_type, + (TYPE_QUALS (gnu_param_type) + | TYPE_QUAL_CONST)); + + gnu_param_type = build_pointer_type (gnu_param_type); + } + + /* Fat pointers are passed as thin pointers for foreign conventions. */ + else if (foreign && TYPE_IS_FAT_POINTER_P (gnu_param_type)) + gnu_param_type + = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0); + + /* If we must pass or were requested to pass by reference, do so. + If we were requested to pass by copy, do so. + Otherwise, for foreign conventions, pass In Out or Out parameters + or aggregates by reference. For COBOL and Fortran, pass all + integer and FP types that way too. For Convention Ada, use + the standard Ada default. */ + else if (must_pass_by_ref (gnu_param_type) + || mech == By_Reference + || (mech != By_Copy + && ((foreign + && (!in_param || AGGREGATE_TYPE_P (gnu_param_type))) + || (foreign + && (Convention (gnat_subprog) == Convention_Fortran + || Convention (gnat_subprog) == Convention_COBOL) + && (INTEGRAL_TYPE_P (gnu_param_type) + || FLOAT_TYPE_P (gnu_param_type))) + || (!foreign + && default_pass_by_ref (gnu_param_type))))) + { + gnu_param_type = build_reference_type (gnu_param_type); + by_ref = true; + + /* In some ABIs, e.g. SPARC 32-bit, fat pointer types are themselves + passed by reference. Pass them by explicit reference, this will + generate more debuggable code at -O0. */ + if (TYPE_IS_FAT_POINTER_P (gnu_param_type) + && targetm.calls.pass_by_reference (NULL, + TYPE_MODE (gnu_param_type), + gnu_param_type, + true)) + { + gnu_param_type = build_reference_type (gnu_param_type); + by_double_ref = true; + } + } + + /* Pass In Out or Out parameters using copy-in copy-out mechanism. */ + else if (!in_param) + *cico = true; + + if (mech == By_Copy && (by_ref || by_component_ptr)) + post_error ("?cannot pass & by copy", gnat_param); + + /* If this is an Out parameter that isn't passed by reference and isn't + a pointer or aggregate, we don't make a PARM_DECL for it. Instead, + it will be a VAR_DECL created when we process the procedure, so just + return its type. For the special parameter of a valued procedure, + never pass it in. + + An exception is made to cover the RM-6.4.1 rule requiring "by copy" + Out parameters with discriminants or implicit initial values to be + handled like In Out parameters. These type are normally built as + aggregates, hence passed by reference, except for some packed arrays + which end up encoded in special integer types. + + The exception we need to make is then for packed arrays of records + with discriminants or implicit initial values. We have no light/easy + way to check for the latter case, so we merely check for packed arrays + of records. This may lead to useless copy-in operations, but in very + rare cases only, as these would be exceptions in a set of already + exceptional situations. */ + if (Ekind (gnat_param) == E_Out_Parameter + && !by_ref + && (by_return + || (mech != By_Descriptor + && mech != By_Short_Descriptor + && !POINTER_TYPE_P (gnu_param_type) + && !AGGREGATE_TYPE_P (gnu_param_type))) + && !(Is_Array_Type (Etype (gnat_param)) + && Is_Packed (Etype (gnat_param)) + && Is_Composite_Type (Component_Type (Etype (gnat_param))))) + return gnu_param_type; + + gnu_param = create_param_decl (gnu_param_name, gnu_param_type, + ro_param || by_ref || by_component_ptr); + DECL_BY_REF_P (gnu_param) = by_ref; + DECL_BY_DOUBLE_REF_P (gnu_param) = by_double_ref; + DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr; + DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor || + mech == By_Short_Descriptor); + DECL_POINTS_TO_READONLY_P (gnu_param) + = (ro_param && (by_ref || by_component_ptr)); + + /* Save the alternate descriptor type, if any. */ + if (gnu_param_type_alt) + SET_DECL_PARM_ALT_TYPE (gnu_param, gnu_param_type_alt); + + /* If no Mechanism was specified, indicate what we're using, then + back-annotate it. */ + if (mech == Default) + mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy; + + Set_Mechanism (gnat_param, mech); + return gnu_param; +} + +/* Return true if DISCR1 and DISCR2 represent the same discriminant. */ + +static bool +same_discriminant_p (Entity_Id discr1, Entity_Id discr2) +{ + while (Present (Corresponding_Discriminant (discr1))) + discr1 = Corresponding_Discriminant (discr1); + + while (Present (Corresponding_Discriminant (discr2))) + discr2 = Corresponding_Discriminant (discr2); + + return + Original_Record_Component (discr1) == Original_Record_Component (discr2); +} + +/* Return true if the array type GNU_TYPE, which represents a dimension of + GNAT_TYPE, has a non-aliased component in the back-end sense. */ + +static bool +array_type_has_nonaliased_component (tree gnu_type, Entity_Id gnat_type) +{ + /* If the array type is not the innermost dimension of the GNAT type, + then it has a non-aliased component. */ + if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type))) + return true; + + /* If the array type has an aliased component in the front-end sense, + then it also has an aliased component in the back-end sense. */ + if (Has_Aliased_Components (gnat_type)) + return false; + + /* If this is a derived type, then it has a non-aliased component if + and only if its parent type also has one. */ + if (Is_Derived_Type (gnat_type)) + { + tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_type)); + int index; + if (TREE_CODE (gnu_parent_type) == UNCONSTRAINED_ARRAY_TYPE) + gnu_parent_type + = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_parent_type)))); + for (index = Number_Dimensions (gnat_type) - 1; index > 0; index--) + gnu_parent_type = TREE_TYPE (gnu_parent_type); + return TYPE_NONALIASED_COMPONENT (gnu_parent_type); + } + + /* Otherwise, rely exclusively on properties of the element type. */ + return type_for_nonaliased_component_p (TREE_TYPE (gnu_type)); +} + +/* Return true if GNAT_ADDRESS is a value known at compile-time. */ + +static bool +compile_time_known_address_p (Node_Id gnat_address) +{ + /* Catch System'To_Address. */ + if (Nkind (gnat_address) == N_Unchecked_Type_Conversion) + gnat_address = Expression (gnat_address); + + return Compile_Time_Known_Value (gnat_address); +} + +/* Return true if GNAT_RANGE, a N_Range node, cannot be superflat, i.e. if the + inequality HB >= LB-1 is true. LB and HB are the low and high bounds. */ + +static bool +cannot_be_superflat_p (Node_Id gnat_range) +{ + Node_Id gnat_lb = Low_Bound (gnat_range), gnat_hb = High_Bound (gnat_range); + Node_Id scalar_range; + tree gnu_lb, gnu_hb, gnu_lb_minus_one; + + /* If the low bound is not constant, try to find an upper bound. */ + while (Nkind (gnat_lb) != N_Integer_Literal + && (Ekind (Etype (gnat_lb)) == E_Signed_Integer_Subtype + || Ekind (Etype (gnat_lb)) == E_Modular_Integer_Subtype) + && (scalar_range = Scalar_Range (Etype (gnat_lb))) + && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition + || Nkind (scalar_range) == N_Range)) + gnat_lb = High_Bound (scalar_range); + + /* If the high bound is not constant, try to find a lower bound. */ + while (Nkind (gnat_hb) != N_Integer_Literal + && (Ekind (Etype (gnat_hb)) == E_Signed_Integer_Subtype + || Ekind (Etype (gnat_hb)) == E_Modular_Integer_Subtype) + && (scalar_range = Scalar_Range (Etype (gnat_hb))) + && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition + || Nkind (scalar_range) == N_Range)) + gnat_hb = Low_Bound (scalar_range); + + /* If we have failed to find constant bounds, punt. */ + if (Nkind (gnat_lb) != N_Integer_Literal + || Nkind (gnat_hb) != N_Integer_Literal) + return false; + + /* We need at least a signed 64-bit type to catch most cases. */ + gnu_lb = UI_To_gnu (Intval (gnat_lb), sbitsizetype); + gnu_hb = UI_To_gnu (Intval (gnat_hb), sbitsizetype); + if (TREE_OVERFLOW (gnu_lb) || TREE_OVERFLOW (gnu_hb)) + return false; + + /* If the low bound is the smallest integer, nothing can be smaller. */ + gnu_lb_minus_one = size_binop (MINUS_EXPR, gnu_lb, sbitsize_one_node); + if (TREE_OVERFLOW (gnu_lb_minus_one)) + return true; + + return !tree_int_cst_lt (gnu_hb, gnu_lb_minus_one); +} + +/* Return true if GNU_EXPR is (essentially) the address of a CONSTRUCTOR. */ + +static bool +constructor_address_p (tree gnu_expr) +{ + while (TREE_CODE (gnu_expr) == NOP_EXPR + || TREE_CODE (gnu_expr) == CONVERT_EXPR + || TREE_CODE (gnu_expr) == NON_LVALUE_EXPR) + gnu_expr = TREE_OPERAND (gnu_expr, 0); + + return (TREE_CODE (gnu_expr) == ADDR_EXPR + && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == CONSTRUCTOR); +} + +/* Given GNAT_ENTITY, elaborate all expressions that are required to + be elaborated at the point of its definition, but do nothing else. */ + +void +elaborate_entity (Entity_Id gnat_entity) +{ + switch (Ekind (gnat_entity)) + { + case E_Signed_Integer_Subtype: + case E_Modular_Integer_Subtype: + case E_Enumeration_Subtype: + case E_Ordinary_Fixed_Point_Subtype: + case E_Decimal_Fixed_Point_Subtype: + case E_Floating_Point_Subtype: + { + Node_Id gnat_lb = Type_Low_Bound (gnat_entity); + Node_Id gnat_hb = Type_High_Bound (gnat_entity); + + /* ??? Tests to avoid Constraint_Error in static expressions + are needed until after the front stops generating bogus + conversions on bounds of real types. */ + if (!Raises_Constraint_Error (gnat_lb)) + elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"), + true, false, Needs_Debug_Info (gnat_entity)); + if (!Raises_Constraint_Error (gnat_hb)) + elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"), + true, false, Needs_Debug_Info (gnat_entity)); + break; + } + + case E_Record_Type: + { + Node_Id full_definition = Declaration_Node (gnat_entity); + Node_Id record_definition = Type_Definition (full_definition); + + /* If this is a record extension, go a level further to find the + record definition. */ + if (Nkind (record_definition) == N_Derived_Type_Definition) + record_definition = Record_Extension_Part (record_definition); + } + break; + + case E_Record_Subtype: + case E_Private_Subtype: + case E_Limited_Private_Subtype: + case E_Record_Subtype_With_Private: + if (Is_Constrained (gnat_entity) + && Has_Discriminants (gnat_entity) + && Present (Discriminant_Constraint (gnat_entity))) + { + Node_Id gnat_discriminant_expr; + Entity_Id gnat_field; + + for (gnat_field + = First_Discriminant (Implementation_Base_Type (gnat_entity)), + gnat_discriminant_expr + = First_Elmt (Discriminant_Constraint (gnat_entity)); + Present (gnat_field); + gnat_field = Next_Discriminant (gnat_field), + gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr)) + /* ??? For now, ignore access discriminants. */ + if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr)))) + elaborate_expression (Node (gnat_discriminant_expr), + gnat_entity, get_entity_name (gnat_field), + true, false, false); + } + break; + + } +} + +/* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark + any entities on its entity chain similarly. */ + +void +mark_out_of_scope (Entity_Id gnat_entity) +{ + Entity_Id gnat_sub_entity; + unsigned int kind = Ekind (gnat_entity); + + /* If this has an entity list, process all in the list. */ + if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind) + || IN (kind, Private_Kind) + || kind == E_Block || kind == E_Entry || kind == E_Entry_Family + || kind == E_Function || kind == E_Generic_Function + || kind == E_Generic_Package || kind == E_Generic_Procedure + || kind == E_Loop || kind == E_Operator || kind == E_Package + || kind == E_Package_Body || kind == E_Procedure + || kind == E_Record_Type || kind == E_Record_Subtype + || kind == E_Subprogram_Body || kind == E_Subprogram_Type) + for (gnat_sub_entity = First_Entity (gnat_entity); + Present (gnat_sub_entity); + gnat_sub_entity = Next_Entity (gnat_sub_entity)) + if (Scope (gnat_sub_entity) == gnat_entity + && gnat_sub_entity != gnat_entity) + mark_out_of_scope (gnat_sub_entity); + + /* Now clear this if it has been defined, but only do so if it isn't + a subprogram or parameter. We could refine this, but it isn't + worth it. If this is statically allocated, it is supposed to + hang around out of cope. */ + if (present_gnu_tree (gnat_entity) && !Is_Statically_Allocated (gnat_entity) + && kind != E_Procedure && kind != E_Function && !IN (kind, Formal_Kind)) + { + save_gnu_tree (gnat_entity, NULL_TREE, true); + save_gnu_tree (gnat_entity, error_mark_node, true); + } +} + +/* Relate the alias sets of GNU_NEW_TYPE and GNU_OLD_TYPE according to OP. + If this is a multi-dimensional array type, do this recursively. + + OP may be + - ALIAS_SET_COPY: the new set is made a copy of the old one. + - ALIAS_SET_SUPERSET: the new set is made a superset of the old one. + - ALIAS_SET_SUBSET: the new set is made a subset of the old one. */ + +static void +relate_alias_sets (tree gnu_new_type, tree gnu_old_type, enum alias_set_op op) +{ + /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case + of a one-dimensional array, since the padding has the same alias set + as the field type, but if it's a multi-dimensional array, we need to + see the inner types. */ + while (TREE_CODE (gnu_old_type) == RECORD_TYPE + && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type) + || TYPE_PADDING_P (gnu_old_type))) + gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type)); + + /* Unconstrained array types are deemed incomplete and would thus be given + alias set 0. Retrieve the underlying array type. */ + if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE) + gnu_old_type + = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type)))); + if (TREE_CODE (gnu_new_type) == UNCONSTRAINED_ARRAY_TYPE) + gnu_new_type + = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_new_type)))); + + if (TREE_CODE (gnu_new_type) == ARRAY_TYPE + && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type))) + relate_alias_sets (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type), op); + + switch (op) + { + case ALIAS_SET_COPY: + /* The alias set shouldn't be copied between array types with different + aliasing settings because this can break the aliasing relationship + between the array type and its element type. */ +#ifndef ENABLE_CHECKING + if (flag_strict_aliasing) +#endif + gcc_assert (!(TREE_CODE (gnu_new_type) == ARRAY_TYPE + && TREE_CODE (gnu_old_type) == ARRAY_TYPE + && TYPE_NONALIASED_COMPONENT (gnu_new_type) + != TYPE_NONALIASED_COMPONENT (gnu_old_type))); + + TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type); + break; + + case ALIAS_SET_SUBSET: + case ALIAS_SET_SUPERSET: + { + alias_set_type old_set = get_alias_set (gnu_old_type); + alias_set_type new_set = get_alias_set (gnu_new_type); + + /* Do nothing if the alias sets conflict. This ensures that we + never call record_alias_subset several times for the same pair + or at all for alias set 0. */ + if (!alias_sets_conflict_p (old_set, new_set)) + { + if (op == ALIAS_SET_SUBSET) + record_alias_subset (old_set, new_set); + else + record_alias_subset (new_set, old_set); + } + } + break; + + default: + gcc_unreachable (); + } + + record_component_aliases (gnu_new_type); +} + +/* Return true if the size represented by GNU_SIZE can be handled by an + allocation. If STATIC_P is true, consider only what can be done with a + static allocation. */ + +static bool +allocatable_size_p (tree gnu_size, bool static_p) +{ + HOST_WIDE_INT our_size; + + /* If this is not a static allocation, the only case we want to forbid + is an overflowing size. That will be converted into a raise a + Storage_Error. */ + if (!static_p) + return !(TREE_CODE (gnu_size) == INTEGER_CST + && TREE_OVERFLOW (gnu_size)); + + /* Otherwise, we need to deal with both variable sizes and constant + sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT + since assemblers may not like very large sizes. */ + if (!host_integerp (gnu_size, 1)) + return false; + + our_size = tree_low_cst (gnu_size, 1); + return (int) our_size == our_size; +} + +/* Prepend to ATTR_LIST an entry for an attribute with provided TYPE, + NAME, ARGS and ERROR_POINT. */ + +static void +prepend_one_attribute_to (struct attrib ** attr_list, + enum attr_type attr_type, + tree attr_name, + tree attr_args, + Node_Id attr_error_point) +{ + struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib)); + + attr->type = attr_type; + attr->name = attr_name; + attr->args = attr_args; + attr->error_point = attr_error_point; + + attr->next = *attr_list; + *attr_list = attr; +} + +/* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */ + +static void +prepend_attributes (Entity_Id gnat_entity, struct attrib ** attr_list) +{ + Node_Id gnat_temp; + + /* Attributes are stored as Representation Item pragmas. */ + + for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp); + gnat_temp = Next_Rep_Item (gnat_temp)) + if (Nkind (gnat_temp) == N_Pragma) + { + tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE; + Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp); + enum attr_type etype; + + /* Map the kind of pragma at hand. Skip if this is not one + we know how to handle. */ + + switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_temp)))) + { + case Pragma_Machine_Attribute: + etype = ATTR_MACHINE_ATTRIBUTE; + break; + + case Pragma_Linker_Alias: + etype = ATTR_LINK_ALIAS; + break; + + case Pragma_Linker_Section: + etype = ATTR_LINK_SECTION; + break; + + case Pragma_Linker_Constructor: + etype = ATTR_LINK_CONSTRUCTOR; + break; + + case Pragma_Linker_Destructor: + etype = ATTR_LINK_DESTRUCTOR; + break; + + case Pragma_Weak_External: + etype = ATTR_WEAK_EXTERNAL; + break; + + case Pragma_Thread_Local_Storage: + etype = ATTR_THREAD_LOCAL_STORAGE; + break; + + default: + continue; + } + + /* See what arguments we have and turn them into GCC trees for + attribute handlers. These expect identifier for strings. We + handle at most two arguments, static expressions only. */ + + if (Present (gnat_assoc) && Present (First (gnat_assoc))) + { + Node_Id gnat_arg0 = Next (First (gnat_assoc)); + Node_Id gnat_arg1 = Empty; + + if (Present (gnat_arg0) + && Is_Static_Expression (Expression (gnat_arg0))) + { + gnu_arg0 = gnat_to_gnu (Expression (gnat_arg0)); + + if (TREE_CODE (gnu_arg0) == STRING_CST) + gnu_arg0 = get_identifier (TREE_STRING_POINTER (gnu_arg0)); + + gnat_arg1 = Next (gnat_arg0); + } + + if (Present (gnat_arg1) + && Is_Static_Expression (Expression (gnat_arg1))) + { + gnu_arg1 = gnat_to_gnu (Expression (gnat_arg1)); + + if (TREE_CODE (gnu_arg1) == STRING_CST) + gnu_arg1 = get_identifier (TREE_STRING_POINTER (gnu_arg1)); + } + } + + /* Prepend to the list now. Make a list of the argument we might + have, as GCC expects it. */ + prepend_one_attribute_to + (attr_list, + etype, gnu_arg0, + (gnu_arg1 != NULL_TREE) + ? build_tree_list (NULL_TREE, gnu_arg1) : NULL_TREE, + Present (Next (First (gnat_assoc))) + ? Expression (Next (First (gnat_assoc))) : gnat_temp); + } +} + +/* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a + type definition (either a bound or a discriminant value) for GNAT_ENTITY, + return the GCC tree to use for that expression. GNU_NAME is the suffix + to use if a variable needs to be created and DEFINITION is true if this + is a definition of GNAT_ENTITY. If NEED_VALUE is true, we need a result; + otherwise, we are just elaborating the expression for side-effects. If + NEED_DEBUG is true, we need a variable for debugging purposes even if it + isn't needed for code generation. */ + +static tree +elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, tree gnu_name, + bool definition, bool need_value, bool need_debug) +{ + tree gnu_expr; + + /* If we already elaborated this expression (e.g. it was involved + in the definition of a private type), use the old value. */ + if (present_gnu_tree (gnat_expr)) + return get_gnu_tree (gnat_expr); + + /* If we don't need a value and this is static or a discriminant, + we don't need to do anything. */ + if (!need_value + && (Is_OK_Static_Expression (gnat_expr) + || (Nkind (gnat_expr) == N_Identifier + && Ekind (Entity (gnat_expr)) == E_Discriminant))) + return NULL_TREE; + + /* If it's a static expression, we don't need a variable for debugging. */ + if (need_debug && Is_OK_Static_Expression (gnat_expr)) + need_debug = false; + + /* Otherwise, convert this tree to its GCC equivalent and elaborate it. */ + gnu_expr = elaborate_expression_1 (gnat_to_gnu (gnat_expr), gnat_entity, + gnu_name, definition, need_debug); + + /* Save the expression in case we try to elaborate this entity again. Since + it's not a DECL, don't check it. Don't save if it's a discriminant. */ + if (!CONTAINS_PLACEHOLDER_P (gnu_expr)) + save_gnu_tree (gnat_expr, gnu_expr, true); + + return need_value ? gnu_expr : error_mark_node; +} + +/* Similar, but take a GNU expression and always return a result. */ + +static tree +elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name, + bool definition, bool need_debug) +{ + /* Skip any conversions and simple arithmetics to see if the expression + is a read-only variable. + ??? This really should remain read-only, but we have to think about + the typing of the tree here. */ + tree gnu_inner_expr + = skip_simple_arithmetic (remove_conversions (gnu_expr, true)); + tree gnu_decl = NULL_TREE; + bool expr_global = Is_Public (gnat_entity) || global_bindings_p (); + bool expr_variable; + + /* In most cases, we won't see a naked FIELD_DECL because a discriminant + reference will have been replaced with a COMPONENT_REF when the type + is being elaborated. However, there are some cases involving child + types where we will. So convert it to a COMPONENT_REF. We hope it + will be at the highest level of the expression in these cases. */ + if (TREE_CODE (gnu_expr) == FIELD_DECL) + gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr), + build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)), + gnu_expr, NULL_TREE); + + /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable + that is read-only, make a variable that is initialized to contain the + bound when the package containing the definition is elaborated. If + this entity is defined at top level and a bound or discriminant value + isn't a constant or a reference to a discriminant, replace the bound + by the variable; otherwise use a SAVE_EXPR if needed. Note that we + rely here on the fact that an expression cannot contain both the + discriminant and some other variable. */ + expr_variable = (!CONSTANT_CLASS_P (gnu_expr) + && !(TREE_CODE (gnu_inner_expr) == VAR_DECL + && (TREE_READONLY (gnu_inner_expr) + || DECL_READONLY_ONCE_ELAB (gnu_inner_expr))) + && !CONTAINS_PLACEHOLDER_P (gnu_expr)); + + /* If GNU_EXPR contains a discriminant, we can't elaborate a variable. */ + if (need_debug && CONTAINS_PLACEHOLDER_P (gnu_expr)) + need_debug = false; + + /* Now create the variable if we need it. */ + if (need_debug || (expr_variable && expr_global)) + gnu_decl + = create_var_decl (create_concat_name (gnat_entity, + IDENTIFIER_POINTER (gnu_name)), + NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, + !need_debug, Is_Public (gnat_entity), + !definition, expr_global, NULL, gnat_entity); + + /* We only need to use this variable if we are in global context since GCC + can do the right thing in the local case. */ + if (expr_global && expr_variable) + return gnu_decl; + + return expr_variable ? gnat_save_expr (gnu_expr) : gnu_expr; +} + +/* Similar, but take an alignment factor and make it explicit in the tree. */ + +static tree +elaborate_expression_2 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name, + bool definition, bool need_debug, unsigned int align) +{ + tree unit_align = size_int (align / BITS_PER_UNIT); + return + size_binop (MULT_EXPR, + elaborate_expression_1 (size_binop (EXACT_DIV_EXPR, + gnu_expr, + unit_align), + gnat_entity, gnu_name, definition, + need_debug), + unit_align); +} + +/* Create a record type that contains a SIZE bytes long field of TYPE with a + starting bit position so that it is aligned to ALIGN bits, and leaving at + least ROOM bytes free before the field. BASE_ALIGN is the alignment the + record is guaranteed to get. */ + +tree +make_aligning_type (tree type, unsigned int align, tree size, + unsigned int base_align, int room) +{ + /* We will be crafting a record type with one field at a position set to be + the next multiple of ALIGN past record'address + room bytes. We use a + record placeholder to express record'address. */ + tree record_type = make_node (RECORD_TYPE); + tree record = build0 (PLACEHOLDER_EXPR, record_type); + + tree record_addr_st + = convert (sizetype, build_unary_op (ADDR_EXPR, NULL_TREE, record)); + + /* The diagram below summarizes the shape of what we manipulate: + + <--------- pos ----------> + { +------------+-------------+-----------------+ + record =>{ |############| ... | field (type) | + { +------------+-------------+-----------------+ + |<-- room -->|<- voffset ->|<---- size ----->| + o o + | | + record_addr vblock_addr + + Every length is in sizetype bytes there, except "pos" which has to be + set as a bit position in the GCC tree for the record. */ + tree room_st = size_int (room); + tree vblock_addr_st = size_binop (PLUS_EXPR, record_addr_st, room_st); + tree voffset_st, pos, field; + + tree name = TYPE_NAME (type); + + if (TREE_CODE (name) == TYPE_DECL) + name = DECL_NAME (name); + name = concat_name (name, "ALIGN"); + TYPE_NAME (record_type) = name; + + /* Compute VOFFSET and then POS. The next byte position multiple of some + alignment after some address is obtained by "and"ing the alignment minus + 1 with the two's complement of the address. */ + voffset_st = size_binop (BIT_AND_EXPR, + fold_build1 (NEGATE_EXPR, sizetype, vblock_addr_st), + size_int ((align / BITS_PER_UNIT) - 1)); + + /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype. */ + pos = size_binop (MULT_EXPR, + convert (bitsizetype, + size_binop (PLUS_EXPR, room_st, voffset_st)), + bitsize_unit_node); + + /* Craft the GCC record representation. We exceptionally do everything + manually here because 1) our generic circuitry is not quite ready to + handle the complex position/size expressions we are setting up, 2) we + have a strong simplifying factor at hand: we know the maximum possible + value of voffset, and 3) we have to set/reset at least the sizes in + accordance with this maximum value anyway, as we need them to convey + what should be "alloc"ated for this type. + + Use -1 as the 'addressable' indication for the field to prevent the + creation of a bitfield. We don't need one, it would have damaging + consequences on the alignment computation, and create_field_decl would + make one without this special argument, for instance because of the + complex position expression. */ + field = create_field_decl (get_identifier ("F"), type, record_type, size, + pos, 1, -1); + TYPE_FIELDS (record_type) = field; + + TYPE_ALIGN (record_type) = base_align; + TYPE_USER_ALIGN (record_type) = 1; + + TYPE_SIZE (record_type) + = size_binop (PLUS_EXPR, + size_binop (MULT_EXPR, convert (bitsizetype, size), + bitsize_unit_node), + bitsize_int (align + room * BITS_PER_UNIT)); + TYPE_SIZE_UNIT (record_type) + = size_binop (PLUS_EXPR, size, + size_int (room + align / BITS_PER_UNIT)); + + SET_TYPE_MODE (record_type, BLKmode); + relate_alias_sets (record_type, type, ALIAS_SET_COPY); + + /* Declare it now since it will never be declared otherwise. This is + necessary to ensure that its subtrees are properly marked. */ + create_type_decl (name, record_type, NULL, true, false, Empty); + + return record_type; +} + +/* Return the result of rounding T up to ALIGN. */ + +static inline unsigned HOST_WIDE_INT +round_up_to_align (unsigned HOST_WIDE_INT t, unsigned int align) +{ + t += align - 1; + t /= align; + t *= align; + return t; +} + +/* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used + as the field type of a packed record if IN_RECORD is true, or as the + component type of a packed array if IN_RECORD is false. See if we can + rewrite it either as a type that has a non-BLKmode, which we can pack + tighter in the packed record case, or as a smaller type. If so, return + the new type. If not, return the original type. */ + +static tree +make_packable_type (tree type, bool in_record) +{ + unsigned HOST_WIDE_INT size = tree_low_cst (TYPE_SIZE (type), 1); + unsigned HOST_WIDE_INT new_size; + tree new_type, old_field, field_list = NULL_TREE; + + /* No point in doing anything if the size is zero. */ + if (size == 0) + return type; + + new_type = make_node (TREE_CODE (type)); + + /* Copy the name and flags from the old type to that of the new. + Note that we rely on the pointer equality created here for + TYPE_NAME to look through conversions in various places. */ + TYPE_NAME (new_type) = TYPE_NAME (type); + TYPE_JUSTIFIED_MODULAR_P (new_type) = TYPE_JUSTIFIED_MODULAR_P (type); + TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type); + if (TREE_CODE (type) == RECORD_TYPE) + TYPE_PADDING_P (new_type) = TYPE_PADDING_P (type); + + /* If we are in a record and have a small size, set the alignment to + try for an integral mode. Otherwise set it to try for a smaller + type with BLKmode. */ + if (in_record && size <= MAX_FIXED_MODE_SIZE) + { + TYPE_ALIGN (new_type) = ceil_alignment (size); + new_size = round_up_to_align (size, TYPE_ALIGN (new_type)); + } + else + { + unsigned HOST_WIDE_INT align; + + /* Do not try to shrink the size if the RM size is not constant. */ + if (TYPE_CONTAINS_TEMPLATE_P (type) + || !host_integerp (TYPE_ADA_SIZE (type), 1)) + return type; + + /* Round the RM size up to a unit boundary to get the minimal size + for a BLKmode record. Give up if it's already the size. */ + new_size = TREE_INT_CST_LOW (TYPE_ADA_SIZE (type)); + new_size = round_up_to_align (new_size, BITS_PER_UNIT); + if (new_size == size) + return type; + + align = new_size & -new_size; + TYPE_ALIGN (new_type) = MIN (TYPE_ALIGN (type), align); + } + + TYPE_USER_ALIGN (new_type) = 1; + + /* Now copy the fields, keeping the position and size as we don't want + to change the layout by propagating the packedness downwards. */ + for (old_field = TYPE_FIELDS (type); old_field; + old_field = DECL_CHAIN (old_field)) + { + tree new_field_type = TREE_TYPE (old_field); + tree new_field, new_size; + + if ((TREE_CODE (new_field_type) == RECORD_TYPE + || TREE_CODE (new_field_type) == UNION_TYPE + || TREE_CODE (new_field_type) == QUAL_UNION_TYPE) + && !TYPE_FAT_POINTER_P (new_field_type) + && host_integerp (TYPE_SIZE (new_field_type), 1)) + new_field_type = make_packable_type (new_field_type, true); + + /* However, for the last field in a not already packed record type + that is of an aggregate type, we need to use the RM size in the + packable version of the record type, see finish_record_type. */ + if (!DECL_CHAIN (old_field) + && !TYPE_PACKED (type) + && (TREE_CODE (new_field_type) == RECORD_TYPE + || TREE_CODE (new_field_type) == UNION_TYPE + || TREE_CODE (new_field_type) == QUAL_UNION_TYPE) + && !TYPE_FAT_POINTER_P (new_field_type) + && !TYPE_CONTAINS_TEMPLATE_P (new_field_type) + && TYPE_ADA_SIZE (new_field_type)) + new_size = TYPE_ADA_SIZE (new_field_type); + else + new_size = DECL_SIZE (old_field); + + new_field + = create_field_decl (DECL_NAME (old_field), new_field_type, new_type, + new_size, bit_position (old_field), + TYPE_PACKED (type), + !DECL_NONADDRESSABLE_P (old_field)); + + DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field); + SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, old_field); + if (TREE_CODE (new_type) == QUAL_UNION_TYPE) + DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field); + + DECL_CHAIN (new_field) = field_list; + field_list = new_field; + } + + finish_record_type (new_type, nreverse (field_list), 2, false); + relate_alias_sets (new_type, type, ALIAS_SET_COPY); + + /* If this is a padding record, we never want to make the size smaller + than what was specified. For QUAL_UNION_TYPE, also copy the size. */ + if (TYPE_IS_PADDING_P (type) || TREE_CODE (type) == QUAL_UNION_TYPE) + { + TYPE_SIZE (new_type) = TYPE_SIZE (type); + TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type); + new_size = size; + } + else + { + TYPE_SIZE (new_type) = bitsize_int (new_size); + TYPE_SIZE_UNIT (new_type) + = size_int ((new_size + BITS_PER_UNIT - 1) / BITS_PER_UNIT); + } + + if (!TYPE_CONTAINS_TEMPLATE_P (type)) + SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (type)); + + compute_record_mode (new_type); + + /* Try harder to get a packable type if necessary, for example + in case the record itself contains a BLKmode field. */ + if (in_record && TYPE_MODE (new_type) == BLKmode) + SET_TYPE_MODE (new_type, + mode_for_size_tree (TYPE_SIZE (new_type), MODE_INT, 1)); + + /* If neither the mode nor the size has shrunk, return the old type. */ + if (TYPE_MODE (new_type) == BLKmode && new_size >= size) + return type; + + return new_type; +} + +/* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type + if needed. We have already verified that SIZE and TYPE are large enough. + GNAT_ENTITY is used to name the resulting record and to issue a warning. + IS_COMPONENT_TYPE is true if this is being done for the component type + of an array. IS_USER_TYPE is true if we must complete the original type. + DEFINITION is true if this type is being defined. SAME_RM_SIZE is true + if the RM size of the resulting type is to be set to SIZE too; otherwise, + it's set to the RM size of the original type. */ + +tree +maybe_pad_type (tree type, tree size, unsigned int align, + Entity_Id gnat_entity, bool is_component_type, + bool is_user_type, bool definition, bool same_rm_size) +{ + tree orig_rm_size = same_rm_size ? NULL_TREE : rm_size (type); + tree orig_size = TYPE_SIZE (type); + tree record, field; + + /* If TYPE is a padded type, see if it agrees with any size and alignment + we were given. If so, return the original type. Otherwise, strip + off the padding, since we will either be returning the inner type + or repadding it. If no size or alignment is specified, use that of + the original padded type. */ + if (TYPE_IS_PADDING_P (type)) + { + if ((!size + || operand_equal_p (round_up (size, + MAX (align, TYPE_ALIGN (type))), + round_up (TYPE_SIZE (type), + MAX (align, TYPE_ALIGN (type))), + 0)) + && (align == 0 || align == TYPE_ALIGN (type))) + return type; + + if (!size) + size = TYPE_SIZE (type); + if (align == 0) + align = TYPE_ALIGN (type); + + type = TREE_TYPE (TYPE_FIELDS (type)); + orig_size = TYPE_SIZE (type); + } + + /* If the size is either not being changed or is being made smaller (which + is not done here and is only valid for bitfields anyway), show the size + isn't changing. Likewise, clear the alignment if it isn't being + changed. Then return if we aren't doing anything. */ + if (size + && (operand_equal_p (size, orig_size, 0) + || (TREE_CODE (orig_size) == INTEGER_CST + && tree_int_cst_lt (size, orig_size)))) + size = NULL_TREE; + + if (align == TYPE_ALIGN (type)) + align = 0; + + if (align == 0 && !size) + return type; + + /* If requested, complete the original type and give it a name. */ + if (is_user_type) + create_type_decl (get_entity_name (gnat_entity), type, + NULL, !Comes_From_Source (gnat_entity), + !(TYPE_NAME (type) + && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL + && DECL_IGNORED_P (TYPE_NAME (type))), + gnat_entity); + + /* We used to modify the record in place in some cases, but that could + generate incorrect debugging information. So make a new record + type and name. */ + record = make_node (RECORD_TYPE); + TYPE_PADDING_P (record) = 1; + + if (Present (gnat_entity)) + TYPE_NAME (record) = create_concat_name (gnat_entity, "PAD"); + + TYPE_VOLATILE (record) + = Present (gnat_entity) && Treat_As_Volatile (gnat_entity); + + TYPE_ALIGN (record) = align; + TYPE_SIZE (record) = size ? size : orig_size; + TYPE_SIZE_UNIT (record) + = convert (sizetype, + size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record), + bitsize_unit_node)); + + /* If we are changing the alignment and the input type is a record with + BLKmode and a small constant size, try to make a form that has an + integral mode. This might allow the padding record to also have an + integral mode, which will be much more efficient. There is no point + in doing so if a size is specified unless it is also a small constant + size and it is incorrect to do so if we cannot guarantee that the mode + will be naturally aligned since the field must always be addressable. + + ??? This might not always be a win when done for a stand-alone object: + since the nominal and the effective type of the object will now have + different modes, a VIEW_CONVERT_EXPR will be required for converting + between them and it might be hard to overcome afterwards, including + at the RTL level when the stand-alone object is accessed as a whole. */ + if (align != 0 + && TREE_CODE (type) == RECORD_TYPE + && TYPE_MODE (type) == BLKmode + && !TREE_ADDRESSABLE (type) + && TREE_CODE (orig_size) == INTEGER_CST + && !TREE_OVERFLOW (orig_size) + && compare_tree_int (orig_size, MAX_FIXED_MODE_SIZE) <= 0 + && (!size + || (TREE_CODE (size) == INTEGER_CST + && compare_tree_int (size, MAX_FIXED_MODE_SIZE) <= 0))) + { + tree packable_type = make_packable_type (type, true); + if (TYPE_MODE (packable_type) != BLKmode + && align >= TYPE_ALIGN (packable_type)) + type = packable_type; + } + + /* Now create the field with the original size. */ + field = create_field_decl (get_identifier ("F"), type, record, orig_size, + bitsize_zero_node, 0, 1); + DECL_INTERNAL_P (field) = 1; + + /* Do not emit debug info until after the auxiliary record is built. */ + finish_record_type (record, field, 1, false); + + /* Set the same size for its RM size if requested; otherwise reuse + the RM size of the original type. */ + SET_TYPE_ADA_SIZE (record, same_rm_size ? size : orig_rm_size); + + /* Unless debugging information isn't being written for the input type, + write a record that shows what we are a subtype of and also make a + variable that indicates our size, if still variable. */ + if (TREE_CODE (orig_size) != INTEGER_CST + && TYPE_NAME (record) + && TYPE_NAME (type) + && !(TREE_CODE (TYPE_NAME (type)) == TYPE_DECL + && DECL_IGNORED_P (TYPE_NAME (type)))) + { + tree marker = make_node (RECORD_TYPE); + tree name = TYPE_NAME (record); + tree orig_name = TYPE_NAME (type); + + if (TREE_CODE (name) == TYPE_DECL) + name = DECL_NAME (name); + + if (TREE_CODE (orig_name) == TYPE_DECL) + orig_name = DECL_NAME (orig_name); + + TYPE_NAME (marker) = concat_name (name, "XVS"); + finish_record_type (marker, + create_field_decl (orig_name, + build_reference_type (type), + marker, NULL_TREE, NULL_TREE, + 0, 0), + 0, true); + + add_parallel_type (TYPE_STUB_DECL (record), marker); + + if (definition && size && TREE_CODE (size) != INTEGER_CST) + TYPE_SIZE_UNIT (marker) + = create_var_decl (concat_name (name, "XVZ"), NULL_TREE, sizetype, + TYPE_SIZE_UNIT (record), false, false, false, + false, NULL, gnat_entity); + } + + rest_of_record_type_compilation (record); + + /* If the size was widened explicitly, maybe give a warning. Take the + original size as the maximum size of the input if there was an + unconstrained record involved and round it up to the specified alignment, + if one was specified. */ + if (CONTAINS_PLACEHOLDER_P (orig_size)) + orig_size = max_size (orig_size, true); + + if (align) + orig_size = round_up (orig_size, align); + + if (Present (gnat_entity) + && size + && TREE_CODE (size) != MAX_EXPR + && TREE_CODE (size) != COND_EXPR + && !operand_equal_p (size, orig_size, 0) + && !(TREE_CODE (size) == INTEGER_CST + && TREE_CODE (orig_size) == INTEGER_CST + && (TREE_OVERFLOW (size) + || TREE_OVERFLOW (orig_size) + || tree_int_cst_lt (size, orig_size)))) + { + Node_Id gnat_error_node = Empty; + + if (Is_Packed_Array_Type (gnat_entity)) + gnat_entity = Original_Array_Type (gnat_entity); + + if ((Ekind (gnat_entity) == E_Component + || Ekind (gnat_entity) == E_Discriminant) + && Present (Component_Clause (gnat_entity))) + gnat_error_node = Last_Bit (Component_Clause (gnat_entity)); + else if (Present (Size_Clause (gnat_entity))) + gnat_error_node = Expression (Size_Clause (gnat_entity)); + + /* Generate message only for entities that come from source, since + if we have an entity created by expansion, the message will be + generated for some other corresponding source entity. */ + if (Comes_From_Source (gnat_entity)) + { + if (Present (gnat_error_node)) + post_error_ne_tree ("{^ }bits of & unused?", + gnat_error_node, gnat_entity, + size_diffop (size, orig_size)); + else if (is_component_type) + post_error_ne_tree ("component of& padded{ by ^ bits}?", + gnat_entity, gnat_entity, + size_diffop (size, orig_size)); + } + } + + return record; +} + +/* Given a GNU tree and a GNAT list of choices, generate an expression to test + the value passed against the list of choices. */ + +tree +choices_to_gnu (tree operand, Node_Id choices) +{ + Node_Id choice; + Node_Id gnat_temp; + tree result = integer_zero_node; + tree this_test, low = 0, high = 0, single = 0; + + for (choice = First (choices); Present (choice); choice = Next (choice)) + { + switch (Nkind (choice)) + { + case N_Range: + low = gnat_to_gnu (Low_Bound (choice)); + high = gnat_to_gnu (High_Bound (choice)); + + this_test + = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node, + build_binary_op (GE_EXPR, boolean_type_node, + operand, low), + build_binary_op (LE_EXPR, boolean_type_node, + operand, high)); + + break; + + case N_Subtype_Indication: + gnat_temp = Range_Expression (Constraint (choice)); + low = gnat_to_gnu (Low_Bound (gnat_temp)); + high = gnat_to_gnu (High_Bound (gnat_temp)); + + this_test + = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node, + build_binary_op (GE_EXPR, boolean_type_node, + operand, low), + build_binary_op (LE_EXPR, boolean_type_node, + operand, high)); + break; + + case N_Identifier: + case N_Expanded_Name: + /* This represents either a subtype range, an enumeration + literal, or a constant Ekind says which. If an enumeration + literal or constant, fall through to the next case. */ + if (Ekind (Entity (choice)) != E_Enumeration_Literal + && Ekind (Entity (choice)) != E_Constant) + { + tree type = gnat_to_gnu_type (Entity (choice)); + + low = TYPE_MIN_VALUE (type); + high = TYPE_MAX_VALUE (type); + + this_test + = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node, + build_binary_op (GE_EXPR, boolean_type_node, + operand, low), + build_binary_op (LE_EXPR, boolean_type_node, + operand, high)); + break; + } + + /* ... fall through ... */ + + case N_Character_Literal: + case N_Integer_Literal: + single = gnat_to_gnu (choice); + this_test = build_binary_op (EQ_EXPR, boolean_type_node, operand, + single); + break; + + case N_Others_Choice: + this_test = integer_one_node; + break; + + default: + gcc_unreachable (); + } + + result = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, result, + this_test); + } + + return result; +} + +/* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of + type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */ + +static int +adjust_packed (tree field_type, tree record_type, int packed) +{ + /* If the field contains an item of variable size, we cannot pack it + because we cannot create temporaries of non-fixed size in case + we need to take the address of the field. See addressable_p and + the notes on the addressability issues for further details. */ + if (is_variable_size (field_type)) + return 0; + + /* If the alignment of the record is specified and the field type + is over-aligned, request Storage_Unit alignment for the field. */ + if (packed == -2) + { + if (TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type)) + return -1; + else + return 0; + } + + return packed; +} + +/* Return a GCC tree for a field corresponding to GNAT_FIELD to be + placed in GNU_RECORD_TYPE. + + PACKED is 1 if the enclosing record is packed, -1 if the enclosing + record has Component_Alignment of Storage_Unit, -2 if the enclosing + record has a specified alignment. + + DEFINITION is true if this field is for a record being defined. + + DEBUG_INFO_P is true if we need to write debug information for types + that we may create in the process. */ + +static tree +gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, + bool definition, bool debug_info_p) +{ + tree gnu_field_id = get_entity_name (gnat_field); + tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field)); + tree gnu_field, gnu_size, gnu_pos; + bool needs_strict_alignment + = (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field)) + || Treat_As_Volatile (gnat_field)); + + /* If this field requires strict alignment, we cannot pack it because + it would very likely be under-aligned in the record. */ + if (needs_strict_alignment) + packed = 0; + else + packed = adjust_packed (gnu_field_type, gnu_record_type, packed); + + /* If a size is specified, use it. Otherwise, if the record type is packed, + use the official RM size. See "Handling of Type'Size Values" in Einfo + for further details. */ + if (Known_Static_Esize (gnat_field)) + gnu_size = validate_size (Esize (gnat_field), gnu_field_type, + gnat_field, FIELD_DECL, false, true); + else if (packed == 1) + gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type, + gnat_field, FIELD_DECL, false, true); + else + gnu_size = NULL_TREE; + + /* If we have a specified size that is smaller than that of the field's type, + or a position is specified, and the field's type is a record that doesn't + require strict alignment, see if we can get either an integral mode form + of the type or a smaller form. If we can, show a size was specified for + the field if there wasn't one already, so we know to make this a bitfield + and avoid making things wider. + + Changing to an integral mode form is useful when the record is packed as + we can then place the field at a non-byte-aligned position and so achieve + tighter packing. This is in addition required if the field shares a byte + with another field and the front-end lets the back-end handle the access + to the field, because GCC cannot handle non-byte-aligned BLKmode fields. + + Changing to a smaller form is required if the specified size is smaller + than that of the field's type and the type contains sub-fields that are + padded, in order to avoid generating accesses to these sub-fields that + are wider than the field. + + We avoid the transformation if it is not required or potentially useful, + as it might entail an increase of the field's alignment and have ripple + effects on the outer record type. A typical case is a field known to be + byte-aligned and not to share a byte with another field. */ + if (!needs_strict_alignment + && TREE_CODE (gnu_field_type) == RECORD_TYPE + && !TYPE_FAT_POINTER_P (gnu_field_type) + && host_integerp (TYPE_SIZE (gnu_field_type), 1) + && (packed == 1 + || (gnu_size + && (tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type)) + || (Present (Component_Clause (gnat_field)) + && !(UI_To_Int (Component_Bit_Offset (gnat_field)) + % BITS_PER_UNIT == 0 + && value_factor_p (gnu_size, BITS_PER_UNIT))))))) + { + tree gnu_packable_type = make_packable_type (gnu_field_type, true); + if (gnu_packable_type != gnu_field_type) + { + gnu_field_type = gnu_packable_type; + if (!gnu_size) + gnu_size = rm_size (gnu_field_type); + } + } + + /* If we are packing the record and the field is BLKmode, round the + size up to a byte boundary. */ + if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size) + gnu_size = round_up (gnu_size, BITS_PER_UNIT); + + if (Present (Component_Clause (gnat_field))) + { + Entity_Id gnat_parent + = Parent_Subtype (Underlying_Type (Scope (gnat_field))); + + gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype); + gnu_size = validate_size (Esize (gnat_field), gnu_field_type, + gnat_field, FIELD_DECL, false, true); + + /* Ensure the position does not overlap with the parent subtype, if there + is one. This test is omitted if the parent of the tagged type has a + full rep clause since, in this case, component clauses are allowed to + overlay the space allocated for the parent type and the front-end has + checked that there are no overlapping components. */ + if (Present (gnat_parent) && !Is_Fully_Repped_Tagged_Type (gnat_parent)) + { + tree gnu_parent = gnat_to_gnu_type (gnat_parent); + + if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST + && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent))) + { + post_error_ne_tree + ("offset of& must be beyond parent{, minimum allowed is ^}", + First_Bit (Component_Clause (gnat_field)), gnat_field, + TYPE_SIZE_UNIT (gnu_parent)); + } + } + + /* If this field needs strict alignment, ensure the record is + sufficiently aligned and that that position and size are + consistent with the alignment. */ + if (needs_strict_alignment) + { + TYPE_ALIGN (gnu_record_type) + = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type)); + + if (gnu_size + && !operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0)) + { + if (Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field))) + post_error_ne_tree + ("atomic field& must be natural size of type{ (^)}", + Last_Bit (Component_Clause (gnat_field)), gnat_field, + TYPE_SIZE (gnu_field_type)); + + else if (Is_Aliased (gnat_field)) + post_error_ne_tree + ("size of aliased field& must be ^ bits", + Last_Bit (Component_Clause (gnat_field)), gnat_field, + TYPE_SIZE (gnu_field_type)); + + else if (Strict_Alignment (Etype (gnat_field))) + post_error_ne_tree + ("size of & with aliased or tagged components not ^ bits", + Last_Bit (Component_Clause (gnat_field)), gnat_field, + TYPE_SIZE (gnu_field_type)); + + gnu_size = NULL_TREE; + } + + if (!integer_zerop (size_binop + (TRUNC_MOD_EXPR, gnu_pos, + bitsize_int (TYPE_ALIGN (gnu_field_type))))) + { + if (Is_Aliased (gnat_field)) + post_error_ne_num + ("position of aliased field& must be multiple of ^ bits", + First_Bit (Component_Clause (gnat_field)), gnat_field, + TYPE_ALIGN (gnu_field_type)); + + else if (Treat_As_Volatile (gnat_field)) + post_error_ne_num + ("position of volatile field& must be multiple of ^ bits", + First_Bit (Component_Clause (gnat_field)), gnat_field, + TYPE_ALIGN (gnu_field_type)); + + else if (Strict_Alignment (Etype (gnat_field))) + post_error_ne_num + ("position of & with aliased or tagged components not multiple of ^ bits", + First_Bit (Component_Clause (gnat_field)), gnat_field, + TYPE_ALIGN (gnu_field_type)); + + else + gcc_unreachable (); + + gnu_pos = NULL_TREE; + } + } + + if (Is_Atomic (gnat_field)) + check_ok_for_atomic (gnu_field_type, gnat_field, false); + } + + /* If the record has rep clauses and this is the tag field, make a rep + clause for it as well. */ + else if (Has_Specified_Layout (Scope (gnat_field)) + && Chars (gnat_field) == Name_uTag) + { + gnu_pos = bitsize_zero_node; + gnu_size = TYPE_SIZE (gnu_field_type); + } + + else + gnu_pos = NULL_TREE; + + /* We need to make the size the maximum for the type if it is + self-referential and an unconstrained type. In that case, we can't + pack the field since we can't make a copy to align it. */ + if (TREE_CODE (gnu_field_type) == RECORD_TYPE + && !gnu_size + && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type)) + && !Is_Constrained (Underlying_Type (Etype (gnat_field)))) + { + gnu_size = max_size (TYPE_SIZE (gnu_field_type), true); + packed = 0; + } + + /* If a size is specified, adjust the field's type to it. */ + if (gnu_size) + { + tree orig_field_type; + + /* If the field's type is justified modular, we would need to remove + the wrapper to (better) meet the layout requirements. However we + can do so only if the field is not aliased to preserve the unique + layout and if the prescribed size is not greater than that of the + packed array to preserve the justification. */ + if (!needs_strict_alignment + && TREE_CODE (gnu_field_type) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type) + && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type)) + <= 0) + gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type)); + + gnu_field_type + = make_type_from_size (gnu_field_type, gnu_size, + Has_Biased_Representation (gnat_field)); + + orig_field_type = gnu_field_type; + gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field, + false, false, definition, true); + + /* If a padding record was made, declare it now since it will never be + declared otherwise. This is necessary to ensure that its subtrees + are properly marked. */ + if (gnu_field_type != orig_field_type + && !DECL_P (TYPE_NAME (gnu_field_type))) + create_type_decl (TYPE_NAME (gnu_field_type), gnu_field_type, NULL, + true, debug_info_p, gnat_field); + } + + /* Otherwise (or if there was an error), don't specify a position. */ + else + gnu_pos = NULL_TREE; + + gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE + || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type)); + + /* Now create the decl for the field. */ + gnu_field + = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type, + gnu_size, gnu_pos, packed, Is_Aliased (gnat_field)); + Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field)); + TREE_THIS_VOLATILE (gnu_field) = Treat_As_Volatile (gnat_field); + + if (Ekind (gnat_field) == E_Discriminant) + DECL_DISCRIMINANT_NUMBER (gnu_field) + = UI_To_gnu (Discriminant_Number (gnat_field), sizetype); + + return gnu_field; +} + +/* Return true if TYPE is a type with variable size, a padding type with a + field of variable size or is a record that has a field such a field. */ + +static bool +is_variable_size (tree type) +{ + tree field; + + if (!TREE_CONSTANT (TYPE_SIZE (type))) + return true; + + if (TYPE_IS_PADDING_P (type) + && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type)))) + return true; + + if (TREE_CODE (type) != RECORD_TYPE + && TREE_CODE (type) != UNION_TYPE + && TREE_CODE (type) != QUAL_UNION_TYPE) + return false; + + for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field)) + if (is_variable_size (TREE_TYPE (field))) + return true; + + return false; +} + +/* qsort comparer for the bit positions of two record components. */ + +static int +compare_field_bitpos (const PTR rt1, const PTR rt2) +{ + const_tree const field1 = * (const_tree const *) rt1; + const_tree const field2 = * (const_tree const *) rt2; + const int ret + = tree_int_cst_compare (bit_position (field1), bit_position (field2)); + + return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2)); +} + +/* Translate and chain the GNAT_COMPONENT_LIST to the GNU_FIELD_LIST, set + the result as the field list of GNU_RECORD_TYPE and finish it up. When + called from gnat_to_gnu_entity during the processing of a record type + definition, the GCC node for the parent, if any, will be the single field + of GNU_RECORD_TYPE and the GCC nodes for the discriminants will be on the + GNU_FIELD_LIST. The other calls to this function are recursive calls for + the component list of a variant and, in this case, GNU_FIELD_LIST is empty. + + PACKED is 1 if this is for a packed record, -1 if this is for a record + with Component_Alignment of Storage_Unit, -2 if this is for a record + with a specified alignment. + + DEFINITION is true if we are defining this record type. + + P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field + with a rep clause is to be added; in this case, that is all that should + be done with such fields. + + CANCEL_ALIGNMENT is true if the alignment should be zeroed before laying + out the record. This means the alignment only serves to force fields to + be bitfields, but not to require the record to be that aligned. This is + used for variants. + + ALL_REP is true if a rep clause is present for all the fields. + + UNCHECKED_UNION is true if we are building this type for a record with a + Pragma Unchecked_Union. + + DEBUG_INFO_P is true if we need to write debug information about the type. + + MAYBE_UNUSED is true if this type may be unused in the end; this doesn't + mean that its contents may be unused as well, but only the container. */ + + +static void +components_to_record (tree gnu_record_type, Node_Id gnat_component_list, + tree gnu_field_list, int packed, bool definition, + tree *p_gnu_rep_list, bool cancel_alignment, + bool all_rep, bool unchecked_union, bool debug_info_p, + bool maybe_unused) +{ + bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type); + bool layout_with_rep = false; + Node_Id component_decl, variant_part; + tree gnu_our_rep_list = NULL_TREE; + tree gnu_field, gnu_next, gnu_last = tree_last (gnu_field_list); + + /* For each component referenced in a component declaration create a GCC + field and add it to the list, skipping pragmas in the GNAT list. */ + if (Present (Component_Items (gnat_component_list))) + for (component_decl + = First_Non_Pragma (Component_Items (gnat_component_list)); + Present (component_decl); + component_decl = Next_Non_Pragma (component_decl)) + { + Entity_Id gnat_field = Defining_Entity (component_decl); + Name_Id gnat_name = Chars (gnat_field); + + /* If present, the _Parent field must have been created as the single + field of the record type. Put it before any other fields. */ + if (gnat_name == Name_uParent) + { + gnu_field = TYPE_FIELDS (gnu_record_type); + gnu_field_list = chainon (gnu_field_list, gnu_field); + } + else + { + gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed, + definition, debug_info_p); + + /* If this is the _Tag field, put it before any other fields. */ + if (gnat_name == Name_uTag) + gnu_field_list = chainon (gnu_field_list, gnu_field); + + /* If this is the _Controller field, put it before the other + fields except for the _Tag or _Parent field. */ + else if (gnat_name == Name_uController && gnu_last) + { + DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last); + DECL_CHAIN (gnu_last) = gnu_field; + } + + /* If this is a regular field, put it after the other fields. */ + else + { + DECL_CHAIN (gnu_field) = gnu_field_list; + gnu_field_list = gnu_field; + if (!gnu_last) + gnu_last = gnu_field; + } + } + + save_gnu_tree (gnat_field, gnu_field, false); + } + + /* At the end of the component list there may be a variant part. */ + variant_part = Variant_Part (gnat_component_list); + + /* We create a QUAL_UNION_TYPE for the variant part since the variants are + mutually exclusive and should go in the same memory. To do this we need + to treat each variant as a record whose elements are created from the + component list for the variant. So here we create the records from the + lists for the variants and put them all into the QUAL_UNION_TYPE. + If this is an Unchecked_Union, we make a UNION_TYPE instead or + use GNU_RECORD_TYPE if there are no fields so far. */ + if (Present (variant_part)) + { + Node_Id gnat_discr = Name (variant_part), variant; + tree gnu_discr = gnat_to_gnu (gnat_discr); + tree gnu_name = TYPE_NAME (gnu_record_type); + tree gnu_var_name + = concat_name (get_identifier (Get_Name_String (Chars (gnat_discr))), + "XVN"); + tree gnu_union_type, gnu_union_name, gnu_union_field; + tree gnu_variant_list = NULL_TREE; + + if (TREE_CODE (gnu_name) == TYPE_DECL) + gnu_name = DECL_NAME (gnu_name); + + gnu_union_name + = concat_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name)); + + /* Reuse an enclosing union if all fields are in the variant part + and there is no representation clause on the record, to match + the layout of C unions. There is an associated check below. */ + if (!gnu_field_list + && TREE_CODE (gnu_record_type) == UNION_TYPE + && !TYPE_PACKED (gnu_record_type)) + gnu_union_type = gnu_record_type; + else + { + gnu_union_type + = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE); + + TYPE_NAME (gnu_union_type) = gnu_union_name; + TYPE_ALIGN (gnu_union_type) = 0; + TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type); + } + + for (variant = First_Non_Pragma (Variants (variant_part)); + Present (variant); + variant = Next_Non_Pragma (variant)) + { + tree gnu_variant_type = make_node (RECORD_TYPE); + tree gnu_inner_name; + tree gnu_qual; + + Get_Variant_Encoding (variant); + gnu_inner_name = get_identifier_with_length (Name_Buffer, Name_Len); + TYPE_NAME (gnu_variant_type) + = concat_name (gnu_union_name, + IDENTIFIER_POINTER (gnu_inner_name)); + + /* Set the alignment of the inner type in case we need to make + inner objects into bitfields, but then clear it out so the + record actually gets only the alignment required. */ + TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type); + TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type); + + /* Similarly, if the outer record has a size specified and all + fields have record rep clauses, we can propagate the size + into the variant part. */ + if (all_rep_and_size) + { + TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type); + TYPE_SIZE_UNIT (gnu_variant_type) + = TYPE_SIZE_UNIT (gnu_record_type); + } + + /* Add the fields into the record type for the variant. Note that + we aren't sure to really use it at this point, see below. */ + components_to_record (gnu_variant_type, Component_List (variant), + NULL_TREE, packed, definition, + &gnu_our_rep_list, !all_rep_and_size, all_rep, + unchecked_union, debug_info_p, true); + + gnu_qual = choices_to_gnu (gnu_discr, Discrete_Choices (variant)); + + Set_Present_Expr (variant, annotate_value (gnu_qual)); + + /* If this is an Unchecked_Union and we have exactly one field, + use this field directly to match the layout of C unions. */ + if (unchecked_union + && TYPE_FIELDS (gnu_variant_type) + && !DECL_CHAIN (TYPE_FIELDS (gnu_variant_type))) + gnu_field = TYPE_FIELDS (gnu_variant_type); + else + { + /* Deal with packedness like in gnat_to_gnu_field. */ + int field_packed + = adjust_packed (gnu_variant_type, gnu_record_type, packed); + + /* Finalize the record type now. We used to throw away + empty records but we no longer do that because we need + them to generate complete debug info for the variant; + otherwise, the union type definition will be lacking + the fields associated with these empty variants. */ + rest_of_record_type_compilation (gnu_variant_type); + create_type_decl (TYPE_NAME (gnu_variant_type), gnu_variant_type, + NULL, true, debug_info_p, gnat_component_list); + + gnu_field + = create_field_decl (gnu_inner_name, gnu_variant_type, + gnu_union_type, + all_rep_and_size + ? TYPE_SIZE (gnu_variant_type) : 0, + all_rep_and_size + ? bitsize_zero_node : 0, + field_packed, 0); + + DECL_INTERNAL_P (gnu_field) = 1; + + if (!unchecked_union) + DECL_QUALIFIER (gnu_field) = gnu_qual; + } + + DECL_CHAIN (gnu_field) = gnu_variant_list; + gnu_variant_list = gnu_field; + } + + /* Only make the QUAL_UNION_TYPE if there are non-empty variants. */ + if (gnu_variant_list) + { + int union_field_packed; + + if (all_rep_and_size) + { + TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type); + TYPE_SIZE_UNIT (gnu_union_type) + = TYPE_SIZE_UNIT (gnu_record_type); + } + + finish_record_type (gnu_union_type, nreverse (gnu_variant_list), + all_rep_and_size ? 1 : 0, debug_info_p); + + /* If GNU_UNION_TYPE is our record type, it means we must have an + Unchecked_Union with no fields. Verify that and, if so, just + return. */ + if (gnu_union_type == gnu_record_type) + { + gcc_assert (unchecked_union + && !gnu_field_list + && !gnu_our_rep_list); + return; + } + + create_type_decl (TYPE_NAME (gnu_union_type), gnu_union_type, + NULL, true, debug_info_p, gnat_component_list); + + /* Deal with packedness like in gnat_to_gnu_field. */ + union_field_packed + = adjust_packed (gnu_union_type, gnu_record_type, packed); + + gnu_union_field + = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type, + all_rep ? TYPE_SIZE (gnu_union_type) : 0, + all_rep ? bitsize_zero_node : 0, + union_field_packed, 0); + + DECL_INTERNAL_P (gnu_union_field) = 1; + DECL_CHAIN (gnu_union_field) = gnu_field_list; + gnu_field_list = gnu_union_field; + } + } + + /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they + do, pull them out and put them into GNU_OUR_REP_LIST. We have to do + this in a separate pass since we want to handle the discriminants but + can't play with them until we've used them in debugging data above. + + ??? If we then reorder them, debugging information will be wrong but + there's nothing that can be done about this at the moment. */ + gnu_last = NULL_TREE; + for (gnu_field = gnu_field_list; gnu_field; gnu_field = gnu_next) + { + gnu_next = DECL_CHAIN (gnu_field); + + if (DECL_FIELD_OFFSET (gnu_field)) + { + if (!gnu_last) + gnu_field_list = gnu_next; + else + DECL_CHAIN (gnu_last) = gnu_next; + + DECL_CHAIN (gnu_field) = gnu_our_rep_list; + gnu_our_rep_list = gnu_field; + } + else + gnu_last = gnu_field; + } + + /* If we have any fields in our rep'ed field list and it is not the case that + all the fields in the record have rep clauses and P_REP_LIST is nonzero, + set it and ignore these fields. */ + if (gnu_our_rep_list && p_gnu_rep_list && !all_rep) + *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list); + + /* Otherwise, sort the fields by bit position and put them into their own + record, before the others, if we also have fields without rep clauses. */ + else if (gnu_our_rep_list) + { + tree gnu_rep_type + = (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type); + int i, len = list_length (gnu_our_rep_list); + tree *gnu_arr = XALLOCAVEC (tree, len); + + for (gnu_field = gnu_our_rep_list, i = 0; + gnu_field; + gnu_field = DECL_CHAIN (gnu_field), i++) + gnu_arr[i] = gnu_field; + + qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos); + + /* Put the fields in the list in order of increasing position, which + means we start from the end. */ + gnu_our_rep_list = NULL_TREE; + for (i = len - 1; i >= 0; i--) + { + DECL_CHAIN (gnu_arr[i]) = gnu_our_rep_list; + gnu_our_rep_list = gnu_arr[i]; + DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type; + } + + if (gnu_field_list) + { + finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, debug_info_p); + gnu_field + = create_field_decl (get_identifier ("REP"), gnu_rep_type, + gnu_record_type, NULL_TREE, NULL_TREE, 0, 1); + DECL_INTERNAL_P (gnu_field) = 1; + gnu_field_list = chainon (gnu_field_list, gnu_field); + } + else + { + layout_with_rep = true; + gnu_field_list = nreverse (gnu_our_rep_list); + } + } + + if (cancel_alignment) + TYPE_ALIGN (gnu_record_type) = 0; + + finish_record_type (gnu_record_type, nreverse (gnu_field_list), + layout_with_rep ? 1 : 0, debug_info_p && !maybe_unused); +} + +/* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be + placed into an Esize, Component_Bit_Offset, or Component_Size value + in the GNAT tree. */ + +static Uint +annotate_value (tree gnu_size) +{ + TCode tcode; + Node_Ref_Or_Val ops[3], ret; + struct tree_int_map **h = NULL; + int i; + + /* See if we've already saved the value for this node. */ + if (EXPR_P (gnu_size)) + { + struct tree_int_map in; + if (!annotate_value_cache) + annotate_value_cache = htab_create_ggc (512, tree_int_map_hash, + tree_int_map_eq, 0); + in.base.from = gnu_size; + h = (struct tree_int_map **) + htab_find_slot (annotate_value_cache, &in, INSERT); + + if (*h) + return (Node_Ref_Or_Val) (*h)->to; + } + + /* If we do not return inside this switch, TCODE will be set to the + code to use for a Create_Node operand and LEN (set above) will be + the number of recursive calls for us to make. */ + + switch (TREE_CODE (gnu_size)) + { + case INTEGER_CST: + if (TREE_OVERFLOW (gnu_size)) + return No_Uint; + + /* This may come from a conversion from some smaller type, so ensure + this is in bitsizetype. */ + gnu_size = convert (bitsizetype, gnu_size); + + /* For a negative value, build NEGATE_EXPR of the opposite. Such values + appear in expressions containing aligning patterns. Note that, since + sizetype is sign-extended but nonetheless unsigned, we don't directly + use tree_int_cst_sgn. */ + if (TREE_INT_CST_HIGH (gnu_size) < 0) + { + tree op_size = fold_build1 (NEGATE_EXPR, bitsizetype, gnu_size); + return annotate_value (build1 (NEGATE_EXPR, bitsizetype, op_size)); + } + + return UI_From_gnu (gnu_size); + + case COMPONENT_REF: + /* The only case we handle here is a simple discriminant reference. */ + if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR + && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL + && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1))) + return Create_Node (Discrim_Val, + annotate_value (DECL_DISCRIMINANT_NUMBER + (TREE_OPERAND (gnu_size, 1))), + No_Uint, No_Uint); + else + return No_Uint; + + CASE_CONVERT: case NON_LVALUE_EXPR: + return annotate_value (TREE_OPERAND (gnu_size, 0)); + + /* Now just list the operations we handle. */ + case COND_EXPR: tcode = Cond_Expr; break; + case PLUS_EXPR: tcode = Plus_Expr; break; + case MINUS_EXPR: tcode = Minus_Expr; break; + case MULT_EXPR: tcode = Mult_Expr; break; + case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break; + case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break; + case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break; + case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break; + case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break; + case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break; + case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break; + case NEGATE_EXPR: tcode = Negate_Expr; break; + case MIN_EXPR: tcode = Min_Expr; break; + case MAX_EXPR: tcode = Max_Expr; break; + case ABS_EXPR: tcode = Abs_Expr; break; + case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break; + case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break; + case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break; + case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break; + case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break; + case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break; + case BIT_AND_EXPR: tcode = Bit_And_Expr; break; + case LT_EXPR: tcode = Lt_Expr; break; + case LE_EXPR: tcode = Le_Expr; break; + case GT_EXPR: tcode = Gt_Expr; break; + case GE_EXPR: tcode = Ge_Expr; break; + case EQ_EXPR: tcode = Eq_Expr; break; + case NE_EXPR: tcode = Ne_Expr; break; + + case CALL_EXPR: + { + tree t = maybe_inline_call_in_expr (gnu_size); + if (t) + return annotate_value (t); + } + + /* Fall through... */ + + default: + return No_Uint; + } + + /* Now get each of the operands that's relevant for this code. If any + cannot be expressed as a repinfo node, say we can't. */ + for (i = 0; i < 3; i++) + ops[i] = No_Uint; + + for (i = 0; i < TREE_CODE_LENGTH (TREE_CODE (gnu_size)); i++) + { + ops[i] = annotate_value (TREE_OPERAND (gnu_size, i)); + if (ops[i] == No_Uint) + return No_Uint; + } + + ret = Create_Node (tcode, ops[0], ops[1], ops[2]); + + /* Save the result in the cache. */ + if (h) + { + *h = ggc_alloc_tree_int_map (); + (*h)->base.from = gnu_size; + (*h)->to = ret; + } + + return ret; +} + +/* Given GNAT_ENTITY, an object (constant, variable, parameter, exception) + and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the + size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null. + BY_REF is true if the object is used by reference and BY_DOUBLE_REF is + true if the object is used by double reference. */ + +void +annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref, + bool by_double_ref) +{ + if (by_ref) + { + if (by_double_ref) + gnu_type = TREE_TYPE (gnu_type); + + if (TYPE_IS_FAT_POINTER_P (gnu_type)) + gnu_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type); + else + gnu_type = TREE_TYPE (gnu_type); + } + + if (Unknown_Esize (gnat_entity)) + { + if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) + size = TYPE_SIZE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)))); + else if (!size) + size = TYPE_SIZE (gnu_type); + + if (size) + Set_Esize (gnat_entity, annotate_value (size)); + } + + if (Unknown_Alignment (gnat_entity)) + Set_Alignment (gnat_entity, + UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT)); +} + +/* Return first element of field list whose TREE_PURPOSE is the same as ELEM. + Return NULL_TREE if there is no such element in the list. */ + +static tree +purpose_member_field (const_tree elem, tree list) +{ + while (list) + { + tree field = TREE_PURPOSE (list); + if (SAME_FIELD_P (field, elem)) + return list; + list = TREE_CHAIN (list); + } + return NULL_TREE; +} + +/* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding GCC type, + set Component_Bit_Offset and Esize of the components to the position and + size used by Gigi. */ + +static void +annotate_rep (Entity_Id gnat_entity, tree gnu_type) +{ + Entity_Id gnat_field; + tree gnu_list; + + /* We operate by first making a list of all fields and their position (we + can get the size easily) and then update all the sizes in the tree. */ + gnu_list + = build_position_list (gnu_type, false, size_zero_node, bitsize_zero_node, + BIGGEST_ALIGNMENT, NULL_TREE); + + for (gnat_field = First_Entity (gnat_entity); + Present (gnat_field); + gnat_field = Next_Entity (gnat_field)) + if (Ekind (gnat_field) == E_Component + || (Ekind (gnat_field) == E_Discriminant + && !Is_Unchecked_Union (Scope (gnat_field)))) + { + tree t = purpose_member_field (gnat_to_gnu_field_decl (gnat_field), + gnu_list); + if (t) + { + tree parent_offset; + + if (type_annotate_only && Is_Tagged_Type (gnat_entity)) + { + /* In this mode the tag and parent components are not + generated, so we add the appropriate offset to each + component. For a component appearing in the current + extension, the offset is the size of the parent. */ + if (Is_Derived_Type (gnat_entity) + && Original_Record_Component (gnat_field) == gnat_field) + parent_offset + = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))), + bitsizetype); + else + parent_offset = bitsize_int (POINTER_SIZE); + } + else + parent_offset = bitsize_zero_node; + + Set_Component_Bit_Offset + (gnat_field, + annotate_value + (size_binop (PLUS_EXPR, + bit_from_pos (TREE_VEC_ELT (TREE_VALUE (t), 0), + TREE_VEC_ELT (TREE_VALUE (t), 2)), + parent_offset))); + + Set_Esize (gnat_field, + annotate_value (DECL_SIZE (TREE_PURPOSE (t)))); + } + else if (Is_Tagged_Type (gnat_entity) && Is_Derived_Type (gnat_entity)) + { + /* If there is no entry, this is an inherited component whose + position is the same as in the parent type. */ + Set_Component_Bit_Offset + (gnat_field, + Component_Bit_Offset (Original_Record_Component (gnat_field))); + + Set_Esize (gnat_field, + Esize (Original_Record_Component (gnat_field))); + } + } +} + +/* Scan all fields in GNU_TYPE and return a TREE_LIST where TREE_PURPOSE is + the FIELD_DECL and TREE_VALUE a TREE_VEC containing the byte position, the + value to be placed into DECL_OFFSET_ALIGN and the bit position. The list + of fields is flattened, except for variant parts if DO_NOT_FLATTEN_VARIANT + is set to true. GNU_POS is to be added to the position, GNU_BITPOS to the + bit position, OFFSET_ALIGN is the present offset alignment. GNU_LIST is a + pre-existing list to be chained to the newly created entries. */ + +static tree +build_position_list (tree gnu_type, bool do_not_flatten_variant, tree gnu_pos, + tree gnu_bitpos, unsigned int offset_align, tree gnu_list) +{ + tree gnu_field; + + for (gnu_field = TYPE_FIELDS (gnu_type); + gnu_field; + gnu_field = DECL_CHAIN (gnu_field)) + { + tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos, + DECL_FIELD_BIT_OFFSET (gnu_field)); + tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos, + DECL_FIELD_OFFSET (gnu_field)); + unsigned int our_offset_align + = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field)); + tree v = make_tree_vec (3); + + TREE_VEC_ELT (v, 0) = gnu_our_offset; + TREE_VEC_ELT (v, 1) = size_int (our_offset_align); + TREE_VEC_ELT (v, 2) = gnu_our_bitpos; + gnu_list = tree_cons (gnu_field, v, gnu_list); + + /* Recurse on internal fields, flattening the nested fields except for + those in the variant part, if requested. */ + if (DECL_INTERNAL_P (gnu_field)) + { + tree gnu_field_type = TREE_TYPE (gnu_field); + if (do_not_flatten_variant + && TREE_CODE (gnu_field_type) == QUAL_UNION_TYPE) + gnu_list + = build_position_list (gnu_field_type, do_not_flatten_variant, + size_zero_node, bitsize_zero_node, + BIGGEST_ALIGNMENT, gnu_list); + else + gnu_list + = build_position_list (gnu_field_type, do_not_flatten_variant, + gnu_our_offset, gnu_our_bitpos, + our_offset_align, gnu_list); + } + } + + return gnu_list; +} + +/* Return a VEC describing the substitutions needed to reflect the + discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE. They can + be in any order. The values in an element of the VEC are in the form + of operands to SUBSTITUTE_IN_EXPR. DEFINITION is true if this is for + a definition of GNAT_SUBTYPE. */ + +static VEC(subst_pair,heap) * +build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition) +{ + VEC(subst_pair,heap) *gnu_vec = NULL; + Entity_Id gnat_discrim; + Node_Id gnat_value; + + for (gnat_discrim = First_Stored_Discriminant (gnat_type), + gnat_value = First_Elmt (Stored_Constraint (gnat_subtype)); + Present (gnat_discrim); + gnat_discrim = Next_Stored_Discriminant (gnat_discrim), + gnat_value = Next_Elmt (gnat_value)) + /* Ignore access discriminants. */ + if (!Is_Access_Type (Etype (Node (gnat_value)))) + { + tree gnu_field = gnat_to_gnu_field_decl (gnat_discrim); + tree replacement = convert (TREE_TYPE (gnu_field), + elaborate_expression + (Node (gnat_value), gnat_subtype, + get_entity_name (gnat_discrim), + definition, true, false)); + subst_pair *s = VEC_safe_push (subst_pair, heap, gnu_vec, NULL); + s->discriminant = gnu_field; + s->replacement = replacement; + } + + return gnu_vec; +} + +/* Scan all fields in QUAL_UNION_TYPE and return a VEC describing the + variants of QUAL_UNION_TYPE that are still relevant after applying + the substitutions described in SUBST_LIST. VARIANT_LIST is a + pre-existing VEC onto which newly created entries should be + pushed. */ + +static VEC(variant_desc,heap) * +build_variant_list (tree qual_union_type, VEC(subst_pair,heap) *subst_list, + VEC(variant_desc,heap) *variant_list) +{ + tree gnu_field; + + for (gnu_field = TYPE_FIELDS (qual_union_type); + gnu_field; + gnu_field = DECL_CHAIN (gnu_field)) + { + tree qual = DECL_QUALIFIER (gnu_field); + unsigned ix; + subst_pair *s; + + FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s) + qual = SUBSTITUTE_IN_EXPR (qual, s->discriminant, s->replacement); + + /* If the new qualifier is not unconditionally false, its variant may + still be accessed. */ + if (!integer_zerop (qual)) + { + variant_desc *v; + tree variant_type = TREE_TYPE (gnu_field), variant_subpart; + + v = VEC_safe_push (variant_desc, heap, variant_list, NULL); + v->type = variant_type; + v->field = gnu_field; + v->qual = qual; + v->new_type = NULL_TREE; + + /* Recurse on the variant subpart of the variant, if any. */ + variant_subpart = get_variant_part (variant_type); + if (variant_subpart) + variant_list = build_variant_list (TREE_TYPE (variant_subpart), + subst_list, variant_list); + + /* If the new qualifier is unconditionally true, the subsequent + variants cannot be accessed. */ + if (integer_onep (qual)) + break; + } + } + + return variant_list; +} + +/* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE + corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding + to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying + the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL + for the size of a field. COMPONENT_P is true if we are being called + to process the Component_Size of GNAT_OBJECT. This is used for error + message handling and to indicate to use the object size of GNU_TYPE. + ZERO_OK is true if a size of zero is permitted; if ZERO_OK is false, + it means that a size of zero should be treated as an unspecified size. */ + +static tree +validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object, + enum tree_code kind, bool component_p, bool zero_ok) +{ + Node_Id gnat_error_node; + tree type_size, size; + + /* Return 0 if no size was specified. */ + if (uint_size == No_Uint) + return NULL_TREE; + + /* Ignore a negative size since that corresponds to our back-annotation. */ + if (UI_Lt (uint_size, Uint_0)) + return NULL_TREE; + + /* Find the node to use for errors. */ + if ((Ekind (gnat_object) == E_Component + || Ekind (gnat_object) == E_Discriminant) + && Present (Component_Clause (gnat_object))) + gnat_error_node = Last_Bit (Component_Clause (gnat_object)); + else if (Present (Size_Clause (gnat_object))) + gnat_error_node = Expression (Size_Clause (gnat_object)); + else + gnat_error_node = gnat_object; + + /* Get the size as a tree. Issue an error if a size was specified but + cannot be represented in sizetype. */ + size = UI_To_gnu (uint_size, bitsizetype); + if (TREE_OVERFLOW (size)) + { + if (component_p) + post_error_ne ("component size of & is too large", gnat_error_node, + gnat_object); + else + post_error_ne ("size of & is too large", gnat_error_node, + gnat_object); + return NULL_TREE; + } + + /* Ignore a zero size if it is not permitted. */ + if (!zero_ok && integer_zerop (size)) + return NULL_TREE; + + /* The size of objects is always a multiple of a byte. */ + if (kind == VAR_DECL + && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node))) + { + if (component_p) + post_error_ne ("component size for& is not a multiple of Storage_Unit", + gnat_error_node, gnat_object); + else + post_error_ne ("size for& is not a multiple of Storage_Unit", + gnat_error_node, gnat_object); + return NULL_TREE; + } + + /* If this is an integral type or a packed array type, the front-end has + verified the size, so we need not do it here (which would entail + checking against the bounds). However, if this is an aliased object, + it may not be smaller than the type of the object. */ + if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type)) + && !(kind == VAR_DECL && Is_Aliased (gnat_object))) + return size; + + /* If the object is a record that contains a template, add the size of + the template to the specified size. */ + if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) + size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size); + + if (kind == VAR_DECL + /* If a type needs strict alignment, a component of this type in + a packed record cannot be packed and thus uses the type size. */ + || (kind == TYPE_DECL && Strict_Alignment (gnat_object))) + type_size = TYPE_SIZE (gnu_type); + else + type_size = rm_size (gnu_type); + + /* Modify the size of the type to be that of the maximum size if it has a + discriminant. */ + if (type_size && CONTAINS_PLACEHOLDER_P (type_size)) + type_size = max_size (type_size, true); + + /* If this is an access type or a fat pointer, the minimum size is that given + by the smallest integral mode that's valid for pointers. */ + if (TREE_CODE (gnu_type) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (gnu_type)) + { + enum machine_mode p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT); + while (!targetm.valid_pointer_mode (p_mode)) + p_mode = GET_MODE_WIDER_MODE (p_mode); + type_size = bitsize_int (GET_MODE_BITSIZE (p_mode)); + } + + /* If the size of the object is a constant, the new size must not be + smaller. */ + if (TREE_CODE (type_size) != INTEGER_CST + || TREE_OVERFLOW (type_size) + || tree_int_cst_lt (size, type_size)) + { + if (component_p) + post_error_ne_tree + ("component size for& too small{, minimum allowed is ^}", + gnat_error_node, gnat_object, type_size); + else + post_error_ne_tree + ("size for& too small{, minimum allowed is ^}", + gnat_error_node, gnat_object, type_size); + + size = NULL_TREE; + } + + return size; +} + +/* Similarly, but both validate and process a value of RM size. This + routine is only called for types. */ + +static void +set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity) +{ + Node_Id gnat_attr_node; + tree old_size, size; + + /* Do nothing if no size was specified. */ + if (uint_size == No_Uint) + return; + + /* Ignore a negative size since that corresponds to our back-annotation. */ + if (UI_Lt (uint_size, Uint_0)) + return; + + /* Only issue an error if a Value_Size clause was explicitly given. + Otherwise, we'd be duplicating an error on the Size clause. */ + gnat_attr_node + = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size); + + /* Get the size as a tree. Issue an error if a size was specified but + cannot be represented in sizetype. */ + size = UI_To_gnu (uint_size, bitsizetype); + if (TREE_OVERFLOW (size)) + { + if (Present (gnat_attr_node)) + post_error_ne ("Value_Size of & is too large", gnat_attr_node, + gnat_entity); + return; + } + + /* Ignore a zero size unless a Value_Size clause exists, or a size clause + exists, or this is an integer type, in which case the front-end will + have always set it. */ + if (No (gnat_attr_node) + && integer_zerop (size) + && !Has_Size_Clause (gnat_entity) + && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity)) + return; + + old_size = rm_size (gnu_type); + + /* If the old size is self-referential, get the maximum size. */ + if (CONTAINS_PLACEHOLDER_P (old_size)) + old_size = max_size (old_size, true); + + /* If the size of the object is a constant, the new size must not be smaller + (the front-end has verified this for scalar and packed array types). */ + if (TREE_CODE (old_size) != INTEGER_CST + || TREE_OVERFLOW (old_size) + || (AGGREGATE_TYPE_P (gnu_type) + && !(TREE_CODE (gnu_type) == ARRAY_TYPE + && TYPE_PACKED_ARRAY_TYPE_P (gnu_type)) + && !(TYPE_IS_PADDING_P (gnu_type) + && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) == ARRAY_TYPE + && TYPE_PACKED_ARRAY_TYPE_P + (TREE_TYPE (TYPE_FIELDS (gnu_type)))) + && tree_int_cst_lt (size, old_size))) + { + if (Present (gnat_attr_node)) + post_error_ne_tree + ("Value_Size for& too small{, minimum allowed is ^}", + gnat_attr_node, gnat_entity, old_size); + return; + } + + /* Otherwise, set the RM size proper for integral types... */ + if ((TREE_CODE (gnu_type) == INTEGER_TYPE + && Is_Discrete_Or_Fixed_Point_Type (gnat_entity)) + || (TREE_CODE (gnu_type) == ENUMERAL_TYPE + || TREE_CODE (gnu_type) == BOOLEAN_TYPE)) + SET_TYPE_RM_SIZE (gnu_type, size); + + /* ...or the Ada size for record and union types. */ + else if ((TREE_CODE (gnu_type) == RECORD_TYPE + || TREE_CODE (gnu_type) == UNION_TYPE + || TREE_CODE (gnu_type) == QUAL_UNION_TYPE) + && !TYPE_FAT_POINTER_P (gnu_type)) + SET_TYPE_ADA_SIZE (gnu_type, size); +} + +/* Given a type TYPE, return a new type whose size is appropriate for SIZE. + If TYPE is the best type, return it. Otherwise, make a new type. We + only support new integral and pointer types. FOR_BIASED is true if + we are making a biased type. */ + +static tree +make_type_from_size (tree type, tree size_tree, bool for_biased) +{ + unsigned HOST_WIDE_INT size; + bool biased_p; + tree new_type; + + /* If size indicates an error, just return TYPE to avoid propagating + the error. Likewise if it's too large to represent. */ + if (!size_tree || !host_integerp (size_tree, 1)) + return type; + + size = tree_low_cst (size_tree, 1); + + switch (TREE_CODE (type)) + { + case INTEGER_TYPE: + case ENUMERAL_TYPE: + case BOOLEAN_TYPE: + biased_p = (TREE_CODE (type) == INTEGER_TYPE + && TYPE_BIASED_REPRESENTATION_P (type)); + + /* Integer types with precision 0 are forbidden. */ + if (size == 0) + size = 1; + + /* Only do something if the type is not a packed array type and + doesn't already have the proper size. */ + if (TYPE_PACKED_ARRAY_TYPE_P (type) + || (TYPE_PRECISION (type) == size && biased_p == for_biased)) + break; + + biased_p |= for_biased; + if (size > LONG_LONG_TYPE_SIZE) + size = LONG_LONG_TYPE_SIZE; + + if (TYPE_UNSIGNED (type) || biased_p) + new_type = make_unsigned_type (size); + else + new_type = make_signed_type (size); + TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type; + SET_TYPE_RM_MIN_VALUE (new_type, + convert (TREE_TYPE (new_type), + TYPE_MIN_VALUE (type))); + SET_TYPE_RM_MAX_VALUE (new_type, + convert (TREE_TYPE (new_type), + TYPE_MAX_VALUE (type))); + /* Copy the name to show that it's essentially the same type and + not a subrange type. */ + TYPE_NAME (new_type) = TYPE_NAME (type); + TYPE_BIASED_REPRESENTATION_P (new_type) = biased_p; + SET_TYPE_RM_SIZE (new_type, bitsize_int (size)); + return new_type; + + case RECORD_TYPE: + /* Do something if this is a fat pointer, in which case we + may need to return the thin pointer. */ + if (TYPE_FAT_POINTER_P (type) && size < POINTER_SIZE * 2) + { + enum machine_mode p_mode = mode_for_size (size, MODE_INT, 0); + if (!targetm.valid_pointer_mode (p_mode)) + p_mode = ptr_mode; + return + build_pointer_type_for_mode + (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)), + p_mode, 0); + } + break; + + case POINTER_TYPE: + /* Only do something if this is a thin pointer, in which case we + may need to return the fat pointer. */ + if (TYPE_IS_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2) + return + build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))); + break; + + default: + break; + } + + return type; +} + +/* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY, + a type or object whose present alignment is ALIGN. If this alignment is + valid, return it. Otherwise, give an error and return ALIGN. */ + +static unsigned int +validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align) +{ + unsigned int max_allowed_alignment = get_target_maximum_allowed_alignment (); + unsigned int new_align; + Node_Id gnat_error_node; + + /* Don't worry about checking alignment if alignment was not specified + by the source program and we already posted an error for this entity. */ + if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity)) + return align; + + /* Post the error on the alignment clause if any. Note, for the implicit + base type of an array type, the alignment clause is on the first + subtype. */ + if (Present (Alignment_Clause (gnat_entity))) + gnat_error_node = Expression (Alignment_Clause (gnat_entity)); + + else if (Is_Itype (gnat_entity) + && Is_Array_Type (gnat_entity) + && Etype (gnat_entity) == gnat_entity + && Present (Alignment_Clause (First_Subtype (gnat_entity)))) + gnat_error_node = + Expression (Alignment_Clause (First_Subtype (gnat_entity))); + + else + gnat_error_node = gnat_entity; + + /* Within GCC, an alignment is an integer, so we must make sure a value is + specified that fits in that range. Also, there is an upper bound to + alignments we can support/allow. */ + if (!UI_Is_In_Int_Range (alignment) + || ((new_align = UI_To_Int (alignment)) > max_allowed_alignment)) + post_error_ne_num ("largest supported alignment for& is ^", + gnat_error_node, gnat_entity, max_allowed_alignment); + else if (!(Present (Alignment_Clause (gnat_entity)) + && From_At_Mod (Alignment_Clause (gnat_entity))) + && new_align * BITS_PER_UNIT < align) + { + unsigned int double_align; + bool is_capped_double, align_clause; + + /* If the default alignment of "double" or larger scalar types is + specifically capped and the new alignment is above the cap, do + not post an error and change the alignment only if there is an + alignment clause; this makes it possible to have the associated + GCC type overaligned by default for performance reasons. */ + if ((double_align = double_float_alignment) > 0) + { + Entity_Id gnat_type + = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity); + is_capped_double + = is_double_float_or_array (gnat_type, &align_clause); + } + else if ((double_align = double_scalar_alignment) > 0) + { + Entity_Id gnat_type + = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity); + is_capped_double + = is_double_scalar_or_array (gnat_type, &align_clause); + } + else + is_capped_double = align_clause = false; + + if (is_capped_double && new_align >= double_align) + { + if (align_clause) + align = new_align * BITS_PER_UNIT; + } + else + { + if (is_capped_double) + align = double_align * BITS_PER_UNIT; + + post_error_ne_num ("alignment for& must be at least ^", + gnat_error_node, gnat_entity, + align / BITS_PER_UNIT); + } + } + else + { + new_align = (new_align > 0 ? new_align * BITS_PER_UNIT : 1); + if (new_align > align) + align = new_align; + } + + return align; +} + +/* Return the smallest alignment not less than SIZE. */ + +static unsigned int +ceil_alignment (unsigned HOST_WIDE_INT size) +{ + return (unsigned int) 1 << (floor_log2 (size - 1) + 1); +} + +/* Verify that OBJECT, a type or decl, is something we can implement + atomically. If not, give an error for GNAT_ENTITY. COMP_P is true + if we require atomic components. */ + +static void +check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p) +{ + Node_Id gnat_error_point = gnat_entity; + Node_Id gnat_node; + enum machine_mode mode; + unsigned int align; + tree size; + + /* There are three case of what OBJECT can be. It can be a type, in which + case we take the size, alignment and mode from the type. It can be a + declaration that was indirect, in which case the relevant values are + that of the type being pointed to, or it can be a normal declaration, + in which case the values are of the decl. The code below assumes that + OBJECT is either a type or a decl. */ + if (TYPE_P (object)) + { + /* If this is an anonymous base type, nothing to check. Error will be + reported on the source type. */ + if (!Comes_From_Source (gnat_entity)) + return; + + mode = TYPE_MODE (object); + align = TYPE_ALIGN (object); + size = TYPE_SIZE (object); + } + else if (DECL_BY_REF_P (object)) + { + mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object))); + align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object))); + size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object))); + } + else + { + mode = DECL_MODE (object); + align = DECL_ALIGN (object); + size = DECL_SIZE (object); + } + + /* Consider all floating-point types atomic and any types that that are + represented by integers no wider than a machine word. */ + if (GET_MODE_CLASS (mode) == MODE_FLOAT + || ((GET_MODE_CLASS (mode) == MODE_INT + || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT) + && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD)) + return; + + /* For the moment, also allow anything that has an alignment equal + to its size and which is smaller than a word. */ + if (size && TREE_CODE (size) == INTEGER_CST + && compare_tree_int (size, align) == 0 + && align <= BITS_PER_WORD) + return; + + for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node); + gnat_node = Next_Rep_Item (gnat_node)) + { + if (!comp_p && Nkind (gnat_node) == N_Pragma + && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node))) + == Pragma_Atomic)) + gnat_error_point = First (Pragma_Argument_Associations (gnat_node)); + else if (comp_p && Nkind (gnat_node) == N_Pragma + && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node))) + == Pragma_Atomic_Components)) + gnat_error_point = First (Pragma_Argument_Associations (gnat_node)); + } + + if (comp_p) + post_error_ne ("atomic access to component of & cannot be guaranteed", + gnat_error_point, gnat_entity); + else + post_error_ne ("atomic access to & cannot be guaranteed", + gnat_error_point, gnat_entity); +} + + +/* Helper for the intrin compatibility checks family. Evaluate whether + two types are definitely incompatible. */ + +static bool +intrin_types_incompatible_p (tree t1, tree t2) +{ + enum tree_code code; + + if (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2)) + return false; + + if (TYPE_MODE (t1) != TYPE_MODE (t2)) + return true; + + if (TREE_CODE (t1) != TREE_CODE (t2)) + return true; + + code = TREE_CODE (t1); + + switch (code) + { + case INTEGER_TYPE: + case REAL_TYPE: + return TYPE_PRECISION (t1) != TYPE_PRECISION (t2); + + case POINTER_TYPE: + case REFERENCE_TYPE: + /* Assume designated types are ok. We'd need to account for char * and + void * variants to do better, which could rapidly get messy and isn't + clearly worth the effort. */ + return false; + + default: + break; + } + + return false; +} + +/* Helper for intrin_profiles_compatible_p, to perform compatibility checks + on the Ada/builtin argument lists for the INB binding. */ + +static bool +intrin_arglists_compatible_p (intrin_binding_t * inb) +{ + tree ada_args = TYPE_ARG_TYPES (inb->ada_fntype); + tree btin_args = TYPE_ARG_TYPES (inb->btin_fntype); + + /* Sequence position of the last argument we checked. */ + int argpos = 0; + + while (ada_args != 0 || btin_args != 0) + { + tree ada_type, btin_type; + + /* If one list is shorter than the other, they fail to match. */ + if (ada_args == 0 || btin_args == 0) + return false; + + ada_type = TREE_VALUE (ada_args); + btin_type = TREE_VALUE (btin_args); + + /* If we're done with the Ada args and not with the internal builtin + args, or the other way around, complain. */ + if (ada_type == void_type_node + && btin_type != void_type_node) + { + post_error ("?Ada arguments list too short!", inb->gnat_entity); + return false; + } + + if (btin_type == void_type_node + && ada_type != void_type_node) + { + post_error_ne_num ("?Ada arguments list too long ('> ^)!", + inb->gnat_entity, inb->gnat_entity, argpos); + return false; + } + + /* Otherwise, check that types match for the current argument. */ + argpos ++; + if (intrin_types_incompatible_p (ada_type, btin_type)) + { + post_error_ne_num ("?intrinsic binding type mismatch on argument ^!", + inb->gnat_entity, inb->gnat_entity, argpos); + return false; + } + + ada_args = TREE_CHAIN (ada_args); + btin_args = TREE_CHAIN (btin_args); + } + + return true; +} + +/* Helper for intrin_profiles_compatible_p, to perform compatibility checks + on the Ada/builtin return values for the INB binding. */ + +static bool +intrin_return_compatible_p (intrin_binding_t * inb) +{ + tree ada_return_type = TREE_TYPE (inb->ada_fntype); + tree btin_return_type = TREE_TYPE (inb->btin_fntype); + + /* Accept function imported as procedure, common and convenient. */ + if (VOID_TYPE_P (ada_return_type) + && !VOID_TYPE_P (btin_return_type)) + return true; + + /* Check return types compatibility otherwise. Note that this + handles void/void as well. */ + if (intrin_types_incompatible_p (btin_return_type, ada_return_type)) + { + post_error ("?intrinsic binding type mismatch on return value!", + inb->gnat_entity); + return false; + } + + return true; +} + +/* Check and return whether the Ada and gcc builtin profiles bound by INB are + compatible. Issue relevant warnings when they are not. + + This is intended as a light check to diagnose the most obvious cases, not + as a full fledged type compatibility predicate. It is the programmer's + responsibility to ensure correctness of the Ada declarations in Imports, + especially when binding straight to a compiler internal. */ + +static bool +intrin_profiles_compatible_p (intrin_binding_t * inb) +{ + /* Check compatibility on return values and argument lists, each responsible + for posting warnings as appropriate. Ensure use of the proper sloc for + this purpose. */ + + bool arglists_compatible_p, return_compatible_p; + location_t saved_location = input_location; + + Sloc_to_locus (Sloc (inb->gnat_entity), &input_location); + + return_compatible_p = intrin_return_compatible_p (inb); + arglists_compatible_p = intrin_arglists_compatible_p (inb); + + input_location = saved_location; + + return return_compatible_p && arglists_compatible_p; +} + +/* Return a FIELD_DECL node modeled on OLD_FIELD. FIELD_TYPE is its type + and RECORD_TYPE is the type of the parent. If SIZE is nonzero, it is the + specified size for this field. POS_LIST is a position list describing + the layout of OLD_FIELD and SUBST_LIST a substitution list to be applied + to this layout. */ + +static tree +create_field_decl_from (tree old_field, tree field_type, tree record_type, + tree size, tree pos_list, + VEC(subst_pair,heap) *subst_list) +{ + tree t = TREE_VALUE (purpose_member (old_field, pos_list)); + tree pos = TREE_VEC_ELT (t, 0), bitpos = TREE_VEC_ELT (t, 2); + unsigned int offset_align = tree_low_cst (TREE_VEC_ELT (t, 1), 1); + tree new_pos, new_field; + unsigned ix; + subst_pair *s; + + if (CONTAINS_PLACEHOLDER_P (pos)) + FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s) + pos = SUBSTITUTE_IN_EXPR (pos, s->discriminant, s->replacement); + + /* If the position is now a constant, we can set it as the position of the + field when we make it. Otherwise, we need to deal with it specially. */ + if (TREE_CONSTANT (pos)) + new_pos = bit_from_pos (pos, bitpos); + else + new_pos = NULL_TREE; + + new_field + = create_field_decl (DECL_NAME (old_field), field_type, record_type, + size, new_pos, DECL_PACKED (old_field), + !DECL_NONADDRESSABLE_P (old_field)); + + if (!new_pos) + { + normalize_offset (&pos, &bitpos, offset_align); + DECL_FIELD_OFFSET (new_field) = pos; + DECL_FIELD_BIT_OFFSET (new_field) = bitpos; + SET_DECL_OFFSET_ALIGN (new_field, offset_align); + DECL_SIZE (new_field) = size; + DECL_SIZE_UNIT (new_field) + = convert (sizetype, + size_binop (CEIL_DIV_EXPR, size, bitsize_unit_node)); + layout_decl (new_field, DECL_OFFSET_ALIGN (new_field)); + } + + DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field); + SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, old_field); + DECL_DISCRIMINANT_NUMBER (new_field) = DECL_DISCRIMINANT_NUMBER (old_field); + TREE_THIS_VOLATILE (new_field) = TREE_THIS_VOLATILE (old_field); + + return new_field; +} + +/* Return the REP part of RECORD_TYPE, if any. Otherwise return NULL. */ + +static tree +get_rep_part (tree record_type) +{ + tree field = TYPE_FIELDS (record_type); + + /* The REP part is the first field, internal, another record, and its name + doesn't start with an underscore (i.e. is not generated by the FE). */ + if (DECL_INTERNAL_P (field) + && TREE_CODE (TREE_TYPE (field)) == RECORD_TYPE + && IDENTIFIER_POINTER (DECL_NAME (field)) [0] != '_') + return field; + + return NULL_TREE; +} + +/* Return the variant part of RECORD_TYPE, if any. Otherwise return NULL. */ + +tree +get_variant_part (tree record_type) +{ + tree field; + + /* The variant part is the only internal field that is a qualified union. */ + for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field)) + if (DECL_INTERNAL_P (field) + && TREE_CODE (TREE_TYPE (field)) == QUAL_UNION_TYPE) + return field; + + return NULL_TREE; +} + +/* Return a new variant part modeled on OLD_VARIANT_PART. VARIANT_LIST is + the list of variants to be used and RECORD_TYPE is the type of the parent. + POS_LIST is a position list describing the layout of fields present in + OLD_VARIANT_PART and SUBST_LIST a substitution list to be applied to this + layout. */ + +static tree +create_variant_part_from (tree old_variant_part, + VEC(variant_desc,heap) *variant_list, + tree record_type, tree pos_list, + VEC(subst_pair,heap) *subst_list) +{ + tree offset = DECL_FIELD_OFFSET (old_variant_part); + tree old_union_type = TREE_TYPE (old_variant_part); + tree new_union_type, new_variant_part; + tree union_field_list = NULL_TREE; + variant_desc *v; + unsigned ix; + + /* First create the type of the variant part from that of the old one. */ + new_union_type = make_node (QUAL_UNION_TYPE); + TYPE_NAME (new_union_type) + = concat_name (TYPE_NAME (record_type), + IDENTIFIER_POINTER (DECL_NAME (old_variant_part))); + + /* If the position of the variant part is constant, subtract it from the + size of the type of the parent to get the new size. This manual CSE + reduces the code size when not optimizing. */ + if (TREE_CODE (offset) == INTEGER_CST) + { + tree bitpos = DECL_FIELD_BIT_OFFSET (old_variant_part); + tree first_bit = bit_from_pos (offset, bitpos); + TYPE_SIZE (new_union_type) + = size_binop (MINUS_EXPR, TYPE_SIZE (record_type), first_bit); + TYPE_SIZE_UNIT (new_union_type) + = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (record_type), + byte_from_pos (offset, bitpos)); + SET_TYPE_ADA_SIZE (new_union_type, + size_binop (MINUS_EXPR, TYPE_ADA_SIZE (record_type), + first_bit)); + TYPE_ALIGN (new_union_type) = TYPE_ALIGN (old_union_type); + relate_alias_sets (new_union_type, old_union_type, ALIAS_SET_COPY); + } + else + copy_and_substitute_in_size (new_union_type, old_union_type, subst_list); + + /* Now finish up the new variants and populate the union type. */ + FOR_EACH_VEC_ELT_REVERSE (variant_desc, variant_list, ix, v) + { + tree old_field = v->field, new_field; + tree old_variant, old_variant_subpart, new_variant, field_list; + + /* Skip variants that don't belong to this nesting level. */ + if (DECL_CONTEXT (old_field) != old_union_type) + continue; + + /* Retrieve the list of fields already added to the new variant. */ + new_variant = v->new_type; + field_list = TYPE_FIELDS (new_variant); + + /* If the old variant had a variant subpart, we need to create a new + variant subpart and add it to the field list. */ + old_variant = v->type; + old_variant_subpart = get_variant_part (old_variant); + if (old_variant_subpart) + { + tree new_variant_subpart + = create_variant_part_from (old_variant_subpart, variant_list, + new_variant, pos_list, subst_list); + DECL_CHAIN (new_variant_subpart) = field_list; + field_list = new_variant_subpart; + } + + /* Finish up the new variant and create the field. No need for debug + info thanks to the XVS type. */ + finish_record_type (new_variant, nreverse (field_list), 2, false); + compute_record_mode (new_variant); + create_type_decl (TYPE_NAME (new_variant), new_variant, NULL, + true, false, Empty); + + new_field + = create_field_decl_from (old_field, new_variant, new_union_type, + TYPE_SIZE (new_variant), + pos_list, subst_list); + DECL_QUALIFIER (new_field) = v->qual; + DECL_INTERNAL_P (new_field) = 1; + DECL_CHAIN (new_field) = union_field_list; + union_field_list = new_field; + } + + /* Finish up the union type and create the variant part. No need for debug + info thanks to the XVS type. */ + finish_record_type (new_union_type, union_field_list, 2, false); + compute_record_mode (new_union_type); + create_type_decl (TYPE_NAME (new_union_type), new_union_type, NULL, + true, false, Empty); + + new_variant_part + = create_field_decl_from (old_variant_part, new_union_type, record_type, + TYPE_SIZE (new_union_type), + pos_list, subst_list); + DECL_INTERNAL_P (new_variant_part) = 1; + + /* With multiple discriminants it is possible for an inner variant to be + statically selected while outer ones are not; in this case, the list + of fields of the inner variant is not flattened and we end up with a + qualified union with a single member. Drop the useless container. */ + if (!DECL_CHAIN (union_field_list)) + { + DECL_CONTEXT (union_field_list) = record_type; + DECL_FIELD_OFFSET (union_field_list) + = DECL_FIELD_OFFSET (new_variant_part); + DECL_FIELD_BIT_OFFSET (union_field_list) + = DECL_FIELD_BIT_OFFSET (new_variant_part); + SET_DECL_OFFSET_ALIGN (union_field_list, + DECL_OFFSET_ALIGN (new_variant_part)); + new_variant_part = union_field_list; + } + + return new_variant_part; +} + +/* Copy the size (and alignment and alias set) from OLD_TYPE to NEW_TYPE, + which are both RECORD_TYPE, after applying the substitutions described + in SUBST_LIST. */ + +static void +copy_and_substitute_in_size (tree new_type, tree old_type, + VEC(subst_pair,heap) *subst_list) +{ + unsigned ix; + subst_pair *s; + + TYPE_SIZE (new_type) = TYPE_SIZE (old_type); + TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (old_type); + SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (old_type)); + TYPE_ALIGN (new_type) = TYPE_ALIGN (old_type); + relate_alias_sets (new_type, old_type, ALIAS_SET_COPY); + + if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type))) + FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s) + TYPE_SIZE (new_type) + = SUBSTITUTE_IN_EXPR (TYPE_SIZE (new_type), + s->discriminant, s->replacement); + + if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (new_type))) + FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s) + TYPE_SIZE_UNIT (new_type) + = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (new_type), + s->discriminant, s->replacement); + + if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (new_type))) + FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s) + SET_TYPE_ADA_SIZE + (new_type, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (new_type), + s->discriminant, s->replacement)); + + /* Finalize the size. */ + TYPE_SIZE (new_type) = variable_size (TYPE_SIZE (new_type)); + TYPE_SIZE_UNIT (new_type) = variable_size (TYPE_SIZE_UNIT (new_type)); +} + +/* Given a type T, a FIELD_DECL F, and a replacement value R, return a + type with all size expressions that contain F in a PLACEHOLDER_EXPR + updated by replacing F with R. + + The function doesn't update the layout of the type, i.e. it assumes + that the substitution is purely formal. That's why the replacement + value R must itself contain a PLACEHOLDER_EXPR. */ + +tree +substitute_in_type (tree t, tree f, tree r) +{ + tree nt; + + gcc_assert (CONTAINS_PLACEHOLDER_P (r)); + + switch (TREE_CODE (t)) + { + case INTEGER_TYPE: + case ENUMERAL_TYPE: + case BOOLEAN_TYPE: + case REAL_TYPE: + + /* First the domain types of arrays. */ + if (CONTAINS_PLACEHOLDER_P (TYPE_GCC_MIN_VALUE (t)) + || CONTAINS_PLACEHOLDER_P (TYPE_GCC_MAX_VALUE (t))) + { + tree low = SUBSTITUTE_IN_EXPR (TYPE_GCC_MIN_VALUE (t), f, r); + tree high = SUBSTITUTE_IN_EXPR (TYPE_GCC_MAX_VALUE (t), f, r); + + if (low == TYPE_GCC_MIN_VALUE (t) && high == TYPE_GCC_MAX_VALUE (t)) + return t; + + nt = copy_type (t); + TYPE_GCC_MIN_VALUE (nt) = low; + TYPE_GCC_MAX_VALUE (nt) = high; + + if (TREE_CODE (t) == INTEGER_TYPE && TYPE_INDEX_TYPE (t)) + SET_TYPE_INDEX_TYPE + (nt, substitute_in_type (TYPE_INDEX_TYPE (t), f, r)); + + return nt; + } + + /* Then the subtypes. */ + if (CONTAINS_PLACEHOLDER_P (TYPE_RM_MIN_VALUE (t)) + || CONTAINS_PLACEHOLDER_P (TYPE_RM_MAX_VALUE (t))) + { + tree low = SUBSTITUTE_IN_EXPR (TYPE_RM_MIN_VALUE (t), f, r); + tree high = SUBSTITUTE_IN_EXPR (TYPE_RM_MAX_VALUE (t), f, r); + + if (low == TYPE_RM_MIN_VALUE (t) && high == TYPE_RM_MAX_VALUE (t)) + return t; + + nt = copy_type (t); + SET_TYPE_RM_MIN_VALUE (nt, low); + SET_TYPE_RM_MAX_VALUE (nt, high); + + return nt; + } + + return t; + + case COMPLEX_TYPE: + nt = substitute_in_type (TREE_TYPE (t), f, r); + if (nt == TREE_TYPE (t)) + return t; + + return build_complex_type (nt); + + case FUNCTION_TYPE: + /* These should never show up here. */ + gcc_unreachable (); + + case ARRAY_TYPE: + { + tree component = substitute_in_type (TREE_TYPE (t), f, r); + tree domain = substitute_in_type (TYPE_DOMAIN (t), f, r); + + if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t)) + return t; + + nt = build_nonshared_array_type (component, domain); + TYPE_ALIGN (nt) = TYPE_ALIGN (t); + TYPE_USER_ALIGN (nt) = TYPE_USER_ALIGN (t); + SET_TYPE_MODE (nt, TYPE_MODE (t)); + TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r); + TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r); + TYPE_NONALIASED_COMPONENT (nt) = TYPE_NONALIASED_COMPONENT (t); + TYPE_MULTI_ARRAY_P (nt) = TYPE_MULTI_ARRAY_P (t); + TYPE_CONVENTION_FORTRAN_P (nt) = TYPE_CONVENTION_FORTRAN_P (t); + return nt; + } + + case RECORD_TYPE: + case UNION_TYPE: + case QUAL_UNION_TYPE: + { + bool changed_field = false; + tree field; + + /* Start out with no fields, make new fields, and chain them + in. If we haven't actually changed the type of any field, + discard everything we've done and return the old type. */ + nt = copy_type (t); + TYPE_FIELDS (nt) = NULL_TREE; + + for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field)) + { + tree new_field = copy_node (field), new_n; + + new_n = substitute_in_type (TREE_TYPE (field), f, r); + if (new_n != TREE_TYPE (field)) + { + TREE_TYPE (new_field) = new_n; + changed_field = true; + } + + new_n = SUBSTITUTE_IN_EXPR (DECL_FIELD_OFFSET (field), f, r); + if (new_n != DECL_FIELD_OFFSET (field)) + { + DECL_FIELD_OFFSET (new_field) = new_n; + changed_field = true; + } + + /* Do the substitution inside the qualifier, if any. */ + if (TREE_CODE (t) == QUAL_UNION_TYPE) + { + new_n = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r); + if (new_n != DECL_QUALIFIER (field)) + { + DECL_QUALIFIER (new_field) = new_n; + changed_field = true; + } + } + + DECL_CONTEXT (new_field) = nt; + SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, field); + + DECL_CHAIN (new_field) = TYPE_FIELDS (nt); + TYPE_FIELDS (nt) = new_field; + } + + if (!changed_field) + return t; + + TYPE_FIELDS (nt) = nreverse (TYPE_FIELDS (nt)); + TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r); + TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r); + SET_TYPE_ADA_SIZE (nt, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (t), f, r)); + return nt; + } + + default: + return t; + } +} + +/* Return the RM size of GNU_TYPE. This is the actual number of bits + needed to represent the object. */ + +tree +rm_size (tree gnu_type) +{ + /* For integral types, we store the RM size explicitly. */ + if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type)) + return TYPE_RM_SIZE (gnu_type); + + /* Return the RM size of the actual data plus the size of the template. */ + if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) + return + size_binop (PLUS_EXPR, + rm_size (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)))), + DECL_SIZE (TYPE_FIELDS (gnu_type))); + + /* For record types, we store the size explicitly. */ + if ((TREE_CODE (gnu_type) == RECORD_TYPE + || TREE_CODE (gnu_type) == UNION_TYPE + || TREE_CODE (gnu_type) == QUAL_UNION_TYPE) + && !TYPE_FAT_POINTER_P (gnu_type) + && TYPE_ADA_SIZE (gnu_type)) + return TYPE_ADA_SIZE (gnu_type); + + /* For other types, this is just the size. */ + return TYPE_SIZE (gnu_type); +} + +/* Return the name to be used for GNAT_ENTITY. If a type, create a + fully-qualified name, possibly with type information encoding. + Otherwise, return the name. */ + +tree +get_entity_name (Entity_Id gnat_entity) +{ + Get_Encoded_Name (gnat_entity); + return get_identifier_with_length (Name_Buffer, Name_Len); +} + +/* Return an identifier representing the external name to be used for + GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___" + and the specified suffix. */ + +tree +create_concat_name (Entity_Id gnat_entity, const char *suffix) +{ + Entity_Kind kind = Ekind (gnat_entity); + + if (suffix) + { + String_Template temp = {1, strlen (suffix)}; + Fat_Pointer fp = {suffix, &temp}; + Get_External_Name_With_Suffix (gnat_entity, fp); + } + else + Get_External_Name (gnat_entity, 0); + + /* A variable using the Stdcall convention lives in a DLL. We adjust + its name to use the jump table, the _imp__NAME contains the address + for the NAME variable. */ + if ((kind == E_Variable || kind == E_Constant) + && Has_Stdcall_Convention (gnat_entity)) + { + const int len = 6 + Name_Len; + char *new_name = (char *) alloca (len + 1); + strcpy (new_name, "_imp__"); + strcat (new_name, Name_Buffer); + return get_identifier_with_length (new_name, len); + } + + return get_identifier_with_length (Name_Buffer, Name_Len); +} + +/* Given GNU_NAME, an IDENTIFIER_NODE containing a name and SUFFIX, a + string, return a new IDENTIFIER_NODE that is the concatenation of + the name followed by "___" and the specified suffix. */ + +tree +concat_name (tree gnu_name, const char *suffix) +{ + const int len = IDENTIFIER_LENGTH (gnu_name) + 3 + strlen (suffix); + char *new_name = (char *) alloca (len + 1); + strcpy (new_name, IDENTIFIER_POINTER (gnu_name)); + strcat (new_name, "___"); + strcat (new_name, suffix); + return get_identifier_with_length (new_name, len); +} + +#include "gt-ada-decl.h" diff --git a/gcc/ada/gcc-interface/gadaint.h b/gcc/ada/gcc-interface/gadaint.h new file mode 100644 index 000000000..57503f069 --- /dev/null +++ b/gcc/ada/gcc-interface/gadaint.h @@ -0,0 +1,35 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * G A D A I N T * + * * + * C Header File * + * * + * 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. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING3. If 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 contains the declarations of adaint.c material used in gigi. + It should be used in lieu of adaint.h in gigi because the latter drags + a lot of stuff on Windows and this pollutes the namespace of macros. */ + +#ifndef GCC_ADAINT_H +#define GCC_ADAINT_H + +extern char *__gnat_to_canonical_file_spec (char *); + +#endif /* GCC_ADAINT_H */ diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h new file mode 100644 index 000000000..eca4d9e7e --- /dev/null +++ b/gcc/ada/gcc-interface/gigi.h @@ -0,0 +1,954 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * G I G I * + * * + * C Header File * + * * + * 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. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING3. If not see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* Declare all functions and types used by gigi. */ + +/* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada + entity, this routine returns the equivalent GCC tree for that entity + (an ..._DECL node) and associates the ..._DECL node with the input GNAT + defining identifier. + + If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its + initial value (in GCC tree form). This is optional for variables. + For renamed entities, GNU_EXPR gives the object being renamed. + + DEFINITION is nonzero if this call is intended for a definition. This is + used for separate compilation where it necessary to know whether an + external declaration or a definition should be created if the GCC equivalent + was not created previously. The value of 1 is normally used for a nonzero + DEFINITION, but a value of 2 is used in special circumstances, defined in + the code. */ +extern tree gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, + int definition); + +/* Similar, but if the returned value is a COMPONENT_REF, return the + FIELD_DECL. */ +extern tree gnat_to_gnu_field_decl (Entity_Id gnat_entity); + +/* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return + the GCC type corresponding to that entity. */ +extern tree gnat_to_gnu_type (Entity_Id gnat_entity); + +/* Wrap up compilation of T, a TYPE_DECL, possibly deferring it. */ +extern void rest_of_type_decl_compilation (tree t); + +/* Start a new statement group chained to the previous group. */ +extern void start_stmt_group (void); + +/* Add GNU_STMT to the current statement group. If it is an expression with + no effects, it is ignored. */ +extern void add_stmt (tree gnu_stmt); + +/* Similar, but the statement is always added, regardless of side-effects. */ +extern void add_stmt_force (tree gnu_stmt); + +/* Like add_stmt, but set the location of GNU_STMT to that of GNAT_NODE. */ +extern void add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node); + +/* Similar, but the statement is always added, regardless of side-effects. */ +extern void add_stmt_with_node_force (tree gnu_stmt, Node_Id gnat_node); + +/* Return code corresponding to the current code group. It is normally + a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if + BLOCK or cleanups were set. */ +extern tree end_stmt_group (void); + +/* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */ +extern void set_block_for_group (tree); + +/* Add a declaration statement for GNU_DECL to the current BLOCK_STMT node. + Get SLOC from GNAT_ENTITY. */ +extern void add_decl_expr (tree gnu_decl, Entity_Id gnat_entity); + +/* Mark nodes rooted at T with TREE_VISITED and types as having their + sized gimplified. We use this to indicate all variable sizes and + positions in global types may not be shared by any subprogram. */ +extern void mark_visited (tree t); + +/* This macro calls the above function but short-circuits the common + case of a constant to save time and also checks for NULL. */ + +#define MARK_VISITED(EXP) \ +do { \ + if((EXP) && !CONSTANT_CLASS_P (EXP)) \ + mark_visited (EXP); \ +} while (0) + +/* Finalize any From_With_Type incomplete types. We do this after processing + our compilation unit and after processing its spec, if this is a body. */ +extern void finalize_from_with_types (void); + +/* Return the equivalent type to be used for GNAT_ENTITY, if it's a + kind of type (such E_Task_Type) that has a different type which Gigi + uses for its representation. If the type does not have a special type + for its representation, return GNAT_ENTITY. If a type is supposed to + exist, but does not, abort unless annotating types, in which case + return Empty. If GNAT_ENTITY is Empty, return Empty. */ +extern Entity_Id Gigi_Equivalent_Type (Entity_Id gnat_entity); + +/* Given GNAT_ENTITY, elaborate all expressions that are required to + be elaborated at the point of its definition, but do nothing else. */ +extern void elaborate_entity (Entity_Id gnat_entity); + +/* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark + any entities on its entity chain similarly. */ +extern void mark_out_of_scope (Entity_Id gnat_entity); + +/* Get the unpadded version of a GNAT type. */ +extern tree get_unpadded_type (Entity_Id gnat_entity); + +/* Create a record type that contains a SIZE bytes long field of TYPE with a + starting bit position so that it is aligned to ALIGN bits, and leaving at + least ROOM bytes free before the field. BASE_ALIGN is the alignment the + record is guaranteed to get. */ +extern tree make_aligning_type (tree type, unsigned int align, tree size, + unsigned int base_align, int room); + +/* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type + if needed. We have already verified that SIZE and TYPE are large enough. + GNAT_ENTITY is used to name the resulting record and to issue a warning. + IS_COMPONENT_TYPE is true if this is being done for the component type + of an array. IS_USER_TYPE is true if we must complete the original type. + DEFINITION is true if this type is being defined. SAME_RM_SIZE is true + if the RM size of the resulting type is to be set to SIZE too; otherwise, + it's set to the RM size of the original type. */ +extern tree maybe_pad_type (tree type, tree size, unsigned int align, + Entity_Id gnat_entity, bool is_component_type, + bool is_user_type, bool definition, + bool same_rm_size); + +/* Given a GNU tree and a GNAT list of choices, generate an expression to test + the value passed against the list of choices. */ +extern tree choices_to_gnu (tree operand, Node_Id choices); + +/* Given GNAT_ENTITY, an object (constant, variable, parameter, exception) + and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the + size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null. + BY_REF is true if the object is used by reference and BY_DOUBLE_REF is + true if the object is used by double reference. */ +extern void annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, + bool by_ref, bool by_double_ref); + +/* Return the variant part of RECORD_TYPE, if any. Otherwise return NULL. */ +extern tree get_variant_part (tree record_type); + +/* Given a type T, a FIELD_DECL F, and a replacement value R, return a new + type with all size expressions that contain F updated by replacing F + with R. If F is NULL_TREE, always make a new RECORD_TYPE, even if + nothing has changed. */ +extern tree substitute_in_type (tree t, tree f, tree r); + +/* Return the RM size of GNU_TYPE. This is the actual number of bits + needed to represent the object. */ +extern tree rm_size (tree gnu_type); + +/* Return the name to be used for GNAT_ENTITY. If a type, create a + fully-qualified name, possibly with type information encoding. + Otherwise, return the name. */ +extern tree get_entity_name (Entity_Id gnat_entity); + +/* Return an identifier representing the external name to be used for + GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___" + and the specified suffix. */ +extern tree create_concat_name (Entity_Id gnat_entity, const char *suffix); + +/* Given GNU_NAME, an IDENTIFIER_NODE containing a name and SUFFIX, a + string, return a new IDENTIFIER_NODE that is the concatenation of + the name followed by "___" and the specified suffix. */ +extern tree concat_name (tree gnu_name, const char *suffix); + +/* Highest number in the front-end node table. */ +extern int max_gnat_nodes; + +/* Current node being treated, in case abort called. */ +extern Node_Id error_gnat_node; + +/* True when gigi is being called on an analyzed but unexpanded + tree, and the only purpose of the call is to properly annotate + types with representation information. */ +extern bool type_annotate_only; + +/* Current file name without path. */ +extern const char *ref_filename; + +/* This structure must be kept synchronized with Call_Back_End. */ +struct File_Info_Type +{ + File_Name_Type File_Name; + Nat Num_Source_Lines; +}; + +/* This is the main program of the back-end. It sets up all the table + structures and then generates code. */ +extern void gigi (Node_Id gnat_root, int max_gnat_node, + int number_name ATTRIBUTE_UNUSED, + struct Node *nodes_ptr, Node_Id *next_node_ptr, + Node_Id *prev_node_ptr, struct Elist_Header *elists_ptr, + struct Elmt_Item *elmts_ptr, + struct String_Entry *strings_ptr, + Char_Code *strings_chars_ptr, + struct List_Header *list_headers_ptr, + Nat number_file, + struct File_Info_Type *file_info_ptr, + Entity_Id standard_boolean, + Entity_Id standard_integer, + Entity_Id standard_character, + Entity_Id standard_long_long_float, + Entity_Id standard_exception_type, + Int gigi_operating_mode); + +/* GNAT_NODE is the root of some GNAT tree. Return the root of the + GCC tree corresponding to that GNAT tree. Normally, no code is generated; + we just return an equivalent tree which is used elsewhere to generate + code. */ +extern tree gnat_to_gnu (Node_Id gnat_node); + +/* GNU_STMT is a statement. We generate code for that statement. */ +extern void gnat_expand_stmt (tree gnu_stmt); + +/* Generate GIMPLE in place for the expression at *EXPR_P. */ +extern int gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p, + gimple_seq *post_p ATTRIBUTE_UNUSED); + +/* Do the processing for the declaration of a GNAT_ENTITY, a type. If + a separate Freeze node exists, delay the bulk of the processing. Otherwise + make a GCC type for GNAT_ENTITY and set up the correspondence. */ +extern void process_type (Entity_Id gnat_entity); + +/* Convert SLOC into LOCUS. Return true if SLOC corresponds to a source code + location and false if it doesn't. In the former case, set the Gigi global + variable REF_FILENAME to the simple debug file name as given by sinput. */ +extern bool Sloc_to_locus (Source_Ptr Sloc, location_t *locus); + +/* Post an error message. MSG is the error message, properly annotated. + NODE is the node at which to post the error and the node to use for the + '&' substitution. */ +extern void post_error (const char *msg, Node_Id node); + +/* Similar to post_error, but NODE is the node at which to post the error and + ENT is the node to use for the '&' substitution. */ +extern void post_error_ne (const char *msg, Node_Id node, Entity_Id ent); + +/* Similar to post_error_ne, but NUM is the number to use for the '^'. */ +extern void post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, + int num); + +/* Similar to post_error_ne, but T is a GCC tree representing the number to + write. If T represents a constant, the text inside curly brackets in + MSG will be output (presumably including a '^'). Otherwise it will not + be output and the text inside square brackets will be output instead. */ +extern void post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, + tree t); + +/* Similar to post_error_ne_tree, but NUM is a second integer to write. */ +extern void post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent, + tree t, int num); + +/* Return a label to branch to for the exception type in KIND or NULL_TREE + if none. */ +extern tree get_exception_label (char kind); + +/* Return the decl for the current elaboration procedure. */ +extern tree get_elaboration_procedure (void); + +/* If nonzero, pretend we are allocating at global level. */ +extern int force_global; + +/* The default alignment of "double" floating-point types, i.e. floating + point types whose size is equal to 64 bits, or 0 if this alignment is + not specifically capped. */ +extern int double_float_alignment; + +/* The default alignment of "double" or larger scalar types, i.e. scalar + types whose size is greater or equal to 64 bits, or 0 if this alignment + is not specifically capped. */ +extern int double_scalar_alignment; + +/* Data structures used to represent attributes. */ + +enum attr_type +{ + ATTR_MACHINE_ATTRIBUTE, + ATTR_LINK_ALIAS, + ATTR_LINK_SECTION, + ATTR_LINK_CONSTRUCTOR, + ATTR_LINK_DESTRUCTOR, + ATTR_THREAD_LOCAL_STORAGE, + ATTR_WEAK_EXTERNAL +}; + +struct attrib +{ + struct attrib *next; + enum attr_type type; + tree name; + tree args; + Node_Id error_point; +}; + +/* Table of machine-independent internal attributes. */ +extern const struct attribute_spec gnat_internal_attribute_table[]; + +/* Define the entries in the standard data array. */ +enum standard_datatypes +{ + /* The longest floating-point type. */ + ADT_longest_float_type, + + /* The type of an exception. */ + ADT_except_type, + + /* Type declaration node <==> typedef void *T */ + ADT_ptr_void_type, + + /* Function type declaration -- void T() */ + ADT_void_ftype, + + /* Type declaration node <==> typedef void *T() */ + ADT_ptr_void_ftype, + + /* Type declaration node <==> typedef virtual void *T() */ + ADT_fdesc_type, + + /* Null pointer for above type. */ + ADT_null_fdesc, + + /* Value 1 in signed bitsizetype. */ + ADT_sbitsize_one_node, + + /* Value BITS_PER_UNIT in signed bitsizetype. */ + ADT_sbitsize_unit_node, + + /* Function declaration nodes for run-time functions for allocating memory. + Ada allocators cause calls to these functions to be generated. Malloc32 + is used only on 64bit systems needing to allocate 32bit memory. */ + ADT_malloc_decl, + ADT_malloc32_decl, + + /* Likewise for freeing memory. */ + ADT_free_decl, + + /* Function decl node for 64-bit multiplication with overflow checking. */ + ADT_mulv64_decl, + + /* Identifier for the name of the _Parent field in tagged record types. */ + ADT_parent_name_id, + + /* Identifier for the name of the Exception_Data type. */ + ADT_exception_data_name_id, + + /* Types and decls used by our temporary exception mechanism. See + init_gigi_decls for details. */ + ADT_jmpbuf_type, + ADT_jmpbuf_ptr_type, + ADT_get_jmpbuf_decl, + ADT_set_jmpbuf_decl, + ADT_get_excptr_decl, + ADT_setjmp_decl, + ADT_longjmp_decl, + ADT_update_setjmp_buf_decl, + ADT_raise_nodefer_decl, + ADT_begin_handler_decl, + ADT_end_handler_decl, + ADT_others_decl, + ADT_all_others_decl, + ADT_LAST}; + +/* Define kind of exception information associated with raise statements. */ +enum exception_info_kind +{ + /* Simple exception information: file:line. */ + exception_simple, + /* Range exception information: file:line + index, first, last. */ + exception_range, + /* Column exception information: file:line:column. */ + exception_column +}; + +extern GTY(()) tree gnat_std_decls[(int) ADT_LAST]; +extern GTY(()) tree gnat_raise_decls[(int) LAST_REASON_CODE + 1]; +extern GTY(()) tree gnat_raise_decls_ext[(int) LAST_REASON_CODE + 1]; + +#define longest_float_type_node gnat_std_decls[(int) ADT_longest_float_type] +#define except_type_node gnat_std_decls[(int) ADT_except_type] +#define ptr_void_type_node gnat_std_decls[(int) ADT_ptr_void_type] +#define void_ftype gnat_std_decls[(int) ADT_void_ftype] +#define ptr_void_ftype gnat_std_decls[(int) ADT_ptr_void_ftype] +#define fdesc_type_node gnat_std_decls[(int) ADT_fdesc_type] +#define null_fdesc_node gnat_std_decls[(int) ADT_null_fdesc] +#define sbitsize_one_node gnat_std_decls[(int) ADT_sbitsize_one_node] +#define sbitsize_unit_node gnat_std_decls[(int) ADT_sbitsize_unit_node] +#define malloc_decl gnat_std_decls[(int) ADT_malloc_decl] +#define malloc32_decl gnat_std_decls[(int) ADT_malloc32_decl] +#define free_decl gnat_std_decls[(int) ADT_free_decl] +#define mulv64_decl gnat_std_decls[(int) ADT_mulv64_decl] +#define parent_name_id gnat_std_decls[(int) ADT_parent_name_id] +#define exception_data_name_id gnat_std_decls[(int) ADT_exception_data_name_id] +#define jmpbuf_type gnat_std_decls[(int) ADT_jmpbuf_type] +#define jmpbuf_ptr_type gnat_std_decls[(int) ADT_jmpbuf_ptr_type] +#define get_jmpbuf_decl gnat_std_decls[(int) ADT_get_jmpbuf_decl] +#define set_jmpbuf_decl gnat_std_decls[(int) ADT_set_jmpbuf_decl] +#define get_excptr_decl gnat_std_decls[(int) ADT_get_excptr_decl] +#define setjmp_decl gnat_std_decls[(int) ADT_setjmp_decl] +#define longjmp_decl gnat_std_decls[(int) ADT_longjmp_decl] +#define update_setjmp_buf_decl gnat_std_decls[(int) ADT_update_setjmp_buf_decl] +#define raise_nodefer_decl gnat_std_decls[(int) ADT_raise_nodefer_decl] +#define begin_handler_decl gnat_std_decls[(int) ADT_begin_handler_decl] +#define others_decl gnat_std_decls[(int) ADT_others_decl] +#define all_others_decl gnat_std_decls[(int) ADT_all_others_decl] +#define end_handler_decl gnat_std_decls[(int) ADT_end_handler_decl] + +/* Routines expected by the gcc back-end. They must have exactly the same + prototype and names as below. */ + +/* Returns nonzero if we are currently in the global binding level. */ +extern int global_bindings_p (void); + +/* Enter and exit a new binding level. */ +extern void gnat_pushlevel (void); +extern void gnat_poplevel (void); +extern void gnat_zaplevel (void); + +/* Set SUPERCONTEXT of the BLOCK for the current binding level to FNDECL + and point FNDECL to this BLOCK. */ +extern void set_current_block_context (tree fndecl); + +/* Set the jmpbuf_decl for the current binding level to DECL. */ +extern void set_block_jmpbuf_decl (tree decl); + +/* Get the setjmp_decl, if any, for the current binding level. */ +extern tree get_block_jmpbuf_decl (void); + +/* Records a ..._DECL node DECL as belonging to the current lexical scope + and uses GNAT_NODE for location information. */ +extern void gnat_pushdecl (tree decl, Node_Id gnat_node); + +extern void gnat_init_gcc_eh (void); +extern void gnat_install_builtins (void); + +/* Return an integer type with the number of bits of precision given by + PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise + it is a signed type. */ +extern tree gnat_type_for_size (unsigned precision, int unsignedp); + +/* Return a data type that has machine mode MODE. UNSIGNEDP selects + an unsigned type; otherwise a signed type is returned. */ +extern tree gnat_type_for_mode (enum machine_mode mode, int unsignedp); + +/* Emit debug info for all global variable declarations. */ +extern void gnat_write_global_declarations (void); + +/* Return the unsigned version of a TYPE_NODE, a scalar type. */ +extern tree gnat_unsigned_type (tree type_node); + +/* Return the signed version of a TYPE_NODE, a scalar type. */ +extern tree gnat_signed_type (tree type_node); + +/* Return 1 if the types T1 and T2 are compatible, i.e. if they can be + transparently converted to each other. */ +extern int gnat_types_compatible_p (tree t1, tree t2); + +/* Return true if T, a FUNCTION_TYPE, has the specified list of flags. */ +extern bool fntype_same_flags_p (const_tree, tree, bool, bool, bool); + +/* Create an expression whose value is that of EXPR, + converted to type TYPE. The TREE_TYPE of the value + is always TYPE. This function implements all reasonable + conversions; callers should filter out those that are + not permitted by the language being compiled. */ +extern tree convert (tree type, tree expr); + +/* Routines created solely for the tree translator's sake. Their prototypes + can be changed as desired. */ + +/* Initialize the association of GNAT nodes to GCC trees. */ +extern void init_gnat_to_gnu (void); + +/* GNAT_ENTITY is a GNAT tree node for a defining identifier. + GNU_DECL is the GCC tree which is to be associated with + GNAT_ENTITY. Such gnu tree node is always an ..._DECL node. + If NO_CHECK is nonzero, the latter check is suppressed. + If GNU_DECL is zero, a previous association is to be reset. */ +extern void save_gnu_tree (Entity_Id gnat_entity, tree gnu_decl, + bool no_check); + +/* GNAT_ENTITY is a GNAT tree node for a defining identifier. + Return the ..._DECL node that was associated with it. If there is no tree + node associated with GNAT_ENTITY, abort. */ +extern tree get_gnu_tree (Entity_Id gnat_entity); + +/* Return nonzero if a GCC tree has been associated with GNAT_ENTITY. */ +extern bool present_gnu_tree (Entity_Id gnat_entity); + +/* Initialize the association of GNAT nodes to GCC trees as dummies. */ +extern void init_dummy_type (void); + +/* Make a dummy type corresponding to GNAT_TYPE. */ +extern tree make_dummy_type (Entity_Id gnat_type); + +/* Record TYPE as a builtin type for Ada. NAME is the name of the type. */ +extern void record_builtin_type (const char *name, tree type); + +/* Given a record type RECORD_TYPE and a list of FIELD_DECL nodes FIELD_LIST, + finish constructing the record or union type. If REP_LEVEL is zero, this + record has no representation clause and so will be entirely laid out here. + If REP_LEVEL is one, this record has a representation clause and has been + laid out already; only set the sizes and alignment. If REP_LEVEL is two, + this record is derived from a parent record and thus inherits its layout; + only make a pass on the fields to finalize them. DEBUG_INFO_P is true if + we need to write debug information about this type. */ +extern void finish_record_type (tree record_type, tree field_list, + int rep_level, bool debug_info_p); + +/* Wrap up compilation of RECORD_TYPE, i.e. output all the debug information + associated with it. It need not be invoked directly in most cases since + finish_record_type takes care of doing so, but this can be necessary if + a parallel type is to be attached to the record type. */ +extern void rest_of_record_type_compilation (tree record_type); + +/* Append PARALLEL_TYPE on the chain of parallel types for decl. */ +extern void add_parallel_type (tree decl, tree parallel_type); + +/* Return a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the + subprogram. If it is VOID_TYPE, then we are dealing with a procedure, + otherwise we are dealing with a function. PARAM_DECL_LIST is a list of + PARM_DECL nodes that are the subprogram parameters. CICO_LIST is the + copy-in/copy-out list to be stored into the TYPE_CICO_LIST field. + RETURN_UNCONSTRAINED_P is true if the function returns an unconstrained + object. RETURN_BY_DIRECT_REF_P is true if the function returns by direct + reference. RETURN_BY_INVISI_REF_P is true if the function returns by + invisible reference. */ +extern tree create_subprog_type (tree return_type, tree param_decl_list, + tree cico_list, bool return_unconstrained_p, + bool return_by_direct_ref_p, + bool return_by_invisi_ref_p); + +/* Return a copy of TYPE, but safe to modify in any way. */ +extern tree copy_type (tree type); + +/* Return a subtype of sizetype with range MIN to MAX and whose + TYPE_INDEX_TYPE is INDEX. GNAT_NODE is used for the position + of the associated TYPE_DECL. */ +extern tree create_index_type (tree min, tree max, tree index, + Node_Id gnat_node); + +/* Return a subtype of TYPE with range MIN to MAX. If TYPE is NULL, + sizetype is used. */ +extern tree create_range_type (tree type, tree min, tree max); + +/* Return a TYPE_DECL node suitable for the TYPE_STUB_DECL field of a type. + TYPE_NAME gives the name of the type and TYPE is a ..._TYPE node giving + its data type. */ +extern tree create_type_stub_decl (tree type_name, tree type); + +/* Return a TYPE_DECL node. TYPE_NAME gives the name of the type and TYPE + is a ..._TYPE node giving its data type. ARTIFICIAL_P is true if this + is a declaration that was generated by the compiler. DEBUG_INFO_P is + true if we need to write debug information about this type. GNAT_NODE + is used for the position of the decl. */ +extern tree create_type_decl (tree type_name, tree type, + struct attrib *attr_list, + bool artificial_p, bool debug_info_p, + Node_Id gnat_node); + +/* Return a VAR_DECL or CONST_DECL node. + + VAR_NAME gives the name of the variable. ASM_NAME is its assembler name + (if provided). TYPE is its data type (a GCC ..._TYPE node). VAR_INIT is + the GCC tree for an optional initial expression; NULL_TREE if none. + + CONST_FLAG is true if this variable is constant, in which case we might + return a CONST_DECL node unless CONST_DECL_ALLOWED_P is false. + + PUBLIC_FLAG is true if this definition is to be made visible outside of + the current compilation unit. This flag should be set when processing the + variable definitions in a package specification. + + EXTERN_FLAG is nonzero when processing an external variable declaration (as + opposed to a definition: no storage is to be allocated for the variable). + + STATIC_FLAG is only relevant when not at top level. In that case + it indicates whether to always allocate storage to the variable. + + GNAT_NODE is used for the position of the decl. */ +extern tree +create_var_decl_1 (tree var_name, tree asm_name, tree type, tree var_init, + bool const_flag, bool public_flag, bool extern_flag, + bool static_flag, bool const_decl_allowed_p, + struct attrib *attr_list, Node_Id gnat_node); + +/* Wrapper around create_var_decl_1 for cases where we don't care whether + a VAR or a CONST decl node is created. */ +#define create_var_decl(var_name, asm_name, type, var_init, \ + const_flag, public_flag, extern_flag, \ + static_flag, attr_list, gnat_node) \ + create_var_decl_1 (var_name, asm_name, type, var_init, \ + const_flag, public_flag, extern_flag, \ + static_flag, true, attr_list, gnat_node) + +/* Wrapper around create_var_decl_1 for cases where a VAR_DECL node is + required. The primary intent is for DECL_CONST_CORRESPONDING_VARs, which + must be VAR_DECLs and on which we want TREE_READONLY set to have them + possibly assigned to a readonly data section. */ +#define create_true_var_decl(var_name, asm_name, type, var_init, \ + const_flag, public_flag, extern_flag, \ + static_flag, attr_list, gnat_node) \ + create_var_decl_1 (var_name, asm_name, type, var_init, \ + const_flag, public_flag, extern_flag, \ + static_flag, false, attr_list, gnat_node) + +/* Record DECL as a global renaming pointer. */ +extern void record_global_renaming_pointer (tree decl); + +/* Invalidate the global renaming pointers. */ +extern void invalidate_global_renaming_pointers (void); + +/* Return a FIELD_DECL node. FIELD_NAME is the field's name, FIELD_TYPE is + its type and RECORD_TYPE is the type of the enclosing record. If SIZE is + nonzero, it is the specified size of the field. If POS is nonzero, it is + the bit position. PACKED is 1 if the enclosing record is packed, -1 if it + has Component_Alignment of Storage_Unit. If ADDRESSABLE is nonzero, it + means we are allowed to take the address of the field; if it is negative, + we should not make a bitfield, which is used by make_aligning_type. */ +extern tree create_field_decl (tree field_name, tree field_type, + tree record_type, tree size, tree pos, + int packed, int addressable); + +/* Returns a PARM_DECL node. PARAM_NAME is the name of the parameter, + PARAM_TYPE is its type. READONLY is true if the parameter is + readonly (either an In parameter or an address of a pass-by-ref + parameter). */ +extern tree create_param_decl (tree param_name, tree param_type, + bool readonly); + +/* Returns a FUNCTION_DECL node. SUBPROG_NAME is the name of the subprogram, + ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE + node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of + PARM_DECL nodes chained through the TREE_CHAIN field). + + INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, and ATTR_LIST are used to set the + appropriate fields in the FUNCTION_DECL. GNAT_NODE gives the location. */ +extern tree create_subprog_decl (tree subprog_name, tree asm_name, + tree subprog_type, tree param_decl_list, + bool inlinee_flag, bool public_flag, + bool extern_flag, + struct attrib *attr_list, Node_Id gnat_node); + +/* Returns a LABEL_DECL node for LABEL_NAME. */ +extern tree create_label_decl (tree label_name); + +/* Set up the framework for generating code for SUBPROG_DECL, a subprogram + body. This routine needs to be invoked before processing the declarations + appearing in the subprogram. */ +extern void begin_subprog_body (tree subprog_decl); + +/* Finish the definition of the current subprogram BODY and finalize it. */ +extern void end_subprog_body (tree body); + +/* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE. + EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs. + Return a constructor for the template. */ +extern tree build_template (tree template_type, tree array_type, tree expr); + +/* Build a 64bit VMS descriptor from a Mechanism_Type, which must specify + a descriptor type, and the GCC type of an object. Each FIELD_DECL + in the type contains in its DECL_INITIAL the expression to use when + a constructor is made for the type. GNAT_ENTITY is a gnat node used + to print out an error message if the mechanism cannot be applied to + an object of that type and also for the name. */ +extern tree build_vms_descriptor (tree type, Mechanism_Type mech, + Entity_Id gnat_entity); + +/* Build a 32bit VMS descriptor from a Mechanism_Type. See above. */ +extern tree build_vms_descriptor32 (tree type, Mechanism_Type mech, + Entity_Id gnat_entity); + +/* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG + and the GNAT node GNAT_SUBPROG. */ +extern void build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog); + +/* Build a type to be used to represent an aliased object whose nominal type + is an unconstrained array. This consists of a RECORD_TYPE containing a + field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an ARRAY_TYPE. + If ARRAY_TYPE is that of an unconstrained array, this is used to represent + an arbitrary unconstrained object. Use NAME as the name of the record. + DEBUG_INFO_P is true if we need to write debug information for the type. */ +extern tree build_unc_object_type (tree template_type, tree object_type, + tree name, bool debug_info_p); + +/* Same as build_unc_object_type, but taking a thin or fat pointer type + instead of the template type. */ +extern tree build_unc_object_type_from_ptr (tree thin_fat_ptr_type, + tree object_type, tree name, + bool debug_info_p); + +/* Shift the component offsets within an unconstrained object TYPE to make it + suitable for use as a designated type for thin pointers. */ +extern void shift_unc_components_for_thin_pointers (tree type); + +/* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE. In + the normal case this is just two adjustments, but we have more to do + if NEW is an UNCONSTRAINED_ARRAY_TYPE. */ +extern void update_pointer_to (tree old_type, tree new_type); + +/* EXP is an expression for the size of an object. If this size contains + discriminant references, replace them with the maximum (if MAX_P) or + minimum (if !MAX_P) possible value of the discriminant. */ +extern tree max_size (tree exp, bool max_p); + +/* Remove all conversions that are done in EXP. This includes converting + from a padded type or to a left-justified modular type. If TRUE_ADDRESS + is true, always return the address of the containing object even if + the address is not bit-aligned. */ +extern tree remove_conversions (tree exp, bool true_address); + +/* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that + refers to the underlying array. If its type has TYPE_CONTAINS_TEMPLATE_P, + likewise return an expression pointing to the underlying array. */ +extern tree maybe_unconstrained_array (tree exp); + +/* If EXP's type is a VECTOR_TYPE, return EXP converted to the associated + TYPE_REPRESENTATIVE_ARRAY. */ +extern tree maybe_vector_array (tree exp); + +/* Return an expression that does an unchecked conversion of EXPR to TYPE. + If NOTRUNC_P is true, truncation operations should be suppressed. */ +extern tree unchecked_convert (tree type, tree expr, bool notrunc_p); + +/* Return the appropriate GCC tree code for the specified GNAT_TYPE, + the latter being a record type as predicated by Is_Record_Type. */ +extern enum tree_code tree_code_for_record_type (Entity_Id gnat_type); + +/* Return true if GNAT_TYPE is a "double" floating-point type, i.e. whose + size is equal to 64 bits, or an array of such a type. Set ALIGN_CLAUSE + according to the presence of an alignment clause on the type or, if it + is an array, on the component type. */ +extern bool is_double_float_or_array (Entity_Id gnat_type, + bool *align_clause); + +/* Return true if GNAT_TYPE is a "double" or larger scalar type, i.e. whose + size is greater or equal to 64 bits, or an array of such a type. Set + ALIGN_CLAUSE according to the presence of an alignment clause on the + type or, if it is an array, on the component type. */ +extern bool is_double_scalar_or_array (Entity_Id gnat_type, + bool *align_clause); + +/* Return true if GNU_TYPE is suitable as the type of a non-aliased + component of an aggregate type. */ +extern bool type_for_nonaliased_component_p (tree gnu_type); + +/* Return the base type of TYPE. */ +extern tree get_base_type (tree type); + +/* EXP is a GCC tree representing an address. See if we can find how + strictly the object at that address is aligned. Return that alignment + strictly the object at that address is aligned. Return that alignment + in bits. If we don't know anything about the alignment, return 0. */ +extern unsigned int known_alignment (tree exp); + +/* Return true if VALUE is a multiple of FACTOR. FACTOR must be a power + of 2. */ +extern bool value_factor_p (tree value, HOST_WIDE_INT factor); + +/* Make a binary operation of kind OP_CODE. RESULT_TYPE is the type + desired for the result. Usually the operation is to be performed + in that type. For MODIFY_EXPR and ARRAY_REF, RESULT_TYPE may be 0 + in which case the type to be used will be derived from the operands. */ +extern tree build_binary_op (enum tree_code op_code, tree result_type, + tree left_operand, tree right_operand); + +/* Similar, but make unary operation. */ +extern tree build_unary_op (enum tree_code op_code, tree result_type, + tree operand); + +/* Similar, but for COND_EXPR. */ +extern tree build_cond_expr (tree result_type, tree condition_operand, + tree true_operand, tree false_operand); + +/* Similar, but for COMPOUND_EXPR. */ + +extern tree build_compound_expr (tree result_type, tree stmt_operand, + tree expr_operand); + +/* Similar, but for RETURN_EXPR. */ +extern tree build_return_expr (tree ret_obj, tree ret_val); + +/* Build a CALL_EXPR to call FUNDECL with one argument, ARG. Return + the CALL_EXPR. */ +extern tree build_call_1_expr (tree fundecl, tree arg); + +/* Build a CALL_EXPR to call FUNDECL with two argument, ARG1 & ARG2. Return + the CALL_EXPR. */ +extern tree build_call_2_expr (tree fundecl, tree arg1, tree arg2); + +/* Likewise to call FUNDECL with no arguments. */ +extern tree build_call_0_expr (tree fundecl); + +/* Call a function that raises an exception and pass the line number and file + name, if requested. MSG says which exception function to call. + + GNAT_NODE is the gnat node conveying the source location for which the + error should be signaled, or Empty in which case the error is signaled on + the current ref_file_name/input_line. + + KIND says which kind of exception this is for + (N_Raise_{Constraint,Storage,Program}_Error). */ +extern tree build_call_raise (int msg, Node_Id gnat_node, char kind); + +/* Similar to build_call_raise, for an index or range check exception as + determined by MSG, with extra information generated of the form + "INDEX out of range FIRST..LAST". */ +extern tree build_call_raise_range (int msg, Node_Id gnat_node, + tree index, tree first, tree last); + +/* Similar to build_call_raise, with extra information about the column + where the check failed. */ +extern tree build_call_raise_column (int msg, Node_Id gnat_node); + +/* Return a CONSTRUCTOR of TYPE whose elements are V. This is not the + same as build_constructor in the language-independent tree.c. */ +extern tree gnat_build_constructor (tree type, VEC(constructor_elt,gc) *v); + +/* Return a COMPONENT_REF to access a field that is given by COMPONENT, + an IDENTIFIER_NODE giving the name of the field, FIELD, a FIELD_DECL, + for the field, or both. Don't fold the result if NO_FOLD_P. */ +extern tree build_component_ref (tree record_variable, tree component, + tree field, bool no_fold_p); + +/* Build a GCC tree to call an allocation or deallocation function. + If GNU_OBJ is nonzero, it is an object to deallocate. Otherwise, + generate an allocator. + + GNU_SIZE is the number of bytes to allocate and GNU_TYPE is the contained + object type, used to determine the to-be-honored address alignment. + GNAT_PROC, if present, is a procedure to call and GNAT_POOL is the storage + pool to use. If not present, malloc and free are used. GNAT_NODE is used + to provide an error location for restriction violation messages. */ +extern tree build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, + tree gnu_type, Entity_Id gnat_proc, + Entity_Id gnat_pool, Node_Id gnat_node); + +/* Build a GCC tree to correspond to allocating an object of TYPE whose + initial value if INIT, if INIT is nonzero. Convert the expression to + RESULT_TYPE, which must be some type of pointer. Return the tree. + + GNAT_PROC and GNAT_POOL optionally give the procedure to call and + the storage pool to use. GNAT_NODE is used to provide an error + location for restriction violation messages. If IGNORE_INIT_TYPE is + true, ignore the type of INIT for the purpose of determining the size; + this will cause the maximum size to be allocated if TYPE is of + self-referential size. */ +extern tree build_allocator (tree type, tree init, tree result_type, + Entity_Id gnat_proc, Entity_Id gnat_pool, + Node_Id gnat_node, bool); + +/* Fill in a VMS descriptor of GNU_TYPE for GNU_EXPR and return the result. + GNAT_ACTUAL is the actual parameter for which the descriptor is built. */ +extern tree fill_vms_descriptor (tree gnu_type, tree gnu_expr, + Node_Id gnat_actual); + +/* Indicate that we need to take the address of T and that it therefore + should not be allocated in a register. Returns true if successful. */ +extern bool gnat_mark_addressable (tree t); + +/* Save EXP for later use or reuse. This is equivalent to save_expr in tree.c + but we know how to handle our own nodes. */ +extern tree gnat_save_expr (tree exp); + +/* Protect EXP for immediate reuse. This is a variant of gnat_save_expr that + is optimized under the assumption that EXP's value doesn't change before + its subsequent reuse(s) except through its potential reevaluation. */ +extern tree gnat_protect_expr (tree exp); + +/* This is equivalent to stabilize_reference in tree.c but we know how to + handle our own nodes and we take extra arguments. FORCE says whether to + force evaluation of everything. We set SUCCESS to true unless we walk + through something we don't know how to stabilize. */ +extern tree gnat_stabilize_reference (tree ref, bool force, bool *success); + +/* Implementation of the builtin_function langhook. */ +extern tree gnat_builtin_function (tree decl); + +/* Search the chain of currently reachable declarations for a builtin + FUNCTION_DECL node corresponding to function NAME (an IDENTIFIER_NODE). + Return the first node found, if any, or NULL_TREE otherwise. */ +extern tree builtin_decl_for (tree name); + +/* GNU_TYPE is a type. Determine if it should be passed by reference by + default. */ +extern bool default_pass_by_ref (tree gnu_type); + +/* GNU_TYPE is the type of a subprogram parameter. Determine from the type + if it should be passed by reference. */ +extern bool must_pass_by_ref (tree gnu_type); + +/* Return the size of the FP mode with precision PREC. */ +extern int fp_prec_to_size (int prec); + +/* Return the precision of the FP mode with size SIZE. */ +extern int fp_size_to_prec (int size); + +/* These functions return the basic data type sizes and related parameters + about the target machine. */ + +extern Pos get_target_bits_per_unit (void); +extern Pos get_target_bits_per_word (void); +extern Pos get_target_char_size (void); +extern Pos get_target_wchar_t_size (void); +extern Pos get_target_short_size (void); +extern Pos get_target_int_size (void); +extern Pos get_target_long_size (void); +extern Pos get_target_long_long_size (void); +extern Pos get_target_float_size (void); +extern Pos get_target_double_size (void); +extern Pos get_target_long_double_size (void); +extern Pos get_target_pointer_size (void); +extern Pos get_target_maximum_default_alignment (void); +extern Pos get_target_default_allocator_alignment (void); +extern Pos get_target_maximum_allowed_alignment (void); +extern Pos get_target_maximum_alignment (void); +extern Nat get_float_words_be (void); +extern Nat get_words_be (void); +extern Nat get_bytes_be (void); +extern Nat get_bits_be (void); +extern Nat get_target_strict_alignment (void); +extern Nat get_target_double_float_alignment (void); +extern Nat get_target_double_scalar_alignment (void); + +/* Let code know whether we are targetting VMS without need of + intrusive preprocessor directives. */ +#ifndef TARGET_ABI_OPEN_VMS +#define TARGET_ABI_OPEN_VMS 0 +#endif + +/* VMS macro set by default, when clear forces 32bit mallocs and 32bit + Descriptors. Always used in combination with TARGET_ABI_OPEN_VMS + so no effect on non-VMS systems. */ +#ifndef TARGET_MALLOC64 +#define TARGET_MALLOC64 0 +#endif + +/* Convenient shortcuts. */ +#define VECTOR_TYPE_P(TYPE) (TREE_CODE (TYPE) == VECTOR_TYPE) diff --git a/gcc/ada/gcc-interface/lang-specs.h b/gcc/ada/gcc-interface/lang-specs.h new file mode 100644 index 000000000..5fd30b978 --- /dev/null +++ b/gcc/ada/gcc-interface/lang-specs.h @@ -0,0 +1,48 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * L A N G - S P E C S * + * * + * C Header File * + * * + * 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. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License along with GCC; see the file COPYING3. If 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 contribution to the `default_compilers' array in gcc.c for + GNAT. */ + + {".ads", "@ada", 0, 0, 0}, + {".adb", "@ada", 0, 0, 0}, + {"@ada", + "\ + %{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\ + %{!S:%{!c:%e-c or -S required for Ada}}\ + gnat1 %{I*} %{k8:-gnatk8} %{Wall:-gnatwa} %{w:-gnatws} %{!Q:-quiet}\ + %{nostdinc*} %{nostdlib*}\ + -dumpbase %{.adb:%b.adb}%{.ads:%b.ads}%{!.adb:%{!.ads:%b.ada}}\ + %{c|S:%{o*:-auxbase-strip %*}%{!o*:-auxbase %b}}%{!c:%{!S:-auxbase %b}} \ + %{O*} %{W*} %{w} %{p} %{pg:-p} %{d*} %{f*}\ + %{coverage:-fprofile-arcs -ftest-coverage} " + "%{gnatea:-gnatez} %{g*&m*} " +#if defined(TARGET_VXWORKS_RTP) + "%{fRTS=rtp:-mrtp} " +#endif + "%1 %{!S:%{o*:%w%*-gnatO}} \ + %i %{S:%W{o*}%{!o*:-o %b.s}} \ + %{gnatc*|gnats*: -o %j} %{-param*} \ + %{!gnatc*:%{!gnats*:%(invoke_as)}}", 0, 0, 0}, diff --git a/gcc/ada/gcc-interface/lang.opt b/gcc/ada/gcc-interface/lang.opt new file mode 100644 index 000000000..ce6ce89d6 --- /dev/null +++ b/gcc/ada/gcc-interface/lang.opt @@ -0,0 +1,119 @@ +; Options for the Ada front end. +; Copyright (C) 2003, 2007, 2008, 2010 Free Software Foundation, Inc. +; +; This file is part of GCC. +; +; GCC is free software; you can redistribute it and/or modify it under +; the terms of the GNU General Public License as published by the Free +; Software Foundation; either version 3, or (at your option) any later +; version. +; +; GCC is distributed in the hope that it will be useful, but WITHOUT ANY +; WARRANTY; without even the implied warranty of MERCHANTABILITY or +; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +; for more details. +; +; You should have received a copy of the GNU General Public License +; along with GCC; see the file COPYING3. If not see +; . + + +; See the GCC internals manual for a description of this file's format. + +; Please try to keep this file in ASCII collating order. + +Language +Ada + +-all-warnings +Ada Alias(Wall) + +-include-barrier +Ada Alias(I, -) + +-include-directory +Ada Separate Alias(I) + +-include-directory= +Ada Joined Alias(I) + +-no-standard-includes +Ada Alias(nostdinc) + +-no-standard-libraries +Ada Alias(nostdlib) + +I +Ada Joined Separate +; Documented for C + +Wall +Ada +; Documented for C + +Wmissing-prototypes +Ada +; Documented for C + +Wstrict-prototypes +Ada +; Documented for C + +Wwrite-strings +Ada +; Documented for C + +Wlong-long +Ada +; Documented for C + +Wvariadic-macros +Ada +; Documented for C + +Wold-style-definition +Ada +; Documented for C + +Wmissing-format-attribute +Ada +; Documented for C + +Woverlength-strings +Ada +; Documented for C + +k8 +Driver + +nostdinc +Ada RejectNegative +; Don't look for source files + +nostdlib +Ada +; Don't look for object files + +feliminate-unused-debug-types +Ada +; Effect documented for C - intercepted for Ada to force the associated flag +; not to be set by default, as it currently eliminates unreferenced parallel +; types we need for encoding descriptions to the debugger. + +fRTS= +Ada Joined RejectNegative +; Selects the runtime + +gant +Ada Joined Undocumented +; Catches typos + +gnatO +Ada Separate +; Sets name of output ALI file (internal switch) + +gnat +Ada Joined +-gnat Specify options to GNAT + +; This comment is to ensure we retain the blank line above. diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c new file mode 100644 index 000000000..4f7a5e1da --- /dev/null +++ b/gcc/ada/gcc-interface/misc.c @@ -0,0 +1,760 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * M I S C * + * * + * C Implementation File * + * * + * 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. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING3. If not see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tm.h" +#include "tree.h" +#include "diagnostic.h" +#include "target.h" +#include "ggc.h" +#include "flags.h" +#include "debug.h" +#include "toplev.h" +#include "langhooks.h" +#include "langhooks-def.h" +#include "opts.h" +#include "options.h" +#include "plugin.h" +#include "function.h" /* For pass_by_reference. */ + +#include "ada.h" +#include "adadecode.h" +#include "types.h" +#include "atree.h" +#include "elists.h" +#include "namet.h" +#include "nlists.h" +#include "stringt.h" +#include "uintp.h" +#include "fe.h" +#include "sinfo.h" +#include "einfo.h" +#include "ada-tree.h" +#include "gigi.h" + +/* This symbol needs to be defined for the front-end. */ +void *callgraph_info_file = NULL; + +/* Command-line argc and argv. These variables are global since they are + imported in back_end.adb. */ +unsigned int save_argc; +const char **save_argv; + +/* GNAT argc and argv. */ +extern int gnat_argc; +extern char **gnat_argv; + +/* Declare functions we use as part of startup. */ +extern void __gnat_initialize (void *); +extern void __gnat_install_SEH_handler (void *); +extern void adainit (void); +extern void _ada_gnat1drv (void); + +/* The parser for the language. For us, we process the GNAT tree. */ + +static void +gnat_parse_file (void) +{ + int seh[2]; + + /* Call the target specific initializations. */ + __gnat_initialize (NULL); + + /* ??? Call the SEH initialization routine. This is to workaround + a bootstrap path problem. The call below should be removed at some + point and the SEH pointer passed to __gnat_initialize() above. */ + __gnat_install_SEH_handler((void *)seh); + + /* Call the front-end elaboration procedures. */ + adainit (); + + /* Call the front end. */ + _ada_gnat1drv (); +} + +/* Decode all the language specific options that cannot be decoded by GCC. + The option decoding phase of GCC calls this routine on the flags that + are marked as Ada-specific. Return true on success or false on failure. */ + +static bool +gnat_handle_option (size_t scode, const char *arg ATTRIBUTE_UNUSED, int value, + int kind ATTRIBUTE_UNUSED, location_t loc ATTRIBUTE_UNUSED, + const struct cl_option_handlers *handlers ATTRIBUTE_UNUSED) +{ + enum opt_code code = (enum opt_code) scode; + + switch (code) + { + case OPT_Wall: + warn_unused = value; + warn_uninitialized = value; + break; + + case OPT_Wmissing_prototypes: + case OPT_Wstrict_prototypes: + case OPT_Wwrite_strings: + case OPT_Wlong_long: + case OPT_Wvariadic_macros: + case OPT_Wold_style_definition: + case OPT_Wmissing_format_attribute: + case OPT_Woverlength_strings: + /* These are used in the GCC Makefile. */ + break; + + case OPT_feliminate_unused_debug_types: + /* We arrange for post_option to be able to only set the corresponding + flag to 1 when explicitly requested by the user. We expect the + default flag value to be either 0 or positive, and expose a positive + -f as a negative value to post_option. */ + flag_eliminate_unused_debug_types = -value; + break; + + case OPT_gant: + warning (0, "%<-gnat%> misspelled as %<-gant%>"); + + /* ... fall through ... */ + + case OPT_gnat: + case OPT_gnatO: + case OPT_fRTS_: + case OPT_I: + case OPT_nostdinc: + case OPT_nostdlib: + /* These are handled by the front-end. */ + break; + + default: + gcc_unreachable (); + } + + return true; +} + +/* Return language mask for option processing. */ + +static unsigned int +gnat_option_lang_mask (void) +{ + return CL_Ada; +} + +/* Initialize options structure OPTS. */ + +static void +gnat_init_options_struct (struct gcc_options *opts) +{ + /* Uninitialized really means uninitialized in Ada. */ + opts->x_flag_zero_initialized_in_bss = 0; +} + +/* Initialize for option processing. */ + +static void +gnat_init_options (unsigned int decoded_options_count, + struct cl_decoded_option *decoded_options) +{ + /* Reconstruct an argv array for use of back_end.adb. + + ??? back_end.adb should not rely on this; instead, it should work with + decoded options without such reparsing, to ensure consistency in how + options are decoded. */ + unsigned int i; + + save_argv = XNEWVEC (const char *, 2 * decoded_options_count + 1); + save_argc = 0; + for (i = 0; i < decoded_options_count; i++) + { + size_t num_elements = decoded_options[i].canonical_option_num_elements; + + if (decoded_options[i].errors + || decoded_options[i].opt_index == OPT_SPECIAL_unknown + || num_elements == 0) + continue; + + /* Deal with -I- specially since it must be a single switch. */ + if (decoded_options[i].opt_index == OPT_I + && num_elements == 2 + && decoded_options[i].canonical_option[1][0] == '-' + && decoded_options[i].canonical_option[1][1] == '\0') + save_argv[save_argc++] = "-I-"; + else + { + gcc_assert (num_elements >= 1 && num_elements <= 2); + save_argv[save_argc++] = decoded_options[i].canonical_option[0]; + if (num_elements >= 2) + save_argv[save_argc++] = decoded_options[i].canonical_option[1]; + } + } + save_argv[save_argc] = NULL; + + gnat_argv = (char **) xmalloc (sizeof (save_argv[0])); + gnat_argv[0] = xstrdup (save_argv[0]); /* name of the command */ + gnat_argc = 1; +} + +/* Ada code requires variables for these settings rather than elements + of the global_options structure. */ +#undef optimize +#undef optimize_size +#undef flag_compare_debug +#undef flag_stack_check +int optimize; +int optimize_size; +int flag_compare_debug; +enum stack_check_type flag_stack_check = NO_STACK_CHECK; + +/* Post-switch processing. */ + +static bool +gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED) +{ + /* Excess precision other than "fast" requires front-end + support. */ + if (flag_excess_precision_cmdline == EXCESS_PRECISION_STANDARD + && TARGET_FLT_EVAL_METHOD_NON_DEFAULT) + sorry ("-fexcess-precision=standard for Ada"); + flag_excess_precision_cmdline = EXCESS_PRECISION_FAST; + + /* ??? The warning machinery is outsmarted by Ada. */ + warn_unused_parameter = 0; + + /* No psABI change warnings for Ada. */ + warn_psabi = 0; + + /* Force eliminate_unused_debug_types to 0 unless an explicit positive + -f has been passed. This forces the default to 0 for Ada, which might + differ from the common default. */ + if (flag_eliminate_unused_debug_types < 0) + flag_eliminate_unused_debug_types = 1; + else + flag_eliminate_unused_debug_types = 0; + + optimize = global_options.x_optimize; + optimize_size = global_options.x_optimize_size; + flag_compare_debug = global_options.x_flag_compare_debug; + flag_stack_check = global_options.x_flag_stack_check; + + return false; +} + +/* Here is the function to handle the compiler error processing in GCC. */ + +static void +internal_error_function (diagnostic_context *context, + const char *msgid, va_list *ap) +{ + text_info tinfo; + char *buffer, *p, *loc; + String_Template temp, temp_loc; + Fat_Pointer fp, fp_loc; + expanded_location s; + + /* Warn if plugins present. */ + warn_if_plugins (); + + /* Reset the pretty-printer. */ + pp_clear_output_area (context->printer); + + /* Format the message into the pretty-printer. */ + tinfo.format_spec = msgid; + tinfo.args_ptr = ap; + tinfo.err_no = errno; + pp_format_verbatim (context->printer, &tinfo); + + /* Extract a (writable) pointer to the formatted text. */ + buffer = xstrdup (pp_formatted_text (context->printer)); + + /* Go up to the first newline. */ + for (p = buffer; *p; p++) + if (*p == '\n') + { + *p = '\0'; + break; + } + + temp.Low_Bound = 1; + temp.High_Bound = p - buffer; + fp.Bounds = &temp; + fp.Array = buffer; + + s = expand_location (input_location); + if (context->show_column && s.column != 0) + asprintf (&loc, "%s:%d:%d", s.file, s.line, s.column); + else + asprintf (&loc, "%s:%d", s.file, s.line); + temp_loc.Low_Bound = 1; + temp_loc.High_Bound = strlen (loc); + fp_loc.Bounds = &temp_loc; + fp_loc.Array = loc; + + Current_Error_Node = error_gnat_node; + Compiler_Abort (fp, -1, fp_loc); +} + +/* Perform all the initialization steps that are language-specific. */ + +static bool +gnat_init (void) +{ + /* Do little here, most of the standard declarations are set up after the + front-end has been run. Use the same `char' as C, this doesn't really + matter since we'll use the explicit `unsigned char' for Character. */ + build_common_tree_nodes (flag_signed_char); + + /* In Ada, we use the unsigned type corresponding to the width of Pmode as + SIZETYPE. In most cases when ptr_mode and Pmode differ, C will use the + width of ptr_mode for SIZETYPE, but we get better code using the width + of Pmode. Note that, although we manipulate negative offsets for some + internal constructs and rely on compile time overflow detection in size + computations, using unsigned types for SIZETYPEs is fine since they are + treated specially by the middle-end, in particular sign-extended. */ + size_type_node = gnat_type_for_mode (Pmode, 1); + set_sizetype (size_type_node); + TYPE_NAME (sizetype) = get_identifier ("size_type"); + + /* In Ada, we use an unsigned 8-bit type for the default boolean type. */ + boolean_type_node = make_unsigned_type (8); + TREE_SET_CODE (boolean_type_node, BOOLEAN_TYPE); + SET_TYPE_RM_MAX_VALUE (boolean_type_node, + build_int_cst (boolean_type_node, 1)); + SET_TYPE_RM_SIZE (boolean_type_node, bitsize_int (1)); + + build_common_tree_nodes_2 (0); + sbitsize_one_node = sbitsize_int (1); + sbitsize_unit_node = sbitsize_int (BITS_PER_UNIT); + boolean_true_node = TYPE_MAX_VALUE (boolean_type_node); + + ptr_void_type_node = build_pointer_type (void_type_node); + + /* Show that REFERENCE_TYPEs are internal and should be Pmode. */ + internal_reference_types (); + + /* Register our internal error function. */ + global_dc->internal_error = &internal_error_function; + + return true; +} + +/* If we are using the GCC mechanism to process exception handling, we + have to register the personality routine for Ada and to initialize + various language dependent hooks. */ + +void +gnat_init_gcc_eh (void) +{ +#ifdef DWARF2_UNWIND_INFO + /* lang_dependent_init already called dwarf2out_frame_init if true. */ + int dwarf2out_frame_initialized = dwarf2out_do_frame (); +#endif + + /* We shouldn't do anything if the No_Exceptions_Handler pragma is set, + though. This could for instance lead to the emission of tables with + references to symbols (such as the Ada eh personality routine) within + libraries we won't link against. */ + if (No_Exception_Handlers_Set ()) + return; + + /* Tell GCC we are handling cleanup actions through exception propagation. + This opens possibilities that we don't take advantage of yet, but is + nonetheless necessary to ensure that fixup code gets assigned to the + right exception regions. */ + using_eh_for_cleanups (); + + /* Turn on -fexceptions and -fnon-call-exceptions. The first one triggers + the generation of the necessary exception tables. The second one is + useful for two reasons: 1/ we map some asynchronous signals like SEGV to + exceptions, so we need to ensure that the insns which can lead to such + signals are correctly attached to the exception region they pertain to, + 2/ Some calls to pure subprograms are handled as libcall blocks and then + marked as "cannot trap" if the flag is not set (see emit_libcall_block). + We should not let this be since it is possible for such calls to actually + raise in Ada. */ + flag_exceptions = 1; + flag_non_call_exceptions = 1; + + init_eh (); + +#ifdef DWARF2_UNWIND_INFO + if (!dwarf2out_frame_initialized && dwarf2out_do_frame ()) + dwarf2out_frame_init (); +#endif +} + +/* Print language-specific items in declaration NODE. */ + +static void +gnat_print_decl (FILE *file, tree node, int indent) +{ + switch (TREE_CODE (node)) + { + case CONST_DECL: + print_node (file, "corresponding var", + DECL_CONST_CORRESPONDING_VAR (node), indent + 4); + break; + + case FIELD_DECL: + print_node (file, "original field", DECL_ORIGINAL_FIELD (node), + indent + 4); + break; + + case VAR_DECL: + print_node (file, "renamed object", DECL_RENAMED_OBJECT (node), + indent + 4); + break; + + default: + break; + } +} + +/* Print language-specific items in type NODE. */ + +static void +gnat_print_type (FILE *file, tree node, int indent) +{ + switch (TREE_CODE (node)) + { + case FUNCTION_TYPE: + print_node (file, "ci/co list", TYPE_CI_CO_LIST (node), indent + 4); + break; + + case INTEGER_TYPE: + if (TYPE_MODULAR_P (node)) + print_node_brief (file, "modulus", TYPE_MODULUS (node), indent + 4); + else if (TYPE_HAS_ACTUAL_BOUNDS_P (node)) + print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node), + indent + 4); + else if (TYPE_VAX_FLOATING_POINT_P (node)) + ; + else + print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4); + + /* ... fall through ... */ + + case ENUMERAL_TYPE: + case BOOLEAN_TYPE: + print_node_brief (file, "RM size", TYPE_RM_SIZE (node), indent + 4); + + /* ... fall through ... */ + + case REAL_TYPE: + print_node_brief (file, "RM min", TYPE_RM_MIN_VALUE (node), indent + 4); + print_node_brief (file, "RM max", TYPE_RM_MAX_VALUE (node), indent + 4); + break; + + case ARRAY_TYPE: + print_node (file,"actual bounds", TYPE_ACTUAL_BOUNDS (node), indent + 4); + break; + + case VECTOR_TYPE: + print_node (file,"representative array", + TYPE_REPRESENTATIVE_ARRAY (node), indent + 4); + break; + + case RECORD_TYPE: + if (TYPE_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node)) + print_node (file, "unconstrained array", + TYPE_UNCONSTRAINED_ARRAY (node), indent + 4); + else + print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4); + break; + + case UNION_TYPE: + case QUAL_UNION_TYPE: + print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4); + break; + + default: + break; + } +} + +/* Return the name to be printed for DECL. */ + +static const char * +gnat_printable_name (tree decl, int verbosity) +{ + const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl)); + char *ada_name = (char *) ggc_alloc_atomic (strlen (coded_name) * 2 + 60); + + __gnat_decode (coded_name, ada_name, 0); + + if (verbosity == 2 && !DECL_IS_BUILTIN (decl)) + { + Set_Identifier_Casing (ada_name, DECL_SOURCE_FILE (decl)); + return ggc_strdup (Name_Buffer); + } + + return ada_name; +} + +/* Return the name to be used in DWARF debug info for DECL. */ + +static const char * +gnat_dwarf_name (tree decl, int verbosity ATTRIBUTE_UNUSED) +{ + gcc_assert (DECL_P (decl)); + return (const char *) IDENTIFIER_POINTER (DECL_NAME (decl)); +} + +/* Return true if types T1 and T2 are identical for type hashing purposes. + Called only after doing all language independent checks. At present, + this function is only called when both types are FUNCTION_TYPE. */ + +static bool +gnat_type_hash_eq (const_tree t1, const_tree t2) +{ + gcc_assert (TREE_CODE (t1) == FUNCTION_TYPE); + return fntype_same_flags_p (t1, TYPE_CI_CO_LIST (t2), + TYPE_RETURN_UNCONSTRAINED_P (t2), + TYPE_RETURN_BY_DIRECT_REF_P (t2), + TREE_ADDRESSABLE (t2)); +} + +/* Do nothing (return the tree node passed). */ + +static tree +gnat_return_tree (tree t) +{ + return t; +} + +/* Get the alias set corresponding to a type or expression. */ + +static alias_set_type +gnat_get_alias_set (tree type) +{ + /* If this is a padding type, use the type of the first field. */ + if (TYPE_IS_PADDING_P (type)) + return get_alias_set (TREE_TYPE (TYPE_FIELDS (type))); + + /* If the type is an unconstrained array, use the type of the + self-referential array we make. */ + else if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) + return + get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type))))); + + /* If the type can alias any other types, return the alias set 0. */ + else if (TYPE_P (type) + && TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (type))) + return 0; + + return -1; +} + +/* GNU_TYPE is a type. Return its maximum size in bytes, if known, + as a constant when possible. */ + +static tree +gnat_type_max_size (const_tree gnu_type) +{ + /* First see what we can get from TYPE_SIZE_UNIT, which might not + be constant even for simple expressions if it has already been + elaborated and possibly replaced by a VAR_DECL. */ + tree max_unitsize = max_size (TYPE_SIZE_UNIT (gnu_type), true); + + /* If we don't have a constant, see what we can get from TYPE_ADA_SIZE, + which should stay untouched. */ + if (!host_integerp (max_unitsize, 1) + && (TREE_CODE (gnu_type) == RECORD_TYPE + || TREE_CODE (gnu_type) == UNION_TYPE + || TREE_CODE (gnu_type) == QUAL_UNION_TYPE) + && TYPE_ADA_SIZE (gnu_type)) + { + tree max_adasize = max_size (TYPE_ADA_SIZE (gnu_type), true); + + /* If we have succeeded in finding a constant, round it up to the + type's alignment and return the result in units. */ + if (host_integerp (max_adasize, 1)) + max_unitsize + = size_binop (CEIL_DIV_EXPR, + round_up (max_adasize, TYPE_ALIGN (gnu_type)), + bitsize_unit_node); + } + + return max_unitsize; +} + +/* GNU_TYPE is a subtype of an integral type. Set LOWVAL to the low bound + and HIGHVAL to the high bound, respectively. */ + +static void +gnat_get_subrange_bounds (const_tree gnu_type, tree *lowval, tree *highval) +{ + *lowval = TYPE_MIN_VALUE (gnu_type); + *highval = TYPE_MAX_VALUE (gnu_type); +} + +/* GNU_TYPE is the type of a subprogram parameter. Determine if it should be + passed by reference by default. */ + +bool +default_pass_by_ref (tree gnu_type) +{ + /* We pass aggregates by reference if they are sufficiently large. The + choice of constant here is somewhat arbitrary. We also pass by + reference if the target machine would either pass or return by + reference. Strictly speaking, we need only check the return if this + is an In Out parameter, but it's probably best to err on the side of + passing more things by reference. */ + + if (pass_by_reference (NULL, TYPE_MODE (gnu_type), gnu_type, true)) + return true; + + if (targetm.calls.return_in_memory (gnu_type, NULL_TREE)) + return true; + + if (AGGREGATE_TYPE_P (gnu_type) + && (!host_integerp (TYPE_SIZE (gnu_type), 1) + || 0 < compare_tree_int (TYPE_SIZE (gnu_type), + 8 * TYPE_ALIGN (gnu_type)))) + return true; + + return false; +} + +/* GNU_TYPE is the type of a subprogram parameter. Determine if it must be + passed by reference. */ + +bool +must_pass_by_ref (tree gnu_type) +{ + /* We pass only unconstrained objects, those required by the language + to be passed by reference, and objects of variable size. The latter + is more efficient, avoids problems with variable size temporaries, + and does not produce compatibility problems with C, since C does + not have such objects. */ + return (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE + || TREE_ADDRESSABLE (gnu_type) + || (TYPE_SIZE (gnu_type) + && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST)); +} + +/* Return the size of the FP mode with precision PREC. */ + +int +fp_prec_to_size (int prec) +{ + enum machine_mode mode; + + for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode; + mode = GET_MODE_WIDER_MODE (mode)) + if (GET_MODE_PRECISION (mode) == prec) + return GET_MODE_BITSIZE (mode); + + gcc_unreachable (); +} + +/* Return the precision of the FP mode with size SIZE. */ + +int +fp_size_to_prec (int size) +{ + enum machine_mode mode; + + for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode; + mode = GET_MODE_WIDER_MODE (mode)) + if (GET_MODE_BITSIZE (mode) == size) + return GET_MODE_PRECISION (mode); + + gcc_unreachable (); +} + +static GTY(()) tree gnat_eh_personality_decl; + +/* Return the GNAT personality function decl. */ + +static tree +gnat_eh_personality (void) +{ + if (!gnat_eh_personality_decl) + gnat_eh_personality_decl = build_personality_function ("gnat"); + return gnat_eh_personality_decl; +} + +/* Definitions for our language-specific hooks. */ + +#undef LANG_HOOKS_NAME +#define LANG_HOOKS_NAME "GNU Ada" +#undef LANG_HOOKS_IDENTIFIER_SIZE +#define LANG_HOOKS_IDENTIFIER_SIZE sizeof (struct tree_identifier) +#undef LANG_HOOKS_INIT +#define LANG_HOOKS_INIT gnat_init +#undef LANG_HOOKS_OPTION_LANG_MASK +#define LANG_HOOKS_OPTION_LANG_MASK gnat_option_lang_mask +#undef LANG_HOOKS_INIT_OPTIONS_STRUCT +#define LANG_HOOKS_INIT_OPTIONS_STRUCT gnat_init_options_struct +#undef LANG_HOOKS_INIT_OPTIONS +#define LANG_HOOKS_INIT_OPTIONS gnat_init_options +#undef LANG_HOOKS_HANDLE_OPTION +#define LANG_HOOKS_HANDLE_OPTION gnat_handle_option +#undef LANG_HOOKS_POST_OPTIONS +#define LANG_HOOKS_POST_OPTIONS gnat_post_options +#undef LANG_HOOKS_PARSE_FILE +#define LANG_HOOKS_PARSE_FILE gnat_parse_file +#undef LANG_HOOKS_TYPE_HASH_EQ +#define LANG_HOOKS_TYPE_HASH_EQ gnat_type_hash_eq +#undef LANG_HOOKS_GETDECLS +#define LANG_HOOKS_GETDECLS lhd_return_null_tree_v +#undef LANG_HOOKS_PUSHDECL +#define LANG_HOOKS_PUSHDECL gnat_return_tree +#undef LANG_HOOKS_WRITE_GLOBALS +#define LANG_HOOKS_WRITE_GLOBALS gnat_write_global_declarations +#undef LANG_HOOKS_GET_ALIAS_SET +#define LANG_HOOKS_GET_ALIAS_SET gnat_get_alias_set +#undef LANG_HOOKS_PRINT_DECL +#define LANG_HOOKS_PRINT_DECL gnat_print_decl +#undef LANG_HOOKS_PRINT_TYPE +#define LANG_HOOKS_PRINT_TYPE gnat_print_type +#undef LANG_HOOKS_TYPE_MAX_SIZE +#define LANG_HOOKS_TYPE_MAX_SIZE gnat_type_max_size +#undef LANG_HOOKS_DECL_PRINTABLE_NAME +#define LANG_HOOKS_DECL_PRINTABLE_NAME gnat_printable_name +#undef LANG_HOOKS_DWARF_NAME +#define LANG_HOOKS_DWARF_NAME gnat_dwarf_name +#undef LANG_HOOKS_GIMPLIFY_EXPR +#define LANG_HOOKS_GIMPLIFY_EXPR gnat_gimplify_expr +#undef LANG_HOOKS_TYPE_FOR_MODE +#define LANG_HOOKS_TYPE_FOR_MODE gnat_type_for_mode +#undef LANG_HOOKS_TYPE_FOR_SIZE +#define LANG_HOOKS_TYPE_FOR_SIZE gnat_type_for_size +#undef LANG_HOOKS_TYPES_COMPATIBLE_P +#define LANG_HOOKS_TYPES_COMPATIBLE_P gnat_types_compatible_p +#undef LANG_HOOKS_GET_SUBRANGE_BOUNDS +#define LANG_HOOKS_GET_SUBRANGE_BOUNDS gnat_get_subrange_bounds +#undef LANG_HOOKS_ATTRIBUTE_TABLE +#define LANG_HOOKS_ATTRIBUTE_TABLE gnat_internal_attribute_table +#undef LANG_HOOKS_BUILTIN_FUNCTION +#define LANG_HOOKS_BUILTIN_FUNCTION gnat_builtin_function +#undef LANG_HOOKS_EH_PERSONALITY +#define LANG_HOOKS_EH_PERSONALITY gnat_eh_personality +#undef LANG_HOOKS_DEEP_UNSHARING +#define LANG_HOOKS_DEEP_UNSHARING true + +struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER; + +#include "gt-ada-misc.h" diff --git a/gcc/ada/gcc-interface/targtyps.c b/gcc/ada/gcc-interface/targtyps.c new file mode 100644 index 000000000..b31fee311 --- /dev/null +++ b/gcc/ada/gcc-interface/targtyps.c @@ -0,0 +1,261 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * T A R G T Y P S * + * * + * Body * + * * + * 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. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING3. If not see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* Functions for retrieving target types. See Ada package Get_Targ */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "tm.h" +#include "tm_p.h" + +#include "ada.h" +#include "types.h" +#include "atree.h" +#include "elists.h" +#include "namet.h" +#include "nlists.h" +#include "snames.h" +#include "stringt.h" +#include "uintp.h" +#include "urealp.h" +#include "fe.h" +#include "sinfo.h" +#include "einfo.h" +#include "ada-tree.h" +#include "gigi.h" + +/* If we don't have a specific size for Ada's equivalent of `long', use that + of C. */ +#ifndef ADA_LONG_TYPE_SIZE +#define ADA_LONG_TYPE_SIZE LONG_TYPE_SIZE +#endif + +#ifndef WIDEST_HARDWARE_FP_SIZE +#define WIDEST_HARDWARE_FP_SIZE LONG_DOUBLE_TYPE_SIZE +#endif + +/* The following provide a functional interface for the front end Ada code + to determine the sizes that are used for various C types. */ + +Pos +get_target_bits_per_unit (void) +{ + return BITS_PER_UNIT; +} + +Pos +get_target_bits_per_word (void) +{ + return BITS_PER_WORD; +} + +Pos +get_target_char_size (void) +{ + return CHAR_TYPE_SIZE; +} + +Pos +get_target_wchar_t_size (void) +{ + /* We never want wide characters less than "short" in Ada. */ + return MAX (SHORT_TYPE_SIZE, WCHAR_TYPE_SIZE); +} + +Pos +get_target_short_size (void) +{ + return SHORT_TYPE_SIZE; +} + +Pos +get_target_int_size (void) +{ + return INT_TYPE_SIZE; +} + +Pos +get_target_long_size (void) +{ + return ADA_LONG_TYPE_SIZE; +} + +Pos +get_target_long_long_size (void) +{ + return LONG_LONG_TYPE_SIZE; +} + +Pos +get_target_float_size (void) +{ + return fp_prec_to_size (FLOAT_TYPE_SIZE); +} + +Pos +get_target_double_size (void) +{ + return fp_prec_to_size (DOUBLE_TYPE_SIZE); +} + +Pos +get_target_long_double_size (void) +{ + return fp_prec_to_size (WIDEST_HARDWARE_FP_SIZE); +} + +Pos +get_target_pointer_size (void) +{ + return POINTER_SIZE; +} + +/* Alignment related values, mapped to attributes for functional and + documentation purposes. */ + +/* Standard'Maximum_Default_Alignment. Maximum alignment that the compiler + might choose by default for a type or object. + + Stricter alignment requests trigger gigi's aligning_type circuitry for + stack objects or objects allocated by the default allocator. */ + +Pos +get_target_maximum_default_alignment (void) +{ + return BIGGEST_ALIGNMENT / BITS_PER_UNIT; +} + +/* Standard'Default_Allocator_Alignment. Alignment guaranteed to be honored + by the default allocator (System.Memory.Alloc or malloc if we have no + run-time library at hand). + + Stricter alignment requests trigger gigi's aligning_type circuitry for + objects allocated by the default allocator. */ + +/* ??? Need a way to get info about __gnat_malloc from here (whether it is + handy and what alignment it honors). In the meantime, resort to malloc + considerations only. */ + +/* Account for MALLOC_OBSERVABLE_ALIGNMENTs here. Use this or the ABI + guaranteed alignment if greater. */ + +#ifdef MALLOC_OBSERVABLE_ALIGNMENT +#define MALLOC_ALIGNMENT MALLOC_OBSERVABLE_ALIGNMENT +#else +#define MALLOC_OBSERVABLE_ALIGNMENT (2 * LONG_TYPE_SIZE) +#define MALLOC_ALIGNMENT \ + MAX (MALLOC_ABI_ALIGNMENT, MALLOC_OBSERVABLE_ALIGNMENT) +#endif + +Pos +get_target_default_allocator_alignment (void) +{ + return MALLOC_ALIGNMENT / BITS_PER_UNIT; +} + +/* Standard'Maximum_Allowed_Alignment. Maximum alignment that we may + accept for any type or object. */ + +#ifndef MAX_OFILE_ALIGNMENT +#define MAX_OFILE_ALIGNMENT BIGGEST_ALIGNMENT +#endif + +Pos +get_target_maximum_allowed_alignment (void) +{ + return MAX_OFILE_ALIGNMENT / BITS_PER_UNIT; +} + +/* Standard'Maximum_Alignment. The single attribute initially made + available, now a synonym of Standard'Maximum_Default_Alignment. */ + +Pos +get_target_maximum_alignment (void) +{ + return get_target_maximum_default_alignment (); +} + +#ifndef FLOAT_WORDS_BIG_ENDIAN +#define FLOAT_WORDS_BIG_ENDIAN WORDS_BIG_ENDIAN +#endif + +Nat +get_float_words_be (void) +{ + return FLOAT_WORDS_BIG_ENDIAN; +} + +Nat +get_words_be (void) +{ + return WORDS_BIG_ENDIAN; +} + +Nat +get_bytes_be (void) +{ + return BYTES_BIG_ENDIAN; +} + +Nat +get_bits_be (void) +{ + return BITS_BIG_ENDIAN; +} + +Nat +get_target_strict_alignment (void) +{ + return STRICT_ALIGNMENT; +} + +Nat +get_target_double_float_alignment (void) +{ +#ifdef TARGET_ALIGN_NATURAL + /* This macro is only defined by the rs6000 port. */ + if (!TARGET_ALIGN_NATURAL + && (DEFAULT_ABI == ABI_AIX || DEFAULT_ABI == ABI_DARWIN)) + return 32 / BITS_PER_UNIT; +#endif + return 0; +} + +Nat +get_target_double_scalar_alignment (void) +{ +#ifdef TARGET_ALIGN_DOUBLE + /* This macro is only defined by the i386 and sh ports. */ + if (!TARGET_ALIGN_DOUBLE +#ifdef TARGET_64BIT + && !TARGET_64BIT +#endif + ) + return 32 / BITS_PER_UNIT; +#endif + return 0; +} diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c new file mode 100644 index 000000000..e84ff3652 --- /dev/null +++ b/gcc/ada/gcc-interface/trans.c @@ -0,0 +1,8007 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * T R A N S * + * * + * C Implementation File * + * * + * 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. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING3. If not see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tm.h" +#include "tree.h" +#include "flags.h" +#include "ggc.h" +#include "output.h" +#include "libfuncs.h" /* For set_stack_check_libfunc. */ +#include "tree-iterator.h" +#include "gimple.h" + +#include "ada.h" +#include "adadecode.h" +#include "types.h" +#include "atree.h" +#include "elists.h" +#include "namet.h" +#include "nlists.h" +#include "snames.h" +#include "stringt.h" +#include "uintp.h" +#include "urealp.h" +#include "fe.h" +#include "sinfo.h" +#include "einfo.h" +#include "gadaint.h" +#include "ada-tree.h" +#include "gigi.h" + +/* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca, + for fear of running out of stack space. If we need more, we use xmalloc + instead. */ +#define ALLOCA_THRESHOLD 1000 + +/* Let code below know whether we are targetting VMS without need of + intrusive preprocessor directives. */ +#ifndef TARGET_ABI_OPEN_VMS +#define TARGET_ABI_OPEN_VMS 0 +#endif + +/* In configurations where blocks have no end_locus attached, just + sink assignments into a dummy global. */ +#ifndef BLOCK_SOURCE_END_LOCATION +static location_t block_end_locus_sink; +#define BLOCK_SOURCE_END_LOCATION(BLOCK) block_end_locus_sink +#endif + +/* For efficient float-to-int rounding, it is necessary to know whether + floating-point arithmetic may use wider intermediate results. When + FP_ARITH_MAY_WIDEN is not defined, be conservative and only assume + that arithmetic does not widen if double precision is emulated. */ +#ifndef FP_ARITH_MAY_WIDEN +#if defined(HAVE_extendsfdf2) +#define FP_ARITH_MAY_WIDEN HAVE_extendsfdf2 +#else +#define FP_ARITH_MAY_WIDEN 0 +#endif +#endif + +/* Pointers to front-end tables accessed through macros. */ +struct Node *Nodes_Ptr; +Node_Id *Next_Node_Ptr; +Node_Id *Prev_Node_Ptr; +struct Elist_Header *Elists_Ptr; +struct Elmt_Item *Elmts_Ptr; +struct String_Entry *Strings_Ptr; +Char_Code *String_Chars_Ptr; +struct List_Header *List_Headers_Ptr; + +/* Highest number in the front-end node table. */ +int max_gnat_nodes; + +/* Current node being treated, in case abort called. */ +Node_Id error_gnat_node; + +/* True when gigi is being called on an analyzed but unexpanded + tree, and the only purpose of the call is to properly annotate + types with representation information. */ +bool type_annotate_only; + +/* Current filename without path. */ +const char *ref_filename; + +/* When not optimizing, we cache the 'First, 'Last and 'Length attributes + of unconstrained array IN parameters to avoid emitting a great deal of + redundant instructions to recompute them each time. */ +struct GTY (()) parm_attr_d { + int id; /* GTY doesn't like Entity_Id. */ + int dim; + tree first; + tree last; + tree length; +}; + +typedef struct parm_attr_d *parm_attr; + +DEF_VEC_P(parm_attr); +DEF_VEC_ALLOC_P(parm_attr,gc); + +struct GTY(()) language_function { + VEC(parm_attr,gc) *parm_attr_cache; +}; + +#define f_parm_attr_cache \ + DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache + +/* A structure used to gather together information about a statement group. + We use this to gather related statements, for example the "then" part + of a IF. In the case where it represents a lexical scope, we may also + have a BLOCK node corresponding to it and/or cleanups. */ + +struct GTY((chain_next ("%h.previous"))) stmt_group { + struct stmt_group *previous; /* Previous code group. */ + tree stmt_list; /* List of statements for this code group. */ + tree block; /* BLOCK for this code group, if any. */ + tree cleanups; /* Cleanups for this code group, if any. */ +}; + +static GTY(()) struct stmt_group *current_stmt_group; + +/* List of unused struct stmt_group nodes. */ +static GTY((deletable)) struct stmt_group *stmt_group_free_list; + +/* A structure used to record information on elaboration procedures + we've made and need to process. + + ??? gnat_node should be Node_Id, but gengtype gets confused. */ + +struct GTY((chain_next ("%h.next"))) elab_info { + struct elab_info *next; /* Pointer to next in chain. */ + tree elab_proc; /* Elaboration procedure. */ + int gnat_node; /* The N_Compilation_Unit. */ +}; + +static GTY(()) struct elab_info *elab_info_list; + +/* Stack of exception pointer variables. Each entry is the VAR_DECL + that stores the address of the raised exception. Nonzero means we + are in an exception handler. Not used in the zero-cost case. */ +static GTY(()) VEC(tree,gc) *gnu_except_ptr_stack; + +/* Stack for storing the current elaboration procedure decl. */ +static GTY(()) VEC(tree,gc) *gnu_elab_proc_stack; + +/* Stack of labels to be used as a goto target instead of a return in + some functions. See processing for N_Subprogram_Body. */ +static GTY(()) VEC(tree,gc) *gnu_return_label_stack; + +/* Stack of variable for the return value of a function with copy-in/copy-out + parameters. See processing for N_Subprogram_Body. */ +static GTY(()) VEC(tree,gc) *gnu_return_var_stack; + +/* Stack of LOOP_STMT nodes. */ +static GTY(()) VEC(tree,gc) *gnu_loop_label_stack; + +/* The stacks for N_{Push,Pop}_*_Label. */ +static GTY(()) VEC(tree,gc) *gnu_constraint_error_label_stack; +static GTY(()) VEC(tree,gc) *gnu_storage_error_label_stack; +static GTY(()) VEC(tree,gc) *gnu_program_error_label_stack; + +/* Map GNAT tree codes to GCC tree codes for simple expressions. */ +static enum tree_code gnu_codes[Number_Node_Kinds]; + +static void init_code_table (void); +static void Compilation_Unit_to_gnu (Node_Id); +static void record_code_position (Node_Id); +static void insert_code_for (Node_Id); +static void add_cleanup (tree, Node_Id); +static void add_stmt_list (List_Id); +static void push_exception_label_stack (VEC(tree,gc) **, Entity_Id); +static tree build_stmt_group (List_Id, bool); +static enum gimplify_status gnat_gimplify_stmt (tree *); +static void elaborate_all_entities (Node_Id); +static void process_freeze_entity (Node_Id); +static void process_decls (List_Id, List_Id, Node_Id, bool, bool); +static tree emit_range_check (tree, Node_Id, Node_Id); +static tree emit_index_check (tree, tree, tree, tree, Node_Id); +static tree emit_check (tree, tree, int, Node_Id); +static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id); +static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id); +static tree convert_with_check (Entity_Id, tree, bool, bool, bool, Node_Id); +static bool smaller_form_type_p (tree, tree); +static bool addressable_p (tree, tree); +static tree assoc_to_constructor (Entity_Id, Node_Id, tree); +static tree extract_values (tree, tree); +static tree pos_to_constructor (Node_Id, tree, Entity_Id); +static tree maybe_implicit_deref (tree); +static void set_expr_location_from_node (tree, Node_Id); +static bool set_end_locus_from_node (tree, Node_Id); +static void set_gnu_expr_location_from_node (tree, Node_Id); +static int lvalue_required_p (Node_Id, tree, bool, bool, bool); +static tree build_raise_check (int, tree, enum exception_info_kind); + +/* Hooks for debug info back-ends, only supported and used in a restricted set + of configurations. */ +static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED; +static const char *decode_name (const char *) ATTRIBUTE_UNUSED; + +/* This is the main program of the back-end. It sets up all the table + structures and then generates code. */ + +void +gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, + struct Node *nodes_ptr, Node_Id *next_node_ptr, Node_Id *prev_node_ptr, + struct Elist_Header *elists_ptr, struct Elmt_Item *elmts_ptr, + struct String_Entry *strings_ptr, Char_Code *string_chars_ptr, + struct List_Header *list_headers_ptr, Nat number_file, + struct File_Info_Type *file_info_ptr, + Entity_Id standard_boolean, Entity_Id standard_integer, + Entity_Id standard_character, Entity_Id standard_long_long_float, + Entity_Id standard_exception_type, Int gigi_operating_mode) +{ + Entity_Id gnat_literal; + tree long_long_float_type, exception_type, t; + tree int64_type = gnat_type_for_size (64, 0); + struct elab_info *info; + int i; + + max_gnat_nodes = max_gnat_node; + + Nodes_Ptr = nodes_ptr; + Next_Node_Ptr = next_node_ptr; + Prev_Node_Ptr = prev_node_ptr; + Elists_Ptr = elists_ptr; + Elmts_Ptr = elmts_ptr; + Strings_Ptr = strings_ptr; + String_Chars_Ptr = string_chars_ptr; + List_Headers_Ptr = list_headers_ptr; + + type_annotate_only = (gigi_operating_mode == 1); + + gcc_assert (Nkind (gnat_root) == N_Compilation_Unit); + + /* Declare the name of the compilation unit as the first global + name in order to make the middle-end fully deterministic. */ + t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL); + first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t)); + + for (i = 0; i < number_file; i++) + { + /* Use the identifier table to make a permanent copy of the filename as + the name table gets reallocated after Gigi returns but before all the + debugging information is output. The __gnat_to_canonical_file_spec + call translates filenames from pragmas Source_Reference that contain + host style syntax not understood by gdb. */ + const char *filename + = IDENTIFIER_POINTER + (get_identifier + (__gnat_to_canonical_file_spec + (Get_Name_String (file_info_ptr[i].File_Name)))); + + /* We rely on the order isomorphism between files and line maps. */ + gcc_assert ((int) line_table->used == i); + + /* We create the line map for a source file at once, with a fixed number + of columns chosen to avoid jumping over the next power of 2. */ + linemap_add (line_table, LC_ENTER, 0, filename, 1); + linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252); + linemap_position_for_column (line_table, 252 - 1); + linemap_add (line_table, LC_LEAVE, 0, NULL, 0); + } + + /* Initialize ourselves. */ + init_code_table (); + init_gnat_to_gnu (); + init_dummy_type (); + + /* If we are just annotating types, give VOID_TYPE zero sizes to avoid + errors. */ + if (type_annotate_only) + { + TYPE_SIZE (void_type_node) = bitsize_zero_node; + TYPE_SIZE_UNIT (void_type_node) = size_zero_node; + } + + /* Enable GNAT stack checking method if needed */ + if (!Stack_Check_Probes_On_Target) + set_stack_check_libfunc ("_gnat_stack_check"); + + /* Retrieve alignment settings. */ + double_float_alignment = get_target_double_float_alignment (); + double_scalar_alignment = get_target_double_scalar_alignment (); + + /* Record the builtin types. Define `integer' and `character' first so that + dbx will output them first. */ + record_builtin_type ("integer", integer_type_node); + record_builtin_type ("character", unsigned_char_type_node); + record_builtin_type ("boolean", boolean_type_node); + record_builtin_type ("void", void_type_node); + + /* Save the type we made for integer as the type for Standard.Integer. */ + save_gnu_tree (Base_Type (standard_integer), + TYPE_NAME (integer_type_node), + false); + + /* Likewise for character as the type for Standard.Character. */ + save_gnu_tree (Base_Type (standard_character), + TYPE_NAME (unsigned_char_type_node), + false); + + /* Likewise for boolean as the type for Standard.Boolean. */ + save_gnu_tree (Base_Type (standard_boolean), + TYPE_NAME (boolean_type_node), + false); + gnat_literal = First_Literal (Base_Type (standard_boolean)); + t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node); + gcc_assert (t == boolean_false_node); + t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE, + boolean_type_node, t, true, false, false, false, + NULL, gnat_literal); + DECL_IGNORED_P (t) = 1; + save_gnu_tree (gnat_literal, t, false); + gnat_literal = Next_Literal (gnat_literal); + t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node); + gcc_assert (t == boolean_true_node); + t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE, + boolean_type_node, t, true, false, false, false, + NULL, gnat_literal); + DECL_IGNORED_P (t) = 1; + save_gnu_tree (gnat_literal, t, false); + + void_ftype = build_function_type (void_type_node, NULL_TREE); + ptr_void_ftype = build_pointer_type (void_ftype); + + /* Now declare run-time functions. */ + t = tree_cons (NULL_TREE, void_type_node, NULL_TREE); + + /* malloc is a function declaration tree for a function to allocate + memory. */ + malloc_decl + = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE, + build_function_type (ptr_void_type_node, + tree_cons (NULL_TREE, + sizetype, t)), + NULL_TREE, false, true, true, NULL, Empty); + DECL_IS_MALLOC (malloc_decl) = 1; + + /* malloc32 is a function declaration tree for a function to allocate + 32-bit memory on a 64-bit system. Needed only on 64-bit VMS. */ + malloc32_decl + = create_subprog_decl (get_identifier ("__gnat_malloc32"), NULL_TREE, + build_function_type (ptr_void_type_node, + tree_cons (NULL_TREE, + sizetype, t)), + NULL_TREE, false, true, true, NULL, Empty); + DECL_IS_MALLOC (malloc32_decl) = 1; + + /* free is a function declaration tree for a function to free memory. */ + free_decl + = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE, + build_function_type (void_type_node, + tree_cons (NULL_TREE, + ptr_void_type_node, + t)), + NULL_TREE, false, true, true, NULL, Empty); + + /* This is used for 64-bit multiplication with overflow checking. */ + mulv64_decl + = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE, + build_function_type_list (int64_type, int64_type, + int64_type, NULL_TREE), + NULL_TREE, false, true, true, NULL, Empty); + + /* Name of the _Parent field in tagged record types. */ + parent_name_id = get_identifier (Get_Name_String (Name_uParent)); + + /* Name of the Exception_Data type defined in System.Standard_Library. */ + exception_data_name_id + = get_identifier ("system__standard_library__exception_data"); + + /* Make the types and functions used for exception processing. */ + jmpbuf_type + = build_array_type (gnat_type_for_mode (Pmode, 0), + build_index_type (size_int (5))); + record_builtin_type ("JMPBUF_T", jmpbuf_type); + jmpbuf_ptr_type = build_pointer_type (jmpbuf_type); + + /* Functions to get and set the jumpbuf pointer for the current thread. */ + get_jmpbuf_decl + = create_subprog_decl + (get_identifier ("system__soft_links__get_jmpbuf_address_soft"), + NULL_TREE, build_function_type (jmpbuf_ptr_type, NULL_TREE), + NULL_TREE, false, true, true, NULL, Empty); + DECL_IGNORED_P (get_jmpbuf_decl) = 1; + + set_jmpbuf_decl + = create_subprog_decl + (get_identifier ("system__soft_links__set_jmpbuf_address_soft"), + NULL_TREE, + build_function_type (void_type_node, + tree_cons (NULL_TREE, jmpbuf_ptr_type, t)), + NULL_TREE, false, true, true, NULL, Empty); + DECL_IGNORED_P (set_jmpbuf_decl) = 1; + + /* setjmp returns an integer and has one operand, which is a pointer to + a jmpbuf. */ + setjmp_decl + = create_subprog_decl + (get_identifier ("__builtin_setjmp"), NULL_TREE, + build_function_type (integer_type_node, + tree_cons (NULL_TREE, jmpbuf_ptr_type, t)), + NULL_TREE, false, true, true, NULL, Empty); + DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL; + DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP; + + /* update_setjmp_buf updates a setjmp buffer from the current stack pointer + address. */ + update_setjmp_buf_decl + = create_subprog_decl + (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE, + build_function_type (void_type_node, + tree_cons (NULL_TREE, jmpbuf_ptr_type, t)), + NULL_TREE, false, true, true, NULL, Empty); + DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL; + DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF; + + /* Hooks to call when entering/leaving an exception handler. */ + begin_handler_decl + = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE, + build_function_type (void_type_node, + tree_cons (NULL_TREE, + ptr_void_type_node, + t)), + NULL_TREE, false, true, true, NULL, Empty); + DECL_IGNORED_P (begin_handler_decl) = 1; + + end_handler_decl + = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE, + build_function_type (void_type_node, + tree_cons (NULL_TREE, + ptr_void_type_node, + t)), + NULL_TREE, false, true, true, NULL, Empty); + DECL_IGNORED_P (end_handler_decl) = 1; + + /* If in no exception handlers mode, all raise statements are redirected to + __gnat_last_chance_handler. No need to redefine raise_nodefer_decl since + this procedure will never be called in this mode. */ + if (No_Exception_Handlers_Set ()) + { + tree decl + = create_subprog_decl + (get_identifier ("__gnat_last_chance_handler"), NULL_TREE, + build_function_type (void_type_node, + tree_cons (NULL_TREE, + build_pointer_type + (unsigned_char_type_node), + tree_cons (NULL_TREE, + integer_type_node, + t))), + NULL_TREE, false, true, true, NULL, Empty); + TREE_THIS_VOLATILE (decl) = 1; + TREE_SIDE_EFFECTS (decl) = 1; + TREE_TYPE (decl) + = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE); + for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++) + gnat_raise_decls[i] = decl; + } + else + { + /* Otherwise, make one decl for each exception reason. */ + for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++) + gnat_raise_decls[i] = build_raise_check (i, t, exception_simple); + for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls_ext); i++) + gnat_raise_decls_ext[i] + = build_raise_check (i, t, + i == CE_Index_Check_Failed + || i == CE_Range_Check_Failed + || i == CE_Invalid_Data + ? exception_range : exception_column); + } + + /* Set the types that GCC and Gigi use from the front end. */ + exception_type + = gnat_to_gnu_entity (Base_Type (standard_exception_type), NULL_TREE, 0); + except_type_node = TREE_TYPE (exception_type); + + /* Make other functions used for exception processing. */ + get_excptr_decl + = create_subprog_decl + (get_identifier ("system__soft_links__get_gnat_exception"), + NULL_TREE, + build_function_type (build_pointer_type (except_type_node), NULL_TREE), + NULL_TREE, false, true, true, NULL, Empty); + + raise_nodefer_decl + = create_subprog_decl + (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE, + build_function_type (void_type_node, + tree_cons (NULL_TREE, + build_pointer_type (except_type_node), + t)), + NULL_TREE, false, true, true, NULL, Empty); + + /* Indicate that these never return. */ + TREE_THIS_VOLATILE (raise_nodefer_decl) = 1; + TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1; + TREE_TYPE (raise_nodefer_decl) + = build_qualified_type (TREE_TYPE (raise_nodefer_decl), + TYPE_QUAL_VOLATILE); + + /* Build the special descriptor type and its null node if needed. */ + if (TARGET_VTABLE_USES_DESCRIPTORS) + { + tree null_node = fold_convert (ptr_void_ftype, null_pointer_node); + tree field_list = NULL_TREE; + int j; + VEC(constructor_elt,gc) *null_vec = NULL; + constructor_elt *elt; + + fdesc_type_node = make_node (RECORD_TYPE); + VEC_safe_grow (constructor_elt, gc, null_vec, + TARGET_VTABLE_USES_DESCRIPTORS); + elt = (VEC_address (constructor_elt,null_vec) + + TARGET_VTABLE_USES_DESCRIPTORS - 1); + + for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++) + { + tree field + = create_field_decl (NULL_TREE, ptr_void_ftype, fdesc_type_node, + NULL_TREE, NULL_TREE, 0, 1); + TREE_CHAIN (field) = field_list; + field_list = field; + elt->index = field; + elt->value = null_node; + elt--; + } + + finish_record_type (fdesc_type_node, nreverse (field_list), 0, false); + record_builtin_type ("descriptor", fdesc_type_node); + null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_vec); + } + + long_long_float_type + = gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0); + + if (TREE_CODE (TREE_TYPE (long_long_float_type)) == INTEGER_TYPE) + { + /* In this case, the builtin floating point types are VAX float, + so make up a type for use. */ + longest_float_type_node = make_node (REAL_TYPE); + TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE; + layout_type (longest_float_type_node); + record_builtin_type ("longest float type", longest_float_type_node); + } + else + longest_float_type_node = TREE_TYPE (long_long_float_type); + + /* Dummy objects to materialize "others" and "all others" in the exception + tables. These are exported by a-exexpr.adb, so see this unit for the + types to use. */ + others_decl + = create_var_decl (get_identifier ("OTHERS"), + get_identifier ("__gnat_others_value"), + integer_type_node, NULL_TREE, true, false, true, false, + NULL, Empty); + + all_others_decl + = create_var_decl (get_identifier ("ALL_OTHERS"), + get_identifier ("__gnat_all_others_value"), + integer_type_node, NULL_TREE, true, false, true, false, + NULL, Empty); + + main_identifier_node = get_identifier ("main"); + + /* Install the builtins we might need, either internally or as + user available facilities for Intrinsic imports. */ + gnat_install_builtins (); + + VEC_safe_push (tree, gc, gnu_except_ptr_stack, NULL_TREE); + VEC_safe_push (tree, gc, gnu_constraint_error_label_stack, NULL_TREE); + VEC_safe_push (tree, gc, gnu_storage_error_label_stack, NULL_TREE); + VEC_safe_push (tree, gc, gnu_program_error_label_stack, NULL_TREE); + + /* Process any Pragma Ident for the main unit. */ +#ifdef ASM_OUTPUT_IDENT + if (Present (Ident_String (Main_Unit))) + ASM_OUTPUT_IDENT + (asm_out_file, + TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit)))); +#endif + + /* If we are using the GCC exception mechanism, let GCC know. */ + if (Exception_Mechanism == Back_End_Exceptions) + gnat_init_gcc_eh (); + + /* Now translate the compilation unit proper. */ + Compilation_Unit_to_gnu (gnat_root); + + /* Finally see if we have any elaboration procedures to deal with. */ + for (info = elab_info_list; info; info = info->next) + { + tree gnu_body = DECL_SAVED_TREE (info->elab_proc), gnu_stmts; + + /* We should have a BIND_EXPR but it may not have any statements in it. + If it doesn't have any, we have nothing to do except for setting the + flag on the GNAT node. Otherwise, process the function as others. */ + gnu_stmts = gnu_body; + if (TREE_CODE (gnu_stmts) == BIND_EXPR) + gnu_stmts = BIND_EXPR_BODY (gnu_stmts); + if (!gnu_stmts || !STATEMENT_LIST_HEAD (gnu_stmts)) + Set_Has_No_Elaboration_Code (info->gnat_node, 1); + else + { + begin_subprog_body (info->elab_proc); + end_subprog_body (gnu_body); + } + } + + /* We cannot track the location of errors past this point. */ + error_gnat_node = Empty; +} + +/* Return a subprogram decl corresponding to __gnat_rcheck_xx for the given + CHECK (if EXTENDED is false), or __gnat_rcheck_xx_ext (if EXTENDED is + true). */ + +static tree +build_raise_check (int check, tree void_tree, enum exception_info_kind kind) +{ + char name[21]; + tree result; + + if (kind != exception_simple) + { + sprintf (name, "__gnat_rcheck_%.2d_ext", check); + result + = create_subprog_decl + (get_identifier (name), NULL_TREE, + build_function_type + (void_type_node, + tree_cons + (NULL_TREE, build_pointer_type (unsigned_char_type_node), + tree_cons (NULL_TREE, integer_type_node, + tree_cons (NULL_TREE, integer_type_node, + kind == exception_column + ? void_tree + : tree_cons (NULL_TREE, integer_type_node, + tree_cons (NULL_TREE, + integer_type_node, + void_tree)))))), + NULL_TREE, false, true, true, NULL, Empty); + } + else + { + sprintf (name, "__gnat_rcheck_%.2d", check); + result + = create_subprog_decl + (get_identifier (name), NULL_TREE, + build_function_type + (void_type_node, + tree_cons + (NULL_TREE, build_pointer_type (unsigned_char_type_node), + tree_cons (NULL_TREE, integer_type_node, void_tree))), + NULL_TREE, false, true, true, NULL, Empty); + } + + TREE_THIS_VOLATILE (result) = 1; + TREE_SIDE_EFFECTS (result) = 1; + TREE_TYPE (result) + = build_qualified_type (TREE_TYPE (result), TYPE_QUAL_VOLATILE); + + return result; +} + +/* Return a positive value if an lvalue is required for GNAT_NODE, which is + an N_Attribute_Reference. */ + +static int +lvalue_required_for_attribute_p (Node_Id gnat_node) +{ + switch (Get_Attribute_Id (Attribute_Name (gnat_node))) + { + case Attr_Pos: + case Attr_Val: + case Attr_Pred: + case Attr_Succ: + case Attr_First: + case Attr_Last: + case Attr_Range_Length: + case Attr_Length: + case Attr_Object_Size: + case Attr_Value_Size: + case Attr_Component_Size: + case Attr_Max_Size_In_Storage_Elements: + case Attr_Min: + case Attr_Max: + case Attr_Null_Parameter: + case Attr_Passed_By_Reference: + case Attr_Mechanism_Code: + return 0; + + case Attr_Address: + case Attr_Access: + case Attr_Unchecked_Access: + case Attr_Unrestricted_Access: + case Attr_Code_Address: + case Attr_Pool_Address: + case Attr_Size: + case Attr_Alignment: + case Attr_Bit_Position: + case Attr_Position: + case Attr_First_Bit: + case Attr_Last_Bit: + case Attr_Bit: + default: + return 1; + } +} + +/* Return a positive value if an lvalue is required for GNAT_NODE. GNU_TYPE + is the type that will be used for GNAT_NODE in the translated GNU tree. + CONSTANT indicates whether the underlying object represented by GNAT_NODE + is constant in the Ada sense. If it is, ADDRESS_OF_CONSTANT indicates + whether its value is the address of a constant and ALIASED whether it is + aliased. If it isn't, ADDRESS_OF_CONSTANT and ALIASED are ignored. + + The function climbs up the GNAT tree starting from the node and returns 1 + upon encountering a node that effectively requires an lvalue downstream. + It returns int instead of bool to facilitate usage in non-purely binary + logic contexts. */ + +static int +lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant, + bool address_of_constant, bool aliased) +{ + Node_Id gnat_parent = Parent (gnat_node), gnat_temp; + + switch (Nkind (gnat_parent)) + { + case N_Reference: + return 1; + + case N_Attribute_Reference: + return lvalue_required_for_attribute_p (gnat_parent); + + case N_Parameter_Association: + case N_Function_Call: + case N_Procedure_Call_Statement: + /* If the parameter is by reference, an lvalue is required. */ + return (!constant + || must_pass_by_ref (gnu_type) + || default_pass_by_ref (gnu_type)); + + case N_Indexed_Component: + /* Only the array expression can require an lvalue. */ + if (Prefix (gnat_parent) != gnat_node) + return 0; + + /* ??? Consider that referencing an indexed component with a + non-constant index forces the whole aggregate to memory. + Note that N_Integer_Literal is conservative, any static + expression in the RM sense could probably be accepted. */ + for (gnat_temp = First (Expressions (gnat_parent)); + Present (gnat_temp); + gnat_temp = Next (gnat_temp)) + if (Nkind (gnat_temp) != N_Integer_Literal) + return 1; + + /* ... fall through ... */ + + case N_Slice: + /* Only the array expression can require an lvalue. */ + if (Prefix (gnat_parent) != gnat_node) + return 0; + + aliased |= Has_Aliased_Components (Etype (gnat_node)); + return lvalue_required_p (gnat_parent, gnu_type, constant, + address_of_constant, aliased); + + case N_Selected_Component: + aliased |= Is_Aliased (Entity (Selector_Name (gnat_parent))); + return lvalue_required_p (gnat_parent, gnu_type, constant, + address_of_constant, aliased); + + case N_Object_Renaming_Declaration: + /* We need to make a real renaming only if the constant object is + aliased or if we may use a renaming pointer; otherwise we can + optimize and return the rvalue. We make an exception if the object + is an identifier since in this case the rvalue can be propagated + attached to the CONST_DECL. */ + return (!constant + || aliased + /* This should match the constant case of the renaming code. */ + || Is_Composite_Type + (Underlying_Type (Etype (Name (gnat_parent)))) + || Nkind (Name (gnat_parent)) == N_Identifier); + + case N_Object_Declaration: + /* We cannot use a constructor if this is an atomic object because + the actual assignment might end up being done component-wise. */ + return (!constant + ||(Is_Composite_Type (Underlying_Type (Etype (gnat_node))) + && Is_Atomic (Defining_Entity (gnat_parent))) + /* We don't use a constructor if this is a class-wide object + because the effective type of the object is the equivalent + type of the class-wide subtype and it smashes most of the + data into an array of bytes to which we cannot convert. */ + || Ekind ((Etype (Defining_Entity (gnat_parent)))) + == E_Class_Wide_Subtype); + + case N_Assignment_Statement: + /* We cannot use a constructor if the LHS is an atomic object because + the actual assignment might end up being done component-wise. */ + return (!constant + || Name (gnat_parent) == gnat_node + || (Is_Composite_Type (Underlying_Type (Etype (gnat_node))) + && Is_Atomic (Entity (Name (gnat_parent))))); + + case N_Unchecked_Type_Conversion: + if (!constant) + return 1; + + /* ... fall through ... */ + + case N_Type_Conversion: + case N_Qualified_Expression: + /* We must look through all conversions because we may need to bypass + an intermediate conversion that is meant to be purely formal. */ + return lvalue_required_p (gnat_parent, + get_unpadded_type (Etype (gnat_parent)), + constant, address_of_constant, aliased); + + case N_Allocator: + /* We should only reach here through the N_Qualified_Expression case. + Force an lvalue for composite types since a block-copy to the newly + allocated area of memory is made. */ + return Is_Composite_Type (Underlying_Type (Etype (gnat_node))); + + case N_Explicit_Dereference: + /* We look through dereferences for address of constant because we need + to handle the special cases listed above. */ + if (constant && address_of_constant) + return lvalue_required_p (gnat_parent, + get_unpadded_type (Etype (gnat_parent)), + true, false, true); + + /* ... fall through ... */ + + default: + return 0; + } + + gcc_unreachable (); +} + +/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier, + to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer + to where we should place the result type. */ + +static tree +Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) +{ + Node_Id gnat_temp, gnat_temp_type; + tree gnu_result, gnu_result_type; + + /* Whether we should require an lvalue for GNAT_NODE. Needed in + specific circumstances only, so evaluated lazily. < 0 means + unknown, > 0 means known true, 0 means known false. */ + int require_lvalue = -1; + + /* If GNAT_NODE is a constant, whether we should use the initialization + value instead of the constant entity, typically for scalars with an + address clause when the parent doesn't require an lvalue. */ + bool use_constant_initializer = false; + + /* If the Etype of this node does not equal the Etype of the Entity, + something is wrong with the entity map, probably in generic + instantiation. However, this does not apply to types. Since we sometime + have strange Ekind's, just do this test for objects. Also, if the Etype of + the Entity is private, the Etype of the N_Identifier is allowed to be the + full type and also we consider a packed array type to be the same as the + original type. Similarly, a class-wide type is equivalent to a subtype of + itself. Finally, if the types are Itypes, one may be a copy of the other, + which is also legal. */ + gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier + ? gnat_node : Entity (gnat_node)); + gnat_temp_type = Etype (gnat_temp); + + gcc_assert (Etype (gnat_node) == gnat_temp_type + || (Is_Packed (gnat_temp_type) + && Etype (gnat_node) == Packed_Array_Type (gnat_temp_type)) + || (Is_Class_Wide_Type (Etype (gnat_node))) + || (IN (Ekind (gnat_temp_type), Private_Kind) + && Present (Full_View (gnat_temp_type)) + && ((Etype (gnat_node) == Full_View (gnat_temp_type)) + || (Is_Packed (Full_View (gnat_temp_type)) + && (Etype (gnat_node) + == Packed_Array_Type (Full_View + (gnat_temp_type)))))) + || (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type)) + || !(Ekind (gnat_temp) == E_Variable + || Ekind (gnat_temp) == E_Component + || Ekind (gnat_temp) == E_Constant + || Ekind (gnat_temp) == E_Loop_Parameter + || IN (Ekind (gnat_temp), Formal_Kind))); + + /* If this is a reference to a deferred constant whose partial view is an + unconstrained private type, the proper type is on the full view of the + constant, not on the full view of the type, which may be unconstrained. + + This may be a reference to a type, for example in the prefix of the + attribute Position, generated for dispatching code (see Make_DT in + exp_disp,adb). In that case we need the type itself, not is parent, + in particular if it is a derived type */ + if (Is_Private_Type (gnat_temp_type) + && Has_Unknown_Discriminants (gnat_temp_type) + && Ekind (gnat_temp) == E_Constant + && Present (Full_View (gnat_temp))) + { + gnat_temp = Full_View (gnat_temp); + gnat_temp_type = Etype (gnat_temp); + } + else + { + /* We want to use the Actual_Subtype if it has already been elaborated, + otherwise the Etype. Avoid using Actual_Subtype for packed arrays to + simplify things. */ + if ((Ekind (gnat_temp) == E_Constant + || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp)) + && !(Is_Array_Type (Etype (gnat_temp)) + && Present (Packed_Array_Type (Etype (gnat_temp)))) + && Present (Actual_Subtype (gnat_temp)) + && present_gnu_tree (Actual_Subtype (gnat_temp))) + gnat_temp_type = Actual_Subtype (gnat_temp); + else + gnat_temp_type = Etype (gnat_node); + } + + /* Expand the type of this identifier first, in case it is an enumeral + literal, which only get made when the type is expanded. There is no + order-of-elaboration issue here. */ + gnu_result_type = get_unpadded_type (gnat_temp_type); + + /* If this is a non-imported scalar constant with an address clause, + retrieve the value instead of a pointer to be dereferenced unless + an lvalue is required. This is generally more efficient and actually + required if this is a static expression because it might be used + in a context where a dereference is inappropriate, such as a case + statement alternative or a record discriminant. There is no possible + volatile-ness short-circuit here since Volatile constants must be + imported per C.6. */ + if (Ekind (gnat_temp) == E_Constant + && Is_Scalar_Type (gnat_temp_type) + && !Is_Imported (gnat_temp) + && Present (Address_Clause (gnat_temp))) + { + require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true, + false, Is_Aliased (gnat_temp)); + use_constant_initializer = !require_lvalue; + } + + if (use_constant_initializer) + { + /* If this is a deferred constant, the initializer is attached to + the full view. */ + if (Present (Full_View (gnat_temp))) + gnat_temp = Full_View (gnat_temp); + + gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_temp))); + } + else + gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0); + + /* Some objects (such as parameters passed by reference, globals of + variable size, and renamed objects) actually represent the address + of the object. In that case, we must do the dereference. Likewise, + deal with parameters to foreign convention subprograms. */ + if (DECL_P (gnu_result) + && (DECL_BY_REF_P (gnu_result) + || (TREE_CODE (gnu_result) == PARM_DECL + && DECL_BY_COMPONENT_PTR_P (gnu_result)))) + { + const bool read_only = DECL_POINTS_TO_READONLY_P (gnu_result); + tree renamed_obj; + + if (TREE_CODE (gnu_result) == PARM_DECL + && DECL_BY_DOUBLE_REF_P (gnu_result)) + { + gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); + if (TREE_CODE (gnu_result) == INDIRECT_REF) + TREE_THIS_NOTRAP (gnu_result) = 1; + } + + if (TREE_CODE (gnu_result) == PARM_DECL + && DECL_BY_COMPONENT_PTR_P (gnu_result)) + { + gnu_result + = build_unary_op (INDIRECT_REF, NULL_TREE, + convert (build_pointer_type (gnu_result_type), + gnu_result)); + if (TREE_CODE (gnu_result) == INDIRECT_REF) + TREE_THIS_NOTRAP (gnu_result) = 1; + } + + /* If it's a renaming pointer and we are at the right binding level, + we can reference the renamed object directly, since the renamed + expression has been protected against multiple evaluations. */ + else if (TREE_CODE (gnu_result) == VAR_DECL + && (renamed_obj = DECL_RENAMED_OBJECT (gnu_result)) + && (!DECL_RENAMING_GLOBAL_P (gnu_result) + || global_bindings_p ())) + gnu_result = renamed_obj; + + /* Return the underlying CST for a CONST_DECL like a few lines below, + after dereferencing in this case. */ + else if (TREE_CODE (gnu_result) == CONST_DECL) + gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, + DECL_INITIAL (gnu_result)); + + else + { + gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); + if (TREE_CODE (gnu_result) == INDIRECT_REF + && No (Address_Clause (gnat_temp))) + TREE_THIS_NOTRAP (gnu_result) = 1; + } + + if (read_only) + TREE_READONLY (gnu_result) = 1; + } + + /* The GNAT tree has the type of a function as the type of its result. Also + use the type of the result if the Etype is a subtype which is nominally + unconstrained. But remove any padding from the resulting type. */ + if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE + || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type)) + { + gnu_result_type = TREE_TYPE (gnu_result); + if (TYPE_IS_PADDING_P (gnu_result_type)) + gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type)); + } + + /* If we have a constant declaration and its initializer, try to return the + latter to avoid the need to call fold in lots of places and the need for + elaboration code if this identifier is used as an initializer itself. */ + if (TREE_CONSTANT (gnu_result) + && DECL_P (gnu_result) + && DECL_INITIAL (gnu_result)) + { + bool constant_only = (TREE_CODE (gnu_result) == CONST_DECL + && !DECL_CONST_CORRESPONDING_VAR (gnu_result)); + bool address_of_constant = (TREE_CODE (gnu_result) == CONST_DECL + && DECL_CONST_ADDRESS_P (gnu_result)); + + /* If there is a (corresponding) variable or this is the address of a + constant, we only want to return the initializer if an lvalue isn't + required. Evaluate this now if we have not already done so. */ + if ((!constant_only || address_of_constant) && require_lvalue < 0) + require_lvalue + = lvalue_required_p (gnat_node, gnu_result_type, true, + address_of_constant, Is_Aliased (gnat_temp)); + + /* ??? We need to unshare the initializer if the object is external + as such objects are not marked for unsharing if we are not at the + global level. This should be fixed in add_decl_expr. */ + if ((constant_only && !address_of_constant) || !require_lvalue) + gnu_result = unshare_expr (DECL_INITIAL (gnu_result)); + } + + *gnu_result_type_p = gnu_result_type; + + return gnu_result; +} + +/* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return + any statements we generate. */ + +static tree +Pragma_to_gnu (Node_Id gnat_node) +{ + Node_Id gnat_temp; + tree gnu_result = alloc_stmt_list (); + + /* Check for (and ignore) unrecognized pragma and do nothing if we are just + annotating types. */ + if (type_annotate_only + || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node)))) + return gnu_result; + + switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))) + { + case Pragma_Inspection_Point: + /* Do nothing at top level: all such variables are already viewable. */ + if (global_bindings_p ()) + break; + + for (gnat_temp = First (Pragma_Argument_Associations (gnat_node)); + Present (gnat_temp); + gnat_temp = Next (gnat_temp)) + { + Node_Id gnat_expr = Expression (gnat_temp); + tree gnu_expr = gnat_to_gnu (gnat_expr); + int use_address; + enum machine_mode mode; + tree asm_constraint = NULL_TREE; +#ifdef ASM_COMMENT_START + char *comment; +#endif + + if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF) + gnu_expr = TREE_OPERAND (gnu_expr, 0); + + /* Use the value only if it fits into a normal register, + otherwise use the address. */ + mode = TYPE_MODE (TREE_TYPE (gnu_expr)); + use_address = ((GET_MODE_CLASS (mode) != MODE_INT + && GET_MODE_CLASS (mode) != MODE_PARTIAL_INT) + || GET_MODE_SIZE (mode) > UNITS_PER_WORD); + + if (use_address) + gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr); + +#ifdef ASM_COMMENT_START + comment = concat (ASM_COMMENT_START, + " inspection point: ", + Get_Name_String (Chars (gnat_expr)), + use_address ? " address" : "", + " is in %0", + NULL); + asm_constraint = build_string (strlen (comment), comment); + free (comment); +#endif + gnu_expr = build5 (ASM_EXPR, void_type_node, + asm_constraint, + NULL_TREE, + tree_cons + (build_tree_list (NULL_TREE, + build_string (1, "g")), + gnu_expr, NULL_TREE), + NULL_TREE, NULL_TREE); + ASM_VOLATILE_P (gnu_expr) = 1; + set_expr_location_from_node (gnu_expr, gnat_node); + append_to_statement_list (gnu_expr, &gnu_result); + } + break; + + case Pragma_Optimize: + switch (Chars (Expression + (First (Pragma_Argument_Associations (gnat_node))))) + { + case Name_Time: case Name_Space: + if (!optimize) + post_error ("insufficient -O value?", gnat_node); + break; + + case Name_Off: + if (optimize) + post_error ("must specify -O0?", gnat_node); + break; + + default: + gcc_unreachable (); + } + break; + + case Pragma_Reviewable: + if (write_symbols == NO_DEBUG) + post_error ("must specify -g?", gnat_node); + break; + } + + return gnu_result; +} + +/* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node, + to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to + where we should place the result type. ATTRIBUTE is the attribute ID. */ + +static tree +Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) +{ + tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node)); + tree gnu_type = TREE_TYPE (gnu_prefix); + tree gnu_expr, gnu_result_type, gnu_result = error_mark_node; + bool prefix_unused = false; + + /* If the input is a NULL_EXPR, make a new one. */ + if (TREE_CODE (gnu_prefix) == NULL_EXPR) + { + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + *gnu_result_type_p = gnu_result_type; + return build1 (NULL_EXPR, gnu_result_type, TREE_OPERAND (gnu_prefix, 0)); + } + + switch (attribute) + { + case Attr_Pos: + case Attr_Val: + /* These are just conversions since representation clauses for + enumeration types are handled in the front-end. */ + { + bool checkp = Do_Range_Check (First (Expressions (gnat_node))); + gnu_result = gnat_to_gnu (First (Expressions (gnat_node))); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = convert_with_check (Etype (gnat_node), gnu_result, + checkp, checkp, true, gnat_node); + } + break; + + case Attr_Pred: + case Attr_Succ: + /* These just add or subtract the constant 1 since representation + clauses for enumeration types are handled in the front-end. */ + gnu_expr = gnat_to_gnu (First (Expressions (gnat_node))); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + if (Do_Range_Check (First (Expressions (gnat_node)))) + { + gnu_expr = gnat_protect_expr (gnu_expr); + gnu_expr + = emit_check + (build_binary_op (EQ_EXPR, boolean_type_node, + gnu_expr, + attribute == Attr_Pred + ? TYPE_MIN_VALUE (gnu_result_type) + : TYPE_MAX_VALUE (gnu_result_type)), + gnu_expr, CE_Range_Check_Failed, gnat_node); + } + + gnu_result + = build_binary_op (attribute == Attr_Pred ? MINUS_EXPR : PLUS_EXPR, + gnu_result_type, gnu_expr, + convert (gnu_result_type, integer_one_node)); + break; + + case Attr_Address: + case Attr_Unrestricted_Access: + /* Conversions don't change addresses but can cause us to miss the + COMPONENT_REF case below, so strip them off. */ + gnu_prefix = remove_conversions (gnu_prefix, + !Must_Be_Byte_Aligned (gnat_node)); + + /* If we are taking 'Address of an unconstrained object, this is the + pointer to the underlying array. */ + if (attribute == Attr_Address) + gnu_prefix = maybe_unconstrained_array (gnu_prefix); + + /* If we are building a static dispatch table, we have to honor + TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible + with the C++ ABI. We do it in the non-static case as well, + see gnat_to_gnu_entity, case E_Access_Subprogram_Type. */ + else if (TARGET_VTABLE_USES_DESCRIPTORS + && Is_Dispatch_Table_Entity (Etype (gnat_node))) + { + tree gnu_field, t; + /* Descriptors can only be built here for top-level functions. */ + bool build_descriptor = (global_bindings_p () != 0); + int i; + VEC(constructor_elt,gc) *gnu_vec = NULL; + constructor_elt *elt; + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + /* If we're not going to build the descriptor, we have to retrieve + the one which will be built by the linker (or by the compiler + later if a static chain is requested). */ + if (!build_descriptor) + { + gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_prefix); + gnu_result = fold_convert (build_pointer_type (gnu_result_type), + gnu_result); + gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result); + } + + VEC_safe_grow (constructor_elt, gc, gnu_vec, + TARGET_VTABLE_USES_DESCRIPTORS); + elt = (VEC_address (constructor_elt, gnu_vec) + + TARGET_VTABLE_USES_DESCRIPTORS - 1); + for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0; + i < TARGET_VTABLE_USES_DESCRIPTORS; + gnu_field = TREE_CHAIN (gnu_field), i++) + { + if (build_descriptor) + { + t = build2 (FDESC_EXPR, TREE_TYPE (gnu_field), gnu_prefix, + build_int_cst (NULL_TREE, i)); + TREE_CONSTANT (t) = 1; + } + else + t = build3 (COMPONENT_REF, ptr_void_ftype, gnu_result, + gnu_field, NULL_TREE); + + elt->index = gnu_field; + elt->value = t; + elt--; + } + + gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec); + break; + } + + /* ... fall through ... */ + + case Attr_Access: + case Attr_Unchecked_Access: + case Attr_Code_Address: + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result + = build_unary_op (((attribute == Attr_Address + || attribute == Attr_Unrestricted_Access) + && !Must_Be_Byte_Aligned (gnat_node)) + ? ATTR_ADDR_EXPR : ADDR_EXPR, + gnu_result_type, gnu_prefix); + + /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we + don't try to build a trampoline. */ + if (attribute == Attr_Code_Address) + { + for (gnu_expr = gnu_result; + CONVERT_EXPR_P (gnu_expr); + gnu_expr = TREE_OPERAND (gnu_expr, 0)) + TREE_CONSTANT (gnu_expr) = 1; + + if (TREE_CODE (gnu_expr) == ADDR_EXPR) + TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1; + } + + /* For other address attributes applied to a nested function, + find an inner ADDR_EXPR and annotate it so that we can issue + a useful warning with -Wtrampolines. */ + else if (TREE_CODE (TREE_TYPE (gnu_prefix)) == FUNCTION_TYPE) + { + for (gnu_expr = gnu_result; + CONVERT_EXPR_P (gnu_expr); + gnu_expr = TREE_OPERAND (gnu_expr, 0)) + ; + + if (TREE_CODE (gnu_expr) == ADDR_EXPR + && decl_function_context (TREE_OPERAND (gnu_expr, 0))) + { + set_expr_location_from_node (gnu_expr, gnat_node); + + /* Check that we're not violating the No_Implicit_Dynamic_Code + restriction. Be conservative if we don't know anything + about the trampoline strategy for the target. */ + Check_Implicit_Dynamic_Code_Allowed (gnat_node); + } + } + break; + + case Attr_Pool_Address: + { + tree gnu_obj_type; + tree gnu_ptr = gnu_prefix; + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + /* If this is an unconstrained array, we know the object has been + allocated with the template in front of the object. So compute + the template address. */ + if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr))) + gnu_ptr + = convert (build_pointer_type + (TYPE_OBJECT_RECORD_TYPE + (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))), + gnu_ptr); + + gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr)); + if (TREE_CODE (gnu_obj_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type)) + { + tree gnu_char_ptr_type + = build_pointer_type (unsigned_char_type_node); + tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type)); + gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr); + gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type, + gnu_ptr, gnu_pos); + } + + gnu_result = convert (gnu_result_type, gnu_ptr); + } + break; + + case Attr_Size: + case Attr_Object_Size: + case Attr_Value_Size: + case Attr_Max_Size_In_Storage_Elements: + gnu_expr = gnu_prefix; + + /* Remove NOPs and conversions between original and packable version + from GNU_EXPR, and conversions from GNU_PREFIX. We use GNU_EXPR + to see if a COMPONENT_REF was involved. */ + while (TREE_CODE (gnu_expr) == NOP_EXPR + || (TREE_CODE (gnu_expr) == VIEW_CONVERT_EXPR + && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE + && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))) + == RECORD_TYPE + && TYPE_NAME (TREE_TYPE (gnu_expr)) + == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))) + gnu_expr = TREE_OPERAND (gnu_expr, 0); + + gnu_prefix = remove_conversions (gnu_prefix, true); + prefix_unused = true; + gnu_type = TREE_TYPE (gnu_prefix); + + /* Replace an unconstrained array type with the type of the underlying + array. We can't do this with a call to maybe_unconstrained_array + since we may have a TYPE_DECL. For 'Max_Size_In_Storage_Elements, + use the record type that will be used to allocate the object and its + template. */ + if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) + { + gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type); + if (attribute != Attr_Max_Size_In_Storage_Elements) + gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))); + } + + /* If we're looking for the size of a field, return the field size. + Otherwise, if the prefix is an object, or if we're looking for + 'Object_Size or 'Max_Size_In_Storage_Elements, the result is the + GCC size of the type. Otherwise, it is the RM size of the type. */ + if (TREE_CODE (gnu_prefix) == COMPONENT_REF) + gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1)); + else if (TREE_CODE (gnu_prefix) != TYPE_DECL + || attribute == Attr_Object_Size + || attribute == Attr_Max_Size_In_Storage_Elements) + { + /* If the prefix is an object of a padded type, the GCC size isn't + relevant to the programmer. Normally what we want is the RM size, + which was set from the specified size, but if it was not set, we + want the size of the field. Using the MAX of those two produces + the right result in all cases. Don't use the size of the field + if it's self-referential, since that's never what's wanted. */ + if (TREE_CODE (gnu_prefix) != TYPE_DECL + && TYPE_IS_PADDING_P (gnu_type) + && TREE_CODE (gnu_expr) == COMPONENT_REF) + { + gnu_result = rm_size (gnu_type); + if (!CONTAINS_PLACEHOLDER_P + (DECL_SIZE (TREE_OPERAND (gnu_expr, 1)))) + gnu_result + = size_binop (MAX_EXPR, gnu_result, + DECL_SIZE (TREE_OPERAND (gnu_expr, 1))); + } + else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference) + { + Node_Id gnat_deref = Prefix (gnat_node); + Node_Id gnat_actual_subtype + = Actual_Designated_Subtype (gnat_deref); + tree gnu_ptr_type + = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref))); + + if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type) + && Present (gnat_actual_subtype)) + { + tree gnu_actual_obj_type + = gnat_to_gnu_type (gnat_actual_subtype); + gnu_type + = build_unc_object_type_from_ptr (gnu_ptr_type, + gnu_actual_obj_type, + get_identifier ("SIZE"), + false); + } + + gnu_result = TYPE_SIZE (gnu_type); + } + else + gnu_result = TYPE_SIZE (gnu_type); + } + else + gnu_result = rm_size (gnu_type); + + /* Deal with a self-referential size by returning the maximum size for + a type and by qualifying the size with the object otherwise. */ + if (CONTAINS_PLACEHOLDER_P (gnu_result)) + { + if (TREE_CODE (gnu_prefix) == TYPE_DECL) + gnu_result = max_size (gnu_result, true); + else + gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr); + } + + /* If the type contains a template, subtract its size. */ + if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) + gnu_result = size_binop (MINUS_EXPR, gnu_result, + DECL_SIZE (TYPE_FIELDS (gnu_type))); + + /* For 'Max_Size_In_Storage_Elements, adjust the unit. */ + if (attribute == Attr_Max_Size_In_Storage_Elements) + gnu_result = size_binop (CEIL_DIV_EXPR, gnu_result, bitsize_unit_node); + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + break; + + case Attr_Alignment: + { + unsigned int align; + + if (TREE_CODE (gnu_prefix) == COMPONENT_REF + && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))) + gnu_prefix = TREE_OPERAND (gnu_prefix, 0); + + gnu_type = TREE_TYPE (gnu_prefix); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + prefix_unused = true; + + if (TREE_CODE (gnu_prefix) == COMPONENT_REF) + align = DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) / BITS_PER_UNIT; + else + { + Node_Id gnat_prefix = Prefix (gnat_node); + Entity_Id gnat_type = Etype (gnat_prefix); + unsigned int double_align; + bool is_capped_double, align_clause; + + /* If the default alignment of "double" or larger scalar types is + specifically capped and there is an alignment clause neither + on the type nor on the prefix itself, return the cap. */ + if ((double_align = double_float_alignment) > 0) + is_capped_double + = is_double_float_or_array (gnat_type, &align_clause); + else if ((double_align = double_scalar_alignment) > 0) + is_capped_double + = is_double_scalar_or_array (gnat_type, &align_clause); + else + is_capped_double = align_clause = false; + + if (is_capped_double + && Nkind (gnat_prefix) == N_Identifier + && Present (Alignment_Clause (Entity (gnat_prefix)))) + align_clause = true; + + if (is_capped_double && !align_clause) + align = double_align; + else + align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT; + } + + gnu_result = size_int (align); + } + break; + + case Attr_First: + case Attr_Last: + case Attr_Range_Length: + prefix_unused = true; + + if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE) + { + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + if (attribute == Attr_First) + gnu_result = TYPE_MIN_VALUE (gnu_type); + else if (attribute == Attr_Last) + gnu_result = TYPE_MAX_VALUE (gnu_type); + else + gnu_result + = build_binary_op + (MAX_EXPR, get_base_type (gnu_result_type), + build_binary_op + (PLUS_EXPR, get_base_type (gnu_result_type), + build_binary_op (MINUS_EXPR, + get_base_type (gnu_result_type), + convert (gnu_result_type, + TYPE_MAX_VALUE (gnu_type)), + convert (gnu_result_type, + TYPE_MIN_VALUE (gnu_type))), + convert (gnu_result_type, integer_one_node)), + convert (gnu_result_type, integer_zero_node)); + + break; + } + + /* ... fall through ... */ + + case Attr_Length: + { + int Dimension = (Present (Expressions (gnat_node)) + ? UI_To_Int (Intval (First (Expressions (gnat_node)))) + : 1), i; + struct parm_attr_d *pa = NULL; + Entity_Id gnat_param = Empty; + + /* Make sure any implicit dereference gets done. */ + gnu_prefix = maybe_implicit_deref (gnu_prefix); + gnu_prefix = maybe_unconstrained_array (gnu_prefix); + /* We treat unconstrained array In parameters specially. */ + if (Nkind (Prefix (gnat_node)) == N_Identifier + && !Is_Constrained (Etype (Prefix (gnat_node))) + && Ekind (Entity (Prefix (gnat_node))) == E_In_Parameter) + gnat_param = Entity (Prefix (gnat_node)); + gnu_type = TREE_TYPE (gnu_prefix); + prefix_unused = true; + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + if (TYPE_CONVENTION_FORTRAN_P (gnu_type)) + { + int ndim; + tree gnu_type_temp; + + for (ndim = 1, gnu_type_temp = gnu_type; + TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp)); + ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp)) + ; + + Dimension = ndim + 1 - Dimension; + } + + for (i = 1; i < Dimension; i++) + gnu_type = TREE_TYPE (gnu_type); + + gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE); + + /* When not optimizing, look up the slot associated with the parameter + and the dimension in the cache and create a new one on failure. */ + if (!optimize && Present (gnat_param)) + { + FOR_EACH_VEC_ELT (parm_attr, f_parm_attr_cache, i, pa) + if (pa->id == gnat_param && pa->dim == Dimension) + break; + + if (!pa) + { + pa = ggc_alloc_cleared_parm_attr_d (); + pa->id = gnat_param; + pa->dim = Dimension; + VEC_safe_push (parm_attr, gc, f_parm_attr_cache, pa); + } + } + + /* Return the cached expression or build a new one. */ + if (attribute == Attr_First) + { + if (pa && pa->first) + { + gnu_result = pa->first; + break; + } + + gnu_result + = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))); + } + + else if (attribute == Attr_Last) + { + if (pa && pa->last) + { + gnu_result = pa->last; + break; + } + + gnu_result + = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))); + } + + else /* attribute == Attr_Range_Length || attribute == Attr_Length */ + { + if (pa && pa->length) + { + gnu_result = pa->length; + break; + } + else + { + /* We used to compute the length as max (hb - lb + 1, 0), + which could overflow for some cases of empty arrays, e.g. + when lb == index_type'first. We now compute the length as + (hb >= lb) ? hb - lb + 1 : 0, which would only overflow in + much rarer cases, for extremely large arrays we expect + never to encounter in practice. In addition, the former + computation required the use of potentially constraining + signed arithmetic while the latter doesn't. Note that + the comparison must be done in the original index type, + to avoid any overflow during the conversion. */ + tree comp_type = get_base_type (gnu_result_type); + tree index_type = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)); + tree lb = TYPE_MIN_VALUE (index_type); + tree hb = TYPE_MAX_VALUE (index_type); + gnu_result + = build_binary_op (PLUS_EXPR, comp_type, + build_binary_op (MINUS_EXPR, + comp_type, + convert (comp_type, hb), + convert (comp_type, lb)), + convert (comp_type, integer_one_node)); + gnu_result + = build_cond_expr (comp_type, + build_binary_op (GE_EXPR, + boolean_type_node, + hb, lb), + gnu_result, + convert (comp_type, integer_zero_node)); + } + } + + /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are + handling. Note that these attributes could not have been used on + an unconstrained array type. */ + gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix); + + /* Cache the expression we have just computed. Since we want to do it + at run time, we force the use of a SAVE_EXPR and let the gimplifier + create the temporary in the outermost binding level. We will make + sure in Subprogram_Body_to_gnu that it is evaluated on all possible + paths by forcing its evaluation on entry of the function. */ + if (pa) + { + gnu_result + = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result); + if (attribute == Attr_First) + pa->first = gnu_result; + else if (attribute == Attr_Last) + pa->last = gnu_result; + else + pa->length = gnu_result; + } + + /* Set the source location onto the predicate of the condition in the + 'Length case but do not do it if the expression is cached to avoid + messing up the debug info. */ + else if ((attribute == Attr_Range_Length || attribute == Attr_Length) + && TREE_CODE (gnu_result) == COND_EXPR + && EXPR_P (TREE_OPERAND (gnu_result, 0))) + set_expr_location_from_node (TREE_OPERAND (gnu_result, 0), + gnat_node); + + break; + } + + case Attr_Bit_Position: + case Attr_Position: + case Attr_First_Bit: + case Attr_Last_Bit: + case Attr_Bit: + { + HOST_WIDE_INT bitsize; + HOST_WIDE_INT bitpos; + tree gnu_offset; + tree gnu_field_bitpos; + tree gnu_field_offset; + tree gnu_inner; + enum machine_mode mode; + int unsignedp, volatilep; + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_prefix = remove_conversions (gnu_prefix, true); + prefix_unused = true; + + /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF, + the result is 0. Don't allow 'Bit on a bare component, though. */ + if (attribute == Attr_Bit + && TREE_CODE (gnu_prefix) != COMPONENT_REF + && TREE_CODE (gnu_prefix) != FIELD_DECL) + { + gnu_result = integer_zero_node; + break; + } + + else + gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF + || (attribute == Attr_Bit_Position + && TREE_CODE (gnu_prefix) == FIELD_DECL)); + + get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset, + &mode, &unsignedp, &volatilep, false); + + if (TREE_CODE (gnu_prefix) == COMPONENT_REF) + { + gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1)); + gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1)); + + for (gnu_inner = TREE_OPERAND (gnu_prefix, 0); + TREE_CODE (gnu_inner) == COMPONENT_REF + && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1)); + gnu_inner = TREE_OPERAND (gnu_inner, 0)) + { + gnu_field_bitpos + = size_binop (PLUS_EXPR, gnu_field_bitpos, + bit_position (TREE_OPERAND (gnu_inner, 1))); + gnu_field_offset + = size_binop (PLUS_EXPR, gnu_field_offset, + byte_position (TREE_OPERAND (gnu_inner, 1))); + } + } + else if (TREE_CODE (gnu_prefix) == FIELD_DECL) + { + gnu_field_bitpos = bit_position (gnu_prefix); + gnu_field_offset = byte_position (gnu_prefix); + } + else + { + gnu_field_bitpos = bitsize_zero_node; + gnu_field_offset = size_zero_node; + } + + switch (attribute) + { + case Attr_Position: + gnu_result = gnu_field_offset; + break; + + case Attr_First_Bit: + case Attr_Bit: + gnu_result = size_int (bitpos % BITS_PER_UNIT); + break; + + case Attr_Last_Bit: + gnu_result = bitsize_int (bitpos % BITS_PER_UNIT); + gnu_result = size_binop (PLUS_EXPR, gnu_result, + TYPE_SIZE (TREE_TYPE (gnu_prefix))); + gnu_result = size_binop (MINUS_EXPR, gnu_result, + bitsize_one_node); + break; + + case Attr_Bit_Position: + gnu_result = gnu_field_bitpos; + break; + } + + /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are + handling. */ + gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix); + break; + } + + case Attr_Min: + case Attr_Max: + { + tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node))); + tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node)))); + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = build_binary_op (attribute == Attr_Min + ? MIN_EXPR : MAX_EXPR, + gnu_result_type, gnu_lhs, gnu_rhs); + } + break; + + case Attr_Passed_By_Reference: + gnu_result = size_int (default_pass_by_ref (gnu_type) + || must_pass_by_ref (gnu_type)); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + break; + + case Attr_Component_Size: + if (TREE_CODE (gnu_prefix) == COMPONENT_REF + && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))) + gnu_prefix = TREE_OPERAND (gnu_prefix, 0); + + gnu_prefix = maybe_implicit_deref (gnu_prefix); + gnu_type = TREE_TYPE (gnu_prefix); + + if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) + gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type)))); + + while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type))) + gnu_type = TREE_TYPE (gnu_type); + + gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE); + + /* Note this size cannot be self-referential. */ + gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type)); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + prefix_unused = true; + break; + + case Attr_Null_Parameter: + /* This is just a zero cast to the pointer type for our prefix and + dereferenced. */ + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result + = build_unary_op (INDIRECT_REF, NULL_TREE, + convert (build_pointer_type (gnu_result_type), + integer_zero_node)); + TREE_PRIVATE (gnu_result) = 1; + break; + + case Attr_Mechanism_Code: + { + int code; + Entity_Id gnat_obj = Entity (Prefix (gnat_node)); + + prefix_unused = true; + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + if (Present (Expressions (gnat_node))) + { + int i = UI_To_Int (Intval (First (Expressions (gnat_node)))); + + for (gnat_obj = First_Formal (gnat_obj); i > 1; + i--, gnat_obj = Next_Formal (gnat_obj)) + ; + } + + code = Mechanism (gnat_obj); + if (code == Default) + code = ((present_gnu_tree (gnat_obj) + && (DECL_BY_REF_P (get_gnu_tree (gnat_obj)) + || ((TREE_CODE (get_gnu_tree (gnat_obj)) + == PARM_DECL) + && (DECL_BY_COMPONENT_PTR_P + (get_gnu_tree (gnat_obj)))))) + ? By_Reference : By_Copy); + gnu_result = convert (gnu_result_type, size_int (- code)); + } + break; + + default: + /* Say we have an unimplemented attribute. Then set the value to be + returned to be a zero and hope that's something we can convert to + the type of this attribute. */ + post_error ("unimplemented attribute", gnat_node); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = integer_zero_node; + break; + } + + /* If this is an attribute where the prefix was unused, force a use of it if + it has a side-effect. But don't do it if the prefix is just an entity + name. However, if an access check is needed, we must do it. See second + example in AARM 11.6(5.e). */ + if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix) + && !Is_Entity_Name (Prefix (gnat_node))) + gnu_result = build_compound_expr (TREE_TYPE (gnu_result), gnu_prefix, + gnu_result); + + *gnu_result_type_p = gnu_result_type; + return gnu_result; +} + +/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement, + to a GCC tree, which is returned. */ + +static tree +Case_Statement_to_gnu (Node_Id gnat_node) +{ + tree gnu_result, gnu_expr, gnu_label; + Node_Id gnat_when; + location_t end_locus; + bool may_fallthru = false; + + gnu_expr = gnat_to_gnu (Expression (gnat_node)); + gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr); + + /* The range of values in a case statement is determined by the rules in + RM 5.4(7-9). In almost all cases, this range is represented by the Etype + of the expression. One exception arises in the case of a simple name that + is parenthesized. This still has the Etype of the name, but since it is + not a name, para 7 does not apply, and we need to go to the base type. + This is the only case where parenthesization affects the dynamic + semantics (i.e. the range of possible values at run time that is covered + by the others alternative). + + Another exception is if the subtype of the expression is non-static. In + that case, we also have to use the base type. */ + if (Paren_Count (Expression (gnat_node)) != 0 + || !Is_OK_Static_Subtype (Underlying_Type + (Etype (Expression (gnat_node))))) + gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr); + + /* We build a SWITCH_EXPR that contains the code with interspersed + CASE_LABEL_EXPRs for each label. */ + if (!Sloc_to_locus (Sloc (gnat_node) + UI_To_Int (End_Span (gnat_node)), + &end_locus)) + end_locus = input_location; + gnu_label = create_artificial_label (end_locus); + start_stmt_group (); + + for (gnat_when = First_Non_Pragma (Alternatives (gnat_node)); + Present (gnat_when); + gnat_when = Next_Non_Pragma (gnat_when)) + { + bool choices_added_p = false; + Node_Id gnat_choice; + + /* First compile all the different case choices for the current WHEN + alternative. */ + for (gnat_choice = First (Discrete_Choices (gnat_when)); + Present (gnat_choice); gnat_choice = Next (gnat_choice)) + { + tree gnu_low = NULL_TREE, gnu_high = NULL_TREE; + + switch (Nkind (gnat_choice)) + { + case N_Range: + gnu_low = gnat_to_gnu (Low_Bound (gnat_choice)); + gnu_high = gnat_to_gnu (High_Bound (gnat_choice)); + break; + + case N_Subtype_Indication: + gnu_low = gnat_to_gnu (Low_Bound (Range_Expression + (Constraint (gnat_choice)))); + gnu_high = gnat_to_gnu (High_Bound (Range_Expression + (Constraint (gnat_choice)))); + break; + + case N_Identifier: + case N_Expanded_Name: + /* This represents either a subtype range or a static value of + some kind; Ekind says which. */ + if (IN (Ekind (Entity (gnat_choice)), Type_Kind)) + { + tree gnu_type = get_unpadded_type (Entity (gnat_choice)); + + gnu_low = fold (TYPE_MIN_VALUE (gnu_type)); + gnu_high = fold (TYPE_MAX_VALUE (gnu_type)); + break; + } + + /* ... fall through ... */ + + case N_Character_Literal: + case N_Integer_Literal: + gnu_low = gnat_to_gnu (gnat_choice); + break; + + case N_Others_Choice: + break; + + default: + gcc_unreachable (); + } + + /* If the case value is a subtype that raises Constraint_Error at + run time because of a wrong bound, then gnu_low or gnu_high is + not translated into an INTEGER_CST. In such a case, we need + to ensure that the when statement is not added in the tree, + otherwise it will crash the gimplifier. */ + if ((!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST) + && (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST)) + { + add_stmt_with_node (build3 + (CASE_LABEL_EXPR, void_type_node, + gnu_low, gnu_high, + create_artificial_label (input_location)), + gnat_choice); + choices_added_p = true; + } + } + + /* Push a binding level here in case variables are declared as we want + them to be local to this set of statements instead of to the block + containing the Case statement. */ + if (choices_added_p) + { + tree group = build_stmt_group (Statements (gnat_when), true); + bool group_may_fallthru = block_may_fallthru (group); + add_stmt (group); + if (group_may_fallthru) + { + tree stmt = build1 (GOTO_EXPR, void_type_node, gnu_label); + SET_EXPR_LOCATION (stmt, end_locus); + add_stmt (stmt); + may_fallthru = true; + } + } + } + + /* Now emit a definition of the label the cases branch to, if any. */ + if (may_fallthru) + add_stmt (build1 (LABEL_EXPR, void_type_node, gnu_label)); + gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr, + end_stmt_group (), NULL_TREE); + + return gnu_result; +} + +/* Return true if VAL (of type TYPE) can equal the minimum value if MAX is + false, or the maximum value if MAX is true, of TYPE. */ + +static bool +can_equal_min_or_max_val_p (tree val, tree type, bool max) +{ + tree min_or_max_val = (max ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type)); + + if (TREE_CODE (min_or_max_val) != INTEGER_CST) + return true; + + if (TREE_CODE (val) == NOP_EXPR) + val = (max + ? TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val, 0))) + : TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val, 0)))); + + if (TREE_CODE (val) != INTEGER_CST) + return true; + + return tree_int_cst_equal (val, min_or_max_val) == 1; +} + +/* Return true if VAL (of type TYPE) can equal the minimum value of TYPE. + If REVERSE is true, minimum value is taken as maximum value. */ + +static inline bool +can_equal_min_val_p (tree val, tree type, bool reverse) +{ + return can_equal_min_or_max_val_p (val, type, reverse); +} + +/* Return true if VAL (of type TYPE) can equal the maximum value of TYPE. + If REVERSE is true, maximum value is taken as minimum value. */ + +static inline bool +can_equal_max_val_p (tree val, tree type, bool reverse) +{ + return can_equal_min_or_max_val_p (val, type, !reverse); +} + +/* Return true if VAL1 can be lower than VAL2. */ + +static bool +can_be_lower_p (tree val1, tree val2) +{ + if (TREE_CODE (val1) == NOP_EXPR) + val1 = TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val1, 0))); + + if (TREE_CODE (val1) != INTEGER_CST) + return true; + + if (TREE_CODE (val2) == NOP_EXPR) + val2 = TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val2, 0))); + + if (TREE_CODE (val2) != INTEGER_CST) + return true; + + return tree_int_cst_lt (val1, val2); +} + +/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement, + to a GCC tree, which is returned. */ + +static tree +Loop_Statement_to_gnu (Node_Id gnat_node) +{ + const Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node); + tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE, + NULL_TREE, NULL_TREE, NULL_TREE); + tree gnu_loop_label = create_artificial_label (input_location); + tree gnu_loop_var = NULL_TREE, gnu_cond_expr = NULL_TREE; + tree gnu_result; + + /* Set location information for statement and end label. */ + set_expr_location_from_node (gnu_loop_stmt, gnat_node); + Sloc_to_locus (Sloc (End_Label (gnat_node)), + &DECL_SOURCE_LOCATION (gnu_loop_label)); + LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label; + + /* Save the end label of this LOOP_STMT in a stack so that a corresponding + N_Exit_Statement can find it. */ + VEC_safe_push (tree, gc, gnu_loop_label_stack, gnu_loop_label); + + /* Set the condition under which the loop must keep going. + For the case "LOOP .... END LOOP;" the condition is always true. */ + if (No (gnat_iter_scheme)) + ; + + /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate. */ + else if (Present (Condition (gnat_iter_scheme))) + LOOP_STMT_COND (gnu_loop_stmt) + = gnat_to_gnu (Condition (gnat_iter_scheme)); + + /* Otherwise we have an iteration scheme and the condition is given by the + bounds of the subtype of the iteration variable. */ + else + { + Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme); + Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec); + Entity_Id gnat_type = Etype (gnat_loop_var); + tree gnu_type = get_unpadded_type (gnat_type); + tree gnu_low = TYPE_MIN_VALUE (gnu_type); + tree gnu_high = TYPE_MAX_VALUE (gnu_type); + tree gnu_base_type = get_base_type (gnu_type); + tree gnu_one_node = convert (gnu_base_type, integer_one_node); + tree gnu_first, gnu_last; + enum tree_code update_code, test_code, shift_code; + bool reverse = Reverse_Present (gnat_loop_spec), fallback = false; + + /* We must disable modulo reduction for the iteration variable, if any, + in order for the loop comparison to be effective. */ + if (reverse) + { + gnu_first = gnu_high; + gnu_last = gnu_low; + update_code = MINUS_NOMOD_EXPR; + test_code = GE_EXPR; + shift_code = PLUS_NOMOD_EXPR; + } + else + { + gnu_first = gnu_low; + gnu_last = gnu_high; + update_code = PLUS_NOMOD_EXPR; + test_code = LE_EXPR; + shift_code = MINUS_NOMOD_EXPR; + } + + /* We use two different strategies to translate the loop, depending on + whether optimization is enabled. + + If it is, we try to generate the canonical form of loop expected by + the loop optimizer, which is the do-while form: + + ENTRY_COND + loop: + TOP_UPDATE + BODY + BOTTOM_COND + GOTO loop + + This makes it possible to bypass loop header copying and to turn the + BOTTOM_COND into an inequality test. This should catch (almost) all + loops with constant starting point. If we cannot, we try to generate + the default form, which is: + + loop: + TOP_COND + BODY + BOTTOM_UPDATE + GOTO loop + + It will be rotated during loop header copying and an entry test added + to yield the do-while form. This should catch (almost) all loops with + constant ending point. If we cannot, we generate the fallback form: + + ENTRY_COND + loop: + BODY + BOTTOM_COND + BOTTOM_UPDATE + GOTO loop + + which works in all cases but for which loop header copying will copy + the BOTTOM_COND, thus adding a third conditional branch. + + If optimization is disabled, loop header copying doesn't come into + play and we try to generate the loop forms with the less conditional + branches directly. First, the default form, it should catch (almost) + all loops with constant ending point. Then, if we cannot, we try to + generate the shifted form: + + loop: + TOP_COND + TOP_UPDATE + BODY + GOTO loop + + which should catch loops with constant starting point. Otherwise, if + we cannot, we generate the fallback form. */ + + if (optimize) + { + /* We can use the do-while form if GNU_FIRST-1 doesn't overflow. */ + if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse)) + { + gnu_first = build_binary_op (shift_code, gnu_base_type, + gnu_first, gnu_one_node); + LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1; + LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1; + } + + /* Otherwise, we can use the default form if GNU_LAST+1 doesn't. */ + else if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse)) + ; + + /* Otherwise, use the fallback form. */ + else + fallback = true; + } + else + { + /* We can use the default form if GNU_LAST+1 doesn't overflow. */ + if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse)) + ; + + /* Otherwise, we can use the shifted form if neither GNU_FIRST-1 nor + GNU_LAST-1 does. */ + else if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse) + && !can_equal_min_val_p (gnu_last, gnu_base_type, reverse)) + { + gnu_first = build_binary_op (shift_code, gnu_base_type, + gnu_first, gnu_one_node); + gnu_last = build_binary_op (shift_code, gnu_base_type, + gnu_last, gnu_one_node); + LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1; + } + + /* Otherwise, use the fallback form. */ + else + fallback = true; + } + + if (fallback) + LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1; + + /* If we use the BOTTOM_COND, we can turn the test into an inequality + test but we may have to add ENTRY_COND to protect the empty loop. */ + if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt)) + { + test_code = NE_EXPR; + if (can_be_lower_p (gnu_high, gnu_low)) + { + gnu_cond_expr + = build3 (COND_EXPR, void_type_node, + build_binary_op (LE_EXPR, boolean_type_node, + gnu_low, gnu_high), + NULL_TREE, alloc_stmt_list ()); + set_expr_location_from_node (gnu_cond_expr, gnat_loop_spec); + } + } + + /* Open a new nesting level that will surround the loop to declare the + iteration variable. */ + start_stmt_group (); + gnat_pushlevel (); + + /* Declare the iteration variable and set it to its initial value. */ + gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1); + if (DECL_BY_REF_P (gnu_loop_var)) + gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var); + + /* Do all the arithmetics in the base type. */ + gnu_loop_var = convert (gnu_base_type, gnu_loop_var); + + /* Set either the top or bottom exit condition. */ + LOOP_STMT_COND (gnu_loop_stmt) + = build_binary_op (test_code, boolean_type_node, gnu_loop_var, + gnu_last); + + /* Set either the top or bottom update statement and give it the source + location of the iteration for better coverage info. */ + LOOP_STMT_UPDATE (gnu_loop_stmt) + = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var, + build_binary_op (update_code, gnu_base_type, + gnu_loop_var, gnu_one_node)); + set_expr_location_from_node (LOOP_STMT_UPDATE (gnu_loop_stmt), + gnat_iter_scheme); + } + + /* If the loop was named, have the name point to this loop. In this case, + the association is not a DECL node, but the end label of the loop. */ + if (Present (Identifier (gnat_node))) + save_gnu_tree (Entity (Identifier (gnat_node)), gnu_loop_label, true); + + /* Make the loop body into its own block, so any allocated storage will be + released every iteration. This is needed for stack allocation. */ + LOOP_STMT_BODY (gnu_loop_stmt) + = build_stmt_group (Statements (gnat_node), true); + TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1; + + /* If we declared a variable, then we are in a statement group for that + declaration. Add the LOOP_STMT to it and make that the "loop". */ + if (gnu_loop_var) + { + add_stmt (gnu_loop_stmt); + gnat_poplevel (); + gnu_loop_stmt = end_stmt_group (); + } + + /* If we have an outer COND_EXPR, that's our result and this loop is its + "true" statement. Otherwise, the result is the LOOP_STMT. */ + if (gnu_cond_expr) + { + COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt; + gnu_result = gnu_cond_expr; + recalculate_side_effects (gnu_cond_expr); + } + else + gnu_result = gnu_loop_stmt; + + VEC_pop (tree, gnu_loop_label_stack); + + return gnu_result; +} + +/* Emit statements to establish __gnat_handle_vms_condition as a VMS condition + handler for the current function. */ + +/* This is implemented by issuing a call to the appropriate VMS specific + builtin. To avoid having VMS specific sections in the global gigi decls + array, we maintain the decls of interest here. We can't declare them + inside the function because we must mark them never to be GC'd, which we + can only do at the global level. */ + +static GTY(()) tree vms_builtin_establish_handler_decl = NULL_TREE; +static GTY(()) tree gnat_vms_condition_handler_decl = NULL_TREE; + +static void +establish_gnat_vms_condition_handler (void) +{ + tree establish_stmt; + + /* Elaborate the required decls on the first call. Check on the decl for + the gnat condition handler to decide, as this is one we create so we are + sure that it will be non null on subsequent calls. The builtin decl is + looked up so remains null on targets where it is not implemented yet. */ + if (gnat_vms_condition_handler_decl == NULL_TREE) + { + vms_builtin_establish_handler_decl + = builtin_decl_for + (get_identifier ("__builtin_establish_vms_condition_handler")); + + gnat_vms_condition_handler_decl + = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"), + NULL_TREE, + build_function_type_list (boolean_type_node, + ptr_void_type_node, + ptr_void_type_node, + NULL_TREE), + NULL_TREE, 0, 1, 1, 0, Empty); + + /* ??? DECL_CONTEXT shouldn't have been set because of DECL_EXTERNAL. */ + DECL_CONTEXT (gnat_vms_condition_handler_decl) = NULL_TREE; + } + + /* Do nothing if the establish builtin is not available, which might happen + on targets where the facility is not implemented. */ + if (vms_builtin_establish_handler_decl == NULL_TREE) + return; + + establish_stmt + = build_call_1_expr (vms_builtin_establish_handler_decl, + build_unary_op + (ADDR_EXPR, NULL_TREE, + gnat_vms_condition_handler_decl)); + + add_stmt (establish_stmt); +} + +/* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We + don't return anything. */ + +static void +Subprogram_Body_to_gnu (Node_Id gnat_node) +{ + /* Defining identifier of a parameter to the subprogram. */ + Entity_Id gnat_param; + /* The defining identifier for the subprogram body. Note that if a + specification has appeared before for this body, then the identifier + occurring in that specification will also be a defining identifier and all + the calls to this subprogram will point to that specification. */ + Entity_Id gnat_subprog_id + = (Present (Corresponding_Spec (gnat_node)) + ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node)); + /* The FUNCTION_DECL node corresponding to the subprogram spec. */ + tree gnu_subprog_decl; + /* Its RESULT_DECL node. */ + tree gnu_result_decl; + /* Its FUNCTION_TYPE node. */ + tree gnu_subprog_type; + /* The TYPE_CI_CO_LIST of its FUNCTION_TYPE node, if any. */ + tree gnu_cico_list; + /* The entry in the CI_CO_LIST that represents a function return, if any. */ + tree gnu_return_var_elmt = NULL_TREE; + tree gnu_result; + VEC(parm_attr,gc) *cache; + + /* If this is a generic object or if it has been eliminated, + ignore it. */ + if (Ekind (gnat_subprog_id) == E_Generic_Procedure + || Ekind (gnat_subprog_id) == E_Generic_Function + || Is_Eliminated (gnat_subprog_id)) + return; + + /* If this subprogram acts as its own spec, define it. Otherwise, just get + the already-elaborated tree node. However, if this subprogram had its + elaboration deferred, we will already have made a tree node for it. So + treat it as not being defined in that case. Such a subprogram cannot + have an address clause or a freeze node, so this test is safe, though it + does disable some otherwise-useful error checking. */ + gnu_subprog_decl + = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, + Acts_As_Spec (gnat_node) + && !present_gnu_tree (gnat_subprog_id)); + gnu_result_decl = DECL_RESULT (gnu_subprog_decl); + gnu_subprog_type = TREE_TYPE (gnu_subprog_decl); + gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); + if (gnu_cico_list) + gnu_return_var_elmt = value_member (void_type_node, gnu_cico_list); + + /* If the function returns by invisible reference, make it explicit in the + function body. See gnat_to_gnu_entity, E_Subprogram_Type case. + Handle the explicit case here and the copy-in/copy-out case below. */ + if (TREE_ADDRESSABLE (gnu_subprog_type) && !gnu_return_var_elmt) + { + TREE_TYPE (gnu_result_decl) + = build_reference_type (TREE_TYPE (gnu_result_decl)); + relayout_decl (gnu_result_decl); + } + + /* Propagate the debug mode. */ + if (!Needs_Debug_Info (gnat_subprog_id)) + DECL_IGNORED_P (gnu_subprog_decl) = 1; + + /* Set the line number in the decl to correspond to that of the body so that + the line number notes are written correctly. */ + Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl)); + + /* Initialize the information structure for the function. */ + allocate_struct_function (gnu_subprog_decl, false); + DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language + = ggc_alloc_cleared_language_function (); + set_cfun (NULL); + + begin_subprog_body (gnu_subprog_decl); + + /* If there are In Out or Out parameters, we need to ensure that the return + statement properly copies them out. We do this by making a new block and + converting any return into a goto to a label at the end of the block. */ + if (gnu_cico_list) + { + tree gnu_return_var = NULL_TREE; + + VEC_safe_push (tree, gc, gnu_return_label_stack, + create_artificial_label (input_location)); + + start_stmt_group (); + gnat_pushlevel (); + + /* If this is a function with In Out or Out parameters, we also need a + variable for the return value to be placed. */ + if (gnu_return_var_elmt) + { + tree gnu_return_type + = TREE_TYPE (TREE_PURPOSE (gnu_return_var_elmt)); + + /* If the function returns by invisible reference, make it + explicit in the function body. See gnat_to_gnu_entity, + E_Subprogram_Type case. */ + if (TREE_ADDRESSABLE (gnu_subprog_type)) + gnu_return_type = build_reference_type (gnu_return_type); + + gnu_return_var + = create_var_decl (get_identifier ("RETVAL"), NULL_TREE, + gnu_return_type, NULL_TREE, false, false, + false, false, NULL, gnat_subprog_id); + TREE_VALUE (gnu_return_var_elmt) = gnu_return_var; + } + + VEC_safe_push (tree, gc, gnu_return_var_stack, gnu_return_var); + + /* See whether there are parameters for which we don't have a GCC tree + yet. These must be Out parameters. Make a VAR_DECL for them and + put it into TYPE_CI_CO_LIST, which must contain an empty entry too. + We can match up the entries because TYPE_CI_CO_LIST is in the order + of the parameters. */ + for (gnat_param = First_Formal_With_Extras (gnat_subprog_id); + Present (gnat_param); + gnat_param = Next_Formal_With_Extras (gnat_param)) + if (!present_gnu_tree (gnat_param)) + { + tree gnu_cico_entry = gnu_cico_list; + + /* Skip any entries that have been already filled in; they must + correspond to In Out parameters. */ + while (gnu_cico_entry && TREE_VALUE (gnu_cico_entry)) + gnu_cico_entry = TREE_CHAIN (gnu_cico_entry); + + /* Do any needed references for padded types. */ + TREE_VALUE (gnu_cico_entry) + = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry)), + gnat_to_gnu_entity (gnat_param, NULL_TREE, 1)); + } + } + else + VEC_safe_push (tree, gc, gnu_return_label_stack, NULL_TREE); + + /* Get a tree corresponding to the code for the subprogram. */ + start_stmt_group (); + gnat_pushlevel (); + + /* On VMS, establish our condition handler to possibly turn a condition into + the corresponding exception if the subprogram has a foreign convention or + is exported. + + To ensure proper execution of local finalizations on condition instances, + we must turn a condition into the corresponding exception even if there + is no applicable Ada handler, and need at least one condition handler per + possible call chain involving GNAT code. OTOH, establishing the handler + has a cost so we want to minimize the number of subprograms into which + this happens. The foreign or exported condition is expected to satisfy + all the constraints. */ + if (TARGET_ABI_OPEN_VMS + && (Has_Foreign_Convention (gnat_subprog_id) + || Is_Exported (gnat_subprog_id))) + establish_gnat_vms_condition_handler (); + + process_decls (Declarations (gnat_node), Empty, Empty, true, true); + + /* Generate the code of the subprogram itself. A return statement will be + present and any Out parameters will be handled there. */ + add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); + gnat_poplevel (); + gnu_result = end_stmt_group (); + + /* If we populated the parameter attributes cache, we need to make sure that + the cached expressions are evaluated on all the possible paths leading to + their uses. So we force their evaluation on entry of the function. */ + cache = DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language->parm_attr_cache; + if (cache) + { + struct parm_attr_d *pa; + int i; + + start_stmt_group (); + + FOR_EACH_VEC_ELT (parm_attr, cache, i, pa) + { + if (pa->first) + add_stmt_with_node_force (pa->first, gnat_node); + if (pa->last) + add_stmt_with_node_force (pa->last, gnat_node); + if (pa->length) + add_stmt_with_node_force (pa->length, gnat_node); + } + + add_stmt (gnu_result); + gnu_result = end_stmt_group (); + } + + /* If we are dealing with a return from an Ada procedure with parameters + passed by copy-in/copy-out, we need to return a record containing the + final values of these parameters. If the list contains only one entry, + return just that entry though. + + For a full description of the copy-in/copy-out parameter mechanism, see + the part of the gnat_to_gnu_entity routine dealing with the translation + of subprograms. + + We need to make a block that contains the definition of that label and + the copying of the return value. It first contains the function, then + the label and copy statement. */ + if (gnu_cico_list) + { + tree gnu_retval; + + add_stmt (gnu_result); + add_stmt (build1 (LABEL_EXPR, void_type_node, + VEC_last (tree, gnu_return_label_stack))); + + if (list_length (gnu_cico_list) == 1) + gnu_retval = TREE_VALUE (gnu_cico_list); + else + gnu_retval = build_constructor_from_list (TREE_TYPE (gnu_subprog_type), + gnu_cico_list); + + add_stmt_with_node (build_return_expr (gnu_result_decl, gnu_retval), + End_Label (Handled_Statement_Sequence (gnat_node))); + gnat_poplevel (); + gnu_result = end_stmt_group (); + } + + VEC_pop (tree, gnu_return_label_stack); + + end_subprog_body (gnu_result); + + /* Attempt setting the end_locus of our GCC body tree, typically a + BIND_EXPR or STATEMENT_LIST, then the end_locus of our GCC subprogram + declaration tree. */ + set_end_locus_from_node (gnu_result, gnat_node); + set_end_locus_from_node (gnu_subprog_decl, gnat_node); + + /* Finally annotate the parameters and disconnect the trees for parameters + that we have turned into variables since they are now unusable. */ + for (gnat_param = First_Formal_With_Extras (gnat_subprog_id); + Present (gnat_param); + gnat_param = Next_Formal_With_Extras (gnat_param)) + { + tree gnu_param = get_gnu_tree (gnat_param); + bool is_var_decl = (TREE_CODE (gnu_param) == VAR_DECL); + + annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE, + DECL_BY_REF_P (gnu_param), + !is_var_decl && DECL_BY_DOUBLE_REF_P (gnu_param)); + + if (is_var_decl) + save_gnu_tree (gnat_param, NULL_TREE, false); + } + + if (DECL_FUNCTION_STUB (gnu_subprog_decl)) + build_function_stub (gnu_subprog_decl, gnat_subprog_id); + + if (gnu_return_var_elmt) + TREE_VALUE (gnu_return_var_elmt) = void_type_node; + + mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node))); +} + + +/* Create a temporary variable with PREFIX and initialize it with GNU_INIT. + Put the initialization statement into GNU_INIT_STMT and annotate it with + the SLOC of GNAT_NODE. Return the temporary variable. */ + +static tree +create_init_temporary (const char *prefix, tree gnu_init, tree *gnu_init_stmt, + Node_Id gnat_node) +{ + tree gnu_temp = create_var_decl (create_tmp_var_name (prefix), NULL_TREE, + TREE_TYPE (gnu_init), NULL_TREE, false, + false, false, false, NULL, Empty); + DECL_ARTIFICIAL (gnu_temp) = 1; + DECL_IGNORED_P (gnu_temp) = 1; + + *gnu_init_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_init); + set_expr_location_from_node (*gnu_init_stmt, gnat_node); + + return gnu_temp; +} + +/* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call + or an N_Procedure_Call_Statement, to a GCC tree, which is returned. + GNU_RESULT_TYPE_P is a pointer to where we should place the result type. + If GNU_TARGET is non-null, this must be a function call on the RHS of a + N_Assignment_Statement and the result is to be placed into that object. */ + +static tree +call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) +{ + /* The GCC node corresponding to the GNAT subprogram name. This can either + be a FUNCTION_DECL node if we are dealing with a standard subprogram call, + or an indirect reference expression (an INDIRECT_REF node) pointing to a + subprogram. */ + tree gnu_subprog = gnat_to_gnu (Name (gnat_node)); + /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */ + tree gnu_subprog_type = TREE_TYPE (gnu_subprog); + tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog); + Entity_Id gnat_formal; + Node_Id gnat_actual; + VEC(tree,gc) *gnu_actual_vec = NULL; + tree gnu_name_list = NULL_TREE; + tree gnu_before_list = NULL_TREE; + tree gnu_after_list = NULL_TREE; + tree gnu_call, gnu_result; + bool returning_value = (Nkind (gnat_node) == N_Function_Call && !gnu_target); + bool pushed_binding_level = false; + bool went_into_elab_proc = false; + + gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE); + + /* If we are calling a stubbed function, raise Program_Error, but Elaborate + all our args first. */ + if (TREE_CODE (gnu_subprog) == FUNCTION_DECL && DECL_STUBBED_P (gnu_subprog)) + { + tree call_expr = build_call_raise (PE_Stubbed_Subprogram_Called, + gnat_node, N_Raise_Program_Error); + + for (gnat_actual = First_Actual (gnat_node); + Present (gnat_actual); + gnat_actual = Next_Actual (gnat_actual)) + add_stmt (gnat_to_gnu (gnat_actual)); + + if (returning_value) + { + *gnu_result_type_p = TREE_TYPE (gnu_subprog_type); + return build1 (NULL_EXPR, TREE_TYPE (gnu_subprog_type), call_expr); + } + + return call_expr; + } + + /* The only way we can be making a call via an access type is if Name is an + explicit dereference. In that case, get the list of formal args from the + type the access type is pointing to. Otherwise, get the formals from the + entity being called. */ + if (Nkind (Name (gnat_node)) == N_Explicit_Dereference) + gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node))); + else if (Nkind (Name (gnat_node)) == N_Attribute_Reference) + /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */ + gnat_formal = Empty; + else + gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node))); + + /* If we are translating a statement, push a new binding level that will + surround it to declare the temporaries created for the call. Likewise + if we'll be returning a value and also have copy-in/copy-out parameters, + as we need to create statements to fetch their value after the call. + + ??? We could do that unconditionally, but the middle-end doesn't seem + to be prepared to handle the construct in nested contexts. */ + if (!returning_value || TYPE_CI_CO_LIST (gnu_subprog_type)) + { + start_stmt_group (); + gnat_pushlevel (); + pushed_binding_level = true; + } + + /* The lifetime of the temporaries created for the call ends with the call + so we can give them the scope of the elaboration routine at top level. */ + if (!current_function_decl) + { + current_function_decl = get_elaboration_procedure (); + went_into_elab_proc = true; + } + + /* Create the list of the actual parameters as GCC expects it, namely a + chain of TREE_LIST nodes in which the TREE_VALUE field of each node + is an expression and the TREE_PURPOSE field is null. But skip Out + parameters not passed by reference and that need not be copied in. */ + for (gnat_actual = First_Actual (gnat_node); + Present (gnat_actual); + gnat_formal = Next_Formal_With_Extras (gnat_formal), + gnat_actual = Next_Actual (gnat_actual)) + { + tree gnu_formal = present_gnu_tree (gnat_formal) + ? get_gnu_tree (gnat_formal) : NULL_TREE; + tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal)); + /* In the Out or In Out case, we must suppress conversions that yield + an lvalue but can nevertheless cause the creation of a temporary, + because we need the real object in this case, either to pass its + address if it's passed by reference or as target of the back copy + done after the call if it uses the copy-in copy-out mechanism. + We do it in the In case too, except for an unchecked conversion + because it alone can cause the actual to be misaligned and the + addressability test is applied to the real object. */ + bool suppress_type_conversion + = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion + && Ekind (gnat_formal) != E_In_Parameter) + || (Nkind (gnat_actual) == N_Type_Conversion + && Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))); + Node_Id gnat_name = suppress_type_conversion + ? Expression (gnat_actual) : gnat_actual; + tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type; + tree gnu_actual; + + /* If it's possible we may need to use this expression twice, make sure + that any side-effects are handled via SAVE_EXPRs; likewise if we need + to force side-effects before the call. + ??? This is more conservative than we need since we don't need to do + this for pass-by-ref with no conversion. */ + if (Ekind (gnat_formal) != E_In_Parameter) + gnu_name = gnat_stabilize_reference (gnu_name, true, NULL); + + /* If we are passing a non-addressable parameter by reference, pass the + address of a copy. In the Out or In Out case, set up to copy back + out after the call. */ + if (gnu_formal + && (DECL_BY_REF_P (gnu_formal) + || (TREE_CODE (gnu_formal) == PARM_DECL + && (DECL_BY_COMPONENT_PTR_P (gnu_formal) + || (DECL_BY_DESCRIPTOR_P (gnu_formal))))) + && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name))) + && !addressable_p (gnu_name, gnu_name_type)) + { + bool in_param = (Ekind (gnat_formal) == E_In_Parameter); + tree gnu_orig = gnu_name, gnu_temp, gnu_stmt; + + /* Do not issue warnings for CONSTRUCTORs since this is not a copy + but sort of an instantiation for them. */ + if (TREE_CODE (gnu_name) == CONSTRUCTOR) + ; + + /* If the type is passed by reference, a copy is not allowed. */ + else if (TREE_ADDRESSABLE (gnu_formal_type)) + post_error ("misaligned actual cannot be passed by reference", + gnat_actual); + + /* For users of Starlet we issue a warning because the interface + apparently assumes that by-ref parameters outlive the procedure + invocation. The code still will not work as intended, but we + cannot do much better since low-level parts of the back-end + would allocate temporaries at will because of the misalignment + if we did not do so here. */ + else if (Is_Valued_Procedure (Entity (Name (gnat_node)))) + { + post_error + ("?possible violation of implicit assumption", gnat_actual); + post_error_ne + ("?made by pragma Import_Valued_Procedure on &", gnat_actual, + Entity (Name (gnat_node))); + post_error_ne ("?because of misalignment of &", gnat_actual, + gnat_formal); + } + + /* If the actual type of the object is already the nominal type, + we have nothing to do, except if the size is self-referential + in which case we'll remove the unpadding below. */ + if (TREE_TYPE (gnu_name) == gnu_name_type + && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type))) + ; + + /* Otherwise remove the unpadding from all the objects. */ + else if (TREE_CODE (gnu_name) == COMPONENT_REF + && TYPE_IS_PADDING_P + (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))) + gnu_orig = gnu_name = TREE_OPERAND (gnu_name, 0); + + /* Otherwise convert to the nominal type of the object if needed. + There are several cases in which we need to make the temporary + using this type instead of the actual type of the object when + they are distinct, because the expectations of the callee would + otherwise not be met: + - if it's a justified modular type, + - if the actual type is a smaller form of it, + - if it's a smaller form of the actual type. */ + else if ((TREE_CODE (gnu_name_type) == RECORD_TYPE + && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type) + || smaller_form_type_p (TREE_TYPE (gnu_name), + gnu_name_type))) + || (INTEGRAL_TYPE_P (gnu_name_type) + && smaller_form_type_p (gnu_name_type, + TREE_TYPE (gnu_name)))) + gnu_name = convert (gnu_name_type, gnu_name); + + /* If we haven't pushed a binding level and this is an In Out or Out + parameter, push a new one. This is needed to wrap the copy-back + statements we'll be making below. */ + if (!pushed_binding_level && !in_param) + { + start_stmt_group (); + gnat_pushlevel (); + pushed_binding_level = true; + } + + /* Create an explicit temporary holding the copy. This ensures that + its lifetime is as narrow as possible around a statement. */ + gnu_temp + = create_init_temporary ("A", gnu_name, &gnu_stmt, gnat_actual); + + /* But initialize it on the fly like for an implicit temporary as + we aren't necessarily dealing with a statement. */ + gnu_name = build_compound_expr (TREE_TYPE (gnu_name), gnu_stmt, + gnu_temp); + + /* Set up to move the copy back to the original if needed. */ + if (!in_param) + { + gnu_stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig, + gnu_temp); + set_expr_location_from_node (gnu_stmt, gnat_node); + append_to_statement_list (gnu_stmt, &gnu_after_list); + } + } + + /* Start from the real object and build the actual. */ + gnu_actual = gnu_name; + + /* If this was a procedure call, we may not have removed any padding. + So do it here for the part we will use as an input, if any. */ + if (Ekind (gnat_formal) != E_Out_Parameter + && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))) + gnu_actual + = convert (get_unpadded_type (Etype (gnat_actual)), gnu_actual); + + /* Put back the conversion we suppressed above in the computation of the + real object. And even if we didn't suppress any conversion there, we + may have suppressed a conversion to the Etype of the actual earlier, + since the parent is a procedure call, so put it back here. */ + if (suppress_type_conversion + && Nkind (gnat_actual) == N_Unchecked_Type_Conversion) + gnu_actual + = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)), + gnu_actual, No_Truncation (gnat_actual)); + else + gnu_actual + = convert (gnat_to_gnu_type (Etype (gnat_actual)), gnu_actual); + + /* Make sure that the actual is in range of the formal's type. */ + if (Ekind (gnat_formal) != E_Out_Parameter + && Do_Range_Check (gnat_actual)) + gnu_actual + = emit_range_check (gnu_actual, Etype (gnat_formal), gnat_actual); + + /* Unless this is an In parameter, we must remove any justified modular + building from GNU_NAME to get an lvalue. */ + if (Ekind (gnat_formal) != E_In_Parameter + && TREE_CODE (gnu_name) == CONSTRUCTOR + && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name))) + gnu_name + = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))), gnu_name); + + /* If we have not saved a GCC object for the formal, it means it is an + Out parameter not passed by reference and that need not be copied in. + Otherwise, first see if the parameter is passed by reference. */ + if (gnu_formal + && TREE_CODE (gnu_formal) == PARM_DECL + && DECL_BY_REF_P (gnu_formal)) + { + if (Ekind (gnat_formal) != E_In_Parameter) + { + /* In Out or Out parameters passed by reference don't use the + copy-in copy-out mechanism so the address of the real object + must be passed to the function. */ + gnu_actual = gnu_name; + + /* If we have a padded type, be sure we've removed padding. */ + if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))) + gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)), + gnu_actual); + + /* If we have the constructed subtype of an aliased object + with an unconstrained nominal subtype, the type of the + actual includes the template, although it is formally + constrained. So we need to convert it back to the real + constructed subtype to retrieve the constrained part + and takes its address. */ + if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual)) + && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual)) + && Is_Array_Type (Etype (gnat_actual))) + gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)), + gnu_actual); + } + + /* There is no need to convert the actual to the formal's type before + taking its address. The only exception is for unconstrained array + types because of the way we build fat pointers. */ + else if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE) + gnu_actual = convert (gnu_formal_type, gnu_actual); + + /* The symmetry of the paths to the type of an entity is broken here + since arguments don't know that they will be passed by ref. */ + gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal)); + + if (DECL_BY_DOUBLE_REF_P (gnu_formal)) + gnu_actual + = build_unary_op (ADDR_EXPR, TREE_TYPE (gnu_formal_type), + gnu_actual); + + gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual); + } + else if (gnu_formal + && TREE_CODE (gnu_formal) == PARM_DECL + && DECL_BY_COMPONENT_PTR_P (gnu_formal)) + { + gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal)); + gnu_actual = maybe_implicit_deref (gnu_actual); + gnu_actual = maybe_unconstrained_array (gnu_actual); + + if (TYPE_IS_PADDING_P (gnu_formal_type)) + { + gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type)); + gnu_actual = convert (gnu_formal_type, gnu_actual); + } + + /* Take the address of the object and convert to the proper pointer + type. We'd like to actually compute the address of the beginning + of the array using an ADDR_EXPR of an ARRAY_REF, but there's a + possibility that the ARRAY_REF might return a constant and we'd be + getting the wrong address. Neither approach is exactly correct, + but this is the most likely to work in all cases. */ + gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual); + } + else if (gnu_formal + && TREE_CODE (gnu_formal) == PARM_DECL + && DECL_BY_DESCRIPTOR_P (gnu_formal)) + { + gnu_actual = convert (gnu_formal_type, gnu_actual); + + /* If this is 'Null_Parameter, pass a zero descriptor. */ + if ((TREE_CODE (gnu_actual) == INDIRECT_REF + || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF) + && TREE_PRIVATE (gnu_actual)) + gnu_actual + = convert (DECL_ARG_TYPE (gnu_formal), integer_zero_node); + else + gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE, + fill_vms_descriptor + (TREE_TYPE (TREE_TYPE (gnu_formal)), + gnu_actual, gnat_actual)); + } + else + { + tree gnu_size; + + if (Ekind (gnat_formal) != E_In_Parameter) + gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list); + + if (!(gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL)) + { + /* Make sure side-effects are evaluated before the call. */ + if (TREE_SIDE_EFFECTS (gnu_name)) + append_to_statement_list (gnu_name, &gnu_before_list); + continue; + } + + gnu_actual = convert (gnu_formal_type, gnu_actual); + + /* If this is 'Null_Parameter, pass a zero even though we are + dereferencing it. */ + if (TREE_CODE (gnu_actual) == INDIRECT_REF + && TREE_PRIVATE (gnu_actual) + && (gnu_size = TYPE_SIZE (TREE_TYPE (gnu_actual))) + && TREE_CODE (gnu_size) == INTEGER_CST + && compare_tree_int (gnu_size, BITS_PER_WORD) <= 0) + gnu_actual + = unchecked_convert (DECL_ARG_TYPE (gnu_formal), + convert (gnat_type_for_size + (TREE_INT_CST_LOW (gnu_size), 1), + integer_zero_node), + false); + else + gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual); + } + + VEC_safe_push (tree, gc, gnu_actual_vec, gnu_actual); + } + + gnu_call = build_call_vec (TREE_TYPE (gnu_subprog_type), gnu_subprog_addr, + gnu_actual_vec); + set_expr_location_from_node (gnu_call, gnat_node); + + /* If this is a subprogram with copy-in/copy-out parameters, we need to + unpack the valued returned from the function into the In Out or Out + parameters. We deal with the function return (if this is an Ada + function) below. */ + if (TYPE_CI_CO_LIST (gnu_subprog_type)) + { + /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/ + copy-out parameters. */ + tree gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); + const int length = list_length (gnu_cico_list); + + /* The call sequence must contain one and only one call, even though the + function is pure. Save the result into a temporary if needed. */ + if (length > 1) + { + tree gnu_stmt; + gnu_call + = create_init_temporary ("R", gnu_call, &gnu_stmt, gnat_node); + append_to_statement_list (gnu_stmt, &gnu_before_list); + + gnu_name_list = nreverse (gnu_name_list); + } + + /* The first entry is for the actual return value if this is a + function, so skip it. */ + if (TREE_VALUE (gnu_cico_list) == void_type_node) + gnu_cico_list = TREE_CHAIN (gnu_cico_list); + + if (Nkind (Name (gnat_node)) == N_Explicit_Dereference) + gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node))); + else + gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node))); + + for (gnat_actual = First_Actual (gnat_node); + Present (gnat_actual); + gnat_formal = Next_Formal_With_Extras (gnat_formal), + gnat_actual = Next_Actual (gnat_actual)) + /* If we are dealing with a copy-in/copy-out parameter, we must + retrieve its value from the record returned in the call. */ + if (!(present_gnu_tree (gnat_formal) + && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL + && (DECL_BY_REF_P (get_gnu_tree (gnat_formal)) + || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL + && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal)) + || (DECL_BY_DESCRIPTOR_P + (get_gnu_tree (gnat_formal)))))))) + && Ekind (gnat_formal) != E_In_Parameter) + { + /* Get the value to assign to this Out or In Out parameter. It is + either the result of the function if there is only a single such + parameter or the appropriate field from the record returned. */ + tree gnu_result + = length == 1 + ? gnu_call + : build_component_ref (gnu_call, NULL_TREE, + TREE_PURPOSE (gnu_cico_list), false); + + /* If the actual is a conversion, get the inner expression, which + will be the real destination, and convert the result to the + type of the actual parameter. */ + tree gnu_actual + = maybe_unconstrained_array (TREE_VALUE (gnu_name_list)); + + /* If the result is a padded type, remove the padding. */ + if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))) + gnu_result + = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))), + gnu_result); + + /* If the actual is a type conversion, the real target object is + denoted by the inner Expression and we need to convert the + result to the associated type. + We also need to convert our gnu assignment target to this type + if the corresponding GNU_NAME was constructed from the GNAT + conversion node and not from the inner Expression. */ + if (Nkind (gnat_actual) == N_Type_Conversion) + { + gnu_result + = convert_with_check + (Etype (Expression (gnat_actual)), gnu_result, + Do_Overflow_Check (gnat_actual), + Do_Range_Check (Expression (gnat_actual)), + Float_Truncate (gnat_actual), gnat_actual); + + if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal)))) + gnu_actual = convert (TREE_TYPE (gnu_result), gnu_actual); + } + + /* Unchecked conversions as actuals for Out parameters are not + allowed in user code because they are not variables, but do + occur in front-end expansions. The associated GNU_NAME is + always obtained from the inner expression in such cases. */ + else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion) + gnu_result = unchecked_convert (TREE_TYPE (gnu_actual), + gnu_result, + No_Truncation (gnat_actual)); + else + { + if (Do_Range_Check (gnat_actual)) + gnu_result + = emit_range_check (gnu_result, Etype (gnat_actual), + gnat_actual); + + if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual))) + && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result))))) + gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result); + } + + gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE, + gnu_actual, gnu_result); + set_expr_location_from_node (gnu_result, gnat_node); + append_to_statement_list (gnu_result, &gnu_before_list); + gnu_cico_list = TREE_CHAIN (gnu_cico_list); + gnu_name_list = TREE_CHAIN (gnu_name_list); + } + } + + /* If this is a function call, the result is the call expression unless a + target is specified, in which case we copy the result into the target + and return the assignment statement. */ + if (Nkind (gnat_node) == N_Function_Call) + { + tree gnu_result_type = TREE_TYPE (gnu_subprog_type); + + /* If this is a function with copy-in/copy-out parameters, extract the + return value from it and update the return type. */ + if (TYPE_CI_CO_LIST (gnu_subprog_type)) + { + tree gnu_elmt = value_member (void_type_node, + TYPE_CI_CO_LIST (gnu_subprog_type)); + gnu_call = build_component_ref (gnu_call, NULL_TREE, + TREE_PURPOSE (gnu_elmt), false); + gnu_result_type = TREE_TYPE (gnu_call); + } + + /* If the function returns an unconstrained array or by direct reference, + we have to dereference the pointer. */ + if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type) + || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type)) + gnu_call = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_call); + + if (gnu_target) + { + Node_Id gnat_parent = Parent (gnat_node); + enum tree_code op_code; + + /* If range check is needed, emit code to generate it. */ + if (Do_Range_Check (gnat_node)) + gnu_call + = emit_range_check (gnu_call, Etype (Name (gnat_parent)), + gnat_parent); + + /* ??? If the return type has non-constant size, then force the + return slot optimization as we would not be able to generate + a temporary. Likewise if it was unconstrained as we would + copy too much data. That's what has been done historically. */ + if (!TREE_CONSTANT (TYPE_SIZE (gnu_result_type)) + || (TYPE_IS_PADDING_P (gnu_result_type) + && CONTAINS_PLACEHOLDER_P + (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_result_type)))))) + op_code = INIT_EXPR; + else + op_code = MODIFY_EXPR; + + gnu_call + = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_call); + set_expr_location_from_node (gnu_call, gnat_parent); + append_to_statement_list (gnu_call, &gnu_before_list); + } + else + *gnu_result_type_p = get_unpadded_type (Etype (gnat_node)); + } + + /* Otherwise, if this is a procedure call statement without copy-in/copy-out + parameters, the result is just the call statement. */ + else if (!TYPE_CI_CO_LIST (gnu_subprog_type)) + append_to_statement_list (gnu_call, &gnu_before_list); + + if (went_into_elab_proc) + current_function_decl = NULL_TREE; + + /* If we have pushed a binding level, the result is the statement group. + Otherwise it's just the call expression. */ + if (pushed_binding_level) + { + /* If we need a value and haven't created the call statement, do so. */ + if (returning_value && !TYPE_CI_CO_LIST (gnu_subprog_type)) + { + tree gnu_stmt; + gnu_call + = create_init_temporary ("R", gnu_call, &gnu_stmt, gnat_node); + append_to_statement_list (gnu_stmt, &gnu_before_list); + } + append_to_statement_list (gnu_after_list, &gnu_before_list); + add_stmt (gnu_before_list); + gnat_poplevel (); + gnu_result = end_stmt_group (); + } + else + return gnu_call; + + /* If we need a value, make a COMPOUND_EXPR to return it; otherwise, + return the result. Deal specially with UNCONSTRAINED_ARRAY_REF. */ + if (returning_value) + gnu_result = build_compound_expr (TREE_TYPE (gnu_call), gnu_result, + gnu_call); + + return gnu_result; +} + +/* Subroutine of gnat_to_gnu to translate gnat_node, an + N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */ + +static tree +Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) +{ + tree gnu_jmpsave_decl = NULL_TREE; + tree gnu_jmpbuf_decl = NULL_TREE; + /* If just annotating, ignore all EH and cleanups. */ + bool gcc_zcx = (!type_annotate_only + && Present (Exception_Handlers (gnat_node)) + && Exception_Mechanism == Back_End_Exceptions); + bool setjmp_longjmp + = (!type_annotate_only && Present (Exception_Handlers (gnat_node)) + && Exception_Mechanism == Setjmp_Longjmp); + bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node)); + bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp); + tree gnu_inner_block; /* The statement(s) for the block itself. */ + tree gnu_result; + tree gnu_expr; + Node_Id gnat_temp; + + /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes + and we have our own SJLJ mechanism. To call the GCC mechanism, we call + add_cleanup, and when we leave the binding, end_stmt_group will create + the TRY_FINALLY_EXPR. + + ??? The region level calls down there have been specifically put in place + for a ZCX context and currently the order in which things are emitted + (region/handlers) is different from the SJLJ case. Instead of putting + other calls with different conditions at other places for the SJLJ case, + it seems cleaner to reorder things for the SJLJ case and generalize the + condition to make it not ZCX specific. + + If there are any exceptions or cleanup processing involved, we need an + outer statement group (for Setjmp_Longjmp) and binding level. */ + if (binding_for_block) + { + start_stmt_group (); + gnat_pushlevel (); + } + + /* If using setjmp_longjmp, make the variables for the setjmp buffer and save + area for address of previous buffer. Do this first since we need to have + the setjmp buf known for any decls in this block. */ + if (setjmp_longjmp) + { + gnu_jmpsave_decl = create_var_decl (get_identifier ("JMPBUF_SAVE"), + NULL_TREE, jmpbuf_ptr_type, + build_call_0_expr (get_jmpbuf_decl), + false, false, false, false, + NULL, gnat_node); + DECL_ARTIFICIAL (gnu_jmpsave_decl) = 1; + + /* The __builtin_setjmp receivers will immediately reinstall it. Now + because of the unstructured form of EH used by setjmp_longjmp, there + might be forward edges going to __builtin_setjmp receivers on which + it is uninitialized, although they will never be actually taken. */ + TREE_NO_WARNING (gnu_jmpsave_decl) = 1; + gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"), + NULL_TREE, jmpbuf_type, NULL_TREE, + false, false, false, false, + NULL, gnat_node); + DECL_ARTIFICIAL (gnu_jmpbuf_decl) = 1; + + set_block_jmpbuf_decl (gnu_jmpbuf_decl); + + /* When we exit this block, restore the saved value. */ + add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl), + End_Label (gnat_node)); + } + + /* If we are to call a function when exiting this block, add a cleanup + to the binding level we made above. Note that add_cleanup is FIFO + so we must register this cleanup after the EH cleanup just above. */ + if (at_end) + add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))), + End_Label (gnat_node)); + + /* Now build the tree for the declarations and statements inside this block. + If this is SJLJ, set our jmp_buf as the current buffer. */ + start_stmt_group (); + + if (setjmp_longjmp) + add_stmt (build_call_1_expr (set_jmpbuf_decl, + build_unary_op (ADDR_EXPR, NULL_TREE, + gnu_jmpbuf_decl))); + + if (Present (First_Real_Statement (gnat_node))) + process_decls (Statements (gnat_node), Empty, + First_Real_Statement (gnat_node), true, true); + + /* Generate code for each statement in the block. */ + for (gnat_temp = (Present (First_Real_Statement (gnat_node)) + ? First_Real_Statement (gnat_node) + : First (Statements (gnat_node))); + Present (gnat_temp); gnat_temp = Next (gnat_temp)) + add_stmt (gnat_to_gnu (gnat_temp)); + gnu_inner_block = end_stmt_group (); + + /* Now generate code for the two exception models, if either is relevant for + this block. */ + if (setjmp_longjmp) + { + tree *gnu_else_ptr = 0; + tree gnu_handler; + + /* Make a binding level for the exception handling declarations and code + and set up gnu_except_ptr_stack for the handlers to use. */ + start_stmt_group (); + gnat_pushlevel (); + + VEC_safe_push (tree, gc, gnu_except_ptr_stack, + create_var_decl (get_identifier ("EXCEPT_PTR"), NULL_TREE, + build_pointer_type (except_type_node), + build_call_0_expr (get_excptr_decl), + false, false, false, false, + NULL, gnat_node)); + + /* Generate code for each handler. The N_Exception_Handler case does the + real work and returns a COND_EXPR for each handler, which we chain + together here. */ + for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node)); + Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp)) + { + gnu_expr = gnat_to_gnu (gnat_temp); + + /* If this is the first one, set it as the outer one. Otherwise, + point the "else" part of the previous handler to us. Then point + to our "else" part. */ + if (!gnu_else_ptr) + add_stmt (gnu_expr); + else + *gnu_else_ptr = gnu_expr; + + gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr); + } + + /* If none of the exception handlers did anything, re-raise but do not + defer abortion. */ + gnu_expr = build_call_1_expr (raise_nodefer_decl, + VEC_last (tree, gnu_except_ptr_stack)); + set_expr_location_from_node + (gnu_expr, + Present (End_Label (gnat_node)) ? End_Label (gnat_node) : gnat_node); + + if (gnu_else_ptr) + *gnu_else_ptr = gnu_expr; + else + add_stmt (gnu_expr); + + /* End the binding level dedicated to the exception handlers and get the + whole statement group. */ + VEC_pop (tree, gnu_except_ptr_stack); + gnat_poplevel (); + gnu_handler = end_stmt_group (); + + /* If the setjmp returns 1, we restore our incoming longjmp value and + then check the handlers. */ + start_stmt_group (); + add_stmt_with_node (build_call_1_expr (set_jmpbuf_decl, + gnu_jmpsave_decl), + gnat_node); + add_stmt (gnu_handler); + gnu_handler = end_stmt_group (); + + /* This block is now "if (setjmp) ... else ". */ + gnu_result = build3 (COND_EXPR, void_type_node, + (build_call_1_expr + (setjmp_decl, + build_unary_op (ADDR_EXPR, NULL_TREE, + gnu_jmpbuf_decl))), + gnu_handler, gnu_inner_block); + } + else if (gcc_zcx) + { + tree gnu_handlers; + + /* First make a block containing the handlers. */ + start_stmt_group (); + for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node)); + Present (gnat_temp); + gnat_temp = Next_Non_Pragma (gnat_temp)) + add_stmt (gnat_to_gnu (gnat_temp)); + gnu_handlers = end_stmt_group (); + + /* Now make the TRY_CATCH_EXPR for the block. */ + gnu_result = build2 (TRY_CATCH_EXPR, void_type_node, + gnu_inner_block, gnu_handlers); + } + else + gnu_result = gnu_inner_block; + + /* Now close our outer block, if we had to make one. */ + if (binding_for_block) + { + add_stmt (gnu_result); + gnat_poplevel (); + gnu_result = end_stmt_group (); + } + + return gnu_result; +} + +/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler, + to a GCC tree, which is returned. This is the variant for Setjmp_Longjmp + exception handling. */ + +static tree +Exception_Handler_to_gnu_sjlj (Node_Id gnat_node) +{ + /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make + an "if" statement to select the proper exceptions. For "Others", exclude + exceptions where Handled_By_Others is nonzero unless the All_Others flag + is set. For "Non-ada", accept an exception if "Lang" is 'V'. */ + tree gnu_choice = integer_zero_node; + tree gnu_body = build_stmt_group (Statements (gnat_node), false); + Node_Id gnat_temp; + + for (gnat_temp = First (Exception_Choices (gnat_node)); + gnat_temp; gnat_temp = Next (gnat_temp)) + { + tree this_choice; + + if (Nkind (gnat_temp) == N_Others_Choice) + { + if (All_Others (gnat_temp)) + this_choice = integer_one_node; + else + this_choice + = build_binary_op + (EQ_EXPR, boolean_type_node, + convert + (integer_type_node, + build_component_ref + (build_unary_op + (INDIRECT_REF, NULL_TREE, + VEC_last (tree, gnu_except_ptr_stack)), + get_identifier ("not_handled_by_others"), NULL_TREE, + false)), + integer_zero_node); + } + + else if (Nkind (gnat_temp) == N_Identifier + || Nkind (gnat_temp) == N_Expanded_Name) + { + Entity_Id gnat_ex_id = Entity (gnat_temp); + tree gnu_expr; + + /* Exception may be a renaming. Recover original exception which is + the one elaborated and registered. */ + if (Present (Renamed_Object (gnat_ex_id))) + gnat_ex_id = Renamed_Object (gnat_ex_id); + + gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0); + + this_choice + = build_binary_op + (EQ_EXPR, boolean_type_node, + VEC_last (tree, gnu_except_ptr_stack), + convert (TREE_TYPE (VEC_last (tree, gnu_except_ptr_stack)), + build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr))); + + /* If this is the distinguished exception "Non_Ada_Error" (and we are + in VMS mode), also allow a non-Ada exception (a VMS condition) t + match. */ + if (Is_Non_Ada_Error (Entity (gnat_temp))) + { + tree gnu_comp + = build_component_ref + (build_unary_op (INDIRECT_REF, NULL_TREE, + VEC_last (tree, gnu_except_ptr_stack)), + get_identifier ("lang"), NULL_TREE, false); + + this_choice + = build_binary_op + (TRUTH_ORIF_EXPR, boolean_type_node, + build_binary_op (EQ_EXPR, boolean_type_node, gnu_comp, + build_int_cst (TREE_TYPE (gnu_comp), 'V')), + this_choice); + } + } + else + gcc_unreachable (); + + gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, + gnu_choice, this_choice); + } + + return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE); +} + +/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler, + to a GCC tree, which is returned. This is the variant for ZCX. */ + +static tree +Exception_Handler_to_gnu_zcx (Node_Id gnat_node) +{ + tree gnu_etypes_list = NULL_TREE; + tree gnu_expr; + tree gnu_etype; + tree gnu_current_exc_ptr; + tree gnu_incoming_exc_ptr; + Node_Id gnat_temp; + + /* We build a TREE_LIST of nodes representing what exception types this + handler can catch, with special cases for others and all others cases. + + Each exception type is actually identified by a pointer to the exception + id, or to a dummy object for "others" and "all others". */ + for (gnat_temp = First (Exception_Choices (gnat_node)); + gnat_temp; gnat_temp = Next (gnat_temp)) + { + if (Nkind (gnat_temp) == N_Others_Choice) + { + tree gnu_expr + = All_Others (gnat_temp) ? all_others_decl : others_decl; + + gnu_etype + = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr); + } + else if (Nkind (gnat_temp) == N_Identifier + || Nkind (gnat_temp) == N_Expanded_Name) + { + Entity_Id gnat_ex_id = Entity (gnat_temp); + + /* Exception may be a renaming. Recover original exception which is + the one elaborated and registered. */ + if (Present (Renamed_Object (gnat_ex_id))) + gnat_ex_id = Renamed_Object (gnat_ex_id); + + gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0); + gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr); + + /* The Non_Ada_Error case for VMS exceptions is handled + by the personality routine. */ + } + else + gcc_unreachable (); + + /* The GCC interface expects NULL to be passed for catch all handlers, so + it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype + is integer_zero_node. It would not work, however, because GCC's + notion of "catch all" is stronger than our notion of "others". Until + we correctly use the cleanup interface as well, doing that would + prevent the "all others" handlers from being seen, because nothing + can be caught beyond a catch all from GCC's point of view. */ + gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list); + } + + start_stmt_group (); + gnat_pushlevel (); + + /* Expand a call to the begin_handler hook at the beginning of the handler, + and arrange for a call to the end_handler hook to occur on every possible + exit path. + + The hooks expect a pointer to the low level occurrence. This is required + for our stack management scheme because a raise inside the handler pushes + a new occurrence on top of the stack, which means that this top does not + necessarily match the occurrence this handler was dealing with. + + __builtin_eh_pointer references the exception occurrence being + propagated. Upon handler entry, this is the exception for which the + handler is triggered. This might not be the case upon handler exit, + however, as we might have a new occurrence propagated by the handler's + body, and the end_handler hook called as a cleanup in this context. + + We use a local variable to retrieve the incoming value at handler entry + time, and reuse it to feed the end_handler hook's argument at exit. */ + + gnu_current_exc_ptr + = build_call_expr (built_in_decls [BUILT_IN_EH_POINTER], + 1, integer_zero_node); + gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE, + ptr_type_node, gnu_current_exc_ptr, + false, false, false, false, + NULL, gnat_node); + + add_stmt_with_node (build_call_1_expr (begin_handler_decl, + gnu_incoming_exc_ptr), + gnat_node); + /* ??? We don't seem to have an End_Label at hand to set the location. */ + add_cleanup (build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr), + Empty); + add_stmt_list (Statements (gnat_node)); + gnat_poplevel (); + + return build2 (CATCH_EXPR, void_type_node, gnu_etypes_list, + end_stmt_group ()); +} + +/* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */ + +static void +Compilation_Unit_to_gnu (Node_Id gnat_node) +{ + const Node_Id gnat_unit = Unit (gnat_node); + const bool body_p = (Nkind (gnat_unit) == N_Package_Body + || Nkind (gnat_unit) == N_Subprogram_Body); + const Entity_Id gnat_unit_entity = Defining_Entity (gnat_unit); + /* Make the decl for the elaboration procedure. */ + tree gnu_elab_proc_decl + = create_subprog_decl + (create_concat_name (gnat_unit_entity, body_p ? "elabb" : "elabs"), + NULL_TREE, void_ftype, NULL_TREE, false, true, false, NULL, gnat_unit); + struct elab_info *info; + + VEC_safe_push (tree, gc, gnu_elab_proc_stack, gnu_elab_proc_decl); + DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1; + + /* Initialize the information structure for the function. */ + allocate_struct_function (gnu_elab_proc_decl, false); + set_cfun (NULL); + + current_function_decl = NULL_TREE; + + start_stmt_group (); + gnat_pushlevel (); + + /* For a body, first process the spec if there is one. */ + if (Nkind (Unit (gnat_node)) == N_Package_Body + || (Nkind (Unit (gnat_node)) == N_Subprogram_Body + && !Acts_As_Spec (gnat_node))) + { + add_stmt (gnat_to_gnu (Library_Unit (gnat_node))); + finalize_from_with_types (); + } + + /* If we can inline, generate code for all the inlined subprograms. */ + if (optimize) + { + Entity_Id gnat_entity; + + for (gnat_entity = First_Inlined_Subprogram (gnat_node); + Present (gnat_entity); + gnat_entity = Next_Inlined_Subprogram (gnat_entity)) + { + Node_Id gnat_body = Parent (Declaration_Node (gnat_entity)); + + if (Nkind (gnat_body) != N_Subprogram_Body) + { + /* ??? This really should always be present. */ + if (No (Corresponding_Body (gnat_body))) + continue; + gnat_body + = Parent (Declaration_Node (Corresponding_Body (gnat_body))); + } + + if (Present (gnat_body)) + { + /* Define the entity first so we set DECL_EXTERNAL. */ + gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0); + add_stmt (gnat_to_gnu (gnat_body)); + } + } + } + + if (type_annotate_only && gnat_node == Cunit (Main_Unit)) + { + elaborate_all_entities (gnat_node); + + if (Nkind (Unit (gnat_node)) == N_Subprogram_Declaration + || Nkind (Unit (gnat_node)) == N_Generic_Package_Declaration + || Nkind (Unit (gnat_node)) == N_Generic_Subprogram_Declaration) + return; + } + + process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty, + true, true); + add_stmt (gnat_to_gnu (Unit (gnat_node))); + + /* Process any pragmas and actions following the unit. */ + add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node))); + add_stmt_list (Actions (Aux_Decls_Node (gnat_node))); + finalize_from_with_types (); + + /* Save away what we've made so far and record this potential elaboration + procedure. */ + info = ggc_alloc_elab_info (); + set_current_block_context (gnu_elab_proc_decl); + gnat_poplevel (); + DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group (); + + set_end_locus_from_node (gnu_elab_proc_decl, gnat_unit); + + info->next = elab_info_list; + info->elab_proc = gnu_elab_proc_decl; + info->gnat_node = gnat_node; + elab_info_list = info; + + /* Generate elaboration code for this unit, if necessary, and say whether + we did or not. */ + VEC_pop (tree, gnu_elab_proc_stack); + + /* Invalidate the global renaming pointers. This is necessary because + stabilization of the renamed entities may create SAVE_EXPRs which + have been tied to a specific elaboration routine just above. */ + invalidate_global_renaming_pointers (); +} + +/* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far + as gigi is concerned. This is used to avoid conversions on the LHS. */ + +static bool +unchecked_conversion_nop (Node_Id gnat_node) +{ + Entity_Id from_type, to_type; + + /* The conversion must be on the LHS of an assignment or an actual parameter + of a call. Otherwise, even if the conversion was essentially a no-op, it + could de facto ensure type consistency and this should be preserved. */ + if (!(Nkind (Parent (gnat_node)) == N_Assignment_Statement + && Name (Parent (gnat_node)) == gnat_node) + && !((Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement + || Nkind (Parent (gnat_node)) == N_Function_Call) + && Name (Parent (gnat_node)) != gnat_node)) + return false; + + from_type = Etype (Expression (gnat_node)); + + /* We're interested in artificial conversions generated by the front-end + to make private types explicit, e.g. in Expand_Assign_Array. */ + if (!Is_Private_Type (from_type)) + return false; + + from_type = Underlying_Type (from_type); + to_type = Etype (gnat_node); + + /* The direct conversion to the underlying type is a no-op. */ + if (to_type == from_type) + return true; + + /* For an array subtype, the conversion to the PAT is a no-op. */ + if (Ekind (from_type) == E_Array_Subtype + && to_type == Packed_Array_Type (from_type)) + return true; + + /* For a record subtype, the conversion to the type is a no-op. */ + if (Ekind (from_type) == E_Record_Subtype + && to_type == Etype (from_type)) + return true; + + return false; +} + +/* This function is the driver of the GNAT to GCC tree transformation process. + It is the entry point of the tree transformer. GNAT_NODE is the root of + some GNAT tree. Return the root of the corresponding GCC tree. If this + is an expression, return the GCC equivalent of the expression. If this + is a statement, return the statement or add it to the current statement + group, in which case anything returned is to be interpreted as occurring + after anything added. */ + +tree +gnat_to_gnu (Node_Id gnat_node) +{ + const Node_Kind kind = Nkind (gnat_node); + bool went_into_elab_proc = false; + tree gnu_result = error_mark_node; /* Default to no value. */ + tree gnu_result_type = void_type_node; + tree gnu_expr, gnu_lhs, gnu_rhs; + Node_Id gnat_temp; + + /* Save node number for error message and set location information. */ + error_gnat_node = gnat_node; + Sloc_to_locus (Sloc (gnat_node), &input_location); + + /* If this node is a statement and we are only annotating types, return an + empty statement list. */ + if (type_annotate_only && IN (kind, N_Statement_Other_Than_Procedure_Call)) + return alloc_stmt_list (); + + /* If this node is a non-static subexpression and we are only annotating + types, make this into a NULL_EXPR. */ + if (type_annotate_only + && IN (kind, N_Subexpr) + && kind != N_Identifier + && !Compile_Time_Known_Value (gnat_node)) + return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)), + build_call_raise (CE_Range_Check_Failed, gnat_node, + N_Raise_Constraint_Error)); + + if ((IN (kind, N_Statement_Other_Than_Procedure_Call) + && kind != N_Null_Statement) + || kind == N_Procedure_Call_Statement + || kind == N_Label + || kind == N_Implicit_Label_Declaration + || kind == N_Handled_Sequence_Of_Statements + || (IN (kind, N_Raise_xxx_Error) && Ekind (Etype (gnat_node)) == E_Void)) + { + tree current_elab_proc = get_elaboration_procedure (); + + /* If this is a statement and we are at top level, it must be part of + the elaboration procedure, so mark us as being in that procedure. */ + if (!current_function_decl) + { + current_function_decl = current_elab_proc; + went_into_elab_proc = true; + } + + /* If we are in the elaboration procedure, check if we are violating a + No_Elaboration_Code restriction by having a statement there. Don't + check for a possible No_Elaboration_Code restriction violation on + N_Handled_Sequence_Of_Statements, as we want to signal an error on + every nested real statement instead. This also avoids triggering + spurious errors on dummy (empty) sequences created by the front-end + for package bodies in some cases. */ + if (current_function_decl == current_elab_proc + && kind != N_Handled_Sequence_Of_Statements) + Check_Elaboration_Code_Allowed (gnat_node); + } + + switch (kind) + { + /********************************/ + /* Chapter 2: Lexical Elements */ + /********************************/ + + case N_Identifier: + case N_Expanded_Name: + case N_Operator_Symbol: + case N_Defining_Identifier: + gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type); + break; + + case N_Integer_Literal: + { + tree gnu_type; + + /* Get the type of the result, looking inside any padding and + justified modular types. Then get the value in that type. */ + gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (gnu_type)) + gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type)); + + gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type); + + /* If the result overflows (meaning it doesn't fit in its base type), + abort. We would like to check that the value is within the range + of the subtype, but that causes problems with subtypes whose usage + will raise Constraint_Error and with biased representation, so + we don't. */ + gcc_assert (!TREE_OVERFLOW (gnu_result)); + } + break; + + case N_Character_Literal: + /* If a Entity is present, it means that this was one of the + literals in a user-defined character type. In that case, + just return the value in the CONST_DECL. Otherwise, use the + character code. In that case, the base type should be an + INTEGER_TYPE, but we won't bother checking for that. */ + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + if (Present (Entity (gnat_node))) + gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node))); + else + gnu_result + = build_int_cst_type + (gnu_result_type, UI_To_CC (Char_Literal_Value (gnat_node))); + break; + + case N_Real_Literal: + /* If this is of a fixed-point type, the value we want is the + value of the corresponding integer. */ + if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind)) + { + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node), + gnu_result_type); + gcc_assert (!TREE_OVERFLOW (gnu_result)); + } + + /* We should never see a Vax_Float type literal, since the front end + is supposed to transform these using appropriate conversions. */ + else if (Vax_Float (Underlying_Type (Etype (gnat_node)))) + gcc_unreachable (); + + else + { + Ureal ur_realval = Realval (gnat_node); + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + /* If the real value is zero, so is the result. Otherwise, + convert it to a machine number if it isn't already. That + forces BASE to 0 or 2 and simplifies the rest of our logic. */ + if (UR_Is_Zero (ur_realval)) + gnu_result = convert (gnu_result_type, integer_zero_node); + else + { + if (!Is_Machine_Number (gnat_node)) + ur_realval + = Machine (Base_Type (Underlying_Type (Etype (gnat_node))), + ur_realval, Round_Even, gnat_node); + + gnu_result + = UI_To_gnu (Numerator (ur_realval), gnu_result_type); + + /* If we have a base of zero, divide by the denominator. + Otherwise, the base must be 2 and we scale the value, which + we know can fit in the mantissa of the type (hence the use + of that type above). */ + if (No (Rbase (ur_realval))) + gnu_result + = build_binary_op (RDIV_EXPR, + get_base_type (gnu_result_type), + gnu_result, + UI_To_gnu (Denominator (ur_realval), + gnu_result_type)); + else + { + REAL_VALUE_TYPE tmp; + + gcc_assert (Rbase (ur_realval) == 2); + real_ldexp (&tmp, &TREE_REAL_CST (gnu_result), + - UI_To_Int (Denominator (ur_realval))); + gnu_result = build_real (gnu_result_type, tmp); + } + } + + /* Now see if we need to negate the result. Do it this way to + properly handle -0. */ + if (UR_Is_Negative (Realval (gnat_node))) + gnu_result + = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type), + gnu_result); + } + + break; + + case N_String_Literal: + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR) + { + String_Id gnat_string = Strval (gnat_node); + int length = String_Length (gnat_string); + int i; + char *string; + if (length >= ALLOCA_THRESHOLD) + string = XNEWVEC (char, length + 1); + else + string = (char *) alloca (length + 1); + + /* Build the string with the characters in the literal. Note + that Ada strings are 1-origin. */ + for (i = 0; i < length; i++) + string[i] = Get_String_Char (gnat_string, i + 1); + + /* Put a null at the end of the string in case it's in a context + where GCC will want to treat it as a C string. */ + string[i] = 0; + + gnu_result = build_string (length, string); + + /* Strings in GCC don't normally have types, but we want + this to not be converted to the array type. */ + TREE_TYPE (gnu_result) = gnu_result_type; + + if (length >= ALLOCA_THRESHOLD) + free (string); + } + else + { + /* Build a list consisting of each character, then make + the aggregate. */ + String_Id gnat_string = Strval (gnat_node); + int length = String_Length (gnat_string); + int i; + tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type)); + VEC(constructor_elt,gc) *gnu_vec + = VEC_alloc (constructor_elt, gc, length); + + for (i = 0; i < length; i++) + { + tree t = build_int_cst (TREE_TYPE (gnu_result_type), + Get_String_Char (gnat_string, i + 1)); + + CONSTRUCTOR_APPEND_ELT (gnu_vec, gnu_idx, t); + gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, integer_one_node, + 0); + } + + gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec); + } + break; + + case N_Pragma: + gnu_result = Pragma_to_gnu (gnat_node); + break; + + /**************************************/ + /* Chapter 3: Declarations and Types */ + /**************************************/ + + case N_Subtype_Declaration: + case N_Full_Type_Declaration: + case N_Incomplete_Type_Declaration: + case N_Private_Type_Declaration: + case N_Private_Extension_Declaration: + case N_Task_Type_Declaration: + process_type (Defining_Entity (gnat_node)); + gnu_result = alloc_stmt_list (); + break; + + case N_Object_Declaration: + case N_Exception_Declaration: + gnat_temp = Defining_Entity (gnat_node); + gnu_result = alloc_stmt_list (); + + /* If we are just annotating types and this object has an unconstrained + or task type, don't elaborate it. */ + if (type_annotate_only + && (((Is_Array_Type (Etype (gnat_temp)) + || Is_Record_Type (Etype (gnat_temp))) + && !Is_Constrained (Etype (gnat_temp))) + || Is_Concurrent_Type (Etype (gnat_temp)))) + break; + + if (Present (Expression (gnat_node)) + && !(kind == N_Object_Declaration && No_Initialization (gnat_node)) + && (!type_annotate_only + || Compile_Time_Known_Value (Expression (gnat_node)))) + { + gnu_expr = gnat_to_gnu (Expression (gnat_node)); + if (Do_Range_Check (Expression (gnat_node))) + gnu_expr + = emit_range_check (gnu_expr, Etype (gnat_temp), gnat_node); + + /* If this object has its elaboration delayed, we must force + evaluation of GNU_EXPR right now and save it for when the object + is frozen. */ + if (Present (Freeze_Node (gnat_temp))) + { + if (TREE_CONSTANT (gnu_expr)) + ; + else if (global_bindings_p ()) + gnu_expr + = create_var_decl (create_concat_name (gnat_temp, "init"), + NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, + false, false, false, false, + NULL, gnat_temp); + else + gnu_expr = gnat_save_expr (gnu_expr); + + save_gnu_tree (gnat_node, gnu_expr, true); + } + } + else + gnu_expr = NULL_TREE; + + if (type_annotate_only && gnu_expr && TREE_CODE (gnu_expr) == ERROR_MARK) + gnu_expr = NULL_TREE; + + /* If this is a deferred constant with an address clause, we ignore the + full view since the clause is on the partial view and we cannot have + 2 different GCC trees for the object. The only bits of the full view + we will use is the initializer, but it will be directly fetched. */ + if (Ekind(gnat_temp) == E_Constant + && Present (Address_Clause (gnat_temp)) + && Present (Full_View (gnat_temp))) + save_gnu_tree (Full_View (gnat_temp), error_mark_node, true); + + if (No (Freeze_Node (gnat_temp))) + gnat_to_gnu_entity (gnat_temp, gnu_expr, 1); + break; + + case N_Object_Renaming_Declaration: + gnat_temp = Defining_Entity (gnat_node); + + /* Don't do anything if this renaming is handled by the front end or if + we are just annotating types and this object has a composite or task + type, don't elaborate it. We return the result in case it has any + SAVE_EXPRs in it that need to be evaluated here. */ + if (!Is_Renaming_Of_Object (gnat_temp) + && ! (type_annotate_only + && (Is_Array_Type (Etype (gnat_temp)) + || Is_Record_Type (Etype (gnat_temp)) + || Is_Concurrent_Type (Etype (gnat_temp))))) + gnu_result + = gnat_to_gnu_entity (gnat_temp, + gnat_to_gnu (Renamed_Object (gnat_temp)), 1); + else + gnu_result = alloc_stmt_list (); + break; + + case N_Implicit_Label_Declaration: + gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1); + gnu_result = alloc_stmt_list (); + break; + + case N_Exception_Renaming_Declaration: + case N_Number_Declaration: + case N_Package_Renaming_Declaration: + case N_Subprogram_Renaming_Declaration: + /* These are fully handled in the front end. */ + gnu_result = alloc_stmt_list (); + break; + + /*************************************/ + /* Chapter 4: Names and Expressions */ + /*************************************/ + + case N_Explicit_Dereference: + gnu_result = gnat_to_gnu (Prefix (gnat_node)); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); + break; + + case N_Indexed_Component: + { + tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node)); + tree gnu_type; + int ndim; + int i; + Node_Id *gnat_expr_array; + + gnu_array_object = maybe_implicit_deref (gnu_array_object); + + /* Convert vector inputs to their representative array type, to fit + what the code below expects. */ + gnu_array_object = maybe_vector_array (gnu_array_object); + + gnu_array_object = maybe_unconstrained_array (gnu_array_object); + + /* If we got a padded type, remove it too. */ + if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object))) + gnu_array_object + = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))), + gnu_array_object); + + gnu_result = gnu_array_object; + + /* First compute the number of dimensions of the array, then + fill the expression array, the order depending on whether + this is a Convention_Fortran array or not. */ + for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object); + TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)); + ndim++, gnu_type = TREE_TYPE (gnu_type)) + ; + + gnat_expr_array = XALLOCAVEC (Node_Id, ndim); + + if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object))) + for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node)); + i >= 0; + i--, gnat_temp = Next (gnat_temp)) + gnat_expr_array[i] = gnat_temp; + else + for (i = 0, gnat_temp = First (Expressions (gnat_node)); + i < ndim; + i++, gnat_temp = Next (gnat_temp)) + gnat_expr_array[i] = gnat_temp; + + for (i = 0, gnu_type = TREE_TYPE (gnu_array_object); + i < ndim; i++, gnu_type = TREE_TYPE (gnu_type)) + { + gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE); + gnat_temp = gnat_expr_array[i]; + gnu_expr = gnat_to_gnu (gnat_temp); + + if (Do_Range_Check (gnat_temp)) + gnu_expr + = emit_index_check + (gnu_array_object, gnu_expr, + TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))), + TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))), + gnat_temp); + + gnu_result = build_binary_op (ARRAY_REF, NULL_TREE, + gnu_result, gnu_expr); + } + } + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + break; + + case N_Slice: + { + Node_Id gnat_range_node = Discrete_Range (gnat_node); + tree gnu_type; + + gnu_result = gnat_to_gnu (Prefix (gnat_node)); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + /* Do any implicit dereferences of the prefix and do any needed + range check. */ + gnu_result = maybe_implicit_deref (gnu_result); + gnu_result = maybe_unconstrained_array (gnu_result); + gnu_type = TREE_TYPE (gnu_result); + if (Do_Range_Check (gnat_range_node)) + { + /* Get the bounds of the slice. */ + tree gnu_index_type + = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type)); + tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type); + tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type); + /* Get the permitted bounds. */ + tree gnu_base_index_type + = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)); + tree gnu_base_min_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR + (TYPE_MIN_VALUE (gnu_base_index_type), gnu_result); + tree gnu_base_max_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR + (TYPE_MAX_VALUE (gnu_base_index_type), gnu_result); + tree gnu_expr_l, gnu_expr_h, gnu_expr_type; + + gnu_min_expr = gnat_protect_expr (gnu_min_expr); + gnu_max_expr = gnat_protect_expr (gnu_max_expr); + + /* Derive a good type to convert everything to. */ + gnu_expr_type = get_base_type (gnu_index_type); + + /* Test whether the minimum slice value is too small. */ + gnu_expr_l = build_binary_op (LT_EXPR, boolean_type_node, + convert (gnu_expr_type, + gnu_min_expr), + convert (gnu_expr_type, + gnu_base_min_expr)); + + /* Test whether the maximum slice value is too large. */ + gnu_expr_h = build_binary_op (GT_EXPR, boolean_type_node, + convert (gnu_expr_type, + gnu_max_expr), + convert (gnu_expr_type, + gnu_base_max_expr)); + + /* Build a slice index check that returns the low bound, + assuming the slice is not empty. */ + gnu_expr = emit_check + (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, + gnu_expr_l, gnu_expr_h), + gnu_min_expr, CE_Index_Check_Failed, gnat_node); + + /* Build a conditional expression that does the index checks and + returns the low bound if the slice is not empty (max >= min), + and returns the naked low bound otherwise (max < min), unless + it is non-constant and the high bound is; this prevents VRP + from inferring bogus ranges on the unlikely path. */ + gnu_expr = fold_build3 (COND_EXPR, gnu_expr_type, + build_binary_op (GE_EXPR, gnu_expr_type, + convert (gnu_expr_type, + gnu_max_expr), + convert (gnu_expr_type, + gnu_min_expr)), + gnu_expr, + TREE_CODE (gnu_min_expr) != INTEGER_CST + && TREE_CODE (gnu_max_expr) == INTEGER_CST + ? gnu_max_expr : gnu_min_expr); + } + else + /* Simply return the naked low bound. */ + gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type)); + + /* If this is a slice with non-constant size of an array with constant + size, set the maximum size for the allocation of temporaries. */ + if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type)) + && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_type))) + TYPE_ARRAY_MAX_SIZE (gnu_result_type) = TYPE_SIZE_UNIT (gnu_type); + + gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type, + gnu_result, gnu_expr); + } + break; + + case N_Selected_Component: + { + tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node)); + Entity_Id gnat_field = Entity (Selector_Name (gnat_node)); + Entity_Id gnat_pref_type = Etype (Prefix (gnat_node)); + tree gnu_field; + + while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind) + || IN (Ekind (gnat_pref_type), Access_Kind)) + { + if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)) + gnat_pref_type = Underlying_Type (gnat_pref_type); + else if (IN (Ekind (gnat_pref_type), Access_Kind)) + gnat_pref_type = Designated_Type (gnat_pref_type); + } + + gnu_prefix = maybe_implicit_deref (gnu_prefix); + + /* For discriminant references in tagged types always substitute the + corresponding discriminant as the actual selected component. */ + if (Is_Tagged_Type (gnat_pref_type)) + while (Present (Corresponding_Discriminant (gnat_field))) + gnat_field = Corresponding_Discriminant (gnat_field); + + /* For discriminant references of untagged types always substitute the + corresponding stored discriminant. */ + else if (Present (Corresponding_Discriminant (gnat_field))) + gnat_field = Original_Record_Component (gnat_field); + + /* Handle extracting the real or imaginary part of a complex. + The real part is the first field and the imaginary the last. */ + if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE) + gnu_result = build_unary_op (Present (Next_Entity (gnat_field)) + ? REALPART_EXPR : IMAGPART_EXPR, + NULL_TREE, gnu_prefix); + else + { + gnu_field = gnat_to_gnu_field_decl (gnat_field); + + /* If there are discriminants, the prefix might be evaluated more + than once, which is a problem if it has side-effects. */ + if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node))) + ? Designated_Type (Etype + (Prefix (gnat_node))) + : Etype (Prefix (gnat_node)))) + gnu_prefix = gnat_stabilize_reference (gnu_prefix, false, NULL); + + gnu_result + = build_component_ref (gnu_prefix, NULL_TREE, gnu_field, + (Nkind (Parent (gnat_node)) + == N_Attribute_Reference) + && lvalue_required_for_attribute_p + (Parent (gnat_node))); + } + + gcc_assert (gnu_result); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + } + break; + + case N_Attribute_Reference: + { + /* The attribute designator. */ + const int attr = Get_Attribute_Id (Attribute_Name (gnat_node)); + + /* The Elab_Spec and Elab_Body attributes are special in that Prefix + is a unit, not an object with a GCC equivalent. */ + if (attr == Attr_Elab_Spec || attr == Attr_Elab_Body) + return + create_subprog_decl (create_concat_name + (Entity (Prefix (gnat_node)), + attr == Attr_Elab_Body ? "elabb" : "elabs"), + NULL_TREE, void_ftype, NULL_TREE, false, + true, true, NULL, gnat_node); + + gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attr); + } + break; + + case N_Reference: + /* Like 'Access as far as we are concerned. */ + gnu_result = gnat_to_gnu (Prefix (gnat_node)); + gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + break; + + case N_Aggregate: + case N_Extension_Aggregate: + { + tree gnu_aggr_type; + + /* ??? It is wrong to evaluate the type now, but there doesn't + seem to be any other practical way of doing it. */ + + gcc_assert (!Expansion_Delayed (gnat_node)); + + gnu_aggr_type = gnu_result_type + = get_unpadded_type (Etype (gnat_node)); + + if (TREE_CODE (gnu_result_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type)) + gnu_aggr_type + = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type))); + else if (TREE_CODE (gnu_result_type) == VECTOR_TYPE) + gnu_aggr_type = TYPE_REPRESENTATIVE_ARRAY (gnu_result_type); + + if (Null_Record_Present (gnat_node)) + gnu_result = gnat_build_constructor (gnu_aggr_type, NULL); + + else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE + || TREE_CODE (gnu_aggr_type) == UNION_TYPE) + gnu_result + = assoc_to_constructor (Etype (gnat_node), + First (Component_Associations (gnat_node)), + gnu_aggr_type); + else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE) + gnu_result = pos_to_constructor (First (Expressions (gnat_node)), + gnu_aggr_type, + Component_Type (Etype (gnat_node))); + else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE) + gnu_result + = build_binary_op + (COMPLEX_EXPR, gnu_aggr_type, + gnat_to_gnu (Expression (First + (Component_Associations (gnat_node)))), + gnat_to_gnu (Expression + (Next + (First (Component_Associations (gnat_node)))))); + else + gcc_unreachable (); + + gnu_result = convert (gnu_result_type, gnu_result); + } + break; + + case N_Null: + if (TARGET_VTABLE_USES_DESCRIPTORS + && Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type + && Is_Dispatch_Table_Entity (Etype (gnat_node))) + gnu_result = null_fdesc_node; + else + gnu_result = null_pointer_node; + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + break; + + case N_Type_Conversion: + case N_Qualified_Expression: + /* Get the operand expression. */ + gnu_result = gnat_to_gnu (Expression (gnat_node)); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + gnu_result + = convert_with_check (Etype (gnat_node), gnu_result, + Do_Overflow_Check (gnat_node), + Do_Range_Check (Expression (gnat_node)), + kind == N_Type_Conversion + && Float_Truncate (gnat_node), gnat_node); + break; + + case N_Unchecked_Type_Conversion: + gnu_result = gnat_to_gnu (Expression (gnat_node)); + + /* Skip further processing if the conversion is deemed a no-op. */ + if (unchecked_conversion_nop (gnat_node)) + { + gnu_result_type = TREE_TYPE (gnu_result); + break; + } + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + /* If the result is a pointer type, see if we are improperly + converting to a stricter alignment. */ + if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type) + && IN (Ekind (Etype (gnat_node)), Access_Kind)) + { + unsigned int align = known_alignment (gnu_result); + tree gnu_obj_type = TREE_TYPE (gnu_result_type); + unsigned int oalign = TYPE_ALIGN (gnu_obj_type); + + if (align != 0 && align < oalign && !TYPE_ALIGN_OK (gnu_obj_type)) + post_error_ne_tree_2 + ("?source alignment (^) '< alignment of & (^)", + gnat_node, Designated_Type (Etype (gnat_node)), + size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT); + } + + /* If we are converting a descriptor to a function pointer, first + build the pointer. */ + if (TARGET_VTABLE_USES_DESCRIPTORS + && TREE_TYPE (gnu_result) == fdesc_type_node + && POINTER_TYPE_P (gnu_result_type)) + gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result); + + gnu_result = unchecked_convert (gnu_result_type, gnu_result, + No_Truncation (gnat_node)); + break; + + case N_In: + case N_Not_In: + { + tree gnu_obj = gnat_to_gnu (Left_Opnd (gnat_node)); + Node_Id gnat_range = Right_Opnd (gnat_node); + tree gnu_low, gnu_high; + + /* GNAT_RANGE is either an N_Range node or an identifier denoting a + subtype. */ + if (Nkind (gnat_range) == N_Range) + { + gnu_low = gnat_to_gnu (Low_Bound (gnat_range)); + gnu_high = gnat_to_gnu (High_Bound (gnat_range)); + } + else if (Nkind (gnat_range) == N_Identifier + || Nkind (gnat_range) == N_Expanded_Name) + { + tree gnu_range_type = get_unpadded_type (Entity (gnat_range)); + + gnu_low = TYPE_MIN_VALUE (gnu_range_type); + gnu_high = TYPE_MAX_VALUE (gnu_range_type); + } + else + gcc_unreachable (); + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + /* If LOW and HIGH are identical, perform an equality test. Otherwise, + ensure that GNU_OBJ is evaluated only once and perform a full range + test. */ + if (operand_equal_p (gnu_low, gnu_high, 0)) + gnu_result + = build_binary_op (EQ_EXPR, gnu_result_type, gnu_obj, gnu_low); + else + { + tree t1, t2; + gnu_obj = gnat_protect_expr (gnu_obj); + t1 = build_binary_op (GE_EXPR, gnu_result_type, gnu_obj, gnu_low); + if (EXPR_P (t1)) + set_expr_location_from_node (t1, gnat_node); + t2 = build_binary_op (LE_EXPR, gnu_result_type, gnu_obj, gnu_high); + if (EXPR_P (t2)) + set_expr_location_from_node (t2, gnat_node); + gnu_result + = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type, t1, t2); + } + + if (kind == N_Not_In) + gnu_result + = invert_truthvalue_loc (EXPR_LOCATION (gnu_result), gnu_result); + } + break; + + case N_Op_Divide: + gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node)); + gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node)); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type) + ? RDIV_EXPR + : (Rounded_Result (gnat_node) + ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR), + gnu_result_type, gnu_lhs, gnu_rhs); + break; + + case N_Op_Or: case N_Op_And: case N_Op_Xor: + /* These can either be operations on booleans or on modular types. + Fall through for boolean types since that's the way GNU_CODES is + set up. */ + if (IN (Ekind (Underlying_Type (Etype (gnat_node))), + Modular_Integer_Kind)) + { + enum tree_code code + = (kind == N_Op_Or ? BIT_IOR_EXPR + : kind == N_Op_And ? BIT_AND_EXPR + : BIT_XOR_EXPR); + + gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node)); + gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node)); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = build_binary_op (code, gnu_result_type, + gnu_lhs, gnu_rhs); + break; + } + + /* ... fall through ... */ + + case N_Op_Eq: case N_Op_Ne: case N_Op_Lt: + case N_Op_Le: case N_Op_Gt: case N_Op_Ge: + case N_Op_Add: case N_Op_Subtract: case N_Op_Multiply: + case N_Op_Mod: case N_Op_Rem: + case N_Op_Rotate_Left: + case N_Op_Rotate_Right: + case N_Op_Shift_Left: + case N_Op_Shift_Right: + case N_Op_Shift_Right_Arithmetic: + case N_And_Then: case N_Or_Else: + { + enum tree_code code = gnu_codes[kind]; + bool ignore_lhs_overflow = false; + location_t saved_location = input_location; + tree gnu_type; + + gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node)); + gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node)); + gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + /* Pending generic support for efficient vector logical operations in + GCC, convert vectors to their representative array type view and + fallthrough. */ + gnu_lhs = maybe_vector_array (gnu_lhs); + gnu_rhs = maybe_vector_array (gnu_rhs); + + /* If this is a comparison operator, convert any references to + an unconstrained array value into a reference to the + actual array. */ + if (TREE_CODE_CLASS (code) == tcc_comparison) + { + gnu_lhs = maybe_unconstrained_array (gnu_lhs); + gnu_rhs = maybe_unconstrained_array (gnu_rhs); + } + + /* If the result type is a private type, its full view may be a + numeric subtype. The representation we need is that of its base + type, given that it is the result of an arithmetic operation. */ + else if (Is_Private_Type (Etype (gnat_node))) + gnu_type = gnu_result_type + = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node)))); + + /* If this is a shift whose count is not guaranteed to be correct, + we need to adjust the shift count. */ + if (IN (kind, N_Op_Shift) && !Shift_Count_OK (gnat_node)) + { + tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs)); + tree gnu_max_shift + = convert (gnu_count_type, TYPE_SIZE (gnu_type)); + + if (kind == N_Op_Rotate_Left || kind == N_Op_Rotate_Right) + gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type, + gnu_rhs, gnu_max_shift); + else if (kind == N_Op_Shift_Right_Arithmetic) + gnu_rhs + = build_binary_op + (MIN_EXPR, gnu_count_type, + build_binary_op (MINUS_EXPR, + gnu_count_type, + gnu_max_shift, + convert (gnu_count_type, + integer_one_node)), + gnu_rhs); + } + + /* For right shifts, the type says what kind of shift to do, + so we may need to choose a different type. In this case, + we have to ignore integer overflow lest it propagates all + the way down and causes a CE to be explicitly raised. */ + if (kind == N_Op_Shift_Right && !TYPE_UNSIGNED (gnu_type)) + { + gnu_type = gnat_unsigned_type (gnu_type); + ignore_lhs_overflow = true; + } + else if (kind == N_Op_Shift_Right_Arithmetic + && TYPE_UNSIGNED (gnu_type)) + { + gnu_type = gnat_signed_type (gnu_type); + ignore_lhs_overflow = true; + } + + if (gnu_type != gnu_result_type) + { + tree gnu_old_lhs = gnu_lhs; + gnu_lhs = convert (gnu_type, gnu_lhs); + if (TREE_CODE (gnu_lhs) == INTEGER_CST && ignore_lhs_overflow) + TREE_OVERFLOW (gnu_lhs) = TREE_OVERFLOW (gnu_old_lhs); + gnu_rhs = convert (gnu_type, gnu_rhs); + } + + /* Instead of expanding overflow checks for addition, subtraction + and multiplication itself, the front end will leave this to + the back end when Backend_Overflow_Checks_On_Target is set. + As the GCC back end itself does not know yet how to properly + do overflow checking, do it here. The goal is to push + the expansions further into the back end over time. */ + if (Do_Overflow_Check (gnat_node) && Backend_Overflow_Checks_On_Target + && (kind == N_Op_Add + || kind == N_Op_Subtract + || kind == N_Op_Multiply) + && !TYPE_UNSIGNED (gnu_type) + && !FLOAT_TYPE_P (gnu_type)) + gnu_result = build_binary_op_trapv (code, gnu_type, + gnu_lhs, gnu_rhs, gnat_node); + else + { + /* Some operations, e.g. comparisons of arrays, generate complex + trees that need to be annotated while they are being built. */ + input_location = saved_location; + gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs); + } + + /* If this is a logical shift with the shift count not verified, + we must return zero if it is too large. We cannot compensate + above in this case. */ + if ((kind == N_Op_Shift_Left || kind == N_Op_Shift_Right) + && !Shift_Count_OK (gnat_node)) + gnu_result + = build_cond_expr + (gnu_type, + build_binary_op (GE_EXPR, boolean_type_node, + gnu_rhs, + convert (TREE_TYPE (gnu_rhs), + TYPE_SIZE (gnu_type))), + convert (gnu_type, integer_zero_node), + gnu_result); + } + break; + + case N_Conditional_Expression: + { + tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node))); + tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node)))); + tree gnu_false + = gnat_to_gnu (Next (Next (First (Expressions (gnat_node))))); + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result + = build_cond_expr (gnu_result_type, gnu_cond, gnu_true, gnu_false); + } + break; + + case N_Op_Plus: + gnu_result = gnat_to_gnu (Right_Opnd (gnat_node)); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + break; + + case N_Op_Not: + /* This case can apply to a boolean or a modular type. + Fall through for a boolean operand since GNU_CODES is set + up to handle this. */ + if (Is_Modular_Integer_Type (Etype (gnat_node)) + || (Ekind (Etype (gnat_node)) == E_Private_Type + && Is_Modular_Integer_Type (Full_View (Etype (gnat_node))))) + { + gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node)); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type, + gnu_expr); + break; + } + + /* ... fall through ... */ + + case N_Op_Minus: case N_Op_Abs: + gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node)); + + if (Ekind (Etype (gnat_node)) != E_Private_Type) + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + else + gnu_result_type = get_unpadded_type (Base_Type + (Full_View (Etype (gnat_node)))); + + if (Do_Overflow_Check (gnat_node) + && !TYPE_UNSIGNED (gnu_result_type) + && !FLOAT_TYPE_P (gnu_result_type)) + gnu_result + = build_unary_op_trapv (gnu_codes[kind], + gnu_result_type, gnu_expr, gnat_node); + else + gnu_result = build_unary_op (gnu_codes[kind], + gnu_result_type, gnu_expr); + break; + + case N_Allocator: + { + tree gnu_init = 0; + tree gnu_type; + bool ignore_init_type = false; + + gnat_temp = Expression (gnat_node); + + /* The Expression operand can either be an N_Identifier or + Expanded_Name, which must represent a type, or a + N_Qualified_Expression, which contains both the object type and an + initial value for the object. */ + if (Nkind (gnat_temp) == N_Identifier + || Nkind (gnat_temp) == N_Expanded_Name) + gnu_type = gnat_to_gnu_type (Entity (gnat_temp)); + else if (Nkind (gnat_temp) == N_Qualified_Expression) + { + Entity_Id gnat_desig_type + = Designated_Type (Underlying_Type (Etype (gnat_node))); + + ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type); + gnu_init = gnat_to_gnu (Expression (gnat_temp)); + + gnu_init = maybe_unconstrained_array (gnu_init); + if (Do_Range_Check (Expression (gnat_temp))) + gnu_init + = emit_range_check (gnu_init, gnat_desig_type, gnat_temp); + + if (Is_Elementary_Type (gnat_desig_type) + || Is_Constrained (gnat_desig_type)) + { + gnu_type = gnat_to_gnu_type (gnat_desig_type); + gnu_init = convert (gnu_type, gnu_init); + } + else + { + gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp))); + if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) + gnu_type = TREE_TYPE (gnu_init); + + gnu_init = convert (gnu_type, gnu_init); + } + } + else + gcc_unreachable (); + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + return build_allocator (gnu_type, gnu_init, gnu_result_type, + Procedure_To_Call (gnat_node), + Storage_Pool (gnat_node), gnat_node, + ignore_init_type); + } + break; + + /**************************/ + /* Chapter 5: Statements */ + /**************************/ + + case N_Label: + gnu_result = build1 (LABEL_EXPR, void_type_node, + gnat_to_gnu (Identifier (gnat_node))); + break; + + case N_Null_Statement: + /* When not optimizing, turn null statements from source into gotos to + the next statement that the middle-end knows how to preserve. */ + if (!optimize && Comes_From_Source (gnat_node)) + { + tree stmt, label = create_label_decl (NULL_TREE); + start_stmt_group (); + stmt = build1 (GOTO_EXPR, void_type_node, label); + set_expr_location_from_node (stmt, gnat_node); + add_stmt (stmt); + stmt = build1 (LABEL_EXPR, void_type_node, label); + set_expr_location_from_node (stmt, gnat_node); + add_stmt (stmt); + gnu_result = end_stmt_group (); + } + else + gnu_result = alloc_stmt_list (); + break; + + case N_Assignment_Statement: + /* Get the LHS and RHS of the statement and convert any reference to an + unconstrained array into a reference to the underlying array. */ + gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node))); + + /* If the type has a size that overflows, convert this into raise of + Storage_Error: execution shouldn't have gotten here anyway. */ + if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST + && TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs)))) + gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node, + N_Raise_Storage_Error); + else if (Nkind (Expression (gnat_node)) == N_Function_Call) + gnu_result + = call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs); + else + { + gnu_rhs + = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node))); + + /* If range check is needed, emit code to generate it. */ + if (Do_Range_Check (Expression (gnat_node))) + gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)), + gnat_node); + + gnu_result + = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs); + + /* If the type being assigned is an array type and the two sides are + not completely disjoint, play safe and use memmove. But don't do + it for a bit-packed array as it might not be byte-aligned. */ + if (TREE_CODE (gnu_result) == MODIFY_EXPR + && Is_Array_Type (Etype (Name (gnat_node))) + && !Is_Bit_Packed_Array (Etype (Name (gnat_node))) + && !(Forwards_OK (gnat_node) && Backwards_OK (gnat_node))) + { + tree to, from, size, to_ptr, from_ptr, t; + + to = TREE_OPERAND (gnu_result, 0); + from = TREE_OPERAND (gnu_result, 1); + + size = TYPE_SIZE_UNIT (TREE_TYPE (from)); + size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, from); + + to_ptr = build_fold_addr_expr (to); + from_ptr = build_fold_addr_expr (from); + + t = implicit_built_in_decls[BUILT_IN_MEMMOVE]; + gnu_result = build_call_expr (t, 3, to_ptr, from_ptr, size); + } + } + break; + + case N_If_Statement: + { + tree *gnu_else_ptr; /* Point to put next "else if" or "else". */ + + /* Make the outer COND_EXPR. Avoid non-determinism. */ + gnu_result = build3 (COND_EXPR, void_type_node, + gnat_to_gnu (Condition (gnat_node)), + NULL_TREE, NULL_TREE); + COND_EXPR_THEN (gnu_result) + = build_stmt_group (Then_Statements (gnat_node), false); + TREE_SIDE_EFFECTS (gnu_result) = 1; + gnu_else_ptr = &COND_EXPR_ELSE (gnu_result); + + /* Now make a COND_EXPR for each of the "else if" parts. Put each + into the previous "else" part and point to where to put any + outer "else". Also avoid non-determinism. */ + if (Present (Elsif_Parts (gnat_node))) + for (gnat_temp = First (Elsif_Parts (gnat_node)); + Present (gnat_temp); gnat_temp = Next (gnat_temp)) + { + gnu_expr = build3 (COND_EXPR, void_type_node, + gnat_to_gnu (Condition (gnat_temp)), + NULL_TREE, NULL_TREE); + COND_EXPR_THEN (gnu_expr) + = build_stmt_group (Then_Statements (gnat_temp), false); + TREE_SIDE_EFFECTS (gnu_expr) = 1; + set_expr_location_from_node (gnu_expr, gnat_temp); + *gnu_else_ptr = gnu_expr; + gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr); + } + + *gnu_else_ptr = build_stmt_group (Else_Statements (gnat_node), false); + } + break; + + case N_Case_Statement: + gnu_result = Case_Statement_to_gnu (gnat_node); + break; + + case N_Loop_Statement: + gnu_result = Loop_Statement_to_gnu (gnat_node); + break; + + case N_Block_Statement: + start_stmt_group (); + gnat_pushlevel (); + process_decls (Declarations (gnat_node), Empty, Empty, true, true); + add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); + gnat_poplevel (); + gnu_result = end_stmt_group (); + + if (Present (Identifier (gnat_node))) + mark_out_of_scope (Entity (Identifier (gnat_node))); + break; + + case N_Exit_Statement: + gnu_result + = build2 (EXIT_STMT, void_type_node, + (Present (Condition (gnat_node)) + ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE), + (Present (Name (gnat_node)) + ? get_gnu_tree (Entity (Name (gnat_node))) + : VEC_last (tree, gnu_loop_label_stack))); + break; + + case N_Return_Statement: + { + tree gnu_ret_val, gnu_ret_obj; + + /* If the subprogram is a function, we must return the expression. */ + if (Present (Expression (gnat_node))) + { + tree gnu_subprog_type = TREE_TYPE (current_function_decl); + tree gnu_ret_type = TREE_TYPE (gnu_subprog_type); + tree gnu_result_decl = DECL_RESULT (current_function_decl); + gnu_ret_val = gnat_to_gnu (Expression (gnat_node)); + + /* If this function has copy-in/copy-out parameters, get the real + variable and type for the return. See Subprogram_to_gnu. */ + if (TYPE_CI_CO_LIST (gnu_subprog_type)) + { + gnu_result_decl = VEC_last (tree, gnu_return_var_stack); + gnu_ret_type = TREE_TYPE (gnu_result_decl); + } + + /* Do not remove the padding from GNU_RET_VAL if the inner type is + self-referential since we want to allocate the fixed size. */ + if (TREE_CODE (gnu_ret_val) == COMPONENT_REF + && TYPE_IS_PADDING_P + (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))) + && CONTAINS_PLACEHOLDER_P + (TYPE_SIZE (TREE_TYPE (gnu_ret_val)))) + gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0); + + /* If the subprogram returns by direct reference, return a pointer + to the return value. */ + if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type) + || By_Ref (gnat_node)) + gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val); + + /* Otherwise, if it returns an unconstrained array, we have to + allocate a new version of the result and return it. */ + else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)) + { + gnu_ret_val = maybe_unconstrained_array (gnu_ret_val); + gnu_ret_val = build_allocator (TREE_TYPE (gnu_ret_val), + gnu_ret_val, gnu_ret_type, + Procedure_To_Call (gnat_node), + Storage_Pool (gnat_node), + gnat_node, false); + } + + /* If the subprogram returns by invisible reference, dereference + the pointer it is passed using the type of the return value + and build the copy operation manually. This ensures that we + don't copy too much data, for example if the return type is + unconstrained with a maximum size. */ + if (TREE_ADDRESSABLE (gnu_subprog_type)) + { + gnu_ret_obj + = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val), + gnu_result_decl); + gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE, + gnu_ret_obj, gnu_ret_val); + add_stmt_with_node (gnu_result, gnat_node); + gnu_ret_val = NULL_TREE; + gnu_ret_obj = gnu_result_decl; + } + + /* Otherwise, build a regular return. */ + else + gnu_ret_obj = gnu_result_decl; + } + else + { + gnu_ret_val = NULL_TREE; + gnu_ret_obj = NULL_TREE; + } + + /* If we have a return label defined, convert this into a branch to + that label. The return proper will be handled elsewhere. */ + if (VEC_last (tree, gnu_return_label_stack)) + { + if (gnu_ret_obj) + add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_ret_obj, + gnu_ret_val)); + + gnu_result = build1 (GOTO_EXPR, void_type_node, + VEC_last (tree, gnu_return_label_stack)); + /* When not optimizing, make sure the return is preserved. */ + if (!optimize && Comes_From_Source (gnat_node)) + DECL_ARTIFICIAL (VEC_last (tree, gnu_return_label_stack)) = 0; + break; + } + + gnu_result = build_return_expr (gnu_ret_obj, gnu_ret_val); + } + break; + + case N_Goto_Statement: + gnu_result = build1 (GOTO_EXPR, void_type_node, + gnat_to_gnu (Name (gnat_node))); + break; + + /***************************/ + /* Chapter 6: Subprograms */ + /***************************/ + + case N_Subprogram_Declaration: + /* Unless there is a freeze node, declare the subprogram. We consider + this a "definition" even though we're not generating code for + the subprogram because we will be making the corresponding GCC + node here. */ + + if (No (Freeze_Node (Defining_Entity (Specification (gnat_node))))) + gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)), + NULL_TREE, 1); + gnu_result = alloc_stmt_list (); + break; + + case N_Abstract_Subprogram_Declaration: + /* This subprogram doesn't exist for code generation purposes, but we + have to elaborate the types of any parameters and result, unless + they are imported types (nothing to generate in this case). + + The parameter list may contain types with freeze nodes, e.g. not null + subtypes, so the subprogram itself may carry a freeze node, in which + case its elaboration must be deferred. */ + + /* Process the parameter types first. */ + if (No (Freeze_Node (Defining_Entity (Specification (gnat_node))))) + for (gnat_temp + = First_Formal_With_Extras + (Defining_Entity (Specification (gnat_node))); + Present (gnat_temp); + gnat_temp = Next_Formal_With_Extras (gnat_temp)) + if (Is_Itype (Etype (gnat_temp)) + && !From_With_Type (Etype (gnat_temp))) + gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0); + + /* Then the result type, set to Standard_Void_Type for procedures. */ + { + Entity_Id gnat_temp_type + = Etype (Defining_Entity (Specification (gnat_node))); + + if (Is_Itype (gnat_temp_type) && !From_With_Type (gnat_temp_type)) + gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, 0); + } + + gnu_result = alloc_stmt_list (); + break; + + case N_Defining_Program_Unit_Name: + /* For a child unit identifier go up a level to get the specification. + We get this when we try to find the spec of a child unit package + that is the compilation unit being compiled. */ + gnu_result = gnat_to_gnu (Parent (gnat_node)); + break; + + case N_Subprogram_Body: + Subprogram_Body_to_gnu (gnat_node); + gnu_result = alloc_stmt_list (); + break; + + case N_Function_Call: + case N_Procedure_Call_Statement: + gnu_result = call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE); + break; + + /************************/ + /* Chapter 7: Packages */ + /************************/ + + case N_Package_Declaration: + gnu_result = gnat_to_gnu (Specification (gnat_node)); + break; + + case N_Package_Specification: + + start_stmt_group (); + process_decls (Visible_Declarations (gnat_node), + Private_Declarations (gnat_node), Empty, true, true); + gnu_result = end_stmt_group (); + break; + + case N_Package_Body: + + /* If this is the body of a generic package - do nothing. */ + if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package) + { + gnu_result = alloc_stmt_list (); + break; + } + + start_stmt_group (); + process_decls (Declarations (gnat_node), Empty, Empty, true, true); + + if (Present (Handled_Statement_Sequence (gnat_node))) + add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); + + gnu_result = end_stmt_group (); + break; + + /********************************/ + /* Chapter 8: Visibility Rules */ + /********************************/ + + case N_Use_Package_Clause: + case N_Use_Type_Clause: + /* Nothing to do here - but these may appear in list of declarations. */ + gnu_result = alloc_stmt_list (); + break; + + /*********************/ + /* Chapter 9: Tasks */ + /*********************/ + + case N_Protected_Type_Declaration: + gnu_result = alloc_stmt_list (); + break; + + case N_Single_Task_Declaration: + gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1); + gnu_result = alloc_stmt_list (); + break; + + /*********************************************************/ + /* Chapter 10: Program Structure and Compilation Issues */ + /*********************************************************/ + + case N_Compilation_Unit: + /* This is not called for the main unit on which gigi is invoked. */ + Compilation_Unit_to_gnu (gnat_node); + gnu_result = alloc_stmt_list (); + break; + + case N_Subprogram_Body_Stub: + case N_Package_Body_Stub: + case N_Protected_Body_Stub: + case N_Task_Body_Stub: + /* Simply process whatever unit is being inserted. */ + gnu_result = gnat_to_gnu (Unit (Library_Unit (gnat_node))); + break; + + case N_Subunit: + gnu_result = gnat_to_gnu (Proper_Body (gnat_node)); + break; + + /***************************/ + /* Chapter 11: Exceptions */ + /***************************/ + + case N_Handled_Sequence_Of_Statements: + /* If there is an At_End procedure attached to this node, and the EH + mechanism is SJLJ, we must have at least a corresponding At_End + handler, unless the No_Exception_Handlers restriction is set. */ + gcc_assert (type_annotate_only + || Exception_Mechanism != Setjmp_Longjmp + || No (At_End_Proc (gnat_node)) + || Present (Exception_Handlers (gnat_node)) + || No_Exception_Handlers_Set ()); + + gnu_result = Handled_Sequence_Of_Statements_to_gnu (gnat_node); + break; + + case N_Exception_Handler: + if (Exception_Mechanism == Setjmp_Longjmp) + gnu_result = Exception_Handler_to_gnu_sjlj (gnat_node); + else if (Exception_Mechanism == Back_End_Exceptions) + gnu_result = Exception_Handler_to_gnu_zcx (gnat_node); + else + gcc_unreachable (); + + break; + + case N_Push_Constraint_Error_Label: + push_exception_label_stack (&gnu_constraint_error_label_stack, + Exception_Label (gnat_node)); + break; + + case N_Push_Storage_Error_Label: + push_exception_label_stack (&gnu_storage_error_label_stack, + Exception_Label (gnat_node)); + break; + + case N_Push_Program_Error_Label: + push_exception_label_stack (&gnu_program_error_label_stack, + Exception_Label (gnat_node)); + break; + + case N_Pop_Constraint_Error_Label: + VEC_pop (tree, gnu_constraint_error_label_stack); + break; + + case N_Pop_Storage_Error_Label: + VEC_pop (tree, gnu_storage_error_label_stack); + break; + + case N_Pop_Program_Error_Label: + VEC_pop (tree, gnu_program_error_label_stack); + break; + + /******************************/ + /* Chapter 12: Generic Units */ + /******************************/ + + case N_Generic_Function_Renaming_Declaration: + case N_Generic_Package_Renaming_Declaration: + case N_Generic_Procedure_Renaming_Declaration: + case N_Generic_Package_Declaration: + case N_Generic_Subprogram_Declaration: + case N_Package_Instantiation: + case N_Procedure_Instantiation: + case N_Function_Instantiation: + /* These nodes can appear on a declaration list but there is nothing to + to be done with them. */ + gnu_result = alloc_stmt_list (); + break; + + /**************************************************/ + /* Chapter 13: Representation Clauses and */ + /* Implementation-Dependent Features */ + /**************************************************/ + + case N_Attribute_Definition_Clause: + gnu_result = alloc_stmt_list (); + + /* The only one we need to deal with is 'Address since, for the others, + the front-end puts the information elsewhere. */ + if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address) + break; + + /* And we only deal with 'Address if the object has a Freeze node. */ + gnat_temp = Entity (Name (gnat_node)); + if (No (Freeze_Node (gnat_temp))) + break; + + /* Get the value to use as the address and save it as the equivalent + for the object. When it is frozen, gnat_to_gnu_entity will do the + right thing. */ + save_gnu_tree (gnat_temp, gnat_to_gnu (Expression (gnat_node)), true); + break; + + case N_Enumeration_Representation_Clause: + case N_Record_Representation_Clause: + case N_At_Clause: + /* We do nothing with these. SEM puts the information elsewhere. */ + gnu_result = alloc_stmt_list (); + break; + + case N_Code_Statement: + if (!type_annotate_only) + { + tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node)); + tree gnu_inputs = NULL_TREE, gnu_outputs = NULL_TREE; + tree gnu_clobbers = NULL_TREE, tail; + bool allows_mem, allows_reg, fake; + int ninputs, noutputs, i; + const char **oconstraints; + const char *constraint; + char *clobber; + + /* First retrieve the 3 operand lists built by the front-end. */ + Setup_Asm_Outputs (gnat_node); + while (Present (gnat_temp = Asm_Output_Variable ())) + { + tree gnu_value = gnat_to_gnu (gnat_temp); + tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu + (Asm_Output_Constraint ())); + + gnu_outputs = tree_cons (gnu_constr, gnu_value, gnu_outputs); + Next_Asm_Output (); + } + + Setup_Asm_Inputs (gnat_node); + while (Present (gnat_temp = Asm_Input_Value ())) + { + tree gnu_value = gnat_to_gnu (gnat_temp); + tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu + (Asm_Input_Constraint ())); + + gnu_inputs = tree_cons (gnu_constr, gnu_value, gnu_inputs); + Next_Asm_Input (); + } + + Clobber_Setup (gnat_node); + while ((clobber = Clobber_Get_Next ())) + gnu_clobbers + = tree_cons (NULL_TREE, + build_string (strlen (clobber) + 1, clobber), + gnu_clobbers); + + /* Then perform some standard checking and processing on the + operands. In particular, mark them addressable if needed. */ + gnu_outputs = nreverse (gnu_outputs); + noutputs = list_length (gnu_outputs); + gnu_inputs = nreverse (gnu_inputs); + ninputs = list_length (gnu_inputs); + oconstraints = XALLOCAVEC (const char *, noutputs); + + for (i = 0, tail = gnu_outputs; tail; ++i, tail = TREE_CHAIN (tail)) + { + tree output = TREE_VALUE (tail); + constraint + = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail))); + oconstraints[i] = constraint; + + if (parse_output_constraint (&constraint, i, ninputs, noutputs, + &allows_mem, &allows_reg, &fake)) + { + /* If the operand is going to end up in memory, + mark it addressable. Note that we don't test + allows_mem like in the input case below; this + is modelled on the C front-end. */ + if (!allows_reg + && !gnat_mark_addressable (output)) + output = error_mark_node; + } + else + output = error_mark_node; + + TREE_VALUE (tail) = output; + } + + for (i = 0, tail = gnu_inputs; tail; ++i, tail = TREE_CHAIN (tail)) + { + tree input = TREE_VALUE (tail); + constraint + = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail))); + + if (parse_input_constraint (&constraint, i, ninputs, noutputs, + 0, oconstraints, + &allows_mem, &allows_reg)) + { + /* If the operand is going to end up in memory, + mark it addressable. */ + if (!allows_reg && allows_mem + && !gnat_mark_addressable (input)) + input = error_mark_node; + } + else + input = error_mark_node; + + TREE_VALUE (tail) = input; + } + + gnu_result = build5 (ASM_EXPR, void_type_node, + gnu_template, gnu_outputs, + gnu_inputs, gnu_clobbers, NULL_TREE); + ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node); + } + else + gnu_result = alloc_stmt_list (); + + break; + + /****************/ + /* Added Nodes */ + /****************/ + + case N_Expression_With_Actions: + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + /* This construct doesn't define a scope so we don't wrap the statement + list in a BIND_EXPR; however, we wrap it in a SAVE_EXPR to protect it + from unsharing. */ + gnu_result = build_stmt_group (Actions (gnat_node), false); + gnu_result = build1 (SAVE_EXPR, void_type_node, gnu_result); + TREE_SIDE_EFFECTS (gnu_result) = 1; + gnu_expr = gnat_to_gnu (Expression (gnat_node)); + gnu_result + = build_compound_expr (TREE_TYPE (gnu_expr), gnu_result, gnu_expr); + break; + + case N_Freeze_Entity: + start_stmt_group (); + process_freeze_entity (gnat_node); + process_decls (Actions (gnat_node), Empty, Empty, true, true); + gnu_result = end_stmt_group (); + break; + + case N_Itype_Reference: + if (!present_gnu_tree (Itype (gnat_node))) + process_type (Itype (gnat_node)); + + gnu_result = alloc_stmt_list (); + break; + + case N_Free_Statement: + if (!type_annotate_only) + { + tree gnu_ptr = gnat_to_gnu (Expression (gnat_node)); + tree gnu_ptr_type = TREE_TYPE (gnu_ptr); + tree gnu_obj_type; + tree gnu_actual_obj_type = 0; + tree gnu_obj_size; + + /* If this is a thin pointer, we must dereference it to create + a fat pointer, then go back below to a thin pointer. The + reason for this is that we need a fat pointer someplace in + order to properly compute the size. */ + if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr))) + gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE, + build_unary_op (INDIRECT_REF, NULL_TREE, + gnu_ptr)); + + /* If this is an unconstrained array, we know the object must + have been allocated with the template in front of the object. + So pass the template address, but get the total size. Do this + by converting to a thin pointer. */ + if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr))) + gnu_ptr + = convert (build_pointer_type + (TYPE_OBJECT_RECORD_TYPE + (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))), + gnu_ptr); + + gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr)); + + if (Present (Actual_Designated_Subtype (gnat_node))) + { + gnu_actual_obj_type + = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node)); + + if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)) + gnu_actual_obj_type + = build_unc_object_type_from_ptr (gnu_ptr_type, + gnu_actual_obj_type, + get_identifier ("DEALLOC"), + false); + } + else + gnu_actual_obj_type = gnu_obj_type; + + gnu_obj_size = TYPE_SIZE_UNIT (gnu_actual_obj_type); + + if (TREE_CODE (gnu_obj_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type)) + { + tree gnu_char_ptr_type + = build_pointer_type (unsigned_char_type_node); + tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type)); + gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr); + gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type, + gnu_ptr, gnu_pos); + } + + gnu_result + = build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, gnu_obj_type, + Procedure_To_Call (gnat_node), + Storage_Pool (gnat_node), + gnat_node); + } + break; + + case N_Raise_Constraint_Error: + case N_Raise_Program_Error: + case N_Raise_Storage_Error: + { + const int reason = UI_To_Int (Reason (gnat_node)); + const Node_Id cond = Condition (gnat_node); + bool handled = false; + + if (type_annotate_only) + { + gnu_result = alloc_stmt_list (); + break; + } + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + if (Exception_Extra_Info + && !No_Exception_Handlers_Set () + && !get_exception_label (kind) + && TREE_CODE (gnu_result_type) == VOID_TYPE + && Present (cond)) + { + if (reason == CE_Access_Check_Failed) + { + gnu_result = build_call_raise_column (reason, gnat_node); + handled = true; + } + else if ((reason == CE_Index_Check_Failed + || reason == CE_Range_Check_Failed + || reason == CE_Invalid_Data) + && Nkind (cond) == N_Op_Not + && Nkind (Right_Opnd (cond)) == N_In + && Nkind (Right_Opnd (Right_Opnd (cond))) == N_Range) + { + Node_Id op = Right_Opnd (cond); /* N_In node */ + Node_Id index = Left_Opnd (op); + Node_Id type = Etype (index); + + if (Is_Type (type) + && Known_Esize (type) + && UI_To_Int (Esize (type)) <= 32) + { + Node_Id right_op = Right_Opnd (op); + gnu_result + = build_call_raise_range + (reason, gnat_node, + gnat_to_gnu (index), /* index */ + gnat_to_gnu (Low_Bound (right_op)), /* first */ + gnat_to_gnu (High_Bound (right_op))); /* last */ + handled = true; + } + } + } + + if (handled) + { + set_expr_location_from_node (gnu_result, gnat_node); + gnu_result = build3 (COND_EXPR, void_type_node, + gnat_to_gnu (cond), + gnu_result, alloc_stmt_list ()); + } + else + { + gnu_result = build_call_raise (reason, gnat_node, kind); + + /* If the type is VOID, this is a statement, so we need to generate + the code for the call. Handle a Condition, if there is one. */ + if (TREE_CODE (gnu_result_type) == VOID_TYPE) + { + set_expr_location_from_node (gnu_result, gnat_node); + if (Present (cond)) + gnu_result = build3 (COND_EXPR, void_type_node, + gnat_to_gnu (cond), + gnu_result, alloc_stmt_list ()); + } + else + gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result); + } + } + break; + + case N_Validate_Unchecked_Conversion: + { + Entity_Id gnat_target_type = Target_Type (gnat_node); + tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node)); + tree gnu_target_type = gnat_to_gnu_type (gnat_target_type); + + /* No need for any warning in this case. */ + if (!flag_strict_aliasing) + ; + + /* If the result is a pointer type, see if we are either converting + from a non-pointer or from a pointer to a type with a different + alias set and warn if so. If the result is defined in the same + unit as this unchecked conversion, we can allow this because we + can know to make the pointer type behave properly. */ + else if (POINTER_TYPE_P (gnu_target_type) + && !In_Same_Source_Unit (gnat_target_type, gnat_node) + && !No_Strict_Aliasing (Underlying_Type (gnat_target_type))) + { + tree gnu_source_desig_type = POINTER_TYPE_P (gnu_source_type) + ? TREE_TYPE (gnu_source_type) + : NULL_TREE; + tree gnu_target_desig_type = TREE_TYPE (gnu_target_type); + + if ((TYPE_DUMMY_P (gnu_target_desig_type) + || get_alias_set (gnu_target_desig_type) != 0) + && (!POINTER_TYPE_P (gnu_source_type) + || (TYPE_DUMMY_P (gnu_source_desig_type) + != TYPE_DUMMY_P (gnu_target_desig_type)) + || (TYPE_DUMMY_P (gnu_source_desig_type) + && gnu_source_desig_type != gnu_target_desig_type) + || !alias_sets_conflict_p + (get_alias_set (gnu_source_desig_type), + get_alias_set (gnu_target_desig_type)))) + { + post_error_ne + ("?possible aliasing problem for type&", + gnat_node, Target_Type (gnat_node)); + post_error + ("\\?use -fno-strict-aliasing switch for references", + gnat_node); + post_error_ne + ("\\?or use `pragma No_Strict_Aliasing (&);`", + gnat_node, Target_Type (gnat_node)); + } + } + + /* But if the result is a fat pointer type, we have no mechanism to + do that, so we unconditionally warn in problematic cases. */ + else if (TYPE_IS_FAT_POINTER_P (gnu_target_type)) + { + tree gnu_source_array_type + = TYPE_IS_FAT_POINTER_P (gnu_source_type) + ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type))) + : NULL_TREE; + tree gnu_target_array_type + = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type))); + + if ((TYPE_DUMMY_P (gnu_target_array_type) + || get_alias_set (gnu_target_array_type) != 0) + && (!TYPE_IS_FAT_POINTER_P (gnu_source_type) + || (TYPE_DUMMY_P (gnu_source_array_type) + != TYPE_DUMMY_P (gnu_target_array_type)) + || (TYPE_DUMMY_P (gnu_source_array_type) + && gnu_source_array_type != gnu_target_array_type) + || !alias_sets_conflict_p + (get_alias_set (gnu_source_array_type), + get_alias_set (gnu_target_array_type)))) + { + post_error_ne + ("?possible aliasing problem for type&", + gnat_node, Target_Type (gnat_node)); + post_error + ("\\?use -fno-strict-aliasing switch for references", + gnat_node); + } + } + } + gnu_result = alloc_stmt_list (); + break; + + default: + /* SCIL nodes require no processing for GCC. Other nodes should only + be present when annotating types. */ + gcc_assert (IN (kind, N_SCIL_Node) || type_annotate_only); + gnu_result = alloc_stmt_list (); + } + + /* If we pushed the processing of the elaboration routine, pop it back. */ + if (went_into_elab_proc) + current_function_decl = NULL_TREE; + + /* When not optimizing, turn boolean rvalues B into B != false tests + so that the code just below can put the location information of the + reference to B on the inequality operator for better debug info. */ + if (!optimize + && TREE_CODE (gnu_result) != INTEGER_CST + && (kind == N_Identifier + || kind == N_Expanded_Name + || kind == N_Explicit_Dereference + || kind == N_Function_Call + || kind == N_Indexed_Component + || kind == N_Selected_Component) + && TREE_CODE (get_base_type (gnu_result_type)) == BOOLEAN_TYPE + && !lvalue_required_p (gnat_node, gnu_result_type, false, false, false)) + gnu_result = build_binary_op (NE_EXPR, gnu_result_type, + convert (gnu_result_type, gnu_result), + convert (gnu_result_type, + boolean_false_node)); + + /* Set the location information on the result. Note that we may have + no result if we tried to build a CALL_EXPR node to a procedure with + no side-effects and optimization is enabled. */ + if (gnu_result && EXPR_P (gnu_result)) + set_gnu_expr_location_from_node (gnu_result, gnat_node); + + /* If we're supposed to return something of void_type, it means we have + something we're elaborating for effect, so just return. */ + if (TREE_CODE (gnu_result_type) == VOID_TYPE) + return gnu_result; + + /* If the result is a constant that overflowed, raise Constraint_Error. */ + if (TREE_CODE (gnu_result) == INTEGER_CST && TREE_OVERFLOW (gnu_result)) + { + post_error ("?`Constraint_Error` will be raised at run time", gnat_node); + gnu_result + = build1 (NULL_EXPR, gnu_result_type, + build_call_raise (CE_Overflow_Check_Failed, gnat_node, + N_Raise_Constraint_Error)); + } + + /* If our result has side-effects and is of an unconstrained type, + make a SAVE_EXPR so that we can be sure it will only be referenced + once. Note we must do this before any conversions. */ + if (TREE_SIDE_EFFECTS (gnu_result) + && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE + || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))) + gnu_result = gnat_stabilize_reference (gnu_result, false, NULL); + + /* Now convert the result to the result type, unless we are in one of the + following cases: + + 1. If this is the Name of an assignment statement or a parameter of + a procedure call, return the result almost unmodified since the + RHS will have to be converted to our type in that case, unless + the result type has a simpler size. Likewise if there is just + a no-op unchecked conversion in-between. Similarly, don't convert + integral types that are the operands of an unchecked conversion + since we need to ignore those conversions (for 'Valid). + + 2. If we have a label (which doesn't have any well-defined type), a + field or an error, return the result almost unmodified. Also don't + do the conversion if the result type involves a PLACEHOLDER_EXPR in + its size since those are the cases where the front end may have the + type wrong due to "instantiating" the unconstrained record with + discriminant values. Similarly, if the two types are record types + with the same name don't convert. This will be the case when we are + converting from a packable version of a type to its original type and + we need those conversions to be NOPs in order for assignments into + these types to work properly. + + 3. If the type is void or if we have no result, return error_mark_node + to show we have no result. + + 4. Finally, if the type of the result is already correct. */ + + if (Present (Parent (gnat_node)) + && ((Nkind (Parent (gnat_node)) == N_Assignment_Statement + && Name (Parent (gnat_node)) == gnat_node) + || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion + && unchecked_conversion_nop (Parent (gnat_node))) + || (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement + && Name (Parent (gnat_node)) != gnat_node) + || Nkind (Parent (gnat_node)) == N_Parameter_Association + || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion + && !AGGREGATE_TYPE_P (gnu_result_type) + && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))) + && !(TYPE_SIZE (gnu_result_type) + && TYPE_SIZE (TREE_TYPE (gnu_result)) + && (AGGREGATE_TYPE_P (gnu_result_type) + == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))) + && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST + && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result))) + != INTEGER_CST)) + || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST + && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)) + && (CONTAINS_PLACEHOLDER_P + (TYPE_SIZE (TREE_TYPE (gnu_result)))))) + && !(TREE_CODE (gnu_result_type) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type)))) + { + /* Remove padding only if the inner object is of self-referential + size: in that case it must be an object of unconstrained type + with a default discriminant and we want to avoid copying too + much data. */ + if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)) + && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS + (TREE_TYPE (gnu_result)))))) + gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))), + gnu_result); + } + + else if (TREE_CODE (gnu_result) == LABEL_DECL + || TREE_CODE (gnu_result) == FIELD_DECL + || TREE_CODE (gnu_result) == ERROR_MARK + || (TYPE_SIZE (gnu_result_type) + && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST + && TREE_CODE (gnu_result) != INDIRECT_REF + && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))) + || ((TYPE_NAME (gnu_result_type) + == TYPE_NAME (TREE_TYPE (gnu_result))) + && TREE_CODE (gnu_result_type) == RECORD_TYPE + && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE)) + { + /* Remove any padding. */ + if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))) + gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))), + gnu_result); + } + + else if (gnu_result == error_mark_node || gnu_result_type == void_type_node) + gnu_result = error_mark_node; + + else if (gnu_result_type != TREE_TYPE (gnu_result)) + gnu_result = convert (gnu_result_type, gnu_result); + + /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result. */ + while ((TREE_CODE (gnu_result) == NOP_EXPR + || TREE_CODE (gnu_result) == NON_LVALUE_EXPR) + && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result)) + gnu_result = TREE_OPERAND (gnu_result, 0); + + return gnu_result; +} + +/* Subroutine of above to push the exception label stack. GNU_STACK is + a pointer to the stack to update and GNAT_LABEL, if present, is the + label to push onto the stack. */ + +static void +push_exception_label_stack (VEC(tree,gc) **gnu_stack, Entity_Id gnat_label) +{ + tree gnu_label = (Present (gnat_label) + ? gnat_to_gnu_entity (gnat_label, NULL_TREE, 0) + : NULL_TREE); + + VEC_safe_push (tree, gc, *gnu_stack, gnu_label); +} + +/* Record the current code position in GNAT_NODE. */ + +static void +record_code_position (Node_Id gnat_node) +{ + tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE); + + add_stmt_with_node (stmt_stmt, gnat_node); + save_gnu_tree (gnat_node, stmt_stmt, true); +} + +/* Insert the code for GNAT_NODE at the position saved for that node. */ + +static void +insert_code_for (Node_Id gnat_node) +{ + STMT_STMT_STMT (get_gnu_tree (gnat_node)) = gnat_to_gnu (gnat_node); + save_gnu_tree (gnat_node, NULL_TREE, true); +} + +/* Start a new statement group chained to the previous group. */ + +void +start_stmt_group (void) +{ + struct stmt_group *group = stmt_group_free_list; + + /* First see if we can get one from the free list. */ + if (group) + stmt_group_free_list = group->previous; + else + group = ggc_alloc_stmt_group (); + + group->previous = current_stmt_group; + group->stmt_list = group->block = group->cleanups = NULL_TREE; + current_stmt_group = group; +} + +/* Add GNU_STMT to the current statement group. If it is an expression with + no effects, it is ignored. */ + +void +add_stmt (tree gnu_stmt) +{ + append_to_statement_list (gnu_stmt, ¤t_stmt_group->stmt_list); +} + +/* Similar, but the statement is always added, regardless of side-effects. */ + +void +add_stmt_force (tree gnu_stmt) +{ + append_to_statement_list_force (gnu_stmt, ¤t_stmt_group->stmt_list); +} + +/* Like add_stmt, but set the location of GNU_STMT to that of GNAT_NODE. */ + +void +add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node) +{ + if (Present (gnat_node)) + set_expr_location_from_node (gnu_stmt, gnat_node); + add_stmt (gnu_stmt); +} + +/* Similar, but the statement is always added, regardless of side-effects. */ + +void +add_stmt_with_node_force (tree gnu_stmt, Node_Id gnat_node) +{ + if (Present (gnat_node)) + set_expr_location_from_node (gnu_stmt, gnat_node); + add_stmt_force (gnu_stmt); +} + +/* Add a declaration statement for GNU_DECL to the current statement group. + Get SLOC from Entity_Id. */ + +void +add_decl_expr (tree gnu_decl, Entity_Id gnat_entity) +{ + tree type = TREE_TYPE (gnu_decl); + tree gnu_stmt, gnu_init, t; + + /* If this is a variable that Gigi is to ignore, we may have been given + an ERROR_MARK. So test for it. We also might have been given a + reference for a renaming. So only do something for a decl. Also + ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE. */ + if (!DECL_P (gnu_decl) + || (TREE_CODE (gnu_decl) == TYPE_DECL + && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)) + return; + + gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl); + + /* If we are global, we don't want to actually output the DECL_EXPR for + this decl since we already have evaluated the expressions in the + sizes and positions as globals and doing it again would be wrong. */ + if (global_bindings_p ()) + { + /* Mark everything as used to prevent node sharing with subprograms. + Note that walk_tree knows how to deal with TYPE_DECL, but neither + VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */ + MARK_VISITED (gnu_stmt); + if (TREE_CODE (gnu_decl) == VAR_DECL + || TREE_CODE (gnu_decl) == CONST_DECL) + { + MARK_VISITED (DECL_SIZE (gnu_decl)); + MARK_VISITED (DECL_SIZE_UNIT (gnu_decl)); + MARK_VISITED (DECL_INITIAL (gnu_decl)); + } + /* In any case, we have to deal with our own TYPE_ADA_SIZE field. */ + else if (TREE_CODE (gnu_decl) == TYPE_DECL + && ((TREE_CODE (type) == RECORD_TYPE + && !TYPE_FAT_POINTER_P (type)) + || TREE_CODE (type) == UNION_TYPE + || TREE_CODE (type) == QUAL_UNION_TYPE)) + MARK_VISITED (TYPE_ADA_SIZE (type)); + } + else if (!DECL_EXTERNAL (gnu_decl)) + add_stmt_with_node (gnu_stmt, gnat_entity); + + /* If this is a variable and an initializer is attached to it, it must be + valid for the context. Similar to init_const in create_var_decl_1. */ + if (TREE_CODE (gnu_decl) == VAR_DECL + && (gnu_init = DECL_INITIAL (gnu_decl)) != NULL_TREE + && (!gnat_types_compatible_p (type, TREE_TYPE (gnu_init)) + || (TREE_STATIC (gnu_decl) + && !initializer_constant_valid_p (gnu_init, + TREE_TYPE (gnu_init))))) + { + /* If GNU_DECL has a padded type, convert it to the unpadded + type so the assignment is done properly. */ + if (TYPE_IS_PADDING_P (type)) + t = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl); + else + t = gnu_decl; + + gnu_stmt = build_binary_op (INIT_EXPR, NULL_TREE, t, gnu_init); + + DECL_INITIAL (gnu_decl) = NULL_TREE; + if (TREE_READONLY (gnu_decl)) + { + TREE_READONLY (gnu_decl) = 0; + DECL_READONLY_ONCE_ELAB (gnu_decl) = 1; + } + + add_stmt_with_node (gnu_stmt, gnat_entity); + } +} + +/* Callback for walk_tree to mark the visited trees rooted at *TP. */ + +static tree +mark_visited_r (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED) +{ + tree t = *tp; + + if (TREE_VISITED (t)) + *walk_subtrees = 0; + + /* Don't mark a dummy type as visited because we want to mark its sizes + and fields once it's filled in. */ + else if (!TYPE_IS_DUMMY_P (t)) + TREE_VISITED (t) = 1; + + if (TYPE_P (t)) + TYPE_SIZES_GIMPLIFIED (t) = 1; + + return NULL_TREE; +} + +/* Mark nodes rooted at T with TREE_VISITED and types as having their + sized gimplified. We use this to indicate all variable sizes and + positions in global types may not be shared by any subprogram. */ + +void +mark_visited (tree t) +{ + walk_tree (&t, mark_visited_r, NULL, NULL); +} + +/* Add GNU_CLEANUP, a cleanup action, to the current code group and + set its location to that of GNAT_NODE if present. */ + +static void +add_cleanup (tree gnu_cleanup, Node_Id gnat_node) +{ + if (Present (gnat_node)) + set_expr_location_from_node (gnu_cleanup, gnat_node); + append_to_statement_list (gnu_cleanup, ¤t_stmt_group->cleanups); +} + +/* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */ + +void +set_block_for_group (tree gnu_block) +{ + gcc_assert (!current_stmt_group->block); + current_stmt_group->block = gnu_block; +} + +/* Return code corresponding to the current code group. It is normally + a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if + BLOCK or cleanups were set. */ + +tree +end_stmt_group (void) +{ + struct stmt_group *group = current_stmt_group; + tree gnu_retval = group->stmt_list; + + /* If this is a null list, allocate a new STATEMENT_LIST. Then, if there + are cleanups, make a TRY_FINALLY_EXPR. Last, if there is a BLOCK, + make a BIND_EXPR. Note that we nest in that because the cleanup may + reference variables in the block. */ + if (gnu_retval == NULL_TREE) + gnu_retval = alloc_stmt_list (); + + if (group->cleanups) + gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval, + group->cleanups); + + if (current_stmt_group->block) + gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block), + gnu_retval, group->block); + + /* Remove this group from the stack and add it to the free list. */ + current_stmt_group = group->previous; + group->previous = stmt_group_free_list; + stmt_group_free_list = group; + + return gnu_retval; +} + +/* Add a list of statements from GNAT_LIST, a possibly-empty list of + statements.*/ + +static void +add_stmt_list (List_Id gnat_list) +{ + Node_Id gnat_node; + + if (Present (gnat_list)) + for (gnat_node = First (gnat_list); Present (gnat_node); + gnat_node = Next (gnat_node)) + add_stmt (gnat_to_gnu (gnat_node)); +} + +/* Build a tree from GNAT_LIST, a possibly-empty list of statements. + If BINDING_P is true, push and pop a binding level around the list. */ + +static tree +build_stmt_group (List_Id gnat_list, bool binding_p) +{ + start_stmt_group (); + if (binding_p) + gnat_pushlevel (); + + add_stmt_list (gnat_list); + if (binding_p) + gnat_poplevel (); + + return end_stmt_group (); +} + +/* Generate GIMPLE in place for the expression at *EXPR_P. */ + +int +gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p, + gimple_seq *post_p ATTRIBUTE_UNUSED) +{ + tree expr = *expr_p; + tree op; + + if (IS_ADA_STMT (expr)) + return gnat_gimplify_stmt (expr_p); + + switch (TREE_CODE (expr)) + { + case NULL_EXPR: + /* If this is for a scalar, just make a VAR_DECL for it. If for + an aggregate, get a null pointer of the appropriate type and + dereference it. */ + if (AGGREGATE_TYPE_P (TREE_TYPE (expr))) + *expr_p = build1 (INDIRECT_REF, TREE_TYPE (expr), + convert (build_pointer_type (TREE_TYPE (expr)), + integer_zero_node)); + else + { + *expr_p = create_tmp_var (TREE_TYPE (expr), NULL); + TREE_NO_WARNING (*expr_p) = 1; + } + + gimplify_and_add (TREE_OPERAND (expr, 0), pre_p); + return GS_OK; + + case UNCONSTRAINED_ARRAY_REF: + /* We should only do this if we are just elaborating for side-effects, + but we can't know that yet. */ + *expr_p = TREE_OPERAND (*expr_p, 0); + return GS_OK; + + case ADDR_EXPR: + op = TREE_OPERAND (expr, 0); + + /* If we are taking the address of a constant CONSTRUCTOR, make sure it + is put into static memory. We know that it's going to be read-only + given the semantics we have and it must be in static memory when the + reference is in an elaboration procedure. */ + if (TREE_CODE (op) == CONSTRUCTOR && TREE_CONSTANT (op)) + { + tree addr = build_fold_addr_expr (tree_output_constant_def (op)); + *expr_p = fold_convert (TREE_TYPE (expr), addr); + return GS_ALL_DONE; + } + + /* Otherwise, if we are taking the address of a non-constant CONSTRUCTOR + or of a call, explicitly create the local temporary. That's required + if the type is passed by reference. */ + if (TREE_CODE (op) == CONSTRUCTOR || TREE_CODE (op) == CALL_EXPR) + { + tree mod, new_var = create_tmp_var_raw (TREE_TYPE (op), "C"); + TREE_ADDRESSABLE (new_var) = 1; + gimple_add_tmp_var (new_var); + + mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, op); + gimplify_and_add (mod, pre_p); + + TREE_OPERAND (expr, 0) = new_var; + recompute_tree_invariant_for_addr_expr (expr); + return GS_ALL_DONE; + } + + return GS_UNHANDLED; + + case VIEW_CONVERT_EXPR: + op = TREE_OPERAND (expr, 0); + + /* If we are view-converting a CONSTRUCTOR or a call from an aggregate + type to a scalar one, explicitly create the local temporary. That's + required if the type is passed by reference. */ + if ((TREE_CODE (op) == CONSTRUCTOR || TREE_CODE (op) == CALL_EXPR) + && AGGREGATE_TYPE_P (TREE_TYPE (op)) + && !AGGREGATE_TYPE_P (TREE_TYPE (expr))) + { + tree mod, new_var = create_tmp_var_raw (TREE_TYPE (op), "C"); + gimple_add_tmp_var (new_var); + + mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, op); + gimplify_and_add (mod, pre_p); + + TREE_OPERAND (expr, 0) = new_var; + return GS_OK; + } + + return GS_UNHANDLED; + + case DECL_EXPR: + op = DECL_EXPR_DECL (expr); + + /* The expressions for the RM bounds must be gimplified to ensure that + they are properly elaborated. See gimplify_decl_expr. */ + if ((TREE_CODE (op) == TYPE_DECL || TREE_CODE (op) == VAR_DECL) + && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op))) + switch (TREE_CODE (TREE_TYPE (op))) + { + case INTEGER_TYPE: + case ENUMERAL_TYPE: + case BOOLEAN_TYPE: + case REAL_TYPE: + { + tree type = TYPE_MAIN_VARIANT (TREE_TYPE (op)), t, val; + + val = TYPE_RM_MIN_VALUE (type); + if (val) + { + gimplify_one_sizepos (&val, pre_p); + for (t = type; t; t = TYPE_NEXT_VARIANT (t)) + SET_TYPE_RM_MIN_VALUE (t, val); + } + + val = TYPE_RM_MAX_VALUE (type); + if (val) + { + gimplify_one_sizepos (&val, pre_p); + for (t = type; t; t = TYPE_NEXT_VARIANT (t)) + SET_TYPE_RM_MAX_VALUE (t, val); + } + + } + break; + + default: + break; + } + + /* ... fall through ... */ + + default: + return GS_UNHANDLED; + } +} + +/* Generate GIMPLE in place for the statement at *STMT_P. */ + +static enum gimplify_status +gnat_gimplify_stmt (tree *stmt_p) +{ + tree stmt = *stmt_p; + + switch (TREE_CODE (stmt)) + { + case STMT_STMT: + *stmt_p = STMT_STMT_STMT (stmt); + return GS_OK; + + case LOOP_STMT: + { + tree gnu_start_label = create_artificial_label (input_location); + tree gnu_cond = LOOP_STMT_COND (stmt); + tree gnu_update = LOOP_STMT_UPDATE (stmt); + tree gnu_end_label = LOOP_STMT_LABEL (stmt); + tree t; + + /* Build the condition expression from the test, if any. */ + if (gnu_cond) + gnu_cond + = build3 (COND_EXPR, void_type_node, gnu_cond, alloc_stmt_list (), + build1 (GOTO_EXPR, void_type_node, gnu_end_label)); + + /* Set to emit the statements of the loop. */ + *stmt_p = NULL_TREE; + + /* We first emit the start label and then a conditional jump to the + end label if there's a top condition, then the update if it's at + the top, then the body of the loop, then a conditional jump to + the end label if there's a bottom condition, then the update if + it's at the bottom, and finally a jump to the start label and the + definition of the end label. */ + append_to_statement_list (build1 (LABEL_EXPR, void_type_node, + gnu_start_label), + stmt_p); + + if (gnu_cond && !LOOP_STMT_BOTTOM_COND_P (stmt)) + append_to_statement_list (gnu_cond, stmt_p); + + if (gnu_update && LOOP_STMT_TOP_UPDATE_P (stmt)) + append_to_statement_list (gnu_update, stmt_p); + + append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p); + + if (gnu_cond && LOOP_STMT_BOTTOM_COND_P (stmt)) + append_to_statement_list (gnu_cond, stmt_p); + + if (gnu_update && !LOOP_STMT_TOP_UPDATE_P (stmt)) + append_to_statement_list (gnu_update, stmt_p); + + t = build1 (GOTO_EXPR, void_type_node, gnu_start_label); + SET_EXPR_LOCATION (t, DECL_SOURCE_LOCATION (gnu_end_label)); + append_to_statement_list (t, stmt_p); + + append_to_statement_list (build1 (LABEL_EXPR, void_type_node, + gnu_end_label), + stmt_p); + return GS_OK; + } + + case EXIT_STMT: + /* Build a statement to jump to the corresponding end label, then + see if it needs to be conditional. */ + *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt)); + if (EXIT_STMT_COND (stmt)) + *stmt_p = build3 (COND_EXPR, void_type_node, + EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ()); + return GS_OK; + + default: + gcc_unreachable (); + } +} + +/* Force references to each of the entities in packages withed by GNAT_NODE. + Operate recursively but check that we aren't elaborating something more + than once. + + This routine is exclusively called in type_annotate mode, to compute DDA + information for types in withed units, for ASIS use. */ + +static void +elaborate_all_entities (Node_Id gnat_node) +{ + Entity_Id gnat_with_clause, gnat_entity; + + /* Process each unit only once. As we trace the context of all relevant + units transitively, including generic bodies, we may encounter the + same generic unit repeatedly. */ + if (!present_gnu_tree (gnat_node)) + save_gnu_tree (gnat_node, integer_zero_node, true); + + /* Save entities in all context units. A body may have an implicit_with + on its own spec, if the context includes a child unit, so don't save + the spec twice. */ + for (gnat_with_clause = First (Context_Items (gnat_node)); + Present (gnat_with_clause); + gnat_with_clause = Next (gnat_with_clause)) + if (Nkind (gnat_with_clause) == N_With_Clause + && !present_gnu_tree (Library_Unit (gnat_with_clause)) + && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit))) + { + elaborate_all_entities (Library_Unit (gnat_with_clause)); + + if (Ekind (Entity (Name (gnat_with_clause))) == E_Package) + { + for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause))); + Present (gnat_entity); + gnat_entity = Next_Entity (gnat_entity)) + if (Is_Public (gnat_entity) + && Convention (gnat_entity) != Convention_Intrinsic + && Ekind (gnat_entity) != E_Package + && Ekind (gnat_entity) != E_Package_Body + && Ekind (gnat_entity) != E_Operator + && !(IN (Ekind (gnat_entity), Type_Kind) + && !Is_Frozen (gnat_entity)) + && !((Ekind (gnat_entity) == E_Procedure + || Ekind (gnat_entity) == E_Function) + && Is_Intrinsic_Subprogram (gnat_entity)) + && !IN (Ekind (gnat_entity), Named_Kind) + && !IN (Ekind (gnat_entity), Generic_Unit_Kind)) + gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0); + } + else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package) + { + Node_Id gnat_body + = Corresponding_Body (Unit (Library_Unit (gnat_with_clause))); + + /* Retrieve compilation unit node of generic body. */ + while (Present (gnat_body) + && Nkind (gnat_body) != N_Compilation_Unit) + gnat_body = Parent (gnat_body); + + /* If body is available, elaborate its context. */ + if (Present (gnat_body)) + elaborate_all_entities (gnat_body); + } + } + + if (Nkind (Unit (gnat_node)) == N_Package_Body) + elaborate_all_entities (Library_Unit (gnat_node)); +} + +/* Do the processing of GNAT_NODE, an N_Freeze_Entity. */ + +static void +process_freeze_entity (Node_Id gnat_node) +{ + const Entity_Id gnat_entity = Entity (gnat_node); + const Entity_Kind kind = Ekind (gnat_entity); + tree gnu_old, gnu_new; + + /* If this is a package, we need to generate code for the package. */ + if (kind == E_Package) + { + insert_code_for + (Parent (Corresponding_Body + (Parent (Declaration_Node (gnat_entity))))); + return; + } + + /* Don't do anything for class-wide types as they are always transformed + into their root type. */ + if (kind == E_Class_Wide_Type) + return; + + /* Check for an old definition. This freeze node might be for an Itype. */ + gnu_old + = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : NULL_TREE; + + /* If this entity has an address representation clause, GNU_OLD is the + address, so discard it here. */ + if (Present (Address_Clause (gnat_entity))) + gnu_old = NULL_TREE; + + /* Don't do anything for subprograms that may have been elaborated before + their freeze nodes. This can happen, for example, because of an inner + call in an instance body or because of previous compilation of a spec + for inlining purposes. */ + if (gnu_old + && ((TREE_CODE (gnu_old) == FUNCTION_DECL + && (kind == E_Function || kind == E_Procedure)) + || (TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE + && kind == E_Subprogram_Type))) + return; + + /* If we have a non-dummy type old tree, we have nothing to do, except + aborting if this is the public view of a private type whose full view was + not delayed, as this node was never delayed as it should have been. We + let this happen for concurrent types and their Corresponding_Record_Type, + however, because each might legitimately be elaborated before its own + freeze node, e.g. while processing the other. */ + if (gnu_old + && !(TREE_CODE (gnu_old) == TYPE_DECL + && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)))) + { + gcc_assert ((IN (kind, Incomplete_Or_Private_Kind) + && Present (Full_View (gnat_entity)) + && No (Freeze_Node (Full_View (gnat_entity)))) + || Is_Concurrent_Type (gnat_entity) + || (IN (kind, Record_Kind) + && Is_Concurrent_Record_Type (gnat_entity))); + return; + } + + /* Reset the saved tree, if any, and elaborate the object or type for real. + If there is a full view, elaborate it and use the result. And, if this + is the root type of a class-wide type, reuse it for the latter. */ + if (gnu_old) + { + save_gnu_tree (gnat_entity, NULL_TREE, false); + if (IN (kind, Incomplete_Or_Private_Kind) + && Present (Full_View (gnat_entity)) + && present_gnu_tree (Full_View (gnat_entity))) + save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false); + if (IN (kind, Type_Kind) + && Present (Class_Wide_Type (gnat_entity)) + && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity) + save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false); + } + + if (IN (kind, Incomplete_Or_Private_Kind) + && Present (Full_View (gnat_entity))) + { + gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1); + + /* Propagate back-annotations from full view to partial view. */ + if (Unknown_Alignment (gnat_entity)) + Set_Alignment (gnat_entity, Alignment (Full_View (gnat_entity))); + + if (Unknown_Esize (gnat_entity)) + Set_Esize (gnat_entity, Esize (Full_View (gnat_entity))); + + if (Unknown_RM_Size (gnat_entity)) + Set_RM_Size (gnat_entity, RM_Size (Full_View (gnat_entity))); + + /* The above call may have defined this entity (the simplest example + of this is when we have a private enumeral type since the bounds + will have the public view). */ + if (!present_gnu_tree (gnat_entity)) + save_gnu_tree (gnat_entity, gnu_new, false); + } + else + { + tree gnu_init + = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration + && present_gnu_tree (Declaration_Node (gnat_entity))) + ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE; + + gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1); + } + + if (IN (kind, Type_Kind) + && Present (Class_Wide_Type (gnat_entity)) + && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity) + save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false); + + /* If we've made any pointers to the old version of this type, we + have to update them. */ + if (gnu_old) + update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)), + TREE_TYPE (gnu_new)); +} + +/* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present. + We make two passes, one to elaborate anything other than bodies (but + we declare a function if there was no spec). The second pass + elaborates the bodies. + + GNAT_END_LIST gives the element in the list past the end. Normally, + this is Empty, but can be First_Real_Statement for a + Handled_Sequence_Of_Statements. + + We make a complete pass through both lists if PASS1P is true, then make + the second pass over both lists if PASS2P is true. The lists usually + correspond to the public and private parts of a package. */ + +static void +process_decls (List_Id gnat_decls, List_Id gnat_decls2, + Node_Id gnat_end_list, bool pass1p, bool pass2p) +{ + List_Id gnat_decl_array[2]; + Node_Id gnat_decl; + int i; + + gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2; + + if (pass1p) + for (i = 0; i <= 1; i++) + if (Present (gnat_decl_array[i])) + for (gnat_decl = First (gnat_decl_array[i]); + gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl)) + { + /* For package specs, we recurse inside the declarations, + thus taking the two pass approach inside the boundary. */ + if (Nkind (gnat_decl) == N_Package_Declaration + && (Nkind (Specification (gnat_decl) + == N_Package_Specification))) + process_decls (Visible_Declarations (Specification (gnat_decl)), + Private_Declarations (Specification (gnat_decl)), + Empty, true, false); + + /* Similarly for any declarations in the actions of a + freeze node. */ + else if (Nkind (gnat_decl) == N_Freeze_Entity) + { + process_freeze_entity (gnat_decl); + process_decls (Actions (gnat_decl), Empty, Empty, true, false); + } + + /* Package bodies with freeze nodes get their elaboration deferred + until the freeze node, but the code must be placed in the right + place, so record the code position now. */ + else if (Nkind (gnat_decl) == N_Package_Body + && Present (Freeze_Node (Corresponding_Spec (gnat_decl)))) + record_code_position (gnat_decl); + + else if (Nkind (gnat_decl) == N_Package_Body_Stub + && Present (Library_Unit (gnat_decl)) + && Present (Freeze_Node + (Corresponding_Spec + (Proper_Body (Unit + (Library_Unit (gnat_decl))))))) + record_code_position + (Proper_Body (Unit (Library_Unit (gnat_decl)))); + + /* We defer most subprogram bodies to the second pass. */ + else if (Nkind (gnat_decl) == N_Subprogram_Body) + { + if (Acts_As_Spec (gnat_decl)) + { + Node_Id gnat_subprog_id = Defining_Entity (gnat_decl); + + if (Ekind (gnat_subprog_id) != E_Generic_Procedure + && Ekind (gnat_subprog_id) != E_Generic_Function) + gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1); + } + } + + /* For bodies and stubs that act as their own specs, the entity + itself must be elaborated in the first pass, because it may + be used in other declarations. */ + else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub) + { + Node_Id gnat_subprog_id + = Defining_Entity (Specification (gnat_decl)); + + if (Ekind (gnat_subprog_id) != E_Subprogram_Body + && Ekind (gnat_subprog_id) != E_Generic_Procedure + && Ekind (gnat_subprog_id) != E_Generic_Function) + gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1); + } + + /* Concurrent stubs stand for the corresponding subprogram bodies, + which are deferred like other bodies. */ + else if (Nkind (gnat_decl) == N_Task_Body_Stub + || Nkind (gnat_decl) == N_Protected_Body_Stub) + ; + + else + add_stmt (gnat_to_gnu (gnat_decl)); + } + + /* Here we elaborate everything we deferred above except for package bodies, + which are elaborated at their freeze nodes. Note that we must also + go inside things (package specs and freeze nodes) the first pass did. */ + if (pass2p) + for (i = 0; i <= 1; i++) + if (Present (gnat_decl_array[i])) + for (gnat_decl = First (gnat_decl_array[i]); + gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl)) + { + if (Nkind (gnat_decl) == N_Subprogram_Body + || Nkind (gnat_decl) == N_Subprogram_Body_Stub + || Nkind (gnat_decl) == N_Task_Body_Stub + || Nkind (gnat_decl) == N_Protected_Body_Stub) + add_stmt (gnat_to_gnu (gnat_decl)); + + else if (Nkind (gnat_decl) == N_Package_Declaration + && (Nkind (Specification (gnat_decl) + == N_Package_Specification))) + process_decls (Visible_Declarations (Specification (gnat_decl)), + Private_Declarations (Specification (gnat_decl)), + Empty, false, true); + + else if (Nkind (gnat_decl) == N_Freeze_Entity) + process_decls (Actions (gnat_decl), Empty, Empty, false, true); + } +} + +/* Make a unary operation of kind CODE using build_unary_op, but guard + the operation by an overflow check. CODE can be one of NEGATE_EXPR + or ABS_EXPR. GNU_TYPE is the type desired for the result. Usually + the operation is to be performed in that type. GNAT_NODE is the gnat + node conveying the source location for which the error should be + signaled. */ + +static tree +build_unary_op_trapv (enum tree_code code, tree gnu_type, tree operand, + Node_Id gnat_node) +{ + gcc_assert (code == NEGATE_EXPR || code == ABS_EXPR); + + operand = gnat_protect_expr (operand); + + return emit_check (build_binary_op (EQ_EXPR, boolean_type_node, + operand, TYPE_MIN_VALUE (gnu_type)), + build_unary_op (code, gnu_type, operand), + CE_Overflow_Check_Failed, gnat_node); +} + +/* Make a binary operation of kind CODE using build_binary_op, but guard + the operation by an overflow check. CODE can be one of PLUS_EXPR, + MINUS_EXPR or MULT_EXPR. GNU_TYPE is the type desired for the result. + Usually the operation is to be performed in that type. GNAT_NODE is + the GNAT node conveying the source location for which the error should + be signaled. */ + +static tree +build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left, + tree right, Node_Id gnat_node) +{ + tree lhs = gnat_protect_expr (left); + tree rhs = gnat_protect_expr (right); + tree type_max = TYPE_MAX_VALUE (gnu_type); + tree type_min = TYPE_MIN_VALUE (gnu_type); + tree gnu_expr; + tree tmp1, tmp2; + tree zero = convert (gnu_type, integer_zero_node); + tree rhs_lt_zero; + tree check_pos; + tree check_neg; + tree check; + int precision = TYPE_PRECISION (gnu_type); + + gcc_assert (!(precision & (precision - 1))); /* ensure power of 2 */ + + /* Prefer a constant or known-positive rhs to simplify checks. */ + if (!TREE_CONSTANT (rhs) + && commutative_tree_code (code) + && (TREE_CONSTANT (lhs) || (!tree_expr_nonnegative_p (rhs) + && tree_expr_nonnegative_p (lhs)))) + { + tree tmp = lhs; + lhs = rhs; + rhs = tmp; + } + + rhs_lt_zero = tree_expr_nonnegative_p (rhs) + ? boolean_false_node + : build_binary_op (LT_EXPR, boolean_type_node, rhs, zero); + + /* ??? Should use more efficient check for operand_equal_p (lhs, rhs, 0) */ + + /* Try a few strategies that may be cheaper than the general + code at the end of the function, if the rhs is not known. + The strategies are: + - Call library function for 64-bit multiplication (complex) + - Widen, if input arguments are sufficiently small + - Determine overflow using wrapped result for addition/subtraction. */ + + if (!TREE_CONSTANT (rhs)) + { + /* Even for add/subtract double size to get another base type. */ + int needed_precision = precision * 2; + + if (code == MULT_EXPR && precision == 64) + { + tree int_64 = gnat_type_for_size (64, 0); + + return convert (gnu_type, build_call_2_expr (mulv64_decl, + convert (int_64, lhs), + convert (int_64, rhs))); + } + + else if (needed_precision <= BITS_PER_WORD + || (code == MULT_EXPR + && needed_precision <= LONG_LONG_TYPE_SIZE)) + { + tree wide_type = gnat_type_for_size (needed_precision, 0); + + tree wide_result = build_binary_op (code, wide_type, + convert (wide_type, lhs), + convert (wide_type, rhs)); + + tree check = build_binary_op + (TRUTH_ORIF_EXPR, boolean_type_node, + build_binary_op (LT_EXPR, boolean_type_node, wide_result, + convert (wide_type, type_min)), + build_binary_op (GT_EXPR, boolean_type_node, wide_result, + convert (wide_type, type_max))); + + tree result = convert (gnu_type, wide_result); + + return + emit_check (check, result, CE_Overflow_Check_Failed, gnat_node); + } + + else if (code == PLUS_EXPR || code == MINUS_EXPR) + { + tree unsigned_type = gnat_type_for_size (precision, 1); + tree wrapped_expr = convert + (gnu_type, build_binary_op (code, unsigned_type, + convert (unsigned_type, lhs), + convert (unsigned_type, rhs))); + + tree result = convert + (gnu_type, build_binary_op (code, gnu_type, lhs, rhs)); + + /* Overflow when (rhs < 0) ^ (wrapped_expr < lhs)), for addition + or when (rhs < 0) ^ (wrapped_expr > lhs) for subtraction. */ + tree check = build_binary_op + (TRUTH_XOR_EXPR, boolean_type_node, rhs_lt_zero, + build_binary_op (code == PLUS_EXPR ? LT_EXPR : GT_EXPR, + boolean_type_node, wrapped_expr, lhs)); + + return + emit_check (check, result, CE_Overflow_Check_Failed, gnat_node); + } + } + + switch (code) + { + case PLUS_EXPR: + /* When rhs >= 0, overflow when lhs > type_max - rhs. */ + check_pos = build_binary_op (GT_EXPR, boolean_type_node, lhs, + build_binary_op (MINUS_EXPR, gnu_type, + type_max, rhs)), + + /* When rhs < 0, overflow when lhs < type_min - rhs. */ + check_neg = build_binary_op (LT_EXPR, boolean_type_node, lhs, + build_binary_op (MINUS_EXPR, gnu_type, + type_min, rhs)); + break; + + case MINUS_EXPR: + /* When rhs >= 0, overflow when lhs < type_min + rhs. */ + check_pos = build_binary_op (LT_EXPR, boolean_type_node, lhs, + build_binary_op (PLUS_EXPR, gnu_type, + type_min, rhs)), + + /* When rhs < 0, overflow when lhs > type_max + rhs. */ + check_neg = build_binary_op (GT_EXPR, boolean_type_node, lhs, + build_binary_op (PLUS_EXPR, gnu_type, + type_max, rhs)); + break; + + case MULT_EXPR: + /* The check here is designed to be efficient if the rhs is constant, + but it will work for any rhs by using integer division. + Four different check expressions determine whether X * C overflows, + depending on C. + C == 0 => false + C > 0 => X > type_max / C || X < type_min / C + C == -1 => X == type_min + C < -1 => X > type_min / C || X < type_max / C */ + + tmp1 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs); + tmp2 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs); + + check_pos + = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node, + build_binary_op (NE_EXPR, boolean_type_node, zero, + rhs), + build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, + build_binary_op (GT_EXPR, + boolean_type_node, + lhs, tmp1), + build_binary_op (LT_EXPR, + boolean_type_node, + lhs, tmp2))); + + check_neg + = fold_build3 (COND_EXPR, boolean_type_node, + build_binary_op (EQ_EXPR, boolean_type_node, rhs, + build_int_cst (gnu_type, -1)), + build_binary_op (EQ_EXPR, boolean_type_node, lhs, + type_min), + build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, + build_binary_op (GT_EXPR, + boolean_type_node, + lhs, tmp2), + build_binary_op (LT_EXPR, + boolean_type_node, + lhs, tmp1))); + break; + + default: + gcc_unreachable(); + } + + gnu_expr = build_binary_op (code, gnu_type, lhs, rhs); + + /* If we can fold the expression to a constant, just return it. + The caller will deal with overflow, no need to generate a check. */ + if (TREE_CONSTANT (gnu_expr)) + return gnu_expr; + + check = fold_build3 (COND_EXPR, boolean_type_node, rhs_lt_zero, check_neg, + check_pos); + + return emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node); +} + +/* Emit code for a range check. GNU_EXPR is the expression to be checked, + GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against + which we have to check. GNAT_NODE is the GNAT node conveying the source + location for which the error should be signaled. */ + +static tree +emit_range_check (tree gnu_expr, Entity_Id gnat_range_type, Node_Id gnat_node) +{ + tree gnu_range_type = get_unpadded_type (gnat_range_type); + tree gnu_low = TYPE_MIN_VALUE (gnu_range_type); + tree gnu_high = TYPE_MAX_VALUE (gnu_range_type); + tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr)); + + /* If GNU_EXPR has GNAT_RANGE_TYPE as its base type, no check is needed. + This can for example happen when translating 'Val or 'Value. */ + if (gnu_compare_type == gnu_range_type) + return gnu_expr; + + /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE, + we can't do anything since we might be truncating the bounds. No + check is needed in this case. */ + if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr)) + && (TYPE_PRECISION (gnu_compare_type) + < TYPE_PRECISION (get_base_type (gnu_range_type)))) + return gnu_expr; + + /* Checked expressions must be evaluated only once. */ + gnu_expr = gnat_protect_expr (gnu_expr); + + /* Note that the form of the check is + (not (expr >= lo)) or (not (expr <= hi)) + the reason for this slightly convoluted form is that NaNs + are not considered to be in range in the float case. */ + return emit_check + (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, + invert_truthvalue + (build_binary_op (GE_EXPR, boolean_type_node, + convert (gnu_compare_type, gnu_expr), + convert (gnu_compare_type, gnu_low))), + invert_truthvalue + (build_binary_op (LE_EXPR, boolean_type_node, + convert (gnu_compare_type, gnu_expr), + convert (gnu_compare_type, + gnu_high)))), + gnu_expr, CE_Range_Check_Failed, gnat_node); +} + +/* Emit code for an index check. GNU_ARRAY_OBJECT is the array object which + we are about to index, GNU_EXPR is the index expression to be checked, + GNU_LOW and GNU_HIGH are the lower and upper bounds against which GNU_EXPR + has to be checked. Note that for index checking we cannot simply use the + emit_range_check function (although very similar code needs to be generated + in both cases) since for index checking the array type against which we are + checking the indices may be unconstrained and consequently we need to get + the actual index bounds from the array object itself (GNU_ARRAY_OBJECT). + The place where we need to do that is in subprograms having unconstrained + array formal parameters. GNAT_NODE is the GNAT node conveying the source + location for which the error should be signaled. */ + +static tree +emit_index_check (tree gnu_array_object, tree gnu_expr, tree gnu_low, + tree gnu_high, Node_Id gnat_node) +{ + tree gnu_expr_check; + + /* Checked expressions must be evaluated only once. */ + gnu_expr = gnat_protect_expr (gnu_expr); + + /* Must do this computation in the base type in case the expression's + type is an unsigned subtypes. */ + gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr); + + /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by + the object we are handling. */ + gnu_low = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low, gnu_array_object); + gnu_high = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high, gnu_array_object); + + return emit_check + (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, + build_binary_op (LT_EXPR, boolean_type_node, + gnu_expr_check, + convert (TREE_TYPE (gnu_expr_check), + gnu_low)), + build_binary_op (GT_EXPR, boolean_type_node, + gnu_expr_check, + convert (TREE_TYPE (gnu_expr_check), + gnu_high))), + gnu_expr, CE_Index_Check_Failed, gnat_node); +} + +/* GNU_COND contains the condition corresponding to an access, discriminant or + range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR if + GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true. + REASON is the code that says why the exception was raised. GNAT_NODE is + the GNAT node conveying the source location for which the error should be + signaled. */ + +static tree +emit_check (tree gnu_cond, tree gnu_expr, int reason, Node_Id gnat_node) +{ + tree gnu_call + = build_call_raise (reason, gnat_node, N_Raise_Constraint_Error); + tree gnu_result + = fold_build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond, + build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_call, + convert (TREE_TYPE (gnu_expr), integer_zero_node)), + gnu_expr); + + /* GNU_RESULT has side effects if and only if GNU_EXPR has: + we don't need to evaluate it just for the check. */ + TREE_SIDE_EFFECTS (gnu_result) = TREE_SIDE_EFFECTS (gnu_expr); + + return gnu_result; +} + +/* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow + checks if OVERFLOW_P is true and range checks if RANGE_P is true. + GNAT_TYPE is known to be an integral type. If TRUNCATE_P true, do a + float to integer conversion with truncation; otherwise round. + GNAT_NODE is the GNAT node conveying the source location for which the + error should be signaled. */ + +static tree +convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp, + bool rangep, bool truncatep, Node_Id gnat_node) +{ + tree gnu_type = get_unpadded_type (gnat_type); + tree gnu_in_type = TREE_TYPE (gnu_expr); + tree gnu_in_basetype = get_base_type (gnu_in_type); + tree gnu_base_type = get_base_type (gnu_type); + tree gnu_result = gnu_expr; + + /* If we are not doing any checks, the output is an integral type, and + the input is not a floating type, just do the conversion. This + shortcut is required to avoid problems with packed array types + and simplifies code in all cases anyway. */ + if (!rangep && !overflowp && INTEGRAL_TYPE_P (gnu_base_type) + && !FLOAT_TYPE_P (gnu_in_type)) + return convert (gnu_type, gnu_expr); + + /* First convert the expression to its base type. This + will never generate code, but makes the tests below much simpler. + But don't do this if converting from an integer type to an unconstrained + array type since then we need to get the bounds from the original + (unpacked) type. */ + if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE) + gnu_result = convert (gnu_in_basetype, gnu_result); + + /* If overflow checks are requested, we need to be sure the result will + fit in the output base type. But don't do this if the input + is integer and the output floating-point. */ + if (overflowp + && !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype))) + { + /* Ensure GNU_EXPR only gets evaluated once. */ + tree gnu_input = gnat_protect_expr (gnu_result); + tree gnu_cond = integer_zero_node; + tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype); + tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype); + tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type); + tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type); + + /* Convert the lower bounds to signed types, so we're sure we're + comparing them properly. Likewise, convert the upper bounds + to unsigned types. */ + if (INTEGRAL_TYPE_P (gnu_in_basetype) && TYPE_UNSIGNED (gnu_in_basetype)) + gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb); + + if (INTEGRAL_TYPE_P (gnu_in_basetype) + && !TYPE_UNSIGNED (gnu_in_basetype)) + gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub); + + if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type)) + gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb); + + if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type)) + gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub); + + /* Check each bound separately and only if the result bound + is tighter than the bound on the input type. Note that all the + types are base types, so the bounds must be constant. Also, + the comparison is done in the base type of the input, which + always has the proper signedness. First check for input + integer (which means output integer), output float (which means + both float), or mixed, in which case we always compare. + Note that we have to do the comparison which would *fail* in the + case of an error since if it's an FP comparison and one of the + values is a NaN or Inf, the comparison will fail. */ + if (INTEGRAL_TYPE_P (gnu_in_basetype) + ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb) + : (FLOAT_TYPE_P (gnu_base_type) + ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb), + TREE_REAL_CST (gnu_out_lb)) + : 1)) + gnu_cond + = invert_truthvalue + (build_binary_op (GE_EXPR, boolean_type_node, + gnu_input, convert (gnu_in_basetype, + gnu_out_lb))); + + if (INTEGRAL_TYPE_P (gnu_in_basetype) + ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub) + : (FLOAT_TYPE_P (gnu_base_type) + ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub), + TREE_REAL_CST (gnu_in_lb)) + : 1)) + gnu_cond + = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, gnu_cond, + invert_truthvalue + (build_binary_op (LE_EXPR, boolean_type_node, + gnu_input, + convert (gnu_in_basetype, + gnu_out_ub)))); + + if (!integer_zerop (gnu_cond)) + gnu_result = emit_check (gnu_cond, gnu_input, + CE_Overflow_Check_Failed, gnat_node); + } + + /* Now convert to the result base type. If this is a non-truncating + float-to-integer conversion, round. */ + if (INTEGRAL_TYPE_P (gnu_base_type) && FLOAT_TYPE_P (gnu_in_basetype) + && !truncatep) + { + REAL_VALUE_TYPE half_minus_pred_half, pred_half; + tree gnu_conv, gnu_zero, gnu_comp, calc_type; + tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half; + const struct real_format *fmt; + + /* The following calculations depend on proper rounding to even + of each arithmetic operation. In order to prevent excess + precision from spoiling this property, use the widest hardware + floating-point type if FP_ARITH_MAY_WIDEN is true. */ + calc_type + = FP_ARITH_MAY_WIDEN ? longest_float_type_node : gnu_in_basetype; + + /* FIXME: Should not have padding in the first place. */ + if (TYPE_IS_PADDING_P (calc_type)) + calc_type = TREE_TYPE (TYPE_FIELDS (calc_type)); + + /* Compute the exact value calc_type'Pred (0.5) at compile time. */ + fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type)); + real_2expN (&half_minus_pred_half, -(fmt->p) - 1, TYPE_MODE (calc_type)); + REAL_ARITHMETIC (pred_half, MINUS_EXPR, dconsthalf, + half_minus_pred_half); + gnu_pred_half = build_real (calc_type, pred_half); + + /* If the input is strictly negative, subtract this value + and otherwise add it from the input. For 0.5, the result + is exactly between 1.0 and the machine number preceding 1.0 + (for calc_type). Since the last bit of 1.0 is even, this 0.5 + will round to 1.0, while all other number with an absolute + value less than 0.5 round to 0.0. For larger numbers exactly + halfway between integers, rounding will always be correct as + the true mathematical result will be closer to the higher + integer compared to the lower one. So, this constant works + for all floating-point numbers. + + The reason to use the same constant with subtract/add instead + of a positive and negative constant is to allow the comparison + to be scheduled in parallel with retrieval of the constant and + conversion of the input to the calc_type (if necessary). */ + + gnu_zero = convert (gnu_in_basetype, integer_zero_node); + gnu_result = gnat_protect_expr (gnu_result); + gnu_conv = convert (calc_type, gnu_result); + gnu_comp + = fold_build2 (GE_EXPR, boolean_type_node, gnu_result, gnu_zero); + gnu_add_pred_half + = fold_build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half); + gnu_subtract_pred_half + = fold_build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half); + gnu_result = fold_build3 (COND_EXPR, calc_type, gnu_comp, + gnu_add_pred_half, gnu_subtract_pred_half); + } + + if (TREE_CODE (gnu_base_type) == INTEGER_TYPE + && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type) + && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF) + gnu_result = unchecked_convert (gnu_base_type, gnu_result, false); + else + gnu_result = convert (gnu_base_type, gnu_result); + + /* Finally, do the range check if requested. Note that if the result type + is a modular type, the range check is actually an overflow check. */ + if (rangep + || (TREE_CODE (gnu_base_type) == INTEGER_TYPE + && TYPE_MODULAR_P (gnu_base_type) && overflowp)) + gnu_result = emit_range_check (gnu_result, gnat_type, gnat_node); + + return convert (gnu_type, gnu_result); +} + +/* Return true if TYPE is a smaller form of ORIG_TYPE. */ + +static bool +smaller_form_type_p (tree type, tree orig_type) +{ + tree size, osize; + + /* We're not interested in variants here. */ + if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (orig_type)) + return false; + + /* Like a variant, a packable version keeps the original TYPE_NAME. */ + if (TYPE_NAME (type) != TYPE_NAME (orig_type)) + return false; + + size = TYPE_SIZE (type); + osize = TYPE_SIZE (orig_type); + + if (!(TREE_CODE (size) == INTEGER_CST && TREE_CODE (osize) == INTEGER_CST)) + return false; + + return tree_int_cst_lt (size, osize) != 0; +} + +/* Return true if GNU_EXPR can be directly addressed. This is the case + unless it is an expression involving computation or if it involves a + reference to a bitfield or to an object not sufficiently aligned for + its type. If GNU_TYPE is non-null, return true only if GNU_EXPR can + be directly addressed as an object of this type. + + *** Notes on addressability issues in the Ada compiler *** + + This predicate is necessary in order to bridge the gap between Gigi + and the middle-end about addressability of GENERIC trees. A tree + is said to be addressable if it can be directly addressed, i.e. if + its address can be taken, is a multiple of the type's alignment on + strict-alignment architectures and returns the first storage unit + assigned to the object represented by the tree. + + In the C family of languages, everything is in practice addressable + at the language level, except for bit-fields. This means that these + compilers will take the address of any tree that doesn't represent + a bit-field reference and expect the result to be the first storage + unit assigned to the object. Even in cases where this will result + in unaligned accesses at run time, nothing is supposed to be done + and the program is considered as erroneous instead (see PR c/18287). + + The implicit assumptions made in the middle-end are in keeping with + the C viewpoint described above: + - the address of a bit-field reference is supposed to be never + taken; the compiler (generally) will stop on such a construct, + - any other tree is addressable if it is formally addressable, + i.e. if it is formally allowed to be the operand of ADDR_EXPR. + + In Ada, the viewpoint is the opposite one: nothing is addressable + at the language level unless explicitly declared so. This means + that the compiler will both make sure that the trees representing + references to addressable ("aliased" in Ada parlance) objects are + addressable and make no real attempts at ensuring that the trees + representing references to non-addressable objects are addressable. + + In the first case, Ada is effectively equivalent to C and handing + down the direct result of applying ADDR_EXPR to these trees to the + middle-end works flawlessly. In the second case, Ada cannot afford + to consider the program as erroneous if the address of trees that + are not addressable is requested for technical reasons, unlike C; + as a consequence, the Ada compiler must arrange for either making + sure that this address is not requested in the middle-end or for + compensating by inserting temporaries if it is requested in Gigi. + + The first goal can be achieved because the middle-end should not + request the address of non-addressable trees on its own; the only + exception is for the invocation of low-level block operations like + memcpy, for which the addressability requirements are lower since + the type's alignment can be disregarded. In practice, this means + that Gigi must make sure that such operations cannot be applied to + non-BLKmode bit-fields. + + The second goal is achieved by means of the addressable_p predicate, + which computes whether a temporary must be inserted by Gigi when the + address of a tree is requested; if so, the address of the temporary + will be used in lieu of that of the original tree and some glue code + generated to connect everything together. */ + +static bool +addressable_p (tree gnu_expr, tree gnu_type) +{ + /* For an integral type, the size of the actual type of the object may not + be greater than that of the expected type, otherwise an indirect access + in the latter type wouldn't correctly set all the bits of the object. */ + if (gnu_type + && INTEGRAL_TYPE_P (gnu_type) + && smaller_form_type_p (gnu_type, TREE_TYPE (gnu_expr))) + return false; + + /* The size of the actual type of the object may not be smaller than that + of the expected type, otherwise an indirect access in the latter type + would be larger than the object. But only record types need to be + considered in practice for this case. */ + if (gnu_type + && TREE_CODE (gnu_type) == RECORD_TYPE + && smaller_form_type_p (TREE_TYPE (gnu_expr), gnu_type)) + return false; + + switch (TREE_CODE (gnu_expr)) + { + case VAR_DECL: + case PARM_DECL: + case FUNCTION_DECL: + case RESULT_DECL: + /* All DECLs are addressable: if they are in a register, we can force + them to memory. */ + return true; + + case UNCONSTRAINED_ARRAY_REF: + case INDIRECT_REF: + /* Taking the address of a dereference yields the original pointer. */ + return true; + + case STRING_CST: + case INTEGER_CST: + /* Taking the address yields a pointer to the constant pool. */ + return true; + + case CONSTRUCTOR: + /* Taking the address of a static constructor yields a pointer to the + tree constant pool. */ + return TREE_STATIC (gnu_expr) ? true : false; + + case NULL_EXPR: + case SAVE_EXPR: + case CALL_EXPR: + case PLUS_EXPR: + case MINUS_EXPR: + case BIT_IOR_EXPR: + case BIT_XOR_EXPR: + case BIT_AND_EXPR: + case BIT_NOT_EXPR: + /* All rvalues are deemed addressable since taking their address will + force a temporary to be created by the middle-end. */ + return true; + + case COMPOUND_EXPR: + /* The address of a compound expression is that of its 2nd operand. */ + return addressable_p (TREE_OPERAND (gnu_expr, 1), gnu_type); + + case COND_EXPR: + /* We accept &COND_EXPR as soon as both operands are addressable and + expect the outcome to be the address of the selected operand. */ + return (addressable_p (TREE_OPERAND (gnu_expr, 1), NULL_TREE) + && addressable_p (TREE_OPERAND (gnu_expr, 2), NULL_TREE)); + + case COMPONENT_REF: + return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1)) + /* Even with DECL_BIT_FIELD cleared, we have to ensure that + the field is sufficiently aligned, in case it is subject + to a pragma Component_Alignment. But we don't need to + check the alignment of the containing record, as it is + guaranteed to be not smaller than that of its most + aligned field that is not a bit-field. */ + && (!STRICT_ALIGNMENT + || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1)) + >= TYPE_ALIGN (TREE_TYPE (gnu_expr)))) + /* The field of a padding record is always addressable. */ + || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))) + && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE)); + + case ARRAY_REF: case ARRAY_RANGE_REF: + case REALPART_EXPR: case IMAGPART_EXPR: + case NOP_EXPR: + return addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE); + + case CONVERT_EXPR: + return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr)) + && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE)); + + case VIEW_CONVERT_EXPR: + { + /* This is addressable if we can avoid a copy. */ + tree type = TREE_TYPE (gnu_expr); + tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0)); + return (((TYPE_MODE (type) == TYPE_MODE (inner_type) + && (!STRICT_ALIGNMENT + || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type) + || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT)) + || ((TYPE_MODE (type) == BLKmode + || TYPE_MODE (inner_type) == BLKmode) + && (!STRICT_ALIGNMENT + || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type) + || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT + || TYPE_ALIGN_OK (type) + || TYPE_ALIGN_OK (inner_type)))) + && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE)); + } + + default: + return false; + } +} + +/* Do the processing for the declaration of a GNAT_ENTITY, a type. If + a separate Freeze node exists, delay the bulk of the processing. Otherwise + make a GCC type for GNAT_ENTITY and set up the correspondence. */ + +void +process_type (Entity_Id gnat_entity) +{ + tree gnu_old + = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0; + tree gnu_new; + + /* If we are to delay elaboration of this type, just do any + elaborations needed for expressions within the declaration and + make a dummy type entry for this node and its Full_View (if + any) in case something points to it. Don't do this if it + has already been done (the only way that can happen is if + the private completion is also delayed). */ + if (Present (Freeze_Node (gnat_entity)) + || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind) + && Present (Full_View (gnat_entity)) + && Freeze_Node (Full_View (gnat_entity)) + && !present_gnu_tree (Full_View (gnat_entity)))) + { + elaborate_entity (gnat_entity); + + if (!gnu_old) + { + tree gnu_decl = TYPE_STUB_DECL (make_dummy_type (gnat_entity)); + save_gnu_tree (gnat_entity, gnu_decl, false); + if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind) + && Present (Full_View (gnat_entity))) + save_gnu_tree (Full_View (gnat_entity), gnu_decl, false); + } + + return; + } + + /* If we saved away a dummy type for this node it means that this + made the type that corresponds to the full type of an incomplete + type. Clear that type for now and then update the type in the + pointers. */ + if (gnu_old) + { + gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL + && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))); + + save_gnu_tree (gnat_entity, NULL_TREE, false); + } + + /* Now fully elaborate the type. */ + gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1); + gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL); + + /* If we have an old type and we've made pointers to this type, + update those pointers. */ + if (gnu_old) + update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)), + TREE_TYPE (gnu_new)); + + /* If this is a record type corresponding to a task or protected type + that is a completion of an incomplete type, perform a similar update + on the type. ??? Including protected types here is a guess. */ + if (IN (Ekind (gnat_entity), Record_Kind) + && Is_Concurrent_Record_Type (gnat_entity) + && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity))) + { + tree gnu_task_old + = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)); + + save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity), + NULL_TREE, false); + save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity), + gnu_new, false); + + update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)), + TREE_TYPE (gnu_new)); + } +} + +/* GNAT_ENTITY is the type of the resulting constructors, + GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate, + and GNU_TYPE is the GCC type of the corresponding record. + + Return a CONSTRUCTOR to build the record. */ + +static tree +assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type) +{ + tree gnu_list, gnu_result; + + /* We test for GNU_FIELD being empty in the case where a variant + was the last thing since we don't take things off GNAT_ASSOC in + that case. We check GNAT_ASSOC in case we have a variant, but it + has no fields. */ + + for (gnu_list = NULL_TREE; Present (gnat_assoc); + gnat_assoc = Next (gnat_assoc)) + { + Node_Id gnat_field = First (Choices (gnat_assoc)); + tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field)); + tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc)); + + /* The expander is supposed to put a single component selector name + in every record component association. */ + gcc_assert (No (Next (gnat_field))); + + /* Ignore fields that have Corresponding_Discriminants since we'll + be setting that field in the parent. */ + if (Present (Corresponding_Discriminant (Entity (gnat_field))) + && Is_Tagged_Type (Scope (Entity (gnat_field)))) + continue; + + /* Also ignore discriminants of Unchecked_Unions. */ + else if (Is_Unchecked_Union (gnat_entity) + && Ekind (Entity (gnat_field)) == E_Discriminant) + continue; + + /* Before assigning a value in an aggregate make sure range checks + are done if required. Then convert to the type of the field. */ + if (Do_Range_Check (Expression (gnat_assoc))) + gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field), Empty); + + gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr); + + /* Add the field and expression to the list. */ + gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list); + } + + gnu_result = extract_values (gnu_list, gnu_type); + +#ifdef ENABLE_CHECKING + { + tree gnu_field; + + /* Verify every entry in GNU_LIST was used. */ + for (gnu_field = gnu_list; gnu_field; gnu_field = TREE_CHAIN (gnu_field)) + gcc_assert (TREE_ADDRESSABLE (gnu_field)); + } +#endif + + return gnu_result; +} + +/* Build a possibly nested constructor for array aggregates. GNAT_EXPR is + the first element of an array aggregate. It may itself be an aggregate. + GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate. + GNAT_COMPONENT_TYPE is the type of the array component; it is needed + for range checking. */ + +static tree +pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type, + Entity_Id gnat_component_type) +{ + tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type)); + tree gnu_expr; + VEC(constructor_elt,gc) *gnu_expr_vec = NULL; + + for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr)) + { + /* If the expression is itself an array aggregate then first build the + innermost constructor if it is part of our array (multi-dimensional + case). */ + if (Nkind (gnat_expr) == N_Aggregate + && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type))) + gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)), + TREE_TYPE (gnu_array_type), + gnat_component_type); + else + { + gnu_expr = gnat_to_gnu (gnat_expr); + + /* Before assigning the element to the array, make sure it is + in range. */ + if (Do_Range_Check (gnat_expr)) + gnu_expr = emit_range_check (gnu_expr, gnat_component_type, Empty); + } + + CONSTRUCTOR_APPEND_ELT (gnu_expr_vec, gnu_index, + convert (TREE_TYPE (gnu_array_type), gnu_expr)); + + gnu_index = int_const_binop (PLUS_EXPR, gnu_index, integer_one_node, 0); + } + + return gnat_build_constructor (gnu_array_type, gnu_expr_vec); +} + +/* Subroutine of assoc_to_constructor: VALUES is a list of field associations, + some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting + of the associations that are from RECORD_TYPE. If we see an internal + record, make a recursive call to fill it in as well. */ + +static tree +extract_values (tree values, tree record_type) +{ + tree field, tem; + VEC(constructor_elt,gc) *v = NULL; + + for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field)) + { + tree value = 0; + + /* _Parent is an internal field, but may have values in the aggregate, + so check for values first. */ + if ((tem = purpose_member (field, values))) + { + value = TREE_VALUE (tem); + TREE_ADDRESSABLE (tem) = 1; + } + + else if (DECL_INTERNAL_P (field)) + { + value = extract_values (values, TREE_TYPE (field)); + if (TREE_CODE (value) == CONSTRUCTOR + && VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (value))) + value = 0; + } + else + /* If we have a record subtype, the names will match, but not the + actual FIELD_DECLs. */ + for (tem = values; tem; tem = TREE_CHAIN (tem)) + if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field)) + { + value = convert (TREE_TYPE (field), TREE_VALUE (tem)); + TREE_ADDRESSABLE (tem) = 1; + } + + if (!value) + continue; + + CONSTRUCTOR_APPEND_ELT (v, field, value); + } + + return gnat_build_constructor (record_type, v); +} + +/* EXP is to be treated as an array or record. Handle the cases when it is + an access object and perform the required dereferences. */ + +static tree +maybe_implicit_deref (tree exp) +{ + /* If the type is a pointer, dereference it. */ + if (POINTER_TYPE_P (TREE_TYPE (exp)) + || TYPE_IS_FAT_POINTER_P (TREE_TYPE (exp))) + exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp); + + /* If we got a padded type, remove it too. */ + if (TYPE_IS_PADDING_P (TREE_TYPE (exp))) + exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp); + + return exp; +} + +/* Convert SLOC into LOCUS. Return true if SLOC corresponds to a source code + location and false if it doesn't. In the former case, set the Gigi global + variable REF_FILENAME to the simple debug file name as given by sinput. */ + +bool +Sloc_to_locus (Source_Ptr Sloc, location_t *locus) +{ + if (Sloc == No_Location) + return false; + + if (Sloc <= Standard_Location) + { + *locus = BUILTINS_LOCATION; + return false; + } + else + { + Source_File_Index file = Get_Source_File_Index (Sloc); + Logical_Line_Number line = Get_Logical_Line_Number (Sloc); + Column_Number column = Get_Column_Number (Sloc); + struct line_map *map = &line_table->maps[file - 1]; + + /* Translate the location according to the line-map.h formula. */ + *locus = map->start_location + + ((line - map->to_line) << map->column_bits) + + (column & ((1 << map->column_bits) - 1)); + } + + ref_filename + = IDENTIFIER_POINTER + (get_identifier + (Get_Name_String (Debug_Source_Name (Get_Source_File_Index (Sloc)))));; + + return true; +} + +/* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and + don't do anything if it doesn't correspond to a source location. */ + +static void +set_expr_location_from_node (tree node, Node_Id gnat_node) +{ + location_t locus; + + if (!Sloc_to_locus (Sloc (gnat_node), &locus)) + return; + + SET_EXPR_LOCATION (node, locus); +} + +/* More elaborate version of set_expr_location_from_node to be used in more + general contexts, for example the result of the translation of a generic + GNAT node. */ + +static void +set_gnu_expr_location_from_node (tree node, Node_Id gnat_node) +{ + /* Set the location information on the node if it is a real expression. + References can be reused for multiple GNAT nodes and they would get + the location information of their last use. Also make sure not to + overwrite an existing location as it is probably more precise. */ + + switch (TREE_CODE (node)) + { + CASE_CONVERT: + case NON_LVALUE_EXPR: + break; + + case COMPOUND_EXPR: + if (EXPR_P (TREE_OPERAND (node, 1))) + set_gnu_expr_location_from_node (TREE_OPERAND (node, 1), gnat_node); + + /* ... fall through ... */ + + default: + if (!REFERENCE_CLASS_P (node) && !EXPR_HAS_LOCATION (node)) + { + set_expr_location_from_node (node, gnat_node); + set_end_locus_from_node (node, gnat_node); + } + break; + } +} + +/* Return a colon-separated list of encodings contained in encoded Ada + name. */ + +static const char * +extract_encoding (const char *name) +{ + char *encoding = (char *) ggc_alloc_atomic (strlen (name)); + get_encoding (name, encoding); + return encoding; +} + +/* Extract the Ada name from an encoded name. */ + +static const char * +decode_name (const char *name) +{ + char *decoded = (char *) ggc_alloc_atomic (strlen (name) * 2 + 60); + __gnat_decode (name, decoded, 0); + return decoded; +} + +/* Post an error message. MSG is the error message, properly annotated. + NODE is the node at which to post the error and the node to use for the + '&' substitution. */ + +void +post_error (const char *msg, Node_Id node) +{ + String_Template temp; + Fat_Pointer fp; + + temp.Low_Bound = 1, temp.High_Bound = strlen (msg); + fp.Array = msg, fp.Bounds = &temp; + if (Present (node)) + Error_Msg_N (fp, node); +} + +/* Similar to post_error, but NODE is the node at which to post the error and + ENT is the node to use for the '&' substitution. */ + +void +post_error_ne (const char *msg, Node_Id node, Entity_Id ent) +{ + String_Template temp; + Fat_Pointer fp; + + temp.Low_Bound = 1, temp.High_Bound = strlen (msg); + fp.Array = msg, fp.Bounds = &temp; + if (Present (node)) + Error_Msg_NE (fp, node, ent); +} + +/* Similar to post_error_ne, but NUM is the number to use for the '^'. */ + +void +post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int num) +{ + Error_Msg_Uint_1 = UI_From_Int (num); + post_error_ne (msg, node, ent); +} + +/* Set the end_locus information for GNU_NODE, if any, from an explicit end + location associated with GNAT_NODE or GNAT_NODE itself, whichever makes + most sense. Return true if a sensible assignment was performed. */ + +static bool +set_end_locus_from_node (tree gnu_node, Node_Id gnat_node) +{ + Node_Id gnat_end_label = Empty; + location_t end_locus; + + /* Pick the GNAT node of which we'll take the sloc to assign to the GCC node + end_locus when there is one. We consider only GNAT nodes with a possible + End_Label attached. If the End_Label actually was unassigned, fallback + on the orginal node. We'd better assign an explicit sloc associated with + the outer construct in any case. */ + + switch (Nkind (gnat_node)) + { + case N_Package_Body: + case N_Subprogram_Body: + case N_Block_Statement: + gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node)); + break; + + case N_Package_Declaration: + gnat_end_label = End_Label (Specification (gnat_node)); + break; + + default: + return false; + } + + gnat_node = Present (gnat_end_label) ? gnat_end_label : gnat_node; + + /* Some expanded subprograms have neither an End_Label nor a Sloc + attached. Notify that to callers. */ + + if (!Sloc_to_locus (Sloc (gnat_node), &end_locus)) + return false; + + switch (TREE_CODE (gnu_node)) + { + case BIND_EXPR: + BLOCK_SOURCE_END_LOCATION (BIND_EXPR_BLOCK (gnu_node)) = end_locus; + return true; + + case FUNCTION_DECL: + DECL_STRUCT_FUNCTION (gnu_node)->function_end_locus = end_locus; + return true; + + default: + return false; + } +} + +/* Similar to post_error_ne, but T is a GCC tree representing the number to + write. If T represents a constant, the text inside curly brackets in + MSG will be output (presumably including a '^'). Otherwise it will not + be output and the text inside square brackets will be output instead. */ + +void +post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t) +{ + char *new_msg = XALLOCAVEC (char, strlen (msg) + 1); + char start_yes, end_yes, start_no, end_no; + const char *p; + char *q; + + if (TREE_CODE (t) == INTEGER_CST) + { + Error_Msg_Uint_1 = UI_From_gnu (t); + start_yes = '{', end_yes = '}', start_no = '[', end_no = ']'; + } + else + start_yes = '[', end_yes = ']', start_no = '{', end_no = '}'; + + for (p = msg, q = new_msg; *p; p++) + { + if (*p == start_yes) + for (p++; *p != end_yes; p++) + *q++ = *p; + else if (*p == start_no) + for (p++; *p != end_no; p++) + ; + else + *q++ = *p; + } + + *q = 0; + + post_error_ne (new_msg, node, ent); +} + +/* Similar to post_error_ne_tree, but NUM is a second integer to write. */ + +void +post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent, tree t, + int num) +{ + Error_Msg_Uint_2 = UI_From_Int (num); + post_error_ne_tree (msg, node, ent, t); +} + +/* Initialize the table that maps GNAT codes to GCC codes for simple + binary and unary operations. */ + +static void +init_code_table (void) +{ + gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR; + gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR; + + gnu_codes[N_Op_And] = TRUTH_AND_EXPR; + gnu_codes[N_Op_Or] = TRUTH_OR_EXPR; + gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR; + gnu_codes[N_Op_Eq] = EQ_EXPR; + gnu_codes[N_Op_Ne] = NE_EXPR; + gnu_codes[N_Op_Lt] = LT_EXPR; + gnu_codes[N_Op_Le] = LE_EXPR; + gnu_codes[N_Op_Gt] = GT_EXPR; + gnu_codes[N_Op_Ge] = GE_EXPR; + gnu_codes[N_Op_Add] = PLUS_EXPR; + gnu_codes[N_Op_Subtract] = MINUS_EXPR; + gnu_codes[N_Op_Multiply] = MULT_EXPR; + gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR; + gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR; + gnu_codes[N_Op_Minus] = NEGATE_EXPR; + gnu_codes[N_Op_Abs] = ABS_EXPR; + gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR; + gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR; + gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR; + gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR; + gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR; + gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR; +} + +/* Return a label to branch to for the exception type in KIND or NULL_TREE + if none. */ + +tree +get_exception_label (char kind) +{ + if (kind == N_Raise_Constraint_Error) + return VEC_last (tree, gnu_constraint_error_label_stack); + else if (kind == N_Raise_Storage_Error) + return VEC_last (tree, gnu_storage_error_label_stack); + else if (kind == N_Raise_Program_Error) + return VEC_last (tree, gnu_program_error_label_stack); + else + return NULL_TREE; +} + +/* Return the decl for the current elaboration procedure. */ + +tree +get_elaboration_procedure (void) +{ + return VEC_last (tree, gnu_elab_proc_stack); +} + +#include "gt-ada-trans.h" diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c new file mode 100644 index 000000000..eac87e0bb --- /dev/null +++ b/gcc/ada/gcc-interface/utils.c @@ -0,0 +1,5579 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * U T I L S * + * * + * C Implementation File * + * * + * 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. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License along with GCC; see the file COPYING3. If not see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tm.h" +#include "tree.h" +#include "flags.h" +#include "toplev.h" +#include "diagnostic-core.h" +#include "output.h" +#include "ggc.h" +#include "debug.h" +#include "convert.h" +#include "target.h" +#include "langhooks.h" +#include "cgraph.h" +#include "tree-dump.h" +#include "tree-inline.h" +#include "tree-iterator.h" + +#include "ada.h" +#include "types.h" +#include "atree.h" +#include "elists.h" +#include "namet.h" +#include "nlists.h" +#include "stringt.h" +#include "uintp.h" +#include "fe.h" +#include "sinfo.h" +#include "einfo.h" +#include "ada-tree.h" +#include "gigi.h" + +#ifndef MAX_BITS_PER_WORD +#define MAX_BITS_PER_WORD BITS_PER_WORD +#endif + +/* If nonzero, pretend we are allocating at global level. */ +int force_global; + +/* The default alignment of "double" floating-point types, i.e. floating + point types whose size is equal to 64 bits, or 0 if this alignment is + not specifically capped. */ +int double_float_alignment; + +/* The default alignment of "double" or larger scalar types, i.e. scalar + types whose size is greater or equal to 64 bits, or 0 if this alignment + is not specifically capped. */ +int double_scalar_alignment; + +/* Tree nodes for the various types and decls we create. */ +tree gnat_std_decls[(int) ADT_LAST]; + +/* Functions to call for each of the possible raise reasons. */ +tree gnat_raise_decls[(int) LAST_REASON_CODE + 1]; + +/* Likewise, but with extra info for each of the possible raise reasons. */ +tree gnat_raise_decls_ext[(int) LAST_REASON_CODE + 1]; + +/* Forward declarations for handlers of attributes. */ +static tree handle_const_attribute (tree *, tree, tree, int, bool *); +static tree handle_nothrow_attribute (tree *, tree, tree, int, bool *); +static tree handle_pure_attribute (tree *, tree, tree, int, bool *); +static tree handle_novops_attribute (tree *, tree, tree, int, bool *); +static tree handle_nonnull_attribute (tree *, tree, tree, int, bool *); +static tree handle_sentinel_attribute (tree *, tree, tree, int, bool *); +static tree handle_noreturn_attribute (tree *, tree, tree, int, bool *); +static tree handle_leaf_attribute (tree *, tree, tree, int, bool *); +static tree handle_malloc_attribute (tree *, tree, tree, int, bool *); +static tree handle_type_generic_attribute (tree *, tree, tree, int, bool *); +static tree handle_vector_size_attribute (tree *, tree, tree, int, bool *); +static tree handle_vector_type_attribute (tree *, tree, tree, int, bool *); + +/* Fake handler for attributes we don't properly support, typically because + they'd require dragging a lot of the common-c front-end circuitry. */ +static tree fake_attribute_handler (tree *, tree, tree, int, bool *); + +/* Table of machine-independent internal attributes for Ada. We support + this minimal set of attributes to accommodate the needs of builtins. */ +const struct attribute_spec gnat_internal_attribute_table[] = +{ + /* { name, min_len, max_len, decl_req, type_req, fn_type_req, handler } */ + { "const", 0, 0, true, false, false, handle_const_attribute }, + { "nothrow", 0, 0, true, false, false, handle_nothrow_attribute }, + { "pure", 0, 0, true, false, false, handle_pure_attribute }, + { "no vops", 0, 0, true, false, false, handle_novops_attribute }, + { "nonnull", 0, -1, false, true, true, handle_nonnull_attribute }, + { "sentinel", 0, 1, false, true, true, handle_sentinel_attribute }, + { "noreturn", 0, 0, true, false, false, handle_noreturn_attribute }, + { "leaf", 0, 0, true, false, false, handle_leaf_attribute }, + { "malloc", 0, 0, true, false, false, handle_malloc_attribute }, + { "type generic", 0, 0, false, true, true, handle_type_generic_attribute }, + + { "vector_size", 1, 1, false, true, false, handle_vector_size_attribute }, + { "vector_type", 0, 0, false, true, false, handle_vector_type_attribute }, + { "may_alias", 0, 0, false, true, false, NULL }, + + /* ??? format and format_arg are heavy and not supported, which actually + prevents support for stdio builtins, which we however declare as part + of the common builtins.def contents. */ + { "format", 3, 3, false, true, true, fake_attribute_handler }, + { "format_arg", 1, 1, false, true, true, fake_attribute_handler }, + + { NULL, 0, 0, false, false, false, NULL } +}; + +/* Associates a GNAT tree node to a GCC tree node. It is used in + `save_gnu_tree', `get_gnu_tree' and `present_gnu_tree'. See documentation + of `save_gnu_tree' for more info. */ +static GTY((length ("max_gnat_nodes"))) tree *associate_gnat_to_gnu; + +#define GET_GNU_TREE(GNAT_ENTITY) \ + associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] + +#define SET_GNU_TREE(GNAT_ENTITY,VAL) \ + associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] = (VAL) + +#define PRESENT_GNU_TREE(GNAT_ENTITY) \ + (associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE) + +/* Associates a GNAT entity to a GCC tree node used as a dummy, if any. */ +static GTY((length ("max_gnat_nodes"))) tree *dummy_node_table; + +#define GET_DUMMY_NODE(GNAT_ENTITY) \ + dummy_node_table[(GNAT_ENTITY) - First_Node_Id] + +#define SET_DUMMY_NODE(GNAT_ENTITY,VAL) \ + dummy_node_table[(GNAT_ENTITY) - First_Node_Id] = (VAL) + +#define PRESENT_DUMMY_NODE(GNAT_ENTITY) \ + (dummy_node_table[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE) + +/* This variable keeps a table for types for each precision so that we only + allocate each of them once. Signed and unsigned types are kept separate. + + Note that these types are only used when fold-const requests something + special. Perhaps we should NOT share these types; we'll see how it + goes later. */ +static GTY(()) tree signed_and_unsigned_types[2 * MAX_BITS_PER_WORD + 1][2]; + +/* Likewise for float types, but record these by mode. */ +static GTY(()) tree float_types[NUM_MACHINE_MODES]; + +/* For each binding contour we allocate a binding_level structure to indicate + the binding depth. */ + +struct GTY((chain_next ("%h.chain"))) gnat_binding_level { + /* The binding level containing this one (the enclosing binding level). */ + struct gnat_binding_level *chain; + /* The BLOCK node for this level. */ + tree block; + /* If nonzero, the setjmp buffer that needs to be updated for any + variable-sized definition within this context. */ + tree jmpbuf_decl; +}; + +/* The binding level currently in effect. */ +static GTY(()) struct gnat_binding_level *current_binding_level; + +/* A chain of gnat_binding_level structures awaiting reuse. */ +static GTY((deletable)) struct gnat_binding_level *free_binding_level; + +/* An array of global declarations. */ +static GTY(()) VEC(tree,gc) *global_decls; + +/* An array of builtin function declarations. */ +static GTY(()) VEC(tree,gc) *builtin_decls; + +/* An array of global renaming pointers. */ +static GTY(()) VEC(tree,gc) *global_renaming_pointers; + +/* A chain of unused BLOCK nodes. */ +static GTY((deletable)) tree free_block_chain; + +static tree merge_sizes (tree, tree, tree, bool, bool); +static tree compute_related_constant (tree, tree); +static tree split_plus (tree, tree *); +static tree float_type_for_precision (int, enum machine_mode); +static tree convert_to_fat_pointer (tree, tree); +static tree convert_to_thin_pointer (tree, tree); +static bool potential_alignment_gap (tree, tree, tree); +static void process_attributes (tree, struct attrib *); + +/* Initialize the association of GNAT nodes to GCC trees. */ + +void +init_gnat_to_gnu (void) +{ + associate_gnat_to_gnu = ggc_alloc_cleared_vec_tree (max_gnat_nodes); +} + +/* GNAT_ENTITY is a GNAT tree node for an entity. Associate GNU_DECL, a GCC + tree node, with GNAT_ENTITY. If GNU_DECL is not a ..._DECL node, abort. + If NO_CHECK is true, the latter check is suppressed. + + If GNU_DECL is zero, reset a previous association. */ + +void +save_gnu_tree (Entity_Id gnat_entity, tree gnu_decl, bool no_check) +{ + /* Check that GNAT_ENTITY is not already defined and that it is being set + to something which is a decl. If that is not the case, this usually + means GNAT_ENTITY is defined twice, but occasionally is due to some + Gigi problem. */ + gcc_assert (!(gnu_decl + && (PRESENT_GNU_TREE (gnat_entity) + || (!no_check && !DECL_P (gnu_decl))))); + + SET_GNU_TREE (gnat_entity, gnu_decl); +} + +/* GNAT_ENTITY is a GNAT tree node for an entity. Return the GCC tree node + that was associated with it. If there is no such tree node, abort. + + In some cases, such as delayed elaboration or expressions that need to + be elaborated only once, GNAT_ENTITY is really not an entity. */ + +tree +get_gnu_tree (Entity_Id gnat_entity) +{ + gcc_assert (PRESENT_GNU_TREE (gnat_entity)); + return GET_GNU_TREE (gnat_entity); +} + +/* Return nonzero if a GCC tree has been associated with GNAT_ENTITY. */ + +bool +present_gnu_tree (Entity_Id gnat_entity) +{ + return PRESENT_GNU_TREE (gnat_entity); +} + +/* Initialize the association of GNAT nodes to GCC trees as dummies. */ + +void +init_dummy_type (void) +{ + dummy_node_table = ggc_alloc_cleared_vec_tree (max_gnat_nodes); +} + +/* Make a dummy type corresponding to GNAT_TYPE. */ + +tree +make_dummy_type (Entity_Id gnat_type) +{ + Entity_Id gnat_underlying = Gigi_Equivalent_Type (gnat_type); + tree gnu_type; + + /* If there is an equivalent type, get its underlying type. */ + if (Present (gnat_underlying)) + gnat_underlying = Underlying_Type (gnat_underlying); + + /* If there was no equivalent type (can only happen when just annotating + types) or underlying type, go back to the original type. */ + if (No (gnat_underlying)) + gnat_underlying = gnat_type; + + /* If it there already a dummy type, use that one. Else make one. */ + if (PRESENT_DUMMY_NODE (gnat_underlying)) + return GET_DUMMY_NODE (gnat_underlying); + + /* If this is a record, make a RECORD_TYPE or UNION_TYPE; else make + an ENUMERAL_TYPE. */ + gnu_type = make_node (Is_Record_Type (gnat_underlying) + ? tree_code_for_record_type (gnat_underlying) + : ENUMERAL_TYPE); + TYPE_NAME (gnu_type) = get_entity_name (gnat_type); + TYPE_DUMMY_P (gnu_type) = 1; + TYPE_STUB_DECL (gnu_type) + = create_type_stub_decl (TYPE_NAME (gnu_type), gnu_type); + if (Is_By_Reference_Type (gnat_type)) + TREE_ADDRESSABLE (gnu_type) = 1; + + SET_DUMMY_NODE (gnat_underlying, gnu_type); + + return gnu_type; +} + +/* Return nonzero if we are currently in the global binding level. */ + +int +global_bindings_p (void) +{ + return ((force_global || !current_function_decl) ? -1 : 0); +} + +/* Enter a new binding level. */ + +void +gnat_pushlevel (void) +{ + struct gnat_binding_level *newlevel = NULL; + + /* Reuse a struct for this binding level, if there is one. */ + if (free_binding_level) + { + newlevel = free_binding_level; + free_binding_level = free_binding_level->chain; + } + else + newlevel = ggc_alloc_gnat_binding_level (); + + /* Use a free BLOCK, if any; otherwise, allocate one. */ + if (free_block_chain) + { + newlevel->block = free_block_chain; + free_block_chain = BLOCK_CHAIN (free_block_chain); + BLOCK_CHAIN (newlevel->block) = NULL_TREE; + } + else + newlevel->block = make_node (BLOCK); + + /* Point the BLOCK we just made to its parent. */ + if (current_binding_level) + BLOCK_SUPERCONTEXT (newlevel->block) = current_binding_level->block; + + BLOCK_VARS (newlevel->block) = NULL_TREE; + BLOCK_SUBBLOCKS (newlevel->block) = NULL_TREE; + TREE_USED (newlevel->block) = 1; + + /* Add this level to the front of the chain (stack) of active levels. */ + newlevel->chain = current_binding_level; + newlevel->jmpbuf_decl = NULL_TREE; + current_binding_level = newlevel; +} + +/* Set SUPERCONTEXT of the BLOCK for the current binding level to FNDECL + and point FNDECL to this BLOCK. */ + +void +set_current_block_context (tree fndecl) +{ + BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl; + DECL_INITIAL (fndecl) = current_binding_level->block; + set_block_for_group (current_binding_level->block); +} + +/* Set the jmpbuf_decl for the current binding level to DECL. */ + +void +set_block_jmpbuf_decl (tree decl) +{ + current_binding_level->jmpbuf_decl = decl; +} + +/* Get the jmpbuf_decl, if any, for the current binding level. */ + +tree +get_block_jmpbuf_decl (void) +{ + return current_binding_level->jmpbuf_decl; +} + +/* Exit a binding level. Set any BLOCK into the current code group. */ + +void +gnat_poplevel (void) +{ + struct gnat_binding_level *level = current_binding_level; + tree block = level->block; + + BLOCK_VARS (block) = nreverse (BLOCK_VARS (block)); + BLOCK_SUBBLOCKS (block) = blocks_nreverse (BLOCK_SUBBLOCKS (block)); + + /* If this is a function-level BLOCK don't do anything. Otherwise, if there + are no variables free the block and merge its subblocks into those of its + parent block. Otherwise, add it to the list of its parent. */ + if (TREE_CODE (BLOCK_SUPERCONTEXT (block)) == FUNCTION_DECL) + ; + else if (BLOCK_VARS (block) == NULL_TREE) + { + BLOCK_SUBBLOCKS (level->chain->block) + = chainon (BLOCK_SUBBLOCKS (block), + BLOCK_SUBBLOCKS (level->chain->block)); + BLOCK_CHAIN (block) = free_block_chain; + free_block_chain = block; + } + else + { + BLOCK_CHAIN (block) = BLOCK_SUBBLOCKS (level->chain->block); + BLOCK_SUBBLOCKS (level->chain->block) = block; + TREE_USED (block) = 1; + set_block_for_group (block); + } + + /* Free this binding structure. */ + current_binding_level = level->chain; + level->chain = free_binding_level; + free_binding_level = level; +} + +/* Exit a binding level and discard the associated BLOCK. */ + +void +gnat_zaplevel (void) +{ + struct gnat_binding_level *level = current_binding_level; + tree block = level->block; + + BLOCK_CHAIN (block) = free_block_chain; + free_block_chain = block; + + /* Free this binding structure. */ + current_binding_level = level->chain; + level->chain = free_binding_level; + free_binding_level = level; +} + +/* Records a ..._DECL node DECL as belonging to the current lexical scope + and uses GNAT_NODE for location information and propagating flags. */ + +void +gnat_pushdecl (tree decl, Node_Id gnat_node) +{ + /* If this decl is public external or at toplevel, there is no context. */ + if ((TREE_PUBLIC (decl) && DECL_EXTERNAL (decl)) || global_bindings_p ()) + DECL_CONTEXT (decl) = 0; + else + { + DECL_CONTEXT (decl) = current_function_decl; + + /* Functions imported in another function are not really nested. + For really nested functions mark them initially as needing + a static chain for uses of that flag before unnesting; + lower_nested_functions will then recompute it. */ + if (TREE_CODE (decl) == FUNCTION_DECL && !TREE_PUBLIC (decl)) + DECL_STATIC_CHAIN (decl) = 1; + } + + TREE_NO_WARNING (decl) = (gnat_node == Empty || Warnings_Off (gnat_node)); + + /* Set the location of DECL and emit a declaration for it. */ + if (Present (gnat_node)) + Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (decl)); + add_decl_expr (decl, gnat_node); + + /* Put the declaration on the list. The list of declarations is in reverse + order. The list will be reversed later. Put global declarations in the + globals list and local ones in the current block. But skip TYPE_DECLs + for UNCONSTRAINED_ARRAY_TYPE in both cases, as they will cause trouble + with the debugger and aren't needed anyway. */ + if (!(TREE_CODE (decl) == TYPE_DECL + && TREE_CODE (TREE_TYPE (decl)) == UNCONSTRAINED_ARRAY_TYPE)) + { + if (global_bindings_p ()) + { + VEC_safe_push (tree, gc, global_decls, decl); + + if (TREE_CODE (decl) == FUNCTION_DECL && DECL_BUILT_IN (decl)) + VEC_safe_push (tree, gc, builtin_decls, decl); + } + else if (!DECL_EXTERNAL (decl)) + { + DECL_CHAIN (decl) = BLOCK_VARS (current_binding_level->block); + BLOCK_VARS (current_binding_level->block) = decl; + } + } + + /* For the declaration of a type, set its name if it either is not already + set or if the previous type name was not derived from a source name. + We'd rather have the type named with a real name and all the pointer + types to the same object have the same POINTER_TYPE node. Code in the + equivalent function of c-decl.c makes a copy of the type node here, but + that may cause us trouble with incomplete types. We make an exception + for fat pointer types because the compiler automatically builds them + for unconstrained array types and the debugger uses them to represent + both these and pointers to these. */ + if (TREE_CODE (decl) == TYPE_DECL && DECL_NAME (decl)) + { + tree t = TREE_TYPE (decl); + + if (!(TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL)) + ; + else if (TYPE_IS_FAT_POINTER_P (t)) + { + tree tt = build_variant_type_copy (t); + TYPE_NAME (tt) = decl; + TREE_USED (tt) = TREE_USED (t); + TREE_TYPE (decl) = tt; + if (DECL_ORIGINAL_TYPE (TYPE_NAME (t))) + DECL_ORIGINAL_TYPE (decl) = DECL_ORIGINAL_TYPE (TYPE_NAME (t)); + else + DECL_ORIGINAL_TYPE (decl) = t; + t = NULL_TREE; + DECL_ARTIFICIAL (decl) = 0; + } + else if (DECL_ARTIFICIAL (TYPE_NAME (t)) && !DECL_ARTIFICIAL (decl)) + ; + else + t = NULL_TREE; + + /* Propagate the name to all the variants. This is needed for + the type qualifiers machinery to work properly. */ + if (t) + for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t)) + TYPE_NAME (t) = decl; + } +} + +/* Record TYPE as a builtin type for Ada. NAME is the name of the type. */ + +void +record_builtin_type (const char *name, tree type) +{ + tree type_decl = build_decl (input_location, + TYPE_DECL, get_identifier (name), type); + + gnat_pushdecl (type_decl, Empty); + + if (debug_hooks->type_decl) + debug_hooks->type_decl (type_decl, false); +} + +/* Given a record type RECORD_TYPE and a list of FIELD_DECL nodes FIELD_LIST, + finish constructing the record or union type. If REP_LEVEL is zero, this + record has no representation clause and so will be entirely laid out here. + If REP_LEVEL is one, this record has a representation clause and has been + laid out already; only set the sizes and alignment. If REP_LEVEL is two, + this record is derived from a parent record and thus inherits its layout; + only make a pass on the fields to finalize them. DEBUG_INFO_P is true if + we need to write debug information about this type. */ + +void +finish_record_type (tree record_type, tree field_list, int rep_level, + bool debug_info_p) +{ + enum tree_code code = TREE_CODE (record_type); + tree name = TYPE_NAME (record_type); + tree ada_size = bitsize_zero_node; + tree size = bitsize_zero_node; + bool had_size = TYPE_SIZE (record_type) != 0; + bool had_size_unit = TYPE_SIZE_UNIT (record_type) != 0; + bool had_align = TYPE_ALIGN (record_type) != 0; + tree field; + + TYPE_FIELDS (record_type) = field_list; + + /* Always attach the TYPE_STUB_DECL for a record type. It is required to + generate debug info and have a parallel type. */ + if (name && TREE_CODE (name) == TYPE_DECL) + name = DECL_NAME (name); + TYPE_STUB_DECL (record_type) = create_type_stub_decl (name, record_type); + + /* Globally initialize the record first. If this is a rep'ed record, + that just means some initializations; otherwise, layout the record. */ + if (rep_level > 0) + { + TYPE_ALIGN (record_type) = MAX (BITS_PER_UNIT, TYPE_ALIGN (record_type)); + + if (!had_size_unit) + TYPE_SIZE_UNIT (record_type) = size_zero_node; + + if (!had_size) + TYPE_SIZE (record_type) = bitsize_zero_node; + + /* For all-repped records with a size specified, lay the QUAL_UNION_TYPE + out just like a UNION_TYPE, since the size will be fixed. */ + else if (code == QUAL_UNION_TYPE) + code = UNION_TYPE; + } + else + { + /* Ensure there isn't a size already set. There can be in an error + case where there is a rep clause but all fields have errors and + no longer have a position. */ + TYPE_SIZE (record_type) = 0; + layout_type (record_type); + } + + /* At this point, the position and size of each field is known. It was + either set before entry by a rep clause, or by laying out the type above. + + We now run a pass over the fields (in reverse order for QUAL_UNION_TYPEs) + to compute the Ada size; the GCC size and alignment (for rep'ed records + that are not padding types); and the mode (for rep'ed records). We also + clear the DECL_BIT_FIELD indication for the cases we know have not been + handled yet, and adjust DECL_NONADDRESSABLE_P accordingly. */ + + if (code == QUAL_UNION_TYPE) + field_list = nreverse (field_list); + + for (field = field_list; field; field = DECL_CHAIN (field)) + { + tree type = TREE_TYPE (field); + tree pos = bit_position (field); + tree this_size = DECL_SIZE (field); + tree this_ada_size; + + if ((TREE_CODE (type) == RECORD_TYPE + || TREE_CODE (type) == UNION_TYPE + || TREE_CODE (type) == QUAL_UNION_TYPE) + && !TYPE_FAT_POINTER_P (type) + && !TYPE_CONTAINS_TEMPLATE_P (type) + && TYPE_ADA_SIZE (type)) + this_ada_size = TYPE_ADA_SIZE (type); + else + this_ada_size = this_size; + + /* Clear DECL_BIT_FIELD for the cases layout_decl does not handle. */ + if (DECL_BIT_FIELD (field) + && operand_equal_p (this_size, TYPE_SIZE (type), 0)) + { + unsigned int align = TYPE_ALIGN (type); + + /* In the general case, type alignment is required. */ + if (value_factor_p (pos, align)) + { + /* The enclosing record type must be sufficiently aligned. + Otherwise, if no alignment was specified for it and it + has been laid out already, bump its alignment to the + desired one if this is compatible with its size. */ + if (TYPE_ALIGN (record_type) >= align) + { + DECL_ALIGN (field) = MAX (DECL_ALIGN (field), align); + DECL_BIT_FIELD (field) = 0; + } + else if (!had_align + && rep_level == 0 + && value_factor_p (TYPE_SIZE (record_type), align)) + { + TYPE_ALIGN (record_type) = align; + DECL_ALIGN (field) = MAX (DECL_ALIGN (field), align); + DECL_BIT_FIELD (field) = 0; + } + } + + /* In the non-strict alignment case, only byte alignment is. */ + if (!STRICT_ALIGNMENT + && DECL_BIT_FIELD (field) + && value_factor_p (pos, BITS_PER_UNIT)) + DECL_BIT_FIELD (field) = 0; + } + + /* If we still have DECL_BIT_FIELD set at this point, we know that the + field is technically not addressable. Except that it can actually + be addressed if it is BLKmode and happens to be properly aligned. */ + if (DECL_BIT_FIELD (field) + && !(DECL_MODE (field) == BLKmode + && value_factor_p (pos, BITS_PER_UNIT))) + DECL_NONADDRESSABLE_P (field) = 1; + + /* A type must be as aligned as its most aligned field that is not + a bit-field. But this is already enforced by layout_type. */ + if (rep_level > 0 && !DECL_BIT_FIELD (field)) + TYPE_ALIGN (record_type) + = MAX (TYPE_ALIGN (record_type), DECL_ALIGN (field)); + + switch (code) + { + case UNION_TYPE: + ada_size = size_binop (MAX_EXPR, ada_size, this_ada_size); + size = size_binop (MAX_EXPR, size, this_size); + break; + + case QUAL_UNION_TYPE: + ada_size + = fold_build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field), + this_ada_size, ada_size); + size = fold_build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field), + this_size, size); + break; + + case RECORD_TYPE: + /* Since we know here that all fields are sorted in order of + increasing bit position, the size of the record is one + higher than the ending bit of the last field processed + unless we have a rep clause, since in that case we might + have a field outside a QUAL_UNION_TYPE that has a higher ending + position. So use a MAX in that case. Also, if this field is a + QUAL_UNION_TYPE, we need to take into account the previous size in + the case of empty variants. */ + ada_size + = merge_sizes (ada_size, pos, this_ada_size, + TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0); + size + = merge_sizes (size, pos, this_size, + TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0); + break; + + default: + gcc_unreachable (); + } + } + + if (code == QUAL_UNION_TYPE) + nreverse (field_list); + + if (rep_level < 2) + { + /* If this is a padding record, we never want to make the size smaller + than what was specified in it, if any. */ + if (TYPE_IS_PADDING_P (record_type) && TYPE_SIZE (record_type)) + size = TYPE_SIZE (record_type); + + /* Now set any of the values we've just computed that apply. */ + if (!TYPE_FAT_POINTER_P (record_type) + && !TYPE_CONTAINS_TEMPLATE_P (record_type)) + SET_TYPE_ADA_SIZE (record_type, ada_size); + + if (rep_level > 0) + { + tree size_unit = had_size_unit + ? TYPE_SIZE_UNIT (record_type) + : convert (sizetype, + size_binop (CEIL_DIV_EXPR, size, + bitsize_unit_node)); + unsigned int align = TYPE_ALIGN (record_type); + + TYPE_SIZE (record_type) = variable_size (round_up (size, align)); + TYPE_SIZE_UNIT (record_type) + = variable_size (round_up (size_unit, align / BITS_PER_UNIT)); + + compute_record_mode (record_type); + } + } + + if (debug_info_p) + rest_of_record_type_compilation (record_type); +} + +/* Wrap up compilation of RECORD_TYPE, i.e. output all the debug information + associated with it. It need not be invoked directly in most cases since + finish_record_type takes care of doing so, but this can be necessary if + a parallel type is to be attached to the record type. */ + +void +rest_of_record_type_compilation (tree record_type) +{ + tree field_list = TYPE_FIELDS (record_type); + tree field; + enum tree_code code = TREE_CODE (record_type); + bool var_size = false; + + for (field = field_list; field; field = DECL_CHAIN (field)) + { + /* We need to make an XVE/XVU record if any field has variable size, + whether or not the record does. For example, if we have a union, + it may be that all fields, rounded up to the alignment, have the + same size, in which case we'll use that size. But the debug + output routines (except Dwarf2) won't be able to output the fields, + so we need to make the special record. */ + if (TREE_CODE (DECL_SIZE (field)) != INTEGER_CST + /* If a field has a non-constant qualifier, the record will have + variable size too. */ + || (code == QUAL_UNION_TYPE + && TREE_CODE (DECL_QUALIFIER (field)) != INTEGER_CST)) + { + var_size = true; + break; + } + } + + /* If this record is of variable size, rename it so that the + debugger knows it is and make a new, parallel, record + that tells the debugger how the record is laid out. See + exp_dbug.ads. But don't do this for records that are padding + since they confuse GDB. */ + if (var_size && !TYPE_IS_PADDING_P (record_type)) + { + tree new_record_type + = make_node (TREE_CODE (record_type) == QUAL_UNION_TYPE + ? UNION_TYPE : TREE_CODE (record_type)); + tree orig_name = TYPE_NAME (record_type), new_name; + tree last_pos = bitsize_zero_node; + tree old_field, prev_old_field = NULL_TREE; + + if (TREE_CODE (orig_name) == TYPE_DECL) + orig_name = DECL_NAME (orig_name); + + new_name + = concat_name (orig_name, TREE_CODE (record_type) == QUAL_UNION_TYPE + ? "XVU" : "XVE"); + TYPE_NAME (new_record_type) = new_name; + TYPE_ALIGN (new_record_type) = BIGGEST_ALIGNMENT; + TYPE_STUB_DECL (new_record_type) + = create_type_stub_decl (new_name, new_record_type); + DECL_IGNORED_P (TYPE_STUB_DECL (new_record_type)) + = DECL_IGNORED_P (TYPE_STUB_DECL (record_type)); + TYPE_SIZE (new_record_type) = size_int (TYPE_ALIGN (record_type)); + TYPE_SIZE_UNIT (new_record_type) + = size_int (TYPE_ALIGN (record_type) / BITS_PER_UNIT); + + add_parallel_type (TYPE_STUB_DECL (record_type), new_record_type); + + /* Now scan all the fields, replacing each field with a new + field corresponding to the new encoding. */ + for (old_field = TYPE_FIELDS (record_type); old_field; + old_field = DECL_CHAIN (old_field)) + { + tree field_type = TREE_TYPE (old_field); + tree field_name = DECL_NAME (old_field); + tree new_field; + tree curpos = bit_position (old_field); + bool var = false; + unsigned int align = 0; + tree pos; + + /* See how the position was modified from the last position. + + There are two basic cases we support: a value was added + to the last position or the last position was rounded to + a boundary and they something was added. Check for the + first case first. If not, see if there is any evidence + of rounding. If so, round the last position and try + again. + + If this is a union, the position can be taken as zero. */ + + /* Some computations depend on the shape of the position expression, + so strip conversions to make sure it's exposed. */ + curpos = remove_conversions (curpos, true); + + if (TREE_CODE (new_record_type) == UNION_TYPE) + pos = bitsize_zero_node, align = 0; + else + pos = compute_related_constant (curpos, last_pos); + + if (!pos && TREE_CODE (curpos) == MULT_EXPR + && host_integerp (TREE_OPERAND (curpos, 1), 1)) + { + tree offset = TREE_OPERAND (curpos, 0); + align = tree_low_cst (TREE_OPERAND (curpos, 1), 1); + + /* An offset which is a bitwise AND with a negative power of 2 + means an alignment corresponding to this power of 2. Note + that, as sizetype is sign-extended but nonetheless unsigned, + we don't directly use tree_int_cst_sgn. */ + offset = remove_conversions (offset, true); + if (TREE_CODE (offset) == BIT_AND_EXPR + && host_integerp (TREE_OPERAND (offset, 1), 0) + && TREE_INT_CST_HIGH (TREE_OPERAND (offset, 1)) < 0) + { + unsigned int pow + = - tree_low_cst (TREE_OPERAND (offset, 1), 0); + if (exact_log2 (pow) > 0) + align *= pow; + } + + pos = compute_related_constant (curpos, + round_up (last_pos, align)); + } + else if (!pos && TREE_CODE (curpos) == PLUS_EXPR + && TREE_CODE (TREE_OPERAND (curpos, 1)) == INTEGER_CST + && TREE_CODE (TREE_OPERAND (curpos, 0)) == MULT_EXPR + && host_integerp (TREE_OPERAND + (TREE_OPERAND (curpos, 0), 1), + 1)) + { + align + = tree_low_cst + (TREE_OPERAND (TREE_OPERAND (curpos, 0), 1), 1); + pos = compute_related_constant (curpos, + round_up (last_pos, align)); + } + else if (potential_alignment_gap (prev_old_field, old_field, + pos)) + { + align = TYPE_ALIGN (field_type); + pos = compute_related_constant (curpos, + round_up (last_pos, align)); + } + + /* If we can't compute a position, set it to zero. + + ??? We really should abort here, but it's too much work + to get this correct for all cases. */ + + if (!pos) + pos = bitsize_zero_node; + + /* See if this type is variable-sized and make a pointer type + and indicate the indirection if so. Beware that the debug + back-end may adjust the position computed above according + to the alignment of the field type, i.e. the pointer type + in this case, if we don't preventively counter that. */ + if (TREE_CODE (DECL_SIZE (old_field)) != INTEGER_CST) + { + field_type = build_pointer_type (field_type); + if (align != 0 && TYPE_ALIGN (field_type) > align) + { + field_type = copy_node (field_type); + TYPE_ALIGN (field_type) = align; + } + var = true; + } + + /* Make a new field name, if necessary. */ + if (var || align != 0) + { + char suffix[16]; + + if (align != 0) + sprintf (suffix, "XV%c%u", var ? 'L' : 'A', + align / BITS_PER_UNIT); + else + strcpy (suffix, "XVL"); + + field_name = concat_name (field_name, suffix); + } + + new_field + = create_field_decl (field_name, field_type, new_record_type, + DECL_SIZE (old_field), pos, 0, 0); + DECL_CHAIN (new_field) = TYPE_FIELDS (new_record_type); + TYPE_FIELDS (new_record_type) = new_field; + + /* If old_field is a QUAL_UNION_TYPE, take its size as being + zero. The only time it's not the last field of the record + is when there are other components at fixed positions after + it (meaning there was a rep clause for every field) and we + want to be able to encode them. */ + last_pos = size_binop (PLUS_EXPR, bit_position (old_field), + (TREE_CODE (TREE_TYPE (old_field)) + == QUAL_UNION_TYPE) + ? bitsize_zero_node + : DECL_SIZE (old_field)); + prev_old_field = old_field; + } + + TYPE_FIELDS (new_record_type) + = nreverse (TYPE_FIELDS (new_record_type)); + + rest_of_type_decl_compilation (TYPE_STUB_DECL (new_record_type)); + } + + rest_of_type_decl_compilation (TYPE_STUB_DECL (record_type)); +} + +/* Append PARALLEL_TYPE on the chain of parallel types for decl. */ + +void +add_parallel_type (tree decl, tree parallel_type) +{ + tree d = decl; + + while (DECL_PARALLEL_TYPE (d)) + d = TYPE_STUB_DECL (DECL_PARALLEL_TYPE (d)); + + SET_DECL_PARALLEL_TYPE (d, parallel_type); +} + +/* Utility function of above to merge LAST_SIZE, the previous size of a record + with FIRST_BIT and SIZE that describe a field. SPECIAL is true if this + represents a QUAL_UNION_TYPE in which case we must look for COND_EXPRs and + replace a value of zero with the old size. If HAS_REP is true, we take the + MAX of the end position of this field with LAST_SIZE. In all other cases, + we use FIRST_BIT plus SIZE. Return an expression for the size. */ + +static tree +merge_sizes (tree last_size, tree first_bit, tree size, bool special, + bool has_rep) +{ + tree type = TREE_TYPE (last_size); + tree new_size; + + if (!special || TREE_CODE (size) != COND_EXPR) + { + new_size = size_binop (PLUS_EXPR, first_bit, size); + if (has_rep) + new_size = size_binop (MAX_EXPR, last_size, new_size); + } + + else + new_size = fold_build3 (COND_EXPR, type, TREE_OPERAND (size, 0), + integer_zerop (TREE_OPERAND (size, 1)) + ? last_size : merge_sizes (last_size, first_bit, + TREE_OPERAND (size, 1), + 1, has_rep), + integer_zerop (TREE_OPERAND (size, 2)) + ? last_size : merge_sizes (last_size, first_bit, + TREE_OPERAND (size, 2), + 1, has_rep)); + + /* We don't need any NON_VALUE_EXPRs and they can confuse us (especially + when fed through substitute_in_expr) into thinking that a constant + size is not constant. */ + while (TREE_CODE (new_size) == NON_LVALUE_EXPR) + new_size = TREE_OPERAND (new_size, 0); + + return new_size; +} + +/* Utility function of above to see if OP0 and OP1, both of SIZETYPE, are + related by the addition of a constant. Return that constant if so. */ + +static tree +compute_related_constant (tree op0, tree op1) +{ + tree op0_var, op1_var; + tree op0_con = split_plus (op0, &op0_var); + tree op1_con = split_plus (op1, &op1_var); + tree result = size_binop (MINUS_EXPR, op0_con, op1_con); + + if (operand_equal_p (op0_var, op1_var, 0)) + return result; + else if (operand_equal_p (op0, size_binop (PLUS_EXPR, op1_var, result), 0)) + return result; + else + return 0; +} + +/* Utility function of above to split a tree OP which may be a sum, into a + constant part, which is returned, and a variable part, which is stored + in *PVAR. *PVAR may be bitsize_zero_node. All operations must be of + bitsizetype. */ + +static tree +split_plus (tree in, tree *pvar) +{ + /* Strip NOPS in order to ease the tree traversal and maximize the + potential for constant or plus/minus discovery. We need to be careful + to always return and set *pvar to bitsizetype trees, but it's worth + the effort. */ + STRIP_NOPS (in); + + *pvar = convert (bitsizetype, in); + + if (TREE_CODE (in) == INTEGER_CST) + { + *pvar = bitsize_zero_node; + return convert (bitsizetype, in); + } + else if (TREE_CODE (in) == PLUS_EXPR || TREE_CODE (in) == MINUS_EXPR) + { + tree lhs_var, rhs_var; + tree lhs_con = split_plus (TREE_OPERAND (in, 0), &lhs_var); + tree rhs_con = split_plus (TREE_OPERAND (in, 1), &rhs_var); + + if (lhs_var == TREE_OPERAND (in, 0) + && rhs_var == TREE_OPERAND (in, 1)) + return bitsize_zero_node; + + *pvar = size_binop (TREE_CODE (in), lhs_var, rhs_var); + return size_binop (TREE_CODE (in), lhs_con, rhs_con); + } + else + return bitsize_zero_node; +} + +/* Return a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the + subprogram. If it is VOID_TYPE, then we are dealing with a procedure, + otherwise we are dealing with a function. PARAM_DECL_LIST is a list of + PARM_DECL nodes that are the subprogram parameters. CICO_LIST is the + copy-in/copy-out list to be stored into the TYPE_CICO_LIST field. + RETURN_UNCONSTRAINED_P is true if the function returns an unconstrained + object. RETURN_BY_DIRECT_REF_P is true if the function returns by direct + reference. RETURN_BY_INVISI_REF_P is true if the function returns by + invisible reference. */ + +tree +create_subprog_type (tree return_type, tree param_decl_list, tree cico_list, + bool return_unconstrained_p, bool return_by_direct_ref_p, + bool return_by_invisi_ref_p) +{ + /* A chain of TREE_LIST nodes whose TREE_VALUEs are the data type nodes of + the subprogram formal parameters. This list is generated by traversing + the input list of PARM_DECL nodes. */ + tree param_type_list = NULL_TREE; + tree t, type; + + for (t = param_decl_list; t; t = DECL_CHAIN (t)) + param_type_list = tree_cons (NULL_TREE, TREE_TYPE (t), param_type_list); + + /* The list of the function parameter types has to be terminated by the void + type to signal to the back-end that we are not dealing with a variable + parameter subprogram, but that it has a fixed number of parameters. */ + param_type_list = tree_cons (NULL_TREE, void_type_node, param_type_list); + + /* The list of argument types has been created in reverse so reverse it. */ + param_type_list = nreverse (param_type_list); + + type = build_function_type (return_type, param_type_list); + + /* TYPE may have been shared since GCC hashes types. If it has a different + CICO_LIST, make a copy. Likewise for the various flags. */ + if (!fntype_same_flags_p (type, cico_list, return_unconstrained_p, + return_by_direct_ref_p, return_by_invisi_ref_p)) + { + type = copy_type (type); + TYPE_CI_CO_LIST (type) = cico_list; + TYPE_RETURN_UNCONSTRAINED_P (type) = return_unconstrained_p; + TYPE_RETURN_BY_DIRECT_REF_P (type) = return_by_direct_ref_p; + TREE_ADDRESSABLE (type) = return_by_invisi_ref_p; + } + + return type; +} + +/* Return a copy of TYPE but safe to modify in any way. */ + +tree +copy_type (tree type) +{ + tree new_type = copy_node (type); + + /* Unshare the language-specific data. */ + if (TYPE_LANG_SPECIFIC (type)) + { + TYPE_LANG_SPECIFIC (new_type) = NULL; + SET_TYPE_LANG_SPECIFIC (new_type, GET_TYPE_LANG_SPECIFIC (type)); + } + + /* And the contents of the language-specific slot if needed. */ + if ((INTEGRAL_TYPE_P (type) || TREE_CODE (type) == REAL_TYPE) + && TYPE_RM_VALUES (type)) + { + TYPE_RM_VALUES (new_type) = NULL_TREE; + SET_TYPE_RM_SIZE (new_type, TYPE_RM_SIZE (type)); + SET_TYPE_RM_MIN_VALUE (new_type, TYPE_RM_MIN_VALUE (type)); + SET_TYPE_RM_MAX_VALUE (new_type, TYPE_RM_MAX_VALUE (type)); + } + + /* copy_node clears this field instead of copying it, because it is + aliased with TREE_CHAIN. */ + TYPE_STUB_DECL (new_type) = TYPE_STUB_DECL (type); + + TYPE_POINTER_TO (new_type) = 0; + TYPE_REFERENCE_TO (new_type) = 0; + TYPE_MAIN_VARIANT (new_type) = new_type; + TYPE_NEXT_VARIANT (new_type) = 0; + + return new_type; +} + +/* Return a subtype of sizetype with range MIN to MAX and whose + TYPE_INDEX_TYPE is INDEX. GNAT_NODE is used for the position + of the associated TYPE_DECL. */ + +tree +create_index_type (tree min, tree max, tree index, Node_Id gnat_node) +{ + /* First build a type for the desired range. */ + tree type = build_nonshared_range_type (sizetype, min, max); + + /* Then set the index type. */ + SET_TYPE_INDEX_TYPE (type, index); + create_type_decl (NULL_TREE, type, NULL, true, false, gnat_node); + + return type; +} + +/* Return a subtype of TYPE with range MIN to MAX. If TYPE is NULL, + sizetype is used. */ + +tree +create_range_type (tree type, tree min, tree max) +{ + tree range_type; + + if (type == NULL_TREE) + type = sizetype; + + /* First build a type with the base range. */ + range_type = build_nonshared_range_type (type, TYPE_MIN_VALUE (type), + TYPE_MAX_VALUE (type)); + + /* Then set the actual range. */ + SET_TYPE_RM_MIN_VALUE (range_type, convert (type, min)); + SET_TYPE_RM_MAX_VALUE (range_type, convert (type, max)); + + return range_type; +} + +/* Return a TYPE_DECL node suitable for the TYPE_STUB_DECL field of a type. + TYPE_NAME gives the name of the type and TYPE is a ..._TYPE node giving + its data type. */ + +tree +create_type_stub_decl (tree type_name, tree type) +{ + /* Using a named TYPE_DECL ensures that a type name marker is emitted in + STABS while setting DECL_ARTIFICIAL ensures that no DW_TAG_typedef is + emitted in DWARF. */ + tree type_decl = build_decl (input_location, + TYPE_DECL, type_name, type); + DECL_ARTIFICIAL (type_decl) = 1; + return type_decl; +} + +/* Return a TYPE_DECL node. TYPE_NAME gives the name of the type and TYPE + is a ..._TYPE node giving its data type. ARTIFICIAL_P is true if this + is a declaration that was generated by the compiler. DEBUG_INFO_P is + true if we need to write debug information about this type. GNAT_NODE + is used for the position of the decl. */ + +tree +create_type_decl (tree type_name, tree type, struct attrib *attr_list, + bool artificial_p, bool debug_info_p, Node_Id gnat_node) +{ + enum tree_code code = TREE_CODE (type); + bool named = TYPE_NAME (type) && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL; + tree type_decl; + + /* Only the builtin TYPE_STUB_DECL should be used for dummy types. */ + gcc_assert (!TYPE_IS_DUMMY_P (type)); + + /* If the type hasn't been named yet, we're naming it; preserve an existing + TYPE_STUB_DECL that has been attached to it for some purpose. */ + if (!named && TYPE_STUB_DECL (type)) + { + type_decl = TYPE_STUB_DECL (type); + DECL_NAME (type_decl) = type_name; + } + else + type_decl = build_decl (input_location, + TYPE_DECL, type_name, type); + + DECL_ARTIFICIAL (type_decl) = artificial_p; + + /* Add this decl to the current binding level. */ + gnat_pushdecl (type_decl, gnat_node); + + process_attributes (type_decl, attr_list); + + /* If we're naming the type, equate the TYPE_STUB_DECL to the name. + This causes the name to be also viewed as a "tag" by the debug + back-end, with the advantage that no DW_TAG_typedef is emitted + for artificial "tagged" types in DWARF. */ + if (!named) + TYPE_STUB_DECL (type) = type_decl; + + /* Pass the type declaration to the debug back-end unless this is an + UNCONSTRAINED_ARRAY_TYPE that the back-end does not support, or a + type for which debugging information was not requested, or else an + ENUMERAL_TYPE or RECORD_TYPE (except for fat pointers) which are + handled separately. And do not pass dummy types either. */ + if (code == UNCONSTRAINED_ARRAY_TYPE || !debug_info_p) + DECL_IGNORED_P (type_decl) = 1; + else if (code != ENUMERAL_TYPE + && (code != RECORD_TYPE || TYPE_FAT_POINTER_P (type)) + && !((code == POINTER_TYPE || code == REFERENCE_TYPE) + && TYPE_IS_DUMMY_P (TREE_TYPE (type))) + && !(code == RECORD_TYPE + && TYPE_IS_DUMMY_P + (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (type)))))) + rest_of_type_decl_compilation (type_decl); + + return type_decl; +} + +/* Return a VAR_DECL or CONST_DECL node. + + VAR_NAME gives the name of the variable. ASM_NAME is its assembler name + (if provided). TYPE is its data type (a GCC ..._TYPE node). VAR_INIT is + the GCC tree for an optional initial expression; NULL_TREE if none. + + CONST_FLAG is true if this variable is constant, in which case we might + return a CONST_DECL node unless CONST_DECL_ALLOWED_P is false. + + PUBLIC_FLAG is true if this is for a reference to a public entity or for a + definition to be made visible outside of the current compilation unit, for + instance variable definitions in a package specification. + + EXTERN_FLAG is true when processing an external variable declaration (as + opposed to a definition: no storage is to be allocated for the variable). + + STATIC_FLAG is only relevant when not at top level. In that case + it indicates whether to always allocate storage to the variable. + + GNAT_NODE is used for the position of the decl. */ + +tree +create_var_decl_1 (tree var_name, tree asm_name, tree type, tree var_init, + bool const_flag, bool public_flag, bool extern_flag, + bool static_flag, bool const_decl_allowed_p, + struct attrib *attr_list, Node_Id gnat_node) +{ + bool init_const + = (var_init != 0 + && gnat_types_compatible_p (type, TREE_TYPE (var_init)) + && (global_bindings_p () || static_flag + ? initializer_constant_valid_p (var_init, TREE_TYPE (var_init)) != 0 + : TREE_CONSTANT (var_init))); + + /* Whether we will make TREE_CONSTANT the DECL we produce here, in which + case the initializer may be used in-lieu of the DECL node (as done in + Identifier_to_gnu). This is useful to prevent the need of elaboration + code when an identifier for which such a decl is made is in turn used as + an initializer. We used to rely on CONST vs VAR_DECL for this purpose, + but extra constraints apply to this choice (see below) and are not + relevant to the distinction we wish to make. */ + bool constant_p = const_flag && init_const; + + /* The actual DECL node. CONST_DECL was initially intended for enumerals + and may be used for scalars in general but not for aggregates. */ + tree var_decl + = build_decl (input_location, + (constant_p && const_decl_allowed_p + && !AGGREGATE_TYPE_P (type)) ? CONST_DECL : VAR_DECL, + var_name, type); + + /* If this is external, throw away any initializations (they will be done + elsewhere) unless this is a constant for which we would like to remain + able to get the initializer. If we are defining a global here, leave a + constant initialization and save any variable elaborations for the + elaboration routine. If we are just annotating types, throw away the + initialization if it isn't a constant. */ + if ((extern_flag && !constant_p) + || (type_annotate_only && var_init && !TREE_CONSTANT (var_init))) + var_init = NULL_TREE; + + /* At the global level, an initializer requiring code to be generated + produces elaboration statements. Check that such statements are allowed, + that is, not violating a No_Elaboration_Code restriction. */ + if (global_bindings_p () && var_init != 0 && !init_const) + Check_Elaboration_Code_Allowed (gnat_node); + + DECL_INITIAL (var_decl) = var_init; + TREE_READONLY (var_decl) = const_flag; + DECL_EXTERNAL (var_decl) = extern_flag; + TREE_PUBLIC (var_decl) = public_flag || extern_flag; + TREE_CONSTANT (var_decl) = constant_p; + TREE_THIS_VOLATILE (var_decl) = TREE_SIDE_EFFECTS (var_decl) + = TYPE_VOLATILE (type); + + /* Ada doesn't feature Fortran-like COMMON variables so we shouldn't + try to fiddle with DECL_COMMON. However, on platforms that don't + support global BSS sections, uninitialized global variables would + go in DATA instead, thus increasing the size of the executable. */ + if (!flag_no_common + && TREE_CODE (var_decl) == VAR_DECL + && TREE_PUBLIC (var_decl) + && !have_global_bss_p ()) + DECL_COMMON (var_decl) = 1; + + /* At the global binding level, we need to allocate static storage for the + variable if it isn't external. Otherwise, we allocate automatic storage + unless requested not to. */ + TREE_STATIC (var_decl) + = !extern_flag && (static_flag || global_bindings_p ()); + + /* For an external constant whose initializer is not absolute, do not emit + debug info. In DWARF this would mean a global relocation in a read-only + section which runs afoul of the PE-COFF run-time relocation mechanism. */ + if (extern_flag + && constant_p + && initializer_constant_valid_p (var_init, TREE_TYPE (var_init)) + != null_pointer_node) + DECL_IGNORED_P (var_decl) = 1; + + /* Add this decl to the current binding level. */ + gnat_pushdecl (var_decl, gnat_node); + + if (TREE_SIDE_EFFECTS (var_decl)) + TREE_ADDRESSABLE (var_decl) = 1; + + if (TREE_CODE (var_decl) == VAR_DECL) + { + if (asm_name) + SET_DECL_ASSEMBLER_NAME (var_decl, asm_name); + process_attributes (var_decl, attr_list); + if (global_bindings_p ()) + rest_of_decl_compilation (var_decl, true, 0); + } + else + expand_decl (var_decl); + + return var_decl; +} + +/* Return true if TYPE, an aggregate type, contains (or is) an array. */ + +static bool +aggregate_type_contains_array_p (tree type) +{ + switch (TREE_CODE (type)) + { + case RECORD_TYPE: + case UNION_TYPE: + case QUAL_UNION_TYPE: + { + tree field; + for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field)) + if (AGGREGATE_TYPE_P (TREE_TYPE (field)) + && aggregate_type_contains_array_p (TREE_TYPE (field))) + return true; + return false; + } + + case ARRAY_TYPE: + return true; + + default: + gcc_unreachable (); + } +} + +/* Return a FIELD_DECL node. FIELD_NAME is the field's name, FIELD_TYPE is + its type and RECORD_TYPE is the type of the enclosing record. If SIZE is + nonzero, it is the specified size of the field. If POS is nonzero, it is + the bit position. PACKED is 1 if the enclosing record is packed, -1 if it + has Component_Alignment of Storage_Unit. If ADDRESSABLE is nonzero, it + means we are allowed to take the address of the field; if it is negative, + we should not make a bitfield, which is used by make_aligning_type. */ + +tree +create_field_decl (tree field_name, tree field_type, tree record_type, + tree size, tree pos, int packed, int addressable) +{ + tree field_decl = build_decl (input_location, + FIELD_DECL, field_name, field_type); + + DECL_CONTEXT (field_decl) = record_type; + TREE_READONLY (field_decl) = TYPE_READONLY (field_type); + + /* If FIELD_TYPE is BLKmode, we must ensure this is aligned to at least a + byte boundary since GCC cannot handle less-aligned BLKmode bitfields. + Likewise for an aggregate without specified position that contains an + array, because in this case slices of variable length of this array + must be handled by GCC and variable-sized objects need to be aligned + to at least a byte boundary. */ + if (packed && (TYPE_MODE (field_type) == BLKmode + || (!pos + && AGGREGATE_TYPE_P (field_type) + && aggregate_type_contains_array_p (field_type)))) + DECL_ALIGN (field_decl) = BITS_PER_UNIT; + + /* If a size is specified, use it. Otherwise, if the record type is packed + compute a size to use, which may differ from the object's natural size. + We always set a size in this case to trigger the checks for bitfield + creation below, which is typically required when no position has been + specified. */ + if (size) + size = convert (bitsizetype, size); + else if (packed == 1) + { + size = rm_size (field_type); + if (TYPE_MODE (field_type) == BLKmode) + size = round_up (size, BITS_PER_UNIT); + } + + /* If we may, according to ADDRESSABLE, make a bitfield if a size is + specified for two reasons: first if the size differs from the natural + size. Second, if the alignment is insufficient. There are a number of + ways the latter can be true. + + We never make a bitfield if the type of the field has a nonconstant size, + because no such entity requiring bitfield operations should reach here. + + We do *preventively* make a bitfield when there might be the need for it + but we don't have all the necessary information to decide, as is the case + of a field with no specified position in a packed record. + + We also don't look at STRICT_ALIGNMENT here, and rely on later processing + in layout_decl or finish_record_type to clear the bit_field indication if + it is in fact not needed. */ + if (addressable >= 0 + && size + && TREE_CODE (size) == INTEGER_CST + && TREE_CODE (TYPE_SIZE (field_type)) == INTEGER_CST + && (!tree_int_cst_equal (size, TYPE_SIZE (field_type)) + || (pos && !value_factor_p (pos, TYPE_ALIGN (field_type))) + || packed + || (TYPE_ALIGN (record_type) != 0 + && TYPE_ALIGN (record_type) < TYPE_ALIGN (field_type)))) + { + DECL_BIT_FIELD (field_decl) = 1; + DECL_SIZE (field_decl) = size; + if (!packed && !pos) + { + if (TYPE_ALIGN (record_type) != 0 + && TYPE_ALIGN (record_type) < TYPE_ALIGN (field_type)) + DECL_ALIGN (field_decl) = TYPE_ALIGN (record_type); + else + DECL_ALIGN (field_decl) = TYPE_ALIGN (field_type); + } + } + + DECL_PACKED (field_decl) = pos ? DECL_BIT_FIELD (field_decl) : packed; + + /* Bump the alignment if need be, either for bitfield/packing purposes or + to satisfy the type requirements if no such consideration applies. When + we get the alignment from the type, indicate if this is from an explicit + user request, which prevents stor-layout from lowering it later on. */ + { + unsigned int bit_align + = (DECL_BIT_FIELD (field_decl) ? 1 + : packed && TYPE_MODE (field_type) != BLKmode ? BITS_PER_UNIT : 0); + + if (bit_align > DECL_ALIGN (field_decl)) + DECL_ALIGN (field_decl) = bit_align; + else if (!bit_align && TYPE_ALIGN (field_type) > DECL_ALIGN (field_decl)) + { + DECL_ALIGN (field_decl) = TYPE_ALIGN (field_type); + DECL_USER_ALIGN (field_decl) = TYPE_USER_ALIGN (field_type); + } + } + + if (pos) + { + /* We need to pass in the alignment the DECL is known to have. + This is the lowest-order bit set in POS, but no more than + the alignment of the record, if one is specified. Note + that an alignment of 0 is taken as infinite. */ + unsigned int known_align; + + if (host_integerp (pos, 1)) + known_align = tree_low_cst (pos, 1) & - tree_low_cst (pos, 1); + else + known_align = BITS_PER_UNIT; + + if (TYPE_ALIGN (record_type) + && (known_align == 0 || known_align > TYPE_ALIGN (record_type))) + known_align = TYPE_ALIGN (record_type); + + layout_decl (field_decl, known_align); + SET_DECL_OFFSET_ALIGN (field_decl, + host_integerp (pos, 1) ? BIGGEST_ALIGNMENT + : BITS_PER_UNIT); + pos_from_bit (&DECL_FIELD_OFFSET (field_decl), + &DECL_FIELD_BIT_OFFSET (field_decl), + DECL_OFFSET_ALIGN (field_decl), pos); + } + + /* In addition to what our caller says, claim the field is addressable if we + know that its type is not suitable. + + The field may also be "technically" nonaddressable, meaning that even if + we attempt to take the field's address we will actually get the address + of a copy. This is the case for true bitfields, but the DECL_BIT_FIELD + value we have at this point is not accurate enough, so we don't account + for this here and let finish_record_type decide. */ + if (!addressable && !type_for_nonaliased_component_p (field_type)) + addressable = 1; + + DECL_NONADDRESSABLE_P (field_decl) = !addressable; + + return field_decl; +} + +/* Return a PARM_DECL node. PARAM_NAME is the name of the parameter and + PARAM_TYPE is its type. READONLY is true if the parameter is readonly + (either an In parameter or an address of a pass-by-ref parameter). */ + +tree +create_param_decl (tree param_name, tree param_type, bool readonly) +{ + tree param_decl = build_decl (input_location, + PARM_DECL, param_name, param_type); + + /* Honor TARGET_PROMOTE_PROTOTYPES like the C compiler, as not doing so + can lead to various ABI violations. */ + if (targetm.calls.promote_prototypes (NULL_TREE) + && INTEGRAL_TYPE_P (param_type) + && TYPE_PRECISION (param_type) < TYPE_PRECISION (integer_type_node)) + { + /* We have to be careful about biased types here. Make a subtype + of integer_type_node with the proper biasing. */ + if (TREE_CODE (param_type) == INTEGER_TYPE + && TYPE_BIASED_REPRESENTATION_P (param_type)) + { + tree subtype + = make_unsigned_type (TYPE_PRECISION (integer_type_node)); + TREE_TYPE (subtype) = integer_type_node; + TYPE_BIASED_REPRESENTATION_P (subtype) = 1; + SET_TYPE_RM_MIN_VALUE (subtype, TYPE_MIN_VALUE (param_type)); + SET_TYPE_RM_MAX_VALUE (subtype, TYPE_MAX_VALUE (param_type)); + param_type = subtype; + } + else + param_type = integer_type_node; + } + + DECL_ARG_TYPE (param_decl) = param_type; + TREE_READONLY (param_decl) = readonly; + return param_decl; +} + +/* Given a DECL and ATTR_LIST, process the listed attributes. */ + +static void +process_attributes (tree decl, struct attrib *attr_list) +{ + for (; attr_list; attr_list = attr_list->next) + switch (attr_list->type) + { + case ATTR_MACHINE_ATTRIBUTE: + input_location = DECL_SOURCE_LOCATION (decl); + decl_attributes (&decl, tree_cons (attr_list->name, attr_list->args, + NULL_TREE), + ATTR_FLAG_TYPE_IN_PLACE); + break; + + case ATTR_LINK_ALIAS: + if (! DECL_EXTERNAL (decl)) + { + TREE_STATIC (decl) = 1; + assemble_alias (decl, attr_list->name); + } + break; + + case ATTR_WEAK_EXTERNAL: + if (SUPPORTS_WEAK) + declare_weak (decl); + else + post_error ("?weak declarations not supported on this target", + attr_list->error_point); + break; + + case ATTR_LINK_SECTION: + if (targetm.have_named_sections) + { + DECL_SECTION_NAME (decl) + = build_string (IDENTIFIER_LENGTH (attr_list->name), + IDENTIFIER_POINTER (attr_list->name)); + DECL_COMMON (decl) = 0; + } + else + post_error ("?section attributes are not supported for this target", + attr_list->error_point); + break; + + case ATTR_LINK_CONSTRUCTOR: + DECL_STATIC_CONSTRUCTOR (decl) = 1; + TREE_USED (decl) = 1; + break; + + case ATTR_LINK_DESTRUCTOR: + DECL_STATIC_DESTRUCTOR (decl) = 1; + TREE_USED (decl) = 1; + break; + + case ATTR_THREAD_LOCAL_STORAGE: + DECL_TLS_MODEL (decl) = decl_default_tls_model (decl); + DECL_COMMON (decl) = 0; + break; + } +} + +/* Record DECL as a global renaming pointer. */ + +void +record_global_renaming_pointer (tree decl) +{ + gcc_assert (DECL_RENAMED_OBJECT (decl)); + VEC_safe_push (tree, gc, global_renaming_pointers, decl); +} + +/* Invalidate the global renaming pointers. */ + +void +invalidate_global_renaming_pointers (void) +{ + unsigned int i; + tree iter; + + FOR_EACH_VEC_ELT (tree, global_renaming_pointers, i, iter) + SET_DECL_RENAMED_OBJECT (iter, NULL_TREE); + + VEC_free (tree, gc, global_renaming_pointers); +} + +/* Return true if VALUE is a known to be a multiple of FACTOR, which must be + a power of 2. */ + +bool +value_factor_p (tree value, HOST_WIDE_INT factor) +{ + if (host_integerp (value, 1)) + return tree_low_cst (value, 1) % factor == 0; + + if (TREE_CODE (value) == MULT_EXPR) + return (value_factor_p (TREE_OPERAND (value, 0), factor) + || value_factor_p (TREE_OPERAND (value, 1), factor)); + + return false; +} + +/* Given 2 consecutive field decls PREV_FIELD and CURR_FIELD, return true + unless we can prove these 2 fields are laid out in such a way that no gap + exist between the end of PREV_FIELD and the beginning of CURR_FIELD. OFFSET + is the distance in bits between the end of PREV_FIELD and the starting + position of CURR_FIELD. It is ignored if null. */ + +static bool +potential_alignment_gap (tree prev_field, tree curr_field, tree offset) +{ + /* If this is the first field of the record, there cannot be any gap */ + if (!prev_field) + return false; + + /* If the previous field is a union type, then return False: The only + time when such a field is not the last field of the record is when + there are other components at fixed positions after it (meaning there + was a rep clause for every field), in which case we don't want the + alignment constraint to override them. */ + if (TREE_CODE (TREE_TYPE (prev_field)) == QUAL_UNION_TYPE) + return false; + + /* If the distance between the end of prev_field and the beginning of + curr_field is constant, then there is a gap if the value of this + constant is not null. */ + if (offset && host_integerp (offset, 1)) + return !integer_zerop (offset); + + /* If the size and position of the previous field are constant, + then check the sum of this size and position. There will be a gap + iff it is not multiple of the current field alignment. */ + if (host_integerp (DECL_SIZE (prev_field), 1) + && host_integerp (bit_position (prev_field), 1)) + return ((tree_low_cst (bit_position (prev_field), 1) + + tree_low_cst (DECL_SIZE (prev_field), 1)) + % DECL_ALIGN (curr_field) != 0); + + /* If both the position and size of the previous field are multiples + of the current field alignment, there cannot be any gap. */ + if (value_factor_p (bit_position (prev_field), DECL_ALIGN (curr_field)) + && value_factor_p (DECL_SIZE (prev_field), DECL_ALIGN (curr_field))) + return false; + + /* Fallback, return that there may be a potential gap */ + return true; +} + +/* Returns a LABEL_DECL node for LABEL_NAME. */ + +tree +create_label_decl (tree label_name) +{ + tree label_decl = build_decl (input_location, + LABEL_DECL, label_name, void_type_node); + + DECL_CONTEXT (label_decl) = current_function_decl; + DECL_MODE (label_decl) = VOIDmode; + DECL_SOURCE_LOCATION (label_decl) = input_location; + + return label_decl; +} + +/* Returns a FUNCTION_DECL node. SUBPROG_NAME is the name of the subprogram, + ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE + node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of + PARM_DECL nodes chained through the TREE_CHAIN field). + + INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, and ATTR_LIST are used to set the + appropriate fields in the FUNCTION_DECL. GNAT_NODE gives the location. */ + +tree +create_subprog_decl (tree subprog_name, tree asm_name, + tree subprog_type, tree param_decl_list, bool inline_flag, + bool public_flag, bool extern_flag, + struct attrib *attr_list, Node_Id gnat_node) +{ + tree subprog_decl = build_decl (input_location, FUNCTION_DECL, subprog_name, + subprog_type); + tree result_decl = build_decl (input_location, RESULT_DECL, NULL_TREE, + TREE_TYPE (subprog_type)); + + /* If this is a non-inline function nested inside an inlined external + function, we cannot honor both requests without cloning the nested + function in the current unit since it is private to the other unit. + We could inline the nested function as well but it's probably better + to err on the side of too little inlining. */ + if (!inline_flag + && current_function_decl + && DECL_DECLARED_INLINE_P (current_function_decl) + && DECL_EXTERNAL (current_function_decl)) + DECL_DECLARED_INLINE_P (current_function_decl) = 0; + + DECL_EXTERNAL (subprog_decl) = extern_flag; + TREE_PUBLIC (subprog_decl) = public_flag; + TREE_READONLY (subprog_decl) = TYPE_READONLY (subprog_type); + TREE_THIS_VOLATILE (subprog_decl) = TYPE_VOLATILE (subprog_type); + TREE_SIDE_EFFECTS (subprog_decl) = TYPE_VOLATILE (subprog_type); + DECL_DECLARED_INLINE_P (subprog_decl) = inline_flag; + DECL_ARGUMENTS (subprog_decl) = param_decl_list; + + DECL_ARTIFICIAL (result_decl) = 1; + DECL_IGNORED_P (result_decl) = 1; + DECL_BY_REFERENCE (result_decl) = TREE_ADDRESSABLE (subprog_type); + DECL_RESULT (subprog_decl) = result_decl; + + if (asm_name) + { + SET_DECL_ASSEMBLER_NAME (subprog_decl, asm_name); + + /* The expand_main_function circuitry expects "main_identifier_node" to + designate the DECL_NAME of the 'main' entry point, in turn expected + to be declared as the "main" function literally by default. Ada + program entry points are typically declared with a different name + within the binder generated file, exported as 'main' to satisfy the + system expectations. Force main_identifier_node in this case. */ + if (asm_name == main_identifier_node) + DECL_NAME (subprog_decl) = main_identifier_node; + } + + /* Add this decl to the current binding level. */ + gnat_pushdecl (subprog_decl, gnat_node); + + process_attributes (subprog_decl, attr_list); + + /* Output the assembler code and/or RTL for the declaration. */ + rest_of_decl_compilation (subprog_decl, global_bindings_p (), 0); + + return subprog_decl; +} + +/* Set up the framework for generating code for SUBPROG_DECL, a subprogram + body. This routine needs to be invoked before processing the declarations + appearing in the subprogram. */ + +void +begin_subprog_body (tree subprog_decl) +{ + tree param_decl; + + announce_function (subprog_decl); + + /* This function is being defined. */ + TREE_STATIC (subprog_decl) = 1; + + current_function_decl = subprog_decl; + + /* Enter a new binding level and show that all the parameters belong to + this function. */ + gnat_pushlevel (); + + for (param_decl = DECL_ARGUMENTS (subprog_decl); param_decl; + param_decl = DECL_CHAIN (param_decl)) + DECL_CONTEXT (param_decl) = subprog_decl; + + make_decl_rtl (subprog_decl); + + /* We handle pending sizes via the elaboration of types, so we don't need to + save them. This causes them to be marked as part of the outer function + and then discarded. */ + get_pending_sizes (); +} + +/* Finish the definition of the current subprogram BODY and finalize it. */ + +void +end_subprog_body (tree body) +{ + tree fndecl = current_function_decl; + + /* Attach the BLOCK for this level to the function and pop the level. */ + BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl; + DECL_INITIAL (fndecl) = current_binding_level->block; + gnat_poplevel (); + + /* We handle pending sizes via the elaboration of types, so we don't + need to save them. */ + get_pending_sizes (); + + /* Mark the RESULT_DECL as being in this subprogram. */ + DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl; + + /* The body should be a BIND_EXPR whose BLOCK is the top-level one. */ + if (TREE_CODE (body) == BIND_EXPR) + { + BLOCK_SUPERCONTEXT (BIND_EXPR_BLOCK (body)) = fndecl; + DECL_INITIAL (fndecl) = BIND_EXPR_BLOCK (body); + } + + DECL_SAVED_TREE (fndecl) = body; + + current_function_decl = DECL_CONTEXT (fndecl); + + /* We cannot track the location of errors past this point. */ + error_gnat_node = Empty; + + /* If we're only annotating types, don't actually compile this function. */ + if (type_annotate_only) + return; + + /* Dump functions before gimplification. */ + dump_function (TDI_original, fndecl); + + /* ??? This special handling of nested functions is probably obsolete. */ + if (!DECL_CONTEXT (fndecl)) + cgraph_finalize_function (fndecl, false); + else + /* Register this function with cgraph just far enough to get it + added to our parent's nested function list. */ + (void) cgraph_node (fndecl); +} + +tree +gnat_builtin_function (tree decl) +{ + gnat_pushdecl (decl, Empty); + return decl; +} + +/* Return an integer type with the number of bits of precision given by + PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise + it is a signed type. */ + +tree +gnat_type_for_size (unsigned precision, int unsignedp) +{ + tree t; + char type_name[20]; + + if (precision <= 2 * MAX_BITS_PER_WORD + && signed_and_unsigned_types[precision][unsignedp]) + return signed_and_unsigned_types[precision][unsignedp]; + + if (unsignedp) + t = make_unsigned_type (precision); + else + t = make_signed_type (precision); + + if (precision <= 2 * MAX_BITS_PER_WORD) + signed_and_unsigned_types[precision][unsignedp] = t; + + if (!TYPE_NAME (t)) + { + sprintf (type_name, "%sSIGNED_%d", unsignedp ? "UN" : "", precision); + TYPE_NAME (t) = get_identifier (type_name); + } + + return t; +} + +/* Likewise for floating-point types. */ + +static tree +float_type_for_precision (int precision, enum machine_mode mode) +{ + tree t; + char type_name[20]; + + if (float_types[(int) mode]) + return float_types[(int) mode]; + + float_types[(int) mode] = t = make_node (REAL_TYPE); + TYPE_PRECISION (t) = precision; + layout_type (t); + + gcc_assert (TYPE_MODE (t) == mode); + if (!TYPE_NAME (t)) + { + sprintf (type_name, "FLOAT_%d", precision); + TYPE_NAME (t) = get_identifier (type_name); + } + + return t; +} + +/* Return a data type that has machine mode MODE. UNSIGNEDP selects + an unsigned type; otherwise a signed type is returned. */ + +tree +gnat_type_for_mode (enum machine_mode mode, int unsignedp) +{ + if (mode == BLKmode) + return NULL_TREE; + + if (mode == VOIDmode) + return void_type_node; + + if (COMPLEX_MODE_P (mode)) + return NULL_TREE; + + if (SCALAR_FLOAT_MODE_P (mode)) + return float_type_for_precision (GET_MODE_PRECISION (mode), mode); + + if (SCALAR_INT_MODE_P (mode)) + return gnat_type_for_size (GET_MODE_BITSIZE (mode), unsignedp); + + if (VECTOR_MODE_P (mode)) + { + enum machine_mode inner_mode = GET_MODE_INNER (mode); + tree inner_type = gnat_type_for_mode (inner_mode, unsignedp); + if (inner_type) + return build_vector_type_for_mode (inner_type, mode); + } + + return NULL_TREE; +} + +/* Return the unsigned version of a TYPE_NODE, a scalar type. */ + +tree +gnat_unsigned_type (tree type_node) +{ + tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 1); + + if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node)) + { + type = copy_node (type); + TREE_TYPE (type) = type_node; + } + else if (TREE_TYPE (type_node) + && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE + && TYPE_MODULAR_P (TREE_TYPE (type_node))) + { + type = copy_node (type); + TREE_TYPE (type) = TREE_TYPE (type_node); + } + + return type; +} + +/* Return the signed version of a TYPE_NODE, a scalar type. */ + +tree +gnat_signed_type (tree type_node) +{ + tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 0); + + if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node)) + { + type = copy_node (type); + TREE_TYPE (type) = type_node; + } + else if (TREE_TYPE (type_node) + && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE + && TYPE_MODULAR_P (TREE_TYPE (type_node))) + { + type = copy_node (type); + TREE_TYPE (type) = TREE_TYPE (type_node); + } + + return type; +} + +/* Return 1 if the types T1 and T2 are compatible, i.e. if they can be + transparently converted to each other. */ + +int +gnat_types_compatible_p (tree t1, tree t2) +{ + enum tree_code code; + + /* This is the default criterion. */ + if (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2)) + return 1; + + /* We only check structural equivalence here. */ + if ((code = TREE_CODE (t1)) != TREE_CODE (t2)) + return 0; + + /* Vector types are also compatible if they have the same number of subparts + and the same form of (scalar) element type. */ + if (code == VECTOR_TYPE + && TYPE_VECTOR_SUBPARTS (t1) == TYPE_VECTOR_SUBPARTS (t2) + && TREE_CODE (TREE_TYPE (t1)) == TREE_CODE (TREE_TYPE (t2)) + && TYPE_PRECISION (TREE_TYPE (t1)) == TYPE_PRECISION (TREE_TYPE (t2))) + return 1; + + /* Array types are also compatible if they are constrained and have the same + domain(s) and the same component type. */ + if (code == ARRAY_TYPE + && (TYPE_DOMAIN (t1) == TYPE_DOMAIN (t2) + || (TYPE_DOMAIN (t1) + && TYPE_DOMAIN (t2) + && tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (t1)), + TYPE_MIN_VALUE (TYPE_DOMAIN (t2))) + && tree_int_cst_equal (TYPE_MAX_VALUE (TYPE_DOMAIN (t1)), + TYPE_MAX_VALUE (TYPE_DOMAIN (t2))))) + && (TREE_TYPE (t1) == TREE_TYPE (t2) + || (TREE_CODE (TREE_TYPE (t1)) == ARRAY_TYPE + && gnat_types_compatible_p (TREE_TYPE (t1), TREE_TYPE (t2))))) + return 1; + + /* Padding record types are also compatible if they pad the same + type and have the same constant size. */ + if (code == RECORD_TYPE + && TYPE_PADDING_P (t1) && TYPE_PADDING_P (t2) + && TREE_TYPE (TYPE_FIELDS (t1)) == TREE_TYPE (TYPE_FIELDS (t2)) + && tree_int_cst_equal (TYPE_SIZE (t1), TYPE_SIZE (t2))) + return 1; + + return 0; +} + +/* Return true if T, a FUNCTION_TYPE, has the specified list of flags. */ + +bool +fntype_same_flags_p (const_tree t, tree cico_list, bool return_unconstrained_p, + bool return_by_direct_ref_p, bool return_by_invisi_ref_p) +{ + return TYPE_CI_CO_LIST (t) == cico_list + && TYPE_RETURN_UNCONSTRAINED_P (t) == return_unconstrained_p + && TYPE_RETURN_BY_DIRECT_REF_P (t) == return_by_direct_ref_p + && TREE_ADDRESSABLE (t) == return_by_invisi_ref_p; +} + +/* EXP is an expression for the size of an object. If this size contains + discriminant references, replace them with the maximum (if MAX_P) or + minimum (if !MAX_P) possible value of the discriminant. */ + +tree +max_size (tree exp, bool max_p) +{ + enum tree_code code = TREE_CODE (exp); + tree type = TREE_TYPE (exp); + + switch (TREE_CODE_CLASS (code)) + { + case tcc_declaration: + case tcc_constant: + return exp; + + case tcc_vl_exp: + if (code == CALL_EXPR) + { + tree t, *argarray; + int n, i; + + t = maybe_inline_call_in_expr (exp); + if (t) + return max_size (t, max_p); + + n = call_expr_nargs (exp); + gcc_assert (n > 0); + argarray = XALLOCAVEC (tree, n); + for (i = 0; i < n; i++) + argarray[i] = max_size (CALL_EXPR_ARG (exp, i), max_p); + return build_call_array (type, CALL_EXPR_FN (exp), n, argarray); + } + break; + + case tcc_reference: + /* If this contains a PLACEHOLDER_EXPR, it is the thing we want to + modify. Otherwise, we treat it like a variable. */ + if (!CONTAINS_PLACEHOLDER_P (exp)) + return exp; + + type = TREE_TYPE (TREE_OPERAND (exp, 1)); + return + max_size (max_p ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type), true); + + case tcc_comparison: + return max_p ? size_one_node : size_zero_node; + + case tcc_unary: + case tcc_binary: + case tcc_expression: + switch (TREE_CODE_LENGTH (code)) + { + case 1: + if (code == NON_LVALUE_EXPR) + return max_size (TREE_OPERAND (exp, 0), max_p); + else + return + fold_build1 (code, type, + max_size (TREE_OPERAND (exp, 0), + code == NEGATE_EXPR ? !max_p : max_p)); + + case 2: + if (code == COMPOUND_EXPR) + return max_size (TREE_OPERAND (exp, 1), max_p); + + { + tree lhs = max_size (TREE_OPERAND (exp, 0), max_p); + tree rhs = max_size (TREE_OPERAND (exp, 1), + code == MINUS_EXPR ? !max_p : max_p); + + /* Special-case wanting the maximum value of a MIN_EXPR. + In that case, if one side overflows, return the other. + sizetype is signed, but we know sizes are non-negative. + Likewise, handle a MINUS_EXPR or PLUS_EXPR with the LHS + overflowing and the RHS a variable. */ + if (max_p + && code == MIN_EXPR + && TREE_CODE (rhs) == INTEGER_CST + && TREE_OVERFLOW (rhs)) + return lhs; + else if (max_p + && code == MIN_EXPR + && TREE_CODE (lhs) == INTEGER_CST + && TREE_OVERFLOW (lhs)) + return rhs; + else if ((code == MINUS_EXPR || code == PLUS_EXPR) + && TREE_CODE (lhs) == INTEGER_CST + && TREE_OVERFLOW (lhs) + && !TREE_CONSTANT (rhs)) + return lhs; + else + return fold_build2 (code, type, lhs, rhs); + } + + case 3: + if (code == SAVE_EXPR) + return exp; + else if (code == COND_EXPR) + return fold_build2 (max_p ? MAX_EXPR : MIN_EXPR, type, + max_size (TREE_OPERAND (exp, 1), max_p), + max_size (TREE_OPERAND (exp, 2), max_p)); + } + + /* Other tree classes cannot happen. */ + default: + break; + } + + gcc_unreachable (); +} + +/* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE. + EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs. + Return a constructor for the template. */ + +tree +build_template (tree template_type, tree array_type, tree expr) +{ + VEC(constructor_elt,gc) *template_elts = NULL; + tree bound_list = NULL_TREE; + tree field; + + while (TREE_CODE (array_type) == RECORD_TYPE + && (TYPE_PADDING_P (array_type) + || TYPE_JUSTIFIED_MODULAR_P (array_type))) + array_type = TREE_TYPE (TYPE_FIELDS (array_type)); + + if (TREE_CODE (array_type) == ARRAY_TYPE + || (TREE_CODE (array_type) == INTEGER_TYPE + && TYPE_HAS_ACTUAL_BOUNDS_P (array_type))) + bound_list = TYPE_ACTUAL_BOUNDS (array_type); + + /* First make the list for a CONSTRUCTOR for the template. Go down the + field list of the template instead of the type chain because this + array might be an Ada array of arrays and we can't tell where the + nested arrays stop being the underlying object. */ + + for (field = TYPE_FIELDS (template_type); field; + (bound_list + ? (bound_list = TREE_CHAIN (bound_list)) + : (array_type = TREE_TYPE (array_type))), + field = DECL_CHAIN (DECL_CHAIN (field))) + { + tree bounds, min, max; + + /* If we have a bound list, get the bounds from there. Likewise + for an ARRAY_TYPE. Otherwise, if expr is a PARM_DECL with + DECL_BY_COMPONENT_PTR_P, use the bounds of the field in the template. + This will give us a maximum range. */ + if (bound_list) + bounds = TREE_VALUE (bound_list); + else if (TREE_CODE (array_type) == ARRAY_TYPE) + bounds = TYPE_INDEX_TYPE (TYPE_DOMAIN (array_type)); + else if (expr && TREE_CODE (expr) == PARM_DECL + && DECL_BY_COMPONENT_PTR_P (expr)) + bounds = TREE_TYPE (field); + else + gcc_unreachable (); + + min = convert (TREE_TYPE (field), TYPE_MIN_VALUE (bounds)); + max = convert (TREE_TYPE (DECL_CHAIN (field)), TYPE_MAX_VALUE (bounds)); + + /* If either MIN or MAX involve a PLACEHOLDER_EXPR, we must + substitute it from OBJECT. */ + min = SUBSTITUTE_PLACEHOLDER_IN_EXPR (min, expr); + max = SUBSTITUTE_PLACEHOLDER_IN_EXPR (max, expr); + + CONSTRUCTOR_APPEND_ELT (template_elts, field, min); + CONSTRUCTOR_APPEND_ELT (template_elts, DECL_CHAIN (field), max); + } + + return gnat_build_constructor (template_type, template_elts); +} + +/* Helper routine to make a descriptor field. FIELD_LIST is the list of decls + being built; the new decl is chained on to the front of the list. */ + +static tree +make_descriptor_field (const char *name, tree type, tree rec_type, + tree initial, tree field_list) +{ + tree field + = create_field_decl (get_identifier (name), type, rec_type, NULL_TREE, + NULL_TREE, 0, 0); + + DECL_INITIAL (field) = initial; + DECL_CHAIN (field) = field_list; + return field; +} + +/* Build a 32-bit VMS descriptor from a Mechanism_Type, which must specify a + descriptor type, and the GCC type of an object. Each FIELD_DECL in the + type contains in its DECL_INITIAL the expression to use when a constructor + is made for the type. GNAT_ENTITY is an entity used to print out an error + message if the mechanism cannot be applied to an object of that type and + also for the name. */ + +tree +build_vms_descriptor32 (tree type, Mechanism_Type mech, Entity_Id gnat_entity) +{ + tree record_type = make_node (RECORD_TYPE); + tree pointer32_type, pointer64_type; + tree field_list = NULL_TREE; + int klass, ndim, i, dtype = 0; + tree inner_type, tem; + tree *idx_arr; + + /* If TYPE is an unconstrained array, use the underlying array type. */ + if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) + type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))); + + /* If this is an array, compute the number of dimensions in the array, + get the index types, and point to the inner type. */ + if (TREE_CODE (type) != ARRAY_TYPE) + ndim = 0; + else + for (ndim = 1, inner_type = type; + TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type)); + ndim++, inner_type = TREE_TYPE (inner_type)) + ; + + idx_arr = XALLOCAVEC (tree, ndim); + + if (mech != By_Descriptor_NCA && mech != By_Short_Descriptor_NCA + && TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type)) + for (i = ndim - 1, inner_type = type; + i >= 0; + i--, inner_type = TREE_TYPE (inner_type)) + idx_arr[i] = TYPE_DOMAIN (inner_type); + else + for (i = 0, inner_type = type; + i < ndim; + i++, inner_type = TREE_TYPE (inner_type)) + idx_arr[i] = TYPE_DOMAIN (inner_type); + + /* Now get the DTYPE value. */ + switch (TREE_CODE (type)) + { + case INTEGER_TYPE: + case ENUMERAL_TYPE: + case BOOLEAN_TYPE: + if (TYPE_VAX_FLOATING_POINT_P (type)) + switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1)) + { + case 6: + dtype = 10; + break; + case 9: + dtype = 11; + break; + case 15: + dtype = 27; + break; + } + else + switch (GET_MODE_BITSIZE (TYPE_MODE (type))) + { + case 8: + dtype = TYPE_UNSIGNED (type) ? 2 : 6; + break; + case 16: + dtype = TYPE_UNSIGNED (type) ? 3 : 7; + break; + case 32: + dtype = TYPE_UNSIGNED (type) ? 4 : 8; + break; + case 64: + dtype = TYPE_UNSIGNED (type) ? 5 : 9; + break; + case 128: + dtype = TYPE_UNSIGNED (type) ? 25 : 26; + break; + } + break; + + case REAL_TYPE: + dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53; + break; + + case COMPLEX_TYPE: + if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE + && TYPE_VAX_FLOATING_POINT_P (type)) + switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1)) + { + case 6: + dtype = 12; + break; + case 9: + dtype = 13; + break; + case 15: + dtype = 29; + } + else + dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55; + break; + + case ARRAY_TYPE: + dtype = 14; + break; + + default: + break; + } + + /* Get the CLASS value. */ + switch (mech) + { + case By_Descriptor_A: + case By_Short_Descriptor_A: + klass = 4; + break; + case By_Descriptor_NCA: + case By_Short_Descriptor_NCA: + klass = 10; + break; + case By_Descriptor_SB: + case By_Short_Descriptor_SB: + klass = 15; + break; + case By_Descriptor: + case By_Short_Descriptor: + case By_Descriptor_S: + case By_Short_Descriptor_S: + default: + klass = 1; + break; + } + + /* Make the type for a descriptor for VMS. The first four fields are the + same for all types. */ + field_list + = make_descriptor_field ("LENGTH", gnat_type_for_size (16, 1), record_type, + size_in_bytes ((mech == By_Descriptor_A + || mech == By_Short_Descriptor_A) + ? inner_type : type), + field_list); + field_list + = make_descriptor_field ("DTYPE", gnat_type_for_size (8, 1), record_type, + size_int (dtype), field_list); + field_list + = make_descriptor_field ("CLASS", gnat_type_for_size (8, 1), record_type, + size_int (klass), field_list); + + pointer32_type = build_pointer_type_for_mode (type, SImode, false); + pointer64_type = build_pointer_type_for_mode (type, DImode, false); + + /* Ensure that only 32-bit pointers are passed in 32-bit descriptors. Note + that we cannot build a template call to the CE routine as it would get a + wrong source location; instead we use a second placeholder for it. */ + tem = build_unary_op (ADDR_EXPR, pointer64_type, + build0 (PLACEHOLDER_EXPR, type)); + tem = build3 (COND_EXPR, pointer32_type, + build_binary_op (GE_EXPR, boolean_type_node, tem, + build_int_cstu (pointer64_type, 0x80000000)), + build0 (PLACEHOLDER_EXPR, void_type_node), + convert (pointer32_type, tem)); + + field_list + = make_descriptor_field ("POINTER", pointer32_type, record_type, tem, + field_list); + + switch (mech) + { + case By_Descriptor: + case By_Short_Descriptor: + case By_Descriptor_S: + case By_Short_Descriptor_S: + break; + + case By_Descriptor_SB: + case By_Short_Descriptor_SB: + field_list + = make_descriptor_field ("SB_L1", gnat_type_for_size (32, 1), + record_type, + (TREE_CODE (type) == ARRAY_TYPE + ? TYPE_MIN_VALUE (TYPE_DOMAIN (type)) + : size_zero_node), + field_list); + field_list + = make_descriptor_field ("SB_U1", gnat_type_for_size (32, 1), + record_type, + (TREE_CODE (type) == ARRAY_TYPE + ? TYPE_MAX_VALUE (TYPE_DOMAIN (type)) + : size_zero_node), + field_list); + break; + + case By_Descriptor_A: + case By_Short_Descriptor_A: + case By_Descriptor_NCA: + case By_Short_Descriptor_NCA: + field_list + = make_descriptor_field ("SCALE", gnat_type_for_size (8, 1), + record_type, size_zero_node, field_list); + + field_list + = make_descriptor_field ("DIGITS", gnat_type_for_size (8, 1), + record_type, size_zero_node, field_list); + + field_list + = make_descriptor_field ("AFLAGS", gnat_type_for_size (8, 1), + record_type, + size_int ((mech == By_Descriptor_NCA + || mech == By_Short_Descriptor_NCA) + ? 0 + /* Set FL_COLUMN, FL_COEFF, and + FL_BOUNDS. */ + : (TREE_CODE (type) == ARRAY_TYPE + && TYPE_CONVENTION_FORTRAN_P + (type) + ? 224 : 192)), + field_list); + + field_list + = make_descriptor_field ("DIMCT", gnat_type_for_size (8, 1), + record_type, size_int (ndim), field_list); + + field_list + = make_descriptor_field ("ARSIZE", gnat_type_for_size (32, 1), + record_type, size_in_bytes (type), + field_list); + + /* Now build a pointer to the 0,0,0... element. */ + tem = build0 (PLACEHOLDER_EXPR, type); + for (i = 0, inner_type = type; i < ndim; + i++, inner_type = TREE_TYPE (inner_type)) + tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem, + convert (TYPE_DOMAIN (inner_type), size_zero_node), + NULL_TREE, NULL_TREE); + + field_list + = make_descriptor_field ("A0", pointer32_type, record_type, + build1 (ADDR_EXPR, pointer32_type, tem), + field_list); + + /* Next come the addressing coefficients. */ + tem = size_one_node; + for (i = 0; i < ndim; i++) + { + char fname[3]; + tree idx_length + = size_binop (MULT_EXPR, tem, + size_binop (PLUS_EXPR, + size_binop (MINUS_EXPR, + TYPE_MAX_VALUE (idx_arr[i]), + TYPE_MIN_VALUE (idx_arr[i])), + size_int (1))); + + fname[0] = ((mech == By_Descriptor_NCA || + mech == By_Short_Descriptor_NCA) ? 'S' : 'M'); + fname[1] = '0' + i, fname[2] = 0; + field_list + = make_descriptor_field (fname, gnat_type_for_size (32, 1), + record_type, idx_length, field_list); + + if (mech == By_Descriptor_NCA || mech == By_Short_Descriptor_NCA) + tem = idx_length; + } + + /* Finally here are the bounds. */ + for (i = 0; i < ndim; i++) + { + char fname[3]; + + fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0; + field_list + = make_descriptor_field (fname, gnat_type_for_size (32, 1), + record_type, TYPE_MIN_VALUE (idx_arr[i]), + field_list); + + fname[0] = 'U'; + field_list + = make_descriptor_field (fname, gnat_type_for_size (32, 1), + record_type, TYPE_MAX_VALUE (idx_arr[i]), + field_list); + } + break; + + default: + post_error ("unsupported descriptor type for &", gnat_entity); + } + + TYPE_NAME (record_type) = create_concat_name (gnat_entity, "DESC"); + finish_record_type (record_type, nreverse (field_list), 0, false); + return record_type; +} + +/* Build a 64-bit VMS descriptor from a Mechanism_Type, which must specify a + descriptor type, and the GCC type of an object. Each FIELD_DECL in the + type contains in its DECL_INITIAL the expression to use when a constructor + is made for the type. GNAT_ENTITY is an entity used to print out an error + message if the mechanism cannot be applied to an object of that type and + also for the name. */ + +tree +build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity) +{ + tree record_type = make_node (RECORD_TYPE); + tree pointer64_type; + tree field_list = NULL_TREE; + int klass, ndim, i, dtype = 0; + tree inner_type, tem; + tree *idx_arr; + + /* If TYPE is an unconstrained array, use the underlying array type. */ + if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) + type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))); + + /* If this is an array, compute the number of dimensions in the array, + get the index types, and point to the inner type. */ + if (TREE_CODE (type) != ARRAY_TYPE) + ndim = 0; + else + for (ndim = 1, inner_type = type; + TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type)); + ndim++, inner_type = TREE_TYPE (inner_type)) + ; + + idx_arr = XALLOCAVEC (tree, ndim); + + if (mech != By_Descriptor_NCA + && TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type)) + for (i = ndim - 1, inner_type = type; + i >= 0; + i--, inner_type = TREE_TYPE (inner_type)) + idx_arr[i] = TYPE_DOMAIN (inner_type); + else + for (i = 0, inner_type = type; + i < ndim; + i++, inner_type = TREE_TYPE (inner_type)) + idx_arr[i] = TYPE_DOMAIN (inner_type); + + /* Now get the DTYPE value. */ + switch (TREE_CODE (type)) + { + case INTEGER_TYPE: + case ENUMERAL_TYPE: + case BOOLEAN_TYPE: + if (TYPE_VAX_FLOATING_POINT_P (type)) + switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1)) + { + case 6: + dtype = 10; + break; + case 9: + dtype = 11; + break; + case 15: + dtype = 27; + break; + } + else + switch (GET_MODE_BITSIZE (TYPE_MODE (type))) + { + case 8: + dtype = TYPE_UNSIGNED (type) ? 2 : 6; + break; + case 16: + dtype = TYPE_UNSIGNED (type) ? 3 : 7; + break; + case 32: + dtype = TYPE_UNSIGNED (type) ? 4 : 8; + break; + case 64: + dtype = TYPE_UNSIGNED (type) ? 5 : 9; + break; + case 128: + dtype = TYPE_UNSIGNED (type) ? 25 : 26; + break; + } + break; + + case REAL_TYPE: + dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53; + break; + + case COMPLEX_TYPE: + if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE + && TYPE_VAX_FLOATING_POINT_P (type)) + switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1)) + { + case 6: + dtype = 12; + break; + case 9: + dtype = 13; + break; + case 15: + dtype = 29; + } + else + dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55; + break; + + case ARRAY_TYPE: + dtype = 14; + break; + + default: + break; + } + + /* Get the CLASS value. */ + switch (mech) + { + case By_Descriptor_A: + klass = 4; + break; + case By_Descriptor_NCA: + klass = 10; + break; + case By_Descriptor_SB: + klass = 15; + break; + case By_Descriptor: + case By_Descriptor_S: + default: + klass = 1; + break; + } + + /* Make the type for a 64-bit descriptor for VMS. The first six fields + are the same for all types. */ + field_list + = make_descriptor_field ("MBO", gnat_type_for_size (16, 1), + record_type, size_int (1), field_list); + field_list + = make_descriptor_field ("DTYPE", gnat_type_for_size (8, 1), + record_type, size_int (dtype), field_list); + field_list + = make_descriptor_field ("CLASS", gnat_type_for_size (8, 1), + record_type, size_int (klass), field_list); + field_list + = make_descriptor_field ("MBMO", gnat_type_for_size (32, 1), + record_type, ssize_int (-1), field_list); + field_list + = make_descriptor_field ("LENGTH", gnat_type_for_size (64, 1), + record_type, + size_in_bytes (mech == By_Descriptor_A + ? inner_type : type), + field_list); + + pointer64_type = build_pointer_type_for_mode (type, DImode, false); + + field_list + = make_descriptor_field ("POINTER", pointer64_type, record_type, + build_unary_op (ADDR_EXPR, pointer64_type, + build0 (PLACEHOLDER_EXPR, type)), + field_list); + + switch (mech) + { + case By_Descriptor: + case By_Descriptor_S: + break; + + case By_Descriptor_SB: + field_list + = make_descriptor_field ("SB_L1", gnat_type_for_size (64, 1), + record_type, + (TREE_CODE (type) == ARRAY_TYPE + ? TYPE_MIN_VALUE (TYPE_DOMAIN (type)) + : size_zero_node), + field_list); + field_list + = make_descriptor_field ("SB_U1", gnat_type_for_size (64, 1), + record_type, + (TREE_CODE (type) == ARRAY_TYPE + ? TYPE_MAX_VALUE (TYPE_DOMAIN (type)) + : size_zero_node), + field_list); + break; + + case By_Descriptor_A: + case By_Descriptor_NCA: + field_list + = make_descriptor_field ("SCALE", gnat_type_for_size (8, 1), + record_type, size_zero_node, field_list); + + field_list + = make_descriptor_field ("DIGITS", gnat_type_for_size (8, 1), + record_type, size_zero_node, field_list); + + dtype = (mech == By_Descriptor_NCA + ? 0 + /* Set FL_COLUMN, FL_COEFF, and + FL_BOUNDS. */ + : (TREE_CODE (type) == ARRAY_TYPE + && TYPE_CONVENTION_FORTRAN_P (type) + ? 224 : 192)); + field_list + = make_descriptor_field ("AFLAGS", gnat_type_for_size (8, 1), + record_type, size_int (dtype), + field_list); + + field_list + = make_descriptor_field ("DIMCT", gnat_type_for_size (8, 1), + record_type, size_int (ndim), field_list); + + field_list + = make_descriptor_field ("MBZ", gnat_type_for_size (32, 1), + record_type, size_int (0), field_list); + field_list + = make_descriptor_field ("ARSIZE", gnat_type_for_size (64, 1), + record_type, size_in_bytes (type), + field_list); + + /* Now build a pointer to the 0,0,0... element. */ + tem = build0 (PLACEHOLDER_EXPR, type); + for (i = 0, inner_type = type; i < ndim; + i++, inner_type = TREE_TYPE (inner_type)) + tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem, + convert (TYPE_DOMAIN (inner_type), size_zero_node), + NULL_TREE, NULL_TREE); + + field_list + = make_descriptor_field ("A0", pointer64_type, record_type, + build1 (ADDR_EXPR, pointer64_type, tem), + field_list); + + /* Next come the addressing coefficients. */ + tem = size_one_node; + for (i = 0; i < ndim; i++) + { + char fname[3]; + tree idx_length + = size_binop (MULT_EXPR, tem, + size_binop (PLUS_EXPR, + size_binop (MINUS_EXPR, + TYPE_MAX_VALUE (idx_arr[i]), + TYPE_MIN_VALUE (idx_arr[i])), + size_int (1))); + + fname[0] = (mech == By_Descriptor_NCA ? 'S' : 'M'); + fname[1] = '0' + i, fname[2] = 0; + field_list + = make_descriptor_field (fname, gnat_type_for_size (64, 1), + record_type, idx_length, field_list); + + if (mech == By_Descriptor_NCA) + tem = idx_length; + } + + /* Finally here are the bounds. */ + for (i = 0; i < ndim; i++) + { + char fname[3]; + + fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0; + field_list + = make_descriptor_field (fname, gnat_type_for_size (64, 1), + record_type, + TYPE_MIN_VALUE (idx_arr[i]), field_list); + + fname[0] = 'U'; + field_list + = make_descriptor_field (fname, gnat_type_for_size (64, 1), + record_type, + TYPE_MAX_VALUE (idx_arr[i]), field_list); + } + break; + + default: + post_error ("unsupported descriptor type for &", gnat_entity); + } + + TYPE_NAME (record_type) = create_concat_name (gnat_entity, "DESC64"); + finish_record_type (record_type, nreverse (field_list), 0, false); + return record_type; +} + +/* Fill in a VMS descriptor of GNU_TYPE for GNU_EXPR and return the result. + GNAT_ACTUAL is the actual parameter for which the descriptor is built. */ + +tree +fill_vms_descriptor (tree gnu_type, tree gnu_expr, Node_Id gnat_actual) +{ + VEC(constructor_elt,gc) *v = NULL; + tree field; + + gnu_expr = maybe_unconstrained_array (gnu_expr); + gnu_expr = gnat_protect_expr (gnu_expr); + gnat_mark_addressable (gnu_expr); + + /* We may need to substitute both GNU_EXPR and a CALL_EXPR to the raise CE + routine in case we have a 32-bit descriptor. */ + gnu_expr = build2 (COMPOUND_EXPR, void_type_node, + build_call_raise (CE_Range_Check_Failed, gnat_actual, + N_Raise_Constraint_Error), + gnu_expr); + + for (field = TYPE_FIELDS (gnu_type); field; field = DECL_CHAIN (field)) + { + tree value + = convert (TREE_TYPE (field), + SUBSTITUTE_PLACEHOLDER_IN_EXPR (DECL_INITIAL (field), + gnu_expr)); + CONSTRUCTOR_APPEND_ELT (v, field, value); + } + + return gnat_build_constructor (gnu_type, v); +} + +/* Convert GNU_EXPR, a pointer to a 64bit VMS descriptor, to GNU_TYPE, a + regular pointer or fat pointer type. GNAT_SUBPROG is the subprogram to + which the VMS descriptor is passed. */ + +static tree +convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) +{ + tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr)); + tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr); + /* The CLASS field is the 3rd field in the descriptor. */ + tree klass = DECL_CHAIN (DECL_CHAIN (TYPE_FIELDS (desc_type))); + /* The POINTER field is the 6th field in the descriptor. */ + tree pointer = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (klass))); + + /* Retrieve the value of the POINTER field. */ + tree gnu_expr64 + = build3 (COMPONENT_REF, TREE_TYPE (pointer), desc, pointer, NULL_TREE); + + if (POINTER_TYPE_P (gnu_type)) + return convert (gnu_type, gnu_expr64); + + else if (TYPE_IS_FAT_POINTER_P (gnu_type)) + { + tree p_array_type = TREE_TYPE (TYPE_FIELDS (gnu_type)); + tree p_bounds_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))); + tree template_type = TREE_TYPE (p_bounds_type); + tree min_field = TYPE_FIELDS (template_type); + tree max_field = TREE_CHAIN (TYPE_FIELDS (template_type)); + tree template_tree, template_addr, aflags, dimct, t, u; + /* See the head comment of build_vms_descriptor. */ + int iklass = TREE_INT_CST_LOW (DECL_INITIAL (klass)); + tree lfield, ufield; + VEC(constructor_elt,gc) *v; + + /* Convert POINTER to the pointer-to-array type. */ + gnu_expr64 = convert (p_array_type, gnu_expr64); + + switch (iklass) + { + case 1: /* Class S */ + case 15: /* Class SB */ + /* Build {1, LENGTH} template; LENGTH64 is the 5th field. */ + v = VEC_alloc (constructor_elt, gc, 2); + t = DECL_CHAIN (DECL_CHAIN (klass)); + t = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + CONSTRUCTOR_APPEND_ELT (v, min_field, + convert (TREE_TYPE (min_field), + integer_one_node)); + CONSTRUCTOR_APPEND_ELT (v, max_field, + convert (TREE_TYPE (max_field), t)); + template_tree = gnat_build_constructor (template_type, v); + template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template_tree); + + /* For class S, we are done. */ + if (iklass == 1) + break; + + /* Test that we really have a SB descriptor, like DEC Ada. */ + t = build3 (COMPONENT_REF, TREE_TYPE (klass), desc, klass, NULL); + u = convert (TREE_TYPE (klass), DECL_INITIAL (klass)); + u = build_binary_op (EQ_EXPR, boolean_type_node, t, u); + /* If so, there is already a template in the descriptor and + it is located right after the POINTER field. The fields are + 64bits so they must be repacked. */ + t = TREE_CHAIN (pointer); + lfield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + lfield = convert (TREE_TYPE (TYPE_FIELDS (template_type)), lfield); + + t = TREE_CHAIN (t); + ufield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + ufield = convert + (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (template_type))), ufield); + + /* Build the template in the form of a constructor. */ + v = VEC_alloc (constructor_elt, gc, 2); + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (template_type), lfield); + CONSTRUCTOR_APPEND_ELT (v, TREE_CHAIN (TYPE_FIELDS (template_type)), + ufield); + template_tree = gnat_build_constructor (template_type, v); + + /* Otherwise use the {1, LENGTH} template we build above. */ + template_addr = build3 (COND_EXPR, p_bounds_type, u, + build_unary_op (ADDR_EXPR, p_bounds_type, + template_tree), + template_addr); + break; + + case 4: /* Class A */ + /* The AFLAGS field is the 3rd field after the pointer in the + descriptor. */ + t = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (pointer))); + aflags = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + /* The DIMCT field is the next field in the descriptor after + aflags. */ + t = TREE_CHAIN (t); + dimct = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + /* Raise CONSTRAINT_ERROR if either more than 1 dimension + or FL_COEFF or FL_BOUNDS not set. */ + u = build_int_cst (TREE_TYPE (aflags), 192); + u = build_binary_op (TRUTH_OR_EXPR, boolean_type_node, + build_binary_op (NE_EXPR, boolean_type_node, + dimct, + convert (TREE_TYPE (dimct), + size_one_node)), + build_binary_op (NE_EXPR, boolean_type_node, + build2 (BIT_AND_EXPR, + TREE_TYPE (aflags), + aflags, u), + u)); + /* There is already a template in the descriptor and it is located + in block 3. The fields are 64bits so they must be repacked. */ + t = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (DECL_CHAIN + (t))))); + lfield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + lfield = convert (TREE_TYPE (TYPE_FIELDS (template_type)), lfield); + + t = TREE_CHAIN (t); + ufield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + ufield = convert + (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (template_type))), ufield); + + /* Build the template in the form of a constructor. */ + v = VEC_alloc (constructor_elt, gc, 2); + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (template_type), lfield); + CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (template_type)), + ufield); + template_tree = gnat_build_constructor (template_type, v); + template_tree = build3 (COND_EXPR, template_type, u, + build_call_raise (CE_Length_Check_Failed, Empty, + N_Raise_Constraint_Error), + template_tree); + template_addr + = build_unary_op (ADDR_EXPR, p_bounds_type, template_tree); + break; + + case 10: /* Class NCA */ + default: + post_error ("unsupported descriptor type for &", gnat_subprog); + template_addr = integer_zero_node; + break; + } + + /* Build the fat pointer in the form of a constructor. */ + v = VEC_alloc (constructor_elt, gc, 2); + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (gnu_type), gnu_expr64); + CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (gnu_type)), + template_addr); + return gnat_build_constructor (gnu_type, v); + } + + else + gcc_unreachable (); +} + +/* Convert GNU_EXPR, a pointer to a 32bit VMS descriptor, to GNU_TYPE, a + regular pointer or fat pointer type. GNAT_SUBPROG is the subprogram to + which the VMS descriptor is passed. */ + +static tree +convert_vms_descriptor32 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) +{ + tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr)); + tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr); + /* The CLASS field is the 3rd field in the descriptor. */ + tree klass = DECL_CHAIN (DECL_CHAIN (TYPE_FIELDS (desc_type))); + /* The POINTER field is the 4th field in the descriptor. */ + tree pointer = DECL_CHAIN (klass); + + /* Retrieve the value of the POINTER field. */ + tree gnu_expr32 + = build3 (COMPONENT_REF, TREE_TYPE (pointer), desc, pointer, NULL_TREE); + + if (POINTER_TYPE_P (gnu_type)) + return convert (gnu_type, gnu_expr32); + + else if (TYPE_IS_FAT_POINTER_P (gnu_type)) + { + tree p_array_type = TREE_TYPE (TYPE_FIELDS (gnu_type)); + tree p_bounds_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))); + tree template_type = TREE_TYPE (p_bounds_type); + tree min_field = TYPE_FIELDS (template_type); + tree max_field = TREE_CHAIN (TYPE_FIELDS (template_type)); + tree template_tree, template_addr, aflags, dimct, t, u; + /* See the head comment of build_vms_descriptor. */ + int iklass = TREE_INT_CST_LOW (DECL_INITIAL (klass)); + VEC(constructor_elt,gc) *v; + + /* Convert POINTER to the pointer-to-array type. */ + gnu_expr32 = convert (p_array_type, gnu_expr32); + + switch (iklass) + { + case 1: /* Class S */ + case 15: /* Class SB */ + /* Build {1, LENGTH} template; LENGTH is the 1st field. */ + v = VEC_alloc (constructor_elt, gc, 2); + t = TYPE_FIELDS (desc_type); + t = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + CONSTRUCTOR_APPEND_ELT (v, min_field, + convert (TREE_TYPE (min_field), + integer_one_node)); + CONSTRUCTOR_APPEND_ELT (v, max_field, + convert (TREE_TYPE (max_field), t)); + template_tree = gnat_build_constructor (template_type, v); + template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template_tree); + + /* For class S, we are done. */ + if (iklass == 1) + break; + + /* Test that we really have a SB descriptor, like DEC Ada. */ + t = build3 (COMPONENT_REF, TREE_TYPE (klass), desc, klass, NULL); + u = convert (TREE_TYPE (klass), DECL_INITIAL (klass)); + u = build_binary_op (EQ_EXPR, boolean_type_node, t, u); + /* If so, there is already a template in the descriptor and + it is located right after the POINTER field. */ + t = TREE_CHAIN (pointer); + template_tree + = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + /* Otherwise use the {1, LENGTH} template we build above. */ + template_addr = build3 (COND_EXPR, p_bounds_type, u, + build_unary_op (ADDR_EXPR, p_bounds_type, + template_tree), + template_addr); + break; + + case 4: /* Class A */ + /* The AFLAGS field is the 7th field in the descriptor. */ + t = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (pointer))); + aflags = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + /* The DIMCT field is the 8th field in the descriptor. */ + t = TREE_CHAIN (t); + dimct = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + /* Raise CONSTRAINT_ERROR if either more than 1 dimension + or FL_COEFF or FL_BOUNDS not set. */ + u = build_int_cst (TREE_TYPE (aflags), 192); + u = build_binary_op (TRUTH_OR_EXPR, boolean_type_node, + build_binary_op (NE_EXPR, boolean_type_node, + dimct, + convert (TREE_TYPE (dimct), + size_one_node)), + build_binary_op (NE_EXPR, boolean_type_node, + build2 (BIT_AND_EXPR, + TREE_TYPE (aflags), + aflags, u), + u)); + /* There is already a template in the descriptor and it is + located at the start of block 3 (12th field). */ + t = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (t)))); + template_tree + = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); + template_tree = build3 (COND_EXPR, TREE_TYPE (t), u, + build_call_raise (CE_Length_Check_Failed, Empty, + N_Raise_Constraint_Error), + template_tree); + template_addr + = build_unary_op (ADDR_EXPR, p_bounds_type, template_tree); + break; + + case 10: /* Class NCA */ + default: + post_error ("unsupported descriptor type for &", gnat_subprog); + template_addr = integer_zero_node; + break; + } + + /* Build the fat pointer in the form of a constructor. */ + v = VEC_alloc (constructor_elt, gc, 2); + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (gnu_type), gnu_expr32); + CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (gnu_type)), + template_addr); + + return gnat_build_constructor (gnu_type, v); + } + + else + gcc_unreachable (); +} + +/* Convert GNU_EXPR, a pointer to a VMS descriptor, to GNU_TYPE, a regular + pointer or fat pointer type. GNU_EXPR_ALT_TYPE is the alternate (32-bit) + pointer type of GNU_EXPR. BY_REF is true if the result is to be used by + reference. GNAT_SUBPROG is the subprogram to which the VMS descriptor is + passed. */ + +static tree +convert_vms_descriptor (tree gnu_type, tree gnu_expr, tree gnu_expr_alt_type, + bool by_ref, Entity_Id gnat_subprog) +{ + tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr)); + tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr); + tree mbo = TYPE_FIELDS (desc_type); + const char *mbostr = IDENTIFIER_POINTER (DECL_NAME (mbo)); + tree mbmo = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (mbo))); + tree real_type, is64bit, gnu_expr32, gnu_expr64; + + if (by_ref) + real_type = TREE_TYPE (gnu_type); + else + real_type = gnu_type; + + /* If the field name is not MBO, it must be 32-bit and no alternate. + Otherwise primary must be 64-bit and alternate 32-bit. */ + if (strcmp (mbostr, "MBO") != 0) + { + tree ret = convert_vms_descriptor32 (real_type, gnu_expr, gnat_subprog); + if (by_ref) + ret = build_unary_op (ADDR_EXPR, gnu_type, ret); + return ret; + } + + /* Build the test for 64-bit descriptor. */ + mbo = build3 (COMPONENT_REF, TREE_TYPE (mbo), desc, mbo, NULL_TREE); + mbmo = build3 (COMPONENT_REF, TREE_TYPE (mbmo), desc, mbmo, NULL_TREE); + is64bit + = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node, + build_binary_op (EQ_EXPR, boolean_type_node, + convert (integer_type_node, mbo), + integer_one_node), + build_binary_op (EQ_EXPR, boolean_type_node, + convert (integer_type_node, mbmo), + integer_minus_one_node)); + + /* Build the 2 possible end results. */ + gnu_expr64 = convert_vms_descriptor64 (real_type, gnu_expr, gnat_subprog); + if (by_ref) + gnu_expr64 = build_unary_op (ADDR_EXPR, gnu_type, gnu_expr64); + gnu_expr = fold_convert (gnu_expr_alt_type, gnu_expr); + gnu_expr32 = convert_vms_descriptor32 (real_type, gnu_expr, gnat_subprog); + if (by_ref) + gnu_expr32 = build_unary_op (ADDR_EXPR, gnu_type, gnu_expr32); + + return build3 (COND_EXPR, gnu_type, is64bit, gnu_expr64, gnu_expr32); +} + +/* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG + and the GNAT node GNAT_SUBPROG. */ + +void +build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog) +{ + tree gnu_subprog_type, gnu_subprog_addr, gnu_subprog_call; + tree gnu_subprog_param, gnu_stub_param, gnu_param; + tree gnu_stub_decl = DECL_FUNCTION_STUB (gnu_subprog); + VEC(tree,gc) *gnu_param_vec = NULL; + + gnu_subprog_type = TREE_TYPE (gnu_subprog); + + /* Initialize the information structure for the function. */ + allocate_struct_function (gnu_stub_decl, false); + set_cfun (NULL); + + begin_subprog_body (gnu_stub_decl); + + start_stmt_group (); + gnat_pushlevel (); + + /* Loop over the parameters of the stub and translate any of them + passed by descriptor into a by reference one. */ + for (gnu_stub_param = DECL_ARGUMENTS (gnu_stub_decl), + gnu_subprog_param = DECL_ARGUMENTS (gnu_subprog); + gnu_stub_param; + gnu_stub_param = TREE_CHAIN (gnu_stub_param), + gnu_subprog_param = TREE_CHAIN (gnu_subprog_param)) + { + if (DECL_BY_DESCRIPTOR_P (gnu_stub_param)) + { + gcc_assert (DECL_BY_REF_P (gnu_subprog_param)); + gnu_param + = convert_vms_descriptor (TREE_TYPE (gnu_subprog_param), + gnu_stub_param, + DECL_PARM_ALT_TYPE (gnu_stub_param), + DECL_BY_DOUBLE_REF_P (gnu_subprog_param), + gnat_subprog); + } + else + gnu_param = gnu_stub_param; + + VEC_safe_push (tree, gc, gnu_param_vec, gnu_param); + } + + /* Invoke the internal subprogram. */ + gnu_subprog_addr = build1 (ADDR_EXPR, build_pointer_type (gnu_subprog_type), + gnu_subprog); + gnu_subprog_call = build_call_vec (TREE_TYPE (gnu_subprog_type), + gnu_subprog_addr, gnu_param_vec); + + /* Propagate the return value, if any. */ + if (VOID_TYPE_P (TREE_TYPE (gnu_subprog_type))) + add_stmt (gnu_subprog_call); + else + add_stmt (build_return_expr (DECL_RESULT (gnu_stub_decl), + gnu_subprog_call)); + + gnat_poplevel (); + end_subprog_body (end_stmt_group ()); +} + +/* Build a type to be used to represent an aliased object whose nominal type + is an unconstrained array. This consists of a RECORD_TYPE containing a + field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an ARRAY_TYPE. + If ARRAY_TYPE is that of an unconstrained array, this is used to represent + an arbitrary unconstrained object. Use NAME as the name of the record. + DEBUG_INFO_P is true if we need to write debug information for the type. */ + +tree +build_unc_object_type (tree template_type, tree object_type, tree name, + bool debug_info_p) +{ + tree type = make_node (RECORD_TYPE); + tree template_field + = create_field_decl (get_identifier ("BOUNDS"), template_type, type, + NULL_TREE, NULL_TREE, 0, 1); + tree array_field + = create_field_decl (get_identifier ("ARRAY"), object_type, type, + NULL_TREE, NULL_TREE, 0, 1); + + TYPE_NAME (type) = name; + TYPE_CONTAINS_TEMPLATE_P (type) = 1; + DECL_CHAIN (template_field) = array_field; + finish_record_type (type, template_field, 0, true); + + /* Declare it now since it will never be declared otherwise. This is + necessary to ensure that its subtrees are properly marked. */ + create_type_decl (name, type, NULL, true, debug_info_p, Empty); + + return type; +} + +/* Same, taking a thin or fat pointer type instead of a template type. */ + +tree +build_unc_object_type_from_ptr (tree thin_fat_ptr_type, tree object_type, + tree name, bool debug_info_p) +{ + tree template_type; + + gcc_assert (TYPE_IS_FAT_OR_THIN_POINTER_P (thin_fat_ptr_type)); + + template_type + = (TYPE_IS_FAT_POINTER_P (thin_fat_ptr_type) + ? TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (thin_fat_ptr_type)))) + : TREE_TYPE (TYPE_FIELDS (TREE_TYPE (thin_fat_ptr_type)))); + + return + build_unc_object_type (template_type, object_type, name, debug_info_p); +} + +/* Shift the component offsets within an unconstrained object TYPE to make it + suitable for use as a designated type for thin pointers. */ + +void +shift_unc_components_for_thin_pointers (tree type) +{ + /* Thin pointer values designate the ARRAY data of an unconstrained object, + allocated past the BOUNDS template. The designated type is adjusted to + have ARRAY at position zero and the template at a negative offset, so + that COMPONENT_REFs on (*thin_ptr) designate the proper location. */ + + tree bounds_field = TYPE_FIELDS (type); + tree array_field = DECL_CHAIN (TYPE_FIELDS (type)); + + DECL_FIELD_OFFSET (bounds_field) + = size_binop (MINUS_EXPR, size_zero_node, byte_position (array_field)); + + DECL_FIELD_OFFSET (array_field) = size_zero_node; + DECL_FIELD_BIT_OFFSET (array_field) = bitsize_zero_node; +} + +/* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE. + In the normal case this is just two adjustments, but we have more to + do if NEW_TYPE is an UNCONSTRAINED_ARRAY_TYPE. */ + +void +update_pointer_to (tree old_type, tree new_type) +{ + tree ptr = TYPE_POINTER_TO (old_type); + tree ref = TYPE_REFERENCE_TO (old_type); + tree t; + + /* If this is the main variant, process all the other variants first. */ + if (TYPE_MAIN_VARIANT (old_type) == old_type) + for (t = TYPE_NEXT_VARIANT (old_type); t; t = TYPE_NEXT_VARIANT (t)) + update_pointer_to (t, new_type); + + /* If no pointers and no references, we are done. */ + if (!ptr && !ref) + return; + + /* Merge the old type qualifiers in the new type. + + Each old variant has qualifiers for specific reasons, and the new + designated type as well. Each set of qualifiers represents useful + information grabbed at some point, and merging the two simply unifies + these inputs into the final type description. + + Consider for instance a volatile type frozen after an access to constant + type designating it; after the designated type's freeze, we get here with + a volatile NEW_TYPE and a dummy OLD_TYPE with a readonly variant, created + when the access type was processed. We will make a volatile and readonly + designated type, because that's what it really is. + + We might also get here for a non-dummy OLD_TYPE variant with different + qualifiers than those of NEW_TYPE, for instance in some cases of pointers + to private record type elaboration (see the comments around the call to + this routine in gnat_to_gnu_entity ). We have to merge + the qualifiers in those cases too, to avoid accidentally discarding the + initial set, and will often end up with OLD_TYPE == NEW_TYPE then. */ + new_type + = build_qualified_type (new_type, + TYPE_QUALS (old_type) | TYPE_QUALS (new_type)); + + /* If old type and new type are identical, there is nothing to do. */ + if (old_type == new_type) + return; + + /* Otherwise, first handle the simple case. */ + if (TREE_CODE (new_type) != UNCONSTRAINED_ARRAY_TYPE) + { + tree new_ptr, new_ref; + + /* If pointer or reference already points to new type, nothing to do. + This can happen as update_pointer_to can be invoked multiple times + on the same couple of types because of the type variants. */ + if ((ptr && TREE_TYPE (ptr) == new_type) + || (ref && TREE_TYPE (ref) == new_type)) + return; + + /* Chain PTR and its variants at the end. */ + new_ptr = TYPE_POINTER_TO (new_type); + if (new_ptr) + { + while (TYPE_NEXT_PTR_TO (new_ptr)) + new_ptr = TYPE_NEXT_PTR_TO (new_ptr); + TYPE_NEXT_PTR_TO (new_ptr) = ptr; + } + else + TYPE_POINTER_TO (new_type) = ptr; + + /* Now adjust them. */ + for (; ptr; ptr = TYPE_NEXT_PTR_TO (ptr)) + for (t = TYPE_MAIN_VARIANT (ptr); t; t = TYPE_NEXT_VARIANT (t)) + TREE_TYPE (t) = new_type; + TYPE_POINTER_TO (old_type) = NULL_TREE; + + /* Chain REF and its variants at the end. */ + new_ref = TYPE_REFERENCE_TO (new_type); + if (new_ref) + { + while (TYPE_NEXT_REF_TO (new_ref)) + new_ref = TYPE_NEXT_REF_TO (new_ref); + TYPE_NEXT_REF_TO (new_ref) = ref; + } + else + TYPE_REFERENCE_TO (new_type) = ref; + + /* Now adjust them. */ + for (; ref; ref = TYPE_NEXT_REF_TO (ref)) + for (t = TYPE_MAIN_VARIANT (ref); t; t = TYPE_NEXT_VARIANT (t)) + TREE_TYPE (t) = new_type; + TYPE_REFERENCE_TO (old_type) = NULL_TREE; + } + + /* Now deal with the unconstrained array case. In this case the pointer + is actually a record where both fields are pointers to dummy nodes. + Turn them into pointers to the correct types using update_pointer_to. */ + else + { + tree new_ptr = TYPE_MAIN_VARIANT (TYPE_POINTER_TO (new_type)); + tree new_obj_rec = TYPE_OBJECT_RECORD_TYPE (new_type); + tree array_field, bounds_field, new_ref, last = NULL_TREE; + + gcc_assert (TYPE_IS_FAT_POINTER_P (ptr)); + + /* If PTR already points to new type, nothing to do. This can happen + since update_pointer_to can be invoked multiple times on the same + couple of types because of the type variants. */ + if (TYPE_UNCONSTRAINED_ARRAY (ptr) == new_type) + return; + + array_field = TYPE_FIELDS (ptr); + bounds_field = DECL_CHAIN (array_field); + + /* Make pointers to the dummy template point to the real template. */ + update_pointer_to + (TREE_TYPE (TREE_TYPE (bounds_field)), + TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (new_ptr))))); + + /* The references to the template bounds present in the array type use + the bounds field of NEW_PTR through a PLACEHOLDER_EXPR. Since we + are going to merge PTR in NEW_PTR, we must rework these references + to use the bounds field of PTR instead. */ + new_ref = build3 (COMPONENT_REF, TREE_TYPE (bounds_field), + build0 (PLACEHOLDER_EXPR, new_ptr), + bounds_field, NULL_TREE); + + /* Create the new array for the new PLACEHOLDER_EXPR and make pointers + to the dummy array point to it. */ + update_pointer_to + (TREE_TYPE (TREE_TYPE (array_field)), + substitute_in_type (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (new_ptr))), + DECL_CHAIN (TYPE_FIELDS (new_ptr)), new_ref)); + + /* Merge PTR in NEW_PTR. */ + DECL_FIELD_CONTEXT (array_field) = new_ptr; + DECL_FIELD_CONTEXT (bounds_field) = new_ptr; + for (t = new_ptr; t; last = t, t = TYPE_NEXT_VARIANT (t)) + TYPE_FIELDS (t) = TYPE_FIELDS (ptr); + TYPE_ALIAS_SET (new_ptr) = TYPE_ALIAS_SET (ptr); + + /* Chain PTR and its variants at the end. */ + TYPE_NEXT_VARIANT (last) = TYPE_MAIN_VARIANT (ptr); + + /* Now adjust them. */ + for (t = TYPE_MAIN_VARIANT (ptr); t; t = TYPE_NEXT_VARIANT (t)) + { + TYPE_MAIN_VARIANT (t) = new_ptr; + SET_TYPE_UNCONSTRAINED_ARRAY (t, new_type); + + /* And show the original pointer NEW_PTR to the debugger. This is + the counterpart of the special processing for fat pointer types + in gnat_pushdecl, but when the unconstrained array type is only + frozen after access types to it. */ + if (TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL) + { + DECL_ORIGINAL_TYPE (TYPE_NAME (t)) = new_ptr; + DECL_ARTIFICIAL (TYPE_NAME (t)) = 0; + } + } + + /* Now handle updating the allocation record, what the thin pointer + points to. Update all pointers from the old record into the new + one, update the type of the array field, and recompute the size. */ + update_pointer_to (TYPE_OBJECT_RECORD_TYPE (old_type), new_obj_rec); + TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (new_obj_rec))) + = TREE_TYPE (TREE_TYPE (array_field)); + + /* The size recomputation needs to account for alignment constraints, so + we let layout_type work it out. This will reset the field offsets to + what they would be in a regular record, so we shift them back to what + we want them to be for a thin pointer designated type afterwards. */ + DECL_SIZE (TYPE_FIELDS (new_obj_rec)) = NULL_TREE; + DECL_SIZE (DECL_CHAIN (TYPE_FIELDS (new_obj_rec))) = NULL_TREE; + TYPE_SIZE (new_obj_rec) = NULL_TREE; + layout_type (new_obj_rec); + shift_unc_components_for_thin_pointers (new_obj_rec); + + /* We are done, at last. */ + rest_of_record_type_compilation (ptr); + } +} + +/* Convert EXPR, a pointer to a constrained array, into a pointer to an + unconstrained one. This involves making or finding a template. */ + +static tree +convert_to_fat_pointer (tree type, tree expr) +{ + tree template_type = TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (type)))); + tree p_array_type = TREE_TYPE (TYPE_FIELDS (type)); + tree etype = TREE_TYPE (expr); + tree template_tree; + VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 2); + + /* If EXPR is null, make a fat pointer that contains null pointers to the + template and array. */ + if (integer_zerop (expr)) + { + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), + convert (p_array_type, expr)); + CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)), + convert (build_pointer_type (template_type), + expr)); + return gnat_build_constructor (type, v); + } + + /* If EXPR is a thin pointer, make template and data from the record.. */ + else if (TYPE_IS_THIN_POINTER_P (etype)) + { + tree fields = TYPE_FIELDS (TREE_TYPE (etype)); + + expr = gnat_protect_expr (expr); + if (TREE_CODE (expr) == ADDR_EXPR) + expr = TREE_OPERAND (expr, 0); + else + expr = build1 (INDIRECT_REF, TREE_TYPE (etype), expr); + + template_tree = build_component_ref (expr, NULL_TREE, fields, false); + expr = build_unary_op (ADDR_EXPR, NULL_TREE, + build_component_ref (expr, NULL_TREE, + DECL_CHAIN (fields), false)); + } + + /* Otherwise, build the constructor for the template. */ + else + template_tree = build_template (template_type, TREE_TYPE (etype), expr); + + /* The final result is a constructor for the fat pointer. + + If EXPR is an argument of a foreign convention subprogram, the type it + points to is directly the component type. In this case, the expression + type may not match the corresponding FIELD_DECL type at this point, so we + call "convert" here to fix that up if necessary. This type consistency is + required, for instance because it ensures that possible later folding of + COMPONENT_REFs against this constructor always yields something of the + same type as the initial reference. + + Note that the call to "build_template" above is still fine because it + will only refer to the provided TEMPLATE_TYPE in this case. */ + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), + convert (p_array_type, expr)); + CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)), + build_unary_op (ADDR_EXPR, NULL_TREE, + template_tree)); + return gnat_build_constructor (type, v); +} + +/* Convert to a thin pointer type, TYPE. The only thing we know how to convert + is something that is a fat pointer, so convert to it first if it EXPR + is not already a fat pointer. */ + +static tree +convert_to_thin_pointer (tree type, tree expr) +{ + if (!TYPE_IS_FAT_POINTER_P (TREE_TYPE (expr))) + expr + = convert_to_fat_pointer + (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))), expr); + + /* We get the pointer to the data and use a NOP_EXPR to make it the + proper GCC type. */ + expr = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (TREE_TYPE (expr)), + false); + expr = build1 (NOP_EXPR, type, expr); + + return expr; +} + +/* Create an expression whose value is that of EXPR, + converted to type TYPE. The TREE_TYPE of the value + is always TYPE. This function implements all reasonable + conversions; callers should filter out those that are + not permitted by the language being compiled. */ + +tree +convert (tree type, tree expr) +{ + tree etype = TREE_TYPE (expr); + enum tree_code ecode = TREE_CODE (etype); + enum tree_code code = TREE_CODE (type); + + /* If the expression is already of the right type, we are done. */ + if (etype == type) + return expr; + + /* If both input and output have padding and are of variable size, do this + as an unchecked conversion. Likewise if one is a mere variant of the + other, so we avoid a pointless unpad/repad sequence. */ + else if (code == RECORD_TYPE && ecode == RECORD_TYPE + && TYPE_PADDING_P (type) && TYPE_PADDING_P (etype) + && (!TREE_CONSTANT (TYPE_SIZE (type)) + || !TREE_CONSTANT (TYPE_SIZE (etype)) + || gnat_types_compatible_p (type, etype) + || TYPE_NAME (TREE_TYPE (TYPE_FIELDS (type))) + == TYPE_NAME (TREE_TYPE (TYPE_FIELDS (etype))))) + ; + + /* If the output type has padding, convert to the inner type and make a + constructor to build the record, unless a variable size is involved. */ + else if (code == RECORD_TYPE && TYPE_PADDING_P (type)) + { + VEC(constructor_elt,gc) *v; + + /* If we previously converted from another type and our type is + of variable size, remove the conversion to avoid the need for + variable-sized temporaries. Likewise for a conversion between + original and packable version. */ + if (TREE_CODE (expr) == VIEW_CONVERT_EXPR + && (!TREE_CONSTANT (TYPE_SIZE (type)) + || (ecode == RECORD_TYPE + && TYPE_NAME (etype) + == TYPE_NAME (TREE_TYPE (TREE_OPERAND (expr, 0)))))) + expr = TREE_OPERAND (expr, 0); + + /* If we are just removing the padding from expr, convert the original + object if we have variable size in order to avoid the need for some + variable-sized temporaries. Likewise if the padding is a variant + of the other, so we avoid a pointless unpad/repad sequence. */ + if (TREE_CODE (expr) == COMPONENT_REF + && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (expr, 0))) + && (!TREE_CONSTANT (TYPE_SIZE (type)) + || gnat_types_compatible_p (type, + TREE_TYPE (TREE_OPERAND (expr, 0))) + || (ecode == RECORD_TYPE + && TYPE_NAME (etype) + == TYPE_NAME (TREE_TYPE (TYPE_FIELDS (type)))))) + return convert (type, TREE_OPERAND (expr, 0)); + + /* If the inner type is of self-referential size and the expression type + is a record, do this as an unchecked conversion. But first pad the + expression if possible to have the same size on both sides. */ + if (ecode == RECORD_TYPE + && CONTAINS_PLACEHOLDER_P (DECL_SIZE (TYPE_FIELDS (type)))) + { + if (TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST) + expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0, Empty, + false, false, false, true), + expr); + return unchecked_convert (type, expr, false); + } + + /* If we are converting between array types with variable size, do the + final conversion as an unchecked conversion, again to avoid the need + for some variable-sized temporaries. If valid, this conversion is + very likely purely technical and without real effects. */ + if (ecode == ARRAY_TYPE + && TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == ARRAY_TYPE + && !TREE_CONSTANT (TYPE_SIZE (etype)) + && !TREE_CONSTANT (TYPE_SIZE (type))) + return unchecked_convert (type, + convert (TREE_TYPE (TYPE_FIELDS (type)), + expr), + false); + + v = VEC_alloc (constructor_elt, gc, 1); + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), + convert (TREE_TYPE (TYPE_FIELDS (type)), expr)); + return gnat_build_constructor (type, v); + } + + /* If the input type has padding, remove it and convert to the output type. + The conditions ordering is arranged to ensure that the output type is not + a padding type here, as it is not clear whether the conversion would + always be correct if this was to happen. */ + else if (ecode == RECORD_TYPE && TYPE_PADDING_P (etype)) + { + tree unpadded; + + /* If we have just converted to this padded type, just get the + inner expression. */ + if (TREE_CODE (expr) == CONSTRUCTOR + && !VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (expr)) + && VEC_index (constructor_elt, CONSTRUCTOR_ELTS (expr), 0)->index + == TYPE_FIELDS (etype)) + unpadded + = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (expr), 0)->value; + + /* Otherwise, build an explicit component reference. */ + else + unpadded + = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (etype), false); + + return convert (type, unpadded); + } + + /* If the input is a biased type, adjust first. */ + if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype)) + return convert (type, fold_build2 (PLUS_EXPR, TREE_TYPE (etype), + fold_convert (TREE_TYPE (etype), + expr), + TYPE_MIN_VALUE (etype))); + + /* If the input is a justified modular type, we need to extract the actual + object before converting it to any other type with the exceptions of an + unconstrained array or of a mere type variant. It is useful to avoid the + extraction and conversion in the type variant case because it could end + up replacing a VAR_DECL expr by a constructor and we might be about the + take the address of the result. */ + if (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype) + && code != UNCONSTRAINED_ARRAY_TYPE + && TYPE_MAIN_VARIANT (type) != TYPE_MAIN_VARIANT (etype)) + return convert (type, build_component_ref (expr, NULL_TREE, + TYPE_FIELDS (etype), false)); + + /* If converting to a type that contains a template, convert to the data + type and then build the template. */ + if (code == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (type)) + { + tree obj_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (type))); + VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 2); + + /* If the source already has a template, get a reference to the + associated array only, as we are going to rebuild a template + for the target type anyway. */ + expr = maybe_unconstrained_array (expr); + + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), + build_template (TREE_TYPE (TYPE_FIELDS (type)), + obj_type, NULL_TREE)); + CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)), + convert (obj_type, expr)); + return gnat_build_constructor (type, v); + } + + /* There are some special cases of expressions that we process + specially. */ + switch (TREE_CODE (expr)) + { + case ERROR_MARK: + return expr; + + case NULL_EXPR: + /* Just set its type here. For TRANSFORM_EXPR, we will do the actual + conversion in gnat_expand_expr. NULL_EXPR does not represent + and actual value, so no conversion is needed. */ + expr = copy_node (expr); + TREE_TYPE (expr) = type; + return expr; + + case STRING_CST: + /* If we are converting a STRING_CST to another constrained array type, + just make a new one in the proper type. */ + if (code == ecode && AGGREGATE_TYPE_P (etype) + && !(TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST + && TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)) + { + expr = copy_node (expr); + TREE_TYPE (expr) = type; + return expr; + } + break; + + case VECTOR_CST: + /* If we are converting a VECTOR_CST to a mere variant type, just make + a new one in the proper type. */ + if (code == ecode && gnat_types_compatible_p (type, etype)) + { + expr = copy_node (expr); + TREE_TYPE (expr) = type; + return expr; + } + + case CONSTRUCTOR: + /* If we are converting a CONSTRUCTOR to a mere variant type, just make + a new one in the proper type. */ + if (code == ecode && gnat_types_compatible_p (type, etype)) + { + expr = copy_node (expr); + TREE_TYPE (expr) = type; + return expr; + } + + /* Likewise for a conversion between original and packable version, or + conversion between types of the same size and with the same list of + fields, but we have to work harder to preserve type consistency. */ + if (code == ecode + && code == RECORD_TYPE + && (TYPE_NAME (type) == TYPE_NAME (etype) + || tree_int_cst_equal (TYPE_SIZE (type), TYPE_SIZE (etype)))) + + { + VEC(constructor_elt,gc) *e = CONSTRUCTOR_ELTS (expr); + unsigned HOST_WIDE_INT len = VEC_length (constructor_elt, e); + VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, len); + tree efield = TYPE_FIELDS (etype), field = TYPE_FIELDS (type); + unsigned HOST_WIDE_INT idx; + tree index, value; + + /* Whether we need to clear TREE_CONSTANT et al. on the output + constructor when we convert in place. */ + bool clear_constant = false; + + FOR_EACH_CONSTRUCTOR_ELT(e, idx, index, value) + { + constructor_elt *elt; + /* We expect only simple constructors. */ + if (!SAME_FIELD_P (index, efield)) + break; + /* The field must be the same. */ + if (!SAME_FIELD_P (efield, field)) + break; + elt = VEC_quick_push (constructor_elt, v, NULL); + elt->index = field; + elt->value = convert (TREE_TYPE (field), value); + + /* If packing has made this field a bitfield and the input + value couldn't be emitted statically any more, we need to + clear TREE_CONSTANT on our output. */ + if (!clear_constant + && TREE_CONSTANT (expr) + && !CONSTRUCTOR_BITFIELD_P (efield) + && CONSTRUCTOR_BITFIELD_P (field) + && !initializer_constant_valid_for_bitfield_p (value)) + clear_constant = true; + + efield = DECL_CHAIN (efield); + field = DECL_CHAIN (field); + } + + /* If we have been able to match and convert all the input fields + to their output type, convert in place now. We'll fallback to a + view conversion downstream otherwise. */ + if (idx == len) + { + expr = copy_node (expr); + TREE_TYPE (expr) = type; + CONSTRUCTOR_ELTS (expr) = v; + if (clear_constant) + TREE_CONSTANT (expr) = TREE_STATIC (expr) = 0; + return expr; + } + } + + /* Likewise for a conversion between array type and vector type with a + compatible representative array. */ + else if (code == VECTOR_TYPE + && ecode == ARRAY_TYPE + && gnat_types_compatible_p (TYPE_REPRESENTATIVE_ARRAY (type), + etype)) + { + VEC(constructor_elt,gc) *e = CONSTRUCTOR_ELTS (expr); + unsigned HOST_WIDE_INT len = VEC_length (constructor_elt, e); + VEC(constructor_elt,gc) *v; + unsigned HOST_WIDE_INT ix; + tree value; + + /* Build a VECTOR_CST from a *constant* array constructor. */ + if (TREE_CONSTANT (expr)) + { + bool constant_p = true; + + /* Iterate through elements and check if all constructor + elements are *_CSTs. */ + FOR_EACH_CONSTRUCTOR_VALUE (e, ix, value) + if (!CONSTANT_CLASS_P (value)) + { + constant_p = false; + break; + } + + if (constant_p) + return build_vector_from_ctor (type, + CONSTRUCTOR_ELTS (expr)); + } + + /* Otherwise, build a regular vector constructor. */ + v = VEC_alloc (constructor_elt, gc, len); + FOR_EACH_CONSTRUCTOR_VALUE (e, ix, value) + { + constructor_elt *elt = VEC_quick_push (constructor_elt, v, NULL); + elt->index = NULL_TREE; + elt->value = value; + } + expr = copy_node (expr); + TREE_TYPE (expr) = type; + CONSTRUCTOR_ELTS (expr) = v; + return expr; + } + break; + + case UNCONSTRAINED_ARRAY_REF: + /* Convert this to the type of the inner array by getting the address of + the array from the template. */ + expr = TREE_OPERAND (expr, 0); + expr = build_unary_op (INDIRECT_REF, NULL_TREE, + build_component_ref (expr, NULL_TREE, + TYPE_FIELDS + (TREE_TYPE (expr)), + false)); + etype = TREE_TYPE (expr); + ecode = TREE_CODE (etype); + break; + + case VIEW_CONVERT_EXPR: + { + /* GCC 4.x is very sensitive to type consistency overall, and view + conversions thus are very frequent. Even though just "convert"ing + the inner operand to the output type is fine in most cases, it + might expose unexpected input/output type mismatches in special + circumstances so we avoid such recursive calls when we can. */ + tree op0 = TREE_OPERAND (expr, 0); + + /* If we are converting back to the original type, we can just + lift the input conversion. This is a common occurrence with + switches back-and-forth amongst type variants. */ + if (type == TREE_TYPE (op0)) + return op0; + + /* Otherwise, if we're converting between two aggregate or vector + types, we might be allowed to substitute the VIEW_CONVERT_EXPR + target type in place or to just convert the inner expression. */ + if ((AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype)) + || (VECTOR_TYPE_P (type) && VECTOR_TYPE_P (etype))) + { + /* If we are converting between mere variants, we can just + substitute the VIEW_CONVERT_EXPR in place. */ + if (gnat_types_compatible_p (type, etype)) + return build1 (VIEW_CONVERT_EXPR, type, op0); + + /* Otherwise, we may just bypass the input view conversion unless + one of the types is a fat pointer, which is handled by + specialized code below which relies on exact type matching. */ + else if (!TYPE_IS_FAT_POINTER_P (type) + && !TYPE_IS_FAT_POINTER_P (etype)) + return convert (type, op0); + } + } + break; + + default: + break; + } + + /* Check for converting to a pointer to an unconstrained array. */ + if (TYPE_IS_FAT_POINTER_P (type) && !TYPE_IS_FAT_POINTER_P (etype)) + return convert_to_fat_pointer (type, expr); + + /* If we are converting between two aggregate or vector types that are mere + variants, just make a VIEW_CONVERT_EXPR. Likewise when we are converting + to a vector type from its representative array type. */ + else if ((code == ecode + && (AGGREGATE_TYPE_P (type) || VECTOR_TYPE_P (type)) + && gnat_types_compatible_p (type, etype)) + || (code == VECTOR_TYPE + && ecode == ARRAY_TYPE + && gnat_types_compatible_p (TYPE_REPRESENTATIVE_ARRAY (type), + etype))) + return build1 (VIEW_CONVERT_EXPR, type, expr); + + /* If we are converting between tagged types, try to upcast properly. */ + else if (ecode == RECORD_TYPE && code == RECORD_TYPE + && TYPE_ALIGN_OK (etype) && TYPE_ALIGN_OK (type)) + { + tree child_etype = etype; + do { + tree field = TYPE_FIELDS (child_etype); + if (DECL_NAME (field) == parent_name_id && TREE_TYPE (field) == type) + return build_component_ref (expr, NULL_TREE, field, false); + child_etype = TREE_TYPE (field); + } while (TREE_CODE (child_etype) == RECORD_TYPE); + } + + /* In all other cases of related types, make a NOP_EXPR. */ + else if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype)) + return fold_convert (type, expr); + + switch (code) + { + case VOID_TYPE: + return fold_build1 (CONVERT_EXPR, type, expr); + + case INTEGER_TYPE: + if (TYPE_HAS_ACTUAL_BOUNDS_P (type) + && (ecode == ARRAY_TYPE || ecode == UNCONSTRAINED_ARRAY_TYPE + || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype)))) + return unchecked_convert (type, expr, false); + else if (TYPE_BIASED_REPRESENTATION_P (type)) + return fold_convert (type, + fold_build2 (MINUS_EXPR, TREE_TYPE (type), + convert (TREE_TYPE (type), expr), + TYPE_MIN_VALUE (type))); + + /* ... fall through ... */ + + case ENUMERAL_TYPE: + case BOOLEAN_TYPE: + /* If we are converting an additive expression to an integer type + with lower precision, be wary of the optimization that can be + applied by convert_to_integer. There are 2 problematic cases: + - if the first operand was originally of a biased type, + because we could be recursively called to convert it + to an intermediate type and thus rematerialize the + additive operator endlessly, + - if the expression contains a placeholder, because an + intermediate conversion that changes the sign could + be inserted and thus introduce an artificial overflow + at compile time when the placeholder is substituted. */ + if (code == INTEGER_TYPE + && ecode == INTEGER_TYPE + && TYPE_PRECISION (type) < TYPE_PRECISION (etype) + && (TREE_CODE (expr) == PLUS_EXPR || TREE_CODE (expr) == MINUS_EXPR)) + { + tree op0 = get_unwidened (TREE_OPERAND (expr, 0), type); + + if ((TREE_CODE (TREE_TYPE (op0)) == INTEGER_TYPE + && TYPE_BIASED_REPRESENTATION_P (TREE_TYPE (op0))) + || CONTAINS_PLACEHOLDER_P (expr)) + return build1 (NOP_EXPR, type, expr); + } + + return fold (convert_to_integer (type, expr)); + + case POINTER_TYPE: + case REFERENCE_TYPE: + /* If converting between two pointers to records denoting + both a template and type, adjust if needed to account + for any differing offsets, since one might be negative. */ + if (TYPE_IS_THIN_POINTER_P (etype) && TYPE_IS_THIN_POINTER_P (type)) + { + tree bit_diff + = size_diffop (bit_position (TYPE_FIELDS (TREE_TYPE (etype))), + bit_position (TYPE_FIELDS (TREE_TYPE (type)))); + tree byte_diff + = size_binop (CEIL_DIV_EXPR, bit_diff, sbitsize_unit_node); + expr = build1 (NOP_EXPR, type, expr); + TREE_CONSTANT (expr) = TREE_CONSTANT (TREE_OPERAND (expr, 0)); + if (integer_zerop (byte_diff)) + return expr; + + return build_binary_op (POINTER_PLUS_EXPR, type, expr, + fold (convert (sizetype, byte_diff))); + } + + /* If converting to a thin pointer, handle specially. */ + if (TYPE_IS_THIN_POINTER_P (type) + && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))) + return convert_to_thin_pointer (type, expr); + + /* If converting fat pointer to normal pointer, get the pointer to the + array and then convert it. */ + else if (TYPE_IS_FAT_POINTER_P (etype)) + expr + = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (etype), false); + + return fold (convert_to_pointer (type, expr)); + + case REAL_TYPE: + return fold (convert_to_real (type, expr)); + + case RECORD_TYPE: + if (TYPE_JUSTIFIED_MODULAR_P (type) && !AGGREGATE_TYPE_P (etype)) + { + VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 1); + + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), + convert (TREE_TYPE (TYPE_FIELDS (type)), + expr)); + return gnat_build_constructor (type, v); + } + + /* ... fall through ... */ + + case ARRAY_TYPE: + /* In these cases, assume the front-end has validated the conversion. + If the conversion is valid, it will be a bit-wise conversion, so + it can be viewed as an unchecked conversion. */ + return unchecked_convert (type, expr, false); + + case UNION_TYPE: + /* This is a either a conversion between a tagged type and some + subtype, which we have to mark as a UNION_TYPE because of + overlapping fields or a conversion of an Unchecked_Union. */ + return unchecked_convert (type, expr, false); + + case UNCONSTRAINED_ARRAY_TYPE: + /* If the input is a VECTOR_TYPE, convert to the representative + array type first. */ + if (ecode == VECTOR_TYPE) + { + expr = convert (TYPE_REPRESENTATIVE_ARRAY (etype), expr); + etype = TREE_TYPE (expr); + ecode = TREE_CODE (etype); + } + + /* If EXPR is a constrained array, take its address, convert it to a + fat pointer, and then dereference it. Likewise if EXPR is a + record containing both a template and a constrained array. + Note that a record representing a justified modular type + always represents a packed constrained array. */ + if (ecode == ARRAY_TYPE + || (ecode == INTEGER_TYPE && TYPE_HAS_ACTUAL_BOUNDS_P (etype)) + || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype)) + || (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype))) + return + build_unary_op + (INDIRECT_REF, NULL_TREE, + convert_to_fat_pointer (TREE_TYPE (type), + build_unary_op (ADDR_EXPR, + NULL_TREE, expr))); + + /* Do something very similar for converting one unconstrained + array to another. */ + else if (ecode == UNCONSTRAINED_ARRAY_TYPE) + return + build_unary_op (INDIRECT_REF, NULL_TREE, + convert (TREE_TYPE (type), + build_unary_op (ADDR_EXPR, + NULL_TREE, expr))); + else + gcc_unreachable (); + + case COMPLEX_TYPE: + return fold (convert_to_complex (type, expr)); + + default: + gcc_unreachable (); + } +} + +/* Remove all conversions that are done in EXP. This includes converting + from a padded type or to a justified modular type. If TRUE_ADDRESS + is true, always return the address of the containing object even if + the address is not bit-aligned. */ + +tree +remove_conversions (tree exp, bool true_address) +{ + switch (TREE_CODE (exp)) + { + case CONSTRUCTOR: + if (true_address + && TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (exp))) + return + remove_conversions (VEC_index (constructor_elt, + CONSTRUCTOR_ELTS (exp), 0)->value, + true); + break; + + case COMPONENT_REF: + if (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (exp, 0)))) + return remove_conversions (TREE_OPERAND (exp, 0), true_address); + break; + + case VIEW_CONVERT_EXPR: case NON_LVALUE_EXPR: + CASE_CONVERT: + return remove_conversions (TREE_OPERAND (exp, 0), true_address); + + default: + break; + } + + return exp; +} + +/* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that + refers to the underlying array. If it has TYPE_CONTAINS_TEMPLATE_P, + likewise return an expression pointing to the underlying array. */ + +tree +maybe_unconstrained_array (tree exp) +{ + enum tree_code code = TREE_CODE (exp); + tree new_exp; + + switch (TREE_CODE (TREE_TYPE (exp))) + { + case UNCONSTRAINED_ARRAY_TYPE: + if (code == UNCONSTRAINED_ARRAY_REF) + { + new_exp = TREE_OPERAND (exp, 0); + new_exp + = build_unary_op (INDIRECT_REF, NULL_TREE, + build_component_ref (new_exp, NULL_TREE, + TYPE_FIELDS + (TREE_TYPE (new_exp)), + false)); + TREE_READONLY (new_exp) = TREE_READONLY (exp); + return new_exp; + } + + else if (code == NULL_EXPR) + return build1 (NULL_EXPR, + TREE_TYPE (TREE_TYPE (TYPE_FIELDS + (TREE_TYPE (TREE_TYPE (exp))))), + TREE_OPERAND (exp, 0)); + + case RECORD_TYPE: + /* If this is a padded type, convert to the unpadded type and see if + it contains a template. */ + if (TYPE_PADDING_P (TREE_TYPE (exp))) + { + new_exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp); + if (TREE_CODE (TREE_TYPE (new_exp)) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (new_exp))) + return + build_component_ref (new_exp, NULL_TREE, + DECL_CHAIN + (TYPE_FIELDS (TREE_TYPE (new_exp))), + false); + } + else if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (exp))) + return + build_component_ref (exp, NULL_TREE, + DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))), + false); + break; + + default: + break; + } + + return exp; +} + +/* If EXP's type is a VECTOR_TYPE, return EXP converted to the associated + TYPE_REPRESENTATIVE_ARRAY. */ + +tree +maybe_vector_array (tree exp) +{ + tree etype = TREE_TYPE (exp); + + if (VECTOR_TYPE_P (etype)) + exp = convert (TYPE_REPRESENTATIVE_ARRAY (etype), exp); + + return exp; +} + +/* Return true if EXPR is an expression that can be folded as an operand + of a VIEW_CONVERT_EXPR. See ada-tree.h for a complete rationale. */ + +static bool +can_fold_for_view_convert_p (tree expr) +{ + tree t1, t2; + + /* The folder will fold NOP_EXPRs between integral types with the same + precision (in the middle-end's sense). We cannot allow it if the + types don't have the same precision in the Ada sense as well. */ + if (TREE_CODE (expr) != NOP_EXPR) + return true; + + t1 = TREE_TYPE (expr); + t2 = TREE_TYPE (TREE_OPERAND (expr, 0)); + + /* Defer to the folder for non-integral conversions. */ + if (!(INTEGRAL_TYPE_P (t1) && INTEGRAL_TYPE_P (t2))) + return true; + + /* Only fold conversions that preserve both precisions. */ + if (TYPE_PRECISION (t1) == TYPE_PRECISION (t2) + && operand_equal_p (rm_size (t1), rm_size (t2), 0)) + return true; + + return false; +} + +/* Return an expression that does an unchecked conversion of EXPR to TYPE. + If NOTRUNC_P is true, truncation operations should be suppressed. + + Special care is required with (source or target) integral types whose + precision is not equal to their size, to make sure we fetch or assign + the value bits whose location might depend on the endianness, e.g. + + Rmsize : constant := 8; + subtype Int is Integer range 0 .. 2 ** Rmsize - 1; + + type Bit_Array is array (1 .. Rmsize) of Boolean; + pragma Pack (Bit_Array); + + function To_Bit_Array is new Unchecked_Conversion (Int, Bit_Array); + + Value : Int := 2#1000_0001#; + Vbits : Bit_Array := To_Bit_Array (Value); + + we expect the 8 bits at Vbits'Address to always contain Value, while + their original location depends on the endianness, at Value'Address + on a little-endian architecture but not on a big-endian one. */ + +tree +unchecked_convert (tree type, tree expr, bool notrunc_p) +{ + tree etype = TREE_TYPE (expr); + enum tree_code ecode = TREE_CODE (etype); + enum tree_code code = TREE_CODE (type); + int c; + + /* If the expression is already of the right type, we are done. */ + if (etype == type) + return expr; + + /* If both types types are integral just do a normal conversion. + Likewise for a conversion to an unconstrained array. */ + if ((((INTEGRAL_TYPE_P (type) + && !(code == INTEGER_TYPE && TYPE_VAX_FLOATING_POINT_P (type))) + || (POINTER_TYPE_P (type) && ! TYPE_IS_THIN_POINTER_P (type)) + || (code == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (type))) + && ((INTEGRAL_TYPE_P (etype) + && !(ecode == INTEGER_TYPE && TYPE_VAX_FLOATING_POINT_P (etype))) + || (POINTER_TYPE_P (etype) && !TYPE_IS_THIN_POINTER_P (etype)) + || (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype)))) + || code == UNCONSTRAINED_ARRAY_TYPE) + { + if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype)) + { + tree ntype = copy_type (etype); + TYPE_BIASED_REPRESENTATION_P (ntype) = 0; + TYPE_MAIN_VARIANT (ntype) = ntype; + expr = build1 (NOP_EXPR, ntype, expr); + } + + if (code == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (type)) + { + tree rtype = copy_type (type); + TYPE_BIASED_REPRESENTATION_P (rtype) = 0; + TYPE_MAIN_VARIANT (rtype) = rtype; + expr = convert (rtype, expr); + expr = build1 (NOP_EXPR, type, expr); + } + else + expr = convert (type, expr); + } + + /* If we are converting to an integral type whose precision is not equal + to its size, first unchecked convert to a record that contains an + object of the output type. Then extract the field. */ + else if (INTEGRAL_TYPE_P (type) + && TYPE_RM_SIZE (type) + && 0 != compare_tree_int (TYPE_RM_SIZE (type), + GET_MODE_BITSIZE (TYPE_MODE (type)))) + { + tree rec_type = make_node (RECORD_TYPE); + tree field = create_field_decl (get_identifier ("OBJ"), type, rec_type, + NULL_TREE, NULL_TREE, 1, 0); + + TYPE_FIELDS (rec_type) = field; + layout_type (rec_type); + + expr = unchecked_convert (rec_type, expr, notrunc_p); + expr = build_component_ref (expr, NULL_TREE, field, false); + } + + /* Similarly if we are converting from an integral type whose precision + is not equal to its size. */ + else if (INTEGRAL_TYPE_P (etype) + && TYPE_RM_SIZE (etype) + && 0 != compare_tree_int (TYPE_RM_SIZE (etype), + GET_MODE_BITSIZE (TYPE_MODE (etype)))) + { + tree rec_type = make_node (RECORD_TYPE); + tree field = create_field_decl (get_identifier ("OBJ"), etype, rec_type, + NULL_TREE, NULL_TREE, 1, 0); + VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 1); + + TYPE_FIELDS (rec_type) = field; + layout_type (rec_type); + + CONSTRUCTOR_APPEND_ELT (v, field, expr); + expr = gnat_build_constructor (rec_type, v); + expr = unchecked_convert (type, expr, notrunc_p); + } + + /* If we are converting from a scalar type to a type with a different size, + we need to pad to have the same size on both sides. + + ??? We cannot do it unconditionally because unchecked conversions are + used liberally by the front-end to implement polymorphism, e.g. in: + + S191s : constant ada__tags__addr_ptr := ada__tags__addr_ptr!(S190s); + return p___size__4 (p__object!(S191s.all)); + + so we skip all expressions that are references. */ + else if (!REFERENCE_CLASS_P (expr) + && !AGGREGATE_TYPE_P (etype) + && TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST + && (c = tree_int_cst_compare (TYPE_SIZE (etype), TYPE_SIZE (type)))) + { + if (c < 0) + { + expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0, Empty, + false, false, false, true), + expr); + expr = unchecked_convert (type, expr, notrunc_p); + } + else + { + tree rec_type = maybe_pad_type (type, TYPE_SIZE (etype), 0, Empty, + false, false, false, true); + expr = unchecked_convert (rec_type, expr, notrunc_p); + expr = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (rec_type), + false); + } + } + + /* We have a special case when we are converting between two unconstrained + array types. In that case, take the address, convert the fat pointer + types, and dereference. */ + else if (ecode == code && code == UNCONSTRAINED_ARRAY_TYPE) + expr = build_unary_op (INDIRECT_REF, NULL_TREE, + build1 (VIEW_CONVERT_EXPR, TREE_TYPE (type), + build_unary_op (ADDR_EXPR, NULL_TREE, + expr))); + + /* Another special case is when we are converting to a vector type from its + representative array type; this a regular conversion. */ + else if (code == VECTOR_TYPE + && ecode == ARRAY_TYPE + && gnat_types_compatible_p (TYPE_REPRESENTATIVE_ARRAY (type), + etype)) + expr = convert (type, expr); + + else + { + expr = maybe_unconstrained_array (expr); + etype = TREE_TYPE (expr); + ecode = TREE_CODE (etype); + if (can_fold_for_view_convert_p (expr)) + expr = fold_build1 (VIEW_CONVERT_EXPR, type, expr); + else + expr = build1 (VIEW_CONVERT_EXPR, type, expr); + } + + /* If the result is an integral type whose precision is not equal to its + size, sign- or zero-extend the result. We need not do this if the input + is an integral type of the same precision and signedness or if the output + is a biased type or if both the input and output are unsigned. */ + if (!notrunc_p + && INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type) + && !(code == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (type)) + && 0 != compare_tree_int (TYPE_RM_SIZE (type), + GET_MODE_BITSIZE (TYPE_MODE (type))) + && !(INTEGRAL_TYPE_P (etype) + && TYPE_UNSIGNED (type) == TYPE_UNSIGNED (etype) + && operand_equal_p (TYPE_RM_SIZE (type), + (TYPE_RM_SIZE (etype) != 0 + ? TYPE_RM_SIZE (etype) : TYPE_SIZE (etype)), + 0)) + && !(TYPE_UNSIGNED (type) && TYPE_UNSIGNED (etype))) + { + tree base_type + = gnat_type_for_mode (TYPE_MODE (type), TYPE_UNSIGNED (type)); + tree shift_expr + = convert (base_type, + size_binop (MINUS_EXPR, + bitsize_int + (GET_MODE_BITSIZE (TYPE_MODE (type))), + TYPE_RM_SIZE (type))); + expr + = convert (type, + build_binary_op (RSHIFT_EXPR, base_type, + build_binary_op (LSHIFT_EXPR, base_type, + convert (base_type, expr), + shift_expr), + shift_expr)); + } + + /* An unchecked conversion should never raise Constraint_Error. The code + below assumes that GCC's conversion routines overflow the same way that + the underlying hardware does. This is probably true. In the rare case + when it is false, we can rely on the fact that such conversions are + erroneous anyway. */ + if (TREE_CODE (expr) == INTEGER_CST) + TREE_OVERFLOW (expr) = 0; + + /* If the sizes of the types differ and this is an VIEW_CONVERT_EXPR, + show no longer constant. */ + if (TREE_CODE (expr) == VIEW_CONVERT_EXPR + && !operand_equal_p (TYPE_SIZE_UNIT (type), TYPE_SIZE_UNIT (etype), + OEP_ONLY_CONST)) + TREE_CONSTANT (expr) = 0; + + return expr; +} + +/* Return the appropriate GCC tree code for the specified GNAT_TYPE, + the latter being a record type as predicated by Is_Record_Type. */ + +enum tree_code +tree_code_for_record_type (Entity_Id gnat_type) +{ + Node_Id component_list + = Component_List (Type_Definition + (Declaration_Node + (Implementation_Base_Type (gnat_type)))); + Node_Id component; + + /* Make this a UNION_TYPE unless it's either not an Unchecked_Union or + we have a non-discriminant field outside a variant. In either case, + it's a RECORD_TYPE. */ + + if (!Is_Unchecked_Union (gnat_type)) + return RECORD_TYPE; + + for (component = First_Non_Pragma (Component_Items (component_list)); + Present (component); + component = Next_Non_Pragma (component)) + if (Ekind (Defining_Entity (component)) == E_Component) + return RECORD_TYPE; + + return UNION_TYPE; +} + +/* Return true if GNAT_TYPE is a "double" floating-point type, i.e. whose + size is equal to 64 bits, or an array of such a type. Set ALIGN_CLAUSE + according to the presence of an alignment clause on the type or, if it + is an array, on the component type. */ + +bool +is_double_float_or_array (Entity_Id gnat_type, bool *align_clause) +{ + gnat_type = Underlying_Type (gnat_type); + + *align_clause = Present (Alignment_Clause (gnat_type)); + + if (Is_Array_Type (gnat_type)) + { + gnat_type = Underlying_Type (Component_Type (gnat_type)); + if (Present (Alignment_Clause (gnat_type))) + *align_clause = true; + } + + if (!Is_Floating_Point_Type (gnat_type)) + return false; + + if (UI_To_Int (Esize (gnat_type)) != 64) + return false; + + return true; +} + +/* Return true if GNAT_TYPE is a "double" or larger scalar type, i.e. whose + size is greater or equal to 64 bits, or an array of such a type. Set + ALIGN_CLAUSE according to the presence of an alignment clause on the + type or, if it is an array, on the component type. */ + +bool +is_double_scalar_or_array (Entity_Id gnat_type, bool *align_clause) +{ + gnat_type = Underlying_Type (gnat_type); + + *align_clause = Present (Alignment_Clause (gnat_type)); + + if (Is_Array_Type (gnat_type)) + { + gnat_type = Underlying_Type (Component_Type (gnat_type)); + if (Present (Alignment_Clause (gnat_type))) + *align_clause = true; + } + + if (!Is_Scalar_Type (gnat_type)) + return false; + + if (UI_To_Int (Esize (gnat_type)) < 64) + return false; + + return true; +} + +/* Return true if GNU_TYPE is suitable as the type of a non-aliased + component of an aggregate type. */ + +bool +type_for_nonaliased_component_p (tree gnu_type) +{ + /* If the type is passed by reference, we may have pointers to the + component so it cannot be made non-aliased. */ + if (must_pass_by_ref (gnu_type) || default_pass_by_ref (gnu_type)) + return false; + + /* We used to say that any component of aggregate type is aliased + because the front-end may take 'Reference of it. The front-end + has been enhanced in the meantime so as to use a renaming instead + in most cases, but the back-end can probably take the address of + such a component too so we go for the conservative stance. + + For instance, we might need the address of any array type, even + if normally passed by copy, to construct a fat pointer if the + component is used as an actual for an unconstrained formal. + + Likewise for record types: even if a specific record subtype is + passed by copy, the parent type might be passed by ref (e.g. if + it's of variable size) and we might take the address of a child + component to pass to a parent formal. We have no way to check + for such conditions here. */ + if (AGGREGATE_TYPE_P (gnu_type)) + return false; + + return true; +} + +/* Perform final processing on global variables. */ + +void +gnat_write_global_declarations (void) +{ + /* Proceed to optimize and emit assembly. + FIXME: shouldn't be the front end's responsibility to call this. */ + cgraph_finalize_compilation_unit (); + + /* Emit debug info for all global declarations. */ + emit_debug_global_declarations (VEC_address (tree, global_decls), + VEC_length (tree, global_decls)); +} + +/* ************************************************************************ + * * GCC builtins support * + * ************************************************************************ */ + +/* The general scheme is fairly simple: + + For each builtin function/type to be declared, gnat_install_builtins calls + internal facilities which eventually get to gnat_push_decl, which in turn + tracks the so declared builtin function decls in the 'builtin_decls' global + datastructure. When an Intrinsic subprogram declaration is processed, we + search this global datastructure to retrieve the associated BUILT_IN DECL + node. */ + +/* Search the chain of currently available builtin declarations for a node + corresponding to function NAME (an IDENTIFIER_NODE). Return the first node + found, if any, or NULL_TREE otherwise. */ +tree +builtin_decl_for (tree name) +{ + unsigned i; + tree decl; + + FOR_EACH_VEC_ELT (tree, builtin_decls, i, decl) + if (DECL_NAME (decl) == name) + return decl; + + return NULL_TREE; +} + +/* The code below eventually exposes gnat_install_builtins, which declares + the builtin types and functions we might need, either internally or as + user accessible facilities. + + ??? This is a first implementation shot, still in rough shape. It is + heavily inspired from the "C" family implementation, with chunks copied + verbatim from there. + + Two obvious TODO candidates are + o Use a more efficient name/decl mapping scheme + o Devise a middle-end infrastructure to avoid having to copy + pieces between front-ends. */ + +/* ----------------------------------------------------------------------- * + * BUILTIN ELEMENTARY TYPES * + * ----------------------------------------------------------------------- */ + +/* Standard data types to be used in builtin argument declarations. */ + +enum c_tree_index +{ + CTI_SIGNED_SIZE_TYPE, /* For format checking only. */ + CTI_STRING_TYPE, + CTI_CONST_STRING_TYPE, + + CTI_MAX +}; + +static tree c_global_trees[CTI_MAX]; + +#define signed_size_type_node c_global_trees[CTI_SIGNED_SIZE_TYPE] +#define string_type_node c_global_trees[CTI_STRING_TYPE] +#define const_string_type_node c_global_trees[CTI_CONST_STRING_TYPE] + +/* ??? In addition some attribute handlers, we currently don't support a + (small) number of builtin-types, which in turns inhibits support for a + number of builtin functions. */ +#define wint_type_node void_type_node +#define intmax_type_node void_type_node +#define uintmax_type_node void_type_node + +/* Build the void_list_node (void_type_node having been created). */ + +static tree +build_void_list_node (void) +{ + tree t = build_tree_list (NULL_TREE, void_type_node); + return t; +} + +/* Used to help initialize the builtin-types.def table. When a type of + the correct size doesn't exist, use error_mark_node instead of NULL. + The later results in segfaults even when a decl using the type doesn't + get invoked. */ + +static tree +builtin_type_for_size (int size, bool unsignedp) +{ + tree type = gnat_type_for_size (size, unsignedp); + return type ? type : error_mark_node; +} + +/* Build/push the elementary type decls that builtin functions/types + will need. */ + +static void +install_builtin_elementary_types (void) +{ + signed_size_type_node = gnat_signed_type (size_type_node); + pid_type_node = integer_type_node; + void_list_node = build_void_list_node (); + + string_type_node = build_pointer_type (char_type_node); + const_string_type_node + = build_pointer_type (build_qualified_type + (char_type_node, TYPE_QUAL_CONST)); +} + +/* ----------------------------------------------------------------------- * + * BUILTIN FUNCTION TYPES * + * ----------------------------------------------------------------------- */ + +/* Now, builtin function types per se. */ + +enum c_builtin_type +{ +#define DEF_PRIMITIVE_TYPE(NAME, VALUE) NAME, +#define DEF_FUNCTION_TYPE_0(NAME, RETURN) NAME, +#define DEF_FUNCTION_TYPE_1(NAME, RETURN, ARG1) NAME, +#define DEF_FUNCTION_TYPE_2(NAME, RETURN, ARG1, ARG2) NAME, +#define DEF_FUNCTION_TYPE_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME, +#define DEF_FUNCTION_TYPE_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME, +#define DEF_FUNCTION_TYPE_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) NAME, +#define DEF_FUNCTION_TYPE_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6) NAME, +#define DEF_FUNCTION_TYPE_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7) NAME, +#define DEF_FUNCTION_TYPE_VAR_0(NAME, RETURN) NAME, +#define DEF_FUNCTION_TYPE_VAR_1(NAME, RETURN, ARG1) NAME, +#define DEF_FUNCTION_TYPE_VAR_2(NAME, RETURN, ARG1, ARG2) NAME, +#define DEF_FUNCTION_TYPE_VAR_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME, +#define DEF_FUNCTION_TYPE_VAR_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME, +#define DEF_FUNCTION_TYPE_VAR_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG6) \ + NAME, +#define DEF_POINTER_TYPE(NAME, TYPE) NAME, +#include "builtin-types.def" +#undef DEF_PRIMITIVE_TYPE +#undef DEF_FUNCTION_TYPE_0 +#undef DEF_FUNCTION_TYPE_1 +#undef DEF_FUNCTION_TYPE_2 +#undef DEF_FUNCTION_TYPE_3 +#undef DEF_FUNCTION_TYPE_4 +#undef DEF_FUNCTION_TYPE_5 +#undef DEF_FUNCTION_TYPE_6 +#undef DEF_FUNCTION_TYPE_7 +#undef DEF_FUNCTION_TYPE_VAR_0 +#undef DEF_FUNCTION_TYPE_VAR_1 +#undef DEF_FUNCTION_TYPE_VAR_2 +#undef DEF_FUNCTION_TYPE_VAR_3 +#undef DEF_FUNCTION_TYPE_VAR_4 +#undef DEF_FUNCTION_TYPE_VAR_5 +#undef DEF_POINTER_TYPE + BT_LAST +}; + +typedef enum c_builtin_type builtin_type; + +/* A temporary array used in communication with def_fn_type. */ +static GTY(()) tree builtin_types[(int) BT_LAST + 1]; + +/* A helper function for install_builtin_types. Build function type + for DEF with return type RET and N arguments. If VAR is true, then the + function should be variadic after those N arguments. + + Takes special care not to ICE if any of the types involved are + error_mark_node, which indicates that said type is not in fact available + (see builtin_type_for_size). In which case the function type as a whole + should be error_mark_node. */ + +static void +def_fn_type (builtin_type def, builtin_type ret, bool var, int n, ...) +{ + tree args = NULL, t; + va_list list; + int i; + + va_start (list, n); + for (i = 0; i < n; ++i) + { + builtin_type a = (builtin_type) va_arg (list, int); + t = builtin_types[a]; + if (t == error_mark_node) + goto egress; + args = tree_cons (NULL_TREE, t, args); + } + va_end (list); + + args = nreverse (args); + if (!var) + args = chainon (args, void_list_node); + + t = builtin_types[ret]; + if (t == error_mark_node) + goto egress; + t = build_function_type (t, args); + + egress: + builtin_types[def] = t; +} + +/* Build the builtin function types and install them in the builtin_types + array for later use in builtin function decls. */ + +static void +install_builtin_function_types (void) +{ + tree va_list_ref_type_node; + tree va_list_arg_type_node; + + if (TREE_CODE (va_list_type_node) == ARRAY_TYPE) + { + va_list_arg_type_node = va_list_ref_type_node = + build_pointer_type (TREE_TYPE (va_list_type_node)); + } + else + { + va_list_arg_type_node = va_list_type_node; + va_list_ref_type_node = build_reference_type (va_list_type_node); + } + +#define DEF_PRIMITIVE_TYPE(ENUM, VALUE) \ + builtin_types[ENUM] = VALUE; +#define DEF_FUNCTION_TYPE_0(ENUM, RETURN) \ + def_fn_type (ENUM, RETURN, 0, 0); +#define DEF_FUNCTION_TYPE_1(ENUM, RETURN, ARG1) \ + def_fn_type (ENUM, RETURN, 0, 1, ARG1); +#define DEF_FUNCTION_TYPE_2(ENUM, RETURN, ARG1, ARG2) \ + def_fn_type (ENUM, RETURN, 0, 2, ARG1, ARG2); +#define DEF_FUNCTION_TYPE_3(ENUM, RETURN, ARG1, ARG2, ARG3) \ + def_fn_type (ENUM, RETURN, 0, 3, ARG1, ARG2, ARG3); +#define DEF_FUNCTION_TYPE_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \ + def_fn_type (ENUM, RETURN, 0, 4, ARG1, ARG2, ARG3, ARG4); +#define DEF_FUNCTION_TYPE_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \ + def_fn_type (ENUM, RETURN, 0, 5, ARG1, ARG2, ARG3, ARG4, ARG5); +#define DEF_FUNCTION_TYPE_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6) \ + def_fn_type (ENUM, RETURN, 0, 6, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6); +#define DEF_FUNCTION_TYPE_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6, ARG7) \ + def_fn_type (ENUM, RETURN, 0, 7, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7); +#define DEF_FUNCTION_TYPE_VAR_0(ENUM, RETURN) \ + def_fn_type (ENUM, RETURN, 1, 0); +#define DEF_FUNCTION_TYPE_VAR_1(ENUM, RETURN, ARG1) \ + def_fn_type (ENUM, RETURN, 1, 1, ARG1); +#define DEF_FUNCTION_TYPE_VAR_2(ENUM, RETURN, ARG1, ARG2) \ + def_fn_type (ENUM, RETURN, 1, 2, ARG1, ARG2); +#define DEF_FUNCTION_TYPE_VAR_3(ENUM, RETURN, ARG1, ARG2, ARG3) \ + def_fn_type (ENUM, RETURN, 1, 3, ARG1, ARG2, ARG3); +#define DEF_FUNCTION_TYPE_VAR_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \ + def_fn_type (ENUM, RETURN, 1, 4, ARG1, ARG2, ARG3, ARG4); +#define DEF_FUNCTION_TYPE_VAR_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \ + def_fn_type (ENUM, RETURN, 1, 5, ARG1, ARG2, ARG3, ARG4, ARG5); +#define DEF_POINTER_TYPE(ENUM, TYPE) \ + builtin_types[(int) ENUM] = build_pointer_type (builtin_types[(int) TYPE]); + +#include "builtin-types.def" + +#undef DEF_PRIMITIVE_TYPE +#undef DEF_FUNCTION_TYPE_1 +#undef DEF_FUNCTION_TYPE_2 +#undef DEF_FUNCTION_TYPE_3 +#undef DEF_FUNCTION_TYPE_4 +#undef DEF_FUNCTION_TYPE_5 +#undef DEF_FUNCTION_TYPE_6 +#undef DEF_FUNCTION_TYPE_VAR_0 +#undef DEF_FUNCTION_TYPE_VAR_1 +#undef DEF_FUNCTION_TYPE_VAR_2 +#undef DEF_FUNCTION_TYPE_VAR_3 +#undef DEF_FUNCTION_TYPE_VAR_4 +#undef DEF_FUNCTION_TYPE_VAR_5 +#undef DEF_POINTER_TYPE + builtin_types[(int) BT_LAST] = NULL_TREE; +} + +/* ----------------------------------------------------------------------- * + * BUILTIN ATTRIBUTES * + * ----------------------------------------------------------------------- */ + +enum built_in_attribute +{ +#define DEF_ATTR_NULL_TREE(ENUM) ENUM, +#define DEF_ATTR_INT(ENUM, VALUE) ENUM, +#define DEF_ATTR_IDENT(ENUM, STRING) ENUM, +#define DEF_ATTR_TREE_LIST(ENUM, PURPOSE, VALUE, CHAIN) ENUM, +#include "builtin-attrs.def" +#undef DEF_ATTR_NULL_TREE +#undef DEF_ATTR_INT +#undef DEF_ATTR_IDENT +#undef DEF_ATTR_TREE_LIST + ATTR_LAST +}; + +static GTY(()) tree built_in_attributes[(int) ATTR_LAST]; + +static void +install_builtin_attributes (void) +{ + /* Fill in the built_in_attributes array. */ +#define DEF_ATTR_NULL_TREE(ENUM) \ + built_in_attributes[(int) ENUM] = NULL_TREE; +#define DEF_ATTR_INT(ENUM, VALUE) \ + built_in_attributes[(int) ENUM] = build_int_cst (NULL_TREE, VALUE); +#define DEF_ATTR_IDENT(ENUM, STRING) \ + built_in_attributes[(int) ENUM] = get_identifier (STRING); +#define DEF_ATTR_TREE_LIST(ENUM, PURPOSE, VALUE, CHAIN) \ + built_in_attributes[(int) ENUM] \ + = tree_cons (built_in_attributes[(int) PURPOSE], \ + built_in_attributes[(int) VALUE], \ + built_in_attributes[(int) CHAIN]); +#include "builtin-attrs.def" +#undef DEF_ATTR_NULL_TREE +#undef DEF_ATTR_INT +#undef DEF_ATTR_IDENT +#undef DEF_ATTR_TREE_LIST +} + +/* Handle a "const" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_const_attribute (tree *node, tree ARG_UNUSED (name), + tree ARG_UNUSED (args), int ARG_UNUSED (flags), + bool *no_add_attrs) +{ + if (TREE_CODE (*node) == FUNCTION_DECL) + TREE_READONLY (*node) = 1; + else + *no_add_attrs = true; + + return NULL_TREE; +} + +/* Handle a "nothrow" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_nothrow_attribute (tree *node, tree ARG_UNUSED (name), + tree ARG_UNUSED (args), int ARG_UNUSED (flags), + bool *no_add_attrs) +{ + if (TREE_CODE (*node) == FUNCTION_DECL) + TREE_NOTHROW (*node) = 1; + else + *no_add_attrs = true; + + return NULL_TREE; +} + +/* Handle a "pure" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_pure_attribute (tree *node, tree name, tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + if (TREE_CODE (*node) == FUNCTION_DECL) + DECL_PURE_P (*node) = 1; + /* ??? TODO: Support types. */ + else + { + warning (OPT_Wattributes, "%qs attribute ignored", + IDENTIFIER_POINTER (name)); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "no vops" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_novops_attribute (tree *node, tree ARG_UNUSED (name), + tree ARG_UNUSED (args), int ARG_UNUSED (flags), + bool *ARG_UNUSED (no_add_attrs)) +{ + gcc_assert (TREE_CODE (*node) == FUNCTION_DECL); + DECL_IS_NOVOPS (*node) = 1; + return NULL_TREE; +} + +/* Helper for nonnull attribute handling; fetch the operand number + from the attribute argument list. */ + +static bool +get_nonnull_operand (tree arg_num_expr, unsigned HOST_WIDE_INT *valp) +{ + /* Verify the arg number is a constant. */ + if (TREE_CODE (arg_num_expr) != INTEGER_CST + || TREE_INT_CST_HIGH (arg_num_expr) != 0) + return false; + + *valp = TREE_INT_CST_LOW (arg_num_expr); + return true; +} + +/* Handle the "nonnull" attribute. */ +static tree +handle_nonnull_attribute (tree *node, tree ARG_UNUSED (name), + tree args, int ARG_UNUSED (flags), + bool *no_add_attrs) +{ + tree type = *node; + unsigned HOST_WIDE_INT attr_arg_num; + + /* If no arguments are specified, all pointer arguments should be + non-null. Verify a full prototype is given so that the arguments + will have the correct types when we actually check them later. */ + if (!args) + { + if (!prototype_p (type)) + { + error ("nonnull attribute without arguments on a non-prototype"); + *no_add_attrs = true; + } + return NULL_TREE; + } + + /* Argument list specified. Verify that each argument number references + a pointer argument. */ + for (attr_arg_num = 1; args; args = TREE_CHAIN (args)) + { + tree argument; + unsigned HOST_WIDE_INT arg_num = 0, ck_num; + + if (!get_nonnull_operand (TREE_VALUE (args), &arg_num)) + { + error ("nonnull argument has invalid operand number (argument %lu)", + (unsigned long) attr_arg_num); + *no_add_attrs = true; + return NULL_TREE; + } + + argument = TYPE_ARG_TYPES (type); + if (argument) + { + for (ck_num = 1; ; ck_num++) + { + if (!argument || ck_num == arg_num) + break; + argument = TREE_CHAIN (argument); + } + + if (!argument + || TREE_CODE (TREE_VALUE (argument)) == VOID_TYPE) + { + error ("nonnull argument with out-of-range operand number " + "(argument %lu, operand %lu)", + (unsigned long) attr_arg_num, (unsigned long) arg_num); + *no_add_attrs = true; + return NULL_TREE; + } + + if (TREE_CODE (TREE_VALUE (argument)) != POINTER_TYPE) + { + error ("nonnull argument references non-pointer operand " + "(argument %lu, operand %lu)", + (unsigned long) attr_arg_num, (unsigned long) arg_num); + *no_add_attrs = true; + return NULL_TREE; + } + } + } + + return NULL_TREE; +} + +/* Handle a "sentinel" attribute. */ + +static tree +handle_sentinel_attribute (tree *node, tree name, tree args, + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + tree params = TYPE_ARG_TYPES (*node); + + if (!prototype_p (*node)) + { + warning (OPT_Wattributes, + "%qs attribute requires prototypes with named arguments", + IDENTIFIER_POINTER (name)); + *no_add_attrs = true; + } + else + { + while (TREE_CHAIN (params)) + params = TREE_CHAIN (params); + + if (VOID_TYPE_P (TREE_VALUE (params))) + { + warning (OPT_Wattributes, + "%qs attribute only applies to variadic functions", + IDENTIFIER_POINTER (name)); + *no_add_attrs = true; + } + } + + if (args) + { + tree position = TREE_VALUE (args); + + if (TREE_CODE (position) != INTEGER_CST) + { + warning (0, "requested position is not an integer constant"); + *no_add_attrs = true; + } + else + { + if (tree_int_cst_lt (position, integer_zero_node)) + { + warning (0, "requested position is less than zero"); + *no_add_attrs = true; + } + } + } + + return NULL_TREE; +} + +/* Handle a "noreturn" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_noreturn_attribute (tree *node, tree name, tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + tree type = TREE_TYPE (*node); + + /* See FIXME comment in c_common_attribute_table. */ + if (TREE_CODE (*node) == FUNCTION_DECL) + TREE_THIS_VOLATILE (*node) = 1; + else if (TREE_CODE (type) == POINTER_TYPE + && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE) + TREE_TYPE (*node) + = build_pointer_type + (build_type_variant (TREE_TYPE (type), + TYPE_READONLY (TREE_TYPE (type)), 1)); + else + { + warning (OPT_Wattributes, "%qs attribute ignored", + IDENTIFIER_POINTER (name)); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "leaf" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_leaf_attribute (tree *node, tree name, + tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + if (TREE_CODE (*node) != FUNCTION_DECL) + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + if (!TREE_PUBLIC (*node)) + { + warning (OPT_Wattributes, "%qE attribute has no effect", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "malloc" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_malloc_attribute (tree *node, tree name, tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + if (TREE_CODE (*node) == FUNCTION_DECL + && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (*node)))) + DECL_IS_MALLOC (*node) = 1; + else + { + warning (OPT_Wattributes, "%qs attribute ignored", + IDENTIFIER_POINTER (name)); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Fake handler for attributes we don't properly support. */ + +tree +fake_attribute_handler (tree * ARG_UNUSED (node), + tree ARG_UNUSED (name), + tree ARG_UNUSED (args), + int ARG_UNUSED (flags), + bool * ARG_UNUSED (no_add_attrs)) +{ + return NULL_TREE; +} + +/* Handle a "type_generic" attribute. */ + +static tree +handle_type_generic_attribute (tree *node, tree ARG_UNUSED (name), + tree ARG_UNUSED (args), int ARG_UNUSED (flags), + bool * ARG_UNUSED (no_add_attrs)) +{ + tree params; + + /* Ensure we have a function type. */ + gcc_assert (TREE_CODE (*node) == FUNCTION_TYPE); + + params = TYPE_ARG_TYPES (*node); + while (params && ! VOID_TYPE_P (TREE_VALUE (params))) + params = TREE_CHAIN (params); + + /* Ensure we have a variadic function. */ + gcc_assert (!params); + + return NULL_TREE; +} + +/* Handle a "vector_size" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_vector_size_attribute (tree *node, tree name, tree args, + int ARG_UNUSED (flags), + bool *no_add_attrs) +{ + unsigned HOST_WIDE_INT vecsize, nunits; + enum machine_mode orig_mode; + tree type = *node, new_type, size; + + *no_add_attrs = true; + + size = TREE_VALUE (args); + + if (!host_integerp (size, 1)) + { + warning (OPT_Wattributes, "%qs attribute ignored", + IDENTIFIER_POINTER (name)); + return NULL_TREE; + } + + /* Get the vector size (in bytes). */ + vecsize = tree_low_cst (size, 1); + + /* We need to provide for vector pointers, vector arrays, and + functions returning vectors. For example: + + __attribute__((vector_size(16))) short *foo; + + In this case, the mode is SI, but the type being modified is + HI, so we need to look further. */ + + while (POINTER_TYPE_P (type) + || TREE_CODE (type) == FUNCTION_TYPE + || TREE_CODE (type) == ARRAY_TYPE) + type = TREE_TYPE (type); + + /* Get the mode of the type being modified. */ + orig_mode = TYPE_MODE (type); + + if ((!INTEGRAL_TYPE_P (type) + && !SCALAR_FLOAT_TYPE_P (type) + && !FIXED_POINT_TYPE_P (type)) + || (!SCALAR_FLOAT_MODE_P (orig_mode) + && GET_MODE_CLASS (orig_mode) != MODE_INT + && !ALL_SCALAR_FIXED_POINT_MODE_P (orig_mode)) + || !host_integerp (TYPE_SIZE_UNIT (type), 1) + || TREE_CODE (type) == BOOLEAN_TYPE) + { + error ("invalid vector type for attribute %qs", + IDENTIFIER_POINTER (name)); + return NULL_TREE; + } + + if (vecsize % tree_low_cst (TYPE_SIZE_UNIT (type), 1)) + { + error ("vector size not an integral multiple of component size"); + return NULL; + } + + if (vecsize == 0) + { + error ("zero vector size"); + return NULL; + } + + /* Calculate how many units fit in the vector. */ + nunits = vecsize / tree_low_cst (TYPE_SIZE_UNIT (type), 1); + if (nunits & (nunits - 1)) + { + error ("number of components of the vector not a power of two"); + return NULL_TREE; + } + + new_type = build_vector_type (type, nunits); + + /* Build back pointers if needed. */ + *node = reconstruct_complex_type (*node, new_type); + + return NULL_TREE; +} + +/* Handle a "vector_type" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_vector_type_attribute (tree *node, tree name, tree ARG_UNUSED (args), + int ARG_UNUSED (flags), + bool *no_add_attrs) +{ + /* Vector representative type and size. */ + tree rep_type = *node; + tree rep_size = TYPE_SIZE_UNIT (rep_type); + tree rep_name; + + /* Vector size in bytes and number of units. */ + unsigned HOST_WIDE_INT vec_bytes, vec_units; + + /* Vector element type and mode. */ + tree elem_type; + enum machine_mode elem_mode; + + *no_add_attrs = true; + + /* Get the representative array type, possibly nested within a + padding record e.g. for alignment purposes. */ + + if (TYPE_IS_PADDING_P (rep_type)) + rep_type = TREE_TYPE (TYPE_FIELDS (rep_type)); + + if (TREE_CODE (rep_type) != ARRAY_TYPE) + { + error ("attribute %qs applies to array types only", + IDENTIFIER_POINTER (name)); + return NULL_TREE; + } + + /* Silently punt on variable sizes. We can't make vector types for them, + need to ignore them on front-end generated subtypes of unconstrained + bases, and this attribute is for binding implementors, not end-users, so + we should never get there from legitimate explicit uses. */ + + if (!host_integerp (rep_size, 1)) + return NULL_TREE; + + /* Get the element type/mode and check this is something we know + how to make vectors of. */ + + elem_type = TREE_TYPE (rep_type); + elem_mode = TYPE_MODE (elem_type); + + if ((!INTEGRAL_TYPE_P (elem_type) + && !SCALAR_FLOAT_TYPE_P (elem_type) + && !FIXED_POINT_TYPE_P (elem_type)) + || (!SCALAR_FLOAT_MODE_P (elem_mode) + && GET_MODE_CLASS (elem_mode) != MODE_INT + && !ALL_SCALAR_FIXED_POINT_MODE_P (elem_mode)) + || !host_integerp (TYPE_SIZE_UNIT (elem_type), 1)) + { + error ("invalid element type for attribute %qs", + IDENTIFIER_POINTER (name)); + return NULL_TREE; + } + + /* Sanity check the vector size and element type consistency. */ + + vec_bytes = tree_low_cst (rep_size, 1); + + if (vec_bytes % tree_low_cst (TYPE_SIZE_UNIT (elem_type), 1)) + { + error ("vector size not an integral multiple of component size"); + return NULL; + } + + if (vec_bytes == 0) + { + error ("zero vector size"); + return NULL; + } + + vec_units = vec_bytes / tree_low_cst (TYPE_SIZE_UNIT (elem_type), 1); + if (vec_units & (vec_units - 1)) + { + error ("number of components of the vector not a power of two"); + return NULL_TREE; + } + + /* Build the vector type and replace. */ + + *node = build_vector_type (elem_type, vec_units); + rep_name = TYPE_NAME (rep_type); + if (TREE_CODE (rep_name) == TYPE_DECL) + rep_name = DECL_NAME (rep_name); + TYPE_NAME (*node) = rep_name; + TYPE_REPRESENTATIVE_ARRAY (*node) = rep_type; + + return NULL_TREE; +} + +/* ----------------------------------------------------------------------- * + * BUILTIN FUNCTIONS * + * ----------------------------------------------------------------------- */ + +/* Worker for DEF_BUILTIN. Possibly define a builtin function with one or two + names. Does not declare a non-__builtin_ function if flag_no_builtin, or + if nonansi_p and flag_no_nonansi_builtin. */ + +static void +def_builtin_1 (enum built_in_function fncode, + const char *name, + enum built_in_class fnclass, + tree fntype, tree libtype, + bool both_p, bool fallback_p, + bool nonansi_p ATTRIBUTE_UNUSED, + tree fnattrs, bool implicit_p) +{ + tree decl; + const char *libname; + + /* Preserve an already installed decl. It most likely was setup in advance + (e.g. as part of the internal builtins) for specific reasons. */ + if (built_in_decls[(int) fncode] != NULL_TREE) + return; + + gcc_assert ((!both_p && !fallback_p) + || !strncmp (name, "__builtin_", + strlen ("__builtin_"))); + + libname = name + strlen ("__builtin_"); + decl = add_builtin_function (name, fntype, fncode, fnclass, + (fallback_p ? libname : NULL), + fnattrs); + if (both_p) + /* ??? This is normally further controlled by command-line options + like -fno-builtin, but we don't have them for Ada. */ + add_builtin_function (libname, libtype, fncode, fnclass, + NULL, fnattrs); + + built_in_decls[(int) fncode] = decl; + if (implicit_p) + implicit_built_in_decls[(int) fncode] = decl; +} + +static int flag_isoc94 = 0; +static int flag_isoc99 = 0; + +/* Install what the common builtins.def offers. */ + +static void +install_builtin_functions (void) +{ +#define DEF_BUILTIN(ENUM, NAME, CLASS, TYPE, LIBTYPE, BOTH_P, FALLBACK_P, \ + NONANSI_P, ATTRS, IMPLICIT, COND) \ + if (NAME && COND) \ + def_builtin_1 (ENUM, NAME, CLASS, \ + builtin_types[(int) TYPE], \ + builtin_types[(int) LIBTYPE], \ + BOTH_P, FALLBACK_P, NONANSI_P, \ + built_in_attributes[(int) ATTRS], IMPLICIT); +#include "builtins.def" +#undef DEF_BUILTIN +} + +/* ----------------------------------------------------------------------- * + * BUILTIN FUNCTIONS * + * ----------------------------------------------------------------------- */ + +/* Install the builtin functions we might need. */ + +void +gnat_install_builtins (void) +{ + install_builtin_elementary_types (); + install_builtin_function_types (); + install_builtin_attributes (); + + /* Install builtins used by generic middle-end pieces first. Some of these + know about internal specificities and control attributes accordingly, for + instance __builtin_alloca vs no-throw and -fstack-check. We will ignore + the generic definition from builtins.def. */ + build_common_builtin_nodes (); + + /* Now, install the target specific builtins, such as the AltiVec family on + ppc, and the common set as exposed by builtins.def. */ + targetm.init_builtins (); + install_builtin_functions (); +} + +#include "gt-ada-utils.h" +#include "gtype-ada.h" diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c new file mode 100644 index 000000000..7028cdcd0 --- /dev/null +++ b/gcc/ada/gcc-interface/utils2.c @@ -0,0 +1,2574 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * U T I L S 2 * + * * + * C Implementation File * + * * + * 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. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License along with GCC; see the file COPYING3. If not see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tm.h" +#include "tree.h" +#include "flags.h" +#include "ggc.h" +#include "output.h" +#include "tree-inline.h" + +#include "ada.h" +#include "types.h" +#include "atree.h" +#include "elists.h" +#include "namet.h" +#include "nlists.h" +#include "snames.h" +#include "stringt.h" +#include "uintp.h" +#include "fe.h" +#include "sinfo.h" +#include "einfo.h" +#include "ada-tree.h" +#include "gigi.h" + +/* Return the base type of TYPE. */ + +tree +get_base_type (tree type) +{ + if (TREE_CODE (type) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (type)) + type = TREE_TYPE (TYPE_FIELDS (type)); + + while (TREE_TYPE (type) + && (TREE_CODE (type) == INTEGER_TYPE + || TREE_CODE (type) == REAL_TYPE)) + type = TREE_TYPE (type); + + return type; +} + +/* EXP is a GCC tree representing an address. See if we can find how + strictly the object at that address is aligned. Return that alignment + in bits. If we don't know anything about the alignment, return 0. */ + +unsigned int +known_alignment (tree exp) +{ + unsigned int this_alignment; + unsigned int lhs, rhs; + + switch (TREE_CODE (exp)) + { + CASE_CONVERT: + case VIEW_CONVERT_EXPR: + case NON_LVALUE_EXPR: + /* Conversions between pointers and integers don't change the alignment + of the underlying object. */ + this_alignment = known_alignment (TREE_OPERAND (exp, 0)); + break; + + case COMPOUND_EXPR: + /* The value of a COMPOUND_EXPR is that of it's second operand. */ + this_alignment = known_alignment (TREE_OPERAND (exp, 1)); + break; + + case PLUS_EXPR: + case MINUS_EXPR: + /* If two address are added, the alignment of the result is the + minimum of the two alignments. */ + lhs = known_alignment (TREE_OPERAND (exp, 0)); + rhs = known_alignment (TREE_OPERAND (exp, 1)); + this_alignment = MIN (lhs, rhs); + break; + + case POINTER_PLUS_EXPR: + lhs = known_alignment (TREE_OPERAND (exp, 0)); + rhs = known_alignment (TREE_OPERAND (exp, 1)); + /* If we don't know the alignment of the offset, we assume that + of the base. */ + if (rhs == 0) + this_alignment = lhs; + else + this_alignment = MIN (lhs, rhs); + break; + + case COND_EXPR: + /* If there is a choice between two values, use the smallest one. */ + lhs = known_alignment (TREE_OPERAND (exp, 1)); + rhs = known_alignment (TREE_OPERAND (exp, 2)); + this_alignment = MIN (lhs, rhs); + break; + + case INTEGER_CST: + { + unsigned HOST_WIDE_INT c = TREE_INT_CST_LOW (exp); + /* The first part of this represents the lowest bit in the constant, + but it is originally in bytes, not bits. */ + this_alignment = MIN (BITS_PER_UNIT * (c & -c), BIGGEST_ALIGNMENT); + } + break; + + case MULT_EXPR: + /* If we know the alignment of just one side, use it. Otherwise, + use the product of the alignments. */ + lhs = known_alignment (TREE_OPERAND (exp, 0)); + rhs = known_alignment (TREE_OPERAND (exp, 1)); + + if (lhs == 0) + this_alignment = rhs; + else if (rhs == 0) + this_alignment = lhs; + else + this_alignment = MIN (lhs * rhs, BIGGEST_ALIGNMENT); + break; + + case BIT_AND_EXPR: + /* A bit-and expression is as aligned as the maximum alignment of the + operands. We typically get here for a complex lhs and a constant + negative power of two on the rhs to force an explicit alignment, so + don't bother looking at the lhs. */ + this_alignment = known_alignment (TREE_OPERAND (exp, 1)); + break; + + case ADDR_EXPR: + this_alignment = expr_align (TREE_OPERAND (exp, 0)); + break; + + case CALL_EXPR: + { + tree t = maybe_inline_call_in_expr (exp); + if (t) + return known_alignment (t); + } + + /* Fall through... */ + + default: + /* For other pointer expressions, we assume that the pointed-to object + is at least as aligned as the pointed-to type. Beware that we can + have a dummy type here (e.g. a Taft Amendment type), for which the + alignment is meaningless and should be ignored. */ + if (POINTER_TYPE_P (TREE_TYPE (exp)) + && !TYPE_IS_DUMMY_P (TREE_TYPE (TREE_TYPE (exp)))) + this_alignment = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (exp))); + else + this_alignment = 0; + break; + } + + return this_alignment; +} + +/* We have a comparison or assignment operation on two types, T1 and T2, which + are either both array types or both record types. T1 is assumed to be for + the left hand side operand, and T2 for the right hand side. Return the + type that both operands should be converted to for the operation, if any. + Otherwise return zero. */ + +static tree +find_common_type (tree t1, tree t2) +{ + /* ??? As of today, various constructs lead here with types of different + sizes even when both constants (e.g. tagged types, packable vs regular + component types, padded vs unpadded types, ...). While some of these + would better be handled upstream (types should be made consistent before + calling into build_binary_op), some others are really expected and we + have to be careful. */ + + /* We must avoid writing more than what the target can hold if this is for + an assignment and the case of tagged types is handled in build_binary_op + so we use the lhs type if it is known to be smaller or of constant size + and the rhs type is not, whatever the modes. We also force t1 in case of + constant size equality to minimize occurrences of view conversions on the + lhs of an assignment, except for the case of record types with a variant + part on the lhs but not on the rhs to make the conversion simpler. */ + if (TREE_CONSTANT (TYPE_SIZE (t1)) + && (!TREE_CONSTANT (TYPE_SIZE (t2)) + || tree_int_cst_lt (TYPE_SIZE (t1), TYPE_SIZE (t2)) + || (TYPE_SIZE (t1) == TYPE_SIZE (t2) + && !(TREE_CODE (t1) == RECORD_TYPE + && TREE_CODE (t2) == RECORD_TYPE + && get_variant_part (t1) != NULL_TREE + && get_variant_part (t2) == NULL_TREE)))) + return t1; + + /* Otherwise, if the lhs type is non-BLKmode, use it. Note that we know + that we will not have any alignment problems since, if we did, the + non-BLKmode type could not have been used. */ + if (TYPE_MODE (t1) != BLKmode) + return t1; + + /* If the rhs type is of constant size, use it whatever the modes. At + this point it is known to be smaller, or of constant size and the + lhs type is not. */ + if (TREE_CONSTANT (TYPE_SIZE (t2))) + return t2; + + /* Otherwise, if the rhs type is non-BLKmode, use it. */ + if (TYPE_MODE (t2) != BLKmode) + return t2; + + /* In this case, both types have variable size and BLKmode. It's + probably best to leave the "type mismatch" because changing it + could cause a bad self-referential reference. */ + return NULL_TREE; +} + +/* Return an expression tree representing an equality comparison of A1 and A2, + two objects of type ARRAY_TYPE. The result should be of type RESULT_TYPE. + + Two arrays are equal in one of two ways: (1) if both have zero length in + some dimension (not necessarily the same dimension) or (2) if the lengths + in each dimension are equal and the data is equal. We perform the length + tests in as efficient a manner as possible. */ + +static tree +compare_arrays (location_t loc, tree result_type, tree a1, tree a2) +{ + tree result = convert (result_type, boolean_true_node); + tree a1_is_null = convert (result_type, boolean_false_node); + tree a2_is_null = convert (result_type, boolean_false_node); + tree t1 = TREE_TYPE (a1); + tree t2 = TREE_TYPE (a2); + bool a1_side_effects_p = TREE_SIDE_EFFECTS (a1); + bool a2_side_effects_p = TREE_SIDE_EFFECTS (a2); + bool length_zero_p = false; + + /* If either operand has side-effects, they have to be evaluated only once + in spite of the multiple references to the operand in the comparison. */ + if (a1_side_effects_p) + a1 = gnat_protect_expr (a1); + + if (a2_side_effects_p) + a2 = gnat_protect_expr (a2); + + /* Process each dimension separately and compare the lengths. If any + dimension has a length known to be zero, set LENGTH_ZERO_P to true + in order to suppress the comparison of the data at the end. */ + while (TREE_CODE (t1) == ARRAY_TYPE && TREE_CODE (t2) == ARRAY_TYPE) + { + tree lb1 = TYPE_MIN_VALUE (TYPE_DOMAIN (t1)); + tree ub1 = TYPE_MAX_VALUE (TYPE_DOMAIN (t1)); + tree lb2 = TYPE_MIN_VALUE (TYPE_DOMAIN (t2)); + tree ub2 = TYPE_MAX_VALUE (TYPE_DOMAIN (t2)); + tree length1 = size_binop (PLUS_EXPR, size_binop (MINUS_EXPR, ub1, lb1), + size_one_node); + tree length2 = size_binop (PLUS_EXPR, size_binop (MINUS_EXPR, ub2, lb2), + size_one_node); + tree comparison, this_a1_is_null, this_a2_is_null; + + /* If the length of the first array is a constant, swap our operands + unless the length of the second array is the constant zero. */ + if (TREE_CODE (length1) == INTEGER_CST && !integer_zerop (length2)) + { + tree tem; + bool btem; + + tem = a1, a1 = a2, a2 = tem; + tem = t1, t1 = t2, t2 = tem; + tem = lb1, lb1 = lb2, lb2 = tem; + tem = ub1, ub1 = ub2, ub2 = tem; + tem = length1, length1 = length2, length2 = tem; + tem = a1_is_null, a1_is_null = a2_is_null, a2_is_null = tem; + btem = a1_side_effects_p, a1_side_effects_p = a2_side_effects_p, + a2_side_effects_p = btem; + } + + /* If the length of the second array is the constant zero, we can just + use the original stored bounds for the first array and see whether + last < first holds. */ + if (integer_zerop (length2)) + { + length_zero_p = true; + + ub1 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))); + lb1 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))); + + comparison = fold_build2_loc (loc, LT_EXPR, result_type, ub1, lb1); + comparison = SUBSTITUTE_PLACEHOLDER_IN_EXPR (comparison, a1); + if (EXPR_P (comparison)) + SET_EXPR_LOCATION (comparison, loc); + + this_a1_is_null = comparison; + this_a2_is_null = convert (result_type, boolean_true_node); + } + + /* Otherwise, if the length is some other constant value, we know that + this dimension in the second array cannot be superflat, so we can + just use its length computed from the actual stored bounds. */ + else if (TREE_CODE (length2) == INTEGER_CST) + { + tree bt; + + ub1 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))); + lb1 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))); + /* Note that we know that UB2 and LB2 are constant and hence + cannot contain a PLACEHOLDER_EXPR. */ + ub2 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2))); + lb2 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2))); + bt = get_base_type (TREE_TYPE (ub1)); + + comparison + = fold_build2_loc (loc, EQ_EXPR, result_type, + build_binary_op (MINUS_EXPR, bt, ub1, lb1), + build_binary_op (MINUS_EXPR, bt, ub2, lb2)); + comparison = SUBSTITUTE_PLACEHOLDER_IN_EXPR (comparison, a1); + if (EXPR_P (comparison)) + SET_EXPR_LOCATION (comparison, loc); + + this_a1_is_null + = fold_build2_loc (loc, LT_EXPR, result_type, ub1, lb1); + + this_a2_is_null = convert (result_type, boolean_false_node); + } + + /* Otherwise, compare the computed lengths. */ + else + { + length1 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1, a1); + length2 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length2, a2); + + comparison + = fold_build2_loc (loc, EQ_EXPR, result_type, length1, length2); + + /* If the length expression is of the form (cond ? val : 0), assume + that cond is equivalent to (length != 0). That's guaranteed by + construction of the array types in gnat_to_gnu_entity. */ + if (TREE_CODE (length1) == COND_EXPR + && integer_zerop (TREE_OPERAND (length1, 2))) + this_a1_is_null + = invert_truthvalue_loc (loc, TREE_OPERAND (length1, 0)); + else + this_a1_is_null = fold_build2_loc (loc, EQ_EXPR, result_type, + length1, size_zero_node); + + /* Likewise for the second array. */ + if (TREE_CODE (length2) == COND_EXPR + && integer_zerop (TREE_OPERAND (length2, 2))) + this_a2_is_null + = invert_truthvalue_loc (loc, TREE_OPERAND (length2, 0)); + else + this_a2_is_null = fold_build2_loc (loc, EQ_EXPR, result_type, + length2, size_zero_node); + } + + /* Append expressions for this dimension to the final expressions. */ + result = build_binary_op (TRUTH_ANDIF_EXPR, result_type, + result, comparison); + + a1_is_null = build_binary_op (TRUTH_ORIF_EXPR, result_type, + this_a1_is_null, a1_is_null); + + a2_is_null = build_binary_op (TRUTH_ORIF_EXPR, result_type, + this_a2_is_null, a2_is_null); + + t1 = TREE_TYPE (t1); + t2 = TREE_TYPE (t2); + } + + /* Unless the length of some dimension is known to be zero, compare the + data in the array. */ + if (!length_zero_p) + { + tree type = find_common_type (TREE_TYPE (a1), TREE_TYPE (a2)); + tree comparison; + + if (type) + { + a1 = convert (type, a1), + a2 = convert (type, a2); + } + + comparison = fold_build2_loc (loc, EQ_EXPR, result_type, a1, a2); + + result + = build_binary_op (TRUTH_ANDIF_EXPR, result_type, result, comparison); + } + + /* The result is also true if both sizes are zero. */ + result = build_binary_op (TRUTH_ORIF_EXPR, result_type, + build_binary_op (TRUTH_ANDIF_EXPR, result_type, + a1_is_null, a2_is_null), + result); + + /* If either operand has side-effects, they have to be evaluated before + starting the comparison above since the place they would be otherwise + evaluated could be wrong. */ + if (a1_side_effects_p) + result = build2 (COMPOUND_EXPR, result_type, a1, result); + + if (a2_side_effects_p) + result = build2 (COMPOUND_EXPR, result_type, a2, result); + + return result; +} + +/* Compute the result of applying OP_CODE to LHS and RHS, where both are of + type TYPE. We know that TYPE is a modular type with a nonbinary + modulus. */ + +static tree +nonbinary_modular_operation (enum tree_code op_code, tree type, tree lhs, + tree rhs) +{ + tree modulus = TYPE_MODULUS (type); + unsigned int needed_precision = tree_floor_log2 (modulus) + 1; + unsigned int precision; + bool unsignedp = true; + tree op_type = type; + tree result; + + /* If this is an addition of a constant, convert it to a subtraction + of a constant since we can do that faster. */ + if (op_code == PLUS_EXPR && TREE_CODE (rhs) == INTEGER_CST) + { + rhs = fold_build2 (MINUS_EXPR, type, modulus, rhs); + op_code = MINUS_EXPR; + } + + /* For the logical operations, we only need PRECISION bits. For + addition and subtraction, we need one more and for multiplication we + need twice as many. But we never want to make a size smaller than + our size. */ + if (op_code == PLUS_EXPR || op_code == MINUS_EXPR) + needed_precision += 1; + else if (op_code == MULT_EXPR) + needed_precision *= 2; + + precision = MAX (needed_precision, TYPE_PRECISION (op_type)); + + /* Unsigned will do for everything but subtraction. */ + if (op_code == MINUS_EXPR) + unsignedp = false; + + /* If our type is the wrong signedness or isn't wide enough, make a new + type and convert both our operands to it. */ + if (TYPE_PRECISION (op_type) < precision + || TYPE_UNSIGNED (op_type) != unsignedp) + { + /* Copy the node so we ensure it can be modified to make it modular. */ + op_type = copy_node (gnat_type_for_size (precision, unsignedp)); + modulus = convert (op_type, modulus); + SET_TYPE_MODULUS (op_type, modulus); + TYPE_MODULAR_P (op_type) = 1; + lhs = convert (op_type, lhs); + rhs = convert (op_type, rhs); + } + + /* Do the operation, then we'll fix it up. */ + result = fold_build2 (op_code, op_type, lhs, rhs); + + /* For multiplication, we have no choice but to do a full modulus + operation. However, we want to do this in the narrowest + possible size. */ + if (op_code == MULT_EXPR) + { + tree div_type = copy_node (gnat_type_for_size (needed_precision, 1)); + modulus = convert (div_type, modulus); + SET_TYPE_MODULUS (div_type, modulus); + TYPE_MODULAR_P (div_type) = 1; + result = convert (op_type, + fold_build2 (TRUNC_MOD_EXPR, div_type, + convert (div_type, result), modulus)); + } + + /* For subtraction, add the modulus back if we are negative. */ + else if (op_code == MINUS_EXPR) + { + result = gnat_protect_expr (result); + result = fold_build3 (COND_EXPR, op_type, + fold_build2 (LT_EXPR, boolean_type_node, result, + convert (op_type, integer_zero_node)), + fold_build2 (PLUS_EXPR, op_type, result, modulus), + result); + } + + /* For the other operations, subtract the modulus if we are >= it. */ + else + { + result = gnat_protect_expr (result); + result = fold_build3 (COND_EXPR, op_type, + fold_build2 (GE_EXPR, boolean_type_node, + result, modulus), + fold_build2 (MINUS_EXPR, op_type, + result, modulus), + result); + } + + return convert (type, result); +} + +/* Make a binary operation of kind OP_CODE. RESULT_TYPE is the type + desired for the result. Usually the operation is to be performed + in that type. For MODIFY_EXPR and ARRAY_REF, RESULT_TYPE may be 0 + in which case the type to be used will be derived from the operands. + + This function is very much unlike the ones for C and C++ since we + have already done any type conversion and matching required. All we + have to do here is validate the work done by SEM and handle subtypes. */ + +tree +build_binary_op (enum tree_code op_code, tree result_type, + tree left_operand, tree right_operand) +{ + tree left_type = TREE_TYPE (left_operand); + tree right_type = TREE_TYPE (right_operand); + tree left_base_type = get_base_type (left_type); + tree right_base_type = get_base_type (right_type); + tree operation_type = result_type; + tree best_type = NULL_TREE; + tree modulus, result; + bool has_side_effects = false; + + if (operation_type + && TREE_CODE (operation_type) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (operation_type)) + operation_type = TREE_TYPE (TYPE_FIELDS (operation_type)); + + if (operation_type + && !AGGREGATE_TYPE_P (operation_type) + && TYPE_EXTRA_SUBTYPE_P (operation_type)) + operation_type = get_base_type (operation_type); + + modulus = (operation_type + && TREE_CODE (operation_type) == INTEGER_TYPE + && TYPE_MODULAR_P (operation_type) + ? TYPE_MODULUS (operation_type) : NULL_TREE); + + switch (op_code) + { + case INIT_EXPR: + case MODIFY_EXPR: + /* If there were integral or pointer conversions on the LHS, remove + them; we'll be putting them back below if needed. Likewise for + conversions between array and record types, except for justified + modular types. But don't do this if the right operand is not + BLKmode (for packed arrays) unless we are not changing the mode. */ + while ((CONVERT_EXPR_P (left_operand) + || TREE_CODE (left_operand) == VIEW_CONVERT_EXPR) + && (((INTEGRAL_TYPE_P (left_type) + || POINTER_TYPE_P (left_type)) + && (INTEGRAL_TYPE_P (TREE_TYPE + (TREE_OPERAND (left_operand, 0))) + || POINTER_TYPE_P (TREE_TYPE + (TREE_OPERAND (left_operand, 0))))) + || (((TREE_CODE (left_type) == RECORD_TYPE + && !TYPE_JUSTIFIED_MODULAR_P (left_type)) + || TREE_CODE (left_type) == ARRAY_TYPE) + && ((TREE_CODE (TREE_TYPE + (TREE_OPERAND (left_operand, 0))) + == RECORD_TYPE) + || (TREE_CODE (TREE_TYPE + (TREE_OPERAND (left_operand, 0))) + == ARRAY_TYPE)) + && (TYPE_MODE (right_type) == BLKmode + || (TYPE_MODE (left_type) + == TYPE_MODE (TREE_TYPE + (TREE_OPERAND + (left_operand, 0)))))))) + { + left_operand = TREE_OPERAND (left_operand, 0); + left_type = TREE_TYPE (left_operand); + } + + /* If a class-wide type may be involved, force use of the RHS type. */ + if ((TREE_CODE (right_type) == RECORD_TYPE + || TREE_CODE (right_type) == UNION_TYPE) + && TYPE_ALIGN_OK (right_type)) + operation_type = right_type; + + /* If we are copying between padded objects with compatible types, use + the padded view of the objects, this is very likely more efficient. + Likewise for a padded object that is assigned a constructor, if we + can convert the constructor to the inner type, to avoid putting a + VIEW_CONVERT_EXPR on the LHS. But don't do so if we wouldn't have + actually copied anything. */ + else if (TYPE_IS_PADDING_P (left_type) + && TREE_CONSTANT (TYPE_SIZE (left_type)) + && ((TREE_CODE (right_operand) == COMPONENT_REF + && TYPE_IS_PADDING_P + (TREE_TYPE (TREE_OPERAND (right_operand, 0))) + && gnat_types_compatible_p + (left_type, + TREE_TYPE (TREE_OPERAND (right_operand, 0)))) + || (TREE_CODE (right_operand) == CONSTRUCTOR + && !CONTAINS_PLACEHOLDER_P + (DECL_SIZE (TYPE_FIELDS (left_type))))) + && !integer_zerop (TYPE_SIZE (right_type))) + operation_type = left_type; + + /* Find the best type to use for copying between aggregate types. */ + else if (((TREE_CODE (left_type) == ARRAY_TYPE + && TREE_CODE (right_type) == ARRAY_TYPE) + || (TREE_CODE (left_type) == RECORD_TYPE + && TREE_CODE (right_type) == RECORD_TYPE)) + && (best_type = find_common_type (left_type, right_type))) + operation_type = best_type; + + /* Otherwise use the LHS type. */ + else if (!operation_type) + operation_type = left_type; + + /* Ensure everything on the LHS is valid. If we have a field reference, + strip anything that get_inner_reference can handle. Then remove any + conversions between types having the same code and mode. And mark + VIEW_CONVERT_EXPRs with TREE_ADDRESSABLE. When done, we must have + either an INDIRECT_REF, a NULL_EXPR or a DECL node. */ + result = left_operand; + while (true) + { + tree restype = TREE_TYPE (result); + + if (TREE_CODE (result) == COMPONENT_REF + || TREE_CODE (result) == ARRAY_REF + || TREE_CODE (result) == ARRAY_RANGE_REF) + while (handled_component_p (result)) + result = TREE_OPERAND (result, 0); + else if (TREE_CODE (result) == REALPART_EXPR + || TREE_CODE (result) == IMAGPART_EXPR + || (CONVERT_EXPR_P (result) + && (((TREE_CODE (restype) + == TREE_CODE (TREE_TYPE + (TREE_OPERAND (result, 0)))) + && (TYPE_MODE (TREE_TYPE + (TREE_OPERAND (result, 0))) + == TYPE_MODE (restype))) + || TYPE_ALIGN_OK (restype)))) + result = TREE_OPERAND (result, 0); + else if (TREE_CODE (result) == VIEW_CONVERT_EXPR) + { + TREE_ADDRESSABLE (result) = 1; + result = TREE_OPERAND (result, 0); + } + else + break; + } + + gcc_assert (TREE_CODE (result) == INDIRECT_REF + || TREE_CODE (result) == NULL_EXPR + || DECL_P (result)); + + /* Convert the right operand to the operation type unless it is + either already of the correct type or if the type involves a + placeholder, since the RHS may not have the same record type. */ + if (operation_type != right_type + && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (operation_type))) + { + right_operand = convert (operation_type, right_operand); + right_type = operation_type; + } + + /* If the left operand is not of the same type as the operation + type, wrap it up in a VIEW_CONVERT_EXPR. */ + if (left_type != operation_type) + left_operand = unchecked_convert (operation_type, left_operand, false); + + has_side_effects = true; + modulus = NULL_TREE; + break; + + case ARRAY_REF: + if (!operation_type) + operation_type = TREE_TYPE (left_type); + + /* ... fall through ... */ + + case ARRAY_RANGE_REF: + /* First look through conversion between type variants. Note that + this changes neither the operation type nor the type domain. */ + if (TREE_CODE (left_operand) == VIEW_CONVERT_EXPR + && TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (left_operand, 0))) + == TYPE_MAIN_VARIANT (left_type)) + { + left_operand = TREE_OPERAND (left_operand, 0); + left_type = TREE_TYPE (left_operand); + } + + /* For a range, make sure the element type is consistent. */ + if (op_code == ARRAY_RANGE_REF + && TREE_TYPE (operation_type) != TREE_TYPE (left_type)) + operation_type = build_array_type (TREE_TYPE (left_type), + TYPE_DOMAIN (operation_type)); + + /* Then convert the right operand to its base type. This will prevent + unneeded sign conversions when sizetype is wider than integer. */ + right_operand = convert (right_base_type, right_operand); + right_operand = convert (sizetype, right_operand); + + if (!TREE_CONSTANT (right_operand) + || !TREE_CONSTANT (TYPE_MIN_VALUE (right_type))) + gnat_mark_addressable (left_operand); + + modulus = NULL_TREE; + break; + + case TRUTH_ANDIF_EXPR: + case TRUTH_ORIF_EXPR: + case TRUTH_AND_EXPR: + case TRUTH_OR_EXPR: + case TRUTH_XOR_EXPR: +#ifdef ENABLE_CHECKING + gcc_assert (TREE_CODE (get_base_type (result_type)) == BOOLEAN_TYPE); +#endif + operation_type = left_base_type; + left_operand = convert (operation_type, left_operand); + right_operand = convert (operation_type, right_operand); + break; + + case GE_EXPR: + case LE_EXPR: + case GT_EXPR: + case LT_EXPR: + case EQ_EXPR: + case NE_EXPR: +#ifdef ENABLE_CHECKING + gcc_assert (TREE_CODE (get_base_type (result_type)) == BOOLEAN_TYPE); +#endif + /* If either operand is a NULL_EXPR, just return a new one. */ + if (TREE_CODE (left_operand) == NULL_EXPR) + return build2 (op_code, result_type, + build1 (NULL_EXPR, integer_type_node, + TREE_OPERAND (left_operand, 0)), + integer_zero_node); + + else if (TREE_CODE (right_operand) == NULL_EXPR) + return build2 (op_code, result_type, + build1 (NULL_EXPR, integer_type_node, + TREE_OPERAND (right_operand, 0)), + integer_zero_node); + + /* If either object is a justified modular types, get the + fields from within. */ + if (TREE_CODE (left_type) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (left_type)) + { + left_operand = convert (TREE_TYPE (TYPE_FIELDS (left_type)), + left_operand); + left_type = TREE_TYPE (left_operand); + left_base_type = get_base_type (left_type); + } + + if (TREE_CODE (right_type) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (right_type)) + { + right_operand = convert (TREE_TYPE (TYPE_FIELDS (right_type)), + right_operand); + right_type = TREE_TYPE (right_operand); + right_base_type = get_base_type (right_type); + } + + /* If both objects are arrays, compare them specially. */ + if ((TREE_CODE (left_type) == ARRAY_TYPE + || (TREE_CODE (left_type) == INTEGER_TYPE + && TYPE_HAS_ACTUAL_BOUNDS_P (left_type))) + && (TREE_CODE (right_type) == ARRAY_TYPE + || (TREE_CODE (right_type) == INTEGER_TYPE + && TYPE_HAS_ACTUAL_BOUNDS_P (right_type)))) + { + result = compare_arrays (input_location, + result_type, left_operand, right_operand); + if (op_code == NE_EXPR) + result = invert_truthvalue_loc (EXPR_LOCATION (result), result); + else + gcc_assert (op_code == EQ_EXPR); + + return result; + } + + /* Otherwise, the base types must be the same, unless they are both fat + pointer types or record types. In the latter case, use the best type + and convert both operands to that type. */ + if (left_base_type != right_base_type) + { + if (TYPE_IS_FAT_POINTER_P (left_base_type) + && TYPE_IS_FAT_POINTER_P (right_base_type)) + { + gcc_assert (TYPE_MAIN_VARIANT (left_base_type) + == TYPE_MAIN_VARIANT (right_base_type)); + best_type = left_base_type; + } + + else if (TREE_CODE (left_base_type) == RECORD_TYPE + && TREE_CODE (right_base_type) == RECORD_TYPE) + { + /* The only way this is permitted is if both types have the same + name. In that case, one of them must not be self-referential. + Use it as the best type. Even better with a fixed size. */ + gcc_assert (TYPE_NAME (left_base_type) + && TYPE_NAME (left_base_type) + == TYPE_NAME (right_base_type)); + + if (TREE_CONSTANT (TYPE_SIZE (left_base_type))) + best_type = left_base_type; + else if (TREE_CONSTANT (TYPE_SIZE (right_base_type))) + best_type = right_base_type; + else if (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (left_base_type))) + best_type = left_base_type; + else if (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (right_base_type))) + best_type = right_base_type; + else + gcc_unreachable (); + } + + else + gcc_unreachable (); + + left_operand = convert (best_type, left_operand); + right_operand = convert (best_type, right_operand); + } + else + { + left_operand = convert (left_base_type, left_operand); + right_operand = convert (right_base_type, right_operand); + } + + /* If we are comparing a fat pointer against zero, we just need to + compare the data pointer. */ + if (TYPE_IS_FAT_POINTER_P (left_base_type) + && TREE_CODE (right_operand) == CONSTRUCTOR + && integer_zerop (VEC_index (constructor_elt, + CONSTRUCTOR_ELTS (right_operand), + 0)->value)) + { + left_operand + = build_component_ref (left_operand, NULL_TREE, + TYPE_FIELDS (left_base_type), false); + right_operand + = convert (TREE_TYPE (left_operand), integer_zero_node); + } + + modulus = NULL_TREE; + break; + + case LSHIFT_EXPR: + case RSHIFT_EXPR: + case LROTATE_EXPR: + case RROTATE_EXPR: + /* The RHS of a shift can be any type. Also, ignore any modulus + (we used to abort, but this is needed for unchecked conversion + to modular types). Otherwise, processing is the same as normal. */ + gcc_assert (operation_type == left_base_type); + modulus = NULL_TREE; + left_operand = convert (operation_type, left_operand); + break; + + case BIT_AND_EXPR: + case BIT_IOR_EXPR: + case BIT_XOR_EXPR: + /* For binary modulus, if the inputs are in range, so are the + outputs. */ + if (modulus && integer_pow2p (modulus)) + modulus = NULL_TREE; + goto common; + + case COMPLEX_EXPR: + gcc_assert (TREE_TYPE (result_type) == left_base_type + && TREE_TYPE (result_type) == right_base_type); + left_operand = convert (left_base_type, left_operand); + right_operand = convert (right_base_type, right_operand); + break; + + case TRUNC_DIV_EXPR: case TRUNC_MOD_EXPR: + case CEIL_DIV_EXPR: case CEIL_MOD_EXPR: + case FLOOR_DIV_EXPR: case FLOOR_MOD_EXPR: + case ROUND_DIV_EXPR: case ROUND_MOD_EXPR: + /* These always produce results lower than either operand. */ + modulus = NULL_TREE; + goto common; + + case POINTER_PLUS_EXPR: + gcc_assert (operation_type == left_base_type + && sizetype == right_base_type); + left_operand = convert (operation_type, left_operand); + right_operand = convert (sizetype, right_operand); + break; + + case PLUS_NOMOD_EXPR: + case MINUS_NOMOD_EXPR: + if (op_code == PLUS_NOMOD_EXPR) + op_code = PLUS_EXPR; + else + op_code = MINUS_EXPR; + modulus = NULL_TREE; + + /* ... fall through ... */ + + case PLUS_EXPR: + case MINUS_EXPR: + /* Avoid doing arithmetics in ENUMERAL_TYPE or BOOLEAN_TYPE like the + other compilers. Contrary to C, Ada doesn't allow arithmetics in + these types but can generate addition/subtraction for Succ/Pred. */ + if (operation_type + && (TREE_CODE (operation_type) == ENUMERAL_TYPE + || TREE_CODE (operation_type) == BOOLEAN_TYPE)) + operation_type = left_base_type = right_base_type + = gnat_type_for_mode (TYPE_MODE (operation_type), + TYPE_UNSIGNED (operation_type)); + + /* ... fall through ... */ + + default: + common: + /* The result type should be the same as the base types of the + both operands (and they should be the same). Convert + everything to the result type. */ + + gcc_assert (operation_type == left_base_type + && left_base_type == right_base_type); + left_operand = convert (operation_type, left_operand); + right_operand = convert (operation_type, right_operand); + } + + if (modulus && !integer_pow2p (modulus)) + { + result = nonbinary_modular_operation (op_code, operation_type, + left_operand, right_operand); + modulus = NULL_TREE; + } + /* If either operand is a NULL_EXPR, just return a new one. */ + else if (TREE_CODE (left_operand) == NULL_EXPR) + return build1 (NULL_EXPR, operation_type, TREE_OPERAND (left_operand, 0)); + else if (TREE_CODE (right_operand) == NULL_EXPR) + return build1 (NULL_EXPR, operation_type, TREE_OPERAND (right_operand, 0)); + else if (op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF) + result = fold (build4 (op_code, operation_type, left_operand, + right_operand, NULL_TREE, NULL_TREE)); + else + result + = fold_build2 (op_code, operation_type, left_operand, right_operand); + + if (TREE_CONSTANT (result)) + ; + else if (op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF) + { + TREE_THIS_NOTRAP (result) = 1; + if (TYPE_VOLATILE (operation_type)) + TREE_THIS_VOLATILE (result) = 1; + } + else + TREE_CONSTANT (result) + |= (TREE_CONSTANT (left_operand) && TREE_CONSTANT (right_operand)); + + TREE_SIDE_EFFECTS (result) |= has_side_effects; + + /* If we are working with modular types, perform the MOD operation + if something above hasn't eliminated the need for it. */ + if (modulus) + result = fold_build2 (FLOOR_MOD_EXPR, operation_type, result, + convert (operation_type, modulus)); + + if (result_type && result_type != operation_type) + result = convert (result_type, result); + + return result; +} + +/* Similar, but for unary operations. */ + +tree +build_unary_op (enum tree_code op_code, tree result_type, tree operand) +{ + tree type = TREE_TYPE (operand); + tree base_type = get_base_type (type); + tree operation_type = result_type; + tree result; + bool side_effects = false; + + if (operation_type + && TREE_CODE (operation_type) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (operation_type)) + operation_type = TREE_TYPE (TYPE_FIELDS (operation_type)); + + if (operation_type + && !AGGREGATE_TYPE_P (operation_type) + && TYPE_EXTRA_SUBTYPE_P (operation_type)) + operation_type = get_base_type (operation_type); + + switch (op_code) + { + case REALPART_EXPR: + case IMAGPART_EXPR: + if (!operation_type) + result_type = operation_type = TREE_TYPE (type); + else + gcc_assert (result_type == TREE_TYPE (type)); + + result = fold_build1 (op_code, operation_type, operand); + break; + + case TRUTH_NOT_EXPR: +#ifdef ENABLE_CHECKING + gcc_assert (TREE_CODE (get_base_type (result_type)) == BOOLEAN_TYPE); +#endif + result = invert_truthvalue_loc (EXPR_LOCATION (operand), operand); + /* When not optimizing, fold the result as invert_truthvalue_loc + doesn't fold the result of comparisons. This is intended to undo + the trick used for boolean rvalues in gnat_to_gnu. */ + if (!optimize) + result = fold (result); + break; + + case ATTR_ADDR_EXPR: + case ADDR_EXPR: + switch (TREE_CODE (operand)) + { + case INDIRECT_REF: + case UNCONSTRAINED_ARRAY_REF: + result = TREE_OPERAND (operand, 0); + + /* Make sure the type here is a pointer, not a reference. + GCC wants pointer types for function addresses. */ + if (!result_type) + result_type = build_pointer_type (type); + + /* If the underlying object can alias everything, propagate the + property since we are effectively retrieving the object. */ + if (POINTER_TYPE_P (TREE_TYPE (result)) + && TYPE_REF_CAN_ALIAS_ALL (TREE_TYPE (result))) + { + if (TREE_CODE (result_type) == POINTER_TYPE + && !TYPE_REF_CAN_ALIAS_ALL (result_type)) + result_type + = build_pointer_type_for_mode (TREE_TYPE (result_type), + TYPE_MODE (result_type), + true); + else if (TREE_CODE (result_type) == REFERENCE_TYPE + && !TYPE_REF_CAN_ALIAS_ALL (result_type)) + result_type + = build_reference_type_for_mode (TREE_TYPE (result_type), + TYPE_MODE (result_type), + true); + } + break; + + case NULL_EXPR: + result = operand; + TREE_TYPE (result) = type = build_pointer_type (type); + break; + + case COMPOUND_EXPR: + /* Fold a compound expression if it has unconstrained array type + since the middle-end cannot handle it. But we don't it in the + general case because it may introduce aliasing issues if the + first operand is an indirect assignment and the second operand + the corresponding address, e.g. for an allocator. */ + if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) + { + result = build_unary_op (ADDR_EXPR, result_type, + TREE_OPERAND (operand, 1)); + result = build2 (COMPOUND_EXPR, TREE_TYPE (result), + TREE_OPERAND (operand, 0), result); + break; + } + goto common; + + case ARRAY_REF: + case ARRAY_RANGE_REF: + case COMPONENT_REF: + case BIT_FIELD_REF: + /* If this is for 'Address, find the address of the prefix and add + the offset to the field. Otherwise, do this the normal way. */ + if (op_code == ATTR_ADDR_EXPR) + { + HOST_WIDE_INT bitsize; + HOST_WIDE_INT bitpos; + tree offset, inner; + enum machine_mode mode; + int unsignedp, volatilep; + + inner = get_inner_reference (operand, &bitsize, &bitpos, &offset, + &mode, &unsignedp, &volatilep, + false); + + /* If INNER is a padding type whose field has a self-referential + size, convert to that inner type. We know the offset is zero + and we need to have that type visible. */ + if (TYPE_IS_PADDING_P (TREE_TYPE (inner)) + && CONTAINS_PLACEHOLDER_P + (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS + (TREE_TYPE (inner)))))) + inner = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (inner))), + inner); + + /* Compute the offset as a byte offset from INNER. */ + if (!offset) + offset = size_zero_node; + + offset = size_binop (PLUS_EXPR, offset, + size_int (bitpos / BITS_PER_UNIT)); + + /* Take the address of INNER, convert the offset to void *, and + add then. It will later be converted to the desired result + type, if any. */ + inner = build_unary_op (ADDR_EXPR, NULL_TREE, inner); + inner = convert (ptr_void_type_node, inner); + result = build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node, + inner, offset); + result = convert (build_pointer_type (TREE_TYPE (operand)), + result); + break; + } + goto common; + + case CONSTRUCTOR: + /* If this is just a constructor for a padded record, we can + just take the address of the single field and convert it to + a pointer to our type. */ + if (TYPE_IS_PADDING_P (type)) + { + result = VEC_index (constructor_elt, + CONSTRUCTOR_ELTS (operand), + 0)->value; + result = convert (build_pointer_type (TREE_TYPE (operand)), + build_unary_op (ADDR_EXPR, NULL_TREE, result)); + break; + } + + goto common; + + case NOP_EXPR: + if (AGGREGATE_TYPE_P (type) + && AGGREGATE_TYPE_P (TREE_TYPE (TREE_OPERAND (operand, 0)))) + return build_unary_op (ADDR_EXPR, result_type, + TREE_OPERAND (operand, 0)); + + /* ... fallthru ... */ + + case VIEW_CONVERT_EXPR: + /* If this just a variant conversion or if the conversion doesn't + change the mode, get the result type from this type and go down. + This is needed for conversions of CONST_DECLs, to eventually get + to the address of their CORRESPONDING_VARs. */ + if ((TYPE_MAIN_VARIANT (type) + == TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (operand, 0)))) + || (TYPE_MODE (type) != BLKmode + && (TYPE_MODE (type) + == TYPE_MODE (TREE_TYPE (TREE_OPERAND (operand, 0)))))) + return build_unary_op (ADDR_EXPR, + (result_type ? result_type + : build_pointer_type (type)), + TREE_OPERAND (operand, 0)); + goto common; + + case CONST_DECL: + operand = DECL_CONST_CORRESPONDING_VAR (operand); + + /* ... fall through ... */ + + default: + common: + + /* If we are taking the address of a padded record whose field is + contains a template, take the address of the template. */ + if (TYPE_IS_PADDING_P (type) + && TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (TYPE_FIELDS (type)))) + { + type = TREE_TYPE (TYPE_FIELDS (type)); + operand = convert (type, operand); + } + + gnat_mark_addressable (operand); + result = build_fold_addr_expr (operand); + } + + TREE_CONSTANT (result) = staticp (operand) || TREE_CONSTANT (operand); + break; + + case INDIRECT_REF: + /* If we want to refer to an unconstrained array, use the appropriate + expression to do so. This will never survive down to the back-end. + But if TYPE is a thin pointer, first convert to a fat pointer. */ + if (TYPE_IS_THIN_POINTER_P (type) + && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))) + { + operand + = convert (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))), + operand); + type = TREE_TYPE (operand); + } + + if (TYPE_IS_FAT_POINTER_P (type)) + { + result = build1 (UNCONSTRAINED_ARRAY_REF, + TYPE_UNCONSTRAINED_ARRAY (type), operand); + TREE_READONLY (result) + = TYPE_READONLY (TYPE_UNCONSTRAINED_ARRAY (type)); + } + + /* If we are dereferencing an ADDR_EXPR, return its operand. */ + else if (TREE_CODE (operand) == ADDR_EXPR) + result = TREE_OPERAND (operand, 0); + + /* Otherwise, build and fold the indirect reference. */ + else + { + result = build_fold_indirect_ref (operand); + TREE_READONLY (result) = TYPE_READONLY (TREE_TYPE (type)); + } + + side_effects + = (!TYPE_IS_FAT_POINTER_P (type) && TYPE_VOLATILE (TREE_TYPE (type))); + break; + + case NEGATE_EXPR: + case BIT_NOT_EXPR: + { + tree modulus = ((operation_type + && TREE_CODE (operation_type) == INTEGER_TYPE + && TYPE_MODULAR_P (operation_type)) + ? TYPE_MODULUS (operation_type) : NULL_TREE); + int mod_pow2 = modulus && integer_pow2p (modulus); + + /* If this is a modular type, there are various possibilities + depending on the operation and whether the modulus is a + power of two or not. */ + + if (modulus) + { + gcc_assert (operation_type == base_type); + operand = convert (operation_type, operand); + + /* The fastest in the negate case for binary modulus is + the straightforward code; the TRUNC_MOD_EXPR below + is an AND operation. */ + if (op_code == NEGATE_EXPR && mod_pow2) + result = fold_build2 (TRUNC_MOD_EXPR, operation_type, + fold_build1 (NEGATE_EXPR, operation_type, + operand), + modulus); + + /* For nonbinary negate case, return zero for zero operand, + else return the modulus minus the operand. If the modulus + is a power of two minus one, we can do the subtraction + as an XOR since it is equivalent and faster on most machines. */ + else if (op_code == NEGATE_EXPR && !mod_pow2) + { + if (integer_pow2p (fold_build2 (PLUS_EXPR, operation_type, + modulus, + convert (operation_type, + integer_one_node)))) + result = fold_build2 (BIT_XOR_EXPR, operation_type, + operand, modulus); + else + result = fold_build2 (MINUS_EXPR, operation_type, + modulus, operand); + + result = fold_build3 (COND_EXPR, operation_type, + fold_build2 (NE_EXPR, + boolean_type_node, + operand, + convert + (operation_type, + integer_zero_node)), + result, operand); + } + else + { + /* For the NOT cases, we need a constant equal to + the modulus minus one. For a binary modulus, we + XOR against the constant and subtract the operand from + that constant for nonbinary modulus. */ + + tree cnst = fold_build2 (MINUS_EXPR, operation_type, modulus, + convert (operation_type, + integer_one_node)); + + if (mod_pow2) + result = fold_build2 (BIT_XOR_EXPR, operation_type, + operand, cnst); + else + result = fold_build2 (MINUS_EXPR, operation_type, + cnst, operand); + } + + break; + } + } + + /* ... fall through ... */ + + default: + gcc_assert (operation_type == base_type); + result = fold_build1 (op_code, operation_type, + convert (operation_type, operand)); + } + + if (side_effects) + { + TREE_SIDE_EFFECTS (result) = 1; + if (TREE_CODE (result) == INDIRECT_REF) + TREE_THIS_VOLATILE (result) = TYPE_VOLATILE (TREE_TYPE (result)); + } + + if (result_type && TREE_TYPE (result) != result_type) + result = convert (result_type, result); + + return result; +} + +/* Similar, but for COND_EXPR. */ + +tree +build_cond_expr (tree result_type, tree condition_operand, + tree true_operand, tree false_operand) +{ + bool addr_p = false; + tree result; + + /* The front-end verified that result, true and false operands have + same base type. Convert everything to the result type. */ + true_operand = convert (result_type, true_operand); + false_operand = convert (result_type, false_operand); + + /* If the result type is unconstrained, take the address of the operands and + then dereference the result. Likewise if the result type is passed by + reference, but this is natively handled in the gimplifier. */ + if (TREE_CODE (result_type) == UNCONSTRAINED_ARRAY_TYPE + || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (result_type))) + { + result_type = build_pointer_type (result_type); + true_operand = build_unary_op (ADDR_EXPR, result_type, true_operand); + false_operand = build_unary_op (ADDR_EXPR, result_type, false_operand); + addr_p = true; + } + + result = fold_build3 (COND_EXPR, result_type, condition_operand, + true_operand, false_operand); + + /* If we have a common SAVE_EXPR (possibly surrounded by arithmetics) + in both arms, make sure it gets evaluated by moving it ahead of the + conditional expression. This is necessary because it is evaluated + in only one place at run time and would otherwise be uninitialized + in one of the arms. */ + true_operand = skip_simple_arithmetic (true_operand); + false_operand = skip_simple_arithmetic (false_operand); + + if (true_operand == false_operand && TREE_CODE (true_operand) == SAVE_EXPR) + result = build2 (COMPOUND_EXPR, result_type, true_operand, result); + + if (addr_p) + result = build_unary_op (INDIRECT_REF, NULL_TREE, result); + + return result; +} + +/* Similar, but for COMPOUND_EXPR. */ + +tree +build_compound_expr (tree result_type, tree stmt_operand, tree expr_operand) +{ + bool addr_p = false; + tree result; + + /* If the result type is unconstrained, take the address of the operand and + then dereference the result. Likewise if the result type is passed by + reference, but this is natively handled in the gimplifier. */ + if (TREE_CODE (result_type) == UNCONSTRAINED_ARRAY_TYPE + || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (result_type))) + { + result_type = build_pointer_type (result_type); + expr_operand = build_unary_op (ADDR_EXPR, result_type, expr_operand); + addr_p = true; + } + + result = fold_build2 (COMPOUND_EXPR, result_type, stmt_operand, + expr_operand); + + if (addr_p) + result = build_unary_op (INDIRECT_REF, NULL_TREE, result); + + return result; +} +/* Similar, but for RETURN_EXPR. If RET_VAL is non-null, build a RETURN_EXPR + around the assignment of RET_VAL to RET_OBJ. Otherwise just build a bare + RETURN_EXPR around RESULT_OBJ, which may be null in this case. */ + +tree +build_return_expr (tree ret_obj, tree ret_val) +{ + tree result_expr; + + if (ret_val) + { + /* The gimplifier explicitly enforces the following invariant: + + RETURN_EXPR + | + MODIFY_EXPR + / \ + / \ + RET_OBJ ... + + As a consequence, type consistency dictates that we use the type + of the RET_OBJ as the operation type. */ + tree operation_type = TREE_TYPE (ret_obj); + + /* Convert the right operand to the operation type. Note that it's the + same transformation as in the MODIFY_EXPR case of build_binary_op, + with the assumption that the type cannot involve a placeholder. */ + if (operation_type != TREE_TYPE (ret_val)) + ret_val = convert (operation_type, ret_val); + + result_expr = build2 (MODIFY_EXPR, operation_type, ret_obj, ret_val); + } + else + result_expr = ret_obj; + + return build1 (RETURN_EXPR, void_type_node, result_expr); +} + +/* Build a CALL_EXPR to call FUNDECL with one argument, ARG. Return + the CALL_EXPR. */ + +tree +build_call_1_expr (tree fundecl, tree arg) +{ + tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)), + build_unary_op (ADDR_EXPR, NULL_TREE, fundecl), + 1, arg); + TREE_SIDE_EFFECTS (call) = 1; + return call; +} + +/* Build a CALL_EXPR to call FUNDECL with two arguments, ARG1 & ARG2. Return + the CALL_EXPR. */ + +tree +build_call_2_expr (tree fundecl, tree arg1, tree arg2) +{ + tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)), + build_unary_op (ADDR_EXPR, NULL_TREE, fundecl), + 2, arg1, arg2); + TREE_SIDE_EFFECTS (call) = 1; + return call; +} + +/* Likewise to call FUNDECL with no arguments. */ + +tree +build_call_0_expr (tree fundecl) +{ + /* We rely on build_call_nary to compute TREE_SIDE_EFFECTS. This makes + it possible to propagate DECL_IS_PURE on parameterless functions. */ + tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)), + build_unary_op (ADDR_EXPR, NULL_TREE, fundecl), + 0); + return call; +} + +/* Call a function that raises an exception and pass the line number and file + name, if requested. MSG says which exception function to call. + + GNAT_NODE is the gnat node conveying the source location for which the + error should be signaled, or Empty in which case the error is signaled on + the current ref_file_name/input_line. + + KIND says which kind of exception this is for + (N_Raise_{Constraint,Storage,Program}_Error). */ + +tree +build_call_raise (int msg, Node_Id gnat_node, char kind) +{ + tree fndecl = gnat_raise_decls[msg]; + tree label = get_exception_label (kind); + tree filename; + int line_number; + const char *str; + int len; + + /* If this is to be done as a goto, handle that case. */ + if (label) + { + Entity_Id local_raise = Get_Local_Raise_Call_Entity (); + tree gnu_result = build1 (GOTO_EXPR, void_type_node, label); + + /* If Local_Raise is present, generate + Local_Raise (exception'Identity); */ + if (Present (local_raise)) + { + tree gnu_local_raise + = gnat_to_gnu_entity (local_raise, NULL_TREE, 0); + tree gnu_exception_entity + = gnat_to_gnu_entity (Get_RT_Exception_Entity (msg), NULL_TREE, 0); + tree gnu_call + = build_call_1_expr (gnu_local_raise, + build_unary_op (ADDR_EXPR, NULL_TREE, + gnu_exception_entity)); + + gnu_result = build2 (COMPOUND_EXPR, void_type_node, + gnu_call, gnu_result);} + + return gnu_result; + } + + str + = (Debug_Flag_NN || Exception_Locations_Suppressed) + ? "" + : (gnat_node != Empty && Sloc (gnat_node) != No_Location) + ? IDENTIFIER_POINTER + (get_identifier (Get_Name_String + (Debug_Source_Name + (Get_Source_File_Index (Sloc (gnat_node)))))) + : ref_filename; + + len = strlen (str); + filename = build_string (len, str); + line_number + = (gnat_node != Empty && Sloc (gnat_node) != No_Location) + ? Get_Logical_Line_Number (Sloc(gnat_node)) : input_line; + + TREE_TYPE (filename) = build_array_type (unsigned_char_type_node, + build_index_type (size_int (len))); + + return + build_call_2_expr (fndecl, + build1 (ADDR_EXPR, + build_pointer_type (unsigned_char_type_node), + filename), + build_int_cst (NULL_TREE, line_number)); +} + +/* Similar to build_call_raise, for an index or range check exception as + determined by MSG, with extra information generated of the form + "INDEX out of range FIRST..LAST". */ + +tree +build_call_raise_range (int msg, Node_Id gnat_node, + tree index, tree first, tree last) +{ + tree call; + tree fndecl = gnat_raise_decls_ext[msg]; + tree filename; + int line_number, column_number; + const char *str; + int len; + + str + = (Debug_Flag_NN || Exception_Locations_Suppressed) + ? "" + : (gnat_node != Empty && Sloc (gnat_node) != No_Location) + ? IDENTIFIER_POINTER + (get_identifier (Get_Name_String + (Debug_Source_Name + (Get_Source_File_Index (Sloc (gnat_node)))))) + : ref_filename; + + len = strlen (str); + filename = build_string (len, str); + if (gnat_node != Empty && Sloc (gnat_node) != No_Location) + { + line_number = Get_Logical_Line_Number (Sloc (gnat_node)); + column_number = Get_Column_Number (Sloc (gnat_node)); + } + else + { + line_number = input_line; + column_number = 0; + } + + TREE_TYPE (filename) = build_array_type (unsigned_char_type_node, + build_index_type (size_int (len))); + + call = build_call_nary (TREE_TYPE (TREE_TYPE (fndecl)), + build_unary_op (ADDR_EXPR, NULL_TREE, fndecl), + 6, + build1 (ADDR_EXPR, + build_pointer_type (unsigned_char_type_node), + filename), + build_int_cst (NULL_TREE, line_number), + build_int_cst (NULL_TREE, column_number), + convert (integer_type_node, index), + convert (integer_type_node, first), + convert (integer_type_node, last)); + TREE_SIDE_EFFECTS (call) = 1; + return call; +} + +/* Similar to build_call_raise, with extra information about the column + where the check failed. */ + +tree +build_call_raise_column (int msg, Node_Id gnat_node) +{ + tree fndecl = gnat_raise_decls_ext[msg]; + tree call; + tree filename; + int line_number, column_number; + const char *str; + int len; + + str + = (Debug_Flag_NN || Exception_Locations_Suppressed) + ? "" + : (gnat_node != Empty && Sloc (gnat_node) != No_Location) + ? IDENTIFIER_POINTER + (get_identifier (Get_Name_String + (Debug_Source_Name + (Get_Source_File_Index (Sloc (gnat_node)))))) + : ref_filename; + + len = strlen (str); + filename = build_string (len, str); + if (gnat_node != Empty && Sloc (gnat_node) != No_Location) + { + line_number = Get_Logical_Line_Number (Sloc (gnat_node)); + column_number = Get_Column_Number (Sloc (gnat_node)); + } + else + { + line_number = input_line; + column_number = 0; + } + + TREE_TYPE (filename) = build_array_type (unsigned_char_type_node, + build_index_type (size_int (len))); + + call = build_call_nary (TREE_TYPE (TREE_TYPE (fndecl)), + build_unary_op (ADDR_EXPR, NULL_TREE, fndecl), + 3, + build1 (ADDR_EXPR, + build_pointer_type (unsigned_char_type_node), + filename), + build_int_cst (NULL_TREE, line_number), + build_int_cst (NULL_TREE, column_number)); + TREE_SIDE_EFFECTS (call) = 1; + return call; +} + +/* qsort comparer for the bit positions of two constructor elements + for record components. */ + +static int +compare_elmt_bitpos (const PTR rt1, const PTR rt2) +{ + const constructor_elt * const elmt1 = (const constructor_elt * const) rt1; + const constructor_elt * const elmt2 = (const constructor_elt * const) rt2; + const_tree const field1 = elmt1->index; + const_tree const field2 = elmt2->index; + const int ret + = tree_int_cst_compare (bit_position (field1), bit_position (field2)); + + return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2)); +} + +/* Return a CONSTRUCTOR of TYPE whose elements are V. */ + +tree +gnat_build_constructor (tree type, VEC(constructor_elt,gc) *v) +{ + bool allconstant = (TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST); + bool side_effects = false; + tree result, obj, val; + unsigned int n_elmts; + + /* Scan the elements to see if they are all constant or if any has side + effects, to let us set global flags on the resulting constructor. Count + the elements along the way for possible sorting purposes below. */ + FOR_EACH_CONSTRUCTOR_ELT (v, n_elmts, obj, val) + { + /* The predicate must be in keeping with output_constructor. */ + if (!TREE_CONSTANT (val) + || (TREE_CODE (type) == RECORD_TYPE + && CONSTRUCTOR_BITFIELD_P (obj) + && !initializer_constant_valid_for_bitfield_p (val)) + || !initializer_constant_valid_p (val, TREE_TYPE (val))) + allconstant = false; + + if (TREE_SIDE_EFFECTS (val)) + side_effects = true; + } + + /* For record types with constant components only, sort field list + by increasing bit position. This is necessary to ensure the + constructor can be output as static data. */ + if (allconstant && TREE_CODE (type) == RECORD_TYPE && n_elmts > 1) + VEC_qsort (constructor_elt, v, compare_elmt_bitpos); + + result = build_constructor (type, v); + TREE_CONSTANT (result) = TREE_STATIC (result) = allconstant; + TREE_SIDE_EFFECTS (result) = side_effects; + TREE_READONLY (result) = TYPE_READONLY (type) || allconstant; + return result; +} + +/* Return a COMPONENT_REF to access a field that is given by COMPONENT, + an IDENTIFIER_NODE giving the name of the field, or FIELD, a FIELD_DECL, + for the field. Don't fold the result if NO_FOLD_P is true. + + We also handle the fact that we might have been passed a pointer to the + actual record and know how to look for fields in variant parts. */ + +static tree +build_simple_component_ref (tree record_variable, tree component, + tree field, bool no_fold_p) +{ + tree record_type = TYPE_MAIN_VARIANT (TREE_TYPE (record_variable)); + tree ref, inner_variable; + + gcc_assert ((TREE_CODE (record_type) == RECORD_TYPE + || TREE_CODE (record_type) == UNION_TYPE + || TREE_CODE (record_type) == QUAL_UNION_TYPE) + && TYPE_SIZE (record_type) + && (component != 0) != (field != 0)); + + /* If no field was specified, look for a field with the specified name + in the current record only. */ + if (!field) + for (field = TYPE_FIELDS (record_type); field; + field = TREE_CHAIN (field)) + if (DECL_NAME (field) == component) + break; + + if (!field) + return NULL_TREE; + + /* If this field is not in the specified record, see if we can find a field + in the specified record whose original field is the same as this one. */ + if (DECL_CONTEXT (field) != record_type) + { + tree new_field; + + /* First loop thru normal components. */ + for (new_field = TYPE_FIELDS (record_type); new_field; + new_field = DECL_CHAIN (new_field)) + if (SAME_FIELD_P (field, new_field)) + break; + + /* Next, see if we're looking for an inherited component in an extension. + If so, look thru the extension directly. */ + if (!new_field + && TREE_CODE (record_variable) == VIEW_CONVERT_EXPR + && TYPE_ALIGN_OK (record_type) + && TREE_CODE (TREE_TYPE (TREE_OPERAND (record_variable, 0))) + == RECORD_TYPE + && TYPE_ALIGN_OK (TREE_TYPE (TREE_OPERAND (record_variable, 0)))) + { + ref = build_simple_component_ref (TREE_OPERAND (record_variable, 0), + NULL_TREE, field, no_fold_p); + if (ref) + return ref; + } + + /* Next, loop thru DECL_INTERNAL_P components if we haven't found + the component in the first search. Doing this search in 2 steps + is required to avoiding hidden homonymous fields in the + _Parent field. */ + if (!new_field) + for (new_field = TYPE_FIELDS (record_type); new_field; + new_field = DECL_CHAIN (new_field)) + if (DECL_INTERNAL_P (new_field)) + { + tree field_ref + = build_simple_component_ref (record_variable, + NULL_TREE, new_field, no_fold_p); + ref = build_simple_component_ref (field_ref, NULL_TREE, field, + no_fold_p); + + if (ref) + return ref; + } + + field = new_field; + } + + if (!field) + return NULL_TREE; + + /* If the field's offset has overflowed, do not attempt to access it + as doing so may trigger sanity checks deeper in the back-end. + Note that we don't need to warn since this will be done on trying + to declare the object. */ + if (TREE_CODE (DECL_FIELD_OFFSET (field)) == INTEGER_CST + && TREE_OVERFLOW (DECL_FIELD_OFFSET (field))) + return NULL_TREE; + + /* Look through conversion between type variants. Note that this + is transparent as far as the field is concerned. */ + if (TREE_CODE (record_variable) == VIEW_CONVERT_EXPR + && TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (record_variable, 0))) + == record_type) + inner_variable = TREE_OPERAND (record_variable, 0); + else + inner_variable = record_variable; + + ref = build3 (COMPONENT_REF, TREE_TYPE (field), inner_variable, field, + NULL_TREE); + + if (TREE_READONLY (record_variable) || TREE_READONLY (field)) + TREE_READONLY (ref) = 1; + if (TREE_THIS_VOLATILE (record_variable) || TREE_THIS_VOLATILE (field) + || TYPE_VOLATILE (record_type)) + TREE_THIS_VOLATILE (ref) = 1; + + if (no_fold_p) + return ref; + + /* The generic folder may punt in this case because the inner array type + can be self-referential, but folding is in fact not problematic. */ + else if (TREE_CODE (record_variable) == CONSTRUCTOR + && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (record_variable))) + { + VEC(constructor_elt,gc) *elts = CONSTRUCTOR_ELTS (record_variable); + unsigned HOST_WIDE_INT idx; + tree index, value; + FOR_EACH_CONSTRUCTOR_ELT (elts, idx, index, value) + if (index == field) + return value; + return ref; + } + + else + return fold (ref); +} + +/* Like build_simple_component_ref, except that we give an error if the + reference could not be found. */ + +tree +build_component_ref (tree record_variable, tree component, + tree field, bool no_fold_p) +{ + tree ref = build_simple_component_ref (record_variable, component, field, + no_fold_p); + + if (ref) + return ref; + + /* If FIELD was specified, assume this is an invalid user field so raise + Constraint_Error. Otherwise, we have no type to return so abort. */ + gcc_assert (field); + return build1 (NULL_EXPR, TREE_TYPE (field), + build_call_raise (CE_Discriminant_Check_Failed, Empty, + N_Raise_Constraint_Error)); +} + +/* Helper for build_call_alloc_dealloc, with arguments to be interpreted + identically. Process the case where a GNAT_PROC to call is provided. */ + +static inline tree +build_call_alloc_dealloc_proc (tree gnu_obj, tree gnu_size, tree gnu_type, + Entity_Id gnat_proc, Entity_Id gnat_pool) +{ + tree gnu_proc = gnat_to_gnu (gnat_proc); + tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc); + tree gnu_call; + + /* The storage pools are obviously always tagged types, but the + secondary stack uses the same mechanism and is not tagged. */ + if (Is_Tagged_Type (Etype (gnat_pool))) + { + /* The size is the third parameter; the alignment is the + same type. */ + Entity_Id gnat_size_type + = Etype (Next_Formal (Next_Formal (First_Formal (gnat_proc)))); + tree gnu_size_type = gnat_to_gnu_type (gnat_size_type); + + tree gnu_pool = gnat_to_gnu (gnat_pool); + tree gnu_pool_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_pool); + tree gnu_align = size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT); + + gnu_size = convert (gnu_size_type, gnu_size); + gnu_align = convert (gnu_size_type, gnu_align); + + /* The first arg is always the address of the storage pool; next + comes the address of the object, for a deallocator, then the + size and alignment. */ + if (gnu_obj) + gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)), + gnu_proc_addr, 4, gnu_pool_addr, + gnu_obj, gnu_size, gnu_align); + else + gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)), + gnu_proc_addr, 3, gnu_pool_addr, + gnu_size, gnu_align); + } + + /* Secondary stack case. */ + else + { + /* The size is the second parameter. */ + Entity_Id gnat_size_type + = Etype (Next_Formal (First_Formal (gnat_proc))); + tree gnu_size_type = gnat_to_gnu_type (gnat_size_type); + + gnu_size = convert (gnu_size_type, gnu_size); + + /* The first arg is the address of the object, for a deallocator, + then the size. */ + if (gnu_obj) + gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)), + gnu_proc_addr, 2, gnu_obj, gnu_size); + else + gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)), + gnu_proc_addr, 1, gnu_size); + } + + TREE_SIDE_EFFECTS (gnu_call) = 1; + return gnu_call; +} + +/* Helper for build_call_alloc_dealloc, to build and return an allocator for + DATA_SIZE bytes aimed at containing a DATA_TYPE object, using the default + __gnat_malloc allocator. Honor DATA_TYPE alignments greater than what the + latter offers. */ + +static inline tree +maybe_wrap_malloc (tree data_size, tree data_type, Node_Id gnat_node) +{ + /* When the DATA_TYPE alignment is stricter than what malloc offers + (super-aligned case), we allocate an "aligning" wrapper type and return + the address of its single data field with the malloc's return value + stored just in front. */ + + unsigned int data_align = TYPE_ALIGN (data_type); + unsigned int default_allocator_alignment + = get_target_default_allocator_alignment () * BITS_PER_UNIT; + + tree aligning_type + = ((data_align > default_allocator_alignment) + ? make_aligning_type (data_type, data_align, data_size, + default_allocator_alignment, + POINTER_SIZE / BITS_PER_UNIT) + : NULL_TREE); + + tree size_to_malloc + = aligning_type ? TYPE_SIZE_UNIT (aligning_type) : data_size; + + tree malloc_ptr; + + /* On VMS, if pointers are 64-bit and the allocator size is 32-bit or + Convention C, allocate 32-bit memory. */ + if (TARGET_ABI_OPEN_VMS + && POINTER_SIZE == 64 + && Nkind (gnat_node) == N_Allocator + && (UI_To_Int (Esize (Etype (gnat_node))) == 32 + || Convention (Etype (gnat_node)) == Convention_C)) + malloc_ptr = build_call_1_expr (malloc32_decl, size_to_malloc); + else + malloc_ptr = build_call_1_expr (malloc_decl, size_to_malloc); + + if (aligning_type) + { + /* Latch malloc's return value and get a pointer to the aligning field + first. */ + tree storage_ptr = gnat_protect_expr (malloc_ptr); + + tree aligning_record_addr + = convert (build_pointer_type (aligning_type), storage_ptr); + + tree aligning_record + = build_unary_op (INDIRECT_REF, NULL_TREE, aligning_record_addr); + + tree aligning_field + = build_component_ref (aligning_record, NULL_TREE, + TYPE_FIELDS (aligning_type), false); + + tree aligning_field_addr + = build_unary_op (ADDR_EXPR, NULL_TREE, aligning_field); + + /* Then arrange to store the allocator's return value ahead + and return. */ + tree storage_ptr_slot_addr + = build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node, + convert (ptr_void_type_node, aligning_field_addr), + size_int (-(HOST_WIDE_INT) POINTER_SIZE + / BITS_PER_UNIT)); + + tree storage_ptr_slot + = build_unary_op (INDIRECT_REF, NULL_TREE, + convert (build_pointer_type (ptr_void_type_node), + storage_ptr_slot_addr)); + + return + build2 (COMPOUND_EXPR, TREE_TYPE (aligning_field_addr), + build_binary_op (MODIFY_EXPR, NULL_TREE, + storage_ptr_slot, storage_ptr), + aligning_field_addr); + } + else + return malloc_ptr; +} + +/* Helper for build_call_alloc_dealloc, to release a DATA_TYPE object + designated by DATA_PTR using the __gnat_free entry point. */ + +static inline tree +maybe_wrap_free (tree data_ptr, tree data_type) +{ + /* In the regular alignment case, we pass the data pointer straight to free. + In the superaligned case, we need to retrieve the initial allocator + return value, stored in front of the data block at allocation time. */ + + unsigned int data_align = TYPE_ALIGN (data_type); + unsigned int default_allocator_alignment + = get_target_default_allocator_alignment () * BITS_PER_UNIT; + + tree free_ptr; + + if (data_align > default_allocator_alignment) + { + /* DATA_FRONT_PTR (void *) + = (void *)DATA_PTR - (void *)sizeof (void *)) */ + tree data_front_ptr + = build_binary_op + (POINTER_PLUS_EXPR, ptr_void_type_node, + convert (ptr_void_type_node, data_ptr), + size_int (-(HOST_WIDE_INT) POINTER_SIZE / BITS_PER_UNIT)); + + /* FREE_PTR (void *) = *(void **)DATA_FRONT_PTR */ + free_ptr + = build_unary_op + (INDIRECT_REF, NULL_TREE, + convert (build_pointer_type (ptr_void_type_node), data_front_ptr)); + } + else + free_ptr = data_ptr; + + return build_call_1_expr (free_decl, free_ptr); +} + +/* Build a GCC tree to call an allocation or deallocation function. + If GNU_OBJ is nonzero, it is an object to deallocate. Otherwise, + generate an allocator. + + GNU_SIZE is the number of bytes to allocate and GNU_TYPE is the contained + object type, used to determine the to-be-honored address alignment. + GNAT_PROC, if present, is a procedure to call and GNAT_POOL is the storage + pool to use. If not present, malloc and free are used. GNAT_NODE is used + to provide an error location for restriction violation messages. */ + +tree +build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, tree gnu_type, + Entity_Id gnat_proc, Entity_Id gnat_pool, + Node_Id gnat_node) +{ + gnu_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size, gnu_obj); + + /* Explicit proc to call ? This one is assumed to deal with the type + alignment constraints. */ + if (Present (gnat_proc)) + return build_call_alloc_dealloc_proc (gnu_obj, gnu_size, gnu_type, + gnat_proc, gnat_pool); + + /* Otherwise, object to "free" or "malloc" with possible special processing + for alignments stricter than what the default allocator honors. */ + else if (gnu_obj) + return maybe_wrap_free (gnu_obj, gnu_type); + else + { + /* Assert that we no longer can be called with this special pool. */ + gcc_assert (gnat_pool != -1); + + /* Check that we aren't violating the associated restriction. */ + if (!(Nkind (gnat_node) == N_Allocator && Comes_From_Source (gnat_node))) + Check_No_Implicit_Heap_Alloc (gnat_node); + + return maybe_wrap_malloc (gnu_size, gnu_type, gnat_node); + } +} + +/* Build a GCC tree to correspond to allocating an object of TYPE whose + initial value is INIT, if INIT is nonzero. Convert the expression to + RESULT_TYPE, which must be some type of pointer. Return the tree. + + GNAT_PROC and GNAT_POOL optionally give the procedure to call and + the storage pool to use. GNAT_NODE is used to provide an error + location for restriction violation messages. If IGNORE_INIT_TYPE is + true, ignore the type of INIT for the purpose of determining the size; + this will cause the maximum size to be allocated if TYPE is of + self-referential size. */ + +tree +build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc, + Entity_Id gnat_pool, Node_Id gnat_node, bool ignore_init_type) +{ + tree size = TYPE_SIZE_UNIT (type); + tree result; + + /* If the initializer, if present, is a NULL_EXPR, just return a new one. */ + if (init && TREE_CODE (init) == NULL_EXPR) + return build1 (NULL_EXPR, result_type, TREE_OPERAND (init, 0)); + + /* If RESULT_TYPE is a fat or thin pointer, set SIZE to be the sum of the + sizes of the object and its template. Allocate the whole thing and + fill in the parts that are known. */ + else if (TYPE_IS_FAT_OR_THIN_POINTER_P (result_type)) + { + tree storage_type + = build_unc_object_type_from_ptr (result_type, type, + get_identifier ("ALLOC"), false); + tree template_type = TREE_TYPE (TYPE_FIELDS (storage_type)); + tree storage_ptr_type = build_pointer_type (storage_type); + tree storage; + + size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (storage_type), + init); + + /* If the size overflows, pass -1 so the allocator will raise + storage error. */ + if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size)) + size = ssize_int (-1); + + storage = build_call_alloc_dealloc (NULL_TREE, size, storage_type, + gnat_proc, gnat_pool, gnat_node); + storage = convert (storage_ptr_type, gnat_protect_expr (storage)); + + if (TYPE_IS_PADDING_P (type)) + { + type = TREE_TYPE (TYPE_FIELDS (type)); + if (init) + init = convert (type, init); + } + + /* If there is an initializing expression, make a constructor for + the entire object including the bounds and copy it into the + object. If there is no initializing expression, just set the + bounds. */ + if (init) + { + VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 2); + + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (storage_type), + build_template (template_type, type, init)); + CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (storage_type)), + init); + + return convert + (result_type, + build2 (COMPOUND_EXPR, storage_ptr_type, + build_binary_op + (MODIFY_EXPR, storage_type, + build_unary_op (INDIRECT_REF, NULL_TREE, + convert (storage_ptr_type, storage)), + gnat_build_constructor (storage_type, v)), + convert (storage_ptr_type, storage))); + } + else + return build2 + (COMPOUND_EXPR, result_type, + build_binary_op + (MODIFY_EXPR, template_type, + build_component_ref + (build_unary_op (INDIRECT_REF, NULL_TREE, + convert (storage_ptr_type, storage)), + NULL_TREE, TYPE_FIELDS (storage_type), false), + build_template (template_type, type, NULL_TREE)), + convert (result_type, convert (storage_ptr_type, storage))); + } + + /* If we have an initializing expression, see if its size is simpler + than the size from the type. */ + if (!ignore_init_type && init && TYPE_SIZE_UNIT (TREE_TYPE (init)) + && (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (init))) == INTEGER_CST + || CONTAINS_PLACEHOLDER_P (size))) + size = TYPE_SIZE_UNIT (TREE_TYPE (init)); + + /* If the size is still self-referential, reference the initializing + expression, if it is present. If not, this must have been a + call to allocate a library-level object, in which case we use + the maximum size. */ + if (CONTAINS_PLACEHOLDER_P (size)) + { + if (!ignore_init_type && init) + size = substitute_placeholder_in_expr (size, init); + else + size = max_size (size, true); + } + + /* If the size overflows, pass -1 so the allocator will raise + storage error. */ + if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size)) + size = ssize_int (-1); + + result = convert (result_type, + build_call_alloc_dealloc (NULL_TREE, size, type, + gnat_proc, gnat_pool, + gnat_node)); + + /* If we have an initial value, protect the new address, assign the value + and return the address with a COMPOUND_EXPR. */ + if (init) + { + result = gnat_protect_expr (result); + result + = build2 (COMPOUND_EXPR, TREE_TYPE (result), + build_binary_op + (MODIFY_EXPR, NULL_TREE, + build_unary_op (INDIRECT_REF, + TREE_TYPE (TREE_TYPE (result)), result), + init), + result); + } + + return convert (result_type, result); +} + +/* Indicate that we need to take the address of T and that it therefore + should not be allocated in a register. Returns true if successful. */ + +bool +gnat_mark_addressable (tree t) +{ + while (true) + switch (TREE_CODE (t)) + { + case ADDR_EXPR: + case COMPONENT_REF: + case ARRAY_REF: + case ARRAY_RANGE_REF: + case REALPART_EXPR: + case IMAGPART_EXPR: + case VIEW_CONVERT_EXPR: + case NON_LVALUE_EXPR: + CASE_CONVERT: + t = TREE_OPERAND (t, 0); + break; + + case COMPOUND_EXPR: + t = TREE_OPERAND (t, 1); + break; + + case CONSTRUCTOR: + TREE_ADDRESSABLE (t) = 1; + return true; + + case VAR_DECL: + case PARM_DECL: + case RESULT_DECL: + TREE_ADDRESSABLE (t) = 1; + return true; + + case FUNCTION_DECL: + TREE_ADDRESSABLE (t) = 1; + return true; + + case CONST_DECL: + return DECL_CONST_CORRESPONDING_VAR (t) + && gnat_mark_addressable (DECL_CONST_CORRESPONDING_VAR (t)); + + default: + return true; + } +} + +/* Save EXP for later use or reuse. This is equivalent to save_expr in tree.c + but we know how to handle our own nodes. */ + +tree +gnat_save_expr (tree exp) +{ + tree type = TREE_TYPE (exp); + enum tree_code code = TREE_CODE (exp); + + if (TREE_CONSTANT (exp) || code == SAVE_EXPR || code == NULL_EXPR) + return exp; + + if (code == UNCONSTRAINED_ARRAY_REF) + { + tree t = build1 (code, type, gnat_save_expr (TREE_OPERAND (exp, 0))); + TREE_READONLY (t) = TYPE_READONLY (type); + return t; + } + + /* If this is a COMPONENT_REF of a fat pointer, save the entire fat pointer. + This may be more efficient, but will also allow us to more easily find + the match for the PLACEHOLDER_EXPR. */ + if (code == COMPONENT_REF + && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (exp, 0)))) + return build3 (code, type, gnat_save_expr (TREE_OPERAND (exp, 0)), + TREE_OPERAND (exp, 1), TREE_OPERAND (exp, 2)); + + return save_expr (exp); +} + +/* Protect EXP for immediate reuse. This is a variant of gnat_save_expr that + is optimized under the assumption that EXP's value doesn't change before + its subsequent reuse(s) except through its potential reevaluation. */ + +tree +gnat_protect_expr (tree exp) +{ + tree type = TREE_TYPE (exp); + enum tree_code code = TREE_CODE (exp); + + if (TREE_CONSTANT (exp) || code == SAVE_EXPR || code == NULL_EXPR) + return exp; + + /* If EXP has no side effects, we theoretically don't need to do anything. + However, we may be recursively passed more and more complex expressions + involving checks which will be reused multiple times and eventually be + unshared for gimplification; in order to avoid a complexity explosion + at that point, we protect any expressions more complex than a simple + arithmetic expression. */ + if (!TREE_SIDE_EFFECTS (exp)) + { + tree inner = skip_simple_arithmetic (exp); + if (!EXPR_P (inner) || REFERENCE_CLASS_P (inner)) + return exp; + } + + /* If this is a conversion, protect what's inside the conversion. */ + if (code == NON_LVALUE_EXPR + || CONVERT_EXPR_CODE_P (code) + || code == VIEW_CONVERT_EXPR) + return build1 (code, type, gnat_protect_expr (TREE_OPERAND (exp, 0))); + + /* If we're indirectly referencing something, we only need to protect the + address since the data itself can't change in these situations. */ + if (code == INDIRECT_REF || code == UNCONSTRAINED_ARRAY_REF) + { + tree t = build1 (code, type, gnat_protect_expr (TREE_OPERAND (exp, 0))); + TREE_READONLY (t) = TYPE_READONLY (type); + return t; + } + + /* If this is a COMPONENT_REF of a fat pointer, save the entire fat pointer. + This may be more efficient, but will also allow us to more easily find + the match for the PLACEHOLDER_EXPR. */ + if (code == COMPONENT_REF + && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (exp, 0)))) + return build3 (code, type, gnat_protect_expr (TREE_OPERAND (exp, 0)), + TREE_OPERAND (exp, 1), TREE_OPERAND (exp, 2)); + + /* If this is a fat pointer or something that can be placed in a register, + just make a SAVE_EXPR. Likewise for a CALL_EXPR as large objects are + returned via invisible reference in most ABIs so the temporary will + directly be filled by the callee. */ + if (TYPE_IS_FAT_POINTER_P (type) + || TYPE_MODE (type) != BLKmode + || code == CALL_EXPR) + return save_expr (exp); + + /* Otherwise reference, protect the address and dereference. */ + return + build_unary_op (INDIRECT_REF, type, + save_expr (build_unary_op (ADDR_EXPR, + build_reference_type (type), + exp))); +} + +/* This is equivalent to stabilize_reference_1 in tree.c but we take an extra + argument to force evaluation of everything. */ + +static tree +gnat_stabilize_reference_1 (tree e, bool force) +{ + enum tree_code code = TREE_CODE (e); + tree type = TREE_TYPE (e); + tree result; + + /* We cannot ignore const expressions because it might be a reference + to a const array but whose index contains side-effects. But we can + ignore things that are actual constant or that already have been + handled by this function. */ + if (TREE_CONSTANT (e) || code == SAVE_EXPR) + return e; + + switch (TREE_CODE_CLASS (code)) + { + case tcc_exceptional: + case tcc_declaration: + case tcc_comparison: + case tcc_expression: + case tcc_reference: + case tcc_vl_exp: + /* If this is a COMPONENT_REF of a fat pointer, save the entire + fat pointer. This may be more efficient, but will also allow + us to more easily find the match for the PLACEHOLDER_EXPR. */ + if (code == COMPONENT_REF + && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0)))) + result + = build3 (code, type, + gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force), + TREE_OPERAND (e, 1), TREE_OPERAND (e, 2)); + /* If the expression has side-effects, then encase it in a SAVE_EXPR + so that it will only be evaluated once. */ + /* The tcc_reference and tcc_comparison classes could be handled as + below, but it is generally faster to only evaluate them once. */ + else if (TREE_SIDE_EFFECTS (e) || force) + return save_expr (e); + else + return e; + break; + + case tcc_binary: + /* Recursively stabilize each operand. */ + result + = build2 (code, type, + gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force), + gnat_stabilize_reference_1 (TREE_OPERAND (e, 1), force)); + break; + + case tcc_unary: + /* Recursively stabilize each operand. */ + result + = build1 (code, type, + gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force)); + break; + + default: + gcc_unreachable (); + } + + /* See similar handling in gnat_stabilize_reference. */ + TREE_READONLY (result) = TREE_READONLY (e); + TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e); + TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e); + + if (code == INDIRECT_REF || code == ARRAY_REF || code == ARRAY_RANGE_REF) + TREE_THIS_NOTRAP (result) = TREE_THIS_NOTRAP (e); + + return result; +} + +/* This is equivalent to stabilize_reference in tree.c but we know how to + handle our own nodes and we take extra arguments. FORCE says whether to + force evaluation of everything. We set SUCCESS to true unless we walk + through something we don't know how to stabilize. */ + +tree +gnat_stabilize_reference (tree ref, bool force, bool *success) +{ + tree type = TREE_TYPE (ref); + enum tree_code code = TREE_CODE (ref); + tree result; + + /* Assume we'll success unless proven otherwise. */ + if (success) + *success = true; + + switch (code) + { + case CONST_DECL: + case VAR_DECL: + case PARM_DECL: + case RESULT_DECL: + /* No action is needed in this case. */ + return ref; + + case ADDR_EXPR: + CASE_CONVERT: + case FLOAT_EXPR: + case FIX_TRUNC_EXPR: + case VIEW_CONVERT_EXPR: + result + = build1 (code, type, + gnat_stabilize_reference (TREE_OPERAND (ref, 0), force, + success)); + break; + + case INDIRECT_REF: + case UNCONSTRAINED_ARRAY_REF: + result = build1 (code, type, + gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0), + force)); + break; + + case COMPONENT_REF: + result = build3 (COMPONENT_REF, type, + gnat_stabilize_reference (TREE_OPERAND (ref, 0), force, + success), + TREE_OPERAND (ref, 1), NULL_TREE); + break; + + case BIT_FIELD_REF: + result = build3 (BIT_FIELD_REF, type, + gnat_stabilize_reference (TREE_OPERAND (ref, 0), force, + success), + gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1), + force), + gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2), + force)); + break; + + case ARRAY_REF: + case ARRAY_RANGE_REF: + result = build4 (code, type, + gnat_stabilize_reference (TREE_OPERAND (ref, 0), force, + success), + gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1), + force), + NULL_TREE, NULL_TREE); + break; + + case CALL_EXPR: + result = gnat_stabilize_reference_1 (ref, force); + break; + + case COMPOUND_EXPR: + result = build2 (COMPOUND_EXPR, type, + gnat_stabilize_reference (TREE_OPERAND (ref, 0), force, + success), + gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1), + force)); + break; + + case CONSTRUCTOR: + /* Constructors with 1 element are used extensively to formally + convert objects to special wrapping types. */ + if (TREE_CODE (type) == RECORD_TYPE + && VEC_length (constructor_elt, CONSTRUCTOR_ELTS (ref)) == 1) + { + tree index + = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0)->index; + tree value + = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0)->value; + result + = build_constructor_single (type, index, + gnat_stabilize_reference_1 (value, + force)); + } + else + { + if (success) + *success = false; + return ref; + } + break; + + case ERROR_MARK: + ref = error_mark_node; + + /* ... fall through to failure ... */ + + /* If arg isn't a kind of lvalue we recognize, make no change. + Caller should recognize the error for an invalid lvalue. */ + default: + if (success) + *success = false; + return ref; + } + + /* TREE_THIS_VOLATILE and TREE_SIDE_EFFECTS set on the initial expression + may not be sustained across some paths, such as the way via build1 for + INDIRECT_REF. We reset those flags here in the general case, which is + consistent with the GCC version of this routine. + + Special care should be taken regarding TREE_SIDE_EFFECTS, because some + paths introduce side-effects where there was none initially (e.g. if a + SAVE_EXPR is built) and we also want to keep track of that. */ + TREE_READONLY (result) = TREE_READONLY (ref); + TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (ref); + TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref); + + return result; +} diff --git a/gcc/ada/get_scos.adb b/gcc/ada/get_scos.adb new file mode 100644 index 000000000..70d77c80b --- /dev/null +++ b/gcc/ada/get_scos.adb @@ -0,0 +1,399 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G E T _ S C O S -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with SCOs; use SCOs; +with Types; use Types; + +with Ada.IO_Exceptions; use Ada.IO_Exceptions; + +procedure Get_SCOs is + Dnum : Nat; + C : Character; + Loc1 : Source_Location; + Loc2 : Source_Location; + Cond : Character; + Dtyp : Character; + + use ASCII; + -- For CR/LF + + function At_EOL return Boolean; + -- Skips any spaces, then checks if we are the end of a line. If so, + -- returns True (but does not skip over the EOL sequence). If not, + -- then returns False. + + procedure Check (C : Character); + -- Checks that file is positioned at given character, and if so skips past + -- it, If not, raises Data_Error. + + function Get_Int return Int; + -- On entry the file is positioned to a digit. On return, the file is + -- positioned past the last digit, and the returned result is the decimal + -- value read. Data_Error is raised for overflow (value greater than + -- Int'Last), or if the initial character is not a digit. + + procedure Get_Source_Location (Loc : out Source_Location); + -- Reads a source location in the form line:col and places the source + -- location in Loc. Raises Data_Error if the format does not match this + -- requirement. Note that initial spaces are not skipped. + + procedure Get_Source_Location_Range (Loc1, Loc2 : out Source_Location); + -- Skips initial spaces, then reads a source location range in the form + -- line:col-line:col and places the two source locations in Loc1 and Loc2. + -- Raises Data_Error if format does not match this requirement. + + procedure Skip_EOL; + -- Called with the current character about to be read being LF or CR. Skips + -- past CR/LF characters until either a non-CR/LF character is found, or + -- the end of file is encountered. + + procedure Skip_Spaces; + -- Skips zero or more spaces at the current position, leaving the file + -- positioned at the first non-blank character (or Types.EOF). + + ------------ + -- At_EOL -- + ------------ + + function At_EOL return Boolean is + begin + Skip_Spaces; + return Nextc = CR or else Nextc = LF; + end At_EOL; + + ----------- + -- Check -- + ----------- + + procedure Check (C : Character) is + begin + if Nextc = C then + Skipc; + else + raise Data_Error; + end if; + end Check; + + ------------- + -- Get_Int -- + ------------- + + function Get_Int return Int is + Val : Int; + C : Character; + + begin + C := Nextc; + Val := 0; + + if C not in '0' .. '9' then + raise Data_Error; + end if; + + -- Loop to read digits of integer value + + loop + declare + pragma Unsuppress (Overflow_Check); + begin + Val := Val * 10 + (Character'Pos (C) - Character'Pos ('0')); + end; + + Skipc; + C := Nextc; + + exit when C not in '0' .. '9'; + end loop; + + return Val; + + exception + when Constraint_Error => + raise Data_Error; + end Get_Int; + + ------------------------- + -- Get_Source_Location -- + ------------------------- + + procedure Get_Source_Location (Loc : out Source_Location) is + pragma Unsuppress (Range_Check); + begin + Loc.Line := Logical_Line_Number (Get_Int); + Check (':'); + Loc.Col := Column_Number (Get_Int); + exception + when Constraint_Error => + raise Data_Error; + end Get_Source_Location; + + ------------------------------- + -- Get_Source_Location_Range -- + ------------------------------- + + procedure Get_Source_Location_Range (Loc1, Loc2 : out Source_Location) is + begin + Skip_Spaces; + Get_Source_Location (Loc1); + Check ('-'); + Get_Source_Location (Loc2); + end Get_Source_Location_Range; + -------------- + -- Skip_EOL -- + -------------- + + procedure Skip_EOL is + C : Character; + + begin + loop + Skipc; + C := Nextc; + exit when C /= LF and then C /= CR; + + if C = ' ' then + Skip_Spaces; + C := Nextc; + exit when C /= LF and then C /= CR; + end if; + end loop; + end Skip_EOL; + + ----------------- + -- Skip_Spaces -- + ----------------- + + procedure Skip_Spaces is + begin + while Nextc = ' ' loop + Skipc; + end loop; + end Skip_Spaces; + +-- Start of processing for Get_Scos + +begin + SCOs.Initialize; + + -- Loop through lines of SCO information + + while Nextc = 'C' loop + Skipc; + + C := Getc; + + -- Make sure first line is a header line + + if SCO_Unit_Table.Last = 0 and then C /= ' ' then + raise Data_Error; + end if; + + -- Otherwise dispatch on type of line + + case C is + + -- Header entry + + when ' ' => + + -- Complete previous entry if any + + if SCO_Unit_Table.Last /= 0 then + SCO_Unit_Table.Table (SCO_Unit_Table.Last).To := + SCO_Table.Last; + end if; + + -- Scan out dependency number and file name + + declare + Ptr : String_Ptr := new String (1 .. 32768); + N : Integer; + + begin + Skip_Spaces; + Dnum := Get_Int; + + Skip_Spaces; + + N := 0; + while Nextc > ' ' loop + N := N + 1; + Ptr.all (N) := Getc; + end loop; + + -- Make new unit table entry (will fill in To later) + + SCO_Unit_Table.Append ( + (File_Name => new String'(Ptr.all (1 .. N)), + Dep_Num => Dnum, + From => SCO_Table.Last + 1, + To => 0)); + + Free (Ptr); + end; + + -- Statement entry + + when 'S' | 's' => + declare + Typ : Character; + Key : Character; + + begin + -- If continuation, reset Last indication in last entry + -- stored for previous CS or cs line, and start with key + -- set to s for continuations. + + if C = 's' then + SCO_Table.Table (SCO_Table.Last).Last := False; + Key := 's'; + + -- CS case (first line, so start with key set to S) + + else + Key := 'S'; + end if; + + -- Initialize to scan items on one line + + Skip_Spaces; + + -- Loop through items on one line + + loop + Typ := Nextc; + + if Typ in '1' .. '9' then + Typ := ' '; + else + Skipc; + end if; + + Get_Source_Location_Range (Loc1, Loc2); + + Add_SCO + (C1 => Key, + C2 => Typ, + From => Loc1, + To => Loc2, + Last => At_EOL); + + exit when At_EOL; + Key := 's'; + end loop; + end; + + -- Decision entry + + when 'I' | 'E' | 'P' | 'W' | 'X' => + Dtyp := C; + Skip_Spaces; + + -- Output header + + declare + Loc : Source_Location; + C2v : Character; + + begin + -- Acquire location information + + if Dtyp = 'X' then + Loc := No_Source_Location; + else + Get_Source_Location (Loc); + end if; + + -- C2 is a space except for pragmas where it is 'e' since + -- clearly the pragma is enabled if it was written out. + + if C = 'P' then + C2v := 'e'; + else + C2v := ' '; + end if; + + Add_SCO + (C1 => Dtyp, + C2 => C2v, + From => Loc, + To => No_Source_Location, + Last => False); + end; + + -- Loop through terms in complex expression + + C := Nextc; + while C /= CR and then C /= LF loop + if C = 'c' or else C = 't' or else C = 'f' then + Cond := C; + Skipc; + Get_Source_Location_Range (Loc1, Loc2); + Add_SCO + (C2 => Cond, + From => Loc1, + To => Loc2, + Last => False); + + elsif C = '!' or else + C = '&' or else + C = '|' + then + Skipc; + + declare + Loc : Source_Location; + begin + Get_Source_Location (Loc); + Add_SCO (C1 => C, From => Loc, Last => False); + end; + + elsif C = ' ' then + Skip_Spaces; + + else + raise Data_Error; + end if; + + C := Nextc; + end loop; + + -- Reset Last indication to True for last entry + + SCO_Table.Table (SCO_Table.Last).Last := True; + + -- No other SCO lines are possible + + when others => + raise Data_Error; + end case; + + Skip_EOL; + end loop; + + -- Here with all SCO's stored, complete last SCO Unit table entry + + SCO_Unit_Table.Table (SCO_Unit_Table.Last).To := SCO_Table.Last; +end Get_SCOs; diff --git a/gcc/ada/get_scos.ads b/gcc/ada/get_scos.ads new file mode 100644 index 000000000..639d938bb --- /dev/null +++ b/gcc/ada/get_scos.ads @@ -0,0 +1,58 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G E T _ S C O 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 used to read SCO information from an ALI +-- file and populate the tables defined in package SCOs with the result. + +generic + -- These subprograms provide access to the ALI file. Locating, opening and + -- providing access to the ALI file is the callers' responsibility. + + with function Getc return Character is <>; + -- Get next character, positioning the ALI file ready to read the following + -- character (equivalent to calling Skipc, then Nextc). If the end of file + -- is encountered, the value Types.EOF is returned. + + with function Nextc return Character is <>; + -- Look at the next character, and return it, leaving the position of the + -- file unchanged, so that a subsequent call to Getc or Nextc will return + -- this same character. If the file is positioned at the end of file, then + -- Types.EOF is returned. + + with procedure Skipc is <>; + -- Skip past the current character (which typically was read with Nextc), + -- and position to the next character, which will be returned by the next + -- call to Getc or Nextc. + +procedure Get_SCOs; +-- Load SCO information from ALI file text format into internal SCO tables +-- (SCOs.SCO_Table and SCOs.SCO_Unit_Table). On entry the input file is +-- positioned to the initial 'C' of the first SCO line in the ALI file. +-- On return, the file is positioned either to the end of file, or to the +-- first character of the line following the SCO information (which will +-- never start with a 'C'). +-- +-- If a format error is detected in the input, then an exceptions is raised +-- (Ada.IO_Exceptions.Data_Error), with the file positioned to the error. diff --git a/gcc/ada/get_targ.adb b/gcc/ada/get_targ.adb new file mode 100644 index 000000000..9eb588dd5 --- /dev/null +++ b/gcc/ada/get_targ.adb @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G E T _ T A R G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Get_Targ is + + ---------------------- + -- Digits_From_Size -- + ---------------------- + + function Digits_From_Size (Size : Pos) return Pos is + begin + if Size = 32 then + return 6; + elsif Size = 48 then + return 9; + elsif Size = 64 then + return 15; + elsif Size = 96 then + return 18; + elsif Size = 128 then + return 18; + else + raise Program_Error; + end if; + end Digits_From_Size; + + ----------------------------- + -- Get_Max_Unaligned_Field -- + ----------------------------- + + function Get_Max_Unaligned_Field return Pos is + begin + return 64; -- Can be different on some targets (e.g., AAMP) + end Get_Max_Unaligned_Field; + + --------------------- + -- Width_From_Size -- + --------------------- + + function Width_From_Size (Size : Pos) return Pos is + begin + if Size = 8 then + return 4; + elsif Size = 16 then + return 6; + elsif Size = 32 then + return 11; + elsif Size = 64 then + return 21; + else + raise Program_Error; + end if; + end Width_From_Size; + +end Get_Targ; diff --git a/gcc/ada/get_targ.ads b/gcc/ada/get_targ.ads new file mode 100644 index 000000000..07a9ab2db --- /dev/null +++ b/gcc/ada/get_targ.ads @@ -0,0 +1,114 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G E T _ T A R G -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an Import to the C functions which provide +-- values related to types on the target system. It is only needed for +-- exp_dbug and the elaboration of ttypes. + +-- NOTE: Any changes in this package must be reflected in jgettarg.ads +-- and aa_getta.ads! + +-- Note that all these values return sizes of C types with corresponding +-- names. This allows GNAT to define the corresponding Ada types to have +-- the same representation. There is one exception to this: the +-- Wide_Character_Type uses twice the size of a C char, instead of the +-- size of wchar_t. + +with Types; use Types; + +package Get_Targ is + pragma Preelaborate; + + function Get_Bits_Per_Unit return Pos; + pragma Import (C, Get_Bits_Per_Unit, "get_target_bits_per_unit"); + + function Get_Bits_Per_Word return Pos; + pragma Import (C, Get_Bits_Per_Word, "get_target_bits_per_word"); + + function Get_Char_Size return Pos; -- Standard.Character'Size + pragma Import (C, Get_Char_Size, "get_target_char_size"); + + function Get_Wchar_T_Size return Pos; -- Interfaces.C.wchar_t'Size + pragma Import (C, Get_Wchar_T_Size, "get_target_wchar_t_size"); + + function Get_Short_Size return Pos; -- Standard.Short_Integer'Size + pragma Import (C, Get_Short_Size, "get_target_short_size"); + + function Get_Int_Size return Pos; -- Standard.Integer'Size + pragma Import (C, Get_Int_Size, "get_target_int_size"); + + function Get_Long_Size return Pos; -- Standard.Long_Integer'Size + pragma Import (C, Get_Long_Size, "get_target_long_size"); + + function Get_Long_Long_Size return Pos; -- Standard.Long_Long_Integer'Size + pragma Import (C, Get_Long_Long_Size, "get_target_long_long_size"); + + function Get_Float_Size return Pos; -- Standard.Float'Size + pragma Import (C, Get_Float_Size, "get_target_float_size"); + + function Get_Double_Size return Pos; -- Standard.Long_Float'Size + pragma Import (C, Get_Double_Size, "get_target_double_size"); + + function Get_Long_Double_Size return Pos; -- Standard.Long_Long_Float'Size + pragma Import (C, Get_Long_Double_Size, "get_target_long_double_size"); + + function Get_Pointer_Size return Pos; -- System.Address'Size + pragma Import (C, Get_Pointer_Size, "get_target_pointer_size"); + + function Get_Maximum_Alignment return Pos; + pragma Import (C, Get_Maximum_Alignment, "get_target_maximum_alignment"); + + function Get_Float_Words_BE return Nat; + pragma Import (C, Get_Float_Words_BE, "get_float_words_be"); + + function Get_Words_BE return Nat; + pragma Import (C, Get_Words_BE, "get_words_be"); + + function Get_Bytes_BE return Nat; + pragma Import (C, Get_Bytes_BE, "get_bytes_be"); + + function Get_Bits_BE return Nat; + pragma Import (C, Get_Bits_BE, "get_bits_be"); + + function Get_Strict_Alignment return Nat; + pragma Import (C, Get_Strict_Alignment, "get_target_strict_alignment"); + + function Get_Double_Float_Alignment return Nat; + pragma Import (C, Get_Double_Float_Alignment, + "get_target_double_float_alignment"); + + function Get_Double_Scalar_Alignment return Nat; + pragma Import (C, Get_Double_Scalar_Alignment, + "get_target_double_scalar_alignment"); + + function Get_Max_Unaligned_Field return Pos; + -- Returns the maximum supported size in bits for a field that is + -- not aligned on a storage unit boundary. + + function Width_From_Size (Size : Pos) return Pos; + function Digits_From_Size (Size : Pos) return Pos; + -- Calculate values for 'Width or 'Digits from 'Size + +end Get_Targ; diff --git a/gcc/ada/gnat-style.texi b/gcc/ada/gnat-style.texi new file mode 100644 index 000000000..13eb1ed1f --- /dev/null +++ b/gcc/ada/gnat-style.texi @@ -0,0 +1,930 @@ +\input texinfo @c -*-texinfo-*- +@c %**start of header + +@c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo +@c o +@c GNAT DOCUMENTATION o +@c o +@c G N A T C O D I N G S T Y L E o +@c o +@c GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). o +@c o +@c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo + +@setfilename gnat-style.info + +@copying +Copyright @copyright{} 1992-2008, Free Software Foundation, Inc. + +Permission is granted to copy, distribute and/or modify this document +under the terms of the GNU Free Documentation License, Version 1.3 or +any later version published by the Free Software Foundation; with no +Invariant Sections, with no Front-Cover Texts and with no Back-Cover +Texts. A copy of the license is included in the section entitled +``GNU Free Documentation License''. +@end copying + +@settitle GNAT Coding Style +@setchapternewpage odd + +@include gcc-common.texi + +@dircategory Software development +@direntry +* gnat-style: (gnat-style). GNAT Coding Style +@end direntry + +@macro syntax{element} +@t{\element\} +@end macro +@c %**end of header + +@titlepage +@titlefont{GNAT Coding Style:} +@sp 1 +@title A Guide for GNAT Developers +@subtitle GNAT, The GNU Ada Compiler +@versionsubtitle +@author Ada Core Technologies, Inc. +@page +@vskip 0pt plus 1filll + +@insertcopying +@end titlepage + +@raisesections + +@node Top, General, , (dir) +@comment node-name, next, previous, up + +@ifnottex +@noindent +GNAT Coding Style@* +A Guide for GNAT Developers +@sp 2 +@noindent +GNAT, The GNU Ada Compiler@* + +@noindent +@insertcopying +@end ifnottex + + +@menu +* General:: +* Lexical Elements:: +* Declarations and Types:: +* Expressions and Names:: +* Statements:: +* Subprograms:: +* Packages:: +* Program Structure:: +* GNU Free Documentation License:: +* Index:: +@end menu + +@c ------------------------------------------------------------------------- +@node General, Lexical Elements, Top, Top +@section General +@c ------------------------------------------------------------------------- + +@noindent +Most of GNAT is written in Ada using a consistent style to ensure +readability of the code. This document has been written to help +maintain this consistent style, while having a large group of developers +work on the compiler. + +For the coding style in the C parts of the compiler and run time, +see the GNU Coding Guidelines. + +This document is structured after the @cite{Ada Reference Manual}. +Those familiar with that document should be able to quickly +lookup style rules for particular constructs. + + +@c ------------------------------------------------------------------------- +@node Lexical Elements, Declarations and Types, General, Top +@section Lexical Elements +@c ------------------------------------------------------------------------- +@cindex Lexical elements + +@subsection Character Set and Separators +@c ------------------------------------------------------------------------- +@cindex Character set +@cindex ASCII +@cindex Separators +@cindex End-of-line +@cindex Line length +@cindex Indentation + +@itemize @bullet +@item +The character set used should be plain 7-bit ASCII@. +The only separators allowed are space and the end-of-line sequence. +No other control character or format effector (such as @code{HT}, +@code{VT}, @code{FF}) +should be used. +The normal end-of-line sequence is used, which may be +@code{LF}, @code{CR/LF} or @code{CR}, +depending on the host system. An optional @code{SUB} +(@code{16#1A#}) may be present as the +last character in the file on hosts using that character as file terminator. + +@item +Files that are checked in or distributed should be in host format. + +@item +A line should never be longer than 79 characters, not counting the line +separator. + +@item +Lines must not have trailing blanks. + +@item +Indentation is 3 characters per level for @code{if} statements, loops, and +@code{case} statements. +For exact information on required spacing between lexical +elements, see file @file{style.adb}. +@cindex @file{style.adb} file +@end itemize + + +@subsection Identifiers +@c ------------------------------------------------------------------------- +@itemize @bullet +@cindex Identifiers + +@item +Identifiers will start with an upper case letter, and each letter following +an underscore will be upper case. +@cindex Casing (for identifiers) +Short acronyms may be all upper case. +All other letters are lower case. +An exception is for identifiers matching a foreign language. In particular, +we use all lower case where appropriate for C@. + +@item +Use underscores to separate words in an identifier. +@cindex Underscores + +@item Try to limit your use of abbreviations in identifiers. +It is ok to make a few abbreviations, explain what they mean, and then +use them frequently, but don't use lots of obscure abbreviations. An +example is the @code{ALI} word which stands for Ada Library +Information and is by convention always written in upper-case when +used in entity names. + +@smallexample @c adanocomment + procedure Find_ALI_Files; +@end smallexample + +@item +Don't use the variable name @code{I}, use @code{J} instead; @code{I} is too +easily confused with @code{1} in some fonts. Similarly don't use the +variable @code{O}, which is too easily mistaken for the number @code{0}. +@end itemize + +@subsection Numeric Literals +@c ------------------------------------------------------------------------- +@cindex Numeric literals + +@itemize @bullet +@item +Numeric literals should include underscores where helpful for +readability. +@cindex Underscores + +@smallexample + 1_000_000 + 16#8000_000# + 3.14159_26535_89793_23846 +@end smallexample +@end itemize + +@subsection Reserved Words +@c ------------------------------------------------------------------------- +@cindex Reserved words + +@itemize @bullet +@item +Reserved words use all lower case. +@cindex Casing (for reserved words) + +@smallexample @c adanocomment + return else +@end smallexample + +@item +The words @code{Access}, @code{Delta} and @code{Digits} are +capitalized when used as @syntax{attribute_designator}. +@end itemize + +@subsection Comments +@c ------------------------------------------------------------------------- +@cindex Comments + +@itemize @bullet +@item +A comment starts with @code{--} followed by two spaces. +The only exception to this rule (i.e.@: one space is tolerated) is when the +comment ends with a single space followed by @code{--}. +It is also acceptable to have only one space between @code{--} and the start +of the comment when the comment is at the end of a line, +after some Ada code. + +@item +Every sentence in a comment should start with an upper-case letter (including +the first letter of the comment). +@cindex Casing (in comments) + +@item +When declarations are commented with ``hanging'' comments, i.e.@: +comments after the declaration, there is no blank line before the +comment, and if it is absolutely necessary to have blank lines within +the comments, e.g. to make paragraph separations within a single comment, +these blank lines @emph{do} have a @code{--} (unlike the +normal rule, which is to use entirely blank lines for separating +comment paragraphs). The comment starts at same level of indentation +as code it is commenting. +@cindex Blank lines (in comments) +@cindex Indentation + +@smallexample @c adanocomment + z : Integer; + -- Integer value for storing value of z + -- + -- The previous line was a blank line. +@end smallexample + +@item +Comments that are dubious or incomplete, or that comment on possibly +wrong or incomplete code, should be preceded or followed by @code{???}@. + +@item +Comments in a subprogram body must generally be surrounded by blank lines. +An exception is a comment that follows a line containing a single keyword +(@code{begin}, @code{else}, @code{loop}): + +@smallexample @c adanocomment +@group + begin + -- Comment for the next statement + + A := 5; + + -- Comment for the B statement + + B := 6; + end; +@end group +@end smallexample + +@item +In sequences of statements, comments at the end of the lines should be +aligned. +@cindex Alignment (in comments) + +@smallexample @c adanocomment + My_Identifier := 5; -- First comment + Other_Id := 6; -- Second comment +@end smallexample + +@item +Short comments that fit on a single line are @emph{not} ended with a +period. Comments taking more than a line are punctuated in the normal +manner. + +@item +Comments should focus on @emph{why} instead of @emph{what}. +Descriptions of what subprograms do go with the specification. + +@item +Comments describing a subprogram spec should specifically mention the +formal argument names. General rule: write a comment that does not +depend on the names of things. The names are supplementary, not +sufficient, as comments. + +@item +@emph{Do not} put two spaces after periods in comments. +@end itemize + +@c ------------------------------------------------------------------------- +@node Declarations and Types, Expressions and Names, Lexical Elements,Top +@section Declarations and Types +@c ------------------------------------------------------------------------- +@cindex Declarations and Types + +@itemize @bullet +@item +In entity declarations, colons must be surrounded by spaces. Colons +should be aligned. +@cindex Alignment (in declarations) + +@smallexample @c adanocomment + Entity1 : Integer; + My_Entity : Integer; +@end smallexample + +@item +Declarations should be grouped in a logical order. +Related groups of declarations may be preceded by a header comment. + +@item +All local subprograms in a subprogram or package body should be declared +before the first local subprogram body. + +@item +Do not declare local entities that hide global entities. +@cindex Hiding of outer entities + +@item +Do not declare multiple variables in one declaration that spans lines. +Start a new declaration on each line, instead. + +@item +The @syntax{defining_identifier}s of global declarations serve as +comments of a sort. So don't choose terse names, but look for names +that give useful information instead. + +@item +Local names can be shorter, because they are used only within +one context, where comments explain their purpose. + +@end itemize + + +@c ------------------------------------------------------------------------- +@node Expressions and Names, Statements, Declarations and Types, Top +@section Expressions and Names +@c ------------------------------------------------------------------------- +@cindex Expressions and names + +@itemize @bullet + +@item +Every operator must be surrounded by spaces. An exception is that +this rule does not apply to the exponentiation operator, for which +there are no specific layout rules. The reason for this exception +is that sometimes it makes clearer reading to leave out the spaces +around exponentiation. +@cindex Operators + +@smallexample @c adanocomment + E := A * B**2 + 3 * (C - D); +@end smallexample + +@item +Use parentheses where they clarify the intended association of operands +with operators: +@cindex Parenthesization of expressions +@smallexample @c adanocomment + (A / B) * C +@end smallexample +@end itemize + +@c ------------------------------------------------------------------------- +@node Statements, Subprograms, Expressions and Names, Top +@section Statements +@c ------------------------------------------------------------------------- +@cindex Statements + +@subsection Simple and Compound Statements +@c ------------------------------------------------------------------------- +@cindex Simple and compound statements + +@itemize @bullet +@item +Use only one statement or label per line. +@item +A longer @syntax{sequence_of_statements} may be divided in logical +groups or separated from surrounding code using a blank line. +@end itemize + +@subsection If Statements +@c ------------------------------------------------------------------------- +@cindex @code{if} statement + +@itemize @bullet +@item +When the @code{if}, @code{elsif} or @code{else} keywords fit on the +same line with the condition and the @code{then} keyword, then the +statement is formatted as follows: +@cindex Alignment (in an @code{if} statement) + +@smallexample @c adanocomment +@group + if @var{condition} then + ... + elsif @var{condition} then + ... + else + ... + end if; +@end group +@end smallexample + +@noindent +When the above layout is not possible, @code{then} should be aligned +with @code{if}, and conditions should preferably be split before an +@code{and} or @code{or} keyword a follows: + +@smallexample @c adanocomment +@group + if @var{long_condition_that_has_to_be_split} + and then @var{continued_on_the_next_line} + then + ... + end if; +@end group +@end smallexample + +@noindent +The @code{elsif}, @code{else} and @code{end if} always line up with +the @code{if} keyword. The preferred location for splitting the line +is before @code{and} or @code{or}. The continuation of a condition is +indented with two spaces or as many as needed to make nesting clear. +As an exception, if conditions are closely related either of the +following is allowed: + +@smallexample +@group + if x = lakdsjfhlkashfdlkflkdsalkhfsalkdhflkjdsahf + or else + x = asldkjhalkdsjfhhfd + or else + x = asdfadsfadsf + then + ... + end if; +@end group + +@group + if x = lakdsjfhlkashfdlkflkdsalkhfsalkdhflkjdsahf or else + x = asldkjhalkdsjfhhfd or else + x = asdfadsfadsf + then + ... + end if; +@end group +@end smallexample + +@item +Conditions should use short-circuit forms (@code{and then}, +@code{or else}), except when the operands are boolean variables +or boolean constants. +@cindex Short-circuit forms + +@item +Complex conditions in @code{if} statements are indented two characters: +@cindex Indentation (in @code{if} statements) + +@smallexample @c adanocomment +@group + if @var{this_complex_condition} + and then @var{that_other_one} + and then @var{one_last_one} + then + ... + end if; +@end group +@end smallexample + +@noindent +There are some cases where complex conditionals can be laid out +in manners that do not follow these rules to preserve better +parallelism between branches, e.g. + +@smallexample @c adanocomment +@group + if xyz.abc (gef) = 'c' + or else + xyz.abc (gef) = 'x' + then + ... + end if; +@end group +@end smallexample + + +@item +Every @code{if} block is preceded and followed by a blank line, except +where it begins or ends a @syntax{sequence_of_statements}. +@cindex Blank lines (in an @code{if} statement) + +@smallexample @c adanocomment +@group + A := 5; + + if A = 5 then + null; + end if; + + A := 6; +@end group +@end smallexample +@end itemize + +@subsection Case Statements +@cindex @code{case} statements + +@itemize @bullet +@item +Layout is as below. For long @code{case} statements, the extra indentation +can be saved by aligning the @code{when} clauses with the opening @code{case}. + +@smallexample @c adanocomment +@group + case @var{expression} is + when @var{condition} => + ... + when @var{condition} => + ... + end case; +@end group +@end smallexample +@end itemize + +@subsection Loop Statements +@cindex Loop statements + +@itemize @bullet +@noindent +When possible, have @code{for} or @code{while} on one line with the +condition and the @code{loop} keyword. + +@smallexample @c adanocomment +@group + for J in S'Range loop + ... + end loop; +@end group +@end smallexample + +@noindent +If the condition is too long, split the condition (see ``If +statements'' above) and align @code{loop} with the @code{for} or +@code{while} keyword. +@cindex Alignment (in a loop statement) + +@smallexample @c adanocomment +@group + while @var{long_condition_that_has_to_be_split} + and then @var{continued_on_the_next_line} + loop + ... + end loop; +@end group +@end smallexample + +@noindent +If the @syntax{loop_statement} has an identifier, it is laid out as follows: + +@smallexample @c adanocomment +@group + Outer : while not @var{condition} loop + ... + end Outer; +@end group +@end smallexample +@end itemize + +@subsection Block Statements +@cindex Block statement + +@itemize @bullet +@item +The @code{declare} (optional), @code{begin} and @code{end} words +are aligned, except when the @syntax{block_statement} is named. There +is a blank line before the @code{begin} keyword: +@cindex Alignment (in a block statement) + +@smallexample @c adanocomment +@group + Some_Block : declare + ... + + begin + ... + end Some_Block; +@end group +@end smallexample + +@end itemize + +@c ------------------------------------------------------------------------- +@node Subprograms, Packages, Statements, Top +@section Subprograms +@c ------------------------------------------------------------------------- +@cindex Subprograms + +@subsection Subprogram Declarations +@c ------------------------------------------------------------------------- +@itemize @bullet + +@item +Do not write the @code{in} for parameters. + +@smallexample @c adanocomment + function Length (S : String) return Integer; +@end smallexample + +@item +When the declaration line for a procedure or a function is too long to fit +the entire declaration (including the keyword procedure or function) on a +single line, then fold it, putting a single parameter on a line, aligning +the colons, as in: + +@smallexample @c adanocomment +@group + procedure Set_Heading + (Source : String; + Count : Natural; + Pad : Character := Space; + Fill : Boolean := True); +@end group +@end smallexample + +@noindent +In the case of a function, if the entire spec does not fit on one line, then +the return may appear after the last parameter, as in: + +@smallexample @c adanocomment +@group + function Head + (Source : String; + Count : Natural; + Pad : Character := Space) return String; +@end group +@end smallexample + +@noindent +Or it may appear on its own as a separate line. This form is preferred when +putting the return on the same line as the last parameter would result in +an overlong line. The return type may optionally be aligned with the types +of the parameters (usually we do this aligning if it results only in a small +number of extra spaces, and otherwise we don't attempt to align). So two +alternative forms for the above spec are: + +@smallexample @c adanocomment +@group + function Head + (Source : String; + Count : Natural; + Pad : Character := Space) + return String; + + function Head + (Source : String; + Count : Natural; + Pad : Character := Space) + return String; +@end group +@end smallexample + +@end itemize + +@subsection Subprogram Bodies +@c ------------------------------------------------------------------------- +@cindex Subprogram bodies + +@itemize @bullet +@item +Function and procedure bodies should usually be sorted alphabetically. Do +not attempt to sort them in some logical order by functionality. For a +sequence of subprogram specs, a general alphabetical sorting is also +usually appropriate, but occasionally it makes sense to group by major +function, with appropriate headers. + +@item +All subprograms have a header giving the function name, with the following +format: + +@smallexample @c adanocomment +@group + ----------------- + -- My_Function -- + ----------------- + + procedure My_Function is + begin + ... + end My_Function; +@end group +@end smallexample + +@noindent +Note that the name in the header is preceded by a single space, +not two spaces as for other comments. These headers are used on +nested subprograms as well as outer level subprograms. They may +also be used as headers for sections of comments, or collections +of declarations that are related. + +@item +Every subprogram body must have a preceding @syntax{subprogram_declaration}. + +@item +@cindex Blank lines (in subprogram bodies) +A sequence of declarations may optionally be separated from the following +begin by a blank line. Just as we optionally allow blank lines in general +between declarations, this blank line should be present only if it improves +readability. Generally we avoid this blank line if the declarative part is +small (one or two lines) and the body has no blank lines, and we include it +if the declarative part is long or if the body has blank lines. + +@item +If the declarations in a subprogram contain at least one nested +subprogram body, then just before the @code{begin} of the enclosing +subprogram, there is a comment line and a blank line: + +@smallexample @c adanocomment +@group + -- Start of processing for @var{Enclosing_Subprogram} + + begin + ... + end @var{Enclosing_Subprogram}; +@end group +@end smallexample + +@item +When nested subprograms are present, variables that are referenced by any +nested subprogram should precede the nested subprogram specs. For variables +that are not referenced by nested procedures, the declarations can either also +be before any of the nested subprogram specs (this is the old style, more +generally used). Or then can come just before the begin, with a header. The +following example shows the two possible styles: + +@smallexample @c adanocomment +@group + procedure Style1 is + Var_Referenced_In_Nested : Integer; + Var_Referenced_Only_In_Style1 : Integer; + + proc Nested; + -- Comments ... + + + ------------ + -- Nested -- + ------------ + + procedure Nested is + begin + ... + end Nested; + + -- Start of processing for Style1 + + begin + ... + end Style1; + +@end group + +@group + procedure Style2 is + Var_Referenced_In_Nested : Integer; + + proc Nested; + -- Comments ... + + ------------ + -- Nested -- + ------------ + + procedure Nested is + begin + ... + end Nested; + + -- Local variables + + Var_Referenced_Only_In_Style2 : Integer; + + -- Start of processing for Style2 + + begin + ... + end Style2; + +@end group +@end smallexample + +@noindent +For new code, we generally prefer Style2, but we do not insist on +modifying all legacy occurrences of Style1, which is still much +more common in the sources. + +@end itemize + + +@c ------------------------------------------------------------------------- +@node Packages, Program Structure, Subprograms, Top +@section Packages and Visibility Rules +@c ------------------------------------------------------------------------- +@cindex Packages + +@itemize @bullet +@item +All program units and subprograms have their name at the end: + +@smallexample @c adanocomment +@group + package P is + ... + end P; +@end group +@end smallexample + +@item +We will use the style of @code{use}-ing @code{with}-ed packages, with +the context clauses looking like: +@cindex @code{use} clauses + +@smallexample @c adanocomment +@group + with A; use A; + with B; use B; +@end group +@end smallexample + +@item +Names declared in the visible part of packages should be +unique, to prevent name clashes when the packages are @code{use}d. +@cindex Name clash avoidance + +@smallexample @c adanocomment +@group + package Entity is + type Entity_Kind is ...; + ... + end Entity; +@end group +@end smallexample + +@item +After the file header comment, the context clause and unit specification +should be the first thing in a @syntax{program_unit}. + +@item +Preelaborate, Pure and Elaborate_Body pragmas should be added right after the +package name, indented an extra level and using the parameterless form: + +@smallexample @c adanocomment +@group + package Preelaborate_Package is + pragma Preelaborate; + ... + end Preelaborate_Package; +@end group +@end smallexample + +@end itemize + +@c ------------------------------------------------------------------------- +@node Program Structure, GNU Free Documentation License, Packages, Top +@section Program Structure and Compilation Issues +@c ------------------------------------------------------------------------- +@cindex Program structure + +@itemize @bullet +@item +Every GNAT source file must be compiled with the @option{-gnatg} +switch to check the coding style. +(Note that you should look at +@file{style.adb} to see the lexical rules enforced by +@option{-gnatg}). +@cindex @option{-gnatg} option (to gcc) +@cindex @file{style.adb} file + +@item +Each source file should contain only one compilation unit. + +@item +Filenames should be 8 or fewer characters, followed by the @code{.adb} +extension for a body or @code{.ads} for a spec. +@cindex File name length + +@item +Unit names should be distinct when ``krunch''ed to 8 characters +(see @file{krunch.ads}) and the filenames should match the unit name, +except that they are all lower case. +@cindex @file{krunch.ads} file +@end itemize + + +@c ********************************** +@c * GNU Free Documentation License * +@c ********************************** +@include fdl.texi +@c GNU Free Documentation License +@cindex GNU Free Documentation License + +@node Index,,GNU Free Documentation License, Top +@unnumberedsec Index + +@printindex cp + +@contents + +@bye diff --git a/gcc/ada/gnat.ads b/gcc/ada/gnat.ads new file mode 100644 index 000000000..faf1bff22 --- /dev/null +++ b/gcc/ada/gnat.ads @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005 AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the parent package for a library of useful units provided with GNAT + +package GNAT is + pragma Pure; + +end GNAT; diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb new file mode 100644 index 000000000..2bd24ad54 --- /dev/null +++ b/gcc/ada/gnat1drv.adb @@ -0,0 +1,1092 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T 1 D R V -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Back_End; use Back_End; +with Comperr; +with Csets; use Csets; +with Debug; use Debug; +with Elists; +with Errout; use Errout; +with Exp_CG; +with Fmap; +with Fname; use Fname; +with Fname.UF; use Fname.UF; +with Frontend; +with Gnatvsn; use Gnatvsn; +with Hostparm; +with Inline; +with Lib; use Lib; +with Lib.Writ; use Lib.Writ; +with Lib.Xref; +with Namet; use Namet; +with Nlists; +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; +with Par_SCO; +with Prepcomp; +with Repinfo; use Repinfo; +with Restrict; +with Rident; use Rident; +with Rtsfind; +with SCOs; +with Sem; +with Sem_Ch8; +with Sem_Ch12; +with Sem_Ch13; +with Sem_Elim; +with Sem_Eval; +with Sem_Type; +with Sinfo; use Sinfo; +with Sinput.L; use Sinput.L; +with Snames; +with Sprint; use Sprint; +with Stringt; +with Stylesw; use Stylesw; +with Targparm; use Targparm; +with Tree_Gen; +with Treepr; use Treepr; +with Ttypes; +with Types; use Types; +with Uintp; use Uintp; +with Uname; use Uname; +with Urealp; +with Usage; +with Validsw; use Validsw; + +with System.Assertions; + +procedure Gnat1drv is + Main_Unit_Node : Node_Id; + -- Compilation unit node for main unit + + Main_Kind : Node_Kind; + -- Kind of main compilation unit node + + Back_End_Mode : Back_End.Back_End_Mode_Type; + -- Record back end mode + + procedure Adjust_Global_Switches; + -- There are various interactions between front end switch settings, + -- including debug switch settings and target dependent parameters. + -- This procedure takes care of properly handling these interactions. + -- We do it after scanning out all the switches, so that we are not + -- depending on the order in which switches appear. + + procedure Check_Bad_Body; + -- Called to check if the unit we are compiling has a bad body + + procedure Check_Rep_Info; + -- Called when we are not generating code, to check if -gnatR was requested + -- and if so, explain that we will not be honoring the request. + + procedure Check_Library_Items; + -- For debugging -- checks the behavior of Walk_Library_Items + pragma Warnings (Off, Check_Library_Items); + -- In case the call below is commented out + + ---------------------------- + -- Adjust_Global_Switches -- + ---------------------------- + + procedure Adjust_Global_Switches is + begin + -- Debug flag -gnatd.I is a synonym for Generate_SCIL and requires code + -- generation. + + if Debug_Flag_Dot_II + and then Operating_Mode = Generate_Code + then + Generate_SCIL := True; + end if; + + -- Disable CodePeer_Mode in Check_Syntax, since we need front-end + -- expansion. + + if Operating_Mode = Check_Syntax then + CodePeer_Mode := False; + end if; + + -- Set ASIS mode if -gnatt and -gnatc are set + + if Operating_Mode = Check_Semantics and then Tree_Output then + ASIS_Mode := True; + + -- Turn off inlining in ASIS mode, since ASIS cannot handle the extra + -- information in the trees caused by inlining being active. + + -- More specifically, the tree seems to be malformed from the ASIS + -- point of view if -gnatc and -gnatn appear together??? + + Inline_Active := False; + + -- Turn off SCIL generation and CodePeer mode in semantics mode, + -- since SCIL requires front-end expansion. + + Generate_SCIL := False; + CodePeer_Mode := False; + end if; + + -- SCIL mode needs to disable front-end inlining since the generated + -- trees (in particular order and consistency between specs compiled + -- as part of a main unit or as part of a with-clause) are causing + -- troubles. + + if Generate_SCIL then + Front_End_Inlining := False; + end if; + + -- Tune settings for optimal SCIL generation in CodePeer mode + + if CodePeer_Mode then + + -- Turn off inlining, confuses CodePeer output and gains nothing + + Front_End_Inlining := False; + Inline_Active := False; + + -- Disable front-end optimizations, to keep the tree as close to the + -- source code as possible, and also to avoid inconsistencies between + -- trees when using different optimization switches. + + Optimization_Level := 0; + + -- Enable some restrictions systematically to simplify the generated + -- code (and ease analysis). Note that restriction checks are also + -- disabled in CodePeer mode, see Restrict.Check_Restriction, and + -- user specified Restrictions pragmas are ignored, see + -- Sem_Prag.Process_Restrictions_Or_Restriction_Warnings. + + Restrict.Restrictions.Set (No_Initialize_Scalars) := True; + Restrict.Restrictions.Set (No_Task_Hierarchy) := True; + Restrict.Restrictions.Set (No_Abort_Statements) := True; + Restrict.Restrictions.Set (Max_Asynchronous_Select_Nesting) := True; + Restrict.Restrictions.Value (Max_Asynchronous_Select_Nesting) := 0; + + -- Suppress overflow, division by zero and access checks since they + -- are handled implicitly by CodePeer. + + -- Turn off dynamic elaboration checks: generates inconsistencies in + -- trees between specs compiled as part of a main unit or as part of + -- a with-clause. + + -- Turn off alignment checks: these cannot be proved statically by + -- CodePeer and generate false positives. + + -- Enable all other language checks + + Suppress_Options := + (Access_Check => True, + Alignment_Check => True, + Division_Check => True, + Elaboration_Check => True, + Overflow_Check => True, + others => False); + Enable_Overflow_Checks := False; + Dynamic_Elaboration_Checks := False; + + -- Kill debug of generated code, since it messes up sloc values + + Debug_Generated_Code := False; + + -- Turn cross-referencing on in case it was disabled (e.g. by -gnatD) + -- Do we really need to spend time generating xref in CodePeer + -- mode??? Consider setting Xref_Active to False. + + Xref_Active := True; + + -- Polling mode forced off, since it generates confusing junk + + Polling_Required := False; + + -- Set operating mode to Generate_Code to benefit from full front-end + -- expansion (e.g. generics). + + Operating_Mode := Generate_Code; + + -- We need SCIL generation of course + + Generate_SCIL := True; + + -- Enable assertions and debug pragmas, since they give CodePeer + -- valuable extra information. + + Assertions_Enabled := True; + Debug_Pragmas_Enabled := True; + + -- Disable all simple value propagation. This is an optimization + -- which is valuable for code optimization, and also for generation + -- of compiler warnings, but these are being turned off by default, + -- and CodePeer generates better messages (referencing original + -- variables) this way. + + Debug_Flag_MM := True; + + -- Set normal RM validity checking, and checking of IN OUT parameters + -- (this might give CodePeer more useful checks to analyze, to be + -- confirmed???). All other validity checking is turned off, since + -- this can generate very complex trees that only confuse CodePeer + -- and do not bring enough useful info. + + Reset_Validity_Check_Options; + Validity_Check_Default := True; + Validity_Check_In_Out_Params := True; + Validity_Check_In_Params := True; + + -- Turn off style check options since we are not interested in any + -- front-end warnings when we are getting CodePeer output. + + Reset_Style_Check_Options; + + -- Always perform semantics and generate ali files in CodePeer mode, + -- so that a gnatmake -c -k will proceed further when possible. + + Force_ALI_Tree_File := True; + Try_Semantics := True; + end if; + + -- Set Configurable_Run_Time mode if system.ads flag set + + if Targparm.Configurable_Run_Time_On_Target or Debug_Flag_YY then + Configurable_Run_Time_Mode := True; + end if; + + -- Set -gnatR3m mode if debug flag A set + + if Debug_Flag_AA then + Back_Annotate_Rep_Info := True; + List_Representation_Info := 1; + List_Representation_Info_Mechanisms := True; + end if; + + -- Force Target_Strict_Alignment true if debug flag -gnatd.a is set + + if Debug_Flag_Dot_A then + Ttypes.Target_Strict_Alignment := True; + end if; + + -- Disable static allocation of dispatch tables if -gnatd.t or if layout + -- is enabled. The front end's layout phase currently treats types that + -- have discriminant-dependent arrays as not being static even when a + -- discriminant constraint on the type is static, and this leads to + -- problems with subtypes of type Ada.Tags.Dispatch_Table_Wrapper. ??? + + if Debug_Flag_Dot_T or else Frontend_Layout_On_Target then + Static_Dispatch_Tables := False; + end if; + + -- Flip endian mode if -gnatd8 set + + if Debug_Flag_8 then + Ttypes.Bytes_Big_Endian := not Ttypes.Bytes_Big_Endian; + end if; + + -- Deal with forcing OpenVMS switches True if debug flag M is set, but + -- record the setting of Targparm.Open_VMS_On_Target in True_VMS_Target + -- before doing this, so we know if we are in real OpenVMS or not! + + Opt.True_VMS_Target := Targparm.OpenVMS_On_Target; + + if Debug_Flag_M then + Targparm.OpenVMS_On_Target := True; + Hostparm.OpenVMS := True; + end if; + + -- Activate front end layout if debug flag -gnatdF is set + + if Debug_Flag_FF then + Targparm.Frontend_Layout_On_Target := True; + end if; + + -- Set and check exception mechanism + + if Targparm.ZCX_By_Default_On_Target then + if Targparm.GCC_ZCX_Support_On_Target then + Exception_Mechanism := Back_End_Exceptions; + else + Osint.Fail ("Zero Cost Exceptions not supported on this target"); + end if; + end if; + + -- Set proper status for overflow checks. We turn on overflow checks if + -- -gnatp was not specified, and either -gnato is set or the back-end + -- takes care of overflow checks. Otherwise we suppress overflow checks + -- by default (since front end checks are expensive). + + if not Opt.Suppress_Checks + and then (Opt.Enable_Overflow_Checks + or else + (Targparm.Backend_Divide_Checks_On_Target + and + Targparm.Backend_Overflow_Checks_On_Target)) + then + Suppress_Options (Overflow_Check) := False; + else + Suppress_Options (Overflow_Check) := True; + end if; + + -- Set switch indicating if we can use N_Expression_With_Actions + + -- Debug flag -gnatd.X decisively sets usage on + + if Debug_Flag_Dot_XX then + Use_Expression_With_Actions := True; + + -- Debug flag -gnatd.Y decisively sets usage off + + elsif Debug_Flag_Dot_YY then + Use_Expression_With_Actions := False; + + -- Otherwise this feature is implemented, so we allow its use + + else + Use_Expression_With_Actions := True; + end if; + + -- Set switch indicating if back end can handle limited types, and + -- guarantee that no incorrect copies are made (e.g. in the context + -- of a conditional expression). + + -- Debug flag -gnatd.L decisively sets usage on + + if Debug_Flag_Dot_LL then + Back_End_Handles_Limited_Types := True; + + -- If no debug flag, usage off for AAMP, VM, SCIL cases + + elsif AAMP_On_Target + or else VM_Target /= No_VM + or else Generate_SCIL + then + Back_End_Handles_Limited_Types := False; + + -- Otherwise normal gcc back end, for now still turn flag off by + -- default, since there are unresolved problems in the front end. + + else + Back_End_Handles_Limited_Types := False; + end if; + end Adjust_Global_Switches; + + -------------------- + -- Check_Bad_Body -- + -------------------- + + procedure Check_Bad_Body is + Sname : Unit_Name_Type; + Src_Ind : Source_File_Index; + Fname : File_Name_Type; + + procedure Bad_Body_Error (Msg : String); + -- Issue message for bad body found + + -------------------- + -- Bad_Body_Error -- + -------------------- + + procedure Bad_Body_Error (Msg : String) is + begin + Error_Msg_N (Msg, Main_Unit_Node); + Error_Msg_File_1 := Fname; + Error_Msg_N ("remove incorrect body in file{!", Main_Unit_Node); + end Bad_Body_Error; + + -- Start of processing for Check_Bad_Body + + begin + -- Nothing to do if we are only checking syntax, because we don't know + -- enough to know if we require or forbid a body in this case. + + if Operating_Mode = Check_Syntax then + return; + end if; + + -- Check for body not allowed + + if (Main_Kind = N_Package_Declaration + and then not Body_Required (Main_Unit_Node)) + or else (Main_Kind = N_Generic_Package_Declaration + and then not Body_Required (Main_Unit_Node)) + or else Main_Kind = N_Package_Renaming_Declaration + or else Main_Kind = N_Subprogram_Renaming_Declaration + or else Nkind (Original_Node (Unit (Main_Unit_Node))) + in N_Generic_Instantiation + then + Sname := Unit_Name (Main_Unit); + + -- If we do not already have a body name, then get the body name + -- (but how can we have a body name here???) + + if not Is_Body_Name (Sname) then + Sname := Get_Body_Name (Sname); + end if; + + Fname := Get_File_Name (Sname, Subunit => False); + Src_Ind := Load_Source_File (Fname); + + -- Case where body is present and it is not a subunit. Exclude the + -- subunit case, because it has nothing to do with the package we are + -- compiling. It is illegal for a child unit and a subunit with the + -- same expanded name (RM 10.2(9)) to appear together in a partition, + -- but there is nothing to stop a compilation environment from having + -- both, and the test here simply allows that. If there is an attempt + -- to include both in a partition, this is diagnosed at bind time. In + -- Ada 83 mode this is not a warning case. + + -- Note: if weird file names are being used, we can have a situation + -- where the file name that supposedly contains body in fact contains + -- a spec, or we can't tell what it contains. Skip the error message + -- in these cases. + + -- Also ignore body that is nothing but pragma No_Body; (that's the + -- whole point of this pragma, to be used this way and to cause the + -- body file to be ignored in this context). + + if Src_Ind /= No_Source_File + and then Get_Expected_Unit_Type (Fname) = Expect_Body + and then not Source_File_Is_Subunit (Src_Ind) + and then not Source_File_Is_No_Body (Src_Ind) + then + Errout.Finalize (Last_Call => False); + + Error_Msg_Unit_1 := Sname; + + -- Ada 83 case of a package body being ignored. This is not an + -- error as far as the Ada 83 RM is concerned, but it is almost + -- certainly not what is wanted so output a warning. Give this + -- message only if there were no errors, since otherwise it may + -- be incorrect (we may have misinterpreted a junk spec as not + -- needing a body when it really does). + + if Main_Kind = N_Package_Declaration + and then Ada_Version = Ada_83 + and then Operating_Mode = Generate_Code + and then Distribution_Stub_Mode /= Generate_Caller_Stub_Body + and then not Compilation_Errors + then + Error_Msg_N + ("package $$ does not require a body?", Main_Unit_Node); + Error_Msg_File_1 := Fname; + Error_Msg_N ("body in file{? will be ignored", Main_Unit_Node); + + -- Ada 95 cases of a body file present when no body is + -- permitted. This we consider to be an error. + + else + -- For generic instantiations, we never allow a body + + if Nkind (Original_Node (Unit (Main_Unit_Node))) + in N_Generic_Instantiation + then + Bad_Body_Error + ("generic instantiation for $$ does not allow a body"); + + -- A library unit that is a renaming never allows a body + + elsif Main_Kind in N_Renaming_Declaration then + Bad_Body_Error + ("renaming declaration for $$ does not allow a body!"); + + -- Remaining cases are packages and generic packages. Here + -- we only do the test if there are no previous errors, + -- because if there are errors, they may lead us to + -- incorrectly believe that a package does not allow a body + -- when in fact it does. + + elsif not Compilation_Errors then + if Main_Kind = N_Package_Declaration then + Bad_Body_Error + ("package $$ does not allow a body!"); + + elsif Main_Kind = N_Generic_Package_Declaration then + Bad_Body_Error + ("generic package $$ does not allow a body!"); + end if; + end if; + + end if; + end if; + end if; + end Check_Bad_Body; + + ------------------------- + -- Check_Library_Items -- + ------------------------- + + -- Walk_Library_Items has plenty of assertions, so all we need to do is + -- call it, just for these assertions, not actually doing anything else. + + procedure Check_Library_Items is + + procedure Action (Item : Node_Id); + -- Action passed to Walk_Library_Items to do nothing + + ------------ + -- Action -- + ------------ + + procedure Action (Item : Node_Id) is + begin + null; + end Action; + + procedure Walk is new Sem.Walk_Library_Items (Action); + + -- Start of processing for Check_Library_Items + + begin + Walk; + end Check_Library_Items; + + -------------------- + -- Check_Rep_Info -- + -------------------- + + procedure Check_Rep_Info is + begin + if List_Representation_Info /= 0 + or else List_Representation_Info_Mechanisms + then + Set_Standard_Error; + Write_Eol; + Write_Str + ("cannot generate representation information, no code generated"); + Write_Eol; + Write_Eol; + Set_Standard_Output; + end if; + end Check_Rep_Info; + +-- Start of processing for Gnat1drv + +begin + -- This inner block is set up to catch assertion errors and constraint + -- errors. Since the code for handling these errors can cause another + -- exception to be raised (namely Unrecoverable_Error), we need two + -- nested blocks, so that the outer one handles unrecoverable error. + + begin + -- Initialize all packages. For the most part, these initialization + -- calls can be made in any order. Exceptions are as follows: + + -- Lib.Initialize need to be called before Scan_Compiler_Arguments, + -- because it initializes a table filled by Scan_Compiler_Arguments. + + Osint.Initialize; + Fmap.Reset_Tables; + Lib.Initialize; + Lib.Xref.Initialize; + Scan_Compiler_Arguments; + Osint.Add_Default_Search_Dirs; + + Nlists.Initialize; + Sinput.Initialize; + Sem.Initialize; + Exp_CG.Initialize; + Csets.Initialize; + Uintp.Initialize; + Urealp.Initialize; + Errout.Initialize; + SCOs.Initialize; + Snames.Initialize; + Stringt.Initialize; + Inline.Initialize; + Par_SCO.Initialize; + Sem_Ch8.Initialize; + Sem_Ch12.Initialize; + Sem_Ch13.Initialize; + Sem_Elim.Initialize; + Sem_Eval.Initialize; + Sem_Type.Init_Interp_Tables; + + -- Acquire target parameters from system.ads (source of package System) + + declare + use Sinput; + + S : Source_File_Index; + N : File_Name_Type; + + begin + Name_Buffer (1 .. 10) := "system.ads"; + Name_Len := 10; + N := Name_Find; + S := Load_Source_File (N); + + if S = No_Source_File then + Write_Line + ("fatal error, run-time library not installed correctly"); + Write_Line ("cannot locate file system.ads"); + raise Unrecoverable_Error; + + -- Remember source index of system.ads (which was read successfully) + + else + System_Source_File_Index := S; + end if; + + Targparm.Get_Target_Parameters + (System_Text => Source_Text (S), + Source_First => Source_First (S), + Source_Last => Source_Last (S)); + + -- Acquire configuration pragma information from Targparm + + Restrict.Restrictions := Targparm.Restrictions_On_Target; + end; + + Adjust_Global_Switches; + + -- Output copyright notice if full list mode unless we have a list + -- file, in which case we defer this so that it is output in the file + + if (Verbose_Mode or else (Full_List and then Full_List_File_Name = null)) + and then not Debug_Flag_7 + then + Write_Eol; + Write_Str ("GNAT "); + Write_Str (Gnat_Version_String); + Write_Eol; + Write_Str ("Copyright 1992-" & Current_Year + & ", Free Software Foundation, Inc."); + Write_Eol; + end if; + + -- Check we do not have more than one source file, this happens only in + -- the case where the driver is called directly, it cannot happen when + -- gnat1 is invoked from gcc in the normal case. + + if Osint.Number_Of_Files /= 1 then + Usage; + Write_Eol; + Osint.Fail ("you must provide one source file"); + + elsif Usage_Requested then + Usage; + end if; + + Original_Operating_Mode := Operating_Mode; + Frontend; + + -- Exit with errors if the main source could not be parsed + + if Sinput.Main_Source_File = No_Source_File then + Errout.Finalize (Last_Call => True); + Errout.Output_Messages; + Exit_Program (E_Errors); + end if; + + Main_Unit_Node := Cunit (Main_Unit); + Main_Kind := Nkind (Unit (Main_Unit_Node)); + Check_Bad_Body; + + -- Exit if compilation errors detected + + Errout.Finalize (Last_Call => False); + + if Compilation_Errors then + Treepr.Tree_Dump; + Sem_Ch13.Validate_Unchecked_Conversions; + Sem_Ch13.Validate_Address_Clauses; + Sem_Ch13.Validate_Independence; + Errout.Output_Messages; + Namet.Finalize; + + -- Generate ALI file if specially requested + + if Opt.Force_ALI_Tree_File then + Write_ALI (Object => False); + Tree_Gen; + end if; + + Errout.Finalize (Last_Call => True); + Exit_Program (E_Errors); + end if; + + -- Set Generate_Code on main unit and its spec. We do this even if are + -- not generating code, since Lib-Writ uses this to determine which + -- units get written in the ali file. + + Set_Generate_Code (Main_Unit); + + -- If we have a corresponding spec, and it comes from source or it is + -- not a generated spec for a child subprogram body, then we need object + -- code for the spec unit as well. + + if Nkind (Unit (Main_Unit_Node)) in N_Unit_Body + and then not Acts_As_Spec (Main_Unit_Node) + then + if Nkind (Unit (Main_Unit_Node)) = N_Subprogram_Body + and then not Comes_From_Source (Library_Unit (Main_Unit_Node)) + then + null; + else + Set_Generate_Code + (Get_Cunit_Unit_Number (Library_Unit (Main_Unit_Node))); + end if; + end if; + + -- Case of no code required to be generated, exit indicating no error + + if Original_Operating_Mode = Check_Syntax then + Treepr.Tree_Dump; + Errout.Finalize (Last_Call => True); + Errout.Output_Messages; + Tree_Gen; + Namet.Finalize; + Check_Rep_Info; + + -- Use a goto instead of calling Exit_Program so that finalization + -- occurs normally. + + goto End_Of_Program; + + elsif Original_Operating_Mode = Check_Semantics then + Back_End_Mode := Declarations_Only; + + -- All remaining cases are cases in which the user requested that code + -- be generated (i.e. no -gnatc or -gnats switch was used). Check if we + -- can in fact satisfy this request. + + -- Cannot generate code if someone has turned off code generation for + -- any reason at all. We will try to figure out a reason below. + + elsif Operating_Mode /= Generate_Code then + Back_End_Mode := Skip; + + -- We can generate code for a subprogram body unless there were missing + -- subunits. Note that we always generate code for all generic units (a + -- change from some previous versions of GNAT). + + elsif Main_Kind = N_Subprogram_Body and then not Subunits_Missing then + Back_End_Mode := Generate_Object; + + -- We can generate code for a package body unless there are subunits + -- missing (note that we always generate code for generic units, which + -- is a change from some earlier versions of GNAT). + + elsif Main_Kind = N_Package_Body and then not Subunits_Missing then + Back_End_Mode := Generate_Object; + + -- We can generate code for a package declaration or a subprogram + -- declaration only if it does not required a body. + + elsif Nkind_In (Main_Kind, + N_Package_Declaration, + N_Subprogram_Declaration) + and then + (not Body_Required (Main_Unit_Node) + or else + Distribution_Stub_Mode = Generate_Caller_Stub_Body) + then + Back_End_Mode := Generate_Object; + + -- We can generate code for a generic package declaration of a generic + -- subprogram declaration only if does not require a body. + + elsif Nkind_In (Main_Kind, N_Generic_Package_Declaration, + N_Generic_Subprogram_Declaration) + and then not Body_Required (Main_Unit_Node) + then + Back_End_Mode := Generate_Object; + + -- Compilation units that are renamings do not require bodies, so we can + -- generate code for them. + + elsif Nkind_In (Main_Kind, N_Package_Renaming_Declaration, + N_Subprogram_Renaming_Declaration) + then + Back_End_Mode := Generate_Object; + + -- Compilation units that are generic renamings do not require bodies + -- so we can generate code for them. + + elsif Main_Kind in N_Generic_Renaming_Declaration then + Back_End_Mode := Generate_Object; + + -- It's not an error to generate SCIL for e.g. a spec which has a body + + elsif CodePeer_Mode then + Back_End_Mode := Generate_Object; + + -- In all other cases (specs which have bodies, generics, and bodies + -- where subunits are missing), we cannot generate code and we generate + -- a warning message. Note that generic instantiations are gone at this + -- stage since they have been replaced by their instances. + + else + Back_End_Mode := Skip; + end if; + + -- At this stage Back_End_Mode is set to indicate if the backend should + -- be called to generate code. If it is Skip, then code generation has + -- been turned off, even though code was requested by the original + -- command. This is not an error from the user point of view, but it is + -- an error from the point of view of the gcc driver, so we must exit + -- with an error status. + + -- We generate an informative message (from the gcc point of view, it + -- is an error message, but from the users point of view this is not an + -- error, just a consequence of compiling something that cannot + -- generate code). + + if Back_End_Mode = Skip then + Set_Standard_Error; + Write_Str ("cannot generate code for "); + Write_Str ("file "); + Write_Name (Unit_File_Name (Main_Unit)); + + if Subunits_Missing then + Write_Str (" (missing subunits)"); + Write_Eol; + + -- Force generation of ALI file, for backward compatibility + + Opt.Force_ALI_Tree_File := True; + + elsif Main_Kind = N_Subunit then + Write_Str (" (subunit)"); + Write_Eol; + + -- Force generation of ALI file, for backward compatibility + + Opt.Force_ALI_Tree_File := True; + + elsif Main_Kind = N_Subprogram_Declaration then + Write_Str (" (subprogram spec)"); + Write_Eol; + + -- Generic package body in GNAT implementation mode + + elsif Main_Kind = N_Package_Body and then GNAT_Mode then + Write_Str (" (predefined generic)"); + Write_Eol; + + -- Force generation of ALI file, for backward compatibility + + Opt.Force_ALI_Tree_File := True; + + -- Only other case is a package spec + + else + Write_Str (" (package spec)"); + Write_Eol; + end if; + + Set_Standard_Output; + + Sem_Ch13.Validate_Unchecked_Conversions; + Sem_Ch13.Validate_Address_Clauses; + Sem_Ch13.Validate_Independence; + Errout.Finalize (Last_Call => True); + Errout.Output_Messages; + Treepr.Tree_Dump; + Tree_Gen; + + -- Generate ALI file if specially requested, or for missing subunits, + -- subunits or predefined generic. + + if Opt.Force_ALI_Tree_File then + Write_ALI (Object => False); + end if; + + Namet.Finalize; + Check_Rep_Info; + + -- Exit program with error indication, to kill object file + + Exit_Program (E_No_Code); + end if; + + -- In -gnatc mode, we only do annotation if -gnatt or -gnatR is also set + -- as indicated by Back_Annotate_Rep_Info being set to True. + + -- We don't call for annotations on a subunit, because to process those + -- the back-end requires that the parent(s) be properly compiled. + + -- Annotation is suppressed for targets where front-end layout is + -- enabled, because the front end determines representations. + + -- Annotation is also suppressed in the case of compiling for a VM, + -- since representations are largely symbolic there. + + if Back_End_Mode = Declarations_Only + and then (not (Back_Annotate_Rep_Info or Generate_SCIL) + or else Main_Kind = N_Subunit + or else Targparm.Frontend_Layout_On_Target + or else Targparm.VM_Target /= No_VM) + then + Sem_Ch13.Validate_Unchecked_Conversions; + Sem_Ch13.Validate_Address_Clauses; + Sem_Ch13.Validate_Independence; + Errout.Finalize (Last_Call => True); + Errout.Output_Messages; + Write_ALI (Object => False); + Tree_Dump; + Tree_Gen; + Namet.Finalize; + Check_Rep_Info; + return; + end if; + + -- Ensure that we properly register a dependency on system.ads, since + -- even if we do not semantically depend on this, Targparm has read + -- system parameters from the system.ads file. + + Lib.Writ.Ensure_System_Dependency; + + -- Add dependencies, if any, on preprocessing data file and on + -- preprocessing definition file(s). + + Prepcomp.Add_Dependencies; + + -- Back end needs to explicitly unlock tables it needs to touch + + Atree.Lock; + Elists.Lock; + Fname.UF.Lock; + Inline.Lock; + Lib.Lock; + Nlists.Lock; + Sem.Lock; + Sinput.Lock; + Namet.Lock; + Stringt.Lock; + + -- ???Check_Library_Items under control of a debug flag, because it + -- currently does not work if the -gnatn switch (back end inlining) is + -- used. + + if Debug_Flag_Dot_WW then + Check_Library_Items; + end if; + + -- Here we call the back end to generate the output code + + Generating_Code := True; + Back_End.Call_Back_End (Back_End_Mode); + + -- Once the backend is complete, we unlock the names table. This call + -- allows a few extra entries, needed for example for the file name for + -- the library file output. + + Namet.Unlock; + + -- Generate the call-graph output of dispatching calls + + Exp_CG.Generate_CG_Output; + + -- Validate unchecked conversions (using the values for size and + -- alignment annotated by the backend where possible). + + Sem_Ch13.Validate_Unchecked_Conversions; + + -- Validate address clauses (again using alignment values annotated + -- by the backend where possible). + + Sem_Ch13.Validate_Address_Clauses; + + -- Validate independence pragmas (again using values annotated by + -- the back end for component layout etc.) + + Sem_Ch13.Validate_Independence; + + -- Now we complete output of errors, rep info and the tree info. These + -- are delayed till now, since it is perfectly possible for gigi to + -- generate errors, modify the tree (in particular by setting flags + -- indicating that elaboration is required, and also to back annotate + -- representation information for List_Rep_Info. + + Errout.Finalize (Last_Call => True); + Errout.Output_Messages; + List_Rep_Info; + + -- Only write the library if the backend did not generate any error + -- messages. Otherwise signal errors to the driver program so that + -- there will be no attempt to generate an object file. + + if Compilation_Errors then + Treepr.Tree_Dump; + Exit_Program (E_Errors); + end if; + + Write_ALI (Object => (Back_End_Mode = Generate_Object)); + + -- Generate ASIS tree after writing the ALI file, since in ASIS mode, + -- Write_ALI may in fact result in further tree decoration from the + -- original tree file. Note that we dump the tree just before generating + -- it, so that the dump will exactly reflect what is written out. + + Treepr.Tree_Dump; + Tree_Gen; + + -- Finalize name table and we are all done + + Namet.Finalize; + + exception + -- Handle fatal internal compiler errors + + when Rtsfind.RE_Not_Available => + Comperr.Compiler_Abort ("RE_Not_Available"); + + when System.Assertions.Assert_Failure => + Comperr.Compiler_Abort ("Assert_Failure"); + + when Constraint_Error => + Comperr.Compiler_Abort ("Constraint_Error"); + + when Program_Error => + Comperr.Compiler_Abort ("Program_Error"); + + when Storage_Error => + + -- Assume this is a bug. If it is real, the message will in any case + -- say Storage_Error, giving a strong hint! + + Comperr.Compiler_Abort ("Storage_Error"); + end; + + <> + null; + + -- The outer exception handles an unrecoverable error + +exception + when Unrecoverable_Error => + Errout.Finalize (Last_Call => True); + Errout.Output_Messages; + + Set_Standard_Error; + Write_Str ("compilation abandoned"); + Write_Eol; + + Set_Standard_Output; + Source_Dump; + Tree_Dump; + Exit_Program (E_Errors); + +end Gnat1drv; diff --git a/gcc/ada/gnat1drv.ads b/gcc/ada/gnat1drv.ads new file mode 100644 index 000000000..f6b456c4e --- /dev/null +++ b/gcc/ada/gnat1drv.ads @@ -0,0 +1,32 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T 1 D R V -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Main procedure for the GNAT compiler + +-- This driver processes a single main unit, generating output object code + +-- file.ad[sb] ---> front-end ---> back-end ---> file.o + +procedure Gnat1drv; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi new file mode 100644 index 000000000..40e3c9142 --- /dev/null +++ b/gcc/ada/gnat_rm.texi @@ -0,0 +1,17952 @@ +\input texinfo @c -*-texinfo-*- + +@c %**start of header + +@c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo +@c o +@c GNAT DOCUMENTATION o +@c o +@c G N A T _ RM o +@c o +@c GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). o +@c o +@c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo + +@setfilename gnat_rm.info + +@copying +Copyright @copyright{} 1995-2008, Free Software Foundation, Inc. + +Permission is granted to copy, distribute and/or modify this document +under the terms of the GNU Free Documentation License, Version 1.3 or +any later version published by the Free Software Foundation; with no +Invariant Sections, with the Front-Cover Texts being ``GNAT Reference +Manual'', and with no Back-Cover Texts. A copy of the license is +included in the section entitled ``GNU Free Documentation License''. +@end copying + +@set EDITION GNAT +@set DEFAULTLANGUAGEVERSION Ada 2005 +@set NONDEFAULTLANGUAGEVERSION Ada 95 + +@settitle GNAT Reference Manual + +@setchapternewpage odd +@syncodeindex fn cp + +@include gcc-common.texi + +@dircategory GNU Ada tools +@direntry +* GNAT Reference Manual: (gnat_rm). Reference Manual for GNU Ada tools. +@end direntry + +@titlepage +@title GNAT Reference Manual +@subtitle GNAT, The GNU Ada Compiler +@versionsubtitle +@author AdaCore +@page +@vskip 0pt plus 1filll + +@insertcopying + +@end titlepage + +@ifnottex +@node Top, About This Guide, (dir), (dir) +@top GNAT Reference Manual + +@noindent +GNAT Reference Manual + +@noindent +GNAT, The GNU Ada Compiler@* +GCC version @value{version-GCC}@* + +@noindent +AdaCore + +@menu +* About This Guide:: +* Implementation Defined Pragmas:: +* Implementation Defined Attributes:: +* Implementation Advice:: +* Implementation Defined Characteristics:: +* Intrinsic Subprograms:: +* Representation Clauses and Pragmas:: +* Standard Library Routines:: +* The Implementation of Standard I/O:: +* The GNAT Library:: +* Interfacing to Other Languages:: +* Specialized Needs Annexes:: +* Implementation of Specific Ada Features:: +* Implementation of Ada 2012 Features:: +* Obsolescent Features:: +* GNU Free Documentation License:: +* Index:: + + --- The Detailed Node Listing --- + +About This Guide + +* What This Reference Manual Contains:: +* Related Information:: + +Implementation Defined Pragmas + +* Pragma Abort_Defer:: +* Pragma Ada_83:: +* Pragma Ada_95:: +* Pragma Ada_05:: +* Pragma Ada_2005:: +* Pragma Ada_12:: +* Pragma Ada_2012:: +* Pragma Annotate:: +* Pragma Assert:: +* Pragma Assume_No_Invalid_Values:: +* Pragma Ast_Entry:: +* Pragma C_Pass_By_Copy:: +* Pragma Check:: +* Pragma Check_Name:: +* Pragma Check_Policy:: +* Pragma Comment:: +* Pragma Common_Object:: +* Pragma Compile_Time_Error:: +* Pragma Compile_Time_Warning:: +* Pragma Compiler_Unit:: +* Pragma Complete_Representation:: +* Pragma Complex_Representation:: +* Pragma Component_Alignment:: +* Pragma Convention_Identifier:: +* Pragma CPP_Class:: +* Pragma CPP_Constructor:: +* Pragma CPP_Virtual:: +* Pragma CPP_Vtable:: +* Pragma Debug:: +* Pragma Debug_Policy:: +* Pragma Detect_Blocking:: +* Pragma Elaboration_Checks:: +* Pragma Eliminate:: +* Pragma Export_Exception:: +* Pragma Export_Function:: +* Pragma Export_Object:: +* Pragma Export_Procedure:: +* Pragma Export_Value:: +* Pragma Export_Valued_Procedure:: +* Pragma Extend_System:: +* Pragma Extensions_Allowed:: +* Pragma External:: +* Pragma External_Name_Casing:: +* Pragma Fast_Math:: +* Pragma Favor_Top_Level:: +* Pragma Finalize_Storage_Only:: +* Pragma Float_Representation:: +* Pragma Ident:: +* Pragma Implemented:: +* Pragma Implicit_Packing:: +* Pragma Import_Exception:: +* Pragma Import_Function:: +* Pragma Import_Object:: +* Pragma Import_Procedure:: +* Pragma Import_Valued_Procedure:: +* Pragma Initialize_Scalars:: +* Pragma Inline_Always:: +* Pragma Inline_Generic:: +* Pragma Interface:: +* Pragma Interface_Name:: +* Pragma Interrupt_Handler:: +* Pragma Interrupt_State:: +* Pragma Invariant:: +* Pragma Keep_Names:: +* Pragma License:: +* Pragma Link_With:: +* Pragma Linker_Alias:: +* Pragma Linker_Constructor:: +* Pragma Linker_Destructor:: +* Pragma Linker_Section:: +* Pragma Long_Float:: +* Pragma Machine_Attribute:: +* Pragma Main:: +* Pragma Main_Storage:: +* Pragma No_Body:: +* Pragma No_Return:: +* Pragma No_Strict_Aliasing :: +* Pragma Normalize_Scalars:: +* Pragma Obsolescent:: +* Pragma Optimize_Alignment:: +* Pragma Ordered:: +* Pragma Passive:: +* Pragma Persistent_BSS:: +* Pragma Polling:: +* Pragma Postcondition:: +* Pragma Precondition:: +* Pragma Profile (Ravenscar):: +* Pragma Profile (Restricted):: +* Pragma Psect_Object:: +* Pragma Pure_Function:: +* Pragma Restriction_Warnings:: +* Pragma Shared:: +* Pragma Short_Circuit_And_Or:: +* Pragma Short_Descriptors:: +* Pragma Source_File_Name:: +* Pragma Source_File_Name_Project:: +* Pragma Source_Reference:: +* Pragma Stream_Convert:: +* Pragma Style_Checks:: +* Pragma Subtitle:: +* Pragma Suppress:: +* Pragma Suppress_All:: +* Pragma Suppress_Exception_Locations:: +* Pragma Suppress_Initialization:: +* Pragma Task_Info:: +* Pragma Task_Name:: +* Pragma Task_Storage:: +* Pragma Thread_Local_Storage:: +* Pragma Time_Slice:: +* Pragma Title:: +* Pragma Unchecked_Union:: +* Pragma Unimplemented_Unit:: +* Pragma Universal_Aliasing :: +* Pragma Universal_Data:: +* Pragma Unmodified:: +* Pragma Unreferenced:: +* Pragma Unreferenced_Objects:: +* Pragma Unreserve_All_Interrupts:: +* Pragma Unsuppress:: +* Pragma Use_VADS_Size:: +* Pragma Validity_Checks:: +* Pragma Volatile:: +* Pragma Warnings:: +* Pragma Weak_External:: +* Pragma Wide_Character_Encoding:: + +Implementation Defined Attributes + +* Abort_Signal:: +* Address_Size:: +* Asm_Input:: +* Asm_Output:: +* AST_Entry:: +* Bit:: +* Bit_Position:: +* Compiler_Version:: +* Code_Address:: +* Default_Bit_Order:: +* Elaborated:: +* Elab_Body:: +* Elab_Spec:: +* Emax:: +* Enabled:: +* Enum_Rep:: +* Enum_Val:: +* Epsilon:: +* Fixed_Value:: +* Has_Access_Values:: +* Has_Discriminants:: +* Img:: +* Integer_Value:: +* Invalid_Value:: +* Large:: +* Machine_Size:: +* Mantissa:: +* Max_Interrupt_Priority:: +* Max_Priority:: +* Maximum_Alignment:: +* Mechanism_Code:: +* Null_Parameter:: +* Object_Size:: +* Old:: +* Passed_By_Reference:: +* Pool_Address:: +* Range_Length:: +* Result:: +* Safe_Emax:: +* Safe_Large:: +* Small:: +* Storage_Unit:: +* Stub_Type:: +* Target_Name:: +* Tick:: +* To_Address:: +* Type_Class:: +* UET_Address:: +* Unconstrained_Array:: +* Universal_Literal_String:: +* Unrestricted_Access:: +* VADS_Size:: +* Value_Size:: +* Wchar_T_Size:: +* Word_Size:: + +The Implementation of Standard I/O + +* Standard I/O Packages:: +* FORM Strings:: +* Direct_IO:: +* Sequential_IO:: +* Text_IO:: +* Wide_Text_IO:: +* Wide_Wide_Text_IO:: +* Stream_IO:: +* Text Translation:: +* Shared Files:: +* Filenames encoding:: +* Open Modes:: +* Operations on C Streams:: +* Interfacing to C Streams:: + +The GNAT Library + +* Ada.Characters.Latin_9 (a-chlat9.ads):: +* Ada.Characters.Wide_Latin_1 (a-cwila1.ads):: +* Ada.Characters.Wide_Latin_9 (a-cwila9.ads):: +* Ada.Characters.Wide_Wide_Latin_1 (a-chzla1.ads):: +* Ada.Characters.Wide_Wide_Latin_9 (a-chzla9.ads):: +* Ada.Command_Line.Environment (a-colien.ads):: +* Ada.Command_Line.Remove (a-colire.ads):: +* Ada.Command_Line.Response_File (a-clrefi.ads):: +* Ada.Direct_IO.C_Streams (a-diocst.ads):: +* Ada.Exceptions.Is_Null_Occurrence (a-einuoc.ads):: +* Ada.Exceptions.Last_Chance_Handler (a-elchha.ads):: +* Ada.Exceptions.Traceback (a-exctra.ads):: +* Ada.Sequential_IO.C_Streams (a-siocst.ads):: +* Ada.Streams.Stream_IO.C_Streams (a-ssicst.ads):: +* Ada.Strings.Unbounded.Text_IO (a-suteio.ads):: +* Ada.Strings.Wide_Unbounded.Wide_Text_IO (a-swuwti.ads):: +* Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO (a-szuzti.ads):: +* Ada.Text_IO.C_Streams (a-tiocst.ads):: +* Ada.Text_IO.Reset_Standard_Files (a-tirsfi.ads):: +* Ada.Wide_Characters.Unicode (a-wichun.ads):: +* Ada.Wide_Text_IO.C_Streams (a-wtcstr.ads):: +* Ada.Wide_Text_IO.Reset_Standard_Files (a-wrstfi.ads):: +* Ada.Wide_Wide_Characters.Unicode (a-zchuni.ads):: +* Ada.Wide_Wide_Text_IO.C_Streams (a-ztcstr.ads):: +* Ada.Wide_Wide_Text_IO.Reset_Standard_Files (a-zrstfi.ads):: +* GNAT.Altivec (g-altive.ads):: +* GNAT.Altivec.Conversions (g-altcon.ads):: +* GNAT.Altivec.Vector_Operations (g-alveop.ads):: +* GNAT.Altivec.Vector_Types (g-alvety.ads):: +* GNAT.Altivec.Vector_Views (g-alvevi.ads):: +* GNAT.Array_Split (g-arrspl.ads):: +* GNAT.AWK (g-awk.ads):: +* GNAT.Bounded_Buffers (g-boubuf.ads):: +* GNAT.Bounded_Mailboxes (g-boumai.ads):: +* GNAT.Bubble_Sort (g-bubsor.ads):: +* GNAT.Bubble_Sort_A (g-busora.ads):: +* GNAT.Bubble_Sort_G (g-busorg.ads):: +* GNAT.Byte_Order_Mark (g-byorma.ads):: +* GNAT.Byte_Swapping (g-bytswa.ads):: +* GNAT.Calendar (g-calend.ads):: +* GNAT.Calendar.Time_IO (g-catiio.ads):: +* GNAT.Case_Util (g-casuti.ads):: +* GNAT.CGI (g-cgi.ads):: +* GNAT.CGI.Cookie (g-cgicoo.ads):: +* GNAT.CGI.Debug (g-cgideb.ads):: +* GNAT.Command_Line (g-comlin.ads):: +* GNAT.Compiler_Version (g-comver.ads):: +* GNAT.Ctrl_C (g-ctrl_c.ads):: +* GNAT.CRC32 (g-crc32.ads):: +* GNAT.Current_Exception (g-curexc.ads):: +* GNAT.Debug_Pools (g-debpoo.ads):: +* GNAT.Debug_Utilities (g-debuti.ads):: +* GNAT.Decode_String (g-decstr.ads):: +* GNAT.Decode_UTF8_String (g-deutst.ads):: +* GNAT.Directory_Operations (g-dirope.ads):: +* GNAT.Directory_Operations.Iteration (g-diopit.ads):: +* GNAT.Dynamic_HTables (g-dynhta.ads):: +* GNAT.Dynamic_Tables (g-dyntab.ads):: +* GNAT.Encode_String (g-encstr.ads):: +* GNAT.Encode_UTF8_String (g-enutst.ads):: +* GNAT.Exception_Actions (g-excact.ads):: +* GNAT.Exception_Traces (g-exctra.ads):: +* GNAT.Exceptions (g-except.ads):: +* GNAT.Expect (g-expect.ads):: +* GNAT.Float_Control (g-flocon.ads):: +* GNAT.Heap_Sort (g-heasor.ads):: +* GNAT.Heap_Sort_A (g-hesora.ads):: +* GNAT.Heap_Sort_G (g-hesorg.ads):: +* GNAT.HTable (g-htable.ads):: +* GNAT.IO (g-io.ads):: +* GNAT.IO_Aux (g-io_aux.ads):: +* GNAT.Lock_Files (g-locfil.ads):: +* GNAT.MBBS_Discrete_Random (g-mbdira.ads):: +* GNAT.MBBS_Float_Random (g-mbflra.ads):: +* GNAT.MD5 (g-md5.ads):: +* GNAT.Memory_Dump (g-memdum.ads):: +* GNAT.Most_Recent_Exception (g-moreex.ads):: +* GNAT.OS_Lib (g-os_lib.ads):: +* GNAT.Perfect_Hash_Generators (g-pehage.ads):: +* GNAT.Random_Numbers (g-rannum.ads):: +* GNAT.Regexp (g-regexp.ads):: +* GNAT.Registry (g-regist.ads):: +* GNAT.Regpat (g-regpat.ads):: +* GNAT.Secondary_Stack_Info (g-sestin.ads):: +* GNAT.Semaphores (g-semaph.ads):: +* GNAT.Serial_Communications (g-sercom.ads):: +* GNAT.SHA1 (g-sha1.ads):: +* GNAT.SHA224 (g-sha224.ads):: +* GNAT.SHA256 (g-sha256.ads):: +* GNAT.SHA384 (g-sha384.ads):: +* GNAT.SHA512 (g-sha512.ads):: +* GNAT.Signals (g-signal.ads):: +* GNAT.Sockets (g-socket.ads):: +* GNAT.Source_Info (g-souinf.ads):: +* GNAT.Spelling_Checker (g-speche.ads):: +* GNAT.Spelling_Checker_Generic (g-spchge.ads):: +* GNAT.Spitbol.Patterns (g-spipat.ads):: +* GNAT.Spitbol (g-spitbo.ads):: +* GNAT.Spitbol.Table_Boolean (g-sptabo.ads):: +* GNAT.Spitbol.Table_Integer (g-sptain.ads):: +* GNAT.Spitbol.Table_VString (g-sptavs.ads):: +* GNAT.SSE (g-sse.ads):: +* GNAT.SSE.Vector_Types (g-ssvety.ads):: +* GNAT.Strings (g-string.ads):: +* GNAT.String_Split (g-strspl.ads):: +* GNAT.Table (g-table.ads):: +* GNAT.Task_Lock (g-tasloc.ads):: +* GNAT.Threads (g-thread.ads):: +* GNAT.Time_Stamp (g-timsta.ads):: +* GNAT.Traceback (g-traceb.ads):: +* GNAT.Traceback.Symbolic (g-trasym.ads):: +* GNAT.UTF_32 (g-utf_32.ads):: +* GNAT.UTF_32_Spelling_Checker (g-u3spch.ads):: +* GNAT.Wide_Spelling_Checker (g-wispch.ads):: +* GNAT.Wide_String_Split (g-wistsp.ads):: +* GNAT.Wide_Wide_Spelling_Checker (g-zspche.ads):: +* GNAT.Wide_Wide_String_Split (g-zistsp.ads):: +* Interfaces.C.Extensions (i-cexten.ads):: +* Interfaces.C.Streams (i-cstrea.ads):: +* Interfaces.CPP (i-cpp.ads):: +* Interfaces.Packed_Decimal (i-pacdec.ads):: +* Interfaces.VxWorks (i-vxwork.ads):: +* Interfaces.VxWorks.IO (i-vxwoio.ads):: +* System.Address_Image (s-addima.ads):: +* System.Assertions (s-assert.ads):: +* System.Memory (s-memory.ads):: +* System.Partition_Interface (s-parint.ads):: +* System.Pool_Global (s-pooglo.ads):: +* System.Pool_Local (s-pooloc.ads):: +* System.Restrictions (s-restri.ads):: +* System.Rident (s-rident.ads):: +* System.Strings.Stream_Ops (s-ststop.ads):: +* System.Task_Info (s-tasinf.ads):: +* System.Wch_Cnv (s-wchcnv.ads):: +* System.Wch_Con (s-wchcon.ads):: + +Text_IO + +* Text_IO Stream Pointer Positioning:: +* Text_IO Reading and Writing Non-Regular Files:: +* Get_Immediate:: +* Treating Text_IO Files as Streams:: +* Text_IO Extensions:: +* Text_IO Facilities for Unbounded Strings:: + +Wide_Text_IO + +* Wide_Text_IO Stream Pointer Positioning:: +* Wide_Text_IO Reading and Writing Non-Regular Files:: + +Wide_Wide_Text_IO + +* Wide_Wide_Text_IO Stream Pointer Positioning:: +* Wide_Wide_Text_IO Reading and Writing Non-Regular Files:: + +Interfacing to Other Languages + +* Interfacing to C:: +* Interfacing to C++:: +* Interfacing to COBOL:: +* Interfacing to Fortran:: +* Interfacing to non-GNAT Ada code:: + +Specialized Needs Annexes + +Implementation of Specific Ada Features +* Machine Code Insertions:: +* GNAT Implementation of Tasking:: +* GNAT Implementation of Shared Passive Packages:: +* Code Generation for Array Aggregates:: +* The Size of Discriminated Records with Default Discriminants:: +* Strict Conformance to the Ada Reference Manual:: + +Implementation of Ada 2012 Features + +Obsolescent Features + +GNU Free Documentation License + +Index +@end menu + +@end ifnottex + +@node About This Guide +@unnumbered About This Guide + +@noindent +This manual contains useful information in writing programs using the +@value{EDITION} compiler. It includes information on implementation dependent +characteristics of @value{EDITION}, including all the information required by +Annex M of the Ada language standard. + +@value{EDITION} implements Ada 95 and Ada 2005, and it may also be invoked in +Ada 83 compatibility mode. +By default, @value{EDITION} assumes @value{DEFAULTLANGUAGEVERSION}, +but you can override with a compiler switch +to explicitly specify the language version. +(Please refer to @ref{Compiling Different Versions of Ada,,, gnat_ugn, +@value{EDITION} User's Guide}, for details on these switches.) +Throughout this manual, references to ``Ada'' without a year suffix +apply to both the Ada 95 and Ada 2005 versions of the language. + +Ada is designed to be highly portable. +In general, a program will have the same effect even when compiled by +different compilers on different platforms. +However, since Ada is designed to be used in a +wide variety of applications, it also contains a number of system +dependent features to be used in interfacing to the external world. +@cindex Implementation-dependent features +@cindex Portability + +Note: Any program that makes use of implementation-dependent features +may be non-portable. You should follow good programming practice and +isolate and clearly document any sections of your program that make use +of these features in a non-portable manner. + +@ifset PROEDITION +For ease of exposition, ``GNAT Pro'' will be referred to simply as +``GNAT'' in the remainder of this document. +@end ifset + +@menu +* What This Reference Manual Contains:: +* Conventions:: +* Related Information:: +@end menu + +@node What This Reference Manual Contains +@unnumberedsec What This Reference Manual Contains + +@noindent +This reference manual contains the following chapters: + +@itemize @bullet +@item +@ref{Implementation Defined Pragmas}, lists GNAT implementation-dependent +pragmas, which can be used to extend and enhance the functionality of the +compiler. + +@item +@ref{Implementation Defined Attributes}, lists GNAT +implementation-dependent attributes which can be used to extend and +enhance the functionality of the compiler. + +@item +@ref{Implementation Advice}, provides information on generally +desirable behavior which are not requirements that all compilers must +follow since it cannot be provided on all systems, or which may be +undesirable on some systems. + +@item +@ref{Implementation Defined Characteristics}, provides a guide to +minimizing implementation dependent features. + +@item +@ref{Intrinsic Subprograms}, describes the intrinsic subprograms +implemented by GNAT, and how they can be imported into user +application programs. + +@item +@ref{Representation Clauses and Pragmas}, describes in detail the +way that GNAT represents data, and in particular the exact set +of representation clauses and pragmas that is accepted. + +@item +@ref{Standard Library Routines}, provides a listing of packages and a +brief description of the functionality that is provided by Ada's +extensive set of standard library routines as implemented by GNAT@. + +@item +@ref{The Implementation of Standard I/O}, details how the GNAT +implementation of the input-output facilities. + +@item +@ref{The GNAT Library}, is a catalog of packages that complement +the Ada predefined library. + +@item +@ref{Interfacing to Other Languages}, describes how programs +written in Ada using GNAT can be interfaced to other programming +languages. + +@ref{Specialized Needs Annexes}, describes the GNAT implementation of all +of the specialized needs annexes. + +@item +@ref{Implementation of Specific Ada Features}, discusses issues related +to GNAT's implementation of machine code insertions, tasking, and several +other features. + +@item +@ref{Implementation of Ada 2012 Features}, describes the status of the +GNAT implementation of the Ada 2012 language standard. + +@item +@ref{Obsolescent Features} documents implementation dependent features, +including pragmas and attributes, which are considered obsolescent, since +there are other preferred ways of achieving the same results. These +obsolescent forms are retained for backwards compatibility. + +@end itemize + +@cindex Ada 95 Language Reference Manual +@cindex Ada 2005 Language Reference Manual +@noindent +This reference manual assumes a basic familiarity with the Ada 95 language, as +described in the International Standard ANSI/ISO/IEC-8652:1995, +January 1995. +It does not require knowledge of the new features introduced by Ada 2005, +(officially known as ISO/IEC 8652:1995 with Technical Corrigendum 1 +and Amendment 1). +Both reference manuals are included in the GNAT documentation +package. + +@node Conventions +@unnumberedsec Conventions +@cindex Conventions, typographical +@cindex Typographical conventions + +@noindent +Following are examples of the typographical and graphic conventions used +in this guide: + +@itemize @bullet +@item +@code{Functions}, @code{utility program names}, @code{standard names}, +and @code{classes}. + +@item +@code{Option flags} + +@item +@file{File names}, @samp{button names}, and @samp{field names}. + +@item +@code{Variables}, @env{environment variables}, and @var{metasyntactic +variables}. + +@item +@emph{Emphasis}. + +@item +[optional information or parameters] + +@item +Examples are described by text +@smallexample +and then shown this way. +@end smallexample +@end itemize + +@noindent +Commands that are entered by the user are preceded in this manual by the +characters @samp{$ } (dollar sign followed by space). If your system uses this +sequence as a prompt, then the commands will appear exactly as you see them +in the manual. If your system uses some other prompt, then the command will +appear with the @samp{$} replaced by whatever prompt character you are using. + +@node Related Information +@unnumberedsec Related Information +@noindent +See the following documents for further information on GNAT: + +@itemize @bullet +@item +@xref{Top, @value{EDITION} User's Guide, About This Guide, gnat_ugn, +@value{EDITION} User's Guide}, which provides information on how to use the +GNAT compiler system. + +@item +@cite{Ada 95 Reference Manual}, which contains all reference +material for the Ada 95 programming language. + +@item +@cite{Ada 95 Annotated Reference Manual}, which is an annotated version +of the Ada 95 standard. The annotations describe +detailed aspects of the design decision, and in particular contain useful +sections on Ada 83 compatibility. + +@item +@cite{Ada 2005 Reference Manual}, which contains all reference +material for the Ada 2005 programming language. + +@item +@cite{Ada 2005 Annotated Reference Manual}, which is an annotated version +of the Ada 2005 standard. The annotations describe +detailed aspects of the design decision, and in particular contain useful +sections on Ada 83 and Ada 95 compatibility. + +@item +@cite{DEC Ada, Technical Overview and Comparison on DIGITAL Platforms}, +which contains specific information on compatibility between GNAT and +DEC Ada 83 systems. + +@item +@cite{DEC Ada, Language Reference Manual, part number AA-PYZAB-TK} which +describes in detail the pragmas and attributes provided by the DEC Ada 83 +compiler system. + +@end itemize + +@node Implementation Defined Pragmas +@chapter Implementation Defined Pragmas + +@noindent +Ada defines a set of pragmas that can be used to supply additional +information to the compiler. These language defined pragmas are +implemented in GNAT and work as described in the Ada Reference Manual. + +In addition, Ada allows implementations to define additional pragmas +whose meaning is defined by the implementation. GNAT provides a number +of these implementation-defined pragmas, which can be used to extend +and enhance the functionality of the compiler. This section of the GNAT +Reference Manual describes these additional pragmas. + +Note that any program using these pragmas might not be portable to other +compilers (although GNAT implements this set of pragmas on all +platforms). Therefore if portability to other compilers is an important +consideration, the use of these pragmas should be minimized. + +@menu +* Pragma Abort_Defer:: +* Pragma Ada_83:: +* Pragma Ada_95:: +* Pragma Ada_05:: +* Pragma Ada_2005:: +* Pragma Ada_12:: +* Pragma Ada_2012:: +* Pragma Annotate:: +* Pragma Assert:: +* Pragma Assume_No_Invalid_Values:: +* Pragma Ast_Entry:: +* Pragma C_Pass_By_Copy:: +* Pragma Check:: +* Pragma Check_Name:: +* Pragma Check_Policy:: +* Pragma Comment:: +* Pragma Common_Object:: +* Pragma Compile_Time_Error:: +* Pragma Compile_Time_Warning:: +* Pragma Compiler_Unit:: +* Pragma Complete_Representation:: +* Pragma Complex_Representation:: +* Pragma Component_Alignment:: +* Pragma Convention_Identifier:: +* Pragma CPP_Class:: +* Pragma CPP_Constructor:: +* Pragma CPP_Virtual:: +* Pragma CPP_Vtable:: +* Pragma Debug:: +* Pragma Debug_Policy:: +* Pragma Detect_Blocking:: +* Pragma Elaboration_Checks:: +* Pragma Eliminate:: +* Pragma Export_Exception:: +* Pragma Export_Function:: +* Pragma Export_Object:: +* Pragma Export_Procedure:: +* Pragma Export_Value:: +* Pragma Export_Valued_Procedure:: +* Pragma Extend_System:: +* Pragma Extensions_Allowed:: +* Pragma External:: +* Pragma External_Name_Casing:: +* Pragma Fast_Math:: +* Pragma Favor_Top_Level:: +* Pragma Finalize_Storage_Only:: +* Pragma Float_Representation:: +* Pragma Ident:: +* Pragma Implemented:: +* Pragma Implicit_Packing:: +* Pragma Import_Exception:: +* Pragma Import_Function:: +* Pragma Import_Object:: +* Pragma Import_Procedure:: +* Pragma Import_Valued_Procedure:: +* Pragma Initialize_Scalars:: +* Pragma Inline_Always:: +* Pragma Inline_Generic:: +* Pragma Interface:: +* Pragma Interface_Name:: +* Pragma Interrupt_Handler:: +* Pragma Interrupt_State:: +* Pragma Invariant:: +* Pragma Keep_Names:: +* Pragma License:: +* Pragma Link_With:: +* Pragma Linker_Alias:: +* Pragma Linker_Constructor:: +* Pragma Linker_Destructor:: +* Pragma Linker_Section:: +* Pragma Long_Float:: +* Pragma Machine_Attribute:: +* Pragma Main:: +* Pragma Main_Storage:: +* Pragma No_Body:: +* Pragma No_Return:: +* Pragma No_Strict_Aliasing:: +* Pragma Normalize_Scalars:: +* Pragma Obsolescent:: +* Pragma Optimize_Alignment:: +* Pragma Ordered:: +* Pragma Passive:: +* Pragma Persistent_BSS:: +* Pragma Polling:: +* Pragma Postcondition:: +* Pragma Precondition:: +* Pragma Profile (Ravenscar):: +* Pragma Profile (Restricted):: +* Pragma Psect_Object:: +* Pragma Pure_Function:: +* Pragma Restriction_Warnings:: +* Pragma Shared:: +* Pragma Short_Circuit_And_Or:: +* Pragma Short_Descriptors:: +* Pragma Source_File_Name:: +* Pragma Source_File_Name_Project:: +* Pragma Source_Reference:: +* Pragma Stream_Convert:: +* Pragma Style_Checks:: +* Pragma Subtitle:: +* Pragma Suppress:: +* Pragma Suppress_All:: +* Pragma Suppress_Exception_Locations:: +* Pragma Suppress_Initialization:: +* Pragma Task_Info:: +* Pragma Task_Name:: +* Pragma Task_Storage:: +* Pragma Thread_Local_Storage:: +* Pragma Time_Slice:: +* Pragma Title:: +* Pragma Unchecked_Union:: +* Pragma Unimplemented_Unit:: +* Pragma Universal_Aliasing :: +* Pragma Universal_Data:: +* Pragma Unmodified:: +* Pragma Unreferenced:: +* Pragma Unreferenced_Objects:: +* Pragma Unreserve_All_Interrupts:: +* Pragma Unsuppress:: +* Pragma Use_VADS_Size:: +* Pragma Validity_Checks:: +* Pragma Volatile:: +* Pragma Warnings:: +* Pragma Weak_External:: +* Pragma Wide_Character_Encoding:: +@end menu + +@node Pragma Abort_Defer +@unnumberedsec Pragma Abort_Defer +@findex Abort_Defer +@cindex Deferring aborts +@noindent +Syntax: +@smallexample +pragma Abort_Defer; +@end smallexample + +@noindent +This pragma must appear at the start of the statement sequence of a +handled sequence of statements (right after the @code{begin}). It has +the effect of deferring aborts for the sequence of statements (but not +for the declarations or handlers, if any, associated with this statement +sequence). + +@node Pragma Ada_83 +@unnumberedsec Pragma Ada_83 +@findex Ada_83 +@noindent +Syntax: +@smallexample @c ada +pragma Ada_83; +@end smallexample + +@noindent +A configuration pragma that establishes Ada 83 mode for the unit to +which it applies, regardless of the mode set by the command line +switches. In Ada 83 mode, GNAT attempts to be as compatible with +the syntax and semantics of Ada 83, as defined in the original Ada +83 Reference Manual as possible. In particular, the keywords added by Ada 95 +and Ada 2005 are not recognized, optional package bodies are allowed, +and generics may name types with unknown discriminants without using +the @code{(<>)} notation. In addition, some but not all of the additional +restrictions of Ada 83 are enforced. + +Ada 83 mode is intended for two purposes. Firstly, it allows existing +Ada 83 code to be compiled and adapted to GNAT with less effort. +Secondly, it aids in keeping code backwards compatible with Ada 83. +However, there is no guarantee that code that is processed correctly +by GNAT in Ada 83 mode will in fact compile and execute with an Ada +83 compiler, since GNAT does not enforce all the additional checks +required by Ada 83. + +@node Pragma Ada_95 +@unnumberedsec Pragma Ada_95 +@findex Ada_95 +@noindent +Syntax: +@smallexample @c ada +pragma Ada_95; +@end smallexample + +@noindent +A configuration pragma that establishes Ada 95 mode for the unit to which +it applies, regardless of the mode set by the command line switches. +This mode is set automatically for the @code{Ada} and @code{System} +packages and their children, so you need not specify it in these +contexts. This pragma is useful when writing a reusable component that +itself uses Ada 95 features, but which is intended to be usable from +either Ada 83 or Ada 95 programs. + +@node Pragma Ada_05 +@unnumberedsec Pragma Ada_05 +@findex Ada_05 +@noindent +Syntax: +@smallexample @c ada +pragma Ada_05; +@end smallexample + +@noindent +A configuration pragma that establishes Ada 2005 mode for the unit to which +it applies, regardless of the mode set by the command line switches. +This pragma is useful when writing a reusable component that +itself uses Ada 2005 features, but which is intended to be usable from +either Ada 83 or Ada 95 programs. + +@node Pragma Ada_2005 +@unnumberedsec Pragma Ada_2005 +@findex Ada_2005 +@noindent +Syntax: +@smallexample @c ada +pragma Ada_2005; +@end smallexample + +@noindent +This configuration pragma is a synonym for pragma Ada_05 and has the +same syntax and effect. + +@node Pragma Ada_12 +@unnumberedsec Pragma Ada_12 +@findex Ada_12 +@noindent +Syntax: +@smallexample @c ada +pragma Ada_12; +@end smallexample + +@noindent +A configuration pragma that establishes Ada 2012 mode for the unit to which +it applies, regardless of the mode set by the command line switches. +This mode is set automatically for the @code{Ada} and @code{System} +packages and their children, so you need not specify it in these +contexts. This pragma is useful when writing a reusable component that +itself uses Ada 2012 features, but which is intended to be usable from +Ada 83, Ada 95, or Ada 2005 programs. + +@node Pragma Ada_2012 +@unnumberedsec Pragma Ada_2012 +@findex Ada_2005 +@noindent +Syntax: +@smallexample @c ada +pragma Ada_2012; +@end smallexample + +@noindent +This configuration pragma is a synonym for pragma Ada_12 and has the +same syntax and effect. + +@node Pragma Annotate +@unnumberedsec Pragma Annotate +@findex Annotate +@noindent +Syntax: +@smallexample @c ada +pragma Annotate (IDENTIFIER [,IDENTIFIER] @{, ARG@}); + +ARG ::= NAME | EXPRESSION +@end smallexample + +@noindent +This pragma is used to annotate programs. @var{identifier} identifies +the type of annotation. GNAT verifies that it is an identifier, but does +not otherwise analyze it. The second optional identifier is also left +unanalyzed, and by convention is used to control the action of the tool to +which the annotation is addressed. The remaining @var{arg} arguments +can be either string literals or more generally expressions. +String literals are assumed to be either of type +@code{Standard.String} or else @code{Wide_String} or @code{Wide_Wide_String} +depending on the character literals they contain. +All other kinds of arguments are analyzed as expressions, and must be +unambiguous. + +The analyzed pragma is retained in the tree, but not otherwise processed +by any part of the GNAT compiler. This pragma is intended for use by +external tools, including ASIS@. + +@node Pragma Assert +@unnumberedsec Pragma Assert +@findex Assert +@noindent +Syntax: +@smallexample @c ada +pragma Assert ( + boolean_EXPRESSION + [, string_EXPRESSION]); +@end smallexample + +@noindent +The effect of this pragma depends on whether the corresponding command +line switch is set to activate assertions. The pragma expands into code +equivalent to the following: + +@smallexample @c ada +if assertions-enabled then + if not boolean_EXPRESSION then + System.Assertions.Raise_Assert_Failure + (string_EXPRESSION); + end if; +end if; +@end smallexample + +@noindent +The string argument, if given, is the message that will be associated +with the exception occurrence if the exception is raised. If no second +argument is given, the default message is @samp{@var{file}:@var{nnn}}, +where @var{file} is the name of the source file containing the assert, +and @var{nnn} is the line number of the assert. A pragma is not a +statement, so if a statement sequence contains nothing but a pragma +assert, then a null statement is required in addition, as in: + +@smallexample @c ada +@dots{} +if J > 3 then + pragma Assert (K > 3, "Bad value for K"); + null; +end if; +@end smallexample + +@noindent +Note that, as with the @code{if} statement to which it is equivalent, the +type of the expression is either @code{Standard.Boolean}, or any type derived +from this standard type. + +If assertions are disabled (switch @option{-gnata} not used), then there +is no run-time effect (and in particular, any side effects from the +expression will not occur at run time). (The expression is still +analyzed at compile time, and may cause types to be frozen if they are +mentioned here for the first time). + +If assertions are enabled, then the given expression is tested, and if +it is @code{False} then @code{System.Assertions.Raise_Assert_Failure} is called +which results in the raising of @code{Assert_Failure} with the given message. + +You should generally avoid side effects in the expression arguments of +this pragma, because these side effects will turn on and off with the +setting of the assertions mode, resulting in assertions that have an +effect on the program. However, the expressions are analyzed for +semantic correctness whether or not assertions are enabled, so turning +assertions on and off cannot affect the legality of a program. + +@node Pragma Assume_No_Invalid_Values +@unnumberedsec Pragma Assume_No_Invalid_Values +@findex Assume_No_Invalid_Values +@cindex Invalid representations +@cindex Invalid values +@noindent +Syntax: +@smallexample @c ada +pragma Assume_No_Invalid_Values (On | Off); +@end smallexample + +@noindent +This is a configuration pragma that controls the assumptions made by the +compiler about the occurrence of invalid representations (invalid values) +in the code. + +The default behavior (corresponding to an Off argument for this pragma), is +to assume that values may in general be invalid unless the compiler can +prove they are valid. Consider the following example: + +@smallexample @c ada +V1 : Integer range 1 .. 10; +V2 : Integer range 11 .. 20; +... +for J in V2 .. V1 loop + ... +end loop; +@end smallexample + +@noindent +if V1 and V2 have valid values, then the loop is known at compile +time not to execute since the lower bound must be greater than the +upper bound. However in default mode, no such assumption is made, +and the loop may execute. If @code{Assume_No_Invalid_Values (On)} +is given, the compiler will assume that any occurrence of a variable +other than in an explicit @code{'Valid} test always has a valid +value, and the loop above will be optimized away. + +The use of @code{Assume_No_Invalid_Values (On)} is appropriate if +you know your code is free of uninitialized variables and other +possible sources of invalid representations, and may result in +more efficient code. A program that accesses an invalid representation +with this pragma in effect is erroneous, so no guarantees can be made +about its behavior. + +It is peculiar though permissible to use this pragma in conjunction +with validity checking (-gnatVa). In such cases, accessing invalid +values will generally give an exception, though formally the program +is erroneous so there are no guarantees that this will always be the +case, and it is recommended that these two options not be used together. + +@node Pragma Ast_Entry +@unnumberedsec Pragma Ast_Entry +@cindex OpenVMS +@findex Ast_Entry +@noindent +Syntax: +@smallexample @c ada +pragma AST_Entry (entry_IDENTIFIER); +@end smallexample + +@noindent +This pragma is implemented only in the OpenVMS implementation of GNAT@. The +argument is the simple name of a single entry; at most one @code{AST_Entry} +pragma is allowed for any given entry. This pragma must be used in +conjunction with the @code{AST_Entry} attribute, and is only allowed after +the entry declaration and in the same task type specification or single task +as the entry to which it applies. This pragma specifies that the given entry +may be used to handle an OpenVMS asynchronous system trap (@code{AST}) +resulting from an OpenVMS system service call. The pragma does not affect +normal use of the entry. For further details on this pragma, see the +DEC Ada Language Reference Manual, section 9.12a. + +@node Pragma C_Pass_By_Copy +@unnumberedsec Pragma C_Pass_By_Copy +@cindex Passing by copy +@findex C_Pass_By_Copy +@noindent +Syntax: +@smallexample @c ada +pragma C_Pass_By_Copy + ([Max_Size =>] static_integer_EXPRESSION); +@end smallexample + +@noindent +Normally the default mechanism for passing C convention records to C +convention subprograms is to pass them by reference, as suggested by RM +B.3(69). Use the configuration pragma @code{C_Pass_By_Copy} to change +this default, by requiring that record formal parameters be passed by +copy if all of the following conditions are met: + +@itemize @bullet +@item +The size of the record type does not exceed the value specified for +@code{Max_Size}. +@item +The record type has @code{Convention C}. +@item +The formal parameter has this record type, and the subprogram has a +foreign (non-Ada) convention. +@end itemize + +@noindent +If these conditions are met the argument is passed by copy, i.e.@: in a +manner consistent with what C expects if the corresponding formal in the +C prototype is a struct (rather than a pointer to a struct). + +You can also pass records by copy by specifying the convention +@code{C_Pass_By_Copy} for the record type, or by using the extended +@code{Import} and @code{Export} pragmas, which allow specification of +passing mechanisms on a parameter by parameter basis. + +@node Pragma Check +@unnumberedsec Pragma Check +@cindex Assertions +@cindex Named assertions +@findex Check +@noindent +Syntax: +@smallexample @c ada +pragma Check ( + [Name =>] Identifier, + [Check =>] Boolean_EXPRESSION + [, [Message =>] string_EXPRESSION] ); +@end smallexample + +@noindent +This pragma is similar to the predefined pragma @code{Assert} except that an +extra identifier argument is present. In conjunction with pragma +@code{Check_Policy}, this can be used to define groups of assertions that can +be independently controlled. The identifier @code{Assertion} is special, it +refers to the normal set of pragma @code{Assert} statements. The identifiers +@code{Precondition} and @code{Postcondition} correspond to the pragmas of these +names, so these three names would normally not be used directly in a pragma +@code{Check}. + +Checks introduced by this pragma are normally deactivated by default. They can +be activated either by the command line option @option{-gnata}, which turns on +all checks, or individually controlled using pragma @code{Check_Policy}. + +@node Pragma Check_Name +@unnumberedsec Pragma Check_Name +@cindex Defining check names +@cindex Check names, defining +@findex Check_Name +@noindent +Syntax: +@smallexample @c ada +pragma Check_Name (check_name_IDENTIFIER); +@end smallexample + +@noindent +This is a configuration pragma that defines a new implementation +defined check name (unless IDENTIFIER matches one of the predefined +check names, in which case the pragma has no effect). Check names +are global to a partition, so if two or more configuration pragmas +are present in a partition mentioning the same name, only one new +check name is introduced. + +An implementation defined check name introduced with this pragma may +be used in only three contexts: @code{pragma Suppress}, +@code{pragma Unsuppress}, +and as the prefix of a @code{Check_Name'Enabled} attribute reference. For +any of these three cases, the check name must be visible. A check +name is visible if it is in the configuration pragmas applying to +the current unit, or if it appears at the start of any unit that +is part of the dependency set of the current unit (e.g., units that +are mentioned in @code{with} clauses). + +@node Pragma Check_Policy +@unnumberedsec Pragma Check_Policy +@cindex Controlling assertions +@cindex Assertions, control +@cindex Check pragma control +@cindex Named assertions +@findex Check +@noindent +Syntax: +@smallexample @c ada +pragma Check_Policy + ([Name =>] Identifier, + [Policy =>] POLICY_IDENTIFIER); + +POLICY_IDENTIFIER ::= On | Off | Check | Ignore +@end smallexample + +@noindent +This pragma is similar to the predefined pragma @code{Assertion_Policy}, +except that it controls sets of named assertions introduced using the +@code{Check} pragmas. It can be used as a configuration pragma or (unlike +@code{Assertion_Policy}) can be used within a declarative part, in which case +it controls the status to the end of the corresponding construct (in a manner +identical to pragma @code{Suppress)}. + +The identifier given as the first argument corresponds to a name used in +associated @code{Check} pragmas. For example, if the pragma: + +@smallexample @c ada +pragma Check_Policy (Critical_Error, Off); +@end smallexample + +@noindent +is given, then subsequent @code{Check} pragmas whose first argument is also +@code{Critical_Error} will be disabled. The special identifier @code{Assertion} +controls the behavior of normal @code{Assert} pragmas (thus a pragma +@code{Check_Policy} with this identifier is similar to the normal +@code{Assertion_Policy} pragma except that it can appear within a +declarative part). + +The special identifiers @code{Precondition} and @code{Postcondition} control +the status of preconditions and postconditions. If a @code{Precondition} pragma +is encountered, it is ignored if turned off by a @code{Check_Policy} specifying +that @code{Precondition} checks are @code{Off} or @code{Ignored}. Similarly use +of the name @code{Postcondition} controls whether @code{Postcondition} pragmas +are recognized. + +The check policy is @code{Off} to turn off corresponding checks, and @code{On} +to turn on corresponding checks. The default for a set of checks for which no +@code{Check_Policy} is given is @code{Off} unless the compiler switch +@option{-gnata} is given, which turns on all checks by default. + +The check policy settings @code{Check} and @code{Ignore} are also recognized +as synonyms for @code{On} and @code{Off}. These synonyms are provided for +compatibility with the standard @code{Assertion_Policy} pragma. + +@node Pragma Comment +@unnumberedsec Pragma Comment +@findex Comment +@noindent +Syntax: + +@smallexample @c ada +pragma Comment (static_string_EXPRESSION); +@end smallexample + +@noindent +This is almost identical in effect to pragma @code{Ident}. It allows the +placement of a comment into the object file and hence into the +executable file if the operating system permits such usage. The +difference is that @code{Comment}, unlike @code{Ident}, has +no limitations on placement of the pragma (it can be placed +anywhere in the main source unit), and if more than one pragma +is used, all comments are retained. + +@node Pragma Common_Object +@unnumberedsec Pragma Common_Object +@findex Common_Object +@noindent +Syntax: + +@smallexample @c ada +pragma Common_Object ( + [Internal =>] LOCAL_NAME + [, [External =>] EXTERNAL_SYMBOL] + [, [Size =>] EXTERNAL_SYMBOL] ); + +EXTERNAL_SYMBOL ::= + IDENTIFIER +| static_string_EXPRESSION +@end smallexample + +@noindent +This pragma enables the shared use of variables stored in overlaid +linker areas corresponding to the use of @code{COMMON} +in Fortran. The single +object @var{LOCAL_NAME} is assigned to the area designated by +the @var{External} argument. +You may define a record to correspond to a series +of fields. The @var{Size} argument +is syntax checked in GNAT, but otherwise ignored. + +@code{Common_Object} is not supported on all platforms. If no +support is available, then the code generator will issue a message +indicating that the necessary attribute for implementation of this +pragma is not available. + +@node Pragma Compile_Time_Error +@unnumberedsec Pragma Compile_Time_Error +@findex Compile_Time_Error +@noindent +Syntax: + +@smallexample @c ada +pragma Compile_Time_Error + (boolean_EXPRESSION, static_string_EXPRESSION); +@end smallexample + +@noindent +This pragma can be used to generate additional compile time +error messages. It +is particularly useful in generics, where errors can be issued for +specific problematic instantiations. The first parameter is a boolean +expression. The pragma is effective only if the value of this expression +is known at compile time, and has the value True. The set of expressions +whose values are known at compile time includes all static boolean +expressions, and also other values which the compiler can determine +at compile time (e.g., the size of a record type set by an explicit +size representation clause, or the value of a variable which was +initialized to a constant and is known not to have been modified). +If these conditions are met, an error message is generated using +the value given as the second argument. This string value may contain +embedded ASCII.LF characters to break the message into multiple lines. + +@node Pragma Compile_Time_Warning +@unnumberedsec Pragma Compile_Time_Warning +@findex Compile_Time_Warning +@noindent +Syntax: + +@smallexample @c ada +pragma Compile_Time_Warning + (boolean_EXPRESSION, static_string_EXPRESSION); +@end smallexample + +@noindent +Same as pragma Compile_Time_Error, except a warning is issued instead +of an error message. Note that if this pragma is used in a package that +is with'ed by a client, the client will get the warning even though it +is issued by a with'ed package (normally warnings in with'ed units are +suppressed, but this is a special exception to that rule). + +One typical use is within a generic where compile time known characteristics +of formal parameters are tested, and warnings given appropriately. Another use +with a first parameter of True is to warn a client about use of a package, +for example that it is not fully implemented. + +@node Pragma Compiler_Unit +@unnumberedsec Pragma Compiler_Unit +@findex Compiler_Unit +@noindent +Syntax: + +@smallexample @c ada +pragma Compiler_Unit; +@end smallexample + +@noindent +This pragma is intended only for internal use in the GNAT run-time library. +It indicates that the unit is used as part of the compiler build. The effect +is to disallow constructs (raise with message, conditional expressions etc) +that would cause trouble when bootstrapping using an older version of GNAT. +For the exact list of restrictions, see the compiler sources and references +to Is_Compiler_Unit. + +@node Pragma Complete_Representation +@unnumberedsec Pragma Complete_Representation +@findex Complete_Representation +@noindent +Syntax: + +@smallexample @c ada +pragma Complete_Representation; +@end smallexample + +@noindent +This pragma must appear immediately within a record representation +clause. Typical placements are before the first component clause +or after the last component clause. The effect is to give an error +message if any component is missing a component clause. This pragma +may be used to ensure that a record representation clause is +complete, and that this invariant is maintained if fields are +added to the record in the future. + +@node Pragma Complex_Representation +@unnumberedsec Pragma Complex_Representation +@findex Complex_Representation +@noindent +Syntax: + +@smallexample @c ada +pragma Complex_Representation + ([Entity =>] LOCAL_NAME); +@end smallexample + +@noindent +The @var{Entity} argument must be the name of a record type which has +two fields of the same floating-point type. The effect of this pragma is +to force gcc to use the special internal complex representation form for +this record, which may be more efficient. Note that this may result in +the code for this type not conforming to standard ABI (application +binary interface) requirements for the handling of record types. For +example, in some environments, there is a requirement for passing +records by pointer, and the use of this pragma may result in passing +this type in floating-point registers. + +@node Pragma Component_Alignment +@unnumberedsec Pragma Component_Alignment +@cindex Alignments of components +@findex Component_Alignment +@noindent +Syntax: + +@smallexample @c ada +pragma Component_Alignment ( + [Form =>] ALIGNMENT_CHOICE + [, [Name =>] type_LOCAL_NAME]); + +ALIGNMENT_CHOICE ::= + Component_Size +| Component_Size_4 +| Storage_Unit +| Default +@end smallexample + +@noindent +Specifies the alignment of components in array or record types. +The meaning of the @var{Form} argument is as follows: + +@table @code +@findex Component_Size +@item Component_Size +Aligns scalar components and subcomponents of the array or record type +on boundaries appropriate to their inherent size (naturally +aligned). For example, 1-byte components are aligned on byte boundaries, +2-byte integer components are aligned on 2-byte boundaries, 4-byte +integer components are aligned on 4-byte boundaries and so on. These +alignment rules correspond to the normal rules for C compilers on all +machines except the VAX@. + +@findex Component_Size_4 +@item Component_Size_4 +Naturally aligns components with a size of four or fewer +bytes. Components that are larger than 4 bytes are placed on the next +4-byte boundary. + +@findex Storage_Unit +@item Storage_Unit +Specifies that array or record components are byte aligned, i.e.@: +aligned on boundaries determined by the value of the constant +@code{System.Storage_Unit}. + +@cindex OpenVMS +@item Default +Specifies that array or record components are aligned on default +boundaries, appropriate to the underlying hardware or operating system or +both. For OpenVMS VAX systems, the @code{Default} choice is the same as +the @code{Storage_Unit} choice (byte alignment). For all other systems, +the @code{Default} choice is the same as @code{Component_Size} (natural +alignment). +@end table + +@noindent +If the @code{Name} parameter is present, @var{type_LOCAL_NAME} must +refer to a local record or array type, and the specified alignment +choice applies to the specified type. The use of +@code{Component_Alignment} together with a pragma @code{Pack} causes the +@code{Component_Alignment} pragma to be ignored. The use of +@code{Component_Alignment} together with a record representation clause +is only effective for fields not specified by the representation clause. + +If the @code{Name} parameter is absent, the pragma can be used as either +a configuration pragma, in which case it applies to one or more units in +accordance with the normal rules for configuration pragmas, or it can be +used within a declarative part, in which case it applies to types that +are declared within this declarative part, or within any nested scope +within this declarative part. In either case it specifies the alignment +to be applied to any record or array type which has otherwise standard +representation. + +If the alignment for a record or array type is not specified (using +pragma @code{Pack}, pragma @code{Component_Alignment}, or a record rep +clause), the GNAT uses the default alignment as described previously. + +@node Pragma Convention_Identifier +@unnumberedsec Pragma Convention_Identifier +@findex Convention_Identifier +@cindex Conventions, synonyms +@noindent +Syntax: + +@smallexample @c ada +pragma Convention_Identifier ( + [Name =>] IDENTIFIER, + [Convention =>] convention_IDENTIFIER); +@end smallexample + +@noindent +This pragma provides a mechanism for supplying synonyms for existing +convention identifiers. The @code{Name} identifier can subsequently +be used as a synonym for the given convention in other pragmas (including +for example pragma @code{Import} or another @code{Convention_Identifier} +pragma). As an example of the use of this, suppose you had legacy code +which used Fortran77 as the identifier for Fortran. Then the pragma: + +@smallexample @c ada +pragma Convention_Identifier (Fortran77, Fortran); +@end smallexample + +@noindent +would allow the use of the convention identifier @code{Fortran77} in +subsequent code, avoiding the need to modify the sources. As another +example, you could use this to parameterize convention requirements +according to systems. Suppose you needed to use @code{Stdcall} on +windows systems, and @code{C} on some other system, then you could +define a convention identifier @code{Library} and use a single +@code{Convention_Identifier} pragma to specify which convention +would be used system-wide. + +@node Pragma CPP_Class +@unnumberedsec Pragma CPP_Class +@findex CPP_Class +@cindex Interfacing with C++ +@noindent +Syntax: + +@smallexample @c ada +pragma CPP_Class ([Entity =>] LOCAL_NAME); +@end smallexample + +@noindent +The argument denotes an entity in the current declarative region that is +declared as a record type. It indicates that the type corresponds to an +externally declared C++ class type, and is to be laid out the same way +that C++ would lay out the type. If the C++ class has virtual primitives +then the record must be declared as a tagged record type. + +Types for which @code{CPP_Class} is specified do not have assignment or +equality operators defined (such operations can be imported or declared +as subprograms as required). Initialization is allowed only by constructor +functions (see pragma @code{CPP_Constructor}). Such types are implicitly +limited if not explicitly declared as limited or derived from a limited +type, and an error is issued in that case. + +Pragma @code{CPP_Class} is intended primarily for automatic generation +using an automatic binding generator tool. +See @ref{Interfacing to C++} for related information. + +Note: Pragma @code{CPP_Class} is currently obsolete. It is supported +for backward compatibility but its functionality is available +using pragma @code{Import} with @code{Convention} = @code{CPP}. + +@node Pragma CPP_Constructor +@unnumberedsec Pragma CPP_Constructor +@cindex Interfacing with C++ +@findex CPP_Constructor +@noindent +Syntax: + +@smallexample @c ada +pragma CPP_Constructor ([Entity =>] LOCAL_NAME + [, [External_Name =>] static_string_EXPRESSION ] + [, [Link_Name =>] static_string_EXPRESSION ]); +@end smallexample + +@noindent +This pragma identifies an imported function (imported in the usual way +with pragma @code{Import}) as corresponding to a C++ constructor. If +@code{External_Name} and @code{Link_Name} are not specified then the +@code{Entity} argument is a name that must have been previously mentioned +in a pragma @code{Import} with @code{Convention} = @code{CPP}. Such name +must be of one of the following forms: + +@itemize @bullet +@item +@code{function @var{Fname} return @var{T}} + +@itemize @bullet +@item +@code{function @var{Fname} return @var{T}'Class} + +@item +@code{function @var{Fname} (@dots{}) return @var{T}} +@end itemize + +@item +@code{function @var{Fname} (@dots{}) return @var{T}'Class} +@end itemize + +@noindent +where @var{T} is a limited record type imported from C++ with pragma +@code{Import} and @code{Convention} = @code{CPP}. + +The first two forms import the default constructor, used when an object +of type @var{T} is created on the Ada side with no explicit constructor. +The latter two forms cover all the non-default constructors of the type. +See the GNAT users guide for details. + +If no constructors are imported, it is impossible to create any objects +on the Ada side and the type is implicitly declared abstract. + +Pragma @code{CPP_Constructor} is intended primarily for automatic generation +using an automatic binding generator tool. +See @ref{Interfacing to C++} for more related information. + +Note: The use of functions returning class-wide types for constructors is +currently obsolete. They are supported for backward compatibility. The +use of functions returning the type T leave the Ada sources more clear +because the imported C++ constructors always return an object of type T; +that is, they never return an object whose type is a descendant of type T. + +@node Pragma CPP_Virtual +@unnumberedsec Pragma CPP_Virtual +@cindex Interfacing to C++ +@findex CPP_Virtual +@noindent +This pragma is now obsolete has has no effect because GNAT generates +the same object layout than the G++ compiler. + +See @ref{Interfacing to C++} for related information. + +@node Pragma CPP_Vtable +@unnumberedsec Pragma CPP_Vtable +@cindex Interfacing with C++ +@findex CPP_Vtable +@noindent +This pragma is now obsolete has has no effect because GNAT generates +the same object layout than the G++ compiler. + +See @ref{Interfacing to C++} for related information. + +@node Pragma Debug +@unnumberedsec Pragma Debug +@findex Debug +@noindent +Syntax: + +@smallexample @c ada +pragma Debug ([CONDITION, ]PROCEDURE_CALL_WITHOUT_SEMICOLON); + +PROCEDURE_CALL_WITHOUT_SEMICOLON ::= + PROCEDURE_NAME +| PROCEDURE_PREFIX ACTUAL_PARAMETER_PART +@end smallexample + +@noindent +The procedure call argument has the syntactic form of an expression, meeting +the syntactic requirements for pragmas. + +If debug pragmas are not enabled or if the condition is present and evaluates +to False, this pragma has no effect. If debug pragmas are enabled, the +semantics of the pragma is exactly equivalent to the procedure call statement +corresponding to the argument with a terminating semicolon. Pragmas are +permitted in sequences of declarations, so you can use pragma @code{Debug} to +intersperse calls to debug procedures in the middle of declarations. Debug +pragmas can be enabled either by use of the command line switch @option{-gnata} +or by use of the configuration pragma @code{Debug_Policy}. + +@node Pragma Debug_Policy +@unnumberedsec Pragma Debug_Policy +@findex Debug_Policy +@noindent +Syntax: + +@smallexample @c ada +pragma Debug_Policy (CHECK | IGNORE); +@end smallexample + +@noindent +If the argument is @code{CHECK}, then pragma @code{DEBUG} is enabled. +If the argument is @code{IGNORE}, then pragma @code{DEBUG} is ignored. +This pragma overrides the effect of the @option{-gnata} switch on the +command line. + +@node Pragma Detect_Blocking +@unnumberedsec Pragma Detect_Blocking +@findex Detect_Blocking +@noindent +Syntax: + +@smallexample @c ada +pragma Detect_Blocking; +@end smallexample + +@noindent +This is a configuration pragma that forces the detection of potentially +blocking operations within a protected operation, and to raise Program_Error +if that happens. + +@node Pragma Elaboration_Checks +@unnumberedsec Pragma Elaboration_Checks +@cindex Elaboration control +@findex Elaboration_Checks +@noindent +Syntax: + +@smallexample @c ada +pragma Elaboration_Checks (Dynamic | Static); +@end smallexample + +@noindent +This is a configuration pragma that provides control over the +elaboration model used by the compilation affected by the +pragma. If the parameter is @code{Dynamic}, +then the dynamic elaboration +model described in the Ada Reference Manual is used, as though +the @option{-gnatE} switch had been specified on the command +line. If the parameter is @code{Static}, then the default GNAT static +model is used. This configuration pragma overrides the setting +of the command line. For full details on the elaboration models +used by the GNAT compiler, see @ref{Elaboration Order Handling in GNAT,,, +gnat_ugn, @value{EDITION} User's Guide}. + +@node Pragma Eliminate +@unnumberedsec Pragma Eliminate +@cindex Elimination of unused subprograms +@findex Eliminate +@noindent +Syntax: + +@smallexample @c ada +pragma Eliminate (UNIT_NAME, ENTITY, Source_Location => SOURCE_TRACE) + +UNIT_NAME ::= IDENTIFIER | + SELECTED_COMPONENT, + +ENTITY ::= IDENTIFIER | + SELECTED_COMPONENT, + +SOURCE_TRACE ::= SOURCE_REFERENCE | + SOURCE_REFERENCE LBRACKET SOURCE_TRACE RBRACKET + +LBRACKET ::= [ +RBRACKET ::= ] + +SOURCE_REFERENCE ::= FILE_NAME : LINE_NUMBER + +FILE_NAME ::= STRING_LITERAL +LINE_NUMBER ::= INTEGER_LITERAL +@end smallexample + +@noindent +This pragma indicates that the given entity is not used in the program +to be compiled and built. The entity must be an explicitly declared +subprogram; this includes generic subprogram instances and +subprograms declared in generic package instances. @code{Unit_Name} +must be the name of the compilation unit in which the entity is declared. + +The @code{Source_Location} argument is used to resolve overloading +in case more then one callable entity with the same name is declared +in the given compilation unit. Each file name must be the short name of the +source file (with no directory information). +If an entity is not declared in +a generic instantiation (this includes generic subprogram instances), +the source trace includes only one source +reference. If an entity is declared inside a generic instantiation, +its source trace starts from the source location in the instantiation and +ends with the source location of the declaration of the corresponding +entity in the generic +unit. This approach is recursively used in case of nested instantiations: +the leftmost element of the +source trace is the location of the outermost instantiation, the next +element is the location of the next (first nested) instantiation in the +code of the corresponding generic unit, and so on. + +The effect of the pragma is to allow the compiler to eliminate +the code or data associated with the named entity. Any reference to +an eliminated entity outside the compilation unit where it is defined +causes a compile-time or link-time error. + +The intention of pragma @code{Eliminate} is to allow a program to be compiled +in a system-independent manner, with unused entities eliminated, without +needing to modify the source text. Normally the required set +of @code{Eliminate} pragmas is constructed automatically using the gnatelim +tool. Elimination of unused entities local to a compilation unit is +automatic, without requiring the use of pragma @code{Eliminate}. + +Any source file change that removes, splits, or +adds lines may make the set of Eliminate pragmas invalid because their +@code{Source_Location} argument values may get out of date. + +Pragma Eliminate may be used where the referenced entity is a +dispatching operation. In this case all the subprograms to which the +given operation can dispatch are considered to be unused (are never called +as a result of a direct or a dispatching call). + +@node Pragma Export_Exception +@unnumberedsec Pragma Export_Exception +@cindex OpenVMS +@findex Export_Exception +@noindent +Syntax: + +@smallexample @c ada +pragma Export_Exception ( + [Internal =>] LOCAL_NAME + [, [External =>] EXTERNAL_SYMBOL] + [, [Form =>] Ada | VMS] + [, [Code =>] static_integer_EXPRESSION]); + +EXTERNAL_SYMBOL ::= + IDENTIFIER +| static_string_EXPRESSION +@end smallexample + +@noindent +This pragma is implemented only in the OpenVMS implementation of GNAT@. It +causes the specified exception to be propagated outside of the Ada program, +so that it can be handled by programs written in other OpenVMS languages. +This pragma establishes an external name for an Ada exception and makes the +name available to the OpenVMS Linker as a global symbol. For further details +on this pragma, see the +DEC Ada Language Reference Manual, section 13.9a3.2. + +@node Pragma Export_Function +@unnumberedsec Pragma Export_Function +@cindex Argument passing mechanisms +@findex Export_Function + +@noindent +Syntax: + +@smallexample @c ada +pragma Export_Function ( + [Internal =>] LOCAL_NAME + [, [External =>] EXTERNAL_SYMBOL] + [, [Parameter_Types =>] PARAMETER_TYPES] + [, [Result_Type =>] result_SUBTYPE_MARK] + [, [Mechanism =>] MECHANISM] + [, [Result_Mechanism =>] MECHANISM_NAME]); + +EXTERNAL_SYMBOL ::= + IDENTIFIER +| static_string_EXPRESSION +| "" + +PARAMETER_TYPES ::= + null +| TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} + +TYPE_DESIGNATOR ::= + subtype_NAME +| subtype_Name ' Access + +MECHANISM ::= + MECHANISM_NAME +| (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) + +MECHANISM_ASSOCIATION ::= + [formal_parameter_NAME =>] MECHANISM_NAME + +MECHANISM_NAME ::= + Value +| Reference +| Descriptor [([Class =>] CLASS_NAME)] +| Short_Descriptor [([Class =>] CLASS_NAME)] + +CLASS_NAME ::= ubs | ubsb | uba | s | sb | a +@end smallexample + +@noindent +Use this pragma to make a function externally callable and optionally +provide information on mechanisms to be used for passing parameter and +result values. We recommend, for the purposes of improving portability, +this pragma always be used in conjunction with a separate pragma +@code{Export}, which must precede the pragma @code{Export_Function}. +GNAT does not require a separate pragma @code{Export}, but if none is +present, @code{Convention Ada} is assumed, which is usually +not what is wanted, so it is usually appropriate to use this +pragma in conjunction with a @code{Export} or @code{Convention} +pragma that specifies the desired foreign convention. +Pragma @code{Export_Function} +(and @code{Export}, if present) must appear in the same declarative +region as the function to which they apply. + +@var{internal_name} must uniquely designate the function to which the +pragma applies. If more than one function name exists of this name in +the declarative part you must use the @code{Parameter_Types} and +@code{Result_Type} parameters is mandatory to achieve the required +unique designation. @var{subtype_mark}s in these parameters must +exactly match the subtypes in the corresponding function specification, +using positional notation to match parameters with subtype marks. +The form with an @code{'Access} attribute can be used to match an +anonymous access parameter. + +@cindex OpenVMS +@cindex Passing by descriptor +Passing by descriptor is supported only on the OpenVMS ports of GNAT@. +The default behavior for Export_Function is to accept either 64bit or +32bit descriptors unless short_descriptor is specified, then only 32bit +descriptors are accepted. + +@cindex Suppressing external name +Special treatment is given if the EXTERNAL is an explicit null +string or a static string expressions that evaluates to the null +string. In this case, no external name is generated. This form +still allows the specification of parameter mechanisms. + +@node Pragma Export_Object +@unnumberedsec Pragma Export_Object +@findex Export_Object +@noindent +Syntax: + +@smallexample @c ada +pragma Export_Object + [Internal =>] LOCAL_NAME + [, [External =>] EXTERNAL_SYMBOL] + [, [Size =>] EXTERNAL_SYMBOL] + +EXTERNAL_SYMBOL ::= + IDENTIFIER +| static_string_EXPRESSION +@end smallexample + +@noindent +This pragma designates an object as exported, and apart from the +extended rules for external symbols, is identical in effect to the use of +the normal @code{Export} pragma applied to an object. You may use a +separate Export pragma (and you probably should from the point of view +of portability), but it is not required. @var{Size} is syntax checked, +but otherwise ignored by GNAT@. + +@node Pragma Export_Procedure +@unnumberedsec Pragma Export_Procedure +@findex Export_Procedure +@noindent +Syntax: + +@smallexample @c ada +pragma Export_Procedure ( + [Internal =>] LOCAL_NAME + [, [External =>] EXTERNAL_SYMBOL] + [, [Parameter_Types =>] PARAMETER_TYPES] + [, [Mechanism =>] MECHANISM]); + +EXTERNAL_SYMBOL ::= + IDENTIFIER +| static_string_EXPRESSION +| "" + +PARAMETER_TYPES ::= + null +| TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} + +TYPE_DESIGNATOR ::= + subtype_NAME +| subtype_Name ' Access + +MECHANISM ::= + MECHANISM_NAME +| (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) + +MECHANISM_ASSOCIATION ::= + [formal_parameter_NAME =>] MECHANISM_NAME + +MECHANISM_NAME ::= + Value +| Reference +| Descriptor [([Class =>] CLASS_NAME)] +| Short_Descriptor [([Class =>] CLASS_NAME)] + +CLASS_NAME ::= ubs | ubsb | uba | s | sb | a +@end smallexample + +@noindent +This pragma is identical to @code{Export_Function} except that it +applies to a procedure rather than a function and the parameters +@code{Result_Type} and @code{Result_Mechanism} are not permitted. +GNAT does not require a separate pragma @code{Export}, but if none is +present, @code{Convention Ada} is assumed, which is usually +not what is wanted, so it is usually appropriate to use this +pragma in conjunction with a @code{Export} or @code{Convention} +pragma that specifies the desired foreign convention. + +@cindex OpenVMS +@cindex Passing by descriptor +Passing by descriptor is supported only on the OpenVMS ports of GNAT@. +The default behavior for Export_Procedure is to accept either 64bit or +32bit descriptors unless short_descriptor is specified, then only 32bit +descriptors are accepted. + +@cindex Suppressing external name +Special treatment is given if the EXTERNAL is an explicit null +string or a static string expressions that evaluates to the null +string. In this case, no external name is generated. This form +still allows the specification of parameter mechanisms. + +@node Pragma Export_Value +@unnumberedsec Pragma Export_Value +@findex Export_Value +@noindent +Syntax: + +@smallexample @c ada +pragma Export_Value ( + [Value =>] static_integer_EXPRESSION, + [Link_Name =>] static_string_EXPRESSION); +@end smallexample + +@noindent +This pragma serves to export a static integer value for external use. +The first argument specifies the value to be exported. The Link_Name +argument specifies the symbolic name to be associated with the integer +value. This pragma is useful for defining a named static value in Ada +that can be referenced in assembly language units to be linked with +the application. This pragma is currently supported only for the +AAMP target and is ignored for other targets. + +@node Pragma Export_Valued_Procedure +@unnumberedsec Pragma Export_Valued_Procedure +@findex Export_Valued_Procedure +@noindent +Syntax: + +@smallexample @c ada +pragma Export_Valued_Procedure ( + [Internal =>] LOCAL_NAME + [, [External =>] EXTERNAL_SYMBOL] + [, [Parameter_Types =>] PARAMETER_TYPES] + [, [Mechanism =>] MECHANISM]); + +EXTERNAL_SYMBOL ::= + IDENTIFIER +| static_string_EXPRESSION +| "" + +PARAMETER_TYPES ::= + null +| TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} + +TYPE_DESIGNATOR ::= + subtype_NAME +| subtype_Name ' Access + +MECHANISM ::= + MECHANISM_NAME +| (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) + +MECHANISM_ASSOCIATION ::= + [formal_parameter_NAME =>] MECHANISM_NAME + +MECHANISM_NAME ::= + Value +| Reference +| Descriptor [([Class =>] CLASS_NAME)] +| Short_Descriptor [([Class =>] CLASS_NAME)] + +CLASS_NAME ::= ubs | ubsb | uba | s | sb | a +@end smallexample + +@noindent +This pragma is identical to @code{Export_Procedure} except that the +first parameter of @var{LOCAL_NAME}, which must be present, must be of +mode @code{OUT}, and externally the subprogram is treated as a function +with this parameter as the result of the function. GNAT provides for +this capability to allow the use of @code{OUT} and @code{IN OUT} +parameters in interfacing to external functions (which are not permitted +in Ada functions). +GNAT does not require a separate pragma @code{Export}, but if none is +present, @code{Convention Ada} is assumed, which is almost certainly +not what is wanted since the whole point of this pragma is to interface +with foreign language functions, so it is usually appropriate to use this +pragma in conjunction with a @code{Export} or @code{Convention} +pragma that specifies the desired foreign convention. + +@cindex OpenVMS +@cindex Passing by descriptor +Passing by descriptor is supported only on the OpenVMS ports of GNAT@. +The default behavior for Export_Valued_Procedure is to accept either 64bit or +32bit descriptors unless short_descriptor is specified, then only 32bit +descriptors are accepted. + +@cindex Suppressing external name +Special treatment is given if the EXTERNAL is an explicit null +string or a static string expressions that evaluates to the null +string. In this case, no external name is generated. This form +still allows the specification of parameter mechanisms. + +@node Pragma Extend_System +@unnumberedsec Pragma Extend_System +@cindex @code{system}, extending +@cindex Dec Ada 83 +@findex Extend_System +@noindent +Syntax: + +@smallexample @c ada +pragma Extend_System ([Name =>] IDENTIFIER); +@end smallexample + +@noindent +This pragma is used to provide backwards compatibility with other +implementations that extend the facilities of package @code{System}. In +GNAT, @code{System} contains only the definitions that are present in +the Ada RM@. However, other implementations, notably the DEC Ada 83 +implementation, provide many extensions to package @code{System}. + +For each such implementation accommodated by this pragma, GNAT provides a +package @code{Aux_@var{xxx}}, e.g.@: @code{Aux_DEC} for the DEC Ada 83 +implementation, which provides the required additional definitions. You +can use this package in two ways. You can @code{with} it in the normal +way and access entities either by selection or using a @code{use} +clause. In this case no special processing is required. + +However, if existing code contains references such as +@code{System.@var{xxx}} where @var{xxx} is an entity in the extended +definitions provided in package @code{System}, you may use this pragma +to extend visibility in @code{System} in a non-standard way that +provides greater compatibility with the existing code. Pragma +@code{Extend_System} is a configuration pragma whose single argument is +the name of the package containing the extended definition +(e.g.@: @code{Aux_DEC} for the DEC Ada case). A unit compiled under +control of this pragma will be processed using special visibility +processing that looks in package @code{System.Aux_@var{xxx}} where +@code{Aux_@var{xxx}} is the pragma argument for any entity referenced in +package @code{System}, but not found in package @code{System}. + +You can use this pragma either to access a predefined @code{System} +extension supplied with the compiler, for example @code{Aux_DEC} or +you can construct your own extension unit following the above +definition. Note that such a package is a child of @code{System} +and thus is considered part of the implementation. To compile +it you will have to use the appropriate switch for compiling +system units. +@xref{Top, @value{EDITION} User's Guide, About This Guide, gnat_ugn, @value{EDITION} User's Guide}, +for details. + +@node Pragma Extensions_Allowed +@unnumberedsec Pragma Extensions_Allowed +@cindex Ada Extensions +@cindex GNAT Extensions +@findex Extensions_Allowed +@noindent +Syntax: + +@smallexample @c ada +pragma Extensions_Allowed (On | Off); +@end smallexample + +@noindent +This configuration pragma enables or disables the implementation +extension mode (the use of Off as a parameter cancels the effect +of the @option{-gnatX} command switch). + +In extension mode, the latest version of the Ada language is +implemented (currently Ada 2012), and in addition a small number +of GNAT specific extensions are recognized as follows: + +@table @asis +@item Constrained attribute for generic objects +The @code{Constrained} attribute is permitted for objects of +generic types. The result indicates if the corresponding actual +is constrained. + +@end table + +@node Pragma External +@unnumberedsec Pragma External +@findex External +@noindent +Syntax: + +@smallexample @c ada +pragma External ( + [ Convention =>] convention_IDENTIFIER, + [ Entity =>] LOCAL_NAME + [, [External_Name =>] static_string_EXPRESSION ] + [, [Link_Name =>] static_string_EXPRESSION ]); +@end smallexample + +@noindent +This pragma is identical in syntax and semantics to pragma +@code{Export} as defined in the Ada Reference Manual. It is +provided for compatibility with some Ada 83 compilers that +used this pragma for exactly the same purposes as pragma +@code{Export} before the latter was standardized. + +@node Pragma External_Name_Casing +@unnumberedsec Pragma External_Name_Casing +@cindex Dec Ada 83 casing compatibility +@cindex External Names, casing +@cindex Casing of External names +@findex External_Name_Casing +@noindent +Syntax: + +@smallexample @c ada +pragma External_Name_Casing ( + Uppercase | Lowercase + [, Uppercase | Lowercase | As_Is]); +@end smallexample + +@noindent +This pragma provides control over the casing of external names associated +with Import and Export pragmas. There are two cases to consider: + +@table @asis +@item Implicit external names +Implicit external names are derived from identifiers. The most common case +arises when a standard Ada Import or Export pragma is used with only two +arguments, as in: + +@smallexample @c ada + pragma Import (C, C_Routine); +@end smallexample + +@noindent +Since Ada is a case-insensitive language, the spelling of the identifier in +the Ada source program does not provide any information on the desired +casing of the external name, and so a convention is needed. In GNAT the +default treatment is that such names are converted to all lower case +letters. This corresponds to the normal C style in many environments. +The first argument of pragma @code{External_Name_Casing} can be used to +control this treatment. If @code{Uppercase} is specified, then the name +will be forced to all uppercase letters. If @code{Lowercase} is specified, +then the normal default of all lower case letters will be used. + +This same implicit treatment is also used in the case of extended DEC Ada 83 +compatible Import and Export pragmas where an external name is explicitly +specified using an identifier rather than a string. + +@item Explicit external names +Explicit external names are given as string literals. The most common case +arises when a standard Ada Import or Export pragma is used with three +arguments, as in: + +@smallexample @c ada +pragma Import (C, C_Routine, "C_routine"); +@end smallexample + +@noindent +In this case, the string literal normally provides the exact casing required +for the external name. The second argument of pragma +@code{External_Name_Casing} may be used to modify this behavior. +If @code{Uppercase} is specified, then the name +will be forced to all uppercase letters. If @code{Lowercase} is specified, +then the name will be forced to all lowercase letters. A specification of +@code{As_Is} provides the normal default behavior in which the casing is +taken from the string provided. +@end table + +@noindent +This pragma may appear anywhere that a pragma is valid. In particular, it +can be used as a configuration pragma in the @file{gnat.adc} file, in which +case it applies to all subsequent compilations, or it can be used as a program +unit pragma, in which case it only applies to the current unit, or it can +be used more locally to control individual Import/Export pragmas. + +It is primarily intended for use with OpenVMS systems, where many +compilers convert all symbols to upper case by default. For interfacing to +such compilers (e.g.@: the DEC C compiler), it may be convenient to use +the pragma: + +@smallexample @c ada +pragma External_Name_Casing (Uppercase, Uppercase); +@end smallexample + +@noindent +to enforce the upper casing of all external symbols. + +@node Pragma Fast_Math +@unnumberedsec Pragma Fast_Math +@findex Fast_Math +@noindent +Syntax: + +@smallexample @c ada +pragma Fast_Math; +@end smallexample + +@noindent +This is a configuration pragma which activates a mode in which speed is +considered more important for floating-point operations than absolutely +accurate adherence to the requirements of the standard. Currently the +following operations are affected: + +@table @asis +@item Complex Multiplication +The normal simple formula for complex multiplication can result in intermediate +overflows for numbers near the end of the range. The Ada standard requires that +this situation be detected and corrected by scaling, but in Fast_Math mode such +cases will simply result in overflow. Note that to take advantage of this you +must instantiate your own version of @code{Ada.Numerics.Generic_Complex_Types} +under control of the pragma, rather than use the preinstantiated versions. +@end table + +@node Pragma Favor_Top_Level +@unnumberedsec Pragma Favor_Top_Level +@findex Favor_Top_Level +@noindent +Syntax: + +@smallexample @c ada +pragma Favor_Top_Level (type_NAME); +@end smallexample + +@noindent +The named type must be an access-to-subprogram type. This pragma is an +efficiency hint to the compiler, regarding the use of 'Access or +'Unrestricted_Access on nested (non-library-level) subprograms. The +pragma means that nested subprograms are not used with this type, or +are rare, so that the generated code should be efficient in the +top-level case. When this pragma is used, dynamically generated +trampolines may be used on some targets for nested subprograms. +See also the No_Implicit_Dynamic_Code restriction. + +@node Pragma Finalize_Storage_Only +@unnumberedsec Pragma Finalize_Storage_Only +@findex Finalize_Storage_Only +@noindent +Syntax: + +@smallexample @c ada +pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME); +@end smallexample + +@noindent +This pragma allows the compiler not to emit a Finalize call for objects +defined at the library level. This is mostly useful for types where +finalization is only used to deal with storage reclamation since in most +environments it is not necessary to reclaim memory just before terminating +execution, hence the name. + +@node Pragma Float_Representation +@unnumberedsec Pragma Float_Representation +@cindex OpenVMS +@findex Float_Representation +@noindent +Syntax: + +@smallexample @c ada +pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]); + +FLOAT_REP ::= VAX_Float | IEEE_Float +@end smallexample + +@noindent +In the one argument form, this pragma is a configuration pragma which +allows control over the internal representation chosen for the predefined +floating point types declared in the packages @code{Standard} and +@code{System}. On all systems other than OpenVMS, the argument must +be @code{IEEE_Float} and the pragma has no effect. On OpenVMS, the +argument may be @code{VAX_Float} to specify the use of the VAX float +format for the floating-point types in Standard. This requires that +the standard runtime libraries be recompiled. + +The two argument form specifies the representation to be used for +the specified floating-point type. On all systems other than OpenVMS, +the argument must +be @code{IEEE_Float} and the pragma has no effect. On OpenVMS, the +argument may be @code{VAX_Float} to specify the use of the VAX float +format, as follows: + +@itemize @bullet +@item +For digits values up to 6, F float format will be used. +@item +For digits values from 7 to 9, D float format will be used. +@item +For digits values from 10 to 15, G float format will be used. +@item +Digits values above 15 are not allowed. +@end itemize + +@node Pragma Ident +@unnumberedsec Pragma Ident +@findex Ident +@noindent +Syntax: + +@smallexample @c ada +pragma Ident (static_string_EXPRESSION); +@end smallexample + +@noindent +This pragma provides a string identification in the generated object file, +if the system supports the concept of this kind of identification string. +This pragma is allowed only in the outermost declarative part or +declarative items of a compilation unit. If more than one @code{Ident} +pragma is given, only the last one processed is effective. +@cindex OpenVMS +On OpenVMS systems, the effect of the pragma is identical to the effect of +the DEC Ada 83 pragma of the same name. Note that in DEC Ada 83, the +maximum allowed length is 31 characters, so if it is important to +maintain compatibility with this compiler, you should obey this length +limit. + +@node Pragma Implemented +@unnumberedsec Pragma Implemented +@findex Implemented +@noindent +Syntax: + +@smallexample @c ada +pragma Implemented (procedure_LOCAL_NAME, implementation_kind); + +implementation_kind ::= By_Entry | By_Protected_Procedure | By_Any +@end smallexample + +@noindent +This is an Ada 2012 representation pragma which applies to protected, task +and synchronized interface primitives. The use of pragma Implemented provides +a way to impose a static requirement on the overriding operation by adhering +to one of the three implementation kids: entry, protected procedure or any of +the above. + +@smallexample @c ada +type Synch_Iface is synchronized interface; +procedure Prim_Op (Obj : in out Iface) is abstract; +pragma Implemented (Prim_Op, By_Protected_Procedure); + +protected type Prot_1 is new Synch_Iface with + procedure Prim_Op; -- Legal +end Prot_1; + +protected type Prot_2 is new Synch_Iface with + entry Prim_Op; -- Illegal +end Prot_2; + +task type Task_Typ is new Synch_Iface with + entry Prim_Op; -- Illegal +end Task_Typ; +@end smallexample + +@noindent +When applied to the procedure_or_entry_NAME of a requeue statement, pragma +Implemented determines the runtime behavior of the requeue. Implementation kind +By_Entry guarantees that the action of requeueing will proceed from an entry to +another entry. Implementation kind By_Protected_Procedure transforms the +requeue into a dispatching call, thus eliminating the chance of blocking. Kind +By_Any shares the behavior of By_Entry and By_Protected_Procedure depending on +the target's overriding subprogram kind. + +@node Pragma Implicit_Packing +@unnumberedsec Pragma Implicit_Packing +@findex Implicit_Packing +@noindent +Syntax: + +@smallexample @c ada +pragma Implicit_Packing; +@end smallexample + +@noindent +This is a configuration pragma that requests implicit packing for packed +arrays for which a size clause is given but no explicit pragma Pack or +specification of Component_Size is present. It also applies to records +where no record representation clause is present. Consider this example: + +@smallexample @c ada +type R is array (0 .. 7) of Boolean; +for R'Size use 8; +@end smallexample + +@noindent +In accordance with the recommendation in the RM (RM 13.3(53)), a Size clause +does not change the layout of a composite object. So the Size clause in the +above example is normally rejected, since the default layout of the array uses +8-bit components, and thus the array requires a minimum of 64 bits. + +If this declaration is compiled in a region of code covered by an occurrence +of the configuration pragma Implicit_Packing, then the Size clause in this +and similar examples will cause implicit packing and thus be accepted. For +this implicit packing to occur, the type in question must be an array of small +components whose size is known at compile time, and the Size clause must +specify the exact size that corresponds to the length of the array multiplied +by the size in bits of the component type. +@cindex Array packing + +Similarly, the following example shows the use in the record case + +@smallexample @c ada +type r is record + a, b, c, d, e, f, g, h : boolean; + chr : character; +end record; +for r'size use 16; +@end smallexample + +@noindent +Without a pragma Pack, each Boolean field requires 8 bits, so the +minimum size is 72 bits, but with a pragma Pack, 16 bits would be +sufficient. The use of pragma Implicit_Packing allows this record +declaration to compile without an explicit pragma Pack. +@node Pragma Import_Exception +@unnumberedsec Pragma Import_Exception +@cindex OpenVMS +@findex Import_Exception +@noindent +Syntax: + +@smallexample @c ada +pragma Import_Exception ( + [Internal =>] LOCAL_NAME + [, [External =>] EXTERNAL_SYMBOL] + [, [Form =>] Ada | VMS] + [, [Code =>] static_integer_EXPRESSION]); + +EXTERNAL_SYMBOL ::= + IDENTIFIER +| static_string_EXPRESSION +@end smallexample + +@noindent +This pragma is implemented only in the OpenVMS implementation of GNAT@. +It allows OpenVMS conditions (for example, from OpenVMS system services or +other OpenVMS languages) to be propagated to Ada programs as Ada exceptions. +The pragma specifies that the exception associated with an exception +declaration in an Ada program be defined externally (in non-Ada code). +For further details on this pragma, see the +DEC Ada Language Reference Manual, section 13.9a.3.1. + +@node Pragma Import_Function +@unnumberedsec Pragma Import_Function +@findex Import_Function +@noindent +Syntax: + +@smallexample @c ada +pragma Import_Function ( + [Internal =>] LOCAL_NAME, + [, [External =>] EXTERNAL_SYMBOL] + [, [Parameter_Types =>] PARAMETER_TYPES] + [, [Result_Type =>] SUBTYPE_MARK] + [, [Mechanism =>] MECHANISM] + [, [Result_Mechanism =>] MECHANISM_NAME] + [, [First_Optional_Parameter =>] IDENTIFIER]); + +EXTERNAL_SYMBOL ::= + IDENTIFIER +| static_string_EXPRESSION + +PARAMETER_TYPES ::= + null +| TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} + +TYPE_DESIGNATOR ::= + subtype_NAME +| subtype_Name ' Access + +MECHANISM ::= + MECHANISM_NAME +| (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) + +MECHANISM_ASSOCIATION ::= + [formal_parameter_NAME =>] MECHANISM_NAME + +MECHANISM_NAME ::= + Value +| Reference +| Descriptor [([Class =>] CLASS_NAME)] +| Short_Descriptor [([Class =>] CLASS_NAME)] + +CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca +@end smallexample + +@noindent +This pragma is used in conjunction with a pragma @code{Import} to +specify additional information for an imported function. The pragma +@code{Import} (or equivalent pragma @code{Interface}) must precede the +@code{Import_Function} pragma and both must appear in the same +declarative part as the function specification. + +The @var{Internal} argument must uniquely designate +the function to which the +pragma applies. If more than one function name exists of this name in +the declarative part you must use the @code{Parameter_Types} and +@var{Result_Type} parameters to achieve the required unique +designation. Subtype marks in these parameters must exactly match the +subtypes in the corresponding function specification, using positional +notation to match parameters with subtype marks. +The form with an @code{'Access} attribute can be used to match an +anonymous access parameter. + +You may optionally use the @var{Mechanism} and @var{Result_Mechanism} +parameters to specify passing mechanisms for the +parameters and result. If you specify a single mechanism name, it +applies to all parameters. Otherwise you may specify a mechanism on a +parameter by parameter basis using either positional or named +notation. If the mechanism is not specified, the default mechanism +is used. + +@cindex OpenVMS +@cindex Passing by descriptor +Passing by descriptor is supported only on the OpenVMS ports of GNAT@. +The default behavior for Import_Function is to pass a 64bit descriptor +unless short_descriptor is specified, then a 32bit descriptor is passed. + +@code{First_Optional_Parameter} applies only to OpenVMS ports of GNAT@. +It specifies that the designated parameter and all following parameters +are optional, meaning that they are not passed at the generated code +level (this is distinct from the notion of optional parameters in Ada +where the parameters are passed anyway with the designated optional +parameters). All optional parameters must be of mode @code{IN} and have +default parameter values that are either known at compile time +expressions, or uses of the @code{'Null_Parameter} attribute. + +@node Pragma Import_Object +@unnumberedsec Pragma Import_Object +@findex Import_Object +@noindent +Syntax: + +@smallexample @c ada +pragma Import_Object + [Internal =>] LOCAL_NAME + [, [External =>] EXTERNAL_SYMBOL] + [, [Size =>] EXTERNAL_SYMBOL]); + +EXTERNAL_SYMBOL ::= + IDENTIFIER +| static_string_EXPRESSION +@end smallexample + +@noindent +This pragma designates an object as imported, and apart from the +extended rules for external symbols, is identical in effect to the use of +the normal @code{Import} pragma applied to an object. Unlike the +subprogram case, you need not use a separate @code{Import} pragma, +although you may do so (and probably should do so from a portability +point of view). @var{size} is syntax checked, but otherwise ignored by +GNAT@. + +@node Pragma Import_Procedure +@unnumberedsec Pragma Import_Procedure +@findex Import_Procedure +@noindent +Syntax: + +@smallexample @c ada +pragma Import_Procedure ( + [Internal =>] LOCAL_NAME + [, [External =>] EXTERNAL_SYMBOL] + [, [Parameter_Types =>] PARAMETER_TYPES] + [, [Mechanism =>] MECHANISM] + [, [First_Optional_Parameter =>] IDENTIFIER]); + +EXTERNAL_SYMBOL ::= + IDENTIFIER +| static_string_EXPRESSION + +PARAMETER_TYPES ::= + null +| TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} + +TYPE_DESIGNATOR ::= + subtype_NAME +| subtype_Name ' Access + +MECHANISM ::= + MECHANISM_NAME +| (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) + +MECHANISM_ASSOCIATION ::= + [formal_parameter_NAME =>] MECHANISM_NAME + +MECHANISM_NAME ::= + Value +| Reference +| Descriptor [([Class =>] CLASS_NAME)] +| Short_Descriptor [([Class =>] CLASS_NAME)] + +CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca +@end smallexample + +@noindent +This pragma is identical to @code{Import_Function} except that it +applies to a procedure rather than a function and the parameters +@code{Result_Type} and @code{Result_Mechanism} are not permitted. + +@node Pragma Import_Valued_Procedure +@unnumberedsec Pragma Import_Valued_Procedure +@findex Import_Valued_Procedure +@noindent +Syntax: + +@smallexample @c ada +pragma Import_Valued_Procedure ( + [Internal =>] LOCAL_NAME + [, [External =>] EXTERNAL_SYMBOL] + [, [Parameter_Types =>] PARAMETER_TYPES] + [, [Mechanism =>] MECHANISM] + [, [First_Optional_Parameter =>] IDENTIFIER]); + +EXTERNAL_SYMBOL ::= + IDENTIFIER +| static_string_EXPRESSION + +PARAMETER_TYPES ::= + null +| TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} + +TYPE_DESIGNATOR ::= + subtype_NAME +| subtype_Name ' Access + +MECHANISM ::= + MECHANISM_NAME +| (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) + +MECHANISM_ASSOCIATION ::= + [formal_parameter_NAME =>] MECHANISM_NAME + +MECHANISM_NAME ::= + Value +| Reference +| Descriptor [([Class =>] CLASS_NAME)] +| Short_Descriptor [([Class =>] CLASS_NAME)] + +CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca +@end smallexample + +@noindent +This pragma is identical to @code{Import_Procedure} except that the +first parameter of @var{LOCAL_NAME}, which must be present, must be of +mode @code{OUT}, and externally the subprogram is treated as a function +with this parameter as the result of the function. The purpose of this +capability is to allow the use of @code{OUT} and @code{IN OUT} +parameters in interfacing to external functions (which are not permitted +in Ada functions). You may optionally use the @code{Mechanism} +parameters to specify passing mechanisms for the parameters. +If you specify a single mechanism name, it applies to all parameters. +Otherwise you may specify a mechanism on a parameter by parameter +basis using either positional or named notation. If the mechanism is not +specified, the default mechanism is used. + +Note that it is important to use this pragma in conjunction with a separate +pragma Import that specifies the desired convention, since otherwise the +default convention is Ada, which is almost certainly not what is required. + +@node Pragma Initialize_Scalars +@unnumberedsec Pragma Initialize_Scalars +@findex Initialize_Scalars +@cindex debugging with Initialize_Scalars +@noindent +Syntax: + +@smallexample @c ada +pragma Initialize_Scalars; +@end smallexample + +@noindent +This pragma is similar to @code{Normalize_Scalars} conceptually but has +two important differences. First, there is no requirement for the pragma +to be used uniformly in all units of a partition, in particular, it is fine +to use this just for some or all of the application units of a partition, +without needing to recompile the run-time library. + +In the case where some units are compiled with the pragma, and some without, +then a declaration of a variable where the type is defined in package +Standard or is locally declared will always be subject to initialization, +as will any declaration of a scalar variable. For composite variables, +whether the variable is initialized may also depend on whether the package +in which the type of the variable is declared is compiled with the pragma. + +The other important difference is that you can control the value used +for initializing scalar objects. At bind time, you can select several +options for initialization. You can +initialize with invalid values (similar to Normalize_Scalars, though for +Initialize_Scalars it is not always possible to determine the invalid +values in complex cases like signed component fields with non-standard +sizes). You can also initialize with high or +low values, or with a specified bit pattern. See the users guide for binder +options for specifying these cases. + +This means that you can compile a program, and then without having to +recompile the program, you can run it with different values being used +for initializing otherwise uninitialized values, to test if your program +behavior depends on the choice. Of course the behavior should not change, +and if it does, then most likely you have an erroneous reference to an +uninitialized value. + +It is even possible to change the value at execution time eliminating even +the need to rebind with a different switch using an environment variable. +See the GNAT users guide for details. + +Note that pragma @code{Initialize_Scalars} is particularly useful in +conjunction with the enhanced validity checking that is now provided +in GNAT, which checks for invalid values under more conditions. +Using this feature (see description of the @option{-gnatV} flag in the +users guide) in conjunction with pragma @code{Initialize_Scalars} +provides a powerful new tool to assist in the detection of problems +caused by uninitialized variables. + +Note: the use of @code{Initialize_Scalars} has a fairly extensive +effect on the generated code. This may cause your code to be +substantially larger. It may also cause an increase in the amount +of stack required, so it is probably a good idea to turn on stack +checking (see description of stack checking in the GNAT users guide) +when using this pragma. + +@node Pragma Inline_Always +@unnumberedsec Pragma Inline_Always +@findex Inline_Always +@noindent +Syntax: + +@smallexample @c ada +pragma Inline_Always (NAME [, NAME]); +@end smallexample + +@noindent +Similar to pragma @code{Inline} except that inlining is not subject to +the use of option @option{-gnatn} and the inlining happens regardless of +whether this option is used. + +@node Pragma Inline_Generic +@unnumberedsec Pragma Inline_Generic +@findex Inline_Generic +@noindent +Syntax: + +@smallexample @c ada +pragma Inline_Generic (generic_package_NAME); +@end smallexample + +@noindent +This is implemented for compatibility with DEC Ada 83 and is recognized, +but otherwise ignored, by GNAT@. All generic instantiations are inlined +by default when using GNAT@. + +@node Pragma Interface +@unnumberedsec Pragma Interface +@findex Interface +@noindent +Syntax: + +@smallexample @c ada +pragma Interface ( + [Convention =>] convention_identifier, + [Entity =>] local_NAME + [, [External_Name =>] static_string_expression] + [, [Link_Name =>] static_string_expression]); +@end smallexample + +@noindent +This pragma is identical in syntax and semantics to +the standard Ada pragma @code{Import}. It is provided for compatibility +with Ada 83. The definition is upwards compatible both with pragma +@code{Interface} as defined in the Ada 83 Reference Manual, and also +with some extended implementations of this pragma in certain Ada 83 +implementations. The only difference between pragma @code{Interface} +and pragma @code{Import} is that there is special circuitry to allow +both pragmas to appear for the same subprogram entity (normally it +is illegal to have multiple @code{Import} pragmas. This is useful in +maintaining Ada 83/Ada 95 compatibility and is compatible with other +Ada 83 compilers. + +@node Pragma Interface_Name +@unnumberedsec Pragma Interface_Name +@findex Interface_Name +@noindent +Syntax: + +@smallexample @c ada +pragma Interface_Name ( + [Entity =>] LOCAL_NAME + [, [External_Name =>] static_string_EXPRESSION] + [, [Link_Name =>] static_string_EXPRESSION]); +@end smallexample + +@noindent +This pragma provides an alternative way of specifying the interface name +for an interfaced subprogram, and is provided for compatibility with Ada +83 compilers that use the pragma for this purpose. You must provide at +least one of @var{External_Name} or @var{Link_Name}. + +@node Pragma Interrupt_Handler +@unnumberedsec Pragma Interrupt_Handler +@findex Interrupt_Handler +@noindent +Syntax: + +@smallexample @c ada +pragma Interrupt_Handler (procedure_LOCAL_NAME); +@end smallexample + +@noindent +This program unit pragma is supported for parameterless protected procedures +as described in Annex C of the Ada Reference Manual. On the AAMP target +the pragma can also be specified for nonprotected parameterless procedures +that are declared at the library level (which includes procedures +declared at the top level of a library package). In the case of AAMP, +when this pragma is applied to a nonprotected procedure, the instruction +@code{IERET} is generated for returns from the procedure, enabling +maskable interrupts, in place of the normal return instruction. + +@node Pragma Interrupt_State +@unnumberedsec Pragma Interrupt_State +@findex Interrupt_State +@noindent +Syntax: + +@smallexample @c ada +pragma Interrupt_State + ([Name =>] value, + [State =>] SYSTEM | RUNTIME | USER); +@end smallexample + +@noindent +Normally certain interrupts are reserved to the implementation. Any attempt +to attach an interrupt causes Program_Error to be raised, as described in +RM C.3.2(22). A typical example is the @code{SIGINT} interrupt used in +many systems for an @kbd{Ctrl-C} interrupt. Normally this interrupt is +reserved to the implementation, so that @kbd{Ctrl-C} can be used to +interrupt execution. Additionally, signals such as @code{SIGSEGV}, +@code{SIGABRT}, @code{SIGFPE} and @code{SIGILL} are often mapped to specific +Ada exceptions, or used to implement run-time functions such as the +@code{abort} statement and stack overflow checking. + +Pragma @code{Interrupt_State} provides a general mechanism for overriding +such uses of interrupts. It subsumes the functionality of pragma +@code{Unreserve_All_Interrupts}. Pragma @code{Interrupt_State} is not +available on Windows or VMS. On all other platforms than VxWorks, +it applies to signals; on VxWorks, it applies to vectored hardware interrupts +and may be used to mark interrupts required by the board support package +as reserved. + +Interrupts can be in one of three states: +@itemize @bullet +@item System + +The interrupt is reserved (no Ada handler can be installed), and the +Ada run-time may not install a handler. As a result you are guaranteed +standard system default action if this interrupt is raised. + +@item Runtime + +The interrupt is reserved (no Ada handler can be installed). The run time +is allowed to install a handler for internal control purposes, but is +not required to do so. + +@item User + +The interrupt is unreserved. The user may install a handler to provide +some other action. +@end itemize + +@noindent +These states are the allowed values of the @code{State} parameter of the +pragma. The @code{Name} parameter is a value of the type +@code{Ada.Interrupts.Interrupt_ID}. Typically, it is a name declared in +@code{Ada.Interrupts.Names}. + +This is a configuration pragma, and the binder will check that there +are no inconsistencies between different units in a partition in how a +given interrupt is specified. It may appear anywhere a pragma is legal. + +The effect is to move the interrupt to the specified state. + +By declaring interrupts to be SYSTEM, you guarantee the standard system +action, such as a core dump. + +By declaring interrupts to be USER, you guarantee that you can install +a handler. + +Note that certain signals on many operating systems cannot be caught and +handled by applications. In such cases, the pragma is ignored. See the +operating system documentation, or the value of the array @code{Reserved} +declared in the spec of package @code{System.OS_Interface}. + +Overriding the default state of signals used by the Ada runtime may interfere +with an application's runtime behavior in the cases of the synchronous signals, +and in the case of the signal used to implement the @code{abort} statement. + +@node Pragma Invariant +@unnumberedsec Pragma Invariant +@findex Invariant +@noindent +Syntax: + +@smallexample @c ada +pragma Invariant + ([Entity =>] private_type_LOCAL_NAME, + [Check =>] EXPRESSION + [,[Message =>] String_Expression]); +@end smallexample + +@noindent +This pragma provides exactly the same capabilities as the Invariant aspect +defined in AI05-0146-1, and in the Ada 2012 Reference Manual. The Invariant +aspect is fully implemented in Ada 2012 mode, but since it requires the use +of the aspect syntax, which is not available exception in 2012 mode, it is +not possible to use the Invariant aspect in earlier versions of Ada. However +the Invariant pragma may be used in any version of Ada. + +The pragma must appear within the visible part of the package specification, +after the type to which its Entity argument appears. As with the Invariant +aspect, the Check expression is not analyzed until the end of the visible +part of the package, so it may contain forward references. The Message +argument, if present, provides the exception message used if the invariant +is violated. If no Message parameter is provided, a default message that +identifies the line on which the pragma appears is used. + +It is permissible to have multiple Invariants for the same type entity, in +which case they are and'ed together. It is permissible to use this pragma +in Ada 2012 mode, but you cannot have both an invariant aspect and an +invariant pragma for the same entity. + +For further details on the use of this pragma, see the Ada 2012 documentation +of the Invariant aspect. + +@node Pragma Keep_Names +@unnumberedsec Pragma Keep_Names +@findex Keep_Names +@noindent +Syntax: + +@smallexample @c ada +pragma Keep_Names ([On =>] enumeration_first_subtype_LOCAL_NAME); +@end smallexample + +@noindent +The @var{LOCAL_NAME} argument +must refer to an enumeration first subtype +in the current declarative part. The effect is to retain the enumeration +literal names for use by @code{Image} and @code{Value} even if a global +@code{Discard_Names} pragma applies. This is useful when you want to +generally suppress enumeration literal names and for example you therefore +use a @code{Discard_Names} pragma in the @file{gnat.adc} file, but you +want to retain the names for specific enumeration types. + +@node Pragma License +@unnumberedsec Pragma License +@findex License +@cindex License checking +@noindent +Syntax: + +@smallexample @c ada +pragma License (Unrestricted | GPL | Modified_GPL | Restricted); +@end smallexample + +@noindent +This pragma is provided to allow automated checking for appropriate license +conditions with respect to the standard and modified GPL@. A pragma +@code{License}, which is a configuration pragma that typically appears at +the start of a source file or in a separate @file{gnat.adc} file, specifies +the licensing conditions of a unit as follows: + +@itemize @bullet +@item Unrestricted +This is used for a unit that can be freely used with no license restrictions. +Examples of such units are public domain units, and units from the Ada +Reference Manual. + +@item GPL +This is used for a unit that is licensed under the unmodified GPL, and which +therefore cannot be @code{with}'ed by a restricted unit. + +@item Modified_GPL +This is used for a unit licensed under the GNAT modified GPL that includes +a special exception paragraph that specifically permits the inclusion of +the unit in programs without requiring the entire program to be released +under the GPL@. + +@item Restricted +This is used for a unit that is restricted in that it is not permitted to +depend on units that are licensed under the GPL@. Typical examples are +proprietary code that is to be released under more restrictive license +conditions. Note that restricted units are permitted to @code{with} units +which are licensed under the modified GPL (this is the whole point of the +modified GPL). + +@end itemize + +@noindent +Normally a unit with no @code{License} pragma is considered to have an +unknown license, and no checking is done. However, standard GNAT headers +are recognized, and license information is derived from them as follows. + +@itemize @bullet + +A GNAT license header starts with a line containing 78 hyphens. The following +comment text is searched for the appearance of any of the following strings. + +If the string ``GNU General Public License'' is found, then the unit is assumed +to have GPL license, unless the string ``As a special exception'' follows, in +which case the license is assumed to be modified GPL@. + +If one of the strings +``This specification is adapted from the Ada Semantic Interface'' or +``This specification is derived from the Ada Reference Manual'' is found +then the unit is assumed to be unrestricted. +@end itemize + +@noindent +These default actions means that a program with a restricted license pragma +will automatically get warnings if a GPL unit is inappropriately +@code{with}'ed. For example, the program: + +@smallexample @c ada +with Sem_Ch3; +with GNAT.Sockets; +procedure Secret_Stuff is + @dots{} +end Secret_Stuff +@end smallexample + +@noindent +if compiled with pragma @code{License} (@code{Restricted}) in a +@file{gnat.adc} file will generate the warning: + +@smallexample +1. with Sem_Ch3; + | + >>> license of withed unit "Sem_Ch3" is incompatible + +2. with GNAT.Sockets; +3. procedure Secret_Stuff is +@end smallexample + +@noindent +Here we get a warning on @code{Sem_Ch3} since it is part of the GNAT +compiler and is licensed under the +GPL, but no warning for @code{GNAT.Sockets} which is part of the GNAT +run time, and is therefore licensed under the modified GPL@. + +@node Pragma Link_With +@unnumberedsec Pragma Link_With +@findex Link_With +@noindent +Syntax: + +@smallexample @c ada +pragma Link_With (static_string_EXPRESSION @{,static_string_EXPRESSION@}); +@end smallexample + +@noindent +This pragma is provided for compatibility with certain Ada 83 compilers. +It has exactly the same effect as pragma @code{Linker_Options} except +that spaces occurring within one of the string expressions are treated +as separators. For example, in the following case: + +@smallexample @c ada +pragma Link_With ("-labc -ldef"); +@end smallexample + +@noindent +results in passing the strings @code{-labc} and @code{-ldef} as two +separate arguments to the linker. In addition pragma Link_With allows +multiple arguments, with the same effect as successive pragmas. + +@node Pragma Linker_Alias +@unnumberedsec Pragma Linker_Alias +@findex Linker_Alias +@noindent +Syntax: + +@smallexample @c ada +pragma Linker_Alias ( + [Entity =>] LOCAL_NAME, + [Target =>] static_string_EXPRESSION); +@end smallexample + +@noindent +@var{LOCAL_NAME} must refer to an object that is declared at the library +level. This pragma establishes the given entity as a linker alias for the +given target. It is equivalent to @code{__attribute__((alias))} in GNU C +and causes @var{LOCAL_NAME} to be emitted as an alias for the symbol +@var{static_string_EXPRESSION} in the object file, that is to say no space +is reserved for @var{LOCAL_NAME} by the assembler and it will be resolved +to the same address as @var{static_string_EXPRESSION} by the linker. + +The actual linker name for the target must be used (e.g.@: the fully +encoded name with qualification in Ada, or the mangled name in C++), +or it must be declared using the C convention with @code{pragma Import} +or @code{pragma Export}. + +Not all target machines support this pragma. On some of them it is accepted +only if @code{pragma Weak_External} has been applied to @var{LOCAL_NAME}. + +@smallexample @c ada +-- Example of the use of pragma Linker_Alias + +package p is + i : Integer := 1; + pragma Export (C, i); + + new_name_for_i : Integer; + pragma Linker_Alias (new_name_for_i, "i"); +end p; +@end smallexample + +@node Pragma Linker_Constructor +@unnumberedsec Pragma Linker_Constructor +@findex Linker_Constructor +@noindent +Syntax: + +@smallexample @c ada +pragma Linker_Constructor (procedure_LOCAL_NAME); +@end smallexample + +@noindent +@var{procedure_LOCAL_NAME} must refer to a parameterless procedure that +is declared at the library level. A procedure to which this pragma is +applied will be treated as an initialization routine by the linker. +It is equivalent to @code{__attribute__((constructor))} in GNU C and +causes @var{procedure_LOCAL_NAME} to be invoked before the entry point +of the executable is called (or immediately after the shared library is +loaded if the procedure is linked in a shared library), in particular +before the Ada run-time environment is set up. + +Because of these specific contexts, the set of operations such a procedure +can perform is very limited and the type of objects it can manipulate is +essentially restricted to the elementary types. In particular, it must only +contain code to which pragma Restrictions (No_Elaboration_Code) applies. + +This pragma is used by GNAT to implement auto-initialization of shared Stand +Alone Libraries, which provides a related capability without the restrictions +listed above. Where possible, the use of Stand Alone Libraries is preferable +to the use of this pragma. + +@node Pragma Linker_Destructor +@unnumberedsec Pragma Linker_Destructor +@findex Linker_Destructor +@noindent +Syntax: + +@smallexample @c ada +pragma Linker_Destructor (procedure_LOCAL_NAME); +@end smallexample + +@noindent +@var{procedure_LOCAL_NAME} must refer to a parameterless procedure that +is declared at the library level. A procedure to which this pragma is +applied will be treated as a finalization routine by the linker. +It is equivalent to @code{__attribute__((destructor))} in GNU C and +causes @var{procedure_LOCAL_NAME} to be invoked after the entry point +of the executable has exited (or immediately before the shared library +is unloaded if the procedure is linked in a shared library), in particular +after the Ada run-time environment is shut down. + +See @code{pragma Linker_Constructor} for the set of restrictions that apply +because of these specific contexts. + +@node Pragma Linker_Section +@unnumberedsec Pragma Linker_Section +@findex Linker_Section +@noindent +Syntax: + +@smallexample @c ada +pragma Linker_Section ( + [Entity =>] LOCAL_NAME, + [Section =>] static_string_EXPRESSION); +@end smallexample + +@noindent +@var{LOCAL_NAME} must refer to an object that is declared at the library +level. This pragma specifies the name of the linker section for the given +entity. It is equivalent to @code{__attribute__((section))} in GNU C and +causes @var{LOCAL_NAME} to be placed in the @var{static_string_EXPRESSION} +section of the executable (assuming the linker doesn't rename the section). + +The compiler normally places library-level objects in standard sections +depending on their type: procedures and functions generally go in the +@code{.text} section, initialized variables in the @code{.data} section +and uninitialized variables in the @code{.bss} section. + +Other, special sections may exist on given target machines to map special +hardware, for example I/O ports or flash memory. This pragma is a means to +defer the final layout of the executable to the linker, thus fully working +at the symbolic level with the compiler. + +Some file formats do not support arbitrary sections so not all target +machines support this pragma. The use of this pragma may cause a program +execution to be erroneous if it is used to place an entity into an +inappropriate section (e.g.@: a modified variable into the @code{.text} +section). See also @code{pragma Persistent_BSS}. + +@smallexample @c ada +-- Example of the use of pragma Linker_Section + +package IO_Card is + Port_A : Integer; + pragma Volatile (Port_A); + pragma Linker_Section (Port_A, ".bss.port_a"); + + Port_B : Integer; + pragma Volatile (Port_B); + pragma Linker_Section (Port_B, ".bss.port_b"); +end IO_Card; +@end smallexample + +@node Pragma Long_Float +@unnumberedsec Pragma Long_Float +@cindex OpenVMS +@findex Long_Float +@noindent +Syntax: + +@smallexample @c ada +pragma Long_Float (FLOAT_FORMAT); + +FLOAT_FORMAT ::= D_Float | G_Float +@end smallexample + +@noindent +This pragma is implemented only in the OpenVMS implementation of GNAT@. +It allows control over the internal representation chosen for the predefined +type @code{Long_Float} and for floating point type representations with +@code{digits} specified in the range 7 through 15. +For further details on this pragma, see the +@cite{DEC Ada Language Reference Manual}, section 3.5.7b. Note that to use +this pragma, the standard runtime libraries must be recompiled. + +@node Pragma Machine_Attribute +@unnumberedsec Pragma Machine_Attribute +@findex Machine_Attribute +@noindent +Syntax: + +@smallexample @c ada +pragma Machine_Attribute ( + [Entity =>] LOCAL_NAME, + [Attribute_Name =>] static_string_EXPRESSION + [, [Info =>] static_EXPRESSION] ); +@end smallexample + +@noindent +Machine-dependent attributes can be specified for types and/or +declarations. This pragma is semantically equivalent to +@code{__attribute__((@var{attribute_name}))} (if @var{info} is not +specified) or @code{__attribute__((@var{attribute_name}(@var{info})))} +in GNU C, where @code{@var{attribute_name}} is recognized by the +compiler middle-end or the @code{TARGET_ATTRIBUTE_TABLE} machine +specific macro. A string literal for the optional parameter @var{info} +is transformed into an identifier, which may make this pragma unusable +for some attributes. @xref{Target Attributes,, Defining target-specific +uses of @code{__attribute__}, gccint, GNU Compiler Collection (GCC) +Internals}, further information. + +@node Pragma Main +@unnumberedsec Pragma Main +@cindex OpenVMS +@findex Main +@noindent +Syntax: + +@smallexample @c ada +pragma Main + (MAIN_OPTION [, MAIN_OPTION]); + +MAIN_OPTION ::= + [Stack_Size =>] static_integer_EXPRESSION +| [Task_Stack_Size_Default =>] static_integer_EXPRESSION +| [Time_Slicing_Enabled =>] static_boolean_EXPRESSION +@end smallexample + +@noindent +This pragma is provided for compatibility with OpenVMS VAX Systems. It has +no effect in GNAT, other than being syntax checked. + +@node Pragma Main_Storage +@unnumberedsec Pragma Main_Storage +@cindex OpenVMS +@findex Main_Storage +@noindent +Syntax: + +@smallexample @c ada +pragma Main_Storage + (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]); + +MAIN_STORAGE_OPTION ::= + [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION +| [TOP_GUARD =>] static_SIMPLE_EXPRESSION +@end smallexample + +@noindent +This pragma is provided for compatibility with OpenVMS VAX Systems. It has +no effect in GNAT, other than being syntax checked. Note that the pragma +also has no effect in DEC Ada 83 for OpenVMS Alpha Systems. + +@node Pragma No_Body +@unnumberedsec Pragma No_Body +@findex No_Body +@noindent +Syntax: + +@smallexample @c ada +pragma No_Body; +@end smallexample + +@noindent +There are a number of cases in which a package spec does not require a body, +and in fact a body is not permitted. GNAT will not permit the spec to be +compiled if there is a body around. The pragma No_Body allows you to provide +a body file, even in a case where no body is allowed. The body file must +contain only comments and a single No_Body pragma. This is recognized by +the compiler as indicating that no body is logically present. + +This is particularly useful during maintenance when a package is modified in +such a way that a body needed before is no longer needed. The provision of a +dummy body with a No_Body pragma ensures that there is no interference from +earlier versions of the package body. + +@node Pragma No_Return +@unnumberedsec Pragma No_Return +@findex No_Return +@noindent +Syntax: + +@smallexample @c ada +pragma No_Return (procedure_LOCAL_NAME @{, procedure_LOCAL_NAME@}); +@end smallexample + +@noindent +Each @var{procedure_LOCAL_NAME} argument must refer to one or more procedure +declarations in the current declarative part. A procedure to which this +pragma is applied may not contain any explicit @code{return} statements. +In addition, if the procedure contains any implicit returns from falling +off the end of a statement sequence, then execution of that implicit +return will cause Program_Error to be raised. + +One use of this pragma is to identify procedures whose only purpose is to raise +an exception. Another use of this pragma is to suppress incorrect warnings +about missing returns in functions, where the last statement of a function +statement sequence is a call to such a procedure. + +Note that in Ada 2005 mode, this pragma is part of the language, and is +identical in effect to the pragma as implemented in Ada 95 mode. + +@node Pragma No_Strict_Aliasing +@unnumberedsec Pragma No_Strict_Aliasing +@findex No_Strict_Aliasing +@noindent +Syntax: + +@smallexample @c ada +pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)]; +@end smallexample + +@noindent +@var{type_LOCAL_NAME} must refer to an access type +declaration in the current declarative part. The effect is to inhibit +strict aliasing optimization for the given type. The form with no +arguments is a configuration pragma which applies to all access types +declared in units to which the pragma applies. For a detailed +description of the strict aliasing optimization, and the situations +in which it must be suppressed, see @ref{Optimization and Strict +Aliasing,,, gnat_ugn, @value{EDITION} User's Guide}. + +@node Pragma Normalize_Scalars +@unnumberedsec Pragma Normalize_Scalars +@findex Normalize_Scalars +@noindent +Syntax: + +@smallexample @c ada +pragma Normalize_Scalars; +@end smallexample + +@noindent +This is a language defined pragma which is fully implemented in GNAT@. The +effect is to cause all scalar objects that are not otherwise initialized +to be initialized. The initial values are implementation dependent and +are as follows: + +@table @code +@item Standard.Character +@noindent +Objects whose root type is Standard.Character are initialized to +Character'Last unless the subtype range excludes NUL (in which case +NUL is used). This choice will always generate an invalid value if +one exists. + +@item Standard.Wide_Character +@noindent +Objects whose root type is Standard.Wide_Character are initialized to +Wide_Character'Last unless the subtype range excludes NUL (in which case +NUL is used). This choice will always generate an invalid value if +one exists. + +@item Standard.Wide_Wide_Character +@noindent +Objects whose root type is Standard.Wide_Wide_Character are initialized to +the invalid value 16#FFFF_FFFF# unless the subtype range excludes NUL (in +which case NUL is used). This choice will always generate an invalid value if +one exists. + +@item Integer types +@noindent +Objects of an integer type are treated differently depending on whether +negative values are present in the subtype. If no negative values are +present, then all one bits is used as the initial value except in the +special case where zero is excluded from the subtype, in which case +all zero bits are used. This choice will always generate an invalid +value if one exists. + +For subtypes with negative values present, the largest negative number +is used, except in the unusual case where this largest negative number +is in the subtype, and the largest positive number is not, in which case +the largest positive value is used. This choice will always generate +an invalid value if one exists. + +@item Floating-Point Types +Objects of all floating-point types are initialized to all 1-bits. For +standard IEEE format, this corresponds to a NaN (not a number) which is +indeed an invalid value. + +@item Fixed-Point Types +Objects of all fixed-point types are treated as described above for integers, +with the rules applying to the underlying integer value used to represent +the fixed-point value. + +@item Modular types +Objects of a modular type are initialized to all one bits, except in +the special case where zero is excluded from the subtype, in which +case all zero bits are used. This choice will always generate an +invalid value if one exists. + +@item Enumeration types +Objects of an enumeration type are initialized to all one-bits, i.e.@: to +the value @code{2 ** typ'Size - 1} unless the subtype excludes the literal +whose Pos value is zero, in which case a code of zero is used. This choice +will always generate an invalid value if one exists. + +@end table + +@node Pragma Obsolescent +@unnumberedsec Pragma Obsolescent +@findex Obsolescent +@noindent +Syntax: + +@smallexample @c ada +pragma Obsolescent; + +pragma Obsolescent ( + [Message =>] static_string_EXPRESSION +[,[Version =>] Ada_05]]); + +pragma Obsolescent ( + [Entity =>] NAME +[,[Message =>] static_string_EXPRESSION +[,[Version =>] Ada_05]] ); +@end smallexample + +@noindent +This pragma can occur immediately following a declaration of an entity, +including the case of a record component. If no Entity argument is present, +then this declaration is the one to which the pragma applies. If an Entity +parameter is present, it must either match the name of the entity in this +declaration, or alternatively, the pragma can immediately follow an enumeration +type declaration, where the Entity argument names one of the enumeration +literals. + +This pragma is used to indicate that the named entity +is considered obsolescent and should not be used. Typically this is +used when an API must be modified by eventually removing or modifying +existing subprograms or other entities. The pragma can be used at an +intermediate stage when the entity is still present, but will be +removed later. + +The effect of this pragma is to output a warning message on a reference to +an entity thus marked that the subprogram is obsolescent if the appropriate +warning option in the compiler is activated. If the Message parameter is +present, then a second warning message is given containing this text. In +addition, a reference to the entity is considered to be a violation of pragma +Restrictions (No_Obsolescent_Features). + +This pragma can also be used as a program unit pragma for a package, +in which case the entity name is the name of the package, and the +pragma indicates that the entire package is considered +obsolescent. In this case a client @code{with}'ing such a package +violates the restriction, and the @code{with} statement is +flagged with warnings if the warning option is set. + +If the Version parameter is present (which must be exactly +the identifier Ada_05, no other argument is allowed), then the +indication of obsolescence applies only when compiling in Ada 2005 +mode. This is primarily intended for dealing with the situations +in the predefined library where subprograms or packages +have become defined as obsolescent in Ada 2005 +(e.g.@: in Ada.Characters.Handling), but may be used anywhere. + +The following examples show typical uses of this pragma: + +@smallexample @c ada +package p is + pragma Obsolescent (p, Message => "use pp instead of p"); +end p; + +package q is + procedure q2; + pragma Obsolescent ("use q2new instead"); + + type R is new integer; + pragma Obsolescent + (Entity => R, + Message => "use RR in Ada 2005", + Version => Ada_05); + + type M is record + F1 : Integer; + F2 : Integer; + pragma Obsolescent; + F3 : Integer; + end record; + + type E is (a, bc, 'd', quack); + pragma Obsolescent (Entity => bc) + pragma Obsolescent (Entity => 'd') + + function "+" + (a, b : character) return character; + pragma Obsolescent (Entity => "+"); +end; +@end smallexample + +@noindent +Note that, as for all pragmas, if you use a pragma argument identifier, +then all subsequent parameters must also use a pragma argument identifier. +So if you specify "Entity =>" for the Entity argument, and a Message +argument is present, it must be preceded by "Message =>". + +@node Pragma Optimize_Alignment +@unnumberedsec Pragma Optimize_Alignment +@findex Optimize_Alignment +@cindex Alignment, default settings +@noindent +Syntax: + +@smallexample @c ada +pragma Optimize_Alignment (TIME | SPACE | OFF); +@end smallexample + +@noindent +This is a configuration pragma which affects the choice of default alignments +for types where no alignment is explicitly specified. There is a time/space +trade-off in the selection of these values. Large alignments result in more +efficient code, at the expense of larger data space, since sizes have to be +increased to match these alignments. Smaller alignments save space, but the +access code is slower. The normal choice of default alignments (which is what +you get if you do not use this pragma, or if you use an argument of OFF), +tries to balance these two requirements. + +Specifying SPACE causes smaller default alignments to be chosen in two cases. +First any packed record is given an alignment of 1. Second, if a size is given +for the type, then the alignment is chosen to avoid increasing this size. For +example, consider: + +@smallexample @c ada + type R is record + X : Integer; + Y : Character; + end record; + + for R'Size use 5*8; +@end smallexample + +@noindent +In the default mode, this type gets an alignment of 4, so that access to the +Integer field X are efficient. But this means that objects of the type end up +with a size of 8 bytes. This is a valid choice, since sizes of objects are +allowed to be bigger than the size of the type, but it can waste space if for +example fields of type R appear in an enclosing record. If the above type is +compiled in @code{Optimize_Alignment (Space)} mode, the alignment is set to 1. + +Specifying TIME causes larger default alignments to be chosen in the case of +small types with sizes that are not a power of 2. For example, consider: + +@smallexample @c ada + type R is record + A : Character; + B : Character; + C : Boolean; + end record; + + pragma Pack (R); + for R'Size use 17; +@end smallexample + +@noindent +The default alignment for this record is normally 1, but if this type is +compiled in @code{Optimize_Alignment (Time)} mode, then the alignment is set +to 4, which wastes space for objects of the type, since they are now 4 bytes +long, but results in more efficient access when the whole record is referenced. + +As noted above, this is a configuration pragma, and there is a requirement +that all units in a partition be compiled with a consistent setting of the +optimization setting. This would normally be achieved by use of a configuration +pragma file containing the appropriate setting. The exception to this rule is +that units with an explicit configuration pragma in the same file as the source +unit are excluded from the consistency check, as are all predefined units. The +latter are compiled by default in pragma Optimize_Alignment (Off) mode if no +pragma appears at the start of the file. + +@node Pragma Ordered +@unnumberedsec Pragma Ordered +@findex Ordered +@findex pragma @code{Ordered} +@noindent +Syntax: + +@smallexample @c ada +pragma Ordered (enumeration_first_subtype_LOCAL_NAME); +@end smallexample + +@noindent +Most enumeration types are from a conceptual point of view unordered. +For example, consider: + +@smallexample @c ada +type Color is (Red, Blue, Green, Yellow); +@end smallexample + +@noindent +By Ada semantics @code{Blue > Red} and @code{Green > Blue}, +but really these relations make no sense; the enumeration type merely +specifies a set of possible colors, and the order is unimportant. + +For unordered enumeration types, it is generally a good idea if +clients avoid comparisons (other than equality or inequality) and +explicit ranges. (A @emph{client} is a unit where the type is referenced, +other than the unit where the type is declared, its body, and its subunits.) +For example, if code buried in some client says: + +@smallexample @c ada +if Current_Color < Yellow then ... +if Current_Color in Blue .. Green then ... +@end smallexample + +@noindent +then the client code is relying on the order, which is undesirable. +It makes the code hard to read and creates maintenance difficulties if +entries have to be added to the enumeration type. Instead, +the code in the client should list the possibilities, or an +appropriate subtype should be declared in the unit that declares +the original enumeration type. E.g., the following subtype could +be declared along with the type @code{Color}: + +@smallexample @c ada +subtype RBG is Color range Red .. Green; +@end smallexample + +@noindent +and then the client could write: + +@smallexample @c ada +if Current_Color in RBG then ... +if Current_Color = Blue or Current_Color = Green then ... +@end smallexample + +@noindent +However, some enumeration types are legitimately ordered from a conceptual +point of view. For example, if you declare: + +@smallexample @c ada +type Day is (Mon, Tue, Wed, Thu, Fri, Sat, Sun); +@end smallexample + +@noindent +then the ordering imposed by the language is reasonable, and +clients can depend on it, writing for example: + +@smallexample @c ada +if D in Mon .. Fri then ... +if D < Wed then ... +@end smallexample + +@noindent +The pragma @option{Ordered} is provided to mark enumeration types that +are conceptually ordered, alerting the reader that clients may depend +on the ordering. GNAT provides a pragma to mark enumerations as ordered +rather than one to mark them as unordered, since in our experience, +the great majority of enumeration types are conceptually unordered. + +The types @code{Boolean}, @code{Character}, @code{Wide_Character}, +and @code{Wide_Wide_Character} +are considered to be ordered types, so each is declared with a +pragma @code{Ordered} in package @code{Standard}. + +Normally pragma @code{Ordered} serves only as documentation and a guide for +coding standards, but GNAT provides a warning switch @option{-gnatw.u} that +requests warnings for inappropriate uses (comparisons and explicit +subranges) for unordered types. If this switch is used, then any +enumeration type not marked with pragma @code{Ordered} will be considered +as unordered, and will generate warnings for inappropriate uses. + +For additional information please refer to the description of the +@option{-gnatw.u} switch in the @value{EDITION} User's Guide. + +@node Pragma Passive +@unnumberedsec Pragma Passive +@findex Passive +@noindent +Syntax: + +@smallexample @c ada +pragma Passive [(Semaphore | No)]; +@end smallexample + +@noindent +Syntax checked, but otherwise ignored by GNAT@. This is recognized for +compatibility with DEC Ada 83 implementations, where it is used within a +task definition to request that a task be made passive. If the argument +@code{Semaphore} is present, or the argument is omitted, then DEC Ada 83 +treats the pragma as an assertion that the containing task is passive +and that optimization of context switch with this task is permitted and +desired. If the argument @code{No} is present, the task must not be +optimized. GNAT does not attempt to optimize any tasks in this manner +(since protected objects are available in place of passive tasks). + +@node Pragma Persistent_BSS +@unnumberedsec Pragma Persistent_BSS +@findex Persistent_BSS +@noindent +Syntax: + +@smallexample @c ada +pragma Persistent_BSS [(LOCAL_NAME)] +@end smallexample + +@noindent +This pragma allows selected objects to be placed in the @code{.persistent_bss} +section. On some targets the linker and loader provide for special +treatment of this section, allowing a program to be reloaded without +affecting the contents of this data (hence the name persistent). + +There are two forms of usage. If an argument is given, it must be the +local name of a library level object, with no explicit initialization +and whose type is potentially persistent. If no argument is given, then +the pragma is a configuration pragma, and applies to all library level +objects with no explicit initialization of potentially persistent types. + +A potentially persistent type is a scalar type, or a non-tagged, +non-discriminated record, all of whose components have no explicit +initialization and are themselves of a potentially persistent type, +or an array, all of whose constraints are static, and whose component +type is potentially persistent. + +If this pragma is used on a target where this feature is not supported, +then the pragma will be ignored. See also @code{pragma Linker_Section}. + +@node Pragma Polling +@unnumberedsec Pragma Polling +@findex Polling +@noindent +Syntax: + +@smallexample @c ada +pragma Polling (ON | OFF); +@end smallexample + +@noindent +This pragma controls the generation of polling code. This is normally off. +If @code{pragma Polling (ON)} is used then periodic calls are generated to +the routine @code{Ada.Exceptions.Poll}. This routine is a separate unit in the +runtime library, and can be found in file @file{a-excpol.adb}. + +Pragma @code{Polling} can appear as a configuration pragma (for example it +can be placed in the @file{gnat.adc} file) to enable polling globally, or it +can be used in the statement or declaration sequence to control polling +more locally. + +A call to the polling routine is generated at the start of every loop and +at the start of every subprogram call. This guarantees that the @code{Poll} +routine is called frequently, and places an upper bound (determined by +the complexity of the code) on the period between two @code{Poll} calls. + +The primary purpose of the polling interface is to enable asynchronous +aborts on targets that cannot otherwise support it (for example Windows +NT), but it may be used for any other purpose requiring periodic polling. +The standard version is null, and can be replaced by a user program. This +will require re-compilation of the @code{Ada.Exceptions} package that can +be found in files @file{a-except.ads} and @file{a-except.adb}. + +A standard alternative unit (in file @file{4wexcpol.adb} in the standard GNAT +distribution) is used to enable the asynchronous abort capability on +targets that do not normally support the capability. The version of +@code{Poll} in this file makes a call to the appropriate runtime routine +to test for an abort condition. + +Note that polling can also be enabled by use of the @option{-gnatP} switch. +@xref{Switches for gcc,,, gnat_ugn, @value{EDITION} User's Guide}, for +details. + +@node Pragma Postcondition +@unnumberedsec Pragma Postcondition +@cindex Postconditions +@cindex Checks, postconditions +@findex Postconditions +@noindent +Syntax: + +@smallexample @c ada +pragma Postcondition ( + [Check =>] Boolean_Expression + [,[Message =>] String_Expression]); +@end smallexample + +@noindent +The @code{Postcondition} pragma allows specification of automatic +postcondition checks for subprograms. These checks are similar to +assertions, but are automatically inserted just prior to the return +statements of the subprogram with which they are associated (including +implicit returns at the end of procedure bodies and associated +exception handlers). + +In addition, the boolean expression which is the condition which +must be true may contain references to function'Result in the case +of a function to refer to the returned value. + +@code{Postcondition} pragmas may appear either immediate following the +(separate) declaration of a subprogram, or at the start of the +declarations of a subprogram body. Only other pragmas may intervene +(that is appear between the subprogram declaration and its +postconditions, or appear before the postcondition in the +declaration sequence in a subprogram body). In the case of a +postcondition appearing after a subprogram declaration, the +formal arguments of the subprogram are visible, and can be +referenced in the postcondition expressions. + +The postconditions are collected and automatically tested just +before any return (implicit or explicit) in the subprogram body. +A postcondition is only recognized if postconditions are active +at the time the pragma is encountered. The compiler switch @option{gnata} +turns on all postconditions by default, and pragma @code{Check_Policy} +with an identifier of @code{Postcondition} can also be used to +control whether postconditions are active. + +The general approach is that postconditions are placed in the spec +if they represent functional aspects which make sense to the client. +For example we might have: + +@smallexample @c ada + function Direction return Integer; + pragma Postcondition + (Direction'Result = +1 + or else + Direction'Result = -1); +@end smallexample + +@noindent +which serves to document that the result must be +1 or -1, and +will test that this is the case at run time if postcondition +checking is active. + +Postconditions within the subprogram body can be used to +check that some internal aspect of the implementation, +not visible to the client, is operating as expected. +For instance if a square root routine keeps an internal +counter of the number of times it is called, then we +might have the following postcondition: + +@smallexample @c ada + Sqrt_Calls : Natural := 0; + + function Sqrt (Arg : Float) return Float is + pragma Postcondition + (Sqrt_Calls = Sqrt_Calls'Old + 1); + ... + end Sqrt +@end smallexample + +@noindent +As this example, shows, the use of the @code{Old} attribute +is often useful in postconditions to refer to the state on +entry to the subprogram. + +Note that postconditions are only checked on normal returns +from the subprogram. If an abnormal return results from +raising an exception, then the postconditions are not checked. + +If a postcondition fails, then the exception +@code{System.Assertions.Assert_Failure} is raised. If +a message argument was supplied, then the given string +will be used as the exception message. If no message +argument was supplied, then the default message has +the form "Postcondition failed at file:line". The +exception is raised in the context of the subprogram +body, so it is possible to catch postcondition failures +within the subprogram body itself. + +Within a package spec, normal visibility rules +in Ada would prevent forward references within a +postcondition pragma to functions defined later in +the same package. This would introduce undesirable +ordering constraints. To avoid this problem, all +postcondition pragmas are analyzed at the end of +the package spec, allowing forward references. + +The following example shows that this even allows +mutually recursive postconditions as in: + +@smallexample @c ada +package Parity_Functions is + function Odd (X : Natural) return Boolean; + pragma Postcondition + (Odd'Result = + (x = 1 + or else + (x /= 0 and then Even (X - 1)))); + + function Even (X : Natural) return Boolean; + pragma Postcondition + (Even'Result = + (x = 0 + or else + (x /= 1 and then Odd (X - 1)))); + +end Parity_Functions; +@end smallexample + +@noindent +There are no restrictions on the complexity or form of +conditions used within @code{Postcondition} pragmas. +The following example shows that it is even possible +to verify performance behavior. + +@smallexample @c ada +package Sort is + + Performance : constant Float; + -- Performance constant set by implementation + -- to match target architecture behavior. + + procedure Treesort (Arg : String); + -- Sorts characters of argument using N*logN sort + pragma Postcondition + (Float (Clock - Clock'Old) <= + Float (Arg'Length) * + log (Float (Arg'Length)) * + Performance); +end Sort; +@end smallexample + +@noindent +Note: postcondition pragmas associated with subprograms that are +marked as Inline_Always, or those marked as Inline with front-end +inlining (-gnatN option set) are accepted and legality-checked +by the compiler, but are ignored at run-time even if postcondition +checking is enabled. + +@node Pragma Precondition +@unnumberedsec Pragma Precondition +@cindex Preconditions +@cindex Checks, preconditions +@findex Preconditions +@noindent +Syntax: + +@smallexample @c ada +pragma Precondition ( + [Check =>] Boolean_Expression + [,[Message =>] String_Expression]); +@end smallexample + +@noindent +The @code{Precondition} pragma is similar to @code{Postcondition} +except that the corresponding checks take place immediately upon +entry to the subprogram, and if a precondition fails, the exception +is raised in the context of the caller, and the attribute 'Result +cannot be used within the precondition expression. + +Otherwise, the placement and visibility rules are identical to those +described for postconditions. The following is an example of use +within a package spec: + +@smallexample @c ada +package Math_Functions is + ... + function Sqrt (Arg : Float) return Float; + pragma Precondition (Arg >= 0.0) + ... +end Math_Functions; +@end smallexample + +@noindent +@code{Precondition} pragmas may appear either immediate following the +(separate) declaration of a subprogram, or at the start of the +declarations of a subprogram body. Only other pragmas may intervene +(that is appear between the subprogram declaration and its +postconditions, or appear before the postcondition in the +declaration sequence in a subprogram body). + +Note: postcondition pragmas associated with subprograms that are +marked as Inline_Always, or those marked as Inline with front-end +inlining (-gnatN option set) are accepted and legality-checked +by the compiler, but are ignored at run-time even if postcondition +checking is enabled. + +@node Pragma Profile (Ravenscar) +@unnumberedsec Pragma Profile (Ravenscar) +@findex Ravenscar +@noindent +Syntax: + +@smallexample @c ada +pragma Profile (Ravenscar); +@end smallexample + +@noindent +A configuration pragma that establishes the following set of configuration +pragmas: + +@table @code +@item Task_Dispatching_Policy (FIFO_Within_Priorities) +[RM D.2.2] Tasks are dispatched following a preemptive +priority-ordered scheduling policy. + +@item Locking_Policy (Ceiling_Locking) +[RM D.3] While tasks and interrupts execute a protected action, they inherit +the ceiling priority of the corresponding protected object. +@c +@c @item Detect_Blocking +@c This pragma forces the detection of potentially blocking operations within a +@c protected operation, and to raise Program_Error if that happens. +@end table +@noindent + +plus the following set of restrictions: + +@table @code +@item Max_Entry_Queue_Length = 1 +Defines the maximum number of calls that are queued on a (protected) entry. +Note that this restrictions is checked at run time. Violation of this +restriction results in the raising of Program_Error exception at the point of +the call. For the Profile (Ravenscar) the value of Max_Entry_Queue_Length is +always 1 and hence no task can be queued on a protected entry. + +@item Max_Protected_Entries = 1 +[RM D.7] Specifies the maximum number of entries per protected type. The +bounds of every entry family of a protected unit shall be static, or shall be +defined by a discriminant of a subtype whose corresponding bound is static. +For the Profile (Ravenscar) the value of Max_Protected_Entries is always 1. + +@item Max_Task_Entries = 0 +[RM D.7] Specifies the maximum number of entries +per task. The bounds of every entry family +of a task unit shall be static, or shall be +defined by a discriminant of a subtype whose +corresponding bound is static. A value of zero +indicates that no rendezvous are possible. For +the Profile (Ravenscar), the value of Max_Task_Entries is always +0 (zero). + +@item No_Abort_Statements +[RM D.7] There are no abort_statements, and there are +no calls to Task_Identification.Abort_Task. + +@item No_Asynchronous_Control +There are no semantic dependences on the package +Asynchronous_Task_Control. + +@item No_Calendar +There are no semantic dependencies on the package Ada.Calendar. + +@item No_Dynamic_Attachment +There is no call to any of the operations defined in package Ada.Interrupts +(Is_Reserved, Is_Attached, Current_Handler, Attach_Handler, Exchange_Handler, +Detach_Handler, and Reference). + +@item No_Dynamic_Priorities +[RM D.7] There are no semantic dependencies on the package Dynamic_Priorities. + +@item No_Implicit_Heap_Allocations +[RM D.7] No constructs are allowed to cause implicit heap allocation. + +@item No_Local_Protected_Objects +Protected objects and access types that designate +such objects shall be declared only at library level. + +@item No_Local_Timing_Events +[RM D.7] All objects of type Ada.Timing_Events.Timing_Event are +declared at the library level. + +@item No_Protected_Type_Allocators +There are no allocators for protected types or +types containing protected subcomponents. + +@item No_Relative_Delay +There are no delay_relative statements. + +@item No_Requeue_Statements +Requeue statements are not allowed. + +@item No_Select_Statements +There are no select_statements. + +@item No_Specific_Termination_Handlers +[RM D.7] There are no calls to Ada.Task_Termination.Set_Specific_Handler +or to Ada.Task_Termination.Specific_Handler. + +@item No_Task_Allocators +[RM D.7] There are no allocators for task types +or types containing task subcomponents. + +@item No_Task_Attributes_Package +There are no semantic dependencies on the Ada.Task_Attributes package. + +@item No_Task_Hierarchy +[RM D.7] All (non-environment) tasks depend +directly on the environment task of the partition. + +@item No_Task_Termination +Tasks which terminate are erroneous. + +@item No_Unchecked_Conversion +There are no semantic dependencies on the Ada.Unchecked_Conversion package. + +@item No_Unchecked_Deallocation +There are no semantic dependencies on the Ada.Unchecked_Deallocation package. + +@item Simple_Barriers +Entry barrier condition expressions shall be either static +boolean expressions or boolean objects which are declared in +the protected type which contains the entry. +@end table + +@noindent +This set of configuration pragmas and restrictions correspond to the +definition of the ``Ravenscar Profile'' for limited tasking, devised and +published by the @cite{International Real-Time Ada Workshop}, 1997, +and whose most recent description is available at +@url{http://www-users.cs.york.ac.uk/~burns/ravenscar.ps}. + +The original definition of the profile was revised at subsequent IRTAW +meetings. It has been included in the ISO +@cite{Guide for the Use of the Ada Programming Language in High +Integrity Systems}, and has been approved by ISO/IEC/SC22/WG9 for inclusion in +the next revision of the standard. The formal definition given by +the Ada Rapporteur Group (ARG) can be found in two Ada Issues (AI-249 and +AI-305) available at +@url{http://www.ada-auth.org/cgi-bin/cvsweb.cgi/AIs/AI-00249.TXT} and +@url{http://www.ada-auth.org/cgi-bin/cvsweb.cgi/AIs/AI-00305.TXT} +respectively. + +The above set is a superset of the restrictions provided by pragma +@code{Profile (Restricted)}, it includes six additional restrictions +(@code{Simple_Barriers}, @code{No_Select_Statements}, +@code{No_Calendar}, @code{No_Implicit_Heap_Allocations}, +@code{No_Relative_Delay} and @code{No_Task_Termination}). This means +that pragma @code{Profile (Ravenscar)}, like the pragma +@code{Profile (Restricted)}, +automatically causes the use of a simplified, +more efficient version of the tasking run-time system. + +@node Pragma Profile (Restricted) +@unnumberedsec Pragma Profile (Restricted) +@findex Restricted Run Time +@noindent +Syntax: + +@smallexample @c ada +pragma Profile (Restricted); +@end smallexample + +@noindent +A configuration pragma that establishes the following set of restrictions: + +@itemize @bullet +@item No_Abort_Statements +@item No_Entry_Queue +@item No_Task_Hierarchy +@item No_Task_Allocators +@item No_Dynamic_Priorities +@item No_Terminate_Alternatives +@item No_Dynamic_Attachment +@item No_Protected_Type_Allocators +@item No_Local_Protected_Objects +@item No_Requeue_Statements +@item No_Task_Attributes_Package +@item Max_Asynchronous_Select_Nesting = 0 +@item Max_Task_Entries = 0 +@item Max_Protected_Entries = 1 +@item Max_Select_Alternatives = 0 +@end itemize + +@noindent +This set of restrictions causes the automatic selection of a simplified +version of the run time that provides improved performance for the +limited set of tasking functionality permitted by this set of restrictions. + +@node Pragma Psect_Object +@unnumberedsec Pragma Psect_Object +@findex Psect_Object +@noindent +Syntax: + +@smallexample @c ada +pragma Psect_Object ( + [Internal =>] LOCAL_NAME, + [, [External =>] EXTERNAL_SYMBOL] + [, [Size =>] EXTERNAL_SYMBOL]); + +EXTERNAL_SYMBOL ::= + IDENTIFIER +| static_string_EXPRESSION +@end smallexample + +@noindent +This pragma is identical in effect to pragma @code{Common_Object}. + +@node Pragma Pure_Function +@unnumberedsec Pragma Pure_Function +@findex Pure_Function +@noindent +Syntax: + +@smallexample @c ada +pragma Pure_Function ([Entity =>] function_LOCAL_NAME); +@end smallexample + +@noindent +This pragma appears in the same declarative part as a function +declaration (or a set of function declarations if more than one +overloaded declaration exists, in which case the pragma applies +to all entities). It specifies that the function @code{Entity} is +to be considered pure for the purposes of code generation. This means +that the compiler can assume that there are no side effects, and +in particular that two calls with identical arguments produce the +same result. It also means that the function can be used in an +address clause. + +Note that, quite deliberately, there are no static checks to try +to ensure that this promise is met, so @code{Pure_Function} can be used +with functions that are conceptually pure, even if they do modify +global variables. For example, a square root function that is +instrumented to count the number of times it is called is still +conceptually pure, and can still be optimized, even though it +modifies a global variable (the count). Memo functions are another +example (where a table of previous calls is kept and consulted to +avoid re-computation). + +Note also that the normal rules excluding optimization of subprograms +in pure units (when parameter types are descended from System.Address, +or when the full view of a parameter type is limited), do not apply +for the Pure_Function case. If you explicitly specify Pure_Function, +the compiler may optimize away calls with identical arguments, and +if that results in unexpected behavior, the proper action is not to +use the pragma for subprograms that are not (conceptually) pure. + +@findex Pure +Note: Most functions in a @code{Pure} package are automatically pure, and +there is no need to use pragma @code{Pure_Function} for such functions. One +exception is any function that has at least one formal of type +@code{System.Address} or a type derived from it. Such functions are not +considered pure by default, since the compiler assumes that the +@code{Address} parameter may be functioning as a pointer and that the +referenced data may change even if the address value does not. +Similarly, imported functions are not considered to be pure by default, +since there is no way of checking that they are in fact pure. The use +of pragma @code{Pure_Function} for such a function will override these default +assumption, and cause the compiler to treat a designated subprogram as pure +in these cases. + +Note: If pragma @code{Pure_Function} is applied to a renamed function, it +applies to the underlying renamed function. This can be used to +disambiguate cases of overloading where some but not all functions +in a set of overloaded functions are to be designated as pure. + +If pragma @code{Pure_Function} is applied to a library level function, the +function is also considered pure from an optimization point of view, but the +unit is not a Pure unit in the categorization sense. So for example, a function +thus marked is free to @code{with} non-pure units. + +@node Pragma Restriction_Warnings +@unnumberedsec Pragma Restriction_Warnings +@findex Restriction_Warnings +@noindent +Syntax: + +@smallexample @c ada +pragma Restriction_Warnings + (restriction_IDENTIFIER @{, restriction_IDENTIFIER@}); +@end smallexample + +@noindent +This pragma allows a series of restriction identifiers to be +specified (the list of allowed identifiers is the same as for +pragma @code{Restrictions}). For each of these identifiers +the compiler checks for violations of the restriction, but +generates a warning message rather than an error message +if the restriction is violated. + +@node Pragma Shared +@unnumberedsec Pragma Shared +@findex Shared + +@noindent +This pragma is provided for compatibility with Ada 83. The syntax and +semantics are identical to pragma Atomic. + +@node Pragma Short_Circuit_And_Or +@unnumberedsec Pragma Short_Circuit_And_Or +@findex Short_Circuit_And_Or + +@noindent +This configuration pragma causes any occurrence of the AND operator applied to +operands of type Standard.Boolean to be short-circuited (i.e. the AND operator +is treated as if it were AND THEN). Or is similarly treated as OR ELSE. This +may be useful in the context of certification protocols requiring the use of +short-circuited logical operators. If this configuration pragma occurs locally +within the file being compiled, it applies only to the file being compiled. +There is no requirement that all units in a partition use this option. + +@node Pragma Short_Descriptors +@unnumberedsec Pragma Short_Descriptors +@findex Short_Descriptors +@noindent +Syntax: + +@smallexample @c ada +pragma Short_Descriptors +@end smallexample + +@noindent +In VMS versions of the compiler, this configuration pragma causes all +occurrences of the mechanism types Descriptor[_xxx] to be treated as +Short_Descriptor[_xxx]. This is helpful in porting legacy applications from a +32-bit environment to a 64-bit environment. This pragma is ignored for non-VMS +versions. + +@node Pragma Source_File_Name +@unnumberedsec Pragma Source_File_Name +@findex Source_File_Name +@noindent +Syntax: + +@smallexample @c ada +pragma Source_File_Name ( + [Unit_Name =>] unit_NAME, + Spec_File_Name => STRING_LITERAL, + [Index => INTEGER_LITERAL]); + +pragma Source_File_Name ( + [Unit_Name =>] unit_NAME, + Body_File_Name => STRING_LITERAL, + [Index => INTEGER_LITERAL]); +@end smallexample + +@noindent +Use this to override the normal naming convention. It is a configuration +pragma, and so has the usual applicability of configuration pragmas +(i.e.@: it applies to either an entire partition, or to all units in a +compilation, or to a single unit, depending on how it is used. +@var{unit_name} is mapped to @var{file_name_literal}. The identifier for +the second argument is required, and indicates whether this is the file +name for the spec or for the body. + +The optional Index argument should be used when a file contains multiple +units, and when you do not want to use @code{gnatchop} to separate then +into multiple files (which is the recommended procedure to limit the +number of recompilations that are needed when some sources change). +For instance, if the source file @file{source.ada} contains + +@smallexample @c ada +package B is +... +end B; + +with B; +procedure A is +begin + .. +end A; +@end smallexample + +you could use the following configuration pragmas: + +@smallexample @c ada +pragma Source_File_Name + (B, Spec_File_Name => "source.ada", Index => 1); +pragma Source_File_Name + (A, Body_File_Name => "source.ada", Index => 2); +@end smallexample + +Note that the @code{gnatname} utility can also be used to generate those +configuration pragmas. + +Another form of the @code{Source_File_Name} pragma allows +the specification of patterns defining alternative file naming schemes +to apply to all files. + +@smallexample @c ada +pragma Source_File_Name + ( [Spec_File_Name =>] STRING_LITERAL + [,[Casing =>] CASING_SPEC] + [,[Dot_Replacement =>] STRING_LITERAL]); + +pragma Source_File_Name + ( [Body_File_Name =>] STRING_LITERAL + [,[Casing =>] CASING_SPEC] + [,[Dot_Replacement =>] STRING_LITERAL]); + +pragma Source_File_Name + ( [Subunit_File_Name =>] STRING_LITERAL + [,[Casing =>] CASING_SPEC] + [,[Dot_Replacement =>] STRING_LITERAL]); + +CASING_SPEC ::= Lowercase | Uppercase | Mixedcase +@end smallexample + +@noindent +The first argument is a pattern that contains a single asterisk indicating +the point at which the unit name is to be inserted in the pattern string +to form the file name. The second argument is optional. If present it +specifies the casing of the unit name in the resulting file name string. +The default is lower case. Finally the third argument allows for systematic +replacement of any dots in the unit name by the specified string literal. + +A pragma Source_File_Name cannot appear after a +@ref{Pragma Source_File_Name_Project}. + +For more details on the use of the @code{Source_File_Name} pragma, +@xref{Using Other File Names,,, gnat_ugn, @value{EDITION} User's Guide}, +and @ref{Alternative File Naming Schemes,,, gnat_ugn, @value{EDITION} +User's Guide}. + +@node Pragma Source_File_Name_Project +@unnumberedsec Pragma Source_File_Name_Project +@findex Source_File_Name_Project +@noindent + +This pragma has the same syntax and semantics as pragma Source_File_Name. +It is only allowed as a stand alone configuration pragma. +It cannot appear after a @ref{Pragma Source_File_Name}, and +most importantly, once pragma Source_File_Name_Project appears, +no further Source_File_Name pragmas are allowed. + +The intention is that Source_File_Name_Project pragmas are always +generated by the Project Manager in a manner consistent with the naming +specified in a project file, and when naming is controlled in this manner, +it is not permissible to attempt to modify this naming scheme using +Source_File_Name pragmas (which would not be known to the project manager). + +@node Pragma Source_Reference +@unnumberedsec Pragma Source_Reference +@findex Source_Reference +@noindent +Syntax: + +@smallexample @c ada +pragma Source_Reference (INTEGER_LITERAL, STRING_LITERAL); +@end smallexample + +@noindent +This pragma must appear as the first line of a source file. +@var{integer_literal} is the logical line number of the line following +the pragma line (for use in error messages and debugging +information). @var{string_literal} is a static string constant that +specifies the file name to be used in error messages and debugging +information. This is most notably used for the output of @code{gnatchop} +with the @option{-r} switch, to make sure that the original unchopped +source file is the one referred to. + +The second argument must be a string literal, it cannot be a static +string expression other than a string literal. This is because its value +is needed for error messages issued by all phases of the compiler. + +@node Pragma Stream_Convert +@unnumberedsec Pragma Stream_Convert +@findex Stream_Convert +@noindent +Syntax: + +@smallexample @c ada +pragma Stream_Convert ( + [Entity =>] type_LOCAL_NAME, + [Read =>] function_NAME, + [Write =>] function_NAME); +@end smallexample + +@noindent +This pragma provides an efficient way of providing stream functions for +types defined in packages. Not only is it simpler to use than declaring +the necessary functions with attribute representation clauses, but more +significantly, it allows the declaration to made in such a way that the +stream packages are not loaded unless they are needed. The use of +the Stream_Convert pragma adds no overhead at all, unless the stream +attributes are actually used on the designated type. + +The first argument specifies the type for which stream functions are +provided. The second parameter provides a function used to read values +of this type. It must name a function whose argument type may be any +subtype, and whose returned type must be the type given as the first +argument to the pragma. + +The meaning of the @var{Read} +parameter is that if a stream attribute directly +or indirectly specifies reading of the type given as the first parameter, +then a value of the type given as the argument to the Read function is +read from the stream, and then the Read function is used to convert this +to the required target type. + +Similarly the @var{Write} parameter specifies how to treat write attributes +that directly or indirectly apply to the type given as the first parameter. +It must have an input parameter of the type specified by the first parameter, +and the return type must be the same as the input type of the Read function. +The effect is to first call the Write function to convert to the given stream +type, and then write the result type to the stream. + +The Read and Write functions must not be overloaded subprograms. If necessary +renamings can be supplied to meet this requirement. +The usage of this attribute is best illustrated by a simple example, taken +from the GNAT implementation of package Ada.Strings.Unbounded: + +@smallexample @c ada +function To_Unbounded (S : String) + return Unbounded_String + renames To_Unbounded_String; + +pragma Stream_Convert + (Unbounded_String, To_Unbounded, To_String); +@end smallexample + +@noindent +The specifications of the referenced functions, as given in the Ada +Reference Manual are: + +@smallexample @c ada +function To_Unbounded_String (Source : String) + return Unbounded_String; + +function To_String (Source : Unbounded_String) + return String; +@end smallexample + +@noindent +The effect is that if the value of an unbounded string is written to a stream, +then the representation of the item in the stream is in the same format that +would be used for @code{Standard.String'Output}, and this same representation +is expected when a value of this type is read from the stream. Note that the +value written always includes the bounds, even for Unbounded_String'Write, +since Unbounded_String is not an array type. + +@node Pragma Style_Checks +@unnumberedsec Pragma Style_Checks +@findex Style_Checks +@noindent +Syntax: + +@smallexample @c ada +pragma Style_Checks (string_LITERAL | ALL_CHECKS | + On | Off [, LOCAL_NAME]); +@end smallexample + +@noindent +This pragma is used in conjunction with compiler switches to control the +built in style checking provided by GNAT@. The compiler switches, if set, +provide an initial setting for the switches, and this pragma may be used +to modify these settings, or the settings may be provided entirely by +the use of the pragma. This pragma can be used anywhere that a pragma +is legal, including use as a configuration pragma (including use in +the @file{gnat.adc} file). + +The form with a string literal specifies which style options are to be +activated. These are additive, so they apply in addition to any previously +set style check options. The codes for the options are the same as those +used in the @option{-gnaty} switch to @command{gcc} or @command{gnatmake}. +For example the following two methods can be used to enable +layout checking: + +@itemize @bullet +@item +@smallexample @c ada +pragma Style_Checks ("l"); +@end smallexample + +@item +@smallexample +gcc -c -gnatyl @dots{} +@end smallexample +@end itemize + +@noindent +The form ALL_CHECKS activates all standard checks (its use is equivalent +to the use of the @code{gnaty} switch with no options. @xref{Top, +@value{EDITION} User's Guide, About This Guide, gnat_ugn, +@value{EDITION} User's Guide}, for details.) + +Note: the behavior is slightly different in GNAT mode (@option{-gnatg} used). +In this case, ALL_CHECKS implies the standard set of GNAT mode style check +options (i.e. equivalent to -gnatyg). + +The forms with @code{Off} and @code{On} +can be used to temporarily disable style checks +as shown in the following example: + +@smallexample @c ada +@iftex +@leftskip=0cm +@end iftex +pragma Style_Checks ("k"); -- requires keywords in lower case +pragma Style_Checks (Off); -- turn off style checks +NULL; -- this will not generate an error message +pragma Style_Checks (On); -- turn style checks back on +NULL; -- this will generate an error message +@end smallexample + +@noindent +Finally the two argument form is allowed only if the first argument is +@code{On} or @code{Off}. The effect is to turn of semantic style checks +for the specified entity, as shown in the following example: + +@smallexample @c ada +@iftex +@leftskip=0cm +@end iftex +pragma Style_Checks ("r"); -- require consistency of identifier casing +Arg : Integer; +Rf1 : Integer := ARG; -- incorrect, wrong case +pragma Style_Checks (Off, Arg); +Rf2 : Integer := ARG; -- OK, no error +@end smallexample + +@node Pragma Subtitle +@unnumberedsec Pragma Subtitle +@findex Subtitle +@noindent +Syntax: + +@smallexample @c ada +pragma Subtitle ([Subtitle =>] STRING_LITERAL); +@end smallexample + +@noindent +This pragma is recognized for compatibility with other Ada compilers +but is ignored by GNAT@. + +@node Pragma Suppress +@unnumberedsec Pragma Suppress +@findex Suppress +@noindent +Syntax: + +@smallexample @c ada +pragma Suppress (Identifier [, [On =>] Name]); +@end smallexample + +@noindent +This is a standard pragma, and supports all the check names required in +the RM. It is included here because GNAT recognizes one additional check +name: @code{Alignment_Check} which can be used to suppress alignment checks +on addresses used in address clauses. Such checks can also be suppressed +by suppressing range checks, but the specific use of @code{Alignment_Check} +allows suppression of alignment checks without suppressing other range checks. + +Note that pragma Suppress gives the compiler permission to omit +checks, but does not require the compiler to omit checks. The compiler +will generate checks if they are essentially free, even when they are +suppressed. In particular, if the compiler can prove that a certain +check will necessarily fail, it will generate code to do an +unconditional ``raise'', even if checks are suppressed. The compiler +warns in this case. + +Of course, run-time checks are omitted whenever the compiler can prove +that they will not fail, whether or not checks are suppressed. + +@node Pragma Suppress_All +@unnumberedsec Pragma Suppress_All +@findex Suppress_All +@noindent +Syntax: + +@smallexample @c ada +pragma Suppress_All; +@end smallexample + +@noindent +This pragma can appear anywhere within a unit. +The effect is to apply @code{Suppress (All_Checks)} to the unit +in which it appears. This pragma is implemented for compatibility with DEC +Ada 83 usage where it appears at the end of a unit, and for compatibility +with Rational Ada, where it appears as a program unit pragma. +The use of the standard Ada pragma @code{Suppress (All_Checks)} +as a normal configuration pragma is the preferred usage in GNAT@. + +@node Pragma Suppress_Exception_Locations +@unnumberedsec Pragma Suppress_Exception_Locations +@findex Suppress_Exception_Locations +@noindent +Syntax: + +@smallexample @c ada +pragma Suppress_Exception_Locations; +@end smallexample + +@noindent +In normal mode, a raise statement for an exception by default generates +an exception message giving the file name and line number for the location +of the raise. This is useful for debugging and logging purposes, but this +entails extra space for the strings for the messages. The configuration +pragma @code{Suppress_Exception_Locations} can be used to suppress the +generation of these strings, with the result that space is saved, but the +exception message for such raises is null. This configuration pragma may +appear in a global configuration pragma file, or in a specific unit as +usual. It is not required that this pragma be used consistently within +a partition, so it is fine to have some units within a partition compiled +with this pragma and others compiled in normal mode without it. + +@node Pragma Suppress_Initialization +@unnumberedsec Pragma Suppress_Initialization +@findex Suppress_Initialization +@cindex Suppressing initialization +@cindex Initialization, suppression of +@noindent +Syntax: + +@smallexample @c ada +pragma Suppress_Initialization ([Entity =>] type_Name); +@end smallexample + +@noindent +This pragma suppresses any implicit or explicit initialization +associated with the given type name for all variables of this type. + +@node Pragma Task_Info +@unnumberedsec Pragma Task_Info +@findex Task_Info +@noindent +Syntax + +@smallexample @c ada +pragma Task_Info (EXPRESSION); +@end smallexample + +@noindent +This pragma appears within a task definition (like pragma +@code{Priority}) and applies to the task in which it appears. The +argument must be of type @code{System.Task_Info.Task_Info_Type}. +The @code{Task_Info} pragma provides system dependent control over +aspects of tasking implementation, for example, the ability to map +tasks to specific processors. For details on the facilities available +for the version of GNAT that you are using, see the documentation +in the spec of package System.Task_Info in the runtime +library. + +@node Pragma Task_Name +@unnumberedsec Pragma Task_Name +@findex Task_Name +@noindent +Syntax + +@smallexample @c ada +pragma Task_Name (string_EXPRESSION); +@end smallexample + +@noindent +This pragma appears within a task definition (like pragma +@code{Priority}) and applies to the task in which it appears. The +argument must be of type String, and provides a name to be used for +the task instance when the task is created. Note that this expression +is not required to be static, and in particular, it can contain +references to task discriminants. This facility can be used to +provide different names for different tasks as they are created, +as illustrated in the example below. + +The task name is recorded internally in the run-time structures +and is accessible to tools like the debugger. In addition the +routine @code{Ada.Task_Identification.Image} will return this +string, with a unique task address appended. + +@smallexample @c ada +-- Example of the use of pragma Task_Name + +with Ada.Task_Identification; +use Ada.Task_Identification; +with Text_IO; use Text_IO; +procedure t3 is + + type Astring is access String; + + task type Task_Typ (Name : access String) is + pragma Task_Name (Name.all); + end Task_Typ; + + task body Task_Typ is + Nam : constant String := Image (Current_Task); + begin + Put_Line ("-->" & Nam (1 .. 14) & "<--"); + end Task_Typ; + + type Ptr_Task is access Task_Typ; + Task_Var : Ptr_Task; + +begin + Task_Var := + new Task_Typ (new String'("This is task 1")); + Task_Var := + new Task_Typ (new String'("This is task 2")); +end; +@end smallexample + +@node Pragma Task_Storage +@unnumberedsec Pragma Task_Storage +@findex Task_Storage +Syntax: + +@smallexample @c ada +pragma Task_Storage ( + [Task_Type =>] LOCAL_NAME, + [Top_Guard =>] static_integer_EXPRESSION); +@end smallexample + +@noindent +This pragma specifies the length of the guard area for tasks. The guard +area is an additional storage area allocated to a task. A value of zero +means that either no guard area is created or a minimal guard area is +created, depending on the target. This pragma can appear anywhere a +@code{Storage_Size} attribute definition clause is allowed for a task +type. + +@node Pragma Thread_Local_Storage +@unnumberedsec Pragma Thread_Local_Storage +@findex Thread_Local_Storage +@cindex Task specific storage +@cindex TLS (Thread Local Storage) +Syntax: + +@smallexample @c ada +pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME); +@end smallexample + +@noindent +This pragma specifies that the specified entity, which must be +a variable declared in a library level package, is to be marked as +"Thread Local Storage" (@code{TLS}). On systems supporting this (which +include Solaris, GNU/Linux and VxWorks 6), this causes each thread +(and hence each Ada task) to see a distinct copy of the variable. + +The variable may not have default initialization, and if there is +an explicit initialization, it must be either @code{null} for an +access variable, or a static expression for a scalar variable. +This provides a low level mechanism similar to that provided by +the @code{Ada.Task_Attributes} package, but much more efficient +and is also useful in writing interface code that will interact +with foreign threads. + +If this pragma is used on a system where @code{TLS} is not supported, +then an error message will be generated and the program will be rejected. + +@node Pragma Time_Slice +@unnumberedsec Pragma Time_Slice +@findex Time_Slice +@noindent +Syntax: + +@smallexample @c ada +pragma Time_Slice (static_duration_EXPRESSION); +@end smallexample + +@noindent +For implementations of GNAT on operating systems where it is possible +to supply a time slice value, this pragma may be used for this purpose. +It is ignored if it is used in a system that does not allow this control, +or if it appears in other than the main program unit. +@cindex OpenVMS +Note that the effect of this pragma is identical to the effect of the +DEC Ada 83 pragma of the same name when operating under OpenVMS systems. + +@node Pragma Title +@unnumberedsec Pragma Title +@findex Title +@noindent +Syntax: + +@smallexample @c ada +pragma Title (TITLING_OPTION [, TITLING OPTION]); + +TITLING_OPTION ::= + [Title =>] STRING_LITERAL, +| [Subtitle =>] STRING_LITERAL +@end smallexample + +@noindent +Syntax checked but otherwise ignored by GNAT@. This is a listing control +pragma used in DEC Ada 83 implementations to provide a title and/or +subtitle for the program listing. The program listing generated by GNAT +does not have titles or subtitles. + +Unlike other pragmas, the full flexibility of named notation is allowed +for this pragma, i.e.@: the parameters may be given in any order if named +notation is used, and named and positional notation can be mixed +following the normal rules for procedure calls in Ada. + +@node Pragma Unchecked_Union +@unnumberedsec Pragma Unchecked_Union +@cindex Unions in C +@findex Unchecked_Union +@noindent +Syntax: + +@smallexample @c ada +pragma Unchecked_Union (first_subtype_LOCAL_NAME); +@end smallexample + +@noindent +This pragma is used to specify a representation of a record type that is +equivalent to a C union. It was introduced as a GNAT implementation defined +pragma in the GNAT Ada 95 mode. Ada 2005 includes an extended version of this +pragma, making it language defined, and GNAT fully implements this extended +version in all language modes (Ada 83, Ada 95, and Ada 2005). For full +details, consult the Ada 2005 Reference Manual, section B.3.3. + +@node Pragma Unimplemented_Unit +@unnumberedsec Pragma Unimplemented_Unit +@findex Unimplemented_Unit +@noindent +Syntax: + +@smallexample @c ada +pragma Unimplemented_Unit; +@end smallexample + +@noindent +If this pragma occurs in a unit that is processed by the compiler, GNAT +aborts with the message @samp{@var{xxx} not implemented}, where +@var{xxx} is the name of the current compilation unit. This pragma is +intended to allow the compiler to handle unimplemented library units in +a clean manner. + +The abort only happens if code is being generated. Thus you can use +specs of unimplemented packages in syntax or semantic checking mode. + +@node Pragma Universal_Aliasing +@unnumberedsec Pragma Universal_Aliasing +@findex Universal_Aliasing +@noindent +Syntax: + +@smallexample @c ada +pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)]; +@end smallexample + +@noindent +@var{type_LOCAL_NAME} must refer to a type declaration in the current +declarative part. The effect is to inhibit strict type-based aliasing +optimization for the given type. In other words, the effect is as though +access types designating this type were subject to pragma No_Strict_Aliasing. +For a detailed description of the strict aliasing optimization, and the +situations in which it must be suppressed, @xref{Optimization and Strict +Aliasing,,, gnat_ugn, @value{EDITION} User's Guide}. + +@node Pragma Universal_Data +@unnumberedsec Pragma Universal_Data +@findex Universal_Data +@noindent +Syntax: + +@smallexample @c ada +pragma Universal_Data [(library_unit_Name)]; +@end smallexample + +@noindent +This pragma is supported only for the AAMP target and is ignored for +other targets. The pragma specifies that all library-level objects +(Counter 0 data) associated with the library unit are to be accessed +and updated using universal addressing (24-bit addresses for AAMP5) +rather than the default of 16-bit Data Environment (DENV) addressing. +Use of this pragma will generally result in less efficient code for +references to global data associated with the library unit, but +allows such data to be located anywhere in memory. This pragma is +a library unit pragma, but can also be used as a configuration pragma +(including use in the @file{gnat.adc} file). The functionality +of this pragma is also available by applying the -univ switch on the +compilations of units where universal addressing of the data is desired. + +@node Pragma Unmodified +@unnumberedsec Pragma Unmodified +@findex Unmodified +@cindex Warnings, unmodified +@noindent +Syntax: + +@smallexample @c ada +pragma Unmodified (LOCAL_NAME @{, LOCAL_NAME@}); +@end smallexample + +@noindent +This pragma signals that the assignable entities (variables, +@code{out} parameters, @code{in out} parameters) whose names are listed are +deliberately not assigned in the current source unit. This +suppresses warnings about the +entities being referenced but not assigned, and in addition a warning will be +generated if one of these entities is in fact assigned in the +same unit as the pragma (or in the corresponding body, or one +of its subunits). + +This is particularly useful for clearly signaling that a particular +parameter is not modified, even though the spec suggests that it might +be. + +@node Pragma Unreferenced +@unnumberedsec Pragma Unreferenced +@findex Unreferenced +@cindex Warnings, unreferenced +@noindent +Syntax: + +@smallexample @c ada +pragma Unreferenced (LOCAL_NAME @{, LOCAL_NAME@}); +pragma Unreferenced (library_unit_NAME @{, library_unit_NAME@}); +@end smallexample + +@noindent +This pragma signals that the entities whose names are listed are +deliberately not referenced in the current source unit. This +suppresses warnings about the +entities being unreferenced, and in addition a warning will be +generated if one of these entities is in fact referenced in the +same unit as the pragma (or in the corresponding body, or one +of its subunits). + +This is particularly useful for clearly signaling that a particular +parameter is not referenced in some particular subprogram implementation +and that this is deliberate. It can also be useful in the case of +objects declared only for their initialization or finalization side +effects. + +If @code{LOCAL_NAME} identifies more than one matching homonym in the +current scope, then the entity most recently declared is the one to which +the pragma applies. Note that in the case of accept formals, the pragma +Unreferenced may appear immediately after the keyword @code{do} which +allows the indication of whether or not accept formals are referenced +or not to be given individually for each accept statement. + +The left hand side of an assignment does not count as a reference for the +purpose of this pragma. Thus it is fine to assign to an entity for which +pragma Unreferenced is given. + +Note that if a warning is desired for all calls to a given subprogram, +regardless of whether they occur in the same unit as the subprogram +declaration, then this pragma should not be used (calls from another +unit would not be flagged); pragma Obsolescent can be used instead +for this purpose, see @xref{Pragma Obsolescent}. + +The second form of pragma @code{Unreferenced} is used within a context +clause. In this case the arguments must be unit names of units previously +mentioned in @code{with} clauses (similar to the usage of pragma +@code{Elaborate_All}. The effect is to suppress warnings about unreferenced +units and unreferenced entities within these units. + +@node Pragma Unreferenced_Objects +@unnumberedsec Pragma Unreferenced_Objects +@findex Unreferenced_Objects +@cindex Warnings, unreferenced +@noindent +Syntax: + +@smallexample @c ada +pragma Unreferenced_Objects (local_subtype_NAME @{, local_subtype_NAME@}); +@end smallexample + +@noindent +This pragma signals that for the types or subtypes whose names are +listed, objects which are declared with one of these types or subtypes may +not be referenced, and if no references appear, no warnings are given. + +This is particularly useful for objects which are declared solely for their +initialization and finalization effect. Such variables are sometimes referred +to as RAII variables (Resource Acquisition Is Initialization). Using this +pragma on the relevant type (most typically a limited controlled type), the +compiler will automatically suppress unwanted warnings about these variables +not being referenced. + +@node Pragma Unreserve_All_Interrupts +@unnumberedsec Pragma Unreserve_All_Interrupts +@findex Unreserve_All_Interrupts +@noindent +Syntax: + +@smallexample @c ada +pragma Unreserve_All_Interrupts; +@end smallexample + +@noindent +Normally certain interrupts are reserved to the implementation. Any attempt +to attach an interrupt causes Program_Error to be raised, as described in +RM C.3.2(22). A typical example is the @code{SIGINT} interrupt used in +many systems for a @kbd{Ctrl-C} interrupt. Normally this interrupt is +reserved to the implementation, so that @kbd{Ctrl-C} can be used to +interrupt execution. + +If the pragma @code{Unreserve_All_Interrupts} appears anywhere in any unit in +a program, then all such interrupts are unreserved. This allows the +program to handle these interrupts, but disables their standard +functions. For example, if this pragma is used, then pressing +@kbd{Ctrl-C} will not automatically interrupt execution. However, +a program can then handle the @code{SIGINT} interrupt as it chooses. + +For a full list of the interrupts handled in a specific implementation, +see the source code for the spec of @code{Ada.Interrupts.Names} in +file @file{a-intnam.ads}. This is a target dependent file that contains the +list of interrupts recognized for a given target. The documentation in +this file also specifies what interrupts are affected by the use of +the @code{Unreserve_All_Interrupts} pragma. + +For a more general facility for controlling what interrupts can be +handled, see pragma @code{Interrupt_State}, which subsumes the functionality +of the @code{Unreserve_All_Interrupts} pragma. + +@node Pragma Unsuppress +@unnumberedsec Pragma Unsuppress +@findex Unsuppress +@noindent +Syntax: + +@smallexample @c ada +pragma Unsuppress (IDENTIFIER [, [On =>] NAME]); +@end smallexample + +@noindent +This pragma undoes the effect of a previous pragma @code{Suppress}. If +there is no corresponding pragma @code{Suppress} in effect, it has no +effect. The range of the effect is the same as for pragma +@code{Suppress}. The meaning of the arguments is identical to that used +in pragma @code{Suppress}. + +One important application is to ensure that checks are on in cases where +code depends on the checks for its correct functioning, so that the code +will compile correctly even if the compiler switches are set to suppress +checks. + +@node Pragma Use_VADS_Size +@unnumberedsec Pragma Use_VADS_Size +@cindex @code{Size}, VADS compatibility +@findex Use_VADS_Size +@noindent +Syntax: + +@smallexample @c ada +pragma Use_VADS_Size; +@end smallexample + +@noindent +This is a configuration pragma. In a unit to which it applies, any use +of the 'Size attribute is automatically interpreted as a use of the +'VADS_Size attribute. Note that this may result in incorrect semantic +processing of valid Ada 95 or Ada 2005 programs. This is intended to aid in +the handling of existing code which depends on the interpretation of Size +as implemented in the VADS compiler. See description of the VADS_Size +attribute for further details. + +@node Pragma Validity_Checks +@unnumberedsec Pragma Validity_Checks +@findex Validity_Checks +@noindent +Syntax: + +@smallexample @c ada +pragma Validity_Checks (string_LITERAL | ALL_CHECKS | On | Off); +@end smallexample + +@noindent +This pragma is used in conjunction with compiler switches to control the +built-in validity checking provided by GNAT@. The compiler switches, if set +provide an initial setting for the switches, and this pragma may be used +to modify these settings, or the settings may be provided entirely by +the use of the pragma. This pragma can be used anywhere that a pragma +is legal, including use as a configuration pragma (including use in +the @file{gnat.adc} file). + +The form with a string literal specifies which validity options are to be +activated. The validity checks are first set to include only the default +reference manual settings, and then a string of letters in the string +specifies the exact set of options required. The form of this string +is exactly as described for the @option{-gnatVx} compiler switch (see the +GNAT users guide for details). For example the following two methods +can be used to enable validity checking for mode @code{in} and +@code{in out} subprogram parameters: + +@itemize @bullet +@item +@smallexample @c ada +pragma Validity_Checks ("im"); +@end smallexample + +@item +@smallexample +gcc -c -gnatVim @dots{} +@end smallexample +@end itemize + +@noindent +The form ALL_CHECKS activates all standard checks (its use is equivalent +to the use of the @code{gnatva} switch. + +The forms with @code{Off} and @code{On} +can be used to temporarily disable validity checks +as shown in the following example: + +@smallexample @c ada +@iftex +@leftskip=0cm +@end iftex +pragma Validity_Checks ("c"); -- validity checks for copies +pragma Validity_Checks (Off); -- turn off validity checks +A := B; -- B will not be validity checked +pragma Validity_Checks (On); -- turn validity checks back on +A := C; -- C will be validity checked +@end smallexample + +@node Pragma Volatile +@unnumberedsec Pragma Volatile +@findex Volatile +@noindent +Syntax: + +@smallexample @c ada +pragma Volatile (LOCAL_NAME); +@end smallexample + +@noindent +This pragma is defined by the Ada Reference Manual, and the GNAT +implementation is fully conformant with this definition. The reason it +is mentioned in this section is that a pragma of the same name was supplied +in some Ada 83 compilers, including DEC Ada 83. The Ada 95 / Ada 2005 +implementation of pragma Volatile is upwards compatible with the +implementation in DEC Ada 83. + +@node Pragma Warnings +@unnumberedsec Pragma Warnings +@findex Warnings +@noindent +Syntax: + +@smallexample @c ada +pragma Warnings (On | Off); +pragma Warnings (On | Off, LOCAL_NAME); +pragma Warnings (static_string_EXPRESSION); +pragma Warnings (On | Off, static_string_EXPRESSION); +@end smallexample + +@noindent +Normally warnings are enabled, with the output being controlled by +the command line switch. Warnings (@code{Off}) turns off generation of +warnings until a Warnings (@code{On}) is encountered or the end of the +current unit. If generation of warnings is turned off using this +pragma, then no warning messages are output, regardless of the +setting of the command line switches. + +The form with a single argument may be used as a configuration pragma. + +If the @var{LOCAL_NAME} parameter is present, warnings are suppressed for +the specified entity. This suppression is effective from the point where +it occurs till the end of the extended scope of the variable (similar to +the scope of @code{Suppress}). + +The form with a single static_string_EXPRESSION argument provides more precise +control over which warnings are active. The string is a list of letters +specifying which warnings are to be activated and which deactivated. The +code for these letters is the same as the string used in the command +line switch controlling warnings. For a brief summary, use the gnatmake +command with no arguments, which will generate usage information containing +the list of warnings switches supported. For +full details see @ref{Warning Message Control,,, gnat_ugn, @value{EDITION} +User's Guide}. + +@noindent +The specified warnings will be in effect until the end of the program +or another pragma Warnings is encountered. The effect of the pragma is +cumulative. Initially the set of warnings is the standard default set +as possibly modified by compiler switches. Then each pragma Warning +modifies this set of warnings as specified. This form of the pragma may +also be used as a configuration pragma. + +The fourth form, with an On|Off parameter and a string, is used to +control individual messages, based on their text. The string argument +is a pattern that is used to match against the text of individual +warning messages (not including the initial "warning: " tag). + +The pattern may contain asterisks, which match zero or more characters in +the message. For example, you can use +@code{pragma Warnings (Off, "*bits of*unused")} to suppress the warning +message @code{warning: 960 bits of "a" unused}. No other regular +expression notations are permitted. All characters other than asterisk in +these three specific cases are treated as literal characters in the match. + +There are two ways to use this pragma. The OFF form can be used as a +configuration pragma. The effect is to suppress all warnings (if any) +that match the pattern string throughout the compilation. + +The second usage is to suppress a warning locally, and in this case, two +pragmas must appear in sequence: + +@smallexample @c ada +pragma Warnings (Off, Pattern); +@dots{} code where given warning is to be suppressed +pragma Warnings (On, Pattern); +@end smallexample + +@noindent +In this usage, the pattern string must match in the Off and On pragmas, +and at least one matching warning must be suppressed. + +Note: the debug flag -gnatd.i (@code{/NOWARNINGS_PRAGMAS} in VMS) can be +used to cause the compiler to entirely ignore all WARNINGS pragmas. This can +be useful in checking whether obsolete pragmas in existing programs are hiding +real problems. + +Note: pragma Warnings does not affect the processing of style messages. See +separate entry for pragma Style_Checks for control of style messages. + +@node Pragma Weak_External +@unnumberedsec Pragma Weak_External +@findex Weak_External +@noindent +Syntax: + +@smallexample @c ada +pragma Weak_External ([Entity =>] LOCAL_NAME); +@end smallexample + +@noindent +@var{LOCAL_NAME} must refer to an object that is declared at the library +level. This pragma specifies that the given entity should be marked as a +weak symbol for the linker. It is equivalent to @code{__attribute__((weak))} +in GNU C and causes @var{LOCAL_NAME} to be emitted as a weak symbol instead +of a regular symbol, that is to say a symbol that does not have to be +resolved by the linker if used in conjunction with a pragma Import. + +When a weak symbol is not resolved by the linker, its address is set to +zero. This is useful in writing interfaces to external modules that may +or may not be linked in the final executable, for example depending on +configuration settings. + +If a program references at run time an entity to which this pragma has been +applied, and the corresponding symbol was not resolved at link time, then +the execution of the program is erroneous. It is not erroneous to take the +Address of such an entity, for example to guard potential references, +as shown in the example below. + +Some file formats do not support weak symbols so not all target machines +support this pragma. + +@smallexample @c ada +-- Example of the use of pragma Weak_External + +package External_Module is + key : Integer; + pragma Import (C, key); + pragma Weak_External (key); + function Present return boolean; +end External_Module; + +with System; use System; +package body External_Module is + function Present return boolean is + begin + return key'Address /= System.Null_Address; + end Present; +end External_Module; +@end smallexample + +@node Pragma Wide_Character_Encoding +@unnumberedsec Pragma Wide_Character_Encoding +@findex Wide_Character_Encoding +@noindent +Syntax: + +@smallexample @c ada +pragma Wide_Character_Encoding (IDENTIFIER | CHARACTER_LITERAL); +@end smallexample + +@noindent +This pragma specifies the wide character encoding to be used in program +source text appearing subsequently. It is a configuration pragma, but may +also be used at any point that a pragma is allowed, and it is permissible +to have more than one such pragma in a file, allowing multiple encodings +to appear within the same file. + +The argument can be an identifier or a character literal. In the identifier +case, it is one of @code{HEX}, @code{UPPER}, @code{SHIFT_JIS}, +@code{EUC}, @code{UTF8}, or @code{BRACKETS}. In the character literal +case it is correspondingly one of the characters @samp{h}, @samp{u}, +@samp{s}, @samp{e}, @samp{8}, or @samp{b}. + +Note that when the pragma is used within a file, it affects only the +encoding within that file, and does not affect withed units, specs, +or subunits. + +@node Implementation Defined Attributes +@chapter Implementation Defined Attributes +Ada defines (throughout the Ada reference manual, +summarized in Annex K), +a set of attributes that provide useful additional functionality in all +areas of the language. These language defined attributes are implemented +in GNAT and work as described in the Ada Reference Manual. + +In addition, Ada allows implementations to define additional +attributes whose meaning is defined by the implementation. GNAT provides +a number of these implementation-dependent attributes which can be used +to extend and enhance the functionality of the compiler. This section of +the GNAT reference manual describes these additional attributes. + +Note that any program using these attributes may not be portable to +other compilers (although GNAT implements this set of attributes on all +platforms). Therefore if portability to other compilers is an important +consideration, you should minimize the use of these attributes. + +@menu +* Abort_Signal:: +* Address_Size:: +* Asm_Input:: +* Asm_Output:: +* AST_Entry:: +* Bit:: +* Bit_Position:: +* Compiler_Version:: +* Code_Address:: +* Default_Bit_Order:: +* Elaborated:: +* Elab_Body:: +* Elab_Spec:: +* Emax:: +* Enabled:: +* Enum_Rep:: +* Enum_Val:: +* Epsilon:: +* Fixed_Value:: +* Has_Access_Values:: +* Has_Discriminants:: +* Img:: +* Integer_Value:: +* Invalid_Value:: +* Large:: +* Machine_Size:: +* Mantissa:: +* Max_Interrupt_Priority:: +* Max_Priority:: +* Maximum_Alignment:: +* Mechanism_Code:: +* Null_Parameter:: +* Object_Size:: +* Old:: +* Passed_By_Reference:: +* Pool_Address:: +* Range_Length:: +* Ref:: +* Result:: +* Safe_Emax:: +* Safe_Large:: +* Small:: +* Storage_Unit:: +* Stub_Type:: +* Target_Name:: +* Tick:: +* To_Address:: +* Type_Class:: +* UET_Address:: +* Unconstrained_Array:: +* Universal_Literal_String:: +* Unrestricted_Access:: +* VADS_Size:: +* Value_Size:: +* Wchar_T_Size:: +* Word_Size:: +@end menu + +@node Abort_Signal +@unnumberedsec Abort_Signal +@findex Abort_Signal +@noindent +@code{Standard'Abort_Signal} (@code{Standard} is the only allowed +prefix) provides the entity for the special exception used to signal +task abort or asynchronous transfer of control. Normally this attribute +should only be used in the tasking runtime (it is highly peculiar, and +completely outside the normal semantics of Ada, for a user program to +intercept the abort exception). + +@node Address_Size +@unnumberedsec Address_Size +@cindex Size of @code{Address} +@findex Address_Size +@noindent +@code{Standard'Address_Size} (@code{Standard} is the only allowed +prefix) is a static constant giving the number of bits in an +@code{Address}. It is the same value as System.Address'Size, +but has the advantage of being static, while a direct +reference to System.Address'Size is non-static because Address +is a private type. + +@node Asm_Input +@unnumberedsec Asm_Input +@findex Asm_Input +@noindent +The @code{Asm_Input} attribute denotes a function that takes two +parameters. The first is a string, the second is an expression of the +type designated by the prefix. The first (string) argument is required +to be a static expression, and is the constraint for the parameter, +(e.g.@: what kind of register is required). The second argument is the +value to be used as the input argument. The possible values for the +constant are the same as those used in the RTL, and are dependent on +the configuration file used to built the GCC back end. +@ref{Machine Code Insertions} + +@node Asm_Output +@unnumberedsec Asm_Output +@findex Asm_Output +@noindent +The @code{Asm_Output} attribute denotes a function that takes two +parameters. The first is a string, the second is the name of a variable +of the type designated by the attribute prefix. The first (string) +argument is required to be a static expression and designates the +constraint for the parameter (e.g.@: what kind of register is +required). The second argument is the variable to be updated with the +result. The possible values for constraint are the same as those used in +the RTL, and are dependent on the configuration file used to build the +GCC back end. If there are no output operands, then this argument may +either be omitted, or explicitly given as @code{No_Output_Operands}. +@ref{Machine Code Insertions} + +@node AST_Entry +@unnumberedsec AST_Entry +@cindex OpenVMS +@findex AST_Entry +@noindent +This attribute is implemented only in OpenVMS versions of GNAT@. Applied to +the name of an entry, it yields a value of the predefined type AST_Handler +(declared in the predefined package System, as extended by the use of +pragma @code{Extend_System (Aux_DEC)}). This value enables the given entry to +be called when an AST occurs. For further details, refer to the @cite{DEC Ada +Language Reference Manual}, section 9.12a. + +@node Bit +@unnumberedsec Bit +@findex Bit +@code{@var{obj}'Bit}, where @var{obj} is any object, yields the bit +offset within the storage unit (byte) that contains the first bit of +storage allocated for the object. The value of this attribute is of the +type @code{Universal_Integer}, and is always a non-negative number not +exceeding the value of @code{System.Storage_Unit}. + +For an object that is a variable or a constant allocated in a register, +the value is zero. (The use of this attribute does not force the +allocation of a variable to memory). + +For an object that is a formal parameter, this attribute applies +to either the matching actual parameter or to a copy of the +matching actual parameter. + +For an access object the value is zero. Note that +@code{@var{obj}.all'Bit} is subject to an @code{Access_Check} for the +designated object. Similarly for a record component +@code{@var{X}.@var{C}'Bit} is subject to a discriminant check and +@code{@var{X}(@var{I}).Bit} and @code{@var{X}(@var{I1}..@var{I2})'Bit} +are subject to index checks. + +This attribute is designed to be compatible with the DEC Ada 83 definition +and implementation of the @code{Bit} attribute. + +@node Bit_Position +@unnumberedsec Bit_Position +@findex Bit_Position +@noindent +@code{@var{R.C}'Bit_Position}, where @var{R} is a record object and C is one +of the fields of the record type, yields the bit +offset within the record contains the first bit of +storage allocated for the object. The value of this attribute is of the +type @code{Universal_Integer}. The value depends only on the field +@var{C} and is independent of the alignment of +the containing record @var{R}. + +@node Compiler_Version +@unnumberedsec Compiler_Version +@findex Compiler_Version +@noindent +@code{Standard'Compiler_Version} (@code{Standard} is the only allowed +prefix) yields a static string identifying the version of the compiler +being used to compile the unit containing the attribute reference. A +typical result would be something like "GNAT Pro 6.3.0w (20090221)". + +@node Code_Address +@unnumberedsec Code_Address +@findex Code_Address +@cindex Subprogram address +@cindex Address of subprogram code +@noindent +The @code{'Address} +attribute may be applied to subprograms in Ada 95 and Ada 2005, but the +intended effect seems to be to provide +an address value which can be used to call the subprogram by means of +an address clause as in the following example: + +@smallexample @c ada +procedure K is @dots{} + +procedure L; +for L'Address use K'Address; +pragma Import (Ada, L); +@end smallexample + +@noindent +A call to @code{L} is then expected to result in a call to @code{K}@. +In Ada 83, where there were no access-to-subprogram values, this was +a common work-around for getting the effect of an indirect call. +GNAT implements the above use of @code{Address} and the technique +illustrated by the example code works correctly. + +However, for some purposes, it is useful to have the address of the start +of the generated code for the subprogram. On some architectures, this is +not necessarily the same as the @code{Address} value described above. +For example, the @code{Address} value may reference a subprogram +descriptor rather than the subprogram itself. + +The @code{'Code_Address} attribute, which can only be applied to +subprogram entities, always returns the address of the start of the +generated code of the specified subprogram, which may or may not be +the same value as is returned by the corresponding @code{'Address} +attribute. + +@node Default_Bit_Order +@unnumberedsec Default_Bit_Order +@cindex Big endian +@cindex Little endian +@findex Default_Bit_Order +@noindent +@code{Standard'Default_Bit_Order} (@code{Standard} is the only +permissible prefix), provides the value @code{System.Default_Bit_Order} +as a @code{Pos} value (0 for @code{High_Order_First}, 1 for +@code{Low_Order_First}). This is used to construct the definition of +@code{Default_Bit_Order} in package @code{System}. + +@node Elaborated +@unnumberedsec Elaborated +@findex Elaborated +@noindent +The prefix of the @code{'Elaborated} attribute must be a unit name. The +value is a Boolean which indicates whether or not the given unit has been +elaborated. This attribute is primarily intended for internal use by the +generated code for dynamic elaboration checking, but it can also be used +in user programs. The value will always be True once elaboration of all +units has been completed. An exception is for units which need no +elaboration, the value is always False for such units. + +@node Elab_Body +@unnumberedsec Elab_Body +@findex Elab_Body +@noindent +This attribute can only be applied to a program unit name. It returns +the entity for the corresponding elaboration procedure for elaborating +the body of the referenced unit. This is used in the main generated +elaboration procedure by the binder and is not normally used in any +other context. However, there may be specialized situations in which it +is useful to be able to call this elaboration procedure from Ada code, +e.g.@: if it is necessary to do selective re-elaboration to fix some +error. + +@node Elab_Spec +@unnumberedsec Elab_Spec +@findex Elab_Spec +@noindent +This attribute can only be applied to a program unit name. It returns +the entity for the corresponding elaboration procedure for elaborating +the spec of the referenced unit. This is used in the main +generated elaboration procedure by the binder and is not normally used +in any other context. However, there may be specialized situations in +which it is useful to be able to call this elaboration procedure from +Ada code, e.g.@: if it is necessary to do selective re-elaboration to fix +some error. + +@node Emax +@unnumberedsec Emax +@cindex Ada 83 attributes +@findex Emax +@noindent +The @code{Emax} attribute is provided for compatibility with Ada 83. See +the Ada 83 reference manual for an exact description of the semantics of +this attribute. + +@node Enabled +@unnumberedsec Enabled +@findex Enabled +@noindent +The @code{Enabled} attribute allows an application program to check at compile +time to see if the designated check is currently enabled. The prefix is a +simple identifier, referencing any predefined check name (other than +@code{All_Checks}) or a check name introduced by pragma Check_Name. If +no argument is given for the attribute, the check is for the general state +of the check, if an argument is given, then it is an entity name, and the +check indicates whether an @code{Suppress} or @code{Unsuppress} has been +given naming the entity (if not, then the argument is ignored). + +Note that instantiations inherit the check status at the point of the +instantiation, so a useful idiom is to have a library package that +introduces a check name with @code{pragma Check_Name}, and then contains +generic packages or subprograms which use the @code{Enabled} attribute +to see if the check is enabled. A user of this package can then issue +a @code{pragma Suppress} or @code{pragma Unsuppress} before instantiating +the package or subprogram, controlling whether the check will be present. + +@node Enum_Rep +@unnumberedsec Enum_Rep +@cindex Representation of enums +@findex Enum_Rep +@noindent +For every enumeration subtype @var{S}, @code{@var{S}'Enum_Rep} denotes a +function with the following spec: + +@smallexample @c ada +function @var{S}'Enum_Rep (Arg : @var{S}'Base) + return @i{Universal_Integer}; +@end smallexample + +@noindent +It is also allowable to apply @code{Enum_Rep} directly to an object of an +enumeration type or to a non-overloaded enumeration +literal. In this case @code{@var{S}'Enum_Rep} is equivalent to +@code{@var{typ}'Enum_Rep(@var{S})} where @var{typ} is the type of the +enumeration literal or object. + +The function returns the representation value for the given enumeration +value. This will be equal to value of the @code{Pos} attribute in the +absence of an enumeration representation clause. This is a static +attribute (i.e.@: the result is static if the argument is static). + +@code{@var{S}'Enum_Rep} can also be used with integer types and objects, +in which case it simply returns the integer value. The reason for this +is to allow it to be used for @code{(<>)} discrete formal arguments in +a generic unit that can be instantiated with either enumeration types +or integer types. Note that if @code{Enum_Rep} is used on a modular +type whose upper bound exceeds the upper bound of the largest signed +integer type, and the argument is a variable, so that the universal +integer calculation is done at run time, then the call to @code{Enum_Rep} +may raise @code{Constraint_Error}. + +@node Enum_Val +@unnumberedsec Enum_Val +@cindex Representation of enums +@findex Enum_Val +@noindent +For every enumeration subtype @var{S}, @code{@var{S}'Enum_Val} denotes a +function with the following spec: + +@smallexample @c ada +function @var{S}'Enum_Val (Arg : @i{Universal_Integer) + return @var{S}'Base}; +@end smallexample + +@noindent +The function returns the enumeration value whose representation matches the +argument, or raises Constraint_Error if no enumeration literal of the type +has the matching value. +This will be equal to value of the @code{Val} attribute in the +absence of an enumeration representation clause. This is a static +attribute (i.e.@: the result is static if the argument is static). + +@node Epsilon +@unnumberedsec Epsilon +@cindex Ada 83 attributes +@findex Epsilon +@noindent +The @code{Epsilon} attribute is provided for compatibility with Ada 83. See +the Ada 83 reference manual for an exact description of the semantics of +this attribute. + +@node Fixed_Value +@unnumberedsec Fixed_Value +@findex Fixed_Value +@noindent +For every fixed-point type @var{S}, @code{@var{S}'Fixed_Value} denotes a +function with the following specification: + +@smallexample @c ada +function @var{S}'Fixed_Value (Arg : @i{Universal_Integer}) + return @var{S}; +@end smallexample + +@noindent +The value returned is the fixed-point value @var{V} such that + +@smallexample @c ada +@var{V} = Arg * @var{S}'Small +@end smallexample + +@noindent +The effect is thus similar to first converting the argument to the +integer type used to represent @var{S}, and then doing an unchecked +conversion to the fixed-point type. The difference is +that there are full range checks, to ensure that the result is in range. +This attribute is primarily intended for use in implementation of the +input-output functions for fixed-point values. + +@node Has_Access_Values +@unnumberedsec Has_Access_Values +@cindex Access values, testing for +@findex Has_Access_Values +@noindent +The prefix of the @code{Has_Access_Values} attribute is a type. The result +is a Boolean value which is True if the is an access type, or is a composite +type with a component (at any nesting depth) that is an access type, and is +False otherwise. +The intended use of this attribute is in conjunction with generic +definitions. If the attribute is applied to a generic private type, it +indicates whether or not the corresponding actual type has access values. + +@node Has_Discriminants +@unnumberedsec Has_Discriminants +@cindex Discriminants, testing for +@findex Has_Discriminants +@noindent +The prefix of the @code{Has_Discriminants} attribute is a type. The result +is a Boolean value which is True if the type has discriminants, and False +otherwise. The intended use of this attribute is in conjunction with generic +definitions. If the attribute is applied to a generic private type, it +indicates whether or not the corresponding actual type has discriminants. + +@node Img +@unnumberedsec Img +@findex Img +@noindent +The @code{Img} attribute differs from @code{Image} in that it may be +applied to objects as well as types, in which case it gives the +@code{Image} for the subtype of the object. This is convenient for +debugging: + +@smallexample @c ada +Put_Line ("X = " & X'Img); +@end smallexample + +@noindent +has the same meaning as the more verbose: + +@smallexample @c ada +Put_Line ("X = " & @var{T}'Image (X)); +@end smallexample + +@noindent +where @var{T} is the (sub)type of the object @code{X}. + +@node Integer_Value +@unnumberedsec Integer_Value +@findex Integer_Value +@noindent +For every integer type @var{S}, @code{@var{S}'Integer_Value} denotes a +function with the following spec: + +@smallexample @c ada +function @var{S}'Integer_Value (Arg : @i{Universal_Fixed}) + return @var{S}; +@end smallexample + +@noindent +The value returned is the integer value @var{V}, such that + +@smallexample @c ada +Arg = @var{V} * @var{T}'Small +@end smallexample + +@noindent +where @var{T} is the type of @code{Arg}. +The effect is thus similar to first doing an unchecked conversion from +the fixed-point type to its corresponding implementation type, and then +converting the result to the target integer type. The difference is +that there are full range checks, to ensure that the result is in range. +This attribute is primarily intended for use in implementation of the +standard input-output functions for fixed-point values. + +@node Invalid_Value +@unnumberedsec Invalid_Value +@findex Invalid_Value +@noindent +For every scalar type S, S'Invalid_Value returns an undefined value of the +type. If possible this value is an invalid representation for the type. The +value returned is identical to the value used to initialize an otherwise +uninitialized value of the type if pragma Initialize_Scalars is used, +including the ability to modify the value with the binder -Sxx flag and +relevant environment variables at run time. + +@node Large +@unnumberedsec Large +@cindex Ada 83 attributes +@findex Large +@noindent +The @code{Large} attribute is provided for compatibility with Ada 83. See +the Ada 83 reference manual for an exact description of the semantics of +this attribute. + +@node Machine_Size +@unnumberedsec Machine_Size +@findex Machine_Size +@noindent +This attribute is identical to the @code{Object_Size} attribute. It is +provided for compatibility with the DEC Ada 83 attribute of this name. + +@node Mantissa +@unnumberedsec Mantissa +@cindex Ada 83 attributes +@findex Mantissa +@noindent +The @code{Mantissa} attribute is provided for compatibility with Ada 83. See +the Ada 83 reference manual for an exact description of the semantics of +this attribute. + +@node Max_Interrupt_Priority +@unnumberedsec Max_Interrupt_Priority +@cindex Interrupt priority, maximum +@findex Max_Interrupt_Priority +@noindent +@code{Standard'Max_Interrupt_Priority} (@code{Standard} is the only +permissible prefix), provides the same value as +@code{System.Max_Interrupt_Priority}. + +@node Max_Priority +@unnumberedsec Max_Priority +@cindex Priority, maximum +@findex Max_Priority +@noindent +@code{Standard'Max_Priority} (@code{Standard} is the only permissible +prefix) provides the same value as @code{System.Max_Priority}. + +@node Maximum_Alignment +@unnumberedsec Maximum_Alignment +@cindex Alignment, maximum +@findex Maximum_Alignment +@noindent +@code{Standard'Maximum_Alignment} (@code{Standard} is the only +permissible prefix) provides the maximum useful alignment value for the +target. This is a static value that can be used to specify the alignment +for an object, guaranteeing that it is properly aligned in all +cases. + +@node Mechanism_Code +@unnumberedsec Mechanism_Code +@cindex Return values, passing mechanism +@cindex Parameters, passing mechanism +@findex Mechanism_Code +@noindent +@code{@var{function}'Mechanism_Code} yields an integer code for the +mechanism used for the result of function, and +@code{@var{subprogram}'Mechanism_Code (@var{n})} yields the mechanism +used for formal parameter number @var{n} (a static integer value with 1 +meaning the first parameter) of @var{subprogram}. The code returned is: + +@table @asis +@item 1 +by copy (value) +@item 2 +by reference +@item 3 +by descriptor (default descriptor class) +@item 4 +by descriptor (UBS: unaligned bit string) +@item 5 +by descriptor (UBSB: aligned bit string with arbitrary bounds) +@item 6 +by descriptor (UBA: unaligned bit array) +@item 7 +by descriptor (S: string, also scalar access type parameter) +@item 8 +by descriptor (SB: string with arbitrary bounds) +@item 9 +by descriptor (A: contiguous array) +@item 10 +by descriptor (NCA: non-contiguous array) +@end table + +@noindent +Values from 3 through 10 are only relevant to Digital OpenVMS implementations. +@cindex OpenVMS + +@node Null_Parameter +@unnumberedsec Null_Parameter +@cindex Zero address, passing +@findex Null_Parameter +@noindent +A reference @code{@var{T}'Null_Parameter} denotes an imaginary object of +type or subtype @var{T} allocated at machine address zero. The attribute +is allowed only as the default expression of a formal parameter, or as +an actual expression of a subprogram call. In either case, the +subprogram must be imported. + +The identity of the object is represented by the address zero in the +argument list, independent of the passing mechanism (explicit or +default). + +This capability is needed to specify that a zero address should be +passed for a record or other composite object passed by reference. +There is no way of indicating this without the @code{Null_Parameter} +attribute. + +@node Object_Size +@unnumberedsec Object_Size +@cindex Size, used for objects +@findex Object_Size +@noindent +The size of an object is not necessarily the same as the size of the type +of an object. This is because by default object sizes are increased to be +a multiple of the alignment of the object. For example, +@code{Natural'Size} is +31, but by default objects of type @code{Natural} will have a size of 32 bits. +Similarly, a record containing an integer and a character: + +@smallexample @c ada +type Rec is record + I : Integer; + C : Character; +end record; +@end smallexample + +@noindent +will have a size of 40 (that is @code{Rec'Size} will be 40). The +alignment will be 4, because of the +integer field, and so the default size of record objects for this type +will be 64 (8 bytes). + +@node Old +@unnumberedsec Old +@cindex Capturing Old values +@cindex Postconditions +@noindent +The attribute Prefix'Old can be used within a +subprogram body or within a precondition or +postcondition pragma. The effect is to +refer to the value of the prefix on entry. So for +example if you have an argument of a record type X called Arg1, +you can refer to Arg1.Field'Old which yields the value of +Arg1.Field on entry. The implementation simply involves generating +an object declaration which captures the value on entry. Any +prefix is allowed except one of a limited type (since limited +types cannot be copied to capture their values) or an expression +which references a local variable +(since local variables do not exist at subprogram entry time). + +The following example shows the use of 'Old to implement +a test of a postcondition: + +@smallexample @c ada +with Old_Pkg; +procedure Old is +begin + Old_Pkg.Incr; +end Old; + +package Old_Pkg is + procedure Incr; +end Old_Pkg; + +package body Old_Pkg is + Count : Natural := 0; + + procedure Incr is + begin + ... code manipulating the value of Count + + pragma Assert (Count = Count'Old + 1); + end Incr; +end Old_Pkg; +@end smallexample + +@noindent +Note that it is allowed to apply 'Old to a constant entity, but this will +result in a warning, since the old and new values will always be the same. + +@node Passed_By_Reference +@unnumberedsec Passed_By_Reference +@cindex Parameters, when passed by reference +@findex Passed_By_Reference +@noindent +@code{@var{type}'Passed_By_Reference} for any subtype @var{type} returns +a value of type @code{Boolean} value that is @code{True} if the type is +normally passed by reference and @code{False} if the type is normally +passed by copy in calls. For scalar types, the result is always @code{False} +and is static. For non-scalar types, the result is non-static. + +@node Pool_Address +@unnumberedsec Pool_Address +@cindex Parameters, when passed by reference +@findex Pool_Address +@noindent +@code{@var{X}'Pool_Address} for any object @var{X} returns the address +of X within its storage pool. This is the same as +@code{@var{X}'Address}, except that for an unconstrained array whose +bounds are allocated just before the first component, +@code{@var{X}'Pool_Address} returns the address of those bounds, +whereas @code{@var{X}'Address} returns the address of the first +component. + +Here, we are interpreting ``storage pool'' broadly to mean ``wherever +the object is allocated'', which could be a user-defined storage pool, +the global heap, on the stack, or in a static memory area. For an +object created by @code{new}, @code{@var{Ptr.all}'Pool_Address} is +what is passed to @code{Allocate} and returned from @code{Deallocate}. + +@node Range_Length +@unnumberedsec Range_Length +@findex Range_Length +@noindent +@code{@var{type}'Range_Length} for any discrete type @var{type} yields +the number of values represented by the subtype (zero for a null +range). The result is static for static subtypes. @code{Range_Length} +applied to the index subtype of a one dimensional array always gives the +same result as @code{Range} applied to the array itself. + +@node Ref +@unnumberedsec Ref +@findex Ref +@noindent +The @code{System.Address'Ref} +(@code{System.Address} is the only permissible prefix) +denotes a function identical to +@code{System.Storage_Elements.To_Address} except that +it is a static attribute. See @ref{To_Address} for more details. + +@node Result +@unnumberedsec Result +@findex Result +@noindent +@code{@var{function}'Result} can only be used with in a Postcondition pragma +for a function. The prefix must be the name of the corresponding function. This +is used to refer to the result of the function in the postcondition expression. +For a further discussion of the use of this attribute and examples of its use, +see the description of pragma Postcondition. + +@node Safe_Emax +@unnumberedsec Safe_Emax +@cindex Ada 83 attributes +@findex Safe_Emax +@noindent +The @code{Safe_Emax} attribute is provided for compatibility with Ada 83. See +the Ada 83 reference manual for an exact description of the semantics of +this attribute. + +@node Safe_Large +@unnumberedsec Safe_Large +@cindex Ada 83 attributes +@findex Safe_Large +@noindent +The @code{Safe_Large} attribute is provided for compatibility with Ada 83. See +the Ada 83 reference manual for an exact description of the semantics of +this attribute. + +@node Small +@unnumberedsec Small +@cindex Ada 83 attributes +@findex Small +@noindent +The @code{Small} attribute is defined in Ada 95 (and Ada 2005) only for +fixed-point types. +GNAT also allows this attribute to be applied to floating-point types +for compatibility with Ada 83. See +the Ada 83 reference manual for an exact description of the semantics of +this attribute when applied to floating-point types. + +@node Storage_Unit +@unnumberedsec Storage_Unit +@findex Storage_Unit +@noindent +@code{Standard'Storage_Unit} (@code{Standard} is the only permissible +prefix) provides the same value as @code{System.Storage_Unit}. + +@node Stub_Type +@unnumberedsec Stub_Type +@findex Stub_Type +@noindent +The GNAT implementation of remote access-to-classwide types is +organized as described in AARM section E.4 (20.t): a value of an RACW type +(designating a remote object) is represented as a normal access +value, pointing to a "stub" object which in turn contains the +necessary information to contact the designated remote object. A +call on any dispatching operation of such a stub object does the +remote call, if necessary, using the information in the stub object +to locate the target partition, etc. + +For a prefix @code{T} that denotes a remote access-to-classwide type, +@code{T'Stub_Type} denotes the type of the corresponding stub objects. + +By construction, the layout of @code{T'Stub_Type} is identical to that of +type @code{RACW_Stub_Type} declared in the internal implementation-defined +unit @code{System.Partition_Interface}. Use of this attribute will create +an implicit dependency on this unit. + +@node Target_Name +@unnumberedsec Target_Name +@findex Target_Name +@noindent +@code{Standard'Target_Name} (@code{Standard} is the only permissible +prefix) provides a static string value that identifies the target +for the current compilation. For GCC implementations, this is the +standard gcc target name without the terminating slash (for +example, GNAT 5.0 on windows yields "i586-pc-mingw32msv"). + +@node Tick +@unnumberedsec Tick +@findex Tick +@noindent +@code{Standard'Tick} (@code{Standard} is the only permissible prefix) +provides the same value as @code{System.Tick}, + +@node To_Address +@unnumberedsec To_Address +@findex To_Address +@noindent +The @code{System'To_Address} +(@code{System} is the only permissible prefix) +denotes a function identical to +@code{System.Storage_Elements.To_Address} except that +it is a static attribute. This means that if its argument is +a static expression, then the result of the attribute is a +static expression. The result is that such an expression can be +used in contexts (e.g.@: preelaborable packages) which require a +static expression and where the function call could not be used +(since the function call is always non-static, even if its +argument is static). + +@node Type_Class +@unnumberedsec Type_Class +@findex Type_Class +@noindent +@code{@var{type}'Type_Class} for any type or subtype @var{type} yields +the value of the type class for the full type of @var{type}. If +@var{type} is a generic formal type, the value is the value for the +corresponding actual subtype. The value of this attribute is of type +@code{System.Aux_DEC.Type_Class}, which has the following definition: + +@smallexample @c ada + 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, + Type_Class_Address); +@end smallexample + +@noindent +Protected types yield the value @code{Type_Class_Task}, which thus +applies to all concurrent types. This attribute is designed to +be compatible with the DEC Ada 83 attribute of the same name. + +@node UET_Address +@unnumberedsec UET_Address +@findex UET_Address +@noindent +The @code{UET_Address} attribute can only be used for a prefix which +denotes a library package. It yields the address of the unit exception +table when zero cost exception handling is used. This attribute is +intended only for use within the GNAT implementation. See the unit +@code{Ada.Exceptions} in files @file{a-except.ads} and @file{a-except.adb} +for details on how this attribute is used in the implementation. + +@node Unconstrained_Array +@unnumberedsec Unconstrained_Array +@findex Unconstrained_Array +@noindent +The @code{Unconstrained_Array} attribute can be used with a prefix that +denotes any type or subtype. It is a static attribute that yields +@code{True} if the prefix designates an unconstrained array, +and @code{False} otherwise. In a generic instance, the result is +still static, and yields the result of applying this test to the +generic actual. + +@node Universal_Literal_String +@unnumberedsec Universal_Literal_String +@cindex Named numbers, representation of +@findex Universal_Literal_String +@noindent +The prefix of @code{Universal_Literal_String} must be a named +number. The static result is the string consisting of the characters of +the number as defined in the original source. This allows the user +program to access the actual text of named numbers without intermediate +conversions and without the need to enclose the strings in quotes (which +would preclude their use as numbers). + +For example, the following program prints the first 50 digits of pi: + +@smallexample @c ada +with Text_IO; use Text_IO; +with Ada.Numerics; +procedure Pi is +begin + Put (Ada.Numerics.Pi'Universal_Literal_String); +end; +@end smallexample + +@node Unrestricted_Access +@unnumberedsec Unrestricted_Access +@cindex @code{Access}, unrestricted +@findex Unrestricted_Access +@noindent +The @code{Unrestricted_Access} attribute is similar to @code{Access} +except that all accessibility and aliased view checks are omitted. This +is a user-beware attribute. It is similar to +@code{Address}, for which it is a desirable replacement where the value +desired is an access type. In other words, its effect is identical to +first applying the @code{Address} attribute and then doing an unchecked +conversion to a desired access type. In GNAT, but not necessarily in +other implementations, the use of static chains for inner level +subprograms means that @code{Unrestricted_Access} applied to a +subprogram yields a value that can be called as long as the subprogram +is in scope (normal Ada accessibility rules restrict this usage). + +It is possible to use @code{Unrestricted_Access} for any type, but care +must be exercised if it is used to create pointers to unconstrained +objects. In this case, the resulting pointer has the same scope as the +context of the attribute, and may not be returned to some enclosing +scope. For instance, a function cannot use @code{Unrestricted_Access} +to create a unconstrained pointer and then return that value to the +caller. + +@node VADS_Size +@unnumberedsec VADS_Size +@cindex @code{Size}, VADS compatibility +@findex VADS_Size +@noindent +The @code{'VADS_Size} attribute is intended to make it easier to port +legacy code which relies on the semantics of @code{'Size} as implemented +by the VADS Ada 83 compiler. GNAT makes a best effort at duplicating the +same semantic interpretation. In particular, @code{'VADS_Size} applied +to a predefined or other primitive type with no Size clause yields the +Object_Size (for example, @code{Natural'Size} is 32 rather than 31 on +typical machines). In addition @code{'VADS_Size} applied to an object +gives the result that would be obtained by applying the attribute to +the corresponding type. + +@node Value_Size +@unnumberedsec Value_Size +@cindex @code{Size}, setting for not-first subtype +@findex Value_Size +@code{@var{type}'Value_Size} is the number of bits required to represent +a value of the given subtype. It is the same as @code{@var{type}'Size}, +but, unlike @code{Size}, may be set for non-first subtypes. + +@node Wchar_T_Size +@unnumberedsec Wchar_T_Size +@findex Wchar_T_Size +@code{Standard'Wchar_T_Size} (@code{Standard} is the only permissible +prefix) provides the size in bits of the C @code{wchar_t} type +primarily for constructing the definition of this type in +package @code{Interfaces.C}. + +@node Word_Size +@unnumberedsec Word_Size +@findex Word_Size +@code{Standard'Word_Size} (@code{Standard} is the only permissible +prefix) provides the value @code{System.Word_Size}. + +@c ------------------------ +@node Implementation Advice +@chapter Implementation Advice +@noindent +The main text of the Ada Reference Manual describes the required +behavior of all Ada compilers, and the GNAT compiler conforms to +these requirements. + +In addition, there are sections throughout the Ada Reference Manual headed +by the phrase ``Implementation advice''. These sections are not normative, +i.e., they do not specify requirements that all compilers must +follow. Rather they provide advice on generally desirable behavior. You +may wonder why they are not requirements. The most typical answer is +that they describe behavior that seems generally desirable, but cannot +be provided on all systems, or which may be undesirable on some systems. + +As far as practical, GNAT follows the implementation advice sections in +the Ada Reference Manual. This chapter contains a table giving the +reference manual section number, paragraph number and several keywords +for each advice. Each entry consists of the text of the advice followed +by the GNAT interpretation of this advice. Most often, this simply says +``followed'', which means that GNAT follows the advice. However, in a +number of cases, GNAT deliberately deviates from this advice, in which +case the text describes what GNAT does and why. + +@cindex Error detection +@unnumberedsec 1.1.3(20): Error Detection +@sp 1 +@cartouche +If an implementation detects the use of an unsupported Specialized Needs +Annex feature at run time, it should raise @code{Program_Error} if +feasible. +@end cartouche +Not relevant. All specialized needs annex features are either supported, +or diagnosed at compile time. + +@cindex Child Units +@unnumberedsec 1.1.3(31): Child Units +@sp 1 +@cartouche +If an implementation wishes to provide implementation-defined +extensions to the functionality of a language-defined library unit, it +should normally do so by adding children to the library unit. +@end cartouche +Followed. + +@cindex Bounded errors +@unnumberedsec 1.1.5(12): Bounded Errors +@sp 1 +@cartouche +If an implementation detects a bounded error or erroneous +execution, it should raise @code{Program_Error}. +@end cartouche +Followed in all cases in which the implementation detects a bounded +error or erroneous execution. Not all such situations are detected at +runtime. + +@cindex Pragmas +@unnumberedsec 2.8(16): Pragmas +@sp 1 +@cartouche +Normally, implementation-defined pragmas should have no semantic effect +for error-free programs; that is, if the implementation-defined pragmas +are removed from a working program, the program should still be legal, +and should still have the same semantics. +@end cartouche +The following implementation defined pragmas are exceptions to this +rule: + +@table @code +@item Abort_Defer +Affects semantics +@item Ada_83 +Affects legality +@item Assert +Affects semantics +@item CPP_Class +Affects semantics +@item CPP_Constructor +Affects semantics +@item Debug +Affects semantics +@item Interface_Name +Affects semantics +@item Machine_Attribute +Affects semantics +@item Unimplemented_Unit +Affects legality +@item Unchecked_Union +Affects semantics +@end table + +@noindent +In each of the above cases, it is essential to the purpose of the pragma +that this advice not be followed. For details see the separate section +on implementation defined pragmas. + +@unnumberedsec 2.8(17-19): Pragmas +@sp 1 +@cartouche +Normally, an implementation should not define pragmas that can +make an illegal program legal, except as follows: +@end cartouche +@sp 1 +@cartouche +A pragma used to complete a declaration, such as a pragma @code{Import}; +@end cartouche +@sp 1 +@cartouche +A pragma used to configure the environment by adding, removing, or +replacing @code{library_items}. +@end cartouche +See response to paragraph 16 of this same section. + +@cindex Character Sets +@cindex Alternative Character Sets +@unnumberedsec 3.5.2(5): Alternative Character Sets +@sp 1 +@cartouche +If an implementation supports a mode with alternative interpretations +for @code{Character} and @code{Wide_Character}, the set of graphic +characters of @code{Character} should nevertheless remain a proper +subset of the set of graphic characters of @code{Wide_Character}. Any +character set ``localizations'' should be reflected in the results of +the subprograms defined in the language-defined package +@code{Characters.Handling} (see A.3) available in such a mode. In a mode with +an alternative interpretation of @code{Character}, the implementation should +also support a corresponding change in what is a legal +@code{identifier_letter}. +@end cartouche +Not all wide character modes follow this advice, in particular the JIS +and IEC modes reflect standard usage in Japan, and in these encoding, +the upper half of the Latin-1 set is not part of the wide-character +subset, since the most significant bit is used for wide character +encoding. However, this only applies to the external forms. Internally +there is no such restriction. + +@cindex Integer types +@unnumberedsec 3.5.4(28): Integer Types + +@sp 1 +@cartouche +An implementation should support @code{Long_Integer} in addition to +@code{Integer} if the target machine supports 32-bit (or longer) +arithmetic. No other named integer subtypes are recommended for package +@code{Standard}. Instead, appropriate named integer subtypes should be +provided in the library package @code{Interfaces} (see B.2). +@end cartouche +@code{Long_Integer} is supported. Other standard integer types are supported +so this advice is not fully followed. These types +are supported for convenient interface to C, and so that all hardware +types of the machine are easily available. +@unnumberedsec 3.5.4(29): Integer Types + +@sp 1 +@cartouche +An implementation for a two's complement machine should support +modular types with a binary modulus up to @code{System.Max_Int*2+2}. An +implementation should support a non-binary modules up to @code{Integer'Last}. +@end cartouche +Followed. + +@cindex Enumeration values +@unnumberedsec 3.5.5(8): Enumeration Values +@sp 1 +@cartouche +For the evaluation of a call on @code{@var{S}'Pos} for an enumeration +subtype, if the value of the operand does not correspond to the internal +code for any enumeration literal of its type (perhaps due to an +un-initialized variable), then the implementation should raise +@code{Program_Error}. This is particularly important for enumeration +types with noncontiguous internal codes specified by an +enumeration_representation_clause. +@end cartouche +Followed. + +@cindex Float types +@unnumberedsec 3.5.7(17): Float Types +@sp 1 +@cartouche +An implementation should support @code{Long_Float} in addition to +@code{Float} if the target machine supports 11 or more digits of +precision. No other named floating point subtypes are recommended for +package @code{Standard}. Instead, appropriate named floating point subtypes +should be provided in the library package @code{Interfaces} (see B.2). +@end cartouche +@code{Short_Float} and @code{Long_Long_Float} are also provided. The +former provides improved compatibility with other implementations +supporting this type. The latter corresponds to the highest precision +floating-point type supported by the hardware. On most machines, this +will be the same as @code{Long_Float}, but on some machines, it will +correspond to the IEEE extended form. The notable case is all ia32 +(x86) implementations, where @code{Long_Long_Float} corresponds to +the 80-bit extended precision format supported in hardware on this +processor. Note that the 128-bit format on SPARC is not supported, +since this is a software rather than a hardware format. + +@cindex Multidimensional arrays +@cindex Arrays, multidimensional +@unnumberedsec 3.6.2(11): Multidimensional Arrays +@sp 1 +@cartouche +An implementation should normally represent multidimensional arrays in +row-major order, consistent with the notation used for multidimensional +array aggregates (see 4.3.3). However, if a pragma @code{Convention} +(@code{Fortran}, @dots{}) applies to a multidimensional array type, then +column-major order should be used instead (see B.5, ``Interfacing with +Fortran''). +@end cartouche +Followed. + +@findex Duration'Small +@unnumberedsec 9.6(30-31): Duration'Small +@sp 1 +@cartouche +Whenever possible in an implementation, the value of @code{Duration'Small} +should be no greater than 100 microseconds. +@end cartouche +Followed. (@code{Duration'Small} = 10**(@minus{}9)). + +@sp 1 +@cartouche +The time base for @code{delay_relative_statements} should be monotonic; +it need not be the same time base as used for @code{Calendar.Clock}. +@end cartouche +Followed. + +@unnumberedsec 10.2.1(12): Consistent Representation +@sp 1 +@cartouche +In an implementation, a type declared in a pre-elaborated package should +have the same representation in every elaboration of a given version of +the package, whether the elaborations occur in distinct executions of +the same program, or in executions of distinct programs or partitions +that include the given version. +@end cartouche +Followed, except in the case of tagged types. Tagged types involve +implicit pointers to a local copy of a dispatch table, and these pointers +have representations which thus depend on a particular elaboration of the +package. It is not easy to see how it would be possible to follow this +advice without severely impacting efficiency of execution. + +@cindex Exception information +@unnumberedsec 11.4.1(19): Exception Information +@sp 1 +@cartouche +@code{Exception_Message} by default and @code{Exception_Information} +should produce information useful for +debugging. @code{Exception_Message} should be short, about one +line. @code{Exception_Information} can be long. @code{Exception_Message} +should not include the +@code{Exception_Name}. @code{Exception_Information} should include both +the @code{Exception_Name} and the @code{Exception_Message}. +@end cartouche +Followed. For each exception that doesn't have a specified +@code{Exception_Message}, the compiler generates one containing the location +of the raise statement. This location has the form ``file:line'', where +file is the short file name (without path information) and line is the line +number in the file. Note that in the case of the Zero Cost Exception +mechanism, these messages become redundant with the Exception_Information that +contains a full backtrace of the calling sequence, so they are disabled. +To disable explicitly the generation of the source location message, use the +Pragma @code{Discard_Names}. + +@cindex Suppression of checks +@cindex Checks, suppression of +@unnumberedsec 11.5(28): Suppression of Checks +@sp 1 +@cartouche +The implementation should minimize the code executed for checks that +have been suppressed. +@end cartouche +Followed. + +@cindex Representation clauses +@unnumberedsec 13.1 (21-24): Representation Clauses +@sp 1 +@cartouche +The recommended level of support for all representation items is +qualified as follows: +@end cartouche +@sp 1 +@cartouche +An implementation need not support representation items containing +non-static expressions, except that an implementation should support a +representation item for a given entity if each non-static expression in +the representation item is a name that statically denotes a constant +declared before the entity. +@end cartouche +Followed. In fact, GNAT goes beyond the recommended level of support +by allowing nonstatic expressions in some representation clauses even +without the need to declare constants initialized with the values of +such expressions. +For example: + +@smallexample @c ada + X : Integer; + Y : Float; + for Y'Address use X'Address;>> +@end smallexample + +@sp 1 +@cartouche +An implementation need not support a specification for the @code{Size} +for a given composite subtype, nor the size or storage place for an +object (including a component) of a given composite subtype, unless the +constraints on the subtype and its composite subcomponents (if any) are +all static constraints. +@end cartouche +Followed. Size Clauses are not permitted on non-static components, as +described above. + +@sp 1 +@cartouche +An aliased component, or a component whose type is by-reference, should +always be allocated at an addressable location. +@end cartouche +Followed. + +@cindex Packed types +@unnumberedsec 13.2(6-8): Packed Types +@sp 1 +@cartouche +If a type is packed, then the implementation should try to minimize +storage allocated to objects of the type, possibly at the expense of +speed of accessing components, subject to reasonable complexity in +addressing calculations. +@end cartouche +@sp 1 +@cartouche +The recommended level of support pragma @code{Pack} is: + +For a packed record type, the components should be packed as tightly as +possible subject to the Sizes of the component subtypes, and subject to +any @code{record_representation_clause} that applies to the type; the +implementation may, but need not, reorder components or cross aligned +word boundaries to improve the packing. A component whose @code{Size} is +greater than the word size may be allocated an integral number of words. +@end cartouche +Followed. Tight packing of arrays is supported for all component sizes +up to 64-bits. If the array component size is 1 (that is to say, if +the component is a boolean type or an enumeration type with two values) +then values of the type are implicitly initialized to zero. This +happens both for objects of the packed type, and for objects that have a +subcomponent of the packed type. + +@sp 1 +@cartouche +An implementation should support Address clauses for imported +subprograms. +@end cartouche +Followed. +@cindex @code{Address} clauses +@unnumberedsec 13.3(14-19): Address Clauses + +@sp 1 +@cartouche +For an array @var{X}, @code{@var{X}'Address} should point at the first +component of the array, and not at the array bounds. +@end cartouche +Followed. + +@sp 1 +@cartouche +The recommended level of support for the @code{Address} attribute is: + +@code{@var{X}'Address} should produce a useful result if @var{X} is an +object that is aliased or of a by-reference type, or is an entity whose +@code{Address} has been specified. +@end cartouche +Followed. A valid address will be produced even if none of those +conditions have been met. If necessary, the object is forced into +memory to ensure the address is valid. + +@sp 1 +@cartouche +An implementation should support @code{Address} clauses for imported +subprograms. +@end cartouche +Followed. + +@sp 1 +@cartouche +Objects (including subcomponents) that are aliased or of a by-reference +type should be allocated on storage element boundaries. +@end cartouche +Followed. + +@sp 1 +@cartouche +If the @code{Address} of an object is specified, or it is imported or exported, +then the implementation should not perform optimizations based on +assumptions of no aliases. +@end cartouche +Followed. + +@cindex @code{Alignment} clauses +@unnumberedsec 13.3(29-35): Alignment Clauses +@sp 1 +@cartouche +The recommended level of support for the @code{Alignment} attribute for +subtypes is: + +An implementation should support specified Alignments that are factors +and multiples of the number of storage elements per word, subject to the +following: +@end cartouche +Followed. + +@sp 1 +@cartouche +An implementation need not support specified @code{Alignment}s for +combinations of @code{Size}s and @code{Alignment}s that cannot be easily +loaded and stored by available machine instructions. +@end cartouche +Followed. + +@sp 1 +@cartouche +An implementation need not support specified @code{Alignment}s that are +greater than the maximum @code{Alignment} the implementation ever returns by +default. +@end cartouche +Followed. + +@sp 1 +@cartouche +The recommended level of support for the @code{Alignment} attribute for +objects is: + +Same as above, for subtypes, but in addition: +@end cartouche +Followed. + +@sp 1 +@cartouche +For stand-alone library-level objects of statically constrained +subtypes, the implementation should support all @code{Alignment}s +supported by the target linker. For example, page alignment is likely to +be supported for such objects, but not for subtypes. +@end cartouche +Followed. + +@cindex @code{Size} clauses +@unnumberedsec 13.3(42-43): Size Clauses +@sp 1 +@cartouche +The recommended level of support for the @code{Size} attribute of +objects is: + +A @code{Size} clause should be supported for an object if the specified +@code{Size} is at least as large as its subtype's @code{Size}, and +corresponds to a size in storage elements that is a multiple of the +object's @code{Alignment} (if the @code{Alignment} is nonzero). +@end cartouche +Followed. + +@unnumberedsec 13.3(50-56): Size Clauses +@sp 1 +@cartouche +If the @code{Size} of a subtype is specified, and allows for efficient +independent addressability (see 9.10) on the target architecture, then +the @code{Size} of the following objects of the subtype should equal the +@code{Size} of the subtype: + +Aliased objects (including components). +@end cartouche +Followed. + +@sp 1 +@cartouche +@code{Size} clause on a composite subtype should not affect the +internal layout of components. +@end cartouche +Followed. But note that this can be overridden by use of the implementation +pragma Implicit_Packing in the case of packed arrays. + +@sp 1 +@cartouche +The recommended level of support for the @code{Size} attribute of subtypes is: +@end cartouche +@sp 1 +@cartouche +The @code{Size} (if not specified) of a static discrete or fixed point +subtype should be the number of bits needed to represent each value +belonging to the subtype using an unbiased representation, leaving space +for a sign bit only if the subtype contains negative values. If such a +subtype is a first subtype, then an implementation should support a +specified @code{Size} for it that reflects this representation. +@end cartouche +Followed. + +@sp 1 +@cartouche +For a subtype implemented with levels of indirection, the @code{Size} +should include the size of the pointers, but not the size of what they +point at. +@end cartouche +Followed. + +@cindex @code{Component_Size} clauses +@unnumberedsec 13.3(71-73): Component Size Clauses +@sp 1 +@cartouche +The recommended level of support for the @code{Component_Size} +attribute is: +@end cartouche +@sp 1 +@cartouche +An implementation need not support specified @code{Component_Sizes} that are +less than the @code{Size} of the component subtype. +@end cartouche +Followed. + +@sp 1 +@cartouche +An implementation should support specified @code{Component_Size}s that +are factors and multiples of the word size. For such +@code{Component_Size}s, the array should contain no gaps between +components. For other @code{Component_Size}s (if supported), the array +should contain no gaps between components when packing is also +specified; the implementation should forbid this combination in cases +where it cannot support a no-gaps representation. +@end cartouche +Followed. + +@cindex Enumeration representation clauses +@cindex Representation clauses, enumeration +@unnumberedsec 13.4(9-10): Enumeration Representation Clauses +@sp 1 +@cartouche +The recommended level of support for enumeration representation clauses +is: + +An implementation need not support enumeration representation clauses +for boolean types, but should at minimum support the internal codes in +the range @code{System.Min_Int.System.Max_Int}. +@end cartouche +Followed. + +@cindex Record representation clauses +@cindex Representation clauses, records +@unnumberedsec 13.5.1(17-22): Record Representation Clauses +@sp 1 +@cartouche +The recommended level of support for +@*@code{record_representation_clauses} is: + +An implementation should support storage places that can be extracted +with a load, mask, shift sequence of machine code, and set with a load, +shift, mask, store sequence, given the available machine instructions +and run-time model. +@end cartouche +Followed. + +@sp 1 +@cartouche +A storage place should be supported if its size is equal to the +@code{Size} of the component subtype, and it starts and ends on a +boundary that obeys the @code{Alignment} of the component subtype. +@end cartouche +Followed. + +@sp 1 +@cartouche +If the default bit ordering applies to the declaration of a given type, +then for a component whose subtype's @code{Size} is less than the word +size, any storage place that does not cross an aligned word boundary +should be supported. +@end cartouche +Followed. + +@sp 1 +@cartouche +An implementation may reserve a storage place for the tag field of a +tagged type, and disallow other components from overlapping that place. +@end cartouche +Followed. The storage place for the tag field is the beginning of the tagged +record, and its size is Address'Size. GNAT will reject an explicit component +clause for the tag field. + +@sp 1 +@cartouche +An implementation need not support a @code{component_clause} for a +component of an extension part if the storage place is not after the +storage places of all components of the parent type, whether or not +those storage places had been specified. +@end cartouche +Followed. The above advice on record representation clauses is followed, +and all mentioned features are implemented. + +@cindex Storage place attributes +@unnumberedsec 13.5.2(5): Storage Place Attributes +@sp 1 +@cartouche +If a component is represented using some form of pointer (such as an +offset) to the actual data of the component, and this data is contiguous +with the rest of the object, then the storage place attributes should +reflect the place of the actual data, not the pointer. If a component is +allocated discontinuously from the rest of the object, then a warning +should be generated upon reference to one of its storage place +attributes. +@end cartouche +Followed. There are no such components in GNAT@. + +@cindex Bit ordering +@unnumberedsec 13.5.3(7-8): Bit Ordering +@sp 1 +@cartouche +The recommended level of support for the non-default bit ordering is: +@end cartouche +@sp 1 +@cartouche +If @code{Word_Size} = @code{Storage_Unit}, then the implementation +should support the non-default bit ordering in addition to the default +bit ordering. +@end cartouche +Followed. Word size does not equal storage size in this implementation. +Thus non-default bit ordering is not supported. + +@cindex @code{Address}, as private type +@unnumberedsec 13.7(37): Address as Private +@sp 1 +@cartouche +@code{Address} should be of a private type. +@end cartouche +Followed. + +@cindex Operations, on @code{Address} +@cindex @code{Address}, operations of +@unnumberedsec 13.7.1(16): Address Operations +@sp 1 +@cartouche +Operations in @code{System} and its children should reflect the target +environment semantics as closely as is reasonable. For example, on most +machines, it makes sense for address arithmetic to ``wrap around''. +Operations that do not make sense should raise @code{Program_Error}. +@end cartouche +Followed. Address arithmetic is modular arithmetic that wraps around. No +operation raises @code{Program_Error}, since all operations make sense. + +@cindex Unchecked conversion +@unnumberedsec 13.9(14-17): Unchecked Conversion +@sp 1 +@cartouche +The @code{Size} of an array object should not include its bounds; hence, +the bounds should not be part of the converted data. +@end cartouche +Followed. + +@sp 1 +@cartouche +The implementation should not generate unnecessary run-time checks to +ensure that the representation of @var{S} is a representation of the +target type. It should take advantage of the permission to return by +reference when possible. Restrictions on unchecked conversions should be +avoided unless required by the target environment. +@end cartouche +Followed. There are no restrictions on unchecked conversion. A warning is +generated if the source and target types do not have the same size since +the semantics in this case may be target dependent. + +@sp 1 +@cartouche +The recommended level of support for unchecked conversions is: +@end cartouche +@sp 1 +@cartouche +Unchecked conversions should be supported and should be reversible in +the cases where this clause defines the result. To enable meaningful use +of unchecked conversion, a contiguous representation should be used for +elementary subtypes, for statically constrained array subtypes whose +component subtype is one of the subtypes described in this paragraph, +and for record subtypes without discriminants whose component subtypes +are described in this paragraph. +@end cartouche +Followed. + +@cindex Heap usage, implicit +@unnumberedsec 13.11(23-25): Implicit Heap Usage +@sp 1 +@cartouche +An implementation should document any cases in which it dynamically +allocates heap storage for a purpose other than the evaluation of an +allocator. +@end cartouche +Followed, the only other points at which heap storage is dynamically +allocated are as follows: + +@itemize @bullet +@item +At initial elaboration time, to allocate dynamically sized global +objects. + +@item +To allocate space for a task when a task is created. + +@item +To extend the secondary stack dynamically when needed. The secondary +stack is used for returning variable length results. +@end itemize + +@sp 1 +@cartouche +A default (implementation-provided) storage pool for an +access-to-constant type should not have overhead to support deallocation of +individual objects. +@end cartouche +Followed. + +@sp 1 +@cartouche +A storage pool for an anonymous access type should be created at the +point of an allocator for the type, and be reclaimed when the designated +object becomes inaccessible. +@end cartouche +Followed. + +@cindex Unchecked deallocation +@unnumberedsec 13.11.2(17): Unchecked De-allocation +@sp 1 +@cartouche +For a standard storage pool, @code{Free} should actually reclaim the +storage. +@end cartouche +Followed. + +@cindex Stream oriented attributes +@unnumberedsec 13.13.2(17): Stream Oriented Attributes +@sp 1 +@cartouche +If a stream element is the same size as a storage element, then the +normal in-memory representation should be used by @code{Read} and +@code{Write} for scalar objects. Otherwise, @code{Read} and @code{Write} +should use the smallest number of stream elements needed to represent +all values in the base range of the scalar type. +@end cartouche + +Followed. By default, GNAT uses the interpretation suggested by AI-195, +which specifies using the size of the first subtype. +However, such an implementation is based on direct binary +representations and is therefore target- and endianness-dependent. +To address this issue, GNAT also supplies an alternate implementation +of the stream attributes @code{Read} and @code{Write}, +which uses the target-independent XDR standard representation +for scalar types. +@cindex XDR representation +@cindex @code{Read} attribute +@cindex @code{Write} attribute +@cindex Stream oriented attributes +The XDR implementation is provided as an alternative body of the +@code{System.Stream_Attributes} package, in the file +@file{s-stratt-xdr.adb} in the GNAT library. +There is no @file{s-stratt-xdr.ads} file. +In order to install the XDR implementation, do the following: +@enumerate +@item Replace the default implementation of the +@code{System.Stream_Attributes} package with the XDR implementation. +For example on a Unix platform issue the commands: +@smallexample +$ mv s-stratt.adb s-stratt-default.adb +$ mv s-stratt-xdr.adb s-stratt.adb +@end smallexample + +@item +Rebuild the GNAT run-time library as documented in +@ref{GNAT and Libraries,,, gnat_ugn, @value{EDITION} User's Guide}. +@end enumerate + +@unnumberedsec A.1(52): Names of Predefined Numeric Types +@sp 1 +@cartouche +If an implementation provides additional named predefined integer types, +then the names should end with @samp{Integer} as in +@samp{Long_Integer}. If an implementation provides additional named +predefined floating point types, then the names should end with +@samp{Float} as in @samp{Long_Float}. +@end cartouche +Followed. + +@findex Ada.Characters.Handling +@unnumberedsec A.3.2(49): @code{Ada.Characters.Handling} +@sp 1 +@cartouche +If an implementation provides a localized definition of @code{Character} +or @code{Wide_Character}, then the effects of the subprograms in +@code{Characters.Handling} should reflect the localizations. See also +3.5.2. +@end cartouche +Followed. GNAT provides no such localized definitions. + +@cindex Bounded-length strings +@unnumberedsec A.4.4(106): Bounded-Length String Handling +@sp 1 +@cartouche +Bounded string objects should not be implemented by implicit pointers +and dynamic allocation. +@end cartouche +Followed. No implicit pointers or dynamic allocation are used. + +@cindex Random number generation +@unnumberedsec A.5.2(46-47): Random Number Generation +@sp 1 +@cartouche +Any storage associated with an object of type @code{Generator} should be +reclaimed on exit from the scope of the object. +@end cartouche +Followed. + +@sp 1 +@cartouche +If the generator period is sufficiently long in relation to the number +of distinct initiator values, then each possible value of +@code{Initiator} passed to @code{Reset} should initiate a sequence of +random numbers that does not, in a practical sense, overlap the sequence +initiated by any other value. If this is not possible, then the mapping +between initiator values and generator states should be a rapidly +varying function of the initiator value. +@end cartouche +Followed. The generator period is sufficiently long for the first +condition here to hold true. + +@findex Get_Immediate +@unnumberedsec A.10.7(23): @code{Get_Immediate} +@sp 1 +@cartouche +The @code{Get_Immediate} procedures should be implemented with +unbuffered input. For a device such as a keyboard, input should be +@dfn{available} if a key has already been typed, whereas for a disk +file, input should always be available except at end of file. For a file +associated with a keyboard-like device, any line-editing features of the +underlying operating system should be disabled during the execution of +@code{Get_Immediate}. +@end cartouche +Followed on all targets except VxWorks. For VxWorks, there is no way to +provide this functionality that does not result in the input buffer being +flushed before the @code{Get_Immediate} call. A special unit +@code{Interfaces.Vxworks.IO} is provided that contains routines to enable +this functionality. + +@findex Export +@unnumberedsec B.1(39-41): Pragma @code{Export} +@sp 1 +@cartouche +If an implementation supports pragma @code{Export} to a given language, +then it should also allow the main subprogram to be written in that +language. It should support some mechanism for invoking the elaboration +of the Ada library units included in the system, and for invoking the +finalization of the environment task. On typical systems, the +recommended mechanism is to provide two subprograms whose link names are +@code{adainit} and @code{adafinal}. @code{adainit} should contain the +elaboration code for library units. @code{adafinal} should contain the +finalization code. These subprograms should have no effect the second +and subsequent time they are called. +@end cartouche +Followed. + +@sp 1 +@cartouche +Automatic elaboration of pre-elaborated packages should be +provided when pragma @code{Export} is supported. +@end cartouche +Followed when the main program is in Ada. If the main program is in a +foreign language, then +@code{adainit} must be called to elaborate pre-elaborated +packages. + +@sp 1 +@cartouche +For each supported convention @var{L} other than @code{Intrinsic}, an +implementation should support @code{Import} and @code{Export} pragmas +for objects of @var{L}-compatible types and for subprograms, and pragma +@code{Convention} for @var{L}-eligible types and for subprograms, +presuming the other language has corresponding features. Pragma +@code{Convention} need not be supported for scalar types. +@end cartouche +Followed. + +@cindex Package @code{Interfaces} +@findex Interfaces +@unnumberedsec B.2(12-13): Package @code{Interfaces} +@sp 1 +@cartouche +For each implementation-defined convention identifier, there should be a +child package of package Interfaces with the corresponding name. This +package should contain any declarations that would be useful for +interfacing to the language (implementation) represented by the +convention. Any declarations useful for interfacing to any language on +the given hardware architecture should be provided directly in +@code{Interfaces}. +@end cartouche +Followed. An additional package not defined +in the Ada Reference Manual is @code{Interfaces.CPP}, used +for interfacing to C++. + +@sp 1 +@cartouche +An implementation supporting an interface to C, COBOL, or Fortran should +provide the corresponding package or packages described in the following +clauses. +@end cartouche +Followed. GNAT provides all the packages described in this section. + +@cindex C, interfacing with +@unnumberedsec B.3(63-71): Interfacing with C +@sp 1 +@cartouche +An implementation should support the following interface correspondences +between Ada and C@. +@end cartouche +Followed. + +@sp 1 +@cartouche +An Ada procedure corresponds to a void-returning C function. +@end cartouche +Followed. + +@sp 1 +@cartouche +An Ada function corresponds to a non-void C function. +@end cartouche +Followed. + +@sp 1 +@cartouche +An Ada @code{in} scalar parameter is passed as a scalar argument to a C +function. +@end cartouche +Followed. + +@sp 1 +@cartouche +An Ada @code{in} parameter of an access-to-object type with designated +type @var{T} is passed as a @code{@var{t}*} argument to a C function, +where @var{t} is the C type corresponding to the Ada type @var{T}. +@end cartouche +Followed. + +@sp 1 +@cartouche +An Ada access @var{T} parameter, or an Ada @code{out} or @code{in out} +parameter of an elementary type @var{T}, is passed as a @code{@var{t}*} +argument to a C function, where @var{t} is the C type corresponding to +the Ada type @var{T}. In the case of an elementary @code{out} or +@code{in out} parameter, a pointer to a temporary copy is used to +preserve by-copy semantics. +@end cartouche +Followed. + +@sp 1 +@cartouche +An Ada parameter of a record type @var{T}, of any mode, is passed as a +@code{@var{t}*} argument to a C function, where @var{t} is the C +structure corresponding to the Ada type @var{T}. +@end cartouche +Followed. This convention may be overridden by the use of the C_Pass_By_Copy +pragma, or Convention, or by explicitly specifying the mechanism for a given +call using an extended import or export pragma. + +@sp 1 +@cartouche +An Ada parameter of an array type with component type @var{T}, of any +mode, is passed as a @code{@var{t}*} argument to a C function, where +@var{t} is the C type corresponding to the Ada type @var{T}. +@end cartouche +Followed. + +@sp 1 +@cartouche +An Ada parameter of an access-to-subprogram type is passed as a pointer +to a C function whose prototype corresponds to the designated +subprogram's specification. +@end cartouche +Followed. + +@cindex COBOL, interfacing with +@unnumberedsec B.4(95-98): Interfacing with COBOL +@sp 1 +@cartouche +An Ada implementation should support the following interface +correspondences between Ada and COBOL@. +@end cartouche +Followed. + +@sp 1 +@cartouche +An Ada access @var{T} parameter is passed as a @samp{BY REFERENCE} data item of +the COBOL type corresponding to @var{T}. +@end cartouche +Followed. + +@sp 1 +@cartouche +An Ada in scalar parameter is passed as a @samp{BY CONTENT} data item of +the corresponding COBOL type. +@end cartouche +Followed. + +@sp 1 +@cartouche +Any other Ada parameter is passed as a @samp{BY REFERENCE} data item of the +COBOL type corresponding to the Ada parameter type; for scalars, a local +copy is used if necessary to ensure by-copy semantics. +@end cartouche +Followed. + +@cindex Fortran, interfacing with +@unnumberedsec B.5(22-26): Interfacing with Fortran +@sp 1 +@cartouche +An Ada implementation should support the following interface +correspondences between Ada and Fortran: +@end cartouche +Followed. + +@sp 1 +@cartouche +An Ada procedure corresponds to a Fortran subroutine. +@end cartouche +Followed. + +@sp 1 +@cartouche +An Ada function corresponds to a Fortran function. +@end cartouche +Followed. + +@sp 1 +@cartouche +An Ada parameter of an elementary, array, or record type @var{T} is +passed as a @var{T} argument to a Fortran procedure, where @var{T} is +the Fortran type corresponding to the Ada type @var{T}, and where the +INTENT attribute of the corresponding dummy argument matches the Ada +formal parameter mode; the Fortran implementation's parameter passing +conventions are used. For elementary types, a local copy is used if +necessary to ensure by-copy semantics. +@end cartouche +Followed. + +@sp 1 +@cartouche +An Ada parameter of an access-to-subprogram type is passed as a +reference to a Fortran procedure whose interface corresponds to the +designated subprogram's specification. +@end cartouche +Followed. + +@cindex Machine operations +@unnumberedsec C.1(3-5): Access to Machine Operations +@sp 1 +@cartouche +The machine code or intrinsic support should allow access to all +operations normally available to assembly language programmers for the +target environment, including privileged instructions, if any. +@end cartouche +Followed. + +@sp 1 +@cartouche +The interfacing pragmas (see Annex B) should support interface to +assembler; the default assembler should be associated with the +convention identifier @code{Assembler}. +@end cartouche +Followed. + +@sp 1 +@cartouche +If an entity is exported to assembly language, then the implementation +should allocate it at an addressable location, and should ensure that it +is retained by the linking process, even if not otherwise referenced +from the Ada code. The implementation should assume that any call to a +machine code or assembler subprogram is allowed to read or update every +object that is specified as exported. +@end cartouche +Followed. + +@unnumberedsec C.1(10-16): Access to Machine Operations +@sp 1 +@cartouche +The implementation should ensure that little or no overhead is +associated with calling intrinsic and machine-code subprograms. +@end cartouche +Followed for both intrinsics and machine-code subprograms. + +@sp 1 +@cartouche +It is recommended that intrinsic subprograms be provided for convenient +access to any machine operations that provide special capabilities or +efficiency and that are not otherwise available through the language +constructs. +@end cartouche +Followed. A full set of machine operation intrinsic subprograms is provided. + +@sp 1 +@cartouche +Atomic read-modify-write operations---e.g.@:, test and set, compare and +swap, decrement and test, enqueue/dequeue. +@end cartouche +Followed on any target supporting such operations. + +@sp 1 +@cartouche +Standard numeric functions---e.g.@:, sin, log. +@end cartouche +Followed on any target supporting such operations. + +@sp 1 +@cartouche +String manipulation operations---e.g.@:, translate and test. +@end cartouche +Followed on any target supporting such operations. + +@sp 1 +@cartouche +Vector operations---e.g.@:, compare vector against thresholds. +@end cartouche +Followed on any target supporting such operations. + +@sp 1 +@cartouche +Direct operations on I/O ports. +@end cartouche +Followed on any target supporting such operations. + +@cindex Interrupt support +@unnumberedsec C.3(28): Interrupt Support +@sp 1 +@cartouche +If the @code{Ceiling_Locking} policy is not in effect, the +implementation should provide means for the application to specify which +interrupts are to be blocked during protected actions, if the underlying +system allows for a finer-grain control of interrupt blocking. +@end cartouche +Followed. The underlying system does not allow for finer-grain control +of interrupt blocking. + +@cindex Protected procedure handlers +@unnumberedsec C.3.1(20-21): Protected Procedure Handlers +@sp 1 +@cartouche +Whenever possible, the implementation should allow interrupt handlers to +be called directly by the hardware. +@end cartouche +@c SGI info: +@ignore +This is never possible under IRIX, so this is followed by default. +@end ignore +Followed on any target where the underlying operating system permits +such direct calls. + +@sp 1 +@cartouche +Whenever practical, violations of any +implementation-defined restrictions should be detected before run time. +@end cartouche +Followed. Compile time warnings are given when possible. + +@cindex Package @code{Interrupts} +@findex Interrupts +@unnumberedsec C.3.2(25): Package @code{Interrupts} + +@sp 1 +@cartouche +If implementation-defined forms of interrupt handler procedures are +supported, such as protected procedures with parameters, then for each +such form of a handler, a type analogous to @code{Parameterless_Handler} +should be specified in a child package of @code{Interrupts}, with the +same operations as in the predefined package Interrupts. +@end cartouche +Followed. + +@cindex Pre-elaboration requirements +@unnumberedsec C.4(14): Pre-elaboration Requirements +@sp 1 +@cartouche +It is recommended that pre-elaborated packages be implemented in such a +way that there should be little or no code executed at run time for the +elaboration of entities not already covered by the Implementation +Requirements. +@end cartouche +Followed. Executable code is generated in some cases, e.g.@: loops +to initialize large arrays. + +@unnumberedsec C.5(8): Pragma @code{Discard_Names} + +@sp 1 +@cartouche +If the pragma applies to an entity, then the implementation should +reduce the amount of storage used for storing names associated with that +entity. +@end cartouche +Followed. + +@cindex Package @code{Task_Attributes} +@findex Task_Attributes +@unnumberedsec C.7.2(30): The Package Task_Attributes +@sp 1 +@cartouche +Some implementations are targeted to domains in which memory use at run +time must be completely deterministic. For such implementations, it is +recommended that the storage for task attributes will be pre-allocated +statically and not from the heap. This can be accomplished by either +placing restrictions on the number and the size of the task's +attributes, or by using the pre-allocated storage for the first @var{N} +attribute objects, and the heap for the others. In the latter case, +@var{N} should be documented. +@end cartouche +Not followed. This implementation is not targeted to such a domain. + +@cindex Locking Policies +@unnumberedsec D.3(17): Locking Policies + +@sp 1 +@cartouche +The implementation should use names that end with @samp{_Locking} for +locking policies defined by the implementation. +@end cartouche +Followed. A single implementation-defined locking policy is defined, +whose name (@code{Inheritance_Locking}) follows this suggestion. + +@cindex Entry queuing policies +@unnumberedsec D.4(16): Entry Queuing Policies +@sp 1 +@cartouche +Names that end with @samp{_Queuing} should be used +for all implementation-defined queuing policies. +@end cartouche +Followed. No such implementation-defined queuing policies exist. + +@cindex Preemptive abort +@unnumberedsec D.6(9-10): Preemptive Abort +@sp 1 +@cartouche +Even though the @code{abort_statement} is included in the list of +potentially blocking operations (see 9.5.1), it is recommended that this +statement be implemented in a way that never requires the task executing +the @code{abort_statement} to block. +@end cartouche +Followed. + +@sp 1 +@cartouche +On a multi-processor, the delay associated with aborting a task on +another processor should be bounded; the implementation should use +periodic polling, if necessary, to achieve this. +@end cartouche +Followed. + +@cindex Tasking restrictions +@unnumberedsec D.7(21): Tasking Restrictions +@sp 1 +@cartouche +When feasible, the implementation should take advantage of the specified +restrictions to produce a more efficient implementation. +@end cartouche +GNAT currently takes advantage of these restrictions by providing an optimized +run time when the Ravenscar profile and the GNAT restricted run time set +of restrictions are specified. See pragma @code{Profile (Ravenscar)} and +pragma @code{Profile (Restricted)} for more details. + +@cindex Time, monotonic +@unnumberedsec D.8(47-49): Monotonic Time +@sp 1 +@cartouche +When appropriate, implementations should provide configuration +mechanisms to change the value of @code{Tick}. +@end cartouche +Such configuration mechanisms are not appropriate to this implementation +and are thus not supported. + +@sp 1 +@cartouche +It is recommended that @code{Calendar.Clock} and @code{Real_Time.Clock} +be implemented as transformations of the same time base. +@end cartouche +Followed. + +@sp 1 +@cartouche +It is recommended that the @dfn{best} time base which exists in +the underlying system be available to the application through +@code{Clock}. @dfn{Best} may mean highest accuracy or largest range. +@end cartouche +Followed. + +@cindex Partition communication subsystem +@cindex PCS +@unnumberedsec E.5(28-29): Partition Communication Subsystem +@sp 1 +@cartouche +Whenever possible, the PCS on the called partition should allow for +multiple tasks to call the RPC-receiver with different messages and +should allow them to block until the corresponding subprogram body +returns. +@end cartouche +Followed by GLADE, a separately supplied PCS that can be used with +GNAT. + +@sp 1 +@cartouche +The @code{Write} operation on a stream of type @code{Params_Stream_Type} +should raise @code{Storage_Error} if it runs out of space trying to +write the @code{Item} into the stream. +@end cartouche +Followed by GLADE, a separately supplied PCS that can be used with +GNAT@. + +@cindex COBOL support +@unnumberedsec F(7): COBOL Support +@sp 1 +@cartouche +If COBOL (respectively, C) is widely supported in the target +environment, implementations supporting the Information Systems Annex +should provide the child package @code{Interfaces.COBOL} (respectively, +@code{Interfaces.C}) specified in Annex B and should support a +@code{convention_identifier} of COBOL (respectively, C) in the interfacing +pragmas (see Annex B), thus allowing Ada programs to interface with +programs written in that language. +@end cartouche +Followed. + +@cindex Decimal radix support +@unnumberedsec F.1(2): Decimal Radix Support +@sp 1 +@cartouche +Packed decimal should be used as the internal representation for objects +of subtype @var{S} when @var{S}'Machine_Radix = 10. +@end cartouche +Not followed. GNAT ignores @var{S}'Machine_Radix and always uses binary +representations. + +@cindex Numerics +@unnumberedsec G: Numerics +@sp 2 +@cartouche +If Fortran (respectively, C) is widely supported in the target +environment, implementations supporting the Numerics Annex +should provide the child package @code{Interfaces.Fortran} (respectively, +@code{Interfaces.C}) specified in Annex B and should support a +@code{convention_identifier} of Fortran (respectively, C) in the interfacing +pragmas (see Annex B), thus allowing Ada programs to interface with +programs written in that language. +@end cartouche +Followed. + +@cindex Complex types +@unnumberedsec G.1.1(56-58): Complex Types +@sp 2 +@cartouche +Because the usual mathematical meaning of multiplication of a complex +operand and a real operand is that of the scaling of both components of +the former by the latter, an implementation should not perform this +operation by first promoting the real operand to complex type and then +performing a full complex multiplication. In systems that, in the +future, support an Ada binding to IEC 559:1989, the latter technique +will not generate the required result when one of the components of the +complex operand is infinite. (Explicit multiplication of the infinite +component by the zero component obtained during promotion yields a NaN +that propagates into the final result.) Analogous advice applies in the +case of multiplication of a complex operand and a pure-imaginary +operand, and in the case of division of a complex operand by a real or +pure-imaginary operand. +@end cartouche +Not followed. + +@sp 1 +@cartouche +Similarly, because the usual mathematical meaning of addition of a +complex operand and a real operand is that the imaginary operand remains +unchanged, an implementation should not perform this operation by first +promoting the real operand to complex type and then performing a full +complex addition. In implementations in which the @code{Signed_Zeros} +attribute of the component type is @code{True} (and which therefore +conform to IEC 559:1989 in regard to the handling of the sign of zero in +predefined arithmetic operations), the latter technique will not +generate the required result when the imaginary component of the complex +operand is a negatively signed zero. (Explicit addition of the negative +zero to the zero obtained during promotion yields a positive zero.) +Analogous advice applies in the case of addition of a complex operand +and a pure-imaginary operand, and in the case of subtraction of a +complex operand and a real or pure-imaginary operand. +@end cartouche +Not followed. + +@sp 1 +@cartouche +Implementations in which @code{Real'Signed_Zeros} is @code{True} should +attempt to provide a rational treatment of the signs of zero results and +result components. As one example, the result of the @code{Argument} +function should have the sign of the imaginary component of the +parameter @code{X} when the point represented by that parameter lies on +the positive real axis; as another, the sign of the imaginary component +of the @code{Compose_From_Polar} function should be the same as +(respectively, the opposite of) that of the @code{Argument} parameter when that +parameter has a value of zero and the @code{Modulus} parameter has a +nonnegative (respectively, negative) value. +@end cartouche +Followed. + +@cindex Complex elementary functions +@unnumberedsec G.1.2(49): Complex Elementary Functions +@sp 1 +@cartouche +Implementations in which @code{Complex_Types.Real'Signed_Zeros} is +@code{True} should attempt to provide a rational treatment of the signs +of zero results and result components. For example, many of the complex +elementary functions have components that are odd functions of one of +the parameter components; in these cases, the result component should +have the sign of the parameter component at the origin. Other complex +elementary functions have zero components whose sign is opposite that of +a parameter component at the origin, or is always positive or always +negative. +@end cartouche +Followed. + +@cindex Accuracy requirements +@unnumberedsec G.2.4(19): Accuracy Requirements +@sp 1 +@cartouche +The versions of the forward trigonometric functions without a +@code{Cycle} parameter should not be implemented by calling the +corresponding version with a @code{Cycle} parameter of +@code{2.0*Numerics.Pi}, since this will not provide the required +accuracy in some portions of the domain. For the same reason, the +version of @code{Log} without a @code{Base} parameter should not be +implemented by calling the corresponding version with a @code{Base} +parameter of @code{Numerics.e}. +@end cartouche +Followed. + +@cindex Complex arithmetic accuracy +@cindex Accuracy, complex arithmetic +@unnumberedsec G.2.6(15): Complex Arithmetic Accuracy + +@sp 1 +@cartouche +The version of the @code{Compose_From_Polar} function without a +@code{Cycle} parameter should not be implemented by calling the +corresponding version with a @code{Cycle} parameter of +@code{2.0*Numerics.Pi}, since this will not provide the required +accuracy in some portions of the domain. +@end cartouche +Followed. + +@c ----------------------------------------- +@node Implementation Defined Characteristics +@chapter Implementation Defined Characteristics + +@noindent +In addition to the implementation dependent pragmas and attributes, and the +implementation advice, there are a number of other Ada features that are +potentially implementation dependent and are designated as +implementation-defined. These are mentioned throughout the Ada Reference +Manual, and are summarized in Annex M@. + +A requirement for conforming Ada compilers is that they provide +documentation describing how the implementation deals with each of these +issues. In this chapter, you will find each point in Annex M listed +followed by a description in italic font of how GNAT +@c SGI info: +@ignore +in the ProDev Ada +implementation on IRIX 5.3 operating system or greater +@end ignore +handles the implementation dependence. + +You can use this chapter as a guide to minimizing implementation +dependent features in your programs if portability to other compilers +and other operating systems is an important consideration. The numbers +in each section below correspond to the paragraph number in the Ada +Reference Manual. + +@sp 1 +@cartouche +@noindent +@strong{2}. Whether or not each recommendation given in Implementation +Advice is followed. See 1.1.2(37). +@end cartouche +@noindent +@xref{Implementation Advice}. + +@sp 1 +@cartouche +@noindent +@strong{3}. Capacity limitations of the implementation. See 1.1.3(3). +@end cartouche +@noindent +The complexity of programs that can be processed is limited only by the +total amount of available virtual memory, and disk space for the +generated object files. + +@sp 1 +@cartouche +@noindent +@strong{4}. Variations from the standard that are impractical to avoid +given the implementation's execution environment. See 1.1.3(6). +@end cartouche +@noindent +There are no variations from the standard. + +@sp 1 +@cartouche +@noindent +@strong{5}. Which @code{code_statement}s cause external +interactions. See 1.1.3(10). +@end cartouche +@noindent +Any @code{code_statement} can potentially cause external interactions. + +@sp 1 +@cartouche +@noindent +@strong{6}. The coded representation for the text of an Ada +program. See 2.1(4). +@end cartouche +@noindent +See separate section on source representation. + +@sp 1 +@cartouche +@noindent +@strong{7}. The control functions allowed in comments. See 2.1(14). +@end cartouche +@noindent +See separate section on source representation. + +@sp 1 +@cartouche +@noindent +@strong{8}. The representation for an end of line. See 2.2(2). +@end cartouche +@noindent +See separate section on source representation. + +@sp 1 +@cartouche +@noindent +@strong{9}. Maximum supported line length and lexical element +length. See 2.2(15). +@end cartouche +@noindent +The maximum line length is 255 characters and the maximum length of a +lexical element is also 255 characters. + +@sp 1 +@cartouche +@noindent +@strong{10}. Implementation defined pragmas. See 2.8(14). +@end cartouche +@noindent + +@xref{Implementation Defined Pragmas}. + +@sp 1 +@cartouche +@noindent +@strong{11}. Effect of pragma @code{Optimize}. See 2.8(27). +@end cartouche +@noindent +Pragma @code{Optimize}, if given with a @code{Time} or @code{Space} +parameter, checks that the optimization flag is set, and aborts if it is +not. + +@sp 1 +@cartouche +@noindent +@strong{12}. The sequence of characters of the value returned by +@code{@var{S}'Image} when some of the graphic characters of +@code{@var{S}'Wide_Image} are not defined in @code{Character}. See +3.5(37). +@end cartouche +@noindent +The sequence of characters is as defined by the wide character encoding +method used for the source. See section on source representation for +further details. + +@sp 1 +@cartouche +@noindent +@strong{13}. The predefined integer types declared in +@code{Standard}. See 3.5.4(25). +@end cartouche +@noindent +@table @code +@item Short_Short_Integer +8 bit signed +@item Short_Integer +(Short) 16 bit signed +@item Integer +32 bit signed +@item Long_Integer +64 bit signed (Alpha OpenVMS only) +32 bit signed (all other targets) +@item Long_Long_Integer +64 bit signed +@end table + +@sp 1 +@cartouche +@noindent +@strong{14}. Any nonstandard integer types and the operators defined +for them. See 3.5.4(26). +@end cartouche +@noindent +There are no nonstandard integer types. + +@sp 1 +@cartouche +@noindent +@strong{15}. Any nonstandard real types and the operators defined for +them. See 3.5.6(8). +@end cartouche +@noindent +There are no nonstandard real types. + +@sp 1 +@cartouche +@noindent +@strong{16}. What combinations of requested decimal precision and range +are supported for floating point types. See 3.5.7(7). +@end cartouche +@noindent +The precision and range is as defined by the IEEE standard. + +@sp 1 +@cartouche +@noindent +@strong{17}. The predefined floating point types declared in +@code{Standard}. See 3.5.7(16). +@end cartouche +@noindent +@table @code +@item Short_Float +32 bit IEEE short +@item Float +(Short) 32 bit IEEE short +@item Long_Float +64 bit IEEE long +@item Long_Long_Float +64 bit IEEE long (80 bit IEEE long on x86 processors) +@end table + +@sp 1 +@cartouche +@noindent +@strong{18}. The small of an ordinary fixed point type. See 3.5.9(8). +@end cartouche +@noindent +@code{Fine_Delta} is 2**(@minus{}63) + +@sp 1 +@cartouche +@noindent +@strong{19}. What combinations of small, range, and digits are +supported for fixed point types. See 3.5.9(10). +@end cartouche +@noindent +Any combinations are permitted that do not result in a small less than +@code{Fine_Delta} and do not result in a mantissa larger than 63 bits. +If the mantissa is larger than 53 bits on machines where Long_Long_Float +is 64 bits (true of all architectures except ia32), then the output from +Text_IO is accurate to only 53 bits, rather than the full mantissa. This +is because floating-point conversions are used to convert fixed point. + +@sp 1 +@cartouche +@noindent +@strong{20}. The result of @code{Tags.Expanded_Name} for types declared +within an unnamed @code{block_statement}. See 3.9(10). +@end cartouche +@noindent +Block numbers of the form @code{B@var{nnn}}, where @var{nnn} is a +decimal integer are allocated. + +@sp 1 +@cartouche +@noindent +@strong{21}. Implementation-defined attributes. See 4.1.4(12). +@end cartouche +@noindent +@xref{Implementation Defined Attributes}. + +@sp 1 +@cartouche +@noindent +@strong{22}. Any implementation-defined time types. See 9.6(6). +@end cartouche +@noindent +There are no implementation-defined time types. + +@sp 1 +@cartouche +@noindent +@strong{23}. The time base associated with relative delays. +@end cartouche +@noindent +See 9.6(20). The time base used is that provided by the C library +function @code{gettimeofday}. + +@sp 1 +@cartouche +@noindent +@strong{24}. The time base of the type @code{Calendar.Time}. See +9.6(23). +@end cartouche +@noindent +The time base used is that provided by the C library function +@code{gettimeofday}. + +@sp 1 +@cartouche +@noindent +@strong{25}. The time zone used for package @code{Calendar} +operations. See 9.6(24). +@end cartouche +@noindent +The time zone used by package @code{Calendar} is the current system time zone +setting for local time, as accessed by the C library function +@code{localtime}. + +@sp 1 +@cartouche +@noindent +@strong{26}. Any limit on @code{delay_until_statements} of +@code{select_statements}. See 9.6(29). +@end cartouche +@noindent +There are no such limits. + +@sp 1 +@cartouche +@noindent +@strong{27}. Whether or not two non-overlapping parts of a composite +object are independently addressable, in the case where packing, record +layout, or @code{Component_Size} is specified for the object. See +9.10(1). +@end cartouche +@noindent +Separate components are independently addressable if they do not share +overlapping storage units. + +@sp 1 +@cartouche +@noindent +@strong{28}. The representation for a compilation. See 10.1(2). +@end cartouche +@noindent +A compilation is represented by a sequence of files presented to the +compiler in a single invocation of the @command{gcc} command. + +@sp 1 +@cartouche +@noindent +@strong{29}. Any restrictions on compilations that contain multiple +compilation_units. See 10.1(4). +@end cartouche +@noindent +No single file can contain more than one compilation unit, but any +sequence of files can be presented to the compiler as a single +compilation. + +@sp 1 +@cartouche +@noindent +@strong{30}. The mechanisms for creating an environment and for adding +and replacing compilation units. See 10.1.4(3). +@end cartouche +@noindent +See separate section on compilation model. + +@sp 1 +@cartouche +@noindent +@strong{31}. The manner of explicitly assigning library units to a +partition. See 10.2(2). +@end cartouche +@noindent +If a unit contains an Ada main program, then the Ada units for the partition +are determined by recursive application of the rules in the Ada Reference +Manual section 10.2(2-6). In other words, the Ada units will be those that +are needed by the main program, and then this definition of need is applied +recursively to those units, and the partition contains the transitive +closure determined by this relationship. In short, all the necessary units +are included, with no need to explicitly specify the list. If additional +units are required, e.g.@: by foreign language units, then all units must be +mentioned in the context clause of one of the needed Ada units. + +If the partition contains no main program, or if the main program is in +a language other than Ada, then GNAT +provides the binder options @option{-z} and @option{-n} respectively, and in +this case a list of units can be explicitly supplied to the binder for +inclusion in the partition (all units needed by these units will also +be included automatically). For full details on the use of these +options, refer to @ref{The GNAT Make Program gnatmake,,, gnat_ugn, +@value{EDITION} User's Guide}. + +@sp 1 +@cartouche +@noindent +@strong{32}. The implementation-defined means, if any, of specifying +which compilation units are needed by a given compilation unit. See +10.2(2). +@end cartouche +@noindent +The units needed by a given compilation unit are as defined in +the Ada Reference Manual section 10.2(2-6). There are no +implementation-defined pragmas or other implementation-defined +means for specifying needed units. + +@sp 1 +@cartouche +@noindent +@strong{33}. The manner of designating the main subprogram of a +partition. See 10.2(7). +@end cartouche +@noindent +The main program is designated by providing the name of the +corresponding @file{ALI} file as the input parameter to the binder. + +@sp 1 +@cartouche +@noindent +@strong{34}. The order of elaboration of @code{library_items}. See +10.2(18). +@end cartouche +@noindent +The first constraint on ordering is that it meets the requirements of +Chapter 10 of the Ada Reference Manual. This still leaves some +implementation dependent choices, which are resolved by first +elaborating bodies as early as possible (i.e., in preference to specs +where there is a choice), and second by evaluating the immediate with +clauses of a unit to determine the probably best choice, and +third by elaborating in alphabetical order of unit names +where a choice still remains. + +@sp 1 +@cartouche +@noindent +@strong{35}. Parameter passing and function return for the main +subprogram. See 10.2(21). +@end cartouche +@noindent +The main program has no parameters. It may be a procedure, or a function +returning an integer type. In the latter case, the returned integer +value is the return code of the program (overriding any value that +may have been set by a call to @code{Ada.Command_Line.Set_Exit_Status}). + +@sp 1 +@cartouche +@noindent +@strong{36}. The mechanisms for building and running partitions. See +10.2(24). +@end cartouche +@noindent +GNAT itself supports programs with only a single partition. The GNATDIST +tool provided with the GLADE package (which also includes an implementation +of the PCS) provides a completely flexible method for building and running +programs consisting of multiple partitions. See the separate GLADE manual +for details. + +@sp 1 +@cartouche +@noindent +@strong{37}. The details of program execution, including program +termination. See 10.2(25). +@end cartouche +@noindent +See separate section on compilation model. + +@sp 1 +@cartouche +@noindent +@strong{38}. The semantics of any non-active partitions supported by the +implementation. See 10.2(28). +@end cartouche +@noindent +Passive partitions are supported on targets where shared memory is +provided by the operating system. See the GLADE reference manual for +further details. + +@sp 1 +@cartouche +@noindent +@strong{39}. The information returned by @code{Exception_Message}. See +11.4.1(10). +@end cartouche +@noindent +Exception message returns the null string unless a specific message has +been passed by the program. + +@sp 1 +@cartouche +@noindent +@strong{40}. The result of @code{Exceptions.Exception_Name} for types +declared within an unnamed @code{block_statement}. See 11.4.1(12). +@end cartouche +@noindent +Blocks have implementation defined names of the form @code{B@var{nnn}} +where @var{nnn} is an integer. + +@sp 1 +@cartouche +@noindent +@strong{41}. The information returned by +@code{Exception_Information}. See 11.4.1(13). +@end cartouche +@noindent +@code{Exception_Information} returns a string in the following format: + +@smallexample +@emph{Exception_Name:} nnnnn +@emph{Message:} mmmmm +@emph{PID:} ppp +@emph{Call stack traceback locations:} +0xhhhh 0xhhhh 0xhhhh ... 0xhhh +@end smallexample + +@noindent +where + +@itemize @bullet +@item +@code{nnnn} is the fully qualified name of the exception in all upper +case letters. This line is always present. + +@item +@code{mmmm} is the message (this line present only if message is non-null) + +@item +@code{ppp} is the Process Id value as a decimal integer (this line is +present only if the Process Id is nonzero). Currently we are +not making use of this field. + +@item +The Call stack traceback locations line and the following values +are present only if at least one traceback location was recorded. +The values are given in C style format, with lower case letters +for a-f, and only as many digits present as are necessary. +@end itemize + +@noindent +The line terminator sequence at the end of each line, including +the last line is a single @code{LF} character (@code{16#0A#}). + +@sp 1 +@cartouche +@noindent +@strong{42}. Implementation-defined check names. See 11.5(27). +@end cartouche +@noindent +The implementation defined check name Alignment_Check controls checking of +address clause values for proper alignment (that is, the address supplied +must be consistent with the alignment of the type). + +In addition, a user program can add implementation-defined check names +by means of the pragma Check_Name. + +@sp 1 +@cartouche +@noindent +@strong{43}. The interpretation of each aspect of representation. See +13.1(20). +@end cartouche +@noindent +See separate section on data representations. + +@sp 1 +@cartouche +@noindent +@strong{44}. Any restrictions placed upon representation items. See +13.1(20). +@end cartouche +@noindent +See separate section on data representations. + +@sp 1 +@cartouche +@noindent +@strong{45}. The meaning of @code{Size} for indefinite subtypes. See +13.3(48). +@end cartouche +@noindent +Size for an indefinite subtype is the maximum possible size, except that +for the case of a subprogram parameter, the size of the parameter object +is the actual size. + +@sp 1 +@cartouche +@noindent +@strong{46}. The default external representation for a type tag. See +13.3(75). +@end cartouche +@noindent +The default external representation for a type tag is the fully expanded +name of the type in upper case letters. + +@sp 1 +@cartouche +@noindent +@strong{47}. What determines whether a compilation unit is the same in +two different partitions. See 13.3(76). +@end cartouche +@noindent +A compilation unit is the same in two different partitions if and only +if it derives from the same source file. + +@sp 1 +@cartouche +@noindent +@strong{48}. Implementation-defined components. See 13.5.1(15). +@end cartouche +@noindent +The only implementation defined component is the tag for a tagged type, +which contains a pointer to the dispatching table. + +@sp 1 +@cartouche +@noindent +@strong{49}. If @code{Word_Size} = @code{Storage_Unit}, the default bit +ordering. See 13.5.3(5). +@end cartouche +@noindent +@code{Word_Size} (32) is not the same as @code{Storage_Unit} (8) for this +implementation, so no non-default bit ordering is supported. The default +bit ordering corresponds to the natural endianness of the target architecture. + +@sp 1 +@cartouche +@noindent +@strong{50}. The contents of the visible part of package @code{System} +and its language-defined children. See 13.7(2). +@end cartouche +@noindent +See the definition of these packages in files @file{system.ads} and +@file{s-stoele.ads}. + +@sp 1 +@cartouche +@noindent +@strong{51}. The contents of the visible part of package +@code{System.Machine_Code}, and the meaning of +@code{code_statements}. See 13.8(7). +@end cartouche +@noindent +See the definition and documentation in file @file{s-maccod.ads}. + +@sp 1 +@cartouche +@noindent +@strong{52}. The effect of unchecked conversion. See 13.9(11). +@end cartouche +@noindent +Unchecked conversion between types of the same size +results in an uninterpreted transmission of the bits from one type +to the other. If the types are of unequal sizes, then in the case of +discrete types, a shorter source is first zero or sign extended as +necessary, and a shorter target is simply truncated on the left. +For all non-discrete types, the source is first copied if necessary +to ensure that the alignment requirements of the target are met, then +a pointer is constructed to the source value, and the result is obtained +by dereferencing this pointer after converting it to be a pointer to the +target type. Unchecked conversions where the target subtype is an +unconstrained array are not permitted. If the target alignment is +greater than the source alignment, then a copy of the result is +made with appropriate alignment + +@sp 1 +@cartouche +@noindent +@strong{53}. The semantics of operations on invalid representations. +See 13.9.2(10-11). +@end cartouche +@noindent +For assignments and other operations where the use of invalid values cannot +result in erroneous behavior, the compiler ignores the possibility of invalid +values. An exception is raised at the point where an invalid value would +result in erroneous behavior. For example executing: + +@smallexample @c ada +procedure invalidvals is + X : Integer := -1; + Y : Natural range 1 .. 10; + for Y'Address use X'Address; + Z : Natural range 1 .. 10; + A : array (Natural range 1 .. 10) of Integer; +begin + Z := Y; -- no exception + A (Z) := 3; -- exception raised; +end; +@end smallexample + +@noindent +As indicated, an exception is raised on the array assignment, but not +on the simple assignment of the invalid negative value from Y to Z. + +@sp 1 +@cartouche +@noindent +@strong{53}. The manner of choosing a storage pool for an access type +when @code{Storage_Pool} is not specified for the type. See 13.11(17). +@end cartouche +@noindent +There are 3 different standard pools used by the compiler when +@code{Storage_Pool} is not specified depending whether the type is local +to a subprogram or defined at the library level and whether +@code{Storage_Size}is specified or not. See documentation in the runtime +library units @code{System.Pool_Global}, @code{System.Pool_Size} and +@code{System.Pool_Local} in files @file{s-poosiz.ads}, +@file{s-pooglo.ads} and @file{s-pooloc.ads} for full details on the +default pools used. + +@sp 1 +@cartouche +@noindent +@strong{54}. Whether or not the implementation provides user-accessible +names for the standard pool type(s). See 13.11(17). +@end cartouche +@noindent + +See documentation in the sources of the run time mentioned in paragraph +@strong{53} . All these pools are accessible by means of @code{with}'ing +these units. + +@sp 1 +@cartouche +@noindent +@strong{55}. The meaning of @code{Storage_Size}. See 13.11(18). +@end cartouche +@noindent +@code{Storage_Size} is measured in storage units, and refers to the +total space available for an access type collection, or to the primary +stack space for a task. + +@sp 1 +@cartouche +@noindent +@strong{56}. Implementation-defined aspects of storage pools. See +13.11(22). +@end cartouche +@noindent +See documentation in the sources of the run time mentioned in paragraph +@strong{53} for details on GNAT-defined aspects of storage pools. + +@sp 1 +@cartouche +@noindent +@strong{57}. The set of restrictions allowed in a pragma +@code{Restrictions}. See 13.12(7). +@end cartouche +@noindent +All RM defined Restriction identifiers are implemented. The following +additional restriction identifiers are provided. There are two separate +lists of implementation dependent restriction identifiers. The first +set requires consistency throughout a partition (in other words, if the +restriction identifier is used for any compilation unit in the partition, +then all compilation units in the partition must obey the restriction. + +@table @code + +@item Simple_Barriers +@findex Simple_Barriers +This restriction ensures at compile time that barriers in entry declarations +for protected types are restricted to either static boolean expressions or +references to simple boolean variables defined in the private part of the +protected type. No other form of entry barriers is permitted. This is one +of the restrictions of the Ravenscar profile for limited tasking (see also +pragma @code{Profile (Ravenscar)}). + +@item Max_Entry_Queue_Length => Expr +@findex Max_Entry_Queue_Length +This restriction is a declaration that any protected entry compiled in +the scope of the restriction has at most the specified number of +tasks waiting on the entry +at any one time, and so no queue is required. This restriction is not +checked at compile time. A program execution is erroneous if an attempt +is made to queue more than the specified number of tasks on such an entry. + +@item No_Calendar +@findex No_Calendar +This restriction ensures at compile time that there is no implicit or +explicit dependence on the package @code{Ada.Calendar}. + +@item No_Default_Initialization +@findex No_Default_Initialization + +This restriction prohibits any instance of default initialization of variables. +The binder implements a consistency rule which prevents any unit compiled +without the restriction from with'ing a unit with the restriction (this allows +the generation of initialization procedures to be skipped, since you can be +sure that no call is ever generated to an initialization procedure in a unit +with the restriction active). If used in conjunction with Initialize_Scalars or +Normalize_Scalars, the effect is to prohibit all cases of variables declared +without a specific initializer (including the case of OUT scalar parameters). + +@item No_Direct_Boolean_Operators +@findex No_Direct_Boolean_Operators +This restriction ensures that no logical (and/or/xor) are used on +operands of type Boolean (or any type derived +from Boolean). This is intended for use in safety critical programs +where the certification protocol requires the use of short-circuit +(and then, or else) forms for all composite boolean operations. + +@item No_Dispatching_Calls +@findex No_Dispatching_Calls +This restriction ensures at compile time that the code generated by the +compiler involves no dispatching calls. The use of this restriction allows the +safe use of record extensions, classwide membership tests and other classwide +features not involving implicit dispatching. This restriction ensures that +the code contains no indirect calls through a dispatching mechanism. Note that +this includes internally-generated calls created by the compiler, for example +in the implementation of class-wide objects assignments. The +membership test is allowed in the presence of this restriction, because its +implementation requires no dispatching. +This restriction is comparable to the official Ada restriction +@code{No_Dispatch} except that it is a bit less restrictive in that it allows +all classwide constructs that do not imply dispatching. +The following example indicates constructs that violate this restriction. + +@smallexample +package Pkg is + type T is tagged record + Data : Natural; + end record; + procedure P (X : T); + + type DT is new T with record + More_Data : Natural; + end record; + procedure Q (X : DT); +end Pkg; + +with Pkg; use Pkg; +procedure Example is + procedure Test (O : T'Class) is + N : Natural := O'Size;-- Error: Dispatching call + C : T'Class := O; -- Error: implicit Dispatching Call + begin + if O in DT'Class then -- OK : Membership test + Q (DT (O)); -- OK : Type conversion plus direct call + else + P (O); -- Error: Dispatching call + end if; + end Test; + + Obj : DT; +begin + P (Obj); -- OK : Direct call + P (T (Obj)); -- OK : Type conversion plus direct call + P (T'Class (Obj)); -- Error: Dispatching call + + Test (Obj); -- OK : Type conversion + + if Obj in T'Class then -- OK : Membership test + null; + end if; +end Example; +@end smallexample + +@item No_Dynamic_Attachment +@findex No_Dynamic_Attachment +This restriction ensures that there is no call to any of the operations +defined in package Ada.Interrupts. + +@item No_Enumeration_Maps +@findex No_Enumeration_Maps +This restriction ensures at compile time that no operations requiring +enumeration maps are used (that is Image and Value attributes applied +to enumeration types). + +@item No_Entry_Calls_In_Elaboration_Code +@findex No_Entry_Calls_In_Elaboration_Code +This restriction ensures at compile time that no task or protected entry +calls are made during elaboration code. As a result of the use of this +restriction, the compiler can assume that no code past an accept statement +in a task can be executed at elaboration time. + +@item No_Exception_Handlers +@findex No_Exception_Handlers +This restriction ensures at compile time that there are no explicit +exception handlers. It also indicates that no exception propagation will +be provided. In this mode, exceptions may be raised but will result in +an immediate call to the last chance handler, a routine that the user +must define with the following profile: + +@smallexample @c ada +procedure Last_Chance_Handler + (Source_Location : System.Address; Line : Integer); +pragma Export (C, Last_Chance_Handler, + "__gnat_last_chance_handler"); +@end smallexample + +The parameter is a C null-terminated string representing a message to be +associated with the exception (typically the source location of the raise +statement generated by the compiler). The Line parameter when nonzero +represents the line number in the source program where the raise occurs. + +@item No_Exception_Propagation +@findex No_Exception_Propagation +This restriction guarantees that exceptions are never propagated to an outer +subprogram scope). The only case in which an exception may be raised is when +the handler is statically in the same subprogram, so that the effect of a raise +is essentially like a goto statement. Any other raise statement (implicit or +explicit) will be considered unhandled. Exception handlers are allowed, but may +not contain an exception occurrence identifier (exception choice). In addition +use of the package GNAT.Current_Exception is not permitted, and reraise +statements (raise with no operand) are not permitted. + +@item No_Exception_Registration +@findex No_Exception_Registration +This restriction ensures at compile time that no stream operations for +types Exception_Id or Exception_Occurrence are used. This also makes it +impossible to pass exceptions to or from a partition with this restriction +in a distributed environment. If this exception is active, then the generated +code is simplified by omitting the otherwise-required global registration +of exceptions when they are declared. + +@item No_Implicit_Conditionals +@findex No_Implicit_Conditionals +This restriction ensures that the generated code does not contain any +implicit conditionals, either by modifying the generated code where possible, +or by rejecting any construct that would otherwise generate an implicit +conditional. Note that this check does not include run time constraint +checks, which on some targets may generate implicit conditionals as +well. To control the latter, constraint checks can be suppressed in the +normal manner. Constructs generating implicit conditionals include comparisons +of composite objects and the Max/Min attributes. + +@item No_Implicit_Dynamic_Code +@findex No_Implicit_Dynamic_Code +@cindex trampoline +This restriction prevents the compiler from building ``trampolines''. +This is a structure that is built on the stack and contains dynamic +code to be executed at run time. On some targets, a trampoline is +built for the following features: @code{Access}, +@code{Unrestricted_Access}, or @code{Address} of a nested subprogram; +nested task bodies; primitive operations of nested tagged types. +Trampolines do not work on machines that prevent execution of stack +data. For example, on windows systems, enabling DEP (data execution +protection) will cause trampolines to raise an exception. +Trampolines are also quite slow at run time. + +On many targets, trampolines have been largely eliminated. Look at the +version of system.ads for your target --- if it has +Always_Compatible_Rep equal to False, then trampolines are largely +eliminated. In particular, a trampoline is built for the following +features: @code{Address} of a nested subprogram; +@code{Access} or @code{Unrestricted_Access} of a nested subprogram, +but only if pragma Favor_Top_Level applies, or the access type has a +foreign-language convention; primitive operations of nested tagged +types. + +@item No_Implicit_Loops +@findex No_Implicit_Loops +This restriction ensures that the generated code does not contain any +implicit @code{for} loops, either by modifying +the generated code where possible, +or by rejecting any construct that would otherwise generate an implicit +@code{for} loop. If this restriction is active, it is possible to build +large array aggregates with all static components without generating an +intermediate temporary, and without generating a loop to initialize individual +components. Otherwise, a loop is created for arrays larger than about 5000 +scalar components. + +@item No_Initialize_Scalars +@findex No_Initialize_Scalars +This restriction ensures that no unit in the partition is compiled with +pragma Initialize_Scalars. This allows the generation of more efficient +code, and in particular eliminates dummy null initialization routines that +are otherwise generated for some record and array types. + +@item No_Local_Protected_Objects +@findex No_Local_Protected_Objects +This restriction ensures at compile time that protected objects are +only declared at the library level. + +@item No_Protected_Type_Allocators +@findex No_Protected_Type_Allocators +This restriction ensures at compile time that there are no allocator +expressions that attempt to allocate protected objects. + +@item No_Secondary_Stack +@findex No_Secondary_Stack +This restriction ensures at compile time that the generated code does not +contain any reference to the secondary stack. The secondary stack is used +to implement functions returning unconstrained objects (arrays or records) +on some targets. + +@item No_Select_Statements +@findex No_Select_Statements +This restriction ensures at compile time no select statements of any kind +are permitted, that is the keyword @code{select} may not appear. +This is one of the restrictions of the Ravenscar +profile for limited tasking (see also pragma @code{Profile (Ravenscar)}). + +@item No_Standard_Storage_Pools +@findex No_Standard_Storage_Pools +This restriction ensures at compile time that no access types +use the standard default storage pool. Any access type declared must +have an explicit Storage_Pool attribute defined specifying a +user-defined storage pool. + +@item No_Streams +@findex No_Streams +This restriction ensures at compile/bind time that there are no +stream objects created and no use of stream attributes. +This restriction does not forbid dependences on the package +@code{Ada.Streams}. So it is permissible to with +@code{Ada.Streams} (or another package that does so itself) +as long as no actual stream objects are created and no +stream attributes are used. + +Note that the use of restriction allows optimization of tagged types, +since they do not need to worry about dispatching stream operations. +To take maximum advantage of this space-saving optimization, any +unit declaring a tagged type should be compiled with the restriction, +though this is not required. + +@item No_Task_Attributes_Package +@findex No_Task_Attributes_Package +This restriction ensures at compile time that there are no implicit or +explicit dependencies on the package @code{Ada.Task_Attributes}. + +@item No_Task_Termination +@findex No_Task_Termination +This restriction ensures at compile time that no terminate alternatives +appear in any task body. + +@item No_Tasking +@findex No_Tasking +This restriction prevents the declaration of tasks or task types throughout +the partition. It is similar in effect to the use of @code{Max_Tasks => 0} +except that violations are caught at compile time and cause an error message +to be output either by the compiler or binder. + +@item Static_Priorities +@findex Static_Priorities +This restriction ensures at compile time that all priority expressions +are static, and that there are no dependencies on the package +@code{Ada.Dynamic_Priorities}. + +@item Static_Storage_Size +@findex Static_Storage_Size +This restriction ensures at compile time that any expression appearing +in a Storage_Size pragma or attribute definition clause is static. + +@end table + +@noindent +The second set of implementation dependent restriction identifiers +does not require partition-wide consistency. +The restriction may be enforced for a single +compilation unit without any effect on any of the +other compilation units in the partition. + +@table @code + +@item No_Elaboration_Code +@findex No_Elaboration_Code +This restriction ensures at compile time that no elaboration code is +generated. Note that this is not the same condition as is enforced +by pragma @code{Preelaborate}. There are cases in which pragma +@code{Preelaborate} still permits code to be generated (e.g.@: code +to initialize a large array to all zeroes), and there are cases of units +which do not meet the requirements for pragma @code{Preelaborate}, +but for which no elaboration code is generated. Generally, it is +the case that preelaborable units will meet the restrictions, with +the exception of large aggregates initialized with an others_clause, +and exception declarations (which generate calls to a run-time +registry procedure). This restriction is enforced on +a unit by unit basis, it need not be obeyed consistently +throughout a partition. + +In the case of aggregates with others, if the aggregate has a dynamic +size, there is no way to eliminate the elaboration code (such dynamic +bounds would be incompatible with @code{Preelaborate} in any case). If +the bounds are static, then use of this restriction actually modifies +the code choice of the compiler to avoid generating a loop, and instead +generate the aggregate statically if possible, no matter how many times +the data for the others clause must be repeatedly generated. + +It is not possible to precisely document +the constructs which are compatible with this restriction, since, +unlike most other restrictions, this is not a restriction on the +source code, but a restriction on the generated object code. For +example, if the source contains a declaration: + +@smallexample + Val : constant Integer := X; +@end smallexample + +@noindent +where X is not a static constant, it may be possible, depending +on complex optimization circuitry, for the compiler to figure +out the value of X at compile time, in which case this initialization +can be done by the loader, and requires no initialization code. It +is not possible to document the precise conditions under which the +optimizer can figure this out. + +Note that this the implementation of this restriction requires full +code generation. If it is used in conjunction with "semantics only" +checking, then some cases of violations may be missed. + +@item No_Entry_Queue +@findex No_Entry_Queue +This restriction is a declaration that any protected entry compiled in +the scope of the restriction has at most one task waiting on the entry +at any one time, and so no queue is required. This restriction is not +checked at compile time. A program execution is erroneous if an attempt +is made to queue a second task on such an entry. + +@item No_Implementation_Attributes +@findex No_Implementation_Attributes +This restriction checks at compile time that no GNAT-defined attributes +are present. With this restriction, the only attributes that can be used +are those defined in the Ada Reference Manual. + +@item No_Implementation_Pragmas +@findex No_Implementation_Pragmas +This restriction checks at compile time that no GNAT-defined pragmas +are present. With this restriction, the only pragmas that can be used +are those defined in the Ada Reference Manual. + +@item No_Implementation_Restrictions +@findex No_Implementation_Restrictions +This restriction checks at compile time that no GNAT-defined restriction +identifiers (other than @code{No_Implementation_Restrictions} itself) +are present. With this restriction, the only other restriction identifiers +that can be used are those defined in the Ada Reference Manual. + +@item No_Wide_Characters +@findex No_Wide_Characters +This restriction ensures at compile time that no uses of the types +@code{Wide_Character} or @code{Wide_String} or corresponding wide +wide types +appear, and that no wide or wide wide string or character literals +appear in the program (that is literals representing characters not in +type @code{Character}. + +@end table + +@sp 1 +@cartouche +@noindent +@strong{58}. The consequences of violating limitations on +@code{Restrictions} pragmas. See 13.12(9). +@end cartouche +@noindent +Restrictions that can be checked at compile time result in illegalities +if violated. Currently there are no other consequences of violating +restrictions. + +@sp 1 +@cartouche +@noindent +@strong{59}. The representation used by the @code{Read} and +@code{Write} attributes of elementary types in terms of stream +elements. See 13.13.2(9). +@end cartouche +@noindent +The representation is the in-memory representation of the base type of +the type, using the number of bits corresponding to the +@code{@var{type}'Size} value, and the natural ordering of the machine. + +@sp 1 +@cartouche +@noindent +@strong{60}. The names and characteristics of the numeric subtypes +declared in the visible part of package @code{Standard}. See A.1(3). +@end cartouche +@noindent +See items describing the integer and floating-point types supported. + +@sp 1 +@cartouche +@noindent +@strong{61}. The accuracy actually achieved by the elementary +functions. See A.5.1(1). +@end cartouche +@noindent +The elementary functions correspond to the functions available in the C +library. Only fast math mode is implemented. + +@sp 1 +@cartouche +@noindent +@strong{62}. The sign of a zero result from some of the operators or +functions in @code{Numerics.Generic_Elementary_Functions}, when +@code{Float_Type'Signed_Zeros} is @code{True}. See A.5.1(46). +@end cartouche +@noindent +The sign of zeroes follows the requirements of the IEEE 754 standard on +floating-point. + +@sp 1 +@cartouche +@noindent +@strong{63}. The value of +@code{Numerics.Float_Random.Max_Image_Width}. See A.5.2(27). +@end cartouche +@noindent +Maximum image width is 6864, see library file @file{s-rannum.ads}. + +@sp 1 +@cartouche +@noindent +@strong{64}. The value of +@code{Numerics.Discrete_Random.Max_Image_Width}. See A.5.2(27). +@end cartouche +@noindent +Maximum image width is 6864, see library file @file{s-rannum.ads}. + +@sp 1 +@cartouche +@noindent +@strong{65}. The algorithms for random number generation. See +A.5.2(32). +@end cartouche +@noindent +The algorithm is the Mersenne Twister, as documented in the source file +@file{s-rannum.adb}. This version of the algorithm has a period of +2**19937-1. + +@sp 1 +@cartouche +@noindent +@strong{66}. The string representation of a random number generator's +state. See A.5.2(38). +@end cartouche +@noindent +The value returned by the Image function is the concatenation of +the fixed-width decimal representations of the 624 32-bit integers +of the state vector. + +@sp 1 +@cartouche +@noindent +@strong{67}. The minimum time interval between calls to the +time-dependent Reset procedure that are guaranteed to initiate different +random number sequences. See A.5.2(45). +@end cartouche +@noindent +The minimum period between reset calls to guarantee distinct series of +random numbers is one microsecond. + +@sp 1 +@cartouche +@noindent +@strong{68}. The values of the @code{Model_Mantissa}, +@code{Model_Emin}, @code{Model_Epsilon}, @code{Model}, +@code{Safe_First}, and @code{Safe_Last} attributes, if the Numerics +Annex is not supported. See A.5.3(72). +@end cartouche +@noindent +Run the compiler with @option{-gnatS} to produce a listing of package +@code{Standard}, has the values of all numeric attributes. + +@sp 1 +@cartouche +@noindent +@strong{69}. Any implementation-defined characteristics of the +input-output packages. See A.7(14). +@end cartouche +@noindent +There are no special implementation defined characteristics for these +packages. + +@sp 1 +@cartouche +@noindent +@strong{70}. The value of @code{Buffer_Size} in @code{Storage_IO}. See +A.9(10). +@end cartouche +@noindent +All type representations are contiguous, and the @code{Buffer_Size} is +the value of @code{@var{type}'Size} rounded up to the next storage unit +boundary. + +@sp 1 +@cartouche +@noindent +@strong{71}. External files for standard input, standard output, and +standard error See A.10(5). +@end cartouche +@noindent +These files are mapped onto the files provided by the C streams +libraries. See source file @file{i-cstrea.ads} for further details. + +@sp 1 +@cartouche +@noindent +@strong{72}. The accuracy of the value produced by @code{Put}. See +A.10.9(36). +@end cartouche +@noindent +If more digits are requested in the output than are represented by the +precision of the value, zeroes are output in the corresponding least +significant digit positions. + +@sp 1 +@cartouche +@noindent +@strong{73}. The meaning of @code{Argument_Count}, @code{Argument}, and +@code{Command_Name}. See A.15(1). +@end cartouche +@noindent +These are mapped onto the @code{argv} and @code{argc} parameters of the +main program in the natural manner. + +@sp 1 +@cartouche +@noindent +@strong{74}. The interpretation of the @code{Form} parameter in procedure +@code{Create_Directory}. See A.16(56). +@end cartouche +@noindent +The @code{Form} parameter is not used. + +@sp 1 +@cartouche +@noindent +@strong{75}. The interpretation of the @code{Form} parameter in procedure +@code{Create_Path}. See A.16(60). +@end cartouche +@noindent +The @code{Form} parameter is not used. + +@sp 1 +@cartouche +@noindent +@strong{76}. The interpretation of the @code{Form} parameter in procedure +@code{Copy_File}. See A.16(68). +@end cartouche +@noindent +The @code{Form} parameter is case-insensitive. + +Two fields are recognized in the @code{Form} parameter: + +@table @code + +@item preserve= + +@item mode= + +@end table + +@noindent + starts immediately after the character '=' and ends with the +character immediately preceding the next comma (',') or with the last +character of the parameter. + +The only possible values for preserve= are: + +@table @code + +@item no_attributes +Do not try to preserve any file attributes. This is the default if no +preserve= is found in Form. + +@item all_attributes +Try to preserve all file attributes (timestamps, access rights). + +@item timestamps +Preserve the timestamp of the copied file, but not the other file attributes. + +@end table + +@noindent +The only possible values for mode= are: + +@table @code + +@item copy +Only do the copy if the destination file does not already exist. If it already +exists, Copy_File fails. + +@item overwrite +Copy the file in all cases. Overwrite an already existing destination file. + +@item 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. + +@end table + +@noindent +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: + +@smallexample +Form => "preserve=no_attributes,mode=overwrite" (the default) +Form => "mode=append" +Form => "mode=copy, preserve=all_attributes" +@end smallexample + +@noindent +Examples of incorrect Forms + +@smallexample +Form => "preserve=junk" +Form => "mode=internal, preserve=timestamps" +@end smallexample + +@sp 1 +@cartouche +@noindent +@strong{77}. Implementation-defined convention names. See B.1(11). +@end cartouche +@noindent +The following convention names are supported + +@table @code +@item Ada +Ada +@item Assembler +Assembly language +@item Asm +Synonym for Assembler +@item Assembly +Synonym for Assembler +@item C +C +@item C_Pass_By_Copy +Allowed only for record types, like C, but also notes that record +is to be passed by copy rather than reference. +@item COBOL +COBOL +@item C_Plus_Plus (or CPP) +C++ +@item Default +Treated the same as C +@item External +Treated the same as C +@item Fortran +Fortran +@item Intrinsic +For support of pragma @code{Import} with convention Intrinsic, see +separate section on Intrinsic Subprograms. +@item Stdcall +Stdcall (used for Windows implementations only). This convention correspond +to the WINAPI (previously called Pascal convention) C/C++ convention under +Windows. A function with this convention cleans the stack before exit. +@item DLL +Synonym for Stdcall +@item Win32 +Synonym for Stdcall +@item Stubbed +Stubbed is a special convention used to indicate that the body of the +subprogram will be entirely ignored. Any call to the subprogram +is converted into a raise of the @code{Program_Error} exception. If a +pragma @code{Import} specifies convention @code{stubbed} then no body need +be present at all. This convention is useful during development for the +inclusion of subprograms whose body has not yet been written. + +@end table +@noindent +In addition, all otherwise unrecognized convention names are also +treated as being synonymous with convention C@. In all implementations +except for VMS, use of such other names results in a warning. In VMS +implementations, these names are accepted silently. + +@sp 1 +@cartouche +@noindent +@strong{78}. The meaning of link names. See B.1(36). +@end cartouche +@noindent +Link names are the actual names used by the linker. + +@sp 1 +@cartouche +@noindent +@strong{79}. The manner of choosing link names when neither the link +name nor the address of an imported or exported entity is specified. See +B.1(36). +@end cartouche +@noindent +The default linker name is that which would be assigned by the relevant +external language, interpreting the Ada name as being in all lower case +letters. + +@sp 1 +@cartouche +@noindent +@strong{80}. The effect of pragma @code{Linker_Options}. See B.1(37). +@end cartouche +@noindent +The string passed to @code{Linker_Options} is presented uninterpreted as +an argument to the link command, unless it contains ASCII.NUL characters. +NUL characters if they appear act as argument separators, so for example + +@smallexample @c ada +pragma Linker_Options ("-labc" & ASCII.NUL & "-ldef"); +@end smallexample + +@noindent +causes two separate arguments @code{-labc} and @code{-ldef} to be passed to the +linker. The order of linker options is preserved for a given unit. The final +list of options passed to the linker is in reverse order of the elaboration +order. For example, linker options for a body always appear before the options +from the corresponding package spec. + +@sp 1 +@cartouche +@noindent +@strong{81}. The contents of the visible part of package +@code{Interfaces} and its language-defined descendants. See B.2(1). +@end cartouche +@noindent +See files with prefix @file{i-} in the distributed library. + +@sp 1 +@cartouche +@noindent +@strong{82}. Implementation-defined children of package +@code{Interfaces}. The contents of the visible part of package +@code{Interfaces}. See B.2(11). +@end cartouche +@noindent +See files with prefix @file{i-} in the distributed library. + +@sp 1 +@cartouche +@noindent +@strong{83}. The types @code{Floating}, @code{Long_Floating}, +@code{Binary}, @code{Long_Binary}, @code{Decimal_ Element}, and +@code{COBOL_Character}; and the initialization of the variables +@code{Ada_To_COBOL} and @code{COBOL_To_Ada}, in +@code{Interfaces.COBOL}. See B.4(50). +@end cartouche +@noindent +@table @code +@item Floating +Float +@item Long_Floating +(Floating) Long_Float +@item Binary +Integer +@item Long_Binary +Long_Long_Integer +@item Decimal_Element +Character +@item COBOL_Character +Character +@end table + +@noindent +For initialization, see the file @file{i-cobol.ads} in the distributed library. + +@sp 1 +@cartouche +@noindent +@strong{84}. Support for access to machine instructions. See C.1(1). +@end cartouche +@noindent +See documentation in file @file{s-maccod.ads} in the distributed library. + +@sp 1 +@cartouche +@noindent +@strong{85}. Implementation-defined aspects of access to machine +operations. See C.1(9). +@end cartouche +@noindent +See documentation in file @file{s-maccod.ads} in the distributed library. + +@sp 1 +@cartouche +@noindent +@strong{86}. Implementation-defined aspects of interrupts. See C.3(2). +@end cartouche +@noindent +Interrupts are mapped to signals or conditions as appropriate. See +definition of unit +@code{Ada.Interrupt_Names} in source file @file{a-intnam.ads} for details +on the interrupts supported on a particular target. + +@sp 1 +@cartouche +@noindent +@strong{87}. Implementation-defined aspects of pre-elaboration. See +C.4(13). +@end cartouche +@noindent +GNAT does not permit a partition to be restarted without reloading, +except under control of the debugger. + +@sp 1 +@cartouche +@noindent +@strong{88}. The semantics of pragma @code{Discard_Names}. See C.5(7). +@end cartouche +@noindent +Pragma @code{Discard_Names} causes names of enumeration literals to +be suppressed. In the presence of this pragma, the Image attribute +provides the image of the Pos of the literal, and Value accepts +Pos values. + +@sp 1 +@cartouche +@noindent +@strong{89}. The result of the @code{Task_Identification.Image} +attribute. See C.7.1(7). +@end cartouche +@noindent +The result of this attribute is a string that identifies +the object or component that denotes a given task. If a variable @code{Var} +has a task type, the image for this task will have the form @code{Var_@var{XXXXXXXX}}, +where the suffix +is the hexadecimal representation of the virtual address of the corresponding +task control block. If the variable is an array of tasks, the image of each +task will have the form of an indexed component indicating the position of a +given task in the array, e.g.@: @code{Group(5)_@var{XXXXXXX}}. If the task is a +component of a record, the image of the task will have the form of a selected +component. These rules are fully recursive, so that the image of a task that +is a subcomponent of a composite object corresponds to the expression that +designates this task. +@noindent +If a task is created by an allocator, its image depends on the context. If the +allocator is part of an object declaration, the rules described above are used +to construct its image, and this image is not affected by subsequent +assignments. If the allocator appears within an expression, the image +includes only the name of the task type. +@noindent +If the configuration pragma Discard_Names is present, or if the restriction +No_Implicit_Heap_Allocation is in effect, the image reduces to +the numeric suffix, that is to say the hexadecimal representation of the +virtual address of the control block of the task. +@sp 1 +@cartouche +@noindent +@strong{90}. The value of @code{Current_Task} when in a protected entry +or interrupt handler. See C.7.1(17). +@end cartouche +@noindent +Protected entries or interrupt handlers can be executed by any +convenient thread, so the value of @code{Current_Task} is undefined. + +@sp 1 +@cartouche +@noindent +@strong{91}. The effect of calling @code{Current_Task} from an entry +body or interrupt handler. See C.7.1(19). +@end cartouche +@noindent +The effect of calling @code{Current_Task} from an entry body or +interrupt handler is to return the identification of the task currently +executing the code. + +@sp 1 +@cartouche +@noindent +@strong{92}. Implementation-defined aspects of +@code{Task_Attributes}. See C.7.2(19). +@end cartouche +@noindent +There are no implementation-defined aspects of @code{Task_Attributes}. + +@sp 1 +@cartouche +@noindent +@strong{93}. Values of all @code{Metrics}. See D(2). +@end cartouche +@noindent +The metrics information for GNAT depends on the performance of the +underlying operating system. The sources of the run-time for tasking +implementation, together with the output from @option{-gnatG} can be +used to determine the exact sequence of operating systems calls made +to implement various tasking constructs. Together with appropriate +information on the performance of the underlying operating system, +on the exact target in use, this information can be used to determine +the required metrics. + +@sp 1 +@cartouche +@noindent +@strong{94}. The declarations of @code{Any_Priority} and +@code{Priority}. See D.1(11). +@end cartouche +@noindent +See declarations in file @file{system.ads}. + +@sp 1 +@cartouche +@noindent +@strong{95}. Implementation-defined execution resources. See D.1(15). +@end cartouche +@noindent +There are no implementation-defined execution resources. + +@sp 1 +@cartouche +@noindent +@strong{96}. Whether, on a multiprocessor, a task that is waiting for +access to a protected object keeps its processor busy. See D.2.1(3). +@end cartouche +@noindent +On a multi-processor, a task that is waiting for access to a protected +object does not keep its processor busy. + +@sp 1 +@cartouche +@noindent +@strong{97}. The affect of implementation defined execution resources +on task dispatching. See D.2.1(9). +@end cartouche +@noindent +@c SGI info +@ignore +Tasks map to IRIX threads, and the dispatching policy is as defined by +the IRIX implementation of threads. +@end ignore +Tasks map to threads in the threads package used by GNAT@. Where possible +and appropriate, these threads correspond to native threads of the +underlying operating system. + +@sp 1 +@cartouche +@noindent +@strong{98}. Implementation-defined @code{policy_identifiers} allowed +in a pragma @code{Task_Dispatching_Policy}. See D.2.2(3). +@end cartouche +@noindent +There are no implementation-defined policy-identifiers allowed in this +pragma. + +@sp 1 +@cartouche +@noindent +@strong{99}. Implementation-defined aspects of priority inversion. See +D.2.2(16). +@end cartouche +@noindent +Execution of a task cannot be preempted by the implementation processing +of delay expirations for lower priority tasks. + +@sp 1 +@cartouche +@noindent +@strong{100}. Implementation defined task dispatching. See D.2.2(18). +@end cartouche +@noindent +@c SGI info: +@ignore +Tasks map to IRIX threads, and the dispatching policy is as defined by +the IRIX implementation of threads. +@end ignore +The policy is the same as that of the underlying threads implementation. + +@sp 1 +@cartouche +@noindent +@strong{101}. Implementation-defined @code{policy_identifiers} allowed +in a pragma @code{Locking_Policy}. See D.3(4). +@end cartouche +@noindent +The only implementation defined policy permitted in GNAT is +@code{Inheritance_Locking}. On targets that support this policy, locking +is implemented by inheritance, i.e.@: the task owning the lock operates +at a priority equal to the highest priority of any task currently +requesting the lock. + +@sp 1 +@cartouche +@noindent +@strong{102}. Default ceiling priorities. See D.3(10). +@end cartouche +@noindent +The ceiling priority of protected objects of the type +@code{System.Interrupt_Priority'Last} as described in the Ada +Reference Manual D.3(10), + +@sp 1 +@cartouche +@noindent +@strong{103}. The ceiling of any protected object used internally by +the implementation. See D.3(16). +@end cartouche +@noindent +The ceiling priority of internal protected objects is +@code{System.Priority'Last}. + +@sp 1 +@cartouche +@noindent +@strong{104}. Implementation-defined queuing policies. See D.4(1). +@end cartouche +@noindent +There are no implementation-defined queuing policies. + +@sp 1 +@cartouche +@noindent +@strong{105}. On a multiprocessor, any conditions that cause the +completion of an aborted construct to be delayed later than what is +specified for a single processor. See D.6(3). +@end cartouche +@noindent +The semantics for abort on a multi-processor is the same as on a single +processor, there are no further delays. + +@sp 1 +@cartouche +@noindent +@strong{106}. Any operations that implicitly require heap storage +allocation. See D.7(8). +@end cartouche +@noindent +The only operation that implicitly requires heap storage allocation is +task creation. + +@sp 1 +@cartouche +@noindent +@strong{107}. Implementation-defined aspects of pragma +@code{Restrictions}. See D.7(20). +@end cartouche +@noindent +There are no such implementation-defined aspects. + +@sp 1 +@cartouche +@noindent +@strong{108}. Implementation-defined aspects of package +@code{Real_Time}. See D.8(17). +@end cartouche +@noindent +There are no implementation defined aspects of package @code{Real_Time}. + +@sp 1 +@cartouche +@noindent +@strong{109}. Implementation-defined aspects of +@code{delay_statements}. See D.9(8). +@end cartouche +@noindent +Any difference greater than one microsecond will cause the task to be +delayed (see D.9(7)). + +@sp 1 +@cartouche +@noindent +@strong{110}. The upper bound on the duration of interrupt blocking +caused by the implementation. See D.12(5). +@end cartouche +@noindent +The upper bound is determined by the underlying operating system. In +no cases is it more than 10 milliseconds. + +@sp 1 +@cartouche +@noindent +@strong{111}. The means for creating and executing distributed +programs. See E(5). +@end cartouche +@noindent +The GLADE package provides a utility GNATDIST for creating and executing +distributed programs. See the GLADE reference manual for further details. + +@sp 1 +@cartouche +@noindent +@strong{112}. Any events that can result in a partition becoming +inaccessible. See E.1(7). +@end cartouche +@noindent +See the GLADE reference manual for full details on such events. + +@sp 1 +@cartouche +@noindent +@strong{113}. The scheduling policies, treatment of priorities, and +management of shared resources between partitions in certain cases. See +E.1(11). +@end cartouche +@noindent +See the GLADE reference manual for full details on these aspects of +multi-partition execution. + +@sp 1 +@cartouche +@noindent +@strong{114}. Events that cause the version of a compilation unit to +change. See E.3(5). +@end cartouche +@noindent +Editing the source file of a compilation unit, or the source files of +any units on which it is dependent in a significant way cause the version +to change. No other actions cause the version number to change. All changes +are significant except those which affect only layout, capitalization or +comments. + +@sp 1 +@cartouche +@noindent +@strong{115}. Whether the execution of the remote subprogram is +immediately aborted as a result of cancellation. See E.4(13). +@end cartouche +@noindent +See the GLADE reference manual for details on the effect of abort in +a distributed application. + +@sp 1 +@cartouche +@noindent +@strong{116}. Implementation-defined aspects of the PCS@. See E.5(25). +@end cartouche +@noindent +See the GLADE reference manual for a full description of all implementation +defined aspects of the PCS@. + +@sp 1 +@cartouche +@noindent +@strong{117}. Implementation-defined interfaces in the PCS@. See +E.5(26). +@end cartouche +@noindent +See the GLADE reference manual for a full description of all +implementation defined interfaces. + +@sp 1 +@cartouche +@noindent +@strong{118}. The values of named numbers in the package +@code{Decimal}. See F.2(7). +@end cartouche +@noindent +@table @code +@item Max_Scale ++18 +@item Min_Scale +-18 +@item Min_Delta +1.0E-18 +@item Max_Delta +1.0E+18 +@item Max_Decimal_Digits +18 +@end table + +@sp 1 +@cartouche +@noindent +@strong{119}. The value of @code{Max_Picture_Length} in the package +@code{Text_IO.Editing}. See F.3.3(16). +@end cartouche +@noindent +64 + +@sp 1 +@cartouche +@noindent +@strong{120}. The value of @code{Max_Picture_Length} in the package +@code{Wide_Text_IO.Editing}. See F.3.4(5). +@end cartouche +@noindent +64 + +@sp 1 +@cartouche +@noindent +@strong{121}. The accuracy actually achieved by the complex elementary +functions and by other complex arithmetic operations. See G.1(1). +@end cartouche +@noindent +Standard library functions are used for the complex arithmetic +operations. Only fast math mode is currently supported. + +@sp 1 +@cartouche +@noindent +@strong{122}. The sign of a zero result (or a component thereof) from +any operator or function in @code{Numerics.Generic_Complex_Types}, when +@code{Real'Signed_Zeros} is True. See G.1.1(53). +@end cartouche +@noindent +The signs of zero values are as recommended by the relevant +implementation advice. + +@sp 1 +@cartouche +@noindent +@strong{123}. The sign of a zero result (or a component thereof) from +any operator or function in +@code{Numerics.Generic_Complex_Elementary_Functions}, when +@code{Real'Signed_Zeros} is @code{True}. See G.1.2(45). +@end cartouche +@noindent +The signs of zero values are as recommended by the relevant +implementation advice. + +@sp 1 +@cartouche +@noindent +@strong{124}. Whether the strict mode or the relaxed mode is the +default. See G.2(2). +@end cartouche +@noindent +The strict mode is the default. There is no separate relaxed mode. GNAT +provides a highly efficient implementation of strict mode. + +@sp 1 +@cartouche +@noindent +@strong{125}. The result interval in certain cases of fixed-to-float +conversion. See G.2.1(10). +@end cartouche +@noindent +For cases where the result interval is implementation dependent, the +accuracy is that provided by performing all operations in 64-bit IEEE +floating-point format. + +@sp 1 +@cartouche +@noindent +@strong{126}. The result of a floating point arithmetic operation in +overflow situations, when the @code{Machine_Overflows} attribute of the +result type is @code{False}. See G.2.1(13). +@end cartouche +@noindent +Infinite and NaN values are produced as dictated by the IEEE +floating-point standard. + +Note that on machines that are not fully compliant with the IEEE +floating-point standard, such as Alpha, the @option{-mieee} compiler flag +must be used for achieving IEEE confirming behavior (although at the cost +of a significant performance penalty), so infinite and NaN values are +properly generated. + +@sp 1 +@cartouche +@noindent +@strong{127}. The result interval for division (or exponentiation by a +negative exponent), when the floating point hardware implements division +as multiplication by a reciprocal. See G.2.1(16). +@end cartouche +@noindent +Not relevant, division is IEEE exact. + +@sp 1 +@cartouche +@noindent +@strong{128}. The definition of close result set, which determines the +accuracy of certain fixed point multiplications and divisions. See +G.2.3(5). +@end cartouche +@noindent +Operations in the close result set are performed using IEEE long format +floating-point arithmetic. The input operands are converted to +floating-point, the operation is done in floating-point, and the result +is converted to the target type. + +@sp 1 +@cartouche +@noindent +@strong{129}. Conditions on a @code{universal_real} operand of a fixed +point multiplication or division for which the result shall be in the +perfect result set. See G.2.3(22). +@end cartouche +@noindent +The result is only defined to be in the perfect result set if the result +can be computed by a single scaling operation involving a scale factor +representable in 64-bits. + +@sp 1 +@cartouche +@noindent +@strong{130}. The result of a fixed point arithmetic operation in +overflow situations, when the @code{Machine_Overflows} attribute of the +result type is @code{False}. See G.2.3(27). +@end cartouche +@noindent +Not relevant, @code{Machine_Overflows} is @code{True} for fixed-point +types. + +@sp 1 +@cartouche +@noindent +@strong{131}. The result of an elementary function reference in +overflow situations, when the @code{Machine_Overflows} attribute of the +result type is @code{False}. See G.2.4(4). +@end cartouche +@noindent +IEEE infinite and Nan values are produced as appropriate. + +@sp 1 +@cartouche +@noindent +@strong{132}. The value of the angle threshold, within which certain +elementary functions, complex arithmetic operations, and complex +elementary functions yield results conforming to a maximum relative +error bound. See G.2.4(10). +@end cartouche +@noindent +Information on this subject is not yet available. + +@sp 1 +@cartouche +@noindent +@strong{133}. The accuracy of certain elementary functions for +parameters beyond the angle threshold. See G.2.4(10). +@end cartouche +@noindent +Information on this subject is not yet available. + +@sp 1 +@cartouche +@noindent +@strong{134}. The result of a complex arithmetic operation or complex +elementary function reference in overflow situations, when the +@code{Machine_Overflows} attribute of the corresponding real type is +@code{False}. See G.2.6(5). +@end cartouche +@noindent +IEEE infinite and Nan values are produced as appropriate. + +@sp 1 +@cartouche +@noindent +@strong{135}. The accuracy of certain complex arithmetic operations and +certain complex elementary functions for parameters (or components +thereof) beyond the angle threshold. See G.2.6(8). +@end cartouche +@noindent +Information on those subjects is not yet available. + +@sp 1 +@cartouche +@noindent +@strong{136}. Information regarding bounded errors and erroneous +execution. See H.2(1). +@end cartouche +@noindent +Information on this subject is not yet available. + +@sp 1 +@cartouche +@noindent +@strong{137}. Implementation-defined aspects of pragma +@code{Inspection_Point}. See H.3.2(8). +@end cartouche +@noindent +Pragma @code{Inspection_Point} ensures that the variable is live and can +be examined by the debugger at the inspection point. + +@sp 1 +@cartouche +@noindent +@strong{138}. Implementation-defined aspects of pragma +@code{Restrictions}. See H.4(25). +@end cartouche +@noindent +There are no implementation-defined aspects of pragma @code{Restrictions}. The +use of pragma @code{Restrictions [No_Exceptions]} has no effect on the +generated code. Checks must suppressed by use of pragma @code{Suppress}. + +@sp 1 +@cartouche +@noindent +@strong{139}. Any restrictions on pragma @code{Restrictions}. See +H.4(27). +@end cartouche +@noindent +There are no restrictions on pragma @code{Restrictions}. + +@node Intrinsic Subprograms +@chapter Intrinsic Subprograms +@cindex Intrinsic Subprograms + +@menu +* Intrinsic Operators:: +* Enclosing_Entity:: +* Exception_Information:: +* Exception_Message:: +* Exception_Name:: +* File:: +* Line:: +* Rotate_Left:: +* Rotate_Right:: +* Shift_Left:: +* Shift_Right:: +* Shift_Right_Arithmetic:: +* Source_Location:: +@end menu + +@noindent +GNAT allows a user application program to write the declaration: + +@smallexample @c ada + pragma Import (Intrinsic, name); +@end smallexample + +@noindent +providing that the name corresponds to one of the implemented intrinsic +subprograms in GNAT, and that the parameter profile of the referenced +subprogram meets the requirements. This chapter describes the set of +implemented intrinsic subprograms, and the requirements on parameter profiles. +Note that no body is supplied; as with other uses of pragma Import, the +body is supplied elsewhere (in this case by the compiler itself). Note +that any use of this feature is potentially non-portable, since the +Ada standard does not require Ada compilers to implement this feature. + +@node Intrinsic Operators +@section Intrinsic Operators +@cindex Intrinsic operator + +@noindent +All the predefined numeric operators in package Standard +in @code{pragma Import (Intrinsic,..)} +declarations. In the binary operator case, the operands must have the same +size. The operand or operands must also be appropriate for +the operator. For example, for addition, the operands must +both be floating-point or both be fixed-point, and the +right operand for @code{"**"} must have a root type of +@code{Standard.Integer'Base}. +You can use an intrinsic operator declaration as in the following example: + +@smallexample @c ada + type Int1 is new Integer; + type Int2 is new Integer; + + function "+" (X1 : Int1; X2 : Int2) return Int1; + function "+" (X1 : Int1; X2 : Int2) return Int2; + pragma Import (Intrinsic, "+"); +@end smallexample + +@noindent +This declaration would permit ``mixed mode'' arithmetic on items +of the differing types @code{Int1} and @code{Int2}. +It is also possible to specify such operators for private types, if the +full views are appropriate arithmetic types. + +@node Enclosing_Entity +@section Enclosing_Entity +@cindex Enclosing_Entity +@noindent +This intrinsic subprogram is used in the implementation of the +library routine @code{GNAT.Source_Info}. The only useful use of the +intrinsic import in this case is the one in this unit, so an +application program should simply call the function +@code{GNAT.Source_Info.Enclosing_Entity} to obtain the name of +the current subprogram, package, task, entry, or protected subprogram. + +@node Exception_Information +@section Exception_Information +@cindex Exception_Information' +@noindent +This intrinsic subprogram is used in the implementation of the +library routine @code{GNAT.Current_Exception}. The only useful +use of the intrinsic import in this case is the one in this unit, +so an application program should simply call the function +@code{GNAT.Current_Exception.Exception_Information} to obtain +the exception information associated with the current exception. + +@node Exception_Message +@section Exception_Message +@cindex Exception_Message +@noindent +This intrinsic subprogram is used in the implementation of the +library routine @code{GNAT.Current_Exception}. The only useful +use of the intrinsic import in this case is the one in this unit, +so an application program should simply call the function +@code{GNAT.Current_Exception.Exception_Message} to obtain +the message associated with the current exception. + +@node Exception_Name +@section Exception_Name +@cindex Exception_Name +@noindent +This intrinsic subprogram is used in the implementation of the +library routine @code{GNAT.Current_Exception}. The only useful +use of the intrinsic import in this case is the one in this unit, +so an application program should simply call the function +@code{GNAT.Current_Exception.Exception_Name} to obtain +the name of the current exception. + +@node File +@section File +@cindex File +@noindent +This intrinsic subprogram is used in the implementation of the +library routine @code{GNAT.Source_Info}. The only useful use of the +intrinsic import in this case is the one in this unit, so an +application program should simply call the function +@code{GNAT.Source_Info.File} to obtain the name of the current +file. + +@node Line +@section Line +@cindex Line +@noindent +This intrinsic subprogram is used in the implementation of the +library routine @code{GNAT.Source_Info}. The only useful use of the +intrinsic import in this case is the one in this unit, so an +application program should simply call the function +@code{GNAT.Source_Info.Line} to obtain the number of the current +source line. + +@node Rotate_Left +@section Rotate_Left +@cindex Rotate_Left +@noindent +In standard Ada, the @code{Rotate_Left} function is available only +for the predefined modular types in package @code{Interfaces}. However, in +GNAT it is possible to define a Rotate_Left function for a user +defined modular type or any signed integer type as in this example: + +@smallexample @c ada + function Shift_Left + (Value : My_Modular_Type; + Amount : Natural) + return My_Modular_Type; +@end smallexample + +@noindent +The requirements are that the profile be exactly as in the example +above. The only modifications allowed are in the formal parameter +names, and in the type of @code{Value} and the return type, which +must be the same, and must be either a signed integer type, or +a modular integer type with a binary modulus, and the size must +be 8. 16, 32 or 64 bits. + +@node Rotate_Right +@section Rotate_Right +@cindex Rotate_Right +@noindent +A @code{Rotate_Right} function can be defined for any user defined +binary modular integer type, or signed integer type, as described +above for @code{Rotate_Left}. + +@node Shift_Left +@section Shift_Left +@cindex Shift_Left +@noindent +A @code{Shift_Left} function can be defined for any user defined +binary modular integer type, or signed integer type, as described +above for @code{Rotate_Left}. + +@node Shift_Right +@section Shift_Right +@cindex Shift_Right +@noindent +A @code{Shift_Right} function can be defined for any user defined +binary modular integer type, or signed integer type, as described +above for @code{Rotate_Left}. + +@node Shift_Right_Arithmetic +@section Shift_Right_Arithmetic +@cindex Shift_Right_Arithmetic +@noindent +A @code{Shift_Right_Arithmetic} function can be defined for any user +defined binary modular integer type, or signed integer type, as described +above for @code{Rotate_Left}. + +@node Source_Location +@section Source_Location +@cindex Source_Location +@noindent +This intrinsic subprogram is used in the implementation of the +library routine @code{GNAT.Source_Info}. The only useful use of the +intrinsic import in this case is the one in this unit, so an +application program should simply call the function +@code{GNAT.Source_Info.Source_Location} to obtain the current +source file location. + +@node Representation Clauses and Pragmas +@chapter Representation Clauses and Pragmas +@cindex Representation Clauses + +@menu +* Alignment Clauses:: +* Size Clauses:: +* Storage_Size Clauses:: +* Size of Variant Record Objects:: +* Biased Representation :: +* Value_Size and Object_Size Clauses:: +* Component_Size Clauses:: +* Bit_Order Clauses:: +* Effect of Bit_Order on Byte Ordering:: +* Pragma Pack for Arrays:: +* Pragma Pack for Records:: +* Record Representation Clauses:: +* Enumeration Clauses:: +* Address Clauses:: +* Effect of Convention on Representation:: +* Determining the Representations chosen by GNAT:: +@end menu + +@noindent +@cindex Representation Clause +@cindex Representation Pragma +@cindex Pragma, representation +This section describes the representation clauses accepted by GNAT, and +their effect on the representation of corresponding data objects. + +GNAT fully implements Annex C (Systems Programming). This means that all +the implementation advice sections in chapter 13 are fully implemented. +However, these sections only require a minimal level of support for +representation clauses. GNAT provides much more extensive capabilities, +and this section describes the additional capabilities provided. + +@node Alignment Clauses +@section Alignment Clauses +@cindex Alignment Clause + +@noindent +GNAT requires that all alignment clauses specify a power of 2, and all +default alignments are always a power of 2. The default alignment +values are as follows: + +@itemize @bullet +@item @emph{Primitive Types}. +For primitive types, the alignment is the minimum of the actual size of +objects of the type divided by @code{Storage_Unit}, +and the maximum alignment supported by the target. +(This maximum alignment is given by the GNAT-specific attribute +@code{Standard'Maximum_Alignment}; see @ref{Maximum_Alignment}.) +@cindex @code{Maximum_Alignment} attribute +For example, for type @code{Long_Float}, the object size is 8 bytes, and the +default alignment will be 8 on any target that supports alignments +this large, but on some targets, the maximum alignment may be smaller +than 8, in which case objects of type @code{Long_Float} will be maximally +aligned. + +@item @emph{Arrays}. +For arrays, the alignment is equal to the alignment of the component type +for the normal case where no packing or component size is given. If the +array is packed, and the packing is effective (see separate section on +packed arrays), then the alignment will be one for long packed arrays, +or arrays whose length is not known at compile time. For short packed +arrays, which are handled internally as modular types, the alignment +will be as described for primitive types, e.g.@: a packed array of length +31 bits will have an object size of four bytes, and an alignment of 4. + +@item @emph{Records}. +For the normal non-packed case, the alignment of a record is equal to +the maximum alignment of any of its components. For tagged records, this +includes the implicit access type used for the tag. If a pragma @code{Pack} +is used and all components are packable (see separate section on pragma +@code{Pack}), then the resulting alignment is 1, unless the layout of the +record makes it profitable to increase it. + +A special case is when: +@itemize @bullet +@item +the size of the record is given explicitly, or a +full record representation clause is given, and +@item +the size of the record is 2, 4, or 8 bytes. +@end itemize +@noindent +In this case, an alignment is chosen to match the +size of the record. For example, if we have: + +@smallexample @c ada + type Small is record + A, B : Character; + end record; + for Small'Size use 16; +@end smallexample + +@noindent +then the default alignment of the record type @code{Small} is 2, not 1. This +leads to more efficient code when the record is treated as a unit, and also +allows the type to specified as @code{Atomic} on architectures requiring +strict alignment. + +@end itemize + +@noindent +An alignment clause may specify a larger alignment than the default value +up to some maximum value dependent on the target (obtainable by using the +attribute reference @code{Standard'Maximum_Alignment}). It may also specify +a smaller alignment than the default value for enumeration, integer and +fixed point types, as well as for record types, for example + +@smallexample @c ada + type V is record + A : Integer; + end record; + + for V'alignment use 1; +@end smallexample + +@noindent +@cindex Alignment, default +The default alignment for the type @code{V} is 4, as a result of the +Integer field in the record, but it is permissible, as shown, to +override the default alignment of the record with a smaller value. + +@node Size Clauses +@section Size Clauses +@cindex Size Clause + +@noindent +The default size for a type @code{T} is obtainable through the +language-defined attribute @code{T'Size} and also through the +equivalent GNAT-defined attribute @code{T'Value_Size}. +For objects of type @code{T}, GNAT will generally increase the type size +so that the object size (obtainable through the GNAT-defined attribute +@code{T'Object_Size}) +is a multiple of @code{T'Alignment * Storage_Unit}. +For example + +@smallexample @c ada + type Smallint is range 1 .. 6; + + type Rec is record + Y1 : integer; + Y2 : boolean; + end record; +@end smallexample + +@noindent +In this example, @code{Smallint'Size} = @code{Smallint'Value_Size} = 3, +as specified by the RM rules, +but objects of this type will have a size of 8 +(@code{Smallint'Object_Size} = 8), +since objects by default occupy an integral number +of storage units. On some targets, notably older +versions of the Digital Alpha, the size of stand +alone objects of this type may be 32, reflecting +the inability of the hardware to do byte load/stores. + +Similarly, the size of type @code{Rec} is 40 bits +(@code{Rec'Size} = @code{Rec'Value_Size} = 40), but +the alignment is 4, so objects of this type will have +their size increased to 64 bits so that it is a multiple +of the alignment (in bits). This decision is +in accordance with the specific Implementation Advice in RM 13.3(43): + +@quotation +A @code{Size} clause should be supported for an object if the specified +@code{Size} is at least as large as its subtype's @code{Size}, and corresponds +to a size in storage elements that is a multiple of the object's +@code{Alignment} (if the @code{Alignment} is nonzero). +@end quotation + +@noindent +An explicit size clause may be used to override the default size by +increasing it. For example, if we have: + +@smallexample @c ada + type My_Boolean is new Boolean; + for My_Boolean'Size use 32; +@end smallexample + +@noindent +then values of this type will always be 32 bits long. In the case of +discrete types, the size can be increased up to 64 bits, with the effect +that the entire specified field is used to hold the value, sign- or +zero-extended as appropriate. If more than 64 bits is specified, then +padding space is allocated after the value, and a warning is issued that +there are unused bits. + +Similarly the size of records and arrays may be increased, and the effect +is to add padding bits after the value. This also causes a warning message +to be generated. + +The largest Size value permitted in GNAT is 2**31@minus{}1. Since this is a +Size in bits, this corresponds to an object of size 256 megabytes (minus +one). This limitation is true on all targets. The reason for this +limitation is that it improves the quality of the code in many cases +if it is known that a Size value can be accommodated in an object of +type Integer. + +@node Storage_Size Clauses +@section Storage_Size Clauses +@cindex Storage_Size Clause + +@noindent +For tasks, the @code{Storage_Size} clause specifies the amount of space +to be allocated for the task stack. This cannot be extended, and if the +stack is exhausted, then @code{Storage_Error} will be raised (if stack +checking is enabled). Use a @code{Storage_Size} attribute definition clause, +or a @code{Storage_Size} pragma in the task definition to set the +appropriate required size. A useful technique is to include in every +task definition a pragma of the form: + +@smallexample @c ada + pragma Storage_Size (Default_Stack_Size); +@end smallexample + +@noindent +Then @code{Default_Stack_Size} can be defined in a global package, and +modified as required. Any tasks requiring stack sizes different from the +default can have an appropriate alternative reference in the pragma. + +You can also use the @option{-d} binder switch to modify the default stack +size. + +For access types, the @code{Storage_Size} clause specifies the maximum +space available for allocation of objects of the type. If this space is +exceeded then @code{Storage_Error} will be raised by an allocation attempt. +In the case where the access type is declared local to a subprogram, the +use of a @code{Storage_Size} clause triggers automatic use of a special +predefined storage pool (@code{System.Pool_Size}) that ensures that all +space for the pool is automatically reclaimed on exit from the scope in +which the type is declared. + +A special case recognized by the compiler is the specification of a +@code{Storage_Size} of zero for an access type. This means that no +items can be allocated from the pool, and this is recognized at compile +time, and all the overhead normally associated with maintaining a fixed +size storage pool is eliminated. Consider the following example: + +@smallexample @c ada + procedure p is + type R is array (Natural) of Character; + type P is access all R; + for P'Storage_Size use 0; + -- Above access type intended only for interfacing purposes + + y : P; + + procedure g (m : P); + pragma Import (C, g); + + -- @dots{} + + begin + -- @dots{} + y := new R; + end; +@end smallexample + +@noindent +As indicated in this example, these dummy storage pools are often useful in +connection with interfacing where no object will ever be allocated. If you +compile the above example, you get the warning: + +@smallexample + p.adb:16:09: warning: allocation from empty storage pool + p.adb:16:09: warning: Storage_Error will be raised at run time +@end smallexample + +@noindent +Of course in practice, there will not be any explicit allocators in the +case of such an access declaration. + +@node Size of Variant Record Objects +@section Size of Variant Record Objects +@cindex Size, variant record objects +@cindex Variant record objects, size + +@noindent +In the case of variant record objects, there is a question whether Size gives +information about a particular variant, or the maximum size required +for any variant. Consider the following program + +@smallexample @c ada +with Text_IO; use Text_IO; +procedure q is + type R1 (A : Boolean := False) is record + case A is + when True => X : Character; + when False => null; + end case; + end record; + + V1 : R1 (False); + V2 : R1; + +begin + Put_Line (Integer'Image (V1'Size)); + Put_Line (Integer'Image (V2'Size)); +end q; +@end smallexample + +@noindent +Here we are dealing with a variant record, where the True variant +requires 16 bits, and the False variant requires 8 bits. +In the above example, both V1 and V2 contain the False variant, +which is only 8 bits long. However, the result of running the +program is: + +@smallexample +8 +16 +@end smallexample + +@noindent +The reason for the difference here is that the discriminant value of +V1 is fixed, and will always be False. It is not possible to assign +a True variant value to V1, therefore 8 bits is sufficient. On the +other hand, in the case of V2, the initial discriminant value is +False (from the default), but it is possible to assign a True +variant value to V2, therefore 16 bits must be allocated for V2 +in the general case, even fewer bits may be needed at any particular +point during the program execution. + +As can be seen from the output of this program, the @code{'Size} +attribute applied to such an object in GNAT gives the actual allocated +size of the variable, which is the largest size of any of the variants. +The Ada Reference Manual is not completely clear on what choice should +be made here, but the GNAT behavior seems most consistent with the +language in the RM@. + +In some cases, it may be desirable to obtain the size of the current +variant, rather than the size of the largest variant. This can be +achieved in GNAT by making use of the fact that in the case of a +subprogram parameter, GNAT does indeed return the size of the current +variant (because a subprogram has no way of knowing how much space +is actually allocated for the actual). + +Consider the following modified version of the above program: + +@smallexample @c ada +with Text_IO; use Text_IO; +procedure q is + type R1 (A : Boolean := False) is record + case A is + when True => X : Character; + when False => null; + end case; + end record; + + V2 : R1; + + function Size (V : R1) return Integer is + begin + return V'Size; + end Size; + +begin + Put_Line (Integer'Image (V2'Size)); + Put_Line (Integer'IMage (Size (V2))); + V2 := (True, 'x'); + Put_Line (Integer'Image (V2'Size)); + Put_Line (Integer'IMage (Size (V2))); +end q; +@end smallexample + +@noindent +The output from this program is + +@smallexample +16 +8 +16 +16 +@end smallexample + +@noindent +Here we see that while the @code{'Size} attribute always returns +the maximum size, regardless of the current variant value, the +@code{Size} function does indeed return the size of the current +variant value. + +@node Biased Representation +@section Biased Representation +@cindex Size for biased representation +@cindex Biased representation + +@noindent +In the case of scalars with a range starting at other than zero, it is +possible in some cases to specify a size smaller than the default minimum +value, and in such cases, GNAT uses an unsigned biased representation, +in which zero is used to represent the lower bound, and successive values +represent successive values of the type. + +For example, suppose we have the declaration: + +@smallexample @c ada + type Small is range -7 .. -4; + for Small'Size use 2; +@end smallexample + +@noindent +Although the default size of type @code{Small} is 4, the @code{Size} +clause is accepted by GNAT and results in the following representation +scheme: + +@smallexample + -7 is represented as 2#00# + -6 is represented as 2#01# + -5 is represented as 2#10# + -4 is represented as 2#11# +@end smallexample + +@noindent +Biased representation is only used if the specified @code{Size} clause +cannot be accepted in any other manner. These reduced sizes that force +biased representation can be used for all discrete types except for +enumeration types for which a representation clause is given. + +@node Value_Size and Object_Size Clauses +@section Value_Size and Object_Size Clauses +@findex Value_Size +@findex Object_Size +@cindex Size, of objects + +@noindent +In Ada 95 and Ada 2005, @code{T'Size} for a type @code{T} is the minimum +number of bits required to hold values of type @code{T}. +Although this interpretation was allowed in Ada 83, it was not required, +and this requirement in practice can cause some significant difficulties. +For example, in most Ada 83 compilers, @code{Natural'Size} was 32. +However, in Ada 95 and Ada 2005, +@code{Natural'Size} is +typically 31. This means that code may change in behavior when moving +from Ada 83 to Ada 95 or Ada 2005. For example, consider: + +@smallexample @c ada + type Rec is record; + A : Natural; + B : Natural; + end record; + + for Rec use record + at 0 range 0 .. Natural'Size - 1; + at 0 range Natural'Size .. 2 * Natural'Size - 1; + end record; +@end smallexample + +@noindent +In the above code, since the typical size of @code{Natural} objects +is 32 bits and @code{Natural'Size} is 31, the above code can cause +unexpected inefficient packing in Ada 95 and Ada 2005, and in general +there are cases where the fact that the object size can exceed the +size of the type causes surprises. + +To help get around this problem GNAT provides two implementation +defined attributes, @code{Value_Size} and @code{Object_Size}. When +applied to a type, these attributes yield the size of the type +(corresponding to the RM defined size attribute), and the size of +objects of the type respectively. + +The @code{Object_Size} is used for determining the default size of +objects and components. This size value can be referred to using the +@code{Object_Size} attribute. The phrase ``is used'' here means that it is +the basis of the determination of the size. The backend is free to +pad this up if necessary for efficiency, e.g.@: an 8-bit stand-alone +character might be stored in 32 bits on a machine with no efficient +byte access instructions such as the Alpha. + +The default rules for the value of @code{Object_Size} for +discrete types are as follows: + +@itemize @bullet +@item +The @code{Object_Size} for base subtypes reflect the natural hardware +size in bits (run the compiler with @option{-gnatS} to find those values +for numeric types). Enumeration types and fixed-point base subtypes have +8, 16, 32 or 64 bits for this size, depending on the range of values +to be stored. + +@item +The @code{Object_Size} of a subtype is the same as the +@code{Object_Size} of +the type from which it is obtained. + +@item +The @code{Object_Size} of a derived base type is copied from the parent +base type, and the @code{Object_Size} of a derived first subtype is copied +from the parent first subtype. +@end itemize + +@noindent +The @code{Value_Size} attribute +is the (minimum) number of bits required to store a value +of the type. +This value is used to determine how tightly to pack +records or arrays with components of this type, and also affects +the semantics of unchecked conversion (unchecked conversions where +the @code{Value_Size} values differ generate a warning, and are potentially +target dependent). + +The default rules for the value of @code{Value_Size} are as follows: + +@itemize @bullet +@item +The @code{Value_Size} for a base subtype is the minimum number of bits +required to store all values of the type (including the sign bit +only if negative values are possible). + +@item +If a subtype statically matches the first subtype of a given type, then it has +by default the same @code{Value_Size} as the first subtype. This is a +consequence of RM 13.1(14) (``if two subtypes statically match, +then their subtype-specific aspects are the same''.) + +@item +All other subtypes have a @code{Value_Size} corresponding to the minimum +number of bits required to store all values of the subtype. For +dynamic bounds, it is assumed that the value can range down or up +to the corresponding bound of the ancestor +@end itemize + +@noindent +The RM defined attribute @code{Size} corresponds to the +@code{Value_Size} attribute. + +The @code{Size} attribute may be defined for a first-named subtype. This sets +the @code{Value_Size} of +the first-named subtype to the given value, and the +@code{Object_Size} of this first-named subtype to the given value padded up +to an appropriate boundary. It is a consequence of the default rules +above that this @code{Object_Size} will apply to all further subtypes. On the +other hand, @code{Value_Size} is affected only for the first subtype, any +dynamic subtypes obtained from it directly, and any statically matching +subtypes. The @code{Value_Size} of any other static subtypes is not affected. + +@code{Value_Size} and +@code{Object_Size} may be explicitly set for any subtype using +an attribute definition clause. Note that the use of these attributes +can cause the RM 13.1(14) rule to be violated. If two access types +reference aliased objects whose subtypes have differing @code{Object_Size} +values as a result of explicit attribute definition clauses, then it +is erroneous to convert from one access subtype to the other. + +At the implementation level, Esize stores the Object_Size and the +RM_Size field stores the @code{Value_Size} (and hence the value of the +@code{Size} attribute, +which, as noted above, is equivalent to @code{Value_Size}). + +To get a feel for the difference, consider the following examples (note +that in each case the base is @code{Short_Short_Integer} with a size of 8): + +@smallexample + Object_Size Value_Size + +type x1 is range 0 .. 5; 8 3 + +type x2 is range 0 .. 5; +for x2'size use 12; 16 12 + +subtype x3 is x2 range 0 .. 3; 16 2 + +subtype x4 is x2'base range 0 .. 10; 8 4 + +subtype x5 is x2 range 0 .. dynamic; 16 3* + +subtype x6 is x2'base range 0 .. dynamic; 8 3* + +@end smallexample + +@noindent +Note: the entries marked ``3*'' are not actually specified by the Ada +Reference Manual, but it seems in the spirit of the RM rules to allocate +the minimum number of bits (here 3, given the range for @code{x2}) +known to be large enough to hold the given range of values. + +So far, so good, but GNAT has to obey the RM rules, so the question is +under what conditions must the RM @code{Size} be used. +The following is a list +of the occasions on which the RM @code{Size} must be used: + +@itemize @bullet +@item +Component size for packed arrays or records + +@item +Value of the attribute @code{Size} for a type + +@item +Warning about sizes not matching for unchecked conversion +@end itemize + +@noindent +For record types, the @code{Object_Size} is always a multiple of the +alignment of the type (this is true for all types). In some cases the +@code{Value_Size} can be smaller. Consider: + +@smallexample + type R is record + X : Integer; + Y : Character; + end record; +@end smallexample + +@noindent +On a typical 32-bit architecture, the X component will be four bytes, and +require four-byte alignment, and the Y component will be one byte. In this +case @code{R'Value_Size} will be 40 (bits) since this is the minimum size +required to store a value of this type, and for example, it is permissible +to have a component of type R in an outer array whose component size is +specified to be 48 bits. However, @code{R'Object_Size} will be 64 (bits), +since it must be rounded up so that this value is a multiple of the +alignment (4 bytes = 32 bits). + +@noindent +For all other types, the @code{Object_Size} +and Value_Size are the same (and equivalent to the RM attribute @code{Size}). +Only @code{Size} may be specified for such types. + +@node Component_Size Clauses +@section Component_Size Clauses +@cindex Component_Size Clause + +@noindent +Normally, the value specified in a component size clause must be consistent +with the subtype of the array component with regard to size and alignment. +In other words, the value specified must be at least equal to the size +of this subtype, and must be a multiple of the alignment value. + +In addition, component size clauses are allowed which cause the array +to be packed, by specifying a smaller value. A first case is for +component size values in the range 1 through 63. The value specified +must not be smaller than the Size of the subtype. GNAT will accurately +honor all packing requests in this range. For example, if we have: + +@smallexample @c ada +type r is array (1 .. 8) of Natural; +for r'Component_Size use 31; +@end smallexample + +@noindent +then the resulting array has a length of 31 bytes (248 bits = 8 * 31). +Of course access to the components of such an array is considerably +less efficient than if the natural component size of 32 is used. +A second case is when the subtype of the component is a record type +padded because of its default alignment. For example, if we have: + +@smallexample @c ada +type r is record + i : Integer; + j : Integer; + b : Boolean; +end record; + +type a is array (1 .. 8) of r; +for a'Component_Size use 72; +@end smallexample + +@noindent +then the resulting array has a length of 72 bytes, instead of 96 bytes +if the alignment of the record (4) was obeyed. + +Note that there is no point in giving both a component size clause +and a pragma Pack for the same array type. if such duplicate +clauses are given, the pragma Pack will be ignored. + +@node Bit_Order Clauses +@section Bit_Order Clauses +@cindex Bit_Order Clause +@cindex bit ordering +@cindex ordering, of bits + +@noindent +For record subtypes, GNAT permits the specification of the @code{Bit_Order} +attribute. The specification may either correspond to the default bit +order for the target, in which case the specification has no effect and +places no additional restrictions, or it may be for the non-standard +setting (that is the opposite of the default). + +In the case where the non-standard value is specified, the effect is +to renumber bits within each byte, but the ordering of bytes is not +affected. There are certain +restrictions placed on component clauses as follows: + +@itemize @bullet + +@item Components fitting within a single storage unit. +@noindent +These are unrestricted, and the effect is merely to renumber bits. For +example if we are on a little-endian machine with @code{Low_Order_First} +being the default, then the following two declarations have exactly +the same effect: + +@smallexample @c ada + type R1 is record + A : Boolean; + B : Integer range 1 .. 120; + end record; + + for R1 use record + A at 0 range 0 .. 0; + B at 0 range 1 .. 7; + end record; + + type R2 is record + A : Boolean; + B : Integer range 1 .. 120; + end record; + + for R2'Bit_Order use High_Order_First; + + for R2 use record + A at 0 range 7 .. 7; + B at 0 range 0 .. 6; + end record; +@end smallexample + +@noindent +The useful application here is to write the second declaration with the +@code{Bit_Order} attribute definition clause, and know that it will be treated +the same, regardless of whether the target is little-endian or big-endian. + +@item Components occupying an integral number of bytes. +@noindent +These are components that exactly fit in two or more bytes. Such component +declarations are allowed, but have no effect, since it is important to realize +that the @code{Bit_Order} specification does not affect the ordering of bytes. +In particular, the following attempt at getting an endian-independent integer +does not work: + +@smallexample @c ada + type R2 is record + A : Integer; + end record; + + for R2'Bit_Order use High_Order_First; + + for R2 use record + A at 0 range 0 .. 31; + end record; +@end smallexample + +@noindent +This declaration will result in a little-endian integer on a +little-endian machine, and a big-endian integer on a big-endian machine. +If byte flipping is required for interoperability between big- and +little-endian machines, this must be explicitly programmed. This capability +is not provided by @code{Bit_Order}. + +@item Components that are positioned across byte boundaries +@noindent +but do not occupy an integral number of bytes. Given that bytes are not +reordered, such fields would occupy a non-contiguous sequence of bits +in memory, requiring non-trivial code to reassemble. They are for this +reason not permitted, and any component clause specifying such a layout +will be flagged as illegal by GNAT@. + +@end itemize + +@noindent +Since the misconception that Bit_Order automatically deals with all +endian-related incompatibilities is a common one, the specification of +a component field that is an integral number of bytes will always +generate a warning. This warning may be suppressed using @code{pragma +Warnings (Off)} if desired. The following section contains additional +details regarding the issue of byte ordering. + +@node Effect of Bit_Order on Byte Ordering +@section Effect of Bit_Order on Byte Ordering +@cindex byte ordering +@cindex ordering, of bytes + +@noindent +In this section we will review the effect of the @code{Bit_Order} attribute +definition clause on byte ordering. Briefly, it has no effect at all, but +a detailed example will be helpful. Before giving this +example, let us review the precise +definition of the effect of defining @code{Bit_Order}. The effect of a +non-standard bit order is described in section 15.5.3 of the Ada +Reference Manual: + +@quotation +2 A bit ordering is a method of interpreting the meaning of +the storage place attributes. +@end quotation + +@noindent +To understand the precise definition of storage place attributes in +this context, we visit section 13.5.1 of the manual: + +@quotation +13 A record_representation_clause (without the mod_clause) +specifies the layout. The storage place attributes (see 13.5.2) +are taken from the values of the position, first_bit, and last_bit +expressions after normalizing those values so that first_bit is +less than Storage_Unit. +@end quotation + +@noindent +The critical point here is that storage places are taken from +the values after normalization, not before. So the @code{Bit_Order} +interpretation applies to normalized values. The interpretation +is described in the later part of the 15.5.3 paragraph: + +@quotation +2 A bit ordering is a method of interpreting the meaning of +the storage place attributes. High_Order_First (known in the +vernacular as ``big endian'') means that the first bit of a +storage element (bit 0) is the most significant bit (interpreting +the sequence of bits that represent a component as an unsigned +integer value). Low_Order_First (known in the vernacular as +``little endian'') means the opposite: the first bit is the +least significant. +@end quotation + +@noindent +Note that the numbering is with respect to the bits of a storage +unit. In other words, the specification affects only the numbering +of bits within a single storage unit. + +We can make the effect clearer by giving an example. + +Suppose that we have an external device which presents two bytes, the first +byte presented, which is the first (low addressed byte) of the two byte +record is called Master, and the second byte is called Slave. + +The left most (most significant bit is called Control for each byte, and +the remaining 7 bits are called V1, V2, @dots{} V7, where V7 is the rightmost +(least significant) bit. + +On a big-endian machine, we can write the following representation clause + +@smallexample @c ada + type Data is record + Master_Control : Bit; + Master_V1 : Bit; + Master_V2 : Bit; + Master_V3 : Bit; + Master_V4 : Bit; + Master_V5 : Bit; + Master_V6 : Bit; + Master_V7 : Bit; + Slave_Control : Bit; + Slave_V1 : Bit; + Slave_V2 : Bit; + Slave_V3 : Bit; + Slave_V4 : Bit; + Slave_V5 : Bit; + Slave_V6 : Bit; + Slave_V7 : Bit; + end record; + + for Data use record + Master_Control at 0 range 0 .. 0; + Master_V1 at 0 range 1 .. 1; + Master_V2 at 0 range 2 .. 2; + Master_V3 at 0 range 3 .. 3; + Master_V4 at 0 range 4 .. 4; + Master_V5 at 0 range 5 .. 5; + Master_V6 at 0 range 6 .. 6; + Master_V7 at 0 range 7 .. 7; + Slave_Control at 1 range 0 .. 0; + Slave_V1 at 1 range 1 .. 1; + Slave_V2 at 1 range 2 .. 2; + Slave_V3 at 1 range 3 .. 3; + Slave_V4 at 1 range 4 .. 4; + Slave_V5 at 1 range 5 .. 5; + Slave_V6 at 1 range 6 .. 6; + Slave_V7 at 1 range 7 .. 7; + end record; +@end smallexample + +@noindent +Now if we move this to a little endian machine, then the bit ordering within +the byte is backwards, so we have to rewrite the record rep clause as: + +@smallexample @c ada + for Data use record + Master_Control at 0 range 7 .. 7; + Master_V1 at 0 range 6 .. 6; + Master_V2 at 0 range 5 .. 5; + Master_V3 at 0 range 4 .. 4; + Master_V4 at 0 range 3 .. 3; + Master_V5 at 0 range 2 .. 2; + Master_V6 at 0 range 1 .. 1; + Master_V7 at 0 range 0 .. 0; + Slave_Control at 1 range 7 .. 7; + Slave_V1 at 1 range 6 .. 6; + Slave_V2 at 1 range 5 .. 5; + Slave_V3 at 1 range 4 .. 4; + Slave_V4 at 1 range 3 .. 3; + Slave_V5 at 1 range 2 .. 2; + Slave_V6 at 1 range 1 .. 1; + Slave_V7 at 1 range 0 .. 0; + end record; +@end smallexample + +@noindent +It is a nuisance to have to rewrite the clause, especially if +the code has to be maintained on both machines. However, +this is a case that we can handle with the +@code{Bit_Order} attribute if it is implemented. +Note that the implementation is not required on byte addressed +machines, but it is indeed implemented in GNAT. +This means that we can simply use the +first record clause, together with the declaration + +@smallexample @c ada + for Data'Bit_Order use High_Order_First; +@end smallexample + +@noindent +and the effect is what is desired, namely the layout is exactly the same, +independent of whether the code is compiled on a big-endian or little-endian +machine. + +The important point to understand is that byte ordering is not affected. +A @code{Bit_Order} attribute definition never affects which byte a field +ends up in, only where it ends up in that byte. +To make this clear, let us rewrite the record rep clause of the previous +example as: + +@smallexample @c ada + for Data'Bit_Order use High_Order_First; + for Data use record + Master_Control at 0 range 0 .. 0; + Master_V1 at 0 range 1 .. 1; + Master_V2 at 0 range 2 .. 2; + Master_V3 at 0 range 3 .. 3; + Master_V4 at 0 range 4 .. 4; + Master_V5 at 0 range 5 .. 5; + Master_V6 at 0 range 6 .. 6; + Master_V7 at 0 range 7 .. 7; + Slave_Control at 0 range 8 .. 8; + Slave_V1 at 0 range 9 .. 9; + Slave_V2 at 0 range 10 .. 10; + Slave_V3 at 0 range 11 .. 11; + Slave_V4 at 0 range 12 .. 12; + Slave_V5 at 0 range 13 .. 13; + Slave_V6 at 0 range 14 .. 14; + Slave_V7 at 0 range 15 .. 15; + end record; +@end smallexample + +@noindent +This is exactly equivalent to saying (a repeat of the first example): + +@smallexample @c ada + for Data'Bit_Order use High_Order_First; + for Data use record + Master_Control at 0 range 0 .. 0; + Master_V1 at 0 range 1 .. 1; + Master_V2 at 0 range 2 .. 2; + Master_V3 at 0 range 3 .. 3; + Master_V4 at 0 range 4 .. 4; + Master_V5 at 0 range 5 .. 5; + Master_V6 at 0 range 6 .. 6; + Master_V7 at 0 range 7 .. 7; + Slave_Control at 1 range 0 .. 0; + Slave_V1 at 1 range 1 .. 1; + Slave_V2 at 1 range 2 .. 2; + Slave_V3 at 1 range 3 .. 3; + Slave_V4 at 1 range 4 .. 4; + Slave_V5 at 1 range 5 .. 5; + Slave_V6 at 1 range 6 .. 6; + Slave_V7 at 1 range 7 .. 7; + end record; +@end smallexample + +@noindent +Why are they equivalent? Well take a specific field, the @code{Slave_V2} +field. The storage place attributes are obtained by normalizing the +values given so that the @code{First_Bit} value is less than 8. After +normalizing the values (0,10,10) we get (1,2,2) which is exactly what +we specified in the other case. + +Now one might expect that the @code{Bit_Order} attribute might affect +bit numbering within the entire record component (two bytes in this +case, thus affecting which byte fields end up in), but that is not +the way this feature is defined, it only affects numbering of bits, +not which byte they end up in. + +Consequently it never makes sense to specify a starting bit number +greater than 7 (for a byte addressable field) if an attribute +definition for @code{Bit_Order} has been given, and indeed it +may be actively confusing to specify such a value, so the compiler +generates a warning for such usage. + +If you do need to control byte ordering then appropriate conditional +values must be used. If in our example, the slave byte came first on +some machines we might write: + +@smallexample @c ada + Master_Byte_First constant Boolean := @dots{}; + + Master_Byte : constant Natural := + 1 - Boolean'Pos (Master_Byte_First); + Slave_Byte : constant Natural := + Boolean'Pos (Master_Byte_First); + + for Data'Bit_Order use High_Order_First; + for Data use record + Master_Control at Master_Byte range 0 .. 0; + Master_V1 at Master_Byte range 1 .. 1; + Master_V2 at Master_Byte range 2 .. 2; + Master_V3 at Master_Byte range 3 .. 3; + Master_V4 at Master_Byte range 4 .. 4; + Master_V5 at Master_Byte range 5 .. 5; + Master_V6 at Master_Byte range 6 .. 6; + Master_V7 at Master_Byte range 7 .. 7; + Slave_Control at Slave_Byte range 0 .. 0; + Slave_V1 at Slave_Byte range 1 .. 1; + Slave_V2 at Slave_Byte range 2 .. 2; + Slave_V3 at Slave_Byte range 3 .. 3; + Slave_V4 at Slave_Byte range 4 .. 4; + Slave_V5 at Slave_Byte range 5 .. 5; + Slave_V6 at Slave_Byte range 6 .. 6; + Slave_V7 at Slave_Byte range 7 .. 7; + end record; +@end smallexample + +@noindent +Now to switch between machines, all that is necessary is +to set the boolean constant @code{Master_Byte_First} in +an appropriate manner. + +@node Pragma Pack for Arrays +@section Pragma Pack for Arrays +@cindex Pragma Pack (for arrays) + +@noindent +Pragma @code{Pack} applied to an array has no effect unless the component type +is packable. For a component type to be packable, it must be one of the +following cases: + +@itemize @bullet +@item +Any scalar type +@item +Any type whose size is specified with a size clause +@item +Any packed array type with a static size +@item +Any record type padded because of its default alignment +@end itemize + +@noindent +For all these cases, if the component subtype size is in the range +1 through 63, then the effect of the pragma @code{Pack} is exactly as though a +component size were specified giving the component subtype size. +For example if we have: + +@smallexample @c ada + type r is range 0 .. 17; + + type ar is array (1 .. 8) of r; + pragma Pack (ar); +@end smallexample + +@noindent +Then the component size of @code{ar} will be set to 5 (i.e.@: to @code{r'size}, +and the size of the array @code{ar} will be exactly 40 bits. + +Note that in some cases this rather fierce approach to packing can produce +unexpected effects. For example, in Ada 95 and Ada 2005, +subtype @code{Natural} typically has a size of 31, meaning that if you +pack an array of @code{Natural}, you get 31-bit +close packing, which saves a few bits, but results in far less efficient +access. Since many other Ada compilers will ignore such a packing request, +GNAT will generate a warning on some uses of pragma @code{Pack} that it guesses +might not be what is intended. You can easily remove this warning by +using an explicit @code{Component_Size} setting instead, which never generates +a warning, since the intention of the programmer is clear in this case. + +GNAT treats packed arrays in one of two ways. If the size of the array is +known at compile time and is less than 64 bits, then internally the array +is represented as a single modular type, of exactly the appropriate number +of bits. If the length is greater than 63 bits, or is not known at compile +time, then the packed array is represented as an array of bytes, and the +length is always a multiple of 8 bits. + +Note that to represent a packed array as a modular type, the alignment must +be suitable for the modular type involved. For example, on typical machines +a 32-bit packed array will be represented by a 32-bit modular integer with +an alignment of four bytes. If you explicitly override the default alignment +with an alignment clause that is too small, the modular representation +cannot be used. For example, consider the following set of declarations: + +@smallexample @c ada + type R is range 1 .. 3; + type S is array (1 .. 31) of R; + for S'Component_Size use 2; + for S'Size use 62; + for S'Alignment use 1; +@end smallexample + +@noindent +If the alignment clause were not present, then a 62-bit modular +representation would be chosen (typically with an alignment of 4 or 8 +bytes depending on the target). But the default alignment is overridden +with the explicit alignment clause. This means that the modular +representation cannot be used, and instead the array of bytes +representation must be used, meaning that the length must be a multiple +of 8. Thus the above set of declarations will result in a diagnostic +rejecting the size clause and noting that the minimum size allowed is 64. + +@cindex Pragma Pack (for type Natural) +@cindex Pragma Pack warning + +One special case that is worth noting occurs when the base type of the +component size is 8/16/32 and the subtype is one bit less. Notably this +occurs with subtype @code{Natural}. Consider: + +@smallexample @c ada + type Arr is array (1 .. 32) of Natural; + pragma Pack (Arr); +@end smallexample + +@noindent +In all commonly used Ada 83 compilers, this pragma Pack would be ignored, +since typically @code{Natural'Size} is 32 in Ada 83, and in any case most +Ada 83 compilers did not attempt 31 bit packing. + +In Ada 95 and Ada 2005, @code{Natural'Size} is required to be 31. Furthermore, +GNAT really does pack 31-bit subtype to 31 bits. This may result in a +substantial unintended performance penalty when porting legacy Ada 83 code. +To help prevent this, GNAT generates a warning in such cases. If you really +want 31 bit packing in a case like this, you can set the component size +explicitly: + +@smallexample @c ada + type Arr is array (1 .. 32) of Natural; + for Arr'Component_Size use 31; +@end smallexample + +@noindent +Here 31-bit packing is achieved as required, and no warning is generated, +since in this case the programmer intention is clear. + +@node Pragma Pack for Records +@section Pragma Pack for Records +@cindex Pragma Pack (for records) + +@noindent +Pragma @code{Pack} applied to a record will pack the components to reduce +wasted space from alignment gaps and by reducing the amount of space +taken by components. We distinguish between @emph{packable} components and +@emph{non-packable} components. +Components of the following types are considered packable: +@itemize @bullet +@item +All primitive types are packable. + +@item +Small packed arrays, whose size does not exceed 64 bits, and where the +size is statically known at compile time, are represented internally +as modular integers, and so they are also packable. + +@end itemize + +@noindent +All packable components occupy the exact number of bits corresponding to +their @code{Size} value, and are packed with no padding bits, i.e.@: they +can start on an arbitrary bit boundary. + +All other types are non-packable, they occupy an integral number of +storage units, and +are placed at a boundary corresponding to their alignment requirements. + +For example, consider the record + +@smallexample @c ada + type Rb1 is array (1 .. 13) of Boolean; + pragma Pack (rb1); + + type Rb2 is array (1 .. 65) of Boolean; + pragma Pack (rb2); + + type x2 is record + l1 : Boolean; + l2 : Duration; + l3 : Float; + l4 : Boolean; + l5 : Rb1; + l6 : Rb2; + end record; + pragma Pack (x2); +@end smallexample + +@noindent +The representation for the record x2 is as follows: + +@smallexample @c ada +for x2'Size use 224; +for x2 use record + l1 at 0 range 0 .. 0; + l2 at 0 range 1 .. 64; + l3 at 12 range 0 .. 31; + l4 at 16 range 0 .. 0; + l5 at 16 range 1 .. 13; + l6 at 18 range 0 .. 71; +end record; +@end smallexample + +@noindent +Studying this example, we see that the packable fields @code{l1} +and @code{l2} are +of length equal to their sizes, and placed at specific bit boundaries (and +not byte boundaries) to +eliminate padding. But @code{l3} is of a non-packable float type, so +it is on the next appropriate alignment boundary. + +The next two fields are fully packable, so @code{l4} and @code{l5} are +minimally packed with no gaps. However, type @code{Rb2} is a packed +array that is longer than 64 bits, so it is itself non-packable. Thus +the @code{l6} field is aligned to the next byte boundary, and takes an +integral number of bytes, i.e.@: 72 bits. + +@node Record Representation Clauses +@section Record Representation Clauses +@cindex Record Representation Clause + +@noindent +Record representation clauses may be given for all record types, including +types obtained by record extension. Component clauses are allowed for any +static component. The restrictions on component clauses depend on the type +of the component. + +@cindex Component Clause +For all components of an elementary type, the only restriction on component +clauses is that the size must be at least the 'Size value of the type +(actually the Value_Size). There are no restrictions due to alignment, +and such components may freely cross storage boundaries. + +Packed arrays with a size up to and including 64 bits are represented +internally using a modular type with the appropriate number of bits, and +thus the same lack of restriction applies. For example, if you declare: + +@smallexample @c ada + type R is array (1 .. 49) of Boolean; + pragma Pack (R); + for R'Size use 49; +@end smallexample + +@noindent +then a component clause for a component of type R may start on any +specified bit boundary, and may specify a value of 49 bits or greater. + +For packed bit arrays that are longer than 64 bits, there are two +cases. If the component size is a power of 2 (1,2,4,8,16,32 bits), +including the important case of single bits or boolean values, then +there are no limitations on placement of such components, and they +may start and end at arbitrary bit boundaries. + +If the component size is not a power of 2 (e.g.@: 3 or 5), then +an array of this type longer than 64 bits must always be placed on +on a storage unit (byte) boundary and occupy an integral number +of storage units (bytes). Any component clause that does not +meet this requirement will be rejected. + +Any aliased component, or component of an aliased type, must +have its normal alignment and size. A component clause that +does not meet this requirement will be rejected. + +The tag field of a tagged type always occupies an address sized field at +the start of the record. No component clause may attempt to overlay this +tag. When a tagged type appears as a component, the tag field must have +proper alignment + +In the case of a record extension T1, of a type T, no component clause applied +to the type T1 can specify a storage location that would overlap the first +T'Size bytes of the record. + +For all other component types, including non-bit-packed arrays, +the component can be placed at an arbitrary bit boundary, +so for example, the following is permitted: + +@smallexample @c ada + type R is array (1 .. 10) of Boolean; + for R'Size use 80; + + type Q is record + G, H : Boolean; + L, M : R; + end record; + + for Q use record + G at 0 range 0 .. 0; + H at 0 range 1 .. 1; + L at 0 range 2 .. 81; + R at 0 range 82 .. 161; + end record; +@end smallexample + +@noindent +Note: the above rules apply to recent releases of GNAT 5. +In GNAT 3, there are more severe restrictions on larger components. +For non-primitive types, including packed arrays with a size greater than +64 bits, component clauses must respect the alignment requirement of the +type, in particular, always starting on a byte boundary, and the length +must be a multiple of the storage unit. + +@node Enumeration Clauses +@section Enumeration Clauses + +The only restriction on enumeration clauses is that the range of values +must be representable. For the signed case, if one or more of the +representation values are negative, all values must be in the range: + +@smallexample @c ada + System.Min_Int .. System.Max_Int +@end smallexample + +@noindent +For the unsigned case, where all values are nonnegative, the values must +be in the range: + +@smallexample @c ada + 0 .. System.Max_Binary_Modulus; +@end smallexample + +@noindent +A @emph{confirming} representation clause is one in which the values range +from 0 in sequence, i.e.@: a clause that confirms the default representation +for an enumeration type. +Such a confirming representation +is permitted by these rules, and is specially recognized by the compiler so +that no extra overhead results from the use of such a clause. + +If an array has an index type which is an enumeration type to which an +enumeration clause has been applied, then the array is stored in a compact +manner. Consider the declarations: + +@smallexample @c ada + type r is (A, B, C); + for r use (A => 1, B => 5, C => 10); + type t is array (r) of Character; +@end smallexample + +@noindent +The array type t corresponds to a vector with exactly three elements and +has a default size equal to @code{3*Character'Size}. This ensures efficient +use of space, but means that accesses to elements of the array will incur +the overhead of converting representation values to the corresponding +positional values, (i.e.@: the value delivered by the @code{Pos} attribute). + +@node Address Clauses +@section Address Clauses +@cindex Address Clause + +The reference manual allows a general restriction on representation clauses, +as found in RM 13.1(22): + +@quotation +An implementation need not support representation +items containing nonstatic expressions, except that +an implementation should support a representation item +for a given entity if each nonstatic expression in the +representation item is a name that statically denotes +a constant declared before the entity. +@end quotation + +@noindent +In practice this is applicable only to address clauses, since this is the +only case in which a non-static expression is permitted by the syntax. As +the AARM notes in sections 13.1 (22.a-22.h): + +@display + 22.a Reason: This is to avoid the following sort of thing: + + 22.b X : Integer := F(@dots{}); + Y : Address := G(@dots{}); + for X'Address use Y; + + 22.c In the above, we have to evaluate the + initialization expression for X before we + know where to put the result. This seems + like an unreasonable implementation burden. + + 22.d The above code should instead be written + like this: + + 22.e Y : constant Address := G(@dots{}); + X : Integer := F(@dots{}); + for X'Address use Y; + + 22.f This allows the expression ``Y'' to be safely + evaluated before X is created. + + 22.g The constant could be a formal parameter of mode in. + + 22.h An implementation can support other nonstatic + expressions if it wants to. Expressions of type + Address are hardly ever static, but their value + might be known at compile time anyway in many + cases. +@end display + +@noindent +GNAT does indeed permit many additional cases of non-static expressions. In +particular, if the type involved is elementary there are no restrictions +(since in this case, holding a temporary copy of the initialization value, +if one is present, is inexpensive). In addition, if there is no implicit or +explicit initialization, then there are no restrictions. GNAT will reject +only the case where all three of these conditions hold: + +@itemize @bullet + +@item +The type of the item is non-elementary (e.g.@: a record or array). + +@item +There is explicit or implicit initialization required for the object. +Note that access values are always implicitly initialized, and also +in GNAT, certain bit-packed arrays (those having a dynamic length or +a length greater than 64) will also be implicitly initialized to zero. + +@item +The address value is non-static. Here GNAT is more permissive than the +RM, and allows the address value to be the address of a previously declared +stand-alone variable, as long as it does not itself have an address clause. + +@smallexample @c ada + Anchor : Some_Initialized_Type; + Overlay : Some_Initialized_Type; + for Overlay'Address use Anchor'Address; +@end smallexample + +@noindent +However, the prefix of the address clause cannot be an array component, or +a component of a discriminated record. + +@end itemize + +@noindent +As noted above in section 22.h, address values are typically non-static. In +particular the To_Address function, even if applied to a literal value, is +a non-static function call. To avoid this minor annoyance, GNAT provides +the implementation defined attribute 'To_Address. The following two +expressions have identical values: + +@findex Attribute +@findex To_Address +@smallexample @c ada + To_Address (16#1234_0000#) + System'To_Address (16#1234_0000#); +@end smallexample + +@noindent +except that the second form is considered to be a static expression, and +thus when used as an address clause value is always permitted. + +@noindent +Additionally, GNAT treats as static an address clause that is an +unchecked_conversion of a static integer value. This simplifies the porting +of legacy code, and provides a portable equivalent to the GNAT attribute +@code{To_Address}. + +Another issue with address clauses is the interaction with alignment +requirements. When an address clause is given for an object, the address +value must be consistent with the alignment of the object (which is usually +the same as the alignment of the type of the object). If an address clause +is given that specifies an inappropriately aligned address value, then the +program execution is erroneous. + +Since this source of erroneous behavior can have unfortunate effects, GNAT +checks (at compile time if possible, generating a warning, or at execution +time with a run-time check) that the alignment is appropriate. If the +run-time check fails, then @code{Program_Error} is raised. This run-time +check is suppressed if range checks are suppressed, or if the special GNAT +check Alignment_Check is suppressed, or if +@code{pragma Restrictions (No_Elaboration_Code)} is in effect. + +Finally, GNAT does not permit overlaying of objects of controlled types or +composite types containing a controlled component. In most cases, the compiler +can detect an attempt at such overlays and will generate a warning at compile +time and a Program_Error exception at run time. + +@findex Export +An address clause cannot be given for an exported object. More +understandably the real restriction is that objects with an address +clause cannot be exported. This is because such variables are not +defined by the Ada program, so there is no external object to export. + +@findex Import +It is permissible to give an address clause and a pragma Import for the +same object. In this case, the variable is not really defined by the +Ada program, so there is no external symbol to be linked. The link name +and the external name are ignored in this case. The reason that we allow this +combination is that it provides a useful idiom to avoid unwanted +initializations on objects with address clauses. + +When an address clause is given for an object that has implicit or +explicit initialization, then by default initialization takes place. This +means that the effect of the object declaration is to overwrite the +memory at the specified address. This is almost always not what the +programmer wants, so GNAT will output a warning: + +@smallexample + with System; + package G is + type R is record + M : Integer := 0; + end record; + + Ext : R; + for Ext'Address use System'To_Address (16#1234_1234#); + | + >>> warning: implicit initialization of "Ext" may + modify overlaid storage + >>> warning: use pragma Import for "Ext" to suppress + initialization (RM B(24)) + + end G; +@end smallexample + +@noindent +As indicated by the warning message, the solution is to use a (dummy) pragma +Import to suppress this initialization. The pragma tell the compiler that the +object is declared and initialized elsewhere. The following package compiles +without warnings (and the initialization is suppressed): + +@smallexample @c ada + with System; + package G is + type R is record + M : Integer := 0; + end record; + + Ext : R; + for Ext'Address use System'To_Address (16#1234_1234#); + pragma Import (Ada, Ext); + end G; +@end smallexample + +@noindent +A final issue with address clauses involves their use for overlaying +variables, as in the following example: +@cindex Overlaying of objects + +@smallexample @c ada + A : Integer; + B : Integer; + for B'Address use A'Address; +@end smallexample + +@noindent +or alternatively, using the form recommended by the RM: + +@smallexample @c ada + A : Integer; + Addr : constant Address := A'Address; + B : Integer; + for B'Address use Addr; +@end smallexample + +@noindent +In both of these cases, @code{A} +and @code{B} become aliased to one another via the +address clause. This use of address clauses to overlay +variables, achieving an effect similar to unchecked +conversion was erroneous in Ada 83, but in Ada 95 and Ada 2005 +the effect is implementation defined. Furthermore, the +Ada RM specifically recommends that in a situation +like this, @code{B} should be subject to the following +implementation advice (RM 13.3(19)): + +@quotation +19 If the Address of an object is specified, or it is imported + or exported, then the implementation should not perform + optimizations based on assumptions of no aliases. +@end quotation + +@noindent +GNAT follows this recommendation, and goes further by also applying +this recommendation to the overlaid variable (@code{A} +in the above example) in this case. This means that the overlay +works "as expected", in that a modification to one of the variables +will affect the value of the other. + +@node Effect of Convention on Representation +@section Effect of Convention on Representation +@cindex Convention, effect on representation + +@noindent +Normally the specification of a foreign language convention for a type or +an object has no effect on the chosen representation. In particular, the +representation chosen for data in GNAT generally meets the standard system +conventions, and for example records are laid out in a manner that is +consistent with C@. This means that specifying convention C (for example) +has no effect. + +There are four exceptions to this general rule: + +@itemize @bullet + +@item Convention Fortran and array subtypes +If pragma Convention Fortran is specified for an array subtype, then in +accordance with the implementation advice in section 3.6.2(11) of the +Ada Reference Manual, the array will be stored in a Fortran-compatible +column-major manner, instead of the normal default row-major order. + +@item Convention C and enumeration types +GNAT normally stores enumeration types in 8, 16, or 32 bits as required +to accommodate all values of the type. For example, for the enumeration +type declared by: + +@smallexample @c ada + type Color is (Red, Green, Blue); +@end smallexample + +@noindent +8 bits is sufficient to store all values of the type, so by default, objects +of type @code{Color} will be represented using 8 bits. However, normal C +convention is to use 32 bits for all enum values in C, since enum values +are essentially of type int. If pragma @code{Convention C} is specified for an +Ada enumeration type, then the size is modified as necessary (usually to +32 bits) to be consistent with the C convention for enum values. + +Note that this treatment applies only to types. If Convention C is given for +an enumeration object, where the enumeration type is not Convention C, then +Object_Size bits are allocated. For example, for a normal enumeration type, +with less than 256 elements, only 8 bits will be allocated for the object. +Since this may be a surprise in terms of what C expects, GNAT will issue a +warning in this situation. The warning can be suppressed by giving an explicit +size clause specifying the desired size. + +@item Convention C/Fortran and Boolean types +In C, the usual convention for boolean values, that is values used for +conditions, is that zero represents false, and nonzero values represent +true. In Ada, the normal convention is that two specific values, typically +0/1, are used to represent false/true respectively. + +Fortran has a similar convention for @code{LOGICAL} values (any nonzero +value represents true). + +To accommodate the Fortran and C conventions, if a pragma Convention specifies +C or Fortran convention for a derived Boolean, as in the following example: + +@smallexample @c ada + type C_Switch is new Boolean; + pragma Convention (C, C_Switch); +@end smallexample + +@noindent +then the GNAT generated code will treat any nonzero value as true. For truth +values generated by GNAT, the conventional value 1 will be used for True, but +when one of these values is read, any nonzero value is treated as True. + +@item Access types on OpenVMS +For 64-bit OpenVMS systems, access types (other than those for unconstrained +arrays) are 64-bits long. An exception to this rule is for the case of +C-convention access types where there is no explicit size clause present (or +inherited for derived types). In this case, GNAT chooses to make these +pointers 32-bits, which provides an easier path for migration of 32-bit legacy +code. size clause specifying 64-bits must be used to obtain a 64-bit pointer. + +@end itemize + +@node Determining the Representations chosen by GNAT +@section Determining the Representations chosen by GNAT +@cindex Representation, determination of +@cindex @option{-gnatR} switch + +@noindent +Although the descriptions in this section are intended to be complete, it is +often easier to simply experiment to see what GNAT accepts and what the +effect is on the layout of types and objects. + +As required by the Ada RM, if a representation clause is not accepted, then +it must be rejected as illegal by the compiler. However, when a +representation clause or pragma is accepted, there can still be questions +of what the compiler actually does. For example, if a partial record +representation clause specifies the location of some components and not +others, then where are the non-specified components placed? Or if pragma +@code{Pack} is used on a record, then exactly where are the resulting +fields placed? The section on pragma @code{Pack} in this chapter can be +used to answer the second question, but it is often easier to just see +what the compiler does. + +For this purpose, GNAT provides the option @option{-gnatR}. If you compile +with this option, then the compiler will output information on the actual +representations chosen, in a format similar to source representation +clauses. For example, if we compile the package: + +@smallexample @c ada +package q is + type r (x : boolean) is tagged record + case x is + when True => S : String (1 .. 100); + when False => null; + end case; + end record; + + type r2 is new r (false) with record + y2 : integer; + end record; + + for r2 use record + y2 at 16 range 0 .. 31; + end record; + + type x is record + y : character; + end record; + + type x1 is array (1 .. 10) of x; + for x1'component_size use 11; + + type ia is access integer; + + type Rb1 is array (1 .. 13) of Boolean; + pragma Pack (rb1); + + type Rb2 is array (1 .. 65) of Boolean; + pragma Pack (rb2); + + type x2 is record + l1 : Boolean; + l2 : Duration; + l3 : Float; + l4 : Boolean; + l5 : Rb1; + l6 : Rb2; + end record; + pragma Pack (x2); +end q; +@end smallexample + +@noindent +using the switch @option{-gnatR} we obtain the following output: + +@smallexample +Representation information for unit q +------------------------------------- + +for r'Size use ??; +for r'Alignment use 4; +for r use record + x at 4 range 0 .. 7; + _tag at 0 range 0 .. 31; + s at 5 range 0 .. 799; +end record; + +for r2'Size use 160; +for r2'Alignment use 4; +for r2 use record + x at 4 range 0 .. 7; + _tag at 0 range 0 .. 31; + _parent at 0 range 0 .. 63; + y2 at 16 range 0 .. 31; +end record; + +for x'Size use 8; +for x'Alignment use 1; +for x use record + y at 0 range 0 .. 7; +end record; + +for x1'Size use 112; +for x1'Alignment use 1; +for x1'Component_Size use 11; + +for rb1'Size use 13; +for rb1'Alignment use 2; +for rb1'Component_Size use 1; + +for rb2'Size use 72; +for rb2'Alignment use 1; +for rb2'Component_Size use 1; + +for x2'Size use 224; +for x2'Alignment use 4; +for x2 use record + l1 at 0 range 0 .. 0; + l2 at 0 range 1 .. 64; + l3 at 12 range 0 .. 31; + l4 at 16 range 0 .. 0; + l5 at 16 range 1 .. 13; + l6 at 18 range 0 .. 71; +end record; +@end smallexample + +@noindent +The Size values are actually the Object_Size, i.e.@: the default size that +will be allocated for objects of the type. +The ?? size for type r indicates that we have a variant record, and the +actual size of objects will depend on the discriminant value. + +The Alignment values show the actual alignment chosen by the compiler +for each record or array type. + +The record representation clause for type r shows where all fields +are placed, including the compiler generated tag field (whose location +cannot be controlled by the programmer). + +The record representation clause for the type extension r2 shows all the +fields present, including the parent field, which is a copy of the fields +of the parent type of r2, i.e.@: r1. + +The component size and size clauses for types rb1 and rb2 show +the exact effect of pragma @code{Pack} on these arrays, and the record +representation clause for type x2 shows how pragma @code{Pack} affects +this record type. + +In some cases, it may be useful to cut and paste the representation clauses +generated by the compiler into the original source to fix and guarantee +the actual representation to be used. + +@node Standard Library Routines +@chapter Standard Library Routines + +@noindent +The Ada Reference Manual contains in Annex A a full description of an +extensive set of standard library routines that can be used in any Ada +program, and which must be provided by all Ada compilers. They are +analogous to the standard C library used by C programs. + +GNAT implements all of the facilities described in annex A, and for most +purposes the description in the Ada Reference Manual, or appropriate Ada +text book, will be sufficient for making use of these facilities. + +In the case of the input-output facilities, +@xref{The Implementation of Standard I/O}, +gives details on exactly how GNAT interfaces to the +file system. For the remaining packages, the Ada Reference Manual +should be sufficient. The following is a list of the packages included, +together with a brief description of the functionality that is provided. + +For completeness, references are included to other predefined library +routines defined in other sections of the Ada Reference Manual (these are +cross-indexed from Annex A). + +@table @code +@item Ada (A.2) +This is a parent package for all the standard library packages. It is +usually included implicitly in your program, and itself contains no +useful data or routines. + +@item Ada.Calendar (9.6) +@code{Calendar} provides time of day access, and routines for +manipulating times and durations. + +@item Ada.Characters (A.3.1) +This is a dummy parent package that contains no useful entities + +@item Ada.Characters.Handling (A.3.2) +This package provides some basic character handling capabilities, +including classification functions for classes of characters (e.g.@: test +for letters, or digits). + +@item Ada.Characters.Latin_1 (A.3.3) +This package includes a complete set of definitions of the characters +that appear in type CHARACTER@. It is useful for writing programs that +will run in international environments. For example, if you want an +upper case E with an acute accent in a string, it is often better to use +the definition of @code{UC_E_Acute} in this package. Then your program +will print in an understandable manner even if your environment does not +support these extended characters. + +@item Ada.Command_Line (A.15) +This package provides access to the command line parameters and the name +of the current program (analogous to the use of @code{argc} and @code{argv} +in C), and also allows the exit status for the program to be set in a +system-independent manner. + +@item Ada.Decimal (F.2) +This package provides constants describing the range of decimal numbers +implemented, and also a decimal divide routine (analogous to the COBOL +verb DIVIDE @dots{} GIVING @dots{} REMAINDER @dots{}) + +@item Ada.Direct_IO (A.8.4) +This package provides input-output using a model of a set of records of +fixed-length, containing an arbitrary definite Ada type, indexed by an +integer record number. + +@item Ada.Dynamic_Priorities (D.5) +This package allows the priorities of a task to be adjusted dynamically +as the task is running. + +@item Ada.Exceptions (11.4.1) +This package provides additional information on exceptions, and also +contains facilities for treating exceptions as data objects, and raising +exceptions with associated messages. + +@item Ada.Finalization (7.6) +This package contains the declarations and subprograms to support the +use of controlled types, providing for automatic initialization and +finalization (analogous to the constructors and destructors of C++) + +@item Ada.Interrupts (C.3.2) +This package provides facilities for interfacing to interrupts, which +includes the set of signals or conditions that can be raised and +recognized as interrupts. + +@item Ada.Interrupts.Names (C.3.2) +This package provides the set of interrupt names (actually signal +or condition names) that can be handled by GNAT@. + +@item Ada.IO_Exceptions (A.13) +This package defines the set of exceptions that can be raised by use of +the standard IO packages. + +@item Ada.Numerics +This package contains some standard constants and exceptions used +throughout the numerics packages. Note that the constants pi and e are +defined here, and it is better to use these definitions than rolling +your own. + +@item Ada.Numerics.Complex_Elementary_Functions +Provides the implementation of standard elementary functions (such as +log and trigonometric functions) operating on complex numbers using the +standard @code{Float} and the @code{Complex} and @code{Imaginary} types +created by the package @code{Numerics.Complex_Types}. + +@item Ada.Numerics.Complex_Types +This is a predefined instantiation of +@code{Numerics.Generic_Complex_Types} using @code{Standard.Float} to +build the type @code{Complex} and @code{Imaginary}. + +@item Ada.Numerics.Discrete_Random +This generic package provides a random number generator suitable for generating +uniformly distributed values of a specified discrete subtype. + +@item Ada.Numerics.Float_Random +This package provides a random number generator suitable for generating +uniformly distributed floating point values in the unit interval. + +@item Ada.Numerics.Generic_Complex_Elementary_Functions +This is a generic version of the package that provides the +implementation of standard elementary functions (such as log and +trigonometric functions) for an arbitrary complex type. + +The following predefined instantiations of this package are provided: + +@table @code +@item Short_Float +@code{Ada.Numerics.Short_Complex_Elementary_Functions} +@item Float +@code{Ada.Numerics.Complex_Elementary_Functions} +@item Long_Float +@code{Ada.Numerics.Long_Complex_Elementary_Functions} +@end table + +@item Ada.Numerics.Generic_Complex_Types +This is a generic package that allows the creation of complex types, +with associated complex arithmetic operations. + +The following predefined instantiations of this package exist +@table @code +@item Short_Float +@code{Ada.Numerics.Short_Complex_Complex_Types} +@item Float +@code{Ada.Numerics.Complex_Complex_Types} +@item Long_Float +@code{Ada.Numerics.Long_Complex_Complex_Types} +@end table + +@item Ada.Numerics.Generic_Elementary_Functions +This is a generic package that provides the implementation of standard +elementary functions (such as log an trigonometric functions) for an +arbitrary float type. + +The following predefined instantiations of this package exist + +@table @code +@item Short_Float +@code{Ada.Numerics.Short_Elementary_Functions} +@item Float +@code{Ada.Numerics.Elementary_Functions} +@item Long_Float +@code{Ada.Numerics.Long_Elementary_Functions} +@end table + +@item Ada.Real_Time (D.8) +This package provides facilities similar to those of @code{Calendar}, but +operating with a finer clock suitable for real time control. Note that +annex D requires that there be no backward clock jumps, and GNAT generally +guarantees this behavior, but of course if the external clock on which +the GNAT runtime depends is deliberately reset by some external event, +then such a backward jump may occur. + +@item Ada.Sequential_IO (A.8.1) +This package provides input-output facilities for sequential files, +which can contain a sequence of values of a single type, which can be +any Ada type, including indefinite (unconstrained) types. + +@item Ada.Storage_IO (A.9) +This package provides a facility for mapping arbitrary Ada types to and +from a storage buffer. It is primarily intended for the creation of new +IO packages. + +@item Ada.Streams (13.13.1) +This is a generic package that provides the basic support for the +concept of streams as used by the stream attributes (@code{Input}, +@code{Output}, @code{Read} and @code{Write}). + +@item Ada.Streams.Stream_IO (A.12.1) +This package is a specialization of the type @code{Streams} defined in +package @code{Streams} together with a set of operations providing +Stream_IO capability. The Stream_IO model permits both random and +sequential access to a file which can contain an arbitrary set of values +of one or more Ada types. + +@item Ada.Strings (A.4.1) +This package provides some basic constants used by the string handling +packages. + +@item Ada.Strings.Bounded (A.4.4) +This package provides facilities for handling variable length +strings. The bounded model requires a maximum length. It is thus +somewhat more limited than the unbounded model, but avoids the use of +dynamic allocation or finalization. + +@item Ada.Strings.Fixed (A.4.3) +This package provides facilities for handling fixed length strings. + +@item Ada.Strings.Maps (A.4.2) +This package provides facilities for handling character mappings and +arbitrarily defined subsets of characters. For instance it is useful in +defining specialized translation tables. + +@item Ada.Strings.Maps.Constants (A.4.6) +This package provides a standard set of predefined mappings and +predefined character sets. For example, the standard upper to lower case +conversion table is found in this package. Note that upper to lower case +conversion is non-trivial if you want to take the entire set of +characters, including extended characters like E with an acute accent, +into account. You should use the mappings in this package (rather than +adding 32 yourself) to do case mappings. + +@item Ada.Strings.Unbounded (A.4.5) +This package provides facilities for handling variable length +strings. The unbounded model allows arbitrary length strings, but +requires the use of dynamic allocation and finalization. + +@item Ada.Strings.Wide_Bounded (A.4.7) +@itemx Ada.Strings.Wide_Fixed (A.4.7) +@itemx Ada.Strings.Wide_Maps (A.4.7) +@itemx Ada.Strings.Wide_Maps.Constants (A.4.7) +@itemx Ada.Strings.Wide_Unbounded (A.4.7) +These packages provide analogous capabilities to the corresponding +packages without @samp{Wide_} in the name, but operate with the types +@code{Wide_String} and @code{Wide_Character} instead of @code{String} +and @code{Character}. + +@item Ada.Strings.Wide_Wide_Bounded (A.4.7) +@itemx Ada.Strings.Wide_Wide_Fixed (A.4.7) +@itemx Ada.Strings.Wide_Wide_Maps (A.4.7) +@itemx Ada.Strings.Wide_Wide_Maps.Constants (A.4.7) +@itemx Ada.Strings.Wide_Wide_Unbounded (A.4.7) +These packages provide analogous capabilities to the corresponding +packages without @samp{Wide_} in the name, but operate with the types +@code{Wide_Wide_String} and @code{Wide_Wide_Character} instead +of @code{String} and @code{Character}. + +@item Ada.Synchronous_Task_Control (D.10) +This package provides some standard facilities for controlling task +communication in a synchronous manner. + +@item Ada.Tags +This package contains definitions for manipulation of the tags of tagged +values. + +@item Ada.Task_Attributes +This package provides the capability of associating arbitrary +task-specific data with separate tasks. + +@item Ada.Text_IO +This package provides basic text input-output capabilities for +character, string and numeric data. The subpackages of this +package are listed next. + +@item Ada.Text_IO.Decimal_IO +Provides input-output facilities for decimal fixed-point types + +@item Ada.Text_IO.Enumeration_IO +Provides input-output facilities for enumeration types. + +@item Ada.Text_IO.Fixed_IO +Provides input-output facilities for ordinary fixed-point types. + +@item Ada.Text_IO.Float_IO +Provides input-output facilities for float types. The following +predefined instantiations of this generic package are available: + +@table @code +@item Short_Float +@code{Short_Float_Text_IO} +@item Float +@code{Float_Text_IO} +@item Long_Float +@code{Long_Float_Text_IO} +@end table + +@item Ada.Text_IO.Integer_IO +Provides input-output facilities for integer types. The following +predefined instantiations of this generic package are available: + +@table @code +@item Short_Short_Integer +@code{Ada.Short_Short_Integer_Text_IO} +@item Short_Integer +@code{Ada.Short_Integer_Text_IO} +@item Integer +@code{Ada.Integer_Text_IO} +@item Long_Integer +@code{Ada.Long_Integer_Text_IO} +@item Long_Long_Integer +@code{Ada.Long_Long_Integer_Text_IO} +@end table + +@item Ada.Text_IO.Modular_IO +Provides input-output facilities for modular (unsigned) types + +@item Ada.Text_IO.Complex_IO (G.1.3) +This package provides basic text input-output capabilities for complex +data. + +@item Ada.Text_IO.Editing (F.3.3) +This package contains routines for edited output, analogous to the use +of pictures in COBOL@. The picture formats used by this package are a +close copy of the facility in COBOL@. + +@item Ada.Text_IO.Text_Streams (A.12.2) +This package provides a facility that allows Text_IO files to be treated +as streams, so that the stream attributes can be used for writing +arbitrary data, including binary data, to Text_IO files. + +@item Ada.Unchecked_Conversion (13.9) +This generic package allows arbitrary conversion from one type to +another of the same size, providing for breaking the type safety in +special circumstances. + +If the types have the same Size (more accurately the same Value_Size), +then the effect is simply to transfer the bits from the source to the +target type without any modification. This usage is well defined, and +for simple types whose representation is typically the same across +all implementations, gives a portable method of performing such +conversions. + +If the types do not have the same size, then the result is implementation +defined, and thus may be non-portable. The following describes how GNAT +handles such unchecked conversion cases. + +If the types are of different sizes, and are both discrete types, then +the effect is of a normal type conversion without any constraint checking. +In particular if the result type has a larger size, the result will be +zero or sign extended. If the result type has a smaller size, the result +will be truncated by ignoring high order bits. + +If the types are of different sizes, and are not both discrete types, +then the conversion works as though pointers were created to the source +and target, and the pointer value is converted. The effect is that bits +are copied from successive low order storage units and bits of the source +up to the length of the target type. + +A warning is issued if the lengths differ, since the effect in this +case is implementation dependent, and the above behavior may not match +that of some other compiler. + +A pointer to one type may be converted to a pointer to another type using +unchecked conversion. The only case in which the effect is undefined is +when one or both pointers are pointers to unconstrained array types. In +this case, the bounds information may get incorrectly transferred, and in +particular, GNAT uses double size pointers for such types, and it is +meaningless to convert between such pointer types. GNAT will issue a +warning if the alignment of the target designated type is more strict +than the alignment of the source designated type (since the result may +be unaligned in this case). + +A pointer other than a pointer to an unconstrained array type may be +converted to and from System.Address. Such usage is common in Ada 83 +programs, but note that Ada.Address_To_Access_Conversions is the +preferred method of performing such conversions in Ada 95 and Ada 2005. +Neither +unchecked conversion nor Ada.Address_To_Access_Conversions should be +used in conjunction with pointers to unconstrained objects, since +the bounds information cannot be handled correctly in this case. + +@item Ada.Unchecked_Deallocation (13.11.2) +This generic package allows explicit freeing of storage previously +allocated by use of an allocator. + +@item Ada.Wide_Text_IO (A.11) +This package is similar to @code{Ada.Text_IO}, except that the external +file supports wide character representations, and the internal types are +@code{Wide_Character} and @code{Wide_String} instead of @code{Character} +and @code{String}. It contains generic subpackages listed next. + +@item Ada.Wide_Text_IO.Decimal_IO +Provides input-output facilities for decimal fixed-point types + +@item Ada.Wide_Text_IO.Enumeration_IO +Provides input-output facilities for enumeration types. + +@item Ada.Wide_Text_IO.Fixed_IO +Provides input-output facilities for ordinary fixed-point types. + +@item Ada.Wide_Text_IO.Float_IO +Provides input-output facilities for float types. The following +predefined instantiations of this generic package are available: + +@table @code +@item Short_Float +@code{Short_Float_Wide_Text_IO} +@item Float +@code{Float_Wide_Text_IO} +@item Long_Float +@code{Long_Float_Wide_Text_IO} +@end table + +@item Ada.Wide_Text_IO.Integer_IO +Provides input-output facilities for integer types. The following +predefined instantiations of this generic package are available: + +@table @code +@item Short_Short_Integer +@code{Ada.Short_Short_Integer_Wide_Text_IO} +@item Short_Integer +@code{Ada.Short_Integer_Wide_Text_IO} +@item Integer +@code{Ada.Integer_Wide_Text_IO} +@item Long_Integer +@code{Ada.Long_Integer_Wide_Text_IO} +@item Long_Long_Integer +@code{Ada.Long_Long_Integer_Wide_Text_IO} +@end table + +@item Ada.Wide_Text_IO.Modular_IO +Provides input-output facilities for modular (unsigned) types + +@item Ada.Wide_Text_IO.Complex_IO (G.1.3) +This package is similar to @code{Ada.Text_IO.Complex_IO}, except that the +external file supports wide character representations. + +@item Ada.Wide_Text_IO.Editing (F.3.4) +This package is similar to @code{Ada.Text_IO.Editing}, except that the +types are @code{Wide_Character} and @code{Wide_String} instead of +@code{Character} and @code{String}. + +@item Ada.Wide_Text_IO.Streams (A.12.3) +This package is similar to @code{Ada.Text_IO.Streams}, except that the +types are @code{Wide_Character} and @code{Wide_String} instead of +@code{Character} and @code{String}. + +@item Ada.Wide_Wide_Text_IO (A.11) +This package is similar to @code{Ada.Text_IO}, except that the external +file supports wide character representations, and the internal types are +@code{Wide_Character} and @code{Wide_String} instead of @code{Character} +and @code{String}. It contains generic subpackages listed next. + +@item Ada.Wide_Wide_Text_IO.Decimal_IO +Provides input-output facilities for decimal fixed-point types + +@item Ada.Wide_Wide_Text_IO.Enumeration_IO +Provides input-output facilities for enumeration types. + +@item Ada.Wide_Wide_Text_IO.Fixed_IO +Provides input-output facilities for ordinary fixed-point types. + +@item Ada.Wide_Wide_Text_IO.Float_IO +Provides input-output facilities for float types. The following +predefined instantiations of this generic package are available: + +@table @code +@item Short_Float +@code{Short_Float_Wide_Wide_Text_IO} +@item Float +@code{Float_Wide_Wide_Text_IO} +@item Long_Float +@code{Long_Float_Wide_Wide_Text_IO} +@end table + +@item Ada.Wide_Wide_Text_IO.Integer_IO +Provides input-output facilities for integer types. The following +predefined instantiations of this generic package are available: + +@table @code +@item Short_Short_Integer +@code{Ada.Short_Short_Integer_Wide_Wide_Text_IO} +@item Short_Integer +@code{Ada.Short_Integer_Wide_Wide_Text_IO} +@item Integer +@code{Ada.Integer_Wide_Wide_Text_IO} +@item Long_Integer +@code{Ada.Long_Integer_Wide_Wide_Text_IO} +@item Long_Long_Integer +@code{Ada.Long_Long_Integer_Wide_Wide_Text_IO} +@end table + +@item Ada.Wide_Wide_Text_IO.Modular_IO +Provides input-output facilities for modular (unsigned) types + +@item Ada.Wide_Wide_Text_IO.Complex_IO (G.1.3) +This package is similar to @code{Ada.Text_IO.Complex_IO}, except that the +external file supports wide character representations. + +@item Ada.Wide_Wide_Text_IO.Editing (F.3.4) +This package is similar to @code{Ada.Text_IO.Editing}, except that the +types are @code{Wide_Character} and @code{Wide_String} instead of +@code{Character} and @code{String}. + +@item Ada.Wide_Wide_Text_IO.Streams (A.12.3) +This package is similar to @code{Ada.Text_IO.Streams}, except that the +types are @code{Wide_Character} and @code{Wide_String} instead of +@code{Character} and @code{String}. +@end table + +@node The Implementation of Standard I/O +@chapter The Implementation of Standard I/O + +@noindent +GNAT implements all the required input-output facilities described in +A.6 through A.14. These sections of the Ada Reference Manual describe the +required behavior of these packages from the Ada point of view, and if +you are writing a portable Ada program that does not need to know the +exact manner in which Ada maps to the outside world when it comes to +reading or writing external files, then you do not need to read this +chapter. As long as your files are all regular files (not pipes or +devices), and as long as you write and read the files only from Ada, the +description in the Ada Reference Manual is sufficient. + +However, if you want to do input-output to pipes or other devices, such +as the keyboard or screen, or if the files you are dealing with are +either generated by some other language, or to be read by some other +language, then you need to know more about the details of how the GNAT +implementation of these input-output facilities behaves. + +In this chapter we give a detailed description of exactly how GNAT +interfaces to the file system. As always, the sources of the system are +available to you for answering questions at an even more detailed level, +but for most purposes the information in this chapter will suffice. + +Another reason that you may need to know more about how input-output is +implemented arises when you have a program written in mixed languages +where, for example, files are shared between the C and Ada sections of +the same program. GNAT provides some additional facilities, in the form +of additional child library packages, that facilitate this sharing, and +these additional facilities are also described in this chapter. + +@menu +* Standard I/O Packages:: +* FORM Strings:: +* Direct_IO:: +* Sequential_IO:: +* Text_IO:: +* Wide_Text_IO:: +* Wide_Wide_Text_IO:: +* Stream_IO:: +* Text Translation:: +* Shared Files:: +* Filenames encoding:: +* Open Modes:: +* Operations on C Streams:: +* Interfacing to C Streams:: +@end menu + +@node Standard I/O Packages +@section Standard I/O Packages + +@noindent +The Standard I/O packages described in Annex A for + +@itemize @bullet +@item +Ada.Text_IO +@item +Ada.Text_IO.Complex_IO +@item +Ada.Text_IO.Text_Streams +@item +Ada.Wide_Text_IO +@item +Ada.Wide_Text_IO.Complex_IO +@item +Ada.Wide_Text_IO.Text_Streams +@item +Ada.Wide_Wide_Text_IO +@item +Ada.Wide_Wide_Text_IO.Complex_IO +@item +Ada.Wide_Wide_Text_IO.Text_Streams +@item +Ada.Stream_IO +@item +Ada.Sequential_IO +@item +Ada.Direct_IO +@end itemize + +@noindent +are implemented using the C +library streams facility; where + +@itemize @bullet +@item +All files are opened using @code{fopen}. +@item +All input/output operations use @code{fread}/@code{fwrite}. +@end itemize + +@noindent +There is no internal buffering of any kind at the Ada library level. The only +buffering is that provided at the system level in the implementation of the +library routines that support streams. This facilitates shared use of these +streams by mixed language programs. Note though that system level buffering is +explicitly enabled at elaboration of the standard I/O packages and that can +have an impact on mixed language programs, in particular those using I/O before +calling the Ada elaboration routine (e.g.@: adainit). It is recommended to call +the Ada elaboration routine before performing any I/O or when impractical, +flush the common I/O streams and in particular Standard_Output before +elaborating the Ada code. + +@node FORM Strings +@section FORM Strings + +@noindent +The format of a FORM string in GNAT is: + +@smallexample +"keyword=value,keyword=value,@dots{},keyword=value" +@end smallexample + +@noindent +where letters may be in upper or lower case, and there are no spaces +between values. The order of the entries is not important. Currently +the following keywords defined. + +@smallexample +TEXT_TRANSLATION=[YES|NO] +SHARED=[YES|NO] +WCEM=[n|h|u|s|e|8|b] +ENCODING=[UTF8|8BITS] +@end smallexample + +@noindent +The use of these parameters is described later in this section. + +@node Direct_IO +@section Direct_IO + +@noindent +Direct_IO can only be instantiated for definite types. This is a +restriction of the Ada language, which means that the records are fixed +length (the length being determined by @code{@var{type}'Size}, rounded +up to the next storage unit boundary if necessary). + +The records of a Direct_IO file are simply written to the file in index +sequence, with the first record starting at offset zero, and subsequent +records following. There is no control information of any kind. For +example, if 32-bit integers are being written, each record takes +4-bytes, so the record at index @var{K} starts at offset +(@var{K}@minus{}1)*4. + +There is no limit on the size of Direct_IO files, they are expanded as +necessary to accommodate whatever records are written to the file. + +@node Sequential_IO +@section Sequential_IO + +@noindent +Sequential_IO may be instantiated with either a definite (constrained) +or indefinite (unconstrained) type. + +For the definite type case, the elements written to the file are simply +the memory images of the data values with no control information of any +kind. The resulting file should be read using the same type, no validity +checking is performed on input. + +For the indefinite type case, the elements written consist of two +parts. First is the size of the data item, written as the memory image +of a @code{Interfaces.C.size_t} value, followed by the memory image of +the data value. The resulting file can only be read using the same +(unconstrained) type. Normal assignment checks are performed on these +read operations, and if these checks fail, @code{Data_Error} is +raised. In particular, in the array case, the lengths must match, and in +the variant record case, if the variable for a particular read operation +is constrained, the discriminants must match. + +Note that it is not possible to use Sequential_IO to write variable +length array items, and then read the data back into different length +arrays. For example, the following will raise @code{Data_Error}: + +@smallexample @c ada + package IO is new Sequential_IO (String); + F : IO.File_Type; + S : String (1..4); + @dots{} + IO.Create (F) + IO.Write (F, "hello!") + IO.Reset (F, Mode=>In_File); + IO.Read (F, S); + Put_Line (S); + +@end smallexample + +@noindent +On some Ada implementations, this will print @code{hell}, but the program is +clearly incorrect, since there is only one element in the file, and that +element is the string @code{hello!}. + +In Ada 95 and Ada 2005, this kind of behavior can be legitimately achieved +using Stream_IO, and this is the preferred mechanism. In particular, the +above program fragment rewritten to use Stream_IO will work correctly. + +@node Text_IO +@section Text_IO + +@noindent +Text_IO files consist of a stream of characters containing the following +special control characters: + +@smallexample +LF (line feed, 16#0A#) Line Mark +FF (form feed, 16#0C#) Page Mark +@end smallexample + +@noindent +A canonical Text_IO file is defined as one in which the following +conditions are met: + +@itemize @bullet +@item +The character @code{LF} is used only as a line mark, i.e.@: to mark the end +of the line. + +@item +The character @code{FF} is used only as a page mark, i.e.@: to mark the +end of a page and consequently can appear only immediately following a +@code{LF} (line mark) character. + +@item +The file ends with either @code{LF} (line mark) or @code{LF}-@code{FF} +(line mark, page mark). In the former case, the page mark is implicitly +assumed to be present. +@end itemize + +@noindent +A file written using Text_IO will be in canonical form provided that no +explicit @code{LF} or @code{FF} characters are written using @code{Put} +or @code{Put_Line}. There will be no @code{FF} character at the end of +the file unless an explicit @code{New_Page} operation was performed +before closing the file. + +A canonical Text_IO file that is a regular file (i.e., not a device or a +pipe) can be read using any of the routines in Text_IO@. The +semantics in this case will be exactly as defined in the Ada Reference +Manual, and all the routines in Text_IO are fully implemented. + +A text file that does not meet the requirements for a canonical Text_IO +file has one of the following: + +@itemize @bullet +@item +The file contains @code{FF} characters not immediately following a +@code{LF} character. + +@item +The file contains @code{LF} or @code{FF} characters written by +@code{Put} or @code{Put_Line}, which are not logically considered to be +line marks or page marks. + +@item +The file ends in a character other than @code{LF} or @code{FF}, +i.e.@: there is no explicit line mark or page mark at the end of the file. +@end itemize + +@noindent +Text_IO can be used to read such non-standard text files but subprograms +to do with line or page numbers do not have defined meanings. In +particular, a @code{FF} character that does not follow a @code{LF} +character may or may not be treated as a page mark from the point of +view of page and line numbering. Every @code{LF} character is considered +to end a line, and there is an implied @code{LF} character at the end of +the file. + +@menu +* Text_IO Stream Pointer Positioning:: +* Text_IO Reading and Writing Non-Regular Files:: +* Get_Immediate:: +* Treating Text_IO Files as Streams:: +* Text_IO Extensions:: +* Text_IO Facilities for Unbounded Strings:: +@end menu + +@node Text_IO Stream Pointer Positioning +@subsection Stream Pointer Positioning + +@noindent +@code{Ada.Text_IO} has a definition of current position for a file that +is being read. No internal buffering occurs in Text_IO, and usually the +physical position in the stream used to implement the file corresponds +to this logical position defined by Text_IO@. There are two exceptions: + +@itemize @bullet +@item +After a call to @code{End_Of_Page} that returns @code{True}, the stream +is positioned past the @code{LF} (line mark) that precedes the page +mark. Text_IO maintains an internal flag so that subsequent read +operations properly handle the logical position which is unchanged by +the @code{End_Of_Page} call. + +@item +After a call to @code{End_Of_File} that returns @code{True}, if the +Text_IO file was positioned before the line mark at the end of file +before the call, then the logical position is unchanged, but the stream +is physically positioned right at the end of file (past the line mark, +and past a possible page mark following the line mark. Again Text_IO +maintains internal flags so that subsequent read operations properly +handle the logical position. +@end itemize + +@noindent +These discrepancies have no effect on the observable behavior of +Text_IO, but if a single Ada stream is shared between a C program and +Ada program, or shared (using @samp{shared=yes} in the form string) +between two Ada files, then the difference may be observable in some +situations. + +@node Text_IO Reading and Writing Non-Regular Files +@subsection Reading and Writing Non-Regular Files + +@noindent +A non-regular file is a device (such as a keyboard), or a pipe. Text_IO +can be used for reading and writing. Writing is not affected and the +sequence of characters output is identical to the normal file case, but +for reading, the behavior of Text_IO is modified to avoid undesirable +look-ahead as follows: + +An input file that is not a regular file is considered to have no page +marks. Any @code{Ascii.FF} characters (the character normally used for a +page mark) appearing in the file are considered to be data +characters. In particular: + +@itemize @bullet +@item +@code{Get_Line} and @code{Skip_Line} do not test for a page mark +following a line mark. If a page mark appears, it will be treated as a +data character. + +@item +This avoids the need to wait for an extra character to be typed or +entered from the pipe to complete one of these operations. + +@item +@code{End_Of_Page} always returns @code{False} + +@item +@code{End_Of_File} will return @code{False} if there is a page mark at +the end of the file. +@end itemize + +@noindent +Output to non-regular files is the same as for regular files. Page marks +may be written to non-regular files using @code{New_Page}, but as noted +above they will not be treated as page marks on input if the output is +piped to another Ada program. + +Another important discrepancy when reading non-regular files is that the end +of file indication is not ``sticky''. If an end of file is entered, e.g.@: by +pressing the @key{EOT} key, +then end of file +is signaled once (i.e.@: the test @code{End_Of_File} +will yield @code{True}, or a read will +raise @code{End_Error}), but then reading can resume +to read data past that end of +file indication, until another end of file indication is entered. + +@node Get_Immediate +@subsection Get_Immediate +@cindex Get_Immediate + +@noindent +Get_Immediate returns the next character (including control characters) +from the input file. In particular, Get_Immediate will return LF or FF +characters used as line marks or page marks. Such operations leave the +file positioned past the control character, and it is thus not treated +as having its normal function. This means that page, line and column +counts after this kind of Get_Immediate call are set as though the mark +did not occur. In the case where a Get_Immediate leaves the file +positioned between the line mark and page mark (which is not normally +possible), it is undefined whether the FF character will be treated as a +page mark. + +@node Treating Text_IO Files as Streams +@subsection Treating Text_IO Files as Streams +@cindex Stream files + +@noindent +The package @code{Text_IO.Streams} allows a Text_IO file to be treated +as a stream. Data written to a Text_IO file in this stream mode is +binary data. If this binary data contains bytes 16#0A# (@code{LF}) or +16#0C# (@code{FF}), the resulting file may have non-standard +format. Similarly if read operations are used to read from a Text_IO +file treated as a stream, then @code{LF} and @code{FF} characters may be +skipped and the effect is similar to that described above for +@code{Get_Immediate}. + +@node Text_IO Extensions +@subsection Text_IO Extensions +@cindex Text_IO extensions + +@noindent +A package GNAT.IO_Aux in the GNAT library provides some useful extensions +to the standard @code{Text_IO} package: + +@itemize @bullet +@item function File_Exists (Name : String) return Boolean; +Determines if a file of the given name exists. + +@item function Get_Line return String; +Reads a string from the standard input file. The value returned is exactly +the length of the line that was read. + +@item function Get_Line (File : Ada.Text_IO.File_Type) return String; +Similar, except that the parameter File specifies the file from which +the string is to be read. + +@end itemize + +@node Text_IO Facilities for Unbounded Strings +@subsection Text_IO Facilities for Unbounded Strings +@cindex Text_IO for unbounded strings +@cindex Unbounded_String, Text_IO operations + +@noindent +The package @code{Ada.Strings.Unbounded.Text_IO} +in library files @code{a-suteio.ads/adb} contains some GNAT-specific +subprograms useful for Text_IO operations on unbounded strings: + +@itemize @bullet + +@item function Get_Line (File : File_Type) return Unbounded_String; +Reads a line from the specified file +and returns the result as an unbounded string. + +@item procedure Put (File : File_Type; U : Unbounded_String); +Writes the value of the given unbounded string to the specified file +Similar to the effect of +@code{Put (To_String (U))} except that an extra copy is avoided. + +@item procedure Put_Line (File : File_Type; U : Unbounded_String); +Writes the value of the given unbounded string to the specified file, +followed by a @code{New_Line}. +Similar to the effect of @code{Put_Line (To_String (U))} except +that an extra copy is avoided. +@end itemize + +@noindent +In the above procedures, @code{File} is of type @code{Ada.Text_IO.File_Type} +and is optional. If the parameter is omitted, then the standard input or +output file is referenced as appropriate. + +The package @code{Ada.Strings.Wide_Unbounded.Wide_Text_IO} in library +files @file{a-swuwti.ads} and @file{a-swuwti.adb} provides similar extended +@code{Wide_Text_IO} functionality for unbounded wide strings. + +The package @code{Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO} in library +files @file{a-szuzti.ads} and @file{a-szuzti.adb} provides similar extended +@code{Wide_Wide_Text_IO} functionality for unbounded wide wide strings. + +@node Wide_Text_IO +@section Wide_Text_IO + +@noindent +@code{Wide_Text_IO} is similar in most respects to Text_IO, except that +both input and output files may contain special sequences that represent +wide character values. The encoding scheme for a given file may be +specified using a FORM parameter: + +@smallexample +WCEM=@var{x} +@end smallexample + +@noindent +as part of the FORM string (WCEM = wide character encoding method), +where @var{x} is one of the following characters + +@table @samp +@item h +Hex ESC encoding +@item u +Upper half encoding +@item s +Shift-JIS encoding +@item e +EUC Encoding +@item 8 +UTF-8 encoding +@item b +Brackets encoding +@end table + +@noindent +The encoding methods match those that +can be used in a source +program, but there is no requirement that the encoding method used for +the source program be the same as the encoding method used for files, +and different files may use different encoding methods. + +The default encoding method for the standard files, and for opened files +for which no WCEM parameter is given in the FORM string matches the +wide character encoding specified for the main program (the default +being brackets encoding if no coding method was specified with -gnatW). + +@table @asis +@item Hex Coding +In this encoding, a wide character is represented by a five character +sequence: + +@smallexample +ESC a b c d +@end smallexample + +@noindent +where @var{a}, @var{b}, @var{c}, @var{d} are the four hexadecimal +characters (using upper case letters) of the wide character code. For +example, ESC A345 is used to represent the wide character with code +16#A345#. This scheme is compatible with use of the full +@code{Wide_Character} set. + +@item Upper Half Coding +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. + +@item Shift JIS Coding +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. Only characters defined in the JIS code set table can be +used with this encoding method. + +@item EUC Coding +A wide character is represented by a two character sequence 16#ab# and +16#cd#, with both characters being in the upper half. The internal +character code is the corresponding JIS character according to the EUC +encoding algorithm. Only characters defined in the JIS code set table +can be used with this encoding method. + +@item UTF-8 Coding +A wide character is represented using +UCS Transformation Format 8 (UTF-8) as defined in Annex R of ISO +10646-1/Am.2. Depending on the character value, the representation +is a one, two, or three byte sequence: + +@smallexample +16#0000#-16#007f#: 2#0xxxxxxx# +16#0080#-16#07ff#: 2#110xxxxx# 2#10xxxxxx# +16#0800#-16#ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx# +@end smallexample + +@noindent +where the @var{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 +(The full UTF-8 scheme allows for encoding 31-bit characters as +6-byte sequences, but in this implementation, all UTF-8 sequences +of four or more bytes length will raise a Constraint_Error, as +will all invalid UTF-8 sequences.) + +@item Brackets Coding +In this encoding, a wide character is represented by the following eight +character sequence: + +@smallexample +[ " a b c d " ] +@end smallexample + +@noindent +where @code{a}, @code{b}, @code{c}, @code{d} are the four hexadecimal +characters (using uppercase letters) of the wide character code. For +example, @code{["A345"]} is used to represent the wide character with code +@code{16#A345#}. +This scheme is compatible with use of the full Wide_Character set. +On input, brackets coding can also be used for upper half characters, +e.g.@: @code{["C1"]} for lower case a. However, on output, brackets notation +is only used for wide characters with a code greater than @code{16#FF#}. + +Note that brackets coding is not normally used in the context of +Wide_Text_IO or Wide_Wide_Text_IO, since it is really just designed as +a portable way of encoding source files. In the context of Wide_Text_IO +or Wide_Wide_Text_IO, it can only be used if the file does not contain +any instance of the left bracket character other than to encode wide +character values using the brackets encoding method. In practice it is +expected that some standard wide character encoding method such +as UTF-8 will be used for text input output. + +If brackets notation is used, then any occurrence of a left bracket +in the input file which is not the start of a valid wide character +sequence will cause Constraint_Error to be raised. It is possible to +encode a left bracket as ["5B"] and Wide_Text_IO and Wide_Wide_Text_IO +input will interpret this as a left bracket. + +However, when a left bracket is output, it will be output as a left bracket +and not as ["5B"]. We make this decision because for normal use of +Wide_Text_IO for outputting messages, it is unpleasant to clobber left +brackets. For example, if we write: + +@smallexample + Put_Line ("Start of output [first run]"); +@end smallexample + +@noindent +we really do not want to have the left bracket in this message clobbered so +that the output reads: + +@smallexample + Start of output ["5B"]first run] +@end smallexample + +@noindent +In practice brackets encoding is reasonably useful for normal Put_Line use +since we won't get confused between left brackets and wide character +sequences in the output. But for input, or when files are written out +and read back in, it really makes better sense to use one of the standard +encoding methods such as UTF-8. + +@end table + +@noindent +For the coding schemes other than UTF-8, Hex, or Brackets encoding, +not all wide character +values can be represented. An attempt to output a character that cannot +be represented using the encoding scheme for the file causes +Constraint_Error to be raised. An invalid wide character sequence on +input also causes Constraint_Error to be raised. + +@menu +* Wide_Text_IO Stream Pointer Positioning:: +* Wide_Text_IO Reading and Writing Non-Regular Files:: +@end menu + +@node Wide_Text_IO Stream Pointer Positioning +@subsection Stream Pointer Positioning + +@noindent +@code{Ada.Wide_Text_IO} is similar to @code{Ada.Text_IO} in its handling +of stream pointer positioning (@pxref{Text_IO}). There is one additional +case: + +If @code{Ada.Wide_Text_IO.Look_Ahead} reads a character outside the +normal lower ASCII set (i.e.@: a character in the range: + +@smallexample @c ada +Wide_Character'Val (16#0080#) .. Wide_Character'Val (16#FFFF#) +@end smallexample + +@noindent +then although the logical position of the file pointer is unchanged by +the @code{Look_Ahead} call, the stream is physically positioned past the +wide character sequence. Again this is to avoid the need for buffering +or backup, and all @code{Wide_Text_IO} routines check the internal +indication that this situation has occurred so that this is not visible +to a normal program using @code{Wide_Text_IO}. However, this discrepancy +can be observed if the wide text file shares a stream with another file. + +@node Wide_Text_IO Reading and Writing Non-Regular Files +@subsection Reading and Writing Non-Regular Files + +@noindent +As in the case of Text_IO, when a non-regular file is read, it is +assumed that the file contains no page marks (any form characters are +treated as data characters), and @code{End_Of_Page} always returns +@code{False}. Similarly, the end of file indication is not sticky, so +it is possible to read beyond an end of file. + +@node Wide_Wide_Text_IO +@section Wide_Wide_Text_IO + +@noindent +@code{Wide_Wide_Text_IO} is similar in most respects to Text_IO, except that +both input and output files may contain special sequences that represent +wide wide character values. The encoding scheme for a given file may be +specified using a FORM parameter: + +@smallexample +WCEM=@var{x} +@end smallexample + +@noindent +as part of the FORM string (WCEM = wide character encoding method), +where @var{x} is one of the following characters + +@table @samp +@item h +Hex ESC encoding +@item u +Upper half encoding +@item s +Shift-JIS encoding +@item e +EUC Encoding +@item 8 +UTF-8 encoding +@item b +Brackets encoding +@end table + +@noindent +The encoding methods match those that +can be used in a source +program, but there is no requirement that the encoding method used for +the source program be the same as the encoding method used for files, +and different files may use different encoding methods. + +The default encoding method for the standard files, and for opened files +for which no WCEM parameter is given in the FORM string matches the +wide character encoding specified for the main program (the default +being brackets encoding if no coding method was specified with -gnatW). + +@table @asis + +@item UTF-8 Coding +A wide character is represented using +UCS Transformation Format 8 (UTF-8) as defined in Annex R of ISO +10646-1/Am.2. Depending on the character value, the representation +is a one, two, three, or four byte sequence: + +@smallexample +16#000000#-16#00007f#: 2#0xxxxxxx# +16#000080#-16#0007ff#: 2#110xxxxx# 2#10xxxxxx# +16#000800#-16#00ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx# +16#010000#-16#10ffff#: 2#11110xxx# 2#10xxxxxx# 2#10xxxxxx# 2#10xxxxxx# +@end smallexample + +@noindent +where the @var{xxx} bits correspond to the left-padded bits of the +21-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 +characters. + +@item Brackets Coding +In this encoding, a wide wide character is represented by the following eight +character sequence if is in wide character range + +@smallexample +[ " a b c d " ] +@end smallexample + +and by the following ten character sequence if not + +@smallexample +[ " a b c d e f " ] +@end smallexample + +@noindent +where @code{a}, @code{b}, @code{c}, @code{d}, @code{e}, and @code{f} +are the four or six hexadecimal +characters (using uppercase letters) of the wide wide character code. For +example, @code{["01A345"]} is used to represent the wide wide character +with code @code{16#01A345#}. + +This scheme is compatible with use of the full Wide_Wide_Character set. +On input, brackets coding can also be used for upper half characters, +e.g.@: @code{["C1"]} for lower case a. However, on output, brackets notation +is only used for wide characters with a code greater than @code{16#FF#}. + +@end table + +@noindent +If is also possible to use the other Wide_Character encoding methods, +such as Shift-JIS, but the other schemes cannot support the full range +of wide wide characters. +An attempt to output a character that cannot +be represented using the encoding scheme for the file causes +Constraint_Error to be raised. An invalid wide character sequence on +input also causes Constraint_Error to be raised. + +@menu +* Wide_Wide_Text_IO Stream Pointer Positioning:: +* Wide_Wide_Text_IO Reading and Writing Non-Regular Files:: +@end menu + +@node Wide_Wide_Text_IO Stream Pointer Positioning +@subsection Stream Pointer Positioning + +@noindent +@code{Ada.Wide_Wide_Text_IO} is similar to @code{Ada.Text_IO} in its handling +of stream pointer positioning (@pxref{Text_IO}). There is one additional +case: + +If @code{Ada.Wide_Wide_Text_IO.Look_Ahead} reads a character outside the +normal lower ASCII set (i.e.@: a character in the range: + +@smallexample @c ada +Wide_Wide_Character'Val (16#0080#) .. Wide_Wide_Character'Val (16#10FFFF#) +@end smallexample + +@noindent +then although the logical position of the file pointer is unchanged by +the @code{Look_Ahead} call, the stream is physically positioned past the +wide character sequence. Again this is to avoid the need for buffering +or backup, and all @code{Wide_Wide_Text_IO} routines check the internal +indication that this situation has occurred so that this is not visible +to a normal program using @code{Wide_Wide_Text_IO}. However, this discrepancy +can be observed if the wide text file shares a stream with another file. + +@node Wide_Wide_Text_IO Reading and Writing Non-Regular Files +@subsection Reading and Writing Non-Regular Files + +@noindent +As in the case of Text_IO, when a non-regular file is read, it is +assumed that the file contains no page marks (any form characters are +treated as data characters), and @code{End_Of_Page} always returns +@code{False}. Similarly, the end of file indication is not sticky, so +it is possible to read beyond an end of file. + +@node Stream_IO +@section Stream_IO + +@noindent +A stream file is a sequence of bytes, where individual elements are +written to the file as described in the Ada Reference Manual. The type +@code{Stream_Element} is simply a byte. There are two ways to read or +write a stream file. + +@itemize @bullet +@item +The operations @code{Read} and @code{Write} directly read or write a +sequence of stream elements with no control information. + +@item +The stream attributes applied to a stream file transfer data in the +manner described for stream attributes. +@end itemize + +@node Text Translation +@section Text Translation + +@noindent +@samp{Text_Translation=@var{xxx}} may be used as the Form parameter +passed to Text_IO.Create and Text_IO.Open: +@samp{Text_Translation=@var{Yes}} is the default, which means to +translate LF to/from CR/LF on Windows systems. +@samp{Text_Translation=@var{No}} disables this translation; i.e. it +uses binary mode. For output files, @samp{Text_Translation=@var{No}} +may be used to create Unix-style files on +Windows. @samp{Text_Translation=@var{xxx}} has no effect on Unix +systems. + +@node Shared Files +@section Shared Files + +@noindent +Section A.14 of the Ada Reference Manual allows implementations to +provide a wide variety of behavior if an attempt is made to access the +same external file with two or more internal files. + +To provide a full range of functionality, while at the same time +minimizing the problems of portability caused by this implementation +dependence, GNAT handles file sharing as follows: + +@itemize @bullet +@item +In the absence of a @samp{shared=@var{xxx}} form parameter, an attempt +to open two or more files with the same full name is considered an error +and is not supported. The exception @code{Use_Error} will be +raised. Note that a file that is not explicitly closed by the program +remains open until the program terminates. + +@item +If the form parameter @samp{shared=no} appears in the form string, the +file can be opened or created with its own separate stream identifier, +regardless of whether other files sharing the same external file are +opened. The exact effect depends on how the C stream routines handle +multiple accesses to the same external files using separate streams. + +@item +If the form parameter @samp{shared=yes} appears in the form string for +each of two or more files opened using the same full name, the same +stream is shared between these files, and the semantics are as described +in Ada Reference Manual, Section A.14. +@end itemize + +@noindent +When a program that opens multiple files with the same name is ported +from another Ada compiler to GNAT, the effect will be that +@code{Use_Error} is raised. + +The documentation of the original compiler and the documentation of the +program should then be examined to determine if file sharing was +expected, and @samp{shared=@var{xxx}} parameters added to @code{Open} +and @code{Create} calls as required. + +When a program is ported from GNAT to some other Ada compiler, no +special attention is required unless the @samp{shared=@var{xxx}} form +parameter is used in the program. In this case, you must examine the +documentation of the new compiler to see if it supports the required +file sharing semantics, and form strings modified appropriately. Of +course it may be the case that the program cannot be ported if the +target compiler does not support the required functionality. The best +approach in writing portable code is to avoid file sharing (and hence +the use of the @samp{shared=@var{xxx}} parameter in the form string) +completely. + +One common use of file sharing in Ada 83 is the use of instantiations of +Sequential_IO on the same file with different types, to achieve +heterogeneous input-output. Although this approach will work in GNAT if +@samp{shared=yes} is specified, it is preferable in Ada to use Stream_IO +for this purpose (using the stream attributes) + +@node Filenames encoding +@section Filenames encoding + +@noindent +An encoding form parameter can be used to specify the filename +encoding @samp{encoding=@var{xxx}}. + +@itemize @bullet +@item +If the form parameter @samp{encoding=utf8} appears in the form string, the +filename must be encoded in UTF-8. + +@item +If the form parameter @samp{encoding=8bits} appears in the form +string, the filename must be a standard 8bits string. +@end itemize + +In the absence of a @samp{encoding=@var{xxx}} form parameter, the +encoding is controlled by the @samp{GNAT_CODE_PAGE} environment +variable. And if not set @samp{utf8} is assumed. + +@table @samp +@item CP_ACP +The current system Windows ANSI code page. +@item CP_UTF8 +UTF-8 encoding +@end table + +This encoding form parameter is only supported on the Windows +platform. On the other Operating Systems the run-time is supporting +UTF-8 natively. + +@node Open Modes +@section Open Modes + +@noindent +@code{Open} and @code{Create} calls result in a call to @code{fopen} +using the mode shown in the following table: + +@sp 2 +@center @code{Open} and @code{Create} Call Modes +@smallexample + @b{OPEN } @b{CREATE} +Append_File "r+" "w+" +In_File "r" "w+" +Out_File (Direct_IO) "r+" "w" +Out_File (all other cases) "w" "w" +Inout_File "r+" "w+" +@end smallexample + +@noindent +If text file translation is required, then either @samp{b} or @samp{t} +is added to the mode, depending on the setting of Text. Text file +translation refers to the mapping of CR/LF sequences in an external file +to LF characters internally. This mapping only occurs in DOS and +DOS-like systems, and is not relevant to other systems. + +A special case occurs with Stream_IO@. As shown in the above table, the +file is initially opened in @samp{r} or @samp{w} mode for the +@code{In_File} and @code{Out_File} cases. If a @code{Set_Mode} operation +subsequently requires switching from reading to writing or vice-versa, +then the file is reopened in @samp{r+} mode to permit the required operation. + +@node Operations on C Streams +@section Operations on C Streams +The package @code{Interfaces.C_Streams} provides an Ada program with direct +access to the C library functions for operations on C streams: + +@smallexample @c adanocomment +package Interfaces.C_Streams is + -- Note: the reason we do not use the types that are in + -- Interfaces.C is that we want to avoid dragging in the + -- code in this unit if possible. + subtype chars is System.Address; + -- Pointer to null-terminated array of characters + subtype FILEs is System.Address; + -- Corresponds to the C type FILE* + subtype voids is System.Address; + -- Corresponds to the C type void* + subtype int is Integer; + subtype long is Long_Integer; + -- Note: the above types are subtypes deliberately, and it + -- is part of this spec that the above correspondences are + -- guaranteed. This means that it is legitimate to, for + -- example, use Integer instead of int. We provide these + -- synonyms for clarity, but in some cases it may be + -- convenient to use the underlying types (for example to + -- avoid an unnecessary dependency of a spec on the spec + -- of this unit). + type size_t is mod 2 ** Standard'Address_Size; + 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 + 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); + function fclose (stream : FILEs) return int; + function fdopen (handle : int; mode : chars) return FILEs; + function feof (stream : FILEs) return int; + function ferror (stream : FILEs) return int; + function fflush (stream : FILEs) return int; + function fgetc (stream : FILEs) return int; + function fgets (strng : chars; n : int; stream : FILEs) + return chars; + function fileno (stream : FILEs) return int; + function fopen (filename : chars; Mode : chars) + return FILEs; + -- Note: to maintain target independence, use + -- text_translation_required, a boolean variable defined in + -- a-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; + function fputs (Strng : chars; Stream : FILEs) return int; + function fread + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) + return size_t; + function freopen + (filename : chars; + mode : chars; + stream : FILEs) + return FILEs; + function fseek + (stream : FILEs; + offset : long; + origin : int) + return int; + function ftell (stream : FILEs) return long; + function fwrite + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) + return size_t; + function isatty (handle : int) return int; + procedure mktemp (template : chars); + -- The return value (which is just a pointer to template) + -- is discarded + procedure rewind (stream : FILEs); + function rmtmp return int; + function setvbuf + (stream : FILEs; + buffer : chars; + mode : int; + size : size_t) + return int; + + function tmpfile return FILEs; + function ungetc (c : int; stream : FILEs) return int; + function unlink (filename : chars) return int; + --------------------- + -- 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 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 -- + --------------------------------- + -- If text_translation_required is true, then the following + -- 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 (i.e.@: in + -- normal UNIX mode). Use fileno to get a stream handle. + procedure set_binary_mode (handle : int); + procedure set_text_mode (handle : int); + ---------------------------- + -- 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 : integer; + -- Maximum length of an allowable full path name on the + -- system, including a terminating NUL character. +end Interfaces.C_Streams; +@end smallexample + +@node Interfacing to C Streams +@section Interfacing to C Streams + +@noindent +The packages in this section permit interfacing Ada files to C Stream +operations. + +@smallexample @c ada + with Interfaces.C_Streams; + package Ada.Sequential_IO.C_Streams is + function C_Stream (F : File_Type) + return Interfaces.C_Streams.FILEs; + procedure Open + (File : in out File_Type; + Mode : in File_Mode; + C_Stream : in Interfaces.C_Streams.FILEs; + Form : in String := ""); + end Ada.Sequential_IO.C_Streams; + + with Interfaces.C_Streams; + package Ada.Direct_IO.C_Streams is + function C_Stream (F : File_Type) + return Interfaces.C_Streams.FILEs; + procedure Open + (File : in out File_Type; + Mode : in File_Mode; + C_Stream : in Interfaces.C_Streams.FILEs; + Form : in String := ""); + end Ada.Direct_IO.C_Streams; + + with Interfaces.C_Streams; + package Ada.Text_IO.C_Streams is + function C_Stream (F : File_Type) + return Interfaces.C_Streams.FILEs; + procedure Open + (File : in out File_Type; + Mode : in File_Mode; + C_Stream : in Interfaces.C_Streams.FILEs; + Form : in String := ""); + end Ada.Text_IO.C_Streams; + + with Interfaces.C_Streams; + package Ada.Wide_Text_IO.C_Streams is + function C_Stream (F : File_Type) + return Interfaces.C_Streams.FILEs; + procedure Open + (File : in out File_Type; + Mode : in File_Mode; + C_Stream : in Interfaces.C_Streams.FILEs; + Form : in String := ""); + end Ada.Wide_Text_IO.C_Streams; + + with Interfaces.C_Streams; + package Ada.Wide_Wide_Text_IO.C_Streams is + function C_Stream (F : File_Type) + return Interfaces.C_Streams.FILEs; + procedure Open + (File : in out File_Type; + Mode : in File_Mode; + C_Stream : in Interfaces.C_Streams.FILEs; + Form : in String := ""); + end Ada.Wide_Wide_Text_IO.C_Streams; + + with Interfaces.C_Streams; + package Ada.Stream_IO.C_Streams is + function C_Stream (F : File_Type) + return Interfaces.C_Streams.FILEs; + procedure Open + (File : in out File_Type; + Mode : in File_Mode; + C_Stream : in Interfaces.C_Streams.FILEs; + Form : in String := ""); + end Ada.Stream_IO.C_Streams; +@end smallexample + +@noindent +In each of these six packages, the @code{C_Stream} function obtains the +@code{FILE} pointer from a currently opened Ada file. It is then +possible to use the @code{Interfaces.C_Streams} package to operate on +this stream, or the stream can be passed to a C program which can +operate on it directly. Of course the program is responsible for +ensuring that only appropriate sequences of operations are executed. + +One particular use of relevance to an Ada program is that the +@code{setvbuf} function can be used to control the buffering of the +stream used by an Ada file. In the absence of such a call the standard +default buffering is used. + +The @code{Open} procedures in these packages open a file giving an +existing C Stream instead of a file name. Typically this stream is +imported from a C program, allowing an Ada file to operate on an +existing C file. + +@node The GNAT Library +@chapter The GNAT Library + +@noindent +The GNAT library contains a number of general and special purpose packages. +It represents functionality that the GNAT developers have found useful, and +which is made available to GNAT users. The packages described here are fully +supported, and upwards compatibility will be maintained in future releases, +so you can use these facilities with the confidence that the same functionality +will be available in future releases. + +The chapter here simply gives a brief summary of the facilities available. +The full documentation is found in the spec file for the package. The full +sources of these library packages, including both spec and body, are provided +with all GNAT releases. For example, to find out the full specifications of +the SPITBOL pattern matching capability, including a full tutorial and +extensive examples, look in the @file{g-spipat.ads} file in the library. + +For each entry here, the package name (as it would appear in a @code{with} +clause) is given, followed by the name of the corresponding spec file in +parentheses. The packages are children in four hierarchies, @code{Ada}, +@code{Interfaces}, @code{System}, and @code{GNAT}, the latter being a +GNAT-specific hierarchy. + +Note that an application program should only use packages in one of these +four hierarchies if the package is defined in the Ada Reference Manual, +or is listed in this section of the GNAT Programmers Reference Manual. +All other units should be considered internal implementation units and +should not be directly @code{with}'ed by application code. The use of +a @code{with} statement that references one of these internal implementation +units makes an application potentially dependent on changes in versions +of GNAT, and will generate a warning message. + +@menu +* Ada.Characters.Latin_9 (a-chlat9.ads):: +* Ada.Characters.Wide_Latin_1 (a-cwila1.ads):: +* Ada.Characters.Wide_Latin_9 (a-cwila9.ads):: +* Ada.Characters.Wide_Wide_Latin_1 (a-chzla1.ads):: +* Ada.Characters.Wide_Wide_Latin_9 (a-chzla9.ads):: +* Ada.Command_Line.Environment (a-colien.ads):: +* Ada.Command_Line.Remove (a-colire.ads):: +* Ada.Command_Line.Response_File (a-clrefi.ads):: +* Ada.Direct_IO.C_Streams (a-diocst.ads):: +* Ada.Exceptions.Is_Null_Occurrence (a-einuoc.ads):: +* Ada.Exceptions.Last_Chance_Handler (a-elchha.ads):: +* Ada.Exceptions.Traceback (a-exctra.ads):: +* Ada.Sequential_IO.C_Streams (a-siocst.ads):: +* Ada.Streams.Stream_IO.C_Streams (a-ssicst.ads):: +* Ada.Strings.Unbounded.Text_IO (a-suteio.ads):: +* Ada.Strings.Wide_Unbounded.Wide_Text_IO (a-swuwti.ads):: +* Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO (a-szuzti.ads):: +* Ada.Text_IO.C_Streams (a-tiocst.ads):: +* Ada.Text_IO.Reset_Standard_Files (a-tirsfi.ads):: +* Ada.Wide_Characters.Unicode (a-wichun.ads):: +* Ada.Wide_Text_IO.C_Streams (a-wtcstr.ads):: +* Ada.Wide_Text_IO.Reset_Standard_Files (a-wrstfi.ads):: +* Ada.Wide_Wide_Characters.Unicode (a-zchuni.ads):: +* Ada.Wide_Wide_Text_IO.C_Streams (a-ztcstr.ads):: +* Ada.Wide_Wide_Text_IO.Reset_Standard_Files (a-zrstfi.ads):: +* GNAT.Altivec (g-altive.ads):: +* GNAT.Altivec.Conversions (g-altcon.ads):: +* GNAT.Altivec.Vector_Operations (g-alveop.ads):: +* GNAT.Altivec.Vector_Types (g-alvety.ads):: +* GNAT.Altivec.Vector_Views (g-alvevi.ads):: +* GNAT.Array_Split (g-arrspl.ads):: +* GNAT.AWK (g-awk.ads):: +* GNAT.Bounded_Buffers (g-boubuf.ads):: +* GNAT.Bounded_Mailboxes (g-boumai.ads):: +* GNAT.Bubble_Sort (g-bubsor.ads):: +* GNAT.Bubble_Sort_A (g-busora.ads):: +* GNAT.Bubble_Sort_G (g-busorg.ads):: +* GNAT.Byte_Order_Mark (g-byorma.ads):: +* GNAT.Byte_Swapping (g-bytswa.ads):: +* GNAT.Calendar (g-calend.ads):: +* GNAT.Calendar.Time_IO (g-catiio.ads):: +* GNAT.Case_Util (g-casuti.ads):: +* GNAT.CGI (g-cgi.ads):: +* GNAT.CGI.Cookie (g-cgicoo.ads):: +* GNAT.CGI.Debug (g-cgideb.ads):: +* GNAT.Command_Line (g-comlin.ads):: +* GNAT.Compiler_Version (g-comver.ads):: +* GNAT.Ctrl_C (g-ctrl_c.ads):: +* GNAT.CRC32 (g-crc32.ads):: +* GNAT.Current_Exception (g-curexc.ads):: +* GNAT.Debug_Pools (g-debpoo.ads):: +* GNAT.Debug_Utilities (g-debuti.ads):: +* GNAT.Decode_String (g-decstr.ads):: +* GNAT.Decode_UTF8_String (g-deutst.ads):: +* GNAT.Directory_Operations (g-dirope.ads):: +* GNAT.Directory_Operations.Iteration (g-diopit.ads):: +* GNAT.Dynamic_HTables (g-dynhta.ads):: +* GNAT.Dynamic_Tables (g-dyntab.ads):: +* GNAT.Encode_String (g-encstr.ads):: +* GNAT.Encode_UTF8_String (g-enutst.ads):: +* GNAT.Exception_Actions (g-excact.ads):: +* GNAT.Exception_Traces (g-exctra.ads):: +* GNAT.Exceptions (g-except.ads):: +* GNAT.Expect (g-expect.ads):: +* GNAT.Float_Control (g-flocon.ads):: +* GNAT.Heap_Sort (g-heasor.ads):: +* GNAT.Heap_Sort_A (g-hesora.ads):: +* GNAT.Heap_Sort_G (g-hesorg.ads):: +* GNAT.HTable (g-htable.ads):: +* GNAT.IO (g-io.ads):: +* GNAT.IO_Aux (g-io_aux.ads):: +* GNAT.Lock_Files (g-locfil.ads):: +* GNAT.MBBS_Discrete_Random (g-mbdira.ads):: +* GNAT.MBBS_Float_Random (g-mbflra.ads):: +* GNAT.MD5 (g-md5.ads):: +* GNAT.Memory_Dump (g-memdum.ads):: +* GNAT.Most_Recent_Exception (g-moreex.ads):: +* GNAT.OS_Lib (g-os_lib.ads):: +* GNAT.Perfect_Hash_Generators (g-pehage.ads):: +* GNAT.Random_Numbers (g-rannum.ads):: +* GNAT.Regexp (g-regexp.ads):: +* GNAT.Registry (g-regist.ads):: +* GNAT.Regpat (g-regpat.ads):: +* GNAT.Secondary_Stack_Info (g-sestin.ads):: +* GNAT.Semaphores (g-semaph.ads):: +* GNAT.Serial_Communications (g-sercom.ads):: +* GNAT.SHA1 (g-sha1.ads):: +* GNAT.SHA224 (g-sha224.ads):: +* GNAT.SHA256 (g-sha256.ads):: +* GNAT.SHA384 (g-sha384.ads):: +* GNAT.SHA512 (g-sha512.ads):: +* GNAT.Signals (g-signal.ads):: +* GNAT.Sockets (g-socket.ads):: +* GNAT.Source_Info (g-souinf.ads):: +* GNAT.Spelling_Checker (g-speche.ads):: +* GNAT.Spelling_Checker_Generic (g-spchge.ads):: +* GNAT.Spitbol.Patterns (g-spipat.ads):: +* GNAT.Spitbol (g-spitbo.ads):: +* GNAT.Spitbol.Table_Boolean (g-sptabo.ads):: +* GNAT.Spitbol.Table_Integer (g-sptain.ads):: +* GNAT.Spitbol.Table_VString (g-sptavs.ads):: +* GNAT.SSE (g-sse.ads):: +* GNAT.SSE.Vector_Types (g-ssvety.ads):: +* GNAT.Strings (g-string.ads):: +* GNAT.String_Split (g-strspl.ads):: +* GNAT.Table (g-table.ads):: +* GNAT.Task_Lock (g-tasloc.ads):: +* GNAT.Threads (g-thread.ads):: +* GNAT.Time_Stamp (g-timsta.ads):: +* GNAT.Traceback (g-traceb.ads):: +* GNAT.Traceback.Symbolic (g-trasym.ads):: +* GNAT.UTF_32 (g-utf_32.ads):: +* GNAT.UTF_32_Spelling_Checker (g-u3spch.ads):: +* GNAT.Wide_Spelling_Checker (g-wispch.ads):: +* GNAT.Wide_String_Split (g-wistsp.ads):: +* GNAT.Wide_Wide_Spelling_Checker (g-zspche.ads):: +* GNAT.Wide_Wide_String_Split (g-zistsp.ads):: +* Interfaces.C.Extensions (i-cexten.ads):: +* Interfaces.C.Streams (i-cstrea.ads):: +* Interfaces.CPP (i-cpp.ads):: +* Interfaces.Packed_Decimal (i-pacdec.ads):: +* Interfaces.VxWorks (i-vxwork.ads):: +* Interfaces.VxWorks.IO (i-vxwoio.ads):: +* System.Address_Image (s-addima.ads):: +* System.Assertions (s-assert.ads):: +* System.Memory (s-memory.ads):: +* System.Partition_Interface (s-parint.ads):: +* System.Pool_Global (s-pooglo.ads):: +* System.Pool_Local (s-pooloc.ads):: +* System.Restrictions (s-restri.ads):: +* System.Rident (s-rident.ads):: +* System.Strings.Stream_Ops (s-ststop.ads):: +* System.Task_Info (s-tasinf.ads):: +* System.Wch_Cnv (s-wchcnv.ads):: +* System.Wch_Con (s-wchcon.ads):: +@end menu + +@node Ada.Characters.Latin_9 (a-chlat9.ads) +@section @code{Ada.Characters.Latin_9} (@file{a-chlat9.ads}) +@cindex @code{Ada.Characters.Latin_9} (@file{a-chlat9.ads}) +@cindex Latin_9 constants for Character + +@noindent +This child of @code{Ada.Characters} +provides a set of definitions corresponding to those in the +RM-defined package @code{Ada.Characters.Latin_1} but with the +few modifications required for @code{Latin-9} +The provision of such a package +is specifically authorized by the Ada Reference Manual +(RM A.3.3(27)). + +@node Ada.Characters.Wide_Latin_1 (a-cwila1.ads) +@section @code{Ada.Characters.Wide_Latin_1} (@file{a-cwila1.ads}) +@cindex @code{Ada.Characters.Wide_Latin_1} (@file{a-cwila1.ads}) +@cindex Latin_1 constants for Wide_Character + +@noindent +This child of @code{Ada.Characters} +provides a set of definitions corresponding to those in the +RM-defined package @code{Ada.Characters.Latin_1} but with the +types of the constants being @code{Wide_Character} +instead of @code{Character}. The provision of such a package +is specifically authorized by the Ada Reference Manual +(RM A.3.3(27)). + +@node Ada.Characters.Wide_Latin_9 (a-cwila9.ads) +@section @code{Ada.Characters.Wide_Latin_9} (@file{a-cwila1.ads}) +@cindex @code{Ada.Characters.Wide_Latin_9} (@file{a-cwila1.ads}) +@cindex Latin_9 constants for Wide_Character + +@noindent +This child of @code{Ada.Characters} +provides a set of definitions corresponding to those in the +GNAT defined package @code{Ada.Characters.Latin_9} but with the +types of the constants being @code{Wide_Character} +instead of @code{Character}. The provision of such a package +is specifically authorized by the Ada Reference Manual +(RM A.3.3(27)). + +@node Ada.Characters.Wide_Wide_Latin_1 (a-chzla1.ads) +@section @code{Ada.Characters.Wide_Wide_Latin_1} (@file{a-chzla1.ads}) +@cindex @code{Ada.Characters.Wide_Wide_Latin_1} (@file{a-chzla1.ads}) +@cindex Latin_1 constants for Wide_Wide_Character + +@noindent +This child of @code{Ada.Characters} +provides a set of definitions corresponding to those in the +RM-defined package @code{Ada.Characters.Latin_1} but with the +types of the constants being @code{Wide_Wide_Character} +instead of @code{Character}. The provision of such a package +is specifically authorized by the Ada Reference Manual +(RM A.3.3(27)). + +@node Ada.Characters.Wide_Wide_Latin_9 (a-chzla9.ads) +@section @code{Ada.Characters.Wide_Wide_Latin_9} (@file{a-chzla9.ads}) +@cindex @code{Ada.Characters.Wide_Wide_Latin_9} (@file{a-chzla9.ads}) +@cindex Latin_9 constants for Wide_Wide_Character + +@noindent +This child of @code{Ada.Characters} +provides a set of definitions corresponding to those in the +GNAT defined package @code{Ada.Characters.Latin_9} but with the +types of the constants being @code{Wide_Wide_Character} +instead of @code{Character}. The provision of such a package +is specifically authorized by the Ada Reference Manual +(RM A.3.3(27)). + +@node Ada.Command_Line.Environment (a-colien.ads) +@section @code{Ada.Command_Line.Environment} (@file{a-colien.ads}) +@cindex @code{Ada.Command_Line.Environment} (@file{a-colien.ads}) +@cindex Environment entries + +@noindent +This child of @code{Ada.Command_Line} +provides a mechanism for obtaining environment values on systems +where this concept makes sense. + +@node Ada.Command_Line.Remove (a-colire.ads) +@section @code{Ada.Command_Line.Remove} (@file{a-colire.ads}) +@cindex @code{Ada.Command_Line.Remove} (@file{a-colire.ads}) +@cindex Removing command line arguments +@cindex Command line, argument removal + +@noindent +This child of @code{Ada.Command_Line} +provides a mechanism for logically removing +arguments from the argument list. Once removed, an argument is not visible +to further calls on the subprograms in @code{Ada.Command_Line} will not +see the removed argument. + +@node Ada.Command_Line.Response_File (a-clrefi.ads) +@section @code{Ada.Command_Line.Response_File} (@file{a-clrefi.ads}) +@cindex @code{Ada.Command_Line.Response_File} (@file{a-clrefi.ads}) +@cindex Response file for command line +@cindex Command line, response file +@cindex Command line, handling long command lines + +@noindent +This child of @code{Ada.Command_Line} provides a mechanism facilities for +getting command line arguments from a text file, called a "response file". +Using a response file allow passing a set of arguments to an executable longer +than the maximum allowed by the system on the command line. + +@node Ada.Direct_IO.C_Streams (a-diocst.ads) +@section @code{Ada.Direct_IO.C_Streams} (@file{a-diocst.ads}) +@cindex @code{Ada.Direct_IO.C_Streams} (@file{a-diocst.ads}) +@cindex C Streams, Interfacing with Direct_IO + +@noindent +This package provides subprograms that allow interfacing between +C streams and @code{Direct_IO}. The stream identifier can be +extracted from a file opened on the Ada side, and an Ada file +can be constructed from a stream opened on the C side. + +@node Ada.Exceptions.Is_Null_Occurrence (a-einuoc.ads) +@section @code{Ada.Exceptions.Is_Null_Occurrence} (@file{a-einuoc.ads}) +@cindex @code{Ada.Exceptions.Is_Null_Occurrence} (@file{a-einuoc.ads}) +@cindex Null_Occurrence, testing for + +@noindent +This child subprogram provides a way of testing for the null +exception occurrence (@code{Null_Occurrence}) without raising +an exception. + +@node Ada.Exceptions.Last_Chance_Handler (a-elchha.ads) +@section @code{Ada.Exceptions.Last_Chance_Handler} (@file{a-elchha.ads}) +@cindex @code{Ada.Exceptions.Last_Chance_Handler} (@file{a-elchha.ads}) +@cindex Null_Occurrence, testing for + +@noindent +This child subprogram is used for handling otherwise unhandled +exceptions (hence the name last chance), and perform clean ups before +terminating the program. Note that this subprogram never returns. + +@node Ada.Exceptions.Traceback (a-exctra.ads) +@section @code{Ada.Exceptions.Traceback} (@file{a-exctra.ads}) +@cindex @code{Ada.Exceptions.Traceback} (@file{a-exctra.ads}) +@cindex Traceback for Exception Occurrence + +@noindent +This child package provides the subprogram (@code{Tracebacks}) to +give a traceback array of addresses based on an exception +occurrence. + +@node Ada.Sequential_IO.C_Streams (a-siocst.ads) +@section @code{Ada.Sequential_IO.C_Streams} (@file{a-siocst.ads}) +@cindex @code{Ada.Sequential_IO.C_Streams} (@file{a-siocst.ads}) +@cindex C Streams, Interfacing with Sequential_IO + +@noindent +This package provides subprograms that allow interfacing between +C streams and @code{Sequential_IO}. The stream identifier can be +extracted from a file opened on the Ada side, and an Ada file +can be constructed from a stream opened on the C side. + +@node Ada.Streams.Stream_IO.C_Streams (a-ssicst.ads) +@section @code{Ada.Streams.Stream_IO.C_Streams} (@file{a-ssicst.ads}) +@cindex @code{Ada.Streams.Stream_IO.C_Streams} (@file{a-ssicst.ads}) +@cindex C Streams, Interfacing with Stream_IO + +@noindent +This package provides subprograms that allow interfacing between +C streams and @code{Stream_IO}. The stream identifier can be +extracted from a file opened on the Ada side, and an Ada file +can be constructed from a stream opened on the C side. + +@node Ada.Strings.Unbounded.Text_IO (a-suteio.ads) +@section @code{Ada.Strings.Unbounded.Text_IO} (@file{a-suteio.ads}) +@cindex @code{Ada.Strings.Unbounded.Text_IO} (@file{a-suteio.ads}) +@cindex @code{Unbounded_String}, IO support +@cindex @code{Text_IO}, extensions for unbounded strings + +@noindent +This package provides subprograms for Text_IO for unbounded +strings, avoiding the necessity for an intermediate operation +with ordinary strings. + +@node Ada.Strings.Wide_Unbounded.Wide_Text_IO (a-swuwti.ads) +@section @code{Ada.Strings.Wide_Unbounded.Wide_Text_IO} (@file{a-swuwti.ads}) +@cindex @code{Ada.Strings.Wide_Unbounded.Wide_Text_IO} (@file{a-swuwti.ads}) +@cindex @code{Unbounded_Wide_String}, IO support +@cindex @code{Text_IO}, extensions for unbounded wide strings + +@noindent +This package provides subprograms for Text_IO for unbounded +wide strings, avoiding the necessity for an intermediate operation +with ordinary wide strings. + +@node Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO (a-szuzti.ads) +@section @code{Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO} (@file{a-szuzti.ads}) +@cindex @code{Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO} (@file{a-szuzti.ads}) +@cindex @code{Unbounded_Wide_Wide_String}, IO support +@cindex @code{Text_IO}, extensions for unbounded wide wide strings + +@noindent +This package provides subprograms for Text_IO for unbounded +wide wide strings, avoiding the necessity for an intermediate operation +with ordinary wide wide strings. + +@node Ada.Text_IO.C_Streams (a-tiocst.ads) +@section @code{Ada.Text_IO.C_Streams} (@file{a-tiocst.ads}) +@cindex @code{Ada.Text_IO.C_Streams} (@file{a-tiocst.ads}) +@cindex C Streams, Interfacing with @code{Text_IO} + +@noindent +This package provides subprograms that allow interfacing between +C streams and @code{Text_IO}. The stream identifier can be +extracted from a file opened on the Ada side, and an Ada file +can be constructed from a stream opened on the C side. + +@node Ada.Text_IO.Reset_Standard_Files (a-tirsfi.ads) +@section @code{Ada.Text_IO.Reset_Standard_Files} (@file{a-tirsfi.ads}) +@cindex @code{Ada.Text_IO.Reset_Standard_Files} (@file{a-tirsfi.ads}) +@cindex @code{Text_IO} resetting standard files + +@noindent +This procedure is used to reset the status of the standard files used +by Ada.Text_IO. This is useful in a situation (such as a restart in an +embedded application) where the status of the files may change during +execution (for example a standard input file may be redefined to be +interactive). + +@node Ada.Wide_Characters.Unicode (a-wichun.ads) +@section @code{Ada.Wide_Characters.Unicode} (@file{a-wichun.ads}) +@cindex @code{Ada.Wide_Characters.Unicode} (@file{a-wichun.ads}) +@cindex Unicode categorization, Wide_Character + +@noindent +This package provides subprograms that allow categorization of +Wide_Character values according to Unicode categories. + +@node Ada.Wide_Text_IO.C_Streams (a-wtcstr.ads) +@section @code{Ada.Wide_Text_IO.C_Streams} (@file{a-wtcstr.ads}) +@cindex @code{Ada.Wide_Text_IO.C_Streams} (@file{a-wtcstr.ads}) +@cindex C Streams, Interfacing with @code{Wide_Text_IO} + +@noindent +This package provides subprograms that allow interfacing between +C streams and @code{Wide_Text_IO}. The stream identifier can be +extracted from a file opened on the Ada side, and an Ada file +can be constructed from a stream opened on the C side. + +@node Ada.Wide_Text_IO.Reset_Standard_Files (a-wrstfi.ads) +@section @code{Ada.Wide_Text_IO.Reset_Standard_Files} (@file{a-wrstfi.ads}) +@cindex @code{Ada.Wide_Text_IO.Reset_Standard_Files} (@file{a-wrstfi.ads}) +@cindex @code{Wide_Text_IO} resetting standard files + +@noindent +This procedure is used to reset the status of the standard files used +by Ada.Wide_Text_IO. This is useful in a situation (such as a restart in an +embedded application) where the status of the files may change during +execution (for example a standard input file may be redefined to be +interactive). + +@node Ada.Wide_Wide_Characters.Unicode (a-zchuni.ads) +@section @code{Ada.Wide_Wide_Characters.Unicode} (@file{a-zchuni.ads}) +@cindex @code{Ada.Wide_Wide_Characters.Unicode} (@file{a-zchuni.ads}) +@cindex Unicode categorization, Wide_Wide_Character + +@noindent +This package provides subprograms that allow categorization of +Wide_Wide_Character values according to Unicode categories. + +@node Ada.Wide_Wide_Text_IO.C_Streams (a-ztcstr.ads) +@section @code{Ada.Wide_Wide_Text_IO.C_Streams} (@file{a-ztcstr.ads}) +@cindex @code{Ada.Wide_Wide_Text_IO.C_Streams} (@file{a-ztcstr.ads}) +@cindex C Streams, Interfacing with @code{Wide_Wide_Text_IO} + +@noindent +This package provides subprograms that allow interfacing between +C streams and @code{Wide_Wide_Text_IO}. The stream identifier can be +extracted from a file opened on the Ada side, and an Ada file +can be constructed from a stream opened on the C side. + +@node Ada.Wide_Wide_Text_IO.Reset_Standard_Files (a-zrstfi.ads) +@section @code{Ada.Wide_Wide_Text_IO.Reset_Standard_Files} (@file{a-zrstfi.ads}) +@cindex @code{Ada.Wide_Wide_Text_IO.Reset_Standard_Files} (@file{a-zrstfi.ads}) +@cindex @code{Wide_Wide_Text_IO} resetting standard files + +@noindent +This procedure is used to reset the status of the standard files used +by Ada.Wide_Wide_Text_IO. This is useful in a situation (such as a +restart in an embedded application) where the status of the files may +change during execution (for example a standard input file may be +redefined to be interactive). + +@node GNAT.Altivec (g-altive.ads) +@section @code{GNAT.Altivec} (@file{g-altive.ads}) +@cindex @code{GNAT.Altivec} (@file{g-altive.ads}) +@cindex AltiVec + +@noindent +This is the root package of the GNAT AltiVec binding. It provides +definitions of constants and types common to all the versions of the +binding. + +@node GNAT.Altivec.Conversions (g-altcon.ads) +@section @code{GNAT.Altivec.Conversions} (@file{g-altcon.ads}) +@cindex @code{GNAT.Altivec.Conversions} (@file{g-altcon.ads}) +@cindex AltiVec + +@noindent +This package provides the Vector/View conversion routines. + +@node GNAT.Altivec.Vector_Operations (g-alveop.ads) +@section @code{GNAT.Altivec.Vector_Operations} (@file{g-alveop.ads}) +@cindex @code{GNAT.Altivec.Vector_Operations} (@file{g-alveop.ads}) +@cindex AltiVec + +@noindent +This package exposes the Ada interface to the AltiVec operations on +vector objects. A soft emulation is included by default in the GNAT +library. The hard binding is provided as a separate package. This unit +is common to both bindings. + +@node GNAT.Altivec.Vector_Types (g-alvety.ads) +@section @code{GNAT.Altivec.Vector_Types} (@file{g-alvety.ads}) +@cindex @code{GNAT.Altivec.Vector_Types} (@file{g-alvety.ads}) +@cindex AltiVec + +@noindent +This package exposes the various vector types part of the Ada binding +to AltiVec facilities. + +@node GNAT.Altivec.Vector_Views (g-alvevi.ads) +@section @code{GNAT.Altivec.Vector_Views} (@file{g-alvevi.ads}) +@cindex @code{GNAT.Altivec.Vector_Views} (@file{g-alvevi.ads}) +@cindex AltiVec + +@noindent +This package provides public 'View' data types from/to which private +vector representations can be converted via +GNAT.Altivec.Conversions. This allows convenient access to individual +vector elements and provides a simple way to initialize vector +objects. + +@node GNAT.Array_Split (g-arrspl.ads) +@section @code{GNAT.Array_Split} (@file{g-arrspl.ads}) +@cindex @code{GNAT.Array_Split} (@file{g-arrspl.ads}) +@cindex Array splitter + +@noindent +Useful array-manipulation routines: given a set of separators, split +an array wherever the separators appear, and provide direct access +to the resulting slices. + +@node GNAT.AWK (g-awk.ads) +@section @code{GNAT.AWK} (@file{g-awk.ads}) +@cindex @code{GNAT.AWK} (@file{g-awk.ads}) +@cindex Parsing +@cindex AWK + +@noindent +Provides AWK-like parsing functions, with an easy interface for parsing one +or more files containing formatted data. The file is viewed as a database +where each record is a line and a field is a data element in this line. + +@node GNAT.Bounded_Buffers (g-boubuf.ads) +@section @code{GNAT.Bounded_Buffers} (@file{g-boubuf.ads}) +@cindex @code{GNAT.Bounded_Buffers} (@file{g-boubuf.ads}) +@cindex Parsing +@cindex Bounded Buffers + +@noindent +Provides a concurrent generic bounded buffer abstraction. Instances are +useful directly or as parts of the implementations of other abstractions, +such as mailboxes. + +@node GNAT.Bounded_Mailboxes (g-boumai.ads) +@section @code{GNAT.Bounded_Mailboxes} (@file{g-boumai.ads}) +@cindex @code{GNAT.Bounded_Mailboxes} (@file{g-boumai.ads}) +@cindex Parsing +@cindex Mailboxes + +@noindent +Provides a thread-safe asynchronous intertask mailbox communication facility. + +@node GNAT.Bubble_Sort (g-bubsor.ads) +@section @code{GNAT.Bubble_Sort} (@file{g-bubsor.ads}) +@cindex @code{GNAT.Bubble_Sort} (@file{g-bubsor.ads}) +@cindex Sorting +@cindex Bubble sort + +@noindent +Provides a general implementation of bubble sort usable for sorting arbitrary +data items. Exchange and comparison procedures are provided by passing +access-to-procedure values. + +@node GNAT.Bubble_Sort_A (g-busora.ads) +@section @code{GNAT.Bubble_Sort_A} (@file{g-busora.ads}) +@cindex @code{GNAT.Bubble_Sort_A} (@file{g-busora.ads}) +@cindex Sorting +@cindex Bubble sort + +@noindent +Provides a general implementation of bubble sort usable for sorting arbitrary +data items. Move and comparison procedures are provided by passing +access-to-procedure values. This is an older version, retained for +compatibility. Usually @code{GNAT.Bubble_Sort} will be preferable. + +@node GNAT.Bubble_Sort_G (g-busorg.ads) +@section @code{GNAT.Bubble_Sort_G} (@file{g-busorg.ads}) +@cindex @code{GNAT.Bubble_Sort_G} (@file{g-busorg.ads}) +@cindex Sorting +@cindex Bubble sort + +@noindent +Similar to @code{Bubble_Sort_A} except that the move and sorting procedures +are provided as generic parameters, this improves efficiency, especially +if the procedures can be inlined, at the expense of duplicating code for +multiple instantiations. + +@node GNAT.Byte_Order_Mark (g-byorma.ads) +@section @code{GNAT.Byte_Order_Mark} (@file{g-byorma.ads}) +@cindex @code{GNAT.Byte_Order_Mark} (@file{g-byorma.ads}) +@cindex UTF-8 representation +@cindex Wide characte representations + +@noindent +Provides a routine which given a string, reads the start of the string to +see whether it is one of the standard byte order marks (BOM's) which signal +the encoding of the string. The routine includes detection of special XML +sequences for various UCS input formats. + +@node GNAT.Byte_Swapping (g-bytswa.ads) +@section @code{GNAT.Byte_Swapping} (@file{g-bytswa.ads}) +@cindex @code{GNAT.Byte_Swapping} (@file{g-bytswa.ads}) +@cindex Byte swapping +@cindex Endian + +@noindent +General routines for swapping the bytes in 2-, 4-, and 8-byte quantities. +Machine-specific implementations are available in some cases. + +@node GNAT.Calendar (g-calend.ads) +@section @code{GNAT.Calendar} (@file{g-calend.ads}) +@cindex @code{GNAT.Calendar} (@file{g-calend.ads}) +@cindex @code{Calendar} + +@noindent +Extends the facilities provided by @code{Ada.Calendar} to include handling +of days of the week, an extended @code{Split} and @code{Time_Of} capability. +Also provides conversion of @code{Ada.Calendar.Time} values to and from the +C @code{timeval} format. + +@node GNAT.Calendar.Time_IO (g-catiio.ads) +@section @code{GNAT.Calendar.Time_IO} (@file{g-catiio.ads}) +@cindex @code{Calendar} +@cindex Time +@cindex @code{GNAT.Calendar.Time_IO} (@file{g-catiio.ads}) + +@node GNAT.CRC32 (g-crc32.ads) +@section @code{GNAT.CRC32} (@file{g-crc32.ads}) +@cindex @code{GNAT.CRC32} (@file{g-crc32.ads}) +@cindex CRC32 +@cindex Cyclic Redundancy Check + +@noindent +This package implements the CRC-32 algorithm. For a full description +of this algorithm see +``Computation of Cyclic Redundancy Checks via Table Look-Up'', +@cite{Communications of the ACM}, Vol.@: 31 No.@: 8, pp.@: 1008-1013, +Aug.@: 1988. Sarwate, D.V@. + +@node GNAT.Case_Util (g-casuti.ads) +@section @code{GNAT.Case_Util} (@file{g-casuti.ads}) +@cindex @code{GNAT.Case_Util} (@file{g-casuti.ads}) +@cindex Casing utilities +@cindex Character handling (@code{GNAT.Case_Util}) + +@noindent +A set of simple routines for handling upper and lower casing of strings +without the overhead of the full casing tables +in @code{Ada.Characters.Handling}. + +@node GNAT.CGI (g-cgi.ads) +@section @code{GNAT.CGI} (@file{g-cgi.ads}) +@cindex @code{GNAT.CGI} (@file{g-cgi.ads}) +@cindex CGI (Common Gateway Interface) + +@noindent +This is a package for interfacing a GNAT program with a Web server via the +Common Gateway Interface (CGI)@. Basically this package parses the CGI +parameters, which are a set of key/value pairs sent by the Web server. It +builds a table whose index is the key and provides some services to deal +with this table. + +@node GNAT.CGI.Cookie (g-cgicoo.ads) +@section @code{GNAT.CGI.Cookie} (@file{g-cgicoo.ads}) +@cindex @code{GNAT.CGI.Cookie} (@file{g-cgicoo.ads}) +@cindex CGI (Common Gateway Interface) cookie support +@cindex Cookie support in CGI + +@noindent +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). + +@node GNAT.CGI.Debug (g-cgideb.ads) +@section @code{GNAT.CGI.Debug} (@file{g-cgideb.ads}) +@cindex @code{GNAT.CGI.Debug} (@file{g-cgideb.ads}) +@cindex CGI (Common Gateway Interface) debugging + +@noindent +This is a package to help debugging CGI (Common Gateway Interface) +programs written in Ada. + +@node GNAT.Command_Line (g-comlin.ads) +@section @code{GNAT.Command_Line} (@file{g-comlin.ads}) +@cindex @code{GNAT.Command_Line} (@file{g-comlin.ads}) +@cindex Command line + +@noindent +Provides a high level interface to @code{Ada.Command_Line} facilities, +including the ability to scan for named switches with optional parameters +and expand file names using wild card notations. + +@node GNAT.Compiler_Version (g-comver.ads) +@section @code{GNAT.Compiler_Version} (@file{g-comver.ads}) +@cindex @code{GNAT.Compiler_Version} (@file{g-comver.ads}) +@cindex Compiler Version +@cindex Version, of compiler + +@noindent +Provides a routine for obtaining the version of the compiler used to +compile the program. More accurately this is the version of the binder +used to bind the program (this will normally be the same as the version +of the compiler if a consistent tool set is used to compile all units +of a partition). + +@node GNAT.Ctrl_C (g-ctrl_c.ads) +@section @code{GNAT.Ctrl_C} (@file{g-ctrl_c.ads}) +@cindex @code{GNAT.Ctrl_C} (@file{g-ctrl_c.ads}) +@cindex Interrupt + +@noindent +Provides a simple interface to handle Ctrl-C keyboard events. + +@node GNAT.Current_Exception (g-curexc.ads) +@section @code{GNAT.Current_Exception} (@file{g-curexc.ads}) +@cindex @code{GNAT.Current_Exception} (@file{g-curexc.ads}) +@cindex Current exception +@cindex Exception retrieval + +@noindent +Provides access to information on the current exception that has been raised +without the need for using the Ada 95 / Ada 2005 exception choice parameter +specification syntax. +This is particularly useful in simulating typical facilities for +obtaining information about exceptions provided by Ada 83 compilers. + +@node GNAT.Debug_Pools (g-debpoo.ads) +@section @code{GNAT.Debug_Pools} (@file{g-debpoo.ads}) +@cindex @code{GNAT.Debug_Pools} (@file{g-debpoo.ads}) +@cindex Debugging +@cindex Debug pools +@cindex Memory corruption debugging + +@noindent +Provide a debugging storage pools that helps tracking memory corruption +problems. @xref{The GNAT Debug Pool Facility,,, gnat_ugn, +@value{EDITION} User's Guide}. + +@node GNAT.Debug_Utilities (g-debuti.ads) +@section @code{GNAT.Debug_Utilities} (@file{g-debuti.ads}) +@cindex @code{GNAT.Debug_Utilities} (@file{g-debuti.ads}) +@cindex Debugging + +@noindent +Provides a few useful utilities for debugging purposes, including conversion +to and from string images of address values. Supports both C and Ada formats +for hexadecimal literals. + +@node GNAT.Decode_String (g-decstr.ads) +@section @code{GNAT.Decode_String} (@file{g-decstr.ads}) +@cindex @code{GNAT.Decode_String} (@file{g-decstr.ads}) +@cindex Decoding strings +@cindex String decoding +@cindex Wide character encoding +@cindex UTF-8 +@cindex Unicode + +@noindent +A generic package providing routines for decoding wide character and wide wide +character strings encoded as sequences of 8-bit characters using a specified +encoding method. Includes validation routines, and also routines for stepping +to next or previous encoded character in an encoded string. +Useful in conjunction with Unicode character coding. Note there is a +preinstantiation for UTF-8. See next entry. + +@node GNAT.Decode_UTF8_String (g-deutst.ads) +@section @code{GNAT.Decode_UTF8_String} (@file{g-deutst.ads}) +@cindex @code{GNAT.Decode_UTF8_String} (@file{g-deutst.ads}) +@cindex Decoding strings +@cindex Decoding UTF-8 strings +@cindex UTF-8 string decoding +@cindex Wide character decoding +@cindex UTF-8 +@cindex Unicode + +@noindent +A preinstantiation of GNAT.Decode_Strings for UTF-8 encoding. + +@node GNAT.Directory_Operations (g-dirope.ads) +@section @code{GNAT.Directory_Operations} (@file{g-dirope.ads}) +@cindex @code{GNAT.Directory_Operations} (@file{g-dirope.ads}) +@cindex Directory operations + +@noindent +Provides a set of routines for manipulating directories, including changing +the current directory, making new directories, and scanning the files in a +directory. + +@node GNAT.Directory_Operations.Iteration (g-diopit.ads) +@section @code{GNAT.Directory_Operations.Iteration} (@file{g-diopit.ads}) +@cindex @code{GNAT.Directory_Operations.Iteration} (@file{g-diopit.ads}) +@cindex Directory operations iteration + +@noindent +A child unit of GNAT.Directory_Operations providing additional operations +for iterating through directories. + +@node GNAT.Dynamic_HTables (g-dynhta.ads) +@section @code{GNAT.Dynamic_HTables} (@file{g-dynhta.ads}) +@cindex @code{GNAT.Dynamic_HTables} (@file{g-dynhta.ads}) +@cindex Hash tables + +@noindent +A generic implementation of hash tables that can be used to hash arbitrary +data. Provided in two forms, a simple form with built in hash functions, +and a more complex form in which the hash function is supplied. + +@noindent +This package provides a facility similar to that of @code{GNAT.HTable}, +except that this package declares a type that can be used to define +dynamic instances of the hash table, while an instantiation of +@code{GNAT.HTable} creates a single instance of the hash table. + +@node GNAT.Dynamic_Tables (g-dyntab.ads) +@section @code{GNAT.Dynamic_Tables} (@file{g-dyntab.ads}) +@cindex @code{GNAT.Dynamic_Tables} (@file{g-dyntab.ads}) +@cindex Table implementation +@cindex Arrays, extendable + +@noindent +A generic package providing a single dimension array abstraction where the +length of the array can be dynamically modified. + +@noindent +This package provides a facility similar to that of @code{GNAT.Table}, +except that this package declares a type that can be used to define +dynamic instances of the table, while an instantiation of +@code{GNAT.Table} creates a single instance of the table type. + +@node GNAT.Encode_String (g-encstr.ads) +@section @code{GNAT.Encode_String} (@file{g-encstr.ads}) +@cindex @code{GNAT.Encode_String} (@file{g-encstr.ads}) +@cindex Encoding strings +@cindex String encoding +@cindex Wide character encoding +@cindex UTF-8 +@cindex Unicode + +@noindent +A generic package providing routines for encoding wide character and wide +wide character strings as sequences of 8-bit characters using a specified +encoding method. Useful in conjunction with Unicode character coding. +Note there is a preinstantiation for UTF-8. See next entry. + +@node GNAT.Encode_UTF8_String (g-enutst.ads) +@section @code{GNAT.Encode_UTF8_String} (@file{g-enutst.ads}) +@cindex @code{GNAT.Encode_UTF8_String} (@file{g-enutst.ads}) +@cindex Encoding strings +@cindex Encoding UTF-8 strings +@cindex UTF-8 string encoding +@cindex Wide character encoding +@cindex UTF-8 +@cindex Unicode + +@noindent +A preinstantiation of GNAT.Encode_Strings for UTF-8 encoding. + +@node GNAT.Exception_Actions (g-excact.ads) +@section @code{GNAT.Exception_Actions} (@file{g-excact.ads}) +@cindex @code{GNAT.Exception_Actions} (@file{g-excact.ads}) +@cindex Exception actions + +@noindent +Provides callbacks when an exception is raised. Callbacks can be registered +for specific exceptions, or when any exception is raised. This +can be used for instance to force a core dump to ease debugging. + +@node GNAT.Exception_Traces (g-exctra.ads) +@section @code{GNAT.Exception_Traces} (@file{g-exctra.ads}) +@cindex @code{GNAT.Exception_Traces} (@file{g-exctra.ads}) +@cindex Exception traces +@cindex Debugging + +@noindent +Provides an interface allowing to control automatic output upon exception +occurrences. + +@node GNAT.Exceptions (g-except.ads) +@section @code{GNAT.Exceptions} (@file{g-expect.ads}) +@cindex @code{GNAT.Exceptions} (@file{g-expect.ads}) +@cindex Exceptions, Pure +@cindex Pure packages, exceptions + +@noindent +Normally it is not possible to raise an exception with +a message from a subprogram in a pure package, since the +necessary types and subprograms are in @code{Ada.Exceptions} +which is not a pure unit. @code{GNAT.Exceptions} provides a +facility for getting around this limitation for a few +predefined exceptions, and for example allow raising +@code{Constraint_Error} with a message from a pure subprogram. + +@node GNAT.Expect (g-expect.ads) +@section @code{GNAT.Expect} (@file{g-expect.ads}) +@cindex @code{GNAT.Expect} (@file{g-expect.ads}) + +@noindent +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. Currently @code{GNAT.Expect} +is implemented on all native GNAT ports except for OpenVMS@. +It is not implemented for cross ports, and in particular is not +implemented for VxWorks or LynxOS@. + +@node GNAT.Float_Control (g-flocon.ads) +@section @code{GNAT.Float_Control} (@file{g-flocon.ads}) +@cindex @code{GNAT.Float_Control} (@file{g-flocon.ads}) +@cindex Floating-Point Processor + +@noindent +Provides an interface for resetting the floating-point processor into the +mode required for correct semantic operation in Ada. Some third party +library calls may cause this mode to be modified, and the Reset procedure +in this package can be used to reestablish the required mode. + +@node GNAT.Heap_Sort (g-heasor.ads) +@section @code{GNAT.Heap_Sort} (@file{g-heasor.ads}) +@cindex @code{GNAT.Heap_Sort} (@file{g-heasor.ads}) +@cindex Sorting + +@noindent +Provides a general implementation of heap sort usable for sorting arbitrary +data items. Exchange and comparison procedures are provided by passing +access-to-procedure values. The algorithm used is a modified heap sort +that performs approximately N*log(N) comparisons in the worst case. + +@node GNAT.Heap_Sort_A (g-hesora.ads) +@section @code{GNAT.Heap_Sort_A} (@file{g-hesora.ads}) +@cindex @code{GNAT.Heap_Sort_A} (@file{g-hesora.ads}) +@cindex Sorting + +@noindent +Provides a general implementation of heap sort usable for sorting arbitrary +data items. Move and comparison procedures are provided by passing +access-to-procedure values. The algorithm used is a modified heap sort +that performs approximately N*log(N) comparisons in the worst case. +This differs from @code{GNAT.Heap_Sort} in having a less convenient +interface, but may be slightly more efficient. + +@node GNAT.Heap_Sort_G (g-hesorg.ads) +@section @code{GNAT.Heap_Sort_G} (@file{g-hesorg.ads}) +@cindex @code{GNAT.Heap_Sort_G} (@file{g-hesorg.ads}) +@cindex Sorting + +@noindent +Similar to @code{Heap_Sort_A} except that the move and sorting procedures +are provided as generic parameters, this improves efficiency, especially +if the procedures can be inlined, at the expense of duplicating code for +multiple instantiations. + +@node GNAT.HTable (g-htable.ads) +@section @code{GNAT.HTable} (@file{g-htable.ads}) +@cindex @code{GNAT.HTable} (@file{g-htable.ads}) +@cindex Hash tables + +@noindent +A generic implementation of hash tables that can be used to hash arbitrary +data. Provides two approaches, one a simple static approach, and the other +allowing arbitrary dynamic hash tables. + +@node GNAT.IO (g-io.ads) +@section @code{GNAT.IO} (@file{g-io.ads}) +@cindex @code{GNAT.IO} (@file{g-io.ads}) +@cindex Simple I/O +@cindex Input/Output facilities + +@noindent +A simple preelaborable input-output package that provides a subset of +simple Text_IO functions for reading characters and strings from +Standard_Input, and writing characters, strings and integers to either +Standard_Output or Standard_Error. + +@node GNAT.IO_Aux (g-io_aux.ads) +@section @code{GNAT.IO_Aux} (@file{g-io_aux.ads}) +@cindex @code{GNAT.IO_Aux} (@file{g-io_aux.ads}) +@cindex Text_IO +@cindex Input/Output facilities + +Provides some auxiliary functions for use with Text_IO, including a test +for whether a file exists, and functions for reading a line of text. + +@node GNAT.Lock_Files (g-locfil.ads) +@section @code{GNAT.Lock_Files} (@file{g-locfil.ads}) +@cindex @code{GNAT.Lock_Files} (@file{g-locfil.ads}) +@cindex File locking +@cindex Locking using files + +@noindent +Provides a general interface for using files as locks. Can be used for +providing program level synchronization. + +@node GNAT.MBBS_Discrete_Random (g-mbdira.ads) +@section @code{GNAT.MBBS_Discrete_Random} (@file{g-mbdira.ads}) +@cindex @code{GNAT.MBBS_Discrete_Random} (@file{g-mbdira.ads}) +@cindex Random number generation + +@noindent +The original implementation of @code{Ada.Numerics.Discrete_Random}. Uses +a modified version of the Blum-Blum-Shub generator. + +@node GNAT.MBBS_Float_Random (g-mbflra.ads) +@section @code{GNAT.MBBS_Float_Random} (@file{g-mbflra.ads}) +@cindex @code{GNAT.MBBS_Float_Random} (@file{g-mbflra.ads}) +@cindex Random number generation + +@noindent +The original implementation of @code{Ada.Numerics.Float_Random}. Uses +a modified version of the Blum-Blum-Shub generator. + +@node GNAT.MD5 (g-md5.ads) +@section @code{GNAT.MD5} (@file{g-md5.ads}) +@cindex @code{GNAT.MD5} (@file{g-md5.ads}) +@cindex Message Digest MD5 + +@noindent +Implements the MD5 Message-Digest Algorithm as described in RFC 1321. + +@node GNAT.Memory_Dump (g-memdum.ads) +@section @code{GNAT.Memory_Dump} (@file{g-memdum.ads}) +@cindex @code{GNAT.Memory_Dump} (@file{g-memdum.ads}) +@cindex Dump Memory + +@noindent +Provides a convenient routine for dumping raw memory to either the +standard output or standard error files. Uses GNAT.IO for actual +output. + +@node GNAT.Most_Recent_Exception (g-moreex.ads) +@section @code{GNAT.Most_Recent_Exception} (@file{g-moreex.ads}) +@cindex @code{GNAT.Most_Recent_Exception} (@file{g-moreex.ads}) +@cindex Exception, obtaining most recent + +@noindent +Provides access to the most recently raised exception. Can be used for +various logging purposes, including duplicating functionality of some +Ada 83 implementation dependent extensions. + +@node GNAT.OS_Lib (g-os_lib.ads) +@section @code{GNAT.OS_Lib} (@file{g-os_lib.ads}) +@cindex @code{GNAT.OS_Lib} (@file{g-os_lib.ads}) +@cindex Operating System interface +@cindex Spawn capability + +@noindent +Provides a range of target independent operating system interface functions, +including time/date management, file operations, subprocess management, +including a portable spawn procedure, and access to environment variables +and error return codes. + +@node GNAT.Perfect_Hash_Generators (g-pehage.ads) +@section @code{GNAT.Perfect_Hash_Generators} (@file{g-pehage.ads}) +@cindex @code{GNAT.Perfect_Hash_Generators} (@file{g-pehage.ads}) +@cindex Hash functions + +@noindent +Provides a generator of static minimal perfect hash functions. No +collisions occur and each item can be retrieved from the table in one +probe (perfect property). The hash table size corresponds to the exact +size of the key set and no larger (minimal property). The key set has to +be know in advance (static property). The hash functions are also order +preserving. If w2 is inserted after w1 in the generator, their +hashcode are in the same order. These hashing functions are very +convenient for use with realtime applications. + +@node GNAT.Random_Numbers (g-rannum.ads) +@section @code{GNAT.Random_Numbers} (@file{g-rannum.ads}) +@cindex @code{GNAT.Random_Numbers} (@file{g-rannum.ads}) +@cindex Random number generation + +@noindent +Provides random number capabilities which extend those available in the +standard Ada library and are more convenient to use. + +@node GNAT.Regexp (g-regexp.ads) +@section @code{GNAT.Regexp} (@file{g-regexp.ads}) +@cindex @code{GNAT.Regexp} (@file{g-regexp.ads}) +@cindex Regular expressions +@cindex Pattern matching + +@noindent +A simple implementation of regular expressions, using a subset of regular +expression syntax copied from familiar Unix style utilities. This is the +simples of the three pattern matching packages provided, and is particularly +suitable for ``file globbing'' applications. + +@node GNAT.Registry (g-regist.ads) +@section @code{GNAT.Registry} (@file{g-regist.ads}) +@cindex @code{GNAT.Registry} (@file{g-regist.ads}) +@cindex Windows Registry + +@noindent +This is a high level binding to the Windows registry. It is possible to +do simple things like reading a key value, creating a new key. For full +registry API, but at a lower level of abstraction, refer to the Win32.Winreg +package provided with the Win32Ada binding + +@node GNAT.Regpat (g-regpat.ads) +@section @code{GNAT.Regpat} (@file{g-regpat.ads}) +@cindex @code{GNAT.Regpat} (@file{g-regpat.ads}) +@cindex Regular expressions +@cindex Pattern matching + +@noindent +A complete implementation of Unix-style regular expression matching, copied +from the original V7 style regular expression library written in C by +Henry Spencer (and binary compatible with this C library). + +@node GNAT.Secondary_Stack_Info (g-sestin.ads) +@section @code{GNAT.Secondary_Stack_Info} (@file{g-sestin.ads}) +@cindex @code{GNAT.Secondary_Stack_Info} (@file{g-sestin.ads}) +@cindex Secondary Stack Info + +@noindent +Provide the capability to query the high water mark of the current task's +secondary stack. + +@node GNAT.Semaphores (g-semaph.ads) +@section @code{GNAT.Semaphores} (@file{g-semaph.ads}) +@cindex @code{GNAT.Semaphores} (@file{g-semaph.ads}) +@cindex Semaphores + +@noindent +Provides classic counting and binary semaphores using protected types. + +@node GNAT.Serial_Communications (g-sercom.ads) +@section @code{GNAT.Serial_Communications} (@file{g-sercom.ads}) +@cindex @code{GNAT.Serial_Communications} (@file{g-sercom.ads}) +@cindex Serial_Communications + +@noindent +Provides a simple interface to send and receive data over a serial +port. This is only supported on GNU/Linux and Windows. + +@node GNAT.SHA1 (g-sha1.ads) +@section @code{GNAT.SHA1} (@file{g-sha1.ads}) +@cindex @code{GNAT.SHA1} (@file{g-sha1.ads}) +@cindex Secure Hash Algorithm SHA-1 + +@noindent +Implements the SHA-1 Secure Hash Algorithm as described in FIPS PUB 180-3 +and RFC 3174. + +@node GNAT.SHA224 (g-sha224.ads) +@section @code{GNAT.SHA224} (@file{g-sha224.ads}) +@cindex @code{GNAT.SHA224} (@file{g-sha224.ads}) +@cindex Secure Hash Algorithm SHA-224 + +@noindent +Implements the SHA-224 Secure Hash Algorithm as described in FIPS PUB 180-3. + +@node GNAT.SHA256 (g-sha256.ads) +@section @code{GNAT.SHA256} (@file{g-sha256.ads}) +@cindex @code{GNAT.SHA256} (@file{g-sha256.ads}) +@cindex Secure Hash Algorithm SHA-256 + +@noindent +Implements the SHA-256 Secure Hash Algorithm as described in FIPS PUB 180-3. + +@node GNAT.SHA384 (g-sha384.ads) +@section @code{GNAT.SHA384} (@file{g-sha384.ads}) +@cindex @code{GNAT.SHA384} (@file{g-sha384.ads}) +@cindex Secure Hash Algorithm SHA-384 + +@noindent +Implements the SHA-384 Secure Hash Algorithm as described in FIPS PUB 180-3. + +@node GNAT.SHA512 (g-sha512.ads) +@section @code{GNAT.SHA512} (@file{g-sha512.ads}) +@cindex @code{GNAT.SHA512} (@file{g-sha512.ads}) +@cindex Secure Hash Algorithm SHA-512 + +@noindent +Implements the SHA-512 Secure Hash Algorithm as described in FIPS PUB 180-3. + +@node GNAT.Signals (g-signal.ads) +@section @code{GNAT.Signals} (@file{g-signal.ads}) +@cindex @code{GNAT.Signals} (@file{g-signal.ads}) +@cindex Signals + +@noindent +Provides the ability to manipulate the blocked status of signals on supported +targets. + +@node GNAT.Sockets (g-socket.ads) +@section @code{GNAT.Sockets} (@file{g-socket.ads}) +@cindex @code{GNAT.Sockets} (@file{g-socket.ads}) +@cindex Sockets + +@noindent +A high level and portable interface to develop sockets based applications. +This package is based on the sockets thin binding found in +@code{GNAT.Sockets.Thin}. Currently @code{GNAT.Sockets} is implemented +on all native GNAT ports except for OpenVMS@. It is not implemented +for the LynxOS@ cross port. + +@node GNAT.Source_Info (g-souinf.ads) +@section @code{GNAT.Source_Info} (@file{g-souinf.ads}) +@cindex @code{GNAT.Source_Info} (@file{g-souinf.ads}) +@cindex Source Information + +@noindent +Provides subprograms that give access to source code information known at +compile time, such as the current file name and line number. + +@node GNAT.Spelling_Checker (g-speche.ads) +@section @code{GNAT.Spelling_Checker} (@file{g-speche.ads}) +@cindex @code{GNAT.Spelling_Checker} (@file{g-speche.ads}) +@cindex Spell checking + +@noindent +Provides a function for determining whether one string is a plausible +near misspelling of another string. + +@node GNAT.Spelling_Checker_Generic (g-spchge.ads) +@section @code{GNAT.Spelling_Checker_Generic} (@file{g-spchge.ads}) +@cindex @code{GNAT.Spelling_Checker_Generic} (@file{g-spchge.ads}) +@cindex Spell checking + +@noindent +Provides a generic function that can be instantiated with a string type for +determining whether one string is a plausible near misspelling of another +string. + +@node GNAT.Spitbol.Patterns (g-spipat.ads) +@section @code{GNAT.Spitbol.Patterns} (@file{g-spipat.ads}) +@cindex @code{GNAT.Spitbol.Patterns} (@file{g-spipat.ads}) +@cindex SPITBOL pattern matching +@cindex Pattern matching + +@noindent +A complete implementation of SNOBOL4 style pattern matching. This is the +most elaborate of the pattern matching packages provided. It fully duplicates +the SNOBOL4 dynamic pattern construction and matching capabilities, using the +efficient algorithm developed by Robert Dewar for the SPITBOL system. + +@node GNAT.Spitbol (g-spitbo.ads) +@section @code{GNAT.Spitbol} (@file{g-spitbo.ads}) +@cindex @code{GNAT.Spitbol} (@file{g-spitbo.ads}) +@cindex SPITBOL interface + +@noindent +The top level package of the collection of SPITBOL-style functionality, this +package provides basic SNOBOL4 string manipulation functions, such as +Pad, Reverse, Trim, Substr capability, as well as a generic table function +useful for constructing arbitrary mappings from strings in the style of +the SNOBOL4 TABLE function. + +@node GNAT.Spitbol.Table_Boolean (g-sptabo.ads) +@section @code{GNAT.Spitbol.Table_Boolean} (@file{g-sptabo.ads}) +@cindex @code{GNAT.Spitbol.Table_Boolean} (@file{g-sptabo.ads}) +@cindex Sets of strings +@cindex SPITBOL Tables + +@noindent +A library level of instantiation of @code{GNAT.Spitbol.Patterns.Table} +for type @code{Standard.Boolean}, giving an implementation of sets of +string values. + +@node GNAT.Spitbol.Table_Integer (g-sptain.ads) +@section @code{GNAT.Spitbol.Table_Integer} (@file{g-sptain.ads}) +@cindex @code{GNAT.Spitbol.Table_Integer} (@file{g-sptain.ads}) +@cindex Integer maps +@cindex Maps +@cindex SPITBOL Tables + +@noindent +A library level of instantiation of @code{GNAT.Spitbol.Patterns.Table} +for type @code{Standard.Integer}, giving an implementation of maps +from string to integer values. + +@node GNAT.Spitbol.Table_VString (g-sptavs.ads) +@section @code{GNAT.Spitbol.Table_VString} (@file{g-sptavs.ads}) +@cindex @code{GNAT.Spitbol.Table_VString} (@file{g-sptavs.ads}) +@cindex String maps +@cindex Maps +@cindex SPITBOL Tables + +@noindent +A library level of instantiation of @code{GNAT.Spitbol.Patterns.Table} for +a variable length string type, giving an implementation of general +maps from strings to strings. + +@node GNAT.SSE (g-sse.ads) +@section @code{GNAT.SSE} (@file{g-sse.ads}) +@cindex @code{GNAT.SSE} (@file{g-sse.ads}) + +@noindent +Root of a set of units aimed at offering Ada bindings to a subset of +the Intel(r) Streaming SIMD Extensions with GNAT on the x86 family of +targets. It exposes vector component types together with a general +introduction to the binding contents and use. + +@node GNAT.SSE.Vector_Types (g-ssvety.ads) +@section @code{GNAT.SSE.Vector_Types} (@file{g-ssvety.ads}) +@cindex @code{GNAT.SSE.Vector_Types} (@file{g-ssvety.ads}) + +@noindent +SSE vector types for use with SSE related intrinsics. + +@node GNAT.Strings (g-string.ads) +@section @code{GNAT.Strings} (@file{g-string.ads}) +@cindex @code{GNAT.Strings} (@file{g-string.ads}) + +@noindent +Common String access types and related subprograms. Basically it +defines a string access and an array of string access types. + +@node GNAT.String_Split (g-strspl.ads) +@section @code{GNAT.String_Split} (@file{g-strspl.ads}) +@cindex @code{GNAT.String_Split} (@file{g-strspl.ads}) +@cindex String splitter + +@noindent +Useful string manipulation routines: given a set of separators, split +a string wherever the separators appear, and provide direct access +to the resulting slices. This package is instantiated from +@code{GNAT.Array_Split}. + +@node GNAT.Table (g-table.ads) +@section @code{GNAT.Table} (@file{g-table.ads}) +@cindex @code{GNAT.Table} (@file{g-table.ads}) +@cindex Table implementation +@cindex Arrays, extendable + +@noindent +A generic package providing a single dimension array abstraction where the +length of the array can be dynamically modified. + +@noindent +This package provides a facility similar to that of @code{GNAT.Dynamic_Tables}, +except that this package declares a single instance of the table type, +while an instantiation of @code{GNAT.Dynamic_Tables} creates a type that can be +used to define dynamic instances of the table. + +@node GNAT.Task_Lock (g-tasloc.ads) +@section @code{GNAT.Task_Lock} (@file{g-tasloc.ads}) +@cindex @code{GNAT.Task_Lock} (@file{g-tasloc.ads}) +@cindex Task synchronization +@cindex Task locking +@cindex Locking + +@noindent +A very simple facility for locking and unlocking sections of code using a +single global task lock. Appropriate for use in situations where contention +between tasks is very rarely expected. + +@node GNAT.Time_Stamp (g-timsta.ads) +@section @code{GNAT.Time_Stamp} (@file{g-timsta.ads}) +@cindex @code{GNAT.Time_Stamp} (@file{g-timsta.ads}) +@cindex Time stamp +@cindex Current time + +@noindent +Provides a simple function that returns a string YYYY-MM-DD HH:MM:SS.SS that +represents the current date and time in ISO 8601 format. This is a very simple +routine with minimal code and there are no dependencies on any other unit. + +@node GNAT.Threads (g-thread.ads) +@section @code{GNAT.Threads} (@file{g-thread.ads}) +@cindex @code{GNAT.Threads} (@file{g-thread.ads}) +@cindex Foreign threads +@cindex Threads, foreign + +@noindent +Provides facilities for dealing with foreign threads which need to be known +by the GNAT run-time system. Consult the documentation of this package for +further details if your program has threads that are created by a non-Ada +environment which then accesses Ada code. + +@node GNAT.Traceback (g-traceb.ads) +@section @code{GNAT.Traceback} (@file{g-traceb.ads}) +@cindex @code{GNAT.Traceback} (@file{g-traceb.ads}) +@cindex Trace back facilities + +@noindent +Provides a facility for obtaining non-symbolic traceback information, useful +in various debugging situations. + +@node GNAT.Traceback.Symbolic (g-trasym.ads) +@section @code{GNAT.Traceback.Symbolic} (@file{g-trasym.ads}) +@cindex @code{GNAT.Traceback.Symbolic} (@file{g-trasym.ads}) +@cindex Trace back facilities + +@node GNAT.UTF_32 (g-utf_32.ads) +@section @code{GNAT.UTF_32} (@file{g-table.ads}) +@cindex @code{GNAT.UTF_32} (@file{g-table.ads}) +@cindex Wide character codes + +@noindent +This is a package intended to be used in conjunction with the +@code{Wide_Character} type in Ada 95 and the +@code{Wide_Wide_Character} type in Ada 2005 (available +in @code{GNAT} in Ada 2005 mode). This package contains +Unicode categorization routines, as well as lexical +categorization routines corresponding to the Ada 2005 +lexical rules for identifiers and strings, and also a +lower case to upper case fold routine corresponding to +the Ada 2005 rules for identifier equivalence. + +@node GNAT.UTF_32_Spelling_Checker (g-u3spch.ads) +@section @code{GNAT.Wide_Spelling_Checker} (@file{g-u3spch.ads}) +@cindex @code{GNAT.Wide_Spelling_Checker} (@file{g-u3spch.ads}) +@cindex Spell checking + +@noindent +Provides a function for determining whether one wide wide string is a plausible +near misspelling of another wide wide string, where the strings are represented +using the UTF_32_String type defined in System.Wch_Cnv. + +@node GNAT.Wide_Spelling_Checker (g-wispch.ads) +@section @code{GNAT.Wide_Spelling_Checker} (@file{g-wispch.ads}) +@cindex @code{GNAT.Wide_Spelling_Checker} (@file{g-wispch.ads}) +@cindex Spell checking + +@noindent +Provides a function for determining whether one wide string is a plausible +near misspelling of another wide string. + +@node GNAT.Wide_String_Split (g-wistsp.ads) +@section @code{GNAT.Wide_String_Split} (@file{g-wistsp.ads}) +@cindex @code{GNAT.Wide_String_Split} (@file{g-wistsp.ads}) +@cindex Wide_String splitter + +@noindent +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. This package is instantiated from +@code{GNAT.Array_Split}. + +@node GNAT.Wide_Wide_Spelling_Checker (g-zspche.ads) +@section @code{GNAT.Wide_Wide_Spelling_Checker} (@file{g-zspche.ads}) +@cindex @code{GNAT.Wide_Wide_Spelling_Checker} (@file{g-zspche.ads}) +@cindex Spell checking + +@noindent +Provides a function for determining whether one wide wide string is a plausible +near misspelling of another wide wide string. + +@node GNAT.Wide_Wide_String_Split (g-zistsp.ads) +@section @code{GNAT.Wide_Wide_String_Split} (@file{g-zistsp.ads}) +@cindex @code{GNAT.Wide_Wide_String_Split} (@file{g-zistsp.ads}) +@cindex Wide_Wide_String splitter + +@noindent +Useful wide wide string manipulation routines: given a set of separators, split +a wide wide string wherever the separators appear, and provide direct access +to the resulting slices. This package is instantiated from +@code{GNAT.Array_Split}. + +@node Interfaces.C.Extensions (i-cexten.ads) +@section @code{Interfaces.C.Extensions} (@file{i-cexten.ads}) +@cindex @code{Interfaces.C.Extensions} (@file{i-cexten.ads}) + +@noindent +This package contains additional C-related definitions, intended +for use with either manually or automatically generated bindings +to C libraries. + +@node Interfaces.C.Streams (i-cstrea.ads) +@section @code{Interfaces.C.Streams} (@file{i-cstrea.ads}) +@cindex @code{Interfaces.C.Streams} (@file{i-cstrea.ads}) +@cindex C streams, interfacing + +@noindent +This package is a binding for the most commonly used operations +on C streams. + +@node Interfaces.CPP (i-cpp.ads) +@section @code{Interfaces.CPP} (@file{i-cpp.ads}) +@cindex @code{Interfaces.CPP} (@file{i-cpp.ads}) +@cindex C++ interfacing +@cindex Interfacing, to C++ + +@noindent +This package provides facilities for use in interfacing to C++. It +is primarily intended to be used in connection with automated tools +for the generation of C++ interfaces. + +@node Interfaces.Packed_Decimal (i-pacdec.ads) +@section @code{Interfaces.Packed_Decimal} (@file{i-pacdec.ads}) +@cindex @code{Interfaces.Packed_Decimal} (@file{i-pacdec.ads}) +@cindex IBM Packed Format +@cindex Packed Decimal + +@noindent +This package provides a set of routines for conversions to and +from a packed decimal format compatible with that used on IBM +mainframes. + +@node Interfaces.VxWorks (i-vxwork.ads) +@section @code{Interfaces.VxWorks} (@file{i-vxwork.ads}) +@cindex @code{Interfaces.VxWorks} (@file{i-vxwork.ads}) +@cindex Interfacing to VxWorks +@cindex VxWorks, interfacing + +@noindent +This package provides a limited binding to the VxWorks API. +In particular, it interfaces with the +VxWorks hardware interrupt facilities. + +@node Interfaces.VxWorks.IO (i-vxwoio.ads) +@section @code{Interfaces.VxWorks.IO} (@file{i-vxwoio.ads}) +@cindex @code{Interfaces.VxWorks.IO} (@file{i-vxwoio.ads}) +@cindex Interfacing to VxWorks' I/O +@cindex VxWorks, I/O interfacing +@cindex VxWorks, Get_Immediate +@cindex Get_Immediate, VxWorks + +@noindent +This package provides a binding to the ioctl (IO/Control) +function of VxWorks, defining a set of option values and +function codes. A particular use of this package is +to enable the use of Get_Immediate under VxWorks. + +@node System.Address_Image (s-addima.ads) +@section @code{System.Address_Image} (@file{s-addima.ads}) +@cindex @code{System.Address_Image} (@file{s-addima.ads}) +@cindex Address image +@cindex Image, of an address + +@noindent +This function provides a useful debugging +function that gives an (implementation dependent) +string which identifies an address. + +@node System.Assertions (s-assert.ads) +@section @code{System.Assertions} (@file{s-assert.ads}) +@cindex @code{System.Assertions} (@file{s-assert.ads}) +@cindex Assertions +@cindex Assert_Failure, exception + +@noindent +This package provides the declaration of the exception raised +by an run-time assertion failure, as well as the routine that +is used internally to raise this assertion. + +@node System.Memory (s-memory.ads) +@section @code{System.Memory} (@file{s-memory.ads}) +@cindex @code{System.Memory} (@file{s-memory.ads}) +@cindex Memory allocation + +@noindent +This package provides the interface to the low level routines used +by the generated code for allocation and freeing storage for the +default storage pool (analogous to the C routines malloc and free. +It also provides a reallocation interface analogous to the C routine +realloc. The body of this unit may be modified to provide alternative +allocation mechanisms for the default pool, and in addition, direct +calls to this unit may be made for low level allocation uses (for +example see the body of @code{GNAT.Tables}). + +@node System.Partition_Interface (s-parint.ads) +@section @code{System.Partition_Interface} (@file{s-parint.ads}) +@cindex @code{System.Partition_Interface} (@file{s-parint.ads}) +@cindex Partition interfacing functions + +@noindent +This package provides facilities for partition interfacing. It +is used primarily in a distribution context when using Annex E +with @code{GLADE}. + +@node System.Pool_Global (s-pooglo.ads) +@section @code{System.Pool_Global} (@file{s-pooglo.ads}) +@cindex @code{System.Pool_Global} (@file{s-pooglo.ads}) +@cindex Storage pool, global +@cindex Global storage pool + +@noindent +This package provides a storage pool that is equivalent to the default +storage pool used for access types for which no pool is specifically +declared. It uses malloc/free to allocate/free and does not attempt to +do any automatic reclamation. + +@node System.Pool_Local (s-pooloc.ads) +@section @code{System.Pool_Local} (@file{s-pooloc.ads}) +@cindex @code{System.Pool_Local} (@file{s-pooloc.ads}) +@cindex Storage pool, local +@cindex Local storage pool + +@noindent +This package provides a storage pool that is intended for use with locally +defined access types. It uses malloc/free for allocate/free, and maintains +a list of allocated blocks, so that all storage allocated for the pool can +be freed automatically when the pool is finalized. + +@node System.Restrictions (s-restri.ads) +@section @code{System.Restrictions} (@file{s-restri.ads}) +@cindex @code{System.Restrictions} (@file{s-restri.ads}) +@cindex Run-time restrictions access + +@noindent +This package provides facilities for accessing at run time +the status of restrictions specified at compile time for +the partition. Information is available both with regard +to actual restrictions specified, and with regard to +compiler determined information on which restrictions +are violated by one or more packages in the partition. + +@node System.Rident (s-rident.ads) +@section @code{System.Rident} (@file{s-rident.ads}) +@cindex @code{System.Rident} (@file{s-rident.ads}) +@cindex Restrictions definitions + +@noindent +This package provides definitions of the restrictions +identifiers supported by GNAT, and also the format of +the restrictions provided in package System.Restrictions. +It is not normally necessary to @code{with} this generic package +since the necessary instantiation is included in +package System.Restrictions. + +@node System.Strings.Stream_Ops (s-ststop.ads) +@section @code{System.Strings.Stream_Ops} (@file{s-ststop.ads}) +@cindex @code{System.Strings.Stream_Ops} (@file{s-ststop.ads}) +@cindex Stream operations +@cindex String stream operations + +@noindent +This package provides a set of stream subprograms for standard string types. +It is intended primarily to support implicit use of such subprograms when +stream attributes are applied to string types, but the subprograms in this +package can be used directly by application programs. + +@node System.Task_Info (s-tasinf.ads) +@section @code{System.Task_Info} (@file{s-tasinf.ads}) +@cindex @code{System.Task_Info} (@file{s-tasinf.ads}) +@cindex Task_Info pragma + +@noindent +This package provides target dependent functionality that is used +to support the @code{Task_Info} pragma + +@node System.Wch_Cnv (s-wchcnv.ads) +@section @code{System.Wch_Cnv} (@file{s-wchcnv.ads}) +@cindex @code{System.Wch_Cnv} (@file{s-wchcnv.ads}) +@cindex Wide Character, Representation +@cindex Wide String, Conversion +@cindex Representation of wide characters + +@noindent +This package provides routines for converting between +wide and wide wide characters and a representation as a value of type +@code{Standard.String}, using a specified wide character +encoding method. It uses definitions in +package @code{System.Wch_Con}. + +@node System.Wch_Con (s-wchcon.ads) +@section @code{System.Wch_Con} (@file{s-wchcon.ads}) +@cindex @code{System.Wch_Con} (@file{s-wchcon.ads}) + +@noindent +This package provides definitions and descriptions of +the various methods used for encoding wide characters +in ordinary strings. These definitions are used by +the package @code{System.Wch_Cnv}. + +@node Interfacing to Other Languages +@chapter Interfacing to Other Languages +@noindent +The facilities in annex B of the Ada Reference Manual are fully +implemented in GNAT, and in addition, a full interface to C++ is +provided. + +@menu +* Interfacing to C:: +* Interfacing to C++:: +* Interfacing to COBOL:: +* Interfacing to Fortran:: +* Interfacing to non-GNAT Ada code:: +@end menu + +@node Interfacing to C +@section Interfacing to C + +@noindent +Interfacing to C with GNAT can use one of two approaches: + +@itemize @bullet +@item +The types in the package @code{Interfaces.C} may be used. +@item +Standard Ada types may be used directly. This may be less portable to +other compilers, but will work on all GNAT compilers, which guarantee +correspondence between the C and Ada types. +@end itemize + +@noindent +Pragma @code{Convention C} may be applied to Ada types, but mostly has no +effect, since this is the default. The following table shows the +correspondence between Ada scalar types and the corresponding C types. + +@table @code +@item Integer +@code{int} +@item Short_Integer +@code{short} +@item Short_Short_Integer +@code{signed char} +@item Long_Integer +@code{long} +@item Long_Long_Integer +@code{long long} +@item Short_Float +@code{float} +@item Float +@code{float} +@item Long_Float +@code{double} +@item Long_Long_Float +This is the longest floating-point type supported by the hardware. +@end table + +@noindent +Additionally, there are the following general correspondences between Ada +and C types: +@itemize @bullet +@item +Ada enumeration types map to C enumeration types directly if pragma +@code{Convention C} is specified, which causes them to have int +length. Without pragma @code{Convention C}, Ada enumeration types map to +8, 16, or 32 bits (i.e.@: C types @code{signed char}, @code{short}, +@code{int}, respectively) depending on the number of values passed. +This is the only case in which pragma @code{Convention C} affects the +representation of an Ada type. + +@item +Ada access types map to C pointers, except for the case of pointers to +unconstrained types in Ada, which have no direct C equivalent. + +@item +Ada arrays map directly to C arrays. + +@item +Ada records map directly to C structures. + +@item +Packed Ada records map to C structures where all members are bit fields +of the length corresponding to the @code{@var{type}'Size} value in Ada. +@end itemize + +@node Interfacing to C++ +@section Interfacing to C++ + +@noindent +The interface to C++ makes use of the following pragmas, which are +primarily intended to be constructed automatically using a binding generator +tool, although it is possible to construct them by hand. No suitable binding +generator tool is supplied with GNAT though. + +Using these pragmas it is possible to achieve complete +inter-operability between Ada tagged types and C++ class definitions. +See @ref{Implementation Defined Pragmas}, for more details. + +@table @code +@item pragma CPP_Class ([Entity =>] @var{LOCAL_NAME}) +The argument denotes an entity in the current declarative region that is +declared as a tagged or untagged record type. It indicates that the type +corresponds to an externally declared C++ class type, and is to be laid +out the same way that C++ would lay out the type. + +Note: Pragma @code{CPP_Class} is currently obsolete. It is supported +for backward compatibility but its functionality is available +using pragma @code{Import} with @code{Convention} = @code{CPP}. + +@item pragma CPP_Constructor ([Entity =>] @var{LOCAL_NAME}) +This pragma identifies an imported function (imported in the usual way +with pragma @code{Import}) as corresponding to a C++ constructor. +@end table + +@node Interfacing to COBOL +@section Interfacing to COBOL + +@noindent +Interfacing to COBOL is achieved as described in section B.4 of +the Ada Reference Manual. + +@node Interfacing to Fortran +@section Interfacing to Fortran + +@noindent +Interfacing to Fortran is achieved as described in section B.5 of the +Ada Reference Manual. The pragma @code{Convention Fortran}, applied to a +multi-dimensional array causes the array to be stored in column-major +order as required for convenient interface to Fortran. + +@node Interfacing to non-GNAT Ada code +@section Interfacing to non-GNAT Ada code + +It is possible to specify the convention @code{Ada} in a pragma +@code{Import} or pragma @code{Export}. However this refers to +the calling conventions used by GNAT, which may or may not be +similar enough to those used by some other Ada 83 / Ada 95 / Ada 2005 +compiler to allow interoperation. + +If arguments types are kept simple, and if the foreign compiler generally +follows system calling conventions, then it may be possible to integrate +files compiled by other Ada compilers, provided that the elaboration +issues are adequately addressed (for example by eliminating the +need for any load time elaboration). + +In particular, GNAT running on VMS is designed to +be highly compatible with the DEC Ada 83 compiler, so this is one +case in which it is possible to import foreign units of this type, +provided that the data items passed are restricted to simple scalar +values or simple record types without variants, or simple array +types with fixed bounds. + +@node Specialized Needs Annexes +@chapter Specialized Needs Annexes + +@noindent +Ada 95 and Ada 2005 define a number of Specialized Needs Annexes, which are not +required in all implementations. However, as described in this chapter, +GNAT implements all of these annexes: + +@table @asis +@item Systems Programming (Annex C) +The Systems Programming Annex is fully implemented. + +@item Real-Time Systems (Annex D) +The Real-Time Systems Annex is fully implemented. + +@item Distributed Systems (Annex E) +Stub generation is fully implemented in the GNAT compiler. In addition, +a complete compatible PCS is available as part of the GLADE system, +a separate product. When the two +products are used in conjunction, this annex is fully implemented. + +@item Information Systems (Annex F) +The Information Systems annex is fully implemented. + +@item Numerics (Annex G) +The Numerics Annex is fully implemented. + +@item Safety and Security / High-Integrity Systems (Annex H) +The Safety and Security Annex (termed the High-Integrity Systems Annex +in Ada 2005) is fully implemented. +@end table + +@node Implementation of Specific Ada Features +@chapter Implementation of Specific Ada Features + +@noindent +This chapter describes the GNAT implementation of several Ada language +facilities. + +@menu +* Machine Code Insertions:: +* GNAT Implementation of Tasking:: +* GNAT Implementation of Shared Passive Packages:: +* Code Generation for Array Aggregates:: +* The Size of Discriminated Records with Default Discriminants:: +* Strict Conformance to the Ada Reference Manual:: +@end menu + +@node Machine Code Insertions +@section Machine Code Insertions +@cindex Machine Code insertions + +@noindent +Package @code{Machine_Code} provides machine code support as described +in the Ada Reference Manual in two separate forms: +@itemize @bullet +@item +Machine code statements, consisting of qualified expressions that +fit the requirements of RM section 13.8. +@item +An intrinsic callable procedure, providing an alternative mechanism of +including machine instructions in a subprogram. +@end itemize + +@noindent +The two features are similar, and both are closely related to the mechanism +provided by the asm instruction in the GNU C compiler. Full understanding +and use of the facilities in this package requires understanding the asm +instruction, see @ref{Extended Asm,, Assembler Instructions with C Expression +Operands, gcc, Using the GNU Compiler Collection (GCC)}. + +Calls to the function @code{Asm} and the procedure @code{Asm} have identical +semantic restrictions and effects as described below. Both are provided so +that the procedure call can be used as a statement, and the function call +can be used to form a code_statement. + +The first example given in the GCC documentation is the C @code{asm} +instruction: +@smallexample + asm ("fsinx %1 %0" : "=f" (result) : "f" (angle)); +@end smallexample + +@noindent +The equivalent can be written for GNAT as: + +@smallexample @c ada +Asm ("fsinx %1 %0", + My_Float'Asm_Output ("=f", result), + My_Float'Asm_Input ("f", angle)); +@end smallexample + +@noindent +The first argument to @code{Asm} is the assembler template, and is +identical to what is used in GNU C@. This string must be a static +expression. The second argument is the output operand list. It is +either a single @code{Asm_Output} attribute reference, or a list of such +references enclosed in parentheses (technically an array aggregate of +such references). + +The @code{Asm_Output} attribute denotes a function that takes two +parameters. The first is a string, the second is the name of a variable +of the type designated by the attribute prefix. The first (string) +argument is required to be a static expression and designates the +constraint for the parameter (e.g.@: what kind of register is +required). The second argument is the variable to be updated with the +result. The possible values for constraint are the same as those used in +the RTL, and are dependent on the configuration file used to build the +GCC back end. If there are no output operands, then this argument may +either be omitted, or explicitly given as @code{No_Output_Operands}. + +The second argument of @code{@var{my_float}'Asm_Output} functions as +though it were an @code{out} parameter, which is a little curious, but +all names have the form of expressions, so there is no syntactic +irregularity, even though normally functions would not be permitted +@code{out} parameters. The third argument is the list of input +operands. It is either a single @code{Asm_Input} attribute reference, or +a list of such references enclosed in parentheses (technically an array +aggregate of such references). + +The @code{Asm_Input} attribute denotes a function that takes two +parameters. The first is a string, the second is an expression of the +type designated by the prefix. The first (string) argument is required +to be a static expression, and is the constraint for the parameter, +(e.g.@: what kind of register is required). The second argument is the +value to be used as the input argument. The possible values for the +constant are the same as those used in the RTL, and are dependent on +the configuration file used to built the GCC back end. + +If there are no input operands, this argument may either be omitted, or +explicitly given as @code{No_Input_Operands}. The fourth argument, not +present in the above example, is a list of register names, called the +@dfn{clobber} argument. This argument, if given, must be a static string +expression, and is a space or comma separated list of names of registers +that must be considered destroyed as a result of the @code{Asm} call. If +this argument is the null string (the default value), then the code +generator assumes that no additional registers are destroyed. + +The fifth argument, not present in the above example, called the +@dfn{volatile} argument, is by default @code{False}. It can be set to +the literal value @code{True} to indicate to the code generator that all +optimizations with respect to the instruction specified should be +suppressed, and that in particular, for an instruction that has outputs, +the instruction will still be generated, even if none of the outputs are +used. @xref{Extended Asm,, Assembler Instructions with C Expression Operands, +gcc, Using the GNU Compiler Collection (GCC)}, for the full description. +Generally it is strongly advisable to use Volatile for any ASM statement +that is missing either input or output operands, or when two or more ASM +statements appear in sequence, to avoid unwanted optimizations. A warning +is generated if this advice is not followed. + +The @code{Asm} subprograms may be used in two ways. First the procedure +forms can be used anywhere a procedure call would be valid, and +correspond to what the RM calls ``intrinsic'' routines. Such calls can +be used to intersperse machine instructions with other Ada statements. +Second, the function forms, which return a dummy value of the limited +private type @code{Asm_Insn}, can be used in code statements, and indeed +this is the only context where such calls are allowed. Code statements +appear as aggregates of the form: + +@smallexample @c ada +Asm_Insn'(Asm (@dots{})); +Asm_Insn'(Asm_Volatile (@dots{})); +@end smallexample + +@noindent +In accordance with RM rules, such code statements are allowed only +within subprograms whose entire body consists of such statements. It is +not permissible to intermix such statements with other Ada statements. + +Typically the form using intrinsic procedure calls is more convenient +and more flexible. The code statement form is provided to meet the RM +suggestion that such a facility should be made available. The following +is the exact syntax of the call to @code{Asm}. As usual, if named notation +is used, the arguments may be given in arbitrary order, following the +normal rules for use of positional and named arguments) + +@smallexample +ASM_CALL ::= Asm ( + [Template =>] static_string_EXPRESSION + [,[Outputs =>] OUTPUT_OPERAND_LIST ] + [,[Inputs =>] INPUT_OPERAND_LIST ] + [,[Clobber =>] static_string_EXPRESSION ] + [,[Volatile =>] static_boolean_EXPRESSION] ) + +OUTPUT_OPERAND_LIST ::= + [PREFIX.]No_Output_Operands +| OUTPUT_OPERAND_ATTRIBUTE +| (OUTPUT_OPERAND_ATTRIBUTE @{,OUTPUT_OPERAND_ATTRIBUTE@}) + +OUTPUT_OPERAND_ATTRIBUTE ::= + SUBTYPE_MARK'Asm_Output (static_string_EXPRESSION, NAME) + +INPUT_OPERAND_LIST ::= + [PREFIX.]No_Input_Operands +| INPUT_OPERAND_ATTRIBUTE +| (INPUT_OPERAND_ATTRIBUTE @{,INPUT_OPERAND_ATTRIBUTE@}) + +INPUT_OPERAND_ATTRIBUTE ::= + SUBTYPE_MARK'Asm_Input (static_string_EXPRESSION, EXPRESSION) +@end smallexample + +@noindent +The identifiers @code{No_Input_Operands} and @code{No_Output_Operands} +are declared in the package @code{Machine_Code} and must be referenced +according to normal visibility rules. In particular if there is no +@code{use} clause for this package, then appropriate package name +qualification is required. + +@node GNAT Implementation of Tasking +@section GNAT Implementation of Tasking + +@noindent +This chapter outlines the basic GNAT approach to tasking (in particular, +a multi-layered library for portability) and discusses issues related +to compliance with the Real-Time Systems Annex. + +@menu +* Mapping Ada Tasks onto the Underlying Kernel Threads:: +* Ensuring Compliance with the Real-Time Annex:: +@end menu + +@node Mapping Ada Tasks onto the Underlying Kernel Threads +@subsection Mapping Ada Tasks onto the Underlying Kernel Threads + +@noindent +GNAT's run-time support comprises two layers: + +@itemize @bullet +@item GNARL (GNAT Run-time Layer) +@item GNULL (GNAT Low-level Library) +@end itemize + +@noindent +In GNAT, Ada's tasking services rely on a platform and OS independent +layer known as GNARL@. This code is responsible for implementing the +correct semantics of Ada's task creation, rendezvous, protected +operations etc. + +GNARL decomposes Ada's tasking semantics into simpler lower level +operations such as create a thread, set the priority of a thread, +yield, create a lock, lock/unlock, etc. The spec for these low-level +operations constitutes GNULLI, the GNULL Interface. This interface is +directly inspired from the POSIX real-time API@. + +If the underlying executive or OS implements the POSIX standard +faithfully, the GNULL Interface maps as is to the services offered by +the underlying kernel. Otherwise, some target dependent glue code maps +the services offered by the underlying kernel to the semantics expected +by GNARL@. + +Whatever the underlying OS (VxWorks, UNIX, Windows, etc.) the +key point is that each Ada task is mapped on a thread in the underlying +kernel. For example, in the case of VxWorks, one Ada task = one VxWorks task. + +In addition Ada task priorities map onto the underlying thread priorities. +Mapping Ada tasks onto the underlying kernel threads has several advantages: + +@itemize @bullet +@item +The underlying scheduler is used to schedule the Ada tasks. This +makes Ada tasks as efficient as kernel threads from a scheduling +standpoint. + +@item +Interaction with code written in C containing threads is eased +since at the lowest level Ada tasks and C threads map onto the same +underlying kernel concept. + +@item +When an Ada task is blocked during I/O the remaining Ada tasks are +able to proceed. + +@item +On multiprocessor systems Ada tasks can execute in parallel. +@end itemize + +@noindent +Some threads libraries offer a mechanism to fork a new process, with the +child process duplicating the threads from the parent. +GNAT does not +support this functionality when the parent contains more than one task. +@cindex Forking a new process + +@node Ensuring Compliance with the Real-Time Annex +@subsection Ensuring Compliance with the Real-Time Annex +@cindex Real-Time Systems Annex compliance + +@noindent +Although mapping Ada tasks onto +the underlying threads has significant advantages, it does create some +complications when it comes to respecting the scheduling semantics +specified in the real-time annex (Annex D). + +For instance the Annex D requirement for the @code{FIFO_Within_Priorities} +scheduling policy states: + +@quotation +@emph{When the active priority of a ready task that is not running +changes, or the setting of its base priority takes effect, the +task is removed from the ready queue for its old active priority +and is added at the tail of the ready queue for its new active +priority, except in the case where the active priority is lowered +due to the loss of inherited priority, in which case the task is +added at the head of the ready queue for its new active priority.} +@end quotation + +@noindent +While most kernels do put tasks at the end of the priority queue when +a task changes its priority, (which respects the main +FIFO_Within_Priorities requirement), almost none keep a thread at the +beginning of its priority queue when its priority drops from the loss +of inherited priority. + +As a result most vendors have provided incomplete Annex D implementations. + +The GNAT run-time, has a nice cooperative solution to this problem +which ensures that accurate FIFO_Within_Priorities semantics are +respected. + +The principle is as follows. When an Ada task T is about to start +running, it checks whether some other Ada task R with the same +priority as T has been suspended due to the loss of priority +inheritance. If this is the case, T yields and is placed at the end of +its priority queue. When R arrives at the front of the queue it +executes. + +Note that this simple scheme preserves the relative order of the tasks +that were ready to execute in the priority queue where R has been +placed at the end. + +@node GNAT Implementation of Shared Passive Packages +@section GNAT Implementation of Shared Passive Packages +@cindex Shared passive packages + +@noindent +GNAT fully implements the pragma @code{Shared_Passive} for +@cindex pragma @code{Shared_Passive} +the purpose of designating shared passive packages. +This allows the use of passive partitions in the +context described in the Ada Reference Manual; i.e., for communication +between separate partitions of a distributed application using the +features in Annex E. +@cindex Annex E +@cindex Distribution Systems Annex + +However, the implementation approach used by GNAT provides for more +extensive usage as follows: + +@table @emph +@item Communication between separate programs + +This allows separate programs to access the data in passive +partitions, using protected objects for synchronization where +needed. The only requirement is that the two programs have a +common shared file system. It is even possible for programs +running on different machines with different architectures +(e.g.@: different endianness) to communicate via the data in +a passive partition. + +@item Persistence between program runs + +The data in a passive package can persist from one run of a +program to another, so that a later program sees the final +values stored by a previous run of the same program. + +@end table + +@noindent +The implementation approach used is to store the data in files. A +separate stream file is created for each object in the package, and +an access to an object causes the corresponding file to be read or +written. + +The environment variable @code{SHARED_MEMORY_DIRECTORY} should be +@cindex @code{SHARED_MEMORY_DIRECTORY} environment variable +set to the directory to be used for these files. +The files in this directory +have names that correspond to their fully qualified names. For +example, if we have the package + +@smallexample @c ada +package X is + pragma Shared_Passive (X); + Y : Integer; + Z : Float; +end X; +@end smallexample + +@noindent +and the environment variable is set to @code{/stemp/}, then the files created +will have the names: + +@smallexample +/stemp/x.y +/stemp/x.z +@end smallexample + +@noindent +These files are created when a value is initially written to the object, and +the files are retained until manually deleted. This provides the persistence +semantics. If no file exists, it means that no partition has assigned a value +to the variable; in this case the initial value declared in the package +will be used. This model ensures that there are no issues in synchronizing +the elaboration process, since elaboration of passive packages elaborates the +initial values, but does not create the files. + +The files are written using normal @code{Stream_IO} access. +If you want to be able +to communicate between programs or partitions running on different +architectures, then you should use the XDR versions of the stream attribute +routines, since these are architecture independent. + +If active synchronization is required for access to the variables in the +shared passive package, then as described in the Ada Reference Manual, the +package may contain protected objects used for this purpose. In this case +a lock file (whose name is @file{___lock} (three underscores) +is created in the shared memory directory. +@cindex @file{___lock} file (for shared passive packages) +This is used to provide the required locking +semantics for proper protected object synchronization. + +As of January 2003, GNAT supports shared passive packages on all platforms +except for OpenVMS. + +@node Code Generation for Array Aggregates +@section Code Generation for Array Aggregates + +@menu +* Static constant aggregates with static bounds:: +* Constant aggregates with unconstrained nominal types:: +* Aggregates with static bounds:: +* Aggregates with non-static bounds:: +* Aggregates in assignment statements:: +@end menu + +@noindent +Aggregates have a rich syntax and allow the user to specify the values of +complex data structures by means of a single construct. As a result, the +code generated for aggregates can be quite complex and involve loops, case +statements and multiple assignments. In the simplest cases, however, the +compiler will recognize aggregates whose components and constraints are +fully static, and in those cases the compiler will generate little or no +executable code. The following is an outline of the code that GNAT generates +for various aggregate constructs. For further details, you will find it +useful to examine the output produced by the -gnatG flag to see the expanded +source that is input to the code generator. You may also want to examine +the assembly code generated at various levels of optimization. + +The code generated for aggregates depends on the context, the component values, +and the type. In the context of an object declaration the code generated is +generally simpler than in the case of an assignment. As a general rule, static +component values and static subtypes also lead to simpler code. + +@node Static constant aggregates with static bounds +@subsection Static constant aggregates with static bounds + +@noindent +For the declarations: +@smallexample @c ada + type One_Dim is array (1..10) of integer; + ar0 : constant One_Dim := (1, 2, 3, 4, 5, 6, 7, 8, 9, 0); +@end smallexample + +@noindent +GNAT generates no executable code: the constant ar0 is placed in static memory. +The same is true for constant aggregates with named associations: + +@smallexample @c ada + Cr1 : constant One_Dim := (4 => 16, 2 => 4, 3 => 9, 1 => 1, 5 .. 10 => 0); + Cr3 : constant One_Dim := (others => 7777); +@end smallexample + +@noindent +The same is true for multidimensional constant arrays such as: + +@smallexample @c ada + type two_dim is array (1..3, 1..3) of integer; + Unit : constant two_dim := ( (1,0,0), (0,1,0), (0,0,1)); +@end smallexample + +@noindent +The same is true for arrays of one-dimensional arrays: the following are +static: + +@smallexample @c ada +type ar1b is array (1..3) of boolean; +type ar_ar is array (1..3) of ar1b; +None : constant ar1b := (others => false); -- fully static +None2 : constant ar_ar := (1..3 => None); -- fully static +@end smallexample + +@noindent +However, for multidimensional aggregates with named associations, GNAT will +generate assignments and loops, even if all associations are static. The +following two declarations generate a loop for the first dimension, and +individual component assignments for the second dimension: + +@smallexample @c ada +Zero1: constant two_dim := (1..3 => (1..3 => 0)); +Zero2: constant two_dim := (others => (others => 0)); +@end smallexample + +@node Constant aggregates with unconstrained nominal types +@subsection Constant aggregates with unconstrained nominal types + +@noindent +In such cases the aggregate itself establishes the subtype, so that +associations with @code{others} cannot be used. GNAT determines the +bounds for the actual subtype of the aggregate, and allocates the +aggregate statically as well. No code is generated for the following: + +@smallexample @c ada + type One_Unc is array (natural range <>) of integer; + Cr_Unc : constant One_Unc := (12,24,36); +@end smallexample + +@node Aggregates with static bounds +@subsection Aggregates with static bounds + +@noindent +In all previous examples the aggregate was the initial (and immutable) value +of a constant. If the aggregate initializes a variable, then code is generated +for it as a combination of individual assignments and loops over the target +object. The declarations + +@smallexample @c ada + Cr_Var1 : One_Dim := (2, 5, 7, 11, 0, 0, 0, 0, 0, 0); + Cr_Var2 : One_Dim := (others > -1); +@end smallexample + +@noindent +generate the equivalent of + +@smallexample @c ada + Cr_Var1 (1) := 2; + Cr_Var1 (2) := 3; + Cr_Var1 (3) := 5; + Cr_Var1 (4) := 11; + + for I in Cr_Var2'range loop + Cr_Var2 (I) := -1; + end loop; +@end smallexample + +@node Aggregates with non-static bounds +@subsection Aggregates with non-static bounds + +@noindent +If the bounds of the aggregate are not statically compatible with the bounds +of the nominal subtype of the target, then constraint checks have to be +generated on the bounds. For a multidimensional array, constraint checks may +have to be applied to sub-arrays individually, if they do not have statically +compatible subtypes. + +@node Aggregates in assignment statements +@subsection Aggregates in assignment statements + +@noindent +In general, aggregate assignment requires the construction of a temporary, +and a copy from the temporary to the target of the assignment. This is because +it is not always possible to convert the assignment into a series of individual +component assignments. For example, consider the simple case: + +@smallexample @c ada + A := (A(2), A(1)); +@end smallexample + +@noindent +This cannot be converted into: + +@smallexample @c ada + A(1) := A(2); + A(2) := A(1); +@end smallexample + +@noindent +So the aggregate has to be built first in a separate location, and then +copied into the target. GNAT recognizes simple cases where this intermediate +step is not required, and the assignments can be performed in place, directly +into the target. The following sufficient criteria are applied: + +@itemize @bullet +@item +The bounds of the aggregate are static, and the associations are static. +@item +The components of the aggregate are static constants, names of +simple variables that are not renamings, or expressions not involving +indexed components whose operands obey these rules. +@end itemize + +@noindent +If any of these conditions are violated, the aggregate will be built in +a temporary (created either by the front-end or the code generator) and then +that temporary will be copied onto the target. + +@node The Size of Discriminated Records with Default Discriminants +@section The Size of Discriminated Records with Default Discriminants + +@noindent +If a discriminated type @code{T} has discriminants with default values, it is +possible to declare an object of this type without providing an explicit +constraint: + +@smallexample @c ada +@group +type Size is range 1..100; + +type Rec (D : Size := 15) is record + Name : String (1..D); +end T; + +Word : Rec; +@end group +@end smallexample + +@noindent +Such an object is said to be @emph{unconstrained}. +The discriminant of the object +can be modified by a full assignment to the object, as long as it preserves the +relation between the value of the discriminant, and the value of the components +that depend on it: + +@smallexample @c ada +@group +Word := (3, "yes"); + +Word := (5, "maybe"); + +Word := (5, "no"); -- raises Constraint_Error +@end group +@end smallexample + +@noindent +In order to support this behavior efficiently, an unconstrained object is +given the maximum size that any value of the type requires. In the case +above, @code{Word} has storage for the discriminant and for +a @code{String} of length 100. +It is important to note that unconstrained objects do not require dynamic +allocation. It would be an improper implementation to place on the heap those +components whose size depends on discriminants. (This improper implementation +was used by some Ada83 compilers, where the @code{Name} component above +would have +been stored as a pointer to a dynamic string). Following the principle that +dynamic storage management should never be introduced implicitly, +an Ada compiler should reserve the full size for an unconstrained declared +object, and place it on the stack. + +This maximum size approach +has been a source of surprise to some users, who expect the default +values of the discriminants to determine the size reserved for an +unconstrained object: ``If the default is 15, why should the object occupy +a larger size?'' +The answer, of course, is that the discriminant may be later modified, +and its full range of values must be taken into account. This is why the +declaration: + +@smallexample +@group +type Rec (D : Positive := 15) is record + Name : String (1..D); +end record; + +Too_Large : Rec; +@end group +@end smallexample + +@noindent +is flagged by the compiler with a warning: +an attempt to create @code{Too_Large} will raise @code{Storage_Error}, +because the required size includes @code{Positive'Last} +bytes. As the first example indicates, the proper approach is to declare an +index type of ``reasonable'' range so that unconstrained objects are not too +large. + +One final wrinkle: if the object is declared to be @code{aliased}, or if it is +created in the heap by means of an allocator, then it is @emph{not} +unconstrained: +it is constrained by the default values of the discriminants, and those values +cannot be modified by full assignment. This is because in the presence of +aliasing all views of the object (which may be manipulated by different tasks, +say) must be consistent, so it is imperative that the object, once created, +remain invariant. + +@node Strict Conformance to the Ada Reference Manual +@section Strict Conformance to the Ada Reference Manual + +@noindent +The dynamic semantics defined by the Ada Reference Manual impose a set of +run-time checks to be generated. By default, the GNAT compiler will insert many +run-time checks into the compiled code, including most of those required by the +Ada Reference Manual. However, there are three checks that are not enabled +in the default mode for efficiency reasons: arithmetic overflow checking for +integer operations (including division by zero), checks for access before +elaboration on subprogram calls, and stack overflow checking (most operating +systems do not perform this check by default). + +Strict conformance to the Ada Reference Manual can be achieved by adding +three compiler options for overflow checking for integer operations +(@option{-gnato}), dynamic checks for access-before-elaboration on subprogram +calls and generic instantiations (@option{-gnatE}), and stack overflow +checking (@option{-fstack-check}). + +Note that the result of a floating point arithmetic operation in overflow and +invalid situations, when the @code{Machine_Overflows} attribute of the result +type is @code{False}, is to generate IEEE NaN and infinite values. This is the +case for machines compliant with the IEEE floating-point standard, but on +machines that are not fully compliant with this standard, such as Alpha, the +@option{-mieee} compiler flag must be used for achieving IEEE confirming +behavior (although at the cost of a significant performance penalty), so +infinite and NaN values are properly generated. + + +@node Implementation of Ada 2012 Features +@chapter Implementation of Ada 2012 Features +@cindex Ada 2012 implementation status + +This chapter contains a complete list of Ada 2012 features that have been +implemented as of GNAT version 6.4. Generally, these features are only +available if the @option{-gnat12} (Ada 2012 features enabled) flag is set +@cindex @option{-gnat12} option +or if the configuration pragma @code{Ada_2012} is used. +@cindex pragma @code{Ada_2012} +@cindex configuration pragma @code{Ada_2012} +@cindex @code{Ada_2012} configuration pragma +However, new pragmas, attributes, and restrictions are +unconditionally available, since the Ada 95 standard allows the addition of +new pragmas, attributes, and restrictions (there are exceptions, which are +documented in the individual descriptions), and also certain packages +were made available in earlier versions of Ada. + +An ISO date (YYYY-MM-DD) appears in parentheses on the description line. +This date shows the implementation date of the feature. Any wavefront +subsequent to this date will contain the indicated feature, as will any +subsequent releases. A date of 0000-00-00 means that GNAT has always +implemented the feature, or implemented it as soon as it appeared as a +binding interpretation. + +Each feature corresponds to an Ada Issue (``AI'') approved by the Ada +standardization group (ISO/IEC JTC1/SC22/WG9) for inclusion in Ada 2012. +The features are ordered based on the relevant sections of the Ada +Reference Manual (``RM''). When a given AI relates to multiple points +in the RM, the earliest is used. + +A complete description of the AIs may be found in +@url{www.ada-auth.org/ai05-summary.html}. + +@itemize @bullet + +@item +@emph{AI-0176 Quantified expressions (2010-09-29)} +@cindex AI-0176 (Ada 2012 feature) + +@noindent + Both universally and existentially quantified expressions are implemented. + They use the new syntax for iterators proposed in AI05-139-2, as well as + the standard Ada loop syntax. + +@noindent + RM References: 1.01.04 (12) 2.09 (2/2) 4.04 (7) 4.05.09 (0) + +@item +@emph{AI-0079 Allow @i{other_format} characters in source (2010-07-10)} +@cindex AI-0079 (Ada 2012 feature) + +@noindent + Wide characters in the unicode category @i{other_format} are now allowed in + source programs between tokens, but not within a token such as an identifier. + +@noindent + RM References: 2.01 (4/2) 2.02 (7) + +@item +@emph{AI-0091 Do not allow @i{other_format} in identifiers (0000-00-00)} +@cindex AI-0091 (Ada 2012 feature) + +@noindent + Wide characters in the unicode category @i{other_format} are not permitted + within an identifier, since this can be a security problem. The error + message for this case has been improved to be more specific, but GNAT has + never allowed such characters to appear in identifiers. + +@noindent + RM References: 2.03 (3.1/2) 2.03 (4/2) 2.03 (5/2) 2.03 (5.1/2) 2.03 (5.2/2) 2.03 (5.3/2) 2.09 (2/2) + +@item +@emph{AI-0100 Placement of pragmas (2010-07-01)} +@cindex AI-0100 (Ada 2012 feature) + +@noindent + This AI is an earlier version of AI-163. It simplifies the rules + for legal placement of pragmas. In the case of lists that allow pragmas, if + the list may have no elements, then the list may consist solely of pragmas. + +@noindent + RM References: 2.08 (7) + +@item +@emph{AI-0163 Pragmas in place of null (2010-07-01)} +@cindex AI-0163 (Ada 2012 feature) + +@noindent + A statement sequence may be composed entirely of pragmas. It is no longer + necessary to add a dummy @code{null} statement to make the sequence legal. + +@noindent + RM References: 2.08 (7) 2.08 (16) + + +@item +@emph{AI-0080 ``View of'' not needed if clear from context (0000-00-00)} +@cindex AI-0080 (Ada 2012 feature) + +@noindent + This is an editorial change only, described as non-testable in the AI. + +@noindent + RM References: 3.01 (7) + + +@item +@emph{AI-0183 Aspect specifications (2010-08-16)} +@cindex AI-0183 (Ada 2012 feature) + +@noindent + Aspect specifications have been fully implemented except for pre and post- + conditions, and type invariants, which have their own separate AI's. All + forms of declarations listed in the AI are supported. The following is a + list of the aspects supported (with GNAT implementation aspects marked) + +@multitable {@code{Preelaborable_Initialization}} {--GNAT} +@item @code{Ada_2005} @tab -- GNAT +@item @code{Ada_2012} @tab -- GNAT +@item @code{Address} @tab +@item @code{Alignment} @tab +@item @code{Atomic} @tab +@item @code{Atomic_Components} @tab +@item @code{Bit_Order} @tab +@item @code{Component_Size} @tab +@item @code{Discard_Names} @tab +@item @code{External_Tag} @tab +@item @code{Favor_Top_Level} @tab -- GNAT +@item @code{Inline} @tab +@item @code{Inline_Always} @tab -- GNAT +@item @code{Invariant} @tab +@item @code{Machine_Radix} @tab +@item @code{No_Return} @tab +@item @code{Object_Size} @tab -- GNAT +@item @code{Pack} @tab +@item @code{Persistent_BSS} @tab -- GNAT +@item @code{Post} @tab +@item @code{Pre} @tab +@item @code{Predicate} @tab +@item @code{Preelaborable_Initialization} @tab +@item @code{Pure_Function} @tab -- GNAT +@item @code{Shared} @tab -- GNAT +@item @code{Size} @tab +@item @code{Storage_Pool} @tab +@item @code{Storage_Size} @tab +@item @code{Stream_Size} @tab +@item @code{Suppress} @tab +@item @code{Suppress_Debug_Info} @tab -- GNAT +@item @code{Unchecked_Union} @tab +@item @code{Universal_Aliasing} @tab -- GNAT +@item @code{Unmodified} @tab -- GNAT +@item @code{Unreferenced} @tab -- GNAT +@item @code{Unreferenced_Objects} @tab -- GNAT +@item @code{Unsuppress} @tab +@item @code{Value_Size} @tab -- GNAT +@item @code{Volatile} @tab +@item @code{Volatile_Components} +@item @code{Warnings} @tab -- GNAT +@end multitable + +@noindent + Note that for aspects with an expression, e.g. @code{Size}, the expression is + treated like a default expression (visibility is analyzed at the point of + occurrence of the aspect, but evaluation of the expression occurs at the + freeze point of the entity involved. + +@noindent + RM References: 3.02.01 (3) 3.02.02 (2) 3.03.01 (2/2) 3.08 (6) + 3.09.03 (1.1/2) 6.01 (2/2) 6.07 (2/2) 9.05.02 (2/2) 7.01 (3) 7.03 + (2) 7.03 (3) 9.01 (2/2) 9.01 (3/2) 9.04 (2/2) 9.04 (3/2) + 9.05.02 (2/2) 11.01 (2) 12.01 (3) 12.03 (2/2) 12.04 (2/2) 12.05 (2) + 12.06 (2.1/2) 12.06 (2.2/2) 12.07 (2) 13.01 (0.1/2) 13.03 (5/1) + 13.03.01 (0) + + +@item +@emph{AI-0128 Inequality is a primitive operation (0000-00-00)} +@cindex AI-0128 (Ada 2012 feature) + +@noindent + If an equality operator ("=") is declared for a type, then the implicitly + declared inequality operator ("/=") is a primitive operation of the type. + This is the only reasonable interpretation, and is the one always implemented + by GNAT, but the RM was not entirely clear in making this point. + +@noindent + RM References: 3.02.03 (6) 6.06 (6) + +@item +@emph{AI-0003 Qualified expressions as names (2010-07-11)} +@cindex AI-0003 (Ada 2012 feature) + +@noindent + In Ada 2012, a qualified expression is considered to be syntactically a name, + meaning that constructs such as @code{A'(F(X)).B} are now legal. This is + useful in disambiguating some cases of overloading. + +@noindent + RM References: 3.03 (11) 3.03 (21) 4.01 (2) 4.04 (7) 4.07 (3) + 5.04 (7) + +@item +@emph{AI-0120 Constant instance of protected object (0000-00-00)} +@cindex AI-0120 (Ada 2012 feature) + +@noindent + This is an RM editorial change only. The section that lists objects that are + constant failed to include the current instance of a protected object + within a protected function. This has always been treated as a constant + in GNAT. + +@noindent + RM References: 3.03 (21) + +@item +@emph{AI-0008 General access to constrained objects (0000-00-00)} +@cindex AI-0008 (Ada 2012 feature) + +@noindent + The wording in the RM implied that if you have a general access to a + constrained object, it could be used to modify the discriminants. This was + obviously not intended. @code{Constraint_Error} should be raised, and GNAT + has always done so in this situation. + +@noindent + RM References: 3.03 (23) 3.10.02 (26/2) 4.01 (9) 6.04.01 (17) 8.05.01 (5/2) + + +@item +@emph{AI-0093 Additional rules use immutably limited (0000-00-00)} +@cindex AI-0093 (Ada 2012 feature) + +@noindent + This is an editorial change only, to make more widespread use of the Ada 2012 + ``immutably limited''. + +@noindent + RM References: 3.03 (23.4/3) + + + +@item +@emph{AI-0096 Deriving from formal private types (2010-07-20)} +@cindex AI-0096 (Ada 2012 feature) + +@noindent + In general it is illegal for a type derived from a formal limited type to be + nonlimited. This AI makes an exception to this rule: derivation is legal + if it appears in the private part of the generic, and the formal type is not + tagged. If the type is tagged, the legality check must be applied to the + private part of the package. + +@noindent + RM References: 3.04 (5.1/2) 6.02 (7) + + +@item +@emph{AI-0181 Soft hyphen is a non-graphic character (2010-07-23)} +@cindex AI-0181 (Ada 2012 feature) + +@noindent + From Ada 2005 on, soft hyphen is considered a non-graphic character, which + means that it has a special name (@code{SOFT_HYPHEN}) in conjunction with the + @code{Image} and @code{Value} attributes for the character types. Strictly + speaking this is an inconsistency with Ada 95, but in practice the use of + these attributes is so obscure that it will not cause problems. + +@noindent + RM References: 3.05.02 (2/2) A.01 (35/2) A.03.03 (21) + + +@item +@emph{AI-0182 Additional forms for @code{Character'Value} (0000-00-00)} +@cindex AI-0182 (Ada 2012 feature) + +@noindent + This AI allows @code{Character'Value} to accept the string @code{'?'} where + @code{?} is any character including non-graphic control characters. GNAT has + always accepted such strings. It also allows strings such as + @code{HEX_00000041} to be accepted, but GNAT does not take advantage of this + permission and raises @code{Constraint_Error}, as is certainly still + permitted. + +@noindent + RM References: 3.05 (56/2) + + +@item +@emph{AI-0214 Defaulted discriminants for limited tagged (2010-10-01)} +@cindex AI-0214 (Ada 2012 feature) + +@noindent + Ada 2012 relaxes the restriction that forbids discriminants of tagged types + to have default expressions by allowing them when the type is limited. It + is often useful to define a default value for a discriminant even though + it can't be changed by assignment. + +@noindent + RM References: 3.07 (9.1/2) 3.07.02 (3) + + +@item +@emph{AI-0102 Some implicit conversions are illegal (0000-00-00)} +@cindex AI-0102 (Ada 2012 feature) + +@noindent + It is illegal to assign an anonymous access constant to an anonymous access + variable. The RM did not have a clear rule to prevent this, but GNAT has + always generated an error for this usage. + +@noindent + RM References: 3.07 (16) 3.07.01 (9) 6.04.01 (6) 8.06 (27/2) + + +@item +@emph{AI-0158 Generalizing membership tests (2010-09-16)} +@cindex AI-0158 (Ada 2012 feature) + +@noindent + This AI extends the syntax of membership tests to simplify complex conditions + that can be expressed as membership in a subset of values of any type. It + introduces syntax for a list of expressions that may be used in loop contexts + as well. + +@noindent + RM References: 3.08.01 (5) 4.04 (3) 4.05.02 (3) 4.05.02 (5) 4.05.02 (27) + + +@item +@emph{AI-0173 Testing if tags represent abstract types (2010-07-03)} +@cindex AI-0173 (Ada 2012 feature) + +@noindent + The function @code{Ada.Tags.Type_Is_Abstract} returns @code{True} if invoked + with the tag of an abstract type, and @code{False} otherwise. + +@noindent + RM References: 3.09 (7.4/2) 3.09 (12.4/2) + + + +@item +@emph{AI-0076 function with controlling result (0000-00-00)} +@cindex AI-0076 (Ada 2012 feature) + +@noindent + This is an editorial change only. The RM defines calls with controlling + results, but uses the term ``function with controlling result'' without an + explicit definition. + +@noindent + RM References: 3.09.02 (2/2) + + +@item +@emph{AI-0126 Dispatching with no declared operation (0000-00-00)} +@cindex AI-0126 (Ada 2012 feature) + +@noindent + This AI clarifies dispatching rules, and simply confirms that dispatching + executes the operation of the parent type when there is no explicitly or + implicitly declared operation for the descendant type. This has always been + the case in all versions of GNAT. + +@noindent + RM References: 3.09.02 (20/2) 3.09.02 (20.1/2) 3.09.02 (20.2/2) + + +@item +@emph{AI-0097 Treatment of abstract null extension (2010-07-19)} +@cindex AI-0097 (Ada 2012 feature) + +@noindent + The RM as written implied that in some cases it was possible to create an + object of an abstract type, by having an abstract extension inherit a non- + abstract constructor from its parent type. This mistake has been corrected + in GNAT and in the RM, and this construct is now illegal. + +@noindent + RM References: 3.09.03 (4/2) + + +@item +@emph{AI-0203 Extended return cannot be abstract (0000-00-00)} +@cindex AI-0203 (Ada 2012 feature) + +@noindent + A return_subtype_indication cannot denote an abstract subtype. GNAT has never + permitted such usage. + +@noindent + RM References: 3.09.03 (8/3) + + +@item +@emph{AI-0198 Inheriting abstract operators (0000-00-00)} +@cindex AI-0198 (Ada 2012 feature) + +@noindent + This AI resolves a conflict between two rules involving inherited abstract + operations and predefined operators. If a derived numeric type inherits + an abstract operator, it overrides the predefined one. This interpretation + was always the one implemented in GNAT. + +@noindent + RM References: 3.09.03 (4/3) + +@item +@emph{AI-0073 Functions returning abstract types (2010-07-10)} +@cindex AI-0073 (Ada 2012 feature) + +@noindent + This AI covers a number of issues regarding returning abstract types. In + particular generic functions cannot have abstract result types or access + result types designated an abstract type. There are some other cases which + are detailed in the AI. Note that this binding interpretation has not been + retrofitted to operate before Ada 2012 mode, since it caused a significant + number of regressions. + +@noindent + RM References: 3.09.03 (8) 3.09.03 (10) 6.05 (8/2) + + +@item +@emph{AI-0070 Elaboration of interface types (0000-00-00)} +@cindex AI-0070 (Ada 2012 feature) + +@noindent + This is an editorial change only, there are no testable consequences short of + checking for the absence of generated code for an interface declaration. + +@noindent + RM References: 3.09.04 (18/2) + + +@item +@emph{AI-0208 Characteristics of incomplete views (0000-00-00)} +@cindex AI-0208 (Ada 2012 feature) + +@noindent + The wording in the Ada 2005 RM concerning characteristics of incomplete views + was incorrect and implied that some programs intended to be legal were now + illegal. GNAT had never considered such programs illegal, so it has always + implemented the intent of this AI. + +@noindent + RM References: 3.10.01 (2.4/2) 3.10.01 (2.6/2) + + +@item +@emph{AI-0162 Incomplete type completed by partial view (2010-09-15)} +@cindex AI-0162 (Ada 2012 feature) + +@noindent + Incomplete types are made more useful by allowing them to be completed by + private types and private extensions. + +@noindent + RM References: 3.10.01 (2.5/2) 3.10.01 (2.6/2) 3.10.01 (3) 3.10.01 (4/2) + + + +@item +@emph{AI-0098 Anonymous subprogram access restrictions (0000-00-00)} +@cindex AI-0098 (Ada 2012 feature) + +@noindent + An unintentional omission in the RM implied some inconsistent restrictions on + the use of anonymous access to subprogram values. These restrictions were not + intentional, and have never been enforced by GNAT. + +@noindent + RM References: 3.10.01 (6) 3.10.01 (9.2/2) + + +@item +@emph{AI-0199 Aggregate with anonymous access components (2010-07-14)} +@cindex AI-0199 (Ada 2012 feature) + +@noindent + A choice list in a record aggregate can include several components of + (distinct) anonymous access types as long as they have matching designated + subtypes. + +@noindent + RM References: 4.03.01 (16) + + +@item +@emph{AI-0220 Needed components for aggregates (0000-00-00)} +@cindex AI-0220 (Ada 2012 feature) + +@noindent + This AI addresses a wording problem in the RM that appears to permit some + complex cases of aggregates with non-static discriminants. GNAT has always + implemented the intended semantics. + +@noindent + RM References: 4.03.01 (17) + +@item +@emph{AI-0147 Conditional expressions (2009-03-29)} +@cindex AI-0147 (Ada 2012 feature) + +@noindent + Conditional expressions are permitted. The form of such an expression is: + +@smallexample + (@b{if} @i{expr} @b{then} @i{expr} @{@b{elsif} @i{expr} @b{then} @i{expr}@} [@b{else} @i{expr}]) +@end smallexample + + The parentheses can be omitted in contexts where parentheses are present + anyway, such as subprogram arguments and pragma arguments. If the @b{else} + clause is omitted, @b{else True} is assumed; + thus @code{(@b{if} A @b{then} B)} is a way to conveniently represent + @emph{(A implies B)} in standard logic. + +@noindent + RM References: 4.03.03 (15) 4.04 (1) 4.04 (7) 4.05.07 (0) 4.07 (2) + 4.07 (3) 4.09 (12) 4.09 (33) 5.03 (3) 5.03 (4) 7.05 (2.1/2) + + +@item +@emph{AI-0037 Out-of-range box associations in aggregate (0000-00-00)} +@cindex AI-0037 (Ada 2012 feature) + +@noindent + This AI confirms that an association of the form @code{Indx => <>} in an + array aggregate must raise @code{Constraint_Error} if @code{Indx} + is out of range. The RM specified a range check on other associations, but + not when the value of the association was defaulted. GNAT has always inserted + a constraint check on the index value. + +@noindent + RM References: 4.03.03 (29) + + +@item +@emph{AI-0123 Composability of equality (2010-04-13)} +@cindex AI-0123 (Ada 2012 feature) + +@noindent + Equality of untagged record composes, so that the predefined equality for a + composite type that includes a component of some untagged record type + @code{R} uses the equality operation of @code{R} (which may be user-defined + or predefined). This makes the behavior of untagged records identical to that + of tagged types in this respect. + + This change is an incompatibility with previous versions of Ada, but it + corrects a non-uniformity that was often a source of confusion. Analysis of + a large number of industrial programs indicates that in those rare cases + where a composite type had an untagged record component with a user-defined + equality, either there was no use of the composite equality, or else the code + expected the same composability as for tagged types, and thus had a bug that + would be fixed by this change. + +@noindent + RM References: 4.05.02 (9.7/2) 4.05.02 (14) 4.05.02 (15) 4.05.02 (24) + 8.05.04 (8) + + +@item +@emph{AI-0088 The value of exponentiation (0000-00-00)} +@cindex AI-0088 (Ada 2012 feature) + +@noindent + This AI clarifies the equivalence rule given for the dynamic semantics of + exponentiation: the value of the operation can be obtained by repeated + multiplication, but the operation can be implemented otherwise (for example + using the familiar divide-by-two-and-square algorithm, even if this is less + accurate), and does not imply repeated reads of a volatile base. + +@noindent + RM References: 4.05.06 (11) + +@item +@emph{AI-0188 Case expressions (2010-01-09)} +@cindex AI-0188 (Ada 2012 feature) + +@noindent + Case expressions are permitted. This allows use of constructs such as: +@smallexample + X := (@b{case} Y @b{is when} 1 => 2, @b{when} 2 => 3, @b{when others} => 31) +@end smallexample + +@noindent + RM References: 4.05.07 (0) 4.05.08 (0) 4.09 (12) 4.09 (33) + +@item +@emph{AI-0104 Null exclusion and uninitialized allocator (2010-07-15)} +@cindex AI-0104 (Ada 2012 feature) + +@noindent + The assignment @code{Ptr := @b{new not null} Some_Ptr;} will raise + @code{Constraint_Error} because the default value of the allocated object is + @b{null}. This useless construct is illegal in Ada 2012. + +@noindent + RM References: 4.08 (2) + +@item +@emph{AI-0157 Allocation/Deallocation from empty pool (2010-07-11)} +@cindex AI-0157 (Ada 2012 feature) + +@noindent + Allocation and Deallocation from an empty storage pool (i.e. allocation or + deallocation of a pointer for which a static storage size clause of zero + has been given) is now illegal and is detected as such. GNAT + previously gave a warning but not an error. + +@noindent + RM References: 4.08 (5.3/2) 13.11.02 (4) 13.11.02 (17) + +@item +@emph{AI-0179 Statement not required after label (2010-04-10)} +@cindex AI-0179 (Ada 2012 feature) + +@noindent + It is not necessary to have a statement following a label, so a label + can appear at the end of a statement sequence without the need for putting a + null statement afterwards, but it is not allowable to have only labels and + no real statements in a statement sequence. + +@noindent + RM References: 5.01 (2) + + +@item +@emph{AI-139-2 Syntactic sugar for iterators (2010-09-29)} +@cindex AI-139-2 (Ada 2012 feature) + +@noindent + The new syntax for iterating over arrays and containers is now implemented. + Iteration over containers is for now limited to read-only iterators. Only + default iterators are supported, with the syntax: @code{@b{for} Elem @b{of} C}. + +@noindent + RM References: 5.05 + +@item +@emph{AI-0134 Profiles must match for full conformance (0000-00-00)} +@cindex AI-0134 (Ada 2012 feature) + +@noindent + For full conformance, the profiles of anonymous-access-to-subprogram + parameters must match. GNAT has always enforced this rule. + +@noindent + RM References: 6.03.01 (18) + +@item +@emph{AI-0207 Mode conformance and access constant (0000-00-00)} +@cindex AI-0207 (Ada 2012 feature) + +@noindent + This AI confirms that access_to_constant indication must match for mode + conformance. This was implemented in GNAT when the qualifier was originally + introduced in Ada 2005. + +@noindent + RM References: 6.03.01 (16/2) + + +@item +@emph{AI-0046 Null exclusion match for full conformance (2010-07-17)} +@cindex AI-0046 (Ada 2012 feature) + +@noindent + For full conformance, in the case of access parameters, the null exclusion + must match (either both or neither must have @code{@b{not null}}). + +@noindent + RM References: 6.03.02 (18) + + +@item +@emph{AI-0118 The association of parameter associations (0000-00-00)} +@cindex AI-0118 (Ada 2012 feature) + +@noindent + This AI clarifies the rules for named associations in subprogram calls and + generic instantiations. The rules have been in place since Ada 83. + +@noindent + RM References: 6.04.01 (2) 12.03 (9) + + +@item +@emph{AI-0196 Null exclusion tests for out parameters (0000-00-00)} +@cindex AI-0196 (Ada 2012 feature) + +@noindent + Null exclusion checks are not made for @code{@b{out}} parameters when + evaluating the actual parameters. GNAT has never generated these checks. + +@noindent + RM References: 6.04.01 (13) + +@item +@emph{AI-0015 Constant return objects (0000-00-00)} +@cindex AI-0015 (Ada 2012 feature) + +@noindent + The return object declared in an @i{extended_return_statement} may be + declared constant. This was always intended, and GNAT has always allowed it. + +@noindent + RM References: 6.05 (2.1/2) 3.03 (10/2) 3.03 (21) 6.05 (5/2) + 6.05 (5.7/2) + + +@item +@emph{AI-0032 Extended return for class-wide functions (0000-00-00)} +@cindex AI-0032 (Ada 2012 feature) + +@noindent + If a function returns a class-wide type, the object of an extended return + statement can be declared with a specific type that is covered by the class- + wide type. This has been implemented in GNAT since the introduction of + extended returns. Note AI-0103 complements this AI by imposing matching + rules for constrained return types. + +@noindent + RM References: 6.05 (5.2/2) 6.05 (5.3/2) 6.05 (5.6/2) 6.05 (5.8/2) + 6.05 (8/2) + +@item +@emph{AI-0103 Static matching for extended return (2010-07-23)} +@cindex AI-0103 (Ada 2012 feature) + +@noindent + If the return subtype of a function is an elementary type or a constrained + type, the subtype indication in an extended return statement must match + statically this return subtype. + +@noindent + RM References: 6.05 (5.2/2) + + +@item +@emph{AI-0058 Abnormal completion of an extended return (0000-00-00)} +@cindex AI-0058 (Ada 2012 feature) + +@noindent + The RM had some incorrect wording implying wrong treatment of abnormal + completion in an extended return. GNAT has always implemented the intended + correct semantics as described by this AI. + +@noindent + RM References: 6.05 (22/2) + + +@item +@emph{AI-0050 Raising Constraint_Error early for function call (0000-00-00)} +@cindex AI-0050 (Ada 2012 feature) + +@noindent + The implementation permissions for raising @code{Constraint_Error} early on a function call when it was clear an exception would be raised were over-permissive and allowed mishandling of discriminants in some cases. GNAT did + not take advantage of these incorrect permissions in any case. + +@noindent + RM References: 6.05 (24/2) + + +@item +@emph{AI-0125 Nonoverridable operations of an ancestor (2010-09-28)} +@cindex AI-0125 (Ada 2012 feature) + +@noindent + In Ada 2012, the declaration of a primitive operation of a type extension + or private extension can also override an inherited primitive that is not + visible at the point of this declaration. + +@noindent + RM References: 7.03.01 (6) 8.03 (23) 8.03.01 (5/2) 8.03.01 (6/2) + +@item +@emph{AI-0062 Null exclusions and deferred constants (0000-00-00)} +@cindex AI-0062 (Ada 2012 feature) + +@noindent + A full constant may have a null exclusion even if its associated deferred + constant does not. GNAT has always allowed this. + +@noindent + RM References: 7.04 (6/2) 7.04 (7.1/2) + + +@item +@emph{AI-0178 Incomplete views are limited (0000-00-00)} +@cindex AI-0178 (Ada 2012 feature) + +@noindent + This AI clarifies the role of incomplete views and plugs an omission in the + RM. GNAT always correctly restricted the use of incomplete views and types. + +@noindent + RM References: 7.05 (3/2) 7.05 (6/2) + +@item +@emph{AI-0087 Actual for formal nonlimited derived type (2010-07-15)} +@cindex AI-0087 (Ada 2012 feature) + +@noindent + The actual for a formal nonlimited derived type cannot be limited. In + particular, a formal derived type that extends a limited interface but which + is not explicitly limited cannot be instantiated with a limited type. + +@noindent + RM References: 7.05 (5/2) 12.05.01 (5.1/2) + +@item +@emph{AI-0099 Tag determines whether finalization needed (0000-00-00)} +@cindex AI-0099 (Ada 2012 feature) + +@noindent + This AI clarifies that ``needs finalization'' is part of dynamic semantics, + and therefore depends on the run-time characteristics of an object (i.e. its + tag) and not on its nominal type. As the AI indicates: ``we do not expect + this to affect any implementation''. + +@noindent + RM References: 7.06.01 (6) 7.06.01 (7) 7.06.01 (8) 7.06.01 (9/2) + + + +@item +@emph{AI-0064 Redundant finalization rule (0000-00-00)} +@cindex AI-0064 (Ada 2012 feature) + +@noindent + This is an editorial change only. The intended behavior is already checked + by an existing ACATS test, which GNAT has always executed correctly. + +@noindent + RM References: 7.06.01 (17.1/1) + +@item +@emph{AI-0026 Missing rules for Unchecked_Union (2010-07-07)} +@cindex AI-0026 (Ada 2012 feature) + +@noindent + Record representation clauses concerning Unchecked_Union types cannot mention + the discriminant of the type. The type of a component declared in the variant + part of an Unchecked_Union cannot be controlled, have controlled components, + nor have protected or task parts. If an Unchecked_Union type is declared + within the body of a generic unit or its descendants, then the type of a + component declared in the variant part cannot be a formal private type or a + formal private extension declared within the same generic unit. + +@noindent + RM References: 7.06 (9.4/2) B.03.03 (9/2) B.03.03 (10/2) + + +@item +@emph{AI-0205 Extended return declares visible name (0000-00-00)} +@cindex AI-0205 (Ada 2012 feature) + +@noindent + This AI corrects a simple omission in the RM. Return objects have always + been visible within an extended return statement. + +@noindent + RM References: 8.03 (17) + + +@item +@emph{AI-0042 Overriding versus implemented-by (0000-00-00)} +@cindex AI-0042 (Ada 2012 feature) + +@noindent + This AI fixes a wording gap in the RM. An operation of a synchronized + interface can be implemented by a protected or task entry, but the abstract + operation is not being overridden in the usual sense, and it must be stated + separately that this implementation is legal. This has always been the case + in GNAT. + +@noindent + RM References: 9.01 (9.2/2) 9.04 (11.1/2) + +@item +@emph{AI-0030 Requeue on synchronized interfaces (2010-07-19)} +@cindex AI-0030 (Ada 2012 feature) + +@noindent + Requeue is permitted to a protected, synchronized or task interface primitive + providing it is known that the overriding operation is an entry. Otherwise + the requeue statement has the same effect as a procedure call. Use of pragma + @code{Implemented} provides a way to impose a static requirement on the + overriding operation by adhering to one of the implementation kinds: entry, + protected procedure or any of the above. + +@noindent + RM References: 9.05 (9) 9.05.04 (2) 9.05.04 (3) 9.05.04 (5) + 9.05.04 (6) 9.05.04 (7) 9.05.04 (12) + + +@item +@emph{AI-0201 Independence of atomic object components (2010-07-22)} +@cindex AI-0201 (Ada 2012 feature) + +@noindent + If an Atomic object has a pragma @code{Pack} or a @code{Component_Size} + attribute, then individual components may not be addressable by independent + tasks. However, if the representation clause has no effect (is confirming), + then independence is not compromised. Furthermore, in GNAT, specification of + other appropriately addressable component sizes (e.g. 16 for 8-bit + characters) also preserves independence. GNAT now gives very clear warnings + both for the declaration of such a type, and for any assignment to its components. + +@noindent + RM References: 9.10 (1/3) C.06 (22/2) C.06 (23/2) + +@item +@emph{AI-0009 Pragma Independent[_Components] (2010-07-23)} +@cindex AI-0009 (Ada 2012 feature) + +@noindent + This AI introduces the new pragmas @code{Independent} and + @code{Independent_Components}, + which control guaranteeing independence of access to objects and components. + The AI also requires independence not unaffected by confirming rep clauses. + +@noindent + RM References: 9.10 (1) 13.01 (15/1) 13.02 (9) 13.03 (13) C.06 (2) + C.06 (4) C.06 (6) C.06 (9) C.06 (13) C.06 (14) + + +@item +@emph{AI-0072 Task signalling using 'Terminated (0000-00-00)} +@cindex AI-0072 (Ada 2012 feature) + +@noindent + This AI clarifies that task signalling for reading @code{'Terminated} only + occurs if the result is True. GNAT semantics has always been consistent with + this notion of task signalling. + +@noindent + RM References: 9.10 (6.1/1) + +@item +@emph{AI-0108 Limited incomplete view and discriminants (0000-00-00)} +@cindex AI-0108 (Ada 2012 feature) + +@noindent + This AI confirms that an incomplete type from a limited view does not have + discriminants. This has always been the case in GNAT. + +@noindent + RM References: 10.01.01 (12.3/2) + +@item +@emph{AI-0129 Limited views and incomplete types (0000-00-00)} +@cindex AI-0129 (Ada 2012 feature) + +@noindent + This AI clarifies the description of limited views: a limited view of a + package includes only one view of a type that has an incomplete declaration + and a full declaration (there is no possible ambiguity in a client package). + This AI also fixes an omission: a nested package in the private part has no + limited view. GNAT always implemented this correctly. + +@noindent + RM References: 10.01.01 (12.2/2) 10.01.01 (12.3/2) + + + +@item +@emph{AI-0077 Limited withs and scope of declarations (0000-00-00)} +@cindex AI-0077 (Ada 2012 feature) + +@noindent + This AI clarifies that a declaration does not include a context clause, + and confirms that it is illegal to have a context in which both a limited + and a nonlimited view of a package are accessible. Such double visibility + was always rejected by GNAT. + +@noindent + RM References: 10.01.02 (12/2) 10.01.02 (21/2) 10.01.02 (22/2) + +@item +@emph{AI-0122 Private with and children of generics (0000-00-00)} +@cindex AI-0122 (Ada 2012 feature) + +@noindent + This AI clarifies the visibility of private children of generic units within + instantiations of a parent. GNAT has always handled this correctly. + +@noindent + RM References: 10.01.02 (12/2) + + + +@item +@emph{AI-0040 Limited with clauses on descendant (0000-00-00)} +@cindex AI-0040 (Ada 2012 feature) + +@noindent + This AI confirms that a limited with clause in a child unit cannot name + an ancestor of the unit. This has always been checked in GNAT. + +@noindent + RM References: 10.01.02 (20/2) + +@item +@emph{AI-0132 Placement of library unit pragmas (0000-00-00)} +@cindex AI-0132 (Ada 2012 feature) + +@noindent + This AI fills a gap in the description of library unit pragmas. The pragma + clearly must apply to a library unit, even if it does not carry the name + of the enclosing unit. GNAT has always enforced the required check. + +@noindent + RM References: 10.01.05 (7) + + +@item +@emph{AI-0034 Categorization of limited views (0000-00-00)} +@cindex AI-0034 (Ada 2012 feature) + +@noindent + The RM makes certain limited with clauses illegal because of categorization + considerations, when the corresponding normal with would be legal. This is + not intended, and GNAT has always implemented the recommended behavior. + +@noindent + RM References: 10.02.01 (11/1) 10.02.01 (17/2) + + +@item +@emph{AI-0035 Inconsistencies with Pure units (0000-00-00)} +@cindex AI-0035 (Ada 2012 feature) + +@noindent + This AI remedies some inconsistencies in the legality rules for Pure units. + Derived access types are legal in a pure unit (on the assumption that the + rule for a zero storage pool size has been enforced on the ancestor type). + The rules are enforced in generic instances and in subunits. GNAT has always + implemented the recommended behavior. + +@noindent + RM References: 10.02.01 (15.1/2) 10.02.01 (15.4/2) 10.02.01 (15.5/2) 10.02.01 (17/2) + + +@item +@emph{AI-0219 Pure permissions and limited parameters (2010-05-25)} +@cindex AI-0219 (Ada 2012 feature) + +@noindent + This AI refines the rules for the cases with limited parameters which do not + allow the implementations to omit ``redundant''. GNAT now properly conforms + to the requirements of this binding interpretation. + +@noindent + RM References: 10.02.01 (18/2) + +@item +@emph{AI-0043 Rules about raising exceptions (0000-00-00)} +@cindex AI-0043 (Ada 2012 feature) + +@noindent + This AI covers various omissions in the RM regarding the raising of + exceptions. GNAT has always implemented the intended semantics. + +@noindent + RM References: 11.04.01 (10.1/2) 11 (2) + + +@item +@emph{AI-0200 Mismatches in formal package declarations (0000-00-00)} +@cindex AI-0200 (Ada 2012 feature) + +@noindent + This AI plugs a gap in the RM which appeared to allow some obviously intended + illegal instantiations. GNAT has never allowed these instantiations. + +@noindent + RM References: 12.07 (16) + + +@item +@emph{AI-0112 Detection of duplicate pragmas (2010-07-24)} +@cindex AI-0112 (Ada 2012 feature) + +@noindent + This AI concerns giving names to various representation aspects, but the + practical effect is simply to make the use of duplicate + @code{Atomic}[@code{_Components}], + @code{Volatile}[@code{_Components}] and + @code{Independent}[@code{_Components}] pragmas illegal, and GNAT + now performs this required check. + +@noindent + RM References: 13.01 (8) + +@item +@emph{AI-0106 No representation pragmas on generic formals (0000-00-00)} +@cindex AI-0106 (Ada 2012 feature) + +@noindent + The RM appeared to allow representation pragmas on generic formal parameters, + but this was not intended, and GNAT has never permitted this usage. + +@noindent + RM References: 13.01 (9.1/1) + + +@item +@emph{AI-0012 Pack/Component_Size for aliased/atomic (2010-07-15)} +@cindex AI-0012 (Ada 2012 feature) + +@noindent + It is now illegal to give an inappropriate component size or a pragma + @code{Pack} that attempts to change the component size in the case of atomic + or aliased components. Previously GNAT ignored such an attempt with a + warning. + +@noindent + RM References: 13.02 (6.1/2) 13.02 (7) C.06 (10) C.06 (11) C.06 (21) + + +@item +@emph{AI-0039 Stream attributes cannot be dynamic (0000-00-00)} +@cindex AI-0039 (Ada 2012 feature) + +@noindent + The RM permitted the use of dynamic expressions (such as @code{ptr.@b{all})} + for stream attributes, but these were never useful and are now illegal. GNAT + has always regarded such expressions as illegal. + +@noindent + RM References: 13.03 (4) 13.03 (6) 13.13.02 (38/2) + + +@item +@emph{AI-0095 Address of intrinsic subprograms (0000-00-00)} +@cindex AI-0095 (Ada 2012 feature) + +@noindent + The prefix of @code{'Address} cannot statically denote a subprogram with + convention @code{Intrinsic}. The use of the @code{Address} attribute raises + @code{Program_Error} if the prefix denotes a subprogram with convention + @code{Intrinsic}. + +@noindent + RM References: 13.03 (11/1) + + +@item +@emph{AI-0116 Alignment of class-wide objects (0000-00-00)} +@cindex AI-0116 (Ada 2012 feature) + +@noindent + This AI requires that the alignment of a class-wide object be no greater + than the alignment of any type in the class. GNAT has always followed this + recommendation. + +@noindent + RM References: 13.03 (29) 13.11 (16) + + +@item +@emph{AI-0146 Type invariants (2009-09-21)} +@cindex AI-0146 (Ada 2012 feature) + +@noindent + Type invariants may be specified for private types using the aspect notation. + Aspect @code{Invariant} may be specified for any private type, + @code{Invariant'Class} can + only be specified for tagged types, and is inherited by any descendent of the + tagged types. The invariant is a boolean expression that is tested for being + true in the following situations: conversions to the private type, object + declarations for the private type that are default initialized, and + [@b{in}] @b{out} + parameters and returned result on return from any primitive operation for + the type that is visible to a client. + +@noindent + RM References: 13.03.03 (00) + +@item +@emph{AI-0078 Relax Unchecked_Conversion alignment rules (0000-00-00)} +@cindex AI-0078 (Ada 2012 feature) + +@noindent + In Ada 2012, compilers are required to support unchecked conversion where the + target alignment is a multiple of the source alignment. GNAT always supported + this case (and indeed all cases of differing alignments, doing copies where + required if the alignment was reduced). + +@noindent + RM References: 13.09 (7) + + +@item +@emph{AI-0195 Invalid value handling is implementation defined (2010-07-03)} +@cindex AI-0195 (Ada 2012 feature) + +@noindent + The handling of invalid values is now designated to be implementation + defined. This is a documentation change only, requiring Annex M in the GNAT + Reference Manual to document this handling. + In GNAT, checks for invalid values are made + only when necessary to avoid erroneous behavior. Operations like assignments + which cannot cause erroneous behavior ignore the possibility of invalid + values and do not do a check. The date given above applies only to the + documentation change, this behavior has always been implemented by GNAT. + +@noindent + RM References: 13.09.01 (10) + +@item +@emph{AI-0193 Alignment of allocators (2010-09-16)} +@cindex AI-0193 (Ada 2012 feature) + +@noindent + This AI introduces a new attribute @code{Max_Alignment_For_Allocation}, + analogous to @code{Max_Size_In_Storage_Elements}, but for alignment instead + of size. + +@noindent + RM References: 13.11 (16) 13.11 (21) 13.11.01 (0) 13.11.01 (1) + 13.11.01 (2) 13.11.01 (3) + + +@item +@emph{AI-0177 Parameterized expressions (2010-07-10)} +@cindex AI-0177 (Ada 2012 feature) + +@noindent + The new Ada 2012 notion of parameterized expressions is implemented. The form + is: +@smallexample + @i{function specification} @b{is} (@i{expression}) +@end smallexample + +@noindent + This is exactly equivalent to the + corresponding function body that returns the expression, but it can appear + in a package spec. Note that the expression must be parenthesized. + +@noindent + RM References: 13.11.01 (3/2) + +@item +@emph{AI-0033 Attach/Interrupt_Handler in generic (2010-07-24)} +@cindex AI-0033 (Ada 2012 feature) + +@noindent + Neither of these two pragmas may appear within a generic template, because + the generic might be instantiated at other than the library level. + +@noindent + RM References: 13.11.02 (16) C.03.01 (7/2) C.03.01 (8/2) + + +@item +@emph{AI-0161 Restriction No_Default_Stream_Attributes (2010-09-11)} +@cindex AI-0161 (Ada 2012 feature) + +@noindent + A new restriction @code{No_Default_Stream_Attributes} prevents the use of any + of the default stream attributes for elementary types. If this restriction is + in force, then it is necessary to provide explicit subprograms for any + stream attributes used. + +@noindent + RM References: 13.12.01 (4/2) 13.13.02 (40/2) 13.13.02 (52/2) + +@item +@emph{AI-0194 Value of Stream_Size attribute (0000-00-00)} +@cindex AI-0194 (Ada 2012 feature) + +@noindent + The @code{Stream_Size} attribute returns the default number of bits in the + stream representation of the given type. + This value is not affected by the presence + of stream subprogram attributes for the type. GNAT has always implemented + this interpretation. + +@noindent + RM References: 13.13.02 (1.2/2) + +@item +@emph{AI-0109 Redundant check in S'Class'Input (0000-00-00)} +@cindex AI-0109 (Ada 2012 feature) + +@noindent + This AI is an editorial change only. It removes the need for a tag check + that can never fail. + +@noindent + RM References: 13.13.02 (34/2) + +@item +@emph{AI-0007 Stream read and private scalar types (0000-00-00)} +@cindex AI-0007 (Ada 2012 feature) + +@noindent + The RM as written appeared to limit the possibilities of declaring read + attribute procedures for private scalar types. This limitation was not + intended, and has never been enforced by GNAT. + +@noindent + RM References: 13.13.02 (50/2) 13.13.02 (51/2) + + +@item +@emph{AI-0065 Remote access types and external streaming (0000-00-00)} +@cindex AI-0065 (Ada 2012 feature) + +@noindent + This AI clarifies the fact that all remote access types support external + streaming. This fixes an obvious oversight in the definition of the + language, and GNAT always implemented the intended correct rules. + +@noindent + RM References: 13.13.02 (52/2) + +@item +@emph{AI-0019 Freezing of primitives for tagged types (0000-00-00)} +@cindex AI-0019 (Ada 2012 feature) + +@noindent + The RM suggests that primitive subprograms of a specific tagged type are + frozen when the tagged type is frozen. This would be an incompatible change + and is not intended. GNAT has never attempted this kind of freezing and its + behavior is consistent with the recommendation of this AI. + +@noindent + RM References: 13.14 (2) 13.14 (3/1) 13.14 (8.1/1) 13.14 (10) 13.14 (14) 13.14 (15.1/2) + +@item +@emph{AI-0017 Freezing and incomplete types (0000-00-00)} +@cindex AI-0017 (Ada 2012 feature) + +@noindent + So-called ``Taft-amendment types'' (i.e., types that are completed in package + bodies) are not frozen by the occurrence of bodies in the + enclosing declarative part. GNAT always implemented this properly. + +@noindent + RM References: 13.14 (3/1) + + +@item +@emph{AI-0060 Extended definition of remote access types (0000-00-00)} +@cindex AI-0060 (Ada 2012 feature) + +@noindent + This AI extends the definition of remote access types to include access + to limited, synchronized, protected or task class-wide interface types. + GNAT already implemented this extension. + +@noindent + RM References: A (4) E.02.02 (9/1) E.02.02 (9.2/1) E.02.02 (14/2) E.02.02 (18) + +@item +@emph{AI-0114 Classification of letters (0000-00-00)} +@cindex AI-0114 (Ada 2012 feature) + +@noindent + The code points 170 (@code{FEMININE ORDINAL INDICATOR}), + 181 (@code{MICRO SIGN}), and + 186 (@code{MASCULINE ORDINAL INDICATOR}) are technically considered + lower case letters by Unicode. + However, they are not allowed in identifiers, and they + return @code{False} to @code{Ada.Characters.Handling.Is_Letter/Is_Lower}. + This behavior is consistent with that defined in Ada 95. + +@noindent + RM References: A.03.02 (59) A.04.06 (7) + + +@item +@emph{AI-0185 Ada.Wide_[Wide_]Characters.Handling (2010-07-06)} +@cindex AI-0185 (Ada 2012 feature) + +@noindent + Two new packages @code{Ada.Wide_[Wide_]Characters.Handling} provide + classification functions for @code{Wide_Character} and + @code{Wide_Wide_Character}, as well as providing + case folding routines for @code{Wide_[Wide_]Character} and + @code{Wide_[Wide_]String}. + +@noindent + RM References: A.03.05 (0) A.03.06 (0) + + +@item +@emph{AI-0031 Add From parameter to Find_Token (2010-07-25)} +@cindex AI-0031 (Ada 2012 feature) + +@noindent + A new version of @code{Find_Token} is added to all relevant string packages, + with an extra parameter @code{From}. Instead of starting at the first + character of the string, the search for a matching Token starts at the + character indexed by the value of @code{From}. + These procedures are available in all versions of Ada + but if used in versions earlier than Ada 2012 they will generate a warning + that an Ada 2012 subprogram is being used. + +@noindent + RM References: A.04.03 (16) A.04.03 (67) A.04.03 (68/1) A.04.04 (51) + A.04.05 (46) + + +@item +@emph{AI-0056 Index on null string returns zero (0000-00-00)} +@cindex AI-0056 (Ada 2012 feature) + +@noindent + The wording in the Ada 2005 RM implied an incompatible handling of the + @code{Index} functions, resulting in raising an exception instead of + returning zero in some situations. + This was not intended and has been corrected. + GNAT always returned zero, and is thus consistent with this AI. + +@noindent + RM References: A.04.03 (56.2/2) A.04.03 (58.5/2) + + +@item +@emph{AI-0137 String encoding package (2010-03-25)} +@cindex AI-0137 (Ada 2012 feature) + +@noindent + The packages @code{Ada.Strings.UTF_Encoding}, together with its child + packages, @code{Conversions}, @code{Strings}, @code{Wide_Strings}, + and @code{Wide_Wide_Strings} have been + implemented. These packages (whose documentation can be found in the spec + files @file{a-stuten.ads}, @file{a-suenco.ads}, @file{a-suenst.ads}, + @file{a-suewst.ads}, @file{a-suezst.ads}) allow encoding and decoding of + @code{String}, @code{Wide_String}, and @code{Wide_Wide_String} + values using UTF coding schemes (including UTF-8, UTF-16LE, UTF-16BE, and + UTF-16), as well as conversions between the different UTF encodings. With + the exception of @code{Wide_Wide_Strings}, these packages are available in + Ada 95 and Ada 2005 mode as well as Ada 2012 mode. + The @code{Wide_Wide_Strings package} + is available in Ada 2005 mode as well as Ada 2012 mode (but not in Ada 95 + mode since it uses @code{Wide_Wide_Character}). + +@noindent + RM References: A.04.11 + +@item +@emph{AI-0038 Minor errors in Text_IO (0000-00-00)} +@cindex AI-0038 (Ada 2012 feature) + +@noindent + These are minor errors in the description on three points. The intent on + all these points has always been clear, and GNAT has always implemented the + correct intended semantics. + +@noindent + RM References: A.10.05 (37) A.10.07 (8/1) A.10.07 (10) A.10.07 (12) A.10.08 (10) A.10.08 (24) + +@item +@emph{AI-0044 Restrictions on container instantiations (0000-00-00)} +@cindex AI-0044 (Ada 2012 feature) + +@noindent + This AI places restrictions on allowed instantiations of generic containers. + These restrictions are not checked by the compiler, so there is nothing to + change in the implementation. This affects only the RM documentation. + +@noindent + RM References: A.18 (4/2) A.18.02 (231/2) A.18.03 (145/2) A.18.06 (56/2) A.18.08 (66/2) A.18.09 (79/2) A.18.26 (5/2) A.18.26 (9/2) + +@item +@emph{AI-0127 Adding Locale Capabilities (2010-09-29)} +@cindex AI-0127 (Ada 2012 feature) + +@noindent + This package provides an interface for identifying the current locale. + +@noindent + RM References: A.19 A.19.01 A.19.02 A.19.03 A.19.05 A.19.06 + A.19.07 A.19.08 A.19.09 A.19.10 A.19.11 A.19.12 A.19.13 + + + +@item +@emph{AI-0002 Export C with unconstrained arrays (0000-00-00)} +@cindex AI-0002 (Ada 2012 feature) + +@noindent + The compiler is not required to support exporting an Ada subprogram with + convention C if there are parameters or a return type of an unconstrained + array type (such as @code{String}). GNAT allows such declarations but + generates warnings. It is possible, but complicated, to write the + corresponding C code and certainly such code would be specific to GNAT and + non-portable. + +@noindent + RM References: B.01 (17) B.03 (62) B.03 (71.1/2) + + +@item +@emph{AI-0216 No_Task_Hierarchy forbids local tasks (0000-00-00)} +@cindex AI-0216 (Ada 2012 feature) + +@noindent + It is clearly the intention that @code{No_Task_Hierarchy} is intended to + forbid tasks declared locally within subprograms, or functions returning task + objects, and that is the implementation that GNAT has always provided. + However the language in the RM was not sufficiently clear on this point. + Thus this is a documentation change in the RM only. + +@noindent + RM References: D.07 (3/3) + +@item +@emph{AI-0211 No_Relative_Delays forbids Set_Handler use (2010-07-09)} +@cindex AI-0211 (Ada 2012 feature) + +@noindent + The restriction @code{No_Relative_Delays} forbids any calls to the subprogram + @code{Ada.Real_Time.Timing_Events.Set_Handler}. + +@noindent + RM References: D.07 (5) D.07 (10/2) D.07 (10.4/2) D.07 (10.7/2) + +@item +@emph{AI-0190 pragma Default_Storage_Pool (2010-09-15)} +@cindex AI-0190 (Ada 2012 feature) + +@noindent + This AI introduces a new pragma @code{Default_Storage_Pool}, which can be + used to control storage pools globally. + In particular, you can force every access + type that is used for allocation (@b{new}) to have an explicit storage pool, + or you can declare a pool globally to be used for all access types that lack + an explicit one. + +@noindent + RM References: D.07 (8) + +@item +@emph{AI-0189 No_Allocators_After_Elaboration (2010-01-23)} +@cindex AI-0189 (Ada 2012 feature) + +@noindent + This AI introduces a new restriction @code{No_Allocators_After_Elaboration}, + which says that no dynamic allocation will occur once elaboration is + completed. + In general this requires a run-time check, which is not required, and which + GNAT does not attempt. But the static cases of allocators in a task body or + in the body of the main program are detected and flagged at compile or bind + time. + +@noindent + RM References: D.07 (19.1/2) H.04 (23.3/2) + +@item +@emph{AI-0171 Pragma CPU and Ravenscar Profile (2010-09-24)} +@cindex AI-0171 (Ada 2012 feature) + +@noindent + A new package @code{System.Multiprocessors} is added, together with the + definition of pragma @code{CPU} for controlling task affinity. A new no + dependence restriction, on @code{System.Multiprocessors.Dispatching_Domains}, + is added to the Ravenscar profile. + +@noindent + RM References: D.13.01 (4/2) D.16 + + +@item +@emph{AI-0210 Correct Timing_Events metric (0000-00-00)} +@cindex AI-0210 (Ada 2012 feature) + +@noindent + This is a documentation only issue regarding wording of metric requirements, + that does not affect the implementation of the compiler. + +@noindent + RM References: D.15 (24/2) + + +@item +@emph{AI-0206 Remote types packages and preelaborate (2010-07-24)} +@cindex AI-0206 (Ada 2012 feature) + +@noindent + Remote types packages are now allowed to depend on preelaborated packages. + This was formerly considered illegal. + +@noindent + RM References: E.02.02 (6) + + + +@item +@emph{AI-0152 Restriction No_Anonymous_Allocators (2010-09-08)} +@cindex AI-0152 (Ada 2012 feature) + +@noindent + Restriction @code{No_Anonymous_Allocators} prevents the use of allocators + where the type of the returned value is an anonymous access type. + +@noindent + RM References: H.04 (8/1) +@end itemize + + +@node Obsolescent Features +@chapter Obsolescent Features + +@noindent +This chapter describes features that are provided by GNAT, but are +considered obsolescent since there are preferred ways of achieving +the same effect. These features are provided solely for historical +compatibility purposes. + +@menu +* pragma No_Run_Time:: +* pragma Ravenscar:: +* pragma Restricted_Run_Time:: +@end menu + +@node pragma No_Run_Time +@section pragma No_Run_Time + +The pragma @code{No_Run_Time} is used to achieve an affect similar +to the use of the "Zero Foot Print" configurable run time, but without +requiring a specially configured run time. The result of using this +pragma, which must be used for all units in a partition, is to restrict +the use of any language features requiring run-time support code. The +preferred usage is to use an appropriately configured run-time that +includes just those features that are to be made accessible. + +@node pragma Ravenscar +@section pragma Ravenscar + +The pragma @code{Ravenscar} has exactly the same effect as pragma +@code{Profile (Ravenscar)}. The latter usage is preferred since it +is part of the new Ada 2005 standard. + +@node pragma Restricted_Run_Time +@section pragma Restricted_Run_Time + +The pragma @code{Restricted_Run_Time} has exactly the same effect as +pragma @code{Profile (Restricted)}. The latter usage is +preferred since the Ada 2005 pragma @code{Profile} is intended for +this kind of implementation dependent addition. + +@include fdl.texi +@c GNU Free Documentation License + +@node Index,,GNU Free Documentation License, Top +@unnumbered Index + +@printindex cp + +@contents + +@bye diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi new file mode 100644 index 000000000..d843106df --- /dev/null +++ b/gcc/ada/gnat_ugn.texi @@ -0,0 +1,28265 @@ +\input texinfo @c -*-texinfo-*- +@c %**start of header + +@c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo +@c o +@c GNAT DOCUMENTATION o +@c o +@c G N A T _ U G N o +@c o +@c Copyright (C) 1992-2010, AdaCore o +@c o +@c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo + +@setfilename gnat_ugn.info + +@copying +Copyright @copyright{} 1995-2009 Free Software Foundation, +Inc. + +Permission is granted to copy, distribute and/or modify this document +under the terms of the GNU Free Documentation License, Version 1.3 or +any later version published by the Free Software Foundation; with no +Invariant Sections, with no Front-Cover Texts and with no Back-Cover +Texts. A copy of the license is included in the section entitled +``GNU Free Documentation License''. +@end copying + +@c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo +@c +@c GNAT_UGN Style Guide +@c +@c 1. Always put a @noindent on the line before the first paragraph +@c after any of these commands: +@c +@c @chapter +@c @section +@c @subsection +@c @subsubsection +@c @subsubsubsection +@c +@c @end smallexample +@c @end itemize +@c @end enumerate +@c +@c 2. DO NOT use @example. Use @smallexample instead. +@c a) DO NOT use highlighting commands (@b{}, @i{}) inside an @smallexample +@c context. These can interfere with the readability of the texi +@c source file. Instead, use one of the following annotated +@c @smallexample commands, and preprocess the texi file with the +@c ada2texi tool (which generates appropriate highlighting): +@c @smallexample @c ada +@c @smallexample @c adanocomment +@c @smallexample @c projectfile +@c b) The "@c ada" markup will result in boldface for reserved words +@c and italics for comments +@c c) The "@c adanocomment" markup will result only in boldface for +@c reserved words (comments are left alone) +@c d) The "@c projectfile" markup is like "@c ada" except that the set +@c of reserved words include the new reserved words for project files +@c +@c 3. Each @chapter, @section, @subsection, @subsubsection, etc. +@c command must be preceded by two empty lines +@c +@c 4. The @item command should be on a line of its own if it is in an +@c @itemize or @enumerate command. +@c +@c 5. When talking about ALI files use "ALI" (all uppercase), not "Ali" +@c or "ali". +@c +@c 6. DO NOT put trailing spaces at the end of a line. Such spaces will +@c cause the document build to fail. +@c +@c 7. DO NOT use @cartouche for examples that are longer than around 10 lines. +@c This command inhibits page breaks, so long examples in a @cartouche can +@c lead to large, ugly patches of empty space on a page. +@c +@c NOTE: This file should be submitted to xgnatugn with either the vms flag +@c or the unw flag set. The unw flag covers topics for both Unix and +@c Windows. +@c +@c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo + +@set NOW January 2007 +@c This flag is used where the text refers to conditions that exist when the +@c text was entered into the document but which may change over time. +@c Update the setting for the flag, and (if necessary) the text surrounding, +@c the references to the flag, on future doc revisions: +@c search for @value{NOW}. + +@set FSFEDITION +@set EDITION GNAT +@set DEFAULTLANGUAGEVERSION Ada 2005 +@set NONDEFAULTLANGUAGEVERSION Ada 95 + +@ifset unw +@set PLATFORM +@end ifset + +@ifset vms +@set PLATFORM OpenVMS +@end ifset + +@c @ovar(ARG) +@c ---------- +@c The ARG is an optional argument. To be used for macro arguments in +@c their documentation (@defmac). +@macro ovar{varname} +@r{[}@var{\varname\}@r{]}@c +@end macro +@c Status as of November 2009: +@c Unfortunately texi2pdf and texi2html treat the trailing "@c" +@c differently, and faulty output is produced by one or the other +@c depending on whether the "@c" is present or absent. +@c As a result, the @ovar macro is not used, and all invocations +@c of the @ovar macro have been expanded inline. + + +@settitle @value{EDITION} User's Guide @value{PLATFORM} +@dircategory GNU Ada tools +@direntry +* @value{EDITION} User's Guide: (gnat_ugn). @value{PLATFORM} +@end direntry + +@include gcc-common.texi + +@setchapternewpage odd +@syncodeindex fn cp +@c %**end of header + +@titlepage +@title @value{EDITION} User's Guide +@ifset vms +@sp 1 +@flushright +@titlefont{@i{@value{PLATFORM}}} +@end flushright +@end ifset + +@sp 2 + +@subtitle GNAT, The GNU Ada Compiler +@versionsubtitle +@author AdaCore + +@page +@vskip 0pt plus 1filll + +@insertcopying + +@end titlepage + +@ifnottex +@node Top, About This Guide, (dir), (dir) +@top @value{EDITION} User's Guide + +@noindent +@value{EDITION} User's Guide @value{PLATFORM} + +@noindent +GNAT, The GNU Ada Compiler@* +GCC version @value{version-GCC}@* + +@noindent +AdaCore@* + +@menu +* About This Guide:: +* Getting Started with GNAT:: +* The GNAT Compilation Model:: +* Compiling Using gcc:: +* Binding Using gnatbind:: +* Linking Using gnatlink:: +* The GNAT Make Program gnatmake:: +* Improving Performance:: +* Renaming Files Using gnatchop:: +* Configuration Pragmas:: +* Handling Arbitrary File Naming Conventions Using gnatname:: +* GNAT Project Manager:: +* Tools Supporting Project Files:: +* The Cross-Referencing Tools gnatxref and gnatfind:: +* The GNAT Pretty-Printer gnatpp:: +* The GNAT Metric Tool gnatmetric:: +* File Name Krunching Using gnatkr:: +* Preprocessing Using gnatprep:: +* The GNAT Library Browser gnatls:: +* Cleaning Up Using gnatclean:: +@ifclear vms +* GNAT and Libraries:: +* Using the GNU make Utility:: +@end ifclear +* Memory Management Issues:: +* Stack Related Facilities:: +* Verifying Properties Using gnatcheck:: +* Creating Sample Bodies Using gnatstub:: +* Generating Ada Bindings for C and C++ headers:: +* Other Utility Programs:: +* Running and Debugging Ada Programs:: +@ifclear vms +* Code Coverage and Profiling:: +@end ifclear +@ifset vms +* Compatibility with HP Ada:: +@end ifset +* Platform-Specific Information for the Run-Time Libraries:: +* Example of Binder Output File:: +* Elaboration Order Handling in GNAT:: +* Conditional Compilation:: +* Inline Assembler:: +* Compatibility and Porting Guide:: +@ifset unw +* Microsoft Windows Topics:: +@end ifset +* GNU Free Documentation License:: +* Index:: + + --- The Detailed Node Listing --- + +About This Guide + +* What This Guide Contains:: +* What You Should Know before Reading This Guide:: +* Related Information:: +* Conventions:: + +Getting Started with GNAT + +* Running GNAT:: +* Running a Simple Ada Program:: +* Running a Program with Multiple Units:: +* Using the gnatmake Utility:: +@ifset vms +* Editing with Emacs:: +@end ifset +@ifclear vms +* Introduction to GPS:: +@end ifclear + +The GNAT Compilation Model + +* Source Representation:: +* Foreign Language Representation:: +* File Naming Rules:: +* Using Other File Names:: +* Alternative File Naming Schemes:: +* Generating Object Files:: +* Source Dependencies:: +* The Ada Library Information Files:: +* Binding an Ada Program:: +* Mixed Language Programming:: +@ifclear vms +* Building Mixed Ada & C++ Programs:: +* Comparison between GNAT and C/C++ Compilation Models:: +@end ifclear +* Comparison between GNAT and Conventional Ada Library Models:: +@ifset vms +* Placement of temporary files:: +@end ifset + +Foreign Language Representation + +* Latin-1:: +* Other 8-Bit Codes:: +* Wide Character Encodings:: + +Compiling Ada Programs With gcc + +* Compiling Programs:: +* Switches for gcc:: +* Search Paths and the Run-Time Library (RTL):: +* Order of Compilation Issues:: +* Examples:: + +Switches for gcc + +* Output and Error Message Control:: +* Warning Message Control:: +* Debugging and Assertion Control:: +* Validity Checking:: +* Style Checking:: +* Run-Time Checks:: +* Using gcc for Syntax Checking:: +* Using gcc for Semantic Checking:: +* Compiling Different Versions of Ada:: +* Character Set Control:: +* File Naming Control:: +* Subprogram Inlining Control:: +* Auxiliary Output Control:: +* Debugging Control:: +* Exception Handling Control:: +* Units to Sources Mapping Files:: +* Integrated Preprocessing:: +@ifset vms +* Return Codes:: +@end ifset + +Binding Ada Programs With gnatbind + +* Running gnatbind:: +* Switches for gnatbind:: +* Command-Line Access:: +* Search Paths for gnatbind:: +* Examples of gnatbind Usage:: + +Switches for gnatbind + +* Consistency-Checking Modes:: +* Binder Error Message Control:: +* Elaboration Control:: +* Output Control:: +* Binding with Non-Ada Main Programs:: +* Binding Programs with No Main Subprogram:: + +Linking Using gnatlink + +* Running gnatlink:: +* Switches for gnatlink:: + +The GNAT Make Program gnatmake + +* Running gnatmake:: +* Switches for gnatmake:: +* Mode Switches for gnatmake:: +* Notes on the Command Line:: +* How gnatmake Works:: +* Examples of gnatmake Usage:: + +Improving Performance +* Performance Considerations:: +* Text_IO Suggestions:: +* Reducing Size of Ada Executables with gnatelim:: +* Reducing Size of Executables with unused subprogram/data elimination:: + +Performance Considerations +* Controlling Run-Time Checks:: +* Use of Restrictions:: +* Optimization Levels:: +* Debugging Optimized Code:: +* Inlining of Subprograms:: +* Other Optimization Switches:: +* Optimization and Strict Aliasing:: +@ifset vms +* Coverage Analysis:: +@end ifset + +Reducing Size of Ada Executables with gnatelim +* About gnatelim:: +* Running gnatelim:: +* Processing Precompiled Libraries:: +* Correcting the List of Eliminate Pragmas:: +* Making Your Executables Smaller:: +* Summary of the gnatelim Usage Cycle:: + +Reducing Size of Executables with unused subprogram/data elimination +* About unused subprogram/data elimination:: +* Compilation options:: + +Renaming Files Using gnatchop + +* Handling Files with Multiple Units:: +* Operating gnatchop in Compilation Mode:: +* Command Line for gnatchop:: +* Switches for gnatchop:: +* Examples of gnatchop Usage:: + +Configuration Pragmas + +* Handling of Configuration Pragmas:: +* The Configuration Pragmas Files:: + +Handling Arbitrary File Naming Conventions Using gnatname + +* Arbitrary File Naming Conventions:: +* Running gnatname:: +* Switches for gnatname:: +* Examples of gnatname Usage:: + +The Cross-Referencing Tools gnatxref and gnatfind + +* Switches for gnatxref:: +* Switches for gnatfind:: +* Project Files for gnatxref and gnatfind:: +* Regular Expressions in gnatfind and gnatxref:: +* Examples of gnatxref Usage:: +* Examples of gnatfind Usage:: + +The GNAT Pretty-Printer gnatpp + +* Switches for gnatpp:: +* Formatting Rules:: + +The GNAT Metrics Tool gnatmetric + +* Switches for gnatmetric:: + +File Name Krunching Using gnatkr + +* About gnatkr:: +* Using gnatkr:: +* Krunching Method:: +* Examples of gnatkr Usage:: + +Preprocessing Using gnatprep +* Preprocessing Symbols:: +* Using gnatprep:: +* Switches for gnatprep:: +* Form of Definitions File:: +* Form of Input Text for gnatprep:: + +The GNAT Library Browser gnatls + +* Running gnatls:: +* Switches for gnatls:: +* Examples of gnatls Usage:: + +Cleaning Up Using gnatclean + +* Running gnatclean:: +* Switches for gnatclean:: +@c * Examples of gnatclean Usage:: + +@ifclear vms + +GNAT and Libraries + +* Introduction to Libraries in GNAT:: +* General Ada Libraries:: +* Stand-alone Ada Libraries:: +* Rebuilding the GNAT Run-Time Library:: + +Using the GNU make Utility + +* Using gnatmake in a Makefile:: +* Automatically Creating a List of Directories:: +* Generating the Command Line Switches:: +* Overcoming Command Line Length Limits:: +@end ifclear + +Memory Management Issues + +* Some Useful Memory Pools:: +* The GNAT Debug Pool Facility:: +@ifclear vms +* The gnatmem Tool:: +@end ifclear + +Stack Related Facilities + +* Stack Overflow Checking:: +* Static Stack Usage Analysis:: +* Dynamic Stack Usage Analysis:: + +Some Useful Memory Pools + +The GNAT Debug Pool Facility + +@ifclear vms +The gnatmem Tool + +* Running gnatmem:: +* Switches for gnatmem:: +* Example of gnatmem Usage:: +@end ifclear + +Verifying Properties Using gnatcheck + +Sample Bodies Using gnatstub + +* Running gnatstub:: +* Switches for gnatstub:: + +Other Utility Programs + +* Using Other Utility Programs with GNAT:: +* The External Symbol Naming Scheme of GNAT:: +* Converting Ada Files to html with gnathtml:: + +@ifclear vms +Code Coverage and Profiling + +* Code Coverage of Ada Programs using gcov:: +* Profiling an Ada Program using gprof:: +@end ifclear + +Running and Debugging Ada Programs + +* The GNAT Debugger GDB:: +* Running GDB:: +* Introduction to GDB Commands:: +* Using Ada Expressions:: +* Calling User-Defined Subprograms:: +* Using the Next Command in a Function:: +* Ada Exceptions:: +* Ada Tasks:: +* Debugging Generic Units:: +* Remote Debugging using gdbserver:: +* GNAT Abnormal Termination or Failure to Terminate:: +* Naming Conventions for GNAT Source Files:: +* Getting Internal Debugging Information:: +* Stack Traceback:: + +@ifset vms +* LSE:: +@end ifset + +@ifset vms +Compatibility with HP Ada + +* Ada Language Compatibility:: +* Differences in the Definition of Package System:: +* Language-Related Features:: +* The Package STANDARD:: +* The Package SYSTEM:: +* Tasking and Task-Related Features:: +* Pragmas and Pragma-Related Features:: +* Library of Predefined Units:: +* Bindings:: +* Main Program Definition:: +* Implementation-Defined Attributes:: +* Compiler and Run-Time Interfacing:: +* Program Compilation and Library Management:: +* Input-Output:: +* Implementation Limits:: +* Tools and Utilities:: + +Language-Related Features + +* Integer Types and Representations:: +* Floating-Point Types and Representations:: +* Pragmas Float_Representation and Long_Float:: +* Fixed-Point Types and Representations:: +* Record and Array Component Alignment:: +* Address Clauses:: +* Other Representation Clauses:: + +Tasking and Task-Related Features + +* Implementation of Tasks in HP Ada for OpenVMS Alpha Systems:: +* Assigning Task IDs:: +* Task IDs and Delays:: +* Task-Related Pragmas:: +* Scheduling and Task Priority:: +* The Task Stack:: +* External Interrupts:: + +Pragmas and Pragma-Related Features + +* Restrictions on the Pragma INLINE:: +* Restrictions on the Pragma INTERFACE:: +* Restrictions on the Pragma SYSTEM_NAME:: + +Library of Predefined Units + +* Changes to DECLIB:: + +Bindings + +* Shared Libraries and Options Files:: +* Interfaces to C:: +@end ifset + +Platform-Specific Information for the Run-Time Libraries + +* Summary of Run-Time Configurations:: +* Specifying a Run-Time Library:: +* Choosing the Scheduling Policy:: +* Solaris-Specific Considerations:: +* Linux-Specific Considerations:: +* AIX-Specific Considerations:: +* Irix-Specific Considerations:: +* RTX-Specific Considerations:: +* HP-UX-Specific Considerations:: + +Example of Binder Output File + +Elaboration Order Handling in GNAT + +* Elaboration Code:: +* Checking the Elaboration Order:: +* Controlling the Elaboration Order:: +* Controlling Elaboration in GNAT - Internal Calls:: +* Controlling Elaboration in GNAT - External Calls:: +* Default Behavior in GNAT - Ensuring Safety:: +* Treatment of Pragma Elaborate:: +* Elaboration Issues for Library Tasks:: +* Mixing Elaboration Models:: +* What to Do If the Default Elaboration Behavior Fails:: +* Elaboration for Access-to-Subprogram Values:: +* Summary of Procedures for Elaboration Control:: +* Other Elaboration Order Considerations:: + +Conditional Compilation +* Use of Boolean Constants:: +* Debugging - A Special Case:: +* Conditionalizing Declarations:: +* Use of Alternative Implementations:: +* Preprocessing:: + +Inline Assembler + +* Basic Assembler Syntax:: +* A Simple Example of Inline Assembler:: +* Output Variables in Inline Assembler:: +* Input Variables in Inline Assembler:: +* Inlining Inline Assembler Code:: +* Other Asm Functionality:: + +Compatibility and Porting Guide + +* Compatibility with Ada 83:: +* Compatibility between Ada 95 and Ada 2005:: +* Implementation-dependent characteristics:: +@ifclear vms +@c This brief section is only in the non-VMS version +@c The complete chapter on HP Ada issues is in the VMS version +* Compatibility with HP Ada 83:: +@end ifclear +* Compatibility with Other Ada Systems:: +* Representation Clauses:: +@ifset vms +* Transitioning to 64-Bit GNAT for OpenVMS:: +@end ifset + +@ifset unw +Microsoft Windows Topics + +* Using GNAT on Windows:: +* CONSOLE and WINDOWS subsystems:: +* Temporary Files:: +* Mixed-Language Programming on Windows:: +* Windows Calling Conventions:: +* Introduction to Dynamic Link Libraries (DLLs):: +* Using DLLs with GNAT:: +* Building DLLs with GNAT:: +* GNAT and Windows Resources:: +* Debugging a DLL:: +* Setting Stack Size from gnatlink:: +* Setting Heap Size from gnatlink:: +@end ifset + +* Index:: +@end menu +@end ifnottex + +@node About This Guide +@unnumbered About This Guide + +@noindent +@ifset vms +This guide describes the use of @value{EDITION}, +a compiler and software development toolset for the full Ada +programming language, implemented on OpenVMS for HP's Alpha and +Integrity server (I64) platforms. +@end ifset +@ifclear vms +This guide describes the use of @value{EDITION}, +a compiler and software development +toolset for the full Ada programming language. +@end ifclear +It documents the features of the compiler and tools, and explains +how to use them to build Ada applications. + +@value{EDITION} implements Ada 95 and Ada 2005, and it may also be invoked in +Ada 83 compatibility mode. +By default, @value{EDITION} assumes @value{DEFAULTLANGUAGEVERSION}, +but you can override with a compiler switch +(@pxref{Compiling Different Versions of Ada}) +to explicitly specify the language version. +Throughout this manual, references to ``Ada'' without a year suffix +apply to both the Ada 95 and Ada 2005 versions of the language. + + +@ifclear FSFEDITION +For ease of exposition, ``@value{EDITION}'' will be referred to simply as +``GNAT'' in the remainder of this document. +@end ifclear + + + + +@menu +* What This Guide Contains:: +* What You Should Know before Reading This Guide:: +* Related Information:: +* Conventions:: +@end menu + +@node What This Guide Contains +@unnumberedsec What This Guide Contains + +@noindent +This guide contains the following chapters: +@itemize @bullet + +@item +@ref{Getting Started with GNAT}, describes how to get started compiling +and running Ada programs with the GNAT Ada programming environment. +@item +@ref{The GNAT Compilation Model}, describes the compilation model used +by GNAT. + +@item +@ref{Compiling Using gcc}, describes how to compile +Ada programs with @command{gcc}, the Ada compiler. + +@item +@ref{Binding Using gnatbind}, describes how to +perform binding of Ada programs with @code{gnatbind}, the GNAT binding +utility. + +@item +@ref{Linking Using gnatlink}, +describes @command{gnatlink}, a +program that provides for linking using the GNAT run-time library to +construct a program. @command{gnatlink} can also incorporate foreign language +object units into the executable. + +@item +@ref{The GNAT Make Program gnatmake}, describes @command{gnatmake}, a +utility that automatically determines the set of sources +needed by an Ada compilation unit, and executes the necessary compilations +binding and link. + +@item +@ref{Improving Performance}, shows various techniques for making your +Ada program run faster or take less space. +It discusses the effect of the compiler's optimization switch and +also describes the @command{gnatelim} tool and unused subprogram/data +elimination. + +@item +@ref{Renaming Files Using gnatchop}, describes +@code{gnatchop}, a utility that allows you to preprocess a file that +contains Ada source code, and split it into one or more new files, one +for each compilation unit. + +@item +@ref{Configuration Pragmas}, describes the configuration pragmas +handled by GNAT. + +@item +@ref{Handling Arbitrary File Naming Conventions Using gnatname}, +shows how to override the default GNAT file naming conventions, +either for an individual unit or globally. + +@item +@ref{GNAT Project Manager}, describes how to use project files +to organize large projects. + +@item +@ref{The Cross-Referencing Tools gnatxref and gnatfind}, discusses +@code{gnatxref} and @code{gnatfind}, two tools that provide an easy +way to navigate through sources. + +@item +@ref{The GNAT Pretty-Printer gnatpp}, shows how to produce a reformatted +version of an Ada source file with control over casing, indentation, +comment placement, and other elements of program presentation style. + +@item +@ref{The GNAT Metric Tool gnatmetric}, shows how to compute various +metrics for an Ada source file, such as the number of types and subprograms, +and assorted complexity measures. + +@item +@ref{File Name Krunching Using gnatkr}, describes the @code{gnatkr} +file name krunching utility, used to handle shortened +file names on operating systems with a limit on the length of names. + +@item +@ref{Preprocessing Using gnatprep}, describes @code{gnatprep}, a +preprocessor utility that allows a single source file to be used to +generate multiple or parameterized source files by means of macro +substitution. + +@item +@ref{The GNAT Library Browser gnatls}, describes @code{gnatls}, a +utility that displays information about compiled units, including dependences +on the corresponding sources files, and consistency of compilations. + +@item +@ref{Cleaning Up Using gnatclean}, describes @code{gnatclean}, a utility +to delete files that are produced by the compiler, binder and linker. + +@ifclear vms +@item +@ref{GNAT and Libraries}, describes the process of creating and using +Libraries with GNAT. It also describes how to recompile the GNAT run-time +library. + +@item +@ref{Using the GNU make Utility}, describes some techniques for using +the GNAT toolset in Makefiles. +@end ifclear + +@item +@ref{Memory Management Issues}, describes some useful predefined storage pools +and in particular the GNAT Debug Pool facility, which helps detect incorrect +memory references. +@ifclear vms +It also describes @command{gnatmem}, a utility that monitors dynamic +allocation and deallocation and helps detect ``memory leaks''. +@end ifclear + +@item +@ref{Stack Related Facilities}, describes some useful tools associated with +stack checking and analysis. + +@item +@ref{Verifying Properties Using gnatcheck}, discusses @code{gnatcheck}, +a utility that checks Ada code against a set of rules. + +@item +@ref{Creating Sample Bodies Using gnatstub}, discusses @code{gnatstub}, +a utility that generates empty but compilable bodies for library units. + +@item +@ref{Generating Ada Bindings for C and C++ headers}, describes how to +generate automatically Ada bindings from C and C++ headers. + +@item +@ref{Other Utility Programs}, discusses several other GNAT utilities, +including @code{gnathtml}. + +@ifclear vms +@item +@ref{Code Coverage and Profiling}, describes how to perform a structural +coverage and profile the execution of Ada programs. +@end ifclear + +@item +@ref{Running and Debugging Ada Programs}, describes how to run and debug +Ada programs. + +@ifset vms +@item +@ref{Compatibility with HP Ada}, details the compatibility of GNAT with +HP Ada 83 @footnote{``HP Ada'' refers to the legacy product originally +developed by Digital Equipment Corporation and currently supported by HP.} +for OpenVMS Alpha. This product was formerly known as DEC Ada, +@cindex DEC Ada +and for +historical compatibility reasons, the relevant libraries still use the +DEC prefix. +@end ifset + +@item +@ref{Platform-Specific Information for the Run-Time Libraries}, +describes the various run-time +libraries supported by GNAT on various platforms and explains how to +choose a particular library. + +@item +@ref{Example of Binder Output File}, shows the source code for the binder +output file for a sample program. + +@item +@ref{Elaboration Order Handling in GNAT}, describes how GNAT helps +you deal with elaboration order issues. + +@item +@ref{Conditional Compilation}, describes how to model conditional compilation, +both with Ada in general and with GNAT facilities in particular. + +@item +@ref{Inline Assembler}, shows how to use the inline assembly facility +in an Ada program. + +@item +@ref{Compatibility and Porting Guide}, contains sections on compatibility +of GNAT with other Ada development environments (including Ada 83 systems), +to assist in porting code from those environments. + +@ifset unw +@item +@ref{Microsoft Windows Topics}, presents information relevant to the +Microsoft Windows platform. +@end ifset +@end itemize + +@c ************************************************* +@node What You Should Know before Reading This Guide +@c ************************************************* +@unnumberedsec What You Should Know before Reading This Guide + +@cindex Ada 95 Language Reference Manual +@cindex Ada 2005 Language Reference Manual +@noindent +This guide assumes a basic familiarity with the Ada 95 language, as +described in the International Standard ANSI/ISO/IEC-8652:1995, January +1995. +It does not require knowledge of the new features introduced by Ada 2005, +(officially known as ISO/IEC 8652:1995 with Technical Corrigendum 1 +and Amendment 1). +Both reference manuals are included in the GNAT documentation +package. + +@node Related Information +@unnumberedsec Related Information + +@noindent +For further information about related tools, refer to the following +documents: + +@itemize @bullet +@item +@xref{Top, GNAT Reference Manual, About This Guide, gnat_rm, GNAT +Reference Manual}, which contains all reference material for the GNAT +implementation of Ada. + +@ifset unw +@item +@cite{Using the GNAT Programming Studio}, which describes the GPS +Integrated Development Environment. + +@item +@cite{GNAT Programming Studio Tutorial}, which introduces the +main GPS features through examples. +@end ifset + +@item +@cite{Ada 95 Reference Manual}, which contains reference +material for the Ada 95 programming language. + +@item +@cite{Ada 2005 Reference Manual}, which contains reference +material for the Ada 2005 programming language. + +@item +@xref{Top,, Debugging with GDB, gdb, Debugging with GDB}, +@ifset vms +in the GNU:[DOCS] directory, +@end ifset +for all details on the use of the GNU source-level debugger. + +@item +@xref{Top,, The extensible self-documenting text editor, emacs, +GNU Emacs Manual}, +@ifset vms +located in the GNU:[DOCS] directory if the EMACS kit is installed, +@end ifset +for full information on the extensible editor and programming +environment Emacs. + +@end itemize + +@c ************** +@node Conventions +@unnumberedsec Conventions +@cindex Conventions +@cindex Typographical conventions + +@noindent +Following are examples of the typographical and graphic conventions used +in this guide: + +@itemize @bullet +@item +@code{Functions}, @command{utility program names}, @code{standard names}, +and @code{classes}. + +@item +@option{Option flags} + +@item +@file{File names}, @samp{button names}, and @samp{field names}. + +@item +@code{Variables}, @env{environment variables}, and @var{metasyntactic +variables}. + +@item +@emph{Emphasis}. + +@item +@r{[}optional information or parameters@r{]} + +@item +Examples are described by text +@smallexample +and then shown this way. +@end smallexample +@end itemize + +@noindent +Commands that are entered by the user are preceded in this manual by the +characters @w{``@code{$ }''} (dollar sign followed by space). If your system +uses this sequence as a prompt, then the commands will appear exactly as +you see them in the manual. If your system uses some other prompt, then +the command will appear with the @code{$} replaced by whatever prompt +character you are using. + +@ifset unw +Full file names are shown with the ``@code{/}'' character +as the directory separator; e.g., @file{parent-dir/subdir/myfile.adb}. +If you are using GNAT on a Windows platform, please note that +the ``@code{\}'' character should be used instead. +@end ifset + +@c **************************** +@node Getting Started with GNAT +@chapter Getting Started with GNAT + +@noindent +This chapter describes some simple ways of using GNAT to build +executable Ada programs. +@ifset unw +@ref{Running GNAT}, through @ref{Using the gnatmake Utility}, +show how to use the command line environment. +@ref{Introduction to GPS}, provides a brief +introduction to the GNAT Programming Studio, a visually-oriented +Integrated Development Environment for GNAT. +GPS offers a graphical ``look and feel'', support for development in +other programming languages, comprehensive browsing features, and +many other capabilities. +For information on GPS please refer to +@cite{Using the GNAT Programming Studio}. +@end ifset + +@menu +* Running GNAT:: +* Running a Simple Ada Program:: +* Running a Program with Multiple Units:: +* Using the gnatmake Utility:: +@ifset vms +* Editing with Emacs:: +@end ifset +@ifclear vms +* Introduction to GPS:: +@end ifclear +@end menu + +@node Running GNAT +@section Running GNAT + +@noindent +Three steps are needed to create an executable file from an Ada source +file: + +@enumerate +@item +The source file(s) must be compiled. +@item +The file(s) must be bound using the GNAT binder. +@item +All appropriate object files must be linked to produce an executable. +@end enumerate + +@noindent +All three steps are most commonly handled by using the @command{gnatmake} +utility program that, given the name of the main program, automatically +performs the necessary compilation, binding and linking steps. + +@node Running a Simple Ada Program +@section Running a Simple Ada Program + +@noindent +Any text editor may be used to prepare an Ada program. +(If @code{Emacs} is +used, the optional Ada mode may be helpful in laying out the program.) +The +program text is a normal text file. We will assume in our initial +example that you have used your editor to prepare the following +standard format text file: + +@smallexample @c ada +@cartouche +with Ada.Text_IO; use Ada.Text_IO; +procedure Hello is +begin + Put_Line ("Hello WORLD!"); +end Hello; +@end cartouche +@end smallexample + +@noindent +This file should be named @file{hello.adb}. +With the normal default file naming conventions, GNAT requires +that each file +contain a single compilation unit whose file name is the +unit name, +with periods replaced by hyphens; the +extension is @file{ads} for a +spec and @file{adb} for a body. +You can override this default file naming convention by use of the +special pragma @code{Source_File_Name} (@pxref{Using Other File Names}). +Alternatively, if you want to rename your files according to this default +convention, which is probably more convenient if you will be using GNAT +for all your compilations, then the @code{gnatchop} utility +can be used to generate correctly-named source files +(@pxref{Renaming Files Using gnatchop}). + +You can compile the program using the following command (@code{$} is used +as the command prompt in the examples in this document): + +@smallexample +$ gcc -c hello.adb +@end smallexample + +@noindent +@command{gcc} is the command used to run the compiler. This compiler is +capable of compiling programs in several languages, including Ada and +C. It assumes that you have given it an Ada program if the file extension is +either @file{.ads} or @file{.adb}, and it will then call +the GNAT compiler to compile the specified file. + +@ifclear vms +The @option{-c} switch is required. It tells @command{gcc} to only do a +compilation. (For C programs, @command{gcc} can also do linking, but this +capability is not used directly for Ada programs, so the @option{-c} +switch must always be present.) +@end ifclear + +This compile command generates a file +@file{hello.o}, which is the object +file corresponding to your Ada program. It also generates +an ``Ada Library Information'' file @file{hello.ali}, +which contains additional information used to check +that an Ada program is consistent. +To build an executable file, +use @code{gnatbind} to bind the program +and @command{gnatlink} to link it. The +argument to both @code{gnatbind} and @command{gnatlink} is the name of the +@file{ALI} file, but the default extension of @file{.ali} can +be omitted. This means that in the most common case, the argument +is simply the name of the main program: + +@smallexample +$ gnatbind hello +$ gnatlink hello +@end smallexample + +@noindent +A simpler method of carrying out these steps is to use +@command{gnatmake}, +a master program that invokes all the required +compilation, binding and linking tools in the correct order. In particular, +@command{gnatmake} automatically recompiles any sources that have been +modified since they were last compiled, or sources that depend +on such modified sources, so that ``version skew'' is avoided. +@cindex Version skew (avoided by @command{gnatmake}) + +@smallexample +$ gnatmake hello.adb +@end smallexample + +@noindent +The result is an executable program called @file{hello}, which can be +run by entering: + +@smallexample +$ ^hello^RUN HELLO^ +@end smallexample + +@noindent +assuming that the current directory is on the search path +for executable programs. + +@noindent +and, if all has gone well, you will see + +@smallexample +Hello WORLD! +@end smallexample + +@noindent +appear in response to this command. + +@c **************************************** +@node Running a Program with Multiple Units +@section Running a Program with Multiple Units + +@noindent +Consider a slightly more complicated example that has three files: a +main program, and the spec and body of a package: + +@smallexample @c ada +@cartouche +@group +package Greetings is + procedure Hello; + procedure Goodbye; +end Greetings; + +with Ada.Text_IO; use Ada.Text_IO; +package body Greetings is + procedure Hello is + begin + Put_Line ("Hello WORLD!"); + end Hello; + + procedure Goodbye is + begin + Put_Line ("Goodbye WORLD!"); + end Goodbye; +end Greetings; +@end group + +@group +with Greetings; +procedure Gmain is +begin + Greetings.Hello; + Greetings.Goodbye; +end Gmain; +@end group +@end cartouche +@end smallexample + +@noindent +Following the one-unit-per-file rule, place this program in the +following three separate files: + +@table @file +@item greetings.ads +spec of package @code{Greetings} + +@item greetings.adb +body of package @code{Greetings} + +@item gmain.adb +body of main program +@end table + +@noindent +To build an executable version of +this program, we could use four separate steps to compile, bind, and link +the program, as follows: + +@smallexample +$ gcc -c gmain.adb +$ gcc -c greetings.adb +$ gnatbind gmain +$ gnatlink gmain +@end smallexample + +@noindent +Note that there is no required order of compilation when using GNAT. +In particular it is perfectly fine to compile the main program first. +Also, it is not necessary to compile package specs in the case where +there is an accompanying body; you only need to compile the body. If you want +to submit these files to the compiler for semantic checking and not code +generation, then use the +@option{-gnatc} switch: + +@smallexample +$ gcc -c greetings.ads -gnatc +@end smallexample + +@noindent +Although the compilation can be done in separate steps as in the +above example, in practice it is almost always more convenient +to use the @command{gnatmake} tool. All you need to know in this case +is the name of the main program's source file. The effect of the above four +commands can be achieved with a single one: + +@smallexample +$ gnatmake gmain.adb +@end smallexample + +@noindent +In the next section we discuss the advantages of using @command{gnatmake} in +more detail. + +@c ***************************** +@node Using the gnatmake Utility +@section Using the @command{gnatmake} Utility + +@noindent +If you work on a program by compiling single components at a time using +@command{gcc}, you typically keep track of the units you modify. In order to +build a consistent system, you compile not only these units, but also any +units that depend on the units you have modified. +For example, in the preceding case, +if you edit @file{gmain.adb}, you only need to recompile that file. But if +you edit @file{greetings.ads}, you must recompile both +@file{greetings.adb} and @file{gmain.adb}, because both files contain +units that depend on @file{greetings.ads}. + +@code{gnatbind} will warn you if you forget one of these compilation +steps, so that it is impossible to generate an inconsistent program as a +result of forgetting to do a compilation. Nevertheless it is tedious and +error-prone to keep track of dependencies among units. +One approach to handle the dependency-bookkeeping is to use a +makefile. However, makefiles present maintenance problems of their own: +if the dependencies change as you change the program, you must make +sure that the makefile is kept up-to-date manually, which is also an +error-prone process. + +The @command{gnatmake} utility takes care of these details automatically. +Invoke it using either one of the following forms: + +@smallexample +$ gnatmake gmain.adb +$ gnatmake ^gmain^GMAIN^ +@end smallexample + +@noindent +The argument is the name of the file containing the main program; +you may omit the extension. @command{gnatmake} +examines the environment, automatically recompiles any files that need +recompiling, and binds and links the resulting set of object files, +generating the executable file, @file{^gmain^GMAIN.EXE^}. +In a large program, it +can be extremely helpful to use @command{gnatmake}, because working out by hand +what needs to be recompiled can be difficult. + +Note that @command{gnatmake} +takes into account all the Ada rules that +establish dependencies among units. These include dependencies that result +from inlining subprogram bodies, and from +generic instantiation. Unlike some other +Ada make tools, @command{gnatmake} does not rely on the dependencies that were +found by the compiler on a previous compilation, which may possibly +be wrong when sources change. @command{gnatmake} determines the exact set of +dependencies from scratch each time it is run. + +@ifset vms +@node Editing with Emacs +@section Editing with Emacs +@cindex Emacs + +@noindent +Emacs is an extensible self-documenting text editor that is available in a +separate VMSINSTAL kit. + +Invoke Emacs by typing @kbd{Emacs} at the command prompt. To get started, +click on the Emacs Help menu and run the Emacs Tutorial. +In a character cell terminal, Emacs help is invoked with @kbd{Ctrl-h} (also +written as @kbd{C-h}), and the tutorial by @kbd{C-h t}. + +Documentation on Emacs and other tools is available in Emacs under the +pull-down menu button: @code{Help - Info}. After selecting @code{Info}, +use the middle mouse button to select a topic (e.g.@: Emacs). + +In a character cell terminal, do @kbd{C-h i} to invoke info, and then @kbd{m} +(stands for menu) followed by the menu item desired, as in @kbd{m Emacs}, to +get to the Emacs manual. +Help on Emacs is also available by typing @kbd{HELP EMACS} at the DCL command +prompt. + +The tutorial is highly recommended in order to learn the intricacies of Emacs, +which is sufficiently extensible to provide for a complete programming +environment and shell for the sophisticated user. +@end ifset + +@ifclear vms +@node Introduction to GPS +@section Introduction to GPS +@cindex GPS (GNAT Programming Studio) +@cindex GNAT Programming Studio (GPS) +@noindent +Although the command line interface (@command{gnatmake}, etc.) alone +is sufficient, a graphical Interactive Development +Environment can make it easier for you to compose, navigate, and debug +programs. This section describes the main features of GPS +(``GNAT Programming Studio''), the GNAT graphical IDE. +You will see how to use GPS to build and debug an executable, and +you will also learn some of the basics of the GNAT ``project'' facility. + +GPS enables you to do much more than is presented here; +e.g., you can produce a call graph, interface to a third-party +Version Control System, and inspect the generated assembly language +for a program. +Indeed, GPS also supports languages other than Ada. +Such additional information, and an explanation of all of the GPS menu +items. may be found in the on-line help, which includes +a user's guide and a tutorial (these are also accessible from the GNAT +startup menu). + +@menu +* Building a New Program with GPS:: +* Simple Debugging with GPS:: +@end menu + +@node Building a New Program with GPS +@subsection Building a New Program with GPS +@noindent +GPS invokes the GNAT compilation tools using information +contained in a @emph{project} (also known as a @emph{project file}): +a collection of properties such +as source directories, identities of main subprograms, tool switches, etc., +and their associated values. +See @ref{GNAT Project Manager} for details. +In order to run GPS, you will need to either create a new project +or else open an existing one. + +This section will explain how you can use GPS to create a project, +to associate Ada source files with a project, and to build and run +programs. + +@enumerate +@item @emph{Creating a project} + +Invoke GPS, either from the command line or the platform's IDE. +After it starts, GPS will display a ``Welcome'' screen with three +radio buttons: + +@itemize @bullet +@item +@code{Start with default project in directory} + +@item +@code{Create new project with wizard} + +@item +@code{Open existing project} +@end itemize + +@noindent +Select @code{Create new project with wizard} and press @code{OK}. +A new window will appear. In the text box labeled with +@code{Enter the name of the project to create}, type @file{sample} +as the project name. +In the next box, browse to choose the directory in which you +would like to create the project file. +After selecting an appropriate directory, press @code{Forward}. + +A window will appear with the title +@code{Version Control System Configuration}. +Simply press @code{Forward}. + +A window will appear with the title +@code{Please select the source directories for this project}. +The directory that you specified for the project file will be selected +by default as the one to use for sources; simply press @code{Forward}. + +A window will appear with the title +@code{Please select the build directory for this project}. +The directory that you specified for the project file will be selected +by default for object files and executables; +simply press @code{Forward}. + +A window will appear with the title +@code{Please select the main units for this project}. +You will supply this information later, after creating the source file. +Simply press @code{Forward} for now. + +A window will appear with the title +@code{Please select the switches to build the project}. +Press @code{Apply}. This will create a project file named +@file{sample.prj} in the directory that you had specified. + +@item @emph{Creating and saving the source file} + +After you create the new project, a GPS window will appear, which is +partitioned into two main sections: + +@itemize @bullet +@item +A @emph{Workspace area}, initially greyed out, which you will use for +creating and editing source files + +@item +Directly below, a @emph{Messages area}, which initially displays a +``Welcome'' message. +(If the Messages area is not visible, drag its border upward to expand it.) +@end itemize + +@noindent +Select @code{File} on the menu bar, and then the @code{New} command. +The Workspace area will become white, and you can now +enter the source program explicitly. +Type the following text + +@smallexample @c ada +@group +with Ada.Text_IO; use Ada.Text_IO; +procedure Hello is +begin + Put_Line("Hello from GPS!"); +end Hello; +@end group +@end smallexample + +@noindent +Select @code{File}, then @code{Save As}, and enter the source file name +@file{hello.adb}. +The file will be saved in the same directory you specified as the +location of the default project file. + +@item @emph{Updating the project file} + +You need to add the new source file to the project. +To do this, select +the @code{Project} menu and then @code{Edit project properties}. +Click the @code{Main files} tab on the left, and then the +@code{Add} button. +Choose @file{hello.adb} from the list, and press @code{Open}. +The project settings window will reflect this action. +Click @code{OK}. + +@item @emph{Building and running the program} + +In the main GPS window, now choose the @code{Build} menu, then @code{Make}, +and select @file{hello.adb}. +The Messages window will display the resulting invocations of @command{gcc}, +@command{gnatbind}, and @command{gnatlink} +(reflecting the default switch settings from the +project file that you created) and then a ``successful compilation/build'' +message. + +To run the program, choose the @code{Build} menu, then @code{Run}, and +select @command{hello}. +An @emph{Arguments Selection} window will appear. +There are no command line arguments, so just click @code{OK}. + +The Messages window will now display the program's output (the string +@code{Hello from GPS}), and at the bottom of the GPS window a status +update is displayed (@code{Run: hello}). +Close the GPS window (or select @code{File}, then @code{Exit}) to +terminate this GPS session. +@end enumerate + +@node Simple Debugging with GPS +@subsection Simple Debugging with GPS +@noindent +This section illustrates basic debugging techniques (setting breakpoints, +examining/modifying variables, single stepping). + +@enumerate +@item @emph{Opening a project} + +Start GPS and select @code{Open existing project}; browse to +specify the project file @file{sample.prj} that you had created in the +earlier example. + +@item @emph{Creating a source file} + +Select @code{File}, then @code{New}, and type in the following program: + +@smallexample @c ada +@group +with Ada.Text_IO; use Ada.Text_IO; +procedure Example is + Line : String (1..80); + N : Natural; +begin + Put_Line("Type a line of text at each prompt; an empty line to exit"); + loop + Put(": "); + Get_Line (Line, N); + Put_Line (Line (1..N) ); + exit when N=0; + end loop; +end Example; +@end group +@end smallexample + +@noindent +Select @code{File}, then @code{Save as}, and enter the file name +@file{example.adb}. + +@item @emph{Updating the project file} + +Add @code{Example} as a new main unit for the project: +@enumerate a +@item +Select @code{Project}, then @code{Edit Project Properties}. + +@item +Select the @code{Main files} tab, click @code{Add}, then +select the file @file{example.adb} from the list, and +click @code{Open}. +You will see the file name appear in the list of main units + +@item +Click @code{OK} +@end enumerate + +@item @emph{Building/running the executable} + +To build the executable +select @code{Build}, then @code{Make}, and then choose @file{example.adb}. + +Run the program to see its effect (in the Messages area). +Each line that you enter is displayed; an empty line will +cause the loop to exit and the program to terminate. + +@item @emph{Debugging the program} + +Note that the @option{-g} switches to @command{gcc} and @command{gnatlink}, +which are required for debugging, are on by default when you create +a new project. +Thus unless you intentionally remove these settings, you will be able +to debug any program that you develop using GPS. + +@enumerate a +@item @emph{Initializing} + +Select @code{Debug}, then @code{Initialize}, then @file{example} + +@item @emph{Setting a breakpoint} + +After performing the initialization step, you will observe a small +icon to the right of each line number. +This serves as a toggle for breakpoints; clicking the icon will +set a breakpoint at the corresponding line (the icon will change to +a red circle with an ``x''), and clicking it again +will remove the breakpoint / reset the icon. + +For purposes of this example, set a breakpoint at line 10 (the +statement @code{Put_Line@ (Line@ (1..N));} + +@item @emph{Starting program execution} + +Select @code{Debug}, then @code{Run}. When the +@code{Program Arguments} window appears, click @code{OK}. +A console window will appear; enter some line of text, +e.g.@: @code{abcde}, at the prompt. +The program will pause execution when it gets to the +breakpoint, and the corresponding line is highlighted. + +@item @emph{Examining a variable} + +Move the mouse over one of the occurrences of the variable @code{N}. +You will see the value (5) displayed, in ``tool tip'' fashion. +Right click on @code{N}, select @code{Debug}, then select @code{Display N}. +You will see information about @code{N} appear in the @code{Debugger Data} +pane, showing the value as 5. + +@item @emph{Assigning a new value to a variable} + +Right click on the @code{N} in the @code{Debugger Data} pane, and +select @code{Set value of N}. +When the input window appears, enter the value @code{4} and click +@code{OK}. +This value does not automatically appear in the @code{Debugger Data} +pane; to see it, right click again on the @code{N} in the +@code{Debugger Data} pane and select @code{Update value}. +The new value, 4, will appear in red. + +@item @emph{Single stepping} + +Select @code{Debug}, then @code{Next}. +This will cause the next statement to be executed, in this case the +call of @code{Put_Line} with the string slice. +Notice in the console window that the displayed string is simply +@code{abcd} and not @code{abcde} which you had entered. +This is because the upper bound of the slice is now 4 rather than 5. + +@item @emph{Removing a breakpoint} + +Toggle the breakpoint icon at line 10. + +@item @emph{Resuming execution from a breakpoint} + +Select @code{Debug}, then @code{Continue}. +The program will reach the next iteration of the loop, and +wait for input after displaying the prompt. +This time, just hit the @kbd{Enter} key. +The value of @code{N} will be 0, and the program will terminate. +The console window will disappear. +@end enumerate +@end enumerate +@end ifclear + +@node The GNAT Compilation Model +@chapter The GNAT Compilation Model +@cindex GNAT compilation model +@cindex Compilation model + +@menu +* Source Representation:: +* Foreign Language Representation:: +* File Naming Rules:: +* Using Other File Names:: +* Alternative File Naming Schemes:: +* Generating Object Files:: +* Source Dependencies:: +* The Ada Library Information Files:: +* Binding an Ada Program:: +* Mixed Language Programming:: +@ifclear vms +* Building Mixed Ada & C++ Programs:: +* Comparison between GNAT and C/C++ Compilation Models:: +@end ifclear +* Comparison between GNAT and Conventional Ada Library Models:: +@ifset vms +* Placement of temporary files:: +@end ifset +@end menu + +@noindent +This chapter describes the compilation model used by GNAT. Although +similar to that used by other languages, such as C and C++, this model +is substantially different from the traditional Ada compilation models, +which are based on a library. The model is initially described without +reference to the library-based model. If you have not previously used an +Ada compiler, you need only read the first part of this chapter. The +last section describes and discusses the differences between the GNAT +model and the traditional Ada compiler models. If you have used other +Ada compilers, this section will help you to understand those +differences, and the advantages of the GNAT model. + +@node Source Representation +@section Source Representation +@cindex Latin-1 + +@noindent +Ada source programs are represented in standard text files, using +Latin-1 coding. Latin-1 is an 8-bit code that includes the familiar +7-bit ASCII set, plus additional characters used for +representing foreign languages (@pxref{Foreign Language Representation} +for support of non-USA character sets). The format effector characters +are represented using their standard ASCII encodings, as follows: + +@table @code +@item VT +@findex VT +Vertical tab, @code{16#0B#} + +@item HT +@findex HT +Horizontal tab, @code{16#09#} + +@item CR +@findex CR +Carriage return, @code{16#0D#} + +@item LF +@findex LF +Line feed, @code{16#0A#} + +@item FF +@findex FF +Form feed, @code{16#0C#} +@end table + +@noindent +Source files are in standard text file format. In addition, GNAT will +recognize a wide variety of stream formats, in which the end of +physical lines is marked by any of the following sequences: +@code{LF}, @code{CR}, @code{CR-LF}, or @code{LF-CR}. This is useful +in accommodating files that are imported from other operating systems. + +@cindex End of source file +@cindex Source file, end +@findex SUB +The end of a source file is normally represented by the physical end of +file. However, the control character @code{16#1A#} (@code{SUB}) is also +recognized as signalling the end of the source file. Again, this is +provided for compatibility with other operating systems where this +code is used to represent the end of file. + +Each file contains a single Ada compilation unit, including any pragmas +associated with the unit. For example, this means you must place a +package declaration (a package @dfn{spec}) and the corresponding body in +separate files. An Ada @dfn{compilation} (which is a sequence of +compilation units) is represented using a sequence of files. Similarly, +you will place each subunit or child unit in a separate file. + +@node Foreign Language Representation +@section Foreign Language Representation + +@noindent +GNAT supports the standard character sets defined in Ada as well as +several other non-standard character sets for use in localized versions +of the compiler (@pxref{Character Set Control}). +@menu +* Latin-1:: +* Other 8-Bit Codes:: +* Wide Character Encodings:: +@end menu + +@node Latin-1 +@subsection Latin-1 +@cindex Latin-1 + +@noindent +The basic character set is Latin-1. This character set is defined by ISO +standard 8859, part 1. The lower half (character codes @code{16#00#} +@dots{} @code{16#7F#)} is identical to standard ASCII coding, but the upper +half is used to represent additional characters. These include extended letters +used by European languages, such as French accents, the vowels with umlauts +used in German, and the extra letter A-ring used in Swedish. + +@findex Ada.Characters.Latin_1 +For a complete list of Latin-1 codes and their encodings, see the source +file of library unit @code{Ada.Characters.Latin_1} in file +@file{a-chlat1.ads}. +You may use any of these extended characters freely in character or +string literals. In addition, the extended characters that represent +letters can be used in identifiers. + +@node Other 8-Bit Codes +@subsection Other 8-Bit Codes + +@noindent +GNAT also supports several other 8-bit coding schemes: + +@table @asis +@item ISO 8859-2 (Latin-2) +@cindex Latin-2 +@cindex ISO 8859-2 +Latin-2 letters allowed in identifiers, with uppercase and lowercase +equivalence. + +@item ISO 8859-3 (Latin-3) +@cindex Latin-3 +@cindex ISO 8859-3 +Latin-3 letters allowed in identifiers, with uppercase and lowercase +equivalence. + +@item ISO 8859-4 (Latin-4) +@cindex Latin-4 +@cindex ISO 8859-4 +Latin-4 letters allowed in identifiers, with uppercase and lowercase +equivalence. + +@item ISO 8859-5 (Cyrillic) +@cindex ISO 8859-5 +@cindex Cyrillic +ISO 8859-5 letters (Cyrillic) allowed in identifiers, with uppercase and +lowercase equivalence. + +@item ISO 8859-15 (Latin-9) +@cindex ISO 8859-15 +@cindex Latin-9 +ISO 8859-15 (Latin-9) letters allowed in identifiers, with uppercase and +lowercase equivalence + +@item IBM PC (code page 437) +@cindex code page 437 +This code page is the normal default for PCs in the U.S. It corresponds +to the original IBM PC character set. This set has some, but not all, of +the extended Latin-1 letters, but these letters do not have the same +encoding as Latin-1. In this mode, these letters are allowed in +identifiers with uppercase and lowercase equivalence. + +@item IBM PC (code page 850) +@cindex code page 850 +This code page is a modification of 437 extended to include all the +Latin-1 letters, but still not with the usual Latin-1 encoding. In this +mode, all these letters are allowed in identifiers with uppercase and +lowercase equivalence. + +@item Full Upper 8-bit +Any character in the range 80-FF allowed in identifiers, and all are +considered distinct. In other words, there are no uppercase and lowercase +equivalences in this range. This is useful in conjunction with +certain encoding schemes used for some foreign character sets (e.g., +the typical method of representing Chinese characters on the PC). + +@item No Upper-Half +No upper-half characters in the range 80-FF are allowed in identifiers. +This gives Ada 83 compatibility for identifier names. +@end table + +@noindent +For precise data on the encodings permitted, and the uppercase and lowercase +equivalences that are recognized, see the file @file{csets.adb} in +the GNAT compiler sources. You will need to obtain a full source release +of GNAT to obtain this file. + +@node Wide Character Encodings +@subsection Wide Character Encodings + +@noindent +GNAT allows wide character codes to appear in character and string +literals, and also optionally in identifiers, by means of the following +possible encoding schemes: + +@table @asis + +@item Hex Coding +In this encoding, a wide character is represented by the following five +character sequence: + +@smallexample +ESC a b c d +@end smallexample + +@noindent +Where @code{a}, @code{b}, @code{c}, @code{d} are the four hexadecimal +characters (using uppercase letters) of the wide character code. For +example, ESC A345 is used to represent the wide character with code +@code{16#A345#}. +This scheme is compatible with use of the full Wide_Character set. + +@item Upper-Half Coding +@cindex Upper-Half Coding +The wide character with encoding @code{16#abcd#} where the upper bit is on +(in other words, ``a'' is in the range 8-F) is represented as two bytes, +@code{16#ab#} and @code{16#cd#}. The second byte cannot 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. + +@item Shift JIS Coding +@cindex Shift JIS Coding +A wide character is represented by a two-character sequence, +@code{16#ab#} and +@code{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. Only characters defined in the JIS code set table can be +used with this encoding method. + +@item EUC Coding +@cindex EUC Coding +A wide character is represented by a two-character sequence +@code{16#ab#} and +@code{16#cd#}, with both characters being in the upper half. The internal +character code is the corresponding JIS character according to the EUC +encoding algorithm. Only characters defined in the JIS code set table +can be used with this encoding method. + +@item UTF-8 Coding +A wide character is represented using +UCS Transformation Format 8 (UTF-8) as defined in Annex R of ISO +10646-1/Am.2. Depending on the character value, the representation +is a one, two, or three byte sequence: +@smallexample +@iftex +@leftskip=.7cm +@end iftex +16#0000#-16#007f#: 2#0@var{xxxxxxx}# +16#0080#-16#07ff#: 2#110@var{xxxxx}# 2#10@var{xxxxxx}# +16#0800#-16#ffff#: 2#1110@var{xxxx}# 2#10@var{xxxxxx}# 2#10@var{xxxxxx}# + +@end smallexample + +@noindent +where the @var{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 +(The full UTF-8 scheme allows for encoding 31-bit characters as +6-byte sequences, but in this implementation, all UTF-8 sequences +of four or more bytes length will be treated as illegal). +@item Brackets Coding +In this encoding, a wide character is represented by the following eight +character sequence: + +@smallexample +[ " a b c d " ] +@end smallexample + +@noindent +Where @code{a}, @code{b}, @code{c}, @code{d} are the four hexadecimal +characters (using uppercase letters) of the wide character code. For +example, [``A345''] is used to represent the wide character with code +@code{16#A345#}. It is also possible (though not required) to use the +Brackets coding for upper half characters. For example, the code +@code{16#A3#} can be represented as @code{[``A3'']}. + +This scheme is compatible with use of the full Wide_Character set, +and is also the method used for wide character encoding in the standard +ACVC (Ada Compiler Validation Capability) test suite distributions. + +@end table + +@noindent +Note: Some of these coding schemes do not permit the full use of the +Ada character set. For example, neither Shift JIS, nor EUC allow the +use of the upper half of the Latin-1 set. + +@node File Naming Rules +@section File Naming Rules + +@noindent +The default file name is determined by the name of the unit that the +file contains. The name is formed by taking the full expanded name of +the unit and replacing the separating dots with hyphens and using +^lowercase^uppercase^ for all letters. + +An exception arises if the file name generated by the above rules starts +with one of the characters +@ifset vms +@samp{A}, @samp{G}, @samp{I}, or @samp{S}, +@end ifset +@ifclear vms +@samp{a}, @samp{g}, @samp{i}, or @samp{s}, +@end ifclear +and the second character is a +minus. In this case, the character ^tilde^dollar sign^ is used in place +of the minus. The reason for this special rule is to avoid clashes with +the standard names for child units of the packages System, Ada, +Interfaces, and GNAT, which use the prefixes +@ifset vms +@samp{S-}, @samp{A-}, @samp{I-}, and @samp{G-}, +@end ifset +@ifclear vms +@samp{s-}, @samp{a-}, @samp{i-}, and @samp{g-}, +@end ifclear +respectively. + +The file extension is @file{.ads} for a spec and +@file{.adb} for a body. The following list shows some +examples of these rules. + +@table @file +@item main.ads +Main (spec) +@item main.adb +Main (body) +@item arith_functions.ads +Arith_Functions (package spec) +@item arith_functions.adb +Arith_Functions (package body) +@item func-spec.ads +Func.Spec (child package spec) +@item func-spec.adb +Func.Spec (child package body) +@item main-sub.adb +Sub (subunit of Main) +@item ^a~bad.adb^A$BAD.ADB^ +A.Bad (child package body) +@end table + +@noindent +Following these rules can result in excessively long +file names if corresponding +unit names are long (for example, if child units or subunits are +heavily nested). An option is available to shorten such long file names +(called file name ``krunching''). This may be particularly useful when +programs being developed with GNAT are to be used on operating systems +with limited file name lengths. @xref{Using gnatkr}. + +Of course, no file shortening algorithm can guarantee uniqueness over +all possible unit names; if file name krunching is used, it is your +responsibility to ensure no name clashes occur. Alternatively you +can specify the exact file names that you want used, as described +in the next section. Finally, if your Ada programs are migrating from a +compiler with a different naming convention, you can use the gnatchop +utility to produce source files that follow the GNAT naming conventions. +(For details @pxref{Renaming Files Using gnatchop}.) + +Note: in the case of @code{Windows NT/XP} or @code{OpenVMS} operating +systems, case is not significant. So for example on @code{Windows XP} +if the canonical name is @code{main-sub.adb}, you can use the file name +@code{Main-Sub.adb} instead. However, case is significant for other +operating systems, so for example, if you want to use other than +canonically cased file names on a Unix system, you need to follow +the procedures described in the next section. + +@node Using Other File Names +@section Using Other File Names +@cindex File names + +@noindent +In the previous section, we have described the default rules used by +GNAT to determine the file name in which a given unit resides. It is +often convenient to follow these default rules, and if you follow them, +the compiler knows without being explicitly told where to find all +the files it needs. + +However, in some cases, particularly when a program is imported from +another Ada compiler environment, it may be more convenient for the +programmer to specify which file names contain which units. GNAT allows +arbitrary file names to be used by means of the Source_File_Name pragma. +The form of this pragma is as shown in the following examples: +@cindex Source_File_Name pragma + +@smallexample @c ada +@cartouche +pragma Source_File_Name (My_Utilities.Stacks, + Spec_File_Name => "myutilst_a.ada"); +pragma Source_File_name (My_Utilities.Stacks, + Body_File_Name => "myutilst.ada"); +@end cartouche +@end smallexample + +@noindent +As shown in this example, the first argument for the pragma is the unit +name (in this example a child unit). The second argument has the form +of a named association. The identifier +indicates whether the file name is for a spec or a body; +the file name itself is given by a string literal. + +The source file name pragma is a configuration pragma, which means that +normally it will be placed in the @file{gnat.adc} +file used to hold configuration +pragmas that apply to a complete compilation environment. +For more details on how the @file{gnat.adc} file is created and used +see @ref{Handling of Configuration Pragmas}. +@cindex @file{gnat.adc} + +@ifclear vms +GNAT allows completely arbitrary file names to be specified using the +source file name pragma. However, if the file name specified has an +extension other than @file{.ads} or @file{.adb} it is necessary to use +a special syntax when compiling the file. The name in this case must be +preceded by the special sequence @option{-x} followed by a space and the name +of the language, here @code{ada}, as in: + +@smallexample +$ gcc -c -x ada peculiar_file_name.sim +@end smallexample +@end ifclear + +@noindent +@command{gnatmake} handles non-standard file names in the usual manner (the +non-standard file name for the main program is simply used as the +argument to gnatmake). Note that if the extension is also non-standard, +then it must be included in the @command{gnatmake} command, it may not +be omitted. + +@node Alternative File Naming Schemes +@section Alternative File Naming Schemes +@cindex File naming schemes, alternative +@cindex File names + +In the previous section, we described the use of the @code{Source_File_Name} +pragma to allow arbitrary names to be assigned to individual source files. +However, this approach requires one pragma for each file, and especially in +large systems can result in very long @file{gnat.adc} files, and also create +a maintenance problem. + +GNAT also provides a facility for specifying systematic file naming schemes +other than the standard default naming scheme previously described. An +alternative scheme for naming is specified by the use of +@code{Source_File_Name} pragmas having the following format: +@cindex Source_File_Name pragma + +@smallexample @c ada +pragma Source_File_Name ( + Spec_File_Name => FILE_NAME_PATTERN + @r{[},Casing => CASING_SPEC@r{]} + @r{[},Dot_Replacement => STRING_LITERAL@r{]}); + +pragma Source_File_Name ( + Body_File_Name => FILE_NAME_PATTERN + @r{[},Casing => CASING_SPEC@r{]} + @r{[},Dot_Replacement => STRING_LITERAL@r{]}); + +pragma Source_File_Name ( + Subunit_File_Name => FILE_NAME_PATTERN + @r{[},Casing => CASING_SPEC@r{]} + @r{[},Dot_Replacement => STRING_LITERAL@r{]}); + +FILE_NAME_PATTERN ::= STRING_LITERAL +CASING_SPEC ::= Lowercase | Uppercase | Mixedcase +@end smallexample + +@noindent +The @code{FILE_NAME_PATTERN} string shows how the file name is constructed. +It contains a single asterisk character, and the unit name is substituted +systematically for this asterisk. The optional parameter +@code{Casing} indicates +whether the unit name is to be all upper-case letters, all lower-case letters, +or mixed-case. If no +@code{Casing} parameter is used, then the default is all +^lower-case^upper-case^. + +The optional @code{Dot_Replacement} string is used to replace any periods +that occur in subunit or child unit names. If no @code{Dot_Replacement} +argument is used then separating dots appear unchanged in the resulting +file name. +Although the above syntax indicates that the +@code{Casing} argument must appear +before the @code{Dot_Replacement} argument, but it +is also permissible to write these arguments in the opposite order. + +As indicated, it is possible to specify different naming schemes for +bodies, specs, and subunits. Quite often the rule for subunits is the +same as the rule for bodies, in which case, there is no need to give +a separate @code{Subunit_File_Name} rule, and in this case the +@code{Body_File_name} rule is used for subunits as well. + +The separate rule for subunits can also be used to implement the rather +unusual case of a compilation environment (e.g.@: a single directory) which +contains a subunit and a child unit with the same unit name. Although +both units cannot appear in the same partition, the Ada Reference Manual +allows (but does not require) the possibility of the two units coexisting +in the same environment. + +The file name translation works in the following steps: + +@itemize @bullet + +@item +If there is a specific @code{Source_File_Name} pragma for the given unit, +then this is always used, and any general pattern rules are ignored. + +@item +If there is a pattern type @code{Source_File_Name} pragma that applies to +the unit, then the resulting file name will be used if the file exists. If +more than one pattern matches, the latest one will be tried first, and the +first attempt resulting in a reference to a file that exists will be used. + +@item +If no pattern type @code{Source_File_Name} pragma that applies to the unit +for which the corresponding file exists, then the standard GNAT default +naming rules are used. + +@end itemize + +@noindent +As an example of the use of this mechanism, consider a commonly used scheme +in which file names are all lower case, with separating periods copied +unchanged to the resulting file name, and specs end with @file{.1.ada}, and +bodies end with @file{.2.ada}. GNAT will follow this scheme if the following +two pragmas appear: + +@smallexample @c ada +pragma Source_File_Name + (Spec_File_Name => "*.1.ada"); +pragma Source_File_Name + (Body_File_Name => "*.2.ada"); +@end smallexample + +@noindent +The default GNAT scheme is actually implemented by providing the following +default pragmas internally: + +@smallexample @c ada +pragma Source_File_Name + (Spec_File_Name => "*.ads", Dot_Replacement => "-"); +pragma Source_File_Name + (Body_File_Name => "*.adb", Dot_Replacement => "-"); +@end smallexample + +@noindent +Our final example implements a scheme typically used with one of the +Ada 83 compilers, where the separator character for subunits was ``__'' +(two underscores), specs were identified by adding @file{_.ADA}, bodies +by adding @file{.ADA}, and subunits by +adding @file{.SEP}. All file names were +upper case. Child units were not present of course since this was an +Ada 83 compiler, but it seems reasonable to extend this scheme to use +the same double underscore separator for child units. + +@smallexample @c ada +pragma Source_File_Name + (Spec_File_Name => "*_.ADA", + Dot_Replacement => "__", + Casing = Uppercase); +pragma Source_File_Name + (Body_File_Name => "*.ADA", + Dot_Replacement => "__", + Casing = Uppercase); +pragma Source_File_Name + (Subunit_File_Name => "*.SEP", + Dot_Replacement => "__", + Casing = Uppercase); +@end smallexample + +@node Generating Object Files +@section Generating Object Files + +@noindent +An Ada program consists of a set of source files, and the first step in +compiling the program is to generate the corresponding object files. +These are generated by compiling a subset of these source files. +The files you need to compile are the following: + +@itemize @bullet +@item +If a package spec has no body, compile the package spec to produce the +object file for the package. + +@item +If a package has both a spec and a body, compile the body to produce the +object file for the package. The source file for the package spec need +not be compiled in this case because there is only one object file, which +contains the code for both the spec and body of the package. + +@item +For a subprogram, compile the subprogram body to produce the object file +for the subprogram. The spec, if one is present, is as usual in a +separate file, and need not be compiled. + +@item +@cindex Subunits +In the case of subunits, only compile the parent unit. A single object +file is generated for the entire subunit tree, which includes all the +subunits. + +@item +Compile child units independently of their parent units +(though, of course, the spec of all the ancestor unit must be present in order +to compile a child unit). + +@item +@cindex Generics +Compile generic units in the same manner as any other units. The object +files in this case are small dummy files that contain at most the +flag used for elaboration checking. This is because GNAT always handles generic +instantiation by means of macro expansion. However, it is still necessary to +compile generic units, for dependency checking and elaboration purposes. +@end itemize + +@noindent +The preceding rules describe the set of files that must be compiled to +generate the object files for a program. Each object file has the same +name as the corresponding source file, except that the extension is +@file{.o} as usual. + +You may wish to compile other files for the purpose of checking their +syntactic and semantic correctness. For example, in the case where a +package has a separate spec and body, you would not normally compile the +spec. However, it is convenient in practice to compile the spec to make +sure it is error-free before compiling clients of this spec, because such +compilations will fail if there is an error in the spec. + +GNAT provides an option for compiling such files purely for the +purposes of checking correctness; such compilations are not required as +part of the process of building a program. To compile a file in this +checking mode, use the @option{-gnatc} switch. + +@node Source Dependencies +@section Source Dependencies + +@noindent +A given object file clearly depends on the source file which is compiled +to produce it. Here we are using @dfn{depends} in the sense of a typical +@code{make} utility; in other words, an object file depends on a source +file if changes to the source file require the object file to be +recompiled. +In addition to this basic dependency, a given object may depend on +additional source files as follows: + +@itemize @bullet +@item +If a file being compiled @code{with}'s a unit @var{X}, the object file +depends on the file containing the spec of unit @var{X}. This includes +files that are @code{with}'ed implicitly either because they are parents +of @code{with}'ed child units or they are run-time units required by the +language constructs used in a particular unit. + +@item +If a file being compiled instantiates a library level generic unit, the +object file depends on both the spec and body files for this generic +unit. + +@item +If a file being compiled instantiates a generic unit defined within a +package, the object file depends on the body file for the package as +well as the spec file. + +@item +@findex Inline +@cindex @option{-gnatn} switch +If a file being compiled contains a call to a subprogram for which +pragma @code{Inline} applies and inlining is activated with the +@option{-gnatn} switch, the object file depends on the file containing the +body of this subprogram as well as on the file containing the spec. Note +that for inlining to actually occur as a result of the use of this switch, +it is necessary to compile in optimizing mode. + +@cindex @option{-gnatN} switch +The use of @option{-gnatN} activates inlining optimization +that is performed by the front end of the compiler. This inlining does +not require that the code generation be optimized. Like @option{-gnatn}, +the use of this switch generates additional dependencies. + +When using a gcc-based back end (in practice this means using any version +of GNAT other than the JGNAT, .NET or GNAAMP versions), then the use of +@option{-gnatN} is deprecated, and the use of @option{-gnatn} is preferred. +Historically front end inlining was more extensive than the gcc back end +inlining, but that is no longer the case. + +@item +If an object file @file{O} depends on the proper body of a subunit through +inlining or instantiation, it depends on the parent unit of the subunit. +This means that any modification of the parent unit or one of its subunits +affects the compilation of @file{O}. + +@item +The object file for a parent unit depends on all its subunit body files. + +@item +The previous two rules meant that for purposes of computing dependencies and +recompilation, a body and all its subunits are treated as an indivisible whole. + +@noindent +These rules are applied transitively: if unit @code{A} @code{with}'s +unit @code{B}, whose elaboration calls an inlined procedure in package +@code{C}, the object file for unit @code{A} will depend on the body of +@code{C}, in file @file{c.adb}. + +The set of dependent files described by these rules includes all the +files on which the unit is semantically dependent, as dictated by the +Ada language standard. However, it is a superset of what the +standard describes, because it includes generic, inline, and subunit +dependencies. + +An object file must be recreated by recompiling the corresponding source +file if any of the source files on which it depends are modified. For +example, if the @code{make} utility is used to control compilation, +the rule for an Ada object file must mention all the source files on +which the object file depends, according to the above definition. +The determination of the necessary +recompilations is done automatically when one uses @command{gnatmake}. +@end itemize + +@node The Ada Library Information Files +@section The Ada Library Information Files +@cindex Ada Library Information files +@cindex @file{ALI} files + +@noindent +Each compilation actually generates two output files. The first of these +is the normal object file that has a @file{.o} extension. The second is a +text file containing full dependency information. It has the same +name as the source file, but an @file{.ali} extension. +This file is known as the Ada Library Information (@file{ALI}) file. +The following information is contained in the @file{ALI} file. + +@itemize @bullet +@item +Version information (indicates which version of GNAT was used to compile +the unit(s) in question) + +@item +Main program information (including priority and time slice settings, +as well as the wide character encoding used during compilation). + +@item +List of arguments used in the @command{gcc} command for the compilation + +@item +Attributes of the unit, including configuration pragmas used, an indication +of whether the compilation was successful, exception model used etc. + +@item +A list of relevant restrictions applying to the unit (used for consistency) +checking. + +@item +Categorization information (e.g.@: use of pragma @code{Pure}). + +@item +Information on all @code{with}'ed units, including presence of +@code{Elaborate} or @code{Elaborate_All} pragmas. + +@item +Information from any @code{Linker_Options} pragmas used in the unit + +@item +Information on the use of @code{Body_Version} or @code{Version} +attributes in the unit. + +@item +Dependency information. This is a list of files, together with +time stamp and checksum information. These are files on which +the unit depends in the sense that recompilation is required +if any of these units are modified. + +@item +Cross-reference data. Contains information on all entities referenced +in the unit. Used by tools like @code{gnatxref} and @code{gnatfind} to +provide cross-reference information. + +@end itemize + +@noindent +For a full detailed description of the format of the @file{ALI} file, +see the source of the body of unit @code{Lib.Writ}, contained in file +@file{lib-writ.adb} in the GNAT compiler sources. + +@node Binding an Ada Program +@section Binding an Ada Program + +@noindent +When using languages such as C and C++, once the source files have been +compiled the only remaining step in building an executable program +is linking the object modules together. This means that it is possible to +link an inconsistent version of a program, in which two units have +included different versions of the same header. + +The rules of Ada do not permit such an inconsistent program to be built. +For example, if two clients have different versions of the same package, +it is illegal to build a program containing these two clients. +These rules are enforced by the GNAT binder, which also determines an +elaboration order consistent with the Ada rules. + +The GNAT binder is run after all the object files for a program have +been created. It is given the name of the main program unit, and from +this it determines the set of units required by the program, by reading the +corresponding ALI files. It generates error messages if the program is +inconsistent or if no valid order of elaboration exists. + +If no errors are detected, the binder produces a main program, in Ada by +default, that contains calls to the elaboration procedures of those +compilation unit that require them, followed by +a call to the main program. This Ada program is compiled to generate the +object file for the main program. The name of +the Ada file is @file{b~@var{xxx}.adb} (with the corresponding spec +@file{b~@var{xxx}.ads}) where @var{xxx} is the name of the +main program unit. + +Finally, the linker is used to build the resulting executable program, +using the object from the main program from the bind step as well as the +object files for the Ada units of the program. + +@node Mixed Language Programming +@section Mixed Language Programming +@cindex Mixed Language Programming + +@noindent +This section describes how to develop a mixed-language program, +specifically one that comprises units in both Ada and C. + +@menu +* Interfacing to C:: +* Calling Conventions:: +@end menu + +@node Interfacing to C +@subsection Interfacing to C +@noindent +Interfacing Ada with a foreign language such as C involves using +compiler directives to import and/or export entity definitions in each +language---using @code{extern} statements in C, for instance, and the +@code{Import}, @code{Export}, and @code{Convention} pragmas in Ada. +A full treatment of these topics is provided in Appendix B, section 1 +of the Ada Reference Manual. + +There are two ways to build a program using GNAT that contains some Ada +sources and some foreign language sources, depending on whether or not +the main subprogram is written in Ada. Here is a source example with +the main subprogram in Ada: + +@smallexample +/* file1.c */ +#include + +void print_num (int num) +@{ + printf ("num is %d.\n", num); + return; +@} + +/* file2.c */ + +/* num_from_Ada is declared in my_main.adb */ +extern int num_from_Ada; + +int get_num (void) +@{ + return num_from_Ada; +@} +@end smallexample + +@smallexample @c ada +-- my_main.adb +procedure My_Main is + + -- Declare then export an Integer entity called num_from_Ada + My_Num : Integer := 10; + pragma Export (C, My_Num, "num_from_Ada"); + + -- Declare an Ada function spec for Get_Num, then use + -- C function get_num for the implementation. + function Get_Num return Integer; + pragma Import (C, Get_Num, "get_num"); + + -- Declare an Ada procedure spec for Print_Num, then use + -- C function print_num for the implementation. + procedure Print_Num (Num : Integer); + pragma Import (C, Print_Num, "print_num"); + +begin + Print_Num (Get_Num); +end My_Main; +@end smallexample + +@enumerate +@item +To build this example, first compile the foreign language files to +generate object files: +@smallexample +^gcc -c file1.c^gcc -c FILE1.C^ +^gcc -c file2.c^gcc -c FILE2.C^ +@end smallexample + +@item +Then, compile the Ada units to produce a set of object files and ALI +files: +@smallexample +gnatmake ^-c^/ACTIONS=COMPILE^ my_main.adb +@end smallexample + +@item +Run the Ada binder on the Ada main program: +@smallexample +gnatbind my_main.ali +@end smallexample + +@item +Link the Ada main program, the Ada objects and the other language +objects: +@smallexample +gnatlink my_main.ali file1.o file2.o +@end smallexample +@end enumerate + +The last three steps can be grouped in a single command: +@smallexample +gnatmake my_main.adb -largs file1.o file2.o +@end smallexample + +@cindex Binder output file +@noindent +If the main program is in a language other than Ada, then you may have +more than one entry point into the Ada subsystem. You must use a special +binder option to generate callable routines that initialize and +finalize the Ada units (@pxref{Binding with Non-Ada Main Programs}). +Calls to the initialization and finalization routines must be inserted +in the main program, or some other appropriate point in the code. The +call to initialize the Ada units must occur before the first Ada +subprogram is called, and the call to finalize the Ada units must occur +after the last Ada subprogram returns. The binder will place the +initialization and finalization subprograms into the +@file{b~@var{xxx}.adb} file where they can be accessed by your C +sources. To illustrate, we have the following example: + +@smallexample +/* main.c */ +extern void adainit (void); +extern void adafinal (void); +extern int add (int, int); +extern int sub (int, int); + +int main (int argc, char *argv[]) +@{ + int a = 21, b = 7; + + adainit(); + + /* Should print "21 + 7 = 28" */ + printf ("%d + %d = %d\n", a, b, add (a, b)); + /* Should print "21 - 7 = 14" */ + printf ("%d - %d = %d\n", a, b, sub (a, b)); + + adafinal(); +@} +@end smallexample + +@smallexample @c ada +-- unit1.ads +package Unit1 is + function Add (A, B : Integer) return Integer; + pragma Export (C, Add, "add"); +end Unit1; + +-- unit1.adb +package body Unit1 is + function Add (A, B : Integer) return Integer is + begin + return A + B; + end Add; +end Unit1; + +-- unit2.ads +package Unit2 is + function Sub (A, B : Integer) return Integer; + pragma Export (C, Sub, "sub"); +end Unit2; + +-- unit2.adb +package body Unit2 is + function Sub (A, B : Integer) return Integer is + begin + return A - B; + end Sub; +end Unit2; +@end smallexample + +@enumerate +@item +The build procedure for this application is similar to the last +example's. First, compile the foreign language files to generate object +files: +@smallexample +^gcc -c main.c^gcc -c main.c^ +@end smallexample + +@item +Next, compile the Ada units to produce a set of object files and ALI +files: +@smallexample +gnatmake ^-c^/ACTIONS=COMPILE^ unit1.adb +gnatmake ^-c^/ACTIONS=COMPILE^ unit2.adb +@end smallexample + +@item +Run the Ada binder on every generated ALI file. Make sure to use the +@option{-n} option to specify a foreign main program: +@smallexample +gnatbind ^-n^/NOMAIN^ unit1.ali unit2.ali +@end smallexample + +@item +Link the Ada main program, the Ada objects and the foreign language +objects. You need only list the last ALI file here: +@smallexample +gnatlink unit2.ali main.o -o exec_file +@end smallexample + +This procedure yields a binary executable called @file{exec_file}. +@end enumerate + +@noindent +Depending on the circumstances (for example when your non-Ada main object +does not provide symbol @code{main}), you may also need to instruct the +GNAT linker not to include the standard startup objects by passing the +@option{^-nostartfiles^/NOSTART_FILES^} switch to @command{gnatlink}. + +@node Calling Conventions +@subsection Calling Conventions +@cindex Foreign Languages +@cindex Calling Conventions +GNAT follows standard calling sequence conventions and will thus interface +to any other language that also follows these conventions. The following +Convention identifiers are recognized by GNAT: + +@table @code +@cindex Interfacing to Ada +@cindex Other Ada compilers +@cindex Convention Ada +@item Ada +This indicates that the standard Ada calling sequence will be +used and all Ada data items may be passed without any limitations in the +case where GNAT is used to generate both the caller and callee. It is also +possible to mix GNAT generated code and code generated by another Ada +compiler. In this case, the data types should be restricted to simple +cases, including primitive types. Whether complex data types can be passed +depends on the situation. Probably it is safe to pass simple arrays, such +as arrays of integers or floats. Records may or may not work, depending +on whether both compilers lay them out identically. Complex structures +involving variant records, access parameters, tasks, or protected types, +are unlikely to be able to be passed. + +Note that in the case of GNAT running +on a platform that supports HP Ada 83, a higher degree of compatibility +can be guaranteed, and in particular records are layed out in an identical +manner in the two compilers. Note also that if output from two different +compilers is mixed, the program is responsible for dealing with elaboration +issues. Probably the safest approach is to write the main program in the +version of Ada other than GNAT, so that it takes care of its own elaboration +requirements, and then call the GNAT-generated adainit procedure to ensure +elaboration of the GNAT components. Consult the documentation of the other +Ada compiler for further details on elaboration. + +However, it is not possible to mix the tasking run time of GNAT and +HP Ada 83, All the tasking operations must either be entirely within +GNAT compiled sections of the program, or entirely within HP Ada 83 +compiled sections of the program. + +@cindex Interfacing to Assembly +@cindex Convention Assembler +@item Assembler +Specifies assembler as the convention. In practice this has the +same effect as convention Ada (but is not equivalent in the sense of being +considered the same convention). + +@cindex Convention Asm +@findex Asm +@item Asm +Equivalent to Assembler. + +@cindex Interfacing to COBOL +@cindex Convention COBOL +@findex COBOL +@item COBOL +Data will be passed according to the conventions described +in section B.4 of the Ada Reference Manual. + +@findex C +@cindex Interfacing to C +@cindex Convention C +@item C +Data will be passed according to the conventions described +in section B.3 of the Ada Reference Manual. + +A note on interfacing to a C ``varargs'' function: +@findex C varargs function +@cindex Interfacing to C varargs function +@cindex varargs function interfaces + +@itemize @bullet +@item +In C, @code{varargs} allows a function to take a variable number of +arguments. There is no direct equivalent in this to Ada. One +approach that can be used is to create a C wrapper for each +different profile and then interface to this C wrapper. For +example, to print an @code{int} value using @code{printf}, +create a C function @code{printfi} that takes two arguments, a +pointer to a string and an int, and calls @code{printf}. +Then in the Ada program, use pragma @code{Import} to +interface to @code{printfi}. + +@item +It may work on some platforms to directly interface to +a @code{varargs} function by providing a specific Ada profile +for a particular call. However, this does not work on +all platforms, since there is no guarantee that the +calling sequence for a two argument normal C function +is the same as for calling a @code{varargs} C function with +the same two arguments. +@end itemize + +@cindex Convention Default +@findex Default +@item Default +Equivalent to C. + +@cindex Convention External +@findex External +@item External +Equivalent to C. + +@ifclear vms +@findex C++ +@cindex Interfacing to C++ +@cindex Convention C++ +@item C_Plus_Plus (or CPP) +This stands for C++. For most purposes this is identical to C. +See the separate description of the specialized GNAT pragmas relating to +C++ interfacing for further details. +@end ifclear + +@findex Fortran +@cindex Interfacing to Fortran +@cindex Convention Fortran +@item Fortran +Data will be passed according to the conventions described +in section B.5 of the Ada Reference Manual. + +@item Intrinsic +This applies to an intrinsic operation, as defined in the Ada +Reference Manual. If a pragma Import (Intrinsic) applies to a subprogram, +this means that the body of the subprogram is provided by the compiler itself, +usually by means of an efficient code sequence, and that the user does not +supply an explicit body for it. In an application program, the pragma may +be applied to the following sets of names: + +@itemize @bullet +@item +Rotate_Left, Rotate_Right, Shift_Left, Shift_Right, +Shift_Right_Arithmetic. The corresponding subprogram declaration must have +two formal parameters. The +first one must be a signed integer type or a modular type with a binary +modulus, and the second parameter must be of type Natural. +The return type must be the same as the type of the first argument. The size +of this type can only be 8, 16, 32, or 64. + +@item +Binary arithmetic operators: ``+'', ``-'', ``*'', ``/'' +The corresponding operator declaration must have parameters and result type +that have the same root numeric type (for example, all three are long_float +types). This simplifies the definition of operations that use type checking +to perform dimensional checks: + +@smallexample @c ada +type Distance is new Long_Float; +type Time is new Long_Float; +type Velocity is new Long_Float; +function "/" (D : Distance; T : Time) + return Velocity; +pragma Import (Intrinsic, "/"); +@end smallexample + +@noindent +This common idiom is often programmed with a generic definition and an +explicit body. The pragma makes it simpler to introduce such declarations. +It incurs no overhead in compilation time or code size, because it is +implemented as a single machine instruction. + +@item +General subprogram entities, to bind an Ada subprogram declaration to +a compiler builtin by name with back-ends where such interfaces are +available. A typical example is the set of ``__builtin'' functions +exposed by the GCC back-end, as in the following example: + +@smallexample @c ada + function builtin_sqrt (F : Float) return Float; + pragma Import (Intrinsic, builtin_sqrt, "__builtin_sqrtf"); +@end smallexample + +Most of the GCC builtins are accessible this way, and as for other +import conventions (e.g. C), it is the user's responsibility to ensure +that the Ada subprogram profile matches the underlying builtin +expectations. +@end itemize + +@noindent + +@ifset unw +@findex Stdcall +@cindex Convention Stdcall +@item Stdcall +This is relevant only to Windows XP/2000/NT implementations of GNAT, +and specifies that the @code{Stdcall} calling sequence will be used, +as defined by the NT API. Nevertheless, to ease building +cross-platform bindings this convention will be handled as a @code{C} calling +convention on non-Windows platforms. + +@findex DLL +@cindex Convention DLL +@item DLL +This is equivalent to @code{Stdcall}. + +@findex Win32 +@cindex Convention Win32 +@item Win32 +This is equivalent to @code{Stdcall}. +@end ifset + +@findex Stubbed +@cindex Convention Stubbed +@item Stubbed +This is a special convention that indicates that the compiler +should provide a stub body that raises @code{Program_Error}. +@end table + +@noindent +GNAT additionally provides a useful pragma @code{Convention_Identifier} +that can be used to parameterize conventions and allow additional synonyms +to be specified. For example if you have legacy code in which the convention +identifier Fortran77 was used for Fortran, you can use the configuration +pragma: + +@smallexample @c ada +pragma Convention_Identifier (Fortran77, Fortran); +@end smallexample + +@noindent +And from now on the identifier Fortran77 may be used as a convention +identifier (for example in an @code{Import} pragma) with the same +meaning as Fortran. + +@ifclear vms +@node Building Mixed Ada & C++ Programs +@section Building Mixed Ada and C++ Programs + +@noindent +A programmer inexperienced with mixed-language development may find that +building an application containing both Ada and C++ code can be a +challenge. This section gives a few +hints that should make this task easier. The first section addresses +the differences between interfacing with C and interfacing with C++. +The second section +looks into the delicate problem of linking the complete application from +its Ada and C++ parts. The last section gives some hints on how the GNAT +run-time library can be adapted in order to allow inter-language dispatching +with a new C++ compiler. + +@menu +* Interfacing to C++:: +* Linking a Mixed C++ & Ada Program:: +* A Simple Example:: +* Interfacing with C++ constructors:: +* Interfacing with C++ at the Class Level:: +@end menu + +@node Interfacing to C++ +@subsection Interfacing to C++ + +@noindent +GNAT supports interfacing with the G++ compiler (or any C++ compiler +generating code that is compatible with the G++ Application Binary +Interface ---see http://www.codesourcery.com/archives/cxx-abi). + +@noindent +Interfacing can be done at 3 levels: simple data, subprograms, and +classes. In the first two cases, GNAT offers a specific @code{Convention +C_Plus_Plus} (or @code{CPP}) that behaves exactly like @code{Convention C}. +Usually, C++ mangles the names of subprograms. To generate proper mangled +names automatically, see @ref{Generating Ada Bindings for C and C++ headers}). +This problem can also be addressed manually in two ways: + +@itemize @bullet +@item +by modifying the C++ code in order to force a C convention using +the @code{extern "C"} syntax. + +@item +by figuring out the mangled name (using e.g. @command{nm}) and using it as the +Link_Name argument of the pragma import. +@end itemize + +@noindent +Interfacing at the class level can be achieved by using the GNAT specific +pragmas such as @code{CPP_Constructor}. @xref{Interfacing to C++,,, +gnat_rm, GNAT Reference Manual}, for additional information. + +@node Linking a Mixed C++ & Ada Program +@subsection Linking a Mixed C++ & Ada Program + +@noindent +Usually the linker of the C++ development system must be used to link +mixed applications because most C++ systems will resolve elaboration +issues (such as calling constructors on global class instances) +transparently during the link phase. GNAT has been adapted to ease the +use of a foreign linker for the last phase. Three cases can be +considered: +@enumerate + +@item +Using GNAT and G++ (GNU C++ compiler) from the same GCC installation: +The C++ linker can simply be called by using the C++ specific driver +called @code{g++}. + +Note that if the C++ code uses inline functions, you will need to +compile your C++ code with the @code{-fkeep-inline-functions} switch in +order to provide an existing function implementation that the Ada code can +link with. + +@smallexample +$ g++ -c -fkeep-inline-functions file1.C +$ g++ -c -fkeep-inline-functions file2.C +$ gnatmake ada_unit -largs file1.o file2.o --LINK=g++ +@end smallexample + +@item +Using GNAT and G++ from two different GCC installations: If both +compilers are on the @env{PATH}, the previous method may be used. It is +important to note that environment variables such as +@env{C_INCLUDE_PATH}, @env{GCC_EXEC_PREFIX}, @env{BINUTILS_ROOT}, and +@env{GCC_ROOT} will affect both compilers +at the same time and may make one of the two compilers operate +improperly if set during invocation of the wrong compiler. It is also +very important that the linker uses the proper @file{libgcc.a} GCC +library -- that is, the one from the C++ compiler installation. The +implicit link command as suggested in the @command{gnatmake} command +from the former example can be replaced by an explicit link command with +the full-verbosity option in order to verify which library is used: +@smallexample +$ gnatbind ada_unit +$ gnatlink -v -v ada_unit file1.o file2.o --LINK=c++ +@end smallexample +If there is a problem due to interfering environment variables, it can +be worked around by using an intermediate script. The following example +shows the proper script to use when GNAT has not been installed at its +default location and g++ has been installed at its default location: + +@smallexample +$ cat ./my_script +#!/bin/sh +unset BINUTILS_ROOT +unset GCC_ROOT +c++ $* +$ gnatlink -v -v ada_unit file1.o file2.o --LINK=./my_script +@end smallexample + +@item +Using a non-GNU C++ compiler: The commands previously described can be +used to insure that the C++ linker is used. Nonetheless, you need to add +a few more parameters to the link command line, depending on the exception +mechanism used. + +If the @code{setjmp/longjmp} exception mechanism is used, only the paths +to the libgcc libraries are required: + +@smallexample +$ cat ./my_script +#!/bin/sh +CC $* `gcc -print-file-name=libgcc.a` `gcc -print-file-name=libgcc_eh.a` +$ gnatlink ada_unit file1.o file2.o --LINK=./my_script +@end smallexample + +Where CC is the name of the non-GNU C++ compiler. + +If the @code{zero cost} exception mechanism is used, and the platform +supports automatic registration of exception tables (e.g.@: Solaris or IRIX), +paths to more objects are required: + +@smallexample +$ cat ./my_script +#!/bin/sh +CC `gcc -print-file-name=crtbegin.o` $* \ +`gcc -print-file-name=libgcc.a` `gcc -print-file-name=libgcc_eh.a` \ +`gcc -print-file-name=crtend.o` +$ gnatlink ada_unit file1.o file2.o --LINK=./my_script +@end smallexample + +If the @code{zero cost} exception mechanism is used, and the platform +doesn't support automatic registration of exception tables (e.g.@: HP-UX, +Tru64 or AIX), the simple approach described above will not work and +a pre-linking phase using GNAT will be necessary. + +@end enumerate + +Another alternative is to use the @command{gprbuild} multi-language builder +which has a large knowledge base and knows how to link Ada and C++ code +together automatically in most cases. + +@node A Simple Example +@subsection A Simple Example +@noindent +The following example, provided as part of the GNAT examples, shows how +to achieve procedural interfacing between Ada and C++ in both +directions. The C++ class A has two methods. The first method is exported +to Ada by the means of an extern C wrapper function. The second method +calls an Ada subprogram. On the Ada side, The C++ calls are modelled by +a limited record with a layout comparable to the C++ class. The Ada +subprogram, in turn, calls the C++ method. So, starting from the C++ +main program, the process passes back and forth between the two +languages. + +@noindent +Here are the compilation commands: +@smallexample +$ gnatmake -c simple_cpp_interface +$ g++ -c cpp_main.C +$ g++ -c ex7.C +$ gnatbind -n simple_cpp_interface +$ gnatlink simple_cpp_interface -o cpp_main --LINK=g++ + -lstdc++ ex7.o cpp_main.o +@end smallexample + +@noindent +Here are the corresponding sources: +@smallexample + +//cpp_main.C + +#include "ex7.h" + +extern "C" @{ + void adainit (void); + void adafinal (void); + void method1 (A *t); +@} + +void method1 (A *t) +@{ + t->method1 (); +@} + +int main () +@{ + A obj; + adainit (); + obj.method2 (3030); + adafinal (); +@} + +//ex7.h + +class Origin @{ + public: + int o_value; +@}; +class A : public Origin @{ + public: + void method1 (void); + void method2 (int v); + A(); + int a_value; +@}; + +//ex7.C + +#include "ex7.h" +#include + +extern "C" @{ void ada_method2 (A *t, int v);@} + +void A::method1 (void) +@{ + a_value = 2020; + printf ("in A::method1, a_value = %d \n",a_value); + +@} + +void A::method2 (int v) +@{ + ada_method2 (this, v); + printf ("in A::method2, a_value = %d \n",a_value); + +@} + +A::A(void) +@{ + a_value = 1010; + printf ("in A::A, a_value = %d \n",a_value); +@} +@end smallexample + +@smallexample @c ada +-- Ada sources +package body Simple_Cpp_Interface is + + procedure Ada_Method2 (This : in out A; V : Integer) is + begin + Method1 (This); + This.A_Value := V; + end Ada_Method2; + +end Simple_Cpp_Interface; + +with System; +package Simple_Cpp_Interface is + type A is limited + record + Vptr : System.Address; + O_Value : Integer; + A_Value : Integer; + end record; + pragma Convention (C, A); + + procedure Method1 (This : in out A); + pragma Import (C, Method1); + + procedure Ada_Method2 (This : in out A; V : Integer); + pragma Export (C, Ada_Method2); + +end Simple_Cpp_Interface; +@end smallexample + +@node Interfacing with C++ constructors +@subsection Interfacing with C++ constructors +@noindent + +In order to interface with C++ constructors GNAT provides the +@code{pragma CPP_Constructor} (@xref{Interfacing to C++,,, +gnat_rm, GNAT Reference Manual}, for additional information). +In this section we present some common uses of C++ constructors +in mixed-languages programs in GNAT. + +Let us assume that we need to interface with the following +C++ class: + +@smallexample +@b{class} Root @{ +@b{public}: + int a_value; + int b_value; + @b{virtual} int Get_Value (); + Root(); // Default constructor + Root(int v); // 1st non-default constructor + Root(int v, int w); // 2nd non-default constructor +@}; +@end smallexample + +For this purpose we can write the following package spec (further +information on how to build this spec is available in +@ref{Interfacing with C++ at the Class Level} and +@ref{Generating Ada Bindings for C and C++ headers}). + +@smallexample @c ada +with Interfaces.C; use Interfaces.C; +package Pkg_Root is + type Root is tagged limited record + A_Value : int; + B_Value : int; + end record; + pragma Import (CPP, Root); + + function Get_Value (Obj : Root) return int; + pragma Import (CPP, Get_Value); + + function Constructor return Root; + pragma Cpp_Constructor (Constructor, "_ZN4RootC1Ev"); + + function Constructor (v : Integer) return Root; + pragma Cpp_Constructor (Constructor, "_ZN4RootC1Ei"); + + function Constructor (v, w : Integer) return Root; + pragma Cpp_Constructor (Constructor, "_ZN4RootC1Eii"); +end Pkg_Root; +@end smallexample + +On the Ada side the constructor is represented by a function (whose +name is arbitrary) that returns the classwide type corresponding to +the imported C++ class. Although the constructor is described as a +function, it is typically a procedure with an extra implicit argument +(the object being initialized) at the implementation level. GNAT +issues the appropriate call, whatever it is, to get the object +properly initialized. + +Constructors can only appear in the following contexts: + +@itemize @bullet +@item +On the right side of an initialization of an object of type @var{T}. +@item +On the right side of an initialization of a record component of type @var{T}. +@item +In an Ada 2005 limited aggregate. +@item +In an Ada 2005 nested limited aggregate. +@item +In an Ada 2005 limited aggregate that initializes an object built in +place by an extended return statement. +@end itemize + +@noindent +In a declaration of an object whose type is a class imported from C++, +either the default C++ constructor is implicitly called by GNAT, or +else the required C++ constructor must be explicitly called in the +expression that initializes the object. For example: + +@smallexample @c ada + Obj1 : Root; + Obj2 : Root := Constructor; + Obj3 : Root := Constructor (v => 10); + Obj4 : Root := Constructor (30, 40); +@end smallexample + +The first two declarations are equivalent: in both cases the default C++ +constructor is invoked (in the former case the call to the constructor is +implicit, and in the latter case the call is explicit in the object +declaration). @code{Obj3} is initialized by the C++ non-default constructor +that takes an integer argument, and @code{Obj4} is initialized by the +non-default C++ constructor that takes two integers. + +Let us derive the imported C++ class in the Ada side. For example: + +@smallexample @c ada + type DT is new Root with record + C_Value : Natural := 2009; + end record; +@end smallexample + +In this case the components DT inherited from the C++ side must be +initialized by a C++ constructor, and the additional Ada components +of type DT are initialized by GNAT. The initialization of such an +object is done either by default, or by means of a function returning +an aggregate of type DT, or by means of an extension aggregate. + +@smallexample @c ada + Obj5 : DT; + Obj6 : DT := Function_Returning_DT (50); + Obj7 : DT := (Constructor (30,40) with C_Value => 50); +@end smallexample + +The declaration of @code{Obj5} invokes the default constructors: the +C++ default constructor of the parent type takes care of the initialization +of the components inherited from Root, and GNAT takes care of the default +initialization of the additional Ada components of type DT (that is, +@code{C_Value} is initialized to value 2009). The order of invocation of +the constructors is consistent with the order of elaboration required by +Ada and C++. That is, the constructor of the parent type is always called +before the constructor of the derived type. + +Let us now consider a record that has components whose type is imported +from C++. For example: + +@smallexample @c ada + type Rec1 is limited record + Data1 : Root := Constructor (10); + Value : Natural := 1000; + end record; + + type Rec2 (D : Integer := 20) is limited record + Rec : Rec1; + Data2 : Root := Constructor (D, 30); + end record; +@end smallexample + +The initialization of an object of type @code{Rec2} will call the +non-default C++ constructors specified for the imported components. +For example: + +@smallexample @c ada + Obj8 : Rec2 (40); +@end smallexample + +Using Ada 2005 we can use limited aggregates to initialize an object +invoking C++ constructors that differ from those specified in the type +declarations. For example: + +@smallexample @c ada + Obj9 : Rec2 := (Rec => (Data1 => Constructor (15, 16), + others => <>), + others => <>); +@end smallexample + +The above declaration uses an Ada 2005 limited aggregate to +initialize @code{Obj9}, and the C++ constructor that has two integer +arguments is invoked to initialize the @code{Data1} component instead +of the constructor specified in the declaration of type @code{Rec1}. In +Ada 2005 the box in the aggregate indicates that unspecified components +are initialized using the expression (if any) available in the component +declaration. That is, in this case discriminant @code{D} is initialized +to value @code{20}, @code{Value} is initialized to value 1000, and the +non-default C++ constructor that handles two integers takes care of +initializing component @code{Data2} with values @code{20,30}. + +In Ada 2005 we can use the extended return statement to build the Ada +equivalent to C++ non-default constructors. For example: + +@smallexample @c ada + function Constructor (V : Integer) return Rec2 is + begin + return Obj : Rec2 := (Rec => (Data1 => Constructor (V, 20), + others => <>), + others => <>) do + -- Further actions required for construction of + -- objects of type Rec2 + ... + end record; + end Constructor; +@end smallexample + +In this example the extended return statement construct is used to +build in place the returned object whose components are initialized +by means of a limited aggregate. Any further action associated with +the constructor can be placed inside the construct. + +@node Interfacing with C++ at the Class Level +@subsection Interfacing with C++ at the Class Level +@noindent +In this section we demonstrate the GNAT features for interfacing with +C++ by means of an example making use of Ada 2005 abstract interface +types. This example consists of a classification of animals; classes +have been used to model our main classification of animals, and +interfaces provide support for the management of secondary +classifications. We first demonstrate a case in which the types and +constructors are defined on the C++ side and imported from the Ada +side, and latter the reverse case. + +The root of our derivation will be the @code{Animal} class, with a +single private attribute (the @code{Age} of the animal) and two public +primitives to set and get the value of this attribute. + +@smallexample +@b{class} Animal @{ + @b{public}: + @b{virtual} void Set_Age (int New_Age); + @b{virtual} int Age (); + @b{private}: + int Age_Count; +@}; +@end smallexample + +Abstract interface types are defined in C++ by means of classes with pure +virtual functions and no data members. In our example we will use two +interfaces that provide support for the common management of @code{Carnivore} +and @code{Domestic} animals: + +@smallexample +@b{class} Carnivore @{ +@b{public}: + @b{virtual} int Number_Of_Teeth () = 0; +@}; + +@b{class} Domestic @{ +@b{public}: + @b{virtual void} Set_Owner (char* Name) = 0; +@}; +@end smallexample + +Using these declarations, we can now say that a @code{Dog} is an animal that is +both Carnivore and Domestic, that is: + +@smallexample +@b{class} Dog : Animal, Carnivore, Domestic @{ + @b{public}: + @b{virtual} int Number_Of_Teeth (); + @b{virtual} void Set_Owner (char* Name); + + Dog(); // Constructor + @b{private}: + int Tooth_Count; + char *Owner; +@}; +@end smallexample + +In the following examples we will assume that the previous declarations are +located in a file named @code{animals.h}. The following package demonstrates +how to import these C++ declarations from the Ada side: + +@smallexample @c ada +with Interfaces.C.Strings; use Interfaces.C.Strings; +package Animals is + type Carnivore is interface; + pragma Convention (C_Plus_Plus, Carnivore); + function Number_Of_Teeth (X : Carnivore) + return Natural is abstract; + + type Domestic is interface; + pragma Convention (C_Plus_Plus, Set_Owner); + procedure Set_Owner + (X : in out Domestic; + Name : Chars_Ptr) is abstract; + + type Animal is tagged record + Age : Natural := 0; + end record; + pragma Import (C_Plus_Plus, Animal); + + procedure Set_Age (X : in out Animal; Age : Integer); + pragma Import (C_Plus_Plus, Set_Age); + + function Age (X : Animal) return Integer; + pragma Import (C_Plus_Plus, Age); + + type Dog is new Animal and Carnivore and Domestic with record + Tooth_Count : Natural; + Owner : String (1 .. 30); + end record; + pragma Import (C_Plus_Plus, Dog); + + function Number_Of_Teeth (A : Dog) return Integer; + pragma Import (C_Plus_Plus, Number_Of_Teeth); + + procedure Set_Owner (A : in out Dog; Name : Chars_Ptr); + pragma Import (C_Plus_Plus, Set_Owner); + + function New_Dog return Dog; + pragma CPP_Constructor (New_Dog); + pragma Import (CPP, New_Dog, "_ZN3DogC2Ev"); +end Animals; +@end smallexample + +Thanks to the compatibility between GNAT run-time structures and the C++ ABI, +interfacing with these C++ classes is easy. The only requirement is that all +the primitives and components must be declared exactly in the same order in +the two languages. + +Regarding the abstract interfaces, we must indicate to the GNAT compiler by +means of a @code{pragma Convention (C_Plus_Plus)}, the convention used to pass +the arguments to the called primitives will be the same as for C++. For the +imported classes we use @code{pragma Import} with convention @code{C_Plus_Plus} +to indicate that they have been defined on the C++ side; this is required +because the dispatch table associated with these tagged types will be built +in the C++ side and therefore will not contain the predefined Ada primitives +which Ada would otherwise expect. + +As the reader can see there is no need to indicate the C++ mangled names +associated with each subprogram because it is assumed that all the calls to +these primitives will be dispatching calls. The only exception is the +constructor, which must be registered with the compiler by means of +@code{pragma CPP_Constructor} and needs to provide its associated C++ +mangled name because the Ada compiler generates direct calls to it. + +With the above packages we can now declare objects of type Dog on the Ada side +and dispatch calls to the corresponding subprograms on the C++ side. We can +also extend the tagged type Dog with further fields and primitives, and +override some of its C++ primitives on the Ada side. For example, here we have +a type derivation defined on the Ada side that inherits all the dispatching +primitives of the ancestor from the C++ side. + +@smallexample +@b{with} Animals; @b{use} Animals; +@b{package} Vaccinated_Animals @b{is} + @b{type} Vaccinated_Dog @b{is new} Dog @b{with null record}; + @b{function} Vaccination_Expired (A : Vaccinated_Dog) @b{return} Boolean; +@b{end} Vaccinated_Animals; +@end smallexample + +It is important to note that, because of the ABI compatibility, the programmer +does not need to add any further information to indicate either the object +layout or the dispatch table entry associated with each dispatching operation. + +Now let us define all the types and constructors on the Ada side and export +them to C++, using the same hierarchy of our previous example: + +@smallexample @c ada +with Interfaces.C.Strings; +use Interfaces.C.Strings; +package Animals is + type Carnivore is interface; + pragma Convention (C_Plus_Plus, Carnivore); + function Number_Of_Teeth (X : Carnivore) + return Natural is abstract; + + type Domestic is interface; + pragma Convention (C_Plus_Plus, Set_Owner); + procedure Set_Owner + (X : in out Domestic; + Name : Chars_Ptr) is abstract; + + type Animal is tagged record + Age : Natural := 0; + end record; + pragma Convention (C_Plus_Plus, Animal); + + procedure Set_Age (X : in out Animal; Age : Integer); + pragma Export (C_Plus_Plus, Set_Age); + + function Age (X : Animal) return Integer; + pragma Export (C_Plus_Plus, Age); + + type Dog is new Animal and Carnivore and Domestic with record + Tooth_Count : Natural; + Owner : String (1 .. 30); + end record; + pragma Convention (C_Plus_Plus, Dog); + + function Number_Of_Teeth (A : Dog) return Integer; + pragma Export (C_Plus_Plus, Number_Of_Teeth); + + procedure Set_Owner (A : in out Dog; Name : Chars_Ptr); + pragma Export (C_Plus_Plus, Set_Owner); + + function New_Dog return Dog'Class; + pragma Export (C_Plus_Plus, New_Dog); +end Animals; +@end smallexample + +Compared with our previous example the only difference is the use of +@code{pragma Export} to indicate to the GNAT compiler that the primitives will +be available to C++. Thanks to the ABI compatibility, on the C++ side there is +nothing else to be done; as explained above, the only requirement is that all +the primitives and components are declared in exactly the same order. + +For completeness, let us see a brief C++ main program that uses the +declarations available in @code{animals.h} (presented in our first example) to +import and use the declarations from the Ada side, properly initializing and +finalizing the Ada run-time system along the way: + +@smallexample +@b{#include} "animals.h" +@b{#include} +@b{using namespace} std; + +void Check_Carnivore (Carnivore *obj) @{@dots{}@} +void Check_Domestic (Domestic *obj) @{@dots{}@} +void Check_Animal (Animal *obj) @{@dots{}@} +void Check_Dog (Dog *obj) @{@dots{}@} + +@b{extern} "C" @{ + void adainit (void); + void adafinal (void); + Dog* new_dog (); +@} + +void test () +@{ + Dog *obj = new_dog(); // Ada constructor + Check_Carnivore (obj); // Check secondary DT + Check_Domestic (obj); // Check secondary DT + Check_Animal (obj); // Check primary DT + Check_Dog (obj); // Check primary DT +@} + +int main () +@{ + adainit (); test(); adafinal (); + return 0; +@} +@end smallexample + +@node Comparison between GNAT and C/C++ Compilation Models +@section Comparison between GNAT and C/C++ Compilation Models + +@noindent +The GNAT model of compilation is close to the C and C++ models. You can +think of Ada specs as corresponding to header files in C. As in C, you +don't need to compile specs; they are compiled when they are used. The +Ada @code{with} is similar in effect to the @code{#include} of a C +header. + +One notable difference is that, in Ada, you may compile specs separately +to check them for semantic and syntactic accuracy. This is not always +possible with C headers because they are fragments of programs that have +less specific syntactic or semantic rules. + +The other major difference is the requirement for running the binder, +which performs two important functions. First, it checks for +consistency. In C or C++, the only defense against assembling +inconsistent programs lies outside the compiler, in a makefile, for +example. The binder satisfies the Ada requirement that it be impossible +to construct an inconsistent program when the compiler is used in normal +mode. + +@cindex Elaboration order control +The other important function of the binder is to deal with elaboration +issues. There are also elaboration issues in C++ that are handled +automatically. This automatic handling has the advantage of being +simpler to use, but the C++ programmer has no control over elaboration. +Where @code{gnatbind} might complain there was no valid order of +elaboration, a C++ compiler would simply construct a program that +malfunctioned at run time. +@end ifclear + +@node Comparison between GNAT and Conventional Ada Library Models +@section Comparison between GNAT and Conventional Ada Library Models + +@noindent +This section is intended for Ada programmers who have +used an Ada compiler implementing the traditional Ada library +model, as described in the Ada Reference Manual. + +@cindex GNAT library +In GNAT, there is no ``library'' in the normal sense. Instead, the set of +source files themselves acts as the library. Compiling Ada programs does +not generate any centralized information, but rather an object file and +a ALI file, which are of interest only to the binder and linker. +In a traditional system, the compiler reads information not only from +the source file being compiled, but also from the centralized library. +This means that the effect of a compilation depends on what has been +previously compiled. In particular: + +@itemize @bullet +@item +When a unit is @code{with}'ed, the unit seen by the compiler corresponds +to the version of the unit most recently compiled into the library. + +@item +Inlining is effective only if the necessary body has already been +compiled into the library. + +@item +Compiling a unit may obsolete other units in the library. +@end itemize + +@noindent +In GNAT, compiling one unit never affects the compilation of any other +units because the compiler reads only source files. Only changes to source +files can affect the results of a compilation. In particular: + +@itemize @bullet +@item +When a unit is @code{with}'ed, the unit seen by the compiler corresponds +to the source version of the unit that is currently accessible to the +compiler. + +@item +@cindex Inlining +Inlining requires the appropriate source files for the package or +subprogram bodies to be available to the compiler. Inlining is always +effective, independent of the order in which units are complied. + +@item +Compiling a unit never affects any other compilations. The editing of +sources may cause previous compilations to be out of date if they +depended on the source file being modified. +@end itemize + +@noindent +The most important result of these differences is that order of compilation +is never significant in GNAT. There is no situation in which one is +required to do one compilation before another. What shows up as order of +compilation requirements in the traditional Ada library becomes, in +GNAT, simple source dependencies; in other words, there is only a set +of rules saying what source files must be present when a file is +compiled. + +@ifset vms +@node Placement of temporary files +@section Placement of temporary files +@cindex Temporary files (user control over placement) + +@noindent +GNAT creates temporary files in the directory designated by the environment +variable @env{TMPDIR}. +(See the HP @emph{C RTL Reference Manual} on the function @code{getenv()} +for detailed information on how environment variables are resolved. +For most users the easiest way to make use of this feature is to simply +define @env{TMPDIR} as a job level logical name). +For example, if you wish to use a Ramdisk (assuming DECRAM is installed) +for compiler temporary files, then you can include something like the +following command in your @file{LOGIN.COM} file: + +@smallexample +$ define/job TMPDIR "/disk$scratchram/000000/temp/" +@end smallexample + +@noindent +If @env{TMPDIR} is not defined, then GNAT uses the directory designated by +@env{TMP}; if @env{TMP} is not defined, then GNAT uses the directory +designated by @env{TEMP}. +If none of these environment variables are defined then GNAT uses the +directory designated by the logical name @code{SYS$SCRATCH:} +(by default the user's home directory). If all else fails +GNAT uses the current directory for temporary files. +@end ifset + +@c ************************* +@node Compiling Using gcc +@chapter Compiling Using @command{gcc} + +@noindent +This chapter discusses how to compile Ada programs using the @command{gcc} +command. It also describes the set of switches +that can be used to control the behavior of the compiler. +@menu +* Compiling Programs:: +* Switches for gcc:: +* Search Paths and the Run-Time Library (RTL):: +* Order of Compilation Issues:: +* Examples:: +@end menu + +@node Compiling Programs +@section Compiling Programs + +@noindent +The first step in creating an executable program is to compile the units +of the program using the @command{gcc} command. You must compile the +following files: + +@itemize @bullet +@item +the body file (@file{.adb}) for a library level subprogram or generic +subprogram + +@item +the spec file (@file{.ads}) for a library level package or generic +package that has no body + +@item +the body file (@file{.adb}) for a library level package +or generic package that has a body + +@end itemize + +@noindent +You need @emph{not} compile the following files + +@itemize @bullet + +@item +the spec of a library unit which has a body + +@item +subunits +@end itemize + +@noindent +because they are compiled as part of compiling related units. GNAT +package specs +when the corresponding body is compiled, and subunits when the parent is +compiled. + +@cindex cannot generate code +If you attempt to compile any of these files, you will get one of the +following error messages (where @var{fff} is the name of the file you +compiled): + +@smallexample +cannot generate code for file @var{fff} (package spec) +to check package spec, use -gnatc + +cannot generate code for file @var{fff} (missing subunits) +to check parent unit, use -gnatc + +cannot generate code for file @var{fff} (subprogram spec) +to check subprogram spec, use -gnatc + +cannot generate code for file @var{fff} (subunit) +to check subunit, use -gnatc +@end smallexample + +@noindent +As indicated by the above error messages, if you want to submit +one of these files to the compiler to check for correct semantics +without generating code, then use the @option{-gnatc} switch. + +The basic command for compiling a file containing an Ada unit is + +@smallexample +@c $ gcc -c @ovar{switches} @file{file name} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gcc -c @r{[}@var{switches}@r{]} @file{file name} +@end smallexample + +@noindent +where @var{file name} is the name of the Ada file (usually +having an extension +@file{.ads} for a spec or @file{.adb} for a body). +@ifclear vms +You specify the +@option{-c} switch to tell @command{gcc} to compile, but not link, the file. +@end ifclear +The result of a successful compilation is an object file, which has the +same name as the source file but an extension of @file{.o} and an Ada +Library Information (ALI) file, which also has the same name as the +source file, but with @file{.ali} as the extension. GNAT creates these +two output files in the current directory, but you may specify a source +file in any directory using an absolute or relative path specification +containing the directory information. + +@findex gnat1 +@command{gcc} is actually a driver program that looks at the extensions of +the file arguments and loads the appropriate compiler. For example, the +GNU C compiler is @file{cc1}, and the Ada compiler is @file{gnat1}. +These programs are in directories known to the driver program (in some +configurations via environment variables you set), but need not be in +your path. The @command{gcc} driver also calls the assembler and any other +utilities needed to complete the generation of the required object +files. + +It is possible to supply several file names on the same @command{gcc} +command. This causes @command{gcc} to call the appropriate compiler for +each file. For example, the following command lists three separate +files to be compiled: + +@smallexample +$ gcc -c x.adb y.adb z.c +@end smallexample + +@noindent +calls @code{gnat1} (the Ada compiler) twice to compile @file{x.adb} and +@file{y.adb}, and @code{cc1} (the C compiler) once to compile @file{z.c}. +The compiler generates three object files @file{x.o}, @file{y.o} and +@file{z.o} and the two ALI files @file{x.ali} and @file{y.ali} from the +Ada compilations. Any switches apply to all the files ^listed,^listed.^ +@ifclear vms +except for +@option{-gnat@var{x}} switches, which apply only to Ada compilations. +@end ifclear + +@node Switches for gcc +@section Switches for @command{gcc} + +@noindent +The @command{gcc} command accepts switches that control the +compilation process. These switches are fully described in this section. +First we briefly list all the switches, in alphabetical order, then we +describe the switches in more detail in functionally grouped sections. + +More switches exist for GCC than those documented here, especially +for specific targets. However, their use is not recommended as +they may change code generation in ways that are incompatible with +the Ada run-time library, or can cause inconsistencies between +compilation units. + +@menu +* Output and Error Message Control:: +* Warning Message Control:: +* Debugging and Assertion Control:: +* Validity Checking:: +* Style Checking:: +* Run-Time Checks:: +* Using gcc for Syntax Checking:: +* Using gcc for Semantic Checking:: +* Compiling Different Versions of Ada:: +* Character Set Control:: +* File Naming Control:: +* Subprogram Inlining Control:: +* Auxiliary Output Control:: +* Debugging Control:: +* Exception Handling Control:: +* Units to Sources Mapping Files:: +* Integrated Preprocessing:: +* Code Generation Control:: +@ifset vms +* Return Codes:: +@end ifset +@end menu + +@table @option +@c !sort! +@ifclear vms +@cindex @option{-b} (@command{gcc}) +@item -b @var{target} +Compile your program to run on @var{target}, which is the name of a +system configuration. You must have a GNAT cross-compiler built if +@var{target} is not the same as your host system. + +@item -B@var{dir} +@cindex @option{-B} (@command{gcc}) +Load compiler executables (for example, @code{gnat1}, the Ada compiler) +from @var{dir} instead of the default location. Only use this switch +when multiple versions of the GNAT compiler are available. +@xref{Directory Options,, Options for Directory Search, gcc, Using the +GNU Compiler Collection (GCC)}, for further details. You would normally +use the @option{-b} or @option{-V} switch instead. + +@item -c +@cindex @option{-c} (@command{gcc}) +Compile. Always use this switch when compiling Ada programs. + +Note: for some other languages when using @command{gcc}, notably in +the case of C and C++, it is possible to use +use @command{gcc} without a @option{-c} switch to +compile and link in one step. In the case of GNAT, you +cannot use this approach, because the binder must be run +and @command{gcc} cannot be used to run the GNAT binder. +@end ifclear + +@item -fno-inline +@cindex @option{-fno-inline} (@command{gcc}) +Suppresses all back-end inlining, even if other optimization or inlining +switches are set. +This includes suppression of inlining that results +from the use of the pragma @code{Inline_Always}. +Any occurrences of pragma @code{Inline} or @code{Inline_Always} +are ignored, and @option{-gnatn} and @option{-gnatN} have no +effect if this switch is present. + +@item -fno-inline-functions +@cindex @option{-fno-inline-functions} (@command{gcc}) +Suppresses automatic inlining of subprograms, which is enabled +if @option{-O3} is used. + +@item -fno-inline-small-functions +@cindex @option{-fno-inline-small-functions} (@command{gcc}) +Suppresses automatic inlining of small subprograms, which is enabled +if @option{-O2} is used. + +@item -fno-inline-functions-called-once +@cindex @option{-fno-inline-functions-called-once} (@command{gcc}) +Suppresses inlining of subprograms local to the unit and called once +from within it, which is enabled if @option{-O1} is used. + +@item -fno-ivopts +@cindex @option{-fno-ivopts} (@command{gcc}) +Suppresses high-level loop induction variable optimizations, which are +enabled if @option{-O1} is used. These optimizations are generally +profitable but, for some specific cases of loops with numerous uses +of the iteration variable that follow a common pattern, they may end +up destroying the regularity that could be exploited at a lower level +and thus producing inferior code. + +@item -fno-strict-aliasing +@cindex @option{-fno-strict-aliasing} (@command{gcc}) +Causes the compiler to avoid assumptions regarding non-aliasing +of objects of different types. See +@ref{Optimization and Strict Aliasing} for details. + +@item -fstack-check +@cindex @option{-fstack-check} (@command{gcc}) +Activates stack checking. +See @ref{Stack Overflow Checking} for details. + +@item -fstack-usage +@cindex @option{-fstack-usage} (@command{gcc}) +Makes the compiler output stack usage information for the program, on a +per-function basis. See @ref{Static Stack Usage Analysis} for details. + +@item -fcallgraph-info@r{[}=su@r{]} +@cindex @option{-fcallgraph-info} (@command{gcc}) +Makes the compiler output callgraph information for the program, on a +per-file basis. The information is generated in the VCG format. It can +be decorated with stack-usage per-node information. + +@item ^-g^/DEBUG^ +@cindex @option{^-g^/DEBUG^} (@command{gcc}) +Generate debugging information. This information is stored in the object +file and copied from there to the final executable file by the linker, +where it can be read by the debugger. You must use the +@option{^-g^/DEBUG^} switch if you plan on using the debugger. + +@item -gnat83 +@cindex @option{-gnat83} (@command{gcc}) +Enforce Ada 83 restrictions. + +@item -gnat95 +@cindex @option{-gnat95} (@command{gcc}) +Enforce Ada 95 restrictions. + +@item -gnat05 +@cindex @option{-gnat05} (@command{gcc}) +Allow full Ada 2005 features. + +@item -gnat2005 +@cindex @option{-gnat2005} (@command{gcc}) +Allow full Ada 2005 features (same as @option{-gnat05}) + +@item -gnat12 +@cindex @option{-gnat12} (@command{gcc}) + +@item -gnat2012 +@cindex @option{-gnat2012} (@command{gcc}) +Allow full Ada 2012 features (same as @option{-gnat12}) + +@item -gnata +@cindex @option{-gnata} (@command{gcc}) +Assertions enabled. @code{Pragma Assert} and @code{pragma Debug} to be +activated. Note that these pragmas can also be controlled using the +configuration pragmas @code{Assertion_Policy} and @code{Debug_Policy}. +It also activates pragmas @code{Check}, @code{Precondition}, and +@code{Postcondition}. Note that these pragmas can also be controlled +using the configuration pragma @code{Check_Policy}. + +@item -gnatA +@cindex @option{-gnatA} (@command{gcc}) +Avoid processing @file{gnat.adc}. If a @file{gnat.adc} file is present, +it will be ignored. + +@item -gnatb +@cindex @option{-gnatb} (@command{gcc}) +Generate brief messages to @file{stderr} even if verbose mode set. + +@item -gnatB +@cindex @option{-gnatB} (@command{gcc}) +Assume no invalid (bad) values except for 'Valid attribute use +(@pxref{Validity Checking}). + +@item -gnatc +@cindex @option{-gnatc} (@command{gcc}) +Check syntax and semantics only (no code generation attempted). + +@item -gnatC +@cindex @option{-gnatC} (@command{gcc}) +Generate CodePeer information (no code generation attempted). +This switch will generate an intermediate representation suitable for +use by CodePeer (@file{.scil} files). This switch is not compatible with +code generation (it will, among other things, disable some switches such +as -gnatn, and enable others such as -gnata). + +@item -gnatd +@cindex @option{-gnatd} (@command{gcc}) +Specify debug options for the compiler. The string of characters after +the @option{-gnatd} specify the specific debug options. The possible +characters are 0-9, a-z, A-Z, optionally preceded by a dot. See +compiler source file @file{debug.adb} for details of the implemented +debug options. Certain debug options are relevant to applications +programmers, and these are documented at appropriate points in this +users guide. + +@ifclear vms +@item -gnatD +@cindex @option{-gnatD[nn]} (@command{gcc}) +@end ifclear +@ifset vms +@item /XDEBUG /LXDEBUG=nnn +@end ifset +Create expanded source files for source level debugging. This switch +also suppress generation of cross-reference information +(see @option{-gnatx}). + +@item -gnatec=@var{path} +@cindex @option{-gnatec} (@command{gcc}) +Specify a configuration pragma file +@ifclear vms +(the equal sign is optional) +@end ifclear +(@pxref{The Configuration Pragmas Files}). + +@item ^-gnateD^/DATA_PREPROCESSING=^symbol@r{[}=@var{value}@r{]} +@cindex @option{-gnateD} (@command{gcc}) +Defines a symbol, associated with @var{value}, for preprocessing. +(@pxref{Integrated Preprocessing}). + +@item -gnateE +@cindex @option{-gnateE} (@command{gcc}) +Generate extra information in exception messages, in particular display +extra column information and the value and range associated with index and +range check failures, and extra column information for access checks. + +@item -gnatef +@cindex @option{-gnatef} (@command{gcc}) +Display full source path name in brief error messages. + +@item -gnateG +@cindex @option{-gnateG} (@command{gcc}) +Save result of preprocessing in a text file. + +@item -gnatem=@var{path} +@cindex @option{-gnatem} (@command{gcc}) +Specify a mapping file +@ifclear vms +(the equal sign is optional) +@end ifclear +(@pxref{Units to Sources Mapping Files}). + +@item -gnatep=@var{file} +@cindex @option{-gnatep} (@command{gcc}) +Specify a preprocessing data file +@ifclear vms +(the equal sign is optional) +@end ifclear +(@pxref{Integrated Preprocessing}). + +@item -gnateP +@cindex @option{-gnateP} (@command{gcc}) +Turn categorization dependency errors into warnings. +Ada requires that units that WITH one another have compatible categories, for +example a Pure unit cannto WITH a Preelaborate unit. If this switch is used, +these errors become warnings (which can be ignored, or suppressed in the usual +manner). This can be useful in some specialized circumstances such as the +temporary use of special test software. +@item -gnateS +@cindex @option{-gnateS} (@command{gcc}) +Generate SCO (Source Coverage Obligation) information in the ALI +file. This information is used by advanced coverage tools. See +unit @file{SCOs} in the compiler sources for details in files +@file{scos.ads} and @file{scos.adb}. + +@item -gnatE +@cindex @option{-gnatE} (@command{gcc}) +Full dynamic elaboration checks. + +@item -gnatf +@cindex @option{-gnatf} (@command{gcc}) +Full errors. Multiple errors per line, all undefined references, do not +attempt to suppress cascaded errors. + +@item -gnatF +@cindex @option{-gnatF} (@command{gcc}) +Externals names are folded to all uppercase. + +@item ^-gnatg^/GNAT_INTERNAL^ +@cindex @option{^-gnatg^/GNAT_INTERNAL^} (@command{gcc}) +Internal GNAT implementation mode. This should not be used for +applications programs, it is intended only for use by the compiler +and its run-time library. For documentation, see the GNAT sources. +Note that @option{^-gnatg^/GNAT_INTERNAL^} implies +@option{^-gnatwae^/WARNINGS=ALL,ERRORS^} and +@option{^-gnatyg^/STYLE_CHECKS=GNAT^} +so that all standard warnings and all standard style options are turned on. +All warnings and style messages are treated as errors. + +@ifclear vms +@item -gnatG=nn +@cindex @option{-gnatG[nn]} (@command{gcc}) +@end ifclear +@ifset vms +@item /EXPAND_SOURCE, /LEXPAND_SOURCE=nnn +@end ifset +List generated expanded code in source form. + +@item ^-gnath^/HELP^ +@cindex @option{^-gnath^/HELP^} (@command{gcc}) +Output usage information. The output is written to @file{stdout}. + +@item ^-gnati^/IDENTIFIER_CHARACTER_SET=^@var{c} +@cindex @option{^-gnati^/IDENTIFIER_CHARACTER_SET^} (@command{gcc}) +Identifier character set +@ifclear vms +(@var{c}=1/2/3/4/8/9/p/f/n/w). +@end ifclear +For details of the possible selections for @var{c}, +see @ref{Character Set Control}. + +@item ^-gnatI^/IGNORE_REP_CLAUSES^ +@cindex @option{^-gnatI^IGNORE_REP_CLAUSES^} (@command{gcc}) +Ignore representation clauses. When this switch is used, +representation clauses are treated as comments. This is useful +when initially porting code where you want to ignore rep clause +problems, and also for compiling foreign code (particularly +for use with ASIS). The representation clauses that are ignored +are: enumeration_representation_clause, record_representation_clause, +and attribute_definition_clause for the following attributes: +Address, Alignment, Bit_Order, Component_Size, Machine_Radix, +Object_Size, Size, Small, Stream_Size, and Value_Size. +Note that this option should be used only for compiling -- the +code is likely to malfunction at run time. + +@item -gnatjnn +@cindex @option{-gnatjnn} (@command{gcc}) +Reformat error messages to fit on nn character lines + +@item -gnatk=@var{n} +@cindex @option{-gnatk} (@command{gcc}) +Limit file names to @var{n} (1-999) characters ^(@code{k} = krunch)^^. + +@item -gnatl +@cindex @option{-gnatl} (@command{gcc}) +Output full source listing with embedded error messages. + +@item -gnatL +@cindex @option{-gnatL} (@command{gcc}) +Used in conjunction with -gnatG or -gnatD to intersperse original +source lines (as comment lines with line numbers) in the expanded +source output. + +@item -gnatm=@var{n} +@cindex @option{-gnatm} (@command{gcc}) +Limit number of detected error or warning messages to @var{n} +where @var{n} is in the range 1..999999. The default setting if +no switch is given is 9999. If the number of warnings reaches this +limit, then a message is output and further warnings are suppressed, +but the compilation is continued. If the number of error messages +reaches this limit, then a message is output and the compilation +is abandoned. The equal sign here is optional. A value of zero +means that no limit applies. + +@item -gnatn +@cindex @option{-gnatn} (@command{gcc}) +Activate inlining for subprograms for which +pragma @code{Inline} is specified. This inlining is performed +by the GCC back-end. + +@item -gnatN +@cindex @option{-gnatN} (@command{gcc}) +Activate front end inlining for subprograms for which +pragma @code{Inline} is specified. This inlining is performed +by the front end and will be visible in the +@option{-gnatG} output. + +When using a gcc-based back end (in practice this means using any version +of GNAT other than the JGNAT, .NET or GNAAMP versions), then the use of +@option{-gnatN} is deprecated, and the use of @option{-gnatn} is preferred. +Historically front end inlining was more extensive than the gcc back end +inlining, but that is no longer the case. + +@item -gnato +@cindex @option{-gnato} (@command{gcc}) +Enable numeric overflow checking (which is not normally enabled by +default). Note that division by zero is a separate check that is not +controlled by this switch (division by zero checking is on by default). + +@item -gnatp +@cindex @option{-gnatp} (@command{gcc}) +Suppress all checks. See @ref{Run-Time Checks} for details. This switch +has no effect if cancelled by a subsequent @option{-gnat-p} switch. + +@item -gnat-p +@cindex @option{-gnat-p} (@command{gcc}) +Cancel effect of previous @option{-gnatp} switch. + +@item -gnatP +@cindex @option{-gnatP} (@command{gcc}) +Enable polling. This is required on some systems (notably Windows NT) to +obtain asynchronous abort and asynchronous transfer of control capability. +@xref{Pragma Polling,,, gnat_rm, GNAT Reference Manual}, for full +details. + +@item -gnatq +@cindex @option{-gnatq} (@command{gcc}) +Don't quit. Try semantics, even if parse errors. + +@item -gnatQ +@cindex @option{-gnatQ} (@command{gcc}) +Don't quit. Generate @file{ALI} and tree files even if illegalities. + +@item -gnatr +@cindex @option{-gnatr} (@command{gcc}) +Treat pragma Restrictions as Restriction_Warnings. + +@item ^-gnatR@r{[}0@r{/}1@r{/}2@r{/}3@r{[}s@r{]]}^/REPRESENTATION_INFO^ +@cindex @option{-gnatR} (@command{gcc}) +Output representation information for declared types and objects. + +@item -gnats +@cindex @option{-gnats} (@command{gcc}) +Syntax check only. + +@item -gnatS +@cindex @option{-gnatS} (@command{gcc}) +Print package Standard. + +@item -gnatt +@cindex @option{-gnatt} (@command{gcc}) +Generate tree output file. + +@item ^-gnatT^/TABLE_MULTIPLIER=^@var{nnn} +@cindex @option{^-gnatT^/TABLE_MULTIPLIER^} (@command{gcc}) +All compiler tables start at @var{nnn} times usual starting size. + +@item -gnatu +@cindex @option{-gnatu} (@command{gcc}) +List units for this compilation. + +@item -gnatU +@cindex @option{-gnatU} (@command{gcc}) +Tag all error messages with the unique string ``error:'' + +@item -gnatv +@cindex @option{-gnatv} (@command{gcc}) +Verbose mode. Full error output with source lines to @file{stdout}. + +@item -gnatV +@cindex @option{-gnatV} (@command{gcc}) +Control level of validity checking (@pxref{Validity Checking}). + +@item ^-gnatw@var{xxx}^/WARNINGS=(@var{option}@r{[},@dots{}@r{]})^ +@cindex @option{^-gnatw^/WARNINGS^} (@command{gcc}) +Warning mode where +^@var{xxx} is a string of option letters that^the list of options^ denotes +the exact warnings that +are enabled or disabled (@pxref{Warning Message Control}). + +@item ^-gnatW^/WIDE_CHARACTER_ENCODING=^@var{e} +@cindex @option{^-gnatW^/WIDE_CHARACTER_ENCODING^} (@command{gcc}) +Wide character encoding method +@ifclear vms +(@var{e}=n/h/u/s/e/8). +@end ifclear +@ifset vms +(@var{e}=@code{BRACKETS, NONE, HEX, UPPER, SHIFT_JIS, EUC, UTF8}) +@end ifset + +@item -gnatx +@cindex @option{-gnatx} (@command{gcc}) +Suppress generation of cross-reference information. + +@item -gnatX +@cindex @option{-gnatX} (@command{gcc}) +Enable GNAT implementation extensions and latest Ada version. + +@item ^-gnaty^/STYLE_CHECKS=(option,option@dots{})^ +@cindex @option{^-gnaty^/STYLE_CHECKS^} (@command{gcc}) +Enable built-in style checks (@pxref{Style Checking}). + +@item ^-gnatz^/DISTRIBUTION_STUBS=^@var{m} +@cindex @option{^-gnatz^/DISTRIBUTION_STUBS^} (@command{gcc}) +Distribution stub generation and compilation +@ifclear vms +(@var{m}=r/c for receiver/caller stubs). +@end ifclear +@ifset vms +(@var{m}=@code{RECEIVER} or @code{CALLER} to specify the type of stubs +to be generated and compiled). +@end ifset + +@item ^-I^/SEARCH=^@var{dir} +@cindex @option{^-I^/SEARCH^} (@command{gcc}) +@cindex RTL +Direct GNAT to search the @var{dir} directory for source files needed by +the current compilation +(@pxref{Search Paths and the Run-Time Library (RTL)}). + +@item ^-I-^/NOCURRENT_DIRECTORY^ +@cindex @option{^-I-^/NOCURRENT_DIRECTORY^} (@command{gcc}) +@cindex RTL +Except for the source file named in the command line, do not look for source +files in the directory containing the source file named in the command line +(@pxref{Search Paths and the Run-Time Library (RTL)}). + +@ifclear vms +@item -mbig-switch +@cindex @option{-mbig-switch} (@command{gcc}) +@cindex @code{case} statement (effect of @option{-mbig-switch} option) +This standard gcc switch causes the compiler to use larger offsets in its +jump table representation for @code{case} statements. +This may result in less efficient code, but is sometimes necessary +(for example on HP-UX targets) +@cindex HP-UX and @option{-mbig-switch} option +in order to compile large and/or nested @code{case} statements. + +@item -o @var{file} +@cindex @option{-o} (@command{gcc}) +This switch is used in @command{gcc} to redirect the generated object file +and its associated ALI file. Beware of this switch with GNAT, because it may +cause the object file and ALI file to have different names which in turn +may confuse the binder and the linker. +@end ifclear + +@item -nostdinc +@cindex @option{-nostdinc} (@command{gcc}) +Inhibit the search of the default location for the GNAT Run Time +Library (RTL) source files. + +@item -nostdlib +@cindex @option{-nostdlib} (@command{gcc}) +Inhibit the search of the default location for the GNAT Run Time +Library (RTL) ALI files. + +@ifclear vms +@c @item -O@ovar{n} +@c Expanding @ovar macro inline (explanation in macro def comments) +@item -O@r{[}@var{n}@r{]} +@cindex @option{-O} (@command{gcc}) +@var{n} controls the optimization level. + +@table @asis +@item n = 0 +No optimization, the default setting if no @option{-O} appears + +@item n = 1 +Normal optimization, the default if you specify @option{-O} without +an operand. A good compromise between code quality and compilation +time. + +@item n = 2 +Extensive optimization, may improve execution time, possibly at the cost of +substantially increased compilation time. + +@item n = 3 +Same as @option{-O2}, and also includes inline expansion for small subprograms +in the same unit. + +@item n = s +Optimize space usage +@end table + +@noindent +See also @ref{Optimization Levels}. +@end ifclear + +@ifset vms +@item /NOOPTIMIZE +@cindex @option{/NOOPTIMIZE} (@code{GNAT COMPILE}) +Equivalent to @option{/OPTIMIZE=NONE}. +This is the default behavior in the absence of an @option{/OPTIMIZE} +qualifier. + +@item /OPTIMIZE@r{[}=(keyword@r{[},@dots{}@r{]})@r{]} +@cindex @option{/OPTIMIZE} (@code{GNAT COMPILE}) +Selects the level of optimization for your program. The supported +keywords are as follows: +@table @code +@item ALL +Perform most optimizations, including those that +are expensive. +This is the default if the @option{/OPTIMIZE} qualifier is supplied +without keyword options. + +@item NONE +Do not do any optimizations. Same as @code{/NOOPTIMIZE}. + +@item SOME +Perform some optimizations, but omit ones that are costly. + +@item DEVELOPMENT +Same as @code{SOME}. + +@item INLINING +Full optimization as in @option{/OPTIMIZE=ALL}, and also attempts +automatic inlining of small subprograms within a unit + +@item UNROLL_LOOPS +Try to unroll loops. This keyword may be specified together with +any keyword above other than @code{NONE}. Loop unrolling +usually, but not always, improves the performance of programs. + +@item SPACE +Optimize space usage +@end table + +@noindent +See also @ref{Optimization Levels}. +@end ifset + +@ifclear vms +@item -pass-exit-codes +@cindex @option{-pass-exit-codes} (@command{gcc}) +Catch exit codes from the compiler and use the most meaningful as +exit status. +@end ifclear + +@item --RTS=@var{rts-path} +@cindex @option{--RTS} (@command{gcc}) +Specifies the default location of the runtime library. Same meaning as the +equivalent @command{gnatmake} flag (@pxref{Switches for gnatmake}). + +@item ^-S^/ASM^ +@cindex @option{^-S^/ASM^} (@command{gcc}) +^Used in place of @option{-c} to^Used to^ +cause the assembler source file to be +generated, using @file{^.s^.S^} as the extension, +instead of the object file. +This may be useful if you need to examine the generated assembly code. + +@item ^-fverbose-asm^/VERBOSE_ASM^ +@cindex @option{^-fverbose-asm^/VERBOSE_ASM^} (@command{gcc}) +^Used in conjunction with @option{-S}^Used in place of @option{/ASM}^ +to cause the generated assembly code file to be annotated with variable +names, making it significantly easier to follow. + +@item ^-v^/VERBOSE^ +@cindex @option{^-v^/VERBOSE^} (@command{gcc}) +Show commands generated by the @command{gcc} driver. Normally used only for +debugging purposes or if you need to be sure what version of the +compiler you are executing. + +@ifclear vms +@item -V @var{ver} +@cindex @option{-V} (@command{gcc}) +Execute @var{ver} version of the compiler. This is the @command{gcc} +version, not the GNAT version. +@end ifclear + +@item ^-w^/NO_BACK_END_WARNINGS^ +@cindex @option{-w} (@command{gcc}) +Turn off warnings generated by the back end of the compiler. Use of +this switch also causes the default for front end warnings to be set +to suppress (as though @option{-gnatws} had appeared at the start of +the options). + +@end table + +@ifclear vms +@c Combining qualifiers does not work on VMS +You may combine a sequence of GNAT switches into a single switch. For +example, the combined switch + +@cindex Combining GNAT switches +@smallexample +-gnatofi3 +@end smallexample + +@noindent +is equivalent to specifying the following sequence of switches: + +@smallexample +-gnato -gnatf -gnati3 +@end smallexample +@end ifclear + +@noindent +The following restrictions apply to the combination of switches +in this manner: + +@itemize @bullet +@item +The switch @option{-gnatc} if combined with other switches must come +first in the string. + +@item +The switch @option{-gnats} if combined with other switches must come +first in the string. + +@item +The switches +^^@option{/DISTRIBUTION_STUBS=},^ +@option{-gnatzc} and @option{-gnatzr} may not be combined with any other +switches, and only one of them may appear in the command line. + +@item +The switch @option{-gnat-p} may not be combined with any other switch. + +@ifclear vms +@item +Once a ``y'' appears in the string (that is a use of the @option{-gnaty} +switch), then all further characters in the switch are interpreted +as style modifiers (see description of @option{-gnaty}). + +@item +Once a ``d'' appears in the string (that is a use of the @option{-gnatd} +switch), then all further characters in the switch are interpreted +as debug flags (see description of @option{-gnatd}). + +@item +Once a ``w'' appears in the string (that is a use of the @option{-gnatw} +switch), then all further characters in the switch are interpreted +as warning mode modifiers (see description of @option{-gnatw}). + +@item +Once a ``V'' appears in the string (that is a use of the @option{-gnatV} +switch), then all further characters in the switch are interpreted +as validity checking options (@pxref{Validity Checking}). + +@item +Option ``em'', ``ec'', ``ep'', ``l='' and ``R'' must be the last options in +a combined list of options. +@end ifclear +@end itemize + +@node Output and Error Message Control +@subsection Output and Error Message Control +@findex stderr + +@noindent +The standard default format for error messages is called ``brief format''. +Brief format messages are written to @file{stderr} (the standard error +file) and have the following form: + +@smallexample +e.adb:3:04: Incorrect spelling of keyword "function" +e.adb:4:20: ";" should be "is" +@end smallexample + +@noindent +The first integer after the file name is the line number in the file, +and the second integer is the column number within the line. +@ifclear vms +@code{GPS} can parse the error messages +and point to the referenced character. +@end ifclear +The following switches provide control over the error message +format: + +@table @option +@c !sort! +@item -gnatv +@cindex @option{-gnatv} (@command{gcc}) +@findex stdout +@ifclear vms +The v stands for verbose. +@end ifclear +The effect of this setting is to write long-format error +messages to @file{stdout} (the standard output file. +The same program compiled with the +@option{-gnatv} switch would generate: + +@smallexample +@cartouche +3. funcion X (Q : Integer) + | +>>> Incorrect spelling of keyword "function" +4. return Integer; + | +>>> ";" should be "is" +@end cartouche +@end smallexample + +@noindent +The vertical bar indicates the location of the error, and the @samp{>>>} +prefix can be used to search for error messages. When this switch is +used the only source lines output are those with errors. + +@item -gnatl +@cindex @option{-gnatl} (@command{gcc}) +@ifclear vms +The @code{l} stands for list. +@end ifclear +This switch causes a full listing of +the file to be generated. In the case where a body is +compiled, the corresponding spec is also listed, along +with any subunits. Typical output from compiling a package +body @file{p.adb} might look like: + +@smallexample @c ada +@cartouche + Compiling: p.adb + + 1. package body p is + 2. procedure a; + 3. procedure a is separate; + 4. begin + 5. null + | + >>> missing ";" + + 6. end; + +Compiling: p.ads + + 1. package p is + 2. pragma Elaborate_Body + | + >>> missing ";" + + 3. end p; + +Compiling: p-a.adb + + 1. separate p + | + >>> missing "(" + + 2. procedure a is + 3. begin + 4. null + | + >>> missing ";" + + 5. end; +@end cartouche +@end smallexample + +@noindent +@findex stderr +When you specify the @option{-gnatv} or @option{-gnatl} switches and +standard output is redirected, a brief summary is written to +@file{stderr} (standard error) giving the number of error messages and +warning messages generated. + +@item ^-gnatl^/OUTPUT_FILE^=file +@cindex @option{^-gnatl^/OUTPUT_FILE^=fname} (@command{gcc}) +This has the same effect as @option{-gnatl} except that the output is +written to a file instead of to standard output. If the given name +@file{fname} does not start with a period, then it is the full name +of the file to be written. If @file{fname} is an extension, it is +appended to the name of the file being compiled. For example, if +file @file{xyz.adb} is compiled with @option{^-gnatl^/OUTPUT_FILE^=.lst}, +then the output is written to file ^xyz.adb.lst^xyz.adb_lst^. + +@item -gnatU +@cindex @option{-gnatU} (@command{gcc}) +This switch forces all error messages to be preceded by the unique +string ``error:''. This means that error messages take a few more +characters in space, but allows easy searching for and identification +of error messages. + +@item -gnatb +@cindex @option{-gnatb} (@command{gcc}) +@ifclear vms +The @code{b} stands for brief. +@end ifclear +This switch causes GNAT to generate the +brief format error messages to @file{stderr} (the standard error +file) as well as the verbose +format message or full listing (which as usual is written to +@file{stdout} (the standard output file). + +@item -gnatm=@var{n} +@cindex @option{-gnatm} (@command{gcc}) +@ifclear vms +The @code{m} stands for maximum. +@end ifclear +@var{n} is a decimal integer in the +range of 1 to 999999 and limits the number of error or warning +messages to be generated. For example, using +@option{-gnatm2} might yield + +@smallexample +e.adb:3:04: Incorrect spelling of keyword "function" +e.adb:5:35: missing ".." +fatal error: maximum number of errors detected +compilation abandoned +@end smallexample + +@noindent +The default setting if +no switch is given is 9999. If the number of warnings reaches this +limit, then a message is output and further warnings are suppressed, +but the compilation is continued. If the number of error messages +reaches this limit, then a message is output and the compilation +is abandoned. A value of zero means that no limit applies. + +@noindent +Note that the equal sign is optional, so the switches +@option{-gnatm2} and @option{-gnatm=2} are equivalent. + +@item -gnatf +@cindex @option{-gnatf} (@command{gcc}) +@cindex Error messages, suppressing +@ifclear vms +The @code{f} stands for full. +@end ifclear +Normally, the compiler suppresses error messages that are likely to be +redundant. This switch causes all error +messages to be generated. In particular, in the case of +references to undefined variables. If a given variable is referenced +several times, the normal format of messages is +@smallexample +e.adb:7:07: "V" is undefined (more references follow) +@end smallexample + +@noindent +where the parenthetical comment warns that there are additional +references to the variable @code{V}. Compiling the same program with the +@option{-gnatf} switch yields + +@smallexample +e.adb:7:07: "V" is undefined +e.adb:8:07: "V" is undefined +e.adb:8:12: "V" is undefined +e.adb:8:16: "V" is undefined +e.adb:9:07: "V" is undefined +e.adb:9:12: "V" is undefined +@end smallexample + +@noindent +The @option{-gnatf} switch also generates additional information for +some error messages. Some examples are: + +@itemize @bullet +@item +Details on possibly non-portable unchecked conversion +@item +List possible interpretations for ambiguous calls +@item +Additional details on incorrect parameters +@end itemize + +@item -gnatjnn +@cindex @option{-gnatjnn} (@command{gcc}) +In normal operation mode (or if @option{-gnatj0} is used, then error messages +with continuation lines are treated as though the continuation lines were +separate messages (and so a warning with two continuation lines counts as +three warnings, and is listed as three separate messages). + +If the @option{-gnatjnn} switch is used with a positive value for nn, then +messages are output in a different manner. A message and all its continuation +lines are treated as a unit, and count as only one warning or message in the +statistics totals. Furthermore, the message is reformatted so that no line +is longer than nn characters. + +@item -gnatq +@cindex @option{-gnatq} (@command{gcc}) +@ifclear vms +The @code{q} stands for quit (really ``don't quit''). +@end ifclear +In normal operation mode, the compiler first parses the program and +determines if there are any syntax errors. If there are, appropriate +error messages are generated and compilation is immediately terminated. +This switch tells +GNAT to continue with semantic analysis even if syntax errors have been +found. This may enable the detection of more errors in a single run. On +the other hand, the semantic analyzer is more likely to encounter some +internal fatal error when given a syntactically invalid tree. + +@item -gnatQ +@cindex @option{-gnatQ} (@command{gcc}) +In normal operation mode, the @file{ALI} file is not generated if any +illegalities are detected in the program. The use of @option{-gnatQ} forces +generation of the @file{ALI} file. This file is marked as being in +error, so it cannot be used for binding purposes, but it does contain +reasonably complete cross-reference information, and thus may be useful +for use by tools (e.g., semantic browsing tools or integrated development +environments) that are driven from the @file{ALI} file. This switch +implies @option{-gnatq}, since the semantic phase must be run to get a +meaningful ALI file. + +In addition, if @option{-gnatt} is also specified, then the tree file is +generated even if there are illegalities. It may be useful in this case +to also specify @option{-gnatq} to ensure that full semantic processing +occurs. The resulting tree file can be processed by ASIS, for the purpose +of providing partial information about illegal units, but if the error +causes the tree to be badly malformed, then ASIS may crash during the +analysis. + +When @option{-gnatQ} is used and the generated @file{ALI} file is marked as +being in error, @command{gnatmake} will attempt to recompile the source when it +finds such an @file{ALI} file, including with switch @option{-gnatc}. + +Note that @option{-gnatQ} has no effect if @option{-gnats} is specified, +since ALI files are never generated if @option{-gnats} is set. + +@end table + +@node Warning Message Control +@subsection Warning Message Control +@cindex Warning messages +@noindent +In addition to error messages, which correspond to illegalities as defined +in the Ada Reference Manual, the compiler detects two kinds of warning +situations. + +First, the compiler considers some constructs suspicious and generates a +warning message to alert you to a possible error. Second, if the +compiler detects a situation that is sure to raise an exception at +run time, it generates a warning message. The following shows an example +of warning messages: +@smallexample +e.adb:4:24: warning: creation of object may raise Storage_Error +e.adb:10:17: warning: static value out of range +e.adb:10:17: warning: "Constraint_Error" will be raised at run time +@end smallexample + +@noindent +GNAT considers a large number of situations as appropriate +for the generation of warning messages. As always, warnings are not +definite indications of errors. For example, if you do an out-of-range +assignment with the deliberate intention of raising a +@code{Constraint_Error} exception, then the warning that may be +issued does not indicate an error. Some of the situations for which GNAT +issues warnings (at least some of the time) are given in the following +list. This list is not complete, and new warnings are often added to +subsequent versions of GNAT. The list is intended to give a general idea +of the kinds of warnings that are generated. + +@itemize @bullet +@item +Possible infinitely recursive calls + +@item +Out-of-range values being assigned + +@item +Possible order of elaboration problems + +@item +Assertions (pragma Assert) that are sure to fail + +@item +Unreachable code + +@item +Address clauses with possibly unaligned values, or where an attempt is +made to overlay a smaller variable with a larger one. + +@item +Fixed-point type declarations with a null range + +@item +Direct_IO or Sequential_IO instantiated with a type that has access values + +@item +Variables that are never assigned a value + +@item +Variables that are referenced before being initialized + +@item +Task entries with no corresponding @code{accept} statement + +@item +Duplicate accepts for the same task entry in a @code{select} + +@item +Objects that take too much storage + +@item +Unchecked conversion between types of differing sizes + +@item +Missing @code{return} statement along some execution path in a function + +@item +Incorrect (unrecognized) pragmas + +@item +Incorrect external names + +@item +Allocation from empty storage pool + +@item +Potentially blocking operation in protected type + +@item +Suspicious parenthesization of expressions + +@item +Mismatching bounds in an aggregate + +@item +Attempt to return local value by reference + +@item +Premature instantiation of a generic body + +@item +Attempt to pack aliased components + +@item +Out of bounds array subscripts + +@item +Wrong length on string assignment + +@item +Violations of style rules if style checking is enabled + +@item +Unused @code{with} clauses + +@item +@code{Bit_Order} usage that does not have any effect + +@item +@code{Standard.Duration} used to resolve universal fixed expression + +@item +Dereference of possibly null value + +@item +Declaration that is likely to cause storage error + +@item +Internal GNAT unit @code{with}'ed by application unit + +@item +Values known to be out of range at compile time + +@item +Unreferenced labels and variables + +@item +Address overlays that could clobber memory + +@item +Unexpected initialization when address clause present + +@item +Bad alignment for address clause + +@item +Useless type conversions + +@item +Redundant assignment statements and other redundant constructs + +@item +Useless exception handlers + +@item +Accidental hiding of name by child unit + +@item +Access before elaboration detected at compile time + +@item +A range in a @code{for} loop that is known to be null or might be null + +@end itemize + +@noindent +The following section lists compiler switches that are available +to control the handling of warning messages. It is also possible +to exercise much finer control over what warnings are issued and +suppressed using the GNAT pragma Warnings, @xref{Pragma Warnings,,, +gnat_rm, GNAT Reference manual}. + +@table @option +@c !sort! +@item -gnatwa +@emph{Activate most optional warnings.} +@cindex @option{-gnatwa} (@command{gcc}) +This switch activates most optional warning messages. See the remaining list +in this section for details on optional warning messages that can be +individually controlled. The warnings that are not turned on by this +switch are +@option{-gnatwd} (implicit dereferencing), +@option{-gnatwh} (hiding), +@option{-gnatw.h} (holes (gaps) in record layouts) +@option{-gnatwl} (elaboration warnings), +@option{-gnatw.o} (warn on values set by out parameters ignored) +and @option{-gnatwt} (tracking of deleted conditional code). +All other optional warnings are turned on. + +@item -gnatwA +@emph{Suppress all optional errors.} +@cindex @option{-gnatwA} (@command{gcc}) +This switch suppresses all optional warning messages, see remaining list +in this section for details on optional warning messages that can be +individually controlled. + +@item -gnatw.a +@emph{Activate warnings on failing assertions.} +@cindex @option{-gnatw.a} (@command{gcc}) +@cindex Assert failures +This switch activates warnings for assertions where the compiler can tell at +compile time that the assertion will fail. Note that this warning is given +even if assertions are disabled. The default is that such warnings are +generated. + +@item -gnatw.A +@emph{Suppress warnings on failing assertions.} +@cindex @option{-gnatw.A} (@command{gcc}) +@cindex Assert failures +This switch suppresses warnings for assertions where the compiler can tell at +compile time that the assertion will fail. + +@item -gnatwb +@emph{Activate warnings on bad fixed values.} +@cindex @option{-gnatwb} (@command{gcc}) +@cindex Bad fixed values +@cindex Fixed-point Small value +@cindex Small value +This switch activates warnings for static fixed-point expressions whose +value is not an exact multiple of Small. Such values are implementation +dependent, since an implementation is free to choose either of the multiples +that surround the value. GNAT always chooses the closer one, but this is not +required behavior, and it is better to specify a value that is an exact +multiple, ensuring predictable execution. The default is that such warnings +are not generated. + +@item -gnatwB +@emph{Suppress warnings on bad fixed values.} +@cindex @option{-gnatwB} (@command{gcc}) +This switch suppresses warnings for static fixed-point expressions whose +value is not an exact multiple of Small. + +@item -gnatw.b +@emph{Activate warnings on biased representation.} +@cindex @option{-gnatw.b} (@command{gcc}) +@cindex Biased representation +This switch activates warnings when a size clause, value size clause, component +clause, or component size clause forces the use of biased representation for an +integer type (e.g. representing a range of 10..11 in a single bit by using 0/1 +to represent 10/11). The default is that such warnings are generated. + +@item -gnatw.B +@emph{Suppress warnings on biased representation.} +@cindex @option{-gnatwB} (@command{gcc}) +This switch suppresses warnings for representation clauses that force the use +of biased representation. + +@item -gnatwc +@emph{Activate warnings on conditionals.} +@cindex @option{-gnatwc} (@command{gcc}) +@cindex Conditionals, constant +This switch activates warnings for conditional expressions used in +tests that are known to be True or False at compile time. The default +is that such warnings are not generated. +Note that this warning does +not get issued for the use of boolean variables or constants whose +values are known at compile time, since this is a standard technique +for conditional compilation in Ada, and this would generate too many +false positive warnings. + +This warning option also activates a special test for comparisons using +the operators ``>='' and`` <=''. +If the compiler can tell that only the equality condition is possible, +then it will warn that the ``>'' or ``<'' part of the test +is useless and that the operator could be replaced by ``=''. +An example would be comparing a @code{Natural} variable <= 0. + +This warning option also generates warnings if +one or both tests is optimized away in a membership test for integer +values if the result can be determined at compile time. Range tests on +enumeration types are not included, since it is common for such tests +to include an end point. + +This warning can also be turned on using @option{-gnatwa}. + +@item -gnatwC +@emph{Suppress warnings on conditionals.} +@cindex @option{-gnatwC} (@command{gcc}) +This switch suppresses warnings for conditional expressions used in +tests that are known to be True or False at compile time. + +@item -gnatw.c +@emph{Activate warnings on missing component clauses.} +@cindex @option{-gnatw.c} (@command{gcc}) +@cindex Component clause, missing +This switch activates warnings for record components where a record +representation clause is present and has component clauses for the +majority, but not all, of the components. A warning is given for each +component for which no component clause is present. + +This warning can also be turned on using @option{-gnatwa}. + +@item -gnatw.C +@emph{Suppress warnings on missing component clauses.} +@cindex @option{-gnatwC} (@command{gcc}) +This switch suppresses warnings for record components that are +missing a component clause in the situation described above. + +@item -gnatwd +@emph{Activate warnings on implicit dereferencing.} +@cindex @option{-gnatwd} (@command{gcc}) +If this switch is set, then the use of a prefix of an access type +in an indexed component, slice, or selected component without an +explicit @code{.all} will generate a warning. With this warning +enabled, access checks occur only at points where an explicit +@code{.all} appears in the source code (assuming no warnings are +generated as a result of this switch). The default is that such +warnings are not generated. +Note that @option{-gnatwa} does not affect the setting of +this warning option. + +@item -gnatwD +@emph{Suppress warnings on implicit dereferencing.} +@cindex @option{-gnatwD} (@command{gcc}) +@cindex Implicit dereferencing +@cindex Dereferencing, implicit +This switch suppresses warnings for implicit dereferences in +indexed components, slices, and selected components. + +@item -gnatwe +@emph{Treat warnings and style checks as errors.} +@cindex @option{-gnatwe} (@command{gcc}) +@cindex Warnings, treat as error +This switch causes warning messages and style check messages to be +treated as errors. +The warning string still appears, but the warning messages are counted +as errors, and prevent the generation of an object file. Note that this +is the only -gnatw switch that affects the handling of style check messages. + +@item -gnatw.e +@emph{Activate every optional warning} +@cindex @option{-gnatw.e} (@command{gcc}) +@cindex Warnings, activate every optional warning +This switch activates all optional warnings, including those which +are not activated by @code{-gnatwa}. + +@item -gnatwf +@emph{Activate warnings on unreferenced formals.} +@cindex @option{-gnatwf} (@command{gcc}) +@cindex Formals, unreferenced +This switch causes a warning to be generated if a formal parameter +is not referenced in the body of the subprogram. This warning can +also be turned on using @option{-gnatwa} or @option{-gnatwu}. The +default is that these warnings are not generated. + +@item -gnatwF +@emph{Suppress warnings on unreferenced formals.} +@cindex @option{-gnatwF} (@command{gcc}) +This switch suppresses warnings for unreferenced formal +parameters. Note that the +combination @option{-gnatwu} followed by @option{-gnatwF} has the +effect of warning on unreferenced entities other than subprogram +formals. + +@item -gnatwg +@emph{Activate warnings on unrecognized pragmas.} +@cindex @option{-gnatwg} (@command{gcc}) +@cindex Pragmas, unrecognized +This switch causes a warning to be generated if an unrecognized +pragma is encountered. Apart from issuing this warning, the +pragma is ignored and has no effect. This warning can +also be turned on using @option{-gnatwa}. The default +is that such warnings are issued (satisfying the Ada Reference +Manual requirement that such warnings appear). + +@item -gnatwG +@emph{Suppress warnings on unrecognized pragmas.} +@cindex @option{-gnatwG} (@command{gcc}) +This switch suppresses warnings for unrecognized pragmas. + +@item -gnatwh +@emph{Activate warnings on hiding.} +@cindex @option{-gnatwh} (@command{gcc}) +@cindex Hiding of Declarations +This switch activates warnings on hiding declarations. +A declaration is considered hiding +if it is for a non-overloadable entity, and it declares an entity with the +same name as some other entity that is directly or use-visible. The default +is that such warnings are not generated. +Note that @option{-gnatwa} does not affect the setting of this warning option. + +@item -gnatwH +@emph{Suppress warnings on hiding.} +@cindex @option{-gnatwH} (@command{gcc}) +This switch suppresses warnings on hiding declarations. + +@item -gnatw.h +@emph{Activate warnings on holes/gaps in records.} +@cindex @option{-gnatw.h} (@command{gcc}) +@cindex Record Representation (gaps) +This switch activates warnings on component clauses in record +representation clauses that leave holes (gaps) in the record layout. +If this warning option is active, then record representation clauses +should specify a contiguous layout, adding unused fill fields if needed. +Note that @option{-gnatwa} does not affect the setting of this warning option. + +@item -gnatw.H +@emph{Suppress warnings on holes/gaps in records.} +@cindex @option{-gnatw.H} (@command{gcc}) +This switch suppresses warnings on component clauses in record +representation clauses that leave holes (haps) in the record layout. + +@item -gnatwi +@emph{Activate warnings on implementation units.} +@cindex @option{-gnatwi} (@command{gcc}) +This switch activates warnings for a @code{with} of an internal GNAT +implementation unit, defined as any unit from the @code{Ada}, +@code{Interfaces}, @code{GNAT}, +^^@code{DEC},^ or @code{System} +hierarchies that is not +documented in either the Ada Reference Manual or the GNAT +Programmer's Reference Manual. Such units are intended only +for internal implementation purposes and should not be @code{with}'ed +by user programs. The default is that such warnings are generated +This warning can also be turned on using @option{-gnatwa}. + +@item -gnatwI +@emph{Disable warnings on implementation units.} +@cindex @option{-gnatwI} (@command{gcc}) +This switch disables warnings for a @code{with} of an internal GNAT +implementation unit. + +@item -gnatw.i +@emph{Activate warnings on overlapping actuals.} +@cindex @option{-gnatw.i} (@command{gcc}) +This switch enables a warning on statically detectable overlapping actuals in +a subprogram call, when one of the actuals is an in-out parameter, and the +types of the actuals are not by-copy types. The warning is off by default, +and is not included under -gnatwa. + +@item -gnatw.I +@emph{Disable warnings on overlapping actuals.} +@cindex @option{-gnatw.I} (@command{gcc}) +This switch disables warnings on overlapping actuals in a call.. + +@item -gnatwj +@emph{Activate warnings on obsolescent features (Annex J).} +@cindex @option{-gnatwj} (@command{gcc}) +@cindex Features, obsolescent +@cindex Obsolescent features +If this warning option is activated, then warnings are generated for +calls to subprograms marked with @code{pragma Obsolescent} and +for use of features in Annex J of the Ada Reference Manual. In the +case of Annex J, not all features are flagged. In particular use +of the renamed packages (like @code{Text_IO}) and use of package +@code{ASCII} are not flagged, since these are very common and +would generate many annoying positive warnings. The default is that +such warnings are not generated. This warning is also turned on by +the use of @option{-gnatwa}. + +In addition to the above cases, warnings are also generated for +GNAT features that have been provided in past versions but which +have been superseded (typically by features in the new Ada standard). +For example, @code{pragma Ravenscar} will be flagged since its +function is replaced by @code{pragma Profile(Ravenscar)}. + +Note that this warning option functions differently from the +restriction @code{No_Obsolescent_Features} in two respects. +First, the restriction applies only to annex J features. +Second, the restriction does flag uses of package @code{ASCII}. + +@item -gnatwJ +@emph{Suppress warnings on obsolescent features (Annex J).} +@cindex @option{-gnatwJ} (@command{gcc}) +This switch disables warnings on use of obsolescent features. + +@item -gnatwk +@emph{Activate warnings on variables that could be constants.} +@cindex @option{-gnatwk} (@command{gcc}) +This switch activates warnings for variables that are initialized but +never modified, and then could be declared constants. The default is that +such warnings are not given. +This warning can also be turned on using @option{-gnatwa}. + +@item -gnatwK +@emph{Suppress warnings on variables that could be constants.} +@cindex @option{-gnatwK} (@command{gcc}) +This switch disables warnings on variables that could be declared constants. + +@item -gnatwl +@emph{Activate warnings for elaboration pragmas.} +@cindex @option{-gnatwl} (@command{gcc}) +@cindex Elaboration, warnings +This switch activates warnings on missing +@code{Elaborate_All} and @code{Elaborate} pragmas. +See the section in this guide on elaboration checking for details on +when such pragmas should be used. In dynamic elaboration mode, this switch +generations warnings about the need to add elaboration pragmas. Note however, +that if you blindly follow these warnings, and add @code{Elaborate_All} +warnings wherever they are recommended, you basically end up with the +equivalent of the static elaboration model, which may not be what you want for +legacy code for which the static model does not work. + +For the static model, the messages generated are labeled "info:" (for +information messages). They are not warnings to add elaboration pragmas, +merely informational messages showing what implicit elaboration pragmas +have been added, for use in analyzing elaboration circularity problems. + +Warnings are also generated if you +are using the static mode of elaboration, and a @code{pragma Elaborate} +is encountered. The default is that such warnings +are not generated. +This warning is not automatically turned on by the use of @option{-gnatwa}. + +@item -gnatwL +@emph{Suppress warnings for elaboration pragmas.} +@cindex @option{-gnatwL} (@command{gcc}) +This switch suppresses warnings on missing Elaborate and Elaborate_All pragmas. +See the section in this guide on elaboration checking for details on +when such pragmas should be used. + +@item -gnatwm +@emph{Activate warnings on modified but unreferenced variables.} +@cindex @option{-gnatwm} (@command{gcc}) +This switch activates warnings for variables that are assigned (using +an initialization value or with one or more assignment statements) but +whose value is never read. The warning is suppressed for volatile +variables and also for variables that are renamings of other variables +or for which an address clause is given. +This warning can also be turned on using @option{-gnatwa}. +The default is that these warnings are not given. + +@item -gnatwM +@emph{Disable warnings on modified but unreferenced variables.} +@cindex @option{-gnatwM} (@command{gcc}) +This switch disables warnings for variables that are assigned or +initialized, but never read. + +@item -gnatw.m +@emph{Activate warnings on suspicious modulus values.} +@cindex @option{-gnatw.m} (@command{gcc}) +This switch activates warnings for modulus values that seem suspicious. +The cases caught are where the size is the same as the modulus (e.g. +a modulus of 7 with a size of 7 bits), and modulus values of 32 or 64 +with no size clause. The guess in both cases is that 2**x was intended +rather than x. The default is that these warnings are given. + +@item -gnatw.M +@emph{Disable warnings on suspicious modulus values.} +@cindex @option{-gnatw.M} (@command{gcc}) +This switch disables warnings for suspicious modulus values. + +@item -gnatwn +@emph{Set normal warnings mode.} +@cindex @option{-gnatwn} (@command{gcc}) +This switch sets normal warning mode, in which enabled warnings are +issued and treated as warnings rather than errors. This is the default +mode. the switch @option{-gnatwn} can be used to cancel the effect of +an explicit @option{-gnatws} or +@option{-gnatwe}. It also cancels the effect of the +implicit @option{-gnatwe} that is activated by the +use of @option{-gnatg}. + +@item -gnatwo +@emph{Activate warnings on address clause overlays.} +@cindex @option{-gnatwo} (@command{gcc}) +@cindex Address Clauses, warnings +This switch activates warnings for possibly unintended initialization +effects of defining address clauses that cause one variable to overlap +another. The default is that such warnings are generated. +This warning can also be turned on using @option{-gnatwa}. + +@item -gnatwO +@emph{Suppress warnings on address clause overlays.} +@cindex @option{-gnatwO} (@command{gcc}) +This switch suppresses warnings on possibly unintended initialization +effects of defining address clauses that cause one variable to overlap +another. + +@item -gnatw.o +@emph{Activate warnings on modified but unreferenced out parameters.} +@cindex @option{-gnatw.o} (@command{gcc}) +This switch activates warnings for variables that are modified by using +them as actuals for a call to a procedure with an out mode formal, where +the resulting assigned value is never read. It is applicable in the case +where there is more than one out mode formal. If there is only one out +mode formal, the warning is issued by default (controlled by -gnatwu). +The warning is suppressed for volatile +variables and also for variables that are renamings of other variables +or for which an address clause is given. +The default is that these warnings are not given. Note that this warning +is not included in -gnatwa, it must be activated explicitly. + +@item -gnatw.O +@emph{Disable warnings on modified but unreferenced out parameters.} +@cindex @option{-gnatw.O} (@command{gcc}) +This switch suppresses warnings for variables that are modified by using +them as actuals for a call to a procedure with an out mode formal, where +the resulting assigned value is never read. + +@item -gnatwp +@emph{Activate warnings on ineffective pragma Inlines.} +@cindex @option{-gnatwp} (@command{gcc}) +@cindex Inlining, warnings +This switch activates warnings for failure of front end inlining +(activated by @option{-gnatN}) to inline a particular call. There are +many reasons for not being able to inline a call, including most +commonly that the call is too complex to inline. The default is +that such warnings are not given. +This warning can also be turned on using @option{-gnatwa}. +Warnings on ineffective inlining by the gcc back-end can be activated +separately, using the gcc switch -Winline. + +@item -gnatwP +@emph{Suppress warnings on ineffective pragma Inlines.} +@cindex @option{-gnatwP} (@command{gcc}) +This switch suppresses warnings on ineffective pragma Inlines. If the +inlining mechanism cannot inline a call, it will simply ignore the +request silently. + +@item -gnatw.p +@emph{Activate warnings on parameter ordering.} +@cindex @option{-gnatw.p} (@command{gcc}) +@cindex Parameter order, warnings +This switch activates warnings for cases of suspicious parameter +ordering when the list of arguments are all simple identifiers that +match the names of the formals, but are in a different order. The +warning is suppressed if any use of named parameter notation is used, +so this is the appropriate way to suppress a false positive (and +serves to emphasize that the "misordering" is deliberate). The +default is +that such warnings are not given. +This warning can also be turned on using @option{-gnatwa}. + +@item -gnatw.P +@emph{Suppress warnings on parameter ordering.} +@cindex @option{-gnatw.P} (@command{gcc}) +This switch suppresses warnings on cases of suspicious parameter +ordering. + +@item -gnatwq +@emph{Activate warnings on questionable missing parentheses.} +@cindex @option{-gnatwq} (@command{gcc}) +@cindex Parentheses, warnings +This switch activates warnings for cases where parentheses are not used and +the result is potential ambiguity from a readers point of view. For example +(not a > b) when a and b are modular means ((not a) > b) and very likely the +programmer intended (not (a > b)). Similarly (-x mod 5) means (-(x mod 5)) and +quite likely ((-x) mod 5) was intended. In such situations it seems best to +follow the rule of always parenthesizing to make the association clear, and +this warning switch warns if such parentheses are not present. The default +is that these warnings are given. +This warning can also be turned on using @option{-gnatwa}. + +@item -gnatwQ +@emph{Suppress warnings on questionable missing parentheses.} +@cindex @option{-gnatwQ} (@command{gcc}) +This switch suppresses warnings for cases where the association is not +clear and the use of parentheses is preferred. + +@item -gnatwr +@emph{Activate warnings on redundant constructs.} +@cindex @option{-gnatwr} (@command{gcc}) +This switch activates warnings for redundant constructs. The following +is the current list of constructs regarded as redundant: + +@itemize @bullet +@item +Assignment of an item to itself. +@item +Type conversion that converts an expression to its own type. +@item +Use of the attribute @code{Base} where @code{typ'Base} is the same +as @code{typ}. +@item +Use of pragma @code{Pack} when all components are placed by a record +representation clause. +@item +Exception handler containing only a reraise statement (raise with no +operand) which has no effect. +@item +Use of the operator abs on an operand that is known at compile time +to be non-negative +@item +Comparison of boolean expressions to an explicit True value. +@end itemize + +This warning can also be turned on using @option{-gnatwa}. +The default is that warnings for redundant constructs are not given. + +@item -gnatwR +@emph{Suppress warnings on redundant constructs.} +@cindex @option{-gnatwR} (@command{gcc}) +This switch suppresses warnings for redundant constructs. + +@item -gnatw.r +@emph{Activate warnings for object renaming function.} +@cindex @option{-gnatw.r} (@command{gcc}) +This switch activates warnings for an object renaming that renames a +function call, which is equivalent to a constant declaration (as +opposed to renaming the function itself). The default is that these +warnings are given. This warning can also be turned on using +@option{-gnatwa}. + +@item -gnatw.R +@emph{Suppress warnings for object renaming function.} +@cindex @option{-gnatwT} (@command{gcc}) +This switch suppresses warnings for object renaming function. + +@item -gnatws +@emph{Suppress all warnings.} +@cindex @option{-gnatws} (@command{gcc}) +This switch completely suppresses the +output of all warning messages from the GNAT front end. +Note that it does not suppress warnings from the @command{gcc} back end. +To suppress these back end warnings as well, use the switch @option{-w} +in addition to @option{-gnatws}. Also this switch has no effect on the +handling of style check messages. + +@item -gnatw.s +@emph{Activate warnings on overridden size clauses.} +@cindex @option{-gnatw.s} (@command{gcc}) +@cindex Record Representation (component sizes) +This switch activates warnings on component clauses in record +representation clauses where the length given overrides that +specified by an explicit size clause for the component type. A +warning is similarly given in the array case if a specified +component size overrides an explicit size clause for the array +component type. +Note that @option{-gnatwa} does not affect the setting of this warning option. + +@item -gnatw.S +@emph{Suppress warnings on overridden size clauses.} +@cindex @option{-gnatw.S} (@command{gcc}) +This switch suppresses warnings on component clauses in record +representation clauses that override size clauses, and similar +warnings when an array component size overrides a size clause. + +@item -gnatwt +@emph{Activate warnings for tracking of deleted conditional code.} +@cindex @option{-gnatwt} (@command{gcc}) +@cindex Deactivated code, warnings +@cindex Deleted code, warnings +This switch activates warnings for tracking of code in conditionals (IF and +CASE statements) that is detected to be dead code which cannot be executed, and +which is removed by the front end. This warning is off by default, and is not +turned on by @option{-gnatwa}, it has to be turned on explicitly. This may be +useful for detecting deactivated code in certified applications. + +@item -gnatwT +@emph{Suppress warnings for tracking of deleted conditional code.} +@cindex @option{-gnatwT} (@command{gcc}) +This switch suppresses warnings for tracking of deleted conditional code. + +@item -gnatwu +@emph{Activate warnings on unused entities.} +@cindex @option{-gnatwu} (@command{gcc}) +This switch activates warnings to be generated for entities that +are declared but not referenced, and for units that are @code{with}'ed +and not +referenced. In the case of packages, a warning is also generated if +no entities in the package are referenced. This means that if the package +is referenced but the only references are in @code{use} +clauses or @code{renames} +declarations, a warning is still generated. A warning is also generated +for a generic package that is @code{with}'ed but never instantiated. +In the case where a package or subprogram body is compiled, and there +is a @code{with} on the corresponding spec +that is only referenced in the body, +a warning is also generated, noting that the +@code{with} can be moved to the body. The default is that +such warnings are not generated. +This switch also activates warnings on unreferenced formals +(it includes the effect of @option{-gnatwf}). +This warning can also be turned on using @option{-gnatwa}. + +@item -gnatwU +@emph{Suppress warnings on unused entities.} +@cindex @option{-gnatwU} (@command{gcc}) +This switch suppresses warnings for unused entities and packages. +It also turns off warnings on unreferenced formals (and thus includes +the effect of @option{-gnatwF}). + +@item -gnatw.u +@emph{Activate warnings on unordered enumeration types.} +@cindex @option{-gnatw.u} (@command{gcc}) +This switch causes enumeration types to be considered as conceptually +unordered, unless an explicit pragma @code{Ordered} is given for the type. +The effect is to generate warnings in clients that use explicit comparisons +or subranges, since these constructs both treat objects of the type as +ordered. (A @emph{client} is defined as a unit that is other than the unit in +which the type is declared, or its body or subunits.) Please refer to +the description of pragma @code{Ordered} in the +@cite{@value{EDITION} Reference Manual} for further details. + +@item -gnatw.U +@emph{Deactivate warnings on unordered enumeration types.} +@cindex @option{-gnatw.U} (@command{gcc}) +This switch causes all enumeration types to be considered as ordered, so +that no warnings are given for comparisons or subranges for any type. + +@item -gnatwv +@emph{Activate warnings on unassigned variables.} +@cindex @option{-gnatwv} (@command{gcc}) +@cindex Unassigned variable warnings +This switch activates warnings for access to variables which +may not be properly initialized. The default is that +such warnings are generated. +This warning can also be turned on using @option{-gnatwa}. + +@item -gnatwV +@emph{Suppress warnings on unassigned variables.} +@cindex @option{-gnatwV} (@command{gcc}) +This switch suppresses warnings for access to variables which +may not be properly initialized. +For variables of a composite type, the warning can also be suppressed in +Ada 2005 by using a default initialization with a box. For example, if +Table is an array of records whose components are only partially uninitialized, +then the following code: + +@smallexample @c ada + Tab : Table := (others => <>); +@end smallexample + +will suppress warnings on subsequent statements that access components +of variable Tab. + +@item -gnatww +@emph{Activate warnings on wrong low bound assumption.} +@cindex @option{-gnatww} (@command{gcc}) +@cindex String indexing warnings +This switch activates warnings for indexing an unconstrained string parameter +with a literal or S'Length. This is a case where the code is assuming that the +low bound is one, which is in general not true (for example when a slice is +passed). The default is that such warnings are generated. +This warning can also be turned on using @option{-gnatwa}. + +@item -gnatwW +@emph{Suppress warnings on wrong low bound assumption.} +@cindex @option{-gnatwW} (@command{gcc}) +This switch suppresses warnings for indexing an unconstrained string parameter +with a literal or S'Length. Note that this warning can also be suppressed +in a particular case by adding an +assertion that the lower bound is 1, +as shown in the following example. + +@smallexample @c ada + procedure K (S : String) is + pragma Assert (S'First = 1); + @dots{} +@end smallexample + +@item -gnatw.w +@emph{Activate warnings on unnecessary Warnings Off pragmas} +@cindex @option{-gnatw.w} (@command{gcc}) +@cindex Warnings Off control +This switch activates warnings for use of @code{pragma Warnings (Off, entity} +where either the pragma is entirely useless (because it suppresses no +warnings), or it could be replaced by @code{pragma Unreferenced} or +@code{pragma Unmodified}.The default is that these warnings are not given. +Note that this warning is not included in -gnatwa, it must be +activated explicitly. + +@item -gnatw.W +@emph{Suppress warnings on unnecessary Warnings Off pragmas} +@cindex @option{-gnatw.W} (@command{gcc}) +This switch suppresses warnings for use of @code{pragma Warnings (Off, entity}. + +@item -gnatwx +@emph{Activate warnings on Export/Import pragmas.} +@cindex @option{-gnatwx} (@command{gcc}) +@cindex Export/Import pragma warnings +This switch activates warnings on Export/Import pragmas when +the compiler detects a possible conflict between the Ada and +foreign language calling sequences. For example, the use of +default parameters in a convention C procedure is dubious +because the C compiler cannot supply the proper default, so +a warning is issued. The default is that such warnings are +generated. +This warning can also be turned on using @option{-gnatwa}. + +@item -gnatwX +@emph{Suppress warnings on Export/Import pragmas.} +@cindex @option{-gnatwX} (@command{gcc}) +This switch suppresses warnings on Export/Import pragmas. +The sense of this is that you are telling the compiler that +you know what you are doing in writing the pragma, and it +should not complain at you. + +@item -gnatw.x +@emph{Activate warnings for No_Exception_Propagation mode.} +@cindex @option{-gnatwm} (@command{gcc}) +This switch activates warnings for exception usage when pragma Restrictions +(No_Exception_Propagation) is in effect. Warnings are given for implicit or +explicit exception raises which are not covered by a local handler, and for +exception handlers which do not cover a local raise. The default is that these +warnings are not given. + +@item -gnatw.X +@emph{Disable warnings for No_Exception_Propagation mode.} +This switch disables warnings for exception usage when pragma Restrictions +(No_Exception_Propagation) is in effect. + +@item -gnatwy +@emph{Activate warnings for Ada 2005 compatibility issues.} +@cindex @option{-gnatwy} (@command{gcc}) +@cindex Ada 2005 compatibility issues warnings +For the most part Ada 2005 is upwards compatible with Ada 95, +but there are some exceptions (for example the fact that +@code{interface} is now a reserved word in Ada 2005). This +switch activates several warnings to help in identifying +and correcting such incompatibilities. The default is that +these warnings are generated. Note that at one point Ada 2005 +was called Ada 0Y, hence the choice of character. +This warning can also be turned on using @option{-gnatwa}. + +@item -gnatwY +@emph{Disable warnings for Ada 2005 compatibility issues.} +@cindex @option{-gnatwY} (@command{gcc}) +@cindex Ada 2005 compatibility issues warnings +This switch suppresses several warnings intended to help in identifying +incompatibilities between Ada 95 and Ada 2005. + +@item -gnatwz +@emph{Activate warnings on unchecked conversions.} +@cindex @option{-gnatwz} (@command{gcc}) +@cindex Unchecked_Conversion warnings +This switch activates warnings for unchecked conversions +where the types are known at compile time to have different +sizes. The default +is that such warnings are generated. Warnings are also +generated for subprogram pointers with different conventions, +and, on VMS only, for data pointers with different conventions. +This warning can also be turned on using @option{-gnatwa}. + +@item -gnatwZ +@emph{Suppress warnings on unchecked conversions.} +@cindex @option{-gnatwZ} (@command{gcc}) +This switch suppresses warnings for unchecked conversions +where the types are known at compile time to have different +sizes or conventions. + +@item ^-Wunused^WARNINGS=UNUSED^ +@cindex @option{-Wunused} +The warnings controlled by the @option{-gnatw} switch are generated by +the front end of the compiler. The @option{GCC} back end can provide +additional warnings and they are controlled by the @option{-W} switch. +For example, @option{^-Wunused^WARNINGS=UNUSED^} activates back end +warnings for entities that are declared but not referenced. + +@item ^-Wuninitialized^WARNINGS=UNINITIALIZED^ +@cindex @option{-Wuninitialized} +Similarly, @option{^-Wuninitialized^WARNINGS=UNINITIALIZED^} activates +the back end warning for uninitialized variables. This switch must be +used in conjunction with an optimization level greater than zero. + +@item ^-Wall^/ALL_BACK_END_WARNINGS^ +@cindex @option{-Wall} +This switch enables all the above warnings from the @option{GCC} back end. +The code generator detects a number of warning situations that are missed +by the @option{GNAT} front end, and this switch can be used to activate them. +The use of this switch also sets the default front end warning mode to +@option{-gnatwa}, that is, most front end warnings activated as well. + +@item ^-w^/NO_BACK_END_WARNINGS^ +@cindex @option{-w} +Conversely, this switch suppresses warnings from the @option{GCC} back end. +The use of this switch also sets the default front end warning mode to +@option{-gnatws}, that is, front end warnings suppressed as well. + +@end table + +@noindent +@ifclear vms +A string of warning parameters can be used in the same parameter. For example: + +@smallexample +-gnatwaLe +@end smallexample + +@noindent +will turn on all optional warnings except for elaboration pragma warnings, +and also specify that warnings should be treated as errors. +@end ifclear +When no switch @option{^-gnatw^/WARNINGS^} is used, this is equivalent to: + +@table @option +@c !sort! +@item -gnatwC +@item -gnatwD +@item -gnatwF +@item -gnatwg +@item -gnatwH +@item -gnatwi +@item -gnatwJ +@item -gnatwK +@item -gnatwL +@item -gnatwM +@item -gnatwn +@item -gnatwo +@item -gnatwP +@item -gnatwR +@item -gnatwU +@item -gnatwv +@item -gnatwz +@item -gnatwx + +@end table + +@node Debugging and Assertion Control +@subsection Debugging and Assertion Control + +@table @option +@item -gnata +@cindex @option{-gnata} (@command{gcc}) +@findex Assert +@findex Debug +@cindex Assertions + +@noindent +The pragmas @code{Assert} and @code{Debug} normally have no effect and +are ignored. This switch, where @samp{a} stands for assert, causes +@code{Assert} and @code{Debug} pragmas to be activated. + +The pragmas have the form: + +@smallexample +@cartouche + @b{pragma} Assert (@var{Boolean-expression} @r{[}, + @var{static-string-expression}@r{]}) + @b{pragma} Debug (@var{procedure call}) +@end cartouche +@end smallexample + +@noindent +The @code{Assert} pragma causes @var{Boolean-expression} to be tested. +If the result is @code{True}, the pragma has no effect (other than +possible side effects from evaluating the expression). If the result is +@code{False}, the exception @code{Assert_Failure} declared in the package +@code{System.Assertions} is +raised (passing @var{static-string-expression}, if present, as the +message associated with the exception). If no string expression is +given the default is a string giving the file name and line number +of the pragma. + +The @code{Debug} pragma causes @var{procedure} to be called. Note that +@code{pragma Debug} may appear within a declaration sequence, allowing +debugging procedures to be called between declarations. + +@ifset vms +@item /DEBUG@r{[}=debug-level@r{]} +@itemx /NODEBUG +Specifies how much debugging information is to be included in +the resulting object file where 'debug-level' is one of the following: +@table @code +@item TRACEBACK +Include both debugger symbol records and traceback +the object file. +This is the default setting. +@item ALL +Include both debugger symbol records and traceback in +object file. +@item NONE +Excludes both debugger symbol records and traceback +the object file. Same as /NODEBUG. +@item SYMBOLS +Includes only debugger symbol records in the object +file. Note that this doesn't include traceback information. +@end table +@end ifset +@end table + +@node Validity Checking +@subsection Validity Checking +@findex Validity Checking + +@noindent +The Ada Reference Manual defines the concept of invalid values (see +RM 13.9.1). The primary source of invalid values is uninitialized +variables. A scalar variable that is left uninitialized may contain +an invalid value; the concept of invalid does not apply to access or +composite types. + +It is an error to read an invalid value, but the RM does not require +run-time checks to detect such errors, except for some minimal +checking to prevent erroneous execution (i.e. unpredictable +behavior). This corresponds to the @option{-gnatVd} switch below, +which is the default. For example, by default, if the expression of a +case statement is invalid, it will raise Constraint_Error rather than +causing a wild jump, and if an array index on the left-hand side of an +assignment is invalid, it will raise Constraint_Error rather than +overwriting an arbitrary memory location. + +The @option{-gnatVa} may be used to enable additional validity checks, +which are not required by the RM. These checks are often very +expensive (which is why the RM does not require them). These checks +are useful in tracking down uninitialized variables, but they are +not usually recommended for production builds. + +The other @option{-gnatV^@var{x}^^} switches below allow finer-grained +control; you can enable whichever validity checks you desire. However, +for most debugging purposes, @option{-gnatVa} is sufficient, and the +default @option{-gnatVd} (i.e. standard Ada behavior) is usually +sufficient for non-debugging use. + +The @option{-gnatB} switch tells the compiler to assume that all +values are valid (that is, within their declared subtype range) +except in the context of a use of the Valid attribute. This means +the compiler can generate more efficient code, since the range +of values is better known at compile time. However, an uninitialized +variable can cause wild jumps and memory corruption in this mode. + +The @option{-gnatV^@var{x}^^} switch allows control over the validity +checking mode as described below. +@ifclear vms +The @code{x} argument is a string of letters that +indicate validity checks that are performed or not performed in addition +to the default checks required by Ada as described above. +@end ifclear +@ifset vms +The options allowed for this qualifier +indicate validity checks that are performed or not performed in addition +to the default checks required by Ada as described above. +@end ifset + +@table @option +@c !sort! +@item -gnatVa +@emph{All validity checks.} +@cindex @option{-gnatVa} (@command{gcc}) +All validity checks are turned on. +@ifclear vms +That is, @option{-gnatVa} is +equivalent to @option{gnatVcdfimorst}. +@end ifclear + +@item -gnatVc +@emph{Validity checks for copies.} +@cindex @option{-gnatVc} (@command{gcc}) +The right hand side of assignments, and the initializing values of +object declarations are validity checked. + +@item -gnatVd +@emph{Default (RM) validity checks.} +@cindex @option{-gnatVd} (@command{gcc}) +Some validity checks are done by default following normal Ada semantics +(RM 13.9.1 (9-11)). +A check is done in case statements that the expression is within the range +of the subtype. If it is not, Constraint_Error is raised. +For assignments to array components, a check is done that the expression used +as index is within the range. If it is not, Constraint_Error is raised. +Both these validity checks may be turned off using switch @option{-gnatVD}. +They are turned on by default. If @option{-gnatVD} is specified, a subsequent +switch @option{-gnatVd} will leave the checks turned on. +Switch @option{-gnatVD} should be used only if you are sure that all such +expressions have valid values. If you use this switch and invalid values +are present, then the program is erroneous, and wild jumps or memory +overwriting may occur. + +@item -gnatVe +@emph{Validity checks for elementary components.} +@cindex @option{-gnatVe} (@command{gcc}) +In the absence of this switch, assignments to record or array components are +not validity checked, even if validity checks for assignments generally +(@option{-gnatVc}) are turned on. In Ada, assignment of composite values do not +require valid data, but assignment of individual components does. So for +example, there is a difference between copying the elements of an array with a +slice assignment, compared to assigning element by element in a loop. This +switch allows you to turn off validity checking for components, even when they +are assigned component by component. + +@item -gnatVf +@emph{Validity checks for floating-point values.} +@cindex @option{-gnatVf} (@command{gcc}) +In the absence of this switch, validity checking occurs only for discrete +values. If @option{-gnatVf} is specified, then validity checking also applies +for floating-point values, and NaNs and infinities are considered invalid, +as well as out of range values for constrained types. Note that this means +that standard IEEE infinity mode is not allowed. The exact contexts +in which floating-point values are checked depends on the setting of other +options. For example, +@option{^-gnatVif^VALIDITY_CHECKING=(IN_PARAMS,FLOATS)^} or +@option{^-gnatVfi^VALIDITY_CHECKING=(FLOATS,IN_PARAMS)^} +(the order does not matter) specifies that floating-point parameters of mode +@code{in} should be validity checked. + +@item -gnatVi +@emph{Validity checks for @code{in} mode parameters} +@cindex @option{-gnatVi} (@command{gcc}) +Arguments for parameters of mode @code{in} are validity checked in function +and procedure calls at the point of call. + +@item -gnatVm +@emph{Validity checks for @code{in out} mode parameters.} +@cindex @option{-gnatVm} (@command{gcc}) +Arguments for parameters of mode @code{in out} are validity checked in +procedure calls at the point of call. The @code{'m'} here stands for +modify, since this concerns parameters that can be modified by the call. +Note that there is no specific option to test @code{out} parameters, +but any reference within the subprogram will be tested in the usual +manner, and if an invalid value is copied back, any reference to it +will be subject to validity checking. + +@item -gnatVn +@emph{No validity checks.} +@cindex @option{-gnatVn} (@command{gcc}) +This switch turns off all validity checking, including the default checking +for case statements and left hand side subscripts. Note that the use of +the switch @option{-gnatp} suppresses all run-time checks, including +validity checks, and thus implies @option{-gnatVn}. When this switch +is used, it cancels any other @option{-gnatV} previously issued. + +@item -gnatVo +@emph{Validity checks for operator and attribute operands.} +@cindex @option{-gnatVo} (@command{gcc}) +Arguments for predefined operators and attributes are validity checked. +This includes all operators in package @code{Standard}, +the shift operators defined as intrinsic in package @code{Interfaces} +and operands for attributes such as @code{Pos}. Checks are also made +on individual component values for composite comparisons, and on the +expressions in type conversions and qualified expressions. Checks are +also made on explicit ranges using @samp{..} (e.g.@: slices, loops etc). + +@item -gnatVp +@emph{Validity checks for parameters.} +@cindex @option{-gnatVp} (@command{gcc}) +This controls the treatment of parameters within a subprogram (as opposed +to @option{-gnatVi} and @option{-gnatVm} which control validity testing +of parameters on a call. If either of these call options is used, then +normally an assumption is made within a subprogram that the input arguments +have been validity checking at the point of call, and do not need checking +again within a subprogram). If @option{-gnatVp} is set, then this assumption +is not made, and parameters are not assumed to be valid, so their validity +will be checked (or rechecked) within the subprogram. + +@item -gnatVr +@emph{Validity checks for function returns.} +@cindex @option{-gnatVr} (@command{gcc}) +The expression in @code{return} statements in functions is validity +checked. + +@item -gnatVs +@emph{Validity checks for subscripts.} +@cindex @option{-gnatVs} (@command{gcc}) +All subscripts expressions are checked for validity, whether they appear +on the right side or left side (in default mode only left side subscripts +are validity checked). + +@item -gnatVt +@emph{Validity checks for tests.} +@cindex @option{-gnatVt} (@command{gcc}) +Expressions used as conditions in @code{if}, @code{while} or @code{exit} +statements are checked, as well as guard expressions in entry calls. + +@end table + +@noindent +The @option{-gnatV} switch may be followed by +^a string of letters^a list of options^ +to turn on a series of validity checking options. +For example, +@option{^-gnatVcr^/VALIDITY_CHECKING=(COPIES, RETURNS)^} +specifies that in addition to the default validity checking, copies and +function return expressions are to be validity checked. +In order to make it easier +to specify the desired combination of effects, +@ifclear vms +the upper case letters @code{CDFIMORST} may +be used to turn off the corresponding lower case option. +@end ifclear +@ifset vms +the prefix @code{NO} on an option turns off the corresponding validity +checking: +@itemize @bullet +@item @code{NOCOPIES} +@item @code{NODEFAULT} +@item @code{NOFLOATS} +@item @code{NOIN_PARAMS} +@item @code{NOMOD_PARAMS} +@item @code{NOOPERANDS} +@item @code{NORETURNS} +@item @code{NOSUBSCRIPTS} +@item @code{NOTESTS} +@end itemize +@end ifset +Thus +@option{^-gnatVaM^/VALIDITY_CHECKING=(ALL, NOMOD_PARAMS)^} +turns on all validity checking options except for +checking of @code{@b{in out}} procedure arguments. + +The specification of additional validity checking generates extra code (and +in the case of @option{-gnatVa} the code expansion can be substantial). +However, these additional checks can be very useful in detecting +uninitialized variables, incorrect use of unchecked conversion, and other +errors leading to invalid values. The use of pragma @code{Initialize_Scalars} +is useful in conjunction with the extra validity checking, since this +ensures that wherever possible uninitialized variables have invalid values. + +See also the pragma @code{Validity_Checks} which allows modification of +the validity checking mode at the program source level, and also allows for +temporary disabling of validity checks. + +@node Style Checking +@subsection Style Checking +@findex Style checking + +@noindent +The @option{-gnaty^x^(option,option,@dots{})^} switch +@cindex @option{-gnaty} (@command{gcc}) +causes the compiler to +enforce specified style rules. A limited set of style rules has been used +in writing the GNAT sources themselves. This switch allows user programs +to activate all or some of these checks. If the source program fails a +specified style check, an appropriate message is given, preceded by +the character sequence ``(style)''. This message does not prevent +successful compilation (unless the @option{-gnatwe} switch is used). + +Note that this is by no means intended to be a general facility for +checking arbitrary coding standards. It is simply an embedding of the +style rules we have chosen for the GNAT sources. If you are starting +a project which does not have established style standards, you may +find it useful to adopt the entire set of GNAT coding standards, or +some subset of them. If you already have an established set of coding +standards, then it may be that selected style checking options do +indeed correspond to choices you have made, but for general checking +of an existing set of coding rules, you should look to the gnatcheck +tool, which is designed for that purpose. + +@ifset vms +@code{(option,option,@dots{})} is a sequence of keywords +@end ifset +@ifclear vms +The string @var{x} is a sequence of letters or digits +@end ifclear +indicating the particular style +checks to be performed. The following checks are defined: + +@table @option +@c !sort! +@item 0-9 +@emph{Specify indentation level.} +If a digit from 1-9 appears +^in the string after @option{-gnaty}^as an option for /STYLE_CHECKS^ +then proper indentation is checked, with the digit indicating the +indentation level required. A value of zero turns off this style check. +The general style of required indentation is as specified by +the examples in the Ada Reference Manual. Full line comments must be +aligned with the @code{--} starting on a column that is a multiple of +the alignment level, or they may be aligned the same way as the following +non-blank line (this is useful when full line comments appear in the middle +of a statement. + +@item ^a^ATTRIBUTE^ +@emph{Check attribute casing.} +Attribute names, including the case of keywords such as @code{digits} +used as attributes names, must be written in mixed case, that is, the +initial letter and any letter following an underscore must be uppercase. +All other letters must be lowercase. + +@item ^A^ARRAY_INDEXES^ +@emph{Use of array index numbers in array attributes.} +When using the array attributes First, Last, Range, +or Length, the index number must be omitted for one-dimensional arrays +and is required for multi-dimensional arrays. + +@item ^b^BLANKS^ +@emph{Blanks not allowed at statement end.} +Trailing blanks are not allowed at the end of statements. The purpose of this +rule, together with h (no horizontal tabs), is to enforce a canonical format +for the use of blanks to separate source tokens. + +@item ^B^BOOLEAN_OPERATORS^ +@emph{Check Boolean operators.} +The use of AND/OR operators is not permitted except in the cases of modular +operands, array operands, and simple stand-alone boolean variables or +boolean constants. In all other cases AND THEN/OR ELSE are required. + +@item ^c^COMMENTS^ +@emph{Check comments.} +Comments must meet the following set of rules: + +@itemize @bullet + +@item +The ``@code{--}'' that starts the column must either start in column one, +or else at least one blank must precede this sequence. + +@item +Comments that follow other tokens on a line must have at least one blank +following the ``@code{--}'' at the start of the comment. + +@item +Full line comments must have at least two blanks following the +``@code{--}'' that starts the comment, with the following exceptions. + +@item +A line consisting only of the ``@code{--}'' characters, possibly preceded +by blanks is permitted. + +@item +A comment starting with ``@code{--x}'' where @code{x} is a special character +is permitted. +This allows proper processing of the output generated by specialized tools +including @command{gnatprep} (where ``@code{--!}'' is used) and the SPARK +annotation +language (where ``@code{--#}'' is used). For the purposes of this rule, a +special character is defined as being in one of the ASCII ranges +@code{16#21#@dots{}16#2F#} or @code{16#3A#@dots{}16#3F#}. +Note that this usage is not permitted +in GNAT implementation units (i.e., when @option{-gnatg} is used). + +@item +A line consisting entirely of minus signs, possibly preceded by blanks, is +permitted. This allows the construction of box comments where lines of minus +signs are used to form the top and bottom of the box. + +@item +A comment that starts and ends with ``@code{--}'' is permitted as long as at +least one blank follows the initial ``@code{--}''. Together with the preceding +rule, this allows the construction of box comments, as shown in the following +example: +@smallexample +--------------------------- +-- This is a box comment -- +-- with two text lines. -- +--------------------------- +@end smallexample +@end itemize + +@item ^d^DOS_LINE_ENDINGS^ +@emph{Check no DOS line terminators present.} +All lines must be terminated by a single ASCII.LF +character (in particular the DOS line terminator sequence CR/LF is not +allowed). + +@item ^e^END^ +@emph{Check end/exit labels.} +Optional labels on @code{end} statements ending subprograms and on +@code{exit} statements exiting named loops, are required to be present. + +@item ^f^VTABS^ +@emph{No form feeds or vertical tabs.} +Neither form feeds nor vertical tab characters are permitted +in the source text. + +@item ^g^GNAT^ +@emph{GNAT style mode} +The set of style check switches is set to match that used by the GNAT sources. +This may be useful when developing code that is eventually intended to be +incorporated into GNAT. For further details, see GNAT sources. + +@item ^h^HTABS^ +@emph{No horizontal tabs.} +Horizontal tab characters are not permitted in the source text. +Together with the b (no blanks at end of line) check, this +enforces a canonical form for the use of blanks to separate +source tokens. + +@item ^i^IF_THEN^ +@emph{Check if-then layout.} +The keyword @code{then} must appear either on the same +line as corresponding @code{if}, or on a line on its own, lined +up under the @code{if} with at least one non-blank line in between +containing all or part of the condition to be tested. + +@item ^I^IN_MODE^ +@emph{check mode IN keywords} +Mode @code{in} (the default mode) is not +allowed to be given explicitly. @code{in out} is fine, +but not @code{in} on its own. + +@item ^k^KEYWORD^ +@emph{Check keyword casing.} +All keywords must be in lower case (with the exception of keywords +such as @code{digits} used as attribute names to which this check +does not apply). + +@item ^l^LAYOUT^ +@emph{Check layout.} +Layout of statement and declaration constructs must follow the +recommendations in the Ada Reference Manual, as indicated by the +form of the syntax rules. For example an @code{else} keyword must +be lined up with the corresponding @code{if} keyword. + +There are two respects in which the style rule enforced by this check +option are more liberal than those in the Ada Reference Manual. First +in the case of record declarations, it is permissible to put the +@code{record} keyword on the same line as the @code{type} keyword, and +then the @code{end} in @code{end record} must line up under @code{type}. +This is also permitted when the type declaration is split on two lines. +For example, any of the following three layouts is acceptable: + +@smallexample @c ada +@cartouche +type q is record + a : integer; + b : integer; +end record; + +type q is + record + a : integer; + b : integer; + end record; + +type q is + record + a : integer; + b : integer; +end record; + +@end cartouche +@end smallexample + +@noindent +Second, in the case of a block statement, a permitted alternative +is to put the block label on the same line as the @code{declare} or +@code{begin} keyword, and then line the @code{end} keyword up under +the block label. For example both the following are permitted: + +@smallexample @c ada +@cartouche +Block : declare + A : Integer := 3; +begin + Proc (A, A); +end Block; + +Block : + declare + A : Integer := 3; + begin + Proc (A, A); + end Block; +@end cartouche +@end smallexample + +@noindent +The same alternative format is allowed for loops. For example, both of +the following are permitted: + +@smallexample @c ada +@cartouche +Clear : while J < 10 loop + A (J) := 0; +end loop Clear; + +Clear : + while J < 10 loop + A (J) := 0; + end loop Clear; +@end cartouche +@end smallexample + +@item ^Lnnn^MAX_NESTING=nnn^ +@emph{Set maximum nesting level} +The maximum level of nesting of constructs (including subprograms, loops, +blocks, packages, and conditionals) may not exceed the given value +@option{nnn}. A value of zero disconnects this style check. + +@item ^m^LINE_LENGTH^ +@emph{Check maximum line length.} +The length of source lines must not exceed 79 characters, including +any trailing blanks. The value of 79 allows convenient display on an +80 character wide device or window, allowing for possible special +treatment of 80 character lines. Note that this count is of +characters in the source text. This means that a tab character counts +as one character in this count but a wide character sequence counts as +a single character (however many bytes are needed in the encoding). + +@item ^Mnnn^MAX_LENGTH=nnn^ +@emph{Set maximum line length.} +The length of lines must not exceed the +given value @option{nnn}. The maximum value that can be specified is 32767. + +@item ^n^STANDARD_CASING^ +@emph{Check casing of entities in Standard.} +Any identifier from Standard must be cased +to match the presentation in the Ada Reference Manual (for example, +@code{Integer} and @code{ASCII.NUL}). + +@item ^N^NONE^ +@emph{Turn off all style checks} +All style check options are turned off. + +@item ^o^ORDERED_SUBPROGRAMS^ +@emph{Check order of subprogram bodies.} +All subprogram bodies in a given scope +(e.g.@: a package body) must be in alphabetical order. The ordering +rule uses normal Ada rules for comparing strings, ignoring casing +of letters, except that if there is a trailing numeric suffix, then +the value of this suffix is used in the ordering (e.g.@: Junk2 comes +before Junk10). + +@item ^O^OVERRIDING_INDICATORS^ +@emph{Check that overriding subprograms are explicitly marked as such.} +The declaration of a primitive operation of a type extension that overrides +an inherited operation must carry an overriding indicator. + +@item ^p^PRAGMA^ +@emph{Check pragma casing.} +Pragma names must be written in mixed case, that is, the +initial letter and any letter following an underscore must be uppercase. +All other letters must be lowercase. + +@item ^r^REFERENCES^ +@emph{Check references.} +All identifier references must be cased in the same way as the +corresponding declaration. No specific casing style is imposed on +identifiers. The only requirement is for consistency of references +with declarations. + +@item ^S^STATEMENTS_AFTER_THEN_ELSE^ +@emph{Check no statements after THEN/ELSE.} +No statements are allowed +on the same line as a THEN or ELSE keyword following the +keyword in an IF statement. OR ELSE and AND THEN are not affected, +and a special exception allows a pragma to appear after ELSE. + +@item ^s^SPECS^ +@emph{Check separate specs.} +Separate declarations (``specs'') are required for subprograms (a +body is not allowed to serve as its own declaration). The only +exception is that parameterless library level procedures are +not required to have a separate declaration. This exception covers +the most frequent form of main program procedures. + +@item ^t^TOKEN^ +@emph{Check token spacing.} +The following token spacing rules are enforced: + +@itemize @bullet + +@item +The keywords @code{@b{abs}} and @code{@b{not}} must be followed by a space. + +@item +The token @code{=>} must be surrounded by spaces. + +@item +The token @code{<>} must be preceded by a space or a left parenthesis. + +@item +Binary operators other than @code{**} must be surrounded by spaces. +There is no restriction on the layout of the @code{**} binary operator. + +@item +Colon must be surrounded by spaces. + +@item +Colon-equal (assignment, initialization) must be surrounded by spaces. + +@item +Comma must be the first non-blank character on the line, or be +immediately preceded by a non-blank character, and must be followed +by a space. + +@item +If the token preceding a left parenthesis ends with a letter or digit, then +a space must separate the two tokens. + +@item +if the token following a right parenthesis starts with a letter or digit, then +a space must separate the two tokens. + +@item +A right parenthesis must either be the first non-blank character on +a line, or it must be preceded by a non-blank character. + +@item +A semicolon must not be preceded by a space, and must not be followed by +a non-blank character. + +@item +A unary plus or minus may not be followed by a space. + +@item +A vertical bar must be surrounded by spaces. +@end itemize + +@item ^u^UNNECESSARY_BLANK_LINES^ +@emph{Check unnecessary blank lines.} +Unnecessary blank lines are not allowed. A blank line is considered +unnecessary if it appears at the end of the file, or if more than +one blank line occurs in sequence. + +@item ^x^XTRA_PARENS^ +@emph{Check extra parentheses.} +Unnecessary extra level of parentheses (C-style) are not allowed +around conditions in @code{if} statements, @code{while} statements and +@code{exit} statements. + +@item ^y^ALL_BUILTIN^ +@emph{Set all standard style check options} +This is equivalent to @code{gnaty3aAbcefhiklmnprst}, that is all checking +options enabled with the exception of @option{-gnatyo}, @option{-gnatyI}, +@option{-gnatyS}, @option{-gnatyLnnn}, +@option{-gnatyd}, @option{-gnatyu}, and @option{-gnatyx}. + +@ifclear vms +@item - +@emph{Remove style check options} +This causes any subsequent options in the string to act as canceling the +corresponding style check option. To cancel maximum nesting level control, +use @option{L} parameter witout any integer value after that, because any +digit following @option{-} in the parameter string of the @option{-gnaty} +option will be threated as canceling indentation check. The same is true +for @option{M} parameter. @option{y} and @option{N} parameters are not +allowed after @option{-}. + +@item + +This causes any subsequent options in the string to enable the corresponding +style check option. That is, it cancels the effect of a previous ^-^REMOVE^, +if any. +@end ifclear + +@ifset vms +@item NOxxx +@emph{Removing style check options} +If the name of a style check is preceded by @option{NO} then the corresponding +style check is turned off. For example @option{NOCOMMENTS} turns off style +checking for comments. +@end ifset +@end table + +@noindent +In the above rules, appearing in column one is always permitted, that is, +counts as meeting either a requirement for a required preceding space, +or as meeting a requirement for no preceding space. + +Appearing at the end of a line is also always permitted, that is, counts +as meeting either a requirement for a following space, or as meeting +a requirement for no following space. + +@noindent +If any of these style rules is violated, a message is generated giving +details on the violation. The initial characters of such messages are +always ``@code{(style)}''. Note that these messages are treated as warning +messages, so they normally do not prevent the generation of an object +file. The @option{-gnatwe} switch can be used to treat warning messages, +including style messages, as fatal errors. + +The switch +@ifclear vms +@option{-gnaty} on its own (that is not +followed by any letters or digits), then the effect is equivalent +to the use of @option{-gnatyy}, as described above, that is all +built-in standard style check options are enabled. + +@end ifclear +@ifset vms +/STYLE_CHECKS=ALL_BUILTIN enables all checking options with +the exception of ORDERED_SUBPROGRAMS, UNNECESSARY_BLANK_LINES, +XTRA_PARENS, and DOS_LINE_ENDINGS. In addition +@end ifset + +The switch +@ifclear vms +@option{-gnatyN} +@end ifclear +@ifset vms +/STYLE_CHECKS=NONE +@end ifset +clears any previously set style checks. + +@node Run-Time Checks +@subsection Run-Time Checks +@cindex Division by zero +@cindex Access before elaboration +@cindex Checks, division by zero +@cindex Checks, access before elaboration +@cindex Checks, stack overflow checking + +@noindent +By default, the following checks are suppressed: integer overflow +checks, stack overflow checks, and checks for access before +elaboration on subprogram calls. All other checks, including range +checks and array bounds checks, are turned on by default. The +following @command{gcc} switches refine this default behavior. + +@table @option +@c !sort! +@item -gnatp +@cindex @option{-gnatp} (@command{gcc}) +@cindex Suppressing checks +@cindex Checks, suppressing +@findex Suppress +This switch causes the unit to be compiled +as though @code{pragma Suppress (All_checks)} +had been present in the source. Validity checks are also eliminated (in +other words @option{-gnatp} also implies @option{-gnatVn}. +Use this switch to improve the performance +of the code at the expense of safety in the presence of invalid data or +program bugs. + +Note that when checks are suppressed, the compiler is allowed, but not +required, to omit the checking code. If the run-time cost of the +checking code is zero or near-zero, the compiler will generate it even +if checks are suppressed. In particular, if the compiler can prove +that a certain check will necessarily fail, it will generate code to +do an unconditional ``raise'', even if checks are suppressed. The +compiler warns in this case. Another case in which checks may not be +eliminated is when they are embedded in certain run time routines such +as math library routines. + +Of course, run-time checks are omitted whenever the compiler can prove +that they will not fail, whether or not checks are suppressed. + +Note that if you suppress a check that would have failed, program +execution is erroneous, which means the behavior is totally +unpredictable. The program might crash, or print wrong answers, or +do anything else. It might even do exactly what you wanted it to do +(and then it might start failing mysteriously next week or next +year). The compiler will generate code based on the assumption that +the condition being checked is true, which can result in disaster if +that assumption is wrong. + +The @option{-gnatp} switch has no effect if a subsequent +@option{-gnat-p} switch appears. + +@item -gnat-p +@cindex @option{-gnat-p} (@command{gcc}) +@cindex Suppressing checks +@cindex Checks, suppressing +@findex Suppress +This switch cancels the effect of a previous @option{gnatp} switch. + +@item -gnato +@cindex @option{-gnato} (@command{gcc}) +@cindex Overflow checks +@cindex Check, overflow +Enables overflow checking for integer operations. +This causes GNAT to generate slower and larger executable +programs by adding code to check for overflow (resulting in raising +@code{Constraint_Error} as required by standard Ada +semantics). These overflow checks correspond to situations in which +the true value of the result of an operation may be outside the base +range of the result type. The following example shows the distinction: + +@smallexample @c ada +X1 : Integer := "Integer'Last"; +X2 : Integer range 1 .. 5 := "5"; +X3 : Integer := "Integer'Last"; +X4 : Integer range 1 .. 5 := "5"; +F : Float := "2.0E+20"; +@dots{} +X1 := X1 + 1; +X2 := X2 + 1; +X3 := Integer (F); +X4 := Integer (F); +@end smallexample + +@noindent +Note that if explicit values are assigned at compile time, the +compiler may be able to detect overflow at compile time, in which case +no actual run-time checking code is required, and Constraint_Error +will be raised unconditionally, with or without +@option{-gnato}. That's why the assigned values in the above fragment +are in quotes, the meaning is "assign a value not known to the +compiler that happens to be equal to ...". The remaining discussion +assumes that the compiler cannot detect the values at compile time. + +Here the first addition results in a value that is outside the base range +of Integer, and hence requires an overflow check for detection of the +constraint error. Thus the first assignment to @code{X1} raises a +@code{Constraint_Error} exception only if @option{-gnato} is set. + +The second increment operation results in a violation of the explicit +range constraint; such range checks are performed by default, and are +unaffected by @option{-gnato}. + +The two conversions of @code{F} both result in values that are outside +the base range of type @code{Integer} and thus will raise +@code{Constraint_Error} exceptions only if @option{-gnato} is used. +The fact that the result of the second conversion is assigned to +variable @code{X4} with a restricted range is irrelevant, since the problem +is in the conversion, not the assignment. + +Basically the rule is that in the default mode (@option{-gnato} not +used), the generated code assures that all integer variables stay +within their declared ranges, or within the base range if there is +no declared range. This prevents any serious problems like indexes +out of range for array operations. + +What is not checked in default mode is an overflow that results in +an in-range, but incorrect value. In the above example, the assignments +to @code{X1}, @code{X2}, @code{X3} all give results that are within the +range of the target variable, but the result is wrong in the sense that +it is too large to be represented correctly. Typically the assignment +to @code{X1} will result in wrap around to the largest negative number. +The conversions of @code{F} will result in some @code{Integer} value +and if that integer value is out of the @code{X4} range then the +subsequent assignment would generate an exception. + +@findex Machine_Overflows +Note that the @option{-gnato} switch does not affect the code generated +for any floating-point operations; it applies only to integer +semantics). +For floating-point, GNAT has the @code{Machine_Overflows} +attribute set to @code{False} and the normal mode of operation is to +generate IEEE NaN and infinite values on overflow or invalid operations +(such as dividing 0.0 by 0.0). + +The reason that we distinguish overflow checking from other kinds of +range constraint checking is that a failure of an overflow check, unlike +for example the failure of a range check, can result in an incorrect +value, but cannot cause random memory destruction (like an out of range +subscript), or a wild jump (from an out of range case value). Overflow +checking is also quite expensive in time and space, since in general it +requires the use of double length arithmetic. + +Note again that @option{-gnato} is off by default, so overflow checking is +not performed in default mode. This means that out of the box, with the +default settings, GNAT does not do all the checks expected from the +language description in the Ada Reference Manual. If you want all constraint +checks to be performed, as described in this Manual, then you must +explicitly use the -gnato switch either on the @command{gnatmake} or +@command{gcc} command. + +@item -gnatE +@cindex @option{-gnatE} (@command{gcc}) +@cindex Elaboration checks +@cindex Check, elaboration +Enables dynamic checks for access-before-elaboration +on subprogram calls and generic instantiations. +Note that @option{-gnatE} is not necessary for safety, because in the +default mode, GNAT ensures statically that the checks would not fail. +For full details of the effect and use of this switch, +@xref{Compiling Using gcc}. + +@item -fstack-check +@cindex @option{-fstack-check} (@command{gcc}) +@cindex Stack Overflow Checking +@cindex Checks, stack overflow checking +Activates stack overflow checking. For full details of the effect and use of +this switch see @ref{Stack Overflow Checking}. +@end table + +@findex Unsuppress +@noindent +The setting of these switches only controls the default setting of the +checks. You may modify them using either @code{Suppress} (to remove +checks) or @code{Unsuppress} (to add back suppressed checks) pragmas in +the program source. + +@node Using gcc for Syntax Checking +@subsection Using @command{gcc} for Syntax Checking +@table @option +@item -gnats +@cindex @option{-gnats} (@command{gcc}) +@ifclear vms + +@noindent +The @code{s} stands for ``syntax''. +@end ifclear + +Run GNAT in syntax checking only mode. For +example, the command + +@smallexample +$ gcc -c -gnats x.adb +@end smallexample + +@noindent +compiles file @file{x.adb} in syntax-check-only mode. You can check a +series of files in a single command +@ifclear vms +, and can use wild cards to specify such a group of files. +Note that you must specify the @option{-c} (compile +only) flag in addition to the @option{-gnats} flag. +@end ifclear +. +You may use other switches in conjunction with @option{-gnats}. In +particular, @option{-gnatl} and @option{-gnatv} are useful to control the +format of any generated error messages. + +When the source file is empty or contains only empty lines and/or comments, +the output is a warning: + +@smallexample +$ gcc -c -gnats -x ada toto.txt +toto.txt:1:01: warning: empty file, contains no compilation units +$ +@end smallexample + +Otherwise, the output is simply the error messages, if any. No object file or +ALI file is generated by a syntax-only compilation. Also, no units other +than the one specified are accessed. For example, if a unit @code{X} +@code{with}'s a unit @code{Y}, compiling unit @code{X} in syntax +check only mode does not access the source file containing unit +@code{Y}. + +@cindex Multiple units, syntax checking +Normally, GNAT allows only a single unit in a source file. However, this +restriction does not apply in syntax-check-only mode, and it is possible +to check a file containing multiple compilation units concatenated +together. This is primarily used by the @code{gnatchop} utility +(@pxref{Renaming Files Using gnatchop}). +@end table + +@node Using gcc for Semantic Checking +@subsection Using @command{gcc} for Semantic Checking +@table @option +@item -gnatc +@cindex @option{-gnatc} (@command{gcc}) + +@ifclear vms +@noindent +The @code{c} stands for ``check''. +@end ifclear +Causes the compiler to operate in semantic check mode, +with full checking for all illegalities specified in the +Ada Reference Manual, but without generation of any object code +(no object file is generated). + +Because dependent files must be accessed, you must follow the GNAT +semantic restrictions on file structuring to operate in this mode: + +@itemize @bullet +@item +The needed source files must be accessible +(@pxref{Search Paths and the Run-Time Library (RTL)}). + +@item +Each file must contain only one compilation unit. + +@item +The file name and unit name must match (@pxref{File Naming Rules}). +@end itemize + +The output consists of error messages as appropriate. No object file is +generated. An @file{ALI} file is generated for use in the context of +cross-reference tools, but this file is marked as not being suitable +for binding (since no object file is generated). +The checking corresponds exactly to the notion of +legality in the Ada Reference Manual. + +Any unit can be compiled in semantics-checking-only mode, including +units that would not normally be compiled (subunits, +and specifications where a separate body is present). +@end table + +@node Compiling Different Versions of Ada +@subsection Compiling Different Versions of Ada + +@noindent +The switches described in this section allow you to explicitly specify +the version of the Ada language that your programs are written in. +By default @value{EDITION} assumes @value{DEFAULTLANGUAGEVERSION}, +but you can also specify @value{NONDEFAULTLANGUAGEVERSION} or +indicate Ada 83 compatibility mode. + +@table @option +@cindex Compatibility with Ada 83 + +@item -gnat83 (Ada 83 Compatibility Mode) +@cindex @option{-gnat83} (@command{gcc}) +@cindex ACVC, Ada 83 tests +@cindex Ada 83 mode + +@noindent +Although GNAT is primarily an Ada 95 / Ada 2005 compiler, this switch +specifies that the program is to be compiled in Ada 83 mode. With +@option{-gnat83}, GNAT rejects most post-Ada 83 extensions and applies Ada 83 +semantics where this can be done easily. +It is not possible to guarantee this switch does a perfect +job; some subtle tests, such as are +found in earlier ACVC tests (and that have been removed from the ACATS suite +for Ada 95), might not compile correctly. +Nevertheless, this switch may be useful in some circumstances, for example +where, due to contractual reasons, existing code needs to be maintained +using only Ada 83 features. + +With few exceptions (most notably the need to use @code{<>} on +@cindex Generic formal parameters +unconstrained generic formal parameters, the use of the new Ada 95 / Ada 2005 +reserved words, and the use of packages +with optional bodies), it is not necessary to specify the +@option{-gnat83} switch when compiling Ada 83 programs, because, with rare +exceptions, Ada 95 and Ada 2005 are upwardly compatible with Ada 83. Thus +a correct Ada 83 program is usually also a correct program +in these later versions of the language standard. +For further information, please refer to @ref{Compatibility and Porting Guide}. + +@item -gnat95 (Ada 95 mode) +@cindex @option{-gnat95} (@command{gcc}) +@cindex Ada 95 mode + +@noindent +This switch directs the compiler to implement the Ada 95 version of the +language. +Since Ada 95 is almost completely upwards +compatible with Ada 83, Ada 83 programs may generally be compiled using +this switch (see the description of the @option{-gnat83} switch for further +information about Ada 83 mode). +If an Ada 2005 program is compiled in Ada 95 mode, +uses of the new Ada 2005 features will cause error +messages or warnings. + +This switch also can be used to cancel the effect of a previous +@option{-gnat83}, @option{-gnat05/2005}, or @option{-gnat12/2012} +switch earlier in the command line. + +@item -gnat05 or -gnat2005 (Ada 2005 mode) +@cindex @option{-gnat05} (@command{gcc}) +@cindex @option{-gnat2005} (@command{gcc}) +@cindex Ada 2005 mode + +@noindent +This switch directs the compiler to implement the Ada 2005 version of the +language, as documented in the official Ada standards document. +Since Ada 2005 is almost completely upwards +compatible with Ada 95 (and thus also with Ada 83), Ada 83 and Ada 95 programs +may generally be compiled using this switch (see the description of the +@option{-gnat83} and @option{-gnat95} switches for further +information). + +@ifset PROEDITION +Note that even though Ada 2005 is the current official version of the +language, GNAT still compiles in Ada 95 mode by default, so if you are +using Ada 2005 features in your program, you must use this switch (or +the equivalent Ada_05 or Ada_2005 configuration pragmas). +@end ifset + +@item -gnat12 or -gnat2012 (Ada 2012 mode) +@cindex @option{-gnat12} (@command{gcc}) +@cindex @option{-gnat2012} (@command{gcc}) +@cindex Ada 2012 mode + +@noindent +This switch directs the compiler to implement the Ada 2012 version of the +language. +Since Ada 2012 is almost completely upwards +compatible with Ada 2005 (and thus also with Ada 83, and Ada 95), +Ada 83 and Ada 95 programs +may generally be compiled using this switch (see the description of the +@option{-gnat83}, @option{-gnat95}, and @option{-gnat05/2005} switches +for further information). + +For information about the approved ``Ada Issues'' that have been incorporated +into Ada 2012, see @url{http://www.ada-auth.org/ais.html}. +Included with GNAT releases is a file @file{features-ada12} that describes +the set of implemented Ada 2012 features. + +@item -gnatX (Enable GNAT Extensions) +@cindex @option{-gnatX} (@command{gcc}) +@cindex Ada language extensions +@cindex GNAT extensions + +@noindent +This switch directs the compiler to implement the latest version of the +language (currently Ada 2012) and also to enable certain GNAT implementation +extensions that are not part of any Ada standard. For a full list of these +extensions, see the GNAT reference manual. + +@end table + +@node Character Set Control +@subsection Character Set Control +@table @option +@item ^-gnati^/IDENTIFIER_CHARACTER_SET=^@var{c} +@cindex @option{^-gnati^/IDENTIFIER_CHARACTER_SET^} (@command{gcc}) + +@noindent +Normally GNAT recognizes the Latin-1 character set in source program +identifiers, as described in the Ada Reference Manual. +This switch causes +GNAT to recognize alternate character sets in identifiers. @var{c} is a +single character ^^or word^ indicating the character set, as follows: + +@table @code +@item 1 +ISO 8859-1 (Latin-1) identifiers + +@item 2 +ISO 8859-2 (Latin-2) letters allowed in identifiers + +@item 3 +ISO 8859-3 (Latin-3) letters allowed in identifiers + +@item 4 +ISO 8859-4 (Latin-4) letters allowed in identifiers + +@item 5 +ISO 8859-5 (Cyrillic) letters allowed in identifiers + +@item 9 +ISO 8859-15 (Latin-9) letters allowed in identifiers + +@item ^p^PC^ +IBM PC letters (code page 437) allowed in identifiers + +@item ^8^PC850^ +IBM PC letters (code page 850) allowed in identifiers + +@item ^f^FULL_UPPER^ +Full upper-half codes allowed in identifiers + +@item ^n^NO_UPPER^ +No upper-half codes allowed in identifiers + +@item ^w^WIDE^ +Wide-character codes (that is, codes greater than 255) +allowed in identifiers +@end table + +@xref{Foreign Language Representation}, for full details on the +implementation of these character sets. + +@item ^-gnatW^/WIDE_CHARACTER_ENCODING=^@var{e} +@cindex @option{^-gnatW^/WIDE_CHARACTER_ENCODING^} (@command{gcc}) +Specify the method of encoding for wide characters. +@var{e} is one of the following: + +@table @code + +@item ^h^HEX^ +Hex encoding (brackets coding also recognized) + +@item ^u^UPPER^ +Upper half encoding (brackets encoding also recognized) + +@item ^s^SHIFT_JIS^ +Shift/JIS encoding (brackets encoding also recognized) + +@item ^e^EUC^ +EUC encoding (brackets encoding also recognized) + +@item ^8^UTF8^ +UTF-8 encoding (brackets encoding also recognized) + +@item ^b^BRACKETS^ +Brackets encoding only (default value) +@end table +For full details on these encoding +methods see @ref{Wide Character Encodings}. +Note that brackets coding is always accepted, even if one of the other +options is specified, so for example @option{-gnatW8} specifies that both +brackets and UTF-8 encodings will be recognized. The units that are +with'ed directly or indirectly will be scanned using the specified +representation scheme, and so if one of the non-brackets scheme is +used, it must be used consistently throughout the program. However, +since brackets encoding is always recognized, it may be conveniently +used in standard libraries, allowing these libraries to be used with +any of the available coding schemes. +scheme. + +If no @option{-gnatW?} parameter is present, then the default +representation is normally Brackets encoding only. However, if the +first three characters of the file are 16#EF# 16#BB# 16#BF# (the standard +byte order mark or BOM for UTF-8), then these three characters are +skipped and the default representation for the file is set to UTF-8. + +Note that the wide character representation that is specified (explicitly +or by default) for the main program also acts as the default encoding used +for Wide_Text_IO files if not specifically overridden by a WCEM form +parameter. + +@end table +@node File Naming Control +@subsection File Naming Control + +@table @option +@item ^-gnatk^/FILE_NAME_MAX_LENGTH=^@var{n} +@cindex @option{-gnatk} (@command{gcc}) +Activates file name ``krunching''. @var{n}, a decimal integer in the range +1-999, indicates the maximum allowable length of a file name (not +including the @file{.ads} or @file{.adb} extension). The default is not +to enable file name krunching. + +For the source file naming rules, @xref{File Naming Rules}. +@end table + +@node Subprogram Inlining Control +@subsection Subprogram Inlining Control + +@table @option +@c !sort! +@item -gnatn +@cindex @option{-gnatn} (@command{gcc}) +@ifclear vms +The @code{n} here is intended to suggest the first syllable of the +word ``inline''. +@end ifclear +GNAT recognizes and processes @code{Inline} pragmas. However, for the +inlining to actually occur, optimization must be enabled. To enable +inlining of subprograms specified by pragma @code{Inline}, +you must also specify this switch. +In the absence of this switch, GNAT does not attempt +inlining and does not need to access the bodies of +subprograms for which @code{pragma Inline} is specified if they are not +in the current unit. + +If you specify this switch the compiler will access these bodies, +creating an extra source dependency for the resulting object file, and +where possible, the call will be inlined. +For further details on when inlining is possible +see @ref{Inlining of Subprograms}. + +@item -gnatN +@cindex @option{-gnatN} (@command{gcc}) +This switch activates front-end inlining which also +generates additional dependencies. + +When using a gcc-based back end (in practice this means using any version +of GNAT other than the JGNAT, .NET or GNAAMP versions), then the use of +@option{-gnatN} is deprecated, and the use of @option{-gnatn} is preferred. +Historically front end inlining was more extensive than the gcc back end +inlining, but that is no longer the case. +@end table + +@node Auxiliary Output Control +@subsection Auxiliary Output Control + +@table @option +@item -gnatt +@cindex @option{-gnatt} (@command{gcc}) +@cindex Writing internal trees +@cindex Internal trees, writing to file +Causes GNAT to write the internal tree for a unit to a file (with the +extension @file{.adt}. +This not normally required, but is used by separate analysis tools. +Typically +these tools do the necessary compilations automatically, so you should +not have to specify this switch in normal operation. +Note that the combination of switches @option{-gnatct} +generates a tree in the form required by ASIS applications. + +@item -gnatu +@cindex @option{-gnatu} (@command{gcc}) +Print a list of units required by this compilation on @file{stdout}. +The listing includes all units on which the unit being compiled depends +either directly or indirectly. + +@ifclear vms +@item -pass-exit-codes +@cindex @option{-pass-exit-codes} (@command{gcc}) +If this switch is not used, the exit code returned by @command{gcc} when +compiling multiple files indicates whether all source files have +been successfully used to generate object files or not. + +When @option{-pass-exit-codes} is used, @command{gcc} exits with an extended +exit status and allows an integrated development environment to better +react to a compilation failure. Those exit status are: + +@table @asis +@item 5 +There was an error in at least one source file. +@item 3 +At least one source file did not generate an object file. +@item 2 +The compiler died unexpectedly (internal error for example). +@item 0 +An object file has been generated for every source file. +@end table +@end ifclear +@end table + +@node Debugging Control +@subsection Debugging Control + +@table @option +@c !sort! +@cindex Debugging options +@ifclear vms +@item -gnatd@var{x} +@cindex @option{-gnatd} (@command{gcc}) +Activate internal debugging switches. @var{x} is a letter or digit, or +string of letters or digits, which specifies the type of debugging +outputs desired. Normally these are used only for internal development +or system debugging purposes. You can find full documentation for these +switches in the body of the @code{Debug} unit in the compiler source +file @file{debug.adb}. +@end ifclear + +@item -gnatG[=nn] +@cindex @option{-gnatG} (@command{gcc}) +This switch causes the compiler to generate auxiliary output containing +a pseudo-source listing of the generated expanded code. Like most Ada +compilers, GNAT works by first transforming the high level Ada code into +lower level constructs. For example, tasking operations are transformed +into calls to the tasking run-time routines. A unique capability of GNAT +is to list this expanded code in a form very close to normal Ada source. +This is very useful in understanding the implications of various Ada +usage on the efficiency of the generated code. There are many cases in +Ada (e.g.@: the use of controlled types), where simple Ada statements can +generate a lot of run-time code. By using @option{-gnatG} you can identify +these cases, and consider whether it may be desirable to modify the coding +approach to improve efficiency. + +The optional parameter @code{nn} if present after -gnatG specifies an +alternative maximum line length that overrides the normal default of 72. +This value is in the range 40-999999, values less than 40 being silently +reset to 40. The equal sign is optional. + +The format of the output is very similar to standard Ada source, and is +easily understood by an Ada programmer. The following special syntactic +additions correspond to low level features used in the generated code that +do not have any exact analogies in pure Ada source form. The following +is a partial list of these special constructions. See the spec +of package @code{Sprint} in file @file{sprint.ads} for a full list. + +If the switch @option{-gnatL} is used in conjunction with +@cindex @option{-gnatL} (@command{gcc}) +@option{-gnatG}, then the original source lines are interspersed +in the expanded source (as comment lines with the original line number). + +@table @code +@item new @var{xxx} @r{[}storage_pool = @var{yyy}@r{]} +Shows the storage pool being used for an allocator. + +@item at end @var{procedure-name}; +Shows the finalization (cleanup) procedure for a scope. + +@item (if @var{expr} then @var{expr} else @var{expr}) +Conditional expression equivalent to the @code{x?y:z} construction in C. + +@item @var{target}^^^(@var{source}) +A conversion with floating-point truncation instead of rounding. + +@item @var{target}?(@var{source}) +A conversion that bypasses normal Ada semantic checking. In particular +enumeration types and fixed-point types are treated simply as integers. + +@item @var{target}?^^^(@var{source}) +Combines the above two cases. + +@item @var{x} #/ @var{y} +@itemx @var{x} #mod @var{y} +@itemx @var{x} #* @var{y} +@itemx @var{x} #rem @var{y} +A division or multiplication of fixed-point values which are treated as +integers without any kind of scaling. + +@item free @var{expr} @r{[}storage_pool = @var{xxx}@r{]} +Shows the storage pool associated with a @code{free} statement. + +@item [subtype or type declaration] +Used to list an equivalent declaration for an internally generated +type that is referenced elsewhere in the listing. + +@c @item freeze @var{type-name} @ovar{actions} +@c Expanding @ovar macro inline (explanation in macro def comments) +@item freeze @var{type-name} @r{[}@var{actions}@r{]} +Shows the point at which @var{type-name} is frozen, with possible +associated actions to be performed at the freeze point. + +@item reference @var{itype} +Reference (and hence definition) to internal type @var{itype}. + +@item @var{function-name}! (@var{arg}, @var{arg}, @var{arg}) +Intrinsic function call. + +@item @var{label-name} : label +Declaration of label @var{labelname}. + +@item #$ @var{subprogram-name} +An implicit call to a run-time support routine +(to meet the requirement of H.3.1(9) in a +convenient manner). + +@item @var{expr} && @var{expr} && @var{expr} @dots{} && @var{expr} +A multiple concatenation (same effect as @var{expr} & @var{expr} & +@var{expr}, but handled more efficiently). + +@item [constraint_error] +Raise the @code{Constraint_Error} exception. + +@item @var{expression}'reference +A pointer to the result of evaluating @var{expression}. + +@item @var{target-type}!(@var{source-expression}) +An unchecked conversion of @var{source-expression} to @var{target-type}. + +@item [@var{numerator}/@var{denominator}] +Used to represent internal real literals (that) have no exact +representation in base 2-16 (for example, the result of compile time +evaluation of the expression 1.0/27.0). +@end table + +@item -gnatD[=nn] +@cindex @option{-gnatD} (@command{gcc}) +When used in conjunction with @option{-gnatG}, this switch causes +the expanded source, as described above for +@option{-gnatG} to be written to files with names +@file{^xxx.dg^XXX_DG^}, where @file{xxx} is the normal file name, +instead of to the standard output file. For +example, if the source file name is @file{hello.adb}, then a file +@file{^hello.adb.dg^HELLO.ADB_DG^} will be written. The debugging +information generated by the @command{gcc} @option{^-g^/DEBUG^} switch +will refer to the generated @file{^xxx.dg^XXX_DG^} file. This allows +you to do source level debugging using the generated code which is +sometimes useful for complex code, for example to find out exactly +which part of a complex construction raised an exception. This switch +also suppress generation of cross-reference information (see +@option{-gnatx}) since otherwise the cross-reference information +would refer to the @file{^.dg^.DG^} file, which would cause +confusion since this is not the original source file. + +Note that @option{-gnatD} actually implies @option{-gnatG} +automatically, so it is not necessary to give both options. +In other words @option{-gnatD} is equivalent to @option{-gnatDG}). + +If the switch @option{-gnatL} is used in conjunction with +@cindex @option{-gnatL} (@command{gcc}) +@option{-gnatDG}, then the original source lines are interspersed +in the expanded source (as comment lines with the original line number). + +The optional parameter @code{nn} if present after -gnatD specifies an +alternative maximum line length that overrides the normal default of 72. +This value is in the range 40-999999, values less than 40 being silently +reset to 40. The equal sign is optional. + +@item -gnatr +@cindex @option{-gnatr} (@command{gcc}) +@cindex pragma Restrictions +This switch causes pragma Restrictions to be treated as Restriction_Warnings +so that violation of restrictions causes warnings rather than illegalities. +This is useful during the development process when new restrictions are added +or investigated. The switch also causes pragma Profile to be treated as +Profile_Warnings, and pragma Restricted_Run_Time and pragma Ravenscar set +restriction warnings rather than restrictions. + +@ifclear vms +@item -gnatR@r{[}0@r{|}1@r{|}2@r{|}3@r{[}s@r{]]} +@cindex @option{-gnatR} (@command{gcc}) +This switch controls output from the compiler of a listing showing +representation information for declared types and objects. For +@option{-gnatR0}, no information is output (equivalent to omitting +the @option{-gnatR} switch). For @option{-gnatR1} (which is the default, +so @option{-gnatR} with no parameter has the same effect), size and alignment +information is listed for declared array and record types. For +@option{-gnatR2}, size and alignment information is listed for all +declared types and objects. Finally @option{-gnatR3} includes symbolic +expressions for values that are computed at run time for +variant records. These symbolic expressions have a mostly obvious +format with #n being used to represent the value of the n'th +discriminant. See source files @file{repinfo.ads/adb} in the +@code{GNAT} sources for full details on the format of @option{-gnatR3} +output. If the switch is followed by an s (e.g.@: @option{-gnatR2s}), then +the output is to a file with the name @file{^file.rep^file_REP^} where +file is the name of the corresponding source file. +@end ifclear +@ifset vms +@item /REPRESENTATION_INFO +@cindex @option{/REPRESENTATION_INFO} (@command{gcc}) +This qualifier controls output from the compiler of a listing showing +representation information for declared types and objects. For +@option{/REPRESENTATION_INFO=NONE}, no information is output +(equivalent to omitting the @option{/REPRESENTATION_INFO} qualifier). +@option{/REPRESENTATION_INFO} without option is equivalent to +@option{/REPRESENTATION_INFO=ARRAYS}. +For @option{/REPRESENTATION_INFO=ARRAYS}, size and alignment +information is listed for declared array and record types. For +@option{/REPRESENTATION_INFO=OBJECTS}, size and alignment information +is listed for all expression information for values that are computed +at run time for variant records. These symbolic expressions have a mostly +obvious format with #n being used to represent the value of the n'th +discriminant. See source files @file{REPINFO.ADS/ADB} in the +@code{GNAT} sources for full details on the format of +@option{/REPRESENTATION_INFO=SYMBOLIC} output. +If _FILE is added at the end of an option +(e.g.@: @option{/REPRESENTATION_INFO=ARRAYS_FILE}), +then the output is to a file with the name @file{file_REP} where +file is the name of the corresponding source file. +@end ifset +Note that it is possible for record components to have zero size. In +this case, the component clause uses an obvious extension of permitted +Ada syntax, for example @code{at 0 range 0 .. -1}. + +Representation information requires that code be generated (since it is the +code generator that lays out complex data structures). If an attempt is made +to output representation information when no code is generated, for example +when a subunit is compiled on its own, then no information can be generated +and the compiler outputs a message to this effect. + +@item -gnatS +@cindex @option{-gnatS} (@command{gcc}) +The use of the switch @option{-gnatS} for an +Ada compilation will cause the compiler to output a +representation of package Standard in a form very +close to standard Ada. It is not quite possible to +do this entirely in standard Ada (since new +numeric base types cannot be created in standard +Ada), but the output is easily +readable to any Ada programmer, and is useful to +determine the characteristics of target dependent +types in package Standard. + +@item -gnatx +@cindex @option{-gnatx} (@command{gcc}) +Normally the compiler generates full cross-referencing information in +the @file{ALI} file. This information is used by a number of tools, +including @code{gnatfind} and @code{gnatxref}. The @option{-gnatx} switch +suppresses this information. This saves some space and may slightly +speed up compilation, but means that these tools cannot be used. +@end table + +@node Exception Handling Control +@subsection Exception Handling Control + +@noindent +GNAT uses two methods for handling exceptions at run-time. The +@code{setjmp/longjmp} method saves the context when entering +a frame with an exception handler. Then when an exception is +raised, the context can be restored immediately, without the +need for tracing stack frames. This method provides very fast +exception propagation, but introduces significant overhead for +the use of exception handlers, even if no exception is raised. + +The other approach is called ``zero cost'' exception handling. +With this method, the compiler builds static tables to describe +the exception ranges. No dynamic code is required when entering +a frame containing an exception handler. When an exception is +raised, the tables are used to control a back trace of the +subprogram invocation stack to locate the required exception +handler. This method has considerably poorer performance for +the propagation of exceptions, but there is no overhead for +exception handlers if no exception is raised. Note that in this +mode and in the context of mixed Ada and C/C++ programming, +to propagate an exception through a C/C++ code, the C/C++ code +must be compiled with the @option{-funwind-tables} GCC's +option. + +The following switches may be used to control which of the +two exception handling methods is used. + +@table @option +@c !sort! + +@item --RTS=sjlj +@cindex @option{--RTS=sjlj} (@command{gnatmake}) +This switch causes the setjmp/longjmp run-time (when available) to be used +for exception handling. If the default +mechanism for the target is zero cost exceptions, then +this switch can be used to modify this default, and must be +used for all units in the partition. +This option is rarely used. One case in which it may be +advantageous is if you have an application where exception +raising is common and the overall performance of the +application is improved by favoring exception propagation. + +@item --RTS=zcx +@cindex @option{--RTS=zcx} (@command{gnatmake}) +@cindex Zero Cost Exceptions +This switch causes the zero cost approach to be used +for exception handling. If this is the default mechanism for the +target (see below), then this switch is unneeded. If the default +mechanism for the target is setjmp/longjmp exceptions, then +this switch can be used to modify this default, and must be +used for all units in the partition. +This option can only be used if the zero cost approach +is available for the target in use, otherwise it will generate an error. +@end table + +@noindent +The same option @option{--RTS} must be used both for @command{gcc} +and @command{gnatbind}. Passing this option to @command{gnatmake} +(@pxref{Switches for gnatmake}) will ensure the required consistency +through the compilation and binding steps. + +@node Units to Sources Mapping Files +@subsection Units to Sources Mapping Files + +@table @option + +@item -gnatem=@var{path} +@cindex @option{-gnatem} (@command{gcc}) +A mapping file is a way to communicate to the compiler two mappings: +from unit names to file names (without any directory information) and from +file names to path names (with full directory information). These mappings +are used by the compiler to short-circuit the path search. + +The use of mapping files is not required for correct operation of the +compiler, but mapping files can improve efficiency, particularly when +sources are read over a slow network connection. In normal operation, +you need not be concerned with the format or use of mapping files, +and the @option{-gnatem} switch is not a switch that you would use +explicitly. It is intended primarily for use by automatic tools such as +@command{gnatmake} running under the project file facility. The +description here of the format of mapping files is provided +for completeness and for possible use by other tools. + +A mapping file is a sequence of sets of three lines. In each set, the +first line is the unit name, in lower case, with @code{%s} appended +for specs and @code{%b} appended for bodies; the second line is the +file name; and the third line is the path name. + +Example: +@smallexample + main%b + main.2.ada + /gnat/project1/sources/main.2.ada +@end smallexample + +When the switch @option{-gnatem} is specified, the compiler will +create in memory the two mappings from the specified file. If there is +any problem (nonexistent file, truncated file or duplicate entries), +no mapping will be created. + +Several @option{-gnatem} switches may be specified; however, only the +last one on the command line will be taken into account. + +When using a project file, @command{gnatmake} creates a temporary +mapping file and communicates it to the compiler using this switch. + +@end table + +@node Integrated Preprocessing +@subsection Integrated Preprocessing + +@noindent +GNAT sources may be preprocessed immediately before compilation. +In this case, the actual +text of the source is not the text of the source file, but is derived from it +through a process called preprocessing. Integrated preprocessing is specified +through switches @option{-gnatep} and/or @option{-gnateD}. @option{-gnatep} +indicates, through a text file, the preprocessing data to be used. +@option{-gnateD} specifies or modifies the values of preprocessing symbol. + +@noindent +Note that when integrated preprocessing is used, the output from the +preprocessor is not written to any external file. Instead it is passed +internally to the compiler. If you need to preserve the result of +preprocessing in a file, then you should use @command{gnatprep} +to perform the desired preprocessing in stand-alone mode. + +@noindent +It is recommended that @command{gnatmake} switch ^-s^/SWITCH_CHECK^ should be +used when Integrated Preprocessing is used. The reason is that preprocessing +with another Preprocessing Data file without changing the sources will +not trigger recompilation without this switch. + +@noindent +Note that @command{gnatmake} switch ^-m^/MINIMAL_RECOMPILATION^ will almost +always trigger recompilation for sources that are preprocessed, +because @command{gnatmake} cannot compute the checksum of the source after +preprocessing. + +@noindent +The actual preprocessing function is described in details in section +@ref{Preprocessing Using gnatprep}. This section only describes how integrated +preprocessing is triggered and parameterized. + +@table @code + +@item -gnatep=@var{file} +@cindex @option{-gnatep} (@command{gcc}) +This switch indicates to the compiler the file name (without directory +information) of the preprocessor data file to use. The preprocessor data file +should be found in the source directories. + +@noindent +A preprocessing data file is a text file with significant lines indicating +how should be preprocessed either a specific source or all sources not +mentioned in other lines. A significant line is a nonempty, non-comment line. +Comments are similar to Ada comments. + +@noindent +Each significant line starts with either a literal string or the character '*'. +A literal string is the file name (without directory information) of the source +to preprocess. A character '*' indicates the preprocessing for all the sources +that are not specified explicitly on other lines (order of the lines is not +significant). It is an error to have two lines with the same file name or two +lines starting with the character '*'. + +@noindent +After the file name or the character '*', another optional literal string +indicating the file name of the definition file to be used for preprocessing +(@pxref{Form of Definitions File}). The definition files are found by the +compiler in one of the source directories. In some cases, when compiling +a source in a directory other than the current directory, if the definition +file is in the current directory, it may be necessary to add the current +directory as a source directory through switch ^-I.^/SEARCH=[]^, otherwise +the compiler would not find the definition file. + +@noindent +Then, optionally, ^switches^switches^ similar to those of @code{gnatprep} may +be found. Those ^switches^switches^ are: + +@table @code + +@item -b +Causes both preprocessor lines and the lines deleted by +preprocessing to be replaced by blank lines, preserving the line number. +This ^switch^switch^ is always implied; however, if specified after @option{-c} +it cancels the effect of @option{-c}. + +@item -c +Causes both preprocessor lines and the lines deleted +by preprocessing to be retained as comments marked +with the special string ``@code{--! }''. + +@item -Dsymbol=value +Define or redefine a symbol, associated with value. A symbol is an Ada +identifier, or an Ada reserved word, with the exception of @code{if}, +@code{else}, @code{elsif}, @code{end}, @code{and}, @code{or} and @code{then}. +@code{value} is either a literal string, an Ada identifier or any Ada reserved +word. A symbol declared with this ^switch^switch^ replaces a symbol with the +same name defined in a definition file. + +@item -s +Causes a sorted list of symbol names and values to be +listed on the standard output file. + +@item -u +Causes undefined symbols to be treated as having the value @code{FALSE} +in the context +of a preprocessor test. In the absence of this option, an undefined symbol in +a @code{#if} or @code{#elsif} test will be treated as an error. + +@end table + +@noindent +Examples of valid lines in a preprocessor data file: + +@smallexample + "toto.adb" "prep.def" -u + -- preprocess "toto.adb", using definition file "prep.def", + -- undefined symbol are False. + + * -c -DVERSION=V101 + -- preprocess all other sources without a definition file; + -- suppressed lined are commented; symbol VERSION has the value V101. + + "titi.adb" "prep2.def" -s + -- preprocess "titi.adb", using definition file "prep2.def"; + -- list all symbols with their values. +@end smallexample + +@item ^-gnateD^/DATA_PREPROCESSING=^symbol@r{[}=value@r{]} +@cindex @option{-gnateD} (@command{gcc}) +Define or redefine a preprocessing symbol, associated with value. If no value +is given on the command line, then the value of the symbol is @code{True}. +A symbol is an identifier, following normal Ada (case-insensitive) +rules for its syntax, and value is any sequence (including an empty sequence) +of characters from the set (letters, digits, period, underline). +Ada reserved words may be used as symbols, with the exceptions of @code{if}, +@code{else}, @code{elsif}, @code{end}, @code{and}, @code{or} and @code{then}. + +@noindent +A symbol declared with this ^switch^switch^ on the command line replaces a +symbol with the same name either in a definition file or specified with a +^switch^switch^ -D in the preprocessor data file. + +@noindent +This switch is similar to switch @option{^-D^/ASSOCIATE^} of @code{gnatprep}. + +@item -gnateG +When integrated preprocessing is performed and the preprocessor modifies +the source text, write the result of this preprocessing into a file +^.prep^_prep^. + +@end table + +@node Code Generation Control +@subsection Code Generation Control + +@noindent + +The GCC technology provides a wide range of target dependent +@option{-m} switches for controlling +details of code generation with respect to different versions of +architectures. This includes variations in instruction sets (e.g.@: +different members of the power pc family), and different requirements +for optimal arrangement of instructions (e.g.@: different members of +the x86 family). The list of available @option{-m} switches may be +found in the GCC documentation. + +Use of these @option{-m} switches may in some cases result in improved +code performance. + +The GNAT Pro technology is tested and qualified without any +@option{-m} switches, +so generally the most reliable approach is to avoid the use of these +switches. However, we generally expect most of these switches to work +successfully with GNAT Pro, and many customers have reported successful +use of these options. + +Our general advice is to avoid the use of @option{-m} switches unless +special needs lead to requirements in this area. In particular, +there is no point in using @option{-m} switches to improve performance +unless you actually see a performance improvement. + +@ifset vms +@node Return Codes +@subsection Return Codes +@cindex Return Codes +@cindex @option{/RETURN_CODES=VMS} + +@noindent +On VMS, GNAT compiled programs return POSIX-style codes by default, +e.g.@: @option{/RETURN_CODES=POSIX}. + +To enable VMS style return codes, use GNAT BIND and LINK with the option +@option{/RETURN_CODES=VMS}. For example: + +@smallexample +GNAT BIND MYMAIN.ALI /RETURN_CODES=VMS +GNAT LINK MYMAIN.ALI /RETURN_CODES=VMS +@end smallexample + +@noindent +Programs built with /RETURN_CODES=VMS are suitable to be called in +VMS DCL scripts. Programs compiled with the default /RETURN_CODES=POSIX +are suitable for spawning with appropriate GNAT RTL routines. + +@end ifset + +@node Search Paths and the Run-Time Library (RTL) +@section Search Paths and the Run-Time Library (RTL) + +@noindent +With the GNAT source-based library system, the compiler must be able to +find source files for units that are needed by the unit being compiled. +Search paths are used to guide this process. + +The compiler compiles one source file whose name must be given +explicitly on the command line. In other words, no searching is done +for this file. To find all other source files that are needed (the most +common being the specs of units), the compiler examines the following +directories, in the following order: + +@enumerate +@item +The directory containing the source file of the main unit being compiled +(the file name on the command line). + +@item +Each directory named by an @option{^-I^/SOURCE_SEARCH^} switch given on the +@command{gcc} command line, in the order given. + +@item +@findex ADA_PRJ_INCLUDE_FILE +Each of the directories listed in the text file whose name is given +by the @env{ADA_PRJ_INCLUDE_FILE} ^environment variable^logical name^. + +@noindent +@env{ADA_PRJ_INCLUDE_FILE} is normally set by gnatmake or by the ^gnat^GNAT^ +driver when project files are used. It should not normally be set +by other means. + +@item +@findex ADA_INCLUDE_PATH +Each of the directories listed in the value of the +@env{ADA_INCLUDE_PATH} ^environment variable^logical name^. +@ifclear vms +Construct this value +exactly as the @env{PATH} environment variable: a list of directory +names separated by colons (semicolons when working with the NT version). +@end ifclear +@ifset vms +Normally, define this value as a logical name containing a comma separated +list of directory names. + +This variable can also be defined by means of an environment string +(an argument to the HP C exec* set of functions). + +Logical Name: +@smallexample +DEFINE ANOTHER_PATH FOO:[BAG] +DEFINE ADA_INCLUDE_PATH ANOTHER_PATH,FOO:[BAM],FOO:[BAR] +@end smallexample + +By default, the path includes GNU:[LIB.OPENVMS7_x.2_8_x.DECLIB] +first, followed by the standard Ada +libraries in GNU:[LIB.OPENVMS7_x.2_8_x.ADAINCLUDE]. +If this is not redefined, the user will obtain the HP Ada 83 IO packages +(Text_IO, Sequential_IO, etc) +instead of the standard Ada packages. Thus, in order to get the standard Ada +packages by default, ADA_INCLUDE_PATH must be redefined. +@end ifset + +@item +The content of the @file{ada_source_path} file which is part of the GNAT +installation tree and is used to store standard libraries such as the +GNAT Run Time Library (RTL) source files. +@ifclear vms +@ref{Installing a library} +@end ifclear +@end enumerate + +@noindent +Specifying the switch @option{^-I-^/NOCURRENT_DIRECTORY^} +inhibits the use of the directory +containing the source file named in the command line. You can still +have this directory on your search path, but in this case it must be +explicitly requested with a @option{^-I^/SOURCE_SEARCH^} switch. + +Specifying the switch @option{-nostdinc} +inhibits the search of the default location for the GNAT Run Time +Library (RTL) source files. + +The compiler outputs its object files and ALI files in the current +working directory. +@ifclear vms +Caution: The object file can be redirected with the @option{-o} switch; +however, @command{gcc} and @code{gnat1} have not been coordinated on this +so the @file{ALI} file will not go to the right place. Therefore, you should +avoid using the @option{-o} switch. +@end ifclear + +@findex System.IO +The packages @code{Ada}, @code{System}, and @code{Interfaces} and their +children make up the GNAT RTL, together with the simple @code{System.IO} +package used in the @code{"Hello World"} example. The sources for these units +are needed by the compiler and are kept together in one directory. Not +all of the bodies are needed, but all of the sources are kept together +anyway. In a normal installation, you need not specify these directory +names when compiling or binding. Either the environment variables or +the built-in defaults cause these files to be found. + +In addition to the language-defined hierarchies (@code{System}, @code{Ada} and +@code{Interfaces}), the GNAT distribution provides a fourth hierarchy, +consisting of child units of @code{GNAT}. This is a collection of generally +useful types, subprograms, etc. @xref{Top, GNAT Reference Manual, About +This Guid, gnat_rm, GNAT Reference Manual}, for further details. + +Besides simplifying access to the RTL, a major use of search paths is +in compiling sources from multiple directories. This can make +development environments much more flexible. + +@node Order of Compilation Issues +@section Order of Compilation Issues + +@noindent +If, in our earlier example, there was a spec for the @code{hello} +procedure, it would be contained in the file @file{hello.ads}; yet this +file would not have to be explicitly compiled. This is the result of the +model we chose to implement library management. Some of the consequences +of this model are as follows: + +@itemize @bullet +@item +There is no point in compiling specs (except for package +specs with no bodies) because these are compiled as needed by clients. If +you attempt a useless compilation, you will receive an error message. +It is also useless to compile subunits because they are compiled as needed +by the parent. + +@item +There are no order of compilation requirements: performing a +compilation never obsoletes anything. The only way you can obsolete +something and require recompilations is to modify one of the +source files on which it depends. + +@item +There is no library as such, apart from the ALI files +(@pxref{The Ada Library Information Files}, for information on the format +of these files). For now we find it convenient to create separate ALI files, +but eventually the information therein may be incorporated into the object +file directly. + +@item +When you compile a unit, the source files for the specs of all units +that it @code{with}'s, all its subunits, and the bodies of any generics it +instantiates must be available (reachable by the search-paths mechanism +described above), or you will receive a fatal error message. +@end itemize + +@node Examples +@section Examples + +@noindent +The following are some typical Ada compilation command line examples: + +@table @code +@item $ gcc -c xyz.adb +Compile body in file @file{xyz.adb} with all default options. + +@ifclear vms +@item $ gcc -c -O2 -gnata xyz-def.adb +@end ifclear +@ifset vms +@item $ GNAT COMPILE /OPTIMIZE=ALL -gnata xyz-def.adb +@end ifset + +Compile the child unit package in file @file{xyz-def.adb} with extensive +optimizations, and pragma @code{Assert}/@code{Debug} statements +enabled. + +@item $ gcc -c -gnatc abc-def.adb +Compile the subunit in file @file{abc-def.adb} in semantic-checking-only +mode. +@end table + +@node Binding Using gnatbind +@chapter Binding Using @code{gnatbind} +@findex gnatbind + +@menu +* Running gnatbind:: +* Switches for gnatbind:: +* Command-Line Access:: +* Search Paths for gnatbind:: +* Examples of gnatbind Usage:: +@end menu + +@noindent +This chapter describes the GNAT binder, @code{gnatbind}, which is used +to bind compiled GNAT objects. + +Note: to invoke @code{gnatbind} with a project file, use the @code{gnat} +driver (see @ref{The GNAT Driver and Project Files}). + +The @code{gnatbind} program performs four separate functions: + +@enumerate +@item +Checks that a program is consistent, in accordance with the rules in +Chapter 10 of the Ada Reference Manual. In particular, error +messages are generated if a program uses inconsistent versions of a +given unit. + +@item +Checks that an acceptable order of elaboration exists for the program +and issues an error message if it cannot find an order of elaboration +that satisfies the rules in Chapter 10 of the Ada Language Manual. + +@item +Generates a main program incorporating the given elaboration order. +This program is a small Ada package (body and spec) that +must be subsequently compiled +using the GNAT compiler. The necessary compilation step is usually +performed automatically by @command{gnatlink}. The two most important +functions of this program +are to call the elaboration routines of units in an appropriate order +and to call the main program. + +@item +Determines the set of object files required by the given main program. +This information is output in the forms of comments in the generated program, +to be read by the @command{gnatlink} utility used to link the Ada application. +@end enumerate + +@node Running gnatbind +@section Running @code{gnatbind} + +@noindent +The form of the @code{gnatbind} command is + +@smallexample +@c $ gnatbind @ovar{switches} @var{mainprog}@r{[}.ali@r{]} @ovar{switches} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatbind @r{[}@var{switches}@r{]} @var{mainprog}@r{[}.ali@r{]} @r{[}@var{switches}@r{]} +@end smallexample + +@noindent +where @file{@var{mainprog}.adb} is the Ada file containing the main program +unit body. @code{gnatbind} constructs an Ada +package in two files whose names are +@file{b~@var{mainprog}.ads}, and @file{b~@var{mainprog}.adb}. +For example, if given the +parameter @file{hello.ali}, for a main program contained in file +@file{hello.adb}, the binder output files would be @file{b~hello.ads} +and @file{b~hello.adb}. + +When doing consistency checking, the binder takes into consideration +any source files it can locate. For example, if the binder determines +that the given main program requires the package @code{Pack}, whose +@file{.ALI} +file is @file{pack.ali} and whose corresponding source spec file is +@file{pack.ads}, it attempts to locate the source file @file{pack.ads} +(using the same search path conventions as previously described for the +@command{gcc} command). If it can locate this source file, it checks that +the time stamps +or source checksums of the source and its references to in @file{ALI} files +match. In other words, any @file{ALI} files that mentions this spec must have +resulted from compiling this version of the source file (or in the case +where the source checksums match, a version close enough that the +difference does not matter). + +@cindex Source files, use by binder +The effect of this consistency checking, which includes source files, is +that the binder ensures that the program is consistent with the latest +version of the source files that can be located at bind time. Editing a +source file without compiling files that depend on the source file cause +error messages to be generated by the binder. + +For example, suppose you have a main program @file{hello.adb} and a +package @code{P}, from file @file{p.ads} and you perform the following +steps: + +@enumerate +@item +Enter @code{gcc -c hello.adb} to compile the main program. + +@item +Enter @code{gcc -c p.ads} to compile package @code{P}. + +@item +Edit file @file{p.ads}. + +@item +Enter @code{gnatbind hello}. +@end enumerate + +@noindent +At this point, the file @file{p.ali} contains an out-of-date time stamp +because the file @file{p.ads} has been edited. The attempt at binding +fails, and the binder generates the following error messages: + +@smallexample +error: "hello.adb" must be recompiled ("p.ads" has been modified) +error: "p.ads" has been modified and must be recompiled +@end smallexample + +@noindent +Now both files must be recompiled as indicated, and then the bind can +succeed, generating a main program. You need not normally be concerned +with the contents of this file, but for reference purposes a sample +binder output file is given in @ref{Example of Binder Output File}. + +In most normal usage, the default mode of @command{gnatbind} which is to +generate the main package in Ada, as described in the previous section. +In particular, this means that any Ada programmer can read and understand +the generated main program. It can also be debugged just like any other +Ada code provided the @option{^-g^/DEBUG^} switch is used for +@command{gnatbind} and @command{gnatlink}. + +@node Switches for gnatbind +@section Switches for @command{gnatbind} + +@noindent +The following switches are available with @code{gnatbind}; details will +be presented in subsequent sections. + +@menu +* Consistency-Checking Modes:: +* Binder Error Message Control:: +* Elaboration Control:: +* Output Control:: +* Dynamic Allocation Control:: +* Binding with Non-Ada Main Programs:: +* Binding Programs with No Main Subprogram:: +@end menu + +@table @option +@c !sort! + +@item --version +@cindex @option{--version} @command{gnatbind} +Display Copyright and version, then exit disregarding all other options. + +@item --help +@cindex @option{--help} @command{gnatbind} +If @option{--version} was not used, display usage, then exit disregarding +all other options. + +@item -a +@cindex @option{-a} @command{gnatbind} +Indicates that, if supported by the platform, the adainit procedure should +be treated as an initialisation routine by the linker (a constructor). This +is intended to be used by the Project Manager to automatically initialize +shared Stand-Alone Libraries. + +@item ^-aO^/OBJECT_SEARCH^ +@cindex @option{^-aO^/OBJECT_SEARCH^} (@command{gnatbind}) +Specify directory to be searched for ALI files. + +@item ^-aI^/SOURCE_SEARCH^ +@cindex @option{^-aI^/SOURCE_SEARCH^} (@command{gnatbind}) +Specify directory to be searched for source file. + +@item ^-A^/ALI_LIST^@r{[=}@var{filename}@r{]} +@cindex @option{^-A^/ALI_LIST^} (@command{gnatbind}) +Output ALI list (to standard output or to the named file). + +@item ^-b^/REPORT_ERRORS=BRIEF^ +@cindex @option{^-b^/REPORT_ERRORS=BRIEF^} (@command{gnatbind}) +Generate brief messages to @file{stderr} even if verbose mode set. + +@item ^-c^/NOOUTPUT^ +@cindex @option{^-c^/NOOUTPUT^} (@command{gnatbind}) +Check only, no generation of binder output file. + +@item ^-d^/DEFAULT_STACK_SIZE=^@var{nn}@r{[}k@r{|}m@r{]} +@cindex @option{^-d^/DEFAULT_STACK_SIZE=^@var{nn}@r{[}k@r{|}m@r{]}} (@command{gnatbind}) +This switch can be used to change the default task stack size value +to a specified size @var{nn}, which is expressed in bytes by default, or +in kilobytes when suffixed with @var{k} or in megabytes when suffixed +with @var{m}. +In the absence of a @samp{@r{[}k@r{|}m@r{]}} suffix, this switch is equivalent, +in effect, to completing all task specs with +@smallexample @c ada + pragma Storage_Size (nn); +@end smallexample +When they do not already have such a pragma. + +@item ^-D^/DEFAULT_SECONDARY_STACK_SIZE=^@var{nn}@r{[}k@r{|}m@r{]} +@cindex @option{^-D^/DEFAULT_SECONDARY_STACK_SIZE=nnnnn^} (@command{gnatbind}) +This switch can be used to change the default secondary stack size value +to a specified size @var{nn}, which is expressed in bytes by default, or +in kilobytes when suffixed with @var{k} or in megabytes when suffixed +with @var{m}. + +The secondary stack is used to deal with functions that return a variable +sized result, for example a function returning an unconstrained +String. There are two ways in which this secondary stack is allocated. + +For most targets, the secondary stack is growing on demand and is allocated +as a chain of blocks in the heap. The -D option is not very +relevant. It only give some control over the size of the allocated +blocks (whose size is the minimum of the default secondary stack size value, +and the actual size needed for the current allocation request). + +For certain targets, notably VxWorks 653, +the secondary stack is allocated by carving off a fixed ratio chunk of the +primary task stack. The -D option is used to define the +size of the environment task's secondary stack. + +@item ^-e^/ELABORATION_DEPENDENCIES^ +@cindex @option{^-e^/ELABORATION_DEPENDENCIES^} (@command{gnatbind}) +Output complete list of elaboration-order dependencies. + +@item ^-E^/STORE_TRACEBACKS^ +@cindex @option{^-E^/STORE_TRACEBACKS^} (@command{gnatbind}) +Store tracebacks in exception occurrences when the target supports it. +@ignore +@c The following may get moved to an appendix +This option is currently supported on the following targets: +all x86 ports, Solaris, Windows, HP-UX, AIX, PowerPC VxWorks and Alpha VxWorks. +@end ignore +See also the packages @code{GNAT.Traceback} and +@code{GNAT.Traceback.Symbolic} for more information. +@ifclear vms +Note that on x86 ports, you must not use @option{-fomit-frame-pointer} +@command{gcc} option. +@end ifclear + +@item ^-F^/FORCE_ELABS_FLAGS^ +@cindex @option{^-F^/FORCE_ELABS_FLAGS^} (@command{gnatbind}) +Force the checks of elaboration flags. @command{gnatbind} does not normally +generate checks of elaboration flags for the main executable, except when +a Stand-Alone Library is used. However, there are cases when this cannot be +detected by gnatbind. An example is importing an interface of a Stand-Alone +Library through a pragma Import and only specifying through a linker switch +this Stand-Alone Library. This switch is used to guarantee that elaboration +flag checks are generated. + +@item ^-h^/HELP^ +@cindex @option{^-h^/HELP^} (@command{gnatbind}) +Output usage (help) information + +@item ^-H32^/32_MALLOC^ +@cindex @option{^-H32^/32_MALLOC^} (@command{gnatbind}) +Use 32-bit allocations for @code{__gnat_malloc} (and thus for access types). +For further details see @ref{Dynamic Allocation Control}. + +@item ^-H64^/64_MALLOC^ +@cindex @option{^-H64^/64_MALLOC^} (@command{gnatbind}) +Use 64-bit allocations for @code{__gnat_malloc} (and thus for access types). +@cindex @code{__gnat_malloc} +For further details see @ref{Dynamic Allocation Control}. + +@item ^-I^/SEARCH^ +@cindex @option{^-I^/SEARCH^} (@command{gnatbind}) +Specify directory to be searched for source and ALI files. + +@item ^-I-^/NOCURRENT_DIRECTORY^ +@cindex @option{^-I-^/NOCURRENT_DIRECTORY^} (@command{gnatbind}) +Do not look for sources in the current directory where @code{gnatbind} was +invoked, and do not look for ALI files in the directory containing the +ALI file named in the @code{gnatbind} command line. + +@item ^-l^/ORDER_OF_ELABORATION^ +@cindex @option{^-l^/ORDER_OF_ELABORATION^} (@command{gnatbind}) +Output chosen elaboration order. + +@item ^-L@var{xxx}^/BUILD_LIBRARY=@var{xxx}^ +@cindex @option{^-L^/BUILD_LIBRARY^} (@command{gnatbind}) +Bind the units for library building. In this case the adainit and +adafinal procedures (@pxref{Binding with Non-Ada Main Programs}) +are renamed to ^@var{xxx}init^@var{XXX}INIT^ and +^@var{xxx}final^@var{XXX}FINAL^. +Implies ^-n^/NOCOMPILE^. +@ifclear vms +(@xref{GNAT and Libraries}, for more details.) +@end ifclear +@ifset vms +On OpenVMS, these init and final procedures are exported in uppercase +letters. For example if /BUILD_LIBRARY=toto is used, the exported name of +the init procedure will be "TOTOINIT" and the exported name of the final +procedure will be "TOTOFINAL". +@end ifset + +@item ^-Mxyz^/RENAME_MAIN=xyz^ +@cindex @option{^-M^/RENAME_MAIN^} (@command{gnatbind}) +Rename generated main program from main to xyz. This option is +supported on cross environments only. + +@item ^-m^/ERROR_LIMIT=^@var{n} +@cindex @option{^-m^/ERROR_LIMIT^} (@command{gnatbind}) +Limit number of detected errors or warnings to @var{n}, where @var{n} is +in the range 1..999999. The default value if no switch is +given is 9999. If the number of warnings reaches this limit, then a +message is output and further warnings are suppressed, the bind +continues in this case. If the number of errors reaches this +limit, then a message is output and the bind is abandoned. +A value of zero means that no limit is enforced. The equal +sign is optional. + +@ifset unw +Furthermore, under Windows, the sources pointed to by the libraries path +set in the registry are not searched for. +@end ifset + +@item ^-n^/NOMAIN^ +@cindex @option{^-n^/NOMAIN^} (@command{gnatbind}) +No main program. + +@item -nostdinc +@cindex @option{-nostdinc} (@command{gnatbind}) +Do not look for sources in the system default directory. + +@item -nostdlib +@cindex @option{-nostdlib} (@command{gnatbind}) +Do not look for library files in the system default directory. + +@item --RTS=@var{rts-path} +@cindex @option{--RTS} (@code{gnatbind}) +Specifies the default location of the runtime library. Same meaning as the +equivalent @command{gnatmake} flag (@pxref{Switches for gnatmake}). + +@item ^-o ^/OUTPUT=^@var{file} +@cindex @option{^-o ^/OUTPUT^} (@command{gnatbind}) +Name the output file @var{file} (default is @file{b~@var{xxx}.adb}). +Note that if this option is used, then linking must be done manually, +gnatlink cannot be used. + +@item ^-O^/OBJECT_LIST^@r{[=}@var{filename}@r{]} +@cindex @option{^-O^/OBJECT_LIST^} (@command{gnatbind}) +Output object list (to standard output or to the named file). + +@item ^-p^/PESSIMISTIC_ELABORATION^ +@cindex @option{^-p^/PESSIMISTIC_ELABORATION^} (@command{gnatbind}) +Pessimistic (worst-case) elaboration order + +@item ^-R^-R^ +@cindex @option{^-R^-R^} (@command{gnatbind}) +Output closure source list. + +@item ^-s^/READ_SOURCES=ALL^ +@cindex @option{^-s^/READ_SOURCES=ALL^} (@command{gnatbind}) +Require all source files to be present. + +@item ^-S@var{xxx}^/INITIALIZE_SCALARS=@var{xxx}^ +@cindex @option{^-S^/INITIALIZE_SCALARS^} (@command{gnatbind}) +Specifies the value to be used when detecting uninitialized scalar +objects with pragma Initialize_Scalars. +The @var{xxx} ^string specified with the switch^option^ may be either +@itemize @bullet +@item ``@option{^in^INVALID^}'' requesting an invalid value where possible +@item ``@option{^lo^LOW^}'' for the lowest possible value +@item ``@option{^hi^HIGH^}'' for the highest possible value +@item ``@option{@var{xx}}'' for a value consisting of repeated bytes with the +value @code{16#@var{xx}#} (i.e., @var{xx} is a string of two hexadecimal digits). +@end itemize + +In addition, you can specify @option{-Sev} to indicate that the value is +to be set at run time. In this case, the program will look for an environment +@cindex GNAT_INIT_SCALARS +variable of the form @env{GNAT_INIT_SCALARS=@var{xx}}, where @var{xx} is one +of @option{in/lo/hi/@var{xx}} with the same meanings as above. +If no environment variable is found, or if it does not have a valid value, +then the default is @option{in} (invalid values). + +@ifclear vms +@item -static +@cindex @option{-static} (@code{gnatbind}) +Link against a static GNAT run time. + +@item -shared +@cindex @option{-shared} (@code{gnatbind}) +Link against a shared GNAT run time when available. +@end ifclear + +@item ^-t^/NOTIME_STAMP_CHECK^ +@cindex @option{^-t^/NOTIME_STAMP_CHECK^} (@code{gnatbind}) +Tolerate time stamp and other consistency errors + +@item ^-T@var{n}^/TIME_SLICE=@var{n}^ +@cindex @option{^-T^/TIME_SLICE^} (@code{gnatbind}) +Set the time slice value to @var{n} milliseconds. If the system supports +the specification of a specific time slice value, then the indicated value +is used. If the system does not support specific time slice values, but +does support some general notion of round-robin scheduling, then any +nonzero value will activate round-robin scheduling. + +A value of zero is treated specially. It turns off time +slicing, and in addition, indicates to the tasking run time that the +semantics should match as closely as possible the Annex D +requirements of the Ada RM, and in particular sets the default +scheduling policy to @code{FIFO_Within_Priorities}. + +@item ^-u@var{n}^/DYNAMIC_STACK_USAGE=@var{n}^ +@cindex @option{^-u^/DYNAMIC_STACK_USAGE^} (@code{gnatbind}) +Enable dynamic stack usage, with @var{n} results stored and displayed +at program termination. A result is generated when a task +terminates. Results that can't be stored are displayed on the fly, at +task termination. This option is currently not supported on Itanium +platforms. (See @ref{Dynamic Stack Usage Analysis} for details.) + +@item ^-v^/REPORT_ERRORS=VERBOSE^ +@cindex @option{^-v^/REPORT_ERRORS=VERBOSE^} (@code{gnatbind}) +Verbose mode. Write error messages, header, summary output to +@file{stdout}. + +@ifclear vms +@item -w@var{x} +@cindex @option{-w} (@code{gnatbind}) +Warning mode (@var{x}=s/e for suppress/treat as error) +@end ifclear + +@ifset vms +@item /WARNINGS=NORMAL +@cindex @option{/WARNINGS} (@code{gnatbind}) +Normal warnings mode. Warnings are issued but ignored + +@item /WARNINGS=SUPPRESS +@cindex @option{/WARNINGS} (@code{gnatbind}) +All warning messages are suppressed + +@item /WARNINGS=ERROR +@cindex @option{/WARNINGS} (@code{gnatbind}) +Warning messages are treated as fatal errors +@end ifset + +@item ^-Wx^/WIDE_CHARACTER_ENCODING=^@var{e} +@cindex @option{^-Wx^/WIDE_CHARACTER_ENCODING^} (@code{gnatbind}) +Override default wide character encoding for standard Text_IO files. + +@item ^-x^/READ_SOURCES=NONE^ +@cindex @option{^-x^/READ_SOURCES^} (@code{gnatbind}) +Exclude source files (check object consistency only). + +@ifset vms +@item /READ_SOURCES=AVAILABLE +@cindex @option{/READ_SOURCES} (@code{gnatbind}) +Default mode, in which sources are checked for consistency only if +they are available. +@end ifset + +@item ^-y^/ENABLE_LEAP_SECONDS^ +@cindex @option{^-y^/ENABLE_LEAP_SECONDS^} (@code{gnatbind}) +Enable leap seconds support in @code{Ada.Calendar} and its children. + +@item ^-z^/ZERO_MAIN^ +@cindex @option{^-z^/ZERO_MAIN^} (@code{gnatbind}) +No main subprogram. +@end table + +@ifclear vms +@noindent +You may obtain this listing of switches by running @code{gnatbind} with +no arguments. +@end ifclear + +@node Consistency-Checking Modes +@subsection Consistency-Checking Modes + +@noindent +As described earlier, by default @code{gnatbind} checks +that object files are consistent with one another and are consistent +with any source files it can locate. The following switches control binder +access to sources. + +@table @option +@c !sort! +@item ^-s^/READ_SOURCES=ALL^ +@cindex @option{^-s^/READ_SOURCES=ALL^} (@code{gnatbind}) +Require source files to be present. In this mode, the binder must be +able to locate all source files that are referenced, in order to check +their consistency. In normal mode, if a source file cannot be located it +is simply ignored. If you specify this switch, a missing source +file is an error. + +@item ^-Wx^/WIDE_CHARACTER_ENCODING=^@var{e} +@cindex @option{^-Wx^/WIDE_CHARACTER_ENCODING^} (@code{gnatbind}) +Override default wide character encoding for standard Text_IO files. +Normally the default wide character encoding method used for standard +[Wide_[Wide_]]Text_IO files is taken from the encoding specified for +the main source input (see description of switch +@option{^-gnatWx^/WIDE_CHARACTER_ENCODING^} for the compiler). The +use of this switch for the binder (which has the same set of +possible arguments) overrides this default as specified. + +@item ^-x^/READ_SOURCES=NONE^ +@cindex @option{^-x^/READ_SOURCES=NONE^} (@code{gnatbind}) +Exclude source files. In this mode, the binder only checks that ALI +files are consistent with one another. Source files are not accessed. +The binder runs faster in this mode, and there is still a guarantee that +the resulting program is self-consistent. +If a source file has been edited since it was last compiled, and you +specify this switch, the binder will not detect that the object +file is out of date with respect to the source file. Note that this is the +mode that is automatically used by @command{gnatmake} because in this +case the checking against sources has already been performed by +@command{gnatmake} in the course of compilation (i.e.@: before binding). + +@ifset vms +@item /READ_SOURCES=AVAILABLE +@cindex @code{/READ_SOURCES=AVAILABLE} (@code{gnatbind}) +This is the default mode in which source files are checked if they are +available, and ignored if they are not available. +@end ifset +@end table + +@node Binder Error Message Control +@subsection Binder Error Message Control + +@noindent +The following switches provide control over the generation of error +messages from the binder: + +@table @option +@c !sort! +@item ^-v^/REPORT_ERRORS=VERBOSE^ +@cindex @option{^-v^/REPORT_ERRORS=VERBOSE^} (@code{gnatbind}) +Verbose mode. In the normal mode, brief error messages are generated to +@file{stderr}. If this switch is present, a header is written +to @file{stdout} and any error messages are directed to @file{stdout}. +All that is written to @file{stderr} is a brief summary message. + +@item ^-b^/REPORT_ERRORS=BRIEF^ +@cindex @option{^-b^/REPORT_ERRORS=BRIEF^} (@code{gnatbind}) +Generate brief error messages to @file{stderr} even if verbose mode is +specified. This is relevant only when used with the +@option{^-v^/REPORT_ERRORS=VERBOSE^} switch. + +@ifclear vms +@item -m@var{n} +@cindex @option{-m} (@code{gnatbind}) +Limits the number of error messages to @var{n}, a decimal integer in the +range 1-999. The binder terminates immediately if this limit is reached. + +@item -M@var{xxx} +@cindex @option{-M} (@code{gnatbind}) +Renames the generated main program from @code{main} to @code{xxx}. +This is useful in the case of some cross-building environments, where +the actual main program is separate from the one generated +by @code{gnatbind}. +@end ifclear + +@item ^-ws^/WARNINGS=SUPPRESS^ +@cindex @option{^-ws^/WARNINGS=SUPPRESS^} (@code{gnatbind}) +@cindex Warnings +Suppress all warning messages. + +@item ^-we^/WARNINGS=ERROR^ +@cindex @option{^-we^/WARNINGS=ERROR^} (@code{gnatbind}) +Treat any warning messages as fatal errors. + +@ifset vms +@item /WARNINGS=NORMAL +Standard mode with warnings generated, but warnings do not get treated +as errors. +@end ifset + +@item ^-t^/NOTIME_STAMP_CHECK^ +@cindex @option{^-t^/NOTIME_STAMP_CHECK^} (@code{gnatbind}) +@cindex Time stamp checks, in binder +@cindex Binder consistency checks +@cindex Consistency checks, in binder +The binder performs a number of consistency checks including: + +@itemize @bullet +@item +Check that time stamps of a given source unit are consistent +@item +Check that checksums of a given source unit are consistent +@item +Check that consistent versions of @code{GNAT} were used for compilation +@item +Check consistency of configuration pragmas as required +@end itemize + +@noindent +Normally failure of such checks, in accordance with the consistency +requirements of the Ada Reference Manual, causes error messages to be +generated which abort the binder and prevent the output of a binder +file and subsequent link to obtain an executable. + +The @option{^-t^/NOTIME_STAMP_CHECK^} switch converts these error messages +into warnings, so that +binding and linking can continue to completion even in the presence of such +errors. The result may be a failed link (due to missing symbols), or a +non-functional executable which has undefined semantics. +@emph{This means that +@option{^-t^/NOTIME_STAMP_CHECK^} should be used only in unusual situations, +with extreme care.} +@end table + +@node Elaboration Control +@subsection Elaboration Control + +@noindent +The following switches provide additional control over the elaboration +order. For full details see @ref{Elaboration Order Handling in GNAT}. + +@table @option +@item ^-p^/PESSIMISTIC_ELABORATION^ +@cindex @option{^-p^/PESSIMISTIC_ELABORATION^} (@code{gnatbind}) +Normally the binder attempts to choose an elaboration order that is +likely to minimize the likelihood of an elaboration order error resulting +in raising a @code{Program_Error} exception. This switch reverses the +action of the binder, and requests that it deliberately choose an order +that is likely to maximize the likelihood of an elaboration error. +This is useful in ensuring portability and avoiding dependence on +accidental fortuitous elaboration ordering. + +Normally it only makes sense to use the @option{^-p^/PESSIMISTIC_ELABORATION^} +switch if dynamic +elaboration checking is used (@option{-gnatE} switch used for compilation). +This is because in the default static elaboration mode, all necessary +@code{Elaborate} and @code{Elaborate_All} pragmas are implicitly inserted. +These implicit pragmas are still respected by the binder in +@option{^-p^/PESSIMISTIC_ELABORATION^} mode, so a +safe elaboration order is assured. +@end table + +@node Output Control +@subsection Output Control + +@noindent +The following switches allow additional control over the output +generated by the binder. + +@table @option +@c !sort! + +@item ^-c^/NOOUTPUT^ +@cindex @option{^-c^/NOOUTPUT^} (@code{gnatbind}) +Check only. Do not generate the binder output file. In this mode the +binder performs all error checks but does not generate an output file. + +@item ^-e^/ELABORATION_DEPENDENCIES^ +@cindex @option{^-e^/ELABORATION_DEPENDENCIES^} (@code{gnatbind}) +Output complete list of elaboration-order dependencies, showing the +reason for each dependency. This output can be rather extensive but may +be useful in diagnosing problems with elaboration order. The output is +written to @file{stdout}. + +@item ^-h^/HELP^ +@cindex @option{^-h^/HELP^} (@code{gnatbind}) +Output usage information. The output is written to @file{stdout}. + +@item ^-K^/LINKER_OPTION_LIST^ +@cindex @option{^-K^/LINKER_OPTION_LIST^} (@code{gnatbind}) +Output linker options to @file{stdout}. Includes library search paths, +contents of pragmas Ident and Linker_Options, and libraries added +by @code{gnatbind}. + +@item ^-l^/ORDER_OF_ELABORATION^ +@cindex @option{^-l^/ORDER_OF_ELABORATION^} (@code{gnatbind}) +Output chosen elaboration order. The output is written to @file{stdout}. + +@item ^-O^/OBJECT_LIST^ +@cindex @option{^-O^/OBJECT_LIST^} (@code{gnatbind}) +Output full names of all the object files that must be linked to provide +the Ada component of the program. The output is written to @file{stdout}. +This list includes the files explicitly supplied and referenced by the user +as well as implicitly referenced run-time unit files. The latter are +omitted if the corresponding units reside in shared libraries. The +directory names for the run-time units depend on the system configuration. + +@item ^-o ^/OUTPUT=^@var{file} +@cindex @option{^-o^/OUTPUT^} (@code{gnatbind}) +Set name of output file to @var{file} instead of the normal +@file{b~@var{mainprog}.adb} default. Note that @var{file} denote the Ada +binder generated body filename. +Note that if this option is used, then linking must be done manually. +It is not possible to use gnatlink in this case, since it cannot locate +the binder file. + +@item ^-r^/RESTRICTION_LIST^ +@cindex @option{^-r^/RESTRICTION_LIST^} (@code{gnatbind}) +Generate list of @code{pragma Restrictions} that could be applied to +the current unit. This is useful for code audit purposes, and also may +be used to improve code generation in some cases. + +@end table + +@node Dynamic Allocation Control +@subsection Dynamic Allocation Control + +@noindent +The heap control switches -- @option{-H32} and @option{-H64} -- +determine whether dynamic allocation uses 32-bit or 64-bit memory. +They only affect compiler-generated allocations via @code{__gnat_malloc}; +explicit calls to @code{malloc} and related functions from the C +run-time library are unaffected. + +@table @option +@item -H32 +Allocate memory on 32-bit heap + +@item -H64 +Allocate memory on 64-bit heap. This is the default +unless explicitly overridden by a @code{'Size} clause on the access type. +@end table + +@ifset vms +@noindent +See also @ref{Access types and 32/64-bit allocation}. +@end ifset +@ifclear vms +@noindent +These switches are only effective on VMS platforms. +@end ifclear + + +@node Binding with Non-Ada Main Programs +@subsection Binding with Non-Ada Main Programs + +@noindent +In our description so far we have assumed that the main +program is in Ada, and that the task of the binder is to generate a +corresponding function @code{main} that invokes this Ada main +program. GNAT also supports the building of executable programs where +the main program is not in Ada, but some of the called routines are +written in Ada and compiled using GNAT (@pxref{Mixed Language Programming}). +The following switch is used in this situation: + +@table @option +@item ^-n^/NOMAIN^ +@cindex @option{^-n^/NOMAIN^} (@code{gnatbind}) +No main program. The main program is not in Ada. +@end table + +@noindent +In this case, most of the functions of the binder are still required, +but instead of generating a main program, the binder generates a file +containing the following callable routines: + +@table @code +@item adainit +@findex adainit +You must call this routine to initialize the Ada part of the program by +calling the necessary elaboration routines. A call to @code{adainit} is +required before the first call to an Ada subprogram. + +Note that it is assumed that the basic execution environment must be setup +to be appropriate for Ada execution at the point where the first Ada +subprogram is called. In particular, if the Ada code will do any +floating-point operations, then the FPU must be setup in an appropriate +manner. For the case of the x86, for example, full precision mode is +required. The procedure GNAT.Float_Control.Reset may be used to ensure +that the FPU is in the right state. + +@item adafinal +@findex adafinal +You must call this routine to perform any library-level finalization +required by the Ada subprograms. A call to @code{adafinal} is required +after the last call to an Ada subprogram, and before the program +terminates. +@end table + +@noindent +If the @option{^-n^/NOMAIN^} switch +@cindex @option{^-n^/NOMAIN^} (@command{gnatbind}) +@cindex Binder, multiple input files +is given, more than one ALI file may appear on +the command line for @code{gnatbind}. The normal @dfn{closure} +calculation is performed for each of the specified units. Calculating +the closure means finding out the set of units involved by tracing +@code{with} references. The reason it is necessary to be able to +specify more than one ALI file is that a given program may invoke two or +more quite separate groups of Ada units. + +The binder takes the name of its output file from the last specified ALI +file, unless overridden by the use of the @option{^-o file^/OUTPUT=file^}. +@cindex @option{^-o^/OUTPUT^} (@command{gnatbind}) +The output is an Ada unit in source form that can be compiled with GNAT. +This compilation occurs automatically as part of the @command{gnatlink} +processing. + +Currently the GNAT run time requires a FPU using 80 bits mode +precision. Under targets where this is not the default it is required to +call GNAT.Float_Control.Reset before using floating point numbers (this +include float computation, float input and output) in the Ada code. A +side effect is that this could be the wrong mode for the foreign code +where floating point computation could be broken after this call. + +@node Binding Programs with No Main Subprogram +@subsection Binding Programs with No Main Subprogram + +@noindent +It is possible to have an Ada program which does not have a main +subprogram. This program will call the elaboration routines of all the +packages, then the finalization routines. + +The following switch is used to bind programs organized in this manner: + +@table @option +@item ^-z^/ZERO_MAIN^ +@cindex @option{^-z^/ZERO_MAIN^} (@code{gnatbind}) +Normally the binder checks that the unit name given on the command line +corresponds to a suitable main subprogram. When this switch is used, +a list of ALI files can be given, and the execution of the program +consists of elaboration of these units in an appropriate order. Note +that the default wide character encoding method for standard Text_IO +files is always set to Brackets if this switch is set (you can use +the binder switch +@option{^-Wx^WIDE_CHARACTER_ENCODING^} to override this default). +@end table + +@node Command-Line Access +@section Command-Line Access + +@noindent +The package @code{Ada.Command_Line} provides access to the command-line +arguments and program name. In order for this interface to operate +correctly, the two variables + +@smallexample +@group +int gnat_argc; +char **gnat_argv; +@end group +@end smallexample + +@noindent +@findex gnat_argv +@findex gnat_argc +are declared in one of the GNAT library routines. These variables must +be set from the actual @code{argc} and @code{argv} values passed to the +main program. With no @option{^n^/NOMAIN^} present, @code{gnatbind} +generates the C main program to automatically set these variables. +If the @option{^n^/NOMAIN^} switch is used, there is no automatic way to +set these variables. If they are not set, the procedures in +@code{Ada.Command_Line} will not be available, and any attempt to use +them will raise @code{Constraint_Error}. If command line access is +required, your main program must set @code{gnat_argc} and +@code{gnat_argv} from the @code{argc} and @code{argv} values passed to +it. + +@node Search Paths for gnatbind +@section Search Paths for @code{gnatbind} + +@noindent +The binder takes the name of an ALI file as its argument and needs to +locate source files as well as other ALI files to verify object consistency. + +For source files, it follows exactly the same search rules as @command{gcc} +(@pxref{Search Paths and the Run-Time Library (RTL)}). For ALI files the +directories searched are: + +@enumerate +@item +The directory containing the ALI file named in the command line, unless +the switch @option{^-I-^/NOCURRENT_DIRECTORY^} is specified. + +@item +All directories specified by @option{^-I^/SEARCH^} +switches on the @code{gnatbind} +command line, in the order given. + +@item +@findex ADA_PRJ_OBJECTS_FILE +Each of the directories listed in the text file whose name is given +by the @env{ADA_PRJ_OBJECTS_FILE} ^environment variable^logical name^. + +@noindent +@env{ADA_PRJ_OBJECTS_FILE} is normally set by gnatmake or by the ^gnat^GNAT^ +driver when project files are used. It should not normally be set +by other means. + +@item +@findex ADA_OBJECTS_PATH +Each of the directories listed in the value of the +@env{ADA_OBJECTS_PATH} ^environment variable^logical name^. +@ifset unw +Construct this value +exactly as the @env{PATH} environment variable: a list of directory +names separated by colons (semicolons when working with the NT version +of GNAT). +@end ifset +@ifset vms +Normally, define this value as a logical name containing a comma separated +list of directory names. + +This variable can also be defined by means of an environment string +(an argument to the HP C exec* set of functions). + +Logical Name: +@smallexample +DEFINE ANOTHER_PATH FOO:[BAG] +DEFINE ADA_OBJECTS_PATH ANOTHER_PATH,FOO:[BAM],FOO:[BAR] +@end smallexample + +By default, the path includes GNU:[LIB.OPENVMS7_x.2_8_x.DECLIB] +first, followed by the standard Ada +libraries in GNU:[LIB.OPENVMS7_x.2_8_x.ADALIB]. +If this is not redefined, the user will obtain the HP Ada 83 IO packages +(Text_IO, Sequential_IO, etc) +instead of the standard Ada packages. Thus, in order to get the standard Ada +packages by default, ADA_OBJECTS_PATH must be redefined. +@end ifset + +@item +The content of the @file{ada_object_path} file which is part of the GNAT +installation tree and is used to store standard libraries such as the +GNAT Run Time Library (RTL) unless the switch @option{-nostdlib} is +specified. +@ifclear vms +@ref{Installing a library} +@end ifclear +@end enumerate + +@noindent +In the binder the switch @option{^-I^/SEARCH^} +@cindex @option{^-I^/SEARCH^} (@command{gnatbind}) +is used to specify both source and +library file paths. Use @option{^-aI^/SOURCE_SEARCH^} +@cindex @option{^-aI^/SOURCE_SEARCH^} (@command{gnatbind}) +instead if you want to specify +source paths only, and @option{^-aO^/LIBRARY_SEARCH^} +@cindex @option{^-aO^/LIBRARY_SEARCH^} (@command{gnatbind}) +if you want to specify library paths +only. This means that for the binder +@option{^-I^/SEARCH=^}@var{dir} is equivalent to +@option{^-aI^/SOURCE_SEARCH=^}@var{dir} +@option{^-aO^/OBJECT_SEARCH=^}@var{dir}. +The binder generates the bind file (a C language source file) in the +current working directory. + +@findex Ada +@findex System +@findex Interfaces +@findex GNAT +The packages @code{Ada}, @code{System}, and @code{Interfaces} and their +children make up the GNAT Run-Time Library, together with the package +GNAT and its children, which contain a set of useful additional +library functions provided by GNAT. The sources for these units are +needed by the compiler and are kept together in one directory. The ALI +files and object files generated by compiling the RTL are needed by the +binder and the linker and are kept together in one directory, typically +different from the directory containing the sources. In a normal +installation, you need not specify these directory names when compiling +or binding. Either the environment variables or the built-in defaults +cause these files to be found. + +Besides simplifying access to the RTL, a major use of search paths is +in compiling sources from multiple directories. This can make +development environments much more flexible. + +@node Examples of gnatbind Usage +@section Examples of @code{gnatbind} Usage + +@noindent +This section contains a number of examples of using the GNAT binding +utility @code{gnatbind}. + +@table @code +@item gnatbind hello +The main program @code{Hello} (source program in @file{hello.adb}) is +bound using the standard switch settings. The generated main program is +@file{b~hello.adb}. This is the normal, default use of the binder. + +@ifclear vms +@item gnatbind hello -o mainprog.adb +@end ifclear +@ifset vms +@item gnatbind HELLO.ALI /OUTPUT=Mainprog.ADB +@end ifset +The main program @code{Hello} (source program in @file{hello.adb}) is +bound using the standard switch settings. The generated main program is +@file{mainprog.adb} with the associated spec in +@file{mainprog.ads}. Note that you must specify the body here not the +spec. Note that if this option is used, then linking must be done manually, +since gnatlink will not be able to find the generated file. +@end table + +@c ------------------------------------ +@node Linking Using gnatlink +@chapter Linking Using @command{gnatlink} +@c ------------------------------------ +@findex gnatlink + +@noindent +This chapter discusses @command{gnatlink}, a tool that links +an Ada program and builds an executable file. This utility +invokes the system linker ^(via the @command{gcc} command)^^ +with a correct list of object files and library references. +@command{gnatlink} automatically determines the list of files and +references for the Ada part of a program. It uses the binder file +generated by the @command{gnatbind} to determine this list. + +Note: to invoke @code{gnatlink} with a project file, use the @code{gnat} +driver (see @ref{The GNAT Driver and Project Files}). + +@menu +* Running gnatlink:: +* Switches for gnatlink:: +@end menu + +@node Running gnatlink +@section Running @command{gnatlink} + +@noindent +The form of the @command{gnatlink} command is + +@smallexample +@c $ gnatlink @ovar{switches} @var{mainprog}@r{[}.ali@r{]} +@c @ovar{non-Ada objects} @ovar{linker options} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatlink @r{[}@var{switches}@r{]} @var{mainprog}@r{[}.ali@r{]} + @r{[}@var{non-Ada objects}@r{]} @r{[}@var{linker options}@r{]} + +@end smallexample + +@noindent +The arguments of @command{gnatlink} (switches, main @file{ALI} file, +non-Ada objects +or linker options) may be in any order, provided that no non-Ada object may +be mistaken for a main @file{ALI} file. +Any file name @file{F} without the @file{.ali} +extension will be taken as the main @file{ALI} file if a file exists +whose name is the concatenation of @file{F} and @file{.ali}. + +@noindent +@file{@var{mainprog}.ali} references the ALI file of the main program. +The @file{.ali} extension of this file can be omitted. From this +reference, @command{gnatlink} locates the corresponding binder file +@file{b~@var{mainprog}.adb} and, using the information in this file along +with the list of non-Ada objects and linker options, constructs a +linker command file to create the executable. + +The arguments other than the @command{gnatlink} switches and the main +@file{ALI} file are passed to the linker uninterpreted. +They typically include the names of +object files for units written in other languages than Ada and any library +references required to resolve references in any of these foreign language +units, or in @code{Import} pragmas in any Ada units. + +@var{linker options} is an optional list of linker specific +switches. +The default linker called by gnatlink is @command{gcc} which in +turn calls the appropriate system linker. + +One useful option for the linker is @option{-s}: it reduces the size of the +executable by removing all symbol table and relocation information from the +executable. + +Standard options for the linker such as @option{-lmy_lib} or +@option{-Ldir} can be added as is. +For options that are not recognized by +@command{gcc} as linker options, use the @command{gcc} switches +@option{-Xlinker} or @option{-Wl,}. + +Refer to the GCC documentation for +details. + +Here is an example showing how to generate a linker map: + +@smallexample +$ ^gnatlink my_prog -Wl,-Map,MAPFILE^GNAT LINK my_prog.ali /MAP^ +@end smallexample + +Using @var{linker options} it is possible to set the program stack and +heap size. +@ifset unw +See @ref{Setting Stack Size from gnatlink} and +@ref{Setting Heap Size from gnatlink}. +@end ifset + +@command{gnatlink} determines the list of objects required by the Ada +program and prepends them to the list of objects passed to the linker. +@command{gnatlink} also gathers any arguments set by the use of +@code{pragma Linker_Options} and adds them to the list of arguments +presented to the linker. + +@ifset vms +@command{gnatlink} accepts the following types of extra files on the command +line: objects (@file{.OBJ}), libraries (@file{.OLB}), sharable images +(@file{.EXE}), and options files (@file{.OPT}). These are recognized and +handled according to their extension. +@end ifset + +@node Switches for gnatlink +@section Switches for @command{gnatlink} + +@noindent +The following switches are available with the @command{gnatlink} utility: + +@table @option +@c !sort! + +@item --version +@cindex @option{--version} @command{gnatlink} +Display Copyright and version, then exit disregarding all other options. + +@item --help +@cindex @option{--help} @command{gnatlink} +If @option{--version} was not used, display usage, then exit disregarding +all other options. + +@item ^-f^/FORCE_OBJECT_FILE_LIST^ +@cindex Command line length +@cindex @option{^-f^/FORCE_OBJECT_FILE_LIST^} (@command{gnatlink}) +On some targets, the command line length is limited, and @command{gnatlink} +will generate a separate file for the linker if the list of object files +is too long. +The @option{^-f^/FORCE_OBJECT_FILE_LIST^} switch forces this file +to be generated even if +the limit is not exceeded. This is useful in some cases to deal with +special situations where the command line length is exceeded. + +@item ^-g^/DEBUG^ +@cindex Debugging information, including +@cindex @option{^-g^/DEBUG^} (@command{gnatlink}) +The option to include debugging information causes the Ada bind file (in +other words, @file{b~@var{mainprog}.adb}) to be compiled with +@option{^-g^/DEBUG^}. +In addition, the binder does not delete the @file{b~@var{mainprog}.adb}, +@file{b~@var{mainprog}.o} and @file{b~@var{mainprog}.ali} files. +Without @option{^-g^/DEBUG^}, the binder removes these files by +default. The same procedure apply if a C bind file was generated using +@option{^-C^/BIND_FILE=C^} @code{gnatbind} option, in this case the filenames +are @file{b_@var{mainprog}.c} and @file{b_@var{mainprog}.o}. + +@item ^-n^/NOCOMPILE^ +@cindex @option{^-n^/NOCOMPILE^} (@command{gnatlink}) +Do not compile the file generated by the binder. This may be used when +a link is rerun with different options, but there is no need to recompile +the binder file. + +@item ^-v^/VERBOSE^ +@cindex @option{^-v^/VERBOSE^} (@command{gnatlink}) +Causes additional information to be output, including a full list of the +included object files. This switch option is most useful when you want +to see what set of object files are being used in the link step. + +@item ^-v -v^/VERBOSE/VERBOSE^ +@cindex @option{^-v -v^/VERBOSE/VERBOSE^} (@command{gnatlink}) +Very verbose mode. Requests that the compiler operate in verbose mode when +it compiles the binder file, and that the system linker run in verbose mode. + +@item ^-o ^/EXECUTABLE=^@var{exec-name} +@cindex @option{^-o^/EXECUTABLE^} (@command{gnatlink}) +@var{exec-name} specifies an alternate name for the generated +executable program. If this switch is omitted, the executable has the same +name as the main unit. For example, @code{gnatlink try.ali} creates +an executable called @file{^try^TRY.EXE^}. + +@ifclear vms +@item -b @var{target} +@cindex @option{-b} (@command{gnatlink}) +Compile your program to run on @var{target}, which is the name of a +system configuration. You must have a GNAT cross-compiler built if +@var{target} is not the same as your host system. + +@item -B@var{dir} +@cindex @option{-B} (@command{gnatlink}) +Load compiler executables (for example, @code{gnat1}, the Ada compiler) +from @var{dir} instead of the default location. Only use this switch +when multiple versions of the GNAT compiler are available. +@xref{Directory Options,,, gcc, The GNU Compiler Collection}, +for further details. You would normally use the @option{-b} or +@option{-V} switch instead. + +@item --GCC=@var{compiler_name} +@cindex @option{--GCC=compiler_name} (@command{gnatlink}) +Program used for compiling the binder file. The default is +@command{gcc}. You need to use quotes around @var{compiler_name} if +@code{compiler_name} contains spaces or other separator characters. +As an example @option{--GCC="foo -x -y"} will instruct @command{gnatlink} to +use @code{foo -x -y} as your compiler. Note that switch @option{-c} is always +inserted after your command name. Thus in the above example the compiler +command that will be used by @command{gnatlink} will be @code{foo -c -x -y}. +A limitation of this syntax is that the name and path name of the executable +itself must not include any embedded spaces. If the compiler executable is +different from the default one (gcc or -gcc), then the back-end +switches in the ALI file are not used to compile the binder generated source. +For example, this is the case with @option{--GCC="foo -x -y"}. But the back end +switches will be used for @option{--GCC="gcc -gnatv"}. If several +@option{--GCC=compiler_name} are used, only the last @var{compiler_name} +is taken into account. However, all the additional switches are also taken +into account. Thus, +@option{--GCC="foo -x -y" --GCC="bar -z -t"} is equivalent to +@option{--GCC="bar -x -y -z -t"}. + +@item --LINK=@var{name} +@cindex @option{--LINK=} (@command{gnatlink}) +@var{name} is the name of the linker to be invoked. This is especially +useful in mixed language programs since languages such as C++ require +their own linker to be used. When this switch is omitted, the default +name for the linker is @command{gcc}. When this switch is used, the +specified linker is called instead of @command{gcc} with exactly the same +parameters that would have been passed to @command{gcc} so if the desired +linker requires different parameters it is necessary to use a wrapper +script that massages the parameters before invoking the real linker. It +may be useful to control the exact invocation by using the verbose +switch. + +@end ifclear + +@ifset vms +@item /DEBUG=TRACEBACK +@cindex @code{/DEBUG=TRACEBACK} (@command{gnatlink}) +This qualifier causes sufficient information to be included in the +executable file to allow a traceback, but does not include the full +symbol information needed by the debugger. + +@item /IDENTIFICATION="" +@code{""} specifies the string to be stored in the image file +identification field in the image header. +It overrides any pragma @code{Ident} specified string. + +@item /NOINHIBIT-EXEC +Generate the executable file even if there are linker warnings. + +@item /NOSTART_FILES +Don't link in the object file containing the ``main'' transfer address. +Used when linking with a foreign language main program compiled with an +HP compiler. + +@item /STATIC +Prefer linking with object libraries over sharable images, even without +/DEBUG. +@end ifset + +@end table + +@node The GNAT Make Program gnatmake +@chapter The GNAT Make Program @command{gnatmake} +@findex gnatmake + +@menu +* Running gnatmake:: +* Switches for gnatmake:: +* Mode Switches for gnatmake:: +* Notes on the Command Line:: +* How gnatmake Works:: +* Examples of gnatmake Usage:: +@end menu +@noindent +A typical development cycle when working on an Ada program consists of +the following steps: + +@enumerate +@item +Edit some sources to fix bugs. + +@item +Add enhancements. + +@item +Compile all sources affected. + +@item +Rebind and relink. + +@item +Test. +@end enumerate + +@noindent +The third step can be tricky, because not only do the modified files +@cindex Dependency rules +have to be compiled, but any files depending on these files must also be +recompiled. The dependency rules in Ada can be quite complex, especially +in the presence of overloading, @code{use} clauses, generics and inlined +subprograms. + +@command{gnatmake} automatically takes care of the third and fourth steps +of this process. It determines which sources need to be compiled, +compiles them, and binds and links the resulting object files. + +Unlike some other Ada make programs, the dependencies are always +accurately recomputed from the new sources. The source based approach of +the GNAT compilation model makes this possible. This means that if +changes to the source program cause corresponding changes in +dependencies, they will always be tracked exactly correctly by +@command{gnatmake}. + +@node Running gnatmake +@section Running @command{gnatmake} + +@noindent +The usual form of the @command{gnatmake} command is + +@smallexample +@c $ gnatmake @ovar{switches} @var{file_name} +@c @ovar{file_names} @ovar{mode_switches} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatmake @r{[}@var{switches}@r{]} @var{file_name} + @r{[}@var{file_names}@r{]} @r{[}@var{mode_switches}@r{]} +@end smallexample + +@noindent +The only required argument is one @var{file_name}, which specifies +a compilation unit that is a main program. Several @var{file_names} can be +specified: this will result in several executables being built. +If @code{switches} are present, they can be placed before the first +@var{file_name}, between @var{file_names} or after the last @var{file_name}. +If @var{mode_switches} are present, they must always be placed after +the last @var{file_name} and all @code{switches}. + +If you are using standard file extensions (@file{.adb} and @file{.ads}), then the +extension may be omitted from the @var{file_name} arguments. However, if +you are using non-standard extensions, then it is required that the +extension be given. A relative or absolute directory path can be +specified in a @var{file_name}, in which case, the input source file will +be searched for in the specified directory only. Otherwise, the input +source file will first be searched in the directory where +@command{gnatmake} was invoked and if it is not found, it will be search on +the source path of the compiler as described in +@ref{Search Paths and the Run-Time Library (RTL)}. + +All @command{gnatmake} output (except when you specify +@option{^-M^/DEPENDENCIES_LIST^}) is to +@file{stderr}. The output produced by the +@option{^-M^/DEPENDENCIES_LIST^} switch is send to +@file{stdout}. + +@node Switches for gnatmake +@section Switches for @command{gnatmake} + +@noindent +You may specify any of the following switches to @command{gnatmake}: + +@table @option +@c !sort! + +@item --version +@cindex @option{--version} @command{gnatmake} +Display Copyright and version, then exit disregarding all other options. + +@item --help +@cindex @option{--help} @command{gnatmake} +If @option{--version} was not used, display usage, then exit disregarding +all other options. + +@ifclear vms +@item --GCC=@var{compiler_name} +@cindex @option{--GCC=compiler_name} (@command{gnatmake}) +Program used for compiling. The default is `@command{gcc}'. You need to use +quotes around @var{compiler_name} if @code{compiler_name} contains +spaces or other separator characters. As an example @option{--GCC="foo -x +-y"} will instruct @command{gnatmake} to use @code{foo -x -y} as your +compiler. A limitation of this syntax is that the name and path name of +the executable itself must not include any embedded spaces. Note that +switch @option{-c} is always inserted after your command name. Thus in the +above example the compiler command that will be used by @command{gnatmake} +will be @code{foo -c -x -y}. If several @option{--GCC=compiler_name} are +used, only the last @var{compiler_name} is taken into account. However, +all the additional switches are also taken into account. Thus, +@option{--GCC="foo -x -y" --GCC="bar -z -t"} is equivalent to +@option{--GCC="bar -x -y -z -t"}. + +@item --GNATBIND=@var{binder_name} +@cindex @option{--GNATBIND=binder_name} (@command{gnatmake}) +Program used for binding. The default is `@code{gnatbind}'. You need to +use quotes around @var{binder_name} if @var{binder_name} contains spaces +or other separator characters. As an example @option{--GNATBIND="bar -x +-y"} will instruct @command{gnatmake} to use @code{bar -x -y} as your +binder. Binder switches that are normally appended by @command{gnatmake} +to `@code{gnatbind}' are now appended to the end of @code{bar -x -y}. +A limitation of this syntax is that the name and path name of the executable +itself must not include any embedded spaces. + +@item --GNATLINK=@var{linker_name} +@cindex @option{--GNATLINK=linker_name} (@command{gnatmake}) +Program used for linking. The default is `@command{gnatlink}'. You need to +use quotes around @var{linker_name} if @var{linker_name} contains spaces +or other separator characters. As an example @option{--GNATLINK="lan -x +-y"} will instruct @command{gnatmake} to use @code{lan -x -y} as your +linker. Linker switches that are normally appended by @command{gnatmake} to +`@command{gnatlink}' are now appended to the end of @code{lan -x -y}. +A limitation of this syntax is that the name and path name of the executable +itself must not include any embedded spaces. + +@end ifclear + +@item ^--subdirs^/SUBDIRS^=subdir +Actual object directory of each project file is the subdirectory subdir of the +object directory specified or defaulted in the project file. + +@item ^--single-compile-per-obj-dir^/SINGLE_COMPILE_PER_OBJ_DIR^ +Disallow simultaneous compilations in the same object directory when +project files are used. + +@item ^--unchecked-shared-lib-imports^/UNCHECKED_SHARED_LIB_IMPORTS^ +By default, shared library projects are not allowed to import static library +projects. When this switch is used on the command line, this restriction is +relaxed. + +@item ^--source-info=^/SRC_INFO=source-info-file^ +Specify a source info file. This switch is active only when project files +are used. If the source info file is specified as a relative path, then it is +relative to the object directory of the main project. If the source info file +does not exist, then after the Project Manager has successfully parsed and +processed the project files and found the sources, it creates the source info +file. If the source info file already exists and can be read successfully, +then the Project Manager will get all the needed information about the sources +from the source info file and will not look for them. This reduces the time +to process the project files, especially when looking for sources that take a +long time. If the source info file exists but cannot be parsed successfully, +the Project Manager will attempt to recreate it. If the Project Manager fails +to create the source info file, a message is issued, but gnatmake does not +fail. + +@ifclear vms +@item --create-map-file +When linking an executable, create a map file. The name of the map file +has the same name as the executable with extension ".map". + +@item --create-map-file=mapfile +When linking an executable, create a map file. The name of the map file is +"mapfile". + +@end ifclear + +@item ^-a^/ALL_FILES^ +@cindex @option{^-a^/ALL_FILES^} (@command{gnatmake}) +Consider all files in the make process, even the GNAT internal system +files (for example, the predefined Ada library files), as well as any +locked files. Locked files are files whose ALI file is write-protected. +By default, +@command{gnatmake} does not check these files, +because the assumption is that the GNAT internal files are properly up +to date, and also that any write protected ALI files have been properly +installed. Note that if there is an installation problem, such that one +of these files is not up to date, it will be properly caught by the +binder. +You may have to specify this switch if you are working on GNAT +itself. The switch @option{^-a^/ALL_FILES^} is also useful +in conjunction with @option{^-f^/FORCE_COMPILE^} +if you need to recompile an entire application, +including run-time files, using special configuration pragmas, +such as a @code{Normalize_Scalars} pragma. + +By default +@code{gnatmake ^-a^/ALL_FILES^} compiles all GNAT +internal files with +@ifclear vms +@code{gcc -c -gnatpg} rather than @code{gcc -c}. +@end ifclear +@ifset vms +the @code{/CHECKS=SUPPRESS_ALL /STYLE_CHECKS=GNAT} switch. +@end ifset + +@item ^-b^/ACTIONS=BIND^ +@cindex @option{^-b^/ACTIONS=BIND^} (@command{gnatmake}) +Bind only. Can be combined with @option{^-c^/ACTIONS=COMPILE^} to do +compilation and binding, but no link. +Can be combined with @option{^-l^/ACTIONS=LINK^} +to do binding and linking. When not combined with +@option{^-c^/ACTIONS=COMPILE^} +all the units in the closure of the main program must have been previously +compiled and must be up to date. The root unit specified by @var{file_name} +may be given without extension, with the source extension or, if no GNAT +Project File is specified, with the ALI file extension. + +@item ^-c^/ACTIONS=COMPILE^ +@cindex @option{^-c^/ACTIONS=COMPILE^} (@command{gnatmake}) +Compile only. Do not perform binding, except when @option{^-b^/ACTIONS=BIND^} +is also specified. Do not perform linking, except if both +@option{^-b^/ACTIONS=BIND^} and +@option{^-l^/ACTIONS=LINK^} are also specified. +If the root unit specified by @var{file_name} is not a main unit, this is the +default. Otherwise @command{gnatmake} will attempt binding and linking +unless all objects are up to date and the executable is more recent than +the objects. + +@item ^-C^/MAPPING^ +@cindex @option{^-C^/MAPPING^} (@command{gnatmake}) +Use a temporary mapping file. A mapping file is a way to communicate +to the compiler two mappings: from unit names to file names (without +any directory information) and from file names to path names (with +full directory information). A mapping file can make the compiler's +file searches faster, especially if there are many source directories, +or the sources are read over a slow network connection. If +@option{^-P^/PROJECT_FILE^} is used, a mapping file is always used, so +@option{^-C^/MAPPING^} is unnecessary; in this case the mapping file +is initially populated based on the project file. If +@option{^-C^/MAPPING^} is used without +@option{^-P^/PROJECT_FILE^}, +the mapping file is initially empty. Each invocation of the compiler +will add any newly accessed sources to the mapping file. + +@item ^-C=^/USE_MAPPING_FILE=^@var{file} +@cindex @option{^-C=^/USE_MAPPING^} (@command{gnatmake}) +Use a specific mapping file. The file, specified as a path name (absolute or +relative) by this switch, should already exist, otherwise the switch is +ineffective. The specified mapping file will be communicated to the compiler. +This switch is not compatible with a project file +(^-P^/PROJECT_FILE=^@var{file}) or with multiple compiling processes +(^-j^/PROCESSES=^nnn, when nnn is greater than 1). + +@item ^-d^/DISPLAY_PROGRESS^ +@cindex @option{^-d^/DISPLAY_PROGRESS^} (@command{gnatmake}) +Display progress for each source, up to date or not, as a single line + +@smallexample +completed x out of y (zz%) +@end smallexample + +If the file needs to be compiled this is displayed after the invocation of +the compiler. These lines are displayed even in quiet output mode. + +@item ^-D ^/DIRECTORY_OBJECTS=^@var{dir} +@cindex @option{^-D^/DIRECTORY_OBJECTS^} (@command{gnatmake}) +Put all object files and ALI file in directory @var{dir}. +If the @option{^-D^/DIRECTORY_OBJECTS^} switch is not used, all object files +and ALI files go in the current working directory. + +This switch cannot be used when using a project file. + +@ifclear vms +@item -eL +@cindex @option{-eL} (@command{gnatmake}) +@cindex symbolic links +Follow all symbolic links when processing project files. +This should be used if your project uses symbolic links for files or +directories, but is not needed in other cases. + +@cindex naming scheme +This also assumes that no directory matches the naming scheme for files (for +instance that you do not have a directory called "sources.ads" when using the +default GNAT naming scheme). + +When you do not have to use this switch (i.e.@: by default), gnatmake is able to +save a lot of system calls (several per source file and object file), which +can result in a significant speed up to load and manipulate a project file, +especially when using source files from a remote system. + +@end ifclear + +@item ^-eS^/STANDARD_OUTPUT_FOR_COMMANDS^ +@cindex @option{^-eS^/STANDARD_OUTPUT_FOR_COMMANDS^} (@command{gnatmake}) +Output the commands for the compiler, the binder and the linker +on ^standard output^SYS$OUTPUT^, +instead of ^standard error^SYS$ERROR^. + +@item ^-f^/FORCE_COMPILE^ +@cindex @option{^-f^/FORCE_COMPILE^} (@command{gnatmake}) +Force recompilations. Recompile all sources, even though some object +files may be up to date, but don't recompile predefined or GNAT internal +files or locked files (files with a write-protected ALI file), +unless the @option{^-a^/ALL_FILES^} switch is also specified. + +@item ^-F^/FULL_PATH_IN_BRIEF_MESSAGES^ +@cindex @option{^-F^/FULL_PATH_IN_BRIEF_MESSAGES^} (@command{gnatmake}) +When using project files, if some errors or warnings are detected during +parsing and verbose mode is not in effect (no use of switch +^-v^/VERBOSE^), then error lines start with the full path name of the project +file, rather than its simple file name. + +@item ^-g^/DEBUG^ +@cindex @option{^-g^/DEBUG^} (@command{gnatmake}) +Enable debugging. This switch is simply passed to the compiler and to the +linker. + +@item ^-i^/IN_PLACE^ +@cindex @option{^-i^/IN_PLACE^} (@command{gnatmake}) +In normal mode, @command{gnatmake} compiles all object files and ALI files +into the current directory. If the @option{^-i^/IN_PLACE^} switch is used, +then instead object files and ALI files that already exist are overwritten +in place. This means that once a large project is organized into separate +directories in the desired manner, then @command{gnatmake} will automatically +maintain and update this organization. If no ALI files are found on the +Ada object path (@ref{Search Paths and the Run-Time Library (RTL)}), +the new object and ALI files are created in the +directory containing the source being compiled. If another organization +is desired, where objects and sources are kept in different directories, +a useful technique is to create dummy ALI files in the desired directories. +When detecting such a dummy file, @command{gnatmake} will be forced to +recompile the corresponding source file, and it will be put the resulting +object and ALI files in the directory where it found the dummy file. + +@item ^-j^/PROCESSES=^@var{n} +@cindex @option{^-j^/PROCESSES^} (@command{gnatmake}) +@cindex Parallel make +Use @var{n} processes to carry out the (re)compilations. On a +multiprocessor machine compilations will occur in parallel. In the +event of compilation errors, messages from various compilations might +get interspersed (but @command{gnatmake} will give you the full ordered +list of failing compiles at the end). If this is problematic, rerun +the make process with n set to 1 to get a clean list of messages. + +@item ^-k^/CONTINUE_ON_ERROR^ +@cindex @option{^-k^/CONTINUE_ON_ERROR^} (@command{gnatmake}) +Keep going. Continue as much as possible after a compilation error. To +ease the programmer's task in case of compilation errors, the list of +sources for which the compile fails is given when @command{gnatmake} +terminates. + +If @command{gnatmake} is invoked with several @file{file_names} and with this +switch, if there are compilation errors when building an executable, +@command{gnatmake} will not attempt to build the following executables. + +@item ^-l^/ACTIONS=LINK^ +@cindex @option{^-l^/ACTIONS=LINK^} (@command{gnatmake}) +Link only. Can be combined with @option{^-b^/ACTIONS=BIND^} to binding +and linking. Linking will not be performed if combined with +@option{^-c^/ACTIONS=COMPILE^} +but not with @option{^-b^/ACTIONS=BIND^}. +When not combined with @option{^-b^/ACTIONS=BIND^} +all the units in the closure of the main program must have been previously +compiled and must be up to date, and the main program needs to have been bound. +The root unit specified by @var{file_name} +may be given without extension, with the source extension or, if no GNAT +Project File is specified, with the ALI file extension. + +@item ^-m^/MINIMAL_RECOMPILATION^ +@cindex @option{^-m^/MINIMAL_RECOMPILATION^} (@command{gnatmake}) +Specify that the minimum necessary amount of recompilations +be performed. In this mode @command{gnatmake} ignores time +stamp differences when the only +modifications to a source file consist in adding/removing comments, +empty lines, spaces or tabs. This means that if you have changed the +comments in a source file or have simply reformatted it, using this +switch will tell @command{gnatmake} not to recompile files that depend on it +(provided other sources on which these files depend have undergone no +semantic modifications). Note that the debugging information may be +out of date with respect to the sources if the @option{-m} switch causes +a compilation to be switched, so the use of this switch represents a +trade-off between compilation time and accurate debugging information. + +@item ^-M^/DEPENDENCIES_LIST^ +@cindex Dependencies, producing list +@cindex @option{^-M^/DEPENDENCIES_LIST^} (@command{gnatmake}) +Check if all objects are up to date. If they are, output the object +dependences to @file{stdout} in a form that can be directly exploited in +a @file{Makefile}. By default, each source file is prefixed with its +(relative or absolute) directory name. This name is whatever you +specified in the various @option{^-aI^/SOURCE_SEARCH^} +and @option{^-I^/SEARCH^} switches. If you use +@code{gnatmake ^-M^/DEPENDENCIES_LIST^} +@option{^-q^/QUIET^} +(see below), only the source file names, +without relative paths, are output. If you just specify the +@option{^-M^/DEPENDENCIES_LIST^} +switch, dependencies of the GNAT internal system files are omitted. This +is typically what you want. If you also specify +the @option{^-a^/ALL_FILES^} switch, +dependencies of the GNAT internal files are also listed. Note that +dependencies of the objects in external Ada libraries (see switch +@option{^-aL^/SKIP_MISSING=^}@var{dir} in the following list) +are never reported. + +@item ^-n^/DO_OBJECT_CHECK^ +@cindex @option{^-n^/DO_OBJECT_CHECK^} (@command{gnatmake}) +Don't compile, bind, or link. Checks if all objects are up to date. +If they are not, the full name of the first file that needs to be +recompiled is printed. +Repeated use of this option, followed by compiling the indicated source +file, will eventually result in recompiling all required units. + +@item ^-o ^/EXECUTABLE=^@var{exec_name} +@cindex @option{^-o^/EXECUTABLE^} (@command{gnatmake}) +Output executable name. The name of the final executable program will be +@var{exec_name}. If the @option{^-o^/EXECUTABLE^} switch is omitted the default +name for the executable will be the name of the input file in appropriate form +for an executable file on the host system. + +This switch cannot be used when invoking @command{gnatmake} with several +@file{file_names}. + +@item ^-p or --create-missing-dirs^/CREATE_MISSING_DIRS^ +@cindex @option{^-p^/CREATE_MISSING_DIRS^} (@command{gnatmake}) +When using project files (^-P^/PROJECT_FILE=^@var{project}), create +automatically missing object directories, library directories and exec +directories. + +@item ^-P^/PROJECT_FILE=^@var{project} +@cindex @option{^-P^/PROJECT_FILE^} (@command{gnatmake}) +Use project file @var{project}. Only one such switch can be used. +@xref{gnatmake and Project Files}. + +@item ^-q^/QUIET^ +@cindex @option{^-q^/QUIET^} (@command{gnatmake}) +Quiet. When this flag is not set, the commands carried out by +@command{gnatmake} are displayed. + +@item ^-s^/SWITCH_CHECK/^ +@cindex @option{^-s^/SWITCH_CHECK^} (@command{gnatmake}) +Recompile if compiler switches have changed since last compilation. +All compiler switches but -I and -o are taken into account in the +following way: +orders between different ``first letter'' switches are ignored, but +orders between same switches are taken into account. For example, +@option{-O -O2} is different than @option{-O2 -O}, but @option{-g -O} +is equivalent to @option{-O -g}. + +This switch is recommended when Integrated Preprocessing is used. + +@item ^-u^/UNIQUE^ +@cindex @option{^-u^/UNIQUE^} (@command{gnatmake}) +Unique. Recompile at most the main files. It implies -c. Combined with +-f, it is equivalent to calling the compiler directly. Note that using +^-u^/UNIQUE^ with a project file and no main has a special meaning +(@pxref{Project Files and Main Subprograms}). + +@item ^-U^/ALL_PROJECTS^ +@cindex @option{^-U^/ALL_PROJECTS^} (@command{gnatmake}) +When used without a project file or with one or several mains on the command +line, is equivalent to ^-u^/UNIQUE^. When used with a project file and no main +on the command line, all sources of all project files are checked and compiled +if not up to date, and libraries are rebuilt, if necessary. + +@item ^-v^/REASONS^ +@cindex @option{^-v^/REASONS^} (@command{gnatmake}) +Verbose. Display the reason for all recompilations @command{gnatmake} +decides are necessary, with the highest verbosity level. + +@item ^-vl^/LOW_VERBOSITY^ +@cindex @option{^-vl^/LOW_VERBOSITY^} (@command{gnatmake}) +Verbosity level Low. Display fewer lines than in verbosity Medium. + +@item ^-vm^/MEDIUM_VERBOSITY^ +@cindex @option{^-vm^/MEDIUM_VERBOSITY^} (@command{gnatmake}) +Verbosity level Medium. Potentially display fewer lines than in verbosity High. + +@item ^-vh^/HIGH_VERBOSITY^ +@cindex @option{^-vm^/HIGH_VERBOSITY^} (@command{gnatmake}) +Verbosity level High. Equivalent to ^-v^/REASONS^. + +@item ^-vP^/MESSAGES_PROJECT_FILE=^@emph{x} +Indicate the verbosity of the parsing of GNAT project files. +@xref{Switches Related to Project Files}. + +@item ^-x^/NON_PROJECT_UNIT_COMPILATION^ +@cindex @option{^-x^/NON_PROJECT_UNIT_COMPILATION^} (@command{gnatmake}) +Indicate that sources that are not part of any Project File may be compiled. +Normally, when using Project Files, only sources that are part of a Project +File may be compile. When this switch is used, a source outside of all Project +Files may be compiled. The ALI file and the object file will be put in the +object directory of the main Project. The compilation switches used will only +be those specified on the command line. Even when +@option{^-x^/NON_PROJECT_UNIT_COMPILATION^} is used, mains specified on the +command line need to be sources of a project file. + +@item ^-X^/EXTERNAL_REFERENCE=^@var{name=value} +Indicate that external variable @var{name} has the value @var{value}. +The Project Manager will use this value for occurrences of +@code{external(name)} when parsing the project file. +@xref{Switches Related to Project Files}. + +@item ^-z^/NOMAIN^ +@cindex @option{^-z^/NOMAIN^} (@command{gnatmake}) +No main subprogram. Bind and link the program even if the unit name +given on the command line is a package name. The resulting executable +will execute the elaboration routines of the package and its closure, +then the finalization routines. + +@end table + +@table @asis +@item @command{gcc} @asis{switches} +@ifclear vms +Any uppercase or multi-character switch that is not a @command{gnatmake} switch +is passed to @command{gcc} (e.g.@: @option{-O}, @option{-gnato,} etc.) +@end ifclear +@ifset vms +Any qualifier that cannot be recognized as a qualifier for @code{GNAT MAKE} +but is recognizable as a valid qualifier for @code{GNAT COMPILE} is +automatically treated as a compiler switch, and passed on to all +compilations that are carried out. +@end ifset +@end table + +@noindent +Source and library search path switches: + +@table @option +@c !sort! +@item ^-aI^/SOURCE_SEARCH=^@var{dir} +@cindex @option{^-aI^/SOURCE_SEARCH^} (@command{gnatmake}) +When looking for source files also look in directory @var{dir}. +The order in which source files search is undertaken is +described in @ref{Search Paths and the Run-Time Library (RTL)}. + +@item ^-aL^/SKIP_MISSING=^@var{dir} +@cindex @option{^-aL^/SKIP_MISSING^} (@command{gnatmake}) +Consider @var{dir} as being an externally provided Ada library. +Instructs @command{gnatmake} to skip compilation units whose @file{.ALI} +files have been located in directory @var{dir}. This allows you to have +missing bodies for the units in @var{dir} and to ignore out of date bodies +for the same units. You still need to specify +the location of the specs for these units by using the switches +@option{^-aI^/SOURCE_SEARCH=^@var{dir}} +or @option{^-I^/SEARCH=^@var{dir}}. +Note: this switch is provided for compatibility with previous versions +of @command{gnatmake}. The easier method of causing standard libraries +to be excluded from consideration is to write-protect the corresponding +ALI files. + +@item ^-aO^/OBJECT_SEARCH=^@var{dir} +@cindex @option{^-aO^/OBJECT_SEARCH^} (@command{gnatmake}) +When searching for library and object files, look in directory +@var{dir}. The order in which library files are searched is described in +@ref{Search Paths for gnatbind}. + +@item ^-A^/CONDITIONAL_SOURCE_SEARCH=^@var{dir} +@cindex Search paths, for @command{gnatmake} +@cindex @option{^-A^/CONDITIONAL_SOURCE_SEARCH^} (@command{gnatmake}) +Equivalent to @option{^-aL^/SKIP_MISSING=^@var{dir} +^-aI^/SOURCE_SEARCH=^@var{dir}}. + +@item ^-I^/SEARCH=^@var{dir} +@cindex @option{^-I^/SEARCH^} (@command{gnatmake}) +Equivalent to @option{^-aO^/OBJECT_SEARCH=^@var{dir} +^-aI^/SOURCE_SEARCH=^@var{dir}}. + +@item ^-I-^/NOCURRENT_DIRECTORY^ +@cindex @option{^-I-^/NOCURRENT_DIRECTORY^} (@command{gnatmake}) +@cindex Source files, suppressing search +Do not look for source files in the directory containing the source +file named in the command line. +Do not look for ALI or object files in the directory +where @command{gnatmake} was invoked. + +@item ^-L^/LIBRARY_SEARCH=^@var{dir} +@cindex @option{^-L^/LIBRARY_SEARCH^} (@command{gnatmake}) +@cindex Linker libraries +Add directory @var{dir} to the list of directories in which the linker +will search for libraries. This is equivalent to +@option{-largs ^-L^/LIBRARY_SEARCH=^}@var{dir}. +@ifclear vms +Furthermore, under Windows, the sources pointed to by the libraries path +set in the registry are not searched for. +@end ifclear + +@item -nostdinc +@cindex @option{-nostdinc} (@command{gnatmake}) +Do not look for source files in the system default directory. + +@item -nostdlib +@cindex @option{-nostdlib} (@command{gnatmake}) +Do not look for library files in the system default directory. + +@item --RTS=@var{rts-path} +@cindex @option{--RTS} (@command{gnatmake}) +Specifies the default location of the runtime library. GNAT looks for the +runtime +in the following directories, and stops as soon as a valid runtime is found +(@file{adainclude} or @file{ada_source_path}, and @file{adalib} or +@file{ada_object_path} present): + +@itemize @bullet +@item /$rts_path + +@item /$rts_path + +@item /rts-$rts_path +@end itemize + +@noindent +The selected path is handled like a normal RTS path. + +@end table + +@node Mode Switches for gnatmake +@section Mode Switches for @command{gnatmake} + +@noindent +The mode switches (referred to as @code{mode_switches}) allow the +inclusion of switches that are to be passed to the compiler itself, the +binder or the linker. The effect of a mode switch is to cause all +subsequent switches up to the end of the switch list, or up to the next +mode switch, to be interpreted as switches to be passed on to the +designated component of GNAT. + +@table @option +@c !sort! +@item -cargs @var{switches} +@cindex @option{-cargs} (@command{gnatmake}) +Compiler switches. Here @var{switches} is a list of switches +that are valid switches for @command{gcc}. They will be passed on to +all compile steps performed by @command{gnatmake}. + +@item -bargs @var{switches} +@cindex @option{-bargs} (@command{gnatmake}) +Binder switches. Here @var{switches} is a list of switches +that are valid switches for @code{gnatbind}. They will be passed on to +all bind steps performed by @command{gnatmake}. + +@item -largs @var{switches} +@cindex @option{-largs} (@command{gnatmake}) +Linker switches. Here @var{switches} is a list of switches +that are valid switches for @command{gnatlink}. They will be passed on to +all link steps performed by @command{gnatmake}. + +@item -margs @var{switches} +@cindex @option{-margs} (@command{gnatmake}) +Make switches. The switches are directly interpreted by @command{gnatmake}, +regardless of any previous occurrence of @option{-cargs}, @option{-bargs} +or @option{-largs}. +@end table + +@node Notes on the Command Line +@section Notes on the Command Line + +@noindent +This section contains some additional useful notes on the operation +of the @command{gnatmake} command. + +@itemize @bullet +@item +@cindex Recompilation, by @command{gnatmake} +If @command{gnatmake} finds no ALI files, it recompiles the main program +and all other units required by the main program. +This means that @command{gnatmake} +can be used for the initial compile, as well as during subsequent steps of +the development cycle. + +@item +If you enter @code{gnatmake @var{file}.adb}, where @file{@var{file}.adb} +is a subunit or body of a generic unit, @command{gnatmake} recompiles +@file{@var{file}.adb} (because it finds no ALI) and stops, issuing a +warning. + +@item +In @command{gnatmake} the switch @option{^-I^/SEARCH^} +is used to specify both source and +library file paths. Use @option{^-aI^/SOURCE_SEARCH^} +instead if you just want to specify +source paths only and @option{^-aO^/OBJECT_SEARCH^} +if you want to specify library paths +only. + +@item +@command{gnatmake} will ignore any files whose ALI file is write-protected. +This may conveniently be used to exclude standard libraries from +consideration and in particular it means that the use of the +@option{^-f^/FORCE_COMPILE^} switch will not recompile these files +unless @option{^-a^/ALL_FILES^} is also specified. + +@item +@command{gnatmake} has been designed to make the use of Ada libraries +particularly convenient. Assume you have an Ada library organized +as follows: @i{^obj-dir^[OBJ_DIR]^} contains the objects and ALI files for +of your Ada compilation units, +whereas @i{^include-dir^[INCLUDE_DIR]^} contains the +specs of these units, but no bodies. Then to compile a unit +stored in @code{main.adb}, which uses this Ada library you would just type + +@smallexample +@ifclear vms +$ gnatmake -aI@var{include-dir} -aL@var{obj-dir} main +@end ifclear +@ifset vms +$ gnatmake /SOURCE_SEARCH=@i{[INCLUDE_DIR]} + /SKIP_MISSING=@i{[OBJ_DIR]} main +@end ifset +@end smallexample + +@item +Using @command{gnatmake} along with the +@option{^-m (minimal recompilation)^/MINIMAL_RECOMPILATION^} +switch provides a mechanism for avoiding unnecessary recompilations. Using +this switch, +you can update the comments/format of your +source files without having to recompile everything. Note, however, that +adding or deleting lines in a source files may render its debugging +info obsolete. If the file in question is a spec, the impact is rather +limited, as that debugging info will only be useful during the +elaboration phase of your program. For bodies the impact can be more +significant. In all events, your debugger will warn you if a source file +is more recent than the corresponding object, and alert you to the fact +that the debugging information may be out of date. +@end itemize + +@node How gnatmake Works +@section How @command{gnatmake} Works + +@noindent +Generally @command{gnatmake} automatically performs all necessary +recompilations and you don't need to worry about how it works. However, +it may be useful to have some basic understanding of the @command{gnatmake} +approach and in particular to understand how it uses the results of +previous compilations without incorrectly depending on them. + +First a definition: an object file is considered @dfn{up to date} if the +corresponding ALI file exists and if all the source files listed in the +dependency section of this ALI file have time stamps matching those in +the ALI file. This means that neither the source file itself nor any +files that it depends on have been modified, and hence there is no need +to recompile this file. + +@command{gnatmake} works by first checking if the specified main unit is up +to date. If so, no compilations are required for the main unit. If not, +@command{gnatmake} compiles the main program to build a new ALI file that +reflects the latest sources. Then the ALI file of the main unit is +examined to find all the source files on which the main program depends, +and @command{gnatmake} recursively applies the above procedure on all these +files. + +This process ensures that @command{gnatmake} only trusts the dependencies +in an existing ALI file if they are known to be correct. Otherwise it +always recompiles to determine a new, guaranteed accurate set of +dependencies. As a result the program is compiled ``upside down'' from what may +be more familiar as the required order of compilation in some other Ada +systems. In particular, clients are compiled before the units on which +they depend. The ability of GNAT to compile in any order is critical in +allowing an order of compilation to be chosen that guarantees that +@command{gnatmake} will recompute a correct set of new dependencies if +necessary. + +When invoking @command{gnatmake} with several @var{file_names}, if a unit is +imported by several of the executables, it will be recompiled at most once. + +Note: when using non-standard naming conventions +(@pxref{Using Other File Names}), changing through a configuration pragmas +file the version of a source and invoking @command{gnatmake} to recompile may +have no effect, if the previous version of the source is still accessible +by @command{gnatmake}. It may be necessary to use the switch +^-f^/FORCE_COMPILE^. + +@node Examples of gnatmake Usage +@section Examples of @command{gnatmake} Usage + +@table @code +@item gnatmake hello.adb +Compile all files necessary to bind and link the main program +@file{hello.adb} (containing unit @code{Hello}) and bind and link the +resulting object files to generate an executable file @file{^hello^HELLO.EXE^}. + +@item gnatmake main1 main2 main3 +Compile all files necessary to bind and link the main programs +@file{main1.adb} (containing unit @code{Main1}), @file{main2.adb} +(containing unit @code{Main2}) and @file{main3.adb} +(containing unit @code{Main3}) and bind and link the resulting object files +to generate three executable files @file{^main1^MAIN1.EXE^}, +@file{^main2^MAIN2.EXE^} +and @file{^main3^MAIN3.EXE^}. + +@ifclear vms +@item gnatmake -q Main_Unit -cargs -O2 -bargs -l +@end ifclear + +@ifset vms +@item gnatmake Main_Unit /QUIET +/COMPILER_QUALIFIERS /OPTIMIZE=ALL +/BINDER_QUALIFIERS /ORDER_OF_ELABORATION +@end ifset +Compile all files necessary to bind and link the main program unit +@code{Main_Unit} (from file @file{main_unit.adb}). All compilations will +be done with optimization level 2 and the order of elaboration will be +listed by the binder. @command{gnatmake} will operate in quiet mode, not +displaying commands it is executing. +@end table + +@c ************************* +@node Improving Performance +@chapter Improving Performance +@cindex Improving performance + +@noindent +This chapter presents several topics related to program performance. +It first describes some of the tradeoffs that need to be considered +and some of the techniques for making your program run faster. +It then documents the @command{gnatelim} tool and unused subprogram/data +elimination feature, which can reduce the size of program executables. + +Note: to invoke @command{gnatelim} with a project file, use the @code{gnat} +driver (see @ref{The GNAT Driver and Project Files}). + +@ifnottex +@menu +* Performance Considerations:: +* Text_IO Suggestions:: +* Reducing Size of Ada Executables with gnatelim:: +* Reducing Size of Executables with unused subprogram/data elimination:: +@end menu +@end ifnottex + +@c ***************************** +@node Performance Considerations +@section Performance Considerations + +@noindent +The GNAT system provides a number of options that allow a trade-off +between + +@itemize @bullet +@item +performance of the generated code + +@item +speed of compilation + +@item +minimization of dependences and recompilation + +@item +the degree of run-time checking. +@end itemize + +@noindent +The defaults (if no options are selected) aim at improving the speed +of compilation and minimizing dependences, at the expense of performance +of the generated code: + +@itemize @bullet +@item +no optimization + +@item +no inlining of subprogram calls + +@item +all run-time checks enabled except overflow and elaboration checks +@end itemize + +@noindent +These options are suitable for most program development purposes. This +chapter describes how you can modify these choices, and also provides +some guidelines on debugging optimized code. + +@menu +* Controlling Run-Time Checks:: +* Use of Restrictions:: +* Optimization Levels:: +* Debugging Optimized Code:: +* Inlining of Subprograms:: +* Other Optimization Switches:: +* Optimization and Strict Aliasing:: + +@ifset vms +* Coverage Analysis:: +@end ifset +@end menu + +@node Controlling Run-Time Checks +@subsection Controlling Run-Time Checks + +@noindent +By default, GNAT generates all run-time checks, except integer overflow +checks, stack overflow checks, and checks for access before elaboration on +subprogram calls. The latter are not required in default mode, because all +necessary checking is done at compile time. +@cindex @option{-gnatp} (@command{gcc}) +@cindex @option{-gnato} (@command{gcc}) +Two gnat switches, @option{-gnatp} and @option{-gnato} allow this default to +be modified. @xref{Run-Time Checks}. + +Our experience is that the default is suitable for most development +purposes. + +We treat integer overflow specially because these +are quite expensive and in our experience are not as important as other +run-time checks in the development process. Note that division by zero +is not considered an overflow check, and divide by zero checks are +generated where required by default. + +Elaboration checks are off by default, and also not needed by default, since +GNAT uses a static elaboration analysis approach that avoids the need for +run-time checking. This manual contains a full chapter discussing the issue +of elaboration checks, and if the default is not satisfactory for your use, +you should read this chapter. + +For validity checks, the minimal checks required by the Ada Reference +Manual (for case statements and assignments to array elements) are on +by default. These can be suppressed by use of the @option{-gnatVn} switch. +Note that in Ada 83, there were no validity checks, so if the Ada 83 mode +is acceptable (or when comparing GNAT performance with an Ada 83 compiler), +it may be reasonable to routinely use @option{-gnatVn}. Validity checks +are also suppressed entirely if @option{-gnatp} is used. + +@cindex Overflow checks +@cindex Checks, overflow +@findex Suppress +@findex Unsuppress +@cindex pragma Suppress +@cindex pragma Unsuppress +Note that the setting of the switches controls the default setting of +the checks. They may be modified using either @code{pragma Suppress} (to +remove checks) or @code{pragma Unsuppress} (to add back suppressed +checks) in the program source. + +@node Use of Restrictions +@subsection Use of Restrictions + +@noindent +The use of pragma Restrictions allows you to control which features are +permitted in your program. Apart from the obvious point that if you avoid +relatively expensive features like finalization (enforceable by the use +of pragma Restrictions (No_Finalization), the use of this pragma does not +affect the generated code in most cases. + +One notable exception to this rule is that the possibility of task abort +results in some distributed overhead, particularly if finalization or +exception handlers are used. The reason is that certain sections of code +have to be marked as non-abortable. + +If you use neither the @code{abort} statement, nor asynchronous transfer +of control (@code{select @dots{} then abort}), then this distributed overhead +is removed, which may have a general positive effect in improving +overall performance. Especially code involving frequent use of tasking +constructs and controlled types will show much improved performance. +The relevant restrictions pragmas are + +@smallexample @c ada + pragma Restrictions (No_Abort_Statements); + pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); +@end smallexample + +@noindent +It is recommended that these restriction pragmas be used if possible. Note +that this also means that you can write code without worrying about the +possibility of an immediate abort at any point. + +@node Optimization Levels +@subsection Optimization Levels +@cindex @option{^-O^/OPTIMIZE^} (@command{gcc}) + +@noindent +Without any optimization ^option,^qualifier,^ +the compiler's goal is to reduce the cost of +compilation and to make debugging produce the expected results. +Statements are independent: if you stop the program with a breakpoint between +statements, you can then assign a new value to any variable or change +the program counter to any other statement in the subprogram and get exactly +the results you would expect from the source code. + +Turning on optimization makes the compiler attempt to improve the +performance and/or code size at the expense of compilation time and +possibly the ability to debug the program. + +If you use multiple +^-O options, with or without level numbers,^/OPTIMIZE qualifiers,^ +the last such option is the one that is effective. + +@noindent +The default is optimization off. This results in the fastest compile +times, but GNAT makes absolutely no attempt to optimize, and the +generated programs are considerably larger and slower than when +optimization is enabled. You can use the +@ifclear vms +@option{-O} switch (the permitted forms are @option{-O0}, @option{-O1} +@option{-O2}, @option{-O3}, and @option{-Os}) +@end ifclear +@ifset vms +@code{OPTIMIZE} qualifier +@end ifset +to @command{gcc} to control the optimization level: + +@table @option +@item ^-O0^/OPTIMIZE=NONE^ +No optimization (the default); +generates unoptimized code but has +the fastest compilation time. + +Note that many other compilers do fairly extensive optimization +even if ``no optimization'' is specified. With gcc, it is +very unusual to use ^-O0^/OPTIMIZE=NONE^ for production if +execution time is of any concern, since ^-O0^/OPTIMIZE=NONE^ +really does mean no optimization at all. This difference between +gcc and other compilers should be kept in mind when doing +performance comparisons. + +@item ^-O1^/OPTIMIZE=SOME^ +Moderate optimization; +optimizes reasonably well but does not +degrade compilation time significantly. + +@item ^-O2^/OPTIMIZE=ALL^ +@ifset vms +@itemx /OPTIMIZE=DEVELOPMENT +@end ifset +Full optimization; +generates highly optimized code and has +the slowest compilation time. + +@item ^-O3^/OPTIMIZE=INLINING^ +Full optimization as in @option{-O2}; +also uses more aggressive automatic inlining of subprograms within a unit +(@pxref{Inlining of Subprograms}) and attempts to vectorize loops. + +@item ^-Os^/OPTIMIZE=SPACE^ +Optimize space usage (code and data) of resulting program. +@end table + +@noindent +Higher optimization levels perform more global transformations on the +program and apply more expensive analysis algorithms in order to generate +faster and more compact code. The price in compilation time, and the +resulting improvement in execution time, +both depend on the particular application and the hardware environment. +You should experiment to find the best level for your application. + +Since the precise set of optimizations done at each level will vary from +release to release (and sometime from target to target), it is best to think +of the optimization settings in general terms. +@xref{Optimize Options,, Options That Control Optimization, gcc, Using +the GNU Compiler Collection (GCC)}, for details about +^the @option{-O} settings and a number of @option{-f} options that^how to^ +individually enable or disable specific optimizations. + +Unlike some other compilation systems, ^@command{gcc}^GNAT^ has +been tested extensively at all optimization levels. There are some bugs +which appear only with optimization turned on, but there have also been +bugs which show up only in @emph{unoptimized} code. Selecting a lower +level of optimization does not improve the reliability of the code +generator, which in practice is highly reliable at all optimization +levels. + +Note regarding the use of @option{-O3}: The use of this optimization level +is generally discouraged with GNAT, since it often results in larger +executables which may run more slowly. See further discussion of this point +in @ref{Inlining of Subprograms}. + +@node Debugging Optimized Code +@subsection Debugging Optimized Code +@cindex Debugging optimized code +@cindex Optimization and debugging + +@noindent +Although it is possible to do a reasonable amount of debugging at +@ifclear vms +nonzero optimization levels, +the higher the level the more likely that +@end ifclear +@ifset vms +@option{/OPTIMIZE} settings other than @code{NONE}, +such settings will make it more likely that +@end ifset +source-level constructs will have been eliminated by optimization. +For example, if a loop is strength-reduced, the loop +control variable may be completely eliminated and thus cannot be +displayed in the debugger. +This can only happen at @option{-O2} or @option{-O3}. +Explicit temporary variables that you code might be eliminated at +^level^setting^ @option{-O1} or higher. + +The use of the @option{^-g^/DEBUG^} switch, +@cindex @option{^-g^/DEBUG^} (@command{gcc}) +which is needed for source-level debugging, +affects the size of the program executable on disk, +and indeed the debugging information can be quite large. +However, it has no effect on the generated code (and thus does not +degrade performance) + +Since the compiler generates debugging tables for a compilation unit before +it performs optimizations, the optimizing transformations may invalidate some +of the debugging data. You therefore need to anticipate certain +anomalous situations that may arise while debugging optimized code. +These are the most common cases: + +@enumerate +@item +@i{The ``hopping Program Counter'':} Repeated @code{step} or @code{next} +commands show +the PC bouncing back and forth in the code. This may result from any of +the following optimizations: + +@itemize @bullet +@item +@i{Common subexpression elimination:} using a single instance of code for a +quantity that the source computes several times. As a result you +may not be able to stop on what looks like a statement. + +@item +@i{Invariant code motion:} moving an expression that does not change within a +loop, to the beginning of the loop. + +@item +@i{Instruction scheduling:} moving instructions so as to +overlap loads and stores (typically) with other code, or in +general to move computations of values closer to their uses. Often +this causes you to pass an assignment statement without the assignment +happening and then later bounce back to the statement when the +value is actually needed. Placing a breakpoint on a line of code +and then stepping over it may, therefore, not always cause all the +expected side-effects. +@end itemize + +@item +@i{The ``big leap'':} More commonly known as @emph{cross-jumping}, in which +two identical pieces of code are merged and the program counter suddenly +jumps to a statement that is not supposed to be executed, simply because +it (and the code following) translates to the same thing as the code +that @emph{was} supposed to be executed. This effect is typically seen in +sequences that end in a jump, such as a @code{goto}, a @code{return}, or +a @code{break} in a C @code{^switch^switch^} statement. + +@item +@i{The ``roving variable'':} The symptom is an unexpected value in a variable. +There are various reasons for this effect: + +@itemize @bullet +@item +In a subprogram prologue, a parameter may not yet have been moved to its +``home''. + +@item +A variable may be dead, and its register re-used. This is +probably the most common cause. + +@item +As mentioned above, the assignment of a value to a variable may +have been moved. + +@item +A variable may be eliminated entirely by value propagation or +other means. In this case, GCC may incorrectly generate debugging +information for the variable +@end itemize + +@noindent +In general, when an unexpected value appears for a local variable or parameter +you should first ascertain if that value was actually computed by +your program, as opposed to being incorrectly reported by the debugger. +Record fields or +array elements in an object designated by an access value +are generally less of a problem, once you have ascertained that the access +value is sensible. +Typically, this means checking variables in the preceding code and in the +calling subprogram to verify that the value observed is explainable from other +values (one must apply the procedure recursively to those +other values); or re-running the code and stopping a little earlier +(perhaps before the call) and stepping to better see how the variable obtained +the value in question; or continuing to step @emph{from} the point of the +strange value to see if code motion had simply moved the variable's +assignments later. +@end enumerate + +@noindent +In light of such anomalies, a recommended technique is to use @option{-O0} +early in the software development cycle, when extensive debugging capabilities +are most needed, and then move to @option{-O1} and later @option{-O2} as +the debugger becomes less critical. +Whether to use the @option{^-g^/DEBUG^} switch in the release version is +a release management issue. +@ifclear vms +Note that if you use @option{-g} you can then use the @command{strip} program +on the resulting executable, +which removes both debugging information and global symbols. +@end ifclear + +@node Inlining of Subprograms +@subsection Inlining of Subprograms + +@noindent +A call to a subprogram in the current unit is inlined if all the +following conditions are met: + +@itemize @bullet +@item +The optimization level is at least @option{-O1}. + +@item +The called subprogram is suitable for inlining: It must be small enough +and not contain something that @command{gcc} cannot support in inlined +subprograms. + +@item +@cindex pragma Inline +@findex Inline +Any one of the following applies: @code{pragma Inline} is applied to the +subprogram and the @option{^-gnatn^/INLINE^} switch is specified; the +subprogram is local to the unit and called once from within it; the +subprogram is small and optimization level @option{-O2} is specified; +optimization level @option{-O3}) is specified. +@end itemize + +@noindent +Calls to subprograms in @code{with}'ed units are normally not inlined. +To achieve actual inlining (that is, replacement of the call by the code +in the body of the subprogram), the following conditions must all be true. + +@itemize @bullet +@item +The optimization level is at least @option{-O1}. + +@item +The called subprogram is suitable for inlining: It must be small enough +and not contain something that @command{gcc} cannot support in inlined +subprograms. + +@item +The call appears in a body (not in a package spec). + +@item +There is a @code{pragma Inline} for the subprogram. + +@item +The @option{^-gnatn^/INLINE^} switch is used on the command line. +@end itemize + +Even if all these conditions are met, it may not be possible for +the compiler to inline the call, due to the length of the body, +or features in the body that make it impossible for the compiler +to do the inlining. + +Note that specifying the @option{-gnatn} switch causes additional +compilation dependencies. Consider the following: + +@smallexample @c ada +@cartouche +package R is + procedure Q; + pragma Inline (Q); +end R; +package body R is + @dots{} +end R; + +with R; +procedure Main is +begin + @dots{} + R.Q; +end Main; +@end cartouche +@end smallexample + +@noindent +With the default behavior (no @option{-gnatn} switch specified), the +compilation of the @code{Main} procedure depends only on its own source, +@file{main.adb}, and the spec of the package in file @file{r.ads}. This +means that editing the body of @code{R} does not require recompiling +@code{Main}. + +On the other hand, the call @code{R.Q} is not inlined under these +circumstances. If the @option{-gnatn} switch is present when @code{Main} +is compiled, the call will be inlined if the body of @code{Q} is small +enough, but now @code{Main} depends on the body of @code{R} in +@file{r.adb} as well as on the spec. This means that if this body is edited, +the main program must be recompiled. Note that this extra dependency +occurs whether or not the call is in fact inlined by @command{gcc}. + +The use of front end inlining with @option{-gnatN} generates similar +additional dependencies. + +@cindex @option{^-fno-inline^/INLINE=SUPPRESS^} (@command{gcc}) +Note: The @option{^-fno-inline^/INLINE=SUPPRESS^} switch +can be used to prevent +all inlining. This switch overrides all other conditions and ensures +that no inlining occurs. The extra dependences resulting from +@option{-gnatn} will still be active, even if +this switch is used to suppress the resulting inlining actions. + +@cindex @option{-fno-inline-functions} (@command{gcc}) +Note: The @option{-fno-inline-functions} switch can be used to prevent +automatic inlining of subprograms if @option{-O3} is used. + +@cindex @option{-fno-inline-small-functions} (@command{gcc}) +Note: The @option{-fno-inline-small-functions} switch can be used to prevent +automatic inlining of small subprograms if @option{-O2} is used. + +@cindex @option{-fno-inline-functions-called-once} (@command{gcc}) +Note: The @option{-fno-inline-functions-called-once} switch +can be used to prevent inlining of subprograms local to the unit +and called once from within it if @option{-O1} is used. + +Note regarding the use of @option{-O3}: There is no difference in inlining +behavior between @option{-O2} and @option{-O3} for subprograms with an explicit +pragma @code{Inline} assuming the use of @option{-gnatn} +or @option{-gnatN} (the switches that activate inlining). If you have used +pragma @code{Inline} in appropriate cases, then it is usually much better +to use @option{-O2} and @option{-gnatn} and avoid the use of @option{-O3} which +in this case only has the effect of inlining subprograms you did not +think should be inlined. We often find that the use of @option{-O3} slows +down code by performing excessive inlining, leading to increased instruction +cache pressure from the increased code size. So the bottom line here is +that you should not automatically assume that @option{-O3} is better than +@option{-O2}, and indeed you should use @option{-O3} only if tests show that +it actually improves performance. + +@node Other Optimization Switches +@subsection Other Optimization Switches +@cindex Optimization Switches + +Since @code{GNAT} uses the @command{gcc} back end, all the specialized +@command{gcc} optimization switches are potentially usable. These switches +have not been extensively tested with GNAT but can generally be expected +to work. Examples of switches in this category are +@option{-funroll-loops} and +the various target-specific @option{-m} options (in particular, it has been +observed that @option{-march=pentium4} can significantly improve performance +on appropriate machines). For full details of these switches, see +@ref{Submodel Options,, Hardware Models and Configurations, gcc, Using +the GNU Compiler Collection (GCC)}. + +@node Optimization and Strict Aliasing +@subsection Optimization and Strict Aliasing +@cindex Aliasing +@cindex Strict Aliasing +@cindex No_Strict_Aliasing + +@noindent +The strong typing capabilities of Ada allow an optimizer to generate +efficient code in situations where other languages would be forced to +make worst case assumptions preventing such optimizations. Consider +the following example: + +@smallexample @c ada +@cartouche +procedure R is + type Int1 is new Integer; + type Int2 is new Integer; + type Int1A is access Int1; + type Int2A is access Int2; + Int1V : Int1A; + Int2V : Int2A; + @dots{} + +begin + @dots{} + for J in Data'Range loop + if Data (J) = Int1V.all then + Int2V.all := Int2V.all + 1; + end if; + end loop; + @dots{} +end R; +@end cartouche +@end smallexample + +@noindent +In this example, since the variable @code{Int1V} can only access objects +of type @code{Int1}, and @code{Int2V} can only access objects of type +@code{Int2}, there is no possibility that the assignment to +@code{Int2V.all} affects the value of @code{Int1V.all}. This means that +the compiler optimizer can "know" that the value @code{Int1V.all} is constant +for all iterations of the loop and avoid the extra memory reference +required to dereference it each time through the loop. + +This kind of optimization, called strict aliasing analysis, is +triggered by specifying an optimization level of @option{-O2} or +higher or @option{-Os} and allows @code{GNAT} to generate more efficient code +when access values are involved. + +However, although this optimization is always correct in terms of +the formal semantics of the Ada Reference Manual, difficulties can +arise if features like @code{Unchecked_Conversion} are used to break +the typing system. Consider the following complete program example: + +@smallexample @c ada +@cartouche +package p1 is + type int1 is new integer; + type int2 is new integer; + type a1 is access int1; + type a2 is access int2; +end p1; + +with p1; use p1; +package p2 is + function to_a2 (Input : a1) return a2; +end p2; + +with Unchecked_Conversion; +package body p2 is + function to_a2 (Input : a1) return a2 is + function to_a2u is + new Unchecked_Conversion (a1, a2); + begin + return to_a2u (Input); + end to_a2; +end p2; + +with p2; use p2; +with p1; use p1; +with Text_IO; use Text_IO; +procedure m is + v1 : a1 := new int1; + v2 : a2 := to_a2 (v1); +begin + v1.all := 1; + v2.all := 0; + put_line (int1'image (v1.all)); +end; +@end cartouche +@end smallexample + +@noindent +This program prints out 0 in @option{-O0} or @option{-O1} +mode, but it prints out 1 in @option{-O2} mode. That's +because in strict aliasing mode, the compiler can and +does assume that the assignment to @code{v2.all} could not +affect the value of @code{v1.all}, since different types +are involved. + +This behavior is not a case of non-conformance with the standard, since +the Ada RM specifies that an unchecked conversion where the resulting +bit pattern is not a correct value of the target type can result in an +abnormal value and attempting to reference an abnormal value makes the +execution of a program erroneous. That's the case here since the result +does not point to an object of type @code{int2}. This means that the +effect is entirely unpredictable. + +However, although that explanation may satisfy a language +lawyer, in practice an applications programmer expects an +unchecked conversion involving pointers to create true +aliases and the behavior of printing 1 seems plain wrong. +In this case, the strict aliasing optimization is unwelcome. + +Indeed the compiler recognizes this possibility, and the +unchecked conversion generates a warning: + +@smallexample +p2.adb:5:07: warning: possible aliasing problem with type "a2" +p2.adb:5:07: warning: use -fno-strict-aliasing switch for references +p2.adb:5:07: warning: or use "pragma No_Strict_Aliasing (a2);" +@end smallexample + +@noindent +Unfortunately the problem is recognized when compiling the body of +package @code{p2}, but the actual "bad" code is generated while +compiling the body of @code{m} and this latter compilation does not see +the suspicious @code{Unchecked_Conversion}. + +As implied by the warning message, there are approaches you can use to +avoid the unwanted strict aliasing optimization in a case like this. + +One possibility is to simply avoid the use of @option{-O2}, but +that is a bit drastic, since it throws away a number of useful +optimizations that do not involve strict aliasing assumptions. + +A less drastic approach is to compile the program using the +option @option{-fno-strict-aliasing}. Actually it is only the +unit containing the dereferencing of the suspicious pointer +that needs to be compiled. So in this case, if we compile +unit @code{m} with this switch, then we get the expected +value of zero printed. Analyzing which units might need +the switch can be painful, so a more reasonable approach +is to compile the entire program with options @option{-O2} +and @option{-fno-strict-aliasing}. If the performance is +satisfactory with this combination of options, then the +advantage is that the entire issue of possible "wrong" +optimization due to strict aliasing is avoided. + +To avoid the use of compiler switches, the configuration +pragma @code{No_Strict_Aliasing} with no parameters may be +used to specify that for all access types, the strict +aliasing optimization should be suppressed. + +However, these approaches are still overkill, in that they causes +all manipulations of all access values to be deoptimized. A more +refined approach is to concentrate attention on the specific +access type identified as problematic. + +First, if a careful analysis of uses of the pointer shows +that there are no possible problematic references, then +the warning can be suppressed by bracketing the +instantiation of @code{Unchecked_Conversion} to turn +the warning off: + +@smallexample @c ada + pragma Warnings (Off); + function to_a2u is + new Unchecked_Conversion (a1, a2); + pragma Warnings (On); +@end smallexample + +@noindent +Of course that approach is not appropriate for this particular +example, since indeed there is a problematic reference. In this +case we can take one of two other approaches. + +The first possibility is to move the instantiation of unchecked +conversion to the unit in which the type is declared. In +this example, we would move the instantiation of +@code{Unchecked_Conversion} from the body of package +@code{p2} to the spec of package @code{p1}. Now the +warning disappears. That's because any use of the +access type knows there is a suspicious unchecked +conversion, and the strict aliasing optimization +is automatically suppressed for the type. + +If it is not practical to move the unchecked conversion to the same unit +in which the destination access type is declared (perhaps because the +source type is not visible in that unit), you may use pragma +@code{No_Strict_Aliasing} for the type. This pragma must occur in the +same declarative sequence as the declaration of the access type: + +@smallexample @c ada + type a2 is access int2; + pragma No_Strict_Aliasing (a2); +@end smallexample + +@noindent +Here again, the compiler now knows that the strict aliasing optimization +should be suppressed for any reference to type @code{a2} and the +expected behavior is obtained. + +Finally, note that although the compiler can generate warnings for +simple cases of unchecked conversions, there are tricker and more +indirect ways of creating type incorrect aliases which the compiler +cannot detect. Examples are the use of address overlays and unchecked +conversions involving composite types containing access types as +components. In such cases, no warnings are generated, but there can +still be aliasing problems. One safe coding practice is to forbid the +use of address clauses for type overlaying, and to allow unchecked +conversion only for primitive types. This is not really a significant +restriction since any possible desired effect can be achieved by +unchecked conversion of access values. + +The aliasing analysis done in strict aliasing mode can certainly +have significant benefits. We have seen cases of large scale +application code where the time is increased by up to 5% by turning +this optimization off. If you have code that includes significant +usage of unchecked conversion, you might want to just stick with +@option{-O1} and avoid the entire issue. If you get adequate +performance at this level of optimization level, that's probably +the safest approach. If tests show that you really need higher +levels of optimization, then you can experiment with @option{-O2} +and @option{-O2 -fno-strict-aliasing} to see how much effect this +has on size and speed of the code. If you really need to use +@option{-O2} with strict aliasing in effect, then you should +review any uses of unchecked conversion of access types, +particularly if you are getting the warnings described above. + +@ifset vms +@node Coverage Analysis +@subsection Coverage Analysis + +@noindent +GNAT supports the HP Performance Coverage Analyzer (PCA), which allows +the user to determine the distribution of execution time across a program, +@pxref{Profiling} for details of usage. +@end ifset + + +@node Text_IO Suggestions +@section @code{Text_IO} Suggestions +@cindex @code{Text_IO} and performance + +@noindent +The @code{Ada.Text_IO} package has fairly high overheads due in part to +the requirement of maintaining page and line counts. If performance +is critical, a recommendation is to use @code{Stream_IO} instead of +@code{Text_IO} for volume output, since this package has less overhead. + +If @code{Text_IO} must be used, note that by default output to the standard +output and standard error files is unbuffered (this provides better +behavior when output statements are used for debugging, or if the +progress of a program is observed by tracking the output, e.g. by +using the Unix @command{tail -f} command to watch redirected output. + +If you are generating large volumes of output with @code{Text_IO} and +performance is an important factor, use a designated file instead +of the standard output file, or change the standard output file to +be buffered using @code{Interfaces.C_Streams.setvbuf}. + + + +@node Reducing Size of Ada Executables with gnatelim +@section Reducing Size of Ada Executables with @code{gnatelim} +@findex gnatelim + +@noindent +This section describes @command{gnatelim}, a tool which detects unused +subprograms and helps the compiler to create a smaller executable for your +program. + +@menu +* About gnatelim:: +* Running gnatelim:: +* Processing Precompiled Libraries:: +* Correcting the List of Eliminate Pragmas:: +* Making Your Executables Smaller:: +* Summary of the gnatelim Usage Cycle:: +@end menu + +@node About gnatelim +@subsection About @code{gnatelim} + +@noindent +When a program shares a set of Ada +packages with other programs, it may happen that this program uses +only a fraction of the subprograms defined in these packages. The code +created for these unused subprograms increases the size of the executable. + +@code{gnatelim} tracks unused subprograms in an Ada program and +outputs a list of GNAT-specific pragmas @code{Eliminate} marking all the +subprograms that are declared but never called. By placing the list of +@code{Eliminate} pragmas in the GNAT configuration file @file{gnat.adc} and +recompiling your program, you may decrease the size of its executable, +because the compiler will not generate the code for 'eliminated' subprograms. +@xref{Pragma Eliminate,,, gnat_rm, GNAT Reference Manual}, for more +information about this pragma. + +@code{gnatelim} needs as its input data the name of the main subprogram. + +If a set of source files is specified as @code{gnatelim} arguments, it +treats these files as a complete set of sources making up a program to +analyse, and analyses only these sources. + +After a full successful build of the main subprogram @code{gnatelim} can be +called without specifying sources to analyse, in this case it computes +the source closure of the main unit from the @file{ALI} files. + +The following command will create the set of @file{ALI} files needed for +@code{gnatelim}: + +@smallexample +$ gnatmake ^-c Main_Prog^/ACTIONS=COMPILE MAIN_PROG^ +@end smallexample + +Note that @code{gnatelim} does not need object files. + +@node Running gnatelim +@subsection Running @code{gnatelim} + +@noindent +@code{gnatelim} has the following command-line interface: + +@smallexample +$ gnatelim [@var{switches}] ^-main^?MAIN^=@var{main_unit_name} @{@var{filename}@} @r{[}-cargs @var{gcc_switches}@r{]} +@end smallexample + +@noindent +@var{main_unit_name} should be a name of a source file that contains the main +subprogram of a program (partition). + +Each @var{filename} is the name (including the extension) of a source +file to process. ``Wildcards'' are allowed, and +the file name may contain path information. + +@samp{@var{gcc_switches}} is a list of switches for +@command{gcc}. They will be passed on to all compiler invocations made by +@command{gnatelim} to generate the ASIS trees. Here you can provide +@option{^-I^/INCLUDE_DIRS=^} switches to form the source search path, +use the @option{-gnatec} switch to set the configuration file, +use the @option{-gnat05} switch if sources should be compiled in +Ada 2005 mode etc. + +@code{gnatelim} has the following switches: + +@table @option +@c !sort! +@item ^-files^/FILES^=@var{filename} +@cindex @option{^-files^/FILES^} (@code{gnatelim}) +Take the argument source files from the specified file. This file should be an +ordinary text file containing file names separated by spaces or +line breaks. You can use this switch more than once in the same call to +@command{gnatelim}. You also can combine this switch with +an explicit list of files. + +@item ^-log^/LOG^ +@cindex @option{^-log^/LOG^} (@command{gnatelim}) +Duplicate all the output sent to @file{stderr} into a log file. The log file +is named @file{gnatelim.log} and is located in the current directory. + +@item ^-log^/LOGFILE^=@var{filename} +@cindex @option{^-log^/LOGFILE^} (@command{gnatelim}) +Duplicate all the output sent to @file{stderr} into a specified log file. + +@cindex @option{^--no-elim-dispatch^/NO_DISPATCH^} (@command{gnatelim}) +@item ^--no-elim-dispatch^/NO_DISPATCH^ +Do not generate pragmas for dispatching operations. + +@item ^--ignore^/IGNORE^=@var{filename} +@cindex @option{^--ignore^/IGNORE^} (@command{gnatelim}) +Do not generate pragmas for subprograms declared in the sources +listed in a specified file + +@cindex @option{^-o^/OUTPUT^} (@command{gnatelim}) +@item ^-o^/OUTPUT^=@var{report_file} +Put @command{gnatelim} output into a specified file. If this file already exists, +it is overridden. If this switch is not used, @command{gnatelim} outputs its results +into @file{stderr} + +@item ^-q^/QUIET^ +@cindex @option{^-q^/QUIET^} (@command{gnatelim}) +Quiet mode: by default @code{gnatelim} outputs to the standard error +stream the number of program units left to be processed. This option turns +this trace off. + +@cindex @option{^-t^/TIME^} (@command{gnatelim}) +@item ^-t^/TIME^ +Print out execution time. + +@item ^-v^/VERBOSE^ +@cindex @option{^-v^/VERBOSE^} (@command{gnatelim}) +Verbose mode: @code{gnatelim} version information is printed as Ada +comments to the standard output stream. Also, in addition to the number of +program units left @code{gnatelim} will output the name of the current unit +being processed. + +@item ^-wq^/WARNINGS=QUIET^ +@cindex @option{^-wq^/WARNINGS=QUIET^} (@command{gnatelim}) +Quiet warning mode - some warnings are suppressed. In particular warnings that +indicate that the analysed set of sources is incomplete to make up a +partition and that some subprogram bodies are missing are not generated. +@end table + +@node Processing Precompiled Libraries +@subsection Processing Precompiled Libraries + +@noindent +If some program uses a precompiled Ada library, it can be processed by +@code{gnatelim} in a usual way. @code{gnatelim} will newer generate an +Eliminate pragma for a subprogram if the body of this subprogram has not +been analysed, this is a typical case for subprograms from precompiled +libraries. Switch @option{^-wq^/WARNINGS=QUIET^} may be used to suppress +warnings about missing source files and non-analyzed subprogram bodies +that can be generated when processing precompiled Ada libraries. + +@node Correcting the List of Eliminate Pragmas +@subsection Correcting the List of Eliminate Pragmas + +@noindent +In some rare cases @code{gnatelim} may try to eliminate +subprograms that are actually called in the program. In this case, the +compiler will generate an error message of the form: + +@smallexample +main.adb:4:08: cannot reference subprogram "P" eliminated at elim.out:5 +@end smallexample + +@noindent +You will need to manually remove the wrong @code{Eliminate} pragmas from +the configuration file indicated in the error message. You should recompile +your program from scratch after that, because you need a consistent +configuration file(s) during the entire compilation. + +@node Making Your Executables Smaller +@subsection Making Your Executables Smaller + +@noindent +In order to get a smaller executable for your program you now have to +recompile the program completely with the configuration file containing +pragmas Eliminate generated by gnatelim. If these pragmas are placed in +@file{gnat.adc} file located in your current directory, just do: + +@smallexample +$ gnatmake ^-f main_prog^/FORCE_COMPILE MAIN_PROG^ +@end smallexample + +@noindent +(Use the @option{^-f^/FORCE_COMPILE^} option for @command{gnatmake} to +recompile everything +with the set of pragmas @code{Eliminate} that you have obtained with +@command{gnatelim}). + +Be aware that the set of @code{Eliminate} pragmas is specific to each +program. It is not recommended to merge sets of @code{Eliminate} +pragmas created for different programs in one configuration file. + +@node Summary of the gnatelim Usage Cycle +@subsection Summary of the @code{gnatelim} Usage Cycle + +@noindent +Here is a quick summary of the steps to be taken in order to reduce +the size of your executables with @code{gnatelim}. You may use +other GNAT options to control the optimization level, +to produce the debugging information, to set search path, etc. + +@enumerate +@item +Create a complete set of @file{ALI} files (if the program has not been +built already) + +@smallexample +$ gnatmake ^-c main_prog^/ACTIONS=COMPILE MAIN_PROG^ +@end smallexample + +@item +Generate a list of @code{Eliminate} pragmas in default configuration file +@file{gnat.adc} in the current directory +@smallexample +@ifset vms +$ PIPE GNAT ELIM MAIN_PROG > GNAT.ADC +@end ifset +@ifclear vms +$ gnatelim main_prog >@r{[}>@r{]} gnat.adc +@end ifclear +@end smallexample + +@item +Recompile the application + +@smallexample +$ gnatmake ^-f main_prog^/FORCE_COMPILE MAIN_PROG^ +@end smallexample + +@end enumerate + +@node Reducing Size of Executables with unused subprogram/data elimination +@section Reducing Size of Executables with Unused Subprogram/Data Elimination +@findex unused subprogram/data elimination + +@noindent +This section describes how you can eliminate unused subprograms and data from +your executable just by setting options at compilation time. + +@menu +* About unused subprogram/data elimination:: +* Compilation options:: +* Example of unused subprogram/data elimination:: +@end menu + +@node About unused subprogram/data elimination +@subsection About unused subprogram/data elimination + +@noindent +By default, an executable contains all code and data of its composing objects +(directly linked or coming from statically linked libraries), even data or code +never used by this executable. + +This feature will allow you to eliminate such unused code from your +executable, making it smaller (in disk and in memory). + +This functionality is available on all Linux platforms except for the IA-64 +architecture and on all cross platforms using the ELF binary file format. +In both cases GNU binutils version 2.16 or later are required to enable it. + +@node Compilation options +@subsection Compilation options + +@noindent +The operation of eliminating the unused code and data from the final executable +is directly performed by the linker. + +In order to do this, it has to work with objects compiled with the +following options: +@option{-ffunction-sections} @option{-fdata-sections}. +@cindex @option{-ffunction-sections} (@command{gcc}) +@cindex @option{-fdata-sections} (@command{gcc}) +These options are usable with C and Ada files. +They will place respectively each +function or data in a separate section in the resulting object file. + +Once the objects and static libraries are created with these options, the +linker can perform the dead code elimination. You can do this by setting +the @option{-Wl,--gc-sections} option to gcc command or in the +@option{-largs} section of @command{gnatmake}. This will perform a +garbage collection of code and data never referenced. + +If the linker performs a partial link (@option{-r} ld linker option), then you +will need to provide one or several entry point using the +@option{-e} / @option{--entry} ld option. + +Note that objects compiled without the @option{-ffunction-sections} and +@option{-fdata-sections} options can still be linked with the executable. +However, no dead code elimination will be performed on those objects (they will +be linked as is). + +The GNAT static library is now compiled with -ffunction-sections and +-fdata-sections on some platforms. This allows you to eliminate the unused code +and data of the GNAT library from your executable. + +@node Example of unused subprogram/data elimination +@subsection Example of unused subprogram/data elimination + +@noindent +Here is a simple example: + +@smallexample @c ada +with Aux; + +procedure Test is +begin + Aux.Used (10); +end Test; + +package Aux is + Used_Data : Integer; + Unused_Data : Integer; + + procedure Used (Data : Integer); + procedure Unused (Data : Integer); +end Aux; + +package body Aux is + procedure Used (Data : Integer) is + begin + Used_Data := Data; + end Used; + + procedure Unused (Data : Integer) is + begin + Unused_Data := Data; + end Unused; +end Aux; +@end smallexample + +@noindent +@code{Unused} and @code{Unused_Data} are never referenced in this code +excerpt, and hence they may be safely removed from the final executable. + +@smallexample +$ gnatmake test + +$ nm test | grep used +020015f0 T aux__unused +02005d88 B aux__unused_data +020015cc T aux__used +02005d84 B aux__used_data + +$ gnatmake test -cargs -fdata-sections -ffunction-sections \ + -largs -Wl,--gc-sections + +$ nm test | grep used +02005350 T aux__used +0201ffe0 B aux__used_data +@end smallexample + +@noindent +It can be observed that the procedure @code{Unused} and the object +@code{Unused_Data} are removed by the linker when using the +appropriate options. + +@c ******************************** +@node Renaming Files Using gnatchop +@chapter Renaming Files Using @code{gnatchop} +@findex gnatchop + +@noindent +This chapter discusses how to handle files with multiple units by using +the @code{gnatchop} utility. This utility is also useful in renaming +files to meet the standard GNAT default file naming conventions. + +@menu +* Handling Files with Multiple Units:: +* Operating gnatchop in Compilation Mode:: +* Command Line for gnatchop:: +* Switches for gnatchop:: +* Examples of gnatchop Usage:: +@end menu + +@node Handling Files with Multiple Units +@section Handling Files with Multiple Units + +@noindent +The basic compilation model of GNAT requires that a file submitted to the +compiler have only one unit and there be a strict correspondence +between the file name and the unit name. + +The @code{gnatchop} utility allows both of these rules to be relaxed, +allowing GNAT to process files which contain multiple compilation units +and files with arbitrary file names. @code{gnatchop} +reads the specified file and generates one or more output files, +containing one unit per file. The unit and the file name correspond, +as required by GNAT. + +If you want to permanently restructure a set of ``foreign'' files so that +they match the GNAT rules, and do the remaining development using the +GNAT structure, you can simply use @command{gnatchop} once, generate the +new set of files and work with them from that point on. + +Alternatively, if you want to keep your files in the ``foreign'' format, +perhaps to maintain compatibility with some other Ada compilation +system, you can set up a procedure where you use @command{gnatchop} each +time you compile, regarding the source files that it writes as temporary +files that you throw away. + +Note that if your file containing multiple units starts with a byte order +mark (BOM) specifying UTF-8 encoding, then the files generated by gnatchop +will each start with a copy of this BOM, meaning that they can be compiled +automatically in UTF-8 mode without needing to specify an explicit encoding. + +@node Operating gnatchop in Compilation Mode +@section Operating gnatchop in Compilation Mode + +@noindent +The basic function of @code{gnatchop} is to take a file with multiple units +and split it into separate files. The boundary between files is reasonably +clear, except for the issue of comments and pragmas. In default mode, the +rule is that any pragmas between units belong to the previous unit, except +that configuration pragmas always belong to the following unit. Any comments +belong to the following unit. These rules +almost always result in the right choice of +the split point without needing to mark it explicitly and most users will +find this default to be what they want. In this default mode it is incorrect to +submit a file containing only configuration pragmas, or one that ends in +configuration pragmas, to @code{gnatchop}. + +However, using a special option to activate ``compilation mode'', +@code{gnatchop} +can perform another function, which is to provide exactly the semantics +required by the RM for handling of configuration pragmas in a compilation. +In the absence of configuration pragmas (at the main file level), this +option has no effect, but it causes such configuration pragmas to be handled +in a quite different manner. + +First, in compilation mode, if @code{gnatchop} is given a file that consists of +only configuration pragmas, then this file is appended to the +@file{gnat.adc} file in the current directory. This behavior provides +the required behavior described in the RM for the actions to be taken +on submitting such a file to the compiler, namely that these pragmas +should apply to all subsequent compilations in the same compilation +environment. Using GNAT, the current directory, possibly containing a +@file{gnat.adc} file is the representation +of a compilation environment. For more information on the +@file{gnat.adc} file, see @ref{Handling of Configuration Pragmas}. + +Second, in compilation mode, if @code{gnatchop} +is given a file that starts with +configuration pragmas, and contains one or more units, then these +configuration pragmas are prepended to each of the chopped files. This +behavior provides the required behavior described in the RM for the +actions to be taken on compiling such a file, namely that the pragmas +apply to all units in the compilation, but not to subsequently compiled +units. + +Finally, if configuration pragmas appear between units, they are appended +to the previous unit. This results in the previous unit being illegal, +since the compiler does not accept configuration pragmas that follow +a unit. This provides the required RM behavior that forbids configuration +pragmas other than those preceding the first compilation unit of a +compilation. + +For most purposes, @code{gnatchop} will be used in default mode. The +compilation mode described above is used only if you need exactly +accurate behavior with respect to compilations, and you have files +that contain multiple units and configuration pragmas. In this +circumstance the use of @code{gnatchop} with the compilation mode +switch provides the required behavior, and is for example the mode +in which GNAT processes the ACVC tests. + +@node Command Line for gnatchop +@section Command Line for @code{gnatchop} + +@noindent +The @code{gnatchop} command has the form: + +@smallexample +@c $ gnatchop switches @var{file name} @r{[}@var{file name} @dots{}@r{]} +@c @ovar{directory} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatchop switches @var{file name} @r{[}@var{file name} @dots{}@r{]} + @r{[}@var{directory}@r{]} +@end smallexample + +@noindent +The only required argument is the file name of the file to be chopped. +There are no restrictions on the form of this file name. The file itself +contains one or more Ada units, in normal GNAT format, concatenated +together. As shown, more than one file may be presented to be chopped. + +When run in default mode, @code{gnatchop} generates one output file in +the current directory for each unit in each of the files. + +@var{directory}, if specified, gives the name of the directory to which +the output files will be written. If it is not specified, all files are +written to the current directory. + +For example, given a +file called @file{hellofiles} containing + +@smallexample @c ada +@group +@cartouche +procedure hello; + +with Text_IO; use Text_IO; +procedure hello is +begin + Put_Line ("Hello"); +end hello; +@end cartouche +@end group +@end smallexample + +@noindent +the command + +@smallexample +$ gnatchop ^hellofiles^HELLOFILES.^ +@end smallexample + +@noindent +generates two files in the current directory, one called +@file{hello.ads} containing the single line that is the procedure spec, +and the other called @file{hello.adb} containing the remaining text. The +original file is not affected. The generated files can be compiled in +the normal manner. + +@noindent +When gnatchop is invoked on a file that is empty or that contains only empty +lines and/or comments, gnatchop will not fail, but will not produce any +new sources. + +For example, given a +file called @file{toto.txt} containing + +@smallexample @c ada +@group +@cartouche +-- Just a comment +@end cartouche +@end group +@end smallexample + +@noindent +the command + +@smallexample +$ gnatchop ^toto.txt^TOT.TXT^ +@end smallexample + +@noindent +will not produce any new file and will result in the following warnings: + +@smallexample +toto.txt:1:01: warning: empty file, contains no compilation units +no compilation units found +no source files written +@end smallexample + +@node Switches for gnatchop +@section Switches for @code{gnatchop} + +@noindent +@command{gnatchop} recognizes the following switches: + +@table @option +@c !sort! + +@item --version +@cindex @option{--version} @command{gnatchop} +Display Copyright and version, then exit disregarding all other options. + +@item --help +@cindex @option{--help} @command{gnatchop} +If @option{--version} was not used, display usage, then exit disregarding +all other options. + +@item ^-c^/COMPILATION^ +@cindex @option{^-c^/COMPILATION^} (@code{gnatchop}) +Causes @code{gnatchop} to operate in compilation mode, in which +configuration pragmas are handled according to strict RM rules. See +previous section for a full description of this mode. + +@ifclear vms +@item -gnat@var{xxx} +This passes the given @option{-gnat@var{xxx}} switch to @code{gnat} which is +used to parse the given file. Not all @var{xxx} options make sense, +but for example, the use of @option{-gnati2} allows @code{gnatchop} to +process a source file that uses Latin-2 coding for identifiers. +@end ifclear + +@item ^-h^/HELP^ +Causes @code{gnatchop} to generate a brief help summary to the standard +output file showing usage information. + +@item ^-k@var{mm}^/FILE_NAME_MAX_LENGTH=@var{mm}^ +@cindex @option{^-k^/FILE_NAME_MAX_LENGTH^} (@code{gnatchop}) +Limit generated file names to the specified number @code{mm} +of characters. +This is useful if the +resulting set of files is required to be interoperable with systems +which limit the length of file names. +@ifset vms +If no value is given, or +if no @code{/FILE_NAME_MAX_LENGTH} qualifier is given, +a default of 39, suitable for OpenVMS Alpha +Systems, is assumed +@end ifset +@ifclear vms +No space is allowed between the @option{-k} and the numeric value. The numeric +value may be omitted in which case a default of @option{-k8}, +suitable for use +with DOS-like file systems, is used. If no @option{-k} switch +is present then +there is no limit on the length of file names. +@end ifclear + +@item ^-p^/PRESERVE^ +@cindex @option{^-p^/PRESERVE^} (@code{gnatchop}) +Causes the file ^modification^creation^ time stamp of the input file to be +preserved and used for the time stamp of the output file(s). This may be +useful for preserving coherency of time stamps in an environment where +@code{gnatchop} is used as part of a standard build process. + +@item ^-q^/QUIET^ +@cindex @option{^-q^/QUIET^} (@code{gnatchop}) +Causes output of informational messages indicating the set of generated +files to be suppressed. Warnings and error messages are unaffected. + +@item ^-r^/REFERENCE^ +@cindex @option{^-r^/REFERENCE^} (@code{gnatchop}) +@findex Source_Reference +Generate @code{Source_Reference} pragmas. Use this switch if the output +files are regarded as temporary and development is to be done in terms +of the original unchopped file. This switch causes +@code{Source_Reference} pragmas to be inserted into each of the +generated files to refers back to the original file name and line number. +The result is that all error messages refer back to the original +unchopped file. +In addition, the debugging information placed into the object file (when +the @option{^-g^/DEBUG^} switch of @command{gcc} or @command{gnatmake} is +specified) +also refers back to this original file so that tools like profilers and +debuggers will give information in terms of the original unchopped file. + +If the original file to be chopped itself contains +a @code{Source_Reference} +pragma referencing a third file, then gnatchop respects +this pragma, and the generated @code{Source_Reference} pragmas +in the chopped file refer to the original file, with appropriate +line numbers. This is particularly useful when @code{gnatchop} +is used in conjunction with @code{gnatprep} to compile files that +contain preprocessing statements and multiple units. + +@item ^-v^/VERBOSE^ +@cindex @option{^-v^/VERBOSE^} (@code{gnatchop}) +Causes @code{gnatchop} to operate in verbose mode. The version +number and copyright notice are output, as well as exact copies of +the gnat1 commands spawned to obtain the chop control information. + +@item ^-w^/OVERWRITE^ +@cindex @option{^-w^/OVERWRITE^} (@code{gnatchop}) +Overwrite existing file names. Normally @code{gnatchop} regards it as a +fatal error if there is already a file with the same name as a +file it would otherwise output, in other words if the files to be +chopped contain duplicated units. This switch bypasses this +check, and causes all but the last instance of such duplicated +units to be skipped. + +@ifclear vms +@item --GCC=@var{xxxx} +@cindex @option{--GCC=} (@code{gnatchop}) +Specify the path of the GNAT parser to be used. When this switch is used, +no attempt is made to add the prefix to the GNAT parser executable. +@end ifclear +@end table + +@node Examples of gnatchop Usage +@section Examples of @code{gnatchop} Usage + +@table @code +@ifset vms +@item gnatchop /OVERWRITE HELLO_S.ADA [PRERELEASE.FILES] +@end ifset +@ifclear vms +@item gnatchop -w hello_s.ada prerelease/files +@end ifclear + +Chops the source file @file{hello_s.ada}. The output files will be +placed in the directory @file{^prerelease/files^[PRERELEASE.FILES]^}, +overwriting any +files with matching names in that directory (no files in the current +directory are modified). + +@item gnatchop ^archive^ARCHIVE.^ +Chops the source file @file{^archive^ARCHIVE.^} +into the current directory. One +useful application of @code{gnatchop} is in sending sets of sources +around, for example in email messages. The required sources are simply +concatenated (for example, using a ^Unix @code{cat}^VMS @code{APPEND/NEW}^ +command), and then +@command{gnatchop} is used at the other end to reconstitute the original +file names. + +@item gnatchop file1 file2 file3 direc +Chops all units in files @file{file1}, @file{file2}, @file{file3}, placing +the resulting files in the directory @file{direc}. Note that if any units +occur more than once anywhere within this set of files, an error message +is generated, and no files are written. To override this check, use the +@option{^-w^/OVERWRITE^} switch, +in which case the last occurrence in the last file will +be the one that is output, and earlier duplicate occurrences for a given +unit will be skipped. +@end table + +@node Configuration Pragmas +@chapter Configuration Pragmas +@cindex Configuration pragmas +@cindex Pragmas, configuration + +@noindent +Configuration pragmas include those pragmas described as +such in the Ada Reference Manual, as well as +implementation-dependent pragmas that are configuration pragmas. +@xref{Implementation Defined Pragmas,,, gnat_rm, GNAT Reference Manual}, +for details on these additional GNAT-specific configuration pragmas. +Most notably, the pragma @code{Source_File_Name}, which allows +specifying non-default names for source files, is a configuration +pragma. The following is a complete list of configuration pragmas +recognized by GNAT: + +@smallexample + Ada_83 + Ada_95 + Ada_05 + Ada_2005 + Ada_12 + Ada_2012 + Assertion_Policy + Assume_No_Invalid_Values + C_Pass_By_Copy + Check_Name + Check_Policy + Compile_Time_Error + Compile_Time_Warning + Compiler_Unit + Component_Alignment + Convention_Identifier + Debug_Policy + Detect_Blocking + Default_Storage_Pool + Discard_Names + Elaboration_Checks + Eliminate + Extend_System + Extensions_Allowed + External_Name_Casing + Fast_Math + Favor_Top_Level + Float_Representation + Implicit_Packing + Initialize_Scalars + Interrupt_State + License + Locking_Policy + Long_Float + No_Run_Time + No_Strict_Aliasing + Normalize_Scalars + Optimize_Alignment + Persistent_BSS + Polling + Priority_Specific_Dispatching + Profile + Profile_Warnings + Propagate_Exceptions + Queuing_Policy + Ravenscar + Restricted_Run_Time + Restrictions + Restrictions_Warnings + Reviewable + Short_Circuit_And_Or + Source_File_Name + Source_File_Name_Project + Style_Checks + Suppress + Suppress_Exception_Locations + Task_Dispatching_Policy + Universal_Data + Unsuppress + Use_VADS_Size + Validity_Checks + Warnings + Wide_Character_Encoding + +@end smallexample + +@menu +* Handling of Configuration Pragmas:: +* The Configuration Pragmas Files:: +@end menu + +@node Handling of Configuration Pragmas +@section Handling of Configuration Pragmas + +Configuration pragmas may either appear at the start of a compilation +unit, in which case they apply only to that unit, or they may apply to +all compilations performed in a given compilation environment. + +GNAT also provides the @code{gnatchop} utility to provide an automatic +way to handle configuration pragmas following the semantics for +compilations (that is, files with multiple units), described in the RM. +See @ref{Operating gnatchop in Compilation Mode} for details. +However, for most purposes, it will be more convenient to edit the +@file{gnat.adc} file that contains configuration pragmas directly, +as described in the following section. + +@node The Configuration Pragmas Files +@section The Configuration Pragmas Files +@cindex @file{gnat.adc} + +@noindent +In GNAT a compilation environment is defined by the current +directory at the time that a compile command is given. This current +directory is searched for a file whose name is @file{gnat.adc}. If +this file is present, it is expected to contain one or more +configuration pragmas that will be applied to the current compilation. +However, if the switch @option{-gnatA} is used, @file{gnat.adc} is not +considered. + +Configuration pragmas may be entered into the @file{gnat.adc} file +either by running @code{gnatchop} on a source file that consists only of +configuration pragmas, or more conveniently by +direct editing of the @file{gnat.adc} file, which is a standard format +source file. + +In addition to @file{gnat.adc}, additional files containing configuration +pragmas may be applied to the current compilation using the switch +@option{-gnatec}@var{path}. @var{path} must designate an existing file that +contains only configuration pragmas. These configuration pragmas are +in addition to those found in @file{gnat.adc} (provided @file{gnat.adc} +is present and switch @option{-gnatA} is not used). + +It is allowed to specify several switches @option{-gnatec}, all of which +will be taken into account. + +If you are using project file, a separate mechanism is provided using +project attributes, see @ref{Specifying Configuration Pragmas} for more +details. + +@ifset vms +Of special interest to GNAT OpenVMS Alpha is the following +configuration pragma: + +@smallexample @c ada +@cartouche +pragma Extend_System (Aux_DEC); +@end cartouche +@end smallexample + +@noindent +In the presence of this pragma, GNAT adds to the definition of the +predefined package SYSTEM all the additional types and subprograms that are +defined in HP Ada. See @ref{Compatibility with HP Ada} for details. +@end ifset + +@node Handling Arbitrary File Naming Conventions Using gnatname +@chapter Handling Arbitrary File Naming Conventions Using @code{gnatname} +@cindex Arbitrary File Naming Conventions + +@menu +* Arbitrary File Naming Conventions:: +* Running gnatname:: +* Switches for gnatname:: +* Examples of gnatname Usage:: +@end menu + +@node Arbitrary File Naming Conventions +@section Arbitrary File Naming Conventions + +@noindent +The GNAT compiler must be able to know the source file name of a compilation +unit. When using the standard GNAT default file naming conventions +(@code{.ads} for specs, @code{.adb} for bodies), the GNAT compiler +does not need additional information. + +@noindent +When the source file names do not follow the standard GNAT default file naming +conventions, the GNAT compiler must be given additional information through +a configuration pragmas file (@pxref{Configuration Pragmas}) +or a project file. +When the non-standard file naming conventions are well-defined, +a small number of pragmas @code{Source_File_Name} specifying a naming pattern +(@pxref{Alternative File Naming Schemes}) may be sufficient. However, +if the file naming conventions are irregular or arbitrary, a number +of pragma @code{Source_File_Name} for individual compilation units +must be defined. +To help maintain the correspondence between compilation unit names and +source file names within the compiler, +GNAT provides a tool @code{gnatname} to generate the required pragmas for a +set of files. + +@node Running gnatname +@section Running @code{gnatname} + +@noindent +The usual form of the @code{gnatname} command is + +@smallexample +@c $ gnatname @ovar{switches} @var{naming_pattern} @ovar{naming_patterns} +@c @r{[}--and @ovar{switches} @var{naming_pattern} @ovar{naming_patterns}@r{]} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatname @r{[}@var{switches}@r{]} @var{naming_pattern} @r{[}@var{naming_patterns}@r{]} + @r{[}--and @r{[}@var{switches}@r{]} @var{naming_pattern} @r{[}@var{naming_patterns}@r{]}@r{]} +@end smallexample + +@noindent +All of the arguments are optional. If invoked without any argument, +@code{gnatname} will display its usage. + +@noindent +When used with at least one naming pattern, @code{gnatname} will attempt to +find all the compilation units in files that follow at least one of the +naming patterns. To find these compilation units, +@code{gnatname} will use the GNAT compiler in syntax-check-only mode on all +regular files. + +@noindent +One or several Naming Patterns may be given as arguments to @code{gnatname}. +Each Naming Pattern is enclosed between double quotes (or single +quotes on Windows). +A Naming Pattern is a regular expression similar to the wildcard patterns +used in file names by the Unix shells or the DOS prompt. + +@noindent +@code{gnatname} may be called with several sections of directories/patterns. +Sections are separated by switch @code{--and}. In each section, there must be +at least one pattern. If no directory is specified in a section, the current +directory (or the project directory is @code{-P} is used) is implied. +The options other that the directory switches and the patterns apply globally +even if they are in different sections. + +@noindent +Examples of Naming Patterns are + +@smallexample + "*.[12].ada" + "*.ad[sb]*" + "body_*" "spec_*" +@end smallexample + +@noindent +For a more complete description of the syntax of Naming Patterns, +see the second kind of regular expressions described in @file{g-regexp.ads} +(the ``Glob'' regular expressions). + +@noindent +When invoked with no switch @code{-P}, @code{gnatname} will create a +configuration pragmas file @file{gnat.adc} in the current working directory, +with pragmas @code{Source_File_Name} for each file that contains a valid Ada +unit. + +@node Switches for gnatname +@section Switches for @code{gnatname} + +@noindent +Switches for @code{gnatname} must precede any specified Naming Pattern. + +@noindent +You may specify any of the following switches to @code{gnatname}: + +@table @option +@c !sort! + +@item --version +@cindex @option{--version} @command{gnatname} +Display Copyright and version, then exit disregarding all other options. + +@item --help +@cindex @option{--help} @command{gnatname} +If @option{--version} was not used, display usage, then exit disregarding +all other options. + +@item --and +Start another section of directories/patterns. + +@item ^-c^/CONFIG_FILE=^@file{file} +@cindex @option{^-c^/CONFIG_FILE^} (@code{gnatname}) +Create a configuration pragmas file @file{file} (instead of the default +@file{gnat.adc}). +@ifclear vms +There may be zero, one or more space between @option{-c} and +@file{file}. +@end ifclear +@file{file} may include directory information. @file{file} must be +writable. There may be only one switch @option{^-c^/CONFIG_FILE^}. +When a switch @option{^-c^/CONFIG_FILE^} is +specified, no switch @option{^-P^/PROJECT_FILE^} may be specified (see below). + +@item ^-d^/SOURCE_DIRS=^@file{dir} +@cindex @option{^-d^/SOURCE_DIRS^} (@code{gnatname}) +Look for source files in directory @file{dir}. There may be zero, one or more +spaces between @option{^-d^/SOURCE_DIRS=^} and @file{dir}. +When a switch @option{^-d^/SOURCE_DIRS^} +is specified, the current working directory will not be searched for source +files, unless it is explicitly specified with a @option{^-d^/SOURCE_DIRS^} +or @option{^-D^/DIR_FILES^} switch. +Several switches @option{^-d^/SOURCE_DIRS^} may be specified. +If @file{dir} is a relative path, it is relative to the directory of +the configuration pragmas file specified with switch +@option{^-c^/CONFIG_FILE^}, +or to the directory of the project file specified with switch +@option{^-P^/PROJECT_FILE^} or, +if neither switch @option{^-c^/CONFIG_FILE^} +nor switch @option{^-P^/PROJECT_FILE^} are specified, it is relative to the +current working directory. The directory +specified with switch @option{^-d^/SOURCE_DIRS^} must exist and be readable. + +@item ^-D^/DIRS_FILE=^@file{file} +@cindex @option{^-D^/DIRS_FILE^} (@code{gnatname}) +Look for source files in all directories listed in text file @file{file}. +There may be zero, one or more spaces between @option{^-D^/DIRS_FILE=^} +and @file{file}. +@file{file} must be an existing, readable text file. +Each nonempty line in @file{file} must be a directory. +Specifying switch @option{^-D^/DIRS_FILE^} is equivalent to specifying as many +switches @option{^-d^/SOURCE_DIRS^} as there are nonempty lines in +@file{file}. + +@item ^-f^/FOREIGN_PATTERN=^@file{pattern} +@cindex @option{^-f^/FOREIGN_PATTERN^} (@code{gnatname}) +Foreign patterns. Using this switch, it is possible to add sources of languages +other than Ada to the list of sources of a project file. +It is only useful if a ^-P^/PROJECT_FILE^ switch is used. +For example, +@smallexample +gnatname ^-Pprj -f"*.c"^/PROJECT_FILE=PRJ /FOREIGN_PATTERN=*.C^ "*.ada" +@end smallexample +@noindent +will look for Ada units in all files with the @file{.ada} extension, +and will add to the list of file for project @file{prj.gpr} the C files +with extension @file{.^c^C^}. + +@item ^-h^/HELP^ +@cindex @option{^-h^/HELP^} (@code{gnatname}) +Output usage (help) information. The output is written to @file{stdout}. + +@item ^-P^/PROJECT_FILE=^@file{proj} +@cindex @option{^-P^/PROJECT_FILE^} (@code{gnatname}) +Create or update project file @file{proj}. There may be zero, one or more space +between @option{-P} and @file{proj}. @file{proj} may include directory +information. @file{proj} must be writable. +There may be only one switch @option{^-P^/PROJECT_FILE^}. +When a switch @option{^-P^/PROJECT_FILE^} is specified, +no switch @option{^-c^/CONFIG_FILE^} may be specified. + +@item ^-v^/VERBOSE^ +@cindex @option{^-v^/VERBOSE^} (@code{gnatname}) +Verbose mode. Output detailed explanation of behavior to @file{stdout}. +This includes name of the file written, the name of the directories to search +and, for each file in those directories whose name matches at least one of +the Naming Patterns, an indication of whether the file contains a unit, +and if so the name of the unit. + +@item ^-v -v^/VERBOSE /VERBOSE^ +@cindex @option{^-v -v^/VERBOSE /VERBOSE^} (@code{gnatname}) +Very Verbose mode. In addition to the output produced in verbose mode, +for each file in the searched directories whose name matches none of +the Naming Patterns, an indication is given that there is no match. + +@item ^-x^/EXCLUDED_PATTERN=^@file{pattern} +@cindex @option{^-x^/EXCLUDED_PATTERN^} (@code{gnatname}) +Excluded patterns. Using this switch, it is possible to exclude some files +that would match the name patterns. For example, +@smallexample +gnatname ^-x "*_nt.ada"^/EXCLUDED_PATTERN=*_nt.ada^ "*.ada" +@end smallexample +@noindent +will look for Ada units in all files with the @file{.ada} extension, +except those whose names end with @file{_nt.ada}. + +@end table + +@node Examples of gnatname Usage +@section Examples of @code{gnatname} Usage + +@ifset vms +@smallexample +$ gnatname /CONFIG_FILE=[HOME.ME]NAMES.ADC /SOURCE_DIRS=SOURCES "[a-z]*.ada*" +@end smallexample +@end ifset + +@ifclear vms +@smallexample +$ gnatname -c /home/me/names.adc -d sources "[a-z]*.ada*" +@end smallexample +@end ifclear + +@noindent +In this example, the directory @file{^/home/me^[HOME.ME]^} must already exist +and be writable. In addition, the directory +@file{^/home/me/sources^[HOME.ME.SOURCES]^} (specified by +@option{^-d sources^/SOURCE_DIRS=SOURCES^}) must exist and be readable. + +@ifclear vms +Note the optional spaces after @option{-c} and @option{-d}. +@end ifclear + +@smallexample +@ifclear vms +$ gnatname -P/home/me/proj -x "*_nt_body.ada" + -dsources -dsources/plus -Dcommon_dirs.txt "body_*" "spec_*" +@end ifclear +@ifset vms +$ gnatname /PROJECT_FILE=[HOME.ME]PROJ + /EXCLUDED_PATTERN=*_nt_body.ada + /SOURCE_DIRS=(SOURCES,[SOURCES.PLUS]) + /DIRS_FILE=COMMON_DIRS.TXT "body_*" "spec_*" +@end ifset +@end smallexample + +Note that several switches @option{^-d^/SOURCE_DIRS^} may be used, +even in conjunction with one or several switches +@option{^-D^/DIRS_FILE^}. Several Naming Patterns and one excluded pattern +are used in this example. + +@c ***************************************** +@c * G N A T P r o j e c t M a n a g e r * +@c ***************************************** + +@c ------ macros for projects.texi +@c These macros are needed when building the gprbuild documentation, but +@c should have no effect in the gnat user's guide + +@macro CODESAMPLE{TXT} +@smallexample +@group +\TXT\ +@end group +@end smallexample +@end macro + +@macro PROJECTFILE{TXT} +@CODESAMPLE{\TXT\} +@end macro + +@c simulates a newline when in a @CODESAMPLE +@macro NL{} +@end macro + +@macro TIP{TXT} +@quotation +@noindent +\TXT\ +@end quotation +@end macro + +@macro TIPHTML{TXT} +\TXT\ +@end macro + +@macro IMPORTANT{TXT} +@quotation +@noindent +\TXT\ +@end quotation + +@end macro + +@macro NOTE{TXT} +@quotation +@noindent +\TXT\ +@end quotation +@end macro + +@include projects.texi + +@c ***************************************** +@c * Cross-referencing tools +@c ***************************************** + +@node The Cross-Referencing Tools gnatxref and gnatfind +@chapter The Cross-Referencing Tools @code{gnatxref} and @code{gnatfind} +@findex gnatxref +@findex gnatfind + +@noindent +The compiler generates cross-referencing information (unless +you set the @samp{-gnatx} switch), which are saved in the @file{.ali} files. +This information indicates where in the source each entity is declared and +referenced. Note that entities in package Standard are not included, but +entities in all other predefined units are included in the output. + +Before using any of these two tools, you need to compile successfully your +application, so that GNAT gets a chance to generate the cross-referencing +information. + +The two tools @code{gnatxref} and @code{gnatfind} take advantage of this +information to provide the user with the capability to easily locate the +declaration and references to an entity. These tools are quite similar, +the difference being that @code{gnatfind} is intended for locating +definitions and/or references to a specified entity or entities, whereas +@code{gnatxref} is oriented to generating a full report of all +cross-references. + +To use these tools, you must not compile your application using the +@option{-gnatx} switch on the @command{gnatmake} command line +(@pxref{The GNAT Make Program gnatmake}). Otherwise, cross-referencing +information will not be generated. + +Note: to invoke @code{gnatxref} or @code{gnatfind} with a project file, +use the @code{gnat} driver (see @ref{The GNAT Driver and Project Files}). + +@menu +* Switches for gnatxref:: +* Switches for gnatfind:: +* Project Files for gnatxref and gnatfind:: +* Regular Expressions in gnatfind and gnatxref:: +* Examples of gnatxref Usage:: +* Examples of gnatfind Usage:: +@end menu + +@node Switches for gnatxref +@section @code{gnatxref} Switches + +@noindent +The command invocation for @code{gnatxref} is: +@smallexample +@c $ gnatxref @ovar{switches} @var{sourcefile1} @r{[}@var{sourcefile2} @dots{}@r{]} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatxref @r{[}@var{switches}@r{]} @var{sourcefile1} @r{[}@var{sourcefile2} @dots{}@r{]} +@end smallexample + +@noindent +where + +@table @var +@item sourcefile1 +@itemx sourcefile2 +identifies the source files for which a report is to be generated. The +``with''ed units will be processed too. You must provide at least one file. + +These file names are considered to be regular expressions, so for instance +specifying @file{source*.adb} is the same as giving every file in the current +directory whose name starts with @file{source} and whose extension is +@file{adb}. + +You shouldn't specify any directory name, just base names. @command{gnatxref} +and @command{gnatfind} will be able to locate these files by themselves using +the source path. If you specify directories, no result is produced. + +@end table + +@noindent +The switches can be: +@table @option +@c !sort! +@item --version +@cindex @option{--version} @command{gnatxref} +Display Copyright and version, then exit disregarding all other options. + +@item --help +@cindex @option{--help} @command{gnatxref} +If @option{--version} was not used, display usage, then exit disregarding +all other options. + +@item ^-a^/ALL_FILES^ +@cindex @option{^-a^/ALL_FILES^} (@command{gnatxref}) +If this switch is present, @code{gnatfind} and @code{gnatxref} will parse +the read-only files found in the library search path. Otherwise, these files +will be ignored. This option can be used to protect Gnat sources or your own +libraries from being parsed, thus making @code{gnatfind} and @code{gnatxref} +much faster, and their output much smaller. Read-only here refers to access +or permissions status in the file system for the current user. + +@item -aIDIR +@cindex @option{-aIDIR} (@command{gnatxref}) +When looking for source files also look in directory DIR. The order in which +source file search is undertaken is the same as for @command{gnatmake}. + +@item -aODIR +@cindex @option{-aODIR} (@command{gnatxref}) +When searching for library and object files, look in directory +DIR. The order in which library files are searched is the same as for +@command{gnatmake}. + +@item -nostdinc +@cindex @option{-nostdinc} (@command{gnatxref}) +Do not look for sources in the system default directory. + +@item -nostdlib +@cindex @option{-nostdlib} (@command{gnatxref}) +Do not look for library files in the system default directory. + +@item --ext=@var{extension} +@cindex @option{--ext} (@command{gnatxref}) +Specify an alternate ali file extension. The default is @code{ali} and other +extensions (e.g. @code{sli} for SPARK library files) may be specified via this +switch. Note that if this switch overrides the default, which means that only +the new extension will be considered. + +@item --RTS=@var{rts-path} +@cindex @option{--RTS} (@command{gnatxref}) +Specifies the default location of the runtime library. Same meaning as the +equivalent @command{gnatmake} flag (@pxref{Switches for gnatmake}). + +@item ^-d^/DERIVED_TYPES^ +@cindex @option{^-d^/DERIVED_TYPES^} (@command{gnatxref}) +If this switch is set @code{gnatxref} will output the parent type +reference for each matching derived types. + +@item ^-f^/FULL_PATHNAME^ +@cindex @option{^-f^/FULL_PATHNAME^} (@command{gnatxref}) +If this switch is set, the output file names will be preceded by their +directory (if the file was found in the search path). If this switch is +not set, the directory will not be printed. + +@item ^-g^/IGNORE_LOCALS^ +@cindex @option{^-g^/IGNORE_LOCALS^} (@command{gnatxref}) +If this switch is set, information is output only for library-level +entities, ignoring local entities. The use of this switch may accelerate +@code{gnatfind} and @code{gnatxref}. + +@item -IDIR +@cindex @option{-IDIR} (@command{gnatxref}) +Equivalent to @samp{-aODIR -aIDIR}. + +@item -pFILE +@cindex @option{-pFILE} (@command{gnatxref}) +Specify a project file to use @xref{GNAT Project Manager}. +If you need to use the @file{.gpr} +project files, you should use gnatxref through the GNAT driver +(@command{gnat xref -Pproject}). + +By default, @code{gnatxref} and @code{gnatfind} will try to locate a +project file in the current directory. + +If a project file is either specified or found by the tools, then the content +of the source directory and object directory lines are added as if they +had been specified respectively by @samp{^-aI^/SOURCE_SEARCH^} +and @samp{^-aO^OBJECT_SEARCH^}. +@item ^-u^/UNUSED^ +Output only unused symbols. This may be really useful if you give your +main compilation unit on the command line, as @code{gnatxref} will then +display every unused entity and 'with'ed package. + +@ifclear vms +@item -v +Instead of producing the default output, @code{gnatxref} will generate a +@file{tags} file that can be used by vi. For examples how to use this +feature, see @ref{Examples of gnatxref Usage}. The tags file is output +to the standard output, thus you will have to redirect it to a file. +@end ifclear + +@end table + +@noindent +All these switches may be in any order on the command line, and may even +appear after the file names. They need not be separated by spaces, thus +you can say @samp{gnatxref ^-ag^/ALL_FILES/IGNORE_LOCALS^} instead of +@samp{gnatxref ^-a -g^/ALL_FILES /IGNORE_LOCALS^}. + +@node Switches for gnatfind +@section @code{gnatfind} Switches + +@noindent +The command line for @code{gnatfind} is: + +@smallexample +@c $ gnatfind @ovar{switches} @var{pattern}@r{[}:@var{sourcefile}@r{[}:@var{line}@r{[}:@var{column}@r{]]]} +@c @r{[}@var{file1} @var{file2} @dots{}] +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatfind @r{[}@var{switches}@r{]} @var{pattern}@r{[}:@var{sourcefile}@r{[}:@var{line}@r{[}:@var{column}@r{]]]} + @r{[}@var{file1} @var{file2} @dots{}@r{]} +@end smallexample + +@noindent +where + +@table @var +@item pattern +An entity will be output only if it matches the regular expression found +in @var{pattern}, see @ref{Regular Expressions in gnatfind and gnatxref}. + +Omitting the pattern is equivalent to specifying @samp{*}, which +will match any entity. Note that if you do not provide a pattern, you +have to provide both a sourcefile and a line. + +Entity names are given in Latin-1, with uppercase/lowercase equivalence +for matching purposes. At the current time there is no support for +8-bit codes other than Latin-1, or for wide characters in identifiers. + +@item sourcefile +@code{gnatfind} will look for references, bodies or declarations +of symbols referenced in @file{@var{sourcefile}}, at line @var{line} +and column @var{column}. See @ref{Examples of gnatfind Usage} +for syntax examples. + +@item line +is a decimal integer identifying the line number containing +the reference to the entity (or entities) to be located. + +@item column +is a decimal integer identifying the exact location on the +line of the first character of the identifier for the +entity reference. Columns are numbered from 1. + +@item file1 file2 @dots{} +The search will be restricted to these source files. If none are given, then +the search will be done for every library file in the search path. +These file must appear only after the pattern or sourcefile. + +These file names are considered to be regular expressions, so for instance +specifying @file{source*.adb} is the same as giving every file in the current +directory whose name starts with @file{source} and whose extension is +@file{adb}. + +The location of the spec of the entity will always be displayed, even if it +isn't in one of @file{@var{file1}}, @file{@var{file2}},@enddots{} The +occurrences of the entity in the separate units of the ones given on the +command line will also be displayed. + +Note that if you specify at least one file in this part, @code{gnatfind} may +sometimes not be able to find the body of the subprograms. + +@end table + +@noindent +At least one of 'sourcefile' or 'pattern' has to be present on +the command line. + +The following switches are available: +@table @option +@c !sort! + +@cindex @option{--version} @command{gnatfind} +Display Copyright and version, then exit disregarding all other options. + +@item --help +@cindex @option{--help} @command{gnatfind} +If @option{--version} was not used, display usage, then exit disregarding +all other options. + +@item ^-a^/ALL_FILES^ +@cindex @option{^-a^/ALL_FILES^} (@command{gnatfind}) +If this switch is present, @code{gnatfind} and @code{gnatxref} will parse +the read-only files found in the library search path. Otherwise, these files +will be ignored. This option can be used to protect Gnat sources or your own +libraries from being parsed, thus making @code{gnatfind} and @code{gnatxref} +much faster, and their output much smaller. Read-only here refers to access +or permission status in the file system for the current user. + +@item -aIDIR +@cindex @option{-aIDIR} (@command{gnatfind}) +When looking for source files also look in directory DIR. The order in which +source file search is undertaken is the same as for @command{gnatmake}. + +@item -aODIR +@cindex @option{-aODIR} (@command{gnatfind}) +When searching for library and object files, look in directory +DIR. The order in which library files are searched is the same as for +@command{gnatmake}. + +@item -nostdinc +@cindex @option{-nostdinc} (@command{gnatfind}) +Do not look for sources in the system default directory. + +@item -nostdlib +@cindex @option{-nostdlib} (@command{gnatfind}) +Do not look for library files in the system default directory. + +@item --ext=@var{extension} +@cindex @option{--ext} (@command{gnatfind}) +Specify an alternate ali file extension. The default is @code{ali} and other +extensions (e.g. @code{sli} for SPARK library files) may be specified via this +switch. Note that if this switch overrides the default, which means that only +the new extension will be considered. + +@item --RTS=@var{rts-path} +@cindex @option{--RTS} (@command{gnatfind}) +Specifies the default location of the runtime library. Same meaning as the +equivalent @command{gnatmake} flag (@pxref{Switches for gnatmake}). + +@item ^-d^/DERIVED_TYPE_INFORMATION^ +@cindex @option{^-d^/DERIVED_TYPE_INFORMATION^} (@code{gnatfind}) +If this switch is set, then @code{gnatfind} will output the parent type +reference for each matching derived types. + +@item ^-e^/EXPRESSIONS^ +@cindex @option{^-e^/EXPRESSIONS^} (@command{gnatfind}) +By default, @code{gnatfind} accept the simple regular expression set for +@samp{pattern}. If this switch is set, then the pattern will be +considered as full Unix-style regular expression. + +@item ^-f^/FULL_PATHNAME^ +@cindex @option{^-f^/FULL_PATHNAME^} (@command{gnatfind}) +If this switch is set, the output file names will be preceded by their +directory (if the file was found in the search path). If this switch is +not set, the directory will not be printed. + +@item ^-g^/IGNORE_LOCALS^ +@cindex @option{^-g^/IGNORE_LOCALS^} (@command{gnatfind}) +If this switch is set, information is output only for library-level +entities, ignoring local entities. The use of this switch may accelerate +@code{gnatfind} and @code{gnatxref}. + +@item -IDIR +@cindex @option{-IDIR} (@command{gnatfind}) +Equivalent to @samp{-aODIR -aIDIR}. + +@item -pFILE +@cindex @option{-pFILE} (@command{gnatfind}) +Specify a project file (@pxref{GNAT Project Manager}) to use. +By default, @code{gnatxref} and @code{gnatfind} will try to locate a +project file in the current directory. + +If a project file is either specified or found by the tools, then the content +of the source directory and object directory lines are added as if they +had been specified respectively by @samp{^-aI^/SOURCE_SEARCH^} and +@samp{^-aO^/OBJECT_SEARCH^}. + +@item ^-r^/REFERENCES^ +@cindex @option{^-r^/REFERENCES^} (@command{gnatfind}) +By default, @code{gnatfind} will output only the information about the +declaration, body or type completion of the entities. If this switch is +set, the @code{gnatfind} will locate every reference to the entities in +the files specified on the command line (or in every file in the search +path if no file is given on the command line). + +@item ^-s^/PRINT_LINES^ +@cindex @option{^-s^/PRINT_LINES^} (@command{gnatfind}) +If this switch is set, then @code{gnatfind} will output the content +of the Ada source file lines were the entity was found. + +@item ^-t^/TYPE_HIERARCHY^ +@cindex @option{^-t^/TYPE_HIERARCHY^} (@command{gnatfind}) +If this switch is set, then @code{gnatfind} will output the type hierarchy for +the specified type. It act like -d option but recursively from parent +type to parent type. When this switch is set it is not possible to +specify more than one file. + +@end table + +@noindent +All these switches may be in any order on the command line, and may even +appear after the file names. They need not be separated by spaces, thus +you can say @samp{gnatxref ^-ag^/ALL_FILES/IGNORE_LOCALS^} instead of +@samp{gnatxref ^-a -g^/ALL_FILES /IGNORE_LOCALS^}. + +As stated previously, gnatfind will search in every directory in the +search path. You can force it to look only in the current directory if +you specify @code{*} at the end of the command line. + +@node Project Files for gnatxref and gnatfind +@section Project Files for @command{gnatxref} and @command{gnatfind} + +@noindent +Project files allow a programmer to specify how to compile its +application, where to find sources, etc. These files are used +@ifclear vms +primarily by GPS, but they can also be used +@end ifclear +by the two tools +@code{gnatxref} and @code{gnatfind}. + +A project file name must end with @file{.gpr}. If a single one is +present in the current directory, then @code{gnatxref} and @code{gnatfind} will +extract the information from it. If multiple project files are found, none of +them is read, and you have to use the @samp{-p} switch to specify the one +you want to use. + +The following lines can be included, even though most of them have default +values which can be used in most cases. +The lines can be entered in any order in the file. +Except for @file{src_dir} and @file{obj_dir}, you can only have one instance of +each line. If you have multiple instances, only the last one is taken into +account. + +@table @code +@item src_dir=DIR +[default: @code{"^./^[]^"}] +specifies a directory where to look for source files. Multiple @code{src_dir} +lines can be specified and they will be searched in the order they +are specified. + +@item obj_dir=DIR +[default: @code{"^./^[]^"}] +specifies a directory where to look for object and library files. Multiple +@code{obj_dir} lines can be specified, and they will be searched in the order +they are specified + +@item comp_opt=SWITCHES +[default: @code{""}] +creates a variable which can be referred to subsequently by using +the @code{$@{comp_opt@}} notation. This is intended to store the default +switches given to @command{gnatmake} and @command{gcc}. + +@item bind_opt=SWITCHES +[default: @code{""}] +creates a variable which can be referred to subsequently by using +the @samp{$@{bind_opt@}} notation. This is intended to store the default +switches given to @command{gnatbind}. + +@item link_opt=SWITCHES +[default: @code{""}] +creates a variable which can be referred to subsequently by using +the @samp{$@{link_opt@}} notation. This is intended to store the default +switches given to @command{gnatlink}. + +@item main=EXECUTABLE +[default: @code{""}] +specifies the name of the executable for the application. This variable can +be referred to in the following lines by using the @samp{$@{main@}} notation. + +@ifset vms +@item comp_cmd=COMMAND +[default: @code{"GNAT COMPILE /SEARCH=$@{src_dir@} /DEBUG /TRY_SEMANTICS"}] +@end ifset +@ifclear vms +@item comp_cmd=COMMAND +[default: @code{"gcc -c -I$@{src_dir@} -g -gnatq"}] +@end ifclear +specifies the command used to compile a single file in the application. + +@ifset vms +@item make_cmd=COMMAND +[default: @code{"GNAT MAKE $@{main@} +/SOURCE_SEARCH=$@{src_dir@} /OBJECT_SEARCH=$@{obj_dir@} +/DEBUG /TRY_SEMANTICS /COMPILER_QUALIFIERS $@{comp_opt@} +/BINDER_QUALIFIERS $@{bind_opt@} /LINKER_QUALIFIERS $@{link_opt@}"}] +@end ifset +@ifclear vms +@item make_cmd=COMMAND +[default: @code{"gnatmake $@{main@} -aI$@{src_dir@} +-aO$@{obj_dir@} -g -gnatq -cargs $@{comp_opt@} +-bargs $@{bind_opt@} -largs $@{link_opt@}"}] +@end ifclear +specifies the command used to recompile the whole application. + +@item run_cmd=COMMAND +[default: @code{"$@{main@}"}] +specifies the command used to run the application. + +@item debug_cmd=COMMAND +[default: @code{"gdb $@{main@}"}] +specifies the command used to debug the application + +@end table + +@noindent +@command{gnatxref} and @command{gnatfind} only take into account the +@code{src_dir} and @code{obj_dir} lines, and ignore the others. + +@node Regular Expressions in gnatfind and gnatxref +@section Regular Expressions in @code{gnatfind} and @code{gnatxref} + +@noindent +As specified in the section about @command{gnatfind}, the pattern can be a +regular expression. Actually, there are to set of regular expressions +which are recognized by the program: + +@table @code +@item globbing patterns +These are the most usual regular expression. They are the same that you +generally used in a Unix shell command line, or in a DOS session. + +Here is a more formal grammar: +@smallexample +@group +@iftex +@leftskip=.5cm +@end iftex +regexp ::= term +term ::= elmt -- matches elmt +term ::= elmt elmt -- concatenation (elmt then elmt) +term ::= * -- any string of 0 or more characters +term ::= ? -- matches any character +term ::= [char @{char@}] -- matches any character listed +term ::= [char - char] -- matches any character in range +@end group +@end smallexample + +@item full regular expression +The second set of regular expressions is much more powerful. This is the +type of regular expressions recognized by utilities such a @file{grep}. + +The following is the form of a regular expression, expressed in Ada +reference manual style BNF is as follows + +@smallexample +@iftex +@leftskip=.5cm +@end iftex +@group +regexp ::= term @{| term@} -- alternation (term or term @dots{}) + +term ::= item @{item@} -- concatenation (item then item) + +item ::= elmt -- match elmt +item ::= elmt * -- zero or more elmt's +item ::= elmt + -- one or more elmt's +item ::= elmt ? -- matches elmt or nothing +@end group +@group +elmt ::= nschar -- matches given character +elmt ::= [nschar @{nschar@}] -- matches any character listed +elmt ::= [^^^ nschar @{nschar@}] -- matches any character not listed +elmt ::= [char - char] -- matches chars in given range +elmt ::= \ char -- matches given character +elmt ::= . -- matches any single character +elmt ::= ( regexp ) -- parens used for grouping + +char ::= any character, including special characters +nschar ::= any character except ()[].*+?^^^ +@end group +@end smallexample + +Following are a few examples: + +@table @samp +@item abcde|fghi +will match any of the two strings @samp{abcde} and @samp{fghi}, + +@item abc*d +will match any string like @samp{abd}, @samp{abcd}, @samp{abccd}, +@samp{abcccd}, and so on, + +@item [a-z]+ +will match any string which has only lowercase characters in it (and at +least one character. + +@end table +@end table + +@node Examples of gnatxref Usage +@section Examples of @code{gnatxref} Usage + +@subsection General Usage + +@noindent +For the following examples, we will consider the following units: + +@smallexample @c ada +@group +@cartouche +main.ads: +1: with Bar; +2: package Main is +3: procedure Foo (B : in Integer); +4: C : Integer; +5: private +6: D : Integer; +7: end Main; + +main.adb: +1: package body Main is +2: procedure Foo (B : in Integer) is +3: begin +4: C := B; +5: D := B; +6: Bar.Print (B); +7: Bar.Print (C); +8: end Foo; +9: end Main; + +bar.ads: +1: package Bar is +2: procedure Print (B : Integer); +3: end bar; +@end cartouche +@end group +@end smallexample + +@table @code + +@noindent +The first thing to do is to recompile your application (for instance, in +that case just by doing a @samp{gnatmake main}, so that GNAT generates +the cross-referencing information. +You can then issue any of the following commands: + +@item gnatxref main.adb +@code{gnatxref} generates cross-reference information for main.adb +and every unit 'with'ed by main.adb. + +The output would be: +@smallexample +@iftex +@leftskip=0cm +@end iftex +B Type: Integer + Decl: bar.ads 2:22 +B Type: Integer + Decl: main.ads 3:20 + Body: main.adb 2:20 + Ref: main.adb 4:13 5:13 6:19 +Bar Type: Unit + Decl: bar.ads 1:9 + Ref: main.adb 6:8 7:8 + main.ads 1:6 +C Type: Integer + Decl: main.ads 4:5 + Modi: main.adb 4:8 + Ref: main.adb 7:19 +D Type: Integer + Decl: main.ads 6:5 + Modi: main.adb 5:8 +Foo Type: Unit + Decl: main.ads 3:15 + Body: main.adb 2:15 +Main Type: Unit + Decl: main.ads 2:9 + Body: main.adb 1:14 +Print Type: Unit + Decl: bar.ads 2:15 + Ref: main.adb 6:12 7:12 +@end smallexample + +@noindent +that is the entity @code{Main} is declared in main.ads, line 2, column 9, +its body is in main.adb, line 1, column 14 and is not referenced any where. + +The entity @code{Print} is declared in bar.ads, line 2, column 15 and it +it referenced in main.adb, line 6 column 12 and line 7 column 12. + +@item gnatxref package1.adb package2.ads +@code{gnatxref} will generates cross-reference information for +package1.adb, package2.ads and any other package 'with'ed by any +of these. + +@end table + +@ifclear vms +@subsection Using gnatxref with vi + +@code{gnatxref} can generate a tags file output, which can be used +directly from @command{vi}. Note that the standard version of @command{vi} +will not work properly with overloaded symbols. Consider using another +free implementation of @command{vi}, such as @command{vim}. + +@smallexample +$ gnatxref -v gnatfind.adb > tags +@end smallexample + +@noindent +will generate the tags file for @code{gnatfind} itself (if the sources +are in the search path!). + +From @command{vi}, you can then use the command @samp{:tag @var{entity}} +(replacing @var{entity} by whatever you are looking for), and vi will +display a new file with the corresponding declaration of entity. +@end ifclear + +@node Examples of gnatfind Usage +@section Examples of @code{gnatfind} Usage + +@table @code + +@item gnatfind ^-f^/FULL_PATHNAME^ xyz:main.adb +Find declarations for all entities xyz referenced at least once in +main.adb. The references are search in every library file in the search +path. + +The directories will be printed as well (as the @samp{^-f^/FULL_PATHNAME^} +switch is set) + +The output will look like: +@smallexample +^directory/^[directory]^main.ads:106:14: xyz <= declaration +^directory/^[directory]^main.adb:24:10: xyz <= body +^directory/^[directory]^foo.ads:45:23: xyz <= declaration +@end smallexample + +@noindent +that is to say, one of the entities xyz found in main.adb is declared at +line 12 of main.ads (and its body is in main.adb), and another one is +declared at line 45 of foo.ads + +@item gnatfind ^-fs^/FULL_PATHNAME/SOURCE_LINE^ xyz:main.adb +This is the same command as the previous one, instead @code{gnatfind} will +display the content of the Ada source file lines. + +The output will look like: + +@smallexample +^directory/^[directory]^main.ads:106:14: xyz <= declaration + procedure xyz; +^directory/^[directory]^main.adb:24:10: xyz <= body + procedure xyz is +^directory/^[directory]^foo.ads:45:23: xyz <= declaration + xyz : Integer; +@end smallexample + +@noindent +This can make it easier to find exactly the location your are looking +for. + +@item gnatfind ^-r^/REFERENCES^ "*x*":main.ads:123 foo.adb +Find references to all entities containing an x that are +referenced on line 123 of main.ads. +The references will be searched only in main.ads and foo.adb. + +@item gnatfind main.ads:123 +Find declarations and bodies for all entities that are referenced on +line 123 of main.ads. + +This is the same as @code{gnatfind "*":main.adb:123}. + +@item gnatfind ^mydir/^[mydir]^main.adb:123:45 +Find the declaration for the entity referenced at column 45 in +line 123 of file main.adb in directory mydir. Note that it +is usual to omit the identifier name when the column is given, +since the column position identifies a unique reference. + +The column has to be the beginning of the identifier, and should not +point to any character in the middle of the identifier. + +@end table + +@c ********************************* +@node The GNAT Pretty-Printer gnatpp +@chapter The GNAT Pretty-Printer @command{gnatpp} +@findex gnatpp +@cindex Pretty-Printer + +@noindent +^The @command{gnatpp} tool^GNAT PRETTY^ is an ASIS-based utility +for source reformatting / pretty-printing. +It takes an Ada source file as input and generates a reformatted +version as output. +You can specify various style directives via switches; e.g., +identifier case conventions, rules of indentation, and comment layout. + +To produce a reformatted file, @command{gnatpp} generates and uses the ASIS +tree for the input source and thus requires the input to be syntactically and +semantically legal. +If this condition is not met, @command{gnatpp} will terminate with an +error message; no output file will be generated. + +If the source files presented to @command{gnatpp} contain +preprocessing directives, then the output file will +correspond to the generated source after all +preprocessing is carried out. There is no way +using @command{gnatpp} to obtain pretty printed files that +include the preprocessing directives. + +If the compilation unit +contained in the input source depends semantically upon units located +outside the current directory, you have to provide the source search path +when invoking @command{gnatpp}, if these units are contained in files with +names that do not follow the GNAT file naming rules, you have to provide +the configuration file describing the corresponding naming scheme; +see the description of the @command{gnatpp} +switches below. Another possibility is to use a project file and to +call @command{gnatpp} through the @command{gnat} driver + +The @command{gnatpp} command has the form + +@smallexample +@c $ gnatpp @ovar{switches} @var{filename} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatpp @r{[}@var{switches}@r{]} @var{filename} @r{[}-cargs @var{gcc_switches}@r{]} +@end smallexample + +@noindent +where +@itemize @bullet +@item +@var{switches} is an optional sequence of switches defining such properties as +the formatting rules, the source search path, and the destination for the +output source file + +@item +@var{filename} is the name (including the extension) of the source file to +reformat; ``wildcards'' or several file names on the same gnatpp command are +allowed. The file name may contain path information; it does not have to +follow the GNAT file naming rules + +@item +@samp{@var{gcc_switches}} is a list of switches for +@command{gcc}. They will be passed on to all compiler invocations made by +@command{gnatelim} to generate the ASIS trees. Here you can provide +@option{^-I^/INCLUDE_DIRS=^} switches to form the source search path, +use the @option{-gnatec} switch to set the configuration file, +use the @option{-gnat05} switch if sources should be compiled in +Ada 2005 mode etc. +@end itemize + +@menu +* Switches for gnatpp:: +* Formatting Rules:: +@end menu + +@node Switches for gnatpp +@section Switches for @command{gnatpp} + +@noindent +The following subsections describe the various switches accepted by +@command{gnatpp}, organized by category. + +@ifclear vms +You specify a switch by supplying a name and generally also a value. +In many cases the values for a switch with a given name are incompatible with +each other +(for example the switch that controls the casing of a reserved word may have +exactly one value: upper case, lower case, or +mixed case) and thus exactly one such switch can be in effect for an +invocation of @command{gnatpp}. +If more than one is supplied, the last one is used. +However, some values for the same switch are mutually compatible. +You may supply several such switches to @command{gnatpp}, but then +each must be specified in full, with both the name and the value. +Abbreviated forms (the name appearing once, followed by each value) are +not permitted. +For example, to set +the alignment of the assignment delimiter both in declarations and in +assignment statements, you must write @option{-A2A3} +(or @option{-A2 -A3}), but not @option{-A23}. +@end ifclear + +@ifset vms +In many cases the set of options for a given qualifier are incompatible with +each other (for example the qualifier that controls the casing of a reserved +word may have exactly one option, which specifies either upper case, lower +case, or mixed case), and thus exactly one such option can be in effect for +an invocation of @command{gnatpp}. +If more than one is supplied, the last one is used. +However, some qualifiers have options that are mutually compatible, +and then you may then supply several such options when invoking +@command{gnatpp}. +@end ifset + +In most cases, it is obvious whether or not the +^values for a switch with a given name^options for a given qualifier^ +are compatible with each other. +When the semantics might not be evident, the summaries below explicitly +indicate the effect. + +@menu +* Alignment Control:: +* Casing Control:: +* Construct Layout Control:: +* General Text Layout Control:: +* Other Formatting Options:: +* Setting the Source Search Path:: +* Output File Control:: +* Other gnatpp Switches:: +@end menu + +@node Alignment Control +@subsection Alignment Control +@cindex Alignment control in @command{gnatpp} + +@noindent +Programs can be easier to read if certain constructs are vertically aligned. +By default all alignments are set ON. +Through the @option{^-A0^/ALIGN=OFF^} switch you may reset the default to +OFF, and then use one or more of the other +^@option{-A@var{n}} switches^@option{/ALIGN} options^ +to activate alignment for specific constructs. + +@table @option +@cindex @option{^-A@var{n}^/ALIGN^} (@command{gnatpp}) + +@ifset vms +@item /ALIGN=ON +Set all alignments to ON +@end ifset + +@item ^-A0^/ALIGN=OFF^ +Set all alignments to OFF + +@item ^-A1^/ALIGN=COLONS^ +Align @code{:} in declarations + +@item ^-A2^/ALIGN=DECLARATIONS^ +Align @code{:=} in initializations in declarations + +@item ^-A3^/ALIGN=STATEMENTS^ +Align @code{:=} in assignment statements + +@item ^-A4^/ALIGN=ARROWS^ +Align @code{=>} in associations + +@item ^-A5^/ALIGN=COMPONENT_CLAUSES^ +Align @code{at} keywords in the component clauses in record +representation clauses +@end table + +@noindent +The @option{^-A^/ALIGN^} switches are mutually compatible; any combination +is allowed. + +@node Casing Control +@subsection Casing Control +@cindex Casing control in @command{gnatpp} + +@noindent +@command{gnatpp} allows you to specify the casing for reserved words, +pragma names, attribute designators and identifiers. +For identifiers you may define a +general rule for name casing but also override this rule +via a set of dictionary files. + +Three types of casing are supported: lower case, upper case, and mixed case. +Lower and upper case are self-explanatory (but since some letters in +Latin1 and other GNAT-supported character sets +exist only in lower-case form, an upper case conversion will have no +effect on them.) +``Mixed case'' means that the first letter, and also each letter immediately +following an underscore, are converted to their uppercase forms; +all the other letters are converted to their lowercase forms. + +@table @option +@cindex @option{^-a@var{x}^/ATTRIBUTE^} (@command{gnatpp}) +@item ^-aL^/ATTRIBUTE_CASING=LOWER_CASE^ +Attribute designators are lower case + +@item ^-aU^/ATTRIBUTE_CASING=UPPER_CASE^ +Attribute designators are upper case + +@item ^-aM^/ATTRIBUTE_CASING=MIXED_CASE^ +Attribute designators are mixed case (this is the default) + +@cindex @option{^-k@var{x}^/KEYWORD_CASING^} (@command{gnatpp}) +@item ^-kL^/KEYWORD_CASING=LOWER_CASE^ +Keywords (technically, these are known in Ada as @emph{reserved words}) are +lower case (this is the default) + +@item ^-kU^/KEYWORD_CASING=UPPER_CASE^ +Keywords are upper case + +@cindex @option{^-n@var{x}^/NAME_CASING^} (@command{gnatpp}) +@item ^-nD^/NAME_CASING=AS_DECLARED^ +Name casing for defining occurrences are as they appear in the source file +(this is the default) + +@item ^-nU^/NAME_CASING=UPPER_CASE^ +Names are in upper case + +@item ^-nL^/NAME_CASING=LOWER_CASE^ +Names are in lower case + +@item ^-nM^/NAME_CASING=MIXED_CASE^ +Names are in mixed case + +@cindex @option{^-p@var{x}^/PRAGMA_CASING^} (@command{gnatpp}) +@item ^-pL^/PRAGMA_CASING=LOWER_CASE^ +Pragma names are lower case + +@item ^-pU^/PRAGMA_CASING=UPPER_CASE^ +Pragma names are upper case + +@item ^-pM^/PRAGMA_CASING=MIXED_CASE^ +Pragma names are mixed case (this is the default) + +@item ^-D@var{file}^/DICTIONARY=@var{file}^ +@cindex @option{^-D^/DICTIONARY^} (@command{gnatpp}) +Use @var{file} as a @emph{dictionary file} that defines +the casing for a set of specified names, +thereby overriding the effect on these names by +any explicit or implicit +^-n^/NAME_CASING^ switch. +To supply more than one dictionary file, +use ^several @option{-D} switches^a list of files as options^. + +@noindent +@option{gnatpp} implicitly uses a @emph{default dictionary file} +to define the casing for the Ada predefined names and +the names declared in the GNAT libraries. + +@item ^-D-^/SPECIFIC_CASING^ +@cindex @option{^-D-^/SPECIFIC_CASING^} (@command{gnatpp}) +Do not use the default dictionary file; +instead, use the casing +defined by a @option{^-n^/NAME_CASING^} switch and any explicit +dictionary file(s) +@end table + +@noindent +The structure of a dictionary file, and details on the conventions +used in the default dictionary file, are defined in @ref{Name Casing}. + +The @option{^-D-^/SPECIFIC_CASING^} and +@option{^-D@var{file}^/DICTIONARY=@var{file}^} switches are mutually +compatible. + +@node Construct Layout Control +@subsection Construct Layout Control +@cindex Layout control in @command{gnatpp} + +@noindent +This group of @command{gnatpp} switches controls the layout of comments and +complex syntactic constructs. See @ref{Formatting Comments} for details +on their effect. + +@table @option +@cindex @option{^-c@var{n}^/COMMENTS_LAYOUT^} (@command{gnatpp}) +@item ^-c0^/COMMENTS_LAYOUT=UNTOUCHED^ +All the comments remain unchanged + +@item ^-c1^/COMMENTS_LAYOUT=DEFAULT^ +GNAT-style comment line indentation (this is the default). + +@item ^-c2^/COMMENTS_LAYOUT=STANDARD_INDENT^ +Reference-manual comment line indentation. + +@item ^-c3^/COMMENTS_LAYOUT=GNAT_BEGINNING^ +GNAT-style comment beginning + +@item ^-c4^/COMMENTS_LAYOUT=REFORMAT^ +Reformat comment blocks + +@item ^-c5^/COMMENTS_LAYOUT=KEEP_SPECIAL^ +Keep unchanged special form comments + +Reformat comment blocks + +@cindex @option{^-l@var{n}^/CONSTRUCT_LAYOUT^} (@command{gnatpp}) +@item ^-l1^/CONSTRUCT_LAYOUT=GNAT^ +GNAT-style layout (this is the default) + +@item ^-l2^/CONSTRUCT_LAYOUT=COMPACT^ +Compact layout + +@item ^-l3^/CONSTRUCT_LAYOUT=UNCOMPACT^ +Uncompact layout + +@cindex @option{^-N^/NOTABS^} (@command{gnatpp}) +@item ^-N^/NOTABS^ +All the VT characters are removed from the comment text. All the HT characters +are expanded with the sequences of space characters to get to the next tab +stops. + +@cindex @option{^--no-separate-is^/NO_SEPARATE_IS^} (@command{gnatpp}) +@item ^--no-separate-is^/NO_SEPARATE_IS^ +Do not place the keyword @code{is} on a separate line in a subprogram body in +case if the spec occupies more then one line. + +@cindex @option{^--separate-label^/SEPARATE_LABEL^} (@command{gnatpp}) +@item ^--separate-label^/SEPARATE_LABEL^ +Place statement label(s) on a separate line, with the following statement +on the next line. + +@cindex @option{^--separate-loop-then^/SEPARATE_LOOP_THEN^} (@command{gnatpp}) +@item ^--separate-loop-then^/SEPARATE_LOOP_THEN^ +Place the keyword @code{loop} in FOR and WHILE loop statements and the +keyword @code{then} in IF statements on a separate line. + +@cindex @option{^--no-separate-loop-then^/NO_SEPARATE_LOOP_THEN^} (@command{gnatpp}) +@item ^--no-separate-loop-then^/NO_SEPARATE_LOOP_THEN^ +Do not place the keyword @code{loop} in FOR and WHILE loop statements and the +keyword @code{then} in IF statements on a separate line. This option is +incompatible with @option{^--separate-loop-then^/SEPARATE_LOOP_THEN^} option. + +@cindex @option{^--use-on-new-line^/USE_ON_NEW_LINE^} (@command{gnatpp}) +@item ^--use-on-new-line^/USE_ON_NEW_LINE^ +Start each USE clause in a context clause from a separate line. + +@cindex @option{^--separate-stmt-name^/STMT_NAME_ON_NEW_LINE^} (@command{gnatpp}) +@item ^--separate-stmt-name^/STMT_NAME_ON_NEW_LINE^ +Use a separate line for a loop or block statement name, but do not use an extra +indentation level for the statement itself. + +@end table + +@ifclear vms +@noindent +The @option{-c1} and @option{-c2} switches are incompatible. +The @option{-c3} and @option{-c4} switches are compatible with each other and +also with @option{-c1} and @option{-c2}. The @option{-c0} switch disables all +the other comment formatting switches. + +The @option{-l1}, @option{-l2}, and @option{-l3} switches are incompatible. +@end ifclear + +@ifset vms +@noindent +For the @option{/COMMENTS_LAYOUT} qualifier: +@itemize @bullet +@item +The @option{DEFAULT} and @option{STANDARD_INDENT} options are incompatible. +@item +The @option{GNAT_BEGINNING} and @option{REFORMAT} options are compatible with +each other and also with @option{DEFAULT} and @option{STANDARD_INDENT}. +@end itemize + +@noindent +The @option{GNAT}, @option{COMPACT}, and @option{UNCOMPACT} options for the +@option{/CONSTRUCT_LAYOUT} qualifier are incompatible. +@end ifset + +@node General Text Layout Control +@subsection General Text Layout Control + +@noindent +These switches allow control over line length and indentation. + +@table @option +@item ^-M@var{nnn}^/LINE_LENGTH_MAX=@var{nnn}^ +@cindex @option{^-M^/LINE_LENGTH^} (@command{gnatpp}) +Maximum line length, @var{nnn} from 32@dots{}256, the default value is 79 + +@item ^-i@var{nnn}^/INDENTATION_LEVEL=@var{nnn}^ +@cindex @option{^-i^/INDENTATION_LEVEL^} (@command{gnatpp}) +Indentation level, @var{nnn} from 1@dots{}9, the default value is 3 + +@item ^-cl@var{nnn}^/CONTINUATION_INDENT=@var{nnn}^ +@cindex @option{^-cl^/CONTINUATION_INDENT^} (@command{gnatpp}) +Indentation level for continuation lines (relative to the line being +continued), @var{nnn} from 1@dots{}9. +The default +value is one less then the (normal) indentation level, unless the +indentation is set to 1 (in which case the default value for continuation +line indentation is also 1) +@end table + +@node Other Formatting Options +@subsection Other Formatting Options + +@noindent +These switches control the inclusion of missing end/exit labels, and +the indentation level in @b{case} statements. + +@table @option +@item ^-e^/NO_MISSED_LABELS^ +@cindex @option{^-e^/NO_MISSED_LABELS^} (@command{gnatpp}) +Do not insert missing end/exit labels. An end label is the name of +a construct that may optionally be repeated at the end of the +construct's declaration; +e.g., the names of packages, subprograms, and tasks. +An exit label is the name of a loop that may appear as target +of an exit statement within the loop. +By default, @command{gnatpp} inserts these end/exit labels when +they are absent from the original source. This option suppresses such +insertion, so that the formatted source reflects the original. + +@item ^-ff^/FORM_FEED_AFTER_PRAGMA_PAGE^ +@cindex @option{^-ff^/FORM_FEED_AFTER_PRAGMA_PAGE^} (@command{gnatpp}) +Insert a Form Feed character after a pragma Page. + +@item ^-T@var{nnn}^/MAX_INDENT=@var{nnn}^ +@cindex @option{^-T^/MAX_INDENT^} (@command{gnatpp}) +Do not use an additional indentation level for @b{case} alternatives +and variants if there are @var{nnn} or more (the default +value is 10). +If @var{nnn} is 0, an additional indentation level is +used for @b{case} alternatives and variants regardless of their number. +@end table + +@node Setting the Source Search Path +@subsection Setting the Source Search Path + +@noindent +To define the search path for the input source file, @command{gnatpp} +uses the same switches as the GNAT compiler, with the same effects. + +@table @option +@item ^-I^/SEARCH=^@var{dir} +@cindex @option{^-I^/SEARCH^} (@code{gnatpp}) +The same as the corresponding gcc switch + +@item ^-I-^/NOCURRENT_DIRECTORY^ +@cindex @option{^-I-^/NOCURRENT_DIRECTORY^} (@code{gnatpp}) +The same as the corresponding gcc switch + +@item ^-gnatec^/CONFIGURATION_PRAGMAS_FILE^=@var{path} +@cindex @option{^-gnatec^/CONFIGURATION_PRAGMAS_FILE^} (@code{gnatpp}) +The same as the corresponding gcc switch + +@item ^--RTS^/RUNTIME_SYSTEM^=@var{path} +@cindex @option{^--RTS^/RUNTIME_SYSTEM^} (@code{gnatpp}) +The same as the corresponding gcc switch + +@end table + +@node Output File Control +@subsection Output File Control + +@noindent +By default the output is sent to the file whose name is obtained by appending +the ^@file{.pp}^@file{$PP}^ suffix to the name of the input file +(if the file with this name already exists, it is unconditionally overwritten). +Thus if the input file is @file{^my_ada_proc.adb^MY_ADA_PROC.ADB^} then +@command{gnatpp} will produce @file{^my_ada_proc.adb.pp^MY_ADA_PROC.ADB$PP^} +as output file. +The output may be redirected by the following switches: + +@table @option +@item ^-pipe^/STANDARD_OUTPUT^ +@cindex @option{^-pipe^/STANDARD_OUTPUT^} (@code{gnatpp}) +Send the output to @code{Standard_Output} + +@item ^-o @var{output_file}^/OUTPUT=@var{output_file}^ +@cindex @option{^-o^/OUTPUT^} (@code{gnatpp}) +Write the output into @var{output_file}. +If @var{output_file} already exists, @command{gnatpp} terminates without +reading or processing the input file. + +@item ^-of ^/FORCED_OUTPUT=^@var{output_file} +@cindex @option{^-of^/FORCED_OUTPUT^} (@code{gnatpp}) +Write the output into @var{output_file}, overwriting the existing file +(if one is present). + +@item ^-r^/REPLACE^ +@cindex @option{^-r^/REPLACE^} (@code{gnatpp}) +Replace the input source file with the reformatted output, and copy the +original input source into the file whose name is obtained by appending the +^@file{.npp}^@file{$NPP}^ suffix to the name of the input file. +If a file with this name already exists, @command{gnatpp} terminates without +reading or processing the input file. + +@item ^-rf^/OVERRIDING_REPLACE^ +@cindex @option{^-rf^/OVERRIDING_REPLACE^} (@code{gnatpp}) +Like @option{^-r^/REPLACE^} except that if the file with the specified name +already exists, it is overwritten. + +@item ^-rnb^/REPLACE_NO_BACKUP^ +@cindex @option{^-rnb^/REPLACE_NO_BACKUP^} (@code{gnatpp}) +Replace the input source file with the reformatted output without +creating any backup copy of the input source. + +@item ^--eol=@var{xxx}^/END_OF_LINE=@var{xxx}^ +@cindex @option{^--eol^/END_OF_LINE^} (@code{gnatpp}) +Specifies the format of the reformatted output file. The @var{xxx} +^string specified with the switch^option^ may be either +@itemize @bullet +@item ``@option{^dos^DOS^}'' MS DOS style, lines end with CR LF characters +@item ``@option{^crlf^CRLF^}'' +the same as @option{^crlf^CRLF^} +@item ``@option{^unix^UNIX^}'' UNIX style, lines end with LF character +@item ``@option{^lf^LF^}'' +the same as @option{^unix^UNIX^} +@end itemize + +@item ^-W^/RESULT_ENCODING=^@var{e} +@cindex @option{^-W^/RESULT_ENCODING=^} (@command{gnatpp}) +Specify the wide character encoding method used to write the code in the +result file +@var{e} is one of the following: + +@itemize @bullet + +@item ^h^HEX^ +Hex encoding + +@item ^u^UPPER^ +Upper half encoding + +@item ^s^SHIFT_JIS^ +Shift/JIS encoding + +@item ^e^EUC^ +EUC encoding + +@item ^8^UTF8^ +UTF-8 encoding + +@item ^b^BRACKETS^ +Brackets encoding (default value) +@end itemize + +@end table + +@noindent +Options @option{^-pipe^/STANDARD_OUTPUT^}, +@option{^-o^/OUTPUT^} and +@option{^-of^/FORCED_OUTPUT^} are allowed only if the call to gnatpp +contains only one file to reformat. +Option +@option{^--eol^/END_OF_LINE^} +and +@option{^-W^/RESULT_ENCODING^} +cannot be used together +with @option{^-pipe^/STANDARD_OUTPUT^} option. + +@node Other gnatpp Switches +@subsection Other @code{gnatpp} Switches + +@noindent +The additional @command{gnatpp} switches are defined in this subsection. + +@table @option +@item ^-files @var{filename}^/FILES=@var{filename}^ +@cindex @option{^-files^/FILES^} (@code{gnatpp}) +Take the argument source files from the specified file. This file should be an +ordinary text file containing file names separated by spaces or +line breaks. You can use this switch more than once in the same call to +@command{gnatpp}. You also can combine this switch with an explicit list of +files. + +@item ^-v^/VERBOSE^ +@cindex @option{^-v^/VERBOSE^} (@code{gnatpp}) +Verbose mode; +@command{gnatpp} generates version information and then +a trace of the actions it takes to produce or obtain the ASIS tree. + +@item ^-w^/WARNINGS^ +@cindex @option{^-w^/WARNINGS^} (@code{gnatpp}) +Warning mode; +@command{gnatpp} generates a warning whenever it cannot provide +a required layout in the result source. +@end table + +@node Formatting Rules +@section Formatting Rules + +@noindent +The following subsections show how @command{gnatpp} treats ``white space'', +comments, program layout, and name casing. +They provide the detailed descriptions of the switches shown above. + +@menu +* White Space and Empty Lines:: +* Formatting Comments:: +* Construct Layout:: +* Name Casing:: +@end menu + +@node White Space and Empty Lines +@subsection White Space and Empty Lines + +@noindent +@command{gnatpp} does not have an option to control space characters. +It will add or remove spaces according to the style illustrated by the +examples in the @cite{Ada Reference Manual}. + +The only format effectors +(see @cite{Ada Reference Manual}, paragraph 2.1(13)) +that will appear in the output file are platform-specific line breaks, +and also format effectors within (but not at the end of) comments. +In particular, each horizontal tab character that is not inside +a comment will be treated as a space and thus will appear in the +output file as zero or more spaces depending on +the reformatting of the line in which it appears. +The only exception is a Form Feed character, which is inserted after a +pragma @code{Page} when @option{-ff} is set. + +The output file will contain no lines with trailing ``white space'' (spaces, +format effectors). + +Empty lines in the original source are preserved +only if they separate declarations or statements. +In such contexts, a +sequence of two or more empty lines is replaced by exactly one empty line. +Note that a blank line will be removed if it separates two ``comment blocks'' +(a comment block is a sequence of whole-line comments). +In order to preserve a visual separation between comment blocks, use an +``empty comment'' (a line comprising only hyphens) rather than an empty line. +Likewise, if for some reason you wish to have a sequence of empty lines, +use a sequence of empty comments instead. + +@node Formatting Comments +@subsection Formatting Comments + +@noindent +Comments in Ada code are of two kinds: +@itemize @bullet +@item +a @emph{whole-line comment}, which appears by itself (possibly preceded by +``white space'') on a line + +@item +an @emph{end-of-line comment}, which follows some other Ada lexical element +on the same line. +@end itemize + +@noindent +The indentation of a whole-line comment is that of either +the preceding or following line in +the formatted source, depending on switch settings as will be described below. + +For an end-of-line comment, @command{gnatpp} leaves the same number of spaces +between the end of the preceding Ada lexical element and the beginning +of the comment as appear in the original source, +unless either the comment has to be split to +satisfy the line length limitation, or else the next line contains a +whole line comment that is considered a continuation of this end-of-line +comment (because it starts at the same position). +In the latter two +cases, the start of the end-of-line comment is moved right to the nearest +multiple of the indentation level. +This may result in a ``line overflow'' (the right-shifted comment extending +beyond the maximum line length), in which case the comment is split as +described below. + +There is a difference between @option{^-c1^/COMMENTS_LAYOUT=DEFAULT^} +(GNAT-style comment line indentation) +and @option{^-c2^/COMMENTS_LAYOUT=STANDARD_INDENT^} +(reference-manual comment line indentation). +With reference-manual style, a whole-line comment is indented as if it +were a declaration or statement at the same place +(i.e., according to the indentation of the preceding line(s)). +With GNAT style, a whole-line comment that is immediately followed by an +@b{if} or @b{case} statement alternative, a record variant, or the reserved +word @b{begin}, is indented based on the construct that follows it. + +For example: +@smallexample @c ada +@cartouche +if A then + null; + -- some comment +else + null; +end if; +@end cartouche +@end smallexample + +@noindent +Reference-manual indentation produces: + +@smallexample @c ada +@cartouche +if A then + null; + -- some comment +else + null; +end if; +@end cartouche +@end smallexample + +@noindent +while GNAT-style indentation produces: + +@smallexample @c ada +@cartouche +if A then + null; +-- some comment +else + null; +end if; +@end cartouche +@end smallexample + +@noindent +The @option{^-c3^/COMMENTS_LAYOUT=GNAT_BEGINNING^} switch +(GNAT style comment beginning) has the following +effect: + +@itemize @bullet +@item +For each whole-line comment that does not end with two hyphens, +@command{gnatpp} inserts spaces if necessary after the starting two hyphens +to ensure that there are at least two spaces between these hyphens and the +first non-blank character of the comment. +@end itemize + +@noindent +For an end-of-line comment, if in the original source the next line is a +whole-line comment that starts at the same position +as the end-of-line comment, +then the whole-line comment (and all whole-line comments +that follow it and that start at the same position) +will start at this position in the output file. + +@noindent +That is, if in the original source we have: + +@smallexample @c ada +@cartouche +begin +A := B + C; -- B must be in the range Low1..High1 + -- C must be in the range Low2..High2 + --B+C will be in the range Low1+Low2..High1+High2 +X := X + 1; +@end cartouche +@end smallexample + +@noindent +Then in the formatted source we get + +@smallexample @c ada +@cartouche +begin + A := B + C; -- B must be in the range Low1..High1 + -- C must be in the range Low2..High2 + -- B+C will be in the range Low1+Low2..High1+High2 + X := X + 1; +@end cartouche +@end smallexample + +@noindent +A comment that exceeds the line length limit will be split. +Unless switch +@option{^-c4^/COMMENTS_LAYOUT=REFORMAT^} (reformat comment blocks) is set and +the line belongs to a reformattable block, splitting the line generates a +@command{gnatpp} warning. +The @option{^-c4^/COMMENTS_LAYOUT=REFORMAT^} switch specifies that whole-line +comments may be reformatted in typical +word processor style (that is, moving words between lines and putting as +many words in a line as possible). + +@noindent +The @option{^-c5^/COMMENTS_LAYOUT=KEEP_SPECIAL^} switch specifies, that comments +that has a special format (that is, a character that is neither a letter nor digit +not white space nor line break immediately following the leading @code{--} of +the comment) should be without any change moved from the argument source +into reformatted source. This switch allows to preserve comments that are used +as a special marks in the code (e.g.@: SPARK annotation). + +@node Construct Layout +@subsection Construct Layout + +@noindent +In several cases the suggested layout in the Ada Reference Manual includes +an extra level of indentation that many programmers prefer to avoid. The +affected cases include: + +@itemize @bullet + +@item Record type declaration (RM 3.8) + +@item Record representation clause (RM 13.5.1) + +@item Loop statement in case if a loop has a statement identifier (RM 5.6) + +@item Block statement in case if a block has a statement identifier (RM 5.6) +@end itemize + +@noindent +In compact mode (when GNAT style layout or compact layout is set), +the pretty printer uses one level of indentation instead +of two. This is achieved in the record definition and record representation +clause cases by putting the @code{record} keyword on the same line as the +start of the declaration or representation clause, and in the block and loop +case by putting the block or loop header on the same line as the statement +identifier. + +@noindent +The difference between GNAT style @option{^-l1^/CONSTRUCT_LAYOUT=GNAT^} +and compact @option{^-l2^/CONSTRUCT_LAYOUT=COMPACT^} +layout on the one hand, and uncompact layout +@option{^-l3^/CONSTRUCT_LAYOUT=UNCOMPACT^} on the other hand, +can be illustrated by the following examples: + +@iftex +@cartouche +@multitable @columnfractions .5 .5 +@item @i{GNAT style, compact layout} @tab @i{Uncompact layout} + +@item +@smallexample @c ada +type q is record + a : integer; + b : integer; +end record; +@end smallexample +@tab +@smallexample @c ada +type q is + record + a : integer; + b : integer; + end record; +@end smallexample + +@item +@smallexample @c ada +for q use record + a at 0 range 0 .. 31; + b at 4 range 0 .. 31; +end record; +@end smallexample +@tab +@smallexample @c ada +for q use + record + a at 0 range 0 .. 31; + b at 4 range 0 .. 31; + end record; +@end smallexample + +@item +@smallexample @c ada +Block : declare + A : Integer := 3; +begin + Proc (A, A); +end Block; +@end smallexample +@tab +@smallexample @c ada +Block : + declare + A : Integer := 3; + begin + Proc (A, A); + end Block; +@end smallexample + +@item +@smallexample @c ada +Clear : for J in 1 .. 10 loop + A (J) := 0; +end loop Clear; +@end smallexample +@tab +@smallexample @c ada +Clear : + for J in 1 .. 10 loop + A (J) := 0; + end loop Clear; +@end smallexample +@end multitable +@end cartouche +@end iftex + +@ifnottex +@smallexample +@cartouche +GNAT style, compact layout Uncompact layout + +type q is record type q is + a : integer; record + b : integer; a : integer; +end record; b : integer; + end record; + +for q use record for q use + a at 0 range 0 .. 31; record + b at 4 range 0 .. 31; a at 0 range 0 .. 31; +end record; b at 4 range 0 .. 31; + end record; + +Block : declare Block : + A : Integer := 3; declare +begin A : Integer := 3; + Proc (A, A); begin +end Block; Proc (A, A); + end Block; + +Clear : for J in 1 .. 10 loop Clear : + A (J) := 0; for J in 1 .. 10 loop +end loop Clear; A (J) := 0; + end loop Clear; +@end cartouche +@end smallexample +@end ifnottex + +@noindent +A further difference between GNAT style layout and compact layout is that +GNAT style layout inserts empty lines as separation for +compound statements, return statements and bodies. + +Note that the layout specified by +@option{^--separate-stmt-name^/STMT_NAME_ON_NEW_LINE^} +for named block and loop statements overrides the layout defined by these +constructs by @option{^-l1^/CONSTRUCT_LAYOUT=GNAT^}, +@option{^-l2^/CONSTRUCT_LAYOUT=COMPACT^} or +@option{^-l3^/CONSTRUCT_LAYOUT=UNCOMPACT^} option. + +@node Name Casing +@subsection Name Casing + +@noindent +@command{gnatpp} always converts the usage occurrence of a (simple) name to +the same casing as the corresponding defining identifier. + +You control the casing for defining occurrences via the +@option{^-n^/NAME_CASING^} switch. +@ifclear vms +With @option{-nD} (``as declared'', which is the default), +@end ifclear +@ifset vms +With @option{/NAME_CASING=AS_DECLARED}, which is the default, +@end ifset +defining occurrences appear exactly as in the source file +where they are declared. +The other ^values for this switch^options for this qualifier^ --- +@option{^-nU^UPPER_CASE^}, +@option{^-nL^LOWER_CASE^}, +@option{^-nM^MIXED_CASE^} --- +result in +^upper, lower, or mixed case, respectively^the corresponding casing^. +If @command{gnatpp} changes the casing of a defining +occurrence, it analogously changes the casing of all the +usage occurrences of this name. + +If the defining occurrence of a name is not in the source compilation unit +currently being processed by @command{gnatpp}, the casing of each reference to +this name is changed according to the value of the @option{^-n^/NAME_CASING^} +switch (subject to the dictionary file mechanism described below). +Thus @command{gnatpp} acts as though the @option{^-n^/NAME_CASING^} switch +had affected the +casing for the defining occurrence of the name. + +Some names may need to be spelled with casing conventions that are not +covered by the upper-, lower-, and mixed-case transformations. +You can arrange correct casing by placing such names in a +@emph{dictionary file}, +and then supplying a @option{^-D^/DICTIONARY^} switch. +The casing of names from dictionary files overrides +any @option{^-n^/NAME_CASING^} switch. + +To handle the casing of Ada predefined names and the names from GNAT libraries, +@command{gnatpp} assumes a default dictionary file. +The name of each predefined entity is spelled with the same casing as is used +for the entity in the @cite{Ada Reference Manual}. +The name of each entity in the GNAT libraries is spelled with the same casing +as is used in the declaration of that entity. + +The @w{@option{^-D-^/SPECIFIC_CASING^}} switch suppresses the use of the +default dictionary file. +Instead, the casing for predefined and GNAT-defined names will be established +by the @option{^-n^/NAME_CASING^} switch or explicit dictionary files. +For example, by default the names @code{Ada.Text_IO} and @code{GNAT.OS_Lib} +will appear as just shown, +even in the presence of a @option{^-nU^/NAME_CASING=UPPER_CASE^} switch. +To ensure that even such names are rendered in uppercase, +additionally supply the @w{@option{^-D-^/SPECIFIC_CASING^}} switch +(or else, less conveniently, place these names in upper case in a dictionary +file). + +A dictionary file is +a plain text file; each line in this file can be either a blank line +(containing only space characters and ASCII.HT characters), an Ada comment +line, or the specification of exactly one @emph{casing schema}. + +A casing schema is a string that has the following syntax: + +@smallexample +@cartouche + @var{casing_schema} ::= @var{identifier} | *@var{simple_identifier}* + + @var{simple_identifier} ::= @var{letter}@{@var{letter_or_digit}@} +@end cartouche +@end smallexample + +@noindent +(See @cite{Ada Reference Manual}, Section 2.3) for the definition of the +@var{identifier} lexical element and the @var{letter_or_digit} category.) + +The casing schema string can be followed by white space and/or an Ada-style +comment; any amount of white space is allowed before the string. + +If a dictionary file is passed as +@ifclear vms +the value of a @option{-D@var{file}} switch +@end ifclear +@ifset vms +an option to the @option{/DICTIONARY} qualifier +@end ifset +then for every +simple name and every identifier, @command{gnatpp} checks if the dictionary +defines the casing for the name or for some of its parts (the term ``subword'' +is used below to denote the part of a name which is delimited by ``_'' or by +the beginning or end of the word and which does not contain any ``_'' inside): + +@itemize @bullet +@item +if the whole name is in the dictionary, @command{gnatpp} uses for this name +the casing defined by the dictionary; no subwords are checked for this word + +@item +for every subword @command{gnatpp} checks if the dictionary contains the +corresponding string of the form @code{*@var{simple_identifier}*}, +and if it does, the casing of this @var{simple_identifier} is used +for this subword + +@item +if the whole name does not contain any ``_'' inside, and if for this name +the dictionary contains two entries - one of the form @var{identifier}, +and another - of the form *@var{simple_identifier}*, then the first one +is applied to define the casing of this name + +@item +if more than one dictionary file is passed as @command{gnatpp} switches, each +dictionary adds new casing exceptions and overrides all the existing casing +exceptions set by the previous dictionaries + +@item +when @command{gnatpp} checks if the word or subword is in the dictionary, +this check is not case sensitive +@end itemize + +@noindent +For example, suppose we have the following source to reformat: + +@smallexample @c ada +@cartouche +procedure test is + name1 : integer := 1; + name4_name3_name2 : integer := 2; + name2_name3_name4 : Boolean; + name1_var : Float; +begin + name2_name3_name4 := name4_name3_name2 > name1; +end; +@end cartouche +@end smallexample + +@noindent +And suppose we have two dictionaries: + +@smallexample +@cartouche +@i{dict1:} + NAME1 + *NaMe3* + *Name1* +@end cartouche + +@cartouche +@i{dict2:} + *NAME3* +@end cartouche +@end smallexample + +@noindent +If @command{gnatpp} is called with the following switches: + +@smallexample +@ifclear vms +@command{gnatpp -nM -D dict1 -D dict2 test.adb} +@end ifclear +@ifset vms +@command{gnatpp test.adb /NAME_CASING=MIXED_CASE /DICTIONARY=(dict1, dict2)} +@end ifset +@end smallexample + +@noindent +then we will get the following name casing in the @command{gnatpp} output: + +@smallexample @c ada +@cartouche +procedure Test is + NAME1 : Integer := 1; + Name4_NAME3_Name2 : Integer := 2; + Name2_NAME3_Name4 : Boolean; + Name1_Var : Float; +begin + Name2_NAME3_Name4 := Name4_NAME3_Name2 > NAME1; +end Test; +@end cartouche +@end smallexample + +@c ********************************* +@node The GNAT Metric Tool gnatmetric +@chapter The GNAT Metric Tool @command{gnatmetric} +@findex gnatmetric +@cindex Metric tool + +@noindent +^The @command{gnatmetric} tool^@command{GNAT METRIC}^ is an ASIS-based utility +for computing various program metrics. +It takes an Ada source file as input and generates a file containing the +metrics data as output. Various switches control which +metrics are computed and output. + +@command{gnatmetric} generates and uses the ASIS +tree for the input source and thus requires the input to be syntactically and +semantically legal. +If this condition is not met, @command{gnatmetric} will generate +an error message; no metric information for this file will be +computed and reported. + +If the compilation unit contained in the input source depends semantically +upon units in files located outside the current directory, you have to provide +the source search path when invoking @command{gnatmetric}. +If it depends semantically upon units that are contained +in files with names that do not follow the GNAT file naming rules, you have to +provide the configuration file describing the corresponding naming scheme (see +the description of the @command{gnatmetric} switches below.) +Alternatively, you may use a project file and invoke @command{gnatmetric} +through the @command{gnat} driver. + +The @command{gnatmetric} command has the form + +@smallexample +@c $ gnatmetric @ovar{switches} @{@var{filename}@} @r{[}-cargs @var{gcc_switches}@r{]} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatmetric @r{[}@var{switches}@r{]} @{@var{filename}@} @r{[}-cargs @var{gcc_switches}@r{]} +@end smallexample + +@noindent +where +@itemize @bullet +@item +@var{switches} specify the metrics to compute and define the destination for +the output + +@item +Each @var{filename} is the name (including the extension) of a source +file to process. ``Wildcards'' are allowed, and +the file name may contain path information. +If no @var{filename} is supplied, then the @var{switches} list must contain +at least one +@option{-files} switch (@pxref{Other gnatmetric Switches}). +Including both a @option{-files} switch and one or more +@var{filename} arguments is permitted. + +@item +@samp{@var{gcc_switches}} is a list of switches for +@command{gcc}. They will be passed on to all compiler invocations made by +@command{gnatmetric} to generate the ASIS trees. Here you can provide +@option{^-I^/INCLUDE_DIRS=^} switches to form the source search path, +and use the @option{-gnatec} switch to set the configuration file, +use the @option{-gnat05} switch if sources should be compiled in +Ada 2005 mode etc. +@end itemize + +@menu +* Switches for gnatmetric:: +@end menu + +@node Switches for gnatmetric +@section Switches for @command{gnatmetric} + +@noindent +The following subsections describe the various switches accepted by +@command{gnatmetric}, organized by category. + +@menu +* Output Files Control:: +* Disable Metrics For Local Units:: +* Specifying a set of metrics to compute:: +* Other gnatmetric Switches:: +* Generate project-wide metrics:: +@end menu + +@node Output Files Control +@subsection Output File Control +@cindex Output file control in @command{gnatmetric} + +@noindent +@command{gnatmetric} has two output formats. It can generate a +textual (human-readable) form, and also XML. By default only textual +output is generated. + +When generating the output in textual form, @command{gnatmetric} creates +for each Ada source file a corresponding text file +containing the computed metrics, except for the case when the set of metrics +specified by gnatmetric parameters consists only of metrics that are computed +for the whole set of analyzed sources, but not for each Ada source. +By default, this file is placed in the same directory as where the source +file is located, and its name is obtained +by appending the ^@file{.metrix}^@file{$METRIX}^ suffix to the name of the +input file. + +All the output information generated in XML format is placed in a single +file. By default this file is placed in the current directory and has the +name ^@file{metrix.xml}^@file{METRIX$XML}^. + +Some of the computed metrics are summed over the units passed to +@command{gnatmetric}; for example, the total number of lines of code. +By default this information is sent to @file{stdout}, but a file +can be specified with the @option{-og} switch. + +The following switches control the @command{gnatmetric} output: + +@table @option +@cindex @option{^-x^/XML^} (@command{gnatmetric}) +@item ^-x^/XML^ +Generate the XML output + +@cindex @option{^-xs^/XSD^} (@command{gnatmetric}) +@item ^-xs^/XSD^ +Generate the XML output and the XML schema file that describes the structure +of the XML metric report, this schema is assigned to the XML file. The schema +file has the same name as the XML output file with @file{.xml} suffix replaced +with @file{.xsd} + +@cindex @option{^-nt^/NO_TEXT^} (@command{gnatmetric}) +@item ^-nt^/NO_TEXT^ +Do not generate the output in text form (implies @option{^-x^/XML^}) + +@cindex @option{^-d^/DIRECTORY^} (@command{gnatmetric}) +@item ^-d @var{output_dir}^/DIRECTORY=@var{output_dir}^ +Put text files with detailed metrics into @var{output_dir} + +@cindex @option{^-o^/SUFFIX_DETAILS^} (@command{gnatmetric}) +@item ^-o @var{file_suffix}^/SUFFIX_DETAILS=@var{file_suffix}^ +Use @var{file_suffix}, instead of ^@file{.metrix}^@file{$METRIX}^ +in the name of the output file. + +@cindex @option{^-og^/GLOBAL_OUTPUT^} (@command{gnatmetric}) +@item ^-og @var{file_name}^/GLOBAL_OUTPUT=@var{file_name}^ +Put global metrics into @var{file_name} + +@cindex @option{^-ox^/XML_OUTPUT^} (@command{gnatmetric}) +@item ^-ox @var{file_name}^/XML_OUTPUT=@var{file_name}^ +Put the XML output into @var{file_name} (also implies @option{^-x^/XML^}) + +@cindex @option{^-sfn^/SHORT_SOURCE_FILE_NAME^} (@command{gnatmetric}) +@item ^-sfn^/SHORT_SOURCE_FILE_NAME^ +Use ``short'' source file names in the output. (The @command{gnatmetric} +output includes the name(s) of the Ada source file(s) from which the metrics +are computed. By default each name includes the absolute path. The +@option{^-sfn^/SHORT_SOURCE_FILE_NAME^} switch causes @command{gnatmetric} +to exclude all directory information from the file names that are output.) + +@end table + +@node Disable Metrics For Local Units +@subsection Disable Metrics For Local Units +@cindex Disable Metrics For Local Units in @command{gnatmetric} + +@noindent +@command{gnatmetric} relies on the GNAT compilation model @minus{} +one compilation +unit per one source file. It computes line metrics for the whole source +file, and it also computes syntax +and complexity metrics for the file's outermost unit. + +By default, @command{gnatmetric} will also compute all metrics for certain +kinds of locally declared program units: + +@itemize @bullet +@item +subprogram (and generic subprogram) bodies; + +@item +package (and generic package) specs and bodies; + +@item +task object and type specifications and bodies; + +@item +protected object and type specifications and bodies. +@end itemize + +@noindent +These kinds of entities will be referred to as +@emph{eligible local program units}, or simply @emph{eligible local units}, +@cindex Eligible local unit (for @command{gnatmetric}) +in the discussion below. + +Note that a subprogram declaration, generic instantiation, +or renaming declaration only receives metrics +computation when it appear as the outermost entity +in a source file. + +Suppression of metrics computation for eligible local units can be +obtained via the following switch: + +@table @option +@cindex @option{^-n@var{x}^/SUPPRESS^} (@command{gnatmetric}) +@item ^-nolocal^/SUPPRESS=LOCAL_DETAILS^ +Do not compute detailed metrics for eligible local program units + +@end table + +@node Specifying a set of metrics to compute +@subsection Specifying a set of metrics to compute + +@noindent +By default all the metrics are computed and reported. The switches +described in this subsection allow you to control, on an individual +basis, whether metrics are computed and +reported. If at least one positive metric +switch is specified (that is, a switch that defines that a given +metric or set of metrics is to be computed), then only +explicitly specified metrics are reported. + +@menu +* Line Metrics Control:: +* Syntax Metrics Control:: +* Complexity Metrics Control:: +* Object-Oriented Metrics Control:: +@end menu + +@node Line Metrics Control +@subsubsection Line Metrics Control +@cindex Line metrics control in @command{gnatmetric} + +@noindent +For any (legal) source file, and for each of its +eligible local program units, @command{gnatmetric} computes the following +metrics: + +@itemize @bullet +@item +the total number of lines; + +@item +the total number of code lines (i.e., non-blank lines that are not comments) + +@item +the number of comment lines + +@item +the number of code lines containing end-of-line comments; + +@item +the comment percentage: the ratio between the number of lines that contain +comments and the number of all non-blank lines, expressed as a percentage; + +@item +the number of empty lines and lines containing only space characters and/or +format effectors (blank lines) + +@item +the average number of code lines in subprogram bodies, task bodies, entry +bodies and statement sequences in package bodies (this metric is only computed +across the whole set of the analyzed units) + +@end itemize + +@noindent +@command{gnatmetric} sums the values of the line metrics for all the +files being processed and then generates the cumulative results. The tool +also computes for all the files being processed the average number of code +lines in bodies. + +You can use the following switches to select the specific line metrics +to be computed and reported. + +@table @option +@cindex @option{^--lines@var{x}^/LINE_COUNT_METRICS^} (@command{gnatmetric}) + +@ifclear vms +@cindex @option{--no-lines@var{x}} +@end ifclear + +@item ^--lines-all^/LINE_COUNT_METRICS=ALL^ +Report all the line metrics + +@item ^--no-lines-all^/LINE_COUNT_METRICS=NONE^ +Do not report any of line metrics + +@item ^--lines^/LINE_COUNT_METRICS=ALL_LINES^ +Report the number of all lines + +@item ^--no-lines^/LINE_COUNT_METRICS=NOALL_LINES^ +Do not report the number of all lines + +@item ^--lines-code^/LINE_COUNT_METRICS=CODE_LINES^ +Report the number of code lines + +@item ^--no-lines-code^/LINE_COUNT_METRICS=NOCODE_LINES^ +Do not report the number of code lines + +@item ^--lines-comment^/LINE_COUNT_METRICS=COMMENT_LINES^ +Report the number of comment lines + +@item ^--no-lines-comment^/LINE_COUNT_METRICS=NOCOMMENT_LINES^ +Do not report the number of comment lines + +@item ^--lines-eol-comment^/LINE_COUNT_METRICS=CODE_COMMENT_LINES^ +Report the number of code lines containing +end-of-line comments + +@item ^--no-lines-eol-comment^/LINE_COUNT_METRICS=NOCODE_COMMENT_LINES^ +Do not report the number of code lines containing +end-of-line comments + +@item ^--lines-ratio^/LINE_COUNT_METRICS=COMMENT_PERCENTAGE^ +Report the comment percentage in the program text + +@item ^--no-lines-ratio^/LINE_COUNT_METRICS=NOCOMMENT_PERCENTAGE^ +Do not report the comment percentage in the program text + +@item ^--lines-blank^/LINE_COUNT_METRICS=BLANK_LINES^ +Report the number of blank lines + +@item ^--no-lines-blank^/LINE_COUNT_METRICS=NOBLANK_LINES^ +Do not report the number of blank lines + +@item ^--lines-average^/LINE_COUNT_METRICS=AVERAGE_BODY_LINES^ +Report the average number of code lines in subprogram bodies, task bodies, +entry bodies and statement sequences in package bodies. The metric is computed +and reported for the whole set of processed Ada sources only. + +@item ^--no-lines-average^/LINE_COUNT_METRICS=NOAVERAGE_BODY_LINES^ +Do not report the average number of code lines in subprogram bodies, +task bodies, entry bodies and statement sequences in package bodies. + +@end table + +@node Syntax Metrics Control +@subsubsection Syntax Metrics Control +@cindex Syntax metrics control in @command{gnatmetric} + +@noindent +@command{gnatmetric} computes various syntactic metrics for the +outermost unit and for each eligible local unit: + +@table @emph +@item LSLOC (``Logical Source Lines Of Code'') +The total number of declarations and the total number of statements + +@item Maximal static nesting level of inner program units +According to +@cite{Ada Reference Manual}, 10.1(1), ``A program unit is either a +package, a task unit, a protected unit, a +protected entry, a generic unit, or an explicitly declared subprogram other +than an enumeration literal.'' + +@item Maximal nesting level of composite syntactic constructs +This corresponds to the notion of the +maximum nesting level in the GNAT built-in style checks +(@pxref{Style Checking}) +@end table + +@noindent +For the outermost unit in the file, @command{gnatmetric} additionally computes +the following metrics: + +@table @emph +@item Public subprograms +This metric is computed for package specs. It is the +number of subprograms and generic subprograms declared in the visible +part (including the visible part of nested packages, protected objects, and +protected types). + +@item All subprograms +This metric is computed for bodies and subunits. The +metric is equal to a total number of subprogram bodies in the compilation +unit. +Neither generic instantiations nor renamings-as-a-body nor body stubs +are counted. Any subprogram body is counted, independently of its nesting +level and enclosing constructs. Generic bodies and bodies of protected +subprograms are counted in the same way as ``usual'' subprogram bodies. + +@item Public types +This metric is computed for package specs and +generic package declarations. It is the total number of types +that can be referenced from outside this compilation unit, plus the +number of types from all the visible parts of all the visible generic +packages. Generic formal types are not counted. Only types, not subtypes, +are included. + +@noindent +Along with the total number of public types, the following +types are counted and reported separately: + +@itemize @bullet +@item +Abstract types + +@item +Root tagged types (abstract, non-abstract, private, non-private). Type +extensions are @emph{not} counted + +@item +Private types (including private extensions) + +@item +Task types + +@item +Protected types + +@end itemize + +@item All types +This metric is computed for any compilation unit. It is equal to the total +number of the declarations of different types given in the compilation unit. +The private and the corresponding full type declaration are counted as one +type declaration. Incomplete type declarations and generic formal types +are not counted. +No distinction is made among different kinds of types (abstract, +private etc.); the total number of types is computed and reported. + +@end table + +@noindent +By default, all the syntax metrics are computed and reported. You can use the +following switches to select specific syntax metrics. + +@table @option + +@cindex @option{^--syntax@var{x}^/SYNTAX_METRICS^} (@command{gnatmetric}) + +@ifclear vms +@cindex @option{--no-syntax@var{x}} (@command{gnatmetric}) +@end ifclear + +@item ^--syntax-all^/SYNTAX_METRICS=ALL^ +Report all the syntax metrics + +@item ^--no-syntax-all^/SYNTAX_METRICS=NONE^ +Do not report any of syntax metrics + +@item ^--declarations^/SYNTAX_METRICS=DECLARATIONS^ +Report the total number of declarations + +@item ^--no-declarations^/SYNTAX_METRICS=NODECLARATIONS^ +Do not report the total number of declarations + +@item ^--statements^/SYNTAX_METRICS=STATEMENTS^ +Report the total number of statements + +@item ^--no-statements^/SYNTAX_METRICS=NOSTATEMENTS^ +Do not report the total number of statements + +@item ^--public-subprograms^/SYNTAX_METRICS=PUBLIC_SUBPROGRAMS^ +Report the number of public subprograms in a compilation unit + +@item ^--no-public-subprograms^/SYNTAX_METRICS=NOPUBLIC_SUBPROGRAMS^ +Do not report the number of public subprograms in a compilation unit + +@item ^--all-subprograms^/SYNTAX_METRICS=ALL_SUBPROGRAMS^ +Report the number of all the subprograms in a compilation unit + +@item ^--no-all-subprograms^/SYNTAX_METRICS=NOALL_SUBPROGRAMS^ +Do not report the number of all the subprograms in a compilation unit + +@item ^--public-types^/SYNTAX_METRICS=PUBLIC_TYPES^ +Report the number of public types in a compilation unit + +@item ^--no-public-types^/SYNTAX_METRICS=NOPUBLIC_TYPES^ +Do not report the number of public types in a compilation unit + +@item ^--all-types^/SYNTAX_METRICS=ALL_TYPES^ +Report the number of all the types in a compilation unit + +@item ^--no-all-types^/SYNTAX_METRICS=NOALL_TYPES^ +Do not report the number of all the types in a compilation unit + +@item ^--unit-nesting^/SYNTAX_METRICS=UNIT_NESTING^ +Report the maximal program unit nesting level + +@item ^--no-unit-nesting^/SYNTAX_METRICS=UNIT_NESTING_OFF^ +Do not report the maximal program unit nesting level + +@item ^--construct-nesting^/SYNTAX_METRICS=CONSTRUCT_NESTING^ +Report the maximal construct nesting level + +@item ^--no-construct-nesting^/SYNTAX_METRICS=NOCONSTRUCT_NESTING^ +Do not report the maximal construct nesting level + +@end table + +@node Complexity Metrics Control +@subsubsection Complexity Metrics Control +@cindex Complexity metrics control in @command{gnatmetric} + +@noindent +For a program unit that is an executable body (a subprogram body (including +generic bodies), task body, entry body or a package body containing +its own statement sequence) @command{gnatmetric} computes the following +complexity metrics: + +@itemize @bullet +@item +McCabe cyclomatic complexity; + +@item +McCabe essential complexity; + +@item +maximal loop nesting level + +@end itemize + +@noindent +The McCabe complexity metrics are defined +in @url{http://www.mccabe.com/pdf/nist235r.pdf} + +According to McCabe, both control statements and short-circuit control forms +should be taken into account when computing cyclomatic complexity. For each +body, we compute three metric values: + +@itemize @bullet +@item +the complexity introduced by control +statements only, without taking into account short-circuit forms, + +@item +the complexity introduced by short-circuit control forms only, and + +@item +the total +cyclomatic complexity, which is the sum of these two values. +@end itemize + +@noindent +When computing cyclomatic and essential complexity, @command{gnatmetric} skips +the code in the exception handlers and in all the nested program units. + +By default, all the complexity metrics are computed and reported. +For more fine-grained control you can use +the following switches: + +@table @option +@cindex @option{^-complexity@var{x}^/COMPLEXITY_METRICS^} (@command{gnatmetric}) + +@ifclear vms +@cindex @option{--no-complexity@var{x}} +@end ifclear + +@item ^--complexity-all^/COMPLEXITY_METRICS=ALL^ +Report all the complexity metrics + +@item ^--no-complexity-all^/COMPLEXITY_METRICS=NONE^ +Do not report any of complexity metrics + +@item ^--complexity-cyclomatic^/COMPLEXITY_METRICS=CYCLOMATIC^ +Report the McCabe Cyclomatic Complexity + +@item ^--no-complexity-cyclomatic^/COMPLEXITY_METRICS=NOCYCLOMATIC^ +Do not report the McCabe Cyclomatic Complexity + +@item ^--complexity-essential^/COMPLEXITY_METRICS=ESSENTIAL^ +Report the Essential Complexity + +@item ^--no-complexity-essential^/COMPLEXITY_METRICS=NOESSENTIAL^ +Do not report the Essential Complexity + +@item ^--loop-nesting^/COMPLEXITY_METRICS=LOOP_NESTING_ON^ +Report maximal loop nesting level + +@item ^--no-loop-nesting^/COMPLEXITY_METRICS=NOLOOP_NESTING^ +Do not report maximal loop nesting level + +@item ^--complexity-average^/COMPLEXITY_METRICS=AVERAGE_COMPLEXITY^ +Report the average McCabe Cyclomatic Complexity for all the subprogram bodies, +task bodies, entry bodies and statement sequences in package bodies. +The metric is computed and reported for whole set of processed Ada sources +only. + +@item ^--no-complexity-average^/COMPLEXITY_METRICS=NOAVERAGE_COMPLEXITY^ +Do not report the average McCabe Cyclomatic Complexity for all the subprogram +bodies, task bodies, entry bodies and statement sequences in package bodies + +@cindex @option{^-ne^/NO_EXITS_AS_GOTOS^} (@command{gnatmetric}) +@item ^-ne^/NO_EXITS_AS_GOTOS^ +Do not consider @code{exit} statements as @code{goto}s when +computing Essential Complexity + +@item ^--extra-exit-points^/EXTRA_EXIT_POINTS^ +Report the extra exit points for subprogram bodies. As an exit point, this +metric counts @code{return} statements and raise statements in case when the +raised exception is not handled in the same body. In case of a function this +metric subtracts 1 from the number of exit points, because a function body +must contain at least one @code{return} statement. + +@item ^--no-extra-exit-points^/NOEXTRA_EXIT_POINTS^ +Do not report the extra exit points for subprogram bodies +@end table + + +@node Object-Oriented Metrics Control +@subsubsection Object-Oriented Metrics Control +@cindex Object-Oriented metrics control in @command{gnatmetric} + +@noindent +@cindex Coupling metrics (in in @command{gnatmetric}) +Coupling metrics are object-oriented metrics that measure the +dependencies between a given class (or a group of classes) and the +``external world'' (that is, the other classes in the program). In this +subsection the term ``class'' is used in its +traditional object-oriented programming sense +(an instantiable module that contains data and/or method members). +A @emph{category} (of classes) +is a group of closely related classes that are reused and/or +modified together. + +A class @code{K}'s @emph{efferent coupling} is the number of classes +that @code{K} depends upon. +A category's efferent coupling is the number of classes outside the +category that the classes inside the category depend upon. + +A class @code{K}'s @emph{afferent coupling} is the number of classes +that depend upon @code{K}. +A category's afferent coupling is the number of classes outside the +category that depend on classes belonging to the category. + +Ada's implementation of the object-oriented paradigm does not use the +traditional class notion, so the definition of the coupling +metrics for Ada maps the class and class category notions +onto Ada constructs. + +For the coupling metrics, several kinds of modules -- a library package, +a library generic package, and a library generic package instantiation -- +that define a tagged type or an interface type are +considered to be a class. A category consists of a library package (or +a library generic package) that defines a tagged or an interface type, +together with all its descendant (generic) packages that define tagged +or interface types. For any package counted as a class, +its body and subunits (if any) are considered +together with its spec when counting the dependencies, and coupling +metrics are reported for spec units only. For dependencies +between classes, the Ada semantic dependencies are considered. +For coupling metrics, only dependencies on units that are considered as +classes, are considered. + +When computing coupling metrics, @command{gnatmetric} counts only +dependencies between units that are arguments of the gnatmetric call. +Coupling metrics are program-wide (or project-wide) metrics, so to +get a valid result, you should call @command{gnatmetric} for +the whole set of sources that make up your program. It can be done +by calling @command{gnatmetric} from the GNAT driver with @option{-U} +option (see See @ref{The GNAT Driver and Project Files} for details. + +By default, all the coupling metrics are disabled. You can use the following +switches to specify the coupling metrics to be computed and reported: + +@table @option + +@ifclear vms +@cindex @option{--package@var{x}} (@command{gnatmetric}) +@cindex @option{--no-package@var{x}} (@command{gnatmetric}) +@cindex @option{--category@var{x}} (@command{gnatmetric}) +@cindex @option{--no-category@var{x}} (@command{gnatmetric}) +@end ifclear + +@ifset vms +@cindex @option{/COUPLING_METRICS} (@command{gnatmetric}) +@end ifset + +@item ^--coupling-all^/COUPLING_METRICS=ALL^ +Report all the coupling metrics + +@item ^--no-coupling-all^/COUPLING_METRICS=NONE^ +Do not report any of metrics + +@item ^--package-efferent-coupling^/COUPLING_METRICS=PACKAGE_EFFERENT^ +Report package efferent coupling + +@item ^--no-package-efferent-coupling^/COUPLING_METRICS=NOPACKAGE_EFFERENT^ +Do not report package efferent coupling + +@item ^--package-afferent-coupling^/COUPLING_METRICS=PACKAGE_AFFERENT^ +Report package afferent coupling + +@item ^--no-package-afferent-coupling^/COUPLING_METRICS=NOPACKAGE_AFFERENT^ +Do not report package afferent coupling + +@item ^--category-efferent-coupling^/COUPLING_METRICS=CATEGORY_EFFERENT^ +Report category efferent coupling + +@item ^--no-category-efferent-coupling^/COUPLING_METRICS=NOCATEGORY_EFFERENT^ +Do not report category efferent coupling + +@item ^--category-afferent-coupling^/COUPLING_METRICS=CATEGORY_AFFERENT^ +Report category afferent coupling + +@item ^--no-category-afferent-coupling^/COUPLING_METRICS=NOCATEGORY_AFFERENT^ +Do not report category afferent coupling + +@end table + +@node Other gnatmetric Switches +@subsection Other @code{gnatmetric} Switches + +@noindent +Additional @command{gnatmetric} switches are as follows: + +@table @option +@item ^-files @var{filename}^/FILES=@var{filename}^ +@cindex @option{^-files^/FILES^} (@code{gnatmetric}) +Take the argument source files from the specified file. This file should be an +ordinary text file containing file names separated by spaces or +line breaks. You can use this switch more than once in the same call to +@command{gnatmetric}. You also can combine this switch with +an explicit list of files. + +@item ^-v^/VERBOSE^ +@cindex @option{^-v^/VERBOSE^} (@code{gnatmetric}) +Verbose mode; +@command{gnatmetric} generates version information and then +a trace of sources being processed. + +@item ^-q^/QUIET^ +@cindex @option{^-q^/QUIET^} (@code{gnatmetric}) +Quiet mode. +@end table + +@node Generate project-wide metrics +@subsection Generate project-wide metrics + +In order to compute metrics on all units of a given project, you can use +the @command{gnat} driver along with the @option{-P} option: +@smallexample + gnat metric -Pproj +@end smallexample + +@noindent +If the project @code{proj} depends upon other projects, you can compute +the metrics on the project closure using the @option{-U} option: +@smallexample + gnat metric -Pproj -U +@end smallexample + +@noindent +Finally, if not all the units are relevant to a particular main +program in the project closure, you can generate metrics for the set +of units needed to create a given main program (unit closure) using +the @option{-U} option followed by the name of the main unit: +@smallexample + gnat metric -Pproj -U main +@end smallexample + + +@c *********************************** +@node File Name Krunching Using gnatkr +@chapter File Name Krunching Using @code{gnatkr} +@findex gnatkr + +@noindent +This chapter discusses the method used by the compiler to shorten +the default file names chosen for Ada units so that they do not +exceed the maximum length permitted. It also describes the +@code{gnatkr} utility that can be used to determine the result of +applying this shortening. +@menu +* About gnatkr:: +* Using gnatkr:: +* Krunching Method:: +* Examples of gnatkr Usage:: +@end menu + +@node About gnatkr +@section About @code{gnatkr} + +@noindent +The default file naming rule in GNAT +is that the file name must be derived from +the unit name. The exact default rule is as follows: +@itemize @bullet +@item +Take the unit name and replace all dots by hyphens. +@item +If such a replacement occurs in the +second character position of a name, and the first character is +^@samp{a}, @samp{g}, @samp{s}, or @samp{i}, ^@samp{A}, @samp{G}, @samp{S}, or @samp{I},^ +then replace the dot by the character +^@samp{~} (tilde)^@samp{$} (dollar sign)^ +instead of a minus. +@end itemize +The reason for this exception is to avoid clashes +with the standard names for children of System, Ada, Interfaces, +and GNAT, which use the prefixes +^@samp{s-}, @samp{a-}, @samp{i-}, and @samp{g-},^@samp{S-}, @samp{A-}, @samp{I-}, and @samp{G-},^ +respectively. + +The @option{^-gnatk^/FILE_NAME_MAX_LENGTH=^@var{nn}} +switch of the compiler activates a ``krunching'' +circuit that limits file names to nn characters (where nn is a decimal +integer). For example, using OpenVMS, +where the maximum file name length is +39, the value of nn is usually set to 39, but if you want to generate +a set of files that would be usable if ported to a system with some +different maximum file length, then a different value can be specified. +The default value of 39 for OpenVMS need not be specified. + +The @code{gnatkr} utility can be used to determine the krunched name for +a given file, when krunched to a specified maximum length. + +@node Using gnatkr +@section Using @code{gnatkr} + +@noindent +The @code{gnatkr} command has the form + +@ifclear vms +@smallexample +@c $ gnatkr @var{name} @ovar{length} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatkr @var{name} @r{[}@var{length}@r{]} +@end smallexample +@end ifclear + +@ifset vms +@smallexample +$ gnatkr @var{name} /COUNT=nn +@end smallexample +@end ifset + +@noindent +@var{name} is the uncrunched file name, derived from the name of the unit +in the standard manner described in the previous section (i.e., in particular +all dots are replaced by hyphens). The file name may or may not have an +extension (defined as a suffix of the form period followed by arbitrary +characters other than period). If an extension is present then it will +be preserved in the output. For example, when krunching @file{hellofile.ads} +to eight characters, the result will be hellofil.ads. + +Note: for compatibility with previous versions of @code{gnatkr} dots may +appear in the name instead of hyphens, but the last dot will always be +taken as the start of an extension. So if @code{gnatkr} is given an argument +such as @file{Hello.World.adb} it will be treated exactly as if the first +period had been a hyphen, and for example krunching to eight characters +gives the result @file{hellworl.adb}. + +Note that the result is always all lower case (except on OpenVMS where it is +all upper case). Characters of the other case are folded as required. + +@var{length} represents the length of the krunched name. The default +when no argument is given is ^8^39^ characters. A length of zero stands for +unlimited, in other words do not chop except for system files where the +implied crunching length is always eight characters. + +@noindent +The output is the krunched name. The output has an extension only if the +original argument was a file name with an extension. + +@node Krunching Method +@section Krunching Method + +@noindent +The initial file name is determined by the name of the unit that the file +contains. The name is formed by taking the full expanded name of the +unit and replacing the separating dots with hyphens and +using ^lowercase^uppercase^ +for all letters, except that a hyphen in the second character position is +replaced by a ^tilde^dollar sign^ if the first character is +^@samp{a}, @samp{i}, @samp{g}, or @samp{s}^@samp{A}, @samp{I}, @samp{G}, or @samp{S}^. +The extension is @code{.ads} for a +spec and @code{.adb} for a body. +Krunching does not affect the extension, but the file name is shortened to +the specified length by following these rules: + +@itemize @bullet +@item +The name is divided into segments separated by hyphens, tildes or +underscores and all hyphens, tildes, and underscores are +eliminated. If this leaves the name short enough, we are done. + +@item +If the name is too long, the longest segment is located (left-most +if there are two of equal length), and shortened by dropping +its last character. This is repeated until the name is short enough. + +As an example, consider the krunching of @*@file{our-strings-wide_fixed.adb} +to fit the name into 8 characters as required by some operating systems. + +@smallexample +our-strings-wide_fixed 22 +our strings wide fixed 19 +our string wide fixed 18 +our strin wide fixed 17 +our stri wide fixed 16 +our stri wide fixe 15 +our str wide fixe 14 +our str wid fixe 13 +our str wid fix 12 +ou str wid fix 11 +ou st wid fix 10 +ou st wi fix 9 +ou st wi fi 8 +Final file name: oustwifi.adb +@end smallexample + +@item +The file names for all predefined units are always krunched to eight +characters. The krunching of these predefined units uses the following +special prefix replacements: + +@table @file +@item ada- +replaced by @file{^a^A^-} + +@item gnat- +replaced by @file{^g^G^-} + +@item interfaces- +replaced by @file{^i^I^-} + +@item system- +replaced by @file{^s^S^-} +@end table + +These system files have a hyphen in the second character position. That +is why normal user files replace such a character with a +^tilde^dollar sign^, to +avoid confusion with system file names. + +As an example of this special rule, consider +@*@file{ada-strings-wide_fixed.adb}, which gets krunched as follows: + +@smallexample +ada-strings-wide_fixed 22 +a- strings wide fixed 18 +a- string wide fixed 17 +a- strin wide fixed 16 +a- stri wide fixed 15 +a- stri wide fixe 14 +a- str wide fixe 13 +a- str wid fixe 12 +a- str wid fix 11 +a- st wid fix 10 +a- st wi fix 9 +a- st wi fi 8 +Final file name: a-stwifi.adb +@end smallexample +@end itemize + +Of course no file shortening algorithm can guarantee uniqueness over all +possible unit names, and if file name krunching is used then it is your +responsibility to ensure that no name clashes occur. The utility +program @code{gnatkr} is supplied for conveniently determining the +krunched name of a file. + +@node Examples of gnatkr Usage +@section Examples of @code{gnatkr} Usage + +@smallexample +@iftex +@leftskip=0cm +@end iftex +@ifclear vms +$ gnatkr very_long_unit_name.ads --> velounna.ads +$ gnatkr grandparent-parent-child.ads --> grparchi.ads +$ gnatkr Grandparent.Parent.Child.ads --> grparchi.ads +$ gnatkr grandparent-parent-child --> grparchi +@end ifclear +$ gnatkr very_long_unit_name.ads/count=6 --> vlunna.ads +$ gnatkr very_long_unit_name.ads/count=0 --> very_long_unit_name.ads +@end smallexample + +@node Preprocessing Using gnatprep +@chapter Preprocessing Using @code{gnatprep} +@findex gnatprep + +@noindent +This chapter discusses how to use GNAT's @code{gnatprep} utility for simple +preprocessing. +Although designed for use with GNAT, @code{gnatprep} does not depend on any +special GNAT features. +For further discussion of conditional compilation in general, see +@ref{Conditional Compilation}. + +@menu +* Preprocessing Symbols:: +* Using gnatprep:: +* Switches for gnatprep:: +* Form of Definitions File:: +* Form of Input Text for gnatprep:: +@end menu + +@node Preprocessing Symbols +@section Preprocessing Symbols + +@noindent +Preprocessing symbols are defined in definition files and referred to in +sources to be preprocessed. A Preprocessing symbol is an identifier, following +normal Ada (case-insensitive) rules for its syntax, with the restriction that +all characters need to be in the ASCII set (no accented letters). + +@node Using gnatprep +@section Using @code{gnatprep} + +@noindent +To call @code{gnatprep} use + +@smallexample +@c $ gnatprep @ovar{switches} @var{infile} @var{outfile} @ovar{deffile} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatprep @r{[}@var{switches}@r{]} @var{infile} @var{outfile} @r{[}@var{deffile}@r{]} +@end smallexample + +@noindent +where +@table @var +@item switches +is an optional sequence of switches as described in the next section. + +@item infile +is the full name of the input file, which is an Ada source +file containing preprocessor directives. + +@item outfile +is the full name of the output file, which is an Ada source +in standard Ada form. When used with GNAT, this file name will +normally have an ads or adb suffix. + +@item deffile +is the full name of a text file containing definitions of +preprocessing symbols to be referenced by the preprocessor. This argument is +optional, and can be replaced by the use of the @option{-D} switch. + +@end table + +@node Switches for gnatprep +@section Switches for @code{gnatprep} + +@table @option +@c !sort! + +@item ^-b^/BLANK_LINES^ +@cindex @option{^-b^/BLANK_LINES^} (@command{gnatprep}) +Causes both preprocessor lines and the lines deleted by +preprocessing to be replaced by blank lines in the output source file, +preserving line numbers in the output file. + +@item ^-c^/COMMENTS^ +@cindex @option{^-c^/COMMENTS^} (@command{gnatprep}) +Causes both preprocessor lines and the lines deleted +by preprocessing to be retained in the output source as comments marked +with the special string @code{"--! "}. This option will result in line numbers +being preserved in the output file. + +@item ^-C^/REPLACE_IN_COMMENTS^ +@cindex @option{^-C^/REPLACE_IN_COMMENTS^} (@command{gnatprep}) +Causes comments to be scanned. Normally comments are ignored by gnatprep. +If this option is specified, then comments are scanned and any $symbol +substitutions performed as in program text. This is particularly useful +when structured comments are used (e.g., when writing programs in the +SPARK dialect of Ada). Note that this switch is not available when +doing integrated preprocessing (it would be useless in this context +since comments are ignored by the compiler in any case). + +@item ^-Dsymbol=value^/ASSOCIATE="symbol=value"^ +@cindex @option{^-D^/ASSOCIATE^} (@command{gnatprep}) +Defines a new preprocessing symbol, associated with value. If no value is given +on the command line, then symbol is considered to be @code{True}. This switch +can be used in place of a definition file. + +@ifset vms +@item /REMOVE +@cindex @option{/REMOVE} (@command{gnatprep}) +This is the default setting which causes lines deleted by preprocessing +to be entirely removed from the output file. +@end ifset + +@item ^-r^/REFERENCE^ +@cindex @option{^-r^/REFERENCE^} (@command{gnatprep}) +Causes a @code{Source_Reference} pragma to be generated that +references the original input file, so that error messages will use +the file name of this original file. The use of this switch implies +that preprocessor lines are not to be removed from the file, so its +use will force @option{^-b^/BLANK_LINES^} mode if +@option{^-c^/COMMENTS^} +has not been specified explicitly. + +Note that if the file to be preprocessed contains multiple units, then +it will be necessary to @code{gnatchop} the output file from +@code{gnatprep}. If a @code{Source_Reference} pragma is present +in the preprocessed file, it will be respected by +@code{gnatchop ^-r^/REFERENCE^} +so that the final chopped files will correctly refer to the original +input source file for @code{gnatprep}. + +@item ^-s^/SYMBOLS^ +@cindex @option{^-s^/SYMBOLS^} (@command{gnatprep}) +Causes a sorted list of symbol names and values to be +listed on the standard output file. + +@item ^-u^/UNDEFINED^ +@cindex @option{^-u^/UNDEFINED^} (@command{gnatprep}) +Causes undefined symbols to be treated as having the value FALSE in the context +of a preprocessor test. In the absence of this option, an undefined symbol in +a @code{#if} or @code{#elsif} test will be treated as an error. + +@end table + +@ifclear vms +@noindent +Note: if neither @option{-b} nor @option{-c} is present, +then preprocessor lines and +deleted lines are completely removed from the output, unless -r is +specified, in which case -b is assumed. +@end ifclear + +@node Form of Definitions File +@section Form of Definitions File + +@noindent +The definitions file contains lines of the form + +@smallexample +symbol := value +@end smallexample + +@noindent +where symbol is a preprocessing symbol, and value is one of the following: + +@itemize @bullet +@item +Empty, corresponding to a null substitution +@item +A string literal using normal Ada syntax +@item +Any sequence of characters from the set +(letters, digits, period, underline). +@end itemize + +@noindent +Comment lines may also appear in the definitions file, starting with +the usual @code{--}, +and comments may be added to the definitions lines. + +@node Form of Input Text for gnatprep +@section Form of Input Text for @code{gnatprep} + +@noindent +The input text may contain preprocessor conditional inclusion lines, +as well as general symbol substitution sequences. + +The preprocessor conditional inclusion commands have the form + +@smallexample +@group +@cartouche +#if @i{expression} @r{[}then@r{]} + lines +#elsif @i{expression} @r{[}then@r{]} + lines +#elsif @i{expression} @r{[}then@r{]} + lines +@dots{} +#else + lines +#end if; +@end cartouche +@end group +@end smallexample + +@noindent +In this example, @i{expression} is defined by the following grammar: +@smallexample +@i{expression} ::= +@i{expression} ::= = "" +@i{expression} ::= = +@i{expression} ::= 'Defined +@i{expression} ::= not @i{expression} +@i{expression} ::= @i{expression} and @i{expression} +@i{expression} ::= @i{expression} or @i{expression} +@i{expression} ::= @i{expression} and then @i{expression} +@i{expression} ::= @i{expression} or else @i{expression} +@i{expression} ::= ( @i{expression} ) +@end smallexample + +The following restriction exists: it is not allowed to have "and" or "or" +following "not" in the same expression without parentheses. For example, this +is not allowed: + +@smallexample + not X or Y +@end smallexample + +This should be one of the following: + +@smallexample + (not X) or Y + not (X or Y) +@end smallexample + +@noindent +For the first test (@i{expression} ::= ) the symbol must have +either the value true or false, that is to say the right-hand of the +symbol definition must be one of the (case-insensitive) literals +@code{True} or @code{False}. If the value is true, then the +corresponding lines are included, and if the value is false, they are +excluded. + +The test (@i{expression} ::= @code{'Defined}) is true only if +the symbol has been defined in the definition file or by a @option{-D} +switch on the command line. Otherwise, the test is false. + +The equality tests are case insensitive, as are all the preprocessor lines. + +If the symbol referenced is not defined in the symbol definitions file, +then the effect depends on whether or not switch @option{-u} +is specified. If so, then the symbol is treated as if it had the value +false and the test fails. If this switch is not specified, then +it is an error to reference an undefined symbol. It is also an error to +reference a symbol that is defined with a value other than @code{True} +or @code{False}. + +The use of the @code{not} operator inverts the sense of this logical test. +The @code{not} operator cannot be combined with the @code{or} or @code{and} +operators, without parentheses. For example, "if not X or Y then" is not +allowed, but "if (not X) or Y then" and "if not (X or Y) then" are. + +The @code{then} keyword is optional as shown + +The @code{#} must be the first non-blank character on a line, but +otherwise the format is free form. Spaces or tabs may appear between +the @code{#} and the keyword. The keywords and the symbols are case +insensitive as in normal Ada code. Comments may be used on a +preprocessor line, but other than that, no other tokens may appear on a +preprocessor line. Any number of @code{elsif} clauses can be present, +including none at all. The @code{else} is optional, as in Ada. + +The @code{#} marking the start of a preprocessor line must be the first +non-blank character on the line, i.e., it must be preceded only by +spaces or horizontal tabs. + +Symbol substitution outside of preprocessor lines is obtained by using +the sequence + +@smallexample +$symbol +@end smallexample + +@noindent +anywhere within a source line, except in a comment or within a +string literal. The identifier +following the @code{$} must match one of the symbols defined in the symbol +definition file, and the result is to substitute the value of the +symbol in place of @code{$symbol} in the output file. + +Note that although the substitution of strings within a string literal +is not possible, it is possible to have a symbol whose defined value is +a string literal. So instead of setting XYZ to @code{hello} and writing: + +@smallexample +Header : String := "$XYZ"; +@end smallexample + +@noindent +you should set XYZ to @code{"hello"} and write: + +@smallexample +Header : String := $XYZ; +@end smallexample + +@noindent +and then the substitution will occur as desired. + +@node The GNAT Library Browser gnatls +@chapter The GNAT Library Browser @code{gnatls} +@findex gnatls +@cindex Library browser + +@noindent +@code{gnatls} is a tool that outputs information about compiled +units. It gives the relationship between objects, unit names and source +files. It can also be used to check the source dependencies of a unit +as well as various characteristics. + +Note: to invoke @code{gnatls} with a project file, use the @code{gnat} +driver (see @ref{The GNAT Driver and Project Files}). + +@menu +* Running gnatls:: +* Switches for gnatls:: +* Examples of gnatls Usage:: +@end menu + +@node Running gnatls +@section Running @code{gnatls} + +@noindent +The @code{gnatls} command has the form + +@smallexample +$ gnatls switches @var{object_or_ali_file} +@end smallexample + +@noindent +The main argument is the list of object or @file{ali} files +(@pxref{The Ada Library Information Files}) +for which information is requested. + +In normal mode, without additional option, @code{gnatls} produces a +four-column listing. Each line represents information for a specific +object. The first column gives the full path of the object, the second +column gives the name of the principal unit in this object, the third +column gives the status of the source and the fourth column gives the +full path of the source representing this unit. +Here is a simple example of use: + +@smallexample +$ gnatls *.o +^./^[]^demo1.o demo1 DIF demo1.adb +^./^[]^demo2.o demo2 OK demo2.adb +^./^[]^hello.o h1 OK hello.adb +^./^[]^instr-child.o instr.child MOK instr-child.adb +^./^[]^instr.o instr OK instr.adb +^./^[]^tef.o tef DIF tef.adb +^./^[]^text_io_example.o text_io_example OK text_io_example.adb +^./^[]^tgef.o tgef DIF tgef.adb +@end smallexample + +@noindent +The first line can be interpreted as follows: the main unit which is +contained in +object file @file{demo1.o} is demo1, whose main source is in +@file{demo1.adb}. Furthermore, the version of the source used for the +compilation of demo1 has been modified (DIF). Each source file has a status +qualifier which can be: + +@table @code +@item OK (unchanged) +The version of the source file used for the compilation of the +specified unit corresponds exactly to the actual source file. + +@item MOK (slightly modified) +The version of the source file used for the compilation of the +specified unit differs from the actual source file but not enough to +require recompilation. If you use gnatmake with the qualifier +@option{^-m (minimal recompilation)^/MINIMAL_RECOMPILATION^}, a file marked +MOK will not be recompiled. + +@item DIF (modified) +No version of the source found on the path corresponds to the source +used to build this object. + +@item ??? (file not found) +No source file was found for this unit. + +@item HID (hidden, unchanged version not first on PATH) +The version of the source that corresponds exactly to the source used +for compilation has been found on the path but it is hidden by another +version of the same source that has been modified. + +@end table + +@node Switches for gnatls +@section Switches for @code{gnatls} + +@noindent +@code{gnatls} recognizes the following switches: + +@table @option +@c !sort! +@cindex @option{--version} @command{gnatls} +Display Copyright and version, then exit disregarding all other options. + +@item --help +@cindex @option{--help} @command{gnatls} +If @option{--version} was not used, display usage, then exit disregarding +all other options. + +@item ^-a^/ALL_UNITS^ +@cindex @option{^-a^/ALL_UNITS^} (@code{gnatls}) +Consider all units, including those of the predefined Ada library. +Especially useful with @option{^-d^/DEPENDENCIES^}. + +@item ^-d^/DEPENDENCIES^ +@cindex @option{^-d^/DEPENDENCIES^} (@code{gnatls}) +List sources from which specified units depend on. + +@item ^-h^/OUTPUT=OPTIONS^ +@cindex @option{^-h^/OUTPUT=OPTIONS^} (@code{gnatls}) +Output the list of options. + +@item ^-o^/OUTPUT=OBJECTS^ +@cindex @option{^-o^/OUTPUT=OBJECTS^} (@code{gnatls}) +Only output information about object files. + +@item ^-s^/OUTPUT=SOURCES^ +@cindex @option{^-s^/OUTPUT=SOURCES^} (@code{gnatls}) +Only output information about source files. + +@item ^-u^/OUTPUT=UNITS^ +@cindex @option{^-u^/OUTPUT=UNITS^} (@code{gnatls}) +Only output information about compilation units. + +@item ^-files^/FILES^=@var{file} +@cindex @option{^-files^/FILES^} (@code{gnatls}) +Take as arguments the files listed in text file @var{file}. +Text file @var{file} may contain empty lines that are ignored. +Each nonempty line should contain the name of an existing file. +Several such switches may be specified simultaneously. + +@item ^-aO^/OBJECT_SEARCH=^@var{dir} +@itemx ^-aI^/SOURCE_SEARCH=^@var{dir} +@itemx ^-I^/SEARCH=^@var{dir} +@itemx ^-I-^/NOCURRENT_DIRECTORY^ +@itemx -nostdinc +@cindex @option{^-aO^/OBJECT_SEARCH^} (@code{gnatls}) +@cindex @option{^-aI^/SOURCE_SEARCH^} (@code{gnatls}) +@cindex @option{^-I^/SEARCH^} (@code{gnatls}) +@cindex @option{^-I-^/NOCURRENT_DIRECTORY^} (@code{gnatls}) +Source path manipulation. Same meaning as the equivalent @command{gnatmake} +flags (@pxref{Switches for gnatmake}). + +@item --RTS=@var{rts-path} +@cindex @option{--RTS} (@code{gnatls}) +Specifies the default location of the runtime library. Same meaning as the +equivalent @command{gnatmake} flag (@pxref{Switches for gnatmake}). + +@item ^-v^/OUTPUT=VERBOSE^ +@cindex @option{^-v^/OUTPUT=VERBOSE^} (@code{gnatls}) +Verbose mode. Output the complete source, object and project paths. Do not use +the default column layout but instead use long format giving as much as +information possible on each requested units, including special +characteristics such as: + +@table @code +@item Preelaborable +The unit is preelaborable in the Ada sense. + +@item No_Elab_Code +No elaboration code has been produced by the compiler for this unit. + +@item Pure +The unit is pure in the Ada sense. + +@item Elaborate_Body +The unit contains a pragma Elaborate_Body. + +@item Remote_Types +The unit contains a pragma Remote_Types. + +@item Shared_Passive +The unit contains a pragma Shared_Passive. + +@item Predefined +This unit is part of the predefined environment and cannot be modified +by the user. + +@item Remote_Call_Interface +The unit contains a pragma Remote_Call_Interface. + +@end table + +@end table + +@node Examples of gnatls Usage +@section Example of @code{gnatls} Usage +@ifclear vms + +@noindent +Example of using the verbose switch. Note how the source and +object paths are affected by the -I switch. + +@smallexample +$ gnatls -v -I.. demo1.o + +GNATLS 5.03w (20041123-34) +Copyright 1997-2004 Free Software Foundation, Inc. + +Source Search Path: + + ../ + /home/comar/local/adainclude/ + +Object Search Path: + + ../ + /home/comar/local/lib/gcc-lib/x86-linux/3.4.3/adalib/ + +Project Search Path: + + /home/comar/local/lib/gnat/ + +./demo1.o + Unit => + Name => demo1 + Kind => subprogram body + Flags => No_Elab_Code + Source => demo1.adb modified +@end smallexample + +@noindent +The following is an example of use of the dependency list. +Note the use of the -s switch +which gives a straight list of source files. This can be useful for +building specialized scripts. + +@smallexample +$ gnatls -d demo2.o +./demo2.o demo2 OK demo2.adb + OK gen_list.ads + OK gen_list.adb + OK instr.ads + OK instr-child.ads + +$ gnatls -d -s -a demo1.o +demo1.adb +/home/comar/local/adainclude/ada.ads +/home/comar/local/adainclude/a-finali.ads +/home/comar/local/adainclude/a-filico.ads +/home/comar/local/adainclude/a-stream.ads +/home/comar/local/adainclude/a-tags.ads +gen_list.ads +gen_list.adb +/home/comar/local/adainclude/gnat.ads +/home/comar/local/adainclude/g-io.ads +instr.ads +/home/comar/local/adainclude/system.ads +/home/comar/local/adainclude/s-exctab.ads +/home/comar/local/adainclude/s-finimp.ads +/home/comar/local/adainclude/s-finroo.ads +/home/comar/local/adainclude/s-secsta.ads +/home/comar/local/adainclude/s-stalib.ads +/home/comar/local/adainclude/s-stoele.ads +/home/comar/local/adainclude/s-stratt.ads +/home/comar/local/adainclude/s-tasoli.ads +/home/comar/local/adainclude/s-unstyp.ads +/home/comar/local/adainclude/unchconv.ads +@end smallexample +@end ifclear + +@ifset vms +@smallexample +GNAT LIST /DEPENDENCIES /OUTPUT=SOURCES /ALL_UNITS DEMO1.ADB + +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]ada.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]a-finali.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]a-filico.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]a-stream.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]a-tags.ads +demo1.adb +gen_list.ads +gen_list.adb +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]gnat.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]g-io.ads +instr.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]system.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-exctab.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-finimp.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-finroo.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-secsta.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-stalib.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-stoele.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-stratt.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-tasoli.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-unstyp.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]unchconv.ads +@end smallexample +@end ifset + +@node Cleaning Up Using gnatclean +@chapter Cleaning Up Using @code{gnatclean} +@findex gnatclean +@cindex Cleaning tool + +@noindent +@code{gnatclean} is a tool that allows the deletion of files produced by the +compiler, binder and linker, including ALI files, object files, tree files, +expanded source files, library files, interface copy source files, binder +generated files and executable files. + +@menu +* Running gnatclean:: +* Switches for gnatclean:: +@c * Examples of gnatclean Usage:: +@end menu + +@node Running gnatclean +@section Running @code{gnatclean} + +@noindent +The @code{gnatclean} command has the form: + +@smallexample +$ gnatclean switches @var{names} +@end smallexample + +@noindent +@var{names} is a list of source file names. Suffixes @code{.^ads^ADS^} and +@code{^adb^ADB^} may be omitted. If a project file is specified using switch +@code{^-P^/PROJECT_FILE=^}, then @var{names} may be completely omitted. + +@noindent +In normal mode, @code{gnatclean} delete the files produced by the compiler and, +if switch @code{^-c^/COMPILER_FILES_ONLY^} is not specified, by the binder and +the linker. In informative-only mode, specified by switch +@code{^-n^/NODELETE^}, the list of files that would have been deleted in +normal mode is listed, but no file is actually deleted. + +@node Switches for gnatclean +@section Switches for @code{gnatclean} + +@noindent +@code{gnatclean} recognizes the following switches: + +@table @option +@c !sort! +@cindex @option{--version} @command{gnatclean} +Display Copyright and version, then exit disregarding all other options. + +@item --help +@cindex @option{--help} @command{gnatclean} +If @option{--version} was not used, display usage, then exit disregarding +all other options. + +@item ^--subdirs^/SUBDIRS^=subdir +Actual object directory of each project file is the subdirectory subdir of the +object directory specified or defaulted in the project file. + +@item ^--unchecked-shared-lib-imports^/UNCHECKED_SHARED_LIB_IMPORTS^ +By default, shared library projects are not allowed to import static library +projects. When this switch is used on the command line, this restriction is +relaxed. + +@item ^-c^/COMPILER_FILES_ONLY^ +@cindex @option{^-c^/COMPILER_FILES_ONLY^} (@code{gnatclean}) +Only attempt to delete the files produced by the compiler, not those produced +by the binder or the linker. The files that are not to be deleted are library +files, interface copy files, binder generated files and executable files. + +@item ^-D ^/DIRECTORY_OBJECTS=^@var{dir} +@cindex @option{^-D^/DIRECTORY_OBJECTS^} (@code{gnatclean}) +Indicate that ALI and object files should normally be found in directory +@var{dir}. + +@item ^-F^/FULL_PATH_IN_BRIEF_MESSAGES^ +@cindex @option{^-F^/FULL_PATH_IN_BRIEF_MESSAGES^} (@code{gnatclean}) +When using project files, if some errors or warnings are detected during +parsing and verbose mode is not in effect (no use of switch +^-v^/VERBOSE^), then error lines start with the full path name of the project +file, rather than its simple file name. + +@item ^-h^/HELP^ +@cindex @option{^-h^/HELP^} (@code{gnatclean}) +Output a message explaining the usage of @code{^gnatclean^gnatclean^}. + +@item ^-n^/NODELETE^ +@cindex @option{^-n^/NODELETE^} (@code{gnatclean}) +Informative-only mode. Do not delete any files. Output the list of the files +that would have been deleted if this switch was not specified. + +@item ^-P^/PROJECT_FILE=^@var{project} +@cindex @option{^-P^/PROJECT_FILE^} (@code{gnatclean}) +Use project file @var{project}. Only one such switch can be used. +When cleaning a project file, the files produced by the compilation of the +immediate sources or inherited sources of the project files are to be +deleted. This is not depending on the presence or not of executable names +on the command line. + +@item ^-q^/QUIET^ +@cindex @option{^-q^/QUIET^} (@code{gnatclean}) +Quiet output. If there are no errors, do not output anything, except in +verbose mode (switch ^-v^/VERBOSE^) or in informative-only mode +(switch ^-n^/NODELETE^). + +@item ^-r^/RECURSIVE^ +@cindex @option{^-r^/RECURSIVE^} (@code{gnatclean}) +When a project file is specified (using switch ^-P^/PROJECT_FILE=^), +clean all imported and extended project files, recursively. If this switch +is not specified, only the files related to the main project file are to be +deleted. This switch has no effect if no project file is specified. + +@item ^-v^/VERBOSE^ +@cindex @option{^-v^/VERBOSE^} (@code{gnatclean}) +Verbose mode. + +@item ^-vP^/MESSAGES_PROJECT_FILE=^@emph{x} +@cindex @option{^-vP^/MESSAGES_PROJECT_FILE^} (@code{gnatclean}) +Indicates the verbosity of the parsing of GNAT project files. +@xref{Switches Related to Project Files}. + +@item ^-X^/EXTERNAL_REFERENCE=^@var{name=value} +@cindex @option{^-X^/EXTERNAL_REFERENCE^} (@code{gnatclean}) +Indicates that external variable @var{name} has the value @var{value}. +The Project Manager will use this value for occurrences of +@code{external(name)} when parsing the project file. +@xref{Switches Related to Project Files}. + +@item ^-aO^/OBJECT_SEARCH=^@var{dir} +@cindex @option{^-aO^/OBJECT_SEARCH^} (@code{gnatclean}) +When searching for ALI and object files, look in directory +@var{dir}. + +@item ^-I^/SEARCH=^@var{dir} +@cindex @option{^-I^/SEARCH^} (@code{gnatclean}) +Equivalent to @option{^-aO^/OBJECT_SEARCH=^@var{dir}}. + +@item ^-I-^/NOCURRENT_DIRECTORY^ +@cindex @option{^-I-^/NOCURRENT_DIRECTORY^} (@code{gnatclean}) +@cindex Source files, suppressing search +Do not look for ALI or object files in the directory +where @code{gnatclean} was invoked. + +@end table + +@c @node Examples of gnatclean Usage +@c @section Examples of @code{gnatclean} Usage + +@ifclear vms +@node GNAT and Libraries +@chapter GNAT and Libraries +@cindex Library, building, installing, using + +@noindent +This chapter describes how to build and use libraries with GNAT, and also shows +how to recompile the GNAT run-time library. You should be familiar with the +Project Manager facility (@pxref{GNAT Project Manager}) before reading this +chapter. + +@menu +* Introduction to Libraries in GNAT:: +* General Ada Libraries:: +* Stand-alone Ada Libraries:: +* Rebuilding the GNAT Run-Time Library:: +@end menu + +@node Introduction to Libraries in GNAT +@section Introduction to Libraries in GNAT + +@noindent +A library is, conceptually, a collection of objects which does not have its +own main thread of execution, but rather provides certain services to the +applications that use it. A library can be either statically linked with the +application, in which case its code is directly included in the application, +or, on platforms that support it, be dynamically linked, in which case +its code is shared by all applications making use of this library. + +GNAT supports both types of libraries. +In the static case, the compiled code can be provided in different ways. The +simplest approach is to provide directly the set of objects resulting from +compilation of the library source files. Alternatively, you can group the +objects into an archive using whatever commands are provided by the operating +system. For the latter case, the objects are grouped into a shared library. + +In the GNAT environment, a library has three types of components: +@itemize @bullet +@item +Source files. +@item +@file{ALI} files. +@xref{The Ada Library Information Files}. +@item +Object files, an archive or a shared library. +@end itemize + +@noindent +A GNAT library may expose all its source files, which is useful for +documentation purposes. Alternatively, it may expose only the units needed by +an external user to make use of the library. That is to say, the specs +reflecting the library services along with all the units needed to compile +those specs, which can include generic bodies or any body implementing an +inlined routine. In the case of @emph{stand-alone libraries} those exposed +units are called @emph{interface units} (@pxref{Stand-alone Ada Libraries}). + +All compilation units comprising an application, including those in a library, +need to be elaborated in an order partially defined by Ada's semantics. GNAT +computes the elaboration order from the @file{ALI} files and this is why they +constitute a mandatory part of GNAT libraries. +@emph{Stand-alone libraries} are the exception to this rule because a specific +library elaboration routine is produced independently of the application(s) +using the library. + +@node General Ada Libraries +@section General Ada Libraries + +@menu +* Building a library:: +* Installing a library:: +* Using a library:: +@end menu + +@node Building a library +@subsection Building a library + +@noindent +The easiest way to build a library is to use the Project Manager, +which supports a special type of project called a @emph{Library Project} +(@pxref{Library Projects}). + +A project is considered a library project, when two project-level attributes +are defined in it: @code{Library_Name} and @code{Library_Dir}. In order to +control different aspects of library configuration, additional optional +project-level attributes can be specified: +@table @code +@item Library_Kind +This attribute controls whether the library is to be static or dynamic + +@item Library_Version +This attribute specifies the library version; this value is used +during dynamic linking of shared libraries to determine if the currently +installed versions of the binaries are compatible. + +@item Library_Options +@item Library_GCC +These attributes specify additional low-level options to be used during +library generation, and redefine the actual application used to generate +library. +@end table + +@noindent +The GNAT Project Manager takes full care of the library maintenance task, +including recompilation of the source files for which objects do not exist +or are not up to date, assembly of the library archive, and installation of +the library (i.e., copying associated source, object and @file{ALI} files +to the specified location). + +Here is a simple library project file: +@smallexample @c ada +project My_Lib is + for Source_Dirs use ("src1", "src2"); + for Object_Dir use "obj"; + for Library_Name use "mylib"; + for Library_Dir use "lib"; + for Library_Kind use "dynamic"; +end My_lib; +@end smallexample + +@noindent +and the compilation command to build and install the library: + +@smallexample @c ada + $ gnatmake -Pmy_lib +@end smallexample + +@noindent +It is not entirely trivial to perform manually all the steps required to +produce a library. We recommend that you use the GNAT Project Manager +for this task. In special cases where this is not desired, the necessary +steps are discussed below. + +There are various possibilities for compiling the units that make up the +library: for example with a Makefile (@pxref{Using the GNU make Utility}) or +with a conventional script. For simple libraries, it is also possible to create +a dummy main program which depends upon all the packages that comprise the +interface of the library. This dummy main program can then be given to +@command{gnatmake}, which will ensure that all necessary objects are built. + +After this task is accomplished, you should follow the standard procedure +of the underlying operating system to produce the static or shared library. + +Here is an example of such a dummy program: +@smallexample @c ada +@group +with My_Lib.Service1; +with My_Lib.Service2; +with My_Lib.Service3; +procedure My_Lib_Dummy is +begin + null; +end; +@end group +@end smallexample + +@noindent +Here are the generic commands that will build an archive or a shared library. + +@smallexample +# compiling the library +$ gnatmake -c my_lib_dummy.adb + +# we don't need the dummy object itself +$ rm my_lib_dummy.o my_lib_dummy.ali + +# create an archive with the remaining objects +$ ar rc libmy_lib.a *.o +# some systems may require "ranlib" to be run as well + +# or create a shared library +$ gcc -shared -o libmy_lib.so *.o +# some systems may require the code to have been compiled with -fPIC + +# remove the object files that are now in the library +$ rm *.o + +# Make the ALI files read-only so that gnatmake will not try to +# regenerate the objects that are in the library +$ chmod -w *.ali +@end smallexample + +@noindent +Please note that the library must have a name of the form @file{lib@var{xxx}.a} +or @file{lib@var{xxx}.so} (or @file{lib@var{xxx}.dll} on Windows) in order to +be accessed by the directive @option{-l@var{xxx}} at link time. + +@node Installing a library +@subsection Installing a library +@cindex @code{ADA_PROJECT_PATH} +@cindex @code{GPR_PROJECT_PATH} + +@noindent +If you use project files, library installation is part of the library build +process (@pxref{Installing a library with project files}). + +When project files are not an option, it is also possible, but not recommended, +to install the library so that the sources needed to use the library are on the +Ada source path and the ALI files & libraries be on the Ada Object path (see +@ref{Search Paths and the Run-Time Library (RTL)}. Alternatively, the system +administrator can place general-purpose libraries in the default compiler +paths, by specifying the libraries' location in the configuration files +@file{ada_source_path} and @file{ada_object_path}. These configuration files +must be located in the GNAT installation tree at the same place as the gcc spec +file. The location of the gcc spec file can be determined as follows: +@smallexample +$ gcc -v +@end smallexample + +@noindent +The configuration files mentioned above have a simple format: each line +must contain one unique directory name. +Those names are added to the corresponding path +in their order of appearance in the file. The names can be either absolute +or relative; in the latter case, they are relative to where theses files +are located. + +The files @file{ada_source_path} and @file{ada_object_path} might not be +present in a +GNAT installation, in which case, GNAT will look for its run-time library in +the directories @file{adainclude} (for the sources) and @file{adalib} (for the +objects and @file{ALI} files). When the files exist, the compiler does not +look in @file{adainclude} and @file{adalib}, and thus the +@file{ada_source_path} file +must contain the location for the GNAT run-time sources (which can simply +be @file{adainclude}). In the same way, the @file{ada_object_path} file must +contain the location for the GNAT run-time objects (which can simply +be @file{adalib}). + +You can also specify a new default path to the run-time library at compilation +time with the switch @option{--RTS=rts-path}. You can thus choose / change +the run-time library you want your program to be compiled with. This switch is +recognized by @command{gcc}, @command{gnatmake}, @command{gnatbind}, +@command{gnatls}, @command{gnatfind} and @command{gnatxref}. + +It is possible to install a library before or after the standard GNAT +library, by reordering the lines in the configuration files. In general, a +library must be installed before the GNAT library if it redefines +any part of it. + +@node Using a library +@subsection Using a library + +@noindent Once again, the project facility greatly simplifies the use of +libraries. In this context, using a library is just a matter of adding a +@code{with} clause in the user project. For instance, to make use of the +library @code{My_Lib} shown in examples in earlier sections, you can +write: + +@smallexample @c projectfile +with "my_lib"; +project My_Proj is + @dots{} +end My_Proj; +@end smallexample + +Even if you have a third-party, non-Ada library, you can still use GNAT's +Project Manager facility to provide a wrapper for it. For example, the +following project, when @code{with}ed by your main project, will link with the +third-party library @file{liba.a}: + +@smallexample @c projectfile +@group +project Liba is + for Externally_Built use "true"; + for Source_Files use (); + for Library_Dir use "lib"; + for Library_Name use "a"; + for Library_Kind use "static"; +end Liba; +@end group +@end smallexample +This is an alternative to the use of @code{pragma Linker_Options}. It is +especially interesting in the context of systems with several interdependent +static libraries where finding a proper linker order is not easy and best be +left to the tools having visibility over project dependence information. + +@noindent +In order to use an Ada library manually, you need to make sure that this +library is on both your source and object path +(see @ref{Search Paths and the Run-Time Library (RTL)} +and @ref{Search Paths for gnatbind}). Furthermore, when the objects are grouped +in an archive or a shared library, you need to specify the desired +library at link time. + +For example, you can use the library @file{mylib} installed in +@file{/dir/my_lib_src} and @file{/dir/my_lib_obj} with the following commands: + +@smallexample +$ gnatmake -aI/dir/my_lib_src -aO/dir/my_lib_obj my_appl \ + -largs -lmy_lib +@end smallexample + +@noindent +This can be expressed more simply: +@smallexample +$ gnatmake my_appl +@end smallexample +@noindent +when the following conditions are met: +@itemize @bullet +@item +@file{/dir/my_lib_src} has been added by the user to the environment +variable @env{ADA_INCLUDE_PATH}, or by the administrator to the file +@file{ada_source_path} +@item +@file{/dir/my_lib_obj} has been added by the user to the environment +variable @env{ADA_OBJECTS_PATH}, or by the administrator to the file +@file{ada_object_path} +@item +a pragma @code{Linker_Options} has been added to one of the sources. +For example: + +@smallexample @c ada +pragma Linker_Options ("-lmy_lib"); +@end smallexample +@end itemize + +@node Stand-alone Ada Libraries +@section Stand-alone Ada Libraries +@cindex Stand-alone library, building, using + +@menu +* Introduction to Stand-alone Libraries:: +* Building a Stand-alone Library:: +* Creating a Stand-alone Library to be used in a non-Ada context:: +* Restrictions in Stand-alone Libraries:: +@end menu + +@node Introduction to Stand-alone Libraries +@subsection Introduction to Stand-alone Libraries + +@noindent +A Stand-alone Library (abbreviated ``SAL'') is a library that contains the +necessary code to +elaborate the Ada units that are included in the library. In contrast with +an ordinary library, which consists of all sources, objects and @file{ALI} +files of the +library, a SAL may specify a restricted subset of compilation units +to serve as a library interface. In this case, the fully +self-sufficient set of files will normally consist of an objects +archive, the sources of interface units' specs, and the @file{ALI} +files of interface units. +If an interface spec contains a generic unit or an inlined subprogram, +the body's +source must also be provided; if the units that must be provided in the source +form depend on other units, the source and @file{ALI} files of those must +also be provided. + +The main purpose of a SAL is to minimize the recompilation overhead of client +applications when a new version of the library is installed. Specifically, +if the interface sources have not changed, client applications do not need to +be recompiled. If, furthermore, a SAL is provided in the shared form and its +version, controlled by @code{Library_Version} attribute, is not changed, +then the clients do not need to be relinked. + +SALs also allow the library providers to minimize the amount of library source +text exposed to the clients. Such ``information hiding'' might be useful or +necessary for various reasons. + +Stand-alone libraries are also well suited to be used in an executable whose +main routine is not written in Ada. + +@node Building a Stand-alone Library +@subsection Building a Stand-alone Library + +@noindent +GNAT's Project facility provides a simple way of building and installing +stand-alone libraries; see @ref{Stand-alone Library Projects}. +To be a Stand-alone Library Project, in addition to the two attributes +that make a project a Library Project (@code{Library_Name} and +@code{Library_Dir}; see @ref{Library Projects}), the attribute +@code{Library_Interface} must be defined. For example: + +@smallexample @c projectfile +@group + for Library_Dir use "lib_dir"; + for Library_Name use "dummy"; + for Library_Interface use ("int1", "int1.child"); +@end group +@end smallexample + +@noindent +Attribute @code{Library_Interface} has a non-empty string list value, +each string in the list designating a unit contained in an immediate source +of the project file. + +When a Stand-alone Library is built, first the binder is invoked to build +a package whose name depends on the library name +(@file{^b~dummy.ads/b^B$DUMMY.ADS/B^} in the example above). +This binder-generated package includes initialization and +finalization procedures whose +names depend on the library name (@code{dummyinit} and @code{dummyfinal} +in the example +above). The object corresponding to this package is included in the library. + +You must ensure timely (e.g., prior to any use of interfaces in the SAL) +calling of these procedures if a static SAL is built, or if a shared SAL +is built +with the project-level attribute @code{Library_Auto_Init} set to +@code{"false"}. + +For a Stand-Alone Library, only the @file{ALI} files of the Interface Units +(those that are listed in attribute @code{Library_Interface}) are copied to +the Library Directory. As a consequence, only the Interface Units may be +imported from Ada units outside of the library. If other units are imported, +the binding phase will fail. + +The attribute @code{Library_Src_Dir} may be specified for a +Stand-Alone Library. @code{Library_Src_Dir} is a simple attribute that has a +single string value. Its value must be the path (absolute or relative to the +project directory) of an existing directory. This directory cannot be the +object directory or one of the source directories, but it can be the same as +the library directory. The sources of the Interface +Units of the library that are needed by an Ada client of the library will be +copied to the designated directory, called the Interface Copy directory. +These sources include the specs of the Interface Units, but they may also +include bodies and subunits, when pragmas @code{Inline} or @code{Inline_Always} +are used, or when there is a generic unit in the spec. Before the sources +are copied to the Interface Copy directory, an attempt is made to delete all +files in the Interface Copy directory. + +Building stand-alone libraries by hand is somewhat tedious, but for those +occasions when it is necessary here are the steps that you need to perform: +@itemize @bullet +@item +Compile all library sources. + +@item +Invoke the binder with the switch @option{-n} (No Ada main program), +with all the @file{ALI} files of the interfaces, and +with the switch @option{-L} to give specific names to the @code{init} +and @code{final} procedures. For example: +@smallexample + gnatbind -n int1.ali int2.ali -Lsal1 +@end smallexample + +@item +Compile the binder generated file: +@smallexample + gcc -c b~int2.adb +@end smallexample + +@item +Link the dynamic library with all the necessary object files, +indicating to the linker the names of the @code{init} (and possibly +@code{final}) procedures for automatic initialization (and finalization). +The built library should be placed in a directory different from +the object directory. + +@item +Copy the @code{ALI} files of the interface to the library directory, +add in this copy an indication that it is an interface to a SAL +(i.e., add a word @option{SL} on the line in the @file{ALI} file that starts +with letter ``P'') and make the modified copy of the @file{ALI} file +read-only. +@end itemize + +@noindent +Using SALs is not different from using other libraries +(see @ref{Using a library}). + +@node Creating a Stand-alone Library to be used in a non-Ada context +@subsection Creating a Stand-alone Library to be used in a non-Ada context + +@noindent +It is easy to adapt the SAL build procedure discussed above for use of a SAL in +a non-Ada context. + +The only extra step required is to ensure that library interface subprograms +are compatible with the main program, by means of @code{pragma Export} +or @code{pragma Convention}. + +Here is an example of simple library interface for use with C main program: + +@smallexample @c ada +package My_Package is + + procedure Do_Something; + pragma Export (C, Do_Something, "do_something"); + + procedure Do_Something_Else; + pragma Export (C, Do_Something_Else, "do_something_else"); + +end My_Package; +@end smallexample + +@noindent +On the foreign language side, you must provide a ``foreign'' view of the +library interface; remember that it should contain elaboration routines in +addition to interface subprograms. + +The example below shows the content of @code{mylib_interface.h} (note +that there is no rule for the naming of this file, any name can be used) +@smallexample +/* the library elaboration procedure */ +extern void mylibinit (void); + +/* the library finalization procedure */ +extern void mylibfinal (void); + +/* the interface exported by the library */ +extern void do_something (void); +extern void do_something_else (void); +@end smallexample + +@noindent +Libraries built as explained above can be used from any program, provided +that the elaboration procedures (named @code{mylibinit} in the previous +example) are called before the library services are used. Any number of +libraries can be used simultaneously, as long as the elaboration +procedure of each library is called. + +Below is an example of a C program that uses the @code{mylib} library. + +@smallexample +#include "mylib_interface.h" + +int +main (void) +@{ + /* First, elaborate the library before using it */ + mylibinit (); + + /* Main program, using the library exported entities */ + do_something (); + do_something_else (); + + /* Library finalization at the end of the program */ + mylibfinal (); + return 0; +@} +@end smallexample + +@noindent +Note that invoking any library finalization procedure generated by +@code{gnatbind} shuts down the Ada run-time environment. +Consequently, the +finalization of all Ada libraries must be performed at the end of the program. +No call to these libraries or to the Ada run-time library should be made +after the finalization phase. + +@node Restrictions in Stand-alone Libraries +@subsection Restrictions in Stand-alone Libraries + +@noindent +The pragmas listed below should be used with caution inside libraries, +as they can create incompatibilities with other Ada libraries: +@itemize @bullet +@item pragma @code{Locking_Policy} +@item pragma @code{Queuing_Policy} +@item pragma @code{Task_Dispatching_Policy} +@item pragma @code{Unreserve_All_Interrupts} +@end itemize + +@noindent +When using a library that contains such pragmas, the user must make sure +that all libraries use the same pragmas with the same values. Otherwise, +@code{Program_Error} will +be raised during the elaboration of the conflicting +libraries. The usage of these pragmas and its consequences for the user +should therefore be well documented. + +Similarly, the traceback in the exception occurrence mechanism should be +enabled or disabled in a consistent manner across all libraries. +Otherwise, Program_Error will be raised during the elaboration of the +conflicting libraries. + +If the @code{Version} or @code{Body_Version} +attributes are used inside a library, then you need to +perform a @code{gnatbind} step that specifies all @file{ALI} files in all +libraries, so that version identifiers can be properly computed. +In practice these attributes are rarely used, so this is unlikely +to be a consideration. + +@node Rebuilding the GNAT Run-Time Library +@section Rebuilding the GNAT Run-Time Library +@cindex GNAT Run-Time Library, rebuilding +@cindex Building the GNAT Run-Time Library +@cindex Rebuilding the GNAT Run-Time Library +@cindex Run-Time Library, rebuilding + +@noindent +It may be useful to recompile the GNAT library in various contexts, the +most important one being the use of partition-wide configuration pragmas +such as @code{Normalize_Scalars}. A special Makefile called +@code{Makefile.adalib} is provided to that effect and can be found in +the directory containing the GNAT library. The location of this +directory depends on the way the GNAT environment has been installed and can +be determined by means of the command: + +@smallexample +$ gnatls -v +@end smallexample + +@noindent +The last entry in the object search path usually contains the +gnat library. This Makefile contains its own documentation and in +particular the set of instructions needed to rebuild a new library and +to use it. + +@node Using the GNU make Utility +@chapter Using the GNU @code{make} Utility +@findex make + +@noindent +This chapter offers some examples of makefiles that solve specific +problems. It does not explain how to write a makefile (@pxref{Top,, GNU +make, make, GNU @code{make}}), nor does it try to replace the +@command{gnatmake} utility (@pxref{The GNAT Make Program gnatmake}). + +All the examples in this section are specific to the GNU version of +make. Although @command{make} is a standard utility, and the basic language +is the same, these examples use some advanced features found only in +@code{GNU make}. + +@menu +* Using gnatmake in a Makefile:: +* Automatically Creating a List of Directories:: +* Generating the Command Line Switches:: +* Overcoming Command Line Length Limits:: +@end menu + +@node Using gnatmake in a Makefile +@section Using gnatmake in a Makefile +@findex makefile +@cindex GNU make + +@noindent +Complex project organizations can be handled in a very powerful way by +using GNU make combined with gnatmake. For instance, here is a Makefile +which allows you to build each subsystem of a big project into a separate +shared library. Such a makefile allows you to significantly reduce the link +time of very big applications while maintaining full coherence at +each step of the build process. + +The list of dependencies are handled automatically by +@command{gnatmake}. The Makefile is simply used to call gnatmake in each of +the appropriate directories. + +Note that you should also read the example on how to automatically +create the list of directories +(@pxref{Automatically Creating a List of Directories}) +which might help you in case your project has a lot of subdirectories. + +@smallexample +@iftex +@leftskip=0cm +@font@heightrm=cmr8 +@heightrm +@end iftex +## This Makefile is intended to be used with the following directory +## configuration: +## - The sources are split into a series of csc (computer software components) +## Each of these csc is put in its own directory. +## Their name are referenced by the directory names. +## They will be compiled into shared library (although this would also work +## with static libraries +## - The main program (and possibly other packages that do not belong to any +## csc is put in the top level directory (where the Makefile is). +## toplevel_dir __ first_csc (sources) __ lib (will contain the library) +## \_ second_csc (sources) __ lib (will contain the library) +## \_ @dots{} +## Although this Makefile is build for shared library, it is easy to modify +## to build partial link objects instead (modify the lines with -shared and +## gnatlink below) +## +## With this makefile, you can change any file in the system or add any new +## file, and everything will be recompiled correctly (only the relevant shared +## objects will be recompiled, and the main program will be re-linked). + +# The list of computer software component for your project. This might be +# generated automatically. +CSC_LIST=aa bb cc + +# Name of the main program (no extension) +MAIN=main + +# If we need to build objects with -fPIC, uncomment the following line +#NEED_FPIC=-fPIC + +# The following variable should give the directory containing libgnat.so +# You can get this directory through 'gnatls -v'. This is usually the last +# directory in the Object_Path. +GLIB=@dots{} + +# The directories for the libraries +# (This macro expands the list of CSC to the list of shared libraries, you +# could simply use the expanded form: +# LIB_DIR=aa/lib/libaa.so bb/lib/libbb.so cc/lib/libcc.so +LIB_DIR=$@{foreach dir,$@{CSC_LIST@},$@{dir@}/lib/lib$@{dir@}.so@} + +$@{MAIN@}: objects $@{LIB_DIR@} + gnatbind $@{MAIN@} $@{CSC_LIST:%=-aO%/lib@} -shared + gnatlink $@{MAIN@} $@{CSC_LIST:%=-l%@} + +objects:: + # recompile the sources + gnatmake -c -i $@{MAIN@}.adb $@{NEED_FPIC@} $@{CSC_LIST:%=-I%@} + +# Note: In a future version of GNAT, the following commands will be simplified +# by a new tool, gnatmlib +$@{LIB_DIR@}: + mkdir -p $@{dir $@@ @} + cd $@{dir $@@ @} && gcc -shared -o $@{notdir $@@ @} ../*.o -L$@{GLIB@} -lgnat + cd $@{dir $@@ @} && cp -f ../*.ali . + +# The dependencies for the modules +# Note that we have to force the expansion of *.o, since in some cases +# make won't be able to do it itself. +aa/lib/libaa.so: $@{wildcard aa/*.o@} +bb/lib/libbb.so: $@{wildcard bb/*.o@} +cc/lib/libcc.so: $@{wildcard cc/*.o@} + +# Make sure all of the shared libraries are in the path before starting the +# program +run:: + LD_LIBRARY_PATH=`pwd`/aa/lib:`pwd`/bb/lib:`pwd`/cc/lib ./$@{MAIN@} + +clean:: + $@{RM@} -rf $@{CSC_LIST:%=%/lib@} + $@{RM@} $@{CSC_LIST:%=%/*.ali@} + $@{RM@} $@{CSC_LIST:%=%/*.o@} + $@{RM@} *.o *.ali $@{MAIN@} +@end smallexample + +@node Automatically Creating a List of Directories +@section Automatically Creating a List of Directories + +@noindent +In most makefiles, you will have to specify a list of directories, and +store it in a variable. For small projects, it is often easier to +specify each of them by hand, since you then have full control over what +is the proper order for these directories, which ones should be +included. + +However, in larger projects, which might involve hundreds of +subdirectories, it might be more convenient to generate this list +automatically. + +The example below presents two methods. The first one, although less +general, gives you more control over the list. It involves wildcard +characters, that are automatically expanded by @command{make}. Its +shortcoming is that you need to explicitly specify some of the +organization of your project, such as for instance the directory tree +depth, whether some directories are found in a separate tree, @enddots{} + +The second method is the most general one. It requires an external +program, called @command{find}, which is standard on all Unix systems. All +the directories found under a given root directory will be added to the +list. + +@smallexample +@iftex +@leftskip=0cm +@font@heightrm=cmr8 +@heightrm +@end iftex +# The examples below are based on the following directory hierarchy: +# All the directories can contain any number of files +# ROOT_DIRECTORY -> a -> aa -> aaa +# -> ab +# -> ac +# -> b -> ba -> baa +# -> bb +# -> bc +# This Makefile creates a variable called DIRS, that can be reused any time +# you need this list (see the other examples in this section) + +# The root of your project's directory hierarchy +ROOT_DIRECTORY=. + +#### +# First method: specify explicitly the list of directories +# This allows you to specify any subset of all the directories you need. +#### + +DIRS := a/aa/ a/ab/ b/ba/ + +#### +# Second method: use wildcards +# Note that the argument(s) to wildcard below should end with a '/'. +# Since wildcards also return file names, we have to filter them out +# to avoid duplicate directory names. +# We thus use make's @code{dir} and @code{sort} functions. +# It sets DIRs to the following value (note that the directories aaa and baa +# are not given, unless you change the arguments to wildcard). +# DIRS= ./a/a/ ./b/ ./a/aa/ ./a/ab/ ./a/ac/ ./b/ba/ ./b/bb/ ./b/bc/ +#### + +DIRS := $@{sort $@{dir $@{wildcard $@{ROOT_DIRECTORY@}/*/ + $@{ROOT_DIRECTORY@}/*/*/@}@}@} + +#### +# Third method: use an external program +# This command is much faster if run on local disks, avoiding NFS slowdowns. +# This is the most complete command: it sets DIRs to the following value: +# DIRS= ./a ./a/aa ./a/aa/aaa ./a/ab ./a/ac ./b ./b/ba ./b/ba/baa ./b/bb ./b/bc +#### + +DIRS := $@{shell find $@{ROOT_DIRECTORY@} -type d -print@} + +@end smallexample + +@node Generating the Command Line Switches +@section Generating the Command Line Switches + +@noindent +Once you have created the list of directories as explained in the +previous section (@pxref{Automatically Creating a List of Directories}), +you can easily generate the command line arguments to pass to gnatmake. + +For the sake of completeness, this example assumes that the source path +is not the same as the object path, and that you have two separate lists +of directories. + +@smallexample +# see "Automatically creating a list of directories" to create +# these variables +SOURCE_DIRS= +OBJECT_DIRS= + +GNATMAKE_SWITCHES := $@{patsubst %,-aI%,$@{SOURCE_DIRS@}@} +GNATMAKE_SWITCHES += $@{patsubst %,-aO%,$@{OBJECT_DIRS@}@} + +all: + gnatmake $@{GNATMAKE_SWITCHES@} main_unit +@end smallexample + +@node Overcoming Command Line Length Limits +@section Overcoming Command Line Length Limits + +@noindent +One problem that might be encountered on big projects is that many +operating systems limit the length of the command line. It is thus hard to give +gnatmake the list of source and object directories. + +This example shows how you can set up environment variables, which will +make @command{gnatmake} behave exactly as if the directories had been +specified on the command line, but have a much higher length limit (or +even none on most systems). + +It assumes that you have created a list of directories in your Makefile, +using one of the methods presented in +@ref{Automatically Creating a List of Directories}. +For the sake of completeness, we assume that the object +path (where the ALI files are found) is different from the sources patch. + +Note a small trick in the Makefile below: for efficiency reasons, we +create two temporary variables (SOURCE_LIST and OBJECT_LIST), that are +expanded immediately by @code{make}. This way we overcome the standard +make behavior which is to expand the variables only when they are +actually used. + +On Windows, if you are using the standard Windows command shell, you must +replace colons with semicolons in the assignments to these variables. + +@smallexample +@iftex +@leftskip=0cm +@font@heightrm=cmr8 +@heightrm +@end iftex +# In this example, we create both ADA_INCLUDE_PATH and ADA_OBJECT_PATH. +# This is the same thing as putting the -I arguments on the command line. +# (the equivalent of using -aI on the command line would be to define +# only ADA_INCLUDE_PATH, the equivalent of -aO is ADA_OBJECT_PATH). +# You can of course have different values for these variables. +# +# Note also that we need to keep the previous values of these variables, since +# they might have been set before running 'make' to specify where the GNAT +# library is installed. + +# see "Automatically creating a list of directories" to create these +# variables +SOURCE_DIRS= +OBJECT_DIRS= + +empty:= +space:=$@{empty@} $@{empty@} +SOURCE_LIST := $@{subst $@{space@},:,$@{SOURCE_DIRS@}@} +OBJECT_LIST := $@{subst $@{space@},:,$@{OBJECT_DIRS@}@} +ADA_INCLUDE_PATH += $@{SOURCE_LIST@} +ADA_OBJECT_PATH += $@{OBJECT_LIST@} +export ADA_INCLUDE_PATH +export ADA_OBJECT_PATH + +all: + gnatmake main_unit +@end smallexample +@end ifclear + +@node Memory Management Issues +@chapter Memory Management Issues + +@noindent +This chapter describes some useful memory pools provided in the GNAT library +and in particular the GNAT Debug Pool facility, which can be used to detect +incorrect uses of access values (including ``dangling references''). +@ifclear vms +It also describes the @command{gnatmem} tool, which can be used to track down +``memory leaks''. +@end ifclear + +@menu +* Some Useful Memory Pools:: +* The GNAT Debug Pool Facility:: +@ifclear vms +* The gnatmem Tool:: +@end ifclear +@end menu + +@node Some Useful Memory Pools +@section Some Useful Memory Pools +@findex Memory Pool +@cindex storage, pool + +@noindent +The @code{System.Pool_Global} package offers the Unbounded_No_Reclaim_Pool +storage pool. Allocations use the standard system call @code{malloc} while +deallocations use the standard system call @code{free}. No reclamation is +performed when the pool goes out of scope. For performance reasons, the +standard default Ada allocators/deallocators do not use any explicit storage +pools but if they did, they could use this storage pool without any change in +behavior. That is why this storage pool is used when the user +manages to make the default implicit allocator explicit as in this example: +@smallexample @c ada + type T1 is access Something; + -- no Storage pool is defined for T2 + type T2 is access Something_Else; + for T2'Storage_Pool use T1'Storage_Pool; + -- the above is equivalent to + for T2'Storage_Pool use System.Pool_Global.Global_Pool_Object; +@end smallexample + +@noindent +The @code{System.Pool_Local} package offers the Unbounded_Reclaim_Pool storage +pool. The allocation strategy is similar to @code{Pool_Local}'s +except that the all +storage allocated with this pool is reclaimed when the pool object goes out of +scope. This pool provides a explicit mechanism similar to the implicit one +provided by several Ada 83 compilers for allocations performed through a local +access type and whose purpose was to reclaim memory when exiting the +scope of a given local access. As an example, the following program does not +leak memory even though it does not perform explicit deallocation: + +@smallexample @c ada +with System.Pool_Local; +procedure Pooloc1 is + procedure Internal is + type A is access Integer; + X : System.Pool_Local.Unbounded_Reclaim_Pool; + for A'Storage_Pool use X; + v : A; + begin + for I in 1 .. 50 loop + v := new Integer; + end loop; + end Internal; +begin + for I in 1 .. 100 loop + Internal; + end loop; +end Pooloc1; +@end smallexample + +@noindent +The @code{System.Pool_Size} package implements the Stack_Bounded_Pool used when +@code{Storage_Size} is specified for an access type. +The whole storage for the pool is +allocated at once, usually on the stack at the point where the access type is +elaborated. It is automatically reclaimed when exiting the scope where the +access type is defined. This package is not intended to be used directly by the +user and it is implicitly used for each such declaration: + +@smallexample @c ada + type T1 is access Something; + for T1'Storage_Size use 10_000; +@end smallexample + +@node The GNAT Debug Pool Facility +@section The GNAT Debug Pool Facility +@findex Debug Pool +@cindex storage, pool, memory corruption + +@noindent +The use of unchecked deallocation and unchecked conversion can easily +lead to incorrect memory references. The problems generated by such +references are usually difficult to tackle because the symptoms can be +very remote from the origin of the problem. In such cases, it is +very helpful to detect the problem as early as possible. This is the +purpose of the Storage Pool provided by @code{GNAT.Debug_Pools}. + +In order to use the GNAT specific debugging pool, the user must +associate a debug pool object with each of the access types that may be +related to suspected memory problems. See Ada Reference Manual 13.11. +@smallexample @c ada +type Ptr is access Some_Type; +Pool : GNAT.Debug_Pools.Debug_Pool; +for Ptr'Storage_Pool use Pool; +@end smallexample + +@noindent +@code{GNAT.Debug_Pools} is derived from a GNAT-specific kind of +pool: the @code{Checked_Pool}. Such pools, like standard Ada storage pools, +allow the user to redefine allocation and deallocation strategies. They +also provide a checkpoint for each dereference, through the use of +the primitive operation @code{Dereference} which is implicitly called at +each dereference of an access value. + +Once an access type has been associated with a debug pool, operations on +values of the type may raise four distinct exceptions, +which correspond to four potential kinds of memory corruption: +@itemize @bullet +@item +@code{GNAT.Debug_Pools.Accessing_Not_Allocated_Storage} +@item +@code{GNAT.Debug_Pools.Accessing_Deallocated_Storage} +@item +@code{GNAT.Debug_Pools.Freeing_Not_Allocated_Storage} +@item +@code{GNAT.Debug_Pools.Freeing_Deallocated_Storage } +@end itemize + +@noindent +For types associated with a Debug_Pool, dynamic allocation is performed using +the standard GNAT allocation routine. References to all allocated chunks of +memory are kept in an internal dictionary. Several deallocation strategies are +provided, whereupon the user can choose to release the memory to the system, +keep it allocated for further invalid access checks, or fill it with an easily +recognizable pattern for debug sessions. The memory pattern is the old IBM +hexadecimal convention: @code{16#DEADBEEF#}. + +See the documentation in the file g-debpoo.ads for more information on the +various strategies. + +Upon each dereference, a check is made that the access value denotes a +properly allocated memory location. Here is a complete example of use of +@code{Debug_Pools}, that includes typical instances of memory corruption: +@smallexample @c ada +@iftex +@leftskip=0cm +@end iftex +with Gnat.Io; use Gnat.Io; +with Unchecked_Deallocation; +with Unchecked_Conversion; +with GNAT.Debug_Pools; +with System.Storage_Elements; +with Ada.Exceptions; use Ada.Exceptions; +procedure Debug_Pool_Test is + + type T is access Integer; + type U is access all T; + + P : GNAT.Debug_Pools.Debug_Pool; + for T'Storage_Pool use P; + + procedure Free is new Unchecked_Deallocation (Integer, T); + function UC is new Unchecked_Conversion (U, T); + A, B : aliased T; + + procedure Info is new GNAT.Debug_Pools.Print_Info(Put_Line); + +begin + Info (P); + A := new Integer; + B := new Integer; + B := A; + Info (P); + Free (A); + begin + Put_Line (Integer'Image(B.all)); + exception + when E : others => Put_Line ("raised: " & Exception_Name (E)); + end; + begin + Free (B); + exception + when E : others => Put_Line ("raised: " & Exception_Name (E)); + end; + B := UC(A'Access); + begin + Put_Line (Integer'Image(B.all)); + exception + when E : others => Put_Line ("raised: " & Exception_Name (E)); + end; + begin + Free (B); + exception + when E : others => Put_Line ("raised: " & Exception_Name (E)); + end; + Info (P); +end Debug_Pool_Test; +@end smallexample + +@noindent +The debug pool mechanism provides the following precise diagnostics on the +execution of this erroneous program: +@smallexample +Debug Pool info: + Total allocated bytes : 0 + Total deallocated bytes : 0 + Current Water Mark: 0 + High Water Mark: 0 + +Debug Pool info: + Total allocated bytes : 8 + Total deallocated bytes : 0 + Current Water Mark: 8 + High Water Mark: 8 + +raised: GNAT.DEBUG_POOLS.ACCESSING_DEALLOCATED_STORAGE +raised: GNAT.DEBUG_POOLS.FREEING_DEALLOCATED_STORAGE +raised: GNAT.DEBUG_POOLS.ACCESSING_NOT_ALLOCATED_STORAGE +raised: GNAT.DEBUG_POOLS.FREEING_NOT_ALLOCATED_STORAGE +Debug Pool info: + Total allocated bytes : 8 + Total deallocated bytes : 4 + Current Water Mark: 4 + High Water Mark: 8 +@end smallexample + +@ifclear vms +@node The gnatmem Tool +@section The @command{gnatmem} Tool +@findex gnatmem + +@noindent +The @code{gnatmem} utility monitors dynamic allocation and +deallocation activity in a program, and displays information about +incorrect deallocations and possible sources of memory leaks. +It is designed to work in association with a static runtime library +only and in this context provides three types of information: +@itemize @bullet +@item +General information concerning memory management, such as the total +number of allocations and deallocations, the amount of allocated +memory and the high water mark, i.e.@: the largest amount of allocated +memory in the course of program execution. + +@item +Backtraces for all incorrect deallocations, that is to say deallocations +which do not correspond to a valid allocation. + +@item +Information on each allocation that is potentially the origin of a memory +leak. +@end itemize + +@menu +* Running gnatmem:: +* Switches for gnatmem:: +* Example of gnatmem Usage:: +@end menu + +@node Running gnatmem +@subsection Running @code{gnatmem} + +@noindent +@code{gnatmem} makes use of the output created by the special version of +allocation and deallocation routines that record call information. This +allows to obtain accurate dynamic memory usage history at a minimal cost to +the execution speed. Note however, that @code{gnatmem} is not supported on +all platforms (currently, it is supported on AIX, HP-UX, GNU/Linux, +Solaris and Windows NT/2000/XP (x86). + +@noindent +The @code{gnatmem} command has the form + +@smallexample +@c $ gnatmem @ovar{switches} user_program +@c Expanding @ovar macro inline (explanation in macro def comments) + $ gnatmem @r{[}@var{switches}@r{]} @var{user_program} +@end smallexample + +@noindent +The program must have been linked with the instrumented version of the +allocation and deallocation routines. This is done by linking with the +@file{libgmem.a} library. For correct symbolic backtrace information, +the user program should be compiled with debugging options +(see @ref{Switches for gcc}). For example to build @file{my_program}: + +@smallexample +$ gnatmake -g my_program -largs -lgmem +@end smallexample + +@noindent +As library @file{libgmem.a} contains an alternate body for package +@code{System.Memory}, @file{s-memory.adb} should not be compiled and linked +when an executable is linked with library @file{libgmem.a}. It is then not +recommended to use @command{gnatmake} with switch @option{^-a^/ALL_FILES^}. + +@noindent +When @file{my_program} is executed, the file @file{gmem.out} is produced. +This file contains information about all allocations and deallocations +performed by the program. It is produced by the instrumented allocations and +deallocations routines and will be used by @code{gnatmem}. + +In order to produce symbolic backtrace information for allocations and +deallocations performed by the GNAT run-time library, you need to use a +version of that library that has been compiled with the @option{-g} switch +(see @ref{Rebuilding the GNAT Run-Time Library}). + +Gnatmem must be supplied with the @file{gmem.out} file and the executable to +examine. If the location of @file{gmem.out} file was not explicitly supplied by +@option{-i} switch, gnatmem will assume that this file can be found in the +current directory. For example, after you have executed @file{my_program}, +@file{gmem.out} can be analyzed by @code{gnatmem} using the command: + +@smallexample +$ gnatmem my_program +@end smallexample + +@noindent +This will produce the output with the following format: + +*************** debut cc +@smallexample +$ gnatmem my_program + +Global information +------------------ + Total number of allocations : 45 + Total number of deallocations : 6 + Final Water Mark (non freed mem) : 11.29 Kilobytes + High Water Mark : 11.40 Kilobytes + +. +. +. +Allocation Root # 2 +------------------- + Number of non freed allocations : 11 + Final Water Mark (non freed mem) : 1.16 Kilobytes + High Water Mark : 1.27 Kilobytes + Backtrace : + my_program.adb:23 my_program.alloc +. +. +. +@end smallexample + +The first block of output gives general information. In this case, the +Ada construct ``@code{@b{new}}'' was executed 45 times, and only 6 calls to an +Unchecked_Deallocation routine occurred. + +@noindent +Subsequent paragraphs display information on all allocation roots. +An allocation root is a specific point in the execution of the program +that generates some dynamic allocation, such as a ``@code{@b{new}}'' +construct. This root is represented by an execution backtrace (or subprogram +call stack). By default the backtrace depth for allocations roots is 1, so +that a root corresponds exactly to a source location. The backtrace can +be made deeper, to make the root more specific. + +@node Switches for gnatmem +@subsection Switches for @code{gnatmem} + +@noindent +@code{gnatmem} recognizes the following switches: + +@table @option + +@item -q +@cindex @option{-q} (@code{gnatmem}) +Quiet. Gives the minimum output needed to identify the origin of the +memory leaks. Omits statistical information. + +@item @var{N} +@cindex @var{N} (@code{gnatmem}) +N is an integer literal (usually between 1 and 10) which controls the +depth of the backtraces defining allocation root. The default value for +N is 1. The deeper the backtrace, the more precise the localization of +the root. Note that the total number of roots can depend on this +parameter. This parameter must be specified @emph{before} the name of the +executable to be analyzed, to avoid ambiguity. + +@item -b n +@cindex @option{-b} (@code{gnatmem}) +This switch has the same effect as just depth parameter. + +@item -i @var{file} +@cindex @option{-i} (@code{gnatmem}) +Do the @code{gnatmem} processing starting from @file{file}, rather than +@file{gmem.out} in the current directory. + +@item -m n +@cindex @option{-m} (@code{gnatmem}) +This switch causes @code{gnatmem} to mask the allocation roots that have less +than n leaks. The default value is 1. Specifying the value of 0 will allow to +examine even the roots that didn't result in leaks. + +@item -s order +@cindex @option{-s} (@code{gnatmem}) +This switch causes @code{gnatmem} to sort the allocation roots according to the +specified order of sort criteria, each identified by a single letter. The +currently supported criteria are @code{n, h, w} standing respectively for +number of unfreed allocations, high watermark, and final watermark +corresponding to a specific root. The default order is @code{nwh}. + +@end table + +@node Example of gnatmem Usage +@subsection Example of @code{gnatmem} Usage + +@noindent +The following example shows the use of @code{gnatmem} +on a simple memory-leaking program. +Suppose that we have the following Ada program: + +@smallexample @c ada +@group +@cartouche +with Unchecked_Deallocation; +procedure Test_Gm is + + type T is array (1..1000) of Integer; + type Ptr is access T; + procedure Free is new Unchecked_Deallocation (T, Ptr); + A : Ptr; + + procedure My_Alloc is + begin + A := new T; + end My_Alloc; + + procedure My_DeAlloc is + B : Ptr := A; + begin + Free (B); + end My_DeAlloc; + +begin + My_Alloc; + for I in 1 .. 5 loop + for J in I .. 5 loop + My_Alloc; + end loop; + My_Dealloc; + end loop; +end; +@end cartouche +@end group +@end smallexample + +@noindent +The program needs to be compiled with debugging option and linked with +@code{gmem} library: + +@smallexample +$ gnatmake -g test_gm -largs -lgmem +@end smallexample + +@noindent +Then we execute the program as usual: + +@smallexample +$ test_gm +@end smallexample + +@noindent +Then @code{gnatmem} is invoked simply with +@smallexample +$ gnatmem test_gm +@end smallexample + +@noindent +which produces the following output (result may vary on different platforms): + +@smallexample +Global information +------------------ + Total number of allocations : 18 + Total number of deallocations : 5 + Final Water Mark (non freed mem) : 53.00 Kilobytes + High Water Mark : 56.90 Kilobytes + +Allocation Root # 1 +------------------- + Number of non freed allocations : 11 + Final Water Mark (non freed mem) : 42.97 Kilobytes + High Water Mark : 46.88 Kilobytes + Backtrace : + test_gm.adb:11 test_gm.my_alloc + +Allocation Root # 2 +------------------- + Number of non freed allocations : 1 + Final Water Mark (non freed mem) : 10.02 Kilobytes + High Water Mark : 10.02 Kilobytes + Backtrace : + s-secsta.adb:81 system.secondary_stack.ss_init + +Allocation Root # 3 +------------------- + Number of non freed allocations : 1 + Final Water Mark (non freed mem) : 12 Bytes + High Water Mark : 12 Bytes + Backtrace : + s-secsta.adb:181 system.secondary_stack.ss_init +@end smallexample + +@noindent +Note that the GNAT run time contains itself a certain number of +allocations that have no corresponding deallocation, +as shown here for root #2 and root +#3. This is a normal behavior when the number of non-freed allocations +is one, it allocates dynamic data structures that the run time needs for +the complete lifetime of the program. Note also that there is only one +allocation root in the user program with a single line back trace: +test_gm.adb:11 test_gm.my_alloc, whereas a careful analysis of the +program shows that 'My_Alloc' is called at 2 different points in the +source (line 21 and line 24). If those two allocation roots need to be +distinguished, the backtrace depth parameter can be used: + +@smallexample +$ gnatmem 3 test_gm +@end smallexample + +@noindent +which will give the following output: + +@smallexample +Global information +------------------ + Total number of allocations : 18 + Total number of deallocations : 5 + Final Water Mark (non freed mem) : 53.00 Kilobytes + High Water Mark : 56.90 Kilobytes + +Allocation Root # 1 +------------------- + Number of non freed allocations : 10 + Final Water Mark (non freed mem) : 39.06 Kilobytes + High Water Mark : 42.97 Kilobytes + Backtrace : + test_gm.adb:11 test_gm.my_alloc + test_gm.adb:24 test_gm + b_test_gm.c:52 main + +Allocation Root # 2 +------------------- + Number of non freed allocations : 1 + Final Water Mark (non freed mem) : 10.02 Kilobytes + High Water Mark : 10.02 Kilobytes + Backtrace : + s-secsta.adb:81 system.secondary_stack.ss_init + s-secsta.adb:283 + b_test_gm.c:33 adainit + +Allocation Root # 3 +------------------- + Number of non freed allocations : 1 + Final Water Mark (non freed mem) : 3.91 Kilobytes + High Water Mark : 3.91 Kilobytes + Backtrace : + test_gm.adb:11 test_gm.my_alloc + test_gm.adb:21 test_gm + b_test_gm.c:52 main + +Allocation Root # 4 +------------------- + Number of non freed allocations : 1 + Final Water Mark (non freed mem) : 12 Bytes + High Water Mark : 12 Bytes + Backtrace : + s-secsta.adb:181 system.secondary_stack.ss_init + s-secsta.adb:283 + b_test_gm.c:33 adainit +@end smallexample + +@noindent +The allocation root #1 of the first example has been split in 2 roots #1 +and #3 thanks to the more precise associated backtrace. + +@end ifclear + +@node Stack Related Facilities +@chapter Stack Related Facilities + +@noindent +This chapter describes some useful tools associated with stack +checking and analysis. In +particular, it deals with dynamic and static stack usage measurements. + +@menu +* Stack Overflow Checking:: +* Static Stack Usage Analysis:: +* Dynamic Stack Usage Analysis:: +@end menu + +@node Stack Overflow Checking +@section Stack Overflow Checking +@cindex Stack Overflow Checking +@cindex -fstack-check + +@noindent +For most operating systems, @command{gcc} does not perform stack overflow +checking by default. This means that if the main environment task or +some other task exceeds the available stack space, then unpredictable +behavior will occur. Most native systems offer some level of protection by +adding a guard page at the end of each task stack. This mechanism is usually +not enough for dealing properly with stack overflow situations because +a large local variable could ``jump'' above the guard page. +Furthermore, when the +guard page is hit, there may not be any space left on the stack for executing +the exception propagation code. Enabling stack checking avoids +such situations. + +To activate stack checking, compile all units with the gcc option +@option{-fstack-check}. For example: + +@smallexample +gcc -c -fstack-check package1.adb +@end smallexample + +@noindent +Units compiled with this option will generate extra instructions to check +that any use of the stack (for procedure calls or for declaring local +variables in declare blocks) does not exceed the available stack space. +If the space is exceeded, then a @code{Storage_Error} exception is raised. + +For declared tasks, the stack size is controlled by the size +given in an applicable @code{Storage_Size} pragma or by the value specified +at bind time with @option{-d} (@pxref{Switches for gnatbind}) or is set to +the default size as defined in the GNAT runtime otherwise. + +For the environment task, the stack size depends on +system defaults and is unknown to the compiler. Stack checking +may still work correctly if a fixed +size stack is allocated, but this cannot be guaranteed. +@ifclear vms +To ensure that a clean exception is signalled for stack +overflow, set the environment variable +@env{GNAT_STACK_LIMIT} to indicate the maximum +stack area that can be used, as in: +@cindex GNAT_STACK_LIMIT + +@smallexample +SET GNAT_STACK_LIMIT 1600 +@end smallexample + +@noindent +The limit is given in kilobytes, so the above declaration would +set the stack limit of the environment task to 1.6 megabytes. +Note that the only purpose of this usage is to limit the amount +of stack used by the environment task. If it is necessary to +increase the amount of stack for the environment task, then this +is an operating systems issue, and must be addressed with the +appropriate operating systems commands. +@end ifclear +@ifset vms +To have a fixed size stack in the environment task, the stack must be put +in the P0 address space and its size specified. Use these switches to +create a p0 image: + +@smallexample +gnatmake my_progs -largs "-Wl,--opt=STACK=4000,/p0image" +@end smallexample + +@noindent +The quotes are required to keep case. The number after @samp{STACK=} is the +size of the environmental task stack in pagelets (512 bytes). In this example +the stack size is about 2 megabytes. + +@noindent +A consequence of the @option{/p0image} qualifier is also to makes RMS buffers +be placed in P0 space. Refer to @cite{HP OpenVMS Linker Utility Manual} for +more details about the @option{/p0image} qualifier and the @option{stack} +option. +@end ifset + +@node Static Stack Usage Analysis +@section Static Stack Usage Analysis +@cindex Static Stack Usage Analysis +@cindex -fstack-usage + +@noindent +A unit compiled with @option{-fstack-usage} will generate an extra file +that specifies +the maximum amount of stack used, on a per-function basis. +The file has the same +basename as the target object file with a @file{.su} extension. +Each line of this file is made up of three fields: + +@itemize +@item +The name of the function. +@item +A number of bytes. +@item +One or more qualifiers: @code{static}, @code{dynamic}, @code{bounded}. +@end itemize + +The second field corresponds to the size of the known part of the function +frame. + +The qualifier @code{static} means that the function frame size +is purely static. +It usually means that all local variables have a static size. +In this case, the second field is a reliable measure of the function stack +utilization. + +The qualifier @code{dynamic} means that the function frame size is not static. +It happens mainly when some local variables have a dynamic size. When this +qualifier appears alone, the second field is not a reliable measure +of the function stack analysis. When it is qualified with @code{bounded}, it +means that the second field is a reliable maximum of the function stack +utilization. + +@node Dynamic Stack Usage Analysis +@section Dynamic Stack Usage Analysis + +@noindent +It is possible to measure the maximum amount of stack used by a task, by +adding a switch to @command{gnatbind}, as: + +@smallexample +$ gnatbind -u0 file +@end smallexample + +@noindent +With this option, at each task termination, its stack usage is output on +@file{stderr}. +It is not always convenient to output the stack usage when the program +is still running. Hence, it is possible to delay this output until program +termination. for a given number of tasks specified as the argument of the +@option{-u} option. For instance: + +@smallexample +$ gnatbind -u100 file +@end smallexample + +@noindent +will buffer the stack usage information of the first 100 tasks to terminate and +output this info at program termination. Results are displayed in four +columns: + +@noindent +Index | Task Name | Stack Size | Stack Usage [Value +/- Variation] + +@noindent +where: + +@table @emph +@item Index +is a number associated with each task. + +@item Task Name +is the name of the task analyzed. + +@item Stack Size +is the maximum size for the stack. + +@item Stack Usage +is the measure done by the stack analyzer. In order to prevent overflow, the stack +is not entirely analyzed, and it's not possible to know exactly how +much has actually been used. The report thus contains the theoretical stack usage +(Value) and the possible variation (Variation) around this value. + +@end table + +@noindent +The environment task stack, e.g., the stack that contains the main unit, is +only processed when the environment variable GNAT_STACK_LIMIT is set. + + +@c ********************************* +@c * GNATCHECK * +@c ********************************* +@node Verifying Properties Using gnatcheck +@chapter Verifying Properties Using @command{gnatcheck} +@findex gnatcheck +@cindex @command{gnatcheck} + +@noindent +The @command{gnatcheck} tool is an ASIS-based utility that checks properties +of Ada source files according to a given set of semantic rules. +@cindex ASIS + +In order to check compliance with a given rule, @command{gnatcheck} has to +semantically analyze the Ada sources. +Therefore, checks can only be performed on +legal Ada units. Moreover, when a unit depends semantically upon units located +outside the current directory, the source search path has to be provided when +calling @command{gnatcheck}, either through a specified project file or +through @command{gnatcheck} switches. + +A number of rules are predefined in @command{gnatcheck} and are described +later in this chapter. + +For full details, refer to @cite{GNATcheck Reference Manual} document. + + +@c ********************************* +@node Creating Sample Bodies Using gnatstub +@chapter Creating Sample Bodies Using @command{gnatstub} +@findex gnatstub + +@noindent +@command{gnatstub} creates body stubs, that is, empty but compilable bodies +for library unit declarations. + +Note: to invoke @code{gnatstub} with a project file, use the @code{gnat} +driver (see @ref{The GNAT Driver and Project Files}). + +To create a body stub, @command{gnatstub} has to compile the library +unit declaration. Therefore, bodies can be created only for legal +library units. Moreover, if a library unit depends semantically upon +units located outside the current directory, you have to provide +the source search path when calling @command{gnatstub}, see the description +of @command{gnatstub} switches below. + +By default, all the program unit body stubs generated by @code{gnatstub} +raise the predefined @code{Program_Error} exception, which will catch +accidental calls of generated stubs. This behavior can be changed with +option @option{^--no-exception^/NO_EXCEPTION^} (see below). + +@menu +* Running gnatstub:: +* Switches for gnatstub:: +@end menu + +@node Running gnatstub +@section Running @command{gnatstub} + +@noindent +@command{gnatstub} has the command-line interface of the form + +@smallexample +@c $ gnatstub @ovar{switches} @var{filename} @ovar{directory} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatstub @r{[}@var{switches}@r{]} @var{filename} @r{[}@var{directory}@r{]} @r{[}-cargs @var{gcc_switches}@r{]} +@end smallexample + +@noindent +where +@table @var +@item filename +is the name of the source file that contains a library unit declaration +for which a body must be created. The file name may contain the path +information. +The file name does not have to follow the GNAT file name conventions. If the +name +does not follow GNAT file naming conventions, the name of the body file must +be provided +explicitly as the value of the @option{^-o^/BODY=^@var{body-name}} option. +If the file name follows the GNAT file naming +conventions and the name of the body file is not provided, +@command{gnatstub} +creates the name +of the body file from the argument file name by replacing the @file{.ads} +suffix +with the @file{.adb} suffix. + +@item directory +indicates the directory in which the body stub is to be placed (the default +is the +current directory) + +@item @samp{@var{gcc_switches}} is a list of switches for +@command{gcc}. They will be passed on to all compiler invocations made by +@command{gnatelim} to generate the ASIS trees. Here you can provide +@option{^-I^/INCLUDE_DIRS=^} switches to form the source search path, +use the @option{-gnatec} switch to set the configuration file, +use the @option{-gnat05} switch if sources should be compiled in +Ada 2005 mode etc. + +@item switches +is an optional sequence of switches as described in the next section +@end table + +@node Switches for gnatstub +@section Switches for @command{gnatstub} + +@table @option +@c !sort! + +@item ^-f^/FULL^ +@cindex @option{^-f^/FULL^} (@command{gnatstub}) +If the destination directory already contains a file with the name of the +body file +for the argument spec file, replace it with the generated body stub. + +@item ^-hs^/HEADER=SPEC^ +@cindex @option{^-hs^/HEADER=SPEC^} (@command{gnatstub}) +Put the comment header (i.e., all the comments preceding the +compilation unit) from the source of the library unit declaration +into the body stub. + +@item ^-hg^/HEADER=GENERAL^ +@cindex @option{^-hg^/HEADER=GENERAL^} (@command{gnatstub}) +Put a sample comment header into the body stub. + +@item ^--header-file=@var{filename}^/FROM_HEADER_FILE=@var{filename}^ +@cindex @option{^--header-file^/FROM_HEADER_FILE=^} (@command{gnatstub}) +Use the content of the file as the comment header for a generated body stub. + +@ifclear vms +@item -IDIR +@cindex @option{-IDIR} (@command{gnatstub}) +@itemx -I- +@cindex @option{-I-} (@command{gnatstub}) +@end ifclear +@ifset vms +@item /NOCURRENT_DIRECTORY +@cindex @option{/NOCURRENT_DIRECTORY} (@command{gnatstub}) +@end ifset +^These switches have ^This switch has^ the same meaning as in calls to +@command{gcc}. +^They define ^It defines ^ the source search path in the call to +@command{gcc} issued +by @command{gnatstub} to compile an argument source file. + +@item ^-gnatec^/CONFIGURATION_PRAGMAS_FILE=^@var{PATH} +@cindex @option{^-gnatec^/CONFIGURATION_PRAGMAS_FILE^} (@command{gnatstub}) +This switch has the same meaning as in calls to @command{gcc}. +It defines the additional configuration file to be passed to the call to +@command{gcc} issued +by @command{gnatstub} to compile an argument source file. + +@item ^-gnatyM^/MAX_LINE_LENGTH=^@var{n} +@cindex @option{^-gnatyM^/MAX_LINE_LENGTH^} (@command{gnatstub}) +(@var{n} is a non-negative integer). Set the maximum line length in the +body stub to @var{n}; the default is 79. The maximum value that can be +specified is 32767. Note that in the special case of configuration +pragma files, the maximum is always 32767 regardless of whether or +not this switch appears. + +@item ^-gnaty^/STYLE_CHECKS=^@var{n} +@cindex @option{^-gnaty^/STYLE_CHECKS=^} (@command{gnatstub}) +(@var{n} is a non-negative integer from 1 to 9). Set the indentation level in +the generated body sample to @var{n}. +The default indentation is 3. + +@item ^-gnatyo^/ORDERED_SUBPROGRAMS^ +@cindex @option{^-gnato^/ORDERED_SUBPROGRAMS^} (@command{gnatstub}) +Order local bodies alphabetically. (By default local bodies are ordered +in the same way as the corresponding local specs in the argument spec file.) + +@item ^-i^/INDENTATION=^@var{n} +@cindex @option{^-i^/INDENTATION^} (@command{gnatstub}) +Same as @option{^-gnaty^/STYLE_CHECKS=^@var{n}} + +@item ^-k^/TREE_FILE=SAVE^ +@cindex @option{^-k^/TREE_FILE=SAVE^} (@command{gnatstub}) +Do not remove the tree file (i.e., the snapshot of the compiler internal +structures used by @command{gnatstub}) after creating the body stub. + +@item ^-l^/LINE_LENGTH=^@var{n} +@cindex @option{^-l^/LINE_LENGTH^} (@command{gnatstub}) +Same as @option{^-gnatyM^/MAX_LINE_LENGTH=^@var{n}} + +@item ^--no-exception^/NO_EXCEPTION^ +@cindex @option{^--no-exception^/NO_EXCEPTION^} (@command{gnatstub}) +void raising PROGRAM_ERROR in the generated bodies of program unit stubs. +This is not always possible for function stubs. + +@item ^--no-local-header^/NO_LOCAL_HEADER^ +@cindex @option{^--no-local-header^/NO_LOCAL_HEADER^} (@command{gnatstub}) +Do not place local comment header with unit name before body stub for a +unit. + +@item ^-o ^/BODY=^@var{body-name} +@cindex @option{^-o^/BODY^} (@command{gnatstub}) +Body file name. This should be set if the argument file name does not +follow +the GNAT file naming +conventions. If this switch is omitted the default name for the body will be +obtained +from the argument file name according to the GNAT file naming conventions. + +@item ^-q^/QUIET^ +@cindex @option{^-q^/QUIET^} (@command{gnatstub}) +Quiet mode: do not generate a confirmation when a body is +successfully created, and do not generate a message when a body is not +required for an +argument unit. + +@item ^-r^/TREE_FILE=REUSE^ +@cindex @option{^-r^/TREE_FILE=REUSE^} (@command{gnatstub}) +Reuse the tree file (if it exists) instead of creating it. Instead of +creating the tree file for the library unit declaration, @command{gnatstub} +tries to find it in the current directory and use it for creating +a body. If the tree file is not found, no body is created. This option +also implies @option{^-k^/SAVE^}, whether or not +the latter is set explicitly. + +@item ^-t^/TREE_FILE=OVERWRITE^ +@cindex @option{^-t^/TREE_FILE=OVERWRITE^} (@command{gnatstub}) +Overwrite the existing tree file. If the current directory already +contains the file which, according to the GNAT file naming rules should +be considered as a tree file for the argument source file, +@command{gnatstub} +will refuse to create the tree file needed to create a sample body +unless this option is set. + +@item ^-v^/VERBOSE^ +@cindex @option{^-v^/VERBOSE^} (@command{gnatstub}) +Verbose mode: generate version information. + +@end table + +@c ********************************* +@node Generating Ada Bindings for C and C++ headers +@chapter Generating Ada Bindings for C and C++ headers +@findex binding + +@noindent +GNAT now comes with a binding generator for C and C++ headers which is +intended to do 95% of the tedious work of generating Ada specs from C +or C++ header files. + +Note that this capability is not intended to generate 100% correct Ada specs, +and will is some cases require manual adjustments, although it can often +be used out of the box in practice. + +Some of the known limitations include: + +@itemize @bullet +@item only very simple character constant macros are translated into Ada +constants. Function macros (macros with arguments) are partially translated +as comments, to be completed manually if needed. +@item some extensions (e.g. vector types) are not supported +@item pointers to pointers or complex structures are mapped to System.Address +@item identifiers with identical name (except casing) will generate compilation + errors (e.g. @code{shm_get} vs @code{SHM_GET}). +@end itemize + +The code generated is using the Ada 2005 syntax, which makes it +easier to interface with other languages than previous versions of Ada. + +@menu +* Running the binding generator:: +* Generating bindings for C++ headers:: +* Switches:: +@end menu + +@node Running the binding generator +@section Running the binding generator + +@noindent +The binding generator is part of the @command{gcc} compiler and can be +invoked via the @option{-fdump-ada-spec} switch, which will generate Ada +spec files for the header files specified on the command line, and all +header files needed by these files transitively. For example: + +@smallexample +$ g++ -c -fdump-ada-spec -C /usr/include/time.h +$ gcc -c -gnat05 *.ads +@end smallexample + +will generate, under GNU/Linux, the following files: @file{time_h.ads}, +@file{bits_time_h.ads}, @file{stddef_h.ads}, @file{bits_types_h.ads} which +correspond to the files @file{/usr/include/time.h}, +@file{/usr/include/bits/time.h}, etc@dots{}, and will then compile in Ada 2005 +mode these Ada specs. + +The @code{-C} switch tells @command{gcc} to extract comments from headers, +and will attempt to generate corresponding Ada comments. + +If you want to generate a single Ada file and not the transitive closure, you +can use instead the @option{-fdump-ada-spec-slim} switch. + +Note that we recommend when possible to use the @command{g++} driver to +generate bindings, even for most C headers, since this will in general +generate better Ada specs. For generating bindings for C++ headers, it is +mandatory to use the @command{g++} command, or @command{gcc -x c++} which +is equivalent in this case. If @command{g++} cannot work on your C headers +because of incompatibilities between C and C++, then you can fallback to +@command{gcc} instead. + +For an example of better bindings generated from the C++ front-end, +the name of the parameters (when available) are actually ignored by the C +front-end. Consider the following C header: + +@smallexample +extern void foo (int variable); +@end smallexample + +with the C front-end, @code{variable} is ignored, and the above is handled as: + +@smallexample +extern void foo (int); +@end smallexample + +generating a generic: + +@smallexample +procedure foo (param1 : int); +@end smallexample + +with the C++ front-end, the name is available, and we generate: + +@smallexample +procedure foo (variable : int); +@end smallexample + +In some cases, the generated bindings will be more complete or more meaningful +when defining some macros, which you can do via the @option{-D} switch. This +is for example the case with @file{Xlib.h} under GNU/Linux: + +@smallexample +g++ -c -fdump-ada-spec -DXLIB_ILLEGAL_ACCESS -C /usr/include/X11/Xlib.h +@end smallexample + +The above will generate more complete bindings than a straight call without +the @option{-DXLIB_ILLEGAL_ACCESS} switch. + +In other cases, it is not possible to parse a header file in a stand alone +manner, because other include files need to be included first. In this +case, the solution is to create a small header file including the needed +@code{#include} and possible @code{#define} directives. For example, to +generate Ada bindings for @file{readline/readline.h}, you need to first +include @file{stdio.h}, so you can create a file with the following two +lines in e.g. @file{readline1.h}: + +@smallexample +#include +#include +@end smallexample + +and then generate Ada bindings from this file: + +@smallexample +$ g++ -c -fdump-ada-spec readline1.h +@end smallexample + +@node Generating bindings for C++ headers +@section Generating bindings for C++ headers + +@noindent +Generating bindings for C++ headers is done using the same options, always +with the @command{g++} compiler. + +In this mode, C++ classes will be mapped to Ada tagged types, constructors +will be mapped using the @code{CPP_Constructor} pragma, and when possible, +multiple inheritance of abstract classes will be mapped to Ada interfaces +(@xref{Interfacing to C++,,,gnat_rm, GNAT Reference Manual}, for additional +information on interfacing to C++). + +For example, given the following C++ header file: + +@smallexample +@group +@cartouche +class Carnivore @{ +public: + virtual int Number_Of_Teeth () = 0; +@}; + +class Domestic @{ +public: + virtual void Set_Owner (char* Name) = 0; +@}; + +class Animal @{ +public: + int Age_Count; + virtual void Set_Age (int New_Age); +@}; + +class Dog : Animal, Carnivore, Domestic @{ + public: + int Tooth_Count; + char *Owner; + + virtual int Number_Of_Teeth (); + virtual void Set_Owner (char* Name); + + Dog(); +@}; +@end cartouche +@end group +@end smallexample + +The corresponding Ada code is generated: + +@smallexample @c ada +@group +@cartouche + package Class_Carnivore is + type Carnivore is limited interface; + pragma Import (CPP, Carnivore); + + function Number_Of_Teeth (this : access Carnivore) return int is abstract; + end; + use Class_Carnivore; + + package Class_Domestic is + type Domestic is limited interface; + pragma Import (CPP, Domestic); + + procedure Set_Owner + (this : access Domestic; + Name : Interfaces.C.Strings.chars_ptr) is abstract; + end; + use Class_Domestic; + + package Class_Animal is + type Animal is tagged limited record + Age_Count : aliased int; + end record; + pragma Import (CPP, Animal); + + procedure Set_Age (this : access Animal; New_Age : int); + pragma Import (CPP, Set_Age, "_ZN6Animal7Set_AgeEi"); + end; + use Class_Animal; + + package Class_Dog is + type Dog is new Animal and Carnivore and Domestic with record + Tooth_Count : aliased int; + Owner : Interfaces.C.Strings.chars_ptr; + end record; + pragma Import (CPP, Dog); + + function Number_Of_Teeth (this : access Dog) return int; + pragma Import (CPP, Number_Of_Teeth, "_ZN3Dog15Number_Of_TeethEv"); + + procedure Set_Owner + (this : access Dog; Name : Interfaces.C.Strings.chars_ptr); + pragma Import (CPP, Set_Owner, "_ZN3Dog9Set_OwnerEPc"); + + function New_Dog return Dog; + pragma CPP_Constructor (New_Dog); + pragma Import (CPP, New_Dog, "_ZN3DogC1Ev"); + end; + use Class_Dog; +@end cartouche +@end group +@end smallexample + +@node Switches +@section Switches + +@table @option +@item -fdump-ada-spec +@cindex @option{-fdump-ada-spec} (@command{gcc}) +Generate Ada spec files for the given header files transitively (including +all header files that these headers depend upon). + +@item -fdump-ada-spec-slim +@cindex @option{-fdump-ada-spec-slim} (@command{gcc}) +Generate Ada spec files for the header files specified on the command line +only. + +@item -C +@cindex @option{-C} (@command{gcc}) +Extract comments from headers and generate Ada comments in the Ada spec files. +@end table + +@node Other Utility Programs +@chapter Other Utility Programs + +@noindent +This chapter discusses some other utility programs available in the Ada +environment. + +@menu +* Using Other Utility Programs with GNAT:: +* The External Symbol Naming Scheme of GNAT:: +* Converting Ada Files to html with gnathtml:: +* Installing gnathtml:: +@ifset vms +* LSE:: +* Profiling:: +@end ifset +@end menu + +@node Using Other Utility Programs with GNAT +@section Using Other Utility Programs with GNAT + +@noindent +The object files generated by GNAT are in standard system format and in +particular the debugging information uses this format. This means +programs generated by GNAT can be used with existing utilities that +depend on these formats. + +@ifclear vms +In general, any utility program that works with C will also often work with +Ada programs generated by GNAT. This includes software utilities such as +gprof (a profiling program), @code{gdb} (the FSF debugger), and utilities such +as Purify. +@end ifclear + +@node The External Symbol Naming Scheme of GNAT +@section The External Symbol Naming Scheme of GNAT + +@noindent +In order to interpret the output from GNAT, when using tools that are +originally intended for use with other languages, it is useful to +understand the conventions used to generate link names from the Ada +entity names. + +All link names are in all lowercase letters. With the exception of library +procedure names, the mechanism used is simply to use the full expanded +Ada name with dots replaced by double underscores. For example, suppose +we have the following package spec: + +@smallexample @c ada +@group +@cartouche +package QRS is + MN : Integer; +end QRS; +@end cartouche +@end group +@end smallexample + +@noindent +The variable @code{MN} has a full expanded Ada name of @code{QRS.MN}, so +the corresponding link name is @code{qrs__mn}. +@findex Export +Of course if a @code{pragma Export} is used this may be overridden: + +@smallexample @c ada +@group +@cartouche +package Exports is + Var1 : Integer; + pragma Export (Var1, C, External_Name => "var1_name"); + Var2 : Integer; + pragma Export (Var2, C, Link_Name => "var2_link_name"); +end Exports; +@end cartouche +@end group +@end smallexample + +@noindent +In this case, the link name for @var{Var1} is whatever link name the +C compiler would assign for the C function @var{var1_name}. This typically +would be either @var{var1_name} or @var{_var1_name}, depending on operating +system conventions, but other possibilities exist. The link name for +@var{Var2} is @var{var2_link_name}, and this is not operating system +dependent. + +@findex _main +One exception occurs for library level procedures. A potential ambiguity +arises between the required name @code{_main} for the C main program, +and the name we would otherwise assign to an Ada library level procedure +called @code{Main} (which might well not be the main program). + +To avoid this ambiguity, we attach the prefix @code{_ada_} to such +names. So if we have a library level procedure such as + +@smallexample @c ada +@group +@cartouche +procedure Hello (S : String); +@end cartouche +@end group +@end smallexample + +@noindent +the external name of this procedure will be @var{_ada_hello}. + + +@node Converting Ada Files to html with gnathtml +@section Converting Ada Files to HTML with @code{gnathtml} + +@noindent +This @code{Perl} script allows Ada source files to be browsed using +standard Web browsers. For installation procedure, see the section +@xref{Installing gnathtml}. + +Ada reserved keywords are highlighted in a bold font and Ada comments in +a blue font. Unless your program was compiled with the gcc @option{-gnatx} +switch to suppress the generation of cross-referencing information, user +defined variables and types will appear in a different color; you will +be able to click on any identifier and go to its declaration. + +The command line is as follow: +@smallexample +@c $ perl gnathtml.pl @ovar{^switches^options^} @var{ada-files} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ perl gnathtml.pl @r{[}@var{^switches^options^}@r{]} @var{ada-files} +@end smallexample + +@noindent +You can pass it as many Ada files as you want. @code{gnathtml} will generate +an html file for every ada file, and a global file called @file{index.htm}. +This file is an index of every identifier defined in the files. + +The available ^switches^options^ are the following ones: + +@table @option +@item -83 +@cindex @option{-83} (@code{gnathtml}) +Only the Ada 83 subset of keywords will be highlighted. + +@item -cc @var{color} +@cindex @option{-cc} (@code{gnathtml}) +This option allows you to change the color used for comments. The default +value is green. The color argument can be any name accepted by html. + +@item -d +@cindex @option{-d} (@code{gnathtml}) +If the Ada files depend on some other files (for instance through +@code{with} clauses, the latter files will also be converted to html. +Only the files in the user project will be converted to html, not the files +in the run-time library itself. + +@item -D +@cindex @option{-D} (@code{gnathtml}) +This command is the same as @option{-d} above, but @command{gnathtml} will +also look for files in the run-time library, and generate html files for them. + +@item -ext @var{extension} +@cindex @option{-ext} (@code{gnathtml}) +This option allows you to change the extension of the generated HTML files. +If you do not specify an extension, it will default to @file{htm}. + +@item -f +@cindex @option{-f} (@code{gnathtml}) +By default, gnathtml will generate html links only for global entities +('with'ed units, global variables and types,@dots{}). If you specify +@option{-f} on the command line, then links will be generated for local +entities too. + +@item -l @var{number} +@cindex @option{-l} (@code{gnathtml}) +If this ^switch^option^ is provided and @var{number} is not 0, then +@code{gnathtml} will number the html files every @var{number} line. + +@item -I @var{dir} +@cindex @option{-I} (@code{gnathtml}) +Specify a directory to search for library files (@file{.ALI} files) and +source files. You can provide several -I switches on the command line, +and the directories will be parsed in the order of the command line. + +@item -o @var{dir} +@cindex @option{-o} (@code{gnathtml}) +Specify the output directory for html files. By default, gnathtml will +saved the generated html files in a subdirectory named @file{html/}. + +@item -p @var{file} +@cindex @option{-p} (@code{gnathtml}) +If you are using Emacs and the most recent Emacs Ada mode, which provides +a full Integrated Development Environment for compiling, checking, +running and debugging applications, you may use @file{.gpr} files +to give the directories where Emacs can find sources and object files. + +Using this ^switch^option^, you can tell gnathtml to use these files. +This allows you to get an html version of your application, even if it +is spread over multiple directories. + +@item -sc @var{color} +@cindex @option{-sc} (@code{gnathtml}) +This ^switch^option^ allows you to change the color used for symbol +definitions. +The default value is red. The color argument can be any name accepted by html. + +@item -t @var{file} +@cindex @option{-t} (@code{gnathtml}) +This ^switch^option^ provides the name of a file. This file contains a list of +file names to be converted, and the effect is exactly as though they had +appeared explicitly on the command line. This +is the recommended way to work around the command line length limit on some +systems. + +@end table + +@node Installing gnathtml +@section Installing @code{gnathtml} + +@noindent +@code{Perl} needs to be installed on your machine to run this script. +@code{Perl} is freely available for almost every architecture and +Operating System via the Internet. + +On Unix systems, you may want to modify the first line of the script +@code{gnathtml}, to explicitly tell the Operating system where Perl +is. The syntax of this line is: +@smallexample +#!full_path_name_to_perl +@end smallexample + +@noindent +Alternatively, you may run the script using the following command line: + +@smallexample +@c $ perl gnathtml.pl @ovar{switches} @var{files} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ perl gnathtml.pl @r{[}@var{switches}@r{]} @var{files} +@end smallexample + +@ifset vms +@node LSE +@section LSE +@findex LSE + +@noindent +The GNAT distribution provides an Ada 95 template for the HP Language +Sensitive Editor (LSE), a component of DECset. In order to +access it, invoke LSE with the qualifier /ENVIRONMENT=GNU:[LIB]ADA95.ENV. + +@node Profiling +@section Profiling +@findex PCA + +@noindent +GNAT supports The HP Performance Coverage Analyzer (PCA), a component +of DECset. To use it proceed as outlined under ``HELP PCA'', except for running +the collection phase with the /DEBUG qualifier. + +@smallexample +$ GNAT MAKE /DEBUG +$ DEFINE LIB$DEBUG PCA$COLLECTOR +$ RUN/DEBUG +@end smallexample +@noindent +@end ifset + +@ifclear vms +@c ****************************** +@node Code Coverage and Profiling +@chapter Code Coverage and Profiling +@cindex Code Coverage +@cindex Profiling + +@noindent +This chapter describes how to use @code{gcov} - coverage testing tool - and +@code{gprof} - profiler tool - on your Ada programs. + +@menu +* Code Coverage of Ada Programs using gcov:: +* Profiling an Ada Program using gprof:: +@end menu + +@node Code Coverage of Ada Programs using gcov +@section Code Coverage of Ada Programs using gcov +@cindex gcov +@cindex -fprofile-arcs +@cindex -ftest-coverage +@cindex -coverage +@cindex Code Coverage + +@noindent +@code{gcov} is a test coverage program: it analyzes the execution of a given +program on selected tests, to help you determine the portions of the program +that are still untested. + +@code{gcov} is part of the GCC suite, and is described in detail in the GCC +User's Guide. You can refer to this documentation for a more complete +description. + +This chapter provides a quick startup guide, and +details some Gnat-specific features. + +@menu +* Quick startup guide:: +* Gnat specifics:: +@end menu + +@node Quick startup guide +@subsection Quick startup guide + +In order to perform coverage analysis of a program using @code{gcov}, 3 +steps are needed: + +@itemize @bullet +@item +Code instrumentation during the compilation process +@item +Execution of the instrumented program +@item +Execution of the @code{gcov} tool to generate the result. +@end itemize + +The code instrumentation needed by gcov is created at the object level: +The source code is not modified in any way, because the instrumentation code is +inserted by gcc during the compilation process. To compile your code with code +coverage activated, you need to recompile your whole project using the +switches +@code{-fprofile-arcs} and @code{-ftest-coverage}, and link it using +@code{-fprofile-arcs}. + +@smallexample +$ gnatmake -P my_project.gpr -f -cargs -fprofile-arcs -ftest-coverage \ + -largs -fprofile-arcs +@end smallexample + +This compilation process will create @file{.gcno} files together with +the usual object files. + +Once the program is compiled with coverage instrumentation, you can +run it as many times as needed - on portions of a test suite for +example. The first execution will produce @file{.gcda} files at the +same location as the @file{.gcno} files. The following executions +will update those files, so that a cumulative result of the covered +portions of the program is generated. + +Finally, you need to call the @code{gcov} tool. The different options of +@code{gcov} are available in the GCC User's Guide, section 'Invoking gcov'. + +This will create annotated source files with a @file{.gcov} extension: +@file{my_main.adb} file will be analysed in @file{my_main.adb.gcov}. + +@node Gnat specifics +@subsection Gnat specifics + +Because Ada semantics, portions of the source code may be shared among +several object files. This is the case for example when generics are +involved, when inlining is active or when declarations generate initialisation +calls. In order to take +into account this shared code, you need to call @code{gcov} on all +source files of the tested program at once. + +The list of source files might exceed the system's maximum command line +length. In order to bypass this limitation, a new mechanism has been +implemented in @code{gcov}: you can now list all your project's files into a +text file, and provide this file to gcov as a parameter, preceded by a @@ +(e.g. @samp{gcov @@mysrclist.txt}). + +Note that on AIX compiling a static library with @code{-fprofile-arcs} is +not supported as there can be unresolved symbols during the final link. + +@node Profiling an Ada Program using gprof +@section Profiling an Ada Program using gprof +@cindex gprof +@cindex -pg +@cindex Profiling + +@noindent +This section is not meant to be an exhaustive documentation of @code{gprof}. +Full documentation for it can be found in the GNU Profiler User's Guide +documentation that is part of this GNAT distribution. + +Profiling a program helps determine the parts of a program that are executed +most often, and are therefore the most time-consuming. + +@code{gprof} is the standard GNU profiling tool; it has been enhanced to +better handle Ada programs and multitasking. +It is currently supported on the following platforms +@itemize @bullet +@item +linux x86/x86_64 +@item +solaris sparc/sparc64/x86 +@item +windows x86 +@end itemize + +@noindent +In order to profile a program using @code{gprof}, 3 steps are needed: + +@itemize @bullet +@item +Code instrumentation, requiring a full recompilation of the project with the +proper switches. +@item +Execution of the program under the analysis conditions, i.e. with the desired +input. +@item +Analysis of the results using the @code{gprof} tool. +@end itemize + +@noindent +The following sections detail the different steps, and indicate how +to interpret the results: +@menu +* Compilation for profiling:: +* Program execution:: +* Running gprof:: +* Interpretation of profiling results:: +@end menu + +@node Compilation for profiling +@subsection Compilation for profiling +@cindex -pg +@cindex Profiling + +In order to profile a program the first step is to tell the compiler +to generate the necessary profiling information. The compiler switch to be used +is @code{-pg}, which must be added to other compilation switches. This +switch needs to be specified both during compilation and link stages, and can +be specified once when using gnatmake: + +@smallexample +gnatmake -f -pg -P my_project +@end smallexample + +@noindent +Note that only the objects that were compiled with the @samp{-pg} switch will +be profiled; if you need to profile your whole project, use the @samp{-f} +gnatmake switch to force full recompilation. + +@node Program execution +@subsection Program execution + +@noindent +Once the program has been compiled for profiling, you can run it as usual. + +The only constraint imposed by profiling is that the program must terminate +normally. An interrupted program (via a Ctrl-C, kill, etc.) will not be +properly analyzed. + +Once the program completes execution, a data file called @file{gmon.out} is +generated in the directory where the program was launched from. If this file +already exists, it will be overwritten. + +@node Running gprof +@subsection Running gprof + +@noindent +The @code{gprof} tool is called as follow: + +@smallexample +gprof my_prog gmon.out +@end smallexample + +@noindent +or simpler: + +@smallexample +gprof my_prog +@end smallexample + +@noindent +The complete form of the gprof command line is the following: + +@smallexample +gprof [^switches^options^] [executable [data-file]] +@end smallexample + +@noindent +@code{gprof} supports numerous ^switch^options^. The order of these +^switch^options^ does not matter. The full list of options can be found in +the GNU Profiler User's Guide documentation that comes with this documentation. + +The following is the subset of those switches that is most relevant: + +@table @option + +@item --demangle[=@var{style}] +@itemx --no-demangle +@cindex @option{--demangle} (@code{gprof}) +These options control whether symbol names should be demangled when +printing output. The default is to demangle C++ symbols. The +@code{--no-demangle} option may be used to turn off demangling. Different +compilers have different mangling styles. The optional demangling style +argument can be used to choose an appropriate demangling style for your +compiler, in particular Ada symbols generated by GNAT can be demangled using +@code{--demangle=gnat}. + +@item -e @var{function_name} +@cindex @option{-e} (@code{gprof}) +The @samp{-e @var{function}} option tells @code{gprof} not to print +information about the function @var{function_name} (and its +children@dots{}) in the call graph. The function will still be listed +as a child of any functions that call it, but its index number will be +shown as @samp{[not printed]}. More than one @samp{-e} option may be +given; only one @var{function_name} may be indicated with each @samp{-e} +option. + +@item -E @var{function_name} +@cindex @option{-E} (@code{gprof}) +The @code{-E @var{function}} option works like the @code{-e} option, but +execution time spent in the function (and children who were not called from +anywhere else), will not be used to compute the percentages-of-time for +the call graph. More than one @samp{-E} option may be given; only one +@var{function_name} may be indicated with each @samp{-E} option. + +@item -f @var{function_name} +@cindex @option{-f} (@code{gprof}) +The @samp{-f @var{function}} option causes @code{gprof} to limit the +call graph to the function @var{function_name} and its children (and +their children@dots{}). More than one @samp{-f} option may be given; +only one @var{function_name} may be indicated with each @samp{-f} +option. + +@item -F @var{function_name} +@cindex @option{-F} (@code{gprof}) +The @samp{-F @var{function}} option works like the @code{-f} option, but +only time spent in the function and its children (and their +children@dots{}) will be used to determine total-time and +percentages-of-time for the call graph. More than one @samp{-F} option +may be given; only one @var{function_name} may be indicated with each +@samp{-F} option. The @samp{-F} option overrides the @samp{-E} option. + +@end table + +@node Interpretation of profiling results +@subsection Interpretation of profiling results + +@noindent + +The results of the profiling analysis are represented by two arrays: the +'flat profile' and the 'call graph'. Full documentation of those outputs +can be found in the GNU Profiler User's Guide. + +The flat profile shows the time spent in each function of the program, and how +many time it has been called. This allows you to locate easily the most +time-consuming functions. + +The call graph shows, for each subprogram, the subprograms that call it, +and the subprograms that it calls. It also provides an estimate of the time +spent in each of those callers/called subprograms. +@end ifclear + +@c ****************************** +@node Running and Debugging Ada Programs +@chapter Running and Debugging Ada Programs +@cindex Debugging + +@noindent +This chapter discusses how to debug Ada programs. +@ifset vms +It applies to GNAT on the Alpha OpenVMS platform; +for I64 OpenVMS please refer to the @cite{OpenVMS Debugger Manual}, +since HP has implemented Ada support in the OpenVMS debugger on I64. +@end ifset + +An incorrect Ada program may be handled in three ways by the GNAT compiler: + +@enumerate +@item +The illegality may be a violation of the static semantics of Ada. In +that case GNAT diagnoses the constructs in the program that are illegal. +It is then a straightforward matter for the user to modify those parts of +the program. + +@item +The illegality may be a violation of the dynamic semantics of Ada. In +that case the program compiles and executes, but may generate incorrect +results, or may terminate abnormally with some exception. + +@item +When presented with a program that contains convoluted errors, GNAT +itself may terminate abnormally without providing full diagnostics on +the incorrect user program. +@end enumerate + +@menu +* The GNAT Debugger GDB:: +* Running GDB:: +* Introduction to GDB Commands:: +* Using Ada Expressions:: +* Calling User-Defined Subprograms:: +* Using the Next Command in a Function:: +* Ada Exceptions:: +* Ada Tasks:: +* Debugging Generic Units:: +* Remote Debugging using gdbserver:: +* GNAT Abnormal Termination or Failure to Terminate:: +* Naming Conventions for GNAT Source Files:: +* Getting Internal Debugging Information:: +* Stack Traceback:: +@end menu + +@cindex Debugger +@findex gdb + +@node The GNAT Debugger GDB +@section The GNAT Debugger GDB + +@noindent +@code{GDB} is a general purpose, platform-independent debugger that +can be used to debug mixed-language programs compiled with @command{gcc}, +and in particular is capable of debugging Ada programs compiled with +GNAT. The latest versions of @code{GDB} are Ada-aware and can handle +complex Ada data structures. + +@xref{Top,, Debugging with GDB, gdb, Debugging with GDB}, +@ifset vms +located in the GNU:[DOCS] directory, +@end ifset +for full details on the usage of @code{GDB}, including a section on +its usage on programs. This manual should be consulted for full +details. The section that follows is a brief introduction to the +philosophy and use of @code{GDB}. + +When GNAT programs are compiled, the compiler optionally writes debugging +information into the generated object file, including information on +line numbers, and on declared types and variables. This information is +separate from the generated code. It makes the object files considerably +larger, but it does not add to the size of the actual executable that +will be loaded into memory, and has no impact on run-time performance. The +generation of debug information is triggered by the use of the +^-g^/DEBUG^ switch in the @command{gcc} or @command{gnatmake} command +used to carry out the compilations. It is important to emphasize that +the use of these options does not change the generated code. + +The debugging information is written in standard system formats that +are used by many tools, including debuggers and profilers. The format +of the information is typically designed to describe C types and +semantics, but GNAT implements a translation scheme which allows full +details about Ada types and variables to be encoded into these +standard C formats. Details of this encoding scheme may be found in +the file exp_dbug.ads in the GNAT source distribution. However, the +details of this encoding are, in general, of no interest to a user, +since @code{GDB} automatically performs the necessary decoding. + +When a program is bound and linked, the debugging information is +collected from the object files, and stored in the executable image of +the program. Again, this process significantly increases the size of +the generated executable file, but it does not increase the size of +the executable program itself. Furthermore, if this program is run in +the normal manner, it runs exactly as if the debug information were +not present, and takes no more actual memory. + +However, if the program is run under control of @code{GDB}, the +debugger is activated. The image of the program is loaded, at which +point it is ready to run. If a run command is given, then the program +will run exactly as it would have if @code{GDB} were not present. This +is a crucial part of the @code{GDB} design philosophy. @code{GDB} is +entirely non-intrusive until a breakpoint is encountered. If no +breakpoint is ever hit, the program will run exactly as it would if no +debugger were present. When a breakpoint is hit, @code{GDB} accesses +the debugging information and can respond to user commands to inspect +variables, and more generally to report on the state of execution. + +@c ************** +@node Running GDB +@section Running GDB + +@noindent +This section describes how to initiate the debugger. +@c The above sentence is really just filler, but it was otherwise +@c clumsy to get the first paragraph nonindented given the conditional +@c nature of the description + +@ifclear vms +The debugger can be launched from a @code{GPS} menu or +directly from the command line. The description below covers the latter use. +All the commands shown can be used in the @code{GPS} debug console window, +but there are usually more GUI-based ways to achieve the same effect. +@end ifclear + +The command to run @code{GDB} is + +@smallexample +$ ^gdb program^GDB PROGRAM^ +@end smallexample + +@noindent +where @code{^program^PROGRAM^} is the name of the executable file. This +activates the debugger and results in a prompt for debugger commands. +The simplest command is simply @code{run}, which causes the program to run +exactly as if the debugger were not present. The following section +describes some of the additional commands that can be given to @code{GDB}. + +@c ******************************* +@node Introduction to GDB Commands +@section Introduction to GDB Commands + +@noindent +@code{GDB} contains a large repertoire of commands. @xref{Top,, +Debugging with GDB, gdb, Debugging with GDB}, +@ifset vms +located in the GNU:[DOCS] directory, +@end ifset +for extensive documentation on the use +of these commands, together with examples of their use. Furthermore, +the command @command{help} invoked from within GDB activates a simple help +facility which summarizes the available commands and their options. +In this section we summarize a few of the most commonly +used commands to give an idea of what @code{GDB} is about. You should create +a simple program with debugging information and experiment with the use of +these @code{GDB} commands on the program as you read through the +following section. + +@table @code +@item set args @var{arguments} +The @var{arguments} list above is a list of arguments to be passed to +the program on a subsequent run command, just as though the arguments +had been entered on a normal invocation of the program. The @code{set args} +command is not needed if the program does not require arguments. + +@item run +The @code{run} command causes execution of the program to start from +the beginning. If the program is already running, that is to say if +you are currently positioned at a breakpoint, then a prompt will ask +for confirmation that you want to abandon the current execution and +restart. + +@item breakpoint @var{location} +The breakpoint command sets a breakpoint, that is to say a point at which +execution will halt and @code{GDB} will await further +commands. @var{location} is +either a line number within a file, given in the format @code{file:linenumber}, +or it is the name of a subprogram. If you request that a breakpoint be set on +a subprogram that is overloaded, a prompt will ask you to specify on which of +those subprograms you want to breakpoint. You can also +specify that all of them should be breakpointed. If the program is run +and execution encounters the breakpoint, then the program +stops and @code{GDB} signals that the breakpoint was encountered by +printing the line of code before which the program is halted. + +@item catch exception @var{name} +This command causes the program execution to stop whenever exception +@var{name} is raised. If @var{name} is omitted, then the execution is +suspended when any exception is raised. + +@item print @var{expression} +This will print the value of the given expression. Most simple +Ada expression formats are properly handled by @code{GDB}, so the expression +can contain function calls, variables, operators, and attribute references. + +@item continue +Continues execution following a breakpoint, until the next breakpoint or the +termination of the program. + +@item step +Executes a single line after a breakpoint. If the next statement +is a subprogram call, execution continues into (the first statement of) +the called subprogram. + +@item next +Executes a single line. If this line is a subprogram call, executes and +returns from the call. + +@item list +Lists a few lines around the current source location. In practice, it +is usually more convenient to have a separate edit window open with the +relevant source file displayed. Successive applications of this command +print subsequent lines. The command can be given an argument which is a +line number, in which case it displays a few lines around the specified one. + +@item backtrace +Displays a backtrace of the call chain. This command is typically +used after a breakpoint has occurred, to examine the sequence of calls that +leads to the current breakpoint. The display includes one line for each +activation record (frame) corresponding to an active subprogram. + +@item up +At a breakpoint, @code{GDB} can display the values of variables local +to the current frame. The command @code{up} can be used to +examine the contents of other active frames, by moving the focus up +the stack, that is to say from callee to caller, one frame at a time. + +@item down +Moves the focus of @code{GDB} down from the frame currently being +examined to the frame of its callee (the reverse of the previous command), + +@item frame @var{n} +Inspect the frame with the given number. The value 0 denotes the frame +of the current breakpoint, that is to say the top of the call stack. + +@end table + +@noindent +The above list is a very short introduction to the commands that +@code{GDB} provides. Important additional capabilities, including conditional +breakpoints, the ability to execute command sequences on a breakpoint, +the ability to debug at the machine instruction level and many other +features are described in detail in @ref{Top,, Debugging with GDB, gdb, +Debugging with GDB}. Note that most commands can be abbreviated +(for example, c for continue, bt for backtrace). + +@node Using Ada Expressions +@section Using Ada Expressions +@cindex Ada expressions + +@noindent +@code{GDB} supports a fairly large subset of Ada expression syntax, with some +extensions. The philosophy behind the design of this subset is + +@itemize @bullet +@item +That @code{GDB} should provide basic literals and access to operations for +arithmetic, dereferencing, field selection, indexing, and subprogram calls, +leaving more sophisticated computations to subprograms written into the +program (which therefore may be called from @code{GDB}). + +@item +That type safety and strict adherence to Ada language restrictions +are not particularly important to the @code{GDB} user. + +@item +That brevity is important to the @code{GDB} user. +@end itemize + +@noindent +Thus, for brevity, the debugger acts as if there were +implicit @code{with} and @code{use} clauses in effect for all user-written +packages, thus making it unnecessary to fully qualify most names with +their packages, regardless of context. Where this causes ambiguity, +@code{GDB} asks the user's intent. + +For details on the supported Ada syntax, see @ref{Top,, Debugging with +GDB, gdb, Debugging with GDB}. + +@node Calling User-Defined Subprograms +@section Calling User-Defined Subprograms + +@noindent +An important capability of @code{GDB} is the ability to call user-defined +subprograms while debugging. This is achieved simply by entering +a subprogram call statement in the form: + +@smallexample +call subprogram-name (parameters) +@end smallexample + +@noindent +The keyword @code{call} can be omitted in the normal case where the +@code{subprogram-name} does not coincide with any of the predefined +@code{GDB} commands. + +The effect is to invoke the given subprogram, passing it the +list of parameters that is supplied. The parameters can be expressions and +can include variables from the program being debugged. The +subprogram must be defined +at the library level within your program, and @code{GDB} will call the +subprogram within the environment of your program execution (which +means that the subprogram is free to access or even modify variables +within your program). + +The most important use of this facility is in allowing the inclusion of +debugging routines that are tailored to particular data structures +in your program. Such debugging routines can be written to provide a suitably +high-level description of an abstract type, rather than a low-level dump +of its physical layout. After all, the standard +@code{GDB print} command only knows the physical layout of your +types, not their abstract meaning. Debugging routines can provide information +at the desired semantic level and are thus enormously useful. + +For example, when debugging GNAT itself, it is crucial to have access to +the contents of the tree nodes used to represent the program internally. +But tree nodes are represented simply by an integer value (which in turn +is an index into a table of nodes). +Using the @code{print} command on a tree node would simply print this integer +value, which is not very useful. But the PN routine (defined in file +treepr.adb in the GNAT sources) takes a tree node as input, and displays +a useful high level representation of the tree node, which includes the +syntactic category of the node, its position in the source, the integers +that denote descendant nodes and parent node, as well as varied +semantic information. To study this example in more detail, you might want to +look at the body of the PN procedure in the stated file. + +@node Using the Next Command in a Function +@section Using the Next Command in a Function + +@noindent +When you use the @code{next} command in a function, the current source +location will advance to the next statement as usual. A special case +arises in the case of a @code{return} statement. + +Part of the code for a return statement is the ``epilog'' of the function. +This is the code that returns to the caller. There is only one copy of +this epilog code, and it is typically associated with the last return +statement in the function if there is more than one return. In some +implementations, this epilog is associated with the first statement +of the function. + +The result is that if you use the @code{next} command from a return +statement that is not the last return statement of the function you +may see a strange apparent jump to the last return statement or to +the start of the function. You should simply ignore this odd jump. +The value returned is always that from the first return statement +that was stepped through. + +@node Ada Exceptions +@section Stopping when Ada Exceptions are Raised +@cindex Exceptions + +@noindent +You can set catchpoints that stop the program execution when your program +raises selected exceptions. + +@table @code +@item catch exception +Set a catchpoint that stops execution whenever (any task in the) program +raises any exception. + +@item catch exception @var{name} +Set a catchpoint that stops execution whenever (any task in the) program +raises the exception @var{name}. + +@item catch exception unhandled +Set a catchpoint that stops executing whenever (any task in the) program +raises an exception for which there is no handler. + +@item info exceptions +@itemx info exceptions @var{regexp} +The @code{info exceptions} command permits the user to examine all defined +exceptions within Ada programs. With a regular expression, @var{regexp}, as +argument, prints out only those exceptions whose name matches @var{regexp}. +@end table + +@node Ada Tasks +@section Ada Tasks +@cindex Tasks + +@noindent +@code{GDB} allows the following task-related commands: + +@table @code +@item info tasks +This command shows a list of current Ada tasks, as in the following example: + +@smallexample +@iftex +@leftskip=0cm +@end iftex +(gdb) info tasks + ID TID P-ID Thread Pri State Name + 1 8088000 0 807e000 15 Child Activation Wait main_task + 2 80a4000 1 80ae000 15 Accept/Select Wait b + 3 809a800 1 80a4800 15 Child Activation Wait a +* 4 80ae800 3 80b8000 15 Running c +@end smallexample + +@noindent +In this listing, the asterisk before the first task indicates it to be the +currently running task. The first column lists the task ID that is used +to refer to tasks in the following commands. + +@item break @var{linespec} task @var{taskid} +@itemx break @var{linespec} task @var{taskid} if @dots{} +@cindex Breakpoints and tasks +These commands are like the @code{break @dots{} thread @dots{}}. +@var{linespec} specifies source lines. + +Use the qualifier @samp{task @var{taskid}} with a breakpoint command +to specify that you only want @code{GDB} to stop the program when a +particular Ada task reaches this breakpoint. @var{taskid} is one of the +numeric task identifiers assigned by @code{GDB}, shown in the first +column of the @samp{info tasks} display. + +If you do not specify @samp{task @var{taskid}} when you set a +breakpoint, the breakpoint applies to @emph{all} tasks of your +program. + +You can use the @code{task} qualifier on conditional breakpoints as +well; in this case, place @samp{task @var{taskid}} before the +breakpoint condition (before the @code{if}). + +@item task @var{taskno} +@cindex Task switching + +This command allows to switch to the task referred by @var{taskno}. In +particular, This allows to browse the backtrace of the specified +task. It is advised to switch back to the original task before +continuing execution otherwise the scheduling of the program may be +perturbed. +@end table + +@noindent +For more detailed information on the tasking support, +see @ref{Top,, Debugging with GDB, gdb, Debugging with GDB}. + +@node Debugging Generic Units +@section Debugging Generic Units +@cindex Debugging Generic Units +@cindex Generics + +@noindent +GNAT always uses code expansion for generic instantiation. This means that +each time an instantiation occurs, a complete copy of the original code is +made, with appropriate substitutions of formals by actuals. + +It is not possible to refer to the original generic entities in +@code{GDB}, but it is always possible to debug a particular instance of +a generic, by using the appropriate expanded names. For example, if we have + +@smallexample @c ada +@group +@cartouche +procedure g is + + generic package k is + procedure kp (v1 : in out integer); + end k; + + package body k is + procedure kp (v1 : in out integer) is + begin + v1 := v1 + 1; + end kp; + end k; + + package k1 is new k; + package k2 is new k; + + var : integer := 1; + +begin + k1.kp (var); + k2.kp (var); + k1.kp (var); + k2.kp (var); +end; +@end cartouche +@end group +@end smallexample + +@noindent +Then to break on a call to procedure kp in the k2 instance, simply +use the command: + +@smallexample +(gdb) break g.k2.kp +@end smallexample + +@noindent +When the breakpoint occurs, you can step through the code of the +instance in the normal manner and examine the values of local variables, as for +other units. + +@node Remote Debugging using gdbserver +@section Remote Debugging using gdbserver +@cindex Remote Debugging using gdbserver + +@noindent +On platforms where gdbserver is supported, it is possible to use this tool +to debug your application remotely. This can be useful in situations +where the program needs to be run on a target host that is different +from the host used for development, particularly when the target has +a limited amount of resources (either CPU and/or memory). + +To do so, start your program using gdbserver on the target machine. +gdbserver then automatically suspends the execution of your program +at its entry point, waiting for a debugger to connect to it. The +following commands starts an application and tells gdbserver to +wait for a connection with the debugger on localhost port 4444. + +@smallexample +$ gdbserver localhost:4444 program +Process program created; pid = 5685 +Listening on port 4444 +@end smallexample + +Once gdbserver has started listening, we can tell the debugger to establish +a connection with this gdbserver, and then start the same debugging session +as if the program was being debugged on the same host, directly under +the control of GDB. + +@smallexample +$ gdb program +(gdb) target remote targethost:4444 +Remote debugging using targethost:4444 +0x00007f29936d0af0 in ?? () from /lib64/ld-linux-x86-64.so. +(gdb) b foo.adb:3 +Breakpoint 1 at 0x401f0c: file foo.adb, line 3. +(gdb) continue +Continuing. + +Breakpoint 1, foo () at foo.adb:4 +4 end foo; +@end smallexample + +It is also possible to use gdbserver to attach to an already running +program, in which case the execution of that program is simply suspended +until the connection between the debugger and gdbserver is established. + +For more information on how to use gdbserver, @ref{Top, Server, Using +the gdbserver Program, gdb, Debugging with GDB}. GNAT Pro provides support +for gdbserver on x86-linux, x86-windows and x86_64-linux. + +@node GNAT Abnormal Termination or Failure to Terminate +@section GNAT Abnormal Termination or Failure to Terminate +@cindex GNAT Abnormal Termination or Failure to Terminate + +@noindent +When presented with programs that contain serious errors in syntax +or semantics, +GNAT may on rare occasions experience problems in operation, such +as aborting with a +segmentation fault or illegal memory access, raising an internal +exception, terminating abnormally, or failing to terminate at all. +In such cases, you can activate +various features of GNAT that can help you pinpoint the construct in your +program that is the likely source of the problem. + +The following strategies are presented in increasing order of +difficulty, corresponding to your experience in using GNAT and your +familiarity with compiler internals. + +@enumerate +@item +Run @command{gcc} with the @option{-gnatf}. This first +switch causes all errors on a given line to be reported. In its absence, +only the first error on a line is displayed. + +The @option{-gnatdO} switch causes errors to be displayed as soon as they +are encountered, rather than after compilation is terminated. If GNAT +terminates prematurely or goes into an infinite loop, the last error +message displayed may help to pinpoint the culprit. + +@item +Run @command{gcc} with the @option{^-v (verbose)^/VERBOSE^} switch. In this +mode, @command{gcc} produces ongoing information about the progress of the +compilation and provides the name of each procedure as code is +generated. This switch allows you to find which Ada procedure was being +compiled when it encountered a code generation problem. + +@item +@cindex @option{-gnatdc} switch +Run @command{gcc} with the @option{-gnatdc} switch. This is a GNAT specific +switch that does for the front-end what @option{^-v^VERBOSE^} does +for the back end. The system prints the name of each unit, +either a compilation unit or nested unit, as it is being analyzed. +@item +Finally, you can start +@code{gdb} directly on the @code{gnat1} executable. @code{gnat1} is the +front-end of GNAT, and can be run independently (normally it is just +called from @command{gcc}). You can use @code{gdb} on @code{gnat1} as you +would on a C program (but @pxref{The GNAT Debugger GDB} for caveats). The +@code{where} command is the first line of attack; the variable +@code{lineno} (seen by @code{print lineno}), used by the second phase of +@code{gnat1} and by the @command{gcc} backend, indicates the source line at +which the execution stopped, and @code{input_file name} indicates the name of +the source file. +@end enumerate + +@node Naming Conventions for GNAT Source Files +@section Naming Conventions for GNAT Source Files + +@noindent +In order to examine the workings of the GNAT system, the following +brief description of its organization may be helpful: + +@itemize @bullet +@item +Files with prefix @file{^sc^SC^} contain the lexical scanner. + +@item +All files prefixed with @file{^par^PAR^} are components of the parser. The +numbers correspond to chapters of the Ada Reference Manual. For example, +parsing of select statements can be found in @file{par-ch9.adb}. + +@item +All files prefixed with @file{^sem^SEM^} perform semantic analysis. The +numbers correspond to chapters of the Ada standard. For example, all +issues involving context clauses can be found in @file{sem_ch10.adb}. In +addition, some features of the language require sufficient special processing +to justify their own semantic files: sem_aggr for aggregates, sem_disp for +dynamic dispatching, etc. + +@item +All files prefixed with @file{^exp^EXP^} perform normalization and +expansion of the intermediate representation (abstract syntax tree, or AST). +these files use the same numbering scheme as the parser and semantics files. +For example, the construction of record initialization procedures is done in +@file{exp_ch3.adb}. + +@item +The files prefixed with @file{^bind^BIND^} implement the binder, which +verifies the consistency of the compilation, determines an order of +elaboration, and generates the bind file. + +@item +The files @file{atree.ads} and @file{atree.adb} detail the low-level +data structures used by the front-end. + +@item +The files @file{sinfo.ads} and @file{sinfo.adb} detail the structure of +the abstract syntax tree as produced by the parser. + +@item +The files @file{einfo.ads} and @file{einfo.adb} detail the attributes of +all entities, computed during semantic analysis. + +@item +Library management issues are dealt with in files with prefix +@file{^lib^LIB^}. + +@item +@findex Ada +@cindex Annex A +Ada files with the prefix @file{^a-^A-^} are children of @code{Ada}, as +defined in Annex A. + +@item +@findex Interfaces +@cindex Annex B +Files with prefix @file{^i-^I-^} are children of @code{Interfaces}, as +defined in Annex B. + +@item +@findex System +Files with prefix @file{^s-^S-^} are children of @code{System}. This includes +both language-defined children and GNAT run-time routines. + +@item +@findex GNAT +Files with prefix @file{^g-^G-^} are children of @code{GNAT}. These are useful +general-purpose packages, fully documented in their specs. All +the other @file{.c} files are modifications of common @command{gcc} files. +@end itemize + +@node Getting Internal Debugging Information +@section Getting Internal Debugging Information + +@noindent +Most compilers have internal debugging switches and modes. GNAT +does also, except GNAT internal debugging switches and modes are not +secret. A summary and full description of all the compiler and binder +debug flags are in the file @file{debug.adb}. You must obtain the +sources of the compiler to see the full detailed effects of these flags. + +The switches that print the source of the program (reconstructed from +the internal tree) are of general interest for user programs, as are the +options to print +the full internal tree, and the entity table (the symbol table +information). The reconstructed source provides a readable version of the +program after the front-end has completed analysis and expansion, +and is useful when studying the performance of specific constructs. +For example, constraint checks are indicated, complex aggregates +are replaced with loops and assignments, and tasking primitives +are replaced with run-time calls. + +@node Stack Traceback +@section Stack Traceback +@cindex traceback +@cindex stack traceback +@cindex stack unwinding + +@noindent +Traceback is a mechanism to display the sequence of subprogram calls that +leads to a specified execution point in a program. Often (but not always) +the execution point is an instruction at which an exception has been raised. +This mechanism is also known as @i{stack unwinding} because it obtains +its information by scanning the run-time stack and recovering the activation +records of all active subprograms. Stack unwinding is one of the most +important tools for program debugging. + +The first entry stored in traceback corresponds to the deepest calling level, +that is to say the subprogram currently executing the instruction +from which we want to obtain the traceback. + +Note that there is no runtime performance penalty when stack traceback +is enabled, and no exception is raised during program execution. + +@menu +* Non-Symbolic Traceback:: +* Symbolic Traceback:: +@end menu + +@node Non-Symbolic Traceback +@subsection Non-Symbolic Traceback +@cindex traceback, non-symbolic + +@noindent +Note: this feature is not supported on all platforms. See +@file{GNAT.Traceback spec in g-traceb.ads} for a complete list of supported +platforms. + +@menu +* Tracebacks From an Unhandled Exception:: +* Tracebacks From Exception Occurrences (non-symbolic):: +* Tracebacks From Anywhere in a Program (non-symbolic):: +@end menu + +@node Tracebacks From an Unhandled Exception +@subsubsection Tracebacks From an Unhandled Exception + +@noindent +A runtime non-symbolic traceback is a list of addresses of call instructions. +To enable this feature you must use the @option{-E} +@code{gnatbind}'s option. With this option a stack traceback is stored as part +of exception information. You can retrieve this information using the +@code{addr2line} tool. + +Here is a simple example: + +@smallexample @c ada +@cartouche +procedure STB is + + procedure P1 is + begin + raise Constraint_Error; + end P1; + + procedure P2 is + begin + P1; + end P2; + +begin + P2; +end STB; +@end cartouche +@end smallexample + +@smallexample +$ gnatmake stb -bargs -E +$ stb + +Execution terminated by unhandled exception +Exception name: CONSTRAINT_ERROR +Message: stb.adb:5 +Call stack traceback locations: +0x401373 0x40138b 0x40139c 0x401335 0x4011c4 0x4011f1 0x77e892a4 +@end smallexample + +@noindent +As we see the traceback lists a sequence of addresses for the unhandled +exception @code{CONSTRAINT_ERROR} raised in procedure P1. It is easy to +guess that this exception come from procedure P1. To translate these +addresses into the source lines where the calls appear, the +@code{addr2line} tool, described below, is invaluable. The use of this tool +requires the program to be compiled with debug information. + +@smallexample +$ gnatmake -g stb -bargs -E +$ stb + +Execution terminated by unhandled exception +Exception name: CONSTRAINT_ERROR +Message: stb.adb:5 +Call stack traceback locations: +0x401373 0x40138b 0x40139c 0x401335 0x4011c4 0x4011f1 0x77e892a4 + +$ addr2line --exe=stb 0x401373 0x40138b 0x40139c 0x401335 0x4011c4 + 0x4011f1 0x77e892a4 + +00401373 at d:/stb/stb.adb:5 +0040138B at d:/stb/stb.adb:10 +0040139C at d:/stb/stb.adb:14 +00401335 at d:/stb/b~stb.adb:104 +004011C4 at /build/@dots{}/crt1.c:200 +004011F1 at /build/@dots{}/crt1.c:222 +77E892A4 in ?? at ??:0 +@end smallexample + +@noindent +The @code{addr2line} tool has several other useful options: + +@table @code +@item --functions +to get the function name corresponding to any location + +@item --demangle=gnat +to use the gnat decoding mode for the function names. Note that +for binutils version 2.9.x the option is simply @option{--demangle}. +@end table + +@smallexample +$ addr2line --exe=stb --functions --demangle=gnat 0x401373 0x40138b + 0x40139c 0x401335 0x4011c4 0x4011f1 + +00401373 in stb.p1 at d:/stb/stb.adb:5 +0040138B in stb.p2 at d:/stb/stb.adb:10 +0040139C in stb at d:/stb/stb.adb:14 +00401335 in main at d:/stb/b~stb.adb:104 +004011C4 in <__mingw_CRTStartup> at /build/@dots{}/crt1.c:200 +004011F1 in at /build/@dots{}/crt1.c:222 +@end smallexample + +@noindent +From this traceback we can see that the exception was raised in +@file{stb.adb} at line 5, which was reached from a procedure call in +@file{stb.adb} at line 10, and so on. The @file{b~std.adb} is the binder file, +which contains the call to the main program. +@xref{Running gnatbind}. The remaining entries are assorted runtime routines, +and the output will vary from platform to platform. + +It is also possible to use @code{GDB} with these traceback addresses to debug +the program. For example, we can break at a given code location, as reported +in the stack traceback: + +@smallexample +$ gdb -nw stb +@ifclear vms +@noindent +Furthermore, this feature is not implemented inside Windows DLL. Only +the non-symbolic traceback is reported in this case. +@end ifclear + +(gdb) break *0x401373 +Breakpoint 1 at 0x401373: file stb.adb, line 5. +@end smallexample + +@noindent +It is important to note that the stack traceback addresses +do not change when debug information is included. This is particularly useful +because it makes it possible to release software without debug information (to +minimize object size), get a field report that includes a stack traceback +whenever an internal bug occurs, and then be able to retrieve the sequence +of calls with the same program compiled with debug information. + +@node Tracebacks From Exception Occurrences (non-symbolic) +@subsubsection Tracebacks From Exception Occurrences + +@noindent +Non-symbolic tracebacks are obtained by using the @option{-E} binder argument. +The stack traceback is attached to the exception information string, and can +be retrieved in an exception handler within the Ada program, by means of the +Ada facilities defined in @code{Ada.Exceptions}. Here is a simple example: + +@smallexample @c ada +with Ada.Text_IO; +with Ada.Exceptions; + +procedure STB is + + use Ada; + use Ada.Exceptions; + + procedure P1 is + K : Positive := 1; + begin + K := K - 1; + exception + when E : others => + Text_IO.Put_Line (Exception_Information (E)); + end P1; + + procedure P2 is + begin + P1; + end P2; + +begin + P2; +end STB; +@end smallexample + +@noindent +This program will output: + +@smallexample +$ stb + +Exception name: CONSTRAINT_ERROR +Message: stb.adb:12 +Call stack traceback locations: +0x4015e4 0x401633 0x401644 0x401461 0x4011c4 0x4011f1 0x77e892a4 +@end smallexample + +@node Tracebacks From Anywhere in a Program (non-symbolic) +@subsubsection Tracebacks From Anywhere in a Program + +@noindent +It is also possible to retrieve a stack traceback from anywhere in a +program. For this you need to +use the @code{GNAT.Traceback} API. This package includes a procedure called +@code{Call_Chain} that computes a complete stack traceback, as well as useful +display procedures described below. It is not necessary to use the +@option{-E gnatbind} option in this case, because the stack traceback mechanism +is invoked explicitly. + +@noindent +In the following example we compute a traceback at a specific location in +the program, and we display it using @code{GNAT.Debug_Utilities.Image} to +convert addresses to strings: + +@smallexample @c ada +with Ada.Text_IO; +with GNAT.Traceback; +with GNAT.Debug_Utilities; + +procedure STB is + + use Ada; + use GNAT; + use GNAT.Traceback; + + procedure P1 is + TB : Tracebacks_Array (1 .. 10); + -- We are asking for a maximum of 10 stack frames. + Len : Natural; + -- Len will receive the actual number of stack frames returned. + begin + Call_Chain (TB, Len); + + Text_IO.Put ("In STB.P1 : "); + + for K in 1 .. Len loop + Text_IO.Put (Debug_Utilities.Image (TB (K))); + Text_IO.Put (' '); + end loop; + + Text_IO.New_Line; + end P1; + + procedure P2 is + begin + P1; + end P2; + +begin + P2; +end STB; +@end smallexample + +@smallexample +$ gnatmake -g stb +$ stb + +In STB.P1 : 16#0040_F1E4# 16#0040_14F2# 16#0040_170B# 16#0040_171C# +16#0040_1461# 16#0040_11C4# 16#0040_11F1# 16#77E8_92A4# +@end smallexample + +@noindent +You can then get further information by invoking the @code{addr2line} +tool as described earlier (note that the hexadecimal addresses +need to be specified in C format, with a leading ``0x''). + +@node Symbolic Traceback +@subsection Symbolic Traceback +@cindex traceback, symbolic + +@noindent +A symbolic traceback is a stack traceback in which procedure names are +associated with each code location. + +@noindent +Note that this feature is not supported on all platforms. See +@file{GNAT.Traceback.Symbolic spec in g-trasym.ads} for a complete +list of currently supported platforms. + +@noindent +Note that the symbolic traceback requires that the program be compiled +with debug information. If it is not compiled with debug information +only the non-symbolic information will be valid. + +@menu +* Tracebacks From Exception Occurrences (symbolic):: +* Tracebacks From Anywhere in a Program (symbolic):: +@end menu + +@node Tracebacks From Exception Occurrences (symbolic) +@subsubsection Tracebacks From Exception Occurrences + +@smallexample @c ada +with Ada.Text_IO; +with GNAT.Traceback.Symbolic; + +procedure STB is + + procedure P1 is + begin + raise Constraint_Error; + end P1; + + procedure P2 is + begin + P1; + end P2; + + procedure P3 is + begin + P2; + end P3; + +begin + P3; +exception + when E : others => + Ada.Text_IO.Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E)); +end STB; +@end smallexample + +@smallexample +$ gnatmake -g .\stb -bargs -E -largs -lgnat -laddr2line -lintl +$ stb + +0040149F in stb.p1 at stb.adb:8 +004014B7 in stb.p2 at stb.adb:13 +004014CF in stb.p3 at stb.adb:18 +004015DD in ada.stb at stb.adb:22 +00401461 in main at b~stb.adb:168 +004011C4 in __mingw_CRTStartup at crt1.c:200 +004011F1 in mainCRTStartup at crt1.c:222 +77E892A4 in ?? at ??:0 +@end smallexample + +@noindent +In the above example the ``.\'' syntax in the @command{gnatmake} command +is currently required by @command{addr2line} for files that are in +the current working directory. +Moreover, the exact sequence of linker options may vary from platform +to platform. +The above @option{-largs} section is for Windows platforms. By contrast, +under Unix there is no need for the @option{-largs} section. +Differences across platforms are due to details of linker implementation. + +@node Tracebacks From Anywhere in a Program (symbolic) +@subsubsection Tracebacks From Anywhere in a Program + +@noindent +It is possible to get a symbolic stack traceback +from anywhere in a program, just as for non-symbolic tracebacks. +The first step is to obtain a non-symbolic +traceback, and then call @code{Symbolic_Traceback} to compute the symbolic +information. Here is an example: + +@smallexample @c ada +with Ada.Text_IO; +with GNAT.Traceback; +with GNAT.Traceback.Symbolic; + +procedure STB is + + use Ada; + use GNAT.Traceback; + use GNAT.Traceback.Symbolic; + + procedure P1 is + TB : Tracebacks_Array (1 .. 10); + -- We are asking for a maximum of 10 stack frames. + Len : Natural; + -- Len will receive the actual number of stack frames returned. + begin + Call_Chain (TB, Len); + Text_IO.Put_Line (Symbolic_Traceback (TB (1 .. Len))); + end P1; + + procedure P2 is + begin + P1; + end P2; + +begin + P2; +end STB; +@end smallexample + +@c ****************************** +@ifset vms +@node Compatibility with HP Ada +@chapter Compatibility with HP Ada +@cindex Compatibility + +@noindent +@cindex DEC Ada +@cindex HP Ada +@cindex Compatibility between GNAT and HP Ada +This chapter compares HP Ada (formerly known as ``DEC Ada'') +for OpenVMS Alpha and GNAT for OpenVMS for Alpha and for I64. +GNAT is highly compatible +with HP Ada, and it should generally be straightforward to port code +from the HP Ada environment to GNAT. However, there are a few language +and implementation differences of which the user must be aware. These +differences are discussed in this chapter. In +addition, the operating environment and command structure for the +compiler are different, and these differences are also discussed. + +For further details on these and other compatibility issues, +see Appendix E of the HP publication +@cite{HP Ada, Technical Overview and Comparison on HP Platforms}. + +Except where otherwise indicated, the description of GNAT for OpenVMS +applies to both the Alpha and I64 platforms. + +For information on porting Ada code from GNAT on Alpha OpenVMS to GNAT on +I64 OpenVMS, see @ref{Transitioning to 64-Bit GNAT for OpenVMS}. + +The discussion in this chapter addresses specifically the implementation +of Ada 83 for HP OpenVMS Alpha Systems. In cases where the implementation +of HP Ada differs between OpenVMS Alpha Systems and OpenVMS VAX Systems, +GNAT always follows the Alpha implementation. + +For GNAT running on other than VMS systems, all the HP Ada 83 pragmas and +attributes are recognized, although only a subset of them can sensibly +be implemented. The description of pragmas in +@xref{Implementation Defined Pragmas,,, gnat_rm, GNAT Reference Manual}, +indicates whether or not they are applicable to non-VMS systems. + +@menu +* Ada Language Compatibility:: +* Differences in the Definition of Package System:: +* Language-Related Features:: +* The Package STANDARD:: +* The Package SYSTEM:: +* Tasking and Task-Related Features:: +* Pragmas and Pragma-Related Features:: +* Library of Predefined Units:: +* Bindings:: +* Main Program Definition:: +* Implementation-Defined Attributes:: +* Compiler and Run-Time Interfacing:: +* Program Compilation and Library Management:: +* Input-Output:: +* Implementation Limits:: +* Tools and Utilities:: +@end menu + +@node Ada Language Compatibility +@section Ada Language Compatibility + +@noindent +GNAT handles Ada 95 and Ada 2005 as well as Ada 83, whereas HP Ada is only +for Ada 83. Ada 95 and Ada 2005 are almost completely upwards compatible +with Ada 83, and therefore Ada 83 programs will compile +and run under GNAT with +no changes or only minor changes. The @cite{Annotated Ada Reference Manual} +provides details on specific incompatibilities. + +GNAT provides the switch @option{/83} on the @command{GNAT COMPILE} command, +as well as the pragma @code{ADA_83}, to force the compiler to +operate in Ada 83 mode. This mode does not guarantee complete +conformance to Ada 83, but in practice is sufficient to +eliminate most sources of incompatibilities. +In particular, it eliminates the recognition of the +additional Ada 95 and Ada 2005 keywords, so that their use as identifiers +in Ada 83 programs is legal, and handles the cases of packages +with optional bodies, and generics that instantiate unconstrained +types without the use of @code{(<>)}. + +@node Differences in the Definition of Package System +@section Differences in the Definition of Package @code{System} + +@noindent +An Ada compiler is allowed to add +implementation-dependent declarations to package @code{System}. +In normal mode, +GNAT does not take advantage of this permission, and the version of +@code{System} provided by GNAT exactly matches that defined in the Ada +Reference Manual. + +However, HP Ada adds an extensive set of declarations to package +@code{System}, +as fully documented in the HP Ada manuals. To minimize changes required +for programs that make use of these extensions, GNAT provides the pragma +@code{Extend_System} for extending the definition of package System. By using: +@cindex pragma @code{Extend_System} +@cindex @code{Extend_System} pragma + +@smallexample @c ada +@group +@cartouche +pragma Extend_System (Aux_DEC); +@end cartouche +@end group +@end smallexample + +@noindent +the set of definitions in @code{System} is extended to include those in +package @code{System.Aux_DEC}. +@cindex @code{System.Aux_DEC} package +@cindex @code{Aux_DEC} package (child of @code{System}) +These definitions are incorporated directly into package @code{System}, +as though they had been declared there. For a +list of the declarations added, see the spec of this package, +which can be found in the file @file{s-auxdec.ads} in the GNAT library. +@cindex @file{s-auxdec.ads} file +The pragma @code{Extend_System} is a configuration pragma, which means that +it can be placed in the file @file{gnat.adc}, so that it will automatically +apply to all subsequent compilations. See @ref{Configuration Pragmas}, +for further details. + +An alternative approach that avoids the use of the non-standard +@code{Extend_System} pragma is to add a context clause to the unit that +references these facilities: + +@smallexample @c ada +@cartouche +with System.Aux_DEC; +use System.Aux_DEC; +@end cartouche +@end smallexample + +@noindent +The effect is not quite semantically identical to incorporating +the declarations directly into package @code{System}, +but most programs will not notice a difference +unless they use prefix notation (e.g.@: @code{System.Integer_8}) +to reference the entities directly in package @code{System}. +For units containing such references, +the prefixes must either be removed, or the pragma @code{Extend_System} +must be used. + +@node Language-Related Features +@section Language-Related Features + +@noindent +The following sections highlight differences in types, +representations of types, operations, alignment, and +related topics. + +@menu +* Integer Types and Representations:: +* Floating-Point Types and Representations:: +* Pragmas Float_Representation and Long_Float:: +* Fixed-Point Types and Representations:: +* Record and Array Component Alignment:: +* Address Clauses:: +* Other Representation Clauses:: +@end menu + +@node Integer Types and Representations +@subsection Integer Types and Representations + +@noindent +The set of predefined integer types is identical in HP Ada and GNAT. +Furthermore the representation of these integer types is also identical, +including the capability of size clauses forcing biased representation. + +In addition, +HP Ada for OpenVMS Alpha systems has defined the +following additional integer types in package @code{System}: + +@itemize @bullet + +@item +@code{INTEGER_8} + +@item +@code{INTEGER_16} + +@item +@code{INTEGER_32} + +@item +@code{INTEGER_64} + +@item +@code{LARGEST_INTEGER} +@end itemize + +@noindent +In GNAT, the first four of these types may be obtained from the +standard Ada package @code{Interfaces}. +Alternatively, by use of the pragma @code{Extend_System}, identical +declarations can be referenced directly in package @code{System}. +On both GNAT and HP Ada, the maximum integer size is 64 bits. + +@node Floating-Point Types and Representations +@subsection Floating-Point Types and Representations +@cindex Floating-Point types + +@noindent +The set of predefined floating-point types is identical in HP Ada and GNAT. +Furthermore the representation of these floating-point +types is also identical. One important difference is that the default +representation for HP Ada is @code{VAX_Float}, but the default representation +for GNAT is IEEE. + +Specific types may be declared to be @code{VAX_Float} or IEEE, using the +pragma @code{Float_Representation} as described in the HP Ada +documentation. +For example, the declarations: + +@smallexample @c ada +@cartouche +type F_Float is digits 6; +pragma Float_Representation (VAX_Float, F_Float); +@end cartouche +@end smallexample + +@noindent +declares a type @code{F_Float} that will be represented in @code{VAX_Float} +format. +This set of declarations actually appears in @code{System.Aux_DEC}, +which contains +the full set of additional floating-point declarations provided in +the HP Ada version of package @code{System}. +This and similar declarations may be accessed in a user program +by using pragma @code{Extend_System}. The use of this +pragma, and the related pragma @code{Long_Float} is described in further +detail in the following section. + +@node Pragmas Float_Representation and Long_Float +@subsection Pragmas @code{Float_Representation} and @code{Long_Float} + +@noindent +HP Ada provides the pragma @code{Float_Representation}, which +acts as a program library switch to allow control over +the internal representation chosen for the predefined +floating-point types declared in the package @code{Standard}. +The format of this pragma is as follows: + +@smallexample @c ada +@cartouche +pragma Float_Representation(VAX_Float | IEEE_Float); +@end cartouche +@end smallexample + +@noindent +This pragma controls the representation of floating-point +types as follows: + +@itemize @bullet +@item +@code{VAX_Float} specifies that floating-point +types are represented by default with the VAX system hardware types +@code{F-floating}, @code{D-floating}, @code{G-floating}. +Note that the @code{H-floating} +type was available only on VAX systems, and is not available +in either HP Ada or GNAT. + +@item +@code{IEEE_Float} specifies that floating-point +types are represented by default with the IEEE single and +double floating-point types. +@end itemize + +@noindent +GNAT provides an identical implementation of the pragma +@code{Float_Representation}, except that it functions as a +configuration pragma. Note that the +notion of configuration pragma corresponds closely to the +HP Ada notion of a program library switch. + +When no pragma is used in GNAT, the default is @code{IEEE_Float}, +which is different +from HP Ada 83, where the default is @code{VAX_Float}. In addition, the +predefined libraries in GNAT are built using @code{IEEE_Float}, so it is not +advisable to change the format of numbers passed to standard library +routines, and if necessary explicit type conversions may be needed. + +The use of @code{IEEE_Float} is recommended in GNAT since it is more +efficient, and (given that it conforms to an international standard) +potentially more portable. +The situation in which @code{VAX_Float} may be useful is in interfacing +to existing code and data that expect the use of @code{VAX_Float}. +In such a situation use the predefined @code{VAX_Float} +types in package @code{System}, as extended by +@code{Extend_System}. For example, use @code{System.F_Float} +to specify the 32-bit @code{F-Float} format. + +@noindent +On OpenVMS systems, HP Ada provides the pragma @code{Long_Float} +to allow control over the internal representation chosen +for the predefined type @code{Long_Float} and for floating-point +type declarations with digits specified in the range 7 .. 15. +The format of this pragma is as follows: + +@smallexample @c ada +@cartouche +pragma Long_Float (D_FLOAT | G_FLOAT); +@end cartouche +@end smallexample + +@node Fixed-Point Types and Representations +@subsection Fixed-Point Types and Representations + +@noindent +On HP Ada for OpenVMS Alpha systems, rounding is +away from zero for both positive and negative numbers. +Therefore, @code{+0.5} rounds to @code{1}, +and @code{-0.5} rounds to @code{-1}. + +On GNAT the results of operations +on fixed-point types are in accordance with the Ada +rules. In particular, results of operations on decimal +fixed-point types are truncated. + +@node Record and Array Component Alignment +@subsection Record and Array Component Alignment + +@noindent +On HP Ada for OpenVMS Alpha, all non-composite components +are aligned on natural boundaries. For example, 1-byte +components are aligned on byte boundaries, 2-byte +components on 2-byte boundaries, 4-byte components on 4-byte +byte boundaries, and so on. The OpenVMS Alpha hardware +runs more efficiently with naturally aligned data. + +On GNAT, alignment rules are compatible +with HP Ada for OpenVMS Alpha. + +@node Address Clauses +@subsection Address Clauses + +@noindent +In HP Ada and GNAT, address clauses are supported for +objects and imported subprograms. +The predefined type @code{System.Address} is a private type +in both compilers on Alpha OpenVMS, with the same representation +(it is simply a machine pointer). Addition, subtraction, and comparison +operations are available in the standard Ada package +@code{System.Storage_Elements}, or in package @code{System} +if it is extended to include @code{System.Aux_DEC} using a +pragma @code{Extend_System} as previously described. + +Note that code that @code{with}'s both this extended package @code{System} +and the package @code{System.Storage_Elements} should not @code{use} +both packages, or ambiguities will result. In general it is better +not to mix these two sets of facilities. The Ada package was +designed specifically to provide the kind of features that HP Ada +adds directly to package @code{System}. + +The type @code{System.Address} is a 64-bit integer type in GNAT for +I64 OpenVMS. For more information, +see @ref{Transitioning to 64-Bit GNAT for OpenVMS}. + +GNAT is compatible with HP Ada in its handling of address +clauses, except for some limitations in +the form of address clauses for composite objects with +initialization. Such address clauses are easily replaced +by the use of an explicitly-defined constant as described +in the Ada Reference Manual (13.1(22)). For example, the sequence +of declarations: + +@smallexample @c ada +@cartouche +X, Y : Integer := Init_Func; +Q : String (X .. Y) := "abc"; +@dots{} +for Q'Address use Compute_Address; +@end cartouche +@end smallexample + +@noindent +will be rejected by GNAT, since the address cannot be computed at the time +that @code{Q} is declared. To achieve the intended effect, write instead: + +@smallexample @c ada +@group +@cartouche +X, Y : Integer := Init_Func; +Q_Address : constant Address := Compute_Address; +Q : String (X .. Y) := "abc"; +@dots{} +for Q'Address use Q_Address; +@end cartouche +@end group +@end smallexample + +@noindent +which will be accepted by GNAT (and other Ada compilers), and is also +compatible with Ada 83. A fuller description of the restrictions +on address specifications is found in @ref{Top, GNAT Reference Manual, +About This Guide, gnat_rm, GNAT Reference Manual}. + +@node Other Representation Clauses +@subsection Other Representation Clauses + +@noindent +GNAT implements in a compatible manner all the representation +clauses supported by HP Ada. In addition, GNAT +implements the representation clause forms that were introduced in Ada 95, +including @code{COMPONENT_SIZE} and @code{SIZE} clauses for objects. + +@node The Package STANDARD +@section The Package @code{STANDARD} + +@noindent +The package @code{STANDARD}, as implemented by HP Ada, is fully +described in the @cite{Ada Reference Manual} and in the +@cite{HP Ada Language Reference Manual}. As implemented by GNAT, the +package @code{STANDARD} is described in the @cite{Ada Reference Manual}. + +In addition, HP Ada supports the Latin-1 character set in +the type @code{CHARACTER}. GNAT supports the Latin-1 character set +in the type @code{CHARACTER} and also Unicode (ISO 10646 BMP) in +the type @code{WIDE_CHARACTER}. + +The floating-point types supported by GNAT are those +supported by HP Ada, but the defaults are different, and are controlled by +pragmas. See @ref{Floating-Point Types and Representations}, for details. + +@node The Package SYSTEM +@section The Package @code{SYSTEM} + +@noindent +HP Ada provides a specific version of the package +@code{SYSTEM} for each platform on which the language is implemented. +For the complete spec of the package @code{SYSTEM}, see +Appendix F of the @cite{HP Ada Language Reference Manual}. + +On HP Ada, the package @code{SYSTEM} includes the following conversion +functions: +@itemize @bullet +@item @code{TO_ADDRESS(INTEGER)} + +@item @code{TO_ADDRESS(UNSIGNED_LONGWORD)} + +@item @code{TO_ADDRESS(}@i{universal_integer}@code{)} + +@item @code{TO_INTEGER(ADDRESS)} + +@item @code{TO_UNSIGNED_LONGWORD(ADDRESS)} + +@item Function @code{IMPORT_VALUE return UNSIGNED_LONGWORD} and the +functions @code{IMPORT_ADDRESS} and @code{IMPORT_LARGEST_VALUE} +@end itemize + +@noindent +By default, GNAT supplies a version of @code{SYSTEM} that matches +the definition given in the @cite{Ada Reference Manual}. +This +is a subset of the HP system definitions, which is as +close as possible to the original definitions. The only difference +is that the definition of @code{SYSTEM_NAME} is different: + +@smallexample @c ada +@cartouche +type Name is (SYSTEM_NAME_GNAT); +System_Name : constant Name := SYSTEM_NAME_GNAT; +@end cartouche +@end smallexample + +@noindent +Also, GNAT adds the Ada declarations for +@code{BIT_ORDER} and @code{DEFAULT_BIT_ORDER}. + +However, the use of the following pragma causes GNAT +to extend the definition of package @code{SYSTEM} so that it +encompasses the full set of HP-specific extensions, +including the functions listed above: + +@smallexample @c ada +@cartouche +pragma Extend_System (Aux_DEC); +@end cartouche +@end smallexample + +@noindent +The pragma @code{Extend_System} is a configuration pragma that +is most conveniently placed in the @file{gnat.adc} file. @xref{Pragma +Extend_System,,, gnat_rm, GNAT Reference Manual}, for further details. + +HP Ada does not allow the recompilation of the package +@code{SYSTEM}. Instead HP Ada provides several pragmas +(@code{SYSTEM_NAME}, @code{STORAGE_UNIT}, and @code{MEMORY_SIZE}) +to modify values in the package @code{SYSTEM}. +On OpenVMS Alpha systems, the pragma +@code{SYSTEM_NAME} takes the enumeration literal @code{OPENVMS_AXP} as +its single argument. + +GNAT does permit the recompilation of package @code{SYSTEM} using +the special switch @option{-gnatg}, and this switch can be used if +it is necessary to modify the definitions in @code{SYSTEM}. GNAT does +not permit the specification of @code{SYSTEM_NAME}, @code{STORAGE_UNIT} +or @code{MEMORY_SIZE} by any other means. + +On GNAT systems, the pragma @code{SYSTEM_NAME} takes the +enumeration literal @code{SYSTEM_NAME_GNAT}. + +The definitions provided by the use of + +@smallexample @c ada +pragma Extend_System (AUX_Dec); +@end smallexample + +@noindent +are virtually identical to those provided by the HP Ada 83 package +@code{SYSTEM}. One important difference is that the name of the +@code{TO_ADDRESS} +function for type @code{UNSIGNED_LONGWORD} is changed to +@code{TO_ADDRESS_LONG}. +@xref{Address Clauses,,, gnat_rm, GNAT Reference Manual}, for a +discussion of why this change was necessary. + +@noindent +The version of @code{TO_ADDRESS} taking a @i{universal_integer} argument +is in fact +an extension to Ada 83 not strictly compatible with the reference manual. +GNAT, in order to be exactly compatible with the standard, +does not provide this capability. In HP Ada 83, the +point of this definition is to deal with a call like: + +@smallexample @c ada +TO_ADDRESS (16#12777#); +@end smallexample + +@noindent +Normally, according to Ada 83 semantics, one would expect this to be +ambiguous, since it matches both the @code{INTEGER} and +@code{UNSIGNED_LONGWORD} forms of @code{TO_ADDRESS}. +However, in HP Ada 83, there is no ambiguity, since the +definition using @i{universal_integer} takes precedence. + +In GNAT, since the version with @i{universal_integer} cannot be supplied, +it is +not possible to be 100% compatible. Since there are many programs using +numeric constants for the argument to @code{TO_ADDRESS}, the decision in +GNAT was +to change the name of the function in the @code{UNSIGNED_LONGWORD} case, +so the declarations provided in the GNAT version of @code{AUX_Dec} are: + +@smallexample @c ada +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); +@end smallexample + +@noindent +This means that programs using @code{TO_ADDRESS} for +@code{UNSIGNED_LONGWORD} must change the name to @code{TO_ADDRESS_LONG}. + +@node Tasking and Task-Related Features +@section Tasking and Task-Related Features + +@noindent +This section compares the treatment of tasking in GNAT +and in HP Ada for OpenVMS Alpha. +The GNAT description applies to both Alpha and I64 OpenVMS. +For detailed information on tasking in +HP Ada, see the @cite{HP Ada Language Reference Manual} and the +relevant run-time reference manual. + +@menu +* Implementation of Tasks in HP Ada for OpenVMS Alpha Systems:: +* Assigning Task IDs:: +* Task IDs and Delays:: +* Task-Related Pragmas:: +* Scheduling and Task Priority:: +* The Task Stack:: +* External Interrupts:: +@end menu + +@node Implementation of Tasks in HP Ada for OpenVMS Alpha Systems +@subsection Implementation of Tasks in HP Ada for OpenVMS Alpha Systems + +@noindent +On OpenVMS Alpha systems, each Ada task (except a passive +task) is implemented as a single stream of execution +that is created and managed by the kernel. On these +systems, HP Ada tasking support is based on DECthreads, +an implementation of the POSIX standard for threads. + +Also, on OpenVMS Alpha systems, HP Ada tasks and foreign +code that calls DECthreads routines can be used together. +The interaction between Ada tasks and DECthreads routines +can have some benefits. For example when on OpenVMS Alpha, +HP Ada can call C code that is already threaded. + +GNAT uses the facilities of DECthreads, +and Ada tasks are mapped to threads. + +@node Assigning Task IDs +@subsection Assigning Task IDs + +@noindent +The HP Ada Run-Time Library always assigns @code{%TASK 1} to +the environment task that executes the main program. On +OpenVMS Alpha systems, @code{%TASK 0} is often used for tasks +that have been created but are not yet activated. + +On OpenVMS Alpha systems, task IDs are assigned at +activation. On GNAT systems, task IDs are also assigned at +task creation but do not have the same form or values as +task ID values in HP Ada. There is no null task, and the +environment task does not have a specific task ID value. + +@node Task IDs and Delays +@subsection Task IDs and Delays + +@noindent +On OpenVMS Alpha systems, tasking delays are implemented +using Timer System Services. The Task ID is used for the +identification of the timer request (the @code{REQIDT} parameter). +If Timers are used in the application take care not to use +@code{0} for the identification, because cancelling such a timer +will cancel all timers and may lead to unpredictable results. + +@node Task-Related Pragmas +@subsection Task-Related Pragmas + +@noindent +Ada supplies the pragma @code{TASK_STORAGE}, which allows +specification of the size of the guard area for a task +stack. (The guard area forms an area of memory that has no +read or write access and thus helps in the detection of +stack overflow.) On OpenVMS Alpha systems, if the pragma +@code{TASK_STORAGE} specifies a value of zero, a minimal guard +area is created. In the absence of a pragma @code{TASK_STORAGE}, +a default guard area is created. + +GNAT supplies the following task-related pragmas: + +@itemize @bullet +@item @code{TASK_INFO} + +This pragma appears within a task definition and +applies to the task in which it appears. The argument +must be of type @code{SYSTEM.TASK_INFO.TASK_INFO_TYPE}. + +@item @code{TASK_STORAGE} + +GNAT implements pragma @code{TASK_STORAGE} in the same way as HP Ada. +Both HP Ada and GNAT supply the pragmas @code{PASSIVE}, +@code{SUPPRESS}, and @code{VOLATILE}. +@end itemize +@node Scheduling and Task Priority +@subsection Scheduling and Task Priority + +@noindent +HP Ada implements the Ada language requirement that +when two tasks are eligible for execution and they have +different priorities, the lower priority task does not +execute while the higher priority task is waiting. The HP +Ada Run-Time Library keeps a task running until either the +task is suspended or a higher priority task becomes ready. + +On OpenVMS Alpha systems, the default strategy is round- +robin with preemption. Tasks of equal priority take turns +at the processor. A task is run for a certain period of +time and then placed at the tail of the ready queue for +its priority level. + +HP Ada provides the implementation-defined pragma @code{TIME_SLICE}, +which can be used to enable or disable round-robin +scheduling of tasks with the same priority. +See the relevant HP Ada run-time reference manual for +information on using the pragmas to control HP Ada task +scheduling. + +GNAT follows the scheduling rules of Annex D (Real-Time +Annex) of the @cite{Ada Reference Manual}. In general, this +scheduling strategy is fully compatible with HP Ada +although it provides some additional constraints (as +fully documented in Annex D). +GNAT implements time slicing control in a manner compatible with +HP Ada 83, by means of the pragma @code{Time_Slice}, whose semantics +are identical to the HP Ada 83 pragma of the same name. +Note that it is not possible to mix GNAT tasking and +HP Ada 83 tasking in the same program, since the two run-time +libraries are not compatible. + +@node The Task Stack +@subsection The Task Stack + +@noindent +In HP Ada, a task stack is allocated each time a +non-passive task is activated. As soon as the task is +terminated, the storage for the task stack is deallocated. +If you specify a size of zero (bytes) with @code{T'STORAGE_SIZE}, +a default stack size is used. Also, regardless of the size +specified, some additional space is allocated for task +management purposes. On OpenVMS Alpha systems, at least +one page is allocated. + +GNAT handles task stacks in a similar manner. In accordance with +the Ada rules, it provides the pragma @code{STORAGE_SIZE} as +an alternative method for controlling the task stack size. +The specification of the attribute @code{T'STORAGE_SIZE} is also +supported in a manner compatible with HP Ada. + +@node External Interrupts +@subsection External Interrupts + +@noindent +On HP Ada, external interrupts can be associated with task entries. +GNAT is compatible with HP Ada in its handling of external interrupts. + +@node Pragmas and Pragma-Related Features +@section Pragmas and Pragma-Related Features + +@noindent +Both HP Ada and GNAT supply all language-defined pragmas +as specified by the Ada 83 standard. GNAT also supplies all +language-defined pragmas introduced by Ada 95 and Ada 2005. +In addition, GNAT implements the implementation-defined pragmas +from HP Ada 83. + +@itemize @bullet +@item @code{AST_ENTRY} + +@item @code{COMMON_OBJECT} + +@item @code{COMPONENT_ALIGNMENT} + +@item @code{EXPORT_EXCEPTION} + +@item @code{EXPORT_FUNCTION} + +@item @code{EXPORT_OBJECT} + +@item @code{EXPORT_PROCEDURE} + +@item @code{EXPORT_VALUED_PROCEDURE} + +@item @code{FLOAT_REPRESENTATION} + +@item @code{IDENT} + +@item @code{IMPORT_EXCEPTION} + +@item @code{IMPORT_FUNCTION} + +@item @code{IMPORT_OBJECT} + +@item @code{IMPORT_PROCEDURE} + +@item @code{IMPORT_VALUED_PROCEDURE} + +@item @code{INLINE_GENERIC} + +@item @code{INTERFACE_NAME} + +@item @code{LONG_FLOAT} + +@item @code{MAIN_STORAGE} + +@item @code{PASSIVE} + +@item @code{PSECT_OBJECT} + +@item @code{SHARE_GENERIC} + +@item @code{SUPPRESS_ALL} + +@item @code{TASK_STORAGE} + +@item @code{TIME_SLICE} + +@item @code{TITLE} +@end itemize + +@noindent +These pragmas are all fully implemented, with the exception of @code{TITLE}, +@code{PASSIVE}, and @code{SHARE_GENERIC}, which are +recognized, but which have no +effect in GNAT. The effect of @code{PASSIVE} may be obtained by the +use of Ada protected objects. In GNAT, all generics are inlined. + +Unlike HP Ada, the GNAT ``@code{EXPORT_}@i{subprogram}'' pragmas require +a separate subprogram specification which must appear before the +subprogram body. + +GNAT also supplies a number of implementation-defined pragmas including the +following: + +@itemize @bullet +@item @code{ABORT_DEFER} + +@item @code{ADA_83} + +@item @code{ADA_95} + +@item @code{ADA_05} + +@item @code{Ada_2005} + +@item @code{Ada_12} + +@item @code{Ada_2012} + +@item @code{ANNOTATE} + +@item @code{ASSERT} + +@item @code{C_PASS_BY_COPY} + +@item @code{CPP_CLASS} + +@item @code{CPP_CONSTRUCTOR} + +@item @code{CPP_DESTRUCTOR} + +@item @code{DEBUG} + +@item @code{EXTEND_SYSTEM} + +@item @code{LINKER_ALIAS} + +@item @code{LINKER_SECTION} + +@item @code{MACHINE_ATTRIBUTE} + +@item @code{NO_RETURN} + +@item @code{PURE_FUNCTION} + +@item @code{SOURCE_FILE_NAME} + +@item @code{SOURCE_REFERENCE} + +@item @code{TASK_INFO} + +@item @code{UNCHECKED_UNION} + +@item @code{UNIMPLEMENTED_UNIT} + +@item @code{UNIVERSAL_DATA} + +@item @code{UNSUPPRESS} + +@item @code{WARNINGS} + +@item @code{WEAK_EXTERNAL} +@end itemize + +@noindent +For full details on these and other GNAT implementation-defined pragmas, +see @ref{Implementation Defined Pragmas,,, gnat_rm, GNAT Reference +Manual}. + +@menu +* Restrictions on the Pragma INLINE:: +* Restrictions on the Pragma INTERFACE:: +* Restrictions on the Pragma SYSTEM_NAME:: +@end menu + +@node Restrictions on the Pragma INLINE +@subsection Restrictions on Pragma @code{INLINE} + +@noindent +HP Ada enforces the following restrictions on the pragma @code{INLINE}: +@itemize @bullet +@item Parameters cannot have a task type. + +@item Function results cannot be task types, unconstrained +array types, or unconstrained types with discriminants. + +@item Bodies cannot declare the following: +@itemize @bullet +@item Subprogram body or stub (imported subprogram is allowed) + +@item Tasks + +@item Generic declarations + +@item Instantiations + +@item Exceptions + +@item Access types (types derived from access types allowed) + +@item Array or record types + +@item Dependent tasks + +@item Direct recursive calls of subprogram or containing +subprogram, directly or via a renaming + +@end itemize +@end itemize + +@noindent +In GNAT, the only restriction on pragma @code{INLINE} is that the +body must occur before the call if both are in the same +unit, and the size must be appropriately small. There are +no other specific restrictions which cause subprograms to +be incapable of being inlined. + +@node Restrictions on the Pragma INTERFACE +@subsection Restrictions on Pragma @code{INTERFACE} + +@noindent +The following restrictions on pragma @code{INTERFACE} +are enforced by both HP Ada and GNAT: +@itemize @bullet +@item Languages accepted: Ada, Bliss, C, Fortran, Default. +Default is the default on OpenVMS Alpha systems. + +@item Parameter passing: Language specifies default +mechanisms but can be overridden with an @code{EXPORT} pragma. + +@itemize @bullet +@item Ada: Use internal Ada rules. + +@item Bliss, C: Parameters must be mode @code{in}; cannot be +record or task type. Result cannot be a string, an +array, or a record. + +@item Fortran: Parameters cannot have a task type. Result cannot +be a string, an array, or a record. +@end itemize +@end itemize + +@noindent +GNAT is entirely upwards compatible with HP Ada, and in addition allows +record parameters for all languages. + +@node Restrictions on the Pragma SYSTEM_NAME +@subsection Restrictions on Pragma @code{SYSTEM_NAME} + +@noindent +For HP Ada for OpenVMS Alpha, the enumeration literal +for the type @code{NAME} is @code{OPENVMS_AXP}. +In GNAT, the enumeration +literal for the type @code{NAME} is @code{SYSTEM_NAME_GNAT}. + +@node Library of Predefined Units +@section Library of Predefined Units + +@noindent +A library of predefined units is provided as part of the +HP Ada and GNAT implementations. HP Ada does not provide +the package @code{MACHINE_CODE} but instead recommends importing +assembler code. + +The GNAT versions of the HP Ada Run-Time Library (@code{ADA$PREDEFINED:}) +units are taken from the OpenVMS Alpha version, not the OpenVMS VAX +version. +The HP Ada Predefined Library units are modified to remove post-Ada 83 +incompatibilities and to make them interoperable with GNAT +(@pxref{Changes to DECLIB}, for details). +The units are located in the @file{DECLIB} directory. + +The GNAT RTL is contained in +the @file{ADALIB} directory, and +the default search path is set up to find @code{DECLIB} units in preference +to @code{ADALIB} units with the same name (@code{TEXT_IO}, +@code{SEQUENTIAL_IO}, and @code{DIRECT_IO}, for example). + +@menu +* Changes to DECLIB:: +@end menu + +@node Changes to DECLIB +@subsection Changes to @code{DECLIB} + +@noindent +The changes made to the HP Ada predefined library for GNAT and post-Ada 83 +compatibility are minor and include the following: + +@itemize @bullet +@item Adjusting the location of pragmas and record representation +clauses to obey Ada 95 (and thus Ada 2005) rules + +@item Adding the proper notation to generic formal parameters +that take unconstrained types in instantiation + +@item Adding pragma @code{ELABORATE_BODY} to package specs +that have package bodies not otherwise allowed + +@item Replacing occurrences of the identifier ``@code{PROTECTED}'' by +``@code{PROTECTD}''. +Currently these are found only in the @code{STARLET} package spec. + +@item Changing @code{SYSTEM.ADDRESS} to @code{SYSTEM.SHORT_ADDRESS} +where the address size is constrained to 32 bits. +@end itemize + +@noindent +None of the above changes is visible to users. + +@node Bindings +@section Bindings + +@noindent +On OpenVMS Alpha, HP Ada provides the following strongly-typed bindings: +@itemize @bullet + +@item Command Language Interpreter (CLI interface) + +@item DECtalk Run-Time Library (DTK interface) + +@item Librarian utility routines (LBR interface) + +@item General Purpose Run-Time Library (LIB interface) + +@item Math Run-Time Library (MTH interface) + +@item National Character Set Run-Time Library (NCS interface) + +@item Compiled Code Support Run-Time Library (OTS interface) + +@item Parallel Processing Run-Time Library (PPL interface) + +@item Screen Management Run-Time Library (SMG interface) + +@item Sort Run-Time Library (SOR interface) + +@item String Run-Time Library (STR interface) + +@item STARLET System Library +@findex Starlet + +@item X Window System Version 11R4 and 11R5 (X, XLIB interface) + +@item X Windows Toolkit (XT interface) + +@item X/Motif Version 1.1.3 and 1.2 (XM interface) +@end itemize + +@noindent +GNAT provides implementations of these HP bindings in the @code{DECLIB} +directory, on both the Alpha and I64 OpenVMS platforms. + +The X/Motif bindings used to build @code{DECLIB} are whatever versions are +in the +HP Ada @file{ADA$PREDEFINED} directory with extension @file{.ADC}. +A pragma @code{Linker_Options} has been added to packages @code{Xm}, +@code{Xt}, and @code{X_Lib} +causing the default X/Motif sharable image libraries to be linked in. This +is done via options files named @file{xm.opt}, @file{xt.opt}, and +@file{x_lib.opt} (also located in the @file{DECLIB} directory). + +It may be necessary to edit these options files to update or correct the +library names if, for example, the newer X/Motif bindings from +@file{ADA$EXAMPLES} +had been (previous to installing GNAT) copied and renamed to supersede the +default @file{ADA$PREDEFINED} versions. + +@menu +* Shared Libraries and Options Files:: +* Interfaces to C:: +@end menu + +@node Shared Libraries and Options Files +@subsection Shared Libraries and Options Files + +@noindent +When using the HP Ada +predefined X and Motif bindings, the linking with their sharable images is +done automatically by @command{GNAT LINK}. +When using other X and Motif bindings, you need +to add the corresponding sharable images to the command line for +@code{GNAT LINK}. When linking with shared libraries, or with +@file{.OPT} files, you must +also add them to the command line for @command{GNAT LINK}. + +A shared library to be used with GNAT is built in the same way as other +libraries under VMS. The VMS Link command can be used in standard fashion. + +@node Interfaces to C +@subsection Interfaces to C + +@noindent +HP Ada +provides the following Ada types and operations: + +@itemize @bullet +@item C types package (@code{C_TYPES}) + +@item C strings (@code{C_TYPES.NULL_TERMINATED}) + +@item Other_types (@code{SHORT_INT}) +@end itemize + +@noindent +Interfacing to C with GNAT, you can use the above approach +described for HP Ada or the facilities of Annex B of +the @cite{Ada Reference Manual} (packages @code{INTERFACES.C}, +@code{INTERFACES.C.STRINGS} and @code{INTERFACES.C.POINTERS}). For more +information, see @ref{Interfacing to C,,, gnat_rm, GNAT Reference Manual}. + +The @option{-gnatF} qualifier forces default and explicit +@code{External_Name} parameters in pragmas @code{Import} and @code{Export} +to be uppercased for compatibility with the default behavior +of HP C. The qualifier has no effect on @code{Link_Name} parameters. + +@node Main Program Definition +@section Main Program Definition + +@noindent +The following section discusses differences in the +definition of main programs on HP Ada and GNAT. +On HP Ada, main programs are defined to meet the +following conditions: +@itemize @bullet +@item Procedure with no formal parameters (returns @code{0} upon +normal completion) + +@item Procedure with no formal parameters (returns @code{42} when +an unhandled exception is raised) + +@item Function with no formal parameters whose returned value +is of a discrete type + +@item Procedure with one @code{out} formal of a discrete type for +which a specification of pragma @code{EXPORT_VALUED_PROCEDURE} is given. + +@end itemize + +@noindent +When declared with the pragma @code{EXPORT_VALUED_PROCEDURE}, +a main function or main procedure returns a discrete +value whose size is less than 64 bits (32 on VAX systems), +the value is zero- or sign-extended as appropriate. +On GNAT, main programs are defined as follows: +@itemize @bullet +@item Must be a non-generic, parameterless subprogram that +is either a procedure or function returning an Ada +@code{STANDARD.INTEGER} (the predefined type) + +@item Cannot be a generic subprogram or an instantiation of a +generic subprogram +@end itemize + +@node Implementation-Defined Attributes +@section Implementation-Defined Attributes + +@noindent +GNAT provides all HP Ada implementation-defined +attributes. + +@node Compiler and Run-Time Interfacing +@section Compiler and Run-Time Interfacing + +@noindent +HP Ada provides the following qualifiers to pass options to the linker +(ACS LINK): +@itemize @bullet +@item @option{/WAIT} and @option{/SUBMIT} + +@item @option{/COMMAND} + +@item @option{/@r{[}NO@r{]}MAP} + +@item @option{/OUTPUT=@var{file-spec}} + +@item @option{/@r{[}NO@r{]}DEBUG} and @option{/@r{[}NO@r{]}TRACEBACK} +@end itemize + +@noindent +To pass options to the linker, GNAT provides the following +switches: + +@itemize @bullet +@item @option{/EXECUTABLE=@var{exec-name}} + +@item @option{/VERBOSE} + +@item @option{/@r{[}NO@r{]}DEBUG} and @option{/@r{[}NO@r{]}TRACEBACK} +@end itemize + +@noindent +For more information on these switches, see +@ref{Switches for gnatlink}. +In HP Ada, the command-line switch @option{/OPTIMIZE} is available +to control optimization. HP Ada also supplies the +following pragmas: +@itemize @bullet +@item @code{OPTIMIZE} + +@item @code{INLINE} + +@item @code{INLINE_GENERIC} + +@item @code{SUPPRESS_ALL} + +@item @code{PASSIVE} +@end itemize + +@noindent +In GNAT, optimization is controlled strictly by command +line parameters, as described in the corresponding section of this guide. +The HP pragmas for control of optimization are +recognized but ignored. + +Note that in GNAT, the default is optimization off, whereas in HP Ada +the default is that optimization is turned on. + +@node Program Compilation and Library Management +@section Program Compilation and Library Management + +@noindent +HP Ada and GNAT provide a comparable set of commands to +build programs. HP Ada also provides a program library, +which is a concept that does not exist on GNAT. Instead, +GNAT provides directories of sources that are compiled as +needed. + +The following table summarizes +the HP Ada commands and provides +equivalent GNAT commands. In this table, some GNAT +equivalents reflect the fact that GNAT does not use the +concept of a program library. Instead, it uses a model +in which collections of source and object files are used +in a manner consistent with other languages like C and +Fortran. Therefore, standard system file commands are used +to manipulate these elements. Those GNAT commands are marked with +an asterisk. +Note that, unlike HP Ada, none of the GNAT commands accepts wild cards. + +@need 1500 +@multitable @columnfractions .35 .65 + +@item @emph{HP Ada Command} +@tab @emph{GNAT Equivalent / Description} + +@item @command{ADA} +@tab @command{GNAT COMPILE}@* +Invokes the compiler to compile one or more Ada source files. + +@item @command{ACS ATTACH}@* +@tab [No equivalent]@* +Switches control of terminal from current process running the program +library manager. + +@item @command{ACS CHECK} +@tab @command{GNAT MAKE /DEPENDENCY_LIST}@* +Forms the execution closure of one +or more compiled units and checks completeness and currency. + +@item @command{ACS COMPILE} +@tab @command{GNAT MAKE /ACTIONS=COMPILE}@* +Forms the execution closure of one or +more specified units, checks completeness and currency, +identifies units that have revised source files, compiles same, +and recompiles units that are or will become obsolete. +Also completes incomplete generic instantiations. + +@item @command{ACS COPY FOREIGN} +@tab Copy (*)@* +Copies a foreign object file into the program library as a +library unit body. + +@item @command{ACS COPY UNIT} +@tab Copy (*)@* +Copies a compiled unit from one program library to another. + +@item @command{ACS CREATE LIBRARY} +@tab Create /directory (*)@* +Creates a program library. + +@item @command{ACS CREATE SUBLIBRARY} +@tab Create /directory (*)@* +Creates a program sublibrary. + +@item @command{ACS DELETE LIBRARY} +@tab @* +Deletes a program library and its contents. + +@item @command{ACS DELETE SUBLIBRARY} +@tab @* +Deletes a program sublibrary and its contents. + +@item @command{ACS DELETE UNIT} +@tab Delete file (*)@* +On OpenVMS systems, deletes one or more compiled units from +the current program library. + +@item @command{ACS DIRECTORY} +@tab Directory (*)@* +On OpenVMS systems, lists units contained in the current +program library. + +@item @command{ACS ENTER FOREIGN} +@tab Copy (*)@* +Allows the import of a foreign body as an Ada library +spec and enters a reference to a pointer. + +@item @command{ACS ENTER UNIT} +@tab Copy (*)@* +Enters a reference (pointer) from the current program library to +a unit compiled into another program library. + +@item @command{ACS EXIT} +@tab [No equivalent]@* +Exits from the program library manager. + +@item @command{ACS EXPORT} +@tab Copy (*)@* +Creates an object file that contains system-specific object code +for one or more units. With GNAT, object files can simply be copied +into the desired directory. + +@item @command{ACS EXTRACT SOURCE} +@tab Copy (*)@* +Allows access to the copied source file for each Ada compilation unit + +@item @command{ACS HELP} +@tab @command{HELP GNAT}@* +Provides online help. + +@item @command{ACS LINK} +@tab @command{GNAT LINK}@* +Links an object file containing Ada units into an executable file. + +@item @command{ACS LOAD} +@tab Copy (*)@* +Loads (partially compiles) Ada units into the program library. +Allows loading a program from a collection of files into a library +without knowing the relationship among units. + +@item @command{ACS MERGE} +@tab Copy (*)@* +Merges into the current program library, one or more units from +another library where they were modified. + +@item @command{ACS RECOMPILE} +@tab @command{GNAT MAKE /ACTIONS=COMPILE}@* +Recompiles from external or copied source files any obsolete +unit in the closure. Also, completes any incomplete generic +instantiations. + +@item @command{ACS REENTER} +@tab @command{GNAT MAKE}@* +Reenters current references to units compiled after last entered +with the @command{ACS ENTER UNIT} command. + +@item @command{ACS SET LIBRARY} +@tab Set default (*)@* +Defines a program library to be the compilation context as well +as the target library for compiler output and commands in general. + +@item @command{ACS SET PRAGMA} +@tab Edit @file{gnat.adc} (*)@* +Redefines specified values of the library characteristics +@code{LONG_ FLOAT}, @code{MEMORY_SIZE}, @code{SYSTEM_NAME}, +and @code{Float_Representation}. + +@item @command{ACS SET SOURCE} +@tab Define @code{ADA_INCLUDE_PATH} path (*)@* +Defines the source file search list for the @command{ACS COMPILE} command. + +@item @command{ACS SHOW LIBRARY} +@tab Directory (*)@* +Lists information about one or more program libraries. + +@item @command{ACS SHOW PROGRAM} +@tab [No equivalent]@* +Lists information about the execution closure of one or +more units in the program library. + +@item @command{ACS SHOW SOURCE} +@tab Show logical @code{ADA_INCLUDE_PATH}@* +Shows the source file search used when compiling units. + +@item @command{ACS SHOW VERSION} +@tab Compile with @option{VERBOSE} option +Displays the version number of the compiler and program library +manager used. + +@item @command{ACS SPAWN} +@tab [No equivalent]@* +Creates a subprocess of the current process (same as @command{DCL SPAWN} +command). + +@item @command{ACS VERIFY} +@tab [No equivalent]@* +Performs a series of consistency checks on a program library to +determine whether the library structure and library files are in +valid form. +@end multitable + +@noindent + +@node Input-Output +@section Input-Output + +@noindent +On OpenVMS Alpha systems, HP Ada uses OpenVMS Record +Management Services (RMS) to perform operations on +external files. + +@noindent +HP Ada and GNAT predefine an identical set of input- +output packages. To make the use of the +generic @code{TEXT_IO} operations more convenient, HP Ada +provides predefined library packages that instantiate the +integer and floating-point operations for the predefined +integer and floating-point types as shown in the following table. + +@multitable @columnfractions .45 .55 +@item @emph{Package Name} @tab Instantiation + +@item @code{INTEGER_TEXT_IO} +@tab @code{INTEGER_IO(INTEGER)} + +@item @code{SHORT_INTEGER_TEXT_IO} +@tab @code{INTEGER_IO(SHORT_INTEGER)} + +@item @code{SHORT_SHORT_INTEGER_TEXT_IO} +@tab @code{INTEGER_IO(SHORT_SHORT_INTEGER)} + +@item @code{FLOAT_TEXT_IO} +@tab @code{FLOAT_IO(FLOAT)} + +@item @code{LONG_FLOAT_TEXT_IO} +@tab @code{FLOAT_IO(LONG_FLOAT)} +@end multitable + +@noindent +The HP Ada predefined packages and their operations +are implemented using OpenVMS Alpha files and input-output +facilities. HP Ada supports asynchronous input-output on OpenVMS Alpha. +Familiarity with the following is recommended: +@itemize @bullet +@item RMS file organizations and access methods + +@item OpenVMS file specifications and directories + +@item OpenVMS File Definition Language (FDL) +@end itemize + +@noindent +GNAT provides I/O facilities that are completely +compatible with HP Ada. The distribution includes the +standard HP Ada versions of all I/O packages, operating +in a manner compatible with HP Ada. In particular, the +following packages are by default the HP Ada (Ada 83) +versions of these packages rather than the renamings +suggested in Annex J of the Ada Reference Manual: +@itemize @bullet +@item @code{TEXT_IO} + +@item @code{SEQUENTIAL_IO} + +@item @code{DIRECT_IO} +@end itemize + +@noindent +The use of the standard child package syntax (for +example, @code{ADA.TEXT_IO}) retrieves the post-Ada 83 versions of these +packages. +GNAT provides HP-compatible predefined instantiations +of the @code{TEXT_IO} packages, and also +provides the standard predefined instantiations required +by the @cite{Ada Reference Manual}. + +For further information on how GNAT interfaces to the file +system or how I/O is implemented in programs written in +mixed languages, see @ref{Implementation of the Standard I/O,,, +gnat_rm, GNAT Reference Manual}. +This chapter covers the following: +@itemize @bullet +@item Standard I/O packages + +@item @code{FORM} strings + +@item @code{ADA.DIRECT_IO} + +@item @code{ADA.SEQUENTIAL_IO} + +@item @code{ADA.TEXT_IO} + +@item Stream pointer positioning + +@item Reading and writing non-regular files + +@item @code{GET_IMMEDIATE} + +@item Treating @code{TEXT_IO} files as streams + +@item Shared files + +@item Open modes +@end itemize + +@node Implementation Limits +@section Implementation Limits + +@noindent +The following table lists implementation limits for HP Ada +and GNAT systems. +@multitable @columnfractions .60 .20 .20 +@sp 1 +@item @emph{Compilation Parameter} +@tab @emph{HP Ada} +@tab @emph{GNAT} +@sp 1 + +@item In a subprogram or entry declaration, maximum number of +formal parameters that are of an unconstrained record type +@tab 32 +@tab No set limit +@sp 1 + +@item Maximum identifier length (number of characters) +@tab 255 +@tab 32766 +@sp 1 + +@item Maximum number of characters in a source line +@tab 255 +@tab 32766 +@sp 1 + +@item Maximum collection size (number of bytes) +@tab 2**31-1 +@tab 2**31-1 +@sp 1 + +@item Maximum number of discriminants for a record type +@tab 245 +@tab No set limit +@sp 1 + +@item Maximum number of formal parameters in an entry or +subprogram declaration +@tab 246 +@tab No set limit +@sp 1 + +@item Maximum number of dimensions in an array type +@tab 255 +@tab No set limit +@sp 1 + +@item Maximum number of library units and subunits in a compilation. +@tab 4095 +@tab No set limit +@sp 1 + +@item Maximum number of library units and subunits in an execution. +@tab 16383 +@tab No set limit +@sp 1 + +@item Maximum number of objects declared with the pragma @code{COMMON_OBJECT} +or @code{PSECT_OBJECT} +@tab 32757 +@tab No set limit +@sp 1 + +@item Maximum number of enumeration literals in an enumeration type +definition +@tab 65535 +@tab No set limit +@sp 1 + +@item Maximum number of lines in a source file +@tab 65534 +@tab No set limit +@sp 1 + +@item Maximum number of bits in any object +@tab 2**31-1 +@tab 2**31-1 +@sp 1 + +@item Maximum size of the static portion of a stack frame (approximate) +@tab 2**31-1 +@tab 2**31-1 +@end multitable + +@node Tools and Utilities +@section Tools and Utilities + +@noindent +The following table lists some of the OpenVMS development tools +available for HP Ada, and the corresponding tools for +use with @value{EDITION} on Alpha and I64 platforms. +Aside from the debugger, all the OpenVMS tools identified are part +of the DECset package. + +@iftex +@c Specify table in TeX since Texinfo does a poor job +@tex +\smallskip +\smallskip +\settabs\+Language-Sensitive Editor\quad + &Product with HP Ada\quad + &\cr +\+\it Tool + &\it Product with HP Ada + & \it Product with GNAT Pro\cr +\smallskip +\+Code Management System + &HP CMS + & HP CMS\cr +\smallskip +\+Language-Sensitive Editor + &HP LSE + & emacs or HP LSE (Alpha)\cr +\+ + & + & HP LSE (I64)\cr +\smallskip +\+Debugger + &OpenVMS Debug + & gdb (Alpha),\cr +\+ + & + & OpenVMS Debug (I64)\cr +\smallskip +\+Source Code Analyzer / + &HP SCA + & GNAT XREF\cr +\+Cross Referencer + & + &\cr +\smallskip +\+Test Manager + &HP Digital Test + & HP DTM\cr +\+ + &Manager (DTM) + &\cr +\smallskip +\+Performance and + & HP PCA + & HP PCA\cr +\+Coverage Analyzer + & + &\cr +\smallskip +\+Module Management + & HP MMS + & Not applicable\cr +\+ System + & + &\cr +\smallskip +\smallskip +@end tex +@end iftex + +@ifnottex +@c This is the Texinfo version of the table. It renders poorly in pdf, hence +@c the TeX version above for the printed version +@flushleft +@c @multitable @columnfractions .3 .4 .4 +@multitable {Source Code Analyzer /}{Tool with HP Ada}{Tool with GNAT Pro} +@item @i{Tool} +@tab @i{Tool with HP Ada} +@tab @i{Tool with @value{EDITION}} +@item Code Management@*System +@tab HP CMS +@tab HP CMS +@item Language-Sensitive@*Editor +@tab HP LSE +@tab emacs or HP LSE (Alpha) +@item +@tab +@tab HP LSE (I64) +@item Debugger +@tab OpenVMS Debug +@tab gdb (Alpha), +@item +@tab +@tab OpenVMS Debug (I64) +@item Source Code Analyzer /@*Cross Referencer +@tab HP SCA +@tab GNAT XREF +@item Test Manager +@tab HP Digital Test@*Manager (DTM) +@tab HP DTM +@item Performance and@*Coverage Analyzer +@tab HP PCA +@tab HP PCA +@item Module Management@*System +@tab HP MMS +@tab Not applicable +@end multitable +@end flushleft +@end ifnottex + +@end ifset + +@c ************************************** +@node Platform-Specific Information for the Run-Time Libraries +@appendix Platform-Specific Information for the Run-Time Libraries +@cindex Tasking and threads libraries +@cindex Threads libraries and tasking +@cindex Run-time libraries (platform-specific information) + +@noindent +The GNAT run-time implementation may vary with respect to both the +underlying threads library and the exception handling scheme. +For threads support, one or more of the following are supplied: +@itemize @bullet +@item @b{native threads library}, a binding to the thread package from +the underlying operating system + +@item @b{pthreads library} (Sparc Solaris only), a binding to the Solaris +POSIX thread package +@end itemize + +@noindent +For exception handling, either or both of two models are supplied: +@itemize @bullet +@item @b{Zero-Cost Exceptions} (``ZCX''),@footnote{ +Most programs should experience a substantial speed improvement by +being compiled with a ZCX run-time. +This is especially true for +tasking applications or applications with many exception handlers.} +@cindex Zero-Cost Exceptions +@cindex ZCX (Zero-Cost Exceptions) +which uses binder-generated tables that +are interrogated at run time to locate a handler + +@item @b{setjmp / longjmp} (``SJLJ''), +@cindex setjmp/longjmp Exception Model +@cindex SJLJ (setjmp/longjmp Exception Model) +which uses dynamically-set data to establish +the set of handlers +@end itemize + +@noindent +This appendix summarizes which combinations of threads and exception support +are supplied on various GNAT platforms. +It then shows how to select a particular library either +permanently or temporarily, +explains the properties of (and tradeoffs among) the various threads +libraries, and provides some additional +information about several specific platforms. + +@menu +* Summary of Run-Time Configurations:: +* Specifying a Run-Time Library:: +* Choosing the Scheduling Policy:: +* Solaris-Specific Considerations:: +* Linux-Specific Considerations:: +* AIX-Specific Considerations:: +* Irix-Specific Considerations:: +* RTX-Specific Considerations:: +* HP-UX-Specific Considerations:: +@end menu + +@node Summary of Run-Time Configurations +@section Summary of Run-Time Configurations + +@multitable @columnfractions .30 .70 +@item @b{alpha-openvms} +@item @code{@ @ }@i{rts-native (default)} +@item @code{@ @ @ @ }Tasking @tab native VMS threads +@item @code{@ @ @ @ }Exceptions @tab ZCX +@* +@item @b{alpha-tru64} +@item @code{@ @ }@i{rts-native (default)} +@item @code{@ @ @ @ }Tasking @tab native TRU64 threads +@item @code{@ @ @ @ }Exceptions @tab ZCX +@* +@item @code{@ @ }@i{rts-sjlj} +@item @code{@ @ @ @ }Tasking @tab native TRU64 threads +@item @code{@ @ @ @ }Exceptions @tab SJLJ +@* +@item @b{ia64-hp_linux} +@item @code{@ @ }@i{rts-native (default)} +@item @code{@ @ @ @ }Tasking @tab pthread library +@item @code{@ @ @ @ }Exceptions @tab ZCX +@* +@item @b{ia64-hpux} +@item @code{@ @ }@i{rts-native (default)} +@item @code{@ @ @ @ }Tasking @tab native HP-UX threads +@item @code{@ @ @ @ }Exceptions @tab SJLJ +@* +@item @b{ia64-openvms} +@item @code{@ @ }@i{rts-native (default)} +@item @code{@ @ @ @ }Tasking @tab native VMS threads +@item @code{@ @ @ @ }Exceptions @tab ZCX +@* +@item @b{ia64-sgi_linux} +@item @code{@ @ }@i{rts-native (default)} +@item @code{@ @ @ @ }Tasking @tab pthread library +@item @code{@ @ @ @ }Exceptions @tab ZCX +@* +@item @b{mips-irix} +@item @code{@ @ }@i{rts-native (default)} +@item @code{@ @ @ @ }Tasking @tab native IRIX threads +@item @code{@ @ @ @ }Exceptions @tab ZCX +@* +@item @b{pa-hpux} +@item @code{@ @ }@i{rts-native (default)} +@item @code{@ @ @ @ }Tasking @tab native HP-UX threads +@item @code{@ @ @ @ }Exceptions @tab ZCX +@* +@item @code{@ @ }@i{rts-sjlj} +@item @code{@ @ @ @ }Tasking @tab native HP-UX threads +@item @code{@ @ @ @ }Exceptions @tab SJLJ +@* +@item @b{ppc-aix} +@item @code{@ @ }@i{rts-native (default)} +@item @code{@ @ @ @ }Tasking @tab native AIX threads +@item @code{@ @ @ @ }Exceptions @tab SJLJ +@* +@item @b{ppc-darwin} +@item @code{@ @ }@i{rts-native (default)} +@item @code{@ @ @ @ }Tasking @tab native MacOS threads +@item @code{@ @ @ @ }Exceptions @tab ZCX +@* +@item @b{sparc-solaris} @tab +@item @code{@ @ }@i{rts-native (default)} +@item @code{@ @ @ @ }Tasking @tab native Solaris threads library +@item @code{@ @ @ @ }Exceptions @tab ZCX +@* +@item @code{@ @ }@i{rts-pthread} +@item @code{@ @ @ @ }Tasking @tab pthread library +@item @code{@ @ @ @ }Exceptions @tab ZCX +@* +@item @code{@ @ }@i{rts-sjlj} +@item @code{@ @ @ @ }Tasking @tab native Solaris threads library +@item @code{@ @ @ @ }Exceptions @tab SJLJ +@* +@item @b{sparc64-solaris} @tab +@item @code{@ @ }@i{rts-native (default)} +@item @code{@ @ @ @ }Tasking @tab native Solaris threads library +@item @code{@ @ @ @ }Exceptions @tab ZCX +@* +@item @b{x86-linux} +@item @code{@ @ }@i{rts-native (default)} +@item @code{@ @ @ @ }Tasking @tab pthread library +@item @code{@ @ @ @ }Exceptions @tab ZCX +@* +@item @code{@ @ }@i{rts-sjlj} +@item @code{@ @ @ @ }Tasking @tab pthread library +@item @code{@ @ @ @ }Exceptions @tab SJLJ +@* +@item @b{x86-lynx} +@item @code{@ @ }@i{rts-native (default)} +@item @code{@ @ @ @ }Tasking @tab native LynxOS threads +@item @code{@ @ @ @ }Exceptions @tab SJLJ +@* +@item @b{x86-solaris} +@item @code{@ @ }@i{rts-native (default)} +@item @code{@ @ @ @ }Tasking @tab native Solaris threads +@item @code{@ @ @ @ }Exceptions @tab SJLJ +@* +@item @b{x86-windows} +@item @code{@ @ }@i{rts-native (default)} +@item @code{@ @ @ @ }Tasking @tab native Win32 threads +@item @code{@ @ @ @ }Exceptions @tab ZCX +@* +@item @code{@ @ }@i{rts-sjlj (default)} +@item @code{@ @ @ @ }Tasking @tab native Win32 threads +@item @code{@ @ @ @ }Exceptions @tab SJLJ +@* +@item @b{x86-windows-rtx} +@item @code{@ @ }@i{rts-rtx-rtss (default)} +@item @code{@ @ @ @ }Tasking @tab RTX real-time subsystem RTSS threads (kernel mode) +@item @code{@ @ @ @ }Exceptions @tab SJLJ +@* +@item @code{@ @ }@i{rts-rtx-w32} +@item @code{@ @ @ @ }Tasking @tab RTX Win32 threads (user mode) +@item @code{@ @ @ @ }Exceptions @tab ZCX +@* +@item @b{x86_64-linux} +@item @code{@ @ }@i{rts-native (default)} +@item @code{@ @ @ @ }Tasking @tab pthread library +@item @code{@ @ @ @ }Exceptions @tab ZCX +@* +@item @code{@ @ }@i{rts-sjlj} +@item @code{@ @ @ @ }Tasking @tab pthread library +@item @code{@ @ @ @ }Exceptions @tab SJLJ +@* +@end multitable + +@node Specifying a Run-Time Library +@section Specifying a Run-Time Library + +@noindent +The @file{adainclude} subdirectory containing the sources of the GNAT +run-time library, and the @file{adalib} subdirectory containing the +@file{ALI} files and the static and/or shared GNAT library, are located +in the gcc target-dependent area: + +@smallexample +target=$prefix/lib/gcc/gcc-@i{dumpmachine}/gcc-@i{dumpversion}/ +@end smallexample + +@noindent +As indicated above, on some platforms several run-time libraries are supplied. +These libraries are installed in the target dependent area and +contain a complete source and binary subdirectory. The detailed description +below explains the differences between the different libraries in terms of +their thread support. + +The default run-time library (when GNAT is installed) is @emph{rts-native}. +This default run time is selected by the means of soft links. +For example on x86-linux: + +@smallexample +@group + $(target-dir) + | + +--- adainclude----------+ + | | + +--- adalib-----------+ | + | | | + +--- rts-native | | + | | | | + | +--- adainclude <---+ + | | | + | +--- adalib <----+ + | + +--- rts-sjlj + | + +--- adainclude + | + +--- adalib +@end group +@end smallexample + +@noindent +If the @i{rts-sjlj} library is to be selected on a permanent basis, +these soft links can be modified with the following commands: + +@smallexample +$ cd $target +$ rm -f adainclude adalib +$ ln -s rts-sjlj/adainclude adainclude +$ ln -s rts-sjlj/adalib adalib +@end smallexample + +@noindent +Alternatively, you can specify @file{rts-sjlj/adainclude} in the file +@file{$target/ada_source_path} and @file{rts-sjlj/adalib} in +@file{$target/ada_object_path}. + +Selecting another run-time library temporarily can be +achieved by using the @option{--RTS} switch, e.g., @option{--RTS=sjlj} +@cindex @option{--RTS} option + +@node Choosing the Scheduling Policy +@section Choosing the Scheduling Policy + +@noindent +When using a POSIX threads implementation, you have a choice of several +scheduling policies: @code{SCHED_FIFO}, +@cindex @code{SCHED_FIFO} scheduling policy +@code{SCHED_RR} +@cindex @code{SCHED_RR} scheduling policy +and @code{SCHED_OTHER}. +@cindex @code{SCHED_OTHER} scheduling policy +Typically, the default is @code{SCHED_OTHER}, while using @code{SCHED_FIFO} +or @code{SCHED_RR} requires special (e.g., root) privileges. + +By default, GNAT uses the @code{SCHED_OTHER} policy. To specify +@code{SCHED_FIFO}, +@cindex @code{SCHED_FIFO} scheduling policy +you can use one of the following: + +@itemize @bullet +@item +@code{pragma Time_Slice (0.0)} +@cindex pragma Time_Slice +@item +the corresponding binder option @option{-T0} +@cindex @option{-T0} option +@item +@code{pragma Task_Dispatching_Policy (FIFO_Within_Priorities)} +@cindex pragma Task_Dispatching_Policy +@end itemize + +@noindent +To specify @code{SCHED_RR}, +@cindex @code{SCHED_RR} scheduling policy +you should use @code{pragma Time_Slice} with a +value greater than @code{0.0}, or else use the corresponding @option{-T} +binder option. + +@node Solaris-Specific Considerations +@section Solaris-Specific Considerations +@cindex Solaris Sparc threads libraries + +@noindent +This section addresses some topics related to the various threads libraries +on Sparc Solaris. + +@menu +* Solaris Threads Issues:: +@end menu + +@node Solaris Threads Issues +@subsection Solaris Threads Issues + +@noindent +GNAT under Solaris/Sparc 32 bits comes with an alternate tasking run-time +library based on POSIX threads --- @emph{rts-pthread}. +@cindex rts-pthread threads library +This run-time library has the advantage of being mostly shared across all +POSIX-compliant thread implementations, and it also provides under +@w{Solaris 8} the @code{PTHREAD_PRIO_INHERIT} +@cindex @code{PTHREAD_PRIO_INHERIT} policy (under rts-pthread) +and @code{PTHREAD_PRIO_PROTECT} +@cindex @code{PTHREAD_PRIO_PROTECT} policy (under rts-pthread) +semantics that can be selected using the predefined pragma +@code{Locking_Policy} +@cindex pragma Locking_Policy (under rts-pthread) +with respectively +@code{Inheritance_Locking} and @code{Ceiling_Locking} as the policy. +@cindex @code{Inheritance_Locking} (under rts-pthread) +@cindex @code{Ceiling_Locking} (under rts-pthread) + +As explained above, the native run-time library is based on the Solaris thread +library (@code{libthread}) and is the default library. + +When the Solaris threads library is used (this is the default), programs +compiled with GNAT can automatically take advantage of +and can thus execute on multiple processors. +The user can alternatively specify a processor on which the program should run +to emulate a single-processor system. The multiprocessor / uniprocessor choice +is made by +setting the environment variable @env{GNAT_PROCESSOR} +@cindex @env{GNAT_PROCESSOR} environment variable (on Sparc Solaris) +to one of the following: + +@table @code +@item -2 +Use the default configuration (run the program on all +available processors) - this is the same as having @code{GNAT_PROCESSOR} +unset + +@item -1 +Let the run-time implementation choose one processor and run the program on +that processor + +@item 0 .. Last_Proc +Run the program on the specified processor. +@code{Last_Proc} is equal to @code{_SC_NPROCESSORS_CONF - 1} +(where @code{_SC_NPROCESSORS_CONF} is a system variable). +@end table + +@node Linux-Specific Considerations +@section Linux-Specific Considerations +@cindex Linux threads libraries + +@noindent +On GNU/Linux without NPTL support (usually system with GNU C Library +older than 2.3), the signal model is not POSIX compliant, which means +that to send a signal to the process, you need to send the signal to all +threads, e.g.@: by using @code{killpg()}. + +@node AIX-Specific Considerations +@section AIX-Specific Considerations +@cindex AIX resolver library + +@noindent +On AIX, the resolver library initializes some internal structure on +the first call to @code{get*by*} functions, which are used to implement +@code{GNAT.Sockets.Get_Host_By_Name} and +@code{GNAT.Sockets.Get_Host_By_Address}. +If such initialization occurs within an Ada task, and the stack size for +the task is the default size, a stack overflow may occur. + +To avoid this overflow, the user should either ensure that the first call +to @code{GNAT.Sockets.Get_Host_By_Name} or +@code{GNAT.Sockets.Get_Host_By_Addrss} +occurs in the environment task, or use @code{pragma Storage_Size} to +specify a sufficiently large size for the stack of the task that contains +this call. + +@node Irix-Specific Considerations +@section Irix-Specific Considerations +@cindex Irix libraries + +@noindent +The GCC support libraries coming with the Irix compiler have moved to +their canonical place with respect to the general Irix ABI related +conventions. Running applications built with the default shared GNAT +run-time now requires the LD_LIBRARY_PATH environment variable to +include this location. A possible way to achieve this is to issue the +following command line on a bash prompt: + +@smallexample +@group +$ LD_LIBRARY_PATH=$LD_LIBRARY_PATH:`dirname \`gcc --print-file-name=libgcc_s.so\`` +@end group +@end smallexample + +@node RTX-Specific Considerations +@section RTX-Specific Considerations +@cindex RTX libraries + +@noindent +The Real-time Extension (RTX) to Windows is based on the Windows Win32 +API. Applications can be built to work in two different modes: + +@itemize @bullet +@item +Windows executables that run in Ring 3 to utilize memory protection +(@emph{rts-rtx-w32}). + +@item +Real-time subsystem (RTSS) executables that run in Ring 0, where +performance can be optimized with RTSS applications taking precedent +over all Windows applications (@emph{rts-rtx-rtss}). This mode requires +the Microsoft linker to handle RTSS libraries. + +@end itemize + +@node HP-UX-Specific Considerations +@section HP-UX-Specific Considerations +@cindex HP-UX Scheduling + +@noindent +On HP-UX, appropriate privileges are required to change the scheduling +parameters of a task. The calling process must have appropriate +privileges or be a member of a group having @code{PRIV_RTSCHED} access to +successfully change the scheduling parameters. + +By default, GNAT uses the @code{SCHED_HPUX} policy. To have access to the +priority range 0-31 either the @code{FIFO_Within_Priorities} or the +@code{Round_Robin_Within_Priorities} scheduling policies need to be set. + +To specify the @code{FIFO_Within_Priorities} scheduling policy you can use +one of the following: + +@itemize @bullet +@item +@code{pragma Time_Slice (0.0)} +@cindex pragma Time_Slice +@item +the corresponding binder option @option{-T0} +@cindex @option{-T0} option +@item +@code{pragma Task_Dispatching_Policy (FIFO_Within_Priorities)} +@cindex pragma Task_Dispatching_Policy +@end itemize + +@noindent +To specify the @code{Round_Robin_Within_Priorities}, scheduling policy +you should use @code{pragma Time_Slice} with a +value greater than @code{0.0}, or use the corresponding @option{-T} +binder option, or set the @code{pragma Task_Dispatching_Policy +(Round_Robin_Within_Priorities)}. + +@c ******************************* +@node Example of Binder Output File +@appendix Example of Binder Output File + +@noindent +This Appendix displays the source code for @command{gnatbind}'s output +file generated for a simple ``Hello World'' program. +Comments have been added for clarification purposes. + +@smallexample @c adanocomment +@iftex +@leftskip=0cm +@end iftex +-- The package is called Ada_Main unless this name is actually used +-- as a unit name in the partition, in which case some other unique +-- name is used. + +with System; +package ada_main is + + Elab_Final_Code : Integer; + pragma Import (C, Elab_Final_Code, "__gnat_inside_elab_final_code"); + + -- The main program saves the parameters (argument count, + -- argument values, environment pointer) in global variables + -- for later access by other units including + -- Ada.Command_Line. + + gnat_argc : Integer; + gnat_argv : System.Address; + gnat_envp : System.Address; + + -- The actual variables are stored in a library routine. This + -- is useful for some shared library situations, where there + -- are problems if variables are not in the library. + + pragma Import (C, gnat_argc); + pragma Import (C, gnat_argv); + pragma Import (C, gnat_envp); + + -- The exit status is similarly an external location + + gnat_exit_status : Integer; + pragma Import (C, gnat_exit_status); + + GNAT_Version : constant String := + "GNAT Version: 6.0.0w (20061115)"; + pragma Export (C, GNAT_Version, "__gnat_version"); + + -- This is the generated adafinal routine that performs + -- finalization at the end of execution. In the case where + -- Ada is the main program, this main program makes a call + -- to adafinal at program termination. + + procedure adafinal; + pragma Export (C, adafinal, "adafinal"); + + -- This is the generated adainit routine that performs + -- initialization at the start of execution. In the case + -- where Ada is the main program, this main program makes + -- a call to adainit at program startup. + + procedure adainit; + pragma Export (C, adainit, "adainit"); + + -- This routine is called at the start of execution. It is + -- a dummy routine that is used by the debugger to breakpoint + -- at the start of execution. + + procedure Break_Start; + pragma Import (C, Break_Start, "__gnat_break_start"); + + -- This is the actual generated main program (it would be + -- suppressed if the no main program switch were used). As + -- required by standard system conventions, this program has + -- the external name main. + + function main + (argc : Integer; + argv : System.Address; + envp : System.Address) + return Integer; + pragma Export (C, main, "main"); + + -- The following set of constants give the version + -- identification values for every unit in the bound + -- partition. This identification is computed from all + -- dependent semantic units, and corresponds to the + -- string that would be returned by use of the + -- Body_Version or Version attributes. + + type Version_32 is mod 2 ** 32; + u00001 : constant Version_32 := 16#7880BEB3#; + u00002 : constant Version_32 := 16#0D24CBD0#; + u00003 : constant Version_32 := 16#3283DBEB#; + u00004 : constant Version_32 := 16#2359F9ED#; + u00005 : constant Version_32 := 16#664FB847#; + u00006 : constant Version_32 := 16#68E803DF#; + u00007 : constant Version_32 := 16#5572E604#; + u00008 : constant Version_32 := 16#46B173D8#; + u00009 : constant Version_32 := 16#156A40CF#; + u00010 : constant Version_32 := 16#033DABE0#; + u00011 : constant Version_32 := 16#6AB38FEA#; + u00012 : constant Version_32 := 16#22B6217D#; + u00013 : constant Version_32 := 16#68A22947#; + u00014 : constant Version_32 := 16#18CC4A56#; + u00015 : constant Version_32 := 16#08258E1B#; + u00016 : constant Version_32 := 16#367D5222#; + u00017 : constant Version_32 := 16#20C9ECA4#; + u00018 : constant Version_32 := 16#50D32CB6#; + u00019 : constant Version_32 := 16#39A8BB77#; + u00020 : constant Version_32 := 16#5CF8FA2B#; + u00021 : constant Version_32 := 16#2F1EB794#; + u00022 : constant Version_32 := 16#31AB6444#; + u00023 : constant Version_32 := 16#1574B6E9#; + u00024 : constant Version_32 := 16#5109C189#; + u00025 : constant Version_32 := 16#56D770CD#; + u00026 : constant Version_32 := 16#02F9DE3D#; + u00027 : constant Version_32 := 16#08AB6B2C#; + u00028 : constant Version_32 := 16#3FA37670#; + u00029 : constant Version_32 := 16#476457A0#; + u00030 : constant Version_32 := 16#731E1B6E#; + u00031 : constant Version_32 := 16#23C2E789#; + u00032 : constant Version_32 := 16#0F1BD6A1#; + u00033 : constant Version_32 := 16#7C25DE96#; + u00034 : constant Version_32 := 16#39ADFFA2#; + u00035 : constant Version_32 := 16#571DE3E7#; + u00036 : constant Version_32 := 16#5EB646AB#; + u00037 : constant Version_32 := 16#4249379B#; + u00038 : constant Version_32 := 16#0357E00A#; + u00039 : constant Version_32 := 16#3784FB72#; + u00040 : constant Version_32 := 16#2E723019#; + u00041 : constant Version_32 := 16#623358EA#; + u00042 : constant Version_32 := 16#107F9465#; + u00043 : constant Version_32 := 16#6843F68A#; + u00044 : constant Version_32 := 16#63305874#; + u00045 : constant Version_32 := 16#31E56CE1#; + u00046 : constant Version_32 := 16#02917970#; + u00047 : constant Version_32 := 16#6CCBA70E#; + u00048 : constant Version_32 := 16#41CD4204#; + u00049 : constant Version_32 := 16#572E3F58#; + u00050 : constant Version_32 := 16#20729FF5#; + u00051 : constant Version_32 := 16#1D4F93E8#; + u00052 : constant Version_32 := 16#30B2EC3D#; + u00053 : constant Version_32 := 16#34054F96#; + u00054 : constant Version_32 := 16#5A199860#; + u00055 : constant Version_32 := 16#0E7F912B#; + u00056 : constant Version_32 := 16#5760634A#; + u00057 : constant Version_32 := 16#5D851835#; + + -- The following Export pragmas export the version numbers + -- with symbolic names ending in B (for body) or S + -- (for spec) so that they can be located in a link. The + -- information provided here is sufficient to track down + -- the exact versions of units used in a given build. + + pragma Export (C, u00001, "helloB"); + pragma Export (C, u00002, "system__standard_libraryB"); + pragma Export (C, u00003, "system__standard_libraryS"); + pragma Export (C, u00004, "adaS"); + pragma Export (C, u00005, "ada__text_ioB"); + pragma Export (C, u00006, "ada__text_ioS"); + pragma Export (C, u00007, "ada__exceptionsB"); + pragma Export (C, u00008, "ada__exceptionsS"); + pragma Export (C, u00009, "gnatS"); + pragma Export (C, u00010, "gnat__heap_sort_aB"); + pragma Export (C, u00011, "gnat__heap_sort_aS"); + pragma Export (C, u00012, "systemS"); + pragma Export (C, u00013, "system__exception_tableB"); + pragma Export (C, u00014, "system__exception_tableS"); + pragma Export (C, u00015, "gnat__htableB"); + pragma Export (C, u00016, "gnat__htableS"); + pragma Export (C, u00017, "system__exceptionsS"); + pragma Export (C, u00018, "system__machine_state_operationsB"); + pragma Export (C, u00019, "system__machine_state_operationsS"); + pragma Export (C, u00020, "system__machine_codeS"); + pragma Export (C, u00021, "system__storage_elementsB"); + pragma Export (C, u00022, "system__storage_elementsS"); + pragma Export (C, u00023, "system__secondary_stackB"); + pragma Export (C, u00024, "system__secondary_stackS"); + pragma Export (C, u00025, "system__parametersB"); + pragma Export (C, u00026, "system__parametersS"); + pragma Export (C, u00027, "system__soft_linksB"); + pragma Export (C, u00028, "system__soft_linksS"); + pragma Export (C, u00029, "system__stack_checkingB"); + pragma Export (C, u00030, "system__stack_checkingS"); + pragma Export (C, u00031, "system__tracebackB"); + pragma Export (C, u00032, "system__tracebackS"); + pragma Export (C, u00033, "ada__streamsS"); + pragma Export (C, u00034, "ada__tagsB"); + pragma Export (C, u00035, "ada__tagsS"); + pragma Export (C, u00036, "system__string_opsB"); + pragma Export (C, u00037, "system__string_opsS"); + pragma Export (C, u00038, "interfacesS"); + pragma Export (C, u00039, "interfaces__c_streamsB"); + pragma Export (C, u00040, "interfaces__c_streamsS"); + pragma Export (C, u00041, "system__file_ioB"); + pragma Export (C, u00042, "system__file_ioS"); + pragma Export (C, u00043, "ada__finalizationB"); + pragma Export (C, u00044, "ada__finalizationS"); + pragma Export (C, u00045, "system__finalization_rootB"); + pragma Export (C, u00046, "system__finalization_rootS"); + pragma Export (C, u00047, "system__finalization_implementationB"); + pragma Export (C, u00048, "system__finalization_implementationS"); + pragma Export (C, u00049, "system__string_ops_concat_3B"); + pragma Export (C, u00050, "system__string_ops_concat_3S"); + pragma Export (C, u00051, "system__stream_attributesB"); + pragma Export (C, u00052, "system__stream_attributesS"); + pragma Export (C, u00053, "ada__io_exceptionsS"); + pragma Export (C, u00054, "system__unsigned_typesS"); + pragma Export (C, u00055, "system__file_control_blockS"); + pragma Export (C, u00056, "ada__finalization__list_controllerB"); + pragma Export (C, u00057, "ada__finalization__list_controllerS"); + + -- BEGIN ELABORATION ORDER + -- ada (spec) + -- gnat (spec) + -- gnat.heap_sort_a (spec) + -- gnat.heap_sort_a (body) + -- gnat.htable (spec) + -- gnat.htable (body) + -- interfaces (spec) + -- system (spec) + -- system.machine_code (spec) + -- system.parameters (spec) + -- system.parameters (body) + -- interfaces.c_streams (spec) + -- interfaces.c_streams (body) + -- system.standard_library (spec) + -- ada.exceptions (spec) + -- system.exception_table (spec) + -- system.exception_table (body) + -- ada.io_exceptions (spec) + -- system.exceptions (spec) + -- system.storage_elements (spec) + -- system.storage_elements (body) + -- system.machine_state_operations (spec) + -- system.machine_state_operations (body) + -- system.secondary_stack (spec) + -- system.stack_checking (spec) + -- system.soft_links (spec) + -- system.soft_links (body) + -- system.stack_checking (body) + -- system.secondary_stack (body) + -- system.standard_library (body) + -- system.string_ops (spec) + -- system.string_ops (body) + -- ada.tags (spec) + -- ada.tags (body) + -- ada.streams (spec) + -- system.finalization_root (spec) + -- system.finalization_root (body) + -- system.string_ops_concat_3 (spec) + -- system.string_ops_concat_3 (body) + -- system.traceback (spec) + -- system.traceback (body) + -- ada.exceptions (body) + -- system.unsigned_types (spec) + -- system.stream_attributes (spec) + -- system.stream_attributes (body) + -- system.finalization_implementation (spec) + -- system.finalization_implementation (body) + -- ada.finalization (spec) + -- ada.finalization (body) + -- ada.finalization.list_controller (spec) + -- ada.finalization.list_controller (body) + -- system.file_control_block (spec) + -- system.file_io (spec) + -- system.file_io (body) + -- ada.text_io (spec) + -- ada.text_io (body) + -- hello (body) + -- END ELABORATION ORDER + +end ada_main; + +-- The following source file name pragmas allow the generated file +-- names to be unique for different main programs. They are needed +-- since the package name will always be Ada_Main. + +pragma Source_File_Name (ada_main, Spec_File_Name => "b~hello.ads"); +pragma Source_File_Name (ada_main, Body_File_Name => "b~hello.adb"); + +-- Generated package body for Ada_Main starts here + +package body ada_main is + + -- The actual finalization is performed by calling the + -- library routine in System.Standard_Library.Adafinal + + procedure Do_Finalize; + pragma Import (C, Do_Finalize, "system__standard_library__adafinal"); + + ------------- + -- adainit -- + ------------- + +@findex adainit + procedure adainit is + + -- These booleans are set to True once the associated unit has + -- been elaborated. It is also used to avoid elaborating the + -- same unit twice. + + E040 : Boolean; + pragma Import (Ada, E040, "interfaces__c_streams_E"); + + E008 : Boolean; + pragma Import (Ada, E008, "ada__exceptions_E"); + + E014 : Boolean; + pragma Import (Ada, E014, "system__exception_table_E"); + + E053 : Boolean; + pragma Import (Ada, E053, "ada__io_exceptions_E"); + + E017 : Boolean; + pragma Import (Ada, E017, "system__exceptions_E"); + + E024 : Boolean; + pragma Import (Ada, E024, "system__secondary_stack_E"); + + E030 : Boolean; + pragma Import (Ada, E030, "system__stack_checking_E"); + + E028 : Boolean; + pragma Import (Ada, E028, "system__soft_links_E"); + + E035 : Boolean; + pragma Import (Ada, E035, "ada__tags_E"); + + E033 : Boolean; + pragma Import (Ada, E033, "ada__streams_E"); + + E046 : Boolean; + pragma Import (Ada, E046, "system__finalization_root_E"); + + E048 : Boolean; + pragma Import (Ada, E048, "system__finalization_implementation_E"); + + E044 : Boolean; + pragma Import (Ada, E044, "ada__finalization_E"); + + E057 : Boolean; + pragma Import (Ada, E057, "ada__finalization__list_controller_E"); + + E055 : Boolean; + pragma Import (Ada, E055, "system__file_control_block_E"); + + E042 : Boolean; + pragma Import (Ada, E042, "system__file_io_E"); + + E006 : Boolean; + pragma Import (Ada, E006, "ada__text_io_E"); + + -- Set_Globals is a library routine that stores away the + -- value of the indicated set of global values in global + -- variables within the library. + + procedure Set_Globals + (Main_Priority : Integer; + Time_Slice_Value : Integer; + WC_Encoding : Character; + Locking_Policy : Character; + Queuing_Policy : Character; + Task_Dispatching_Policy : Character; + Adafinal : System.Address; + Unreserve_All_Interrupts : Integer; + Exception_Tracebacks : Integer); +@findex __gnat_set_globals + pragma Import (C, Set_Globals, "__gnat_set_globals"); + + -- SDP_Table_Build is a library routine used to build the + -- exception tables. See unit Ada.Exceptions in files + -- a-except.ads/adb for full details of how zero cost + -- exception handling works. This procedure, the call to + -- it, and the two following tables are all omitted if the + -- build is in longjmp/setjmp exception mode. + +@findex SDP_Table_Build +@findex Zero Cost Exceptions + procedure SDP_Table_Build + (SDP_Addresses : System.Address; + SDP_Count : Natural; + Elab_Addresses : System.Address; + Elab_Addr_Count : Natural); + pragma Import (C, SDP_Table_Build, "__gnat_SDP_Table_Build"); + + -- Table of Unit_Exception_Table addresses. Used for zero + -- cost exception handling to build the top level table. + + ST : aliased constant array (1 .. 23) of System.Address := ( + Hello'UET_Address, + Ada.Text_Io'UET_Address, + Ada.Exceptions'UET_Address, + Gnat.Heap_Sort_A'UET_Address, + System.Exception_Table'UET_Address, + System.Machine_State_Operations'UET_Address, + System.Secondary_Stack'UET_Address, + System.Parameters'UET_Address, + System.Soft_Links'UET_Address, + System.Stack_Checking'UET_Address, + System.Traceback'UET_Address, + Ada.Streams'UET_Address, + Ada.Tags'UET_Address, + System.String_Ops'UET_Address, + Interfaces.C_Streams'UET_Address, + System.File_Io'UET_Address, + Ada.Finalization'UET_Address, + System.Finalization_Root'UET_Address, + System.Finalization_Implementation'UET_Address, + System.String_Ops_Concat_3'UET_Address, + System.Stream_Attributes'UET_Address, + System.File_Control_Block'UET_Address, + Ada.Finalization.List_Controller'UET_Address); + + -- Table of addresses of elaboration routines. Used for + -- zero cost exception handling to make sure these + -- addresses are included in the top level procedure + -- address table. + + EA : aliased constant array (1 .. 23) of System.Address := ( + adainit'Code_Address, + Do_Finalize'Code_Address, + Ada.Exceptions'Elab_Spec'Address, + System.Exceptions'Elab_Spec'Address, + Interfaces.C_Streams'Elab_Spec'Address, + System.Exception_Table'Elab_Body'Address, + Ada.Io_Exceptions'Elab_Spec'Address, + System.Stack_Checking'Elab_Spec'Address, + System.Soft_Links'Elab_Body'Address, + System.Secondary_Stack'Elab_Body'Address, + Ada.Tags'Elab_Spec'Address, + Ada.Tags'Elab_Body'Address, + Ada.Streams'Elab_Spec'Address, + System.Finalization_Root'Elab_Spec'Address, + Ada.Exceptions'Elab_Body'Address, + System.Finalization_Implementation'Elab_Spec'Address, + System.Finalization_Implementation'Elab_Body'Address, + Ada.Finalization'Elab_Spec'Address, + Ada.Finalization.List_Controller'Elab_Spec'Address, + System.File_Control_Block'Elab_Spec'Address, + System.File_Io'Elab_Body'Address, + Ada.Text_Io'Elab_Spec'Address, + Ada.Text_Io'Elab_Body'Address); + + -- Start of processing for adainit + + begin + + -- Call SDP_Table_Build to build the top level procedure + -- table for zero cost exception handling (omitted in + -- longjmp/setjmp mode). + + SDP_Table_Build (ST'Address, 23, EA'Address, 23); + + -- Call Set_Globals to record various information for + -- this partition. The values are derived by the binder + -- from information stored in the ali files by the compiler. + +@findex __gnat_set_globals + Set_Globals + (Main_Priority => -1, + -- Priority of main program, -1 if no pragma Priority used + + Time_Slice_Value => -1, + -- Time slice from Time_Slice pragma, -1 if none used + + WC_Encoding => 'b', + -- Wide_Character encoding used, default is brackets + + Locking_Policy => ' ', + -- Locking_Policy used, default of space means not + -- specified, otherwise it is the first character of + -- the policy name. + + Queuing_Policy => ' ', + -- Queuing_Policy used, default of space means not + -- specified, otherwise it is the first character of + -- the policy name. + + Task_Dispatching_Policy => ' ', + -- Task_Dispatching_Policy used, default of space means + -- not specified, otherwise first character of the + -- policy name. + + Adafinal => System.Null_Address, + -- Address of Adafinal routine, not used anymore + + Unreserve_All_Interrupts => 0, + -- Set true if pragma Unreserve_All_Interrupts was used + + Exception_Tracebacks => 0); + -- Indicates if exception tracebacks are enabled + + Elab_Final_Code := 1; + + -- Now we have the elaboration calls for all units in the partition. + -- The Elab_Spec and Elab_Body attributes generate references to the + -- implicit elaboration procedures generated by the compiler for + -- each unit that requires elaboration. + + if not E040 then + Interfaces.C_Streams'Elab_Spec; + end if; + E040 := True; + if not E008 then + Ada.Exceptions'Elab_Spec; + end if; + if not E014 then + System.Exception_Table'Elab_Body; + E014 := True; + end if; + if not E053 then + Ada.Io_Exceptions'Elab_Spec; + E053 := True; + end if; + if not E017 then + System.Exceptions'Elab_Spec; + E017 := True; + end if; + if not E030 then + System.Stack_Checking'Elab_Spec; + end if; + if not E028 then + System.Soft_Links'Elab_Body; + E028 := True; + end if; + E030 := True; + if not E024 then + System.Secondary_Stack'Elab_Body; + E024 := True; + end if; + if not E035 then + Ada.Tags'Elab_Spec; + end if; + if not E035 then + Ada.Tags'Elab_Body; + E035 := True; + end if; + if not E033 then + Ada.Streams'Elab_Spec; + E033 := True; + end if; + if not E046 then + System.Finalization_Root'Elab_Spec; + end if; + E046 := True; + if not E008 then + Ada.Exceptions'Elab_Body; + E008 := True; + end if; + if not E048 then + System.Finalization_Implementation'Elab_Spec; + end if; + if not E048 then + System.Finalization_Implementation'Elab_Body; + E048 := True; + end if; + if not E044 then + Ada.Finalization'Elab_Spec; + end if; + E044 := True; + if not E057 then + Ada.Finalization.List_Controller'Elab_Spec; + end if; + E057 := True; + if not E055 then + System.File_Control_Block'Elab_Spec; + E055 := True; + end if; + if not E042 then + System.File_Io'Elab_Body; + E042 := True; + end if; + if not E006 then + Ada.Text_Io'Elab_Spec; + end if; + if not E006 then + Ada.Text_Io'Elab_Body; + E006 := True; + end if; + + Elab_Final_Code := 0; + end adainit; + + -------------- + -- adafinal -- + -------------- + +@findex adafinal + procedure adafinal is + begin + Do_Finalize; + end adafinal; + + ---------- + -- main -- + ---------- + + -- main is actually a function, as in the ANSI C standard, + -- defined to return the exit status. The three parameters + -- are the argument count, argument values and environment + -- pointer. + +@findex Main Program + function main + (argc : Integer; + argv : System.Address; + envp : System.Address) + return Integer + is + -- The initialize routine performs low level system + -- initialization using a standard library routine which + -- sets up signal handling and performs any other + -- required setup. The routine can be found in file + -- a-init.c. + +@findex __gnat_initialize + procedure initialize; + pragma Import (C, initialize, "__gnat_initialize"); + + -- The finalize routine performs low level system + -- finalization using a standard library routine. The + -- routine is found in file a-final.c and in the standard + -- distribution is a dummy routine that does nothing, so + -- really this is a hook for special user finalization. + +@findex __gnat_finalize + procedure finalize; + pragma Import (C, finalize, "__gnat_finalize"); + + -- We get to the main program of the partition by using + -- pragma Import because if we try to with the unit and + -- call it Ada style, then not only do we waste time + -- recompiling it, but also, we don't really know the right + -- switches (e.g.@: identifier character set) to be used + -- to compile it. + + procedure Ada_Main_Program; + pragma Import (Ada, Ada_Main_Program, "_ada_hello"); + + -- Start of processing for main + + begin + -- Save global variables + + gnat_argc := argc; + gnat_argv := argv; + gnat_envp := envp; + + -- Call low level system initialization + + Initialize; + + -- Call our generated Ada initialization routine + + adainit; + + -- This is the point at which we want the debugger to get + -- control + + Break_Start; + + -- Now we call the main program of the partition + + Ada_Main_Program; + + -- Perform Ada finalization + + adafinal; + + -- Perform low level system finalization + + Finalize; + + -- Return the proper exit status + return (gnat_exit_status); + end; + +-- This section is entirely comments, so it has no effect on the +-- compilation of the Ada_Main package. It provides the list of +-- object files and linker options, as well as some standard +-- libraries needed for the link. The gnatlink utility parses +-- this b~hello.adb file to read these comment lines to generate +-- the appropriate command line arguments for the call to the +-- system linker. The BEGIN/END lines are used for sentinels for +-- this parsing operation. + +-- The exact file names will of course depend on the environment, +-- host/target and location of files on the host system. + +@findex Object file list +-- BEGIN Object file/option list + -- ./hello.o + -- -L./ + -- -L/usr/local/gnat/lib/gcc-lib/i686-pc-linux-gnu/2.8.1/adalib/ + -- /usr/local/gnat/lib/gcc-lib/i686-pc-linux-gnu/2.8.1/adalib/libgnat.a +-- END Object file/option list + +end ada_main; +@end smallexample + +@noindent +The Ada code in the above example is exactly what is generated by the +binder. We have added comments to more clearly indicate the function +of each part of the generated @code{Ada_Main} package. + +The code is standard Ada in all respects, and can be processed by any +tools that handle Ada. In particular, it is possible to use the debugger +in Ada mode to debug the generated @code{Ada_Main} package. For example, +suppose that for reasons that you do not understand, your program is crashing +during elaboration of the body of @code{Ada.Text_IO}. To locate this bug, +you can place a breakpoint on the call: + +@smallexample @c ada +Ada.Text_Io'Elab_Body; +@end smallexample + +@noindent +and trace the elaboration routine for this package to find out where +the problem might be (more usually of course you would be debugging +elaboration code in your own application). + +@node Elaboration Order Handling in GNAT +@appendix Elaboration Order Handling in GNAT +@cindex Order of elaboration +@cindex Elaboration control + +@menu +* Elaboration Code:: +* Checking the Elaboration Order:: +* Controlling the Elaboration Order:: +* Controlling Elaboration in GNAT - Internal Calls:: +* Controlling Elaboration in GNAT - External Calls:: +* Default Behavior in GNAT - Ensuring Safety:: +* Treatment of Pragma Elaborate:: +* Elaboration Issues for Library Tasks:: +* Mixing Elaboration Models:: +* What to Do If the Default Elaboration Behavior Fails:: +* Elaboration for Access-to-Subprogram Values:: +* Summary of Procedures for Elaboration Control:: +* Other Elaboration Order Considerations:: +@end menu + +@noindent +This chapter describes the handling of elaboration code in Ada and +in GNAT, and discusses how the order of elaboration of program units can +be controlled in GNAT, either automatically or with explicit programming +features. + +@node Elaboration Code +@section Elaboration Code + +@noindent +Ada provides rather general mechanisms for executing code at elaboration +time, that is to say before the main program starts executing. Such code arises +in three contexts: + +@table @asis +@item Initializers for variables. +Variables declared at the library level, in package specs or bodies, can +require initialization that is performed at elaboration time, as in: +@smallexample @c ada +@cartouche +Sqrt_Half : Float := Sqrt (0.5); +@end cartouche +@end smallexample + +@item Package initialization code +Code in a @code{BEGIN-END} section at the outer level of a package body is +executed as part of the package body elaboration code. + +@item Library level task allocators +Tasks that are declared using task allocators at the library level +start executing immediately and hence can execute at elaboration time. +@end table + +@noindent +Subprogram calls are possible in any of these contexts, which means that +any arbitrary part of the program may be executed as part of the elaboration +code. It is even possible to write a program which does all its work at +elaboration time, with a null main program, although stylistically this +would usually be considered an inappropriate way to structure +a program. + +An important concern arises in the context of elaboration code: +we have to be sure that it is executed in an appropriate order. What we +have is a series of elaboration code sections, potentially one section +for each unit in the program. It is important that these execute +in the correct order. Correctness here means that, taking the above +example of the declaration of @code{Sqrt_Half}, +if some other piece of +elaboration code references @code{Sqrt_Half}, +then it must run after the +section of elaboration code that contains the declaration of +@code{Sqrt_Half}. + +There would never be any order of elaboration problem if we made a rule +that whenever you @code{with} a unit, you must elaborate both the spec and body +of that unit before elaborating the unit doing the @code{with}'ing: + +@smallexample @c ada +@group +@cartouche +with Unit_1; +package Unit_2 is @dots{} +@end cartouche +@end group +@end smallexample + +@noindent +would require that both the body and spec of @code{Unit_1} be elaborated +before the spec of @code{Unit_2}. However, a rule like that would be far too +restrictive. In particular, it would make it impossible to have routines +in separate packages that were mutually recursive. + +You might think that a clever enough compiler could look at the actual +elaboration code and determine an appropriate correct order of elaboration, +but in the general case, this is not possible. Consider the following +example. + +In the body of @code{Unit_1}, we have a procedure @code{Func_1} +that references +the variable @code{Sqrt_1}, which is declared in the elaboration code +of the body of @code{Unit_1}: + +@smallexample @c ada +@cartouche +Sqrt_1 : Float := Sqrt (0.1); +@end cartouche +@end smallexample + +@noindent +The elaboration code of the body of @code{Unit_1} also contains: + +@smallexample @c ada +@group +@cartouche +if expression_1 = 1 then + Q := Unit_2.Func_2; +end if; +@end cartouche +@end group +@end smallexample + +@noindent +@code{Unit_2} is exactly parallel, +it has a procedure @code{Func_2} that references +the variable @code{Sqrt_2}, which is declared in the elaboration code of +the body @code{Unit_2}: + +@smallexample @c ada +@cartouche +Sqrt_2 : Float := Sqrt (0.1); +@end cartouche +@end smallexample + +@noindent +The elaboration code of the body of @code{Unit_2} also contains: + +@smallexample @c ada +@group +@cartouche +if expression_2 = 2 then + Q := Unit_1.Func_1; +end if; +@end cartouche +@end group +@end smallexample + +@noindent +Now the question is, which of the following orders of elaboration is +acceptable: + +@smallexample +@group +Spec of Unit_1 +Spec of Unit_2 +Body of Unit_1 +Body of Unit_2 +@end group +@end smallexample + +@noindent +or + +@smallexample +@group +Spec of Unit_2 +Spec of Unit_1 +Body of Unit_2 +Body of Unit_1 +@end group +@end smallexample + +@noindent +If you carefully analyze the flow here, you will see that you cannot tell +at compile time the answer to this question. +If @code{expression_1} is not equal to 1, +and @code{expression_2} is not equal to 2, +then either order is acceptable, because neither of the function calls is +executed. If both tests evaluate to true, then neither order is acceptable +and in fact there is no correct order. + +If one of the two expressions is true, and the other is false, then one +of the above orders is correct, and the other is incorrect. For example, +if @code{expression_1} /= 1 and @code{expression_2} = 2, +then the call to @code{Func_1} +will occur, but not the call to @code{Func_2.} +This means that it is essential +to elaborate the body of @code{Unit_1} before +the body of @code{Unit_2}, so the first +order of elaboration is correct and the second is wrong. + +By making @code{expression_1} and @code{expression_2} +depend on input data, or perhaps +the time of day, we can make it impossible for the compiler or binder +to figure out which of these expressions will be true, and hence it +is impossible to guarantee a safe order of elaboration at run time. + +@node Checking the Elaboration Order +@section Checking the Elaboration Order + +@noindent +In some languages that involve the same kind of elaboration problems, +e.g.@: Java and C++, the programmer is expected to worry about these +ordering problems himself, and it is common to +write a program in which an incorrect elaboration order gives +surprising results, because it references variables before they +are initialized. +Ada is designed to be a safe language, and a programmer-beware approach is +clearly not sufficient. Consequently, the language provides three lines +of defense: + +@table @asis +@item Standard rules +Some standard rules restrict the possible choice of elaboration +order. In particular, if you @code{with} a unit, then its spec is always +elaborated before the unit doing the @code{with}. Similarly, a parent +spec is always elaborated before the child spec, and finally +a spec is always elaborated before its corresponding body. + +@item Dynamic elaboration checks +@cindex Elaboration checks +@cindex Checks, elaboration +Dynamic checks are made at run time, so that if some entity is accessed +before it is elaborated (typically by means of a subprogram call) +then the exception (@code{Program_Error}) is raised. + +@item Elaboration control +Facilities are provided for the programmer to specify the desired order +of elaboration. +@end table + +Let's look at these facilities in more detail. First, the rules for +dynamic checking. One possible rule would be simply to say that the +exception is raised if you access a variable which has not yet been +elaborated. The trouble with this approach is that it could require +expensive checks on every variable reference. Instead Ada has two +rules which are a little more restrictive, but easier to check, and +easier to state: + +@table @asis +@item Restrictions on calls +A subprogram can only be called at elaboration time if its body +has been elaborated. The rules for elaboration given above guarantee +that the spec of the subprogram has been elaborated before the +call, but not the body. If this rule is violated, then the +exception @code{Program_Error} is raised. + +@item Restrictions on instantiations +A generic unit can only be instantiated if the body of the generic +unit has been elaborated. Again, the rules for elaboration given above +guarantee that the spec of the generic unit has been elaborated +before the instantiation, but not the body. If this rule is +violated, then the exception @code{Program_Error} is raised. +@end table + +@noindent +The idea is that if the body has been elaborated, then any variables +it references must have been elaborated; by checking for the body being +elaborated we guarantee that none of its references causes any +trouble. As we noted above, this is a little too restrictive, because a +subprogram that has no non-local references in its body may in fact be safe +to call. However, it really would be unsafe to rely on this, because +it would mean that the caller was aware of details of the implementation +in the body. This goes against the basic tenets of Ada. + +A plausible implementation can be described as follows. +A Boolean variable is associated with each subprogram +and each generic unit. This variable is initialized to False, and is set to +True at the point body is elaborated. Every call or instantiation checks the +variable, and raises @code{Program_Error} if the variable is False. + +Note that one might think that it would be good enough to have one Boolean +variable for each package, but that would not deal with cases of trying +to call a body in the same package as the call +that has not been elaborated yet. +Of course a compiler may be able to do enough analysis to optimize away +some of the Boolean variables as unnecessary, and @code{GNAT} indeed +does such optimizations, but still the easiest conceptual model is to +think of there being one variable per subprogram. + +@node Controlling the Elaboration Order +@section Controlling the Elaboration Order + +@noindent +In the previous section we discussed the rules in Ada which ensure +that @code{Program_Error} is raised if an incorrect elaboration order is +chosen. This prevents erroneous executions, but we need mechanisms to +specify a correct execution and avoid the exception altogether. +To achieve this, Ada provides a number of features for controlling +the order of elaboration. We discuss these features in this section. + +First, there are several ways of indicating to the compiler that a given +unit has no elaboration problems: + +@table @asis +@item packages that do not require a body +A library package that does not require a body does not permit +a body (this rule was introduced in Ada 95). +Thus if we have a such a package, as in: + +@smallexample @c ada +@group +@cartouche +package Definitions is + generic + type m is new integer; + package Subp is + type a is array (1 .. 10) of m; + type b is array (1 .. 20) of m; + end Subp; +end Definitions; +@end cartouche +@end group +@end smallexample + +@noindent +A package that @code{with}'s @code{Definitions} may safely instantiate +@code{Definitions.Subp} because the compiler can determine that there +definitely is no package body to worry about in this case + +@item pragma Pure +@cindex pragma Pure +@findex Pure +Places sufficient restrictions on a unit to guarantee that +no call to any subprogram in the unit can result in an +elaboration problem. This means that the compiler does not need +to worry about the point of elaboration of such units, and in +particular, does not need to check any calls to any subprograms +in this unit. + +@item pragma Preelaborate +@findex Preelaborate +@cindex pragma Preelaborate +This pragma places slightly less stringent restrictions on a unit than +does pragma Pure, +but these restrictions are still sufficient to ensure that there +are no elaboration problems with any calls to the unit. + +@item pragma Elaborate_Body +@findex Elaborate_Body +@cindex pragma Elaborate_Body +This pragma requires that the body of a unit be elaborated immediately +after its spec. Suppose a unit @code{A} has such a pragma, +and unit @code{B} does +a @code{with} of unit @code{A}. Recall that the standard rules require +the spec of unit @code{A} +to be elaborated before the @code{with}'ing unit; given the pragma in +@code{A}, we also know that the body of @code{A} +will be elaborated before @code{B}, so +that calls to @code{A} are safe and do not need a check. +@end table + +@noindent +Note that, +unlike pragma @code{Pure} and pragma @code{Preelaborate}, +the use of +@code{Elaborate_Body} does not guarantee that the program is +free of elaboration problems, because it may not be possible +to satisfy the requested elaboration order. +Let's go back to the example with @code{Unit_1} and @code{Unit_2}. +If a programmer +marks @code{Unit_1} as @code{Elaborate_Body}, +and not @code{Unit_2,} then the order of +elaboration will be: + +@smallexample +@group +Spec of Unit_2 +Spec of Unit_1 +Body of Unit_1 +Body of Unit_2 +@end group +@end smallexample + +@noindent +Now that means that the call to @code{Func_1} in @code{Unit_2} +need not be checked, +it must be safe. But the call to @code{Func_2} in +@code{Unit_1} may still fail if +@code{Expression_1} is equal to 1, +and the programmer must still take +responsibility for this not being the case. + +If all units carry a pragma @code{Elaborate_Body}, then all problems are +eliminated, except for calls entirely within a body, which are +in any case fully under programmer control. However, using the pragma +everywhere is not always possible. +In particular, for our @code{Unit_1}/@code{Unit_2} example, if +we marked both of them as having pragma @code{Elaborate_Body}, then +clearly there would be no possible elaboration order. + +The above pragmas allow a server to guarantee safe use by clients, and +clearly this is the preferable approach. Consequently a good rule +is to mark units as @code{Pure} or @code{Preelaborate} if possible, +and if this is not possible, +mark them as @code{Elaborate_Body} if possible. +As we have seen, there are situations where neither of these +three pragmas can be used. +So we also provide methods for clients to control the +order of elaboration of the servers on which they depend: + +@table @asis +@item pragma Elaborate (unit) +@findex Elaborate +@cindex pragma Elaborate +This pragma is placed in the context clause, after a @code{with} clause, +and it requires that the body of the named unit be elaborated before +the unit in which the pragma occurs. The idea is to use this pragma +if the current unit calls at elaboration time, directly or indirectly, +some subprogram in the named unit. + +@item pragma Elaborate_All (unit) +@findex Elaborate_All +@cindex pragma Elaborate_All +This is a stronger version of the Elaborate pragma. Consider the +following example: + +@smallexample +Unit A @code{with}'s unit B and calls B.Func in elab code +Unit B @code{with}'s unit C, and B.Func calls C.Func +@end smallexample + +@noindent +Now if we put a pragma @code{Elaborate (B)} +in unit @code{A}, this ensures that the +body of @code{B} is elaborated before the call, but not the +body of @code{C}, so +the call to @code{C.Func} could still cause @code{Program_Error} to +be raised. + +The effect of a pragma @code{Elaborate_All} is stronger, it requires +not only that the body of the named unit be elaborated before the +unit doing the @code{with}, but also the bodies of all units that the +named unit uses, following @code{with} links transitively. For example, +if we put a pragma @code{Elaborate_All (B)} in unit @code{A}, +then it requires +not only that the body of @code{B} be elaborated before @code{A}, +but also the +body of @code{C}, because @code{B} @code{with}'s @code{C}. +@end table + +@noindent +We are now in a position to give a usage rule in Ada for avoiding +elaboration problems, at least if dynamic dispatching and access to +subprogram values are not used. We will handle these cases separately +later. + +The rule is simple. If a unit has elaboration code that can directly or +indirectly make a call to a subprogram in a @code{with}'ed unit, or instantiate +a generic package in a @code{with}'ed unit, +then if the @code{with}'ed unit does not have +pragma @code{Pure} or @code{Preelaborate}, then the client should have +a pragma @code{Elaborate_All} +for the @code{with}'ed unit. By following this rule a client is +assured that calls can be made without risk of an exception. + +For generic subprogram instantiations, the rule can be relaxed to +require only a pragma @code{Elaborate} since elaborating the body +of a subprogram cannot cause any transitive elaboration (we are +not calling the subprogram in this case, just elaborating its +declaration). + +If this rule is not followed, then a program may be in one of four +states: + +@table @asis +@item No order exists +No order of elaboration exists which follows the rules, taking into +account any @code{Elaborate}, @code{Elaborate_All}, +or @code{Elaborate_Body} pragmas. In +this case, an Ada compiler must diagnose the situation at bind +time, and refuse to build an executable program. + +@item One or more orders exist, all incorrect +One or more acceptable elaboration orders exist, and all of them +generate an elaboration order problem. In this case, the binder +can build an executable program, but @code{Program_Error} will be raised +when the program is run. + +@item Several orders exist, some right, some incorrect +One or more acceptable elaboration orders exists, and some of them +work, and some do not. The programmer has not controlled +the order of elaboration, so the binder may or may not pick one of +the correct orders, and the program may or may not raise an +exception when it is run. This is the worst case, because it means +that the program may fail when moved to another compiler, or even +another version of the same compiler. + +@item One or more orders exists, all correct +One ore more acceptable elaboration orders exist, and all of them +work. In this case the program runs successfully. This state of +affairs can be guaranteed by following the rule we gave above, but +may be true even if the rule is not followed. +@end table + +@noindent +Note that one additional advantage of following our rules on the use +of @code{Elaborate} and @code{Elaborate_All} +is that the program continues to stay in the ideal (all orders OK) state +even if maintenance +changes some bodies of some units. Conversely, if a program that does +not follow this rule happens to be safe at some point, this state of affairs +may deteriorate silently as a result of maintenance changes. + +You may have noticed that the above discussion did not mention +the use of @code{Elaborate_Body}. This was a deliberate omission. If you +@code{with} an @code{Elaborate_Body} unit, it still may be the case that +code in the body makes calls to some other unit, so it is still necessary +to use @code{Elaborate_All} on such units. + +@node Controlling Elaboration in GNAT - Internal Calls +@section Controlling Elaboration in GNAT - Internal Calls + +@noindent +In the case of internal calls, i.e., calls within a single package, the +programmer has full control over the order of elaboration, and it is up +to the programmer to elaborate declarations in an appropriate order. For +example writing: + +@smallexample @c ada +@group +@cartouche +function One return Float; + +Q : Float := One; + +function One return Float is +begin + return 1.0; +end One; +@end cartouche +@end group +@end smallexample + +@noindent +will obviously raise @code{Program_Error} at run time, because function +One will be called before its body is elaborated. In this case GNAT will +generate a warning that the call will raise @code{Program_Error}: + +@smallexample +@group +@cartouche + 1. procedure y is + 2. function One return Float; + 3. + 4. Q : Float := One; + | + >>> warning: cannot call "One" before body is elaborated + >>> warning: Program_Error will be raised at run time + + 5. + 6. function One return Float is + 7. begin + 8. return 1.0; + 9. end One; +10. +11. begin +12. null; +13. end; +@end cartouche +@end group +@end smallexample + +@noindent +Note that in this particular case, it is likely that the call is safe, because +the function @code{One} does not access any global variables. +Nevertheless in Ada, we do not want the validity of the check to depend on +the contents of the body (think about the separate compilation case), so this +is still wrong, as we discussed in the previous sections. + +The error is easily corrected by rearranging the declarations so that the +body of @code{One} appears before the declaration containing the call +(note that in Ada 95 and Ada 2005, +declarations can appear in any order, so there is no restriction that +would prevent this reordering, and if we write: + +@smallexample @c ada +@group +@cartouche +function One return Float; + +function One return Float is +begin + return 1.0; +end One; + +Q : Float := One; +@end cartouche +@end group +@end smallexample + +@noindent +then all is well, no warning is generated, and no +@code{Program_Error} exception +will be raised. +Things are more complicated when a chain of subprograms is executed: + +@smallexample @c ada +@group +@cartouche +function A return Integer; +function B return Integer; +function C return Integer; + +function B return Integer is begin return A; end; +function C return Integer is begin return B; end; + +X : Integer := C; + +function A return Integer is begin return 1; end; +@end cartouche +@end group +@end smallexample + +@noindent +Now the call to @code{C} +at elaboration time in the declaration of @code{X} is correct, because +the body of @code{C} is already elaborated, +and the call to @code{B} within the body of +@code{C} is correct, but the call +to @code{A} within the body of @code{B} is incorrect, because the body +of @code{A} has not been elaborated, so @code{Program_Error} +will be raised on the call to @code{A}. +In this case GNAT will generate a +warning that @code{Program_Error} may be +raised at the point of the call. Let's look at the warning: + +@smallexample +@group +@cartouche + 1. procedure x is + 2. function A return Integer; + 3. function B return Integer; + 4. function C return Integer; + 5. + 6. function B return Integer is begin return A; end; + | + >>> warning: call to "A" before body is elaborated may + raise Program_Error + >>> warning: "B" called at line 7 + >>> warning: "C" called at line 9 + + 7. function C return Integer is begin return B; end; + 8. + 9. X : Integer := C; +10. +11. function A return Integer is begin return 1; end; +12. +13. begin +14. null; +15. end; +@end cartouche +@end group +@end smallexample + +@noindent +Note that the message here says ``may raise'', instead of the direct case, +where the message says ``will be raised''. That's because whether +@code{A} is +actually called depends in general on run-time flow of control. +For example, if the body of @code{B} said + +@smallexample @c ada +@group +@cartouche +function B return Integer is +begin + if some-condition-depending-on-input-data then + return A; + else + return 1; + end if; +end B; +@end cartouche +@end group +@end smallexample + +@noindent +then we could not know until run time whether the incorrect call to A would +actually occur, so @code{Program_Error} might +or might not be raised. It is possible for a compiler to +do a better job of analyzing bodies, to +determine whether or not @code{Program_Error} +might be raised, but it certainly +couldn't do a perfect job (that would require solving the halting problem +and is provably impossible), and because this is a warning anyway, it does +not seem worth the effort to do the analysis. Cases in which it +would be relevant are rare. + +In practice, warnings of either of the forms given +above will usually correspond to +real errors, and should be examined carefully and eliminated. +In the rare case where a warning is bogus, it can be suppressed by any of +the following methods: + +@itemize @bullet +@item +Compile with the @option{-gnatws} switch set + +@item +Suppress @code{Elaboration_Check} for the called subprogram + +@item +Use pragma @code{Warnings_Off} to turn warnings off for the call +@end itemize + +@noindent +For the internal elaboration check case, +GNAT by default generates the +necessary run-time checks to ensure +that @code{Program_Error} is raised if any +call fails an elaboration check. Of course this can only happen if a +warning has been issued as described above. The use of pragma +@code{Suppress (Elaboration_Check)} may (but is not guaranteed to) suppress +some of these checks, meaning that it may be possible (but is not +guaranteed) for a program to be able to call a subprogram whose body +is not yet elaborated, without raising a @code{Program_Error} exception. + +@node Controlling Elaboration in GNAT - External Calls +@section Controlling Elaboration in GNAT - External Calls + +@noindent +The previous section discussed the case in which the execution of a +particular thread of elaboration code occurred entirely within a +single unit. This is the easy case to handle, because a programmer +has direct and total control over the order of elaboration, and +furthermore, checks need only be generated in cases which are rare +and which the compiler can easily detect. +The situation is more complex when separate compilation is taken into account. +Consider the following: + +@smallexample @c ada +@cartouche +@group +package Math is + function Sqrt (Arg : Float) return Float; +end Math; + +package body Math is + function Sqrt (Arg : Float) return Float is + begin + @dots{} + end Sqrt; +end Math; +@end group +@group +with Math; +package Stuff is + X : Float := Math.Sqrt (0.5); +end Stuff; + +with Stuff; +procedure Main is +begin + @dots{} +end Main; +@end group +@end cartouche +@end smallexample + +@noindent +where @code{Main} is the main program. When this program is executed, the +elaboration code must first be executed, and one of the jobs of the +binder is to determine the order in which the units of a program are +to be elaborated. In this case we have four units: the spec and body +of @code{Math}, +the spec of @code{Stuff} and the body of @code{Main}). +In what order should the four separate sections of elaboration code +be executed? + +There are some restrictions in the order of elaboration that the binder +can choose. In particular, if unit U has a @code{with} +for a package @code{X}, then you +are assured that the spec of @code{X} +is elaborated before U , but you are +not assured that the body of @code{X} +is elaborated before U. +This means that in the above case, the binder is allowed to choose the +order: + +@smallexample +spec of Math +spec of Stuff +body of Math +body of Main +@end smallexample + +@noindent +but that's not good, because now the call to @code{Math.Sqrt} +that happens during +the elaboration of the @code{Stuff} +spec happens before the body of @code{Math.Sqrt} is +elaborated, and hence causes @code{Program_Error} exception to be raised. +At first glance, one might say that the binder is misbehaving, because +obviously you want to elaborate the body of something you @code{with} +first, but +that is not a general rule that can be followed in all cases. Consider + +@smallexample @c ada +@group +@cartouche +package X is @dots{} + +package Y is @dots{} + +with X; +package body Y is @dots{} + +with Y; +package body X is @dots{} +@end cartouche +@end group +@end smallexample + +@noindent +This is a common arrangement, and, apart from the order of elaboration +problems that might arise in connection with elaboration code, this works fine. +A rule that says that you must first elaborate the body of anything you +@code{with} cannot work in this case: +the body of @code{X} @code{with}'s @code{Y}, +which means you would have to +elaborate the body of @code{Y} first, but that @code{with}'s @code{X}, +which means +you have to elaborate the body of @code{X} first, but @dots{} and we have a +loop that cannot be broken. + +It is true that the binder can in many cases guess an order of elaboration +that is unlikely to cause a @code{Program_Error} +exception to be raised, and it tries to do so (in the +above example of @code{Math/Stuff/Spec}, the GNAT binder will +by default +elaborate the body of @code{Math} right after its spec, so all will be well). + +However, a program that blindly relies on the binder to be helpful can +get into trouble, as we discussed in the previous sections, so +GNAT +provides a number of facilities for assisting the programmer in +developing programs that are robust with respect to elaboration order. + +@node Default Behavior in GNAT - Ensuring Safety +@section Default Behavior in GNAT - Ensuring Safety + +@noindent +The default behavior in GNAT ensures elaboration safety. In its +default mode GNAT implements the +rule we previously described as the right approach. Let's restate it: + +@itemize +@item +@emph{If a unit has elaboration code that can directly or indirectly make a +call to a subprogram in a @code{with}'ed unit, or instantiate a generic +package in a @code{with}'ed unit, then if the @code{with}'ed unit +does not have pragma @code{Pure} or +@code{Preelaborate}, then the client should have an +@code{Elaborate_All} pragma for the @code{with}'ed unit.} + +@emph{In the case of instantiating a generic subprogram, it is always +sufficient to have only an @code{Elaborate} pragma for the +@code{with}'ed unit.} +@end itemize + +@noindent +By following this rule a client is assured that calls and instantiations +can be made without risk of an exception. + +In this mode GNAT traces all calls that are potentially made from +elaboration code, and puts in any missing implicit @code{Elaborate} +and @code{Elaborate_All} pragmas. +The advantage of this approach is that no elaboration problems +are possible if the binder can find an elaboration order that is +consistent with these implicit @code{Elaborate} and +@code{Elaborate_All} pragmas. The +disadvantage of this approach is that no such order may exist. + +If the binder does not generate any diagnostics, then it means that it has +found an elaboration order that is guaranteed to be safe. However, the binder +may still be relying on implicitly generated @code{Elaborate} and +@code{Elaborate_All} pragmas so portability to other compilers than GNAT is not +guaranteed. + +If it is important to guarantee portability, then the compilations should +use the +@option{-gnatwl} +(warn on elaboration problems) switch. This will cause warning messages +to be generated indicating the missing @code{Elaborate} and +@code{Elaborate_All} pragmas. +Consider the following source program: + +@smallexample @c ada +@group +@cartouche +with k; +package j is + m : integer := k.r; +end; +@end cartouche +@end group +@end smallexample + +@noindent +where it is clear that there +should be a pragma @code{Elaborate_All} +for unit @code{k}. An implicit pragma will be generated, and it is +likely that the binder will be able to honor it. However, if you want +to port this program to some other Ada compiler than GNAT. +it is safer to include the pragma explicitly in the source. If this +unit is compiled with the +@option{-gnatwl} +switch, then the compiler outputs a warning: + +@smallexample +@group +@cartouche +1. with k; +2. package j is +3. m : integer := k.r; + | + >>> warning: call to "r" may raise Program_Error + >>> warning: missing pragma Elaborate_All for "k" + +4. end; +@end cartouche +@end group +@end smallexample + +@noindent +and these warnings can be used as a guide for supplying manually +the missing pragmas. It is usually a bad idea to use this warning +option during development. That's because it will warn you when +you need to put in a pragma, but cannot warn you when it is time +to take it out. So the use of pragma @code{Elaborate_All} may lead to +unnecessary dependencies and even false circularities. + +This default mode is more restrictive than the Ada Reference +Manual, and it is possible to construct programs which will compile +using the dynamic model described there, but will run into a +circularity using the safer static model we have described. + +Of course any Ada compiler must be able to operate in a mode +consistent with the requirements of the Ada Reference Manual, +and in particular must have the capability of implementing the +standard dynamic model of elaboration with run-time checks. + +In GNAT, this standard mode can be achieved either by the use of +the @option{-gnatE} switch on the compiler (@command{gcc} or +@command{gnatmake}) command, or by the use of the configuration pragma: + +@smallexample @c ada +pragma Elaboration_Checks (DYNAMIC); +@end smallexample + +@noindent +Either approach will cause the unit affected to be compiled using the +standard dynamic run-time elaboration checks described in the Ada +Reference Manual. The static model is generally preferable, since it +is clearly safer to rely on compile and link time checks rather than +run-time checks. However, in the case of legacy code, it may be +difficult to meet the requirements of the static model. This +issue is further discussed in +@ref{What to Do If the Default Elaboration Behavior Fails}. + +Note that the static model provides a strict subset of the allowed +behavior and programs of the Ada Reference Manual, so if you do +adhere to the static model and no circularities exist, +then you are assured that your program will +work using the dynamic model, providing that you remove any +pragma Elaborate statements from the source. + +@node Treatment of Pragma Elaborate +@section Treatment of Pragma Elaborate +@cindex Pragma Elaborate + +@noindent +The use of @code{pragma Elaborate} +should generally be avoided in Ada 95 and Ada 2005 programs, +since there is no guarantee that transitive calls +will be properly handled. Indeed at one point, this pragma was placed +in Annex J (Obsolescent Features), on the grounds that it is never useful. + +Now that's a bit restrictive. In practice, the case in which +@code{pragma Elaborate} is useful is when the caller knows that there +are no transitive calls, or that the called unit contains all necessary +transitive @code{pragma Elaborate} statements, and legacy code often +contains such uses. + +Strictly speaking the static mode in GNAT should ignore such pragmas, +since there is no assurance at compile time that the necessary safety +conditions are met. In practice, this would cause GNAT to be incompatible +with correctly written Ada 83 code that had all necessary +@code{pragma Elaborate} statements in place. Consequently, we made the +decision that GNAT in its default mode will believe that if it encounters +a @code{pragma Elaborate} then the programmer knows what they are doing, +and it will trust that no elaboration errors can occur. + +The result of this decision is two-fold. First to be safe using the +static mode, you should remove all @code{pragma Elaborate} statements. +Second, when fixing circularities in existing code, you can selectively +use @code{pragma Elaborate} statements to convince the static mode of +GNAT that it need not generate an implicit @code{pragma Elaborate_All} +statement. + +When using the static mode with @option{-gnatwl}, any use of +@code{pragma Elaborate} will generate a warning about possible +problems. + +@node Elaboration Issues for Library Tasks +@section Elaboration Issues for Library Tasks +@cindex Library tasks, elaboration issues +@cindex Elaboration of library tasks + +@noindent +In this section we examine special elaboration issues that arise for +programs that declare library level tasks. + +Generally the model of execution of an Ada program is that all units are +elaborated, and then execution of the program starts. However, the +declaration of library tasks definitely does not fit this model. The +reason for this is that library tasks start as soon as they are declared +(more precisely, as soon as the statement part of the enclosing package +body is reached), that is to say before elaboration +of the program is complete. This means that if such a task calls a +subprogram, or an entry in another task, the callee may or may not be +elaborated yet, and in the standard +Reference Manual model of dynamic elaboration checks, you can even +get timing dependent Program_Error exceptions, since there can be +a race between the elaboration code and the task code. + +The static model of elaboration in GNAT seeks to avoid all such +dynamic behavior, by being conservative, and the conservative +approach in this particular case is to assume that all the code +in a task body is potentially executed at elaboration time if +a task is declared at the library level. + +This can definitely result in unexpected circularities. Consider +the following example + +@smallexample @c ada +package Decls is + task Lib_Task is + entry Start; + end Lib_Task; + + type My_Int is new Integer; + + function Ident (M : My_Int) return My_Int; +end Decls; + +with Utils; +package body Decls is + task body Lib_Task is + begin + accept Start; + Utils.Put_Val (2); + end Lib_Task; + + function Ident (M : My_Int) return My_Int is + begin + return M; + end Ident; +end Decls; + +with Decls; +package Utils is + procedure Put_Val (Arg : Decls.My_Int); +end Utils; + +with Text_IO; +package body Utils is + procedure Put_Val (Arg : Decls.My_Int) is + begin + Text_IO.Put_Line (Decls.My_Int'Image (Decls.Ident (Arg))); + end Put_Val; +end Utils; + +with Decls; +procedure Main is +begin + Decls.Lib_Task.Start; +end; +@end smallexample + +@noindent +If the above example is compiled in the default static elaboration +mode, then a circularity occurs. The circularity comes from the call +@code{Utils.Put_Val} in the task body of @code{Decls.Lib_Task}. Since +this call occurs in elaboration code, we need an implicit pragma +@code{Elaborate_All} for @code{Utils}. This means that not only must +the spec and body of @code{Utils} be elaborated before the body +of @code{Decls}, but also the spec and body of any unit that is +@code{with'ed} by the body of @code{Utils} must also be elaborated before +the body of @code{Decls}. This is the transitive implication of +pragma @code{Elaborate_All} and it makes sense, because in general +the body of @code{Put_Val} might have a call to something in a +@code{with'ed} unit. + +In this case, the body of Utils (actually its spec) @code{with's} +@code{Decls}. Unfortunately this means that the body of @code{Decls} +must be elaborated before itself, in case there is a call from the +body of @code{Utils}. + +Here is the exact chain of events we are worrying about: + +@enumerate +@item +In the body of @code{Decls} a call is made from within the body of a library +task to a subprogram in the package @code{Utils}. Since this call may +occur at elaboration time (given that the task is activated at elaboration +time), we have to assume the worst, i.e., that the +call does happen at elaboration time. + +@item +This means that the body and spec of @code{Util} must be elaborated before +the body of @code{Decls} so that this call does not cause an access before +elaboration. + +@item +Within the body of @code{Util}, specifically within the body of +@code{Util.Put_Val} there may be calls to any unit @code{with}'ed +by this package. + +@item +One such @code{with}'ed package is package @code{Decls}, so there +might be a call to a subprogram in @code{Decls} in @code{Put_Val}. +In fact there is such a call in this example, but we would have to +assume that there was such a call even if it were not there, since +we are not supposed to write the body of @code{Decls} knowing what +is in the body of @code{Utils}; certainly in the case of the +static elaboration model, the compiler does not know what is in +other bodies and must assume the worst. + +@item +This means that the spec and body of @code{Decls} must also be +elaborated before we elaborate the unit containing the call, but +that unit is @code{Decls}! This means that the body of @code{Decls} +must be elaborated before itself, and that's a circularity. +@end enumerate + +@noindent +Indeed, if you add an explicit pragma @code{Elaborate_All} for @code{Utils} in +the body of @code{Decls} you will get a true Ada Reference Manual +circularity that makes the program illegal. + +In practice, we have found that problems with the static model of +elaboration in existing code often arise from library tasks, so +we must address this particular situation. + +Note that if we compile and run the program above, using the dynamic model of +elaboration (that is to say use the @option{-gnatE} switch), +then it compiles, binds, +links, and runs, printing the expected result of 2. Therefore in some sense +the circularity here is only apparent, and we need to capture +the properties of this program that distinguish it from other library-level +tasks that have real elaboration problems. + +We have four possible answers to this question: + +@itemize @bullet + +@item +Use the dynamic model of elaboration. + +If we use the @option{-gnatE} switch, then as noted above, the program works. +Why is this? If we examine the task body, it is apparent that the task cannot +proceed past the +@code{accept} statement until after elaboration has been completed, because +the corresponding entry call comes from the main program, not earlier. +This is why the dynamic model works here. But that's really giving +up on a precise analysis, and we prefer to take this approach only if we cannot +solve the +problem in any other manner. So let us examine two ways to reorganize +the program to avoid the potential elaboration problem. + +@item +Split library tasks into separate packages. + +Write separate packages, so that library tasks are isolated from +other declarations as much as possible. Let us look at a variation on +the above program. + +@smallexample @c ada +package Decls1 is + task Lib_Task is + entry Start; + end Lib_Task; +end Decls1; + +with Utils; +package body Decls1 is + task body Lib_Task is + begin + accept Start; + Utils.Put_Val (2); + end Lib_Task; +end Decls1; + +package Decls2 is + type My_Int is new Integer; + function Ident (M : My_Int) return My_Int; +end Decls2; + +with Utils; +package body Decls2 is + function Ident (M : My_Int) return My_Int is + begin + return M; + end Ident; +end Decls2; + +with Decls2; +package Utils is + procedure Put_Val (Arg : Decls2.My_Int); +end Utils; + +with Text_IO; +package body Utils is + procedure Put_Val (Arg : Decls2.My_Int) is + begin + Text_IO.Put_Line (Decls2.My_Int'Image (Decls2.Ident (Arg))); + end Put_Val; +end Utils; + +with Decls1; +procedure Main is +begin + Decls1.Lib_Task.Start; +end; +@end smallexample + +@noindent +All we have done is to split @code{Decls} into two packages, one +containing the library task, and one containing everything else. Now +there is no cycle, and the program compiles, binds, links and executes +using the default static model of elaboration. + +@item +Declare separate task types. + +A significant part of the problem arises because of the use of the +single task declaration form. This means that the elaboration of +the task type, and the elaboration of the task itself (i.e.@: the +creation of the task) happen at the same time. A good rule +of style in Ada is to always create explicit task types. By +following the additional step of placing task objects in separate +packages from the task type declaration, many elaboration problems +are avoided. Here is another modified example of the example program: + +@smallexample @c ada +package Decls is + task type Lib_Task_Type is + entry Start; + end Lib_Task_Type; + + type My_Int is new Integer; + + function Ident (M : My_Int) return My_Int; +end Decls; + +with Utils; +package body Decls is + task body Lib_Task_Type is + begin + accept Start; + Utils.Put_Val (2); + end Lib_Task_Type; + + function Ident (M : My_Int) return My_Int is + begin + return M; + end Ident; +end Decls; + +with Decls; +package Utils is + procedure Put_Val (Arg : Decls.My_Int); +end Utils; + +with Text_IO; +package body Utils is + procedure Put_Val (Arg : Decls.My_Int) is + begin + Text_IO.Put_Line (Decls.My_Int'Image (Decls.Ident (Arg))); + end Put_Val; +end Utils; + +with Decls; +package Declst is + Lib_Task : Decls.Lib_Task_Type; +end Declst; + +with Declst; +procedure Main is +begin + Declst.Lib_Task.Start; +end; +@end smallexample + +@noindent +What we have done here is to replace the @code{task} declaration in +package @code{Decls} with a @code{task type} declaration. Then we +introduce a separate package @code{Declst} to contain the actual +task object. This separates the elaboration issues for +the @code{task type} +declaration, which causes no trouble, from the elaboration issues +of the task object, which is also unproblematic, since it is now independent +of the elaboration of @code{Utils}. +This separation of concerns also corresponds to +a generally sound engineering principle of separating declarations +from instances. This version of the program also compiles, binds, links, +and executes, generating the expected output. + +@item +Use No_Entry_Calls_In_Elaboration_Code restriction. +@cindex No_Entry_Calls_In_Elaboration_Code + +The previous two approaches described how a program can be restructured +to avoid the special problems caused by library task bodies. in practice, +however, such restructuring may be difficult to apply to existing legacy code, +so we must consider solutions that do not require massive rewriting. + +Let us consider more carefully why our original sample program works +under the dynamic model of elaboration. The reason is that the code +in the task body blocks immediately on the @code{accept} +statement. Now of course there is nothing to prohibit elaboration +code from making entry calls (for example from another library level task), +so we cannot tell in isolation that +the task will not execute the accept statement during elaboration. + +However, in practice it is very unusual to see elaboration code +make any entry calls, and the pattern of tasks starting +at elaboration time and then immediately blocking on @code{accept} or +@code{select} statements is very common. What this means is that +the compiler is being too pessimistic when it analyzes the +whole package body as though it might be executed at elaboration +time. + +If we know that the elaboration code contains no entry calls, (a very safe +assumption most of the time, that could almost be made the default +behavior), then we can compile all units of the program under control +of the following configuration pragma: + +@smallexample +pragma Restrictions (No_Entry_Calls_In_Elaboration_Code); +@end smallexample + +@noindent +This pragma can be placed in the @file{gnat.adc} file in the usual +manner. If we take our original unmodified program and compile it +in the presence of a @file{gnat.adc} containing the above pragma, +then once again, we can compile, bind, link, and execute, obtaining +the expected result. In the presence of this pragma, the compiler does +not trace calls in a task body, that appear after the first @code{accept} +or @code{select} statement, and therefore does not report a potential +circularity in the original program. + +The compiler will check to the extent it can that the above +restriction is not violated, but it is not always possible to do a +complete check at compile time, so it is important to use this +pragma only if the stated restriction is in fact met, that is to say +no task receives an entry call before elaboration of all units is completed. + +@end itemize + +@node Mixing Elaboration Models +@section Mixing Elaboration Models +@noindent +So far, we have assumed that the entire program is either compiled +using the dynamic model or static model, ensuring consistency. It +is possible to mix the two models, but rules have to be followed +if this mixing is done to ensure that elaboration checks are not +omitted. + +The basic rule is that @emph{a unit compiled with the static model cannot +be @code{with'ed} by a unit compiled with the dynamic model}. The +reason for this is that in the static model, a unit assumes that +its clients guarantee to use (the equivalent of) pragma +@code{Elaborate_All} so that no elaboration checks are required +in inner subprograms, and this assumption is violated if the +client is compiled with dynamic checks. + +The precise rule is as follows. A unit that is compiled with dynamic +checks can only @code{with} a unit that meets at least one of the +following criteria: + +@itemize @bullet + +@item +The @code{with'ed} unit is itself compiled with dynamic elaboration +checks (that is with the @option{-gnatE} switch. + +@item +The @code{with'ed} unit is an internal GNAT implementation unit from +the System, Interfaces, Ada, or GNAT hierarchies. + +@item +The @code{with'ed} unit has pragma Preelaborate or pragma Pure. + +@item +The @code{with'ing} unit (that is the client) has an explicit pragma +@code{Elaborate_All} for the @code{with'ed} unit. + +@end itemize + +@noindent +If this rule is violated, that is if a unit with dynamic elaboration +checks @code{with's} a unit that does not meet one of the above four +criteria, then the binder (@code{gnatbind}) will issue a warning +similar to that in the following example: + +@smallexample +warning: "x.ads" has dynamic elaboration checks and with's +warning: "y.ads" which has static elaboration checks +@end smallexample + +@noindent +These warnings indicate that the rule has been violated, and that as a result +elaboration checks may be missed in the resulting executable file. +This warning may be suppressed using the @option{-ws} binder switch +in the usual manner. + +One useful application of this mixing rule is in the case of a subsystem +which does not itself @code{with} units from the remainder of the +application. In this case, the entire subsystem can be compiled with +dynamic checks to resolve a circularity in the subsystem, while +allowing the main application that uses this subsystem to be compiled +using the more reliable default static model. + +@node What to Do If the Default Elaboration Behavior Fails +@section What to Do If the Default Elaboration Behavior Fails + +@noindent +If the binder cannot find an acceptable order, it outputs detailed +diagnostics. For example: +@smallexample +@group +@iftex +@leftskip=0cm +@end iftex +error: elaboration circularity detected +info: "proc (body)" must be elaborated before "pack (body)" +info: reason: Elaborate_All probably needed in unit "pack (body)" +info: recompile "pack (body)" with -gnatwl +info: for full details +info: "proc (body)" +info: is needed by its spec: +info: "proc (spec)" +info: which is withed by: +info: "pack (body)" +info: "pack (body)" must be elaborated before "proc (body)" +info: reason: pragma Elaborate in unit "proc (body)" +@end group + +@end smallexample + +@noindent +In this case we have a cycle that the binder cannot break. On the one +hand, there is an explicit pragma Elaborate in @code{proc} for +@code{pack}. This means that the body of @code{pack} must be elaborated +before the body of @code{proc}. On the other hand, there is elaboration +code in @code{pack} that calls a subprogram in @code{proc}. This means +that for maximum safety, there should really be a pragma +Elaborate_All in @code{pack} for @code{proc} which would require that +the body of @code{proc} be elaborated before the body of +@code{pack}. Clearly both requirements cannot be satisfied. +Faced with a circularity of this kind, you have three different options. + +@table @asis +@item Fix the program +The most desirable option from the point of view of long-term maintenance +is to rearrange the program so that the elaboration problems are avoided. +One useful technique is to place the elaboration code into separate +child packages. Another is to move some of the initialization code to +explicitly called subprograms, where the program controls the order +of initialization explicitly. Although this is the most desirable option, +it may be impractical and involve too much modification, especially in +the case of complex legacy code. + +@item Perform dynamic checks +If the compilations are done using the +@option{-gnatE} +(dynamic elaboration check) switch, then GNAT behaves in a quite different +manner. Dynamic checks are generated for all calls that could possibly result +in raising an exception. With this switch, the compiler does not generate +implicit @code{Elaborate} or @code{Elaborate_All} pragmas. The behavior then is +exactly as specified in the @cite{Ada Reference Manual}. +The binder will generate +an executable program that may or may not raise @code{Program_Error}, and then +it is the programmer's job to ensure that it does not raise an exception. Note +that it is important to compile all units with the switch, it cannot be used +selectively. + +@item Suppress checks +The drawback of dynamic checks is that they generate a +significant overhead at run time, both in space and time. If you +are absolutely sure that your program cannot raise any elaboration +exceptions, and you still want to use the dynamic elaboration model, +then you can use the configuration pragma +@code{Suppress (Elaboration_Check)} to suppress all such checks. For +example this pragma could be placed in the @file{gnat.adc} file. + +@item Suppress checks selectively +When you know that certain calls or instantiations in elaboration code cannot +possibly lead to an elaboration error, and the binder nevertheless complains +about implicit @code{Elaborate} and @code{Elaborate_All} pragmas that lead to +elaboration circularities, it is possible to remove those warnings locally and +obtain a program that will bind. Clearly this can be unsafe, and it is the +responsibility of the programmer to make sure that the resulting program has no +elaboration anomalies. The pragma @code{Suppress (Elaboration_Check)} can be +used with different granularity to suppress warnings and break elaboration +circularities: + +@itemize @bullet +@item +Place the pragma that names the called subprogram in the declarative part +that contains the call. + +@item +Place the pragma in the declarative part, without naming an entity. This +disables warnings on all calls in the corresponding declarative region. + +@item +Place the pragma in the package spec that declares the called subprogram, +and name the subprogram. This disables warnings on all elaboration calls to +that subprogram. + +@item +Place the pragma in the package spec that declares the called subprogram, +without naming any entity. This disables warnings on all elaboration calls to +all subprograms declared in this spec. + +@item Use Pragma Elaborate +As previously described in section @xref{Treatment of Pragma Elaborate}, +GNAT in static mode assumes that a @code{pragma} Elaborate indicates correctly +that no elaboration checks are required on calls to the designated unit. +There may be cases in which the caller knows that no transitive calls +can occur, so that a @code{pragma Elaborate} will be sufficient in a +case where @code{pragma Elaborate_All} would cause a circularity. +@end itemize + +@noindent +These five cases are listed in order of decreasing safety, and therefore +require increasing programmer care in their application. Consider the +following program: + +@smallexample @c adanocomment +package Pack1 is + function F1 return Integer; + X1 : Integer; +end Pack1; + +package Pack2 is + function F2 return Integer; + function Pure (x : integer) return integer; + -- pragma Suppress (Elaboration_Check, On => Pure); -- (3) + -- pragma Suppress (Elaboration_Check); -- (4) +end Pack2; + +with Pack2; +package body Pack1 is + function F1 return Integer is + begin + return 100; + end F1; + Val : integer := Pack2.Pure (11); -- Elab. call (1) +begin + declare + -- pragma Suppress(Elaboration_Check, Pack2.F2); -- (1) + -- pragma Suppress(Elaboration_Check); -- (2) + begin + X1 := Pack2.F2 + 1; -- Elab. call (2) + end; +end Pack1; + +with Pack1; +package body Pack2 is + function F2 return Integer is + begin + return Pack1.F1; + end F2; + function Pure (x : integer) return integer is + begin + return x ** 3 - 3 * x; + end; +end Pack2; + +with Pack1, Ada.Text_IO; +procedure Proc3 is +begin + Ada.Text_IO.Put_Line(Pack1.X1'Img); -- 101 +end Proc3; +@end smallexample +In the absence of any pragmas, an attempt to bind this program produces +the following diagnostics: +@smallexample +@group +@iftex +@leftskip=.5cm +@end iftex +error: elaboration circularity detected +info: "pack1 (body)" must be elaborated before "pack1 (body)" +info: reason: Elaborate_All probably needed in unit "pack1 (body)" +info: recompile "pack1 (body)" with -gnatwl for full details +info: "pack1 (body)" +info: must be elaborated along with its spec: +info: "pack1 (spec)" +info: which is withed by: +info: "pack2 (body)" +info: which must be elaborated along with its spec: +info: "pack2 (spec)" +info: which is withed by: +info: "pack1 (body)" +@end group +@end smallexample +The sources of the circularity are the two calls to @code{Pack2.Pure} and +@code{Pack2.F2} in the body of @code{Pack1}. We can see that the call to +F2 is safe, even though F2 calls F1, because the call appears after the +elaboration of the body of F1. Therefore the pragma (1) is safe, and will +remove the warning on the call. It is also possible to use pragma (2) +because there are no other potentially unsafe calls in the block. + +@noindent +The call to @code{Pure} is safe because this function does not depend on the +state of @code{Pack2}. Therefore any call to this function is safe, and it +is correct to place pragma (3) in the corresponding package spec. + +@noindent +Finally, we could place pragma (4) in the spec of @code{Pack2} to disable +warnings on all calls to functions declared therein. Note that this is not +necessarily safe, and requires more detailed examination of the subprogram +bodies involved. In particular, a call to @code{F2} requires that @code{F1} +be already elaborated. +@end table + +@noindent +It is hard to generalize on which of these four approaches should be +taken. Obviously if it is possible to fix the program so that the default +treatment works, this is preferable, but this may not always be practical. +It is certainly simple enough to use +@option{-gnatE} +but the danger in this case is that, even if the GNAT binder +finds a correct elaboration order, it may not always do so, +and certainly a binder from another Ada compiler might not. A +combination of testing and analysis (for which the warnings generated +with the +@option{-gnatwl} +switch can be useful) must be used to ensure that the program is free +of errors. One switch that is useful in this testing is the +@option{^-p (pessimistic elaboration order)^/PESSIMISTIC_ELABORATION_ORDER^} +switch for +@code{gnatbind}. +Normally the binder tries to find an order that has the best chance +of avoiding elaboration problems. However, if this switch is used, the binder +plays a devil's advocate role, and tries to choose the order that +has the best chance of failing. If your program works even with this +switch, then it has a better chance of being error free, but this is still +not a guarantee. + +For an example of this approach in action, consider the C-tests (executable +tests) from the ACVC suite. If these are compiled and run with the default +treatment, then all but one of them succeed without generating any error +diagnostics from the binder. However, there is one test that fails, and +this is not surprising, because the whole point of this test is to ensure +that the compiler can handle cases where it is impossible to determine +a correct order statically, and it checks that an exception is indeed +raised at run time. + +This one test must be compiled and run using the +@option{-gnatE} +switch, and then it passes. Alternatively, the entire suite can +be run using this switch. It is never wrong to run with the dynamic +elaboration switch if your code is correct, and we assume that the +C-tests are indeed correct (it is less efficient, but efficiency is +not a factor in running the ACVC tests.) + +@node Elaboration for Access-to-Subprogram Values +@section Elaboration for Access-to-Subprogram Values +@cindex Access-to-subprogram + +@noindent +Access-to-subprogram types (introduced in Ada 95) complicate +the handling of elaboration. The trouble is that it becomes +impossible to tell at compile time which procedure +is being called. This means that it is not possible for the binder +to analyze the elaboration requirements in this case. + +If at the point at which the access value is created +(i.e., the evaluation of @code{P'Access} for a subprogram @code{P}), +the body of the subprogram is +known to have been elaborated, then the access value is safe, and its use +does not require a check. This may be achieved by appropriate arrangement +of the order of declarations if the subprogram is in the current unit, +or, if the subprogram is in another unit, by using pragma +@code{Pure}, @code{Preelaborate}, or @code{Elaborate_Body} +on the referenced unit. + +If the referenced body is not known to have been elaborated at the point +the access value is created, then any use of the access value must do a +dynamic check, and this dynamic check will fail and raise a +@code{Program_Error} exception if the body has not been elaborated yet. +GNAT will generate the necessary checks, and in addition, if the +@option{-gnatwl} +switch is set, will generate warnings that such checks are required. + +The use of dynamic dispatching for tagged types similarly generates +a requirement for dynamic checks, and premature calls to any primitive +operation of a tagged type before the body of the operation has been +elaborated, will result in the raising of @code{Program_Error}. + +@node Summary of Procedures for Elaboration Control +@section Summary of Procedures for Elaboration Control +@cindex Elaboration control + +@noindent +First, compile your program with the default options, using none of +the special elaboration control switches. If the binder successfully +binds your program, then you can be confident that, apart from issues +raised by the use of access-to-subprogram types and dynamic dispatching, +the program is free of elaboration errors. If it is important that the +program be portable, then use the +@option{-gnatwl} +switch to generate warnings about missing @code{Elaborate} or +@code{Elaborate_All} pragmas, and supply the missing pragmas. + +If the program fails to bind using the default static elaboration +handling, then you can fix the program to eliminate the binder +message, or recompile the entire program with the +@option{-gnatE} switch to generate dynamic elaboration checks, +and, if you are sure there really are no elaboration problems, +use a global pragma @code{Suppress (Elaboration_Check)}. + +@node Other Elaboration Order Considerations +@section Other Elaboration Order Considerations +@noindent +This section has been entirely concerned with the issue of finding a valid +elaboration order, as defined by the Ada Reference Manual. In a case +where several elaboration orders are valid, the task is to find one +of the possible valid elaboration orders (and the static model in GNAT +will ensure that this is achieved). + +The purpose of the elaboration rules in the Ada Reference Manual is to +make sure that no entity is accessed before it has been elaborated. For +a subprogram, this means that the spec and body must have been elaborated +before the subprogram is called. For an object, this means that the object +must have been elaborated before its value is read or written. A violation +of either of these two requirements is an access before elaboration order, +and this section has been all about avoiding such errors. + +In the case where more than one order of elaboration is possible, in the +sense that access before elaboration errors are avoided, then any one of +the orders is ``correct'' in the sense that it meets the requirements of +the Ada Reference Manual, and no such error occurs. + +However, it may be the case for a given program, that there are +constraints on the order of elaboration that come not from consideration +of avoiding elaboration errors, but rather from extra-lingual logic +requirements. Consider this example: + +@smallexample @c ada +with Init_Constants; +package Constants is + X : Integer := 0; + Y : Integer := 0; +end Constants; + +package Init_Constants is + procedure P; -- require a body +end Init_Constants; + +with Constants; +package body Init_Constants is + procedure P is begin null; end; +begin + Constants.X := 3; + Constants.Y := 4; +end Init_Constants; + +with Constants; +package Calc is + Z : Integer := Constants.X + Constants.Y; +end Calc; + +with Calc; +with Text_IO; use Text_IO; +procedure Main is +begin + Put_Line (Calc.Z'Img); +end Main; +@end smallexample + +@noindent +In this example, there is more than one valid order of elaboration. For +example both the following are correct orders: + +@smallexample +Init_Constants spec +Constants spec +Calc spec +Init_Constants body +Main body + + and + +Init_Constants spec +Init_Constants body +Constants spec +Calc spec +Main body +@end smallexample + +@noindent +There is no language rule to prefer one or the other, both are correct +from an order of elaboration point of view. But the programmatic effects +of the two orders are very different. In the first, the elaboration routine +of @code{Calc} initializes @code{Z} to zero, and then the main program +runs with this value of zero. But in the second order, the elaboration +routine of @code{Calc} runs after the body of Init_Constants has set +@code{X} and @code{Y} and thus @code{Z} is set to 7 before @code{Main} +runs. + +One could perhaps by applying pretty clever non-artificial intelligence +to the situation guess that it is more likely that the second order of +elaboration is the one desired, but there is no formal linguistic reason +to prefer one over the other. In fact in this particular case, GNAT will +prefer the second order, because of the rule that bodies are elaborated +as soon as possible, but it's just luck that this is what was wanted +(if indeed the second order was preferred). + +If the program cares about the order of elaboration routines in a case like +this, it is important to specify the order required. In this particular +case, that could have been achieved by adding to the spec of Calc: + +@smallexample @c ada +pragma Elaborate_All (Constants); +@end smallexample + +@noindent +which requires that the body (if any) and spec of @code{Constants}, +as well as the body and spec of any unit @code{with}'ed by +@code{Constants} be elaborated before @code{Calc} is elaborated. + +Clearly no automatic method can always guess which alternative you require, +and if you are working with legacy code that had constraints of this kind +which were not properly specified by adding @code{Elaborate} or +@code{Elaborate_All} pragmas, then indeed it is possible that two different +compilers can choose different orders. + +However, GNAT does attempt to diagnose the common situation where there +are uninitialized variables in the visible part of a package spec, and the +corresponding package body has an elaboration block that directly or +indirectly initialized one or more of these variables. This is the situation +in which a pragma Elaborate_Body is usually desirable, and GNAT will generate +a warning that suggests this addition if it detects this situation. + +The @code{gnatbind} +@option{^-p^/PESSIMISTIC_ELABORATION^} switch may be useful in smoking +out problems. This switch causes bodies to be elaborated as late as possible +instead of as early as possible. In the example above, it would have forced +the choice of the first elaboration order. If you get different results +when using this switch, and particularly if one set of results is right, +and one is wrong as far as you are concerned, it shows that you have some +missing @code{Elaborate} pragmas. For the example above, we have the +following output: + +@smallexample +gnatmake -f -q main +main + 7 +gnatmake -f -q main -bargs -p +main + 0 +@end smallexample + +@noindent +It is of course quite unlikely that both these results are correct, so +it is up to you in a case like this to investigate the source of the +difference, by looking at the two elaboration orders that are chosen, +and figuring out which is correct, and then adding the necessary +@code{Elaborate} or @code{Elaborate_All} pragmas to ensure the desired order. + + + +@c ******************************* +@node Conditional Compilation +@appendix Conditional Compilation +@c ******************************* +@cindex Conditional compilation + +@noindent +It is often necessary to arrange for a single source program +to serve multiple purposes, where it is compiled in different +ways to achieve these different goals. Some examples of the +need for this feature are + +@itemize @bullet +@item Adapting a program to a different hardware environment +@item Adapting a program to a different target architecture +@item Turning debugging features on and off +@item Arranging for a program to compile with different compilers +@end itemize + +@noindent +In C, or C++, the typical approach would be to use the preprocessor +that is defined as part of the language. The Ada language does not +contain such a feature. This is not an oversight, but rather a very +deliberate design decision, based on the experience that overuse of +the preprocessing features in C and C++ can result in programs that +are extremely difficult to maintain. For example, if we have ten +switches that can be on or off, this means that there are a thousand +separate programs, any one of which might not even be syntactically +correct, and even if syntactically correct, the resulting program +might not work correctly. Testing all combinations can quickly become +impossible. + +Nevertheless, the need to tailor programs certainly exists, and in +this Appendix we will discuss how this can +be achieved using Ada in general, and GNAT in particular. + +@menu +* Use of Boolean Constants:: +* Debugging - A Special Case:: +* Conditionalizing Declarations:: +* Use of Alternative Implementations:: +* Preprocessing:: +@end menu + +@node Use of Boolean Constants +@section Use of Boolean Constants + +@noindent +In the case where the difference is simply which code +sequence is executed, the cleanest solution is to use Boolean +constants to control which code is executed. + +@smallexample @c ada +@group +FP_Initialize_Required : constant Boolean := True; +@dots{} +if FP_Initialize_Required then +@dots{} +end if; +@end group +@end smallexample + +@noindent +Not only will the code inside the @code{if} statement not be executed if +the constant Boolean is @code{False}, but it will also be completely +deleted from the program. +However, the code is only deleted after the @code{if} statement +has been checked for syntactic and semantic correctness. +(In contrast, with preprocessors the code is deleted before the +compiler ever gets to see it, so it is not checked until the switch +is turned on.) +@cindex Preprocessors (contrasted with conditional compilation) + +Typically the Boolean constants will be in a separate package, +something like: + +@smallexample @c ada +@group +package Config is + FP_Initialize_Required : constant Boolean := True; + Reset_Available : constant Boolean := False; + @dots{} +end Config; +@end group +@end smallexample + +@noindent +The @code{Config} package exists in multiple forms for the various targets, +with an appropriate script selecting the version of @code{Config} needed. +Then any other unit requiring conditional compilation can do a @code{with} +of @code{Config} to make the constants visible. + + +@node Debugging - A Special Case +@section Debugging - A Special Case + +@noindent +A common use of conditional code is to execute statements (for example +dynamic checks, or output of intermediate results) under control of a +debug switch, so that the debugging behavior can be turned on and off. +This can be done using a Boolean constant to control whether the code +is active: + +@smallexample @c ada +@group +if Debugging then + Put_Line ("got to the first stage!"); +end if; +@end group +@end smallexample + +@noindent +or + +@smallexample @c ada +@group +if Debugging and then Temperature > 999.0 then + raise Temperature_Crazy; +end if; +@end group +@end smallexample + +@noindent +Since this is a common case, there are special features to deal with +this in a convenient manner. For the case of tests, Ada 2005 has added +a pragma @code{Assert} that can be used for such tests. This pragma is modeled +@cindex pragma @code{Assert} +on the @code{Assert} pragma that has always been available in GNAT, so this +feature may be used with GNAT even if you are not using Ada 2005 features. +The use of pragma @code{Assert} is described in +@ref{Pragma Assert,,, gnat_rm, GNAT Reference Manual}, but as an +example, the last test could be written: + +@smallexample @c ada +pragma Assert (Temperature <= 999.0, "Temperature Crazy"); +@end smallexample + +@noindent +or simply + +@smallexample @c ada +pragma Assert (Temperature <= 999.0); +@end smallexample + +@noindent +In both cases, if assertions are active and the temperature is excessive, +the exception @code{Assert_Failure} will be raised, with the given string in +the first case or a string indicating the location of the pragma in the second +case used as the exception message. + +You can turn assertions on and off by using the @code{Assertion_Policy} +pragma. +@cindex pragma @code{Assertion_Policy} +This is an Ada 2005 pragma which is implemented in all modes by +GNAT, but only in the latest versions of GNAT which include Ada 2005 +capability. Alternatively, you can use the @option{-gnata} switch +@cindex @option{-gnata} switch +to enable assertions from the command line (this is recognized by all versions +of GNAT). + +For the example above with the @code{Put_Line}, the GNAT-specific pragma +@code{Debug} can be used: +@cindex pragma @code{Debug} + +@smallexample @c ada +pragma Debug (Put_Line ("got to the first stage!")); +@end smallexample + +@noindent +If debug pragmas are enabled, the argument, which must be of the form of +a procedure call, is executed (in this case, @code{Put_Line} will be called). +Only one call can be present, but of course a special debugging procedure +containing any code you like can be included in the program and then +called in a pragma @code{Debug} argument as needed. + +One advantage of pragma @code{Debug} over the @code{if Debugging then} +construct is that pragma @code{Debug} can appear in declarative contexts, +such as at the very beginning of a procedure, before local declarations have +been elaborated. + +Debug pragmas are enabled using either the @option{-gnata} switch that also +controls assertions, or with a separate Debug_Policy pragma. +@cindex pragma @code{Debug_Policy} +The latter pragma is new in the Ada 2005 versions of GNAT (but it can be used +in Ada 95 and Ada 83 programs as well), and is analogous to +pragma @code{Assertion_Policy} to control assertions. + +@code{Assertion_Policy} and @code{Debug_Policy} are configuration pragmas, +and thus they can appear in @file{gnat.adc} if you are not using a +project file, or in the file designated to contain configuration pragmas +in a project file. +They then apply to all subsequent compilations. In practice the use of +the @option{-gnata} switch is often the most convenient method of controlling +the status of these pragmas. + +Note that a pragma is not a statement, so in contexts where a statement +sequence is required, you can't just write a pragma on its own. You have +to add a @code{null} statement. + +@smallexample @c ada +@group +if @dots{} then + @dots{} -- some statements +else + pragma Assert (Num_Cases < 10); + null; +end if; +@end group +@end smallexample + + +@node Conditionalizing Declarations +@section Conditionalizing Declarations + +@noindent +In some cases, it may be necessary to conditionalize declarations to meet +different requirements. For example we might want a bit string whose length +is set to meet some hardware message requirement. + +In some cases, it may be possible to do this using declare blocks controlled +by conditional constants: + +@smallexample @c ada +@group +if Small_Machine then + declare + X : Bit_String (1 .. 10); + begin + @dots{} + end; +else + declare + X : Large_Bit_String (1 .. 1000); + begin + @dots{} + end; +end if; +@end group +@end smallexample + +@noindent +Note that in this approach, both declarations are analyzed by the +compiler so this can only be used where both declarations are legal, +even though one of them will not be used. + +Another approach is to define integer constants, e.g.@: @code{Bits_Per_Word}, +or Boolean constants, e.g.@: @code{Little_Endian}, and then write declarations +that are parameterized by these constants. For example + +@smallexample @c ada +@group +for Rec use + Field1 at 0 range Boolean'Pos (Little_Endian) * 10 .. Bits_Per_Word; +end record; +@end group +@end smallexample + +@noindent +If @code{Bits_Per_Word} is set to 32, this generates either + +@smallexample @c ada +@group +for Rec use + Field1 at 0 range 0 .. 32; +end record; +@end group +@end smallexample + +@noindent +for the big endian case, or + +@smallexample @c ada +@group +for Rec use record + Field1 at 0 range 10 .. 32; +end record; +@end group +@end smallexample + +@noindent +for the little endian case. Since a powerful subset of Ada expression +notation is usable for creating static constants, clever use of this +feature can often solve quite difficult problems in conditionalizing +compilation (note incidentally that in Ada 95, the little endian +constant was introduced as @code{System.Default_Bit_Order}, so you do not +need to define this one yourself). + + +@node Use of Alternative Implementations +@section Use of Alternative Implementations + +@noindent +In some cases, none of the approaches described above are adequate. This +can occur for example if the set of declarations required is radically +different for two different configurations. + +In this situation, the official Ada way of dealing with conditionalizing +such code is to write separate units for the different cases. As long as +this does not result in excessive duplication of code, this can be done +without creating maintenance problems. The approach is to share common +code as far as possible, and then isolate the code and declarations +that are different. Subunits are often a convenient method for breaking +out a piece of a unit that is to be conditionalized, with separate files +for different versions of the subunit for different targets, where the +build script selects the right one to give to the compiler. +@cindex Subunits (and conditional compilation) + +As an example, consider a situation where a new feature in Ada 2005 +allows something to be done in a really nice way. But your code must be able +to compile with an Ada 95 compiler. Conceptually you want to say: + +@smallexample @c ada +@group +if Ada_2005 then + @dots{} neat Ada 2005 code +else + @dots{} not quite as neat Ada 95 code +end if; +@end group +@end smallexample + +@noindent +where @code{Ada_2005} is a Boolean constant. + +But this won't work when @code{Ada_2005} is set to @code{False}, +since the @code{then} clause will be illegal for an Ada 95 compiler. +(Recall that although such unreachable code would eventually be deleted +by the compiler, it still needs to be legal. If it uses features +introduced in Ada 2005, it will be illegal in Ada 95.) + +So instead we write + +@smallexample @c ada +procedure Insert is separate; +@end smallexample + +@noindent +Then we have two files for the subunit @code{Insert}, with the two sets of +code. +If the package containing this is called @code{File_Queries}, then we might +have two files + +@itemize @bullet +@item @file{file_queries-insert-2005.adb} +@item @file{file_queries-insert-95.adb} +@end itemize + +@noindent +and the build script renames the appropriate file to + +@smallexample +file_queries-insert.adb +@end smallexample + +@noindent +and then carries out the compilation. + +This can also be done with project files' naming schemes. For example: + +@smallexample @c project +For Body ("File_Queries.Insert") use "file_queries-insert-2005.ada"; +@end smallexample + +@noindent +Note also that with project files it is desirable to use a different extension +than @file{ads} / @file{adb} for alternative versions. Otherwise a naming +conflict may arise through another commonly used feature: to declare as part +of the project a set of directories containing all the sources obeying the +default naming scheme. + +The use of alternative units is certainly feasible in all situations, +and for example the Ada part of the GNAT run-time is conditionalized +based on the target architecture using this approach. As a specific example, +consider the implementation of the AST feature in VMS. There is one +spec: + +@smallexample +s-asthan.ads +@end smallexample + +@noindent +which is the same for all architectures, and three bodies: + +@table @file +@item s-asthan.adb +used for all non-VMS operating systems +@item s-asthan-vms-alpha.adb +used for VMS on the Alpha +@item s-asthan-vms-ia64.adb +used for VMS on the ia64 +@end table + +@noindent +The dummy version @file{s-asthan.adb} simply raises exceptions noting that +this operating system feature is not available, and the two remaining +versions interface with the corresponding versions of VMS to provide +VMS-compatible AST handling. The GNAT build script knows the architecture +and operating system, and automatically selects the right version, +renaming it if necessary to @file{s-asthan.adb} before the run-time build. + +Another style for arranging alternative implementations is through Ada's +access-to-subprogram facility. +In case some functionality is to be conditionally included, +you can declare an access-to-procedure variable @code{Ref} that is initialized +to designate a ``do nothing'' procedure, and then invoke @code{Ref.all} +when appropriate. +In some library package, set @code{Ref} to @code{Proc'Access} for some +procedure @code{Proc} that performs the relevant processing. +The initialization only occurs if the library package is included in the +program. +The same idea can also be implemented using tagged types and dispatching +calls. + + +@node Preprocessing +@section Preprocessing +@cindex Preprocessing + +@noindent +Although it is quite possible to conditionalize code without the use of +C-style preprocessing, as described earlier in this section, it is +nevertheless convenient in some cases to use the C approach. Moreover, +older Ada compilers have often provided some preprocessing capability, +so legacy code may depend on this approach, even though it is not +standard. + +To accommodate such use, GNAT provides a preprocessor (modeled to a large +extent on the various preprocessors that have been used +with legacy code on other compilers, to enable easier transition). + +The preprocessor may be used in two separate modes. It can be used quite +separately from the compiler, to generate a separate output source file +that is then fed to the compiler as a separate step. This is the +@code{gnatprep} utility, whose use is fully described in +@ref{Preprocessing Using gnatprep}. +@cindex @code{gnatprep} + +The preprocessing language allows such constructs as + +@smallexample +@group +#if DEBUG or PRIORITY > 4 then + bunch of declarations +#else + completely different bunch of declarations +#end if; +@end group +@end smallexample + +@noindent +The values of the symbols @code{DEBUG} and @code{PRIORITY} can be +defined either on the command line or in a separate file. + +The other way of running the preprocessor is even closer to the C style and +often more convenient. In this approach the preprocessing is integrated into +the compilation process. The compiler is fed the preprocessor input which +includes @code{#if} lines etc, and then the compiler carries out the +preprocessing internally and processes the resulting output. +For more details on this approach, see @ref{Integrated Preprocessing}. + + +@c ******************************* +@node Inline Assembler +@appendix Inline Assembler +@c ******************************* + +@noindent +If you need to write low-level software that interacts directly +with the hardware, Ada provides two ways to incorporate assembly +language code into your program. First, you can import and invoke +external routines written in assembly language, an Ada feature fully +supported by GNAT@. However, for small sections of code it may be simpler +or more efficient to include assembly language statements directly +in your Ada source program, using the facilities of the implementation-defined +package @code{System.Machine_Code}, which incorporates the gcc +Inline Assembler. The Inline Assembler approach offers a number of advantages, +including the following: + +@itemize @bullet +@item No need to use non-Ada tools +@item Consistent interface over different targets +@item Automatic usage of the proper calling conventions +@item Access to Ada constants and variables +@item Definition of intrinsic routines +@item Possibility of inlining a subprogram comprising assembler code +@item Code optimizer can take Inline Assembler code into account +@end itemize + +This chapter presents a series of examples to show you how to use +the Inline Assembler. Although it focuses on the Intel x86, +the general approach applies also to other processors. +It is assumed that you are familiar with Ada +and with assembly language programming. + +@menu +* Basic Assembler Syntax:: +* A Simple Example of Inline Assembler:: +* Output Variables in Inline Assembler:: +* Input Variables in Inline Assembler:: +* Inlining Inline Assembler Code:: +* Other Asm Functionality:: +@end menu + +@c --------------------------------------------------------------------------- +@node Basic Assembler Syntax +@section Basic Assembler Syntax + +@noindent +The assembler used by GNAT and gcc is based not on the Intel assembly +language, but rather on a language that descends from the AT&T Unix +assembler @emph{as} (and which is often referred to as ``AT&T syntax''). +The following table summarizes the main features of @emph{as} syntax +and points out the differences from the Intel conventions. +See the gcc @emph{as} and @emph{gas} (an @emph{as} macro +pre-processor) documentation for further information. + +@table @asis +@item Register names +gcc / @emph{as}: Prefix with ``%''; for example @code{%eax} +@* +Intel: No extra punctuation; for example @code{eax} + +@item Immediate operand +gcc / @emph{as}: Prefix with ``$''; for example @code{$4} +@* +Intel: No extra punctuation; for example @code{4} + +@item Address +gcc / @emph{as}: Prefix with ``$''; for example @code{$loc} +@* +Intel: No extra punctuation; for example @code{loc} + +@item Memory contents +gcc / @emph{as}: No extra punctuation; for example @code{loc} +@* +Intel: Square brackets; for example @code{[loc]} + +@item Register contents +gcc / @emph{as}: Parentheses; for example @code{(%eax)} +@* +Intel: Square brackets; for example @code{[eax]} + +@item Hexadecimal numbers +gcc / @emph{as}: Leading ``0x'' (C language syntax); for example @code{0xA0} +@* +Intel: Trailing ``h''; for example @code{A0h} + +@item Operand size +gcc / @emph{as}: Explicit in op code; for example @code{movw} to move +a 16-bit word +@* +Intel: Implicit, deduced by assembler; for example @code{mov} + +@item Instruction repetition +gcc / @emph{as}: Split into two lines; for example +@* +@code{rep} +@* +@code{stosl} +@* +Intel: Keep on one line; for example @code{rep stosl} + +@item Order of operands +gcc / @emph{as}: Source first; for example @code{movw $4, %eax} +@* +Intel: Destination first; for example @code{mov eax, 4} +@end table + +@c --------------------------------------------------------------------------- +@node A Simple Example of Inline Assembler +@section A Simple Example of Inline Assembler + +@noindent +The following example will generate a single assembly language statement, +@code{nop}, which does nothing. Despite its lack of run-time effect, +the example will be useful in illustrating the basics of +the Inline Assembler facility. + +@smallexample @c ada +@group +with System.Machine_Code; use System.Machine_Code; +procedure Nothing is +begin + Asm ("nop"); +end Nothing; +@end group +@end smallexample + +@code{Asm} is a procedure declared in package @code{System.Machine_Code}; +here it takes one parameter, a @emph{template string} that must be a static +expression and that will form the generated instruction. +@code{Asm} may be regarded as a compile-time procedure that parses +the template string and additional parameters (none here), +from which it generates a sequence of assembly language instructions. + +The examples in this chapter will illustrate several of the forms +for invoking @code{Asm}; a complete specification of the syntax +is found in @ref{Machine Code Insertions,,, gnat_rm, GNAT Reference +Manual}. + +Under the standard GNAT conventions, the @code{Nothing} procedure +should be in a file named @file{nothing.adb}. +You can build the executable in the usual way: +@smallexample +gnatmake nothing +@end smallexample +However, the interesting aspect of this example is not its run-time behavior +but rather the generated assembly code. +To see this output, invoke the compiler as follows: +@smallexample + gcc -c -S -fomit-frame-pointer -gnatp @file{nothing.adb} +@end smallexample +where the options are: + +@table @code +@item -c +compile only (no bind or link) +@item -S +generate assembler listing +@item -fomit-frame-pointer +do not set up separate stack frames +@item -gnatp +do not add runtime checks +@end table + +This gives a human-readable assembler version of the code. The resulting +file will have the same name as the Ada source file, but with a @code{.s} +extension. In our example, the file @file{nothing.s} has the following +contents: + +@smallexample +@group +.file "nothing.adb" +gcc2_compiled.: +___gnu_compiled_ada: +.text + .align 4 +.globl __ada_nothing +__ada_nothing: +#APP + nop +#NO_APP + jmp L1 + .align 2,0x90 +L1: + ret +@end group +@end smallexample + +The assembly code you included is clearly indicated by +the compiler, between the @code{#APP} and @code{#NO_APP} +delimiters. The character before the 'APP' and 'NOAPP' +can differ on different targets. For example, GNU/Linux uses '#APP' while +on NT you will see '/APP'. + +If you make a mistake in your assembler code (such as using the +wrong size modifier, or using a wrong operand for the instruction) GNAT +will report this error in a temporary file, which will be deleted when +the compilation is finished. Generating an assembler file will help +in such cases, since you can assemble this file separately using the +@emph{as} assembler that comes with gcc. + +Assembling the file using the command + +@smallexample +as @file{nothing.s} +@end smallexample +@noindent +will give you error messages whose lines correspond to the assembler +input file, so you can easily find and correct any mistakes you made. +If there are no errors, @emph{as} will generate an object file +@file{nothing.out}. + +@c --------------------------------------------------------------------------- +@node Output Variables in Inline Assembler +@section Output Variables in Inline Assembler + +@noindent +The examples in this section, showing how to access the processor flags, +illustrate how to specify the destination operands for assembly language +statements. + +@smallexample @c ada +@group +with Interfaces; use Interfaces; +with Ada.Text_IO; use Ada.Text_IO; +with System.Machine_Code; use System.Machine_Code; +procedure Get_Flags is + Flags : Unsigned_32; + use ASCII; +begin + Asm ("pushfl" & LF & HT & -- push flags on stack + "popl %%eax" & LF & HT & -- load eax with flags + "movl %%eax, %0", -- store flags in variable + Outputs => Unsigned_32'Asm_Output ("=g", Flags)); + Put_Line ("Flags register:" & Flags'Img); +end Get_Flags; +@end group +@end smallexample + +In order to have a nicely aligned assembly listing, we have separated +multiple assembler statements in the Asm template string with linefeed +(ASCII.LF) and horizontal tab (ASCII.HT) characters. +The resulting section of the assembly output file is: + +@smallexample +@group +#APP + pushfl + popl %eax + movl %eax, -40(%ebp) +#NO_APP +@end group +@end smallexample + +It would have been legal to write the Asm invocation as: + +@smallexample +Asm ("pushfl popl %%eax movl %%eax, %0") +@end smallexample + +but in the generated assembler file, this would come out as: + +@smallexample +#APP + pushfl popl %eax movl %eax, -40(%ebp) +#NO_APP +@end smallexample + +which is not so convenient for the human reader. + +We use Ada comments +at the end of each line to explain what the assembler instructions +actually do. This is a useful convention. + +When writing Inline Assembler instructions, you need to precede each register +and variable name with a percent sign. Since the assembler already requires +a percent sign at the beginning of a register name, you need two consecutive +percent signs for such names in the Asm template string, thus @code{%%eax}. +In the generated assembly code, one of the percent signs will be stripped off. + +Names such as @code{%0}, @code{%1}, @code{%2}, etc., denote input or output +variables: operands you later define using @code{Input} or @code{Output} +parameters to @code{Asm}. +An output variable is illustrated in +the third statement in the Asm template string: +@smallexample +movl %%eax, %0 +@end smallexample +The intent is to store the contents of the eax register in a variable that can +be accessed in Ada. Simply writing @code{movl %%eax, Flags} would not +necessarily work, since the compiler might optimize by using a register +to hold Flags, and the expansion of the @code{movl} instruction would not be +aware of this optimization. The solution is not to store the result directly +but rather to advise the compiler to choose the correct operand form; +that is the purpose of the @code{%0} output variable. + +Information about the output variable is supplied in the @code{Outputs} +parameter to @code{Asm}: +@smallexample +Outputs => Unsigned_32'Asm_Output ("=g", Flags)); +@end smallexample + +The output is defined by the @code{Asm_Output} attribute of the target type; +the general format is +@smallexample +Type'Asm_Output (constraint_string, variable_name) +@end smallexample + +The constraint string directs the compiler how +to store/access the associated variable. In the example +@smallexample +Unsigned_32'Asm_Output ("=m", Flags); +@end smallexample +the @code{"m"} (memory) constraint tells the compiler that the variable +@code{Flags} should be stored in a memory variable, thus preventing +the optimizer from keeping it in a register. In contrast, +@smallexample +Unsigned_32'Asm_Output ("=r", Flags); +@end smallexample +uses the @code{"r"} (register) constraint, telling the compiler to +store the variable in a register. + +If the constraint is preceded by the equal character (@strong{=}), it tells +the compiler that the variable will be used to store data into it. + +In the @code{Get_Flags} example, we used the @code{"g"} (global) constraint, +allowing the optimizer to choose whatever it deems best. + +There are a fairly large number of constraints, but the ones that are +most useful (for the Intel x86 processor) are the following: + +@table @code +@item = +output constraint +@item g +global (i.e.@: can be stored anywhere) +@item m +in memory +@item I +a constant +@item a +use eax +@item b +use ebx +@item c +use ecx +@item d +use edx +@item S +use esi +@item D +use edi +@item r +use one of eax, ebx, ecx or edx +@item q +use one of eax, ebx, ecx, edx, esi or edi +@end table + +The full set of constraints is described in the gcc and @emph{as} +documentation; note that it is possible to combine certain constraints +in one constraint string. + +You specify the association of an output variable with an assembler operand +through the @code{%}@emph{n} notation, where @emph{n} is a non-negative +integer. Thus in +@smallexample @c ada +@group +Asm ("pushfl" & LF & HT & -- push flags on stack + "popl %%eax" & LF & HT & -- load eax with flags + "movl %%eax, %0", -- store flags in variable + Outputs => Unsigned_32'Asm_Output ("=g", Flags)); +@end group +@end smallexample +@noindent +@code{%0} will be replaced in the expanded code by the appropriate operand, +whatever +the compiler decided for the @code{Flags} variable. + +In general, you may have any number of output variables: +@itemize @bullet +@item +Count the operands starting at 0; thus @code{%0}, @code{%1}, etc. +@item +Specify the @code{Outputs} parameter as a parenthesized comma-separated list +of @code{Asm_Output} attributes +@end itemize + +For example: +@smallexample @c ada +@group +Asm ("movl %%eax, %0" & LF & HT & + "movl %%ebx, %1" & LF & HT & + "movl %%ecx, %2", + Outputs => (Unsigned_32'Asm_Output ("=g", Var_A), -- %0 = Var_A + Unsigned_32'Asm_Output ("=g", Var_B), -- %1 = Var_B + Unsigned_32'Asm_Output ("=g", Var_C))); -- %2 = Var_C +@end group +@end smallexample +@noindent +where @code{Var_A}, @code{Var_B}, and @code{Var_C} are variables +in the Ada program. + +As a variation on the @code{Get_Flags} example, we can use the constraints +string to direct the compiler to store the eax register into the @code{Flags} +variable, instead of including the store instruction explicitly in the +@code{Asm} template string: + +@smallexample @c ada +@group +with Interfaces; use Interfaces; +with Ada.Text_IO; use Ada.Text_IO; +with System.Machine_Code; use System.Machine_Code; +procedure Get_Flags_2 is + Flags : Unsigned_32; + use ASCII; +begin + Asm ("pushfl" & LF & HT & -- push flags on stack + "popl %%eax", -- save flags in eax + Outputs => Unsigned_32'Asm_Output ("=a", Flags)); + Put_Line ("Flags register:" & Flags'Img); +end Get_Flags_2; +@end group +@end smallexample + +@noindent +The @code{"a"} constraint tells the compiler that the @code{Flags} +variable will come from the eax register. Here is the resulting code: + +@smallexample +@group +#APP + pushfl + popl %eax +#NO_APP + movl %eax,-40(%ebp) +@end group +@end smallexample + +@noindent +The compiler generated the store of eax into Flags after +expanding the assembler code. + +Actually, there was no need to pop the flags into the eax register; +more simply, we could just pop the flags directly into the program variable: + +@smallexample @c ada +@group +with Interfaces; use Interfaces; +with Ada.Text_IO; use Ada.Text_IO; +with System.Machine_Code; use System.Machine_Code; +procedure Get_Flags_3 is + Flags : Unsigned_32; + use ASCII; +begin + Asm ("pushfl" & LF & HT & -- push flags on stack + "pop %0", -- save flags in Flags + Outputs => Unsigned_32'Asm_Output ("=g", Flags)); + Put_Line ("Flags register:" & Flags'Img); +end Get_Flags_3; +@end group +@end smallexample + +@c --------------------------------------------------------------------------- +@node Input Variables in Inline Assembler +@section Input Variables in Inline Assembler + +@noindent +The example in this section illustrates how to specify the source operands +for assembly language statements. +The program simply increments its input value by 1: + +@smallexample @c ada +@group +with Interfaces; use Interfaces; +with Ada.Text_IO; use Ada.Text_IO; +with System.Machine_Code; use System.Machine_Code; +procedure Increment is + + function Incr (Value : Unsigned_32) return Unsigned_32 is + Result : Unsigned_32; + begin + Asm ("incl %0", + Inputs => Unsigned_32'Asm_Input ("a", Value), + Outputs => Unsigned_32'Asm_Output ("=a", Result)); + return Result; + end Incr; + + Value : Unsigned_32; + +begin + Value := 5; + Put_Line ("Value before is" & Value'Img); + Value := Incr (Value); + Put_Line ("Value after is" & Value'Img); +end Increment; +@end group +@end smallexample + +The @code{Outputs} parameter to @code{Asm} specifies +that the result will be in the eax register and that it is to be stored +in the @code{Result} variable. + +The @code{Inputs} parameter looks much like the @code{Outputs} parameter, +but with an @code{Asm_Input} attribute. +The @code{"="} constraint, indicating an output value, is not present. + +You can have multiple input variables, in the same way that you can have more +than one output variable. + +The parameter count (%0, %1) etc, now starts at the first input +statement, and continues with the output statements. +When both parameters use the same variable, the +compiler will treat them as the same %n operand, which is the case here. + +Just as the @code{Outputs} parameter causes the register to be stored into the +target variable after execution of the assembler statements, so does the +@code{Inputs} parameter cause its variable to be loaded into the register +before execution of the assembler statements. + +Thus the effect of the @code{Asm} invocation is: +@enumerate +@item load the 32-bit value of @code{Value} into eax +@item execute the @code{incl %eax} instruction +@item store the contents of eax into the @code{Result} variable +@end enumerate + +The resulting assembler file (with @option{-O2} optimization) contains: +@smallexample +@group +_increment__incr.1: + subl $4,%esp + movl 8(%esp),%eax +#APP + incl %eax +#NO_APP + movl %eax,%edx + movl %ecx,(%esp) + addl $4,%esp + ret +@end group +@end smallexample + +@c --------------------------------------------------------------------------- +@node Inlining Inline Assembler Code +@section Inlining Inline Assembler Code + +@noindent +For a short subprogram such as the @code{Incr} function in the previous +section, the overhead of the call and return (creating / deleting the stack +frame) can be significant, compared to the amount of code in the subprogram +body. A solution is to apply Ada's @code{Inline} pragma to the subprogram, +which directs the compiler to expand invocations of the subprogram at the +point(s) of call, instead of setting up a stack frame for out-of-line calls. +Here is the resulting program: + +@smallexample @c ada +@group +with Interfaces; use Interfaces; +with Ada.Text_IO; use Ada.Text_IO; +with System.Machine_Code; use System.Machine_Code; +procedure Increment_2 is + + function Incr (Value : Unsigned_32) return Unsigned_32 is + Result : Unsigned_32; + begin + Asm ("incl %0", + Inputs => Unsigned_32'Asm_Input ("a", Value), + Outputs => Unsigned_32'Asm_Output ("=a", Result)); + return Result; + end Incr; + pragma Inline (Increment); + + Value : Unsigned_32; + +begin + Value := 5; + Put_Line ("Value before is" & Value'Img); + Value := Increment (Value); + Put_Line ("Value after is" & Value'Img); +end Increment_2; +@end group +@end smallexample + +Compile the program with both optimization (@option{-O2}) and inlining +(@option{-gnatn}) enabled. + +The @code{Incr} function is still compiled as usual, but at the +point in @code{Increment} where our function used to be called: + +@smallexample +@group +pushl %edi +call _increment__incr.1 +@end group +@end smallexample + +@noindent +the code for the function body directly appears: + +@smallexample +@group +movl %esi,%eax +#APP + incl %eax +#NO_APP + movl %eax,%edx +@end group +@end smallexample + +@noindent +thus saving the overhead of stack frame setup and an out-of-line call. + +@c --------------------------------------------------------------------------- +@node Other Asm Functionality +@section Other @code{Asm} Functionality + +@noindent +This section describes two important parameters to the @code{Asm} +procedure: @code{Clobber}, which identifies register usage; +and @code{Volatile}, which inhibits unwanted optimizations. + +@menu +* The Clobber Parameter:: +* The Volatile Parameter:: +@end menu + +@c --------------------------------------------------------------------------- +@node The Clobber Parameter +@subsection The @code{Clobber} Parameter + +@noindent +One of the dangers of intermixing assembly language and a compiled language +such as Ada is that the compiler needs to be aware of which registers are +being used by the assembly code. In some cases, such as the earlier examples, +the constraint string is sufficient to indicate register usage (e.g., +@code{"a"} for +the eax register). But more generally, the compiler needs an explicit +identification of the registers that are used by the Inline Assembly +statements. + +Using a register that the compiler doesn't know about +could be a side effect of an instruction (like @code{mull} +storing its result in both eax and edx). +It can also arise from explicit register usage in your +assembly code; for example: +@smallexample +@group +Asm ("movl %0, %%ebx" & LF & HT & + "movl %%ebx, %1", + Inputs => Unsigned_32'Asm_Input ("g", Var_In), + Outputs => Unsigned_32'Asm_Output ("=g", Var_Out)); +@end group +@end smallexample +@noindent +where the compiler (since it does not analyze the @code{Asm} template string) +does not know you are using the ebx register. + +In such cases you need to supply the @code{Clobber} parameter to @code{Asm}, +to identify the registers that will be used by your assembly code: + +@smallexample +@group +Asm ("movl %0, %%ebx" & LF & HT & + "movl %%ebx, %1", + Inputs => Unsigned_32'Asm_Input ("g", Var_In), + Outputs => Unsigned_32'Asm_Output ("=g", Var_Out), + Clobber => "ebx"); +@end group +@end smallexample + +The Clobber parameter is a static string expression specifying the +register(s) you are using. Note that register names are @emph{not} prefixed +by a percent sign. Also, if more than one register is used then their names +are separated by commas; e.g., @code{"eax, ebx"} + +The @code{Clobber} parameter has several additional uses: +@enumerate +@item Use ``register'' name @code{cc} to indicate that flags might have changed +@item Use ``register'' name @code{memory} if you changed a memory location +@end enumerate + +@c --------------------------------------------------------------------------- +@node The Volatile Parameter +@subsection The @code{Volatile} Parameter +@cindex Volatile parameter + +@noindent +Compiler optimizations in the presence of Inline Assembler may sometimes have +unwanted effects. For example, when an @code{Asm} invocation with an input +variable is inside a loop, the compiler might move the loading of the input +variable outside the loop, regarding it as a one-time initialization. + +If this effect is not desired, you can disable such optimizations by setting +the @code{Volatile} parameter to @code{True}; for example: + +@smallexample @c ada +@group +Asm ("movl %0, %%ebx" & LF & HT & + "movl %%ebx, %1", + Inputs => Unsigned_32'Asm_Input ("g", Var_In), + Outputs => Unsigned_32'Asm_Output ("=g", Var_Out), + Clobber => "ebx", + Volatile => True); +@end group +@end smallexample + +By default, @code{Volatile} is set to @code{False} unless there is no +@code{Outputs} parameter. + +Although setting @code{Volatile} to @code{True} prevents unwanted +optimizations, it will also disable other optimizations that might be +important for efficiency. In general, you should set @code{Volatile} +to @code{True} only if the compiler's optimizations have created +problems. +@c END OF INLINE ASSEMBLER CHAPTER +@c =============================== + +@c *********************************** +@c * Compatibility and Porting Guide * +@c *********************************** +@node Compatibility and Porting Guide +@appendix Compatibility and Porting Guide + +@noindent +This chapter describes the compatibility issues that may arise between +GNAT and other Ada compilation systems (including those for Ada 83), +and shows how GNAT can expedite porting +applications developed in other Ada environments. + +@menu +* Compatibility with Ada 83:: +* Compatibility between Ada 95 and Ada 2005:: +* Implementation-dependent characteristics:: +* Compatibility with Other Ada Systems:: +* Representation Clauses:: +@ifclear vms +@c Brief section is only in non-VMS version +@c Full chapter is in VMS version +* Compatibility with HP Ada 83:: +@end ifclear +@ifset vms +* Transitioning to 64-Bit GNAT for OpenVMS:: +@end ifset +@end menu + +@node Compatibility with Ada 83 +@section Compatibility with Ada 83 +@cindex Compatibility (between Ada 83 and Ada 95 / Ada 2005) + +@noindent +Ada 95 and Ada 2005 are highly upwards compatible with Ada 83. In +particular, the design intention was that the difficulties associated +with moving from Ada 83 to Ada 95 or Ada 2005 should be no greater than those +that occur when moving from one Ada 83 system to another. + +However, there are a number of points at which there are minor +incompatibilities. The @cite{Ada 95 Annotated Reference Manual} contains +full details of these issues, +and should be consulted for a complete treatment. +In practice the +following subsections treat the most likely issues to be encountered. + +@menu +* Legal Ada 83 programs that are illegal in Ada 95:: +* More deterministic semantics:: +* Changed semantics:: +* Other language compatibility issues:: +@end menu + +@node Legal Ada 83 programs that are illegal in Ada 95 +@subsection Legal Ada 83 programs that are illegal in Ada 95 + +Some legal Ada 83 programs are illegal (i.e., they will fail to compile) in +Ada 95 and thus also in Ada 2005: + +@table @emph +@item Character literals +Some uses of character literals are ambiguous. Since Ada 95 has introduced +@code{Wide_Character} as a new predefined character type, some uses of +character literals that were legal in Ada 83 are illegal in Ada 95. +For example: +@smallexample @c ada + for Char in 'A' .. 'Z' loop @dots{} end loop; +@end smallexample + +@noindent +The problem is that @code{'A'} and @code{'Z'} could be from either +@code{Character} or @code{Wide_Character}. The simplest correction +is to make the type explicit; e.g.: +@smallexample @c ada + for Char in Character range 'A' .. 'Z' loop @dots{} end loop; +@end smallexample + +@item New reserved words +The identifiers @code{abstract}, @code{aliased}, @code{protected}, +@code{requeue}, @code{tagged}, and @code{until} are reserved in Ada 95. +Existing Ada 83 code using any of these identifiers must be edited to +use some alternative name. + +@item Freezing rules +The rules in Ada 95 are slightly different with regard to the point at +which entities are frozen, and representation pragmas and clauses are +not permitted past the freeze point. This shows up most typically in +the form of an error message complaining that a representation item +appears too late, and the appropriate corrective action is to move +the item nearer to the declaration of the entity to which it refers. + +A particular case is that representation pragmas +@ifset vms +(including the +extended HP Ada 83 compatibility pragmas such as @code{Export_Procedure}) +@end ifset +cannot be applied to a subprogram body. If necessary, a separate subprogram +declaration must be introduced to which the pragma can be applied. + +@item Optional bodies for library packages +In Ada 83, a package that did not require a package body was nevertheless +allowed to have one. This lead to certain surprises in compiling large +systems (situations in which the body could be unexpectedly ignored by the +binder). In Ada 95, if a package does not require a body then it is not +permitted to have a body. To fix this problem, simply remove a redundant +body if it is empty, or, if it is non-empty, introduce a dummy declaration +into the spec that makes the body required. One approach is to add a private +part to the package declaration (if necessary), and define a parameterless +procedure called @code{Requires_Body}, which must then be given a dummy +procedure body in the package body, which then becomes required. +Another approach (assuming that this does not introduce elaboration +circularities) is to add an @code{Elaborate_Body} pragma to the package spec, +since one effect of this pragma is to require the presence of a package body. + +@item @code{Numeric_Error} is now the same as @code{Constraint_Error} +In Ada 95, the exception @code{Numeric_Error} is a renaming of +@code{Constraint_Error}. +This means that it is illegal to have separate exception handlers for +the two exceptions. The fix is simply to remove the handler for the +@code{Numeric_Error} case (since even in Ada 83, a compiler was free to raise +@code{Constraint_Error} in place of @code{Numeric_Error} in all cases). + +@item Indefinite subtypes in generics +In Ada 83, it was permissible to pass an indefinite type (e.g.@: @code{String}) +as the actual for a generic formal private type, but then the instantiation +would be illegal if there were any instances of declarations of variables +of this type in the generic body. In Ada 95, to avoid this clear violation +of the methodological principle known as the ``contract model'', +the generic declaration explicitly indicates whether +or not such instantiations are permitted. If a generic formal parameter +has explicit unknown discriminants, indicated by using @code{(<>)} after the +type name, then it can be instantiated with indefinite types, but no +stand-alone variables can be declared of this type. Any attempt to declare +such a variable will result in an illegality at the time the generic is +declared. If the @code{(<>)} notation is not used, then it is illegal +to instantiate the generic with an indefinite type. +This is the potential incompatibility issue when porting Ada 83 code to Ada 95. +It will show up as a compile time error, and +the fix is usually simply to add the @code{(<>)} to the generic declaration. +@end table + +@node More deterministic semantics +@subsection More deterministic semantics + +@table @emph +@item Conversions +Conversions from real types to integer types round away from 0. In Ada 83 +the conversion Integer(2.5) could deliver either 2 or 3 as its value. This +implementation freedom was intended to support unbiased rounding in +statistical applications, but in practice it interfered with portability. +In Ada 95 the conversion semantics are unambiguous, and rounding away from 0 +is required. Numeric code may be affected by this change in semantics. +Note, though, that this issue is no worse than already existed in Ada 83 +when porting code from one vendor to another. + +@item Tasking +The Real-Time Annex introduces a set of policies that define the behavior of +features that were implementation dependent in Ada 83, such as the order in +which open select branches are executed. +@end table + +@node Changed semantics +@subsection Changed semantics + +@noindent +The worst kind of incompatibility is one where a program that is legal in +Ada 83 is also legal in Ada 95 but can have an effect in Ada 95 that was not +possible in Ada 83. Fortunately this is extremely rare, but the one +situation that you should be alert to is the change in the predefined type +@code{Character} from 7-bit ASCII to 8-bit Latin-1. + +@table @emph +@item Range of type @code{Character} +The range of @code{Standard.Character} is now the full 256 characters +of Latin-1, whereas in most Ada 83 implementations it was restricted +to 128 characters. Although some of the effects of +this change will be manifest in compile-time rejection of legal +Ada 83 programs it is possible for a working Ada 83 program to have +a different effect in Ada 95, one that was not permitted in Ada 83. +As an example, the expression +@code{Character'Pos(Character'Last)} returned @code{127} in Ada 83 and now +delivers @code{255} as its value. +In general, you should look at the logic of any +character-processing Ada 83 program and see whether it needs to be adapted +to work correctly with Latin-1. Note that the predefined Ada 95 API has a +character handling package that may be relevant if code needs to be adapted +to account for the additional Latin-1 elements. +The desirable fix is to +modify the program to accommodate the full character set, but in some cases +it may be convenient to define a subtype or derived type of Character that +covers only the restricted range. +@cindex Latin-1 +@end table + +@node Other language compatibility issues +@subsection Other language compatibility issues + +@table @emph +@item @option{-gnat83} switch +All implementations of GNAT provide a switch that causes GNAT to operate +in Ada 83 mode. In this mode, some but not all compatibility problems +of the type described above are handled automatically. For example, the +new reserved words introduced in Ada 95 and Ada 2005 are treated simply +as identifiers as in Ada 83. +However, +in practice, it is usually advisable to make the necessary modifications +to the program to remove the need for using this switch. +See @ref{Compiling Different Versions of Ada}. + +@item Support for removed Ada 83 pragmas and attributes +A number of pragmas and attributes from Ada 83 were removed from Ada 95, +generally because they were replaced by other mechanisms. Ada 95 and Ada 2005 +compilers are allowed, but not required, to implement these missing +elements. In contrast with some other compilers, GNAT implements all +such pragmas and attributes, eliminating this compatibility concern. These +include @code{pragma Interface} and the floating point type attributes +(@code{Emax}, @code{Mantissa}, etc.), among other items. +@end table + + +@node Compatibility between Ada 95 and Ada 2005 +@section Compatibility between Ada 95 and Ada 2005 +@cindex Compatibility between Ada 95 and Ada 2005 + +@noindent +Although Ada 2005 was designed to be upwards compatible with Ada 95, there are +a number of incompatibilities. Several are enumerated below; +for a complete description please see the +Annotated Ada 2005 Reference Manual, or section 9.1.1 in +@cite{Rationale for Ada 2005}. + +@table @emph +@item New reserved words. +The words @code{interface}, @code{overriding} and @code{synchronized} are +reserved in Ada 2005. +A pre-Ada 2005 program that uses any of these as an identifier will be +illegal. + +@item New declarations in predefined packages. +A number of packages in the predefined environment contain new declarations: +@code{Ada.Exceptions}, @code{Ada.Real_Time}, @code{Ada.Strings}, +@code{Ada.Strings.Fixed}, @code{Ada.Strings.Bounded}, +@code{Ada.Strings.Unbounded}, @code{Ada.Strings.Wide_Fixed}, +@code{Ada.Strings.Wide_Bounded}, @code{Ada.Strings.Wide_Unbounded}, +@code{Ada.Tags}, @code{Ada.Text_IO}, and @code{Interfaces.C}. +If an Ada 95 program does a @code{with} and @code{use} of any of these +packages, the new declarations may cause name clashes. + +@item Access parameters. +A nondispatching subprogram with an access parameter cannot be renamed +as a dispatching operation. This was permitted in Ada 95. + +@item Access types, discriminants, and constraints. +Rule changes in this area have led to some incompatibilities; for example, +constrained subtypes of some access types are not permitted in Ada 2005. + +@item Aggregates for limited types. +The allowance of aggregates for limited types in Ada 2005 raises the +possibility of ambiguities in legal Ada 95 programs, since additional types +now need to be considered in expression resolution. + +@item Fixed-point multiplication and division. +Certain expressions involving ``*'' or ``/'' for a fixed-point type, which +were legal in Ada 95 and invoked the predefined versions of these operations, +are now ambiguous. +The ambiguity may be resolved either by applying a type conversion to the +expression, or by explicitly invoking the operation from package +@code{Standard}. + +@item Return-by-reference types. +The Ada 95 return-by-reference mechanism has been removed. Instead, the user +can declare a function returning a value from an anonymous access type. +@end table + + +@node Implementation-dependent characteristics +@section Implementation-dependent characteristics +@noindent +Although the Ada language defines the semantics of each construct as +precisely as practical, in some situations (for example for reasons of +efficiency, or where the effect is heavily dependent on the host or target +platform) the implementation is allowed some freedom. In porting Ada 83 +code to GNAT, you need to be aware of whether / how the existing code +exercised such implementation dependencies. Such characteristics fall into +several categories, and GNAT offers specific support in assisting the +transition from certain Ada 83 compilers. + +@menu +* Implementation-defined pragmas:: +* Implementation-defined attributes:: +* Libraries:: +* Elaboration order:: +* Target-specific aspects:: +@end menu + +@node Implementation-defined pragmas +@subsection Implementation-defined pragmas + +@noindent +Ada compilers are allowed to supplement the language-defined pragmas, and +these are a potential source of non-portability. All GNAT-defined pragmas +are described in @ref{Implementation Defined Pragmas,,, gnat_rm, GNAT +Reference Manual}, and these include several that are specifically +intended to correspond to other vendors' Ada 83 pragmas. +For migrating from VADS, the pragma @code{Use_VADS_Size} may be useful. +For compatibility with HP Ada 83, GNAT supplies the pragmas +@code{Extend_System}, @code{Ident}, @code{Inline_Generic}, +@code{Interface_Name}, @code{Passive}, @code{Suppress_All}, +and @code{Volatile}. +Other relevant pragmas include @code{External} and @code{Link_With}. +Some vendor-specific +Ada 83 pragmas (@code{Share_Generic}, @code{Subtitle}, and @code{Title}) are +recognized, thus +avoiding compiler rejection of units that contain such pragmas; they are not +relevant in a GNAT context and hence are not otherwise implemented. + +@node Implementation-defined attributes +@subsection Implementation-defined attributes + +Analogous to pragmas, the set of attributes may be extended by an +implementation. All GNAT-defined attributes are described in +@ref{Implementation Defined Attributes,,, gnat_rm, GNAT Reference +Manual}, and these include several that are specifically intended +to correspond to other vendors' Ada 83 attributes. For migrating from VADS, +the attribute @code{VADS_Size} may be useful. For compatibility with HP +Ada 83, GNAT supplies the attributes @code{Bit}, @code{Machine_Size} and +@code{Type_Class}. + +@node Libraries +@subsection Libraries +@noindent +Vendors may supply libraries to supplement the standard Ada API. If Ada 83 +code uses vendor-specific libraries then there are several ways to manage +this in Ada 95 or Ada 2005: +@enumerate +@item +If the source code for the libraries (specs and bodies) are +available, then the libraries can be migrated in the same way as the +application. +@item +If the source code for the specs but not the bodies are +available, then you can reimplement the bodies. +@item +Some features introduced by Ada 95 obviate the need for library support. For +example most Ada 83 vendors supplied a package for unsigned integers. The +Ada 95 modular type feature is the preferred way to handle this need, so +instead of migrating or reimplementing the unsigned integer package it may +be preferable to retrofit the application using modular types. +@end enumerate + +@node Elaboration order +@subsection Elaboration order +@noindent +The implementation can choose any elaboration order consistent with the unit +dependency relationship. This freedom means that some orders can result in +Program_Error being raised due to an ``Access Before Elaboration'': an attempt +to invoke a subprogram its body has been elaborated, or to instantiate a +generic before the generic body has been elaborated. By default GNAT +attempts to choose a safe order (one that will not encounter access before +elaboration problems) by implicitly inserting @code{Elaborate} or +@code{Elaborate_All} pragmas where +needed. However, this can lead to the creation of elaboration circularities +and a resulting rejection of the program by gnatbind. This issue is +thoroughly described in @ref{Elaboration Order Handling in GNAT}. +In brief, there are several +ways to deal with this situation: + +@itemize @bullet +@item +Modify the program to eliminate the circularities, e.g.@: by moving +elaboration-time code into explicitly-invoked procedures +@item +Constrain the elaboration order by including explicit @code{Elaborate_Body} or +@code{Elaborate} pragmas, and then inhibit the generation of implicit +@code{Elaborate_All} +pragmas either globally (as an effect of the @option{-gnatE} switch) or locally +(by selectively suppressing elaboration checks via pragma +@code{Suppress(Elaboration_Check)} when it is safe to do so). +@end itemize + +@node Target-specific aspects +@subsection Target-specific aspects +@noindent +Low-level applications need to deal with machine addresses, data +representations, interfacing with assembler code, and similar issues. If +such an Ada 83 application is being ported to different target hardware (for +example where the byte endianness has changed) then you will need to +carefully examine the program logic; the porting effort will heavily depend +on the robustness of the original design. Moreover, Ada 95 (and thus +Ada 2005) are sometimes +incompatible with typical Ada 83 compiler practices regarding implicit +packing, the meaning of the Size attribute, and the size of access values. +GNAT's approach to these issues is described in @ref{Representation Clauses}. + +@node Compatibility with Other Ada Systems +@section Compatibility with Other Ada Systems + +@noindent +If programs avoid the use of implementation dependent and +implementation defined features, as documented in the @cite{Ada +Reference Manual}, there should be a high degree of portability between +GNAT and other Ada systems. The following are specific items which +have proved troublesome in moving Ada 95 programs from GNAT to other Ada 95 +compilers, but do not affect porting code to GNAT@. +(As of @value{NOW}, GNAT is the only compiler available for Ada 2005; +the following issues may or may not arise for Ada 2005 programs +when other compilers appear.) + +@table @emph +@item Ada 83 Pragmas and Attributes +Ada 95 compilers are allowed, but not required, to implement the missing +Ada 83 pragmas and attributes that are no longer defined in Ada 95. +GNAT implements all such pragmas and attributes, eliminating this as +a compatibility concern, but some other Ada 95 compilers reject these +pragmas and attributes. + +@item Specialized Needs Annexes +GNAT implements the full set of special needs annexes. At the +current time, it is the only Ada 95 compiler to do so. This means that +programs making use of these features may not be portable to other Ada +95 compilation systems. + +@item Representation Clauses +Some other Ada 95 compilers implement only the minimal set of +representation clauses required by the Ada 95 reference manual. GNAT goes +far beyond this minimal set, as described in the next section. +@end table + +@node Representation Clauses +@section Representation Clauses + +@noindent +The Ada 83 reference manual was quite vague in describing both the minimal +required implementation of representation clauses, and also their precise +effects. Ada 95 (and thus also Ada 2005) are much more explicit, but the +minimal set of capabilities required is still quite limited. + +GNAT implements the full required set of capabilities in +Ada 95 and Ada 2005, but also goes much further, and in particular +an effort has been made to be compatible with existing Ada 83 usage to the +greatest extent possible. + +A few cases exist in which Ada 83 compiler behavior is incompatible with +the requirements in Ada 95 (and thus also Ada 2005). These are instances of +intentional or accidental dependence on specific implementation dependent +characteristics of these Ada 83 compilers. The following is a list of +the cases most likely to arise in existing Ada 83 code. + +@table @emph +@item Implicit Packing +Some Ada 83 compilers allowed a Size specification to cause implicit +packing of an array or record. This could cause expensive implicit +conversions for change of representation in the presence of derived +types, and the Ada design intends to avoid this possibility. +Subsequent AI's were issued to make it clear that such implicit +change of representation in response to a Size clause is inadvisable, +and this recommendation is represented explicitly in the Ada 95 (and Ada 2005) +Reference Manuals as implementation advice that is followed by GNAT@. +The problem will show up as an error +message rejecting the size clause. The fix is simply to provide +the explicit pragma @code{Pack}, or for more fine tuned control, provide +a Component_Size clause. + +@item Meaning of Size Attribute +The Size attribute in Ada 95 (and Ada 2005) for discrete types is defined as +the minimal number of bits required to hold values of the type. For example, +on a 32-bit machine, the size of @code{Natural} will typically be 31 and not +32 (since no sign bit is required). Some Ada 83 compilers gave 31, and +some 32 in this situation. This problem will usually show up as a compile +time error, but not always. It is a good idea to check all uses of the +'Size attribute when porting Ada 83 code. The GNAT specific attribute +Object_Size can provide a useful way of duplicating the behavior of +some Ada 83 compiler systems. + +@item Size of Access Types +A common assumption in Ada 83 code is that an access type is in fact a pointer, +and that therefore it will be the same size as a System.Address value. This +assumption is true for GNAT in most cases with one exception. For the case of +a pointer to an unconstrained array type (where the bounds may vary from one +value of the access type to another), the default is to use a ``fat pointer'', +which is represented as two separate pointers, one to the bounds, and one to +the array. This representation has a number of advantages, including improved +efficiency. However, it may cause some difficulties in porting existing Ada 83 +code which makes the assumption that, for example, pointers fit in 32 bits on +a machine with 32-bit addressing. + +To get around this problem, GNAT also permits the use of ``thin pointers'' for +access types in this case (where the designated type is an unconstrained array +type). These thin pointers are indeed the same size as a System.Address value. +To specify a thin pointer, use a size clause for the type, for example: + +@smallexample @c ada +type X is access all String; +for X'Size use Standard'Address_Size; +@end smallexample + +@noindent +which will cause the type X to be represented using a single pointer. +When using this representation, the bounds are right behind the array. +This representation is slightly less efficient, and does not allow quite +such flexibility in the use of foreign pointers or in using the +Unrestricted_Access attribute to create pointers to non-aliased objects. +But for any standard portable use of the access type it will work in +a functionally correct manner and allow porting of existing code. +Note that another way of forcing a thin pointer representation +is to use a component size clause for the element size in an array, +or a record representation clause for an access field in a record. +@end table + +@ifclear vms +@c This brief section is only in the non-VMS version +@c The complete chapter on HP Ada is in the VMS version +@node Compatibility with HP Ada 83 +@section Compatibility with HP Ada 83 + +@noindent +The VMS version of GNAT fully implements all the pragmas and attributes +provided by HP Ada 83, as well as providing the standard HP Ada 83 +libraries, including Starlet. In addition, data layouts and parameter +passing conventions are highly compatible. This means that porting +existing HP Ada 83 code to GNAT in VMS systems should be easier than +most other porting efforts. The following are some of the most +significant differences between GNAT and HP Ada 83. + +@table @emph +@item Default floating-point representation +In GNAT, the default floating-point format is IEEE, whereas in HP Ada 83, +it is VMS format. GNAT does implement the necessary pragmas +(Long_Float, Float_Representation) for changing this default. + +@item System +The package System in GNAT exactly corresponds to the definition in the +Ada 95 reference manual, which means that it excludes many of the +HP Ada 83 extensions. However, a separate package Aux_DEC is provided +that contains the additional definitions, and a special pragma, +Extend_System allows this package to be treated transparently as an +extension of package System. + +@item To_Address +The definitions provided by Aux_DEC are exactly compatible with those +in the HP Ada 83 version of System, with one exception. +HP Ada provides the following declarations: + +@smallexample @c ada +TO_ADDRESS (INTEGER) +TO_ADDRESS (UNSIGNED_LONGWORD) +TO_ADDRESS (@i{universal_integer}) +@end smallexample + +@noindent +The version of TO_ADDRESS taking a @i{universal integer} argument is in fact +an extension to Ada 83 not strictly compatible with the reference manual. +In GNAT, we are constrained to be exactly compatible with the standard, +and this means we cannot provide this capability. In HP Ada 83, the +point of this definition is to deal with a call like: + +@smallexample @c ada +TO_ADDRESS (16#12777#); +@end smallexample + +@noindent +Normally, according to the Ada 83 standard, one would expect this to be +ambiguous, since it matches both the INTEGER and UNSIGNED_LONGWORD forms +of TO_ADDRESS@. However, in HP Ada 83, there is no ambiguity, since the +definition using @i{universal_integer} takes precedence. + +In GNAT, since the version with @i{universal_integer} cannot be supplied, it +is not possible to be 100% compatible. Since there are many programs using +numeric constants for the argument to TO_ADDRESS, the decision in GNAT was +to change the name of the function in the UNSIGNED_LONGWORD case, so the +declarations provided in the GNAT version of AUX_Dec are: + +@smallexample @c ada +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); +@end smallexample + +@noindent +This means that programs using TO_ADDRESS for UNSIGNED_LONGWORD must +change the name to TO_ADDRESS_LONG@. + +@item Task_Id values +The Task_Id values assigned will be different in the two systems, and GNAT +does not provide a specified value for the Task_Id of the environment task, +which in GNAT is treated like any other declared task. +@end table + +@noindent +For full details on these and other less significant compatibility issues, +see appendix E of the HP publication entitled @cite{HP Ada, Technical +Overview and Comparison on HP Platforms}. + +For GNAT running on other than VMS systems, all the HP Ada 83 pragmas and +attributes are recognized, although only a subset of them can sensibly +be implemented. The description of pragmas in @ref{Implementation +Defined Pragmas,,, gnat_rm, GNAT Reference Manual} +indicates whether or not they are applicable to non-VMS systems. +@end ifclear + +@ifset vms +@node Transitioning to 64-Bit GNAT for OpenVMS +@section Transitioning to 64-Bit @value{EDITION} for OpenVMS + +@noindent +This section is meant to assist users of pre-2006 @value{EDITION} +for Alpha OpenVMS who are transitioning to 64-bit @value{EDITION}, +the version of the GNAT technology supplied in 2006 and later for +OpenVMS on both Alpha and I64. + +@menu +* Introduction to transitioning:: +* Migration of 32 bit code:: +* Taking advantage of 64 bit addressing:: +* Technical details:: +@end menu + +@node Introduction to transitioning +@subsection Introduction + +@noindent +64-bit @value{EDITION} for Open VMS has been designed to meet +three main goals: + +@enumerate +@item +Providing a full conforming implementation of Ada 95 and Ada 2005 + +@item +Allowing maximum backward compatibility, thus easing migration of existing +Ada source code + +@item +Supplying a path for exploiting the full 64-bit address range +@end enumerate + +@noindent +Ada's strong typing semantics has made it +impractical to have different 32-bit and 64-bit modes. As soon as +one object could possibly be outside the 32-bit address space, this +would make it necessary for the @code{System.Address} type to be 64 bits. +In particular, this would cause inconsistencies if 32-bit code is +called from 64-bit code that raises an exception. + +This issue has been resolved by always using 64-bit addressing +at the system level, but allowing for automatic conversions between +32-bit and 64-bit addresses where required. Thus users who +do not currently require 64-bit addressing capabilities, can +recompile their code with only minimal changes (and indeed +if the code is written in portable Ada, with no assumptions about +the size of the @code{Address} type, then no changes at all are necessary). +At the same time, +this approach provides a simple, gradual upgrade path to future +use of larger memories than available for 32-bit systems. +Also, newly written applications or libraries will by default +be fully compatible with future systems exploiting 64-bit +addressing capabilities. + +@ref{Migration of 32 bit code}, will focus on porting applications +that do not require more than 2 GB of +addressable memory. This code will be referred to as +@emph{32-bit code}. +For applications intending to exploit the full 64-bit address space, +@ref{Taking advantage of 64 bit addressing}, +will consider further changes that may be required. +Such code will be referred to below as @emph{64-bit code}. + +@node Migration of 32 bit code +@subsection Migration of 32-bit code + +@menu +* Address types:: +* Access types and 32/64-bit allocation:: +* Unchecked conversions:: +* Predefined constants:: +* Interfacing with C:: +* 32/64-bit descriptors:: +* Experience with source compatibility:: +@end menu + +@node Address types +@subsubsection Address types + +@noindent +To solve the problem of mixing 64-bit and 32-bit addressing, +while maintaining maximum backward compatibility, the following +approach has been taken: + +@itemize @bullet +@item +@code{System.Address} always has a size of 64 bits +@cindex @code{System.Address} size +@cindex @code{Address} size + +@item +@code{System.Short_Address} is a 32-bit subtype of @code{System.Address} +@cindex @code{System.Short_Address} size +@cindex @code{Short_Address} size +@end itemize + +@noindent +Since @code{System.Short_Address} is a subtype of @code{System.Address}, +a @code{Short_Address} +may be used where an @code{Address} is required, and vice versa, without +needing explicit type conversions. +By virtue of the Open VMS parameter passing conventions, +even imported +and exported subprograms that have 32-bit address parameters are +compatible with those that have 64-bit address parameters. +(See @ref{Making code 64 bit clean} for details.) + +The areas that may need attention are those where record types have +been defined that contain components of the type @code{System.Address}, and +where objects of this type are passed to code expecting a record layout with +32-bit addresses. + +Different compilers on different platforms cannot be +expected to represent the same type in the same way, +since alignment constraints +and other system-dependent properties affect the compiler's decision. +For that reason, Ada code +generally uses representation clauses to specify the expected +layout where required. + +If such a representation clause uses 32 bits for a component having +the type @code{System.Address}, 64-bit @value{EDITION} for OpenVMS +will detect that error and produce a specific diagnostic message. +The developer should then determine whether the representation +should be 64 bits or not and make either of two changes: +change the size to 64 bits and leave the type as @code{System.Address}, or +leave the size as 32 bits and change the type to @code{System.Short_Address}. +Since @code{Short_Address} is a subtype of @code{Address}, no changes are +required in any code setting or accessing the field; the compiler will +automatically perform any needed conversions between address +formats. + +@node Access types and 32/64-bit allocation +@subsubsection Access types and 32/64-bit allocation +@cindex 32-bit allocation +@cindex 64-bit allocation + +@noindent +By default, objects designated by access values are always allocated in +the 64-bit address space, and access values themselves are represented +in 64 bits. If these defaults are not appropriate, and 32-bit allocation +is required (for example if the address of an allocated object is assigned +to a @code{Short_Address} variable), then several alternatives are available: + +@itemize @bullet +@item +A pool-specific access type (ie, an @w{Ada 83} access type, whose +definition is @code{access T} versus @code{access all T} or +@code{access constant T}), may be declared with a @code{'Size} representation +clause that establishes the size as 32 bits. +In such circumstances allocations for that type will +be from the 32-bit heap. Such a clause is not permitted +for a general access type (declared with @code{access all} or +@code{access constant}) as values of such types must be able to refer +to any object of the designated type, including objects residing outside +the 32-bit address range. Existing @w{Ada 83} code will not contain such +type definitions, however, since general access types were introduced +in @w{Ada 95}. + +@item +Switches for @command{GNAT BIND} control whether the internal GNAT +allocation routine @code{__gnat_malloc} uses 64-bit or 32-bit allocations. +@cindex @code{__gnat_malloc} +The switches are respectively @option{-H64} (the default) and +@option{-H32}. +@cindex @option{-H32} (@command{gnatbind}) +@cindex @option{-H64} (@command{gnatbind}) + +@item +The environment variable (logical name) @code{GNAT$NO_MALLOC_64} +@cindex @code{GNAT$NO_MALLOC_64} environment variable +may be used to force @code{__gnat_malloc} to use 32-bit allocation. +If this variable is left +undefined, or defined as @code{"DISABLE"}, @code{"FALSE"}, or @code{"0"}, +then the default (64-bit) allocation is used. +If defined as @code{"ENABLE"}, @code{"TRUE"}, or @code{"1"}, +then 32-bit allocation is used. The gnatbind qualifiers described above +override this logical name. + +@item +A ^gcc switch^gcc switch^ for OpenVMS, @option{-mno-malloc64}, operates +@cindex @option{-mno-malloc64} (^gcc^gcc^) +at a low level to convert explicit calls to @code{malloc} and related +functions from the C run-time library so that they perform allocations +in the 32-bit heap. +Since all internal allocations from GNAT use @code{__gnat_malloc}, +this switch is not required unless the program makes explicit calls on +@code{malloc} (or related functions) from interfaced C code. +@end itemize + + +@node Unchecked conversions +@subsubsection Unchecked conversions + +@noindent +In the case of an @code{Unchecked_Conversion} where the source type is a +64-bit access type or the type @code{System.Address}, and the target +type is a 32-bit type, the compiler will generate a warning. +Even though the generated code will still perform the required +conversions, it is highly recommended in these cases to use +respectively a 32-bit access type or @code{System.Short_Address} +as the source type. + +@node Predefined constants +@subsubsection Predefined constants + +@noindent +The following table shows the correspondence between pre-2006 versions of +@value{EDITION} on Alpha OpenVMS (``Old'') and 64-bit @value{EDITION} +(``New''): + +@multitable {@code{System.Short_Memory_Size}} {2**32} {2**64} +@item @b{Constant} @tab @b{Old} @tab @b{New} +@item @code{System.Word_Size} @tab 32 @tab 64 +@item @code{System.Memory_Size} @tab 2**32 @tab 2**64 +@item @code{System.Short_Memory_Size} @tab 2**32 @tab 2**32 +@item @code{System.Address_Size} @tab 32 @tab 64 +@end multitable + +@noindent +If you need to refer to the specific +memory size of a 32-bit implementation, instead of the +actual memory size, use @code{System.Short_Memory_Size} +rather than @code{System.Memory_Size}. +Similarly, references to @code{System.Address_Size} may need +to be replaced by @code{System.Short_Address'Size}. +The program @command{gnatfind} may be useful for locating +references to the above constants, so that you can verify that they +are still correct. + +@node Interfacing with C +@subsubsection Interfacing with C + +@noindent +In order to minimize the impact of the transition to 64-bit addresses on +legacy programs, some fundamental types in the @code{Interfaces.C} +package hierarchy continue to be represented in 32 bits. +These types are: @code{ptrdiff_t}, @code{size_t}, and @code{chars_ptr}. +This eases integration with the default HP C layout choices, for example +as found in the system routines in @code{DECC$SHR.EXE}. +Because of this implementation choice, the type fully compatible with +@code{chars_ptr} is now @code{Short_Address} and not @code{Address}. +Depending on the context the compiler will issue a +warning or an error when type @code{Address} is used, alerting the user to a +potential problem. Otherwise 32-bit programs that use +@code{Interfaces.C} should normally not require code modifications + +The other issue arising with C interfacing concerns pragma @code{Convention}. +For VMS 64-bit systems, there is an issue of the appropriate default size +of C convention pointers in the absence of an explicit size clause. The HP +C compiler can choose either 32 or 64 bits depending on compiler options. +GNAT chooses 32-bits rather than 64-bits in the default case where no size +clause is given. This proves a better choice for porting 32-bit legacy +applications. In order to have a 64-bit representation, it is necessary to +specify a size representation clause. For example: + +@smallexample @c ada +type int_star is access Interfaces.C.int; +pragma Convention(C, int_star); +for int_star'Size use 64; -- Necessary to get 64 and not 32 bits +@end smallexample + +@node 32/64-bit descriptors +@subsubsection 32/64-bit descriptors + +@noindent +By default, GNAT uses a 64-bit descriptor mechanism. For an imported +subprogram (i.e., a subprogram identified by pragma @code{Import_Function}, +@code{Import_Procedure}, or @code{Import_Valued_Procedure}) that specifies +@code{Short_Descriptor} as its mechanism, a 32-bit descriptor is used. +@cindex @code{Short_Descriptor} mechanism for imported subprograms + +If the configuration pragma @code{Short_Descriptors} is supplied, then +all descriptors will be 32 bits. +@cindex pragma @code{Short_Descriptors} + +@node Experience with source compatibility +@subsubsection Experience with source compatibility + +@noindent +The Security Server and STARLET on I64 provide an interesting ``test case'' +for source compatibility issues, since it is in such system code +where assumptions about @code{Address} size might be expected to occur. +Indeed, there were a small number of occasions in the Security Server +file @file{jibdef.ads} +where a representation clause for a record type specified +32 bits for a component of type @code{Address}. +All of these errors were detected by the compiler. +The repair was obvious and immediate; to simply replace @code{Address} by +@code{Short_Address}. + +In the case of STARLET, there were several record types that should +have had representation clauses but did not. In these record types +there was an implicit assumption that an @code{Address} value occupied +32 bits. +These compiled without error, but their usage resulted in run-time error +returns from STARLET system calls. +Future GNAT technology enhancements may include a tool that detects and flags +these sorts of potential source code porting problems. + +@c **************************************** +@node Taking advantage of 64 bit addressing +@subsection Taking advantage of 64-bit addressing + +@menu +* Making code 64 bit clean:: +* Allocating memory from the 64 bit storage pool:: +* Restrictions on use of 64 bit objects:: +* STARLET and other predefined libraries:: +@end menu + +@node Making code 64 bit clean +@subsubsection Making code 64-bit clean + +@noindent +In order to prevent problems that may occur when (parts of) a +system start using memory outside the 32-bit address range, +we recommend some additional guidelines: + +@itemize @bullet +@item +For imported subprograms that take parameters of the +type @code{System.Address}, ensure that these subprograms can +indeed handle 64-bit addresses. If not, or when in doubt, +change the subprogram declaration to specify +@code{System.Short_Address} instead. + +@item +Resolve all warnings related to size mismatches in +unchecked conversions. Failing to do so causes +erroneous execution if the source object is outside +the 32-bit address space. + +@item +(optional) Explicitly use the 32-bit storage pool +for access types used in a 32-bit context, or use +generic access types where possible +(@pxref{Restrictions on use of 64 bit objects}). +@end itemize + +@noindent +If these rules are followed, the compiler will automatically insert +any necessary checks to ensure that no addresses or access values +passed to 32-bit code ever refer to objects outside the 32-bit +address range. +Any attempt to do this will raise @code{Constraint_Error}. + +@node Allocating memory from the 64 bit storage pool +@subsubsection Allocating memory from the 64-bit storage pool + +@noindent +By default, all allocations -- for both pool-specific and general +access types -- use the 64-bit storage pool. To override +this default, for an individual access type or globally, see +@ref{Access types and 32/64-bit allocation}. + +@node Restrictions on use of 64 bit objects +@subsubsection Restrictions on use of 64-bit objects + +@noindent +Taking the address of an object allocated from a 64-bit storage pool, +and then passing this address to a subprogram expecting +@code{System.Short_Address}, +or assigning it to a variable of type @code{Short_Address}, will cause +@code{Constraint_Error} to be raised. In case the code is not 64-bit clean +(@pxref{Making code 64 bit clean}), or checks are suppressed, +no exception is raised and execution +will become erroneous. + +@node STARLET and other predefined libraries +@subsubsection STARLET and other predefined libraries + +@noindent +All code that comes as part of GNAT is 64-bit clean, but the +restrictions given in @ref{Restrictions on use of 64 bit objects}, +still apply. Look at the package +specs to see in which contexts objects allocated +in 64-bit address space are acceptable. + +@node Technical details +@subsection Technical details + +@noindent +64-bit @value{EDITION} for Open VMS takes advantage of the freedom given in the +Ada standard with respect to the type of @code{System.Address}. Previous +versions of GNAT Pro have defined this type as private and implemented it as a +modular type. + +In order to allow defining @code{System.Short_Address} as a proper subtype, +and to match the implicit sign extension in parameter passing, +in 64-bit @value{EDITION} for Open VMS, @code{System.Address} is defined as a +visible (i.e., non-private) integer type. +Standard operations on the type, such as the binary operators ``+'', ``-'', +etc., that take @code{Address} operands and return an @code{Address} result, +have been hidden by declaring these +@code{abstract}, a feature introduced in Ada 95 that helps avoid the potential +ambiguities that would otherwise result from overloading. +(Note that, although @code{Address} is a visible integer type, +good programming practice dictates against exploiting the type's +integer properties such as literals, since this will compromise +code portability.) + +Defining @code{Address} as a visible integer type helps achieve +maximum compatibility for existing Ada code, +without sacrificing the capabilities of the 64-bit architecture. +@end ifset + +@c ************************************************ +@ifset unw +@node Microsoft Windows Topics +@appendix Microsoft Windows Topics +@cindex Windows NT +@cindex Windows 95 +@cindex Windows 98 + +@noindent +This chapter describes topics that are specific to the Microsoft Windows +platforms (NT, 2000, and XP Professional). + +@menu +* Using GNAT on Windows:: +* Using a network installation of GNAT:: +* CONSOLE and WINDOWS subsystems:: +* Temporary Files:: +* Mixed-Language Programming on Windows:: +* Windows Calling Conventions:: +* Introduction to Dynamic Link Libraries (DLLs):: +* Using DLLs with GNAT:: +* Building DLLs with GNAT Project files:: +* Building DLLs with GNAT:: +* Building DLLs with gnatdll:: +* GNAT and Windows Resources:: +* Debugging a DLL:: +* Setting Stack Size from gnatlink:: +* Setting Heap Size from gnatlink:: +@end menu + +@node Using GNAT on Windows +@section Using GNAT on Windows + +@noindent +One of the strengths of the GNAT technology is that its tool set +(@command{gcc}, @command{gnatbind}, @command{gnatlink}, @command{gnatmake}, the +@code{gdb} debugger, etc.) is used in the same way regardless of the +platform. + +On Windows this tool set is complemented by a number of Microsoft-specific +tools that have been provided to facilitate interoperability with Windows +when this is required. With these tools: + +@itemize @bullet + +@item +You can build applications using the @code{CONSOLE} or @code{WINDOWS} +subsystems. + +@item +You can use any Dynamically Linked Library (DLL) in your Ada code (both +relocatable and non-relocatable DLLs are supported). + +@item +You can build Ada DLLs for use in other applications. These applications +can be written in a language other than Ada (e.g., C, C++, etc). Again both +relocatable and non-relocatable Ada DLLs are supported. + +@item +You can include Windows resources in your Ada application. + +@item +You can use or create COM/DCOM objects. +@end itemize + +@noindent +Immediately below are listed all known general GNAT-for-Windows restrictions. +Other restrictions about specific features like Windows Resources and DLLs +are listed in separate sections below. + +@itemize @bullet + +@item +It is not possible to use @code{GetLastError} and @code{SetLastError} +when tasking, protected records, or exceptions are used. In these +cases, in order to implement Ada semantics, the GNAT run-time system +calls certain Win32 routines that set the last error variable to 0 upon +success. It should be possible to use @code{GetLastError} and +@code{SetLastError} when tasking, protected record, and exception +features are not used, but it is not guaranteed to work. + +@item +It is not possible to link against Microsoft libraries except for +import libraries. Interfacing must be done by the mean of DLLs. + +@item +When the compilation environment is located on FAT32 drives, users may +experience recompilations of the source files that have not changed if +Daylight Saving Time (DST) state has changed since the last time files +were compiled. NTFS drives do not have this problem. + +@item +No components of the GNAT toolset use any entries in the Windows +registry. The only entries that can be created are file associations and +PATH settings, provided the user has chosen to create them at installation +time, as well as some minimal book-keeping information needed to correctly +uninstall or integrate different GNAT products. +@end itemize + +@node Using a network installation of GNAT +@section Using a network installation of GNAT + +@noindent +Make sure the system on which GNAT is installed is accessible from the +current machine, i.e., the install location is shared over the network. +Shared resources are accessed on Windows by means of UNC paths, which +have the format @code{\\server\sharename\path} + +In order to use such a network installation, simply add the UNC path of the +@file{bin} directory of your GNAT installation in front of your PATH. For +example, if GNAT is installed in @file{\GNAT} directory of a share location +called @file{c-drive} on a machine @file{LOKI}, the following command will +make it available: + +@code{@ @ @ path \\loki\c-drive\gnat\bin;%path%} + +Be aware that every compilation using the network installation results in the +transfer of large amounts of data across the network and will likely cause +serious performance penalty. + +@node CONSOLE and WINDOWS subsystems +@section CONSOLE and WINDOWS subsystems +@cindex CONSOLE Subsystem +@cindex WINDOWS Subsystem +@cindex -mwindows + +@noindent +There are two main subsystems under Windows. The @code{CONSOLE} subsystem +(which is the default subsystem) will always create a console when +launching the application. This is not something desirable when the +application has a Windows GUI. To get rid of this console the +application must be using the @code{WINDOWS} subsystem. To do so +the @option{-mwindows} linker option must be specified. + +@smallexample +$ gnatmake winprog -largs -mwindows +@end smallexample + +@node Temporary Files +@section Temporary Files +@cindex Temporary files + +@noindent +It is possible to control where temporary files gets created by setting +the @env{TMP} environment variable. The file will be created: + +@itemize +@item Under the directory pointed to by the @env{TMP} environment variable if +this directory exists. + +@item Under @file{c:\temp}, if the @env{TMP} environment variable is not +set (or not pointing to a directory) and if this directory exists. + +@item Under the current working directory otherwise. +@end itemize + +@noindent +This allows you to determine exactly where the temporary +file will be created. This is particularly useful in networked +environments where you may not have write access to some +directories. + +@node Mixed-Language Programming on Windows +@section Mixed-Language Programming on Windows + +@noindent +Developing pure Ada applications on Windows is no different than on +other GNAT-supported platforms. However, when developing or porting an +application that contains a mix of Ada and C/C++, the choice of your +Windows C/C++ development environment conditions your overall +interoperability strategy. + +If you use @command{gcc} to compile the non-Ada part of your application, +there are no Windows-specific restrictions that affect the overall +interoperability with your Ada code. If you do want to use the +Microsoft tools for your non-Ada code, you have two choices: + +@enumerate +@item +Encapsulate your non-Ada code in a DLL to be linked with your Ada +application. In this case, use the Microsoft or whatever environment to +build the DLL and use GNAT to build your executable +(@pxref{Using DLLs with GNAT}). + +@item +Or you can encapsulate your Ada code in a DLL to be linked with the +other part of your application. In this case, use GNAT to build the DLL +(@pxref{Building DLLs with GNAT Project files}) and use the Microsoft +or whatever environment to build your executable. +@end enumerate + +@node Windows Calling Conventions +@section Windows Calling Conventions +@findex Stdcall +@findex APIENTRY + +This section pertain only to Win32. On Win64 there is a single native +calling convention. All convention specifiers are ignored on this +platform. + +@menu +* C Calling Convention:: +* Stdcall Calling Convention:: +* Win32 Calling Convention:: +* DLL Calling Convention:: +@end menu + +@noindent +When a subprogram @code{F} (caller) calls a subprogram @code{G} +(callee), there are several ways to push @code{G}'s parameters on the +stack and there are several possible scenarios to clean up the stack +upon @code{G}'s return. A calling convention is an agreed upon software +protocol whereby the responsibilities between the caller (@code{F}) and +the callee (@code{G}) are clearly defined. Several calling conventions +are available for Windows: + +@itemize @bullet +@item +@code{C} (Microsoft defined) + +@item +@code{Stdcall} (Microsoft defined) + +@item +@code{Win32} (GNAT specific) + +@item +@code{DLL} (GNAT specific) +@end itemize + +@node C Calling Convention +@subsection @code{C} Calling Convention + +@noindent +This is the default calling convention used when interfacing to C/C++ +routines compiled with either @command{gcc} or Microsoft Visual C++. + +In the @code{C} calling convention subprogram parameters are pushed on the +stack by the caller from right to left. The caller itself is in charge of +cleaning up the stack after the call. In addition, the name of a routine +with @code{C} calling convention is mangled by adding a leading underscore. + +The name to use on the Ada side when importing (or exporting) a routine +with @code{C} calling convention is the name of the routine. For +instance the C function: + +@smallexample +int get_val (long); +@end smallexample + +@noindent +should be imported from Ada as follows: + +@smallexample @c ada +@group +function Get_Val (V : Interfaces.C.long) return Interfaces.C.int; +pragma Import (C, Get_Val, External_Name => "get_val"); +@end group +@end smallexample + +@noindent +Note that in this particular case the @code{External_Name} parameter could +have been omitted since, when missing, this parameter is taken to be the +name of the Ada entity in lower case. When the @code{Link_Name} parameter +is missing, as in the above example, this parameter is set to be the +@code{External_Name} with a leading underscore. + +When importing a variable defined in C, you should always use the @code{C} +calling convention unless the object containing the variable is part of a +DLL (in which case you should use the @code{Stdcall} calling +convention, @pxref{Stdcall Calling Convention}). + +@node Stdcall Calling Convention +@subsection @code{Stdcall} Calling Convention + +@noindent +This convention, which was the calling convention used for Pascal +programs, is used by Microsoft for all the routines in the Win32 API for +efficiency reasons. It must be used to import any routine for which this +convention was specified. + +In the @code{Stdcall} calling convention subprogram parameters are pushed +on the stack by the caller from right to left. The callee (and not the +caller) is in charge of cleaning the stack on routine exit. In addition, +the name of a routine with @code{Stdcall} calling convention is mangled by +adding a leading underscore (as for the @code{C} calling convention) and a +trailing @code{@@}@code{@var{nn}}, where @var{nn} is the overall size (in +bytes) of the parameters passed to the routine. + +The name to use on the Ada side when importing a C routine with a +@code{Stdcall} calling convention is the name of the C routine. The leading +underscore and trailing @code{@@}@code{@var{nn}} are added automatically by +the compiler. For instance the Win32 function: + +@smallexample +@b{APIENTRY} int get_val (long); +@end smallexample + +@noindent +should be imported from Ada as follows: + +@smallexample @c ada +@group +function Get_Val (V : Interfaces.C.long) return Interfaces.C.int; +pragma Import (Stdcall, Get_Val); +-- On the x86 a long is 4 bytes, so the Link_Name is "_get_val@@4" +@end group +@end smallexample + +@noindent +As for the @code{C} calling convention, when the @code{External_Name} +parameter is missing, it is taken to be the name of the Ada entity in lower +case. If instead of writing the above import pragma you write: + +@smallexample @c ada +@group +function Get_Val (V : Interfaces.C.long) return Interfaces.C.int; +pragma Import (Stdcall, Get_Val, External_Name => "retrieve_val"); +@end group +@end smallexample + +@noindent +then the imported routine is @code{_retrieve_val@@4}. However, if instead +of specifying the @code{External_Name} parameter you specify the +@code{Link_Name} as in the following example: + +@smallexample @c ada +@group +function Get_Val (V : Interfaces.C.long) return Interfaces.C.int; +pragma Import (Stdcall, Get_Val, Link_Name => "retrieve_val"); +@end group +@end smallexample + +@noindent +then the imported routine is @code{retrieve_val}, that is, there is no +decoration at all. No leading underscore and no Stdcall suffix +@code{@@}@code{@var{nn}}. + +@noindent +This is especially important as in some special cases a DLL's entry +point name lacks a trailing @code{@@}@code{@var{nn}} while the exported +name generated for a call has it. + +@noindent +It is also possible to import variables defined in a DLL by using an +import pragma for a variable. As an example, if a DLL contains a +variable defined as: + +@smallexample +int my_var; +@end smallexample + +@noindent +then, to access this variable from Ada you should write: + +@smallexample @c ada +@group +My_Var : Interfaces.C.int; +pragma Import (Stdcall, My_Var); +@end group +@end smallexample + +@noindent +Note that to ease building cross-platform bindings this convention +will be handled as a @code{C} calling convention on non-Windows platforms. + +@node Win32 Calling Convention +@subsection @code{Win32} Calling Convention + +@noindent +This convention, which is GNAT-specific is fully equivalent to the +@code{Stdcall} calling convention described above. + +@node DLL Calling Convention +@subsection @code{DLL} Calling Convention + +@noindent +This convention, which is GNAT-specific is fully equivalent to the +@code{Stdcall} calling convention described above. + +@node Introduction to Dynamic Link Libraries (DLLs) +@section Introduction to Dynamic Link Libraries (DLLs) +@findex DLL + +@noindent +A Dynamically Linked Library (DLL) is a library that can be shared by +several applications running under Windows. A DLL can contain any number of +routines and variables. + +One advantage of DLLs is that you can change and enhance them without +forcing all the applications that depend on them to be relinked or +recompiled. However, you should be aware than all calls to DLL routines are +slower since, as you will understand below, such calls are indirect. + +To illustrate the remainder of this section, suppose that an application +wants to use the services of a DLL @file{API.dll}. To use the services +provided by @file{API.dll} you must statically link against the DLL or +an import library which contains a jump table with an entry for each +routine and variable exported by the DLL. In the Microsoft world this +import library is called @file{API.lib}. When using GNAT this import +library is called either @file{libAPI.dll.a}, @file{libapi.dll.a}, +@file{libAPI.a} or @file{libapi.a} (names are case insensitive). + +After you have linked your application with the DLL or the import library +and you run your application, here is what happens: + +@enumerate +@item +Your application is loaded into memory. + +@item +The DLL @file{API.dll} is mapped into the address space of your +application. This means that: + +@itemize @bullet +@item +The DLL will use the stack of the calling thread. + +@item +The DLL will use the virtual address space of the calling process. + +@item +The DLL will allocate memory from the virtual address space of the calling +process. + +@item +Handles (pointers) can be safely exchanged between routines in the DLL +routines and routines in the application using the DLL. +@end itemize + +@item +The entries in the jump table (from the import library @file{libAPI.dll.a} +or @file{API.lib} or automatically created when linking against a DLL) +which is part of your application are initialized with the addresses +of the routines and variables in @file{API.dll}. + +@item +If present in @file{API.dll}, routines @code{DllMain} or +@code{DllMainCRTStartup} are invoked. These routines typically contain +the initialization code needed for the well-being of the routines and +variables exported by the DLL. +@end enumerate + +@noindent +There is an additional point which is worth mentioning. In the Windows +world there are two kind of DLLs: relocatable and non-relocatable +DLLs. Non-relocatable DLLs can only be loaded at a very specific address +in the target application address space. If the addresses of two +non-relocatable DLLs overlap and these happen to be used by the same +application, a conflict will occur and the application will run +incorrectly. Hence, when possible, it is always preferable to use and +build relocatable DLLs. Both relocatable and non-relocatable DLLs are +supported by GNAT. Note that the @option{-s} linker option (see GNU Linker +User's Guide) removes the debugging symbols from the DLL but the DLL can +still be relocated. + +As a side note, an interesting difference between Microsoft DLLs and +Unix shared libraries, is the fact that on most Unix systems all public +routines are exported by default in a Unix shared library, while under +Windows it is possible (but not required) to list exported routines in +a definition file (@pxref{The Definition File}). + +@node Using DLLs with GNAT +@section Using DLLs with GNAT + +@menu +* Creating an Ada Spec for the DLL Services:: +* Creating an Import Library:: +@end menu + +@noindent +To use the services of a DLL, say @file{API.dll}, in your Ada application +you must have: + +@enumerate +@item +The Ada spec for the routines and/or variables you want to access in +@file{API.dll}. If not available this Ada spec must be built from the C/C++ +header files provided with the DLL. + +@item +The import library (@file{libAPI.dll.a} or @file{API.lib}). As previously +mentioned an import library is a statically linked library containing the +import table which will be filled at load time to point to the actual +@file{API.dll} routines. Sometimes you don't have an import library for the +DLL you want to use. The following sections will explain how to build +one. Note that this is optional. + +@item +The actual DLL, @file{API.dll}. +@end enumerate + +@noindent +Once you have all the above, to compile an Ada application that uses the +services of @file{API.dll} and whose main subprogram is @code{My_Ada_App}, +you simply issue the command + +@smallexample +$ gnatmake my_ada_app -largs -lAPI +@end smallexample + +@noindent +The argument @option{-largs -lAPI} at the end of the @command{gnatmake} command +tells the GNAT linker to look for an import library. The linker will +look for a library name in this specific order: + +@enumerate +@item @file{libAPI.dll.a} +@item @file{API.dll.a} +@item @file{libAPI.a} +@item @file{API.lib} +@item @file{libAPI.dll} +@item @file{API.dll} +@end enumerate + +The first three are the GNU style import libraries. The third is the +Microsoft style import libraries. The last two are the actual DLL names. + +Note that if the Ada package spec for @file{API.dll} contains the +following pragma + +@smallexample @c ada +pragma Linker_Options ("-lAPI"); +@end smallexample + +@noindent +you do not have to add @option{-largs -lAPI} at the end of the +@command{gnatmake} command. + +If any one of the items above is missing you will have to create it +yourself. The following sections explain how to do so using as an +example a fictitious DLL called @file{API.dll}. + +@node Creating an Ada Spec for the DLL Services +@subsection Creating an Ada Spec for the DLL Services + +@noindent +A DLL typically comes with a C/C++ header file which provides the +definitions of the routines and variables exported by the DLL. The Ada +equivalent of this header file is a package spec that contains definitions +for the imported entities. If the DLL you intend to use does not come with +an Ada spec you have to generate one such spec yourself. For example if +the header file of @file{API.dll} is a file @file{api.h} containing the +following two definitions: + +@smallexample +@group +@cartouche +int some_var; +int get (char *); +@end cartouche +@end group +@end smallexample + +@noindent +then the equivalent Ada spec could be: + +@smallexample @c ada +@group +@cartouche +with Interfaces.C.Strings; +package API is + use Interfaces; + + Some_Var : C.int; + function Get (Str : C.Strings.Chars_Ptr) return C.int; + +private + pragma Import (C, Get); + pragma Import (DLL, Some_Var); +end API; +@end cartouche +@end group +@end smallexample + +@noindent +Note that a variable is +@strong{always imported with a DLL convention}. A function +can have @code{C} or @code{Stdcall} convention. +(@pxref{Windows Calling Conventions}). + +@node Creating an Import Library +@subsection Creating an Import Library +@cindex Import library + +@menu +* The Definition File:: +* GNAT-Style Import Library:: +* Microsoft-Style Import Library:: +@end menu + +@noindent +If a Microsoft-style import library @file{API.lib} or a GNAT-style +import library @file{libAPI.dll.a} or @file{libAPI.a} is available +with @file{API.dll} you can skip this section. You can also skip this +section if @file{API.dll} or @file{libAPI.dll} is built with GNU tools +as in this case it is possible to link directly against the +DLL. Otherwise read on. + +@node The Definition File +@subsubsection The Definition File +@cindex Definition file +@findex .def + +@noindent +As previously mentioned, and unlike Unix systems, the list of symbols +that are exported from a DLL must be provided explicitly in Windows. +The main goal of a definition file is precisely that: list the symbols +exported by a DLL. A definition file (usually a file with a @code{.def} +suffix) has the following structure: + +@smallexample +@group +@cartouche +@r{[}LIBRARY @var{name}@r{]} +@r{[}DESCRIPTION @var{string}@r{]} +EXPORTS + @var{symbol1} + @var{symbol2} + @dots{} +@end cartouche +@end group +@end smallexample + +@table @code +@item LIBRARY @var{name} +This section, which is optional, gives the name of the DLL. + +@item DESCRIPTION @var{string} +This section, which is optional, gives a description string that will be +embedded in the import library. + +@item EXPORTS +This section gives the list of exported symbols (procedures, functions or +variables). For instance in the case of @file{API.dll} the @code{EXPORTS} +section of @file{API.def} looks like: + +@smallexample +@group +@cartouche +EXPORTS + some_var + get +@end cartouche +@end group +@end smallexample +@end table + +@noindent +Note that you must specify the correct suffix (@code{@@}@code{@var{nn}}) +(@pxref{Windows Calling Conventions}) for a Stdcall +calling convention function in the exported symbols list. + +@noindent +There can actually be other sections in a definition file, but these +sections are not relevant to the discussion at hand. + +@node GNAT-Style Import Library +@subsubsection GNAT-Style Import Library + +@noindent +To create a static import library from @file{API.dll} with the GNAT tools +you should proceed as follows: + +@enumerate +@item +Create the definition file @file{API.def} (@pxref{The Definition File}). +For that use the @code{dll2def} tool as follows: + +@smallexample +$ dll2def API.dll > API.def +@end smallexample + +@noindent +@code{dll2def} is a very simple tool: it takes as input a DLL and prints +to standard output the list of entry points in the DLL. Note that if +some routines in the DLL have the @code{Stdcall} convention +(@pxref{Windows Calling Conventions}) with stripped @code{@@}@var{nn} +suffix then you'll have to edit @file{api.def} to add it, and specify +@option{-k} to @command{gnatdll} when creating the import library. + +@noindent +Here are some hints to find the right @code{@@}@var{nn} suffix. + +@enumerate +@item +If you have the Microsoft import library (.lib), it is possible to get +the right symbols by using Microsoft @code{dumpbin} tool (see the +corresponding Microsoft documentation for further details). + +@smallexample +$ dumpbin /exports api.lib +@end smallexample + +@item +If you have a message about a missing symbol at link time the compiler +tells you what symbol is expected. You just have to go back to the +definition file and add the right suffix. +@end enumerate + +@item +Build the import library @code{libAPI.dll.a}, using @code{gnatdll} +(@pxref{Using gnatdll}) as follows: + +@smallexample +$ gnatdll -e API.def -d API.dll +@end smallexample + +@noindent +@code{gnatdll} takes as input a definition file @file{API.def} and the +name of the DLL containing the services listed in the definition file +@file{API.dll}. The name of the static import library generated is +computed from the name of the definition file as follows: if the +definition file name is @var{xyz}@code{.def}, the import library name will +be @code{lib}@var{xyz}@code{.a}. Note that in the previous example option +@option{-e} could have been removed because the name of the definition +file (before the ``@code{.def}'' suffix) is the same as the name of the +DLL (@pxref{Using gnatdll} for more information about @code{gnatdll}). +@end enumerate + +@node Microsoft-Style Import Library +@subsubsection Microsoft-Style Import Library + +@noindent +With GNAT you can either use a GNAT-style or Microsoft-style import +library. A Microsoft import library is needed only if you plan to make an +Ada DLL available to applications developed with Microsoft +tools (@pxref{Mixed-Language Programming on Windows}). + +To create a Microsoft-style import library for @file{API.dll} you +should proceed as follows: + +@enumerate +@item +Create the definition file @file{API.def} from the DLL. For this use either +the @code{dll2def} tool as described above or the Microsoft @code{dumpbin} +tool (see the corresponding Microsoft documentation for further details). + +@item +Build the actual import library using Microsoft's @code{lib} utility: + +@smallexample +$ lib -machine:IX86 -def:API.def -out:API.lib +@end smallexample + +@noindent +If you use the above command the definition file @file{API.def} must +contain a line giving the name of the DLL: + +@smallexample +LIBRARY "API" +@end smallexample + +@noindent +See the Microsoft documentation for further details about the usage of +@code{lib}. +@end enumerate + +@node Building DLLs with GNAT Project files +@section Building DLLs with GNAT Project files +@cindex DLLs, building + +@noindent +There is nothing specific to Windows in the build process. +@pxref{Library Projects}. + +@noindent +Due to a system limitation, it is not possible under Windows to create threads +when inside the @code{DllMain} routine which is used for auto-initialization +of shared libraries, so it is not possible to have library level tasks in SALs. + +@node Building DLLs with GNAT +@section Building DLLs with GNAT +@cindex DLLs, building + +@noindent +This section explain how to build DLLs using the GNAT built-in DLL +support. With the following procedure it is straight forward to build +and use DLLs with GNAT. + +@enumerate + +@item building object files + +The first step is to build all objects files that are to be included +into the DLL. This is done by using the standard @command{gnatmake} tool. + +@item building the DLL + +To build the DLL you must use @command{gcc}'s @option{-shared} and +@option{-shared-libgcc} options. It is quite simple to use this method: + +@smallexample +$ gcc -shared -shared-libgcc -o api.dll obj1.o obj2.o @dots{} +@end smallexample + +It is important to note that in this case all symbols found in the +object files are automatically exported. It is possible to restrict +the set of symbols to export by passing to @command{gcc} a definition +file, @pxref{The Definition File}. For example: + +@smallexample +$ gcc -shared -shared-libgcc -o api.dll api.def obj1.o obj2.o @dots{} +@end smallexample + +If you use a definition file you must export the elaboration procedures +for every package that required one. Elaboration procedures are named +using the package name followed by "_E". + +@item preparing DLL to be used + +For the DLL to be used by client programs the bodies must be hidden +from it and the .ali set with read-only attribute. This is very important +otherwise GNAT will recompile all packages and will not actually use +the code in the DLL. For example: + +@smallexample +$ mkdir apilib +$ copy *.ads *.ali api.dll apilib +$ attrib +R apilib\*.ali +@end smallexample + +@end enumerate + +At this point it is possible to use the DLL by directly linking +against it. Note that you must use the GNAT shared runtime when using +GNAT shared libraries. This is achieved by using @option{-shared} binder's +option. + +@smallexample +$ gnatmake main -Iapilib -bargs -shared -largs -Lapilib -lAPI +@end smallexample + +@node Building DLLs with gnatdll +@section Building DLLs with gnatdll +@cindex DLLs, building + +@menu +* Limitations When Using Ada DLLs from Ada:: +* Exporting Ada Entities:: +* Ada DLLs and Elaboration:: +* Ada DLLs and Finalization:: +* Creating a Spec for Ada DLLs:: +* Creating the Definition File:: +* Using gnatdll:: +@end menu + +@noindent +Note that it is preferred to use GNAT Project files +(@pxref{Building DLLs with GNAT Project files}) or the built-in GNAT +DLL support (@pxref{Building DLLs with GNAT}) or to build DLLs. + +This section explains how to build DLLs containing Ada code using +@code{gnatdll}. These DLLs will be referred to as Ada DLLs in the +remainder of this section. + +The steps required to build an Ada DLL that is to be used by Ada as well as +non-Ada applications are as follows: + +@enumerate +@item +You need to mark each Ada @i{entity} exported by the DLL with a @code{C} or +@code{Stdcall} calling convention to avoid any Ada name mangling for the +entities exported by the DLL (@pxref{Exporting Ada Entities}). You can +skip this step if you plan to use the Ada DLL only from Ada applications. + +@item +Your Ada code must export an initialization routine which calls the routine +@code{adainit} generated by @command{gnatbind} to perform the elaboration of +the Ada code in the DLL (@pxref{Ada DLLs and Elaboration}). The initialization +routine exported by the Ada DLL must be invoked by the clients of the DLL +to initialize the DLL. + +@item +When useful, the DLL should also export a finalization routine which calls +routine @code{adafinal} generated by @command{gnatbind} to perform the +finalization of the Ada code in the DLL (@pxref{Ada DLLs and Finalization}). +The finalization routine exported by the Ada DLL must be invoked by the +clients of the DLL when the DLL services are no further needed. + +@item +You must provide a spec for the services exported by the Ada DLL in each +of the programming languages to which you plan to make the DLL available. + +@item +You must provide a definition file listing the exported entities +(@pxref{The Definition File}). + +@item +Finally you must use @code{gnatdll} to produce the DLL and the import +library (@pxref{Using gnatdll}). +@end enumerate + +@noindent +Note that a relocatable DLL stripped using the @code{strip} +binutils tool will not be relocatable anymore. To build a DLL without +debug information pass @code{-largs -s} to @code{gnatdll}. This +restriction does not apply to a DLL built using a Library Project. +@pxref{Library Projects}. + +@node Limitations When Using Ada DLLs from Ada +@subsection Limitations When Using Ada DLLs from Ada + +@noindent +When using Ada DLLs from Ada applications there is a limitation users +should be aware of. Because on Windows the GNAT run time is not in a DLL of +its own, each Ada DLL includes a part of the GNAT run time. Specifically, +each Ada DLL includes the services of the GNAT run time that are necessary +to the Ada code inside the DLL. As a result, when an Ada program uses an +Ada DLL there are two independent GNAT run times: one in the Ada DLL and +one in the main program. + +It is therefore not possible to exchange GNAT run-time objects between the +Ada DLL and the main Ada program. Example of GNAT run-time objects are file +handles (e.g.@: @code{Text_IO.File_Type}), tasks types, protected objects +types, etc. + +It is completely safe to exchange plain elementary, array or record types, +Windows object handles, etc. + +@node Exporting Ada Entities +@subsection Exporting Ada Entities +@cindex Export table + +@noindent +Building a DLL is a way to encapsulate a set of services usable from any +application. As a result, the Ada entities exported by a DLL should be +exported with the @code{C} or @code{Stdcall} calling conventions to avoid +any Ada name mangling. As an example here is an Ada package +@code{API}, spec and body, exporting two procedures, a function, and a +variable: + +@smallexample @c ada +@group +@cartouche +with Interfaces.C; use Interfaces; +package API is + Count : C.int := 0; + function Factorial (Val : C.int) return C.int; + + procedure Initialize_API; + procedure Finalize_API; + -- Initialization & Finalization routines. More in the next section. +private + pragma Export (C, Initialize_API); + pragma Export (C, Finalize_API); + pragma Export (C, Count); + pragma Export (C, Factorial); +end API; +@end cartouche +@end group +@end smallexample + +@smallexample @c ada +@group +@cartouche +package body API is + function Factorial (Val : C.int) return C.int is + Fact : C.int := 1; + begin + Count := Count + 1; + for K in 1 .. Val loop + Fact := Fact * K; + end loop; + return Fact; + end Factorial; + + procedure Initialize_API is + procedure Adainit; + pragma Import (C, Adainit); + begin + Adainit; + end Initialize_API; + + procedure Finalize_API is + procedure Adafinal; + pragma Import (C, Adafinal); + begin + Adafinal; + end Finalize_API; +end API; +@end cartouche +@end group +@end smallexample + +@noindent +If the Ada DLL you are building will only be used by Ada applications +you do not have to export Ada entities with a @code{C} or @code{Stdcall} +convention. As an example, the previous package could be written as +follows: + +@smallexample @c ada +@group +@cartouche +package API is + Count : Integer := 0; + function Factorial (Val : Integer) return Integer; + + procedure Initialize_API; + procedure Finalize_API; + -- Initialization and Finalization routines. +end API; +@end cartouche +@end group +@end smallexample + +@smallexample @c ada +@group +@cartouche +package body API is + function Factorial (Val : Integer) return Integer is + Fact : Integer := 1; + begin + Count := Count + 1; + for K in 1 .. Val loop + Fact := Fact * K; + end loop; + return Fact; + end Factorial; + + @dots{} + -- The remainder of this package body is unchanged. +end API; +@end cartouche +@end group +@end smallexample + +@noindent +Note that if you do not export the Ada entities with a @code{C} or +@code{Stdcall} convention you will have to provide the mangled Ada names +in the definition file of the Ada DLL +(@pxref{Creating the Definition File}). + +@node Ada DLLs and Elaboration +@subsection Ada DLLs and Elaboration +@cindex DLLs and elaboration + +@noindent +The DLL that you are building contains your Ada code as well as all the +routines in the Ada library that are needed by it. The first thing a +user of your DLL must do is elaborate the Ada code +(@pxref{Elaboration Order Handling in GNAT}). + +To achieve this you must export an initialization routine +(@code{Initialize_API} in the previous example), which must be invoked +before using any of the DLL services. This elaboration routine must call +the Ada elaboration routine @code{adainit} generated by the GNAT binder +(@pxref{Binding with Non-Ada Main Programs}). See the body of +@code{Initialize_Api} for an example. Note that the GNAT binder is +automatically invoked during the DLL build process by the @code{gnatdll} +tool (@pxref{Using gnatdll}). + +When a DLL is loaded, Windows systematically invokes a routine called +@code{DllMain}. It would therefore be possible to call @code{adainit} +directly from @code{DllMain} without having to provide an explicit +initialization routine. Unfortunately, it is not possible to call +@code{adainit} from the @code{DllMain} if your program has library level +tasks because access to the @code{DllMain} entry point is serialized by +the system (that is, only a single thread can execute ``through'' it at a +time), which means that the GNAT run time will deadlock waiting for the +newly created task to complete its initialization. + +@node Ada DLLs and Finalization +@subsection Ada DLLs and Finalization +@cindex DLLs and finalization + +@noindent +When the services of an Ada DLL are no longer needed, the client code should +invoke the DLL finalization routine, if available. The DLL finalization +routine is in charge of releasing all resources acquired by the DLL. In the +case of the Ada code contained in the DLL, this is achieved by calling +routine @code{adafinal} generated by the GNAT binder +(@pxref{Binding with Non-Ada Main Programs}). +See the body of @code{Finalize_Api} for an +example. As already pointed out the GNAT binder is automatically invoked +during the DLL build process by the @code{gnatdll} tool +(@pxref{Using gnatdll}). + +@node Creating a Spec for Ada DLLs +@subsection Creating a Spec for Ada DLLs + +@noindent +To use the services exported by the Ada DLL from another programming +language (e.g.@: C), you have to translate the specs of the exported Ada +entities in that language. For instance in the case of @code{API.dll}, +the corresponding C header file could look like: + +@smallexample +@group +@cartouche +extern int *_imp__count; +#define count (*_imp__count) +int factorial (int); +@end cartouche +@end group +@end smallexample + +@noindent +It is important to understand that when building an Ada DLL to be used by +other Ada applications, you need two different specs for the packages +contained in the DLL: one for building the DLL and the other for using +the DLL. This is because the @code{DLL} calling convention is needed to +use a variable defined in a DLL, but when building the DLL, the variable +must have either the @code{Ada} or @code{C} calling convention. As an +example consider a DLL comprising the following package @code{API}: + +@smallexample @c ada +@group +@cartouche +package API is + Count : Integer := 0; + @dots{} + -- Remainder of the package omitted. +end API; +@end cartouche +@end group +@end smallexample + +@noindent +After producing a DLL containing package @code{API}, the spec that +must be used to import @code{API.Count} from Ada code outside of the +DLL is: + +@smallexample @c ada +@group +@cartouche +package API is + Count : Integer; + pragma Import (DLL, Count); +end API; +@end cartouche +@end group +@end smallexample + +@node Creating the Definition File +@subsection Creating the Definition File + +@noindent +The definition file is the last file needed to build the DLL. It lists +the exported symbols. As an example, the definition file for a DLL +containing only package @code{API} (where all the entities are exported +with a @code{C} calling convention) is: + +@smallexample +@group +@cartouche +EXPORTS + count + factorial + finalize_api + initialize_api +@end cartouche +@end group +@end smallexample + +@noindent +If the @code{C} calling convention is missing from package @code{API}, +then the definition file contains the mangled Ada names of the above +entities, which in this case are: + +@smallexample +@group +@cartouche +EXPORTS + api__count + api__factorial + api__finalize_api + api__initialize_api +@end cartouche +@end group +@end smallexample + +@node Using gnatdll +@subsection Using @code{gnatdll} +@findex gnatdll + +@menu +* gnatdll Example:: +* gnatdll behind the Scenes:: +* Using dlltool:: +@end menu + +@noindent +@code{gnatdll} is a tool to automate the DLL build process once all the Ada +and non-Ada sources that make up your DLL have been compiled. +@code{gnatdll} is actually in charge of two distinct tasks: build the +static import library for the DLL and the actual DLL. The form of the +@code{gnatdll} command is + +@smallexample +@cartouche +@c $ gnatdll @ovar{switches} @var{list-of-files} @r{[}-largs @var{opts}@r{]} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatdll @r{[}@var{switches}@r{]} @var{list-of-files} @r{[}-largs @var{opts}@r{]} +@end cartouche +@end smallexample + +@noindent +where @var{list-of-files} is a list of ALI and object files. The object +file list must be the exact list of objects corresponding to the non-Ada +sources whose services are to be included in the DLL. The ALI file list +must be the exact list of ALI files for the corresponding Ada sources +whose services are to be included in the DLL. If @var{list-of-files} is +missing, only the static import library is generated. + +@noindent +You may specify any of the following switches to @code{gnatdll}: + +@table @code +@c @item -a@ovar{address} +@c Expanding @ovar macro inline (explanation in macro def comments) +@item -a@r{[}@var{address}@r{]} +@cindex @option{-a} (@code{gnatdll}) +Build a non-relocatable DLL at @var{address}. If @var{address} is not +specified the default address @var{0x11000000} will be used. By default, +when this switch is missing, @code{gnatdll} builds relocatable DLL. We +advise the reader to build relocatable DLL. + +@item -b @var{address} +@cindex @option{-b} (@code{gnatdll}) +Set the relocatable DLL base address. By default the address is +@code{0x11000000}. + +@item -bargs @var{opts} +@cindex @option{-bargs} (@code{gnatdll}) +Binder options. Pass @var{opts} to the binder. + +@item -d @var{dllfile} +@cindex @option{-d} (@code{gnatdll}) +@var{dllfile} is the name of the DLL. This switch must be present for +@code{gnatdll} to do anything. The name of the generated import library is +obtained algorithmically from @var{dllfile} as shown in the following +example: if @var{dllfile} is @code{xyz.dll}, the import library name is +@code{libxyz.dll.a}. The name of the definition file to use (if not specified +by option @option{-e}) is obtained algorithmically from @var{dllfile} +as shown in the following example: +if @var{dllfile} is @code{xyz.dll}, the definition +file used is @code{xyz.def}. + +@item -e @var{deffile} +@cindex @option{-e} (@code{gnatdll}) +@var{deffile} is the name of the definition file. + +@item -g +@cindex @option{-g} (@code{gnatdll}) +Generate debugging information. This information is stored in the object +file and copied from there to the final DLL file by the linker, +where it can be read by the debugger. You must use the +@option{-g} switch if you plan on using the debugger or the symbolic +stack traceback. + +@item -h +@cindex @option{-h} (@code{gnatdll}) +Help mode. Displays @code{gnatdll} switch usage information. + +@item -Idir +@cindex @option{-I} (@code{gnatdll}) +Direct @code{gnatdll} to search the @var{dir} directory for source and +object files needed to build the DLL. +(@pxref{Search Paths and the Run-Time Library (RTL)}). + +@item -k +@cindex @option{-k} (@code{gnatdll}) +Removes the @code{@@}@var{nn} suffix from the import library's exported +names, but keeps them for the link names. You must specify this +option if you want to use a @code{Stdcall} function in a DLL for which +the @code{@@}@var{nn} suffix has been removed. This is the case for most +of the Windows NT DLL for example. This option has no effect when +@option{-n} option is specified. + +@item -l @var{file} +@cindex @option{-l} (@code{gnatdll}) +The list of ALI and object files used to build the DLL are listed in +@var{file}, instead of being given in the command line. Each line in +@var{file} contains the name of an ALI or object file. + +@item -n +@cindex @option{-n} (@code{gnatdll}) +No Import. Do not create the import library. + +@item -q +@cindex @option{-q} (@code{gnatdll}) +Quiet mode. Do not display unnecessary messages. + +@item -v +@cindex @option{-v} (@code{gnatdll}) +Verbose mode. Display extra information. + +@item -largs @var{opts} +@cindex @option{-largs} (@code{gnatdll}) +Linker options. Pass @var{opts} to the linker. +@end table + +@node gnatdll Example +@subsubsection @code{gnatdll} Example + +@noindent +As an example the command to build a relocatable DLL from @file{api.adb} +once @file{api.adb} has been compiled and @file{api.def} created is + +@smallexample +$ gnatdll -d api.dll api.ali +@end smallexample + +@noindent +The above command creates two files: @file{libapi.dll.a} (the import +library) and @file{api.dll} (the actual DLL). If you want to create +only the DLL, just type: + +@smallexample +$ gnatdll -d api.dll -n api.ali +@end smallexample + +@noindent +Alternatively if you want to create just the import library, type: + +@smallexample +$ gnatdll -d api.dll +@end smallexample + +@node gnatdll behind the Scenes +@subsubsection @code{gnatdll} behind the Scenes + +@noindent +This section details the steps involved in creating a DLL. @code{gnatdll} +does these steps for you. Unless you are interested in understanding what +goes on behind the scenes, you should skip this section. + +We use the previous example of a DLL containing the Ada package @code{API}, +to illustrate the steps necessary to build a DLL. The starting point is a +set of objects that will make up the DLL and the corresponding ALI +files. In the case of this example this means that @file{api.o} and +@file{api.ali} are available. To build a relocatable DLL, @code{gnatdll} does +the following: + +@enumerate +@item +@code{gnatdll} builds the base file (@file{api.base}). A base file gives +the information necessary to generate relocation information for the +DLL. + +@smallexample +@group +$ gnatbind -n api +$ gnatlink api -o api.jnk -mdll -Wl,--base-file,api.base +@end group +@end smallexample + +@noindent +In addition to the base file, the @command{gnatlink} command generates an +output file @file{api.jnk} which can be discarded. The @option{-mdll} switch +asks @command{gnatlink} to generate the routines @code{DllMain} and +@code{DllMainCRTStartup} that are called by the Windows loader when the DLL +is loaded into memory. + +@item +@code{gnatdll} uses @code{dlltool} (@pxref{Using dlltool}) to build the +export table (@file{api.exp}). The export table contains the relocation +information in a form which can be used during the final link to ensure +that the Windows loader is able to place the DLL anywhere in memory. + +@smallexample +@group +$ dlltool --dllname api.dll --def api.def --base-file api.base \ + --output-exp api.exp +@end group +@end smallexample + +@item +@code{gnatdll} builds the base file using the new export table. Note that +@command{gnatbind} must be called once again since the binder generated file +has been deleted during the previous call to @command{gnatlink}. + +@smallexample +@group +$ gnatbind -n api +$ gnatlink api -o api.jnk api.exp -mdll + -Wl,--base-file,api.base +@end group +@end smallexample + +@item +@code{gnatdll} builds the new export table using the new base file and +generates the DLL import library @file{libAPI.dll.a}. + +@smallexample +@group +$ dlltool --dllname api.dll --def api.def --base-file api.base \ + --output-exp api.exp --output-lib libAPI.a +@end group +@end smallexample + +@item +Finally @code{gnatdll} builds the relocatable DLL using the final export +table. + +@smallexample +@group +$ gnatbind -n api +$ gnatlink api api.exp -o api.dll -mdll +@end group +@end smallexample +@end enumerate + +@node Using dlltool +@subsubsection Using @code{dlltool} + +@noindent +@code{dlltool} is the low-level tool used by @code{gnatdll} to build +DLLs and static import libraries. This section summarizes the most +common @code{dlltool} switches. The form of the @code{dlltool} command +is + +@smallexample +@c $ dlltool @ovar{switches} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ dlltool @r{[}@var{switches}@r{]} +@end smallexample + +@noindent +@code{dlltool} switches include: + +@table @option +@item --base-file @var{basefile} +@cindex @option{--base-file} (@command{dlltool}) +Read the base file @var{basefile} generated by the linker. This switch +is used to create a relocatable DLL. + +@item --def @var{deffile} +@cindex @option{--def} (@command{dlltool}) +Read the definition file. + +@item --dllname @var{name} +@cindex @option{--dllname} (@command{dlltool}) +Gives the name of the DLL. This switch is used to embed the name of the +DLL in the static import library generated by @code{dlltool} with switch +@option{--output-lib}. + +@item -k +@cindex @option{-k} (@command{dlltool}) +Kill @code{@@}@var{nn} from exported names +(@pxref{Windows Calling Conventions} +for a discussion about @code{Stdcall}-style symbols. + +@item --help +@cindex @option{--help} (@command{dlltool}) +Prints the @code{dlltool} switches with a concise description. + +@item --output-exp @var{exportfile} +@cindex @option{--output-exp} (@command{dlltool}) +Generate an export file @var{exportfile}. The export file contains the +export table (list of symbols in the DLL) and is used to create the DLL. + +@item --output-lib @var{libfile} +@cindex @option{--output-lib} (@command{dlltool}) +Generate a static import library @var{libfile}. + +@item -v +@cindex @option{-v} (@command{dlltool}) +Verbose mode. + +@item --as @var{assembler-name} +@cindex @option{--as} (@command{dlltool}) +Use @var{assembler-name} as the assembler. The default is @code{as}. +@end table + +@node GNAT and Windows Resources +@section GNAT and Windows Resources +@cindex Resources, windows + +@menu +* Building Resources:: +* Compiling Resources:: +* Using Resources:: +@end menu + +@noindent +Resources are an easy way to add Windows specific objects to your +application. The objects that can be added as resources include: + +@itemize @bullet +@item +menus + +@item +accelerators + +@item +dialog boxes + +@item +string tables + +@item +bitmaps + +@item +cursors + +@item +icons + +@item +fonts +@end itemize + +@noindent +This section explains how to build, compile and use resources. + +@node Building Resources +@subsection Building Resources +@cindex Resources, building + +@noindent +A resource file is an ASCII file. By convention resource files have an +@file{.rc} extension. +The easiest way to build a resource file is to use Microsoft tools +such as @code{imagedit.exe} to build bitmaps, icons and cursors and +@code{dlgedit.exe} to build dialogs. +It is always possible to build an @file{.rc} file yourself by writing a +resource script. + +It is not our objective to explain how to write a resource file. A +complete description of the resource script language can be found in the +Microsoft documentation. + +@node Compiling Resources +@subsection Compiling Resources +@findex rc +@findex windres +@cindex Resources, compiling + +@noindent +This section describes how to build a GNAT-compatible (COFF) object file +containing the resources. This is done using the Resource Compiler +@code{windres} as follows: + +@smallexample +$ windres -i myres.rc -o myres.o +@end smallexample + +@noindent +By default @code{windres} will run @command{gcc} to preprocess the @file{.rc} +file. You can specify an alternate preprocessor (usually named +@file{cpp.exe}) using the @code{windres} @option{--preprocessor} +parameter. A list of all possible options may be obtained by entering +the command @code{windres} @option{--help}. + +It is also possible to use the Microsoft resource compiler @code{rc.exe} +to produce a @file{.res} file (binary resource file). See the +corresponding Microsoft documentation for further details. In this case +you need to use @code{windres} to translate the @file{.res} file to a +GNAT-compatible object file as follows: + +@smallexample +$ windres -i myres.res -o myres.o +@end smallexample + +@node Using Resources +@subsection Using Resources +@cindex Resources, using + +@noindent +To include the resource file in your program just add the +GNAT-compatible object file for the resource(s) to the linker +arguments. With @command{gnatmake} this is done by using the @option{-largs} +option: + +@smallexample +$ gnatmake myprog -largs myres.o +@end smallexample + +@node Debugging a DLL +@section Debugging a DLL +@cindex DLL debugging + +@menu +* Program and DLL Both Built with GCC/GNAT:: +* Program Built with Foreign Tools and DLL Built with GCC/GNAT:: +@end menu + +@noindent +Debugging a DLL is similar to debugging a standard program. But +we have to deal with two different executable parts: the DLL and the +program that uses it. We have the following four possibilities: + +@enumerate 1 +@item +The program and the DLL are built with @code{GCC/GNAT}. +@item +The program is built with foreign tools and the DLL is built with +@code{GCC/GNAT}. +@item +The program is built with @code{GCC/GNAT} and the DLL is built with +foreign tools. +@end enumerate + +@noindent +In this section we address only cases one and two above. +There is no point in trying to debug +a DLL with @code{GNU/GDB}, if there is no GDB-compatible debugging +information in it. To do so you must use a debugger compatible with the +tools suite used to build the DLL. + +@node Program and DLL Both Built with GCC/GNAT +@subsection Program and DLL Both Built with GCC/GNAT + +@noindent +This is the simplest case. Both the DLL and the program have @code{GDB} +compatible debugging information. It is then possible to break anywhere in +the process. Let's suppose here that the main procedure is named +@code{ada_main} and that in the DLL there is an entry point named +@code{ada_dll}. + +@noindent +The DLL (@pxref{Introduction to Dynamic Link Libraries (DLLs)}) and +program must have been built with the debugging information (see GNAT -g +switch). Here are the step-by-step instructions for debugging it: + +@enumerate 1 +@item Launch @code{GDB} on the main program. + +@smallexample +$ gdb -nw ada_main +@end smallexample + +@item Start the program and stop at the beginning of the main procedure + +@smallexample +(gdb) start +@end smallexample + +@noindent +This step is required to be able to set a breakpoint inside the DLL. As long +as the program is not run, the DLL is not loaded. This has the +consequence that the DLL debugging information is also not loaded, so it is not +possible to set a breakpoint in the DLL. + +@item Set a breakpoint inside the DLL + +@smallexample +(gdb) break ada_dll +(gdb) cont +@end smallexample + +@end enumerate + +@noindent +At this stage a breakpoint is set inside the DLL. From there on +you can use the standard approach to debug the whole program +(@pxref{Running and Debugging Ada Programs}). + +@ignore +@c This used to work, probably because the DLLs were non-relocatable +@c keep this section around until the problem is sorted out. + +To break on the @code{DllMain} routine it is not possible to follow +the procedure above. At the time the program stop on @code{ada_main} +the @code{DllMain} routine as already been called. Either you can use +the procedure below @pxref{Debugging the DLL Directly} or this procedure: + +@enumerate 1 +@item Launch @code{GDB} on the main program. + +@smallexample +$ gdb ada_main +@end smallexample + +@item Load DLL symbols + +@smallexample +(gdb) add-sym api.dll +@end smallexample + +@item Set a breakpoint inside the DLL + +@smallexample +(gdb) break ada_dll.adb:45 +@end smallexample + +Note that at this point it is not possible to break using the routine symbol +directly as the program is not yet running. The solution is to break +on the proper line (break in @file{ada_dll.adb} line 45). + +@item Start the program + +@smallexample +(gdb) run +@end smallexample + +@end enumerate +@end ignore + +@node Program Built with Foreign Tools and DLL Built with GCC/GNAT +@subsection Program Built with Foreign Tools and DLL Built with GCC/GNAT + +@menu +* Debugging the DLL Directly:: +* Attaching to a Running Process:: +@end menu + +@noindent +In this case things are slightly more complex because it is not possible to +start the main program and then break at the beginning to load the DLL and the +associated DLL debugging information. It is not possible to break at the +beginning of the program because there is no @code{GDB} debugging information, +and therefore there is no direct way of getting initial control. This +section addresses this issue by describing some methods that can be used +to break somewhere in the DLL to debug it. + +@noindent +First suppose that the main procedure is named @code{main} (this is for +example some C code built with Microsoft Visual C) and that there is a +DLL named @code{test.dll} containing an Ada entry point named +@code{ada_dll}. + +@noindent +The DLL (@pxref{Introduction to Dynamic Link Libraries (DLLs)}) must have +been built with debugging information (see GNAT -g option). + +@node Debugging the DLL Directly +@subsubsection Debugging the DLL Directly + +@enumerate 1 +@item +Find out the executable starting address + +@smallexample +$ objdump --file-header main.exe +@end smallexample + +The starting address is reported on the last line. For example: + +@smallexample +main.exe: file format pei-i386 +architecture: i386, flags 0x0000010a: +EXEC_P, HAS_DEBUG, D_PAGED +start address 0x00401010 +@end smallexample + +@item +Launch the debugger on the executable. + +@smallexample +$ gdb main.exe +@end smallexample + +@item +Set a breakpoint at the starting address, and launch the program. + +@smallexample +$ (gdb) break *0x00401010 +$ (gdb) run +@end smallexample + +The program will stop at the given address. + +@item +Set a breakpoint on a DLL subroutine. + +@smallexample +(gdb) break ada_dll.adb:45 +@end smallexample + +Or if you want to break using a symbol on the DLL, you need first to +select the Ada language (language used by the DLL). + +@smallexample +(gdb) set language ada +(gdb) break ada_dll +@end smallexample + +@item +Continue the program. + +@smallexample +(gdb) cont +@end smallexample + +@noindent +This will run the program until it reaches the breakpoint that has been +set. From that point you can use the standard way to debug a program +as described in (@pxref{Running and Debugging Ada Programs}). + +@end enumerate + +@noindent +It is also possible to debug the DLL by attaching to a running process. + +@node Attaching to a Running Process +@subsubsection Attaching to a Running Process +@cindex DLL debugging, attach to process + +@noindent +With @code{GDB} it is always possible to debug a running process by +attaching to it. It is possible to debug a DLL this way. The limitation +of this approach is that the DLL must run long enough to perform the +attach operation. It may be useful for instance to insert a time wasting +loop in the code of the DLL to meet this criterion. + +@enumerate 1 + +@item Launch the main program @file{main.exe}. + +@smallexample +$ main +@end smallexample + +@item Use the Windows @i{Task Manager} to find the process ID. Let's say +that the process PID for @file{main.exe} is 208. + +@item Launch gdb. + +@smallexample +$ gdb +@end smallexample + +@item Attach to the running process to be debugged. + +@smallexample +(gdb) attach 208 +@end smallexample + +@item Load the process debugging information. + +@smallexample +(gdb) symbol-file main.exe +@end smallexample + +@item Break somewhere in the DLL. + +@smallexample +(gdb) break ada_dll +@end smallexample + +@item Continue process execution. + +@smallexample +(gdb) cont +@end smallexample + +@end enumerate + +@noindent +This last step will resume the process execution, and stop at +the breakpoint we have set. From there you can use the standard +approach to debug a program as described in +(@pxref{Running and Debugging Ada Programs}). + +@node Setting Stack Size from gnatlink +@section Setting Stack Size from @command{gnatlink} + +@noindent +It is possible to specify the program stack size at link time. On modern +versions of Windows, starting with XP, this is mostly useful to set the size of +the main stack (environment task). The other task stacks are set with pragma +Storage_Size or with the @command{gnatbind -d} command. + +Since older versions of Windows (2000, NT4, etc.) do not allow setting the +reserve size of individual tasks, the link-time stack size applies to all +tasks, and pragma Storage_Size has no effect. +In particular, Stack Overflow checks are made against this +link-time specified size. + +This setting can be done with +@command{gnatlink} using either: + +@itemize @bullet + +@item using @option{-Xlinker} linker option + +@smallexample +$ gnatlink hello -Xlinker --stack=0x10000,0x1000 +@end smallexample + +This sets the stack reserve size to 0x10000 bytes and the stack commit +size to 0x1000 bytes. + +@item using @option{-Wl} linker option + +@smallexample +$ gnatlink hello -Wl,--stack=0x1000000 +@end smallexample + +This sets the stack reserve size to 0x1000000 bytes. Note that with +@option{-Wl} option it is not possible to set the stack commit size +because the coma is a separator for this option. + +@end itemize + +@node Setting Heap Size from gnatlink +@section Setting Heap Size from @command{gnatlink} + +@noindent +Under Windows systems, it is possible to specify the program heap size from +@command{gnatlink} using either: + +@itemize @bullet + +@item using @option{-Xlinker} linker option + +@smallexample +$ gnatlink hello -Xlinker --heap=0x10000,0x1000 +@end smallexample + +This sets the heap reserve size to 0x10000 bytes and the heap commit +size to 0x1000 bytes. + +@item using @option{-Wl} linker option + +@smallexample +$ gnatlink hello -Wl,--heap=0x1000000 +@end smallexample + +This sets the heap reserve size to 0x1000000 bytes. Note that with +@option{-Wl} option it is not possible to set the heap commit size +because the coma is a separator for this option. + +@end itemize + +@end ifset + +@c ********************************** +@c * GNU Free Documentation License * +@c ********************************** +@include fdl.texi +@c GNU Free Documentation License + +@node Index,,GNU Free Documentation License, Top +@unnumbered Index + +@printindex cp + +@contents +@c Put table of contents at end, otherwise it precedes the "title page" in +@c the .txt version +@c Edit the pdf file to move the contents to the beginning, after the title +@c page + +@bye diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb new file mode 100644 index 000000000..de3084f02 --- /dev/null +++ b/gcc/ada/gnatbind.adb @@ -0,0 +1,982 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T B I N D -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with ALI; use ALI; +with ALI.Util; use ALI.Util; +with Bcheck; use Bcheck; +with Binde; use Binde; +with Binderr; use Binderr; +with Bindgen; use Bindgen; +with Bindusg; +with Butil; use Butil; +with Casing; use Casing; +with Csets; +with Debug; use Debug; +with Fmap; +with Fname; use Fname; +with Namet; use Namet; +with Opt; use Opt; +with Osint; use Osint; +with Osint.B; use Osint.B; +with Output; use Output; +with Rident; use Rident; +with Snames; +with Switch; use Switch; +with Switch.B; use Switch.B; +with Table; +with Targparm; use Targparm; +with Types; use Types; + +with System.Case_Util; use System.Case_Util; +with System.OS_Lib; use System.OS_Lib; + +with Ada.Command_Line.Response_File; use Ada.Command_Line; + +procedure Gnatbind is + + Total_Errors : Nat := 0; + -- Counts total errors in all files + + Total_Warnings : Nat := 0; + -- Total warnings in all files + + Main_Lib_File : File_Name_Type; + -- Current main library file + + First_Main_Lib_File : File_Name_Type := No_File; + -- The first library file, that should be a main subprogram if neither -n + -- nor -z are used. + + Std_Lib_File : File_Name_Type; + -- Standard library + + Text : Text_Buffer_Ptr; + Next_Arg : Positive; + + Output_File_Name_Seen : Boolean := False; + Output_File_Name : String_Ptr := new String'(""); + + L_Switch_Seen : Boolean := False; + + Mapping_File : String_Ptr := null; + + package Closure_Sources is new Table.Table + (Table_Component_Type => File_Name_Type, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Gnatbind.Closure_Sources"); + -- Table to record the sources in the closure, to avoid duplications. Used + -- only with switch -R. + + function Gnatbind_Supports_Auto_Init return Boolean; + -- Indicates if automatic initialization of elaboration procedure + -- through the constructor mechanism is possible on the platform. + + procedure List_Applicable_Restrictions; + -- List restrictions that apply to this partition if option taken + + procedure Scan_Bind_Arg (Argv : String); + -- Scan and process binder specific arguments. Argv is a single argument. + -- All the one character arguments are still handled by Switch. This + -- routine handles -aO -aI and -I-. The lower bound of Argv must be 1. + + function Is_Cross_Compiler return Boolean; + -- Returns True iff this is a cross-compiler + + --------------------------------- + -- Gnatbind_Supports_Auto_Init -- + --------------------------------- + + function Gnatbind_Supports_Auto_Init return Boolean is + function gnat_binder_supports_auto_init return Integer; + pragma Import (C, gnat_binder_supports_auto_init, + "__gnat_binder_supports_auto_init"); + begin + return gnat_binder_supports_auto_init /= 0; + end Gnatbind_Supports_Auto_Init; + + ----------------------- + -- Is_Cross_Compiler -- + ----------------------- + + function Is_Cross_Compiler return Boolean is + Cross_Compiler : Integer; + pragma Import (C, Cross_Compiler, "__gnat_is_cross_compiler"); + begin + return Cross_Compiler = 1; + end Is_Cross_Compiler; + + ---------------------------------- + -- List_Applicable_Restrictions -- + ---------------------------------- + + procedure List_Applicable_Restrictions is + + -- Define those restrictions that should be output if the gnatbind + -- -r switch is used. Not all restrictions are output for the reasons + -- given below in the list, and this array is used to test whether + -- the corresponding pragma should be listed. True means that it + -- should not be listed. + + No_Restriction_List : constant array (All_Restrictions) of Boolean := + (No_Allocators_After_Elaboration => True, + -- This involves run-time conditions not checkable at compile time + + No_Anonymous_Allocators => True, + -- Premature, since we have not implemented this yet + + No_Exception_Propagation => True, + -- Modifies code resulting in different exception semantics + + No_Exceptions => True, + -- Has unexpected Suppress (All_Checks) effect + + No_Implicit_Conditionals => True, + -- This could modify and pessimize generated code + + No_Implicit_Dynamic_Code => True, + -- This could modify and pessimize generated code + + No_Implicit_Loops => True, + -- This could modify and pessimize generated code + + No_Recursion => True, + -- Not checkable at compile time + + No_Reentrancy => True, + -- Not checkable at compile time + + Max_Entry_Queue_Length => True, + -- Not checkable at compile time + + Max_Storage_At_Blocking => True, + -- Not checkable at compile time + + others => False); + + Additional_Restrictions_Listed : Boolean := False; + -- Set True if we have listed header for restrictions + + function Restriction_Could_Be_Set (R : Restriction_Id) return Boolean; + -- Returns True if the given restriction can be listed as an additional + -- restriction that could be set. + + ------------------------------ + -- Restriction_Could_Be_Set -- + ------------------------------ + + function Restriction_Could_Be_Set (R : Restriction_Id) return Boolean is + CR : Restrictions_Info renames Cumulative_Restrictions; + + begin + case R is + + -- Boolean restriction + + when All_Boolean_Restrictions => + + -- The condition for listing a boolean restriction as an + -- additional restriction that could be set is that it is + -- not violated by any unit, and not already set. + + return CR.Violated (R) = False and then CR.Set (R) = False; + + -- Parameter restriction + + when All_Parameter_Restrictions => + + -- If the restriction is violated and the level of violation is + -- unknown, the restriction can definitely not be listed. + + if CR.Violated (R) and then CR.Unknown (R) then + return False; + + -- We can list the restriction if it is not set + + elsif not CR.Set (R) then + return True; + + -- We can list the restriction if is set to a greater value + -- than the maximum value known for the violation. + + else + return CR.Value (R) > CR.Count (R); + end if; + + -- No other values for R possible + + when others => + raise Program_Error; + + end case; + end Restriction_Could_Be_Set; + + -- Start of processing for List_Applicable_Restrictions + + begin + -- Loop through restrictions + + for R in All_Restrictions loop + if not No_Restriction_List (R) + and then Restriction_Could_Be_Set (R) + then + if not Additional_Restrictions_Listed then + Write_Eol; + Write_Line + ("The following additional restrictions may be" & + " applied to this partition:"); + Additional_Restrictions_Listed := True; + end if; + + Write_Str ("pragma Restrictions ("); + + declare + S : constant String := Restriction_Id'Image (R); + begin + Name_Len := S'Length; + Name_Buffer (1 .. Name_Len) := S; + end; + + Set_Casing (Mixed_Case); + Write_Str (Name_Buffer (1 .. Name_Len)); + + if R in All_Parameter_Restrictions then + Write_Str (" => "); + Write_Int (Int (Cumulative_Restrictions.Count (R))); + end if; + + Write_Str (");"); + Write_Eol; + end if; + end loop; + end List_Applicable_Restrictions; + + ------------------- + -- Scan_Bind_Arg -- + ------------------- + + procedure Scan_Bind_Arg (Argv : String) is + pragma Assert (Argv'First = 1); + + begin + -- Now scan arguments that are specific to the binder and are not + -- handled by the common circuitry in Switch. + + if Opt.Output_File_Name_Present + and then not Output_File_Name_Seen + then + Output_File_Name_Seen := True; + + if Argv'Length = 0 + or else (Argv'Length >= 1 and then Argv (1) = '-') + then + Fail ("output File_Name missing after -o"); + + else + Output_File_Name := new String'(Argv); + end if; + + elsif Argv'Length >= 2 and then Argv (1) = '-' then + + -- -I- + + if Argv (2 .. Argv'Last) = "I-" then + Opt.Look_In_Primary_Dir := False; + + -- -Idir + + elsif Argv (2) = 'I' then + Add_Src_Search_Dir (Argv (3 .. Argv'Last)); + Add_Lib_Search_Dir (Argv (3 .. Argv'Last)); + + -- -Ldir + + elsif Argv (2) = 'L' then + if Argv'Length >= 3 then + + -- Remember that the -L switch was specified, so that if this + -- is on OpenVMS, the export names are put in uppercase. + -- This is not known before the target parameters are read. + + L_Switch_Seen := True; + + Opt.Bind_For_Library := True; + Opt.Ada_Init_Name := + new String'(Argv (3 .. Argv'Last) & Opt.Ada_Init_Suffix); + Opt.Ada_Final_Name := + new String'(Argv (3 .. Argv'Last) & Opt.Ada_Final_Suffix); + Opt.Ada_Main_Name := + new String'(Argv (3 .. Argv'Last) & Opt.Ada_Main_Name_Suffix); + + -- This option (-Lxxx) implies -n + + Opt.Bind_Main_Program := False; + + else + Fail + ("Prefix of initialization and finalization " & + "procedure names missing in -L"); + end if; + + -- -Sin -Slo -Shi -Sxx -Sev + + elsif Argv'Length = 4 + and then Argv (2) = 'S' + then + declare + C1 : Character := Argv (3); + C2 : Character := Argv (4); + + begin + -- Fold to upper case + + 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; + + -- Test valid option and set mode accordingly + + if C1 = 'E' and then C2 = 'V' then + null; + + elsif C1 = 'I' and then C2 = 'N' then + null; + + elsif C1 = 'L' and then C2 = 'O' then + null; + + elsif C1 = 'H' and then C2 = 'I' then + null; + + elsif (C1 in '0' .. '9' or else C1 in 'A' .. 'F') + and then + (C2 in '0' .. '9' or else C2 in 'A' .. 'F') + then + null; + + -- Invalid -S switch, let Switch give error, set default of IN + + else + Scan_Binder_Switches (Argv); + C1 := 'I'; + C2 := 'N'; + end if; + + Initialize_Scalars_Mode1 := C1; + Initialize_Scalars_Mode2 := C2; + end; + + -- -aIdir + + elsif Argv'Length >= 3 + and then Argv (2 .. 3) = "aI" + then + Add_Src_Search_Dir (Argv (4 .. Argv'Last)); + + -- -aOdir + + elsif Argv'Length >= 3 + and then Argv (2 .. 3) = "aO" + then + Add_Lib_Search_Dir (Argv (4 .. Argv'Last)); + + -- -nostdlib + + elsif Argv (2 .. Argv'Last) = "nostdlib" then + Opt.No_Stdlib := True; + + -- -nostdinc + + elsif Argv (2 .. Argv'Last) = "nostdinc" then + Opt.No_Stdinc := True; + + -- -static + + elsif Argv (2 .. Argv'Last) = "static" then + Opt.Shared_Libgnat := False; + + -- -shared + + elsif Argv (2 .. Argv'Last) = "shared" then + Opt.Shared_Libgnat := True; + + -- -F=mapping_file + + elsif Argv'Length >= 4 and then Argv (2 .. 3) = "F=" then + if Mapping_File /= null then + Fail ("cannot specify several mapping files"); + end if; + + Mapping_File := new String'(Argv (4 .. Argv'Last)); + + -- -Mname + + elsif Argv'Length >= 3 and then Argv (2) = 'M' then + if not Is_Cross_Compiler then + Write_Line + ("gnatbind: -M not expected to be used on native platforms"); + end if; + + Opt.Bind_Alternate_Main_Name := True; + Opt.Alternate_Main_Name := new String'(Argv (3 .. Argv'Last)); + + -- All other options are single character and are handled by + -- Scan_Binder_Switches. + + else + Scan_Binder_Switches (Argv); + end if; + + -- Not a switch, so must be a file name (if non-empty) + + elsif Argv'Length /= 0 then + if Argv'Length > 4 + and then Argv (Argv'Last - 3 .. Argv'Last) = ".ali" + then + Add_File (Argv); + else + Add_File (Argv & ".ali"); + end if; + end if; + end Scan_Bind_Arg; + + procedure Check_Version_And_Help is + new Check_Version_And_Help_G (Bindusg.Display); + +-- Start of processing for Gnatbind + +begin + + -- Set default for Shared_Libgnat option + + declare + Shared_Libgnat_Default : Character; + pragma Import + (C, Shared_Libgnat_Default, "__gnat_shared_libgnat_default"); + + SHARED : constant Character := 'H'; + STATIC : constant Character := 'T'; + + begin + pragma Assert + (Shared_Libgnat_Default = SHARED + or else + Shared_Libgnat_Default = STATIC); + Shared_Libgnat := (Shared_Libgnat_Default = SHARED); + end; + + -- Scan the switches and arguments + + -- First, scan to detect --version and/or --help + + Check_Version_And_Help ("GNATBIND", "1995"); + + -- Use low level argument routines to avoid dragging in the secondary stack + + Next_Arg := 1; + Scan_Args : while Next_Arg < Arg_Count loop + declare + Next_Argv : String (1 .. Len_Arg (Next_Arg)); + begin + Fill_Arg (Next_Argv'Address, Next_Arg); + + if Next_Argv'Length > 0 then + if Next_Argv (1) = '@' then + if Next_Argv'Length > 1 then + declare + Arguments : constant Argument_List := + Response_File.Arguments_From + (Response_File_Name => + Next_Argv (2 .. Next_Argv'Last), + Recursive => True, + Ignore_Non_Existing_Files => True); + begin + for J in Arguments'Range loop + Scan_Bind_Arg (Arguments (J).all); + end loop; + end; + end if; + + else + Scan_Bind_Arg (Next_Argv); + end if; + end if; + end; + + Next_Arg := Next_Arg + 1; + end loop Scan_Args; + + if Use_Pragma_Linker_Constructor then + if Bind_Main_Program then + Fail ("switch -a must be used in conjunction with -n or -Lxxx"); + + elsif not Gnatbind_Supports_Auto_Init then + Fail ("automatic initialisation of elaboration " & + "not supported on this platform"); + end if; + end if; + + -- Test for trailing -o switch + + if Opt.Output_File_Name_Present + and then not Output_File_Name_Seen + then + Fail ("output file name missing after -o"); + end if; + + -- Output usage if requested + + if Usage_Requested then + Bindusg.Display; + end if; + + -- Check that the Ada binder file specified has extension .adb and that + -- the C binder file has extension .c + + if Opt.Output_File_Name_Present + and then Output_File_Name_Seen + then + Check_Extensions : declare + Length : constant Natural := Output_File_Name'Length; + Last : constant Natural := Output_File_Name'Last; + + begin + if Ada_Bind_File then + if Length <= 4 + or else Output_File_Name (Last - 3 .. Last) /= ".adb" + then + Fail ("output file name should have .adb extension"); + end if; + + else + if Length <= 2 + or else Output_File_Name (Last - 1 .. Last) /= ".c" + then + Fail ("output file name should have .c extension"); + end if; + end if; + end Check_Extensions; + end if; + + Osint.Add_Default_Search_Dirs; + + -- Carry out package initializations. These are initializations which + -- might logically be performed at elaboration time, and we decide to be + -- consistent. Like elaboration, the order in which these calls are made + -- is in some cases important. + + Csets.Initialize; + Snames.Initialize; + + -- Acquire target parameters + + Targparm.Get_Target_Parameters; + + -- Initialize Cumulative_Restrictions with the restrictions on the target + -- scanned from the system.ads file. Then as we read ALI files, we will + -- accumulate additional restrictions specified in other files. + + Cumulative_Restrictions := Targparm.Restrictions_On_Target; + + -- On OpenVMS, when -L is used, all external names used in pragmas Export + -- are in upper case. The reason is that on OpenVMS, the macro-assembler + -- MACASM-32, used to build Stand-Alone Libraries, only understands + -- uppercase. + + if L_Switch_Seen and then OpenVMS_On_Target then + To_Upper (Opt.Ada_Init_Name.all); + To_Upper (Opt.Ada_Final_Name.all); + To_Upper (Opt.Ada_Main_Name.all); + end if; + + -- Acquire configurable run-time mode + + if Configurable_Run_Time_On_Target then + Configurable_Run_Time_Mode := True; + end if; + + -- Output copyright notice if in verbose mode + + if Verbose_Mode then + Write_Eol; + Display_Version ("GNATBIND", "1995"); + end if; + + -- Output usage information if no files + + if not More_Lib_Files then + Bindusg.Display; + Exit_Program (E_Fatal); + end if; + + -- If a mapping file was specified, initialize the file mapping + + if Mapping_File /= null then + Fmap.Initialize (Mapping_File.all); + end if; + + -- The block here is to catch the Unrecoverable_Error exception in the + -- case where we exceed the maximum number of permissible errors or some + -- other unrecoverable error occurs. + + begin + -- Initialize binder packages + + Initialize_Binderr; + Initialize_ALI; + Initialize_ALI_Source; + + if Verbose_Mode then + Write_Eol; + end if; + + -- Input ALI files + + while More_Lib_Files loop + Main_Lib_File := Next_Main_Lib_File; + + if First_Main_Lib_File = No_File then + First_Main_Lib_File := Main_Lib_File; + end if; + + if Verbose_Mode then + if Check_Only then + Write_Str ("Checking: "); + else + Write_Str ("Binding: "); + end if; + + Write_Name (Main_Lib_File); + Write_Eol; + end if; + + Text := Read_Library_Info (Main_Lib_File, True); + + declare + Id : ALI_Id; + pragma Warnings (Off, Id); + + begin + Id := Scan_ALI + (F => Main_Lib_File, + T => Text, + Ignore_ED => False, + Err => False, + Ignore_Errors => Debug_Flag_I, + Directly_Scanned => True); + end; + + Free (Text); + end loop; + + -- No_Run_Time mode + + if No_Run_Time_Mode then + + -- Set standard configuration parameters + + Suppress_Standard_Library_On_Target := True; + Configurable_Run_Time_Mode := True; + end if; + + -- For main ALI files, even if they are interfaces, we get their + -- dependencies. To be sure, we reset the Interface flag for all main + -- ALI files. + + for Index in ALIs.First .. ALIs.Last loop + ALIs.Table (Index).SAL_Interface := False; + end loop; + + -- Add System.Standard_Library to list to ensure that these files are + -- included in the bind, even if not directly referenced from Ada code + -- This is suppressed if the appropriate targparm switch is set. + + if not Suppress_Standard_Library_On_Target then + Name_Buffer (1 .. 12) := "s-stalib.ali"; + Name_Len := 12; + Std_Lib_File := Name_Find; + Text := Read_Library_Info (Std_Lib_File, True); + + declare + Id : ALI_Id; + pragma Warnings (Off, Id); + + begin + Id := + Scan_ALI + (F => Std_Lib_File, + T => Text, + Ignore_ED => False, + Err => False, + Ignore_Errors => Debug_Flag_I); + end; + + Free (Text); + end if; + + -- Load ALIs for all dependent units + + for Index in ALIs.First .. ALIs.Last loop + Read_Withed_ALIs (Index); + end loop; + + -- Quit if some file needs compiling + + if No_Object_Specified then + raise Unrecoverable_Error; + end if; + + -- Output list of ALI files in closure + + if Output_ALI_List then + if ALI_List_Filename /= null then + Set_List_File (ALI_List_Filename.all); + end if; + + for Index in ALIs.First .. ALIs.Last loop + declare + Full_Afile : constant File_Name_Type := + Find_File (ALIs.Table (Index).Afile, Library); + begin + Write_Name (Full_Afile); + Write_Eol; + end; + end loop; + + if ALI_List_Filename /= null then + Close_List_File; + end if; + end if; + + -- Build source file table from the ALI files we have read in + + Set_Source_Table; + + -- If there is main program to bind, set Main_Lib_File to the first + -- library file, and the name from which to derive the binder generate + -- file to the first ALI file. + + if Bind_Main_Program then + Main_Lib_File := First_Main_Lib_File; + Set_Current_File_Name_Index (To => 1); + end if; + + -- Check that main library file is a suitable main program + + if Bind_Main_Program + and then ALIs.Table (ALIs.First).Main_Program = None + and then not No_Main_Subprogram + then + Get_Name_String + (Units.Table (ALIs.Table (ALIs.First).First_Unit).Uname); + + declare + Unit_Name : String := Name_Buffer (1 .. Name_Len - 2); + begin + To_Mixed (Unit_Name); + Get_Name_String (ALIs.Table (ALIs.First).Sfile); + Add_Str_To_Name_Buffer (":1: "); + Add_Str_To_Name_Buffer (Unit_Name); + Add_Str_To_Name_Buffer (" cannot be used as a main program"); + Write_Line (Name_Buffer (1 .. Name_Len)); + Errors_Detected := Errors_Detected + 1; + end; + end if; + + -- Perform consistency and correctness checks + + Check_Duplicated_Subunits; + Check_Versions; + Check_Consistency; + Check_Configuration_Consistency; + + -- List restrictions that could be applied to this partition + + if List_Restrictions then + List_Applicable_Restrictions; + end if; + + -- Complete bind if no errors + + if Errors_Detected = 0 then + Find_Elab_Order; + + if Errors_Detected = 0 then + -- Display elaboration order if -l was specified + + if Elab_Order_Output then + if not Zero_Formatting then + Write_Eol; + Write_Str ("ELABORATION ORDER"); + Write_Eol; + end if; + + for J in Elab_Order.First .. Elab_Order.Last loop + if not Units.Table (Elab_Order.Table (J)).SAL_Interface then + if not Zero_Formatting then + Write_Str (" "); + end if; + + Write_Unit_Name + (Units.Table (Elab_Order.Table (J)).Uname); + Write_Eol; + end if; + end loop; + + if not Zero_Formatting then + Write_Eol; + end if; + end if; + + if not Check_Only then + Gen_Output_File (Output_File_Name.all); + end if; + + -- Display list of sources in the closure (except predefined + -- sources) if -R was used. + + if List_Closure then + List_Closure_Display : declare + Source : File_Name_Type; + + function Put_In_Sources (S : File_Name_Type) return Boolean; + -- Check if S is already in table Sources and put in Sources + -- if it is not. Return False if the source is already in + -- Sources, and True if it is added. + + -------------------- + -- Put_In_Sources -- + -------------------- + + function Put_In_Sources (S : File_Name_Type) + return Boolean + is + begin + for J in 1 .. Closure_Sources.Last loop + if Closure_Sources.Table (J) = S then + return False; + end if; + end loop; + + Closure_Sources.Append (S); + return True; + end Put_In_Sources; + + -- Start of processing for List_Closure_Display + + begin + Closure_Sources.Init; + + if not Zero_Formatting then + Write_Eol; + Write_Str ("REFERENCED SOURCES"); + Write_Eol; + end if; + + for J in reverse Elab_Order.First .. Elab_Order.Last loop + Source := Units.Table (Elab_Order.Table (J)).Sfile; + + -- Do not include the sources of the runtime and do not + -- include the same source several times. + + if Put_In_Sources (Source) + and then not Is_Internal_File_Name (Source) + then + if not Zero_Formatting then + Write_Str (" "); + end if; + + Write_Str (Get_Name_String (Source)); + Write_Eol; + end if; + end loop; + + -- Subunits do not appear in the elaboration table because + -- they are subsumed by their parent units, but we need to + -- list them for other tools. For now they are listed after + -- other files, rather than right after their parent, since + -- there is no easy link between the elaboration table and + -- the ALIs table ??? As subunits may appear repeatedly in + -- the list, if the parent unit appears in the context of + -- several units in the closure, duplicates are suppressed. + + for J in Sdep.First .. Sdep.Last loop + Source := Sdep.Table (J).Sfile; + + if Sdep.Table (J).Subunit_Name /= No_Name + and then Put_In_Sources (Source) + and then not Is_Internal_File_Name (Source) + then + if not Zero_Formatting then + Write_Str (" "); + end if; + + Write_Str (Get_Name_String (Source)); + Write_Eol; + end if; + end loop; + + if not Zero_Formatting then + Write_Eol; + end if; + end List_Closure_Display; + end if; + end if; + end if; + + Total_Errors := Total_Errors + Errors_Detected; + Total_Warnings := Total_Warnings + Warnings_Detected; + + exception + when Unrecoverable_Error => + Total_Errors := Total_Errors + Errors_Detected; + Total_Warnings := Total_Warnings + Warnings_Detected; + end; + + -- All done. Set proper exit status + + Finalize_Binderr; + Namet.Finalize; + + if Total_Errors > 0 then + Exit_Program (E_Errors); + + elsif Total_Warnings > 0 then + Exit_Program (E_Warnings); + + else + -- Do not call Exit_Program (E_Success), so that finalization occurs + -- normally. + + null; + end if; + +end Gnatbind; diff --git a/gcc/ada/gnatbind.ads b/gcc/ada/gnatbind.ads new file mode 100644 index 000000000..be78dcd04 --- /dev/null +++ b/gcc/ada/gnatbind.ads @@ -0,0 +1,28 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T B I N 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Main program of GNAT binder + +procedure Gnatbind; diff --git a/gcc/ada/gnatchop.adb b/gcc/ada/gnatchop.adb new file mode 100644 index 000000000..c72ac75b1 --- /dev/null +++ b/gcc/ada/gnatchop.adb @@ -0,0 +1,1889 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T C H O P -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Conversions; use Ada.Characters.Conversions; +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Directories; use Ada.Directories; +with Ada.Streams.Stream_IO; use Ada.Streams; +with Ada.Text_IO; use Ada.Text_IO; +with System.CRTL; use System; use System.CRTL; + +with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark; +with GNAT.Command_Line; use GNAT.Command_Line; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Heap_Sort_G; +with GNAT.Table; + +with Hostparm; +with Switch; use Switch; +with Types; + +procedure Gnatchop is + + Config_File_Name : constant String_Access := new String'("gnat.adc"); + -- The name of the file holding the GNAT configuration pragmas + + Gcc : String_Access := new String'("gcc"); + -- May be modified by switch --GCC= + + Gcc_Set : Boolean := False; + -- True if a switch --GCC= is used + + Gnat_Cmd : String_Access; + -- Command to execute the GNAT compiler + + Gnat_Args : Argument_List_Access := + new Argument_List' + (new String'("-c"), + new String'("-x"), + new String'("ada"), + new String'("-gnats"), + new String'("-gnatu")); + -- Arguments used in Gnat_Cmd call + + EOF : constant Character := Character'Val (26); + -- Special character to signal end of file. Not required in input files, + -- but properly treated if present. Not generated in output files except + -- as a result of copying input file. + + BOM_Length : Natural := 0; + -- Reset to non-zero value if BOM detected at start of file + + -------------------- + -- File arguments -- + -------------------- + + subtype File_Num is Natural; + subtype File_Offset is Natural; + + type File_Entry is record + Name : String_Access; + -- Name of chop file or directory + + SR_Name : String_Access; + -- Null unless the chop file starts with a source reference pragma + -- in which case this field points to the file name from this pragma. + end record; + + package File is new GNAT.Table + (Table_Component_Type => File_Entry, + Table_Index_Type => File_Num, + Table_Low_Bound => 1, + Table_Initial => 100, + Table_Increment => 100); + + Directory : String_Access; + -- Record name of directory, or a null string if no directory given + + Compilation_Mode : Boolean := False; + Overwrite_Files : Boolean := False; + Preserve_Mode : Boolean := False; + Quiet_Mode : Boolean := False; + Source_References : Boolean := False; + Verbose_Mode : Boolean := False; + Exit_On_Error : Boolean := False; + -- Global options + + Write_gnat_adc : Boolean := False; + -- Gets set true if we append to gnat.adc or create a new gnat.adc. + -- Used to inhibit complaint about no units generated. + + --------------- + -- Unit list -- + --------------- + + type Line_Num is new Natural; + -- Line number (for source reference pragmas) + + type Unit_Count_Type is new Integer; + subtype Unit_Num is Unit_Count_Type range 1 .. Unit_Count_Type'Last; + -- Used to refer to unit number in unit table + + type SUnit_Num is new Integer; + -- Used to refer to entry in sorted units table. Note that entry + -- zero is only for use by Heapsort, and is not otherwise referenced. + + type Unit_Kind is (Unit_Spec, Unit_Body, Config_Pragmas); + + -- Structure to contain all necessary information for one unit. + -- Entries are also temporarily used to record config pragma sequences. + + type Unit_Info is record + File_Name : String_Access; + -- File name from GNAT output line + + Chop_File : File_Num; + -- File number in chop file sequence + + Start_Line : Line_Num; + -- Line number from GNAT output line + + Offset : File_Offset; + -- Offset name from GNAT output line + + SR_Present : Boolean; + -- Set True if SR parameter present + + Length : File_Offset; + -- A length of 0 means that the Unit is the last one in the file + + Kind : Unit_Kind; + -- Indicates kind of unit + + Sorted_Index : SUnit_Num; + -- Index of unit in sorted unit list + + Bufferg : String_Access; + -- Pointer to buffer containing configuration pragmas to be prepended. + -- Null if no pragmas to be prepended. + end record; + + -- The following table stores the unit offset information + + package Unit is new GNAT.Table + (Table_Component_Type => Unit_Info, + Table_Index_Type => Unit_Count_Type, + Table_Low_Bound => 1, + Table_Initial => 500, + Table_Increment => 100); + + -- The following table is used as a sorted index to the Unit.Table. + -- The entries in Unit.Table are not moved, instead we just shuffle + -- the entries in Sorted_Units. Note that the zeroeth entry in this + -- table is used by GNAT.Heap_Sort_G. + + package Sorted_Units is new GNAT.Table + (Table_Component_Type => Unit_Num, + Table_Index_Type => SUnit_Num, + Table_Low_Bound => 0, + Table_Initial => 500, + Table_Increment => 100); + + function Is_Duplicated (U : SUnit_Num) return Boolean; + -- Returns true if U is duplicated by a later unit. + -- Note that this function returns false for the last entry. + + procedure Sort_Units; + -- Sort units and set up sorted unit table + + ---------------------- + -- File_Descriptors -- + ---------------------- + + function dup (handle : File_Descriptor) return File_Descriptor; + function dup2 (from, to : File_Descriptor) return File_Descriptor; + + --------------------- + -- Local variables -- + --------------------- + + Warning_Count : Natural := 0; + -- Count of warnings issued so far + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Error_Msg (Message : String; Warning : Boolean := False); + -- Produce an error message on standard error output + + procedure File_Time_Stamp (Name : C_File_Name; Time : OS_Time); + -- Given the name of a file or directory, Name, set the + -- time stamp. This function must be used for an unopened file. + + function Files_Exist return Boolean; + -- Check Unit.Table for possible file names that already exist + -- in the file system. Returns true if files exist, False otherwise + + function Get_Maximum_File_Name_Length return Integer; + pragma Import (C, Get_Maximum_File_Name_Length, + "__gnat_get_maximum_file_name_length"); + -- Function to get maximum file name length for system + + Maximum_File_Name_Length : constant Integer := Get_Maximum_File_Name_Length; + Maximum_File_Name_Length_String : constant String := + Integer'Image + (Maximum_File_Name_Length); + + function Locate_Executable + (Program_Name : String; + Look_For_Prefix : Boolean := True) return String_Access; + -- Locate executable for given program name. This takes into account + -- the target-prefix of the current command, if Look_For_Prefix is True. + + subtype EOL_Length is Natural range 0 .. 2; + -- Possible lengths of end of line sequence + + type EOL_String (Len : EOL_Length := 0) is record + Str : String (1 .. Len); + end record; + + function Get_EOL + (Source : not null access String; + Start : Positive) return EOL_String; + -- Return the line terminator used in the passed string + + procedure Parse_EOL + (Source : not null access String; + Ptr : in out Positive); + -- On return Source (Ptr) is the first character of the next line + -- or EOF. Source.all must be terminated by EOF. + + function Parse_File (Num : File_Num) return Boolean; + -- Calls the GNAT compiler to parse the given source file and parses the + -- output using Parse_Offset_Info. Returns True if parse operation + -- completes, False if some system error (e.g. failure to read the + -- offset information) occurs. + + procedure Parse_Offset_Info + (Chop_File : File_Num; + Source : not null access String); + -- Parses the output of the compiler indicating the offsets + -- and names of the compilation units in Chop_File. + + procedure Parse_Token + (Source : not null access String; + Ptr : in out Positive; + Token_Ptr : out Positive); + -- Skips any separators and stores the start of the token in Token_Ptr. + -- Then stores the position of the next separator in Ptr. + -- On return Source (Token_Ptr .. Ptr - 1) is the token. + + procedure Read_File + (FD : File_Descriptor; + Contents : out String_Access; + Success : out Boolean); + -- Reads file associated with FS into the newly allocated + -- string Contents. + -- [VMS] Success is true iff the number of bytes read is less than or + -- equal to the file size. + -- [Other] Success is true iff the number of bytes read is equal to + -- the file size. + + function Report_Duplicate_Units return Boolean; + -- Output messages about duplicate units in the input files in Unit.Table + -- Returns True if any duplicates found, False if no duplicates found. + + function Scan_Arguments return Boolean; + -- Scan command line options and set global variables accordingly. + -- Also scan out file and directory arguments. Returns True if scan + -- was successful, and False if the scan fails for any reason. + + procedure Usage; + -- Output message on standard output describing syntax of gnatchop command + + procedure Warning_Msg (Message : String); + -- Output a warning message on standard error and update warning count + + function Write_Chopped_Files (Input : File_Num) return Boolean; + -- Write all units that result from chopping the Input file + + procedure Write_Config_File (Input : File_Num; U : Unit_Num); + -- Call to write configuration pragmas (append them to gnat.adc) + -- Input is the file number for the chop file and U identifies the + -- unit entry for the configuration pragmas. + + function Get_Config_Pragmas + (Input : File_Num; + U : Unit_Num) return String_Access; + -- Call to read configuration pragmas from given unit entry, and + -- return a buffer containing the pragmas to be appended to + -- following units. Input is the file number for the chop file and + -- U identifies the unit entry for the configuration pragmas. + + procedure Write_Source_Reference_Pragma + (Info : Unit_Info; + Line : Line_Num; + File : Stream_IO.File_Type; + EOL : EOL_String; + Success : in out Boolean); + -- If Success is True on entry, writes a source reference pragma using + -- the chop file from Info, and the given line number. On return Success + -- indicates whether the write succeeded. If Success is False on entry, + -- or if the global flag Source_References is False, then the call to + -- Write_Source_Reference_Pragma has no effect. EOL indicates the end + -- of line sequence to be written at the end of the pragma. + + procedure Write_Unit + (Source : not null access String; + Num : Unit_Num; + TS_Time : OS_Time; + Write_BOM : Boolean; + Success : out Boolean); + -- Write one compilation unit of the source to file. Source is the pointer + -- to the input string, Num is the unit number, TS_Time is the timestamp, + -- Write_BOM is set True to write a UTF-8 BOM at the start of the file. + -- Success is set True unless the write attempt fails. + + --------- + -- dup -- + --------- + + function dup (handle : File_Descriptor) return File_Descriptor is + begin + return File_Descriptor (System.CRTL.dup (int (handle))); + end dup; + + ---------- + -- dup2 -- + ---------- + + function dup2 (from, to : File_Descriptor) return File_Descriptor is + begin + return File_Descriptor (System.CRTL.dup2 (int (from), int (to))); + end dup2; + + --------------- + -- Error_Msg -- + --------------- + + procedure Error_Msg (Message : String; Warning : Boolean := False) is + begin + Put_Line (Standard_Error, Message); + + if not Warning then + Set_Exit_Status (Failure); + + if Exit_On_Error then + raise Types.Terminate_Program; + end if; + end if; + end Error_Msg; + + --------------------- + -- File_Time_Stamp -- + --------------------- + + procedure File_Time_Stamp (Name : C_File_Name; Time : OS_Time) is + procedure Set_File_Time (Name : C_File_Name; Time : OS_Time); + pragma Import (C, Set_File_Time, "__gnat_set_file_time_name"); + + begin + Set_File_Time (Name, Time); + end File_Time_Stamp; + + ----------------- + -- Files_Exist -- + ----------------- + + function Files_Exist return Boolean is + Exists : Boolean := False; + + begin + for SNum in 1 .. SUnit_Num (Unit.Last) loop + + -- Only check and report for the last instance of duplicated files + + if not Is_Duplicated (SNum) then + declare + Info : constant Unit_Info := + Unit.Table (Sorted_Units.Table (SNum)); + + begin + if Is_Writable_File (Info.File_Name.all) then + if Hostparm.OpenVMS then + Error_Msg + (Info.File_Name.all + & " already exists, use /OVERWRITE to overwrite"); + else + Error_Msg (Info.File_Name.all + & " already exists, use -w to overwrite"); + end if; + + Exists := True; + end if; + end; + end if; + end loop; + + return Exists; + end Files_Exist; + + ------------------------ + -- Get_Config_Pragmas -- + ------------------------ + + function Get_Config_Pragmas + (Input : File_Num; + U : Unit_Num) return String_Access + is + Info : Unit_Info renames Unit.Table (U); + FD : File_Descriptor; + Name : aliased constant String := + File.Table (Input).Name.all & ASCII.NUL; + Length : File_Offset; + Buffer : String_Access; + Result : String_Access; + + Success : Boolean; + pragma Warnings (Off, Success); + + begin + FD := Open_Read (Name'Address, Binary); + + if FD = Invalid_FD then + Error_Msg ("cannot open " & File.Table (Input).Name.all); + return null; + end if; + + Read_File (FD, Buffer, Success); + + -- A length of 0 indicates that the rest of the file belongs to + -- this unit. The actual length must be calculated now. Take into + -- account that the last character (EOF) must not be written. + + if Info.Length = 0 then + Length := Buffer'Last - (Buffer'First + Info.Offset); + else + Length := Info.Length; + end if; + + Result := new String'(Buffer (1 .. Length)); + Close (FD); + return Result; + end Get_Config_Pragmas; + + ------------- + -- Get_EOL -- + ------------- + + function Get_EOL + (Source : not null access String; + Start : Positive) return EOL_String + is + Ptr : Positive := Start; + First : Positive; + Last : Natural; + + begin + -- Skip to end of line + + while Source (Ptr) /= ASCII.CR and then + Source (Ptr) /= ASCII.LF and then + Source (Ptr) /= EOF + loop + Ptr := Ptr + 1; + end loop; + + Last := Ptr; + + if Source (Ptr) /= EOF then + + -- Found CR or LF + + First := Ptr; + + else + First := Ptr + 1; + end if; + + -- Recognize CR/LF + + if Source (Ptr) = ASCII.CR and then Source (Ptr + 1) = ASCII.LF then + Last := First + 1; + end if; + + return (Len => Last + 1 - First, Str => Source (First .. Last)); + end Get_EOL; + + ------------------- + -- Is_Duplicated -- + ------------------- + + function Is_Duplicated (U : SUnit_Num) return Boolean is + begin + return U < SUnit_Num (Unit.Last) + and then + Unit.Table (Sorted_Units.Table (U)).File_Name.all = + Unit.Table (Sorted_Units.Table (U + 1)).File_Name.all; + end Is_Duplicated; + + ----------------------- + -- Locate_Executable -- + ----------------------- + + function Locate_Executable + (Program_Name : String; + Look_For_Prefix : Boolean := True) return String_Access + is + Gnatchop_Str : constant String := "gnatchop"; + Current_Command : constant String := Normalize_Pathname (Command_Name); + End_Of_Prefix : Natural; + Start_Of_Prefix : Positive; + Start_Of_Suffix : Positive; + Result : String_Access; + + begin + Start_Of_Prefix := Current_Command'First; + Start_Of_Suffix := Current_Command'Last + 1; + End_Of_Prefix := Start_Of_Prefix - 1; + + if Look_For_Prefix then + + -- Find Start_Of_Prefix + + for J in reverse Current_Command'Range loop + if Current_Command (J) = '/' or else + Current_Command (J) = Directory_Separator or else + Current_Command (J) = ':' + then + Start_Of_Prefix := J + 1; + exit; + end if; + end loop; + + -- Find End_Of_Prefix + + for J in Start_Of_Prefix .. + Current_Command'Last - Gnatchop_Str'Length + 1 + loop + if Current_Command (J .. J + Gnatchop_Str'Length - 1) = + Gnatchop_Str + then + End_Of_Prefix := J - 1; + exit; + end if; + end loop; + end if; + + if End_Of_Prefix > Current_Command'First then + Start_Of_Suffix := End_Of_Prefix + Gnatchop_Str'Length + 1; + end if; + + declare + Command : constant String := + Current_Command (Start_Of_Prefix .. End_Of_Prefix) + & Program_Name + & Current_Command (Start_Of_Suffix .. + Current_Command'Last); + begin + Result := Locate_Exec_On_Path (Command); + + if Result = null then + Error_Msg + (Command & ": installation problem, executable not found"); + end if; + end; + + return Result; + end Locate_Executable; + + --------------- + -- Parse_EOL -- + --------------- + + procedure Parse_EOL + (Source : not null access String; + Ptr : in out Positive) is + begin + -- Skip to end of line + + while Source (Ptr) /= ASCII.CR and then Source (Ptr) /= ASCII.LF + and then Source (Ptr) /= EOF + loop + Ptr := Ptr + 1; + end loop; + + if Source (Ptr) /= EOF then + Ptr := Ptr + 1; -- skip CR or LF + end if; + + -- Skip past CR/LF or LF/CR combination + + if (Source (Ptr) = ASCII.CR or else Source (Ptr) = ASCII.LF) + and then Source (Ptr) /= Source (Ptr - 1) + then + Ptr := Ptr + 1; + end if; + end Parse_EOL; + + ---------------- + -- Parse_File -- + ---------------- + + function Parse_File (Num : File_Num) return Boolean is + Chop_Name : constant String_Access := File.Table (Num).Name; + Save_Stdout : constant File_Descriptor := dup (Standout); + Offset_Name : Temp_File_Name; + Offset_FD : File_Descriptor; + Buffer : String_Access; + Success : Boolean; + Failure : exception; + + begin + -- Display copy of GNAT command if verbose mode + + if Verbose_Mode then + Put (Gnat_Cmd.all); + + for J in 1 .. Gnat_Args'Length loop + Put (' '); + Put (Gnat_Args (J).all); + end loop; + + Put (' '); + Put_Line (Chop_Name.all); + end if; + + -- Create temporary file + + Create_Temp_File (Offset_FD, Offset_Name); + + if Offset_FD = Invalid_FD then + Error_Msg ("gnatchop: cannot create temporary file"); + Close (Save_Stdout); + return False; + end if; + + -- Redirect Stdout to this temporary file in the Unix way + + if dup2 (Offset_FD, Standout) = Invalid_FD then + Error_Msg ("gnatchop: cannot redirect stdout to temporary file"); + Close (Save_Stdout); + Close (Offset_FD); + return False; + end if; + + -- Call Gnat on the source filename argument with special options + -- to generate offset information. If this special compilation completes + -- successfully then we can do the actual gnatchop operation. + + Spawn (Gnat_Cmd.all, Gnat_Args.all & Chop_Name, Success); + + if not Success then + Error_Msg (Chop_Name.all & ": parse errors detected"); + Error_Msg (Chop_Name.all & ": chop may not be successful"); + end if; + + -- Restore stdout + + if dup2 (Save_Stdout, Standout) = Invalid_FD then + Error_Msg ("gnatchop: cannot restore stdout"); + end if; + + -- Reopen the file to start reading from the beginning + + Close (Offset_FD); + Close (Save_Stdout); + Offset_FD := Open_Read (Offset_Name'Address, Binary); + + if Offset_FD = Invalid_FD then + Error_Msg ("gnatchop: cannot access offset info"); + raise Failure; + end if; + + Read_File (Offset_FD, Buffer, Success); + + if not Success then + Error_Msg ("gnatchop: error reading offset info"); + Close (Offset_FD); + raise Failure; + else + Parse_Offset_Info (Num, Buffer); + end if; + + -- Close and delete temporary file + + Close (Offset_FD); + Delete_File (Offset_Name'Address, Success); + + return Success; + + exception + when Failure | Types.Terminate_Program => + Close (Offset_FD); + Delete_File (Offset_Name'Address, Success); + return False; + + end Parse_File; + + ----------------------- + -- Parse_Offset_Info -- + ----------------------- + + procedure Parse_Offset_Info + (Chop_File : File_Num; + Source : not null access String) + is + First_Unit : constant Unit_Num := Unit.Last + 1; + Bufferg : String_Access := null; + Parse_Ptr : File_Offset := Source'First; + Token_Ptr : File_Offset; + Info : Unit_Info; + + function Match (Literal : String) return Boolean; + -- Checks if given string appears at the current Token_Ptr location + -- and if so, bumps Parse_Ptr past the token and returns True. If + -- the string is not present, sets Parse_Ptr to Token_Ptr and + -- returns False. + + ----------- + -- Match -- + ----------- + + function Match (Literal : String) return Boolean is + begin + Parse_Token (Source, Parse_Ptr, Token_Ptr); + + if Source'Last + 1 - Token_Ptr < Literal'Length + or else + Source (Token_Ptr .. Token_Ptr + Literal'Length - 1) /= Literal + then + Parse_Ptr := Token_Ptr; + return False; + end if; + + Parse_Ptr := Token_Ptr + Literal'Length; + return True; + end Match; + + -- Start of processing for Parse_Offset_Info + + begin + loop + -- Set default values, should get changed for all + -- units/pragmas except for the last + + Info.Chop_File := Chop_File; + Info.Length := 0; + + -- Parse the current line of offset information into Info + -- and exit the loop if there are any errors or on EOF. + + -- First case, parse a line in the following format: + + -- Unit x (spec) line 7, file offset 142, [SR, ]file name x.ads + + -- Note that the unit name can be an operator name in quotes. + -- This is of course illegal, but both GNAT and gnatchop handle + -- the case so that this error does not interfere with chopping. + + -- The SR ir present indicates that a source reference pragma + -- was processed as part of this unit (and that therefore no + -- Source_Reference pragma should be generated. + + if Match ("Unit") then + Parse_Token (Source, Parse_Ptr, Token_Ptr); + + if Match ("(body)") then + Info.Kind := Unit_Body; + elsif Match ("(spec)") then + Info.Kind := Unit_Spec; + else + exit; + end if; + + exit when not Match ("line"); + Parse_Token (Source, Parse_Ptr, Token_Ptr); + Info.Start_Line := Line_Num'Value + (Source (Token_Ptr .. Parse_Ptr - 1)); + + exit when not Match ("file offset"); + Parse_Token (Source, Parse_Ptr, Token_Ptr); + Info.Offset := File_Offset'Value + (Source (Token_Ptr .. Parse_Ptr - 1)); + + Info.SR_Present := Match ("SR, "); + + exit when not Match ("file name"); + Parse_Token (Source, Parse_Ptr, Token_Ptr); + Info.File_Name := new String' + (Directory.all & Source (Token_Ptr .. Parse_Ptr - 1)); + Parse_EOL (Source, Parse_Ptr); + + -- Second case, parse a line of the following form + + -- Configuration pragmas at line 10, file offset 223 + + elsif Match ("Configuration pragmas at") then + Info.Kind := Config_Pragmas; + Info.File_Name := Config_File_Name; + + exit when not Match ("line"); + Parse_Token (Source, Parse_Ptr, Token_Ptr); + Info.Start_Line := Line_Num'Value + (Source (Token_Ptr .. Parse_Ptr - 1)); + + exit when not Match ("file offset"); + Parse_Token (Source, Parse_Ptr, Token_Ptr); + Info.Offset := File_Offset'Value + (Source (Token_Ptr .. Parse_Ptr - 1)); + + Parse_EOL (Source, Parse_Ptr); + + -- Third case, parse a line of the following form + + -- Source_Reference pragma for file "filename" + + -- This appears at the start of the file only, and indicates + -- the name to be used on any generated Source_Reference pragmas. + + elsif Match ("Source_Reference pragma for file ") then + Parse_Token (Source, Parse_Ptr, Token_Ptr); + File.Table (Chop_File).SR_Name := + new String'(Source (Token_Ptr + 1 .. Parse_Ptr - 2)); + Parse_EOL (Source, Parse_Ptr); + goto Continue; + + -- Unrecognized keyword or end of file + + else + exit; + end if; + + -- Store the data in the Info record in the Unit.Table + + Unit.Increment_Last; + Unit.Table (Unit.Last) := Info; + + -- If this is not the first unit from the file, calculate + -- the length of the previous unit as difference of the offsets + + if Unit.Last > First_Unit then + Unit.Table (Unit.Last - 1).Length := + Info.Offset - Unit.Table (Unit.Last - 1).Offset; + end if; + + -- If not in compilation mode combine current unit with any + -- preceding configuration pragmas. + + if not Compilation_Mode + and then Unit.Last > First_Unit + and then Unit.Table (Unit.Last - 1).Kind = Config_Pragmas + then + Info.Start_Line := Unit.Table (Unit.Last - 1).Start_Line; + Info.Offset := Unit.Table (Unit.Last - 1).Offset; + + -- Delete the configuration pragma entry + + Unit.Table (Unit.Last - 1) := Info; + Unit.Decrement_Last; + end if; + + -- If in compilation mode, and previous entry is the initial + -- entry for the file and is for configuration pragmas, then + -- they are to be appended to every unit in the file. + + if Compilation_Mode + and then Unit.Last = First_Unit + 1 + and then Unit.Table (First_Unit).Kind = Config_Pragmas + then + Bufferg := + Get_Config_Pragmas + (Unit.Table (Unit.Last - 1).Chop_File, First_Unit); + Unit.Table (Unit.Last - 1) := Info; + Unit.Decrement_Last; + end if; + + Unit.Table (Unit.Last).Bufferg := Bufferg; + + -- If in compilation mode, and this is not the first item, + -- combine configuration pragmas with previous unit, which + -- will cause an error message to be generated when the unit + -- is compiled. + + if Compilation_Mode + and then Unit.Last > First_Unit + and then Unit.Table (Unit.Last).Kind = Config_Pragmas + then + Unit.Decrement_Last; + end if; + + <> + null; + + end loop; + + -- Find out if the loop was exited prematurely because of + -- an error or if the EOF marker was found. + + if Source (Parse_Ptr) /= EOF then + Error_Msg + (File.Table (Chop_File).Name.all & ": error parsing offset info"); + return; + end if; + + -- Handle case of a chop file consisting only of config pragmas + + if Unit.Last = First_Unit + and then Unit.Table (Unit.Last).Kind = Config_Pragmas + then + -- In compilation mode, we append such a file to gnat.adc + + if Compilation_Mode then + Write_Config_File (Unit.Table (Unit.Last).Chop_File, First_Unit); + Unit.Decrement_Last; + + -- In default (non-compilation) mode, this is invalid + + else + Error_Msg + (File.Table (Chop_File).Name.all & + ": no units found (only pragmas)"); + Unit.Decrement_Last; + end if; + end if; + + -- Handle case of a chop file ending with config pragmas. This can + -- happen only in default non-compilation mode, since in compilation + -- mode such configuration pragmas are part of the preceding unit. + -- We simply concatenate such pragmas to the previous file which + -- will cause a compilation error, which is appropriate. + + if Unit.Last > First_Unit + and then Unit.Table (Unit.Last).Kind = Config_Pragmas + then + Unit.Decrement_Last; + end if; + end Parse_Offset_Info; + + ----------------- + -- Parse_Token -- + ----------------- + + procedure Parse_Token + (Source : not null access String; + Ptr : in out Positive; + Token_Ptr : out Positive) + is + In_Quotes : Boolean := False; + + begin + -- Skip separators + + while Source (Ptr) = ' ' or else Source (Ptr) = ',' loop + Ptr := Ptr + 1; + end loop; + + Token_Ptr := Ptr; + + -- Find end-of-token + + while (In_Quotes + or else not (Source (Ptr) = ' ' or else Source (Ptr) = ',')) + and then Source (Ptr) >= ' ' + loop + if Source (Ptr) = '"' then + In_Quotes := not In_Quotes; + end if; + + Ptr := Ptr + 1; + end loop; + end Parse_Token; + + --------------- + -- Read_File -- + --------------- + + procedure Read_File + (FD : File_Descriptor; + Contents : out String_Access; + Success : out Boolean) + is + Length : constant File_Offset := File_Offset (File_Length (FD)); + -- Include room for EOF char + Buffer : constant String_Access := new String (1 .. Length + 1); + + This_Read : Integer; + Read_Ptr : File_Offset := 1; + + begin + + loop + This_Read := Read (FD, + A => Buffer (Read_Ptr)'Address, + N => Length + 1 - Read_Ptr); + Read_Ptr := Read_Ptr + Integer'Max (This_Read, 0); + exit when This_Read <= 0; + end loop; + + Buffer (Read_Ptr) := EOF; + Contents := new String (1 .. Read_Ptr); + Contents.all := Buffer (1 .. Read_Ptr); + + -- Things aren't simple on VMS due to the plethora of file types and + -- organizations. It seems clear that there shouldn't be more bytes + -- read than are contained in the file though. + + if Hostparm.OpenVMS then + Success := Read_Ptr <= Length + 1; + else + Success := Read_Ptr = Length + 1; + end if; + end Read_File; + + ---------------------------- + -- Report_Duplicate_Units -- + ---------------------------- + + function Report_Duplicate_Units return Boolean is + US : SUnit_Num; + U : Unit_Num; + + Duplicates : Boolean := False; + + begin + US := 1; + while US < SUnit_Num (Unit.Last) loop + U := Sorted_Units.Table (US); + + if Is_Duplicated (US) then + Duplicates := True; + + -- Move to last two versions of duplicated file to make it clearer + -- to understand which file is retained in case of overwriting. + + while US + 1 < SUnit_Num (Unit.Last) loop + exit when not Is_Duplicated (US + 1); + US := US + 1; + end loop; + + U := Sorted_Units.Table (US); + + if Overwrite_Files then + Warning_Msg (Unit.Table (U).File_Name.all + & " is duplicated (all but last will be skipped)"); + + elsif Unit.Table (U).Chop_File = + Unit.Table (Sorted_Units.Table (US + 1)).Chop_File + then + Error_Msg (Unit.Table (U).File_Name.all + & " is duplicated in " + & File.Table (Unit.Table (U).Chop_File).Name.all); + + else + Error_Msg (Unit.Table (U).File_Name.all + & " in " + & File.Table (Unit.Table (U).Chop_File).Name.all + & " is duplicated in " + & File.Table + (Unit.Table + (Sorted_Units.Table (US + 1)).Chop_File).Name.all); + end if; + end if; + + US := US + 1; + end loop; + + if Duplicates and not Overwrite_Files then + if Hostparm.OpenVMS then + Put_Line + ("use /OVERWRITE to overwrite files and keep last version"); + else + Put_Line ("use -w to overwrite files and keep last version"); + end if; + end if; + + return Duplicates; + end Report_Duplicate_Units; + + -------------------- + -- Scan_Arguments -- + -------------------- + + function Scan_Arguments return Boolean is + Kset : Boolean := False; + -- Set true if -k switch found + + begin + Initialize_Option_Scan; + + -- Scan options first + + loop + case Getopt ("c gnat? h k? p q r v w x -GCC=!") is + when ASCII.NUL => + exit; + + when '-' => + Gcc := new String'(Parameter); + Gcc_Set := True; + + when 'c' => + Compilation_Mode := True; + + when 'g' => + Gnat_Args := + new Argument_List'(Gnat_Args.all & + new String'("-gnat" & Parameter)); + + when 'h' => + Usage; + raise Types.Terminate_Program; + + when 'k' => + declare + Param : String_Access := new String'(Parameter); + + begin + if Param.all /= "" then + for J in Param'Range loop + if Param (J) not in '0' .. '9' then + if Hostparm.OpenVMS then + Error_Msg ("/FILE_NAME_MAX_LENGTH=nnn" & + " requires numeric parameter"); + else + Error_Msg ("-k# requires numeric parameter"); + end if; + + return False; + end if; + end loop; + + else + if Hostparm.OpenVMS then + Param := new String'("39"); + else + Param := new String'("8"); + end if; + end if; + + Gnat_Args := + new Argument_List'(Gnat_Args.all & + new String'("-gnatk" & Param.all)); + Kset := True; + end; + + when 'p' => + Preserve_Mode := True; + + when 'q' => + Quiet_Mode := True; + + when 'r' => + Source_References := True; + + when 'v' => + Verbose_Mode := True; + Display_Version ("GNATCHOP", "1998"); + + when 'w' => + Overwrite_Files := True; + + when 'x' => + Exit_On_Error := True; + + when others => + null; + end case; + end loop; + + if not Kset and then Maximum_File_Name_Length > 0 then + + -- If this system has restricted filename lengths, tell gnat1 + -- about them, removing the leading blank from the image string. + + Gnat_Args := + new Argument_List'(Gnat_Args.all + & new String'("-gnatk" + & Maximum_File_Name_Length_String + (Maximum_File_Name_Length_String'First + 1 + .. Maximum_File_Name_Length_String'Last))); + end if; + + -- Scan file names + + loop + declare + S : constant String := Get_Argument (Do_Expansion => True); + + begin + exit when S = ""; + File.Increment_Last; + File.Table (File.Last).Name := new String'(S); + File.Table (File.Last).SR_Name := null; + end; + end loop; + + -- Case of more than one file where last file is a directory + + if File.Last > 1 + and then Is_Directory (File.Table (File.Last).Name.all) + then + Directory := File.Table (File.Last).Name; + File.Decrement_Last; + + -- Make sure Directory is terminated with a directory separator, + -- so we can generate the output by just appending a filename. + + if Directory (Directory'Last) /= Directory_Separator + and then Directory (Directory'Last) /= '/' + then + Directory := new String'(Directory.all & Directory_Separator); + end if; + + -- At least one filename must be given + + elsif File.Last = 0 then + Usage; + return False; + + -- No directory given, set directory to null, so that we can just + -- concatenate the directory name to the file name unconditionally. + + else + Directory := new String'(""); + end if; + + -- Finally check all filename arguments + + for File_Num in 1 .. File.Last loop + declare + F : constant String := File.Table (File_Num).Name.all; + + begin + if Is_Directory (F) then + Error_Msg (F & " is a directory, cannot be chopped"); + return False; + + elsif not Is_Regular_File (F) then + Error_Msg (F & " not found"); + return False; + end if; + end; + end loop; + + return True; + + exception + when Invalid_Switch => + Error_Msg ("invalid switch " & Full_Switch); + return False; + + when Invalid_Parameter => + if Hostparm.OpenVMS then + Error_Msg ("/FILE_NAME_MAX_LENGTH=nnn qualifier" & + " requires numeric parameter"); + else + Error_Msg ("-k switch requires numeric parameter"); + end if; + + return False; + end Scan_Arguments; + + ---------------- + -- Sort_Units -- + ---------------- + + procedure Sort_Units is + + procedure Move (From : Natural; To : Natural); + -- Procedure used to sort the unit list + -- Unit.Table (To) := Unit_List (From); used by sort + + function Lt (Left, Right : Natural) return Boolean; + -- Compares Left and Right units based on file name (first), + -- Chop_File (second) and Offset (third). This ordering is + -- important to keep the last version in case of duplicate files. + + package Unit_Sort is new GNAT.Heap_Sort_G (Move, Lt); + -- Used for sorting on filename to detect duplicates + + -------- + -- Lt -- + -------- + + function Lt (Left, Right : Natural) return Boolean is + L : Unit_Info renames + Unit.Table (Sorted_Units.Table (SUnit_Num (Left))); + + R : Unit_Info renames + Unit.Table (Sorted_Units.Table (SUnit_Num (Right))); + + begin + return L.File_Name.all < R.File_Name.all + or else (L.File_Name.all = R.File_Name.all + and then (L.Chop_File < R.Chop_File + or else (L.Chop_File = R.Chop_File + and then L.Offset < R.Offset))); + end Lt; + + ---------- + -- Move -- + ---------- + + procedure Move (From : Natural; To : Natural) is + begin + Sorted_Units.Table (SUnit_Num (To)) := + Sorted_Units.Table (SUnit_Num (From)); + end Move; + + -- Start of processing for Sort_Units + + begin + Sorted_Units.Set_Last (SUnit_Num (Unit.Last)); + + for J in 1 .. Unit.Last loop + Sorted_Units.Table (SUnit_Num (J)) := J; + end loop; + + -- Sort Unit.Table, using Sorted_Units.Table (0) as scratch + + Unit_Sort.Sort (Natural (Unit.Last)); + + -- Set the Sorted_Index fields in the unit tables + + for J in 1 .. SUnit_Num (Unit.Last) loop + Unit.Table (Sorted_Units.Table (J)).Sorted_Index := J; + end loop; + end Sort_Units; + + ----------- + -- Usage -- + ----------- + + procedure Usage is + begin + Put_Line + ("Usage: gnatchop [-c] [-h] [-k#] " & + "[-r] [-p] [-q] [-v] [-w] [-x] [--GCC=xx] file [file ...] [dir]"); + + New_Line; + Put_Line + (" -c compilation mode, configuration pragmas " & + "follow RM rules"); + + Put_Line + (" -gnatxxx passes the -gnatxxx switch to gnat parser"); + + Put_Line + (" -h help: output this usage information"); + + Put_Line + (" -k# krunch file names of generated files to " & + "no more than # characters"); + + Put_Line + (" -k krunch file names of generated files to " & + "no more than 8 characters"); + + Put_Line + (" -p preserve time stamp, output files will " & + "have same stamp as input"); + + Put_Line + (" -q quiet mode, no output of generated file " & + "names"); + + Put_Line + (" -r generate Source_Reference pragmas refer" & + "encing original source file"); + + Put_Line + (" -v verbose mode, output version and generat" & + "ed commands"); + + Put_Line + (" -w overwrite existing filenames"); + + Put_Line + (" -x exit on error"); + + Put_Line + (" --GCC=xx specify the path of the gnat parser to be used"); + + New_Line; + Put_Line + (" file... list of source files to be chopped"); + + Put_Line + (" dir directory location for split files (defa" & + "ult = current directory)"); + end Usage; + + ----------------- + -- Warning_Msg -- + ----------------- + + procedure Warning_Msg (Message : String) is + begin + Warning_Count := Warning_Count + 1; + Put_Line (Standard_Error, "warning: " & Message); + end Warning_Msg; + + ------------------------- + -- Write_Chopped_Files -- + ------------------------- + + function Write_Chopped_Files (Input : File_Num) return Boolean is + Name : aliased constant String := + File.Table (Input).Name.all & ASCII.NUL; + FD : File_Descriptor; + Buffer : String_Access; + Success : Boolean; + TS_Time : OS_Time; + + BOM_Present : Boolean; + BOM : BOM_Kind; + -- Record presence of UTF8 BOM in input + + begin + FD := Open_Read (Name'Address, Binary); + TS_Time := File_Time_Stamp (FD); + + if FD = Invalid_FD then + Error_Msg ("cannot open " & File.Table (Input).Name.all); + return False; + end if; + + Read_File (FD, Buffer, Success); + + if not Success then + Error_Msg ("cannot read " & File.Table (Input).Name.all); + Close (FD); + return False; + end if; + + if not Quiet_Mode then + Put_Line ("splitting " & File.Table (Input).Name.all & " into:"); + end if; + + -- Test for presence of BOM + + Read_BOM (Buffer.all, BOM_Length, BOM, False); + BOM_Present := BOM /= Unknown; + + -- Only chop those units that come from this file + + for Unit_Number in 1 .. Unit.Last loop + if Unit.Table (Unit_Number).Chop_File = Input then + Write_Unit + (Source => Buffer, + Num => Unit_Number, + TS_Time => TS_Time, + Write_BOM => BOM_Present and then Unit_Number /= 1, + Success => Success); + exit when not Success; + end if; + end loop; + + Close (FD); + return Success; + end Write_Chopped_Files; + + ----------------------- + -- Write_Config_File -- + ----------------------- + + procedure Write_Config_File (Input : File_Num; U : Unit_Num) is + FD : File_Descriptor; + Name : aliased constant String := "gnat.adc" & ASCII.NUL; + Buffer : String_Access; + Success : Boolean; + Append : Boolean; + Buffera : String_Access; + Bufferl : Natural; + + begin + Write_gnat_adc := True; + FD := Open_Read_Write (Name'Address, Binary); + + if FD = Invalid_FD then + FD := Create_File (Name'Address, Binary); + Append := False; + + if not Quiet_Mode then + Put_Line ("writing configuration pragmas from " & + File.Table (Input).Name.all & " to gnat.adc"); + end if; + + else + Append := True; + + if not Quiet_Mode then + Put_Line + ("appending configuration pragmas from " & + File.Table (Input).Name.all & " to gnat.adc"); + end if; + end if; + + Success := FD /= Invalid_FD; + + if not Success then + Error_Msg ("cannot create gnat.adc"); + return; + end if; + + -- In append mode, acquire existing gnat.adc file + + if Append then + Read_File (FD, Buffera, Success); + + if not Success then + Error_Msg ("cannot read gnat.adc"); + return; + end if; + + -- Find location of EOF byte if any to exclude from append + + Bufferl := 1; + while Bufferl <= Buffera'Last + and then Buffera (Bufferl) /= EOF + loop + Bufferl := Bufferl + 1; + end loop; + + Bufferl := Bufferl - 1; + Close (FD); + + -- Write existing gnat.adc to new gnat.adc file + + FD := Create_File (Name'Address, Binary); + Success := Write (FD, Buffera (1)'Address, Bufferl) = Bufferl; + + if not Success then + Error_Msg ("error writing gnat.adc"); + return; + end if; + end if; + + Buffer := Get_Config_Pragmas (Input, U); + + if Buffer /= null then + Success := Write (FD, Buffer.all'Address, Buffer'Length) = + Buffer'Length; + + if not Success then + Error_Msg ("disk full writing gnat.adc"); + return; + end if; + end if; + + Close (FD); + end Write_Config_File; + + ----------------------------------- + -- Write_Source_Reference_Pragma -- + ----------------------------------- + + procedure Write_Source_Reference_Pragma + (Info : Unit_Info; + Line : Line_Num; + File : Stream_IO.File_Type; + EOL : EOL_String; + Success : in out Boolean) + is + FTE : File_Entry renames Gnatchop.File.Table (Info.Chop_File); + Nam : String_Access; + + begin + if Success and then Source_References and then not Info.SR_Present then + if FTE.SR_Name /= null then + Nam := FTE.SR_Name; + else + Nam := FTE.Name; + end if; + + declare + Reference : String := + "pragma Source_Reference (000000, """ + & Nam.all & """);" & EOL.Str; + + Pos : Positive := Reference'First; + Lin : Line_Num := Line; + + begin + while Reference (Pos + 1) /= ',' loop + Pos := Pos + 1; + end loop; + + while Reference (Pos) = '0' loop + Reference (Pos) := Character'Val + (Character'Pos ('0') + Lin mod 10); + Lin := Lin / 10; + Pos := Pos - 1; + end loop; + + -- Assume there are enough zeroes for any program length + + pragma Assert (Lin = 0); + + begin + String'Write (Stream_IO.Stream (File), Reference); + Success := True; + exception + when others => + Success := False; + end; + end; + end if; + end Write_Source_Reference_Pragma; + + ---------------- + -- Write_Unit -- + ---------------- + + procedure Write_Unit + (Source : not null access String; + Num : Unit_Num; + TS_Time : OS_Time; + Write_BOM : Boolean; + Success : out Boolean) + is + + procedure OS_Filename + (Name : String; + W_Name : Wide_String; + OS_Name : Address; + N_Length : access Natural; + Encoding : Address; + E_Length : access Natural); + pragma Import (C, OS_Filename, "__gnat_os_filename"); + -- Returns in OS_Name the proper name for the OS when used with the + -- returned Encoding value. For example on Windows this will return the + -- UTF-8 encoded name into OS_Name and set Encoding to encoding=utf8 + -- (the form parameter for Stream_IO). + -- + -- Name is the filename and W_Name the same filename in Unicode 16 bits + -- (this corresponds to Win32 Unicode ISO/IEC 10646). N_Length/E_Length + -- are the length returned in OS_Name/Encoding respectively. + + Info : Unit_Info renames Unit.Table (Num); + Name : aliased constant String := Info.File_Name.all & ASCII.NUL; + W_Name : aliased constant Wide_String := To_Wide_String (Name); + EOL : constant EOL_String := + Get_EOL (Source, Source'First + Info.Offset); + OS_Name : aliased String (1 .. Name'Length * 2); + O_Length : aliased Natural := OS_Name'Length; + Encoding : aliased String (1 .. 64); + E_Length : aliased Natural := Encoding'Length; + Length : File_Offset; + + begin + -- Skip duplicated files + + if Is_Duplicated (Info.Sorted_Index) then + Put_Line (" " & Info.File_Name.all & " skipped"); + Success := Overwrite_Files; + return; + end if; + + -- Get OS filename + + OS_Filename + (Name, W_Name, + OS_Name'Address, O_Length'Access, + Encoding'Address, E_Length'Access); + + declare + E_Name : constant String := OS_Name (1 .. O_Length); + C_Name : aliased constant String := E_Name & ASCII.NUL; + OS_Encoding : constant String := Encoding (1 .. E_Length); + File : Stream_IO.File_Type; + + begin + begin + if not Overwrite_Files and then Exists (E_Name) then + raise Stream_IO.Name_Error; + else + Stream_IO.Create + (File, Stream_IO.Out_File, E_Name, OS_Encoding); + Success := True; + end if; + + exception + when Stream_IO.Name_Error | Stream_IO.Use_Error => + Error_Msg ("cannot create " & Info.File_Name.all); + return; + end; + + -- A length of 0 indicates that the rest of the file belongs to + -- this unit. The actual length must be calculated now. Take into + -- account that the last character (EOF) must not be written. + + if Info.Length = 0 then + Length := Source'Last - (Source'First + Info.Offset); + else + Length := Info.Length; + end if; + + -- Write BOM if required + + if Write_BOM then + String'Write + (Stream_IO.Stream (File), + Source.all (Source'First .. Source'First + BOM_Length - 1)); + end if; + + -- Prepend configuration pragmas if necessary + + if Success and then Info.Bufferg /= null then + Write_Source_Reference_Pragma (Info, 1, File, EOL, Success); + String'Write (Stream_IO.Stream (File), Info.Bufferg.all); + end if; + + Write_Source_Reference_Pragma + (Info, Info.Start_Line, File, EOL, Success); + + if Success then + begin + String'Write + (Stream_IO.Stream (File), + Source (Source'First + Info.Offset .. + Source'First + Info.Offset + Length - 1)); + exception + when Stream_IO.Use_Error | Stream_IO.Device_Error => + Error_Msg ("disk full writing " & Info.File_Name.all); + return; + end; + end if; + + if not Quiet_Mode then + Put_Line (" " & Info.File_Name.all); + end if; + + Stream_IO.Close (File); + + if Preserve_Mode then + File_Time_Stamp (C_Name'Address, TS_Time); + end if; + end; + end Write_Unit; + + procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); + +-- Start of processing for gnatchop + +begin + -- Add the directory where gnatchop is invoked in front of the path, if + -- gnatchop is invoked with directory information. Only do this if the + -- platform is not VMS, where the notion of path does not really exist. + + if not Hostparm.OpenVMS then + declare + Command : constant String := Command_Name; + + begin + for Index in reverse Command'Range loop + if Command (Index) = Directory_Separator then + declare + Absolute_Dir : constant String := + Normalize_Pathname + (Command (Command'First .. Index)); + PATH : constant String := + Absolute_Dir + & Path_Separator + & Getenv ("PATH").all; + begin + Setenv ("PATH", PATH); + end; + + exit; + end if; + end loop; + end; + end if; + + -- Process command line options and initialize global variables + + -- First, scan to detect --version and/or --help + + Check_Version_And_Help ("GNATCHOP", "1998"); + + if not Scan_Arguments then + Set_Exit_Status (Failure); + return; + end if; + + -- Check presence of required executables + + Gnat_Cmd := Locate_Executable (Gcc.all, not Gcc_Set); + + if Gnat_Cmd = null then + goto No_Files_Written; + end if; + + -- First parse all files and read offset information + + for Num in 1 .. File.Last loop + if not Parse_File (Num) then + goto No_Files_Written; + end if; + end loop; + + -- Check if any units have been found (assumes non-empty Unit.Table) + + if Unit.Last = 0 then + if not Write_gnat_adc then + Error_Msg ("no compilation units found", Warning => True); + end if; + + goto No_Files_Written; + end if; + + Sort_Units; + + -- Check if any duplicate files would be created. If so, emit a warning if + -- Overwrite_Files is true, otherwise generate an error. + + if Report_Duplicate_Units and then not Overwrite_Files then + goto No_Files_Written; + end if; + + -- Check if any files exist, if so do not write anything Because all files + -- have been parsed and checked already, there won't be any duplicates + + if not Overwrite_Files and then Files_Exist then + goto No_Files_Written; + end if; + + -- After this point, all source files are read in succession and chopped + -- into their destination files. + + -- Source_File_Name pragmas are handled as logical file 0 so write it first + + for F in 1 .. File.Last loop + if not Write_Chopped_Files (F) then + Set_Exit_Status (Failure); + return; + end if; + end loop; + + if Warning_Count > 0 then + declare + Warnings_Msg : constant String := Warning_Count'Img & " warning(s)"; + begin + Error_Msg (Warnings_Msg (2 .. Warnings_Msg'Last), Warning => True); + end; + end if; + + return; + +<> + + -- Special error exit for all situations where no files have + -- been written. + + if not Write_gnat_adc then + Error_Msg ("no source files written", Warning => True); + end if; + + return; + +exception + when Types.Terminate_Program => + null; + +end Gnatchop; diff --git a/gcc/ada/gnatclean.adb b/gcc/ada/gnatclean.adb new file mode 100644 index 000000000..2a2ac75bc --- /dev/null +++ b/gcc/ada/gnatclean.adb @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T C L E A N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Gnatclean is a utility to delete files produced by the GNAT tools: +-- ALI files, object files, tree files, expanded source files, library +-- files, interface copy files, binder generated files and executable files. + +-- Gnatclean may be invoked for one or several executables, for a project +-- file or a tree of project files with the optional specification of +-- one of several executables. + +with Clean; + +procedure Gnatclean is +begin + -- The real work is done in Package Clean + + Clean.Gnatclean; +end Gnatclean; diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb new file mode 100644 index 000000000..cdd159a24 --- /dev/null +++ b/gcc/ada/gnatcmd.adb @@ -0,0 +1,2646 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T C M D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1996-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.Directory_Operations; use GNAT.Directory_Operations; + +with Csets; +with Hostparm; use Hostparm; +with Makeutl; use Makeutl; +with MLib.Tgt; use MLib.Tgt; +with MLib.Utl; +with MLib.Fil; +with Namet; use Namet; +with Opt; use Opt; +with Osint; use Osint; +with Output; +with Prj; use Prj; +with Prj.Env; +with Prj.Ext; use Prj.Ext; +with Prj.Pars; +with Prj.Tree; use Prj.Tree; +with Prj.Util; use Prj.Util; +with Sinput.P; +with Snames; use Snames; +with Table; +with Targparm; +with Tempdir; +with Types; use Types; +with VMS_Conv; use VMS_Conv; +with VMS_Cmds; use VMS_Cmds; + +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.OS_Lib; use GNAT.OS_Lib; + +procedure GNATCmd is + Project_Node_Tree : Project_Node_Tree_Ref; + Project_File : String_Access; + Project : Prj.Project_Id; + Current_Verbosity : Prj.Verbosity := Prj.Default; + Tool_Package_Name : Name_Id := No_Name; + + B_Start : String_Ptr := new String'("b~"); + -- Prefix of binder generated file, changed to b__ for VMS + + Old_Project_File_Used : Boolean := False; + -- This flag indicates a switch -p (for gnatxref and gnatfind) for + -- an old fashioned project file. -p cannot be used in conjunction + -- with -P. + + Temp_File_Name : Path_Name_Type := No_Path; + -- The name of the temporary text file to put a list of source/object + -- files to pass to a tool. + + ASIS_Main : String_Access := null; + -- Main for commands Check, Metric and Pretty, when -U is used + + package First_Switches is new Table.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Gnatcmd.First_Switches"); + -- A table to keep the switches from the project file + + package Carg_Switches is new Table.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Gnatcmd.Carg_Switches"); + -- A table to keep the switches following -cargs for ASIS tools + + package Rules_Switches is new Table.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Gnatcmd.Rules_Switches"); + -- A table to keep the switches following -rules for gnatcheck + + package Library_Paths is new Table.Table ( + Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Make.Library_Path"); + + -- Packages of project files to pass to Prj.Pars.Parse, depending on the + -- tool. We allocate objects because we cannot declare aliased objects + -- as we are in a procedure, not a library level package. + + subtype SA is String_Access; + + Naming_String : constant SA := new String'("naming"); + Binder_String : constant SA := new String'("binder"); + Builder_String : constant SA := new String'("builder"); + Compiler_String : constant SA := new String'("compiler"); + Check_String : constant SA := new String'("check"); + Synchronize_String : constant SA := new String'("synchronize"); + Eliminate_String : constant SA := new String'("eliminate"); + Finder_String : constant SA := new String'("finder"); + Linker_String : constant SA := new String'("linker"); + Gnatls_String : constant SA := new String'("gnatls"); + Pretty_String : constant SA := new String'("pretty_printer"); + Stack_String : constant SA := new String'("stack"); + Gnatstub_String : constant SA := new String'("gnatstub"); + Metric_String : constant SA := new String'("metrics"); + Xref_String : constant SA := new String'("cross_reference"); + + Packages_To_Check_By_Binder : constant String_List_Access := + new String_List'((Naming_String, Binder_String)); + + Packages_To_Check_By_Check : constant String_List_Access := + new String_List' + ((Naming_String, Builder_String, Check_String, Compiler_String)); + + Packages_To_Check_By_Sync : constant String_List_Access := + new String_List'((Naming_String, Synchronize_String, Compiler_String)); + + Packages_To_Check_By_Eliminate : constant String_List_Access := + new String_List'((Naming_String, Eliminate_String, Compiler_String)); + + Packages_To_Check_By_Finder : constant String_List_Access := + new String_List'((Naming_String, Finder_String)); + + Packages_To_Check_By_Linker : constant String_List_Access := + new String_List'((Naming_String, Linker_String)); + + Packages_To_Check_By_Gnatls : constant String_List_Access := + new String_List'((Naming_String, Gnatls_String)); + + Packages_To_Check_By_Pretty : constant String_List_Access := + new String_List'((Naming_String, Pretty_String, Compiler_String)); + + Packages_To_Check_By_Stack : constant String_List_Access := + new String_List'((Naming_String, Stack_String)); + + Packages_To_Check_By_Gnatstub : constant String_List_Access := + new String_List'((Naming_String, Gnatstub_String, Compiler_String)); + + Packages_To_Check_By_Metric : constant String_List_Access := + new String_List'((Naming_String, Metric_String, Compiler_String)); + + Packages_To_Check_By_Xref : constant String_List_Access := + new String_List'((Naming_String, Xref_String)); + + Packages_To_Check : String_List_Access := Prj.All_Packages; + + ---------------------------------- + -- Declarations for GNATCMD use -- + ---------------------------------- + + The_Command : Command_Type; + -- The command specified in the invocation of the GNAT driver + + Command_Arg : Positive := 1; + -- The index of the command in the arguments of the GNAT driver + + My_Exit_Status : Exit_Status := Success; + -- The exit status of the spawned tool. Used to set the correct VMS + -- exit status. + + Current_Work_Dir : constant String := Get_Current_Dir; + -- The path of the working directory + + All_Projects : Boolean := False; + -- Flag used for GNAT CHECK, GNAT PRETTY, GNAT METRIC, and GNAT STACK to + -- indicate that the underlying tool (gnatcheck, gnatpp or gnatmetric) + -- should be invoked for all sources of all projects. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Add_To_Carg_Switches (Switch : String_Access); + -- Add a switch to the Carg_Switches table. If it is the first one, put the + -- switch "-cargs" at the beginning of the table. + + procedure Add_To_Rules_Switches (Switch : String_Access); + -- Add a switch to the Rules_Switches table. If it is the first one, put + -- the switch "-crules" at the beginning of the table. + + procedure Check_Files; + -- For GNAT LIST, GNAT PRETTY, GNAT METRIC, and GNAT STACK, check if a + -- project file is specified, without any file arguments and without a + -- switch -files=. If it is the case, invoke the GNAT tool with the proper + -- list of files, derived from the sources of the project. + + function Check_Project + (Project : Project_Id; + Root_Project : Project_Id) return Boolean; + -- Returns True if Project = Root_Project or if we want to consider all + -- sources of all projects. For GNAT METRIC, also returns True if Project + -- is extended by Root_Project. + + procedure Check_Relative_Executable (Name : in out String_Access); + -- Check if an executable is specified as a relative path. If it is, and + -- the path contains directory information, fail. Otherwise, prepend the + -- exec directory. This procedure is only used for GNAT LINK when a project + -- file is specified. + + function Configuration_Pragmas_File return Path_Name_Type; + -- Return an argument, if there is a configuration pragmas file to be + -- specified for Project, otherwise return No_Name. Used for gnatstub (GNAT + -- STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric (GNAT + -- METRIC). + + function Mapping_File return Path_Name_Type; + -- Create and return the path name of a mapping file. Used for gnatstub + -- (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric + -- (GNAT METRIC). + + procedure Delete_Temp_Config_Files; + -- Delete all temporary config files. The caller is responsible for + -- ensuring that Keep_Temporary_Files is False. + + procedure Get_Closure; + -- Get the sources in the closure of the ASIS_Main and add them to the + -- list of arguments. + + function Index (Char : Character; Str : String) return Natural; + -- Returns first occurrence of Char in Str, returns 0 if Char not in Str + + procedure Non_VMS_Usage; + -- Display usage for platforms other than VMS + + procedure Process_Link; + -- Process GNAT LINK, when there is a project file specified + + procedure Set_Library_For + (Project : Project_Id; + Libraries_Present : in out Boolean); + -- If Project is a library project, add the correct -L and -l switches to + -- the linker invocation. + + procedure Set_Libraries is + new For_Every_Project_Imported (Boolean, Set_Library_For); + -- Add the -L and -l switches to the linker for all of the library + -- projects. + + procedure Test_If_Relative_Path + (Switch : in out String_Access; + Parent : String); + -- Test if Switch is a relative search path switch. If it is and it + -- includes directory information, prepend the path with Parent. This + -- subprogram is only called when using project files. + + -------------------------- + -- Add_To_Carg_Switches -- + -------------------------- + + procedure Add_To_Carg_Switches (Switch : String_Access) is + begin + -- If the Carg_Switches table is empty, put "-cargs" at the beginning + + if Carg_Switches.Last = 0 then + Carg_Switches.Increment_Last; + Carg_Switches.Table (Carg_Switches.Last) := new String'("-cargs"); + end if; + + Carg_Switches.Increment_Last; + Carg_Switches.Table (Carg_Switches.Last) := Switch; + end Add_To_Carg_Switches; + + --------------------------- + -- Add_To_Rules_Switches -- + --------------------------- + + procedure Add_To_Rules_Switches (Switch : String_Access) is + begin + -- If the Rules_Switches table is empty, put "-rules" at the beginning + + if Rules_Switches.Last = 0 then + Rules_Switches.Increment_Last; + Rules_Switches.Table (Rules_Switches.Last) := new String'("-rules"); + end if; + + Rules_Switches.Increment_Last; + Rules_Switches.Table (Rules_Switches.Last) := Switch; + end Add_To_Rules_Switches; + + ----------------- + -- Check_Files -- + ----------------- + + procedure Check_Files is + Add_Sources : Boolean := True; + Unit : Prj.Unit_Index; + Subunit : Boolean := False; + FD : File_Descriptor := Invalid_FD; + Status : Integer; + Success : Boolean; + + procedure Add_To_Response_File + (File_Name : String; + Check_File : Boolean := True); + -- Include the file name passed as parameter in the response file for + -- the tool being called. If the response file can not be written then + -- the file name is passed in the parameter list of the tool. If the + -- Check_File parameter is True then the procedure verifies the + -- existence of the file before adding it to the response file. + + -------------------------- + -- Add_To_Response_File -- + -------------------------- + + procedure Add_To_Response_File + (File_Name : String; + Check_File : Boolean := True) + is + begin + Name_Len := 0; + + Add_Str_To_Name_Buffer (File_Name); + + if not Check_File or else + Is_Regular_File (Name_Buffer (1 .. Name_Len)) + then + if FD /= Invalid_FD then + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ASCII.LF; + + Status := Write (FD, Name_Buffer (1)'Address, Name_Len); + + if Status /= Name_Len then + Osint.Fail ("disk full"); + end if; + else + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'(File_Name); + end if; + end if; + end Add_To_Response_File; + + -- Start of processing for Check_Files + + begin + -- Check if there is at least one argument that is not a switch or if + -- there is a -files= switch. + + for Index in 1 .. Last_Switches.Last loop + if Last_Switches.Table (Index).all'Length > 7 + and then Last_Switches.Table (Index) (1 .. 7) = "-files=" + then + Add_Sources := False; + exit; + + elsif Last_Switches.Table (Index) (1) /= '-' then + if Index = 1 + or else + (The_Command = Check + and then Last_Switches.Table (Index - 1).all /= "-o") + or else + (The_Command = Pretty + and then Last_Switches.Table (Index - 1).all /= "-o" + and then Last_Switches.Table (Index - 1).all /= "-of") + or else + (The_Command = Metric + and then + Last_Switches.Table (Index - 1).all /= "-o" and then + Last_Switches.Table (Index - 1).all /= "-og" and then + Last_Switches.Table (Index - 1).all /= "-ox" and then + Last_Switches.Table (Index - 1).all /= "-d") + or else + (The_Command /= Check and then + The_Command /= Pretty and then + The_Command /= Metric) + then + Add_Sources := False; + exit; + end if; + end if; + end loop; + + -- If all arguments are switches and there is no switch -files=, add + -- the path names of all the sources of the main project. + + if Add_Sources then + + -- For gnatcheck, gnatpp, and gnatmetric, create a temporary file + -- and put the list of sources in it. For gnatstack create a + -- temporary file with the list of .ci files. + + if The_Command = Check or else + The_Command = Pretty or else + The_Command = Metric or else + The_Command = Stack + then + Tempdir.Create_Temp_File (FD, Temp_File_Name); + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-files=" & Get_Name_String (Temp_File_Name)); + end if; + + declare + Proj : Project_List; + + begin + -- Gnatstack needs to add the .ci file for the binder generated + -- files corresponding to all of the library projects and main + -- units belonging to the application. + + if The_Command = Stack then + Proj := Project_Tree.Projects; + while Proj /= null loop + if Check_Project (Proj.Project, Project) then + declare + Main : String_List_Id; + + begin + -- Include binder generated files for main programs + + Main := Proj.Project.Mains; + while Main /= Nil_String loop + Add_To_Response_File + (Get_Name_String + (Proj.Project.Object_Directory.Name) & + B_Start.all & + MLib.Fil.Ext_To + (Get_Name_String + (Project_Tree.String_Elements.Table + (Main).Value), + "ci")); + + -- When looking for the .ci file for a binder + -- generated file, look for both b~xxx and b__xxx + -- as gprbuild always uses b__ as the prefix of + -- such files. + + if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) + and then B_Start.all /= "b__" + then + Add_To_Response_File + (Get_Name_String + (Proj.Project.Object_Directory.Name) & + "b__" & + MLib.Fil.Ext_To + (Get_Name_String + (Project_Tree.String_Elements.Table + (Main).Value), + "ci")); + end if; + + Main := + Project_Tree.String_Elements.Table (Main).Next; + end loop; + + if Proj.Project.Library then + + -- Include the .ci file for the binder generated + -- files that contains the initialization and + -- finalization of the library. + + Add_To_Response_File + (Get_Name_String + (Proj.Project.Object_Directory.Name) & + B_Start.all & + Get_Name_String (Proj.Project.Library_Name) & + ".ci"); + + -- When looking for the .ci file for a binder + -- generated file, look for both b~xxx and b__xxx + -- as gprbuild always uses b__ as the prefix of + -- such files. + + if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) + and then B_Start.all /= "b__" + then + Add_To_Response_File + (Get_Name_String + (Proj.Project.Object_Directory.Name) & + "b__" & + Get_Name_String (Proj.Project.Library_Name) & + ".ci"); + end if; + end if; + end; + end if; + + Proj := Proj.Next; + end loop; + end if; + + Unit := Units_Htable.Get_First (Project_Tree.Units_HT); + while Unit /= No_Unit_Index loop + + -- For gnatls, we only need to put the library units, body or + -- spec, but not the subunits. + + if The_Command = List then + if Unit.File_Names (Impl) /= null + and then not Unit.File_Names (Impl).Locally_Removed + then + -- There is a body, check if it is for this project + + if All_Projects + or else Unit.File_Names (Impl).Project = Project + then + Subunit := False; + + if Unit.File_Names (Spec) = null + or else Unit.File_Names (Spec).Locally_Removed + then + -- We have a body with no spec: we need to check if + -- this is a subunit, because gnatls will complain + -- about subunits. + + declare + Src_Ind : constant Source_File_Index := + Sinput.P.Load_Project_File + (Get_Name_String + (Unit.File_Names + (Impl).Path.Name)); + begin + Subunit := + Sinput.P.Source_File_Is_Subunit (Src_Ind); + end; + end if; + + if not Subunit then + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String' + (Get_Name_String + (Unit.File_Names + (Impl).Display_File)); + end if; + end if; + + elsif Unit.File_Names (Spec) /= null + and then not Unit.File_Names (Spec).Locally_Removed + then + -- We have a spec with no body. Check if it is for this + -- project. + + if All_Projects or else + Unit.File_Names (Spec).Project = Project + then + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'(Get_Name_String + (Unit.File_Names (Spec).Display_File)); + end if; + end if; + + -- For gnatstack, we put the .ci files corresponding to the + -- different units, including the binder generated files. We + -- only need to do that for the library units, body or spec, + -- but not the subunits. + + elsif The_Command = Stack then + if Unit.File_Names (Impl) /= null + and then not Unit.File_Names (Impl).Locally_Removed + then + -- There is a body. Check if .ci files for this project + -- must be added. + + if Check_Project + (Unit.File_Names (Impl).Project, Project) + then + Subunit := False; + + if Unit.File_Names (Spec) = null + or else Unit.File_Names (Spec).Locally_Removed + then + -- We have a body with no spec: we need to check + -- if this is a subunit, because .ci files are not + -- generated for subunits. + + declare + Src_Ind : constant Source_File_Index := + Sinput.P.Load_Project_File + (Get_Name_String + (Unit.File_Names + (Impl).Path.Name)); + begin + Subunit := + Sinput.P.Source_File_Is_Subunit (Src_Ind); + end; + end if; + + if not Subunit then + Add_To_Response_File + (Get_Name_String + (Unit.File_Names + (Impl).Project. Object_Directory.Name) & + MLib.Fil.Ext_To + (Get_Name_String + (Unit.File_Names (Impl).Display_File), + "ci")); + end if; + end if; + + elsif Unit.File_Names (Spec) /= null + and then not Unit.File_Names (Spec).Locally_Removed + then + -- Spec with no body, check if it is for this project + + if Check_Project + (Unit.File_Names (Spec).Project, Project) + then + Add_To_Response_File + (Get_Name_String + (Unit.File_Names + (Spec).Project. Object_Directory.Name) & + Dir_Separator & + MLib.Fil.Ext_To + (Get_Name_String (Unit.File_Names (Spec).File), + "ci")); + end if; + end if; + + else + -- For gnatcheck, gnatsync, gnatpp and gnatmetric, put all + -- sources of the project, or of all projects if -U was + -- specified. + + for Kind in Spec_Or_Body loop + if Unit.File_Names (Kind) /= null + and then Check_Project + (Unit.File_Names (Kind).Project, Project) + and then not Unit.File_Names (Kind).Locally_Removed + then + Add_To_Response_File + ("""" & + Get_Name_String + (Unit.File_Names (Kind).Path.Display_Name) & + """", + Check_File => False); + end if; + end loop; + end if; + + Unit := Units_Htable.Get_Next (Project_Tree.Units_HT); + end loop; + end; + + if FD /= Invalid_FD then + Close (FD, Success); + + if not Success then + Osint.Fail ("disk full"); + end if; + end if; + end if; + end Check_Files; + + ------------------- + -- Check_Project -- + ------------------- + + function Check_Project + (Project : Project_Id; + Root_Project : Project_Id) return Boolean + is + Proj : Project_Id; + + begin + if Project = No_Project then + return False; + + elsif All_Projects or else Project = Root_Project then + return True; + + elsif The_Command = Metric then + Proj := Root_Project; + while Proj.Extends /= No_Project loop + if Project = Proj.Extends then + return True; + end if; + + Proj := Proj.Extends; + end loop; + end if; + + return False; + end Check_Project; + + ------------------------------- + -- Check_Relative_Executable -- + ------------------------------- + + procedure Check_Relative_Executable (Name : in out String_Access) is + Exec_File_Name : constant String := Name.all; + + begin + if not Is_Absolute_Path (Exec_File_Name) then + for Index in Exec_File_Name'Range loop + if Exec_File_Name (Index) = Directory_Separator then + Fail ("relative executable (""" & + Exec_File_Name & + """) with directory part not allowed " & + "when using project files"); + end if; + end loop; + + Get_Name_String (Project.Exec_Directory.Name); + + if Name_Buffer (Name_Len) /= Directory_Separator then + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Directory_Separator; + end if; + + Name_Buffer (Name_Len + 1 .. + Name_Len + Exec_File_Name'Length) := + Exec_File_Name; + Name_Len := Name_Len + Exec_File_Name'Length; + Name := new String'(Name_Buffer (1 .. Name_Len)); + end if; + end Check_Relative_Executable; + + -------------------------------- + -- Configuration_Pragmas_File -- + -------------------------------- + + function Configuration_Pragmas_File return Path_Name_Type is + begin + Prj.Env.Create_Config_Pragmas_File (Project, Project_Tree); + return Project.Config_File_Name; + end Configuration_Pragmas_File; + + ------------------------------ + -- Delete_Temp_Config_Files -- + ------------------------------ + + procedure Delete_Temp_Config_Files is + Success : Boolean; + Proj : Project_List; + pragma Warnings (Off, Success); + + begin + -- This should only be called if Keep_Temporary_Files is False + + pragma Assert (not Keep_Temporary_Files); + + if Project /= No_Project then + Proj := Project_Tree.Projects; + while Proj /= null loop + if Proj.Project.Config_File_Temp then + Delete_Temporary_File + (Project_Tree, Proj.Project.Config_File_Name); + end if; + + Proj := Proj.Next; + end loop; + end if; + + -- If a temporary text file that contains a list of files for a tool + -- has been created, delete this temporary file. + + if Temp_File_Name /= No_Path then + Delete_Temporary_File (Project_Tree, Temp_File_Name); + end if; + end Delete_Temp_Config_Files; + + ----------------- + -- Get_Closure -- + ----------------- + + procedure Get_Closure is + Args : constant Argument_List := + (1 => new String'("-q"), + 2 => new String'("-b"), + 3 => new String'("-P"), + 4 => Project_File, + 5 => ASIS_Main, + 6 => new String'("-bargs"), + 7 => new String'("-R"), + 8 => new String'("-Z")); + -- Arguments for the invocation of gnatmake which are added to the + -- Last_Arguments list by this procedure. + + FD : File_Descriptor; + -- File descriptor for the temp file that will get the output of the + -- invocation of gnatmake. + + Name : Path_Name_Type; + -- Path of the file FD + + GN_Name : constant String := Program_Name ("gnatmake", "gnat").all; + -- Name for gnatmake + + GN_Path : constant String_Access := Locate_Exec_On_Path (GN_Name); + -- Path of gnatmake + + Return_Code : Integer; + + Unused : Boolean; + pragma Warnings (Off, Unused); + + File : Ada.Text_IO.File_Type; + Line : String (1 .. 250); + Last : Natural; + -- Used to read file if there is an error, it is good enough to display + -- just 250 characters if the first line of the file is very long. + + Unit : Unit_Index; + Path : Path_Name_Type; + + begin + if GN_Path = null then + Put_Line (Standard_Error, "could not locate " & GN_Name); + raise Error_Exit; + end if; + + -- Create the temp file + + Tempdir.Create_Temp_File (FD, Name); + + -- And close it, because on VMS Spawn with a file descriptor created + -- with Create_Temp_File does not redirect output. + + Close (FD); + + -- Spawn "gnatmake -q -b -P
-bargs -R -Z" + + Spawn + (Program_Name => GN_Path.all, + Args => Args, + Output_File => Get_Name_String (Name), + Success => Unused, + Return_Code => Return_Code, + Err_To_Out => True); + + -- Read the output of the invocation of gnatmake + + Open (File, In_File, Get_Name_String (Name)); + + -- If it was unsuccessful, display the first line in the file and exit + -- with error. + + if Return_Code /= 0 then + Get_Line (File, Line, Last); + + if not Keep_Temporary_Files then + Delete (File); + else + Close (File); + end if; + + Put_Line (Standard_Error, Line (1 .. Last)); + Put_Line + (Standard_Error, "could not get closure of " & ASIS_Main.all); + raise Error_Exit; + + else + -- Get each file name in the file, find its path and add it the + -- list of arguments. + + while not End_Of_File (File) loop + Get_Line (File, Line, Last); + Path := No_Path; + + Unit := Units_Htable.Get_First (Project_Tree.Units_HT); + while Unit /= No_Unit_Index loop + if Unit.File_Names (Spec) /= null + and then + Get_Name_String (Unit.File_Names (Spec).File) = + Line (1 .. Last) + then + Path := Unit.File_Names (Spec).Path.Name; + exit; + + elsif Unit.File_Names (Impl) /= null + and then + Get_Name_String (Unit.File_Names (Impl).File) = + Line (1 .. Last) + then + Path := Unit.File_Names (Impl).Path.Name; + exit; + end if; + + Unit := Units_Htable.Get_Next (Project_Tree.Units_HT); + end loop; + + Last_Switches.Increment_Last; + + if Path /= No_Path then + Last_Switches.Table (Last_Switches.Last) := + new String'(Get_Name_String (Path)); + + else + Last_Switches.Table (Last_Switches.Last) := + new String'(Line (1 .. Last)); + end if; + end loop; + + if not Keep_Temporary_Files then + Delete (File); + else + Close (File); + end if; + end if; + end Get_Closure; + + ----------- + -- Index -- + ----------- + + function Index (Char : Character; Str : String) return Natural is + begin + for Index in Str'Range loop + if Str (Index) = Char then + return Index; + end if; + end loop; + + return 0; + end Index; + + ------------------ + -- Mapping_File -- + ------------------ + + function Mapping_File return Path_Name_Type is + Result : Path_Name_Type; + begin + Prj.Env.Create_Mapping_File + (Project => Project, + Language => Name_Ada, + In_Tree => Project_Tree, + Name => Result); + return Result; + end Mapping_File; + + ------------------ + -- Process_Link -- + ------------------ + + procedure Process_Link is + Look_For_Executable : Boolean := True; + Libraries_Present : Boolean := False; + Path_Option : constant String_Access := + MLib.Linker_Library_Path_Option; + Prj : Project_Id := Project; + Arg : String_Access; + Last : Natural := 0; + Skip_Executable : Boolean := False; + + begin + -- Add the default search directories, to be able to find + -- libgnat in call to MLib.Utl.Lib_Directory. + + Add_Default_Search_Dirs; + + Library_Paths.Set_Last (0); + + -- Check if there are library project files + + if MLib.Tgt.Support_For_Libraries /= None then + Set_Libraries (Project, Libraries_Present); + end if; + + -- If there are, add the necessary additional switches + + if Libraries_Present then + + -- Add -L -lgnarl -lgnat -Wl,-rpath, + + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-L" & MLib.Utl.Lib_Directory); + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-lgnarl"); + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-lgnat"); + + -- If Path_Option is not null, create the switch ("-Wl,-rpath," or + -- equivalent) with all the library dirs plus the standard GNAT + -- library dir. + + if Path_Option /= null then + declare + Option : String_Access; + Length : Natural := Path_Option'Length; + Current : Natural; + + begin + if MLib.Separate_Run_Path_Options then + + -- We are going to create one switch of the form + -- "-Wl,-rpath,dir_N" for each directory to consider. + + -- One switch for each library directory + + for Index in + Library_Paths.First .. Library_Paths.Last + loop + Last_Switches.Increment_Last; + Last_Switches.Table + (Last_Switches.Last) := new String' + (Path_Option.all & + Last_Switches.Table (Index).all); + end loop; + + -- One switch for the standard GNAT library dir + + Last_Switches.Increment_Last; + Last_Switches.Table + (Last_Switches.Last) := new String' + (Path_Option.all & MLib.Utl.Lib_Directory); + + else + -- First, compute the exact length for the switch + + for Index in + Library_Paths.First .. Library_Paths.Last + loop + -- Add the length of the library dir plus one for the + -- directory separator. + + Length := + Length + + Library_Paths.Table (Index)'Length + 1; + end loop; + + -- Finally, add the length of the standard GNAT library dir + + Length := Length + MLib.Utl.Lib_Directory'Length; + Option := new String (1 .. Length); + Option (1 .. Path_Option'Length) := Path_Option.all; + Current := Path_Option'Length; + + -- Put each library dir followed by a dir separator + + for Index in + Library_Paths.First .. Library_Paths.Last + loop + Option + (Current + 1 .. + Current + + Library_Paths.Table (Index)'Length) := + Library_Paths.Table (Index).all; + Current := + Current + + Library_Paths.Table (Index)'Length + 1; + Option (Current) := Path_Separator; + end loop; + + -- Finally put the standard GNAT library dir + + Option + (Current + 1 .. + Current + MLib.Utl.Lib_Directory'Length) := + MLib.Utl.Lib_Directory; + + -- And add the switch to the last switches + + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + Option; + end if; + end; + end if; + end if; + + -- Check if the first ALI file specified can be found, either in the + -- object directory of the main project or in an object directory of a + -- project file extended by the main project. If the ALI file can be + -- found, replace its name with its absolute path. + + Skip_Executable := False; + + Switch_Loop : for J in 1 .. Last_Switches.Last loop + + -- If we have an executable just reset the flag + + if Skip_Executable then + Skip_Executable := False; + + -- If -o, set flag so that next switch is not processed + + elsif Last_Switches.Table (J).all = "-o" then + Skip_Executable := True; + + -- Normal case + + else + declare + Switch : constant String := + Last_Switches.Table (J).all; + ALI_File : constant String (1 .. Switch'Length + 4) := + Switch & ".ali"; + + Test_Existence : Boolean := False; + + begin + Last := Switch'Length; + + -- Skip real switches + + if Switch'Length /= 0 + and then Switch (Switch'First) /= '-' + then + -- Append ".ali" if file name does not end with it + + if Switch'Length <= 4 + or else Switch (Switch'Last - 3 .. Switch'Last) /= ".ali" + then + Last := ALI_File'Last; + end if; + + -- If file name includes directory information, stop if ALI + -- file exists. + + if Is_Absolute_Path (ALI_File (1 .. Last)) then + Test_Existence := True; + + else + for K in Switch'Range loop + if Switch (K) = '/' + or else Switch (K) = Directory_Separator + then + Test_Existence := True; + exit; + end if; + end loop; + end if; + + if Test_Existence then + if Is_Regular_File (ALI_File (1 .. Last)) then + exit Switch_Loop; + end if; + + -- Look in object directories if ALI file exists + + else + Project_Loop : loop + declare + Dir : constant String := + Get_Name_String (Prj.Object_Directory.Name); + begin + if Is_Regular_File + (Dir & + ALI_File (1 .. Last)) + then + -- We have found the correct project, so we + -- replace the file with the absolute path. + + Last_Switches.Table (J) := + new String'(Dir & ALI_File (1 .. Last)); + + -- And we are done + + exit Switch_Loop; + end if; + end; + + -- Go to the project being extended, if any + + Prj := Prj.Extends; + exit Project_Loop when Prj = No_Project; + end loop Project_Loop; + end if; + end if; + end; + end if; + end loop Switch_Loop; + + -- If a relative path output file has been specified, we add the exec + -- directory. + + for J in reverse 1 .. Last_Switches.Last - 1 loop + if Last_Switches.Table (J).all = "-o" then + Check_Relative_Executable + (Name => Last_Switches.Table (J + 1)); + Look_For_Executable := False; + exit; + end if; + end loop; + + if Look_For_Executable then + for J in reverse 1 .. First_Switches.Last - 1 loop + if First_Switches.Table (J).all = "-o" then + Look_For_Executable := False; + Check_Relative_Executable + (Name => First_Switches.Table (J + 1)); + exit; + end if; + end loop; + end if; + + -- If no executable is specified, then find the name of the first ALI + -- file on the command line and issue a -o switch with the absolute path + -- of the executable in the exec directory. + + if Look_For_Executable then + for J in 1 .. Last_Switches.Last loop + Arg := Last_Switches.Table (J); + Last := 0; + + if Arg'Length /= 0 and then Arg (Arg'First) /= '-' then + if Arg'Length > 4 + and then Arg (Arg'Last - 3 .. Arg'Last) = ".ali" + then + Last := Arg'Last - 4; + + elsif Is_Regular_File (Arg.all & ".ali") then + Last := Arg'Last; + end if; + + if Last /= 0 then + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-o"); + Get_Name_String (Project.Exec_Directory.Name); + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'(Name_Buffer (1 .. Name_Len) & + Executable_Name + (Base_Name (Arg (Arg'First .. Last)))); + exit; + end if; + end if; + end loop; + end if; + end Process_Link; + + --------------------- + -- Set_Library_For -- + --------------------- + + procedure Set_Library_For + (Project : Project_Id; + Libraries_Present : in out Boolean) + is + Path_Option : constant String_Access := + MLib.Linker_Library_Path_Option; + + begin + -- Case of library project + + if Project.Library then + Libraries_Present := True; + + -- Add the -L switch + + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-L" & Get_Name_String (Project.Library_Dir.Name)); + + -- Add the -l switch + + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-l" & Get_Name_String (Project.Library_Name)); + + -- Add the directory to table Library_Paths, to be processed later + -- if library is not static and if Path_Option is not null. + + if Project.Library_Kind /= Static + and then Path_Option /= null + then + Library_Paths.Increment_Last; + Library_Paths.Table (Library_Paths.Last) := + new String'(Get_Name_String (Project.Library_Dir.Name)); + end if; + end if; + end Set_Library_For; + + --------------------------- + -- Test_If_Relative_Path -- + --------------------------- + + procedure Test_If_Relative_Path + (Switch : in out String_Access; + Parent : String) + is + begin + Makeutl.Test_If_Relative_Path + (Switch, Parent, Including_Non_Switch => False, Including_RTS => True); + end Test_If_Relative_Path; + + ------------------- + -- Non_VMS_Usage -- + ------------------- + + procedure Non_VMS_Usage is + begin + Output_Version; + New_Line; + Put_Line ("List of available commands"); + New_Line; + + for C in Command_List'Range loop + + -- No usage for VMS only command or for Sync + + if not Command_List (C).VMS_Only and then C /= Sync then + if Targparm.AAMP_On_Target then + Put ("gnaampcmd "); + else + Put ("gnat "); + end if; + + Put (To_Lower (Command_List (C).Cname.all)); + Set_Col (25); + + -- Never call gnatstack with a prefix + + if C = Stack then + Put (Command_List (C).Unixcmd.all); + else + Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all); + end if; + + declare + Sws : Argument_List_Access renames Command_List (C).Unixsws; + begin + if Sws /= null then + for J in Sws'Range loop + Put (' '); + Put (Sws (J).all); + end loop; + end if; + end; + + New_Line; + end if; + end loop; + + New_Line; + Put_Line ("All commands except chop, krunch and preprocess " & + "accept project file switches -vPx, -Pprj and -Xnam=val"); + New_Line; + end Non_VMS_Usage; + + ------------------------------------- + -- Start of processing for GNATCmd -- + ------------------------------------- + +begin + -- Initializations + + Csets.Initialize; + Snames.Initialize; + + Project_Node_Tree := new Project_Node_Tree_Data; + Prj.Tree.Initialize (Project_Node_Tree); + + Prj.Initialize (Project_Tree); + + Last_Switches.Init; + Last_Switches.Set_Last (0); + + First_Switches.Init; + First_Switches.Set_Last (0); + Carg_Switches.Init; + Carg_Switches.Set_Last (0); + Rules_Switches.Init; + Rules_Switches.Set_Last (0); + + VMS_Conv.Initialize; + + -- Add the default search directories, to be able to find system.ads in the + -- subsequent call to Targparm.Get_Target_Parameters. + + Add_Default_Search_Dirs; + + -- Get target parameters so that AAMP_On_Target will be set, for testing in + -- Osint.Program_Name to handle the mapping of GNAAMP tool names. + + Targparm.Get_Target_Parameters; + + -- Put the command line in environment variable GNAT_DRIVER_COMMAND_LINE, + -- so that the spawned tool may know the way the GNAT driver was invoked. + + Name_Len := 0; + Add_Str_To_Name_Buffer (Command_Name); + + for J in 1 .. Argument_Count loop + Add_Char_To_Name_Buffer (' '); + Add_Str_To_Name_Buffer (Argument (J)); + end loop; + + Setenv ("GNAT_DRIVER_COMMAND_LINE", Name_Buffer (1 .. Name_Len)); + + -- Add the directory where the GNAT driver is invoked in front of the path, + -- if the GNAT driver is invoked with directory information. Do not do this + -- for VMS, where the notion of path does not really exist. + + if not OpenVMS then + declare + Command : constant String := Command_Name; + + begin + for Index in reverse Command'Range loop + if Command (Index) = Directory_Separator then + declare + Absolute_Dir : constant String := + Normalize_Pathname + (Command (Command'First .. Index)); + + PATH : constant String := + Absolute_Dir & Path_Separator & Getenv ("PATH").all; + + begin + Setenv ("PATH", PATH); + end; + + exit; + end if; + end loop; + end; + end if; + + -- If on VMS, or if VMS emulation is on, convert VMS style /qualifiers, + -- filenames and pathnames to Unix style. + + if Hostparm.OpenVMS + or else To_Lower (Getenv ("EMULATE_VMS").all) = "true" + then + VMS_Conversion (The_Command); + + B_Start := new String'("b__"); + + -- If not on VMS, scan the command line directly + + else + if Argument_Count = 0 then + Non_VMS_Usage; + return; + else + begin + loop + if Argument_Count > Command_Arg + and then Argument (Command_Arg) = "-v" + then + Verbose_Mode := True; + Command_Arg := Command_Arg + 1; + + elsif Argument_Count > Command_Arg + and then Argument (Command_Arg) = "-dn" + then + Keep_Temporary_Files := True; + Command_Arg := Command_Arg + 1; + + else + exit; + end if; + end loop; + + The_Command := Real_Command_Type'Value (Argument (Command_Arg)); + + if Command_List (The_Command).VMS_Only then + Non_VMS_Usage; + Fail + ("Command """ + & Command_List (The_Command).Cname.all + & """ can only be used on VMS"); + end if; + + exception + when Constraint_Error => + + -- Check if it is an alternate command + + declare + Alternate : Alternate_Command; + + begin + Alternate := Alternate_Command'Value + (Argument (Command_Arg)); + The_Command := Corresponding_To (Alternate); + + exception + when Constraint_Error => + Non_VMS_Usage; + Fail ("Unknown command: " & Argument (Command_Arg)); + end; + end; + + -- Get the arguments from the command line and from the eventual + -- argument file(s) specified on the command line. + + for Arg in Command_Arg + 1 .. Argument_Count loop + declare + The_Arg : constant String := Argument (Arg); + + begin + -- Check if an argument file is specified + + if The_Arg (The_Arg'First) = '@' then + declare + Arg_File : Ada.Text_IO.File_Type; + Line : String (1 .. 256); + Last : Natural; + + begin + -- Open the file and fail if the file cannot be found + + begin + Open + (Arg_File, In_File, + The_Arg (The_Arg'First + 1 .. The_Arg'Last)); + + exception + when others => + Put + (Standard_Error, "Cannot open argument file """); + Put + (Standard_Error, + The_Arg (The_Arg'First + 1 .. The_Arg'Last)); + + Put_Line (Standard_Error, """"); + raise Error_Exit; + end; + + -- Read line by line and put the content of each non- + -- empty line in the Last_Switches table. + + while not End_Of_File (Arg_File) loop + Get_Line (Arg_File, Line, Last); + + if Last /= 0 then + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'(Line (1 .. Last)); + end if; + end loop; + + Close (Arg_File); + end; + + else + -- It is not an argument file; just put the argument in + -- the Last_Switches table. + + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'(The_Arg); + end if; + end; + end loop; + end if; + end if; + + declare + Program : String_Access; + Exec_Path : String_Access; + + begin + if The_Command = Stack then + + -- Never call gnatstack with a prefix + + Program := new String'(Command_List (The_Command).Unixcmd.all); + + else + Program := + Program_Name (Command_List (The_Command).Unixcmd.all, "gnat"); + end if; + + -- For the tools where the GNAT driver processes the project files, + -- allow shared library projects to import projects that are not shared + -- library projects, to avoid adding a switch for these tools. For the + -- builder (gnatmake), if a shared library project imports a project + -- that is not a shared library project and the appropriate switch is + -- not specified, the invocation of gnatmake will fail. + + Opt.Unchecked_Shared_Lib_Imports := True; + + -- Locate the executable for the command + + Exec_Path := Locate_Exec_On_Path (Program.all); + + if Exec_Path = null then + Put_Line (Standard_Error, "could not locate " & Program.all); + raise Error_Exit; + end if; + + -- If there are switches for the executable, put them as first switches + + if Command_List (The_Command).Unixsws /= null then + for J in Command_List (The_Command).Unixsws'Range loop + First_Switches.Increment_Last; + First_Switches.Table (First_Switches.Last) := + Command_List (The_Command).Unixsws (J); + end loop; + end if; + + -- For BIND, CHECK, ELIM, FIND, LINK, LIST, METRIC, PRETTY, STACK, STUB, + -- SYNC and XREF, look for project file related switches. + + case The_Command is + when Bind => + Tool_Package_Name := Name_Binder; + Packages_To_Check := Packages_To_Check_By_Binder; + when Check => + Tool_Package_Name := Name_Check; + Packages_To_Check := Packages_To_Check_By_Check; + when Elim => + Tool_Package_Name := Name_Eliminate; + Packages_To_Check := Packages_To_Check_By_Eliminate; + when Find => + Tool_Package_Name := Name_Finder; + Packages_To_Check := Packages_To_Check_By_Finder; + when Link => + Tool_Package_Name := Name_Linker; + Packages_To_Check := Packages_To_Check_By_Linker; + when List => + Tool_Package_Name := Name_Gnatls; + Packages_To_Check := Packages_To_Check_By_Gnatls; + when Metric => + Tool_Package_Name := Name_Metrics; + Packages_To_Check := Packages_To_Check_By_Metric; + when Pretty => + Tool_Package_Name := Name_Pretty_Printer; + Packages_To_Check := Packages_To_Check_By_Pretty; + when Stack => + Tool_Package_Name := Name_Stack; + Packages_To_Check := Packages_To_Check_By_Stack; + when Stub => + Tool_Package_Name := Name_Gnatstub; + Packages_To_Check := Packages_To_Check_By_Gnatstub; + when Sync => + Tool_Package_Name := Name_Synchronize; + Packages_To_Check := Packages_To_Check_By_Sync; + when Xref => + Tool_Package_Name := Name_Cross_Reference; + Packages_To_Check := Packages_To_Check_By_Xref; + when others => + Tool_Package_Name := No_Name; + end case; + + if Tool_Package_Name /= No_Name then + + -- Check that the switches are consistent. Detect project file + -- related switches. + + Inspect_Switches : declare + Arg_Num : Positive := 1; + Argv : String_Access; + + procedure Remove_Switch (Num : Positive); + -- Remove a project related switch from table Last_Switches + + ------------------- + -- Remove_Switch -- + ------------------- + + procedure Remove_Switch (Num : Positive) is + begin + Last_Switches.Table (Num .. Last_Switches.Last - 1) := + Last_Switches.Table (Num + 1 .. Last_Switches.Last); + Last_Switches.Decrement_Last; + end Remove_Switch; + + -- Start of processing for Inspect_Switches + + begin + while Arg_Num <= Last_Switches.Last loop + Argv := Last_Switches.Table (Arg_Num); + + if Argv (Argv'First) = '-' then + if Argv'Length = 1 then + Fail + ("switch character cannot be followed by a blank"); + end if; + + -- The two style project files (-p and -P) cannot be used + -- together + + if (The_Command = Find or else The_Command = Xref) + and then Argv (2) = 'p' + then + Old_Project_File_Used := True; + if Project_File /= null then + Fail ("-P and -p cannot be used together"); + end if; + end if; + + -- --subdirs=... Specify Subdirs + + if Argv'Length > Makeutl.Subdirs_Option'Length + and then + Argv + (Argv'First .. + Argv'First + Makeutl.Subdirs_Option'Length - 1) = + Makeutl.Subdirs_Option + then + Subdirs := + new String' + (Argv + (Argv'First + Makeutl.Subdirs_Option'Length .. + Argv'Last)); + + Remove_Switch (Arg_Num); + + -- -aPdir Add dir to the project search path + + elsif Argv'Length > 3 + and then Argv (Argv'First + 1 .. Argv'First + 2) = "aP" + then + Prj.Env.Add_Directories + (Project_Node_Tree.Project_Path, + Argv (Argv'First + 3 .. Argv'Last)); + + Remove_Switch (Arg_Num); + + -- -eL Follow links for files + + elsif Argv.all = "-eL" then + Follow_Links_For_Files := True; + Follow_Links_For_Dirs := True; + + Remove_Switch (Arg_Num); + + -- -vPx Specify verbosity while parsing project files + + elsif Argv'Length = 4 + and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP" + then + case Argv (Argv'Last) is + when '0' => + Current_Verbosity := Prj.Default; + when '1' => + Current_Verbosity := Prj.Medium; + when '2' => + Current_Verbosity := Prj.High; + when others => + Fail ("Invalid switch: " & Argv.all); + end case; + + Remove_Switch (Arg_Num); + + -- -Pproject_file Specify project file to be used + + elsif Argv (Argv'First + 1) = 'P' then + + -- Only one -P switch can be used + + if Project_File /= null then + Fail + (Argv.all + & ": second project file forbidden (first is """ + & Project_File.all + & """)"); + + -- The two style project files (-p and -P) cannot be + -- used together. + + elsif Old_Project_File_Used then + Fail ("-p and -P cannot be used together"); + + elsif Argv'Length = 2 then + + -- There is space between -P and the project file + -- name. -P cannot be the last option. + + if Arg_Num = Last_Switches.Last then + Fail ("project file name missing after -P"); + + else + Remove_Switch (Arg_Num); + Argv := Last_Switches.Table (Arg_Num); + + -- After -P, there must be a project file name, + -- not another switch. + + if Argv (Argv'First) = '-' then + Fail ("project file name missing after -P"); + + else + Project_File := new String'(Argv.all); + end if; + end if; + + else + -- No space between -P and project file name + + Project_File := + new String'(Argv (Argv'First + 2 .. Argv'Last)); + end if; + + Remove_Switch (Arg_Num); + + -- -Xexternal=value Specify an external reference to be + -- used in project files + + elsif Argv'Length >= 5 + and then Argv (Argv'First + 1) = 'X' + then + declare + Equal_Pos : constant Natural := + Index + ('=', + Argv (Argv'First + 2 .. Argv'Last)); + begin + if Equal_Pos >= Argv'First + 3 + and then Equal_Pos /= Argv'Last + then + Add (Project_Node_Tree, + External_Name => + Argv (Argv'First + 2 .. Equal_Pos - 1), + Value => Argv (Equal_Pos + 1 .. Argv'Last)); + else + Fail + (Argv.all + & " is not a valid external assignment."); + end if; + end; + + Remove_Switch (Arg_Num); + + elsif + (The_Command = Check or else + The_Command = Sync or else + The_Command = Pretty or else + The_Command = Metric or else + The_Command = Stack or else + The_Command = List) + and then Argv'Length = 2 + and then Argv (2) = 'U' + then + All_Projects := True; + Remove_Switch (Arg_Num); + + else + Arg_Num := Arg_Num + 1; + end if; + + elsif ((The_Command = Check and then Argv (Argv'First) /= '+') + or else The_Command = Sync + or else The_Command = Metric + or else The_Command = Pretty) + and then Project_File /= null + and then All_Projects + then + if ASIS_Main /= null then + Fail ("cannot specify more than one main after -U"); + else + ASIS_Main := Argv; + Remove_Switch (Arg_Num); + end if; + + else + Arg_Num := Arg_Num + 1; + end if; + end loop; + end Inspect_Switches; + end if; + + -- If there is a project file specified, parse it, get the switches + -- for the tool and setup PATH environment variables. + + if Project_File /= null then + Prj.Pars.Set_Verbosity (To => Current_Verbosity); + + Prj.Pars.Parse + (Project => Project, + In_Tree => Project_Tree, + In_Node_Tree => Project_Node_Tree, + Project_File_Name => Project_File.all, + Flags => Gnatmake_Flags, + Packages_To_Check => Packages_To_Check); + + if Project = Prj.No_Project then + Fail ("""" & Project_File.all & """ processing failed"); + end if; + + -- Check if a package with the name of the tool is in the project + -- file and if there is one, get the switches, if any, and scan them. + + declare + Pkg : constant Prj.Package_Id := + Prj.Util.Value_Of + (Name => Tool_Package_Name, + In_Packages => Project.Decl.Packages, + In_Tree => Project_Tree); + + Element : Package_Element; + + Switches_Array : Array_Element_Id; + + The_Switches : Prj.Variable_Value; + Current : Prj.String_List_Id; + The_String : String_Element; + + Main : String_Access := null; + + begin + if Pkg /= No_Package then + Element := Project_Tree.Packages.Table (Pkg); + + -- Packages Gnatls and Gnatstack have a single attribute + -- Switches, that is not an associative array. + + if The_Command = List or else The_Command = Stack then + The_Switches := + Prj.Util.Value_Of + (Variable_Name => Snames.Name_Switches, + In_Variables => Element.Decl.Attributes, + In_Tree => Project_Tree); + + -- Packages Binder (for gnatbind), Cross_Reference (for + -- gnatxref), Linker (for gnatlink), Finder (for gnatfind), + -- Pretty_Printer (for gnatpp), Eliminate (for gnatelim), Check + -- (for gnatcheck), and Metric (for gnatmetric) have an + -- attributed Switches, an associative array, indexed by the + -- name of the file. + + -- They also have an attribute Default_Switches, indexed by the + -- name of the programming language. + + else + -- First check if there is a single main + + for J in 1 .. Last_Switches.Last loop + if Last_Switches.Table (J) (1) /= '-' then + if Main = null then + Main := Last_Switches.Table (J); + + else + Main := null; + exit; + end if; + end if; + end loop; + + if Main /= null then + Switches_Array := + Prj.Util.Value_Of + (Name => Name_Switches, + In_Arrays => Element.Decl.Arrays, + In_Tree => Project_Tree); + Name_Len := 0; + Add_Str_To_Name_Buffer (Main.all); + The_Switches := Prj.Util.Value_Of + (Index => Name_Find, + Src_Index => 0, + In_Array => Switches_Array, + In_Tree => Project_Tree); + end if; + + if The_Switches.Kind = Prj.Undefined then + Switches_Array := + Prj.Util.Value_Of + (Name => Name_Default_Switches, + In_Arrays => Element.Decl.Arrays, + In_Tree => Project_Tree); + The_Switches := Prj.Util.Value_Of + (Index => Name_Ada, + Src_Index => 0, + In_Array => Switches_Array, + In_Tree => Project_Tree); + end if; + end if; + + -- If there are switches specified in the package of the + -- project file corresponding to the tool, scan them. + + case The_Switches.Kind is + when Prj.Undefined => + null; + + when Prj.Single => + declare + Switch : constant String := + Get_Name_String (The_Switches.Value); + + begin + if Switch'Length > 0 then + First_Switches.Increment_Last; + First_Switches.Table (First_Switches.Last) := + new String'(Switch); + end if; + end; + + when Prj.List => + Current := The_Switches.Values; + while Current /= Prj.Nil_String loop + The_String := Project_Tree.String_Elements. + Table (Current); + + declare + Switch : constant String := + Get_Name_String (The_String.Value); + + begin + if Switch'Length > 0 then + First_Switches.Increment_Last; + First_Switches.Table (First_Switches.Last) := + new String'(Switch); + end if; + end; + + Current := The_String.Next; + end loop; + end case; + end if; + end; + + if The_Command = Bind + or else The_Command = Link + or else The_Command = Elim + then + Change_Dir (Get_Name_String (Project.Object_Directory.Name)); + end if; + + -- Set up the env vars for project path files + + Prj.Env.Set_Ada_Paths + (Project, Project_Tree, Including_Libraries => False); + + -- For gnatcheck, gnatstub, gnatmetric, gnatpp and gnatelim, create + -- a configuration pragmas file, if necessary. + + if The_Command = Pretty + or else The_Command = Metric + or else The_Command = Stub + or else The_Command = Elim + or else The_Command = Check + or else The_Command = Sync + then + -- If there are switches in package Compiler, put them in the + -- Carg_Switches table. + + declare + Pkg : constant Prj.Package_Id := + Prj.Util.Value_Of + (Name => Name_Compiler, + In_Packages => Project.Decl.Packages, + In_Tree => Project_Tree); + + Element : Package_Element; + + Switches_Array : Array_Element_Id; + + The_Switches : Prj.Variable_Value; + Current : Prj.String_List_Id; + The_String : String_Element; + + Main : String_Access := null; + Main_Id : Name_Id; + + begin + if Pkg /= No_Package then + + -- First, check if there is a single main specified. + + for J in 1 .. Last_Switches.Last loop + if Last_Switches.Table (J) (1) /= '-' then + if Main = null then + Main := Last_Switches.Table (J); + + else + Main := null; + exit; + end if; + end if; + end loop; + + Element := Project_Tree.Packages.Table (Pkg); + + -- If there is a single main and there is compilation + -- switches specified in the project file, use them. + + if Main /= null and then not All_Projects then + Name_Len := Main'Length; + Name_Buffer (1 .. Name_Len) := Main.all; + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Main_Id := Name_Find; + + Switches_Array := + Prj.Util.Value_Of + (Name => Name_Switches, + In_Arrays => Element.Decl.Arrays, + In_Tree => Project_Tree); + The_Switches := Prj.Util.Value_Of + (Index => Main_Id, + Src_Index => 0, + In_Array => Switches_Array, + In_Tree => Project_Tree); + end if; + + -- Otherwise, get the Default_Switches ("Ada") + + if The_Switches.Kind = Undefined then + Switches_Array := + Prj.Util.Value_Of + (Name => Name_Default_Switches, + In_Arrays => Element.Decl.Arrays, + In_Tree => Project_Tree); + The_Switches := Prj.Util.Value_Of + (Index => Name_Ada, + Src_Index => 0, + In_Array => Switches_Array, + In_Tree => Project_Tree); + end if; + + -- If there are switches specified, put them in the + -- Carg_Switches table. + + case The_Switches.Kind is + when Prj.Undefined => + null; + + when Prj.Single => + declare + Switch : constant String := + Get_Name_String (The_Switches.Value); + begin + if Switch'Length > 0 then + Add_To_Carg_Switches (new String'(Switch)); + end if; + end; + + when Prj.List => + Current := The_Switches.Values; + while Current /= Prj.Nil_String loop + The_String := + Project_Tree.String_Elements.Table (Current); + + declare + Switch : constant String := + Get_Name_String (The_String.Value); + begin + if Switch'Length > 0 then + Add_To_Carg_Switches (new String'(Switch)); + end if; + end; + + Current := The_String.Next; + end loop; + end case; + end if; + end; + + -- If -cargs is one of the switches, move the following switches + -- to the Carg_Switches table. + + for J in 1 .. First_Switches.Last loop + if First_Switches.Table (J).all = "-cargs" then + declare + K : Positive; + Last : Natural; + + begin + -- Move the switches that are before -rules when the + -- command is CHECK. + + K := J + 1; + while K <= First_Switches.Last + and then + (The_Command /= Check + or else First_Switches.Table (K).all /= "-rules") + loop + Add_To_Carg_Switches (First_Switches.Table (K)); + K := K + 1; + end loop; + + if K > First_Switches.Last then + First_Switches.Set_Last (J - 1); + + else + Last := J - 1; + while K <= First_Switches.Last loop + Last := Last + 1; + First_Switches.Table (Last) := + First_Switches.Table (K); + K := K + 1; + end loop; + + First_Switches.Set_Last (Last); + end if; + end; + + exit; + end if; + end loop; + + for J in 1 .. Last_Switches.Last loop + if Last_Switches.Table (J).all = "-cargs" then + declare + K : Positive; + Last : Natural; + + begin + -- Move the switches that are before -rules when the + -- command is CHECK. + + K := J + 1; + while K <= Last_Switches.Last + and then + (The_Command /= Check + or else Last_Switches.Table (K).all /= "-rules") + loop + Add_To_Carg_Switches (Last_Switches.Table (K)); + K := K + 1; + end loop; + + if K > Last_Switches.Last then + Last_Switches.Set_Last (J - 1); + + else + Last := J - 1; + while K <= Last_Switches.Last loop + Last := Last + 1; + Last_Switches.Table (Last) := + Last_Switches.Table (K); + K := K + 1; + end loop; + + Last_Switches.Set_Last (Last); + end if; + end; + + exit; + end if; + end loop; + + declare + CP_File : constant Path_Name_Type := Configuration_Pragmas_File; + M_File : constant Path_Name_Type := Mapping_File; + + begin + if CP_File /= No_Path then + if The_Command = Elim then + First_Switches.Increment_Last; + First_Switches.Table (First_Switches.Last) := + new String'("-C" & Get_Name_String (CP_File)); + + else + Add_To_Carg_Switches + (new String'("-gnatec=" & Get_Name_String (CP_File))); + end if; + end if; + + if M_File /= No_Path then + Add_To_Carg_Switches + (new String'("-gnatem=" & Get_Name_String (M_File))); + end if; + + -- For gnatcheck, also indicate a global configuration pragmas + -- file and, if -U is not used, a local one. + + if The_Command = Check then + declare + Pkg : constant Prj.Package_Id := + Prj.Util.Value_Of + (Name => Name_Builder, + In_Packages => Project.Decl.Packages, + In_Tree => Project_Tree); + + Variable : Variable_Value := + Prj.Util.Value_Of + (Name => No_Name, + Attribute_Or_Array_Name => + Name_Global_Configuration_Pragmas, + In_Package => Pkg, + In_Tree => Project_Tree); + + begin + if (Variable = Nil_Variable_Value + or else Length_Of_Name (Variable.Value) = 0) + and then Pkg /= No_Package + then + Variable := + Prj.Util.Value_Of + (Name => Name_Ada, + Attribute_Or_Array_Name => + Name_Global_Config_File, + In_Package => Pkg, + In_Tree => Project_Tree); + end if; + + if Variable /= Nil_Variable_Value + and then Length_Of_Name (Variable.Value) /= 0 + then + Add_To_Carg_Switches + (new String' + ("-gnatec=" & Get_Name_String (Variable.Value))); + end if; + end; + + if not All_Projects then + declare + Pkg : constant Prj.Package_Id := + Prj.Util.Value_Of + (Name => Name_Compiler, + In_Packages => Project.Decl.Packages, + In_Tree => Project_Tree); + + Variable : Variable_Value := + Prj.Util.Value_Of + (Name => No_Name, + Attribute_Or_Array_Name => + Name_Local_Configuration_Pragmas, + In_Package => Pkg, + In_Tree => Project_Tree); + + begin + if (Variable = Nil_Variable_Value + or else Length_Of_Name (Variable.Value) = 0) + and then Pkg /= No_Package + then + Variable := + Prj.Util.Value_Of + (Name => Name_Ada, + Attribute_Or_Array_Name => + Name_Local_Config_File, + In_Package => Pkg, + In_Tree => Project_Tree); + end if; + + if Variable /= Nil_Variable_Value + and then Length_Of_Name (Variable.Value) /= 0 + then + Add_To_Carg_Switches + (new String' + ("-gnatec=" & + Get_Name_String (Variable.Value))); + end if; + end; + end if; + end if; + end; + end if; + + if The_Command = Link then + Process_Link; + end if; + + if The_Command = Link or else The_Command = Bind then + + -- For files that are specified as relative paths with directory + -- information, we convert them to absolute paths, with parent + -- being the current working directory if specified on the command + -- line and the project directory if specified in the project + -- file. This is what gnatmake is doing for linker and binder + -- arguments. + + for J in 1 .. Last_Switches.Last loop + GNATCmd.Test_If_Relative_Path + (Last_Switches.Table (J), Current_Work_Dir); + end loop; + + Get_Name_String (Project.Directory.Name); + + declare + Project_Dir : constant String := Name_Buffer (1 .. Name_Len); + begin + for J in 1 .. First_Switches.Last loop + GNATCmd.Test_If_Relative_Path + (First_Switches.Table (J), Project_Dir); + end loop; + end; + + elsif The_Command = Stub then + declare + File_Index : Integer := 0; + Dir_Index : Integer := 0; + Last : constant Integer := Last_Switches.Last; + Lang : constant Language_Ptr := + Get_Language_From_Name (Project, "ada"); + + begin + for Index in 1 .. Last loop + if Last_Switches.Table (Index) + (Last_Switches.Table (Index)'First) /= '-' + then + File_Index := Index; + exit; + end if; + end loop; + + -- If the project file naming scheme is not standard, and if + -- the file name ends with the spec suffix, then indicate to + -- gnatstub the name of the body file with a -o switch. + + if not Is_Standard_GNAT_Naming (Lang.Config.Naming_Data) then + if File_Index /= 0 then + declare + Spec : constant String := + Base_Name + (Last_Switches.Table (File_Index).all); + Last : Natural := Spec'Last; + + begin + Get_Name_String (Lang.Config.Naming_Data.Spec_Suffix); + + if Spec'Length > Name_Len + and then Spec (Last - Name_Len + 1 .. Last) = + Name_Buffer (1 .. Name_Len) + then + Last := Last - Name_Len; + Get_Name_String + (Lang.Config.Naming_Data.Body_Suffix); + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-o"); + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'(Spec (Spec'First .. Last) & + Name_Buffer (1 .. Name_Len)); + end if; + end; + end if; + end if; + + -- Add the directory of the spec as the destination directory + -- of the body, if there is no destination directory already + -- specified. + + if File_Index /= 0 then + for Index in File_Index + 1 .. Last loop + if Last_Switches.Table (Index) + (Last_Switches.Table (Index)'First) /= '-' + then + Dir_Index := Index; + exit; + end if; + end loop; + + if Dir_Index = 0 then + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String' + (Dir_Name (Last_Switches.Table (File_Index).all)); + end if; + end if; + end; + end if; + + -- For gnatmetric, the generated files should be put in the object + -- directory. This must be the first switch, because it may be + -- overridden by a switch in package Metrics in the project file or + -- by a command line option. Note that we don't add the -d= switch + -- if there is no object directory available. + + if The_Command = Metric + and then Project.Object_Directory /= No_Path_Information + then + First_Switches.Increment_Last; + First_Switches.Table (2 .. First_Switches.Last) := + First_Switches.Table (1 .. First_Switches.Last - 1); + First_Switches.Table (1) := + new String'("-d=" & + Get_Name_String (Project.Object_Directory.Name)); + end if; + + -- For gnat check, -rules and the following switches need to be the + -- last options, so move all these switches to table Rules_Switches. + + if The_Command = Check then + declare + New_Last : Natural; + -- Set to rank of options preceding "-rules" + + In_Rules_Switches : Boolean; + -- Set to True when options "-rules" is found + + begin + New_Last := First_Switches.Last; + In_Rules_Switches := False; + + for J in 1 .. First_Switches.Last loop + if In_Rules_Switches then + Add_To_Rules_Switches (First_Switches.Table (J)); + + elsif First_Switches.Table (J).all = "-rules" then + New_Last := J - 1; + In_Rules_Switches := True; + end if; + end loop; + + if In_Rules_Switches then + First_Switches.Set_Last (New_Last); + end if; + + New_Last := Last_Switches.Last; + In_Rules_Switches := False; + + for J in 1 .. Last_Switches.Last loop + if In_Rules_Switches then + Add_To_Rules_Switches (Last_Switches.Table (J)); + + elsif Last_Switches.Table (J).all = "-rules" then + New_Last := J - 1; + In_Rules_Switches := True; + end if; + end loop; + + if In_Rules_Switches then + Last_Switches.Set_Last (New_Last); + end if; + end; + end if; + + -- For gnat check, sync, metric or pretty with -U + a main, get the + -- list of sources from the closure and add them to the arguments. + + if ASIS_Main /= null then + Get_Closure; + + -- On VMS, set up the env var again for source dirs file. This is + -- because the call to gnatmake has set this env var to another + -- file that has now been deleted. + + if Hostparm.OpenVMS then + + -- First make sure that the recorded file names are empty + + Prj.Env.Initialize (Project_Tree); + + Prj.Env.Set_Ada_Paths + (Project, Project_Tree, Including_Libraries => False); + end if; + + -- For gnat check, gnat sync, gnat pretty, gnat metric, gnat list, + -- and gnat stack, if no file has been put on the command line, call + -- tool with all the sources of the main project. + + elsif The_Command = Check or else + The_Command = Sync or else + The_Command = Pretty or else + The_Command = Metric or else + The_Command = List or else + The_Command = Stack + then + Check_Files; + end if; + end if; + + -- Gather all the arguments and invoke the executable + + declare + The_Args : Argument_List + (1 .. First_Switches.Last + + Last_Switches.Last + + Carg_Switches.Last + + Rules_Switches.Last); + Arg_Num : Natural := 0; + + begin + for J in 1 .. First_Switches.Last loop + Arg_Num := Arg_Num + 1; + The_Args (Arg_Num) := First_Switches.Table (J); + end loop; + + for J in 1 .. Last_Switches.Last loop + Arg_Num := Arg_Num + 1; + The_Args (Arg_Num) := Last_Switches.Table (J); + end loop; + + for J in 1 .. Carg_Switches.Last loop + Arg_Num := Arg_Num + 1; + The_Args (Arg_Num) := Carg_Switches.Table (J); + end loop; + + for J in 1 .. Rules_Switches.Last loop + Arg_Num := Arg_Num + 1; + The_Args (Arg_Num) := Rules_Switches.Table (J); + end loop; + + -- If Display_Command is on, only display the generated command + + if Display_Command then + Put (Standard_Error, "generated command -->"); + Put (Standard_Error, Exec_Path.all); + + for Arg in The_Args'Range loop + Put (Standard_Error, " "); + Put (Standard_Error, The_Args (Arg).all); + end loop; + + Put (Standard_Error, "<--"); + New_Line (Standard_Error); + raise Normal_Exit; + end if; + + if Verbose_Mode then + Output.Write_Str (Exec_Path.all); + + for Arg in The_Args'Range loop + Output.Write_Char (' '); + Output.Write_Str (The_Args (Arg).all); + end loop; + + Output.Write_Eol; + end if; + + My_Exit_Status := + Exit_Status (Spawn (Exec_Path.all, The_Args)); + raise Normal_Exit; + end; + end; + +exception + when Error_Exit => + if not Keep_Temporary_Files then + Prj.Delete_All_Temp_Files (Project_Tree); + Delete_Temp_Config_Files; + end if; + + Set_Exit_Status (Failure); + + when Normal_Exit => + if not Keep_Temporary_Files then + Prj.Delete_All_Temp_Files (Project_Tree); + Delete_Temp_Config_Files; + end if; + + -- Since GNATCmd is normally called from DCL (the VMS shell), it must + -- return an understandable VMS exit status. However the exit status + -- returned *to* GNATCmd is a Posix style code, so we test it and return + -- just a simple success or failure on VMS. + + if Hostparm.OpenVMS and then My_Exit_Status /= Success then + Set_Exit_Status (Failure); + else + Set_Exit_Status (My_Exit_Status); + end if; +end GNATCmd; diff --git a/gcc/ada/gnatcmd.ads b/gcc/ada/gnatcmd.ads new file mode 100644 index 000000000..6c2c8c7f5 --- /dev/null +++ b/gcc/ada/gnatcmd.ads @@ -0,0 +1,58 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T C M D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1996-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This program provides a simple command interface for using GNAT and its +-- associated utilities. The format of switches accepted is intended to +-- be more familiar in style for VMS and DOS users than the standard Unix +-- style switches that are accepted directly. + +-- The program is typically called GNAT when it is installed and +-- the two possible styles of use are: + +-- To call gcc: + +-- GNAT filename switches + +-- To call the tool gnatxxx + +-- GNAT xxx filename switches + +-- where xxx is the command name (e.g. MAKE for gnatmake). This command name +-- can be abbreviated by giving a prefix (e.g. GNAT MAK) as long as it +-- remains unique. + +-- In both cases, filename is in the format appropriate to the operating +-- system in use. The individual commands give more details. In some cases +-- a unit name may be given in place of a file name. + +-- The switches start with a slash. Switch names can also be abbreviated +-- where no ambiguity arises. The switches associated with each command +-- are specified by the tables that can be found in the body. + +-- Although by convention we use upper case for command names and switches +-- in the documentation, all command and switch names are case insensitive +-- and may be given in upper case or lower case or a mixture. + +procedure GNATCmd; diff --git a/gcc/ada/gnatdll.adb b/gcc/ada/gnatdll.adb new file mode 100644 index 000000000..6917e631d --- /dev/null +++ b/gcc/ada/gnatdll.adb @@ -0,0 +1,584 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T D L L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- GNATDLL is a Windows specific tool for building a DLL. +-- Both relocatable and non-relocatable DLL's are supported + +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Exceptions; use Ada.Exceptions; +with Ada.Command_Line; use Ada.Command_Line; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Command_Line; use GNAT.Command_Line; +with Gnatvsn; + +with MDLL.Fil; use MDLL.Fil; +with MDLL.Utl; use MDLL.Utl; + +procedure Gnatdll is + + use type GNAT.OS_Lib.Argument_List; + + procedure Syntax; + -- Print out usage + + procedure Check (Filename : String); + -- Check that the file whose name is Filename exists + + procedure Parse_Command_Line; + -- Parse the command line arguments passed to gnatdll + + procedure Check_Context; + -- Check the context before running any commands to build the library + + Syntax_Error : exception; + -- Raised when a syntax error is detected, in this case a usage info will + -- be displayed. + + Context_Error : exception; + -- Raised when some files (specified on the command line) are missing to + -- build the DLL. + + Help : Boolean := False; + -- Help will be set to True the usage information is to be displayed + + Version : constant String := Gnatvsn.Gnat_Version_String; + -- Why should it be necessary to make a copy of this + + Default_DLL_Address : constant String := "0x11000000"; + -- Default address for non relocatable DLL (Win32) + + Lib_Filename : Unbounded_String := Null_Unbounded_String; + -- The DLL filename that will be created (.dll) + + Def_Filename : Unbounded_String := Null_Unbounded_String; + -- The definition filename (.def) + + List_Filename : Unbounded_String := Null_Unbounded_String; + -- The name of the file containing the objects file to put into the DLL + + DLL_Address : Unbounded_String := To_Unbounded_String (Default_DLL_Address); + -- The DLL's base address + + Gen_Map_File : Boolean := False; + -- Set to True if a map file is to be generated + + Objects_Files : Argument_List_Access := MDLL.Null_Argument_List_Access; + -- List of objects to put inside the library + + Ali_Files : Argument_List_Access := MDLL.Null_Argument_List_Access; + -- For each Ada file specified, we keep a record of the corresponding + -- ALI file. This list of SLI files is used to build the binder program. + + Options : Argument_List_Access := MDLL.Null_Argument_List_Access; + -- A list of options set in the command line + + Largs_Options : Argument_List_Access := MDLL.Null_Argument_List_Access; + Bargs_Options : Argument_List_Access := MDLL.Null_Argument_List_Access; + -- GNAT linker and binder args options + + type Build_Mode_State is (Import_Lib, Dynamic_Lib, Dynamic_Lib_Only, Nil); + -- Import_Lib means only the .a file will be created, Dynamic_Lib means + -- that both the DLL and the import library will be created. + -- Dynamic_Lib_Only means that only the DLL will be created (no import + -- library). + + Build_Mode : Build_Mode_State := Nil; + -- Will be set when parsing the command line + + Must_Build_Relocatable : Boolean := True; + -- True means build a relocatable DLL, will be set to False if a + -- non-relocatable DLL must be built. + + ------------ + -- Syntax -- + ------------ + + procedure Syntax is + procedure P (Str : String) renames Put_Line; + begin + P ("Usage : gnatdll [options] [list-of-files]"); + New_Line; + P ("[list-of-files] a list of Ada libraries (.ali) and/or " & + "foreign object files"); + New_Line; + P ("[options] can be"); + P (" -h Help - display this message"); + P (" -v Verbose"); + P (" -q Quiet"); + P (" -k Remove @nn suffix from exported names"); + P (" -g Generate debugging information"); + P (" -Idir Specify source and object files search path"); + P (" -l file File contains a list-of-files to be added to " + & "the library"); + P (" -e file Definition file containing exports"); + P (" -d file Put objects in the relocatable dynamic " + & "library "); + P (" -b addr Set base address for the relocatable DLL"); + P (" default address is " & Default_DLL_Address); + P (" -a[addr] Build non-relocatable DLL at address "); + P (" if is not specified use " + & Default_DLL_Address); + P (" -m Generate map file"); + P (" -n No-import - do not create the import library"); + P (" -bargs opts opts are passed to the binder"); + P (" -largs opts opts are passed to the linker"); + end Syntax; + + ----------- + -- Check -- + ----------- + + procedure Check (Filename : String) is + begin + if not Is_Regular_File (Filename) then + Raise_Exception + (Context_Error'Identity, "Error: " & Filename & " not found."); + end if; + end Check; + + ------------------------ + -- Parse_Command_Line -- + ------------------------ + + procedure Parse_Command_Line is + + procedure Add_File (Filename : String); + -- Add one file to the list of file to handle + + procedure Add_Files_From_List (List_Filename : String); + -- Add the files listed in List_Filename (one by line) to the list + -- of file to handle + + Max_Files : constant := 5_000; + Max_Options : constant := 100; + -- These are arbitrary limits, a better way will be to use linked list. + -- No, a better choice would be to use tables ??? + -- Limits on what??? + + Ofiles : Argument_List (1 .. Max_Files); + O : Positive := Ofiles'First; + -- List of object files to put in the library. O is the next entry + -- to be used. + + Afiles : Argument_List (1 .. Max_Files); + A : Positive := Afiles'First; + -- List of ALI files. A is the next entry to be used + + Gopts : Argument_List (1 .. Max_Options); + G : Positive := Gopts'First; + -- List of gcc options. G is the next entry to be used + + Lopts : Argument_List (1 .. Max_Options); + L : Positive := Lopts'First; + -- A list of -largs options (L is next entry to be used) + + Bopts : Argument_List (1 .. Max_Options); + B : Positive := Bopts'First; + -- A list of -bargs options (B is next entry to be used) + + Build_Import : Boolean := True; + -- Set to False if option -n if specified (no-import) + + -------------- + -- Add_File -- + -------------- + + procedure Add_File (Filename : String) is + begin + if Is_Ali (Filename) then + Check (Filename); + + -- Record it to generate the binder program when + -- building dynamic library + + Afiles (A) := new String'(Filename); + A := A + 1; + + elsif Is_Obj (Filename) then + Check (Filename); + + -- Just record this object file + + Ofiles (O) := new String'(Filename); + O := O + 1; + + else + -- Unknown file type + + Raise_Exception + (Syntax_Error'Identity, + "don't know what to do with " & Filename & " !"); + end if; + end Add_File; + + ------------------------- + -- Add_Files_From_List -- + ------------------------- + + procedure Add_Files_From_List (List_Filename : String) is + File : File_Type; + Buffer : String (1 .. 500); + Last : Natural; + + begin + Open (File, In_File, List_Filename); + + while not End_Of_File (File) loop + Get_Line (File, Buffer, Last); + Add_File (Buffer (1 .. Last)); + end loop; + + Close (File); + + exception + when Name_Error => + Raise_Exception + (Syntax_Error'Identity, + "list-of-files file " & List_Filename & " not found."); + end Add_Files_From_List; + + -- Start of processing for Parse_Command_Line + + begin + Initialize_Option_Scan ('-', False, "bargs largs"); + + -- scan gnatdll switches + + loop + case Getopt ("g h v q k a? b: d: e: l: n m I:") is + + when ASCII.NUL => + exit; + + when 'h' => + Help := True; + + when 'g' => + Gopts (G) := new String'("-g"); + G := G + 1; + + when 'v' => + + -- Turn verbose mode on + + MDLL.Verbose := True; + if MDLL.Quiet then + Raise_Exception + (Syntax_Error'Identity, + "impossible to use -q and -v together."); + end if; + + when 'q' => + + -- Turn quiet mode on + + MDLL.Quiet := True; + if MDLL.Verbose then + Raise_Exception + (Syntax_Error'Identity, + "impossible to use -v and -q together."); + end if; + + when 'k' => + + MDLL.Kill_Suffix := True; + + when 'a' => + + if Parameter = "" then + + -- Default address for a relocatable dynamic library. + -- address for a non relocatable dynamic library. + + DLL_Address := To_Unbounded_String (Default_DLL_Address); + + else + DLL_Address := To_Unbounded_String (Parameter); + end if; + + Must_Build_Relocatable := False; + + when 'b' => + + DLL_Address := To_Unbounded_String (Parameter); + + Must_Build_Relocatable := True; + + when 'e' => + + Def_Filename := To_Unbounded_String (Parameter); + + when 'd' => + + -- Build a non relocatable DLL + + Lib_Filename := To_Unbounded_String (Parameter); + + if Def_Filename = Null_Unbounded_String then + Def_Filename := To_Unbounded_String + (Ext_To (Parameter, "def")); + end if; + + Build_Mode := Dynamic_Lib; + + when 'm' => + + Gen_Map_File := True; + + when 'n' => + + Build_Import := False; + + when 'l' => + List_Filename := To_Unbounded_String (Parameter); + + when 'I' => + Gopts (G) := new String'("-I" & Parameter); + G := G + 1; + + when others => + raise Invalid_Switch; + end case; + end loop; + + -- Get parameters + + loop + declare + File : constant String := Get_Argument (Do_Expansion => True); + begin + exit when File'Length = 0; + Add_File (File); + end; + end loop; + + -- Get largs parameters + + Goto_Section ("largs"); + + loop + case Getopt ("*") is + when ASCII.NUL => + exit; + + when others => + Lopts (L) := new String'(Full_Switch); + L := L + 1; + end case; + end loop; + + -- Get bargs parameters + + Goto_Section ("bargs"); + + loop + case Getopt ("*") is + + when ASCII.NUL => + exit; + + when others => + Bopts (B) := new String'(Full_Switch); + B := B + 1; + + end case; + end loop; + + -- if list filename has been specified, parse it + + if List_Filename /= Null_Unbounded_String then + Add_Files_From_List (To_String (List_Filename)); + end if; + + -- Check if the set of parameters are compatible + + if Build_Mode = Nil and then not Help and then not MDLL.Verbose then + Raise_Exception (Syntax_Error'Identity, "nothing to do."); + end if; + + -- -n option but no file specified + + if not Build_Import + and then A = Afiles'First + and then O = Ofiles'First + then + Raise_Exception + (Syntax_Error'Identity, + "-n specified but there are no objects to build the library."); + end if; + + -- Check if we want to build an import library (option -e and + -- no file specified) + + if Build_Mode = Dynamic_Lib + and then A = Afiles'First + and then O = Ofiles'First + then + Build_Mode := Import_Lib; + end if; + + -- If map file is to be generated, add linker option here + + if Gen_Map_File and then Build_Mode = Import_Lib then + Raise_Exception + (Syntax_Error'Identity, + "Can't generate a map file for an import library."); + end if; + + -- Check if only a dynamic library must be built + + if Build_Mode = Dynamic_Lib and then not Build_Import then + Build_Mode := Dynamic_Lib_Only; + end if; + + if O /= Ofiles'First then + Objects_Files := new Argument_List'(Ofiles (1 .. O - 1)); + end if; + + if A /= Afiles'First then + Ali_Files := new Argument_List'(Afiles (1 .. A - 1)); + end if; + + if G /= Gopts'First then + Options := new Argument_List'(Gopts (1 .. G - 1)); + end if; + + if L /= Lopts'First then + Largs_Options := new Argument_List'(Lopts (1 .. L - 1)); + end if; + + if B /= Bopts'First then + Bargs_Options := new Argument_List'(Bopts (1 .. B - 1)); + end if; + + exception + when Invalid_Switch => + Raise_Exception + (Syntax_Error'Identity, + Message => "Invalid Switch " & Full_Switch); + + when Invalid_Parameter => + Raise_Exception + (Syntax_Error'Identity, + Message => "No parameter for " & Full_Switch); + end Parse_Command_Line; + + ------------------- + -- Check_Context -- + ------------------- + + procedure Check_Context is + begin + Check (To_String (Def_Filename)); + + -- Check that each object file specified exists and raise exception + -- Context_Error if it does not. + + for F in Objects_Files'Range loop + Check (Objects_Files (F).all); + end loop; + end Check_Context; + +-- Start of processing for Gnatdll + +begin + if Ada.Command_Line.Argument_Count = 0 then + Help := True; + else + Parse_Command_Line; + end if; + + if MDLL.Verbose or else Help then + New_Line; + Put_Line ("GNATDLL " & Version & " - Dynamic Libraries Builder"); + New_Line; + end if; + + MDLL.Utl.Locate; + + if Help + or else (MDLL.Verbose and then Ada.Command_Line.Argument_Count = 1) + then + Syntax; + else + Check_Context; + + case Build_Mode is + when Import_Lib => + MDLL.Build_Import_Library + (To_String (Lib_Filename), + To_String (Def_Filename)); + + when Dynamic_Lib => + MDLL.Build_Dynamic_Library + (Objects_Files.all, + Ali_Files.all, + Options.all, + Bargs_Options.all, + Largs_Options.all, + To_String (Lib_Filename), + To_String (Def_Filename), + To_String (DLL_Address), + Build_Import => True, + Relocatable => Must_Build_Relocatable, + Map_File => Gen_Map_File); + + when Dynamic_Lib_Only => + MDLL.Build_Dynamic_Library + (Objects_Files.all, + Ali_Files.all, + Options.all, + Bargs_Options.all, + Largs_Options.all, + To_String (Lib_Filename), + To_String (Def_Filename), + To_String (DLL_Address), + Build_Import => False, + Relocatable => Must_Build_Relocatable, + Map_File => Gen_Map_File); + + when Nil => + null; + end case; + end if; + + Set_Exit_Status (Success); + +exception + when SE : Syntax_Error => + Put_Line ("Syntax error : " & Exception_Message (SE)); + New_Line; + Syntax; + Set_Exit_Status (Failure); + + when E : MDLL.Tools_Error | Context_Error => + Put_Line (Exception_Message (E)); + Set_Exit_Status (Failure); + + when others => + Put_Line ("gnatdll: INTERNAL ERROR. Please report"); + Set_Exit_Status (Failure); +end Gnatdll; diff --git a/gcc/ada/gnatfind.adb b/gcc/ada/gnatfind.adb new file mode 100644 index 000000000..8af7b9e4f --- /dev/null +++ b/gcc/ada/gnatfind.adb @@ -0,0 +1,389 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T F I N D -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Opt; +with Osint; use Osint; +with Switch; use Switch; +with Types; use Types; +with Xr_Tabls; use Xr_Tabls; +with Xref_Lib; use Xref_Lib; + +with Ada.Strings.Fixed; use Ada.Strings.Fixed; +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.Command_Line; use GNAT.Command_Line; + +with System.Strings; use System.Strings; + +-------------- +-- Gnatfind -- +-------------- + +procedure Gnatfind is + Output_Ref : Boolean := False; + Pattern : Xref_Lib.Search_Pattern; + Local_Symbols : Boolean := True; + Prj_File : File_Name_String; + Prj_File_Length : Natural := 0; + Nb_File : Natural := 0; + Usage_Error : exception; + Full_Path_Name : Boolean := False; + Have_Entity : Boolean := False; + Wide_Search : Boolean := True; + Glob_Mode : Boolean := True; + Der_Info : Boolean := False; + Type_Tree : Boolean := False; + Read_Only : Boolean := False; + Source_Lines : Boolean := False; + + Has_File_In_Entity : Boolean := False; + -- Will be true if a file name was specified in the entity + + RTS_Specified : String_Access := null; + -- Used to detect multiple use of --RTS= switch + + EXT_Specified : String_Access := null; + -- Used to detect multiple use of --ext= switch + + procedure Parse_Cmd_Line; + -- Parse every switch on the command line + + procedure Usage; + -- Display the usage + + procedure Write_Usage; + -- Print a small help page for program usage and exit program + + -------------------- + -- Parse_Cmd_Line -- + -------------------- + + procedure Parse_Cmd_Line is + + procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); + + -- Start of processing for Parse_Cmd_Line + + begin + -- First check for --version or --help + + Check_Version_And_Help ("GNATFIND", "1998"); + + -- Now scan the other switches + + GNAT.Command_Line.Initialize_Option_Scan; + + loop + case + GNAT.Command_Line.Getopt + ("a aI: aO: d e f g h I: nostdinc nostdlib p: r s t -RTS= -ext=") + is + when ASCII.NUL => + exit; + + when 'a' => + if GNAT.Command_Line.Full_Switch = "a" then + Read_Only := True; + elsif GNAT.Command_Line.Full_Switch = "aI" then + Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter); + else + Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter); + end if; + + when 'd' => + Der_Info := True; + + when 'e' => + Glob_Mode := False; + + when 'f' => + Full_Path_Name := True; + + when 'g' => + Local_Symbols := False; + + when 'h' => + Write_Usage; + + when 'I' => + Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter); + Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter); + + when 'n' => + if GNAT.Command_Line.Full_Switch = "nostdinc" then + Opt.No_Stdinc := True; + elsif GNAT.Command_Line.Full_Switch = "nostdlib" then + Opt.No_Stdlib := True; + end if; + + when 'p' => + declare + S : constant String := GNAT.Command_Line.Parameter; + begin + Prj_File_Length := S'Length; + Prj_File (1 .. Prj_File_Length) := S; + end; + + when 'r' => + Output_Ref := True; + + when 's' => + Source_Lines := True; + + when 't' => + Type_Tree := True; + + -- Only switch starting with -- recognized is --RTS + + when '-' => + if GNAT.Command_Line.Full_Switch = "-RTS" then + + -- Check that it is the first time we see this switch + + if RTS_Specified = null then + RTS_Specified := new String'(GNAT.Command_Line.Parameter); + elsif RTS_Specified.all /= GNAT.Command_Line.Parameter then + Osint.Fail ("--RTS cannot be specified multiple times"); + end if; + + Opt.No_Stdinc := True; + Opt.RTS_Switch := True; + + declare + Src_Path_Name : constant String_Ptr := + Get_RTS_Search_Dir + (GNAT.Command_Line.Parameter, + Include); + Lib_Path_Name : constant String_Ptr := + Get_RTS_Search_Dir + (GNAT.Command_Line.Parameter, + Objects); + + begin + if Src_Path_Name /= null + and then Lib_Path_Name /= null + then + Add_Search_Dirs (Src_Path_Name, Include); + Add_Search_Dirs (Lib_Path_Name, Objects); + + elsif Src_Path_Name = null + and then Lib_Path_Name = null + then + Osint.Fail ("RTS path not valid: missing " & + "adainclude and adalib directories"); + + elsif Src_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adainclude directory"); + + elsif Lib_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adalib directory"); + end if; + end; + + -- Process -ext switch + + elsif GNAT.Command_Line.Full_Switch = "-ext" then + + -- Check that it is the first time we see this switch + + if EXT_Specified = null then + EXT_Specified := new String'(GNAT.Command_Line.Parameter); + elsif EXT_Specified.all /= GNAT.Command_Line.Parameter then + Osint.Fail ("--ext cannot be specified multiple times"); + end if; + + if + EXT_Specified'Length = Osint.ALI_Default_Suffix'Length + then + Osint.ALI_Suffix := EXT_Specified.all'Access; + else + Osint.Fail ("--ext argument must have 3 characters"); + end if; + + end if; + + when others => + Write_Usage; + end case; + end loop; + + -- Get the other arguments + + loop + declare + S : constant String := GNAT.Command_Line.Get_Argument; + + begin + exit when S'Length = 0; + + -- First argument is the pattern + + if not Have_Entity then + Add_Entity (Pattern, S, Glob_Mode); + Have_Entity := True; + + if not Has_File_In_Entity + and then Index (S, ":") /= 0 + then + Has_File_In_Entity := True; + end if; + + -- Next arguments are the files to search + + else + Add_Xref_File (S); + Wide_Search := False; + Nb_File := Nb_File + 1; + end if; + end; + end loop; + + exception + when GNAT.Command_Line.Invalid_Switch => + Ada.Text_IO.Put_Line ("Invalid switch : " + & GNAT.Command_Line.Full_Switch); + Write_Usage; + + when GNAT.Command_Line.Invalid_Parameter => + Ada.Text_IO.Put_Line ("Parameter missing for : " + & GNAT.Command_Line.Full_Switch); + Write_Usage; + + when Xref_Lib.Invalid_Argument => + Ada.Text_IO.Put_Line ("Invalid line or column in the pattern"); + Write_Usage; + end Parse_Cmd_Line; + + ----------- + -- Usage -- + ----------- + + procedure Usage is + begin + Put_Line ("Usage: gnatfind pattern[:sourcefile[:line[:column]]] " + & "[file1 file2 ...]"); + New_Line; + Put_Line (" pattern Name of the entity to look for (can have " + & "wildcards)"); + Put_Line (" sourcefile Only find entities referenced from this " + & "file"); + Put_Line (" line Only find entities referenced from this line " + & "of file"); + Put_Line (" column Only find entities referenced from this columns" + & " of file"); + Put_Line (" file ... Set of Ada source files to search for " + & "references. This parameters are optional"); + New_Line; + Put_Line ("gnatfind switches:"); + Put_Line (" -a Consider all files, even when the ali file is " + & "readonly"); + Put_Line (" -aIdir Specify source files search path"); + Put_Line (" -aOdir Specify library/object files search path"); + Put_Line (" -d Output derived type information"); + Put_Line (" -e Use the full regular expression set for " + & "pattern"); + Put_Line (" -f Output full path name"); + Put_Line (" -g Output information only for global symbols"); + Put_Line (" -Idir Like -aIdir -aOdir"); + Put_Line (" -nostdinc Don't look for sources in the system default" + & " directory"); + Put_Line (" -nostdlib Don't look for library files in the system" + & " default directory"); + Put_Line (" --ext=xxx Specify alternate ali file extension"); + Put_Line (" --RTS=dir specify the default source and object search" + & " path"); + Put_Line (" -p file Use file as the default project file"); + Put_Line (" -r Find all references (default to find declaration" + & " only)"); + Put_Line (" -s Print source line"); + Put_Line (" -t Print type hierarchy"); + end Usage; + + ----------------- + -- Write_Usage -- + ----------------- + + procedure Write_Usage is + begin + Display_Version ("GNATFIND", "1998"); + New_Line; + + Usage; + + raise Usage_Error; + end Write_Usage; + +-- Start of processing for Gnatfind + +begin + Parse_Cmd_Line; + + if not Have_Entity then + Write_Usage; + end if; + + -- Special case to speed things up: if the user has a command line of the + -- form 'gnatfind entity:file', i.e. has specified a file and only wants + -- the bodies and specs, then we can restrict the search to the .ali file + -- associated with 'file'. + + if Has_File_In_Entity + and then not Output_Ref + then + Wide_Search := False; + end if; + + -- Find the project file + + if Prj_File_Length = 0 then + Xr_Tabls.Create_Project_File (Default_Project_File (".")); + else + Xr_Tabls.Create_Project_File (Prj_File (1 .. Prj_File_Length)); + end if; + + -- Fill up the table + + if Type_Tree and then Nb_File > 1 then + Ada.Text_IO.Put_Line ("Error: for type hierarchy output you must " + & "specify only one file."); + Ada.Text_IO.New_Line; + Write_Usage; + end if; + + Search (Pattern, Local_Symbols, Wide_Search, Read_Only, + Der_Info, Type_Tree); + + if Source_Lines then + Xr_Tabls.Grep_Source_Files; + end if; + + Print_Gnatfind (Output_Ref, Full_Path_Name); + +exception + when Usage_Error => + null; +end Gnatfind; diff --git a/gcc/ada/gnathtml.pl b/gcc/ada/gnathtml.pl new file mode 100644 index 000000000..548fde1ef --- /dev/null +++ b/gcc/ada/gnathtml.pl @@ -0,0 +1,1114 @@ +#! /usr/bin/env perl + +#----------------------------------------------------------------------------- +#- -- +#- GNAT COMPILER COMPONENTS -- +#- -- +#- G N A T H T M L -- +#- -- +#- 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. See the GNU General Public License -- +#- for more details. You should have received a copy of the GNU General -- +#- Public License distributed with GNAT; see file COPYING3. If not see -- +#- . -- +#- -- +#- GNAT was originally developed by the GNAT team at New York University. -- +#- Extensive contributions were provided by Ada Core Technologies Inc. -- +#- -- +#----------------------------------------------------------------------------- + +## This script converts an Ada file (and its dependency files) to Html. +## Keywords, comments and strings are color-hilighted. If the cross-referencing +## information provided by Gnat (when not using the -gnatx switch) is found, +## the html files will also have some cross-referencing features, i.e. if you +## click on a type, its declaration will be displayed. +## +## To find more about the switches provided by this script, please use the +## following command : +## perl gnathtml.pl -h +## You may also change the first line of this script to indicates where Perl is +## installed on your machine, so that you can just type +## gnathtml.pl -h +## +## Unless you supply another directory with the -odir switch, the html files +## will be saved saved in a html subdirectory + +use Cwd 'abs_path'; +use File::Basename; + +### Print help if necessary +sub print_usage +{ + print "Usage is:\n"; + print " $0 [switches] main_file[.adb] main_file2[.adb] ...\n"; + print " -83 : Use Ada83 keywords only (default is Ada95)\n"; + print " -cc color : Choose the color for comments\n"; + print " -d : Convert also the files which main_file depends on\n"; + print " -D : same as -d, also looks for files in the standard library\n"; + print " -f : Include cross-references for local entities too\n"; + print " -absolute : Display absolute filenames in the headers\n"; + print " -h : Print this help page\n"; + print " -lnb : Display line numbers every nb lines\n"; + print " -Idir : Specify library/object files search path\n"; + print " -odir : Name of the directory where the html files will be\n"; + print " saved. Default is 'html/'\n"; + print " -pfile : Use file as a project file (.adp file)\n"; + print " -sc color : Choose the color for symbol definitions\n"; + print " -Tfile : Read the name of the files from file rather than the\n"; + print " command line\n"; + print " -ext ext : Choose the generated file names extension (default\n"; + print " is htm)\n"; + print "This program attempts to generate an html file from an Ada file\n"; + exit; +} + +### Parse the command line +local ($ada83_mode) = 0; +local ($prjfile) = ""; +local (@list_files) = (); +local ($line_numbers) = 0; +local ($dependencies) = 0; +local ($standard_library) = 0; +local ($output_dir) = "html"; +local ($xref_variable) = 0; +local (@search_dir) = ('.'); +local ($tab_size) = 8; +local ($comment_color) = "green"; +local ($symbol_color) = "red"; +local ($absolute) = 0; +local ($fileext) = "htm"; + +while ($_ = shift @ARGV) +{ + /^-83$/ && do { $ada83_mode = 1; }; + /^-d$/ && do { $dependencies = 1; }; + /^-D$/ && do { $dependencies = 1; + $standard_library = 1; }; + /^-f$/ && do { $xref_variable = 1; }; + /^-absolute$/ && do {$absolute = 1; }; + /^-h$/ && do { &print_usage; }; + /^[^-]/ && do { $_ .= ".adb" if (! /\.ad[bs]$/); + push (@list_files, $_); }; + + if (/^-o\s*(.*)$/) + { + $output_dir = ($1 eq "") ? shift @ARGV : $1; + chop $output_dir if ($output_dir =~ /\/$/); + &print_usage if ($output_dir =~ /^-/ || $output_dir eq ""); + } + + if (/^-T\s*(.*)$/) + { + my ($source_file) = ($1 eq "") ? shift @ARGV : $1; + local (*SOURCE); + open (SOURCE, "$source_file") || die "file not found: $source_file"; + while () { + @files = split; + foreach (@files) { + $_ .= ".adb" if (! /\.ad[bs]$/); + push (@list_files, $_); + } + } + } + + if (/^-cc\s*(.*)$/) + { + $comment_color = ($1 eq "") ? shift @ARGV : $1; + &print_usage if ($comment_color =~ /^-/ || $comment_color eq ""); + } + + if (/^-sc\s*(.*)$/) + { + $symbol_color = ($1 eq "") ? shift @ARGV : $1; + &print_usage if ($symbol_color =~ /^-/ || $symbol_color eq ""); + } + + if (/^-I\s*(.*)$/) + { + push (@search_dir, ($1 eq "") ? scalar (shift @ARGV) : $1); + } + + if (/^-p\s*(.*)$/) + { + $prjfile = ($1 eq "") ? shift @ARGV : $1; + &print_usage if ($prjfile =~ /^-/ || $prjfile eq ""); + } + + if (/^-l\s*(.*)$/) + { + $line_numbers = ($1 eq "") ? shift @ARGV : $1; + &print_usage if ($line_numbers =~ /^-/ || $line_numbers eq ""); + } + + if (/^-ext\s*(.*)$/) + { + $fileext = ($1 eq "") ? shift @ARGV : $1; + &print_usage if ($fileext =~ /^-/ || $fileext eq ""); + } +} + +&print_usage if ($#list_files == -1); +local (@original_list) = @list_files; + +## This regexp should match all the files from the standard library (and only them) +## Note that at this stage the '.' in the file names has been replaced with __ +$standard_file_regexp="^([agis]-|ada__|gnat__|system__|interface__).*\$"; + +local (@src_dir) = (); +local (@obj_dir) = (); + +if ($standard_library) { + open (PIPE, "gnatls -v | "); + local ($mode) = ""; + while (defined ($_ = )) { + chop; + s/^\s+//; + $_ = './' if (//); + next if (/^$/); + + if (/Source Search Path:/) { + $mode = 's'; + } + elsif (/Object Search Path:/) { + $mode = 'o'; + } + elsif ($mode eq 's') { + push (@src_dir, $_); + } + elsif ($mode eq 'o') { + push (@obj_dir, $_); + } + } + close (PIPE); +} +else +{ + push (@src_dir, "./"); + push (@obj_dir, "./"); +} + +foreach (@list_files) { + local ($dir) = $_; + $dir =~ s/\/([^\/]+)$//; + push (@src_dir, $dir. '/'); + push (@obj_dir, $dir. '/'); +} + +### Defines and compiles the Ada key words : +local (@Ada_keywords) = ('abort', 'abs', 'accept', 'access', 'all', 'and', + 'array', 'at', 'begin', 'body', 'case', 'constant', + 'declare', 'delay', 'delta', 'digits', 'do', 'else', + 'elsif', 'end', 'entry', 'exception', 'exit', 'for', + 'function', 'generic', 'goto', 'if', 'in', 'is', + 'limited', 'loop', 'mod', 'new', 'not', 'null', 'of', + 'or', 'others', 'out', 'package', 'pragma', 'private', + 'procedure', 'raise', 'range', 'record', 'rem', + 'renames', 'return', 'reverse', 'select', 'separate', + 'subtype', 'task', 'terminate', 'then', 'type', + 'until', 'use', 'when', 'while', 'with', 'xor'); +local (@Ada95_keywords) = ('abstract', 'aliased', 'protected', 'requeue', + 'tagged'); + +local (%keywords) = (); +grep (++ $keywords{$_}, @Ada_keywords); +grep (++ $keywords{$_}, @Ada95_keywords) unless ($ada83_mode); + +### Symbols declarations for the current file +### format is (line_column => 1, ...) +local (%symbols); + +### Symbols usage for the current file +### format is ($adafile#$line_$column => $htmlfile#$linedecl_$columndecl, ...) +local (%symbols_used); + +### the global index of all symbols +### format is ($name => [[file, line, column], [file, line, column], ...]) +local (%global_index); + +######### +## This function create the header of every html file. +## These header is returned as a string +## Params: - Name of the Ada file associated with this html file +######### +sub create_header +{ + local ($adafile) = shift; + local ($string) = "$adafile +\n"; + + if ($adafile ne "") + { + $string .= "

File : $adafile " + . "

\n
";
+  }
+  return $string;
+}
+
+#########
+##  Protect a string (or character) from the Html parser
+##  Params: - the string to protect
+##  Out:    - the protected string
+#########
+sub protect_string
+{
+    local ($string) = shift;
+    $string =~ s/&/&/g;
+    $string =~ s//>/g;
+    return $string;
+}
+
+#########
+##  This function creates the footer of the html file
+##  The footer is returned as a string
+##  Params :  - Name of the Ada file associated with this html file
+#########
+sub create_footer
+{
+  local ($adafile) = shift;
+  local ($string) = "";
+  $string = "
" if ($adafile ne ""); + return $string . "\n"; +} + +######### +## This function creates the string to use for comment output +## Params : - the comment itself +######### +sub output_comment +{ + local ($comment) = &protect_string (shift); + return "--$comment"; +} + +######## +## This function creates the string to use for symbols output +## Params : - the symbol to output +## - the current line +## - the current column +######## +sub output_symbol +{ + local ($symbol) = &protect_string (shift); + local ($lineno) = shift; + local ($column) = shift; + return "$symbol"; +} + +######## +## This function creates the string to use for keyword output +## Params : - the keyword to output +######## +sub output_keyword +{ + local ($keyw) = shift; + return "$keyw"; +} + +######## +## This function outputs a line number +## Params : - the line number to generate +######## +sub output_line_number +{ + local ($no) = shift; + if ($no != -1) + { + return "" . sprintf ("%4d ", $no) . ""; + } + else + { + return " "; + } +} + +######## +## Converts a character into the corresponding Ada type +## This is based on the ali format (see lib-xref.adb) in the GNAT sources +## Note: 'f' or 'K' should be returned in case a link from the body to the +## spec needs to be generated. +## Params : - the character to convert +######## +sub to_type +{ + local ($char) = shift; + $char =~ tr/a-z/A-Z/; + + return 'array' if ($char eq 'A'); + return 'boolean' if ($char eq 'B'); + return 'class' if ($char eq 'C'); + return 'decimal' if ($char eq 'D'); + return 'enumeration' if ($char eq 'E'); + return 'floating point' if ($char eq 'F'); + return 'signed integer' if ($char eq 'I'); + # return 'generic package' if ($char eq 'K'); + return 'block' if ($char eq 'L'); + return 'modular integer' if ($char eq 'M'); + return 'enumeration literal' if ($char eq 'N'); + return 'ordinary fixed point' if ($char eq 'O'); + return 'access' if ($char eq 'P'); + return 'label' if ($char eq 'Q'); + return 'record' if ($char eq 'R'); + return 'string' if ($char eq 'S'); + return 'task' if ($char eq 'T'); + return 'f' if ($char eq 'U'); + return 'f' if ($char eq 'V'); + return 'exception' if ($char eq 'X'); + return 'entry' if ($char eq 'Y'); + return "$char"; +} + +######## +## Changes a file name to be http compatible +######## +sub http_string +{ + local ($str) = shift; + $str =~ s/\//__/g; + $str =~ s/\\/__/g; + $str =~ s/:/__/g; + $str =~ s/\./__/g; + return $str; +} + +######## +## Creates the complete file-name, with directory +## use the variables read in the .prj file +## Params : - file name +## RETURNS : the relative path_name to the file +######## +sub get_real_file_name +{ + local ($filename) = shift; + local ($path) = $filename; + + foreach (@src_dir) + { + if ( -r "$_$filename") + { + $path = "$_$filename"; + last; + } + } + + $path =~ s/^\.\///; + return $path if (substr ($path, 0, 1) ne '/'); + + ## We want to return relative paths only, so that the name of the HTML files + ## can easily be generated + local ($pwd) = `pwd`; + chop ($pwd); + local (@pwd) = split (/\//, $pwd); + local (@path) = split (/\//, $path); + + while (@pwd) + { + if ($pwd [0] ne $path [0]) + { + return '../' x ($#pwd + 1) . join ("/", @path); + } + shift @pwd; + shift @path; + } + return join ('/', @path); +} + +######## +## Reads and parses .adp files +## Params : - adp file name +######## +sub parse_prj_file +{ + local ($filename) = shift; + local (@src) = (); + local (@obj) = (); + + print "Parsing project file : $filename\n"; + + open (PRJ, $filename) || do { print " ... sorry, file not found\n"; + return; + }; + while () + { + chop; + s/\/$//; + push (@src, $1 . "/") if (/^src_dir=(.*)/); + push (@obj, $1 . "/") if (/^obj_dir=(.*)/); + } + unshift (@src_dir, @src); + unshift (@obj_dir, @obj); + close (PRJ); +} + +######## +## Finds a file in the search path +## Params : - the name of the file +## RETURNS : - the directory/file_name +######## +sub find_file +{ + local ($filename) = shift; + + foreach (@search_dir) { + if (-f "$_/$filename") { + return "$_/$filename"; + } + } + return $filename; +} + +######## +## Inserts a new reference in the list of references +## Params: - Ref as it appears in the .ali file ($line$type$column) +## - Current file for the reference +## - Current offset to be added from the line (handling of +## pragma Source_Reference) +## - Current entity reference +## Modifies: - %symbols_used +######## +sub create_new_reference +{ + local ($ref) = shift; + local ($lastfile) = shift; + local ($offset) = shift; + local ($currentref) = shift; + local ($refline, $type, $refcol); + + ## Do not generate references to the standard library files if we + ## do not generate the corresponding html files + return if (! $standard_library && $lastfile =~ /$standard_file_regexp/); + + ($refline, $type, $extern, $refcol) = /(\d+)(.)(<[^>]+>)?(\d+)/; + $refline += $offset; + + ## If we have a body, then we only generate the cross-reference from + ## the spec to the body if we have a subprogram (or a package) + + + if ($type eq "b") +# && ($symbols {$currentref} eq 'f' || $symbols {$currentref} eq 'K')) + { + local ($cref_file, $cref) = ($currentref =~ /([^\#]+).$fileext\#(.+)/); + + $symbols_used {"$cref_file#$cref"} = "$lastfile.$fileext#$refline\_$refcol"; + $symbols_used {"$lastfile#$refline\_$refcol"} = $currentref; + $symbols {"$lastfile.$fileext#$refline\_$refcol"} = "body"; + } + + ## Do not generate cross-references for "e" and "t", since these point to the + ## semicolon that terminates the block -- irrelevant for gnathtml + ## "p" is also removed, since it is used for primitive subprograms + ## "d" is also removed, since it is used for discriminants + ## "i" is removed since it is used for implicit references + ## "z" is used for generic formals + ## "k" is for references to parent package + ## "=", "<", ">", "^" is for subprogram parameters + + elsif ($type !~ /[eztpid=<>^k]/) + { + $symbols_used {"$lastfile#$refline\_$refcol"} = $currentref; + } +} + +######## +## Parses the ali file associated with the current Ada file +## Params : - the complete ali file name +######## +sub parse_ali +{ + local ($filename) = shift; + local ($currentfile); + local ($currentref); + local ($lastfile); + + # A file | line type column reference + local ($reference) = "(?:(?:\\d+\\|)?\\d+.\\d+|\\w+)"; + + # The following variable is used to represent the possible xref information + # output by GNAT when -gnatdM is used. It includes renaming references, and + # references to the parent type, as well as references to the generic parent + + local ($typeref) = "(?:=$reference|<$reference>|\\{$reference\\}|\\($reference\\)|\\[$reference\\])?"; + + # The beginning of an entity declaration line in the ALI file + local ($decl_line) = "^(\\d+)(.)(\\d+)[ *]([\\w\\d.-]+|\"..?\")$typeref\\s+(\\S.*)?\$"; + + # Contains entries of the form [ filename source_reference_offset] + # Offset needs to be added to the lines read in the cross-references, and are + # used when the source comes from a gnatchop-ed file. See lib-write.ads, lines + # with ^D in the ALI file. + local (@reffiles) = (); + + open (ALI, &find_file ($filename)) || do { + print "no ", &find_file ($filename), " file...\n"; + return; + }; + local (@ali) = ; + close (ALI); + + undef %symbols; + undef %symbols_used; + + foreach (@ali) + { + ## The format of D lines is + ## D source-name time-stamp checksum [subunit-name] line:file-name + + if (/^D\s+([\w\d.-]+)\s+\S+ \S+(\s+\D[^: ]+)?( (\d+):(.*))?/) + { + # The offset will be added to each cross-reference line. If it is + # greater than 1, this means that we have a pragma Source_Reference, + # and this must not be counted in the xref information. + my ($file, $offset) = ($1, (defined $4) ? 2 - $4 : 0); + + if ($dependencies) + { + push (@list_files, $1) unless (grep (/$file/, @list_files)); + } + push (@reffiles, [&http_string (&get_real_file_name ($file)), $offset]); + } + + elsif (/^X\s+(\d+)/) + { + $currentfile = $lastfile = $1 - 1; + } + + elsif (defined $currentfile && /$decl_line/) + { + my ($line) = $1 + $reffiles[$currentfile][1]; + next if (! $standard_library + && $reffiles[$currentfile][0] =~ /$standard_file_regexp/); + if ($xref_variable || $2 eq &uppercases ($2)) + { + $currentref = $reffiles[$currentfile][0] . ".$fileext#$line\_$3"; + $symbols {$currentref} = &to_type ($2); + $lastfile = $currentfile; + + local ($endofline) = $5; + + foreach (split (" ", $endofline)) + { + (s/^(\d+)\|//) && do { $lastfile = $1 - 1; }; + &create_new_reference + ($_, $reffiles[$lastfile][0], + $reffiles[$lastfile][1], $currentref); + } + } + else + { + $currentref = ""; + } + } + elsif (/^\.\s(.*)/ && $reffiles[$currentfile][0] ne "" && $currentref ne "") + { + next if (! $standard_library + && $reffiles[$currentfile][0] =~ /$standard_file_regexp/); + foreach (split (" ", $1)) + { + (s/^(\d+)\|//) && do { $lastfile = $1 - 1; }; + &create_new_reference + ($_, $reffiles[$lastfile][0], $reffiles[$lastfile][1], + $currentref); + } + } + } +} + +######### +## Return the name of the ALI file to use for a given source +## Params: - Name of the source file +## return: Name and location of the ALI file +######### + +sub ali_file_name { + local ($source) = shift; + local ($alifilename, $unitname); + local ($in_separate) = 0; + + $source =~ s/\.ad[sb]$//; + $alifilename = $source; + $unitname = $alifilename; + $unitname =~ s/-/./g; + + ## There are two reasons why we might not find the ALI file: either the + ## user did not generate them at all, or we are working on a separate unit. + ## Thus, we search in the parent's ALI file. + + while ($alifilename ne "") { + + ## Search in the object path + foreach (@obj_dir) { + + ## Check if the ALI file does apply to the source file + ## We check the ^D lines, which have the following format: + ## D source-name time-stamp checksum [subunit-name] line:file-name + + if (-r "$_$alifilename.ali") { + if ($in_separate) { + open (FILE, "$_$alifilename.ali"); + + if (grep (/^D \S+\s+\S+\s+\S+ $unitname/, )) { + close FILE; + return "$_$alifilename.ali"; + + } else { + ## If the ALI file doesn't apply to the source file, we can + ## return now, since there won't be a parent ALI file above + ## anyway + close FILE; + return "$source.ali"; + } + } else { + return "$_$alifilename.ali"; + } + } + } + + ## Get the parent's ALI file name + + if (! ($alifilename =~ s/-[^-]+$//)) { + $alifilename = ""; + } + $in_separate = 1; + } + + return "$source.ali"; +} + +######### +## Convert a path to an absolute path +######### + +sub to_absolute +{ + local ($path) = shift; + local ($name, $suffix, $separator); + ($name,$path,$suffix) = fileparse ($path, ()); + $path = &abs_path ($path); + $separator = substr ($path, 0, 1); + return $path . $separator . $name; +} + +######### +## This function outputs the html version of the file FILE +## The output is send to FILE.htm. +## Params : - Name of the file to convert (ends with .ads or .adb) +######### +sub output_file +{ + local ($filename_param) = shift; + local ($lineno) = 1; + local ($column); + local ($found); + + local ($alifilename) = &ali_file_name ($filename_param); + + $filename = &get_real_file_name ($filename_param); + $found = &find_file ($filename); + + ## Read the whole file + open (FILE, $found) || do { + print $found, " not found ... skipping.\n"; + return 0; + }; + local (@file) = ; + close (FILE); + + ## Parse the .ali file to find the cross-references + print "converting ", $filename, "\n"; + &parse_ali ($alifilename); + + ## Create and initialize the html file + open (OUTPUT, ">$output_dir/" . &http_string ($filename) . ".$fileext") + || die "Couldn't write $output_dir/" . &http_string ($filename) + . ".$fileext\n"; + + if ($absolute) { + print OUTPUT &create_header (&to_absolute ($found)), "\n"; + } else { + print OUTPUT &create_header ($filename_param), "\n"; + } + + ## Print the file + $filename = &http_string ($filename); + foreach (@file) + { + local ($index); + local ($line) = $_; + local ($comment); + + $column = 1; + chop ($line); + + ## Print either the line number or a space if required + if ($line_numbers) + { + if ($lineno % $line_numbers == 0) + { + print OUTPUT &output_line_number ($lineno); + } + else + { + print OUTPUT &output_line_number (-1); + } + } + + ## First, isolate any comment on the line + undef $comment; + $index = index ($line, '--'); + if ($index != -1) { + $comment = substr ($line, $index + 2); + if ($index > 1) + { + $line = substr ($line, 0, $index); + } + else + { + undef $line; + } + } + + ## Then print the line + if (defined $line) + { + $index = 0; + while ($index < length ($line)) + { + local ($substring) = substr ($line, $index); + + if ($substring =~ /^\t/) + { + print OUTPUT ' ' x ($tab_size - (($column - 1) % $tab_size)); + $column += $tab_size - (($column - 1) % $tab_size); + $index ++; + } + elsif ($substring =~ /^(\w+)/ + || $substring =~ /^("[^\"]*")/ + || $substring =~ /^(\W)/) + { + local ($word) = $1; + $index += length ($word); + + local ($lowercase) = $word; + $lowercase =~ tr/A-Z/a-z/; + + if ($keywords{$lowercase}) + { + print OUTPUT &output_keyword ($word); + } + elsif ($symbols {"$filename.$fileext#$lineno\_$column"}) + { + ## A symbol can both have a link and be a reference for + ## another link, as is the case for bodies and + ## declarations + + if ($symbols_used{"$filename#$lineno\_$column"}) + { + print OUTPUT "", &protect_string ($word), ""; + print OUTPUT &output_symbol ('', $lineno, $column); + } + else + { + print OUTPUT &output_symbol ($word, $lineno, $column); + } + + ## insert only functions into the global index + + if ($symbols {"$filename.$fileext#$lineno\_$column"} eq 'f') + { + push (@{$global_index {$word}}, + [$filename_param, $filename, $lineno, $column]); + } + } + elsif ($symbols_used{"$filename#$lineno\_$column"}) + { + print OUTPUT "", &protect_string ($word), ""; + } + else + { + print OUTPUT &protect_string ($word); + } + $column += length ($word); + } + else + { + $index ++; + $column ++; + print OUTPUT &protect_string (substr ($substring, 0, 1)); + } + } + } + + ## Then output the comment + print OUTPUT &output_comment ($comment) if (defined $comment); + print OUTPUT "\n"; + + $lineno ++; + } + + print OUTPUT &create_footer ($filename); + close (OUTPUT); + return 1; +} + +######### +## This function generates the global index +######### +sub create_index_file +{ + open (INDEX, ">$output_dir/index.$fileext") || die "couldn't write $output_dir/index.$fileext"; + + print INDEX <<"EOF"; + +Source Browser + + +EOF + ; + + local (@files) = &create_file_index; + print INDEX join ("\n", @files), "\n"; + + print INDEX "
\n"; + local (@functions) = &create_function_index; + print INDEX join ("\n", @functions), "\n"; + + print INDEX <<"EOF"; + + + + + + + + +EOF + ; + close (INDEX); + + open (MAIN, ">$output_dir/main.$fileext") || die "couldn't write $output_dir/main.$fileext"; + print MAIN &create_header (""), + "

", + "[No frame version is here]", + "

", + join ("\n", @files), "\n

", + join ("\n", @functions), "\n"; + + if ($dependencies) { + print MAIN "
\n"; + print MAIN "You should start your browsing with one of these files:\n"; + print MAIN "
    \n"; + foreach (@original_list) { + print MAIN "
  • $_\n"; + } + } + print MAIN &create_footer (""); + close (MAIN); +} + +####### +## Convert to upper cases (did not exist in Perl 4) +####### + +sub uppercases { + local ($tmp) = shift; + $tmp =~ tr/a-z/A-Z/; + return $tmp; +} + +####### +## This function generates the file_index +## RETURN : - table with the html lines to be printed +####### +sub create_file_index +{ + local (@output) = ("

    Files

    "); + + + open (FILES, ">$output_dir/files.$fileext") || die "couldn't write $output_dir/files.$fileext"; + print FILES &create_header (""), join ("\n", @output), "\n"; + + + if ($#list_files > 20) + { + local ($last_letter) = ''; + foreach (sort {&uppercases ($a) cmp &uppercases ($b)} @list_files) + { + next if ($_ eq ""); + if (&uppercases (substr ($_, 0, 1)) ne $last_letter) + { + if ($last_letter ne '') + { + print INDEX_FILE "
\n"; + close (INDEX_FILE); + } + $last_letter = &uppercases (substr ($_, 0, 1)); + open (INDEX_FILE, ">$output_dir/files/$last_letter.$fileext") + || die "couldn't write $output_dir/files/$last_letter.$fileext"; + print INDEX_FILE <<"EOF"; +$last_letter + +

Files - $last_letter

+[index] +
    +EOF + ; + local ($str) = "[$last_letter]"; + push (@output, $str); + print FILES "$str\n"; + } + print INDEX_FILE "
  • $_\n"; ## Problem with TARGET when in no_frame mode! + } + + print INDEX_FILE "
\n"; + close INDEX_FILE; + } + else + { + push (@output, "
    "); + print FILES "
      "; + foreach (sort {&uppercases ($a) cmp &uppercases ($b)} @list_files) + { + next if ($_ eq ""); + local ($ref) = &http_string (&get_real_file_name ($_)); + push (@output, "
    • $_"); + print FILES "
    • $_\n"; + } + } + + print FILES &create_footer (""); + close (FILES); + + push (@output, "
    "); + return @output; +} + +####### +## This function generates the function_index +## RETURN : - table with the html lines to be printed +####### +sub create_function_index +{ + local (@output) = ("

    Functions/Procedures

    "); + local ($initial) = ""; + + open (FUNCS, ">$output_dir/funcs.$fileext") || die "couldn't write $output_dir/funcs.$fileext"; + print FUNCS &create_header (""), join ("\n", @output), "\n"; + + ## If there are more than 20 entries, we just want to create some + ## submenus + if (scalar (keys %global_index) > 20) + { + local ($last_letter) = ''; + foreach (sort {&uppercases ($a) cmp &uppercases ($b)} keys %global_index) + { + if (&uppercases (substr ($_, 0, 1)) ne $last_letter) + { + if ($last_letter ne '') + { + print INDEX_FILE "
\n"; + close (INDEX_FILE); + } + + $last_letter = &uppercases (substr ($_, 0, 1)); + $initial = $last_letter; + if ($initial eq '"') + { + $initial = "operators"; + } + if ($initial ne '.') + { + open (INDEX_FILE, ">$output_dir/funcs/$initial.$fileext") + || die "couldn't write $output_dir/funcs/$initial.$fileext"; + print INDEX_FILE <<"EOF"; +$initial + +

Functions - $initial

+[index] +
    +EOF + ; + local ($str) = "[$initial]"; + push (@output, $str); + print FUNCS "$str\n"; + } + } + local ($ref); + local ($is_overloaded) = ($#{$global_index {$_}} > 0 ? 1 : 0); + foreach $ref (@{$global_index {$_}}) + { + ($file, $full_file, $lineno, $column) = @{$ref}; + local ($symbol) = ($is_overloaded ? "$_ - $file:$lineno" : $_); + print INDEX_FILE "
  • $symbol"; + } + } + + print INDEX_FILE "
\n"; + close INDEX_FILE; + } + else + { + push (@output, "
    "); + print FUNCS "
      "; + foreach (sort {&uppercases ($a) cmp &uppercases ($b)} keys %global_index) + { + local ($ref); + local ($is_overloaded) = ($#{$global_index {$_}} > 0 ? 1 : 0); + foreach $ref (@{$global_index {$_}}) + { + ($file, $full_file, $lineno, $column) = @{$ref}; + local ($symbol) = ($is_overloaded ? "$_ - $file:$lineno" : $_); + push (@output, "
    • $symbol"); + print FUNCS "
    • $symbol"; + } + } + } + + print FUNCS &create_footer (""); + close (FUNCS); + + push (@output, "
    "); + return (@output); +} + +###### +## Main function +###### + +local ($index_file) = 0; + +mkdir ($output_dir, 0755) if (! -d $output_dir); +mkdir ($output_dir."/files", 0755) if (! -d $output_dir."/files"); +mkdir ($output_dir."/funcs", 0755) if (! -d $output_dir."/funcs"); + +&parse_prj_file ($prjfile) if ($prjfile); + +while ($index_file <= $#list_files) +{ + local ($file) = $list_files [$index_file]; + + if (&output_file ($file) == 0) + { + $list_files [$index_file] = ""; + } + $index_file ++; +} +&create_index_file; + +$indexfile = "$output_dir/index.$fileext"; +$indexfile =~ s!//!/!g; +print "You can now download the $indexfile file to see the ", + "created pages\n"; diff --git a/gcc/ada/gnatkr.adb b/gcc/ada/gnatkr.adb new file mode 100644 index 000000000..1df692e7b --- /dev/null +++ b/gcc/ada/gnatkr.adb @@ -0,0 +1,137 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T K R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Command_Line; use Ada.Command_Line; +with Gnatvsn; +with Krunch; +with System.IO; use System.IO; + +procedure Gnatkr is + pragma Ident (Gnatvsn.Gnat_Static_Version_String); + + Count : Natural; + Maxlen : Integer; + Exit_Program : exception; + + function Get_Maximum_File_Name_Length return Integer; + pragma Import (C, Get_Maximum_File_Name_Length, + "__gnat_get_maximum_file_name_length"); + +begin + Count := Argument_Count; + + if Count < 1 or else Count > 2 then + Put_Line ("Usage: gnatkr filename[.extension] [krunch-count]"); + raise Exit_Program; + + else + -- If the length (krunch-count) argument is omitted use the system + -- default if there is one, otherwise use 8. + + if Count = 1 then + Maxlen := Get_Maximum_File_Name_Length; + + if Maxlen = -1 then + Maxlen := 8; + end if; + + else + Maxlen := 0; + + for J in Argument (2)'Range loop + if Argument (2) (J) /= ' ' then + if Argument (2) (J) not in '0' .. '9' then + Put_Line ("Illegal argument for krunch-count"); + raise Exit_Program; + else + Maxlen := Maxlen * 10 + + Character'Pos (Argument (2) (J)) - Character'Pos ('0'); + end if; + end if; + end loop; + + -- Zero means crunch only system files + + if Maxlen = 0 then + Maxlen := Natural'Last; + end if; + + end if; + + declare + Fname : String := Argument (1); + Klen : Natural := Fname'Length; + + Extp : Boolean := False; + -- True if extension is present + + Ext : Natural := 0; + -- If extension is present, points to it (init to prevent warning) + + begin + -- Remove extension if present (an extension is defined as the + -- section of the file name after the last dot in the name. If + -- there is no dot in the name, then + -- name is all lower case and contains no other instances of dots) + + for J in reverse 1 .. Klen loop + if Fname (J) = '.' then + Extp := True; + Ext := J; + Klen := J - 1; + exit; + end if; + end loop; + + -- Fold to lower case and replace dots by dashes + + for J in 1 .. Klen loop + Fname (J) := To_Lower (Fname (J)); + + if Fname (J) = '.' then + Fname (J) := '-'; + end if; + end loop; + + Krunch (Fname, Klen, Maxlen, False); + + Put (Fname (1 .. Klen)); + + if Extp then + Put (Fname (Ext .. Fname'Length)); + end if; + + New_Line; + end; + end if; + + Set_Exit_Status (Success); + +exception + when Exit_Program => + Set_Exit_Status (Failure); + +end Gnatkr; diff --git a/gcc/ada/gnatkr.ads b/gcc/ada/gnatkr.ads new file mode 100644 index 000000000..328da172f --- /dev/null +++ b/gcc/ada/gnatkr.ads @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T K R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a small utility program that incorporates the file krunching +-- algorithm used by the GNAT compiler (when the -gnatk switch is used) + +-- gnatkr filename length + +-- where length is a decimal value, outputs to standard output the krunched +-- name, followed by the original input file name. The file name has an +-- optional extension, which, if present, is copied unchanged to the output. +-- The length argument is optional and defaults to the system default if +-- there is one, otherwise to 8. + +procedure Gnatkr; +-- Execute above described command. This is an Ada main program which +-- sets an exit status (set to Success or Failure as appropriate) diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb new file mode 100644 index 000000000..0b5d681b3 --- /dev/null +++ b/gcc/ada/gnatlink.adb @@ -0,0 +1,2272 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T L I N K -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1996-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Gnatlink usage: please consult the gnat documentation + +with ALI; use ALI; +with Csets; +with Gnatvsn; use Gnatvsn; +with Hostparm; +with Indepsw; use Indepsw; +with Namet; use Namet; +with Opt; +with Osint; use Osint; +with Output; use Output; +with Snames; +with Switch; use Switch; +with System; use System; +with Table; +with Targparm; use Targparm; +with Types; + +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Exceptions; use Ada.Exceptions; + +with System.OS_Lib; use System.OS_Lib; +with System.CRTL; + +with Interfaces.C_Streams; use Interfaces.C_Streams; +with Interfaces.C.Strings; use Interfaces.C.Strings; + +procedure Gnatlink is + pragma Ident (Gnatvsn.Gnat_Static_Version_String); + + Shared_Libgcc_String : constant String := "-shared-libgcc"; + Shared_Libgcc : constant String_Access := + new String'(Shared_Libgcc_String); + -- Used to invoke gcc when the binder is invoked with -shared + + Static_Libgcc_String : constant String := "-static-libgcc"; + Static_Libgcc : constant String_Access := + new String'(Static_Libgcc_String); + -- Used to invoke gcc when shared libs are not used + + package Gcc_Linker_Options is new Table.Table ( + Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Gnatlink.Gcc_Linker_Options"); + -- Comments needed ??? + + package Libpath is new Table.Table ( + Table_Component_Type => Character, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 4096, + Table_Increment => 100, + Table_Name => "Gnatlink.Libpath"); + -- Comments needed ??? + + package Linker_Options is new Table.Table ( + Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Gnatlink.Linker_Options"); + -- Comments needed ??? + + package Linker_Objects is new Table.Table ( + Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Gnatlink.Linker_Objects"); + -- This table collects the objects file to be passed to the linker. In the + -- case where the linker command line is too long then programs objects + -- are put on the Response_File_Objects table. Note that the binder object + -- file and the user's objects remain in this table. This is very + -- important because on the GNU linker command line the -L switch is not + -- used to look for objects files but -L switch is used to look for + -- objects listed in the response file. This is not a problem with the + -- applications objects as they are specified with a full name. + + package Response_File_Objects is new Table.Table ( + Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Gnatlink.Response_File_Objects"); + -- This table collects the objects file that are to be put in the response + -- file. Only application objects are collected there (see details in + -- Linker_Objects table comments) + + package Binder_Options_From_ALI is new Table.Table ( + Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, -- equals low bound of Argument_List for Spawn + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Gnatlink.Binder_Options_From_ALI"); + -- This table collects the switches from the ALI file of the main + -- subprogram. + + package Binder_Options is new Table.Table ( + Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, -- equals low bound of Argument_List for Spawn + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Gnatlink.Binder_Options"); + -- This table collects the arguments to be passed to compile the binder + -- generated file. + + Gcc : String_Access := Program_Name ("gcc", "gnatlink"); + + Read_Mode : constant String := "r" & ASCII.NUL; + + Begin_Info : String := "-- BEGIN Object file/option list"; + End_Info : String := "-- END Object file/option list "; + -- Note: above lines are modified in C mode, see option processing + + Gcc_Path : String_Access; + Linker_Path : String_Access; + Output_File_Name : String_Access; + Ali_File_Name : String_Access; + Binder_Spec_Src_File : String_Access; + Binder_Body_Src_File : String_Access; + Binder_Ali_File : String_Access; + Binder_Obj_File : String_Access; + + Tname : Temp_File_Name; + Tname_FD : File_Descriptor := Invalid_FD; + -- Temporary file used by linker to pass list of object files on + -- certain systems with limitations on size of arguments. + + Debug_Flag_Present : Boolean := False; + Verbose_Mode : Boolean := False; + Very_Verbose_Mode : Boolean := False; + + Ada_Bind_File : Boolean := True; + -- Set to True if bind file is generated in Ada + + Standard_Gcc : Boolean := True; + + Compile_Bind_File : Boolean := True; + -- Set to False if bind file is not to be compiled + + Create_Map_File : Boolean := False; + -- Set to True by switch -M. The map file name is derived from + -- the ALI file name (mainprog.ali => mainprog.map). + + Object_List_File_Supported : Boolean; + for Object_List_File_Supported'Size use Character'Size; + pragma Import + (C, Object_List_File_Supported, "__gnat_objlist_file_supported"); + -- Predicate indicating whether the linker has an option whereby the + -- names of object files can be passed to the linker in a file. + + Object_List_File_Required : Boolean := False; + -- Set to True to force generation of a response file + + Shared_Libgcc_Default : Character; + for Shared_Libgcc_Default'Size use Character'Size; + pragma Import + (C, Shared_Libgcc_Default, "__gnat_shared_libgcc_default"); + -- Indicates wether libgcc should be statically linked (use 'T') or + -- dynamically linked (use 'H') by default. + + function Base_Name (File_Name : String) return String; + -- Return just the file name part without the extension (if present) + + procedure Check_Existing_Executable (File_Name : String); + -- Delete any existing executable to avoid accidentally updating the target + -- of a symbolic link, but produce a Fatail_Error if File_Name matches any + -- of the source file names. This avoids overwriting of extensionless + -- source files by accident on systems where executables do not have + -- extensions. + + procedure Delete (Name : String); + -- Wrapper to unlink as status is ignored by this application + + procedure Error_Msg (Message : String); + -- Output the error or warning Message + + procedure Exit_With_Error (Error : String); + -- Output Error and exit program with a fatal condition + + procedure Process_Args; + -- Go through all the arguments and build option tables + + procedure Process_Binder_File (Name : String); + -- Reads the binder file and extracts linker arguments + + procedure Usage; + -- Display usage + + procedure Write_Header; + -- Show user the program name, version and copyright + + procedure Write_Usage; + -- Show user the program options + + --------------- + -- Base_Name -- + --------------- + + function Base_Name (File_Name : String) return String is + Findex1 : Natural; + Findex2 : Natural; + + begin + Findex1 := File_Name'First; + + -- The file might be specified by a full path name. However, + -- we want the path to be stripped away. + + for J in reverse File_Name'Range loop + if Is_Directory_Separator (File_Name (J)) then + Findex1 := J + 1; + exit; + end if; + end loop; + + Findex2 := File_Name'Last; + while Findex2 > Findex1 + and then File_Name (Findex2) /= '.' + loop + Findex2 := Findex2 - 1; + end loop; + + if Findex2 = Findex1 then + Findex2 := File_Name'Last + 1; + end if; + + return File_Name (Findex1 .. Findex2 - 1); + end Base_Name; + + ------------------------------- + -- Check_Existing_Executable -- + ------------------------------- + + procedure Check_Existing_Executable (File_Name : String) is + Ename : String := File_Name; + Efile : File_Name_Type; + Sfile : File_Name_Type; + + begin + Canonical_Case_File_Name (Ename); + Name_Len := 0; + Add_Str_To_Name_Buffer (Ename); + Efile := Name_Find; + + for J in Units.Table'First .. Units.Last loop + Sfile := Units.Table (J).Sfile; + if Sfile = Efile then + Exit_With_Error ("executable name """ & File_Name & """ matches " + & "source file name """ & Get_Name_String (Sfile) & """"); + end if; + end loop; + + Delete (File_Name); + end Check_Existing_Executable; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Name : String) is + Status : int; + pragma Unreferenced (Status); + begin + Status := unlink (Name'Address); + -- Is it really right to ignore an error here ??? + end Delete; + + --------------- + -- Error_Msg -- + --------------- + + procedure Error_Msg (Message : String) is + begin + Write_Str (Base_Name (Command_Name)); + Write_Str (": "); + Write_Str (Message); + Write_Eol; + end Error_Msg; + + --------------------- + -- Exit_With_Error -- + --------------------- + + procedure Exit_With_Error (Error : String) is + begin + Error_Msg (Error); + Exit_Program (E_Fatal); + end Exit_With_Error; + + ------------------ + -- Process_Args -- + ------------------ + + procedure Process_Args is + Next_Arg : Integer; + Skip_Next : Boolean := False; + -- Set to true if the next argument is to be added into the list of + -- linker's argument without parsing it. + + procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); + + -- Start of processing for Process_Args + + begin + -- First, check for --version and --help + + Check_Version_And_Help ("GNATLINK", "1995"); + + -- Loop through arguments of gnatlink command + + Next_Arg := 1; + loop + exit when Next_Arg > Argument_Count; + + Process_One_Arg : declare + Arg : constant String := Argument (Next_Arg); + + begin + -- Case of argument which is a switch + + -- We definitely need section by section comments here ??? + + if Skip_Next then + + -- This argument must not be parsed, just add it to the + -- list of linker's options. + + Skip_Next := False; + + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Arg); + + elsif Arg'Length /= 0 and then Arg (1) = '-' then + if Arg'Length > 4 and then Arg (2 .. 5) = "gnat" then + Exit_With_Error + ("invalid switch: """ & Arg & """ (gnat not needed here)"); + end if; + + if Arg = "-Xlinker" then + + -- Next argument should be sent directly to the linker. + -- We do not want to parse it here. + + Skip_Next := True; + + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Arg); + + elsif Arg (2) = 'g' + and then (Arg'Length < 5 or else Arg (2 .. 5) /= "gnat") + then + Debug_Flag_Present := True; + + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Arg); + + Binder_Options.Increment_Last; + Binder_Options.Table (Binder_Options.Last) := + Linker_Options.Table (Linker_Options.Last); + + elsif Arg'Length >= 3 and then Arg (2) = 'M' then + declare + Switches : String_List_Access; + + begin + Convert (Map_File, Arg (3 .. Arg'Last), Switches); + + if Switches /= null then + for J in Switches'Range loop + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + Switches (J); + end loop; + end if; + end; + + elsif Arg'Length = 2 then + case Arg (2) is + when 'A' => + Ada_Bind_File := True; + Begin_Info := "-- BEGIN Object file/option list"; + End_Info := "-- END Object file/option list "; + + when 'b' => + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Arg); + + Binder_Options.Increment_Last; + Binder_Options.Table (Binder_Options.Last) := + Linker_Options.Table (Linker_Options.Last); + + Next_Arg := Next_Arg + 1; + + if Next_Arg > Argument_Count then + Exit_With_Error ("Missing argument for -b"); + end if; + + Get_Machine_Name : declare + Name_Arg : constant String_Access := + new String'(Argument (Next_Arg)); + + begin + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + Name_Arg; + + Binder_Options.Increment_Last; + Binder_Options.Table (Binder_Options.Last) := + Name_Arg; + + end Get_Machine_Name; + + when 'C' => + Ada_Bind_File := False; + Begin_Info := "/* BEGIN Object file/option list"; + End_Info := " END Object file/option list */"; + + when 'f' => + if Object_List_File_Supported then + Object_List_File_Required := True; + else + Exit_With_Error + ("Object list file not supported on this target"); + end if; + + when 'M' => + Create_Map_File := True; + + when 'n' => + Compile_Bind_File := False; + + when 'o' => + Next_Arg := Next_Arg + 1; + + if Next_Arg > Argument_Count then + Exit_With_Error ("Missing argument for -o"); + end if; + + Output_File_Name := + new String'(Executable_Name + (Argument (Next_Arg), + Only_If_No_Suffix => True)); + + when 'R' => + Opt.Run_Path_Option := False; + + when 'v' => + + -- Support "double" verbose mode. Second -v + -- gets sent to the linker and binder phases. + + if Verbose_Mode then + Very_Verbose_Mode := True; + + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Arg); + + Binder_Options.Increment_Last; + Binder_Options.Table (Binder_Options.Last) := + Linker_Options.Table (Linker_Options.Last); + + else + Verbose_Mode := True; + + end if; + + when others => + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Arg); + + end case; + + elsif Arg (2) = 'B' then + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Arg); + + Binder_Options.Increment_Last; + Binder_Options.Table (Binder_Options.Last) := + Linker_Options.Table (Linker_Options.Last); + + elsif Arg'Length >= 7 and then Arg (1 .. 7) = "--LINK=" then + if Arg'Length = 7 then + Exit_With_Error ("Missing argument for --LINK="); + end if; + + Linker_Path := + System.OS_Lib.Locate_Exec_On_Path (Arg (8 .. Arg'Last)); + + if Linker_Path = null then + Exit_With_Error + ("Could not locate linker: " & Arg (8 .. Arg'Last)); + end if; + + elsif Arg'Length > 6 and then Arg (1 .. 6) = "--GCC=" then + declare + Program_Args : constant Argument_List_Access := + Argument_String_To_List + (Arg (7 .. Arg'Last)); + + begin + if Program_Args.all (1).all /= Gcc.all then + Gcc := new String'(Program_Args.all (1).all); + Standard_Gcc := False; + end if; + + -- Set appropriate flags for switches passed + + for J in 2 .. Program_Args.all'Last loop + declare + Arg : constant String := Program_Args.all (J).all; + AF : constant Integer := Arg'First; + + begin + if Arg'Length /= 0 and then Arg (AF) = '-' then + if Arg (AF + 1) = 'g' + and then (Arg'Length = 2 + or else Arg (AF + 2) in '0' .. '3' + or else Arg (AF + 2 .. Arg'Last) = "coff") + then + Debug_Flag_Present := True; + end if; + end if; + + -- Add directory to source search dirs so that + -- Get_Target_Parameters can find system.ads + + if Arg (AF .. AF + 1) = "-I" + and then Arg'Length > 2 + then + Add_Src_Search_Dir (Arg (AF + 2 .. Arg'Last)); + end if; + + -- Pass to gcc for compiling binder generated file + -- No use passing libraries, it will just generate + -- a warning + + if not (Arg (AF .. AF + 1) = "-l" + or else Arg (AF .. AF + 1) = "-L") + then + Binder_Options.Increment_Last; + Binder_Options.Table (Binder_Options.Last) := + new String'(Arg); + end if; + + -- Pass to gcc for linking program + + Gcc_Linker_Options.Increment_Last; + Gcc_Linker_Options.Table + (Gcc_Linker_Options.Last) := new String'(Arg); + end; + end loop; + end; + + -- Send all multi-character switches not recognized as + -- a special case by gnatlink to the linker/loader stage. + + else + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Arg); + end if; + + -- Here if argument is a file name rather than a switch + + else + -- If explicit ali file, capture it + + if Arg'Length > 4 + and then Arg (Arg'Last - 3 .. Arg'Last) = ".ali" + then + if Ali_File_Name = null then + Ali_File_Name := new String'(Arg); + else + Exit_With_Error ("cannot handle more than one ALI file"); + end if; + + -- If target object file, record object file + + elsif Arg'Length > Get_Target_Object_Suffix.all'Length + and then Arg + (Arg'Last - + Get_Target_Object_Suffix.all'Length + 1 .. Arg'Last) + = Get_Target_Object_Suffix.all + then + Linker_Objects.Increment_Last; + Linker_Objects.Table (Linker_Objects.Last) := + new String'(Arg); + + -- If host object file, record object file + -- e.g. accept foo.o as well as foo.obj on VMS target + + elsif Arg'Length > Get_Object_Suffix.all'Length + and then Arg + (Arg'Last - Get_Object_Suffix.all'Length + 1 .. Arg'Last) + = Get_Object_Suffix.all + then + Linker_Objects.Increment_Last; + Linker_Objects.Table (Linker_Objects.Last) := + new String'(Arg); + + -- If corresponding ali file exists, capture it + + elsif Ali_File_Name = null + and then Is_Regular_File (Arg & ".ali") + then + Ali_File_Name := new String'(Arg & ".ali"); + + -- Otherwise assume this is a linker options entry, but + -- see below for interesting adjustment to this assumption. + + else + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Arg); + end if; + end if; + end Process_One_Arg; + + Next_Arg := Next_Arg + 1; + end loop; + + -- If Ada bind file, then compile it with warnings suppressed, because + -- otherwise the with of the main program may cause junk warnings. + + if Ada_Bind_File then + Binder_Options.Increment_Last; + Binder_Options.Table (Binder_Options.Last) := new String'("-gnatws"); + end if; + + -- If we did not get an ali file at all, and we had at least one + -- linker option, then assume that was the intended ali file after + -- all, so that we get a nicer message later on. + + if Ali_File_Name = null + and then Linker_Options.Last >= Linker_Options.First + then + Ali_File_Name := + new String'(Linker_Options.Table (Linker_Options.First).all & + ".ali"); + end if; + end Process_Args; + + ------------------------- + -- Process_Binder_File -- + ------------------------- + + procedure Process_Binder_File (Name : String) is + Fd : FILEs; + -- Binder file's descriptor + + Link_Bytes : Integer := 0; + -- Projected number of bytes for the linker command line + + Link_Max : Integer; + pragma Import (C, Link_Max, "__gnat_link_max"); + -- Maximum number of bytes on the command line supported by the OS + -- linker. Passed this limit the response file mechanism must be used + -- if supported. + + Next_Line : String (1 .. 1000); + -- Current line value + + Nlast : Integer; + Nfirst : Integer; + -- Current line slice (the slice does not contain line terminator) + + Last : Integer; + -- Current line last character for shared libraries (without version) + + Objs_Begin : Integer := 0; + -- First object file index in Linker_Objects table + + Objs_End : Integer := 0; + -- Last object file index in Linker_Objects table + + Status : int; + pragma Warnings (Off, Status); + -- Used for various Interfaces.C_Streams calls + + Closing_Status : Boolean; + pragma Warnings (Off, Closing_Status); + -- For call to Close + + GNAT_Static : Boolean := False; + -- Save state of -static option + + GNAT_Shared : Boolean := False; + -- Save state of -shared option + + Xlinker_Was_Previous : Boolean := False; + -- Indicate that "-Xlinker" was the option preceding the current + -- option. If True, then the current option is never suppressed. + + -- Rollback data + + -- These data items are used to store current binder file context. + -- The context is composed of the file descriptor position and the + -- current line together with the slice indexes (first and last + -- position) for this line. The rollback data are used by the + -- Store_File_Context and Rollback_File_Context routines below. + -- The file context mechanism interact only with the Get_Next_Line + -- call. For example: + + -- Store_File_Context; + -- Get_Next_Line; + -- Rollback_File_Context; + -- Get_Next_Line; + + -- Both Get_Next_Line calls above will read the exact same data from + -- the file. In other words, Next_Line, Nfirst and Nlast variables + -- will be set with the exact same values. + + RB_File_Pos : long; -- File position + RB_Next_Line : String (1 .. 1000); -- Current line content + RB_Nlast : Integer; -- Slice last index + RB_Nfirst : Integer; -- Slice first index + + Run_Path_Option_Ptr : Interfaces.C.Strings.chars_ptr; + pragma Import (C, Run_Path_Option_Ptr, "__gnat_run_path_option"); + -- Pointer to string representing the native linker option which + -- specifies the path where the dynamic loader should find shared + -- libraries. Equal to null string if this system doesn't support it. + + Libgcc_Subdir_Ptr : Interfaces.C.Strings.chars_ptr; + pragma Import (C, Libgcc_Subdir_Ptr, "__gnat_default_libgcc_subdir"); + -- Pointer to string indicating the installation subdirectory where + -- a default shared libgcc might be found. + + Object_Library_Ext_Ptr : Interfaces.C.Strings.chars_ptr; + pragma Import + (C, Object_Library_Ext_Ptr, "__gnat_object_library_extension"); + -- Pointer to string specifying the default extension for + -- object libraries, e.g. Unix uses ".a", VMS uses ".olb". + + Object_File_Option_Ptr : Interfaces.C.Strings.chars_ptr; + pragma Import (C, Object_File_Option_Ptr, "__gnat_object_file_option"); + -- Pointer to a string representing the linker option which specifies + -- the response file. + + Using_GNU_Linker : Boolean; + for Using_GNU_Linker'Size use Character'Size; + pragma Import (C, Using_GNU_Linker, "__gnat_using_gnu_linker"); + -- Predicate indicating whether this target uses the GNU linker. In + -- this case we must output a GNU linker compatible response file. + + Separate_Run_Path_Options : Boolean; + for Separate_Run_Path_Options'Size use Character'Size; + pragma Import + (C, Separate_Run_Path_Options, "__gnat_separate_run_path_options"); + -- Whether separate rpath options should be emitted for each directory + + Opening : aliased constant String := """"; + Closing : aliased constant String := '"' & ASCII.LF; + -- Needed to quote object paths in object list files when GNU linker + -- is used. + + procedure Get_Next_Line; + -- Read the next line from the binder file without the line + -- terminator. + + function Index (S, Pattern : String) return Natural; + -- Return the last occurrence of Pattern in S, or 0 if none + + function Is_Option_Present (Opt : String) return Boolean; + -- Return true if the option Opt is already present in + -- Linker_Options table. + + procedure Store_File_Context; + -- Store current file context, Fd position and current line data. + -- The file context is stored into the rollback data above (RB_*). + -- Store_File_Context can be called at any time, only the last call + -- will be used (i.e. this routine overwrites the file context). + + procedure Rollback_File_Context; + -- Restore file context from rollback data. This routine must be called + -- after Store_File_Context. The binder file context will be restored + -- with the data stored by the last Store_File_Context call. + + ------------------- + -- Get_Next_Line -- + ------------------- + + procedure Get_Next_Line is + Fchars : chars; + + begin + Fchars := fgets (Next_Line'Address, Next_Line'Length, Fd); + + if Fchars = System.Null_Address then + Exit_With_Error ("Error reading binder output"); + end if; + + Nfirst := Next_Line'First; + Nlast := Nfirst; + while Nlast <= Next_Line'Last + and then Next_Line (Nlast) /= ASCII.LF + and then Next_Line (Nlast) /= ASCII.CR + loop + Nlast := Nlast + 1; + end loop; + + Nlast := Nlast - 1; + end Get_Next_Line; + + ----------- + -- Index -- + ----------- + + function Index (S, Pattern : String) return Natural is + Len : constant Natural := Pattern'Length; + + begin + for J in reverse S'First .. S'Last - Len + 1 loop + if Pattern = S (J .. J + Len - 1) then + return J; + end if; + end loop; + + return 0; + end Index; + + ----------------------- + -- Is_Option_Present -- + ----------------------- + + function Is_Option_Present (Opt : String) return Boolean is + begin + for I in 1 .. Linker_Options.Last loop + + if Linker_Options.Table (I).all = Opt then + return True; + end if; + + end loop; + + return False; + end Is_Option_Present; + + --------------------------- + -- Rollback_File_Context -- + --------------------------- + + procedure Rollback_File_Context is + begin + Next_Line := RB_Next_Line; + Nfirst := RB_Nfirst; + Nlast := RB_Nlast; + Status := fseek (Fd, RB_File_Pos, Interfaces.C_Streams.SEEK_SET); + + if Status = -1 then + Exit_With_Error ("Error setting file position"); + end if; + end Rollback_File_Context; + + ------------------------ + -- Store_File_Context -- + ------------------------ + + procedure Store_File_Context is + use type System.CRTL.long; + begin + RB_Next_Line := Next_Line; + RB_Nfirst := Nfirst; + RB_Nlast := Nlast; + RB_File_Pos := ftell (Fd); + + if RB_File_Pos = -1 then + Exit_With_Error ("Error getting file position"); + end if; + end Store_File_Context; + + -- Start of processing for Process_Binder_File + + begin + Fd := fopen (Name'Address, Read_Mode'Address); + + if Fd = NULL_Stream then + Exit_With_Error ("Failed to open binder output"); + end if; + + -- Skip up to the Begin Info line + + loop + Get_Next_Line; + exit when Next_Line (Nfirst .. Nlast) = Begin_Info; + end loop; + + loop + Get_Next_Line; + + -- Go to end when end line is reached (this will happen in + -- High_Integrity_Mode where no -L switches are generated) + + exit when Next_Line (Nfirst .. Nlast) = End_Info; + + if Ada_Bind_File then + Next_Line (Nfirst .. Nlast - 8) := + Next_Line (Nfirst + 8 .. Nlast); + Nlast := Nlast - 8; + end if; + + -- Go to next section when switches are reached + + exit when Next_Line (1) = '-'; + + -- Otherwise we have another object file to collect + + Linker_Objects.Increment_Last; + + -- Mark the positions of first and last object files in case + -- they need to be placed with a named file on systems having + -- linker line limitations. + + if Objs_Begin = 0 then + Objs_Begin := Linker_Objects.Last; + end if; + + Linker_Objects.Table (Linker_Objects.Last) := + new String'(Next_Line (Nfirst .. Nlast)); + + Link_Bytes := Link_Bytes + Nlast - Nfirst + 2; + -- Nlast - Nfirst + 1, for the size, plus one for the space between + -- each arguments. + end loop; + + Objs_End := Linker_Objects.Last; + + -- Continue to compute the Link_Bytes, the linker options are part of + -- command line length. + + Store_File_Context; + + while Next_Line (Nfirst .. Nlast) /= End_Info loop + Link_Bytes := Link_Bytes + Nlast - Nfirst + 2; + Get_Next_Line; + end loop; + + Rollback_File_Context; + + -- On systems that have limitations on handling very long linker lines + -- we make use of the system linker option which takes a list of object + -- file names from a file instead of the command line itself. What we do + -- is to replace the list of object files by the special linker option + -- which then reads the object file list from a file instead. The option + -- to read from a file instead of the command line is only triggered if + -- a conservative threshold is passed. + + if Object_List_File_Required + or else (Object_List_File_Supported + and then Link_Bytes > Link_Max) + then + -- Create a temporary file containing the Ada user object files + -- needed by the link. This list is taken from the bind file + -- and is output one object per line for maximal compatibility with + -- linkers supporting this option. + + Create_Temp_File (Tname_FD, Tname); + + -- ??? File descriptor should be checked to not be Invalid_FD. + -- ??? Status of Write and Close operations should be checked, and + -- failure should occur if a status is wrong. + + -- If target is using the GNU linker we must add a special header + -- and footer in the response file. + + -- The syntax is : INPUT (object1.o object2.o ... ) + + -- Because the GNU linker does not like name with characters such + -- as '!', we must put the object paths between double quotes. + + if Using_GNU_Linker then + declare + GNU_Header : aliased constant String := "INPUT ("; + + begin + Status := Write (Tname_FD, GNU_Header'Address, + GNU_Header'Length); + end; + end if; + + for J in Objs_Begin .. Objs_End loop + + -- Opening quote for GNU linker + + if Using_GNU_Linker then + Status := Write (Tname_FD, Opening'Address, 1); + end if; + + Status := Write (Tname_FD, Linker_Objects.Table (J).all'Address, + Linker_Objects.Table (J).all'Length); + + -- Closing quote for GNU linker + + if Using_GNU_Linker then + Status := Write (Tname_FD, Closing'Address, 2); + + else + Status := Write (Tname_FD, ASCII.LF'Address, 1); + end if; + + Response_File_Objects.Increment_Last; + Response_File_Objects.Table (Response_File_Objects.Last) := + Linker_Objects.Table (J); + end loop; + + -- Handle GNU linker response file footer + + if Using_GNU_Linker then + declare + GNU_Footer : aliased constant String := ")"; + + begin + Status := Write (Tname_FD, GNU_Footer'Address, + GNU_Footer'Length); + end; + end if; + + Close (Tname_FD, Closing_Status); + + -- Add the special objects list file option together with the name + -- of the temporary file (removing the null character) to the objects + -- file table. + + Linker_Objects.Table (Objs_Begin) := + new String'(Value (Object_File_Option_Ptr) & + Tname (Tname'First .. Tname'Last - 1)); + + -- The slots containing these object file names are then removed + -- from the objects table so they do not appear in the link. They + -- are removed by moving up the linker options and non-Ada object + -- files appearing after the Ada object list in the table. + + declare + N : Integer; + + begin + N := Objs_End - Objs_Begin + 1; + + for J in Objs_End + 1 .. Linker_Objects.Last loop + Linker_Objects.Table (J - N + 1) := Linker_Objects.Table (J); + end loop; + + Linker_Objects.Set_Last (Linker_Objects.Last - N + 1); + end; + end if; + + -- Process switches and options + + if Next_Line (Nfirst .. Nlast) /= End_Info then + Xlinker_Was_Previous := False; + + loop + if Xlinker_Was_Previous + or else Next_Line (Nfirst .. Nlast) = "-Xlinker" + then + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Next_Line (Nfirst .. Nlast)); + + elsif Next_Line (Nfirst .. Nlast) = "-static" then + GNAT_Static := True; + + elsif Next_Line (Nfirst .. Nlast) = "-shared" then + GNAT_Shared := True; + + -- Add binder options only if not already set on the command + -- line. This rule is a way to control the linker options order. + + -- The following test needs comments, why is it VMS specific. + -- The above comment looks out of date ??? + + elsif not (OpenVMS_On_Target + and then + Is_Option_Present (Next_Line (Nfirst .. Nlast))) + then + if Nlast > Nfirst + 2 and then + Next_Line (Nfirst .. Nfirst + 1) = "-L" + then + -- Construct a library search path for use later + -- to locate static gnatlib libraries. + + if Libpath.Last > 1 then + Libpath.Increment_Last; + Libpath.Table (Libpath.Last) := Path_Separator; + end if; + + for I in Nfirst + 2 .. Nlast loop + Libpath.Increment_Last; + Libpath.Table (Libpath.Last) := Next_Line (I); + end loop; + + Linker_Options.Increment_Last; + + Linker_Options.Table (Linker_Options.Last) := + new String'(Next_Line (Nfirst .. Nlast)); + + elsif Next_Line (Nfirst .. Nlast) = "-ldecgnat" + or else Next_Line (Nfirst .. Nlast) = "-lgnarl" + or else Next_Line (Nfirst .. Nlast) = "-lgnat" + or else Next_Line + (1 .. Natural'Min (Nlast, 8 + Library_Version'Length)) = + Shared_Lib ("gnarl") + or else Next_Line + (1 .. Natural'Min (Nlast, 7 + Library_Version'Length)) = + Shared_Lib ("gnat") + then + -- If it is a shared library, remove the library version. + -- We will be looking for the static version of the library + -- as it is in the same directory as the shared version. + + if Next_Line (Nlast - Library_Version'Length + 1 .. Nlast) + = Library_Version + then + -- Set Last to point to last character before the + -- library version. + + Last := Nlast - Library_Version'Length - 1; + else + Last := Nlast; + end if; + + -- Given a Gnat standard library, search the library path to + -- find the library location. + + -- Shouldn't we abstract a proc here, we are getting awfully + -- heavily nested ??? + + declare + File_Path : String_Access; + + Object_Lib_Extension : constant String := + Value (Object_Library_Ext_Ptr); + + File_Name : constant String := "lib" & + Next_Line (Nfirst + 2 .. Last) & + Object_Lib_Extension; + + Run_Path_Opt : constant String := + Value (Run_Path_Option_Ptr); + + GCC_Index : Natural; + Run_Path_Opt_Index : Natural := 0; + + begin + File_Path := + Locate_Regular_File (File_Name, + String (Libpath.Table (1 .. Libpath.Last))); + + if File_Path /= null then + if GNAT_Static then + + -- If static gnatlib found, explicitly + -- specify to overcome possible linker + -- default usage of shared version. + + Linker_Options.Increment_Last; + + Linker_Options.Table (Linker_Options.Last) := + new String'(File_Path.all); + + elsif GNAT_Shared then + if Opt.Run_Path_Option then + + -- If shared gnatlib desired, add the + -- appropriate system specific switch + -- so that it can be located at runtime. + + if Run_Path_Opt'Length /= 0 then + + -- Output the system specific linker command + -- that allows the image activator to find + -- the shared library at runtime. Also add + -- path to find libgcc_s.so, if relevant. + + declare + Path : String (1 .. File_Path'Length + 15); + Path_Last : constant Natural := + File_Path'Length; + + begin + Path (1 .. File_Path'Length) := + File_Path.all; + + -- To find the location of the shared version + -- of libgcc, we look for "gcc-lib" in the + -- path of the library. However, this + -- subdirectory is no longer present in + -- recent versions of GCC. So, we look for + -- the last subdirectory "lib" in the path. + + GCC_Index := + Index (Path (1 .. Path_Last), "gcc-lib"); + + if GCC_Index /= 0 then + + -- The shared version of libgcc is + -- located in the parent directory. + + GCC_Index := GCC_Index - 1; + + else + GCC_Index := + Index + (Path (1 .. Path_Last), + "/lib/"); + + if GCC_Index = 0 then + GCC_Index := + Index (Path (1 .. Path_Last), + Directory_Separator & + "lib" & + Directory_Separator); + end if; + + -- If we have found a "lib" subdir in + -- the path to libgnat, the possible + -- shared libgcc of interest by default + -- is in libgcc_subdir at the same + -- level. + + if GCC_Index /= 0 then + declare + Subdir : constant String := + Value (Libgcc_Subdir_Ptr); + begin + Path + (GCC_Index + 1 .. + GCC_Index + Subdir'Length) := + Subdir; + GCC_Index := + GCC_Index + Subdir'Length; + end; + end if; + end if; + + -- Look for an eventual run_path_option in + -- the linker switches. + + if Separate_Run_Path_Options then + Linker_Options.Increment_Last; + Linker_Options.Table + (Linker_Options.Last) := + new String' + (Run_Path_Opt + & File_Path + (1 .. File_Path'Length + - File_Name'Length)); + + if GCC_Index /= 0 then + Linker_Options.Increment_Last; + Linker_Options.Table + (Linker_Options.Last) := + new String' + (Run_Path_Opt + & Path (1 .. GCC_Index)); + end if; + + else + for J in reverse + 1 .. Linker_Options.Last + loop + if Linker_Options.Table (J) /= null + and then + Linker_Options.Table (J)'Length + > Run_Path_Opt'Length + and then + Linker_Options.Table (J) + (1 .. Run_Path_Opt'Length) = + Run_Path_Opt + then + -- We have found an already + -- specified run_path_option: we + -- will add to this switch, + -- because only one + -- run_path_option should be + -- specified. + + Run_Path_Opt_Index := J; + exit; + end if; + end loop; + + -- If there is no run_path_option, we + -- need to add one. + + if Run_Path_Opt_Index = 0 then + Linker_Options.Increment_Last; + end if; + + if GCC_Index = 0 then + if Run_Path_Opt_Index = 0 then + Linker_Options.Table + (Linker_Options.Last) := + new String' + (Run_Path_Opt + & File_Path + (1 .. File_Path'Length + - File_Name'Length)); + + else + Linker_Options.Table + (Run_Path_Opt_Index) := + new String' + (Linker_Options.Table + (Run_Path_Opt_Index).all + & Path_Separator + & File_Path + (1 .. File_Path'Length + - File_Name'Length)); + end if; + + else + if Run_Path_Opt_Index = 0 then + Linker_Options.Table + (Linker_Options.Last) := + new String' + (Run_Path_Opt + & File_Path + (1 .. File_Path'Length + - File_Name'Length) + & Path_Separator + & Path (1 .. GCC_Index)); + + else + Linker_Options.Table + (Run_Path_Opt_Index) := + new String' + (Linker_Options.Table + (Run_Path_Opt_Index).all + & Path_Separator + & File_Path + (1 .. File_Path'Length + - File_Name'Length) + & Path_Separator + & Path (1 .. GCC_Index)); + end if; + end if; + end if; + end; + end if; + end if; + + -- Then we add the appropriate -l switch + + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Next_Line (Nfirst .. Nlast)); + end if; + + else + -- If gnatlib library not found, then + -- add it anyway in case some other + -- mechanism may find it. + + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Next_Line (Nfirst .. Nlast)); + end if; + end; + else + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Next_Line (Nfirst .. Nlast)); + end if; + end if; + + Xlinker_Was_Previous := Next_Line (Nfirst .. Nlast) = "-Xlinker"; + + Get_Next_Line; + exit when Next_Line (Nfirst .. Nlast) = End_Info; + + if Ada_Bind_File then + Next_Line (Nfirst .. Nlast - 8) := + Next_Line (Nfirst + 8 .. Nlast); + Nlast := Nlast - 8; + end if; + end loop; + end if; + + -- If -shared was specified, invoke gcc with -shared-libgcc + + if GNAT_Shared then + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := Shared_Libgcc; + end if; + + Status := fclose (Fd); + end Process_Binder_File; + + ----------- + -- Usage -- + ----------- + + procedure Usage is + begin + Write_Str ("Usage: "); + Write_Str (Base_Name (Command_Name)); + Write_Str (" switches mainprog.ali [non-Ada-objects] [linker-options]"); + Write_Eol; + Write_Eol; + Write_Line (" mainprog.ali the ALI file of the main program"); + Write_Eol; + Write_Line (" -f force object file list to be generated"); + Write_Line (" -g Compile binder source file with debug information"); + Write_Line (" -n Do not compile the binder source file"); + Write_Line (" -R Do not use a run_path_option"); + Write_Line (" -v verbose mode"); + Write_Line (" -v -v very verbose mode"); + Write_Eol; + Write_Line (" -o nam Use 'nam' as the name of the executable"); + Write_Line (" -b target Compile the binder source to run on target"); + Write_Line (" -Bdir Load compiler executables from dir"); + + if Is_Supported (Map_File) then + Write_Line (" -Mmap Create map file map"); + Write_Line (" -M Create map file mainprog.map"); + end if; + + Write_Line (" --GCC=comp Use comp as the compiler"); + Write_Line (" --LINK=nam Use 'nam' for the linking rather than 'gcc'"); + Write_Eol; + Write_Line (" [non-Ada-objects] list of non Ada object files"); + Write_Line (" [linker-options] other options for the linker"); + end Usage; + + ------------------ + -- Write_Header -- + ------------------ + + procedure Write_Header is + begin + if Verbose_Mode then + Write_Eol; + Display_Version ("GNATLINK", "1995"); + end if; + end Write_Header; + + ----------------- + -- Write_Usage -- + ----------------- + + procedure Write_Usage is + begin + Write_Header; + Usage; + end Write_Usage; + +-- Start of processing for Gnatlink + +begin + -- Add the directory where gnatlink is invoked in front of the path, if + -- gnatlink is invoked with directory information. Only do this if the + -- platform is not VMS, where the notion of path does not really exist. + + if not Hostparm.OpenVMS then + declare + Command : constant String := Command_Name; + + begin + for Index in reverse Command'Range loop + if Command (Index) = Directory_Separator then + declare + Absolute_Dir : constant String := + Normalize_Pathname + (Command (Command'First .. Index)); + + PATH : constant String := + Absolute_Dir & + Path_Separator & + Getenv ("PATH").all; + + begin + Setenv ("PATH", PATH); + end; + + exit; + end if; + end loop; + end; + end if; + + Process_Args; + + if Argument_Count = 0 + or else (Verbose_Mode and then Argument_Count = 1) + then + Write_Usage; + Exit_Program (E_Fatal); + end if; + + -- Initialize packages to be used + + Csets.Initialize; + Snames.Initialize; + + -- We always compile with -c + + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := + new String'("-c"); + + if Ali_File_Name = null then + Exit_With_Error ("no ali file given for link"); + end if; + + if not Is_Regular_File (Ali_File_Name.all) then + Exit_With_Error (Ali_File_Name.all & " not found"); + end if; + + -- Read the ALI file of the main subprogram if the binder generated file + -- needs to be compiled and no --GCC= switch has been specified. Fetch the + -- back end switches from this ALI file and use these switches to compile + -- the binder generated file + + if Compile_Bind_File and then Standard_Gcc then + Initialize_ALI; + Name_Len := Ali_File_Name'Length; + Name_Buffer (1 .. Name_Len) := Ali_File_Name.all; + + declare + use Types; + F : constant File_Name_Type := Name_Find; + T : Text_Buffer_Ptr; + A : ALI_Id; + + begin + -- Load the ALI file + + T := Read_Library_Info (F, True); + + -- Read it. Note that we ignore errors, since we only want very + -- limited information from the ali file, and likely a slightly + -- wrong version will be just fine, though in normal operation + -- we don't expect this to happen! + + A := Scan_ALI + (F, + T, + Ignore_ED => False, + Err => False, + Ignore_Errors => True); + + if A /= No_ALI_Id then + for + Index in Units.Table (ALIs.Table (A).First_Unit).First_Arg .. + Units.Table (ALIs.Table (A).First_Unit).Last_Arg + loop + -- Do not compile with the front end switches. However, --RTS + -- is to be dealt with specially because it needs to be passed + -- if the binder-generated file is in Ada and may also be used + -- to drive the linker. + + declare + Arg : String_Ptr renames Args.Table (Index); + begin + if not Is_Front_End_Switch (Arg.all) then + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table + (Binder_Options_From_ALI.Last) := String_Access (Arg); + + elsif Arg'Length > 5 + and then Arg (Arg'First + 2 .. Arg'First + 5) = "RTS=" + then + if Ada_Bind_File then + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table + (Binder_Options_From_ALI.Last) + := String_Access (Arg); + end if; + + -- Set the RTS_*_Path_Name variables, so that + -- the correct directories will be set when + -- Osint.Add_Default_Search_Dirs will be called later. + + Opt.RTS_Src_Path_Name := + Get_RTS_Search_Dir + (Arg (Arg'First + 6 .. Arg'Last), Include); + + Opt.RTS_Lib_Path_Name := + Get_RTS_Search_Dir + (Arg (Arg'First + 6 .. Arg'Last), Objects); + + -- GNAT doesn't support the GCC multilib mechanism. + -- This means that, when a multilib switch is used + -- to request a particular compilation mode, the + -- corresponding runtime switch (--RTS) must also be + -- specified. The long-term goal is to fully support the + -- multilib mechanism; however, in the meantime, it is + -- convenient to eliminate the redundancy by keying the + -- compilation mode on a single switch, namely --RTS. + + -- Pass -mrtp to the linker if --RTS=rtp was passed + + if Arg'Length > 8 + and then Arg (Arg'First + 6 .. Arg'First + 8) = "rtp" + then + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'("-mrtp"); + end if; + end if; + end; + end loop; + end if; + end; + end if; + + -- Get target parameters + + Osint.Add_Default_Search_Dirs; + Targparm.Get_Target_Parameters; + + if VM_Target /= No_VM then + case VM_Target is + when JVM_Target => Gcc := new String'("jvm-gnatcompile"); + when CLI_Target => Gcc := new String'("dotnet-gnatcompile"); + when No_VM => raise Program_Error; + end case; + + Ada_Bind_File := True; + Begin_Info := "-- BEGIN Object file/option list"; + End_Info := "-- END Object file/option list "; + end if; + + -- If the main program is in Ada it is compiled with the following + -- switches: + + -- -gnatA stops reading gnat.adc, since we don't know what + -- pragmas would work, and we do not need it anyway. + + -- -gnatWb allows brackets coding for wide characters + + -- -gnatiw allows wide characters in identifiers. This is needed + -- because bindgen uses brackets encoding for all upper + -- half and wide characters in identifier names. + + if Ada_Bind_File then + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := + new String'("-gnatA"); + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := + new String'("-gnatWb"); + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := + new String'("-gnatiw"); + end if; + + -- Locate all the necessary programs and verify required files are present + + Gcc_Path := System.OS_Lib.Locate_Exec_On_Path (Gcc.all); + + if Gcc_Path = null then + Exit_With_Error ("Couldn't locate " & Gcc.all); + end if; + + if Linker_Path = null then + if VM_Target = CLI_Target then + Linker_Path := System.OS_Lib.Locate_Exec_On_Path ("dotnet-ld"); + + if Linker_Path = null then + Exit_With_Error ("Couldn't locate ilasm"); + end if; + + elsif RTX_RTSS_Kernel_Module_On_Target then + + -- Use Microsoft linker for RTSS modules + + Linker_Path := System.OS_Lib.Locate_Exec_On_Path ("link"); + + if Linker_Path = null then + Exit_With_Error ("Couldn't locate link"); + end if; + + else + Linker_Path := Gcc_Path; + end if; + end if; + + Write_Header; + + -- If no output name specified, then use the base name of .ali file name + + if Output_File_Name = null then + Output_File_Name := + new String'(Base_Name (Ali_File_Name.all) + & Get_Target_Debuggable_Suffix.all); + end if; + + if RTX_RTSS_Kernel_Module_On_Target then + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'("/OUT:" & Output_File_Name.all); + + else + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := new String'("-o"); + + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Output_File_Name.all); + end if; + + Check_Existing_Executable (Output_File_Name.all); + + -- Warn if main program is called "test", as that may be a built-in command + -- on Unix. On non-Unix systems executables have a suffix, so the warning + -- will not appear. However, do not warn in the case of a cross compiler. + + -- Assume this is a cross tool if the executable name is not gnatlink + + if Base_Name (Command_Name) = "gnatlink" + and then Output_File_Name.all = "test" + then + Error_Msg ("warning: executable name """ & Output_File_Name.all + & """ may conflict with shell command"); + end if; + + -- If -M switch was specified, add the switches to create the map file + + if Create_Map_File then + declare + Map_Name : constant String := Base_Name (Ali_File_Name.all) & ".map"; + Switches : String_List_Access; + + begin + Convert (Map_File, Map_Name, Switches); + + if Switches /= null then + for J in Switches'Range loop + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := Switches (J); + end loop; + end if; + end; + end if; + + -- Perform consistency checks + + -- Transform the .ali file name into the binder output file name + + Make_Binder_File_Names : declare + Fname : constant String := Base_Name (Ali_File_Name.all); + Fname_Len : Integer := Fname'Length; + + function Get_Maximum_File_Name_Length return Integer; + pragma Import (C, Get_Maximum_File_Name_Length, + "__gnat_get_maximum_file_name_length"); + + Maximum_File_Name_Length : constant Integer := + Get_Maximum_File_Name_Length; + + Bind_File_Prefix : Types.String_Ptr; + -- Contains prefix used for bind files + + begin + -- Set prefix + + if not Ada_Bind_File then + Bind_File_Prefix := new String'("b_"); + elsif OpenVMS_On_Target then + Bind_File_Prefix := new String'("b__"); + else + Bind_File_Prefix := new String'("b~"); + end if; + + -- If the length of the binder file becomes too long due to + -- the addition of the "b?" prefix, then truncate it. + + if Maximum_File_Name_Length > 0 then + while Fname_Len > + Maximum_File_Name_Length - Bind_File_Prefix.all'Length + loop + Fname_Len := Fname_Len - 1; + end loop; + end if; + + declare + Fnam : constant String := + Bind_File_Prefix.all & + Fname (Fname'First .. Fname'First + Fname_Len - 1); + + begin + if Ada_Bind_File then + Binder_Spec_Src_File := new String'(Fnam & ".ads"); + Binder_Body_Src_File := new String'(Fnam & ".adb"); + Binder_Ali_File := new String'(Fnam & ".ali"); + else + Binder_Body_Src_File := new String'(Fnam & ".c"); + end if; + + Binder_Obj_File := new String'(Fnam & Get_Target_Object_Suffix.all); + end; + + if Fname_Len /= Fname'Length then + Binder_Options.Increment_Last; + Binder_Options.Table (Binder_Options.Last) := new String'("-o"); + Binder_Options.Increment_Last; + Binder_Options.Table (Binder_Options.Last) := Binder_Obj_File; + end if; + end Make_Binder_File_Names; + + Process_Binder_File (Binder_Body_Src_File.all & ASCII.NUL); + + -- Compile the binder file. This is fast, so we always do it, unless + -- specifically told not to by the -n switch + + if Compile_Bind_File then + Bind_Step : declare + Success : Boolean; + Args : Argument_List + (1 .. Binder_Options_From_ALI.Last + Binder_Options.Last + 1); + + begin + for J in 1 .. Binder_Options_From_ALI.Last loop + Args (J) := Binder_Options_From_ALI.Table (J); + end loop; + + for J in 1 .. Binder_Options.Last loop + Args (Binder_Options_From_ALI.Last + J) := + Binder_Options.Table (J); + end loop; + + -- Use the full path of the binder generated source, so that it is + -- guaranteed that the debugger will find this source, even with + -- STABS. + + Args (Args'Last) := + new String'(Normalize_Pathname (Binder_Body_Src_File.all)); + + if Verbose_Mode then + Write_Str (Base_Name (Gcc_Path.all)); + + for J in Args'Range loop + Write_Str (" "); + Write_Str (Args (J).all); + end loop; + + Write_Eol; + end if; + + System.OS_Lib.Spawn (Gcc_Path.all, Args, Success); + + if not Success then + Exit_Program (E_Fatal); + end if; + end Bind_Step; + end if; + + -- Now, actually link the program + + -- Skip this step for now on JVM since the Java interpreter will do + -- the actual link at run time. We might consider packing all class files + -- in a .zip file during this step. + + if VM_Target /= JVM_Target then + Link_Step : declare + Num_Args : Natural := + (Linker_Options.Last - Linker_Options.First + 1) + + (Gcc_Linker_Options.Last - Gcc_Linker_Options.First + 1) + + (Linker_Objects.Last - Linker_Objects.First + 1); + Stack_Op : Boolean := False; + IDENT_Op : Boolean := False; + + begin + if AAMP_On_Target then + + -- Remove extraneous flags not relevant for AAMP + + for J in reverse Linker_Options.First .. Linker_Options.Last loop + if Linker_Options.Table (J)'Length = 0 + or else Linker_Options.Table (J) (1 .. 3) = "-Wl" + or else Linker_Options.Table (J) (1 .. 3) = "-sh" + or else Linker_Options.Table (J) (1 .. 2) = "-O" + or else Linker_Options.Table (J) (1 .. 2) = "-g" + then + Linker_Options.Table (J .. Linker_Options.Last - 1) := + Linker_Options.Table (J + 1 .. Linker_Options.Last); + Linker_Options.Decrement_Last; + Num_Args := Num_Args - 1; + end if; + end loop; + + elsif RTX_RTSS_Kernel_Module_On_Target then + + -- Remove flags not relevant for Microsoft linker and adapt some + -- others. + + for J in reverse Linker_Options.First .. Linker_Options.Last loop + + -- Remove flags that are not accepted + + if Linker_Options.Table (J)'Length = 0 + or else Linker_Options.Table (J) (1 .. 2) = "-l" + or else Linker_Options.Table (J) (1 .. 3) = "-Wl" + or else Linker_Options.Table (J) (1 .. 3) = "-sh" + or else Linker_Options.Table (J) (1 .. 2) = "-O" + or else Linker_Options.Table (J) (1 .. 8) = "-Xlinker" + or else Linker_Options.Table (J) (1 .. 9) = "-mthreads" + then + Linker_Options.Table (J .. Linker_Options.Last - 1) := + Linker_Options.Table (J + 1 .. Linker_Options.Last); + Linker_Options.Decrement_Last; + Num_Args := Num_Args - 1; + + -- Replace "-L" by its counterpart "/LIBPATH:" and UNIX "/" by + -- Windows "\". + elsif Linker_Options.Table (J) (1 .. 2) = "-L" then + declare + Libpath_Option : constant String_Access := new String' + ("/LIBPATH:" & + Linker_Options.Table (J) + (3 .. Linker_Options.Table (J).all'Last)); + begin + for Index in 10 .. Libpath_Option'Last loop + if Libpath_Option (Index) = '/' then + Libpath_Option (Index) := '\'; + end if; + end loop; + + Linker_Options.Table (J) := Libpath_Option; + end; + + -- Replace "-g" by "/DEBUG" + elsif Linker_Options.Table (J) (1 .. 2) = "-g" then + Linker_Options.Table (J) := new String'("/DEBUG"); + + -- Replace "-o" by "/OUT:" + elsif Linker_Options.Table (J) (1 .. 2) = "-o" then + Linker_Options.Table (J + 1) := new String' + ("/OUT:" & Linker_Options.Table (J + 1).all); + + Linker_Options.Table (J .. Linker_Options.Last - 1) := + Linker_Options.Table (J + 1 .. Linker_Options.Last); + Linker_Options.Decrement_Last; + Num_Args := Num_Args - 1; + + -- Replace "--stack=" by "/STACK:" + elsif Linker_Options.Table (J) (1 .. 8) = "--stack=" then + Linker_Options.Table (J) := new String' + ("/STACK:" & + Linker_Options.Table (J) + (9 .. Linker_Options.Table (J).all'Last)); + + -- Replace "-v" by its counterpart "/VERBOSE" + elsif Linker_Options.Table (J) (1 .. 2) = "-v" then + Linker_Options.Table (J) := new String'("/VERBOSE"); + end if; + end loop; + + -- Add some required flags to create RTSS modules + + declare + Flags_For_Linker : constant array (1 .. 17) of String_Access := + (new String'("/NODEFAULTLIB"), + new String'("/INCREMENTAL:NO"), + new String'("/NOLOGO"), + new String'("/DRIVER"), + new String'("/ALIGN:0x20"), + new String'("/SUBSYSTEM:NATIVE"), + new String'("/ENTRY:_RtapiProcessEntryCRT@8"), + new String'("/RELEASE"), + new String'("startupCRT.obj"), + new String'("rtxlibcmt.lib"), + new String'("oldnames.lib"), + new String'("rtapi_rtss.lib"), + new String'("Rtx_Rtss.lib"), + new String'("libkernel32.a"), + new String'("libws2_32.a"), + new String'("libmswsock.a"), + new String'("libadvapi32.a")); + -- These flags need to be passed to Microsoft linker. They + -- come from the RTX documentation. + + Gcc_Lib_Path : constant String_Access := new String' + ("/LIBPATH:" & Include_Dir_Default_Prefix & "\..\"); + -- Place to look for gcc related libraries, such as libgcc + + begin + -- Replace UNIX "/" by Windows "\" in the path + + for Index in 10 .. Gcc_Lib_Path.all'Last loop + if Gcc_Lib_Path (Index) = '/' then + Gcc_Lib_Path (Index) := '\'; + end if; + end loop; + + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := Gcc_Lib_Path; + Num_Args := Num_Args + 1; + + for Index in Flags_For_Linker'Range loop + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + Flags_For_Linker (Index); + Num_Args := Num_Args + 1; + end loop; + end; + end if; + + -- Remove duplicate stack size setting from the Linker_Options + -- table. The stack setting option "-Xlinker --stack=R,C" can be + -- found in one line when set by a pragma Linker_Options or in two + -- lines ("-Xlinker" then "--stack=R,C") when set on the command + -- line. We also check for the "-Wl,--stack=R" style option. + + -- We must remove the second stack setting option instance + -- because the one on the command line will always be the first + -- one. And any subsequent stack setting option will overwrite the + -- previous one. This is done especially for GNAT/NT where we set + -- the stack size for tasking programs by a pragma in the NT + -- specific tasking package System.Task_Primitives.Operations. + + -- Note: This is not a FOR loop that runs from Linker_Options.First + -- to Linker_Options.Last, since operations within the loop can + -- modify the length of the table. + + Clean_Link_Option_Set : declare + J : Natural := Linker_Options.First; + Shared_Libgcc_Seen : Boolean := False; + + begin + while J <= Linker_Options.Last loop + + if Linker_Options.Table (J).all = "-Xlinker" + and then J < Linker_Options.Last + and then Linker_Options.Table (J + 1)'Length > 8 + and then Linker_Options.Table (J + 1) (1 .. 8) = "--stack=" + then + if Stack_Op then + Linker_Options.Table (J .. Linker_Options.Last - 2) := + Linker_Options.Table (J + 2 .. Linker_Options.Last); + Linker_Options.Decrement_Last; + Linker_Options.Decrement_Last; + Num_Args := Num_Args - 2; + + else + Stack_Op := True; + end if; + end if; + + -- Remove duplicate -shared-libgcc switch + + if Linker_Options.Table (J).all = Shared_Libgcc_String then + if Shared_Libgcc_Seen then + Linker_Options.Table (J .. Linker_Options.Last - 1) := + Linker_Options.Table (J + 1 .. Linker_Options.Last); + Linker_Options.Decrement_Last; + Num_Args := Num_Args - 1; + + else + Shared_Libgcc_Seen := True; + end if; + end if; + + -- Here we just check for a canonical form that matches the + -- pragma Linker_Options set in the NT runtime. + + if (Linker_Options.Table (J)'Length > 17 + and then Linker_Options.Table (J) (1 .. 17) + = "-Xlinker --stack=") + or else + (Linker_Options.Table (J)'Length > 12 + and then Linker_Options.Table (J) (1 .. 12) + = "-Wl,--stack=") + then + if Stack_Op then + Linker_Options.Table (J .. Linker_Options.Last - 1) := + Linker_Options.Table (J + 1 .. Linker_Options.Last); + Linker_Options.Decrement_Last; + Num_Args := Num_Args - 1; + + else + Stack_Op := True; + end if; + end if; + + -- Remove duplicate IDENTIFICATION directives (VMS) + + if Linker_Options.Table (J)'Length > 29 + and then Linker_Options.Table (J) (1 .. 30) = + "--for-linker=--identification=" + then + if IDENT_Op then + Linker_Options.Table (J .. Linker_Options.Last - 1) := + Linker_Options.Table (J + 1 .. Linker_Options.Last); + Linker_Options.Decrement_Last; + Num_Args := Num_Args - 1; + + else + IDENT_Op := True; + end if; + end if; + + J := J + 1; + end loop; + + if Linker_Path = Gcc_Path and then VM_Target = No_VM then + + -- For systems where the default is to link statically with + -- libgcc, if gcc is not called with -shared-libgcc, call it + -- with -static-libgcc, as there are some platforms where one + -- of these two switches is compulsory to link. + + if Shared_Libgcc_Default = 'T' + and then not Shared_Libgcc_Seen + then + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := Static_Libgcc; + Num_Args := Num_Args + 1; + end if; + + elsif RTX_RTSS_Kernel_Module_On_Target then + + -- Force the use of the static libgcc for RTSS modules + + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'("libgcc.a"); + Num_Args := Num_Args + 1; + end if; + + end Clean_Link_Option_Set; + + -- Prepare arguments for call to linker + + Call_Linker : declare + Success : Boolean; + Args : Argument_List (1 .. Num_Args + 1); + Index : Integer := Args'First; + + begin + Args (Index) := Binder_Obj_File; + + -- Add the object files and any -largs libraries + + for J in Linker_Objects.First .. Linker_Objects.Last loop + Index := Index + 1; + Args (Index) := Linker_Objects.Table (J); + end loop; + + -- Add the linker options from the binder file + + for J in Linker_Options.First .. Linker_Options.Last loop + Index := Index + 1; + Args (Index) := Linker_Options.Table (J); + end loop; + + -- Finally add the libraries from the --GCC= switch + + for J in Gcc_Linker_Options.First .. Gcc_Linker_Options.Last loop + Index := Index + 1; + Args (Index) := Gcc_Linker_Options.Table (J); + end loop; + + if Verbose_Mode then + Write_Str (Linker_Path.all); + + for J in Args'Range loop + Write_Str (" "); + Write_Str (Args (J).all); + end loop; + + Write_Eol; + + -- If we are on very verbose mode (-v -v) and a response file + -- is used we display its content. + + if Very_Verbose_Mode and then Tname_FD /= Invalid_FD then + Write_Eol; + Write_Str ("Response file (" & + Tname (Tname'First .. Tname'Last - 1) & + ") content : "); + Write_Eol; + + for J in + Response_File_Objects.First .. + Response_File_Objects.Last + loop + Write_Str (Response_File_Objects.Table (J).all); + Write_Eol; + end loop; + + Write_Eol; + end if; + end if; + + System.OS_Lib.Spawn (Linker_Path.all, Args, Success); + + -- Delete the temporary file used in conjunction with linking if + -- one was created. See Process_Bind_File for details. + + if Tname_FD /= Invalid_FD then + Delete (Tname); + end if; + + if not Success then + Error_Msg ("error when calling " & Linker_Path.all); + Exit_Program (E_Fatal); + end if; + end Call_Linker; + end Link_Step; + end if; + + -- Only keep the binder output file and it's associated object + -- file if compiling with the -g option. These files are only + -- useful if debugging. + + if not Debug_Flag_Present then + if Binder_Ali_File /= null then + Delete (Binder_Ali_File.all & ASCII.NUL); + end if; + + if Binder_Spec_Src_File /= null then + Delete (Binder_Spec_Src_File.all & ASCII.NUL); + end if; + + Delete (Binder_Body_Src_File.all & ASCII.NUL); + + if VM_Target = No_VM then + Delete (Binder_Obj_File.all & ASCII.NUL); + end if; + end if; + + Exit_Program (E_Success); + +exception + when X : others => + Write_Line (Exception_Information (X)); + Exit_With_Error ("INTERNAL ERROR. Please report"); +end Gnatlink; diff --git a/gcc/ada/gnatlink.ads b/gcc/ada/gnatlink.ads new file mode 100644 index 000000000..54f91a8ae --- /dev/null +++ b/gcc/ada/gnatlink.ads @@ -0,0 +1,30 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T L I N K -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1996-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +procedure Gnatlink; +-- The driver for the gnatlink tool. This utility produces an +-- executable program from a set compiled object files and +-- libraries. For more information on gnatlink (its precise usage, +-- flags and algorithm) please refer to the body of gnatlink. diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb new file mode 100644 index 000000000..b684ebbc8 --- /dev/null +++ b/gcc/ada/gnatls.adb @@ -0,0 +1,1880 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T L 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with ALI; use ALI; +with ALI.Util; use ALI.Util; +with Binderr; use Binderr; +with Butil; use Butil; +with Csets; use Csets; +with Fname; use Fname; +with Gnatvsn; use Gnatvsn; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Namet; use Namet; +with Opt; use Opt; +with Osint; use Osint; +with Osint.L; use Osint.L; +with Output; use Output; +with Rident; use Rident; +with Sdefault; +with Snames; +with Switch; use Switch; +with Types; use Types; + +with GNAT.Case_Util; use GNAT.Case_Util; + +procedure Gnatls is + pragma Ident (Gnat_Static_Version_String); + + Gpr_Project_Path : constant String := "GPR_PROJECT_PATH"; + Ada_Project_Path : constant String := "ADA_PROJECT_PATH"; + -- Names of the env. variables that contains path name(s) of directories + -- where project files may reside. If GPR_PROJECT_PATH is defined, its + -- value is used, otherwise ADA_PROJECT_PATH is used, if defined. + + -- NOTE : The following string may be used by other tools, such as GPS. So + -- it can only be modified if these other uses are checked and coordinated. + + Project_Search_Path : constant String := "Project Search Path:"; + -- Label displayed in verbose mode before the directories in the project + -- search path. Do not modify without checking NOTE above. + + No_Project_Default_Dir : constant String := "-"; + + Max_Column : constant := 80; + + No_Obj : aliased String := ""; + + type File_Status is ( + OK, -- matching timestamp + Checksum_OK, -- only matching checksum + Not_Found, -- file not found on source PATH + Not_Same, -- neither checksum nor timestamp matching + Not_First_On_PATH); -- matching file hidden by Not_Same file on path + + type Dir_Data; + type Dir_Ref is access Dir_Data; + + type Dir_Data is record + Value : String_Access; + Next : Dir_Ref; + end record; + -- ??? comment needed + + First_Source_Dir : Dir_Ref; + Last_Source_Dir : Dir_Ref; + -- The list of source directories from the command line. + -- These directories are added using Osint.Add_Src_Search_Dir + -- after those of the GNAT Project File, if any. + + First_Lib_Dir : Dir_Ref; + Last_Lib_Dir : Dir_Ref; + -- The list of object directories from the command line. + -- These directories are added using Osint.Add_Lib_Search_Dir + -- after those of the GNAT Project File, if any. + + Main_File : File_Name_Type; + Ali_File : File_Name_Type; + Text : Text_Buffer_Ptr; + Next_Arg : Positive; + + Too_Long : Boolean := False; + -- When True, lines are too long for multi-column output and each + -- item of information is on a different line. + + Selective_Output : Boolean := False; + Print_Usage : Boolean := False; + Print_Unit : Boolean := True; + Print_Source : Boolean := True; + Print_Object : Boolean := True; + -- Flags controlling the form of the output + + Also_Predef : Boolean := False; -- -a + Dependable : Boolean := False; -- -d + License : Boolean := False; -- -l + Very_Verbose_Mode : Boolean := False; -- -V + -- Command line flags + + Unit_Start : Integer; + Unit_End : Integer; + Source_Start : Integer; + Source_End : Integer; + Object_Start : Integer; + Object_End : Integer; + -- Various column starts and ends + + Spaces : constant String (1 .. Max_Column) := (others => ' '); + + RTS_Specified : String_Access := null; + -- Used to detect multiple use of --RTS= switch + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Add_Lib_Dir (Dir : String); + -- Add an object directory in the list First_Lib_Dir-Last_Lib_Dir + + procedure Add_Source_Dir (Dir : String); + -- Add a source directory in the list First_Source_Dir-Last_Source_Dir + + procedure Find_General_Layout; + -- Determine the structure of the output (multi columns or not, etc) + + procedure Find_Status + (FS : in out File_Name_Type; + Stamp : Time_Stamp_Type; + Checksum : Word; + Status : out File_Status); + -- Determine the file status (Status) of the file represented by FS + -- with the expected Stamp and checksum given as argument. FS will be + -- updated to the full file name if available. + + function Corresponding_Sdep_Entry (A : ALI_Id; U : Unit_Id) return Sdep_Id; + -- Give the Sdep entry corresponding to the unit U in ali record A + + procedure Output_Object (O : File_Name_Type); + -- Print out the name of the object when requested + + procedure Output_Source (Sdep_I : Sdep_Id); + -- Print out the name and status of the source corresponding to this + -- sdep entry. + + procedure Output_Status (FS : File_Status; Verbose : Boolean); + -- Print out FS either in a coded form if verbose is false or in an + -- expanded form otherwise. + + procedure Output_Unit (ALI : ALI_Id; U_Id : Unit_Id); + -- Print out information on the unit when requested + + procedure Reset_Print; + -- Reset Print flags properly when selective output is chosen + + procedure Scan_Ls_Arg (Argv : String); + -- Scan and process lser specific arguments. Argv is a single argument + + procedure Usage; + -- Print usage message + + procedure Output_License_Information; + -- Output license statement, and if not found, output reference to + -- COPYING. + + function Image (Restriction : Restriction_Id) return String; + -- Returns the capitalized image of Restriction + + ------------------------------------------ + -- GNATDIST specific output subprograms -- + ------------------------------------------ + + package GNATDIST is + + -- Any modification to this subunit requires synchronization with the + -- GNATDIST sources. + + procedure Output_ALI (A : ALI_Id); + -- Comment required saying what this routine does ??? + + procedure Output_No_ALI (Afile : File_Name_Type); + -- Comments required saying what this routine does ??? + + end GNATDIST; + + ----------------- + -- Add_Lib_Dir -- + ----------------- + + procedure Add_Lib_Dir (Dir : String) is + begin + if First_Lib_Dir = null then + First_Lib_Dir := + new Dir_Data' + (Value => new String'(Dir), + Next => null); + Last_Lib_Dir := First_Lib_Dir; + + else + Last_Lib_Dir.Next := + new Dir_Data' + (Value => new String'(Dir), + Next => null); + Last_Lib_Dir := Last_Lib_Dir.Next; + end if; + end Add_Lib_Dir; + + -- ----------------- + -- Add_Source_Dir -- + -------------------- + + procedure Add_Source_Dir (Dir : String) is + begin + if First_Source_Dir = null then + First_Source_Dir := + new Dir_Data' + (Value => new String'(Dir), + Next => null); + Last_Source_Dir := First_Source_Dir; + + else + Last_Source_Dir.Next := + new Dir_Data' + (Value => new String'(Dir), + Next => null); + Last_Source_Dir := Last_Source_Dir.Next; + end if; + end Add_Source_Dir; + + ------------------------------ + -- Corresponding_Sdep_Entry -- + ------------------------------ + + function Corresponding_Sdep_Entry + (A : ALI_Id; + U : Unit_Id) return Sdep_Id + is + begin + for D in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop + if Sdep.Table (D).Sfile = Units.Table (U).Sfile then + return D; + end if; + end loop; + + Error_Msg_Unit_1 := Units.Table (U).Uname; + Error_Msg_File_1 := ALIs.Table (A).Afile; + Write_Eol; + Error_Msg ("wrong ALI format, can't find dependency line for $ in {"); + Exit_Program (E_Fatal); + return No_Sdep_Id; + end Corresponding_Sdep_Entry; + + ------------------------- + -- Find_General_Layout -- + ------------------------- + + procedure Find_General_Layout is + Max_Unit_Length : Integer := 11; + Max_Src_Length : Integer := 11; + Max_Obj_Length : Integer := 11; + + Len : Integer; + FS : File_Name_Type; + + begin + -- Compute maximum of each column + + for Id in ALIs.First .. ALIs.Last loop + Get_Name_String (Units.Table (ALIs.Table (Id).First_Unit).Uname); + if Also_Predef or else not Is_Internal_Unit then + + if Print_Unit then + Len := Name_Len - 1; + Max_Unit_Length := Integer'Max (Max_Unit_Length, Len); + end if; + + if Print_Source then + FS := Full_Source_Name (ALIs.Table (Id).Sfile); + + if FS = No_File then + Get_Name_String (ALIs.Table (Id).Sfile); + Name_Len := Name_Len + 13; + else + Get_Name_String (FS); + end if; + + Max_Src_Length := Integer'Max (Max_Src_Length, Name_Len + 1); + end if; + + if Print_Object then + if ALIs.Table (Id).No_Object then + Max_Obj_Length := + Integer'Max (Max_Obj_Length, No_Obj'Length); + else + Get_Name_String (ALIs.Table (Id).Ofile_Full_Name); + Max_Obj_Length := Integer'Max (Max_Obj_Length, Name_Len + 1); + end if; + end if; + end if; + end loop; + + -- Verify is output is not wider than maximum number of columns + + Too_Long := + Verbose_Mode + or else + (Max_Unit_Length + Max_Src_Length + Max_Obj_Length) > Max_Column; + + -- Set start and end of columns + + Object_Start := 1; + Object_End := Object_Start - 1; + + if Print_Object then + Object_End := Object_Start + Max_Obj_Length; + end if; + + Unit_Start := Object_End + 1; + Unit_End := Unit_Start - 1; + + if Print_Unit then + Unit_End := Unit_Start + Max_Unit_Length; + end if; + + Source_Start := Unit_End + 1; + + if Source_Start > Spaces'Last then + Source_Start := Spaces'Last; + end if; + + Source_End := Source_Start - 1; + + if Print_Source then + Source_End := Source_Start + Max_Src_Length; + end if; + end Find_General_Layout; + + ----------------- + -- Find_Status -- + ----------------- + + procedure Find_Status + (FS : in out File_Name_Type; + Stamp : Time_Stamp_Type; + Checksum : Word; + Status : out File_Status) + is + Tmp1 : File_Name_Type; + Tmp2 : File_Name_Type; + + begin + Tmp1 := Full_Source_Name (FS); + + if Tmp1 = No_File then + Status := Not_Found; + + elsif File_Stamp (Tmp1) = Stamp then + FS := Tmp1; + Status := OK; + + elsif Checksums_Match (Get_File_Checksum (FS), Checksum) then + FS := Tmp1; + Status := Checksum_OK; + + else + Tmp2 := Matching_Full_Source_Name (FS, Stamp); + + if Tmp2 = No_File then + Status := Not_Same; + FS := Tmp1; + + else + Status := Not_First_On_PATH; + FS := Tmp2; + end if; + end if; + end Find_Status; + + -------------- + -- GNATDIST -- + -------------- + + package body GNATDIST is + + N_Flags : Natural; + N_Indents : Natural := 0; + + type Token_Type is + (T_No_ALI, + T_ALI, + T_Unit, + T_With, + T_Source, + T_Afile, + T_Ofile, + T_Sfile, + T_Name, + T_Main, + T_Kind, + T_Flags, + T_Preelaborated, + T_Pure, + T_Has_RACW, + T_Remote_Types, + T_Shared_Passive, + T_RCI, + T_Predefined, + T_Internal, + T_Is_Generic, + T_Procedure, + T_Function, + T_Package, + T_Subprogram, + T_Spec, + T_Body); + + Image : constant array (Token_Type) of String_Access := + (T_No_ALI => new String'("No_ALI"), + T_ALI => new String'("ALI"), + T_Unit => new String'("Unit"), + T_With => new String'("With"), + T_Source => new String'("Source"), + T_Afile => new String'("Afile"), + T_Ofile => new String'("Ofile"), + T_Sfile => new String'("Sfile"), + T_Name => new String'("Name"), + T_Main => new String'("Main"), + T_Kind => new String'("Kind"), + T_Flags => new String'("Flags"), + T_Preelaborated => new String'("Preelaborated"), + T_Pure => new String'("Pure"), + T_Has_RACW => new String'("Has_RACW"), + T_Remote_Types => new String'("Remote_Types"), + T_Shared_Passive => new String'("Shared_Passive"), + T_RCI => new String'("RCI"), + T_Predefined => new String'("Predefined"), + T_Internal => new String'("Internal"), + T_Is_Generic => new String'("Is_Generic"), + T_Procedure => new String'("procedure"), + T_Function => new String'("function"), + T_Package => new String'("package"), + T_Subprogram => new String'("subprogram"), + T_Spec => new String'("spec"), + T_Body => new String'("body")); + + procedure Output_Name (N : Name_Id); + -- Remove any encoding info (%b and %s) and output N + + procedure Output_Afile (A : File_Name_Type); + procedure Output_Ofile (O : File_Name_Type); + procedure Output_Sfile (S : File_Name_Type); + -- Output various names. Check that the name is different from no name. + -- Otherwise, skip the output. + + procedure Output_Token (T : Token_Type); + -- Output token using specific format. That is several indentations and: + -- + -- T_No_ALI .. T_With : & " =>" & NL + -- T_Source .. T_Kind : & " => " + -- T_Flags : & " =>" + -- T_Preelab .. T_Body : " " & + + procedure Output_Sdep (S : Sdep_Id); + procedure Output_Unit (U : Unit_Id); + procedure Output_With (W : With_Id); + -- Output this entry as a global section (like ALIs) + + ------------------ + -- Output_Afile -- + ------------------ + + procedure Output_Afile (A : File_Name_Type) is + begin + if A /= No_File then + Output_Token (T_Afile); + Write_Name (A); + Write_Eol; + end if; + end Output_Afile; + + ---------------- + -- Output_ALI -- + ---------------- + + procedure Output_ALI (A : ALI_Id) is + begin + Output_Token (T_ALI); + N_Indents := N_Indents + 1; + + Output_Afile (ALIs.Table (A).Afile); + Output_Ofile (ALIs.Table (A).Ofile_Full_Name); + Output_Sfile (ALIs.Table (A).Sfile); + + -- Output Main + + if ALIs.Table (A).Main_Program /= None then + Output_Token (T_Main); + + if ALIs.Table (A).Main_Program = Proc then + Output_Token (T_Procedure); + else + Output_Token (T_Function); + end if; + + Write_Eol; + end if; + + -- Output Units + + for U in ALIs.Table (A).First_Unit .. ALIs.Table (A).Last_Unit loop + Output_Unit (U); + end loop; + + -- Output Sdeps + + for S in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop + Output_Sdep (S); + end loop; + + N_Indents := N_Indents - 1; + end Output_ALI; + + ------------------- + -- Output_No_ALI -- + ------------------- + + procedure Output_No_ALI (Afile : File_Name_Type) is + begin + Output_Token (T_No_ALI); + N_Indents := N_Indents + 1; + Output_Afile (Afile); + N_Indents := N_Indents - 1; + end Output_No_ALI; + + ----------------- + -- Output_Name -- + ----------------- + + procedure Output_Name (N : Name_Id) is + begin + -- Remove any encoding info (%s or %b) + + Get_Name_String (N); + + if Name_Len > 2 + and then Name_Buffer (Name_Len - 1) = '%' + then + Name_Len := Name_Len - 2; + end if; + + Output_Token (T_Name); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Eol; + end Output_Name; + + ------------------ + -- Output_Ofile -- + ------------------ + + procedure Output_Ofile (O : File_Name_Type) is + begin + if O /= No_File then + Output_Token (T_Ofile); + Write_Name (O); + Write_Eol; + end if; + end Output_Ofile; + + ----------------- + -- Output_Sdep -- + ----------------- + + procedure Output_Sdep (S : Sdep_Id) is + begin + Output_Token (T_Source); + Write_Name (Sdep.Table (S).Sfile); + Write_Eol; + end Output_Sdep; + + ------------------ + -- Output_Sfile -- + ------------------ + + procedure Output_Sfile (S : File_Name_Type) is + FS : File_Name_Type := S; + + begin + if FS /= No_File then + + -- We want to output the full source name + + FS := Full_Source_Name (FS); + + -- There is no full source name. This occurs for instance when a + -- withed unit has a spec file but no body file. This situation is + -- not a problem for GNATDIST since the unit may be located on a + -- partition we do not want to build. However, we need to locate + -- the spec file and to find its full source name. Replace the + -- body file name with the spec file name used to compile the + -- current unit when possible. + + if FS = No_File then + Get_Name_String (S); + + if Name_Len > 4 + and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb" + then + Name_Buffer (Name_Len) := 's'; + FS := Full_Source_Name (Name_Find); + end if; + end if; + end if; + + if FS /= No_File then + Output_Token (T_Sfile); + Write_Name (FS); + Write_Eol; + end if; + end Output_Sfile; + + ------------------ + -- Output_Token -- + ------------------ + + procedure Output_Token (T : Token_Type) is + begin + if T in T_No_ALI .. T_Flags then + for J in 1 .. N_Indents loop + Write_Str (" "); + end loop; + + Write_Str (Image (T).all); + + for J in Image (T)'Length .. 12 loop + Write_Char (' '); + end loop; + + Write_Str ("=>"); + + if T in T_No_ALI .. T_With then + Write_Eol; + elsif T in T_Source .. T_Name then + Write_Char (' '); + end if; + + elsif T in T_Preelaborated .. T_Body then + if T in T_Preelaborated .. T_Is_Generic then + if N_Flags = 0 then + Output_Token (T_Flags); + end if; + + N_Flags := N_Flags + 1; + end if; + + Write_Char (' '); + Write_Str (Image (T).all); + + else + Write_Str (Image (T).all); + end if; + end Output_Token; + + ----------------- + -- Output_Unit -- + ----------------- + + procedure Output_Unit (U : Unit_Id) is + begin + Output_Token (T_Unit); + N_Indents := N_Indents + 1; + + -- Output Name + + Output_Name (Name_Id (Units.Table (U).Uname)); + + -- Output Kind + + Output_Token (T_Kind); + + if Units.Table (U).Unit_Kind = 'p' then + Output_Token (T_Package); + else + Output_Token (T_Subprogram); + end if; + + if Name_Buffer (Name_Len) = 's' then + Output_Token (T_Spec); + else + Output_Token (T_Body); + end if; + + Write_Eol; + + -- Output source file name + + Output_Sfile (Units.Table (U).Sfile); + + -- Output Flags + + N_Flags := 0; + + if Units.Table (U).Preelab then + Output_Token (T_Preelaborated); + end if; + + if Units.Table (U).Pure then + Output_Token (T_Pure); + end if; + + if Units.Table (U).Has_RACW then + Output_Token (T_Has_RACW); + end if; + + if Units.Table (U).Remote_Types then + Output_Token (T_Remote_Types); + end if; + + if Units.Table (U).Shared_Passive then + Output_Token (T_Shared_Passive); + end if; + + if Units.Table (U).RCI then + Output_Token (T_RCI); + end if; + + if Units.Table (U).Predefined then + Output_Token (T_Predefined); + end if; + + if Units.Table (U).Internal then + Output_Token (T_Internal); + end if; + + if Units.Table (U).Is_Generic then + Output_Token (T_Is_Generic); + end if; + + if N_Flags > 0 then + Write_Eol; + end if; + + -- Output Withs + + for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop + Output_With (W); + end loop; + + N_Indents := N_Indents - 1; + end Output_Unit; + + ----------------- + -- Output_With -- + ----------------- + + procedure Output_With (W : With_Id) is + begin + Output_Token (T_With); + N_Indents := N_Indents + 1; + + Output_Name (Name_Id (Withs.Table (W).Uname)); + + -- Output Kind + + Output_Token (T_Kind); + + if Name_Buffer (Name_Len) = 's' then + Output_Token (T_Spec); + else + Output_Token (T_Body); + end if; + + Write_Eol; + + Output_Afile (Withs.Table (W).Afile); + Output_Sfile (Withs.Table (W).Sfile); + + N_Indents := N_Indents - 1; + end Output_With; + + end GNATDIST; + + ----------- + -- Image -- + ----------- + + function Image (Restriction : Restriction_Id) return String is + Result : String := Restriction'Img; + Skip : Boolean := True; + + begin + for J in Result'Range loop + if Skip then + Skip := False; + Result (J) := To_Upper (Result (J)); + + elsif Result (J) = '_' then + Skip := True; + + else + Result (J) := To_Lower (Result (J)); + end if; + end loop; + + return Result; + end Image; + + -------------------------------- + -- Output_License_Information -- + -------------------------------- + + procedure Output_License_Information is + Params_File_Name : constant String := "gnatlic.adl"; + -- Name of license file + + Lo : constant Source_Ptr := 1; + Hi : Source_Ptr; + Text : Source_Buffer_Ptr; + + begin + Name_Len := 0; + Add_Str_To_Name_Buffer (Params_File_Name); + Read_Source_File (Name_Find, Lo, Hi, Text); + + if Text /= null then + + -- Omit last character (end-of-file marker) in output + + Write_Str (String (Text (Lo .. Hi - 1))); + Write_Eol; + + -- The following condition is determined at compile time: disable + -- "condition is always true/false" warning. + + pragma Warnings (Off); + elsif Build_Type /= GPL and then Build_Type /= FSF then + pragma Warnings (On); + + Write_Str ("License file missing, please contact AdaCore."); + Write_Eol; + + else + Write_Str ("Please refer to file COPYING in your distribution" + & " for license terms."); + Write_Eol; + + end if; + + Exit_Program (E_Success); + end Output_License_Information; + + ------------------- + -- Output_Object -- + ------------------- + + procedure Output_Object (O : File_Name_Type) is + Object_Name : String_Access; + + begin + if Print_Object then + if O /= No_File then + Get_Name_String (O); + Object_Name := To_Host_File_Spec (Name_Buffer (1 .. Name_Len)); + else + Object_Name := No_Obj'Unchecked_Access; + end if; + + Write_Str (Object_Name.all); + + if Print_Source or else Print_Unit then + if Too_Long then + Write_Eol; + Write_Str (" "); + else + Write_Str (Spaces + (Object_Start + Object_Name'Length .. Object_End)); + end if; + end if; + end if; + end Output_Object; + + ------------------- + -- Output_Source -- + ------------------- + + procedure Output_Source (Sdep_I : Sdep_Id) is + Stamp : Time_Stamp_Type; + Checksum : Word; + FS : File_Name_Type; + Status : File_Status; + Object_Name : String_Access; + + begin + if Sdep_I = No_Sdep_Id then + return; + end if; + + Stamp := Sdep.Table (Sdep_I).Stamp; + Checksum := Sdep.Table (Sdep_I).Checksum; + FS := Sdep.Table (Sdep_I).Sfile; + + if Print_Source then + Find_Status (FS, Stamp, Checksum, Status); + Get_Name_String (FS); + + Object_Name := To_Host_File_Spec (Name_Buffer (1 .. Name_Len)); + + if Verbose_Mode then + Write_Str (" Source => "); + Write_Str (Object_Name.all); + + if not Too_Long then + Write_Str + (Spaces (Source_Start + Object_Name'Length .. Source_End)); + end if; + + Output_Status (Status, Verbose => True); + Write_Eol; + Write_Str (" "); + + else + if not Selective_Output then + Output_Status (Status, Verbose => False); + end if; + + Write_Str (Object_Name.all); + end if; + end if; + end Output_Source; + + ------------------- + -- Output_Status -- + ------------------- + + procedure Output_Status (FS : File_Status; Verbose : Boolean) is + begin + if Verbose then + case FS is + when OK => + Write_Str (" unchanged"); + + when Checksum_OK => + Write_Str (" slightly modified"); + + when Not_Found => + Write_Str (" file not found"); + + when Not_Same => + Write_Str (" modified"); + + when Not_First_On_PATH => + Write_Str (" unchanged version not first on PATH"); + end case; + + else + case FS is + when OK => + Write_Str (" OK "); + + when Checksum_OK => + Write_Str (" MOK "); + + when Not_Found => + Write_Str (" ??? "); + + when Not_Same => + Write_Str (" DIF "); + + when Not_First_On_PATH => + Write_Str (" HID "); + end case; + end if; + end Output_Status; + + ----------------- + -- Output_Unit -- + ----------------- + + procedure Output_Unit (ALI : ALI_Id; U_Id : Unit_Id) is + Kind : Character; + U : Unit_Record renames Units.Table (U_Id); + + begin + if Print_Unit then + Get_Name_String (U.Uname); + Kind := Name_Buffer (Name_Len); + Name_Len := Name_Len - 2; + + if not Verbose_Mode then + Write_Str (Name_Buffer (1 .. Name_Len)); + + else + Write_Str ("Unit => "); + Write_Eol; + Write_Str (" Name => "); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Eol; + Write_Str (" Kind => "); + + if Units.Table (U_Id).Unit_Kind = 'p' then + Write_Str ("package "); + else + Write_Str ("subprogram "); + end if; + + if Kind = 's' then + Write_Str ("spec"); + else + Write_Str ("body"); + end if; + end if; + + if Verbose_Mode then + if U.Preelab or else + U.No_Elab or else + U.Pure or else + U.Dynamic_Elab or else + U.Has_RACW or else + U.Remote_Types or else + U.Shared_Passive or else + U.RCI or else + U.Predefined or else + U.Internal or else + U.Is_Generic or else + U.Init_Scalars or else + U.SAL_Interface or else + U.Body_Needed_For_SAL or else + U.Elaborate_Body + then + Write_Eol; + Write_Str (" Flags =>"); + + if U.Preelab then + Write_Str (" Preelaborable"); + end if; + + if U.No_Elab then + Write_Str (" No_Elab_Code"); + end if; + + if U.Pure then + Write_Str (" Pure"); + end if; + + if U.Dynamic_Elab then + Write_Str (" Dynamic_Elab"); + end if; + + if U.Has_RACW then + Write_Str (" Has_RACW"); + end if; + + if U.Remote_Types then + Write_Str (" Remote_Types"); + end if; + + if U.Shared_Passive then + Write_Str (" Shared_Passive"); + end if; + + if U.RCI then + Write_Str (" RCI"); + end if; + + if U.Predefined then + Write_Str (" Predefined"); + end if; + + if U.Internal then + Write_Str (" Internal"); + end if; + + if U.Is_Generic then + Write_Str (" Is_Generic"); + end if; + + if U.Init_Scalars then + Write_Str (" Init_Scalars"); + end if; + + if U.SAL_Interface then + Write_Str (" SAL_Interface"); + end if; + + if U.Body_Needed_For_SAL then + Write_Str (" Body_Needed_For_SAL"); + end if; + + if U.Elaborate_Body then + Write_Str (" Elaborate Body"); + end if; + + if U.Remote_Types then + Write_Str (" Remote_Types"); + end if; + + if U.Shared_Passive then + Write_Str (" Shared_Passive"); + end if; + + if U.Predefined then + Write_Str (" Predefined"); + end if; + end if; + + declare + Restrictions : constant Restrictions_Info := + ALIs.Table (ALI).Restrictions; + + begin + -- If the source was compiled with pragmas Restrictions, + -- Display these restrictions. + + if Restrictions.Set /= (All_Restrictions => False) then + Write_Eol; + Write_Str (" pragma Restrictions =>"); + + -- For boolean restrictions, just display the name of the + -- restriction; for valued restrictions, also display the + -- restriction value. + + for Restriction in All_Restrictions loop + if Restrictions.Set (Restriction) then + Write_Eol; + Write_Str (" "); + Write_Str (Image (Restriction)); + + if Restriction in All_Parameter_Restrictions then + Write_Str (" =>"); + Write_Str (Restrictions.Value (Restriction)'Img); + end if; + end if; + end loop; + end if; + + -- If the unit violates some Restrictions, display the list of + -- these restrictions. + + if Restrictions.Violated /= (All_Restrictions => False) then + Write_Eol; + Write_Str (" Restrictions violated =>"); + + -- For boolean restrictions, just display the name of the + -- restriction. For valued restrictions, also display the + -- restriction value. + + for Restriction in All_Restrictions loop + if Restrictions.Violated (Restriction) then + Write_Eol; + Write_Str (" "); + Write_Str (Image (Restriction)); + + if Restriction in All_Parameter_Restrictions then + if Restrictions.Count (Restriction) > 0 then + Write_Str (" =>"); + + if Restrictions.Unknown (Restriction) then + Write_Str (" at least"); + end if; + + Write_Str (Restrictions.Count (Restriction)'Img); + end if; + end if; + end if; + end loop; + end if; + end; + end if; + + if Print_Source then + if Too_Long then + Write_Eol; + Write_Str (" "); + else + Write_Str (Spaces (Unit_Start + Name_Len + 1 .. Unit_End)); + end if; + end if; + end if; + end Output_Unit; + + ----------------- + -- Reset_Print -- + ----------------- + + procedure Reset_Print is + begin + if not Selective_Output then + Selective_Output := True; + Print_Source := False; + Print_Object := False; + Print_Unit := False; + end if; + end Reset_Print; + + ------------------- + -- Scan_Ls_Arg -- + ------------------- + + procedure Scan_Ls_Arg (Argv : String) is + FD : File_Descriptor; + Len : Integer; + + begin + pragma Assert (Argv'First = 1); + + if Argv'Length = 0 then + return; + end if; + + if Argv (1) = '-' then + if Argv'Length = 1 then + Fail ("switch character cannot be followed by a blank"); + + -- Processing for -I- + + elsif Argv (2 .. Argv'Last) = "I-" then + Opt.Look_In_Primary_Dir := False; + + -- Forbid -?- or -??- where ? is any character + + elsif (Argv'Length = 3 and then Argv (3) = '-') + or else (Argv'Length = 4 and then Argv (4) = '-') + then + Fail ("Trailing ""-"" at the end of " & Argv & " forbidden."); + + -- Processing for -Idir + + elsif Argv (2) = 'I' then + Add_Source_Dir (Argv (3 .. Argv'Last)); + Add_Lib_Dir (Argv (3 .. Argv'Last)); + + -- Processing for -aIdir (to gcc this is like a -I switch) + + elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aI" then + Add_Source_Dir (Argv (4 .. Argv'Last)); + + -- Processing for -aOdir + + elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aO" then + Add_Lib_Dir (Argv (4 .. Argv'Last)); + + -- Processing for -aLdir (to gnatbind this is like a -aO switch) + + elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aL" then + Add_Lib_Dir (Argv (4 .. Argv'Last)); + + -- Processing for -nostdinc + + elsif Argv (2 .. Argv'Last) = "nostdinc" then + Opt.No_Stdinc := True; + + -- Processing for one character switches + + elsif Argv'Length = 2 then + case Argv (2) is + when 'a' => Also_Predef := True; + when 'h' => Print_Usage := True; + when 'u' => Reset_Print; Print_Unit := True; + when 's' => Reset_Print; Print_Source := True; + when 'o' => Reset_Print; Print_Object := True; + when 'v' => Verbose_Mode := True; + when 'd' => Dependable := True; + when 'l' => License := True; + when 'V' => Very_Verbose_Mode := True; + + when others => null; + end case; + + -- Processing for -files=file + + elsif Argv'Length > 7 and then Argv (1 .. 7) = "-files=" then + FD := Open_Read (Argv (8 .. Argv'Last), GNAT.OS_Lib.Text); + + if FD = Invalid_FD then + Osint.Fail ("could not find text file """ & + Argv (8 .. Argv'Last) & '"'); + end if; + + Len := Integer (File_Length (FD)); + + declare + Buffer : String (1 .. Len + 1); + Index : Positive := 1; + Last : Positive; + + begin + -- Read the file + + Len := Read (FD, Buffer (1)'Address, Len); + Buffer (Buffer'Last) := ASCII.NUL; + Close (FD); + + -- Scan the file line by line + + while Index < Buffer'Last loop + + -- Find the end of line + + Last := Index; + while Last <= Buffer'Last + and then Buffer (Last) /= ASCII.LF + and then Buffer (Last) /= ASCII.CR + loop + Last := Last + 1; + end loop; + + -- Ignore empty lines + + if Last > Index then + Add_File (Buffer (Index .. Last - 1)); + end if; + + -- Find the beginning of the next line + + Index := Last; + while Buffer (Index) = ASCII.CR or else + Buffer (Index) = ASCII.LF + loop + Index := Index + 1; + end loop; + end loop; + end; + + -- Processing for --RTS=path + + elsif Argv'Length >= 5 and then Argv (1 .. 5) = "--RTS" then + if Argv'Length <= 6 or else Argv (6) /= '='then + Osint.Fail ("missing path for --RTS"); + + else + -- Check that it is the first time we see this switch or, if + -- it is not the first time, the same path is specified. + + if RTS_Specified = null then + RTS_Specified := new String'(Argv (7 .. Argv'Last)); + + elsif RTS_Specified.all /= Argv (7 .. Argv'Last) then + Osint.Fail ("--RTS cannot be specified multiple times"); + end if; + + -- Valid --RTS switch + + Opt.No_Stdinc := True; + Opt.RTS_Switch := True; + + declare + Src_Path_Name : constant String_Ptr := + Get_RTS_Search_Dir + (Argv (7 .. Argv'Last), Include); + Lib_Path_Name : constant String_Ptr := + Get_RTS_Search_Dir + (Argv (7 .. Argv'Last), Objects); + + begin + if Src_Path_Name /= null + and then Lib_Path_Name /= null + then + Add_Search_Dirs (Src_Path_Name, Include); + Add_Search_Dirs (Lib_Path_Name, Objects); + + elsif Src_Path_Name = null + and then Lib_Path_Name = null + then + Osint.Fail ("RTS path not valid: missing " & + "adainclude and adalib directories"); + + elsif Src_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adainclude directory"); + + elsif Lib_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adalib directory"); + end if; + end; + end if; + end if; + + -- If not a switch, it must be a file name + + else + Add_File (Argv); + end if; + end Scan_Ls_Arg; + + ----------- + -- Usage -- + ----------- + + procedure Usage is + begin + -- Usage line + + Write_Str ("Usage: "); + Osint.Write_Program_Name; + Write_Str (" switches [list of object files]"); + Write_Eol; + Write_Eol; + + -- GNATLS switches + + Write_Str ("switches:"); + Write_Eol; + + -- Line for -a + + Write_Str (" -a also output relevant predefined units"); + Write_Eol; + + -- Line for -u + + Write_Str (" -u output only relevant unit names"); + Write_Eol; + + -- Line for -h + + Write_Str (" -h output this help message"); + Write_Eol; + + -- Line for -s + + Write_Str (" -s output only relevant source names"); + Write_Eol; + + -- Line for -o + + Write_Str (" -o output only relevant object names"); + Write_Eol; + + -- Line for -d + + Write_Str (" -d output sources on which specified units " & + "depend"); + Write_Eol; + + -- Line for -l + + Write_Str (" -l output license information"); + Write_Eol; + + -- Line for -v + + Write_Str (" -v verbose output, full path and unit " & + "information"); + Write_Eol; + Write_Eol; + + -- Line for -files= + + Write_Str (" -files=fil files are listed in text file 'fil'"); + Write_Eol; + + -- Line for -aI switch + + Write_Str (" -aIdir specify source files search path"); + Write_Eol; + + -- Line for -aO switch + + Write_Str (" -aOdir specify object files search path"); + Write_Eol; + + -- Line for -I switch + + Write_Str (" -Idir like -aIdir -aOdir"); + Write_Eol; + + -- Line for -I- switch + + Write_Str (" -I- do not look for sources & object files"); + Write_Str (" in the default directory"); + Write_Eol; + + -- Line for -nostdinc + + Write_Str (" -nostdinc do not look for source files"); + Write_Str (" in the system default directory"); + Write_Eol; + + -- Line for --RTS + + Write_Str (" --RTS=dir specify the default source and object search" + & " path"); + Write_Eol; + + -- File Status explanation + + Write_Eol; + Write_Str (" file status can be:"); + Write_Eol; + + for ST in File_Status loop + Write_Str (" "); + Output_Status (ST, Verbose => False); + Write_Str (" ==> "); + Output_Status (ST, Verbose => True); + Write_Eol; + end loop; + end Usage; + + procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); + +-- Start of processing for Gnatls + +begin + -- Initialize standard packages + + Csets.Initialize; + Snames.Initialize; + + -- First check for --version or --help + + Check_Version_And_Help ("GNATLS", "1997"); + + -- Loop to scan out arguments + + Next_Arg := 1; + Scan_Args : while Next_Arg < Arg_Count loop + declare + Next_Argv : String (1 .. Len_Arg (Next_Arg)); + begin + Fill_Arg (Next_Argv'Address, Next_Arg); + Scan_Ls_Arg (Next_Argv); + end; + + Next_Arg := Next_Arg + 1; + end loop Scan_Args; + + -- If -l (output license information) is given, it must be the only switch + + if License and then Arg_Count /= 2 then + Write_Str ("Can't use -l with another switch"); + Write_Eol; + Usage; + Exit_Program (E_Fatal); + end if; + + -- Add the source and object directories specified on the command line, if + -- any, to the searched directories. + + while First_Source_Dir /= null loop + Add_Src_Search_Dir (First_Source_Dir.Value.all); + First_Source_Dir := First_Source_Dir.Next; + end loop; + + while First_Lib_Dir /= null loop + Add_Lib_Search_Dir (First_Lib_Dir.Value.all); + First_Lib_Dir := First_Lib_Dir.Next; + end loop; + + -- Finally, add the default directories and obtain target parameters + + Osint.Add_Default_Search_Dirs; + + if Verbose_Mode then + Write_Eol; + Display_Version ("GNATLS", "1997"); + Write_Eol; + Write_Str ("Source Search Path:"); + Write_Eol; + + for J in 1 .. Nb_Dir_In_Src_Search_Path loop + Write_Str (" "); + + if Dir_In_Src_Search_Path (J)'Length = 0 then + Write_Str (""); + else + Write_Str (To_Host_Dir_Spec + (Dir_In_Src_Search_Path (J).all, True).all); + end if; + + Write_Eol; + end loop; + + Write_Eol; + Write_Eol; + Write_Str ("Object Search Path:"); + Write_Eol; + + for J in 1 .. Nb_Dir_In_Obj_Search_Path loop + Write_Str (" "); + + if Dir_In_Obj_Search_Path (J)'Length = 0 then + Write_Str (""); + else + Write_Str (To_Host_Dir_Spec + (Dir_In_Obj_Search_Path (J).all, True).all); + end if; + + Write_Eol; + end loop; + + Write_Eol; + Write_Eol; + Write_Str (Project_Search_Path); + Write_Eol; + Write_Str (" "); + Write_Eol; + + declare + Project_Path : String_Access := Getenv (Gpr_Project_Path); + + Lib : constant String := + Directory_Separator & "lib" & Directory_Separator; + + First : Natural; + Last : Natural; + + Add_Default_Dir : Boolean := True; + + begin + -- If there is a project path, display each directory in the path + + if Project_Path.all = "" then + Project_Path := Getenv (Ada_Project_Path); + end if; + + if Project_Path.all /= "" then + First := Project_Path'First; + loop + while First <= Project_Path'Last + and then (Project_Path (First) = Path_Separator) + loop + First := First + 1; + end loop; + + exit when First > Project_Path'Last; + + Last := First; + while Last < Project_Path'Last + and then Project_Path (Last + 1) /= Path_Separator + loop + Last := Last + 1; + end loop; + + -- If the directory is No_Default_Project_Dir, set + -- Add_Default_Dir to False. + + if Project_Path (First .. Last) = No_Project_Default_Dir then + Add_Default_Dir := False; + + elsif First /= Last or else Project_Path (First) /= '.' then + + -- If the directory is ".", skip it as it is the current + -- directory and it is already the first directory in the + -- project path. + + Write_Str (" "); + Write_Str + (To_Host_Dir_Spec + (Project_Path (First .. Last), True).all); + Write_Eol; + end if; + + First := Last + 1; + end loop; + end if; + + -- Add the default dir, except if "-" was one of the "directories" + -- specified in ADA_PROJECT_DIR. + + if Add_Default_Dir then + Name_Len := 0; + Add_Str_To_Name_Buffer (Sdefault.Search_Dir_Prefix.all); + + -- On Windows, make sure that all directory separators are '\' + + if Directory_Separator /= '/' then + for J in 1 .. Name_Len loop + if Name_Buffer (J) = '/' then + Name_Buffer (J) := Directory_Separator; + end if; + end loop; + end if; + + -- Find the sequence "/lib/" + + while Name_Len >= Lib'Length + and then Name_Buffer (Name_Len - 4 .. Name_Len) /= Lib + loop + Name_Len := Name_Len - 1; + end loop; + + -- If the sequence "/lib"/ was found, display the default + -- directory /lib/gnat/. + + if Name_Len >= 5 then + Name_Buffer (Name_Len + 1 .. Name_Len + 4) := "gnat"; + Name_Buffer (Name_Len + 5) := Directory_Separator; + Name_Len := Name_Len + 5; + Write_Str (" "); + Write_Line + (To_Host_Dir_Spec (Name_Buffer (1 .. Name_Len), True).all); + end if; + end if; + end; + + Write_Eol; + end if; + + -- Output usage information when requested + + if Print_Usage then + Usage; + end if; + + -- Output license information when requested + + if License then + Output_License_Information; + Exit_Program (E_Success); + end if; + + if not More_Lib_Files then + if not Print_Usage and then not Verbose_Mode then + Usage; + end if; + + Exit_Program (E_Fatal); + end if; + + Initialize_ALI; + Initialize_ALI_Source; + + -- Print out all library for which no ALI files can be located + + while More_Lib_Files loop + Main_File := Next_Main_Lib_File; + Ali_File := Full_Lib_File_Name (Lib_File_Name (Main_File)); + + if Ali_File = No_File then + if Very_Verbose_Mode then + GNATDIST.Output_No_ALI (Lib_File_Name (Main_File)); + + else + Write_Str ("Can't find library info for "); + Get_Name_String (Main_File); + Write_Char ('"'); -- " + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Char ('"'); -- " + Write_Eol; + end if; + + else + Ali_File := Strip_Directory (Ali_File); + + if Get_Name_Table_Info (Ali_File) = 0 then + Text := Read_Library_Info (Ali_File, True); + + declare + Discard : ALI_Id; + pragma Unreferenced (Discard); + begin + Discard := + Scan_ALI + (Ali_File, + Text, + Ignore_ED => False, + Err => False, + Ignore_Errors => True); + end; + + Free (Text); + end if; + end if; + end loop; + + if Very_Verbose_Mode then + for A in ALIs.First .. ALIs.Last loop + GNATDIST.Output_ALI (A); + end loop; + + return; + end if; + + Find_General_Layout; + + for Id in ALIs.First .. ALIs.Last loop + declare + Last_U : Unit_Id; + + begin + Get_Name_String (Units.Table (ALIs.Table (Id).First_Unit).Uname); + + if Also_Predef or else not Is_Internal_Unit then + if ALIs.Table (Id).No_Object then + Output_Object (No_File); + else + Output_Object (ALIs.Table (Id).Ofile_Full_Name); + end if; + + -- In verbose mode print all main units in the ALI file, otherwise + -- just print the first one to ease columnwise printout + + if Verbose_Mode then + Last_U := ALIs.Table (Id).Last_Unit; + else + Last_U := ALIs.Table (Id).First_Unit; + end if; + + for U in ALIs.Table (Id).First_Unit .. Last_U loop + if U /= ALIs.Table (Id).First_Unit + and then Selective_Output + and then Print_Unit + then + Write_Eol; + end if; + + Output_Unit (Id, U); + + -- Output source now, unless if it will be done as part of + -- outputing dependencies. + + if not (Dependable and then Print_Source) then + Output_Source (Corresponding_Sdep_Entry (Id, U)); + end if; + end loop; + + -- Print out list of units on which this unit depends (D lines) + + if Dependable and then Print_Source then + if Verbose_Mode then + Write_Str ("depends upon"); + Write_Eol; + Write_Str (" "); + else + Write_Eol; + end if; + + for D in + ALIs.Table (Id).First_Sdep .. ALIs.Table (Id).Last_Sdep + loop + if Also_Predef + or else not Is_Internal_File_Name (Sdep.Table (D).Sfile) + then + if Verbose_Mode then + Write_Str (" "); + Output_Source (D); + + elsif Too_Long then + Write_Str (" "); + Output_Source (D); + Write_Eol; + + else + Write_Str (Spaces (1 .. Source_Start - 2)); + Output_Source (D); + Write_Eol; + end if; + end if; + end loop; + end if; + + Write_Eol; + end if; + end; + end loop; + + -- All done. Set proper exit status + + Namet.Finalize; + Exit_Program (E_Success); +end Gnatls; diff --git a/gcc/ada/gnatls.ads b/gcc/ada/gnatls.ads new file mode 100644 index 000000000..8c890f64a --- /dev/null +++ b/gcc/ada/gnatls.ads @@ -0,0 +1,28 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T L S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- GNAT Library browser + +procedure Gnatls; diff --git a/gcc/ada/gnatmake.adb b/gcc/ada/gnatmake.adb new file mode 100644 index 000000000..72e3fd622 --- /dev/null +++ b/gcc/ada/gnatmake.adb @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T M A K E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Gnatmake usage: please consult the gnat documentation + +with Gnatvsn; +with Make; + +procedure Gnatmake is + pragma Ident (Gnatvsn.Gnat_Static_Version_String); +begin + -- The real work is done in Package Make. Gnatmake used to be a standalone + -- routine. Now Gnatmake's facilities have been placed in a package + -- because a number of gnatmake's services may be useful to others. + + Make.Gnatmake; +end Gnatmake; diff --git a/gcc/ada/gnatmake.ads b/gcc/ada/gnatmake.ads new file mode 100644 index 000000000..1bcb40f92 --- /dev/null +++ b/gcc/ada/gnatmake.ads @@ -0,0 +1,30 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T M A K E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +procedure Gnatmake; +-- The driver for the gnatmake tool. This utility can be used to automatically +-- (re)compile a set of ada sources by giving the name of the root compilation +-- unit or the source file containing it. For more information on gnatmake +-- (its precise usage, flags and algorithm) please refer to the gnatmake body. diff --git a/gcc/ada/gnatname.adb b/gcc/ada/gnatname.adb new file mode 100644 index 000000000..00ebebe41 --- /dev/null +++ b/gcc/ada/gnatname.adb @@ -0,0 +1,704 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T N A M E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.Dynamic_Tables; +with GNAT.OS_Lib; use GNAT.OS_Lib; + +with Hostparm; +with Opt; +with Osint; use Osint; +with Output; use Output; +with Prj; use Prj; +with Prj.Makr; +with Switch; use Switch; +with Table; + +with System.Regexp; use System.Regexp; + +procedure Gnatname is + + Subdirs_Switch : constant String := "--subdirs="; + + Usage_Output : Boolean := False; + -- Set to True when usage is output, to avoid multiple output + + Usage_Needed : Boolean := False; + -- Set to True by -h switch + + Version_Output : Boolean := False; + -- Set to True when version is output, to avoid multiple output + + Very_Verbose : Boolean := False; + -- Set to True with -v -v + + Create_Project : Boolean := False; + -- Set to True with a -P switch + + File_Path : String_Access := new String'("gnat.adc"); + -- Path name of the file specified by -c or -P switch + + File_Set : Boolean := False; + -- Set to True by -c or -P switch. + -- Used to detect multiple -c/-P switches. + + package Patterns is new GNAT.Dynamic_Tables + (Table_Component_Type => String_Access, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 100); + -- Table to accumulate the patterns + + type Argument_Data is record + Directories : Patterns.Instance; + Name_Patterns : Patterns.Instance; + Excluded_Patterns : Patterns.Instance; + Foreign_Patterns : Patterns.Instance; + end record; + + package Arguments is new Table.Table + (Table_Component_Type => Argument_Data, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Gnatname.Arguments"); + -- Table to accumulate the foreign patterns + + package Preprocessor_Switches is new Table.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Gnatname.Preprocessor_Switches"); + -- Table to store the preprocessor switches to be used in the call + -- to the compiler. + + procedure Output_Version; + -- Print name and version + + procedure Usage; + -- Print usage + + procedure Scan_Args; + -- Scan the command line arguments + + procedure Add_Source_Directory (S : String); + -- Add S in the Source_Directories table + + procedure Get_Directories (From_File : String); + -- Read a source directory text file + + -------------------------- + -- Add_Source_Directory -- + -------------------------- + + procedure Add_Source_Directory (S : String) is + begin + Patterns.Append + (Arguments.Table (Arguments.Last).Directories, new String'(S)); + end Add_Source_Directory; + + --------------------- + -- Get_Directories -- + --------------------- + + procedure Get_Directories (From_File : String) is + File : Ada.Text_IO.File_Type; + Line : String (1 .. 2_000); + Last : Natural; + + begin + Open (File, In_File, From_File); + + while not End_Of_File (File) loop + Get_Line (File, Line, Last); + + if Last /= 0 then + Add_Source_Directory (Line (1 .. Last)); + end if; + end loop; + + Close (File); + + exception + when Name_Error => + Fail ("cannot open source directory file """ & From_File & '"'); + end Get_Directories; + + -------------------- + -- Output_Version -- + -------------------- + + procedure Output_Version is + begin + if not Version_Output then + Version_Output := True; + Output.Write_Eol; + Display_Version ("GNATNAME", "2001"); + end if; + end Output_Version; + + --------------- + -- Scan_Args -- + --------------- + + procedure Scan_Args is + + procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); + + Project_File_Name_Expected : Boolean; + + Pragmas_File_Expected : Boolean; + + Directory_Expected : Boolean; + + Dir_File_Name_Expected : Boolean; + + Foreign_Pattern_Expected : Boolean; + + Excluded_Pattern_Expected : Boolean; + + procedure Check_Regular_Expression (S : String); + -- Compile string S into a Regexp, fail if any error + + ----------------------------- + -- Check_Regular_Expression-- + ----------------------------- + + procedure Check_Regular_Expression (S : String) is + Dummy : Regexp; + pragma Warnings (Off, Dummy); + begin + Dummy := Compile (S, Glob => True); + exception + when Error_In_Regexp => + Fail ("invalid regular expression """ & S & """"); + end Check_Regular_Expression; + + -- Start of processing for Scan_Args + + begin + -- First check for --version or --help + + Check_Version_And_Help ("GNATNAME", "2001"); + + -- Now scan the other switches + + Project_File_Name_Expected := False; + Pragmas_File_Expected := False; + Directory_Expected := False; + Dir_File_Name_Expected := False; + Foreign_Pattern_Expected := False; + Excluded_Pattern_Expected := False; + + for Next_Arg in 1 .. Argument_Count loop + declare + Next_Argv : constant String := Argument (Next_Arg); + Arg : String (1 .. Next_Argv'Length) := Next_Argv; + + begin + if Arg'Length > 0 then + + -- -P xxx + + if Project_File_Name_Expected then + if Arg (1) = '-' then + Fail ("project file name missing"); + + else + File_Set := True; + File_Path := new String'(Arg); + Project_File_Name_Expected := False; + end if; + + -- -c file + + elsif Pragmas_File_Expected then + File_Set := True; + File_Path := new String'(Arg); + Create_Project := False; + Pragmas_File_Expected := False; + + -- -d xxx + + elsif Directory_Expected then + Add_Source_Directory (Arg); + Directory_Expected := False; + + -- -D xxx + + elsif Dir_File_Name_Expected then + Get_Directories (Arg); + Dir_File_Name_Expected := False; + + -- -f xxx + + elsif Foreign_Pattern_Expected then + Patterns.Append + (Arguments.Table (Arguments.Last).Foreign_Patterns, + new String'(Arg)); + Check_Regular_Expression (Arg); + Foreign_Pattern_Expected := False; + + -- -x xxx + + elsif Excluded_Pattern_Expected then + Patterns.Append + (Arguments.Table (Arguments.Last).Excluded_Patterns, + new String'(Arg)); + Check_Regular_Expression (Arg); + Excluded_Pattern_Expected := False; + + -- There must be at least one Ada pattern or one foreign + -- pattern for the previous section. + + -- --and + + elsif Arg = "--and" then + + if Patterns.Last + (Arguments.Table (Arguments.Last).Name_Patterns) = 0 + and then + Patterns.Last + (Arguments.Table (Arguments.Last).Foreign_Patterns) = 0 + then + Usage; + return; + end if; + + -- If no directory were specified for the previous section, + -- then the directory is the project directory. + + if Patterns.Last + (Arguments.Table (Arguments.Last).Directories) = 0 + then + Patterns.Append + (Arguments.Table (Arguments.Last).Directories, + new String'(".")); + end if; + + -- Add and initialize another component to Arguments table + + declare + New_Arguments : Argument_Data; + pragma Warnings (Off, New_Arguments); + -- Declaring this defaulted initialized object ensures + -- that the new allocated component of table Arguments + -- is correctly initialized. + + -- This is VERY ugly, Table should never be used with + -- data requiring default initialization. We should + -- find a way to avoid violating this rule ??? + + begin + Arguments.Append (New_Arguments); + end; + + Patterns.Init + (Arguments.Table (Arguments.Last).Directories); + Patterns.Set_Last + (Arguments.Table (Arguments.Last).Directories, 0); + Patterns.Init + (Arguments.Table (Arguments.Last).Name_Patterns); + Patterns.Set_Last + (Arguments.Table (Arguments.Last).Name_Patterns, 0); + Patterns.Init + (Arguments.Table (Arguments.Last).Excluded_Patterns); + Patterns.Set_Last + (Arguments.Table (Arguments.Last).Excluded_Patterns, 0); + Patterns.Init + (Arguments.Table (Arguments.Last).Foreign_Patterns); + Patterns.Set_Last + (Arguments.Table (Arguments.Last).Foreign_Patterns, 0); + + -- Subdirectory switch + + elsif Arg'Length > Subdirs_Switch'Length + and then Arg (1 .. Subdirs_Switch'Length) = Subdirs_Switch + then + Subdirs := + new String'(Arg (Subdirs_Switch'Length + 1 .. Arg'Last)); + + -- -c + + elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-c" then + if File_Set then + Fail ("only one -P or -c switch may be specified"); + end if; + + if Arg'Length = 2 then + Pragmas_File_Expected := True; + + if Next_Arg = Argument_Count then + Fail ("configuration pragmas file name missing"); + end if; + + else + File_Set := True; + File_Path := new String'(Arg (3 .. Arg'Last)); + Create_Project := False; + end if; + + -- -d + + elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-d" then + if Arg'Length = 2 then + Directory_Expected := True; + + if Next_Arg = Argument_Count then + Fail ("directory name missing"); + end if; + + else + Add_Source_Directory (Arg (3 .. Arg'Last)); + end if; + + -- -D + + elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-D" then + if Arg'Length = 2 then + Dir_File_Name_Expected := True; + + if Next_Arg = Argument_Count then + Fail ("directory list file name missing"); + end if; + + else + Get_Directories (Arg (3 .. Arg'Last)); + end if; + + -- -eL + + elsif Arg = "-eL" then + Opt.Follow_Links_For_Files := True; + Opt.Follow_Links_For_Dirs := True; + + -- -f + + elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-f" then + if Arg'Length = 2 then + Foreign_Pattern_Expected := True; + + if Next_Arg = Argument_Count then + Fail ("foreign pattern missing"); + end if; + + else + Patterns.Append + (Arguments.Table (Arguments.Last).Foreign_Patterns, + new String'(Arg (3 .. Arg'Last))); + Check_Regular_Expression (Arg (3 .. Arg'Last)); + end if; + + -- -gnatep or -gnateD + + elsif Arg'Length > 7 and then + (Arg (1 .. 7) = "-gnatep" or else Arg (1 .. 7) = "-gnateD") + then + Preprocessor_Switches.Append (new String'(Arg)); + + -- -h + + elsif Arg = "-h" then + Usage_Needed := True; + + -- -p + + elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-P" then + if File_Set then + Fail ("only one -c or -P switch may be specified"); + end if; + + if Arg'Length = 2 then + if Next_Arg = Argument_Count then + Fail ("project file name missing"); + + else + Project_File_Name_Expected := True; + end if; + + else + File_Set := True; + File_Path := new String'(Arg (3 .. Arg'Last)); + end if; + + Create_Project := True; + + -- -v + + elsif Arg = "-v" then + if Opt.Verbose_Mode then + Very_Verbose := True; + else + Opt.Verbose_Mode := True; + end if; + + -- -x + + elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-x" then + if Arg'Length = 2 then + Excluded_Pattern_Expected := True; + + if Next_Arg = Argument_Count then + Fail ("excluded pattern missing"); + end if; + + else + Patterns.Append + (Arguments.Table (Arguments.Last).Excluded_Patterns, + new String'(Arg (3 .. Arg'Last))); + Check_Regular_Expression (Arg (3 .. Arg'Last)); + end if; + + -- Junk switch starting with minus + + elsif Arg (1) = '-' then + Fail ("wrong switch: " & Arg); + + -- Not a recognized switch, assume file name + + else + Canonical_Case_File_Name (Arg); + Patterns.Append + (Arguments.Table (Arguments.Last).Name_Patterns, + new String'(Arg)); + Check_Regular_Expression (Arg); + end if; + end if; + end; + end loop; + end Scan_Args; + + ----------- + -- Usage -- + ----------- + + procedure Usage is + begin + if not Usage_Output then + Usage_Needed := False; + Usage_Output := True; + Write_Str ("Usage: "); + Osint.Write_Program_Name; + Write_Line (" [switches] naming-pattern [naming-patterns]"); + Write_Line (" {--and [switches] naming-pattern [naming-patterns]}"); + Write_Eol; + Write_Line ("switches:"); + + Write_Line (" --subdirs=dir real obj/lib/exec dirs are subdirs"); + Write_Eol; + + Write_Line (" --and use different patterns"); + Write_Eol; + + Write_Line (" -cfile create configuration pragmas file"); + Write_Line (" -ddir use dir as one of the source " & + "directories"); + Write_Line (" -Dfile get source directories from file"); + Write_Line (" -eL follow symbolic links when processing " & + "project files"); + Write_Line (" -fpat foreign pattern"); + Write_Line (" -gnateDsym=v preprocess with symbol definition"); + Write_Line (" -gnatep=data preprocess files with data file"); + Write_Line (" -h output this help message"); + Write_Line (" -Pproj update or create project file proj"); + Write_Line (" -v verbose output"); + Write_Line (" -v -v very verbose output"); + Write_Line (" -xpat exclude pattern pat"); + end if; + end Usage; + +-- Start of processing for Gnatname + +begin + -- Add the directory where gnatname is invoked in front of the + -- path, if gnatname is invoked with directory information. + -- Only do this if the platform is not VMS, where the notion of path + -- does not really exist. + + if not Hostparm.OpenVMS then + declare + Command : constant String := Command_Name; + + begin + for Index in reverse Command'Range loop + if Command (Index) = Directory_Separator then + declare + Absolute_Dir : constant String := + Normalize_Pathname + (Command (Command'First .. Index)); + + PATH : constant String := + Absolute_Dir & + Path_Separator & + Getenv ("PATH").all; + + begin + Setenv ("PATH", PATH); + end; + + exit; + end if; + end loop; + end; + end if; + + -- Initialize tables + + Arguments.Set_Last (0); + Arguments.Increment_Last; + Patterns.Init (Arguments.Table (1).Directories); + Patterns.Set_Last (Arguments.Table (1).Directories, 0); + Patterns.Init (Arguments.Table (1).Name_Patterns); + Patterns.Set_Last (Arguments.Table (1).Name_Patterns, 0); + Patterns.Init (Arguments.Table (1).Excluded_Patterns); + Patterns.Set_Last (Arguments.Table (1).Excluded_Patterns, 0); + Patterns.Init (Arguments.Table (1).Foreign_Patterns); + Patterns.Set_Last (Arguments.Table (1).Foreign_Patterns, 0); + + Preprocessor_Switches.Set_Last (0); + + -- Get the arguments + + Scan_Args; + + if Opt.Verbose_Mode then + Output_Version; + end if; + + if Usage_Needed then + Usage; + end if; + + -- If no Ada or foreign pattern was specified, print the usage and return + + if Patterns.Last (Arguments.Table (Arguments.Last).Name_Patterns) = 0 + and then + Patterns.Last (Arguments.Table (Arguments.Last).Foreign_Patterns) = 0 + then + Usage; + return; + end if; + + -- If no source directory was specified, use the current directory as the + -- unique directory. Note that if a file was specified with directory + -- information, the current directory is the directory of the specified + -- file. + + if Patterns.Last + (Arguments.Table (Arguments.Last).Directories) = 0 + then + Patterns.Append + (Arguments.Table (Arguments.Last).Directories, new String'(".")); + end if; + + -- Initialize + + declare + Prep_Switches : Argument_List + (1 .. Integer (Preprocessor_Switches.Last)); + + begin + for Index in Prep_Switches'Range loop + Prep_Switches (Index) := Preprocessor_Switches.Table (Index); + end loop; + + Prj.Makr.Initialize + (File_Path => File_Path.all, + Project_File => Create_Project, + Preproc_Switches => Prep_Switches, + Very_Verbose => Very_Verbose, + Flags => Gnatmake_Flags); + end; + + -- Process each section successively + + for J in 1 .. Arguments.Last loop + declare + Directories : Argument_List + (1 .. Integer + (Patterns.Last (Arguments.Table (J).Directories))); + Name_Patterns : Prj.Makr.Regexp_List + (1 .. Integer + (Patterns.Last (Arguments.Table (J).Name_Patterns))); + Excl_Patterns : Prj.Makr.Regexp_List + (1 .. Integer + (Patterns.Last (Arguments.Table (J).Excluded_Patterns))); + Frgn_Patterns : Prj.Makr.Regexp_List + (1 .. Integer + (Patterns.Last (Arguments.Table (J).Foreign_Patterns))); + + begin + -- Build the Directories and Patterns arguments + + for Index in Directories'Range loop + Directories (Index) := + Arguments.Table (J).Directories.Table (Index); + end loop; + + for Index in Name_Patterns'Range loop + Name_Patterns (Index) := + Compile + (Arguments.Table (J).Name_Patterns.Table (Index).all, + Glob => True); + end loop; + + for Index in Excl_Patterns'Range loop + Excl_Patterns (Index) := + Compile + (Arguments.Table (J).Excluded_Patterns.Table (Index).all, + Glob => True); + end loop; + + for Index in Frgn_Patterns'Range loop + Frgn_Patterns (Index) := + Compile + (Arguments.Table (J).Foreign_Patterns.Table (Index).all, + Glob => True); + end loop; + + -- Call Prj.Makr.Process where the real work is done + + Prj.Makr.Process + (Directories => Directories, + Name_Patterns => Name_Patterns, + Excluded_Patterns => Excl_Patterns, + Foreign_Patterns => Frgn_Patterns); + end; + end loop; + + -- Finalize + + Prj.Makr.Finalize; + + if Opt.Verbose_Mode then + Write_Eol; + end if; +end Gnatname; diff --git a/gcc/ada/gnatname.ads b/gcc/ada/gnatname.ads new file mode 100644 index 000000000..0cce2c469 --- /dev/null +++ b/gcc/ada/gnatname.ads @@ -0,0 +1,30 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T N A M E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Tool for dealing with source files with arbitrary naming conventions. +-- It either creates a configuration pragmas file, or updates or creates +-- a project file. + +procedure Gnatname; diff --git a/gcc/ada/gnatprep.adb b/gcc/ada/gnatprep.adb new file mode 100644 index 000000000..34982334e --- /dev/null +++ b/gcc/ada/gnatprep.adb @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T P R E P -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1996-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Gnatvsn; +with GPrep; + +procedure GNATprep is + pragma Ident (Gnatvsn.Gnat_Static_Version_String); + +begin + -- Everything is done in GPrep + + GPrep.Gnatprep; +end GNATprep; diff --git a/gcc/ada/gnatprep.ads b/gcc/ada/gnatprep.ads new file mode 100644 index 000000000..bc3421355 --- /dev/null +++ b/gcc/ada/gnatprep.ads @@ -0,0 +1,161 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T P R E P -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This program provides a simple preprocessing capability for Ada programs. +-- It is designed for use with GNAT, but is not dependent on any special +-- features of GNAT. + +-- To call gnatprep use + +-- gnatprep infile outfile [deffile] [-v] [-c] [-b] [-r] [-s] [-u] +-- [-Dsymbol=value] + +-- where + +-- infile is the full name of the input file, which is an Ada source +-- file containing preprocessor directives. + +-- outfile is the full name of the output file, which is an Ada source +-- in standard Ada form. When used with GNAT, this file name will +-- normally have an ads or adb suffix. + +-- deffile is the full name of a text file containing definitions of +-- symbols to be referenced by the preprocessor. This argument is +-- optional. + +-- The -c switch, causes both preprocessor lines and the lines deleted +-- by preprocessing to be retained in the output source as comments marked +-- with the special string "--! ". This option will result in line numbers +-- being preserved in the output file. + +-- The -b switch causes both preprocessor lines and the lines deleted by +-- preprocessing to be replaced by blank lines in the output source file, +-- thus preserving line numbers in the output file. + +-- The -r switch causes a Source_Reference pragma to be generated that +-- references the original input file, so that error messages will use +-- the file name of this original file. + +-- The -u switch causes gnatprep to treat any undefined symbol that it +-- encounters as having the value False. Otherwise an undefined symbol +-- is a fatal error. + +-- The -s switch causes a sorted list of symbol names and values to be +-- listed on the standard output file. + +-- The -v switch causes a Copyright notice to be displayed, and +-- lines containing errors in the input file or the definition file +-- to be displayed before the errors. + +-- The -D switch causes symbol 'symbol' to be associated with 'value'. +-- This symbols can then be referenced by the preprocessor. Several +-- -D switches may be specified. + +-- Note: if neither -b nor -c is present, then preprocessor lines and +-- deleted lines are completely removed from the output, unless -r is +-- specified, in which case -b is assumed. + +-- The definitions file contains lines of the form + +-- symbol := value + +-- where symbol is an identifier, following normal Ada (case-insensitive) +-- rules for its syntax, and value is one of the following: + +-- Empty, corresponding to a null substitution + +-- A string literal using normal Ada syntax + +-- Any sequence of characters from the set +-- (letters, digits, period, underline) + +-- Comment lines may also appear in the definitions file, starting with +-- the usual --, and comments may be added to the definitions lines. + +-- The input text may contain preprocessor conditional inclusion lines, +-- and also general symbol substitution sequences. + +-- The preprocessor conditional inclusion commands have the form + +-- #if [then] +-- lines +-- #elsif [then] +-- lines +-- #elsif [then] +-- lines +-- ... +-- #else +-- lines +-- #end if; +-- +-- Where expression is defined by the following grammar : +-- expression ::= +-- expression ::= = "" +-- expression ::= = +-- expression ::= 'Defined +-- expression ::= not +-- expression ::= and +-- expression ::= or +-- expression ::= and then +-- expression ::= or else +-- expression ::= ( ) + +-- "or" and "and" may not be used in the same expression without +-- using parentheses. + +-- For these Boolean tests, the symbol must have either the value True or +-- False. If the value is True, then the corresponding lines are included, +-- and if the value is False, they are excluded. It is an error to +-- reference a symbol not defined in the symbol definitions file, or +-- to reference a symbol that has a value other than True or False. + +-- The use of the not operator inverts the sense of this logical test, so +-- that the lines are included only if the symbol is not defined. + +-- The THEN keyword is optional as shown + +-- Spaces or tabs may appear between the # and the keyword. The keywords +-- and the symbols are case insensitive as in normal Ada code. Comments +-- may be used on a preprocessor line, but other than that, no other +-- tokens may appear on a preprocessor line. + +-- Any number of #elsif clauses can be present, including none at all + +-- The #else is optional, as in Ada + +-- The # marking the start of a preprocessor line must be the first +-- non-blank character on the line, i.e. it must be preceded only by +-- spaces or horizontal tabs. + +-- Symbol substitution is obtained by using the sequence + +-- $symbol + +-- anywhere within a source line, except in a comment. The identifier +-- following the $ must match one of the symbols defined in the symbol +-- definition file, and the result is to substitute the value of the +-- symbol in place of $symbol in the output file. + +procedure GNATprep; diff --git a/gcc/ada/gnatsym.adb b/gcc/ada/gnatsym.adb new file mode 100644 index 000000000..5a88994a4 --- /dev/null +++ b/gcc/ada/gnatsym.adb @@ -0,0 +1,359 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T S Y M -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This utility application creates symbol files in a format that is +-- platform-dependent. + +-- A symbol file is a text file that lists the symbols to be exported from +-- a shared library. The format of a symbol file depends on the platform; +-- it may be a simple enumeration of the symbol (one per line) or a more +-- elaborate format (on VMS, for example). A symbol file may be used as an +-- input to the platform linker when building a shared library. + +-- This utility is not available on all platforms. It is currently supported +-- only on OpenVMS. + +-- gnatsym takes as parameters: +-- - the name of the symbol file to create +-- - (optional) the policy to create the symbol file +-- - (optional) the name of the reference symbol file +-- - the names of one or more object files where the symbols are found + +with Gnatvsn; use Gnatvsn; +with Osint; use Osint; +with Output; use Output; +with Symbols; use Symbols; +with Table; + +with Ada.Exceptions; use Ada.Exceptions; +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.Command_Line; use GNAT.Command_Line; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.OS_Lib; use GNAT.OS_Lib; + +procedure Gnatsym is + + Empty_String : aliased String := ""; + Empty : constant String_Access := Empty_String'Unchecked_Access; + -- To initialize variables Reference and Version_String + + Copyright_Displayed : Boolean := False; + -- A flag to prevent multiple display of the Copyright notice + + Success : Boolean := True; + + Symbol_Policy : Policy := Autonomous; + + Verbose : Boolean := False; + -- True when -v switch is used + + Quiet : Boolean := False; + -- True when -q switch is used + + Symbol_File_Name : String_Access := null; + -- The name of the symbol file + + Reference_Symbol_File_Name : String_Access := Empty; + -- The name of the reference symbol file + + Version_String : String_Access := Empty; + -- The version of the library (used on VMS) + + type Object_File_Data is record + Path : String_Access; + Name : String_Access; + end record; + + package Object_Files is new Table.Table + (Table_Component_Type => Object_File_Data, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Gnatsymb.Object_Files"); + -- A table to store the object file names + + Object_File : Natural := 0; + -- An index to traverse the Object_Files table + + procedure Display_Copyright; + -- Display Copyright notice + + procedure Parse_Cmd_Line; + -- Parse the command line switches and file names + + procedure Usage; + -- Display the usage + + ----------------------- + -- Display_Copyright -- + ----------------------- + + procedure Display_Copyright is + begin + if not Copyright_Displayed then + Write_Eol; + Write_Str ("GNATSYMB "); + Write_Str (Gnat_Version_String); + Write_Eol; + Write_Str ("Copyright 2003-2004 Free Software Foundation, Inc"); + Write_Eol; + Copyright_Displayed := True; + end if; + end Display_Copyright; + + -------------------- + -- Parse_Cmd_Line -- + -------------------- + + procedure Parse_Cmd_Line is + begin + loop + case GNAT.Command_Line.Getopt ("c C D q r: R s: v V:") is + when ASCII.NUL => + exit; + + when 'c' => + Symbol_Policy := Compliant; + + when 'C' => + Symbol_Policy := Controlled; + + when 'D' => + Symbol_Policy := Direct; + + when 'q' => + Quiet := True; + + when 'r' => + Reference_Symbol_File_Name := + new String'(GNAT.Command_Line.Parameter); + + when 'R' => + Symbol_Policy := Restricted; + + when 's' => + Symbol_File_Name := new String'(GNAT.Command_Line.Parameter); + + when 'v' => + Verbose := True; + + when 'V' => + Version_String := new String'(GNAT.Command_Line.Parameter); + + when others => + Fail ("invalid switch: " & Full_Switch); + end case; + end loop; + + -- Get the object file names and put them in the table in alphabetical + -- order of base names. + + loop + declare + S : constant String_Access := + new String'(GNAT.Command_Line.Get_Argument); + + begin + exit when S'Length = 0; + + Object_Files.Increment_Last; + + declare + Base : constant String := Base_Name (S.all); + Last : constant Positive := Object_Files.Last; + J : Positive; + + begin + J := 1; + while J < Last loop + if Object_Files.Table (J).Name.all > Base then + Object_Files.Table (J + 1 .. Last) := + Object_Files.Table (J .. Last - 1); + exit; + end if; + + J := J + 1; + end loop; + + Object_Files.Table (J) := (S, new String'(Base)); + end; + end; + end loop; + exception + when Invalid_Switch => + Usage; + Fail ("invalid switch : " & Full_Switch); + end Parse_Cmd_Line; + + ----------- + -- Usage -- + ----------- + + procedure Usage is + begin + Write_Line ("gnatsym [options] object_file {object_file}"); + Write_Eol; + Write_Line (" -c Compliant symbol policy"); + Write_Line (" -C Controlled symbol policy"); + Write_Line (" -q Quiet mode"); + Write_Line (" -r Reference symbol file name"); + Write_Line (" -R Restricted symbol policy"); + Write_Line (" -s Symbol file name"); + Write_Line (" -v Verbose mode"); + Write_Line (" -V Version"); + Write_Eol; + Write_Line ("Specifying a symbol file with -s is compulsory"); + Write_Eol; + end Usage; + +-- Start of processing of Gnatsym + +begin + -- Initialize Object_Files table + + Object_Files.Set_Last (0); + + -- Parse the command line + + Parse_Cmd_Line; + + if Verbose then + Display_Copyright; + end if; + + -- If there is no symbol file or no object files on the command line, + -- display the usage and exit with an error status. + + if Symbol_File_Name = null or else Object_Files.Last = 0 then + Usage; + OS_Exit (1); + + -- When symbol policy is direct, simply copy the reference symbol file to + -- the symbol file. + + elsif Symbol_Policy = Direct then + declare + File_In : Ada.Text_IO.File_Type; + File_Out : Ada.Text_IO.File_Type; + Line : String (1 .. 1_000); + Last : Natural; + + begin + begin + Open (File_In, In_File, Reference_Symbol_File_Name.all); + + exception + when X : others => + if not Quiet then + Put_Line + ("could not open """ & + Reference_Symbol_File_Name.all + & """"); + Put_Line (Exception_Message (X)); + end if; + + OS_Exit (1); + end; + + begin + Create (File_Out, Out_File, Symbol_File_Name.all); + + exception + when X : others => + if not Quiet then + Put_Line + ("could not create """ & Symbol_File_Name.all & """"); + Put_Line (Exception_Message (X)); + end if; + + OS_Exit (1); + end; + + while not End_Of_File (File_In) loop + Get_Line (File_In, Line, Last); + Put_Line (File_Out, Line (1 .. Last)); + end loop; + + Close (File_In); + Close (File_Out); + end; + + else + if Verbose then + Write_Str ("Initializing symbol file """); + Write_Str (Symbol_File_Name.all); + Write_Line (""""); + end if; + + -- Initialize symbol file and, if specified, read reference file + + Symbols.Initialize + (Symbol_File => Symbol_File_Name.all, + Reference => Reference_Symbol_File_Name.all, + Symbol_Policy => Symbol_Policy, + Quiet => Quiet, + Version => Version_String.all, + Success => Success); + + -- Process the object files in order. Stop as soon as there is + -- something wrong. + + Object_File := 0; + + while Success and then Object_File < Object_Files.Last loop + Object_File := Object_File + 1; + + if Verbose then + Write_Str ("Processing object file """); + Write_Str (Object_Files.Table (Object_File).Path.all); + Write_Line (""""); + end if; + + Processing.Process + (Object_Files.Table (Object_File).Path.all, + Success); + end loop; + + -- Finalize the symbol file + + if Success then + if Verbose then + Write_Str ("Finalizing """); + Write_Str (Symbol_File_Name.all); + Write_Line (""""); + end if; + + Finalize (Quiet, Success); + end if; + + -- Fail if there was anything wrong + + if not Success then + Fail ("unable to build symbol file"); + end if; + end if; +end Gnatsym; diff --git a/gcc/ada/gnatvsn.adb b/gcc/ada/gnatvsn.adb new file mode 100644 index 000000000..6d76f7e51 --- /dev/null +++ b/gcc/ada/gnatvsn.adb @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T V S N -- +-- -- +-- 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 Gnatvsn is + + ---------------------- + -- Copyright_Holder -- + ---------------------- + + function Copyright_Holder return String is + begin + return "Free Software Foundation, Inc."; + end Copyright_Holder; + + ------------------------ + -- Gnat_Free_Software -- + ------------------------ + + function Gnat_Free_Software return String is + begin + return + "This is free software; see the source for copying conditions." & + ASCII.LF & + "There is NO warranty; not even for MERCHANTABILITY or FITNESS" & + " FOR A PARTICULAR PURPOSE."; + end Gnat_Free_Software; + + type char_array is array (Natural range <>) of aliased Character; + Version_String : char_array (0 .. Ver_Len_Max - 1); + -- Import the C string defined in the (language-independent) source file + -- version.c using the zero-based convention of the C language. + -- The size is not the real one, which does not matter since we will + -- check for the nul character in Gnat_Version_String. + pragma Import (C, Version_String, "version_string"); + + ------------------------- + -- Gnat_Version_String -- + ------------------------- + + function Gnat_Version_String return String is + S : String (1 .. Ver_Len_Max); + Pos : Natural := 0; + begin + loop + exit when Version_String (Pos) = ASCII.NUL; + + S (Pos + 1) := Version_String (Pos); + Pos := Pos + 1; + + exit when Pos = Ver_Len_Max; + end loop; + + return S (1 .. Pos); + end Gnat_Version_String; + +end Gnatvsn; diff --git a/gcc/ada/gnatvsn.ads b/gcc/ada/gnatvsn.ads new file mode 100644 index 000000000..1224b3b5c --- /dev/null +++ b/gcc/ada/gnatvsn.ads @@ -0,0 +1,98 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T V S N -- +-- -- +-- 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 package spec holds version information for the GNAT tools. +-- It is updated whenever the release number is changed. + +package Gnatvsn is + + Gnat_Static_Version_String : constant String := "GNU Ada"; + -- Static string identifying this version, that can be used as an argument + -- to e.g. pragma Ident. + + function Gnat_Version_String return String; + -- Version output when GNAT (compiler), or its related tools, including + -- GNATBIND, GNATCHOP, GNATFIND, GNATLINK, GNATMAKE, GNATXREF, are run + -- (with appropriate verbose option switch set). + + type Gnat_Build_Type is (FSF, GPL); + -- See Build_Type below for the meaning of these values. + + Build_Type : constant Gnat_Build_Type := FSF; + -- Kind of GNAT build: + -- + -- FSF + -- GNAT FSF version. This version of GNAT is part of a Free Software + -- Foundation release of the GNU Compiler Collection (GCC). The bug + -- box generated by Comperr gives information on how to report bugs + -- and list the "no warranty" information. + -- + -- GPL + -- GNAT GPL Edition. This is a special version of GNAT, released by + -- Ada Core Technologies and intended for academic users, and free + -- software developers. The bug box generated by the package Comperr + -- gives appropriate bug submission instructions that do not reference + -- customer number etc. + + function Gnat_Free_Software return String; + -- Text to be displayed by the different GNAT tools when switch --version + -- is used. This text depends on the GNAT build type. + + function Copyright_Holder return String; + -- Return the name of the Copyright holder to be displayed by the different + -- GNAT tools when switch --version is used. + + Ver_Len_Max : constant := 256; + -- Longest possible length for Gnat_Version_String in this or any + -- other version of GNAT. This is used by the binder to establish + -- space to store any possible version string value for checks. This + -- value should never be decreased in the future, but it would be + -- OK to increase it if absolutely necessary. If it is increased, + -- be sure to increase GNAT.Compiler.Version.Ver_Len_Max as well. + + Ver_Prefix : constant String := "GNAT Version: "; + -- Prefix generated by binder. If it is changed, be sure to change + -- GNAT.Compiler_Version.Ver_Prefix as well. + + Library_Version : constant String := "4.6"; + -- Library version. This value must be updated when the compiler + -- version number Gnat_Static_Version_String is updated. + -- + -- Note: Makefile.in uses the library version string to construct the + -- soname value. + + Verbose_Library_Version : constant String := "GNAT Lib v" & Library_Version; + -- Version string stored in e.g. ALI files + + Current_Year : constant String := "2011"; + -- Used in printing copyright messages + +end Gnatvsn; diff --git a/gcc/ada/gnatxref.adb b/gcc/ada/gnatxref.adb new file mode 100644 index 000000000..c20ef1755 --- /dev/null +++ b/gcc/ada/gnatxref.adb @@ -0,0 +1,327 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T X R E F -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Opt; +with Osint; use Osint; +with Types; use Types; +with Switch; use Switch; +with Xr_Tabls; use Xr_Tabls; +with Xref_Lib; use Xref_Lib; + +with Ada.Strings.Fixed; use Ada.Strings.Fixed; +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.Command_Line; use GNAT.Command_Line; + +with System.Strings; use System.Strings; + +procedure Gnatxref is + Search_Unused : Boolean := False; + Local_Symbols : Boolean := True; + Prj_File : File_Name_String; + Prj_File_Length : Natural := 0; + Usage_Error : exception; + Full_Path_Name : Boolean := False; + Vi_Mode : Boolean := False; + Read_Only : Boolean := False; + Have_File : Boolean := False; + Der_Info : Boolean := False; + + RTS_Specified : String_Access := null; + -- Used to detect multiple use of --RTS= switch + + EXT_Specified : String_Access := null; + -- Used to detect multiple use of --ext= switch + + procedure Parse_Cmd_Line; + -- Parse every switch on the command line + + procedure Usage; + -- Display the usage + + procedure Write_Usage; + -- Print a small help page for program usage + + -------------------- + -- Parse_Cmd_Line -- + -------------------- + + procedure Parse_Cmd_Line is + + procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); + + -- Start of processing for Parse_Cmd_Line + + begin + -- First check for --version or --help + + Check_Version_And_Help ("GNATXREF", "1998"); + + loop + case + GNAT.Command_Line.Getopt + ("a aI: aO: d f g h I: nostdinc nostdlib p: u v -RTS= -ext=") + is + when ASCII.NUL => + exit; + + when 'a' => + if GNAT.Command_Line.Full_Switch = "a" then + Read_Only := True; + + elsif GNAT.Command_Line.Full_Switch = "aI" then + Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter); + + else + Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter); + end if; + + when 'd' => + Der_Info := True; + + when 'f' => + Full_Path_Name := True; + + when 'g' => + Local_Symbols := False; + + when 'h' => + Write_Usage; + + when 'I' => + Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter); + Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter); + + when 'n' => + if GNAT.Command_Line.Full_Switch = "nostdinc" then + Opt.No_Stdinc := True; + elsif GNAT.Command_Line.Full_Switch = "nostdlib" then + Opt.No_Stdlib := True; + end if; + + when 'p' => + declare + S : constant String := GNAT.Command_Line.Parameter; + begin + Prj_File_Length := S'Length; + Prj_File (1 .. Prj_File_Length) := S; + end; + + when 'u' => + Search_Unused := True; + Vi_Mode := False; + + when 'v' => + Vi_Mode := True; + Search_Unused := False; + + -- The only switch starting with -- recognized is --RTS + + when '-' => + + -- Check that it is the first time we see this switch + + if Full_Switch = "-RTS" then + if RTS_Specified = null then + RTS_Specified := new String'(GNAT.Command_Line.Parameter); + + elsif RTS_Specified.all /= GNAT.Command_Line.Parameter then + Osint.Fail ("--RTS cannot be specified multiple times"); + end if; + + Opt.No_Stdinc := True; + Opt.RTS_Switch := True; + + declare + Src_Path_Name : constant String_Ptr := + Get_RTS_Search_Dir + (GNAT.Command_Line.Parameter, + Include); + + Lib_Path_Name : constant String_Ptr := + Get_RTS_Search_Dir + (GNAT.Command_Line.Parameter, + Objects); + + begin + if Src_Path_Name /= null + and then Lib_Path_Name /= null + then + Add_Search_Dirs (Src_Path_Name, Include); + Add_Search_Dirs (Lib_Path_Name, Objects); + + elsif Src_Path_Name = null + and then Lib_Path_Name = null + then + Osint.Fail ("RTS path not valid: missing " & + "adainclude and adalib directories"); + + elsif Src_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adainclude directory"); + + elsif Lib_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adalib directory"); + end if; + end; + + elsif GNAT.Command_Line.Full_Switch = "-ext" then + + -- Check that it is the first time we see this switch + + if EXT_Specified = null then + EXT_Specified := new String'(GNAT.Command_Line.Parameter); + + elsif EXT_Specified.all /= GNAT.Command_Line.Parameter then + Osint.Fail ("--ext cannot be specified multiple times"); + end if; + + if EXT_Specified'Length + = Osint.ALI_Default_Suffix'Length + then + Osint.ALI_Suffix := EXT_Specified.all'Access; + else + Osint.Fail ("--ext argument must have 3 characters"); + end if; + end if; + + when others => + Write_Usage; + end case; + end loop; + + -- Get the other arguments + + loop + declare + S : constant String := GNAT.Command_Line.Get_Argument; + + begin + exit when S'Length = 0; + + if Ada.Strings.Fixed.Index (S, ":") /= 0 then + Ada.Text_IO.Put_Line + ("Only file names are allowed on the command line"); + Write_Usage; + end if; + + Add_Xref_File (S); + Have_File := True; + end; + end loop; + + exception + when GNAT.Command_Line.Invalid_Switch => + Ada.Text_IO.Put_Line ("Invalid switch : " + & GNAT.Command_Line.Full_Switch); + Write_Usage; + + when GNAT.Command_Line.Invalid_Parameter => + Ada.Text_IO.Put_Line ("Parameter missing for : " + & GNAT.Command_Line.Full_Switch); + Write_Usage; + end Parse_Cmd_Line; + + ----------- + -- Usage -- + ----------- + + procedure Usage is + begin + Put_Line ("Usage: gnatxref [switches] file1 file2 ..."); + New_Line; + Put_Line (" file ... list of source files to xref, " & + "including with'ed units"); + New_Line; + Put_Line ("gnatxref switches:"); + Put_Line (" -a Consider all files, even when the ali file is" + & " readonly"); + Put_Line (" -aIdir Specify source files search path"); + Put_Line (" -aOdir Specify library/object files search path"); + Put_Line (" -d Output derived type information"); + Put_Line (" -f Output full path name"); + Put_Line (" -g Output information only for global symbols"); + Put_Line (" -Idir Like -aIdir -aOdir"); + Put_Line (" -nostdinc Don't look for sources in the system default" + & " directory"); + Put_Line (" -nostdlib Don't look for library files in the system" + & " default directory"); + Put_Line (" --ext=xxx Specify alternate ali file extension"); + Put_Line (" --RTS=dir specify the default source and object search" + & " path"); + Put_Line (" -p file Use file as the default project file"); + Put_Line (" -u List unused entities"); + Put_Line (" -v Print a 'tags' file for vi"); + New_Line; + + end Usage; + + ----------------- + -- Write_Usage -- + ----------------- + + procedure Write_Usage is + begin + Display_Version ("GNATXREF", "1998"); + New_Line; + Usage; + raise Usage_Error; + end Write_Usage; + +begin + Parse_Cmd_Line; + + if not Have_File then + Write_Usage; + end if; + + Xr_Tabls.Set_Default_Match (True); + + -- Find the project file + + if Prj_File_Length = 0 then + Xr_Tabls.Create_Project_File + (Default_Project_File (Osint.To_Host_Dir_Spec (".", False).all)); + else + Xr_Tabls.Create_Project_File (Prj_File (1 .. Prj_File_Length)); + end if; + + -- Fill up the table + + Search_Xref (Local_Symbols, Read_Only, Der_Info); + + if Search_Unused then + Print_Unused (Full_Path_Name); + elsif Vi_Mode then + Print_Vi (Full_Path_Name); + else + Print_Xref (Full_Path_Name); + end if; + +exception + when Usage_Error => + null; +end Gnatxref; diff --git a/gcc/ada/gprep.adb b/gcc/ada/gprep.adb new file mode 100644 index 000000000..88710d620 --- /dev/null +++ b/gcc/ada/gprep.adb @@ -0,0 +1,823 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G P R E P -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Csets; +with Err_Vars; use Err_Vars; +with Errutil; +with Namet; use Namet; +with Opt; +with Osint; use Osint; +with Output; use Output; +with Prep; use Prep; +with Scng; +with Sinput.C; +with Snames; +with Stringt; use Stringt; +with Switch; use Switch; +with Types; use Types; + +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.Case_Util; use GNAT.Case_Util; +with GNAT.Command_Line; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; + +with System.OS_Lib; use System.OS_Lib; + +package body GPrep is + + Copyright_Displayed : Boolean := False; + -- Used to prevent multiple displays of the copyright notice + + ------------------------ + -- Argument Line Data -- + ------------------------ + + Unix_Line_Terminators : Boolean := False; + -- Set to True with option -T + + type String_Array is array (Boolean) of String_Access; + Yes_No : constant String_Array := + (False => new String'("YES"), + True => new String'("NO")); + + Infile_Name : Name_Id := No_Name; + Outfile_Name : Name_Id := No_Name; + Deffile_Name : Name_Id := No_Name; + + Output_Directory : Name_Id := No_Name; + -- Used when the specified output is an existing directory + + Input_Directory : Name_Id := No_Name; + -- Used when the specified input and output are existing directories + + Source_Ref_Pragma : Boolean := False; + -- Record command line options (set if -r switch set) + + Text_Outfile : aliased Ada.Text_IO.File_Type; + Outfile : constant File_Access := Text_Outfile'Access; + + File_Name_Buffer_Initial_Size : constant := 50; + File_Name_Buffer : String_Access := + new String (1 .. File_Name_Buffer_Initial_Size); + -- A buffer to build output file names from input file names + + ----------------- + -- Subprograms -- + ----------------- + + procedure Display_Copyright; + -- Display the copyright notice + + procedure Post_Scan; + -- Null procedure, needed by instantiation of Scng below + + package Scanner is new Scng + (Post_Scan, + Errutil.Error_Msg, + Errutil.Error_Msg_S, + Errutil.Error_Msg_SC, + Errutil.Error_Msg_SP, + Errutil.Style); + -- The scanner for the preprocessor + + function Is_ASCII_Letter (C : Character) return Boolean; + -- True if C is in 'a' .. 'z' or in 'A' .. 'Z' + + procedure Double_File_Name_Buffer; + -- Double the size of the file name buffer + + procedure Preprocess_Infile_Name; + -- When the specified output is a directory, preprocess the infile name + -- for symbol substitution, to get the output file name. + + procedure Process_Files; + -- Process the single input file or all the files in the directory tree + -- rooted at the input directory. + + procedure Process_Command_Line_Symbol_Definition (S : String); + -- Process a -D switch on the command line + + procedure Put_Char_To_Outfile (C : Character); + -- Output one character to the output file. Used to initialize the + -- preprocessor. + + procedure New_EOL_To_Outfile; + -- Output a new line to the output file. Used to initialize the + -- preprocessor. + + procedure Scan_Command_Line; + -- Scan the switches and the file names + + procedure Usage; + -- Display the usage + + ----------------------- + -- Display_Copyright -- + ----------------------- + + procedure Display_Copyright is + begin + if not Copyright_Displayed then + Display_Version ("GNAT Preprocessor", "1996"); + Copyright_Displayed := True; + end if; + end Display_Copyright; + + ----------------------------- + -- Double_File_Name_Buffer -- + ----------------------------- + + procedure Double_File_Name_Buffer is + New_Buffer : constant String_Access := + new String (1 .. 2 * File_Name_Buffer'Length); + begin + New_Buffer (File_Name_Buffer'Range) := File_Name_Buffer.all; + Free (File_Name_Buffer); + File_Name_Buffer := New_Buffer; + end Double_File_Name_Buffer; + + -------------- + -- Gnatprep -- + -------------- + + procedure Gnatprep is + begin + -- Do some initializations (order is important here!) + + Csets.Initialize; + Snames.Initialize; + Stringt.Initialize; + Prep.Initialize; + + -- Initialize the preprocessor + + Prep.Setup_Hooks + (Error_Msg => Errutil.Error_Msg'Access, + Scan => Scanner.Scan'Access, + Set_Ignore_Errors => Errutil.Set_Ignore_Errors'Access, + Put_Char => Put_Char_To_Outfile'Access, + New_EOL => New_EOL_To_Outfile'Access); + + -- Set the scanner characteristics for the preprocessor + + Scanner.Set_Special_Character ('#'); + Scanner.Set_Special_Character ('$'); + Scanner.Set_End_Of_Line_As_Token (True); + + -- Initialize the mapping table of symbols to values + + Prep.Symbol_Table.Init (Prep.Mapping); + + -- Parse the switches and arguments + + Scan_Command_Line; + + if Opt.Verbose_Mode then + Display_Copyright; + end if; + + -- Test we had all the arguments needed + + if Infile_Name = No_Name then + + -- No input file specified, just output the usage and exit + + Usage; + return; + + elsif Outfile_Name = No_Name then + + -- No output file specified, just output the usage and exit + + Usage; + return; + end if; + + -- If a pragma Source_File_Name, we need to keep line numbers. So, if + -- the deleted lines are not put as comment, we must output them as + -- blank lines. + + if Source_Ref_Pragma and (not Opt.Comment_Deleted_Lines) then + Opt.Blank_Deleted_Lines := True; + end if; + + -- If we have a definition file, parse it + + if Deffile_Name /= No_Name then + declare + Deffile : Source_File_Index; + + begin + Errutil.Initialize; + Deffile := Sinput.C.Load_File (Get_Name_String (Deffile_Name)); + + -- Set Main_Source_File to the definition file for the benefit of + -- Errutil.Finalize. + + Sinput.Main_Source_File := Deffile; + + if Deffile = No_Source_File then + Fail ("unable to find definition file """ + & Get_Name_String (Deffile_Name) + & """"); + end if; + + Scanner.Initialize_Scanner (Deffile); + + Prep.Parse_Def_File; + end; + end if; + + -- If there are errors in the definition file, output them and exit + + if Total_Errors_Detected > 0 then + Errutil.Finalize (Source_Type => "definition"); + Fail ("errors in definition file """ + & Get_Name_String (Deffile_Name) + & """"); + end if; + + -- If -s switch was specified, print a sorted list of symbol names and + -- values, if any. + + if Opt.List_Preprocessing_Symbols then + Prep.List_Symbols (Foreword => ""); + end if; + + Output_Directory := No_Name; + Input_Directory := No_Name; + + -- Check if the specified output is an existing directory + + if Is_Directory (Get_Name_String (Outfile_Name)) then + Output_Directory := Outfile_Name; + + -- As the output is an existing directory, check if the input too + -- is a directory. + + if Is_Directory (Get_Name_String (Infile_Name)) then + Input_Directory := Infile_Name; + end if; + end if; + + -- And process the single input or the files in the directory tree + -- rooted at the input directory. + + Process_Files; + end Gnatprep; + + --------------------- + -- Is_ASCII_Letter -- + --------------------- + + function Is_ASCII_Letter (C : Character) return Boolean is + begin + return C in 'A' .. 'Z' or else C in 'a' .. 'z'; + end Is_ASCII_Letter; + + ------------------------ + -- New_EOL_To_Outfile -- + ------------------------ + + procedure New_EOL_To_Outfile is + begin + New_Line (Outfile.all); + end New_EOL_To_Outfile; + + --------------- + -- Post_Scan -- + --------------- + + procedure Post_Scan is + begin + null; + end Post_Scan; + + ---------------------------- + -- Preprocess_Infile_Name -- + ---------------------------- + + procedure Preprocess_Infile_Name is + Len : Natural; + First : Positive; + Last : Natural; + Symbol : Name_Id; + Data : Symbol_Data; + + begin + -- Initialize the buffer with the name of the input file + + Get_Name_String (Infile_Name); + Len := Name_Len; + + while File_Name_Buffer'Length < Len loop + Double_File_Name_Buffer; + end loop; + + File_Name_Buffer (1 .. Len) := Name_Buffer (1 .. Len); + + -- Look for possible symbols in the file name + + First := 1; + while First < Len loop + + -- A symbol starts with a dollar sign followed by a letter + + if File_Name_Buffer (First) = '$' and then + Is_ASCII_Letter (File_Name_Buffer (First + 1)) + then + Last := First + 1; + + -- Find the last letter of the symbol + + while Last < Len and then + Is_ASCII_Letter (File_Name_Buffer (Last + 1)) + loop + Last := Last + 1; + end loop; + + -- Get the symbol name id + + Name_Len := Last - First; + Name_Buffer (1 .. Name_Len) := + File_Name_Buffer (First + 1 .. Last); + To_Lower (Name_Buffer (1 .. Name_Len)); + Symbol := Name_Find; + + -- And look for this symbol name in the symbol table + + for Index in 1 .. Symbol_Table.Last (Mapping) loop + Data := Mapping.Table (Index); + + if Data.Symbol = Symbol then + + -- We found the symbol. If its value is not a string, + -- replace the symbol in the file name with the value of + -- the symbol. + + if not Data.Is_A_String then + String_To_Name_Buffer (Data.Value); + + declare + Sym_Len : constant Positive := Last - First + 1; + Offset : constant Integer := Name_Len - Sym_Len; + New_Len : constant Natural := Len + Offset; + + begin + while New_Len > File_Name_Buffer'Length loop + Double_File_Name_Buffer; + end loop; + + File_Name_Buffer (Last + 1 + Offset .. New_Len) := + File_Name_Buffer (Last + 1 .. Len); + Len := New_Len; + Last := Last + Offset; + File_Name_Buffer (First .. Last) := + Name_Buffer (1 .. Name_Len); + end; + end if; + + exit; + end if; + end loop; + + -- Skip over the symbol name or its value: we are not checking + -- for another symbol name in the value. + + First := Last + 1; + + else + First := First + 1; + end if; + end loop; + + -- We now have the output file name in the buffer. Get the output + -- path and put it in Outfile_Name. + + Get_Name_String (Output_Directory); + Add_Char_To_Name_Buffer (Directory_Separator); + Add_Str_To_Name_Buffer (File_Name_Buffer (1 .. Len)); + Outfile_Name := Name_Find; + end Preprocess_Infile_Name; + + -------------------------------------------- + -- Process_Command_Line_Symbol_Definition -- + -------------------------------------------- + + procedure Process_Command_Line_Symbol_Definition (S : String) is + Data : Symbol_Data; + Symbol : Symbol_Id; + + begin + -- Check the symbol definition and get the symbol and its value. + -- Fail if symbol definition is illegal. + + Check_Command_Line_Symbol_Definition (S, Data); + + Symbol := Index_Of (Data.Symbol); + + -- If symbol does not already exist, create a new entry in the mapping + -- table. + + if Symbol = No_Symbol then + Symbol_Table.Increment_Last (Mapping); + Symbol := Symbol_Table.Last (Mapping); + end if; + + Mapping.Table (Symbol) := Data; + end Process_Command_Line_Symbol_Definition; + + ------------------- + -- Process_Files -- + ------------------- + + procedure Process_Files is + + procedure Process_One_File; + -- Process input file Infile_Name and put the result in file + -- Outfile_Name. + + procedure Recursive_Process (In_Dir : String; Out_Dir : String); + -- Process recursively files in In_Dir. Results go to Out_Dir + + ---------------------- + -- Process_One_File -- + ---------------------- + + procedure Process_One_File is + Infile : Source_File_Index; + + Modified : Boolean; + pragma Warnings (Off, Modified); + + begin + -- Create the output file (fails if this does not work) + + begin + Create + (File => Text_Outfile, + Mode => Out_File, + Name => Get_Name_String (Outfile_Name), + Form => "Text_Translation=" & + Yes_No (Unix_Line_Terminators).all); + + exception + when others => + Fail + ("unable to create output file """ + & Get_Name_String (Outfile_Name) + & """"); + end; + + -- Load the input file + + Infile := Sinput.C.Load_File (Get_Name_String (Infile_Name)); + + if Infile = No_Source_File then + Fail ("unable to find input file """ + & Get_Name_String (Infile_Name) + & """"); + end if; + + -- Set Main_Source_File to the input file for the benefit of + -- Errutil.Finalize. + + Sinput.Main_Source_File := Infile; + + Scanner.Initialize_Scanner (Infile); + + -- Output the pragma Source_Reference if asked to + + if Source_Ref_Pragma then + Put_Line + (Outfile.all, + "pragma Source_Reference (1, """ & + Get_Name_String (Sinput.Full_File_Name (Infile)) & """);"); + end if; + + -- Preprocess the input file + + Prep.Preprocess (Modified); + + -- In verbose mode, if there is no error, report it + + if Opt.Verbose_Mode and then Err_Vars.Total_Errors_Detected = 0 then + Errutil.Finalize (Source_Type => "input"); + end if; + + -- If we had some errors, delete the output file, and report them + + if Err_Vars.Total_Errors_Detected > 0 then + if Outfile /= Standard_Output then + Delete (Text_Outfile); + end if; + + Errutil.Finalize (Source_Type => "input"); + + OS_Exit (0); + + -- Otherwise, close the output file, and we are done + + elsif Outfile /= Standard_Output then + Close (Text_Outfile); + end if; + end Process_One_File; + + ----------------------- + -- Recursive_Process -- + ----------------------- + + procedure Recursive_Process (In_Dir : String; Out_Dir : String) is + Dir_In : Dir_Type; + Name : String (1 .. 255); + Last : Natural; + In_Dir_Name : Name_Id; + Out_Dir_Name : Name_Id; + + procedure Set_Directory_Names; + -- Establish or reestablish the current input and output directories + + ------------------------- + -- Set_Directory_Names -- + ------------------------- + + procedure Set_Directory_Names is + begin + Input_Directory := In_Dir_Name; + Output_Directory := Out_Dir_Name; + end Set_Directory_Names; + + -- Start of processing for Recursive_Process + + begin + -- Open the current input directory + + begin + Open (Dir_In, In_Dir); + + exception + when Directory_Error => + Fail ("could not read directory " & In_Dir); + end; + + -- Set the new input and output directory names + + Name_Len := In_Dir'Length; + Name_Buffer (1 .. Name_Len) := In_Dir; + In_Dir_Name := Name_Find; + Name_Len := Out_Dir'Length; + Name_Buffer (1 .. Name_Len) := Out_Dir; + Out_Dir_Name := Name_Find; + + Set_Directory_Names; + + -- Traverse the input directory + loop + Read (Dir_In, Name, Last); + exit when Last = 0; + + if Name (1 .. Last) /= "." and then Name (1 .. Last) /= ".." then + declare + Input : constant String := + In_Dir & Directory_Separator & Name (1 .. Last); + Output : constant String := + Out_Dir & Directory_Separator & Name (1 .. Last); + + begin + -- If input is an ordinary file, process it + + if Is_Regular_File (Input) then + -- First get the output file name + + Name_Len := Last; + Name_Buffer (1 .. Name_Len) := Name (1 .. Last); + Infile_Name := Name_Find; + Preprocess_Infile_Name; + + -- Set the input file name and process the file + + Name_Len := Input'Length; + Name_Buffer (1 .. Name_Len) := Input; + Infile_Name := Name_Find; + Process_One_File; + + elsif Is_Directory (Input) then + -- Input is a directory. If the corresponding output + -- directory does not already exist, create it. + + if not Is_Directory (Output) then + begin + Make_Dir (Dir_Name => Output); + + exception + when Directory_Error => + Fail ("could not create directory """ + & Output + & """"); + end; + end if; + + -- And process this new input directory + + Recursive_Process (Input, Output); + + -- Reestablish the input and output directory names + -- that have been modified by the recursive call. + + Set_Directory_Names; + end if; + end; + end if; + end loop; + end Recursive_Process; + + -- Start of processing for Process_Files + + begin + if Output_Directory = No_Name then + + -- If the output is not a directory, fail if the input is + -- an existing directory, to avoid possible problems. + + if Is_Directory (Get_Name_String (Infile_Name)) then + Fail ("input file """ & Get_Name_String (Infile_Name) & + """ is a directory"); + end if; + + -- Just process the single input file + + Process_One_File; + + elsif Input_Directory = No_Name then + + -- Get the output file name from the input file name, and process + -- the single input file. + + Preprocess_Infile_Name; + Process_One_File; + + else + -- Recursively process files in the directory tree rooted at the + -- input directory. + + Recursive_Process + (In_Dir => Get_Name_String (Input_Directory), + Out_Dir => Get_Name_String (Output_Directory)); + end if; + end Process_Files; + + ------------------------- + -- Put_Char_To_Outfile -- + ------------------------- + + procedure Put_Char_To_Outfile (C : Character) is + begin + Put (Outfile.all, C); + end Put_Char_To_Outfile; + + ----------------------- + -- Scan_Command_Line -- + ----------------------- + + procedure Scan_Command_Line is + Switch : Character; + + procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); + + -- Start of processing for Scan_Command_Line + + begin + -- First check for --version or --help + + Check_Version_And_Help ("GNATPREP", "1996"); + + -- Now scan the other switches + + GNAT.Command_Line.Initialize_Option_Scan; + + loop + begin + Switch := GNAT.Command_Line.Getopt ("D: b c C r s T u v"); + + case Switch is + + when ASCII.NUL => + exit; + + when 'D' => + Process_Command_Line_Symbol_Definition + (S => GNAT.Command_Line.Parameter); + + when 'b' => + Opt.Blank_Deleted_Lines := True; + + when 'c' => + Opt.Comment_Deleted_Lines := True; + + when 'C' => + Opt.Replace_In_Comments := True; + + when 'r' => + Source_Ref_Pragma := True; + + when 's' => + Opt.List_Preprocessing_Symbols := True; + + when 'T' => + Unix_Line_Terminators := True; + + when 'u' => + Opt.Undefined_Symbols_Are_False := True; + + when 'v' => + Opt.Verbose_Mode := True; + + when others => + Fail ("Invalid Switch: -" & Switch); + end case; + + exception + when GNAT.Command_Line.Invalid_Switch => + Write_Str ("Invalid Switch: -"); + Write_Line (GNAT.Command_Line.Full_Switch); + Usage; + OS_Exit (1); + end; + end loop; + + -- Get the file names + + loop + declare + S : constant String := GNAT.Command_Line.Get_Argument; + + begin + exit when S'Length = 0; + + Name_Len := S'Length; + Name_Buffer (1 .. Name_Len) := S; + + if Infile_Name = No_Name then + Infile_Name := Name_Find; + elsif Outfile_Name = No_Name then + Outfile_Name := Name_Find; + elsif Deffile_Name = No_Name then + Deffile_Name := Name_Find; + else + Fail ("too many arguments specified"); + end if; + end; + end loop; + end Scan_Command_Line; + + ----------- + -- Usage -- + ----------- + + procedure Usage is + begin + Display_Copyright; + Write_Line ("Usage: gnatprep [-bcrsuv] [-Dsymbol=value] " & + "infile outfile [deffile]"); + Write_Eol; + Write_Line (" infile Name of the input file"); + Write_Line (" outfile Name of the output file"); + Write_Line (" deffile Name of the definition file"); + Write_Eol; + Write_Line ("gnatprep switches:"); + Write_Line (" -b Replace preprocessor lines by blank lines"); + Write_Line (" -c Keep preprocessor lines as comments"); + Write_Line (" -C Do symbol replacements within comments"); + Write_Line (" -D Associate symbol with value"); + Write_Line (" -r Generate Source_Reference pragma"); + Write_Line (" -s Print a sorted list of symbol names and values"); + Write_Line (" -T Use LF as line terminators"); + Write_Line (" -u Treat undefined symbols as FALSE"); + Write_Line (" -v Verbose mode"); + Write_Eol; + end Usage; + +end GPrep; diff --git a/gcc/ada/gprep.ads b/gcc/ada/gprep.ads new file mode 100644 index 000000000..adc100982 --- /dev/null +++ b/gcc/ada/gprep.ads @@ -0,0 +1,33 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G P R E P -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 implementation of GNATPREP + +package GPrep is + + procedure Gnatprep; + -- Called by gnatprep + +end GPrep; diff --git a/gcc/ada/gsocket.h b/gcc/ada/gsocket.h new file mode 100644 index 000000000..7763b1801 --- /dev/null +++ b/gcc/ada/gsocket.h @@ -0,0 +1,240 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * G S O C K E T * + * * + * C Header File * + * * + * 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 * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +#if defined(__nucleus__) || defined(VTHREADS) + +#warning Sockets not supported on these platforms +#undef HAVE_SOCKETS + +#else + +#define HAVE_SOCKETS + +#ifndef _XOPEN_SOURCE_EXTENDED +#define _XOPEN_SOURCE_EXTENDED 1 +/* For HP-UX */ +#endif + +#ifndef BSD_COMP +#define BSD_COMP 1 +/* For Solaris */ +#endif + +#ifndef _ALL_SOURCE +#define _ALL_SOURCE 1 +/* For AIX */ +#endif + +#ifndef _OSF_SOURCE +#define _OSF_SOURCE 1 +/* For Tru64 */ +#endif + +#include +#include + +#if defined(__vxworks) +#include +#include +#include +#define SHUT_RD 0 +#define SHUT_WR 1 +#define SHUT_RDWR 2 + +#elif defined (WINNT) +#define FD_SETSIZE 1024 + +#ifdef __MINGW32__ +#include +#include + +#undef EACCES +#define EACCES WSAEACCES +#undef EADDRINUSE +#define EADDRINUSE WSAEADDRINUSE +#undef EADDRNOTAVAIL +#define EADDRNOTAVAIL WSAEADDRNOTAVAIL +#undef EAFNOSUPPORT +#define EAFNOSUPPORT WSAEAFNOSUPPORT +#undef EALREADY +#define EALREADY WSAEALREADY +#undef EBADF +#define EBADF WSAEBADF +#undef ECONNABORTED +#define ECONNABORTED WSAECONNABORTED +#undef ECONNREFUSED +#define ECONNREFUSED WSAECONNREFUSED +#undef ECONNRESET +#define ECONNRESET WSAECONNRESET +#undef EDESTADDRREQ +#define EDESTADDRREQ WSAEDESTADDRREQ +#undef EFAULT +#define EFAULT WSAEFAULT +#undef EHOSTDOWN +#define EHOSTDOWN WSAEHOSTDOWN +#undef EHOSTUNREACH +#define EHOSTUNREACH WSAEHOSTUNREACH +#undef EINPROGRESS +#define EINPROGRESS WSAEINPROGRESS +#undef EINTR +#define EINTR WSAEINTR +#undef EINVAL +#define EINVAL WSAEINVAL +#undef EIO +#define EIO WSAEDISCON +#undef EISCONN +#define EISCONN WSAEISCONN +#undef ELOOP +#define ELOOP WSAELOOP +#undef EMFILE +#define EMFILE WSAEMFILE +#undef EMSGSIZE +#define EMSGSIZE WSAEMSGSIZE +#undef ENAMETOOLONG +#define ENAMETOOLONG WSAENAMETOOLONG +#undef ENETDOWN +#define ENETDOWN WSAENETDOWN +#undef ENETRESET +#define ENETRESET WSAENETRESET +#undef ENETUNREACH +#define ENETUNREACH WSAENETUNREACH +#undef ENOBUFS +#define ENOBUFS WSAENOBUFS +#undef ENOPROTOOPT +#define ENOPROTOOPT WSAENOPROTOOPT +#undef ENOTCONN +#define ENOTCONN WSAENOTCONN +#undef ENOTSOCK +#define ENOTSOCK WSAENOTSOCK +#undef EOPNOTSUPP +#define EOPNOTSUPP WSAEOPNOTSUPP +#undef EPFNOSUPPORT +#define EPFNOSUPPORT WSAEPFNOSUPPORT +#undef EPROTONOSUPPORT +#define EPROTONOSUPPORT WSAEPROTONOSUPPORT +#undef EPROTOTYPE +#define EPROTOTYPE WSAEPROTOTYPE +#undef ESHUTDOWN +#define ESHUTDOWN WSAESHUTDOWN +#undef ESOCKTNOSUPPORT +#define ESOCKTNOSUPPORT WSAESOCKTNOSUPPORT +#undef ETIMEDOUT +#define ETIMEDOUT WSAETIMEDOUT +#undef ETOOMANYREFS +#define ETOOMANYREFS WSAETOOMANYREFS +#undef EWOULDBLOCK +#define EWOULDBLOCK WSAEWOULDBLOCK + +#define SHUT_RD SD_RECEIVE +#define SHUT_WR SD_SEND +#define SHUT_RDWR SD_BOTH + +#endif + +#include + +#elif defined(VMS) +#define FD_SETSIZE 4096 +#ifndef IN_RTS +/* These DEC C headers are not available when building with GCC */ +#include +#include +#include +#include +#endif + +#endif + +#if defined (__vxworks) && ! defined (__RTP__) +#include +#else +#include +#endif + +/* + * RTEMS has these .h files but not until you have built and installed + * RTEMS. When building a C/C++ toolset, you also build the newlib C library. + * So the build procedure for an RTEMS GNAT toolset requires that + * you build a C/C++ toolset, then build and install RTEMS with + * --enable-multilib, and finally build the Ada part of the toolset. + */ +#if !(defined (VMS) || defined (__MINGW32__)) +#include +#include +#include +#include +#include +#endif + +#if defined (_AIX) || defined (__FreeBSD__) || defined (__hpux__) || \ + defined (__osf__) || defined (_WIN32) || defined (__APPLE__) +# define HAVE_THREAD_SAFE_GETxxxBYyyy 1 + +#elif defined (sgi) || defined (linux) || defined (__GLIBC__) || \ + (defined (sun) && defined (__SVR4) && !defined (__vxworks)) || \ + defined(__rtems__) +# define HAVE_GETxxxBYyyy_R 1 +#endif + +/* + * Properties of the unerlying NetDB library: + * Need_Netdb_Buffer __gnat_getXXXbyYYY expects a caller-supplied buffer + * Need_Netdb_Lock __gnat_getXXXbyYYY expects the caller to ensure + * mutual exclusion + * + * See "Handling of gethostbyname, gethostbyaddr, getservbyname and + * getservbyport" in socket.c for details. + */ + +#if defined (HAVE_GETxxxBYyyy_R) +# define Need_Netdb_Buffer 1 +# define Need_Netdb_Lock 0 + +#else +# define Need_Netdb_Buffer 0 +# if !defined (HAVE_THREAD_SAFE_GETxxxBYyyy) +# define Need_Netdb_Lock 1 +# else +# define Need_Netdb_Lock 0 +# endif +#endif + +#if defined (__FreeBSD__) || defined (__vxworks) || defined(__rtems__) +# define Has_Sockaddr_Len 1 +#else +# define Has_Sockaddr_Len 0 +#endif + +#if !(defined (__vxworks) || defined (_WIN32) || defined (__hpux__) || defined (VMS)) +# define HAVE_INET_PTON +#endif + +#endif /* defined(__nucleus__) */ diff --git a/gcc/ada/hlo.adb b/gcc/ada/hlo.adb new file mode 100644 index 000000000..edbc4dae9 --- /dev/null +++ b/gcc/ada/hlo.adb @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- H L O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Output; use Output; + +package body HLO is + + ------------------------- + -- High_Level_Optimize -- + ------------------------- + + procedure High_Level_Optimize (N : Node_Id) is + pragma Warnings (Off, N); + begin + Write_Str ("High level optimizer activated"); + Write_Eol; + Write_Str ("High level optimizer completed"); + Write_Eol; + end High_Level_Optimize; + +end HLO; diff --git a/gcc/ada/hlo.ads b/gcc/ada/hlo.ads new file mode 100644 index 000000000..b3dc3b522 --- /dev/null +++ b/gcc/ada/hlo.ads @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- H L O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Types; use Types; + +package HLO is + + procedure High_Level_Optimize (N : Node_Id); + -- This procedure activates the high level optimizer. At the time it is + -- called, the tree for compilation unit N has been fully analyzed, but + -- not expanded, but the Analyzed flags have been reset. On return, the + -- tree may be modified (and will be reanalyzed and expanded as required). + +end HLO; diff --git a/gcc/ada/hostparm.ads b/gcc/ada/hostparm.ads new file mode 100644 index 000000000..64164f327 --- /dev/null +++ b/gcc/ada/hostparm.ads @@ -0,0 +1,90 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- H O S T P A R 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 defines some system dependent parameters for GNAT. These +-- are parameters that are relevant to the host machine on which the +-- compiler is running, and thus this package is part of the compiler. + +with Types; + +package Hostparm is + + --------------------- + -- HOST Parameters -- + --------------------- + + Gnat_VMSp : Integer; + pragma Import (C, Gnat_VMSp, "__gnat_vmsp"); + + OpenVMS : Boolean := Gnat_VMSp /= 0; + -- Set True for OpenVMS host. See also OpenVMS target boolean in + -- system-vms.ads and system-vms_64.ads and OpenVMS_On_Target boolean in + -- Targparm. This is not a constant, because it can be modified by -gnatdm. + + Direct_Separator : constant Character; + pragma Import (C, Direct_Separator, "__gnat_dir_separator"); + Normalized_CWD : constant String := "." & Direct_Separator; + -- Normalized string to access current directory + + Max_Line_Length : constant := Types.Column_Number'Pred + (Types.Column_Number'Last); + -- Maximum source line length. By default we set it to the maximum + -- value that can be supported, which is given by the range of the + -- Column_Number type. We subtract 1 because need to be able to + -- have a valid Column_Number equal to Max_Line_Length to represent + -- the location of a "line too long" error. + -- 200 is the minimum value required (RM 2.2(15)). The value set here + -- can be reduced by the explicit use of the -gnatyM style switch. + + Max_Name_Length : constant := 1024; + -- Maximum length of unit name (including all dots, and " (spec)") and + -- of file names in the library, must be at least Max_Line_Length, but + -- can be larger. + + Max_Instantiations : constant := 4000; + -- Maximum number of instantiations permitted (to stop runaway cases + -- of nested instantiations). These situations probably only occur in + -- specially concocted test cases. + + Tag_Errors : constant Boolean := False; + -- If set to true, then brief form error messages will be prefaced by + -- the string "error:". Used as default for Opt.Unique_Error_Tag. + + Exclude_Missing_Objects : constant Boolean := True; + -- If set to true, gnatbind will exclude from consideration all + -- non-existent .o files. + + Max_Debug_Name_Length : constant := 256; + -- If a generated qualified debug name exceeds this length, then it + -- is automatically compressed, regardless of the setting of the + -- Compress_Debug_Names switch controlled by -gnatC. + +end Hostparm; diff --git a/gcc/ada/i-c.adb b/gcc/ada/i-c.adb new file mode 100644 index 000000000..01d69122f --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Interfaces.C is + + ----------------------- + -- Is_Nul_Terminated -- + ----------------------- + + -- Case of char_array + + function Is_Nul_Terminated (Item : char_array) return Boolean is + begin + for J in Item'Range loop + if Item (J) = nul then + return True; + end if; + end loop; + + return False; + end Is_Nul_Terminated; + + -- Case of wchar_array + + function Is_Nul_Terminated (Item : wchar_array) return Boolean is + begin + for J in Item'Range loop + if Item (J) = wide_nul then + return True; + end if; + end loop; + + return False; + end Is_Nul_Terminated; + + -- Case of char16_array + + function Is_Nul_Terminated (Item : char16_array) return Boolean is + begin + for J in Item'Range loop + if Item (J) = char16_nul then + return True; + end if; + end loop; + + return False; + end Is_Nul_Terminated; + + -- Case of char32_array + + function Is_Nul_Terminated (Item : char32_array) return Boolean is + begin + for J in Item'Range loop + if Item (J) = char32_nul then + return True; + end if; + end loop; + + return False; + end Is_Nul_Terminated; + + ------------ + -- To_Ada -- + ------------ + + -- Convert char to Character + + function To_Ada (Item : char) return Character is + begin + return Character'Val (char'Pos (Item)); + end To_Ada; + + -- Convert char_array to String (function form) + + function To_Ada + (Item : char_array; + Trim_Nul : Boolean := True) return String + is + Count : Natural; + From : size_t; + + begin + if Trim_Nul then + From := Item'First; + + loop + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = nul then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + declare + R : String (1 .. Count); + + begin + for J in R'Range loop + R (J) := To_Ada (Item (size_t (J) + (Item'First - 1))); + end loop; + + return R; + end; + end To_Ada; + + -- Convert char_array to String (procedure form) + + procedure To_Ada + (Item : char_array; + Target : out String; + Count : out Natural; + Trim_Nul : Boolean := True) + is + From : size_t; + To : Positive; + + begin + if Trim_Nul then + From := Item'First; + loop + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = nul then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + if Count > Target'Length then + raise Constraint_Error; + + else + From := Item'First; + To := Target'First; + + for J in 1 .. Count loop + Target (To) := Character (Item (From)); + From := From + 1; + To := To + 1; + end loop; + end if; + + end To_Ada; + + -- Convert wchar_t to Wide_Character + + function To_Ada (Item : wchar_t) return Wide_Character is + begin + return Wide_Character (Item); + end To_Ada; + + -- Convert wchar_array to Wide_String (function form) + + function To_Ada + (Item : wchar_array; + Trim_Nul : Boolean := True) return Wide_String + is + Count : Natural; + From : size_t; + + begin + if Trim_Nul then + From := Item'First; + + loop + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = wide_nul then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + declare + R : Wide_String (1 .. Count); + + begin + for J in R'Range loop + R (J) := To_Ada (Item (size_t (J) + (Item'First - 1))); + end loop; + + return R; + end; + end To_Ada; + + -- Convert wchar_array to Wide_String (procedure form) + + procedure To_Ada + (Item : wchar_array; + Target : out Wide_String; + Count : out Natural; + Trim_Nul : Boolean := True) + is + From : size_t; + To : Positive; + + begin + if Trim_Nul then + From := Item'First; + loop + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = wide_nul then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + if Count > Target'Length then + raise Constraint_Error; + + else + From := Item'First; + To := Target'First; + + for J in 1 .. Count loop + Target (To) := To_Ada (Item (From)); + From := From + 1; + To := To + 1; + end loop; + end if; + end To_Ada; + + -- Convert char16_t to Wide_Character + + function To_Ada (Item : char16_t) return Wide_Character is + begin + return Wide_Character'Val (char16_t'Pos (Item)); + end To_Ada; + + -- Convert char16_array to Wide_String (function form) + + function To_Ada + (Item : char16_array; + Trim_Nul : Boolean := True) return Wide_String + is + Count : Natural; + From : size_t; + + begin + if Trim_Nul then + From := Item'First; + + loop + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = char16_t'Val (0) then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + declare + R : Wide_String (1 .. Count); + + begin + for J in R'Range loop + R (J) := To_Ada (Item (size_t (J) + (Item'First - 1))); + end loop; + + return R; + end; + end To_Ada; + + -- Convert char16_array to Wide_String (procedure form) + + procedure To_Ada + (Item : char16_array; + Target : out Wide_String; + Count : out Natural; + Trim_Nul : Boolean := True) + is + From : size_t; + To : Positive; + + begin + if Trim_Nul then + From := Item'First; + loop + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = char16_t'Val (0) then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + if Count > Target'Length then + raise Constraint_Error; + + else + From := Item'First; + To := Target'First; + + for J in 1 .. Count loop + Target (To) := To_Ada (Item (From)); + From := From + 1; + To := To + 1; + end loop; + end if; + end To_Ada; + + -- Convert char32_t to Wide_Wide_Character + + function To_Ada (Item : char32_t) return Wide_Wide_Character is + begin + return Wide_Wide_Character'Val (char32_t'Pos (Item)); + end To_Ada; + + -- Convert char32_array to Wide_Wide_String (function form) + + function To_Ada + (Item : char32_array; + Trim_Nul : Boolean := True) return Wide_Wide_String + is + Count : Natural; + From : size_t; + + begin + if Trim_Nul then + From := Item'First; + + loop + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = char32_t'Val (0) then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + declare + R : Wide_Wide_String (1 .. Count); + + begin + for J in R'Range loop + R (J) := To_Ada (Item (size_t (J) + (Item'First - 1))); + end loop; + + return R; + end; + end To_Ada; + + -- Convert char32_array to Wide_Wide_String (procedure form) + + procedure To_Ada + (Item : char32_array; + Target : out Wide_Wide_String; + Count : out Natural; + Trim_Nul : Boolean := True) + is + From : size_t; + To : Positive; + + begin + if Trim_Nul then + From := Item'First; + loop + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = char32_t'Val (0) then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + if Count > Target'Length then + raise Constraint_Error; + + else + From := Item'First; + To := Target'First; + + for J in 1 .. Count loop + Target (To) := To_Ada (Item (From)); + From := From + 1; + To := To + 1; + end loop; + end if; + end To_Ada; + + ---------- + -- To_C -- + ---------- + + -- Convert Character to char + + function To_C (Item : Character) return char is + begin + return char'Val (Character'Pos (Item)); + end To_C; + + -- Convert String to char_array (function form) + + function To_C + (Item : String; + Append_Nul : Boolean := True) return char_array + is + begin + if Append_Nul then + declare + R : char_array (0 .. Item'Length); + + begin + for J in Item'Range loop + R (size_t (J - Item'First)) := To_C (Item (J)); + end loop; + + R (R'Last) := nul; + return R; + end; + + -- Append_Nul False + + else + -- A nasty case, if the string is null, we must return a null + -- char_array. The lower bound of this array is required to be zero + -- (RM B.3(50)) but that is of course impossible given that size_t + -- is unsigned. According to Ada 2005 AI-258, the result is to raise + -- Constraint_Error. This is also the appropriate behavior in Ada 95, + -- since nothing else makes sense. + + if Item'Length = 0 then + raise Constraint_Error; + + -- Normal case + + else + declare + R : char_array (0 .. Item'Length - 1); + + begin + for J in Item'Range loop + R (size_t (J - Item'First)) := To_C (Item (J)); + end loop; + + return R; + end; + end if; + end if; + end To_C; + + -- Convert String to char_array (procedure form) + + procedure To_C + (Item : String; + Target : out char_array; + Count : out size_t; + Append_Nul : Boolean := True) + is + To : size_t; + + begin + if Target'Length < Item'Length then + raise Constraint_Error; + + else + To := Target'First; + for From in Item'Range loop + Target (To) := char (Item (From)); + To := To + 1; + end loop; + + if Append_Nul then + if To > Target'Last then + raise Constraint_Error; + else + Target (To) := nul; + Count := Item'Length + 1; + end if; + + else + Count := Item'Length; + end if; + end if; + end To_C; + + -- Convert Wide_Character to wchar_t + + function To_C (Item : Wide_Character) return wchar_t is + begin + return wchar_t (Item); + end To_C; + + -- Convert Wide_String to wchar_array (function form) + + function To_C + (Item : Wide_String; + Append_Nul : Boolean := True) return wchar_array + is + begin + if Append_Nul then + declare + R : wchar_array (0 .. Item'Length); + + begin + for J in Item'Range loop + R (size_t (J - Item'First)) := To_C (Item (J)); + end loop; + + R (R'Last) := wide_nul; + return R; + end; + + else + -- A nasty case, if the string is null, we must return a null + -- wchar_array. The lower bound of this array is required to be zero + -- (RM B.3(50)) but that is of course impossible given that size_t + -- is unsigned. According to Ada 2005 AI-258, the result is to raise + -- Constraint_Error. This is also the appropriate behavior in Ada 95, + -- since nothing else makes sense. + + if Item'Length = 0 then + raise Constraint_Error; + + else + declare + R : wchar_array (0 .. Item'Length - 1); + + begin + for J in size_t range 0 .. Item'Length - 1 loop + R (J) := To_C (Item (Integer (J) + Item'First)); + end loop; + + return R; + end; + end if; + end if; + end To_C; + + -- Convert Wide_String to wchar_array (procedure form) + + procedure To_C + (Item : Wide_String; + Target : out wchar_array; + Count : out size_t; + Append_Nul : Boolean := True) + is + To : size_t; + + begin + if Target'Length < Item'Length then + raise Constraint_Error; + + else + To := Target'First; + for From in Item'Range loop + Target (To) := To_C (Item (From)); + To := To + 1; + end loop; + + if Append_Nul then + if To > Target'Last then + raise Constraint_Error; + else + Target (To) := wide_nul; + Count := Item'Length + 1; + end if; + + else + Count := Item'Length; + end if; + end if; + end To_C; + + -- Convert Wide_Character to char16_t + + function To_C (Item : Wide_Character) return char16_t is + begin + return char16_t'Val (Wide_Character'Pos (Item)); + end To_C; + + -- Convert Wide_String to char16_array (function form) + + function To_C + (Item : Wide_String; + Append_Nul : Boolean := True) return char16_array + is + begin + if Append_Nul then + declare + R : char16_array (0 .. Item'Length); + + begin + for J in Item'Range loop + R (size_t (J - Item'First)) := To_C (Item (J)); + end loop; + + R (R'Last) := char16_t'Val (0); + return R; + end; + + else + -- A nasty case, if the string is null, we must return a null + -- char16_array. The lower bound of this array is required to be zero + -- (RM B.3(50)) but that is of course impossible given that size_t + -- is unsigned. According to Ada 2005 AI-258, the result is to raise + -- Constraint_Error. This is also the appropriate behavior in Ada 95, + -- since nothing else makes sense. + + if Item'Length = 0 then + raise Constraint_Error; + + else + declare + R : char16_array (0 .. Item'Length - 1); + + begin + for J in size_t range 0 .. Item'Length - 1 loop + R (J) := To_C (Item (Integer (J) + Item'First)); + end loop; + + return R; + end; + end if; + end if; + end To_C; + + -- Convert Wide_String to char16_array (procedure form) + + procedure To_C + (Item : Wide_String; + Target : out char16_array; + Count : out size_t; + Append_Nul : Boolean := True) + is + To : size_t; + + begin + if Target'Length < Item'Length then + raise Constraint_Error; + + else + To := Target'First; + for From in Item'Range loop + Target (To) := To_C (Item (From)); + To := To + 1; + end loop; + + if Append_Nul then + if To > Target'Last then + raise Constraint_Error; + else + Target (To) := char16_t'Val (0); + Count := Item'Length + 1; + end if; + + else + Count := Item'Length; + end if; + end if; + end To_C; + + -- Convert Wide_Character to char32_t + + function To_C (Item : Wide_Wide_Character) return char32_t is + begin + return char32_t'Val (Wide_Wide_Character'Pos (Item)); + end To_C; + + -- Convert Wide_Wide_String to char32_array (function form) + + function To_C + (Item : Wide_Wide_String; + Append_Nul : Boolean := True) return char32_array + is + begin + if Append_Nul then + declare + R : char32_array (0 .. Item'Length); + + begin + for J in Item'Range loop + R (size_t (J - Item'First)) := To_C (Item (J)); + end loop; + + R (R'Last) := char32_t'Val (0); + return R; + end; + + else + -- A nasty case, if the string is null, we must return a null + -- char32_array. The lower bound of this array is required to be zero + -- (RM B.3(50)) but that is of course impossible given that size_t + -- is unsigned. According to Ada 2005 AI-258, the result is to raise + -- Constraint_Error. + + if Item'Length = 0 then + raise Constraint_Error; + + else + declare + R : char32_array (0 .. Item'Length - 1); + + begin + for J in size_t range 0 .. Item'Length - 1 loop + R (J) := To_C (Item (Integer (J) + Item'First)); + end loop; + + return R; + end; + end if; + end if; + end To_C; + + -- Convert Wide_Wide_String to char32_array (procedure form) + + procedure To_C + (Item : Wide_Wide_String; + Target : out char32_array; + Count : out size_t; + Append_Nul : Boolean := True) + is + To : size_t; + + begin + if Target'Length < Item'Length then + raise Constraint_Error; + + else + To := Target'First; + for From in Item'Range loop + Target (To) := To_C (Item (From)); + To := To + 1; + end loop; + + if Append_Nul then + if To > Target'Last then + raise Constraint_Error; + else + Target (To) := char32_t'Val (0); + Count := Item'Length + 1; + end if; + + else + Count := Item'Length; + end if; + end if; + end To_C; + +end Interfaces.C; diff --git a/gcc/ada/i-c.ads b/gcc/ada/i-c.ads new file mode 100644 index 000000000..9e98b050a --- /dev/null +++ b/gcc/ada/i-c.ads @@ -0,0 +1,230 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with System.Parameters; + +package Interfaces.C is + pragma Pure; + + -- Declaration's based on C's + + CHAR_BIT : constant := 8; + SCHAR_MIN : constant := -128; + SCHAR_MAX : constant := 127; + UCHAR_MAX : constant := 255; + + -- Signed and Unsigned Integers. Note that in GNAT, we have ensured that + -- the standard predefined Ada types correspond to the standard C types + + -- Note: the Integer qualifications used in the declaration of type long + -- avoid ambiguities when compiling in the presence of s-auxdec.ads and + -- a non-private system.address type. + + type int is new Integer; + type short is new Short_Integer; + type long is range -(2 ** (System.Parameters.long_bits - Integer'(1))) + .. +(2 ** (System.Parameters.long_bits - Integer'(1))) - 1; + + type signed_char is range SCHAR_MIN .. SCHAR_MAX; + for signed_char'Size use CHAR_BIT; + + type unsigned is mod 2 ** int'Size; + type unsigned_short is mod 2 ** short'Size; + type unsigned_long is mod 2 ** long'Size; + + type unsigned_char is mod (UCHAR_MAX + 1); + for unsigned_char'Size use CHAR_BIT; + + subtype plain_char is unsigned_char; -- ??? should be parameterized + + -- Note: the Integer qualifications used in the declaration of ptrdiff_t + -- avoid ambiguities when compiling in the presence of s-auxdec.ads and + -- a non-private system.address type. + + type ptrdiff_t is + range -(2 ** (Standard'Address_Size - Integer'(1))) .. + +(2 ** (Standard'Address_Size - Integer'(1)) - 1); + + type size_t is mod 2 ** Standard'Address_Size; + + -- Floating-Point + + type C_float is new Float; + type double is new Standard.Long_Float; + type long_double is new Standard.Long_Long_Float; + + ---------------------------- + -- Characters and Strings -- + ---------------------------- + + type char is new Character; + + nul : constant char := char'First; + + function To_C (Item : Character) return char; + function To_Ada (Item : char) return Character; + + type char_array is array (size_t range <>) of aliased char; + for char_array'Component_Size use CHAR_BIT; + + function Is_Nul_Terminated (Item : char_array) return Boolean; + + function To_C + (Item : String; + Append_Nul : Boolean := True) return char_array; + + function To_Ada + (Item : char_array; + Trim_Nul : Boolean := True) return String; + + procedure To_C + (Item : String; + Target : out char_array; + Count : out size_t; + Append_Nul : Boolean := True); + + procedure To_Ada + (Item : char_array; + Target : out String; + Count : out Natural; + Trim_Nul : Boolean := True); + + ------------------------------------ + -- Wide Character and Wide String -- + ------------------------------------ + + type wchar_t is new Wide_Character; + for wchar_t'Size use Standard'Wchar_T_Size; + + wide_nul : constant wchar_t := wchar_t'First; + + function To_C (Item : Wide_Character) return wchar_t; + function To_Ada (Item : wchar_t) return Wide_Character; + + type wchar_array is array (size_t range <>) of aliased wchar_t; + + function Is_Nul_Terminated (Item : wchar_array) return Boolean; + + function To_C + (Item : Wide_String; + Append_Nul : Boolean := True) return wchar_array; + + function To_Ada + (Item : wchar_array; + Trim_Nul : Boolean := True) return Wide_String; + + procedure To_C + (Item : Wide_String; + Target : out wchar_array; + Count : out size_t; + Append_Nul : Boolean := True); + + procedure To_Ada + (Item : wchar_array; + Target : out Wide_String; + Count : out Natural; + Trim_Nul : Boolean := True); + + Terminator_Error : exception; + + -- The remaining declarations are for Ada 2005 (AI-285) + + -- ISO/IEC 10646:2003 compatible types defined by SC22/WG14 document N1010 + + type char16_t is new Wide_Character; + pragma Ada_05 (char16_t); + + char16_nul : constant char16_t := char16_t'Val (0); + pragma Ada_05 (char16_nul); + + function To_C (Item : Wide_Character) return char16_t; + pragma Ada_05 (To_C); + + function To_Ada (Item : char16_t) return Wide_Character; + pragma Ada_05 (To_Ada); + + type char16_array is array (size_t range <>) of aliased char16_t; + pragma Ada_05 (char16_array); + + function Is_Nul_Terminated (Item : char16_array) return Boolean; + pragma Ada_05 (Is_Nul_Terminated); + + function To_C + (Item : Wide_String; + Append_Nul : Boolean := True) return char16_array; + pragma Ada_05 (To_C); + + function To_Ada + (Item : char16_array; + Trim_Nul : Boolean := True) return Wide_String; + pragma Ada_05 (To_Ada); + + procedure To_C + (Item : Wide_String; + Target : out char16_array; + Count : out size_t; + Append_Nul : Boolean := True); + pragma Ada_05 (To_C); + + procedure To_Ada + (Item : char16_array; + Target : out Wide_String; + Count : out Natural; + Trim_Nul : Boolean := True); + pragma Ada_05 (To_Ada); + + type char32_t is new Wide_Wide_Character; + pragma Ada_05 (char32_t); + + char32_nul : constant char32_t := char32_t'Val (0); + pragma Ada_05 (char32_nul); + + function To_C (Item : Wide_Wide_Character) return char32_t; + pragma Ada_05 (To_C); + + function To_Ada (Item : char32_t) return Wide_Wide_Character; + pragma Ada_05 (To_Ada); + + type char32_array is array (size_t range <>) of aliased char32_t; + pragma Ada_05 (char32_array); + + function Is_Nul_Terminated (Item : char32_array) return Boolean; + pragma Ada_05 (Is_Nul_Terminated); + + function To_C + (Item : Wide_Wide_String; + Append_Nul : Boolean := True) return char32_array; + pragma Ada_05 (To_C); + + function To_Ada + (Item : char32_array; + Trim_Nul : Boolean := True) return Wide_Wide_String; + pragma Ada_05 (To_Ada); + + procedure To_C + (Item : Wide_Wide_String; + Target : out char32_array; + Count : out size_t; + Append_Nul : Boolean := True); + pragma Ada_05 (To_C); + + procedure To_Ada + (Item : char32_array; + Target : out Wide_Wide_String; + Count : out Natural; + Trim_Nul : Boolean := True); + pragma Ada_05 (To_Ada); + +end Interfaces.C; diff --git a/gcc/ada/i-cexten.ads b/gcc/ada/i-cexten.ads new file mode 100644 index 000000000..235aca4b4 --- /dev/null +++ b/gcc/ada/i-cexten.ads @@ -0,0 +1,263 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 + + -- 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; + + -- Definitions for C++ incomplete/unknown classes + + subtype incomplete_class_def is System.Address; + type incomplete_class_def_ptr is access incomplete_class_def; + + -- 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 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; + +end Interfaces.C.Extensions; diff --git a/gcc/ada/i-cobol.adb b/gcc/ada/i-cobol.adb new file mode 100644 index 000000000..ed5b0ab6a --- /dev/null +++ b/gcc/ada/i-cobol.adb @@ -0,0 +1,994 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..ad885e4a9 --- /dev/null +++ b/gcc/ada/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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 new file mode 100644 index 000000000..0e6b32047 --- /dev/null +++ b/gcc/ada/i-cpoint.adb @@ -0,0 +1,277 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 Memory_Size; + + 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 := Target; + S : Pointer := Source; + + begin + if S = null or else T = null then + raise Dereference_Error; + + else + for J in 1 .. Length loop + T.all := S.all; + Increment (T); + Increment (S); + 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 + S : Pointer := Source; + T : Pointer := Target; + L : ptrdiff_t := Limit; + + begin + if S = null or else T = null then + raise Dereference_Error; + + else + while L > 0 loop + T.all := S.all; + exit when T.all = Terminator; + Increment (T); + Increment (S); + L := L - 1; + end loop; + end if; + 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; + 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; + 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 new file mode 100644 index 000000000..053511968 --- /dev/null +++ b/gcc/ada/i-cpoint.ads @@ -0,0 +1,99 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 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; + + 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-cpp.adb b/gcc/ada/i-cpp.adb new file mode 100644 index 000000000..f7a486088 --- /dev/null +++ b/gcc/ada/i-cpp.adb @@ -0,0 +1,35 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- I N T E R F A C E S . C P P -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Dummy body to deal with bootstrap issues (there used to be a real body) + +package body Interfaces.CPP is +end Interfaces.CPP; diff --git a/gcc/ada/i-cpp.ads b/gcc/ada/i-cpp.ads new file mode 100644 index 000000000..0435c135f --- /dev/null +++ b/gcc/ada/i-cpp.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- I N T E R F A C E S . C P P -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Missing package comment ??? + +with Ada.Tags; + +package Interfaces.CPP is + pragma Elaborate_Body; + -- We have a dummy body to deal with bootstrap path issues + + subtype Vtable_Ptr is Ada.Tags.Tag; + + -- These need commenting (this is not an RM package!) + + function Expanded_Name (T : Vtable_Ptr) return String + renames Ada.Tags.Expanded_Name; + + function External_Tag (T : Vtable_Ptr) return String + renames Ada.Tags.External_Tag; + +end Interfaces.CPP; diff --git a/gcc/ada/i-cstrea-vms.adb b/gcc/ada/i-cstrea-vms.adb new file mode 100644 index 000000000..85e6f56b3 --- /dev/null +++ b/gcc/ada/i-cstrea-vms.adb @@ -0,0 +1,253 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 Alpha/VMS version + +with Ada.Unchecked_Conversion; +package body Interfaces.C_Streams is + + use type System.CRTL.size_t; + + -- As the functions fread, fwrite and setvbuf are too big to be inlined, + -- they are just wrappers to the following implementation functions. + + function fread_impl + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) return size_t; + + function fread_impl + (buffer : voids; + index : size_t; + size : size_t; + count : size_t; + stream : FILEs) return size_t; + + function fwrite_impl + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) return size_t; + + function setvbuf_impl + (stream : FILEs; + buffer : chars; + mode : int; + size : size_t) return int; + + ------------ + -- fread -- + ------------ + + function fread_impl + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) return size_t + is + Get_Count : size_t := 0; + + type Buffer_Type is array (size_t range 1 .. count, + size_t range 1 .. size) of Character; + type Buffer_Access is access Buffer_Type; + function To_BA is new Ada.Unchecked_Conversion (voids, Buffer_Access); + + BA : constant Buffer_Access := To_BA (buffer); + Ch : int; + + begin + -- This Fread goes with the Fwrite below. The C library fread sometimes + -- can't read fputc generated files. + + for C in 1 .. count loop + for S in 1 .. size loop + Ch := fgetc (stream); + + if Ch = EOF then + return Get_Count; + end if; + + BA.all (C, S) := Character'Val (Ch); + end loop; + + Get_Count := Get_Count + 1; + end loop; + + return Get_Count; + end fread_impl; + + function fread_impl + (buffer : voids; + index : size_t; + size : size_t; + count : size_t; + stream : FILEs) return size_t + is + Get_Count : size_t := 0; + + type Buffer_Type is array (size_t range 1 .. count, + size_t range 1 .. size) of Character; + type Buffer_Access is access Buffer_Type; + function To_BA is new Ada.Unchecked_Conversion (voids, Buffer_Access); + + BA : constant Buffer_Access := To_BA (buffer); + Ch : int; + + begin + -- This Fread goes with the Fwrite below. The C library fread sometimes + -- can't read fputc generated files. + + for C in 1 + index .. count + index loop + for S in 1 .. size loop + Ch := fgetc (stream); + + if Ch = EOF then + return Get_Count; + end if; + + BA.all (C, S) := Character'Val (Ch); + end loop; + + Get_Count := Get_Count + 1; + end loop; + + return Get_Count; + end fread_impl; + + function fread + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) return size_t + is + begin + return fread_impl (buffer, size, count, stream); + end fread; + + function fread + (buffer : voids; + index : size_t; + size : size_t; + count : size_t; + stream : FILEs) return size_t + is + begin + return fread_impl (buffer, index, size, count, stream); + end fread; + + ------------ + -- fwrite -- + ------------ + + function fwrite_impl + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) return size_t + is + Put_Count : size_t := 0; + + type Buffer_Type is array (size_t range 1 .. count, + size_t range 1 .. size) of Character; + type Buffer_Access is access Buffer_Type; + function To_BA is new Ada.Unchecked_Conversion (voids, Buffer_Access); + + BA : constant Buffer_Access := To_BA (buffer); + + begin + -- Fwrite on VMS has the undesirable effect of always generating at + -- least one record of output per call, regardless of buffering. To + -- get around this, we do multiple fputc calls instead. + + for C in 1 .. count loop + for S in 1 .. size loop + if fputc (Character'Pos (BA.all (C, S)), stream) = EOF then + return Put_Count; + end if; + end loop; + + Put_Count := Put_Count + 1; + end loop; + + return Put_Count; + end fwrite_impl; + + function fwrite + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) return size_t + is + begin + return fwrite_impl (buffer, size, count, stream); + end fwrite; + + ------------- + -- setvbuf -- + ------------- + + function setvbuf_impl + (stream : FILEs; + buffer : chars; + mode : int; + size : size_t) return int + is + use type System.Address; + + begin + -- In order for the above fwrite hack to work, we must always buffer + -- stdout and stderr. Is_regular_file on VMS cannot detect when + -- these are redirected to a file, so checking for that condition + -- doesn't help. + + if mode = IONBF + and then (stream = stdout or else stream = stderr) + then + return System.CRTL.setvbuf + (stream, buffer, IOLBF, System.CRTL.size_t (size)); + else + return System.CRTL.setvbuf + (stream, buffer, mode, System.CRTL.size_t (size)); + end if; + end setvbuf_impl; + + function setvbuf + (stream : FILEs; + buffer : chars; + mode : int; + size : size_t) return int + is + begin + return setvbuf_impl (stream, buffer, mode, size); + end setvbuf; + +end Interfaces.C_Streams; diff --git a/gcc/ada/i-cstrea.adb b/gcc/ada/i-cstrea.adb new file mode 100644 index 000000000..e072b0d41 --- /dev/null +++ b/gcc/ada/i-cstrea.adb @@ -0,0 +1,137 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 which just calls the C versions directly +-- Note: the reason that we provide for specialization here is that on +-- some systems, notably VMS, we may need to worry about buffering. + +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 new file mode 100644 index 000000000..5c997bd75 --- /dev/null +++ b/gcc/ada/i-cstrea.ads @@ -0,0 +1,274 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 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 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 ftell (stream : FILEs) return long + renames System.CRTL.ftell; + + 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 (string : 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 -- + --------------------------------- + + -- If text_translation_required is true, then the following 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 (i.e. in normal unix mode). Use fileno to get a stream handle. + + procedure set_binary_mode (handle : int); + procedure set_text_mode (handle : int); + + ---------------------------- + -- 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 : Integer; + -- Maximum length of an allowable full path name on the system, + -- including a terminating NUL character. + +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, 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 new file mode 100644 index 000000000..8308649d5 --- /dev/null +++ b/gcc/ada/i-cstrin.adb @@ -0,0 +1,342 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 (Address, chars_ptr); + + function To_Address is + new Ada.Unchecked_Conversion (chars_ptr, 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, "__gnat_malloc"); + + 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 + begin + return New_Char_Array (To_C (Str)); + 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 new file mode 100644 index 000000000..7bfee8f2c --- /dev/null +++ b/gcc/ada/i-cstrin.ads @@ -0,0 +1,102 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 Interfaces.C.Strings is + pragma Preelaborate; + + type char_array_access is access all char_array; + + 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; + + type chars_ptr_array is array (size_t range <>) of 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); + + 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; + pragma Convention (C, chars_ptr); + + 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-forbla-darwin.adb b/gcc/ada/i-forbla-darwin.adb new file mode 100644 index 000000000..825a88404 --- /dev/null +++ b/gcc/ada/i-forbla-darwin.adb @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- I N T E R F A C E S . F O R T R A N . B L A S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2006-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. -- +-- -- +------------------------------------------------------------------------------ + +-- Version for Mac OS X + +package body Interfaces.Fortran.BLAS is + pragma Linker_Options ("-lgnala"); + pragma Linker_Options ("-lm"); + pragma Linker_Options ("-Wl,-framework,vecLib"); +end Interfaces.Fortran.BLAS; diff --git a/gcc/ada/i-forbla-unimplemented.ads b/gcc/ada/i-forbla-unimplemented.ads new file mode 100644 index 000000000..deea344bb --- /dev/null +++ b/gcc/ada/i-forbla-unimplemented.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- I N T E R F A C E S . F O R T R A N . B L A S -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a thin binding to the standard Fortran BLAS library. +-- Documentation and a reference BLAS implementation is available from +-- ftp://ftp.netlib.org. The main purpose of this package is to facilitate +-- implementation of the Ada 2005 Ada.Numerics.Generic_Real_Arrays and +-- Ada.Numerics.Generic_Complex_Arrays packages. Bindings to other BLAS +-- routines may be added over time. + +-- This unit is not implemented in this GNAT configuration + +package Interfaces.Fortran.BLAS is + + pragma Unimplemented_Unit; + +end Interfaces.Fortran.BLAS; diff --git a/gcc/ada/i-forbla.adb b/gcc/ada/i-forbla.adb new file mode 100644 index 000000000..4445c5124 --- /dev/null +++ b/gcc/ada/i-forbla.adb @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- I N T E R F A C E S . F O R T R A N . B L A S -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This Interfaces.Fortran.Blas package body contains the required linker +-- pragmas for automatically linking with the LAPACK linear algebra support +-- library, and the systems math library. Alternative bodies can be supplied +-- if different sets of libraries are needed. + +package body Interfaces.Fortran.BLAS is + pragma Linker_Options ("-lgnala"); + pragma Linker_Options ("-llapack"); + pragma Linker_Options ("-lblas"); + pragma Linker_Options ("-lm"); +end Interfaces.Fortran.BLAS; diff --git a/gcc/ada/i-forbla.ads b/gcc/ada/i-forbla.ads new file mode 100644 index 000000000..3910349a6 --- /dev/null +++ b/gcc/ada/i-forbla.ads @@ -0,0 +1,261 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- I N T E R F A C E S . F O R T R A N . B L A S -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a thin binding to the standard Fortran BLAS library. +-- Documentation and a reference BLAS implementation is available from +-- ftp://ftp.netlib.org. The main purpose of this package is to facilitate +-- implementation of the Ada 2005 Ada.Numerics.Generic_Real_Arrays and +-- Ada.Numerics.Generic_Complex_Arrays packages. Bindings to other BLAS +-- routines may be added over time. + +-- As actual linker arguments to link with the BLAS implementation differs +-- according to platform and chosen BLAS implementation, the linker arguments +-- are given in the body of this package. The body may need to be modified in +-- order to link with different BLAS implementations tuned to the specific +-- target. + +package Interfaces.Fortran.BLAS is + pragma Pure; + pragma Elaborate_Body; + + No_Trans : aliased constant Character := 'N'; + Trans : aliased constant Character := 'T'; + Conj_Trans : aliased constant Character := 'C'; + + -- Vector types + + type Real_Vector is array (Integer range <>) of Real; + + type Complex_Vector is array (Integer range <>) of Complex; + + type Double_Precision_Vector is array (Integer range <>) + of Double_Precision; + + type Double_Complex_Vector is array (Integer range <>) of Double_Complex; + + -- Matrix types + + type Real_Matrix is array (Integer range <>, Integer range <>) + of Real; + + type Double_Precision_Matrix is array (Integer range <>, Integer range <>) + of Double_Precision; + + type Complex_Matrix is array (Integer range <>, Integer range <>) + of Complex; + + type Double_Complex_Matrix is array (Integer range <>, Integer range <>) + of Double_Complex; + + -- BLAS Level 1 + + function sdot + (N : Positive; + X : Real_Vector; + Inc_X : Integer := 1; + Y : Real_Vector; + Inc_Y : Integer := 1) return Real; + + function ddot + (N : Positive; + X : Double_Precision_Vector; + Inc_X : Integer := 1; + Y : Double_Precision_Vector; + Inc_Y : Integer := 1) return Double_Precision; + + function cdotu + (N : Positive; + X : Complex_Vector; + Inc_X : Integer := 1; + Y : Complex_Vector; + Inc_Y : Integer := 1) return Complex; + + function zdotu + (N : Positive; + X : Double_Complex_Vector; + Inc_X : Integer := 1; + Y : Double_Complex_Vector; + Inc_Y : Integer := 1) return Double_Complex; + + function snrm2 + (N : Natural; + X : Real_Vector; + Inc_X : Integer := 1) return Real; + + function dnrm2 + (N : Natural; + X : Double_Precision_Vector; + Inc_X : Integer := 1) return Double_Precision; + + function scnrm2 + (N : Natural; + X : Complex_Vector; + Inc_X : Integer := 1) return Real; + + function dznrm2 + (N : Natural; + X : Double_Complex_Vector; + Inc_X : Integer := 1) return Double_Precision; + + -- BLAS Level 2 + + procedure sgemv + (Trans : access constant Character; + M : Natural := 0; + N : Natural := 0; + Alpha : Real := 1.0; + A : Real_Matrix; + Ld_A : Positive; + X : Real_Vector; + Inc_X : Integer := 1; -- must be non-zero + Beta : Real := 0.0; + Y : in out Real_Vector; + Inc_Y : Integer := 1); -- must be non-zero + + procedure dgemv + (Trans : access constant Character; + M : Natural := 0; + N : Natural := 0; + Alpha : Double_Precision := 1.0; + A : Double_Precision_Matrix; + Ld_A : Positive; + X : Double_Precision_Vector; + Inc_X : Integer := 1; -- must be non-zero + Beta : Double_Precision := 0.0; + Y : in out Double_Precision_Vector; + Inc_Y : Integer := 1); -- must be non-zero + + procedure cgemv + (Trans : access constant Character; + M : Natural := 0; + N : Natural := 0; + Alpha : Complex := (1.0, 1.0); + A : Complex_Matrix; + Ld_A : Positive; + X : Complex_Vector; + Inc_X : Integer := 1; -- must be non-zero + Beta : Complex := (0.0, 0.0); + Y : in out Complex_Vector; + Inc_Y : Integer := 1); -- must be non-zero + + procedure zgemv + (Trans : access constant Character; + M : Natural := 0; + N : Natural := 0; + Alpha : Double_Complex := (1.0, 1.0); + A : Double_Complex_Matrix; + Ld_A : Positive; + X : Double_Complex_Vector; + Inc_X : Integer := 1; -- must be non-zero + Beta : Double_Complex := (0.0, 0.0); + Y : in out Double_Complex_Vector; + Inc_Y : Integer := 1); -- must be non-zero + + -- BLAS Level 3 + + procedure sgemm + (Trans_A : access constant Character; + Trans_B : access constant Character; + M : Positive; + N : Positive; + K : Positive; + Alpha : Real := 1.0; + A : Real_Matrix; + Ld_A : Integer; + B : Real_Matrix; + Ld_B : Integer; + Beta : Real := 0.0; + C : in out Real_Matrix; + Ld_C : Integer); + + procedure dgemm + (Trans_A : access constant Character; + Trans_B : access constant Character; + M : Positive; + N : Positive; + K : Positive; + Alpha : Double_Precision := 1.0; + A : Double_Precision_Matrix; + Ld_A : Integer; + B : Double_Precision_Matrix; + Ld_B : Integer; + Beta : Double_Precision := 0.0; + C : in out Double_Precision_Matrix; + Ld_C : Integer); + + procedure cgemm + (Trans_A : access constant Character; + Trans_B : access constant Character; + M : Positive; + N : Positive; + K : Positive; + Alpha : Complex := (1.0, 1.0); + A : Complex_Matrix; + Ld_A : Integer; + B : Complex_Matrix; + Ld_B : Integer; + Beta : Complex := (0.0, 0.0); + C : in out Complex_Matrix; + Ld_C : Integer); + + procedure zgemm + (Trans_A : access constant Character; + Trans_B : access constant Character; + M : Positive; + N : Positive; + K : Positive; + Alpha : Double_Complex := (1.0, 1.0); + A : Double_Complex_Matrix; + Ld_A : Integer; + B : Double_Complex_Matrix; + Ld_B : Integer; + Beta : Double_Complex := (0.0, 0.0); + C : in out Double_Complex_Matrix; + Ld_C : Integer); + +private + pragma Import (Fortran, cdotu, "cdotu_"); + pragma Import (Fortran, cgemm, "cgemm_"); + pragma Import (Fortran, cgemv, "cgemv_"); + pragma Import (Fortran, ddot, "ddot_"); + pragma Import (Fortran, dgemm, "dgemm_"); + pragma Import (Fortran, dgemv, "dgemv_"); + pragma Import (Fortran, dnrm2, "dnrm2_"); + pragma Import (Fortran, dznrm2, "dznrm2_"); + pragma Import (Fortran, scnrm2, "scnrm2_"); + pragma Import (Fortran, sdot, "sdot_"); + pragma Import (Fortran, sgemm, "sgemm_"); + pragma Import (Fortran, sgemv, "sgemv_"); + pragma Import (Fortran, snrm2, "snrm2_"); + pragma Import (Fortran, zdotu, "zdotu_"); + pragma Import (Fortran, zgemm, "zgemm_"); + pragma Import (Fortran, zgemv, "zgemv_"); +end Interfaces.Fortran.BLAS; diff --git a/gcc/ada/i-forlap.ads b/gcc/ada/i-forlap.ads new file mode 100644 index 000000000..ebb08abe6 --- /dev/null +++ b/gcc/ada/i-forlap.ads @@ -0,0 +1,414 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- I N T E R F A C E S . F O R T R A N . L A P A C K -- +-- -- +-- S p e c -- +-- -- +-- 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 comment required if non-RM package ??? + +with Interfaces.Fortran.BLAS; +package Interfaces.Fortran.LAPACK is + pragma Pure; + + type Integer_Vector is array (Integer range <>) of Integer; + + Upper : aliased constant Character := 'U'; + Lower : aliased constant Character := 'L'; + + subtype Real_Vector is BLAS.Real_Vector; + subtype Real_Matrix is BLAS.Real_Matrix; + subtype Double_Precision_Vector is BLAS.Double_Precision_Vector; + subtype Double_Precision_Matrix is BLAS.Double_Precision_Matrix; + subtype Complex_Vector is BLAS.Complex_Vector; + subtype Complex_Matrix is BLAS.Complex_Matrix; + subtype Double_Complex_Vector is BLAS.Double_Complex_Vector; + subtype Double_Complex_Matrix is BLAS.Double_Complex_Matrix; + + -- LAPACK Computational Routines + + -- gerfs Refines the solution of a system of linear equations with + -- a general matrix and estimates its error + -- getrf Computes LU factorization of a general m-by-n matrix + -- getri Computes inverse of an LU-factored general matrix + -- square matrix, with multiple right-hand sides + -- getrs Solves a system of linear equations with an LU-factored + -- square matrix, with multiple right-hand sides + -- hetrd Reduces a complex Hermitian matrix to tridiagonal form + -- heevr Computes selected eigenvalues and, optionally, eigenvectors of + -- a Hermitian matrix using the Relatively Robust Representations + -- orgtr Generates the real orthogonal matrix Q determined by sytrd + -- steqr Computes all eigenvalues and eigenvectors of a symmetric or + -- Hermitian matrix reduced to tridiagonal form (QR algorithm) + -- sterf Computes all eigenvalues of a real symmetric + -- tridiagonal matrix using QR algorithm + -- sytrd Reduces a real symmetric matrix to tridiagonal form + + procedure sgetrf + (M : Natural; + N : Natural; + A : in out Real_Matrix; + Ld_A : Positive; + I_Piv : out Integer_Vector; + Info : access Integer); + + procedure dgetrf + (M : Natural; + N : Natural; + A : in out Double_Precision_Matrix; + Ld_A : Positive; + I_Piv : out Integer_Vector; + Info : access Integer); + + procedure cgetrf + (M : Natural; + N : Natural; + A : in out Complex_Matrix; + Ld_A : Positive; + I_Piv : out Integer_Vector; + Info : access Integer); + + procedure zgetrf + (M : Natural; + N : Natural; + A : in out Double_Complex_Matrix; + Ld_A : Positive; + I_Piv : out Integer_Vector; + Info : access Integer); + + procedure sgetri + (N : Natural; + A : in out Real_Matrix; + Ld_A : Positive; + I_Piv : Integer_Vector; + Work : in out Real_Vector; + L_Work : Integer; + Info : access Integer); + + procedure dgetri + (N : Natural; + A : in out Double_Precision_Matrix; + Ld_A : Positive; + I_Piv : Integer_Vector; + Work : in out Double_Precision_Vector; + L_Work : Integer; + Info : access Integer); + + procedure cgetri + (N : Natural; + A : in out Complex_Matrix; + Ld_A : Positive; + I_Piv : Integer_Vector; + Work : in out Complex_Vector; + L_Work : Integer; + Info : access Integer); + + procedure zgetri + (N : Natural; + A : in out Double_Complex_Matrix; + Ld_A : Positive; + I_Piv : Integer_Vector; + Work : in out Double_Complex_Vector; + L_Work : Integer; + Info : access Integer); + + procedure sgetrs + (Trans : access constant Character; + N : Natural; + N_Rhs : Natural; + A : Real_Matrix; + Ld_A : Positive; + I_Piv : Integer_Vector; + B : in out Real_Matrix; + Ld_B : Positive; + Info : access Integer); + + procedure dgetrs + (Trans : access constant Character; + N : Natural; + N_Rhs : Natural; + A : Double_Precision_Matrix; + Ld_A : Positive; + I_Piv : Integer_Vector; + B : in out Double_Precision_Matrix; + Ld_B : Positive; + Info : access Integer); + + procedure cgetrs + (Trans : access constant Character; + N : Natural; + N_Rhs : Natural; + A : Complex_Matrix; + Ld_A : Positive; + I_Piv : Integer_Vector; + B : in out Complex_Matrix; + Ld_B : Positive; + Info : access Integer); + + procedure zgetrs + (Trans : access constant Character; + N : Natural; + N_Rhs : Natural; + A : Double_Complex_Matrix; + Ld_A : Positive; + I_Piv : Integer_Vector; + B : in out Double_Complex_Matrix; + Ld_B : Positive; + Info : access Integer); + + procedure cheevr + (Job_Z : access constant Character; + Rng : access constant Character; + Uplo : access constant Character; + N : Natural; + A : in out Complex_Matrix; + Ld_A : Positive; + Vl, Vu : Real := 0.0; + Il, Iu : Integer := 1; + Abs_Tol : Real := 0.0; + M : out Integer; + W : out Real_Vector; + Z : out Complex_Matrix; + Ld_Z : Positive; + I_Supp_Z : out Integer_Vector; + Work : out Complex_Vector; + L_Work : Integer; + R_Work : out Real_Vector; + LR_Work : Integer; + I_Work : out Integer_Vector; + LI_Work : Integer; + Info : access Integer); + + procedure zheevr + (Job_Z : access constant Character; + Rng : access constant Character; + Uplo : access constant Character; + N : Natural; + A : in out Double_Complex_Matrix; + Ld_A : Positive; + Vl, Vu : Double_Precision := 0.0; + Il, Iu : Integer := 1; + Abs_Tol : Double_Precision := 0.0; + M : out Integer; + W : out Double_Precision_Vector; + Z : out Double_Complex_Matrix; + Ld_Z : Positive; + I_Supp_Z : out Integer_Vector; + Work : out Double_Complex_Vector; + L_Work : Integer; + R_Work : out Double_Precision_Vector; + LR_Work : Integer; + I_Work : out Integer_Vector; + LI_Work : Integer; + Info : access Integer); + + procedure chetrd + (Uplo : access constant Character; + N : Natural; + A : in out Complex_Matrix; + Ld_A : Positive; + D : out Real_Vector; + E : out Real_Vector; + Tau : out Complex_Vector; + Work : out Complex_Vector; + L_Work : Integer; + Info : access Integer); + + procedure zhetrd + (Uplo : access constant Character; + N : Natural; + A : in out Double_Complex_Matrix; + Ld_A : Positive; + D : out Double_Precision_Vector; + E : out Double_Precision_Vector; + Tau : out Double_Complex_Vector; + Work : out Double_Complex_Vector; + L_Work : Integer; + Info : access Integer); + + procedure ssytrd + (Uplo : access constant Character; + N : Natural; + A : in out Real_Matrix; + Ld_A : Positive; + D : out Real_Vector; + E : out Real_Vector; + Tau : out Real_Vector; + Work : out Real_Vector; + L_Work : Integer; + Info : access Integer); + + procedure dsytrd + (Uplo : access constant Character; + N : Natural; + A : in out Double_Precision_Matrix; + Ld_A : Positive; + D : out Double_Precision_Vector; + E : out Double_Precision_Vector; + Tau : out Double_Precision_Vector; + Work : out Double_Precision_Vector; + L_Work : Integer; + Info : access Integer); + + procedure ssterf + (N : Natural; + D : in out Real_Vector; + E : in out Real_Vector; + Info : access Integer); + + procedure dsterf + (N : Natural; + D : in out Double_Precision_Vector; + E : in out Double_Precision_Vector; + Info : access Integer); + + procedure sorgtr + (Uplo : access constant Character; + N : Natural; + A : in out Real_Matrix; + Ld_A : Positive; + Tau : Real_Vector; + Work : out Real_Vector; + L_Work : Integer; + Info : access Integer); + + procedure dorgtr + (Uplo : access constant Character; + N : Natural; + A : in out Double_Precision_Matrix; + Ld_A : Positive; + Tau : Double_Precision_Vector; + Work : out Double_Precision_Vector; + L_Work : Integer; + Info : access Integer); + + procedure sstebz + (Rng : access constant Character; + Order : access constant Character; + N : Natural; + Vl, Vu : Real := 0.0; + Il, Iu : Integer := 1; + Abs_Tol : Real := 0.0; + D : Real_Vector; + E : Real_Vector; + M : out Natural; + N_Split : out Natural; + W : out Real_Vector; + I_Block : out Integer_Vector; + I_Split : out Integer_Vector; + Work : out Real_Vector; + I_Work : out Integer_Vector; + Info : access Integer); + + procedure dstebz + (Rng : access constant Character; + Order : access constant Character; + N : Natural; + Vl, Vu : Double_Precision := 0.0; + Il, Iu : Integer := 1; + Abs_Tol : Double_Precision := 0.0; + D : Double_Precision_Vector; + E : Double_Precision_Vector; + M : out Natural; + N_Split : out Natural; + W : out Double_Precision_Vector; + I_Block : out Integer_Vector; + I_Split : out Integer_Vector; + Work : out Double_Precision_Vector; + I_Work : out Integer_Vector; + Info : access Integer); + + procedure ssteqr + (Comp_Z : access constant Character; + N : Natural; + D : in out Real_Vector; + E : in out Real_Vector; + Z : in out Real_Matrix; + Ld_Z : Positive; + Work : out Real_Vector; + Info : access Integer); + + procedure dsteqr + (Comp_Z : access constant Character; + N : Natural; + D : in out Double_Precision_Vector; + E : in out Double_Precision_Vector; + Z : in out Double_Precision_Matrix; + Ld_Z : Positive; + Work : out Double_Precision_Vector; + Info : access Integer); + + procedure csteqr + (Comp_Z : access constant Character; + N : Natural; + D : in out Real_Vector; + E : in out Real_Vector; + Z : in out Complex_Matrix; + Ld_Z : Positive; + Work : out Real_Vector; + Info : access Integer); + + procedure zsteqr + (Comp_Z : access constant Character; + N : Natural; + D : in out Double_Precision_Vector; + E : in out Double_Precision_Vector; + Z : in out Double_Complex_Matrix; + Ld_Z : Positive; + Work : out Double_Precision_Vector; + Info : access Integer); + +private + pragma Import (Fortran, csteqr, "csteqr_"); + pragma Import (Fortran, cgetrf, "cgetrf_"); + pragma Import (Fortran, cgetri, "cgetri_"); + pragma Import (Fortran, cgetrs, "cgetrs_"); + pragma Import (Fortran, cheevr, "cheevr_"); + pragma Import (Fortran, chetrd, "chetrd_"); + pragma Import (Fortran, dgetrf, "dgetrf_"); + pragma Import (Fortran, dgetri, "dgetri_"); + pragma Import (Fortran, dgetrs, "dgetrs_"); + pragma Import (Fortran, dsytrd, "dsytrd_"); + pragma Import (Fortran, dstebz, "dstebz_"); + pragma Import (Fortran, dsterf, "dsterf_"); + pragma Import (Fortran, dorgtr, "dorgtr_"); + pragma Import (Fortran, dsteqr, "dsteqr_"); + pragma Import (Fortran, sgetrf, "sgetrf_"); + pragma Import (Fortran, sgetri, "sgetri_"); + pragma Import (Fortran, sgetrs, "sgetrs_"); + pragma Import (Fortran, sorgtr, "sorgtr_"); + pragma Import (Fortran, sstebz, "sstebz_"); + pragma Import (Fortran, ssterf, "ssterf_"); + pragma Import (Fortran, ssteqr, "ssteqr_"); + pragma Import (Fortran, ssytrd, "ssytrd_"); + pragma Import (Fortran, zgetrf, "zgetrf_"); + pragma Import (Fortran, zgetri, "zgetri_"); + pragma Import (Fortran, zgetrs, "zgetrs_"); + pragma Import (Fortran, zheevr, "zheevr_"); + pragma Import (Fortran, zhetrd, "zhetrd_"); + pragma Import (Fortran, zsteqr, "zsteqr_"); +end Interfaces.Fortran.LAPACK; diff --git a/gcc/ada/i-fortra.adb b/gcc/ada/i-fortra.adb new file mode 100644 index 000000000..532089d71 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Interfaces.Fortran is + + ------------ + -- To_Ada -- + ------------ + + -- Single character case + + function To_Ada (Item : Character_Set) return Character is + begin + return Character (Item); + end To_Ada; + + -- String case (function returning converted result) + + function To_Ada (Item : Fortran_Character) return String is + T : String (1 .. Item'Length); + + begin + for J in T'Range loop + T (J) := Character (Item (J - 1 + Item'First)); + end loop; + + return T; + end To_Ada; + + -- String case (procedure copying converted string to given buffer) + + procedure To_Ada + (Item : Fortran_Character; + Target : out String; + Last : out Natural) + is + begin + if Item'Length = 0 then + Last := 0; + return; + + elsif Target'Length = 0 then + raise Constraint_Error; + + else + Last := Target'First - 1; + + for J in Item'Range loop + Last := Last + 1; + + if Last > Target'Last then + raise Constraint_Error; + else + Target (Last) := Character (Item (J)); + end if; + end loop; + end if; + end To_Ada; + + ---------------- + -- To_Fortran -- + ---------------- + + -- Character case + + function To_Fortran (Item : Character) return Character_Set is + begin + return Character_Set (Item); + end To_Fortran; + + -- String case (function returning converted result) + + function To_Fortran (Item : String) return Fortran_Character is + T : Fortran_Character (1 .. Item'Length); + + begin + for J in T'Range loop + T (J) := Character_Set (Item (J - 1 + Item'First)); + end loop; + + return T; + end To_Fortran; + + -- String case (procedure copying converted string to given buffer) + + procedure To_Fortran + (Item : String; + Target : out Fortran_Character; + Last : out Natural) + is + begin + if Item'Length = 0 then + Last := 0; + return; + + elsif Target'Length = 0 then + raise Constraint_Error; + + else + Last := Target'First - 1; + + for J in Item'Range loop + Last := Last + 1; + + if Last > Target'Last then + raise Constraint_Error; + else + Target (Last) := Character_Set (Item (J)); + end if; + end loop; + end if; + end To_Fortran; + +end Interfaces.Fortran; diff --git a/gcc/ada/i-fortra.ads b/gcc/ada/i-fortra.ads new file mode 100644 index 000000000..992eb2863 --- /dev/null +++ b/gcc/ada/i-fortra.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . F O R T R A N -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; +pragma Elaborate_All (Ada.Numerics.Generic_Complex_Types); + +package Interfaces.Fortran is + pragma Pure; + + type Fortran_Integer is new Integer; + type Real is new Float; + type Double_Precision is new Long_Float; + + type Logical is new Boolean; + for Logical'Size use Integer'Size; + pragma Convention (Fortran, Logical); + -- As required by Fortran standard, stand alone logical allocates same + -- space as integer (but what about the array case???). The convention + -- is important, since in Fortran, Booleans have zero/non-zero semantics + -- for False/True, and the pragma Convention (Fortran) activates the + -- special handling required in this case. + + package Single_Precision_Complex_Types is + new Ada.Numerics.Generic_Complex_Types (Real); + + package Double_Precision_Complex_Types is + new Ada.Numerics.Generic_Complex_Types (Double_Precision); + + type Complex is new Single_Precision_Complex_Types.Complex; + + type Double_Complex is new Double_Precision_Complex_Types.Complex; + + subtype Imaginary is Single_Precision_Complex_Types.Imaginary; + i : Imaginary renames Single_Precision_Complex_Types.i; + j : Imaginary renames Single_Precision_Complex_Types.j; + + type Character_Set is new Character; + + type Fortran_Character is array (Positive range <>) of Character_Set; + + function To_Fortran (Item : Character) return Character_Set; + function To_Ada (Item : Character_Set) return Character; + + function To_Fortran (Item : String) return Fortran_Character; + function To_Ada (Item : Fortran_Character) return String; + + procedure To_Fortran + (Item : String; + Target : out Fortran_Character; + Last : out Natural); + + procedure To_Ada + (Item : Fortran_Character; + Target : out String; + Last : out Natural); + +end Interfaces.Fortran; diff --git a/gcc/ada/i-pacdec.adb b/gcc/ada/i-pacdec.adb new file mode 100644 index 000000000..bb6c21a07 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..ce3f0f2e6 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 new file mode 100644 index 000000000..4d480e051 --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..dc6954696 --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..506966e13 --- /dev/null +++ b/gcc/ada/i-vxwork-x86.ads @@ -0,0 +1,221 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the 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 the 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 new file mode 100644 index 000000000..902f9e7ea --- /dev/null +++ b/gcc/ada/i-vxwork.ads @@ -0,0 +1,215 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This 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 the target + -- -- 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/impunit.adb b/gcc/ada/impunit.adb new file mode 100644 index 000000000..85ae7055f --- /dev/null +++ b/gcc/ada/impunit.adb @@ -0,0 +1,752 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I M P U N I T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2000-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Errout; use Errout; +with Sinfo; use Sinfo; +with Fname.UF; use Fname.UF; +with Lib; use Lib; +with Namet; use Namet; +with Uname; use Uname; + +-- Note: this package body is used by GPS and GNATBench to supply a list of +-- entries for help on available library routines. + +package body Impunit is + + subtype File_Name_8 is String (1 .. 8); + type File_List is array (Nat range <>) of File_Name_8; + + ------------------ + -- Ada 95 Units -- + ------------------ + + -- The following is a giant string list containing the names of all non- + -- implementation internal files, i.e. the complete list of files for + -- internal units which a program may legitimately WITH when operating in + -- either Ada 95 or Ada 05 mode. + + -- Note that this list should match the list of units documented in the + -- "GNAT Library" section of the GNAT Reference Manual. A unit listed here + -- must either be documented in that section or described in the Ada RM. + + Non_Imp_File_Names_95 : constant File_List := ( + + ------------------------------------------------------ + -- Ada Hierarchy Units from Ada-95 Reference Manual -- + ------------------------------------------------------ + + "a-astaco", -- Ada.Asynchronous_Task_Control + "a-calend", -- Ada.Calendar + "a-chahan", -- Ada.Characters.Handling + "a-charac", -- Ada.Characters + "a-chlat1", -- Ada.Characters.Latin_1 + "a-comlin", -- Ada.Command_Line + "a-decima", -- Ada.Decimal + "a-direio", -- Ada.Direct_IO + "a-dynpri", -- Ada.Dynamic_Priorities + "a-except", -- Ada.Exceptions + "a-finali", -- Ada.Finalization + "a-flteio", -- Ada.Float_Text_IO + "a-fwteio", -- Ada.Float_Wide_Text_IO + "a-inteio", -- Ada.Integer_Text_IO + "a-interr", -- Ada.Interrupts + "a-intnam", -- Ada.Interrupts.Names + "a-ioexce", -- Ada.IO_Exceptions + "a-iwteio", -- Ada.Integer_Wide_Text_IO + "a-ncelfu", -- Ada.Numerics.Complex_Elementary_Functions + "a-ngcefu", -- Ada.Numerics.Generic_Complex_Elementary_Functions + "a-ngcoty", -- Ada.Numerics.Generic_Complex_Types + "a-ngelfu", -- Ada.Numerics.Generic_Elementary_Functions + "a-nucoty", -- Ada.Numerics.Complex_Types + "a-nudira", -- Ada.Numerics.Discrete_Random + "a-nuelfu", -- Ada.Numerics.Elementary_Functions + "a-nuflra", -- Ada.Numerics.Float_Random + "a-numeri", -- Ada.Numerics + "a-reatim", -- Ada.Real_Time + "a-sequio", -- Ada.Sequential_IO + "a-stmaco", -- Ada.Strings.Maps.Constants + "a-storio", -- Ada.Storage_IO + "a-strbou", -- Ada.Strings.Bounded + "a-stream", -- Ada.Streams + "a-strfix", -- Ada.Strings.Fixed + "a-string", -- Ada.Strings + "a-strmap", -- Ada.Strings.Maps + "a-strunb", -- Ada.Strings.Unbounded + "a-ststio", -- Ada.Streams.Stream_IO + "a-stwibo", -- Ada.Strings.Wide_Bounded + "a-stwifi", -- Ada.Strings.Wide_Fixed + "a-stwima", -- Ada.Strings.Wide_Maps + "a-stwiun", -- Ada.Strings.Wide_Unbounded + "a-swmwco", -- Ada.Strings.Wide_Maps.Wide_Constants + "a-sytaco", -- Ada.Synchronous_Task_Control + "a-tags ", -- Ada.Tags + "a-tasatt", -- Ada.Task_Attributes + "a-taside", -- Ada.Task_Identification + "a-teioed", -- Ada.Text_IO.Editing + "a-textio", -- Ada.Text_IO + "a-ticoio", -- Ada.Text_IO.Complex_IO + "a-titest", -- Ada.Text_IO.Text_Streams + "a-unccon", -- Ada.Unchecked_Conversion + "a-uncdea", -- Ada.Unchecked_Deallocation + "a-witeio", -- Ada.Wide_Text_IO + "a-wtcoio", -- Ada.Wide_Text_IO.Complex_IO + "a-wtedit", -- Ada.Wide_Text_IO.Editing + "a-wttest", -- Ada.Wide_Text_IO.Text_Streams + + ------------------------------------------------- + -- RM Required Additions to Ada for GNAT Types -- + ------------------------------------------------- + + "a-lfteio", -- Ada.Long_Float_Text_IO + "a-lfwtio", -- Ada.Long_Float_Wide_Text_IO + "a-liteio", -- Ada.Long_Integer_Text_IO + "a-liwtio", -- Ada.Long_Integer_Wide_Text_IO + "a-llftio", -- Ada.Long_Long_Float_Text_IO + "a-llfwti", -- Ada.Long_Long_Float_Wide_Text_IO + "a-llitio", -- Ada.Long_Long_Integer_Text_IO + "a-lliwti", -- Ada.Long_Long_Integer_Wide_Text_IO + "a-nlcefu", -- Ada.Long_Complex_Elementary_Functions + "a-nlcoty", -- Ada.Numerics.Long_Complex_Types + "a-nlelfu", -- Ada.Numerics.Long_Elementary_Functions + "a-nllcef", -- Ada.Long_Long_Complex_Elementary_Functions + "a-nllefu", -- Ada.Numerics.Long_Long_Elementary_Functions + "a-nllcty", -- Ada.Numerics.Long_Long_Complex_Types + "a-nscefu", -- Ada.Short_Complex_Elementary_Functions + "a-nscoty", -- Ada.Numerics.Short_Complex_Types + "a-nselfu", -- Ada.Numerics.Short_Elementary_Functions + "a-sfteio", -- Ada.Short_Float_Text_IO + "a-sfwtio", -- Ada.Short_Float_Wide_Text_IO + "a-siteio", -- Ada.Short_Integer_Text_IO + "a-siwtio", -- Ada.Short_Integer_Wide_Text_IO + "a-ssitio", -- Ada.Short_Short_Integer_Text_IO + "a-ssiwti", -- Ada.Short_Short_Integer_Wide_Text_IO + + ----------------------------------- + -- GNAT Defined Additions to Ada -- + ----------------------------------- + + "a-calcon", -- Ada.Calendar.Conversions + "a-chlat9", -- Ada.Characters.Latin_9 + "a-clrefi", -- Ada.Command_Line.Response_File + "a-colien", -- Ada.Command_Line.Environment + "a-colire", -- Ada.Command_Line.Remove + "a-cwila1", -- Ada.Characters.Wide_Latin_1 + "a-cwila9", -- Ada.Characters.Wide_Latin_9 + "a-diocst", -- Ada.Direct_IO.C_Streams + "a-einuoc", -- Ada.Exceptions.Is_Null_Occurrence + "a-elchha", -- Ada.Exceptions.Last_Chance_Handler + "a-exctra", -- Ada.Exceptions.Traceback + "a-siocst", -- Ada.Sequential_IO.C_Streams + "a-ssicst", -- Ada.Streams.Stream_IO.C_Streams + "a-suteio", -- Ada.Strings.Unbounded.Text_IO + "a-swuwti", -- Ada.Strings.Wide_Unbounded.Wide_Text_IO + "a-tiocst", -- Ada.Text_IO.C_Streams + "a-wtcstr", -- Ada.Wide_Text_IO.C_Streams + + -- Note: strictly the next two should be Ada 2005 units, but it seems + -- harmless (and useful) to make then available in Ada 95 mode, since + -- they only deal with Wide_Character, not Wide_Wide_Character. + + "a-wichun", -- Ada.Wide_Characters.Unicode + "a-widcha", -- Ada.Wide_Characters + + -- Note: strictly the following should be Ada 2012 units, but it seems + -- harmless (and useful) to make then available in Ada 95 mode, since + -- they do not deal with Wide_Wide_Character. + + "a-wichha", -- Ada.Wide_Characters.Handling + "a-stuten", -- Ada.Strings.UTF_Encoding + "a-suenco", -- Ada.Strings.UTF_Encoding.Conversions + "a-suenst", -- Ada.Strings.UTF_Encoding.Strings + "a-suewst", -- Ada.Strings.UTF_Encoding.Wide_Strings + + --------------------------- + -- GNAT Special IO Units -- + --------------------------- + + -- As further explained elsewhere (see Sem_Ch10), the internal packages of + -- Text_IO and Wide_Text_IO are actually implemented as separate children, + -- but this fact is intended to be hidden from the user completely. Any + -- attempt to WITH one of these units will be diagnosed as an error later + -- on, but for now we do not consider these internal implementation units + -- (if we did, then we would get a junk warning which would be confusing + -- and unnecessary, given that we generate a clear error message). + + "a-tideio", -- Ada.Text_IO.Decimal_IO + "a-tienio", -- Ada.Text_IO.Enumeration_IO + "a-tifiio", -- Ada.Text_IO.Fixed_IO + "a-tiflio", -- Ada.Text_IO.Float_IO + "a-tiinio", -- Ada.Text_IO.Integer_IO + "a-tiinio", -- Ada.Text_IO.Integer_IO + "a-timoio", -- Ada.Text_IO.Modular_IO + "a-wtdeio", -- Ada.Wide_Text_IO.Decimal_IO + "a-wtenio", -- Ada.Wide_Text_IO.Enumeration_IO + "a-wtfiio", -- Ada.Wide_Text_IO.Fixed_IO + "a-wtflio", -- Ada.Wide_Text_IO.Float_IO + "a-wtinio", -- Ada.Wide_Text_IO.Integer_IO + "a-wtmoio", -- Ada.Wide_Text_IO.Modular_IO + + ------------------------ + -- GNAT Library Units -- + ------------------------ + + "g-altive", -- GNAT.Altivec + "g-altcon", -- GNAT.Altivec.Conversions + "g-alveop", -- GNAT.Altivec.Vector_Operations + "g-alvety", -- GNAT.Altivec.Vector_Types + "g-alvevi", -- GNAT.Altivec.Vector_Views + "g-arrspl", -- GNAT.Array_Split + "g-awk ", -- GNAT.AWK + "g-boubuf", -- GNAT.Bounded_Buffers + "g-boumai", -- GNAT.Bounded_Mailboxes + "g-bubsor", -- GNAT.Bubble_Sort + "g-busora", -- GNAT.Bubble_Sort_A + "g-busorg", -- GNAT.Bubble_Sort_G + "g-byorma", -- GNAT.Byte_Order_Mark + "g-bytswa", -- GNAT.Byte_Swapping + "g-calend", -- GNAT.Calendar + "g-catiio", -- GNAT.Calendar.Time_IO + "g-casuti", -- GNAT.Case_Util + "g-cgi ", -- GNAT.CGI + "g-cgicoo", -- GNAT.CGI.Cookie + "g-cgideb", -- GNAT.CGI.Debug + "g-comlin", -- GNAT.Command_Line + "g-comver", -- GNAT.Compiler_Version + "g-crc32 ", -- GNAT.CRC32 + "g-ctrl_c", -- GNAT.Ctrl_C + "g-curexc", -- GNAT.Current_Exception + "g-debpoo", -- GNAT.Debug_Pools + "g-debuti", -- GNAT.Debug_Utilities + "g-decstr", -- GNAT.Decode_String + "g-deutst", -- GNAT.Decode_UTF8_String + "g-dirope", -- GNAT.Directory_Operations + "g-diopit", -- GNAT.Directory_Operations.Iteration + "g-dynhta", -- GNAT.Dynamic_HTables + "g-dyntab", -- GNAT.Dynamic_Tables + "g-encstr", -- GNAT.Encode_String + "g-enutst", -- GNAT.Encode_UTF8_String + "g-excact", -- GNAT.Exception_Actions + "g-except", -- GNAT.Exceptions + "g-exctra", -- GNAT.Exception_Traces + "g-expect", -- GNAT.Expect + "g-flocon", -- GNAT.Float_Control + "g-heasor", -- GNAT.Heap_Sort + "g-hesora", -- GNAT.Heap_Sort_A + "g-hesorg", -- GNAT.Heap_Sort_G + "g-htable", -- GNAT.Htable + "g-io ", -- GNAT.IO + "g-io_aux", -- GNAT.IO_Aux + "g-locfil", -- GNAT.Lock_Files + "g-mbdira", -- GNAT.MBBS_Discrete_Random + "g-mbflra", -- GNAT.MBBS_Float_Random + "g-md5 ", -- GNAT.MD5 + "g-memdum", -- GNAT.Memory_Dump + "g-moreex", -- GNAT.Most_Recent_Exception + "g-os_lib", -- GNAT.Os_Lib + "g-pehage", -- GNAT.Perfect_Hash_Generators + "g-rannum", -- GNAT.Random_Numbers + "g-regexp", -- GNAT.Regexp + "g-regist", -- GNAT.Registry + "g-regpat", -- GNAT.Regpat + "g-semaph", -- GNAT.Semaphores + "g-sercom", -- GNAT.Serial_Communications + "g-sestin", -- GNAT.Secondary_Stack_Info + "g-sha1 ", -- GNAT.SHA1 + "g-sha224", -- GNAT.SHA224 + "g-sha256", -- GNAT.SHA256 + "g-sha384", -- GNAT.SHA384 + "g-sha512", -- GNAT.SHA512 + "g-signal", -- GNAT.Signals + "g-socket", -- GNAT.Sockets + "g-souinf", -- GNAT.Source_Info + "g-speche", -- GNAT.Spell_Checker + "g-spchge", -- GNAT.Spell_Checker_Generic + "g-spitbo", -- GNAT.Spitbol + "g-spipat", -- GNAT.Spitbol.Patterns + "g-sptabo", -- GNAT.Spitbol.Table_Boolean + "g-sptain", -- GNAT.Spitbol.Table_Integer + "g-sptavs", -- GNAT.Spitbol.Table_Vstring + "g-string", -- GNAT.Strings + "g-strspl", -- GNAT.String_Split + "g-sse ", -- GNAT.SSE + "g-ssvety", -- GNAT.SSE.Vector_Types + "g-table ", -- GNAT.Table + "g-tasloc", -- GNAT.Task_Lock + "g-thread", -- GNAT.Threads + "g-timsta", -- GNAT.Time_Stamp + "g-traceb", -- GNAT.Traceback + "g-trasym", -- GNAT.Traceback.Symbolic + "g-utf_32", -- GNAT.UTF_32 + "g-u3spch", -- GNAT.UTF_32_Spelling_Checker + "g-wispch", -- GNAT.Wide_Spelling_Checker + "g-wistsp", -- GNAT.Wide_String_Split + + ----------------------------------------------------- + -- Interface Hierarchy Units from Reference Manual -- + ----------------------------------------------------- + + "i-c ", -- Interfaces.C + "i-cobol ", -- Interfaces.Cobol + "i-cpoint", -- Interfaces.C.Pointers + "i-cstrin", -- Interfaces.C.Strings + "i-fortra", -- Interfaces.Fortran + + ------------------------------------------ + -- GNAT Defined Additions to Interfaces -- + ------------------------------------------ + + "i-cexten", -- Interfaces.C.Extensions + "i-cil ", -- Interfaces.CIL + "i-cilobj", -- Interfaces.CIL.Object + "i-cpp ", -- Interfaces.CPP + "i-cstrea", -- Interfaces.C.Streams + "i-java ", -- Interfaces.Java + "i-javjni", -- Interfaces.Java.JNI + "i-pacdec", -- Interfaces.Packed_Decimal + "i-vxwoio", -- Interfaces.VxWorks.IO + "i-vxwork", -- Interfaces.VxWorks + + -------------------------------------------------- + -- System Hierarchy Units from Reference Manual -- + -------------------------------------------------- + + "s-atacco", -- System.Address_To_Access_Conversions + "s-maccod", -- System.Machine_Code + "s-rpc ", -- System.Rpc + "s-stoele", -- System.Storage_Elements + "s-stopoo", -- System.Storage_Pools + + -------------------------------------- + -- GNAT Defined Additions to System -- + -------------------------------------- + + "s-addima", -- System.Address_Image + "s-assert", -- System.Assertions + "s-memory", -- System.Memory + "s-parint", -- System.Partition_Interface + "s-pooglo", -- System.Pool_Global + "s-pooloc", -- System.Pool_Local + "s-restri", -- System.Restrictions + "s-rident", -- System.Rident + "s-ststop", -- System.Strings.Stream_Ops + "s-tasinf", -- System.Task_Info + "s-wchcnv", -- System.Wch_Cnv + "s-wchcon"); -- System.Wch_Con + + -------------------- + -- Ada 2005 Units -- + -------------------- + + -- The following units should be used only in Ada 05 mode + + Non_Imp_File_Names_05 : constant File_List := ( + + -------------------------------------------------------- + -- Ada Hierarchy Units from Ada 2005 Reference Manual -- + -------------------------------------------------------- + + "a-assert", -- Ada.Assertions + "a-calari", -- Ada.Calendar.Arithmetic + "a-calfor", -- Ada.Calendar.Formatting + "a-catizo", -- Ada.Calendar.Time_Zones + "a-cdlili", -- Ada.Containers.Doubly_Linked_Lists + "a-cgarso", -- Ada.Containers.Generic_Array_Sort + "a-cgcaso", -- Ada.Containers.Generic_Constrained_Array_Sort + "a-chacon", -- Ada.Characters.Conversions + "a-cidlli", -- Ada.Containers.Indefinite_Doubly_Linked_Lists + "a-cihama", -- Ada.Containers.Indefinite_Hashed_Maps + "a-cihase", -- Ada.Containers.Indefinite_Hashed_Sets + "a-ciorma", -- Ada.Containers.Indefinite_Ordered_Maps + "a-ciorse", -- Ada.Containers.Indefinite_Ordered_Sets + "a-cohama", -- Ada.Containers.Hashed_Maps + "a-cohase", -- Ada.Containers.Hashed_Sets + "a-coinve", -- Ada.Containers.Indefinite_Vectors + "a-contai", -- Ada.Containers + "a-convec", -- Ada.Containers.Vectors + "a-coorma", -- Ada.Containers.Ordered_Maps + "a-coorse", -- Ada.Containers.Ordered_Sets + "a-coteio", -- Ada.Complex_Text_IO + "a-direct", -- Ada.Directories + "a-diroro", -- Ada.Dispatching.Round_Robin + "a-disedf", -- Ada.Dispatching.EDF + "a-dispat", -- Ada.Dispatching + "a-envvar", -- Ada.Environment_Variables + "a-etgrbu", -- Ada.Execution_Time.Group_Budgets + "a-exetim", -- Ada.Execution_Time + "a-extiti", -- Ada.Execution_Time.Timers + "a-izteio", -- Ada.Integer_Wide_Wide_Text_IO + "a-rttiev", -- Ada.Real_Time.Timing_Events + "a-ngcoar", -- Ada.Numerics.Generic_Complex_Arrays + "a-ngrear", -- Ada.Numerics.Generic_Real_Arrays + "a-nucoar", -- Ada.Numerics.Complex_Arrays + "a-nurear", -- Ada.Numerics.Real_Arrays + "a-stboha", -- Ada.Strings.Bounded.Hash + "a-stfiha", -- Ada.Strings.Fixed.Hash + "a-strhas", -- Ada.Strings.Hash + "a-stunha", -- Ada.Strings.Unbounded.Hash + "a-stwiha", -- Ada.Strings.Wide_Hash + "a-stzbou", -- Ada.Strings.Wide_Wide_Bounded + "a-stzfix", -- Ada.Strings.Wide_Wide_Fixed + "a-stzhas", -- Ada.Strings.Wide_Wide_Hash + "a-stzmap", -- Ada.Strings.Wide_Wide_Maps + "a-stzunb", -- Ada.Strings.Wide_Wide_Unbounded + "a-swbwha", -- Ada.Strings.Wide_Bounded.Wide_Hash + "a-swfwha", -- Ada.Strings.Wide_Fixed.Wide_Hash + "a-swuwha", -- Ada.Strings.Wide_Unbounded.Wide_Hash + "a-szbzha", -- Ada.Strings.Wide_Wide_Bounded.Wide_Wide_Hash + "a-szfzha", -- Ada.Strings.Wide_Wide_Fixed.Wide_Wide_Hash + "a-szmzco", -- Ada.Strings.Wide_Wide_Maps.Wide_Wide_Constants + "a-szuzha", -- Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash + "a-taster", -- Ada.Task_Termination + "a-tgdico", -- Ada.Tags.Generic_Dispatching_Constructor + "a-tiboio", -- Ada.Text_IO.Bounded_IO + "a-tiunio", -- Ada.Text_IO.Unbounded_IO + "a-wichun", -- Ada.Wide_Characters.Unicode + "a-wwboio", -- Ada.Wide_Text_IO.Wide_Bounded_IO + "a-wwunio", -- Ada.Wide_Text_IO.Wide_Unbounded_IO + "a-zchara", -- Ada.Wide_Wide_Characters + "a-zchhan", -- Ada.Wide_Wide_Characters.Handling + "a-ztcoio", -- Ada.Wide_Wide_Text_IO.Complex_IO + "a-ztedit", -- Ada.Wide_Wide_Text_IO.Editing + "a-zttest", -- Ada.Wide_Wide_Text_IO.Text_Streams + "a-ztexio", -- Ada.Wide_Wide_Text_IO + "a-zzboio", -- Ada.Wide_Wide_Text_IO.Wide_Wide_Bounded_IO + "a-zzunio", -- Ada.Wide_Wide_Text_IO.Wide_Wide_Unbounded_IO + + ------------------------------------------------------ + -- RM Required Additions to Ada 2005 for GNAT Types -- + ------------------------------------------------------ + + "a-lcteio", -- Ada.Long_Complex_Text_IO + "a-lfztio", -- Ada.Long_Float_Wide_Wide_Text_IO + "a-liztio", -- Ada.Long_Integer_Wide_Wide_Text_IO + "a-llctio", -- Ada.Long_Long_Complex_Text_IO + "a-llfzti", -- Ada.Long_Long_Float_Wide_Wide_Text_IO + "a-llizti", -- Ada.Long_Long_Integer_Wide_Wide_Text_IO + "a-nlcoar", -- Ada.Numerics.Long_Complex_Arrays + "a-nllcar", -- Ada.Numerics.Long_Long_Complex_Arrays + "a-nllrar", -- Ada.Numerics.Long_Long_Real_Arrays + "a-nlrear", -- Ada.Numerics.Long_Real_Arrays + "a-scteio", -- Ada.Short_Complex_Text_IO + "a-sfztio", -- Ada.Short_Float_Wide_Wide_Text_IO + "a-siztio", -- Ada.Short_Integer_Wide_Wide_Text_IO + "a-ssizti", -- Ada.Short_Short_Integer_Wide_Wide_Text_IO + "a-ztcstr", -- Ada.Wide_Wide_Text_IO.C_Streams + + ---------------------------------------- + -- GNAT Defined Additions to Ada 2005 -- + ---------------------------------------- + + "a-cgaaso", -- Ada.Containers.Generic_Anonymous_Array_Sort + "a-chzla1", -- Ada.Characters.Wide_Wide_Latin_1 + "a-chzla9", -- Ada.Characters.Wide_Wide_Latin_9 + "a-ciormu", -- Ada.Containers.Indefinite_Ordered_Multisets + "a-coormu", -- Ada.Containers.Ordered_Multisets + "a-crdlli", -- Ada.Containers.Restricted_Doubly_Linked_Lists + "a-secain", -- Ada.Strings.Equal_Case_Insensitive + "a-shcain", -- Ada.Strings.Hash_Case_Insensitive + "a-slcain", -- Ada.Strings.Less_Case_Insensitive + "a-szuzti", -- Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO + "a-zchuni", -- Ada.Wide_Wide_Characters.Unicode + + -- Note: strictly the following should be Ada 2012 units, but it seems + -- harmless (and useful) to make then available in Ada 2005 mode. + + "a-suezst", -- Ada.Strings.UTF_Encoding.Wide_Wide_Strings + + --------------------------- + -- GNAT Special IO Units -- + --------------------------- + + -- See Ada 95 section for further information. These packages are for the + -- implementation of the Wide_Wide_Text_IO generic packages. + + "a-ztdeio", -- Ada.Wide_Wide_Text_IO.Decimal_IO + "a-ztenio", -- Ada.Wide_Wide_Text_IO.Enumeration_IO + "a-ztfiio", -- Ada.Wide_Wide_Text_IO.Fixed_IO + "a-ztflio", -- Ada.Wide_Wide_Text_IO.Float_IO + "a-ztinio", -- Ada.Wide_Wide_Text_IO.Integer_IO + "a-ztmoio", -- Ada.Wide_Wide_Text_IO.Modular_IO + + ------------------------ + -- GNAT Library Units -- + ------------------------ + + "g-zspche", -- GNAT.Wide_Wide_Spelling_Checker + "g-zstspl"); -- GNAT.Wide_Wide_String_Split + + -------------------- + -- Ada 2012 Units -- + -------------------- + + -- The following units should be used only in Ada 2012 mode + + Non_Imp_File_Names_12 : constant File_List := ( + "s-multip", -- System.Multiprocessors + "s-mudido", -- System.Multiprocessors.Dispatching_Domains + "a-cobove", -- Ada.Containers.Bounded_Vectors + "a-cbdlli", -- Ada.Containers.Bounded_Doubly_Linked_Lists + "a-cborse", -- Ada.Containers.Bounded_Ordered_Sets + "a-cborma", -- Ada.Containers.Bounded_Ordered_Maps + "a-cbhase", -- Ada.Containers.Bounded_Hashed_Sets + "a-cbhama"); -- Ada.Containers.Bounded_Hashed_Maps + + ----------------------- + -- Alternative Units -- + ----------------------- + + -- For some implementation units, there is a unit in the GNAT library + -- that has identical functionality that is usable. If we have such a + -- case we record the appropriate Unit name in Error_Msg_String. + + type Aunit_Record is record + Fname : String (1 .. 6); + Aname : String_Ptr; + end record; + + -- Array of alternative unit names + + Scasuti : aliased String := "GNAT.Case_Util"; + Scrc32 : aliased String := "GNAT.CRC32"; + Shtable : aliased String := "GNAT.HTable"; + Sos_lib : aliased String := "GNAT.OS_Lib"; + Sregexp : aliased String := "GNAT.Regexp"; + Sregpat : aliased String := "GNAT.Regpat"; + Sstring : aliased String := "GNAT.Strings"; + Sstusta : aliased String := "GNAT.Task_Stack_Usage"; + Stasloc : aliased String := "GNAT.Task_Lock"; + Sutf_32 : aliased String := "GNAT.UTF_32"; + + -- Array giving mapping + + Map_Array : constant array (1 .. 10) of Aunit_Record := ( + ("casuti", Scasuti'Access), + ("crc32 ", Scrc32 'Access), + ("htable", Shtable'Access), + ("os_lib", Sos_lib'Access), + ("regexp", Sregexp'Access), + ("regpat", Sregpat'Access), + ("string", Sstring'Access), + ("stusta", Sstusta'Access), + ("tasloc", Stasloc'Access), + ("utf_32", Sutf_32'Access)); + + ---------------------- + -- Get_Kind_Of_Unit -- + ---------------------- + + function Get_Kind_Of_Unit (U : Unit_Number_Type) return Kind_Of_Unit is + Fname : constant File_Name_Type := Unit_File_Name (U); + + begin + Error_Msg_Strlen := 0; + + -- If length of file name is greater than 12, not predefined. + -- The value 12 here is an 8 char name with extension .ads. + + if Length_Of_Name (Fname) > 12 then + return Not_Predefined_Unit; + end if; + + -- Otherwise test file name + + Get_Name_String (Fname); + + -- Not predefined if file name does not start with a- g- s- i- + + if Name_Len < 3 + or else Name_Buffer (2) /= '-' + or else (Name_Buffer (1) /= 'a' + and then + Name_Buffer (1) /= 'g' + and then + Name_Buffer (1) /= 'i' + and then + Name_Buffer (1) /= 's') + then + return Not_Predefined_Unit; + end if; + + -- Not predefined if file name does not end in .ads. This can + -- happen when non-standard file names are being used. + + if Name_Buffer (Name_Len - 3 .. Name_Len) /= ".ads" then + return Not_Predefined_Unit; + end if; + + -- Otherwise normalize file name to 8 characters + + Name_Len := Name_Len - 4; + while Name_Len < 8 loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ' '; + end loop; + + -- See if name is in 95 list + + for J in Non_Imp_File_Names_95'Range loop + if Name_Buffer (1 .. 8) = Non_Imp_File_Names_95 (J) then + return Ada_95_Unit; + end if; + end loop; + + -- See if name is in 2005 list + + for J in Non_Imp_File_Names_05'Range loop + if Name_Buffer (1 .. 8) = Non_Imp_File_Names_05 (J) then + return Ada_2005_Unit; + end if; + end loop; + + -- See if name is in 2012 list + + for J in Non_Imp_File_Names_12'Range loop + if Name_Buffer (1 .. 8) = Non_Imp_File_Names_12 (J) then + return Ada_2012_Unit; + end if; + end loop; + + -- Only remaining special possibilities are children of System.RPC and + -- System.Garlic and special files of the form System.Aux... + + Get_Name_String (Unit_Name (U)); + + if Name_Len > 12 + and then Name_Buffer (1 .. 11) = "system.rpc." + then + return Ada_95_Unit; + end if; + + if Name_Len > 15 + and then Name_Buffer (1 .. 14) = "system.garlic." + then + return Ada_95_Unit; + end if; + + if Name_Len > 11 + and then Name_Buffer (1 .. 10) = "system.aux" + then + return Ada_95_Unit; + end if; + + -- All tests failed, this is definitely an implementation unit. See if + -- we have an alternative name. + + Get_Name_String (Fname); + + if Name_Len in 11 .. 12 + and then Name_Buffer (1 .. 2) = "s-" + and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".ads" + then + for J in Map_Array'Range loop + if (Name_Len = 12 and then + Name_Buffer (3 .. 8) = Map_Array (J).Fname) + or else + (Name_Len = 11 and then + Name_Buffer (3 .. 7) = Map_Array (J).Fname (1 .. 5)) + then + Error_Msg_Strlen := Map_Array (J).Aname'Length; + Error_Msg_String (1 .. Error_Msg_Strlen) := + Map_Array (J).Aname.all; + end if; + end loop; + end if; + + return Implementation_Unit; + end Get_Kind_Of_Unit; + + ------------------- + -- Is_Known_Unit -- + ------------------- + + function Is_Known_Unit (Nam : Node_Id) return Boolean is + Unam : Unit_Name_Type; + Fnam : File_Name_Type; + + begin + -- If selector is not an identifier (e.g. it is a character literal or + -- some junk from a previous error), then definitely not a known unit. + + if Nkind (Selector_Name (Nam)) /= N_Identifier then + return False; + end if; + + -- Otherwise get corresponding file name + + Unam := Get_Unit_Name (Nam); + Fnam := Get_File_Name (Unam, Subunit => False); + Get_Name_String (Fnam); + + -- Remove extension from file name + + if Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb" then + Name_Len := Name_Len - 4; + else + return False; + end if; + + -- Pad name to 8 characters + + while Name_Len < 8 loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ' '; + end loop; + + -- If length more than 8, definitely not a match + + if Name_Len /= 8 then + return False; + end if; + + -- If length is 8, search our tables + + for J in Non_Imp_File_Names_95'Range loop + if Name_Buffer (1 .. 8) = Non_Imp_File_Names_95 (J) then + return True; + end if; + end loop; + + for J in Non_Imp_File_Names_05'Range loop + if Name_Buffer (1 .. 8) = Non_Imp_File_Names_05 (J) then + return True; + end if; + end loop; + + -- If not found, not known + + return False; + + -- A safety guard, if we get an exception during this processing then it + -- is most likely the result of a previous error, or a peculiar case we + -- have not thought of. Since this routine is only used for error message + -- refinement, we will just return False. + + exception + when others => + return False; + end Is_Known_Unit; + +end Impunit; diff --git a/gcc/ada/impunit.ads b/gcc/ada/impunit.ads new file mode 100644 index 000000000..621a03401 --- /dev/null +++ b/gcc/ada/impunit.ads @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I M P U N I T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains data and functions used to determine if a given +-- unit is an internal unit intended only for use by the implementation +-- and which should not be directly WITH'ed by user code. It also checks +-- for Ada 05 units that should only be WITH'ed in Ada 05 mode. + +with Types; use Types; + +package Impunit is + + type Kind_Of_Unit is + (Implementation_Unit, + -- Unit from predefined library intended to be used only by the + -- compiler generated code, or from the implementation of the run time. + -- Use of such a unit generates a warning unless the client is compiled + -- with the -gnatg switch. If we are being super strict, this should be + -- an error for the case of Ada units, but that seems over strenuous. + + Not_Predefined_Unit, + -- This is not a predefined unit, so no checks are needed + + Ada_95_Unit, + -- This unit is defined in the Ada 95 RM, and can be freely with'ed + -- in both Ada 95 mode and Ada 05 mode. Note that in Ada 83 mode, no + -- child units are allowed, so you can't even name such a unit. + + Ada_2005_Unit, + -- This unit is defined in the Ada 2005 RM. Withing this unit from a + -- Ada 95 mode program will generate a warning (again, strictly speaking + -- this should be an error, but that seems over-strenuous). + + Ada_2012_Unit); + -- This unit is defined in the Ada 2012 RM. Withing this unit from a Ada + -- 95 mode or Ada 2005 program will generate a warning (again, strictly + -- speaking this should be an error, but that seems over-strenuous). + + function Get_Kind_Of_Unit (U : Unit_Number_Type) return Kind_Of_Unit; + -- Given the unit number of a unit, this function determines the type + -- of the unit, as defined above. If the result is Implementation_Unit, + -- then the name of a possible atlernative equivalent unit is placed in + -- Error_Msg_String/Slen on return. If there is no alternative name, or + -- if the result is not Implementation_Unit, then Error_Msg_Slen is zero + -- on return, indicating that no alternative name was found. + + function Is_Known_Unit (Nam : Node_Id) return Boolean; + -- Nam is the possible name of a child unit, represented as a selected + -- component node. This function determines whether the name matches + -- one of the known library units, and if so, returns True. If the name + -- does not match any known library unit, False is returned. + +end Impunit; diff --git a/gcc/ada/indepsw-aix.adb b/gcc/ada/indepsw-aix.adb new file mode 100644 index 000000000..8eaa382ca --- /dev/null +++ b/gcc/ada/indepsw-aix.adb @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N D E P S W -- +-- -- +-- B o d y -- +-- (AIX version) -- +-- -- +-- 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 is the AIX version + +package body Indepsw is + + Map_Switch : aliased constant String := "-Wl,-b,map:"; + + ------------- + -- Convert -- + ------------- + + procedure Convert + (Switch : Switch_Kind; + Argument : String; + To : out String_List_Access) + is + begin + case Switch is + when Map_File => + To := new Argument_List'(1 => new String'(Map_Switch & Argument)); + end case; + end Convert; + + ------------------ + -- Is_Supported -- + ------------------ + + function Is_Supported (Switch : Switch_Kind) return Boolean is + begin + case Switch is + when Map_File => + return True; + end case; + end Is_Supported; + +end Indepsw; diff --git a/gcc/ada/indepsw-gnu.adb b/gcc/ada/indepsw-gnu.adb new file mode 100644 index 000000000..c81270ed5 --- /dev/null +++ b/gcc/ada/indepsw-gnu.adb @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N D E P S W -- +-- -- +-- B o d y -- +-- (GNU version) -- +-- -- +-- 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 is the GNU ld version + +package body Indepsw is + + Map_Switch : aliased constant String := "-Wl,-Map,"; + + ------------- + -- Convert -- + ------------- + + procedure Convert + (Switch : Switch_Kind; + Argument : String; + To : out String_List_Access) + is + begin + case Switch is + when Map_File => + To := new Argument_List'(1 => new String'(Map_Switch & Argument)); + end case; + end Convert; + + ------------------ + -- Is_Supported -- + ------------------ + + function Is_Supported (Switch : Switch_Kind) return Boolean is + begin + case Switch is + when Map_File => + return True; + end case; + end Is_Supported; + +end Indepsw; diff --git a/gcc/ada/indepsw-mingw.adb b/gcc/ada/indepsw-mingw.adb new file mode 100644 index 000000000..7632cf7f3 --- /dev/null +++ b/gcc/ada/indepsw-mingw.adb @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N D E P S W -- +-- -- +-- B o d y -- +-- (Windows version) -- +-- -- +-- 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 is the Windows version + +package body Indepsw is + + Map_Switch : aliased constant String := "-Wl,-Map,"; + + ------------- + -- Convert -- + ------------- + + procedure Convert + (Switch : Switch_Kind; + Argument : String; + To : out String_List_Access) + is + begin + case Switch is + when Map_File => + To := new Argument_List'(1 => new String'(Map_Switch & Argument)); + end case; + end Convert; + + ------------------ + -- Is_Supported -- + ------------------ + + function Is_Supported (Switch : Switch_Kind) return Boolean is + begin + case Switch is + when Map_File => + return True; + end case; + end Is_Supported; + +end Indepsw; diff --git a/gcc/ada/indepsw.adb b/gcc/ada/indepsw.adb new file mode 100644 index 000000000..8439075fa --- /dev/null +++ b/gcc/ada/indepsw.adb @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N D E P S W -- +-- -- +-- 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 is the default version: no switches are supported + +with Output; use Output; + +package body Indepsw is + + ------------- + -- Convert -- + ------------- + + procedure Convert + (Switch : Switch_Kind; + Argument : String; + To : out String_List_Access) + is + pragma Unreferenced (Argument); + begin + case Switch is + when others => + Write_Str ("warning: "); + Write_Line (No_Support_For (Switch).all); + To := null; + end case; + end Convert; + + ------------------ + -- Is_Supported -- + ------------------ + + function Is_Supported (Switch : Switch_Kind) return Boolean is + pragma Unreferenced (Switch); + begin + return False; + end Is_Supported; + +end Indepsw; diff --git a/gcc/ada/indepsw.ads b/gcc/ada/indepsw.ads new file mode 100644 index 000000000..a96409aed --- /dev/null +++ b/gcc/ada/indepsw.ads @@ -0,0 +1,82 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N D E P S W -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- GNATLINK platform-independent switches + +-- Used to convert GNAT switches to their platform-dependent switch +-- equivalent for the underlying linker. + +with System.OS_Lib; use System.OS_Lib; + +package Indepsw is + + type Switch_Kind is + -- Independent switches currently supported + + (Map_File); + -- Produce a map file. The path name of the map file to produce + -- is given as an argument. + + procedure Convert + (Switch : Switch_Kind; + Argument : String; + To : out String_List_Access); + -- Convert Switch to the platform-dependent linker switch (with or without + -- additional arguments) To. Issue a warning if Switch is not supported + -- for the platform; in this case, To is set to null. + + function Is_Supported (Switch : Switch_Kind) return Boolean; + -- Return True for each independent switch supported by the platform + +private + -- Default warning messages when the switches are not supported by the + -- implementation. These are in the spec so that the platform specific + -- bodies do not need to redefine them. + + Map_File_Not_Supported : aliased String := + "the underlying linker does not allow the output of a map file"; + + No_Support_For : constant array (Switch_Kind) of String_Access := + (Map_File => Map_File_Not_Supported'Access); + -- All implementations of procedure Convert should include a case + -- statements with a "when others =>" choice that output the default + -- warning message: + + -- case Switch is + -- when ... => + -- ... + -- when others => + -- Write_Str ("warning: "); + -- Write_Line (No_Support_For (Switch).all); + -- To := null; + -- end case; + +end Indepsw; diff --git a/gcc/ada/init.c b/gcc/ada/init.c new file mode 100644 index 000000000..431aa9095 --- /dev/null +++ b/gcc/ada/init.c @@ -0,0 +1,2460 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * I N I T * + * * + * C Implementation File * + * * + * 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. * + * * + ****************************************************************************/ + +/* This unit contains initialization circuits that are system dependent. + A major part of the functionality involves stack overflow checking. + The GCC backend generates probe instructions to test for stack overflow. + For details on the exact approach used to generate these probes, see the + "Using and Porting GCC" manual, in particular the "Stack Checking" section + and the subsection "Specifying How Stack Checking is Done". The handlers + installed by this file are used to catch the resulting signals that come + from these probes failing (i.e. touching protected pages). */ + +/* This file should be kept synchronized with 2sinit.ads, 2sinit.adb, + s-init-ae653-cert.adb and s-init-xi-sparc.adb. All these files implement + the required functionality for different targets. */ + +/* The following include is here to meet the published VxWorks requirement + that the __vxworks header appear before any other include. */ +#ifdef __vxworks +#include "vxWorks.h" +#endif + +#ifdef IN_RTS +#include "tconfig.h" +#include "tsystem.h" +#include + +/* We don't have libiberty, so use malloc. */ +#define xmalloc(S) malloc (S) +#else +#include "config.h" +#include "system.h" +#endif + +#include "adaint.h" +#include "raise.h" + +extern void __gnat_raise_program_error (const char *, int); + +/* Addresses of exception data blocks for predefined exceptions. Tasking_Error + is not used in this unit, and the abort signal is only used on IRIX. */ +extern struct Exception_Data constraint_error; +extern struct Exception_Data numeric_error; +extern struct Exception_Data program_error; +extern struct Exception_Data storage_error; + +/* For the Cert run time we use the regular raise exception routine because + Raise_From_Signal_Handler is not available. */ +#ifdef CERT +#define Raise_From_Signal_Handler \ + __gnat_raise_exception +extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *); +#else +#define Raise_From_Signal_Handler \ + ada__exceptions__raise_from_signal_handler +extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *); +#endif + +/* Global values computed by the binder. */ +int __gl_main_priority = -1; +int __gl_main_cpu = -1; +int __gl_time_slice_val = -1; +char __gl_wc_encoding = 'n'; +char __gl_locking_policy = ' '; +char __gl_queuing_policy = ' '; +char __gl_task_dispatching_policy = ' '; +char *__gl_priority_specific_dispatching = 0; +int __gl_num_specific_dispatching = 0; +char *__gl_interrupt_states = 0; +int __gl_num_interrupt_states = 0; +int __gl_unreserve_all_interrupts = 0; +int __gl_exception_tracebacks = 0; +int __gl_zero_cost_exceptions = 0; +int __gl_detect_blocking = 0; +int __gl_default_stack_size = -1; +int __gl_leap_seconds_support = 0; +int __gl_canonical_streams = 0; + +/* Indication of whether synchronous signal handler has already been + installed by a previous call to adainit. */ +int __gnat_handler_installed = 0; + +#ifndef IN_RTS +int __gnat_inside_elab_final_code = 0; +/* ??? This variable is obsolete since 2001-08-29 but is kept to allow + bootstrap from old GNAT versions (< 3.15). */ +#endif + +/* HAVE_GNAT_INIT_FLOAT must be set on every targets where a __gnat_init_float + is defined. If this is not set then a void implementation will be defined + at the end of this unit. */ +#undef HAVE_GNAT_INIT_FLOAT + +/******************************/ +/* __gnat_get_interrupt_state */ +/******************************/ + +char __gnat_get_interrupt_state (int); + +/* This routine is called from the runtime as needed to determine the state + of an interrupt, as set by an Interrupt_State pragma appearing anywhere + in the current partition. The input argument is the interrupt number, + and the result is one of the following: + + 'n' this interrupt not set by any Interrupt_State pragma + 'u' Interrupt_State pragma set state to User + 'r' Interrupt_State pragma set state to Runtime + 's' Interrupt_State pragma set state to System */ + +char +__gnat_get_interrupt_state (int intrup) +{ + if (intrup >= __gl_num_interrupt_states) + return 'n'; + else + return __gl_interrupt_states [intrup]; +} + +/***********************************/ +/* __gnat_get_specific_dispatching */ +/***********************************/ + +char __gnat_get_specific_dispatching (int); + +/* This routine is called from the runtime as needed to determine the + priority specific dispatching policy, as set by a + Priority_Specific_Dispatching pragma appearing anywhere in the current + partition. The input argument is the priority number, and the result + is the upper case first character of the policy name, e.g. 'F' for + FIFO_Within_Priorities. A space ' ' is returned if no + Priority_Specific_Dispatching pragma is used in the partition. */ + +char +__gnat_get_specific_dispatching (int priority) +{ + if (__gl_num_specific_dispatching == 0) + return ' '; + else if (priority >= __gl_num_specific_dispatching) + return 'F'; + else + return __gl_priority_specific_dispatching [priority]; +} + +#ifndef IN_RTS + +/**********************/ +/* __gnat_set_globals */ +/**********************/ + +/* This routine is kept for bootstrapping purposes, since the binder generated + file now sets the __gl_* variables directly. */ + +void +__gnat_set_globals (void) +{ +} + +#endif + +/***************/ +/* AIX Section */ +/***************/ + +#if defined (_AIX) + +#include +#include + +/* Some versions of AIX don't define SA_NODEFER. */ + +#ifndef SA_NODEFER +#define SA_NODEFER 0 +#endif /* SA_NODEFER */ + +/* Versions of AIX before 4.3 don't have nanosleep but provide + nsleep instead. */ + +#ifndef _AIXVERSION_430 + +extern int nanosleep (struct timestruc_t *, struct timestruc_t *); + +int +nanosleep (struct timestruc_t *Rqtp, struct timestruc_t *Rmtp) +{ + return nsleep (Rqtp, Rmtp); +} + +#endif /* _AIXVERSION_430 */ + +static void +__gnat_error_handler (int sig, + siginfo_t *si ATTRIBUTE_UNUSED, + void *ucontext ATTRIBUTE_UNUSED) +{ + struct Exception_Data *exception; + const char *msg; + + switch (sig) + { + case SIGSEGV: + /* FIXME: we need to detect the case of a *real* SIGSEGV. */ + exception = &storage_error; + msg = "stack overflow or erroneous memory access"; + break; + + case SIGBUS: + exception = &constraint_error; + msg = "SIGBUS"; + break; + + case SIGFPE: + exception = &constraint_error; + msg = "SIGFPE"; + break; + + default: + exception = &program_error; + msg = "unhandled signal"; + } + + Raise_From_Signal_Handler (exception, msg); +} + +void +__gnat_install_handler (void) +{ + struct sigaction act; + + /* Set up signal handler to map synchronous signals to appropriate + exceptions. Make sure that the handler isn't interrupted by another + signal that might cause a scheduling event! */ + + act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO; + act.sa_sigaction = __gnat_error_handler; + sigemptyset (&act.sa_mask); + + /* Do not install handlers if interrupt state is "System". */ + if (__gnat_get_interrupt_state (SIGABRT) != 's') + sigaction (SIGABRT, &act, NULL); + if (__gnat_get_interrupt_state (SIGFPE) != 's') + sigaction (SIGFPE, &act, NULL); + if (__gnat_get_interrupt_state (SIGILL) != 's') + sigaction (SIGILL, &act, NULL); + if (__gnat_get_interrupt_state (SIGSEGV) != 's') + sigaction (SIGSEGV, &act, NULL); + if (__gnat_get_interrupt_state (SIGBUS) != 's') + sigaction (SIGBUS, &act, NULL); + + __gnat_handler_installed = 1; +} + +/*****************/ +/* Tru64 section */ +/*****************/ + +#elif defined(__alpha__) && defined(__osf__) + +#include +#include + +extern char *__gnat_get_code_loc (struct sigcontext *); +extern void __gnat_set_code_loc (struct sigcontext *, char *); +extern size_t __gnat_machine_state_length (void); + +#define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE + +void +__gnat_adjust_context_for_raise (int signo, void *ucontext) +{ + struct sigcontext *sigcontext = (struct sigcontext *) ucontext; + + /* The unwinder expects the signal context to contain the address of the + faulting instruction. For SIGFPE, this depends on the trap shadow + situation (see man ieee). We nonetheless always compensate for it, + considering that PC designates the instruction following the one that + trapped. This is not necessarily true but corresponds to what we have + always observed. */ + if (signo == SIGFPE) + sigcontext->sc_pc--; +} + +static void +__gnat_error_handler (int sig, siginfo_t *si, void *ucontext) +{ + struct Exception_Data *exception; + static int recurse = 0; + const char *msg; + + /* Adjusting is required for every fault context, so adjust for this one + now, before we possibly trigger a recursive fault below. */ + __gnat_adjust_context_for_raise (sig, ucontext); + + /* If this was an explicit signal from a "kill", just resignal it. */ + if (SI_FROMUSER (si)) + { + signal (sig, SIG_DFL); + kill (getpid(), sig); + } + + /* Otherwise, treat it as something we handle. */ + switch (sig) + { + case SIGSEGV: + /* If the problem was permissions, this is a constraint error. + Likewise if the failing address isn't maximally aligned or if + we've recursed. + + ??? Using a static variable here isn't task-safe, but it's + much too hard to do anything else and we're just determining + which exception to raise. */ + if (si->si_code == SEGV_ACCERR + || (long) si->si_addr == 0 + || (((long) si->si_addr) & 3) != 0 + || recurse) + { + exception = &constraint_error; + msg = "SIGSEGV"; + } + else + { + /* See if the page before the faulting page is accessible. Do that + by trying to access it. We'd like to simply try to access + 4096 + the faulting address, but it's not guaranteed to be + the actual address, just to be on the same page. */ + recurse++; + ((volatile char *) + ((long) si->si_addr & - getpagesize ()))[getpagesize ()]; + exception = &storage_error; + msg = "stack overflow (or erroneous memory access)"; + } + break; + + case SIGBUS: + exception = &program_error; + msg = "SIGBUS"; + break; + + case SIGFPE: + exception = &constraint_error; + msg = "SIGFPE"; + break; + + default: + exception = &program_error; + msg = "unhandled signal"; + } + + recurse = 0; + Raise_From_Signal_Handler (exception, (const char *) msg); +} + +void +__gnat_install_handler (void) +{ + struct sigaction act; + + /* Setup signal handler to map synchronous signals to appropriate + exceptions. Make sure that the handler isn't interrupted by another + signal that might cause a scheduling event! */ + + act.sa_handler = (void (*) (int)) __gnat_error_handler; + act.sa_flags = SA_RESTART | SA_NODEFER | SA_SIGINFO; + sigemptyset (&act.sa_mask); + + /* Do not install handlers if interrupt state is "System". */ + if (__gnat_get_interrupt_state (SIGABRT) != 's') + sigaction (SIGABRT, &act, NULL); + if (__gnat_get_interrupt_state (SIGFPE) != 's') + sigaction (SIGFPE, &act, NULL); + if (__gnat_get_interrupt_state (SIGILL) != 's') + sigaction (SIGILL, &act, NULL); + if (__gnat_get_interrupt_state (SIGSEGV) != 's') + sigaction (SIGSEGV, &act, NULL); + if (__gnat_get_interrupt_state (SIGBUS) != 's') + sigaction (SIGBUS, &act, NULL); + + __gnat_handler_installed = 1; +} + +/* Routines called by s-mastop-tru64.adb. */ + +#define SC_GP 29 + +char * +__gnat_get_code_loc (struct sigcontext *context) +{ + return (char *) context->sc_pc; +} + +void +__gnat_set_code_loc (struct sigcontext *context, char *pc) +{ + context->sc_pc = (long) pc; +} + +size_t +__gnat_machine_state_length (void) +{ + return sizeof (struct sigcontext); +} + +/*****************/ +/* HP-UX section */ +/*****************/ + +#elif defined (__hpux__) + +#include +#include + +static void +__gnat_error_handler (int sig, + siginfo_t *si ATTRIBUTE_UNUSED, + void *ucontext ATTRIBUTE_UNUSED) +{ + struct Exception_Data *exception; + const char *msg; + + switch (sig) + { + case SIGSEGV: + /* FIXME: we need to detect the case of a *real* SIGSEGV. */ + exception = &storage_error; + msg = "stack overflow or erroneous memory access"; + break; + + case SIGBUS: + exception = &constraint_error; + msg = "SIGBUS"; + break; + + case SIGFPE: + exception = &constraint_error; + msg = "SIGFPE"; + break; + + default: + exception = &program_error; + msg = "unhandled signal"; + } + + Raise_From_Signal_Handler (exception, msg); +} + +/* This must be in keeping with System.OS_Interface.Alternate_Stack_Size. */ +#if defined (__hppa__) +char __gnat_alternate_stack[16 * 1024]; /* 2 * SIGSTKSZ */ +#else +char __gnat_alternate_stack[128 * 1024]; /* MINSIGSTKSZ */ +#endif + +void +__gnat_install_handler (void) +{ + struct sigaction act; + + /* Set up signal handler to map synchronous signals to appropriate + exceptions. Make sure that the handler isn't interrupted by another + signal that might cause a scheduling event! Also setup an alternate + stack region for the handler execution so that stack overflows can be + handled properly, avoiding a SEGV generation from stack usage by the + handler itself. */ + + stack_t stack; + stack.ss_sp = __gnat_alternate_stack; + stack.ss_size = sizeof (__gnat_alternate_stack); + stack.ss_flags = 0; + sigaltstack (&stack, NULL); + + act.sa_sigaction = __gnat_error_handler; + act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO; + sigemptyset (&act.sa_mask); + + /* Do not install handlers if interrupt state is "System". */ + if (__gnat_get_interrupt_state (SIGABRT) != 's') + sigaction (SIGABRT, &act, NULL); + if (__gnat_get_interrupt_state (SIGFPE) != 's') + sigaction (SIGFPE, &act, NULL); + if (__gnat_get_interrupt_state (SIGILL) != 's') + sigaction (SIGILL, &act, NULL); + if (__gnat_get_interrupt_state (SIGBUS) != 's') + sigaction (SIGBUS, &act, NULL); + act.sa_flags |= SA_ONSTACK; + if (__gnat_get_interrupt_state (SIGSEGV) != 's') + sigaction (SIGSEGV, &act, NULL); + + __gnat_handler_installed = 1; +} + +/*********************/ +/* GNU/Linux Section */ +/*********************/ + +#elif defined (linux) + +#include + +#define __USE_GNU 1 /* required to get REG_EIP/RIP from glibc's ucontext.h */ +#include + +/* GNU/Linux, which uses glibc, does not define NULL in included + header files. */ + +#if !defined (NULL) +#define NULL ((void *) 0) +#endif + +#if defined (MaRTE) + +/* MaRTE OS provides its own version of sigaction, sigfillset, and + sigemptyset (overriding these symbol names). We want to make sure that + the versions provided by the underlying C library are used here (these + versions are renamed by MaRTE to linux_sigaction, fake_linux_sigfillset, + and fake_linux_sigemptyset, respectively). The MaRTE library will not + always be present (it will not be linked if no tasking constructs are + used), so we use the weak symbol mechanism to point always to the symbols + defined within the C library. */ + +#pragma weak linux_sigaction +int linux_sigaction (int signum, const struct sigaction *act, + struct sigaction *oldact) { + return sigaction (signum, act, oldact); +} +#define sigaction(signum, act, oldact) linux_sigaction (signum, act, oldact) + +#pragma weak fake_linux_sigfillset +void fake_linux_sigfillset (sigset_t *set) { + sigfillset (set); +} +#define sigfillset(set) fake_linux_sigfillset (set) + +#pragma weak fake_linux_sigemptyset +void fake_linux_sigemptyset (sigset_t *set) { + sigemptyset (set); +} +#define sigemptyset(set) fake_linux_sigemptyset (set) + +#endif + +#if defined (i386) || defined (__x86_64__) || defined (__ia64__) + +#define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE + +void +__gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) +{ + mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext; + + /* On the i386 and x86-64 architectures, stack checking is performed by + means of probes with moving stack pointer, that is to say the probed + address is always the value of the stack pointer. Upon hitting the + guard page, the stack pointer therefore points to an inaccessible + address and an alternate signal stack is needed to run the handler. + But there is an additional twist: on these architectures, the EH + return code writes the address of the handler at the target CFA's + value on the stack before doing the jump. As a consequence, if + there is an active handler in the frame whose stack has overflowed, + the stack pointer must nevertheless point to an accessible address + by the time the EH return is executed. + + We therefore adjust the saved value of the stack pointer by the size + of one page + a small dope of 4 words, in order to make sure that it + points to an accessible address in case it's used as the target CFA. + The stack checking code guarantees that this address is unused by the + time this happens. */ + +#if defined (i386) + unsigned long *pc = (unsigned long *)mcontext->gregs[REG_EIP]; + /* The pattern is "orl $0x0,(%esp)" for a probe in 32-bit mode. */ + if (signo == SIGSEGV && pc && *pc == 0x00240c83) + mcontext->gregs[REG_ESP] += 4096 + 4 * sizeof (unsigned long); +#elif defined (__x86_64__) + unsigned long *pc = (unsigned long *)mcontext->gregs[REG_RIP]; + /* The pattern is "orq $0x0,(%rsp)" for a probe in 64-bit mode. */ + if (signo == SIGSEGV && pc && (*pc & 0xffffffffff) == 0x00240c8348) + mcontext->gregs[REG_RSP] += 4096 + 4 * sizeof (unsigned long); +#elif defined (__ia64__) + /* ??? The IA-64 unwinder doesn't compensate for signals. */ + mcontext->sc_ip++; +#endif +} + +#endif + +static void +__gnat_error_handler (int sig, siginfo_t *si ATTRIBUTE_UNUSED, void *ucontext) +{ + struct Exception_Data *exception; + const char *msg; + + /* Adjusting is required for every fault context, so adjust for this one + now, before we possibly trigger a recursive fault below. */ + __gnat_adjust_context_for_raise (sig, ucontext); + + switch (sig) + { + case SIGSEGV: + /* Here we would like a discrimination test to see whether the page + before the faulting address is accessible. Unfortunately, Linux + seems to have no way of giving us the faulting address. + + In old versions of init.c, we had a test of the page before the + stack pointer: + + ((volatile char *) + ((long) si->esp_at_signal & - getpagesize ()))[getpagesize ()]; + + but that's wrong since it tests the stack pointer location and the + stack probing code may not move it until all probes succeed. + + For now we simply do not attempt any discrimination at all. Note + that this is quite acceptable, since a "real" SIGSEGV can only + occur as the result of an erroneous program. */ + exception = &storage_error; + msg = "stack overflow (or erroneous memory access)"; + break; + + case SIGBUS: + exception = &constraint_error; + msg = "SIGBUS"; + break; + + case SIGFPE: + exception = &constraint_error; + msg = "SIGFPE"; + break; + + default: + exception = &program_error; + msg = "unhandled signal"; + } + + Raise_From_Signal_Handler (exception, msg); +} + +#if defined (i386) || defined (__x86_64__) || defined (__powerpc__) +/* This must be in keeping with System.OS_Interface.Alternate_Stack_Size. */ +char __gnat_alternate_stack[16 * 1024]; /* 2 * SIGSTKSZ */ +#endif + +#ifdef __XENO__ +#include +#include + +RT_TASK main_task; +#endif + +void +__gnat_install_handler (void) +{ + struct sigaction act; + +#ifdef __XENO__ + int prio; + + if (__gl_main_priority == -1) + prio = 49; + else + prio = __gl_main_priority; + + /* Avoid memory swapping for this program */ + + mlockall (MCL_CURRENT|MCL_FUTURE); + + /* Turn the current Linux task into a native Xenomai task */ + + rt_task_shadow(&main_task, "environment_task", prio, T_FPU); +#endif + + /* Set up signal handler to map synchronous signals to appropriate + exceptions. Make sure that the handler isn't interrupted by another + signal that might cause a scheduling event! Also setup an alternate + stack region for the handler execution so that stack overflows can be + handled properly, avoiding a SEGV generation from stack usage by the + handler itself. */ + +#if defined (i386) || defined (__x86_64__) || defined (__powerpc__) + stack_t stack; + stack.ss_sp = __gnat_alternate_stack; + stack.ss_size = sizeof (__gnat_alternate_stack); + stack.ss_flags = 0; + sigaltstack (&stack, NULL); +#endif + + act.sa_sigaction = __gnat_error_handler; + act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO; + sigemptyset (&act.sa_mask); + + /* Do not install handlers if interrupt state is "System". */ + if (__gnat_get_interrupt_state (SIGABRT) != 's') + sigaction (SIGABRT, &act, NULL); + if (__gnat_get_interrupt_state (SIGFPE) != 's') + sigaction (SIGFPE, &act, NULL); + if (__gnat_get_interrupt_state (SIGILL) != 's') + sigaction (SIGILL, &act, NULL); + if (__gnat_get_interrupt_state (SIGBUS) != 's') + sigaction (SIGBUS, &act, NULL); +#if defined (i386) || defined (__x86_64__) || defined (__powerpc__) + act.sa_flags |= SA_ONSTACK; +#endif + if (__gnat_get_interrupt_state (SIGSEGV) != 's') + sigaction (SIGSEGV, &act, NULL); + + __gnat_handler_installed = 1; +} + +/****************/ +/* IRIX Section */ +/****************/ + +#elif defined (sgi) + +#include +#include + +#ifndef NULL +#define NULL 0 +#endif + +#define SIGADAABORT 48 +#define SIGNAL_STACK_SIZE 4096 +#define SIGNAL_STACK_ALIGNMENT 64 + +#define Check_Abort_Status \ + system__soft_links__check_abort_status +extern int (*Check_Abort_Status) (void); + +extern struct Exception_Data _abort_signal; + +/* We are not setting the SA_SIGINFO bit in the sigaction flags when + connecting that handler, with the effects described in the sigaction + man page: + + SA_SIGINFO [...] + If cleared and the signal is caught, the first argument is + also the signal number but the second argument is the signal + code identifying the cause of the signal. The third argument + points to a sigcontext_t structure containing the receiving + process's context when the signal was delivered. */ + +static void +__gnat_error_handler (int sig, int code, sigcontext_t *sc ATTRIBUTE_UNUSED) +{ + struct Exception_Data *exception; + const char *msg; + + switch (sig) + { + case SIGSEGV: + if (code == EFAULT) + { + exception = &program_error; + msg = "SIGSEGV: (Invalid virtual address)"; + } + else if (code == ENXIO) + { + exception = &program_error; + msg = "SIGSEGV: (Read beyond mapped object)"; + } + else if (code == ENOSPC) + { + exception = &program_error; /* ??? storage_error ??? */ + msg = "SIGSEGV: (Autogrow for file failed)"; + } + else if (code == EACCES || code == EEXIST) + { + /* ??? We handle stack overflows here, some of which do trigger + SIGSEGV + EEXIST on Irix 6.5 although EEXIST is not part of + the documented valid codes for SEGV in the signal(5) man + page. */ + + /* ??? Re-add smarts to further verify that we launched + the stack into a guard page, not an attempt to + write to .text or something. */ + exception = &storage_error; + msg = "SIGSEGV: (stack overflow or erroneous memory access)"; + } + else + { + /* Just in case the OS guys did it to us again. Sometimes + they fail to document all of the valid codes that are + passed to signal handlers, just in case someone depends + on knowing all the codes. */ + exception = &program_error; + msg = "SIGSEGV: (Undocumented reason)"; + } + break; + + case SIGBUS: + /* Map all bus errors to Program_Error. */ + exception = &program_error; + msg = "SIGBUS"; + break; + + case SIGFPE: + /* Map all fpe errors to Constraint_Error. */ + exception = &constraint_error; + msg = "SIGFPE"; + break; + + case SIGADAABORT: + if ((*Check_Abort_Status) ()) + { + exception = &_abort_signal; + msg = ""; + } + else + return; + + break; + + default: + /* Everything else is a Program_Error. */ + exception = &program_error; + msg = "unhandled signal"; + } + + Raise_From_Signal_Handler (exception, msg); +} + +void +__gnat_install_handler (void) +{ + struct sigaction act; + + /* Setup signal handler to map synchronous signals to appropriate + exceptions. Make sure that the handler isn't interrupted by another + signal that might cause a scheduling event! */ + + act.sa_handler = __gnat_error_handler; + act.sa_flags = SA_NODEFER + SA_RESTART; + sigfillset (&act.sa_mask); + sigemptyset (&act.sa_mask); + + /* Do not install handlers if interrupt state is "System". */ + if (__gnat_get_interrupt_state (SIGABRT) != 's') + sigaction (SIGABRT, &act, NULL); + if (__gnat_get_interrupt_state (SIGFPE) != 's') + sigaction (SIGFPE, &act, NULL); + if (__gnat_get_interrupt_state (SIGILL) != 's') + sigaction (SIGILL, &act, NULL); + if (__gnat_get_interrupt_state (SIGSEGV) != 's') + sigaction (SIGSEGV, &act, NULL); + if (__gnat_get_interrupt_state (SIGBUS) != 's') + sigaction (SIGBUS, &act, NULL); + if (__gnat_get_interrupt_state (SIGADAABORT) != 's') + sigaction (SIGADAABORT, &act, NULL); + + __gnat_handler_installed = 1; +} + +/*******************/ +/* LynxOS Section */ +/*******************/ + +#elif defined (__Lynx__) + +#include +#include + +static void +__gnat_error_handler (int sig) +{ + struct Exception_Data *exception; + const char *msg; + + switch(sig) + { + case SIGFPE: + exception = &constraint_error; + msg = "SIGFPE"; + break; + case SIGILL: + exception = &constraint_error; + msg = "SIGILL"; + break; + case SIGSEGV: + exception = &storage_error; + msg = "stack overflow or erroneous memory access"; + break; + case SIGBUS: + exception = &constraint_error; + msg = "SIGBUS"; + break; + default: + exception = &program_error; + msg = "unhandled signal"; + } + + Raise_From_Signal_Handler(exception, msg); +} + +void +__gnat_install_handler(void) +{ + struct sigaction act; + + act.sa_handler = __gnat_error_handler; + act.sa_flags = 0x0; + sigemptyset (&act.sa_mask); + + /* Do not install handlers if interrupt state is "System". */ + if (__gnat_get_interrupt_state (SIGFPE) != 's') + sigaction (SIGFPE, &act, NULL); + if (__gnat_get_interrupt_state (SIGILL) != 's') + sigaction (SIGILL, &act, NULL); + if (__gnat_get_interrupt_state (SIGSEGV) != 's') + sigaction (SIGSEGV, &act, NULL); + if (__gnat_get_interrupt_state (SIGBUS) != 's') + sigaction (SIGBUS, &act, NULL); + + __gnat_handler_installed = 1; +} + +/*******************/ +/* Solaris Section */ +/*******************/ + +#elif defined (sun) && defined (__SVR4) && !defined (__vxworks) + +#include +#include +#include +#include + +/* The code below is common to SPARC and x86. Beware of the delay slot + differences for signal context adjustments. */ + +#if defined (__sparc) +#define RETURN_ADDR_OFFSET 8 +#else +#define RETURN_ADDR_OFFSET 0 +#endif + +static void +__gnat_error_handler (int sig, siginfo_t *si, void *ucontext ATTRIBUTE_UNUSED) +{ + struct Exception_Data *exception; + static int recurse = 0; + const char *msg; + + switch (sig) + { + case SIGSEGV: + /* If the problem was permissions, this is a constraint error. + Likewise if the failing address isn't maximally aligned or if + we've recursed. + + ??? Using a static variable here isn't task-safe, but it's + much too hard to do anything else and we're just determining + which exception to raise. */ + if (si->si_code == SEGV_ACCERR + || (long) si->si_addr == 0 + || (((long) si->si_addr) & 3) != 0 + || recurse) + { + exception = &constraint_error; + msg = "SIGSEGV"; + } + else + { + /* See if the page before the faulting page is accessible. Do that + by trying to access it. We'd like to simply try to access + 4096 + the faulting address, but it's not guaranteed to be + the actual address, just to be on the same page. */ + recurse++; + ((volatile char *) + ((long) si->si_addr & - getpagesize ()))[getpagesize ()]; + exception = &storage_error; + msg = "stack overflow (or erroneous memory access)"; + } + break; + + case SIGBUS: + exception = &program_error; + msg = "SIGBUS"; + break; + + case SIGFPE: + exception = &constraint_error; + msg = "SIGFPE"; + break; + + default: + exception = &program_error; + msg = "unhandled signal"; + } + + recurse = 0; + Raise_From_Signal_Handler (exception, msg); +} + +void +__gnat_install_handler (void) +{ + struct sigaction act; + + /* Set up signal handler to map synchronous signals to appropriate + exceptions. Make sure that the handler isn't interrupted by another + signal that might cause a scheduling event! */ + + act.sa_handler = __gnat_error_handler; + act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO; + sigemptyset (&act.sa_mask); + + /* Do not install handlers if interrupt state is "System". */ + if (__gnat_get_interrupt_state (SIGABRT) != 's') + sigaction (SIGABRT, &act, NULL); + if (__gnat_get_interrupt_state (SIGFPE) != 's') + sigaction (SIGFPE, &act, NULL); + if (__gnat_get_interrupt_state (SIGSEGV) != 's') + sigaction (SIGSEGV, &act, NULL); + if (__gnat_get_interrupt_state (SIGBUS) != 's') + sigaction (SIGBUS, &act, NULL); + + __gnat_handler_installed = 1; +} + +/***************/ +/* VMS Section */ +/***************/ + +#elif defined (VMS) + +/* Routine called from binder to override default feature values. */ +void __gnat_set_features (void); +int __gnat_features_set = 0; + +#ifdef __IA64 +#define lib_get_curr_invo_context LIB$I64_GET_CURR_INVO_CONTEXT +#define lib_get_prev_invo_context LIB$I64_GET_PREV_INVO_CONTEXT +#define lib_get_invo_handle LIB$I64_GET_INVO_HANDLE +#else +#define lib_get_curr_invo_context LIB$GET_CURR_INVO_CONTEXT +#define lib_get_prev_invo_context LIB$GET_PREV_INVO_CONTEXT +#define lib_get_invo_handle LIB$GET_INVO_HANDLE +#endif + +/* Define macro symbols for the VMS conditions that become Ada exceptions. + Most of these are also defined in the header file ssdef.h which has not + yet been converted to be recognized by GNU C. */ + +/* Defining these as macros, as opposed to external addresses, allows + them to be used in a case statement below. */ +#define SS$_ACCVIO 12 +#define SS$_HPARITH 1284 +#define SS$_STKOVF 1364 +#define SS$_RESIGNAL 2328 + +/* These codes are in standard message libraries. */ +extern int C$_SIGKILL; +extern int CMA$_EXIT_THREAD; +extern int SS$_DEBUG; +extern int SS$_INTDIV; +extern int LIB$_KEYNOTFOU; +extern int LIB$_ACTIMAGE; +extern int MTH$_FLOOVEMAT; /* Some ACVC_21 CXA tests */ + +/* These codes are non standard, which is to say the author is + not sure if they are defined in the standard message libraries + so keep them as macros for now. */ +#define RDB$_STREAM_EOF 20480426 +#define FDL$_UNPRIKW 11829410 + +struct cond_except { + const int *cond; + const struct Exception_Data *except; +}; + +struct descriptor_s { + unsigned short len, mbz; + __char_ptr32 adr; +}; + +/* Conditions that don't have an Ada exception counterpart must raise + Non_Ada_Error. Since this is defined in s-auxdec, it should only be + referenced by user programs, not the compiler or tools. Hence the + #ifdef IN_RTS. */ + +#ifdef IN_RTS + +#define Status_Error ada__io_exceptions__status_error +extern struct Exception_Data Status_Error; + +#define Mode_Error ada__io_exceptions__mode_error +extern struct Exception_Data Mode_Error; + +#define Name_Error ada__io_exceptions__name_error +extern struct Exception_Data Name_Error; + +#define Use_Error ada__io_exceptions__use_error +extern struct Exception_Data Use_Error; + +#define Device_Error ada__io_exceptions__device_error +extern struct Exception_Data Device_Error; + +#define End_Error ada__io_exceptions__end_error +extern struct Exception_Data End_Error; + +#define Data_Error ada__io_exceptions__data_error +extern struct Exception_Data Data_Error; + +#define Layout_Error ada__io_exceptions__layout_error +extern struct Exception_Data Layout_Error; + +#define Non_Ada_Error system__aux_dec__non_ada_error +extern struct Exception_Data Non_Ada_Error; + +#define Coded_Exception system__vms_exception_table__coded_exception +extern struct Exception_Data *Coded_Exception (Exception_Code); + +#define Base_Code_In system__vms_exception_table__base_code_in +extern Exception_Code Base_Code_In (Exception_Code); + +/* DEC Ada exceptions are not defined in a header file, so they + must be declared as external addresses. */ + +extern int ADA$_PROGRAM_ERROR; +extern int ADA$_LOCK_ERROR; +extern int ADA$_EXISTENCE_ERROR; +extern int ADA$_KEY_ERROR; +extern int ADA$_KEYSIZERR; +extern int ADA$_STAOVF; +extern int ADA$_CONSTRAINT_ERRO; +extern int ADA$_IOSYSFAILED; +extern int ADA$_LAYOUT_ERROR; +extern int ADA$_STORAGE_ERROR; +extern int ADA$_DATA_ERROR; +extern int ADA$_DEVICE_ERROR; +extern int ADA$_END_ERROR; +extern int ADA$_MODE_ERROR; +extern int ADA$_NAME_ERROR; +extern int ADA$_STATUS_ERROR; +extern int ADA$_NOT_OPEN; +extern int ADA$_ALREADY_OPEN; +extern int ADA$_USE_ERROR; +extern int ADA$_UNSUPPORTED; +extern int ADA$_FAC_MODE_MISMAT; +extern int ADA$_ORG_MISMATCH; +extern int ADA$_RFM_MISMATCH; +extern int ADA$_RAT_MISMATCH; +extern int ADA$_MRS_MISMATCH; +extern int ADA$_MRN_MISMATCH; +extern int ADA$_KEY_MISMATCH; +extern int ADA$_MAXLINEXC; +extern int ADA$_LINEXCMRS; + +/* DEC Ada specific conditions. */ +static const struct cond_except dec_ada_cond_except_table [] = { + {&ADA$_PROGRAM_ERROR, &program_error}, + {&ADA$_USE_ERROR, &Use_Error}, + {&ADA$_KEYSIZERR, &program_error}, + {&ADA$_STAOVF, &storage_error}, + {&ADA$_CONSTRAINT_ERRO, &constraint_error}, + {&ADA$_IOSYSFAILED, &Device_Error}, + {&ADA$_LAYOUT_ERROR, &Layout_Error}, + {&ADA$_STORAGE_ERROR, &storage_error}, + {&ADA$_DATA_ERROR, &Data_Error}, + {&ADA$_DEVICE_ERROR, &Device_Error}, + {&ADA$_END_ERROR, &End_Error}, + {&ADA$_MODE_ERROR, &Mode_Error}, + {&ADA$_NAME_ERROR, &Name_Error}, + {&ADA$_STATUS_ERROR, &Status_Error}, + {&ADA$_NOT_OPEN, &Use_Error}, + {&ADA$_ALREADY_OPEN, &Use_Error}, + {&ADA$_USE_ERROR, &Use_Error}, + {&ADA$_UNSUPPORTED, &Use_Error}, + {&ADA$_FAC_MODE_MISMAT, &Use_Error}, + {&ADA$_ORG_MISMATCH, &Use_Error}, + {&ADA$_RFM_MISMATCH, &Use_Error}, + {&ADA$_RAT_MISMATCH, &Use_Error}, + {&ADA$_MRS_MISMATCH, &Use_Error}, + {&ADA$_MRN_MISMATCH, &Use_Error}, + {&ADA$_KEY_MISMATCH, &Use_Error}, + {&ADA$_MAXLINEXC, &constraint_error}, + {&ADA$_LINEXCMRS, &constraint_error}, + {0, 0} +}; + +#if 0 + /* Already handled by a pragma Import_Exception + in Aux_IO_Exceptions */ + {&ADA$_LOCK_ERROR, &Lock_Error}, + {&ADA$_EXISTENCE_ERROR, &Existence_Error}, + {&ADA$_KEY_ERROR, &Key_Error}, +#endif + +#endif /* IN_RTS */ + +/* Non-DEC Ada specific conditions. We could probably also put + SS$_HPARITH here and possibly SS$_ACCVIO, SS$_STKOVF. */ +static const struct cond_except cond_except_table [] = { + {&MTH$_FLOOVEMAT, &constraint_error}, + {&SS$_INTDIV, &constraint_error}, + {0, 0} +}; + +/* To deal with VMS conditions and their mapping to Ada exceptions, + the __gnat_error_handler routine below is installed as an exception + vector having precedence over DEC frame handlers. Some conditions + still need to be handled by such handlers, however, in which case + __gnat_error_handler needs to return SS$_RESIGNAL. Consider for + instance the use of a third party library compiled with DECAda and + performing its own exception handling internally. + + To allow some user-level flexibility, which conditions should be + resignaled is controlled by a predicate function, provided with the + condition value and returning a boolean indication stating whether + this condition should be resignaled or not. + + That predicate function is called indirectly, via a function pointer, + by __gnat_error_handler, and changing that pointer is allowed to the + user code by way of the __gnat_set_resignal_predicate interface. + + The user level function may then implement what it likes, including + for instance the maintenance of a dynamic data structure if the set + of to be resignalled conditions has to change over the program's + lifetime. + + ??? This is not a perfect solution to deal with the possible + interactions between the GNAT and the DECAda exception handling + models and better (more general) schemes are studied. This is so + just provided as a convenient workaround in the meantime, and + should be use with caution since the implementation has been kept + very simple. */ + +typedef int +resignal_predicate (int code); + +static const int * const cond_resignal_table [] = { + &C$_SIGKILL, + &CMA$_EXIT_THREAD, + &SS$_DEBUG, + &LIB$_KEYNOTFOU, + &LIB$_ACTIMAGE, + (int *) RDB$_STREAM_EOF, + (int *) FDL$_UNPRIKW, + 0 +}; + +static const int facility_resignal_table [] = { + 0x1380000, /* RDB */ + 0x2220000, /* SQL */ + 0 +}; + +/* Default GNAT predicate for resignaling conditions. */ + +static int +__gnat_default_resignal_p (int code) +{ + int i, iexcept; + + for (i = 0; facility_resignal_table [i]; i++) + if ((code & 0xfff0000) == facility_resignal_table [i]) + return 1; + + for (i = 0, iexcept = 0; + cond_resignal_table [i] && + !(iexcept = LIB$MATCH_COND (&code, &cond_resignal_table [i])); + i++); + + return iexcept; +} + +/* Static pointer to predicate that the __gnat_error_handler exception + vector invokes to determine if it should resignal a condition. */ + +static resignal_predicate *__gnat_resignal_p = __gnat_default_resignal_p; + +/* User interface to change the predicate pointer to PREDICATE. Reset to + the default if PREDICATE is null. */ + +void +__gnat_set_resignal_predicate (resignal_predicate *predicate) +{ + if (predicate == NULL) + __gnat_resignal_p = __gnat_default_resignal_p; + else + __gnat_resignal_p = predicate; +} + +/* Should match System.Parameters.Default_Exception_Msg_Max_Length. */ +#define Default_Exception_Msg_Max_Length 512 + +/* Action routine for SYS$PUTMSG. There may be multiple + conditions, each with text to be appended to MESSAGE + and separated by line termination. */ + +static int +copy_msg (struct descriptor_s *msgdesc, char *message) +{ + int len = strlen (message); + int copy_len; + + /* Check for buffer overflow and skip. */ + if (len > 0 && len <= Default_Exception_Msg_Max_Length - 3) + { + strcat (message, "\r\n"); + len += 2; + } + + /* Check for buffer overflow and truncate if necessary. */ + copy_len = (len + msgdesc->len <= Default_Exception_Msg_Max_Length - 1 ? + msgdesc->len : + Default_Exception_Msg_Max_Length - 1 - len); + strncpy (&message [len], msgdesc->adr, copy_len); + message [len + copy_len] = 0; + + return 0; +} + +long +__gnat_handle_vms_condition (int *sigargs, void *mechargs) +{ + struct Exception_Data *exception = 0; + Exception_Code base_code; + struct descriptor_s gnat_facility = {4, 0, "GNAT"}; + char message [Default_Exception_Msg_Max_Length]; + + const char *msg = ""; + + /* Check for conditions to resignal which aren't effected by pragma + Import_Exception. */ + if (__gnat_resignal_p (sigargs [1])) + return SS$_RESIGNAL; + +#ifdef IN_RTS + /* See if it's an imported exception. Beware that registered exceptions + are bound to their base code, with the severity bits masked off. */ + base_code = Base_Code_In ((Exception_Code) sigargs[1]); + exception = Coded_Exception (base_code); + + if (exception) + { + message[0] = 0; + + /* Subtract PC & PSL fields which messes with PUTMSG. */ + sigargs[0] -= 2; + SYS$PUTMSG (sigargs, copy_msg, &gnat_facility, message); + sigargs[0] += 2; + msg = message; + + exception->Name_Length = 19; + /* ??? The full name really should be get sys$getmsg returns. */ + exception->Full_Name = "IMPORTED_EXCEPTION"; + exception->Import_Code = base_code; + +#ifdef __IA64 + /* Do not adjust the program counter as already points to the next + instruction (just after the call to LIB$STOP). */ + Raise_From_Signal_Handler (exception, msg); +#endif + } +#endif + + if (exception == 0) + switch (sigargs[1]) + { + case SS$_ACCVIO: + if (sigargs[3] == 0) + { + exception = &constraint_error; + msg = "access zero"; + } + else + { + exception = &storage_error; + msg = "stack overflow (or erroneous memory access)"; + } + __gnat_adjust_context_for_raise (SS$_ACCVIO, (void *)mechargs); + break; + + case SS$_STKOVF: + exception = &storage_error; + msg = "stack overflow"; + __gnat_adjust_context_for_raise (SS$_STKOVF, (void *)mechargs); + break; + + case SS$_HPARITH: +#ifndef IN_RTS + return SS$_RESIGNAL; /* toplev.c handles for compiler */ +#else + exception = &constraint_error; + msg = "arithmetic error"; + __gnat_adjust_context_for_raise (SS$_HPARITH, (void *)mechargs); +#endif + break; + + default: +#ifdef IN_RTS + { + int i; + + /* Scan the DEC Ada exception condition table for a match and fetch + the associated GNAT exception pointer. */ + for (i = 0; + dec_ada_cond_except_table [i].cond && + !LIB$MATCH_COND (&sigargs [1], + &dec_ada_cond_except_table [i].cond); + i++); + exception = (struct Exception_Data *) + dec_ada_cond_except_table [i].except; + + if (!exception) + { + /* Scan the VMS standard condition table for a match and fetch + the associated GNAT exception pointer. */ + for (i = 0; + cond_except_table[i].cond && + !LIB$MATCH_COND (&sigargs[1], &cond_except_table[i].cond); + i++); + exception = (struct Exception_Data *) + cond_except_table [i].except; + + if (!exception) + /* User programs expect Non_Ada_Error to be raised, reference + DEC Ada test CXCONDHAN. */ + exception = &Non_Ada_Error; + } + } +#else + exception = &program_error; +#endif + message[0] = 0; + /* Subtract PC & PSL fields which messes with PUTMSG. */ + sigargs[0] -= 2; + SYS$PUTMSG (sigargs, copy_msg, &gnat_facility, message); + sigargs[0] += 2; + msg = message; + break; + } + + Raise_From_Signal_Handler (exception, msg); +} + +void +__gnat_install_handler (void) +{ + long prvhnd ATTRIBUTE_UNUSED; + +#if !defined (IN_RTS) + SYS$SETEXV (1, __gnat_handle_vms_condition, 3, &prvhnd); +#endif + + __gnat_handler_installed = 1; +} + +/* __gnat_adjust_context_for_raise for Alpha - see comments along with the + default version later in this file. */ + +#if defined (IN_RTS) && defined (__alpha__) + +#include +#include + +#define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE + +void +__gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) +{ + if (signo == SS$_HPARITH) + { + /* Sub one to the address of the instruction signaling the condition, + located in the sigargs array. */ + + CHF$MECH_ARRAY * mechargs = (CHF$MECH_ARRAY *) ucontext; + CHF$SIGNAL_ARRAY * sigargs + = (CHF$SIGNAL_ARRAY *) mechargs->chf$q_mch_sig_addr; + + int vcount = sigargs->chf$is_sig_args; + int * pc_slot = & (&sigargs->chf$l_sig_name)[vcount-2]; + + (*pc_slot)--; + } +} + +#endif + +/* __gnat_adjust_context_for_raise for ia64. */ + +#if defined (IN_RTS) && defined (__IA64) + +#include +#include + +#define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE + +typedef unsigned long long u64; + +void +__gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) +{ + /* Add one to the address of the instruction signaling the condition, + located in the 64bits sigargs array. */ + + CHF$MECH_ARRAY * mechargs = (CHF$MECH_ARRAY *) ucontext; + + CHF64$SIGNAL_ARRAY *chfsig64 + = (CHF64$SIGNAL_ARRAY *) mechargs->chf$ph_mch_sig64_addr; + + u64 * post_sigarray + = (u64 *)chfsig64 + 1 + chfsig64->chf64$l_sig_args; + + u64 * ih_pc_loc = post_sigarray - 2; + + (*ih_pc_loc) ++; +} + +#endif + +/* Easier interface for LIB$GET_LOGICAL: put the equivalence of NAME into BUF, + always NUL terminated. In case of error or if the result is longer than + LEN (length of BUF) an empty string is written info BUF. */ + +static void +__gnat_vms_get_logical (const char *name, char *buf, int len) +{ + struct descriptor_s name_desc, result_desc; + int status; + unsigned short rlen; + + /* Build the descriptor for NAME. */ + name_desc.len = strlen (name); + name_desc.mbz = 0; + name_desc.adr = (char *)name; + + /* Build the descriptor for the result. */ + result_desc.len = len; + result_desc.mbz = 0; + result_desc.adr = buf; + + status = LIB$GET_LOGICAL (&name_desc, &result_desc, &rlen); + + if ((status & 1) == 1 && rlen < len) + buf[rlen] = 0; + else + buf[0] = 0; +} + +/* Size of a page on ia64 and alpha VMS. */ +#define VMS_PAGESIZE 8192 + +/* User mode. */ +#define PSL__C_USER 3 + +/* No access. */ +#define PRT__C_NA 0 + +/* Descending region. */ +#define VA__M_DESCEND 1 + +/* Get by virtual address. */ +#define VA___REGSUM_BY_VA 1 + +/* Memory region summary. */ +struct regsum +{ + unsigned long long q_region_id; + unsigned int l_flags; + unsigned int l_region_protection; + void *pq_start_va; + unsigned long long q_region_size; + void *pq_first_free_va; +}; + +extern int SYS$GET_REGION_INFO (unsigned int, unsigned long long *, + void *, void *, unsigned int, + void *, unsigned int *); +extern int SYS$EXPREG_64 (unsigned long long *, unsigned long long, + unsigned int, unsigned int, void **, + unsigned long long *); +extern int SYS$SETPRT_64 (void *, unsigned long long, unsigned int, + unsigned int, void **, unsigned long long *, + unsigned int *); +extern int SYS$PUTMSG (void *, int (*)(), void *, unsigned long long); + +/* Add a guard page in the memory region containing ADDR at ADDR +/- SIZE. + (The sign depends on the kind of the memory region). */ + +static int +__gnat_set_stack_guard_page (void *addr, unsigned long size) +{ + int status; + void *ret_va; + unsigned long long ret_len; + unsigned int ret_prot; + void *start_va; + unsigned long long length; + unsigned int retlen; + struct regsum buffer; + + /* Get the region for ADDR. */ + status = SYS$GET_REGION_INFO + (VA___REGSUM_BY_VA, NULL, addr, NULL, sizeof (buffer), &buffer, &retlen); + + if ((status & 1) != 1) + return -1; + + /* Extend the region. */ + status = SYS$EXPREG_64 (&buffer.q_region_id, + size, 0, 0, &start_va, &length); + + if ((status & 1) != 1) + return -1; + + /* Create a guard page. */ + if (!(buffer.l_flags & VA__M_DESCEND)) + start_va = (void *)((unsigned long long)start_va + length - VMS_PAGESIZE); + + status = SYS$SETPRT_64 (start_va, VMS_PAGESIZE, PSL__C_USER, PRT__C_NA, + &ret_va, &ret_len, &ret_prot); + + if ((status & 1) != 1) + return -1; + return 0; +} + +/* Read logicals to limit the stack(s) size. */ + +static void +__gnat_set_stack_limit (void) +{ +#ifdef __ia64__ + void *sp; + unsigned long size; + char value[16]; + char *e; + + /* The main stack. */ + __gnat_vms_get_logical ("GNAT_STACK_SIZE", value, sizeof (value)); + size = strtoul (value, &e, 0); + if (e > value && *e == 0) + { + asm ("mov %0=sp" : "=r" (sp)); + __gnat_set_stack_guard_page (sp, size * 1024); + } + + /* The register stack. */ + __gnat_vms_get_logical ("GNAT_RBS_SIZE", value, sizeof (value)); + size = strtoul (value, &e, 0); + if (e > value && *e == 0) + { + asm ("mov %0=ar.bsp" : "=r" (sp)); + __gnat_set_stack_guard_page (sp, size * 1024); + } +#endif +} + +/* Feature logical name and global variable address pair. + If we ever add another feature logical to this list, the + feature struct will need to be enhanced to take into account + possible values for *gl_addr. */ +struct feature { + const char *name; + int *gl_addr; +}; + +/* Default values for GNAT features set by environment. */ +int __gl_heap_size = 64; + +/* Array feature logical names and global variable addresses. */ +static const struct feature features[] = { + {"GNAT$NO_MALLOC_64", &__gl_heap_size}, + {0, 0} +}; + +void +__gnat_set_features (void) +{ + int i; + char buff[16]; + + /* Loop through features array and test name for enable/disable. */ + for (i = 0; features[i].name; i++) + { + __gnat_vms_get_logical (features[i].name, buff, sizeof (buff)); + + if (strcmp (buff, "ENABLE") == 0 + || strcmp (buff, "TRUE") == 0 + || strcmp (buff, "1") == 0) + *features[i].gl_addr = 32; + else if (strcmp (buff, "DISABLE") == 0 + || strcmp (buff, "FALSE") == 0 + || strcmp (buff, "0") == 0) + *features[i].gl_addr = 64; + } + + /* Features to artificially limit the stack size. */ + __gnat_set_stack_limit (); + + __gnat_features_set = 1; +} + +/*******************/ +/* FreeBSD Section */ +/*******************/ + +#elif defined (__FreeBSD__) + +#include +#include +#include + +static void +__gnat_error_handler (int sig, + siginfo_t *si ATTRIBUTE_UNUSED, + void *ucontext ATTRIBUTE_UNUSED) +{ + struct Exception_Data *exception; + const char *msg; + + switch (sig) + { + case SIGFPE: + exception = &constraint_error; + msg = "SIGFPE"; + break; + + case SIGILL: + exception = &constraint_error; + msg = "SIGILL"; + break; + + case SIGSEGV: + exception = &storage_error; + msg = "stack overflow or erroneous memory access"; + break; + + case SIGBUS: + exception = &constraint_error; + msg = "SIGBUS"; + break; + + default: + exception = &program_error; + msg = "unhandled signal"; + } + + Raise_From_Signal_Handler (exception, msg); +} + +void +__gnat_install_handler () +{ + struct sigaction act; + + /* Set up signal handler to map synchronous signals to appropriate + exceptions. Make sure that the handler isn't interrupted by another + signal that might cause a scheduling event! */ + + act.sa_sigaction + = (void (*)(int, struct __siginfo *, void*)) __gnat_error_handler; + act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO; + (void) sigemptyset (&act.sa_mask); + + (void) sigaction (SIGILL, &act, NULL); + (void) sigaction (SIGFPE, &act, NULL); + (void) sigaction (SIGSEGV, &act, NULL); + (void) sigaction (SIGBUS, &act, NULL); + + __gnat_handler_installed = 1; +} + +/*******************/ +/* VxWorks Section */ +/*******************/ + +#elif defined(__vxworks) + +#include +#include + +#ifndef __RTP__ +#include +#include +#endif + +#ifdef VTHREADS +#include "private/vThreadsP.h" +#endif + +void __gnat_error_handler (int, void *, struct sigcontext *); + +#ifndef __RTP__ + +/* Directly vectored Interrupt routines are not supported when using RTPs. */ + +extern int __gnat_inum_to_ivec (int); + +/* This is needed by the GNAT run time to handle Vxworks interrupts. */ +int +__gnat_inum_to_ivec (int num) +{ + return INUM_TO_IVEC (num); +} +#endif + +#if !defined(__alpha_vxworks) && (_WRS_VXWORKS_MAJOR != 6) && !defined(__RTP__) + +/* getpid is used by s-parint.adb, but is not defined by VxWorks, except + on Alpha VxWorks and VxWorks 6.x (including RTPs). */ + +extern long getpid (void); + +long +getpid (void) +{ + return taskIdSelf (); +} +#endif + +/* VxWorks 653 vThreads expects the field excCnt to be zeroed when a signal is. + handled. The VxWorks version of longjmp does this; GCC's builtin_longjmp + doesn't. */ +void +__gnat_clear_exception_count (void) +{ +#ifdef VTHREADS + WIND_TCB *currentTask = (WIND_TCB *) taskIdSelf(); + + currentTask->vThreads.excCnt = 0; +#endif +} + +/* Handle different SIGnal to exception mappings in different VxWorks + versions. */ +static void +__gnat_map_signal (int sig) +{ + struct Exception_Data *exception; + const char *msg; + + switch (sig) + { + case SIGFPE: + exception = &constraint_error; + msg = "SIGFPE"; + break; +#ifdef VTHREADS +#ifdef __VXWORKSMILS__ + case SIGILL: + exception = &storage_error; + msg = "SIGILL: possible stack overflow"; + break; + case SIGSEGV: + exception = &storage_error; + msg = "SIGSEGV"; + break; + case SIGBUS: + exception = &program_error; + msg = "SIGBUS"; + break; +#else + case SIGILL: + exception = &constraint_error; + msg = "Floating point exception or SIGILL"; + break; + case SIGSEGV: + exception = &storage_error; + msg = "SIGSEGV"; + break; + case SIGBUS: + exception = &storage_error; + msg = "SIGBUS: possible stack overflow"; + break; +#endif +#elif (_WRS_VXWORKS_MAJOR == 6) + case SIGILL: + exception = &constraint_error; + msg = "SIGILL"; + break; +#ifdef __RTP__ + /* In RTP mode a SIGSEGV is most likely due to a stack overflow, + since stack checking uses the probing mechanism. */ + case SIGSEGV: + exception = &storage_error; + msg = "SIGSEGV: possible stack overflow"; + break; + case SIGBUS: + exception = &program_error; + msg = "SIGBUS"; + break; +#else + /* VxWorks 6 kernel mode with probing. SIGBUS for guard page hit */ + case SIGSEGV: + exception = &storage_error; + msg = "SIGSEGV"; + break; + case SIGBUS: + exception = &storage_error; + msg = "SIGBUS: possible stack overflow"; + break; +#endif +#else + /* VxWorks 5: a SIGILL is most likely due to a stack overflow, + since stack checking uses the stack limit mechanism. */ + case SIGILL: + exception = &storage_error; + msg = "SIGILL: possible stack overflow"; + break; + case SIGSEGV: + exception = &storage_error; + msg = "SIGSEGV"; + break; + case SIGBUS: + exception = &program_error; + msg = "SIGBUS"; + break; +#endif + default: + exception = &program_error; + msg = "unhandled signal"; + } + + __gnat_clear_exception_count (); + Raise_From_Signal_Handler (exception, msg); +} + +/* Tasking and Non-tasking signal handler. Map SIGnal to Ada exception + propagation after the required low level adjustments. */ + +void +__gnat_error_handler (int sig, + void *si ATTRIBUTE_UNUSED, + struct sigcontext *sc ATTRIBUTE_UNUSED) +{ + sigset_t mask; + + /* VxWorks will always mask out the signal during the signal handler and + will reenable it on a longjmp. GNAT does not generate a longjmp to + return from a signal handler so the signal will still be masked unless + we unmask it. */ + sigprocmask (SIG_SETMASK, NULL, &mask); + sigdelset (&mask, sig); + sigprocmask (SIG_SETMASK, &mask, NULL); + + __gnat_map_signal (sig); +} + +void +__gnat_install_handler (void) +{ + struct sigaction act; + + /* Setup signal handler to map synchronous signals to appropriate + exceptions. Make sure that the handler isn't interrupted by another + signal that might cause a scheduling event! */ + + act.sa_handler = __gnat_error_handler; + act.sa_flags = SA_SIGINFO | SA_ONSTACK; + sigemptyset (&act.sa_mask); + + /* For VxWorks, install all signal handlers, since pragma Interrupt_State + applies to vectored hardware interrupts, not signals. */ + sigaction (SIGFPE, &act, NULL); + sigaction (SIGILL, &act, NULL); + sigaction (SIGSEGV, &act, NULL); + sigaction (SIGBUS, &act, NULL); + + __gnat_handler_installed = 1; +} + +#define HAVE_GNAT_INIT_FLOAT + +void +__gnat_init_float (void) +{ + /* Disable overflow/underflow exceptions on the PPC processor, needed + to get correct Ada semantics. Note that for AE653 vThreads, the HW + overflow settings are an OS configuration issue. The instructions + below have no effect. */ +#if defined (_ARCH_PPC) && !defined (_SOFT_FLOAT) && !defined (VTHREADS) +#if defined (__SPE__) + { + const unsigned long spefscr_mask = 0xfffffff3; + unsigned long spefscr; + asm ("mfspr %0, 512" : "=r" (spefscr)); + spefscr = spefscr & spefscr_mask; + asm ("mtspr 512, %0\n\tisync" : : "r" (spefscr)); + } +#else + asm ("mtfsb0 25"); + asm ("mtfsb0 26"); +#endif +#endif + +#if (defined (__i386__) || defined (i386)) && !defined (VTHREADS) + /* This is used to properly initialize the FPU on an x86 for each + process thread. */ + asm ("finit"); +#endif + + /* Similarly for SPARC64. Achieved by masking bits in the Trap Enable Mask + field of the Floating-point Status Register (see the SPARC Architecture + Manual Version 9, p 48). */ +#if defined (sparc64) + +#define FSR_TEM_NVM (1 << 27) /* Invalid operand */ +#define FSR_TEM_OFM (1 << 26) /* Overflow */ +#define FSR_TEM_UFM (1 << 25) /* Underflow */ +#define FSR_TEM_DZM (1 << 24) /* Division by Zero */ +#define FSR_TEM_NXM (1 << 23) /* Inexact result */ + { + unsigned int fsr; + + __asm__("st %%fsr, %0" : "=m" (fsr)); + fsr &= ~(FSR_TEM_OFM | FSR_TEM_UFM); + __asm__("ld %0, %%fsr" : : "m" (fsr)); + } +#endif +} + +/* This subprogram is called by System.Task_Primitives.Operations.Enter_Task + (if not null) when a new task is created. It is initialized by + System.Stack_Checking.Operations.Initialize_Stack_Limit. + The use of a hook avoids to drag stack checking subprograms if stack + checking is not used. */ +void (*__gnat_set_stack_limit_hook)(void) = (void (*)(void))0; + +/******************/ +/* NetBSD Section */ +/******************/ + +#elif defined(__NetBSD__) + +#include +#include + +static void +__gnat_error_handler (int sig) +{ + struct Exception_Data *exception; + const char *msg; + + switch(sig) + { + case SIGFPE: + exception = &constraint_error; + msg = "SIGFPE"; + break; + case SIGILL: + exception = &constraint_error; + msg = "SIGILL"; + break; + case SIGSEGV: + exception = &storage_error; + msg = "stack overflow or erroneous memory access"; + break; + case SIGBUS: + exception = &constraint_error; + msg = "SIGBUS"; + break; + default: + exception = &program_error; + msg = "unhandled signal"; + } + + Raise_From_Signal_Handler(exception, msg); +} + +void +__gnat_install_handler(void) +{ + struct sigaction act; + + act.sa_handler = __gnat_error_handler; + act.sa_flags = SA_NODEFER | SA_RESTART; + sigemptyset (&act.sa_mask); + + /* Do not install handlers if interrupt state is "System". */ + if (__gnat_get_interrupt_state (SIGFPE) != 's') + sigaction (SIGFPE, &act, NULL); + if (__gnat_get_interrupt_state (SIGILL) != 's') + sigaction (SIGILL, &act, NULL); + if (__gnat_get_interrupt_state (SIGSEGV) != 's') + sigaction (SIGSEGV, &act, NULL); + if (__gnat_get_interrupt_state (SIGBUS) != 's') + sigaction (SIGBUS, &act, NULL); + + __gnat_handler_installed = 1; +} + +/*******************/ +/* OpenBSD Section */ +/*******************/ + +#elif defined(__OpenBSD__) + +#include +#include + +static void +__gnat_error_handler (int sig) +{ + struct Exception_Data *exception; + const char *msg; + + switch(sig) + { + case SIGFPE: + exception = &constraint_error; + msg = "SIGFPE"; + break; + case SIGILL: + exception = &constraint_error; + msg = "SIGILL"; + break; + case SIGSEGV: + exception = &storage_error; + msg = "stack overflow or erroneous memory access"; + break; + case SIGBUS: + exception = &constraint_error; + msg = "SIGBUS"; + break; + default: + exception = &program_error; + msg = "unhandled signal"; + } + + Raise_From_Signal_Handler(exception, msg); +} + +void +__gnat_install_handler(void) +{ + struct sigaction act; + + act.sa_handler = __gnat_error_handler; + act.sa_flags = SA_NODEFER | SA_RESTART; + sigemptyset (&act.sa_mask); + + /* Do not install handlers if interrupt state is "System" */ + if (__gnat_get_interrupt_state (SIGFPE) != 's') + sigaction (SIGFPE, &act, NULL); + if (__gnat_get_interrupt_state (SIGILL) != 's') + sigaction (SIGILL, &act, NULL); + if (__gnat_get_interrupt_state (SIGSEGV) != 's') + sigaction (SIGSEGV, &act, NULL); + if (__gnat_get_interrupt_state (SIGBUS) != 's') + sigaction (SIGBUS, &act, NULL); + + __gnat_handler_installed = 1; +} + +/******************/ +/* Darwin Section */ +/******************/ + +#elif defined(__APPLE__) + +#include +#include +#include +#include +#include +#include +#include + +/* This must be in keeping with System.OS_Interface.Alternate_Stack_Size. */ +char __gnat_alternate_stack[32 * 1024]; /* 1 * MINSIGSTKSZ */ + +/* Defined in xnu unix_signal.c. + Tell the kernel to re-use alt stack when delivering a signal. */ +#define UC_RESET_ALT_STACK 0x80000000 + +/* Return true if ADDR is within a stack guard area. */ +static int +__gnat_is_stack_guard (mach_vm_address_t addr) +{ + kern_return_t kret; + vm_region_submap_info_data_64_t info; + mach_vm_address_t start; + mach_vm_size_t size; + natural_t depth; + mach_msg_type_number_t count; + + count = VM_REGION_SUBMAP_INFO_COUNT_64; + start = addr; + size = -1; + depth = 9999; + kret = mach_vm_region_recurse (mach_task_self (), &start, &size, &depth, + (vm_region_recurse_info_t) &info, &count); + if (kret == KERN_SUCCESS + && addr >= start && addr < (start + size) + && info.protection == VM_PROT_NONE + && info.user_tag == VM_MEMORY_STACK) + return 1; + return 0; +} + +#define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE + +#if defined (__x86_64__) +static int +__darwin_major_version (void) +{ + static int cache = -1; + if (cache < 0) + { + int mib[2] = {CTL_KERN, KERN_OSRELEASE}; + size_t len; + + /* Find out how big the buffer needs to be (and set cache to 0 + on failure). */ + if (sysctl (mib, 2, NULL, &len, NULL, 0) == 0) + { + char release[len]; + sysctl (mib, 2, release, &len, NULL, 0); + /* Darwin releases are of the form L.M.N where L is the major + version, so strtol will return L. */ + cache = (int) strtol (release, NULL, 10); + } + else + { + cache = 0; + } + } + return cache; +} +#endif + +void +__gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, + void *ucontext ATTRIBUTE_UNUSED) +{ +#if defined (__x86_64__) + if (__darwin_major_version () < 12) + { + /* Work around radar #10302855, where the unwinders (libunwind or + libgcc_s depending on the system revision) and the DWARF unwind + data for sigtramp have different ideas about register numbering, + causing rbx and rdx to be transposed. */ + ucontext_t *uc = (ucontext_t *)ucontext; + unsigned long t = uc->uc_mcontext->__ss.__rbx; + + uc->uc_mcontext->__ss.__rbx = uc->uc_mcontext->__ss.__rdx; + uc->uc_mcontext->__ss.__rdx = t; + } +#endif +} + +static void +__gnat_error_handler (int sig, siginfo_t *si, void *ucontext) +{ + struct Exception_Data *exception; + const char *msg; + + __gnat_adjust_context_for_raise (sig, ucontext); + + switch (sig) + { + case SIGSEGV: + case SIGBUS: + if (__gnat_is_stack_guard ((unsigned long)si->si_addr)) + { + exception = &storage_error; + msg = "stack overflow"; + } + else + { + exception = &constraint_error; + msg = "erroneous memory access"; + } + /* Reset the use of alt stack, so that the alt stack will be used + for the next signal delivery. + The stack can't be used in case of stack checking. */ + syscall (SYS_sigreturn, NULL, UC_RESET_ALT_STACK); + break; + + case SIGFPE: + exception = &constraint_error; + msg = "SIGFPE"; + break; + + default: + exception = &program_error; + msg = "unhandled signal"; + } + + Raise_From_Signal_Handler (exception, msg); +} + +void +__gnat_install_handler (void) +{ + struct sigaction act; + + /* Set up signal handler to map synchronous signals to appropriate + exceptions. Make sure that the handler isn't interrupted by another + signal that might cause a scheduling event! Also setup an alternate + stack region for the handler execution so that stack overflows can be + handled properly, avoiding a SEGV generation from stack usage by the + handler itself (and it is required by Darwin). */ + + stack_t stack; + stack.ss_sp = __gnat_alternate_stack; + stack.ss_size = sizeof (__gnat_alternate_stack); + stack.ss_flags = 0; + sigaltstack (&stack, NULL); + + act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO; + act.sa_sigaction = __gnat_error_handler; + sigemptyset (&act.sa_mask); + + /* Do not install handlers if interrupt state is "System". */ + if (__gnat_get_interrupt_state (SIGABRT) != 's') + sigaction (SIGABRT, &act, NULL); + if (__gnat_get_interrupt_state (SIGFPE) != 's') + sigaction (SIGFPE, &act, NULL); + if (__gnat_get_interrupt_state (SIGILL) != 's') + sigaction (SIGILL, &act, NULL); + + act.sa_flags |= SA_ONSTACK; + if (__gnat_get_interrupt_state (SIGSEGV) != 's') + sigaction (SIGSEGV, &act, NULL); + if (__gnat_get_interrupt_state (SIGBUS) != 's') + sigaction (SIGBUS, &act, NULL); + + __gnat_handler_installed = 1; +} + +#else + +/* For all other versions of GNAT, the handler does nothing. */ + +/*******************/ +/* Default Section */ +/*******************/ + +void +__gnat_install_handler (void) +{ + __gnat_handler_installed = 1; +} + +#endif + +/*********************/ +/* __gnat_init_float */ +/*********************/ + +/* This routine is called as each process thread is created, for possible + initialization of the FP processor. This version is used under INTERIX + and WIN32. */ + +#if defined (_WIN32) || defined (__INTERIX) \ + || defined (__Lynx__) || defined(__NetBSD__) || defined(__FreeBSD__) \ + || defined (__OpenBSD__) + +#define HAVE_GNAT_INIT_FLOAT + +void +__gnat_init_float (void) +{ +#if defined (__i386__) || defined (i386) || defined (__x86_64) + + /* This is used to properly initialize the FPU on an x86 for each + process thread. */ + + asm ("finit"); + +#endif /* Defined __i386__ */ +} +#endif + +#ifndef HAVE_GNAT_INIT_FLOAT + +/* All targets without a specific __gnat_init_float will use an empty one. */ +void +__gnat_init_float (void) +{ +} +#endif + +/***********************************/ +/* __gnat_adjust_context_for_raise */ +/***********************************/ + +#ifndef HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE + +/* All targets without a specific version will use an empty one. */ + +/* Given UCONTEXT a pointer to a context structure received by a signal + handler for SIGNO, perform the necessary adjustments to let the handler + raise an exception. Calls to this routine are not conditioned by the + propagation scheme in use. */ + +void +__gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, + void *ucontext ATTRIBUTE_UNUSED) +{ + /* We used to compensate here for the raised from call vs raised from signal + exception discrepancy with the GCC ZCX scheme, but this now can be dealt + with generically in the unwinder (see GCC PR other/26208). This however + requires the use of the _Unwind_GetIPInfo routine in raise-gcc.c, which + is predicated on the definition of HAVE_GETIPINFO at compile time. Only + the VMS ports still do the compensation described in the few lines below. + + *** Call vs signal exception discrepancy with GCC ZCX scheme *** + + The GCC unwinder expects to be dealing with call return addresses, since + this is the "nominal" case of what we retrieve while unwinding a regular + call chain. + + To evaluate if a handler applies at some point identified by a return + address, the propagation engine needs to determine what region the + corresponding call instruction pertains to. Because the return address + may not be attached to the same region as the call, the unwinder always + subtracts "some" amount from a return address to search the region + tables, amount chosen to ensure that the resulting address is inside the + call instruction. + + When we raise an exception from a signal handler, e.g. to transform a + SIGSEGV into Storage_Error, things need to appear as if the signal + handler had been "called" by the instruction which triggered the signal, + so that exception handlers that apply there are considered. What the + unwinder will retrieve as the return address from the signal handler is + what it will find as the faulting instruction address in the signal + context pushed by the kernel. Leaving this address untouched looses, if + the triggering instruction happens to be the very first of a region, as + the later adjustments performed by the unwinder would yield an address + outside that region. We need to compensate for the unwinder adjustments + at some point, and this is what this routine is expected to do. + + signo is passed because on some targets for some signals the PC in + context points to the instruction after the faulting one, in which case + the unwinder adjustment is still desired. */ +} + +#endif diff --git a/gcc/ada/initialize.c b/gcc/ada/initialize.c new file mode 100644 index 000000000..32ea0e5c7 --- /dev/null +++ b/gcc/ada/initialize.c @@ -0,0 +1,362 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * I N I T I A L I Z E * + * * + * C Implementation File * + * * + * Copyright (C) 1992-2009, Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. * + * * + * As a special exception under Section 7 of GPL version 3, you are granted * + * additional permissions described in the GCC Runtime Library Exception, * + * version 3.1, as published by the Free Software Foundation. * + * * + * You should have received a copy of the GNU General Public License and * + * a copy of the GCC Runtime Library Exception along with this program; * + * see the files COPYING3 and COPYING.RUNTIME respectively. If 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 default implementation for __gnat_initialize () + which is called before the elaboration of the partition. It is provided + in a separate file/object so that users can replace it easily. + The default implementation should be null on most targets. */ + +/* The following include is here to meet the published VxWorks requirement + that the __vxworks header appear before any other include. */ +#ifdef __vxworks +#include "vxWorks.h" +#endif + +#ifdef IN_RTS +#include "tconfig.h" +#include "tsystem.h" +/* We don't have libiberty, so use malloc. */ +#define xmalloc(S) malloc (S) +#define xrealloc(V,S) realloc (V,S) +#else +#include "config.h" +#include "system.h" +#endif + +#include "raise.h" + +/******************************************/ +/* __gnat_initialize (NT-mingw32 Version) */ +/******************************************/ + +#if defined (__MINGW32__) +#include "mingw32.h" +#include + +extern void __gnat_init_float (void); +extern void __gnat_install_SEH_handler (void *); + +extern int gnat_argc; +extern char **gnat_argv; + +#ifdef GNAT_UNICODE_SUPPORT + +#define EXPAND_ARGV_RATE 128 + +static void +append_arg (int *index, LPWSTR dir, LPWSTR value, + char ***argv, int *last, int quoted) +{ + int size; + LPWSTR fullvalue; + int vallen = _tcslen (value); + int dirlen; + + if (dir == NULL) + { + /* no dir prefix */ + dirlen = 0; + fullvalue = xmalloc ((vallen + 1) * sizeof(TCHAR)); + } + else + { + /* Add dir first */ + dirlen = _tcslen (dir); + + fullvalue = xmalloc ((dirlen + vallen + 1) * sizeof(TCHAR)); + _tcscpy (fullvalue, dir); + } + + /* Append value */ + + if (quoted) + { + _tcsncpy (fullvalue + dirlen, value + 1, vallen - 1); + fullvalue [dirlen + vallen - sizeof(TCHAR)] = _T('\0'); + } + else + _tcscpy (fullvalue + dirlen, value); + + if (*last <= *index) + { + *last += EXPAND_ARGV_RATE; + *argv = (char **) xrealloc (*argv, (*last) * sizeof (char *)); + } + + size = WS2SC (NULL, fullvalue, 0); + (*argv)[*index] = (char *) xmalloc (size + sizeof(TCHAR)); + WS2SC ((*argv)[*index], fullvalue, size); + + free (fullvalue); + + (*index)++; +} +#endif + +void +__gnat_initialize (void *eh ATTRIBUTE_UNUSED) +{ + /* Initialize floating-point coprocessor. This call is needed because + the MS libraries default to 64-bit precision instead of 80-bit + precision, and we require the full precision for proper operation, + given that we have set Max_Digits etc with this in mind */ + __gnat_init_float (); + +#ifdef GNAT_UNICODE_SUPPORT + /* Set current code page for filenames handling. */ + { + char *codepage = getenv ("GNAT_CODE_PAGE"); + + /* Default code page is UTF-8. */ + CurrentCodePage = CP_UTF8; + + if (codepage != NULL) + { + if (strcmp (codepage, "CP_ACP") == 0) + CurrentCodePage = CP_ACP; + else if (strcmp (codepage, "CP_UTF8") == 0) + CurrentCodePage = CP_UTF8; + } + } + + /* Adjust gnat_argv to support Unicode characters. */ + { + LPWSTR *wargv; + int wargc; + int k; + int last; + int argc_expanded = 0; + TCHAR result [MAX_PATH]; + int quoted; + + wargv = CommandLineToArgvW (GetCommandLineW(), &wargc); + + if (wargv != NULL) + { + /* Set gnat_argv with arguments encoded in UTF-8. */ + last = wargc + 1; + gnat_argv = (char **) xmalloc ((last) * sizeof (char *)); + + /* argv[0] is the executable full path-name. */ + + SearchPath (NULL, wargv[0], _T(".exe"), MAX_PATH, result, NULL); + append_arg (&argc_expanded, NULL, result, &gnat_argv, &last, 0); + + for (k=1; k= 3) && (defined (_ARCH_PPC) || defined (__ppc)) + { + /* The scheme described above is only useful for the actual ZCX case, and + we don't want any reference to the crt provided symbols otherwise. We + may not link with any of the crt objects in the non-ZCX case, e.g. from + documented procedures instructing the use of -nostdlib, and references + to the ctors symbols here would just remain unsatisfied. + + We have no way to avoid those references in the right conditions in this + C module, because we have nothing like a IN_ZCX_RTS macro. This aspect + is then deferred to an Ada routine, which can do that based on a test + against a constant System flag value. */ + + extern void __gnat_vxw_setup_for_eh (void); + __gnat_vxw_setup_for_eh (); + } +#endif +} + +#elif defined(_T_HPUX10) || (!defined(IN_RTS) && defined(_X_HPUX10)) + +/************************************************/ +/* __gnat_initialize (PA-RISC HP-UX 10 Version) */ +/************************************************/ + +extern void __main (void); + +void +__gnat_initialize (void *eh ATTRIBUTE_UNUSED) +{ + __main (); +} + +#else + +/* For all other versions of GNAT, the initialize routine and handler + installation do nothing */ + +/***************************************/ +/* __gnat_initialize (Default Version) */ +/***************************************/ + +void +__gnat_initialize (void *eh ATTRIBUTE_UNUSED) +{ +} + +#endif diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb new file mode 100644 index 000000000..f40edd92d --- /dev/null +++ b/gcc/ada/inline.adb @@ -0,0 +1,1233 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N L I N E -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Ch7; use Exp_Ch7; +with Exp_Tss; use Exp_Tss; +with Fname; use Fname; +with Fname.UF; use Fname.UF; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Sem_Aux; use Sem_Aux; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch10; use Sem_Ch10; +with Sem_Ch12; use Sem_Ch12; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Uname; use Uname; + +package body Inline is + + -------------------- + -- Inlined Bodies -- + -------------------- + + -- Inlined functions are actually placed in line by the backend if the + -- corresponding bodies are available (i.e. compiled). Whenever we find + -- a call to an inlined subprogram, we add the name of the enclosing + -- compilation unit to a worklist. After all compilation, and after + -- expansion of generic bodies, we traverse the list of pending bodies + -- and compile them as well. + + package Inlined_Bodies is new Table.Table ( + Table_Component_Type => Entity_Id, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.Inlined_Bodies_Initial, + Table_Increment => Alloc.Inlined_Bodies_Increment, + Table_Name => "Inlined_Bodies"); + + ----------------------- + -- Inline Processing -- + ----------------------- + + -- For each call to an inlined subprogram, we make entries in a table + -- that stores caller and callee, and indicates a prerequisite from + -- one to the other. We also record the compilation unit that contains + -- the callee. After analyzing the bodies of all such compilation units, + -- we produce a list of subprograms in topological order, for use by the + -- back-end. If P2 is a prerequisite of P1, then P1 calls P2, and for + -- proper inlining the back-end must analyze the body of P2 before that of + -- P1. The code below guarantees that the transitive closure of inlined + -- subprograms called from the main compilation unit is made available to + -- the code generator. + + Last_Inlined : Entity_Id := Empty; + + -- For each entry in the table we keep a list of successors in topological + -- order, i.e. callers of the current subprogram. + + type Subp_Index is new Nat; + No_Subp : constant Subp_Index := 0; + + -- The subprogram entities are hashed into the Inlined table + + Num_Hash_Headers : constant := 512; + + Hash_Headers : array (Subp_Index range 0 .. Num_Hash_Headers - 1) + of Subp_Index; + + type Succ_Index is new Nat; + No_Succ : constant Succ_Index := 0; + + type Succ_Info is record + Subp : Subp_Index; + Next : Succ_Index; + end record; + + -- The following table stores list elements for the successor lists. + -- These lists cannot be chained directly through entries in the Inlined + -- table, because a given subprogram can appear in several such lists. + + package Successors is new Table.Table ( + Table_Component_Type => Succ_Info, + Table_Index_Type => Succ_Index, + Table_Low_Bound => 1, + Table_Initial => Alloc.Successors_Initial, + Table_Increment => Alloc.Successors_Increment, + Table_Name => "Successors"); + + type Subp_Info is record + Name : Entity_Id := Empty; + First_Succ : Succ_Index := No_Succ; + Count : Integer := 0; + Listed : Boolean := False; + Main_Call : Boolean := False; + Next : Subp_Index := No_Subp; + Next_Nopred : Subp_Index := No_Subp; + end record; + + package Inlined is new Table.Table ( + Table_Component_Type => Subp_Info, + Table_Index_Type => Subp_Index, + Table_Low_Bound => 1, + Table_Initial => Alloc.Inlined_Initial, + Table_Increment => Alloc.Inlined_Increment, + Table_Name => "Inlined"); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Scope_In_Main_Unit (Scop : Entity_Id) return Boolean; + -- Return True if Scop is in the main unit or its spec + + procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty); + -- Make two entries in Inlined table, for an inlined subprogram being + -- called, and for the inlined subprogram that contains the call. If + -- the call is in the main compilation unit, Caller is Empty. + + function Add_Subp (E : Entity_Id) return Subp_Index; + -- Make entry in Inlined table for subprogram E, or return table index + -- that already holds E. + + function Has_Initialized_Type (E : Entity_Id) return Boolean; + -- If a candidate for inlining contains type declarations for types with + -- non-trivial initialization procedures, they are not worth inlining. + + function Is_Nested (E : Entity_Id) return Boolean; + -- If the function is nested inside some other function, it will + -- always be compiled if that function is, so don't add it to the + -- inline list. We cannot compile a nested function outside the + -- scope of the containing function anyway. This is also the case if + -- the function is defined in a task body or within an entry (for + -- example, an initialization procedure). + + procedure Add_Inlined_Subprogram (Index : Subp_Index); + -- Add subprogram to Inlined List once all of its predecessors have been + -- placed on the list. Decrement the count of all its successors, and + -- add them to list (recursively) if count drops to zero. + + ------------------------------ + -- Deferred Cleanup Actions -- + ------------------------------ + + -- The cleanup actions for scopes that contain instantiations is delayed + -- until after expansion of those instantiations, because they may + -- contain finalizable objects or tasks that affect the cleanup code. + -- A scope that contains instantiations only needs to be finalized once, + -- even if it contains more than one instance. We keep a list of scopes + -- that must still be finalized, and call cleanup_actions after all the + -- instantiations have been completed. + + To_Clean : Elist_Id; + + procedure Add_Scope_To_Clean (Inst : Entity_Id); + -- Build set of scopes on which cleanup actions must be performed + + procedure Cleanup_Scopes; + -- Complete cleanup actions on scopes that need it + + -------------- + -- Add_Call -- + -------------- + + procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty) is + P1 : constant Subp_Index := Add_Subp (Called); + P2 : Subp_Index; + J : Succ_Index; + + begin + if Present (Caller) then + P2 := Add_Subp (Caller); + + -- Add P2 to the list of successors of P1, if not already there. + -- Note that P2 may contain more than one call to P1, and only + -- one needs to be recorded. + + J := Inlined.Table (P1).First_Succ; + while J /= No_Succ loop + if Successors.Table (J).Subp = P2 then + return; + end if; + + J := Successors.Table (J).Next; + end loop; + + -- On exit, make a successor entry for P2 + + Successors.Increment_Last; + Successors.Table (Successors.Last).Subp := P2; + Successors.Table (Successors.Last).Next := + Inlined.Table (P1).First_Succ; + Inlined.Table (P1).First_Succ := Successors.Last; + + Inlined.Table (P2).Count := Inlined.Table (P2).Count + 1; + + else + Inlined.Table (P1).Main_Call := True; + end if; + end Add_Call; + + ---------------------- + -- Add_Inlined_Body -- + ---------------------- + + procedure Add_Inlined_Body (E : Entity_Id) is + Pack : Entity_Id; + + function Must_Inline return Boolean; + -- Inlining is only done if the call statement N is in the main unit, + -- or within the body of another inlined subprogram. + + ----------------- + -- Must_Inline -- + ----------------- + + function Must_Inline return Boolean is + Scop : Entity_Id; + Comp : Node_Id; + + begin + -- Check if call is in main unit + + Scop := Current_Scope; + + -- Do not try to inline if scope is standard. This could happen, for + -- example, for a call to Add_Global_Declaration, and it causes + -- trouble to try to inline at this level. + + if Scop = Standard_Standard then + return False; + end if; + + -- Otherwise lookup scope stack to outer scope + + while Scope (Scop) /= Standard_Standard + and then not Is_Child_Unit (Scop) + loop + Scop := Scope (Scop); + end loop; + + Comp := Parent (Scop); + while Nkind (Comp) /= N_Compilation_Unit loop + Comp := Parent (Comp); + end loop; + + if Comp = Cunit (Main_Unit) + or else Comp = Library_Unit (Cunit (Main_Unit)) + then + Add_Call (E); + return True; + end if; + + -- Call is not in main unit. See if it's in some inlined subprogram + + Scop := Current_Scope; + while Scope (Scop) /= Standard_Standard + and then not Is_Child_Unit (Scop) + loop + if Is_Overloadable (Scop) + and then Is_Inlined (Scop) + then + Add_Call (E, Scop); + return True; + end if; + + Scop := Scope (Scop); + end loop; + + return False; + end Must_Inline; + + -- Start of processing for Add_Inlined_Body + + begin + -- Find unit containing E, and add to list of inlined bodies if needed. + -- If the body is already present, no need to load any other unit. This + -- is the case for an initialization procedure, which appears in the + -- package declaration that contains the type. It is also the case if + -- the body has already been analyzed. Finally, if the unit enclosing + -- E is an instance, the instance body will be analyzed in any case, + -- and there is no need to add the enclosing unit (whose body might not + -- be available). + + -- Library-level functions must be handled specially, because there is + -- no enclosing package to retrieve. In this case, it is the body of + -- the function that will have to be loaded. + + if not Is_Abstract_Subprogram (E) and then not Is_Nested (E) + and then Convention (E) /= Convention_Protected + then + Pack := Scope (E); + + if Must_Inline + and then Ekind (Pack) = E_Package + then + Set_Is_Called (E); + + if Pack = Standard_Standard then + + -- Library-level inlined function. Add function itself to + -- list of needed units. + + Inlined_Bodies.Increment_Last; + Inlined_Bodies.Table (Inlined_Bodies.Last) := E; + + elsif Is_Generic_Instance (Pack) then + null; + + elsif not Is_Inlined (Pack) + and then not Has_Completion (E) + then + Set_Is_Inlined (Pack); + Inlined_Bodies.Increment_Last; + Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack; + end if; + end if; + end if; + end Add_Inlined_Body; + + ---------------------------- + -- Add_Inlined_Subprogram -- + ---------------------------- + + procedure Add_Inlined_Subprogram (Index : Subp_Index) is + E : constant Entity_Id := Inlined.Table (Index).Name; + Pack : constant Entity_Id := Cunit_Entity (Get_Code_Unit (E)); + Succ : Succ_Index; + Subp : Subp_Index; + + function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean; + -- There are various conditions under which back-end inlining cannot + -- be done reliably: + -- + -- a) If a body has handlers, it must not be inlined, because this + -- may violate program semantics, and because in zero-cost exception + -- mode it will lead to undefined symbols at link time. + -- + -- b) If a body contains inlined function instances, it cannot be + -- inlined under ZCX because the numeric suffix generated by gigi + -- will be different in the body and the place of the inlined call. + -- + -- If the body to be inlined contains calls to subprograms declared + -- in the same body that have no previous spec, the back-end cannot + -- inline either because the bodies to be inlined are processed before + -- the rest of the enclosing package body, and gigi will then find + -- references to entities that have not been elaborated yet. + -- + -- This procedure must be carefully coordinated with the back end. + + ---------------------------- + -- Back_End_Cannot_Inline -- + ---------------------------- + + function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean is + Decl : constant Node_Id := Unit_Declaration_Node (Subp); + Body_Ent : Entity_Id; + Ent : Entity_Id; + Bad_Call : Node_Id; + + function Process (N : Node_Id) return Traverse_Result; + -- Look for calls to subprograms with no previous spec, declared + -- in the same enclosing package body. + + ------------- + -- Process -- + ------------- + + function Process (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Procedure_Call_Statement + or else Nkind (N) = N_Function_Call + then + if Is_Entity_Name (Name (N)) + and then Comes_From_Source (Entity (Name (N))) + and then + Nkind (Unit_Declaration_Node (Entity (Name (N)))) + = N_Subprogram_Body + and then In_Same_Extended_Unit (Subp, Entity (Name (N))) + then + Bad_Call := N; + return Abandon; + else + return OK; + end if; + else + return OK; + end if; + end Process; + + function Has_Exposed_Call is new Traverse_Func (Process); + + -- Start of processing for Back_End_Cannot_Inline + + begin + if Nkind (Decl) = N_Subprogram_Declaration + and then Present (Corresponding_Body (Decl)) + then + Body_Ent := Corresponding_Body (Decl); + else + return False; + end if; + + -- If subprogram is marked Inline_Always, inlining is mandatory + + if Has_Pragma_Inline_Always (Subp) then + return False; + end if; + + if Present + (Exception_Handlers + (Handled_Statement_Sequence + (Unit_Declaration_Node (Corresponding_Body (Decl))))) + then + return True; + end if; + + Ent := First_Entity (Body_Ent); + while Present (Ent) loop + if Is_Subprogram (Ent) + and then Is_Generic_Instance (Ent) + then + return True; + end if; + + Next_Entity (Ent); + end loop; + + if Has_Exposed_Call + (Unit_Declaration_Node (Corresponding_Body (Decl))) = Abandon + then + if Ineffective_Inline_Warnings then + Error_Msg_N + ("?call to subprogram with no separate spec" + & " prevents inlining!!", Bad_Call); + end if; + + return True; + else + return False; + end if; + end Back_End_Cannot_Inline; + + -- Start of processing for Add_Inlined_Subprogram + + begin + -- Insert the current subprogram in the list of inlined subprograms, if + -- it can actually be inlined by the back-end, and if its unit is known + -- to be inlined, or is an instance whose body will be analyzed anyway. + + if (Is_Inlined (Pack) or else Is_Generic_Instance (Pack)) + and then not Scope_In_Main_Unit (E) + and then Is_Inlined (E) + and then not Is_Nested (E) + and then not Has_Initialized_Type (E) + then + if Back_End_Cannot_Inline (E) then + Set_Is_Inlined (E, False); + + else + if No (Last_Inlined) then + Set_First_Inlined_Subprogram (Cunit (Main_Unit), E); + else + Set_Next_Inlined_Subprogram (Last_Inlined, E); + end if; + + Last_Inlined := E; + end if; + end if; + + Inlined.Table (Index).Listed := True; + + -- Now add to the list those callers of the current subprogram that + -- are themselves called. They may appear on the graph as callers + -- of the current one, even if they are themselves not called, and + -- there is no point in including them in the list for the backend. + -- Furthermore, they might not even be public, in which case the + -- back-end cannot handle them at all. + + Succ := Inlined.Table (Index).First_Succ; + while Succ /= No_Succ loop + Subp := Successors.Table (Succ).Subp; + Inlined.Table (Subp).Count := Inlined.Table (Subp).Count - 1; + + if Inlined.Table (Subp).Count = 0 + and then Is_Called (Inlined.Table (Subp).Name) + then + Add_Inlined_Subprogram (Subp); + end if; + + Succ := Successors.Table (Succ).Next; + end loop; + end Add_Inlined_Subprogram; + + ------------------------ + -- Add_Scope_To_Clean -- + ------------------------ + + procedure Add_Scope_To_Clean (Inst : Entity_Id) is + Scop : constant Entity_Id := Enclosing_Dynamic_Scope (Inst); + Elmt : Elmt_Id; + + begin + -- If the instance appears in a library-level package declaration, + -- all finalization is global, and nothing needs doing here. + + if Scop = Standard_Standard then + return; + end if; + + -- If the instance appears within a generic subprogram there is nothing + -- to finalize either. + + declare + S : Entity_Id; + + begin + S := Scope (Inst); + while Present (S) and then S /= Standard_Standard loop + if Is_Generic_Subprogram (S) then + return; + end if; + + S := Scope (S); + end loop; + end; + + Elmt := First_Elmt (To_Clean); + while Present (Elmt) loop + if Node (Elmt) = Scop then + return; + end if; + + Elmt := Next_Elmt (Elmt); + end loop; + + Append_Elmt (Scop, To_Clean); + end Add_Scope_To_Clean; + + -------------- + -- Add_Subp -- + -------------- + + function Add_Subp (E : Entity_Id) return Subp_Index is + Index : Subp_Index := Subp_Index (E) mod Num_Hash_Headers; + J : Subp_Index; + + procedure New_Entry; + -- Initialize entry in Inlined table + + procedure New_Entry is + begin + Inlined.Increment_Last; + Inlined.Table (Inlined.Last).Name := E; + Inlined.Table (Inlined.Last).First_Succ := No_Succ; + Inlined.Table (Inlined.Last).Count := 0; + Inlined.Table (Inlined.Last).Listed := False; + Inlined.Table (Inlined.Last).Main_Call := False; + Inlined.Table (Inlined.Last).Next := No_Subp; + Inlined.Table (Inlined.Last).Next_Nopred := No_Subp; + end New_Entry; + + -- Start of processing for Add_Subp + + begin + if Hash_Headers (Index) = No_Subp then + New_Entry; + Hash_Headers (Index) := Inlined.Last; + return Inlined.Last; + + else + J := Hash_Headers (Index); + while J /= No_Subp loop + if Inlined.Table (J).Name = E then + return J; + else + Index := J; + J := Inlined.Table (J).Next; + end if; + end loop; + + -- On exit, subprogram was not found. Enter in table. Index is + -- the current last entry on the hash chain. + + New_Entry; + Inlined.Table (Index).Next := Inlined.Last; + return Inlined.Last; + end if; + end Add_Subp; + + ---------------------------- + -- Analyze_Inlined_Bodies -- + ---------------------------- + + procedure Analyze_Inlined_Bodies is + Comp_Unit : Node_Id; + J : Int; + Pack : Entity_Id; + S : Succ_Index; + + function Is_Ancestor_Of_Main + (U_Name : Entity_Id; + Nam : Node_Id) return Boolean; + -- Determine whether the unit whose body is loaded is an ancestor of + -- the main unit, and has a with_clause on it. The body is not + -- analyzed yet, so the check is purely lexical: the name of the with + -- clause is a selected component, and names of ancestors must match. + + ------------------------- + -- Is_Ancestor_Of_Main -- + ------------------------- + + function Is_Ancestor_Of_Main + (U_Name : Entity_Id; + Nam : Node_Id) return Boolean + is + Pref : Node_Id; + + begin + if Nkind (Nam) /= N_Selected_Component then + return False; + + else + if Chars (Selector_Name (Nam)) /= + Chars (Cunit_Entity (Main_Unit)) + then + return False; + end if; + + Pref := Prefix (Nam); + if Nkind (Pref) = N_Identifier then + + -- Par is an ancestor of Par.Child. + + return Chars (Pref) = Chars (U_Name); + + elsif Nkind (Pref) = N_Selected_Component + and then Chars (Selector_Name (Pref)) = Chars (U_Name) + then + -- Par.Child is an ancestor of Par.Child.Grand. + + return True; -- should check that ancestor match + + else + -- A is an ancestor of A.B.C if it is an ancestor of A.B + + return Is_Ancestor_Of_Main (U_Name, Pref); + end if; + end if; + end Is_Ancestor_Of_Main; + + -- Start of processing for Analyze_Inlined_Bodies + + begin + Analyzing_Inlined_Bodies := False; + + if Serious_Errors_Detected = 0 then + Push_Scope (Standard_Standard); + + J := 0; + while J <= Inlined_Bodies.Last + and then Serious_Errors_Detected = 0 + loop + Pack := Inlined_Bodies.Table (J); + while Present (Pack) + and then Scope (Pack) /= Standard_Standard + and then not Is_Child_Unit (Pack) + loop + Pack := Scope (Pack); + end loop; + + Comp_Unit := Parent (Pack); + while Present (Comp_Unit) + and then Nkind (Comp_Unit) /= N_Compilation_Unit + loop + Comp_Unit := Parent (Comp_Unit); + end loop; + + -- Load the body, unless it the main unit, or is an instance whose + -- body has already been analyzed. + + if Present (Comp_Unit) + and then Comp_Unit /= Cunit (Main_Unit) + and then Body_Required (Comp_Unit) + and then (Nkind (Unit (Comp_Unit)) /= N_Package_Declaration + or else No (Corresponding_Body (Unit (Comp_Unit)))) + then + declare + Bname : constant Unit_Name_Type := + Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit))); + + OK : Boolean; + + begin + if not Is_Loaded (Bname) then + Style_Check := False; + Load_Needed_Body (Comp_Unit, OK, Do_Analyze => False); + + if not OK then + + -- Warn that a body was not available for inlining + -- by the back-end. + + Error_Msg_Unit_1 := Bname; + Error_Msg_N + ("one or more inlined subprograms accessed in $!?", + Comp_Unit); + Error_Msg_File_1 := + Get_File_Name (Bname, Subunit => False); + Error_Msg_N ("\but file{ was not found!?", Comp_Unit); + + else + -- If the package to be inlined is an ancestor unit of + -- the main unit, and it has a semantic dependence on + -- it, the inlining cannot take place to prevent an + -- elaboration circularity. The desired body is not + -- analyzed yet, to prevent the completion of Taft + -- amendment types that would lead to elaboration + -- circularities in gigi. + + declare + U_Id : constant Entity_Id := + Defining_Entity (Unit (Comp_Unit)); + Body_Unit : constant Node_Id := + Library_Unit (Comp_Unit); + Item : Node_Id; + + begin + Item := First (Context_Items (Body_Unit)); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then + Is_Ancestor_Of_Main (U_Id, Name (Item)) + then + Set_Is_Inlined (U_Id, False); + exit; + end if; + + Next (Item); + end loop; + + -- If no suspicious with_clauses, analyze the body. + + if Is_Inlined (U_Id) then + Semantics (Body_Unit); + end if; + end; + end if; + end if; + end; + end if; + + J := J + 1; + end loop; + + -- The analysis of required bodies may have produced additional + -- generic instantiations. To obtain further inlining, we perform + -- another round of generic body instantiations. Establishing a + -- fully recursive loop between inlining and generic instantiations + -- is unlikely to yield more than this one additional pass. + + Instantiate_Bodies; + + -- The list of inlined subprograms is an overestimate, because it + -- includes inlined functions called from functions that are compiled + -- as part of an inlined package, but are not themselves called. An + -- accurate computation of just those subprograms that are needed + -- requires that we perform a transitive closure over the call graph, + -- starting from calls in the main program. Here we do one step of + -- the inverse transitive closure, and reset the Is_Called flag on + -- subprograms all of whose callers are not. + + for Index in Inlined.First .. Inlined.Last loop + S := Inlined.Table (Index).First_Succ; + + if S /= No_Succ + and then not Inlined.Table (Index).Main_Call + then + Set_Is_Called (Inlined.Table (Index).Name, False); + + while S /= No_Succ loop + if Is_Called + (Inlined.Table (Successors.Table (S).Subp).Name) + or else Inlined.Table (Successors.Table (S).Subp).Main_Call + then + Set_Is_Called (Inlined.Table (Index).Name); + exit; + end if; + + S := Successors.Table (S).Next; + end loop; + end if; + end loop; + + -- Now that the units are compiled, chain the subprograms within + -- that are called and inlined. Produce list of inlined subprograms + -- sorted in topological order. Start with all subprograms that + -- have no prerequisites, i.e. inlined subprograms that do not call + -- other inlined subprograms. + + for Index in Inlined.First .. Inlined.Last loop + + if Is_Called (Inlined.Table (Index).Name) + and then Inlined.Table (Index).Count = 0 + and then not Inlined.Table (Index).Listed + then + Add_Inlined_Subprogram (Index); + end if; + end loop; + + -- Because Add_Inlined_Subprogram treats recursively nodes that have + -- no prerequisites left, at the end of the loop all subprograms + -- must have been listed. If there are any unlisted subprograms + -- left, there must be some recursive chains that cannot be inlined. + + for Index in Inlined.First .. Inlined.Last loop + if Is_Called (Inlined.Table (Index).Name) + and then Inlined.Table (Index).Count /= 0 + and then not Is_Predefined_File_Name + (Unit_File_Name + (Get_Source_Unit (Inlined.Table (Index).Name))) + then + Error_Msg_N + ("& cannot be inlined?", Inlined.Table (Index).Name); + + -- A warning on the first one might be sufficient ??? + end if; + end loop; + + Pop_Scope; + end if; + end Analyze_Inlined_Bodies; + + ----------------------------- + -- Check_Body_For_Inlining -- + ----------------------------- + + procedure Check_Body_For_Inlining (N : Node_Id; P : Entity_Id) is + Bname : Unit_Name_Type; + E : Entity_Id; + OK : Boolean; + + begin + if Is_Compilation_Unit (P) + and then not Is_Generic_Instance (P) + then + Bname := Get_Body_Name (Get_Unit_Name (Unit (N))); + + E := First_Entity (P); + while Present (E) loop + if Has_Pragma_Inline_Always (E) + or else (Front_End_Inlining and then Has_Pragma_Inline (E)) + then + if not Is_Loaded (Bname) then + Load_Needed_Body (N, OK); + + if OK then + + -- Check we are not trying to inline a parent whose body + -- depends on a child, when we are compiling the body of + -- the child. Otherwise we have a potential elaboration + -- circularity with inlined subprograms and with + -- Taft-Amendment types. + + declare + Comp : Node_Id; -- Body just compiled + Child_Spec : Entity_Id; -- Spec of main unit + Ent : Entity_Id; -- For iteration + With_Clause : Node_Id; -- Context of body. + + begin + if Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body + and then Present (Body_Entity (P)) + then + Child_Spec := + Defining_Entity + ((Unit (Library_Unit (Cunit (Main_Unit))))); + + Comp := + Parent (Unit_Declaration_Node (Body_Entity (P))); + + -- Check whether the context of the body just + -- compiled includes a child of itself, and that + -- child is the spec of the main compilation. + + With_Clause := First (Context_Items (Comp)); + while Present (With_Clause) loop + if Nkind (With_Clause) = N_With_Clause + and then + Scope (Entity (Name (With_Clause))) = P + and then + Entity (Name (With_Clause)) = Child_Spec + then + Error_Msg_Node_2 := Child_Spec; + Error_Msg_NE + ("body of & depends on child unit&?", + With_Clause, P); + Error_Msg_N + ("\subprograms in body cannot be inlined?", + With_Clause); + + -- Disable further inlining from this unit, + -- and keep Taft-amendment types incomplete. + + Ent := First_Entity (P); + while Present (Ent) loop + if Is_Type (Ent) + and then Has_Completion_In_Body (Ent) + then + Set_Full_View (Ent, Empty); + + elsif Is_Subprogram (Ent) then + Set_Is_Inlined (Ent, False); + end if; + + Next_Entity (Ent); + end loop; + + return; + end if; + + Next (With_Clause); + end loop; + end if; + end; + + elsif Ineffective_Inline_Warnings then + Error_Msg_Unit_1 := Bname; + Error_Msg_N + ("unable to inline subprograms defined in $?", P); + Error_Msg_N ("\body not found?", P); + return; + end if; + end if; + + return; + end if; + + Next_Entity (E); + end loop; + end if; + end Check_Body_For_Inlining; + + -------------------- + -- Cleanup_Scopes -- + -------------------- + + procedure Cleanup_Scopes is + Elmt : Elmt_Id; + Decl : Node_Id; + Scop : Entity_Id; + + begin + Elmt := First_Elmt (To_Clean); + while Present (Elmt) loop + Scop := Node (Elmt); + + if Ekind (Scop) = E_Entry then + Scop := Protected_Body_Subprogram (Scop); + + elsif Is_Subprogram (Scop) + and then Is_Protected_Type (Scope (Scop)) + and then Present (Protected_Body_Subprogram (Scop)) + then + -- If a protected operation contains an instance, its + -- cleanup operations have been delayed, and the subprogram + -- has been rewritten in the expansion of the enclosing + -- protected body. It is the corresponding subprogram that + -- may require the cleanup operations, so propagate the + -- information that triggers cleanup activity. + + Set_Uses_Sec_Stack + (Protected_Body_Subprogram (Scop), + Uses_Sec_Stack (Scop)); + Set_Finalization_Chain_Entity + (Protected_Body_Subprogram (Scop), + Finalization_Chain_Entity (Scop)); + Scop := Protected_Body_Subprogram (Scop); + end if; + + if Ekind (Scop) = E_Block then + Decl := Parent (Block_Node (Scop)); + + else + Decl := Unit_Declaration_Node (Scop); + + if Nkind (Decl) = N_Subprogram_Declaration + or else Nkind (Decl) = N_Task_Type_Declaration + or else Nkind (Decl) = N_Subprogram_Body_Stub + then + Decl := Unit_Declaration_Node (Corresponding_Body (Decl)); + end if; + end if; + + Push_Scope (Scop); + Expand_Cleanup_Actions (Decl); + End_Scope; + + Elmt := Next_Elmt (Elmt); + end loop; + end Cleanup_Scopes; + + -------------------------- + -- Has_Initialized_Type -- + -------------------------- + + function Has_Initialized_Type (E : Entity_Id) return Boolean is + E_Body : constant Node_Id := Get_Subprogram_Body (E); + Decl : Node_Id; + + begin + if No (E_Body) then -- imported subprogram + return False; + + else + Decl := First (Declarations (E_Body)); + while Present (Decl) loop + + if Nkind (Decl) = N_Full_Type_Declaration + and then Present (Init_Proc (Defining_Identifier (Decl))) + then + return True; + end if; + + Next (Decl); + end loop; + end if; + + return False; + end Has_Initialized_Type; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Analyzing_Inlined_Bodies := False; + Pending_Descriptor.Init; + Pending_Instantiations.Init; + Inlined_Bodies.Init; + Successors.Init; + Inlined.Init; + + for J in Hash_Headers'Range loop + Hash_Headers (J) := No_Subp; + end loop; + end Initialize; + + ------------------------ + -- Instantiate_Bodies -- + ------------------------ + + -- Generic bodies contain all the non-local references, so an + -- instantiation does not need any more context than Standard + -- itself, even if the instantiation appears in an inner scope. + -- Generic associations have verified that the contract model is + -- satisfied, so that any error that may occur in the analysis of + -- the body is an internal error. + + procedure Instantiate_Bodies is + J : Int; + Info : Pending_Body_Info; + + begin + if Serious_Errors_Detected = 0 then + + Expander_Active := (Operating_Mode = Opt.Generate_Code); + Push_Scope (Standard_Standard); + To_Clean := New_Elmt_List; + + if Is_Generic_Unit (Cunit_Entity (Main_Unit)) then + Start_Generic; + end if; + + -- A body instantiation may generate additional instantiations, so + -- the following loop must scan to the end of a possibly expanding + -- set (that's why we can't simply use a FOR loop here). + + J := 0; + while J <= Pending_Instantiations.Last + and then Serious_Errors_Detected = 0 + loop + Info := Pending_Instantiations.Table (J); + + -- If the instantiation node is absent, it has been removed + -- as part of unreachable code. + + if No (Info.Inst_Node) then + null; + + elsif Nkind (Info.Act_Decl) = N_Package_Declaration then + Instantiate_Package_Body (Info); + Add_Scope_To_Clean (Defining_Entity (Info.Act_Decl)); + + else + Instantiate_Subprogram_Body (Info); + end if; + + J := J + 1; + end loop; + + -- Reset the table of instantiations. Additional instantiations + -- may be added through inlining, when additional bodies are + -- analyzed. + + Pending_Instantiations.Init; + + -- We can now complete the cleanup actions of scopes that contain + -- pending instantiations (skipped for generic units, since we + -- never need any cleanups in generic units). + -- pending instantiations. + + if Expander_Active + and then not Is_Generic_Unit (Main_Unit_Entity) + then + Cleanup_Scopes; + elsif Is_Generic_Unit (Cunit_Entity (Main_Unit)) then + End_Generic; + end if; + + Pop_Scope; + end if; + end Instantiate_Bodies; + + --------------- + -- Is_Nested -- + --------------- + + function Is_Nested (E : Entity_Id) return Boolean is + Scop : Entity_Id; + + begin + Scop := Scope (E); + while Scop /= Standard_Standard loop + if Ekind (Scop) in Subprogram_Kind then + return True; + + elsif Ekind (Scop) = E_Task_Type + or else Ekind (Scop) = E_Entry + or else Ekind (Scop) = E_Entry_Family then + return True; + end if; + + Scop := Scope (Scop); + end loop; + + return False; + end Is_Nested; + + ---------- + -- Lock -- + ---------- + + procedure Lock is + begin + Pending_Instantiations.Locked := True; + Inlined_Bodies.Locked := True; + Successors.Locked := True; + Inlined.Locked := True; + Pending_Instantiations.Release; + Inlined_Bodies.Release; + Successors.Release; + Inlined.Release; + end Lock; + + -------------------------- + -- Remove_Dead_Instance -- + -------------------------- + + procedure Remove_Dead_Instance (N : Node_Id) is + J : Int; + + begin + J := 0; + while J <= Pending_Instantiations.Last loop + if Pending_Instantiations.Table (J).Inst_Node = N then + Pending_Instantiations.Table (J).Inst_Node := Empty; + return; + end if; + + J := J + 1; + end loop; + end Remove_Dead_Instance; + + ------------------------ + -- Scope_In_Main_Unit -- + ------------------------ + + function Scope_In_Main_Unit (Scop : Entity_Id) return Boolean is + Comp : constant Node_Id := Cunit (Get_Code_Unit (Scop)); + + begin + -- Check whether the scope of the subprogram to inline is within the + -- main unit or within its spec. In either case there are no additional + -- bodies to process. If the subprogram appears in a parent of the + -- current unit, the check on whether inlining is possible is done in + -- Analyze_Inlined_Bodies. + + return + Comp = Cunit (Main_Unit) + or else Comp = Library_Unit (Cunit (Main_Unit)); + end Scope_In_Main_Unit; + +end Inline; diff --git a/gcc/ada/inline.ads b/gcc/ada/inline.ads new file mode 100644 index 000000000..04cb32344 --- /dev/null +++ b/gcc/ada/inline.ads @@ -0,0 +1,153 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N L I N E -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This module handles two kinds of inlining activity: + +-- a) Instantiation of generic bodies. This is done unconditionally, after +-- analysis and expansion of the main unit. + +-- b) Compilation of unit bodies that contain the bodies of inlined sub- +-- programs. This is done only if inlining is enabled (-gnatn). Full inlining +-- requires that a) an b) be mutually recursive, because each step may +-- generate another generic expansion and further inlined calls. For now each +-- of them uses a workpile algorithm, but they are called independently from +-- Frontend, and thus are not mutually recursive. + +with Alloc; +with Opt; use Opt; +with Sem; use Sem; +with Table; +with Types; use Types; + +package Inline is + + -------------------------------- + -- Generic Body Instantiation -- + -------------------------------- + + -- The bodies of generic instantiations are built after semantic analysis + -- of the main unit is complete. Generic instantiations are saved in a + -- global data structure, and the bodies constructed by means of a separate + -- analysis and expansion step. + + -- See full description in body of Sem_Ch12 for more details + + type Pending_Body_Info is record + Inst_Node : Node_Id; + -- Node for instantiation that requires the body + + Act_Decl : Node_Id; + -- Declaration for package or subprogram spec for instantiation + + Expander_Status : Boolean; + -- If the body is instantiated only for semantic checking, expansion + -- must be inhibited. + + Current_Sem_Unit : Unit_Number_Type; + -- The semantic unit within which the instantiation is found. Must + -- be restored when compiling the body, to insure that internal enti- + -- ties use the same counter and are unique over spec and body. + + Scope_Suppress : Suppress_Array; + Local_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr; + -- Save suppress information at the point of instantiation. Used to + -- properly inherit check status active at this point (see RM 11.5 + -- (7.2/2), AI95-00224-01): + -- + -- "If a checking pragma applies to a generic instantiation, then the + -- checking pragma also applies to the instance. If a checking pragma + -- applies to a call to a subprogram that has a pragma Inline applied + -- to it, then the checking pragma also applies to the inlined + -- subprogram body". + -- + -- This means we have to capture this information from the current scope + -- at the point of instantiation. + + Version : Ada_Version_Type; + -- The body must be compiled with the same language version as the + -- spec. The version may be set by a configuration pragma in a separate + -- file or in the current file, and may differ from body to body. + end record; + + package Pending_Instantiations is new Table.Table ( + Table_Component_Type => Pending_Body_Info, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.Pending_Instantiations_Initial, + Table_Increment => Alloc.Pending_Instantiations_Increment, + Table_Name => "Pending_Instantiations"); + + -- The following table records subprograms and packages for which + -- generation of subprogram descriptors must be delayed. + + package Pending_Descriptor is new Table.Table ( + Table_Component_Type => Entity_Id, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.Pending_Instantiations_Initial, + Table_Increment => Alloc.Pending_Instantiations_Increment, + Table_Name => "Pending_Descriptor"); + + Analyzing_Inlined_Bodies : Boolean; + -- This flag is set False by the call to Initialize, and then is set + -- True by the call to Analyze_Inlined_Bodies. It is used to suppress + -- generation of subprogram descriptors for inlined bodies. + + ----------------- + -- Subprograms -- + ----------------- + + procedure Initialize; + -- Initialize internal tables + + procedure Lock; + -- Lock internal tables before calling backend + + procedure Instantiate_Bodies; + -- This procedure is called after semantic analysis is complete, to + -- instantiate the bodies of generic instantiations that appear in the + -- compilation unit. + + procedure Add_Inlined_Body (E : Entity_Id); + -- E is an inlined subprogram appearing in a call, either explicitly, or + -- a discriminant check for which gigi builds a call. Add E's enclosing + -- unit to Inlined_Bodies so that body of E can be subsequently retrieved + -- and analyzed. + + procedure Analyze_Inlined_Bodies; + -- At end of compilation, analyze the bodies of all units that contain + -- inlined subprograms that are actually called. + + procedure Check_Body_For_Inlining (N : Node_Id; P : Entity_Id); + -- If front-end inlining is enabled and a package declaration contains + -- inlined subprograms, load and compile the package body to collect the + -- bodies of these subprograms, so they are available to inline calls. + -- N is the compilation unit for the package. + + procedure Remove_Dead_Instance (N : Node_Id); + -- If an instantiation appears in unreachable code, delete the pending + -- body instance. + +end Inline; diff --git a/gcc/ada/interfac.ads b/gcc/ada/interfac.ads new file mode 100644 index 000000000..d36b48f74 --- /dev/null +++ b/gcc/ada/interfac.ads @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S -- +-- -- +-- 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 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. -- +-- -- +------------------------------------------------------------------------------ + +package Interfaces is + pragma Pure; + + 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 range -2 ** 63 .. 2 ** 63 - 1; + for Integer_64'Size use 64; + + 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_32 is mod 2 ** 32; + for Unsigned_32'Size use 32; + + type Unsigned_64 is mod 2 ** 64; + for Unsigned_64'Size use 64; + + 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. Note that the form of these definitions + -- ensures that the work on VMS, even if the standard library is compiled + -- using a Float_Representation pragma for Vax_Float. + + pragma Warnings (Off); + -- Turn off warnings for targets not providing IEEE floating-point types + + type IEEE_Float_32 is digits 6; + pragma Float_Representation (IEEE_Float, IEEE_Float_32); + + type IEEE_Float_64 is digits 15; + pragma Float_Representation (IEEE_Float, IEEE_Float_64); + + -- If there is an IEEE extended float available on the machine, we assume + -- that it is available as Long_Long_Float. + + -- Note: it is harmless, and explicitly permitted, to include additional + -- types in interfaces, so it is not wrong to have IEEE_Extended_Float + -- defined even if the extended format is not available. + + type IEEE_Extended_Float is new Long_Long_Float; + +end Interfaces; diff --git a/gcc/ada/ioexcept.ads b/gcc/ada/ioexcept.ads new file mode 100644 index 000000000..efdadc713 --- /dev/null +++ b/gcc/ada/ioexcept.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- I O _ E X C E P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2005; +-- Explicit setting of Ada 2005 mode is required here, since we want to with a +-- child unit (not possible in Ada 83 mode), and IO_Exceptions is not +-- considered to be an internal unit that is automatically compiled in Ada +-- 2005 mode (since a user is allowed to redeclare IO_Exceptions). + +with Ada.IO_Exceptions; + +package IO_Exceptions renames Ada.IO_Exceptions; diff --git a/gcc/ada/itypes.adb b/gcc/ada/itypes.adb new file mode 100644 index 000000000..e9a86b411 --- /dev/null +++ b/gcc/ada/itypes.adb @@ -0,0 +1,121 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I T Y P E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Opt; use Opt; +with Sem; use Sem; +with Sinfo; use Sinfo; +with Stand; use Stand; +with Targparm; use Targparm; +with Uintp; use Uintp; + +package body Itypes is + + ------------------ + -- Create_Itype -- + ------------------ + + function Create_Itype + (Ekind : Entity_Kind; + Related_Nod : Node_Id; + Related_Id : Entity_Id := Empty; + Suffix : Character := ' '; + Suffix_Index : Nat := 0; + Scope_Id : Entity_Id := Current_Scope) return Entity_Id + is + Typ : Entity_Id; + + begin + -- Should comment setting of Public_Status here ??? + + if Related_Id = Empty then + Typ := New_Internal_Entity (Ekind, Scope_Id, Sloc (Related_Nod), 'T'); + Set_Public_Status (Typ); + + else + Typ := + New_External_Entity + (Ekind, Scope_Id, Sloc (Related_Nod), Related_Id, Suffix, + Suffix_Index, 'T'); + end if; + + -- Make sure Esize (Typ) was properly initialized, it should be since + -- New_Internal_Entity/New_External_Entity call Init_Size_Align. + + pragma Assert (Esize (Typ) = Uint_0); + + Set_Etype (Typ, Any_Type); + Set_Is_Itype (Typ); + Set_Associated_Node_For_Itype (Typ, Related_Nod); + + if In_Deleted_Code + and then not ASIS_Mode + then + Set_Is_Frozen (Typ); + end if; + + if Ekind in Access_Subprogram_Kind then + Set_Can_Use_Internal_Rep (Typ, not Always_Compatible_Rep_On_Target); + end if; + + return Typ; + end Create_Itype; + + --------------------------------- + -- Create_Null_Excluding_Itype -- + --------------------------------- + + function Create_Null_Excluding_Itype + (T : Entity_Id; + Related_Nod : Node_Id; + Scope_Id : Entity_Id := Current_Scope) return Entity_Id + is + I_Typ : Entity_Id; + + begin + pragma Assert (Is_Access_Type (T)); + + I_Typ := Create_Itype (Ekind => E_Access_Subtype, + Related_Nod => Related_Nod, + Scope_Id => Scope_Id); + + Set_Directly_Designated_Type (I_Typ, Directly_Designated_Type (T)); + Set_Etype (I_Typ, Base_Type (T)); + Set_Depends_On_Private (I_Typ, Depends_On_Private (T)); + Set_Is_Public (I_Typ, Is_Public (T)); + Set_From_With_Type (I_Typ, From_With_Type (T)); + Set_Is_Access_Constant (I_Typ, Is_Access_Constant (T)); + Set_Is_Generic_Type (I_Typ, Is_Generic_Type (T)); + Set_Is_Volatile (I_Typ, Is_Volatile (T)); + Set_Treat_As_Volatile (I_Typ, Treat_As_Volatile (T)); + Set_Is_Atomic (I_Typ, Is_Atomic (T)); + Set_Is_Ada_2005_Only (I_Typ, Is_Ada_2005_Only (T)); + Set_Is_Ada_2012_Only (I_Typ, Is_Ada_2012_Only (T)); + Set_Can_Never_Be_Null (I_Typ); + + return I_Typ; + end Create_Null_Excluding_Itype; + +end Itypes; diff --git a/gcc/ada/itypes.ads b/gcc/ada/itypes.ads new file mode 100644 index 000000000..ffd3a1d49 --- /dev/null +++ b/gcc/ada/itypes.ads @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I T Y P E S -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains declarations for handling of implicit types + +with Einfo; use Einfo; +with Sem_Util; use Sem_Util; +with Types; use Types; + +package Itypes is + + -------------------- + -- Implicit Types -- + -------------------- + + -- Implicit types (Itypes) are types and subtypes created by the semantic + -- phase or the expander to reflect the underlying semantics. These could + -- be generated by building trees for corresponding declarations and then + -- analyzing these trees, but there are three reasons for not doing this + -- in some cases: + + -- 1. The declarations would require more tree nodes + + -- 2. In some cases, the elaboration of these types is associated + -- with internal nodes in the tree. + + -- 3. For some types, notably class wide types, there is no Ada + -- declaration that would correspond to the desired entity. + + -- So instead, implicit types are constructed by simply creating an + -- appropriate entity with the help of routines in this package. These + -- entities are fully decorated, as described in Einfo (just as though + -- they had been created by the normal analysis procedure). + + -- The type declaration declaring an Itype must be analyzed with checks + -- off because this declaration has not been inserted in the tree (if it + -- has been then it is not an Itype), and hence checks that would be + -- generated during the analysis cannot be inserted in the tree. At any + -- rate, Itype analysis should always be done with checks off, otherwise + -- duplicate checks will most likely be emitted. + + -- Unlike types declared explicitly, implicit types are defined on first + -- use, which means that Gigi detects the use of such types, and defines + -- them at the point of the first use automatically. + + -- Although Itypes are not explicitly declared, they are associated with + -- a specific node in the tree (roughly the node that caused them to be + -- created), via the Associated_Node_For_Itype field. This association is + -- used particularly by New_Copy_Tree, which uses it to determine whether + -- or not to copy a referenced Itype. If the associated node is part of + -- the tree to be copied by New_Copy_Tree, then (since the idea of the + -- call to New_Copy_Tree is to create a complete duplicate of a tree, + -- as though it had appeared separately in the source), the Itype in + -- question is duplicated as part of the New_Copy_Tree processing. + + -- As a consequence of this copying mechanism, the association between + -- Itypes and associated nodes must be one-to-one: several Itypes must + -- not share an associated node. For example, the semantic decoration + -- of an array aggregate generates several Itypes: for each index subtype + -- and for the array subtype. The associated node of each index subtype + -- is the corresponding range expression. + + -- Notes on the use of the Parent field of an Itype + + -- In some cases, we do create a declaration node for an itype, and in + -- such cases, the Parent field of the Itype points to this declaration + -- in the normal manner. This case can be detected by checking for a + -- non-empty Parent field referencing a declaration whose Defining_Entity + -- is the Itype in question. + + -- In some other cases, where we don't generate such a declaration, as + -- described above, the Itype is attached to the tree implicitly by being + -- referenced elsewhere, e.g. as the Etype of some object. In this case + -- the Parent field may be Empty. + + -- In other cases where we don't generate a declaration for the Itype, + -- the Itype may be attached to an arbitrary node in the tree, using + -- the Parent field. This Parent field may even reference a declaration + -- for a related different entity (hence the description of the tests + -- needed for the case where a declaration for the Itype is created). + + ------------------ + -- Create_Itype -- + ------------------ + + function Create_Itype + (Ekind : Entity_Kind; + Related_Nod : Node_Id; + Related_Id : Entity_Id := Empty; + Suffix : Character := ' '; + Suffix_Index : Nat := 0; + Scope_Id : Entity_Id := Current_Scope) return Entity_Id; + -- Used to create a new Itype + -- + -- Related_Nod is the node for which this Itype was created. It is + -- set as the Associated_Node_For_Itype of the new Itype. The Sloc of + -- the new Itype is that of this node. + -- + -- Related_Id is present only if the implicit type name may be referenced + -- as a public symbol, and thus needs a unique external name. The name + -- is created by a call to: + -- + -- New_External_Name (Chars (Related_Id), Suffix, Suffix_Index, 'T') + -- + -- If the implicit type does not need an external name, then the + -- Related_Id parameter is omitted (and hence Empty). In this case + -- Suffix and Suffix_Index are ignored and the implicit type name is + -- created by a call to Make_Temporary. + -- + -- Note that in all cases, the name starts with "T". This is used + -- to identify implicit types in the error message handling circuits. + -- + -- The Scope_Id parameter specifies the scope of the created type, and + -- is normally the Current_Scope as shown, but can be set otherwise. + -- + -- The size/align fields are initialized to unknown (Uint_0). + -- + -- If Ekind is in Access_Subprogram_Kind, Can_Use_Internal_Rep is set True, + -- unless Always_Compatible_Rep_On_Target is True. + + --------------------------------- + -- Create_Null_Excluding_Itype -- + --------------------------------- + + function Create_Null_Excluding_Itype + (T : Entity_Id; + Related_Nod : Node_Id; + Scope_Id : Entity_Id := Current_Scope) return Entity_Id; + -- Ada 2005 (AI-231): T is an access type and this subprogram creates and + -- returns an internal access-subtype declaration of T that has the null + -- exclusion attribute set to True. + -- + -- Usage of null-excluding Itypes + -- ------------------------------ + -- + -- type T1 is access ... + -- type T2 is not null T1; + -- + -- type Rec is record + -- Comp : not null T1; + -- end record; + -- + -- type Arr is array (...) of not null T1; + -- + -- Instead of associating the not-null attribute with the defining ids of + -- these declarations, we generate an internal subtype declaration of T1 + -- that has the null exclusion attribute set to true. + +end Itypes; diff --git a/gcc/ada/krunch.adb b/gcc/ada/krunch.adb new file mode 100644 index 000000000..f2bbf05dc --- /dev/null +++ b/gcc/ada/krunch.adb @@ -0,0 +1,265 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- K R U N C H -- +-- -- +-- 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 Hostparm; + +procedure Krunch + (Buffer : in out String; + Len : in out Natural; + Maxlen : Natural; + No_Predef : Boolean; + VMS_On_Target : Boolean := False) + +is + pragma Assert (Buffer'First = 1); + -- This is a documented requirement; the assert turns off index warnings + + B1 : Character renames Buffer (1); + Curlen : Natural; + Krlen : Natural; + Num_Seps : Natural; + Startloc : Natural; + J : Natural; + +begin + -- Deal with special predefined children cases. Startloc is the first + -- location for the krunch, set to 1, except for the predefined children + -- case, where it is set to 3, to start after the standard prefix. + + if No_Predef then + Startloc := 1; + Curlen := Len; + Krlen := Maxlen; + + elsif Len >= 18 + and then Buffer (1 .. 17) = "ada-wide_text_io-" + then + Startloc := 3; + Buffer (2 .. 5) := "-wt-"; + Buffer (6 .. Len - 12) := Buffer (18 .. Len); + Curlen := Len - 12; + Krlen := 8; + + elsif Len >= 23 + and then Buffer (1 .. 22) = "ada-wide_wide_text_io-" + then + Startloc := 3; + Buffer (2 .. 5) := "-zt-"; + Buffer (6 .. Len - 17) := Buffer (23 .. Len); + Curlen := Len - 17; + Krlen := 8; + + elsif Len >= 4 and then Buffer (1 .. 4) = "ada-" then + Startloc := 3; + Buffer (2 .. Len - 2) := Buffer (4 .. Len); + Curlen := Len - 2; + Krlen := 8; + + elsif Len >= 5 and then Buffer (1 .. 5) = "gnat-" then + Startloc := 3; + Buffer (2 .. Len - 3) := Buffer (5 .. Len); + Curlen := Len - 3; + Krlen := 8; + + elsif Len >= 7 and then Buffer (1 .. 7) = "system-" then + Startloc := 3; + Buffer (2 .. Len - 5) := Buffer (7 .. Len); + Curlen := Len - 5; + Krlen := 8; + + elsif Len >= 11 and then Buffer (1 .. 11) = "interfaces-" then + Startloc := 3; + Buffer (2 .. Len - 9) := Buffer (11 .. Len); + Curlen := Len - 9; + Krlen := 8; + + -- For the renamings in the obsolescent section, we also force krunching + -- to 8 characters, but no other special processing is required here. + -- Note that text_io and calendar are already short enough anyway. + + elsif (Len = 9 and then Buffer (1 .. 9) = "direct_io") + or else (Len = 10 and then Buffer (1 .. 10) = "interfaces") + or else (Len = 13 and then Buffer (1 .. 13) = "io_exceptions") + or else (Len = 12 and then Buffer (1 .. 12) = "machine_code") + or else (Len = 13 and then Buffer (1 .. 13) = "sequential_io") + or else (Len = 20 and then Buffer (1 .. 20) = "unchecked_conversion") + or else (Len = 22 and then Buffer (1 .. 22) = "unchecked_deallocation") + then + Startloc := 1; + Krlen := 8; + Curlen := Len; + + -- Special case of a child unit whose parent unit is a single letter that + -- is A, G, I, or S. In order to prevent confusion with krunched names + -- of predefined units use a tilde rather than a minus as the second + -- character of the file name. On VMS a tilde is an illegal character + -- in a file name, two consecutive underlines ("__") are used instead. + + elsif Len > 1 + and then Buffer (2) = '-' + and then (B1 = 'a' or else B1 = 'g' or else B1 = 'i' or else B1 = 's') + and then Len <= Maxlen + then + -- When VMS is the host, it is always also the target + + if Hostparm.OpenVMS or else VMS_On_Target then + Len := Len + 1; + Buffer (4 .. Len) := Buffer (3 .. Len - 1); + Buffer (2) := '_'; + Buffer (3) := '_'; + else + Buffer (2) := '~'; + end if; + + if Len <= Maxlen then + return; + + else + -- Case of VMS when the buffer had exactly the length Maxlen and now + -- has the length Maxlen + 1: krunching after "__" is needed. + + Startloc := 4; + Curlen := Len; + Krlen := Maxlen; + end if; + + -- Normal case, not a predefined file + + else + Startloc := 1; + Curlen := Len; + Krlen := Maxlen; + end if; + + -- Immediate return if file name is short enough now + + if Curlen <= Krlen then + Len := Curlen; + return; + end if; + + -- If string contains Wide_Wide, replace by a single z + + J := Startloc; + while J <= Curlen - 8 loop + if Buffer (J .. J + 8) = "wide_wide" + and then (J = Startloc + or else Buffer (J - 1) = '-' + or else Buffer (J - 1) = '_') + and then (J + 8 = Curlen + or else Buffer (J + 9) = '-' + or else Buffer (J + 9) = '_') + then + Buffer (J) := 'z'; + Buffer (J + 1 .. Curlen - 8) := Buffer (J + 9 .. Curlen); + Curlen := Curlen - 8; + end if; + + J := J + 1; + end loop; + + -- For now, refuse to krunch a name that contains an ESC character (wide + -- character sequence) since it's too much trouble to do this right ??? + + for J in 1 .. Curlen loop + if Buffer (J) = ASCII.ESC then + return; + end if; + end loop; + + -- Count number of separators (minus signs and underscores) and for now + -- replace them by spaces. We keep them around till the end to control + -- the krunching process, and then we eliminate them as the last step + + Num_Seps := 0; + for J in Startloc .. Curlen loop + if Buffer (J) = '-' or else Buffer (J) = '_' then + Buffer (J) := ' '; + Num_Seps := Num_Seps + 1; + end if; + end loop; + + -- Now we do the one character at a time krunch till we are short enough + + while Curlen - Num_Seps > Krlen loop + declare + Long_Length : Natural := 0; + Long_Last : Natural := 0; + Piece_Start : Natural; + Ptr : Natural; + + begin + Ptr := Startloc; + + -- Loop through pieces to find longest piece + + while Ptr <= Curlen loop + Piece_Start := Ptr; + + -- Loop through characters in one piece of name + + while Ptr <= Curlen and then Buffer (Ptr) /= ' ' loop + Ptr := Ptr + 1; + end loop; + + if Ptr - Piece_Start > Long_Length then + Long_Length := Ptr - Piece_Start; + Long_Last := Ptr - 1; + end if; + + Ptr := Ptr + 1; + end loop; + + -- Remove last character of longest piece + + if Long_Last < Curlen then + Buffer (Long_Last .. Curlen - 1) := + Buffer (Long_Last + 1 .. Curlen); + end if; + + Curlen := Curlen - 1; + end; + end loop; + + -- Final step, remove the spaces + + Len := 0; + + for J in 1 .. Curlen loop + if Buffer (J) /= ' ' then + Len := Len + 1; + Buffer (Len) := Buffer (J); + end if; + end loop; + + return; + +end Krunch; diff --git a/gcc/ada/krunch.ads b/gcc/ada/krunch.ads new file mode 100644 index 000000000..95a0218e6 --- /dev/null +++ b/gcc/ada/krunch.ads @@ -0,0 +1,138 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- K R U N C H -- +-- -- +-- 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 procedure implements file name crunching + +-- First, the name is divided into segments separated by minus signs and +-- underscores, then all minus signs and underscores are eliminated. If +-- this leaves the name short enough, we are done. + +-- If not, then the longest segment is located (left-most if there are +-- two of equal length), and shortened by dropping its last character. +-- This is repeated until the name is short enough. + +-- As an example, consider the krunch of our-strings-wide_fixed.adb +-- to fit the name into 8 characters as required by DOS: + +-- our-strings-wide_fixed 22 +-- our strings wide fixed 19 +-- our string wide fixed 18 +-- our strin wide fixed 17 +-- our stri wide fixed 16 +-- our stri wide fixe 15 +-- our str wide fixe 14 +-- our str wid fixe 13 +-- our str wid fix 12 +-- ou str wid fix 11 +-- ou st wid fix 10 +-- ou st wi fix 9 +-- ou st wi fi 8 + +-- Final file name: OUSTWIFX.ADB + +-- A special rule applies for children of System, Ada, Gnat, and Interfaces. +-- In these cases, the following special prefix replacements occur: + +-- ada- replaced by a- +-- gnat- replaced by g- +-- interfaces- replaced by i- +-- system- replaced by s- + +-- The rest of the name is krunched in the usual manner described above. +-- In addition, these names, as well as the names of the renamed packages +-- from the obsolescent features annex, are always krunched to 8 characters +-- regardless of the setting of Maxlen. + +-- As an example of this special rule, consider ada-strings-wide_fixed.adb +-- which gets krunched as follows: + +-- ada-strings-wide_fixed 22 +-- a- strings wide fixed 18 +-- a- string wide fixed 17 +-- a- strin wide fixed 16 +-- a- stri wide fixed 15 +-- a- stri wide fixe 14 +-- a- str wide fixe 13 +-- a- str wid fixe 12 +-- a- str wid fix 11 +-- a- st wid fix 10 +-- a- st wi fix 9 +-- a- st wi fi 8 + +-- Final file name: A-STWIFX.ADB + +-- Since children of units named A, G, I or S might conflict with the names +-- of predefined units, the naming rule in that case is that the first hyphen +-- is replaced by a tilde sign. + +-- Note: as described below, this special treatment of predefined library +-- unit file names can be inhibited by setting the No_Predef flag. + +-- Of course there is no guarantee that this algorithm results in uniquely +-- crunched names (nor, obviously, is there any algorithm which would do so) +-- In fact we run into such a case in the standard library routines with +-- children of Wide_Text_IO, so a special rule is applied to deal with this +-- clash, namely the prefix ada-wide_text_io- is replaced by a-wt- and then +-- the normal crunching rules are applied, so that for example, the unit: + +-- Ada.Wide_Text_IO.Float_IO + +-- has the file name + +-- a-wtflio + +-- More problems arise with Wide_Wide, so we replace this sequence by +-- a z (which is not used much) and also (as in the Wide_Text_IO case), +-- we replace the prefix ada.wide_wide_text_io- by a-zt- and then +-- the normal crunching rules are applied. + +-- These are the only irregularity required (so far!) to keep the file names +-- unique in the standard predefined libraries. + +procedure Krunch + (Buffer : in out String; + Len : in out Natural; + Maxlen : Natural; + No_Predef : Boolean; + VMS_On_Target : Boolean := False); +pragma Elaborate_Body (Krunch); +-- The full file name is stored in Buffer (1 .. Len) on entry. The file +-- name is crunched in place and on return Len is updated, so that the +-- resulting krunched name is in Buffer (1 .. Len) where Len <= Maxlen. +-- Note that Len may be less than or equal to Maxlen on entry, in which +-- case it may be possible that Krunch does not modify Buffer. The fourth +-- parameter, No_Predef, is a switch which, if set to True, disables the +-- normal special treatment of predefined library unit file names. +-- VMS_On_Target, when True, indicates to Krunch to apply the VMS treatment +-- to the children of package A, G,I or S. +-- +-- Note: the string Buffer must have a lower bound of 1, and may not +-- contain any blanks (in particular, it must not have leading blanks). diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb new file mode 100644 index 000000000..0c4db36b4 --- /dev/null +++ b/gcc/ada/layout.adb @@ -0,0 +1,3239 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L A Y O U T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Debug; use Debug; +with Einfo; use Einfo; +with Errout; use Errout; +with Exp_Ch3; use Exp_Ch3; +with Exp_Util; use Exp_Util; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Repinfo; use Repinfo; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch13; use Sem_Ch13; +with Sem_Eval; use Sem_Eval; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; + +package body Layout is + + ------------------------ + -- Local Declarations -- + ------------------------ + + SSU : constant Int := Ttypes.System_Storage_Unit; + -- Short hand for System_Storage_Unit + + Vname : constant Name_Id := Name_uV; + -- Formal parameter name used for functions generated for size offset + -- values that depend on the discriminant. All such functions have the + -- following form: + -- + -- function xxx (V : vtyp) return Unsigned is + -- begin + -- return ... expression involving V.discrim + -- end xxx; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Assoc_Add + (Loc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) return Node_Id; + -- This is like Make_Op_Add except that it optimizes some cases knowing + -- that associative rearrangement is allowed for constant folding if one + -- of the operands is a compile time known value. + + function Assoc_Multiply + (Loc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) return Node_Id; + -- This is like Make_Op_Multiply except that it optimizes some cases + -- knowing that associative rearrangement is allowed for constant folding + -- if one of the operands is a compile time known value + + function Assoc_Subtract + (Loc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) return Node_Id; + -- This is like Make_Op_Subtract except that it optimizes some cases + -- knowing that associative rearrangement is allowed for constant folding + -- if one of the operands is a compile time known value + + function Bits_To_SU (N : Node_Id) return Node_Id; + -- This is used when we cross the boundary from static sizes in bits to + -- dynamic sizes in storage units. If the argument N is anything other + -- than an integer literal, it is returned unchanged, but if it is an + -- integer literal, then it is taken as a size in bits, and is replaced + -- by the corresponding size in storage units. + + function Compute_Length (Lo : Node_Id; Hi : Node_Id) return Node_Id; + -- Given expressions for the low bound (Lo) and the high bound (Hi), + -- Build an expression for the value hi-lo+1, converted to type + -- Standard.Unsigned. Takes care of the case where the operands + -- are of an enumeration type (so that the subtraction cannot be + -- done directly) by applying the Pos operator to Hi/Lo first. + + function Expr_From_SO_Ref + (Loc : Source_Ptr; + D : SO_Ref; + Comp : Entity_Id := Empty) return Node_Id; + -- Given a value D from a size or offset field, return an expression + -- representing the value stored. If the value is known at compile time, + -- then an N_Integer_Literal is returned with the appropriate value. If + -- the value references a constant entity, then an N_Identifier node + -- referencing this entity is returned. If the value denotes a size + -- function, then returns a call node denoting the given function, with + -- a single actual parameter that either refers to the parameter V of + -- an enclosing size function (if Comp is Empty or its type doesn't match + -- the function's formal), or else is a selected component V.c when Comp + -- denotes a component c whose type matches that of the function formal. + -- The Loc value is used for the Sloc value of constructed notes. + + function SO_Ref_From_Expr + (Expr : Node_Id; + Ins_Type : Entity_Id; + Vtype : Entity_Id := Empty; + Make_Func : Boolean := False) return Dynamic_SO_Ref; + -- This routine is used in the case where a size/offset value is dynamic + -- and is represented by the expression Expr. SO_Ref_From_Expr checks if + -- the Expr contains a reference to the identifier V, and if so builds + -- a function depending on discriminants of the formal parameter V which + -- is of type Vtype. Otherwise, if the parameter Make_Func is True, then + -- Expr will be encapsulated in a parameterless function; if Make_Func is + -- False, then a constant entity with the value Expr is built. The result + -- is a Dynamic_SO_Ref to the created entity. Note that Vtype can be + -- omitted if Expr does not contain any reference to V, the created entity. + -- The declaration created is inserted in the freeze actions of Ins_Type, + -- which also supplies the Sloc for created nodes. This function also takes + -- care of making sure that the expression is properly analyzed and + -- resolved (which may not be the case yet if we build the expression + -- in this unit). + + function Get_Max_SU_Size (E : Entity_Id) return Node_Id; + -- E is an array type or subtype that has at least one index bound that + -- is the value of a record discriminant. For such an array, the function + -- computes an expression that yields the maximum possible size of the + -- array in storage units. The result is not defined for any other type, + -- or for arrays that do not depend on discriminants, and it is a fatal + -- error to call this unless Size_Depends_On_Discriminant (E) is True. + + procedure Layout_Array_Type (E : Entity_Id); + -- Front-end layout of non-bit-packed array type or subtype + + procedure Layout_Record_Type (E : Entity_Id); + -- Front-end layout of record type + + procedure Rewrite_Integer (N : Node_Id; V : Uint); + -- Rewrite node N with an integer literal whose value is V. The Sloc for + -- the new node is taken from N, and the type of the literal is set to a + -- copy of the type of N on entry. + + procedure Set_And_Check_Static_Size + (E : Entity_Id; + Esiz : SO_Ref; + RM_Siz : SO_Ref); + -- This procedure is called to check explicit given sizes (possibly stored + -- in the Esize and RM_Size fields of E) against computed Object_Size + -- (Esiz) and Value_Size (RM_Siz) values. Appropriate errors and warnings + -- are posted if specified sizes are inconsistent with specified sizes. On + -- return, Esize and RM_Size fields of E are set (either from previously + -- given values, or from the newly computed values, as appropriate). + + procedure Set_Composite_Alignment (E : Entity_Id); + -- This procedure is called for record types and subtypes, and also for + -- atomic array types and subtypes. If no alignment is set, and the size + -- is 2 or 4 (or 8 if the word size is 8), then the alignment is set to + -- match the size. + + ---------------------------- + -- Adjust_Esize_Alignment -- + ---------------------------- + + procedure Adjust_Esize_Alignment (E : Entity_Id) is + Abits : Int; + Esize_Set : Boolean; + + begin + -- Nothing to do if size unknown + + if Unknown_Esize (E) then + return; + end if; + + -- Determine if size is constrained by an attribute definition clause + -- which must be obeyed. If so, we cannot increase the size in this + -- routine. + + -- For a type, the issue is whether an object size clause has been set. + -- A normal size clause constrains only the value size (RM_Size) + + if Is_Type (E) then + Esize_Set := Has_Object_Size_Clause (E); + + -- For an object, the issue is whether a size clause is present + + else + Esize_Set := Has_Size_Clause (E); + end if; + + -- If size is known it must be a multiple of the storage unit size + + if Esize (E) mod SSU /= 0 then + + -- If not, and size specified, then give error + + if Esize_Set then + Error_Msg_NE + ("size for& not a multiple of storage unit size", + Size_Clause (E), E); + return; + + -- Otherwise bump up size to a storage unit boundary + + else + Set_Esize (E, (Esize (E) + SSU - 1) / SSU * SSU); + end if; + end if; + + -- Now we have the size set, it must be a multiple of the alignment + -- nothing more we can do here if the alignment is unknown here. + + if Unknown_Alignment (E) then + return; + end if; + + -- At this point both the Esize and Alignment are known, so we need + -- to make sure they are consistent. + + Abits := UI_To_Int (Alignment (E)) * SSU; + + if Esize (E) mod Abits = 0 then + return; + end if; + + -- Here we have a situation where the Esize is not a multiple of the + -- alignment. We must either increase Esize or reduce the alignment to + -- correct this situation. + + -- The case in which we can decrease the alignment is where the + -- alignment was not set by an alignment clause, and the type in + -- question is a discrete type, where it is definitely safe to reduce + -- the alignment. For example: + + -- t : integer range 1 .. 2; + -- for t'size use 8; + + -- In this situation, the initial alignment of t is 4, copied from + -- the Integer base type, but it is safe to reduce it to 1 at this + -- stage, since we will only be loading a single storage unit. + + if Is_Discrete_Type (Etype (E)) + and then not Has_Alignment_Clause (E) + then + loop + Abits := Abits / 2; + exit when Esize (E) mod Abits = 0; + end loop; + + Init_Alignment (E, Abits / SSU); + return; + end if; + + -- Now the only possible approach left is to increase the Esize but we + -- can't do that if the size was set by a specific clause. + + if Esize_Set then + Error_Msg_NE + ("size for& is not a multiple of alignment", + Size_Clause (E), E); + + -- Otherwise we can indeed increase the size to a multiple of alignment + + else + Set_Esize (E, ((Esize (E) + (Abits - 1)) / Abits) * Abits); + end if; + end Adjust_Esize_Alignment; + + --------------- + -- Assoc_Add -- + --------------- + + function Assoc_Add + (Loc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) return Node_Id + is + L : Node_Id; + R : Uint; + + begin + -- Case of right operand is a constant + + if Compile_Time_Known_Value (Right_Opnd) then + L := Left_Opnd; + R := Expr_Value (Right_Opnd); + + -- Case of left operand is a constant + + elsif Compile_Time_Known_Value (Left_Opnd) then + L := Right_Opnd; + R := Expr_Value (Left_Opnd); + + -- Neither operand is a constant, do the addition with no optimization + + else + return Make_Op_Add (Loc, Left_Opnd, Right_Opnd); + end if; + + -- Case of left operand is an addition + + if Nkind (L) = N_Op_Add then + + -- (C1 + E) + C2 = (C1 + C2) + E + + if Compile_Time_Known_Value (Sinfo.Left_Opnd (L)) then + Rewrite_Integer + (Sinfo.Left_Opnd (L), + Expr_Value (Sinfo.Left_Opnd (L)) + R); + return L; + + -- (E + C1) + C2 = E + (C1 + C2) + + elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L)) then + Rewrite_Integer + (Sinfo.Right_Opnd (L), + Expr_Value (Sinfo.Right_Opnd (L)) + R); + return L; + end if; + + -- Case of left operand is a subtraction + + elsif Nkind (L) = N_Op_Subtract then + + -- (C1 - E) + C2 = (C1 + C2) + E + + if Compile_Time_Known_Value (Sinfo.Left_Opnd (L)) then + Rewrite_Integer + (Sinfo.Left_Opnd (L), + Expr_Value (Sinfo.Left_Opnd (L)) + R); + return L; + + -- (E - C1) + C2 = E - (C1 - C2) + + elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L)) then + Rewrite_Integer + (Sinfo.Right_Opnd (L), + Expr_Value (Sinfo.Right_Opnd (L)) - R); + return L; + end if; + end if; + + -- Not optimizable, do the addition + + return Make_Op_Add (Loc, Left_Opnd, Right_Opnd); + end Assoc_Add; + + -------------------- + -- Assoc_Multiply -- + -------------------- + + function Assoc_Multiply + (Loc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) return Node_Id + is + L : Node_Id; + R : Uint; + + begin + -- Case of right operand is a constant + + if Compile_Time_Known_Value (Right_Opnd) then + L := Left_Opnd; + R := Expr_Value (Right_Opnd); + + -- Case of left operand is a constant + + elsif Compile_Time_Known_Value (Left_Opnd) then + L := Right_Opnd; + R := Expr_Value (Left_Opnd); + + -- Neither operand is a constant, do the multiply with no optimization + + else + return Make_Op_Multiply (Loc, Left_Opnd, Right_Opnd); + end if; + + -- Case of left operand is an multiplication + + if Nkind (L) = N_Op_Multiply then + + -- (C1 * E) * C2 = (C1 * C2) + E + + if Compile_Time_Known_Value (Sinfo.Left_Opnd (L)) then + Rewrite_Integer + (Sinfo.Left_Opnd (L), + Expr_Value (Sinfo.Left_Opnd (L)) * R); + return L; + + -- (E * C1) * C2 = E * (C1 * C2) + + elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L)) then + Rewrite_Integer + (Sinfo.Right_Opnd (L), + Expr_Value (Sinfo.Right_Opnd (L)) * R); + return L; + end if; + end if; + + -- Not optimizable, do the multiplication + + return Make_Op_Multiply (Loc, Left_Opnd, Right_Opnd); + end Assoc_Multiply; + + -------------------- + -- Assoc_Subtract -- + -------------------- + + function Assoc_Subtract + (Loc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) return Node_Id + is + L : Node_Id; + R : Uint; + + begin + -- Case of right operand is a constant + + if Compile_Time_Known_Value (Right_Opnd) then + L := Left_Opnd; + R := Expr_Value (Right_Opnd); + + -- Right operand is a constant, do the subtract with no optimization + + else + return Make_Op_Subtract (Loc, Left_Opnd, Right_Opnd); + end if; + + -- Case of left operand is an addition + + if Nkind (L) = N_Op_Add then + + -- (C1 + E) - C2 = (C1 - C2) + E + + if Compile_Time_Known_Value (Sinfo.Left_Opnd (L)) then + Rewrite_Integer + (Sinfo.Left_Opnd (L), + Expr_Value (Sinfo.Left_Opnd (L)) - R); + return L; + + -- (E + C1) - C2 = E + (C1 - C2) + + elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L)) then + Rewrite_Integer + (Sinfo.Right_Opnd (L), + Expr_Value (Sinfo.Right_Opnd (L)) - R); + return L; + end if; + + -- Case of left operand is a subtraction + + elsif Nkind (L) = N_Op_Subtract then + + -- (C1 - E) - C2 = (C1 - C2) + E + + if Compile_Time_Known_Value (Sinfo.Left_Opnd (L)) then + Rewrite_Integer + (Sinfo.Left_Opnd (L), + Expr_Value (Sinfo.Left_Opnd (L)) + R); + return L; + + -- (E - C1) - C2 = E - (C1 + C2) + + elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L)) then + Rewrite_Integer + (Sinfo.Right_Opnd (L), + Expr_Value (Sinfo.Right_Opnd (L)) + R); + return L; + end if; + end if; + + -- Not optimizable, do the subtraction + + return Make_Op_Subtract (Loc, Left_Opnd, Right_Opnd); + end Assoc_Subtract; + + ---------------- + -- Bits_To_SU -- + ---------------- + + function Bits_To_SU (N : Node_Id) return Node_Id is + begin + if Nkind (N) = N_Integer_Literal then + Set_Intval (N, (Intval (N) + (SSU - 1)) / SSU); + end if; + + return N; + end Bits_To_SU; + + -------------------- + -- Compute_Length -- + -------------------- + + function Compute_Length (Lo : Node_Id; Hi : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (Lo); + Typ : constant Entity_Id := Etype (Lo); + Lo_Op : Node_Id; + Hi_Op : Node_Id; + Lo_Dim : Uint; + Hi_Dim : Uint; + + begin + -- If the bounds are First and Last attributes for the same dimension + -- and both have prefixes that denotes the same entity, then we create + -- and return a Length attribute. This may allow the back end to + -- generate better code in cases where it already has the length. + + if Nkind (Lo) = N_Attribute_Reference + and then Attribute_Name (Lo) = Name_First + and then Nkind (Hi) = N_Attribute_Reference + and then Attribute_Name (Hi) = Name_Last + and then Is_Entity_Name (Prefix (Lo)) + and then Is_Entity_Name (Prefix (Hi)) + and then Entity (Prefix (Lo)) = Entity (Prefix (Hi)) + then + Lo_Dim := Uint_1; + Hi_Dim := Uint_1; + + if Present (First (Expressions (Lo))) then + Lo_Dim := Expr_Value (First (Expressions (Lo))); + end if; + + if Present (First (Expressions (Hi))) then + Hi_Dim := Expr_Value (First (Expressions (Hi))); + end if; + + if Lo_Dim = Hi_Dim then + return + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of + (Entity (Prefix (Lo)), Loc), + Attribute_Name => Name_Length, + Expressions => New_List + (Make_Integer_Literal (Loc, Lo_Dim))); + end if; + end if; + + Lo_Op := New_Copy_Tree (Lo); + Hi_Op := New_Copy_Tree (Hi); + + -- If type is enumeration type, then use Pos attribute to convert + -- to integer type for which subtraction is a permitted operation. + + if Is_Enumeration_Type (Typ) then + Lo_Op := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List (Lo_Op)); + + Hi_Op := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List (Hi_Op)); + end if; + + return + Assoc_Add (Loc, + Left_Opnd => + Assoc_Subtract (Loc, + Left_Opnd => Hi_Op, + Right_Opnd => Lo_Op), + Right_Opnd => Make_Integer_Literal (Loc, 1)); + end Compute_Length; + + ---------------------- + -- Expr_From_SO_Ref -- + ---------------------- + + function Expr_From_SO_Ref + (Loc : Source_Ptr; + D : SO_Ref; + Comp : Entity_Id := Empty) return Node_Id + is + Ent : Entity_Id; + + begin + if Is_Dynamic_SO_Ref (D) then + Ent := Get_Dynamic_SO_Entity (D); + + if Is_Discrim_SO_Function (Ent) then + + -- If a component is passed in whose type matches the type of + -- the function formal, then select that component from the "V" + -- parameter rather than passing "V" directly. + + if Present (Comp) + and then Base_Type (Etype (Comp)) + = Base_Type (Etype (First_Formal (Ent))) + then + return + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Ent, Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Vname), + Selector_Name => New_Occurrence_Of (Comp, Loc)))); + + else + return + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Ent, Loc), + Parameter_Associations => New_List ( + Make_Identifier (Loc, Vname))); + end if; + + else + return New_Occurrence_Of (Ent, Loc); + end if; + + else + return Make_Integer_Literal (Loc, D); + end if; + end Expr_From_SO_Ref; + + --------------------- + -- Get_Max_SU_Size -- + --------------------- + + function Get_Max_SU_Size (E : Entity_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (E); + Indx : Node_Id; + Ityp : Entity_Id; + Lo : Node_Id; + Hi : Node_Id; + S : Uint; + Len : Node_Id; + + type Val_Status_Type is (Const, Dynamic); + + type Val_Type (Status : Val_Status_Type := Const) is + record + case Status is + when Const => Val : Uint; + when Dynamic => Nod : Node_Id; + end case; + end record; + -- Shows the status of the value so far. Const means that the value is + -- constant, and Val is the current constant value. Dynamic means that + -- the value is dynamic, and in this case Nod is the Node_Id of the + -- expression to compute the value. + + Size : Val_Type; + -- Calculated value so far if Size.Status = Const, + -- or expression value so far if Size.Status = Dynamic. + + SU_Convert_Required : Boolean := False; + -- This is set to True if the final result must be converted from bits + -- to storage units (rounding up to a storage unit boundary). + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Max_Discrim (N : in out Node_Id); + -- If the node N represents a discriminant, replace it by the maximum + -- value of the discriminant. + + procedure Min_Discrim (N : in out Node_Id); + -- If the node N represents a discriminant, replace it by the minimum + -- value of the discriminant. + + ----------------- + -- Max_Discrim -- + ----------------- + + procedure Max_Discrim (N : in out Node_Id) is + begin + if Nkind (N) = N_Identifier + and then Ekind (Entity (N)) = E_Discriminant + then + N := Type_High_Bound (Etype (N)); + end if; + end Max_Discrim; + + ----------------- + -- Min_Discrim -- + ----------------- + + procedure Min_Discrim (N : in out Node_Id) is + begin + if Nkind (N) = N_Identifier + and then Ekind (Entity (N)) = E_Discriminant + then + N := Type_Low_Bound (Etype (N)); + end if; + end Min_Discrim; + + -- Start of processing for Get_Max_SU_Size + + begin + pragma Assert (Size_Depends_On_Discriminant (E)); + + -- Initialize status from component size + + if Known_Static_Component_Size (E) then + Size := (Const, Component_Size (E)); + + else + Size := (Dynamic, Expr_From_SO_Ref (Loc, Component_Size (E))); + end if; + + -- Loop through indexes + + Indx := First_Index (E); + while Present (Indx) loop + Ityp := Etype (Indx); + Lo := Type_Low_Bound (Ityp); + Hi := Type_High_Bound (Ityp); + + Min_Discrim (Lo); + Max_Discrim (Hi); + + -- Value of the current subscript range is statically known + + if Compile_Time_Known_Value (Lo) + and then Compile_Time_Known_Value (Hi) + then + S := Expr_Value (Hi) - Expr_Value (Lo) + 1; + + -- If known flat bound, entire size of array is zero! + + if S <= 0 then + return Make_Integer_Literal (Loc, 0); + end if; + + -- Current value is constant, evolve value + + if Size.Status = Const then + Size.Val := Size.Val * S; + + -- Current value is dynamic + + else + -- An interesting little optimization, if we have a pending + -- conversion from bits to storage units, and the current + -- length is a multiple of the storage unit size, then we + -- can take the factor out here statically, avoiding some + -- extra dynamic computations at the end. + + if SU_Convert_Required and then S mod SSU = 0 then + S := S / SSU; + SU_Convert_Required := False; + end if; + + Size.Nod := + Assoc_Multiply (Loc, + Left_Opnd => Size.Nod, + Right_Opnd => + Make_Integer_Literal (Loc, Intval => S)); + end if; + + -- Value of the current subscript range is dynamic + + else + -- If the current size value is constant, then here is where we + -- make a transition to dynamic values, which are always stored + -- in storage units, However, we do not want to convert to SU's + -- too soon, consider the case of a packed array of single bits, + -- we want to do the SU conversion after computing the size in + -- this case. + + if Size.Status = Const then + + -- If the current value is a multiple of the storage unit, + -- then most certainly we can do the conversion now, simply + -- by dividing the current value by the storage unit value. + -- If this works, we set SU_Convert_Required to False. + + if Size.Val mod SSU = 0 then + + Size := + (Dynamic, Make_Integer_Literal (Loc, Size.Val / SSU)); + SU_Convert_Required := False; + + -- Otherwise, we go ahead and convert the value in bits, and + -- set SU_Convert_Required to True to ensure that the final + -- value is indeed properly converted. + + else + Size := (Dynamic, Make_Integer_Literal (Loc, Size.Val)); + SU_Convert_Required := True; + end if; + end if; + + -- Length is hi-lo+1 + + Len := Compute_Length (Lo, Hi); + + -- Check possible range of Len + + declare + OK : Boolean; + LLo : Uint; + LHi : Uint; + pragma Warnings (Off, LHi); + + begin + Set_Parent (Len, E); + Determine_Range (Len, OK, LLo, LHi); + + Len := Convert_To (Standard_Unsigned, Len); + + -- If we cannot verify that range cannot be super-flat, we need + -- a max with zero, since length must be non-negative. + + if not OK or else LLo < 0 then + Len := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Standard_Unsigned, Loc), + Attribute_Name => Name_Max, + Expressions => New_List ( + Make_Integer_Literal (Loc, 0), + Len)); + end if; + end; + end if; + + Next_Index (Indx); + end loop; + + -- Here after processing all bounds to set sizes. If the value is a + -- constant, then it is bits, so we convert to storage units. + + if Size.Status = Const then + return Bits_To_SU (Make_Integer_Literal (Loc, Size.Val)); + + -- Case where the value is dynamic + + else + -- Do convert from bits to SU's if needed + + if SU_Convert_Required then + + -- The expression required is (Size.Nod + SU - 1) / SU + + Size.Nod := + Make_Op_Divide (Loc, + Left_Opnd => + Make_Op_Add (Loc, + Left_Opnd => Size.Nod, + Right_Opnd => Make_Integer_Literal (Loc, SSU - 1)), + Right_Opnd => Make_Integer_Literal (Loc, SSU)); + end if; + + return Size.Nod; + end if; + end Get_Max_SU_Size; + + ----------------------- + -- Layout_Array_Type -- + ----------------------- + + procedure Layout_Array_Type (E : Entity_Id) is + Loc : constant Source_Ptr := Sloc (E); + Ctyp : constant Entity_Id := Component_Type (E); + Indx : Node_Id; + Ityp : Entity_Id; + Lo : Node_Id; + Hi : Node_Id; + S : Uint; + Len : Node_Id; + + Insert_Typ : Entity_Id; + -- This is the type with which any generated constants or functions + -- will be associated (i.e. inserted into the freeze actions). This + -- is normally the type being laid out. The exception occurs when + -- we are laying out Itype's which are local to a record type, and + -- whose scope is this record type. Such types do not have freeze + -- nodes (because we have no place to put them). + + ------------------------------------ + -- How An Array Type is Laid Out -- + ------------------------------------ + + -- Here is what goes on. We need to multiply the component size of the + -- array (which has already been set) by the length of each of the + -- indexes. If all these values are known at compile time, then the + -- resulting size of the array is the appropriate constant value. + + -- If the component size or at least one bound is dynamic (but no + -- discriminants are present), then the size will be computed as an + -- expression that calculates the proper size. + + -- If there is at least one discriminant bound, then the size is also + -- computed as an expression, but this expression contains discriminant + -- values which are obtained by selecting from a function parameter, and + -- the size is given by a function that is passed the variant record in + -- question, and whose body is the expression. + + type Val_Status_Type is (Const, Dynamic, Discrim); + + type Val_Type (Status : Val_Status_Type := Const) is + record + case Status is + when Const => + Val : Uint; + -- Calculated value so far if Val_Status = Const + + when Dynamic | Discrim => + Nod : Node_Id; + -- Expression value so far if Val_Status /= Const + + end case; + end record; + -- Records the value or expression computed so far. Const means that + -- the value is constant, and Val is the current constant value. + -- Dynamic means that the value is dynamic, and in this case Nod is + -- the Node_Id of the expression to compute the value, and Discrim + -- means that at least one bound is a discriminant, in which case Nod + -- is the expression so far (which will be the body of the function). + + Size : Val_Type; + -- Value of size computed so far. See comments above + + Vtyp : Entity_Id := Empty; + -- Variant record type for the formal parameter of the discriminant + -- function V if Status = Discrim. + + SU_Convert_Required : Boolean := False; + -- This is set to True if the final result must be converted from + -- bits to storage units (rounding up to a storage unit boundary). + + Storage_Divisor : Uint := UI_From_Int (SSU); + -- This is the amount that a nonstatic computed size will be divided + -- by to convert it from bits to storage units. This is normally + -- equal to SSU, but can be reduced in the case of packed components + -- that fit evenly into a storage unit. + + Make_Size_Function : Boolean := False; + -- Indicates whether to request that SO_Ref_From_Expr should + -- encapsulate the array size expression in a function. + + procedure Discrimify (N : in out Node_Id); + -- If N represents a discriminant, then the Size.Status is set to + -- Discrim, and Vtyp is set. The parameter N is replaced with the + -- proper expression to extract the discriminant value from V. + + ---------------- + -- Discrimify -- + ---------------- + + procedure Discrimify (N : in out Node_Id) is + Decl : Node_Id; + Typ : Entity_Id; + + begin + if Nkind (N) = N_Identifier + and then Ekind (Entity (N)) = E_Discriminant + then + Set_Size_Depends_On_Discriminant (E); + + if Size.Status /= Discrim then + Decl := Parent (Parent (Entity (N))); + Size := (Discrim, Size.Nod); + Vtyp := Defining_Identifier (Decl); + end if; + + Typ := Etype (N); + + N := + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Vname), + Selector_Name => New_Occurrence_Of (Entity (N), Loc)); + + -- Set the Etype attributes of the selected name and its prefix. + -- Analyze_And_Resolve can't be called here because the Vname + -- entity denoted by the prefix will not yet exist (it's created + -- by SO_Ref_From_Expr, called at the end of Layout_Array_Type). + + Set_Etype (Prefix (N), Vtyp); + Set_Etype (N, Typ); + end if; + end Discrimify; + + -- Start of processing for Layout_Array_Type + + begin + -- Default alignment is component alignment + + if Unknown_Alignment (E) then + Set_Alignment (E, Alignment (Ctyp)); + end if; + + -- Calculate proper type for insertions + + if Is_Record_Type (Underlying_Type (Scope (E))) then + Insert_Typ := Underlying_Type (Scope (E)); + else + Insert_Typ := E; + end if; + + -- If the component type is a generic formal type then there's no point + -- in determining a size for the array type. + + if Is_Generic_Type (Ctyp) then + return; + end if; + + -- Deal with component size if base type + + if Ekind (E) = E_Array_Type then + + -- Cannot do anything if Esize of component type unknown + + if Unknown_Esize (Ctyp) then + return; + end if; + + -- Set component size if not set already + + if Unknown_Component_Size (E) then + Set_Component_Size (E, Esize (Ctyp)); + end if; + end if; + + -- (RM 13.3 (48)) says that the size of an unconstrained array + -- is implementation defined. We choose to leave it as Unknown + -- here, and the actual behavior is determined by the back end. + + if not Is_Constrained (E) then + return; + end if; + + -- Initialize status from component size + + if Known_Static_Component_Size (E) then + Size := (Const, Component_Size (E)); + + else + Size := (Dynamic, Expr_From_SO_Ref (Loc, Component_Size (E))); + end if; + + -- Loop to process array indexes + + Indx := First_Index (E); + while Present (Indx) loop + Ityp := Etype (Indx); + + -- If an index of the array is a generic formal type then there is + -- no point in determining a size for the array type. + + if Is_Generic_Type (Ityp) then + return; + end if; + + Lo := Type_Low_Bound (Ityp); + Hi := Type_High_Bound (Ityp); + + -- Value of the current subscript range is statically known + + if Compile_Time_Known_Value (Lo) + and then Compile_Time_Known_Value (Hi) + then + S := Expr_Value (Hi) - Expr_Value (Lo) + 1; + + -- If known flat bound, entire size of array is zero! + + if S <= 0 then + Set_Esize (E, Uint_0); + Set_RM_Size (E, Uint_0); + return; + end if; + + -- If constant, evolve value + + if Size.Status = Const then + Size.Val := Size.Val * S; + + -- Current value is dynamic + + else + -- An interesting little optimization, if we have a pending + -- conversion from bits to storage units, and the current + -- length is a multiple of the storage unit size, then we + -- can take the factor out here statically, avoiding some + -- extra dynamic computations at the end. + + if SU_Convert_Required and then S mod SSU = 0 then + S := S / SSU; + SU_Convert_Required := False; + end if; + + -- Now go ahead and evolve the expression + + Size.Nod := + Assoc_Multiply (Loc, + Left_Opnd => Size.Nod, + Right_Opnd => + Make_Integer_Literal (Loc, Intval => S)); + end if; + + -- Value of the current subscript range is dynamic + + else + -- If the current size value is constant, then here is where we + -- make a transition to dynamic values, which are always stored + -- in storage units, However, we do not want to convert to SU's + -- too soon, consider the case of a packed array of single bits, + -- we want to do the SU conversion after computing the size in + -- this case. + + if Size.Status = Const then + + -- If the current value is a multiple of the storage unit, + -- then most certainly we can do the conversion now, simply + -- by dividing the current value by the storage unit value. + -- If this works, we set SU_Convert_Required to False. + + if Size.Val mod SSU = 0 then + Size := + (Dynamic, Make_Integer_Literal (Loc, Size.Val / SSU)); + SU_Convert_Required := False; + + -- If the current value is a factor of the storage unit, then + -- we can use a value of one for the size and reduce the + -- strength of the later division. + + elsif SSU mod Size.Val = 0 then + Storage_Divisor := SSU / Size.Val; + Size := (Dynamic, Make_Integer_Literal (Loc, Uint_1)); + SU_Convert_Required := True; + + -- Otherwise, we go ahead and convert the value in bits, and + -- set SU_Convert_Required to True to ensure that the final + -- value is indeed properly converted. + + else + Size := (Dynamic, Make_Integer_Literal (Loc, Size.Val)); + SU_Convert_Required := True; + end if; + end if; + + Discrimify (Lo); + Discrimify (Hi); + + -- Length is hi-lo+1 + + Len := Compute_Length (Lo, Hi); + + -- If Len isn't a Length attribute, then its range needs to be + -- checked a possible Max with zero needs to be computed. + + if Nkind (Len) /= N_Attribute_Reference + or else Attribute_Name (Len) /= Name_Length + then + declare + OK : Boolean; + LLo : Uint; + LHi : Uint; + + begin + -- Check possible range of Len + + Set_Parent (Len, E); + Determine_Range (Len, OK, LLo, LHi); + + Len := Convert_To (Standard_Unsigned, Len); + + -- If range definitely flat or superflat, + -- result size is zero + + if OK and then LHi <= 0 then + Set_Esize (E, Uint_0); + Set_RM_Size (E, Uint_0); + return; + end if; + + -- If we cannot verify that range cannot be super-flat, we + -- need a max with zero, since length cannot be negative. + + if not OK or else LLo < 0 then + Len := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Standard_Unsigned, Loc), + Attribute_Name => Name_Max, + Expressions => New_List ( + Make_Integer_Literal (Loc, 0), + Len)); + end if; + end; + end if; + + -- At this stage, Len has the expression for the length + + Size.Nod := + Assoc_Multiply (Loc, + Left_Opnd => Size.Nod, + Right_Opnd => Len); + end if; + + Next_Index (Indx); + end loop; + + -- Here after processing all bounds to set sizes. If the value is a + -- constant, then it is bits, and the only thing we need to do is to + -- check against explicit given size and do alignment adjust. + + if Size.Status = Const then + Set_And_Check_Static_Size (E, Size.Val, Size.Val); + Adjust_Esize_Alignment (E); + + -- Case where the value is dynamic + + else + -- Do convert from bits to SU's if needed + + if SU_Convert_Required then + + -- The expression required is: + -- (Size.Nod + Storage_Divisor - 1) / Storage_Divisor + + Size.Nod := + Make_Op_Divide (Loc, + Left_Opnd => + Make_Op_Add (Loc, + Left_Opnd => Size.Nod, + Right_Opnd => Make_Integer_Literal + (Loc, Storage_Divisor - 1)), + Right_Opnd => Make_Integer_Literal (Loc, Storage_Divisor)); + end if; + + -- If the array entity is not declared at the library level and its + -- not nested within a subprogram that is marked for inlining, then + -- we request that the size expression be encapsulated in a function. + -- Since this expression is not needed in most cases, we prefer not + -- to incur the overhead of the computation on calls to the enclosing + -- subprogram except for subprograms that require the size. + + if not Is_Library_Level_Entity (E) then + Make_Size_Function := True; + + declare + Parent_Subp : Entity_Id := Enclosing_Subprogram (E); + + begin + while Present (Parent_Subp) loop + if Is_Inlined (Parent_Subp) then + Make_Size_Function := False; + exit; + end if; + + Parent_Subp := Enclosing_Subprogram (Parent_Subp); + end loop; + end; + end if; + + -- Now set the dynamic size (the Value_Size is always the same + -- as the Object_Size for arrays whose length is dynamic). + + -- ??? If Size.Status = Dynamic, Vtyp will not have been set. + -- The added initialization sets it to Empty now, but is this + -- correct? + + Set_Esize + (E, + SO_Ref_From_Expr + (Size.Nod, Insert_Typ, Vtyp, Make_Func => Make_Size_Function)); + Set_RM_Size (E, Esize (E)); + end if; + end Layout_Array_Type; + + ------------------- + -- Layout_Object -- + ------------------- + + procedure Layout_Object (E : Entity_Id) is + T : constant Entity_Id := Etype (E); + + begin + -- Nothing to do if backend does layout + + if not Frontend_Layout_On_Target then + return; + end if; + + -- Set size if not set for object and known for type. Use the RM_Size if + -- that is known for the type and Esize is not. + + if Unknown_Esize (E) then + if Known_Esize (T) then + Set_Esize (E, Esize (T)); + + elsif Known_RM_Size (T) then + Set_Esize (E, RM_Size (T)); + end if; + end if; + + -- Set alignment from type if unknown and type alignment known + + if Unknown_Alignment (E) and then Known_Alignment (T) then + Set_Alignment (E, Alignment (T)); + end if; + + -- Make sure size and alignment are consistent + + Adjust_Esize_Alignment (E); + + -- Final adjustment, if we don't know the alignment, and the Esize was + -- not set by an explicit Object_Size attribute clause, then we reset + -- the Esize to unknown, since we really don't know it. + + if Unknown_Alignment (E) + and then not Has_Size_Clause (E) + then + Set_Esize (E, Uint_0); + end if; + end Layout_Object; + + ------------------------ + -- Layout_Record_Type -- + ------------------------ + + procedure Layout_Record_Type (E : Entity_Id) is + Loc : constant Source_Ptr := Sloc (E); + Decl : Node_Id; + + Comp : Entity_Id; + -- Current component being laid out + + Prev_Comp : Entity_Id; + -- Previous laid out component + + procedure Get_Next_Component_Location + (Prev_Comp : Entity_Id; + Align : Uint; + New_Npos : out SO_Ref; + New_Fbit : out SO_Ref; + New_NPMax : out SO_Ref; + Force_SU : Boolean); + -- Given the previous component in Prev_Comp, which is already laid + -- out, and the alignment of the following component, lays out the + -- following component, and returns its starting position in New_Npos + -- (Normalized_Position value), New_Fbit (Normalized_First_Bit value), + -- and New_NPMax (Normalized_Position_Max value). If Prev_Comp is empty + -- (no previous component is present), then New_Npos, New_Fbit and + -- New_NPMax are all set to zero on return. This procedure is also + -- used to compute the size of a record or variant by giving it the + -- last component, and the record alignment. Force_SU is used to force + -- the new component location to be aligned on a storage unit boundary, + -- even in a packed record, False means that the new position does not + -- need to be bumped to a storage unit boundary, True means a storage + -- unit boundary is always required. + + procedure Layout_Component (Comp : Entity_Id; Prev_Comp : Entity_Id); + -- Lays out component Comp, given Prev_Comp, the previously laid-out + -- component (Prev_Comp = Empty if no components laid out yet). The + -- alignment of the record itself is also updated if needed. Both + -- Comp and Prev_Comp can be either components or discriminants. + + procedure Layout_Components + (From : Entity_Id; + To : Entity_Id; + Esiz : out SO_Ref; + RM_Siz : out SO_Ref); + -- This procedure lays out the components of the given component list + -- which contains the components starting with From and ending with To. + -- The Next_Entity chain is used to traverse the components. On entry, + -- Prev_Comp is set to the component preceding the list, so that the + -- list is laid out after this component. Prev_Comp is set to Empty if + -- the component list is to be laid out starting at the start of the + -- record. On return, the components are all laid out, and Prev_Comp is + -- set to the last laid out component. On return, Esiz is set to the + -- resulting Object_Size value, which is the length of the record up + -- to and including the last laid out entity. For Esiz, the value is + -- adjusted to match the alignment of the record. RM_Siz is similarly + -- set to the resulting Value_Size value, which is the same length, but + -- not adjusted to meet the alignment. Note that in the case of variant + -- records, Esiz represents the maximum size. + + procedure Layout_Non_Variant_Record; + -- Procedure called to lay out a non-variant record type or subtype + + procedure Layout_Variant_Record; + -- Procedure called to lay out a variant record type. Decl is set to the + -- full type declaration for the variant record. + + --------------------------------- + -- Get_Next_Component_Location -- + --------------------------------- + + procedure Get_Next_Component_Location + (Prev_Comp : Entity_Id; + Align : Uint; + New_Npos : out SO_Ref; + New_Fbit : out SO_Ref; + New_NPMax : out SO_Ref; + Force_SU : Boolean) + is + begin + -- No previous component, return zero position + + if No (Prev_Comp) then + New_Npos := Uint_0; + New_Fbit := Uint_0; + New_NPMax := Uint_0; + return; + end if; + + -- Here we have a previous component + + declare + Loc : constant Source_Ptr := Sloc (Prev_Comp); + + Old_Npos : constant SO_Ref := Normalized_Position (Prev_Comp); + Old_Fbit : constant SO_Ref := Normalized_First_Bit (Prev_Comp); + Old_NPMax : constant SO_Ref := Normalized_Position_Max (Prev_Comp); + Old_Esiz : constant SO_Ref := Esize (Prev_Comp); + + Old_Maxsz : Node_Id; + -- Expression representing maximum size of previous component + + begin + -- Case where previous field had a dynamic size + + if Is_Dynamic_SO_Ref (Esize (Prev_Comp)) then + + -- If the previous field had a dynamic length, then it is + -- required to occupy an integral number of storage units, + -- and start on a storage unit boundary. This means that + -- the Normalized_First_Bit value is zero in the previous + -- component, and the new value is also set to zero. + + New_Fbit := Uint_0; + + -- In this case, the new position is given by an expression + -- that is the sum of old normalized position and old size. + + New_Npos := + SO_Ref_From_Expr + (Assoc_Add (Loc, + Left_Opnd => + Expr_From_SO_Ref (Loc, Old_Npos), + Right_Opnd => + Expr_From_SO_Ref (Loc, Old_Esiz, Prev_Comp)), + Ins_Type => E, + Vtype => E); + + -- Get maximum size of previous component + + if Size_Depends_On_Discriminant (Etype (Prev_Comp)) then + Old_Maxsz := Get_Max_SU_Size (Etype (Prev_Comp)); + else + Old_Maxsz := Expr_From_SO_Ref (Loc, Old_Esiz, Prev_Comp); + end if; + + -- Now we can compute the new max position. If the max size + -- is static and the old position is static, then we can + -- compute the new position statically. + + if Nkind (Old_Maxsz) = N_Integer_Literal + and then Known_Static_Normalized_Position_Max (Prev_Comp) + then + New_NPMax := Old_NPMax + Intval (Old_Maxsz); + + -- Otherwise new max position is dynamic + + else + New_NPMax := + SO_Ref_From_Expr + (Assoc_Add (Loc, + Left_Opnd => Expr_From_SO_Ref (Loc, Old_NPMax), + Right_Opnd => Old_Maxsz), + Ins_Type => E, + Vtype => E); + end if; + + -- Previous field has known static Esize + + else + New_Fbit := Old_Fbit + Old_Esiz; + + -- Bump New_Fbit to storage unit boundary if required + + if New_Fbit /= 0 and then Force_SU then + New_Fbit := (New_Fbit + SSU - 1) / SSU * SSU; + end if; + + -- If old normalized position is static, we can go ahead and + -- compute the new normalized position directly. + + if Known_Static_Normalized_Position (Prev_Comp) then + New_Npos := Old_Npos; + + if New_Fbit >= SSU then + New_Npos := New_Npos + New_Fbit / SSU; + New_Fbit := New_Fbit mod SSU; + end if; + + -- Bump alignment if stricter than prev + + if Align > Alignment (Etype (Prev_Comp)) then + New_Npos := (New_Npos + Align - 1) / Align * Align; + end if; + + -- The max position is always equal to the position if + -- the latter is static, since arrays depending on the + -- values of discriminants never have static sizes. + + New_NPMax := New_Npos; + return; + + -- Case of old normalized position is dynamic + + else + -- If new bit position is within the current storage unit, + -- we can just copy the old position as the result position + -- (we have already set the new first bit value). + + if New_Fbit < SSU then + New_Npos := Old_Npos; + New_NPMax := Old_NPMax; + + -- If new bit position is past the current storage unit, we + -- need to generate a new dynamic value for the position + -- ??? need to deal with alignment + + else + New_Npos := + SO_Ref_From_Expr + (Assoc_Add (Loc, + Left_Opnd => Expr_From_SO_Ref (Loc, Old_Npos), + Right_Opnd => + Make_Integer_Literal (Loc, + Intval => New_Fbit / SSU)), + Ins_Type => E, + Vtype => E); + + New_NPMax := + SO_Ref_From_Expr + (Assoc_Add (Loc, + Left_Opnd => Expr_From_SO_Ref (Loc, Old_NPMax), + Right_Opnd => + Make_Integer_Literal (Loc, + Intval => New_Fbit / SSU)), + Ins_Type => E, + Vtype => E); + New_Fbit := New_Fbit mod SSU; + end if; + end if; + end if; + end; + end Get_Next_Component_Location; + + ---------------------- + -- Layout_Component -- + ---------------------- + + procedure Layout_Component (Comp : Entity_Id; Prev_Comp : Entity_Id) is + Ctyp : constant Entity_Id := Etype (Comp); + ORC : constant Entity_Id := Original_Record_Component (Comp); + Npos : SO_Ref; + Fbit : SO_Ref; + NPMax : SO_Ref; + Forc : Boolean; + + begin + -- Increase alignment of record if necessary. Note that we do not + -- do this for packed records, which have an alignment of one by + -- default, or for records for which an explicit alignment was + -- specified with an alignment clause. + + if not Is_Packed (E) + and then not Has_Alignment_Clause (E) + and then Alignment (Ctyp) > Alignment (E) + then + Set_Alignment (E, Alignment (Ctyp)); + end if; + + -- If original component set, then use same layout + + if Present (ORC) and then ORC /= Comp then + Set_Normalized_Position (Comp, Normalized_Position (ORC)); + Set_Normalized_First_Bit (Comp, Normalized_First_Bit (ORC)); + Set_Normalized_Position_Max (Comp, Normalized_Position_Max (ORC)); + Set_Component_Bit_Offset (Comp, Component_Bit_Offset (ORC)); + Set_Esize (Comp, Esize (ORC)); + return; + end if; + + -- Parent field is always at start of record, this will overlap + -- the actual fields that are part of the parent, and that's fine + + if Chars (Comp) = Name_uParent then + Set_Normalized_Position (Comp, Uint_0); + Set_Normalized_First_Bit (Comp, Uint_0); + Set_Normalized_Position_Max (Comp, Uint_0); + Set_Component_Bit_Offset (Comp, Uint_0); + Set_Esize (Comp, Esize (Ctyp)); + return; + end if; + + -- Check case of type of component has a scope of the record we are + -- laying out. When this happens, the type in question is an Itype + -- that has not yet been laid out (that's because such types do not + -- get frozen in the normal manner, because there is no place for + -- the freeze nodes). + + if Scope (Ctyp) = E then + Layout_Type (Ctyp); + end if; + + -- If component already laid out, then we are done + + if Known_Normalized_Position (Comp) then + return; + end if; + + -- Set size of component from type. We use the Esize except in a + -- packed record, where we use the RM_Size (since that is what the + -- RM_Size value, as distinct from the Object_Size is useful for!) + + if Is_Packed (E) then + Set_Esize (Comp, RM_Size (Ctyp)); + else + Set_Esize (Comp, Esize (Ctyp)); + end if; + + -- Compute the component position from the previous one. See if + -- current component requires being on a storage unit boundary. + + -- If record is not packed, we always go to a storage unit boundary + + if not Is_Packed (E) then + Forc := True; + + -- Packed cases + + else + -- Elementary types do not need SU boundary in packed record + + if Is_Elementary_Type (Ctyp) then + Forc := False; + + -- Packed array types with a modular packed array type do not + -- force a storage unit boundary (since the code generation + -- treats these as equivalent to the underlying modular type), + + elsif Is_Array_Type (Ctyp) + and then Is_Bit_Packed_Array (Ctyp) + and then Is_Modular_Integer_Type (Packed_Array_Type (Ctyp)) + then + Forc := False; + + -- Record types with known length less than or equal to the length + -- of long long integer can also be unaligned, since they can be + -- treated as scalars. + + elsif Is_Record_Type (Ctyp) + and then not Is_Dynamic_SO_Ref (Esize (Ctyp)) + and then Esize (Ctyp) <= Esize (Standard_Long_Long_Integer) + then + Forc := False; + + -- All other cases force a storage unit boundary, even when packed + + else + Forc := True; + end if; + end if; + + -- Now get the next component location + + Get_Next_Component_Location + (Prev_Comp, Alignment (Ctyp), Npos, Fbit, NPMax, Forc); + Set_Normalized_Position (Comp, Npos); + Set_Normalized_First_Bit (Comp, Fbit); + Set_Normalized_Position_Max (Comp, NPMax); + + -- Set Component_Bit_Offset in the static case + + if Known_Static_Normalized_Position (Comp) + and then Known_Normalized_First_Bit (Comp) + then + Set_Component_Bit_Offset (Comp, SSU * Npos + Fbit); + end if; + end Layout_Component; + + ----------------------- + -- Layout_Components -- + ----------------------- + + procedure Layout_Components + (From : Entity_Id; + To : Entity_Id; + Esiz : out SO_Ref; + RM_Siz : out SO_Ref) + is + End_Npos : SO_Ref; + End_Fbit : SO_Ref; + End_NPMax : SO_Ref; + + begin + -- Only lay out components if there are some to lay out! + + if Present (From) then + + -- Lay out components with no component clauses + + Comp := From; + loop + if Ekind (Comp) = E_Component + or else Ekind (Comp) = E_Discriminant + then + -- The compatibility of component clauses with composite + -- types isn't checked in Sem_Ch13, so we check it here. + + if Present (Component_Clause (Comp)) then + if Is_Composite_Type (Etype (Comp)) + and then Esize (Comp) < RM_Size (Etype (Comp)) + then + Error_Msg_Uint_1 := RM_Size (Etype (Comp)); + Error_Msg_NE + ("size for & too small, minimum allowed is ^", + Component_Clause (Comp), + Comp); + end if; + + else + Layout_Component (Comp, Prev_Comp); + Prev_Comp := Comp; + end if; + end if; + + exit when Comp = To; + Next_Entity (Comp); + end loop; + end if; + + -- Set size fields, both are zero if no components + + if No (Prev_Comp) then + Esiz := Uint_0; + RM_Siz := Uint_0; + + -- If record subtype with non-static discriminants, then we don't + -- know which variant will be the one which gets chosen. We don't + -- just want to set the maximum size from the base, because the + -- size should depend on the particular variant. + + -- What we do is to use the RM_Size of the base type, which has + -- the necessary conditional computation of the size, using the + -- size information for the particular variant chosen. Records + -- with default discriminants for example have an Esize that is + -- set to the maximum of all variants, but that's not what we + -- want for a constrained subtype. + + elsif Ekind (E) = E_Record_Subtype + and then not Has_Static_Discriminants (E) + then + declare + BT : constant Node_Id := Base_Type (E); + begin + Esiz := RM_Size (BT); + RM_Siz := RM_Size (BT); + Set_Alignment (E, Alignment (BT)); + end; + + else + -- First the object size, for which we align past the last field + -- to the alignment of the record (the object size is required to + -- be a multiple of the alignment). + + Get_Next_Component_Location + (Prev_Comp, + Alignment (E), + End_Npos, + End_Fbit, + End_NPMax, + Force_SU => True); + + -- If the resulting normalized position is a dynamic reference, + -- then the size is dynamic, and is stored in storage units. In + -- this case, we set the RM_Size to the same value, it is simply + -- not worth distinguishing Esize and RM_Size values in the + -- dynamic case, since the RM has nothing to say about them. + + -- Note that a size cannot have been given in this case, since + -- size specifications cannot be given for variable length types. + + declare + Align : constant Uint := Alignment (E); + + begin + if Is_Dynamic_SO_Ref (End_Npos) then + RM_Siz := End_Npos; + + -- Set the Object_Size allowing for the alignment. In the + -- dynamic case, we must do the actual runtime computation. + -- We can skip this in the non-packed record case if the + -- last component has a smaller alignment than the overall + -- record alignment. + + if Is_Dynamic_SO_Ref (End_NPMax) then + Esiz := End_NPMax; + + if Is_Packed (E) + or else Alignment (Etype (Prev_Comp)) < Align + then + -- The expression we build is: + -- (expr + align - 1) / align * align + + Esiz := + SO_Ref_From_Expr + (Expr => + Make_Op_Multiply (Loc, + Left_Opnd => + Make_Op_Divide (Loc, + Left_Opnd => + Make_Op_Add (Loc, + Left_Opnd => + Expr_From_SO_Ref (Loc, Esiz), + Right_Opnd => + Make_Integer_Literal (Loc, + Intval => Align - 1)), + Right_Opnd => + Make_Integer_Literal (Loc, Align)), + Right_Opnd => + Make_Integer_Literal (Loc, Align)), + Ins_Type => E, + Vtype => E); + end if; + + -- Here Esiz is static, so we can adjust the alignment + -- directly go give the required aligned value. + + else + Esiz := (End_NPMax + Align - 1) / Align * Align * SSU; + end if; + + -- Case where computed size is static + + else + -- The ending size was computed in Npos in storage units, + -- but the actual size is stored in bits, so adjust + -- accordingly. We also adjust the size to match the + -- alignment here. + + Esiz := (End_NPMax + Align - 1) / Align * Align * SSU; + + -- Compute the resulting Value_Size (RM_Size). For this + -- purpose we do not force alignment of the record or + -- storage size alignment of the result. + + Get_Next_Component_Location + (Prev_Comp, + Uint_0, + End_Npos, + End_Fbit, + End_NPMax, + Force_SU => False); + + RM_Siz := End_Npos * SSU + End_Fbit; + Set_And_Check_Static_Size (E, Esiz, RM_Siz); + end if; + end; + end if; + end Layout_Components; + + ------------------------------- + -- Layout_Non_Variant_Record -- + ------------------------------- + + procedure Layout_Non_Variant_Record is + Esiz : SO_Ref; + RM_Siz : SO_Ref; + begin + Layout_Components (First_Entity (E), Last_Entity (E), Esiz, RM_Siz); + Set_Esize (E, Esiz); + Set_RM_Size (E, RM_Siz); + end Layout_Non_Variant_Record; + + --------------------------- + -- Layout_Variant_Record -- + --------------------------- + + procedure Layout_Variant_Record is + Tdef : constant Node_Id := Type_Definition (Decl); + First_Discr : Entity_Id; + Last_Discr : Entity_Id; + Esiz : SO_Ref; + + RM_Siz : SO_Ref; + pragma Warnings (Off, SO_Ref); + + RM_Siz_Expr : Node_Id := Empty; + -- Expression for the evolving RM_Siz value. This is typically a + -- conditional expression which involves tests of discriminant values + -- that are formed as references to the entity V. At the end of + -- scanning all the components, a suitable function is constructed + -- in which V is the parameter. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Layout_Component_List + (Clist : Node_Id; + Esiz : out SO_Ref; + RM_Siz_Expr : out Node_Id); + -- Recursive procedure, called to lay out one component list Esiz + -- and RM_Siz_Expr are set to the Object_Size and Value_Size values + -- respectively representing the record size up to and including the + -- last component in the component list (including any variants in + -- this component list). RM_Siz_Expr is returned as an expression + -- which may in the general case involve some references to the + -- discriminants of the current record value, referenced by selecting + -- from the entity V. + + --------------------------- + -- Layout_Component_List -- + --------------------------- + + procedure Layout_Component_List + (Clist : Node_Id; + Esiz : out SO_Ref; + RM_Siz_Expr : out Node_Id) + is + Citems : constant List_Id := Component_Items (Clist); + Vpart : constant Node_Id := Variant_Part (Clist); + Prv : Node_Id; + Var : Node_Id; + RM_Siz : Uint; + RMS_Ent : Entity_Id; + + begin + if Is_Non_Empty_List (Citems) then + Layout_Components + (From => Defining_Identifier (First (Citems)), + To => Defining_Identifier (Last (Citems)), + Esiz => Esiz, + RM_Siz => RM_Siz); + else + Layout_Components (Empty, Empty, Esiz, RM_Siz); + end if; + + -- Case where no variants are present in the component list + + if No (Vpart) then + + -- The Esiz value has been correctly set by the call to + -- Layout_Components, so there is nothing more to be done. + + -- For RM_Siz, we have an SO_Ref value, which we must convert + -- to an appropriate expression. + + if Is_Static_SO_Ref (RM_Siz) then + RM_Siz_Expr := + Make_Integer_Literal (Loc, + Intval => RM_Siz); + + else + RMS_Ent := Get_Dynamic_SO_Entity (RM_Siz); + + -- If the size is represented by a function, then we create + -- an appropriate function call using V as the parameter to + -- the call. + + if Is_Discrim_SO_Function (RMS_Ent) then + RM_Siz_Expr := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RMS_Ent, Loc), + Parameter_Associations => New_List ( + Make_Identifier (Loc, Vname))); + + -- If the size is represented by a constant, then the + -- expression we want is a reference to this constant + + else + RM_Siz_Expr := New_Occurrence_Of (RMS_Ent, Loc); + end if; + end if; + + -- Case where variants are present in this component list + + else + declare + EsizV : SO_Ref; + RM_SizV : Node_Id; + Dchoice : Node_Id; + Discrim : Node_Id; + Dtest : Node_Id; + D_List : List_Id; + D_Entity : Entity_Id; + + begin + RM_Siz_Expr := Empty; + Prv := Prev_Comp; + + Var := Last (Variants (Vpart)); + while Present (Var) loop + Prev_Comp := Prv; + Layout_Component_List + (Component_List (Var), EsizV, RM_SizV); + + -- Set the Object_Size. If this is the first variant, + -- we just set the size of this first variant. + + if Var = Last (Variants (Vpart)) then + Esiz := EsizV; + + -- Otherwise the Object_Size is formed as a maximum + -- of Esiz so far from previous variants, and the new + -- Esiz value from the variant we just processed. + + -- If both values are static, we can just compute the + -- maximum directly to save building junk nodes. + + elsif not Is_Dynamic_SO_Ref (Esiz) + and then not Is_Dynamic_SO_Ref (EsizV) + then + Esiz := UI_Max (Esiz, EsizV); + + -- If either value is dynamic, then we have to generate + -- an appropriate Standard_Unsigned'Max attribute call. + -- If one of the values is static then it needs to be + -- converted from bits to storage units to be compatible + -- with the dynamic value. + + else + if Is_Static_SO_Ref (Esiz) then + Esiz := (Esiz + SSU - 1) / SSU; + end if; + + if Is_Static_SO_Ref (EsizV) then + EsizV := (EsizV + SSU - 1) / SSU; + end if; + + Esiz := + SO_Ref_From_Expr + (Make_Attribute_Reference (Loc, + Attribute_Name => Name_Max, + Prefix => + New_Occurrence_Of (Standard_Unsigned, Loc), + Expressions => New_List ( + Expr_From_SO_Ref (Loc, Esiz), + Expr_From_SO_Ref (Loc, EsizV))), + Ins_Type => E, + Vtype => E); + end if; + + -- Now deal with Value_Size (RM_Siz). We are aiming at + -- an expression that looks like: + + -- if xxDx (V.disc) then rmsiz1 + -- else if xxDx (V.disc) then rmsiz2 + -- else ... + + -- Where rmsiz1, rmsiz2... are the RM_Siz values for the + -- individual variants, and xxDx are the discriminant + -- checking functions generated for the variant type. + + -- If this is the first variant, we simply set the result + -- as the expression. Note that this takes care of the + -- others case. + + if No (RM_Siz_Expr) then + RM_Siz_Expr := Bits_To_SU (RM_SizV); + + -- Otherwise construct the appropriate test + + else + -- The test to be used in general is a call to the + -- discriminant checking function. However, it is + -- definitely worth special casing the very common + -- case where a single value is involved. + + Dchoice := First (Discrete_Choices (Var)); + + if No (Next (Dchoice)) + and then Nkind (Dchoice) /= N_Range + then + -- Discriminant to be tested + + Discrim := + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Vname), + Selector_Name => + New_Occurrence_Of + (Entity (Name (Vpart)), Loc)); + + Dtest := + Make_Op_Eq (Loc, + Left_Opnd => Discrim, + Right_Opnd => New_Copy (Dchoice)); + + -- Generate a call to the discriminant-checking + -- function for the variant. Note that the result + -- has to be complemented since the function returns + -- False when the passed discriminant value matches. + + else + -- The checking function takes all of the type's + -- discriminants as parameters, so a list of all + -- the selected discriminants must be constructed. + + D_List := New_List; + D_Entity := First_Discriminant (E); + while Present (D_Entity) loop + Append ( + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Vname), + Selector_Name => + New_Occurrence_Of (D_Entity, Loc)), + D_List); + + D_Entity := Next_Discriminant (D_Entity); + end loop; + + Dtest := + Make_Op_Not (Loc, + Right_Opnd => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (Dcheck_Function (Var), Loc), + Parameter_Associations => + D_List)); + end if; + + RM_Siz_Expr := + Make_Conditional_Expression (Loc, + Expressions => + New_List + (Dtest, Bits_To_SU (RM_SizV), RM_Siz_Expr)); + end if; + + Prev (Var); + end loop; + end; + end if; + end Layout_Component_List; + + -- Start of processing for Layout_Variant_Record + + begin + -- We need the discriminant checking functions, since we generate + -- calls to these functions for the RM_Size expression, so make + -- sure that these functions have been constructed in time. + + Build_Discr_Checking_Funcs (Decl); + + -- Lay out the discriminants + + First_Discr := First_Discriminant (E); + Last_Discr := First_Discr; + while Present (Next_Discriminant (Last_Discr)) loop + Next_Discriminant (Last_Discr); + end loop; + + Layout_Components + (From => First_Discr, + To => Last_Discr, + Esiz => Esiz, + RM_Siz => RM_Siz); + + -- Lay out the main component list (this will make recursive calls + -- to lay out all component lists nested within variants). + + Layout_Component_List (Component_List (Tdef), Esiz, RM_Siz_Expr); + Set_Esize (E, Esiz); + + -- If the RM_Size is a literal, set its value + + if Nkind (RM_Siz_Expr) = N_Integer_Literal then + Set_RM_Size (E, Intval (RM_Siz_Expr)); + + -- Otherwise we construct a dynamic SO_Ref + + else + Set_RM_Size (E, + SO_Ref_From_Expr + (RM_Siz_Expr, + Ins_Type => E, + Vtype => E)); + end if; + end Layout_Variant_Record; + + -- Start of processing for Layout_Record_Type + + begin + -- If this is a cloned subtype, just copy the size fields from the + -- original, nothing else needs to be done in this case, since the + -- components themselves are all shared. + + if (Ekind (E) = E_Record_Subtype + or else + Ekind (E) = E_Class_Wide_Subtype) + and then Present (Cloned_Subtype (E)) + then + Set_Esize (E, Esize (Cloned_Subtype (E))); + Set_RM_Size (E, RM_Size (Cloned_Subtype (E))); + Set_Alignment (E, Alignment (Cloned_Subtype (E))); + + -- Another special case, class-wide types. The RM says that the size + -- of such types is implementation defined (RM 13.3(48)). What we do + -- here is to leave the fields set as unknown values, and the backend + -- determines the actual behavior. + + elsif Ekind (E) = E_Class_Wide_Type then + null; + + -- All other cases + + else + -- Initialize alignment conservatively to 1. This value will be + -- increased as necessary during processing of the record. + + if Unknown_Alignment (E) then + Set_Alignment (E, Uint_1); + end if; + + -- Initialize previous component. This is Empty unless there are + -- components which have already been laid out by component clauses. + -- If there are such components, we start our lay out of the + -- remaining components following the last such component. + + Prev_Comp := Empty; + + Comp := First_Component_Or_Discriminant (E); + while Present (Comp) loop + if Present (Component_Clause (Comp)) then + if No (Prev_Comp) + or else + Component_Bit_Offset (Comp) > + Component_Bit_Offset (Prev_Comp) + then + Prev_Comp := Comp; + end if; + end if; + + Next_Component_Or_Discriminant (Comp); + end loop; + + -- We have two separate circuits, one for non-variant records and + -- one for variant records. For non-variant records, we simply go + -- through the list of components. This handles all the non-variant + -- cases including those cases of subtypes where there is no full + -- type declaration, so the tree cannot be used to drive the layout. + -- For variant records, we have to drive the layout from the tree + -- since we need to understand the variant structure in this case. + + if Present (Full_View (E)) then + Decl := Declaration_Node (Full_View (E)); + else + Decl := Declaration_Node (E); + end if; + + -- Scan all the components + + if Nkind (Decl) = N_Full_Type_Declaration + and then Has_Discriminants (E) + and then Nkind (Type_Definition (Decl)) = N_Record_Definition + and then Present (Component_List (Type_Definition (Decl))) + and then + Present (Variant_Part (Component_List (Type_Definition (Decl)))) + then + Layout_Variant_Record; + else + Layout_Non_Variant_Record; + end if; + end if; + end Layout_Record_Type; + + ----------------- + -- Layout_Type -- + ----------------- + + procedure Layout_Type (E : Entity_Id) is + Desig_Type : Entity_Id; + + begin + -- For string literal types, for now, kill the size always, this is + -- because gigi does not like or need the size to be set ??? + + if Ekind (E) = E_String_Literal_Subtype then + Set_Esize (E, Uint_0); + Set_RM_Size (E, Uint_0); + return; + end if; + + -- For access types, set size/alignment. This is system address size, + -- except for fat pointers (unconstrained array access types), where the + -- size is two times the address size, to accommodate the two pointers + -- that are required for a fat pointer (data and template). Note that + -- E_Access_Protected_Subprogram_Type is not an access type for this + -- purpose since it is not a pointer but is equivalent to a record. For + -- access subtypes, copy the size from the base type since Gigi + -- represents them the same way. + + if Is_Access_Type (E) then + + Desig_Type := Underlying_Type (Designated_Type (E)); + + -- If we only have a limited view of the type, see whether the + -- non-limited view is available. + + if From_With_Type (Designated_Type (E)) + and then Ekind (Designated_Type (E)) = E_Incomplete_Type + and then Present (Non_Limited_View (Designated_Type (E))) + then + Desig_Type := Non_Limited_View (Designated_Type (E)); + end if; + + -- If Esize already set (e.g. by a size clause), then nothing further + -- to be done here. + + if Known_Esize (E) then + null; + + -- Access to subprogram is a strange beast, and we let the backend + -- figure out what is needed (it may be some kind of fat pointer, + -- including the static link for example. + + elsif Is_Access_Protected_Subprogram_Type (E) then + null; + + -- For access subtypes, copy the size information from base type + + elsif Ekind (E) = E_Access_Subtype then + Set_Size_Info (E, Base_Type (E)); + Set_RM_Size (E, RM_Size (Base_Type (E))); + + -- For other access types, we use either address size, or, if a fat + -- pointer is used (pointer-to-unconstrained array case), twice the + -- address size to accommodate a fat pointer. + + elsif Present (Desig_Type) + and then Is_Array_Type (Desig_Type) + and then not Is_Constrained (Desig_Type) + and then not Has_Completion_In_Body (Desig_Type) + and then not Debug_Flag_6 + then + Init_Size (E, 2 * System_Address_Size); + + -- Check for bad convention set + + if Warn_On_Export_Import + and then + (Convention (E) = Convention_C + or else + Convention (E) = Convention_CPP) + then + Error_Msg_N + ("?this access type does not correspond to C pointer", E); + end if; + + -- If the designated type is a limited view it is unanalyzed. We can + -- examine the declaration itself to determine whether it will need a + -- fat pointer. + + elsif Present (Desig_Type) + and then Present (Parent (Desig_Type)) + and then Nkind (Parent (Desig_Type)) = N_Full_Type_Declaration + and then + Nkind (Type_Definition (Parent (Desig_Type))) + = N_Unconstrained_Array_Definition + then + Init_Size (E, 2 * System_Address_Size); + + -- When the target is AAMP, access-to-subprogram types are fat + -- pointers consisting of the subprogram address and a static link + -- (with the exception of library-level access types, where a simple + -- subprogram address is used). + + elsif AAMP_On_Target + and then + (Ekind (E) = E_Anonymous_Access_Subprogram_Type + or else (Ekind (E) = E_Access_Subprogram_Type + and then Present (Enclosing_Subprogram (E)))) + then + Init_Size (E, 2 * System_Address_Size); + + else + Init_Size (E, System_Address_Size); + end if; + + -- On VMS, reset size to 32 for convention C access type if no + -- explicit size clause is given and the default size is 64. Really + -- we do not know the size, since depending on options for the VMS + -- compiler, the size of a pointer type can be 32 or 64, but choosing + -- 32 as the default improves compatibility with legacy VMS code. + + -- Note: we do not use Has_Size_Clause in the test below, because we + -- want to catch the case of a derived type inheriting a size clause. + -- We want to consider this to be an explicit size clause for this + -- purpose, since it would be weird not to inherit the size in this + -- case. + + -- We do NOT do this if we are in -gnatdm mode on a non-VMS target + -- since in that case we want the normal pointer representation. + + if Opt.True_VMS_Target + and then (Convention (E) = Convention_C + or else + Convention (E) = Convention_CPP) + and then No (Get_Attribute_Definition_Clause (E, Attribute_Size)) + and then Esize (E) = 64 + then + Init_Size (E, 32); + end if; + + Set_Elem_Alignment (E); + + -- Scalar types: set size and alignment + + elsif Is_Scalar_Type (E) then + + -- For discrete types, the RM_Size and Esize must be set already, + -- since this is part of the earlier processing and the front end is + -- always required to lay out the sizes of such types (since they are + -- available as static attributes). All we do is to check that this + -- rule is indeed obeyed! + + if Is_Discrete_Type (E) then + + -- If the RM_Size is not set, then here is where we set it + + -- Note: an RM_Size of zero looks like not set here, but this + -- is a rare case, and we can simply reset it without any harm. + + if not Known_RM_Size (E) then + Set_Discrete_RM_Size (E); + end if; + + -- If Esize for a discrete type is not set then set it + + if not Known_Esize (E) then + declare + S : Int := 8; + + begin + loop + -- If size is big enough, set it and exit + + if S >= RM_Size (E) then + Init_Esize (E, S); + exit; + + -- If the RM_Size is greater than 64 (happens only when + -- strange values are specified by the user, then Esize + -- is simply a copy of RM_Size, it will be further + -- refined later on) + + elsif S = 64 then + Set_Esize (E, RM_Size (E)); + exit; + + -- Otherwise double possible size and keep trying + + else + S := S * 2; + end if; + end loop; + end; + end if; + + -- For non-discrete scalar types, if the RM_Size is not set, then set + -- it now to a copy of the Esize if the Esize is set. + + else + if Known_Esize (E) and then Unknown_RM_Size (E) then + Set_RM_Size (E, Esize (E)); + end if; + end if; + + Set_Elem_Alignment (E); + + -- Non-elementary (composite) types + + else + -- For packed arrays, take size and alignment values from the packed + -- array type if a packed array type has been created and the fields + -- are not currently set. + + if Is_Array_Type (E) and then Present (Packed_Array_Type (E)) then + declare + PAT : constant Entity_Id := Packed_Array_Type (E); + + begin + if Unknown_Esize (E) then + Set_Esize (E, Esize (PAT)); + end if; + + if Unknown_RM_Size (E) then + Set_RM_Size (E, RM_Size (PAT)); + end if; + + if Unknown_Alignment (E) then + Set_Alignment (E, Alignment (PAT)); + end if; + end; + end if; + + -- If RM_Size is known, set Esize if not known + + if Known_RM_Size (E) and then Unknown_Esize (E) then + + -- If the alignment is known, we bump the Esize up to the next + -- alignment boundary if it is not already on one. + + if Known_Alignment (E) then + declare + A : constant Uint := Alignment_In_Bits (E); + S : constant SO_Ref := RM_Size (E); + begin + Set_Esize (E, (S + A - 1) / A * A); + end; + end if; + + -- If Esize is set, and RM_Size is not, RM_Size is copied from Esize. + -- At least for now this seems reasonable, and is in any case needed + -- for compatibility with old versions of gigi. + + elsif Known_Esize (E) and then Unknown_RM_Size (E) then + Set_RM_Size (E, Esize (E)); + end if; + + -- For array base types, set component size if object size of the + -- component type is known and is a small power of 2 (8, 16, 32, 64), + -- since this is what will always be used. + + if Ekind (E) = E_Array_Type + and then Unknown_Component_Size (E) + then + declare + CT : constant Entity_Id := Component_Type (E); + + begin + -- For some reasons, access types can cause trouble, So let's + -- just do this for scalar types ??? + + if Present (CT) + and then Is_Scalar_Type (CT) + and then Known_Static_Esize (CT) + then + declare + S : constant Uint := Esize (CT); + begin + if Addressable (S) then + Set_Component_Size (E, S); + end if; + end; + end if; + end; + end if; + end if; + + -- Lay out array and record types if front end layout set + + if Frontend_Layout_On_Target then + if Is_Array_Type (E) and then not Is_Bit_Packed_Array (E) then + Layout_Array_Type (E); + elsif Is_Record_Type (E) then + Layout_Record_Type (E); + end if; + + -- Case of backend layout, we still do a little in the front end + + else + -- Processing for record types + + if Is_Record_Type (E) then + + -- Special remaining processing for record types with a known + -- size of 16, 32, or 64 bits whose alignment is not yet set. + -- For these types, we set a corresponding alignment matching + -- the size if possible, or as large as possible if not. + + if Convention (E) = Convention_Ada + and then not Debug_Flag_Q + then + Set_Composite_Alignment (E); + end if; + + -- Processing for array types + + elsif Is_Array_Type (E) then + + -- For arrays that are required to be atomic, we do the same + -- processing as described above for short records, since we + -- really need to have the alignment set for the whole array. + + if Is_Atomic (E) and then not Debug_Flag_Q then + Set_Composite_Alignment (E); + end if; + + -- For unpacked array types, set an alignment of 1 if we know + -- that the component alignment is not greater than 1. The reason + -- we do this is to avoid unnecessary copying of slices of such + -- arrays when passed to subprogram parameters (see special test + -- in Exp_Ch6.Expand_Actuals). + + if not Is_Packed (E) + and then Unknown_Alignment (E) + then + if Known_Static_Component_Size (E) + and then Component_Size (E) = 1 + then + Set_Alignment (E, Uint_1); + end if; + end if; + end if; + end if; + + -- Final step is to check that Esize and RM_Size are compatible + + if Known_Static_Esize (E) and then Known_Static_RM_Size (E) then + if Esize (E) < RM_Size (E) then + + -- Esize is less than RM_Size. That's not good. First we test + -- whether this was set deliberately with an Object_Size clause + -- and if so, object to the clause. + + if Has_Object_Size_Clause (E) then + Error_Msg_Uint_1 := RM_Size (E); + Error_Msg_F + ("object size is too small, minimum allowed is ^", + Expression (Get_Attribute_Definition_Clause + (E, Attribute_Object_Size))); + end if; + + -- Adjust Esize up to RM_Size value + + declare + Size : constant Uint := RM_Size (E); + + begin + Set_Esize (E, RM_Size (E)); + + -- For scalar types, increase Object_Size to power of 2, but + -- not less than a storage unit in any case (i.e., normally + -- this means it will be storage-unit addressable). + + if Is_Scalar_Type (E) then + if Size <= System_Storage_Unit then + Init_Esize (E, System_Storage_Unit); + elsif Size <= 16 then + Init_Esize (E, 16); + elsif Size <= 32 then + Init_Esize (E, 32); + else + Set_Esize (E, (Size + 63) / 64 * 64); + end if; + + -- Finally, make sure that alignment is consistent with + -- the newly assigned size. + + while Alignment (E) * System_Storage_Unit < Esize (E) + and then Alignment (E) < Maximum_Alignment + loop + Set_Alignment (E, 2 * Alignment (E)); + end loop; + end if; + end; + end if; + end if; + end Layout_Type; + + --------------------- + -- Rewrite_Integer -- + --------------------- + + procedure Rewrite_Integer (N : Node_Id; V : Uint) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + begin + Rewrite (N, Make_Integer_Literal (Loc, Intval => V)); + Set_Etype (N, Typ); + end Rewrite_Integer; + + ------------------------------- + -- Set_And_Check_Static_Size -- + ------------------------------- + + procedure Set_And_Check_Static_Size + (E : Entity_Id; + Esiz : SO_Ref; + RM_Siz : SO_Ref) + is + SC : Node_Id; + + procedure Check_Size_Too_Small (Spec : Uint; Min : Uint); + -- Spec is the number of bit specified in the size clause, and Min is + -- the minimum computed size. An error is given that the specified size + -- is too small if Spec < Min, and in this case both Esize and RM_Size + -- are set to unknown in E. The error message is posted on node SC. + + procedure Check_Unused_Bits (Spec : Uint; Max : Uint); + -- Spec is the number of bits specified in the size clause, and Max is + -- the maximum computed size. A warning is given about unused bits if + -- Spec > Max. This warning is posted on node SC. + + -------------------------- + -- Check_Size_Too_Small -- + -------------------------- + + procedure Check_Size_Too_Small (Spec : Uint; Min : Uint) is + begin + if Spec < Min then + Error_Msg_Uint_1 := Min; + Error_Msg_NE ("size for & too small, minimum allowed is ^", SC, E); + Init_Esize (E); + Init_RM_Size (E); + end if; + end Check_Size_Too_Small; + + ----------------------- + -- Check_Unused_Bits -- + ----------------------- + + procedure Check_Unused_Bits (Spec : Uint; Max : Uint) is + begin + if Spec > Max then + Error_Msg_Uint_1 := Spec - Max; + Error_Msg_NE ("?^ bits of & unused", SC, E); + end if; + end Check_Unused_Bits; + + -- Start of processing for Set_And_Check_Static_Size + + begin + -- Case where Object_Size (Esize) is already set by a size clause + + if Known_Static_Esize (E) then + SC := Size_Clause (E); + + if No (SC) then + SC := Get_Attribute_Definition_Clause (E, Attribute_Object_Size); + end if; + + -- Perform checks on specified size against computed sizes + + if Present (SC) then + Check_Unused_Bits (Esize (E), Esiz); + Check_Size_Too_Small (Esize (E), RM_Siz); + end if; + end if; + + -- Case where Value_Size (RM_Size) is set by specific Value_Size clause + -- (we do not need to worry about Value_Size being set by a Size clause, + -- since that will have set Esize as well, and we already took care of + -- that case). + + if Known_Static_RM_Size (E) then + SC := Get_Attribute_Definition_Clause (E, Attribute_Value_Size); + + -- Perform checks on specified size against computed sizes + + if Present (SC) then + Check_Unused_Bits (RM_Size (E), Esiz); + Check_Size_Too_Small (RM_Size (E), RM_Siz); + end if; + end if; + + -- Set sizes if unknown + + if Unknown_Esize (E) then + Set_Esize (E, Esiz); + end if; + + if Unknown_RM_Size (E) then + Set_RM_Size (E, RM_Siz); + end if; + end Set_And_Check_Static_Size; + + ----------------------------- + -- Set_Composite_Alignment -- + ----------------------------- + + procedure Set_Composite_Alignment (E : Entity_Id) is + Siz : Uint; + Align : Nat; + + begin + -- If alignment is already set, then nothing to do + + if Known_Alignment (E) then + return; + end if; + + -- Alignment is not known, see if we can set it, taking into account + -- the setting of the Optimize_Alignment mode. + + -- If Optimize_Alignment is set to Space, then packed records always + -- have an alignment of 1. But don't do anything for atomic records + -- since we may need higher alignment for indivisible access. + + if Optimize_Alignment_Space (E) + and then Is_Record_Type (E) + and then Is_Packed (E) + and then not Is_Atomic (E) + then + Align := 1; + + -- Not a record, or not packed + + else + -- The only other cases we worry about here are where the size is + -- statically known at compile time. + + if Known_Static_Esize (E) then + Siz := Esize (E); + + elsif Unknown_Esize (E) + and then Known_Static_RM_Size (E) + then + Siz := RM_Size (E); + + else + return; + end if; + + -- Size is known, alignment is not set + + -- Reset alignment to match size if the known size is exactly 2, 4, + -- or 8 storage units. + + if Siz = 2 * System_Storage_Unit then + Align := 2; + elsif Siz = 4 * System_Storage_Unit then + Align := 4; + elsif Siz = 8 * System_Storage_Unit then + Align := 8; + + -- If Optimize_Alignment is set to Space, then make sure the + -- alignment matches the size, for example, if the size is 17 + -- bytes then we want an alignment of 1 for the type. + + elsif Optimize_Alignment_Space (E) then + if Siz mod (8 * System_Storage_Unit) = 0 then + Align := 8; + elsif Siz mod (4 * System_Storage_Unit) = 0 then + Align := 4; + elsif Siz mod (2 * System_Storage_Unit) = 0 then + Align := 2; + else + Align := 1; + end if; + + -- If Optimize_Alignment is set to Time, then we reset for odd + -- "in between sizes", for example a 17 bit record is given an + -- alignment of 4. Note that this matches the old VMS behavior + -- in versions of GNAT prior to 6.1.1. + + elsif Optimize_Alignment_Time (E) + and then Siz > System_Storage_Unit + and then Siz <= 8 * System_Storage_Unit + then + if Siz <= 2 * System_Storage_Unit then + Align := 2; + elsif Siz <= 4 * System_Storage_Unit then + Align := 4; + else -- Siz <= 8 * System_Storage_Unit then + Align := 8; + end if; + + -- No special alignment fiddling needed + + else + return; + end if; + end if; + + -- Here we have Set Align to the proposed improved value. Make sure the + -- value set does not exceed Maximum_Alignment for the target. + + if Align > Maximum_Alignment then + Align := Maximum_Alignment; + end if; + + -- Further processing for record types only to reduce the alignment + -- set by the above processing in some specific cases. We do not + -- do this for atomic records, since we need max alignment there, + + if Is_Record_Type (E) and then not Is_Atomic (E) then + + -- For records, there is generally no point in setting alignment + -- higher than word size since we cannot do better than move by + -- words in any case. Omit this if we are optimizing for time, + -- since conceivably we may be able to do better. + + if Align > System_Word_Size / System_Storage_Unit + and then not Optimize_Alignment_Time (E) + then + Align := System_Word_Size / System_Storage_Unit; + end if; + + -- Check components. If any component requires a higher alignment, + -- then we set that higher alignment in any case. Don't do this if + -- we have Optimize_Alignment set to Space. Note that that covers + -- the case of packed records, where we already set alignment to 1. + + if not Optimize_Alignment_Space (E) then + declare + Comp : Entity_Id; + + begin + Comp := First_Component (E); + while Present (Comp) loop + if Known_Alignment (Etype (Comp)) then + declare + Calign : constant Uint := Alignment (Etype (Comp)); + + begin + -- The cases to process are when the alignment of the + -- component type is larger than the alignment we have + -- so far, and either there is no component clause for + -- the component, or the length set by the component + -- clause matches the length of the component type. + + if Calign > Align + and then + (Unknown_Esize (Comp) + or else (Known_Static_Esize (Comp) + and then + Esize (Comp) = + Calign * System_Storage_Unit)) + then + Align := UI_To_Int (Calign); + end if; + end; + end if; + + Next_Component (Comp); + end loop; + end; + end if; + end if; + + -- Set chosen alignment, and increase Esize if necessary to match the + -- chosen alignment. + + Set_Alignment (E, UI_From_Int (Align)); + + if Known_Static_Esize (E) + and then Esize (E) < Align * System_Storage_Unit + then + Set_Esize (E, UI_From_Int (Align * System_Storage_Unit)); + end if; + end Set_Composite_Alignment; + + -------------------------- + -- Set_Discrete_RM_Size -- + -------------------------- + + procedure Set_Discrete_RM_Size (Def_Id : Entity_Id) is + FST : constant Entity_Id := First_Subtype (Def_Id); + + begin + -- All discrete types except for the base types in standard are + -- constrained, so indicate this by setting Is_Constrained. + + Set_Is_Constrained (Def_Id); + + -- Set generic types to have an unknown size, since the representation + -- of a generic type is irrelevant, in view of the fact that they have + -- nothing to do with code. + + if Is_Generic_Type (Root_Type (FST)) then + Set_RM_Size (Def_Id, Uint_0); + + -- If the subtype statically matches the first subtype, then it is + -- required to have exactly the same layout. This is required by + -- aliasing considerations. + + elsif Def_Id /= FST and then + Subtypes_Statically_Match (Def_Id, FST) + then + Set_RM_Size (Def_Id, RM_Size (FST)); + Set_Size_Info (Def_Id, FST); + + -- In all other cases the RM_Size is set to the minimum size. Note that + -- this routine is never called for subtypes for which the RM_Size is + -- set explicitly by an attribute clause. + + else + Set_RM_Size (Def_Id, UI_From_Int (Minimum_Size (Def_Id))); + end if; + end Set_Discrete_RM_Size; + + ------------------------ + -- Set_Elem_Alignment -- + ------------------------ + + procedure Set_Elem_Alignment (E : Entity_Id) is + begin + -- Do not set alignment for packed array types, unless we are doing + -- front end layout, because otherwise this is always handled in the + -- backend. + + if Is_Packed_Array_Type (E) and then not Frontend_Layout_On_Target then + return; + + -- If there is an alignment clause, then we respect it + + elsif Has_Alignment_Clause (E) then + return; + + -- If the size is not set, then don't attempt to set the alignment. This + -- happens in the backend layout case for access-to-subprogram types. + + elsif not Known_Static_Esize (E) then + return; + + -- For access types, do not set the alignment if the size is less than + -- the allowed minimum size. This avoids cascaded error messages. + + elsif Is_Access_Type (E) + and then Esize (E) < System_Address_Size + then + return; + end if; + + -- Here we calculate the alignment as the largest power of two multiple + -- of System.Storage_Unit that does not exceed either the actual size of + -- the type, or the maximum allowed alignment. + + declare + S : constant Int := UI_To_Int (Esize (E)) / SSU; + A : Nat; + Max_Alignment : Nat; + + begin + -- If the default alignment of "double" floating-point types is + -- specifically capped, enforce the cap. + + if Ttypes.Target_Double_Float_Alignment > 0 + and then S = 8 + and then Is_Floating_Point_Type (E) + then + Max_Alignment := Ttypes.Target_Double_Float_Alignment; + + -- If the default alignment of "double" or larger scalar types is + -- specifically capped, enforce the cap. + + elsif Ttypes.Target_Double_Scalar_Alignment > 0 + and then S >= 8 + and then Is_Scalar_Type (E) + then + Max_Alignment := Ttypes.Target_Double_Scalar_Alignment; + + -- Otherwise enforce the overall alignment cap + + else + Max_Alignment := Ttypes.Maximum_Alignment; + end if; + + A := 1; + while 2 * A <= Max_Alignment and then 2 * A <= S loop + A := 2 * A; + end loop; + + -- Now we think we should set the alignment to A, but we skip this if + -- an alignment is already set to a value greater than A (happens for + -- derived types). + + -- However, if the alignment is known and too small it must be + -- increased, this happens in a case like: + + -- type R is new Character; + -- for R'Size use 16; + + -- Here the alignment inherited from Character is 1, but it must be + -- increased to 2 to reflect the increased size. + + if Unknown_Alignment (E) or else Alignment (E) < A then + Init_Alignment (E, A); + end if; + end; + end Set_Elem_Alignment; + + ---------------------- + -- SO_Ref_From_Expr -- + ---------------------- + + function SO_Ref_From_Expr + (Expr : Node_Id; + Ins_Type : Entity_Id; + Vtype : Entity_Id := Empty; + Make_Func : Boolean := False) return Dynamic_SO_Ref + is + Loc : constant Source_Ptr := Sloc (Ins_Type); + K : constant Entity_Id := Make_Temporary (Loc, 'K'); + Decl : Node_Id; + + Vtype_Primary_View : Entity_Id; + + function Check_Node_V_Ref (N : Node_Id) return Traverse_Result; + -- Function used to check one node for reference to V + + function Has_V_Ref is new Traverse_Func (Check_Node_V_Ref); + -- Function used to traverse tree to check for reference to V + + ---------------------- + -- Check_Node_V_Ref -- + ---------------------- + + function Check_Node_V_Ref (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Identifier then + if Chars (N) = Vname then + return Abandon; + else + return Skip; + end if; + + else + return OK; + end if; + end Check_Node_V_Ref; + + -- Start of processing for SO_Ref_From_Expr + + begin + -- Case of expression is an integer literal, in this case we just + -- return the value (which must always be non-negative, since size + -- and offset values can never be negative). + + if Nkind (Expr) = N_Integer_Literal then + pragma Assert (Intval (Expr) >= 0); + return Intval (Expr); + end if; + + -- Case where there is a reference to V, create function + + if Has_V_Ref (Expr) = Abandon then + + pragma Assert (Present (Vtype)); + + -- Check whether Vtype is a view of a private type and ensure that + -- we use the primary view of the type (which is denoted by its + -- Etype, whether it's the type's partial or full view entity). + -- This is needed to make sure that we use the same (primary) view + -- of the type for all V formals, whether the current view of the + -- type is the partial or full view, so that types will always + -- match on calls from one size function to another. + + if Has_Private_Declaration (Vtype) then + Vtype_Primary_View := Etype (Vtype); + else + Vtype_Primary_View := Vtype; + end if; + + Set_Is_Discrim_SO_Function (K); + + Decl := + Make_Subprogram_Body (Loc, + + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => K, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars => Vname), + Parameter_Type => + New_Occurrence_Of (Vtype_Primary_View, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Unsigned, Loc)), + + Declarations => Empty_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => Expr)))); + + -- The caller requests that the expression be encapsulated in a + -- parameterless function. + + elsif Make_Func then + Decl := + Make_Subprogram_Body (Loc, + + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => K, + Parameter_Specifications => Empty_List, + Result_Definition => + New_Occurrence_Of (Standard_Unsigned, Loc)), + + Declarations => Empty_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, Expression => Expr)))); + + -- No reference to V and function not requested, so create a constant + + else + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => K, + Object_Definition => + New_Occurrence_Of (Standard_Unsigned, Loc), + Constant_Present => True, + Expression => Expr); + end if; + + Append_Freeze_Action (Ins_Type, Decl); + Analyze (Decl); + return Create_Dynamic_SO_Ref (K); + end SO_Ref_From_Expr; + +end Layout; diff --git a/gcc/ada/layout.ads b/gcc/ada/layout.ads new file mode 100644 index 000000000..c20458768 --- /dev/null +++ b/gcc/ada/layout.ads @@ -0,0 +1,83 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L A Y O U T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package does front-end layout of types and objects. The result is +-- to annotate the tree with information on size and alignment of types +-- and objects. How much layout is performed depends on the setting of the +-- target dependent parameter Backend_Layout. + +with Types; use Types; + +package Layout is + + -- The following procedures are called from Freeze, so all entities + -- for types and objects that get frozen (which should be all such + -- entities which are seen by the back end) will get layed out by one + -- of these two procedures. + + procedure Layout_Type (E : Entity_Id); + -- This procedure may set or adjust the fields Esize, RM_Size and + -- Alignment in the non-generic type or subtype entity E. If the + -- Backend_Layout switch is False, then it is guaranteed that all + -- three fields will be properly set on return. Regardless of the + -- Backend_Layout value, it is guaranteed that all discrete types + -- will have both Esize and RM_Size fields set on return (since + -- these are static values). Note that Layout_Type is not called + -- for generic types, since these play no part in code generation, + -- and hence representation aspects are irrelevant. + + procedure Layout_Object (E : Entity_Id); + -- E is either a variable (E_Variable), a constant (E_Constant), + -- a loop parameter (E_Loop_Parameter), or a formal parameter of + -- a non-generic subprogram (E_In_Parameter, E_In_Out_Parameter, + -- or E_Out_Parameter). This procedure may set or adjust the + -- Esize and Alignment fields of E. If Backend_Layout is False, + -- then it is guaranteed that both fields will be properly set + -- on return. If the Esize is still unknown in the latter case, + -- it means that the object must be allocated dynamically, since + -- its length is not known at compile time. + + -- The following are utility routines, called from various places + + procedure Adjust_Esize_Alignment (E : Entity_Id); + -- E is the entity for a type or object. This procedure checks that the + -- size and alignment are compatible, and if not either gives an error + -- message if they cannot be adjusted or else adjusts them appropriately. + + procedure Set_Discrete_RM_Size (Def_Id : Entity_Id); + -- Set proper RM_Size for discrete size, this is normally the minimum + -- number of bits to accommodate the range given, except in the case + -- where the subtype statically matches the first subtype, in which + -- case the size must be copied from the first subtype. For generic + -- types, the RM_Size is simply set to zero. This routine also sets + -- the Is_Constrained flag in Def_Id. + + procedure Set_Elem_Alignment (E : Entity_Id); + -- The front end always sets alignments for elementary types by calling + -- this procedure. Note that we have to do this for discrete types (since + -- the Alignment attribute is static), so we might as well do it for all + -- elementary types, since the processing is the same. + +end Layout; diff --git a/gcc/ada/lib-list.adb b/gcc/ada/lib-list.adb new file mode 100644 index 000000000..831dc90a2 --- /dev/null +++ b/gcc/ada/lib-list.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B . L I S 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. -- +-- -- +------------------------------------------------------------------------------ + +separate (Lib) +procedure List (File_Names_Only : Boolean := False) is + + Num_Units : constant Nat := Int (Units.Last) - Int (Units.First) + 1; + -- Number of units in file table + + Sorted_Units : Unit_Ref_Table (1 .. Num_Units); + -- Table of unit numbers that we will sort + + Unit_Hed : constant String := "Unit name "; + Unit_Und : constant String := "--------- "; + Unit_Bln : constant String := " "; + File_Hed : constant String := "File name "; + File_Und : constant String := "--------- "; + File_Bln : constant String := " "; + Time_Hed : constant String := "Time stamp"; + Time_Und : constant String := "----------"; + + Unit_Length : constant Natural := Unit_Hed'Length; + File_Length : constant Natural := File_Hed'Length; + +begin + -- First step is to make a sorted table of units + + for J in 1 .. Num_Units loop + Sorted_Units (J) := Unit_Number_Type (Int (Units.First) + J - 1); + end loop; + + Sort (Sorted_Units); + + -- Now we can generate the unit table listing + + Write_Eol; + + if not File_Names_Only then + Write_Str (Unit_Hed); + Write_Str (File_Hed); + Write_Str (Time_Hed); + Write_Eol; + + Write_Str (Unit_Und); + Write_Str (File_Und); + Write_Str (Time_Und); + Write_Eol; + Write_Eol; + end if; + + for R in Sorted_Units'Range loop + if File_Names_Only then + if not Is_Internal_File_Name + (File_Name (Source_Index (Sorted_Units (R)))) + then + Write_Name (Full_File_Name (Source_Index (Sorted_Units (R)))); + Write_Eol; + end if; + + else + Write_Unit_Name (Unit_Name (Sorted_Units (R))); + + if Name_Len > (Unit_Length - 1) then + Write_Eol; + Write_Str (Unit_Bln); + else + for J in Name_Len + 1 .. Unit_Length loop + Write_Char (' '); + end loop; + end if; + + Write_Name (Full_File_Name (Source_Index (Sorted_Units (R)))); + + if Name_Len > (File_Length - 1) then + Write_Eol; + Write_Str (Unit_Bln); + Write_Str (File_Bln); + else + for J in Name_Len + 1 .. File_Length loop + Write_Char (' '); + end loop; + end if; + + Write_Str (String (Time_Stamp (Source_Index (Sorted_Units (R))))); + Write_Eol; + end if; + end loop; + + Write_Eol; +end List; diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb new file mode 100644 index 000000000..894c76017 --- /dev/null +++ b/gcc/ada/lib-load.adb @@ -0,0 +1,911 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B . L O A D -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Debug; use Debug; +with Einfo; use Einfo; +with Errout; use Errout; +with Fname; use Fname; +with Fname.UF; use Fname.UF; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Osint; use Osint; +with Osint.C; use Osint.C; +with Output; use Output; +with Par; +with Restrict; use Restrict; +with Scn; use Scn; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Sinput.L; use Sinput.L; +with Stand; use Stand; +with Tbuild; use Tbuild; +with Uname; use Uname; + +package body Lib.Load is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function From_Limited_With_Chain return Boolean; + -- Check whether a possible circular dependence includes units that + -- have been loaded through limited_with clauses, in which case there + -- is no real circularity. + + function Spec_Is_Irrelevant + (Spec_Unit : Unit_Number_Type; + Body_Unit : Unit_Number_Type) return Boolean; + -- The Spec_Unit and Body_Unit parameters are the unit numbers of the + -- spec file that corresponds to the main unit which is a body. This + -- function determines if the spec file is irrelevant and will be + -- overridden by the body as described in RM 10.1.4(4). See description + -- in "Special Handling of Subprogram Bodies" for further details. + + procedure Write_Dependency_Chain; + -- This procedure is used to generate error message info lines that + -- trace the current dependency chain when a load error occurs. + + ------------------------------ + -- Change_Main_Unit_To_Spec -- + ------------------------------ + + procedure Change_Main_Unit_To_Spec is + U : Unit_Record renames Units.Table (Main_Unit); + N : File_Name_Type; + X : Source_File_Index; + + begin + -- Get name of unit body + + Get_Name_String (U.Unit_File_Name); + + -- Note: for the following we should really generalize and consult the + -- file name pattern data, but for now we just deal with the common + -- naming cases, which is probably good enough in practice ??? + + -- Change .adb to .ads + + if Name_Len >= 5 + and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb" + then + Name_Buffer (Name_Len) := 's'; + + -- Change .2.ada to .1.ada (Rational convention) + + elsif Name_Len >= 7 + and then Name_Buffer (Name_Len - 5 .. Name_Len) = ".2.ada" + then + Name_Buffer (Name_Len - 4) := '1'; + + -- Change .ada to _.ada (DEC convention) + + elsif Name_Len >= 5 + and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".ada" + then + Name_Buffer (Name_Len - 3 .. Name_Len + 1) := "_.ada"; + Name_Len := Name_Len + 1; + + -- No match, don't make the change + + else + return; + end if; + + -- Try loading the spec + + N := Name_Find; + X := Load_Source_File (N); + + -- No change if we did not find the spec + + if X = No_Source_File then + return; + end if; + + -- Otherwise modify Main_Unit entry to point to spec + + U.Unit_File_Name := N; + U.Source_Index := X; + end Change_Main_Unit_To_Spec; + + ------------------------------- + -- Create_Dummy_Package_Unit -- + ------------------------------- + + function Create_Dummy_Package_Unit + (With_Node : Node_Id; + Spec_Name : Unit_Name_Type) return Unit_Number_Type + is + Unum : Unit_Number_Type; + Cunit_Entity : Entity_Id; + Cunit : Node_Id; + Du_Name : Node_Or_Entity_Id; + End_Lab : Node_Id; + Save_CS : constant Boolean := Get_Comes_From_Source_Default; + + begin + -- The created dummy package unit does not come from source + + Set_Comes_From_Source_Default (False); + + -- Normal package + + if Nkind (Name (With_Node)) = N_Identifier then + Cunit_Entity := + Make_Defining_Identifier (No_Location, + Chars => Chars (Name (With_Node))); + Du_Name := Cunit_Entity; + End_Lab := New_Occurrence_Of (Cunit_Entity, No_Location); + + -- Child package + + else + Cunit_Entity := + Make_Defining_Identifier (No_Location, + Chars => Chars (Selector_Name (Name (With_Node)))); + Du_Name := + Make_Defining_Program_Unit_Name (No_Location, + Name => Copy_Separate_Tree (Prefix (Name (With_Node))), + Defining_Identifier => Cunit_Entity); + + Set_Is_Child_Unit (Cunit_Entity); + + End_Lab := + Make_Designator (No_Location, + Name => Copy_Separate_Tree (Prefix (Name (With_Node))), + Identifier => New_Occurrence_Of (Cunit_Entity, No_Location)); + end if; + + Set_Scope (Cunit_Entity, Standard_Standard); + + Cunit := + Make_Compilation_Unit (No_Location, + Context_Items => Empty_List, + Unit => + Make_Package_Declaration (No_Location, + Specification => + Make_Package_Specification (No_Location, + Defining_Unit_Name => Du_Name, + Visible_Declarations => Empty_List, + End_Label => End_Lab)), + Aux_Decls_Node => + Make_Compilation_Unit_Aux (No_Location)); + + -- Mark the dummy package as analyzed to prevent analysis of this + -- (non-existent) unit in -gnatQ mode because at the moment the + -- structure and attributes of this dummy package does not allow + -- a normal analysis of this unit + + Set_Analyzed (Cunit); + + Units.Increment_Last; + Unum := Units.Last; + + Units.Table (Unum) := ( + Cunit => Cunit, + Cunit_Entity => Cunit_Entity, + Dependency_Num => 0, + Dynamic_Elab => False, + Error_Location => Sloc (With_Node), + Expected_Unit => Spec_Name, + Fatal_Error => True, + Generate_Code => False, + Has_Allocator => False, + Has_RACW => False, + Is_Compiler_Unit => False, + Ident_String => Empty, + Loading => False, + Main_Priority => Default_Main_Priority, + Main_CPU => Default_Main_CPU, + Munit_Index => 0, + Serial_Number => 0, + Source_Index => No_Source_File, + Unit_File_Name => Get_File_Name (Spec_Name, Subunit => False), + Unit_Name => Spec_Name, + Version => 0, + OA_Setting => 'O'); + + Set_Comes_From_Source_Default (Save_CS); + Set_Error_Posted (Cunit_Entity); + Set_Error_Posted (Cunit); + return Unum; + end Create_Dummy_Package_Unit; + + ----------------------------- + -- From_Limited_With_Chain -- + ----------------------------- + + function From_Limited_With_Chain return Boolean is + Curr_Num : constant Unit_Number_Type := + Load_Stack.Table (Load_Stack.Last).Unit_Number; + + begin + -- True if the current load operation is through a limited_with clause + -- and we are not within a loop of regular with_clauses. + + for U in reverse Load_Stack.First .. Load_Stack.Last - 1 loop + if Load_Stack.Table (U).Unit_Number = Curr_Num then + return False; + + elsif Present (Load_Stack.Table (U).With_Node) + and then Limited_Present (Load_Stack.Table (U).With_Node) + then + return True; + end if; + end loop; + + return False; + end From_Limited_With_Chain; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Units.Init; + Load_Stack.Init; + end Initialize; + + ------------------------ + -- Initialize_Version -- + ------------------------ + + procedure Initialize_Version (U : Unit_Number_Type) is + begin + Units.Table (U).Version := Source_Checksum (Source_Index (U)); + end Initialize_Version; + + ---------------------- + -- Load_Main_Source -- + ---------------------- + + procedure Load_Main_Source is + Fname : File_Name_Type; + Version : Word := 0; + + begin + Load_Stack.Increment_Last; + Load_Stack.Table (Load_Stack.Last) := (Main_Unit, Empty); + + -- Initialize unit table entry for Main_Unit. Note that we don't know + -- the unit name yet, that gets filled in when the parser parses the + -- main unit, at which time a check is made that it matches the main + -- file name, and then the Unit_Name field is set. The Cunit and + -- Cunit_Entity fields also get filled in later by the parser. + + Units.Increment_Last; + Fname := Next_Main_Source; + + Units.Table (Main_Unit).Unit_File_Name := Fname; + + if Fname /= No_File then + Main_Source_File := Load_Source_File (Fname); + Current_Error_Source_File := Main_Source_File; + + if Main_Source_File /= No_Source_File then + Version := Source_Checksum (Main_Source_File); + end if; + + Units.Table (Main_Unit) := ( + Cunit => Empty, + Cunit_Entity => Empty, + Dependency_Num => 0, + Dynamic_Elab => False, + Error_Location => No_Location, + Expected_Unit => No_Unit_Name, + Fatal_Error => False, + Generate_Code => False, + Has_Allocator => False, + Has_RACW => False, + Is_Compiler_Unit => False, + Ident_String => Empty, + Loading => True, + Main_Priority => Default_Main_Priority, + Main_CPU => Default_Main_CPU, + Munit_Index => 0, + Serial_Number => 0, + Source_Index => Main_Source_File, + Unit_File_Name => Fname, + Unit_Name => No_Unit_Name, + Version => Version, + OA_Setting => 'O'); + end if; + end Load_Main_Source; + + --------------- + -- Load_Unit -- + --------------- + + function Load_Unit + (Load_Name : Unit_Name_Type; + Required : Boolean; + Error_Node : Node_Id; + Subunit : Boolean; + Corr_Body : Unit_Number_Type := No_Unit; + Renamings : Boolean := False; + With_Node : Node_Id := Empty; + PMES : Boolean := False) return Unit_Number_Type + is + Calling_Unit : Unit_Number_Type; + Uname_Actual : Unit_Name_Type; + Unum : Unit_Number_Type; + Unump : Unit_Number_Type; + Fname : File_Name_Type; + Src_Ind : Source_File_Index; + Save_PMES : constant Boolean := Parsing_Main_Extended_Source; + + begin + Parsing_Main_Extended_Source := PMES; + + -- If renamings are allowed and we have a child unit name, then we + -- must first load the parent to deal with finding the real name. + -- Retain the with_clause that names the child, so that if it is + -- limited, the parent is loaded under the same condition. + + if Renamings and then Is_Child_Name (Load_Name) then + Unump := + Load_Unit + (Load_Name => Get_Parent_Spec_Name (Load_Name), + Required => Required, + Subunit => False, + Renamings => True, + Error_Node => Error_Node, + With_Node => With_Node); + + if Unump = No_Unit then + Parsing_Main_Extended_Source := Save_PMES; + return No_Unit; + end if; + + -- If parent is a renaming, then we use the renamed package as + -- the actual parent for the subsequent load operation. + + if Nkind (Unit (Cunit (Unump))) = N_Package_Renaming_Declaration then + Uname_Actual := + New_Child + (Load_Name, Get_Unit_Name (Name (Unit (Cunit (Unump))))); + + -- Save the renaming entity, to establish its visibility when + -- installing the context. The implicit with is on this entity, + -- not on the package it renames. + + if Nkind (Error_Node) = N_With_Clause + and then Nkind (Name (Error_Node)) = N_Selected_Component + then + declare + Par : Node_Id := Name (Error_Node); + + begin + while Nkind (Par) = N_Selected_Component + and then Chars (Selector_Name (Par)) /= + Chars (Cunit_Entity (Unump)) + loop + Par := Prefix (Par); + end loop; + + -- Case of some intermediate parent is a renaming + + if Nkind (Par) = N_Selected_Component then + Set_Entity (Selector_Name (Par), Cunit_Entity (Unump)); + + -- Case where the ultimate parent is a renaming + + else + Set_Entity (Par, Cunit_Entity (Unump)); + end if; + end; + end if; + + -- If the parent is not a renaming, then get its name (this may + -- be different from the parent spec name obtained above because + -- of renamings higher up in the hierarchy). + + else + Uname_Actual := New_Child (Load_Name, Unit_Name (Unump)); + end if; + + -- Here if unit to be loaded is not a child unit + + else + Uname_Actual := Load_Name; + end if; + + Fname := Get_File_Name (Uname_Actual, Subunit); + + if Debug_Flag_L then + Write_Eol; + Write_Str ("*** Load request for unit: "); + Write_Unit_Name (Load_Name); + + if Required then + Write_Str (" (Required = True)"); + else + Write_Str (" (Required = False)"); + end if; + + Write_Eol; + + if Uname_Actual /= Load_Name then + Write_Str ("*** Actual unit loaded: "); + Write_Unit_Name (Uname_Actual); + end if; + end if; + + -- Capture error location if it is for the main unit. The idea is to + -- post errors on the main unit location, not the most recent unit. + -- Note: Unit_Name (Main_Unit) is not set if we are parsing gnat.adc. + + if Present (Error_Node) + and then Unit_Name (Main_Unit) /= No_Unit_Name + then + -- It seems like In_Extended_Main_Source_Unit (Error_Node) would + -- do the trick here, but that's wrong, it is much too early to + -- call this routine. We are still in the parser, and the required + -- semantic information is not established yet. So we base the + -- judgment on unit names. + + Get_External_Unit_Name_String (Unit_Name (Main_Unit)); + + declare + Main_Unit_Name : constant String := Name_Buffer (1 .. Name_Len); + + begin + Get_External_Unit_Name_String + (Unit_Name (Get_Source_Unit (Error_Node))); + + -- If the two names are identical, then for sure we are part + -- of the extended main unit + + if Main_Unit_Name = Name_Buffer (1 .. Name_Len) then + Load_Msg_Sloc := Sloc (Error_Node); + + -- If the load is called from a with_type clause, the error + -- node is correct. + + -- Otherwise, check for the subunit case, and if so, consider + -- we have a match if one name is a prefix of the other name. + + else + if Nkind (Unit (Cunit (Main_Unit))) = N_Subunit + or else + Nkind (Unit (Cunit (Get_Source_Unit (Error_Node)))) = + N_Subunit + then + Name_Len := Integer'Min (Name_Len, Main_Unit_Name'Length); + + if Name_Buffer (1 .. Name_Len) + = + Main_Unit_Name (1 .. Name_Len) + then + Load_Msg_Sloc := Sloc (Error_Node); + end if; + end if; + end if; + end; + end if; + + -- If we are generating error messages, then capture calling unit + + if Present (Error_Node) then + Calling_Unit := Get_Source_Unit (Error_Node); + else + Calling_Unit := No_Unit; + end if; + + -- See if we already have an entry for this unit + + Unum := Main_Unit; + while Unum <= Units.Last loop + exit when Uname_Actual = Units.Table (Unum).Unit_Name; + Unum := Unum + 1; + end loop; + + -- Whether or not the entry was found, Unum is now the right value, + -- since it is one more than Units.Last (i.e. the index of the new + -- entry we will create) in the not found case. + + -- A special check is necessary in the unit not found case. If the unit + -- is not found, but the file in which it lives has already been loaded, + -- then we have the problem that the file does not contain the unit that + -- is needed. We simply treat this as a file not found condition. + + -- We skip this test in multiple unit per file mode since in this + -- case we can have multiple units from the same source file. + + if Unum > Units.Last and then Get_Unit_Index (Uname_Actual) = 0 then + for J in Units.First .. Units.Last loop + if Fname = Units.Table (J).Unit_File_Name then + if Debug_Flag_L then + Write_Str (" file does not contain unit, Unit_Number = "); + Write_Int (Int (Unum)); + Write_Eol; + Write_Eol; + end if; + + if Present (Error_Node) then + if Is_Predefined_File_Name (Fname) then + Error_Msg_Unit_1 := Uname_Actual; + Error_Msg + ("$$ is not a language defined unit", Load_Msg_Sloc); + else + Error_Msg_File_1 := Fname; + Error_Msg_Unit_1 := Uname_Actual; + Error_Msg ("File{ does not contain unit$", Load_Msg_Sloc); + end if; + + Write_Dependency_Chain; + Unum := No_Unit; + goto Done; + + else + Unum := No_Unit; + goto Done; + end if; + end if; + end loop; + end if; + + -- If we are proceeding with load, then make load stack entry, + -- and indicate the kind of with_clause responsible for the load. + + Load_Stack.Increment_Last; + Load_Stack.Table (Load_Stack.Last) := (Unum, With_Node); + + -- Case of entry already in table + + if Unum <= Units.Last then + + -- Here is where we check for a circular dependency, which is + -- an attempt to load a unit which is currently in the process + -- of being loaded. We do *not* care about a circular chain that + -- leads back to a body, because this kind of circular dependence + -- legitimately occurs (e.g. two package bodies that contain + -- inlined subprogram referenced by the other). + + -- Ada 2005 (AI-50217): We also ignore limited_with clauses, because + -- their purpose is precisely to create legal circular structures. + + if Loading (Unum) + and then (Is_Spec_Name (Units.Table (Unum).Unit_Name) + or else Acts_As_Spec (Units.Table (Unum).Cunit)) + and then (Nkind (Error_Node) /= N_With_Clause + or else not Limited_Present (Error_Node)) + and then not From_Limited_With_Chain + then + if Debug_Flag_L then + Write_Str (" circular dependency encountered"); + Write_Eol; + end if; + + if Present (Error_Node) then + Error_Msg ("circular unit dependency", Load_Msg_Sloc); + Write_Dependency_Chain; + else + Load_Stack.Decrement_Last; + end if; + + Unum := No_Unit; + goto Done; + end if; + + if Debug_Flag_L then + Write_Str (" unit already in file table, Unit_Number = "); + Write_Int (Int (Unum)); + Write_Eol; + end if; + + Load_Stack.Decrement_Last; + goto Done; + + -- Unit is not already in table, so try to open the file + + else + if Debug_Flag_L then + Write_Str (" attempt unit load, Unit_Number = "); + Write_Int (Int (Unum)); + Write_Eol; + end if; + + Src_Ind := Load_Source_File (Fname); + + -- Make a partial entry in the file table, used even in the file not + -- found case to print the dependency chain including the last entry + + Units.Increment_Last; + Units.Table (Unum).Unit_Name := Uname_Actual; + + -- File was found + + if Src_Ind /= No_Source_File then + Units.Table (Unum) := ( + Cunit => Empty, + Cunit_Entity => Empty, + Dependency_Num => 0, + Dynamic_Elab => False, + Error_Location => Sloc (Error_Node), + Expected_Unit => Uname_Actual, + Fatal_Error => False, + Generate_Code => False, + Has_Allocator => False, + Has_RACW => False, + Is_Compiler_Unit => False, + Ident_String => Empty, + Loading => True, + Main_Priority => Default_Main_Priority, + Main_CPU => Default_Main_CPU, + Munit_Index => 0, + Serial_Number => 0, + Source_Index => Src_Ind, + Unit_File_Name => Fname, + Unit_Name => Uname_Actual, + Version => Source_Checksum (Src_Ind), + OA_Setting => 'O'); + + -- Parse the new unit + + declare + Save_Index : constant Nat := Multiple_Unit_Index; + Save_PMES : constant Boolean := Parsing_Main_Extended_Source; + + begin + Multiple_Unit_Index := Get_Unit_Index (Uname_Actual); + Units.Table (Unum).Munit_Index := Multiple_Unit_Index; + Initialize_Scanner (Unum, Source_Index (Unum)); + + if Calling_Unit = Main_Unit and then Subunit then + Parsing_Main_Extended_Source := True; + end if; + + Discard_List (Par (Configuration_Pragmas => False)); + + Parsing_Main_Extended_Source := Save_PMES; + + Multiple_Unit_Index := Save_Index; + Set_Loading (Unum, False); + end; + + -- If spec is irrelevant, then post errors and quit + + if Corr_Body /= No_Unit + and then Spec_Is_Irrelevant (Unum, Corr_Body) + then + Error_Msg_File_1 := Unit_File_Name (Corr_Body); + Error_Msg + ("cannot compile subprogram in file {!", Load_Msg_Sloc); + Error_Msg_File_1 := Unit_File_Name (Unum); + Error_Msg + ("\incorrect spec in file { must be removed first!", + Load_Msg_Sloc); + Unum := No_Unit; + goto Done; + end if; + + -- If loaded unit had a fatal error, then caller inherits it! + + if Units.Table (Unum).Fatal_Error + and then Present (Error_Node) + then + Units.Table (Calling_Unit).Fatal_Error := True; + end if; + + -- Remove load stack entry and return the entry in the file table + + Load_Stack.Decrement_Last; + + -- All done, return unit number + + goto Done; + + -- Case of file not found + + else + if Debug_Flag_L then + Write_Str (" file was not found, load failed"); + Write_Eol; + end if; + + -- Generate message if unit required + + if Required and then Present (Error_Node) then + if Is_Predefined_File_Name (Fname) then + + -- This is a predefined library unit which is not present + -- in the run time. If a predefined unit is not available + -- it may very likely be the case that there is also pragma + -- Restriction forbidding its usage. This is typically the + -- case when building a configurable run time, where the + -- usage of certain run-time units is restricted by means + -- of both the corresponding pragma Restriction (such as + -- No_Calendar), and by not including the unit. Hence, we + -- check whether this predefined unit is forbidden, so that + -- the message about the restriction violation is generated, + -- if needed. + + Check_Restricted_Unit (Load_Name, Error_Node); + + Error_Msg_Unit_1 := Uname_Actual; + Error_Msg -- CODEFIX + ("$$ is not a predefined library unit", Load_Msg_Sloc); + + else + Error_Msg_File_1 := Fname; + Error_Msg ("file{ not found", Load_Msg_Sloc); + end if; + + Write_Dependency_Chain; + + -- Remove unit from stack, to avoid cascaded errors on + -- subsequent missing files. + + Load_Stack.Decrement_Last; + Units.Decrement_Last; + + -- If unit not required, remove load stack entry and the junk + -- file table entry, and return No_Unit to indicate not found, + + else + Load_Stack.Decrement_Last; + Units.Decrement_Last; + end if; + + Unum := No_Unit; + goto Done; + end if; + end if; + + -- Here to exit, with result in Unum + + <> + Parsing_Main_Extended_Source := Save_PMES; + return Unum; + end Load_Unit; + + -------------------------- + -- Make_Child_Decl_Unit -- + -------------------------- + + procedure Make_Child_Decl_Unit (N : Node_Id) is + Unit_Decl : constant Node_Id := Library_Unit (N); + + begin + Units.Increment_Last; + Units.Table (Units.Last) := Units.Table (Get_Cunit_Unit_Number (N)); + Units.Table (Units.Last).Unit_Name := + Get_Spec_Name (Unit_Name (Get_Cunit_Unit_Number (N))); + Units.Table (Units.Last).Cunit := Unit_Decl; + Units.Table (Units.Last).Cunit_Entity := + Defining_Identifier + (Defining_Unit_Name (Specification (Unit (Unit_Decl)))); + + -- The library unit created for of a child subprogram unit plays no + -- role in code generation and binding, so label it accordingly. + + Units.Table (Units.Last).Generate_Code := False; + Set_Has_No_Elaboration_Code (Unit_Decl); + end Make_Child_Decl_Unit; + + ------------------------ + -- Make_Instance_Unit -- + ------------------------ + + -- If the unit is an instance, it appears as a package declaration, but + -- contains both declaration and body of the instance. The body becomes + -- the main unit of the compilation, and the declaration is inserted + -- at the end of the unit table. The main unit now has the name of a + -- body, which is constructed from the name of the original spec, + -- and is attached to the compilation node of the original unit. The + -- declaration has been attached to a new compilation unit node, and + -- code will have to be generated for it. + + procedure Make_Instance_Unit (N : Node_Id; In_Main : Boolean) is + Sind : constant Source_File_Index := Source_Index (Main_Unit); + + begin + Units.Increment_Last; + + if In_Main then + Units.Table (Units.Last) := Units.Table (Main_Unit); + Units.Table (Units.Last).Cunit := Library_Unit (N); + Units.Table (Units.Last).Generate_Code := True; + Units.Table (Main_Unit).Cunit := N; + Units.Table (Main_Unit).Unit_Name := + Get_Body_Name + (Unit_Name (Get_Cunit_Unit_Number (Library_Unit (N)))); + Units.Table (Main_Unit).Version := Source_Checksum (Sind); + + else + -- Duplicate information from instance unit, for the body. The unit + -- node N has been rewritten as a body, but it was placed in the + -- units table when first loaded as a declaration. + + Units.Table (Units.Last) := Units.Table (Get_Cunit_Unit_Number (N)); + Units.Table (Units.Last).Cunit := Library_Unit (N); + end if; + end Make_Instance_Unit; + + ------------------------ + -- Spec_Is_Irrelevant -- + ------------------------ + + function Spec_Is_Irrelevant + (Spec_Unit : Unit_Number_Type; + Body_Unit : Unit_Number_Type) return Boolean + is + Sunit : constant Node_Id := Cunit (Spec_Unit); + Bunit : constant Node_Id := Cunit (Body_Unit); + + begin + -- The spec is irrelevant if the body is a subprogram body, and the spec + -- is other than a subprogram spec or generic subprogram spec. Note that + -- the names must be the same, we don't need to check that, because we + -- already know that from the fact that the file names are the same. + + return + Nkind (Unit (Bunit)) = N_Subprogram_Body + and then Nkind (Unit (Sunit)) /= N_Subprogram_Declaration + and then Nkind (Unit (Sunit)) /= N_Generic_Subprogram_Declaration; + end Spec_Is_Irrelevant; + + -------------------- + -- Version_Update -- + -------------------- + + procedure Version_Update (U : Node_Id; From : Node_Id) is + Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (U); + Fnum : constant Unit_Number_Type := Get_Cunit_Unit_Number (From); + begin + if Source_Index (Fnum) /= No_Source_File then + Units.Table (Unum).Version := + Units.Table (Unum).Version + xor + Source_Checksum (Source_Index (Fnum)); + end if; + end Version_Update; + + ---------------------------- + -- Write_Dependency_Chain -- + ---------------------------- + + procedure Write_Dependency_Chain is + begin + -- The dependency chain is only written if it is at least two entries + -- deep, otherwise it is trivial (the main unit depending on a unit + -- that it obviously directly depends on). + + if Load_Stack.Last - 1 > Load_Stack.First then + for U in Load_Stack.First .. Load_Stack.Last - 1 loop + Error_Msg_Unit_1 := + Unit_Name (Load_Stack.Table (U).Unit_Number); + Error_Msg_Unit_2 := + Unit_Name (Load_Stack.Table (U + 1).Unit_Number); + Error_Msg ("$ depends on $!", Load_Msg_Sloc); + end loop; + end if; + end Write_Dependency_Chain; + +end Lib.Load; diff --git a/gcc/ada/lib-load.ads b/gcc/ada/lib-load.ads new file mode 100644 index 000000000..d2856aa41 --- /dev/null +++ b/gcc/ada/lib-load.ads @@ -0,0 +1,204 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B . L O A D -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This child package contains the function used to load a separately +-- compiled unit, as well as the routine used to initialize the unit +-- table and load the main source file. + +package Lib.Load is + + ------------------------------- + -- Handling of Renamed Units -- + ------------------------------- + + -- A compilation unit can be a renaming of another compilation unit. + -- Such renamed units are not allowed as parent units, that is you + -- cannot declare a unit: + + -- with x; + -- package x.y is end; + + -- where x is a renaming of some other package. However you can refer + -- to a renamed unit in a with clause: + + -- package p is end; + + -- package p.q is end; + + -- with p; + -- package pr renames p; + + -- with pr.q .... + + -- This means that in the context of a with clause, the normal fixed + -- correspondence between unit and file names is broken. In the above + -- example, there is no file named pr-q.ads, since the actual child + -- unit is p.q, and it will be found in file p-q.ads. + + -- In order to deal with this case, we have to first load pr.ads, and + -- then discover that it is a renaming of p, so that we know that pr.q + -- really refers to p.q. Furthermore this can happen at any level: + + -- with p.q; + -- package p.r renames p.q; + + -- with p.q; + -- package p.q.s is end; + + -- with p.r.s ... + + -- Now we have a case where the parent p.r is a child unit and is + -- a renaming. This shows that renaming can occur at any level. + + -- Finally, consider: + + -- with pr.q.s ... + + -- Here the parent pr.q is not itself a renaming, but it really refers + -- to the unit p.q, and again we cannot know this without loading the + -- parent. The bottom line here is that while the file name of a unit + -- always corresponds to the unit name, the unit name as given to the + -- Load_Unit function may not be the real unit. + + ----------------- + -- Subprograms -- + ----------------- + + procedure Initialize; + -- Initialize internal tables + + procedure Initialize_Version (U : Unit_Number_Type); + -- This is called once the source file corresponding to unit U has been + -- fully scanned. At that point the checksum is computed, and can be used + -- to initialize the version number. + + procedure Load_Main_Source; + -- Called at the start of compiling a new main source unit to initialize + -- the library processing for the new main source. Establishes and + -- initializes the units table entry for the new main unit (leaving + -- the Unit_File_Name entry of Main_Unit set to No_File if there are no + -- more files. Otherwise the main source file has been opened and read + -- and then closed on return. + + function Load_Unit + (Load_Name : Unit_Name_Type; + Required : Boolean; + Error_Node : Node_Id; + Subunit : Boolean; + Corr_Body : Unit_Number_Type := No_Unit; + Renamings : Boolean := False; + With_Node : Node_Id := Empty; + PMES : Boolean := False) return Unit_Number_Type; + -- This function loads and parses the unit specified by Load_Name (or + -- returns the unit number for the previously constructed units table + -- entry if this is not the first call for this unit). Required indicates + -- the behavior on a file not found condition, as further described below, + -- and Error_Node is the node in the calling program to which error + -- messages are to be attached. + -- + -- If the corresponding file is found, the value returned by Load is the + -- unit number that indexes the corresponding entry in the units table. If + -- a serious enough parser error occurs to prevent subsequent semantic + -- analysis, then the Fatal_Error flag of the returned entry is set and + -- in addition, the fatal error flag of the calling unit is also set. + -- + -- If the corresponding file is not found, then the behavior depends on + -- the setting of Required. If Required is False, then No_Unit is returned + -- and no error messages are issued. If Required is True, then an error + -- message is posted, and No_Unit is returned. + -- + -- A special case arises in the call from Rtsfind, where Error_Node is set + -- to Empty. In this case Required is False, and the caller in any case + -- treats any error as fatal. + -- + -- The Subunit parameter is True to load a subunit, and False to load + -- any other kind of unit (including all specs, package bodies, and + -- subprogram bodies). + -- + -- The Corr_Body argument is normally defaulted. It is set only in the + -- case of loading the corresponding spec when the main unit is a body. + -- In this case, Corr_Body is the unit number of this corresponding + -- body. This is used to set the Serial_Ref_Unit field of the unit + -- table entry. It is also used to deal with the special processing + -- required by RM 10.1.4(4). See description in lib.ads. + -- + -- Renamings activates the handling of renamed units as separately + -- described in the documentation of this unit. If this parameter is + -- set to True, then Load_Name may not be the real unit name and it + -- is necessary to load parents to find the real name. + -- + -- With_Node is set to the with_clause or limited_with_clause causing + -- the unit to be loaded, and is used to bypass the circular dependency + -- check in the case of a limited_with_clause (Ada 2005, AI-50217). + -- + -- PMES indicates the required setting of Parsing_Main_Extended_Unit during + -- loading of the unit. This flag is saved and restored over the call. + + procedure Change_Main_Unit_To_Spec; + -- This procedure is called if the main unit file contains a No_Body pragma + -- and no other tokens. The effect is, if possible, to change the main unit + -- from the body it references now, to the corresponding spec. This has the + -- effect of ignoring the body, which is what we want. If it is impossible + -- to successfully make the change, then the call has no effect, and the + -- file is unchanged (this will lead to an error complaining about the + -- inappropriate No_Body spec). + + function Create_Dummy_Package_Unit + (With_Node : Node_Id; + Spec_Name : Unit_Name_Type) return Unit_Number_Type; + -- With_Node is the Node_Id of a with statement for which the file could + -- not be found, and Spec_Name is the corresponding unit name. This call + -- creates a dummy package unit so that compilation can continue without + -- blowing up when the missing unit is referenced. + + procedure Make_Child_Decl_Unit (N : Node_Id); + -- For a child subprogram body without a spec, we create a subprogram + -- declaration in order to attach the required parent link. We create + -- a Units_Table entry for this declaration, in order to maintain a + -- one-to-one correspondence between compilation units and table entries. + + procedure Make_Instance_Unit (N : Node_Id; In_Main : Boolean); + -- When a compilation unit is an instantiation, it contains both the + -- declaration and the body of the instance, each of which can have its + -- own elaboration routine. The file itself corresponds to the declaration. + -- We create an additional entry for the body, so that the binder can + -- generate the proper elaboration calls to both. The argument N is the + -- compilation unit node created for the body. + -- + -- If the instance is not the main program, we still generate the instance + -- body even though we do not generate code for it. In that case we still + -- generate a compilation unit node for it, and we need to make an entry + -- for it in the units table, so as to maintain a one-to-one mapping + -- between table and nodes. The table entry is used among other things to + -- provide a canonical traversal order for context units for Inspector. + -- The flag In_Main indicates whether the instance is the main unit. + + procedure Version_Update (U : Node_Id; From : Node_Id); + -- This routine is called when unit U is found to be semantically + -- dependent on unit From. It updates the version of U to register + -- dependence on the version of From. The arguments are compilation + -- unit nodes for the relevant library nodes. + +end Lib.Load; diff --git a/gcc/ada/lib-sort.adb b/gcc/ada/lib-sort.adb new file mode 100644 index 000000000..7bc155ba2 --- /dev/null +++ b/gcc/ada/lib-sort.adb @@ -0,0 +1,99 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B . S O R 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. -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.Heap_Sort_G; + +separate (Lib) +procedure Sort (Tbl : in out Unit_Ref_Table) is + + T : array (0 .. Integer (Tbl'Last - Tbl'First + 1)) of Unit_Number_Type; + -- Actual sort is done on this copy of the array with 0's origin + -- subscripts. Location 0 is used as a temporary by the sorting algorithm. + -- Also the addressing of the table is more efficient with 0's origin, + -- even though we have to copy Tbl back and forth. + + function Lt_Uname (C1, C2 : Natural) return Boolean; + -- Comparison routine for comparing Unames. Needed by the sorting routine + + procedure Move_Uname (From : Natural; To : Natural); + -- Move routine needed by the sorting routine below + + package Sorting is new GNAT.Heap_Sort_G (Move_Uname, Lt_Uname); + + -------------- + -- Lt_Uname -- + -------------- + + function Lt_Uname (C1, C2 : Natural) return Boolean is + begin + -- Preprocessing data and definition files are not sorted, they are + -- at the bottom of the list. They are recognized because they are + -- the only ones without a Unit_Name. + + if Units.Table (T (C1)).Unit_Name = No_Unit_Name then + return False; + + elsif Units.Table (T (C2)).Unit_Name = No_Unit_Name then + return True; + + else + return + Uname_Lt + (Units.Table (T (C1)).Unit_Name, Units.Table (T (C2)).Unit_Name); + end if; + end Lt_Uname; + + ---------------- + -- Move_Uname -- + ---------------- + + procedure Move_Uname (From : Natural; To : Natural) is + begin + T (To) := T (From); + end Move_Uname; + +-- Start of processing for Sort + +begin + if T'Last > 0 then + for I in 1 .. T'Last loop + T (I) := Tbl (Int (I) - 1 + Tbl'First); + end loop; + + Sorting.Sort (T'Last); + + -- Sort is complete, copy result back into place + + for I in 1 .. T'Last loop + Tbl (Int (I) - 1 + Tbl'First) := T (I); + end loop; + end if; +end Sort; diff --git a/gcc/ada/lib-util.adb b/gcc/ada/lib-util.adb new file mode 100644 index 000000000..9047690d6 --- /dev/null +++ b/gcc/ada/lib-util.adb @@ -0,0 +1,292 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B . U T I 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Hostparm; +with Osint.C; use Osint.C; +with Stringt; use Stringt; + +package body Lib.Util is + + Max_Line : constant Natural := 2 * Hostparm.Max_Name_Length + 64; + Max_Buffer : constant Natural := 1000 * Max_Line; + + Info_Buffer : String (1 .. Max_Buffer); + -- Info_Buffer used to prepare lines of library output + + Info_Buffer_Len : Natural := 0; + -- Number of characters stored in Info_Buffer + + Info_Buffer_Col : Natural := 1; + -- Column number of next character to be written. + -- Can be different from Info_Buffer_Len + 1 because of tab characters + -- written by Write_Info_Tab. + + procedure Write_Info_Hex_Byte (J : Natural); + -- Place two hex digits representing the value J (which is in the range + -- 0-255) in Info_Buffer, incrementing Info_Buffer_Len by 2. The digits + -- are output using lower case letters. + + --------------------- + -- Write_Info_Char -- + --------------------- + + procedure Write_Info_Char (C : Character) is + begin + Info_Buffer_Len := Info_Buffer_Len + 1; + Info_Buffer (Info_Buffer_Len) := C; + Info_Buffer_Col := Info_Buffer_Col + 1; + end Write_Info_Char; + + -------------------------- + -- Write_Info_Char_Code -- + -------------------------- + + procedure Write_Info_Char_Code (Code : Char_Code) is + begin + -- 00 .. 7F + + if Code <= 16#7F# then + Write_Info_Char (Character'Val (Code)); + + -- 80 .. FF + + elsif Code <= 16#FF# then + Write_Info_Char ('U'); + Write_Info_Hex_Byte (Natural (Code)); + + -- 0100 .. FFFF + + else + Write_Info_Char ('W'); + Write_Info_Hex_Byte (Natural (Code / 256)); + Write_Info_Hex_Byte (Natural (Code mod 256)); + end if; + end Write_Info_Char_Code; + + -------------------- + -- Write_Info_Col -- + -------------------- + + function Write_Info_Col return Positive is + begin + return Info_Buffer_Col; + end Write_Info_Col; + + -------------------- + -- Write_Info_EOL -- + -------------------- + + procedure Write_Info_EOL is + begin + if Hostparm.OpenVMS + or else Info_Buffer_Len + Max_Line + 1 > Max_Buffer + then + Write_Info_Terminate; + else + -- Delete any trailing blanks + + while Info_Buffer_Len > 0 + and then Info_Buffer (Info_Buffer_Len) = ' ' + loop + Info_Buffer_Len := Info_Buffer_Len - 1; + end loop; + + Info_Buffer_Len := Info_Buffer_Len + 1; + Info_Buffer (Info_Buffer_Len) := ASCII.LF; + Info_Buffer_Col := 1; + end if; + end Write_Info_EOL; + + ------------------------- + -- Write_Info_Hex_Byte -- + ------------------------- + + procedure Write_Info_Hex_Byte (J : Natural) is + Hexd : constant array (0 .. 15) of Character := "0123456789abcdef"; + begin + Write_Info_Char (Hexd (J / 16)); + Write_Info_Char (Hexd (J mod 16)); + end Write_Info_Hex_Byte; + + ------------------------- + -- Write_Info_Initiate -- + ------------------------- + + procedure Write_Info_Initiate (Key : Character) renames Write_Info_Char; + + -------------------- + -- Write_Info_Int -- + -------------------- + + procedure Write_Info_Int (N : Int) is + begin + if N >= 0 then + Write_Info_Nat (N); + + -- Negative numbers, use Write_Info_Uint to avoid problems with largest + -- negative number. + + else + Write_Info_Uint (UI_From_Int (N)); + end if; + end Write_Info_Int; + + --------------------- + -- Write_Info_Name -- + --------------------- + + procedure Write_Info_Name (Name : Name_Id) is + begin + Get_Name_String (Name); + Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Name_Len) := + Name_Buffer (1 .. Name_Len); + Info_Buffer_Len := Info_Buffer_Len + Name_Len; + Info_Buffer_Col := Info_Buffer_Col + Name_Len; + end Write_Info_Name; + + procedure Write_Info_Name (Name : File_Name_Type) is + begin + Write_Info_Name (Name_Id (Name)); + end Write_Info_Name; + + procedure Write_Info_Name (Name : Unit_Name_Type) is + begin + Write_Info_Name (Name_Id (Name)); + end Write_Info_Name; + + -------------------- + -- Write_Info_Nat -- + -------------------- + + procedure Write_Info_Nat (N : Nat) is + begin + if N > 9 then + Write_Info_Nat (N / 10); + end if; + + Write_Info_Char (Character'Val (N mod 10 + Character'Pos ('0'))); + end Write_Info_Nat; + + --------------------- + -- Write_Info_Slit -- + --------------------- + + procedure Write_Info_Slit (S : String_Id) is + C : Character; + + begin + Write_Info_Str (""""); + + for J in 1 .. String_Length (S) loop + C := Get_Character (Get_String_Char (S, J)); + + if C in Character'Val (16#20#) .. Character'Val (16#7E#) + and then C /= '{' + then + Write_Info_Char (C); + + if C = '"' then + Write_Info_Char (C); + end if; + + else + Write_Info_Char ('{'); + Write_Info_Hex_Byte (Character'Pos (C)); + Write_Info_Char ('}'); + end if; + end loop; + + Write_Info_Char ('"'); + end Write_Info_Slit; + + -------------------- + -- Write_Info_Str -- + -------------------- + + procedure Write_Info_Str (Val : String) is + begin + Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Val'Length) + := Val; + Info_Buffer_Len := Info_Buffer_Len + Val'Length; + Info_Buffer_Col := Info_Buffer_Col + Val'Length; + end Write_Info_Str; + + -------------------- + -- Write_Info_Tab -- + -------------------- + + procedure Write_Info_Tab (Col : Positive) is + Next_Tab : Positive; + + begin + if Col <= Info_Buffer_Col then + Write_Info_Str (" "); + else + loop + Next_Tab := 8 * ((Info_Buffer_Col - 1) / 8) + 8 + 1; + exit when Col < Next_Tab; + Write_Info_Char (ASCII.HT); + Info_Buffer_Col := Next_Tab; + end loop; + + while Info_Buffer_Col < Col loop + Write_Info_Char (' '); + end loop; + end if; + end Write_Info_Tab; + + -------------------------- + -- Write_Info_Terminate -- + -------------------------- + + procedure Write_Info_Terminate is + begin + -- Delete any trailing blanks + + while Info_Buffer_Len > 0 + and then Info_Buffer (Info_Buffer_Len) = ' ' + loop + Info_Buffer_Len := Info_Buffer_Len - 1; + end loop; + + -- Write_Library_Info adds the EOL + + Write_Library_Info (Info_Buffer (1 .. Info_Buffer_Len)); + + Info_Buffer_Len := 0; + Info_Buffer_Col := 1; + end Write_Info_Terminate; + + --------------------- + -- Write_Info_Uint -- + --------------------- + + procedure Write_Info_Uint (N : Uint) is + begin + UI_Image (N, Decimal); + Write_Info_Str (UI_Image_Buffer (1 .. UI_Image_Length)); + end Write_Info_Uint; + +end Lib.Util; diff --git a/gcc/ada/lib-util.ads b/gcc/ada/lib-util.ads new file mode 100644 index 000000000..b34bd277a --- /dev/null +++ b/gcc/ada/lib-util.ads @@ -0,0 +1,86 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B . U T I 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Uintp; use Uintp; + +package Lib.Util is + + -- This package implements a buffered write of library information + + procedure Write_Info_Char (C : Character); + pragma Inline (Write_Info_Char); + -- Adds one character to the info + + procedure Write_Info_Char_Code (Code : Char_Code); + -- Write a single character code. Upper half values in the range + -- 16#80..16#FF are written as Uhh (hh = 2 hex digits), and values + -- greater than 16#FF are written as Whhhh (hhhh = 4 hex digits). + + function Write_Info_Col return Positive; + -- Returns the column in which the next character will be written + + procedure Write_Info_EOL; + -- Terminate current info line. This only flushes the buffer + -- if there is not enough room for another complete line or + -- if the host system needs a write for each line. + + procedure Write_Info_Initiate (Key : Character); + -- Initiates write of new line to info file, the parameter is the keyword + -- character for the line. The caller is responsible for writing the + -- required blank after the key character if needed. + + procedure Write_Info_Nat (N : Nat); + -- Adds image of N to Info_Buffer with no leading or trailing blanks + + procedure Write_Info_Int (N : Int); + -- Adds image of N to Info_Buffer with no leading or trailing blanks. A + -- minus sign is prepended for negative values. + + procedure Write_Info_Name (Name : Name_Id); + procedure Write_Info_Name (Name : File_Name_Type); + procedure Write_Info_Name (Name : Unit_Name_Type); + -- Adds characters of Name to Info_Buffer. Note that in all cases, the + -- name is written literally from the names table entry without modifying + -- the case, using simply Get_Name_String. + + procedure Write_Info_Slit (S : String_Id); + -- Write string literal value in format required for L/N lines in ali file + + procedure Write_Info_Str (Val : String); + -- Adds characters of Val to Info_Buffer surrounded by quotes + + procedure Write_Info_Tab (Col : Positive); + -- Tab out with blanks and HT's to column Col. If already at or past + -- Col, writes a single blank, so that we do get a required field + -- separation. + + procedure Write_Info_Terminate; + -- Terminate current info line and output lines built in Info_Buffer + + procedure Write_Info_Uint (N : Uint); + -- Adds decimal image of N to Info_Buffer with no leading or trailing + -- blanks. A minus sign is prepended for negative values. + +end Lib.Util; diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb new file mode 100644 index 000000000..d1e442a32 --- /dev/null +++ b/gcc/ada/lib-writ.adb @@ -0,0 +1,1328 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B . W R I T -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with ALI; use ALI; +with Atree; use Atree; +with Casing; use Casing; +with Einfo; use Einfo; +with Errout; use Errout; +with Fname; use Fname; +with Fname.UF; use Fname.UF; +with Lib.Util; use Lib.Util; +with Lib.Xref; use Lib.Xref; +with Nlists; use Nlists; +with Gnatvsn; use Gnatvsn; +with Opt; use Opt; +with Osint; use Osint; +with Osint.C; use Osint.C; +with Par; +with Par_SCO; use Par_SCO; +with Restrict; use Restrict; +with Rident; use Rident; +with Scn; use Scn; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with Stringt; use Stringt; +with Tbuild; use Tbuild; +with Uname; use Uname; + +with System.Case_Util; use System.Case_Util; +with System.WCh_Con; use System.WCh_Con; + +package body Lib.Writ is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Write_Unit_Name (N : Node_Id); + -- Used to write out the unit name for R (pragma Restriction) lines + -- for uses of Restriction (No_Dependence => unit-name). + + ---------------------------------- + -- Add_Preprocessing_Dependency -- + ---------------------------------- + + procedure Add_Preprocessing_Dependency (S : Source_File_Index) is + begin + Units.Increment_Last; + Units.Table (Units.Last) := + (Unit_File_Name => File_Name (S), + Unit_Name => No_Unit_Name, + Expected_Unit => No_Unit_Name, + Source_Index => S, + Cunit => Empty, + Cunit_Entity => Empty, + Dependency_Num => 0, + Dynamic_Elab => False, + Fatal_Error => False, + Generate_Code => False, + Has_Allocator => False, + Has_RACW => False, + Is_Compiler_Unit => False, + Ident_String => Empty, + Loading => False, + Main_Priority => -1, + Main_CPU => -1, + Munit_Index => 0, + Serial_Number => 0, + Version => 0, + Error_Location => No_Location, + OA_Setting => 'O'); + end Add_Preprocessing_Dependency; + + ------------------------------ + -- Ensure_System_Dependency -- + ------------------------------ + + procedure Ensure_System_Dependency is + System_Uname : Unit_Name_Type; + -- Unit name for system spec if needed for dummy entry + + System_Fname : File_Name_Type; + -- File name for system spec if needed for dummy entry + + begin + -- Nothing to do if we already compiled System + + for Unum in Units.First .. Last_Unit loop + if Units.Table (Unum).Source_Index = System_Source_File_Index then + return; + end if; + end loop; + + -- If no entry for system.ads in the units table, then add a entry + -- to the units table for system.ads, which will be referenced when + -- the ali file is generated. We need this because every unit depends + -- on system as a result of Targparm scanning the system.ads file to + -- determine the target dependent parameters for the compilation. + + Name_Len := 6; + Name_Buffer (1 .. 6) := "system"; + System_Uname := Name_To_Unit_Name (Name_Enter); + System_Fname := File_Name (System_Source_File_Index); + + Units.Increment_Last; + Units.Table (Units.Last) := ( + Unit_File_Name => System_Fname, + Unit_Name => System_Uname, + Expected_Unit => System_Uname, + Source_Index => System_Source_File_Index, + Cunit => Empty, + Cunit_Entity => Empty, + Dependency_Num => 0, + Dynamic_Elab => False, + Fatal_Error => False, + Generate_Code => False, + Has_Allocator => False, + Has_RACW => False, + Is_Compiler_Unit => False, + Ident_String => Empty, + Loading => False, + Main_Priority => -1, + Main_CPU => -1, + Munit_Index => 0, + Serial_Number => 0, + Version => 0, + Error_Location => No_Location, + OA_Setting => 'O'); + + -- Parse system.ads so that the checksum is set right + -- Style checks are not applied. + + declare + Save_Mindex : constant Nat := Multiple_Unit_Index; + Save_Style : constant Boolean := Style_Check; + begin + Multiple_Unit_Index := 0; + Style_Check := False; + Initialize_Scanner (Units.Last, System_Source_File_Index); + Discard_List (Par (Configuration_Pragmas => False)); + Style_Check := Save_Style; + Multiple_Unit_Index := Save_Mindex; + end; + end Ensure_System_Dependency; + + --------------- + -- Write_ALI -- + --------------- + + procedure Write_ALI (Object : Boolean) is + + ---------------- + -- Local Data -- + ---------------- + + Last_Unit : constant Unit_Number_Type := Units.Last; + -- Record unit number of last unit. We capture this in case we + -- have to add a dummy entry to the unit table for package System. + + With_Flags : array (Units.First .. Last_Unit) of Boolean; + -- Array of flags to show which units are with'ed + + Elab_Flags : array (Units.First .. Last_Unit) of Boolean; + -- Array of flags to show which units have pragma Elaborate set + + Elab_All_Flags : array (Units.First .. Last_Unit) of Boolean; + -- Array of flags to show which units have pragma Elaborate All set + + Elab_Des_Flags : array (Units.First .. Last_Unit) of Boolean; + -- Array of flags to show which units have Elaborate_Desirable set + + Elab_All_Des_Flags : array (Units.First .. Last_Unit) of Boolean; + -- Array of flags to show which units have Elaborate_All_Desirable set + + Sdep_Table : Unit_Ref_Table (1 .. Pos (Last_Unit - Units.First + 2)); + -- Sorted table of source dependencies. One extra entry in case we + -- have to add a dummy entry for System. + + Num_Sdep : Nat := 0; + -- Number of active entries in Sdep_Table + + flag_compare_debug : Int; + pragma Import (C, flag_compare_debug); + -- Import from toplev.c + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Collect_Withs (Cunit : Node_Id); + -- Collect with lines for entries in the context clause of the + -- given compilation unit, Cunit. + + procedure Update_Tables_From_ALI_File; + -- Given an up to date ALI file (see Up_To_Date_ALI_file_Exists + -- function), update tables from the ALI information, including + -- specifically the Compilation_Switches table. + + function Up_To_Date_ALI_File_Exists return Boolean; + -- If there exists an ALI file that is up to date, then this function + -- initializes the tables in the ALI spec to contain information on + -- this file (using Scan_ALI) and returns True. If no file exists, + -- or the file is not up to date, then False is returned. + + procedure Write_Unit_Information (Unit_Num : Unit_Number_Type); + -- Write out the library information for one unit for which code is + -- generated (includes unit line and with lines). + + procedure Write_With_Lines; + -- Write out with lines collected by calls to Collect_Withs + + ------------------- + -- Collect_Withs -- + ------------------- + + procedure Collect_Withs (Cunit : Node_Id) is + Item : Node_Id; + Unum : Unit_Number_Type; + + begin + Item := First (Context_Items (Cunit)); + while Present (Item) loop + + -- Process with clause + + -- Ada 2005 (AI-50217): limited with_clauses do not create + -- dependencies, but must be recorded as components of the + -- partition, in case there is no regular with_clause for + -- the unit anywhere else. + + if Nkind (Item) = N_With_Clause then + Unum := Get_Cunit_Unit_Number (Library_Unit (Item)); + With_Flags (Unum) := True; + + if not Limited_Present (Item) then + if Elaborate_Present (Item) then + Elab_Flags (Unum) := True; + end if; + + if Elaborate_All_Present (Item) then + Elab_All_Flags (Unum) := True; + end if; + + if Elaborate_All_Desirable (Item) then + Elab_All_Des_Flags (Unum) := True; + end if; + + if Elaborate_Desirable (Item) then + Elab_Des_Flags (Unum) := True; + end if; + + else + Set_From_With_Type (Cunit_Entity (Unum)); + end if; + end if; + + Next (Item); + end loop; + end Collect_Withs; + + -------------------------------- + -- Up_To_Date_ALI_File_Exists -- + -------------------------------- + + function Up_To_Date_ALI_File_Exists return Boolean is + Name : File_Name_Type; + Text : Text_Buffer_Ptr; + Id : Sdep_Id; + Sind : Source_File_Index; + + begin + Opt.Check_Object_Consistency := True; + Read_Library_Info (Name, Text); + + -- Return if we could not find an ALI file + + if Text = null then + return False; + end if; + + -- Return if ALI file has bad format + + Initialize_ALI; + + if Scan_ALI (Name, Text, False, Err => True) = No_ALI_Id then + return False; + end if; + + -- If we have an OK ALI file, check if it is up to date + -- Note that we assume that the ALI read has all the entries + -- we have in our table, plus some additional ones (that can + -- come from expansion). + + Id := First_Sdep_Entry; + for J in 1 .. Num_Sdep loop + Sind := Units.Table (Sdep_Table (J)).Source_Index; + + while Sdep.Table (Id).Sfile /= File_Name (Sind) loop + if Id = Sdep.Last then + return False; + else + Id := Id + 1; + end if; + end loop; + + if Sdep.Table (Id).Stamp /= Time_Stamp (Sind) then + return False; + end if; + end loop; + + return True; + end Up_To_Date_ALI_File_Exists; + + --------------------------------- + -- Update_Tables_From_ALI_File -- + --------------------------------- + + procedure Update_Tables_From_ALI_File is + begin + -- Build Compilation_Switches table + + Compilation_Switches.Init; + + for J in First_Arg_Entry .. Args.Last loop + Compilation_Switches.Increment_Last; + Compilation_Switches.Table (Compilation_Switches.Last) := + Args.Table (J); + end loop; + end Update_Tables_From_ALI_File; + + ---------------------------- + -- Write_Unit_Information -- + ---------------------------- + + procedure Write_Unit_Information (Unit_Num : Unit_Number_Type) is + Unode : constant Node_Id := Cunit (Unit_Num); + Ukind : constant Node_Kind := Nkind (Unit (Unode)); + Uent : constant Entity_Id := Cunit_Entity (Unit_Num); + Pnode : Node_Id; + + begin + Write_Info_Initiate ('U'); + Write_Info_Char (' '); + Write_Info_Name (Unit_Name (Unit_Num)); + Write_Info_Tab (25); + Write_Info_Name (Unit_File_Name (Unit_Num)); + + Write_Info_Tab (49); + Write_Info_Str (Version_Get (Unit_Num)); + + -- Add BD parameter if Elaborate_Body pragma desirable + + if Ekind (Uent) = E_Package + and then Elaborate_Body_Desirable (Uent) + then + Write_Info_Str (" BD"); + end if; + + -- Add BN parameter if body needed for SAL + + if (Is_Subprogram (Uent) + or else Ekind (Uent) = E_Package + or else Is_Generic_Unit (Uent)) + and then Body_Needed_For_SAL (Uent) + then + Write_Info_Str (" BN"); + end if; + + if Dynamic_Elab (Unit_Num) then + Write_Info_Str (" DE"); + end if; + + -- Set the Elaborate_Body indication if either an explicit pragma + -- was present, or if this is an instantiation. + + if Has_Pragma_Elaborate_Body (Uent) + or else (Ukind = N_Package_Declaration + and then Is_Generic_Instance (Uent) + and then Present (Corresponding_Body (Unit (Unode)))) + then + Write_Info_Str (" EB"); + end if; + + -- Now see if we should tell the binder that an elaboration entity + -- is present, which must be set to true during elaboration. + -- We generate the indication if the following condition is met: + + -- If this is a spec ... + + if (Is_Subprogram (Uent) + or else + Ekind (Uent) = E_Package + or else + Is_Generic_Unit (Uent)) + + -- and an elaboration entity was declared ... + + and then Present (Elaboration_Entity (Uent)) + + -- and either the elaboration flag is required ... + + and then + (Elaboration_Entity_Required (Uent) + + -- or this unit has elaboration code ... + + or else not Has_No_Elaboration_Code (Unode) + + -- or this unit has a separate body and this + -- body has elaboration code. + + or else + (Ekind (Uent) = E_Package + and then Present (Body_Entity (Uent)) + and then + not Has_No_Elaboration_Code + (Parent + (Declaration_Node + (Body_Entity (Uent)))))) + then + if Convention (Uent) = Convention_CIL then + + -- Special case for generic CIL packages which never have + -- elaboration code + + Write_Info_Str (" NE"); + + else + Write_Info_Str (" EE"); + end if; + end if; + + if Has_No_Elaboration_Code (Unode) then + Write_Info_Str (" NE"); + end if; + + Write_Info_Str (" O"); + Write_Info_Char (OA_Setting (Unit_Num)); + + if Is_Preelaborated (Uent) then + Write_Info_Str (" PR"); + end if; + + if Is_Pure (Uent) then + Write_Info_Str (" PU"); + end if; + + if Has_RACW (Unit_Num) then + Write_Info_Str (" RA"); + end if; + + if Is_Remote_Call_Interface (Uent) then + Write_Info_Str (" RC"); + end if; + + if Is_Remote_Types (Uent) then + Write_Info_Str (" RT"); + end if; + + if Is_Shared_Passive (Uent) then + Write_Info_Str (" SP"); + end if; + + if Ukind = N_Subprogram_Declaration + or else Ukind = N_Subprogram_Body + then + Write_Info_Str (" SU"); + + elsif Ukind = N_Package_Declaration + or else + Ukind = N_Package_Body + then + -- If this is a wrapper package for a subprogram instantiation, + -- the user view is the subprogram. Note that in this case the + -- ali file contains both the spec and body of the instance. + + if Is_Wrapper_Package (Uent) then + Write_Info_Str (" SU"); + else + Write_Info_Str (" PK"); + end if; + + elsif Ukind = N_Generic_Package_Declaration then + Write_Info_Str (" PK"); + + end if; + + if Ukind in N_Generic_Declaration + or else + (Present (Library_Unit (Unode)) + and then + Nkind (Unit (Library_Unit (Unode))) in N_Generic_Declaration) + then + Write_Info_Str (" GE"); + end if; + + if not Is_Internal_File_Name (Unit_File_Name (Unit_Num), True) then + case Identifier_Casing (Source_Index (Unit_Num)) is + when All_Lower_Case => Write_Info_Str (" IL"); + when All_Upper_Case => Write_Info_Str (" IU"); + when others => null; + end case; + + case Keyword_Casing (Source_Index (Unit_Num)) is + when Mixed_Case => Write_Info_Str (" KM"); + when All_Upper_Case => Write_Info_Str (" KU"); + when others => null; + end case; + end if; + + if Initialize_Scalars or else Invalid_Value_Used then + Write_Info_Str (" IS"); + end if; + + Write_Info_EOL; + + -- Generate with lines, first those that are directly with'ed + + for J in With_Flags'Range loop + With_Flags (J) := False; + Elab_Flags (J) := False; + Elab_All_Flags (J) := False; + Elab_Des_Flags (J) := False; + Elab_All_Des_Flags (J) := False; + end loop; + + Collect_Withs (Unode); + + -- For a body, we must also check for any subunits which belong to + -- it and which have context clauses of their own, since these + -- with'ed units are part of its own elaboration dependencies. + + if Nkind (Unit (Unode)) in N_Unit_Body then + for S in Units.First .. Last_Unit loop + + -- We are only interested in subunits. + -- For preproc. data and def. files, Cunit is Empty, so + -- we need to test that first. + + if Cunit (S) /= Empty + and then Nkind (Unit (Cunit (S))) = N_Subunit + then + Pnode := Library_Unit (Cunit (S)); + + -- In gnatc mode, the errors in the subunits will not + -- have been recorded, but the analysis of the subunit + -- may have failed. There is no information to add to + -- ALI file in this case. + + if No (Pnode) then + exit; + end if; + + -- Find ultimate parent of the subunit + + while Nkind (Unit (Pnode)) = N_Subunit loop + Pnode := Library_Unit (Pnode); + end loop; + + -- See if it belongs to current unit, and if so, include + -- its with_clauses. + + if Pnode = Unode then + Collect_Withs (Cunit (S)); + end if; + end if; + end loop; + end if; + + Write_With_Lines; + + -- Output linker option lines + + for J in 1 .. Linker_Option_Lines.Last loop + declare + S : Linker_Option_Entry renames Linker_Option_Lines.Table (J); + begin + if S.Unit = Unit_Num then + Write_Info_Initiate ('L'); + Write_Info_Char (' '); + Write_Info_Slit (S.Option); + Write_Info_EOL; + end if; + end; + end loop; + + -- Output notes + + for J in 1 .. Notes.Last loop + declare + N : constant Node_Id := Notes.Table (J).Pragma_Node; + L : constant Source_Ptr := Sloc (N); + U : constant Unit_Number_Type := Notes.Table (J).Unit; + C : Character; + + begin + if U = Unit_Num then + Write_Info_Initiate ('N'); + Write_Info_Char (' '); + + case Chars (Pragma_Identifier (N)) is + when Name_Annotate => + C := 'A'; + when Name_Comment => + C := 'C'; + when Name_Ident => + C := 'I'; + when Name_Title => + C := 'T'; + when Name_Subtitle => + C := 'S'; + when others => + raise Program_Error; + end case; + + Write_Info_Char (C); + Write_Info_Int (Int (Get_Logical_Line_Number (L))); + Write_Info_Char (':'); + Write_Info_Int (Int (Get_Column_Number (L))); + + declare + A : Node_Id; + + begin + A := First (Pragma_Argument_Associations (N)); + while Present (A) loop + Write_Info_Char (' '); + + if Chars (A) /= No_Name then + Write_Info_Name (Chars (A)); + Write_Info_Char (':'); + end if; + + declare + Expr : constant Node_Id := Expression (A); + + begin + if Nkind (Expr) = N_Identifier then + Write_Info_Name (Chars (Expr)); + + elsif Nkind (Expr) = N_Integer_Literal + and then Is_Static_Expression (Expr) + then + Write_Info_Uint (Intval (Expr)); + + elsif Nkind (Expr) = N_String_Literal + and then Is_Static_Expression (Expr) + then + Write_Info_Slit (Strval (Expr)); + + else + Write_Info_Str (""); + end if; + end; + + Next (A); + end loop; + end; + + Write_Info_EOL; + end if; + end; + end loop; + end Write_Unit_Information; + + ---------------------- + -- Write_With_Lines -- + ---------------------- + + procedure Write_With_Lines is + With_Table : Unit_Ref_Table (1 .. Pos (Last_Unit - Units.First + 1)); + Num_Withs : Int := 0; + Unum : Unit_Number_Type; + Cunit : Node_Id; + Uname : Unit_Name_Type; + Fname : File_Name_Type; + Pname : constant Unit_Name_Type := + Get_Parent_Spec_Name (Unit_Name (Main_Unit)); + Body_Fname : File_Name_Type; + Body_Index : Nat; + + procedure Write_With_File_Names + (Nam : in out File_Name_Type; + Idx : Nat); + -- Write source file name Nam and ALI file name for unit index Idx. + -- Possibly change Nam to lowercase (generating a new file name). + + -------------------------- + -- Write_With_File_Name -- + -------------------------- + + procedure Write_With_File_Names + (Nam : in out File_Name_Type; + Idx : Nat) + is + begin + if not File_Names_Case_Sensitive then + Get_Name_String (Nam); + To_Lower (Name_Buffer (1 .. Name_Len)); + Nam := Name_Find; + end if; + + Write_Info_Name (Nam); + Write_Info_Tab (49); + Write_Info_Name (Lib_File_Name (Nam, Idx)); + end Write_With_File_Names; + + -- Start of processing for Write_With_Lines + + begin + -- Loop to build the with table. A with on the main unit itself + -- is ignored (AARM 10.2(14a)). Such a with-clause can occur if + -- the main unit is a subprogram with no spec, and a subunit of + -- it unnecessarily withs the parent. + + for J in Units.First + 1 .. Last_Unit loop + + -- Add element to with table if it is with'ed or if it is the + -- parent spec of the main unit (case of main unit is a child + -- unit). The latter with is not needed for semantic purposes, + -- but is required by the binder for elaboration purposes. + -- For preproc. data and def. files, there is no Unit_Name, + -- check for that first. + + if Unit_Name (J) /= No_Unit_Name + and then (With_Flags (J) or else Unit_Name (J) = Pname) + then + Num_Withs := Num_Withs + 1; + With_Table (Num_Withs) := J; + end if; + end loop; + + -- Sort and output the table + + Sort (With_Table (1 .. Num_Withs)); + + for J in 1 .. Num_Withs loop + Unum := With_Table (J); + Cunit := Units.Table (Unum).Cunit; + Uname := Units.Table (Unum).Unit_Name; + Fname := Units.Table (Unum).Unit_File_Name; + + if Ekind (Cunit_Entity (Unum)) = E_Package + and then From_With_Type (Cunit_Entity (Unum)) + then + Write_Info_Initiate ('Y'); + else + Write_Info_Initiate ('W'); + end if; + + Write_Info_Char (' '); + Write_Info_Name (Uname); + + -- Now we need to figure out the names of the files that contain + -- the with'ed unit. These will usually be the files for the body, + -- except in the case of a package that has no body. Note that we + -- have a specific exemption here for predefined library generics + -- (see comments for Generic_May_Lack_ALI). We do not generate + -- dependency upon the ALI file for such units. Older compilers + -- used to not support generating code (and ALI) for generics, and + -- we want to avoid having different processing (namely, different + -- lists of files to be compiled) for different stages of the + -- bootstrap. + + if not ((Nkind (Unit (Cunit)) in N_Generic_Declaration + or else + Nkind (Unit (Cunit)) in N_Generic_Renaming_Declaration) + and then Generic_May_Lack_ALI (Fname)) + then + Write_Info_Tab (25); + + if Is_Spec_Name (Uname) then + Body_Fname := + Get_File_Name + (Get_Body_Name (Uname), + Subunit => False, May_Fail => True); + + Body_Index := + Get_Unit_Index + (Get_Body_Name (Uname)); + + if Body_Fname = No_File then + Body_Fname := Get_File_Name (Uname, Subunit => False); + Body_Index := Get_Unit_Index (Uname); + end if; + + else + Body_Fname := Get_File_Name (Uname, Subunit => False); + Body_Index := Get_Unit_Index (Uname); + end if; + + -- A package is considered to have a body if it requires + -- a body or if a body is present in Ada 83 mode. + + if Body_Required (Cunit) + or else (Ada_Version = Ada_83 + and then Full_Source_Name (Body_Fname) /= No_File) + then + Write_With_File_Names (Body_Fname, Body_Index); + else + Write_With_File_Names (Fname, Munit_Index (Unum)); + end if; + + if Ekind (Cunit_Entity (Unum)) = E_Package + and then From_With_Type (Cunit_Entity (Unum)) + then + null; + else + if Elab_Flags (Unum) then + Write_Info_Str (" E"); + end if; + + if Elab_All_Flags (Unum) then + Write_Info_Str (" EA"); + end if; + + if Elab_Des_Flags (Unum) then + Write_Info_Str (" ED"); + end if; + + if Elab_All_Des_Flags (Unum) then + Write_Info_Str (" AD"); + end if; + end if; + end if; + + Write_Info_EOL; + end loop; + end Write_With_Lines; + + -- Start of processing for Write_ALI + + begin + -- We never write an ALI file if the original operating mode was + -- syntax-only (-gnats switch used in compiler invocation line) + + if Original_Operating_Mode = Check_Syntax + or flag_compare_debug /= 0 + then + return; + end if; + + -- Build sorted source dependency table. We do this right away, because + -- it is referenced by Up_To_Date_ALI_File_Exists. + + for Unum in Units.First .. Last_Unit loop + if Cunit_Entity (Unum) = Empty + or else not From_With_Type (Cunit_Entity (Unum)) + then + Num_Sdep := Num_Sdep + 1; + Sdep_Table (Num_Sdep) := Unum; + end if; + end loop; + + -- Sort the table so that the D lines are in order + + Lib.Sort (Sdep_Table (1 .. Num_Sdep)); + + -- If we are not generating code, and there is an up to date ALI file + -- file accessible, read it, and acquire the compilation arguments from + -- this file. + + if Operating_Mode /= Generate_Code then + if Up_To_Date_ALI_File_Exists then + Update_Tables_From_ALI_File; + return; + end if; + end if; + + -- Otherwise acquire compilation arguments and prepare to write + -- out a new ali file. + + Create_Output_Library_Info; + + -- Output version line + + Write_Info_Initiate ('V'); + Write_Info_Str (" """); + Write_Info_Str (Verbose_Library_Version); + Write_Info_Char ('"'); + + Write_Info_EOL; + + -- Output main program line if this is acceptable main program + + Output_Main_Program_Line : declare + U : Node_Id := Unit (Units.Table (Main_Unit).Cunit); + S : Node_Id; + + procedure M_Parameters; + -- Output parameters for main program line + + ------------------ + -- M_Parameters -- + ------------------ + + procedure M_Parameters is + begin + if Main_Priority (Main_Unit) /= Default_Main_Priority then + Write_Info_Char (' '); + Write_Info_Nat (Main_Priority (Main_Unit)); + end if; + + if Opt.Time_Slice_Set then + Write_Info_Str (" T="); + Write_Info_Nat (Opt.Time_Slice_Value); + end if; + + if Has_Allocator (Main_Unit) then + Write_Info_Str (" AB"); + end if; + + if Main_CPU (Main_Unit) /= Default_Main_CPU then + Write_Info_Str (" C="); + Write_Info_Nat (Main_CPU (Main_Unit)); + end if; + + Write_Info_Str (" W="); + Write_Info_Char + (WC_Encoding_Letters (Wide_Character_Encoding_Method)); + + Write_Info_EOL; + end M_Parameters; + + -- Start of processing for Output_Main_Program_Line + + begin + if Nkind (U) = N_Subprogram_Body + or else + (Nkind (U) = N_Package_Body + and then + Nkind (Original_Node (U)) in N_Subprogram_Instantiation) + then + -- If the unit is a subprogram instance, the entity for the + -- subprogram is the alias of the visible entity, which is the + -- related instance of the wrapper package. We retrieve the + -- subprogram declaration of the desired entity. + + if Nkind (U) = N_Package_Body then + U := Parent (Parent ( + Alias (Related_Instance (Defining_Unit_Name + (Specification (Unit (Library_Unit (Parent (U))))))))); + end if; + + S := Specification (U); + + if No (Parameter_Specifications (S)) then + if Nkind (S) = N_Procedure_Specification then + Write_Info_Initiate ('M'); + Write_Info_Str (" P"); + M_Parameters; + + else + declare + Nam : Node_Id := Defining_Unit_Name (S); + + begin + -- If it is a child unit, get its simple name + + if Nkind (Nam) = N_Defining_Program_Unit_Name then + Nam := Defining_Identifier (Nam); + end if; + + if Is_Integer_Type (Etype (Nam)) then + Write_Info_Initiate ('M'); + Write_Info_Str (" F"); + M_Parameters; + end if; + end; + end if; + end if; + end if; + end Output_Main_Program_Line; + + -- Write command argument ('A') lines + + for A in 1 .. Compilation_Switches.Last loop + Write_Info_Initiate ('A'); + Write_Info_Char (' '); + Write_Info_Str (Compilation_Switches.Table (A).all); + Write_Info_Terminate; + end loop; + + -- Output parameters ('P') line + + Write_Info_Initiate ('P'); + + if Compilation_Errors then + Write_Info_Str (" CE"); + end if; + + if Opt.Detect_Blocking then + Write_Info_Str (" DB"); + end if; + + if Opt.Float_Format /= ' ' then + Write_Info_Str (" F"); + + if Opt.Float_Format = 'I' then + Write_Info_Char ('I'); + + elsif Opt.Float_Format_Long = 'D' then + Write_Info_Char ('D'); + + else + Write_Info_Char ('G'); + end if; + end if; + + if Tasking_Used + and then not Is_Predefined_File_Name (Unit_File_Name (Main_Unit)) + then + if Locking_Policy /= ' ' then + Write_Info_Str (" L"); + Write_Info_Char (Locking_Policy); + end if; + + if Queuing_Policy /= ' ' then + Write_Info_Str (" Q"); + Write_Info_Char (Queuing_Policy); + end if; + + if Task_Dispatching_Policy /= ' ' then + Write_Info_Str (" T"); + Write_Info_Char (Task_Dispatching_Policy); + Write_Info_Char (' '); + end if; + end if; + + if not Object then + Write_Info_Str (" NO"); + end if; + + if No_Run_Time_Mode then + Write_Info_Str (" NR"); + end if; + + if Normalize_Scalars then + Write_Info_Str (" NS"); + end if; + + if Sec_Stack_Used then + Write_Info_Str (" SS"); + end if; + + if Unreserve_All_Interrupts then + Write_Info_Str (" UA"); + end if; + + if Exception_Mechanism = Back_End_Exceptions then + Write_Info_Str (" ZX"); + end if; + + Write_Info_EOL; + + -- Before outputting the restrictions line, update the setting of + -- the No_Elaboration_Code flag. Violations of this restriction + -- cannot be detected until after the backend has been called since + -- it is the backend that sets this flag. We have to check all units + -- for which we have generated code + + for Unit in Units.First .. Last_Unit loop + if Units.Table (Unit).Generate_Code + or else Unit = Main_Unit + then + if not Has_No_Elaboration_Code (Cunit (Unit)) then + Main_Restrictions.Violated (No_Elaboration_Code) := True; + end if; + end if; + end loop; + + -- Output first restrictions line + + Write_Info_Initiate ('R'); + Write_Info_Char (' '); + + -- First the information for the boolean restrictions + + for R in All_Boolean_Restrictions loop + if Main_Restrictions.Set (R) + and then not Restriction_Warnings (R) + then + Write_Info_Char ('r'); + elsif Main_Restrictions.Violated (R) then + Write_Info_Char ('v'); + else + Write_Info_Char ('n'); + end if; + end loop; + + -- And now the information for the parameter restrictions + + for RP in All_Parameter_Restrictions loop + if Main_Restrictions.Set (RP) + and then not Restriction_Warnings (RP) + then + Write_Info_Char ('r'); + Write_Info_Nat (Nat (Main_Restrictions.Value (RP))); + else + Write_Info_Char ('n'); + end if; + + if not Main_Restrictions.Violated (RP) + or else RP not in Checked_Parameter_Restrictions + then + Write_Info_Char ('n'); + else + Write_Info_Char ('v'); + Write_Info_Nat (Nat (Main_Restrictions.Count (RP))); + + if Main_Restrictions.Unknown (RP) then + Write_Info_Char ('+'); + end if; + end if; + end loop; + + Write_Info_EOL; + + -- Output R lines for No_Dependence entries + + for J in No_Dependence.First .. No_Dependence.Last loop + if In_Extended_Main_Source_Unit (No_Dependence.Table (J).Unit) + and then not No_Dependence.Table (J).Warn + then + Write_Info_Initiate ('R'); + Write_Info_Char (' '); + Write_Unit_Name (No_Dependence.Table (J).Unit); + Write_Info_EOL; + end if; + end loop; + + -- Output interrupt state lines + + for J in Interrupt_States.First .. Interrupt_States.Last loop + Write_Info_Initiate ('I'); + Write_Info_Char (' '); + Write_Info_Nat (Interrupt_States.Table (J).Interrupt_Number); + Write_Info_Char (' '); + Write_Info_Char (Interrupt_States.Table (J).Interrupt_State); + Write_Info_Char (' '); + Write_Info_Nat + (Nat (Get_Logical_Line_Number + (Interrupt_States.Table (J).Pragma_Loc))); + Write_Info_EOL; + end loop; + + -- Output priority specific dispatching lines + + for J in Specific_Dispatching.First .. Specific_Dispatching.Last loop + Write_Info_Initiate ('S'); + Write_Info_Char (' '); + Write_Info_Char (Specific_Dispatching.Table (J).Dispatching_Policy); + Write_Info_Char (' '); + Write_Info_Nat (Specific_Dispatching.Table (J).First_Priority); + Write_Info_Char (' '); + Write_Info_Nat (Specific_Dispatching.Table (J).Last_Priority); + Write_Info_Char (' '); + Write_Info_Nat + (Nat (Get_Logical_Line_Number + (Specific_Dispatching.Table (J).Pragma_Loc))); + Write_Info_EOL; + end loop; + + -- Loop through file table to output information for all units for which + -- we have generated code, as marked by the Generate_Code flag. + + for Unit in Units.First .. Last_Unit loop + if Units.Table (Unit).Generate_Code + or else Unit = Main_Unit + then + Write_Info_EOL; -- blank line + Write_Unit_Information (Unit); + end if; + end loop; + + Write_Info_EOL; -- blank line + + -- Output external version reference lines + + for J in 1 .. Version_Ref.Last loop + Write_Info_Initiate ('E'); + Write_Info_Char (' '); + + for K in 1 .. String_Length (Version_Ref.Table (J)) loop + Write_Info_Char_Code (Get_String_Char (Version_Ref.Table (J), K)); + end loop; + + Write_Info_EOL; + end loop; + + -- Prepare to output the source dependency lines + + declare + Unum : Unit_Number_Type; + -- Number of unit being output + + Sind : Source_File_Index; + -- Index of corresponding source file + + Fname : File_Name_Type; + + begin + for J in 1 .. Num_Sdep loop + Unum := Sdep_Table (J); + Units.Table (Unum).Dependency_Num := J; + Sind := Units.Table (Unum).Source_Index; + + Write_Info_Initiate ('D'); + Write_Info_Char (' '); + + -- Normal case of a unit entry with a source index + + if Sind /= No_Source_File then + Fname := File_Name (Sind); + + -- Ensure that on platforms where the file names are not + -- case sensitive, the recorded file name is in lower case. + + if not File_Names_Case_Sensitive then + Get_Name_String (Fname); + To_Lower (Name_Buffer (1 .. Name_Len)); + Fname := Name_Find; + end if; + + Write_Info_Name (Fname); + Write_Info_Tab (25); + Write_Info_Str (String (Time_Stamp (Sind))); + Write_Info_Char (' '); + Write_Info_Str (Get_Hex_String (Source_Checksum (Sind))); + + -- If subunit, add unit name, omitting the %b at the end + + if Present (Cunit (Unum)) + and then Nkind (Unit (Cunit (Unum))) = N_Subunit + then + Get_Decoded_Name_String (Unit_Name (Unum)); + Write_Info_Char (' '); + Write_Info_Str (Name_Buffer (1 .. Name_Len - 2)); + end if; + + -- If Source_Reference pragma used output information + + if Num_SRef_Pragmas (Sind) > 0 then + Write_Info_Char (' '); + + if Num_SRef_Pragmas (Sind) = 1 then + Write_Info_Nat (Int (First_Mapped_Line (Sind))); + else + Write_Info_Nat (0); + end if; + + Write_Info_Char (':'); + Write_Info_Name (Reference_Name (Sind)); + end if; + + -- Case where there is no source index (happens for missing + -- files). In this case we write a dummy time stamp. + + else + Write_Info_Name (Unit_File_Name (Unum)); + Write_Info_Tab (25); + Write_Info_Str (String (Dummy_Time_Stamp)); + Write_Info_Char (' '); + Write_Info_Str (Get_Hex_String (0)); + end if; + + Write_Info_EOL; + end loop; + end; + + -- Output cross-references + + Output_References; + + -- Output SCO information if present + + if Generate_SCO then + SCO_Output; + end if; + + -- Output final blank line and we are done. This final blank line is + -- probably junk, but we don't feel like making an incompatible change! + + Write_Info_Terminate; + Close_Output_Library_Info; + end Write_ALI; + + --------------------- + -- Write_Unit_Name -- + --------------------- + + procedure Write_Unit_Name (N : Node_Id) is + begin + if Nkind (N) = N_Identifier then + Write_Info_Name (Chars (N)); + + else + pragma Assert (Nkind (N) = N_Selected_Component); + Write_Unit_Name (Prefix (N)); + Write_Info_Char ('.'); + Write_Unit_Name (Selector_Name (N)); + end if; + end Write_Unit_Name; + +end Lib.Writ; diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads new file mode 100644 index 000000000..ef5f23a9e --- /dev/null +++ b/gcc/ada/lib-writ.ads @@ -0,0 +1,794 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B . W R I T -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 writing the library information + +package Lib.Writ is + + ----------------------------------- + -- Format of Library Information -- + ----------------------------------- + + -- This section describes the format of the library information that is + -- associated with object files. The exact method of this association is + -- potentially implementation dependent and is described and implemented in + -- package ali. From the point of view of the description here, all we need + -- to know is that the information is represented as a string of characters + -- that is somehow associated with an object file, and can be retrieved. If + -- no library information exists for a given object file, then we take this + -- as equivalent to the non-existence of the object file, as if source file + -- has not been previously compiled. + + -- The library information is written as a series of lines of the form: + + -- Key_Character parameter parameter ... + + -- The following sections describe the format of these lines in detail + + -------------------------------------- + -- Making Changes to the ALI Format -- + -------------------------------------- + + -- A number of tools use ali.adb to parse ali files. This means that + -- changes to this format can cause old versions of these tools to be + -- incompatible with new versions of the compiler. Any changes to ali file + -- formats must be carefully evaluated to understand any such possible + -- conflicts, and in particular, it is very undesirable to create conflicts + -- between older versions of GPS and newer versions of the compiler. + + -- If the following guidelines are respected, downward compatibility + -- problems (old tools reading new ali files) should be minimized: + + -- The basic key character format must be kept + + -- The V line must be the first line, this is checked by ali.adb even in + -- Ignore_Errors mode, and is used to verify that the file at hand is + -- indeed likely intended to be an ali file. + + -- The P line must be present, though may be modified in contents + -- according to remaining guidelines. Again, ali.adb assumes the P + -- line is present even in Ignore_Errors mode. + + -- New modifiers can generally be added (in particular adding new two + -- letter modifiers to the P or U lines is always safe) + + -- Adding entirely new lines (with a new key letter) to the ali file is + -- always safe, at any point (other than before the V line), since such + -- lines will be ignored. + + -- Following the guidelines in this section should ensure that this problem + -- is minimized and that old tools will be able to deal successfully with + -- new ali formats. Note that this does not apply to the compiler itself, + -- which always requires consistency between the ali files and the binder. + -- That is because one of the main functions of the binder is to ensure + -- consistency of the partition, and this can be compromised if the ali + -- files are inconsistent. + + ------------------ + -- Header Lines -- + ------------------ + + -- The initial header lines in the file give information about the + -- compilation environment, and identify other special information such as + -- main program parameters. + + -- ---------------- + -- -- V Version -- + -- ---------------- + + -- V "xxxxxxxxxxxxxxxx" + -- + -- This line indicates the library output version, as defined in + -- Gnatvsn. It ensures that separate object modules of a program are + -- consistent. It has to be changed if anything changes which would + -- affect successful binding of separately compiled modules. Examples + -- of such changes are modifications in the format of the library info + -- described in this package, or modifications to calling sequences, or + -- to the way that data is represented. + + -- Note: the V line absolutely must be the first line, and no change + -- to the ALI format should change this, since even in Ignore_Errors + -- mode, Scan_ALI insists on finding a V line. + + -- --------------------- + -- -- M Main Program -- + -- --------------------- + + -- M type [priority] [T=time-slice] [AB] [C=cpu] W=? + + -- This line appears only if the main unit for this file is suitable + -- for use as a main program. The parameters are: + + -- type + + -- P for a parameterless procedure + -- F for a function returning a value of integral type + -- (used for writing a main program returning an exit status) + + -- priority + + -- Present only if there was a valid pragma Priority in the + -- corresponding unit to set the main task priority. It is an + -- unsigned decimal integer. + + -- T=time-slice + + -- Present only if there was a valid pragma Time_Slice in the + -- corresponding unit. It is an unsigned decimal integer in the + -- range 0 .. 10**9 giving the time slice value in units of + -- milliseconds. The actual significance of this parameter is + -- target dependent. + + -- AB + + -- Present if there is an allocator in the body of the procedure + -- after the BEGIN. This will be a violation of the restriction + -- No_Allocators_After_Elaboration if it is present, and this + -- unit is used as a main program (only the binder can find the + -- violation, since only the binder knows the main program). + + -- C=cpu + + -- Present only if there was a valid pragma CPU in the + -- corresponding unit to set the main task affinity. It is an + -- unsigned decimal integer. + + -- W=? + + -- This parameter indicates the wide character encoding method used + -- when compiling the main program file. The ? character is the + -- single character used in the -gnatW? switch. This is used to + -- provide the default wide-character encoding for Wide_Text_IO + -- files. + + -- ----------------- + -- -- A Argument -- + -- ----------------- + + -- A argument + + -- One of these lines appears for each of the arguments present in the + -- call to the gnat1 program. This can be used if it is necessary to + -- reconstruct this call (e.g. for fix and continue). + + -- ------------------- + -- -- P Parameters -- + -- ------------------- + + -- P <> + + -- Indicates various information that applies to the compilation of the + -- corresponding source file. Parameters is a sequence of zero or more + -- two letter codes that indicate configuration pragmas and other + -- parameters that apply: + -- + -- The arguments are as follows: + -- + -- CE Compilation errors. If this is present it means that the ali + -- file resulted from a compilation with the -gnatQ switch set, + -- and illegalities were detected. The ali file contents may + -- not be completely reliable, but the format will be correct + -- and complete. Note that NO is always present if CE is + -- present. + -- + -- DB Detect_Blocking pragma is in effect for all units in this + -- file. + -- + -- FD Configuration pragmas apply to all the units in this file + -- specifying a possibly non-standard floating point format + -- (VAX float with Long_Float using D_Float). + -- + -- FG Configuration pragmas apply to all the units in this file + -- specifying a possibly non-standard floating point format + -- (VAX float with Long_Float using G_Float). + -- + -- FI Configuration pragmas apply to all the units in this file + -- specifying a possibly non-standard floating point format + -- (IEEE Float). + -- + -- Lx A valid Locking_Policy pragma applies to all the units in + -- this file, where x is the first character (upper case) of + -- the policy name (e.g. 'C' for Ceiling_Locking). + -- + -- NO No object. This flag indicates that the units in this file + -- were not compiled to produce an object. This can occur as a + -- result of the use of -gnatc, or if no object can be produced + -- (e.g. when a package spec is compiled instead of the body, + -- or a subunit on its own). + -- + -- NR No_Run_Time. Indicates that a pragma No_Run_Time applies + -- to all units in the file. + -- + -- NS Normalize_Scalars pragma in effect for all units in + -- this file. + -- + -- Qx A valid Queueing_Policy pragma applies to all the units + -- in this file, where x is the first character (upper case) + -- of the policy name (e.g. 'P' for Priority_Queueing). + -- + -- SL Indicates that the unit is an Interface to a Standalone + -- Library. Note that this indication is never given by the + -- compiler, but is added by the Project Manager in gnatmake + -- when an Interface ALI file is copied to the library + -- directory. + + -- SS This unit references System.Secondary_Stack (that is, + -- the unit makes use of the secondary stack facilities). + -- + -- Tx A valid Task_Dispatching_Policy pragma applies to all + -- the units in this file, where x is the first character + -- (upper case) of the corresponding policy name (e.g. 'F' + -- for FIFO_Within_Priorities). + -- + -- UA Unreserve_All_Interrupts pragma was processed in one or + -- more units in this file + -- + -- ZX Units in this file use zero-cost exceptions and have + -- generated exception tables. If ZX is not present, the + -- longjmp/setjmp exception scheme is in use. + -- + -- Note that language defined units never output policy (Lx, Tx, Qx) + -- parameters. Language defined units must correctly handle all + -- possible cases. These values are checked for consistency by the + -- binder and then copied to the generated binder output file. + + -- Note: The P line must be present. Even in Ignore_Errors mode, Scan_ALI + -- insists on finding a P line. So if changes are made to the ALI format, + -- they should not include removing the P line! + + -- --------------------- + -- -- R Restrictions -- + -- --------------------- + + -- The first R line records the status of restrictions generated by pragma + -- Restrictions encountered, as well as information on what the compiler + -- has been able to determine with respect to restrictions violations. + -- The format is: + + -- R <> <> + + -- The first parameter is a string of characters that records + -- information regarding restrictions that do not take parameter not + -- take parameter values. It is a string of characters, one character + -- for each value (in order) in All_Boolean_Restrictions. There are + -- three possible settings for each restriction: + + -- r Restricted. Unit was compiled under control of a pragma + -- Restrictions for the corresponding restriction. In this case + -- the unit certainly does not violate the Restriction, since + -- this would have been detected by the compiler. + + -- n Not used. The unit was not compiled under control of a pragma + -- Restrictions for the corresponding restriction, and does not + -- make any use of the referenced feature. + + -- v Violated. The unit was not compiled under control of a pragma + -- Restrictions for the corresponding restriction, and it does + -- indeed use the referenced feature. + + -- This information is used in the binder to check consistency, i.e. to + -- detect cases where one unit has "r" and another unit has "v", which + -- is not permitted, since these restrictions are partition-wide. + + -- The second parameter, which immediately follows the first (with no + -- separating space) gives restriction information for identifiers for + -- which a parameter is given. + + -- The parameter is a string of entries, one for each value in + -- Restrict.All_Parameter_Restrictions. Each entry has two components + -- in sequence, the first indicating whether or not there is a + -- restriction, and the second indicating whether or not the compiler + -- detected violations. In the boolean case it is not necessary to + -- separate these, since if a restriction is set, and violated, that is + -- an error. But in the parameter case, this is not true. For example, + -- we can have a unit with a pragma Restrictions (Max_Tasks => 4), + -- where the compiler can detect that there are exactly three tasks + -- declared. Both of these pieces of information must be passed to the + -- binder. The parameter of 4 is important in case the total number of + -- tasks in the partition is greater than 4. The parameter of 3 is + -- important in case some other unit has a restrictions pragma with + -- Max_Tasks=>2. + + -- The component for the presence of restriction has one of two + -- possible forms: + + -- n No pragma for this restriction is present in the set of units + -- for this ali file. + + -- rN At least one pragma for this restriction is present in the + -- set of units for this ali file. The value N is the minimum + -- parameter value encountered in any such pragma. N is in the + -- range of Integer (a value larger than N'Last causes the + -- pragma to be ignored). + + -- The component for the violation detection has one of three + -- possible forms: + + -- n No violations were detected by the compiler + + -- vN A violation was detected. N is either the maximum or total + -- count of violations (depending on the checking type) in all + -- the units represented by the ali file). Note that this + -- setting is only allowed for restrictions that are in + -- Checked_[Max|Sum]_Parameter_Restrictions. The value here is + -- known to be exact by the compiler and is in the range of + -- Natural. + + -- vN+ A violation was detected. The compiler cannot determine + -- the exact count of violations, but it is at least N. + + -- There are no spaces within the parameter string, so the entry + -- described above in the header of this section for Max_Tasks would + -- appear as the string r4v3. + + -- Note: The restrictions line is required to be present. Even in + -- Ignore_Errors mode, Scan_ALI expects to find an R line and will + -- signal a fatal error if it is missing. This means that future + -- changes to the ALI file format must retain the R line. + + -- Subsequent R lines are present only if pragma Restriction No_Dependence + -- is used. There is one such line for each such pragma appearing in the + -- extended main unit. The format is + + -- R unit_name + + -- Here the unit name is in all lower case. The components of the unit + -- name are separated by periods. The names themselves are in encoded + -- form, as documented in Namet. + + -- ------------------------- + -- -- I Interrupt States -- + -- ------------------------- + + -- I interrupt-number interrupt-state line-number + + -- This line records information from an Interrupt_State pragma. There + -- is one line for each separate pragma, and if no such pragmas are + -- used, then no I lines are present. + + -- The interrupt-number is an unsigned positive integer giving the + -- value of the interrupt as defined in Ada.Interrupts.Names. + + -- The interrupt-state is one of r/s/u for Runtime/System/User + + -- The line number is an unsigned decimal integer giving the line + -- number of the corresponding Interrupt_State pragma. This is used + -- in consistency messages. + + -- -------------------------------------- + -- -- S Priority Specific Dispatching -- + -- -------------------------------------- + + -- S policy_identifier first_priority last_priority line-number + + -- This line records information from a Priority_Specific_Dispatching + -- pragma. There is one line for each separate pragma, and if no such + -- pragmas are used, then no S lines are present. + + -- The policy_identifier is the first character (upper case) of the + -- corresponding policy name (e.g. 'F' for FIFO_Within_Priorities). + + -- The first_priority and last_priority fields define the range of + -- priorities to which the specified dispatching policy apply. + + -- The line number is an unsigned decimal integer giving the line + -- number of the corresponding Priority_Specific_Dispatching pragma. + -- This is used in consistency messages. + + ---------------------------- + -- Compilation Unit Lines -- + ---------------------------- + + -- Following these header lines, a set of information lines appears for + -- each compilation unit that appears in the corresponding object file. In + -- particular, when a package body or subprogram body is compiled, there + -- will be two sets of information, one for the spec and one for the body, + -- with the entry for the body appearing first. This is the only case in + -- which a single ALI file contains more than one unit (in particular note + -- that subunits do *not* count as compilation units for this purpose, and + -- generate no library information, since they are inlined). + + -- -------------------- + -- -- U Unit Header -- + -- -------------------- + + -- The lines for each compilation unit have the following form + + -- U unit-name source-name version <> + -- + -- This line identifies the unit to which this section of the library + -- information file applies. The first three parameters are the unit + -- name in internal format, as described in package Uname, and the name + -- of the source file containing the unit. + -- + -- Version is the version given as eight hexadecimal characters with + -- upper case letters. This value is the exclusive or of the source + -- checksums of the unit and all its semantically dependent units. + -- + -- The <> are a series of two letter codes indicating + -- information about the unit: + -- + -- BD Unit does not have pragma Elaborate_Body, but the elaboration + -- circuit has determined that it would be a good idea if this + -- pragma were present, since the body of the package contains + -- elaboration code that modifies one or more variables in the + -- visible part of the package. The binder will try, but does + -- not promise, to keep the elaboration of the body close to + -- the elaboration of the spec. + -- + -- DE Dynamic Elaboration. This unit was compiled with the dynamic + -- elaboration model, as set by either the -gnatE switch or + -- pragma Elaboration_Checks (Dynamic). + -- + -- EB Unit has pragma Elaborate_Body, or is a generic instance that + -- has a body. Set for instances because RM 12.3(20) requires + -- that the body be immediately elaborated after the spec (we + -- would normally do that anyway, because elaborate spec and + -- body together whenever possible, and for an instance it is + -- always possible; however setting EB ensures that this is done + -- even when using the -p gnatbind switch). + -- + -- EE Elaboration entity is present which must be set true when + -- the unit is elaborated. The name of the elaboration entity is + -- formed from the unit name in the usual way. If EE is present, + -- then this boolean must be set True as part of the elaboration + -- processing routine generated by the binder. Note that EE can + -- be set even if NE is set. This happens when the boolean is + -- needed solely for checking for the case of access before + -- elaboration. + -- + -- GE Unit is a generic declaration, or corresponding body + -- + -- IL Unit source uses a style with identifiers in all lower-case + -- IU (IL) or all upper case (IU). If the standard mixed-case usage + -- is detected, or the compiler cannot determine the style, then + -- no I parameter will appear. + -- + -- IS Initialize_Scalars pragma applies to this unit, or else there + -- is at least one use of the Invalid_Value attribute. + -- + -- KM Unit source uses a style with keywords in mixed case (KM) + -- KU or all upper case (KU). If the standard lower-case usage is + -- is detected, or the compiler cannot determine the style, then + -- no K parameter will appear. + -- + -- NE Unit has no elaboration routine. All subprogram bodies and + -- specs are in this category. Package bodies and specs may or + -- may not have NE set, depending on whether or not elaboration + -- code is required. Set if N_Compilation_Unit node has flag + -- Has_No_Elaboration_Code set. + -- + -- OL The units in this file are compiled with a local pragma + -- Optimize_Alignment, so no consistency requirement applies + -- to these units. All internal units have this status since + -- they have an automatic default of Optimize_Alignment (Off). + -- + -- OO Optimize_Alignment (Off) is the default setting for all + -- units in this file. All files in the partition that specify + -- a default must specify the same default. + -- + -- OS Optimize_Alignment (Space) is the default setting for all + -- units in this file. All files in the partition that specify + -- a default must specify the same default. + -- + -- OT Optimize_Alignment (Time) is the default setting for all + -- units in this file. All files in the partition that specify + -- a default must specify the same default. + -- + -- PK Unit is package, rather than a subprogram + -- + -- PU Unit has pragma Pure + -- + -- PR Unit has pragma Preelaborate + -- + -- RA Unit declares a Remote Access to Class-Wide (RACW) type + -- + -- RC Unit has pragma Remote_Call_Interface + -- + -- RT Unit has pragma Remote_Types + -- + -- SP Unit has pragma Shared_Passive. + -- + -- SU Unit is a subprogram, rather than a package + -- + -- The attributes may appear in any order, separated by spaces. + + -- --------------------- + -- -- W Withed Units -- + -- --------------------- + + -- Following each U line, is a series of lines of the form + + -- W unit-name [source-name lib-name] [E] [EA] [ED] [AD] + -- + -- One of these lines is present for each unit that is mentioned in an + -- explicit with clause by the current unit. The first parameter is the + -- unit name in internal format. The second parameter is the file name + -- of the file that must be compiled to compile this unit. It is + -- usually the file for the body, except for packages which have no + -- body. For units that need a body, if the source file for the body + -- cannot be found, the file name of the spec is used instead. The + -- third parameter is the file name of the library information file + -- that contains the results of compiling this unit. The optional + -- modifiers are used as follows: + -- + -- E pragma Elaborate applies to this unit + -- + -- EA pragma Elaborate_All applies to this unit + -- + -- ED Elaborate_Desirable set for this unit, which means that there + -- is no Elaborate, but the analysis suggests that Program_Error + -- may be raised if the Elaborate conditions cannot be satisfied. + -- The binder will attempt to treat ED as E if it can. + -- + -- AD Elaborate_All_Desirable set for this unit, which means that + -- there is no Elaborate_All, but the analysis suggests that + -- Program_Error may be raised if the Elaborate_All conditions + -- cannot be satisfied. The binder will attempt to treat AD as + -- EA if it can. + -- + -- The parameter source-name and lib-name are omitted for the case of a + -- generic unit compiled with earlier versions of GNAT which did not + -- generate object or ali files for generics. + + -- In fact W lines include implicit withs ??? + + -- ----------------------- + -- -- L Linker_Options -- + -- ----------------------- + + -- Following the W lines (if any, or the U line if not), are an optional + -- series of lines that indicates the usage of the pragma Linker_Options in + -- the associated unit. For each appearance of a pragma Linker_Options (or + -- Link_With) in the unit, a line is present with the form: + + -- L "string" + + -- where string is the string from the unit line enclosed in quotes. + -- Within the quotes the following can occur: + + -- c graphic characters in range 20-7E other than " or { + -- "" indicating a single " character + -- {hh} indicating a character whose code is hex hh (0-9,A-F) + -- {00} [ASCII.NUL] is used as a separator character + -- to separate multiple arguments of a single + -- Linker_Options pragma. + + -- For further details, see Stringt.Write_String_Table_Entry. Note that + -- wide characters in the form {hhhh} cannot be produced, since pragma + -- Linker_Option accepts only String, not Wide_String. + + -- The L lines are required to appear in the same order as the + -- corresponding Linker_Options (or Link_With) pragmas appear in the + -- source file, so that this order is preserved by the binder in + -- constructing the set of linker arguments. + + -- -------------- + -- -- N Notes -- + -- -------------- + + -- The final section of unit-specific lines contains notes which record + -- annotations inserted in source code for processing by external tools + -- using pragmas. For each occurrence of any of these pragmas, a line is + -- generated with the following syntax: + + -- N x [:] ... + + -- x is one of: + -- A pragma Annotate + -- C pragma Comment + -- I pragma Ident + -- T pragma Title + -- S pragma Subtitle + + -- is the source location of the pragma in line:col format + + -- Successive entries record the pragma_argument_associations. + + -- If a pragma argument identifier is present, the entry is prefixed + -- with the pragma argument identifier followed by a colon. + + -- represents the pragma argument, and has the following + -- conventions: + + -- - identifiers are output verbatim + -- - static string expressions are output as literals encoded as + -- for L lines + -- - static integer expressions are output as decimal literals + -- - any other expression is replaced by the placeholder "" + + --------------------- + -- Reference Lines -- + --------------------- + + -- The reference lines contain information about references from any of the + -- units in the compilation (including body version and version attributes, + -- linker options pragmas and source dependencies). + + -- ------------------------------------ + -- -- E External Version References -- + -- ------------------------------------ + + -- One of these lines is present for each use of 'Body_Version or 'Version + -- in any of the units of the compilation. These are used by the linker to + -- determine which version symbols must be output. The format is simply: + + -- E name + + -- where name is the external name, i.e. the unit name with either a S or a + -- B for spec or body version referenced (Body_Version always references + -- the body, Version references the Spec, except in the case of a reference + -- to a subprogram with no separate spec). Upper half and wide character + -- codes are encoded using the same method as in Namet (Uhh for upper half, + -- Whhhh for wide character, where hh are hex digits). + + -- --------------------- + -- -- D Dependencies -- + -- --------------------- + + -- The dependency lines indicate the source files on which the compiled + -- units depend. This is used by the binder for consistency checking. + -- These lines are also referenced by the cross-reference information. + + -- D source-name time-stamp checksum [subunit-name] line:file-name + + -- The time-stamp field contains the time stamp of the corresponding + -- source file. See types.ads for details on time stamp representation. + + -- The checksum is an 8-hex digit representation of the source file + -- checksum, with letters given in lower case. + + -- The subunit name is present only if the dependency line is for a + -- subunit. It contains the fully qualified name of the subunit in all + -- lower case letters. + + -- The line:file-name entry is present only if a Source_Reference + -- pragma appeared in the source file identified by source-name. In + -- this case, it gives the information from this pragma. Note that this + -- allows cross-reference information to be related back to the + -- original file. Note: the reason the line number comes first is that + -- a leading digit immediately identifies this as a Source_Reference + -- entry, rather than a subunit-name. + + -- A line number of zero for line: in this entry indicates that there + -- is more than one source reference pragma. In this case, the line + -- numbers in the cross-reference are correct, and refer to the + -- original line number, but there is no information that allows a + -- reader of the ALI file to determine the exact mapping of physical + -- line numbers back to the original source. + + -- Files with a zero checksum and a non-zero time stamp are in general + -- files on which the compilation depends but which are not Ada files + -- with further dependencies. This includes preprocessor data files + -- and preprocessor definition files. + + -- Note: blank lines are ignored when the library information is read, + -- and separate sections of the file are separated by blank lines to + -- ease readability. Blanks between fields are also ignored. + + -- For entries corresponding to files that were not present (and thus + -- resulted in error messages), or for files that are not part of the + -- dependency set, both the time stamp and checksum are set to all zero + -- characters. These dummy entries are ignored by the binder in + -- dependency checking, but must be present for proper interpretation + -- of the cross-reference data. + + -------------------------- + -- Cross-Reference Data -- + -------------------------- + + -- The cross-reference data follows the dependency lines. See the spec of + -- Lib.Xref for details on the format of this data. + + --------------------------------- + -- Source Coverage Obligations -- + --------------------------------- + + -- The Source Coverage Obligation (SCO) information follows the cross- + -- reference data. See the spec of Par_SCO for full details of the format. + + ---------------------- + -- Global Variables -- + ---------------------- + + -- The table defined here stores one entry for each Interrupt_State pragma + -- encountered either in the main source or in an ancillary with'ed source. + -- Since interrupt state values have to be consistent across all units in a + -- partition, we detect inconsistencies at compile time when we can. + + type Interrupt_State_Entry is record + Interrupt_Number : Pos; + -- Interrupt number value + + Interrupt_State : Character; + -- Set to r/s/u for Runtime/System/User + + Pragma_Loc : Source_Ptr; + -- Location of pragma setting this value in place + end record; + + package Interrupt_States is new Table.Table ( + Table_Component_Type => Interrupt_State_Entry, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 30, + Table_Increment => 200, + Table_Name => "Name_Interrupt_States"); + + -- The table structure defined here stores one entry for each + -- Priority_Specific_Dispatching pragma encountered either in the main + -- source or in an ancillary with'ed source. Since have to be consistent + -- across all units in a partition, we may as well detect inconsistencies + -- at compile time when we can. + + type Specific_Dispatching_Entry is record + Dispatching_Policy : Character; + -- First character (upper case) of the corresponding policy name + + First_Priority : Nat; + -- Lower bound of the priority range to which the specified dispatching + -- policy applies. + + Last_Priority : Nat; + -- Upper bound of the priority range to which the specified dispatching + -- policy applies. + + Pragma_Loc : Source_Ptr; + -- Location of pragma setting this value in place + end record; + + package Specific_Dispatching is new Table.Table ( + Table_Component_Type => Specific_Dispatching_Entry, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Name_Priority_Specific_Dispatching"); + + ----------------- + -- Subprograms -- + ----------------- + + procedure Ensure_System_Dependency; + -- This procedure ensures that a dependency is created on system.ads. Even + -- if there is no semantic dependency, Targparm has read the file to + -- acquire target parameters, so we need a source dependency. + + procedure Write_ALI (Object : Boolean); + -- This procedure writes the library information for the current main unit + -- The Object parameter is true if an object file is created, and false + -- otherwise. + -- + -- Note: in the case where we are not generating code (-gnatc mode), this + -- routine only writes an ALI file if it cannot find an existing up to + -- date ALI file. If it *can* find an existing up to date ALI file, then + -- it reads this file and sets the Lib.Compilation_Arguments table from + -- the A lines in this file. + + procedure Add_Preprocessing_Dependency (S : Source_File_Index); + -- Indicate that there is a dependency to be added on a preprocessing data + -- file or on a preprocessing definition file. + +end Lib.Writ; diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb new file mode 100644 index 000000000..81b724103 --- /dev/null +++ b/gcc/ada/lib-xref.adb @@ -0,0 +1,2245 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B . X R E F -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Csets; use Csets; +with Elists; use Elists; +with Errout; use Errout; +with Lib.Util; use Lib.Util; +with Nlists; use Nlists; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Prag; use Sem_Prag; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with Stringt; use Stringt; +with Stand; use Stand; +with Table; use Table; +with Widechar; use Widechar; + +with GNAT.Heap_Sort_G; + +package body Lib.Xref is + + ------------------ + -- Declarations -- + ------------------ + + -- The Xref table is used to record references. The Loc field is set + -- to No_Location for a definition entry. + + subtype Xref_Entry_Number is Int; + + type Xref_Entry is record + Ent : Entity_Id; + -- Entity referenced (E parameter to Generate_Reference) + + Def : Source_Ptr; + -- Original source location for entity being referenced. Note that these + -- values are used only during the output process, they are not set when + -- the entries are originally built. This is because private entities + -- can be swapped when the initial call is made. + + Loc : Source_Ptr; + -- Location of reference (Original_Location (Sloc field of N parameter + -- to Generate_Reference). Set to No_Location for the case of a + -- defining occurrence. + + Typ : Character; + -- Reference type (Typ param to Generate_Reference) + + Eun : Unit_Number_Type; + -- Unit number corresponding to Ent + + Lun : Unit_Number_Type; + -- Unit number corresponding to Loc. Value is undefined and not + -- referenced if Loc is set to No_Location. + + end record; + + package Xrefs is new Table.Table ( + Table_Component_Type => Xref_Entry, + Table_Index_Type => Xref_Entry_Number, + Table_Low_Bound => 1, + Table_Initial => Alloc.Xrefs_Initial, + Table_Increment => Alloc.Xrefs_Increment, + Table_Name => "Xrefs"); + + ------------------------ + -- Local Subprograms -- + ------------------------ + + procedure Generate_Prim_Op_References (Typ : Entity_Id); + -- For a tagged type, generate implicit references to its primitive + -- operations, for source navigation. This is done right before emitting + -- cross-reference information rather than at the freeze point of the type + -- in order to handle late bodies that are primitive operations. + + ------------------------- + -- Generate_Definition -- + ------------------------- + + procedure Generate_Definition (E : Entity_Id) is + Loc : Source_Ptr; + Indx : Nat; + + begin + pragma Assert (Nkind (E) in N_Entity); + + -- Note that we do not test Xref_Entity_Letters here. It is too early + -- to do so, since we are often called before the entity is fully + -- constructed, so that the Ekind is still E_Void. + + if Opt.Xref_Active + + -- Definition must come from source + + -- We make an exception for subprogram child units that have no spec. + -- For these we generate a subprogram declaration for library use, + -- and the corresponding entity does not come from source. + -- Nevertheless, all references will be attached to it and we have + -- to treat is as coming from user code. + + and then (Comes_From_Source (E) or else Is_Child_Unit (E)) + + -- And must have a reasonable source location that is not + -- within an instance (all entities in instances are ignored) + + and then Sloc (E) > No_Location + and then Instantiation_Location (Sloc (E)) = No_Location + + -- And must be a non-internal name from the main source unit + + and then In_Extended_Main_Source_Unit (E) + and then not Is_Internal_Name (Chars (E)) + then + Xrefs.Increment_Last; + Indx := Xrefs.Last; + Loc := Original_Location (Sloc (E)); + + Xrefs.Table (Indx).Ent := E; + Xrefs.Table (Indx).Def := No_Location; + Xrefs.Table (Indx).Loc := No_Location; + Xrefs.Table (Indx).Typ := ' '; + Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc); + Xrefs.Table (Indx).Lun := No_Unit; + Set_Has_Xref_Entry (E); + + if In_Inlined_Body then + Set_Referenced (E); + end if; + end if; + end Generate_Definition; + + --------------------------------- + -- Generate_Operator_Reference -- + --------------------------------- + + procedure Generate_Operator_Reference + (N : Node_Id; + T : Entity_Id) + is + begin + if not In_Extended_Main_Source_Unit (N) then + return; + end if; + + -- If the operator is not a Standard operator, then we generate a real + -- reference to the user defined operator. + + if Sloc (Entity (N)) /= Standard_Location then + Generate_Reference (Entity (N), N); + + -- A reference to an implicit inequality operator is also a reference + -- to the user-defined equality. + + if Nkind (N) = N_Op_Ne + and then not Comes_From_Source (Entity (N)) + and then Present (Corresponding_Equality (Entity (N))) + then + Generate_Reference (Corresponding_Equality (Entity (N)), N); + end if; + + -- For the case of Standard operators, we mark the result type as + -- referenced. This ensures that in the case where we are using a + -- derived operator, we mark an entity of the unit that implicitly + -- defines this operator as used. Otherwise we may think that no entity + -- of the unit is used. The actual entity marked as referenced is the + -- first subtype, which is the relevant user defined entity. + + -- Note: we only do this for operators that come from source. The + -- generated code sometimes reaches for entities that do not need to be + -- explicitly visible (for example, when we expand the code for + -- comparing two record objects, the fields of the record may not be + -- visible). + + elsif Comes_From_Source (N) then + Set_Referenced (First_Subtype (T)); + end if; + end Generate_Operator_Reference; + + --------------------------------- + -- Generate_Prim_Op_References -- + --------------------------------- + + procedure Generate_Prim_Op_References (Typ : Entity_Id) is + Base_T : Entity_Id; + Prim : Elmt_Id; + Prim_List : Elist_Id; + + begin + -- Handle subtypes of synchronized types + + if Ekind (Typ) = E_Protected_Subtype + or else Ekind (Typ) = E_Task_Subtype + then + Base_T := Etype (Typ); + else + Base_T := Typ; + end if; + + -- References to primitive operations are only relevant for tagged types + + if not Is_Tagged_Type (Base_T) + or else Is_Class_Wide_Type (Base_T) + then + return; + end if; + + -- Ada 2005 (AI-345): For synchronized types generate reference + -- to the wrapper that allow us to dispatch calls through their + -- implemented abstract interface types. + + -- The check for Present here is to protect against previously + -- reported critical errors. + + Prim_List := Primitive_Operations (Base_T); + + if No (Prim_List) then + return; + end if; + + Prim := First_Elmt (Prim_List); + while Present (Prim) loop + + -- If the operation is derived, get the original for cross-reference + -- reference purposes (it is the original for which we want the xref + -- and for which the comes_from_source test must be performed). + + Generate_Reference + (Typ, Ultimate_Alias (Node (Prim)), 'p', Set_Ref => False); + Next_Elmt (Prim); + end loop; + end Generate_Prim_Op_References; + + ------------------------ + -- Generate_Reference -- + ------------------------ + + procedure Generate_Reference + (E : Entity_Id; + N : Node_Id; + Typ : Character := 'r'; + Set_Ref : Boolean := True; + Force : Boolean := False) + is + Indx : Nat; + Nod : Node_Id; + Ref : Source_Ptr; + Def : Source_Ptr; + Ent : Entity_Id; + + Call : Node_Id; + Formal : Entity_Id; + -- Used for call to Find_Actual + + Kind : Entity_Kind; + -- If Formal is non-Empty, then its Ekind, otherwise E_Void + + function Is_On_LHS (Node : Node_Id) return Boolean; + -- Used to check if a node is on the left hand side of an assignment. + -- The following cases are handled: + -- + -- Variable Node is a direct descendant of left hand side of an + -- assignment statement. + -- + -- Prefix Of an indexed or selected component that is present in + -- a subtree rooted by an assignment statement. There is + -- no restriction of nesting of components, thus cases + -- such as A.B (C).D are handled properly. However a prefix + -- of a dereference (either implicit or explicit) is never + -- considered as on a LHS. + -- + -- Out param Same as above cases, but OUT parameter + + function OK_To_Set_Referenced return Boolean; + -- Returns True if the Referenced flag can be set. There are a few + -- exceptions where we do not want to set this flag, see body for + -- details of these exceptional cases. + + --------------- + -- Is_On_LHS -- + --------------- + + -- ??? There are several routines here and there that perform a similar + -- (but subtly different) computation, which should be factored: + + -- Sem_Util.May_Be_Lvalue + -- Sem_Util.Known_To_Be_Assigned + -- Exp_Ch2.Expand_Entry_Parameter.In_Assignment_Context + -- Exp_Smem.Is_Out_Actual + + function Is_On_LHS (Node : Node_Id) return Boolean is + N : Node_Id; + P : Node_Id; + K : Node_Kind; + + begin + -- Only identifiers are considered, is this necessary??? + + if Nkind (Node) /= N_Identifier then + return False; + end if; + + -- Immediate return if appeared as OUT parameter + + if Kind = E_Out_Parameter then + return True; + end if; + + -- Search for assignment statement subtree root + + N := Node; + loop + P := Parent (N); + K := Nkind (P); + + if K = N_Assignment_Statement then + return Name (P) = N; + + -- Check whether the parent is a component and the current node is + -- its prefix, but return False if the current node has an access + -- type, as in that case the selected or indexed component is an + -- implicit dereference, and the LHS is the designated object, not + -- the access object. + + -- ??? case of a slice assignment? + + -- ??? Note that in some cases this is called too early + -- (see comments in Sem_Ch8.Find_Direct_Name), at a point where + -- the tree is not fully typed yet. In that case we may lack + -- an Etype for N, and we must disable the check for an implicit + -- dereference. If the dereference is on an LHS, this causes a + -- false positive. + + elsif (K = N_Selected_Component or else K = N_Indexed_Component) + and then Prefix (P) = N + and then not (Present (Etype (N)) + and then + Is_Access_Type (Etype (N))) + then + N := P; + + -- All other cases, definitely not on left side + + else + return False; + end if; + end loop; + end Is_On_LHS; + + --------------------------- + -- OK_To_Set_Referenced -- + --------------------------- + + function OK_To_Set_Referenced return Boolean is + P : Node_Id; + + begin + -- A reference from a pragma Unreferenced or pragma Unmodified or + -- pragma Warnings does not cause the Referenced flag to be set. + -- This avoids silly warnings about things being referenced and + -- not assigned when the only reference is from the pragma. + + if Nkind (N) = N_Identifier then + P := Parent (N); + + if Nkind (P) = N_Pragma_Argument_Association then + P := Parent (P); + + if Nkind (P) = N_Pragma then + if Pragma_Name (P) = Name_Warnings + or else + Pragma_Name (P) = Name_Unmodified + or else + Pragma_Name (P) = Name_Unreferenced + then + return False; + end if; + end if; + end if; + end if; + + return True; + end OK_To_Set_Referenced; + + -- Start of processing for Generate_Reference + + begin + pragma Assert (Nkind (E) in N_Entity); + Find_Actual (N, Formal, Call); + + if Present (Formal) then + Kind := Ekind (Formal); + else + Kind := E_Void; + end if; + + -- Check for obsolescent reference to package ASCII. GNAT treats this + -- element of annex J specially since in practice, programs make a lot + -- of use of this feature, so we don't include it in the set of features + -- diagnosed when Warn_On_Obsolescent_Features mode is set. However we + -- are required to note it as a violation of the RM defined restriction. + + if E = Standard_ASCII then + Check_Restriction (No_Obsolescent_Features, N); + end if; + + -- Check for reference to entity marked with Is_Obsolescent + + -- Note that we always allow obsolescent references in the compiler + -- itself and the run time, since we assume that we know what we are + -- doing in such cases. For example the calls in Ada.Characters.Handling + -- to its own obsolescent subprograms are just fine. + + -- In any case we do not generate warnings within the extended source + -- unit of the entity in question, since we assume the source unit + -- itself knows what is going on (and for sure we do not want silly + -- warnings, e.g. on the end line of an obsolescent procedure body). + + if Is_Obsolescent (E) + and then not GNAT_Mode + and then not In_Extended_Main_Source_Unit (E) + then + Check_Restriction (No_Obsolescent_Features, N); + + if Warn_On_Obsolescent_Feature then + Output_Obsolescent_Entity_Warnings (N, E); + end if; + end if; + + -- Warn if reference to Ada 2005 entity not in Ada 2005 mode. We only + -- detect real explicit references (modifications and references). + + if Comes_From_Source (N) + and then Is_Ada_2005_Only (E) + and then Ada_Version < Ada_2005 + and then Warn_On_Ada_2005_Compatibility + and then (Typ = 'm' or else Typ = 'r' or else Typ = 's') + then + Error_Msg_NE ("& is only defined in Ada 2005?", N, E); + end if; + + -- Warn if reference to Ada 2012 entity not in Ada 2012 mode. We only + -- detect real explicit references (modifications and references). + + if Comes_From_Source (N) + and then Is_Ada_2012_Only (E) + and then Ada_Version < Ada_2012 + and then Warn_On_Ada_2012_Compatibility + and then (Typ = 'm' or else Typ = 'r') + then + Error_Msg_NE ("& is only defined in Ada 2012?", N, E); + end if; + + -- Never collect references if not in main source unit. However, we omit + -- this test if Typ is 'e' or 'k', since these entries are structural, + -- and it is useful to have them in units that reference packages as + -- well as units that define packages. We also omit the test for the + -- case of 'p' since we want to include inherited primitive operations + -- from other packages. + + -- We also omit this test is this is a body reference for a subprogram + -- instantiation. In this case the reference is to the generic body, + -- which clearly need not be in the main unit containing the instance. + -- For the same reason we accept an implicit reference generated for + -- a default in an instance. + + if not In_Extended_Main_Source_Unit (N) then + if Typ = 'e' + or else Typ = 'p' + or else Typ = 'i' + or else Typ = 'k' + or else (Typ = 'b' and then Is_Generic_Instance (E)) + then + null; + else + return; + end if; + end if; + + -- For reference type p, the entity must be in main source unit + + if Typ = 'p' and then not In_Extended_Main_Source_Unit (E) then + return; + end if; + + -- Unless the reference is forced, we ignore references where the + -- reference itself does not come from source. + + if not Force and then not Comes_From_Source (N) then + return; + end if; + + -- Deal with setting entity as referenced, unless suppressed. Note that + -- we still do Set_Referenced on entities that do not come from source. + -- This situation arises when we have a source reference to a derived + -- operation, where the derived operation itself does not come from + -- source, but we still want to mark it as referenced, since we really + -- are referencing an entity in the corresponding package (this avoids + -- wrong complaints that the package contains no referenced entities). + + if Set_Ref then + + -- Assignable object appearing on left side of assignment or as + -- an out parameter. + + if Is_Assignable (E) + and then Is_On_LHS (N) + and then Ekind (E) /= E_In_Out_Parameter + then + -- For objects that are renamings, just set as simply referenced + -- we do not try to do assignment type tracking in this case. + + if Present (Renamed_Object (E)) then + Set_Referenced (E); + + -- Out parameter case + + elsif Kind = E_Out_Parameter then + + -- If warning mode for all out parameters is set, or this is + -- the only warning parameter, then we want to mark this for + -- later warning logic by setting Referenced_As_Out_Parameter + + if Warn_On_Modified_As_Out_Parameter (Formal) then + Set_Referenced_As_Out_Parameter (E, True); + Set_Referenced_As_LHS (E, False); + + -- For OUT parameter not covered by the above cases, we simply + -- regard it as a normal reference (in this case we do not + -- want any of the warning machinery for out parameters). + + else + Set_Referenced (E); + end if; + + -- For the left hand of an assignment case, we do nothing here. + -- The processing for Analyze_Assignment_Statement will set the + -- Referenced_As_LHS flag. + + else + null; + end if; + + -- Check for a reference in a pragma that should not count as a + -- making the variable referenced for warning purposes. + + elsif Is_Non_Significant_Pragma_Reference (N) then + null; + + -- A reference in an attribute definition clause does not count as a + -- reference except for the case of Address. The reason that 'Address + -- is an exception is that it creates an alias through which the + -- variable may be referenced. + + elsif Nkind (Parent (N)) = N_Attribute_Definition_Clause + and then Chars (Parent (N)) /= Name_Address + and then N = Name (Parent (N)) + then + null; + + -- Constant completion does not count as a reference + + elsif Typ = 'c' + and then Ekind (E) = E_Constant + then + null; + + -- Record representation clause does not count as a reference + + elsif Nkind (N) = N_Identifier + and then Nkind (Parent (N)) = N_Record_Representation_Clause + then + null; + + -- Discriminants do not need to produce a reference to record type + + elsif Typ = 'd' + and then Nkind (Parent (N)) = N_Discriminant_Specification + then + null; + + -- All other cases + + else + -- Special processing for IN OUT parameters, where we have an + -- implicit assignment to a simple variable. + + if Kind = E_In_Out_Parameter + and then Is_Assignable (E) + then + -- For sure this counts as a normal read reference + + Set_Referenced (E); + Set_Last_Assignment (E, Empty); + + -- We count it as being referenced as an out parameter if the + -- option is set to warn on all out parameters, except that we + -- have a special exclusion for an intrinsic subprogram, which + -- is most likely an instantiation of Unchecked_Deallocation + -- which we do not want to consider as an assignment since it + -- generates false positives. We also exclude the case of an + -- IN OUT parameter if the name of the procedure is Free, + -- since we suspect similar semantics. + + if Warn_On_All_Unread_Out_Parameters + and then Is_Entity_Name (Name (Call)) + and then not Is_Intrinsic_Subprogram (Entity (Name (Call))) + and then Chars (Name (Call)) /= Name_Free + then + Set_Referenced_As_Out_Parameter (E, True); + Set_Referenced_As_LHS (E, False); + end if; + + -- Don't count a recursive reference within a subprogram as a + -- reference (that allows detection of a recursive subprogram + -- whose only references are recursive calls as unreferenced). + + elsif Is_Subprogram (E) + and then E = Nearest_Dynamic_Scope (Current_Scope) + then + null; + + -- Any other occurrence counts as referencing the entity + + elsif OK_To_Set_Referenced then + Set_Referenced (E); + + -- If variable, this is an OK reference after an assignment + -- so we can clear the Last_Assignment indication. + + if Is_Assignable (E) then + Set_Last_Assignment (E, Empty); + end if; + end if; + end if; + + -- Check for pragma Unreferenced given and reference is within + -- this source unit (occasion for possible warning to be issued). + + if Has_Unreferenced (E) + and then In_Same_Extended_Unit (E, N) + then + -- A reference as a named parameter in a call does not count + -- as a violation of pragma Unreferenced for this purpose... + + if Nkind (N) = N_Identifier + and then Nkind (Parent (N)) = N_Parameter_Association + and then Selector_Name (Parent (N)) = N + then + null; + + -- ... Neither does a reference to a variable on the left side + -- of an assignment. + + elsif Is_On_LHS (N) then + null; + + -- For entry formals, we want to place the warning message on the + -- corresponding entity in the accept statement. The current scope + -- is the body of the accept, so we find the formal whose name + -- matches that of the entry formal (there is no link between the + -- two entities, and the one in the accept statement is only used + -- for conformance checking). + + elsif Ekind (Scope (E)) = E_Entry then + declare + BE : Entity_Id; + + begin + BE := First_Entity (Current_Scope); + while Present (BE) loop + if Chars (BE) = Chars (E) then + Error_Msg_NE -- CODEFIX + ("?pragma Unreferenced given for&!", N, BE); + exit; + end if; + + Next_Entity (BE); + end loop; + end; + + -- Here we issue the warning, since this is a real reference + + else + Error_Msg_NE -- CODEFIX + ("?pragma Unreferenced given for&!", N, E); + end if; + end if; + + -- If this is a subprogram instance, mark as well the internal + -- subprogram in the wrapper package, which may be a visible + -- compilation unit. + + if Is_Overloadable (E) + and then Is_Generic_Instance (E) + and then Present (Alias (E)) + then + Set_Referenced (Alias (E)); + end if; + end if; + + -- Generate reference if all conditions are met: + + if + -- Cross referencing must be active + + Opt.Xref_Active + + -- The entity must be one for which we collect references + + and then Xref_Entity_Letters (Ekind (E)) /= ' ' + + -- Both Sloc values must be set to something sensible + + and then Sloc (E) > No_Location + and then Sloc (N) > No_Location + + -- We ignore references from within an instance, except for default + -- subprograms, for which we generate an implicit reference. + + and then + (Instantiation_Location (Sloc (N)) = No_Location or else Typ = 'i') + + -- Ignore dummy references + + and then Typ /= ' ' + then + if Nkind (N) = N_Identifier + or else + Nkind (N) = N_Defining_Identifier + or else + Nkind (N) in N_Op + or else + Nkind (N) = N_Defining_Operator_Symbol + or else + Nkind (N) = N_Operator_Symbol + or else + (Nkind (N) = N_Character_Literal + and then Sloc (Entity (N)) /= Standard_Location) + or else + Nkind (N) = N_Defining_Character_Literal + then + Nod := N; + + elsif Nkind (N) = N_Expanded_Name + or else + Nkind (N) = N_Selected_Component + then + Nod := Selector_Name (N); + + else + return; + end if; + + -- Normal case of source entity comes from source + + if Comes_From_Source (E) then + Ent := E; + + -- Entity does not come from source, but is a derived subprogram and + -- the derived subprogram comes from source (after one or more + -- derivations) in which case the reference is to parent subprogram. + + elsif Is_Overloadable (E) + and then Present (Alias (E)) + then + Ent := Alias (E); + while not Comes_From_Source (Ent) loop + if No (Alias (Ent)) then + return; + end if; + + Ent := Alias (Ent); + end loop; + + -- The internally created defining entity for a child subprogram + -- that has no previous spec has valid references. + + elsif Is_Overloadable (E) + and then Is_Child_Unit (E) + then + Ent := E; + + -- Record components of discriminated subtypes or derived types must + -- be treated as references to the original component. + + elsif Ekind (E) = E_Component + and then Comes_From_Source (Original_Record_Component (E)) + then + Ent := Original_Record_Component (E); + + -- If this is an expanded reference to a discriminant, recover the + -- original discriminant, which gets the reference. + + elsif Ekind (E) = E_In_Parameter + and then Present (Discriminal_Link (E)) + then + Ent := Discriminal_Link (E); + Set_Referenced (Ent); + + -- Ignore reference to any other entity that is not from source + + else + return; + end if; + + -- Record reference to entity + + Ref := Original_Location (Sloc (Nod)); + Def := Original_Location (Sloc (Ent)); + + Xrefs.Increment_Last; + Indx := Xrefs.Last; + + Xrefs.Table (Indx).Loc := Ref; + + -- Overriding operations are marked with 'P' + + if Typ = 'p' + and then Is_Subprogram (N) + and then Present (Overridden_Operation (N)) + then + Xrefs.Table (Indx).Typ := 'P'; + else + Xrefs.Table (Indx).Typ := Typ; + end if; + + Xrefs.Table (Indx).Eun := Get_Source_Unit (Def); + Xrefs.Table (Indx).Lun := Get_Source_Unit (Ref); + Xrefs.Table (Indx).Ent := Ent; + Set_Has_Xref_Entry (Ent); + end if; + end Generate_Reference; + + ----------------------------------- + -- Generate_Reference_To_Formals -- + ----------------------------------- + + procedure Generate_Reference_To_Formals (E : Entity_Id) is + Formal : Entity_Id; + + begin + if Is_Generic_Subprogram (E) then + Formal := First_Entity (E); + + while Present (Formal) + and then not Is_Formal (Formal) + loop + Next_Entity (Formal); + end loop; + + else + Formal := First_Formal (E); + end if; + + while Present (Formal) loop + if Ekind (Formal) = E_In_Parameter then + + if Nkind (Parameter_Type (Parent (Formal))) + = N_Access_Definition + then + Generate_Reference (E, Formal, '^', False); + else + Generate_Reference (E, Formal, '>', False); + end if; + + elsif Ekind (Formal) = E_In_Out_Parameter then + Generate_Reference (E, Formal, '=', False); + + else + Generate_Reference (E, Formal, '<', False); + end if; + + Next_Formal (Formal); + end loop; + end Generate_Reference_To_Formals; + + ------------------------------------------- + -- Generate_Reference_To_Generic_Formals -- + ------------------------------------------- + + procedure Generate_Reference_To_Generic_Formals (E : Entity_Id) is + Formal : Entity_Id; + + begin + Formal := First_Entity (E); + while Present (Formal) loop + if Comes_From_Source (Formal) then + Generate_Reference (E, Formal, 'z', False); + end if; + + Next_Entity (Formal); + end loop; + end Generate_Reference_To_Generic_Formals; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Xrefs.Init; + end Initialize; + + ----------------------- + -- Output_References -- + ----------------------- + + procedure Output_References is + + procedure Get_Type_Reference + (Ent : Entity_Id; + Tref : out Entity_Id; + Left : out Character; + Right : out Character); + -- Given an Entity_Id Ent, determines whether a type reference is + -- required. If so, Tref is set to the entity for the type reference + -- and Left and Right are set to the left/right brackets to be output + -- for the reference. If no type reference is required, then Tref is + -- set to Empty, and Left/Right are set to space. + + procedure Output_Import_Export_Info (Ent : Entity_Id); + -- Output language and external name information for an interfaced + -- entity, using the format , + + ------------------------ + -- Get_Type_Reference -- + ------------------------ + + procedure Get_Type_Reference + (Ent : Entity_Id; + Tref : out Entity_Id; + Left : out Character; + Right : out Character) + is + Sav : Entity_Id; + + begin + -- See if we have a type reference + + Tref := Ent; + Left := '{'; + Right := '}'; + + loop + Sav := Tref; + + -- Processing for types + + if Is_Type (Tref) then + + -- Case of base type + + if Base_Type (Tref) = Tref then + + -- If derived, then get first subtype + + if Tref /= Etype (Tref) then + Tref := First_Subtype (Etype (Tref)); + + -- Set brackets for derived type, but don't override + -- pointer case since the fact that something is a + -- pointer is more important. + + if Left /= '(' then + Left := '<'; + Right := '>'; + end if; + + -- If non-derived ptr, get directly designated type. + -- If the type has a full view, all references are on the + -- partial view, that is seen first. + + elsif Is_Access_Type (Tref) then + Tref := Directly_Designated_Type (Tref); + Left := '('; + Right := ')'; + + elsif Is_Private_Type (Tref) + and then Present (Full_View (Tref)) + then + if Is_Access_Type (Full_View (Tref)) then + Tref := Directly_Designated_Type (Full_View (Tref)); + Left := '('; + Right := ')'; + + -- If the full view is an array type, we also retrieve + -- the corresponding component type, because the ali + -- entry already indicates that this is an array. + + elsif Is_Array_Type (Full_View (Tref)) then + Tref := Component_Type (Full_View (Tref)); + Left := '('; + Right := ')'; + end if; + + -- If non-derived array, get component type. Skip component + -- type for case of String or Wide_String, saves worthwhile + -- space. + + elsif Is_Array_Type (Tref) + and then Tref /= Standard_String + and then Tref /= Standard_Wide_String + then + Tref := Component_Type (Tref); + Left := '('; + Right := ')'; + + -- For other non-derived base types, nothing + + else + exit; + end if; + + -- For a subtype, go to ancestor subtype + + else + Tref := Ancestor_Subtype (Tref); + + -- If no ancestor subtype, go to base type + + if No (Tref) then + Tref := Base_Type (Sav); + end if; + end if; + + -- For objects, functions, enum literals, just get type from + -- Etype field. + + elsif Is_Object (Tref) + or else Ekind (Tref) = E_Enumeration_Literal + or else Ekind (Tref) = E_Function + or else Ekind (Tref) = E_Operator + then + Tref := Etype (Tref); + + -- For anything else, exit + + else + exit; + end if; + + -- Exit if no type reference, or we are stuck in some loop trying + -- to find the type reference, or if the type is standard void + -- type (the latter is an implementation artifact that should not + -- show up in the generated cross-references). + + exit when No (Tref) + or else Tref = Sav + or else Tref = Standard_Void_Type; + + -- If we have a usable type reference, return, otherwise keep + -- looking for something useful (we are looking for something + -- that either comes from source or standard) + + if Sloc (Tref) = Standard_Location + or else Comes_From_Source (Tref) + then + -- If the reference is a subtype created for a generic actual, + -- go actual directly, the inner subtype is not user visible. + + if Nkind (Parent (Tref)) = N_Subtype_Declaration + and then not Comes_From_Source (Parent (Tref)) + and then + (Is_Wrapper_Package (Scope (Tref)) + or else Is_Generic_Instance (Scope (Tref))) + then + Tref := First_Subtype (Base_Type (Tref)); + end if; + + return; + end if; + end loop; + + -- If we fall through the loop, no type reference + + Tref := Empty; + Left := ' '; + Right := ' '; + end Get_Type_Reference; + + ------------------------------- + -- Output_Import_Export_Info -- + ------------------------------- + + procedure Output_Import_Export_Info (Ent : Entity_Id) is + Language_Name : Name_Id; + Conv : constant Convention_Id := Convention (Ent); + + begin + -- Generate language name from convention + + if Conv = Convention_C then + Language_Name := Name_C; + + elsif Conv = Convention_CPP then + Language_Name := Name_CPP; + + elsif Conv = Convention_Ada then + Language_Name := Name_Ada; + + else + -- For the moment we ignore all other cases ??? + + return; + end if; + + Write_Info_Char ('<'); + Get_Unqualified_Name_String (Language_Name); + + for J in 1 .. Name_Len loop + Write_Info_Char (Name_Buffer (J)); + end loop; + + if Present (Interface_Name (Ent)) then + Write_Info_Char (','); + String_To_Name_Buffer (Strval (Interface_Name (Ent))); + + for J in 1 .. Name_Len loop + Write_Info_Char (Name_Buffer (J)); + end loop; + end if; + + Write_Info_Char ('>'); + end Output_Import_Export_Info; + + -- Start of processing for Output_References + + begin + if not Opt.Xref_Active then + return; + end if; + + -- First we add references to the primitive operations of tagged + -- types declared in the main unit. + + Handle_Prim_Ops : declare + Ent : Entity_Id; + + begin + for J in 1 .. Xrefs.Last loop + Ent := Xrefs.Table (J).Ent; + + if Is_Type (Ent) + and then Is_Tagged_Type (Ent) + and then Is_Base_Type (Ent) + and then In_Extended_Main_Source_Unit (Ent) + then + Generate_Prim_Op_References (Ent); + end if; + end loop; + end Handle_Prim_Ops; + + -- Before we go ahead and output the references we have a problem + -- that needs dealing with. So far we have captured things that are + -- definitely referenced by the main unit, or defined in the main + -- unit. That's because we don't want to clutter up the ali file + -- for this unit with definition lines for entities in other units + -- that are not referenced. + + -- But there is a glitch. We may reference an entity in another unit, + -- and it may have a type reference to an entity that is not directly + -- referenced in the main unit, which may mean that there is no xref + -- entry for this entity yet in the list of references. + + -- If we don't do something about this, we will end with an orphan type + -- reference, i.e. it will point to an entity that does not appear + -- within the generated references in the ali file. That is not good for + -- tools using the xref information. + + -- To fix this, we go through the references adding definition entries + -- for any unreferenced entities that can be referenced in a type + -- reference. There is a recursion problem here, and that is dealt with + -- by making sure that this traversal also traverses any entries that + -- get added by the traversal. + + Handle_Orphan_Type_References : declare + J : Nat; + Tref : Entity_Id; + Indx : Nat; + Ent : Entity_Id; + Loc : Source_Ptr; + + L, R : Character; + pragma Warnings (Off, L); + pragma Warnings (Off, R); + + procedure New_Entry (E : Entity_Id); + -- Make an additional entry into the Xref table for a type entity + -- that is related to the current entity (parent, type ancestor, + -- progenitor, etc.). + + ---------------- + -- New_Entry -- + ---------------- + + procedure New_Entry (E : Entity_Id) is + begin + if Present (E) + and then not Has_Xref_Entry (E) + and then Sloc (E) > No_Location + then + Xrefs.Increment_Last; + Indx := Xrefs.Last; + Loc := Original_Location (Sloc (E)); + Xrefs.Table (Indx).Ent := E; + Xrefs.Table (Indx).Loc := No_Location; + Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc); + Xrefs.Table (Indx).Lun := No_Unit; + Set_Has_Xref_Entry (E); + end if; + end New_Entry; + + -- Start of processing for Handle_Orphan_Type_References + + begin + -- Note that this is not a for loop for a very good reason. The + -- processing of items in the table can add new items to the table, + -- and they must be processed as well. + + J := 1; + while J <= Xrefs.Last loop + Ent := Xrefs.Table (J).Ent; + Get_Type_Reference (Ent, Tref, L, R); + + if Present (Tref) + and then not Has_Xref_Entry (Tref) + and then Sloc (Tref) > No_Location + then + New_Entry (Tref); + + if Is_Record_Type (Ent) + and then Present (Interfaces (Ent)) + then + -- Add an entry for each one of the given interfaces + -- implemented by type Ent. + + declare + Elmt : Elmt_Id := First_Elmt (Interfaces (Ent)); + begin + while Present (Elmt) loop + New_Entry (Node (Elmt)); + Next_Elmt (Elmt); + end loop; + end; + end if; + end if; + + -- Collect inherited primitive operations that may be declared in + -- another unit and have no visible reference in the current one. + + if Is_Type (Ent) + and then Is_Tagged_Type (Ent) + and then Is_Derived_Type (Ent) + and then Is_Base_Type (Ent) + and then In_Extended_Main_Source_Unit (Ent) + then + declare + Op_List : constant Elist_Id := Primitive_Operations (Ent); + Op : Elmt_Id; + Prim : Entity_Id; + + function Parent_Op (E : Entity_Id) return Entity_Id; + -- Find original operation, which may be inherited through + -- several derivations. + + function Parent_Op (E : Entity_Id) return Entity_Id is + Orig_Op : constant Entity_Id := Alias (E); + + begin + if No (Orig_Op) then + return Empty; + + elsif not Comes_From_Source (E) + and then not Has_Xref_Entry (Orig_Op) + and then Comes_From_Source (Orig_Op) + then + return Orig_Op; + else + return Parent_Op (Orig_Op); + end if; + end Parent_Op; + + begin + Op := First_Elmt (Op_List); + while Present (Op) loop + Prim := Parent_Op (Node (Op)); + + if Present (Prim) then + Xrefs.Increment_Last; + Indx := Xrefs.Last; + Loc := Original_Location (Sloc (Prim)); + Xrefs.Table (Indx).Ent := Prim; + Xrefs.Table (Indx).Loc := No_Location; + Xrefs.Table (Indx).Eun := + Get_Source_Unit (Sloc (Prim)); + Xrefs.Table (Indx).Lun := No_Unit; + Set_Has_Xref_Entry (Prim); + end if; + + Next_Elmt (Op); + end loop; + end; + end if; + + J := J + 1; + end loop; + end Handle_Orphan_Type_References; + + -- Now we have all the references, including those for any embedded + -- type references, so we can sort them, and output them. + + Output_Refs : declare + + Nrefs : Nat := Xrefs.Last; + -- Number of references in table. This value may get reset (reduced) + -- when we eliminate duplicate reference entries. + + Rnums : array (0 .. Nrefs) of Nat; + -- This array contains numbers of references in the Xrefs table. + -- This list is sorted in output order. The extra 0'th entry is + -- convenient for the call to sort. When we sort the table, we + -- move the entries in Rnums around, but we do not move the + -- original table entries. + + Curxu : Unit_Number_Type; + -- Current xref unit + + Curru : Unit_Number_Type; + -- Current reference unit for one entity + + Cursrc : Source_Buffer_Ptr; + -- Current xref unit source text + + Curent : Entity_Id; + -- Current entity + + Curnam : String (1 .. Name_Buffer'Length); + Curlen : Natural; + -- Simple name and length of current entity + + Curdef : Source_Ptr; + -- Original source location for current entity + + Crloc : Source_Ptr; + -- Current reference location + + Ctyp : Character; + -- Entity type character + + Tref : Entity_Id; + -- Type reference + + Rref : Node_Id; + -- Renaming reference + + Trunit : Unit_Number_Type; + -- Unit number for type reference + + function Lt (Op1, Op2 : Natural) return Boolean; + -- Comparison function for Sort call + + function Name_Change (X : Entity_Id) return Boolean; + -- Determines if entity X has a different simple name from Curent + + procedure Move (From : Natural; To : Natural); + -- Move procedure for Sort call + + package Sorting is new GNAT.Heap_Sort_G (Move, Lt); + + -------- + -- Lt -- + -------- + + function Lt (Op1, Op2 : Natural) return Boolean is + T1 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op1))); + T2 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op2))); + + begin + -- First test: if entity is in different unit, sort by unit + + if T1.Eun /= T2.Eun then + return Dependency_Num (T1.Eun) < Dependency_Num (T2.Eun); + + -- Second test: within same unit, sort by entity Sloc + + elsif T1.Def /= T2.Def then + return T1.Def < T2.Def; + + -- Third test: sort definitions ahead of references + + elsif T1.Loc = No_Location then + return True; + + elsif T2.Loc = No_Location then + return False; + + -- Fourth test: for same entity, sort by reference location unit + + elsif T1.Lun /= T2.Lun then + return Dependency_Num (T1.Lun) < Dependency_Num (T2.Lun); + + -- Fifth test: order of location within referencing unit + + elsif T1.Loc /= T2.Loc then + return T1.Loc < T2.Loc; + + -- Finally, for two locations at the same address, we prefer + -- the one that does NOT have the type 'r' so that a modification + -- or extension takes preference, when there are more than one + -- reference at the same location. + + else + return T2.Typ = 'r'; + end if; + end Lt; + + ---------- + -- Move -- + ---------- + + procedure Move (From : Natural; To : Natural) is + begin + Rnums (Nat (To)) := Rnums (Nat (From)); + end Move; + + ----------------- + -- Name_Change -- + ----------------- + + -- Why a string comparison here??? Why not compare Name_Id values??? + + function Name_Change (X : Entity_Id) return Boolean is + begin + Get_Unqualified_Name_String (Chars (X)); + + if Name_Len /= Curlen then + return True; + else + return Name_Buffer (1 .. Curlen) /= Curnam (1 .. Curlen); + end if; + end Name_Change; + + -- Start of processing for Output_Refs + + begin + -- Capture the definition Sloc values. We delay doing this till now, + -- since at the time the reference or definition is made, private + -- types may be swapped, and the Sloc value may be incorrect. We + -- also set up the pointer vector for the sort. + + for J in 1 .. Nrefs loop + Rnums (J) := J; + Xrefs.Table (J).Def := + Original_Location (Sloc (Xrefs.Table (J).Ent)); + end loop; + + -- Sort the references + + Sorting.Sort (Integer (Nrefs)); + + -- Eliminate duplicate entries + + declare + NR : constant Nat := Nrefs; + + begin + -- We need this test for NR because if we force ALI file + -- generation in case of errors detected, it may be the case + -- that Nrefs is 0, so we should not reset it here + + if NR >= 2 then + Nrefs := 1; + + for J in 2 .. NR loop + if Xrefs.Table (Rnums (J)) /= + Xrefs.Table (Rnums (Nrefs)) + then + Nrefs := Nrefs + 1; + Rnums (Nrefs) := Rnums (J); + end if; + end loop; + end if; + end; + + -- Initialize loop through references + + Curxu := No_Unit; + Curent := Empty; + Curdef := No_Location; + Curru := No_Unit; + Crloc := No_Location; + + -- Loop to output references + + for Refno in 1 .. Nrefs loop + Output_One_Ref : declare + P2 : Source_Ptr; + Ent : Entity_Id; + + WC : Char_Code; + Err : Boolean; + pragma Warnings (Off, WC); + pragma Warnings (Off, Err); + + XE : Xref_Entry renames Xrefs.Table (Rnums (Refno)); + -- The current entry to be accessed + + P : Source_Ptr; + -- Used to index into source buffer to get entity name + + Left : Character; + Right : Character; + -- Used for {} or <> or () for type reference + + procedure Check_Type_Reference + (Ent : Entity_Id; + List_Interface : Boolean); + -- Find whether there is a meaningful type reference for + -- Ent, and display it accordingly. If List_Interface is + -- true, then Ent is a progenitor interface of the current + -- type entity being listed. In that case list it as is, + -- without looking for a type reference for it. + + procedure Output_Instantiation_Refs (Loc : Source_Ptr); + -- Recursive procedure to output instantiation references for + -- the given source ptr in [file|line[...]] form. No output + -- if the given location is not a generic template reference. + + procedure Output_Overridden_Op (Old_E : Entity_Id); + -- For a subprogram that is overriding, display information + -- about the inherited operation that it overrides. + + -------------------------- + -- Check_Type_Reference -- + -------------------------- + + procedure Check_Type_Reference + (Ent : Entity_Id; + List_Interface : Boolean) + is + begin + if List_Interface then + + -- This is a progenitor interface of the type for which + -- xref information is being generated. + + Tref := Ent; + Left := '<'; + Right := '>'; + + else + Get_Type_Reference (Ent, Tref, Left, Right); + end if; + + if Present (Tref) then + + -- Case of standard entity, output name + + if Sloc (Tref) = Standard_Location then + Write_Info_Char (Left); + Write_Info_Name (Chars (Tref)); + Write_Info_Char (Right); + + -- Case of source entity, output location + + else + Write_Info_Char (Left); + Trunit := Get_Source_Unit (Sloc (Tref)); + + if Trunit /= Curxu then + Write_Info_Nat (Dependency_Num (Trunit)); + Write_Info_Char ('|'); + end if; + + Write_Info_Nat + (Int (Get_Logical_Line_Number (Sloc (Tref)))); + + declare + Ent : Entity_Id; + Ctyp : Character; + + begin + Ent := Tref; + Ctyp := Xref_Entity_Letters (Ekind (Ent)); + + if Ctyp = '+' + and then Present (Full_View (Ent)) + then + Ent := Underlying_Type (Ent); + + if Present (Ent) then + Ctyp := Xref_Entity_Letters (Ekind (Ent)); + end if; + end if; + + Write_Info_Char (Ctyp); + end; + + Write_Info_Nat + (Int (Get_Column_Number (Sloc (Tref)))); + + -- If the type comes from an instantiation, add the + -- corresponding info. + + Output_Instantiation_Refs (Sloc (Tref)); + Write_Info_Char (Right); + end if; + end if; + end Check_Type_Reference; + + ------------------------------- + -- Output_Instantiation_Refs -- + ------------------------------- + + procedure Output_Instantiation_Refs (Loc : Source_Ptr) is + Iloc : constant Source_Ptr := Instantiation_Location (Loc); + Lun : Unit_Number_Type; + Cu : constant Unit_Number_Type := Curru; + + begin + -- Nothing to do if this is not an instantiation + + if Iloc = No_Location then + return; + end if; + + -- Output instantiation reference + + Write_Info_Char ('['); + Lun := Get_Source_Unit (Iloc); + + if Lun /= Curru then + Curru := Lun; + Write_Info_Nat (Dependency_Num (Curru)); + Write_Info_Char ('|'); + end if; + + Write_Info_Nat (Int (Get_Logical_Line_Number (Iloc))); + + -- Recursive call to get nested instantiations + + Output_Instantiation_Refs (Iloc); + + -- Output final ] after call to get proper nesting + + Write_Info_Char (']'); + Curru := Cu; + return; + end Output_Instantiation_Refs; + + -------------------------- + -- Output_Overridden_Op -- + -------------------------- + + procedure Output_Overridden_Op (Old_E : Entity_Id) is + Op : Entity_Id; + + begin + -- The overridden operation has an implicit declaration + -- at the point of derivation. What we want to display + -- is the original operation, which has the actual body + -- (or abstract declaration) that is being overridden. + -- The overridden operation is not always set, e.g. when + -- it is a predefined operator. + + if No (Old_E) then + return; + + -- Follow alias chain if one is present + + elsif Present (Alias (Old_E)) then + + -- The subprogram may have been implicitly inherited + -- through several levels of derivation, so find the + -- ultimate (source) ancestor. + + Op := Ultimate_Alias (Old_E); + + -- Normal case of no alias present + + else + Op := Old_E; + end if; + + if Present (Op) + and then Sloc (Op) /= Standard_Location + then + declare + Loc : constant Source_Ptr := Sloc (Op); + Par_Unit : constant Unit_Number_Type := + Get_Source_Unit (Loc); + + begin + Write_Info_Char ('<'); + + if Par_Unit /= Curxu then + Write_Info_Nat (Dependency_Num (Par_Unit)); + Write_Info_Char ('|'); + end if; + + Write_Info_Nat (Int (Get_Logical_Line_Number (Loc))); + Write_Info_Char ('p'); + Write_Info_Nat (Int (Get_Column_Number (Loc))); + Write_Info_Char ('>'); + end; + end if; + end Output_Overridden_Op; + + -- Start of processing for Output_One_Ref + + begin + Ent := XE.Ent; + Ctyp := Xref_Entity_Letters (Ekind (Ent)); + + -- Skip reference if it is the only reference to an entity, + -- and it is an END line reference, and the entity is not in + -- the current extended source. This prevents junk entries + -- consisting only of packages with END lines, where no + -- entity from the package is actually referenced. + + if XE.Typ = 'e' + and then Ent /= Curent + and then (Refno = Nrefs or else + Ent /= Xrefs.Table (Rnums (Refno + 1)).Ent) + and then + not In_Extended_Main_Source_Unit (Ent) + then + goto Continue; + end if; + + -- For private type, get full view type + + if Ctyp = '+' + and then Present (Full_View (XE.Ent)) + then + Ent := Underlying_Type (Ent); + + if Present (Ent) then + Ctyp := Xref_Entity_Letters (Ekind (Ent)); + end if; + end if; + + -- Special exception for Boolean + + if Ctyp = 'E' and then Is_Boolean_Type (Ent) then + Ctyp := 'B'; + end if; + + -- For variable reference, get corresponding type + + if Ctyp = '*' then + Ent := Etype (XE.Ent); + Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent))); + + -- If variable is private type, get full view type + + if Ctyp = '+' + and then Present (Full_View (Etype (XE.Ent))) + then + Ent := Underlying_Type (Etype (XE.Ent)); + + if Present (Ent) then + Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent))); + end if; + + elsif Is_Generic_Type (Ent) then + + -- If the type of the entity is a generic private type, + -- there is no usable full view, so retain the indication + -- that this is an object. + + Ctyp := '*'; + end if; + + -- Special handling for access parameters and objects of + -- an anonymous access type. + + if Ekind_In (Etype (XE.Ent), + E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type, + E_Anonymous_Access_Protected_Subprogram_Type) + then + if Is_Formal (XE.Ent) + or else Ekind_In (XE.Ent, E_Variable, E_Constant) + then + Ctyp := 'p'; + end if; + + -- Special handling for Boolean + + elsif Ctyp = 'e' and then Is_Boolean_Type (Ent) then + Ctyp := 'b'; + end if; + end if; + + -- Special handling for abstract types and operations + + if Is_Overloadable (XE.Ent) + and then Is_Abstract_Subprogram (XE.Ent) + then + if Ctyp = 'U' then + Ctyp := 'x'; -- Abstract procedure + + elsif Ctyp = 'V' then + Ctyp := 'y'; -- Abstract function + end if; + + elsif Is_Type (XE.Ent) + and then Is_Abstract_Type (XE.Ent) + then + if Is_Interface (XE.Ent) then + Ctyp := 'h'; + + elsif Ctyp = 'R' then + Ctyp := 'H'; -- Abstract type + end if; + end if; + + -- Only output reference if interesting type of entity, and + -- suppress self references, except for bodies that act as + -- specs. Also suppress definitions of body formals (we only + -- treat these as references, and the references were + -- separately recorded). + + if Ctyp = ' ' + or else (XE.Loc = XE.Def + and then + (XE.Typ /= 'b' + or else not Is_Subprogram (XE.Ent))) + or else (Is_Formal (XE.Ent) + and then Present (Spec_Entity (XE.Ent))) + then + null; + + else + -- Start new Xref section if new xref unit + + if XE.Eun /= Curxu then + if Write_Info_Col > 1 then + Write_Info_EOL; + end if; + + Curxu := XE.Eun; + Cursrc := Source_Text (Source_Index (Curxu)); + + Write_Info_Initiate ('X'); + Write_Info_Char (' '); + Write_Info_Nat (Dependency_Num (XE.Eun)); + Write_Info_Char (' '); + Write_Info_Name (Reference_Name (Source_Index (XE.Eun))); + end if; + + -- Start new Entity line if new entity. Note that we + -- consider two entities the same if they have the same + -- name and source location. This causes entities in + -- instantiations to be treated as though they referred + -- to the template. + + if No (Curent) + or else + (XE.Ent /= Curent + and then + (Name_Change (XE.Ent) or else XE.Def /= Curdef)) + then + Curent := XE.Ent; + Curdef := XE.Def; + + Get_Unqualified_Name_String (Chars (XE.Ent)); + Curlen := Name_Len; + Curnam (1 .. Curlen) := Name_Buffer (1 .. Curlen); + + if Write_Info_Col > 1 then + Write_Info_EOL; + end if; + + -- Write column number information + + Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Def))); + Write_Info_Char (Ctyp); + Write_Info_Nat (Int (Get_Column_Number (XE.Def))); + + -- Write level information + + Write_Level_Info : declare + function Is_Visible_Generic_Entity + (E : Entity_Id) return Boolean; + -- Check whether E is declared in the visible part + -- of a generic package. For source navigation + -- purposes, treat this as a visible entity. + + function Is_Private_Record_Component + (E : Entity_Id) return Boolean; + -- Check whether E is a non-inherited component of a + -- private extension. Even if the enclosing record is + -- public, we want to treat the component as private + -- for navigation purposes. + + --------------------------------- + -- Is_Private_Record_Component -- + --------------------------------- + + function Is_Private_Record_Component + (E : Entity_Id) return Boolean + is + S : constant Entity_Id := Scope (E); + begin + return + Ekind (E) = E_Component + and then Nkind (Declaration_Node (S)) = + N_Private_Extension_Declaration + and then Original_Record_Component (E) = E; + end Is_Private_Record_Component; + + ------------------------------- + -- Is_Visible_Generic_Entity -- + ------------------------------- + + function Is_Visible_Generic_Entity + (E : Entity_Id) return Boolean + is + Par : Node_Id; + + begin + -- The Present check here is an error defense + + if Present (Scope (E)) + and then Ekind (Scope (E)) /= E_Generic_Package + then + return False; + end if; + + Par := Parent (E); + while Present (Par) loop + if + Nkind (Par) = N_Generic_Package_Declaration + then + -- Entity is a generic formal + + return False; + + elsif + Nkind (Parent (Par)) = N_Package_Specification + then + return + Is_List_Member (Par) + and then List_Containing (Par) = + Visible_Declarations (Parent (Par)); + else + Par := Parent (Par); + end if; + end loop; + + return False; + end Is_Visible_Generic_Entity; + + -- Start of processing for Write_Level_Info + + begin + if Is_Hidden (Curent) + or else Is_Private_Record_Component (Curent) + then + Write_Info_Char (' '); + + elsif + Is_Public (Curent) + or else Is_Visible_Generic_Entity (Curent) + then + Write_Info_Char ('*'); + + else + Write_Info_Char (' '); + end if; + end Write_Level_Info; + + -- Output entity name. We use the occurrence from the + -- actual source program at the definition point. + + P := Original_Location (Sloc (XE.Ent)); + + -- Entity is character literal + + if Cursrc (P) = ''' then + Write_Info_Char (Cursrc (P)); + Write_Info_Char (Cursrc (P + 1)); + Write_Info_Char (Cursrc (P + 2)); + + -- Entity is operator symbol + + elsif Cursrc (P) = '"' or else Cursrc (P) = '%' then + Write_Info_Char (Cursrc (P)); + + P2 := P; + loop + P2 := P2 + 1; + Write_Info_Char (Cursrc (P2)); + exit when Cursrc (P2) = Cursrc (P); + end loop; + + -- Entity is identifier + + else + loop + if Is_Start_Of_Wide_Char (Cursrc, P) then + Scan_Wide (Cursrc, P, WC, Err); + elsif not Identifier_Char (Cursrc (P)) then + exit; + else + P := P + 1; + end if; + end loop; + + -- Write out the identifier by copying the exact + -- source characters used in its declaration. Note + -- that this means wide characters will be in their + -- original encoded form. + + for J in + Original_Location (Sloc (XE.Ent)) .. P - 1 + loop + Write_Info_Char (Cursrc (J)); + end loop; + end if; + + -- See if we have a renaming reference + + if Is_Object (XE.Ent) + and then Present (Renamed_Object (XE.Ent)) + then + Rref := Renamed_Object (XE.Ent); + + elsif Is_Overloadable (XE.Ent) + and then Nkind (Parent (Declaration_Node (XE.Ent))) = + N_Subprogram_Renaming_Declaration + then + Rref := Name (Parent (Declaration_Node (XE.Ent))); + + elsif Ekind (XE.Ent) = E_Package + and then Nkind (Declaration_Node (XE.Ent)) = + N_Package_Renaming_Declaration + then + Rref := Name (Declaration_Node (XE.Ent)); + + else + Rref := Empty; + end if; + + if Present (Rref) then + if Nkind (Rref) = N_Expanded_Name then + Rref := Selector_Name (Rref); + end if; + + if Nkind (Rref) = N_Identifier + or else Nkind (Rref) = N_Operator_Symbol + then + null; + + -- For renamed array components, use the array name + -- for the renamed entity, which reflect the fact that + -- in general the whole array is aliased. + + elsif Nkind (Rref) = N_Indexed_Component then + if Nkind (Prefix (Rref)) = N_Identifier then + Rref := Prefix (Rref); + elsif Nkind (Prefix (Rref)) = N_Expanded_Name then + Rref := Selector_Name (Prefix (Rref)); + else + Rref := Empty; + end if; + + else + Rref := Empty; + end if; + end if; + + -- Write out renaming reference if we have one + + if Present (Rref) then + Write_Info_Char ('='); + Write_Info_Nat + (Int (Get_Logical_Line_Number (Sloc (Rref)))); + Write_Info_Char (':'); + Write_Info_Nat + (Int (Get_Column_Number (Sloc (Rref)))); + end if; + + -- Indicate that the entity is in the unit of the current + -- xref section. + + Curru := Curxu; + + -- Write out information about generic parent, if entity + -- is an instance. + + if Is_Generic_Instance (XE.Ent) then + declare + Gen_Par : constant Entity_Id := + Generic_Parent + (Specification + (Unit_Declaration_Node (XE.Ent))); + Loc : constant Source_Ptr := Sloc (Gen_Par); + Gen_U : constant Unit_Number_Type := + Get_Source_Unit (Loc); + + begin + Write_Info_Char ('['); + + if Curru /= Gen_U then + Write_Info_Nat (Dependency_Num (Gen_U)); + Write_Info_Char ('|'); + end if; + + Write_Info_Nat + (Int (Get_Logical_Line_Number (Loc))); + Write_Info_Char (']'); + end; + end if; + + -- See if we have a type reference and if so output + + Check_Type_Reference (XE.Ent, False); + + -- Additional information for types with progenitors + + if Is_Record_Type (XE.Ent) + and then Present (Interfaces (XE.Ent)) + then + declare + Elmt : Elmt_Id := First_Elmt (Interfaces (XE.Ent)); + begin + while Present (Elmt) loop + Check_Type_Reference (Node (Elmt), True); + Next_Elmt (Elmt); + end loop; + end; + + -- For array types, list index types as well. (This is + -- not C, indexes have distinct types). + + elsif Is_Array_Type (XE.Ent) then + declare + Indx : Node_Id; + begin + Indx := First_Index (XE.Ent); + while Present (Indx) loop + Check_Type_Reference + (First_Subtype (Etype (Indx)), True); + Next_Index (Indx); + end loop; + end; + end if; + + -- If the entity is an overriding operation, write info + -- on operation that was overridden. + + if Is_Subprogram (XE.Ent) + and then Present (Overridden_Operation (XE.Ent)) + then + Output_Overridden_Op (Overridden_Operation (XE.Ent)); + end if; + + -- End of processing for entity output + + Crloc := No_Location; + end if; + + -- Output the reference + + if XE.Loc /= No_Location + and then XE.Loc /= Crloc + then + Crloc := XE.Loc; + + -- Start continuation if line full, else blank + + if Write_Info_Col > 72 then + Write_Info_EOL; + Write_Info_Initiate ('.'); + end if; + + Write_Info_Char (' '); + + -- Output file number if changed + + if XE.Lun /= Curru then + Curru := XE.Lun; + Write_Info_Nat (Dependency_Num (Curru)); + Write_Info_Char ('|'); + end if; + + Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Loc))); + Write_Info_Char (XE.Typ); + + if Is_Overloadable (XE.Ent) + and then Is_Imported (XE.Ent) + and then XE.Typ = 'b' + then + Output_Import_Export_Info (XE.Ent); + end if; + + Write_Info_Nat (Int (Get_Column_Number (XE.Loc))); + + Output_Instantiation_Refs (Sloc (XE.Ent)); + end if; + end if; + end Output_One_Ref; + + <> + null; + end loop; + + Write_Info_EOL; + end Output_Refs; + end Output_References; + +end Lib.Xref; diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads new file mode 100644 index 000000000..9fb8b2df5 --- /dev/null +++ b/gcc/ada/lib-xref.ads @@ -0,0 +1,681 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B . X R E F -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains for collecting and outputting cross-reference +-- information. + +with Einfo; use Einfo; + +package Lib.Xref is + + ------------------------------------------------------- + -- Format of Cross-Reference Information in ALI File -- + ------------------------------------------------------- + + -- Cross-reference sections follow the dependency section (D lines) in + -- an ALI file, so that they need not be read by gnatbind, gnatmake etc. + + -- A cross reference section has a header of the form + + -- X dependency-number filename + + -- This header precedes xref information (entities/references from + -- the unit), identified by dependency number and file name. The + -- dependency number is the index into the generated D lines and + -- is ones origin (i.e. 2 = reference to second generated D line). + + -- Note that the filename here will reflect the original name if + -- a Source_Reference pragma was encountered (since all line number + -- references will be with respect to the original file). + + -- The lines following the header look like + + -- line type col level entity renameref instref typeref overref ref ref + + -- line is the line number of the referenced entity. The name of + -- the entity starts in column col. Columns are numbered from one, + -- and if horizontal tab characters are present, the column number + -- is computed assuming standard 1,9,17,.. tab stops. For example, + -- if the entity is the first token on the line, and is preceded + -- by space-HT-space, then the column would be column 10. + + -- type is a single letter identifying the type of the entity. + -- See next section (Cross-Reference Entity Identifiers) for a + -- full list of the characters used). + + -- col is the column number of the referenced entity + + -- level is a single character that separates the col and + -- entity fields. It is an asterisk (*) for a top level library + -- entity that is publicly visible, as well for an entity declared + -- in the visible part of a generic package, the plus sign (+) for + -- a C/C++ static entity, and space otherwise. + + -- entity is the name of the referenced entity, with casing in + -- the canonical casing for the source file where it is defined. + + -- renameref provides information on renaming. If the entity is + -- a package, object or overloadable entity which is declared by + -- a renaming declaration, and the renaming refers to an entity + -- with a simple identifier or expanded name, then renameref has + -- the form: + + -- =line:col + + -- Here line:col give the reference to the identifier that + -- appears in the renaming declaration. Note that we never need + -- a file entry, since this identifier is always in the current + -- file in which the entity is declared. Currently, renameref + -- appears only for the simple renaming case. If the renaming + -- reference is a complex expressions, then renameref is omitted. + -- Here line/col give line/column as defined above. + + -- instref is only present for package and subprogram instances. + -- The information in instref is the location of the point of + -- declaration of the generic parent unit. This part has the form: + + -- [file|line] + + -- without column information, on the reasonable assumption that + -- there is only one unit per line (the same assumption is made + -- in references to entities that are declared within instances, + -- see below). + + -- typeref is the reference for a related type. This part is + -- optional. It is present for the following cases: + + -- derived types (points to the parent type) LR=<> + -- access types (points to designated type) LR=() + -- array types (points to component type) LR=() + -- subtypes (points to ancestor type) LR={} + -- functions (points to result type) LR={} + -- enumeration literals (points to enum type) LR={} + -- objects and components (points to type) LR={} + + -- For a type that implements multiple interfaces, there is an + -- entry of the form LR=<> for each of the interfaces appearing + -- in the type declaration. In the data structures of ali.ads, + -- the type that the entity extends (or the first interface if + -- there is no such type) is stored in Xref_Entity_Record.Tref*, + -- additional interfaces are stored in the list of references + -- with a special type of Interface_Reference. + + -- For an array type, there is an entry of the form LR=<> for + -- each of the index types appearing in the type declaration. + -- The index types follow the entry for the component type. + -- In the data structures of ali.ads, however, the list of index + -- types are output in the list of references with a special + -- Rtype set to Array_Index_Reference. + + -- In the above list LR shows the brackets used in the output, + -- which has one of the two following forms: + + -- L file | line type col R user entity + -- L name-in-lower-case R standard entity + + -- For the form for a user entity, file is the dependency number + -- of the file containing the declaration of the related type. + -- This number and the following vertical bar are omitted if the + -- relevant type is defined in the same file as the current entity. + -- The line, type, col are defined as previously described, and + -- specify the location of the relevant type declaration in the + -- referenced file. For the standard entity form, the name between + -- the brackets is the normal name of the entity in lower case. + + -- overref is present for overriding operations (procedures and + -- functions), and provides information on the operation that it + -- overrides. This information has the format: + + -- '<' file | line 'o' col '>' + + -- file is the dependency number of the file containing the + -- declaration of the overridden operation. It and the following + -- vertical bar are omitted if the file is the same as that of + -- the overriding operation. + + -- There may be zero or more ref entries on each line + + -- file | line type col [...] + + -- file is the dependency number of the file with the reference. + -- It and the following vertical bar are omitted if the file is + -- the same as the previous ref, and the refs for the current + -- file are first (and do not need a bar). + + -- line is the line number of the reference + + -- col is the column number of the reference, as defined above + + -- type is one of + -- b = body entity + -- c = completion of private or incomplete type + -- d = discriminant of type + -- e = end of spec + -- H = abstract type + -- i = implicit reference + -- k = implicit reference to parent unit in child unit + -- l = label on END line + -- m = modification + -- o = own variable reference (SPARK only) + -- p = primitive operation + -- P = overriding primitive operation + -- r = reference + -- R = subprogram reference in dispatching call + -- s = subprogram reference in a static call + -- t = end of body + -- w = WITH line + -- x = type extension + -- z = generic formal parameter + -- > = subprogram IN parameter + -- = = subprogram IN OUT parameter + -- < = subprogram OUT parameter + -- ^ = subprogram ACCESS parameter + + -- b is used for spec entities that are repeated in a body, + -- including the unit (subprogram, package, task, protected + -- body, protected entry) name itself, and in the case of a + -- subprogram, the formals. This letter is also used for the + -- occurrence of entry names in accept statements. Such entities + -- are not considered to be definitions for cross-referencing + -- purposes, but rather are considered to be references to the + -- corresponding spec entities, marked with this special type. + + -- c is similar to b but is used to mark the completion of a + -- private or incomplete type. As with b, the completion is not + -- regarded as a separate definition, but rather a reference to + -- the initial declaration, marked with this special type. + + -- d is used to identify a discriminant of a type. If this is + -- an incomplete or private type with discriminants, the entry + -- denotes the occurrence of the discriminant in the partial view + -- which is also the point of definition of the discriminant. + -- The occurrence of the same discriminant in the full view is + -- a regular reference to it. + + -- e is used to identify the end of a construct in the following + -- cases: + + -- Block Statement end [block_IDENTIFIER]; + -- Loop Statement end loop [loop_IDENTIFIER]; + -- Package Specification end [[PARENT_UNIT_NAME .] IDENTIFIER]; + -- Task Definition end [task_IDENTIFIER]; + -- Protected Definition end [protected_IDENTIFIER]; + -- Record Definition end record; + -- Enumeration Definition ); + + -- Note that 'e' entries are special in that they appear even + -- in referencing units (normally xref entries appear only + -- for references in the extended main source unit (see Lib) to + -- which the ali applies. But 'e' entries are really structural + -- and simply indicate where packages end. This information can + -- be used to reconstruct scope information for any entities + -- referenced from within the package. The line/column values + -- for these entries point to the semicolon ending the construct. + + -- i is used to identify a reference to the entity in a generic + -- actual or in a default in a call. The node that denotes the + -- entity does not come from source, but it has the Sloc of the + -- source node that generates the implicit reference, and it is + -- useful to record this one. + + -- k is another non-standard reference type, used to record a + -- reference from a child unit to its parent. For various cross- + -- referencing tools, we need a pointer from the xref entries for + -- the child to the parent. This is the opposite way round from + -- normal xref entries, since the reference is *from* the child + -- unit *to* the parent unit, yet appears in the xref entries for + -- the child. Consider this example: + -- + -- package q is + -- end; + -- package q.r is + -- end q.r; + -- + -- The ali file for q-r.ads has these entries + -- + -- D q.ads + -- D q-r.ads + -- D system.ads + -- X 1 q.ads + -- 1K9*q 2e4 2|1r9 2r5 + -- X 2 q-r.ads + -- 1K11*r 1|1k9 2|2l7 2e8 + -- + -- Here the 2|1r9 entry appearing in the section for the parent + -- is the normal reference from the child to the parent. The 1k9 + -- entry in the section for the child duplicates this information + -- but appears in the child rather than the parent. + + -- l is used to identify the occurrence in the source of the + -- name on an end line. This is just a syntactic reference + -- which can be ignored for semantic purposes (such as call + -- graph construction). Again, in the case of an accept there + -- can be multiple l lines. + + -- o is used for variables referenced from a SPARK 'own' + -- definition. In the SPARK language, it is allowed to use a + -- variable before its actual declaration. + + -- p is used to mark a primitive operation of the given entity. + -- For example, if we have a type Tx, and a primitive operation + -- Pq of this type, then an entry in the list of references to + -- Tx will point to the declaration of Pq. Note that this entry + -- type is unusual because it an implicit rather than explicit, + -- and the name of the reference does not match the name of the + -- entity for which a reference is generated. These entries are + -- generated only for entities declared in the extended main + -- source unit (main unit itself, its separate spec (if any). + -- and all subunits (considered recursively). + + -- If the primitive operation overrides an inherited primitive + -- operation of the parent type, the letter 'P' is used in the + -- corresponding entry. + + -- R is used to mark a dispatching call. The reference is to + -- the specification of the primitive operation of the root + -- type when the call has a controlling argument in its class. + + -- s is used to mark a static subprogram call. The reference is + -- to the specification of the subprogram being called. + + -- t is similar to e. It identifies the end of a corresponding + -- body (such a reference always links up with a b reference) + + -- Subprogram Body end [DESIGNATOR]; + -- Package Body end [[PARENT_UNIT_NAME .] IDENTIFIER]; + -- Task Body end [task_IDENTIFIER]; + -- Entry Body end [entry_IDENTIFIER]; + -- Protected Body end [protected_IDENTIFIER] + -- Accept Statement end [entry_IDENTIFIER]]; + + -- Note that in the case of accept statements, there can + -- be multiple b and t entries for the same entity. + + -- x is used to identify the reference as the entity from which + -- a tagged type is extended. This allows immediate access to + -- the parent of a tagged type. + + -- z is used on the cross-reference line for a generic unit, to + -- mark the definition of a generic formal of the unit. + -- This entry type is similar to 'k' and 'p' in that it is an + -- implicit reference for an entity with a different name. + + -- The characters >, <. =, and ^ are used on the cross-reference + -- line for a subprogram, to denote formal parameters and their + -- modes. As with the 'z' and 'p' entries, each such entry is + -- an implicit reference to an entity with a different name. + + -- [..] is used for generic instantiation references. These + -- references are present only if the entity in question is + -- a generic entity, and in that case the [..] contains the + -- reference for the instantiation. In the case of nested + -- instantiations, this can be nested [...[...[...]]] etc. + -- The reference is of the form [file|line] no column is + -- present since it is assumed that only one instantiation + -- appears on a single source line. Note that the appearance + -- of file numbers in such references follows the normal + -- rules (present only if needed, and resets the current + -- file for subsequent references). + + -- Examples: + + -- 44B5*Flag_Type{boolean} 5r23 6m45 3|9r35 11r56 + + -- This line gives references for the publicly visible Boolean + -- type Flag_Type declared on line 44, column 5. There are four + -- references + + -- a reference on line 5, column 23 of the current file + + -- a modification on line 6, column 45 of the current file + + -- a reference on line 9, column 35 of unit number 3 + + -- a reference on line 11, column 56 of unit number 3 + + -- 2U13 p3=2:35 5b13 8r4 12r13 12t15 + + -- This line gives references for the non-publicly visible + -- procedure p3 declared on line 2, column 13. This procedure + -- renames the procedure whose identifier reference is at + -- line 2 column 35. There are four references: + + -- the corresponding body entity at line 5, column 13, + -- of the current file. + + -- a reference (e.g. a call) at line 8 column 4 of the + -- of the current file. + + -- the END line of the body has an explicit reference to + -- the name of the procedure at line 12, column 13. + + -- the body ends at line 12, column 15, just past this label + + -- 16I9*My_Type<2|4I9> 18r8 + + -- This line gives references for the publicly visible Integer + -- derived type My_Type declared on line 16, column 9. It also + -- gives references to the parent type declared in the unit + -- number 2 on line 4, column 9. There is one reference: + + -- a reference (e.g. a variable declaration) at line 18 column + -- 4 of the current file. + + -- 10I3*Genv{integer} 3|4I10[6|12] + + -- This line gives a reference for the entity Genv in a generic + -- package. The reference in file 3, line 4, col 10, refers to + -- an instance of the generic where the instantiation can be + -- found in file 6 at line 12. + + -- Continuation lines are used if the reference list gets too long, + -- a continuation line starts with a period, and then has references + -- continuing from the previous line. The references are sorted first + -- by unit, then by position in the source. + + -- Note on handling of generic entities. The cross-reference is oriented + -- towards source references, so the entities in a generic instantiation + -- are not considered distinct from the entities in the template. All + -- definitions and references from generic instantiations are suppressed, + -- since they will be generated from the template. Any references to + -- entities in a generic instantiation from outside the instantiation + -- are considered to be references to the original template entity. + + ---------------------------------------- + -- Cross-Reference Entity Identifiers -- + ---------------------------------------- + + -- In the cross-reference section of the ali file, entity types are + -- identified by a single letter, indicating the entity type. The + -- following table indicates the letter. A space for an entry is + -- used for entities that do not appear in the cross-reference table. + + -- For objects, the character * appears in this table. In the xref + -- listing, this character is replaced by the lower case letter that + -- corresponds to the type of the object. For example, if a variable + -- is of a Float type, then, since the type is represented by an + -- upper case F, the object would be represented by a lower case f. + + -- A special exception is the case of booleans, whose entities are + -- normal E_Enumeration_Type or E_Enumeration_Subtype entities, but + -- which appear as B/b in the xref lines, rather than E/e. + + -- For private types, the character + appears in the table. In this + -- case the kind of the underlying type is used, if available, to + -- determine the character to use in the xref listing. The listing + -- will still include a '+' for a generic private type, for example, + -- but will retain the '*' for an object or formal parameter of such + -- a type. + + -- For subprograms, the characters 'U' and 'V' appear in the table, + -- indicating procedures and functions. If the operation is abstract, + -- these letters are replaced in the xref by 'x' and 'y' respectively. + + Xref_Entity_Letters : array (Entity_Kind) of Character := + (E_Void => ' ', + E_Variable => '*', + E_Component => '*', + E_Constant => '*', + E_Discriminant => '*', + + E_Loop_Parameter => '*', + E_In_Parameter => '*', + E_Out_Parameter => '*', + E_In_Out_Parameter => '*', + E_Generic_In_Out_Parameter => '*', + + E_Generic_In_Parameter => '*', + E_Named_Integer => 'N', + E_Named_Real => 'N', + E_Enumeration_Type => 'E', -- B for boolean + E_Enumeration_Subtype => 'E', -- B for boolean + + E_Signed_Integer_Type => 'I', + E_Signed_Integer_Subtype => 'I', + E_Modular_Integer_Type => 'M', + E_Modular_Integer_Subtype => 'M', + E_Ordinary_Fixed_Point_Type => 'O', + + E_Ordinary_Fixed_Point_Subtype => 'O', + E_Decimal_Fixed_Point_Type => 'D', + E_Decimal_Fixed_Point_Subtype => 'D', + E_Floating_Point_Type => 'F', + E_Floating_Point_Subtype => 'F', + + E_Access_Type => 'P', + E_Access_Subtype => 'P', + E_Access_Attribute_Type => 'P', + E_Allocator_Type => ' ', + E_General_Access_Type => 'P', + + E_Access_Subprogram_Type => 'P', + E_Access_Protected_Subprogram_Type => 'P', + E_Anonymous_Access_Subprogram_Type => ' ', + E_Anonymous_Access_Protected_Subprogram_Type => ' ', + E_Anonymous_Access_Type => ' ', + + E_Array_Type => 'A', + E_Array_Subtype => 'A', + E_String_Type => 'S', + E_String_Subtype => 'S', + E_String_Literal_Subtype => ' ', + + E_Class_Wide_Type => 'C', + E_Class_Wide_Subtype => 'C', + E_Record_Type => 'R', + E_Record_Subtype => 'R', + E_Record_Type_With_Private => 'R', + + E_Record_Subtype_With_Private => 'R', + E_Private_Type => '+', + E_Private_Subtype => '+', + E_Limited_Private_Type => '+', + E_Limited_Private_Subtype => '+', + + E_Incomplete_Type => '+', + E_Incomplete_Subtype => '+', + E_Task_Type => 'T', + E_Task_Subtype => 'T', + E_Protected_Type => 'W', + + E_Protected_Subtype => 'W', + E_Exception_Type => ' ', + E_Subprogram_Type => ' ', + E_Enumeration_Literal => 'n', + E_Function => 'V', + + E_Operator => 'V', + E_Procedure => 'U', + E_Entry => 'Y', + E_Entry_Family => 'Y', + E_Block => 'q', + + E_Entry_Index_Parameter => '*', + E_Exception => 'X', + E_Generic_Function => 'v', + E_Generic_Package => 'k', + E_Generic_Procedure => 'u', + + E_Label => 'L', + E_Loop => 'l', + E_Return_Statement => ' ', + E_Package => 'K', + + -- The following entities are not ones to which we gather + -- cross-references, since it does not make sense to do so + -- (e.g. references to a package are to the spec, not the body) + -- Indeed the occurrence of the body entity is considered to + -- be a reference to the spec entity. + + E_Package_Body => ' ', + E_Protected_Object => ' ', + E_Protected_Body => ' ', + E_Task_Body => ' ', + E_Subprogram_Body => ' '); + + -- The following table is for information purposes. It shows the + -- use of each character appearing as an entity type. + + -- letter lower case usage UPPER CASE USAGE + + -- a array object (except string) array type (except string) + -- b Boolean object Boolean type + -- c class-wide object class-wide type + -- d decimal fixed-point object decimal fixed-point type + -- e non-Boolean enumeration object non_Boolean enumeration type + -- f floating-point object floating-point type + -- g C/C++ macro C/C++ fun-like macro + -- h Interface (Ada 2005) Abstract type + -- i signed integer object signed integer type + -- j C++ class object C++ class + -- k generic package package + -- l label on loop label on statement + -- m modular integer object modular integer type + -- n enumeration literal named number + -- o ordinary fixed-point object ordinary fixed-point type + -- p access object access type + -- q label on block C/C++ include file + -- r record object record type + -- s string object string type + -- t task object task type + -- u generic procedure procedure + -- v generic function or operator function or operator + -- w protected object protected type + -- x abstract procedure exception + -- y abstract function entry or entry family + -- z generic formal parameter (unused) + + -------------------------------------- + -- Handling of Imported Subprograms -- + -------------------------------------- + + -- If a pragma Import or Interface applies to a subprogram, the + -- pragma is the completion of the subprogram. This is noted in + -- the ALI file by making the occurrence of the subprogram in the + -- pragma into a body reference ('b') and by including the external + -- name of the subprogram and its language, bracketed by '<' and '>' + -- in that reference. For example: + -- + -- 3U13*elsewhere 4b21 + -- + -- indicates that procedure elsewhere, declared at line 3, has a + -- pragma Import at line 4, that its body is in C, and that the link + -- name as given in the pragma is "there". + + ----------------- + -- Subprograms -- + ----------------- + + procedure Generate_Definition (E : Entity_Id); + -- Records the definition of an entity + + procedure Generate_Operator_Reference + (N : Node_Id; + T : Entity_Id); + -- Node N is an operator node, whose entity has been set. If this entity + -- is a user defined operator (i.e. an operator not defined in package + -- Standard), then a reference to the operator is recorded at node N. + -- T is the operand type of the operator. A reference to the operator + -- is an implicit reference to the type, and that needs to be recorded + -- to avoid spurious warnings on unused entities, when the operator is + -- a renaming of a predefined operator. + + procedure Generate_Reference + (E : Entity_Id; + N : Node_Id; + Typ : Character := 'r'; + Set_Ref : Boolean := True; + Force : Boolean := False); + -- This procedure is called to record a reference. N is the location + -- of the reference and E is the referenced entity. Typ is one of: + -- + -- 'b' body entity + -- 'c' completion of incomplete or private type (see below) + -- 'e' end of construct + -- 'i' implicit reference + -- 'l' label on end line + -- 'm' modification + -- 'p' primitive operation + -- 'r' standard reference + -- 't' end of body + -- 'x' type extension + -- ' ' dummy reference (see below) + -- + -- Note: all references to incomplete or private types are to the + -- original (incomplete or private type) declaration. The full + -- declaration is treated as a reference with type 'c'. + -- + -- Note: all references to packages or subprograms are to the entity + -- for the spec. The entity in the body is treated as a reference + -- with type 'b'. Similar handling for references to subprogram formals. + -- + -- The call has no effect if N is not in the extended main source unit + -- This check is omitted for type 'e' references (where it is useful to + -- have structural scoping information for other than the main source), + -- and for 'p' (since we want to pick up inherited primitive operations + -- that are defined in other packages). + -- + -- The call also has no effect if any of the following conditions hold: + -- + -- cross-reference collection is disabled + -- entity does not come from source (and Force is False) + -- reference does not come from source (and Force is False) + -- the entity is not one for which xrefs are appropriate + -- the type letter is blank + -- the node N is not an identifier, defining identifier, or expanded name + -- the type is 'p' and the entity is not in the extended main source + -- + -- If all these conditions are met, then the Is_Referenced flag of E is set + -- (unless Set_Ref is False) and a cross-reference entry is recorded for + -- later output when Output_References is called. + -- + -- Note: the dummy space entry is for the convenience of some callers, + -- who find it easier to pass a space to suppress the entry than to do + -- a specific test. The call has no effect if the type is a space. + -- + -- The parameter Set_Ref is normally True, and indicates that in addition + -- to generating a cross-reference, the Referenced flag of the specified + -- entity should be set. If this parameter is False, then setting of the + -- Referenced flag is inhibited. + -- + -- The parameter Force is set to True to force a reference to be generated + -- even if Comes_From_Source is false. This is used for certain implicit + -- references, and also for end label references. + + procedure Generate_Reference_To_Formals (E : Entity_Id); + -- Add a reference to the definition of each formal on the line for + -- a subprogram. + + procedure Generate_Reference_To_Generic_Formals (E : Entity_Id); + -- Add a reference to the definition of each generic formal on the line + -- for a generic unit. + + procedure Output_References; + -- Output references to the current ali file + + procedure Initialize; + -- Initialize internal tables + +end Lib.Xref; diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb new file mode 100644 index 000000000..42d922fcc --- /dev/null +++ b/gcc/ada/lib.adb @@ -0,0 +1,1101 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Subprogram ordering not enforced in this unit +-- (because of some logical groupings). + +with Atree; use Atree; +with Einfo; use Einfo; +with Fname; use Fname; +with Output; use Output; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Stand; use Stand; +with Stringt; use Stringt; +with Tree_IO; use Tree_IO; +with Uname; use Uname; + +package body Lib is + + Switch_Storing_Enabled : Boolean := True; + -- Controlled by Enable_Switch_Storing/Disable_Switch_Storing + + ----------------------- + -- Local Subprograms -- + ----------------------- + + type SEU_Result is ( + Yes_Before, -- S1 is in same extended unit as S2 and appears before it + Yes_Same, -- S1 is in same extended unit as S2, Slocs are the same + Yes_After, -- S1 is in same extended unit as S2, and appears after it + No); -- S2 is not in same extended unit as S2 + + function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result; + -- Used by In_Same_Extended_Unit and Earlier_In_Extended_Unit. Returns + -- value as described above. + + function Get_Code_Or_Source_Unit + (S : Source_Ptr; + Unwind_Instances : Boolean) return Unit_Number_Type; + -- Common code for Get_Code_Unit (get unit of instantiation for location) + -- and Get_Source_Unit (get unit of template for location). + + -------------------------------------------- + -- Access Functions for Unit Table Fields -- + -------------------------------------------- + + function Cunit (U : Unit_Number_Type) return Node_Id is + begin + return Units.Table (U).Cunit; + end Cunit; + + function Cunit_Entity (U : Unit_Number_Type) return Entity_Id is + begin + return Units.Table (U).Cunit_Entity; + end Cunit_Entity; + + function Dependency_Num (U : Unit_Number_Type) return Nat is + begin + return Units.Table (U).Dependency_Num; + end Dependency_Num; + + function Dynamic_Elab (U : Unit_Number_Type) return Boolean is + begin + return Units.Table (U).Dynamic_Elab; + end Dynamic_Elab; + + function Error_Location (U : Unit_Number_Type) return Source_Ptr is + begin + return Units.Table (U).Error_Location; + end Error_Location; + + function Expected_Unit (U : Unit_Number_Type) return Unit_Name_Type is + begin + return Units.Table (U).Expected_Unit; + end Expected_Unit; + + function Fatal_Error (U : Unit_Number_Type) return Boolean is + begin + return Units.Table (U).Fatal_Error; + end Fatal_Error; + + function Generate_Code (U : Unit_Number_Type) return Boolean is + begin + return Units.Table (U).Generate_Code; + end Generate_Code; + + function Has_Allocator (U : Unit_Number_Type) return Boolean is + begin + return Units.Table (U).Has_Allocator; + end Has_Allocator; + + function Has_RACW (U : Unit_Number_Type) return Boolean is + begin + return Units.Table (U).Has_RACW; + end Has_RACW; + + function Is_Compiler_Unit (U : Unit_Number_Type) return Boolean is + begin + return Units.Table (U).Is_Compiler_Unit; + end Is_Compiler_Unit; + + function Ident_String (U : Unit_Number_Type) return Node_Id is + begin + return Units.Table (U).Ident_String; + end Ident_String; + + function Loading (U : Unit_Number_Type) return Boolean is + begin + return Units.Table (U).Loading; + end Loading; + + function Main_CPU (U : Unit_Number_Type) return Int is + begin + return Units.Table (U).Main_CPU; + end Main_CPU; + + function Main_Priority (U : Unit_Number_Type) return Int is + begin + return Units.Table (U).Main_Priority; + end Main_Priority; + + function Munit_Index (U : Unit_Number_Type) return Nat is + begin + return Units.Table (U).Munit_Index; + end Munit_Index; + + function OA_Setting (U : Unit_Number_Type) return Character is + begin + return Units.Table (U).OA_Setting; + end OA_Setting; + + function Source_Index (U : Unit_Number_Type) return Source_File_Index is + begin + return Units.Table (U).Source_Index; + end Source_Index; + + function Unit_File_Name (U : Unit_Number_Type) return File_Name_Type is + begin + return Units.Table (U).Unit_File_Name; + end Unit_File_Name; + + function Unit_Name (U : Unit_Number_Type) return Unit_Name_Type is + begin + return Units.Table (U).Unit_Name; + end Unit_Name; + + ------------------------------------------ + -- Subprograms to Set Unit Table Fields -- + ------------------------------------------ + + procedure Set_Cunit (U : Unit_Number_Type; N : Node_Id) is + begin + Units.Table (U).Cunit := N; + end Set_Cunit; + + procedure Set_Cunit_Entity (U : Unit_Number_Type; E : Entity_Id) is + begin + Units.Table (U).Cunit_Entity := E; + Set_Is_Compilation_Unit (E); + end Set_Cunit_Entity; + + procedure Set_Dynamic_Elab (U : Unit_Number_Type; B : Boolean := True) is + begin + Units.Table (U).Dynamic_Elab := B; + end Set_Dynamic_Elab; + + procedure Set_Error_Location (U : Unit_Number_Type; W : Source_Ptr) is + begin + Units.Table (U).Error_Location := W; + end Set_Error_Location; + + procedure Set_Fatal_Error (U : Unit_Number_Type; B : Boolean := True) is + begin + Units.Table (U).Fatal_Error := B; + end Set_Fatal_Error; + + procedure Set_Generate_Code (U : Unit_Number_Type; B : Boolean := True) is + begin + Units.Table (U).Generate_Code := B; + end Set_Generate_Code; + + procedure Set_Has_Allocator (U : Unit_Number_Type; B : Boolean := True) is + begin + Units.Table (U).Has_Allocator := B; + end Set_Has_Allocator; + + procedure Set_Has_RACW (U : Unit_Number_Type; B : Boolean := True) is + begin + Units.Table (U).Has_RACW := B; + end Set_Has_RACW; + + procedure Set_Is_Compiler_Unit + (U : Unit_Number_Type; + B : Boolean := True) + is + begin + Units.Table (U).Is_Compiler_Unit := B; + end Set_Is_Compiler_Unit; + + procedure Set_Ident_String (U : Unit_Number_Type; N : Node_Id) is + begin + Units.Table (U).Ident_String := N; + end Set_Ident_String; + + procedure Set_Loading (U : Unit_Number_Type; B : Boolean := True) is + begin + Units.Table (U).Loading := B; + end Set_Loading; + + procedure Set_Main_CPU (U : Unit_Number_Type; P : Int) is + begin + Units.Table (U).Main_CPU := P; + end Set_Main_CPU; + + procedure Set_Main_Priority (U : Unit_Number_Type; P : Int) is + begin + Units.Table (U).Main_Priority := P; + end Set_Main_Priority; + + procedure Set_OA_Setting (U : Unit_Number_Type; C : Character) is + begin + Units.Table (U).OA_Setting := C; + end Set_OA_Setting; + + procedure Set_Unit_Name (U : Unit_Number_Type; N : Unit_Name_Type) is + begin + Units.Table (U).Unit_Name := N; + end Set_Unit_Name; + + ------------------------------ + -- Check_Same_Extended_Unit -- + ------------------------------ + + function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result is + Sloc1 : Source_Ptr; + Sloc2 : Source_Ptr; + Sind1 : Source_File_Index; + Sind2 : Source_File_Index; + Inst1 : Source_Ptr; + Inst2 : Source_Ptr; + Unum1 : Unit_Number_Type; + Unum2 : Unit_Number_Type; + Unit1 : Node_Id; + Unit2 : Node_Id; + Depth1 : Nat; + Depth2 : Nat; + + begin + if S1 = No_Location or else S2 = No_Location then + return No; + + elsif S1 = Standard_Location then + if S2 = Standard_Location then + return Yes_Same; + else + return No; + end if; + + elsif S2 = Standard_Location then + return No; + end if; + + Sloc1 := S1; + Sloc2 := S2; + Unum1 := Get_Code_Unit (Sloc1); + Unum2 := Get_Code_Unit (Sloc2); + + loop + Sind1 := Get_Source_File_Index (Sloc1); + Sind2 := Get_Source_File_Index (Sloc2); + + if Sind1 = Sind2 then + if Sloc1 < Sloc2 then + return Yes_Before; + elsif Sloc1 > Sloc2 then + return Yes_After; + else + return Yes_Same; + end if; + end if; + + -- OK, the two nodes are in separate source elements, but this is not + -- decisive, because of the issue of subunits and instantiations. + + -- First we deal with subunits, since if the subunit is in an + -- instantiation, we know that the parent is in the corresponding + -- instantiation, since that is the only way we can have a subunit + -- that is part of an instantiation. + + Unit1 := Unit (Cunit (Unum1)); + Unit2 := Unit (Cunit (Unum2)); + + if Nkind (Unit1) = N_Subunit + and then Present (Corresponding_Stub (Unit1)) + then + -- Both in subunits. They could have a common ancestor. If they + -- do, then the deeper one must have a longer unit name. Replace + -- the deeper one with its corresponding stub, in order to find + -- nearest common ancestor, if any. + + if Nkind (Unit2) = N_Subunit + and then Present (Corresponding_Stub (Unit2)) + then + if Length_Of_Name (Unit_Name (Unum1)) < + Length_Of_Name (Unit_Name (Unum2)) + then + Sloc2 := Sloc (Corresponding_Stub (Unit2)); + Unum2 := Get_Source_Unit (Sloc2); + goto Continue; + + else + Sloc1 := Sloc (Corresponding_Stub (Unit1)); + Unum1 := Get_Source_Unit (Sloc1); + goto Continue; + end if; + + -- Nod1 in subunit, Nod2 not + + else + Sloc1 := Sloc (Corresponding_Stub (Unit1)); + Unum1 := Get_Source_Unit (Sloc1); + goto Continue; + end if; + + -- Nod2 in subunit, Nod1 not + + elsif Nkind (Unit2) = N_Subunit + and then Present (Corresponding_Stub (Unit2)) + then + Sloc2 := Sloc (Corresponding_Stub (Unit2)); + Unum2 := Get_Source_Unit (Sloc2); + goto Continue; + end if; + + -- At this stage we know that neither is a subunit, so we deal + -- with instantiations, since we could have a common ancestor + + Inst1 := Instantiation (Sind1); + Inst2 := Instantiation (Sind2); + + if Inst1 /= No_Location then + + -- Both are instantiations + + if Inst2 /= No_Location then + + Depth1 := Instantiation_Depth (Sloc1); + Depth2 := Instantiation_Depth (Sloc2); + + if Depth1 < Depth2 then + Sloc2 := Inst2; + Unum2 := Get_Source_Unit (Sloc2); + goto Continue; + + elsif Depth1 > Depth2 then + Sloc1 := Inst1; + Unum1 := Get_Source_Unit (Sloc1); + goto Continue; + + else + Sloc1 := Inst1; + Sloc2 := Inst2; + Unum1 := Get_Source_Unit (Sloc1); + Unum2 := Get_Source_Unit (Sloc2); + goto Continue; + end if; + + -- Only first node is in instantiation + + else + Sloc1 := Inst1; + Unum1 := Get_Source_Unit (Sloc1); + goto Continue; + end if; + + -- Only second node is instantiation + + elsif Inst2 /= No_Location then + Sloc2 := Inst2; + Unum2 := Get_Source_Unit (Sloc2); + goto Continue; + end if; + + -- No instantiations involved, so we are not in the same unit + -- However, there is one case still to check, namely the case + -- where one location is in the spec, and the other in the + -- corresponding body (the spec location is earlier). + + if Nkind (Unit1) = N_Subprogram_Body + or else + Nkind (Unit1) = N_Package_Body + then + if Library_Unit (Cunit (Unum1)) = Cunit (Unum2) then + return Yes_After; + end if; + + elsif Nkind (Unit2) = N_Subprogram_Body + or else + Nkind (Unit2) = N_Package_Body + then + if Library_Unit (Cunit (Unum2)) = Cunit (Unum1) then + return Yes_Before; + end if; + end if; + + -- If that special case does not occur, then we are certain that + -- the two locations are really in separate units. + + return No; + + <> + null; + end loop; + end Check_Same_Extended_Unit; + + ------------------------------- + -- Compilation_Switches_Last -- + ------------------------------- + + function Compilation_Switches_Last return Nat is + begin + return Compilation_Switches.Last; + end Compilation_Switches_Last; + + --------------------------- + -- Enable_Switch_Storing -- + --------------------------- + + procedure Enable_Switch_Storing is + begin + Switch_Storing_Enabled := True; + end Enable_Switch_Storing; + + ---------------------------- + -- Disable_Switch_Storing -- + ---------------------------- + + procedure Disable_Switch_Storing is + begin + Switch_Storing_Enabled := False; + end Disable_Switch_Storing; + + ------------------------------ + -- Earlier_In_Extended_Unit -- + ------------------------------ + + function Earlier_In_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is + begin + return Check_Same_Extended_Unit (S1, S2) = Yes_Before; + end Earlier_In_Extended_Unit; + + ---------------------------- + -- Entity_Is_In_Main_Unit -- + ---------------------------- + + function Entity_Is_In_Main_Unit (E : Entity_Id) return Boolean is + S : Entity_Id; + + begin + S := Scope (E); + + while S /= Standard_Standard loop + if S = Main_Unit_Entity then + return True; + elsif Ekind (S) = E_Package and then Is_Child_Unit (S) then + return False; + else + S := Scope (S); + end if; + end loop; + + return False; + end Entity_Is_In_Main_Unit; + + -------------------------- + -- Generic_May_Lack_ALI -- + -------------------------- + + function Generic_May_Lack_ALI (Sfile : File_Name_Type) return Boolean is + begin + -- We allow internal generic units to be used without having a + -- corresponding ALI files to help bootstrapping with older compilers + -- that did not support generating ALIs for such generics. It is safe + -- to do so because the only thing the generated code would contain + -- is the elaboration boolean, and we are careful to elaborate all + -- predefined units first anyway. + + return Is_Internal_File_Name + (Fname => Sfile, + Renamings_Included => True); + end Generic_May_Lack_ALI; + + ----------------------------- + -- Get_Code_Or_Source_Unit -- + ----------------------------- + + function Get_Code_Or_Source_Unit + (S : Source_Ptr; + Unwind_Instances : Boolean) return Unit_Number_Type + is + begin + -- Search table unless we have No_Location, which can happen if the + -- relevant location has not been set yet. Happens for example when + -- we obtain Sloc (Cunit (Main_Unit)) before it is set. + + if S /= No_Location then + declare + Source_File : Source_File_Index; + Source_Unit : Unit_Number_Type; + + begin + Source_File := Get_Source_File_Index (S); + + if Unwind_Instances then + while Template (Source_File) /= No_Source_File loop + Source_File := Template (Source_File); + end loop; + end if; + + Source_Unit := Unit (Source_File); + + if Source_Unit /= No_Unit then + return Source_Unit; + end if; + end; + end if; + + -- If S was No_Location, or was not in the table, we must be in the main + -- source unit (and the value has not been placed in the table yet), + -- or in one of the configuration pragma files. + + return Main_Unit; + end Get_Code_Or_Source_Unit; + + ------------------- + -- Get_Code_Unit -- + ------------------- + + function Get_Code_Unit (S : Source_Ptr) return Unit_Number_Type is + begin + return Get_Code_Or_Source_Unit (Top_Level_Location (S), + Unwind_Instances => False); + end Get_Code_Unit; + + function Get_Code_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is + begin + return Get_Code_Unit (Sloc (N)); + end Get_Code_Unit; + + ---------------------------- + -- Get_Compilation_Switch -- + ---------------------------- + + function Get_Compilation_Switch (N : Pos) return String_Ptr is + begin + if N <= Compilation_Switches.Last then + return Compilation_Switches.Table (N); + + else + return null; + end if; + end Get_Compilation_Switch; + + ---------------------------------- + -- Get_Cunit_Entity_Unit_Number -- + ---------------------------------- + + function Get_Cunit_Entity_Unit_Number + (E : Entity_Id) return Unit_Number_Type + is + begin + for U in Units.First .. Units.Last loop + if Cunit_Entity (U) = E then + return U; + end if; + end loop; + + -- If not in the table, must be the main source unit, and we just + -- have not got it put into the table yet. + + return Main_Unit; + end Get_Cunit_Entity_Unit_Number; + + --------------------------- + -- Get_Cunit_Unit_Number -- + --------------------------- + + function Get_Cunit_Unit_Number (N : Node_Id) return Unit_Number_Type is + begin + for U in Units.First .. Units.Last loop + if Cunit (U) = N then + return U; + end if; + end loop; + + -- If not in the table, must be a spec created for a main unit that is a + -- child subprogram body which we have not inserted into the table yet. + + if N = Library_Unit (Cunit (Main_Unit)) then + return Main_Unit; + + -- If it is anything else, something is seriously wrong, and we really + -- don't want to proceed, even if assertions are off, so we explicitly + -- raise an exception in this case to terminate compilation. + + else + raise Program_Error; + end if; + end Get_Cunit_Unit_Number; + + --------------------- + -- Get_Source_Unit -- + --------------------- + + function Get_Source_Unit (S : Source_Ptr) return Unit_Number_Type is + begin + return Get_Code_Or_Source_Unit (S, Unwind_Instances => True); + end Get_Source_Unit; + + function Get_Source_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is + begin + return Get_Source_Unit (Sloc (N)); + end Get_Source_Unit; + + -------------------------------- + -- In_Extended_Main_Code_Unit -- + -------------------------------- + + function In_Extended_Main_Code_Unit + (N : Node_Or_Entity_Id) return Boolean + is + begin + if Sloc (N) = Standard_Location then + return True; + + elsif Sloc (N) = No_Location then + return False; + + -- Special case Itypes to test the Sloc of the associated node. The + -- reason we do this is for possible calls from gigi after -gnatD + -- processing is complete in sprint. This processing updates the + -- sloc fields of all nodes in the tree, but itypes are not in the + -- tree so their slocs do not get updated. + + elsif Nkind (N) = N_Defining_Identifier + and then Is_Itype (N) + then + return In_Extended_Main_Code_Unit (Associated_Node_For_Itype (N)); + + -- Otherwise see if we are in the main unit + + elsif Get_Code_Unit (Sloc (N)) = Get_Code_Unit (Cunit (Main_Unit)) then + return True; + + -- Node may be in spec (or subunit etc) of main unit + + else + return + In_Same_Extended_Unit (N, Cunit (Main_Unit)); + end if; + end In_Extended_Main_Code_Unit; + + function In_Extended_Main_Code_Unit (Loc : Source_Ptr) return Boolean is + begin + if Loc = Standard_Location then + return True; + + elsif Loc = No_Location then + return False; + + -- Otherwise see if we are in the main unit + + elsif Get_Code_Unit (Loc) = Get_Code_Unit (Cunit (Main_Unit)) then + return True; + + -- Location may be in spec (or subunit etc) of main unit + + else + return + In_Same_Extended_Unit (Loc, Sloc (Cunit (Main_Unit))); + end if; + end In_Extended_Main_Code_Unit; + + ---------------------------------- + -- In_Extended_Main_Source_Unit -- + ---------------------------------- + + function In_Extended_Main_Source_Unit + (N : Node_Or_Entity_Id) return Boolean + is + Nloc : constant Source_Ptr := Sloc (N); + Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit)); + + begin + -- If parsing, then use the global flag to indicate result + + if Compiler_State = Parsing then + return Parsing_Main_Extended_Source; + + -- Special value cases + + elsif Nloc = Standard_Location then + return True; + + elsif Nloc = No_Location then + return False; + + -- Special case Itypes to test the Sloc of the associated node. The + -- reason we do this is for possible calls from gigi after -gnatD + -- processing is complete in sprint. This processing updates the + -- sloc fields of all nodes in the tree, but itypes are not in the + -- tree so their slocs do not get updated. + + elsif Nkind (N) = N_Defining_Identifier + and then Is_Itype (N) + then + return In_Extended_Main_Source_Unit (Associated_Node_For_Itype (N)); + + -- Otherwise compare original locations to see if in same unit + + else + return + In_Same_Extended_Unit + (Original_Location (Nloc), Original_Location (Mloc)); + end if; + end In_Extended_Main_Source_Unit; + + function In_Extended_Main_Source_Unit + (Loc : Source_Ptr) return Boolean + is + Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit)); + + begin + -- If parsing, then use the global flag to indicate result + + if Compiler_State = Parsing then + return Parsing_Main_Extended_Source; + + -- Special value cases + + elsif Loc = Standard_Location then + return True; + + elsif Loc = No_Location then + return False; + + -- Otherwise compare original locations to see if in same unit + + else + return + In_Same_Extended_Unit + (Original_Location (Loc), Original_Location (Mloc)); + end if; + end In_Extended_Main_Source_Unit; + + ------------------------ + -- In_Predefined_Unit -- + ------------------------ + + function In_Predefined_Unit (N : Node_Or_Entity_Id) return Boolean is + begin + return In_Predefined_Unit (Sloc (N)); + end In_Predefined_Unit; + + function In_Predefined_Unit (S : Source_Ptr) return Boolean is + Unit : constant Unit_Number_Type := Get_Source_Unit (S); + File : constant File_Name_Type := Unit_File_Name (Unit); + begin + return Is_Predefined_File_Name (File); + end In_Predefined_Unit; + + ----------------------- + -- In_Same_Code_Unit -- + ----------------------- + + function In_Same_Code_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean is + S1 : constant Source_Ptr := Sloc (N1); + S2 : constant Source_Ptr := Sloc (N2); + + begin + if S1 = No_Location or else S2 = No_Location then + return False; + + elsif S1 = Standard_Location then + return S2 = Standard_Location; + + elsif S2 = Standard_Location then + return False; + end if; + + return Get_Code_Unit (N1) = Get_Code_Unit (N2); + end In_Same_Code_Unit; + + --------------------------- + -- In_Same_Extended_Unit -- + --------------------------- + + function In_Same_Extended_Unit + (N1, N2 : Node_Or_Entity_Id) return Boolean + is + begin + return Check_Same_Extended_Unit (Sloc (N1), Sloc (N2)) /= No; + end In_Same_Extended_Unit; + + function In_Same_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is + begin + return Check_Same_Extended_Unit (S1, S2) /= No; + end In_Same_Extended_Unit; + + ------------------------- + -- In_Same_Source_Unit -- + ------------------------- + + function In_Same_Source_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean is + S1 : constant Source_Ptr := Sloc (N1); + S2 : constant Source_Ptr := Sloc (N2); + + begin + if S1 = No_Location or else S2 = No_Location then + return False; + + elsif S1 = Standard_Location then + return S2 = Standard_Location; + + elsif S2 = Standard_Location then + return False; + end if; + + return Get_Source_Unit (N1) = Get_Source_Unit (N2); + end In_Same_Source_Unit; + + ----------------------------- + -- Increment_Serial_Number -- + ----------------------------- + + function Increment_Serial_Number return Nat is + TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number; + begin + TSN := TSN + 1; + return TSN; + end Increment_Serial_Number; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Linker_Option_Lines.Init; + Notes.Init; + Load_Stack.Init; + Units.Init; + Compilation_Switches.Init; + end Initialize; + + --------------- + -- Is_Loaded -- + --------------- + + function Is_Loaded (Uname : Unit_Name_Type) return Boolean is + begin + for Unum in Units.First .. Units.Last loop + if Uname = Unit_Name (Unum) then + return True; + end if; + end loop; + + return False; + end Is_Loaded; + + --------------- + -- Last_Unit -- + --------------- + + function Last_Unit return Unit_Number_Type is + begin + return Units.Last; + end Last_Unit; + + ---------- + -- List -- + ---------- + + procedure List (File_Names_Only : Boolean := False) is separate; + + ---------- + -- Lock -- + ---------- + + procedure Lock is + begin + Linker_Option_Lines.Locked := True; + Load_Stack.Locked := True; + Units.Locked := True; + Linker_Option_Lines.Release; + Load_Stack.Release; + Units.Release; + end Lock; + + --------------- + -- Num_Units -- + --------------- + + function Num_Units return Nat is + begin + return Int (Units.Last) - Int (Main_Unit) + 1; + end Num_Units; + + ----------------- + -- Remove_Unit -- + ----------------- + + procedure Remove_Unit (U : Unit_Number_Type) is + begin + if U = Units.Last then + Units.Decrement_Last; + end if; + end Remove_Unit; + + ---------------------------------- + -- Replace_Linker_Option_String -- + ---------------------------------- + + procedure Replace_Linker_Option_String + (S : String_Id; Match_String : String) + is + begin + if Match_String'Length > 0 then + for J in 1 .. Linker_Option_Lines.Last loop + String_To_Name_Buffer (Linker_Option_Lines.Table (J).Option); + + if Match_String = Name_Buffer (1 .. Match_String'Length) then + Linker_Option_Lines.Table (J).Option := S; + return; + end if; + end loop; + end if; + + Store_Linker_Option_String (S); + end Replace_Linker_Option_String; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Tbl : in out Unit_Ref_Table) is separate; + + ------------------------------ + -- Store_Compilation_Switch -- + ------------------------------ + + procedure Store_Compilation_Switch (Switch : String) is + begin + if Switch_Storing_Enabled then + Compilation_Switches.Increment_Last; + Compilation_Switches.Table (Compilation_Switches.Last) := + new String'(Switch); + + -- Fix up --RTS flag which has been transformed by the gcc driver + -- into -fRTS + + if Switch'Last >= Switch'First + 4 + and then Switch (Switch'First .. Switch'First + 4) = "-fRTS" + then + Compilation_Switches.Table + (Compilation_Switches.Last) (Switch'First + 1) := '-'; + end if; + end if; + end Store_Compilation_Switch; + + -------------------------------- + -- Store_Linker_Option_String -- + -------------------------------- + + procedure Store_Linker_Option_String (S : String_Id) is + begin + Linker_Option_Lines.Append ((Option => S, Unit => Current_Sem_Unit)); + end Store_Linker_Option_String; + + ---------------- + -- Store_Note -- + ---------------- + + procedure Store_Note (N : Node_Id) is + begin + Notes.Append ((Pragma_Node => N, Unit => Current_Sem_Unit)); + end Store_Note; + + ------------------------------- + -- Synchronize_Serial_Number -- + ------------------------------- + + procedure Synchronize_Serial_Number is + TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number; + begin + TSN := TSN + 1; + end Synchronize_Serial_Number; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + N : Nat; + S : String_Ptr; + + begin + Units.Tree_Read; + + -- Read Compilation_Switches table. First release the memory occupied + -- by the previously loaded switches. + + for J in Compilation_Switches.First .. Compilation_Switches.Last loop + Free (Compilation_Switches.Table (J)); + end loop; + + Tree_Read_Int (N); + Compilation_Switches.Set_Last (N); + + for J in 1 .. N loop + Tree_Read_Str (S); + Compilation_Switches.Table (J) := S; + end loop; + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + begin + Units.Tree_Write; + + -- Write Compilation_Switches table + + Tree_Write_Int (Compilation_Switches.Last); + + for J in 1 .. Compilation_Switches.Last loop + Tree_Write_Str (Compilation_Switches.Table (J)); + end loop; + end Tree_Write; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock is + begin + Linker_Option_Lines.Locked := False; + Load_Stack.Locked := False; + Units.Locked := False; + end Unlock; + + ----------------- + -- Version_Get -- + ----------------- + + function Version_Get (U : Unit_Number_Type) return Word_Hex_String is + begin + return Get_Hex_String (Units.Table (U).Version); + end Version_Get; + + ------------------------ + -- Version_Referenced -- + ------------------------ + + procedure Version_Referenced (S : String_Id) is + begin + Version_Ref.Append (S); + end Version_Referenced; + +end Lib; diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads new file mode 100644 index 000000000..fa6fe0c19 --- /dev/null +++ b/gcc/ada/lib.ads @@ -0,0 +1,862 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines for accessing and outputting the library +-- information. It contains the routine to load subsidiary units. + +with Alloc; +with Namet; use Namet; +with Table; +with Types; use Types; + +package Lib is + + type Compiler_State_Type is (Parsing, Analyzing); + Compiler_State : Compiler_State_Type; + -- Indicates current state of compilation. This is used to implement the + -- function In_Extended_Main_Source_Unit. + + Parsing_Main_Extended_Source : Boolean := False; + -- Set True if we are currently parsing a file that is part of the main + -- extended source (the main unit, its spec, or one of its subunits). This + -- flag to implement In_Extended_Main_Source_Unit. + + Analysing_Subunit_Of_Main : Boolean := False; + -- Set to True when analyzing a subunit of the main source. When True, if + -- the subunit is preprocessed and -gnateG is specified, then the + -- preprocessed file (.prep) is written. + + -------------------------------------------- + -- General Approach to Library Management -- + -------------------------------------------- + + -- As described in GNote #1, when a unit is compiled, all its subsidiary + -- units are recompiled, including the following: + + -- (a) Corresponding spec for a body + -- (b) Parent spec of a child library spec + -- (d) With'ed specs + -- (d) Parent body of a subunit + -- (e) Subunits corresponding to any specified stubs + -- (f) Bodies of inlined subprograms that are called + -- (g) Bodies of generic subprograms or packages that are instantiated + -- (h) Bodies of packages containing either of the above two items + -- (i) Specs and bodies of runtime units + -- (j) Parent specs for with'ed child library units + + -- If a unit is being compiled only for syntax checking, then no subsidiary + -- units are loaded, the syntax check applies only to the main unit, + -- i.e. the one contained in the source submitted to the library. + + -- If a unit is being compiled for syntax and semantic checking, then only + -- cases (a)-(d) loads are performed, since the full semantic checking can + -- be carried out without needing (e)-(i) loads. In this case no object + -- file, or library information file, is generated, so the missing units + -- do not affect the results. + + -- Specifications of library subprograms, subunits, and generic specs + -- and bodies, can only be compiled in syntax/semantic checking mode, + -- since no code is ever generated directly for these units. In the case + -- of subunits, only the compilation of the ultimate parent unit generates + -- actual code. If a subunit is submitted to the compiler in syntax/ + -- semantic checking mode, the parent (or parents in the nested case) are + -- semantically checked only up to the point of the corresponding stub. + + -- If code is being generated, then all the above units are required, + -- although the need for bodies of inlined procedures can be suppressed + -- by the use of a switch that sets the mode to ignore pragma Inline + -- statements. + + -- The two main sections of the front end, Par and Sem, are recursive. + -- Compilation proceeds unit by unit making recursive calls as necessary. + -- The process is controlled from the GNAT main program, which makes calls + -- to Par and Sem sequence for the main unit. + + -- Par parses the given unit, and then, after the parse is complete, uses + -- the Par.Load subprogram to load all its subsidiary units in categories + -- (a)-(d) above, installing pointers to the loaded units in the parse + -- tree, as described in a later section of this spec. If any of these + -- required units is missing, a fatal error is signalled, so that no + -- attempt is made to run Sem in such cases, since it is assumed that + -- too many cascaded errors would result, and the confusion would not + -- be helpful. + + -- Following the call to Par on the main unit, the entire tree of required + -- units is thus loaded, and Sem is called on the main unit. The parameter + -- passed to Sem is the unit to be analyzed. The visibility table, which + -- is a single global structure, starts out containing only the entries + -- for the visible entities in Standard. Every call to Sem establishes a + -- new scope stack table, pushing an entry for Standard on entry to provide + -- the proper initial scope environment. + + -- Sem first proceeds to perform semantic analysis on the currently loaded + -- units as follows: + + -- In the case of a body (case (a) above), Sem analyzes the corresponding + -- spec, using a recursive call to Sem. As is always expected to be the + -- case with calls to Sem, any entities installed in the visibility table + -- are removed on exit from Sem, so that these entities have to be + -- reinstalled on return to continue the analysis of the body which of + -- course needs visibility of these entities. + -- + -- In the case of the parent of a child spec (case (b) above), a similar + -- call is made to Sem to analyze the parent. Again, on return, the + -- entities from the analyzed parent spec have to be installed in the + -- visibility table of the caller (the child unit), which must have + -- visibility to the entities in its parent spec. + + -- For with'ed specs (case (c) above), a recursive call to Sem is made + -- to analyze each spec in turn. After all the spec's have been analyzed, + -- but not till that point, the entities from all the with'ed units are + -- reinstalled in the visibility table so that the caller can proceed + -- with the analysis of the unit doing the with's with the necessary + -- entities made either potentially use visible or visible by selection + -- as needed. + + -- Case (d) arises when Sem is passed a subunit to analyze. This means + -- that the main unit is a subunit, and the unit passed to Sem is either + -- the main unit, or one of its ancestors that is still a subunit. Since + -- analysis must start at the top of the tree, Sem essentially cancels + -- the current call by immediately making a call to analyze the parent + -- (when this call is finished it immediately returns, so logically this + -- call is like a goto). The subunit will then be analyzed at the proper + -- time as described for the stub case. Note that we also turn off the + -- indication that code should be generated in this case, since the only + -- time we generate code for subunits is when compiling the main parent. + + -- Case (e), subunits corresponding to stubs, are handled as the stubs + -- are encountered. There are three sub-cases: + + -- If the subunit has already been loaded, then this means that the + -- main unit was a subunit, and we are back on our way down to it + -- after following the initial processing described for case (d). + -- In this case we analyze this particular subunit, as described + -- for the case where we are generating code, but when we get back + -- we are all done, since the rest of the parent is irrelevant. To + -- get out of the parent, we raise the exception Subunit_Found, which + -- is handled at the outer level of Sem. + + -- The cases where the subunit has not already been loaded correspond + -- to cases where the main unit was a parent. In this case the action + -- depends on whether or not we are generating code. If we are not + -- generating code, then this is the case where we can simply ignore + -- the subunit, since in checking mode we don't even want to insist + -- that the subunit exist, much less waste time checking it. + + -- If we are generating code, then we need to load and analyze + -- all subunits. This is achieved with a call to Lib.Load to load + -- and parse the unit, followed by processing that installs the + -- context clause of the subunit, analyzes the subunit, and then + -- removes the context clause (from the visibility chains of the + -- parent). Note that we do *not* do a recursive call to Sem in + -- this case, precisely because we need to do the analysis of the + -- subunit with the current visibility table and scope stack. + + -- Case (f) applies only to subprograms for which a pragma Inline is + -- given, providing that the compiler is operating in the mode where + -- pragma Inline's are activated. When the expander encounters a call + -- to such a subprogram, it loads the body of the subprogram if it has + -- not already been loaded, and calls Sem to process it. + + -- Case (g) is similar to case (f), except that the body of a generic + -- is unconditionally required, regardless of compiler mode settings. + -- As in the subprogram case, when the expander encounters a generic + -- instantiation, it loads the generic body of the subprogram if it + -- has not already been loaded, and calls Sem to process it. + + -- Case (h) arises when a package contains either an inlined subprogram + -- which is called, or a generic which is instantiated. In this case the + -- body of the package must be loaded and analyzed with a call to Sem. + + -- Case (i) is handled by adding implicit with clauses to the context + -- clauses of all units that potentially reference the relevant runtime + -- entities. Note that since we have the full set of units available, + -- the parser can always determine the set of runtime units that is + -- needed. These with clauses do not have associated use clauses, so + -- all references to the entities must be by selection. Once the with + -- clauses have been added, subsequent processing is as for normal + -- with clauses. + + -- Case (j) is also handled by adding appropriate implicit with clauses + -- to any unit that withs a child unit. Again there is no use clause, + -- and subsequent processing proceeds as for an explicit with clause. + + -- Sem thus completes the loading of all required units, except those + -- required for inline subprogram bodies or inlined generics. If any + -- of these load attempts fails, then the expander will not be called, + -- even if code was to be generated. If the load attempts all succeed + -- then the expander is called, though the attempt to generate code may + -- still fail if an error occurs during a load attempt for an inlined + -- body or a generic body. + + ------------------------------------------- + -- Special Handling of Subprogram Bodies -- + ------------------------------------------- + + -- A subprogram body (in an adb file) may stand for both a spec and a body. + -- A simple model (and one that was adopted through version 2.07) is simply + -- to assume that such an adb file acts as its own spec if no ads file is + -- is present. + + -- However, this is not correct. RM 10.1.4(4) requires that such a body + -- act as a spec unless a subprogram declaration of the same name is + -- already present. The correct interpretation of this in GNAT library + -- terms is to ignore an existing ads file of the same name unless this + -- ads file contains a subprogram declaration with the same name. + + -- If there is an ads file with a unit other than a subprogram declaration + -- with the same name, then a fatal message is output, noting that this + -- irrelevant file must be deleted before the body can be compiled. See + -- ACVC test CA1020D to see how this processing is required. + + ----------------- + -- Global Data -- + ----------------- + + Current_Sem_Unit : Unit_Number_Type := Main_Unit; + -- Unit number of unit currently being analyzed/expanded. This is set when + -- ever a new unit is entered, saving and restoring the old value, so that + -- it always reflects the unit currently being analyzed. The initial value + -- of Main_Unit ensures that a proper value is set initially, and in + -- particular for analysis of configuration pragmas in gnat.adc. + + Main_Unit_Entity : Entity_Id; + -- Entity of main unit, same as Cunit_Entity (Main_Unit) except where + -- Main_Unit is a body with a separate spec, in which case it is the + -- entity for the spec. + + ----------------- + -- Units Table -- + ----------------- + + -- The units table has an entry for each unit (source file) read in by the + -- current compilation. The table is indexed by the unit number value, + -- The first entry in the table, subscript Main_Unit, is for the main file. + -- Each entry in this units table contains the following data. + + -- Unit_File_Name + -- The name of the source file containing the unit. Set when the entry + -- is created by a call to Lib.Load, and then cannot be changed. + + -- Source_Index + -- The index in the source file table of the corresponding source file. + -- Set when the entry is created by a call to Lib.Load and then cannot + -- be changed. + + -- Munit_Index + -- The index of the unit within the file for multiple unit per file + -- mode. Set to zero in normal single unit per file mode. + + -- Error_Location + -- This is copied from the Sloc field of the Enode argument passed + -- to Load_Unit. It refers to the enclosing construct which caused + -- this unit to be loaded, e.g. most typically the with clause that + -- referenced the unit, and is used for error handling in Par.Load. + + -- Expected_Unit + -- This is the expected unit name for a file other than the main unit, + -- since these are cases where we load the unit using Lib.Load and we + -- know the unit that is expected. It must be the same as Unit_Name + -- if it is set (see test in Par.Load). Expected_Unit is set to + -- No_Name for the main unit. + + -- Unit_Name + -- The name of the unit. Initialized to No_Name by Lib.Load, and then + -- set by the parser when the unit is parsed to the unit name actually + -- found in the file (which should, in the absence of errors) be the + -- same name as Expected_Unit. + + -- Cunit + -- Pointer to the N_Compilation_Unit node. Initially set to Empty by + -- Lib.Load, and then reset to the required node by the parser when + -- the unit is parsed. + + -- Cunit_Entity + -- Pointer to the entity node for the compilation unit. Initially set + -- to Empty by Lib.Load, and then reset to the required entity by the + -- parser when the unit is parsed. + + -- Dependency_Num + -- This is the number of the unit within the generated dependency + -- lines (D lines in the ALI file) which are sorted into alphabetical + -- order. The number is ones origin, so a value of 2 refers to the + -- second generated D line. The Dependency_Number values are set + -- as the D lines are generated, and are used to generate proper + -- unit references in the generated xref information and SCO output. + + -- Dynamic_Elab + -- A flag indicating if this unit was compiled with dynamic elaboration + -- checks specified (as the result of using the -gnatE compilation + -- option or a pragma Elaboration_Checks (Dynamic). + + -- Fatal_Error + -- A flag that is initialized to False, and gets set to True if a fatal + -- error occurs during the processing of a unit. A fatal error is one + -- defined as serious enough to stop the next phase of the compiler + -- from running (i.e. fatal error during parsing stops semantics, + -- fatal error during semantics stops code generation). Note that + -- currently, errors of any kind cause Fatal_Error to be set, but + -- eventually perhaps only errors labeled as Fatal_Errors should be + -- this severe if we decide to try Sem on sources with minor errors. + + -- Generate_Code + -- This flag is set True for all units in the current file for which + -- code is to be generated. This includes the unit explicitly compiled, + -- together with its specification, and any subunits. + + -- Has_RACW + -- A Boolean flag, initially set to False when a unit entry is created, + -- and set to True if the unit defines a remote access to class wide + -- (RACW) object. This is used for controlling generation of the RA + -- attribute in the ali file. + + -- Is_Compiler_Unit + -- A Boolean flag, initially set False by default, set to True if a + -- pragma Compiler_Unit appears in the unit. + + -- Ident_String + -- N_String_Literal node from a valid pragma Ident that applies to + -- this unit. If no Ident pragma applies to the unit, then Empty. + + -- Loading + -- A flag that is used to catch circular WITH dependencies. It is set + -- True when an entry is initially created in the file table, and set + -- False when the load is completed, or ends with an error. + + -- Main_Priority + -- This field is used to indicate the priority of a possible main + -- program, as set by a pragma Priority. A value of -1 indicates + -- that the default priority is to be used (and is also used for + -- entries that do not correspond to possible main programs). + + -- Main_CPU + -- This field is used to indicate the affinity of a possible main + -- program, as set by a pragma CPU. A value of -1 indicates + -- that the default affinity is to be used (and is also used for + -- entries that do not correspond to possible main programs). + + -- Has_Allocator + -- This flag is set if a subprogram unit has an allocator after the + -- BEGIN (it is used to set the AB flag in the M ALI line). + + -- OA_Setting + -- This is a character field containing L if Optimize_Alignment mode + -- was set locally, and O/T/S for Off/Time/Space default if not. + + -- Serial_Number + -- This field holds a serial number used by New_Internal_Name to + -- generate unique temporary numbers on a unit by unit basis. The + -- only access to this field is via the Increment_Serial_Number + -- routine which increments the current value and returns it. This + -- serial number is separate for each unit. + + -- Version + -- This field holds the version of the unit, which is computed as + -- the exclusive or of the checksums of this unit, and all its + -- semantically dependent units. Access to the version number field + -- is not direct, but is done through the routines described below. + -- When a unit table entry is created, this field is initialized to + -- the checksum of the corresponding source file. Version_Update is + -- then called to reflect the contributions of any unit on which this + -- unit is semantically dependent. + + -- The units table is reset to empty at the start of the compilation of + -- each main unit by Lib.Initialize. Entries are then added by calls to + -- the Lib.Load procedure. The following subprograms are used to access + -- and modify entries in the Units table. Individual entries are accessed + -- using a unit number value which ranges from Main_Unit (the first entry, + -- which is always for the current main unit) to Last_Unit. + + Default_Main_Priority : constant Int := -1; + -- Value used in Main_Priority field to indicate default main priority + + Default_Main_CPU : constant Int := -1; + -- Value used in Main_CPU field to indicate default main affinity + + function Cunit (U : Unit_Number_Type) return Node_Id; + function Cunit_Entity (U : Unit_Number_Type) return Entity_Id; + function Dependency_Num (U : Unit_Number_Type) return Nat; + function Dynamic_Elab (U : Unit_Number_Type) return Boolean; + function Error_Location (U : Unit_Number_Type) return Source_Ptr; + function Expected_Unit (U : Unit_Number_Type) return Unit_Name_Type; + function Fatal_Error (U : Unit_Number_Type) return Boolean; + function Generate_Code (U : Unit_Number_Type) return Boolean; + function Ident_String (U : Unit_Number_Type) return Node_Id; + function Has_Allocator (U : Unit_Number_Type) return Boolean; + function Has_RACW (U : Unit_Number_Type) return Boolean; + function Is_Compiler_Unit (U : Unit_Number_Type) return Boolean; + function Loading (U : Unit_Number_Type) return Boolean; + function Main_CPU (U : Unit_Number_Type) return Int; + function Main_Priority (U : Unit_Number_Type) return Int; + function Munit_Index (U : Unit_Number_Type) return Nat; + function OA_Setting (U : Unit_Number_Type) return Character; + function Source_Index (U : Unit_Number_Type) return Source_File_Index; + function Unit_File_Name (U : Unit_Number_Type) return File_Name_Type; + function Unit_Name (U : Unit_Number_Type) return Unit_Name_Type; + -- Get value of named field from given units table entry + + procedure Set_Cunit (U : Unit_Number_Type; N : Node_Id); + procedure Set_Cunit_Entity (U : Unit_Number_Type; E : Entity_Id); + procedure Set_Dynamic_Elab (U : Unit_Number_Type; B : Boolean := True); + procedure Set_Error_Location (U : Unit_Number_Type; W : Source_Ptr); + procedure Set_Fatal_Error (U : Unit_Number_Type; B : Boolean := True); + procedure Set_Generate_Code (U : Unit_Number_Type; B : Boolean := True); + procedure Set_Has_RACW (U : Unit_Number_Type; B : Boolean := True); + procedure Set_Has_Allocator (U : Unit_Number_Type; B : Boolean := True); + procedure Set_Is_Compiler_Unit (U : Unit_Number_Type; B : Boolean := True); + procedure Set_Ident_String (U : Unit_Number_Type; N : Node_Id); + procedure Set_Loading (U : Unit_Number_Type; B : Boolean := True); + procedure Set_Main_CPU (U : Unit_Number_Type; P : Int); + procedure Set_Main_Priority (U : Unit_Number_Type; P : Int); + procedure Set_OA_Setting (U : Unit_Number_Type; C : Character); + procedure Set_Unit_Name (U : Unit_Number_Type; N : Unit_Name_Type); + -- Set value of named field for given units table entry. Note that we + -- do not have an entry for each possible field, since some of the fields + -- can only be set by specialized interfaces (defined below). + + function Version_Get (U : Unit_Number_Type) return Word_Hex_String; + -- Returns the version as a string with 8 hex digits (upper case letters) + + function Last_Unit return Unit_Number_Type; + -- Unit number of last allocated unit + + function Num_Units return Nat; + -- Number of units currently in unit table + + procedure Remove_Unit (U : Unit_Number_Type); + -- Remove unit U from unit table. Currently this is effective only + -- if U is the last unit currently stored in the unit table. + + function Entity_Is_In_Main_Unit (E : Entity_Id) return Boolean; + -- Returns True if the entity E is declared in the main unit, or, in + -- its corresponding spec, or one of its subunits. Entities declared + -- within generic instantiations return True if the instantiation is + -- itself "in the main unit" by this definition. Otherwise False. + + function Get_Source_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type; + pragma Inline (Get_Source_Unit); + function Get_Source_Unit (S : Source_Ptr) return Unit_Number_Type; + -- Return unit number of file identified by given source pointer value. + -- This call must always succeed, since any valid source pointer value + -- belongs to some previously loaded module. If the given source pointer + -- value is within an instantiation, this function returns the unit number + -- of the template, i.e. the unit containing the source code corresponding + -- to the given Source_Ptr value. The version taking a Node_Id argument, N, + -- simply applies the function to Sloc (N). + + function Get_Code_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type; + pragma Inline (Get_Code_Unit); + function Get_Code_Unit (S : Source_Ptr) return Unit_Number_Type; + -- This is like Get_Source_Unit, except that in the instantiation case, + -- it uses the location of the top level instantiation, rather than the + -- template, so it returns the unit number containing the code that + -- corresponds to the node N, or the source location S. + + function In_Same_Source_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean; + pragma Inline (In_Same_Source_Unit); + -- Determines if the two nodes or entities N1 and N2 are in the same + -- source unit, the criterion being that Get_Source_Unit yields the + -- same value for each argument. + + function In_Same_Code_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean; + pragma Inline (In_Same_Code_Unit); + -- Determines if the two nodes or entities N1 and N2 are in the same + -- code unit, the criterion being that Get_Code_Unit yields the same + -- value for each argument. + + function In_Same_Extended_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean; + pragma Inline (In_Same_Extended_Unit); + -- Determines if two nodes or entities N1 and N2 are in the same + -- extended unit, where an extended unit is defined as a unit and all + -- its subunits (considered recursively, i.e. subunits of subunits are + -- included). Returns true if S1 and S2 are in the same extended unit + -- and False otherwise. + + function In_Same_Extended_Unit (S1, S2 : Source_Ptr) return Boolean; + pragma Inline (In_Same_Extended_Unit); + -- Determines if the two source locations S1 and S2 are in the same + -- extended unit, where an extended unit is defined as a unit and all + -- its subunits (considered recursively, i.e. subunits of subunits are + -- included). Returns true if S1 and S2 are in the same extended unit + -- and False otherwise. + + function In_Extended_Main_Code_Unit + (N : Node_Or_Entity_Id) return Boolean; + -- Return True if the node is in the generated code of the extended main + -- unit, defined as the main unit, its specification (if any), and all + -- its subunits (considered recursively). Units for which this enquiry + -- returns True are those for which code will be generated. Nodes from + -- instantiations are included in the extended main unit for this call. + -- If the main unit is itself a subunit, then the extended main unit + -- includes its parent unit, and the parent unit spec if it is separate. + + function In_Extended_Main_Code_Unit (Loc : Source_Ptr) return Boolean; + -- Same function as above, but argument is a source pointer rather + -- than a node. + + function In_Extended_Main_Source_Unit + (N : Node_Or_Entity_Id) return Boolean; + -- Return True if the node is in the source text of the extended main + -- unit, defined as the main unit, its specification (if any), and all + -- its subunits (considered recursively). Units for which this enquiry + -- returns True are those for which code will be generated. This differs + -- from In_Extended_Main_Code_Unit only in that instantiations are not + -- included for the purposes of this call. If the main unit is itself + -- a subunit, then the extended main unit includes its parent unit, + -- and the parent unit spec if it is separate. + + function In_Extended_Main_Source_Unit (Loc : Source_Ptr) return Boolean; + -- Same function as above, but argument is a source pointer + + function In_Predefined_Unit (N : Node_Or_Entity_Id) return Boolean; + -- Returns True if the given node or entity appears within the source text + -- of a predefined unit (i.e. within Ada, Interfaces, System or within one + -- of the descendent packages of one of these three packages). + + function In_Predefined_Unit (S : Source_Ptr) return Boolean; + -- Same function as above but argument is a source pointer + + function Earlier_In_Extended_Unit (S1, S2 : Source_Ptr) return Boolean; + -- Given two Sloc values for which In_Same_Extended_Unit is true, determine + -- if S1 appears before S2. Returns True if S1 appears before S2, and False + -- otherwise. The result is undefined if S1 and S2 are not in the same + -- extended unit. Note: this routine will not give reliable results if + -- called after Sprint has been called with -gnatD set. + + function Compilation_Switches_Last return Nat; + -- Return the count of stored compilation switches + + function Get_Compilation_Switch (N : Pos) return String_Ptr; + -- Return the Nth stored compilation switch, or null if less than N + -- switches have been stored. Used by ASIS and back ends written in Ada. + + function Get_Cunit_Unit_Number (N : Node_Id) return Unit_Number_Type; + -- Return unit number of the unit whose N_Compilation_Unit node is the + -- one passed as an argument. This must always succeed since the node + -- could not have been built without making a unit table entry. + + function Get_Cunit_Entity_Unit_Number + (E : Entity_Id) return Unit_Number_Type; + -- Return unit number of the unit whose compilation unit spec entity is + -- the one passed as an argument. This must always succeed since the + -- entity could not have been built without making a unit table entry. + + function Increment_Serial_Number return Nat; + -- Increment Serial_Number field for current unit, and return the + -- incremented value. + + procedure Synchronize_Serial_Number; + -- This function increments the Serial_Number field for the current unit + -- but does not return the incremented value. This is used when there + -- is a situation where one path of control increments a serial number + -- (using Increment_Serial_Number), and the other path does not and it is + -- important to keep the serial numbers synchronized in the two cases (e.g. + -- when the references in a package and a client must be kept consistent). + + procedure Replace_Linker_Option_String + (S : String_Id; + Match_String : String); + -- Replace an existing Linker_Option if the prefix Match_String matches, + -- otherwise call Store_Linker_Option_String. + + procedure Store_Compilation_Switch (Switch : String); + -- Called to register a compilation switch, either front-end or back-end, + -- which may influence the generated output file(s). Switch is the text of + -- the switch to store (except that -fRTS gets changed back to --RTS). + + procedure Enable_Switch_Storing; + -- Enable registration of switches by Store_Compilation_Switch. Used to + -- avoid registering switches added automatically by the gcc driver at the + -- beginning of the command line. + + procedure Disable_Switch_Storing; + -- Disable registration of switches by Store_Compilation_Switch. Used to + -- avoid registering switches added automatically by the gcc driver at the + -- end of the command line. + + procedure Store_Linker_Option_String (S : String_Id); + -- This procedure is called to register the string from a pragma + -- Linker_Option. The argument is the Id of the string to register. + + procedure Store_Note (N : Node_Id); + -- This procedure is called to register a pragma N for which a notes + -- entry is required. + + procedure Initialize; + -- Initialize internal tables + + procedure Lock; + -- Lock internal tables before calling back end + + procedure Unlock; + -- Unlock internal tables, in cases where the back end needs to modify them + + procedure Tree_Read; + -- Initializes internal tables from current tree file using the relevant + -- Table.Tree_Read routines. + + procedure Tree_Write; + -- Writes out internal tables to current tree file using the relevant + -- Table.Tree_Write routines. + + function Is_Loaded (Uname : Unit_Name_Type) return Boolean; + -- Determines if unit with given name is already loaded, i.e. there is + -- already an entry in the file table with this unit name for which the + -- corresponding file was found and parsed. Note that the Fatal_Error flag + -- of this entry must be checked before proceeding with further processing. + + procedure Version_Referenced (S : String_Id); + -- This routine is called from Exp_Attr to register the use of a Version + -- or Body_Version attribute. The argument is the external name used to + -- access the version string. + + procedure List (File_Names_Only : Boolean := False); + -- Lists units in active library (i.e. generates output consisting of a + -- sorted listing of the units represented in File table, except for the + -- main unit). If File_Names_Only is set to True, then the list includes + -- only file names, and no other information. Otherwise the unit name and + -- time stamp are also output. File_Names_Only also restricts the list to + -- exclude any predefined files. + + function Generic_May_Lack_ALI (Sfile : File_Name_Type) return Boolean; + -- Generic units must be separately compiled. Since we always use + -- macro substitution for generics, the resulting object file is a dummy + -- one with no code, but the ALI file has the normal form, and we need + -- this ALI file so that the binder can work out a correct order of + -- elaboration. + + -- However, ancient versions of GNAT used to not generate code or ALI + -- files for generic units, and this would yield complex order of + -- elaboration issues. These were fixed in GNAT 3.10. The support for not + -- compiling language-defined library generics was retained nonetheless + -- to facilitate bootstrap. Specifically, it is convenient to have + -- the same list of files to be compiled for all stages. So, if the + -- bootstrap compiler does not generate code for a given file, then + -- the stage1 compiler (and binder) also must deal with the case of + -- that file not being compiled. The predicate Generic_May_Lack_ALI is + -- True for those generic units for which missing ALI files are allowed. + +private + pragma Inline (Cunit); + pragma Inline (Cunit_Entity); + pragma Inline (Dependency_Num); + pragma Inline (Fatal_Error); + pragma Inline (Generate_Code); + pragma Inline (Has_Allocator); + pragma Inline (Has_RACW); + pragma Inline (Is_Compiler_Unit); + pragma Inline (Increment_Serial_Number); + pragma Inline (Loading); + pragma Inline (Main_CPU); + pragma Inline (Main_Priority); + pragma Inline (Munit_Index); + pragma Inline (OA_Setting); + pragma Inline (Set_Cunit); + pragma Inline (Set_Cunit_Entity); + pragma Inline (Set_Fatal_Error); + pragma Inline (Set_Generate_Code); + pragma Inline (Set_Has_Allocator); + pragma Inline (Set_Has_RACW); + pragma Inline (Set_Loading); + pragma Inline (Set_Main_CPU); + pragma Inline (Set_Main_Priority); + pragma Inline (Set_OA_Setting); + pragma Inline (Set_Unit_Name); + pragma Inline (Source_Index); + pragma Inline (Unit_File_Name); + pragma Inline (Unit_Name); + + type Unit_Record is record + Unit_File_Name : File_Name_Type; + Unit_Name : Unit_Name_Type; + Munit_Index : Nat; + Expected_Unit : Unit_Name_Type; + Source_Index : Source_File_Index; + Cunit : Node_Id; + Cunit_Entity : Entity_Id; + Dependency_Num : Int; + Ident_String : Node_Id; + Main_Priority : Int; + Main_CPU : Int; + Serial_Number : Nat; + Version : Word; + Error_Location : Source_Ptr; + Fatal_Error : Boolean; + Generate_Code : Boolean; + Has_RACW : Boolean; + Is_Compiler_Unit : Boolean; + Dynamic_Elab : Boolean; + Loading : Boolean; + Has_Allocator : Boolean; + OA_Setting : Character; + end record; + + -- The following representation clause ensures that the above record + -- has no holes. We do this so that when instances of this record are + -- written by Tree_Gen, we do not write uninitialized values to the file. + + for Unit_Record use record + Unit_File_Name at 0 range 0 .. 31; + Unit_Name at 4 range 0 .. 31; + Munit_Index at 8 range 0 .. 31; + Expected_Unit at 12 range 0 .. 31; + Source_Index at 16 range 0 .. 31; + Cunit at 20 range 0 .. 31; + Cunit_Entity at 24 range 0 .. 31; + Dependency_Num at 28 range 0 .. 31; + Ident_String at 32 range 0 .. 31; + Main_Priority at 36 range 0 .. 31; + Main_CPU at 40 range 0 .. 31; + Serial_Number at 44 range 0 .. 31; + Version at 48 range 0 .. 31; + Error_Location at 52 range 0 .. 31; + Fatal_Error at 56 range 0 .. 7; + Generate_Code at 57 range 0 .. 7; + Has_RACW at 58 range 0 .. 7; + Dynamic_Elab at 59 range 0 .. 7; + Is_Compiler_Unit at 60 range 0 .. 7; + OA_Setting at 61 range 0 .. 7; + Loading at 62 range 0 .. 7; + Has_Allocator at 63 range 0 .. 7; + end record; + + for Unit_Record'Size use 64 * 8; + -- This ensures that we did not leave out any fields + + package Units is new Table.Table ( + Table_Component_Type => Unit_Record, + Table_Index_Type => Unit_Number_Type, + Table_Low_Bound => Main_Unit, + Table_Initial => Alloc.Units_Initial, + Table_Increment => Alloc.Units_Increment, + Table_Name => "Units"); + + -- The following table stores strings from pragma Linker_Option lines + + type Linker_Option_Entry is record + Option : String_Id; + -- The string for the linker option line + + Unit : Unit_Number_Type; + -- The unit from which the linker option comes + end record; + + package Linker_Option_Lines is new Table.Table ( + Table_Component_Type => Linker_Option_Entry, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => Alloc.Linker_Option_Lines_Initial, + Table_Increment => Alloc.Linker_Option_Lines_Increment, + Table_Name => "Linker_Option_Lines"); + + -- The following table stores references to pragmas that generate Notes + + type Notes_Entry is record + Pragma_Node : Node_Id; + Unit : Unit_Number_Type; + end record; + + package Notes is new Table.Table ( + Table_Component_Type => Notes_Entry, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => Alloc.Notes_Initial, + Table_Increment => Alloc.Notes_Increment, + Table_Name => "Notes"); + + -- The following table records the compilation switches used to compile + -- the main unit. The table includes only switches. It excludes -o + -- switches as well as artifacts of the gcc/gnat1 interface such as + -- -quiet, -dumpbase, or -auxbase. + + -- This table is set as part of the compiler argument scanning in + -- Back_End. It can also be reset in -gnatc mode from the data in an + -- existing ali file, and is read and written by the Tree_Read and + -- Tree_Write routines for ASIS. + + package Compilation_Switches is new Table.Table ( + Table_Component_Type => String_Ptr, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 30, + Table_Increment => 100, + Table_Name => "Compilation_Switches"); + + Load_Msg_Sloc : Source_Ptr; + -- Location for placing error messages (a token in the main source text) + -- This is set from Sloc (Enode) by Load only in the case where this Sloc + -- is in the main source file. This ensures that not found messages and + -- circular dependency messages reference the original with in this source. + + type Unit_Ref_Table is array (Pos range <>) of Unit_Number_Type; + -- Type to hold list of indirect references to unit number table + + type Load_Stack_Entry is record + Unit_Number : Unit_Number_Type; + With_Node : Node_Id; + end record; + + -- The Load_Stack table contains a list of unit numbers (indexes into the + -- unit table) of units being loaded on a single dependency chain, and a + -- flag to indicate whether this unit is loaded through a limited_with + -- clause. The First entry is the main unit. The second entry, if present + -- is a unit on which the first unit depends, etc. This stack is used to + -- generate error messages showing the dependency chain if a file is not + -- found, or whether a true circular dependency exists. The Load_Unit + -- function makes an entry in this table when it is called, and removes + -- the entry just before it returns. + + package Load_Stack is new Table.Table ( + Table_Component_Type => Load_Stack_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.Load_Stack_Initial, + Table_Increment => Alloc.Load_Stack_Increment, + Table_Name => "Load_Stack"); + + procedure Sort (Tbl : in out Unit_Ref_Table); + -- This procedure sorts the given unit reference table in order of + -- ascending unit names, where the ordering relation is as described + -- by the comparison routines provided by package Uname. + + -- The Version_Ref table records Body_Version and Version attribute + -- references. The entries are simply the strings for the external + -- names that correspond to the referenced values. + + package Version_Ref is new Table.Table ( + Table_Component_Type => String_Id, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Version_Ref"); + +end Lib; diff --git a/gcc/ada/link.c b/gcc/ada/link.c new file mode 100644 index 000000000..62dd683f1 --- /dev/null +++ b/gcc/ada/link.c @@ -0,0 +1,256 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * L I N K * + * * + * C Implementation File * + * * + * Copyright (C) 1992-2009, Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. * + * * + * As a special exception under Section 7 of GPL version 3, you are granted * + * additional permissions described in the GCC Runtime Library Exception, * + * version 3.1, as published by the Free Software Foundation. * + * * + * You should have received a copy of the GNU General Public License and * + * a copy of the GCC Runtime Library Exception along with this program; * + * see the files COPYING3 and COPYING.RUNTIME respectively. If 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 contains host-specific parameters describing the behavior */ +/* of the linker. It is used by gnatlink as well as all tools that use */ +/* Mlib. */ + +#include + +/* objlist_file_supported is set to 1 when the system linker allows */ +/* response file, that is a file that contains the list of object files. */ +/* This is useful on systems where the command line length is limited, */ +/* meaning that putting all the object files on the command line can */ +/* result in an unacceptable limit on the number of files. */ + +/* object_file_option denotes the system dependent linker option which */ +/* allows object file names to be placed in a file and then passed to */ +/* the linker. object_file_option must be set if objlist_file_supported */ +/* is set to 1. */ + +/* link_max is a conservative system specific threshold (in bytes) of the */ +/* argument length passed to the linker which will trigger a file being */ +/* used instead of the command line directly. If the argument length is */ +/* greater than this threshold, then an objlist_file will be generated */ +/* and object_file_option and objlist_file_supported must be set. If */ +/* objlist_file_supported is set to 0 (unsupported), then link_max is */ +/* set to 2**31-1 so that the limit will never be exceeded. */ + +/* run_path_option is the system dependent linker option which specifies */ +/* the run time path to use when loading dynamic libraries. This should */ +/* be set to the null string if the system does not support dynamic */ +/* loading of libraries. */ + +/* shared_libgnat_default gives the system dependent link method that */ +/* be used by default for linking libgnat (shared or static) */ + +/* shared_libgcc_default gives the system dependent link method that */ +/* be used by default for linking libgcc (shared or static) */ + +/* using_gnu_linker is set to 1 when the GNU linker is used under this */ +/* target. */ + +/* separate_run_path_options is set to 1 when separate "rpath" arguments */ +/* must be passed to the linker for each directory in the rpath. */ + +/* default_libgcc_subdir is the subdirectory name (from the installation */ +/* root) where we may find a shared libgcc to use by default. */ + +/* RESPONSE FILE & GNU LINKER */ +/* -------------------------- */ +/* objlist_file_supported and using_gnu_link used together tell gnatlink */ +/* to generate a GNU style response file. Note that object_file_option */ +/* must be set to "" in this case, since no option is required for a */ +/* response file to be passed to GNU ld. With a GNU linker we use the */ +/* linker script to implement the response file feature. Any file passed */ +/* in the GNU ld command line with an unknown extension is supposed to be */ +/* a linker script. Each linker script augment the current configuration. */ +/* The format of such response file is as follow : */ +/* INPUT (obj1.p obj2.o ...) */ + +#define SHARED 'H' +#define STATIC 'T' + +#if defined (__osf__) +const char *__gnat_object_file_option = "-Wl,-input,"; +const char *__gnat_run_path_option = "-Wl,-rpath,"; +int __gnat_link_max = 10000; +unsigned char __gnat_objlist_file_supported = 1; +char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = STATIC; +unsigned char __gnat_using_gnu_linker = 0; +const char *__gnat_object_library_extension = ".a"; +unsigned char __gnat_separate_run_path_options = 0; +const char *__gnat_default_libgcc_subdir = "lib"; + +#elif defined (sgi) +const char *__gnat_object_file_option = "-Wl,-objectlist,"; +const char *__gnat_run_path_option = "-Wl,-rpath,"; +int __gnat_link_max = 5000; +unsigned char __gnat_objlist_file_supported = 1; +char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = STATIC; +unsigned char __gnat_using_gnu_linker = 0; +const char *__gnat_object_library_extension = ".a"; +unsigned char __gnat_separate_run_path_options = 0; + +/* The libgcc_s locations have changed in GCC 4. The n32 version used + to be in "lib", it moved to "lib32" and "lib" became the home of + the o32 version. We are targetting n32 by default, so ... */ +#if __GNUC__ < 4 +const char *__gnat_default_libgcc_subdir = "lib"; +#else +const char *__gnat_default_libgcc_subdir = "lib32"; +#endif + +#elif defined (__WIN32) +const char *__gnat_object_file_option = ""; +const char *__gnat_run_path_option = ""; +int __gnat_link_max = 30000; +unsigned char __gnat_objlist_file_supported = 1; +char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = STATIC; +unsigned char __gnat_using_gnu_linker = 1; +const char *__gnat_object_library_extension = ".a"; +unsigned char __gnat_separate_run_path_options = 0; +const char *__gnat_default_libgcc_subdir = "lib"; + +#elif defined (__hpux__) +const char *__gnat_object_file_option = "-Wl,-c,"; +const char *__gnat_run_path_option = "-Wl,+b,"; +int __gnat_link_max = 5000; +unsigned char __gnat_objlist_file_supported = 1; +char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = STATIC; +unsigned char __gnat_using_gnu_linker = 0; +const char *__gnat_object_library_extension = ".a"; +unsigned char __gnat_separate_run_path_options = 0; +const char *__gnat_default_libgcc_subdir = "lib"; + +#elif defined (_AIX) +const char *__gnat_object_file_option = "-Wl,-f,"; +const char *__gnat_run_path_option = ""; +int __gnat_link_max = 15000; +const unsigned char __gnat_objlist_file_supported = 1; +char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = STATIC; +unsigned char __gnat_using_gnu_linker = 0; +const char *__gnat_object_library_extension = ".a"; +unsigned char __gnat_separate_run_path_options = 0; +const char *__gnat_default_libgcc_subdir = "lib"; + +#elif defined (VMS) +const char *__gnat_object_file_option = ""; +const char *__gnat_run_path_option = ""; +char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = STATIC; +int __gnat_link_max = 2147483647; +unsigned char __gnat_objlist_file_supported = 0; +unsigned char __gnat_using_gnu_linker = 0; +const char *__gnat_object_library_extension = ".olb"; +unsigned char __gnat_separate_run_path_options = 0; +const char *__gnat_default_libgcc_subdir = "lib"; + +#elif defined (sun) +const char *__gnat_object_file_option = ""; +const char *__gnat_run_path_option = "-Wl,-R"; +char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = STATIC; +int __gnat_link_max = 2147483647; +unsigned char __gnat_objlist_file_supported = 0; +unsigned char __gnat_using_gnu_linker = 0; +const char *__gnat_object_library_extension = ".a"; +unsigned char __gnat_separate_run_path_options = 0; +#if defined (__sparc_v9__) || defined (__sparcv9) +const char *__gnat_default_libgcc_subdir = "lib/sparcv9"; +#elif defined (__x86_64) +const char *__gnat_default_libgcc_subdir = "lib/amd64"; +#else +const char *__gnat_default_libgcc_subdir = "lib"; +#endif + +#elif defined (__FreeBSD__) +const char *__gnat_object_file_option = ""; +const char *__gnat_run_path_option = "-Wl,-rpath,"; +char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = STATIC; +int __gnat_link_max = 8192; +unsigned char __gnat_objlist_file_supported = 1; +unsigned char __gnat_using_gnu_linker = 1; +const char *__gnat_object_library_extension = ".a"; +unsigned char __gnat_separate_run_path_options = 0; +const char *__gnat_default_libgcc_subdir = "lib"; + +#elif defined (__APPLE__) +const char *__gnat_object_file_option = "-Wl,-filelist,"; +const char *__gnat_run_path_option = "-Wl,-rpath,"; +char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = SHARED; +int __gnat_link_max = 262144; +unsigned char __gnat_objlist_file_supported = 1; +unsigned char __gnat_using_gnu_linker = 0; +const char *__gnat_object_library_extension = ".a"; +unsigned char __gnat_separate_run_path_options = 1; +const char *__gnat_default_libgcc_subdir = "lib"; + +#elif defined (linux) || defined(__GLIBC__) +const char *__gnat_object_file_option = ""; +const char *__gnat_run_path_option = "-Wl,-rpath,"; +char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = STATIC; +int __gnat_link_max = 8192; +unsigned char __gnat_objlist_file_supported = 1; +unsigned char __gnat_using_gnu_linker = 1; +const char *__gnat_object_library_extension = ".a"; +unsigned char __gnat_separate_run_path_options = 0; +#if defined (__x86_64) +const char *__gnat_default_libgcc_subdir = "lib64"; +#else +const char *__gnat_default_libgcc_subdir = "lib"; +#endif + +#elif defined (__svr4__) && defined (i386) +const char *__gnat_object_file_option = ""; +const char *__gnat_run_path_option = ""; +char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = STATIC; +int __gnat_link_max = 2147483647; +unsigned char __gnat_objlist_file_supported = 0; +unsigned char __gnat_using_gnu_linker = 0; +const char *__gnat_object_library_extension = ".a"; +unsigned char __gnat_separate_run_path_options = 0; +const char *__gnat_default_libgcc_subdir = "lib"; + +#else + +/* These are the default settings for all other systems. No response file + is supported, the shared library default is STATIC. */ +const char *__gnat_run_path_option = ""; +const char *__gnat_object_file_option = ""; +char __gnat_shared_libgnat_default = STATIC; +char __gnat_shared_libgcc_default = STATIC; +int __gnat_link_max = 2147483647; +unsigned char __gnat_objlist_file_supported = 0; +unsigned char __gnat_using_gnu_linker = 0; +const char *__gnat_object_library_extension = ".a"; +unsigned char __gnat_separate_run_path_options = 0; +const char *__gnat_default_libgcc_subdir = "lib"; +#endif diff --git a/gcc/ada/live.adb b/gcc/ada/live.adb new file mode 100644 index 000000000..eaa52020b --- /dev/null +++ b/gcc/ada/live.adb @@ -0,0 +1,345 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I V E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Lib; use Lib; +with Nlists; use Nlists; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Types; use Types; + +package body Live is + + -- Name_Set + + -- The Name_Set type is used to store the temporary mark bits + -- used by the garbage collection of entities. Using a separate + -- array prevents using up any valuable per-node space and possibly + -- results in better locality and cache usage. + + type Name_Set is array (Node_Id range <>) of Boolean; + pragma Pack (Name_Set); + + function Marked (Marks : Name_Set; Name : Node_Id) return Boolean; + pragma Inline (Marked); + + procedure Set_Marked + (Marks : in out Name_Set; + Name : Node_Id; + Mark : Boolean := True); + pragma Inline (Set_Marked); + + -- Algorithm + + -- The problem of finding live entities is solved in two steps: + + procedure Mark (Root : Node_Id; Marks : out Name_Set); + -- Mark all live entities in Root as Marked + + procedure Sweep (Root : Node_Id; Marks : Name_Set); + -- For all unmarked entities in Root set Is_Eliminated to true + + -- The Mark phase is split into two phases: + + procedure Init_Marked (Root : Node_Id; Marks : out Name_Set); + -- For all subprograms, reset Is_Public flag if a pragma Eliminate + -- applies to the entity, and set the Marked flag to Is_Public + + procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set); + -- Traverse the tree skipping any unmarked subprogram bodies. + -- All visited entities are marked, as well as entities denoted + -- by a visited identifier or operator. When an entity is first + -- marked it is traced as well. + + -- Local functions + + function Body_Of (E : Entity_Id) return Node_Id; + -- Returns subprogram body corresponding to entity E + + function Spec_Of (N : Node_Id) return Entity_Id; + -- Given a subprogram body N, return defining identifier of its declaration + + -- ??? the body of this package contains no comments at all, this + -- should be fixed! + + ------------- + -- Body_Of -- + ------------- + + function Body_Of (E : Entity_Id) return Node_Id is + Decl : constant Node_Id := Unit_Declaration_Node (E); + Kind : constant Node_Kind := Nkind (Decl); + Result : Node_Id; + + begin + if Kind = N_Subprogram_Body then + Result := Decl; + + elsif Kind /= N_Subprogram_Declaration + and Kind /= N_Subprogram_Body_Stub + then + Result := Empty; + + else + Result := Corresponding_Body (Decl); + + if Result /= Empty then + Result := Unit_Declaration_Node (Result); + end if; + end if; + + return Result; + end Body_Of; + + ------------------------------ + -- Collect_Garbage_Entities -- + ------------------------------ + + procedure Collect_Garbage_Entities is + Root : constant Node_Id := Cunit (Main_Unit); + Marks : Name_Set (0 .. Last_Node_Id); + + begin + Mark (Root, Marks); + Sweep (Root, Marks); + end Collect_Garbage_Entities; + + ----------------- + -- Init_Marked -- + ----------------- + + procedure Init_Marked (Root : Node_Id; Marks : out Name_Set) is + + function Process (N : Node_Id) return Traverse_Result; + procedure Traverse is new Traverse_Proc (Process); + + function Process (N : Node_Id) return Traverse_Result is + begin + case Nkind (N) is + when N_Entity'Range => + if Is_Eliminated (N) then + Set_Is_Public (N, False); + end if; + + Set_Marked (Marks, N, Is_Public (N)); + + when N_Subprogram_Body => + Traverse (Spec_Of (N)); + + when N_Package_Body_Stub => + if Present (Library_Unit (N)) then + Traverse (Proper_Body (Unit (Library_Unit (N)))); + end if; + + when N_Package_Body => + declare + Elmt : Node_Id := First (Declarations (N)); + begin + while Present (Elmt) loop + Traverse (Elmt); + Next (Elmt); + end loop; + end; + + when others => + null; + end case; + + return OK; + end Process; + + -- Start of processing for Init_Marked + + begin + Marks := (others => False); + Traverse (Root); + end Init_Marked; + + ---------- + -- Mark -- + ---------- + + procedure Mark (Root : Node_Id; Marks : out Name_Set) is + begin + Init_Marked (Root, Marks); + Trace_Marked (Root, Marks); + end Mark; + + ------------ + -- Marked -- + ------------ + + function Marked (Marks : Name_Set; Name : Node_Id) return Boolean is + begin + return Marks (Name); + end Marked; + + ---------------- + -- Set_Marked -- + ---------------- + + procedure Set_Marked + (Marks : in out Name_Set; + Name : Node_Id; + Mark : Boolean := True) + is + begin + Marks (Name) := Mark; + end Set_Marked; + + ------------- + -- Spec_Of -- + ------------- + + function Spec_Of (N : Node_Id) return Entity_Id is + begin + if Acts_As_Spec (N) then + return Defining_Entity (N); + else + return Corresponding_Spec (N); + end if; + end Spec_Of; + + ----------- + -- Sweep -- + ----------- + + procedure Sweep (Root : Node_Id; Marks : Name_Set) is + + function Process (N : Node_Id) return Traverse_Result; + procedure Traverse is new Traverse_Proc (Process); + + function Process (N : Node_Id) return Traverse_Result is + begin + case Nkind (N) is + when N_Entity'Range => + Set_Is_Eliminated (N, not Marked (Marks, N)); + + when N_Subprogram_Body => + Traverse (Spec_Of (N)); + + when N_Package_Body_Stub => + if Present (Library_Unit (N)) then + Traverse (Proper_Body (Unit (Library_Unit (N)))); + end if; + + when N_Package_Body => + declare + Elmt : Node_Id := First (Declarations (N)); + begin + while Present (Elmt) loop + Traverse (Elmt); + Next (Elmt); + end loop; + end; + + when others => + null; + end case; + return OK; + end Process; + + begin + Traverse (Root); + end Sweep; + + ------------------ + -- Trace_Marked -- + ------------------ + + procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set) is + + function Process (N : Node_Id) return Traverse_Result; + procedure Process (N : Node_Id); + procedure Traverse is new Traverse_Proc (Process); + + procedure Process (N : Node_Id) is + Result : Traverse_Result; + pragma Warnings (Off, Result); + + begin + Result := Process (N); + end Process; + + function Process (N : Node_Id) return Traverse_Result is + Result : Traverse_Result := OK; + B : Node_Id; + E : Entity_Id; + + begin + case Nkind (N) is + when N_Pragma | N_Generic_Declaration'Range | + N_Subprogram_Declaration | N_Subprogram_Body_Stub => + Result := Skip; + + when N_Subprogram_Body => + if not Marked (Marks, Spec_Of (N)) then + Result := Skip; + end if; + + when N_Package_Body_Stub => + if Present (Library_Unit (N)) then + Traverse (Proper_Body (Unit (Library_Unit (N)))); + end if; + + when N_Identifier | N_Operator_Symbol | N_Expanded_Name => + E := Entity (N); + + if E /= Empty and then not Marked (Marks, E) then + Process (E); + + if Is_Subprogram (E) then + B := Body_Of (E); + + if B /= Empty then + Traverse (B); + end if; + end if; + end if; + + when N_Entity'Range => + if (Ekind (N) = E_Component) and then not Marked (Marks, N) then + if Present (Discriminant_Checking_Func (N)) then + Process (Discriminant_Checking_Func (N)); + end if; + end if; + + Set_Marked (Marks, N); + + when others => + null; + end case; + + return Result; + end Process; + + -- Start of processing for Trace_Marked + + begin + Traverse (Root); + end Trace_Marked; + +end Live; diff --git a/gcc/ada/live.ads b/gcc/ada/live.ads new file mode 100644 index 000000000..016203d95 --- /dev/null +++ b/gcc/ada/live.ads @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I V E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package implements a compiler phase that determines the set +-- of live entities. For now entities are considered live when they +-- have at least one execution time reference. + +package Live is + + procedure Collect_Garbage_Entities; + -- Eliminate unreachable entities using a mark-and-sweep from + -- the set of root entities, i.e. those having Is_Public set. + +end Live; diff --git a/gcc/ada/locales.c b/gcc/ada/locales.c new file mode 100644 index 000000000..2fa1b58a0 --- /dev/null +++ b/gcc/ada/locales.c @@ -0,0 +1,56 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * L O C A L E S * + * * + * C Implementation File * + * * + * 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. * + * * + ****************************************************************************/ + +/* This file provides OS-dependent support for the Ada.Locales package. */ + +typedef char char4 [4]; + +/* + c_get_language_code needs to fill in the Alpha-3 encoding of the + language code (3 lowercase letters). That should be "und" if the + language is unknown. [see Ada.Locales] +*/ +void c_get_language_code (char4 p) { + char *r = "und"; + for (; *r != '\0'; p++, r++) + *p = *r; +} + +/* + c_get_country_code needs to fill in the Alpha-2 encoding of the + country code (2 uppercase letters). That should be "ZZ" if the + country is unknown. [see Ada.Locales] +*/ +void c_get_country_code (char4 p) { + char *r = "ZZ"; + for (; *r != '\0'; p++, r++) + *p = *r; +} diff --git a/gcc/ada/machcode.ads b/gcc/ada/machcode.ads new file mode 100644 index 000000000..55e1ae594 --- /dev/null +++ b/gcc/ada/machcode.ads @@ -0,0 +1,18 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M A C H I N E _ C O D E -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with System.Machine_Code; + +package Machine_Code renames System.Machine_Code; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb new file mode 100644 index 000000000..98ae1eb4e --- /dev/null +++ b/gcc/ada/make.adb @@ -0,0 +1,8593 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M A K E -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with ALI; use ALI; +with ALI.Util; use ALI.Util; +with Csets; +with Debug; +with Errutil; +with Fmap; +with Fname; use Fname; +with Fname.SF; use Fname.SF; +with Fname.UF; use Fname.UF; +with Gnatvsn; use Gnatvsn; +with Hostparm; use Hostparm; +with Makeusg; +with Makeutl; use Makeutl; +with MLib; +with MLib.Prj; +with MLib.Tgt; use MLib.Tgt; +with MLib.Utl; +with Namet; use Namet; +with Opt; use Opt; +with Osint.M; use Osint.M; +with Osint; use Osint; +with Output; use Output; +with Prj; use Prj; +with Prj.Com; +with Prj.Env; +with Prj.Pars; +with Prj.Tree; use Prj.Tree; +with Prj.Util; +with SFN_Scan; +with Sinput.P; +with Snames; use Snames; + +pragma Warnings (Off); +with System.HTable; +pragma Warnings (On); + +with Switch; use Switch; +with Switch.M; use Switch.M; +with Targparm; use Targparm; +with Table; +with Tempdir; +with Types; use Types; + +with Ada.Exceptions; use Ada.Exceptions; +with Ada.Command_Line; use Ada.Command_Line; + +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; +with GNAT.HTable; +with GNAT.Case_Util; use GNAT.Case_Util; +with GNAT.OS_Lib; use GNAT.OS_Lib; + +package body Make is + + use ASCII; + -- Make control characters visible + + Standard_Library_Package_Body_Name : constant String := "s-stalib.adb"; + -- Every program depends on this package, that must then be checked, + -- especially when -f and -a are used. + + procedure Kill (Pid : Process_Id; Sig_Num : Integer; Close : Integer); + pragma Import (C, Kill, "__gnat_kill"); + -- Called by Sigint_Intercepted to kill all spawned compilation processes + + type Sigint_Handler is access procedure; + pragma Convention (C, Sigint_Handler); + + procedure Install_Int_Handler (Handler : Sigint_Handler); + pragma Import (C, Install_Int_Handler, "__gnat_install_int_handler"); + -- Called by Gnatmake to install the SIGINT handler below + + procedure Sigint_Intercepted; + pragma Convention (C, Sigint_Intercepted); + -- Called when the program is interrupted by Ctrl-C to delete the + -- temporary mapping files and configuration pragmas files. + + No_Mapping_File : constant Natural := 0; + + type Compilation_Data is record + Pid : Process_Id; + Full_Source_File : File_Name_Type; + Lib_File : File_Name_Type; + Source_Unit : Unit_Name_Type; + Full_Lib_File : File_Name_Type; + Lib_File_Attr : aliased File_Attributes; + Mapping_File : Natural := No_Mapping_File; + Project : Project_Id := No_Project; + end record; + -- Data recorded for each compilation process spawned + + No_Compilation_Data : constant Compilation_Data := + (Invalid_Pid, No_File, No_File, No_Unit_Name, No_File, Unknown_Attributes, + No_Mapping_File, No_Project); + + type Comp_Data_Arr is array (Positive range <>) of Compilation_Data; + type Comp_Data_Ptr is access Comp_Data_Arr; + Running_Compile : Comp_Data_Ptr; + -- Used to save information about outstanding compilations + + Outstanding_Compiles : Natural := 0; + -- Current number of outstanding compiles + + ------------------------- + -- Note on terminology -- + ------------------------- + + -- In this program, we use the phrase "termination" of a file name to refer + -- to the suffix that appears after the unit name portion. Very often this + -- is simply the extension, but in some cases, the sequence may be more + -- complex, for example in main.1.ada, the termination in this name is + -- ".1.ada" and in main_.ada the termination is "_.ada". + + procedure Insert_Project_Sources + (The_Project : Project_Id; + All_Projects : Boolean; + Into_Q : Boolean); + -- If Into_Q is True, insert all sources of the project file(s) that are + -- not already marked into the Q. If Into_Q is False, call Osint.Add_File + -- for the first source, then insert all other sources that are not already + -- marked into the Q. If All_Projects is True, all sources of all projects + -- are concerned; otherwise, only sources of The_Project are concerned, + -- including, if The_Project is an extending project, sources inherited + -- from projects being extended. + + Unique_Compile : Boolean := False; + -- Set to True if -u or -U or a project file with no main is used + + Unique_Compile_All_Projects : Boolean := False; + -- Set to True if -U is used + + Must_Compile : Boolean := False; + -- True if gnatmake is invoked with -f -u and one or several mains on the + -- command line. + + Main_On_Command_Line : Boolean := False; + -- True if gnatmake is invoked with one or several mains on the command + -- line. + + RTS_Specified : String_Access := null; + -- Used to detect multiple --RTS= switches + + N_M_Switch : Natural := 0; + -- Used to count -mxxx switches that can affect multilib + + package Queue is + --------------------------------- + -- Queue Manipulation Routines -- + --------------------------------- + + procedure Initialize (Queue_Per_Obj_Dir : Boolean); + -- Initialize the queue + + function Is_Empty return Boolean; + -- Returns True if the queue is empty + + function Is_Virtually_Empty return Boolean; + -- Returns True if the queue is empty or if all object directories are + -- busy. + + procedure Insert + (Source_File_Name : File_Name_Type; + Project : Project_Id; + Source_Unit : Unit_Name_Type := No_Unit_Name; + Index : Int := 0); + -- Insert source in the queue + + procedure Extract + (Source_File_Name : out File_Name_Type; + Source_Unit : out Unit_Name_Type; + Source_Index : out Int); + -- Get the first source that can be compiled from the queue. If no + -- source may be compiled, return No_File/No_Source. + + function Size return Natural; + -- Return the total size of the queue, including the sources already + -- extracted. + + function Processed return Natural; + -- Return the number of source in the queue that have already been + -- processed. + + procedure Set_Obj_Dir_Busy (Obj_Dir : Path_Name_Type); + -- Indicate that this object directory is busy, so that when + -- One_Compilation_Per_Obj_Dir is True no other compilation occurs in + -- this object directory. + + procedure Set_Obj_Dir_Free (Obj_Dir : Path_Name_Type); + -- Indicate that there is no compilation for this object directory + + function Element (Rank : Positive) return File_Name_Type; + -- Get the file name for element of index Rank in the queue + + end Queue; + + -- The 3 following packages are used to store gcc, gnatbind and gnatlink + -- switches found in the project files. + + package Gcc_Switches is new Table.Table ( + Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Make.Gcc_Switches"); + + package Binder_Switches is new Table.Table ( + Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Make.Binder_Switches"); + + package Linker_Switches is new Table.Table ( + Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Make.Linker_Switches"); + + -- The following instantiations and variables are necessary to save what + -- is found on the command line, in case there is a project file specified. + + package Saved_Gcc_Switches is new Table.Table ( + Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Make.Saved_Gcc_Switches"); + + package Saved_Binder_Switches is new Table.Table ( + Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Make.Saved_Binder_Switches"); + + package Saved_Linker_Switches is new Table.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Make.Saved_Linker_Switches"); + + package Switches_To_Check is new Table.Table ( + Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Make.Switches_To_Check"); + + package Library_Paths is new Table.Table ( + Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Make.Library_Paths"); + + package Failed_Links is new Table.Table ( + Table_Component_Type => File_Name_Type, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Make.Failed_Links"); + + package Successful_Links is new Table.Table ( + Table_Component_Type => File_Name_Type, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Make.Successful_Links"); + + package Library_Projs is new Table.Table ( + Table_Component_Type => Project_Id, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Make.Library_Projs"); + + -- Two variables to keep the last binder and linker switch index in tables + -- Binder_Switches and Linker_Switches, before adding switches from the + -- project file (if any) and switches from the command line (if any). + + Last_Binder_Switch : Integer := 0; + Last_Linker_Switch : Integer := 0; + + Normalized_Switches : Argument_List_Access := new Argument_List (1 .. 10); + Last_Norm_Switch : Natural := 0; + + Saved_Maximum_Processes : Natural := 0; + + Gnatmake_Switch_Found : Boolean; + -- Set by Scan_Make_Arg. True when the switch is a gnatmake switch. + -- Tested by Add_Switches when switches in package Builder must all be + -- gnatmake switches. + + Switch_May_Be_Passed_To_The_Compiler : Boolean; + -- Set by Add_Switches and Switches_Of. True when unrecognized switches + -- are passed to the Ada compiler. + + type Arg_List_Ref is access Argument_List; + The_Saved_Gcc_Switches : Arg_List_Ref; + + Project_File_Name : String_Access := null; + -- The path name of the main project file, if any + + Project_File_Name_Present : Boolean := False; + -- True when -P is used with a space between -P and the project file name + + Current_Verbosity : Prj.Verbosity := Prj.Default; + -- Verbosity to parse the project files + + Main_Project : Prj.Project_Id := No_Project; + -- The project id of the main project file, if any + + Project_Of_Current_Object_Directory : Project_Id := No_Project; + -- The object directory of the project for the last compilation. Avoid + -- calling Change_Dir if the current working directory is already this + -- directory. + + Map_File : String_Access := null; + -- Value of switch --create-map-file + + -- Packages of project files where unknown attributes are errors + + Naming_String : aliased String := "naming"; + Builder_String : aliased String := "builder"; + Compiler_String : aliased String := "compiler"; + Binder_String : aliased String := "binder"; + Linker_String : aliased String := "linker"; + + Gnatmake_Packages : aliased String_List := + (Naming_String 'Access, + Builder_String 'Access, + Compiler_String 'Access, + Binder_String 'Access, + Linker_String 'Access); + + Packages_To_Check_By_Gnatmake : constant String_List_Access := + Gnatmake_Packages'Access; + + procedure Add_Library_Search_Dir + (Path : String; + On_Command_Line : Boolean); + -- Call Add_Lib_Search_Dir with an absolute directory path. If Path is + -- relative path, when On_Command_Line is True, it is relative to the + -- current working directory. When On_Command_Line is False, it is relative + -- to the project directory of the main project. + + procedure Add_Source_Search_Dir + (Path : String; + On_Command_Line : Boolean); + -- Call Add_Src_Search_Dir with an absolute directory path. If Path is a + -- relative path, when On_Command_Line is True, it is relative to the + -- current working directory. When On_Command_Line is False, it is relative + -- to the project directory of the main project. + + procedure Add_Source_Dir (N : String); + -- Call Add_Src_Search_Dir (output one line when in verbose mode) + + procedure Add_Source_Directories is + new Prj.Env.For_All_Source_Dirs (Action => Add_Source_Dir); + + procedure Add_Object_Dir (N : String); + -- Call Add_Lib_Search_Dir (output one line when in verbose mode) + + procedure Add_Object_Directories is + new Prj.Env.For_All_Object_Dirs (Action => Add_Object_Dir); + + procedure Change_To_Object_Directory (Project : Project_Id); + -- Change to the object directory of project Project, if this is not + -- already the current working directory. + + type Bad_Compilation_Info is record + File : File_Name_Type; + Unit : Unit_Name_Type; + Found : Boolean; + end record; + -- File is the name of the file for which a compilation failed. Unit is for + -- gnatdist use in order to easily get the unit name of a file when its + -- name is krunched or declared in gnat.adc. Found is False if the + -- compilation failed because the file could not be found. + + package Bad_Compilation is new Table.Table ( + Table_Component_Type => Bad_Compilation_Info, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Make.Bad_Compilation"); + -- Full name of all the source files for which compilation fails + + Do_Compile_Step : Boolean := True; + Do_Bind_Step : Boolean := True; + Do_Link_Step : Boolean := True; + -- Flags to indicate what step should be executed. Can be set to False + -- with the switches -c, -b and -l. These flags are reset to True for + -- each invocation of procedure Gnatmake. + + Do_Codepeer_Globalize_Step : Boolean := False; + -- Flag to indicate whether the CodePeer globalizer should be called + + Shared_String : aliased String := "-shared"; + Force_Elab_Flags_String : aliased String := "-F"; + + No_Shared_Switch : aliased Argument_List := (1 .. 0 => null); + Shared_Switch : aliased Argument_List := (1 => Shared_String'Access); + Bind_Shared : Argument_List_Access := No_Shared_Switch'Access; + -- Switch to added in front of gnatbind switches. By default no switch is + -- added. Switch "-shared" is added if there is a non-static Library + -- Project File. + + Shared_Libgcc : aliased String := "-shared-libgcc"; + + No_Shared_Libgcc_Switch : aliased Argument_List := (1 .. 0 => null); + Shared_Libgcc_Switch : aliased Argument_List := + (1 => Shared_Libgcc'Access); + Link_With_Shared_Libgcc : Argument_List_Access := + No_Shared_Libgcc_Switch'Access; + + procedure Make_Failed (S : String); + -- Delete all temp files created by Gnatmake and call Osint.Fail, with the + -- parameter S (see osint.ads). This is called from the Prj hierarchy and + -- the MLib hierarchy. + + -------------------------- + -- Obsolete Executables -- + -------------------------- + + Executable_Obsolete : Boolean := False; + -- Executable_Obsolete is initially set to False for each executable, + -- and is set to True whenever one of the source of the executable is + -- compiled, or has already been compiled for another executable. + + Max_Header : constant := 200; + -- This needs a proper comment, it used to say "arbitrary" + -- that's not an adequate comment ??? + + type Header_Num is range 1 .. Max_Header; + -- Header_Num for the hash table Obsoleted below + + function Hash (F : File_Name_Type) return Header_Num; + -- Hash function for the hash table Obsoleted below + + package Obsoleted is new System.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Boolean, + No_Element => False, + Key => File_Name_Type, + Hash => Hash, + Equal => "="); + -- A hash table to keep all files that have been compiled, to detect + -- if an executable is up to date or not. + + procedure Enter_Into_Obsoleted (F : File_Name_Type); + -- Enter a file name, without directory information, into the hash table + -- Obsoleted. + + function Is_In_Obsoleted (F : File_Name_Type) return Boolean; + -- Check if a file name, without directory information, has already been + -- entered into the hash table Obsoleted. + + type Dependency is record + This : File_Name_Type; + Depends_On : File_Name_Type; + end record; + -- Components of table Dependencies below + + package Dependencies is new Table.Table ( + Table_Component_Type => Dependency, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Make.Dependencies"); + -- A table to keep dependencies, to be able to decide if an executable + -- is obsolete. More explanation needed ??? + +-- procedure Add_Dependency (S : File_Name_Type; On : File_Name_Type); +-- -- Add one entry in table Dependencies + + ---------------------------- + -- Arguments and Switches -- + ---------------------------- + + Arguments : Argument_List_Access; + -- Used to gather the arguments for invocation of the compiler + + Last_Argument : Natural := 0; + -- Last index of arguments in Arguments above + + Arguments_Project : Project_Id; + -- Project id, if any, of the source to be compiled + + Arguments_Path_Name : Path_Name_Type; + -- Full path of the source to be compiled, when Arguments_Project is not + -- No_Project. + + Dummy_Switch : constant String_Access := new String'("- "); + -- Used to initialized Prev_Switch in procedure Check + + procedure Add_Arguments (Args : Argument_List); + -- Add arguments to global variable Arguments, increasing its size + -- if necessary and adjusting Last_Argument. + + function Configuration_Pragmas_Switch + (For_Project : Project_Id) return Argument_List; + -- Return an argument list of one element, if there is a configuration + -- pragmas file to be specified for For_Project, + -- otherwise return an empty argument list. + + ------------------- + -- Misc Routines -- + ------------------- + + procedure List_Depend; + -- Prints to standard output the list of object dependencies. This list + -- can be used directly in a Makefile. A call to Compile_Sources must + -- precede the call to List_Depend. Also because this routine uses the + -- ALI files that were originally loaded and scanned by Compile_Sources, + -- no additional ALI files should be scanned between the two calls (i.e. + -- between the call to Compile_Sources and List_Depend.) + + procedure List_Bad_Compilations; + -- Prints out the list of all files for which the compilation failed + + Usage_Needed : Boolean := True; + -- Flag used to make sure Makeusg is call at most once + + procedure Usage; + -- Call Makeusg, if Usage_Needed is True. + -- Set Usage_Needed to False. + + procedure Debug_Msg (S : String; N : Name_Id); + procedure Debug_Msg (S : String; N : File_Name_Type); + procedure Debug_Msg (S : String; N : Unit_Name_Type); + -- If Debug.Debug_Flag_W is set outputs string S followed by name N + + procedure Recursive_Compute_Depth (Project : Project_Id); + -- Compute depth of Project and of the projects it depends on + + ----------------------- + -- Gnatmake Routines -- + ----------------------- + + subtype Lib_Mark_Type is Byte; + -- Used in Mark_Directory + + Ada_Lib_Dir : constant Lib_Mark_Type := 1; + -- Used to mark a directory as a GNAT lib dir + + -- Note that the notion of GNAT lib dir is no longer used. The code related + -- to it has not been removed to give an idea on how to use the directory + -- prefix marking mechanism. + + -- An Ada library directory is a directory containing ali and object files + -- but no source files for the bodies (the specs can be in the same or some + -- other directory). These directories are specified in the Gnatmake + -- command line with the switch "-Adir" (to specify the spec location -Idir + -- cab be used). Gnatmake skips the missing sources whose ali are in Ada + -- library directories. For an explanation of why Gnatmake behaves that + -- way, see the spec of Make.Compile_Sources. The directory lookup penalty + -- is incurred every single time this routine is called. + + procedure Check_Steps; + -- Check what steps (Compile, Bind, Link) must be executed. + -- Set the step flags accordingly. + + function In_Ada_Lib_Dir (File : File_Name_Type) return Boolean; + -- Get directory prefix of this file and get lib mark stored in name + -- table for this directory. Then check if an Ada lib mark has been set. + + procedure Mark_Directory + (Dir : String; + Mark : Lib_Mark_Type; + On_Command_Line : Boolean); + -- Store the absolute path from Dir in name table and set lib mark as name + -- info to identify Ada libraries. + -- + -- If Dir is a relative path, when On_Command_Line is True, it is relative + -- to the current working directory; when On_Command_Line is False, it is + -- relative to the project directory of the main project. + + Output_Is_Object : Boolean := True; + -- Set to False when using a switch -S for the compiler + + procedure Check_For_S_Switch; + -- Set Output_Is_Object to False when the -S switch is used for the + -- compiler. + + function Switches_Of + (Source_File : File_Name_Type; + Source_File_Name : String; + Source_Index : Int; + Project : Project_Id; + In_Package : Package_Id; + Allow_ALI : Boolean) return Variable_Value; + -- Return the switches for the source file in the specified package of a + -- project file. If the Source_File ends with a standard GNAT extension + -- (".ads" or ".adb"), try first the full name, then the name without the + -- extension, then, if Allow_ALI is True, the name with the extension + -- ".ali". If there is no switches for either names, try first Switches + -- (others) then the default switches for Ada. If all failed, return + -- No_Variable_Value. + + function Is_In_Object_Directory + (Source_File : File_Name_Type; + Full_Lib_File : File_Name_Type) return Boolean; + -- Check if, when using a project file, the ALI file is in the project + -- directory of the ultimate extending project. If it is not, we ignore + -- the fact that this ALI file is read-only. + + procedure Process_Multilib (Project_Node_Tree : Project_Node_Tree_Ref); + -- Add appropriate --RTS argument to handle multilib + + ---------------------------------------------------- + -- Compiler, Binder & Linker Data and Subprograms -- + ---------------------------------------------------- + + Gcc : String_Access := Program_Name ("gcc", "gnatmake"); + Gnatbind : String_Access := Program_Name ("gnatbind", "gnatmake"); + Gnatlink : String_Access := Program_Name ("gnatlink", "gnatmake"); + -- Default compiler, binder, linker programs + + Globalizer : constant String := "codepeer_globalizer"; + -- CodePeer globalizer executable name + + Saved_Gcc : String_Access := null; + Saved_Gnatbind : String_Access := null; + Saved_Gnatlink : String_Access := null; + -- Given by the command line. Will be used, if non null + + Gcc_Path : String_Access := + GNAT.OS_Lib.Locate_Exec_On_Path (Gcc.all); + Gnatbind_Path : String_Access := + GNAT.OS_Lib.Locate_Exec_On_Path (Gnatbind.all); + Gnatlink_Path : String_Access := + GNAT.OS_Lib.Locate_Exec_On_Path (Gnatlink.all); + -- Path for compiler, binder, linker programs, defaulted now for gnatdist. + -- Changed later if overridden on command line. + + Globalizer_Path : constant String_Access := + GNAT.OS_Lib.Locate_Exec_On_Path (Globalizer); + -- Path for CodePeer globalizer + + Comp_Flag : constant String_Access := new String'("-c"); + Output_Flag : constant String_Access := new String'("-o"); + Ada_Flag_1 : constant String_Access := new String'("-x"); + Ada_Flag_2 : constant String_Access := new String'("ada"); + No_gnat_adc : constant String_Access := new String'("-gnatA"); + GNAT_Flag : constant String_Access := new String'("-gnatpg"); + Do_Not_Check_Flag : constant String_Access := new String'("-x"); + + Object_Suffix : constant String := Get_Target_Object_Suffix.all; + + Syntax_Only : Boolean := False; + -- Set to True when compiling with -gnats + + Display_Executed_Programs : Boolean := True; + -- Set to True if name of commands should be output on stderr (or on stdout + -- if the Commands_To_Stdout flag was set by use of the -eS switch). + + Output_File_Name_Seen : Boolean := False; + -- Set to True after having scanned the file_name for + -- switch "-o file_name" + + Object_Directory_Seen : Boolean := False; + -- Set to True after having scanned the object directory for + -- switch "-D obj_dir". + + Object_Directory_Path : String_Access := null; + -- The path name of the object directory, set with switch -D + + type Make_Program_Type is (None, Compiler, Binder, Linker); + + Program_Args : Make_Program_Type := None; + -- Used to indicate if we are scanning gnatmake, gcc, gnatbind, or gnatbind + -- options within the gnatmake command line. Used in Scan_Make_Arg only, + -- but must be global since value preserved from one call to another. + + Temporary_Config_File : Boolean := False; + -- Set to True when there is a temporary config file used for a project + -- file, to avoid displaying the -gnatec switch for a temporary file. + + procedure Add_Switches + (The_Package : Package_Id; + File_Name : String; + Index : Int; + Program : Make_Program_Type; + Unknown_Switches_To_The_Compiler : Boolean := True; + Project_Node_Tree : Project_Node_Tree_Ref); + procedure Add_Switch + (S : String_Access; + Program : Make_Program_Type; + Append_Switch : Boolean := True; + And_Save : Boolean := True); + procedure Add_Switch + (S : String; + Program : Make_Program_Type; + Append_Switch : Boolean := True; + And_Save : Boolean := True); + -- Make invokes one of three programs (the compiler, the binder or the + -- linker). For the sake of convenience, some program specific switches + -- can be passed directly on the gnatmake command line. This procedure + -- records these switches so that gnatmake can pass them to the right + -- program. S is the switch to be added at the end of the command line + -- for Program if Append_Switch is True. If Append_Switch is False S is + -- added at the beginning of the command line. + + procedure Check + (Source_File : File_Name_Type; + Source_Index : Int; + Is_Main_Source : Boolean; + The_Args : Argument_List; + Lib_File : File_Name_Type; + Full_Lib_File : File_Name_Type; + Lib_File_Attr : access File_Attributes; + Read_Only : Boolean; + ALI : out ALI_Id; + O_File : out File_Name_Type; + O_Stamp : out Time_Stamp_Type); + -- Determines whether the library file Lib_File is up-to-date or not. The + -- full name (with path information) of the object file corresponding to + -- Lib_File is returned in O_File. Its time stamp is saved in O_Stamp. + -- ALI is the ALI_Id corresponding to Lib_File. If Lib_File in not + -- up-to-date, then the corresponding source file needs to be recompiled. + -- In this case ALI = No_ALI_Id. + -- Full_Lib_File must be the result of calling Osint.Full_Lib_File_Name on + -- Lib_File. Precomputing it saves system calls. Lib_File_Attr is the + -- initialized attributes of that file, which is also used to save on + -- system calls (it can safely be initialized to Unknown_Attributes). + + procedure Check_Linker_Options + (E_Stamp : Time_Stamp_Type; + O_File : out File_Name_Type; + O_Stamp : out Time_Stamp_Type); + -- Checks all linker options for linker files that are newer + -- than E_Stamp. If such objects are found, the youngest object + -- is returned in O_File and its stamp in O_Stamp. + -- + -- If no obsolete linker files were found, the first missing + -- linker file is returned in O_File and O_Stamp is empty. + -- Otherwise O_File is No_File. + + procedure Collect_Arguments + (Source_File : File_Name_Type; + Source_Index : Int; + Is_Main_Source : Boolean; + Args : Argument_List); + -- Collect all arguments for a source to be compiled, including those + -- that come from a project file. + + procedure Display (Program : String; Args : Argument_List); + -- Displays Program followed by the arguments in Args if variable + -- Display_Executed_Programs is set. The lower bound of Args must be 1. + + procedure Report_Compilation_Failed; + -- Delete all temporary files and fail graciously + + ----------------- + -- Mapping files + ----------------- + + type Temp_Path_Names is array (Positive range <>) of Path_Name_Type; + type Temp_Path_Ptr is access Temp_Path_Names; + + type Free_File_Indexes is array (Positive range <>) of Positive; + type Free_Indexes_Ptr is access Free_File_Indexes; + + type Project_Compilation_Data is record + Mapping_File_Names : Temp_Path_Ptr; + -- The name ids of the temporary mapping files used. This is indexed + -- on the maximum number of compilation processes we will be spawning + -- (-j parameter) + + Last_Mapping_File_Names : Natural; + -- Index of the last mapping file created for this project + + Free_Mapping_File_Indexes : Free_Indexes_Ptr; + -- Indexes in Mapping_File_Names of the mapping file names that can be + -- reused for subsequent compilations. + + Last_Free_Indexes : Natural; + -- Number of mapping files that can be reused + end record; + -- Information necessary when compiling a project + + type Project_Compilation_Access is access Project_Compilation_Data; + + package Project_Compilation_Htable is new Simple_HTable + (Header_Num => Prj.Header_Num, + Element => Project_Compilation_Access, + No_Element => null, + Key => Project_Id, + Hash => Prj.Hash, + Equal => "="); + + Project_Compilation : Project_Compilation_Htable.Instance; + + Gnatmake_Mapping_File : String_Access := null; + -- The path name of a mapping file specified by switch -C= + + procedure Init_Mapping_File + (Project : Project_Id; + Data : in out Project_Compilation_Data; + File_Index : in out Natural); + -- Create a new temporary mapping file, and fill it with the project file + -- mappings, when using project file(s). The out parameter File_Index is + -- the index to the name of the file in the array The_Mapping_File_Names. + + procedure Delete_Temp_Config_Files; + -- Delete all temporary config files. Must not be called if Debug_Flag_N + -- is False. + + procedure Delete_All_Temp_Files; + -- Delete all temp files (config files, mapping files, path files), unless + -- Debug_Flag_N is True (in which case all temp files are left for user + -- examination). + + ------------------------------------------------- + -- Subprogram declarations moved from the spec -- + ------------------------------------------------- + + procedure Bind (ALI_File : File_Name_Type; Args : Argument_List); + -- Binds ALI_File. Args are the arguments to pass to the binder. + -- Args must have a lower bound of 1. + + procedure Display_Commands (Display : Boolean := True); + -- The default behavior of Make commands (Compile_Sources, Bind, Link) + -- is to display them on stderr. This behavior can be changed repeatedly + -- by invoking this procedure. + + -- If a compilation, bind or link failed one of the following 3 exceptions + -- is raised. These need to be handled by the calling routines. + + procedure Compile_Sources + (Main_Source : File_Name_Type; + Args : Argument_List; + First_Compiled_File : out File_Name_Type; + Most_Recent_Obj_File : out File_Name_Type; + Most_Recent_Obj_Stamp : out Time_Stamp_Type; + Main_Unit : out Boolean; + Compilation_Failures : out Natural; + Main_Index : Int := 0; + Check_Readonly_Files : Boolean := False; + Do_Not_Execute : Boolean := False; + Force_Compilations : Boolean := False; + Keep_Going : Boolean := False; + In_Place_Mode : Boolean := False; + Initialize_ALI_Data : Boolean := True; + Max_Process : Positive := 1); + -- Compile_Sources will recursively compile all the sources needed by + -- Main_Source. Before calling this routine make sure Namet has been + -- initialized. This routine can be called repeatedly with different + -- Main_Source file as long as all the source (-I flags), library + -- (-B flags) and ada library (-A flags) search paths between calls are + -- *exactly* the same. The default directory must also be the same. + -- + -- Args contains the arguments to use during the compilations. + -- The lower bound of Args must be 1. + -- + -- First_Compiled_File is set to the name of the first file that is + -- compiled or that needs to be compiled. This is set to No_Name if no + -- compilations were needed. + -- + -- Most_Recent_Obj_File is set to the full name of the most recent + -- object file found when no compilations are needed, that is when + -- First_Compiled_File is set to No_Name. When First_Compiled_File + -- is set then Most_Recent_Obj_File is set to No_Name. + -- + -- Most_Recent_Obj_Stamp is the time stamp of Most_Recent_Obj_File. + -- + -- Main_Unit is set to True if Main_Source can be a main unit. + -- If Do_Not_Execute is False and First_Compiled_File /= No_Name + -- the value of Main_Unit is always False. + -- Is this used any more??? It is certainly not used by gnatmake??? + -- + -- Compilation_Failures is a count of compilation failures. This count + -- is used to extract compilation failure reports with Extract_Failure. + -- + -- Main_Index, when not zero, is the index of the main unit in source + -- file Main_Source which is a multi-unit source. + -- Zero indicates that Main_Source is a single unit source file. + -- + -- Check_Readonly_Files set it to True to compile source files + -- which library files are read-only. When compiling GNAT predefined + -- files the "-gnatg" flag is used. + -- + -- Do_Not_Execute set it to True to find out the first source that + -- needs to be recompiled, but without recompiling it. This file is + -- saved in First_Compiled_File. + -- + -- Force_Compilations forces all compilations no matter what but + -- recompiles read-only files only if Check_Readonly_Files + -- is set. + -- + -- Keep_Going when True keep compiling even in the presence of + -- compilation errors. + -- + -- In_Place_Mode when True save library/object files in their object + -- directory if they already exist; otherwise, in the source directory. + -- + -- Initialize_ALI_Data set it to True when you want to initialize ALI + -- data-structures. This is what you should do most of the time. + -- (especially the first time around when you call this routine). + -- This parameter is set to False to preserve previously recorded + -- ALI file data. + -- + -- Max_Process is the maximum number of processes that should be spawned + -- to carry out compilations. + -- + -- Flags in Package Opt Affecting Compile_Sources + -- ----------------------------------------------- + -- + -- Check_Object_Consistency set it to False to omit all consistency + -- checks between an .ali file and its corresponding object file. + -- When this flag is set to true, every time an .ali is read, + -- package Osint checks that the corresponding object file + -- exists and is more recent than the .ali. + -- + -- Use of Name Table Info + -- ---------------------- + -- + -- All file names manipulated by Compile_Sources are entered into the + -- Names table. The Byte field of a source file is used to mark it. + -- + -- Calling Compile_Sources Several Times + -- ------------------------------------- + -- + -- Upon return from Compile_Sources all the ALI data structures are left + -- intact for further browsing. HOWEVER upon entry to this routine ALI + -- data structures are re-initialized if parameter Initialize_ALI_Data + -- above is set to true. Typically this is what you want the first time + -- you call Compile_Sources. You should not load an ali file, call this + -- routine with flag Initialize_ALI_Data set to True and then expect + -- that ALI information to be around after the call. Note that the first + -- time you call Compile_Sources you better set Initialize_ALI_Data to + -- True unless you have called Initialize_ALI yourself. + -- + -- Compile_Sources ALGORITHM : Compile_Sources (Main_Source) + -- ------------------------- + -- + -- 1. Insert Main_Source in a Queue (Q) and mark it. + -- + -- 2. Let unit.adb be the file at the head of the Q. If unit.adb is + -- missing but its corresponding ali file is in an Ada library directory + -- (see below) then, remove unit.adb from the Q and goto step 4. + -- Otherwise, look at the files under the D (dependency) section of + -- unit.ali. If unit.ali does not exist or some of the time stamps do + -- not match, (re)compile unit.adb. + -- + -- An Ada library directory is a directory containing Ada specs, ali + -- and object files but no source files for the bodies. An Ada library + -- directory is communicated to gnatmake by means of some switch so that + -- gnatmake can skip the sources whole ali are in that directory. + -- There are two reasons for skipping the sources in this case. Firstly, + -- Ada libraries typically come without full sources but binding and + -- linking against those libraries is still possible. Secondly, it would + -- be very wasteful for gnatmake to systematically check the consistency + -- of every external Ada library used in a program. The binder is + -- already in charge of catching any potential inconsistencies. + -- + -- 3. Look into the W section of unit.ali and insert into the Q all + -- unmarked source files. Mark all files newly inserted in the Q. + -- Specifically, assuming that the W section looks like + -- + -- W types%s types.adb types.ali + -- W unchecked_deallocation%s + -- W xref_tab%s xref_tab.adb xref_tab.ali + -- + -- Then xref_tab.adb and types.adb are inserted in the Q if they are not + -- already marked. + -- Note that there is no file listed under W unchecked_deallocation%s + -- so no generic body should ever be explicitly compiled (unless the + -- Main_Source at the start was a generic body). + -- + -- 4. Repeat steps 2 and 3 above until the Q is empty + -- + -- Note that the above algorithm works because the units withed in + -- subunits are transitively included in the W section (with section) of + -- the main unit. Likewise the withed units in a generic body needed + -- during a compilation are also transitively included in the W section + -- of the originally compiled file. + + procedure Globalize (Success : out Boolean); + -- Call the CodePeer globalizer on all the project's object directories, + -- or on the current directory if no projects. + + procedure Initialize (Project_Node_Tree : out Project_Node_Tree_Ref); + -- Performs default and package initialization. Therefore, + -- Compile_Sources can be called by an external unit. + + procedure Link + (ALI_File : File_Name_Type; + Args : Argument_List; + Success : out Boolean); + -- Links ALI_File. Args are the arguments to pass to the linker. + -- Args must have a lower bound of 1. Success indicates if the link + -- succeeded or not. + + procedure Scan_Make_Arg + (Project_Node_Tree : Project_Node_Tree_Ref; + Argv : String; + And_Save : Boolean); + -- Scan make arguments. Argv is a single argument to be processed. + -- Project_Node_Tree will be used to initialize external references. It + -- must have been initialized. + + ------------------- + -- Add_Arguments -- + ------------------- + + procedure Add_Arguments (Args : Argument_List) is + begin + if Arguments = null then + Arguments := new Argument_List (1 .. Args'Length + 10); + + else + while Last_Argument + Args'Length > Arguments'Last loop + declare + New_Arguments : constant Argument_List_Access := + new Argument_List (1 .. Arguments'Last * 2); + begin + New_Arguments (1 .. Last_Argument) := + Arguments (1 .. Last_Argument); + Arguments := New_Arguments; + end; + end loop; + end if; + + Arguments (Last_Argument + 1 .. Last_Argument + Args'Length) := Args; + Last_Argument := Last_Argument + Args'Length; + end Add_Arguments; + +-- -------------------- +-- -- Add_Dependency -- +-- -------------------- +-- +-- procedure Add_Dependency (S : File_Name_Type; On : File_Name_Type) is +-- begin +-- Dependencies.Increment_Last; +-- Dependencies.Table (Dependencies.Last) := (S, On); +-- end Add_Dependency; + + ---------------------------- + -- Add_Library_Search_Dir -- + ---------------------------- + + procedure Add_Library_Search_Dir + (Path : String; + On_Command_Line : Boolean) + is + begin + if On_Command_Line then + Add_Lib_Search_Dir (Normalize_Pathname (Path)); + + else + Get_Name_String (Main_Project.Directory.Display_Name); + Add_Lib_Search_Dir + (Normalize_Pathname (Path, Name_Buffer (1 .. Name_Len))); + end if; + end Add_Library_Search_Dir; + + -------------------- + -- Add_Object_Dir -- + -------------------- + + procedure Add_Object_Dir (N : String) is + begin + Add_Lib_Search_Dir (N); + + if Verbose_Mode then + Write_Str ("Adding object directory """); + Write_Str (N); + Write_Str ("""."); + Write_Eol; + end if; + end Add_Object_Dir; + + -------------------- + -- Add_Source_Dir -- + -------------------- + + procedure Add_Source_Dir (N : String) is + begin + Add_Src_Search_Dir (N); + + if Verbose_Mode then + Write_Str ("Adding source directory """); + Write_Str (N); + Write_Str ("""."); + Write_Eol; + end if; + end Add_Source_Dir; + + --------------------------- + -- Add_Source_Search_Dir -- + --------------------------- + + procedure Add_Source_Search_Dir + (Path : String; + On_Command_Line : Boolean) + is + begin + if On_Command_Line then + Add_Src_Search_Dir (Normalize_Pathname (Path)); + + else + Get_Name_String (Main_Project.Directory.Display_Name); + Add_Src_Search_Dir + (Normalize_Pathname (Path, Name_Buffer (1 .. Name_Len))); + end if; + end Add_Source_Search_Dir; + + ---------------- + -- Add_Switch -- + ---------------- + + procedure Add_Switch + (S : String_Access; + Program : Make_Program_Type; + Append_Switch : Boolean := True; + And_Save : Boolean := True) + is + generic + with package T is new Table.Table (<>); + procedure Generic_Position (New_Position : out Integer); + -- Generic procedure that chooses a position for S in T at the + -- beginning or the end, depending on the boolean Append_Switch. + -- Calling this procedure may expand the table. + + ---------------------- + -- Generic_Position -- + ---------------------- + + procedure Generic_Position (New_Position : out Integer) is + begin + T.Increment_Last; + + if Append_Switch then + New_Position := Integer (T.Last); + else + for J in reverse T.Table_Index_Type'Succ (T.First) .. T.Last loop + T.Table (J) := T.Table (T.Table_Index_Type'Pred (J)); + end loop; + + New_Position := Integer (T.First); + end if; + end Generic_Position; + + procedure Gcc_Switches_Pos is new Generic_Position (Gcc_Switches); + procedure Binder_Switches_Pos is new Generic_Position (Binder_Switches); + procedure Linker_Switches_Pos is new Generic_Position (Linker_Switches); + + procedure Saved_Gcc_Switches_Pos is new + Generic_Position (Saved_Gcc_Switches); + + procedure Saved_Binder_Switches_Pos is new + Generic_Position (Saved_Binder_Switches); + + procedure Saved_Linker_Switches_Pos is new + Generic_Position (Saved_Linker_Switches); + + New_Position : Integer; + + -- Start of processing for Add_Switch + + begin + if And_Save then + case Program is + when Compiler => + Saved_Gcc_Switches_Pos (New_Position); + Saved_Gcc_Switches.Table (New_Position) := S; + + when Binder => + Saved_Binder_Switches_Pos (New_Position); + Saved_Binder_Switches.Table (New_Position) := S; + + when Linker => + Saved_Linker_Switches_Pos (New_Position); + Saved_Linker_Switches.Table (New_Position) := S; + + when None => + raise Program_Error; + end case; + + else + case Program is + when Compiler => + Gcc_Switches_Pos (New_Position); + Gcc_Switches.Table (New_Position) := S; + + when Binder => + Binder_Switches_Pos (New_Position); + Binder_Switches.Table (New_Position) := S; + + when Linker => + Linker_Switches_Pos (New_Position); + Linker_Switches.Table (New_Position) := S; + + when None => + raise Program_Error; + end case; + end if; + end Add_Switch; + + procedure Add_Switch + (S : String; + Program : Make_Program_Type; + Append_Switch : Boolean := True; + And_Save : Boolean := True) + is + begin + Add_Switch (S => new String'(S), + Program => Program, + Append_Switch => Append_Switch, + And_Save => And_Save); + end Add_Switch; + + ------------------ + -- Add_Switches -- + ------------------ + + procedure Add_Switches + (The_Package : Package_Id; + File_Name : String; + Index : Int; + Program : Make_Program_Type; + Unknown_Switches_To_The_Compiler : Boolean := True; + Project_Node_Tree : Project_Node_Tree_Ref) + is + Switches : Variable_Value; + Switch_List : String_List_Id; + Element : String_Element; + + begin + Switch_May_Be_Passed_To_The_Compiler := + Unknown_Switches_To_The_Compiler; + + if File_Name'Length > 0 then + Name_Len := 0; + Add_Str_To_Name_Buffer (File_Name); + Switches := + Switches_Of + (Source_File => Name_Find, + Source_File_Name => File_Name, + Source_Index => Index, + Project => Main_Project, + In_Package => The_Package, + Allow_ALI => Program = Binder or else Program = Linker); + + if Switches.Kind = List then + Program_Args := Program; + + Switch_List := Switches.Values; + while Switch_List /= Nil_String loop + Element := Project_Tree.String_Elements.Table (Switch_List); + Get_Name_String (Element.Value); + + if Name_Len > 0 then + declare + Argv : constant String := Name_Buffer (1 .. Name_Len); + -- We need a copy, because Name_Buffer may be modified + + begin + if Verbose_Mode then + Write_Str (" Adding "); + Write_Line (Argv); + end if; + + Scan_Make_Arg + (Project_Node_Tree, Argv, And_Save => False); + + if not Gnatmake_Switch_Found + and then not Switch_May_Be_Passed_To_The_Compiler + then + Errutil.Error_Msg + ('"' & Argv & + """ is not a gnatmake switch. Consider moving " & + "it to Global_Compilation_Switches.", + Element.Location); + Errutil.Finalize; + Make_Failed ("*** illegal switch """ & Argv & """"); + end if; + end; + end if; + + Switch_List := Element.Next; + end loop; + end if; + end if; + end Add_Switches; + + ---------- + -- Bind -- + ---------- + + procedure Bind (ALI_File : File_Name_Type; Args : Argument_List) is + Bind_Args : Argument_List (1 .. Args'Last + 2); + Bind_Last : Integer; + Success : Boolean; + + begin + pragma Assert (Args'First = 1); + + -- Optimize the simple case where the gnatbind command line looks like + -- gnatbind -aO. -I- file.ali --into-> gnatbind file.adb + + if Args'Length = 2 + and then Args (Args'First).all = "-aO" & Normalized_CWD + and then Args (Args'Last).all = "-I-" + and then ALI_File = Strip_Directory (ALI_File) + then + Bind_Last := Args'First - 1; + + else + Bind_Last := Args'Last; + Bind_Args (Args'Range) := Args; + end if; + + -- It is completely pointless to re-check source file time stamps. This + -- has been done already by gnatmake + + Bind_Last := Bind_Last + 1; + Bind_Args (Bind_Last) := Do_Not_Check_Flag; + + Get_Name_String (ALI_File); + + Bind_Last := Bind_Last + 1; + Bind_Args (Bind_Last) := new String'(Name_Buffer (1 .. Name_Len)); + + GNAT.OS_Lib.Normalize_Arguments (Bind_Args (Args'First .. Bind_Last)); + + Display (Gnatbind.all, Bind_Args (Args'First .. Bind_Last)); + + if Gnatbind_Path = null then + Make_Failed ("error, unable to locate " & Gnatbind.all); + end if; + + GNAT.OS_Lib.Spawn + (Gnatbind_Path.all, Bind_Args (Args'First .. Bind_Last), Success); + + if not Success then + Make_Failed ("*** bind failed."); + end if; + end Bind; + + -------------------------------- + -- Change_To_Object_Directory -- + -------------------------------- + + procedure Change_To_Object_Directory (Project : Project_Id) is + Object_Directory : Path_Name_Type; + + begin + pragma Assert (Project /= No_Project); + + -- Nothing to do if the current working directory is already the correct + -- object directory. + + if Project_Of_Current_Object_Directory /= Project then + Project_Of_Current_Object_Directory := Project; + Object_Directory := Project.Object_Directory.Display_Name; + + -- Set the working directory to the object directory of the actual + -- project. + + if Verbose_Mode then + Write_Str ("Changing to object directory of """); + Write_Name (Project.Display_Name); + Write_Str (""": """); + Write_Name (Object_Directory); + Write_Line (""""); + end if; + + Change_Dir (Get_Name_String (Object_Directory)); + end if; + + exception + -- Fail if unable to change to the object directory + + when Directory_Error => + Make_Failed ("unable to change to object directory """ & + Path_Or_File_Name + (Project.Object_Directory.Display_Name) & + """ of project " & + Get_Name_String (Project.Display_Name)); + end Change_To_Object_Directory; + + ----------- + -- Check -- + ----------- + + procedure Check + (Source_File : File_Name_Type; + Source_Index : Int; + Is_Main_Source : Boolean; + The_Args : Argument_List; + Lib_File : File_Name_Type; + Full_Lib_File : File_Name_Type; + Lib_File_Attr : access File_Attributes; + Read_Only : Boolean; + ALI : out ALI_Id; + O_File : out File_Name_Type; + O_Stamp : out Time_Stamp_Type) + is + function First_New_Spec (A : ALI_Id) return File_Name_Type; + -- Looks in the with table entries of A and returns the spec file name + -- of the first withed unit (subprogram) for which no spec existed when + -- A was generated but for which there exists one now, implying that A + -- is now obsolete. If no such unit is found No_File is returned. + -- Otherwise the spec file name of the unit is returned. + -- + -- **WARNING** in the event of Uname format modifications, one *MUST* + -- make sure this function is also updated. + -- + -- Note: This function should really be in ali.adb and use Uname + -- services, but this causes the whole compiler to be dragged along + -- for gnatbind and gnatmake. + + -------------------- + -- First_New_Spec -- + -------------------- + + function First_New_Spec (A : ALI_Id) return File_Name_Type is + Spec_File_Name : File_Name_Type := No_File; + + function New_Spec (Uname : Unit_Name_Type) return Boolean; + -- Uname is the name of the spec or body of some ada unit. This + -- function returns True if the Uname is the name of a body which has + -- a spec not mentioned in ALI file A. If True is returned + -- Spec_File_Name above is set to the name of this spec file. + + -------------- + -- New_Spec -- + -------------- + + function New_Spec (Uname : Unit_Name_Type) return Boolean is + Spec_Name : Unit_Name_Type; + File_Name : File_Name_Type; + + begin + -- Test whether Uname is the name of a body unit (i.e. ends + -- with %b) + + Get_Name_String (Uname); + pragma + Assert (Name_Len > 2 and then Name_Buffer (Name_Len - 1) = '%'); + + if Name_Buffer (Name_Len) /= 'b' then + return False; + end if; + + -- Convert unit name into spec name + + -- ??? this code seems dubious in presence of pragma + -- Source_File_Name since there is no more direct relationship + -- between unit name and file name. + + -- ??? Further, what about alternative subunit naming + + Name_Buffer (Name_Len) := 's'; + Spec_Name := Name_Find; + File_Name := Get_File_Name (Spec_Name, Subunit => False); + + -- Look if File_Name is mentioned in A's sdep list. + -- If not look if the file exists. If it does return True. + + for D in + ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep + loop + if Sdep.Table (D).Sfile = File_Name then + return False; + end if; + end loop; + + if Full_Source_Name (File_Name) /= No_File then + Spec_File_Name := File_Name; + return True; + end if; + + return False; + end New_Spec; + + -- Start of processing for First_New_Spec + + begin + U_Chk : for U in + ALIs.Table (A).First_Unit .. ALIs.Table (A).Last_Unit + loop + exit U_Chk when Units.Table (U).Utype = Is_Body_Only + and then New_Spec (Units.Table (U).Uname); + + for W in Units.Table (U).First_With + .. + Units.Table (U).Last_With + loop + exit U_Chk when + Withs.Table (W).Afile /= No_File + and then New_Spec (Withs.Table (W).Uname); + end loop; + end loop U_Chk; + + return Spec_File_Name; + end First_New_Spec; + + --------------------------------- + -- Data declarations for Check -- + --------------------------------- + + Full_Obj_File : File_Name_Type; + -- Full name of the object file corresponding to Lib_File + + Lib_Stamp : Time_Stamp_Type; + -- Time stamp of the current ada library file + + Obj_Stamp : Time_Stamp_Type; + -- Time stamp of the current object file + + Modified_Source : File_Name_Type; + -- The first source in Lib_File whose current time stamp differs + -- from that stored in Lib_File. + + New_Spec : File_Name_Type; + -- If Lib_File contains in its W (with) section a body (for a + -- subprogram) for which there exists a spec and the spec did not + -- appear in the Sdep section of Lib_File, New_Spec contains the file + -- name of this new spec. + + Source_Name : File_Name_Type; + Text : Text_Buffer_Ptr; + + Prev_Switch : String_Access; + -- Previous switch processed + + Arg : Arg_Id := Arg_Id'First; + -- Current index in Args.Table for a given unit (init to stop warning) + + Switch_Found : Boolean; + -- True if a given switch has been found + + ALI_Project : Project_Id; + -- If the ALI file is in the object directory of a project, this is + -- the project id. + + -- Start of processing for Check + + begin + pragma Assert (Lib_File /= No_File); + + -- If ALI file is read-only, temporarily set Check_Object_Consistency to + -- False. We don't care if the object file is not there (presumably a + -- library will be used for linking.) + + if Read_Only then + declare + Saved_Check_Object_Consistency : constant Boolean := + Check_Object_Consistency; + begin + Check_Object_Consistency := False; + Text := Read_Library_Info_From_Full (Full_Lib_File, Lib_File_Attr); + Check_Object_Consistency := Saved_Check_Object_Consistency; + end; + + else + Text := Read_Library_Info_From_Full (Full_Lib_File, Lib_File_Attr); + end if; + + Full_Obj_File := Full_Object_File_Name; + Lib_Stamp := Current_Library_File_Stamp; + Obj_Stamp := Current_Object_File_Stamp; + + if Full_Lib_File = No_File then + Verbose_Msg + (Lib_File, + "being checked ...", + Prefix => " ", + Minimum_Verbosity => Opt.Medium); + else + Verbose_Msg + (Full_Lib_File, + "being checked ...", + Prefix => " ", + Minimum_Verbosity => Opt.Medium); + end if; + + ALI := No_ALI_Id; + O_File := Full_Obj_File; + O_Stamp := Obj_Stamp; + + if Text = null then + if Full_Lib_File = No_File then + Verbose_Msg (Lib_File, "missing."); + + elsif Obj_Stamp (Obj_Stamp'First) = ' ' then + Verbose_Msg (Full_Obj_File, "missing."); + + else + Verbose_Msg + (Full_Lib_File, "(" & String (Lib_Stamp) & ") newer than", + Full_Obj_File, "(" & String (Obj_Stamp) & ")"); + end if; + + else + ALI := Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True); + Free (Text); + + if ALI = No_ALI_Id then + Verbose_Msg (Full_Lib_File, "incorrectly formatted ALI file"); + return; + + elsif ALIs.Table (ALI).Ver (1 .. ALIs.Table (ALI).Ver_Len) /= + Verbose_Library_Version + then + Verbose_Msg (Full_Lib_File, "compiled with old GNAT version"); + ALI := No_ALI_Id; + return; + end if; + + -- Don't take Ali file into account if it was generated with + -- errors. + + if ALIs.Table (ALI).Compile_Errors then + Verbose_Msg (Full_Lib_File, "had errors, must be recompiled"); + ALI := No_ALI_Id; + return; + end if; + + -- Don't take Ali file into account if it was generated without + -- object. + + if Operating_Mode /= Check_Semantics + and then ALIs.Table (ALI).No_Object + then + Verbose_Msg (Full_Lib_File, "has no corresponding object"); + ALI := No_ALI_Id; + return; + end if; + + -- When compiling with -gnatc, don't take ALI file into account if + -- it has not been generated for the current source, for example if + -- it has been generated for the spec, but we are compiling the body. + + if Operating_Mode = Check_Semantics then + declare + File_Name : constant String := Get_Name_String (Source_File); + OK : Boolean := False; + + begin + for U in ALIs.Table (ALI).First_Unit .. + ALIs.Table (ALI).Last_Unit + loop + OK := Get_Name_String (Units.Table (U).Sfile) = File_Name; + exit when OK; + end loop; + + if not OK then + Verbose_Msg + (Full_Lib_File, "not generated for the same source"); + ALI := No_ALI_Id; + return; + end if; + end; + end if; + + -- Check for matching compiler switches if needed + + if Check_Switches then + + -- First, collect all the switches + + Collect_Arguments + (Source_File, Source_Index, Is_Main_Source, The_Args); + + Prev_Switch := Dummy_Switch; + + Get_Name_String (ALIs.Table (ALI).Sfile); + + Switches_To_Check.Set_Last (0); + + for J in 1 .. Last_Argument loop + + -- Skip non switches -c, -I and -o switches + + if Arguments (J) (1) = '-' + and then Arguments (J) (2) /= 'c' + and then Arguments (J) (2) /= 'o' + and then Arguments (J) (2) /= 'I' + then + Normalize_Compiler_Switches + (Arguments (J).all, + Normalized_Switches, + Last_Norm_Switch); + + for K in 1 .. Last_Norm_Switch loop + Switches_To_Check.Increment_Last; + Switches_To_Check.Table (Switches_To_Check.Last) := + Normalized_Switches (K); + end loop; + end if; + end loop; + + for J in 1 .. Switches_To_Check.Last loop + + -- Comparing switches is delicate because gcc reorders a number + -- of switches, according to lang-specs.h, but gnatmake doesn't + -- have sufficient knowledge to perform the same reordering. + -- Instead, we ignore orders between different "first letter" + -- switches, but keep orders between same switches, e.g -O -O2 + -- is different than -O2 -O, but -g -O is equivalent to -O -g. + + if Switches_To_Check.Table (J) (2) /= Prev_Switch (2) or else + (Prev_Switch'Length >= 6 and then + Prev_Switch (2 .. 5) = "gnat" and then + Switches_To_Check.Table (J)'Length >= 6 and then + Switches_To_Check.Table (J) (2 .. 5) = "gnat" and then + Prev_Switch (6) /= Switches_To_Check.Table (J) (6)) + then + Prev_Switch := Switches_To_Check.Table (J); + Arg := + Units.Table (ALIs.Table (ALI).First_Unit).First_Arg; + end if; + + Switch_Found := False; + + for K in Arg .. + Units.Table (ALIs.Table (ALI).First_Unit).Last_Arg + loop + if + Switches_To_Check.Table (J).all = Args.Table (K).all + then + Arg := K + 1; + Switch_Found := True; + exit; + end if; + end loop; + + if not Switch_Found then + if Verbose_Mode then + Verbose_Msg (ALIs.Table (ALI).Sfile, + "switch mismatch """ & + Switches_To_Check.Table (J).all & '"'); + end if; + + ALI := No_ALI_Id; + return; + end if; + end loop; + + if Switches_To_Check.Last /= + Integer (Units.Table (ALIs.Table (ALI).First_Unit).Last_Arg - + Units.Table (ALIs.Table (ALI).First_Unit).First_Arg + 1) + then + if Verbose_Mode then + Verbose_Msg (ALIs.Table (ALI).Sfile, + "different number of switches"); + + for K in Units.Table (ALIs.Table (ALI).First_Unit).First_Arg + .. Units.Table (ALIs.Table (ALI).First_Unit).Last_Arg + loop + Write_Str (Args.Table (K).all); + Write_Char (' '); + end loop; + + Write_Eol; + + for J in 1 .. Switches_To_Check.Last loop + Write_Str (Switches_To_Check.Table (J).all); + Write_Char (' '); + end loop; + + Write_Eol; + end if; + + ALI := No_ALI_Id; + return; + end if; + end if; + + -- Get the source files and their message digests. Note that some + -- sources may be missing if ALI is out-of-date. + + Set_Source_Table (ALI); + + Modified_Source := Time_Stamp_Mismatch (ALI, Read_Only); + + -- To avoid using too much memory when switch -m is used, free the + -- memory allocated for the source file when computing the checksum. + + if Minimal_Recompilation then + Sinput.P.Clear_Source_File_Table; + end if; + + if Modified_Source /= No_File then + ALI := No_ALI_Id; + + if Verbose_Mode then + Source_Name := Full_Source_Name (Modified_Source); + + if Source_Name /= No_File then + Verbose_Msg (Source_Name, "time stamp mismatch"); + else + Verbose_Msg (Modified_Source, "missing"); + end if; + end if; + + else + New_Spec := First_New_Spec (ALI); + + if New_Spec /= No_File then + ALI := No_ALI_Id; + + if Verbose_Mode then + Source_Name := Full_Source_Name (New_Spec); + + if Source_Name /= No_File then + Verbose_Msg (Source_Name, "new spec"); + else + Verbose_Msg (New_Spec, "old spec missing"); + end if; + end if; + + elsif not Read_Only and then Main_Project /= No_Project then + if not Check_Source_Info_In_ALI (ALI, Project_Tree) then + ALI := No_ALI_Id; + return; + end if; + + -- Check that the ALI file is in the correct object directory. + -- If it is in the object directory of a project that is + -- extended and it depends on a source that is in one of its + -- extending projects, then the ALI file is not in the correct + -- object directory. + + -- First, find the project of this ALI file. As there may be + -- several projects with the same object directory, we first + -- need to find the project of the source. + + ALI_Project := No_Project; + + declare + Udata : Prj.Unit_Index; + + begin + Udata := Units_Htable.Get_First (Project_Tree.Units_HT); + while Udata /= No_Unit_Index loop + if Udata.File_Names (Impl) /= null + and then Udata.File_Names (Impl).File = Source_File + then + ALI_Project := Udata.File_Names (Impl).Project; + exit; + + elsif Udata.File_Names (Spec) /= null + and then Udata.File_Names (Spec).File = Source_File + then + ALI_Project := Udata.File_Names (Spec).Project; + exit; + end if; + + Udata := Units_Htable.Get_Next (Project_Tree.Units_HT); + end loop; + end; + + if ALI_Project = No_Project then + return; + end if; + + declare + Obj_Dir : Path_Name_Type; + Res_Obj_Dir : constant String := + Normalize_Pathname + (Dir_Name + (Get_Name_String (Full_Lib_File)), + Resolve_Links => + Opt.Follow_Links_For_Dirs, + Case_Sensitive => False); + + begin + Name_Len := 0; + Add_Str_To_Name_Buffer (Res_Obj_Dir); + + if not Is_Directory_Separator (Name_Buffer (Name_Len)) then + Add_Char_To_Name_Buffer (Directory_Separator); + end if; + + Obj_Dir := Name_Find; + + while ALI_Project /= No_Project + and then Obj_Dir /= ALI_Project.Object_Directory.Name + loop + ALI_Project := ALI_Project.Extended_By; + end loop; + end; + + if ALI_Project = No_Project then + ALI := No_ALI_Id; + + Verbose_Msg (Lib_File, " wrong object directory"); + return; + end if; + + -- If the ALI project is not extended, then it must be in + -- the correct object directory. + + if ALI_Project.Extended_By = No_Project then + return; + end if; + + -- Count the extending projects + + declare + Num_Ext : Natural; + Proj : Project_Id; + + begin + Num_Ext := 0; + Proj := ALI_Project; + loop + Proj := Proj.Extended_By; + exit when Proj = No_Project; + Num_Ext := Num_Ext + 1; + end loop; + + -- Make a list of the extending projects + + declare + Projects : array (1 .. Num_Ext) of Project_Id; + Dep : Sdep_Record; + OK : Boolean := True; + UID : Unit_Index; + + begin + Proj := ALI_Project; + for J in Projects'Range loop + Proj := Proj.Extended_By; + Projects (J) := Proj; + end loop; + + -- Now check if any of the dependant sources are in + -- any of these extending projects. + + D_Chk : + for D in ALIs.Table (ALI).First_Sdep .. + ALIs.Table (ALI).Last_Sdep + loop + Dep := Sdep.Table (D); + UID := Units_Htable.Get_First (Project_Tree.Units_HT); + Proj := No_Project; + + Unit_Loop : + while UID /= null loop + if UID.File_Names (Impl) /= null + and then UID.File_Names (Impl).File = Dep.Sfile + then + Proj := UID.File_Names (Impl).Project; + + elsif UID.File_Names (Spec) /= null + and then UID.File_Names (Spec).File = Dep.Sfile + then + Proj := UID.File_Names (Spec).Project; + end if; + + -- If a source is in a project, check if it is one + -- in the list. + + if Proj /= No_Project then + for J in Projects'Range loop + if Proj = Projects (J) then + OK := False; + exit D_Chk; + end if; + end loop; + + exit Unit_Loop; + end if; + + UID := + Units_Htable.Get_Next (Project_Tree.Units_HT); + end loop Unit_Loop; + end loop D_Chk; + + -- If one of the dependent sources is in one project of + -- the list, then we must recompile. + + if not OK then + ALI := No_ALI_Id; + Verbose_Msg (Lib_File, " wrong object directory"); + end if; + end; + end; + end if; + end if; + end if; + end Check; + + ------------------------ + -- Check_For_S_Switch -- + ------------------------ + + procedure Check_For_S_Switch is + begin + -- By default, we generate an object file + + Output_Is_Object := True; + + for Arg in 1 .. Last_Argument loop + if Arguments (Arg).all = "-S" then + Output_Is_Object := False; + + elsif Arguments (Arg).all = "-c" then + Output_Is_Object := True; + end if; + end loop; + end Check_For_S_Switch; + + -------------------------- + -- Check_Linker_Options -- + -------------------------- + + procedure Check_Linker_Options + (E_Stamp : Time_Stamp_Type; + O_File : out File_Name_Type; + O_Stamp : out Time_Stamp_Type) + is + procedure Check_File (File : File_Name_Type); + -- Update O_File and O_Stamp if the given file is younger than E_Stamp + -- and O_Stamp, or if O_File is No_File and File does not exist. + + function Get_Library_File (Name : String) return File_Name_Type; + -- Return the full file name including path of a library based + -- on the name specified with the -l linker option, using the + -- Ada object path. Return No_File if no such file can be found. + + type Char_Array is array (Natural) of Character; + type Char_Array_Access is access constant Char_Array; + + Template : Char_Array_Access; + pragma Import (C, Template, "__gnat_library_template"); + + ---------------- + -- Check_File -- + ---------------- + + procedure Check_File (File : File_Name_Type) is + Stamp : Time_Stamp_Type; + Name : File_Name_Type := File; + + begin + Get_Name_String (Name); + + -- Remove any trailing NUL characters + + while Name_Len >= Name_Buffer'First + and then Name_Buffer (Name_Len) = NUL + loop + Name_Len := Name_Len - 1; + end loop; + + if Name_Len = 0 then + return; + + elsif Name_Buffer (1) = '-' then + + -- Do not check if File is a switch other than "-l" + + if Name_Buffer (2) /= 'l' then + return; + end if; + + -- The argument is a library switch, get actual name. It + -- is necessary to make a copy of the relevant part of + -- Name_Buffer as Get_Library_Name uses Name_Buffer as well. + + declare + Base_Name : constant String := Name_Buffer (3 .. Name_Len); + + begin + Name := Get_Library_File (Base_Name); + end; + + if Name = No_File then + return; + end if; + end if; + + Stamp := File_Stamp (Name); + + -- Find the youngest object file that is younger than the + -- executable. If no such file exist, record the first object + -- file that is not found. + + if (O_Stamp < Stamp and then E_Stamp < Stamp) + or else (O_File = No_File and then Stamp (Stamp'First) = ' ') + then + O_Stamp := Stamp; + O_File := Name; + + -- Strip the trailing NUL if present + + Get_Name_String (O_File); + + if Name_Buffer (Name_Len) = NUL then + Name_Len := Name_Len - 1; + O_File := Name_Find; + end if; + end if; + end Check_File; + + ---------------------- + -- Get_Library_Name -- + ---------------------- + + -- See comments in a-adaint.c about template syntax + + function Get_Library_File (Name : String) return File_Name_Type is + File : File_Name_Type := No_File; + + begin + Name_Len := 0; + + for Ptr in Template'Range loop + case Template (Ptr) is + when '*' => + Add_Str_To_Name_Buffer (Name); + + when ';' => + File := Full_Lib_File_Name (Name_Find); + exit when File /= No_File; + Name_Len := 0; + + when NUL => + exit; + + when others => + Add_Char_To_Name_Buffer (Template (Ptr)); + end case; + end loop; + + -- The for loop exited because the end of the template + -- was reached. File contains the last possible file name + -- for the library. + + if File = No_File and then Name_Len > 0 then + File := Full_Lib_File_Name (Name_Find); + end if; + + return File; + end Get_Library_File; + + -- Start of processing for Check_Linker_Options + + begin + O_File := No_File; + O_Stamp := (others => ' '); + + -- Process linker options from the ALI files + + for Opt in 1 .. Linker_Options.Last loop + Check_File (File_Name_Type (Linker_Options.Table (Opt).Name)); + end loop; + + -- Process options given on the command line + + for Opt in Linker_Switches.First .. Linker_Switches.Last loop + + -- Check if the previous Opt has one of the two switches + -- that take an extra parameter. (See GCC manual.) + + if Opt = Linker_Switches.First + or else (Linker_Switches.Table (Opt - 1).all /= "-u" + and then + Linker_Switches.Table (Opt - 1).all /= "-Xlinker" + and then + Linker_Switches.Table (Opt - 1).all /= "-L") + then + Name_Len := 0; + Add_Str_To_Name_Buffer (Linker_Switches.Table (Opt).all); + Check_File (Name_Find); + end if; + end loop; + + end Check_Linker_Options; + + ----------------- + -- Check_Steps -- + ----------------- + + procedure Check_Steps is + begin + -- If either -c, -b or -l has been specified, we will not necessarily + -- execute all steps. + + if Make_Steps then + Do_Compile_Step := Do_Compile_Step and Compile_Only; + Do_Bind_Step := Do_Bind_Step and Bind_Only; + Do_Link_Step := Do_Link_Step and Link_Only; + + -- If -c has been specified, but not -b, ignore any potential -l + + if Do_Compile_Step and then not Do_Bind_Step then + Do_Link_Step := False; + end if; + end if; + end Check_Steps; + + ----------------------- + -- Collect_Arguments -- + ----------------------- + + procedure Collect_Arguments + (Source_File : File_Name_Type; + Source_Index : Int; + Is_Main_Source : Boolean; + Args : Argument_List) + is + begin + Arguments_Project := No_Project; + Last_Argument := 0; + Add_Arguments (Args); + + if Main_Project /= No_Project then + declare + Source_File_Name : constant String := + Get_Name_String (Source_File); + Compiler_Package : Prj.Package_Id; + Switches : Prj.Variable_Value; + + begin + Prj.Env. + Get_Reference + (Source_File_Name => Source_File_Name, + Project => Arguments_Project, + Path => Arguments_Path_Name, + In_Tree => Project_Tree); + + -- If the source is not a source of a project file, add the + -- recorded arguments. Check will be done later if the source + -- need to be compiled that the switch -x has been used. + + if Arguments_Project = No_Project then + Add_Arguments (The_Saved_Gcc_Switches.all); + + elsif not Arguments_Project.Externally_Built + or else Must_Compile + then + -- We get the project directory for the relative path + -- switches and arguments. + + Arguments_Project := + Ultimate_Extending_Project_Of (Arguments_Project); + + -- If building a dynamic or relocatable library, compile with + -- PIC option, if it exists. + + if Arguments_Project.Library + and then Arguments_Project.Library_Kind /= Static + then + declare + PIC : constant String := MLib.Tgt.PIC_Option; + begin + if PIC /= "" then + Add_Arguments ((1 => new String'(PIC))); + end if; + end; + end if; + + -- We now look for package Compiler and get the switches from + -- this package. + + Compiler_Package := + Prj.Util.Value_Of + (Name => Name_Compiler, + In_Packages => Arguments_Project.Decl.Packages, + In_Tree => Project_Tree); + + if Compiler_Package /= No_Package then + + -- If package Gnatmake.Compiler exists, we get the specific + -- switches for the current source, or the global switches, + -- if any. + + Switches := + Switches_Of + (Source_File => Source_File, + Source_File_Name => Source_File_Name, + Source_Index => Source_Index, + Project => Arguments_Project, + In_Package => Compiler_Package, + Allow_ALI => False); + + end if; + + case Switches.Kind is + + -- We have a list of switches. We add these switches, + -- plus the saved gcc switches. + + when List => + + declare + Current : String_List_Id := Switches.Values; + Element : String_Element; + Number : Natural := 0; + + begin + while Current /= Nil_String loop + Element := Project_Tree.String_Elements. + Table (Current); + Number := Number + 1; + Current := Element.Next; + end loop; + + declare + New_Args : Argument_List (1 .. Number); + Last_New : Natural := 0; + Dir_Path : constant String := Get_Name_String + (Arguments_Project.Directory.Display_Name); + + begin + Current := Switches.Values; + + for Index in New_Args'Range loop + Element := Project_Tree.String_Elements. + Table (Current); + Get_Name_String (Element.Value); + + if Name_Len > 0 then + Last_New := Last_New + 1; + New_Args (Last_New) := + new String'(Name_Buffer (1 .. Name_Len)); + Test_If_Relative_Path + (New_Args (Last_New), + Parent => Dir_Path, + Including_Non_Switch => False); + end if; + + Current := Element.Next; + end loop; + + Add_Arguments + (Configuration_Pragmas_Switch + (Arguments_Project) & + New_Args (1 .. Last_New) & + The_Saved_Gcc_Switches.all); + end; + end; + + -- We have a single switch. We add this switch, + -- plus the saved gcc switches. + + when Single => + Get_Name_String (Switches.Value); + + declare + New_Args : Argument_List := + (1 => new String' + (Name_Buffer (1 .. Name_Len))); + Dir_Path : constant String := + Get_Name_String + (Arguments_Project. + Directory.Display_Name); + + begin + Test_If_Relative_Path + (New_Args (1), + Parent => Dir_Path, + Including_Non_Switch => False); + Add_Arguments + (Configuration_Pragmas_Switch (Arguments_Project) & + New_Args & The_Saved_Gcc_Switches.all); + end; + + -- We have no switches from Gnatmake.Compiler. + -- We add the saved gcc switches. + + when Undefined => + Add_Arguments + (Configuration_Pragmas_Switch (Arguments_Project) & + The_Saved_Gcc_Switches.all); + end case; + end if; + end; + end if; + + -- For VMS, when compiling the main source, add switch + -- -mdebug-main=_ada_ so that the executable can be debugged + -- by the standard VMS debugger. + + if not No_Main_Subprogram + and then Targparm.OpenVMS_On_Target + and then Is_Main_Source + then + -- First, check if compilation will be invoked with -g + + for J in 1 .. Last_Argument loop + if Arguments (J)'Length >= 2 + and then Arguments (J) (1 .. 2) = "-g" + and then (Arguments (J)'Length < 5 + or else Arguments (J) (1 .. 5) /= "-gnat") + then + Add_Arguments + ((1 => new String'("-mdebug-main=_ada_"))); + exit; + end if; + end loop; + end if; + + -- Set Output_Is_Object, depending if there is a -S switch. + -- If the bind step is not performed, and there is a -S switch, + -- then we will not check for a valid object file. + + Check_For_S_Switch; + end Collect_Arguments; + + --------------------- + -- Compile_Sources -- + --------------------- + + procedure Compile_Sources + (Main_Source : File_Name_Type; + Args : Argument_List; + First_Compiled_File : out File_Name_Type; + Most_Recent_Obj_File : out File_Name_Type; + Most_Recent_Obj_Stamp : out Time_Stamp_Type; + Main_Unit : out Boolean; + Compilation_Failures : out Natural; + Main_Index : Int := 0; + Check_Readonly_Files : Boolean := False; + Do_Not_Execute : Boolean := False; + Force_Compilations : Boolean := False; + Keep_Going : Boolean := False; + In_Place_Mode : Boolean := False; + Initialize_ALI_Data : Boolean := True; + Max_Process : Positive := 1) + is + Mfile : Natural := No_Mapping_File; + Mapping_File_Arg : String_Access; + -- Info on the mapping file + + Need_To_Check_Standard_Library : Boolean := + (Check_Readonly_Files or Must_Compile) + and not Unique_Compile; + + procedure Add_Process + (Pid : Process_Id; + Sfile : File_Name_Type; + Afile : File_Name_Type; + Uname : Unit_Name_Type; + Full_Lib_File : File_Name_Type; + Lib_File_Attr : File_Attributes; + Mfile : Natural := No_Mapping_File); + -- Adds process Pid to the current list of outstanding compilation + -- processes and record the full name of the source file Sfile that + -- we are compiling, the name of its library file Afile and the + -- name of its unit Uname. If Mfile is not equal to No_Mapping_File, + -- it is the index of the mapping file used during compilation in the + -- array The_Mapping_File_Names. + + procedure Await_Compile + (Data : out Compilation_Data; + OK : out Boolean); + -- Awaits that an outstanding compilation process terminates. When it + -- does set Data to the information registered for the corresponding + -- call to Add_Process. Note that this time stamp can be used to check + -- whether the compilation did generate an object file. OK is set to + -- True if the compilation succeeded. Data could be No_Compilation_Data + -- if there was no compilation to wait for. + + function Bad_Compilation_Count return Natural; + -- Returns the number of compilation failures + + procedure Check_Standard_Library; + -- Check if s-stalib.adb needs to be compiled + + procedure Collect_Arguments_And_Compile + (Full_Source_File : File_Name_Type; + Lib_File : File_Name_Type; + Source_Index : Int; + Pid : out Process_Id; + Process_Created : out Boolean); + -- Collect arguments from project file (if any) and compile. If no + -- compilation was attempted, Processed_Created is set to False, and the + -- value of Pid is unknown. + + function Compile + (Project : Project_Id; + S : File_Name_Type; + L : File_Name_Type; + Source_Index : Int; + Args : Argument_List) return Process_Id; + -- Compiles S using Args. If S is a GNAT predefined source "-gnatpg" is + -- added to Args. Non blocking call. L corresponds to the expected + -- library file name. Process_Id of the process spawned to execute the + -- compilation. + + type ALI_Project is record + ALI : ALI_Id; + Project : Project_Id; + end record; + + package Good_ALI is new Table.Table ( + Table_Component_Type => ALI_Project, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 100, + Table_Name => "Make.Good_ALI"); + -- Contains the set of valid ALI files that have not yet been scanned + + function Good_ALI_Present return Boolean; + -- Returns True if any ALI file was recorded in the previous set + + procedure Get_Mapping_File (Project : Project_Id); + -- Get a mapping file name. If there is one to be reused, reuse it. + -- Otherwise, create a new mapping file. + + function Get_Next_Good_ALI return ALI_Project; + -- Returns the next good ALI_Id record + + procedure Record_Failure + (File : File_Name_Type; + Unit : Unit_Name_Type; + Found : Boolean := True); + -- Records in the previous table that the compilation for File failed. + -- If Found is False then the compilation of File failed because we + -- could not find it. Records also Unit when possible. + + procedure Record_Good_ALI (A : ALI_Id; Project : Project_Id); + -- Records in the previous set the Id of an ALI file + + function Must_Exit_Because_Of_Error return Boolean; + -- Return True if there were errors and the user decided to exit in such + -- a case. This waits for any outstanding compilation. + + function Start_Compile_If_Possible (Args : Argument_List) return Boolean; + -- Check if there is more work that we can do (i.e. the Queue is non + -- empty). If there is, do it only if we have not yet used up all the + -- available processes. + -- Returns True if we should exit the main loop + + procedure Wait_For_Available_Slot; + -- Check if we should wait for a compilation to finish. This is the case + -- if all the available processes are busy compiling sources or there is + -- nothing else to do (that is the Q is empty and there are no good ALIs + -- to process). + + procedure Fill_Queue_From_ALI_Files; + -- Check if we recorded good ALI files. If yes process them now in the + -- order in which they have been recorded. There are two occasions in + -- which we record good ali files. The first is in phase 1 when, after + -- scanning an existing ALI file we realize it is up-to-date, the second + -- instance is after a successful compilation. + + ----------------- + -- Add_Process -- + ----------------- + + procedure Add_Process + (Pid : Process_Id; + Sfile : File_Name_Type; + Afile : File_Name_Type; + Uname : Unit_Name_Type; + Full_Lib_File : File_Name_Type; + Lib_File_Attr : File_Attributes; + Mfile : Natural := No_Mapping_File) + is + OC1 : constant Positive := Outstanding_Compiles + 1; + + begin + pragma Assert (OC1 <= Max_Process); + pragma Assert (Pid /= Invalid_Pid); + + Running_Compile (OC1) := + (Pid => Pid, + Full_Source_File => Sfile, + Lib_File => Afile, + Full_Lib_File => Full_Lib_File, + Lib_File_Attr => Lib_File_Attr, + Source_Unit => Uname, + Mapping_File => Mfile, + Project => Arguments_Project); + + Outstanding_Compiles := OC1; + + if Arguments_Project /= No_Project then + Queue.Set_Obj_Dir_Busy (Arguments_Project.Object_Directory.Name); + end if; + end Add_Process; + + -------------------- + -- Await_Compile -- + ------------------- + + procedure Await_Compile + (Data : out Compilation_Data; + OK : out Boolean) + is + Pid : Process_Id; + Project : Project_Id; + Comp_Data : Project_Compilation_Access; + + begin + pragma Assert (Outstanding_Compiles > 0); + + Data := No_Compilation_Data; + OK := False; + + -- The loop here is a work-around for a problem on VMS; in some + -- circumstances (shared library and several executables, for + -- example), there are child processes other than compilation + -- processes that are received. Until this problem is resolved, + -- we will ignore such processes. + + loop + Wait_Process (Pid, OK); + + if Pid = Invalid_Pid then + return; + end if; + + for J in Running_Compile'First .. Outstanding_Compiles loop + if Pid = Running_Compile (J).Pid then + Data := Running_Compile (J); + Project := Running_Compile (J).Project; + + if Project /= No_Project then + Queue.Set_Obj_Dir_Free (Project.Object_Directory.Name); + end if; + + -- If a mapping file was used by this compilation, get its + -- file name for reuse by a subsequent compilation. + + if Running_Compile (J).Mapping_File /= No_Mapping_File then + Comp_Data := + Project_Compilation_Htable.Get + (Project_Compilation, Project); + Comp_Data.Last_Free_Indexes := + Comp_Data.Last_Free_Indexes + 1; + Comp_Data.Free_Mapping_File_Indexes + (Comp_Data.Last_Free_Indexes) := + Running_Compile (J).Mapping_File; + end if; + + -- To actually remove this Pid and related info from + -- Running_Compile replace its entry with the last valid + -- entry in Running_Compile. + + if J = Outstanding_Compiles then + null; + else + Running_Compile (J) := + Running_Compile (Outstanding_Compiles); + end if; + + Outstanding_Compiles := Outstanding_Compiles - 1; + return; + end if; + end loop; + + -- This child process was not one of our compilation processes; + -- just ignore it for now. + + -- Why is this commented out code sitting here??? + + -- raise Program_Error; + end loop; + end Await_Compile; + + --------------------------- + -- Bad_Compilation_Count -- + --------------------------- + + function Bad_Compilation_Count return Natural is + begin + return Bad_Compilation.Last - Bad_Compilation.First + 1; + end Bad_Compilation_Count; + + ---------------------------- + -- Check_Standard_Library -- + ---------------------------- + + procedure Check_Standard_Library is + begin + Need_To_Check_Standard_Library := False; + + if not Targparm.Suppress_Standard_Library_On_Target then + declare + Sfile : File_Name_Type; + Add_It : Boolean := True; + + begin + Name_Len := 0; + Add_Str_To_Name_Buffer (Standard_Library_Package_Body_Name); + Sfile := Name_Enter; + + -- If we have a special runtime, we add the standard + -- library only if we can find it. + + if RTS_Switch then + Add_It := Full_Source_Name (Sfile) /= No_File; + end if; + + if Add_It then + if Is_Marked (Sfile) then + if Is_In_Obsoleted (Sfile) then + Executable_Obsolete := True; + end if; + + else + Queue.Insert (Sfile, Project => No_Project, Index => 0); + Mark (Sfile, Index => 0); + end if; + end if; + end; + end if; + end Check_Standard_Library; + + ----------------------------------- + -- Collect_Arguments_And_Compile -- + ----------------------------------- + + procedure Collect_Arguments_And_Compile + (Full_Source_File : File_Name_Type; + Lib_File : File_Name_Type; + Source_Index : Int; + Pid : out Process_Id; + Process_Created : out Boolean) is + begin + Process_Created := False; + + -- If we use mapping file (-P or -C switches), then get one + + if Create_Mapping_File then + Get_Mapping_File (Arguments_Project); + end if; + + -- If the source is part of a project file, we set the ADA_*_PATHs, + -- check for an eventual library project, and use the full path. + + if Arguments_Project /= No_Project then + if not Arguments_Project.Externally_Built + or else Must_Compile + then + Prj.Env.Set_Ada_Paths + (Arguments_Project, + Project_Tree, + Including_Libraries => True, + Include_Path => Use_Include_Path_File); + + if not Unique_Compile + and then MLib.Tgt.Support_For_Libraries /= Prj.None + then + declare + Prj : constant Project_Id := + Ultimate_Extending_Project_Of (Arguments_Project); + + begin + if Prj.Library + and then (not Prj.Externally_Built or else Must_Compile) + and then not Prj.Need_To_Build_Lib + then + -- Add to the Q all sources of the project that have + -- not been marked. + + Insert_Project_Sources + (The_Project => Prj, + All_Projects => False, + Into_Q => True); + + -- Now mark the project as processed + + Prj.Need_To_Build_Lib := True; + end if; + end; + end if; + + Pid := + Compile + (Project => Arguments_Project, + S => File_Name_Type (Arguments_Path_Name), + L => Lib_File, + Source_Index => Source_Index, + Args => Arguments (1 .. Last_Argument)); + Process_Created := True; + end if; + + else + -- If this is a source outside of any project file, make sure it + -- will be compiled in object directory of the main project file. + + Pid := + Compile + (Project => Main_Project, + S => Full_Source_File, + L => Lib_File, + Source_Index => Source_Index, + Args => Arguments (1 .. Last_Argument)); + Process_Created := True; + end if; + end Collect_Arguments_And_Compile; + + ------------- + -- Compile -- + ------------- + + function Compile + (Project : Project_Id; + S : File_Name_Type; + L : File_Name_Type; + Source_Index : Int; + Args : Argument_List) return Process_Id + is + Comp_Args : Argument_List (Args'First .. Args'Last + 10); + Comp_Next : Integer := Args'First; + Comp_Last : Integer; + Arg_Index : Integer; + + function Ada_File_Name (Name : File_Name_Type) return Boolean; + -- Returns True if Name is the name of an ada source file + -- (i.e. suffix is .ads or .adb) + + ------------------- + -- Ada_File_Name -- + ------------------- + + function Ada_File_Name (Name : File_Name_Type) return Boolean is + begin + Get_Name_String (Name); + return + Name_Len > 4 + and then Name_Buffer (Name_Len - 3 .. Name_Len - 1) = ".ad" + and then (Name_Buffer (Name_Len) = 'b' + or else + Name_Buffer (Name_Len) = 's'); + end Ada_File_Name; + + -- Start of processing for Compile + + begin + Enter_Into_Obsoleted (S); + + -- By default, Syntax_Only is False + + Syntax_Only := False; + + for J in Args'Range loop + if Args (J).all = "-gnats" then + + -- If we compile with -gnats, the bind step and the link step + -- are inhibited. Also, we set Syntax_Only to True, so that + -- we don't fail when we don't find the ALI file, after + -- compilation. + + Do_Bind_Step := False; + Do_Link_Step := False; + Syntax_Only := True; + + elsif Args (J).all = "-gnatc" then + + -- If we compile with -gnatc, the bind step and the link step + -- are inhibited. We set Syntax_Only to False for the case when + -- -gnats was previously specified. + + Do_Bind_Step := False; + Do_Link_Step := False; + Syntax_Only := False; + + elsif Args (J).all = "-gnatC" + or else Args (J).all = "-gnatcC" + then + -- If we compile with -gnatC, enable CodePeer globalize step + + Do_Codepeer_Globalize_Step := True; + end if; + end loop; + + Comp_Args (Comp_Next) := new String'("-gnatea"); + Comp_Next := Comp_Next + 1; + + Comp_Args (Comp_Next) := Comp_Flag; + Comp_Next := Comp_Next + 1; + + -- Optimize the simple case where the gcc command line looks like + -- gcc -c -I. ... -I- file.adb + -- into + -- gcc -c ... file.adb + + if Args (Args'First).all = "-I" & Normalized_CWD + and then Args (Args'Last).all = "-I-" + and then S = Strip_Directory (S) + then + Comp_Last := Comp_Next + Args'Length - 3; + Arg_Index := Args'First + 1; + + else + Comp_Last := Comp_Next + Args'Length - 1; + Arg_Index := Args'First; + end if; + + -- Make a deep copy of the arguments, because Normalize_Arguments + -- may deallocate some arguments. + + for J in Comp_Next .. Comp_Last loop + Comp_Args (J) := new String'(Args (Arg_Index).all); + Arg_Index := Arg_Index + 1; + end loop; + + -- Set -gnatpg for predefined files (for this purpose the renamings + -- such as Text_IO do not count as predefined). Note that we strip + -- the directory name from the source file name because the call to + -- Fname.Is_Predefined_File_Name cannot deal with directory prefixes. + + declare + Fname : constant File_Name_Type := Strip_Directory (S); + + begin + if Is_Predefined_File_Name (Fname, False) then + if Check_Readonly_Files or else Must_Compile then + Comp_Args (Comp_Args'First + 2 .. Comp_Last + 1) := + Comp_Args (Comp_Args'First + 1 .. Comp_Last); + Comp_Last := Comp_Last + 1; + Comp_Args (Comp_Args'First + 1) := GNAT_Flag; + + else + Make_Failed + ("not allowed to compile """ & + Get_Name_String (Fname) & + """; use -a switch, or compile file with " & + """-gnatg"" switch"); + end if; + end if; + end; + + -- Now check if the file name has one of the suffixes familiar to + -- the gcc driver. If this is not the case then add the ada flag + -- "-x ada". + + if not Ada_File_Name (S) and then not Targparm.AAMP_On_Target then + Comp_Last := Comp_Last + 1; + Comp_Args (Comp_Last) := Ada_Flag_1; + Comp_Last := Comp_Last + 1; + Comp_Args (Comp_Last) := Ada_Flag_2; + end if; + + if Source_Index /= 0 then + declare + Num : constant String := Source_Index'Img; + begin + Comp_Last := Comp_Last + 1; + Comp_Args (Comp_Last) := + new String'("-gnateI" & Num (Num'First + 1 .. Num'Last)); + end; + end if; + + if Source_Index /= 0 + or else L /= Strip_Directory (L) + or else Object_Directory_Path /= null + then + -- Build -o argument + + Get_Name_String (L); + + for J in reverse 1 .. Name_Len loop + if Name_Buffer (J) = '.' then + Name_Len := J + Object_Suffix'Length - 1; + Name_Buffer (J .. Name_Len) := Object_Suffix; + exit; + end if; + end loop; + + Comp_Last := Comp_Last + 1; + Comp_Args (Comp_Last) := Output_Flag; + Comp_Last := Comp_Last + 1; + + -- If an object directory was specified, prepend the object file + -- name with this object directory. + + if Object_Directory_Path /= null then + Comp_Args (Comp_Last) := + new String'(Object_Directory_Path.all & + Name_Buffer (1 .. Name_Len)); + + else + Comp_Args (Comp_Last) := + new String'(Name_Buffer (1 .. Name_Len)); + end if; + end if; + + if Create_Mapping_File and then Mapping_File_Arg /= null then + Comp_Last := Comp_Last + 1; + Comp_Args (Comp_Last) := new String'(Mapping_File_Arg.all); + end if; + + Get_Name_String (S); + + Comp_Last := Comp_Last + 1; + Comp_Args (Comp_Last) := new String'(Name_Buffer (1 .. Name_Len)); + + -- Change to object directory of the project file, if necessary + + if Project /= No_Project then + Change_To_Object_Directory (Project); + end if; + + GNAT.OS_Lib.Normalize_Arguments (Comp_Args (Args'First .. Comp_Last)); + + Comp_Last := Comp_Last + 1; + Comp_Args (Comp_Last) := new String'("-gnatez"); + + Display (Gcc.all, Comp_Args (Args'First .. Comp_Last)); + + if Gcc_Path = null then + Make_Failed ("error, unable to locate " & Gcc.all); + end if; + + return + GNAT.OS_Lib.Non_Blocking_Spawn + (Gcc_Path.all, Comp_Args (Args'First .. Comp_Last)); + end Compile; + + ------------------------------- + -- Fill_Queue_From_ALI_Files -- + ------------------------------- + + procedure Fill_Queue_From_ALI_Files is + ALI_P : ALI_Project; + ALI : ALI_Id; + Source_Index : Int; + Sfile : File_Name_Type; + Uname : Unit_Name_Type; + Unit_Name : Name_Id; + Uid : Prj.Unit_Index; + + begin + while Good_ALI_Present loop + ALI_P := Get_Next_Good_ALI; + ALI := ALI_P.ALI; + Source_Index := Unit_Index_Of (ALIs.Table (ALI_P.ALI).Afile); + + -- If we are processing the library file corresponding to the + -- main source file check if this source can be a main unit. + + if ALIs.Table (ALI).Sfile = Main_Source + and then Source_Index = Main_Index + then + Main_Unit := ALIs.Table (ALI).Main_Program /= None; + end if; + + -- The following adds the standard library (s-stalib) to the list + -- of files to be handled by gnatmake: this file and any files it + -- depends on are always included in every bind, even if they are + -- not in the explicit dependency list. Of course, it is not added + -- if Suppress_Standard_Library is True. + + -- However, to avoid annoying output about s-stalib.ali being read + -- only, when "-v" is used, we add the standard library only when + -- "-a" is used. + + if Need_To_Check_Standard_Library then + Check_Standard_Library; + end if; + + -- Now insert in the Q the unmarked source files (i.e. those which + -- have never been inserted in the Q and hence never considered). + -- Only do that if Unique_Compile is False. + + if not Unique_Compile then + for J in + ALIs.Table (ALI).First_Unit .. ALIs.Table (ALI).Last_Unit + loop + for K in + Units.Table (J).First_With .. Units.Table (J).Last_With + loop + Sfile := Withs.Table (K).Sfile; + Uname := Withs.Table (K).Uname; + + -- If project files are used, find the proper source to + -- compile in case Sfile is the spec but there is a body. + + if Main_Project /= No_Project then + Get_Name_String (Uname); + Name_Len := Name_Len - 2; + Unit_Name := Name_Find; + Uid := + Units_Htable.Get (Project_Tree.Units_HT, Unit_Name); + + if Uid /= Prj.No_Unit_Index then + if Uid.File_Names (Impl) /= null + and then not Uid.File_Names (Impl).Locally_Removed + then + Sfile := Uid.File_Names (Impl).File; + Source_Index := Uid.File_Names (Impl).Index; + + elsif Uid.File_Names (Spec) /= null + and then not Uid.File_Names (Spec).Locally_Removed + then + Sfile := Uid.File_Names (Spec).File; + Source_Index := Uid.File_Names (Spec).Index; + end if; + end if; + end if; + + Dependencies.Append ((ALIs.Table (ALI).Sfile, Sfile)); + + if Is_In_Obsoleted (Sfile) then + Executable_Obsolete := True; + end if; + + if Sfile = No_File then + Debug_Msg ("Skipping generic:", Withs.Table (K).Uname); + + else + Source_Index := Unit_Index_Of (Withs.Table (K).Afile); + + if Is_Marked (Sfile, Source_Index) then + Debug_Msg ("Skipping marked file:", Sfile); + + elsif not (Check_Readonly_Files or Must_Compile) + and then Is_Internal_File_Name (Sfile, False) + then + Debug_Msg ("Skipping internal file:", Sfile); + + else + Queue.Insert + (Sfile, + ALI_P.Project, + Withs.Table (K).Uname, + Source_Index); + Mark (Sfile, Source_Index); + end if; + end if; + end loop; + end loop; + end if; + end loop; + end Fill_Queue_From_ALI_Files; + + ---------------------- + -- Get_Mapping_File -- + ---------------------- + + procedure Get_Mapping_File (Project : Project_Id) is + Data : Project_Compilation_Access; + + begin + Data := Project_Compilation_Htable.Get (Project_Compilation, Project); + + -- If there is a mapping file ready to be reused, reuse it + + if Data.Last_Free_Indexes > 0 then + Mfile := Data.Free_Mapping_File_Indexes (Data.Last_Free_Indexes); + Data.Last_Free_Indexes := Data.Last_Free_Indexes - 1; + + -- Otherwise, create and initialize a new one + + else + Init_Mapping_File + (Project => Project, Data => Data.all, File_Index => Mfile); + end if; + + -- Put the name in the mapping file argument for the invocation + -- of the compiler. + + Free (Mapping_File_Arg); + Mapping_File_Arg := + new String'("-gnatem=" & + Get_Name_String (Data.Mapping_File_Names (Mfile))); + end Get_Mapping_File; + + ----------------------- + -- Get_Next_Good_ALI -- + ----------------------- + + function Get_Next_Good_ALI return ALI_Project is + ALIP : ALI_Project; + + begin + pragma Assert (Good_ALI_Present); + ALIP := Good_ALI.Table (Good_ALI.Last); + Good_ALI.Decrement_Last; + return ALIP; + end Get_Next_Good_ALI; + + ---------------------- + -- Good_ALI_Present -- + ---------------------- + + function Good_ALI_Present return Boolean is + begin + return Good_ALI.First <= Good_ALI.Last; + end Good_ALI_Present; + + -------------------------------- + -- Must_Exit_Because_Of_Error -- + -------------------------------- + + function Must_Exit_Because_Of_Error return Boolean is + Data : Compilation_Data; + Success : Boolean; + + begin + if Bad_Compilation_Count > 0 and then not Keep_Going then + while Outstanding_Compiles > 0 loop + Await_Compile (Data, Success); + + if not Success then + Record_Failure (Data.Full_Source_File, Data.Source_Unit); + end if; + end loop; + + return True; + end if; + + return False; + end Must_Exit_Because_Of_Error; + + -------------------- + -- Record_Failure -- + -------------------- + + procedure Record_Failure + (File : File_Name_Type; + Unit : Unit_Name_Type; + Found : Boolean := True) + is + begin + Bad_Compilation.Increment_Last; + Bad_Compilation.Table (Bad_Compilation.Last) := (File, Unit, Found); + end Record_Failure; + + --------------------- + -- Record_Good_ALI -- + --------------------- + + procedure Record_Good_ALI (A : ALI_Id; Project : Project_Id) is + begin + Good_ALI.Increment_Last; + Good_ALI.Table (Good_ALI.Last) := (A, Project); + end Record_Good_ALI; + + ------------------------------- + -- Start_Compile_If_Possible -- + ------------------------------- + + function Start_Compile_If_Possible + (Args : Argument_List) return Boolean + is + In_Lib_Dir : Boolean; + Need_To_Compile : Boolean; + Pid : Process_Id; + Process_Created : Boolean; + + Source_File : File_Name_Type; + Full_Source_File : File_Name_Type; + Source_File_Attr : aliased File_Attributes; + -- The full name of the source file and its attributes (size, ...) + + Source_Unit : Unit_Name_Type; + Source_Index : Int; + -- Index of the current unit in the current source file + + Lib_File : File_Name_Type; + Full_Lib_File : File_Name_Type; + Lib_File_Attr : aliased File_Attributes; + Read_Only : Boolean := False; + ALI : ALI_Id; + -- The ALI file and its attributes (size, stamp, ...) + + Obj_File : File_Name_Type; + Obj_Stamp : Time_Stamp_Type; + -- The object file + + begin + if not Queue.Is_Virtually_Empty and then + Outstanding_Compiles < Max_Process + then + Queue.Extract (Source_File, Source_Unit, Source_Index); + + Osint.Full_Source_Name + (Source_File, + Full_File => Full_Source_File, + Attr => Source_File_Attr'Access); + + Lib_File := Osint.Lib_File_Name (Source_File, Source_Index); + + -- ??? This call could be avoided when using projects, since we + -- know where the ALI file is supposed to be. That would avoid + -- searches in the object directories, including in the runtime + -- dir. However, that would require getting access to the + -- Source_Id. + + Osint.Full_Lib_File_Name + (Lib_File, + Lib_File => Full_Lib_File, + Attr => Lib_File_Attr); + + -- If source has already been compiled, executable is obsolete + + if Is_In_Obsoleted (Source_File) then + Executable_Obsolete := True; + end if; + + In_Lib_Dir := Full_Lib_File /= No_File + and then In_Ada_Lib_Dir (Full_Lib_File); + + -- Since the following requires a system call, we precompute it + -- when needed. + + if not In_Lib_Dir then + if Full_Lib_File /= No_File + and then not (Check_Readonly_Files or else Must_Compile) + then + Get_Name_String (Full_Lib_File); + Name_Buffer (Name_Len + 1) := ASCII.NUL; + Read_Only := not Is_Writable_File + (Name_Buffer'Address, Lib_File_Attr'Access); + else + Read_Only := False; + end if; + end if; + + -- If the library file is an Ada library skip it + + if In_Lib_Dir then + Verbose_Msg + (Lib_File, + "is in an Ada library", + Prefix => " ", + Minimum_Verbosity => Opt.High); + + -- If the library file is a read-only library skip it, but only + -- if, when using project files, this library file is in the + -- right object directory (a read-only ALI file in the object + -- directory of a project being extended must not be skipped). + + elsif Read_Only + and then Is_In_Object_Directory (Source_File, Full_Lib_File) + then + Verbose_Msg + (Lib_File, + "is a read-only library", + Prefix => " ", + Minimum_Verbosity => Opt.High); + + -- The source file that we are checking cannot be located + + elsif Full_Source_File = No_File then + Record_Failure (Source_File, Source_Unit, False); + + -- Source and library files can be located but are internal + -- files. + + elsif not (Check_Readonly_Files or else Must_Compile) + and then Full_Lib_File /= No_File + and then Is_Internal_File_Name (Source_File, False) + then + if Force_Compilations then + Fail + ("not allowed to compile """ & + Get_Name_String (Source_File) & + """; use -a switch, or compile file with " & + """-gnatg"" switch"); + end if; + + Verbose_Msg + (Lib_File, + "is an internal library", + Prefix => " ", + Minimum_Verbosity => Opt.High); + + -- The source file that we are checking can be located + + else + Collect_Arguments (Source_File, Source_Index, + Source_File = Main_Source, Args); + + -- Do nothing if project of source is externally built + + if Arguments_Project = No_Project + or else not Arguments_Project.Externally_Built + or else Must_Compile + then + -- Don't waste any time if we have to recompile anyway + + Obj_Stamp := Empty_Time_Stamp; + Need_To_Compile := Force_Compilations; + + if not Force_Compilations then + Check (Source_File => Source_File, + Source_Index => Source_Index, + Is_Main_Source => Source_File = Main_Source, + The_Args => Args, + Lib_File => Lib_File, + Full_Lib_File => Full_Lib_File, + Lib_File_Attr => Lib_File_Attr'Access, + Read_Only => Read_Only, + ALI => ALI, + O_File => Obj_File, + O_Stamp => Obj_Stamp); + Need_To_Compile := (ALI = No_ALI_Id); + end if; + + if not Need_To_Compile then + + -- The ALI file is up-to-date; record its Id + + Record_Good_ALI (ALI, Arguments_Project); + + -- Record the time stamp of the most recent object + -- file as long as no (re)compilations are needed. + + if First_Compiled_File = No_File + and then (Most_Recent_Obj_File = No_File + or else Obj_Stamp > Most_Recent_Obj_Stamp) + then + Most_Recent_Obj_File := Obj_File; + Most_Recent_Obj_Stamp := Obj_Stamp; + end if; + + else + -- Check that switch -x has been used if a source outside + -- of project files need to be compiled. + + if Main_Project /= No_Project + and then Arguments_Project = No_Project + and then not External_Unit_Compilation_Allowed + then + Make_Failed ("external source (" + & Get_Name_String (Source_File) + & ") is not part of any project;" + & " cannot be compiled without" + & " gnatmake switch -x"); + end if; + + -- Is this the first file we have to compile? + + if First_Compiled_File = No_File then + First_Compiled_File := Full_Source_File; + Most_Recent_Obj_File := No_File; + + if Do_Not_Execute then + + -- Exit the main loop + + return True; + end if; + end if; + + -- Compute where the ALI file must be generated in + -- In_Place_Mode (this does not require to know the + -- location of the object directory). + + if In_Place_Mode then + if Full_Lib_File = No_File then + + -- If the library file was not found, then save + -- the library file near the source file. + + Lib_File := + Osint.Lib_File_Name + (Full_Source_File, Source_Index); + Full_Lib_File := Lib_File; + + else + -- If the library file was found, then save the + -- library file in the same place. + + Lib_File := Full_Lib_File; + end if; + end if; + + -- Start the compilation and record it. We can do this + -- because there is at least one free process. This might + -- change the current directory. + + Collect_Arguments_And_Compile + (Full_Source_File => Full_Source_File, + Lib_File => Lib_File, + Source_Index => Source_Index, + Pid => Pid, + Process_Created => Process_Created); + + -- Compute where the ALI file will be generated (for + -- cases that might require to know the current + -- directory). The current directory might be changed + -- when compiling other files so we cannot rely on it + -- being the same to find the resulting ALI file. + + if not In_Place_Mode then + + -- Compute the expected location of the ALI file. This + -- can be from several places: + -- -i => in place mode. In such a case, + -- Full_Lib_File has already been set above + -- -D => if specified + -- or defaults in current dir + -- We could simply use a call similar to + -- Osint.Full_Lib_File_Name (Lib_File) + -- but that involves system calls and is thus slower + + if Object_Directory_Path /= null then + Name_Len := 0; + Add_Str_To_Name_Buffer (Object_Directory_Path.all); + Add_Str_To_Name_Buffer (Get_Name_String (Lib_File)); + Full_Lib_File := Name_Find; + + else + if Project_Of_Current_Object_Directory /= + No_Project + then + Get_Name_String + (Project_Of_Current_Object_Directory + .Object_Directory.Display_Name); + Add_Str_To_Name_Buffer + (Get_Name_String (Lib_File)); + Full_Lib_File := Name_Find; + + else + Full_Lib_File := Lib_File; + end if; + end if; + + end if; + + Lib_File_Attr := Unknown_Attributes; + + -- Make sure we could successfully start the compilation + + if Process_Created then + if Pid = Invalid_Pid then + Record_Failure (Full_Source_File, Source_Unit); + else + Add_Process + (Pid => Pid, + Sfile => Full_Source_File, + Afile => Lib_File, + Uname => Source_Unit, + Mfile => Mfile, + Full_Lib_File => Full_Lib_File, + Lib_File_Attr => Lib_File_Attr); + end if; + end if; + end if; + end if; + end if; + end if; + return False; + end Start_Compile_If_Possible; + + ----------------------------- + -- Wait_For_Available_Slot -- + ----------------------------- + + procedure Wait_For_Available_Slot is + Compilation_OK : Boolean; + Text : Text_Buffer_Ptr; + ALI : ALI_Id; + Data : Compilation_Data; + + begin + if Outstanding_Compiles = Max_Process + or else (Queue.Is_Virtually_Empty + and then not Good_ALI_Present + and then Outstanding_Compiles > 0) + then + Await_Compile (Data, Compilation_OK); + + if not Compilation_OK then + Record_Failure (Data.Full_Source_File, Data.Source_Unit); + end if; + + if Compilation_OK or else Keep_Going then + + -- Re-read the updated library file + + declare + Saved_Object_Consistency : constant Boolean := + Check_Object_Consistency; + + begin + -- If compilation was not OK, or if output is not an object + -- file and we don't do the bind step, don't check for + -- object consistency. + + Check_Object_Consistency := + Check_Object_Consistency + and Compilation_OK + and (Output_Is_Object or Do_Bind_Step); + + Text := + Read_Library_Info_From_Full + (Data.Full_Lib_File, Data.Lib_File_Attr'Access); + + -- Restore Check_Object_Consistency to its initial value + + Check_Object_Consistency := Saved_Object_Consistency; + end; + + -- If an ALI file was generated by this compilation, scan the + -- ALI file and record it. + + -- If the scan fails, a previous ali file is inconsistent with + -- the unit just compiled. + + if Text /= null then + ALI := + Scan_ALI + (Data.Lib_File, Text, Ignore_ED => False, Err => True); + + if ALI = No_ALI_Id then + + -- Record a failure only if not already done + + if Compilation_OK then + Inform + (Data.Lib_File, + "incompatible ALI file, please recompile"); + Record_Failure + (Data.Full_Source_File, Data.Source_Unit); + end if; + + else + Record_Good_ALI (ALI, Data.Project); + end if; + + Free (Text); + + -- If we could not read the ALI file that was just generated + -- then there could be a problem reading either the ALI or the + -- corresponding object file (if Check_Object_Consistency is + -- set Read_Library_Info checks that the time stamp of the + -- object file is more recent than that of the ALI). However, + -- we record a failure only if not already done. + + else + if Compilation_OK and not Syntax_Only then + Inform + (Data.Lib_File, + "WARNING: ALI or object file not found after compile"); + Record_Failure (Data.Full_Source_File, Data.Source_Unit); + end if; + end if; + end if; + end if; + end Wait_For_Available_Slot; + + -- Start of processing for Compile_Sources + + begin + pragma Assert (Args'First = 1); + + Outstanding_Compiles := 0; + Running_Compile := new Comp_Data_Arr (1 .. Max_Process); + + -- Package and Queue initializations + + Good_ALI.Init; + + if Initialize_ALI_Data then + Initialize_ALI; + Initialize_ALI_Source; + end if; + + -- The following two flags affect the behavior of ALI.Set_Source_Table. + -- We set Check_Source_Files to True to ensure that source file time + -- stamps are checked, and we set All_Sources to False to avoid checking + -- the presence of the source files listed in the source dependency + -- section of an ali file (which would be a mistake since the ali file + -- may be obsolete). + + Check_Source_Files := True; + All_Sources := False; + + -- Only insert in the Q if it is not already done, to avoid simultaneous + -- compilations if -jnnn is used. + + if not Is_Marked (Main_Source, Main_Index) then + Queue.Insert (Main_Source, Main_Project, Index => Main_Index); + Mark (Main_Source, Main_Index); + end if; + + First_Compiled_File := No_File; + Most_Recent_Obj_File := No_File; + Most_Recent_Obj_Stamp := Empty_Time_Stamp; + Main_Unit := False; + + -- Keep looping until there is no more work to do (the Q is empty) + -- and all the outstanding compilations have terminated. + + Make_Loop : + while not Queue.Is_Empty or else Outstanding_Compiles > 0 loop + exit Make_Loop when Must_Exit_Because_Of_Error; + exit Make_Loop when Start_Compile_If_Possible (Args); + + Wait_For_Available_Slot; + + -- ??? Should be done as soon as we add a Good_ALI, wouldn't it avoid + -- the need for a list of good ALI? + + Fill_Queue_From_ALI_Files; + + if Display_Compilation_Progress then + Write_Str ("completed "); + Write_Int (Int (Queue.Processed)); + Write_Str (" out of "); + Write_Int (Int (Queue.Size)); + Write_Str (" ("); + Write_Int (Int ((Queue.Processed * 100) / Queue.Size)); + Write_Str ("%)..."); + Write_Eol; + end if; + end loop Make_Loop; + + Compilation_Failures := Bad_Compilation_Count; + + -- Compilation is finished + + -- Delete any temporary configuration pragma file + + if not Debug.Debug_Flag_N then + Delete_Temp_Config_Files; + end if; + end Compile_Sources; + + ---------------------------------- + -- Configuration_Pragmas_Switch -- + ---------------------------------- + + function Configuration_Pragmas_Switch + (For_Project : Project_Id) return Argument_List + is + The_Packages : Package_Id; + Gnatmake : Package_Id; + Compiler : Package_Id; + + Global_Attribute : Variable_Value := Nil_Variable_Value; + Local_Attribute : Variable_Value := Nil_Variable_Value; + + Global_Attribute_Present : Boolean := False; + Local_Attribute_Present : Boolean := False; + + Result : Argument_List (1 .. 3); + Last : Natural := 0; + + function Absolute_Path + (Path : Path_Name_Type; + Project : Project_Id) return String; + -- Returns an absolute path for a configuration pragmas file + + ------------------- + -- Absolute_Path -- + ------------------- + + function Absolute_Path + (Path : Path_Name_Type; + Project : Project_Id) return String + is + begin + Get_Name_String (Path); + + declare + Path_Name : constant String := Name_Buffer (1 .. Name_Len); + + begin + if Is_Absolute_Path (Path_Name) then + return Path_Name; + + else + declare + Parent_Directory : constant String := + Get_Name_String (Project.Directory.Display_Name); + + begin + if Parent_Directory (Parent_Directory'Last) = + Directory_Separator + then + return Parent_Directory & Path_Name; + + else + return Parent_Directory & Directory_Separator & Path_Name; + end if; + end; + end if; + end; + end Absolute_Path; + + -- Start of processing for Configuration_Pragmas_Switch + + begin + Prj.Env.Create_Config_Pragmas_File + (For_Project, Project_Tree); + + if For_Project.Config_File_Name /= No_Path then + Temporary_Config_File := For_Project.Config_File_Temp; + Last := 1; + Result (1) := + new String' + ("-gnatec=" & Get_Name_String (For_Project.Config_File_Name)); + + else + Temporary_Config_File := False; + end if; + + -- Check for attribute Builder'Global_Configuration_Pragmas + + The_Packages := Main_Project.Decl.Packages; + Gnatmake := + Prj.Util.Value_Of + (Name => Name_Builder, + In_Packages => The_Packages, + In_Tree => Project_Tree); + + if Gnatmake /= No_Package then + Global_Attribute := Prj.Util.Value_Of + (Variable_Name => Name_Global_Configuration_Pragmas, + In_Variables => Project_Tree.Packages.Table + (Gnatmake).Decl.Attributes, + In_Tree => Project_Tree); + Global_Attribute_Present := + Global_Attribute /= Nil_Variable_Value + and then Get_Name_String (Global_Attribute.Value) /= ""; + + if Global_Attribute_Present then + declare + Path : constant String := + Absolute_Path + (Path_Name_Type (Global_Attribute.Value), + Global_Attribute.Project); + begin + if not Is_Regular_File (Path) then + if Debug.Debug_Flag_F then + Make_Failed + ("cannot find configuration pragmas file " + & File_Name (Path)); + else + Make_Failed + ("cannot find configuration pragmas file " & Path); + end if; + end if; + + Last := Last + 1; + Result (Last) := new String'("-gnatec=" & Path); + end; + end if; + end if; + + -- Check for attribute Compiler'Local_Configuration_Pragmas + + The_Packages := For_Project.Decl.Packages; + Compiler := + Prj.Util.Value_Of + (Name => Name_Compiler, + In_Packages => The_Packages, + In_Tree => Project_Tree); + + if Compiler /= No_Package then + Local_Attribute := Prj.Util.Value_Of + (Variable_Name => Name_Local_Configuration_Pragmas, + In_Variables => Project_Tree.Packages.Table + (Compiler).Decl.Attributes, + In_Tree => Project_Tree); + Local_Attribute_Present := + Local_Attribute /= Nil_Variable_Value + and then Get_Name_String (Local_Attribute.Value) /= ""; + + if Local_Attribute_Present then + declare + Path : constant String := + Absolute_Path + (Path_Name_Type (Local_Attribute.Value), + Local_Attribute.Project); + begin + if not Is_Regular_File (Path) then + if Debug.Debug_Flag_F then + Make_Failed + ("cannot find configuration pragmas file " + & File_Name (Path)); + + else + Make_Failed + ("cannot find configuration pragmas file " & Path); + end if; + end if; + + Last := Last + 1; + Result (Last) := new String'("-gnatec=" & Path); + end; + end if; + end if; + + return Result (1 .. Last); + end Configuration_Pragmas_Switch; + + --------------- + -- Debug_Msg -- + --------------- + + procedure Debug_Msg (S : String; N : Name_Id) is + begin + if Debug.Debug_Flag_W then + Write_Str (" ... "); + Write_Str (S); + Write_Str (" "); + Write_Name (N); + Write_Eol; + end if; + end Debug_Msg; + + procedure Debug_Msg (S : String; N : File_Name_Type) is + begin + Debug_Msg (S, Name_Id (N)); + end Debug_Msg; + + procedure Debug_Msg (S : String; N : Unit_Name_Type) is + begin + Debug_Msg (S, Name_Id (N)); + end Debug_Msg; + + --------------------------- + -- Delete_All_Temp_Files -- + --------------------------- + + procedure Delete_All_Temp_Files is + begin + if not Debug.Debug_Flag_N then + Delete_Temp_Config_Files; + Prj.Delete_All_Temp_Files (Project_Tree); + end if; + end Delete_All_Temp_Files; + + ------------------------------ + -- Delete_Temp_Config_Files -- + ------------------------------ + + procedure Delete_Temp_Config_Files is + Success : Boolean; + Proj : Project_List; + pragma Warnings (Off, Success); + + begin + -- The caller is responsible for ensuring that Debug_Flag_N is False + + pragma Assert (not Debug.Debug_Flag_N); + + if Main_Project /= No_Project then + Proj := Project_Tree.Projects; + while Proj /= null loop + if Proj.Project.Config_File_Temp then + Delete_Temporary_File + (Project_Tree, Proj.Project.Config_File_Name); + + -- Make sure that we don't have a config file for this project, + -- in case there are several mains. In this case, we will + -- recreate another config file: we cannot reuse the one that + -- we just deleted! + + Proj.Project.Config_Checked := False; + Proj.Project.Config_File_Name := No_Path; + Proj.Project.Config_File_Temp := False; + end if; + Proj := Proj.Next; + end loop; + end if; + end Delete_Temp_Config_Files; + + ------------- + -- Display -- + ------------- + + procedure Display (Program : String; Args : Argument_List) is + begin + pragma Assert (Args'First = 1); + + if Display_Executed_Programs then + Write_Str (Program); + + for J in Args'Range loop + + -- Never display -gnatea nor -gnatez + + if Args (J).all /= "-gnatea" + and then + Args (J).all /= "-gnatez" + then + -- Do not display the mapping file argument automatically + -- created when using a project file. + + if Main_Project = No_Project + or else Debug.Debug_Flag_N + or else Args (J)'Length < 8 + or else + Args (J) (Args (J)'First .. Args (J)'First + 6) /= "-gnatem" + then + -- When -dn is not specified, do not display the config + -- pragmas switch (-gnatec) for the temporary file created + -- by the project manager (always the first -gnatec switch). + -- Reset Temporary_Config_File to False so that the eventual + -- other -gnatec switches will be displayed. + + if (not Debug.Debug_Flag_N) + and then Temporary_Config_File + and then Args (J)'Length > 7 + and then Args (J) (Args (J)'First .. Args (J)'First + 6) + = "-gnatec" + then + Temporary_Config_File := False; + + -- Do not display the -F=mapping_file switch for gnatbind + -- if -dn is not specified. + + elsif Debug.Debug_Flag_N + or else Args (J)'Length < 4 + or else + Args (J) (Args (J)'First .. Args (J)'First + 2) /= "-F=" + then + Write_Str (" "); + + -- If -df is used, only display file names, not path + -- names. + + if Debug.Debug_Flag_F then + declare + Equal_Pos : Natural; + begin + Equal_Pos := Args (J)'First - 1; + for K in Args (J)'Range loop + if Args (J) (K) = '=' then + Equal_Pos := K; + exit; + end if; + end loop; + + if Is_Absolute_Path + (Args (J) (Equal_Pos + 1 .. Args (J)'Last)) + then + Write_Str + (Args (J) (Args (J)'First .. Equal_Pos)); + Write_Str + (File_Name + (Args (J) + (Equal_Pos + 1 .. Args (J)'Last))); + + else + Write_Str (Args (J).all); + end if; + end; + + else + Write_Str (Args (J).all); + end if; + end if; + end if; + end if; + end loop; + + Write_Eol; + end if; + end Display; + + ---------------------- + -- Display_Commands -- + ---------------------- + + procedure Display_Commands (Display : Boolean := True) is + begin + Display_Executed_Programs := Display; + end Display_Commands; + + -------------------------- + -- Enter_Into_Obsoleted -- + -------------------------- + + procedure Enter_Into_Obsoleted (F : File_Name_Type) is + Name : constant String := Get_Name_String (F); + First : Natural; + F2 : File_Name_Type; + + begin + First := Name'Last; + while First > Name'First + and then Name (First - 1) /= Directory_Separator + and then Name (First - 1) /= '/' + loop + First := First - 1; + end loop; + + if First /= Name'First then + Name_Len := 0; + Add_Str_To_Name_Buffer (Name (First .. Name'Last)); + F2 := Name_Find; + + else + F2 := F; + end if; + + Debug_Msg ("New entry in Obsoleted table:", F2); + Obsoleted.Set (F2, True); + end Enter_Into_Obsoleted; + + --------------- + -- Globalize -- + --------------- + + procedure Globalize (Success : out Boolean) is + Quiet_Str : aliased String := "-quiet"; + Globalizer_Args : constant Argument_List := + (1 => Quiet_Str'Unchecked_Access); + Previous_Dir : String_Access; + + procedure Globalize_Dir (Dir : String); + -- Call CodePeer globalizer on Dir + + ------------------- + -- Globalize_Dir -- + ------------------- + + procedure Globalize_Dir (Dir : String) is + Result : Boolean; + begin + if Previous_Dir = null or else Dir /= Previous_Dir.all then + Free (Previous_Dir); + Previous_Dir := new String'(Dir); + Change_Dir (Dir); + GNAT.OS_Lib.Spawn (Globalizer_Path.all, Globalizer_Args, Result); + Success := Success and Result; + end if; + end Globalize_Dir; + + procedure Globalize_Dirs is new + Prj.Env.For_All_Object_Dirs (Globalize_Dir); + + begin + Success := True; + Display (Globalizer, Globalizer_Args); + + if Globalizer_Path = null then + Make_Failed ("error, unable to locate " & Globalizer); + end if; + + if Main_Project = No_Project then + GNAT.OS_Lib.Spawn (Globalizer_Path.all, Globalizer_Args, Success); + else + Globalize_Dirs (Main_Project); + end if; + end Globalize; + + -------------- + -- Gnatmake -- + -------------- + + procedure Gnatmake is + Main_Source_File : File_Name_Type; + -- The source file containing the main compilation unit + + Compilation_Failures : Natural; + + Total_Compilation_Failures : Natural := 0; + + Is_Main_Unit : Boolean; + -- Set True by Compile_Sources if Main_Source_File can be a main unit + + Main_ALI_File : File_Name_Type; + -- The ali file corresponding to Main_Source_File + + Executable : File_Name_Type := No_File; + -- The file name of an executable + + Non_Std_Executable : Boolean := False; + -- Non_Std_Executable is set to True when there is a possibility that + -- the linker will not choose the correct executable file name. + + Current_Work_Dir : constant String_Access := + new String'(Get_Current_Dir); + -- The current working directory, used to modify some relative path + -- switches on the command line when a project file is used. + + Current_Main_Index : Int := 0; + -- If not zero, the index of the current main unit in its source file + + Stand_Alone_Libraries : Boolean := False; + -- Set to True when there are Stand-Alone Libraries, so that gnatbind + -- is invoked with the -F switch to force checking of elaboration flags. + + Mapping_Path : Path_Name_Type := No_Path; + -- The path name of the mapping file + + Project_Node_Tree : Project_Node_Tree_Ref; + + Discard : Boolean; + pragma Warnings (Off, Discard); + + procedure Check_Mains; + -- Check that the main subprograms do exist and that they all + -- belong to the same project file. + + ----------------- + -- Check_Mains -- + ----------------- + + procedure Check_Mains is + Real_Main_Project : Project_Id := No_Project; + -- The project of the first main + + Proj : Project_Id := No_Project; + -- The project of the current main + + Real_Path : String_Access; + + begin + Mains.Reset; + + -- Check each main + + loop + declare + Main : constant String := Mains.Next_Main; + -- The name specified on the command line may include directory + -- information. + + File_Name : constant String := Base_Name (Main); + -- The simple file name of the current main + + Lang : Language_Ptr; + + begin + exit when Main = ""; + + -- Get the project of the current main + + Proj := Prj.Env.Project_Of + (File_Name, Main_Project, Project_Tree); + + -- Fail if the current main is not a source of a project + + if Proj = No_Project then + Make_Failed + ("""" & Main & """ is not a source of any project"); + + else + -- If there is directory information, check that the source + -- exists and, if it does, that the path is the actual path + -- of a source of a project. + + if Main /= File_Name then + Lang := Get_Language_From_Name (Main_Project, "ada"); + + Real_Path := + Locate_Regular_File + (Main & Get_Name_String + (Lang.Config.Naming_Data.Body_Suffix), + ""); + if Real_Path = null then + Real_Path := + Locate_Regular_File + (Main & Get_Name_String + (Lang.Config.Naming_Data.Spec_Suffix), + ""); + end if; + + if Real_Path = null then + Real_Path := Locate_Regular_File (Main, ""); + end if; + + -- Fail if the file cannot be found + + if Real_Path = null then + Make_Failed ("file """ & Main & """ does not exist"); + end if; + + declare + Project_Path : constant String := + Prj.Env.File_Name_Of_Library_Unit_Body + (Name => File_Name, + Project => Main_Project, + In_Tree => Project_Tree, + Main_Project_Only => False, + Full_Path => True); + Normed_Path : constant String := + Normalize_Pathname + (Real_Path.all, + Case_Sensitive => False); + Proj_Path : constant String := + Normalize_Pathname + (Project_Path, + Case_Sensitive => False); + + begin + Free (Real_Path); + + -- Fail if it is not the correct path + + if Normed_Path /= Proj_Path then + if Verbose_Mode then + Set_Standard_Error; + Write_Str (Normed_Path); + Write_Str (" /= "); + Write_Line (Proj_Path); + end if; + + Make_Failed + ("""" & Main & + """ is not a source of any project"); + end if; + end; + end if; + + if not Unique_Compile then + + -- Record the project, if it is the first main + + if Real_Main_Project = No_Project then + Real_Main_Project := Proj; + + elsif Proj /= Real_Main_Project then + + -- Fail, as the current main is not a source of the + -- same project as the first main. + + Make_Failed + ("""" & Main & + """ is not a source of project " & + Get_Name_String (Real_Main_Project.Name)); + end if; + end if; + end if; + + -- If -u and -U are not used, we may have mains that are + -- sources of a project that is not the one specified with + -- switch -P. + + if not Unique_Compile then + Main_Project := Real_Main_Project; + end if; + end; + end loop; + end Check_Mains; + + -- Start of processing for Gnatmake + + -- This body is very long, should be broken down??? + + begin + Install_Int_Handler (Sigint_Intercepted'Access); + + Do_Compile_Step := True; + Do_Bind_Step := True; + Do_Link_Step := True; + + Obsoleted.Reset; + + Make.Initialize (Project_Node_Tree); + + Bind_Shared := No_Shared_Switch'Access; + Link_With_Shared_Libgcc := No_Shared_Libgcc_Switch'Access; + + Failed_Links.Set_Last (0); + Successful_Links.Set_Last (0); + + -- Special case when switch -B was specified + + if Build_Bind_And_Link_Full_Project then + + -- When switch -B is specified, there must be a project file + + if Main_Project = No_Project then + Make_Failed ("-B cannot be used without a project file"); + + -- No main program may be specified on the command line + + elsif Osint.Number_Of_Files /= 0 then + Make_Failed ("-B cannot be used with a main specified on " & + "the command line"); + + -- And the project file cannot be a library project file + + elsif Main_Project.Library then + Make_Failed ("-B cannot be used for a library project file"); + + else + No_Main_Subprogram := True; + Insert_Project_Sources + (The_Project => Main_Project, + All_Projects => Unique_Compile_All_Projects, + Into_Q => False); + + -- If there are no sources to compile, we fail + + if Osint.Number_Of_Files = 0 then + Make_Failed ("no sources to compile"); + end if; + + -- Specify -n for gnatbind and add the ALI files of all the + -- sources, except the one which is a fake main subprogram: this + -- is the one for the binder generated file and it will be + -- transmitted to gnatlink. These sources are those that are in + -- the queue. + + Add_Switch ("-n", Binder, And_Save => True); + + for J in 1 .. Queue.Size loop + Add_Switch + (Get_Name_String + (Lib_File_Name (Queue.Element (J))), + Binder, And_Save => True); + end loop; + end if; + + elsif Main_Index /= 0 and then Osint.Number_Of_Files > 1 then + Make_Failed ("cannot specify several mains with a multi-unit index"); + + elsif Main_Project /= No_Project then + + -- If the main project file is a library project file, main(s) cannot + -- be specified on the command line. + + if Osint.Number_Of_Files /= 0 then + if Main_Project.Library + and then not Unique_Compile + and then ((not Make_Steps) or else Bind_Only or else Link_Only) + then + Make_Failed ("cannot specify a main program " & + "on the command line for a library project file"); + + else + -- Check that each main on the command line is a source of a + -- project file and, if there are several mains, each of them + -- is a source of the same project file. + + Check_Mains; + end if; + + -- If no mains have been specified on the command line, and we are + -- using a project file, we either find the main(s) in attribute Main + -- of the main project, or we put all the sources of the project file + -- as mains. + + else + if Main_Index /= 0 then + Make_Failed ("cannot specify a multi-unit index but no main " & + "on the command line"); + end if; + + declare + Value : String_List_Id := Main_Project.Mains; + + begin + -- The attribute Main is an empty list or not specified, or + -- else gnatmake was invoked with the switch "-u". + + if Value = Prj.Nil_String or else Unique_Compile then + + if (not Make_Steps) or else Compile_Only + or else not Main_Project.Library + then + -- First make sure that the binder and the linker will + -- not be invoked. + + Do_Bind_Step := False; + Do_Link_Step := False; + + -- Put all the sources in the queue + + No_Main_Subprogram := True; + Insert_Project_Sources + (The_Project => Main_Project, + All_Projects => Unique_Compile_All_Projects, + Into_Q => False); + + -- If no sources to compile, then there is nothing to do + + if Osint.Number_Of_Files = 0 then + if not Quiet_Output then + Osint.Write_Program_Name; + Write_Line (": no sources to compile"); + end if; + + Delete_All_Temp_Files; + Exit_Program (E_Success); + end if; + end if; + + else + -- The attribute Main is not an empty list. Put all the main + -- subprograms in the list as if they were specified on the + -- command line. However, if attribute Languages includes a + -- language other than Ada, only include the Ada mains; if + -- there is no Ada main, compile all sources of the project. + + declare + Languages : constant Variable_Value := + Prj.Util.Value_Of + (Name_Languages, + Main_Project.Decl.Attributes, + Project_Tree); + + Current : String_List_Id; + Element : String_Element; + + Foreign_Language : Boolean := False; + At_Least_One_Main : Boolean := False; + + begin + -- First, determine if there is a foreign language in + -- attribute Languages. + + if not Languages.Default then + Current := Languages.Values; + Look_For_Foreign : + while Current /= Nil_String loop + Element := Project_Tree.String_Elements. + Table (Current); + Get_Name_String (Element.Value); + To_Lower (Name_Buffer (1 .. Name_Len)); + + if Name_Buffer (1 .. Name_Len) /= "ada" then + Foreign_Language := True; + exit Look_For_Foreign; + end if; + + Current := Element.Next; + end loop Look_For_Foreign; + end if; + + -- Then, find all mains, or if there is a foreign + -- language, all the Ada mains. + + while Value /= Prj.Nil_String loop + -- To know if a main is an Ada main, get its project. + -- It should be the project specified on the command + -- line. + + Get_Name_String + (Project_Tree.String_Elements.Table (Value).Value); + + declare + Main_Name : constant String := + Get_Name_String + (Project_Tree.String_Elements.Table + (Value).Value); + Proj : constant Project_Id := + Prj.Env.Project_Of + (Main_Name, Main_Project, Project_Tree); + begin + + if Proj = Main_Project then + + At_Least_One_Main := True; + Osint.Add_File + (Get_Name_String + (Project_Tree.String_Elements.Table + (Value).Value), + Index => + Project_Tree.String_Elements.Table + (Value).Index); + + elsif not Foreign_Language then + Make_Failed + ("""" & Main_Name & + """ is not a source of project " & + Get_Name_String (Main_Project.Display_Name)); + end if; + end; + + Value := Project_Tree.String_Elements.Table + (Value).Next; + end loop; + + -- If we did not get any main, it means that all mains + -- in attribute Mains are in a foreign language and -B + -- was not specified to gnatmake; so, we fail. + + if not At_Least_One_Main then + Make_Failed + ("no Ada mains, use -B to build foreign main"); + end if; + end; + + end if; + end; + end if; + end if; + + if Verbose_Mode then + Write_Eol; + Display_Version ("GNATMAKE", "1995"); + end if; + + if Osint.Number_Of_Files = 0 then + if Main_Project /= No_Project + and then Main_Project.Library + then + if Do_Bind_Step + and then not Main_Project.Standalone_Library + then + Make_Failed ("only stand-alone libraries may be bound"); + end if; + + -- Add the default search directories to be able to find libgnat + + Osint.Add_Default_Search_Dirs; + + -- Get the target parameters, so that the correct binder generated + -- files are generated if OpenVMS is the target. + + begin + Targparm.Get_Target_Parameters; + + exception + when Unrecoverable_Error => + Make_Failed ("*** make failed."); + end; + + -- And bind and or link the library + + MLib.Prj.Build_Library + (For_Project => Main_Project, + In_Tree => Project_Tree, + Gnatbind => Gnatbind.all, + Gnatbind_Path => Gnatbind_Path, + Gcc => Gcc.all, + Gcc_Path => Gcc_Path, + Bind => Bind_Only, + Link => Link_Only); + + Delete_All_Temp_Files; + Exit_Program (E_Success); + + else + -- Call Get_Target_Parameters to ensure that VM_Target and + -- AAMP_On_Target get set before calling Usage. + + Targparm.Get_Target_Parameters; + + -- Output usage information if no files to compile + + Usage; + Exit_Program (E_Fatal); + end if; + end if; + + -- If -M was specified, behave as if -n was specified + + if List_Dependencies then + Do_Not_Execute := True; + end if; + + -- Note that Osint.M.Next_Main_Source will always return the (possibly + -- abbreviated file) without any directory information. + + Main_Source_File := Next_Main_Source; + + if Current_File_Index /= No_Index then + Main_Index := Current_File_Index; + end if; + + Add_Switch ("-I-", Compiler, And_Save => True); + + if Main_Project = No_Project then + if Look_In_Primary_Dir then + + Add_Switch + ("-I" & + Normalize_Directory_Name + (Get_Primary_Src_Search_Directory.all).all, + Compiler, Append_Switch => False, + And_Save => False); + + end if; + + else + -- If we use a project file, we have already checked that a main + -- specified on the command line with directory information has the + -- path name corresponding to a correct source in the project tree. + -- So, we don't need the directory information to be taken into + -- account by Find_File, and in fact it may lead to take the wrong + -- sources for other compilation units, when there are extending + -- projects. + + Look_In_Primary_Dir := False; + Add_Switch ("-I-", Binder, And_Save => True); + end if; + + -- If the user wants a program without a main subprogram, add the + -- appropriate switch to the binder. + + if No_Main_Subprogram then + Add_Switch ("-z", Binder, And_Save => True); + end if; + + if Main_Project /= No_Project then + + if Main_Project.Object_Directory /= No_Path_Information then + -- Change current directory to object directory of main project + + Project_Of_Current_Object_Directory := No_Project; + Change_To_Object_Directory (Main_Project); + end if; + + -- Source file lookups should be cached for efficiency. + -- Source files are not supposed to change. + + Osint.Source_File_Data (Cache => True); + + -- Find the file name of the (first) main unit + + declare + Main_Source_File_Name : constant String := + Get_Name_String (Main_Source_File); + Main_Unit_File_Name : constant String := + Prj.Env.File_Name_Of_Library_Unit_Body + (Name => Main_Source_File_Name, + Project => Main_Project, + In_Tree => Project_Tree, + Main_Project_Only => + not Unique_Compile); + + The_Packages : constant Package_Id := + Main_Project.Decl.Packages; + + Builder_Package : constant Prj.Package_Id := + Prj.Util.Value_Of + (Name => Name_Builder, + In_Packages => The_Packages, + In_Tree => Project_Tree); + + Binder_Package : constant Prj.Package_Id := + Prj.Util.Value_Of + (Name => Name_Binder, + In_Packages => The_Packages, + In_Tree => Project_Tree); + + Linker_Package : constant Prj.Package_Id := + Prj.Util.Value_Of + (Name => Name_Linker, + In_Packages => The_Packages, + In_Tree => Project_Tree); + + Default_Switches_Array : Array_Id; + + Global_Compilation_Array : Array_Element_Id; + Global_Compilation_Elem : Array_Element; + Global_Compilation_Switches : Variable_Value; + + begin + -- We fail if we cannot find the main source file + + if Main_Unit_File_Name = "" then + Make_Failed ('"' & Main_Source_File_Name + & """ is not a unit of project " + & Project_File_Name.all & "."); + else + -- Remove any directory information from the main source file + -- file name. + + declare + Pos : Natural := Main_Unit_File_Name'Last; + + begin + loop + exit when Pos < Main_Unit_File_Name'First or else + Main_Unit_File_Name (Pos) = Directory_Separator; + Pos := Pos - 1; + end loop; + + Name_Len := Main_Unit_File_Name'Last - Pos; + + Name_Buffer (1 .. Name_Len) := + Main_Unit_File_Name + (Pos + 1 .. Main_Unit_File_Name'Last); + + Main_Source_File := Name_Find; + + -- We only output the main source file if there is only one + + if Verbose_Mode and then Osint.Number_Of_Files = 1 then + Write_Str ("Main source file: """); + Write_Str (Main_Unit_File_Name + (Pos + 1 .. Main_Unit_File_Name'Last)); + Write_Line ("""."); + end if; + end; + end if; + + -- If there is a package Builder in the main project file, add + -- the switches from it. + + if Builder_Package /= No_Package then + + Global_Compilation_Array := Prj.Util.Value_Of + (Name => Name_Global_Compilation_Switches, + In_Arrays => Project_Tree.Packages.Table + (Builder_Package).Decl.Arrays, + In_Tree => Project_Tree); + + Default_Switches_Array := + Project_Tree.Packages.Table + (Builder_Package).Decl.Arrays; + + while Default_Switches_Array /= No_Array and then + Project_Tree.Arrays.Table (Default_Switches_Array).Name /= + Name_Default_Switches + loop + Default_Switches_Array := + Project_Tree.Arrays.Table (Default_Switches_Array).Next; + end loop; + + if Global_Compilation_Array /= No_Array_Element and then + Default_Switches_Array /= No_Array + then + Errutil.Error_Msg + ("Default_Switches forbidden in presence of " & + "Global_Compilation_Switches. Use Switches instead.", + Project_Tree.Arrays.Table + (Default_Switches_Array).Location); + Errutil.Finalize; + Make_Failed + ("*** illegal combination of Builder attributes"); + end if; + + -- If there is only one main, we attempt to get the gnatmake + -- switches for this main (if any). If there are no specific + -- switch for this particular main, get the general gnatmake + -- switches (if any). + + if Osint.Number_Of_Files = 1 then + if Verbose_Mode then + Write_Str ("Adding gnatmake switches for """); + Write_Str (Main_Unit_File_Name); + Write_Line ("""."); + end if; + + Add_Switches + (Project_Node_Tree => Project_Node_Tree, + File_Name => Main_Unit_File_Name, + Index => Main_Index, + The_Package => Builder_Package, + Program => None, + Unknown_Switches_To_The_Compiler => + Global_Compilation_Array = No_Array_Element); + + else + -- If there are several mains, we always get the general + -- gnatmake switches (if any). + + -- Warn the user, if necessary, so that he is not surprised + -- that specific switches are not taken into account. + + declare + Defaults : constant Variable_Value := + Prj.Util.Value_Of + (Name => Name_Ada, + Index => 0, + Attribute_Or_Array_Name => + Name_Default_Switches, + In_Package => + Builder_Package, + In_Tree => Project_Tree); + + Switches : constant Array_Element_Id := + Prj.Util.Value_Of + (Name => Name_Switches, + In_Arrays => + Project_Tree.Packages.Table + (Builder_Package).Decl.Arrays, + In_Tree => Project_Tree); + + Other_Switches : constant Variable_Value := + Prj.Util.Value_Of + (Name => All_Other_Names, + Index => 0, + Attribute_Or_Array_Name + => Name_Switches, + In_Package => Builder_Package, + In_Tree => Project_Tree); + + begin + if Other_Switches /= Nil_Variable_Value then + if not Quiet_Output + and then Switches /= No_Array_Element + and then Project_Tree.Array_Elements.Table + (Switches).Next /= No_Array_Element + then + Write_Line + ("Warning: using Builder'Switches(others), " + & "as there are several mains"); + end if; + + Add_Switches + (Project_Node_Tree => Project_Node_Tree, + File_Name => " ", + Index => 0, + The_Package => Builder_Package, + Program => None, + Unknown_Switches_To_The_Compiler => False); + + elsif Defaults /= Nil_Variable_Value then + if not Quiet_Output + and then Switches /= No_Array_Element + then + Write_Line + ("Warning: using Builder'Default_Switches" + & "(""Ada""), as there are several mains"); + end if; + + Add_Switches + (Project_Node_Tree => Project_Node_Tree, + File_Name => " ", + Index => 0, + The_Package => Builder_Package, + Program => None); + + elsif not Quiet_Output + and then Switches /= No_Array_Element + then + Write_Line + ("Warning: using no switches from package " + & "Builder, as there are several mains"); + end if; + end; + end if; + + -- Take into account attribute Global_Compilation_Switches + -- ("Ada"). + + declare + Index : Name_Id; + List : String_List_Id; + Elem : String_Element; + + begin + while Global_Compilation_Array /= No_Array_Element loop + Global_Compilation_Elem := + Project_Tree.Array_Elements.Table + (Global_Compilation_Array); + + Get_Name_String (Global_Compilation_Elem.Index); + To_Lower (Name_Buffer (1 .. Name_Len)); + Index := Name_Find; + + if Index = Name_Ada then + Global_Compilation_Switches := + Global_Compilation_Elem.Value; + + if Global_Compilation_Switches /= Nil_Variable_Value + and then not Global_Compilation_Switches.Default + then + -- We have found attribute + -- Global_Compilation_Switches ("Ada"): put the + -- switches in the appropriate table. + + List := Global_Compilation_Switches.Values; + + while List /= Nil_String loop + Elem := + Project_Tree.String_Elements.Table (List); + + if Elem.Value /= No_Name then + Add_Switch + (Get_Name_String (Elem.Value), + Compiler, + And_Save => False); + end if; + + List := Elem.Next; + end loop; + + exit; + end if; + end if; + + Global_Compilation_Array := Global_Compilation_Elem.Next; + end loop; + end; + end if; + + Osint.Add_Default_Search_Dirs; + + -- Record the current last switch index for table Binder_Switches + -- and Linker_Switches, so that these tables may be reset before + -- for each main, before adding switches from the project file + -- and from the command line. + + Last_Binder_Switch := Binder_Switches.Last; + Last_Linker_Switch := Linker_Switches.Last; + + Check_Steps; + + -- Add binder switches from the project file for the first main + + if Do_Bind_Step and then Binder_Package /= No_Package then + if Verbose_Mode then + Write_Str ("Adding binder switches for """); + Write_Str (Main_Unit_File_Name); + Write_Line ("""."); + end if; + + Add_Switches + (Project_Node_Tree => Project_Node_Tree, + File_Name => Main_Unit_File_Name, + Index => Main_Index, + The_Package => Binder_Package, + Program => Binder); + end if; + + -- Add linker switches from the project file for the first main + + if Do_Link_Step and then Linker_Package /= No_Package then + if Verbose_Mode then + Write_Str ("Adding linker switches for"""); + Write_Str (Main_Unit_File_Name); + Write_Line ("""."); + end if; + + Add_Switches + (Project_Node_Tree => Project_Node_Tree, + File_Name => Main_Unit_File_Name, + Index => Main_Index, + The_Package => Linker_Package, + Program => Linker); + end if; + end; + end if; + + -- The combination of -f -u and one or several mains on the command line + -- implies -a. + + if Force_Compilations + and then Unique_Compile + and then not Unique_Compile_All_Projects + and then Main_On_Command_Line + then + Must_Compile := True; + end if; + + if Main_Project /= No_Project + and then not Must_Compile + and then Main_Project.Externally_Built + then + Make_Failed + ("nothing to do for a main project that is externally built"); + end if; + + -- Get the target parameters, which are only needed for a couple of + -- cases in gnatmake. Protect against an exception, such as the case of + -- system.ads missing from the library, and fail gracefully. + + begin + Targparm.Get_Target_Parameters; + exception + when Unrecoverable_Error => + Make_Failed ("*** make failed."); + end; + + -- Special processing for VM targets + + if Targparm.VM_Target /= No_VM then + + -- Set proper processing commands + + case Targparm.VM_Target is + when Targparm.JVM_Target => + + -- Do not check for an object file (".o") when compiling to + -- JVM machine since ".class" files are generated instead. + + Check_Object_Consistency := False; + Gcc := new String'("jvm-gnatcompile"); + + when Targparm.CLI_Target => + Gcc := new String'("dotnet-gnatcompile"); + + when Targparm.No_VM => + raise Program_Error; + end case; + end if; + + Display_Commands (not Quiet_Output); + + Check_Steps; + + if Main_Project /= No_Project then + + -- For all library project, if the library file does not exist, put + -- all the project sources in the queue, and flag the project so that + -- the library is generated. + + if not Unique_Compile + and then MLib.Tgt.Support_For_Libraries /= Prj.None + then + declare + Proj : Project_List; + + begin + Proj := Project_Tree.Projects; + while Proj /= null loop + if Proj.Project.Library then + Proj.Project.Need_To_Build_Lib := + not MLib.Tgt.Library_Exists_For + (Proj.Project, Project_Tree) + and then not Proj.Project.Externally_Built; + + if Proj.Project.Need_To_Build_Lib then + + -- If there is no object directory, then it will be + -- impossible to build the library. So fail + -- immediately. + + if + Proj.Project.Object_Directory = No_Path_Information + then + Make_Failed + ("no object files to build library for project """ + & Get_Name_String (Proj.Project.Name) + & """"); + Proj.Project.Need_To_Build_Lib := False; + + else + if Verbose_Mode then + Write_Str + ("Library file does not exist for project """); + Write_Str (Get_Name_String (Proj.Project.Name)); + Write_Line (""""); + end if; + + Insert_Project_Sources + (The_Project => Proj.Project, + All_Projects => False, + Into_Q => True); + end if; + end if; + end if; + + Proj := Proj.Next; + end loop; + end; + end if; + + -- If a relative path output file has been specified, we add the + -- exec directory. + + for J in reverse 1 .. Saved_Linker_Switches.Last - 1 loop + if Saved_Linker_Switches.Table (J).all = Output_Flag.all then + declare + Exec_File_Name : constant String := + Saved_Linker_Switches.Table (J + 1).all; + + begin + if not Is_Absolute_Path (Exec_File_Name) then + Get_Name_String + (Main_Project.Exec_Directory.Display_Name); + + if not + Is_Directory_Separator (Name_Buffer (Name_Len)) + then + Add_Char_To_Name_Buffer (Directory_Separator); + end if; + + Add_Str_To_Name_Buffer (Exec_File_Name); + Saved_Linker_Switches.Table (J + 1) := + new String'(Name_Buffer (1 .. Name_Len)); + end if; + end; + + exit; + end if; + end loop; + + -- If we are using a project file, for relative paths we add the + -- current working directory for any relative path on the command + -- line and the project directory, for any relative path in the + -- project file. + + declare + Dir_Path : constant String := + Get_Name_String (Main_Project.Directory.Display_Name); + begin + for J in 1 .. Binder_Switches.Last loop + Test_If_Relative_Path + (Binder_Switches.Table (J), + Parent => Dir_Path, Including_L_Switch => False); + end loop; + + for J in 1 .. Saved_Binder_Switches.Last loop + Test_If_Relative_Path + (Saved_Binder_Switches.Table (J), + Parent => Current_Work_Dir.all, Including_L_Switch => False); + end loop; + + for J in 1 .. Linker_Switches.Last loop + Test_If_Relative_Path + (Linker_Switches.Table (J), Parent => Dir_Path); + end loop; + + for J in 1 .. Saved_Linker_Switches.Last loop + Test_If_Relative_Path + (Saved_Linker_Switches.Table (J), + Parent => Current_Work_Dir.all); + end loop; + + for J in 1 .. Gcc_Switches.Last loop + Test_If_Relative_Path + (Gcc_Switches.Table (J), + Parent => Dir_Path, + Including_Non_Switch => False); + end loop; + + for J in 1 .. Saved_Gcc_Switches.Last loop + Test_If_Relative_Path + (Saved_Gcc_Switches.Table (J), + Parent => Current_Work_Dir.all, + Including_Non_Switch => False); + end loop; + end; + end if; + + -- We now put in the Binder_Switches and Linker_Switches tables, the + -- binder and linker switches of the command line that have been put in + -- the Saved_ tables. If a project file was used, then the command line + -- switches will follow the project file switches. + + for J in 1 .. Saved_Binder_Switches.Last loop + Add_Switch + (Saved_Binder_Switches.Table (J), + Binder, + And_Save => False); + end loop; + + for J in 1 .. Saved_Linker_Switches.Last loop + Add_Switch + (Saved_Linker_Switches.Table (J), + Linker, + And_Save => False); + end loop; + + -- If no project file is used, we just put the gcc switches + -- from the command line in the Gcc_Switches table. + + if Main_Project = No_Project then + for J in 1 .. Saved_Gcc_Switches.Last loop + Add_Switch + (Saved_Gcc_Switches.Table (J), Compiler, And_Save => False); + end loop; + + else + -- If there is a project, put the command line gcc switches in the + -- variable The_Saved_Gcc_Switches. They are going to be used later + -- in procedure Compile_Sources. + + The_Saved_Gcc_Switches := + new Argument_List (1 .. Saved_Gcc_Switches.Last + 1); + + for J in 1 .. Saved_Gcc_Switches.Last loop + The_Saved_Gcc_Switches (J) := Saved_Gcc_Switches.Table (J); + end loop; + + -- We never use gnat.adc when a project file is used + + The_Saved_Gcc_Switches (The_Saved_Gcc_Switches'Last) := No_gnat_adc; + end if; + + -- If there was a --GCC, --GNATBIND or --GNATLINK switch on the command + -- line, then we have to use it, even if there was another switch in + -- the project file. + + if Saved_Gcc /= null then + Gcc := Saved_Gcc; + end if; + + if Saved_Gnatbind /= null then + Gnatbind := Saved_Gnatbind; + end if; + + if Saved_Gnatlink /= null then + Gnatlink := Saved_Gnatlink; + end if; + + Gcc_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gcc.all); + Gnatbind_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatbind.all); + Gnatlink_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatlink.all); + + -- If we have specified -j switch both from the project file + -- and on the command line, the one from the command line takes + -- precedence. + + if Saved_Maximum_Processes = 0 then + Saved_Maximum_Processes := Maximum_Processes; + end if; + + if Debug.Debug_Flag_M then + Write_Line ("Maximum number of simultaneous compilations =" & + Saved_Maximum_Processes'Img); + end if; + + -- Allocate as many temporary mapping file names as the maximum number + -- of compilations processed, for each possible project. + + declare + Data : Project_Compilation_Access; + Proj : Project_List := Project_Tree.Projects; + begin + while Proj /= null loop + Data := new Project_Compilation_Data' + (Mapping_File_Names => new Temp_Path_Names + (1 .. Saved_Maximum_Processes), + Last_Mapping_File_Names => 0, + Free_Mapping_File_Indexes => new Free_File_Indexes + (1 .. Saved_Maximum_Processes), + Last_Free_Indexes => 0); + + Project_Compilation_Htable.Set + (Project_Compilation, Proj.Project, Data); + Proj := Proj.Next; + end loop; + + Data := new Project_Compilation_Data' + (Mapping_File_Names => new Temp_Path_Names + (1 .. Saved_Maximum_Processes), + Last_Mapping_File_Names => 0, + Free_Mapping_File_Indexes => new Free_File_Indexes + (1 .. Saved_Maximum_Processes), + Last_Free_Indexes => 0); + + Project_Compilation_Htable.Set + (Project_Compilation, No_Project, Data); + end; + + Bad_Compilation.Init; + + -- If project files are used, create the mapping of all the sources, so + -- that the correct paths will be found. Otherwise, if there is a file + -- which is not a source with the same name in a source directory this + -- file may be incorrectly found. + + if Main_Project /= No_Project then + Prj.Env.Create_Mapping (Project_Tree); + end if; + + Current_Main_Index := Main_Index; + + -- Here is where the make process is started + + -- We do the same process for each main + + Multiple_Main_Loop : for N_File in 1 .. Osint.Number_Of_Files loop + + -- First, find the executable name and path + + Executable := No_File; + Executable_Obsolete := False; + Non_Std_Executable := + Targparm.Executable_Extension_On_Target /= No_Name; + + -- Look inside the linker switches to see if the name of the final + -- executable program was specified. + + for J in reverse Linker_Switches.First .. Linker_Switches.Last loop + if Linker_Switches.Table (J).all = Output_Flag.all then + pragma Assert (J < Linker_Switches.Last); + + -- We cannot specify a single executable for several main + -- subprograms + + if Osint.Number_Of_Files > 1 then + Fail + ("cannot specify a single executable for several mains"); + end if; + + Name_Len := 0; + Add_Str_To_Name_Buffer (Linker_Switches.Table (J + 1).all); + Executable := Name_Enter; + + Verbose_Msg (Executable, "final executable"); + end if; + end loop; + + -- If the name of the final executable program was not specified then + -- construct it from the main input file. + + if Executable = No_File then + if Main_Project = No_Project then + Executable := Executable_Name (Strip_Suffix (Main_Source_File)); + + else + -- If we are using a project file, we attempt to remove the + -- body (or spec) termination of the main subprogram. We find + -- it the naming scheme of the project file. This avoids + -- generating an executable "main.2" for a main subprogram + -- "main.2.ada", when the body termination is ".2.ada". + + Executable := + Prj.Util.Executable_Of + (Main_Project, Project_Tree, Main_Source_File, Main_Index); + end if; + end if; + + if Main_Project /= No_Project + and then Main_Project.Exec_Directory /= No_Path_Information + then + declare + Exec_File_Name : constant String := + Get_Name_String (Executable); + + begin + if not Is_Absolute_Path (Exec_File_Name) then + Get_Name_String (Main_Project.Exec_Directory.Display_Name); + + if Name_Buffer (Name_Len) /= Directory_Separator then + Add_Char_To_Name_Buffer (Directory_Separator); + end if; + + Add_Str_To_Name_Buffer (Exec_File_Name); + Executable := Name_Find; + end if; + + Non_Std_Executable := True; + end; + end if; + + if Do_Compile_Step then + Recursive_Compilation_Step : declare + Args : Argument_List (1 .. Gcc_Switches.Last); + + First_Compiled_File : File_Name_Type; + Youngest_Obj_File : File_Name_Type; + Youngest_Obj_Stamp : Time_Stamp_Type; + + Executable_Stamp : Time_Stamp_Type; + -- Executable is the final executable program + -- ??? comment seems unrelated to declaration + + Library_Rebuilt : Boolean := False; + + begin + for J in 1 .. Gcc_Switches.Last loop + Args (J) := Gcc_Switches.Table (J); + end loop; + + Queue.Initialize + (Main_Project /= No_Project and then + One_Compilation_Per_Obj_Dir); + + -- Now we invoke Compile_Sources for the current main + + Compile_Sources + (Main_Source => Main_Source_File, + Args => Args, + First_Compiled_File => First_Compiled_File, + Most_Recent_Obj_File => Youngest_Obj_File, + Most_Recent_Obj_Stamp => Youngest_Obj_Stamp, + Main_Unit => Is_Main_Unit, + Main_Index => Current_Main_Index, + Compilation_Failures => Compilation_Failures, + Check_Readonly_Files => Check_Readonly_Files, + Do_Not_Execute => Do_Not_Execute, + Force_Compilations => Force_Compilations, + In_Place_Mode => In_Place_Mode, + Keep_Going => Keep_Going, + Initialize_ALI_Data => True, + Max_Process => Saved_Maximum_Processes); + + if Verbose_Mode then + Write_Str ("End of compilation"); + Write_Eol; + end if; + + Total_Compilation_Failures := + Total_Compilation_Failures + Compilation_Failures; + + if Total_Compilation_Failures /= 0 then + if Keep_Going then + goto Next_Main; + + else + List_Bad_Compilations; + Report_Compilation_Failed; + end if; + end if; + + -- Regenerate libraries, if there are any and if object files + -- have been regenerated. + + if Main_Project /= No_Project + and then MLib.Tgt.Support_For_Libraries /= Prj.None + and then (Do_Bind_Step + or Unique_Compile_All_Projects + or not Compile_Only) + and then (Do_Link_Step or else N_File = Osint.Number_Of_Files) + then + Library_Projs.Init; + + declare + Depth : Natural; + Current : Natural; + Proj1 : Project_List; + + procedure Add_To_Library_Projs (Proj : Project_Id); + -- Add project Project to table Library_Projs in + -- decreasing depth order. + + -------------------------- + -- Add_To_Library_Projs -- + -------------------------- + + procedure Add_To_Library_Projs (Proj : Project_Id) is + Prj : Project_Id; + + begin + Library_Projs.Increment_Last; + Depth := Proj.Depth; + + -- Put the projects in decreasing depth order, so that + -- if libA depends on libB, libB is first in order. + + Current := Library_Projs.Last; + while Current > 1 loop + Prj := Library_Projs.Table (Current - 1); + exit when Prj.Depth >= Depth; + Library_Projs.Table (Current) := Prj; + Current := Current - 1; + end loop; + + Library_Projs.Table (Current) := Proj; + end Add_To_Library_Projs; + + -- Start of processing for ??? (should name declare block + -- or probably better, break this out as a nested proc). + + begin + -- Put in Library_Projs table all library project file + -- ids when the library need to be rebuilt. + + Proj1 := Project_Tree.Projects; + while Proj1 /= null loop + if Proj1.Project.Standalone_Library then + Stand_Alone_Libraries := True; + end if; + + if Proj1.Project.Library then + MLib.Prj.Check_Library + (Proj1.Project, Project_Tree); + end if; + + if Proj1.Project.Need_To_Build_Lib then + Add_To_Library_Projs (Proj1.Project); + end if; + + Proj1 := Proj1.Next; + end loop; + + -- Check if importing libraries should be regenerated + -- because at least an imported library will be + -- regenerated or is more recent. + + Proj1 := Project_Tree.Projects; + while Proj1 /= null loop + if Proj1.Project.Library + and then Proj1.Project.Library_Kind /= Static + and then not Proj1.Project.Need_To_Build_Lib + and then not Proj1.Project.Externally_Built + then + declare + List : Project_List; + Proj2 : Project_Id; + Rebuild : Boolean := False; + + Lib_Timestamp1 : constant Time_Stamp_Type := + Proj1.Project.Library_TS; + + begin + List := Proj1.Project.All_Imported_Projects; + while List /= null loop + Proj2 := List.Project; + + if Proj2.Library then + if Proj2.Need_To_Build_Lib + or else + (Lib_Timestamp1 < Proj2.Library_TS) + then + Rebuild := True; + exit; + end if; + end if; + + List := List.Next; + end loop; + + if Rebuild then + Proj1.Project.Need_To_Build_Lib := True; + Add_To_Library_Projs (Proj1.Project); + end if; + end; + end if; + + Proj1 := Proj1.Next; + end loop; + + -- Reset the flags Need_To_Build_Lib for the next main, + -- to avoid rebuilding libraries uselessly. + + Proj1 := Project_Tree.Projects; + while Proj1 /= null loop + Proj1.Project.Need_To_Build_Lib := False; + Proj1 := Proj1.Next; + end loop; + end; + + -- Build the libraries, if any need to be built + + for J in 1 .. Library_Projs.Last loop + Library_Rebuilt := True; + + -- If a library is rebuilt, then executables are obsolete + + Executable_Obsolete := True; + + MLib.Prj.Build_Library + (For_Project => Library_Projs.Table (J), + In_Tree => Project_Tree, + Gnatbind => Gnatbind.all, + Gnatbind_Path => Gnatbind_Path, + Gcc => Gcc.all, + Gcc_Path => Gcc_Path); + end loop; + end if; + + if List_Dependencies then + if First_Compiled_File /= No_File then + Inform + (First_Compiled_File, + "must be recompiled. Can't generate dependence list."); + else + List_Depend; + end if; + + elsif First_Compiled_File = No_File + and then not Do_Bind_Step + and then not Quiet_Output + and then not Library_Rebuilt + and then Osint.Number_Of_Files = 1 + then + Inform (Msg => "objects up to date."); + + elsif Do_Not_Execute + and then First_Compiled_File /= No_File + then + Write_Name (First_Compiled_File); + Write_Eol; + end if; + + -- Stop after compile step if any of: + + -- 1) -n (Do_Not_Execute) specified + + -- 2) -M (List_Dependencies) specified (also sets + -- Do_Not_Execute above, so this is probably superfluous). + + -- 3) -c (Compile_Only) specified, but not -b (Bind_Only) + + -- 4) Made unit cannot be a main unit + + if ((Do_Not_Execute + or List_Dependencies + or not Do_Bind_Step + or not Is_Main_Unit) + and then not No_Main_Subprogram + and then not Build_Bind_And_Link_Full_Project) + or else Unique_Compile + then + if Osint.Number_Of_Files = 1 then + exit Multiple_Main_Loop; + + else + goto Next_Main; + end if; + end if; + + -- If the objects were up-to-date check if the executable file + -- is also up-to-date. For now always bind and link on the JVM + -- since there is currently no simple way to check whether + -- objects are up-to-date. + + if Targparm.VM_Target /= JVM_Target + and then First_Compiled_File = No_File + then + Executable_Stamp := File_Stamp (Executable); + + if not Executable_Obsolete then + Executable_Obsolete := + Youngest_Obj_Stamp > Executable_Stamp; + end if; + + if not Executable_Obsolete then + for Index in reverse 1 .. Dependencies.Last loop + if Is_In_Obsoleted + (Dependencies.Table (Index).Depends_On) + then + Enter_Into_Obsoleted + (Dependencies.Table (Index).This); + end if; + end loop; + + Executable_Obsolete := Is_In_Obsoleted (Main_Source_File); + Dependencies.Init; + end if; + + if not Executable_Obsolete then + + -- If no Ada object files obsolete the executable, check + -- for younger or missing linker files. + + Check_Linker_Options + (Executable_Stamp, + Youngest_Obj_File, + Youngest_Obj_Stamp); + + Executable_Obsolete := Youngest_Obj_File /= No_File; + end if; + + -- Check if any library file is more recent than the + -- executable: there may be an externally built library + -- file that has been modified. + + if not Executable_Obsolete + and then Main_Project /= No_Project + then + declare + Proj1 : Project_List; + + begin + Proj1 := Project_Tree.Projects; + while Proj1 /= null loop + if Proj1.Project.Library + and then + Proj1.Project.Library_TS > Executable_Stamp + then + Executable_Obsolete := True; + Youngest_Obj_Stamp := Proj1.Project.Library_TS; + Name_Len := 0; + Add_Str_To_Name_Buffer ("library "); + Add_Str_To_Name_Buffer + (Get_Name_String (Proj1.Project.Library_Name)); + Youngest_Obj_File := Name_Find; + exit; + end if; + + Proj1 := Proj1.Next; + end loop; + end; + end if; + + -- Return if the executable is up to date and otherwise + -- motivate the relink/rebind. + + if not Executable_Obsolete then + if not Quiet_Output then + Inform (Executable, "up to date."); + end if; + + if Osint.Number_Of_Files = 1 then + exit Multiple_Main_Loop; + + else + goto Next_Main; + end if; + end if; + + if Executable_Stamp (1) = ' ' then + if not No_Main_Subprogram then + Verbose_Msg (Executable, "missing.", Prefix => " "); + end if; + + elsif Youngest_Obj_Stamp (1) = ' ' then + Verbose_Msg + (Youngest_Obj_File, "missing.", Prefix => " "); + + elsif Youngest_Obj_Stamp > Executable_Stamp then + Verbose_Msg + (Youngest_Obj_File, + "(" & String (Youngest_Obj_Stamp) & ") newer than", + Executable, + "(" & String (Executable_Stamp) & ")"); + + else + Verbose_Msg + (Executable, "needs to be rebuilt", Prefix => " "); + + end if; + end if; + end Recursive_Compilation_Step; + end if; + + -- For binding and linking, we need to be in the object directory of + -- the main project. + + if Main_Project /= No_Project then + Change_To_Object_Directory (Main_Project); + end if; + + -- If we are here, it means that we need to rebuilt the current main, + -- so we set Executable_Obsolete to True to make sure that subsequent + -- mains will be rebuilt. + + Main_ALI_In_Place_Mode_Step : declare + ALI_File : File_Name_Type; + Src_File : File_Name_Type; + + begin + Src_File := Strip_Directory (Main_Source_File); + ALI_File := Lib_File_Name (Src_File, Current_Main_Index); + Main_ALI_File := Full_Lib_File_Name (ALI_File); + + -- When In_Place_Mode, the library file can be located in the + -- Main_Source_File directory which may not be present in the + -- library path. If it is not present then use the corresponding + -- library file name. + + if Main_ALI_File = No_File and then In_Place_Mode then + Get_Name_String (Get_Directory (Full_Source_Name (Src_File))); + Get_Name_String_And_Append (ALI_File); + Main_ALI_File := Name_Find; + Main_ALI_File := Full_Lib_File_Name (Main_ALI_File); + end if; + + if Main_ALI_File = No_File then + Make_Failed ("could not find the main ALI file"); + end if; + end Main_ALI_In_Place_Mode_Step; + + if Do_Bind_Step then + Bind_Step : declare + Args : Argument_List + (Binder_Switches.First .. Binder_Switches.Last + 2); + -- The arguments for the invocation of gnatbind + + Last_Arg : Natural := Binder_Switches.Last; + -- Index of the last argument in Args + + Shared_Libs : Boolean := False; + -- Set to True when there are shared library project files or + -- when gnatbind is invoked with -shared. + + Proj : Project_List; + + begin + -- Check if there are shared libraries, so that gnatbind is + -- called with -shared. Check also if gnatbind is called with + -- -shared, so that gnatlink is called with -shared-libgcc + -- ensuring that the shared version of libgcc will be used. + + if Main_Project /= No_Project + and then MLib.Tgt.Support_For_Libraries /= Prj.None + then + Proj := Project_Tree.Projects; + while Proj /= null loop + if Proj.Project.Library + and then Proj.Project.Library_Kind /= Static + then + Shared_Libs := True; + Bind_Shared := Shared_Switch'Access; + exit; + end if; + Proj := Proj.Next; + end loop; + end if; + + -- Check now for switch -shared + + if not Shared_Libs then + for J in Binder_Switches.First .. Last_Arg loop + if Binder_Switches.Table (J).all = "-shared" then + Shared_Libs := True; + exit; + end if; + end loop; + end if; + + -- If shared libraries present, invoke gnatlink with + -- -shared-libgcc. + + if Shared_Libs then + Link_With_Shared_Libgcc := Shared_Libgcc_Switch'Access; + end if; + + -- Get all the binder switches + + for J in Binder_Switches.First .. Last_Arg loop + Args (J) := Binder_Switches.Table (J); + end loop; + + if Stand_Alone_Libraries then + Last_Arg := Last_Arg + 1; + Args (Last_Arg) := Force_Elab_Flags_String'Access; + end if; + + if Main_Project /= No_Project then + + -- Put all the source directories in ADA_INCLUDE_PATH, + -- and all the object directories in ADA_OBJECTS_PATH, + -- except those of library projects. + + Prj.Env.Set_Ada_Paths + (Main_Project, Project_Tree, Use_Include_Path_File); + + -- If switch -C was specified, create a binder mapping file + + if Create_Mapping_File then + Mapping_Path := Create_Binder_Mapping_File; + + if Mapping_Path /= No_Path then + Last_Arg := Last_Arg + 1; + Args (Last_Arg) := + new String'("-F=" & Get_Name_String (Mapping_Path)); + end if; + end if; + + end if; + + begin + Bind (Main_ALI_File, + Bind_Shared.all & Args (Args'First .. Last_Arg)); + + exception + when others => + + -- Delete the temporary mapping file if one was created + + if Mapping_Path /= No_Path then + Delete_Temporary_File (Project_Tree, Mapping_Path); + end if; + + -- And reraise the exception + + raise; + end; + + -- If -dn was not specified, delete the temporary mapping file + -- if one was created. + + if Mapping_Path /= No_Path then + Delete_Temporary_File (Project_Tree, Mapping_Path); + end if; + end Bind_Step; + end if; + + if Do_Link_Step then + Link_Step : declare + Linker_Switches_Last : constant Integer := Linker_Switches.Last; + Path_Option : constant String_Access := + MLib.Linker_Library_Path_Option; + Libraries_Present : Boolean := False; + Current : Natural; + Proj2 : Project_Id; + Depth : Natural; + Proj1 : Project_List; + + begin + if not Run_Path_Option then + Linker_Switches.Increment_Last; + Linker_Switches.Table (Linker_Switches.Last) := + new String'("-R"); + end if; + + if Main_Project /= No_Project then + Library_Paths.Set_Last (0); + Library_Projs.Init; + + if MLib.Tgt.Support_For_Libraries /= Prj.None then + + -- Check for library projects + + Proj1 := Project_Tree.Projects; + while Proj1 /= null loop + if Proj1.Project /= Main_Project + and then Proj1.Project.Library + then + -- Add this project to table Library_Projs + + Libraries_Present := True; + Depth := Proj1.Project.Depth; + Library_Projs.Increment_Last; + Current := Library_Projs.Last; + + -- Any project with a greater depth should be + -- after this project in the list. + + while Current > 1 loop + Proj2 := Library_Projs.Table (Current - 1); + exit when Proj2.Depth <= Depth; + Library_Projs.Table (Current) := Proj2; + Current := Current - 1; + end loop; + + Library_Projs.Table (Current) := Proj1.Project; + + -- If it is not a static library and path option + -- is set, add it to the Library_Paths table. + + if Proj1.Project.Library_Kind /= Static + and then Path_Option /= null + then + Library_Paths.Increment_Last; + Library_Paths.Table (Library_Paths.Last) := + new String' + (Get_Name_String + (Proj1.Project.Library_Dir.Display_Name)); + end if; + end if; + + Proj1 := Proj1.Next; + end loop; + + for Index in 1 .. Library_Projs.Last loop + + -- Add the -L switch + + Linker_Switches.Increment_Last; + Linker_Switches.Table (Linker_Switches.Last) := + new String'("-L" & + Get_Name_String + (Library_Projs.Table (Index). + Library_Dir.Display_Name)); + + -- Add the -l switch + + Linker_Switches.Increment_Last; + Linker_Switches.Table (Linker_Switches.Last) := + new String'("-l" & + Get_Name_String + (Library_Projs.Table (Index). + Library_Name)); + end loop; + end if; + + if Libraries_Present then + + -- If Path_Option is not null, create the switch + -- ("-Wl,-rpath," or equivalent) with all the non static + -- library dirs plus the standard GNAT library dir. + -- We do that only if Run_Path_Option is True + -- (not disabled by -R switch). + + if Run_Path_Option and then Path_Option /= null then + declare + Option : String_Access; + Length : Natural := Path_Option'Length; + Current : Natural; + + begin + if MLib.Separate_Run_Path_Options then + + -- We are going to create one switch of the form + -- "-Wl,-rpath,dir_N" for each directory to + -- consider. + + -- One switch for each library directory + + for Index in + Library_Paths.First .. Library_Paths.Last + loop + Linker_Switches.Increment_Last; + Linker_Switches.Table + (Linker_Switches.Last) := new String' + (Path_Option.all & + Library_Paths.Table (Index).all); + end loop; + + -- One switch for the standard GNAT library dir + + Linker_Switches.Increment_Last; + Linker_Switches.Table + (Linker_Switches.Last) := new String' + (Path_Option.all & MLib.Utl.Lib_Directory); + + else + -- We are going to create one switch of the form + -- "-Wl,-rpath,dir_1:dir_2:dir_3" + + for Index in + Library_Paths.First .. Library_Paths.Last + loop + -- Add the length of the library dir plus one + -- for the directory separator. + + Length := + Length + + Library_Paths.Table (Index)'Length + 1; + end loop; + + -- Finally, add the length of the standard GNAT + -- library dir. + + Length := Length + MLib.Utl.Lib_Directory'Length; + Option := new String (1 .. Length); + Option (1 .. Path_Option'Length) := + Path_Option.all; + Current := Path_Option'Length; + + -- Put each library dir followed by a dir + -- separator. + + for Index in + Library_Paths.First .. Library_Paths.Last + loop + Option + (Current + 1 .. + Current + + Library_Paths.Table (Index)'Length) := + Library_Paths.Table (Index).all; + Current := + Current + + Library_Paths.Table (Index)'Length + 1; + Option (Current) := Path_Separator; + end loop; + + -- Finally put the standard GNAT library dir + + Option + (Current + 1 .. + Current + MLib.Utl.Lib_Directory'Length) := + MLib.Utl.Lib_Directory; + + -- And add the switch to the linker switches + + Linker_Switches.Increment_Last; + Linker_Switches.Table (Linker_Switches.Last) := + Option; + end if; + end; + end if; + + end if; + + -- Put the object directories in ADA_OBJECTS_PATH + + Prj.Env.Set_Ada_Paths + (Main_Project, + Project_Tree, + Including_Libraries => False, + Include_Path => False); + + -- Check for attributes Linker'Linker_Options in projects + -- other than the main project + + declare + Linker_Options : constant String_List := + Linker_Options_Switches + (Main_Project, Project_Tree); + begin + for Option in Linker_Options'Range loop + Linker_Switches.Increment_Last; + Linker_Switches.Table (Linker_Switches.Last) := + Linker_Options (Option); + end loop; + end; + end if; + + -- Add switch -M to gnatlink if builder switch + -- --create-map-file has been specified. + + if Map_File /= null then + Linker_Switches.Increment_Last; + Linker_Switches.Table (Linker_Switches.Last) := + new String'("-M" & Map_File.all); + end if; + + declare + Args : Argument_List + (Linker_Switches.First .. Linker_Switches.Last + 2); + + Last_Arg : Integer := Linker_Switches.First - 1; + Skip : Boolean := False; + + begin + -- Get all the linker switches + + for J in Linker_Switches.First .. Linker_Switches.Last loop + if Skip then + Skip := False; + + elsif Non_Std_Executable + and then Linker_Switches.Table (J).all = "-o" + then + Skip := True; + + -- Here we capture and duplicate the linker argument. We + -- need to do the duplication since the arguments will + -- get normalized. Not doing so will result in calling + -- normalized two times for the same set of arguments if + -- gnatmake is passed multiple mains. This can result in + -- the wrong argument being passed to the linker. + + else + Last_Arg := Last_Arg + 1; + Args (Last_Arg) := + new String'(Linker_Switches.Table (J).all); + end if; + end loop; + + -- If need be, add the -o switch + + if Non_Std_Executable then + Last_Arg := Last_Arg + 1; + Args (Last_Arg) := new String'("-o"); + Last_Arg := Last_Arg + 1; + Args (Last_Arg) := + new String'(Get_Name_String (Executable)); + end if; + + -- And invoke the linker + + declare + Success : Boolean := False; + begin + Link (Main_ALI_File, + Link_With_Shared_Libgcc.all & + Args (Args'First .. Last_Arg), + Success); + + if Success then + Successful_Links.Increment_Last; + Successful_Links.Table (Successful_Links.Last) := + Main_ALI_File; + + elsif Osint.Number_Of_Files = 1 + or else not Keep_Going + then + Make_Failed ("*** link failed."); + + else + Set_Standard_Error; + Write_Line ("*** link failed"); + + if Commands_To_Stdout then + Set_Standard_Output; + end if; + + Failed_Links.Increment_Last; + Failed_Links.Table (Failed_Links.Last) := + Main_ALI_File; + end if; + end; + end; + + Linker_Switches.Set_Last (Linker_Switches_Last); + end Link_Step; + end if; + + -- We go to here when we skip the bind and link steps + + <> + + -- We go to the next main, if we did not process the last one + + if N_File < Osint.Number_Of_Files then + Main_Source_File := Next_Main_Source; + + if Current_File_Index /= No_Index then + Main_Index := Current_File_Index; + end if; + + if Main_Project /= No_Project then + + -- Find the file name of the main unit + + declare + Main_Source_File_Name : constant String := + Get_Name_String (Main_Source_File); + + Main_Unit_File_Name : constant String := + Prj.Env. + File_Name_Of_Library_Unit_Body + (Name => Main_Source_File_Name, + Project => Main_Project, + In_Tree => Project_Tree, + Main_Project_Only => + not Unique_Compile); + + The_Packages : constant Package_Id := + Main_Project.Decl.Packages; + + Binder_Package : constant Prj.Package_Id := + Prj.Util.Value_Of + (Name => Name_Binder, + In_Packages => The_Packages, + In_Tree => Project_Tree); + + Linker_Package : constant Prj.Package_Id := + Prj.Util.Value_Of + (Name => Name_Linker, + In_Packages => The_Packages, + In_Tree => Project_Tree); + + begin + -- We fail if we cannot find the main source file + -- as an immediate source of the main project file. + + if Main_Unit_File_Name = "" then + Make_Failed ('"' & Main_Source_File_Name + & """ is not a unit of project " + & Project_File_Name.all & "."); + + else + -- Remove any directory information from the main + -- source file name. + + declare + Pos : Natural := Main_Unit_File_Name'Last; + + begin + loop + exit when Pos < Main_Unit_File_Name'First + or else + Main_Unit_File_Name (Pos) = Directory_Separator; + Pos := Pos - 1; + end loop; + + Name_Len := Main_Unit_File_Name'Last - Pos; + + Name_Buffer (1 .. Name_Len) := + Main_Unit_File_Name + (Pos + 1 .. Main_Unit_File_Name'Last); + + Main_Source_File := Name_Find; + end; + end if; + + -- We now deal with the binder and linker switches. + -- If no project file is used, there is nothing to do + -- because the binder and linker switches are the same + -- for all mains. + + -- Reset the tables Binder_Switches and Linker_Switches + + Binder_Switches.Set_Last (Last_Binder_Switch); + Linker_Switches.Set_Last (Last_Linker_Switch); + + -- Add binder switches from the project file for this main, + -- if any. + + if Do_Bind_Step and then Binder_Package /= No_Package then + if Verbose_Mode then + Write_Str ("Adding binder switches for """); + Write_Str (Main_Unit_File_Name); + Write_Line ("""."); + end if; + + Add_Switches + (Project_Node_Tree => Project_Node_Tree, + File_Name => Main_Unit_File_Name, + Index => Main_Index, + The_Package => Binder_Package, + Program => Binder); + end if; + + -- Add linker switches from the project file for this main, + -- if any. + + if Do_Link_Step and then Linker_Package /= No_Package then + if Verbose_Mode then + Write_Str ("Adding linker switches for"""); + Write_Str (Main_Unit_File_Name); + Write_Line ("""."); + end if; + + Add_Switches + (Project_Node_Tree => Project_Node_Tree, + File_Name => Main_Unit_File_Name, + Index => Main_Index, + The_Package => Linker_Package, + Program => Linker); + end if; + + -- As we are using a project file, for relative paths we add + -- the current working directory for any relative path on + -- the command line and the project directory, for any + -- relative path in the project file. + + declare + Dir_Path : constant String := + Get_Name_String + (Main_Project.Directory.Display_Name); + + begin + for + J in Last_Binder_Switch + 1 .. Binder_Switches.Last + loop + Test_If_Relative_Path + (Binder_Switches.Table (J), + Parent => Dir_Path, Including_L_Switch => False); + end loop; + + for + J in Last_Linker_Switch + 1 .. Linker_Switches.Last + loop + Test_If_Relative_Path + (Linker_Switches.Table (J), Parent => Dir_Path); + end loop; + end; + + -- We now put in the Binder_Switches and Linker_Switches + -- tables, the binder and linker switches of the command + -- line that have been put in the Saved_ tables. + -- These switches will follow the project file switches. + + for J in 1 .. Saved_Binder_Switches.Last loop + Add_Switch + (Saved_Binder_Switches.Table (J), + Binder, + And_Save => False); + end loop; + + for J in 1 .. Saved_Linker_Switches.Last loop + Add_Switch + (Saved_Linker_Switches.Table (J), + Linker, + And_Save => False); + end loop; + end; + end if; + end if; + + -- Remove all marks to be sure to check sources for all executables, + -- as the switches may be different and -s may be in use. + + Delete_All_Marks; + end loop Multiple_Main_Loop; + + if Do_Codepeer_Globalize_Step then + declare + Success : Boolean := False; + begin + Globalize (Success); + + if not Success then + Set_Standard_Error; + Write_Str ("*** globalize failed."); + + if Commands_To_Stdout then + Set_Standard_Output; + end if; + end if; + end; + end if; + + if Failed_Links.Last > 0 then + for Index in 1 .. Successful_Links.Last loop + Write_Str ("Linking of """); + Write_Str (Get_Name_String (Successful_Links.Table (Index))); + Write_Line (""" succeeded."); + end loop; + + Set_Standard_Error; + + for Index in 1 .. Failed_Links.Last loop + Write_Str ("Linking of """); + Write_Str (Get_Name_String (Failed_Links.Table (Index))); + Write_Line (""" failed."); + end loop; + + if Commands_To_Stdout then + Set_Standard_Output; + end if; + + if Total_Compilation_Failures = 0 then + Report_Compilation_Failed; + end if; + end if; + + if Total_Compilation_Failures /= 0 then + List_Bad_Compilations; + Report_Compilation_Failed; + end if; + + -- Delete the temporary mapping file that was created if we are + -- using project files. + + Delete_All_Temp_Files; + + -- Output Namet statistics + + Namet.Finalize; + + exception + when X : others => + Set_Standard_Error; + Write_Line (Exception_Information (X)); + Make_Failed ("INTERNAL ERROR. Please report."); + end Gnatmake; + + ---------- + -- Hash -- + ---------- + + function Hash (F : File_Name_Type) return Header_Num is + begin + return Header_Num (1 + F mod Max_Header); + end Hash; + + -------------------- + -- In_Ada_Lib_Dir -- + -------------------- + + function In_Ada_Lib_Dir (File : File_Name_Type) return Boolean is + D : constant File_Name_Type := Get_Directory (File); + B : constant Byte := Get_Name_Table_Byte (D); + begin + return (B and Ada_Lib_Dir) /= 0; + end In_Ada_Lib_Dir; + + ----------------------- + -- Init_Mapping_File -- + ----------------------- + + procedure Init_Mapping_File + (Project : Project_Id; + Data : in out Project_Compilation_Data; + File_Index : in out Natural) + is + FD : File_Descriptor; + Status : Boolean; + -- For call to Close + + begin + -- Increase the index of the last mapping file for this project + + Data.Last_Mapping_File_Names := Data.Last_Mapping_File_Names + 1; + + -- If there is a project file, call Create_Mapping_File with + -- the project id. + + if Project /= No_Project then + Prj.Env.Create_Mapping_File + (Project, + In_Tree => Project_Tree, + Language => Name_Ada, + Name => Data.Mapping_File_Names + (Data.Last_Mapping_File_Names)); + + -- Otherwise, just create an empty file + + else + Tempdir.Create_Temp_File + (FD, + Data.Mapping_File_Names (Data.Last_Mapping_File_Names)); + + if FD = Invalid_FD then + Make_Failed ("disk full"); + + else + Record_Temp_File + (Project_Tree, + Data.Mapping_File_Names (Data.Last_Mapping_File_Names)); + end if; + + Close (FD, Status); + + if not Status then + Make_Failed ("disk full"); + end if; + end if; + + -- And return the index of the newly created file + + File_Index := Data.Last_Mapping_File_Names; + end Init_Mapping_File; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Project_Node_Tree : out Project_Node_Tree_Ref) is + + procedure Check_Version_And_Help is + new Check_Version_And_Help_G (Makeusg); + + -- Start of processing for Initialize + + begin + -- Prepare the project's tree, since this is used to hold external + -- references, project path and other attributes that can be impacted by + -- the command line switches + + Project_Node_Tree := new Project_Node_Tree_Data; + Prj.Tree.Initialize (Project_Node_Tree); + + -- Override default initialization of Check_Object_Consistency since + -- this is normally False for GNATBIND, but is True for GNATMAKE since + -- we do not need to check source consistency again once GNATMAKE has + -- looked at the sources to check. + + Check_Object_Consistency := True; + + -- Package initializations (the order of calls is important here) + + Output.Set_Standard_Error; + + Gcc_Switches.Init; + Binder_Switches.Init; + Linker_Switches.Init; + + Csets.Initialize; + Snames.Initialize; + + Prj.Initialize (Project_Tree); + + Dependencies.Init; + + RTS_Specified := null; + N_M_Switch := 0; + + Mains.Delete; + + -- Add the directory where gnatmake is invoked in front of the path, + -- if gnatmake is invoked from a bin directory or with directory + -- information. Only do this if the platform is not VMS, where the + -- notion of path does not really exist. + + if not OpenVMS then + declare + Prefix : constant String := Executable_Prefix_Path; + Command : constant String := Command_Name; + + begin + if Prefix'Length > 0 then + declare + PATH : constant String := + Prefix & Directory_Separator & "bin" & + Path_Separator & + Getenv ("PATH").all; + begin + Setenv ("PATH", PATH); + end; + + else + for Index in reverse Command'Range loop + if Command (Index) = Directory_Separator then + declare + Absolute_Dir : constant String := + Normalize_Pathname + (Command (Command'First .. Index)); + PATH : constant String := + Absolute_Dir & + Path_Separator & + Getenv ("PATH").all; + begin + Setenv ("PATH", PATH); + end; + + exit; + end if; + end loop; + end if; + end; + end if; + + -- Scan the switches and arguments + + -- First, scan to detect --version and/or --help + + Check_Version_And_Help ("GNATMAKE", "1995"); + + -- Scan again the switch and arguments, now that we are sure that they + -- do not include --version or --help. + + Scan_Args : for Next_Arg in 1 .. Argument_Count loop + Scan_Make_Arg + (Project_Node_Tree, Argument (Next_Arg), And_Save => True); + end loop Scan_Args; + + if N_M_Switch > 0 and RTS_Specified = null then + Process_Multilib (Project_Node_Tree); + end if; + + if Commands_To_Stdout then + Set_Standard_Output; + end if; + + if Usage_Requested then + Usage; + end if; + + -- Test for trailing -P switch + + if Project_File_Name_Present and then Project_File_Name = null then + Make_Failed ("project file name missing after -P"); + + -- Test for trailing -o switch + + elsif Output_File_Name_Present + and then not Output_File_Name_Seen + then + Make_Failed ("output file name missing after -o"); + + -- Test for trailing -D switch + + elsif Object_Directory_Present + and then not Object_Directory_Seen then + Make_Failed ("object directory missing after -D"); + end if; + + -- Test for simultaneity of -i and -D + + if Object_Directory_Path /= null and then In_Place_Mode then + Make_Failed ("-i and -D cannot be used simultaneously"); + end if; + + -- Deal with -C= switch + + if Gnatmake_Mapping_File /= null then + + -- First, check compatibility with other switches + + if Project_File_Name /= null then + Make_Failed ("-C= switch is not compatible with -P switch"); + + elsif Saved_Maximum_Processes > 1 then + Make_Failed ("-C= switch is not compatible with -jnnn switch"); + end if; + + Fmap.Initialize (Gnatmake_Mapping_File.all); + Add_Switch + ("-gnatem=" & Gnatmake_Mapping_File.all, + Compiler, + And_Save => True); + end if; + + if Project_File_Name /= null then + + -- A project file was specified by a -P switch + + if Verbose_Mode then + Write_Eol; + Write_Str ("Parsing project file """); + Write_Str (Project_File_Name.all); + Write_Str ("""."); + Write_Eol; + end if; + + -- Avoid looking in the current directory for ALI files + + -- Look_In_Primary_Dir := False; + + -- Set the project parsing verbosity to whatever was specified + -- by a possible -vP switch. + + Prj.Pars.Set_Verbosity (To => Current_Verbosity); + + -- Parse the project file. + -- If there is an error, Main_Project will still be No_Project. + + Prj.Pars.Parse + (Project => Main_Project, + In_Tree => Project_Tree, + Project_File_Name => Project_File_Name.all, + Packages_To_Check => Packages_To_Check_By_Gnatmake, + Flags => Gnatmake_Flags, + In_Node_Tree => Project_Node_Tree); + + -- The parsing of project files may have changed the current output + + if Commands_To_Stdout then + Set_Standard_Output; + else + Set_Standard_Error; + end if; + + if Main_Project = No_Project then + Make_Failed + ("""" & Project_File_Name.all & """ processing failed"); + end if; + + Create_Mapping_File := True; + + if Verbose_Mode then + Write_Eol; + Write_Str ("Parsing of project file """); + Write_Str (Project_File_Name.all); + Write_Str (""" is finished."); + Write_Eol; + end if; + + -- We add the source directories and the object directories to the + -- search paths. + -- ??? Why do we need these search directories, we already know the + -- locations from parsing the project, except for the runtime which + -- has its own directories anyway + + Add_Source_Directories (Main_Project, Project_Tree); + Add_Object_Directories (Main_Project); + + Recursive_Compute_Depth (Main_Project); + Compute_All_Imported_Projects (Project_Tree); + + else + + Osint.Add_Default_Search_Dirs; + + -- Source file lookups should be cached for efficiency. Source files + -- are not supposed to change. However, we do that now only if no + -- project file is used; if a project file is used, we do it just + -- after changing the directory to the object directory. + + Osint.Source_File_Data (Cache => True); + + -- Read gnat.adc file to initialize Fname.UF + + Fname.UF.Initialize; + + begin + Fname.SF.Read_Source_File_Name_Pragmas; + + exception + when Err : SFN_Scan.Syntax_Error_In_GNAT_ADC => + Make_Failed (Exception_Message (Err)); + end; + end if; + + -- Make sure no project object directory is recorded + + Project_Of_Current_Object_Directory := No_Project; + + end Initialize; + + ---------------------------- + -- Insert_Project_Sources -- + ---------------------------- + + procedure Insert_Project_Sources + (The_Project : Project_Id; + All_Projects : Boolean; + Into_Q : Boolean) + is + Put_In_Q : Boolean := Into_Q; + Unit : Unit_Index; + Sfile : File_Name_Type; + Index : Int; + Project : Project_Id; + + Extending : constant Boolean := The_Project.Extends /= No_Project; + + function Check_Project (P : Project_Id) return Boolean; + -- Returns True if P is The_Project or a project extended by The_Project + + ------------------- + -- Check_Project -- + ------------------- + + function Check_Project (P : Project_Id) return Boolean is + begin + if All_Projects or else P = The_Project then + return True; + + elsif Extending then + declare + Proj : Project_Id; + + begin + Proj := The_Project; + while Proj /= null loop + if P = Proj.Extends then + return True; + end if; + + Proj := Proj.Extends; + end loop; + end; + end if; + + return False; + end Check_Project; + + -- Start of processing for Insert_Project_Sources + + begin + -- For all the sources in the project files, + + Unit := Units_Htable.Get_First (Project_Tree.Units_HT); + while Unit /= null loop + Sfile := No_File; + Index := 0; + Project := No_Project; + + -- If there is a source for the body, and the body has not been + -- locally removed. + + if Unit.File_Names (Impl) /= null + and then not Unit.File_Names (Impl).Locally_Removed + then + -- And it is a source for the specified project + + if Check_Project (Unit.File_Names (Impl).Project) then + Project := Unit.File_Names (Impl).Project; + + -- If we don't have a spec, we cannot consider the source + -- if it is a subunit. + + if Unit.File_Names (Spec) = null then + declare + Src_Ind : Source_File_Index; + + -- Here we are cheating a little bit: we don't want to + -- use Sinput.L, because it depends on the GNAT tree + -- (Atree, Sinfo, ...). So, we pretend that it is a + -- project file, and we use Sinput.P. + + -- Source_File_Is_Subunit is just scanning through the + -- file until it finds one of the reserved words + -- separate, procedure, function, generic or package. + -- Fortunately, these Ada reserved words are also + -- reserved for project files. + + begin + Src_Ind := Sinput.P.Load_Project_File + (Get_Name_String + (Unit.File_Names (Impl).Path.Display_Name)); + + -- If it is a subunit, discard it + + if Sinput.P.Source_File_Is_Subunit (Src_Ind) then + Sfile := No_File; + Index := 0; + else + Sfile := Unit.File_Names (Impl).Display_File; + Index := Unit.File_Names (Impl).Index; + end if; + end; + + else + Sfile := Unit.File_Names (Impl).Display_File; + Index := Unit.File_Names (Impl).Index; + end if; + end if; + + elsif Unit.File_Names (Spec) /= null + and then not Unit.File_Names (Spec).Locally_Removed + and then Check_Project (Unit.File_Names (Spec).Project) + then + -- If there is no source for the body, but there is one for the + -- spec which has not been locally removed, then we take this one. + + Sfile := Unit.File_Names (Spec).Display_File; + Index := Unit.File_Names (Spec).Index; + Project := Unit.File_Names (Spec).Project; + end if; + + -- For the first source inserted into the Q, we need to initialize + -- the Q, but not for the subsequent sources. + + Queue.Initialize + (Main_Project /= No_Project and then + One_Compilation_Per_Obj_Dir); + + -- And of course, only insert in the Q if the source is not marked + + if Sfile /= No_File and then not Is_Marked (Sfile, Index) then + if Verbose_Mode then + Write_Str ("Adding """); + Write_Str (Get_Name_String (Sfile)); + Write_Line (""" to the queue"); + end if; + + Queue.Insert (Sfile, Project, Index => Index); + Mark (Sfile, Index); + end if; + + if not Put_In_Q and then Sfile /= No_File then + + -- If Put_In_Q is False, we add the source as if it were specified + -- on the command line, and we set Put_In_Q to True, so that the + -- following sources will only be put in the queue. The source is + -- already in the Q, but we need at least one fake main to call + -- Compile_Sources. + + if Verbose_Mode then + Write_Str ("Adding """); + Write_Str (Get_Name_String (Sfile)); + Write_Line (""" as if on the command line"); + end if; + + Osint.Add_File (Get_Name_String (Sfile), Index); + Put_In_Q := True; + end if; + + Unit := Units_Htable.Get_Next (Project_Tree.Units_HT); + end loop; + end Insert_Project_Sources; + + --------------------- + -- Is_In_Obsoleted -- + --------------------- + + function Is_In_Obsoleted (F : File_Name_Type) return Boolean is + begin + if F = No_File then + return False; + + else + declare + Name : constant String := Get_Name_String (F); + First : Natural; + F2 : File_Name_Type; + + begin + First := Name'Last; + while First > Name'First + and then Name (First - 1) /= Directory_Separator + and then Name (First - 1) /= '/' + loop + First := First - 1; + end loop; + + if First /= Name'First then + Name_Len := 0; + Add_Str_To_Name_Buffer (Name (First .. Name'Last)); + F2 := Name_Find; + + else + F2 := F; + end if; + + return Obsoleted.Get (F2); + end; + end if; + end Is_In_Obsoleted; + + ---------------------------- + -- Is_In_Object_Directory -- + ---------------------------- + + function Is_In_Object_Directory + (Source_File : File_Name_Type; + Full_Lib_File : File_Name_Type) return Boolean + is + begin + -- There is something to check only when using project files. Otherwise, + -- this function returns True (last line of the function). + + if Main_Project /= No_Project then + declare + Source_File_Name : constant String := + Get_Name_String (Source_File); + Saved_Verbosity : constant Verbosity := Current_Verbosity; + Project : Project_Id := No_Project; + + Path_Name : Path_Name_Type := No_Path; + pragma Warnings (Off, Path_Name); + + begin + -- Call Get_Reference to know the ultimate extending project of + -- the source. Call it with verbosity default to avoid verbose + -- messages. + + Current_Verbosity := Default; + Prj.Env.Get_Reference + (Source_File_Name => Source_File_Name, + Project => Project, + In_Tree => Project_Tree, + Path => Path_Name); + Current_Verbosity := Saved_Verbosity; + + -- If this source is in a project, check that the ALI file is in + -- its object directory. If it is not, return False, so that the + -- ALI file will not be skipped. + + if Project /= No_Project then + declare + Object_Directory : constant String := + Normalize_Pathname + (Get_Name_String + (Project. + Object_Directory.Display_Name)); + + Olast : Natural := Object_Directory'Last; + + Lib_File_Directory : constant String := + Normalize_Pathname (Dir_Name + (Get_Name_String (Full_Lib_File))); + + Llast : Natural := Lib_File_Directory'Last; + + begin + -- For directories, Normalize_Pathname may or may not put + -- a directory separator at the end, depending on its input. + -- Remove any last directory separator before comparison. + -- Returns True only if the two directories are the same. + + if Object_Directory (Olast) = Directory_Separator then + Olast := Olast - 1; + end if; + + if Lib_File_Directory (Llast) = Directory_Separator then + Llast := Llast - 1; + end if; + + return Object_Directory (Object_Directory'First .. Olast) = + Lib_File_Directory (Lib_File_Directory'First .. Llast); + end; + end if; + end; + end if; + + -- When the source is not in a project file, always return True + + return True; + end Is_In_Object_Directory; + + ---------- + -- Link -- + ---------- + + procedure Link + (ALI_File : File_Name_Type; + Args : Argument_List; + Success : out Boolean) + is + Link_Args : Argument_List (1 .. Args'Length + 1); + + begin + Get_Name_String (ALI_File); + Link_Args (1) := new String'(Name_Buffer (1 .. Name_Len)); + + Link_Args (2 .. Args'Length + 1) := Args; + + GNAT.OS_Lib.Normalize_Arguments (Link_Args); + + Display (Gnatlink.all, Link_Args); + + if Gnatlink_Path = null then + Make_Failed ("error, unable to locate " & Gnatlink.all); + end if; + + GNAT.OS_Lib.Spawn (Gnatlink_Path.all, Link_Args, Success); + end Link; + + --------------------------- + -- List_Bad_Compilations -- + --------------------------- + + procedure List_Bad_Compilations is + begin + for J in Bad_Compilation.First .. Bad_Compilation.Last loop + if Bad_Compilation.Table (J).File = No_File then + null; + elsif not Bad_Compilation.Table (J).Found then + Inform (Bad_Compilation.Table (J).File, "not found"); + else + Inform (Bad_Compilation.Table (J).File, "compilation error"); + end if; + end loop; + end List_Bad_Compilations; + + ----------------- + -- List_Depend -- + ----------------- + + procedure List_Depend is + Lib_Name : File_Name_Type; + Obj_Name : File_Name_Type; + Src_Name : File_Name_Type; + + Len : Natural; + Line_Pos : Natural; + Line_Size : constant := 77; + + begin + Set_Standard_Output; + + for A in ALIs.First .. ALIs.Last loop + Lib_Name := ALIs.Table (A).Afile; + + -- We have to provide the full library file name in In_Place_Mode + + if In_Place_Mode then + Lib_Name := Full_Lib_File_Name (Lib_Name); + end if; + + Obj_Name := Object_File_Name (Lib_Name); + Write_Name (Obj_Name); + Write_Str (" :"); + + Get_Name_String (Obj_Name); + Len := Name_Len; + Line_Pos := Len + 2; + + for D in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop + Src_Name := Sdep.Table (D).Sfile; + + if Is_Internal_File_Name (Src_Name) + and then not Check_Readonly_Files + then + null; + else + if not Quiet_Output then + Src_Name := Full_Source_Name (Src_Name); + end if; + + Get_Name_String (Src_Name); + Len := Name_Len; + + if Line_Pos + Len + 1 > Line_Size then + Write_Str (" \"); + Write_Eol; + Line_Pos := 0; + end if; + + Line_Pos := Line_Pos + Len + 1; + + Write_Str (" "); + Write_Name (Src_Name); + end if; + end loop; + + Write_Eol; + end loop; + + if not Commands_To_Stdout then + Set_Standard_Error; + end if; + end List_Depend; + + ----------------- + -- Make_Failed -- + ----------------- + + procedure Make_Failed (S : String) is + begin + Delete_All_Temp_Files; + Osint.Fail (S); + end Make_Failed; + + -------------------- + -- Mark_Directory -- + -------------------- + + procedure Mark_Directory + (Dir : String; + Mark : Lib_Mark_Type; + On_Command_Line : Boolean) + is + N : Name_Id; + B : Byte; + + function Base_Directory return String; + -- If Dir comes from the command line, empty string (relative paths are + -- resolved with respect to the current directory), else return the main + -- project's directory. + + -------------------- + -- Base_Directory -- + -------------------- + + function Base_Directory return String is + begin + if On_Command_Line then + return ""; + else + return Get_Name_String (Main_Project.Directory.Display_Name); + end if; + end Base_Directory; + + Real_Path : constant String := Normalize_Pathname (Dir, Base_Directory); + + -- Start of processing for Mark_Directory + + begin + Name_Len := 0; + + if Real_Path'Length = 0 then + Add_Str_To_Name_Buffer (Dir); + + else + Add_Str_To_Name_Buffer (Real_Path); + end if; + + -- Last character is supposed to be a directory separator + + if not Is_Directory_Separator (Name_Buffer (Name_Len)) then + Add_Char_To_Name_Buffer (Directory_Separator); + end if; + + -- Add flags to the already existing flags + + N := Name_Find; + B := Get_Name_Table_Byte (N); + Set_Name_Table_Byte (N, B or Mark); + end Mark_Directory; + + ---------------------- + -- Process_Multilib -- + ---------------------- + + procedure Process_Multilib + (Project_Node_Tree : Project_Node_Tree_Ref) + is + Output_FD : File_Descriptor; + Output_Name : String_Access; + Arg_Index : Natural := 0; + Success : Boolean := False; + Return_Code : Integer := 0; + Multilib_Gcc_Path : String_Access; + Multilib_Gcc : String_Access; + N_Read : Integer := 0; + Line : String (1 .. 1000); + Args : Argument_List (1 .. N_M_Switch + 1); + + begin + pragma Assert (N_M_Switch > 0 and RTS_Specified = null); + + -- In case we detected a multilib switch and the user has not + -- manually specified a specific RTS we emulate the following command: + -- gnatmake $FLAGS --RTS=$(gcc -print-multi-directory $FLAGS) + + -- First select the flags which might have an impact on multilib + -- processing. Note that this is an heuristic selection and it + -- will need to be maintained over time. The condition has to + -- be kept synchronized with N_M_Switch counting in Scan_Make_Arg. + + for Next_Arg in 1 .. Argument_Count loop + declare + Argv : constant String := Argument (Next_Arg); + begin + if Argv'Length > 2 + and then Argv (1) = '-' + and then Argv (2) = 'm' + and then Argv /= "-margs" + + -- Ignore -mieee to avoid spawning an extra gcc in this case + + and then Argv /= "-mieee" + then + Arg_Index := Arg_Index + 1; + Args (Arg_Index) := new String'(Argv); + end if; + end; + end loop; + + pragma Assert (Arg_Index = N_M_Switch); + + Args (Args'Last) := new String'("-print-multi-directory"); + + -- Call the GCC driver with the collected flags and save its + -- output. Alternate design would be to link in gnatmake the + -- relevant part of the GCC driver. + + if Saved_Gcc /= null then + Multilib_Gcc := Saved_Gcc; + else + Multilib_Gcc := Gcc; + end if; + + Multilib_Gcc_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Multilib_Gcc.all); + + Create_Temp_Output_File (Output_FD, Output_Name); + + if Output_FD = Invalid_FD then + return; + end if; + + GNAT.OS_Lib.Spawn + (Multilib_Gcc_Path.all, Args, Output_FD, Return_Code, False); + Close (Output_FD); + + if Return_Code /= 0 then + return; + end if; + + -- Parse the GCC driver output which is a single line, removing CR/LF + + Output_FD := Open_Read (Output_Name.all, Binary); + + if Output_FD = Invalid_FD then + return; + end if; + + N_Read := Read (Output_FD, Line (1)'Address, Line'Length); + Close (Output_FD); + Delete_File (Output_Name.all, Success); + + for J in reverse 1 .. N_Read loop + if Line (J) = ASCII.CR or else Line (J) = ASCII.LF then + N_Read := N_Read - 1; + else + exit; + end if; + end loop; + + -- In case the standard RTS is selected do nothing + + if N_Read = 0 or else Line (1 .. N_Read) = "." then + return; + end if; + + -- Otherwise add -margs --RTS=output + + Scan_Make_Arg (Project_Node_Tree, "-margs", And_Save => True); + Scan_Make_Arg + (Project_Node_Tree, "--RTS=" & Line (1 .. N_Read), And_Save => True); + end Process_Multilib; + + ----------- + -- Queue -- + ----------- + + package body Queue is + + type Q_Record is record + File : File_Name_Type; + Unit : Unit_Name_Type; + Index : Int; + Project : Project_Id; + Processed : Boolean; + end record; + -- File is the name of the file to compile. Unit is for gnatdist use in + -- order to easily get the unit name of a file to compile when its name + -- is krunched or declared in gnat.adc. Index, when not 0, is the index + -- of the unit in a multi-unit source. + + package Q is new Table.Table + (Table_Component_Type => Q_Record, + Table_Index_Type => Positive, + Table_Low_Bound => 1, + Table_Initial => 4000, + Table_Increment => 100, + Table_Name => "Make.Queue.Q"); + -- This is the actual Q + + package Busy_Obj_Dirs is new GNAT.HTable.Simple_HTable + (Header_Num => Prj.Header_Num, + Element => Boolean, + No_Element => False, + Key => Path_Name_Type, + Hash => Hash, + Equal => "="); + + Q_First : Natural := 1; + -- Points to the first valid element in the queue + + Q_Processed : Natural := 0; + One_Queue_Per_Obj_Dir : Boolean := False; + Q_Initialized : Boolean := False; + + ------------- + -- Element -- + ------------- + + function Element (Rank : Positive) return File_Name_Type is + begin + if Rank <= Q.Last then + return Q.Table (Rank).File; + else + return No_File; + end if; + end Element; + + ------------- + -- Extract -- + ------------- + + -- This body needs commenting ??? + + procedure Extract + (Source_File_Name : out File_Name_Type; + Source_Unit : out Unit_Name_Type; + Source_Index : out Int) + is + Found : Boolean := False; + + begin + if One_Queue_Per_Obj_Dir then + for J in Q_First .. Q.Last loop + if not Q.Table (J).Processed + and then (Q.Table (J).Project = No_Project + or else not + Busy_Obj_Dirs.Get + (Q.Table (J).Project.Object_Directory.Name)) + then + Found := True; + Source_File_Name := Q.Table (J).File; + Source_Unit := Q.Table (J).Unit; + Source_Index := Q.Table (J).Index; + Q.Table (J).Processed := True; + + if J = Q_First then + while Q_First <= Q.Last + and then Q.Table (Q_First).Processed + loop + Q_First := Q_First + 1; + end loop; + end if; + + exit; + end if; + end loop; + + elsif Q_First <= Q.Last then + Source_File_Name := Q.Table (Q_First).File; + Source_Unit := Q.Table (Q_First).Unit; + Source_Index := Q.Table (Q_First).Index; + Q.Table (Q_First).Processed := True; + Q_First := Q_First + 1; + Found := True; + end if; + + if Found then + Q_Processed := Q_Processed + 1; + else + Source_File_Name := No_File; + Source_Unit := No_Unit_Name; + Source_Index := 0; + end if; + + if Found and then Debug.Debug_Flag_Q then + Write_Str (" Q := Q - [ "); + Write_Name (Source_File_Name); + + if Source_Index /= 0 then + Write_Str (", "); + Write_Int (Source_Index); + end if; + + Write_Str (" ]"); + Write_Eol; + + Write_Str (" Q_First ="); + Write_Int (Int (Q_First)); + Write_Eol; + + Write_Str (" Q.Last ="); + Write_Int (Int (Q.Last)); + Write_Eol; + end if; + end Extract; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Queue_Per_Obj_Dir : Boolean) is + begin + if not Q_Initialized then + One_Queue_Per_Obj_Dir := Queue_Per_Obj_Dir; + Q.Init; + Q_Initialized := True; + Q_Processed := 0; + Q_First := 1; + end if; + end Initialize; + + ------------ + -- Insert -- + ------------ + + -- This body needs commenting ??? + + procedure Insert + (Source_File_Name : File_Name_Type; + Project : Project_Id; + Source_Unit : Unit_Name_Type := No_Unit_Name; + Index : Int := 0) + is + begin + Q.Append + ((File => Source_File_Name, + Project => Project, + Unit => Source_Unit, + Index => Index, + Processed => False)); + + if Debug.Debug_Flag_Q then + Write_Str (" Q := Q + [ "); + Write_Name (Source_File_Name); + + if Index /= 0 then + Write_Str (", "); + Write_Int (Index); + end if; + + Write_Str (" ] "); + Write_Eol; + + Write_Str (" Q_First ="); + Write_Int (Int (Q_First)); + Write_Eol; + + Write_Str (" Q.Last ="); + Write_Int (Int (Q.Last)); + Write_Eol; + end if; + end Insert; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty return Boolean is + begin + if Debug.Debug_Flag_P then + Write_Str (" Q := ["); + + for J in Q_First .. Q.Last loop + if not Q.Table (J).Processed then + Write_Str (" "); + Write_Name (Q.Table (J).File); + Write_Eol; + Write_Str (" "); + end if; + end loop; + + Write_Str ("]"); + Write_Eol; + end if; + + return Q_First > Q.Last; + end Is_Empty; + + ------------------------ + -- Is_Virtually_Empty -- + ------------------------ + + function Is_Virtually_Empty return Boolean is + begin + if One_Queue_Per_Obj_Dir then + for J in Q_First .. Q.Last loop + if not Q.Table (J).Processed + and then + (Q.Table (J).Project = No_Project + or else not + Busy_Obj_Dirs.Get + (Q.Table (J).Project.Object_Directory.Name)) + then + return False; + end if; + end loop; + + return True; + + else + return Is_Empty; + end if; + end Is_Virtually_Empty; + + --------------- + -- Processed -- + --------------- + + function Processed return Natural is + begin + return Q_Processed; + end Processed; + + ---------------------- + -- Set_Obj_Dir_Busy -- + ---------------------- + + procedure Set_Obj_Dir_Busy (Obj_Dir : Path_Name_Type) is + begin + if One_Queue_Per_Obj_Dir then + Busy_Obj_Dirs.Set (Obj_Dir, True); + end if; + end Set_Obj_Dir_Busy; + + ---------------------- + -- Set_Obj_Dir_Free -- + ---------------------- + + procedure Set_Obj_Dir_Free (Obj_Dir : Path_Name_Type) is + begin + if One_Queue_Per_Obj_Dir then + Busy_Obj_Dirs.Set (Obj_Dir, False); + end if; + end Set_Obj_Dir_Free; + + ---------- + -- Size -- + ---------- + + function Size return Natural is + begin + return Q.Last; + end Size; + + end Queue; + + ----------------------------- + -- Recursive_Compute_Depth -- + ----------------------------- + + procedure Recursive_Compute_Depth (Project : Project_Id) is + use Project_Boolean_Htable; + Seen : Project_Boolean_Htable.Instance := Project_Boolean_Htable.Nil; + + procedure Recurse (Prj : Project_Id; Depth : Natural); + -- Recursive procedure that does the work, keeping track of the depth + + ------------- + -- Recurse -- + ------------- + + procedure Recurse (Prj : Project_Id; Depth : Natural) is + List : Project_List; + Proj : Project_Id; + + begin + if Prj.Depth >= Depth or else Get (Seen, Prj) then + return; + end if; + + -- We need a test to avoid infinite recursions with limited withs: + -- If we have A -> B -> A, then when set level of A to n, we try and + -- set level of B to n+1, and then level of A to n + 2, ... + + Set (Seen, Prj, True); + + Prj.Depth := Depth; + + -- Visit each imported project + + List := Prj.Imported_Projects; + while List /= null loop + Proj := List.Project; + List := List.Next; + Recurse (Prj => Proj, Depth => Depth + 1); + end loop; + + -- We again allow changing the depth of this project later on if it + -- is in fact imported by a lower-level project. + + Set (Seen, Prj, False); + end Recurse; + + Proj : Project_List; + + -- Start of processing for Recursive_Compute_Depth + + begin + Proj := Project_Tree.Projects; + while Proj /= null loop + Proj.Project.Depth := 0; + Proj := Proj.Next; + end loop; + + Recurse (Project, Depth => 1); + Reset (Seen); + end Recursive_Compute_Depth; + + ------------------------------- + -- Report_Compilation_Failed -- + ------------------------------- + + procedure Report_Compilation_Failed is + begin + Delete_All_Temp_Files; + Exit_Program (E_Fatal); + end Report_Compilation_Failed; + + ------------------------ + -- Sigint_Intercepted -- + ------------------------ + + procedure Sigint_Intercepted is + SIGINT : constant := 2; + + begin + Set_Standard_Error; + Write_Line ("*** Interrupted ***"); + + -- Send SIGINT to all outstanding compilation processes spawned + + for J in 1 .. Outstanding_Compiles loop + Kill (Running_Compile (J).Pid, SIGINT, 1); + end loop; + + Delete_All_Temp_Files; + OS_Exit (1); + -- ??? OS_Exit (1) is equivalent to Exit_Program (E_No_Compile), + -- shouldn't that be Exit_Program (E_Abort) instead? + end Sigint_Intercepted; + + ------------------- + -- Scan_Make_Arg -- + ------------------- + + procedure Scan_Make_Arg + (Project_Node_Tree : Project_Node_Tree_Ref; + Argv : String; + And_Save : Boolean) + is + Success : Boolean; + + begin + Gnatmake_Switch_Found := True; + + pragma Assert (Argv'First = 1); + + if Argv'Length = 0 then + return; + end if; + + -- If the previous switch has set the Project_File_Name_Present flag + -- (that is we have seen a -P alone), then the next argument is the name + -- of the project file. + + if Project_File_Name_Present and then Project_File_Name = null then + if Argv (1) = '-' then + Make_Failed ("project file name missing after -P"); + + else + Project_File_Name_Present := False; + Project_File_Name := new String'(Argv); + end if; + + -- If the previous switch has set the Output_File_Name_Present flag + -- (that is we have seen a -o), then the next argument is the name of + -- the output executable. + + elsif Output_File_Name_Present + and then not Output_File_Name_Seen + then + Output_File_Name_Seen := True; + + if Argv (1) = '-' then + Make_Failed ("output file name missing after -o"); + + else + Add_Switch ("-o", Linker, And_Save => And_Save); + Add_Switch (Executable_Name (Argv), Linker, And_Save => And_Save); + end if; + + -- If the previous switch has set the Object_Directory_Present flag + -- (that is we have seen a -D), then the next argument is the path name + -- of the object directory. + + elsif Object_Directory_Present + and then not Object_Directory_Seen + then + Object_Directory_Seen := True; + + if Argv (1) = '-' then + Make_Failed ("object directory path name missing after -D"); + + elsif not Is_Directory (Argv) then + Make_Failed ("cannot find object directory """ & Argv & """"); + + else + -- Record the object directory. Make sure it ends with a directory + -- separator. + + declare + Norm : constant String := Normalize_Pathname (Argv); + + begin + if Norm (Norm'Last) = Directory_Separator then + Object_Directory_Path := new String'(Norm); + else + Object_Directory_Path := + new String'(Norm & Directory_Separator); + end if; + + Add_Lib_Search_Dir (Norm); + + -- Specify the object directory to the binder + + Add_Switch ("-aO" & Norm, Binder, And_Save => And_Save); + end; + + end if; + + -- Then check if we are dealing with -cargs/-bargs/-largs/-margs + + elsif Argv = "-bargs" + or else + Argv = "-cargs" + or else + Argv = "-largs" + or else + Argv = "-margs" + then + case Argv (2) is + when 'c' => Program_Args := Compiler; + when 'b' => Program_Args := Binder; + when 'l' => Program_Args := Linker; + when 'm' => Program_Args := None; + + when others => + raise Program_Error; + end case; + + -- A special test is needed for the -o switch within a -largs since that + -- is another way to specify the name of the final executable. + + elsif Program_Args = Linker + and then Argv = "-o" + then + Make_Failed ("switch -o not allowed within a -largs. " & + "Use -o directly."); + + -- Check to see if we are reading switches after a -cargs, -bargs or + -- -largs switch. If so, save it. + + elsif Program_Args /= None then + + -- Check to see if we are reading -I switches in order + -- to take into account in the src & lib search directories. + + if Argv'Length > 2 and then Argv (1 .. 2) = "-I" then + if Argv (3 .. Argv'Last) = "-" then + Look_In_Primary_Dir := False; + + elsif Program_Args = Compiler then + if Argv (3 .. Argv'Last) /= "-" then + Add_Source_Search_Dir (Argv (3 .. Argv'Last), And_Save); + end if; + + elsif Program_Args = Binder then + Add_Library_Search_Dir (Argv (3 .. Argv'Last), And_Save); + end if; + end if; + + Add_Switch (Argv, Program_Args, And_Save => And_Save); + + -- Handle non-default compiler, binder, linker, and handle --RTS switch + + elsif Argv'Length > 2 and then Argv (1 .. 2) = "--" then + if Argv'Length > 6 + and then Argv (1 .. 6) = "--GCC=" + then + declare + Program_Args : constant Argument_List_Access := + Argument_String_To_List + (Argv (7 .. Argv'Last)); + + begin + if And_Save then + Saved_Gcc := new String'(Program_Args.all (1).all); + else + Gcc := new String'(Program_Args.all (1).all); + end if; + + for J in 2 .. Program_Args.all'Last loop + Add_Switch + (Program_Args.all (J).all, Compiler, And_Save => And_Save); + end loop; + end; + + elsif Argv'Length > 11 + and then Argv (1 .. 11) = "--GNATBIND=" + then + declare + Program_Args : constant Argument_List_Access := + Argument_String_To_List + (Argv (12 .. Argv'Last)); + + begin + if And_Save then + Saved_Gnatbind := new String'(Program_Args.all (1).all); + else + Gnatbind := new String'(Program_Args.all (1).all); + end if; + + for J in 2 .. Program_Args.all'Last loop + Add_Switch + (Program_Args.all (J).all, Binder, And_Save => And_Save); + end loop; + end; + + elsif Argv'Length > 11 + and then Argv (1 .. 11) = "--GNATLINK=" + then + declare + Program_Args : constant Argument_List_Access := + Argument_String_To_List + (Argv (12 .. Argv'Last)); + begin + if And_Save then + Saved_Gnatlink := new String'(Program_Args.all (1).all); + else + Gnatlink := new String'(Program_Args.all (1).all); + end if; + + for J in 2 .. Program_Args.all'Last loop + Add_Switch (Program_Args.all (J).all, Linker); + end loop; + end; + + elsif Argv'Length >= 5 and then + Argv (1 .. 5) = "--RTS" + then + Add_Switch (Argv, Compiler, And_Save => And_Save); + Add_Switch (Argv, Binder, And_Save => And_Save); + + if Argv'Length <= 6 or else Argv (6) /= '=' then + Make_Failed ("missing path for --RTS"); + + else + -- Check that this is the first time we see this switch or + -- if it is not the first time, the same path is specified. + + if RTS_Specified = null then + RTS_Specified := new String'(Argv (7 .. Argv'Last)); + + elsif RTS_Specified.all /= Argv (7 .. Argv'Last) then + Make_Failed ("--RTS cannot be specified multiple times"); + end if; + + -- Valid --RTS switch + + No_Stdinc := True; + No_Stdlib := True; + RTS_Switch := True; + + declare + Src_Path_Name : constant String_Ptr := + Get_RTS_Search_Dir + (Argv (7 .. Argv'Last), Include); + + Lib_Path_Name : constant String_Ptr := + Get_RTS_Search_Dir + (Argv (7 .. Argv'Last), Objects); + + begin + if Src_Path_Name /= null + and then Lib_Path_Name /= null + then + -- Set RTS_*_Path_Name variables, so that correct direct- + -- ories will be set when Osint.Add_Default_Search_Dirs + -- is called later. + + RTS_Src_Path_Name := Src_Path_Name; + RTS_Lib_Path_Name := Lib_Path_Name; + + elsif Src_Path_Name = null + and then Lib_Path_Name = null + then + Make_Failed ("RTS path not valid: missing " & + "adainclude and adalib directories"); + + elsif Src_Path_Name = null then + Make_Failed ("RTS path not valid: missing adainclude " & + "directory"); + + elsif Lib_Path_Name = null then + Make_Failed ("RTS path not valid: missing adalib " & + "directory"); + end if; + end; + end if; + + elsif Argv'Length > Source_Info_Option'Length and then + Argv (1 .. Source_Info_Option'Length) = Source_Info_Option + then + Project_Tree.Source_Info_File_Name := + new String'(Argv (Source_Info_Option'Length + 1 .. Argv'Last)); + + elsif Argv'Length >= 8 and then + Argv (1 .. 8) = "--param=" + then + Add_Switch (Argv, Compiler, And_Save => And_Save); + Add_Switch (Argv, Linker, And_Save => And_Save); + + elsif Argv = Create_Map_File_Switch then + Map_File := new String'(""); + + elsif Argv'Length > Create_Map_File_Switch'Length + 1 + and then + Argv (1 .. Create_Map_File_Switch'Length) = Create_Map_File_Switch + and then + Argv (Create_Map_File_Switch'Length + 1) = '=' + then + Map_File := + new String' + (Argv (Create_Map_File_Switch'Length + 2 .. Argv'Last)); + + else + Scan_Make_Switches (Project_Node_Tree, Argv, Success); + end if; + + -- If we have seen a regular switch process it + + elsif Argv (1) = '-' then + if Argv'Length = 1 then + Make_Failed ("switch character cannot be followed by a blank"); + + -- Incorrect switches that should start with "--" + + elsif (Argv'Length > 5 and then Argv (1 .. 5) = "-RTS=") + or else (Argv'Length > 5 and then Argv (1 .. 5) = "-GCC=") + or else (Argv'Length > 8 and then Argv (1 .. 7) = "-param=") + or else (Argv'Length > 10 and then Argv (1 .. 10) = "-GNATLINK=") + or else (Argv'Length > 10 and then Argv (1 .. 10) = "-GNATBIND=") + then + Make_Failed ("option " & Argv & " should start with '--'"); + + -- -I- + + elsif Argv (2 .. Argv'Last) = "I-" then + Look_In_Primary_Dir := False; + + -- Forbid -?- or -??- where ? is any character + + elsif (Argv'Length = 3 and then Argv (3) = '-') + or else (Argv'Length = 4 and then Argv (4) = '-') + then + Make_Failed + ("trailing ""-"" at the end of " & Argv & " forbidden."); + + -- -Idir + + elsif Argv (2) = 'I' then + Add_Source_Search_Dir (Argv (3 .. Argv'Last), And_Save); + Add_Library_Search_Dir (Argv (3 .. Argv'Last), And_Save); + Add_Switch (Argv, Compiler, And_Save => And_Save); + Add_Switch (Argv, Binder, And_Save => And_Save); + + -- -aIdir (to gcc this is like a -I switch) + + elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aI" then + Add_Source_Search_Dir (Argv (4 .. Argv'Last), And_Save); + Add_Switch + ("-I" & Argv (4 .. Argv'Last), Compiler, And_Save => And_Save); + Add_Switch (Argv, Binder, And_Save => And_Save); + + -- -aOdir + + elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aO" then + Add_Library_Search_Dir (Argv (4 .. Argv'Last), And_Save); + Add_Switch (Argv, Binder, And_Save => And_Save); + + -- -aLdir (to gnatbind this is like a -aO switch) + + elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aL" then + Mark_Directory (Argv (4 .. Argv'Last), Ada_Lib_Dir, And_Save); + Add_Library_Search_Dir (Argv (4 .. Argv'Last), And_Save); + Add_Switch + ("-aO" & Argv (4 .. Argv'Last), Binder, And_Save => And_Save); + + -- -aamp_target=... + + elsif Argv'Length >= 13 and then Argv (2 .. 13) = "aamp_target=" then + Add_Switch (Argv, Compiler, And_Save => And_Save); + + -- Set the aamp_target environment variable so that the binder and + -- linker will use the proper target library. This is consistent + -- with how things work when -aamp_target is passed on the command + -- line to gnaampmake. + + Setenv ("aamp_target", Argv (14 .. Argv'Last)); + + -- -Adir (to gnatbind this is like a -aO switch, to gcc like a -I) + + elsif Argv (2) = 'A' then + Mark_Directory (Argv (3 .. Argv'Last), Ada_Lib_Dir, And_Save); + Add_Source_Search_Dir (Argv (3 .. Argv'Last), And_Save); + Add_Library_Search_Dir (Argv (3 .. Argv'Last), And_Save); + Add_Switch + ("-I" & Argv (3 .. Argv'Last), Compiler, And_Save => And_Save); + Add_Switch + ("-aO" & Argv (3 .. Argv'Last), Binder, And_Save => And_Save); + + -- -Ldir + + elsif Argv (2) = 'L' then + Add_Switch (Argv, Linker, And_Save => And_Save); + + -- For -gxxx, -pg, -mxxx, -fxxx, -Oxxx, pass the switch to both the + -- compiler and the linker (except for -gnatxxx which is only for the + -- compiler). Some of the -mxxx (for example -m64) and -fxxx (for + -- example -ftest-coverage for gcov) need to be used when compiling + -- the binder generated files, and using all these gcc switches for + -- them should not be a problem. Pass -Oxxx to the linker for LTO. + + elsif + (Argv (2) = 'g' and then (Argv'Last < 5 + or else Argv (2 .. 5) /= "gnat")) + or else Argv (2 .. Argv'Last) = "pg" + or else (Argv (2) = 'm' and then Argv'Last > 2) + or else (Argv (2) = 'f' and then Argv'Last > 2) + or else Argv (2) = 'O' + then + Add_Switch (Argv, Compiler, And_Save => And_Save); + Add_Switch (Argv, Linker, And_Save => And_Save); + + -- The following condition has to be kept synchronized with + -- the Process_Multilib one. + + if Argv (2) = 'm' + and then Argv /= "-mieee" + then + N_M_Switch := N_M_Switch + 1; + end if; + + -- -C= + + elsif Argv'Last > 2 and then Argv (2) = 'C' then + if And_Save then + if Argv (3) /= '=' or else Argv'Last <= 3 then + Make_Failed ("illegal switch " & Argv); + end if; + + Gnatmake_Mapping_File := new String'(Argv (4 .. Argv'Last)); + end if; + + -- -D + + elsif Argv'Last = 2 and then Argv (2) = 'D' then + if Project_File_Name /= null then + Make_Failed + ("-D cannot be used in conjunction with a project file"); + + else + Scan_Make_Switches (Project_Node_Tree, Argv, Success); + end if; + + -- -d + + elsif Argv (2) = 'd' and then Argv'Last = 2 then + Display_Compilation_Progress := True; + + -- -i + + elsif Argv'Last = 2 and then Argv (2) = 'i' then + if Project_File_Name /= null then + Make_Failed + ("-i cannot be used in conjunction with a project file"); + else + Scan_Make_Switches (Project_Node_Tree, Argv, Success); + end if; + + -- -j (need to save the result) + + elsif Argv (2) = 'j' then + Scan_Make_Switches (Project_Node_Tree, Argv, Success); + + if And_Save then + Saved_Maximum_Processes := Maximum_Processes; + end if; + + -- -m + + elsif Argv (2) = 'm' and then Argv'Last = 2 then + Minimal_Recompilation := True; + + -- -u + + elsif Argv (2) = 'u' and then Argv'Last = 2 then + Unique_Compile := True; + Compile_Only := True; + Do_Bind_Step := False; + Do_Link_Step := False; + + -- -U + + elsif Argv (2) = 'U' + and then Argv'Last = 2 + then + Unique_Compile_All_Projects := True; + Unique_Compile := True; + Compile_Only := True; + Do_Bind_Step := False; + Do_Link_Step := False; + + -- -Pprj or -P prj (only once, and only on the command line) + + elsif Argv (2) = 'P' then + if Project_File_Name /= null then + Make_Failed ("cannot have several project files specified"); + + elsif Object_Directory_Path /= null then + Make_Failed + ("-D cannot be used in conjunction with a project file"); + + elsif In_Place_Mode then + Make_Failed + ("-i cannot be used in conjunction with a project file"); + + elsif not And_Save then + + -- It could be a tool other than gnatmake (e.g. gnatdist) + -- or a -P switch inside a project file. + + Fail + ("either the tool is not ""project-aware"" or " & + "a project file is specified inside a project file"); + + elsif Argv'Last = 2 then + + -- -P is used alone: the project file name is the next option + + Project_File_Name_Present := True; + + else + Project_File_Name := new String'(Argv (3 .. Argv'Last)); + end if; + + -- -vPx (verbosity of the parsing of the project files) + + elsif Argv'Last = 4 + and then Argv (2 .. 3) = "vP" + and then Argv (4) in '0' .. '2' + then + if And_Save then + case Argv (4) is + when '0' => + Current_Verbosity := Prj.Default; + when '1' => + Current_Verbosity := Prj.Medium; + when '2' => + Current_Verbosity := Prj.High; + when others => + null; + end case; + end if; + + -- -Xext=val (External assignment) + + elsif Argv (2) = 'X' + and then Is_External_Assignment (Project_Node_Tree, Argv) + then + -- Is_External_Assignment has side effects when it returns True + + null; + + -- If -gnath is present, then generate the usage information right + -- now and do not pass this option on to the compiler calls. + + elsif Argv = "-gnath" then + Usage; + + -- If -gnatc is specified, make sure the bind and link steps are not + -- executed. + + elsif Argv'Length >= 6 and then Argv (2 .. 6) = "gnatc" then + + -- If -gnatc is specified, make sure the bind and link steps are + -- not executed. + + Add_Switch (Argv, Compiler, And_Save => And_Save); + Operating_Mode := Check_Semantics; + Check_Object_Consistency := False; + Compile_Only := True; + Do_Bind_Step := False; + Do_Link_Step := False; + + elsif Argv (2 .. Argv'Last) = "nostdlib" then + + -- Pass -nstdlib to gnatbind and gnatlink + + No_Stdlib := True; + Add_Switch (Argv, Binder, And_Save => And_Save); + Add_Switch (Argv, Linker, And_Save => And_Save); + + elsif Argv (2 .. Argv'Last) = "nostdinc" then + + -- Pass -nostdinc to the Compiler and to gnatbind + + No_Stdinc := True; + Add_Switch (Argv, Compiler, And_Save => And_Save); + Add_Switch (Argv, Binder, And_Save => And_Save); + + -- All other switches are processed by Scan_Make_Switches. If the + -- call returns with Gnatmake_Switch_Found = False, then the switch + -- is passed to the compiler. + + else + Scan_Make_Switches + (Project_Node_Tree, Argv, Gnatmake_Switch_Found); + + if not Gnatmake_Switch_Found then + Add_Switch (Argv, Compiler, And_Save => And_Save); + end if; + end if; + + -- If not a switch it must be a file name + + else + if And_Save then + Main_On_Command_Line := True; + end if; + + Add_File (Argv); + Mains.Add_Main (Argv); + end if; + end Scan_Make_Arg; + + ----------------- + -- Switches_Of -- + ----------------- + + function Switches_Of + (Source_File : File_Name_Type; + Source_File_Name : String; + Source_Index : Int; + Project : Project_Id; + In_Package : Package_Id; + Allow_ALI : Boolean) return Variable_Value + is + Lang : constant Language_Ptr := Get_Language_From_Name (Project, "ada"); + + Switches : Variable_Value; + + Defaults : constant Array_Element_Id := + Prj.Util.Value_Of + (Name => Name_Default_Switches, + In_Arrays => + Project_Tree.Packages.Table + (In_Package).Decl.Arrays, + In_Tree => Project_Tree); + + Switches_Array : constant Array_Element_Id := + Prj.Util.Value_Of + (Name => Name_Switches, + In_Arrays => + Project_Tree.Packages.Table + (In_Package).Decl.Arrays, + In_Tree => Project_Tree); + + begin + -- First, try Switches () + + Switches := + Prj.Util.Value_Of + (Index => Name_Id (Source_File), + Src_Index => Source_Index, + In_Array => Switches_Array, + In_Tree => Project_Tree, + Allow_Wildcards => True); + + -- Check also without the suffix + + if Switches = Nil_Variable_Value + and then Lang /= null + then + declare + Naming : Lang_Naming_Data renames Lang.Config.Naming_Data; + Name : String (1 .. Source_File_Name'Length + 3); + Last : Positive := Source_File_Name'Length; + Spec_Suffix : String := Get_Name_String (Naming.Spec_Suffix); + Body_Suffix : String := Get_Name_String (Naming.Body_Suffix); + Truncated : Boolean := False; + + begin + Canonical_Case_File_Name (Spec_Suffix); + Canonical_Case_File_Name (Body_Suffix); + Name (1 .. Last) := Source_File_Name; + + if Last > Body_Suffix'Length + and then Name (Last - Body_Suffix'Length + 1 .. Last) = + Body_Suffix + then + Truncated := True; + Last := Last - Body_Suffix'Length; + end if; + + if not Truncated + and then Last > Spec_Suffix'Length + and then Name (Last - Spec_Suffix'Length + 1 .. Last) = + Spec_Suffix + then + Truncated := True; + Last := Last - Spec_Suffix'Length; + end if; + + if Truncated then + Name_Len := 0; + Add_Str_To_Name_Buffer (Name (1 .. Last)); + Switches := + Prj.Util.Value_Of + (Index => Name_Find, + Src_Index => 0, + In_Array => Switches_Array, + In_Tree => Project_Tree, + Allow_Wildcards => True); + + if Switches = Nil_Variable_Value and then Allow_ALI then + Last := Source_File_Name'Length; + + while Name (Last) /= '.' loop + Last := Last - 1; + end loop; + + Name_Len := 0; + Add_Str_To_Name_Buffer (Name (1 .. Last)); + Add_Str_To_Name_Buffer ("ali"); + + Switches := + Prj.Util.Value_Of + (Index => Name_Find, + Src_Index => 0, + In_Array => Switches_Array, + In_Tree => Project_Tree); + end if; + end if; + end; + end if; + + -- Next, try Switches ("Ada") + + if Switches = Nil_Variable_Value then + Switches := + Prj.Util.Value_Of + (Index => Name_Ada, + Src_Index => 0, + In_Array => Switches_Array, + In_Tree => Project_Tree, + Force_Lower_Case_Index => True); + + if Switches /= Nil_Variable_Value then + Switch_May_Be_Passed_To_The_Compiler := False; + end if; + end if; + + -- Next, try Switches (others) + + if Switches = Nil_Variable_Value then + Switches := + Prj.Util.Value_Of + (Index => All_Other_Names, + Src_Index => 0, + In_Array => Switches_Array, + In_Tree => Project_Tree); + + if Switches /= Nil_Variable_Value then + Switch_May_Be_Passed_To_The_Compiler := False; + end if; + end if; + + -- And finally, Default_Switches ("Ada") + + if Switches = Nil_Variable_Value then + Switches := + Prj.Util.Value_Of + (Index => Name_Ada, + Src_Index => 0, + In_Array => Defaults, + In_Tree => Project_Tree); + end if; + + return Switches; + end Switches_Of; + + ----------- + -- Usage -- + ----------- + + procedure Usage is + begin + if Usage_Needed then + Usage_Needed := False; + Makeusg; + end if; + end Usage; + +begin + -- Make sure that in case of failure, the temp files will be deleted + + Prj.Com.Fail := Make_Failed'Access; + MLib.Fail := Make_Failed'Access; + Makeutl.Do_Fail := Make_Failed'Access; +end Make; diff --git a/gcc/ada/make.ads b/gcc/ada/make.ads new file mode 100644 index 000000000..2769df3ac --- /dev/null +++ b/gcc/ada/make.ads @@ -0,0 +1,35 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M A K E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- The following package implements the facilities to recursively +-- compile (a la make), bind and/or link a set of sources. + +package Make is + + procedure Gnatmake; + -- The driver of gnatmake. For more information on gnatmake and its + -- precise usage please refer to the gnat documentation. + +end Make; diff --git a/gcc/ada/makeusg.adb b/gcc/ada/makeusg.adb new file mode 100644 index 000000000..bc3438727 --- /dev/null +++ b/gcc/ada/makeusg.adb @@ -0,0 +1,377 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M A K E U S G -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Makeutl; +with Osint; use Osint; +with Output; use Output; +with Usage; + +procedure Makeusg is + +-- Start of processing for Makeusg + +begin + -- Usage line + + Write_Str ("Usage: "); + Osint.Write_Program_Name; + Write_Str (" opts name "); + Write_Str ("{[-cargs opts] [-bargs opts] [-largs opts] [-margs opts]}"); + Write_Eol; + Write_Eol; + Write_Str (" name is one or more file name from which you"); + Write_Str (" can omit the .adb or .ads suffix"); + Write_Eol; + Write_Eol; + + -- GNATMAKE switches + + Write_Str ("gnatmake switches:"); + Write_Eol; + + -- Line for -a + + Write_Str (" -a Consider all files, even readonly ali files"); + Write_Eol; + + -- Line for -b + + Write_Str (" -b Bind only"); + Write_Eol; + + -- Line for -B + + Write_Str (" -B Build, bind and link full project"); + Write_Eol; + + -- Line for -c + + Write_Str (" -c Compile only"); + Write_Eol; + + -- Line for -C + + Write_Str (" -C Cache source mappings: " & + "invoke compiler with temp mapping file"); + Write_Eol; + + -- Line for -C= + + Write_Str (" -C=mapp Cache source mappings: " & + "invoke compiler with mapping file mapp"); + Write_Eol; + + -- Line for -D + + Write_Str (" -D dir Specify dir as the object directory"); + Write_Eol; + + -- Line for -eI + + Write_Str (" -eI Index of unit in multi-unit source file"); + Write_Eol; + + -- Line for -eL + + Write_Str (" -eL Follow symbolic links when processing " & + "project files"); + Write_Eol; + + -- Line for -eS + + Write_Str (" -eS Echo commands to stdout instead of stderr"); + Write_Eol; + + -- Line for -f + + Write_Str (" -f Force recompilations of non predefined units"); + Write_Eol; + + -- Line for -F + + Write_Str (" -F Full project path name in brief error messages"); + Write_Eol; + + -- Line for -i + + Write_Str (" -i In place. Replace existing ali file, "); + Write_Str ("or put it with source"); + Write_Eol; + + -- Line for -jnnn + + Write_Str (" -jnum Use nnn processes to compile"); + Write_Eol; + + -- Line for -k + + Write_Str (" -k Keep going after compilation errors"); + Write_Eol; + + -- Line for -l + + Write_Str (" -l Link only"); + Write_Eol; + + -- Line for -m + + Write_Str (" -m Minimal recompilation"); + Write_Eol; + + -- Line for -M + + Write_Str (" -M List object file dependences for Makefile"); + Write_Eol; + + -- Line for -n + + Write_Str (" -n Check objects up to date, output next file "); + Write_Str ("to compile if not"); + Write_Eol; + + -- Line for -o + + Write_Str (" -o name Choose an alternate executable name"); + Write_Eol; + + -- Line for -p + + Write_Str (" -p Create missing obj, lib and exec dirs"); + Write_Eol; + + -- Line for -P + + Write_Str (" -Pproj Use GNAT Project File proj"); + Write_Eol; + + -- Line for -q + + Write_Str (" -q Be quiet/terse"); + Write_Eol; + + -- Line for -R + + Write_Str (" -R Do not use a run_path_option when linking"); + Write_Eol; + + -- Line for -s + + Write_Str (" -s Recompile if compiler switches have changed"); + Write_Eol; + + -- Line for -u + + Write_Str (" -u Unique compilation, only compile the given files"); + Write_Eol; + + -- Line for -U + + Write_Str (" -U Unique compilation for all sources of all projects"); + Write_Eol; + + -- Line for -v + + Write_Str (" -v Display reasons for all (re)compilations"); + Write_Eol; + + -- Line for -vl + + Write_Str (" -vl Verbose output (low verbosity)"); + Write_Eol; + + -- Line for -vm + + Write_Str (" -vm Verbose output (medium verbosity)"); + Write_Eol; + + -- Line for -vh + + Write_Str (" -vh Equivalent to -v (high verbosity)"); + Write_Eol; + + -- Line for -vPx + + Write_Str (" -vPx Specify verbosity when parsing GNAT Project Files"); + Write_Eol; + + -- Line for -we + + Write_Str (" -we Treat all warnings as errors"); + Write_Eol; + + -- Line for -wn + + Write_Str (" -wn Normal warning mode (cancels -we/-ws)"); + Write_Eol; + + -- Line for -ws + + Write_Str (" -ws Suppress all warnings"); + Write_Eol; + + -- Line for -x + + Write_Str (" -x " & + "Allow compilation of needed units external to the projects"); + Write_Eol; + + -- Line for -X + + Write_Str (" -Xnm=val Specify an external reference for GNAT " & + "Project Files"); + Write_Eol; + + -- Line for -z + + Write_Str (" -z No main subprogram (zero main)"); + Write_Eol; + Write_Eol; + + Write_Str (" --GCC=command Use this gcc command"); + Write_Eol; + + Write_Str (" --GNATBIND=command Use this gnatbind command"); + Write_Eol; + + Write_Str (" --GNATLINK=command Use this gnatlink command"); + Write_Eol; + Write_Eol; + + -- Source and Library search path switches + + Write_Str ("Project, Source and Library search path switches:"); + Write_Eol; + + -- Line for -aP + + Write_Str (" -aPdir Add directory dir to project search path"); + Write_Eol; + + -- Line for -aL + + Write_Str (" -aLdir Skip missing library sources if ali in dir"); + Write_Eol; + + -- Line for -A + + Write_Str (" -Adir like -aLdir -aIdir"); + Write_Eol; + + -- Line for -aO switch + + Write_Str (" -aOdir Specify library/object files search path"); + Write_Eol; + + -- Line for -aI switch + + Write_Str (" -aIdir Specify source files search path"); + Write_Eol; + + -- Line for -I switch + + Write_Str (" -Idir Like -aIdir -aOdir"); + Write_Eol; + + -- Line for -I- switch + + Write_Str (" -I- Don't look for sources & library files"); + Write_Str (" in the default directory"); + Write_Eol; + + -- Line for -L + + Write_Str (" -Ldir Look for program libraries also in dir"); + Write_Eol; + + -- Line for -nostdinc + + Write_Str (" -nostdinc Don't look for sources"); + Write_Str (" in the system default directory"); + Write_Eol; + + -- Line for -nostdlib + + Write_Str (" -nostdlib Don't look for library files"); + Write_Str (" in the system default directory"); + Write_Eol; + + -- Line for --RTS + + Write_Str (" --RTS=dir specify the default source and object search" + & " path"); + Write_Eol; + + -- Line for --subdirs= + + Write_Str (" --subdirs=dir real obj/lib/exec dirs are subdirs"); + Write_Eol; + + -- Line for --source-info= + + Write_Str (" "); + Write_Str (Makeutl.Source_Info_Option); + Write_Str ("file specify a source info file"); + Write_Eol; + + -- Line for --unchecked-shared-lib-imports + + Write_Str (" "); + Write_Str (Makeutl.Unchecked_Shared_Lib_Imports); + Write_Eol; + Write_Str (" Allow shared libraries to import static libraries"); + Write_Eol; + Write_Eol; + + -- General Compiler, Binder, Linker switches + + Write_Str ("To pass an arbitrary switch to the Compiler, "); + Write_Str ("Binder or Linker:"); + Write_Eol; + + -- Line for -cargs + + Write_Str (" -cargs opts opts are passed to the compiler"); + Write_Eol; + + -- Line for -bargs + + Write_Str (" -bargs opts opts are passed to the binder"); + Write_Eol; + + -- Line for -largs + + Write_Str (" -largs opts opts are passed to the linker"); + Write_Eol; + + -- Line for -margs + + Write_Str (" -margs opts opts are passed to gnatmake"); + Write_Eol; + + -- Add usage information for gcc + + Usage; + +end Makeusg; diff --git a/gcc/ada/makeusg.ads b/gcc/ada/makeusg.ads new file mode 100644 index 000000000..197a18e46 --- /dev/null +++ b/gcc/ada/makeusg.ads @@ -0,0 +1,29 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M A K E U S G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Procedure to output usage information for gnatmake + +procedure Makeusg; +-- Output gnatmake usage information diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb new file mode 100644 index 000000000..1ac84a2b3 --- /dev/null +++ b/gcc/ada/makeutl.adb @@ -0,0 +1,1210 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M A K E U T L -- +-- -- +-- B o d y -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with ALI; use ALI; +with Debug; +with Fname; +with Hostparm; +with Osint; use Osint; +with Output; use Output; +with Opt; use Opt; +with Prj.Ext; +with Prj.Util; +with Snames; use Snames; +with Table; +with Tempdir; + +with Ada.Command_Line; use Ada.Command_Line; + +with GNAT.Case_Util; use GNAT.Case_Util; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.HTable; + +package body Makeutl is + + type Mark_Key is record + File : File_Name_Type; + Index : Int; + end record; + -- Identify either a mono-unit source (when Index = 0) or a specific unit + -- (index = 1's origin index of unit) in a multi-unit source. + + -- There follow many global undocumented declarations, comments needed ??? + + Max_Mask_Num : constant := 2048; + + subtype Mark_Num is Union_Id range 0 .. Max_Mask_Num - 1; + + function Hash (Key : Mark_Key) return Mark_Num; + + package Marks is new GNAT.HTable.Simple_HTable + (Header_Num => Mark_Num, + Element => Boolean, + No_Element => False, + Key => Mark_Key, + Hash => Hash, + Equal => "="); + -- A hash table to keep tracks of the marked units + + type Linker_Options_Data is record + Project : Project_Id; + Options : String_List_Id; + end record; + + Linker_Option_Initial_Count : constant := 20; + + Linker_Options_Buffer : String_List_Access := + new String_List (1 .. Linker_Option_Initial_Count); + + Last_Linker_Option : Natural := 0; + + package Linker_Opts is new Table.Table ( + Table_Component_Type => Linker_Options_Data, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Make.Linker_Opts"); + + procedure Add_Linker_Option (Option : String); + + --------- + -- Add -- + --------- + + procedure Add + (Option : String_Access; + To : in out String_List_Access; + Last : in out Natural) + is + begin + if Last = To'Last then + declare + New_Options : constant String_List_Access := + new String_List (1 .. To'Last * 2); + + begin + New_Options (To'Range) := To.all; + + -- Set all elements of the original options to null to avoid + -- deallocation of copies. + + To.all := (others => null); + + Free (To); + To := New_Options; + end; + end if; + + Last := Last + 1; + To (Last) := Option; + end Add; + + procedure Add + (Option : String; + To : in out String_List_Access; + Last : in out Natural) + is + begin + Add (Option => new String'(Option), To => To, Last => Last); + end Add; + + ----------------------- + -- Add_Linker_Option -- + ----------------------- + + procedure Add_Linker_Option (Option : String) is + begin + if Option'Length > 0 then + if Last_Linker_Option = Linker_Options_Buffer'Last then + declare + New_Buffer : constant String_List_Access := + new String_List + (1 .. Linker_Options_Buffer'Last + + Linker_Option_Initial_Count); + begin + New_Buffer (Linker_Options_Buffer'Range) := + Linker_Options_Buffer.all; + Linker_Options_Buffer.all := (others => null); + Free (Linker_Options_Buffer); + Linker_Options_Buffer := New_Buffer; + end; + end if; + + Last_Linker_Option := Last_Linker_Option + 1; + Linker_Options_Buffer (Last_Linker_Option) := new String'(Option); + end if; + end Add_Linker_Option; + + ------------------------- + -- Base_Name_Index_For -- + ------------------------- + + function Base_Name_Index_For + (Main : String; + Main_Index : Int; + Index_Separator : Character) return File_Name_Type + is + Result : File_Name_Type; + + begin + Name_Len := 0; + Add_Str_To_Name_Buffer (Base_Name (Main)); + + -- Remove the extension, if any, that is the last part of the base name + -- starting with a dot and following some characters. + + for J in reverse 2 .. Name_Len loop + if Name_Buffer (J) = '.' then + Name_Len := J - 1; + exit; + end if; + end loop; + + -- Add the index info, if index is different from 0 + + if Main_Index > 0 then + Add_Char_To_Name_Buffer (Index_Separator); + + declare + Img : constant String := Main_Index'Img; + begin + Add_Str_To_Name_Buffer (Img (2 .. Img'Last)); + end; + end if; + + Result := Name_Find; + return Result; + end Base_Name_Index_For; + + ------------------------------ + -- Check_Source_Info_In_ALI -- + ------------------------------ + + function Check_Source_Info_In_ALI + (The_ALI : ALI_Id; + Tree : Project_Tree_Ref) return Boolean + is + Unit_Name : Name_Id; + + begin + -- Loop through units + + for U in ALIs.Table (The_ALI).First_Unit .. + ALIs.Table (The_ALI).Last_Unit + loop + -- Check if the file name is one of the source of the unit + + Get_Name_String (Units.Table (U).Uname); + Name_Len := Name_Len - 2; + Unit_Name := Name_Find; + + if File_Not_A_Source_Of (Unit_Name, Units.Table (U).Sfile) then + return False; + end if; + + -- Loop to do same check for each of the withed units + + for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop + declare + WR : ALI.With_Record renames Withs.Table (W); + + begin + if WR.Sfile /= No_File then + Get_Name_String (WR.Uname); + Name_Len := Name_Len - 2; + Unit_Name := Name_Find; + + if File_Not_A_Source_Of (Unit_Name, WR.Sfile) then + return False; + end if; + end if; + end; + end loop; + end loop; + + -- Loop to check subunits and replaced sources + + for D in ALIs.Table (The_ALI).First_Sdep .. + ALIs.Table (The_ALI).Last_Sdep + loop + declare + SD : Sdep_Record renames Sdep.Table (D); + + begin + Unit_Name := SD.Subunit_Name; + + if Unit_Name = No_Name then + -- Check if this source file has been replaced by a source with + -- a different file name. + + if Tree /= null and then Tree.Replaced_Source_Number > 0 then + declare + Replacement : constant File_Name_Type := + Replaced_Source_HTable.Get + (Tree.Replaced_Sources, SD.Sfile); + + begin + if Replacement /= No_File then + if Verbose_Mode then + Write_Line + ("source file" & + Get_Name_String (SD.Sfile) & + " has been replaced by " & + Get_Name_String (Replacement)); + end if; + + return False; + end if; + end; + end if; + + else + -- For separates, the file is no longer associated with the + -- unit ("proc-sep.adb" is not associated with unit "proc.sep") + -- so we need to check whether the source file still exists in + -- the source tree: it will if it matches the naming scheme + -- (and then will be for the same unit). + + if Find_Source + (In_Tree => Project_Tree, + Project => No_Project, + Base_Name => SD.Sfile) = No_Source + then + -- If this is not a runtime file or if, when gnatmake switch + -- -a is used, we are not able to find this subunit in the + -- source directories, then recompilation is needed. + + if not Fname.Is_Internal_File_Name (SD.Sfile) + or else + (Check_Readonly_Files + and then Full_Source_Name (SD.Sfile) = No_File) + then + if Verbose_Mode then + Write_Line + ("While parsing ALI file, file " + & Get_Name_String (SD.Sfile) + & " is indicated as containing subunit " + & Get_Name_String (Unit_Name) + & " but this does not match what was found while" + & " parsing the project. Will recompile"); + end if; + + return False; + end if; + end if; + end if; + end; + end loop; + + return True; + end Check_Source_Info_In_ALI; + + -------------------------------- + -- Create_Binder_Mapping_File -- + -------------------------------- + + function Create_Binder_Mapping_File return Path_Name_Type is + Mapping_Path : Path_Name_Type := No_Path; + + Mapping_FD : File_Descriptor := Invalid_FD; + -- A File Descriptor for an eventual mapping file + + ALI_Unit : Unit_Name_Type := No_Unit_Name; + -- The unit name of an ALI file + + ALI_Name : File_Name_Type := No_File; + -- The file name of the ALI file + + ALI_Project : Project_Id := No_Project; + -- The project of the ALI file + + Bytes : Integer; + OK : Boolean := False; + Unit : Unit_Index; + + Status : Boolean; + -- For call to Close + + begin + Tempdir.Create_Temp_File (Mapping_FD, Mapping_Path); + Record_Temp_File (Project_Tree, Mapping_Path); + + if Mapping_FD /= Invalid_FD then + OK := True; + + -- Traverse all units + + Unit := Units_Htable.Get_First (Project_Tree.Units_HT); + while Unit /= No_Unit_Index loop + if Unit.Name /= No_Name then + + -- If there is a body, put it in the mapping + + if Unit.File_Names (Impl) /= No_Source + and then Unit.File_Names (Impl).Project /= No_Project + then + Get_Name_String (Unit.Name); + Add_Str_To_Name_Buffer ("%b"); + ALI_Unit := Name_Find; + ALI_Name := + Lib_File_Name (Unit.File_Names (Impl).Display_File); + ALI_Project := Unit.File_Names (Impl).Project; + + -- Otherwise, if there is a spec, put it in the mapping + + elsif Unit.File_Names (Spec) /= No_Source + and then Unit.File_Names (Spec).Project /= No_Project + then + Get_Name_String (Unit.Name); + Add_Str_To_Name_Buffer ("%s"); + ALI_Unit := Name_Find; + ALI_Name := + Lib_File_Name (Unit.File_Names (Spec).Display_File); + ALI_Project := Unit.File_Names (Spec).Project; + + else + ALI_Name := No_File; + end if; + + -- If we have something to put in the mapping then do it now. + -- However, if the project is extended, we don't put anything + -- in the mapping file, since we don't know where the ALI file + -- is: it might be in the extended project object directory as + -- well as in the extending project object directory. + + if ALI_Name /= No_File + and then ALI_Project.Extended_By = No_Project + and then ALI_Project.Extends = No_Project + then + -- First check if the ALI file exists. If it does not, do + -- not put the unit in the mapping file. + + declare + ALI : constant String := Get_Name_String (ALI_Name); + + begin + -- For library projects, use the library ALI directory, + -- for other projects, use the object directory. + + if ALI_Project.Library then + Get_Name_String + (ALI_Project.Library_ALI_Dir.Display_Name); + else + Get_Name_String + (ALI_Project.Object_Directory.Display_Name); + end if; + + if not + Is_Directory_Separator (Name_Buffer (Name_Len)) + then + Add_Char_To_Name_Buffer (Directory_Separator); + end if; + + Add_Str_To_Name_Buffer (ALI); + Add_Char_To_Name_Buffer (ASCII.LF); + + declare + ALI_Path_Name : constant String := + Name_Buffer (1 .. Name_Len); + + begin + if Is_Regular_File + (ALI_Path_Name (1 .. ALI_Path_Name'Last - 1)) + then + -- First line is the unit name + + Get_Name_String (ALI_Unit); + Add_Char_To_Name_Buffer (ASCII.LF); + Bytes := + Write + (Mapping_FD, + Name_Buffer (1)'Address, + Name_Len); + OK := Bytes = Name_Len; + + exit when not OK; + + -- Second line it the ALI file name + + Get_Name_String (ALI_Name); + Add_Char_To_Name_Buffer (ASCII.LF); + Bytes := + Write + (Mapping_FD, + Name_Buffer (1)'Address, + Name_Len); + OK := (Bytes = Name_Len); + + exit when not OK; + + -- Third line it the ALI path name + + Bytes := + Write + (Mapping_FD, + ALI_Path_Name (1)'Address, + ALI_Path_Name'Length); + OK := (Bytes = ALI_Path_Name'Length); + + -- If OK is False, it means we were unable to + -- write a line. No point in continuing with the + -- other units. + + exit when not OK; + end if; + end; + end; + end if; + end if; + + Unit := Units_Htable.Get_Next (Project_Tree.Units_HT); + end loop; + + Close (Mapping_FD, Status); + + OK := OK and Status; + end if; + + -- If the creation of the mapping file was successful, we add the switch + -- to the arguments of gnatbind. + + if OK then + return Mapping_Path; + + else + return No_Path; + end if; + end Create_Binder_Mapping_File; + + ----------------- + -- Create_Name -- + ----------------- + + function Create_Name (Name : String) return File_Name_Type is + begin + Name_Len := 0; + Add_Str_To_Name_Buffer (Name); + return Name_Find; + end Create_Name; + + function Create_Name (Name : String) return Name_Id is + begin + Name_Len := 0; + Add_Str_To_Name_Buffer (Name); + return Name_Find; + end Create_Name; + + function Create_Name (Name : String) return Path_Name_Type is + begin + Name_Len := 0; + Add_Str_To_Name_Buffer (Name); + return Name_Find; + end Create_Name; + + ---------------------- + -- Delete_All_Marks -- + ---------------------- + + procedure Delete_All_Marks is + begin + Marks.Reset; + end Delete_All_Marks; + + ---------------------------- + -- Executable_Prefix_Path -- + ---------------------------- + + function Executable_Prefix_Path return String is + Exec_Name : constant String := Command_Name; + + function Get_Install_Dir (S : String) return String; + -- S is the executable name preceded by the absolute or relative path, + -- e.g. "c:\usr\bin\gcc.exe". Returns the absolute directory where "bin" + -- lies (in the example "C:\usr"). If the executable is not in a "bin" + -- directory, return "". + + --------------------- + -- Get_Install_Dir -- + --------------------- + + function Get_Install_Dir (S : String) return String is + Exec : String := S; + Path_Last : Integer := 0; + + begin + for J in reverse Exec'Range loop + if Exec (J) = Directory_Separator then + Path_Last := J - 1; + exit; + end if; + end loop; + + if Path_Last >= Exec'First + 2 then + To_Lower (Exec (Path_Last - 2 .. Path_Last)); + end if; + + if Path_Last < Exec'First + 2 + or else Exec (Path_Last - 2 .. Path_Last) /= "bin" + or else (Path_Last - 3 >= Exec'First + and then Exec (Path_Last - 3) /= Directory_Separator) + then + return ""; + end if; + + return Normalize_Pathname + (Exec (Exec'First .. Path_Last - 4), + Resolve_Links => Opt.Follow_Links_For_Dirs) + & Directory_Separator; + end Get_Install_Dir; + + -- Beginning of Executable_Prefix_Path + + begin + -- For VMS, the path returned is always /gnu/ + + if Hostparm.OpenVMS then + return "/gnu/"; + end if; + + -- First determine if a path prefix was placed in front of the + -- executable name. + + for J in reverse Exec_Name'Range loop + if Exec_Name (J) = Directory_Separator then + return Get_Install_Dir (Exec_Name); + end if; + end loop; + + -- If we get here, the user has typed the executable name with no + -- directory prefix. + + declare + Path : String_Access := Locate_Exec_On_Path (Exec_Name); + begin + if Path = null then + return ""; + else + declare + Dir : constant String := Get_Install_Dir (Path.all); + begin + Free (Path); + return Dir; + end; + end if; + end; + end Executable_Prefix_Path; + + -------------------------- + -- File_Not_A_Source_Of -- + -------------------------- + + function File_Not_A_Source_Of + (Uname : Name_Id; + Sfile : File_Name_Type) return Boolean + is + Unit : constant Unit_Index := + Units_Htable.Get (Project_Tree.Units_HT, Uname); + + At_Least_One_File : Boolean := False; + + begin + if Unit /= No_Unit_Index then + for F in Unit.File_Names'Range loop + if Unit.File_Names (F) /= null then + At_Least_One_File := True; + if Unit.File_Names (F).File = Sfile then + return False; + end if; + end if; + end loop; + + if not At_Least_One_File then + + -- The unit was probably created initially for a separate unit + -- (which are initially created as IMPL when both suffixes are the + -- same). Later on, Override_Kind changed the type of the file, + -- and the unit is no longer valid in fact. + + return False; + end if; + + Verbose_Msg (Uname, "sources do not include ", Name_Id (Sfile)); + return True; + end if; + + return False; + end File_Not_A_Source_Of; + + ---------- + -- Hash -- + ---------- + + function Hash (Key : Mark_Key) return Mark_Num is + begin + return Union_Id (Key.File) mod Max_Mask_Num; + end Hash; + + ------------ + -- Inform -- + ------------ + + procedure Inform (N : File_Name_Type; Msg : String) is + begin + Inform (Name_Id (N), Msg); + end Inform; + + procedure Inform (N : Name_Id := No_Name; Msg : String) is + begin + Osint.Write_Program_Name; + + Write_Str (": "); + + if N /= No_Name then + Write_Str (""""); + + declare + Name : constant String := Get_Name_String (N); + begin + if Debug.Debug_Flag_F and then Is_Absolute_Path (Name) then + Write_Str (File_Name (Name)); + else + Write_Str (Name); + end if; + end; + + Write_Str (""" "); + end if; + + Write_Str (Msg); + Write_Eol; + end Inform; + + ---------------------------- + -- Is_External_Assignment -- + ---------------------------- + + function Is_External_Assignment + (Tree : Prj.Tree.Project_Node_Tree_Ref; + Argv : String) return Boolean + is + Start : Positive := 3; + Finish : Natural := Argv'Last; + + pragma Assert (Argv'First = 1); + pragma Assert (Argv (1 .. 2) = "-X"); + + begin + if Argv'Last < 5 then + return False; + + elsif Argv (3) = '"' then + if Argv (Argv'Last) /= '"' or else Argv'Last < 7 then + return False; + else + Start := 4; + Finish := Argv'Last - 1; + end if; + end if; + + return Prj.Ext.Check + (Tree => Tree, + Declaration => Argv (Start .. Finish)); + end Is_External_Assignment; + + --------------- + -- Is_Marked -- + --------------- + + function Is_Marked + (Source_File : File_Name_Type; + Index : Int := 0) return Boolean + is + begin + return Marks.Get (K => (File => Source_File, Index => Index)); + end Is_Marked; + + ----------------------------- + -- Linker_Options_Switches -- + ----------------------------- + + function Linker_Options_Switches + (Project : Project_Id; + In_Tree : Project_Tree_Ref) return String_List + is + procedure Recursive_Add (Proj : Project_Id; Dummy : in out Boolean); + -- The recursive routine used to add linker options + + ------------------- + -- Recursive_Add -- + ------------------- + + procedure Recursive_Add (Proj : Project_Id; Dummy : in out Boolean) is + pragma Unreferenced (Dummy); + + Linker_Package : Package_Id; + Options : Variable_Value; + + begin + Linker_Package := + Prj.Util.Value_Of + (Name => Name_Linker, + In_Packages => Proj.Decl.Packages, + In_Tree => In_Tree); + + Options := + Prj.Util.Value_Of + (Name => Name_Ada, + Index => 0, + Attribute_Or_Array_Name => Name_Linker_Options, + In_Package => Linker_Package, + In_Tree => In_Tree); + + -- If attribute is present, add the project with + -- the attribute to table Linker_Opts. + + if Options /= Nil_Variable_Value then + Linker_Opts.Increment_Last; + Linker_Opts.Table (Linker_Opts.Last) := + (Project => Proj, Options => Options.Values); + end if; + end Recursive_Add; + + procedure For_All_Projects is + new For_Every_Project_Imported (Boolean, Recursive_Add); + + Dummy : Boolean := False; + + -- Start of processing for Linker_Options_Switches + + begin + Linker_Opts.Init; + + For_All_Projects (Project, Dummy, Imported_First => True); + + Last_Linker_Option := 0; + + for Index in reverse 1 .. Linker_Opts.Last loop + declare + Options : String_List_Id; + Proj : constant Project_Id := + Linker_Opts.Table (Index).Project; + Option : Name_Id; + Dir_Path : constant String := + Get_Name_String (Proj.Directory.Name); + + begin + Options := Linker_Opts.Table (Index).Options; + while Options /= Nil_String loop + Option := In_Tree.String_Elements.Table (Options).Value; + Get_Name_String (Option); + + -- Do not consider empty linker options + + if Name_Len /= 0 then + Add_Linker_Option (Name_Buffer (1 .. Name_Len)); + + -- Object files and -L switches specified with relative + -- paths must be converted to absolute paths. + + Test_If_Relative_Path + (Switch => Linker_Options_Buffer (Last_Linker_Option), + Parent => Dir_Path, + Including_L_Switch => True); + end if; + + Options := In_Tree.String_Elements.Table (Options).Next; + end loop; + end; + end loop; + + return Linker_Options_Buffer (1 .. Last_Linker_Option); + end Linker_Options_Switches; + + ----------- + -- Mains -- + ----------- + + package body Mains is + + type File_And_Loc is record + File_Name : File_Name_Type; + Index : Int := 0; + Location : Source_Ptr := No_Location; + end record; + + package Names is new Table.Table + (Table_Component_Type => File_And_Loc, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Makeutl.Mains.Names"); + -- The table that stores the mains + + Current : Natural := 0; + -- The index of the last main retrieved from the table + + -------------- + -- Add_Main -- + -------------- + + procedure Add_Main (Name : String) is + begin + Name_Len := 0; + Add_Str_To_Name_Buffer (Name); + Names.Increment_Last; + Names.Table (Names.Last) := (Name_Find, 0, No_Location); + end Add_Main; + + ------------ + -- Delete -- + ------------ + + procedure Delete is + begin + Names.Set_Last (0); + Mains.Reset; + end Delete; + + --------------- + -- Get_Index -- + --------------- + + function Get_Index return Int is + begin + if Current in Names.First .. Names.Last then + return Names.Table (Current).Index; + else + return 0; + end if; + end Get_Index; + + ------------------ + -- Get_Location -- + ------------------ + + function Get_Location return Source_Ptr is + begin + if Current in Names.First .. Names.Last then + return Names.Table (Current).Location; + else + return No_Location; + end if; + end Get_Location; + + --------------- + -- Next_Main -- + --------------- + + function Next_Main return String is + begin + if Current >= Names.Last then + return ""; + else + Current := Current + 1; + return Get_Name_String (Names.Table (Current).File_Name); + end if; + end Next_Main; + + --------------------- + -- Number_Of_Mains -- + --------------------- + + function Number_Of_Mains return Natural is + begin + return Names.Last; + end Number_Of_Mains; + + ----------- + -- Reset -- + ----------- + + procedure Reset is + begin + Current := 0; + end Reset; + + --------------- + -- Set_Index -- + --------------- + + procedure Set_Index (Index : Int) is + begin + if Names.Last > 0 then + Names.Table (Names.Last).Index := Index; + end if; + end Set_Index; + + ------------------ + -- Set_Location -- + ------------------ + + procedure Set_Location (Location : Source_Ptr) is + begin + if Names.Last > 0 then + Names.Table (Names.Last).Location := Location; + end if; + end Set_Location; + + ----------------- + -- Update_Main -- + ----------------- + + procedure Update_Main (Name : String) is + begin + if Current in Names.First .. Names.Last then + Name_Len := 0; + Add_Str_To_Name_Buffer (Name); + Names.Table (Current).File_Name := Name_Find; + end if; + end Update_Main; + end Mains; + + ---------- + -- Mark -- + ---------- + + procedure Mark (Source_File : File_Name_Type; Index : Int := 0) is + begin + Marks.Set (K => (File => Source_File, Index => Index), E => True); + end Mark; + + ----------------------- + -- Path_Or_File_Name -- + ----------------------- + + function Path_Or_File_Name (Path : Path_Name_Type) return String is + Path_Name : constant String := Get_Name_String (Path); + begin + if Debug.Debug_Flag_F then + return File_Name (Path_Name); + else + return Path_Name; + end if; + end Path_Or_File_Name; + + --------------------------- + -- Test_If_Relative_Path -- + --------------------------- + + procedure Test_If_Relative_Path + (Switch : in out String_Access; + Parent : String; + Including_L_Switch : Boolean := True; + Including_Non_Switch : Boolean := True; + Including_RTS : Boolean := False) + is + begin + if Switch /= null then + declare + Sw : String (1 .. Switch'Length); + Start : Positive; + + begin + Sw := Switch.all; + + if Sw (1) = '-' then + if Sw'Length >= 3 + and then (Sw (2) = 'A' + or else Sw (2) = 'I' + or else (Including_L_Switch and then Sw (2) = 'L')) + then + Start := 3; + + if Sw = "-I-" then + return; + end if; + + elsif Sw'Length >= 4 + and then (Sw (2 .. 3) = "aL" + or else Sw (2 .. 3) = "aO" + or else Sw (2 .. 3) = "aI") + then + Start := 4; + + elsif Including_RTS + and then Sw'Length >= 7 + and then Sw (2 .. 6) = "-RTS=" + then + Start := 7; + + else + return; + end if; + + -- Because relative path arguments to --RTS= may be relative + -- to the search directory prefix, those relative path + -- arguments are converted only when they include directory + -- information. + + if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then + if Parent'Length = 0 then + Do_Fail + ("relative search path switches (""" + & Sw + & """) are not allowed"); + + elsif Including_RTS then + for J in Start .. Sw'Last loop + if Sw (J) = Directory_Separator then + Switch := + new String' + (Sw (1 .. Start - 1) & + Parent & + Directory_Separator & + Sw (Start .. Sw'Last)); + return; + end if; + end loop; + + else + Switch := + new String' + (Sw (1 .. Start - 1) & + Parent & + Directory_Separator & + Sw (Start .. Sw'Last)); + end if; + end if; + + elsif Including_Non_Switch then + if not Is_Absolute_Path (Sw) then + if Parent'Length = 0 then + Do_Fail + ("relative paths (""" & Sw & """) are not allowed"); + else + Switch := new String'(Parent & Directory_Separator & Sw); + end if; + end if; + end if; + end; + end if; + end Test_If_Relative_Path; + + ------------------- + -- Unit_Index_Of -- + ------------------- + + function Unit_Index_Of (ALI_File : File_Name_Type) return Int is + Start : Natural; + Finish : Natural; + Result : Int := 0; + + begin + Get_Name_String (ALI_File); + + -- First, find the last dot + + Finish := Name_Len; + + while Finish >= 1 and then Name_Buffer (Finish) /= '.' loop + Finish := Finish - 1; + end loop; + + if Finish = 1 then + return 0; + end if; + + -- Now check that the dot is preceded by digits + + Start := Finish; + Finish := Finish - 1; + + while Start >= 1 and then Name_Buffer (Start - 1) in '0' .. '9' loop + Start := Start - 1; + end loop; + + -- If there are no digits, or if the digits are not preceded by the + -- character that precedes a unit index, this is not the ALI file of + -- a unit in a multi-unit source. + + if Start > Finish + or else Start = 1 + or else Name_Buffer (Start - 1) /= Multi_Unit_Index_Character + then + return 0; + end if; + + -- Build the index from the digit(s) + + while Start <= Finish loop + Result := Result * 10 + + Character'Pos (Name_Buffer (Start)) - Character'Pos ('0'); + Start := Start + 1; + end loop; + + return Result; + end Unit_Index_Of; + + ----------------- + -- Verbose_Msg -- + ----------------- + + procedure Verbose_Msg + (N1 : Name_Id; + S1 : String; + N2 : Name_Id := No_Name; + S2 : String := ""; + Prefix : String := " -> "; + Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low) + is + begin + if not Opt.Verbose_Mode + or else Minimum_Verbosity > Opt.Verbosity_Level + then + return; + end if; + + Write_Str (Prefix); + Write_Str (""""); + Write_Name (N1); + Write_Str (""" "); + Write_Str (S1); + + if N2 /= No_Name then + Write_Str (" """); + Write_Name (N2); + Write_Str (""" "); + end if; + + Write_Str (S2); + Write_Eol; + end Verbose_Msg; + + procedure Verbose_Msg + (N1 : File_Name_Type; + S1 : String; + N2 : File_Name_Type := No_File; + S2 : String := ""; + Prefix : String := " -> "; + Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low) + is + begin + Verbose_Msg + (Name_Id (N1), S1, Name_Id (N2), S2, Prefix, Minimum_Verbosity); + end Verbose_Msg; + +end Makeutl; diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads new file mode 100644 index 000000000..5ba084a00 --- /dev/null +++ b/gcc/ada/makeutl.ads @@ -0,0 +1,241 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M A K E U T L -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with ALI; +with Namet; use Namet; +with Opt; +with Osint; +with Prj; use Prj; +with Prj.Tree; +with Types; use Types; + +with GNAT.OS_Lib; use GNAT.OS_Lib; + +package Makeutl is + + type Fail_Proc is access procedure (S : String); + Do_Fail : Fail_Proc := Osint.Fail'Access; + -- Failing procedure called from procedure Test_If_Relative_Path below. May + -- be redirected. + + Project_Tree : constant Project_Tree_Ref := new Project_Tree_Data; + -- The project tree + + Source_Info_Option : constant String := "--source-info="; + -- Switch to indicate the source info file + + Subdirs_Option : constant String := "--subdirs="; + -- Switch used to indicate that the real directories (object, exec, + -- library, ...) are subdirectories of those in the project file. + + Unchecked_Shared_Lib_Imports : constant String := + "--unchecked-shared-lib-imports"; + -- Command line switch to allow shared library projects to import projects + -- that are not shared library projects. + + Single_Compile_Per_Obj_Dir_Switch : constant String := + "--single-compile-per-obj-dir"; + -- Switch to forbid simultaneous compilations for the same object directory + -- when project files are used. + + Create_Map_File_Switch : constant String := "--create-map-file"; + -- Switch to create a map file when an executable is linked + + procedure Add + (Option : String_Access; + To : in out String_List_Access; + Last : in out Natural); + procedure Add + (Option : String; + To : in out String_List_Access; + Last : in out Natural); + -- Add a string to a list of strings + + function Create_Binder_Mapping_File return Path_Name_Type; + -- Create a binder mapping file and returns its path name + + function Create_Name (Name : String) return File_Name_Type; + function Create_Name (Name : String) return Name_Id; + function Create_Name (Name : String) return Path_Name_Type; + -- Get an id for a name + + function Base_Name_Index_For + (Main : String; + Main_Index : Int; + Index_Separator : Character) return File_Name_Type; + -- Returns the base name of Main, without the extension, followed by the + -- Index_Separator followed by the Main_Index if it is non-zero. + + function Executable_Prefix_Path return String; + -- Return the absolute path parent directory of the directory where the + -- current executable resides, if its directory is named "bin", otherwise + -- return an empty string. When a directory is returned, it is guaranteed + -- to end with a directory separator. + + procedure Inform (N : Name_Id := No_Name; Msg : String); + procedure Inform (N : File_Name_Type; Msg : String); + -- Prints out the program name followed by a colon, N and S + + function File_Not_A_Source_Of + (Uname : Name_Id; + Sfile : File_Name_Type) return Boolean; + -- Check that file name Sfile is one of the source of unit Uname. Returns + -- True if the unit is in one of the project file, but the file name is not + -- one of its source. Returns False otherwise. + + function Check_Source_Info_In_ALI + (The_ALI : ALI.ALI_Id; + Tree : Project_Tree_Ref) return Boolean; + -- Check whether all file references in ALI are still valid (i.e. the + -- source files are still associated with the same units). Return True + -- if everything is still valid. + + function Is_External_Assignment + (Tree : Prj.Tree.Project_Node_Tree_Ref; + Argv : String) return Boolean; + -- Verify that an external assignment switch is syntactically correct + -- + -- Correct forms are: + -- + -- -Xname=value + -- -X"name=other value" + -- + -- Assumptions: 'First = 1, Argv (1 .. 2) = "-X" + -- + -- When this function returns True, the external assignment has been + -- entered by a call to Prj.Ext.Add, so that in a project file, External + -- ("name") will return "value". + + procedure Verbose_Msg + (N1 : Name_Id; + S1 : String; + N2 : Name_Id := No_Name; + S2 : String := ""; + Prefix : String := " -> "; + Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low); + procedure Verbose_Msg + (N1 : File_Name_Type; + S1 : String; + N2 : File_Name_Type := No_File; + S2 : String := ""; + Prefix : String := " -> "; + Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low); + -- If the verbose flag (Verbose_Mode) is set and the verbosity level is at + -- least equal to Minimum_Verbosity, then print Prefix to standard output + -- followed by N1 and S1. If N2 /= No_Name then N2 is printed after S1. S2 + -- is printed last. Both N1 and N2 are printed in quotation marks. The two + -- forms differ only in taking Name_Id or File_name_Type arguments. + + function Linker_Options_Switches + (Project : Project_Id; + In_Tree : Project_Tree_Ref) return String_List; + -- Collect the options specified in the Linker'Linker_Options attributes + -- of project Project, in project tree In_Tree, and in the projects that + -- it imports directly or indirectly, and returns the result. + + -- Package Mains is used to store the mains specified on the command line + -- and to retrieve them when a project file is used, to verify that the + -- files exist and that they belong to a project file. + + function Unit_Index_Of (ALI_File : File_Name_Type) return Int; + -- Find the index of a unit in a source file. Return zero if the file is + -- not a multi-unit source file. + + procedure Test_If_Relative_Path + (Switch : in out String_Access; + Parent : String; + Including_L_Switch : Boolean := True; + Including_Non_Switch : Boolean := True; + Including_RTS : Boolean := False); + -- Test if Switch is a relative search path switch. If it is, fail if + -- Parent is the empty string, otherwise prepend the path with Parent. + -- This subprogram is only called when using project files. For gnatbind + -- switches, Including_L_Switch is False, because the argument of the -L + -- switch is not a path. If Including_RTS is True, process also switches + -- --RTS=. + + function Path_Or_File_Name (Path : Path_Name_Type) return String; + -- Returns a file name if -df is used, otherwise return a path name + + ----------- + -- Mains -- + ----------- + + -- Mains are stored in a table. An index is used to retrieve the mains + -- from the table. + + package Mains is + + procedure Add_Main (Name : String); + -- Add one main to the table + + procedure Set_Index (Index : Int); + + procedure Set_Location (Location : Source_Ptr); + -- Set the location of the last main added. By default, the location is + -- No_Location. + + procedure Delete; + -- Empty the table + + procedure Reset; + -- Reset the index to the beginning of the table + + function Next_Main return String; + -- Increase the index and return the next main. If table is exhausted, + -- return an empty string. + + function Get_Index return Int; + + function Get_Location return Source_Ptr; + -- Get the location of the current main + + procedure Update_Main (Name : String); + -- Update the file name of the current main + + function Number_Of_Mains return Natural; + -- Returns the number of mains added with Add_Main since the last call + -- to Delete. + + end Mains; + + ---------------------- + -- Marking Routines -- + ---------------------- + + procedure Mark (Source_File : File_Name_Type; Index : Int := 0); + -- Mark a unit, identified by its source file and, when Index is not 0, the + -- index of the unit in the source file. Marking is used to signal that the + -- unit has already been inserted in the Q. + + function Is_Marked + (Source_File : File_Name_Type; + Index : Int := 0) return Boolean; + -- Returns True if the unit was previously marked + + procedure Delete_All_Marks; + -- Remove all file/index couples marked + +end Makeutl; diff --git a/gcc/ada/math_lib.adb b/gcc/ada/math_lib.adb new file mode 100644 index 000000000..e539f477b --- /dev/null +++ b/gcc/ada/math_lib.adb @@ -0,0 +1,1025 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- M A T H _ L I B -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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. This is not a "strict" implementation, but takes full +-- advantage of the C functions, e.g. in providing interface to hardware +-- provided versions of the elementary functions. + +-- A known weakness is that on the x86, all computation is done in Double, +-- which means that a lot of accuracy is lost for the Long_Long_Float case. + +-- Uses functions sqrt, exp, log, pow, sin, asin, cos, acos, tan, atan, +-- sinh, cosh, tanh from C library via math.h + +-- This is an adaptation of Ada.Numerics.Generic_Elementary_Functions that +-- provides a compatible body for the DEC Math_Lib package. + +with Ada.Numerics.Aux; +use type Ada.Numerics.Aux.Double; +with Ada.Numerics; use Ada.Numerics; + +package body Math_Lib is + + Log_Two : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755; + + Two_Pi : constant Real'Base := 2.0 * Pi; + Half_Pi : constant Real'Base := Pi / 2.0; + Fourth_Pi : constant Real'Base := Pi / 4.0; + Epsilon : constant Real'Base := Real'Base'Epsilon; + IEpsilon : constant Real'Base := 1.0 / Epsilon; + + subtype Double is Aux.Double; + + DEpsilon : constant Double := Double (Epsilon); + DIEpsilon : constant Double := Double (IEpsilon); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Arctan + (Y : Real; + A : Real := 1.0) + return Real; + + function Arctan + (Y : Real; + A : Real := 1.0; + Cycle : Real) + return Real; + + function Exact_Remainder + (A : Real; + Y : Real) + return Real; + -- Computes exact remainder of A divided by Y + + function Half_Log_Epsilon return Real; + -- Function to provide constant: 0.5 * Log (Epsilon) + + function Local_Atan + (Y : Real; + A : Real := 1.0) + return Real; + -- Common code for arc tangent after cycle reduction + + function Log_Inverse_Epsilon return Real; + -- Function to provide constant: Log (1.0 / Epsilon) + + function Square_Root_Epsilon return Real; + -- Function to provide constant: Sqrt (Epsilon) + + ---------- + -- "**" -- + ---------- + + function "**" (A1, A2 : Real) return Real is + + begin + if A1 = 0.0 + and then A2 = 0.0 + then + raise Argument_Error; + + elsif A1 < 0.0 then + raise Argument_Error; + + elsif A2 = 0.0 then + return 1.0; + + elsif A1 = 0.0 then + if A2 < 0.0 then + raise Constraint_Error; + else + return 0.0; + end if; + + elsif A1 = 1.0 then + return 1.0; + + elsif A2 = 1.0 then + return A1; + + else + begin + if A2 = 2.0 then + return A1 * A1; + else + return + Real (Aux.pow (Double (A1), Double (A2))); + end if; + + exception + when others => + raise Constraint_Error; + end; + end if; + end "**"; + + ------------ + -- Arccos -- + ------------ + + -- Natural cycle + + function Arccos (A : Real) return Real is + Temp : Real'Base; + + begin + if abs A > 1.0 then + raise Argument_Error; + + elsif abs A < Square_Root_Epsilon then + return Pi / 2.0 - A; + + elsif A = 1.0 then + return 0.0; + + elsif A = -1.0 then + return Pi; + end if; + + Temp := Real (Aux.acos (Double (A))); + + if Temp < 0.0 then + Temp := Pi + Temp; + end if; + + return Temp; + end Arccos; + + -- Arbitrary cycle + + function Arccos (A, Cycle : Real) return Real is + Temp : Real'Base; + + begin + if Cycle <= 0.0 then + raise Argument_Error; + + elsif abs A > 1.0 then + raise Argument_Error; + + elsif abs A < Square_Root_Epsilon then + return Cycle / 4.0; + + elsif A = 1.0 then + return 0.0; + + elsif A = -1.0 then + return Cycle / 2.0; + end if; + + Temp := Arctan (Sqrt (1.0 - A * A) / A, 1.0, Cycle); + + if Temp < 0.0 then + Temp := Cycle / 2.0 + Temp; + end if; + + return Temp; + end Arccos; + + ------------- + -- Arccosh -- + ------------- + + function Arccosh (A : Real) return Real is + begin + -- Return Log (A - Sqrt (A * A - 1.0)); double valued, + -- only positive value returned + -- What is this comment ??? + + if A < 1.0 then + raise Argument_Error; + + elsif A < 1.0 + Square_Root_Epsilon then + return A - 1.0; + + elsif abs A > 1.0 / Square_Root_Epsilon then + return Log (A) + Log_Two; + + else + return Log (A + Sqrt (A * A - 1.0)); + end if; + end Arccosh; + + ------------ + -- Arccot -- + ------------ + + -- Natural cycle + + function Arccot + (A : Real; + Y : Real := 1.0) + return Real + is + begin + -- Just reverse arguments + + return Arctan (Y, A); + end Arccot; + + -- Arbitrary cycle + + function Arccot + (A : Real; + Y : Real := 1.0; + Cycle : Real) + return Real + is + begin + -- Just reverse arguments + + return Arctan (Y, A, Cycle); + end Arccot; + + ------------- + -- Arccoth -- + ------------- + + function Arccoth (A : Real) return Real is + begin + if abs A = 1.0 then + raise Constraint_Error; + + elsif abs A < 1.0 then + raise Argument_Error; + + elsif abs A > 1.0 / Epsilon then + return 0.0; + + else + return 0.5 * Log ((1.0 + A) / (A - 1.0)); + end if; + end Arccoth; + + ------------ + -- Arcsin -- + ------------ + + -- Natural cycle + + function Arcsin (A : Real) return Real is + begin + if abs A > 1.0 then + raise Argument_Error; + + elsif abs A < Square_Root_Epsilon then + return A; + + elsif A = 1.0 then + return Pi / 2.0; + + elsif A = -1.0 then + return -Pi / 2.0; + end if; + + return Real (Aux.asin (Double (A))); + end Arcsin; + + -- Arbitrary cycle + + function Arcsin (A, Cycle : Real) return Real is + begin + if Cycle <= 0.0 then + raise Argument_Error; + + elsif abs A > 1.0 then + raise Argument_Error; + + elsif A = 0.0 then + return A; + + elsif A = 1.0 then + return Cycle / 4.0; + + elsif A = -1.0 then + return -Cycle / 4.0; + end if; + + return Arctan (A / Sqrt (1.0 - A * A), 1.0, Cycle); + end Arcsin; + + ------------- + -- Arcsinh -- + ------------- + + function Arcsinh (A : Real) return Real is + begin + if abs A < Square_Root_Epsilon then + return A; + + elsif A > 1.0 / Square_Root_Epsilon then + return Log (A) + Log_Two; + + elsif A < -1.0 / Square_Root_Epsilon then + return -(Log (-A) + Log_Two); + + elsif A < 0.0 then + return -Log (abs A + Sqrt (A * A + 1.0)); + + else + return Log (A + Sqrt (A * A + 1.0)); + end if; + end Arcsinh; + + ------------ + -- Arctan -- + ------------ + + -- Natural cycle + + function Arctan + (Y : Real; + A : Real := 1.0) + return Real + is + begin + if A = 0.0 + and then Y = 0.0 + then + raise Argument_Error; + + elsif Y = 0.0 then + if A > 0.0 then + return 0.0; + else -- A < 0.0 + return Pi; + end if; + + elsif A = 0.0 then + if Y > 0.0 then + return Half_Pi; + else -- Y < 0.0 + return -Half_Pi; + end if; + + else + return Local_Atan (Y, A); + end if; + end Arctan; + + -- Arbitrary cycle + + function Arctan + (Y : Real; + A : Real := 1.0; + Cycle : Real) + return Real + is + begin + if Cycle <= 0.0 then + raise Argument_Error; + + elsif A = 0.0 + and then Y = 0.0 + then + raise Argument_Error; + + elsif Y = 0.0 then + if A > 0.0 then + return 0.0; + else -- A < 0.0 + return Cycle / 2.0; + end if; + + elsif A = 0.0 then + if Y > 0.0 then + return Cycle / 4.0; + else -- Y < 0.0 + return -Cycle / 4.0; + end if; + + else + return Local_Atan (Y, A) * Cycle / Two_Pi; + end if; + end Arctan; + + ------------- + -- Arctanh -- + ------------- + + function Arctanh (A : Real) return Real is + begin + if abs A = 1.0 then + raise Constraint_Error; + + elsif abs A > 1.0 then + raise Argument_Error; + + elsif abs A < Square_Root_Epsilon then + return A; + + else + return 0.5 * Log ((1.0 + A) / (1.0 - A)); + end if; + end Arctanh; + + --------- + -- Cos -- + --------- + + -- Natural cycle + + function Cos (A : Real) return Real is + begin + if A = 0.0 then + return 1.0; + + elsif abs A < Square_Root_Epsilon then + return 1.0; + + end if; + + return Real (Aux.Cos (Double (A))); + end Cos; + + -- Arbitrary cycle + + function Cos (A, Cycle : Real) return Real is + T : Real'Base; + + begin + if Cycle <= 0.0 then + raise Argument_Error; + + elsif A = 0.0 then + return 1.0; + end if; + + T := Exact_Remainder (abs (A), Cycle) / Cycle; + + if T = 0.25 + or else T = 0.75 + or else T = -0.25 + or else T = -0.75 + then + return 0.0; + + elsif T = 0.5 or T = -0.5 then + return -1.0; + end if; + + return Real (Aux.Cos (Double (T * Two_Pi))); + end Cos; + + ---------- + -- Cosh -- + ---------- + + function Cosh (A : Real) return Real is + begin + if abs A < Square_Root_Epsilon then + return 1.0; + + elsif abs A > Log_Inverse_Epsilon then + return Exp ((abs A) - Log_Two); + end if; + + return Real (Aux.cosh (Double (A))); + + exception + when others => + raise Constraint_Error; + end Cosh; + + --------- + -- Cot -- + --------- + + -- Natural cycle + + function Cot (A : Real) return Real is + begin + if A = 0.0 then + raise Constraint_Error; + + elsif abs A < Square_Root_Epsilon then + return 1.0 / A; + end if; + + return Real (1.0 / Real'Base (Aux.tan (Double (A)))); + end Cot; + + -- Arbitrary cycle + + function Cot (A, Cycle : Real) return Real is + T : Real'Base; + + begin + if Cycle <= 0.0 then + raise Argument_Error; + + elsif A = 0.0 then + raise Constraint_Error; + + elsif abs A < Square_Root_Epsilon then + return 1.0 / A; + end if; + + T := Exact_Remainder (A, Cycle) / Cycle; + + if T = 0.0 or T = 0.5 or T = -0.5 then + raise Constraint_Error; + else + return Cos (T * Two_Pi) / Sin (T * Two_Pi); + end if; + end Cot; + + ---------- + -- Coth -- + ---------- + + function Coth (A : Real) return Real is + begin + if A = 0.0 then + raise Constraint_Error; + + elsif A < Half_Log_Epsilon then + return -1.0; + + elsif A > -Half_Log_Epsilon then + return 1.0; + + elsif abs A < Square_Root_Epsilon then + return 1.0 / A; + end if; + + return Real (1.0 / Real'Base (Aux.tanh (Double (A)))); + end Coth; + + --------------------- + -- Exact_Remainder -- + --------------------- + + function Exact_Remainder + (A : Real; + Y : Real) + return Real + is + Denominator : Real'Base := abs A; + Divisor : Real'Base := abs Y; + Reducer : Real'Base; + Sign : Real'Base := 1.0; + + begin + if Y = 0.0 then + raise Constraint_Error; + + elsif A = 0.0 then + return 0.0; + + elsif A = Y then + return 0.0; + + elsif Denominator < Divisor then + return A; + end if; + + while Denominator >= Divisor loop + + -- Put divisors mantissa with denominators exponent to make reducer + + Reducer := Divisor; + + begin + while Reducer * 1_048_576.0 < Denominator loop + Reducer := Reducer * 1_048_576.0; + end loop; + + exception + when others => null; + end; + + begin + while Reducer * 1_024.0 < Denominator loop + Reducer := Reducer * 1_024.0; + end loop; + + exception + when others => null; + end; + + begin + while Reducer * 2.0 < Denominator loop + Reducer := Reducer * 2.0; + end loop; + + exception + when others => null; + end; + + Denominator := Denominator - Reducer; + end loop; + + if A < 0.0 then + return -Denominator; + else + return Denominator; + end if; + end Exact_Remainder; + + --------- + -- Exp -- + --------- + + function Exp (A : Real) return Real is + Result : Real'Base; + + begin + if A = 0.0 then + return 1.0; + + else + Result := Real (Aux.Exp (Double (A))); + + -- The check here catches the case of Exp returning IEEE infinity + + if Result > Real'Last then + raise Constraint_Error; + else + return Result; + end if; + end if; + end Exp; + + ---------------------- + -- Half_Log_Epsilon -- + ---------------------- + + -- Cannot precompute this constant, because this is required to be a + -- pure package, which allows no state. A pity, but no way around it! + + function Half_Log_Epsilon return Real is + begin + return Real (0.5 * Real'Base (Aux.Log (DEpsilon))); + end Half_Log_Epsilon; + + ---------------- + -- Local_Atan -- + ---------------- + + function Local_Atan + (Y : Real; + A : Real := 1.0) + return Real + is + Z : Real'Base; + Raw_Atan : Real'Base; + + begin + if abs Y > abs A then + Z := abs (A / Y); + else + Z := abs (Y / A); + end if; + + if Z < Square_Root_Epsilon then + Raw_Atan := Z; + + elsif Z = 1.0 then + Raw_Atan := Pi / 4.0; + + elsif Z < Square_Root_Epsilon then + Raw_Atan := Z; + + else + Raw_Atan := Real'Base (Aux.Atan (Double (Z))); + end if; + + if abs Y > abs A then + Raw_Atan := Half_Pi - Raw_Atan; + end if; + + if A > 0.0 then + if Y > 0.0 then + return Raw_Atan; + else -- Y < 0.0 + return -Raw_Atan; + end if; + + else -- A < 0.0 + if Y > 0.0 then + return Pi - Raw_Atan; + else -- Y < 0.0 + return -(Pi - Raw_Atan); + end if; + end if; + end Local_Atan; + + --------- + -- Log -- + --------- + + -- Natural base + + function Log (A : Real) return Real is + begin + if A < 0.0 then + raise Argument_Error; + + elsif A = 0.0 then + raise Constraint_Error; + + elsif A = 1.0 then + return 0.0; + end if; + + return Real (Aux.Log (Double (A))); + end Log; + + -- Arbitrary base + + function Log (A, Base : Real) return Real is + begin + if A < 0.0 then + raise Argument_Error; + + elsif Base <= 0.0 or else Base = 1.0 then + raise Argument_Error; + + elsif A = 0.0 then + raise Constraint_Error; + + elsif A = 1.0 then + return 0.0; + end if; + + return Real (Aux.Log (Double (A)) / Aux.Log (Double (Base))); + end Log; + + ------------------------- + -- Log_Inverse_Epsilon -- + ------------------------- + + -- Cannot precompute this constant, because this is required to be a + -- pure package, which allows no state. A pity, but no way around it! + + function Log_Inverse_Epsilon return Real is + begin + return Real (Aux.Log (DIEpsilon)); + end Log_Inverse_Epsilon; + + --------- + -- Sin -- + --------- + + -- Natural cycle + + function Sin (A : Real) return Real is + begin + if abs A < Square_Root_Epsilon then + return A; + end if; + + return Real (Aux.Sin (Double (A))); + end Sin; + + -- Arbitrary cycle + + function Sin (A, Cycle : Real) return Real is + T : Real'Base; + + begin + if Cycle <= 0.0 then + raise Argument_Error; + + elsif A = 0.0 then + return A; + end if; + + T := Exact_Remainder (A, Cycle) / Cycle; + + if T = 0.0 or T = 0.5 or T = -0.5 then + return 0.0; + + elsif T = 0.25 or T = -0.75 then + return 1.0; + + elsif T = -0.25 or T = 0.75 then + return -1.0; + + end if; + + return Real (Aux.Sin (Double (T * Two_Pi))); + end Sin; + + ---------- + -- Sinh -- + ---------- + + function Sinh (A : Real) return Real is + begin + if abs A < Square_Root_Epsilon then + return A; + + elsif A > Log_Inverse_Epsilon then + return Exp (A - Log_Two); + + elsif A < -Log_Inverse_Epsilon then + return -Exp ((-A) - Log_Two); + end if; + + return Real (Aux.Sinh (Double (A))); + + exception + when others => + raise Constraint_Error; + end Sinh; + + ------------------------- + -- Square_Root_Epsilon -- + ------------------------- + + -- Cannot precompute this constant, because this is required to be a + -- pure package, which allows no state. A pity, but no way around it! + + function Square_Root_Epsilon return Real is + begin + return Real (Aux.Sqrt (DEpsilon)); + end Square_Root_Epsilon; + + ---------- + -- Sqrt -- + ---------- + + function Sqrt (A : Real) return Real is + begin + if A < 0.0 then + raise Argument_Error; + + -- Special case Sqrt (0.0) to preserve possible minus sign per IEEE + + elsif A = 0.0 then + return A; + + -- Sqrt (1.0) must be exact for good complex accuracy + + elsif A = 1.0 then + return 1.0; + + end if; + + return Real (Aux.Sqrt (Double (A))); + end Sqrt; + + --------- + -- Tan -- + --------- + + -- Natural cycle + + function Tan (A : Real) return Real is + begin + if abs A < Square_Root_Epsilon then + return A; + + elsif abs A = Pi / 2.0 then + raise Constraint_Error; + end if; + + return Real (Aux.tan (Double (A))); + end Tan; + + -- Arbitrary cycle + + function Tan (A, Cycle : Real) return Real is + T : Real'Base; + + begin + if Cycle <= 0.0 then + raise Argument_Error; + + elsif A = 0.0 then + return A; + end if; + + T := Exact_Remainder (A, Cycle) / Cycle; + + if T = 0.25 + or else T = 0.75 + or else T = -0.25 + or else T = -0.75 + then + raise Constraint_Error; + + else + return Sin (T * Two_Pi) / Cos (T * Two_Pi); + end if; + end Tan; + + ---------- + -- Tanh -- + ---------- + + function Tanh (A : Real) return Real is + begin + if A < Half_Log_Epsilon then + return -1.0; + + elsif A > -Half_Log_Epsilon then + return 1.0; + + elsif abs A < Square_Root_Epsilon then + return A; + end if; + + return Real (Aux.tanh (Double (A))); + end Tanh; + + ---------------------------- + -- DEC-Specific functions -- + ---------------------------- + + function LOG10 (A : REAL) return REAL is + begin + return Log (A, 10.0); + end LOG10; + + function LOG2 (A : REAL) return REAL is + begin + return Log (A, 2.0); + end LOG2; + + function ASIN (A : REAL) return REAL renames Arcsin; + function ACOS (A : REAL) return REAL renames Arccos; + + function ATAN (A : REAL) return REAL is + begin + return Arctan (A, 1.0); + end ATAN; + + function ATAN2 (A1, A2 : REAL) return REAL renames Arctan; + + function SIND (A : REAL) return REAL is + begin + return Sin (A, 360.0); + end SIND; + + function COSD (A : REAL) return REAL is + begin + return Cos (A, 360.0); + end COSD; + + function TAND (A : REAL) return REAL is + begin + return Tan (A, 360.0); + end TAND; + + function ASIND (A : REAL) return REAL is + begin + return Arcsin (A, 360.0); + end ASIND; + + function ACOSD (A : REAL) return REAL is + begin + return Arccos (A, 360.0); + end ACOSD; + + function Arctan (A : REAL) return REAL is + begin + return Arctan (A, 1.0, 360.0); + end Arctan; + + function ATAND (A : REAL) return REAL is + begin + return Arctan (A, 1.0, 360.0); + end ATAND; + + function ATAN2D (A1, A2 : REAL) return REAL is + begin + return Arctan (A1, A2, 360.0); + end ATAN2D; + +end Math_Lib; diff --git a/gcc/ada/mdll-fil.adb b/gcc/ada/mdll-fil.adb new file mode 100644 index 000000000..bf1b4e734 --- /dev/null +++ b/gcc/ada/mdll-fil.adb @@ -0,0 +1,92 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M D L L . F I L E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Simple services used by GNATDLL to deal with Filename extension + +with Ada.Strings.Fixed; + +package body MDLL.Fil is + + use Ada; + + ------------- + -- Get_Ext -- + ------------- + + function Get_Ext (Filename : String) return String is + use Strings.Fixed; + I : constant Natural := Index (Filename, ".", Strings.Backward); + begin + if I = 0 then + return ""; + else + return Filename (I .. Filename'Last); + end if; + end Get_Ext; + + ------------ + -- Is_Ali -- + ------------ + + function Is_Ali (Filename : String) return Boolean is + begin + return Get_Ext (Filename) = ".ali"; + end Is_Ali; + + ------------ + -- Is_Obj -- + ------------ + + function Is_Obj (Filename : String) return Boolean is + Ext : constant String := Get_Ext (Filename); + begin + return Ext = ".o" or else Ext = ".obj"; + end Is_Obj; + + ------------ + -- Ext_To -- + ------------ + + function Ext_To + (Filename : String; + New_Ext : String := No_Ext) + return String + is + use Strings.Fixed; + I : constant Natural := Index (Filename, ".", Strings.Backward); + begin + if I = 0 then + return Filename; + + else + if New_Ext = "" then + return Filename (Filename'First .. I - 1); + else + return Filename (Filename'First .. I - 1) & '.' & New_Ext; + end if; + end if; + end Ext_To; + +end MDLL.Fil; diff --git a/gcc/ada/mdll-fil.ads b/gcc/ada/mdll-fil.ads new file mode 100644 index 000000000..571f0861e --- /dev/null +++ b/gcc/ada/mdll-fil.ads @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M D L L . F I L E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Simple services used by GNATDLL to deal with Filename extension + +package MDLL.Fil is + + No_Ext : constant String := ""; + -- Used to mark the absence of an extension + + function Get_Ext (Filename : String) return String; + -- Return extension of Filename + + function Is_Ali (Filename : String) return Boolean; + -- Test if Filename is an Ada library file (.ali) + + function Is_Obj (Filename : String) return Boolean; + -- Test if Filename is an object file (.o or .obj) + + function Ext_To + (Filename : String; + New_Ext : String := No_Ext) + return String; + -- Return Filename with the extension change to New_Ext + +end MDLL.Fil; diff --git a/gcc/ada/mdll-utl.adb b/gcc/ada/mdll-utl.adb new file mode 100644 index 000000000..85bc2a3a6 --- /dev/null +++ b/gcc/ada/mdll-utl.adb @@ -0,0 +1,366 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M D L L . T O O L S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Interface to externals tools used to build DLL and import libraries + +with Ada.Text_IO; +with Ada.Exceptions; + +with GNAT.Directory_Operations; +with Osint; + +package body MDLL.Utl is + + use Ada; + use GNAT; + + Dlltool_Name : constant String := "dlltool"; + Dlltool_Exec : OS_Lib.String_Access; + + Gcc_Name : constant String := "gcc"; + Gcc_Exec : OS_Lib.String_Access; + + Gnatbind_Name : constant String := "gnatbind"; + Gnatbind_Exec : OS_Lib.String_Access; + + Gnatlink_Name : constant String := "gnatlink"; + Gnatlink_Exec : OS_Lib.String_Access; + + procedure Print_Command + (Tool_Name : String; + Arguments : OS_Lib.Argument_List); + -- display the command run when in Verbose mode + + ------------------- + -- Print_Command -- + ------------------- + + procedure Print_Command + (Tool_Name : String; + Arguments : OS_Lib.Argument_List) + is + begin + if Verbose then + Text_IO.Put (Tool_Name); + for K in Arguments'Range loop + Text_IO.Put (" " & Arguments (K).all); + end loop; + Text_IO.New_Line; + end if; + end Print_Command; + + ------------- + -- Dlltool -- + ------------- + + procedure Dlltool + (Def_Filename : String; + DLL_Name : String; + Library : String; + Exp_Table : String := ""; + Base_File : String := ""; + Build_Import : Boolean) + is + Arguments : OS_Lib.Argument_List (1 .. 11); + A : Positive; + + Success : Boolean; + + Def_Opt : aliased String := "--def"; + Def_V : aliased String := Def_Filename; + Dll_Opt : aliased String := "--dllname"; + Dll_V : aliased String := DLL_Name; + Lib_Opt : aliased String := "--output-lib"; + Lib_V : aliased String := Library; + Exp_Opt : aliased String := "--output-exp"; + Exp_V : aliased String := Exp_Table; + Bas_Opt : aliased String := "--base-file"; + Bas_V : aliased String := Base_File; + No_Suf_Opt : aliased String := "-k"; + + begin + Arguments (1 .. 4) := (1 => Def_Opt'Unchecked_Access, + 2 => Def_V'Unchecked_Access, + 3 => Dll_Opt'Unchecked_Access, + 4 => Dll_V'Unchecked_Access); + A := 4; + + if Kill_Suffix then + A := A + 1; + Arguments (A) := No_Suf_Opt'Unchecked_Access; + end if; + + if Library /= "" and then Build_Import then + A := A + 1; + Arguments (A) := Lib_Opt'Unchecked_Access; + A := A + 1; + Arguments (A) := Lib_V'Unchecked_Access; + end if; + + if Exp_Table /= "" then + A := A + 1; + Arguments (A) := Exp_Opt'Unchecked_Access; + A := A + 1; + Arguments (A) := Exp_V'Unchecked_Access; + end if; + + if Base_File /= "" then + A := A + 1; + Arguments (A) := Bas_Opt'Unchecked_Access; + A := A + 1; + Arguments (A) := Bas_V'Unchecked_Access; + end if; + + Print_Command ("dlltool", Arguments (1 .. A)); + + OS_Lib.Spawn (Dlltool_Exec.all, Arguments (1 .. A), Success); + + if not Success then + Exceptions.Raise_Exception + (Tools_Error'Identity, Dlltool_Name & " execution error."); + end if; + end Dlltool; + + --------- + -- Gcc -- + --------- + + procedure Gcc + (Output_File : String; + Files : Argument_List; + Options : Argument_List; + Base_File : String := ""; + Build_Lib : Boolean := False) + is + use Osint; + + Arguments : OS_Lib.Argument_List + (1 .. 5 + Files'Length + Options'Length); + A : Natural := 0; + + Success : Boolean; + C_Opt : aliased String := "-c"; + Out_Opt : aliased String := "-o"; + Out_V : aliased String := Output_File; + Bas_Opt : aliased String := "-Wl,--base-file," & Base_File; + Lib_Opt : aliased String := "-mdll"; + Lib_Dir : aliased String := "-L" & Object_Dir_Default_Prefix; + + begin + A := A + 1; + if Build_Lib then + Arguments (A) := Lib_Opt'Unchecked_Access; + else + Arguments (A) := C_Opt'Unchecked_Access; + end if; + + A := A + 1; + Arguments (A .. A + 2) := (Out_Opt'Unchecked_Access, + Out_V'Unchecked_Access, + Lib_Dir'Unchecked_Access); + A := A + 2; + + if Base_File /= "" then + A := A + 1; + Arguments (A) := Bas_Opt'Unchecked_Access; + end if; + + A := A + 1; + Arguments (A .. A + Files'Length - 1) := Files; + A := A + Files'Length - 1; + + if Build_Lib then + A := A + 1; + Arguments (A .. A + Options'Length - 1) := Options; + A := A + Options'Length - 1; + else + declare + Largs : Argument_List (Options'Range); + L : Natural := Largs'First - 1; + begin + for K in Options'Range loop + if Options (K) (1 .. 2) /= "-l" then + L := L + 1; + Largs (L) := Options (K); + end if; + end loop; + A := A + 1; + Arguments (A .. A + L - 1) := Largs (1 .. L); + A := A + L - 1; + end; + end if; + + Print_Command ("gcc", Arguments (1 .. A)); + + OS_Lib.Spawn (Gcc_Exec.all, Arguments (1 .. A), Success); + + if not Success then + Exceptions.Raise_Exception + (Tools_Error'Identity, Gcc_Name & " execution error."); + end if; + end Gcc; + + -------------- + -- Gnatbind -- + -------------- + + procedure Gnatbind + (Alis : Argument_List; + Args : Argument_List := Null_Argument_List) + is + Arguments : OS_Lib.Argument_List (1 .. 1 + Alis'Length + Args'Length); + Success : Boolean; + + No_Main_Opt : aliased String := "-n"; + + begin + Arguments (1) := No_Main_Opt'Unchecked_Access; + Arguments (2 .. 1 + Alis'Length) := Alis; + Arguments (2 + Alis'Length .. Arguments'Last) := Args; + + Print_Command ("gnatbind", Arguments); + + OS_Lib.Spawn (Gnatbind_Exec.all, Arguments, Success); + + -- Delete binder files on failure + + if not Success then + declare + Base_Name : constant String := + Directory_Operations.Base_Name (Alis (Alis'First).all, ".ali"); + begin + OS_Lib.Delete_File ("b~" & Base_Name & ".ads", Success); + OS_Lib.Delete_File ("b~" & Base_Name & ".adb", Success); + end; + + Exceptions.Raise_Exception + (Tools_Error'Identity, Gnatbind_Name & " execution error."); + end if; + end Gnatbind; + + -------------- + -- Gnatlink -- + -------------- + + procedure Gnatlink + (Ali : String; + Args : Argument_List := Null_Argument_List) + is + Arguments : OS_Lib.Argument_List (1 .. 1 + Args'Length); + Success : Boolean; + + Ali_Name : aliased String := Ali; + + begin + Arguments (1) := Ali_Name'Unchecked_Access; + Arguments (2 .. Arguments'Last) := Args; + + Print_Command ("gnatlink", Arguments); + + OS_Lib.Spawn (Gnatlink_Exec.all, Arguments, Success); + + if not Success then + -- Delete binder files + declare + Base_Name : constant String := + Directory_Operations.Base_Name (Ali, ".ali"); + begin + OS_Lib.Delete_File ("b~" & Base_Name & ".ads", Success); + OS_Lib.Delete_File ("b~" & Base_Name & ".adb", Success); + OS_Lib.Delete_File ("b~" & Base_Name & ".ali", Success); + OS_Lib.Delete_File ("b~" & Base_Name & ".o", Success); + end; + + Exceptions.Raise_Exception + (Tools_Error'Identity, Gnatlink_Name & " execution error."); + end if; + end Gnatlink; + + ------------ + -- Locate -- + ------------ + + procedure Locate is + use type OS_Lib.String_Access; + begin + -- dlltool + + if Dlltool_Exec = null then + Dlltool_Exec := OS_Lib.Locate_Exec_On_Path (Dlltool_Name); + + if Dlltool_Exec = null then + Exceptions.Raise_Exception + (Tools_Error'Identity, Dlltool_Name & " not found in path"); + + elsif Verbose then + Text_IO.Put_Line ("using " & Dlltool_Exec.all); + end if; + end if; + + -- gcc + + if Gcc_Exec = null then + Gcc_Exec := OS_Lib.Locate_Exec_On_Path (Gcc_Name); + + if Gcc_Exec = null then + Exceptions.Raise_Exception + (Tools_Error'Identity, Gcc_Name & " not found in path"); + + elsif Verbose then + Text_IO.Put_Line ("using " & Gcc_Exec.all); + end if; + end if; + + -- gnatbind + + if Gnatbind_Exec = null then + Gnatbind_Exec := OS_Lib.Locate_Exec_On_Path (Gnatbind_Name); + + if Gnatbind_Exec = null then + Exceptions.Raise_Exception + (Tools_Error'Identity, Gnatbind_Name & " not found in path"); + + elsif Verbose then + Text_IO.Put_Line ("using " & Gnatbind_Exec.all); + end if; + end if; + + -- gnatlink + + if Gnatlink_Exec = null then + Gnatlink_Exec := OS_Lib.Locate_Exec_On_Path (Gnatlink_Name); + + if Gnatlink_Exec = null then + Exceptions.Raise_Exception + (Tools_Error'Identity, Gnatlink_Name & " not found in path"); + + elsif Verbose then + Text_IO.Put_Line ("using " & Gnatlink_Exec.all); + Text_IO.New_Line; + end if; + end if; + end Locate; + +end MDLL.Utl; diff --git a/gcc/ada/mdll-utl.ads b/gcc/ada/mdll-utl.ads new file mode 100644 index 000000000..2b4125139 --- /dev/null +++ b/gcc/ada/mdll-utl.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M D L L . T O O L S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Interface to externals tools used to build DLL and import libraries + +package MDLL.Utl is + + procedure Dlltool + (Def_Filename : String; + DLL_Name : String; + Library : String; + Exp_Table : String := ""; + Base_File : String := ""; + Build_Import : Boolean); + -- Run dlltool binary. + -- This tools is used to build an import library and an export table + + procedure Gcc + (Output_File : String; + Files : Argument_List; + Options : Argument_List; + Base_File : String := ""; + Build_Lib : Boolean := False); + -- Run gcc binary + + procedure Gnatbind + (Alis : Argument_List; + Args : Argument_List := Null_Argument_List); + -- Run gnatbind binary to build the binder program. + -- it Runs the command : gnatbind -n alis... to build the binder program. + + procedure Gnatlink + (Ali : String; + Args : Argument_List := Null_Argument_List); + -- Run gnatlink binary. + -- It runs the command : gnatlink ali arg1 arg2... + + procedure Locate; + -- Look for the needed tools in the path and record the full path for each + -- one in a variable. + +end MDLL.Utl; diff --git a/gcc/ada/mdll.adb b/gcc/ada/mdll.adb new file mode 100644 index 000000000..e6eb5e936 --- /dev/null +++ b/gcc/ada/mdll.adb @@ -0,0 +1,517 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M D L L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides the core high level routines used by GNATDLL +-- to build Windows DLL. + +with Ada.Text_IO; + +with GNAT.Directory_Operations; +with MDLL.Utl; +with MDLL.Fil; + +package body MDLL is + + use Ada; + use GNAT; + + -- Convention used for the library names on Windows: + -- DLL: .dll + -- Import library: lib.dll + + function Get_Dll_Name (Lib_Filename : String) return String; + -- Returns if it contains a file extension otherwise it + -- returns .dll. + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Afiles : Argument_List; + Options : Argument_List; + Bargs_Options : Argument_List; + Largs_Options : Argument_List; + Lib_Filename : String; + Def_Filename : String; + Lib_Address : String := ""; + Build_Import : Boolean := False; + Relocatable : Boolean := False; + Map_File : Boolean := False) + is + + use type OS_Lib.Argument_List; + + Base_Filename : constant String := MDLL.Fil.Ext_To (Lib_Filename); + + Def_File : aliased constant String := Def_Filename; + Jnk_File : aliased String := Base_Filename & ".jnk"; + Bas_File : aliased constant String := Base_Filename & ".base"; + Dll_File : aliased String := Get_Dll_Name (Lib_Filename); + Exp_File : aliased String := Base_Filename & ".exp"; + Lib_File : aliased constant String := "lib" & Base_Filename & ".dll.a"; + + Bas_Opt : aliased String := "-Wl,--base-file," & Bas_File; + Lib_Opt : aliased String := "-mdll"; + Out_Opt : aliased String := "-o"; + Adr_Opt : aliased String := "-Wl,--image-base=" & Lib_Address; + Map_Opt : aliased String := "-Wl,-Map," & Lib_Filename & ".map"; + + L_Afiles : Argument_List := Afiles; + -- Local afiles list. This list can be reordered to ensure that the + -- binder ALI file is not the first entry in this list. + + All_Options : constant Argument_List := Options & Largs_Options; + + procedure Build_Reloc_DLL; + -- Build a relocatable DLL with only objects file specified. This uses + -- the well known five step build (see GNAT User's Guide). + + procedure Ada_Build_Reloc_DLL; + -- Build a relocatable DLL with Ada code. This uses the well known five + -- step build (see GNAT User's Guide). + + procedure Build_Non_Reloc_DLL; + -- Build a non relocatable DLL containing no Ada code + + procedure Ada_Build_Non_Reloc_DLL; + -- Build a non relocatable DLL with Ada code + + --------------------- + -- Build_Reloc_DLL -- + --------------------- + + procedure Build_Reloc_DLL is + + Objects_Exp_File : constant OS_Lib.Argument_List := + Exp_File'Unchecked_Access & Ofiles; + -- Objects plus the export table (.exp) file + + Success : Boolean; + pragma Warnings (Off, Success); + + begin + if not Quiet then + Text_IO.Put_Line ("building relocatable DLL..."); + Text_IO.Put ("make " & Dll_File); + + if Build_Import then + Text_IO.Put_Line (" and " & Lib_File); + else + Text_IO.New_Line; + end if; + end if; + + -- 1) Build base file with objects files + + Utl.Gcc (Output_File => Jnk_File, + Files => Ofiles, + Options => All_Options, + Base_File => Bas_File, + Build_Lib => True); + + -- 2) Build exp from base file + + Utl.Dlltool (Def_File, Dll_File, Lib_File, + Base_File => Bas_File, + Exp_Table => Exp_File, + Build_Import => False); + + -- 3) Build base file with exp file and objects files + + Utl.Gcc (Output_File => Jnk_File, + Files => Objects_Exp_File, + Options => All_Options, + Base_File => Bas_File, + Build_Lib => True); + + -- 4) Build new exp from base file and the lib file (.a) + + Utl.Dlltool (Def_File, Dll_File, Lib_File, + Base_File => Bas_File, + Exp_Table => Exp_File, + Build_Import => Build_Import); + + -- 5) Build the dynamic library + + declare + Params : constant OS_Lib.Argument_List := + Map_Opt'Unchecked_Access & + Adr_Opt'Unchecked_Access & All_Options; + First_Param : Positive := Params'First + 1; + + begin + if Map_File then + First_Param := Params'First; + end if; + + Utl.Gcc + (Output_File => Dll_File, + Files => Objects_Exp_File, + Options => Params (First_Param .. Params'Last), + Build_Lib => True); + end; + + OS_Lib.Delete_File (Exp_File, Success); + OS_Lib.Delete_File (Bas_File, Success); + OS_Lib.Delete_File (Jnk_File, Success); + + exception + when others => + OS_Lib.Delete_File (Exp_File, Success); + OS_Lib.Delete_File (Bas_File, Success); + OS_Lib.Delete_File (Jnk_File, Success); + raise; + end Build_Reloc_DLL; + + ------------------------- + -- Ada_Build_Reloc_DLL -- + ------------------------- + + procedure Ada_Build_Reloc_DLL is + Success : Boolean; + pragma Warnings (Off, Success); + + begin + if not Quiet then + Text_IO.Put_Line ("Building relocatable DLL..."); + Text_IO.Put ("make " & Dll_File); + + if Build_Import then + Text_IO.Put_Line (" and " & Lib_File); + else + Text_IO.New_Line; + end if; + end if; + + -- 1) Build base file with objects files + + Utl.Gnatbind (L_Afiles, Options & Bargs_Options); + + declare + Params : constant OS_Lib.Argument_List := + Out_Opt'Unchecked_Access & + Jnk_File'Unchecked_Access & + Lib_Opt'Unchecked_Access & + Bas_Opt'Unchecked_Access & + Ofiles & + All_Options; + begin + Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params); + end; + + -- 2) Build exp from base file + + Utl.Dlltool (Def_File, Dll_File, Lib_File, + Base_File => Bas_File, + Exp_Table => Exp_File, + Build_Import => False); + + -- 3) Build base file with exp file and objects files + + Utl.Gnatbind (L_Afiles, Options & Bargs_Options); + + declare + Params : constant OS_Lib.Argument_List := + Out_Opt'Unchecked_Access & + Jnk_File'Unchecked_Access & + Lib_Opt'Unchecked_Access & + Bas_Opt'Unchecked_Access & + Exp_File'Unchecked_Access & + Ofiles & + All_Options; + begin + Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params); + end; + + -- 4) Build new exp from base file and the lib file (.a) + + Utl.Dlltool (Def_File, Dll_File, Lib_File, + Base_File => Bas_File, + Exp_Table => Exp_File, + Build_Import => Build_Import); + + -- 5) Build the dynamic library + + Utl.Gnatbind (L_Afiles, Options & Bargs_Options); + + declare + Params : constant OS_Lib.Argument_List := + Map_Opt'Unchecked_Access & + Out_Opt'Unchecked_Access & + Dll_File'Unchecked_Access & + Lib_Opt'Unchecked_Access & + Exp_File'Unchecked_Access & + Adr_Opt'Unchecked_Access & + Ofiles & + All_Options; + First_Param : Positive := Params'First + 1; + + begin + if Map_File then + First_Param := Params'First; + end if; + + Utl.Gnatlink + (L_Afiles (L_Afiles'Last).all, + Params (First_Param .. Params'Last)); + end; + + OS_Lib.Delete_File (Exp_File, Success); + OS_Lib.Delete_File (Bas_File, Success); + OS_Lib.Delete_File (Jnk_File, Success); + + exception + when others => + OS_Lib.Delete_File (Exp_File, Success); + OS_Lib.Delete_File (Bas_File, Success); + OS_Lib.Delete_File (Jnk_File, Success); + raise; + end Ada_Build_Reloc_DLL; + + ------------------------- + -- Build_Non_Reloc_DLL -- + ------------------------- + + procedure Build_Non_Reloc_DLL is + Success : Boolean; + pragma Warnings (Off, Success); + + begin + if not Quiet then + Text_IO.Put_Line ("building non relocatable DLL..."); + Text_IO.Put ("make " & Dll_File & + " using address " & Lib_Address); + + if Build_Import then + Text_IO.Put_Line (" and " & Lib_File); + else + Text_IO.New_Line; + end if; + end if; + + -- Build exp table and the lib .a file + + Utl.Dlltool (Def_File, Dll_File, Lib_File, + Exp_Table => Exp_File, + Build_Import => Build_Import); + + -- Build the DLL + + declare + Params : OS_Lib.Argument_List := + Adr_Opt'Unchecked_Access & All_Options; + begin + if Map_File then + Params := Map_Opt'Unchecked_Access & Params; + end if; + + Utl.Gcc (Output_File => Dll_File, + Files => Exp_File'Unchecked_Access & Ofiles, + Options => Params, + Build_Lib => True); + end; + + OS_Lib.Delete_File (Exp_File, Success); + + exception + when others => + OS_Lib.Delete_File (Exp_File, Success); + raise; + end Build_Non_Reloc_DLL; + + ----------------------------- + -- Ada_Build_Non_Reloc_DLL -- + ----------------------------- + + -- Build a non relocatable DLL with Ada code + + procedure Ada_Build_Non_Reloc_DLL is + Success : Boolean; + pragma Warnings (Off, Success); + + begin + if not Quiet then + Text_IO.Put_Line ("building non relocatable DLL..."); + Text_IO.Put ("make " & Dll_File & + " using address " & Lib_Address); + + if Build_Import then + Text_IO.Put_Line (" and " & Lib_File); + else + Text_IO.New_Line; + end if; + end if; + + -- Build exp table and the lib .a file + + Utl.Dlltool (Def_File, Dll_File, Lib_File, + Exp_Table => Exp_File, + Build_Import => Build_Import); + + -- Build the DLL + + Utl.Gnatbind (L_Afiles, Options & Bargs_Options); + + declare + Params : OS_Lib.Argument_List := + Out_Opt'Unchecked_Access & + Dll_File'Unchecked_Access & + Lib_Opt'Unchecked_Access & + Exp_File'Unchecked_Access & + Adr_Opt'Unchecked_Access & + Ofiles & + All_Options; + begin + if Map_File then + Params := Map_Opt'Unchecked_Access & Params; + end if; + + Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params); + end; + + OS_Lib.Delete_File (Exp_File, Success); + + exception + when others => + OS_Lib.Delete_File (Exp_File, Success); + raise; + end Ada_Build_Non_Reloc_DLL; + + -- Start of processing for Build_Dynamic_Library + + begin + -- On Windows the binder file must not be in the first position in the + -- list. This is due to the way DLL's are built on Windows. We swap the + -- first ali with the last one if it is the case. + + if L_Afiles'Length > 1 then + declare + Filename : constant String := + Directory_Operations.Base_Name + (L_Afiles (L_Afiles'First).all); + First : constant Positive := Filename'First; + + begin + if Filename (First .. First + 1) = "b~" then + L_Afiles (L_Afiles'Last) := Afiles (Afiles'First); + L_Afiles (L_Afiles'First) := Afiles (Afiles'Last); + end if; + end; + end if; + + case Relocatable is + when True => + if L_Afiles'Length = 0 then + Build_Reloc_DLL; + else + Ada_Build_Reloc_DLL; + end if; + + when False => + if L_Afiles'Length = 0 then + Build_Non_Reloc_DLL; + else + Ada_Build_Non_Reloc_DLL; + end if; + end case; + end Build_Dynamic_Library; + + -------------------------- + -- Build_Import_Library -- + -------------------------- + + procedure Build_Import_Library + (Lib_Filename : String; + Def_Filename : String) + is + procedure Build_Import_Library (Lib_Filename : String); + -- Build an import library. This is to build only a .a library to link + -- against a DLL. + + -------------------------- + -- Build_Import_Library -- + -------------------------- + + procedure Build_Import_Library (Lib_Filename : String) is + + function No_Lib_Prefix (Filename : String) return String; + -- Return Filename without the lib prefix if present + + ------------------- + -- No_Lib_Prefix -- + ------------------- + + function No_Lib_Prefix (Filename : String) return String is + begin + if Filename (Filename'First .. Filename'First + 2) = "lib" then + return Filename (Filename'First + 3 .. Filename'Last); + else + return Filename; + end if; + end No_Lib_Prefix; + + -- Local variables + + Def_File : String renames Def_Filename; + Dll_File : constant String := Get_Dll_Name (Lib_Filename); + Base_Filename : constant String := + MDLL.Fil.Ext_To (No_Lib_Prefix (Lib_Filename)); + Lib_File : constant String := "lib" & Base_Filename & ".dll.a"; + + -- Start of processing for Build_Import_Library + + begin + if not Quiet then + Text_IO.Put_Line ("Building import library..."); + Text_IO.Put_Line + ("make " & Lib_File & " to use dynamic library " & Dll_File); + end if; + + Utl.Dlltool + (Def_File, Dll_File, Lib_File, Build_Import => True); + end Build_Import_Library; + + -- Start of processing for Build_Import_Library + + begin + Build_Import_Library (Lib_Filename); + end Build_Import_Library; + + ------------------ + -- Get_Dll_Name -- + ------------------ + + function Get_Dll_Name (Lib_Filename : String) return String is + begin + if MDLL.Fil.Get_Ext (Lib_Filename) = "" then + return Lib_Filename & ".dll"; + else + return Lib_Filename; + end if; + end Get_Dll_Name; + +end MDLL; diff --git a/gcc/ada/mdll.ads b/gcc/ada/mdll.ads new file mode 100644 index 000000000..45c6a4578 --- /dev/null +++ b/gcc/ada/mdll.ads @@ -0,0 +1,81 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M D L L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides the core high level routines used by GNATDLL +-- to build Windows DLL + +with GNAT.OS_Lib; +-- Should have USE here ??? + +package MDLL is + + subtype Argument_List is GNAT.OS_Lib.Argument_List; + subtype Argument_List_Access is GNAT.OS_Lib.Argument_List_Access; + + Null_Argument_List : constant Argument_List := (1 .. 0 => new String'("")); + + Null_Argument_List_Access : Argument_List_Access := + new Argument_List (1 .. 0); + + Tools_Error : exception; + -- Comment required + + Verbose : Boolean := False; + Quiet : Boolean := False; + -- Comment required ??? + + Kill_Suffix : Boolean := False; + -- Kill_Suffix is used by dlltool to know whether or not the @nn suffix + -- should be removed from the exported names. When Kill_Suffix is set to + -- True then dlltool -k option is used. + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Afiles : Argument_List; + Options : Argument_List; + Bargs_Options : Argument_List; + Largs_Options : Argument_List; + Lib_Filename : String; + Def_Filename : String; + Lib_Address : String := ""; + Build_Import : Boolean := False; + Relocatable : Boolean := False; + Map_File : Boolean := False); + -- Build a DLL and the import library to link against the DLL. + -- this function handles relocatable and non relocatable DLL. + -- If the Afiles argument list contains some Ada units then it will + -- generate the right adainit and adafinal and integrate it in the DLL. + -- If the Afiles argument list is empty (there is only some object files + -- provided) then it will not try to build a binder file. This is ok to + -- build DLL containing no Ada code. If Map_File is set to True, a map + -- file named Lib_Filename & ".map" will be created. + + procedure Build_Import_Library + (Lib_Filename : String; + Def_Filename : String); + -- Build an import library (.a) from a definition files. An import library + -- is needed to link against a DLL. + +end MDLL; diff --git a/gcc/ada/memtrack.adb b/gcc/ada/memtrack.adb new file mode 100644 index 000000000..6b29e1748 --- /dev/null +++ b/gcc/ada/memtrack.adb @@ -0,0 +1,404 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 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 +-- Irix +-- Solaris +-- Tru64 +-- Alpha OpenVMS + +-- 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 : aliased array (0 .. Max_Call_Stack) of Traceback_Entry; + 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'Address, 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'Address, 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'Address, 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/mingw32.h b/gcc/ada/mingw32.h new file mode 100644 index 000000000..bee45852e --- /dev/null +++ b/gcc/ada/mingw32.h @@ -0,0 +1,135 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * M I N G W 3 2 * + * * + * C Header File * + * * + * 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 file provides some macros used for the MINGW32 platform. The main + goal is to be able to build GNAT with a standard MINGW32 C header + set. This files contains also the circuitry for the unicode support. */ + +#ifndef _MINGW32_H +#define _MINGW32_H + +#include <_mingw.h> + +/* The unicode support is activated by default starting with the 3.9 MingW + version. It is not possible to use it with previous version due to a bug + in the MingW runtime. */ + +#if (((__MINGW32_MAJOR_VERSION == 3 \ + && __MINGW32_MINOR_VERSION >= 9) \ + || (__MINGW32_MAJOR_VERSION >= 4) \ + || defined (__MINGW64)) \ + && !defined (RTX)) +#define GNAT_UNICODE_SUPPORT + +#else + +/* Older MingW versions have no definition for _tfreopen, add it here to have a + proper build without unicode support. */ +#ifndef _tfreopen +#define _tfreopen freopen +#endif + +#endif + +#ifdef GNAT_UNICODE_SUPPORT +#define _UNICODE /* For C runtime */ +#define UNICODE /* For Win32 API */ +#endif + +/* We need functionality available only starting with Windows XP */ +#ifndef _WIN32_WINNT +#define _WIN32_WINNT 0x0501 +#endif + +#include +#include + +/* After including this file it is possible to use the character t as prefix + to routines. If GNAT_UNICODE_SUPPORT is defined then the unicode enabled + versions will be used. */ + +/* Copy to/from wide-string, if GNAT_UNICODE_SUPPORT activated this will do + the proper translations using the UTF-8 encoding. */ + +#ifdef GNAT_UNICODE_SUPPORT + +extern UINT CurrentCodePage; + +/* Macros to convert to/from the code page specified in CurrentCodePage. */ +#define S2WSC(wstr,str,len) \ + MultiByteToWideChar (CurrentCodePage,0,str,-1,wstr,len) +#define WS2SC(str,wstr,len) \ + WideCharToMultiByte (CurrentCodePage,0,wstr,-1,str,len,NULL,NULL) + +/* Macros to convert to/from UTF-8 code page. */ +#define S2WSU(wstr,str,len) \ + MultiByteToWideChar (CP_UTF8,0,str,-1,wstr,len) +#define WS2SU(str,wstr,len) \ + WideCharToMultiByte (CP_UTF8,0,wstr,-1,str,len,NULL,NULL) + +/* Macros to convert to/from Windows default code page. */ +#define S2WS(wstr,str,len) \ + MultiByteToWideChar (CP_ACP,0,str,-1,wstr,len) +#define WS2S(str,wstr,len) \ + WideCharToMultiByte (CP_ACP,0,wstr,-1,str,len,NULL,NULL) +#else +#define S2WSC(wstr,str,len) strncpy(wstr,str,len) +#define WS2SC(str,wstr,len) strncpy(str,wstr,len) +#define S2WSU(wstr,str,len) strncpy(wstr,str,len) +#define WS2SU(str,wstr,len) strncpy(str,wstr,len) +#define S2WS(wstr,str,len) strncpy(wstr,str,len) +#define WS2S(str,wstr,len) strncpy(str,wstr,len) +#endif + +#include + +/* STD_MINGW: standard if MINGW32 version > 1.3, we have switched to this + version instead of the previous enhanced version to ease building GNAT on + Windows platforms. By using STD_MINGW or OLD_MINGW it is possible to build + GNAT using both MingW include files (Old MingW + ACT changes and standard + MingW starting with version 1.3. + For w64 Mingw the define STD_MINGW is always set to value 1, because + there is no old header set present. */ +#ifdef _WIN64 +#define STD_MINGW 1 +#else +#define STD_MINGW ((__MINGW32_MAJOR_VERSION == 1 \ + && __MINGW32_MINOR_VERSION >= 3) \ + || (__MINGW32_MAJOR_VERSION >= 2)) +#endif + +#define OLD_MINGW (!(STD_MINGW)) + +#ifndef MAXPATHLEN +#define MAXPATHLEN MAX_PATH +#endif + +#endif /* _MINGW32_H */ diff --git a/gcc/ada/mkdir.c b/gcc/ada/mkdir.c new file mode 100644 index 000000000..debd80677 --- /dev/null +++ b/gcc/ada/mkdir.c @@ -0,0 +1,73 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * M K D I R * + * * + * C Implementation File * + * * + * 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. * + * * + ****************************************************************************/ + +#ifdef __vxworks +#include "vxWorks.h" +#include +#endif /* __vxworks */ + +#ifdef IN_RTS +#include "tconfig.h" +#include "tsystem.h" +#include +#else +#include "config.h" +#include "system.h" +#endif + +#ifdef __MINGW32__ +#include "mingw32.h" +#include +#ifdef MAXPATHLEN +#define GNAT_MAX_PATH_LEN MAXPATHLEN +#else +#define GNAT_MAX_PATH_LEN 256 +#endif +#endif + +#include "adaint.h" + +/* This function provides a portable binding to the mkdir function. */ + +int +__gnat_mkdir (char *dir_name) +{ +#if defined (__vxworks) && !(defined (__RTP__) && (_WRS_VXWORKS_MINOR != 0)) + return mkdir (dir_name); +#elif defined (__MINGW32__) + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + + S2WSC (wname, dir_name, GNAT_MAX_PATH_LEN + 2); + return _tmkdir (wname); +#else + return mkdir (dir_name, S_IRWXU | S_IRWXG | S_IRWXO); +#endif +} diff --git a/gcc/ada/mlib-fil.adb b/gcc/ada/mlib-fil.adb new file mode 100644 index 000000000..8632ef3ca --- /dev/null +++ b/gcc/ada/mlib-fil.adb @@ -0,0 +1,149 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . F I L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2007, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a set of routines to deal with file extensions + +with Ada.Strings.Fixed; +with MLib.Tgt; + +package body MLib.Fil is + + use Ada; + + package Target renames MLib.Tgt; + + --------------- + -- Append_To -- + --------------- + + function Append_To + (Filename : String; + Ext : String) return String + is + begin + if Ext'Length = 0 then + return Filename; + + elsif Filename (Filename'Last) = '.' then + if Ext (Ext'First) = '.' then + return Filename & Ext (Ext'First + 1 .. Ext'Last); + + else + return Filename & Ext; + end if; + + else + if Ext (Ext'First) = '.' then + return Filename & Ext; + + else + return Filename & '.' & Ext; + end if; + end if; + end Append_To; + + ------------ + -- Ext_To -- + ------------ + + function Ext_To + (Filename : String; + New_Ext : String := "") return String + is + use Strings.Fixed; + + J : constant Natural := + Index (Source => Filename, + Pattern => ".", + Going => Strings.Backward); + + begin + if J = 0 then + if New_Ext = "" then + return Filename; + else + return Filename & "." & New_Ext; + end if; + + else + if New_Ext = "" then + return Head (Filename, J - 1); + else + return Head (Filename, J - 1) & '.' & New_Ext; + end if; + end if; + end Ext_To; + + ------------- + -- Get_Ext -- + ------------- + + function Get_Ext (Filename : String) return String is + use Strings.Fixed; + + J : constant Natural := + Index (Source => Filename, + Pattern => ".", + Going => Strings.Backward); + + begin + if J = 0 then + return ""; + else + return Filename (J .. Filename'Last); + end if; + end Get_Ext; + + ---------------- + -- Is_Archive -- + ---------------- + + function Is_Archive (Filename : String) return Boolean is + Ext : constant String := Get_Ext (Filename); + begin + return Target.Is_Archive_Ext (Ext); + end Is_Archive; + + ---------- + -- Is_C -- + ---------- + + function Is_C (Filename : String) return Boolean is + Ext : constant String := Get_Ext (Filename); + begin + return Target.Is_C_Ext (Ext); + end Is_C; + + ------------ + -- Is_Obj -- + ------------ + + function Is_Obj (Filename : String) return Boolean is + Ext : constant String := Get_Ext (Filename); + begin + return Target.Is_Object_Ext (Ext); + end Is_Obj; + +end MLib.Fil; diff --git a/gcc/ada/mlib-fil.ads b/gcc/ada/mlib-fil.ads new file mode 100644 index 000000000..dd5edfeb3 --- /dev/null +++ b/gcc/ada/mlib-fil.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . F I L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2007, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a set of routines to deal with file extensions + +package MLib.Fil is + + function Ext_To + (Filename : String; + New_Ext : String := "") return String; + -- Return Filename with the extension changed to New_Ext + + function Append_To + (Filename : String; + Ext : String) return String; + -- Return Filename with the extension Ext + + function Get_Ext (Filename : String) return String; + -- Return extension of filename + + function Is_Archive (Filename : String) return Boolean; + -- Test if filename is an archive + + function Is_C (Filename : String) return Boolean; + -- Test if Filename is a C file + + function Is_Obj (Filename : String) return Boolean; + -- Test if Filename is an object file + +end MLib.Fil; diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb new file mode 100644 index 000000000..8c0d4e1b0 --- /dev/null +++ b/gcc/ada/mlib-prj.adb @@ -0,0 +1,2494 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . P R J -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with ALI; use ALI; +with Gnatvsn; use Gnatvsn; +with MLib.Fil; use MLib.Fil; +with MLib.Tgt; use MLib.Tgt; +with MLib.Utl; use MLib.Utl; +with Opt; +with Output; use Output; +with Prj.Com; use Prj.Com; +with Prj.Env; use Prj.Env; +with Prj.Util; use Prj.Util; +with Sinput.P; +with Snames; use Snames; +with Switch; use Switch; +with Table; +with Targparm; use Targparm; +with Tempdir; +with Types; use Types; + +with Ada.Characters.Handling; + +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.HTable; +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System; use System; +with System.Case_Util; use System.Case_Util; + +package body MLib.Prj is + + Prj_Add_Obj_Files : Types.Int; + pragma Import (C, Prj_Add_Obj_Files, "__gnat_prj_add_obj_files"); + Add_Object_Files : constant Boolean := Prj_Add_Obj_Files /= 0; + -- Indicates if object files in pragmas Linker_Options (found in the + -- binder generated file) should be taken when linking a stand-alone + -- library. False for Windows, True for other platforms. + + ALI_Suffix : constant String := ".ali"; + + B_Start : String_Ptr := new String'("b~"); + -- Prefix of bind file, changed to b__ for VMS + + S_Osinte_Ads : File_Name_Type := No_File; + -- Name_Id for "s-osinte.ads" + + S_Dec_Ads : File_Name_Type := No_File; + -- Name_Id for "dec.ads" + + G_Trasym_Ads : File_Name_Type := No_File; + -- Name_Id for "g-trasym.ads" + + Arguments : String_List_Access := No_Argument; + -- Used to accumulate arguments for the invocation of gnatbind and of + -- the compiler. Also used to collect the interface ALI when copying + -- the ALI files to the library directory. + + Argument_Number : Natural := 0; + -- Index of the last argument in Arguments + + Initial_Argument_Max : constant := 10; + + No_Main_String : aliased String := "-n"; + No_Main : constant String_Access := No_Main_String'Access; + + Output_Switch_String : aliased String := "-o"; + Output_Switch : constant String_Access := Output_Switch_String'Access; + + Compile_Switch_String : aliased String := "-c"; + Compile_Switch : constant String_Access := Compile_Switch_String'Access; + + Auto_Initialize : constant String := "-a"; + + -- List of objects to put inside the library + + Object_Files : Argument_List_Access; + + package Objects is new Table.Table + (Table_Name => "Mlib.Prj.Objects", + Table_Component_Type => String_Access, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 100); + + package Objects_Htable is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Boolean, + No_Element => False, + Key => Name_Id, + Hash => Hash, + Equal => "="); + + -- List of ALI files + + Ali_Files : Argument_List_Access; + + package ALIs is new Table.Table + (Table_Name => "Mlib.Prj.Alis", + Table_Component_Type => String_Access, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 100); + + -- List of options set in the command line + + Options : Argument_List_Access; + + package Opts is new Table.Table + (Table_Name => "Mlib.Prj.Opts", + Table_Component_Type => String_Access, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 5, + Table_Increment => 100); + + -- All the ALI file in the library + + package Library_ALIs is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Boolean, + No_Element => False, + Key => File_Name_Type, + Hash => Hash, + Equal => "="); + + -- The ALI files in the interface sets + + package Interface_ALIs is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Boolean, + No_Element => False, + Key => File_Name_Type, + Hash => Hash, + Equal => "="); + + -- The ALI files that have been processed to check if the corresponding + -- library unit is in the interface set. + + package Processed_ALIs is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Boolean, + No_Element => False, + Key => File_Name_Type, + Hash => Hash, + Equal => "="); + + -- The projects imported directly or indirectly + + package Processed_Projects is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Boolean, + No_Element => False, + Key => Name_Id, + Hash => Hash, + Equal => "="); + + -- The library projects imported directly or indirectly + + package Library_Projs is new Table.Table ( + Table_Component_Type => Project_Id, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 10, + Table_Name => "Make.Library_Projs"); + + type Build_Mode_State is (None, Static, Dynamic, Relocatable); + + procedure Add_Argument (S : String); + -- Add one argument to Arguments array, if array is full, double its size + + function ALI_File_Name (Source : String) return String; + -- Return the ALI file name corresponding to a source + + procedure Check (Filename : String); + -- Check if filename is a regular file. Fail if it is not + + procedure Check_Context; + -- Check each object files in table Object_Files + -- Fail if any of them is not a regular file + + procedure Copy_Interface_Sources + (For_Project : Project_Id; + In_Tree : Project_Tree_Ref; + Interfaces : Argument_List; + To_Dir : Path_Name_Type); + -- Copy the interface sources of a SAL to directory To_Dir + + procedure Display (Executable : String); + -- Display invocation of gnatbind and of the compiler with the arguments + -- in Arguments, except when Quiet_Output is True. + + function Index (S, Pattern : String) return Natural; + -- Return the last occurrence of Pattern in S, or 0 if none + + procedure Process_Binder_File (Name : String); + -- For Stand-Alone libraries, get the Linker Options in the binder + -- generated file. + + procedure Reset_Tables; + -- Make sure that all the above tables are empty + -- (Objects, Ali_Files, Options). + + function SALs_Use_Constructors return Boolean; + -- Indicate if Stand-Alone Libraries are automatically initialized using + -- the constructor mechanism. + + ------------------ + -- Add_Argument -- + ------------------ + + procedure Add_Argument (S : String) is + begin + if Argument_Number = Arguments'Last then + declare + New_Args : constant String_List_Access := + new String_List (1 .. 2 * Arguments'Last); + + begin + -- Copy the String_Accesses and set them to null in Arguments + -- so that they will not be deallocated by the call to + -- Free (Arguments). + + New_Args (Arguments'Range) := Arguments.all; + Arguments.all := (others => null); + Free (Arguments); + Arguments := New_Args; + end; + end if; + + Argument_Number := Argument_Number + 1; + Arguments (Argument_Number) := new String'(S); + end Add_Argument; + + ------------------- + -- ALI_File_Name -- + ------------------- + + function ALI_File_Name (Source : String) return String is + begin + -- If the source name has an extension, then replace it with + -- the ALI suffix. + + for Index in reverse Source'First + 1 .. Source'Last loop + if Source (Index) = '.' then + return Source (Source'First .. Index - 1) & ALI_Suffix; + end if; + end loop; + + -- If there is no dot, or if it is the first character, just add the + -- ALI suffix. + + return Source & ALI_Suffix; + end ALI_File_Name; + + ------------------- + -- Build_Library -- + ------------------- + + procedure Build_Library + (For_Project : Project_Id; + In_Tree : Project_Tree_Ref; + Gnatbind : String; + Gnatbind_Path : String_Access; + Gcc : String; + Gcc_Path : String_Access; + Bind : Boolean := True; + Link : Boolean := True) + is + Maximum_Size : Integer; + pragma Import (C, Maximum_Size, "__gnat_link_max"); + -- Maximum number of bytes to put in an invocation of the + -- gnatbind. + + Size : Integer; + -- The number of bytes for the invocation of the gnatbind + + Warning_For_Library : Boolean := False; + -- Set to True for the first warning about a unit missing from the + -- interface set. + + Current_Proj : Project_Id; + + Libgnarl_Needed : Yes_No_Unknown := For_Project.Libgnarl_Needed; + -- Set to True if library needs to be linked with libgnarl + + Libdecgnat_Needed : Boolean := False; + -- On OpenVMS, set to True if library needs to be linked with libdecgnat + + Gtrasymobj_Needed : Boolean := False; + -- On OpenVMS, set to True if library needs to be linked with + -- g-trasym.obj. + + Object_Directory_Path : constant String := + Get_Name_String + (For_Project.Object_Directory.Display_Name); + + Standalone : constant Boolean := For_Project.Standalone_Library; + + Project_Name : constant String := Get_Name_String (For_Project.Name); + + Current_Dir : constant String := Get_Current_Dir; + + Lib_Filename : String_Access; + Lib_Dirpath : String_Access; + Lib_Version : String_Access := new String'(""); + + The_Build_Mode : Build_Mode_State := None; + + Success : Boolean := False; + + Library_Options : Variable_Value := Nil_Variable_Value; + + Driver_Name : Name_Id := No_Name; + + In_Main_Object_Directory : Boolean := True; + + Foreign_Sources : Boolean; + + Rpath : String_Access := null; + -- Allocated only if Path Option is supported + + Rpath_Last : Natural := 0; + -- Index of last valid character of Rpath + + Initial_Rpath_Length : constant := 200; + -- Initial size of Rpath, when first allocated + + Path_Option : String_Access := Linker_Library_Path_Option; + -- If null, Path Option is not supported. + -- Not a constant so that it can be deallocated. + + First_ALI : File_Name_Type := No_File; + -- Store the ALI file name of a source of the library (the first found) + + procedure Add_ALI_For (Source : File_Name_Type); + -- Add the name of the ALI file corresponding to Source to the + -- Arguments. + + procedure Add_Rpath (Path : String); + -- Add a path name to Rpath + + function Check_Project (P : Project_Id) return Boolean; + -- Returns True if P is For_Project or a project extended by For_Project + + procedure Check_Libs (ALI_File : String; Main_Project : Boolean); + -- Set Libgnarl_Needed if the ALI_File indicates that there is a need + -- to link with -lgnarl (this is the case when there is a dependency + -- on s-osinte.ads). On OpenVMS, set Libdecgnat_Needed if the ALI file + -- indicates that there is a need to link with -ldecgnat (this is the + -- case when there is a dependency on dec.ads), and set + -- Gtrasymobj_Needed if there is a dependency on g-trasym.ads. + + procedure Process (The_ALI : File_Name_Type); + -- Check if the closure of a library unit which is or should be in the + -- interface set is also in the interface set. Issue a warning for each + -- missing library unit. + + procedure Process_Imported_Libraries; + -- Add the -L and -l switches for the imported Library Project Files, + -- and, if Path Option is supported, the library directory path names + -- to Rpath. + + ----------------- + -- Add_ALI_For -- + ----------------- + + procedure Add_ALI_For (Source : File_Name_Type) is + ALI : constant String := ALI_File_Name (Get_Name_String (Source)); + ALI_Id : File_Name_Type; + + begin + if Bind then + Add_Argument (ALI); + end if; + + Name_Len := 0; + Add_Str_To_Name_Buffer (S => ALI); + ALI_Id := Name_Find; + + -- Add the ALI file name to the library ALIs + + if Bind then + Library_ALIs.Set (ALI_Id, True); + end if; + + -- Set First_ALI, if not already done + + if First_ALI = No_File then + First_ALI := ALI_Id; + end if; + end Add_ALI_For; + + --------------- + -- Add_Rpath -- + --------------- + + procedure Add_Rpath (Path : String) is + + procedure Double; + -- Double Rpath size + + ------------ + -- Double -- + ------------ + + procedure Double is + New_Rpath : constant String_Access := + new String (1 .. 2 * Rpath'Length); + begin + New_Rpath (1 .. Rpath_Last) := Rpath (1 .. Rpath_Last); + Free (Rpath); + Rpath := New_Rpath; + end Double; + + -- Start of processing for Add_Rpath + + begin + -- If first path, allocate initial Rpath + + if Rpath = null then + Rpath := new String (1 .. Initial_Rpath_Length); + Rpath_Last := 0; + + else + -- Otherwise, add a path separator between two path names + + if Rpath_Last = Rpath'Last then + Double; + end if; + + Rpath_Last := Rpath_Last + 1; + Rpath (Rpath_Last) := Path_Separator; + end if; + + -- Increase Rpath size until it is large enough + + while Rpath_Last + Path'Length > Rpath'Last loop + Double; + end loop; + + -- Add the path name + + Rpath (Rpath_Last + 1 .. Rpath_Last + Path'Length) := Path; + Rpath_Last := Rpath_Last + Path'Length; + end Add_Rpath; + + ------------------- + -- Check_Project -- + ------------------- + + function Check_Project (P : Project_Id) return Boolean is + begin + if P = For_Project then + return True; + + elsif P /= No_Project then + declare + Proj : Project_Id; + + begin + Proj := For_Project; + while Proj.Extends /= No_Project loop + if P = Proj.Extends then + return True; + end if; + + Proj := Proj.Extends; + end loop; + end; + end if; + + return False; + end Check_Project; + + ---------------- + -- Check_Libs -- + ---------------- + + procedure Check_Libs (ALI_File : String; Main_Project : Boolean) is + Lib_File : File_Name_Type; + Text : Text_Buffer_Ptr; + Id : ALI.ALI_Id; + + begin + if Libgnarl_Needed /= Yes + or else + (Main_Project + and then OpenVMS_On_Target + and then ((not Libdecgnat_Needed) or (not Gtrasymobj_Needed))) + then + -- Scan the ALI file + + Name_Len := ALI_File'Length; + Name_Buffer (1 .. Name_Len) := ALI_File; + Lib_File := Name_Find; + Text := Read_Library_Info (Lib_File, True); + + Id := ALI.Scan_ALI + (F => Lib_File, + T => Text, + Ignore_ED => False, + Err => True, + Read_Lines => "D"); + Free (Text); + + -- Look for s-osinte.ads in the dependencies + + for Index in ALI.ALIs.Table (Id).First_Sdep .. + ALI.ALIs.Table (Id).Last_Sdep + loop + if ALI.Sdep.Table (Index).Sfile = S_Osinte_Ads then + Libgnarl_Needed := Yes; + + if Main_Project then + For_Project.Libgnarl_Needed := Yes; + else + exit; + end if; + + elsif OpenVMS_On_Target then + if ALI.Sdep.Table (Index).Sfile = S_Dec_Ads then + Libdecgnat_Needed := True; + + elsif ALI.Sdep.Table (Index).Sfile = G_Trasym_Ads then + Gtrasymobj_Needed := True; + end if; + end if; + end loop; + end if; + end Check_Libs; + + ------------- + -- Process -- + ------------- + + procedure Process (The_ALI : File_Name_Type) is + Text : Text_Buffer_Ptr; + Idread : ALI_Id; + First_Unit : ALI.Unit_Id; + Last_Unit : ALI.Unit_Id; + Unit_Data : Unit_Record; + Afile : File_Name_Type; + + begin + -- Nothing to do if the ALI file has already been processed. + -- This happens if an interface imports another interface. + + if not Processed_ALIs.Get (The_ALI) then + Processed_ALIs.Set (The_ALI, True); + Text := Read_Library_Info (The_ALI); + + if Text /= null then + Idread := + Scan_ALI + (F => The_ALI, + T => Text, + Ignore_ED => False, + Err => True); + Free (Text); + + if Idread /= No_ALI_Id then + First_Unit := ALI.ALIs.Table (Idread).First_Unit; + Last_Unit := ALI.ALIs.Table (Idread).Last_Unit; + + -- Process both unit (spec and body) if the body is needed + -- by the spec (inline or generic). Otherwise, just process + -- the spec. + + if First_Unit /= Last_Unit and then + not ALI.Units.Table (Last_Unit).Body_Needed_For_SAL + then + First_Unit := Last_Unit; + end if; + + for Unit in First_Unit .. Last_Unit loop + Unit_Data := ALI.Units.Table (Unit); + + -- Check if each withed unit which is in the library is + -- also in the interface set, if it has not yet been + -- processed. + + for W in Unit_Data.First_With .. Unit_Data.Last_With loop + Afile := Withs.Table (W).Afile; + + if Afile /= No_File and then Library_ALIs.Get (Afile) + and then not Processed_ALIs.Get (Afile) + then + if not Interface_ALIs.Get (Afile) then + if not Warning_For_Library then + Write_Str ("Warning: In library project """); + Get_Name_String (Current_Proj.Name); + To_Mixed (Name_Buffer (1 .. Name_Len)); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Line (""""); + Warning_For_Library := True; + end if; + + Write_Str (" Unit """); + Get_Name_String (Withs.Table (W).Uname); + To_Mixed (Name_Buffer (1 .. Name_Len - 2)); + Write_Str (Name_Buffer (1 .. Name_Len - 2)); + Write_Line (""" is not in the interface set"); + Write_Str (" but it is needed by "); + + case Unit_Data.Utype is + when Is_Spec => + Write_Str ("the spec of "); + + when Is_Body => + Write_Str ("the body of "); + + when others => + null; + end case; + + Write_Str (""""); + Get_Name_String (Unit_Data.Uname); + To_Mixed (Name_Buffer (1 .. Name_Len - 2)); + Write_Str (Name_Buffer (1 .. Name_Len - 2)); + Write_Line (""""); + end if; + + -- Now, process this unit + + Process (Afile); + end if; + end loop; + end loop; + end if; + end if; + end if; + end Process; + + -------------------------------- + -- Process_Imported_Libraries -- + -------------------------------- + + procedure Process_Imported_Libraries is + Current : Project_Id; + + procedure Process_Project (Project : Project_Id); + -- Process Project and its imported projects recursively. + -- Add any library projects to table Library_Projs. + + --------------------- + -- Process_Project -- + --------------------- + + procedure Process_Project (Project : Project_Id) is + Imported : Project_List; + + begin + -- Nothing to do if process has already been processed + + if not Processed_Projects.Get (Project.Name) then + Processed_Projects.Set (Project.Name, True); + + -- Call Process_Project recursively for any imported project. + -- We first process the imported projects to guarantee that + -- we have a proper reverse order for the libraries. + + Imported := Project.Imported_Projects; + while Imported /= null loop + if Imported.Project /= No_Project then + Process_Project (Imported.Project); + end if; + + Imported := Imported.Next; + end loop; + + -- If it is a library project, add it to Library_Projs + + if Project /= For_Project and then Project.Library then + Library_Projs.Increment_Last; + Library_Projs.Table (Library_Projs.Last) := Project; + + -- Check if because of this library we need to use libgnarl + + if Libgnarl_Needed = Unknown then + if Project.Libgnarl_Needed = Unknown + and then Project.Object_Directory /= No_Path_Information + then + -- Check if libgnarl is needed for this library + + declare + Object_Dir_Path : constant String := + Get_Name_String + (Project.Object_Directory. + Display_Name); + Object_Dir : Dir_Type; + Filename : String (1 .. 255); + Last : Natural; + + begin + Open (Object_Dir, Object_Dir_Path); + + -- For all entries in the object directory + + loop + Read (Object_Dir, Filename, Last); + exit when Last = 0; + + -- Check if it is an object file + + if Is_Obj (Filename (1 .. Last)) then + declare + Object_Path : constant String := + Normalize_Pathname + (Object_Dir_Path & + Directory_Separator & + Filename (1 .. Last)); + ALI_File : constant String := + Ext_To + (Object_Path, "ali"); + + begin + if Is_Regular_File (ALI_File) then + + -- Find out if for this ALI file, + -- libgnarl is necessary. + + Check_Libs + (ALI_File, Main_Project => False); + + if Libgnarl_Needed = Yes then + Project.Libgnarl_Needed := Yes; + For_Project.Libgnarl_Needed := Yes; + exit; + end if; + end if; + end; + end if; + end loop; + + Close (Object_Dir); + end; + end if; + + if Project.Libgnarl_Needed = Yes then + Libgnarl_Needed := Yes; + For_Project.Libgnarl_Needed := Yes; + end if; + end if; + end if; + end if; + end Process_Project; + + -- Start of processing for Process_Imported_Libraries + + begin + -- Build list of library projects imported directly or indirectly, + -- in the reverse order. + + Process_Project (For_Project); + + -- Add the -L and -l switches and, if the Rpath option is supported, + -- add the directory to the Rpath. As the library projects are in the + -- wrong order, process from the last to the first. + + for Index in reverse 1 .. Library_Projs.Last loop + Current := Library_Projs.Table (Index); + + Get_Name_String (Current.Library_Dir.Display_Name); + Opts.Increment_Last; + Opts.Table (Opts.Last) := + new String'("-L" & Name_Buffer (1 .. Name_Len)); + + if Path_Option /= null then + Add_Rpath (Name_Buffer (1 .. Name_Len)); + end if; + + Opts.Increment_Last; + Opts.Table (Opts.Last) := + new String'("-l" & Get_Name_String (Current.Library_Name)); + end loop; + end Process_Imported_Libraries; + + -- Start of processing for Build_Library + + begin + Reset_Tables; + + -- Fail if project is not a library project + + if not For_Project.Library then + Com.Fail ("project """ & Project_Name & """ has no library"); + end if; + + -- Do not attempt to build the library if it is externally built + + if For_Project.Externally_Built then + return; + end if; + + -- If this is the first time Build_Library is called, get the Name_Id + -- of "s-osinte.ads". + + if S_Osinte_Ads = No_File then + Name_Len := 0; + Add_Str_To_Name_Buffer ("s-osinte.ads"); + S_Osinte_Ads := Name_Find; + end if; + + if S_Dec_Ads = No_File then + Name_Len := 0; + Add_Str_To_Name_Buffer ("dec.ads"); + S_Dec_Ads := Name_Find; + end if; + + if G_Trasym_Ads = No_File then + Name_Len := 0; + Add_Str_To_Name_Buffer ("g-trasym.ads"); + G_Trasym_Ads := Name_Find; + end if; + + -- We work in the object directory + + Change_Dir (Object_Directory_Path); + + if Standalone then + + -- Call gnatbind only if Bind is True + + if Bind then + if Gnatbind_Path = null then + Com.Fail ("unable to locate " & Gnatbind); + end if; + + if Gcc_Path = null then + Com.Fail ("unable to locate " & Gcc); + end if; + + -- Allocate Arguments, if it is the first time we see a standalone + -- library. + + if Arguments = No_Argument then + Arguments := new String_List (1 .. Initial_Argument_Max); + end if; + + -- Add "-n -o b~.adb (b__.adb on VMS) -L" + + Argument_Number := 2; + Arguments (1) := No_Main; + Arguments (2) := Output_Switch; + + if OpenVMS_On_Target then + B_Start := new String'("b__"); + end if; + + Add_Argument + (B_Start.all + & Get_Name_String (For_Project.Library_Name) & ".adb"); + Add_Argument ("-L" & Get_Name_String (For_Project.Library_Name)); + + if For_Project.Lib_Auto_Init and then SALs_Use_Constructors then + Add_Argument (Auto_Initialize); + end if; + + -- Check if Binder'Default_Switches ("Ada") is defined. If it is, + -- add these switches to call gnatbind. + + declare + Binder_Package : constant Package_Id := + Value_Of + (Name => Name_Binder, + In_Packages => For_Project.Decl.Packages, + In_Tree => In_Tree); + + begin + if Binder_Package /= No_Package then + declare + Defaults : constant Array_Element_Id := + Value_Of + (Name => Name_Default_Switches, + In_Arrays => + In_Tree.Packages.Table + (Binder_Package).Decl.Arrays, + In_Tree => In_Tree); + Switches : Variable_Value := Nil_Variable_Value; + + Switch : String_List_Id := Nil_String; + + begin + if Defaults /= No_Array_Element then + Switches := + Value_Of + (Index => Name_Ada, + Src_Index => 0, + In_Array => Defaults, + In_Tree => In_Tree); + + if not Switches.Default then + Switch := Switches.Values; + + while Switch /= Nil_String loop + Add_Argument + (Get_Name_String + (In_Tree.String_Elements.Table + (Switch).Value)); + Switch := In_Tree.String_Elements. + Table (Switch).Next; + end loop; + end if; + end if; + end; + end if; + end; + end if; + + -- Get all the ALI files of the project file. We do that even if + -- Bind is False, so that First_ALI is set. + + declare + Unit : Unit_Index; + + begin + Library_ALIs.Reset; + Interface_ALIs.Reset; + Processed_ALIs.Reset; + + Unit := Units_Htable.Get_First (In_Tree.Units_HT); + while Unit /= No_Unit_Index loop + if Unit.File_Names (Impl) /= null + and then not Unit.File_Names (Impl).Locally_Removed + then + if Check_Project (Unit.File_Names (Impl).Project) then + if Unit.File_Names (Spec) = null then + declare + Src_Ind : Source_File_Index; + + begin + Src_Ind := Sinput.P.Load_Project_File + (Get_Name_String + (Unit.File_Names (Impl).Path.Name)); + + -- Add the ALI file only if it is not a subunit + + if not + Sinput.P.Source_File_Is_Subunit (Src_Ind) + then + Add_ALI_For (Unit.File_Names (Impl).File); + exit when not Bind; + end if; + end; + + else + Add_ALI_For (Unit.File_Names (Impl).File); + exit when not Bind; + end if; + end if; + + elsif Unit.File_Names (Spec) /= null + and then not Unit.File_Names (Spec).Locally_Removed + and then Check_Project (Unit.File_Names (Spec).Project) + then + Add_ALI_For (Unit.File_Names (Spec).File); + exit when not Bind; + end if; + + Unit := Units_Htable.Get_Next (In_Tree.Units_HT); + end loop; + end; + + -- Continue setup and call gnatbind if Bind is True + + if Bind then + + -- Get an eventual --RTS from the ALI file + + if First_ALI /= No_File then + declare + T : Text_Buffer_Ptr; + A : ALI_Id; + + begin + -- Load the ALI file + + T := Read_Library_Info (First_ALI, True); + + -- Read it + + A := Scan_ALI + (First_ALI, T, Ignore_ED => False, Err => False); + + if A /= No_ALI_Id then + for Index in + ALI.Units.Table + (ALI.ALIs.Table (A).First_Unit).First_Arg .. + ALI.Units.Table + (ALI.ALIs.Table (A).First_Unit).Last_Arg + loop + -- If --RTS found, add switch to call gnatbind + + declare + Arg : String_Ptr renames Args.Table (Index); + begin + if Arg'Length >= 6 and then + Arg (Arg'First + 2 .. Arg'First + 5) = "RTS=" + then + Add_Argument (Arg.all); + exit; + end if; + end; + end loop; + end if; + end; + end if; + + -- Set the paths + + Set_Ada_Paths + (Project => For_Project, + In_Tree => In_Tree, + Including_Libraries => True); + + -- Display the gnatbind command, if not in quiet output + + Display (Gnatbind); + + Size := 0; + for J in 1 .. Argument_Number loop + Size := Size + Arguments (J)'Length + 1; + end loop; + + -- Invoke gnatbind with the arguments if the size is not too large + + if Size <= Maximum_Size then + Spawn + (Gnatbind_Path.all, + Arguments (1 .. Argument_Number), + Success); + + else + -- Otherwise create a temporary response file + + declare + FD : File_Descriptor; + Path : Path_Name_Type; + Args : Argument_List (1 .. 1); + EOL : constant String (1 .. 1) := (1 => ASCII.LF); + Status : Integer; + Succ : Boolean; + Quotes_Needed : Boolean; + Last_Char : Natural; + Ch : Character; + + begin + Tempdir.Create_Temp_File (FD, Path); + Args (1) := new String'("@" & Get_Name_String (Path)); + + for J in 1 .. Argument_Number loop + + -- Check if the argument should be quoted + + Quotes_Needed := False; + Last_Char := Arguments (J)'Length; + + for K in Arguments (J)'Range loop + Ch := Arguments (J) (K); + + if Ch = ' ' or else Ch = ASCII.HT or else Ch = '"' then + Quotes_Needed := True; + exit; + end if; + end loop; + + if Quotes_Needed then + + -- Quote the argument, doubling '"' + + declare + Arg : String (1 .. Arguments (J)'Length * 2 + 2); + + begin + Arg (1) := '"'; + Last_Char := 1; + + for K in Arguments (J)'Range loop + Ch := Arguments (J) (K); + Last_Char := Last_Char + 1; + Arg (Last_Char) := Ch; + + if Ch = '"' then + Last_Char := Last_Char + 1; + Arg (Last_Char) := '"'; + end if; + end loop; + + Last_Char := Last_Char + 1; + Arg (Last_Char) := '"'; + + Status := Write (FD, Arg'Address, Last_Char); + end; + + else + Status := Write + (FD, + Arguments (J) (Arguments (J)'First)'Address, + Last_Char); + end if; + + if Status /= Last_Char then + Fail ("disk full"); + end if; + + Status := Write (FD, EOL (1)'Address, 1); + + if Status /= 1 then + Fail ("disk full"); + end if; + end loop; + + Close (FD); + + -- And invoke gnatbind with this response file + + Spawn (Gnatbind_Path.all, Args, Success); + + Delete_File (Get_Name_String (Path), Succ); + + if not Succ then + null; + end if; + end; + end if; + + if not Success then + Com.Fail ("could not bind standalone library " + & Get_Name_String (For_Project.Library_Name)); + end if; + end if; + + -- Compile the binder generated file only if Link is true + + if Link then + + -- Set the paths + + Set_Ada_Paths + (Project => For_Project, + In_Tree => In_Tree, + Including_Libraries => True); + + -- Invoke -c b__.adb + + -- Allocate Arguments, if it is the first time we see a standalone + -- library. + + if Arguments = No_Argument then + Arguments := new String_List (1 .. Initial_Argument_Max); + end if; + + Argument_Number := 1; + Arguments (1) := Compile_Switch; + + if OpenVMS_On_Target then + B_Start := new String'("b__"); + end if; + + Add_Argument + (B_Start.all + & Get_Name_String (For_Project.Library_Name) & ".adb"); + + -- If necessary, add the PIC option + + if PIC_Option /= "" then + Add_Argument (PIC_Option); + end if; + + -- Get the back-end switches and --RTS from the ALI file + + if First_ALI /= No_File then + declare + T : Text_Buffer_Ptr; + A : ALI_Id; + + begin + -- Load the ALI file + + T := Read_Library_Info (First_ALI, True); + + -- Read it + + A := + Scan_ALI (First_ALI, T, Ignore_ED => False, Err => False); + + if A /= No_ALI_Id then + for Index in + ALI.Units.Table + (ALI.ALIs.Table (A).First_Unit).First_Arg .. + ALI.Units.Table + (ALI.ALIs.Table (A).First_Unit).Last_Arg + loop + -- Do not compile with the front end switches except + -- for --RTS. + + declare + Arg : String_Ptr renames Args.Table (Index); + begin + if not Is_Front_End_Switch (Arg.all) + or else + Arg (Arg'First + 2 .. Arg'First + 5) = "RTS=" + then + Add_Argument (Arg.all); + end if; + end; + end loop; + end if; + end; + end if; + + -- Now that all the arguments are set, compile the binder + -- generated file. + + Display (Gcc); + Spawn + (Gcc_Path.all, Arguments (1 .. Argument_Number), Success); + + if not Success then + Com.Fail + ("could not compile binder generated file for library " + & Get_Name_String (For_Project.Library_Name)); + end if; + + -- Process binder generated file for pragmas Linker_Options + + Process_Binder_File (Arguments (2).all & ASCII.NUL); + end if; + end if; + + -- Build the library only if Link is True + + if Link then + + -- If attributes Library_GCC or Linker'Driver were specified, get the + -- driver name. + + if For_Project.Config.Shared_Lib_Driver /= No_File then + Driver_Name := Name_Id (For_Project.Config.Shared_Lib_Driver); + end if; + + -- If attribute Library_Options was specified, add these additional + -- options. + + Library_Options := Value_Of + (Name_Library_Options, For_Project.Decl.Attributes, In_Tree); + + if not Library_Options.Default then + declare + Current : String_List_Id; + Element : String_Element; + + begin + Current := Library_Options.Values; + while Current /= Nil_String loop + Element := In_Tree.String_Elements.Table (Current); + Get_Name_String (Element.Value); + + if Name_Len /= 0 then + Opts.Increment_Last; + Opts.Table (Opts.Last) := + new String'(Name_Buffer (1 .. Name_Len)); + end if; + + Current := Element.Next; + end loop; + end; + end if; + + Lib_Dirpath := + new String'(Get_Name_String (For_Project.Library_Dir.Display_Name)); + Lib_Filename := new String' + (Get_Name_String (For_Project.Library_Name)); + + case For_Project.Library_Kind is + when Static => + The_Build_Mode := Static; + + when Dynamic => + The_Build_Mode := Dynamic; + + when Relocatable => + The_Build_Mode := Relocatable; + + if PIC_Option /= "" then + Opts.Increment_Last; + Opts.Table (Opts.Last) := new String'(PIC_Option); + end if; + end case; + + -- Get the library version, if any + + if For_Project.Lib_Internal_Name /= No_Name then + Lib_Version := + new String'(Get_Name_String (For_Project.Lib_Internal_Name)); + end if; + + -- Add the objects found in the object directory and the object + -- directories of the extended files, if any, except for generated + -- object files (b~.. or B__..) from extended projects. + -- When there are one or more extended files, only add an object file + -- if no object file with the same name have already been added. + + In_Main_Object_Directory := True; + + -- For gnatmake, when the project specifies more than just Ada as a + -- language (even if course we could not find any source file for + -- the other languages), we will take all object files found in the + -- object directories. Since we know the project supports at least + -- Ada, we just have to test whether it has at least two languages, + -- and not care about the sources. + + Foreign_Sources := For_Project.Languages.Next /= null; + Current_Proj := For_Project; + loop + if Current_Proj.Object_Directory /= No_Path_Information then + + -- The following code gets far too indented, I suggest some + -- procedural abstraction here. How about making this declare + -- block a named procedure??? + + declare + Object_Dir_Path : constant String := + Get_Name_String + (Current_Proj.Object_Directory + .Display_Name); + + Object_Dir : Dir_Type; + Filename : String (1 .. 255); + Last : Natural; + Id : Name_Id; + + begin + Open (Dir => Object_Dir, Dir_Name => Object_Dir_Path); + + -- For all entries in the object directory + + loop + Read (Object_Dir, Filename, Last); + + exit when Last = 0; + + -- Check if it is an object file + + if Is_Obj (Filename (1 .. Last)) then + declare + Object_Path : constant String := + Normalize_Pathname + (Object_Dir_Path + & Directory_Separator + & Filename (1 .. Last)); + Object_File : constant String := + Filename (1 .. Last); + + C_Filename : String := Object_File; + + begin + Canonical_Case_File_Name (C_Filename); + + -- If in the object directory of an extended + -- project, do not consider generated object files. + + if In_Main_Object_Directory + or else Last < 5 + or else + C_Filename (1 .. B_Start'Length) /= B_Start.all + then + Name_Len := 0; + Add_Str_To_Name_Buffer (C_Filename); + Id := Name_Find; + + if not Objects_Htable.Get (Id) then + declare + ALI_File : constant String := + Ext_To (C_Filename, "ali"); + + ALI_Path : constant String := + Ext_To (Object_Path, "ali"); + + Add_It : Boolean; + Fname : File_Name_Type; + Proj : Project_Id; + Index : Unit_Index; + + begin + -- The following assignment could use + -- a comment ??? + + Add_It := + Foreign_Sources + or else + (Last >= 5 + and then + C_Filename (1 .. B_Start'Length) + = B_Start.all); + + if Is_Regular_File (ALI_Path) then + + -- If there is an ALI file, check if + -- the object file should be added to + -- the library. If there are foreign + -- sources we put all object files in + -- the library. + + if not Add_It then + Index := + Units_Htable.Get_First + (In_Tree.Units_HT); + while Index /= null loop + if Index.File_Names (Impl) /= + null + then + Proj := + Index.File_Names (Impl) + .Project; + Fname := + Index.File_Names (Impl).File; + + elsif Index.File_Names (Spec) /= + null + then + Proj := + Index.File_Names (Spec) + .Project; + Fname := + Index.File_Names (Spec).File; + + else + Proj := No_Project; + end if; + + Add_It := Proj /= No_Project; + + -- If the source is in the + -- project or a project it + -- extends, we may put it in + -- the library. + + if Add_It then + Add_It := Check_Project (Proj); + end if; + + -- But we don't, if the ALI file + -- does not correspond to the + -- unit. + + if Add_It then + declare + F : constant String := + Ext_To + (Get_Name_String + (Fname), "ali"); + begin + Add_It := F = ALI_File; + end; + end if; + + exit when Add_It; + + Index := + Units_Htable.Get_Next + (In_Tree.Units_HT); + end loop; + end if; + + if Add_It then + Objects_Htable.Set (Id, True); + Objects.Append + (new String'(Object_Path)); + + -- Record the ALI file + + ALIs.Append (new String'(ALI_Path)); + + -- Find out if for this ALI file, + -- libgnarl or libdecgnat or + -- g-trasym.obj (on OpenVMS) is + -- necessary. + + Check_Libs (ALI_Path, True); + end if; + + elsif Foreign_Sources then + Objects.Append + (new String'(Object_Path)); + end if; + end; + end if; + end if; + end; + end if; + end loop; + + Close (Dir => Object_Dir); + + exception + when Directory_Error => + Com.Fail ("cannot find object directory """ + & Get_Name_String + (Current_Proj.Object_Directory.Display_Name) + & """"); + end; + end if; + + exit when Current_Proj.Extends = No_Project; + + In_Main_Object_Directory := False; + Current_Proj := Current_Proj.Extends; + end loop; + + -- Add the -L and -l switches for the imported Library Project Files, + -- and, if Path Option is supported, the library directory path names + -- to Rpath. + + Process_Imported_Libraries; + + -- Link with libgnat and possibly libgnarl + + Opts.Increment_Last; + Opts.Table (Opts.Last) := new String'("-L" & Lib_Directory); + + -- If Path Option is supported, add libgnat directory path name to + -- Rpath. + + if Path_Option /= null then + declare + Libdir : constant String := Lib_Directory; + GCC_Index : Natural := 0; + + begin + Add_Rpath (Libdir); + + -- For shared libraries, add to the Path Option the directory + -- of the shared version of libgcc. + + if The_Build_Mode /= Static then + GCC_Index := Index (Libdir, "/lib/"); + + if GCC_Index = 0 then + GCC_Index := + Index + (Libdir, + Directory_Separator & "lib" & Directory_Separator); + end if; + + if GCC_Index /= 0 then + Add_Rpath (Libdir (Libdir'First .. GCC_Index + 3)); + end if; + end if; + end; + end if; + + if Libgnarl_Needed = Yes then + Opts.Increment_Last; + + if The_Build_Mode = Static then + Opts.Table (Opts.Last) := new String'("-lgnarl"); + else + Opts.Table (Opts.Last) := new String'(Shared_Lib ("gnarl")); + end if; + end if; + + if Gtrasymobj_Needed then + Opts.Increment_Last; + Opts.Table (Opts.Last) := + new String'(Lib_Directory & "/g-trasym.obj"); + end if; + + if Libdecgnat_Needed then + Opts.Increment_Last; + + Opts.Table (Opts.Last) := + new String'("-L" & Lib_Directory & "/../declib"); + + Opts.Increment_Last; + + if The_Build_Mode = Static then + Opts.Table (Opts.Last) := new String'("-ldecgnat"); + else + Opts.Table (Opts.Last) := new String'(Shared_Lib ("decgnat")); + end if; + end if; + + Opts.Increment_Last; + + if The_Build_Mode = Static then + Opts.Table (Opts.Last) := new String'("-lgnat"); + else + Opts.Table (Opts.Last) := new String'(Shared_Lib ("gnat")); + end if; + + -- If Path Option is supported, add the necessary switch with the + -- content of Rpath. As Rpath contains at least libgnat directory + -- path name, it is guaranteed that it is not null. + + if Path_Option /= null then + Opts.Increment_Last; + Opts.Table (Opts.Last) := + new String'(Path_Option.all & Rpath (1 .. Rpath_Last)); + Free (Path_Option); + Free (Rpath); + end if; + + Object_Files := + new Argument_List' + (Argument_List (Objects.Table (1 .. Objects.Last))); + + Ali_Files := + new Argument_List'(Argument_List (ALIs.Table (1 .. ALIs.Last))); + + Options := + new Argument_List'(Argument_List (Opts.Table (1 .. Opts.Last))); + + -- We fail if there are no object to put in the library + -- (Ada or foreign objects). + + if Object_Files'Length = 0 then + Com.Fail ("no object files for library """ & + Lib_Filename.all & '"'); + end if; + + if not Opt.Quiet_Output then + Write_Eol; + Write_Str ("building "); + Write_Str (Ada.Characters.Handling.To_Lower + (Build_Mode_State'Image (The_Build_Mode))); + Write_Str (" library for project "); + Write_Line (Project_Name); + + -- Only output list of object files and ALI files in verbose mode + + if Opt.Verbose_Mode then + Write_Eol; + + Write_Line ("object files:"); + + for Index in Object_Files'Range loop + Write_Str (" "); + Write_Line (Object_Files (Index).all); + end loop; + + Write_Eol; + + if Ali_Files'Length = 0 then + Write_Line ("NO ALI files"); + + else + Write_Line ("ALI files:"); + + for Index in Ali_Files'Range loop + Write_Str (" "); + Write_Line (Ali_Files (Index).all); + end loop; + end if; + + Write_Eol; + end if; + end if; + + -- We check that all object files are regular files + + Check_Context; + + -- Delete the existing library file, if it exists. Fail if the + -- library file is not writable, or if it is not possible to delete + -- the file. + + declare + DLL_Name : aliased String := + Lib_Dirpath.all & Directory_Separator & DLL_Prefix & + Lib_Filename.all & "." & DLL_Ext; + + Archive_Name : aliased String := + Lib_Dirpath.all & Directory_Separator & "lib" & + Lib_Filename.all & "." & Archive_Ext; + + type Str_Ptr is access all String; + -- This type is necessary to meet the accessibility rules of Ada. + -- It is not possible to use String_Access here. + + Full_Lib_Name : Str_Ptr; + -- Designates the full library path name. Either DLL_Name or + -- Archive_Name, depending on the library kind. + + Success : Boolean; + pragma Warnings (Off, Success); + -- Used to call Delete_File + + begin + if The_Build_Mode = Static then + Full_Lib_Name := Archive_Name'Access; + else + Full_Lib_Name := DLL_Name'Access; + end if; + + if Is_Regular_File (Full_Lib_Name.all) then + if Is_Writable_File (Full_Lib_Name.all) then + Delete_File (Full_Lib_Name.all, Success); + end if; + + if Is_Regular_File (Full_Lib_Name.all) then + Com.Fail ("could not delete """ & Full_Lib_Name.all & """"); + end if; + end if; + end; + + Argument_Number := 0; + + -- If we have a standalone library, gather all the interface ALI. + -- They are passed to Build_Dynamic_Library, where they are used by + -- some platforms (VMS, for example) to decide what symbols should be + -- exported. They are also flagged as Interface when we copy them to + -- the library directory (by Copy_ALI_Files, below). + + if Standalone then + Current_Proj := For_Project; + + declare + Iface : String_List_Id := For_Project.Lib_Interface_ALIs; + ALI : File_Name_Type; + + begin + while Iface /= Nil_String loop + ALI := + File_Name_Type + (In_Tree.String_Elements.Table (Iface).Value); + Interface_ALIs.Set (ALI, True); + Get_Name_String + (In_Tree.String_Elements.Table (Iface).Value); + Add_Argument (Name_Buffer (1 .. Name_Len)); + Iface := In_Tree.String_Elements.Table (Iface).Next; + end loop; + + Iface := For_Project.Lib_Interface_ALIs; + + if not Opt.Quiet_Output then + + -- Check that the interface set is complete: any unit in the + -- library that is needed by an interface should also be an + -- interface. If it is not the case, output a warning. + + while Iface /= Nil_String loop + ALI := + File_Name_Type + (In_Tree.String_Elements.Table (Iface).Value); + Process (ALI); + Iface := In_Tree.String_Elements.Table (Iface).Next; + end loop; + end if; + end; + end if; + + declare + Current_Dir : constant String := Get_Current_Dir; + Dir : Dir_Type; + + Name : String (1 .. 200); + Last : Natural; + + Disregard : Boolean; + pragma Warnings (Off, Disregard); + + DLL_Name : aliased constant String := + Lib_Filename.all & "." & DLL_Ext; + + Archive_Name : aliased constant String := + Lib_Filename.all & "." & Archive_Ext; + + Delete : Boolean := False; + + begin + -- Clean the library directory: remove any file with the name of + -- the library file and any ALI file of a source of the project. + + begin + Get_Name_String (For_Project.Library_Dir.Display_Name); + Change_Dir (Name_Buffer (1 .. Name_Len)); + + exception + when others => + Com.Fail + ("unable to access library directory """ + & Name_Buffer (1 .. Name_Len) + & """"); + end; + + Open (Dir, "."); + + loop + Read (Dir, Name, Last); + exit when Last = 0; + + declare + Filename : constant String := Name (1 .. Last); + + begin + if Is_Regular_File (Filename) then + Canonical_Case_File_Name (Name (1 .. Last)); + Delete := False; + + if (The_Build_Mode = Static + and then Name (1 .. Last) = Archive_Name) + or else + ((The_Build_Mode = Dynamic + or else + The_Build_Mode = Relocatable) + and then Name (1 .. Last) = DLL_Name) + then + Delete := True; + + elsif Last > 4 + and then Name (Last - 3 .. Last) = ".ali" + then + declare + Unit : Unit_Index; + + begin + -- Compare with ALI file names of the project + + Unit := Units_Htable.Get_First (In_Tree.Units_HT); + while Unit /= No_Unit_Index loop + if Unit.File_Names (Impl) /= null + and then Unit.File_Names (Impl).Project /= + No_Project + then + if Ultimate_Extending_Project_Of + (Unit.File_Names (Impl).Project) = + For_Project + then + Get_Name_String + (Unit.File_Names (Impl).File); + Name_Len := + Name_Len - + File_Extension + (Name (1 .. Name_Len))'Length; + + if Name_Buffer (1 .. Name_Len) = + Name (1 .. Last - 4) + then + Delete := True; + exit; + end if; + end if; + + elsif Unit.File_Names (Spec) /= null + and then Ultimate_Extending_Project_Of + (Unit.File_Names (Spec).Project) = + For_Project + then + Get_Name_String (Unit.File_Names (Spec).File); + Name_Len := + Name_Len - + File_Extension (Name (1 .. Last))'Length; + + if Name_Buffer (1 .. Name_Len) = + Name (1 .. Last - 4) + then + Delete := True; + exit; + end if; + end if; + + Unit := Units_Htable.Get_Next (In_Tree.Units_HT); + end loop; + end; + end if; + + if Delete then + Set_Writable (Filename); + Delete_File (Filename, Disregard); + end if; + end if; + end; + end loop; + + Close (Dir); + + Change_Dir (Current_Dir); + end; + + -- Call procedure to build the library, depending on the build mode + + case The_Build_Mode is + when Dynamic | Relocatable => + Build_Dynamic_Library + (Ofiles => Object_Files.all, + Options => Options.all, + Interfaces => Arguments (1 .. Argument_Number), + Lib_Filename => Lib_Filename.all, + Lib_Dir => Lib_Dirpath.all, + Symbol_Data => Current_Proj.Symbol_Data, + Driver_Name => Driver_Name, + Lib_Version => Lib_Version.all, + Auto_Init => Current_Proj.Lib_Auto_Init); + + when Static => + MLib.Build_Library + (Object_Files.all, + Lib_Filename.all, + Lib_Dirpath.all); + + when None => + null; + end case; + + -- We need to copy the ALI files from the object directory to the + -- library ALI directory, so that the linker find them there, and + -- does not need to look in the object directory where it would also + -- find the object files; and we don't want that: we want the linker + -- to use the library. + + -- Copy the ALI files and make the copies read-only. For interfaces, + -- mark the copies as interfaces. + + Copy_ALI_Files + (Files => Ali_Files.all, + To => For_Project.Library_ALI_Dir.Display_Name, + Interfaces => Arguments (1 .. Argument_Number)); + + -- Copy interface sources if Library_Src_Dir specified + + if Standalone + and then For_Project.Library_Src_Dir /= No_Path_Information + then + -- Clean the interface copy directory: remove any source that + -- could be a source of the project. + + begin + Get_Name_String (For_Project.Library_Src_Dir.Display_Name); + Change_Dir (Name_Buffer (1 .. Name_Len)); + + exception + when others => + Com.Fail + ("unable to access library source copy directory """ + & Name_Buffer (1 .. Name_Len) + & """"); + end; + + declare + Dir : Dir_Type; + Delete : Boolean := False; + Unit : Unit_Index; + + Name : String (1 .. 200); + Last : Natural; + + Disregard : Boolean; + pragma Warnings (Off, Disregard); + + begin + Open (Dir, "."); + + loop + Read (Dir, Name, Last); + exit when Last = 0; + + if Is_Regular_File (Name (1 .. Last)) then + Canonical_Case_File_Name (Name (1 .. Last)); + Delete := False; + + -- Compare with source file names of the project + + Unit := Units_Htable.Get_First (In_Tree.Units_HT); + while Unit /= No_Unit_Index loop + if Unit.File_Names (Impl) /= null + and then Ultimate_Extending_Project_Of + (Unit.File_Names (Impl).Project) = For_Project + and then + Get_Name_String + (Unit.File_Names (Impl).File) = + Name (1 .. Last) + then + Delete := True; + exit; + end if; + + if Unit.File_Names (Spec) /= null + and then Ultimate_Extending_Project_Of + (Unit.File_Names (Spec).Project) = + For_Project + and then + Get_Name_String + (Unit.File_Names (Spec).File) = + Name (1 .. Last) + then + Delete := True; + exit; + end if; + + Unit := Units_Htable.Get_Next (In_Tree.Units_HT); + end loop; + end if; + + if Delete then + Set_Writable (Name (1 .. Last)); + Delete_File (Name (1 .. Last), Disregard); + end if; + end loop; + + Close (Dir); + end; + + Copy_Interface_Sources + (For_Project => For_Project, + In_Tree => In_Tree, + Interfaces => Arguments (1 .. Argument_Number), + To_Dir => For_Project.Library_Src_Dir.Display_Name); + end if; + end if; + + -- Reset the current working directory to its previous value + + Change_Dir (Current_Dir); + end Build_Library; + + ----------- + -- Check -- + ----------- + + procedure Check (Filename : String) is + begin + if not Is_Regular_File (Filename) then + Com.Fail (Filename & " not found."); + end if; + end Check; + + ------------------- + -- Check_Context -- + ------------------- + + procedure Check_Context is + begin + -- Check that each object file exists + + for F in Object_Files'Range loop + Check (Object_Files (F).all); + end loop; + end Check_Context; + + ------------------- + -- Check_Library -- + ------------------- + + procedure Check_Library + (For_Project : Project_Id; In_Tree : Project_Tree_Ref) + is + Lib_TS : Time_Stamp_Type; + Current : constant Dir_Name_Str := Get_Current_Dir; + + begin + -- No need to build the library if there is no object directory, + -- hence no object files to build the library. + + if For_Project.Library then + declare + Lib_Name : constant File_Name_Type := + Library_File_Name_For (For_Project, In_Tree); + begin + Change_Dir + (Get_Name_String (For_Project.Library_Dir.Display_Name)); + Lib_TS := File_Stamp (Lib_Name); + For_Project.Library_TS := Lib_TS; + end; + + if not For_Project.Externally_Built + and then not For_Project.Need_To_Build_Lib + and then For_Project.Object_Directory /= No_Path_Information + then + declare + Obj_TS : Time_Stamp_Type; + Object_Dir : Dir_Type; + + begin + if OpenVMS_On_Target then + B_Start := new String'("b__"); + end if; + + -- If the library file does not exist, then the time stamp will + -- be Empty_Time_Stamp, earlier than any other time stamp. + + Change_Dir + (Get_Name_String (For_Project.Object_Directory.Display_Name)); + Open (Dir => Object_Dir, Dir_Name => "."); + + -- For all entries in the object directory + + loop + Read (Object_Dir, Name_Buffer, Name_Len); + exit when Name_Len = 0; + + -- Check if it is an object file, but ignore any binder + -- generated file. + + if Is_Obj (Name_Buffer (1 .. Name_Len)) + and then Name_Buffer (1 .. B_Start'Length) /= B_Start.all + then + -- Get the object file time stamp + + Obj_TS := File_Stamp (File_Name_Type'(Name_Find)); + + -- If library file time stamp is earlier, set + -- Need_To_Build_Lib and return. String comparison is + -- used, otherwise time stamps may be too close and the + -- comparison would return True, which would trigger + -- an unnecessary rebuild of the library. + + if String (Lib_TS) < String (Obj_TS) then + + -- Library must be rebuilt + + For_Project.Need_To_Build_Lib := True; + exit; + end if; + end if; + end loop; + + Close (Object_Dir); + end; + end if; + + Change_Dir (Current); + end if; + end Check_Library; + + ---------------------------- + -- Copy_Interface_Sources -- + ---------------------------- + + procedure Copy_Interface_Sources + (For_Project : Project_Id; + In_Tree : Project_Tree_Ref; + Interfaces : Argument_List; + To_Dir : Path_Name_Type) + is + Current : constant Dir_Name_Str := Get_Current_Dir; + -- The current directory, where to return to at the end + + Target : constant Dir_Name_Str := Get_Name_String (To_Dir); + -- The directory where to copy sources + + Text : Text_Buffer_Ptr; + The_ALI : ALI.ALI_Id; + Lib_File : File_Name_Type; + + First_Unit : ALI.Unit_Id; + Second_Unit : ALI.Unit_Id; + + Copy_Subunits : Boolean := False; + -- When True, indicates that subunits, if any, need to be copied too + + procedure Copy (File_Name : File_Name_Type); + -- Copy one source of the project to the target directory + + ---------- + -- Copy -- + ---------- + + procedure Copy (File_Name : File_Name_Type) is + Success : Boolean; + pragma Warnings (Off, Success); + + Source : Standard.Prj.Source_Id; + begin + Source := Find_Source + (In_Tree, For_Project, + In_Extended_Only => True, + Base_Name => File_Name); + + if Source /= No_Source + and then not Source.Locally_Removed + and then Source.Replaced_By = No_Source + then + Copy_File + (Get_Name_String (Source.Path.Name), + Target, + Success, + Mode => Overwrite, + Preserve => Preserve); + end if; + end Copy; + + -- Start of processing for Copy_Interface_Sources + + begin + -- Change the working directory to the object directory + + Change_Dir (Get_Name_String (For_Project.Object_Directory.Display_Name)); + + for Index in Interfaces'Range loop + + -- First, load the ALI file + + Name_Len := 0; + Add_Str_To_Name_Buffer (Interfaces (Index).all); + Lib_File := Name_Find; + Text := Read_Library_Info (Lib_File); + The_ALI := Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True); + Free (Text); + + Second_Unit := No_Unit_Id; + First_Unit := ALI.ALIs.Table (The_ALI).First_Unit; + Copy_Subunits := True; + + -- If there is both a spec and a body, check if they are both needed + + if ALI.Units.Table (First_Unit).Utype = Is_Body then + Second_Unit := ALI.ALIs.Table (The_ALI).Last_Unit; + + -- If the body is not needed, then reset First_Unit + + if not ALI.Units.Table (Second_Unit).Body_Needed_For_SAL then + First_Unit := No_Unit_Id; + Copy_Subunits := False; + end if; + + elsif ALI.Units.Table (First_Unit).Utype = Is_Spec_Only then + Copy_Subunits := False; + end if; + + -- Copy the file(s) that need to be copied + + if First_Unit /= No_Unit_Id then + Copy (File_Name => ALI.Units.Table (First_Unit).Sfile); + end if; + + if Second_Unit /= No_Unit_Id then + Copy (File_Name => ALI.Units.Table (Second_Unit).Sfile); + end if; + + -- Copy all the separates, if any + + if Copy_Subunits then + for Dep in ALI.ALIs.Table (The_ALI).First_Sdep .. + ALI.ALIs.Table (The_ALI).Last_Sdep + loop + if Sdep.Table (Dep).Subunit_Name /= No_Name then + Copy (File_Name => Sdep.Table (Dep).Sfile); + end if; + end loop; + end if; + end loop; + + -- Restore the initial working directory + + Change_Dir (Current); + end Copy_Interface_Sources; + + ------------- + -- Display -- + ------------- + + procedure Display (Executable : String) is + begin + if not Opt.Quiet_Output then + Write_Str (Executable); + + for Index in 1 .. Argument_Number loop + Write_Char (' '); + Write_Str (Arguments (Index).all); + + if not Opt.Verbose_Mode and then Index > 4 then + Write_Str (" ..."); + exit; + end if; + end loop; + + Write_Eol; + end if; + end Display; + + ----------- + -- Index -- + ----------- + + function Index (S, Pattern : String) return Natural is + Len : constant Natural := Pattern'Length; + + begin + for J in reverse S'First .. S'Last - Len + 1 loop + if Pattern = S (J .. J + Len - 1) then + return J; + end if; + end loop; + + return 0; + end Index; + + ------------------------- + -- Process_Binder_File -- + ------------------------- + + procedure Process_Binder_File (Name : String) is + Fd : FILEs; + -- Binder file's descriptor + + Read_Mode : constant String := "r" & ASCII.NUL; + -- For fopen + + Status : Interfaces.C_Streams.int; + pragma Unreferenced (Status); + -- For fclose + + Begin_Info : constant String := "-- BEGIN Object file/option list"; + End_Info : constant String := "-- END Object file/option list "; + + Next_Line : String (1 .. 1000); + -- Current line value + -- Where does this odd constant 1000 come from, looks suspicious ??? + + Nlast : Integer; + -- End of line slice (the slice does not contain the line terminator) + + procedure Get_Next_Line; + -- Read the next line from the binder file without the line terminator + + ------------------- + -- Get_Next_Line -- + ------------------- + + procedure Get_Next_Line is + Fchars : chars; + + begin + Fchars := fgets (Next_Line'Address, Next_Line'Length, Fd); + + if Fchars = System.Null_Address then + Fail ("Error reading binder output"); + end if; + + Nlast := 1; + while Nlast <= Next_Line'Last + and then Next_Line (Nlast) /= ASCII.LF + and then Next_Line (Nlast) /= ASCII.CR + loop + Nlast := Nlast + 1; + end loop; + + Nlast := Nlast - 1; + end Get_Next_Line; + + -- Start of processing for Process_Binder_File + + begin + Fd := fopen (Name'Address, Read_Mode'Address); + + if Fd = NULL_Stream then + Fail ("Failed to open binder output"); + end if; + + -- Skip up to the Begin Info line + + loop + Get_Next_Line; + exit when Next_Line (1 .. Nlast) = Begin_Info; + end loop; + + -- Find the first switch + + loop + Get_Next_Line; + + exit when Next_Line (1 .. Nlast) = End_Info; + + -- As the binder generated file is in Ada, remove the first eight + -- characters " -- ". + + Next_Line (1 .. Nlast - 8) := Next_Line (9 .. Nlast); + Nlast := Nlast - 8; + + -- Stop when the first switch is found + + exit when Next_Line (1) = '-'; + end loop; + + if Next_Line (1 .. Nlast) /= End_Info then + loop + -- Ignore -static and -shared, since -shared will be used + -- in any case. + + -- Ignore -lgnat, -lgnarl and -ldecgnat as they will be added + -- later, because they are also needed for non Stand-Alone shared + -- libraries. + + -- Also ignore the shared libraries which are : + + -- UNIX / Windows VMS + -- -lgnat- -lgnat_ (7 + version'length chars) + -- -lgnarl- -lgnarl_ (8 + version'length chars) + + if Next_Line (1 .. Nlast) /= "-static" and then + Next_Line (1 .. Nlast) /= "-shared" and then + Next_Line (1 .. Nlast) /= "-ldecgnat" and then + Next_Line (1 .. Nlast) /= "-lgnarl" and then + Next_Line (1 .. Nlast) /= "-lgnat" and then + Next_Line + (1 .. Natural'Min (Nlast, 10 + Library_Version'Length)) /= + Shared_Lib ("decgnat") and then + Next_Line + (1 .. Natural'Min (Nlast, 8 + Library_Version'Length)) /= + Shared_Lib ("gnarl") and then + Next_Line + (1 .. Natural'Min (Nlast, 7 + Library_Version'Length)) /= + Shared_Lib ("gnat") + then + if Next_Line (1) /= '-' then + + -- This is not an option, should we add it? + + if Add_Object_Files then + Opts.Increment_Last; + Opts.Table (Opts.Last) := + new String'(Next_Line (1 .. Nlast)); + end if; + + else + -- Add all other options + + Opts.Increment_Last; + Opts.Table (Opts.Last) := + new String'(Next_Line (1 .. Nlast)); + end if; + end if; + + -- Next option, if any + + Get_Next_Line; + exit when Next_Line (1 .. Nlast) = End_Info; + + -- Remove first eight characters " -- " + + Next_Line (1 .. Nlast - 8) := Next_Line (9 .. Nlast); + Nlast := Nlast - 8; + end loop; + end if; + + Status := fclose (Fd); + + -- Is it really right to ignore any close error ??? + + end Process_Binder_File; + + ------------------ + -- Reset_Tables -- + ------------------ + + procedure Reset_Tables is + begin + Objects.Init; + Objects_Htable.Reset; + ALIs.Init; + Opts.Init; + Processed_Projects.Reset; + Library_Projs.Init; + end Reset_Tables; + + --------------------------- + -- SALs_Use_Constructors -- + --------------------------- + + function SALs_Use_Constructors return Boolean is + function C_SALs_Init_Using_Constructors return Integer; + pragma Import (C, C_SALs_Init_Using_Constructors, + "__gnat_sals_init_using_constructors"); + begin + return C_SALs_Init_Using_Constructors /= 0; + end SALs_Use_Constructors; + +end MLib.Prj; diff --git a/gcc/ada/mlib-prj.ads b/gcc/ada/mlib-prj.ads new file mode 100644 index 000000000..6a32dd352 --- /dev/null +++ b/gcc/ada/mlib-prj.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . P R J -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2007, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package builds a library for a library project file + +with Prj; use Prj; + +package MLib.Prj is + + procedure Build_Library + (For_Project : Project_Id; + In_Tree : Project_Tree_Ref; + Gnatbind : String; + Gnatbind_Path : String_Access; + Gcc : String; + Gcc_Path : String_Access; + Bind : Boolean := True; + Link : Boolean := True); + -- Build the library of library project For_Project. + -- Fails if For_Project is not a library project file. + -- Gnatbind, Gnatbind_Path, Gcc, Gcc_Path are used for standalone + -- libraries, to call the binder and to compile the binder generated + -- files. If Bind is False the binding of a stand-alone library is skipped. + -- If Link is False, the library is not linked/built. + + procedure Check_Library + (For_Project : Project_Id; + In_Tree : Project_Tree_Ref); + -- Check if the library of a library project needs to be rebuilt, + -- because its time-stamp is earlier than the time stamp of one of its + -- object files. + +end MLib.Prj; diff --git a/gcc/ada/mlib-tgt-specific-aix.adb b/gcc/ada/mlib-tgt-specific-aix.adb new file mode 100644 index 000000000..9fb8b1593 --- /dev/null +++ b/gcc/ada/mlib-tgt-specific-aix.adb @@ -0,0 +1,225 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T . S P E C I F I C -- +-- (AIX Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the AIX version of the body + +with Ada.Strings.Fixed; use Ada.Strings.Fixed; + +with MLib.Fil; +with MLib.Utl; +with Opt; +with Output; use Output; +with Prj.Com; +with Prj.Util; use Prj.Util; + +package body MLib.Tgt.Specific is + + -- Local subprograms + -- These *ALL* require comments ??? + + function Archive_Indexer return String; + -- What is this??? + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + function DLL_Ext return String; + + function Library_Major_Minor_Id_Supported return Boolean; + + function Support_For_Libraries return Library_Support; + + -- Local variables + + No_Arguments : aliased Argument_List := (1 .. 0 => null); + Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access; + + Bexpall : aliased String := "-Wl,-bexpall"; + Bexpall_Option : constant String_Access := Bexpall'Access; + -- The switch to export all symbols + + Lpthreads : aliased String := "-lpthreads"; + Native_Thread_Options : aliased Argument_List := (1 => Lpthreads'Access); + -- The switch to use when linking a library against libgnarl when using + -- Native threads. + + Lgthreads : aliased String := "-lgthreads"; + Lmalloc : aliased String := "-lmalloc"; + FSU_Thread_Options : aliased Argument_List := + (1 => Lgthreads'Access, 2 => Lmalloc'Access); + -- The switches to use when linking a library against libgnarl when using + -- FSU threads. + + Thread_Options : Argument_List_Access := Empty_Argument_List; + -- Designate the thread switches to used when linking a library against + -- libgnarl. Depends on the thread library (Native or FSU). Resolved for + -- the first library linked against libgnarl. + + --------------------- + -- Archive_Indexer -- + --------------------- + + function Archive_Indexer return String is + begin + return ""; + end Archive_Indexer; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Lib_Version); + pragma Unreferenced (Auto_Init); + + Lib_File : constant String := + Lib_Dir & Directory_Separator & "lib" & + MLib.Fil.Append_To (Lib_Filename, DLL_Ext); + -- The file name of the library + + Thread_Opts : Argument_List_Access := Empty_Argument_List; + -- Set to Thread_Options if -lgnarl is found in the Options + + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_File); + end if; + + -- Look for -lgnarl in Options. If found, set the thread options + + for J in Options'Range loop + if Options (J).all = "-lgnarl" then + + -- If Thread_Options is null, read s-osinte.ads to discover the + -- thread library and set Thread_Options accordingly. + + if Thread_Options = null then + declare + File : Text_File; + Line : String (1 .. 100); + Last : Natural; + + begin + Open + (File, Include_Dir_Default_Prefix & "/s-osinte.ads"); + + while not End_Of_File (File) loop + Get_Line (File, Line, Last); + + if Index (Line (1 .. Last), "-lpthreads") /= 0 then + Thread_Options := Native_Thread_Options'Access; + exit; + + elsif Index (Line (1 .. Last), "-lgthreads") /= 0 then + Thread_Options := FSU_Thread_Options'Access; + exit; + end if; + end loop; + + Close (File); + + if Thread_Options = null then + Prj.Com.Fail ("cannot find the thread library in use"); + end if; + + exception + when others => + Prj.Com.Fail ("cannot open s-osinte.ads"); + end; + end if; + + Thread_Opts := Thread_Options; + exit; + end if; + end loop; + + -- Finally, call GCC (or the driver specified) to build the library + + MLib.Utl.Gcc + (Output_File => Lib_File, + Objects => Ofiles, + Options => Options & Bexpall_Option, + Driver_Name => Driver_Name, + Options_2 => Thread_Opts.all); + end Build_Dynamic_Library; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "a"; + end DLL_Ext; + + -------------------------------------- + -- Library_Major_Minor_Id_Supported -- + -------------------------------------- + + function Library_Major_Minor_Id_Supported return Boolean is + begin + return False; + end Library_Major_Minor_Id_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Static_Only; + end Support_For_Libraries; + +begin + Archive_Indexer_Ptr := Archive_Indexer'Access; + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + DLL_Ext_Ptr := DLL_Ext'Access; + Library_Major_Minor_Id_Supported_Ptr := + Library_Major_Minor_Id_Supported'Access; + Support_For_Libraries_Ptr := Support_For_Libraries'Access; + +end MLib.Tgt.Specific; diff --git a/gcc/ada/mlib-tgt-specific-darwin.adb b/gcc/ada/mlib-tgt-specific-darwin.adb new file mode 100644 index 000000000..fc6642386 --- /dev/null +++ b/gcc/ada/mlib-tgt-specific-darwin.adb @@ -0,0 +1,176 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T . S P E C I F I C -- +-- (Darwin Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Darwin version of the body + +with MLib; use MLib; +with MLib.Fil; +with MLib.Utl; +with Opt; use Opt; +with Output; use Output; + +package body MLib.Tgt.Specific is + + -- Non default subprograms + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + function DLL_Ext return String; + + function Dynamic_Option return String; + + function Is_Archive_Ext (Ext : String) return Boolean; + + -- Local objects + + Flat_Namespace : aliased String := "-Wl,-flat_namespace"; + -- Instruct the linker to build the shared library as a flat + -- namespace image. The default is a two-level namespace image. + + Shared_Libgcc : aliased String := "-shared-libgcc"; + + Shared_Options : constant Argument_List := + (1 => Flat_Namespace'Access, + 2 => Shared_Libgcc'Access); + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Auto_Init); + + Lib_File : constant String := + "lib" & Fil.Append_To (Lib_Filename, DLL_Ext); + + Lib_Path : constant String := + Lib_Dir & Directory_Separator & Lib_File; + + Symbolic_Link_Needed : Boolean := False; + + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_File); + end if; + + -- If specified, add automatic elaboration/finalization + + if Lib_Version = "" then + Utl.Gcc + (Output_File => Lib_Path, + Objects => Ofiles, + Options => Options & Shared_Options, + Driver_Name => Driver_Name, + Options_2 => No_Argument_List); + + else + declare + Maj_Version : constant String := + Major_Id_Name (Lib_File, Lib_Version); + begin + if Is_Absolute_Path (Lib_Version) then + Utl.Gcc + (Output_File => Lib_Version, + Objects => Ofiles, + Options => Options & Shared_Options, + Driver_Name => Driver_Name, + Options_2 => No_Argument_List); + Symbolic_Link_Needed := Lib_Version /= Lib_Path; + + else + Utl.Gcc + (Output_File => Lib_Dir & Directory_Separator & Lib_Version, + Objects => Ofiles, + Options => Options & Shared_Options, + Driver_Name => Driver_Name, + Options_2 => No_Argument_List); + Symbolic_Link_Needed := + Lib_Dir & Directory_Separator & Lib_Version /= Lib_Path; + end if; + + if Symbolic_Link_Needed then + Create_Sym_Links + (Lib_Path, Lib_Version, Lib_Dir, Maj_Version); + end if; + end; + end if; + end Build_Dynamic_Library; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "dylib"; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return "-dynamiclib"; + end Dynamic_Option; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".dylib" or else Ext = ".a"; + end Is_Archive_Ext; + +begin + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + DLL_Ext_Ptr := DLL_Ext'Access; + Dynamic_Option_Ptr := Dynamic_Option'Access; + Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; +end MLib.Tgt.Specific; diff --git a/gcc/ada/mlib-tgt-specific-hpux.adb b/gcc/ada/mlib-tgt-specific-hpux.adb new file mode 100644 index 000000000..720b0860a --- /dev/null +++ b/gcc/ada/mlib-tgt-specific-hpux.adb @@ -0,0 +1,164 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T . S P E C I F I C -- +-- (HP-UX Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the HP-UX version of the body + +with MLib.Fil; +with MLib.Utl; +with Opt; +with Output; use Output; + +package body MLib.Tgt.Specific is + + -- Non default subprograms + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + function DLL_Ext return String; + + function Is_Archive_Ext (Ext : String) return Boolean; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Auto_Init); + + Lib_File : constant String := + "lib" & Fil.Append_To (Lib_Filename, DLL_Ext); + + Lib_Path : constant String := + Lib_Dir & Directory_Separator & Lib_File; + + Version_Arg : String_Access; + Symbolic_Link_Needed : Boolean := False; + + Common_Options : constant Argument_List := + Options & new String'(PIC_Option); + -- Common set of options to the gcc command performing the link. + -- On HPUX, this command eventually resorts to collect2, which may + -- generate a C file and compile it on the fly. This compilation shall + -- also generate position independent code for the final link to + -- succeed. + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_Path); + end if; + + if Lib_Version = "" then + MLib.Utl.Gcc + (Output_File => Lib_Path, + Objects => Ofiles, + Options => Common_Options, + Options_2 => No_Argument_List, + Driver_Name => Driver_Name); + + else + declare + Maj_Version : constant String := + Major_Id_Name (Lib_File, Lib_Version); + begin + if Maj_Version'Length /= 0 then + Version_Arg := new String'("-Wl,+h," & Maj_Version); + + else + Version_Arg := new String'("-Wl,+h," & Lib_Version); + end if; + + if Is_Absolute_Path (Lib_Version) then + MLib.Utl.Gcc + (Output_File => Lib_Version, + Objects => Ofiles, + Options => Common_Options & Version_Arg, + Options_2 => No_Argument_List, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := Lib_Version /= Lib_Path; + + else + MLib.Utl.Gcc + (Output_File => Lib_Dir & Directory_Separator & Lib_Version, + Objects => Ofiles, + Options => Common_Options & Version_Arg, + Options_2 => No_Argument_List, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := + Lib_Dir & Directory_Separator & Lib_Version /= Lib_Path; + end if; + + if Symbolic_Link_Needed then + Create_Sym_Links + (Lib_Path, Lib_Version, Lib_Dir, Maj_Version); + end if; + end; + end if; + end Build_Dynamic_Library; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "sl"; + end DLL_Ext; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a" or else Ext = ".so"; + end Is_Archive_Ext; + +begin + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + DLL_Ext_Ptr := DLL_Ext'Access; + Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; +end MLib.Tgt.Specific; diff --git a/gcc/ada/mlib-tgt-specific-irix.adb b/gcc/ada/mlib-tgt-specific-irix.adb new file mode 100644 index 000000000..cba87387a --- /dev/null +++ b/gcc/ada/mlib-tgt-specific-irix.adb @@ -0,0 +1,182 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T . S P E C I F I C -- +-- (IRIX Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the IRIX version of the body + +with MLib.Fil; +with MLib.Utl; +with Opt; +with Output; use Output; + +package body MLib.Tgt.Specific is + + -- Non default subprogram + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + function Is_Archive_Ext (Ext : String) return Boolean; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Auto_Init); + + Lib_File : constant String := + "lib" & MLib.Fil.Append_To (Lib_Filename, DLL_Ext); + + Lib_Path : constant String := + Lib_Dir & Directory_Separator & Lib_File; + + Version_Arg : String_Access; + Symbolic_Link_Needed : Boolean := False; + + N_Options : Argument_List := Options; + Options_Last : Natural := N_Options'Last; + -- After moving -lxxx to Options_2, N_Options up to index Options_Last + -- will contain the Options to pass to MLib.Utl.Gcc. + + Real_Options_2 : Argument_List (1 .. Options'Length); + Real_Options_2_Last : Natural := 0; + -- Real_Options_2 up to index Real_Options_2_Last will contain the + -- Options_2 to pass to MLib.Utl.Gcc. + + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_Path); + end if; + + -- Move all -lxxx to Options_2 + + declare + Index : Natural := N_Options'First; + Arg : String_Access; + + begin + while Index <= Options_Last loop + Arg := N_Options (Index); + + if Arg'Length > 2 + and then Arg (Arg'First .. Arg'First + 1) = "-l" + then + Real_Options_2_Last := Real_Options_2_Last + 1; + Real_Options_2 (Real_Options_2_Last) := Arg; + N_Options (Index .. Options_Last - 1) := + N_Options (Index + 1 .. Options_Last); + Options_Last := Options_Last - 1; + + else + Index := Index + 1; + end if; + end loop; + end; + + if Lib_Version = "" then + MLib.Utl.Gcc + (Output_File => Lib_Path, + Objects => Ofiles, + Options => N_Options (N_Options'First .. Options_Last), + Driver_Name => Driver_Name, + Options_2 => Real_Options_2 (1 .. Real_Options_2_Last)); + + else + declare + Maj_Version : constant String := + Major_Id_Name (Lib_File, Lib_Version); + begin + if Maj_Version'Length /= 0 then + Version_Arg := new String'("-Wl,-soname," & Maj_Version); + + else + Version_Arg := new String'("-Wl,-soname," & Lib_Version); + end if; + + if Is_Absolute_Path (Lib_Version) then + MLib.Utl.Gcc + (Output_File => Lib_Version, + Objects => Ofiles, + Options => N_Options (N_Options'First .. Options_Last) & + Version_Arg, + Driver_Name => Driver_Name, + Options_2 => Real_Options_2 (1 .. Real_Options_2_Last)); + Symbolic_Link_Needed := Lib_Version /= Lib_Path; + + else + MLib.Utl.Gcc + (Output_File => Lib_Dir & Directory_Separator & Lib_Version, + Objects => Ofiles, + Options => N_Options (N_Options'First .. Options_Last) & + Version_Arg, + Driver_Name => Driver_Name, + Options_2 => Real_Options_2 (1 .. Real_Options_2_Last)); + Symbolic_Link_Needed := + Lib_Dir & Directory_Separator & Lib_Version /= Lib_Path; + end if; + + if Symbolic_Link_Needed then + Create_Sym_Links + (Lib_Path, Lib_Version, Lib_Dir, Maj_Version); + end if; + end; + end if; + end Build_Dynamic_Library; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a" or else Ext = ".so"; + end Is_Archive_Ext; + +begin + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; +end MLib.Tgt.Specific; diff --git a/gcc/ada/mlib-tgt-specific-linux.adb b/gcc/ada/mlib-tgt-specific-linux.adb new file mode 100644 index 000000000..8559966bf --- /dev/null +++ b/gcc/ada/mlib-tgt-specific-linux.adb @@ -0,0 +1,148 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T . S P E C I F I C -- +-- (GNU/Linux Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the GNU/Linux version of the body + +with MLib.Fil; +with MLib.Utl; +with Opt; +with Output; use Output; + +package body MLib.Tgt.Specific is + + use MLib; + + -- Non default subprograms + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + function Is_Archive_Ext (Ext : String) return Boolean; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Auto_Init); + -- Initialization is done through the constructor mechanism + + Lib_File : constant String := + "lib" & Fil.Append_To (Lib_Filename, DLL_Ext); + + Lib_Path : constant String := + Lib_Dir & Directory_Separator & Lib_File; + + Version_Arg : String_Access; + Symbolic_Link_Needed : Boolean := False; + + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_Path); + end if; + + if Lib_Version = "" then + Utl.Gcc + (Output_File => Lib_Path, + Objects => Ofiles, + Options => Options, + Driver_Name => Driver_Name, + Options_2 => No_Argument_List); + + else + declare + Maj_Version : constant String := + Major_Id_Name (Lib_File, Lib_Version); + begin + if Maj_Version'Length /= 0 then + Version_Arg := new String'("-Wl,-soname," & Maj_Version); + + else + Version_Arg := new String'("-Wl,-soname," & Lib_Version); + end if; + + if Is_Absolute_Path (Lib_Version) then + Utl.Gcc + (Output_File => Lib_Version, + Objects => Ofiles, + Options => Options & Version_Arg, + Driver_Name => Driver_Name, + Options_2 => No_Argument_List); + Symbolic_Link_Needed := Lib_Version /= Lib_Path; + + else + Utl.Gcc + (Output_File => Lib_Dir & Directory_Separator & Lib_Version, + Objects => Ofiles, + Options => Options & Version_Arg, + Driver_Name => Driver_Name, + Options_2 => No_Argument_List); + Symbolic_Link_Needed := + Lib_Dir & Directory_Separator & Lib_Version /= Lib_Path; + end if; + + if Symbolic_Link_Needed then + Create_Sym_Links + (Lib_Path, Lib_Version, Lib_Dir, Maj_Version); + end if; + end; + end if; + end Build_Dynamic_Library; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a" or else Ext = ".so"; + end Is_Archive_Ext; + +begin + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; +end MLib.Tgt.Specific; diff --git a/gcc/ada/mlib-tgt-specific-lynxos.adb b/gcc/ada/mlib-tgt-specific-lynxos.adb new file mode 100644 index 000000000..cb1f8772e --- /dev/null +++ b/gcc/ada/mlib-tgt-specific-lynxos.adb @@ -0,0 +1,149 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T . S P E C I F I C -- +-- (LynxOS Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the LynxOS version of the body + +package body MLib.Tgt.Specific is + + -- Non default subprograms + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + function DLL_Ext return String; + + function Dynamic_Option return String; + + function PIC_Option return String; + + function Library_Major_Minor_Id_Supported return Boolean; + + function Standalone_Library_Auto_Init_Is_Supported return Boolean; + + function Support_For_Libraries return Library_Support; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Ofiles); + pragma Unreferenced (Options); + pragma Unreferenced (Interfaces); + pragma Unreferenced (Lib_Filename); + pragma Unreferenced (Lib_Dir); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Driver_Name); + pragma Unreferenced (Lib_Version); + pragma Unreferenced (Auto_Init); + + begin + null; + end Build_Dynamic_Library; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return ""; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return ""; + end Dynamic_Option; + + -------------------------------------- + -- Library_Major_Minor_Id_Supported -- + -------------------------------------- + + function Library_Major_Minor_Id_Supported return Boolean is + begin + return False; + end Library_Major_Minor_Id_Supported; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return ""; + end PIC_Option; + + ----------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported -- + ----------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported return Boolean is + begin + return False; + end Standalone_Library_Auto_Init_Is_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Static_Only; + end Support_For_Libraries; + +begin + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + DLL_Ext_Ptr := DLL_Ext'Access; + Dynamic_Option_Ptr := Dynamic_Option'Access; + Library_Major_Minor_Id_Supported_Ptr := + Library_Major_Minor_Id_Supported'Access; + PIC_Option_Ptr := PIC_Option'Access; + Standalone_Library_Auto_Init_Is_Supported_Ptr := + Standalone_Library_Auto_Init_Is_Supported'Access; + Support_For_Libraries_Ptr := Support_For_Libraries'Access; +end MLib.Tgt.Specific; diff --git a/gcc/ada/mlib-tgt-specific-mingw.adb b/gcc/ada/mlib-tgt-specific-mingw.adb new file mode 100644 index 000000000..f1eedf5f2 --- /dev/null +++ b/gcc/ada/mlib-tgt-specific-mingw.adb @@ -0,0 +1,162 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T . S P E C I F I C -- +-- (Windows Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Windows version of the body. Works only with GCC versions +-- supporting the "-shared" option. + +with Opt; +with Output; use Output; + +with MLib.Fil; +with MLib.Utl; + +package body MLib.Tgt.Specific is + + package Files renames MLib.Fil; + package Tools renames MLib.Utl; + + -- Non default subprograms + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + function DLL_Ext return String; + + function DLL_Prefix return String; + + function Is_Archive_Ext (Ext : String) return Boolean; + + function Library_Major_Minor_Id_Supported return Boolean; + + function PIC_Option return String; + + Shared_Libgcc : aliased String := "-shared-libgcc"; + + Shared_Libgcc_Switch : constant Argument_List := + (1 => Shared_Libgcc'Access); + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Interfaces); + pragma Unreferenced (Lib_Version); + pragma Unreferenced (Auto_Init); + + Lib_File : constant String := + Lib_Dir & Directory_Separator & + DLL_Prefix & Files.Append_To (Lib_Filename, DLL_Ext); + + -- Start of processing for Build_Dynamic_Library + + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_File); + end if; + + Tools.Gcc + (Output_File => Lib_File, + Objects => Ofiles, + Options => Shared_Libgcc_Switch, + Options_2 => Options, + Driver_Name => Driver_Name); + end Build_Dynamic_Library; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "dll"; + end DLL_Ext; + + ---------------- + -- DLL_Prefix -- + ---------------- + + function DLL_Prefix return String is + begin + return "lib"; + end DLL_Prefix; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a" or else Ext = ".dll"; + end Is_Archive_Ext; + + -------------------------------------- + -- Library_Major_Minor_Id_Supported -- + -------------------------------------- + + function Library_Major_Minor_Id_Supported return Boolean is + begin + return False; + end Library_Major_Minor_Id_Supported; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return ""; + end PIC_Option; + +begin + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + DLL_Ext_Ptr := DLL_Ext'Access; + DLL_Prefix_Ptr := DLL_Prefix'Access; + Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; + PIC_Option_Ptr := PIC_Option'Access; + Library_Major_Minor_Id_Supported_Ptr := + Library_Major_Minor_Id_Supported'Access; +end MLib.Tgt.Specific; diff --git a/gcc/ada/mlib-tgt-specific-solaris.adb b/gcc/ada/mlib-tgt-specific-solaris.adb new file mode 100644 index 000000000..d7cdfcc49 --- /dev/null +++ b/gcc/ada/mlib-tgt-specific-solaris.adb @@ -0,0 +1,145 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T . S P E C I F I C -- +-- (Solaris Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Solaris version of the body + +with MLib.Fil; +with MLib.Utl; +with Opt; +with Output; use Output; + +package body MLib.Tgt.Specific is + + -- Non default subprograms + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + function Is_Archive_Ext (Ext : String) return Boolean; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Auto_Init); + + Lib_File : constant String := + "lib" & Fil.Append_To (Lib_Filename, DLL_Ext); + + Lib_Path : constant String := + Lib_Dir & Directory_Separator & Lib_File; + + Version_Arg : String_Access; + Symbolic_Link_Needed : Boolean := False; + + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_Path); + end if; + + if Lib_Version = "" then + Utl.Gcc + (Output_File => Lib_Path, + Objects => Ofiles, + Options => Options, + Options_2 => No_Argument_List, + Driver_Name => Driver_Name); + + else + declare + Maj_Version : constant String := + Major_Id_Name (Lib_File, Lib_Version); + begin + if Maj_Version'Length /= 0 then + Version_Arg := new String'("-Wl,-h," & Maj_Version); + + else + Version_Arg := new String'("-Wl,-h," & Lib_Version); + end if; + + if Is_Absolute_Path (Lib_Version) then + Utl.Gcc + (Output_File => Lib_Version, + Objects => Ofiles, + Options => Options & Version_Arg, + Options_2 => No_Argument_List, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := Lib_Version /= Lib_Path; + + else + Utl.Gcc + (Output_File => Lib_Dir & Directory_Separator & Lib_Version, + Objects => Ofiles, + Options => Options & Version_Arg, + Options_2 => No_Argument_List, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := + Lib_Dir & Directory_Separator & Lib_Version /= Lib_Path; + end if; + + if Symbolic_Link_Needed then + Create_Sym_Links + (Lib_Path, Lib_Version, Lib_Dir, Maj_Version); + end if; + end; + end if; + end Build_Dynamic_Library; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a" or else Ext = ".so"; + end Is_Archive_Ext; + +begin + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; +end MLib.Tgt.Specific; diff --git a/gcc/ada/mlib-tgt-specific-tru64.adb b/gcc/ada/mlib-tgt-specific-tru64.adb new file mode 100644 index 000000000..b5f5a1371 --- /dev/null +++ b/gcc/ada/mlib-tgt-specific-tru64.adb @@ -0,0 +1,168 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T . S P E C I F I C -- +-- (Tru64 Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Tru64 version of the body + +with MLib.Fil; +with MLib.Utl; +with Opt; +with Output; use Output; + +package body MLib.Tgt.Specific is + + use MLib; + + -- Non default subprogram + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + function Is_Archive_Ext (Ext : String) return Boolean; + + function PIC_Option return String; + + -- Local variables + + Expect_Unresolved : aliased String := "-Wl,-expect_unresolved,*"; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Auto_Init); + -- Initialization is done through the constructor mechanism + + Lib_File : constant String := + "lib" & Fil.Append_To (Lib_Filename, DLL_Ext); + + Lib_Path : constant String := + Lib_Dir & Directory_Separator & Lib_File; + + Version_Arg : String_Access; + Symbolic_Link_Needed : Boolean := False; + + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_Path); + end if; + + -- If specified, add automatic elaboration/finalization + + if Lib_Version = "" then + Utl.Gcc + (Output_File => Lib_Path, + Objects => Ofiles, + Options => Options & Expect_Unresolved'Access, + Options_2 => No_Argument_List, + Driver_Name => Driver_Name); + + else + declare + Maj_Version : constant String := + Major_Id_Name (Lib_File, Lib_Version); + begin + if Maj_Version'Length /= 0 then + Version_Arg := new String'("-Wl,-soname," & Maj_Version); + + else + Version_Arg := new String'("-Wl,-soname," & Lib_Version); + end if; + + if Is_Absolute_Path (Lib_Version) then + Utl.Gcc + (Output_File => Lib_Version, + Objects => Ofiles, + Options => + Options & Version_Arg & Expect_Unresolved'Access, + Options_2 => No_Argument_List, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := Lib_Version /= Lib_Path; + + else + Utl.Gcc + (Output_File => Lib_Dir & Directory_Separator & Lib_Version, + Objects => Ofiles, + Options => + Options & Version_Arg & Expect_Unresolved'Access, + Options_2 => No_Argument_List, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := + Lib_Dir & Directory_Separator & Lib_Version /= Lib_Path; + end if; + + if Symbolic_Link_Needed then + Create_Sym_Links + (Lib_Path, Lib_Version, Lib_Dir, Maj_Version); + end if; + end; + end if; + end Build_Dynamic_Library; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a" or else Ext = ".so"; + end Is_Archive_Ext; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return ""; + end PIC_Option; + +begin + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; + PIC_Option_Ptr := PIC_Option'Access; +end MLib.Tgt.Specific; diff --git a/gcc/ada/mlib-tgt-specific-vms-alpha.adb b/gcc/ada/mlib-tgt-specific-vms-alpha.adb new file mode 100644 index 000000000..c9ffa0d83 --- /dev/null +++ b/gcc/ada/mlib-tgt-specific-vms-alpha.adb @@ -0,0 +1,513 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T . S P E C I F I C -- +-- (Alpha VMS Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Alpha VMS version of the body + +with Ada.Characters.Handling; use Ada.Characters.Handling; + +with MLib.Fil; +with MLib.Utl; + +with MLib.Tgt.VMS_Common; +pragma Warnings (Off, MLib.Tgt.VMS_Common); +-- MLib.Tgt.VMS_Common is with'ed only for elaboration purposes + +with Opt; use Opt; +with Output; use Output; + +with GNAT.Directory_Operations; use GNAT.Directory_Operations; + +with System; use System; +with System.Case_Util; use System.Case_Util; +with System.CRTL; use System.CRTL; + +package body MLib.Tgt.Specific is + + -- Non default subprogram. See comment in mlib-tgt.ads + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + -- Local variables + + Empty_Argument_List : aliased Argument_List := (1 .. 0 => null); + Additional_Objects : Argument_List_Access := Empty_Argument_List'Access; + -- Used to add the generated auto-init object files for auto-initializing + -- stand-alone libraries. + + Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler"; + -- The name of the command to invoke the macro-assembler + + VMS_Options : Argument_List := (1 .. 1 => null); + + Gnatsym_Name : constant String := "gnatsym"; + + Gnatsym_Path : String_Access; + + Arguments : Argument_List_Access := null; + Last_Argument : Natural := 0; + + Success : Boolean := False; + + Shared_Libgcc : aliased String := "-shared-libgcc"; + + Shared_Libgcc_Switch : constant Argument_List := + (1 => Shared_Libgcc'Access); + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + + Lib_File : constant String := + Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Filename, DLL_Ext); + + Opts : Argument_List := Options; + Last_Opt : Natural := Opts'Last; + Opts2 : Argument_List (Options'Range); + Last_Opt2 : Natural := Opts2'First - 1; + + Inter : constant Argument_List := Interfaces; + + function Is_Interface (Obj_File : String) return Boolean; + -- For a Stand-Alone Library, returns True if Obj_File is the object + -- file name of an interface of the SAL. For other libraries, always + -- return True. + + function Option_File_Name return String; + -- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt" + + function Version_String return String; + -- Returns Lib_Version if not empty and if Symbol_Data.Symbol_Policy is + -- not Autonomous, otherwise returns "". When Symbol_Data.Symbol_Policy + -- is Autonomous, fails gnatmake if Lib_Version is not the image of a + -- positive number. + + ------------------ + -- Is_Interface -- + ------------------ + + function Is_Interface (Obj_File : String) return Boolean is + ALI : constant String := + Fil.Ext_To + (Filename => To_Lower (Base_Name (Obj_File)), + New_Ext => "ali"); + + begin + if Inter'Length = 0 then + return True; + + elsif ALI'Length > 2 and then + ALI (ALI'First .. ALI'First + 2) = "b__" + then + return True; + + else + for J in Inter'Range loop + if Inter (J).all = ALI then + return True; + end if; + end loop; + + return False; + end if; + end Is_Interface; + + ---------------------- + -- Option_File_Name -- + ---------------------- + + function Option_File_Name return String is + begin + if Symbol_Data.Symbol_File = No_Path then + return "symvec.opt"; + else + Get_Name_String (Symbol_Data.Symbol_File); + To_Lower (Name_Buffer (1 .. Name_Len)); + return Name_Buffer (1 .. Name_Len); + end if; + end Option_File_Name; + + -------------------- + -- Version_String -- + -------------------- + + function Version_String return String is + Version : Integer := 0; + + begin + if Lib_Version = "" + or else Symbol_Data.Symbol_Policy /= Autonomous + then + return ""; + + else + begin + Version := Integer'Value (Lib_Version); + + if Version <= 0 then + raise Constraint_Error; + end if; + + return Lib_Version; + + exception + when Constraint_Error => + Fail ("illegal version """ + & Lib_Version + & """ (on VMS version must be a positive number)"); + return ""; + end; + end if; + end Version_String; + + --------------------- + -- Local Variables -- + --------------------- + + Opt_File_Name : constant String := Option_File_Name; + Version : constant String := Version_String; + For_Linker_Opt : String_Access; + + -- Start of processing for Build_Dynamic_Library + + begin + -- If option file name does not ends with ".opt", append "/OPTIONS" + -- to its specification for the VMS linker. + + if Opt_File_Name'Length > 4 + and then + Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt" + then + For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name); + else + For_Linker_Opt := + new String'("--for-linker=" & Opt_File_Name & "/OPTIONS"); + end if; + + VMS_Options (VMS_Options'First) := For_Linker_Opt; + + for J in Inter'Range loop + To_Lower (Inter (J).all); + end loop; + + -- "gnatsym" is necessary for building the option file + + if Gnatsym_Path = null then + Gnatsym_Path := Locate_Exec_On_Path (Gnatsym_Name); + + if Gnatsym_Path = null then + Fail (Gnatsym_Name & " not found in path"); + end if; + end if; + + -- For auto-initialization of a stand-alone library, we create + -- a macro-assembly file and we invoke the macro-assembler. + + if Auto_Init then + declare + Macro_File_Name : constant String := Lib_Filename & "__init.asm"; + Macro_File : File_Descriptor; + Init_Proc : String := Lib_Filename & "INIT"; + Popen_Result : System.Address; + Pclose_Result : Integer; + Len : Natural; + OK : Boolean := True; + + command : constant String := + Macro_Name & " " & Macro_File_Name & ASCII.NUL; + -- The command to invoke the assembler on the generated auto-init + -- assembly file. + + mode : constant String := "r" & ASCII.NUL; + -- The mode for the invocation of Popen + + begin + To_Upper (Init_Proc); + + if Verbose_Mode then + Write_Str ("Creating auto-init assembly file """); + Write_Str (Macro_File_Name); + Write_Line (""""); + end if; + + -- Create and write the auto-init assembly file + + declare + use ASCII; + + -- Output a dummy transfer address for debugging + -- followed by the LIB$INITIALIZE section. + + Lines : constant String := + HT & ".text" & LF & + HT & ".align 4" & LF & + HT & ".globl __main" & LF & + HT & ".ent __main" & LF & + "__main..en:" & LF & + HT & ".base $27" & LF & + HT & ".frame $29,0,$26,8" & LF & + HT & "ret $31,($26),1" & LF & + HT & ".link" & LF & + "__main:" & LF & + HT & ".pdesc __main..en,null" & LF & + HT & ".end __main" & LF & LF & + HT & ".section LIB$INITIALIZE,GBL,NOWRT" & LF & + HT & ".long " & Init_Proc & LF; + + begin + Macro_File := Create_File (Macro_File_Name, Text); + OK := Macro_File /= Invalid_FD; + + if OK then + Len := Write + (Macro_File, Lines (Lines'First)'Address, + Lines'Length); + OK := Len = Lines'Length; + end if; + + if OK then + Close (Macro_File, OK); + end if; + + if not OK then + Fail ("creation of auto-init assembly file """ + & Macro_File_Name + & """ failed"); + end if; + end; + + -- Invoke the macro-assembler + + if Verbose_Mode then + Write_Str ("Assembling auto-init assembly file """); + Write_Str (Macro_File_Name); + Write_Line (""""); + end if; + + Popen_Result := popen (command (command'First)'Address, + mode (mode'First)'Address); + + if Popen_Result = Null_Address then + Fail ("assembly of auto-init assembly file """ + & Macro_File_Name + & """ failed"); + end if; + + -- Wait for the end of execution of the macro-assembler + + Pclose_Result := pclose (Popen_Result); + + if Pclose_Result < 0 then + Fail ("assembly of auto init assembly file """ + & Macro_File_Name + & """ failed"); + end if; + + -- Add the generated object file to the list of objects to be + -- included in the library. + + Additional_Objects := + new Argument_List' + (1 => new String'(Lib_Filename & "__init.obj")); + end; + end if; + + -- Allocate the argument list and put the symbol file name, the + -- reference (if any) and the policy (if not autonomous). + + Arguments := new Argument_List (1 .. Ofiles'Length + 8); + + Last_Argument := 0; + + -- Verbosity + + if Verbose_Mode then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-v"); + end if; + + -- Version number (major ID) + + if Lib_Version /= "" then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-V"); + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'(Version); + end if; + + -- Symbol file + + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-s"); + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'(Opt_File_Name); + + -- Reference Symbol File + + if Symbol_Data.Reference /= No_Path then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-r"); + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := + new String'(Get_Name_String (Symbol_Data.Reference)); + end if; + + -- Policy + + case Symbol_Data.Symbol_Policy is + when Autonomous => + null; + + when Compliant => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-c"); + + when Controlled => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-C"); + + when Restricted => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-R"); + + when Direct => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-D"); + + end case; + + -- Add each relevant object file + + for Index in Ofiles'Range loop + if Is_Interface (Ofiles (Index).all) then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'(Ofiles (Index).all); + end if; + end loop; + + -- Spawn gnatsym + + Spawn (Program_Name => Gnatsym_Path.all, + Args => Arguments (1 .. Last_Argument), + Success => Success); + + if not Success then + Fail ("unable to create symbol file for library """ + & Lib_Filename + & """"); + end if; + + Free (Arguments); + + -- Move all the -l switches from Opts to Opts2 + + declare + Index : Natural := Opts'First; + Opt : String_Access; + + begin + while Index <= Last_Opt loop + Opt := Opts (Index); + + if Opt'Length > 2 and then + Opt (Opt'First .. Opt'First + 1) = "-l" + then + if Index < Last_Opt then + Opts (Index .. Last_Opt - 1) := + Opts (Index + 1 .. Last_Opt); + end if; + + Last_Opt := Last_Opt - 1; + + Last_Opt2 := Last_Opt2 + 1; + Opts2 (Last_Opt2) := Opt; + + else + Index := Index + 1; + end if; + end loop; + end; + + -- Invoke gcc to build the library + + Utl.Gcc + (Output_File => Lib_File, + Objects => Ofiles & Additional_Objects.all, + Options => VMS_Options, + Options_2 => Shared_Libgcc_Switch & + Opts (Opts'First .. Last_Opt) & + Opts2 (Opts2'First .. Last_Opt2), + Driver_Name => Driver_Name); + + -- The auto-init object file need to be deleted, so that it will not + -- be included in the library as a regular object file, otherwise + -- it will be included twice when the library will be built next + -- time, which may lead to errors. + + if Auto_Init then + declare + Auto_Init_Object_File_Name : constant String := + Lib_Filename & "__init.obj"; + Disregard : Boolean; + + begin + if Verbose_Mode then + Write_Str ("deleting auto-init object file """); + Write_Str (Auto_Init_Object_File_Name); + Write_Line (""""); + end if; + + Delete_File (Auto_Init_Object_File_Name, Success => Disregard); + end; + end if; + end Build_Dynamic_Library; + +-- Package initialization + +begin + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; +end MLib.Tgt.Specific; diff --git a/gcc/ada/mlib-tgt-specific-vms-ia64.adb b/gcc/ada/mlib-tgt-specific-vms-ia64.adb new file mode 100644 index 000000000..247b2eb30 --- /dev/null +++ b/gcc/ada/mlib-tgt-specific-vms-ia64.adb @@ -0,0 +1,517 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T . S P E C I F I C -- +-- (Integrity VMS Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Integrity VMS version of the body + +with Ada.Characters.Handling; use Ada.Characters.Handling; + +with MLib.Fil; +with MLib.Utl; + +with MLib.Tgt.VMS_Common; +pragma Warnings (Off, MLib.Tgt.VMS_Common); +-- MLib.Tgt.VMS_Common is with'ed only for elaboration purposes + +with Opt; use Opt; +with Output; use Output; + +with GNAT.Directory_Operations; use GNAT.Directory_Operations; + +with System; use System; +with System.Case_Util; use System.Case_Util; +with System.CRTL; use System.CRTL; + +package body MLib.Tgt.Specific is + + -- Non default subprogram, see comment in mlib-tgt.ads + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + -- Local variables + + Empty_Argument_List : aliased Argument_List := (1 .. 0 => null); + Additional_Objects : Argument_List_Access := Empty_Argument_List'Access; + -- Used to add the generated auto-init object files for auto-initializing + -- stand-alone libraries. + + Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler"; + -- The name of the command to invoke the macro-assembler + + VMS_Options : Argument_List := (1 .. 1 => null); + + Gnatsym_Name : constant String := "gnatsym"; + + Gnatsym_Path : String_Access; + + Arguments : Argument_List_Access := null; + Last_Argument : Natural := 0; + + Success : Boolean := False; + + Shared_Libgcc : aliased String := "-shared-libgcc"; + + Shared_Libgcc_Switch : constant Argument_List := + (1 => Shared_Libgcc'Access); + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + + Lib_File : constant String := + Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Filename, DLL_Ext); + + Opts : Argument_List := Options; + Last_Opt : Natural := Opts'Last; + Opts2 : Argument_List (Options'Range); + Last_Opt2 : Natural := Opts2'First - 1; + + Inter : constant Argument_List := Interfaces; + + function Is_Interface (Obj_File : String) return Boolean; + -- For a Stand-Alone Library, returns True if Obj_File is the object + -- file name of an interface of the SAL. For other libraries, always + -- return True. + + function Option_File_Name return String; + -- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt" + + function Version_String return String; + -- Returns Lib_Version if not empty and if Symbol_Data.Symbol_Policy is + -- not Autonomous, otherwise returns "". When Symbol_Data.Symbol_Policy + -- is Autonomous, fails gnatmake if Lib_Version is not the image of a + -- positive number. + + ------------------ + -- Is_Interface -- + ------------------ + + function Is_Interface (Obj_File : String) return Boolean is + ALI : constant String := + Fil.Ext_To + (Filename => To_Lower (Base_Name (Obj_File)), + New_Ext => "ali"); + + begin + if Inter'Length = 0 then + return True; + + elsif ALI'Length > 2 and then + ALI (ALI'First .. ALI'First + 2) = "b__" + then + return True; + + else + for J in Inter'Range loop + if Inter (J).all = ALI then + return True; + end if; + end loop; + + return False; + end if; + end Is_Interface; + + ---------------------- + -- Option_File_Name -- + ---------------------- + + function Option_File_Name return String is + begin + if Symbol_Data.Symbol_File = No_Path then + return "symvec.opt"; + else + Get_Name_String (Symbol_Data.Symbol_File); + To_Lower (Name_Buffer (1 .. Name_Len)); + return Name_Buffer (1 .. Name_Len); + end if; + end Option_File_Name; + + -------------------- + -- Version_String -- + -------------------- + + function Version_String return String is + Version : Integer := 0; + begin + if Lib_Version = "" + or else Symbol_Data.Symbol_Policy /= Autonomous + then + return ""; + + else + begin + Version := Integer'Value (Lib_Version); + + if Version <= 0 then + raise Constraint_Error; + end if; + + return Lib_Version; + + exception + when Constraint_Error => + Fail ("illegal version """ + & Lib_Version + & """ (on VMS version must be a positive number)"); + return ""; + end; + end if; + end Version_String; + + --------------------- + -- Local Variables -- + --------------------- + + Opt_File_Name : constant String := Option_File_Name; + Version : constant String := Version_String; + For_Linker_Opt : String_Access; + + -- Start of processing for Build_Dynamic_Library + + begin + -- Option file must end with ".opt" + + if Opt_File_Name'Length > 4 + and then + Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt" + then + For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name); + else + Fail ("Options File """ & Opt_File_Name & """ must end with .opt"); + end if; + + VMS_Options (VMS_Options'First) := For_Linker_Opt; + + for J in Inter'Range loop + To_Lower (Inter (J).all); + end loop; + + -- "gnatsym" is necessary for building the option file + + if Gnatsym_Path = null then + Gnatsym_Path := Locate_Exec_On_Path (Gnatsym_Name); + + if Gnatsym_Path = null then + Fail (Gnatsym_Name & " not found in path"); + end if; + end if; + + -- For auto-initialization of a stand-alone library, we create + -- a macro-assembly file and we invoke the macro-assembler. + + if Auto_Init then + declare + Macro_File_Name : constant String := Lib_Filename & "__init.asm"; + Macro_File : File_Descriptor; + Init_Proc : String := Lib_Filename & "INIT"; + Popen_Result : System.Address; + Pclose_Result : Integer; + Len : Natural; + OK : Boolean := True; + + command : constant String := + Macro_Name & " " & Macro_File_Name & ASCII.NUL; + -- The command to invoke the assembler on the generated auto-init + -- assembly file. + -- Why odd lower case name ??? + + mode : constant String := "r" & ASCII.NUL; + -- The mode for the invocation of Popen + -- Why odd lower case name ??? + + begin + To_Upper (Init_Proc); + + if Verbose_Mode then + Write_Str ("Creating auto-init assembly file """); + Write_Str (Macro_File_Name); + Write_Line (""""); + end if; + + -- Create and write the auto-init assembly file + + declare + use ASCII; + + -- Output a dummy transfer address for debugging + -- followed by the LIB$INITIALIZE section. + + Lines : constant String := + HT & ".pred.safe_across_calls p1-p5,p16-p63" & LF & + HT & ".text" & LF & + HT & ".align 16" & LF & + HT & ".global __main#" & LF & + HT & ".proc __main#" & LF & + "__main:" & LF & + HT & ".prologue" & LF & + HT & ".body" & LF & + HT & ".mib" & LF & + HT & "nop 0" & LF & + HT & "nop 0" & LF & + HT & "br.ret.sptk.many b0" & LF & + HT & ".endp __main#" & LF & LF & + HT & ".type " & Init_Proc & "#, @function" & LF & + HT & ".global " & Init_Proc & "#" & LF & + HT & ".global LIB$INITIALIZE#" & LF & + HT & ".section LIB$INITIALIZE#,""a"",@progbits" & LF & + HT & "data4 @fptr(" & Init_Proc & "#)" & LF; + + begin + Macro_File := Create_File (Macro_File_Name, Text); + OK := Macro_File /= Invalid_FD; + + if OK then + Len := Write + (Macro_File, Lines (Lines'First)'Address, + Lines'Length); + OK := Len = Lines'Length; + end if; + + if OK then + Close (Macro_File, OK); + end if; + + if not OK then + Fail ("creation of auto-init assembly file """ + & Macro_File_Name + & """ failed"); + end if; + end; + + -- Invoke the macro-assembler + + if Verbose_Mode then + Write_Str ("Assembling auto-init assembly file """); + Write_Str (Macro_File_Name); + Write_Line (""""); + end if; + + Popen_Result := popen (command (command'First)'Address, + mode (mode'First)'Address); + + if Popen_Result = Null_Address then + Fail ("assembly of auto-init assembly file """ + & Macro_File_Name + & """ failed"); + end if; + + -- Wait for the end of execution of the macro-assembler + + Pclose_Result := pclose (Popen_Result); + + if Pclose_Result < 0 then + Fail ("assembly of auto init assembly file """ + & Macro_File_Name + & """ failed"); + end if; + + -- Add the generated object file to the list of objects to be + -- included in the library. + + Additional_Objects := + new Argument_List' + (1 => new String'(Lib_Filename & "__init.obj")); + end; + end if; + + -- Allocate the argument list and put the symbol file name, the + -- reference (if any) and the policy (if not autonomous). + + Arguments := new Argument_List (1 .. Ofiles'Length + 8); + + Last_Argument := 0; + + -- Verbosity + + if Verbose_Mode then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-v"); + end if; + + -- Version number (major ID) + + if Lib_Version /= "" then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-V"); + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'(Version); + end if; + + -- Symbol file + + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-s"); + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'(Opt_File_Name); + + -- Reference Symbol File + + if Symbol_Data.Reference /= No_Path then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-r"); + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := + new String'(Get_Name_String (Symbol_Data.Reference)); + end if; + + -- Policy + + case Symbol_Data.Symbol_Policy is + when Autonomous => + null; + + when Compliant => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-c"); + + when Controlled => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-C"); + + when Restricted => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-R"); + + when Direct => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-D"); + end case; + + -- Add each relevant object file + + for Index in Ofiles'Range loop + if Is_Interface (Ofiles (Index).all) then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'(Ofiles (Index).all); + end if; + end loop; + + -- Spawn gnatsym + + Spawn (Program_Name => Gnatsym_Path.all, + Args => Arguments (1 .. Last_Argument), + Success => Success); + + if not Success then + Fail ("unable to create symbol file for library """ + & Lib_Filename + & """"); + end if; + + Free (Arguments); + + -- Move all the -l switches from Opts to Opts2 + + declare + Index : Natural := Opts'First; + Opt : String_Access; + + begin + while Index <= Last_Opt loop + Opt := Opts (Index); + + if Opt'Length > 2 and then + Opt (Opt'First .. Opt'First + 1) = "-l" + then + if Index < Last_Opt then + Opts (Index .. Last_Opt - 1) := + Opts (Index + 1 .. Last_Opt); + end if; + + Last_Opt := Last_Opt - 1; + + Last_Opt2 := Last_Opt2 + 1; + Opts2 (Last_Opt2) := Opt; + + else + Index := Index + 1; + end if; + end loop; + end; + + -- Invoke gcc to build the library + + Utl.Gcc + (Output_File => Lib_File, + Objects => Ofiles & Additional_Objects.all, + Options => VMS_Options, + Options_2 => Shared_Libgcc_Switch & + Opts (Opts'First .. Last_Opt) & + Opts2 (Opts2'First .. Last_Opt2), + Driver_Name => Driver_Name); + + -- The auto-init object file need to be deleted, so that it will not + -- be included in the library as a regular object file, otherwise + -- it will be included twice when the library will be built next + -- time, which may lead to errors. + + if Auto_Init then + declare + Auto_Init_Object_File_Name : constant String := + Lib_Filename & "__init.obj"; + + Disregard : Boolean; + pragma Warnings (Off, Disregard); + + begin + if Verbose_Mode then + Write_Str ("deleting auto-init object file """); + Write_Str (Auto_Init_Object_File_Name); + Write_Line (""""); + end if; + + Delete_File (Auto_Init_Object_File_Name, Success => Disregard); + end; + end if; + end Build_Dynamic_Library; + +-- Package initialization + +begin + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; +end MLib.Tgt.Specific; diff --git a/gcc/ada/mlib-tgt-specific-vxworks.adb b/gcc/ada/mlib-tgt-specific-vxworks.adb new file mode 100644 index 000000000..1e1fad1d7 --- /dev/null +++ b/gcc/ada/mlib-tgt-specific-vxworks.adb @@ -0,0 +1,217 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T . S P E C I F I C -- +-- (VxWorks Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VxWorks version of the body + +with Sdefault; + +package body MLib.Tgt.Specific is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Get_Target_Suffix return String; + -- Returns the required suffix for some utilities + -- (such as ar and ranlib) that depend on the real target. + + -- Non default subprograms + + function Archive_Builder return String; + + function Archive_Indexer return String; + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + function DLL_Ext return String; + + function Dynamic_Option return String; + + function Library_Major_Minor_Id_Supported return Boolean; + + function PIC_Option return String; + + function Standalone_Library_Auto_Init_Is_Supported return Boolean; + + function Support_For_Libraries return Library_Support; + + --------------------- + -- Archive_Builder -- + --------------------- + + function Archive_Builder return String is + begin + return "ar" & Get_Target_Suffix; + end Archive_Builder; + + --------------------- + -- Archive_Indexer -- + --------------------- + + function Archive_Indexer return String is + begin + return "ranlib" & Get_Target_Suffix; + end Archive_Indexer; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Ofiles); + pragma Unreferenced (Options); + pragma Unreferenced (Interfaces); + pragma Unreferenced (Lib_Filename); + pragma Unreferenced (Lib_Dir); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Driver_Name); + pragma Unreferenced (Lib_Version); + pragma Unreferenced (Auto_Init); + + begin + null; + end Build_Dynamic_Library; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return ""; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return ""; + end Dynamic_Option; + + ----------------------------- + -- Get_Target_Suffix -- + ----------------------------- + + function Get_Target_Suffix return String is + Target_Name : constant String := Sdefault.Target_Name.all; + Index : Positive := Target_Name'First; + + begin + while Index < Target_Name'Last + and then Target_Name (Index + 1) /= '-' + loop + Index := Index + 1; + end loop; + + if Target_Name (Target_Name'First .. Index) = "m68k" then + return "68k"; + elsif Target_Name (Target_Name'First .. Index) = "mips" then + return "mips"; + elsif Target_Name (Target_Name'First .. Index) = "powerpc" then + return "ppc"; + elsif Target_Name (Target_Name'First .. Index) = "sparc" then + return "sparc"; + elsif Target_Name (Target_Name'First .. Index) = "sparc64" then + return "sparc64"; + elsif Target_Name (Target_Name'First .. Index) = "xscale" then + return "arm"; + elsif Target_Name (Target_Name'First .. Index) = "i586" then + return "pentium"; + else + return ""; + end if; + end Get_Target_Suffix; + + -------------------------------------- + -- Library_Major_Minor_Id_Supported -- + -------------------------------------- + + function Library_Major_Minor_Id_Supported return Boolean is + begin + return False; + end Library_Major_Minor_Id_Supported; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return ""; + end PIC_Option; + + ----------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported -- + ----------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported return Boolean is + begin + return False; + end Standalone_Library_Auto_Init_Is_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Static_Only; + end Support_For_Libraries; + +begin + Archive_Builder_Ptr := Archive_Builder'Access; + Archive_Indexer_Ptr := Archive_Indexer'Access; + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + DLL_Ext_Ptr := DLL_Ext'Access; + Dynamic_Option_Ptr := Dynamic_Option'Access; + PIC_Option_Ptr := PIC_Option'Access; + Library_Major_Minor_Id_Supported_Ptr := + Library_Major_Minor_Id_Supported'Access; + Standalone_Library_Auto_Init_Is_Supported_Ptr := + Standalone_Library_Auto_Init_Is_Supported'Access; + Support_For_Libraries_Ptr := Support_For_Libraries'Access; +end MLib.Tgt.Specific; diff --git a/gcc/ada/mlib-tgt-specific-xi.adb b/gcc/ada/mlib-tgt-specific-xi.adb new file mode 100644 index 000000000..10c57b474 --- /dev/null +++ b/gcc/ada/mlib-tgt-specific-xi.adb @@ -0,0 +1,219 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T. S P E C I F I C -- +-- (Bare Board Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the bare board version of the body + +with Sdefault; +with Types; use Types; + +package body MLib.Tgt.Specific is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Get_Target_Prefix return String; + -- Returns the required prefix for some utilities + -- (such as ar and ranlib) that depend on the real target. + + -- Non default subprograms + + function Archive_Builder return String; + + function Archive_Indexer return String; + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + function DLL_Ext return String; + + function Dynamic_Option return String; + + function Library_Major_Minor_Id_Supported return Boolean; + + function PIC_Option return String; + + function Standalone_Library_Auto_Init_Is_Supported return Boolean; + + function Support_For_Libraries return Library_Support; + + --------------------- + -- Archive_Builder -- + --------------------- + + function Archive_Builder return String is + begin + return Get_Target_Prefix & "ar"; + end Archive_Builder; + + --------------------- + -- Archive_Indexer -- + --------------------- + + function Archive_Indexer return String is + begin + return Get_Target_Prefix & "ranlib"; + end Archive_Indexer; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Ofiles); + pragma Unreferenced (Options); + pragma Unreferenced (Interfaces); + pragma Unreferenced (Lib_Filename); + pragma Unreferenced (Lib_Dir); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Driver_Name); + pragma Unreferenced (Lib_Version); + pragma Unreferenced (Auto_Init); + + begin + null; + end Build_Dynamic_Library; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return ""; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return ""; + end Dynamic_Option; + + ----------------------- + -- Get_Target_Prefix -- + ----------------------- + + function Get_Target_Prefix return String is + Target_Name : constant String_Ptr := Sdefault.Target_Name; + Index : Positive := Target_Name'First; + + begin + while Index < Target_Name'Last + and then Target_Name (Index + 1) /= '-' + loop + Index := Index + 1; + end loop; + + if Target_Name (Target_Name'First .. Index) = "avr" then + return "avr-"; + elsif Target_Name (Target_Name'First .. Index) = "erc32" then + return "erc32-elf-"; + elsif Target_Name (Target_Name'First .. Index) = "leon" then + return "leon-elf-"; + elsif Target_Name (Target_Name'First .. Index) = "powerpc" then + if Target_Name'Length >= 23 and then + Target_Name (Target_Name'First .. Target_Name'First + 22) = + "powerpc-unknown-eabispe" + then + return "powerpc-eabispe-"; + else + return "powerpc-elf-"; + end if; + else + return ""; + end if; + end Get_Target_Prefix; + + -------------------------------------- + -- Library_Major_Minor_Id_Supported -- + -------------------------------------- + + function Library_Major_Minor_Id_Supported return Boolean is + begin + return False; + end Library_Major_Minor_Id_Supported; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return ""; + end PIC_Option; + + ----------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported -- + ----------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported return Boolean is + begin + return False; + end Standalone_Library_Auto_Init_Is_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Static_Only; + end Support_For_Libraries; + +begin + Archive_Builder_Ptr := Archive_Builder'Access; + Archive_Indexer_Ptr := Archive_Indexer'Access; + Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; + DLL_Ext_Ptr := DLL_Ext'Access; + Dynamic_Option_Ptr := Dynamic_Option'Access; + Library_Major_Minor_Id_Supported_Ptr := + Library_Major_Minor_Id_Supported'Access; + PIC_Option_Ptr := PIC_Option'Access; + Standalone_Library_Auto_Init_Is_Supported_Ptr := + Standalone_Library_Auto_Init_Is_Supported'Access; + Support_For_Libraries_Ptr := Support_For_Libraries'Access; +end MLib.Tgt.Specific; diff --git a/gcc/ada/mlib-tgt-specific.adb b/gcc/ada/mlib-tgt-specific.adb new file mode 100644 index 000000000..16988b3d6 --- /dev/null +++ b/gcc/ada/mlib-tgt-specific.adb @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T . S P E C I F I C -- +-- (Default empty version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Default version + +package body MLib.Tgt.Specific is + + -- By default, libraries are not supported at all + + function Support_For_Libraries return Library_Support; + -- Function indicating if libraries are supported + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return None; + end Support_For_Libraries; + +begin + Support_For_Libraries_Ptr := Support_For_Libraries'Access; +end MLib.Tgt.Specific; diff --git a/gcc/ada/mlib-tgt-specific.ads b/gcc/ada/mlib-tgt-specific.ads new file mode 100644 index 000000000..7cc891bd7 --- /dev/null +++ b/gcc/ada/mlib-tgt-specific.ads @@ -0,0 +1,34 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T . S P E C I F I C -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 package MLib.Tgt has no interface. +-- For each platform, there is a specific body that defines the subprogram +-- that are different from the default defined in the body of MLib.Tgt, +-- and modify the corresponding access to subprogram value in the private +-- part of MLib.Tgt. + +package MLib.Tgt.Specific is + pragma Elaborate_Body; +end MLib.Tgt.Specific; diff --git a/gcc/ada/mlib-tgt-vms_common.adb b/gcc/ada/mlib-tgt-vms_common.adb new file mode 100644 index 000000000..6d79cd7e9 --- /dev/null +++ b/gcc/ada/mlib-tgt-vms_common.adb @@ -0,0 +1,155 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T . V M S _ C O M M O N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the part of MLib.Tgt.Specific common to both VMS versions + +package body MLib.Tgt.VMS_Common is + + -- Non default subprograms. See comments in mlib-tgt.ads + + function Archive_Ext return String; + + function Default_Symbol_File_Name return String; + + function DLL_Ext return String; + + function Is_Object_Ext (Ext : String) return Boolean; + + function Is_Archive_Ext (Ext : String) return Boolean; + + function Libgnat return String; + + function Object_Ext return String; + + function Library_Major_Minor_Id_Supported return Boolean; + + function PIC_Option return String; + + ----------------- + -- Archive_Ext -- + ----------------- + + function Archive_Ext return String is + begin + return "olb"; + end Archive_Ext; + + ------------------------------ + -- Default_Symbol_File_Name -- + ------------------------------ + + function Default_Symbol_File_Name return String is + begin + return "symvec.opt"; + end Default_Symbol_File_Name; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "exe"; + end DLL_Ext; + + ------------------- + -- Is_Object_Ext -- + ------------------- + + function Is_Object_Ext (Ext : String) return Boolean is + begin + return Ext = ".obj"; + end Is_Object_Ext; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".olb" or else Ext = ".exe"; + end Is_Archive_Ext; + + ------------- + -- Libgnat -- + ------------- + + function Libgnat return String is + Libgnat_A : constant String := "libgnat.a"; + Libgnat_Olb : constant String := "libgnat.olb"; + + begin + Name_Len := Libgnat_A'Length; + Name_Buffer (1 .. Name_Len) := Libgnat_A; + + if Osint.Find_File (Name_Enter, Osint.Library) /= No_File then + return Libgnat_A; + else + return Libgnat_Olb; + end if; + end Libgnat; + + -------------------------------------- + -- Library_Major_Minor_Id_Supported -- + -------------------------------------- + + function Library_Major_Minor_Id_Supported return Boolean is + begin + return False; + end Library_Major_Minor_Id_Supported; + + ---------------- + -- Object_Ext -- + ---------------- + + function Object_Ext return String is + begin + return "obj"; + end Object_Ext; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return ""; + end PIC_Option; + +-- Package initialization + +begin + Archive_Ext_Ptr := Archive_Ext'Access; + Default_Symbol_File_Name_Ptr := Default_Symbol_File_Name'Access; + DLL_Ext_Ptr := DLL_Ext'Access; + Is_Object_Ext_Ptr := Is_Object_Ext'Access; + Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; + Libgnat_Ptr := Libgnat'Access; + Object_Ext_Ptr := Object_Ext'Access; + PIC_Option_Ptr := PIC_Option'Access; + Library_Major_Minor_Id_Supported_Ptr := + Library_Major_Minor_Id_Supported'Access; + +end MLib.Tgt.VMS_Common; diff --git a/gcc/ada/mlib-tgt-vms_common.ads b/gcc/ada/mlib-tgt-vms_common.ads new file mode 100644 index 000000000..8429b7731 --- /dev/null +++ b/gcc/ada/mlib-tgt-vms_common.ads @@ -0,0 +1,30 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T . V M S _ C O M M O N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the part of MLib.Tgt.Specific common to both VMS versions + +package MLib.Tgt.VMS_Common is + pragma Elaborate_Body; +end MLib.Tgt.VMS_Common; diff --git a/gcc/ada/mlib-tgt.adb b/gcc/ada/mlib-tgt.adb new file mode 100644 index 000000000..4d8597c1f --- /dev/null +++ b/gcc/ada/mlib-tgt.adb @@ -0,0 +1,505 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with MLib.Fil; +with Prj.Com; + +with MLib.Tgt.Specific; +pragma Warnings (Off, MLib.Tgt.Specific); +-- MLib.Tgt.Specific is with'ed only for elaboration purposes + +package body MLib.Tgt is + + --------------------- + -- Archive_Builder -- + --------------------- + + function Archive_Builder return String is + begin + return Archive_Builder_Ptr.all; + end Archive_Builder; + + ----------------------------- + -- Archive_Builder_Default -- + ----------------------------- + + function Archive_Builder_Default return String is + begin + return "ar"; + end Archive_Builder_Default; + + ----------------------------- + -- Archive_Builder_Options -- + ----------------------------- + + function Archive_Builder_Options return String_List_Access is + begin + return Archive_Builder_Options_Ptr.all; + end Archive_Builder_Options; + + ------------------------------------- + -- Archive_Builder_Options_Default -- + ------------------------------------- + + function Archive_Builder_Options_Default return String_List_Access is + begin + return new String_List'(1 => new String'("cr")); + end Archive_Builder_Options_Default; + + ------------------------------------ + -- Archive_Builder_Append_Options -- + ------------------------------------ + + function Archive_Builder_Append_Options return String_List_Access is + begin + return Archive_Builder_Append_Options_Ptr.all; + end Archive_Builder_Append_Options; + + -------------------------------------------- + -- Archive_Builder_Append_Options_Default -- + -------------------------------------------- + + function Archive_Builder_Append_Options_Default return String_List_Access is + begin + return new String_List'(1 => new String'("q")); + end Archive_Builder_Append_Options_Default; + + ----------------- + -- Archive_Ext -- + ----------------- + + function Archive_Ext return String is + begin + return Archive_Ext_Ptr.all; + end Archive_Ext; + + ------------------------- + -- Archive_Ext_Default -- + ------------------------- + + function Archive_Ext_Default return String is + begin + return "a"; + end Archive_Ext_Default; + + --------------------- + -- Archive_Indexer -- + --------------------- + + function Archive_Indexer return String is + begin + return Archive_Indexer_Ptr.all; + end Archive_Indexer; + + ----------------------------- + -- Archive_Indexer_Default -- + ----------------------------- + + function Archive_Indexer_Default return String is + begin + return "ranlib"; + end Archive_Indexer_Default; + + ----------------------------- + -- Archive_Indexer_Options -- + ----------------------------- + + function Archive_Indexer_Options return String_List_Access is + begin + return Archive_Indexer_Options_Ptr.all; + end Archive_Indexer_Options; + + ------------------------------------- + -- Archive_Indexer_Options_Default -- + ------------------------------------- + + function Archive_Indexer_Options_Default return String_List_Access is + begin + return new String_List (1 .. 0); + end Archive_Indexer_Options_Default; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False) + is + begin + Build_Dynamic_Library_Ptr + (Ofiles, + Options, + Interfaces, + Lib_Filename, + Lib_Dir, + Symbol_Data, + Driver_Name, + Lib_Version, + Auto_Init); + end Build_Dynamic_Library; + + ------------------------------ + -- Default_Symbol_File_Name -- + ------------------------------ + + function Default_Symbol_File_Name return String is + begin + return Default_Symbol_File_Name_Ptr.all; + end Default_Symbol_File_Name; + + -------------------------------------- + -- Default_Symbol_File_Name_Default -- + -------------------------------------- + + function Default_Symbol_File_Name_Default return String is + begin + return ""; + end Default_Symbol_File_Name_Default; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return DLL_Ext_Ptr.all; + end DLL_Ext; + + --------------------- + -- DLL_Ext_Default -- + --------------------- + + function DLL_Ext_Default return String is + begin + return "so"; + end DLL_Ext_Default; + + ---------------- + -- DLL_Prefix -- + ---------------- + + function DLL_Prefix return String is + begin + return DLL_Prefix_Ptr.all; + end DLL_Prefix; + + ------------------------ + -- DLL_Prefix_Default -- + ------------------------ + + function DLL_Prefix_Default return String is + begin + return "lib"; + end DLL_Prefix_Default; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return Dynamic_Option_Ptr.all; + end Dynamic_Option; + + ---------------------------- + -- Dynamic_Option_Default -- + ---------------------------- + + function Dynamic_Option_Default return String is + begin + return "-shared"; + end Dynamic_Option_Default; + + ------------------- + -- Is_Object_Ext -- + ------------------- + + function Is_Object_Ext (Ext : String) return Boolean is + begin + return Is_Object_Ext_Ptr (Ext); + end Is_Object_Ext; + + --------------------------- + -- Is_Object_Ext_Default -- + --------------------------- + + function Is_Object_Ext_Default (Ext : String) return Boolean is + begin + return Ext = ".o"; + end Is_Object_Ext_Default; + + -------------- + -- Is_C_Ext -- + -------------- + + function Is_C_Ext (Ext : String) return Boolean is + begin + return Is_C_Ext_Ptr (Ext); + end Is_C_Ext; + + ---------------------- + -- Is_C_Ext_Default -- + ---------------------- + + function Is_C_Ext_Default (Ext : String) return Boolean is + begin + return Ext = ".c"; + end Is_C_Ext_Default; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Is_Archive_Ext_Ptr (Ext); + end Is_Archive_Ext; + + ---------------------------- + -- Is_Archive_Ext_Default -- + ---------------------------- + + function Is_Archive_Ext_Default (Ext : String) return Boolean is + begin + return Ext = ".a"; + end Is_Archive_Ext_Default; + + ------------- + -- Libgnat -- + ------------- + + function Libgnat return String is + begin + return Libgnat_Ptr.all; + end Libgnat; + + --------------------- + -- Libgnat_Default -- + --------------------- + + function Libgnat_Default return String is + begin + return "libgnat.a"; + end Libgnat_Default; + + ------------------------ + -- Library_Exists_For -- + ------------------------ + + function Library_Exists_For + (Project : Project_Id; + In_Tree : Project_Tree_Ref) return Boolean + is + begin + return Library_Exists_For_Ptr (Project, In_Tree); + end Library_Exists_For; + + -------------------------------- + -- Library_Exists_For_Default -- + -------------------------------- + + function Library_Exists_For_Default + (Project : Project_Id; + In_Tree : Project_Tree_Ref) return Boolean + is + pragma Unreferenced (In_Tree); + + begin + if not Project.Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " & + "for non library project"); + return False; + + else + declare + Lib_Dir : constant String := + Get_Name_String (Project.Library_Dir.Display_Name); + Lib_Name : constant String := + Get_Name_String (Project.Library_Name); + + begin + if Project.Library_Kind = Static then + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Append_To (Lib_Name, Archive_Ext)); + + else + return Is_Regular_File + (Lib_Dir & Directory_Separator & DLL_Prefix & + Fil.Append_To (Lib_Name, DLL_Ext)); + end if; + end; + end if; + end Library_Exists_For_Default; + + --------------------------- + -- Library_File_Name_For -- + --------------------------- + + function Library_File_Name_For + (Project : Project_Id; + In_Tree : Project_Tree_Ref) return File_Name_Type + is + begin + return Library_File_Name_For_Ptr (Project, In_Tree); + end Library_File_Name_For; + + ----------------------------------- + -- Library_File_Name_For_Default -- + ----------------------------------- + + function Library_File_Name_For_Default + (Project : Project_Id; + In_Tree : Project_Tree_Ref) return File_Name_Type + is + pragma Unreferenced (In_Tree); + begin + if not Project.Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & + "for non library project"); + return No_File; + + else + declare + Lib_Name : constant String := + Get_Name_String (Project.Library_Name); + + begin + if Project.Library_Kind = + Static + then + Name_Len := 3; + Name_Buffer (1 .. Name_Len) := "lib"; + Add_Str_To_Name_Buffer (Fil.Append_To (Lib_Name, Archive_Ext)); + else + Name_Len := 0; + Add_Str_To_Name_Buffer (DLL_Prefix); + Add_Str_To_Name_Buffer (Fil.Append_To (Lib_Name, DLL_Ext)); + end if; + + return Name_Find; + end; + end if; + end Library_File_Name_For_Default; + + -------------------------------------- + -- Library_Major_Minor_Id_Supported -- + -------------------------------------- + + function Library_Major_Minor_Id_Supported return Boolean is + begin + return Library_Major_Minor_Id_Supported_Ptr.all; + end Library_Major_Minor_Id_Supported; + + ---------------------------------------------- + -- Library_Major_Minor_Id_Supported_Default -- + ---------------------------------------------- + + function Library_Major_Minor_Id_Supported_Default return Boolean is + begin + return True; + end Library_Major_Minor_Id_Supported_Default; + + ---------------- + -- Object_Ext -- + ---------------- + + function Object_Ext return String is + begin + return Object_Ext_Ptr.all; + end Object_Ext; + + ------------------------ + -- Object_Ext_Default -- + ------------------------ + + function Object_Ext_Default return String is + begin + return "o"; + end Object_Ext_Default; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return PIC_Option_Ptr.all; + end PIC_Option; + + ------------------------ + -- PIC_Option_Default -- + ------------------------ + + function PIC_Option_Default return String is + begin + return "-fPIC"; + end PIC_Option_Default; + + ----------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported -- + ----------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported return Boolean is + begin + return Standalone_Library_Auto_Init_Is_Supported_Ptr.all; + end Standalone_Library_Auto_Init_Is_Supported; + + ------------------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported_Default -- + ------------------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported_Default return Boolean is + begin + return True; + end Standalone_Library_Auto_Init_Is_Supported_Default; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Support_For_Libraries_Ptr.all; + end Support_For_Libraries; + + ----------------------------------- + -- Support_For_Libraries_Default -- + ----------------------------------- + + function Support_For_Libraries_Default return Library_Support is + begin + return Full; + end Support_For_Libraries_Default; + +end MLib.Tgt; diff --git a/gcc/ada/mlib-tgt.ads b/gcc/ada/mlib-tgt.ads new file mode 100644 index 000000000..cbb15d3ac --- /dev/null +++ b/gcc/ada/mlib-tgt.ads @@ -0,0 +1,270 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T -- +-- -- +-- S p e c -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a set of target dependent routines to build static, +-- dynamic and shared libraries. There are several packages providing +-- the actual routines. This package calls them indirectly by means of +-- access-to-subprogram values. Each target-dependent package initializes +-- these values in its elaboration block. + +with Prj; use Prj; + +package MLib.Tgt is + + function Support_For_Libraries return Library_Support; + -- Indicates how building libraries by gnatmake is supported by the GNAT + -- implementation for the platform. + + function Standalone_Library_Auto_Init_Is_Supported return Boolean; + -- Indicates if when building a dynamic Standalone Library, + -- automatic initialization is supported. If it is, then it is the default, + -- unless attribute Library_Auto_Init has the value "false". + + function Archive_Builder return String; + -- Returns the name of the archive builder program, usually "ar" + + function Archive_Builder_Options return String_List_Access; + -- A list of options to invoke the Archive_Builder, usually "cr" for "ar" + + function Archive_Builder_Append_Options return String_List_Access; + -- A list of options to use with the archive builder to append object + -- files ("q", for example). + + function Archive_Indexer return String; + -- Returns the name of the program, if any, that generates an index to the + -- contents of an archive, usually "ranlib". If there is no archive indexer + -- to be used, returns an empty string. + + function Archive_Indexer_Options return String_List_Access; + -- A list of options to invoke the Archive_Indexer, usually empty + + function Dynamic_Option return String; + -- gcc option to create a dynamic library. + -- For Unix, returns "-shared", for Windows returns "-mdll". + + function Libgnat return String; + -- System dependent static GNAT library + + function Archive_Ext return String; + -- System dependent static library extension, without leading dot. + -- For Unix and Windows, return "a". + + function Object_Ext return String; + -- System dependent object extension, without leading dot. + -- On Unix, returns "o". + + function DLL_Prefix return String; + -- System dependent dynamic library prefix. + -- On Windows, returns "". On other platforms, returns "lib". + + function DLL_Ext return String; + -- System dependent dynamic library extension, without leading dot. + -- On Windows, returns "dll". On Unix, usually returns "so", but not + -- always, e.g. on HP-UX the extension for shared libraries is "sl". + + function PIC_Option return String; + -- Position independent code option + + function Is_Object_Ext (Ext : String) return Boolean; + -- Returns True iff Ext is an object file extension + + function Is_C_Ext (Ext : String) return Boolean; + -- Returns True iff Ext is a C file extension + + function Is_Archive_Ext (Ext : String) return Boolean; + -- Returns True iff Ext is an extension for a library + + function Default_Symbol_File_Name return String; + -- Returns the name of the symbol file when Library_Symbol_File is not + -- specified. Return the empty string when symbol files are not supported. + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + -- Build a dynamic/relocatable library + -- + -- Ofiles is the list of all object files in the library + -- + -- Options is a list of options to be passed to the tool + -- (gcc or other) that effectively builds the dynamic library. + -- + -- Interfaces is the list of ALI files for the interfaces of a SAL. + -- It is empty if the library is not a SAL. + -- + -- Lib_Filename is the name of the library, without any prefix or + -- extension. For example, on Unix, if Lib_Filename is "toto", the + -- name of the library file will be "libtoto.so". + -- + -- Lib_Dir is the directory path where the library will be located + -- + -- For OSes that support symbolic links, Lib_Version, if non null, + -- is the actual file name of the library. For example on Unix, if + -- Lib_Filename is "toto" and Lib_Version is "libtoto.so.2.1", + -- "libtoto.so" will be a symbolic link to "libtoto.so.2.1" which + -- will be the actual library file. + -- + -- Symbol_Data is used for some platforms, including VMS, to generate + -- the symbols to be exported by the library. + -- + -- Note: Depending on the OS, some of the parameters may not be taken into + -- account. For example, on Linux, Interfaces, Symbol_Data and Auto_Init + -- are ignored. + + function Library_Exists_For + (Project : Project_Id; + In_Tree : Project_Tree_Ref) return Boolean; + -- Return True if the library file for a library project already exists. + -- This function can only be called for library projects. + + function Library_File_Name_For + (Project : Project_Id; + In_Tree : Project_Tree_Ref) return File_Name_Type; + -- Returns the file name of the library file of a library project. + -- This function can only be called for library projects. + + function Library_Major_Minor_Id_Supported return Boolean; + -- Indicates if major and minor ids are supported for libraries. + -- If they are supported, then a Library_Version such as libtoto.so.1.2 + -- will have a major id of 1 and a minor id of 2. Then libtoto.so, + -- libtoto.so.1 and libtoto.so.1.2 will be created, all three designating + -- the same file. + +private + No_Argument_List : constant Argument_List := (1 .. 0 => null); + + -- Access to subprogram types for indirection + + type String_Function is access function return String; + type Is_Ext_Function is access function (Ext : String) return Boolean; + type String_List_Access_Function is access function + return String_List_Access; + + type Build_Dynamic_Library_Function is access procedure + (Ofiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Version : String := ""; + Auto_Init : Boolean := False); + + type Library_Exists_For_Function is access function + (Project : Project_Id; + In_Tree : Project_Tree_Ref) return Boolean; + + type Library_File_Name_For_Function is access function + (Project : Project_Id; + In_Tree : Project_Tree_Ref) return File_Name_Type; + + type Boolean_Function is access function return Boolean; + type Library_Support_Function is access function return Library_Support; + + function Archive_Builder_Default return String; + Archive_Builder_Ptr : String_Function := Archive_Builder_Default'Access; + + function Archive_Builder_Options_Default return String_List_Access; + Archive_Builder_Options_Ptr : String_List_Access_Function := + Archive_Builder_Options_Default'Access; + + function Archive_Builder_Append_Options_Default return String_List_Access; + Archive_Builder_Append_Options_Ptr : String_List_Access_Function := + Archive_Builder_Append_Options_Default'Access; + + function Archive_Ext_Default return String; + Archive_Ext_Ptr : String_Function := Archive_Ext_Default'Access; + + function Archive_Indexer_Default return String; + Archive_Indexer_Ptr : String_Function := Archive_Indexer_Default'Access; + + function Archive_Indexer_Options_Default return String_List_Access; + Archive_Indexer_Options_Ptr : String_List_Access_Function := + Archive_Indexer_Options_Default'Access; + + function Default_Symbol_File_Name_Default return String; + Default_Symbol_File_Name_Ptr : String_Function := + Default_Symbol_File_Name_Default'Access; + + Build_Dynamic_Library_Ptr : Build_Dynamic_Library_Function; + + function DLL_Ext_Default return String; + DLL_Ext_Ptr : String_Function := DLL_Ext_Default'Access; + + function DLL_Prefix_Default return String; + DLL_Prefix_Ptr : String_Function := DLL_Prefix_Default'Access; + + function Dynamic_Option_Default return String; + Dynamic_Option_Ptr : String_Function := Dynamic_Option_Default'Access; + + function Is_Object_Ext_Default (Ext : String) return Boolean; + Is_Object_Ext_Ptr : Is_Ext_Function := Is_Object_Ext_Default'Access; + + function Is_C_Ext_Default (Ext : String) return Boolean; + Is_C_Ext_Ptr : Is_Ext_Function := Is_C_Ext_Default'Access; + + function Is_Archive_Ext_Default (Ext : String) return Boolean; + Is_Archive_Ext_Ptr : Is_Ext_Function := Is_Archive_Ext_Default'Access; + + function Libgnat_Default return String; + Libgnat_Ptr : String_Function := Libgnat_Default'Access; + + function Library_Exists_For_Default + (Project : Project_Id; + In_Tree : Project_Tree_Ref) return Boolean; + Library_Exists_For_Ptr : Library_Exists_For_Function := + Library_Exists_For_Default'Access; + + function Library_File_Name_For_Default + (Project : Project_Id; + In_Tree : Project_Tree_Ref) return File_Name_Type; + Library_File_Name_For_Ptr : Library_File_Name_For_Function := + Library_File_Name_For_Default'Access; + + function Object_Ext_Default return String; + Object_Ext_Ptr : String_Function := Object_Ext_Default'Access; + + function PIC_Option_Default return String; + PIC_Option_Ptr : String_Function := PIC_Option_Default'Access; + + function Standalone_Library_Auto_Init_Is_Supported_Default return Boolean; + Standalone_Library_Auto_Init_Is_Supported_Ptr : Boolean_Function := + Standalone_Library_Auto_Init_Is_Supported_Default'Access; + + function Support_For_Libraries_Default return Library_Support; + Support_For_Libraries_Ptr : Library_Support_Function := + Support_For_Libraries_Default'Access; + + function Library_Major_Minor_Id_Supported_Default return Boolean; + Library_Major_Minor_Id_Supported_Ptr : Boolean_Function := + Library_Major_Minor_Id_Supported_Default'Access; +end MLib.Tgt; diff --git a/gcc/ada/mlib-utl.adb b/gcc/ada/mlib-utl.adb new file mode 100644 index 000000000..67e03097e --- /dev/null +++ b/gcc/ada/mlib-utl.adb @@ -0,0 +1,656 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . U T L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2010, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with MLib.Fil; use MLib.Fil; +with MLib.Tgt; use MLib.Tgt; +with Opt; +with Osint; +with Output; use Output; + +with Interfaces.C.Strings; use Interfaces.C.Strings; + +with System; + +package body MLib.Utl is + + Adalib_Path : String_Access := null; + -- Path of the GNAT adalib directory, specified in procedure + -- Specify_Adalib_Dir. Used in function Lib_Directory. + + Gcc_Name : String_Access; + -- Default value of the "gcc" executable used in procedure Gcc + + Gcc_Exec : String_Access; + -- The full path name of the "gcc" executable + + Ar_Name : String_Access; + -- The name of the archive builder for the platform, set when procedure Ar + -- is called for the first time. + + Ar_Exec : String_Access; + -- The full path name of the archive builder + + Ar_Options : String_List_Access; + -- The minimum options used when invoking the archive builder + + Ar_Append_Options : String_List_Access; + -- The options to be used when invoking the archive builder to add chunks + -- of object files, when building the archive in chunks. + + Opt_Length : Natural := 0; + -- The max number of options for the Archive_Builder + + Initial_Size : Natural := 0; + -- The minimum number of bytes for the invocation of the Archive Builder + -- (without name of the archive or object files). + + Ranlib_Name : String_Access; + -- The name of the archive indexer for the platform, if there is one + + Ranlib_Exec : String_Access := null; + -- The full path name of the archive indexer + + Ranlib_Options : String_List_Access := null; + -- The options to be used when invoking the archive indexer, if any + + -------- + -- Ar -- + -------- + + procedure Ar (Output_File : String; Objects : Argument_List) is + Full_Output_File : constant String := + Ext_To (Output_File, Archive_Ext); + + Arguments : Argument_List_Access; + Last_Arg : Natural := 0; + Success : Boolean; + Line_Length : Natural := 0; + + Maximum_Size : Integer; + pragma Import (C, Maximum_Size, "__gnat_link_max"); + -- Maximum number of bytes to put in an invocation of the + -- Archive_Builder. + + Size : Integer; + -- The number of bytes for the invocation of the archive builder + + Current_Object : Natural; + + procedure Display; + -- Display an invocation of the Archive Builder + + ------------- + -- Display -- + ------------- + + procedure Display is + begin + if not Opt.Quiet_Output then + Write_Str (Ar_Name.all); + Line_Length := Ar_Name'Length; + + for J in 1 .. Last_Arg loop + + -- Make sure the Output buffer does not overflow + + if Line_Length + 1 + Arguments (J)'Length > Buffer_Max then + Write_Eol; + Line_Length := 0; + end if; + + Write_Char (' '); + + -- Only output the first object files when not in verbose mode + + if (not Opt.Verbose_Mode) and then J = Opt_Length + 3 then + Write_Str ("..."); + exit; + end if; + + Write_Str (Arguments (J).all); + Line_Length := Line_Length + 1 + Arguments (J)'Length; + end loop; + + Write_Eol; + end if; + + end Display; + + begin + if Ar_Exec = null then + Ar_Name := Osint.Program_Name (Archive_Builder, "gnatmake"); + Ar_Exec := Locate_Exec_On_Path (Ar_Name.all); + + if Ar_Exec = null then + Free (Ar_Name); + Ar_Name := new String'(Archive_Builder); + Ar_Exec := Locate_Exec_On_Path (Ar_Name.all); + end if; + + if Ar_Exec = null then + Fail (Ar_Name.all & " not found in path"); + + elsif Opt.Verbose_Mode then + Write_Str ("found "); + Write_Line (Ar_Exec.all); + end if; + + Ar_Options := Archive_Builder_Options; + + Initial_Size := 0; + for J in Ar_Options'Range loop + Initial_Size := Initial_Size + Ar_Options (J)'Length + 1; + end loop; + + Ar_Append_Options := Archive_Builder_Append_Options; + + Opt_Length := Ar_Options'Length; + + if Ar_Append_Options /= null then + Opt_Length := Natural'Max (Ar_Append_Options'Length, Opt_Length); + + Size := 0; + for J in Ar_Append_Options'Range loop + Size := Size + Ar_Append_Options (J)'Length + 1; + end loop; + + Initial_Size := Integer'Max (Initial_Size, Size); + end if; + + -- ranlib + + Ranlib_Name := Osint.Program_Name (Archive_Indexer, "gnatmake"); + + if Ranlib_Name'Length > 0 then + Ranlib_Exec := Locate_Exec_On_Path (Ranlib_Name.all); + + if Ranlib_Exec = null then + Free (Ranlib_Name); + Ranlib_Name := new String'(Archive_Indexer); + Ranlib_Exec := Locate_Exec_On_Path (Ranlib_Name.all); + end if; + + if Ranlib_Exec /= null and then Opt.Verbose_Mode then + Write_Str ("found "); + Write_Line (Ranlib_Exec.all); + end if; + end if; + + Ranlib_Options := Archive_Indexer_Options; + end if; + + Arguments := + new String_List (1 .. 1 + Opt_Length + Objects'Length); + Arguments (1 .. Ar_Options'Length) := Ar_Options.all; -- "ar cr ..." + Arguments (Ar_Options'Length + 1) := new String'(Full_Output_File); + + Delete_File (Full_Output_File); + + Size := Initial_Size + Full_Output_File'Length + 1; + + -- Check the full size of a call of the archive builder with all the + -- object files. + + for J in Objects'Range loop + Size := Size + Objects (J)'Length + 1; + end loop; + + -- If the size is not too large or if it is not possible to build the + -- archive in chunks, build the archive in a single invocation. + + if Size <= Maximum_Size or else Ar_Append_Options = null then + Last_Arg := Ar_Options'Length + 1 + Objects'Length; + Arguments (Ar_Options'Length + 2 .. Last_Arg) := Objects; + + Display; + + Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success); + + else + -- Build the archive in several invocation, making sure to not + -- go over the maximum size for each invocation. + + Last_Arg := Ar_Options'Length + 1; + Current_Object := Objects'First; + Size := Initial_Size + Full_Output_File'Length + 1; + + -- First invocation + + while Current_Object <= Objects'Last loop + Size := Size + Objects (Current_Object)'Length + 1; + exit when Size > Maximum_Size; + Last_Arg := Last_Arg + 1; + Arguments (Last_Arg) := Objects (Current_Object); + Current_Object := Current_Object + 1; + end loop; + + Display; + + Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success); + + Arguments (1 .. Ar_Append_Options'Length) := Ar_Append_Options.all; + Arguments + (Ar_Append_Options'Length + 1) := new String'(Full_Output_File); + + -- Appending invocation(s) + + Big_Loop : while Success and then Current_Object <= Objects'Last loop + Last_Arg := Ar_Append_Options'Length + 1; + Size := Initial_Size + Full_Output_File'Length + 1; + + Inner_Loop : while Current_Object <= Objects'Last loop + Size := Size + Objects (Current_Object)'Length + 1; + exit Inner_Loop when Size > Maximum_Size; + Last_Arg := Last_Arg + 1; + Arguments (Last_Arg) := Objects (Current_Object); + Current_Object := Current_Object + 1; + end loop Inner_Loop; + + Display; + + Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success); + end loop Big_Loop; + end if; + + if not Success then + Fail (Ar_Name.all & " execution error."); + end if; + + -- If we have found ranlib, run it over the library + + if Ranlib_Exec /= null then + if not Opt.Quiet_Output then + Write_Str (Ranlib_Name.all); + Write_Char (' '); + Write_Line (Arguments (Ar_Options'Length + 1).all); + end if; + + Spawn + (Ranlib_Exec.all, + Ranlib_Options.all & (Arguments (Ar_Options'Length + 1)), + Success); + + if not Success then + Fail (Ranlib_Name.all & " execution error."); + end if; + end if; + end Ar; + + ----------------- + -- Delete_File -- + ----------------- + + procedure Delete_File (Filename : String) is + File : constant String := Filename & ASCII.NUL; + Success : Boolean; + + begin + Delete_File (File'Address, Success); + + if Opt.Verbose_Mode then + if Success then + Write_Str ("deleted "); + + else + Write_Str ("could not delete "); + end if; + + Write_Line (Filename); + end if; + end Delete_File; + + --------- + -- Gcc -- + --------- + + procedure Gcc + (Output_File : String; + Objects : Argument_List; + Options : Argument_List; + Options_2 : Argument_List; + Driver_Name : Name_Id := No_Name) + is + Link_Bytes : Integer := 0; + -- Projected number of bytes for the linker command line + + Link_Max : Integer; + pragma Import (C, Link_Max, "__gnat_link_max"); + -- Maximum number of bytes on the command line supported by the OS + -- linker. Passed this limit the response file mechanism must be used + -- if supported. + + Object_List_File_Supported : Boolean; + for Object_List_File_Supported'Size use Character'Size; + pragma Import + (C, Object_List_File_Supported, "__gnat_objlist_file_supported"); + -- Predicate indicating whether the linker has an option whereby the + -- names of object files can be passed to the linker in a file. + + Object_File_Option_Ptr : Interfaces.C.Strings.chars_ptr; + pragma Import (C, Object_File_Option_Ptr, "__gnat_object_file_option"); + -- Pointer to a string representing the linker option which specifies + -- the response file. + + Using_GNU_Linker : Boolean; + for Using_GNU_Linker'Size use Character'Size; + pragma Import (C, Using_GNU_Linker, "__gnat_using_gnu_linker"); + -- Predicate indicating whether this target uses the GNU linker. In + -- this case we must output a GNU linker compatible response file. + + Opening : aliased constant String := """"; + Closing : aliased constant String := '"' & ASCII.LF; + -- Needed to quote object paths in object list files when GNU linker + -- is used. + + Tname : String_Access; + Tname_FD : File_Descriptor := Invalid_FD; + -- Temporary file used by linker to pass list of object files on + -- certain systems with limitations on size of arguments. + + Closing_Status : Boolean; + -- For call to Close + + Arguments : + Argument_List + (1 .. 7 + Objects'Length + Options'Length + Options_2'Length); + + A : Natural := 0; + Success : Boolean; + + Out_Opt : constant String_Access := new String'("-o"); + Out_V : constant String_Access := new String'(Output_File); + Lib_Dir : constant String_Access := new String'("-L" & Lib_Directory); + Lib_Opt : constant String_Access := new String'(Dynamic_Option); + + Driver : String_Access; + + type Object_Position is (First, Second, Last); + + Position : Object_Position; + + procedure Write_RF (A : System.Address; N : Integer); + -- Write a string to the response file and check if it was successful. + -- Fail the program if it was not successful (disk full). + + -------------- + -- Write_RF -- + -------------- + + procedure Write_RF (A : System.Address; N : Integer) is + Status : Integer; + begin + Status := Write (Tname_FD, A, N); + + if Status /= N then + Fail ("cannot generate response file to link library: disk full"); + end if; + end Write_RF; + + begin + if Driver_Name = No_Name then + if Gcc_Exec = null then + if Gcc_Name = null then + Gcc_Name := Osint.Program_Name ("gcc", "gnatmake"); + end if; + + Gcc_Exec := Locate_Exec_On_Path (Gcc_Name.all); + + if Gcc_Exec = null then + Fail (Gcc_Name.all & " not found in path"); + end if; + end if; + + Driver := Gcc_Exec; + + else + Driver := Locate_Exec_On_Path (Get_Name_String (Driver_Name)); + + if Driver = null then + Fail (Get_Name_String (Driver_Name) & " not found in path"); + end if; + end if; + + Link_Bytes := 0; + + if Lib_Opt'Length /= 0 then + A := A + 1; + Arguments (A) := Lib_Opt; + Link_Bytes := Link_Bytes + Lib_Opt'Length + 1; + end if; + + A := A + 1; + Arguments (A) := Out_Opt; + Link_Bytes := Link_Bytes + Out_Opt'Length + 1; + + A := A + 1; + Arguments (A) := Out_V; + Link_Bytes := Link_Bytes + Out_V'Length + 1; + + A := A + 1; + Arguments (A) := Lib_Dir; + Link_Bytes := Link_Bytes + Lib_Dir'Length + 1; + + A := A + Options'Length; + Arguments (A - Options'Length + 1 .. A) := Options; + + for J in Options'Range loop + Link_Bytes := Link_Bytes + Options (J)'Length + 1; + end loop; + + if not Opt.Quiet_Output then + if Opt.Verbose_Mode then + Write_Str (Driver.all); + + elsif Driver_Name /= No_Name then + Write_Str (Get_Name_String (Driver_Name)); + + else + Write_Str (Gcc_Name.all); + end if; + + for J in 1 .. A loop + if Opt.Verbose_Mode or else J < 4 then + Write_Char (' '); + Write_Str (Arguments (J).all); + + else + Write_Str (" ..."); + exit; + end if; + end loop; + + -- Do not display all the object files if not in verbose mode, only + -- the first one. + + Position := First; + for J in Objects'Range loop + if Opt.Verbose_Mode or else Position = First then + Write_Char (' '); + Write_Str (Objects (J).all); + Position := Second; + + elsif Position = Second then + Write_Str (" ..."); + Position := Last; + exit; + end if; + end loop; + + for J in Options_2'Range loop + if not Opt.Verbose_Mode then + if Position = Second then + Write_Str (" ..."); + end if; + + exit; + end if; + + Write_Char (' '); + Write_Str (Options_2 (J).all); + end loop; + + Write_Eol; + end if; + + for J in Objects'Range loop + Link_Bytes := Link_Bytes + Objects (J)'Length + 1; + end loop; + + for J in Options_2'Range loop + Link_Bytes := Link_Bytes + Options_2 (J)'Length + 1; + end loop; + + if Object_List_File_Supported and then Link_Bytes > Link_Max then + -- Create a temporary file containing the object files, one object + -- file per line for maximal compatibility with linkers supporting + -- this option. + + Create_Temp_File (Tname_FD, Tname); + + -- If target is using the GNU linker we must add a special header + -- and footer in the response file. + + -- The syntax is : INPUT (object1.o object2.o ... ) + + -- Because the GNU linker does not like name with characters such + -- as '!', we must put the object paths between double quotes. + + if Using_GNU_Linker then + declare + GNU_Header : aliased constant String := "INPUT ("; + + begin + Write_RF (GNU_Header'Address, GNU_Header'Length); + end; + end if; + + for J in Objects'Range loop + -- Opening quote for GNU linker + + if Using_GNU_Linker then + Write_RF (Opening'Address, 1); + end if; + + Write_RF + (Objects (J).all'Address, Objects (J).all'Length); + + -- Closing quote for GNU linker + + if Using_GNU_Linker then + Write_RF (Closing'Address, 2); + + else + Write_RF (ASCII.LF'Address, 1); + end if; + end loop; + + -- Handle GNU linker response file footer + + if Using_GNU_Linker then + declare + GNU_Footer : aliased constant String := ")"; + + begin + Write_RF (GNU_Footer'Address, GNU_Footer'Length); + end; + end if; + + Close (Tname_FD, Closing_Status); + + if not Closing_Status then + Fail ("cannot generate response file to link library: disk full"); + end if; + + A := A + 1; + Arguments (A) := + new String'(Value (Object_File_Option_Ptr) & Tname.all); + + else + A := A + Objects'Length; + Arguments (A - Objects'Length + 1 .. A) := Objects; + end if; + + A := A + Options_2'Length; + Arguments (A - Options_2'Length + 1 .. A) := Options_2; + + Spawn (Driver.all, Arguments (1 .. A), Success); + + if Tname /= null then + Delete_File (Tname.all, Closing_Status); + + if not Closing_Status then + Write_Str ("warning: could not delete response file """); + Write_Str (Tname.all); + Write_Line (""" to link library"); + end if; + end if; + + if not Success then + if Driver_Name = No_Name then + Fail (Gcc_Name.all & " execution error"); + else + Fail (Get_Name_String (Driver_Name) & " execution error"); + end if; + end if; + end Gcc; + + ------------------- + -- Lib_Directory -- + ------------------- + + function Lib_Directory return String is + Libgnat : constant String := Tgt.Libgnat; + + begin + -- If procedure Specify_Adalib_Dir has been called, used the specified + -- value. + + if Adalib_Path /= null then + return Adalib_Path.all; + end if; + + Name_Len := Libgnat'Length; + Name_Buffer (1 .. Name_Len) := Libgnat; + Get_Name_String (Osint.Find_File (Name_Enter, Osint.Library)); + + -- Remove libgnat.a + + return Name_Buffer (1 .. Name_Len - Libgnat'Length); + end Lib_Directory; + + ------------------------ + -- Specify_Adalib_Dir -- + ------------------------ + + procedure Specify_Adalib_Dir (Path : String) is + begin + if Path'Length = 0 then + Adalib_Path := null; + else + Adalib_Path := new String'(Path); + end if; + end Specify_Adalib_Dir; + +end MLib.Utl; diff --git a/gcc/ada/mlib-utl.ads b/gcc/ada/mlib-utl.ads new file mode 100644 index 000000000..f91eebf7f --- /dev/null +++ b/gcc/ada/mlib-utl.ads @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . U T L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an easy way of calling various tools such as gcc, +-- ar, etc... + +package MLib.Utl is + + procedure Delete_File (Filename : String); + -- Delete the file Filename and output the name of the deleted file in + -- verbose mode. + + procedure Gcc + (Output_File : String; + Objects : Argument_List; + Options : Argument_List; + Options_2 : Argument_List; + Driver_Name : Name_Id := No_Name); + -- Driver_Name indicates the "driver" to invoke; by default, the "driver" + -- is gcc. This procedure invokes the driver to create a shared library. + -- Options are passed to gcc before the objects, Options_2 after. + -- Output_File is the name of the library file to create. Objects are the + -- names of the object files to put in the library. + + procedure Ar + (Output_File : String; + Objects : Argument_List); + -- Run ar to move all the binaries inside the archive. If ranlib is on + -- the path, run it also. Output_File is the path name of the archive to + -- create. Objects is the list of the path names of the object files to be + -- put in the archive. This procedure currently assumes that it is always + -- called in the context of gnatmake. If other executables start using this + -- procedure, an additional parameter would need to be added, and calls to + -- Osint.Program_Name updated accordingly in the body. + + function Lib_Directory return String; + -- Return the directory containing libgnat + + procedure Specify_Adalib_Dir (Path : String); + -- Specify the path of the GNAT adalib directory, to be returned by + -- function Lib_Directory without looking for it. This is used only in + -- gprlib, because we cannot rely on the search in Lib_Directory, as the + -- GNAT version may be different for gprbuild/gprlib and the compiler. + +end MLib.Utl; diff --git a/gcc/ada/mlib.adb b/gcc/ada/mlib.adb new file mode 100644 index 000000000..4c4d375f3 --- /dev/null +++ b/gcc/ada/mlib.adb @@ -0,0 +1,470 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Interfaces.C.Strings; +with System; + +with Hostparm; +with Opt; +with Output; use Output; + +with MLib.Utl; use MLib.Utl; + +with Prj.Com; + +with GNAT.Directory_Operations; use GNAT.Directory_Operations; + +package body MLib is + + ------------------- + -- Build_Library -- + ------------------- + + procedure Build_Library + (Ofiles : Argument_List; + Output_File : String; + Output_Dir : String) + is + begin + if Opt.Verbose_Mode and not Opt.Quiet_Output then + Write_Line ("building a library..."); + Write_Str (" make "); + Write_Line (Output_File); + end if; + + Ar (Output_Dir & + "lib" & Output_File & ".a", Objects => Ofiles); + end Build_Library; + + ------------------------ + -- Check_Library_Name -- + ------------------------ + + procedure Check_Library_Name (Name : String) is + begin + if Name'Length = 0 then + Prj.Com.Fail ("library name cannot be empty"); + end if; + + if Name'Length > Max_Characters_In_Library_Name then + Prj.Com.Fail ("illegal library name """ + & Name + & """: too long"); + end if; + + if not Is_Letter (Name (Name'First)) then + Prj.Com.Fail ("illegal library name """ + & Name + & """: should start with a letter"); + end if; + + for Index in Name'Range loop + if not Is_Alphanumeric (Name (Index)) then + Prj.Com.Fail ("illegal library name """ + & Name + & """: should include only letters and digits"); + end if; + end loop; + end Check_Library_Name; + + -------------------- + -- Copy_ALI_Files -- + -------------------- + + procedure Copy_ALI_Files + (Files : Argument_List; + To : Path_Name_Type; + Interfaces : String_List) + is + Success : Boolean := False; + To_Dir : constant String := Get_Name_String (To); + Is_Interface : Boolean := False; + + procedure Verbose_Copy (Index : Positive); + -- In verbose mode, output a message that the indexed file is copied + -- to the destination directory. + + ------------------ + -- Verbose_Copy -- + ------------------ + + procedure Verbose_Copy (Index : Positive) is + begin + if Opt.Verbose_Mode then + Write_Str ("Copying """); + Write_Str (Files (Index).all); + Write_Str (""" to """); + Write_Str (To_Dir); + Write_Line (""""); + end if; + end Verbose_Copy; + + -- Start of processing for Copy_ALI_Files + + begin + if Interfaces'Length = 0 then + + -- If there are no Interfaces, copy all the ALI files as is + + for Index in Files'Range loop + Verbose_Copy (Index); + Set_Writable + (To_Dir & + Directory_Separator & + Base_Name (Files (Index).all)); + Copy_File + (Files (Index).all, + To_Dir, + Success, + Mode => Overwrite, + Preserve => Preserve); + + exit when not Success; + end loop; + + else + -- Copy only the interface ALI file, and put the special indicator + -- "SL" on the P line. + + for Index in Files'Range loop + + declare + File_Name : String := Base_Name (Files (Index).all); + + begin + Canonical_Case_File_Name (File_Name); + + -- Check if this is one of the interface ALIs + + Is_Interface := False; + + for Index in Interfaces'Range loop + if File_Name = Interfaces (Index).all then + Is_Interface := True; + exit; + end if; + end loop; + + -- If it is an interface ALI, copy line by line. Insert + -- the interface indication at the end of the P line. + -- Do not copy ALI files that are not Interfaces. + + if Is_Interface then + Success := False; + Verbose_Copy (Index); + Set_Writable + (To_Dir & + Directory_Separator & + Base_Name (Files (Index).all)); + + declare + FD : File_Descriptor; + Len : Integer; + Actual_Len : Integer; + S : String_Access; + Curr : Natural; + P_Line_Found : Boolean; + Status : Boolean; + + begin + -- Open the file + + Name_Len := Files (Index)'Length; + Name_Buffer (1 .. Name_Len) := Files (Index).all; + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ASCII.NUL; + + FD := Open_Read (Name_Buffer'Address, Binary); + + if FD /= Invalid_FD then + Len := Integer (File_Length (FD)); + + -- ??? Why "+3" here + + S := new String (1 .. Len + 3); + + -- Read the file. Note that the loop is not necessary + -- since the whole file is read at once except on VMS. + + Curr := S'First; + while Curr <= Len loop + Actual_Len := Read (FD, S (Curr)'Address, Len); + + -- Exit if we could not read for some reason + + exit when Actual_Len = 0; + + Curr := Curr + Actual_Len; + end loop; + + -- We are done with the input file, so we close it + -- ignoring any bad status. + + Close (FD, Status); + + P_Line_Found := False; + + -- Look for the P line. When found, add marker SL + -- at the beginning of the P line. + + for Index in 1 .. Len - 3 loop + if (S (Index) = ASCII.LF + or else + S (Index) = ASCII.CR) + and then S (Index + 1) = 'P' + then + S (Index + 5 .. Len + 3) := S (Index + 2 .. Len); + S (Index + 2 .. Index + 4) := " SL"; + P_Line_Found := True; + exit; + end if; + end loop; + + if P_Line_Found then + + -- Create new modified ALI file + + Name_Len := To_Dir'Length; + Name_Buffer (1 .. Name_Len) := To_Dir; + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Directory_Separator; + Name_Buffer + (Name_Len + 1 .. Name_Len + File_Name'Length) := + File_Name; + Name_Len := Name_Len + File_Name'Length + 1; + Name_Buffer (Name_Len) := ASCII.NUL; + + FD := Create_File (Name_Buffer'Address, Binary); + + -- Write the modified text and close the newly + -- created file. + + if FD /= Invalid_FD then + Actual_Len := Write (FD, S (1)'Address, Len + 3); + + Close (FD, Status); + + -- Set Success to True only if the newly + -- created file has been correctly written. + + Success := Status and then Actual_Len = Len + 3; + + if Success then + + -- Set_Read_Only is used here, rather than + -- Set_Non_Writable, so that gprbuild can + -- he compiled with older compilers. + + Set_Read_Only + (Name_Buffer (1 .. Name_Len - 1)); + end if; + end if; + end if; + end if; + end; + + -- This is not an interface ALI + + else + Success := True; + end if; + end; + + if not Success then + Prj.Com.Fail ("could not copy ALI files to library dir"); + end if; + end loop; + end if; + end Copy_ALI_Files; + + ---------------------- + -- Create_Sym_Links -- + ---------------------- + + procedure Create_Sym_Links + (Lib_Path : String; + Lib_Version : String; + Lib_Dir : String; + Maj_Version : String) + is + function Symlink + (Oldpath : System.Address; + Newpath : System.Address) return Integer; + pragma Import (C, Symlink, "__gnat_symlink"); + + Version_Path : String_Access; + + Success : Boolean; + Result : Integer; + pragma Unreferenced (Success, Result); + + begin + Version_Path := new String (1 .. Lib_Version'Length + 1); + Version_Path (1 .. Lib_Version'Length) := Lib_Version; + Version_Path (Version_Path'Last) := ASCII.NUL; + + if Maj_Version'Length = 0 then + declare + Newpath : String (1 .. Lib_Path'Length + 1); + begin + Newpath (1 .. Lib_Path'Length) := Lib_Path; + Newpath (Newpath'Last) := ASCII.NUL; + Delete_File (Lib_Path, Success); + Result := Symlink (Version_Path (1)'Address, Newpath'Address); + end; + + else + declare + Newpath1 : String (1 .. Lib_Path'Length + 1); + Maj_Path : constant String := + Lib_Dir & Directory_Separator & Maj_Version; + Newpath2 : String (1 .. Maj_Path'Length + 1); + Maj_Ver : String (1 .. Maj_Version'Length + 1); + + begin + Newpath1 (1 .. Lib_Path'Length) := Lib_Path; + Newpath1 (Newpath1'Last) := ASCII.NUL; + + Newpath2 (1 .. Maj_Path'Length) := Maj_Path; + Newpath2 (Newpath2'Last) := ASCII.NUL; + + Maj_Ver (1 .. Maj_Version'Length) := Maj_Version; + Maj_Ver (Maj_Ver'Last) := ASCII.NUL; + + Delete_File (Maj_Path, Success); + + Result := Symlink (Version_Path (1)'Address, Newpath2'Address); + + Delete_File (Lib_Path, Success); + + Result := Symlink (Maj_Ver'Address, Newpath1'Address); + end; + end if; + end Create_Sym_Links; + + -------------------------------- + -- Linker_Library_Path_Option -- + -------------------------------- + + function Linker_Library_Path_Option return String_Access is + + Run_Path_Option_Ptr : Interfaces.C.Strings.chars_ptr; + pragma Import (C, Run_Path_Option_Ptr, "__gnat_run_path_option"); + -- Pointer to string representing the native linker option which + -- specifies the path where the dynamic loader should find shared + -- libraries. Equal to null string if this system doesn't support it. + + S : constant String := Interfaces.C.Strings.Value (Run_Path_Option_Ptr); + + begin + if S'Length = 0 then + return null; + else + return new String'(S); + end if; + end Linker_Library_Path_Option; + + ------------------- + -- Major_Id_Name -- + ------------------- + + function Major_Id_Name + (Lib_Filename : String; + Lib_Version : String) + return String + is + Maj_Version : constant String := Lib_Version; + Last_Maj : Positive; + Last : Positive; + Ok_Maj : Boolean := False; + + begin + Last_Maj := Maj_Version'Last; + while Last_Maj > Maj_Version'First loop + if Maj_Version (Last_Maj) in '0' .. '9' then + Last_Maj := Last_Maj - 1; + + else + Ok_Maj := Last_Maj /= Maj_Version'Last and then + Maj_Version (Last_Maj) = '.'; + + if Ok_Maj then + Last_Maj := Last_Maj - 1; + end if; + + exit; + end if; + end loop; + + if Ok_Maj then + Last := Last_Maj; + while Last > Maj_Version'First loop + if Maj_Version (Last) in '0' .. '9' then + Last := Last - 1; + + else + Ok_Maj := Last /= Last_Maj and then + Maj_Version (Last) = '.'; + + if Ok_Maj then + Last := Last - 1; + Ok_Maj := + Maj_Version (Maj_Version'First .. Last) = Lib_Filename; + end if; + + exit; + end if; + end loop; + end if; + + if Ok_Maj then + return Maj_Version (Maj_Version'First .. Last_Maj); + else + return ""; + end if; + end Major_Id_Name; + + ------------------------------- + -- Separate_Run_Path_Options -- + ------------------------------- + + function Separate_Run_Path_Options return Boolean is + Separate_Paths : Boolean; + for Separate_Paths'Size use Character'Size; + pragma Import (C, Separate_Paths, "__gnat_separate_run_path_options"); + begin + return Separate_Paths; + end Separate_Run_Path_Options; + +-- Package elaboration + +begin + -- Copy_Attributes always fails on VMS + + if Hostparm.OpenVMS then + Preserve := None; + end if; +end MLib; diff --git a/gcc/ada/mlib.ads b/gcc/ada/mlib.ads new file mode 100644 index 000000000..0aa62d215 --- /dev/null +++ b/gcc/ada/mlib.ads @@ -0,0 +1,97 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1999-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides the core high level routines used by GNATMLIB +-- and GNATMAKE to build libraries + +with Namet; use Namet; +with Osint; use Osint; + +with GNAT.OS_Lib; use GNAT.OS_Lib; + +package MLib is + + No_Argument_List : aliased String_List := (1 .. 0 => null); + No_Argument : constant String_List_Access := No_Argument_List'Access; + + Max_Characters_In_Library_Name : constant := 20; + -- Maximum number of characters in a library name. + -- Used by Check_Library_Name below. + + type Fail_Proc is access procedure (S1 : String); + + Fail : Fail_Proc := Osint.Fail'Access; + -- This procedure is used in the MLib hierarchy, instead of + -- directly calling Osint.Fail. + -- It is redirected to Make.Make_Failed by gnatmake. + + procedure Check_Library_Name (Name : String); + -- Verify that the name of a library has the following characteristics + -- - starts with a letter + -- - includes only letters and digits + -- - contains not more than Max_Characters_In_Library_Name characters + + procedure Build_Library + (Ofiles : Argument_List; + Output_File : String; + Output_Dir : String); + -- Build a static library from a set of object files + + procedure Copy_ALI_Files + (Files : Argument_List; + To : Path_Name_Type; + Interfaces : String_List); + -- Copy all ALI files Files to directory To. + -- Mark Interfaces ALI files as interfaces, if any. + + procedure Create_Sym_Links + (Lib_Path : String; + Lib_Version : String; + Lib_Dir : String; + Maj_Version : String); + + function Linker_Library_Path_Option return String_Access; + -- Linker option to specify to the linker the library directory path. + -- If non null, the library directory path is to be appended. + -- Should be deallocated by the caller, when no longer needed. + + function Major_Id_Name + (Lib_Filename : String; + Lib_Version : String) return String; + -- Returns the major id library file name, if it exists. + -- For example, if Lib_Filename is "libtoto.so" and Lib_Version is + -- "libtoto.so.1.2", then "libtoto.so.1" is returned. + + function Separate_Run_Path_Options return Boolean; + -- Return True if separate rpath arguments must be passed to the linker + -- for each directory in the rpath. + +private + + Preserve : Attribute := Time_Stamps; + -- Used by Copy_ALI_Files. Changed to None for OpenVMS, because + -- Copy_Attributes always fails on VMS. + +end MLib; diff --git a/gcc/ada/namet-sp.adb b/gcc/ada/namet-sp.adb new file mode 100755 index 000000000..30f85f52c --- /dev/null +++ b/gcc/ada/namet-sp.adb @@ -0,0 +1,203 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- N A M E T . S P -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2008-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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_Cnv; use System.WCh_Cnv; + +with GNAT.UTF_32_Spelling_Checker; + +package body Namet.Sp is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Get_Name_String_UTF_32 + (Id : Name_Id; + Result : out UTF_32_String; + Length : out Natural); + -- This procedure is similar to Get_Decoded_Name except that the output + -- is stored in the given Result array as single codes, so in particular + -- any Uhh, Whhhh, or WWhhhhhhhh sequences are decoded to appear as a + -- single value in the output. This call does not affect the contents of + -- either Name_Buffer or Name_Len. The result is in Result (1 .. Length). + -- The caller must ensure that the result buffer is long enough. + + ---------------------------- + -- Get_Name_String_UTF_32 -- + ---------------------------- + + procedure Get_Name_String_UTF_32 + (Id : Name_Id; + Result : out UTF_32_String; + Length : out Natural) + is + pragma Assert (Result'First = 1); + + SPtr : Int := Name_Entries.Table (Id).Name_Chars_Index + 1; + -- Index through characters of name in Name_Chars table. Initial value + -- points to first character of the name. + + SLen : constant Nat := Nat (Name_Entries.Table (Id).Name_Len); + -- Length of the name + + SLast : constant Int := SPtr + SLen - 1; + -- Last index in Name_Chars table for name + + C : Character; + -- Current character from Name_Chars table + + procedure Store_Hex (N : Natural); + -- Read and store next N characters starting at SPtr and store result + -- in next character of Result. Update SPtr past characters read. + + --------------- + -- Store_Hex -- + --------------- + + procedure Store_Hex (N : Natural) is + T : UTF_32_Code; + C : Character; + + begin + T := 0; + for J in 1 .. N loop + C := Name_Chars.Table (SPtr); + SPtr := SPtr + 1; + + if C in '0' .. '9' then + T := 16 * T + Character'Pos (C) - Character'Pos ('0'); + else + pragma Assert (C in 'a' .. 'f'); + + T := 16 * T + Character'Pos (C) - (Character'Pos ('a') - 10); + end if; + end loop; + + Length := Length + 1; + pragma Assert (Length <= Result'Length); + Result (Length) := T; + end Store_Hex; + + -- Start of processing for Get_Name_String_UTF_32 + + begin + Length := 0; + while SPtr <= SLast loop + C := Name_Chars.Table (SPtr); + + -- Uhh encoding + + if C = 'U' + and then SPtr <= SLast - 2 + and then Name_Chars.Table (SPtr + 1) not in 'A' .. 'Z' + then + SPtr := SPtr + 1; + Store_Hex (2); + + -- Whhhh encoding + + elsif C = 'W' + and then SPtr <= SLast - 4 + and then Name_Chars.Table (SPtr + 1) not in 'A' .. 'Z' + then + SPtr := SPtr + 1; + Store_Hex (4); + + -- WWhhhhhhhh encoding + + elsif C = 'W' + and then SPtr <= SLast - 8 + and then Name_Chars.Table (SPtr + 1) = 'W' + then + SPtr := SPtr + 2; + Store_Hex (8); + + -- Q encoding (character literal) + + elsif C = 'Q' and then SPtr < SLast then + + -- Put apostrophes around character + + pragma Assert (Length <= Result'Last - 3); + Result (Length + 1) := UTF_32_Code'Val (Character'Pos (''')); + Result (Length + 2) := + UTF_32_Code (Get_Char_Code (Name_Chars.Table (SPtr + 1))); + Result (Length + 3) := UTF_32_Code'Val (Character'Pos (''')); + SPtr := SPtr + 2; + Length := Length + 3; + + -- Unencoded case + + else + SPtr := SPtr + 1; + Length := Length + 1; + pragma Assert (Length <= Result'Last); + Result (Length) := UTF_32_Code (Get_Char_Code (C)); + end if; + end loop; + end Get_Name_String_UTF_32; + + ------------------------ + -- Is_Bad_Spelling_Of -- + ------------------------ + + function Is_Bad_Spelling_Of (Found, Expect : Name_Id) return Boolean is + FL : constant Natural := Natural (Length_Of_Name (Found)); + EL : constant Natural := Natural (Length_Of_Name (Expect)); + -- Length of input names + + FB : UTF_32_String (1 .. 2 * FL); + EB : UTF_32_String (1 .. 2 * EL); + -- Buffers for results, a factor of 2 is more than enough, the only + -- sequence which expands is Q (character literal) by 1.5 times. + + FBL : Natural; + EBL : Natural; + -- Length of decoded names + + begin + Get_Name_String_UTF_32 (Found, FB, FBL); + Get_Name_String_UTF_32 (Expect, EB, EBL); + + -- For an exact match, return False, otherwise check bad spelling. We + -- need this special test because the library routine returns True for + -- an exact match. + + if FB (1 .. FBL) = EB (1 .. EBL) then + return False; + else + return + GNAT.UTF_32_Spelling_Checker.Is_Bad_Spelling_Of + (FB (1 .. FBL), EB (1 .. EBL)); + end if; + end Is_Bad_Spelling_Of; + +end Namet.Sp; diff --git a/gcc/ada/namet-sp.ads b/gcc/ada/namet-sp.ads new file mode 100755 index 000000000..15d41a07b --- /dev/null +++ b/gcc/ada/namet-sp.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- N A M E T - S P -- +-- -- +-- 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 contains a spell checker for Name_Id values. It is +-- separated off as a child package, because of the extra dependencies, +-- in particular on GNAT.UTF_32_ Spelling_Checker. There are a number of +-- packages that use Namet that do not need the spell checking feature, +-- and this separation helps in dealing with older versions of GNAT. + +package Namet.Sp is + + function Is_Bad_Spelling_Of (Found, Expect : Name_Id) return Boolean; + -- Compares two identifier names from the names table, and returns True if + -- Found is a plausible misspelling of Expect. This function properly deals + -- with wide and wide wide character encodings in the input names. Note + -- that an exact match in the names results in False being returned. + +end Namet.Sp; diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb new file mode 100644 index 000000000..2842dfd4e --- /dev/null +++ b/gcc/ada/namet.adb @@ -0,0 +1,1343 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- N A M E T -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- WARNING: There is a C version of this package. Any changes to this +-- source file must be properly reflected in the C header file namet.h +-- which is created manually from namet.ads and namet.adb. + +with Debug; use Debug; +with Opt; use Opt; +with Output; use Output; +with Tree_IO; use Tree_IO; +with Widechar; use Widechar; + +with Interfaces; use Interfaces; + +package body Namet is + + Name_Chars_Reserve : constant := 5000; + Name_Entries_Reserve : constant := 100; + -- The names table is locked during gigi processing, since gigi assumes + -- that the table does not move. After returning from gigi, the names + -- table is unlocked again, since writing library file information needs + -- to generate some extra names. To avoid the inefficiency of always + -- reallocating during this second unlocked phase, we reserve a bit of + -- extra space before doing the release call. + + Hash_Num : constant Int := 2**16; + -- Number of headers in the hash table. Current hash algorithm is closely + -- tailored to this choice, so it can only be changed if a corresponding + -- change is made to the hash algorithm. + + Hash_Max : constant Int := Hash_Num - 1; + -- Indexes in the hash header table run from 0 to Hash_Num - 1 + + subtype Hash_Index_Type is Int range 0 .. Hash_Max; + -- Range of hash index values + + Hash_Table : array (Hash_Index_Type) of Name_Id; + -- The hash table is used to locate existing entries in the names table. + -- The entries point to the first names table entry whose hash value + -- matches the hash code. Then subsequent names table entries with the + -- same hash code value are linked through the Hash_Link fields. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Hash return Hash_Index_Type; + pragma Inline (Hash); + -- Compute hash code for name stored in Name_Buffer (length in Name_Len) + + procedure Strip_Qualification_And_Suffixes; + -- Given an encoded entity name in Name_Buffer, remove package body + -- suffix as described for Strip_Package_Body_Suffix, and also remove + -- all qualification, i.e. names followed by two underscores. The + -- contents of Name_Buffer is modified by this call, and on return + -- Name_Buffer and Name_Len reflect the stripped name. + + ----------------------------- + -- Add_Char_To_Name_Buffer -- + ----------------------------- + + procedure Add_Char_To_Name_Buffer (C : Character) is + begin + if Name_Len < Name_Buffer'Last then + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := C; + end if; + end Add_Char_To_Name_Buffer; + + ---------------------------- + -- Add_Nat_To_Name_Buffer -- + ---------------------------- + + procedure Add_Nat_To_Name_Buffer (V : Nat) is + begin + if V >= 10 then + Add_Nat_To_Name_Buffer (V / 10); + end if; + + Add_Char_To_Name_Buffer (Character'Val (Character'Pos ('0') + V rem 10)); + end Add_Nat_To_Name_Buffer; + + ---------------------------- + -- Add_Str_To_Name_Buffer -- + ---------------------------- + + procedure Add_Str_To_Name_Buffer (S : String) is + begin + for J in S'Range loop + Add_Char_To_Name_Buffer (S (J)); + end loop; + end Add_Str_To_Name_Buffer; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + F : array (Int range 0 .. 50) of Int; + -- N'th entry is the number of chains of length N, except last entry, + -- which is the number of chains of length F'Last or more. + + Max_Chain_Length : Int := 0; + -- Maximum length of all chains + + Probes : Int := 0; + -- Used to compute average number of probes + + Nsyms : Int := 0; + -- Number of symbols in table + + Verbosity : constant Int range 1 .. 3 := 1; + pragma Warnings (Off, Verbosity); + -- This constant indicates the level of verbosity in the output from + -- this procedure. Currently this can only be changed by editing the + -- declaration above and recompiling. That's good enough in practice, + -- since we very rarely need to use this debug option. Settings are: + -- + -- 1 => print basic summary information + -- 2 => in addition print number of entries per hash chain + -- 3 => in addition print content of entries + + Zero : constant Int := Character'Pos ('0'); + + begin + if not Debug_Flag_H then + return; + end if; + + for J in F'Range loop + F (J) := 0; + end loop; + + for J in Hash_Index_Type loop + if Hash_Table (J) = No_Name then + F (0) := F (0) + 1; + + else + declare + C : Int; + N : Name_Id; + S : Int; + + begin + C := 0; + N := Hash_Table (J); + + while N /= No_Name loop + N := Name_Entries.Table (N).Hash_Link; + C := C + 1; + end loop; + + Nsyms := Nsyms + 1; + Probes := Probes + (1 + C) * 100; + + if C > Max_Chain_Length then + Max_Chain_Length := C; + end if; + + if Verbosity >= 2 then + Write_Str ("Hash_Table ("); + Write_Int (J); + Write_Str (") has "); + Write_Int (C); + Write_Str (" entries"); + Write_Eol; + end if; + + if C < F'Last then + F (C) := F (C) + 1; + else + F (F'Last) := F (F'Last) + 1; + end if; + + if Verbosity >= 3 then + N := Hash_Table (J); + while N /= No_Name loop + S := Name_Entries.Table (N).Name_Chars_Index; + + Write_Str (" "); + + for J in 1 .. Name_Entries.Table (N).Name_Len loop + Write_Char (Name_Chars.Table (S + Int (J))); + end loop; + + Write_Eol; + + N := Name_Entries.Table (N).Hash_Link; + end loop; + end if; + end; + end if; + end loop; + + Write_Eol; + + for J in F'Range loop + if F (J) /= 0 then + Write_Str ("Number of hash chains of length "); + + if J < 10 then + Write_Char (' '); + end if; + + Write_Int (J); + + if J = F'Last then + Write_Str (" or greater"); + end if; + + Write_Str (" = "); + Write_Int (F (J)); + Write_Eol; + end if; + end loop; + + -- Print out average number of probes, in the case where Name_Find is + -- called for a string that is already in the table. + + Write_Eol; + Write_Str ("Average number of probes for lookup = "); + Probes := Probes / Nsyms; + Write_Int (Probes / 200); + Write_Char ('.'); + Probes := (Probes mod 200) / 2; + Write_Char (Character'Val (Zero + Probes / 10)); + Write_Char (Character'Val (Zero + Probes mod 10)); + Write_Eol; + + Write_Str ("Max_Chain_Length = "); + Write_Int (Max_Chain_Length); + Write_Eol; + Write_Str ("Name_Chars'Length = "); + Write_Int (Name_Chars.Last - Name_Chars.First + 1); + Write_Eol; + Write_Str ("Name_Entries'Length = "); + Write_Int (Int (Name_Entries.Last - Name_Entries.First + 1)); + Write_Eol; + Write_Str ("Nsyms = "); + Write_Int (Nsyms); + Write_Eol; + end Finalize; + + ----------------------------- + -- Get_Decoded_Name_String -- + ----------------------------- + + procedure Get_Decoded_Name_String (Id : Name_Id) is + C : Character; + P : Natural; + + begin + Get_Name_String (Id); + + -- Skip scan if we already know there are no encodings + + if Name_Entries.Table (Id).Name_Has_No_Encodings then + return; + end if; + + -- Quick loop to see if there is anything special to do + + P := 1; + loop + if P = Name_Len then + Name_Entries.Table (Id).Name_Has_No_Encodings := True; + return; + + else + C := Name_Buffer (P); + + exit when + C = 'U' or else + C = 'W' or else + C = 'Q' or else + C = 'O'; + + P := P + 1; + end if; + end loop; + + -- Here we have at least some encoding that we must decode + + Decode : declare + New_Len : Natural; + Old : Positive; + New_Buf : String (1 .. Name_Buffer'Last); + + procedure Copy_One_Character; + -- Copy a character from Name_Buffer to New_Buf. Includes case + -- of copying a Uhh,Whhhh,WWhhhhhhhh sequence and decoding it. + + function Hex (N : Natural) return Word; + -- Scans past N digits using Old pointer and returns hex value + + procedure Insert_Character (C : Character); + -- Insert a new character into output decoded name + + ------------------------ + -- Copy_One_Character -- + ------------------------ + + procedure Copy_One_Character is + C : Character; + + begin + C := Name_Buffer (Old); + + -- U (upper half insertion case) + + if C = 'U' + and then Old < Name_Len + and then Name_Buffer (Old + 1) not in 'A' .. 'Z' + and then Name_Buffer (Old + 1) /= '_' + then + Old := Old + 1; + + -- If we have upper half encoding, then we have to set an + -- appropriate wide character sequence for this character. + + if Upper_Half_Encoding then + Widechar.Set_Wide (Char_Code (Hex (2)), New_Buf, New_Len); + + -- For other encoding methods, upper half characters can + -- simply use their normal representation. + + else + Insert_Character (Character'Val (Hex (2))); + end if; + + -- WW (wide wide character insertion) + + elsif C = 'W' + and then Old < Name_Len + and then Name_Buffer (Old + 1) = 'W' + then + Old := Old + 2; + Widechar.Set_Wide (Char_Code (Hex (8)), New_Buf, New_Len); + + -- W (wide character insertion) + + elsif C = 'W' + and then Old < Name_Len + and then Name_Buffer (Old + 1) not in 'A' .. 'Z' + and then Name_Buffer (Old + 1) /= '_' + then + Old := Old + 1; + Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len); + + -- Any other character is copied unchanged + + else + Insert_Character (C); + Old := Old + 1; + end if; + end Copy_One_Character; + + --------- + -- Hex -- + --------- + + function Hex (N : Natural) return Word is + T : Word := 0; + C : Character; + + begin + for J in 1 .. N loop + C := Name_Buffer (Old); + Old := Old + 1; + + pragma Assert (C in '0' .. '9' or else C in 'a' .. 'f'); + + if C <= '9' then + T := 16 * T + Character'Pos (C) - Character'Pos ('0'); + else -- C in 'a' .. 'f' + T := 16 * T + Character'Pos (C) - (Character'Pos ('a') - 10); + end if; + end loop; + + return T; + end Hex; + + ---------------------- + -- Insert_Character -- + ---------------------- + + procedure Insert_Character (C : Character) is + begin + New_Len := New_Len + 1; + New_Buf (New_Len) := C; + end Insert_Character; + + -- Start of processing for Decode + + begin + New_Len := 0; + Old := 1; + + -- Loop through characters of name + + while Old <= Name_Len loop + + -- Case of character literal, put apostrophes around character + + if Name_Buffer (Old) = 'Q' + and then Old < Name_Len + then + Old := Old + 1; + Insert_Character ('''); + Copy_One_Character; + Insert_Character ('''); + + -- Case of operator name + + elsif Name_Buffer (Old) = 'O' + and then Old < Name_Len + and then Name_Buffer (Old + 1) not in 'A' .. 'Z' + and then Name_Buffer (Old + 1) /= '_' + then + Old := Old + 1; + + declare + -- This table maps the 2nd and 3rd characters of the name + -- into the required output. Two blanks means leave the + -- name alone + + Map : constant String := + "ab " & -- Oabs => "abs" + "ad+ " & -- Oadd => "+" + "an " & -- Oand => "and" + "co& " & -- Oconcat => "&" + "di/ " & -- Odivide => "/" + "eq= " & -- Oeq => "=" + "ex**" & -- Oexpon => "**" + "gt> " & -- Ogt => ">" + "ge>=" & -- Oge => ">=" + "le<=" & -- Ole => "<=" + "lt< " & -- Olt => "<" + "mo " & -- Omod => "mod" + "mu* " & -- Omutliply => "*" + "ne/=" & -- One => "/=" + "no " & -- Onot => "not" + "or " & -- Oor => "or" + "re " & -- Orem => "rem" + "su- " & -- Osubtract => "-" + "xo "; -- Oxor => "xor" + + J : Integer; + + begin + Insert_Character ('"'); + + -- Search the map. Note that this loop must terminate, if + -- not we have some kind of internal error, and a constraint + -- error may be raised. + + J := Map'First; + loop + exit when Name_Buffer (Old) = Map (J) + and then Name_Buffer (Old + 1) = Map (J + 1); + J := J + 4; + end loop; + + -- Special operator name + + if Map (J + 2) /= ' ' then + Insert_Character (Map (J + 2)); + + if Map (J + 3) /= ' ' then + Insert_Character (Map (J + 3)); + end if; + + Insert_Character ('"'); + + -- Skip past original operator name in input + + while Old <= Name_Len + and then Name_Buffer (Old) in 'a' .. 'z' + loop + Old := Old + 1; + end loop; + + -- For other operator names, leave them in lower case, + -- surrounded by apostrophes + + else + -- Copy original operator name from input to output + + while Old <= Name_Len + and then Name_Buffer (Old) in 'a' .. 'z' + loop + Copy_One_Character; + end loop; + + Insert_Character ('"'); + end if; + end; + + -- Else copy one character and keep going + + else + Copy_One_Character; + end if; + end loop; + + -- Copy new buffer as result + + Name_Len := New_Len; + Name_Buffer (1 .. New_Len) := New_Buf (1 .. New_Len); + end Decode; + end Get_Decoded_Name_String; + + ------------------------------------------- + -- Get_Decoded_Name_String_With_Brackets -- + ------------------------------------------- + + procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id) is + P : Natural; + + begin + -- Case of operator name, normal decoding is fine + + if Name_Buffer (1) = 'O' then + Get_Decoded_Name_String (Id); + + -- For character literals, normal decoding is fine + + elsif Name_Buffer (1) = 'Q' then + Get_Decoded_Name_String (Id); + + -- Only remaining issue is U/W/WW sequences + + else + Get_Name_String (Id); + + P := 1; + while P < Name_Len loop + if Name_Buffer (P + 1) in 'A' .. 'Z' then + P := P + 1; + + -- Uhh encoding + + elsif Name_Buffer (P) = 'U' then + for J in reverse P + 3 .. P + Name_Len loop + Name_Buffer (J + 3) := Name_Buffer (J); + end loop; + + Name_Len := Name_Len + 3; + Name_Buffer (P + 3) := Name_Buffer (P + 2); + Name_Buffer (P + 2) := Name_Buffer (P + 1); + Name_Buffer (P) := '['; + Name_Buffer (P + 1) := '"'; + Name_Buffer (P + 4) := '"'; + Name_Buffer (P + 5) := ']'; + P := P + 6; + + -- WWhhhhhhhh encoding + + elsif Name_Buffer (P) = 'W' + and then P + 9 <= Name_Len + and then Name_Buffer (P + 1) = 'W' + and then Name_Buffer (P + 2) not in 'A' .. 'Z' + and then Name_Buffer (P + 2) /= '_' + then + Name_Buffer (P + 12 .. Name_Len + 2) := + Name_Buffer (P + 10 .. Name_Len); + Name_Buffer (P) := '['; + Name_Buffer (P + 1) := '"'; + Name_Buffer (P + 10) := '"'; + Name_Buffer (P + 11) := ']'; + Name_Len := Name_Len + 2; + P := P + 12; + + -- Whhhh encoding + + elsif Name_Buffer (P) = 'W' + and then P < Name_Len + and then Name_Buffer (P + 1) not in 'A' .. 'Z' + and then Name_Buffer (P + 1) /= '_' + then + Name_Buffer (P + 8 .. P + Name_Len + 3) := + Name_Buffer (P + 5 .. Name_Len); + Name_Buffer (P + 2 .. P + 5) := Name_Buffer (P + 1 .. P + 4); + Name_Buffer (P) := '['; + Name_Buffer (P + 1) := '"'; + Name_Buffer (P + 6) := '"'; + Name_Buffer (P + 7) := ']'; + Name_Len := Name_Len + 3; + P := P + 8; + + else + P := P + 1; + end if; + end loop; + end if; + end Get_Decoded_Name_String_With_Brackets; + + ------------------------ + -- Get_Last_Two_Chars -- + ------------------------ + + procedure Get_Last_Two_Chars (N : Name_Id; C1, C2 : out Character) is + NE : Name_Entry renames Name_Entries.Table (N); + NEL : constant Int := Int (NE.Name_Len); + + begin + if NEL >= 2 then + C1 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 1); + C2 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 0); + else + C1 := ASCII.NUL; + C2 := ASCII.NUL; + end if; + end Get_Last_Two_Chars; + + --------------------- + -- Get_Name_String -- + --------------------- + + -- Procedure version leaving result in Name_Buffer, length in Name_Len + + procedure Get_Name_String (Id : Name_Id) is + S : Int; + + begin + pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + + S := Name_Entries.Table (Id).Name_Chars_Index; + Name_Len := Natural (Name_Entries.Table (Id).Name_Len); + + for J in 1 .. Name_Len loop + Name_Buffer (J) := Name_Chars.Table (S + Int (J)); + end loop; + end Get_Name_String; + + --------------------- + -- Get_Name_String -- + --------------------- + + -- Function version returning a string + + function Get_Name_String (Id : Name_Id) return String is + S : Int; + + begin + pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + S := Name_Entries.Table (Id).Name_Chars_Index; + + declare + R : String (1 .. Natural (Name_Entries.Table (Id).Name_Len)); + + begin + for J in R'Range loop + R (J) := Name_Chars.Table (S + Int (J)); + end loop; + + return R; + end; + end Get_Name_String; + + -------------------------------- + -- Get_Name_String_And_Append -- + -------------------------------- + + procedure Get_Name_String_And_Append (Id : Name_Id) is + S : Int; + + begin + pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + + S := Name_Entries.Table (Id).Name_Chars_Index; + + for J in 1 .. Natural (Name_Entries.Table (Id).Name_Len) loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Name_Chars.Table (S + Int (J)); + end loop; + end Get_Name_String_And_Append; + + ------------------------- + -- Get_Name_Table_Byte -- + ------------------------- + + function Get_Name_Table_Byte (Id : Name_Id) return Byte is + begin + pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + return Name_Entries.Table (Id).Byte_Info; + end Get_Name_Table_Byte; + + ------------------------- + -- Get_Name_Table_Info -- + ------------------------- + + function Get_Name_Table_Info (Id : Name_Id) return Int is + begin + pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + return Name_Entries.Table (Id).Int_Info; + end Get_Name_Table_Info; + + ----------------------------------------- + -- Get_Unqualified_Decoded_Name_String -- + ----------------------------------------- + + procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id) is + begin + Get_Decoded_Name_String (Id); + Strip_Qualification_And_Suffixes; + end Get_Unqualified_Decoded_Name_String; + + --------------------------------- + -- Get_Unqualified_Name_String -- + --------------------------------- + + procedure Get_Unqualified_Name_String (Id : Name_Id) is + begin + Get_Name_String (Id); + Strip_Qualification_And_Suffixes; + end Get_Unqualified_Name_String; + + ---------- + -- Hash -- + ---------- + + function Hash return Hash_Index_Type is + + -- This hash function looks at every character, in order to make it + -- likely that similar strings get different hash values. The rotate by + -- 7 bits has been determined empirically to be good, and it doesn't + -- lose bits like a shift would. The final conversion can't overflow, + -- because the table is 2**16 in size. This function probably needs to + -- be changed if the hash table size is changed. + + -- Note that we could get some speed improvement by aligning the string + -- to 32 or 64 bits, and doing word-wise xor's. We could also implement + -- a growable table. It doesn't seem worth the trouble to do those + -- things, for now. + + Result : Unsigned_16 := 0; + + begin + for J in 1 .. Name_Len loop + Result := Rotate_Left (Result, 7) xor Character'Pos (Name_Buffer (J)); + end loop; + + return Hash_Index_Type (Result); + end Hash; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + null; + end Initialize; + + ------------------------------- + -- Insert_Str_In_Name_Buffer -- + ------------------------------- + + procedure Insert_Str_In_Name_Buffer (S : String; Index : Positive) is + SL : constant Natural := S'Length; + begin + Name_Buffer (Index + SL .. Name_Len + SL) := + Name_Buffer (Index .. Name_Len); + Name_Buffer (Index .. Index + SL - 1) := S; + Name_Len := Name_Len + SL; + end Insert_Str_In_Name_Buffer; + + ---------------------- + -- Is_Internal_Name -- + ---------------------- + + -- Version taking an argument + + function Is_Internal_Name (Id : Name_Id) return Boolean is + begin + Get_Name_String (Id); + return Is_Internal_Name; + end Is_Internal_Name; + + ---------------------- + -- Is_Internal_Name -- + ---------------------- + + -- Version taking its input from Name_Buffer + + function Is_Internal_Name return Boolean is + begin + if Name_Buffer (1) = '_' + or else Name_Buffer (Name_Len) = '_' + then + return True; + + else + -- Test backwards, because we only want to test the last entity + -- name if the name we have is qualified with other entities. + + for J in reverse 1 .. Name_Len loop + if Is_OK_Internal_Letter (Name_Buffer (J)) then + return True; + + -- Quit if we come to terminating double underscore (note that + -- if the current character is an underscore, we know that + -- there is a previous character present, since we already + -- filtered out the case of Name_Buffer (1) = '_' above. + + elsif Name_Buffer (J) = '_' + and then Name_Buffer (J - 1) = '_' + and then Name_Buffer (J - 2) /= '_' + then + return False; + end if; + end loop; + end if; + + return False; + end Is_Internal_Name; + + --------------------------- + -- Is_OK_Internal_Letter -- + --------------------------- + + function Is_OK_Internal_Letter (C : Character) return Boolean is + begin + return C in 'A' .. 'Z' + and then C /= 'O' + and then C /= 'Q' + and then C /= 'U' + and then C /= 'W' + and then C /= 'X'; + end Is_OK_Internal_Letter; + + ---------------------- + -- Is_Operator_Name -- + ---------------------- + + function Is_Operator_Name (Id : Name_Id) return Boolean is + S : Int; + begin + pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + S := Name_Entries.Table (Id).Name_Chars_Index; + return Name_Chars.Table (S + 1) = 'O'; + end Is_Operator_Name; + + ------------------- + -- Is_Valid_Name -- + ------------------- + + function Is_Valid_Name (Id : Name_Id) return Boolean is + begin + return Id in Name_Entries.First .. Name_Entries.Last; + end Is_Valid_Name; + + -------------------- + -- Length_Of_Name -- + -------------------- + + function Length_Of_Name (Id : Name_Id) return Nat is + begin + return Int (Name_Entries.Table (Id).Name_Len); + end Length_Of_Name; + + ---------- + -- Lock -- + ---------- + + procedure Lock is + begin + Name_Chars.Set_Last (Name_Chars.Last + Name_Chars_Reserve); + Name_Entries.Set_Last (Name_Entries.Last + Name_Entries_Reserve); + Name_Chars.Locked := True; + Name_Entries.Locked := True; + Name_Chars.Release; + Name_Entries.Release; + end Lock; + + ------------------------ + -- Name_Chars_Address -- + ------------------------ + + function Name_Chars_Address return System.Address is + begin + return Name_Chars.Table (0)'Address; + end Name_Chars_Address; + + ---------------- + -- Name_Enter -- + ---------------- + + function Name_Enter return Name_Id is + begin + Name_Entries.Append + ((Name_Chars_Index => Name_Chars.Last, + Name_Len => Short (Name_Len), + Byte_Info => 0, + Int_Info => 0, + Name_Has_No_Encodings => False, + Hash_Link => No_Name)); + + -- Set corresponding string entry in the Name_Chars table + + for J in 1 .. Name_Len loop + Name_Chars.Append (Name_Buffer (J)); + end loop; + + Name_Chars.Append (ASCII.NUL); + + return Name_Entries.Last; + end Name_Enter; + + -------------------------- + -- Name_Entries_Address -- + -------------------------- + + function Name_Entries_Address return System.Address is + begin + return Name_Entries.Table (First_Name_Id)'Address; + end Name_Entries_Address; + + ------------------------ + -- Name_Entries_Count -- + ------------------------ + + function Name_Entries_Count return Nat is + begin + return Int (Name_Entries.Last - Name_Entries.First + 1); + end Name_Entries_Count; + + --------------- + -- Name_Find -- + --------------- + + function Name_Find return Name_Id is + New_Id : Name_Id; + -- Id of entry in hash search, and value to be returned + + S : Int; + -- Pointer into string table + + Hash_Index : Hash_Index_Type; + -- Computed hash index + + begin + -- Quick handling for one character names + + if Name_Len = 1 then + return Name_Id (First_Name_Id + Character'Pos (Name_Buffer (1))); + + -- Otherwise search hash table for existing matching entry + + else + Hash_Index := Namet.Hash; + New_Id := Hash_Table (Hash_Index); + + if New_Id = No_Name then + Hash_Table (Hash_Index) := Name_Entries.Last + 1; + + else + Search : loop + if Name_Len /= + Integer (Name_Entries.Table (New_Id).Name_Len) + then + goto No_Match; + end if; + + S := Name_Entries.Table (New_Id).Name_Chars_Index; + + for J in 1 .. Name_Len loop + if Name_Chars.Table (S + Int (J)) /= Name_Buffer (J) then + goto No_Match; + end if; + end loop; + + return New_Id; + + -- Current entry in hash chain does not match + + <> + if Name_Entries.Table (New_Id).Hash_Link /= No_Name then + New_Id := Name_Entries.Table (New_Id).Hash_Link; + else + Name_Entries.Table (New_Id).Hash_Link := + Name_Entries.Last + 1; + exit Search; + end if; + end loop Search; + end if; + + -- We fall through here only if a matching entry was not found in the + -- hash table. We now create a new entry in the names table. The hash + -- link pointing to the new entry (Name_Entries.Last+1) has been set. + + Name_Entries.Append + ((Name_Chars_Index => Name_Chars.Last, + Name_Len => Short (Name_Len), + Hash_Link => No_Name, + Name_Has_No_Encodings => False, + Int_Info => 0, + Byte_Info => 0)); + + -- Set corresponding string entry in the Name_Chars table + + for J in 1 .. Name_Len loop + Name_Chars.Append (Name_Buffer (J)); + end loop; + + Name_Chars.Append (ASCII.NUL); + + return Name_Entries.Last; + end if; + end Name_Find; + + ------------------ + -- Reinitialize -- + ------------------ + + procedure Reinitialize is + begin + Name_Chars.Init; + Name_Entries.Init; + + -- Initialize entries for one character names + + for C in Character loop + Name_Entries.Append + ((Name_Chars_Index => Name_Chars.Last, + Name_Len => 1, + Byte_Info => 0, + Int_Info => 0, + Name_Has_No_Encodings => True, + Hash_Link => No_Name)); + + Name_Chars.Append (C); + Name_Chars.Append (ASCII.NUL); + end loop; + + -- Clear hash table + + for J in Hash_Index_Type loop + Hash_Table (J) := No_Name; + end loop; + end Reinitialize; + + ---------------------- + -- Reset_Name_Table -- + ---------------------- + + procedure Reset_Name_Table is + begin + for J in First_Name_Id .. Name_Entries.Last loop + Name_Entries.Table (J).Int_Info := 0; + Name_Entries.Table (J).Byte_Info := 0; + end loop; + end Reset_Name_Table; + + -------------------------------- + -- Set_Character_Literal_Name -- + -------------------------------- + + procedure Set_Character_Literal_Name (C : Char_Code) is + begin + Name_Buffer (1) := 'Q'; + Name_Len := 1; + Store_Encoded_Character (C); + end Set_Character_Literal_Name; + + ------------------------- + -- Set_Name_Table_Byte -- + ------------------------- + + procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte) is + begin + pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + Name_Entries.Table (Id).Byte_Info := Val; + end Set_Name_Table_Byte; + + ------------------------- + -- Set_Name_Table_Info -- + ------------------------- + + procedure Set_Name_Table_Info (Id : Name_Id; Val : Int) is + begin + pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + Name_Entries.Table (Id).Int_Info := Val; + end Set_Name_Table_Info; + + ----------------------------- + -- Store_Encoded_Character -- + ----------------------------- + + procedure Store_Encoded_Character (C : Char_Code) is + + procedure Set_Hex_Chars (C : Char_Code); + -- Stores given value, which is in the range 0 .. 255, as two hex + -- digits (using lower case a-f) in Name_Buffer, incrementing Name_Len. + + ------------------- + -- Set_Hex_Chars -- + ------------------- + + procedure Set_Hex_Chars (C : Char_Code) is + Hexd : constant String := "0123456789abcdef"; + N : constant Natural := Natural (C); + begin + Name_Buffer (Name_Len + 1) := Hexd (N / 16 + 1); + Name_Buffer (Name_Len + 2) := Hexd (N mod 16 + 1); + Name_Len := Name_Len + 2; + end Set_Hex_Chars; + + -- Start of processing for Store_Encoded_Character + + begin + Name_Len := Name_Len + 1; + + if In_Character_Range (C) then + declare + CC : constant Character := Get_Character (C); + begin + if CC in 'a' .. 'z' or else CC in '0' .. '9' then + Name_Buffer (Name_Len) := CC; + else + Name_Buffer (Name_Len) := 'U'; + Set_Hex_Chars (C); + end if; + end; + + elsif In_Wide_Character_Range (C) then + Name_Buffer (Name_Len) := 'W'; + Set_Hex_Chars (C / 256); + Set_Hex_Chars (C mod 256); + + else + Name_Buffer (Name_Len) := 'W'; + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := 'W'; + Set_Hex_Chars (C / 2 ** 24); + Set_Hex_Chars ((C / 2 ** 16) mod 256); + Set_Hex_Chars ((C / 256) mod 256); + Set_Hex_Chars (C mod 256); + end if; + end Store_Encoded_Character; + + -------------------------------------- + -- Strip_Qualification_And_Suffixes -- + -------------------------------------- + + procedure Strip_Qualification_And_Suffixes is + J : Integer; + + begin + -- Strip package body qualification string off end + + for J in reverse 2 .. Name_Len loop + if Name_Buffer (J) = 'X' then + Name_Len := J - 1; + exit; + end if; + + exit when Name_Buffer (J) /= 'b' + and then Name_Buffer (J) /= 'n' + and then Name_Buffer (J) /= 'p'; + end loop; + + -- Find rightmost __ or $ separator if one exists. First we position + -- to start the search. If we have a character constant, position + -- just before it, otherwise position to last character but one + + if Name_Buffer (Name_Len) = ''' then + J := Name_Len - 2; + while J > 0 and then Name_Buffer (J) /= ''' loop + J := J - 1; + end loop; + + else + J := Name_Len - 1; + end if; + + -- Loop to search for rightmost __ or $ (homonym) separator + + while J > 1 loop + + -- If $ separator, homonym separator, so strip it and keep looking + + if Name_Buffer (J) = '$' then + Name_Len := J - 1; + J := Name_Len - 1; + + -- Else check for __ found + + elsif Name_Buffer (J) = '_' and then Name_Buffer (J + 1) = '_' then + + -- Found __ so see if digit follows, and if so, this is a + -- homonym separator, so strip it and keep looking. + + if Name_Buffer (J + 2) in '0' .. '9' then + Name_Len := J - 1; + J := Name_Len - 1; + + -- If not a homonym separator, then we simply strip the + -- separator and everything that precedes it, and we are done + + else + Name_Buffer (1 .. Name_Len - J - 1) := + Name_Buffer (J + 2 .. Name_Len); + Name_Len := Name_Len - J - 1; + exit; + end if; + + else + J := J - 1; + end if; + end loop; + end Strip_Qualification_And_Suffixes; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + begin + Name_Chars.Tree_Read; + Name_Entries.Tree_Read; + + Tree_Read_Data + (Hash_Table'Address, + Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit)); + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + begin + Name_Chars.Tree_Write; + Name_Entries.Tree_Write; + + Tree_Write_Data + (Hash_Table'Address, + Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit)); + end Tree_Write; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock is + begin + Name_Chars.Set_Last (Name_Chars.Last - Name_Chars_Reserve); + Name_Entries.Set_Last (Name_Entries.Last - Name_Entries_Reserve); + Name_Chars.Locked := False; + Name_Entries.Locked := False; + Name_Chars.Release; + Name_Entries.Release; + end Unlock; + + -------- + -- wn -- + -------- + + procedure wn (Id : Name_Id) is + S : Int; + + begin + if not Id'Valid then + Write_Str (""); + + elsif Id = No_Name then + Write_Str (""); + + elsif Id = Error_Name then + Write_Str (""); + + else + S := Name_Entries.Table (Id).Name_Chars_Index; + Name_Len := Natural (Name_Entries.Table (Id).Name_Len); + + for J in 1 .. Name_Len loop + Write_Char (Name_Chars.Table (S + Int (J))); + end loop; + end if; + + Write_Eol; + end wn; + + ---------------- + -- Write_Name -- + ---------------- + + procedure Write_Name (Id : Name_Id) is + begin + if Id >= First_Name_Id then + Get_Name_String (Id); + Write_Str (Name_Buffer (1 .. Name_Len)); + end if; + end Write_Name; + + ------------------------ + -- Write_Name_Decoded -- + ------------------------ + + procedure Write_Name_Decoded (Id : Name_Id) is + begin + if Id >= First_Name_Id then + Get_Decoded_Name_String (Id); + Write_Str (Name_Buffer (1 .. Name_Len)); + end if; + end Write_Name_Decoded; + +-- Package initialization, initialize tables + +begin + Reinitialize; +end Namet; diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads new file mode 100644 index 000000000..c4155b4ba --- /dev/null +++ b/gcc/ada/namet.ads @@ -0,0 +1,544 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- N A M E T -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with Alloc; +with Table; +with Hostparm; use Hostparm; +with System; use System; +with Types; use Types; + +package Namet is + +-- WARNING: There is a C version of this package. Any changes to this +-- source file must be properly reflected in the C header file namet.h +-- which is created manually from namet.ads and namet.adb. + +-- This package contains routines for handling the names table. The table +-- is used to store character strings for identifiers and operator symbols, +-- as well as other string values such as unit names and file names. + +-- The forms of the entries are as follows: + +-- Identifiers Stored with upper case letters folded to lower case. Upper +-- half (16#80# bit set) and wide characters are stored +-- in an encoded form (Uhh for upper half char, Whhhh +-- for wide characters, WWhhhhhhhh as provided by the +-- routine Store_Encoded_Character, where hh are hex +-- digits for the character code using lower case a-f). +-- Normally the use of U or W in other internal names is +-- avoided, but these letters may be used in internal +-- names (without this special meaning), if they appear +-- as the last character of the name, or they are +-- followed by an upper case letter (other than the WW +-- sequence), or an underscore. + +-- Operator symbols Stored with an initial letter O, and the remainder +-- of the name is the lower case characters XXX where +-- the name is Name_Op_XXX, see Snames spec for a full +-- list of the operator names. Normally the use of O +-- in other internal names is avoided, but it may be +-- used in internal names (without this special meaning) +-- if it is the last character of the name, or if it is +-- followed by an upper case letter or an underscore. + +-- Character literals Character literals have names that are used only for +-- debugging and error message purposes. The form is an +-- upper case Q followed by a single lower case letter, +-- or by a Uxx/Wxxxx/WWxxxxxxx encoding as described for +-- identifiers. The Set_Character_Literal_Name procedure +-- should be used to construct these encodings. Normally +-- the use of O in other internal names is avoided, but +-- it may be used in internal names (without this special +-- meaning) if it is the last character of the name, or +-- if it is followed by an upper case letter or an +-- underscore. + +-- Unit names Stored with upper case letters folded to lower case, +-- using Uhh/Whhhh/WWhhhhhhhh encoding as described for +-- identifiers, and a %s or %b suffix for specs/bodies. +-- See package Uname for further details. + +-- File names Are stored in the form provided by Osint. Typically +-- they may include wide character escape sequences and +-- upper case characters (in non-encoded form). Casing +-- is also derived from the external environment. Note +-- that file names provided by Osint must generally be +-- consistent with the names from Fname.Get_File_Name. + +-- Other strings The names table is also used as a convenient storage +-- location for other variable length strings such as +-- error messages etc. There are no restrictions on what +-- characters may appear for such entries. + +-- Note: the encodings Uhh (upper half characters), Whhhh (wide characters), +-- WWhhhhhhhh (wide wide characters) and Qx (character literal names) are +-- described in the spec, since they are visible throughout the system (e.g. +-- in debugging output). However, no code should depend on these particular +-- encodings, so it should be possible to change the encodings by making +-- changes only to the Namet specification (to change these comments) and the +-- body (which actually implements the encodings). + +-- The names are hashed so that a given name appears only once in the table, +-- except that names entered with Name_Enter as opposed to Name_Find are +-- omitted from the hash table. + +-- The first 26 entries in the names table (with Name_Id values in the range +-- First_Name_Id .. First_Name_Id + 25) represent names which are the one +-- character lower case letters in the range a-z, and these names are created +-- and initialized by the Initialize procedure. + +-- Two values, one of type Int and one of type Byte, are stored with each +-- names table entry and subprograms are provided for setting and retrieving +-- these associated values. The usage of these values is up to the client. In +-- the compiler, the Int field is used to point to a chain of potentially +-- visible entities (see Sem.Ch8 for details), and the Byte field is used to +-- hold the Token_Type value for reserved words (see Sem for details). In the +-- binder, the Byte field is unused, and the Int field is used in various +-- ways depending on the name involved (see binder documentation). + + Name_Buffer : String (1 .. 4 * Max_Line_Length); + -- This buffer is used to set the name to be stored in the table for the + -- Name_Find call, and to retrieve the name for the Get_Name_String call. + -- The limit here is intended to be an infinite value that ensures that we + -- never overflow the buffer (names this long are too absurd to worry!) + + Name_Len : Natural; + -- Length of name stored in Name_Buffer. Used as an input parameter for + -- Name_Find, and as an output value by Get_Name_String, or Write_Name. + + ----------------------------- + -- Types for Namet Package -- + ----------------------------- + + -- Name_Id values are used to identify entries in the names table. Except + -- for the special values No_Name and Error_Name, they are subscript values + -- for the Names table defined in this package. + + -- Note that with only a few exceptions, which are clearly documented, the + -- type Name_Id should be regarded as a private type. In particular it is + -- never appropriate to perform arithmetic operations using this type. + + type Name_Id is range Names_Low_Bound .. Names_High_Bound; + for Name_Id'Size use 32; + -- Type used to identify entries in the names table + + No_Name : constant Name_Id := Names_Low_Bound; + -- The special Name_Id value No_Name is used in the parser to indicate + -- a situation where no name is present (e.g. on a loop or block). + + Error_Name : constant Name_Id := Names_Low_Bound + 1; + -- The special Name_Id value Error_Name is used in the parser to + -- indicate that some kind of error was encountered in scanning out + -- the relevant name, so it does not have a representable label. + + subtype Error_Name_Or_No_Name is Name_Id range No_Name .. Error_Name; + -- Used to test for either error name or no name + + First_Name_Id : constant Name_Id := Names_Low_Bound + 2; + -- Subscript of first entry in names table + + ----------------- + -- Subprograms -- + ----------------- + + procedure Finalize; + -- Called at the end of a use of the Namet package (before a subsequent + -- call to Initialize). Currently this routine is only used to generate + -- debugging output. + + procedure Get_Name_String (Id : Name_Id); + -- Get_Name_String is used to retrieve the string associated with an entry + -- in the names table. The resulting string is stored in Name_Buffer and + -- Name_Len is set. It is an error to call Get_Name_String with one of the + -- special name Id values (No_Name or Error_Name). + + function Get_Name_String (Id : Name_Id) return String; + -- This functional form returns the result as a string without affecting + -- the contents of either Name_Buffer or Name_Len. The lower bound is 1. + + procedure Get_Unqualified_Name_String (Id : Name_Id); + -- Similar to the above except that qualification (as defined in unit + -- Exp_Dbug) is removed (including both preceding __ delimited names, and + -- also the suffixes used to indicate package body entities and to + -- distinguish between overloaded entities). Note that names are not + -- qualified until just before the call to gigi, so this routine is only + -- needed by processing that occurs after gigi has been called. This + -- includes all ASIS processing, since ASIS works on the tree written + -- after gigi has been called. + + procedure Get_Name_String_And_Append (Id : Name_Id); + -- Like Get_Name_String but the resulting characters are appended to the + -- current contents of the entry stored in Name_Buffer, and Name_Len is + -- incremented to include the added characters. + + procedure Get_Decoded_Name_String (Id : Name_Id); + -- Same calling sequence an interface as Get_Name_String, except that the + -- result is decoded, so that upper half characters and wide characters + -- appear as originally found in the source program text, operators have + -- their source forms (special characters and enclosed in quotes), and + -- character literals appear surrounded by apostrophes. + + procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id); + -- Similar to the above except that qualification (as defined in unit + -- Exp_Dbug) is removed (including both preceding __ delimited names, and + -- also the suffix used to indicate package body entities). Note that + -- names are not qualified until just before the call to gigi, so this + -- routine is only needed by processing that occurs after gigi has been + -- called. This includes all ASIS processing, since ASIS works on the tree + -- written after gigi has been called. + + procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id); + -- This routine is similar to Decoded_Name, except that the brackets + -- notation (Uhh replaced by ["hh"], Whhhh replaced by ["hhhh"], + -- WWhhhhhhhh replaced by ["hhhhhhhh"]) is used for all non-lower half + -- characters, regardless of how Opt.Wide_Character_Encoding_Method is + -- set, and also in that characters in the range 16#80# .. 16#FF# are + -- converted to brackets notation in all cases. This routine can be used + -- when there is a requirement for a canonical representation not affected + -- by the character set options (e.g. in the binder generation of + -- symbols). + + function Get_Name_Table_Byte (Id : Name_Id) return Byte; + pragma Inline (Get_Name_Table_Byte); + -- Fetches the Byte value associated with the given name + + function Get_Name_Table_Info (Id : Name_Id) return Int; + pragma Inline (Get_Name_Table_Info); + -- Fetches the Int value associated with the given name + + function Is_Operator_Name (Id : Name_Id) return Boolean; + -- Returns True if name given is of the form of an operator (that + -- is, it starts with an upper case O). + + procedure Initialize; + -- This is a dummy procedure. It is retained for easy compatibility with + -- clients who used to call Initialize when this call was required. Now + -- initialization is performed automatically during package elaboration. + -- Note that this change fixes problems which existed prior to the change + -- of Initialize being called more than once. See also Reinitialize which + -- allows reinitialization of the tables. + + procedure Lock; + -- Lock name tables before calling back end. We reserve some extra space + -- before locking to avoid unnecessary inefficiencies when we unlock. + + procedure Reinitialize; + -- Clears the name tables and removes all existing entries from the table. + + procedure Unlock; + -- Unlocks the name table to allow use of the extra space reserved by the + -- call to Lock. See gnat1drv for details of the need for this. + + function Length_Of_Name (Id : Name_Id) return Nat; + pragma Inline (Length_Of_Name); + -- Returns length of given name in characters. This is the length of the + -- encoded name, as stored in the names table, the result is equivalent to + -- calling Get_Name_String and reading Name_Len, except that a call to + -- Length_Of_Name does not affect the contents of Name_Len and Name_Buffer. + + function Name_Chars_Address return System.Address; + -- Return starting address of name characters table (used in Back_End call + -- to Gigi). + + function Name_Find return Name_Id; + -- Name_Find is called with a string stored in Name_Buffer whose length is + -- in Name_Len (i.e. the characters of the name are in subscript positions + -- 1 to Name_Len in Name_Buffer). It searches the names table to see if + -- the string has already been stored. If so the Id of the existing entry + -- is returned. Otherwise a new entry is created with its Name_Table_Info + -- field set to zero. The contents of Name_Buffer and Name_Len are not + -- modified by this call. Note that it is permissible for Name_Len to be + -- set to zero to lookup the null name string. + + function Name_Enter return Name_Id; + -- Name_Enter has the same calling interface as Name_Find. The difference + -- is that it does not search the table for an existing match, and also + -- subsequent Name_Find calls using the same name will not locate the + -- entry created by this call. Thus multiple calls to Name_Enter with the + -- same name will create multiple entries in the name table with different + -- Name_Id values. This is useful in the case of created names, which are + -- never expected to be looked up. Note: Name_Enter should never be used + -- for one character names, since these are efficiently located without + -- hashing by Name_Find in any case. + + function Name_Entries_Address return System.Address; + -- Return starting address of Names table (used in Back_End call to Gigi) + + function Name_Entries_Count return Nat; + -- Return current number of entries in the names table + + function Is_OK_Internal_Letter (C : Character) return Boolean; + pragma Inline (Is_OK_Internal_Letter); + -- Returns true if C is a suitable character for using as a prefix or a + -- suffix of an internally generated name, i.e. it is an upper case letter + -- other than one of the ones used for encoding source names (currently + -- the set of reserved letters is O, Q, U, W) and also returns False for + -- the letter X, which is reserved for debug output (see Exp_Dbug). + + function Is_Internal_Name (Id : Name_Id) return Boolean; + -- Returns True if the name is an internal name (i.e. contains a character + -- for which Is_OK_Internal_Letter is true, or if the name starts or ends + -- with an underscore. This call destroys the value of Name_Len and + -- Name_Buffer (it loads these as for Get_Name_String). + -- + -- Note: if the name is qualified (has a double underscore), then only the + -- final entity name is considered, not the qualifying names. Consider for + -- example that the name: + -- + -- pkg__B_1__xyz + -- + -- is not an internal name, because the B comes from the internal name of + -- a qualifying block, but the xyz means that this was indeed a declared + -- identifier called "xyz" within this block and there is nothing internal + -- about that name. + + function Is_Internal_Name return Boolean; + -- Like the form with an Id argument, except that the name to be tested is + -- passed in Name_Buffer and Name_Len (which are not affected by the call). + -- Name_Buffer (it loads these as for Get_Name_String). + + function Is_Valid_Name (Id : Name_Id) return Boolean; + -- True if Id is a valid name -- points to a valid entry in the + -- Name_Entries table. + + procedure Reset_Name_Table; + -- This procedure is used when there are multiple source files to reset + -- the name table info entries associated with current entries in the + -- names table. There is no harm in keeping the names entries themselves + -- from one compilation to another, but we can't keep the entity info, + -- since this refers to tree nodes, which are destroyed between each main + -- source file. + + procedure Add_Char_To_Name_Buffer (C : Character); + pragma Inline (Add_Char_To_Name_Buffer); + -- Add given character to the end of the string currently stored in the + -- Name_Buffer, incrementing Name_Len. + + procedure Add_Nat_To_Name_Buffer (V : Nat); + -- Add decimal representation of given value to the end of the string + -- currently stored in Name_Buffer, incrementing Name_Len as required. + + procedure Add_Str_To_Name_Buffer (S : String); + -- Add characters of string S to the end of the string currently stored + -- in the Name_Buffer, incrementing Name_Len by the length of the string. + + procedure Insert_Str_In_Name_Buffer (S : String; Index : Positive); + -- Inserts given string in name buffer, starting at Index. Any existing + -- characters at or past this location get moved beyond the inserted string + -- and Name_Len is incremented by the length of the string. + + procedure Set_Character_Literal_Name (C : Char_Code); + -- This procedure sets the proper encoded name for the character literal + -- for the given character code. On return Name_Buffer and Name_Len are + -- set to reflect the stored name. + + procedure Set_Name_Table_Info (Id : Name_Id; Val : Int); + pragma Inline (Set_Name_Table_Info); + -- Sets the Int value associated with the given name + + procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte); + pragma Inline (Set_Name_Table_Byte); + -- Sets the Byte value associated with the given name + + procedure Store_Encoded_Character (C : Char_Code); + -- Stores given character code at the end of Name_Buffer, updating the + -- value in Name_Len appropriately. Lower case letters and digits are + -- stored unchanged. Other 8-bit characters are stored using the Uhh + -- encoding (hh = hex code), other 16-bit wide character values are stored + -- using the Whhhh (hhhh = hex code) encoding, and other 32-bit wide wide + -- character values are stored using the WWhhhhhhhh (hhhhhhhh = hex code). + -- Note that this procedure does not fold upper case letters (they are + -- stored using the Uhh encoding). If folding is required, it must be done + -- by the caller prior to the call. + + procedure Tree_Read; + -- Initializes internal tables from current tree file using the relevant + -- Table.Tree_Read routines. Note that Initialize should not be called if + -- Tree_Read is used. Tree_Read includes all necessary initialization. + + procedure Tree_Write; + -- Writes out internal tables to current tree file using the relevant + -- Table.Tree_Write routines. + + procedure Get_Last_Two_Chars (N : Name_Id; C1, C2 : out Character); + -- Obtains last two characters of a name. C1 is last but one character + -- and C2 is last character. If name is less than two characters long, + -- then both C1 and C2 are set to ASCII.NUL on return. + + procedure Write_Name (Id : Name_Id); + -- Write_Name writes the characters of the specified name using the + -- standard output procedures in package Output. No end of line is + -- written, just the characters of the name. On return Name_Buffer and + -- Name_Len are set as for a call to Get_Name_String. The name is written + -- in encoded form (i.e. including Uhh, Whhh, Qx, _op as they appear in + -- the name table). If Id is Error_Name, or No_Name, no text is output. + + procedure Write_Name_Decoded (Id : Name_Id); + -- Like Write_Name, except that the name written is the decoded name, as + -- described for Get_Decoded_Name_String, and the resulting value stored + -- in Name_Len and Name_Buffer is the decoded name. + + ------------------------------ + -- File and Unit Name Types -- + ------------------------------ + + -- These are defined here in Namet rather than Fname and Uname to avoid + -- problems with dependencies, and to avoid dragging in Fname and Uname + -- into many more files, but it would be cleaner to move to Fname/Uname. + + type File_Name_Type is new Name_Id; + -- File names are stored in the names table and this type is used to + -- indicate that a Name_Id value is being used to hold a simple file name + -- (which does not include any directory information). + + No_File : constant File_Name_Type := File_Name_Type (No_Name); + -- Constant used to indicate no file is present (this is used for example + -- when a search for a file indicates that no file of the name exists). + + Error_File_Name : constant File_Name_Type := File_Name_Type (Error_Name); + -- The special File_Name_Type value Error_File_Name is used to indicate + -- a unit name where some previous processing has found an error. + + subtype Error_File_Name_Or_No_File is + File_Name_Type range No_File .. Error_File_Name; + -- Used to test for either error file name or no file + + type Path_Name_Type is new Name_Id; + -- Path names are stored in the names table and this type is used to + -- indicate that a Name_Id value is being used to hold a path name (that + -- may contain directory information). + + No_Path : constant Path_Name_Type := Path_Name_Type (No_Name); + -- Constant used to indicate no path name is present + + type Unit_Name_Type is new Name_Id; + -- Unit names are stored in the names table and this type is used to + -- indicate that a Name_Id value is being used to hold a unit name, which + -- terminates in %b for a body or %s for a spec. + + No_Unit_Name : constant Unit_Name_Type := Unit_Name_Type (No_Name); + -- Constant used to indicate no file name present + + Error_Unit_Name : constant Unit_Name_Type := Unit_Name_Type (Error_Name); + -- The special Unit_Name_Type value Error_Unit_Name is used to indicate + -- a unit name where some previous processing has found an error. + + subtype Error_Unit_Name_Or_No_Unit_Name is + Unit_Name_Type range No_Unit_Name .. Error_Unit_Name; + + ------------------------ + -- Debugging Routines -- + ------------------------ + + procedure wn (Id : Name_Id); + pragma Export (Ada, wn); + -- This routine is intended for debugging use only (i.e. it is intended to + -- be called from the debugger). It writes the characters of the specified + -- name using the standard output procedures in package Output, followed by + -- a new line. The name is written in encoded form (i.e. including Uhh, + -- Whhh, Qx, _op as they appear in the name table). If Id is Error_Name, + -- No_Name, or invalid an appropriate string is written (, + -- , ). Unlike Write_Name, this call does not affect + -- the contents of Name_Buffer or Name_Len. + + --------------------------- + -- Table Data Structures -- + --------------------------- + + -- The following declarations define the data structures used to store + -- names. The definitions are in the private part of the package spec, + -- rather than the body, since they are referenced directly by gigi. + +private + + -- This table stores the actual string names. Although logically there is + -- no need for a terminating character (since the length is stored in the + -- name entry table), we still store a NUL character at the end of every + -- name (for convenience in interfacing to the C world). + + package Name_Chars is new Table.Table ( + Table_Component_Type => Character, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.Name_Chars_Initial, + Table_Increment => Alloc.Name_Chars_Increment, + Table_Name => "Name_Chars"); + + type Name_Entry is record + Name_Chars_Index : Int; + -- Starting location of characters in the Name_Chars table minus one + -- (i.e. pointer to character just before first character). The reason + -- for the bias of one is that indexes in Name_Buffer are one's origin, + -- so this avoids unnecessary adds and subtracts of 1. + + Name_Len : Short; + -- Length of this name in characters + + Byte_Info : Byte; + -- Byte value associated with this name + + Name_Has_No_Encodings : Boolean; + -- This flag is set True if the name entry is known not to contain any + -- special character encodings. This is used to speed up repeated calls + -- to Get_Decoded_Name_String. A value of False means that it is not + -- known whether the name contains any such encodings. + + Hash_Link : Name_Id; + -- Link to next entry in names table for same hash code + + Int_Info : Int; + -- Int Value associated with this name + end record; + + for Name_Entry use record + Name_Chars_Index at 0 range 0 .. 31; + Name_Len at 4 range 0 .. 15; + Byte_Info at 6 range 0 .. 7; + Name_Has_No_Encodings at 7 range 0 .. 7; + Hash_Link at 8 range 0 .. 31; + Int_Info at 12 range 0 .. 31; + end record; + + for Name_Entry'Size use 16 * 8; + -- This ensures that we did not leave out any fields + + -- This is the table that is referenced by Name_Id entries. + -- It contains one entry for each unique name in the table. + + package Name_Entries is new Table.Table ( + Table_Component_Type => Name_Entry, + Table_Index_Type => Name_Id'Base, + Table_Low_Bound => First_Name_Id, + Table_Initial => Alloc.Names_Initial, + Table_Increment => Alloc.Names_Increment, + Table_Name => "Name_Entries"); + +end Namet; diff --git a/gcc/ada/namet.h b/gcc/ada/namet.h new file mode 100644 index 000000000..6182c8b01 --- /dev/null +++ b/gcc/ada/namet.h @@ -0,0 +1,129 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * N A M E T * + * * + * C Header File * + * * + * Copyright (C) 1992-2008, Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING3. If not, go to * + * http://www.gnu.org/licenses for a complete copy of the license. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* This is the C file that corresponds to the Ada package specification + Namet. It was created manually from files namet.ads and namet.adb. */ + +/* Structure defining a names table entry. */ + +struct Name_Entry +{ + Int Name_Chars_Index; /* Starting location of char in Name_Chars table. */ + Short Name_Len; /* Length of this name in characters. */ + Byte Byte_Info; /* Byte value associated with this name */ + Byte Spare; /* Unused */ + Name_Id Hash_Link; /* Link to next entry in names table for same hash + code. Not accessed by C routines. */ + Int Int_Info; /* Int value associated with this name */ +}; + +/* Pointer to names table vector. */ +#define Names_Ptr namet__name_entries__table +extern struct Name_Entry *Names_Ptr; + +/* Pointer to name characters table. */ +#define Name_Chars_Ptr namet__name_chars__table +extern char *Name_Chars_Ptr; + +#define Name_Buffer namet__name_buffer +extern char Name_Buffer[]; + +extern Int namet__name_len; +#define Name_Len namet__name_len + +/* Get_Name_String returns a null terminated C string for the specified name. + We could use the official Ada routine for this purpose, but since the + strings we want are sitting in the name strings table in exactly the form + we need them (null terminated), we just point to the name directly. */ + +static char *Get_Name_String (Name_Id); + +INLINE char * +Get_Name_String (Name_Id Id) +{ + return Name_Chars_Ptr + Names_Ptr[Id - First_Name_Id].Name_Chars_Index + 1; +} + +/* Get_Decoded_Name_String returns a null terminated C string in the same + manner as Get_Name_String, except that it is decoded (i.e. upper half or + wide characters are put back in their external form, and character literals + are also returned in their external form (with surrounding apostrophes) */ + +extern void namet__get_decoded_name_string (Name_Id); + +static char *Get_Decoded_Name_String (Name_Id); + +INLINE char * +Get_Decoded_Name_String (Name_Id Id) +{ + namet__get_decoded_name_string (Id); + Name_Buffer[Name_Len] = 0; + return Name_Buffer; +} + +/* Like Get_Decoded_Name_String, but the result has all qualification and + package body entity suffixes stripped, and also all letters are upper + cased. This is used for building the enumeration literal table. */ + +extern void casing__set_all_upper_case (void); + +/* The following routines and variables are not part of Namet, but we + include the header here since it seems the best place for it. */ + +#define Get_Encoded_Type_Name exp_dbug__get_encoded_type_name +extern Boolean Get_Encoded_Type_Name (Entity_Id); +#define Get_Variant_Encoding exp_dbug__get_variant_encoding +extern void Get_Variant_Encoding (Entity_Id); + +#define Spec_Context_List exp_dbug__spec_context_list +#define Body_Context_List exp_dbug__body_context_list +extern char *Spec_Context_List, *Body_Context_List; +#define Spec_Filename exp_dbug__spec_filename +#define Body_Filename exp_dbug__body_filename +extern char *Spec_Filename, *Body_Filename; + +#define Is_Non_Ada_Error exp_ch11__is_non_ada_error +extern Boolean Is_Non_Ada_Error (Entity_Id); + +/* Here are some functions in sinput.adb we call from a-trans.c. */ +typedef Nat Source_File_Index; +typedef Int Logical_Line_Number; +typedef Int Column_Number; + +#define Debug_Source_Name sinput__debug_source_name +#define Full_Debug_Name sinput__full_debug_name +#define Reference_Name sinput__reference_name +#define Get_Source_File_Index sinput__get_source_file_index +#define Get_Logical_Line_Number sinput__get_logical_line_number +#define Get_Column_Number sinput__get_column_number +#define Instantiation sinput__instantiation + +extern File_Name_Type Debug_Source_Name (Source_File_Index); +extern File_Name_Type Full_Debug_Name (Source_File_Index); +extern File_Name_Type Reference_Name (Source_File_Index); +extern Source_File_Index Get_Source_File_Index (Source_Ptr); +extern Logical_Line_Number Get_Logical_Line_Number (Source_Ptr); +extern Column_Number Get_Column_Number (Source_Ptr); +extern Source_Ptr Instantiation (Source_File_Index); diff --git a/gcc/ada/nlists.adb b/gcc/ada/nlists.adb new file mode 100644 index 000000000..453e665ec --- /dev/null +++ b/gcc/ada/nlists.adb @@ -0,0 +1,1459 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- N L I S T 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. -- +-- -- +------------------------------------------------------------------------------ + +-- WARNING: There is a C version of this package. Any changes to this source +-- file must be properly reflected in the corresponding C header a-nlists.h + +with Alloc; +with Atree; use Atree; +with Debug; use Debug; +with Output; use Output; +with Sinfo; use Sinfo; +with Table; + +package body Nlists is + + use Atree_Private_Part; + -- Get access to Nodes table + + ---------------------------------- + -- Implementation of Node Lists -- + ---------------------------------- + + -- A node list is represented by a list header which contains + -- three fields: + + type List_Header is record + First : Node_Or_Entity_Id; + -- Pointer to first node in list. Empty if list is empty + + Last : Node_Or_Entity_Id; + -- Pointer to last node in list. Empty if list is empty + + Parent : Node_Id; + -- Pointer to parent of list. Empty if list has no parent + end record; + + -- The node lists are stored in a table indexed by List_Id values + + package Lists is new Table.Table ( + Table_Component_Type => List_Header, + Table_Index_Type => List_Id'Base, + Table_Low_Bound => First_List_Id, + Table_Initial => Alloc.Lists_Initial, + Table_Increment => Alloc.Lists_Increment, + Table_Name => "Lists"); + + -- The nodes in the list all have the In_List flag set, and their Link + -- fields (which otherwise point to the parent) contain the List_Id of + -- the list header giving immediate access to the list containing the + -- node, and its parent and first and last elements. + + -- Two auxiliary tables, indexed by Node_Id values and built in parallel + -- with the main nodes table and always having the same size contain the + -- list link values that allow locating the previous and next node in a + -- list. The entries in these tables are valid only if the In_List flag + -- is set in the corresponding node. Next_Node is Empty at the end of a + -- list and Prev_Node is Empty at the start of a list. + + package Next_Node is new Table.Table ( + Table_Component_Type => Node_Or_Entity_Id, + Table_Index_Type => Node_Or_Entity_Id'Base, + Table_Low_Bound => First_Node_Id, + Table_Initial => Alloc.Orig_Nodes_Initial, + Table_Increment => Alloc.Orig_Nodes_Increment, + Table_Name => "Next_Node"); + + package Prev_Node is new Table.Table ( + Table_Component_Type => Node_Or_Entity_Id, + Table_Index_Type => Node_Or_Entity_Id'Base, + Table_Low_Bound => First_Node_Id, + Table_Initial => Alloc.Orig_Nodes_Initial, + Table_Increment => Alloc.Orig_Nodes_Increment, + Table_Name => "Prev_Node"); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Set_First (List : List_Id; To : Node_Or_Entity_Id); + pragma Inline (Set_First); + -- Sets First field of list header List to reference To + + procedure Set_Last (List : List_Id; To : Node_Or_Entity_Id); + pragma Inline (Set_Last); + -- Sets Last field of list header List to reference To + + procedure Set_List_Link (Node : Node_Or_Entity_Id; To : List_Id); + pragma Inline (Set_List_Link); + -- Sets list link of Node to list header To + + procedure Set_Next (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id); + pragma Inline (Set_Next); + -- Sets the Next_Node pointer for Node to reference To + + procedure Set_Prev (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id); + pragma Inline (Set_Prev); + -- Sets the Prev_Node pointer for Node to reference To + + -------------------------- + -- Allocate_List_Tables -- + -------------------------- + + procedure Allocate_List_Tables (N : Node_Or_Entity_Id) is + Old_Last : constant Node_Or_Entity_Id'Base := Next_Node.Last; + + begin + pragma Assert (N >= Old_Last); + Next_Node.Set_Last (N); + Prev_Node.Set_Last (N); + + -- Make sure we have no uninitialized junk in any new entires added. + -- This ensures that Tree_Gen will not write out any uninitialized junk. + + for J in Old_Last + 1 .. N loop + Next_Node.Table (J) := Empty; + Prev_Node.Table (J) := Empty; + end loop; + end Allocate_List_Tables; + + ------------ + -- Append -- + ------------ + + procedure Append (Node : Node_Or_Entity_Id; To : List_Id) is + L : constant Node_Or_Entity_Id := Last (To); + + procedure Append_Debug; + pragma Inline (Append_Debug); + -- Output debug information if Debug_Flag_N set + + ------------------ + -- Append_Debug -- + ------------------ + + procedure Append_Debug is + begin + if Debug_Flag_N then + Write_Str ("Append node "); + Write_Int (Int (Node)); + Write_Str (" to list "); + Write_Int (Int (To)); + Write_Eol; + end if; + end Append_Debug; + + -- Start of processing for Append + + begin + pragma Assert (not Is_List_Member (Node)); + + if Node = Error then + return; + end if; + + pragma Debug (Append_Debug); + + if No (L) then + Set_First (To, Node); + else + Set_Next (L, Node); + end if; + + Set_Last (To, Node); + + Nodes.Table (Node).In_List := True; + + Set_Next (Node, Empty); + Set_Prev (Node, L); + Set_List_Link (Node, To); + end Append; + + ----------------- + -- Append_List -- + ----------------- + + procedure Append_List (List : List_Id; To : List_Id) is + + procedure Append_List_Debug; + pragma Inline (Append_List_Debug); + -- Output debug information if Debug_Flag_N set + + ----------------------- + -- Append_List_Debug -- + ----------------------- + + procedure Append_List_Debug is + begin + if Debug_Flag_N then + Write_Str ("Append list "); + Write_Int (Int (List)); + Write_Str (" to list "); + Write_Int (Int (To)); + Write_Eol; + end if; + end Append_List_Debug; + + -- Start of processing for Append_List + + begin + if Is_Empty_List (List) then + return; + + else + declare + L : constant Node_Or_Entity_Id := Last (To); + F : constant Node_Or_Entity_Id := First (List); + N : Node_Or_Entity_Id; + + begin + pragma Debug (Append_List_Debug); + + N := F; + loop + Set_List_Link (N, To); + N := Next (N); + exit when No (N); + end loop; + + if No (L) then + Set_First (To, F); + else + Set_Next (L, F); + end if; + + Set_Prev (F, L); + Set_Last (To, Last (List)); + + Set_First (List, Empty); + Set_Last (List, Empty); + end; + end if; + end Append_List; + + -------------------- + -- Append_List_To -- + -------------------- + + procedure Append_List_To (To : List_Id; List : List_Id) is + begin + Append_List (List, To); + end Append_List_To; + + --------------- + -- Append_To -- + --------------- + + procedure Append_To (To : List_Id; Node : Node_Or_Entity_Id) is + begin + Append (Node, To); + end Append_To; + + ----------- + -- First -- + ----------- + + function First (List : List_Id) return Node_Or_Entity_Id is + begin + if List = No_List then + return Empty; + else + pragma Assert (List <= Lists.Last); + return Lists.Table (List).First; + end if; + end First; + + ---------------------- + -- First_Non_Pragma -- + ---------------------- + + function First_Non_Pragma (List : List_Id) return Node_Or_Entity_Id is + N : constant Node_Or_Entity_Id := First (List); + begin + if Nkind (N) /= N_Pragma + and then + Nkind (N) /= N_Null_Statement + then + return N; + else + return Next_Non_Pragma (N); + end if; + end First_Non_Pragma; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + E : constant List_Id := Error_List; + + begin + Lists.Init; + Next_Node.Init; + Prev_Node.Init; + + -- Allocate Error_List list header + + Lists.Increment_Last; + Set_Parent (E, Empty); + Set_First (E, Empty); + Set_Last (E, Empty); + end Initialize; + + ------------------ + -- In_Same_List -- + ------------------ + + function In_Same_List (N1, N2 : Node_Or_Entity_Id) return Boolean is + begin + return List_Containing (N1) = List_Containing (N2); + end In_Same_List; + + ------------------ + -- Insert_After -- + ------------------ + + procedure Insert_After + (After : Node_Or_Entity_Id; + Node : Node_Or_Entity_Id) + is + procedure Insert_After_Debug; + pragma Inline (Insert_After_Debug); + -- Output debug information if Debug_Flag_N set + + ------------------------ + -- Insert_After_Debug -- + ------------------------ + + procedure Insert_After_Debug is + begin + if Debug_Flag_N then + Write_Str ("Insert node"); + Write_Int (Int (Node)); + Write_Str (" after node "); + Write_Int (Int (After)); + Write_Eol; + end if; + end Insert_After_Debug; + + -- Start of processing for Insert_After + + begin + pragma Assert + (Is_List_Member (After) and then not Is_List_Member (Node)); + + if Node = Error then + return; + end if; + + pragma Debug (Insert_After_Debug); + + declare + Before : constant Node_Or_Entity_Id := Next (After); + LC : constant List_Id := List_Containing (After); + + begin + if Present (Before) then + Set_Prev (Before, Node); + else + Set_Last (LC, Node); + end if; + + Set_Next (After, Node); + + Nodes.Table (Node).In_List := True; + + Set_Prev (Node, After); + Set_Next (Node, Before); + Set_List_Link (Node, LC); + end; + end Insert_After; + + ------------------- + -- Insert_Before -- + ------------------- + + procedure Insert_Before + (Before : Node_Or_Entity_Id; + Node : Node_Or_Entity_Id) + is + procedure Insert_Before_Debug; + pragma Inline (Insert_Before_Debug); + -- Output debug information if Debug_Flag_N set + + ------------------------- + -- Insert_Before_Debug -- + ------------------------- + + procedure Insert_Before_Debug is + begin + if Debug_Flag_N then + Write_Str ("Insert node"); + Write_Int (Int (Node)); + Write_Str (" before node "); + Write_Int (Int (Before)); + Write_Eol; + end if; + end Insert_Before_Debug; + + -- Start of processing for Insert_Before + + begin + pragma Assert + (Is_List_Member (Before) and then not Is_List_Member (Node)); + + if Node = Error then + return; + end if; + + pragma Debug (Insert_Before_Debug); + + declare + After : constant Node_Or_Entity_Id := Prev (Before); + LC : constant List_Id := List_Containing (Before); + + begin + if Present (After) then + Set_Next (After, Node); + else + Set_First (LC, Node); + end if; + + Set_Prev (Before, Node); + + Nodes.Table (Node).In_List := True; + + Set_Prev (Node, After); + Set_Next (Node, Before); + Set_List_Link (Node, LC); + end; + end Insert_Before; + + ----------------------- + -- Insert_List_After -- + ----------------------- + + procedure Insert_List_After (After : Node_Or_Entity_Id; List : List_Id) is + + procedure Insert_List_After_Debug; + pragma Inline (Insert_List_After_Debug); + -- Output debug information if Debug_Flag_N set + + ----------------------------- + -- Insert_List_After_Debug -- + ----------------------------- + + procedure Insert_List_After_Debug is + begin + if Debug_Flag_N then + Write_Str ("Insert list "); + Write_Int (Int (List)); + Write_Str (" after node "); + Write_Int (Int (After)); + Write_Eol; + end if; + end Insert_List_After_Debug; + + -- Start of processing for Insert_List_After + + begin + pragma Assert (Is_List_Member (After)); + + if Is_Empty_List (List) then + return; + + else + declare + Before : constant Node_Or_Entity_Id := Next (After); + LC : constant List_Id := List_Containing (After); + F : constant Node_Or_Entity_Id := First (List); + L : constant Node_Or_Entity_Id := Last (List); + N : Node_Or_Entity_Id; + + begin + pragma Debug (Insert_List_After_Debug); + + N := F; + loop + Set_List_Link (N, LC); + exit when N = L; + N := Next (N); + end loop; + + if Present (Before) then + Set_Prev (Before, L); + else + Set_Last (LC, L); + end if; + + Set_Next (After, F); + Set_Prev (F, After); + Set_Next (L, Before); + + Set_First (List, Empty); + Set_Last (List, Empty); + end; + end if; + end Insert_List_After; + + ------------------------ + -- Insert_List_Before -- + ------------------------ + + procedure Insert_List_Before (Before : Node_Or_Entity_Id; List : List_Id) is + + procedure Insert_List_Before_Debug; + pragma Inline (Insert_List_Before_Debug); + -- Output debug information if Debug_Flag_N set + + ------------------------------ + -- Insert_List_Before_Debug -- + ------------------------------ + + procedure Insert_List_Before_Debug is + begin + if Debug_Flag_N then + Write_Str ("Insert list "); + Write_Int (Int (List)); + Write_Str (" before node "); + Write_Int (Int (Before)); + Write_Eol; + end if; + end Insert_List_Before_Debug; + + -- Start of processing for Insert_List_Before + + begin + pragma Assert (Is_List_Member (Before)); + + if Is_Empty_List (List) then + return; + + else + declare + After : constant Node_Or_Entity_Id := Prev (Before); + LC : constant List_Id := List_Containing (Before); + F : constant Node_Or_Entity_Id := First (List); + L : constant Node_Or_Entity_Id := Last (List); + N : Node_Or_Entity_Id; + + begin + pragma Debug (Insert_List_Before_Debug); + + N := F; + loop + Set_List_Link (N, LC); + exit when N = L; + N := Next (N); + end loop; + + if Present (After) then + Set_Next (After, F); + else + Set_First (LC, F); + end if; + + Set_Prev (Before, L); + Set_Prev (F, After); + Set_Next (L, Before); + + Set_First (List, Empty); + Set_Last (List, Empty); + end; + end if; + end Insert_List_Before; + + ------------------- + -- Is_Empty_List -- + ------------------- + + function Is_Empty_List (List : List_Id) return Boolean is + begin + return First (List) = Empty; + end Is_Empty_List; + + -------------------- + -- Is_List_Member -- + -------------------- + + function Is_List_Member (Node : Node_Or_Entity_Id) return Boolean is + begin + return Nodes.Table (Node).In_List; + end Is_List_Member; + + ----------------------- + -- Is_Non_Empty_List -- + ----------------------- + + function Is_Non_Empty_List (List : List_Id) return Boolean is + begin + return First (List) /= Empty; + end Is_Non_Empty_List; + + ---------- + -- Last -- + ---------- + + function Last (List : List_Id) return Node_Or_Entity_Id is + begin + pragma Assert (List <= Lists.Last); + return Lists.Table (List).Last; + end Last; + + ------------------ + -- Last_List_Id -- + ------------------ + + function Last_List_Id return List_Id is + begin + return Lists.Last; + end Last_List_Id; + + --------------------- + -- Last_Non_Pragma -- + --------------------- + + function Last_Non_Pragma (List : List_Id) return Node_Or_Entity_Id is + N : constant Node_Or_Entity_Id := Last (List); + begin + if Nkind (N) /= N_Pragma then + return N; + else + return Prev_Non_Pragma (N); + end if; + end Last_Non_Pragma; + + --------------------- + -- List_Containing -- + --------------------- + + function List_Containing (Node : Node_Or_Entity_Id) return List_Id is + begin + pragma Assert (Is_List_Member (Node)); + return List_Id (Nodes.Table (Node).Link); + end List_Containing; + + ----------------- + -- List_Length -- + ----------------- + + function List_Length (List : List_Id) return Nat is + Result : Nat; + Node : Node_Or_Entity_Id; + + begin + Result := 0; + Node := First (List); + while Present (Node) loop + Result := Result + 1; + Node := Next (Node); + end loop; + + return Result; + end List_Length; + + ------------------- + -- Lists_Address -- + ------------------- + + function Lists_Address return System.Address is + begin + return Lists.Table (First_List_Id)'Address; + end Lists_Address; + + ---------- + -- Lock -- + ---------- + + procedure Lock is + begin + Lists.Locked := True; + Lists.Release; + + Prev_Node.Locked := True; + Next_Node.Locked := True; + + Prev_Node.Release; + Next_Node.Release; + end Lock; + + ------------------- + -- New_Copy_List -- + ------------------- + + function New_Copy_List (List : List_Id) return List_Id is + NL : List_Id; + E : Node_Or_Entity_Id; + + begin + if List = No_List then + return No_List; + + else + NL := New_List; + E := First (List); + + while Present (E) loop + Append (New_Copy (E), NL); + E := Next (E); + end loop; + + return NL; + end if; + end New_Copy_List; + + ---------------------------- + -- New_Copy_List_Original -- + ---------------------------- + + function New_Copy_List_Original (List : List_Id) return List_Id is + NL : List_Id; + E : Node_Or_Entity_Id; + + begin + if List = No_List then + return No_List; + + else + NL := New_List; + E := First (List); + + while Present (E) loop + if Comes_From_Source (E) then + Append (New_Copy (E), NL); + end if; + + E := Next (E); + end loop; + + return NL; + end if; + end New_Copy_List_Original; + + -------------- + -- New_List -- + -------------- + + function New_List return List_Id is + + procedure New_List_Debug; + pragma Inline (New_List_Debug); + -- Output debugging information if Debug_Flag_N is set + + -------------------- + -- New_List_Debug -- + -------------------- + + procedure New_List_Debug is + begin + if Debug_Flag_N then + Write_Str ("Allocate new list, returned ID = "); + Write_Int (Int (Lists.Last)); + Write_Eol; + end if; + end New_List_Debug; + + -- Start of processing for New_List + + begin + Lists.Increment_Last; + + declare + List : constant List_Id := Lists.Last; + + begin + Set_Parent (List, Empty); + Set_First (List, Empty); + Set_Last (List, Empty); + + pragma Debug (New_List_Debug); + return (List); + end; + end New_List; + + -- Since the one argument case is common, we optimize to build the right + -- list directly, rather than first building an empty list and then doing + -- the insertion, which results in some unnecessary work. + + function New_List (Node : Node_Or_Entity_Id) return List_Id is + + procedure New_List_Debug; + pragma Inline (New_List_Debug); + -- Output debugging information if Debug_Flag_N is set + + -------------------- + -- New_List_Debug -- + -------------------- + + procedure New_List_Debug is + begin + if Debug_Flag_N then + Write_Str ("Allocate new list, returned ID = "); + Write_Int (Int (Lists.Last)); + Write_Eol; + end if; + end New_List_Debug; + + -- Start of processing for New_List + + begin + if Node = Error then + return New_List; + + else + pragma Assert (not Is_List_Member (Node)); + + Lists.Increment_Last; + + declare + List : constant List_Id := Lists.Last; + + begin + Set_Parent (List, Empty); + Set_First (List, Node); + Set_Last (List, Node); + + Nodes.Table (Node).In_List := True; + Set_List_Link (Node, List); + Set_Prev (Node, Empty); + Set_Next (Node, Empty); + pragma Debug (New_List_Debug); + return List; + end; + end if; + end New_List; + + function New_List + (Node1 : Node_Or_Entity_Id; + Node2 : Node_Or_Entity_Id) return List_Id + is + L : constant List_Id := New_List (Node1); + begin + Append (Node2, L); + return L; + end New_List; + + function New_List + (Node1 : Node_Or_Entity_Id; + Node2 : Node_Or_Entity_Id; + Node3 : Node_Or_Entity_Id) return List_Id + is + L : constant List_Id := New_List (Node1); + begin + Append (Node2, L); + Append (Node3, L); + return L; + end New_List; + + function New_List + (Node1 : Node_Or_Entity_Id; + Node2 : Node_Or_Entity_Id; + Node3 : Node_Or_Entity_Id; + Node4 : Node_Or_Entity_Id) return List_Id + is + L : constant List_Id := New_List (Node1); + begin + Append (Node2, L); + Append (Node3, L); + Append (Node4, L); + return L; + end New_List; + + function New_List + (Node1 : Node_Or_Entity_Id; + Node2 : Node_Or_Entity_Id; + Node3 : Node_Or_Entity_Id; + Node4 : Node_Or_Entity_Id; + Node5 : Node_Or_Entity_Id) return List_Id + is + L : constant List_Id := New_List (Node1); + begin + Append (Node2, L); + Append (Node3, L); + Append (Node4, L); + Append (Node5, L); + return L; + end New_List; + + function New_List + (Node1 : Node_Or_Entity_Id; + Node2 : Node_Or_Entity_Id; + Node3 : Node_Or_Entity_Id; + Node4 : Node_Or_Entity_Id; + Node5 : Node_Or_Entity_Id; + Node6 : Node_Or_Entity_Id) return List_Id + is + L : constant List_Id := New_List (Node1); + begin + Append (Node2, L); + Append (Node3, L); + Append (Node4, L); + Append (Node5, L); + Append (Node6, L); + return L; + end New_List; + + ---------- + -- Next -- + ---------- + + function Next (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id is + begin + pragma Assert (Is_List_Member (Node)); + return Next_Node.Table (Node); + end Next; + + procedure Next (Node : in out Node_Or_Entity_Id) is + begin + Node := Next (Node); + end Next; + + ----------------------- + -- Next_Node_Address -- + ----------------------- + + function Next_Node_Address return System.Address is + begin + return Next_Node.Table (First_Node_Id)'Address; + end Next_Node_Address; + + --------------------- + -- Next_Non_Pragma -- + --------------------- + + function Next_Non_Pragma + (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id + is + N : Node_Or_Entity_Id; + + begin + N := Node; + loop + N := Next (N); + exit when not Nkind_In (N, N_Pragma, N_Null_Statement); + end loop; + + return N; + end Next_Non_Pragma; + + procedure Next_Non_Pragma (Node : in out Node_Or_Entity_Id) is + begin + Node := Next_Non_Pragma (Node); + end Next_Non_Pragma; + + -------- + -- No -- + -------- + + function No (List : List_Id) return Boolean is + begin + return List = No_List; + end No; + + --------------- + -- Num_Lists -- + --------------- + + function Num_Lists return Nat is + begin + return Int (Lists.Last) - Int (Lists.First) + 1; + end Num_Lists; + + ------- + -- p -- + ------- + + function p (U : Union_Id) return Node_Or_Entity_Id is + begin + if U in Node_Range then + return Parent (Node_Or_Entity_Id (U)); + elsif U in List_Range then + return Parent (List_Id (U)); + else + return 99_999_999; + end if; + end p; + + ------------ + -- Parent -- + ------------ + + function Parent (List : List_Id) return Node_Or_Entity_Id is + begin + pragma Assert (List <= Lists.Last); + return Lists.Table (List).Parent; + end Parent; + + ---------- + -- Pick -- + ---------- + + function Pick (List : List_Id; Index : Pos) return Node_Or_Entity_Id is + Elmt : Node_Or_Entity_Id; + + begin + Elmt := First (List); + for J in 1 .. Index - 1 loop + Elmt := Next (Elmt); + end loop; + + return Elmt; + end Pick; + + ------------- + -- Prepend -- + ------------- + + procedure Prepend (Node : Node_Or_Entity_Id; To : List_Id) is + F : constant Node_Or_Entity_Id := First (To); + + procedure Prepend_Debug; + pragma Inline (Prepend_Debug); + -- Output debug information if Debug_Flag_N set + + ------------------- + -- Prepend_Debug -- + ------------------- + + procedure Prepend_Debug is + begin + if Debug_Flag_N then + Write_Str ("Prepend node "); + Write_Int (Int (Node)); + Write_Str (" to list "); + Write_Int (Int (To)); + Write_Eol; + end if; + end Prepend_Debug; + + -- Start of processing for Prepend_Debug + + begin + pragma Assert (not Is_List_Member (Node)); + + if Node = Error then + return; + end if; + + pragma Debug (Prepend_Debug); + + if No (F) then + Set_Last (To, Node); + else + Set_Prev (F, Node); + end if; + + Set_First (To, Node); + + Nodes.Table (Node).In_List := True; + + Set_Next (Node, F); + Set_Prev (Node, Empty); + Set_List_Link (Node, To); + end Prepend; + + ------------------ + -- Prepend_List -- + ------------------ + + procedure Prepend_List (List : List_Id; To : List_Id) is + + procedure Prepend_List_Debug; + pragma Inline (Prepend_List_Debug); + -- Output debug information if Debug_Flag_N set + + ------------------------ + -- Prepend_List_Debug -- + ------------------------ + + procedure Prepend_List_Debug is + begin + if Debug_Flag_N then + Write_Str ("Prepend list "); + Write_Int (Int (List)); + Write_Str (" to list "); + Write_Int (Int (To)); + Write_Eol; + end if; + end Prepend_List_Debug; + + -- Start of processing for Prepend_List + + begin + if Is_Empty_List (List) then + return; + + else + declare + F : constant Node_Or_Entity_Id := First (To); + L : constant Node_Or_Entity_Id := Last (List); + N : Node_Or_Entity_Id; + + begin + pragma Debug (Prepend_List_Debug); + + N := L; + loop + Set_List_Link (N, To); + N := Prev (N); + exit when No (N); + end loop; + + if No (F) then + Set_Last (To, L); + else + Set_Next (L, F); + end if; + + Set_Prev (F, L); + Set_First (To, First (List)); + + Set_First (List, Empty); + Set_Last (List, Empty); + end; + end if; + end Prepend_List; + + --------------------- + -- Prepend_List_To -- + --------------------- + + procedure Prepend_List_To (To : List_Id; List : List_Id) is + begin + Prepend_List (List, To); + end Prepend_List_To; + + ---------------- + -- Prepend_To -- + ---------------- + + procedure Prepend_To (To : List_Id; Node : Node_Or_Entity_Id) is + begin + Prepend (Node, To); + end Prepend_To; + + ------------- + -- Present -- + ------------- + + function Present (List : List_Id) return Boolean is + begin + return List /= No_List; + end Present; + + ---------- + -- Prev -- + ---------- + + function Prev (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id is + begin + pragma Assert (Is_List_Member (Node)); + return Prev_Node.Table (Node); + end Prev; + + procedure Prev (Node : in out Node_Or_Entity_Id) is + begin + Node := Prev (Node); + end Prev; + + ----------------------- + -- Prev_Node_Address -- + ----------------------- + + function Prev_Node_Address return System.Address is + begin + return Prev_Node.Table (First_Node_Id)'Address; + end Prev_Node_Address; + + --------------------- + -- Prev_Non_Pragma -- + --------------------- + + function Prev_Non_Pragma + (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id + is + N : Node_Or_Entity_Id; + + begin + N := Node; + loop + N := Prev (N); + exit when Nkind (N) /= N_Pragma; + end loop; + + return N; + end Prev_Non_Pragma; + + procedure Prev_Non_Pragma (Node : in out Node_Or_Entity_Id) is + begin + Node := Prev_Non_Pragma (Node); + end Prev_Non_Pragma; + + ------------ + -- Remove -- + ------------ + + procedure Remove (Node : Node_Or_Entity_Id) is + Lst : constant List_Id := List_Containing (Node); + Prv : constant Node_Or_Entity_Id := Prev (Node); + Nxt : constant Node_Or_Entity_Id := Next (Node); + + procedure Remove_Debug; + pragma Inline (Remove_Debug); + -- Output debug information if Debug_Flag_N set + + ------------------ + -- Remove_Debug -- + ------------------ + + procedure Remove_Debug is + begin + if Debug_Flag_N then + Write_Str ("Remove node "); + Write_Int (Int (Node)); + Write_Eol; + end if; + end Remove_Debug; + + -- Start of processing for Remove + + begin + pragma Debug (Remove_Debug); + + if No (Prv) then + Set_First (Lst, Nxt); + else + Set_Next (Prv, Nxt); + end if; + + if No (Nxt) then + Set_Last (Lst, Prv); + else + Set_Prev (Nxt, Prv); + end if; + + Nodes.Table (Node).In_List := False; + Set_Parent (Node, Empty); + end Remove; + + ----------------- + -- Remove_Head -- + ----------------- + + function Remove_Head (List : List_Id) return Node_Or_Entity_Id is + Frst : constant Node_Or_Entity_Id := First (List); + + procedure Remove_Head_Debug; + pragma Inline (Remove_Head_Debug); + -- Output debug information if Debug_Flag_N set + + ----------------------- + -- Remove_Head_Debug -- + ----------------------- + + procedure Remove_Head_Debug is + begin + if Debug_Flag_N then + Write_Str ("Remove head of list "); + Write_Int (Int (List)); + Write_Eol; + end if; + end Remove_Head_Debug; + + -- Start of processing for Remove_Head + + begin + pragma Debug (Remove_Head_Debug); + + if Frst = Empty then + return Empty; + + else + declare + Nxt : constant Node_Or_Entity_Id := Next (Frst); + + begin + Set_First (List, Nxt); + + if No (Nxt) then + Set_Last (List, Empty); + else + Set_Prev (Nxt, Empty); + end if; + + Nodes.Table (Frst).In_List := False; + Set_Parent (Frst, Empty); + return Frst; + end; + end if; + end Remove_Head; + + ----------------- + -- Remove_Next -- + ----------------- + + function Remove_Next + (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id + is + Nxt : constant Node_Or_Entity_Id := Next (Node); + + procedure Remove_Next_Debug; + pragma Inline (Remove_Next_Debug); + -- Output debug information if Debug_Flag_N set + + ----------------------- + -- Remove_Next_Debug -- + ----------------------- + + procedure Remove_Next_Debug is + begin + if Debug_Flag_N then + Write_Str ("Remove next node after "); + Write_Int (Int (Node)); + Write_Eol; + end if; + end Remove_Next_Debug; + + -- Start of processing for Remove_Next + + begin + if Present (Nxt) then + declare + Nxt2 : constant Node_Or_Entity_Id := Next (Nxt); + LC : constant List_Id := List_Containing (Node); + + begin + pragma Debug (Remove_Next_Debug); + Set_Next (Node, Nxt2); + + if No (Nxt2) then + Set_Last (LC, Node); + else + Set_Prev (Nxt2, Node); + end if; + + Nodes.Table (Nxt).In_List := False; + Set_Parent (Nxt, Empty); + end; + end if; + + return Nxt; + end Remove_Next; + + --------------- + -- Set_First -- + --------------- + + procedure Set_First (List : List_Id; To : Node_Or_Entity_Id) is + begin + Lists.Table (List).First := To; + end Set_First; + + -------------- + -- Set_Last -- + -------------- + + procedure Set_Last (List : List_Id; To : Node_Or_Entity_Id) is + begin + Lists.Table (List).Last := To; + end Set_Last; + + ------------------- + -- Set_List_Link -- + ------------------- + + procedure Set_List_Link (Node : Node_Or_Entity_Id; To : List_Id) is + begin + Nodes.Table (Node).Link := Union_Id (To); + end Set_List_Link; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id) is + begin + Next_Node.Table (Node) := To; + end Set_Next; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (List : List_Id; Node : Node_Or_Entity_Id) is + begin + pragma Assert (List <= Lists.Last); + Lists.Table (List).Parent := Node; + end Set_Parent; + + -------------- + -- Set_Prev -- + -------------- + + procedure Set_Prev (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id) is + begin + Prev_Node.Table (Node) := To; + end Set_Prev; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + begin + Lists.Tree_Read; + Next_Node.Tree_Read; + Prev_Node.Tree_Read; + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + begin + Lists.Tree_Write; + Next_Node.Tree_Write; + Prev_Node.Tree_Write; + end Tree_Write; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock is + begin + Lists.Locked := False; + Prev_Node.Locked := False; + Next_Node.Locked := False; + end Unlock; + +end Nlists; diff --git a/gcc/ada/nlists.ads b/gcc/ada/nlists.ads new file mode 100644 index 000000000..10c04ed90 --- /dev/null +++ b/gcc/ada/nlists.ads @@ -0,0 +1,374 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- N L I S T S -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides facilities for manipulating lists of nodes (see +-- package Atree for format and implementation of tree nodes). The Link field +-- of the nodes is used as the forward pointer for these lists. See also +-- package Elists which provides another form of lists that are not threaded +-- through the nodes (and therefore allow nodes to be on multiple lists). + +with System; +with Types; use Types; + +package Nlists is + + -- A node list is a list of nodes in a special format that means that + -- nodes can be on at most one such list. For each node list, a list + -- header is allocated in the lists table, and a List_Id value references + -- this header, which may be used to access the nodes in the list using + -- the set of routines that define this interface. + + -- Note: node lists can contain either nodes or entities (extended nodes) + -- or a mixture of nodes and extended nodes. + + function In_Same_List (N1, N2 : Node_Or_Entity_Id) return Boolean; + pragma Inline (In_Same_List); + -- Equivalent to List_Containing (N1) = List_Containing (N2) + + function Last_List_Id return List_Id; + pragma Inline (Last_List_Id); + -- Returns Id of last allocated list header + + function Lists_Address return System.Address; + pragma Inline (Lists_Address); + -- Return address of Lists table (used in Back_End for Gigi call) + + function Num_Lists return Nat; + pragma Inline (Num_Lists); + -- Number of currently allocated lists + + function New_List return List_Id; + -- Creates a new empty node list. Typically this is used to initialize + -- a field in some other node which points to a node list where the list + -- is then subsequently filled in using Append calls. + + function Empty_List return List_Id renames New_List; + -- Used in contexts where an empty list (as opposed to an initially empty + -- list to be filled in) is required. + + function New_List + (Node : Node_Or_Entity_Id) return List_Id; + -- Build a new list initially containing the given node + + function New_List + (Node1 : Node_Or_Entity_Id; + Node2 : Node_Or_Entity_Id) return List_Id; + -- Build a new list initially containing the two given nodes + + function New_List + (Node1 : Node_Or_Entity_Id; + Node2 : Node_Or_Entity_Id; + Node3 : Node_Or_Entity_Id) return List_Id; + -- Build a new list initially containing the three given nodes + + function New_List + (Node1 : Node_Or_Entity_Id; + Node2 : Node_Or_Entity_Id; + Node3 : Node_Or_Entity_Id; + Node4 : Node_Or_Entity_Id) return List_Id; + + function New_List + (Node1 : Node_Or_Entity_Id; + Node2 : Node_Or_Entity_Id; + Node3 : Node_Or_Entity_Id; + Node4 : Node_Or_Entity_Id; + Node5 : Node_Or_Entity_Id) return List_Id; + -- Build a new list initially containing the five given nodes + + function New_List + (Node1 : Node_Or_Entity_Id; + Node2 : Node_Or_Entity_Id; + Node3 : Node_Or_Entity_Id; + Node4 : Node_Or_Entity_Id; + Node5 : Node_Or_Entity_Id; + Node6 : Node_Or_Entity_Id) return List_Id; + -- Build a new list initially containing the six given nodes + + function New_Copy_List (List : List_Id) return List_Id; + -- Creates a new list containing copies (made with Atree.New_Copy) of every + -- node in the original list. If the argument is No_List, then the returned + -- result is No_List. If the argument is an empty list, then the returned + -- result is a new empty list. + + function New_Copy_List_Original (List : List_Id) return List_Id; + -- Same as New_Copy_List but copies only nodes coming from source + + function First (List : List_Id) return Node_Or_Entity_Id; + pragma Inline (First); + -- Obtains the first element of the given node list or, if the node list + -- has no items or is equal to No_List, then Empty is returned. + + function First_Non_Pragma (List : List_Id) return Node_Or_Entity_Id; + -- Used when dealing with a list that can contain pragmas to skip past + -- any initial pragmas and return the first element that is not a pragma. + -- If the list is empty, or if it contains only pragmas, then Empty is + -- returned. It is an error to call First_Non_Pragma with a Node_Id value + -- or No_List (No_List is not considered to be the same as an empty list). + -- This function also skips N_Null nodes which can result from rewriting + -- unrecognized or incorrect pragmas. + + function Last (List : List_Id) return Node_Or_Entity_Id; + pragma Inline (Last); + -- Obtains the last element of the given node list or, if the node list + -- has no items, then Empty is returned. It is an error to call Last with + -- a Node_Id or No_List. (No_List is not considered to be the same as an + -- empty node list). + + function Last_Non_Pragma (List : List_Id) return Node_Or_Entity_Id; + -- Obtains the last element of a given node list that is not a pragma. + -- If the list is empty, or if it contains only pragmas, then Empty is + -- returned. It is an error to call Last_Non_Pragma with a Node_Id or + -- No_List. (No_List is not considered to be the same as an empty list). + + function List_Length (List : List_Id) return Nat; + pragma Inline (List_Length); + -- Returns number of items in the given list. It is an error to call + -- this function with No_List (No_List is not considered to be the same + -- as an empty list). + + function Next (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id; + pragma Inline (Next); + -- This function returns the next node on a node list, or Empty if Node is + -- the last element of the node list. The argument must be a member of a + -- node list. + + procedure Next (Node : in out Node_Or_Entity_Id); + pragma Inline (Next); + -- Equivalent to Node := Next (Node); + + function Next_Non_Pragma + (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id; + -- This function returns the next node on a node list, skipping past any + -- pragmas, or Empty if there is no non-pragma entry left. The argument + -- must be a member of a node list. This function also skips N_Null nodes + -- which can result from rewriting unrecognized or incorrect pragmas. + + procedure Next_Non_Pragma (Node : in out Node_Or_Entity_Id); + pragma Inline (Next_Non_Pragma); + -- Equivalent to Node := Next_Non_Pragma (Node); + + function Prev (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id; + pragma Inline (Prev); + -- This function returns the previous node on a node list, or Empty + -- if Node is the first element of the node list. The argument must be + -- a member of a node list. Note: the implementation does maintain back + -- pointers, so this function executes quickly in constant time. + + function Pick (List : List_Id; Index : Pos) return Node_Or_Entity_Id; + -- Given a list, picks out the Index'th entry (1 = first entry). The + -- caller must ensure that Index is in range. + + procedure Prev (Node : in out Node_Or_Entity_Id); + pragma Inline (Prev); + -- Equivalent to Node := Prev (Node); + + function Prev_Non_Pragma + (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id; + pragma Inline (Prev_Non_Pragma); + -- This function returns the previous node on a node list, skipping any + -- pragmas. If Node is the first element of the list, or if the only + -- elements preceding it are pragmas, then Empty is returned. The + -- argument must be a member of a node list. Note: the implementation + -- does maintain back pointers, so this function executes quickly in + -- constant time. + + procedure Prev_Non_Pragma (Node : in out Node_Or_Entity_Id); + pragma Inline (Prev_Non_Pragma); + -- Equivalent to Node := Prev_Non_Pragma (Node); + + function Is_Empty_List (List : List_Id) return Boolean; + pragma Inline (Is_Empty_List); + -- This function determines if a given list id references a node list that + -- contains no items. No_List as an argument returns True. + + function Is_Non_Empty_List (List : List_Id) return Boolean; + pragma Inline (Is_Non_Empty_List); + -- This function determines if a given list id references a node list that + -- contains at least one item. No_List as an argument returns False. + + function Is_List_Member (Node : Node_Or_Entity_Id) return Boolean; + pragma Inline (Is_List_Member); + -- This function determines if a given node is a member of a node list. + -- It is an error for Node to be Empty, or to be a node list. + + function List_Containing (Node : Node_Or_Entity_Id) return List_Id; + pragma Inline (List_Containing); + -- This function provides a pointer to the node list containing Node. + -- Node must be a member of a node list. + + procedure Append (Node : Node_Or_Entity_Id; To : List_Id); + -- Appends Node at the end of node list To. Node must be a non-empty node + -- that is not already a member of a node list, and To must be a + -- node list. An attempt to append an error node is ignored without + -- complaint and the list is unchanged. + + procedure Append_To (To : List_Id; Node : Node_Or_Entity_Id); + pragma Inline (Append_To); + -- Like Append, but arguments are the other way round + + procedure Append_List (List : List_Id; To : List_Id); + -- Appends node list List to the end of node list To. On return, + -- List is reset to be empty. + + procedure Append_List_To (To : List_Id; List : List_Id); + pragma Inline (Append_List_To); + -- Like Append_List, but arguments are the other way round + + procedure Insert_After + (After : Node_Or_Entity_Id; + Node : Node_Or_Entity_Id); + -- Insert Node, which must be a non-empty node that is not already a + -- member of a node list, immediately past node After, which must be a + -- node that is currently a member of a node list. An attempt to insert + -- an error node is ignored without complaint (and the list is unchanged). + + procedure Insert_List_After + (After : Node_Or_Entity_Id; + List : List_Id); + -- Inserts the entire contents of node list List immediately after node + -- After, which must be a member of a node list. On return, the node list + -- List is reset to be the empty node list. + + procedure Insert_Before + (Before : Node_Or_Entity_Id; + Node : Node_Or_Entity_Id); + -- Insert Node, which must be a non-empty node that is not already a + -- member of a node list, immediately before Before, which must be a node + -- that is currently a member of a node list. An attempt to insert an + -- error node is ignored without complaint (and the list is unchanged). + + procedure Insert_List_Before + (Before : Node_Or_Entity_Id; + List : List_Id); + -- Inserts the entire contents of node list List immediately before node + -- Before, which must be a member of a node list. On return, the node list + -- List is reset to be the empty node list. + + procedure Prepend + (Node : Node_Or_Entity_Id; + To : List_Id); + -- Prepends Node at the start of node list To. Node must be a non-empty + -- node that is not already a member of a node list, and To must be a + -- node list. An attempt to prepend an error node is ignored without + -- complaint and the list is unchanged. + + procedure Prepend_To + (To : List_Id; + Node : Node_Or_Entity_Id); + pragma Inline (Prepend_To); + -- Like Prepend, but arguments are the other way round + + procedure Prepend_List + (List : List_Id; + To : List_Id); + -- Prepends node list List to the start of node list To. On return, + -- List is reset to be empty. + + procedure Prepend_List_To + (To : List_Id; + List : List_Id); + pragma Inline (Prepend_List_To); + -- Like Prepend_List, but arguments are the other way round + + procedure Remove (Node : Node_Or_Entity_Id); + -- Removes Node, which must be a node that is a member of a node list, + -- from this node list. The contents of Node are not otherwise affected. + + function Remove_Head (List : List_Id) return Node_Or_Entity_Id; + -- Removes the head element of a node list, and returns the node (whose + -- contents are not otherwise affected) as the result. If the node list + -- is empty, then Empty is returned. + + function Remove_Next (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id; + -- Removes the item immediately following the given node, and returns it + -- as the result. If Node is the last element of the list, then Empty is + -- returned. Node must be a member of a list. Unlike Remove, Remove_Next + -- is fast and does not involve any list traversal. + + procedure Initialize; + -- Called at the start of compilation of each new main source file to + -- initialize the allocation of the list table. Note that Initialize + -- must not be called if Tree_Read is used. + + procedure Lock; + -- Called to lock tables before back end is called + + procedure Unlock; + -- Unlock tables, in cases where the back end needs to modify them + + procedure Tree_Read; + -- Initializes internal tables from current tree file using the relevant + -- Table.Tree_Read routines. Note that Initialize should not be called if + -- Tree_Read is used. Tree_Read includes all necessary initialization. + + procedure Tree_Write; + -- Writes out internal tables to current tree file using the relevant + -- Table.Tree_Write routines. + + function Parent (List : List_Id) return Node_Or_Entity_Id; + pragma Inline (Parent); + -- Node lists may have a parent in the same way as a node. The function + -- accesses the Parent value, which is either Empty when a list header + -- is first created, or the value that has been set by Set_Parent. + + procedure Set_Parent (List : List_Id; Node : Node_Or_Entity_Id); + pragma Inline (Set_Parent); + -- Sets the parent field of the given list to reference the given node + + function No (List : List_Id) return Boolean; + pragma Inline (No); + -- Tests given Id for equality with No_List. This allows notations like + -- "if No (Statements)" as opposed to "if Statements = No_List". + + function Present (List : List_Id) return Boolean; + pragma Inline (Present); + -- Tests given Id for inequality with No_List. This allows notations like + -- "if Present (Statements)" as opposed to "if Statements /= No_List". + + procedure Allocate_List_Tables (N : Node_Or_Entity_Id); + -- Called when nodes table is expanded to include node N. This call + -- makes sure that list structures internal to Nlists are adjusted + -- appropriately to reflect this increase in the size of the nodes table. + + function Next_Node_Address return System.Address; + function Prev_Node_Address return System.Address; + -- These functions return the addresses of the Next_Node and Prev_Node + -- tables (used in Back_End for Gigi). + + function p (U : Union_Id) return Node_Or_Entity_Id; + -- This function is intended for use from the debugger, it determines + -- whether U is a Node_Id or List_Id, and calls the appropriate Parent + -- function and returns the parent Node in either case. This is shorter + -- to type, and avoids the overloading problem of using Parent. It + -- should NEVER be used except from the debugger. If p is called with + -- other than a node or list id value, it returns 99_999_999. + +end Nlists; diff --git a/gcc/ada/nlists.h b/gcc/ada/nlists.h new file mode 100644 index 000000000..1dd9394e9 --- /dev/null +++ b/gcc/ada/nlists.h @@ -0,0 +1,130 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * N L I S T S * + * * + * C Header File * + * * + * Copyright (C) 1992-2008, Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License along with GCC; see the file COPYING3. If 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 C header corresponding to the Ada package specification for + Nlists. It also contains the implementations of inlined functions from + the package body for Nlists. It was generated manually from nlists.ads and + nlists.adb and must be kept synchronized with changes in these files. + + Note that only routines for reading the tree are included, since the + tree transformer is not supposed to modify the tree in any way. */ + +/* The following is the structure used for the list headers table */ + +struct List_Header +{ + Node_Id first; + Node_Id last; + Node_Id parent; +}; + +/* The list headers are stored in an array. The pointer to this array is + passed as a parameter to gigi and stored in the global variable + List_Headers_Ptr. */ + +extern struct List_Header *List_Headers_Ptr; + +/* The previous and next links for lists are held in two arrays, Next_Node and + Prev_Node. The pointers to these arrays are passed as parameters to gigi + and stored in the global variables Prev_Node_Ptr and Next_Node_Ptr. */ + +extern Node_Id *Next_Node_Ptr; +extern Node_Id *Prev_Node_Ptr; + +/* Node List Access Functions */ + +static Node_Id First (List_Id); + +INLINE Node_Id +First (List_Id List) +{ + return List_Headers_Ptr[List - First_List_Id].first; +} + +#define First_Non_Pragma nlists__first_non_pragma +extern Node_Id First_Non_Pragma (Node_Id); + +static Node_Id Last (List_Id); + +INLINE Node_Id +Last (List_Id List) +{ + return List_Headers_Ptr[List - First_List_Id].last; +} + +#define First_Non_Pragma nlists__first_non_pragma +extern Node_Id First_Non_Pragma (List_Id); + +static Node_Id Next (Node_Id); + +INLINE Node_Id +Next (Node_Id Node) +{ + return Next_Node_Ptr[Node - First_Node_Id]; +} + +#define Next_Non_Pragma nlists__next_non_pragma +extern Node_Id Next_Non_Pragma (List_Id); + +static Node_Id Prev (Node_Id); + +INLINE Node_Id +Prev (Node_Id Node) +{ + return Prev_Node_Ptr[Node - First_Node_Id]; +} + + +#define Prev_Non_Pragma nlists__prev_non_pragma +extern Node_Id Prev_Non_Pragma (Node_Id); + +static Boolean Is_Empty_List (List_Id); +static Boolean Is_Non_Empty_List (List_Id); +static Boolean Is_List_Member (Node_Id); +static List_Id List_Containing (Node_Id); + +INLINE Boolean +Is_Empty_List (List_Id Id) +{ + return (First (Id) == Empty); +} + +INLINE Boolean +Is_Non_Empty_List (List_Id Id) +{ + return (Present (Id) && First (Id) != Empty); +} + +INLINE Boolean +Is_List_Member (Node_Id Node) +{ + return Nodes_Ptr[Node - First_Node_Id].U.K.in_list; +} + +INLINE List_Id +List_Containing (Node_Id Node) +{ + return Nodes_Ptr[Node - First_Node_Id].V.NX.link; +} diff --git a/gcc/ada/nmake.adt b/gcc/ada/nmake.adt new file mode 100644 index 000000000..8fd568414 --- /dev/null +++ b/gcc/ada/nmake.adt @@ -0,0 +1,80 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- N M A K E -- +-- -- +-- T e m p l a t e -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ +-- This file is a template used as input to the utility program XNmake, +-- which reads this template, and the spec of Sinfo (sinfo.ads) and +-- generates the body and/or the spec for the Nmake package (files +-- nmake.ads and nmake.adb) + +pragma Style_Checks (All_Checks); +-- Turn off subprogram order checking, since the routines here are +-- generated automatically in order. + +with Atree; use Atree; -- body only +with Namet; use Namet; -- spec only +with Nlists; use Nlists; -- spec only +with Sinfo; use Sinfo; -- body only +with Snames; use Snames; -- body only +with Stand; use Stand; -- body only +with Types; use Types; -- spec only +with Uintp; use Uintp; -- spec only +with Urealp; use Urealp; -- spec only + +package Nmake is + +-- This package contains a set of routines used to construct tree nodes +-- using a functional style. There is one routine for each node type defined +-- in Sinfo with the general interface: + +-- function Make_xxx (Sloc : Source_Ptr, +-- Field_Name_1 : Field_Name_1_Type [:= default] +-- Field_Name_2 : Field_Name_2_Type [:= default] +-- ...) +-- return Node_Id + +-- Only syntactic fields are included (i.e. fields marked as "-Sem" or "-Lib" +-- in the Sinfo spec are excluded). In addition, the following four syntactic +-- fields are excluded: + +-- Prev_Ids +-- More_Ids +-- Comes_From_Source +-- Paren_Count + +-- since they are very rarely set in expanded code. If they need to be set, +-- to other than the default values (False, False, False, zero), then the +-- appropriate Set_xxx procedures must be used on the returned value. + +-- Default values are provided only for flag fields (where the default is +-- False), and for optional fields. An optional field is one where the +-- comment line describing the field contains the string "(set to xxx if". +-- For such fields, a default value of xxx is provided." + +-- Warning: since calls to Make_xxx routines are normal function calls, the +-- arguments can be evaluated in any order. This means that at most one such +-- argument can have side effects (e.g. be a call to a parse routine). + +!!TEMPLATE INSERTION POINT + +end Nmake; diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb new file mode 100644 index 000000000..0fea77d74 --- /dev/null +++ b/gcc/ada/opt.adb @@ -0,0 +1,321 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O P T -- +-- -- +-- 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 Gnatvsn; use Gnatvsn; +with System; use System; +with Tree_IO; use Tree_IO; + +package body Opt is + + SU : constant := Storage_Unit; + -- Shorthand for System.Storage_Unit + + ---------------------------------- + -- Register_Opt_Config_Switches -- + ---------------------------------- + + procedure Register_Opt_Config_Switches is + begin + Ada_Version_Config := Ada_Version; + Ada_Version_Explicit_Config := Ada_Version_Explicit; + Assertions_Enabled_Config := Assertions_Enabled; + Assume_No_Invalid_Values_Config := Assume_No_Invalid_Values; + Check_Policy_List_Config := Check_Policy_List; + Debug_Pragmas_Enabled_Config := Debug_Pragmas_Enabled; + Default_Pool_Config := Default_Pool; + Dynamic_Elaboration_Checks_Config := Dynamic_Elaboration_Checks; + Exception_Locations_Suppressed_Config := Exception_Locations_Suppressed; + Extensions_Allowed_Config := Extensions_Allowed; + External_Name_Exp_Casing_Config := External_Name_Exp_Casing; + External_Name_Imp_Casing_Config := External_Name_Imp_Casing; + Fast_Math_Config := Fast_Math; + Init_Or_Norm_Scalars_Config := Init_Or_Norm_Scalars; + Initialize_Scalars_Config := Initialize_Scalars; + Optimize_Alignment_Config := Optimize_Alignment; + Persistent_BSS_Mode_Config := Persistent_BSS_Mode; + Polling_Required_Config := Polling_Required; + Short_Descriptors_Config := Short_Descriptors; + Use_VADS_Size_Config := Use_VADS_Size; + + -- Reset the indication that Optimize_Alignment was set locally, since + -- if we had a pragma in the config file, it would set this flag True, + -- but that's not a local setting. + + Optimize_Alignment_Local := False; + end Register_Opt_Config_Switches; + + --------------------------------- + -- Restore_Opt_Config_Switches -- + --------------------------------- + + procedure Restore_Opt_Config_Switches (Save : Config_Switches_Type) is + begin + Ada_Version := Save.Ada_Version; + Ada_Version_Explicit := Save.Ada_Version_Explicit; + Assertions_Enabled := Save.Assertions_Enabled; + Assume_No_Invalid_Values := Save.Assume_No_Invalid_Values; + Check_Policy_List := Save.Check_Policy_List; + Debug_Pragmas_Enabled := Save.Debug_Pragmas_Enabled; + Default_Pool := Save.Default_Pool; + Dynamic_Elaboration_Checks := Save.Dynamic_Elaboration_Checks; + Exception_Locations_Suppressed := Save.Exception_Locations_Suppressed; + Extensions_Allowed := Save.Extensions_Allowed; + External_Name_Exp_Casing := Save.External_Name_Exp_Casing; + External_Name_Imp_Casing := Save.External_Name_Imp_Casing; + Fast_Math := Save.Fast_Math; + Init_Or_Norm_Scalars := Save.Init_Or_Norm_Scalars; + Initialize_Scalars := Save.Initialize_Scalars; + Optimize_Alignment := Save.Optimize_Alignment; + Optimize_Alignment_Local := Save.Optimize_Alignment_Local; + Persistent_BSS_Mode := Save.Persistent_BSS_Mode; + Polling_Required := Save.Polling_Required; + Short_Descriptors := Save.Short_Descriptors; + Use_VADS_Size := Save.Use_VADS_Size; + end Restore_Opt_Config_Switches; + + ------------------------------ + -- Save_Opt_Config_Switches -- + ------------------------------ + + procedure Save_Opt_Config_Switches (Save : out Config_Switches_Type) is + begin + Save.Ada_Version := Ada_Version; + Save.Ada_Version_Explicit := Ada_Version_Explicit; + Save.Assertions_Enabled := Assertions_Enabled; + Save.Assume_No_Invalid_Values := Assume_No_Invalid_Values; + Save.Check_Policy_List := Check_Policy_List; + Save.Debug_Pragmas_Enabled := Debug_Pragmas_Enabled; + Save.Default_Pool := Default_Pool; + Save.Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks; + Save.Exception_Locations_Suppressed := Exception_Locations_Suppressed; + Save.Extensions_Allowed := Extensions_Allowed; + Save.External_Name_Exp_Casing := External_Name_Exp_Casing; + Save.External_Name_Imp_Casing := External_Name_Imp_Casing; + Save.Fast_Math := Fast_Math; + Save.Init_Or_Norm_Scalars := Init_Or_Norm_Scalars; + Save.Initialize_Scalars := Initialize_Scalars; + Save.Optimize_Alignment := Optimize_Alignment; + Save.Optimize_Alignment_Local := Optimize_Alignment_Local; + Save.Persistent_BSS_Mode := Persistent_BSS_Mode; + Save.Polling_Required := Polling_Required; + Save.Short_Descriptors := Short_Descriptors; + Save.Use_VADS_Size := Use_VADS_Size; + end Save_Opt_Config_Switches; + + ----------------------------- + -- Set_Opt_Config_Switches -- + ----------------------------- + + procedure Set_Opt_Config_Switches + (Internal_Unit : Boolean; + Main_Unit : Boolean) + is + begin + -- Case of internal unit + + if Internal_Unit then + + -- Set standard switches. Note we do NOT set Ada_Version_Explicit + -- since the whole point of this is that it still properly indicates + -- the configuration setting even in a run time unit. + + Ada_Version := Ada_Version_Runtime; + Dynamic_Elaboration_Checks := False; + Extensions_Allowed := True; + External_Name_Exp_Casing := As_Is; + External_Name_Imp_Casing := Lowercase; + Optimize_Alignment := 'O'; + Persistent_BSS_Mode := False; + Use_VADS_Size := False; + Optimize_Alignment_Local := True; + + -- For an internal unit, assertions/debug pragmas are off unless this + -- is the main unit and they were explicitly enabled. We also make + -- sure we do not assume that values are necessarily valid. + + if Main_Unit then + Assertions_Enabled := Assertions_Enabled_Config; + Assume_No_Invalid_Values := Assume_No_Invalid_Values_Config; + Debug_Pragmas_Enabled := Debug_Pragmas_Enabled_Config; + Check_Policy_List := Check_Policy_List_Config; + else + Assertions_Enabled := False; + Assume_No_Invalid_Values := False; + Debug_Pragmas_Enabled := False; + Check_Policy_List := Empty; + end if; + + -- Case of non-internal unit + + else + Ada_Version := Ada_Version_Config; + Ada_Version_Explicit := Ada_Version_Explicit_Config; + Assertions_Enabled := Assertions_Enabled_Config; + Assume_No_Invalid_Values := Assume_No_Invalid_Values_Config; + Check_Policy_List := Check_Policy_List_Config; + Debug_Pragmas_Enabled := Debug_Pragmas_Enabled_Config; + Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks_Config; + Extensions_Allowed := Extensions_Allowed_Config; + External_Name_Exp_Casing := External_Name_Exp_Casing_Config; + External_Name_Imp_Casing := External_Name_Imp_Casing_Config; + Fast_Math := Fast_Math_Config; + Init_Or_Norm_Scalars := Init_Or_Norm_Scalars_Config; + Initialize_Scalars := Initialize_Scalars_Config; + Optimize_Alignment := Optimize_Alignment_Config; + Optimize_Alignment_Local := False; + Persistent_BSS_Mode := Persistent_BSS_Mode_Config; + Use_VADS_Size := Use_VADS_Size_Config; + end if; + + Default_Pool := Default_Pool_Config; + Exception_Locations_Suppressed := Exception_Locations_Suppressed_Config; + Fast_Math := Fast_Math_Config; + Optimize_Alignment := Optimize_Alignment_Config; + Polling_Required := Polling_Required_Config; + Short_Descriptors := Short_Descriptors_Config; + end Set_Opt_Config_Switches; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + Tree_Version_String_Len : Nat; + Ada_Version_Config_Val : Nat; + Ada_Version_Explicit_Config_Val : Nat; + Assertions_Enabled_Config_Val : Nat; + + begin + Tree_Read_Int (Tree_ASIS_Version_Number); + Tree_Read_Bool (Brief_Output); + Tree_Read_Bool (GNAT_Mode); + Tree_Read_Char (Identifier_Character_Set); + Tree_Read_Int (Maximum_File_Name_Length); + Tree_Read_Data (Suppress_Options'Address, + (Suppress_Options'Size + SU - 1) / SU); + Tree_Read_Bool (Verbose_Mode); + Tree_Read_Data (Warning_Mode'Address, + (Warning_Mode'Size + SU - 1) / SU); + Tree_Read_Int (Ada_Version_Config_Val); + Tree_Read_Int (Ada_Version_Explicit_Config_Val); + Tree_Read_Int (Assertions_Enabled_Config_Val); + Tree_Read_Bool (All_Errors_Mode); + Tree_Read_Bool (Assertions_Enabled); + Tree_Read_Int (Int (Check_Policy_List)); + Tree_Read_Bool (Debug_Pragmas_Enabled); + Tree_Read_Int (Int (Default_Pool)); + Tree_Read_Bool (Enable_Overflow_Checks); + Tree_Read_Bool (Full_List); + + Ada_Version_Config := + Ada_Version_Type'Val (Ada_Version_Config_Val); + Ada_Version_Explicit_Config := + Ada_Version_Type'Val (Ada_Version_Explicit_Config_Val); + Assertions_Enabled_Config := + Boolean'Val (Assertions_Enabled_Config_Val); + + -- Read version string: we have to get the length first + + Tree_Read_Int (Tree_Version_String_Len); + + declare + Tmp : String (1 .. Integer (Tree_Version_String_Len)); + begin + Tree_Read_Data + (Tmp'Address, Tree_Version_String_Len); + System.Strings.Free (Tree_Version_String); + Free (Tree_Version_String); + Tree_Version_String := new String'(Tmp); + end; + + Tree_Read_Data (Distribution_Stub_Mode'Address, + (Distribution_Stub_Mode'Size + SU - 1) / Storage_Unit); + Tree_Read_Bool (Inline_Active); + Tree_Read_Bool (Inline_Processing_Required); + Tree_Read_Bool (List_Units); + Tree_Read_Bool (Configurable_Run_Time_Mode); + Tree_Read_Data (Operating_Mode'Address, + (Operating_Mode'Size + SU - 1) / Storage_Unit); + Tree_Read_Bool (Suppress_Checks); + Tree_Read_Bool (Try_Semantics); + Tree_Read_Data (Wide_Character_Encoding_Method'Address, + (Wide_Character_Encoding_Method'Size + SU - 1) / SU); + Tree_Read_Bool (Upper_Half_Encoding); + Tree_Read_Bool (Force_ALI_Tree_File); + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + Version_String : String := Gnat_Version_String; + + begin + Tree_Write_Int (ASIS_Version_Number); + Tree_Write_Bool (Brief_Output); + Tree_Write_Bool (GNAT_Mode); + Tree_Write_Char (Identifier_Character_Set); + Tree_Write_Int (Maximum_File_Name_Length); + Tree_Write_Data (Suppress_Options'Address, + (Suppress_Options'Size + SU - 1) / SU); + Tree_Write_Bool (Verbose_Mode); + Tree_Write_Data (Warning_Mode'Address, + (Warning_Mode'Size + SU - 1) / Storage_Unit); + Tree_Write_Int (Ada_Version_Type'Pos (Ada_Version_Config)); + Tree_Write_Int (Ada_Version_Type'Pos (Ada_Version_Explicit_Config)); + Tree_Write_Int (Boolean'Pos (Assertions_Enabled_Config)); + Tree_Write_Bool (All_Errors_Mode); + Tree_Write_Bool (Assertions_Enabled); + Tree_Write_Int (Int (Check_Policy_List)); + Tree_Write_Bool (Debug_Pragmas_Enabled); + Tree_Write_Int (Int (Default_Pool)); + Tree_Write_Bool (Enable_Overflow_Checks); + Tree_Write_Bool (Full_List); + Tree_Write_Int (Int (Version_String'Length)); + Tree_Write_Data (Version_String'Address, Version_String'Length); + Tree_Write_Data (Distribution_Stub_Mode'Address, + (Distribution_Stub_Mode'Size + SU - 1) / SU); + Tree_Write_Bool (Inline_Active); + Tree_Write_Bool (Inline_Processing_Required); + Tree_Write_Bool (List_Units); + Tree_Write_Bool (Configurable_Run_Time_Mode); + Tree_Write_Data (Operating_Mode'Address, + (Operating_Mode'Size + SU - 1) / SU); + Tree_Write_Bool (Suppress_Checks); + Tree_Write_Bool (Try_Semantics); + Tree_Write_Data (Wide_Character_Encoding_Method'Address, + (Wide_Character_Encoding_Method'Size + SU - 1) / SU); + Tree_Write_Bool (Upper_Half_Encoding); + Tree_Write_Bool (Force_ALI_Tree_File); + end Tree_Write; + +end Opt; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads new file mode 100644 index 000000000..45a84cf2f --- /dev/null +++ b/gcc/ada/opt.ads @@ -0,0 +1,1907 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O P T -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains global flags set by the initialization routine from +-- the command line and referenced throughout the compiler, the binder, or +-- other GNAT tools. The comments indicate which options are used by which +-- programs (GNAT, GNATBIND, GNATLINK, GNATMAKE, GPRMAKE, etc). + +-- Some flags are labelled "PROJECT MANAGER". These are used by tools that +-- use the Project Manager. These tools include gnatmake, gnatname, the gnat +-- driver, gnatclean, gprbuild and gprclean. + +with Hostparm; use Hostparm; +with Types; use Types; + +pragma Warnings (Off); +-- This package is used also by gnatcoll +with System.Strings; use System.Strings; +with System.WCh_Con; use System.WCh_Con; +pragma Warnings (On); + +package Opt is + + ---------------------- + -- Checksum Control -- + ---------------------- + + -- Checksums are computed for sources to check for sources being the same + -- from a compilation point of view (e.g. spelling of identifiers and + -- white space layout do not count in this computation). + + -- The way the checksum is computed has evolved across the various versions + -- of GNAT. When gprbuild is called with -m, the checksums must be computed + -- the same way in gprbuild as it was in the GNAT version of the compiler. + -- The different ways are + + -- Version 6.4 and later: + + -- The Accumulate_Token_Checksum procedure is called after each numeric + -- literal and each identifier/keyword. For keywords, Tok_Identifier is + -- used in the call to Accumulate_Token_Checksum. + + -- Versions 5.04 to 6.3: + + -- For keywords, the token value were used in the call to procedure + -- Accumulate_Token_Checksum. Type Token_Type did not include Tok_Some. + + -- Versions 5.03: + + -- For keywords, the token value were used in the call to + -- Accumulate_Token_Checksum. Type Token_Type did not include + -- Tok_Interface, Tok_Overriding, Tok_Synchronized and Tok_Some. + + -- Versions 5.02 and before: + + -- No calls to procedure Accumulate_Token_Checksum (the checksum + -- mechanism was introduced in version 5.03). + + -- To signal to the scanner whether Accumulate_Token_Checksum needs to be + -- called and what versions to call, the following Boolean flags are used: + + Checksum_Accumulate_Token_Checksum : Boolean := True; + -- GPRBUILD + -- Set to False by gprbuild when the version of GNAT is 5.02 or before. If + -- this switch is False, then we do not call Accumulate_Token_Checksum, so + -- the setting of the following two flags is irrelevant. + + Checksum_GNAT_6_3 : Boolean := False; + -- GPRBUILD + -- Set to True by gprbuild when the version of GNAT is 6.3 or before. + + Checksum_GNAT_5_03 : Boolean := False; + -- GPRBUILD + -- Set to True by gprbuild when the version of GNAT is 5.03 or before. + + ---------------------------------------------- + -- Settings of Modes for Current Processing -- + ---------------------------------------------- + + -- The following mode values represent the current state of processing. + -- The values set here are the default values. Unless otherwise noted, + -- the value may be reset in Switch-? with an appropriate switch. In + -- some cases, the values can also be modified by pragmas, and in the + -- case of some binder variables, Gnatbind.Scan_Bind_Arg may modify + -- the default values. + + Ada_Bind_File : Boolean := True; + -- GNATBIND, GNATLINK + -- Set True if binder file to be generated in Ada rather than C + + type Ada_Version_Type is (Ada_83, Ada_95, Ada_2005, Ada_2012); + pragma Ordered (Ada_Version_Type); + -- Versions of Ada for Ada_Version below. Note that these are ordered, + -- so that tests like Ada_Version >= Ada_95 are legitimate and useful. + -- Think twice before using "="; Ada_Version >= Ada_2012 is more likely + -- what you want, because it will apply to future versions of the language. + + Ada_Version_Default : constant Ada_Version_Type := Ada_2005; + pragma Warnings (Off, Ada_Version_Default); + -- GNAT + -- Default Ada version if no switch given. The Warnings off is to kill + -- constant condition warnings. + -- + -- WARNING: some scripts rely on the format of this line of code. Any + -- change must be coordinated with the scripts requirements. + + Ada_Version : Ada_Version_Type := Ada_Version_Default; + -- GNAT + -- Current Ada version for compiler, as set by configuration pragmas, + -- compiler switches, or implicitly (to Ada_Version_Runtime) when a + -- predefined or internal file is compiled. + + Ada_Version_Explicit : Ada_Version_Type := Ada_Version_Default; + -- GNAT + -- Like Ada_Version, but does not get set implicitly for predefined + -- or internal units, so it reflects the Ada version explicitly set + -- using configuration pragmas or compiler switches (or if neither + -- appears, it remains set to Ada_Version_Default). This is used in + -- the rare cases (notably for pragmas Preelaborate_05 and Pure_05) + -- where in the run-time we want the explicit version set. + + Ada_Version_Runtime : Ada_Version_Type := Ada_2012; + -- GNAT + -- Ada version used to compile the runtime. Used to set Ada_Version (but + -- not Ada_Version_Explicit) when compiling predefined or internal units. + + Ada_Final_Suffix : constant String := "final"; + Ada_Final_Name : String_Ptr := new String'("ada" & Ada_Final_Suffix); + -- GNATBIND + -- The name of the procedure that performs the finalization at the end of + -- execution. This variable may be modified by Gnatbind.Scan_Bind_Arg. + + Ada_Init_Suffix : constant String := "init"; + Ada_Init_Name : String_Ptr := new String'("ada" & Ada_Init_Suffix); + -- GNATBIND + -- The name of the procedure that performs initialization at the start + -- of execution. This variable may be modified by Gnatbind.Scan_Bind_Arg. + + Ada_Main_Name_Suffix : constant String := "main"; + -- GNATBIND + -- The suffix for Ada_Main_Name. Defined as a constant here so that it + -- can be referenced in a uniform manner to create either the default + -- value of Ada_Main_Name (declared below), or the non-default name + -- set by Gnatbind.Scan_Bind_Arg. + + Ada_Main_Name : String_Ptr := new String'("ada_" & Ada_Main_Name_Suffix); + -- GNATBIND + -- The name of the Ada package generated by the binder (when in Ada mode). + -- This variable may be modified by Gnatbind.Scan_Bind_Arg. + + Address_Clause_Overlay_Warnings : Boolean := True; + -- GNAT + -- Set False to disable address clause warnings + + Address_Is_Private : Boolean := False; + -- GNAT, GNATBIND + -- Set True if package System has the line "type Address is private;" + + All_Errors_Mode : Boolean := False; + -- GNAT + -- Flag set to force display of multiple errors on a single line and + -- also repeated error messages for references to undefined identifiers + -- and certain other repeated error messages. Set by use of -gnatf. + + All_Sources : Boolean := False; + -- GNATBIND + -- Set to True to require all source files to be present. This flag is + -- directly modified by gnatmake to affect the shared binder routines. + + Alternate_Main_Name : String_Ptr := null; + -- GNATBIND + -- Set to non null when Bind_Alternate_Main_Name is True. This value + -- is modified as needed by Gnatbind.Scan_Bind_Arg. + + ASIS_Mode : Boolean := False; + -- GNAT + -- Enable semantic checks and tree transformations that are important + -- for ASIS but that are usually skipped if Operating_Mode is set to + -- Check_Semantics. This flag does not have the corresponding option to set + -- it ON. It is set ON when Tree_Output is set ON, it can also be set ON + -- from the code of GNSA-based tool (a client may need to set ON the + -- Back_Annotate_Rep_Info flag in this case. At the moment this does not + -- make very much sense, because GNSA cannot do back annotation). + + Assertions_Enabled : Boolean := False; + -- GNAT + -- Enable assertions made using pragma Assert + + Assume_No_Invalid_Values : Boolean := False; + -- GNAT + -- Normally, in accordance with (RM 13.9.1 (9-11)) the front end assumes + -- that values could have invalid representations, unless it can clearly + -- prove that the values are valid. If this switch is set (by -gnatB or by + -- pragma Assume_No_Invalid_Values (Off)), then the compiler assumes values + -- are valid and in range of their representations. This feature is now + -- fully enabled in the compiler. + + Back_Annotate_Rep_Info : Boolean := False; + -- GNAT + -- If set True, enables back annotation of representation information + -- by gigi, even in -gnatc mode. This is set True by the use of -gnatR + -- (list representation information) or -gnatt (generate tree). It is + -- also set true if certain Unchecked_Conversion instantiations require + -- checking based on annotated values. + + Back_End_Handles_Limited_Types : Boolean; + -- This flag is set true if the back end can properly handle limited or + -- other by reference types, and avoid copies. If this flag is False, then + -- the front end does special expansion for conditional expressions to make + -- sure that no copy occurs. If the flag is True, then the expansion for + -- conditional expressions relies on the back end properly handling things. + -- Currently the default is False for all cases (set in gnat1drv). The + -- default can be modified using -gnatd.L (sets the flag True). + + Bind_Alternate_Main_Name : Boolean := False; + -- GNATBIND + -- True if main should be called Alternate_Main_Name.all. + -- This variable may be set to True by Gnatbind.Scan_Bind_Arg. + + Bind_Main_Program : Boolean := True; + -- GNATBIND + -- Set to False if not binding main Ada program + + Bind_For_Library : Boolean := False; + -- GNATBIND + -- Set to True if the binder needs to generate a file designed for building + -- a library. May be set to True by Gnatbind.Scan_Bind_Arg. + + Bind_Only : Boolean := False; + -- GNATMAKE, GPRMAKE, GPRBUILD + -- Set to True to skip compile and link steps + -- (except when Compile_Only and/or Link_Only are True). + + Blank_Deleted_Lines : Boolean := False; + -- GNAT, GNATPREP + -- Output empty lines for each line of preprocessed input that is deleted + -- in the output, including preprocessor lines starting with a '#'. + + Brief_Output : Boolean := False; + -- GNAT, GNATBIND + -- Force brief error messages to standard error, even if verbose mode is + -- set (so that main error messages go to standard output). + + Build_Bind_And_Link_Full_Project : Boolean := False; + -- GNATMAKE + -- Set to True to build, bind and link all the sources of a project file + -- (switch -B) + + Check_Object_Consistency : Boolean := False; + -- GNATBIND, GNATMAKE + -- Set to True to check whether every object file is consistent with + -- its corresponding ada library information (ALI) file. An object + -- file is inconsistent with the corresponding ALI file if the object + -- file does not exist or if it has an older time stamp than the ALI file. + -- Default above is for GNATBIND. GNATMAKE overrides this default to + -- True (see Make.Initialize) since we normally do need to check source + -- consistencies in gnatmake. + + Check_Only : Boolean := False; + -- GNATBIND + -- Set to True to do checks only, no output of binder file + + Check_Policy_List : Node_Id := Empty; + -- GNAT + -- This points to the list of N_Pragma nodes for Check_Policy pragmas + -- that are linked through the Next_Pragma fields, with the list being + -- terminated by Empty. The order is most recently processed first. Note + -- that Push_Scope and Pop_Scope in Sem_Ch8 save and restore the value + -- of this variable, implementing the required scope control for pragmas + -- appearing a declarative part. + + Check_Readonly_Files : Boolean := False; + -- GNATMAKE + -- Set to True to check readonly files during the make process + + Check_Source_Files : Boolean := True; + -- GNATBIND, GNATMAKE + -- Set to True to enable consistency checking for any source files that + -- are present (i.e. date must match the date in the library info file). + -- Set to False for object file consistency check only. This flag is + -- directly modified by gnatmake, to affect the shared binder routines. + + Check_Switches : Boolean := False; + -- GNATMAKE, GPRMAKE, GPBUILD + -- Set to True to check compiler options during the make process + + Check_Unreferenced : Boolean := False; + -- GNAT + -- Set to True to enable checking for unreferenced entities other + -- than formal parameters (for which see Check_Unreferenced_Formals) + + Check_Unreferenced_Formals : Boolean := False; + -- GNAT + -- Set True to check for unreferenced formals. This is turned on by + -- -gnatwa/wf/wu and turned off by -gnatwA/wF/wU. + + Check_Withs : Boolean := False; + -- GNAT + -- Set to True to enable checking for unused withs, and also the case + -- of withing a package and using none of the entities in the package. + + CodePeer_Mode : Boolean := False; + -- GNAT + -- Enable full CodePeer mode (SCIL generation, disable switches that + -- interact badly with it, etc...). + + Commands_To_Stdout : Boolean := False; + -- GNATMAKE + -- True if echoed commands to be written to stdout instead of stderr + + Comment_Deleted_Lines : Boolean := False; + -- GNATPREP + -- True if source lines removed by the preprocessor should be commented + -- in the output file. + + Compile_Only : Boolean := False; + -- GNATMAKE, GNATCLEAN, GPRMAKE, GPBUILD, GPRCLEAN + -- GNATMAKE, GPRMAKE, GPRMAKE: + -- set to True to skip bind and link steps (except when Bind_Only is + -- True). + -- GNATCLEAN, GPRCLEAN: + -- set to True to delete only the files produced by the compiler but not + -- the library files or the executable files. + + Config_File : Boolean := True; + -- GNAT + -- Set to False to inhibit reading and processing of gnat.adc file + + Config_File_Names : String_List_Access := null; + -- GNAT + -- Names of configuration pragmas files (given by switches -gnatec) + + Configurable_Run_Time_Mode : Boolean := False; + -- GNAT, GNATBIND + -- Set True if the compiler is operating in configurable run-time mode. + -- This happens if the flag Targparm.Configurable_Run_TimeMode_On_Target + -- is set True, or if pragma No_Run_Time is used. See the spec of Rtsfind + -- for details on the handling of the latter pragma. + + Constant_Condition_Warnings : Boolean := False; + -- GNAT + -- Set to True to activate warnings on constant conditions + + Create_Mapping_File : Boolean := False; + -- GNATMAKE, GPRMAKE + -- Set to True (-C switch) to indicate that the compiler will be invoked + -- with a mapping file (-gnatem compiler switch). + + Debug_Pragmas_Enabled : Boolean := False; + -- GNAT + -- Enable debug statements from pragma Debug + + subtype Debug_Level_Value is Nat range 0 .. 3; + Debugger_Level : Debug_Level_Value := 0; + -- GNATBIND + -- The value given to the -g parameter. The default value for -g with + -- no value is 2. This is usually ignored by GNATBIND, except in the + -- VMS version where it is passed as an argument to __gnat_initialize + -- to trigger the activation of the remote debugging interface. + -- Is this still true ??? + + Debug_Generated_Code : Boolean := False; + -- GNAT + -- Set True (-gnatD switch) to debug generated expanded code instead + -- of the original source code. Causes debugging information to be + -- written with respect to the generated code file that is written. + + Default_Exit_Status : Int := 0; + -- GNATBIND + -- Set the default exit status value. Set by the -Xnnn switch for the + -- binder. + + Default_Stack_Size : Int := -1; + -- GNATBIND + -- Set to default primary stack size in units of bytes. Set by + -- the -dnnn switch for the binder. A value of -1 indicates that no + -- default was set by the binder. + + Default_Sec_Stack_Size : Int := -1; + -- GNATBIND + -- Set to default secondary stack size in units of bytes. Set by + -- the -Dnnn switch for the binder. A value of -1 indicates that no + -- default was set by the binder, and that the default should be the + -- initial value of System.Secondary_Stack.Default_Secondary_Stack_Size. + + Default_Pool : Node_Id := Empty; + -- GNAT + -- Used to record the storage pool name (or null literal) that is the + -- argument of an applicable pragma Default_Storage_Pool. + -- Empty: No pragma Default_Storage_Pool applies. + -- N_Null node: "pragma Default_Storage_Pool (null);" applies. + -- otherwise: "pragma Default_Storage_Pool (X);" applies, and + -- this points to the name X. + -- Push_Scope and Pop_Scope in Sem_Ch8 save and restore this value. + + Detect_Blocking : Boolean := False; + -- GNAT + -- Set True to force the run time to raise Program_Error if calls to + -- potentially blocking operations are detected from protected actions. + + Display_Compilation_Progress : Boolean := False; + -- GNATMAKE, GPRMAKE, GPRBUILD + -- Set True (-d switch) to display information on progress while compiling + -- files. Internal flag to be used in conjunction with an IDE (e.g GPS). + + type Distribution_Stub_Mode_Type is + -- GNAT + (No_Stubs, + -- Normal mode, no generation/compilation of distribution stubs + + Generate_Receiver_Stub_Body, + -- The unit being compiled is the RCI body, and the compiler will + -- generate the body for the receiver stubs and compile it. + + Generate_Caller_Stub_Body); + -- The unit being compiled is the RCI spec, and the compiler will + -- generate the body for the caller stubs and compile it. + + Distribution_Stub_Mode : Distribution_Stub_Mode_Type := No_Stubs; + -- GNAT + -- This enumeration variable indicates the five states of distribution + -- annex stub generation/compilation. + + Do_Not_Execute : Boolean := False; + -- GNATMAKE + -- Set to True if no actual compilations should be undertaken. + + Dump_Source_Text : Boolean := False; + -- GNAT + -- Set to True (by -gnatL) to dump source text intermingled with generated + -- code. Effective only if either of Debug/Print_Generated_Code is true. + + Dynamic_Elaboration_Checks : Boolean := False; + -- GNAT + -- Set True for dynamic elaboration checking mode, as set by the -gnatE + -- switch or by the use of pragma Elaboration_Checks (Dynamic). + + Dynamic_Stack_Measurement : Boolean := False; + -- GNATBIND + -- Set True to enable dynamic stack measurement (-u flag for gnatbind) + + Dynamic_Stack_Measurement_Array_Size : Nat := 100; + -- GNATBIND + -- Number of measurements we want to store during dynamic stack analysis. + -- When the buffer is full, non-storable results will be output on the fly. + -- The value is relevant only if Dynamic_Stack_Measurement is set. Set + -- by processing of -u flag for gnatbind. + + Elab_Dependency_Output : Boolean := False; + -- GNATBIND + -- Set to True to output complete list of elaboration constraints + + Elab_Order_Output : Boolean := False; + -- GNATBIND + -- Set to True to output chosen elaboration order + + Elab_Warnings : Boolean := False; + -- GNAT + -- Set to True to generate full elaboration warnings (-gnatwl) + + Enable_Overflow_Checks : Boolean := False; + -- GNAT + -- Set to True if -gnato (enable overflow checks) switch is set, + -- but not -gnatp. + + Error_Msg_Line_Length : Nat := 0; + -- GNAT + -- Records the error message line length limit. If this is set to zero, + -- then we get the old style behavior, in which each call to the error + -- message routines generates one line of output as a separate message. + -- If it is set to a non-zero value, then continuation lines are folded + -- to make a single long message, and then this message is split up into + -- multiple lines not exceeding the specified length. Set by -gnatj=nn. + + Exception_Handler_Encountered : Boolean := False; + -- GNAT + -- This flag is set true if the parser encounters an exception handler. + -- It is used to set Warn_On_Exception_Propagation True if the restriction + -- No_Exception_Propagation is set. + + Exception_Extra_Info : Boolean := False; + -- GNAT + -- True when switch -gnateE is used. When True, generate extra information + -- associated with exception messages (in particular range and index + -- checks). + + Exception_Locations_Suppressed : Boolean := False; + -- GNAT + -- Set to True if a Suppress_Exception_Locations configuration pragma is + -- currently active. + + type Exception_Mechanism_Type is + -- Determines the handling of exceptions. See Exp_Ch11 for details + -- + (Front_End_Setjmp_Longjmp_Exceptions, + -- Exceptions use setjmp/longjmp generated explicitly by the + -- front end (this includes gigi or other equivalent parts of + -- the code generator). AT END handlers are converted into + -- exception handlers by the front end in this mode. + + Back_End_Exceptions); + -- Exceptions are handled by the back end. The front end simply + -- generates the handlers as they appear in the source, and AT + -- END handlers are left untouched (they are not converted into + -- exception handlers when operating in this mode. + pragma Convention (C, Exception_Mechanism_Type); + + Exception_Mechanism : Exception_Mechanism_Type := + Front_End_Setjmp_Longjmp_Exceptions; + -- GNAT + -- Set to the appropriate value depending on the default as given in + -- system.ads (ZCX_By_Default, GCC_ZCX_Support). The C convention is there + -- to make this variable accessible to gigi. + + Exception_Tracebacks : Boolean := False; + -- GNATBIND + -- Set to True to store tracebacks in exception occurrences (-E) + + Extensions_Allowed : Boolean := False; + -- GNAT + -- Set to True by switch -gnatX if GNAT specific language extensions + -- are allowed. For example, the use of 'Constrained with objects of + -- generic types is a GNAT extension. + + type External_Casing_Type is ( + As_Is, -- External names cased as they appear in the Ada source + Uppercase, -- External names forced to all uppercase letters + Lowercase); -- External names forced to all lowercase letters + + External_Name_Imp_Casing : External_Casing_Type := Lowercase; + -- GNAT + -- The setting of this flag determines the casing of external names + -- when the name is implicitly derived from an entity name (i.e. either + -- no explicit External_Name or Link_Name argument is used, or, in the + -- case of extended DEC pragmas, the external name is given using an + -- identifier. The As_Is setting is not permitted here (since this would + -- create Ada source programs that were case sensitive). + + External_Name_Exp_Casing : External_Casing_Type := As_Is; + -- GNAT + -- The setting of this flag determines the casing of an external name + -- specified explicitly with a string literal. As_Is means the string + -- literal is used as given with no modification to the casing. If + -- Lowercase or Uppercase is set, then the string is forced to all + -- lowercase or all uppercase letters as appropriate. Note that this + -- setting has no effect if the external name is given using an identifier + -- in the case of extended DEC import/export pragmas (in this case the + -- casing is controlled by External_Name_Imp_Casing), and also has no + -- effect if an explicit Link_Name is supplied (a link name is always + -- used exactly as given). + + External_Unit_Compilation_Allowed : Boolean := False; + -- GNATMAKE + -- When True (set by gnatmake switch -x), allow compilation of sources + -- that are not part of any project file. + + Fast_Math : Boolean := False; + -- GNAT + -- Indicates the current setting of Fast_Math mode, as set by the use + -- of a Fast_Math pragma (set on by Fast_Math (On)). + + Float_Format : Character := ' '; + -- GNAT + -- A non-blank value indicates that a Float_Format pragma has been + -- processed, in which case this variable is set to 'I' for IEEE or + -- to 'V' for VAX. The setting of 'V' is only possible on OpenVMS + -- versions of GNAT. + + Float_Format_Long : Character := ' '; + -- GNAT + -- A non-blank value indicates that a Long_Float pragma has been + -- processed (this pragma is recognized only in OpenVMS versions + -- of GNAT), in which case this variable is set to D or G for + -- D_Float or G_Float. + + Force_ALI_Tree_File : Boolean := False; + -- GNAT + -- Force generation of ALI file even if errors are encountered. + -- Also forces generation of tree file if -gnatt is also set. + + Force_Checking_Of_Elaboration_Flags : Boolean := False; + -- GNATBIND + -- True if binding with forced checking of the elaboration flags + -- (-F switch set). + + Force_Compilations : Boolean := False; + -- GNATMAKE, GPRMAKE, GPRBUILD + -- Set to force recompilations even when the objects are up-to-date. + + Full_Path_Name_For_Brief_Errors : Boolean := False; + -- PROJECT MANAGER + -- When True, in Brief_Output mode, each error message line + -- will start with the full path name of the source. + -- When False, only the file name without directory information + -- is used. + + Full_List : Boolean := False; + -- GNAT + -- Set True to generate full source listing with embedded errors + + Full_List_File_Name : String_Ptr := null; + -- GNAT + -- Set to file name to generate full source listing to named file (or if + -- the name is of the form .xxx, then to name.xxx where name is the source + -- file name with extension stripped. + + Generate_Processed_File : Boolean := False; + -- GNAT + -- True when switch -gnateG is used. When True, create in a file + -- .prep, if the source is preprocessed. + + Generate_SCO : Boolean := False; + -- GNAT + -- True when switch -gnateS is used. When True, Source Coverage Obligation + -- (SCO) information is generated and output in the ALI file. See unit + -- Par_SCO for full details. + + Generating_Code : Boolean := False; + -- GNAT + -- True if the frontend finished its work and has called the backend to + -- process the tree and generate the object file. + + Global_Discard_Names : Boolean := False; + -- GNAT, GNATBIND + -- True if a pragma Discard_Names appeared as a configuration pragma for + -- the current compilation unit. + + GNAT_Mode : Boolean := False; + -- GNAT + -- True if compiling in GNAT system mode (-gnatg switch) + + Heap_Size : Nat := 0; + -- GNATBIND + -- Heap size for memory allocations. Valid values are 32 and 64. Only + -- available on VMS. + + HLO_Active : Boolean := False; + -- GNAT + -- True if High Level Optimizer is activated (-gnatH switch) + + Identifier_Character_Set : Character; + -- GNAT + -- This variable indicates the character set to be used for identifiers. + -- The possible settings are: + -- '1' Latin-5 (ISO-8859-1) + -- '2' Latin-5 (ISO-8859-2) + -- '3' Latin-5 (ISO-8859-3) + -- '4' Latin-5 (ISO-8859-4) + -- '5' Latin-5 (ISO-8859-5, Cyrillic) + -- '9' Latin-5 (ISO-8859-9) + -- 'p' PC (US, IBM page 437) + -- '8' PC (European, IBM page 850) + -- 'f' Full upper set (all distinct) + -- 'n' No upper characters (Ada 83 rules) + -- 'w' Latin-1 plus wide characters allowed in identifiers + -- + -- The setting affects the set of letters allowed in identifiers and the + -- upper/lower case equivalences. It does not affect the interpretation of + -- character and string literals, which are always stored using the actual + -- coding in the source program. This variable is initialized to the + -- default value appropriate to the system (in Osint.Initialize), and then + -- reset if a command line switch is used to change the setting. + + Ignore_Rep_Clauses : Boolean := False; + -- GNAT + -- Set True to ignore all representation clauses. Useful when compiling + -- code from foreign compilers for checking or ASIS purposes. Can be + -- set True by use of -gnatI. + + Implementation_Unit_Warnings : Boolean := True; + -- GNAT + -- Set True to active warnings for use of implementation internal units. + -- Can be controlled by use of -gnatwi/-gnatwI. + + Implicit_Packing : Boolean := False; + -- GNAT + -- If set True, then a Size attribute clause on an array is allowed to + -- cause implicit packing instead of generating an error message. Set by + -- use of pragma Implicit_Packing. + + Ineffective_Inline_Warnings : Boolean := False; + -- GNAT + -- Set True to activate warnings if front-end inlining (-gnatN) is not + -- able to actually inline a particular call (or all calls). Can be + -- controlled by use of -gnatwp/-gnatwP. + + Init_Or_Norm_Scalars : Boolean := False; + -- GNAT, GANTBIND + -- Set True if a pragma Initialize_Scalars applies to the current unit. + -- Also set True if a pragma Normalize_Scalars applies. + + Initialize_Scalars : Boolean := False; + -- GNAT + -- Set True if a pragma Initialize_Scalars applies to the current unit. + -- Note that Init_Or_Norm_Scalars is also set to True if this is True. + + Initialize_Scalars_Mode1 : Character := 'I'; + Initialize_Scalars_Mode2 : Character := 'N'; + -- GNATBIND + -- Set to two characters from -S switch (IN/LO/HI/EV/xx). The default + -- is IN (invalid values), used if no -S switch is used. + + Inline_Active : Boolean := False; + -- GNAT + -- Set True to activate pragma Inline processing across modules. Default + -- for now is not to inline across module boundaries. + + Interface_Library_Unit : Boolean := False; + -- GNATBIND + -- Set to True to indicate that at least one ALI file is an interface ALI: + -- then elaboration flag checks are to be generated in the binder + -- generated file. + + Generate_SCIL : Boolean := False; + -- GNAT + -- Set True to activate SCIL code generation. + + Invalid_Value_Used : Boolean := False; + -- GNAT + -- Set True if a valid Invalid_Value attribute is encountered + + Follow_Links_For_Files : Boolean := False; + -- PROJECT MANAGER + -- Set to True (-eL) to process the project files in trusted mode. If + -- Follow_Links is False, it is assumed that the project doesn't contain + -- any file duplicated through symbolic links (although the latter are + -- still valid if they point to a file which is outside of the project), + -- and that no directory has a name which is a valid source name. + + Follow_Links_For_Dirs : Boolean := False; + -- PROJECT MANAGER + -- Set to True if directories can be links in this project, and therefore + -- additional system calls must be performed to ensure that we always see + -- the same full name for each directory. + + Front_End_Inlining : Boolean := False; + -- GNAT + -- Set True to activate inlining by front-end expansion + + Inline_Processing_Required : Boolean := False; + -- GNAT + -- Set True if inline processing is required. Inline processing is required + -- if an active Inline pragma is processed. The flag is set for a pragma + -- Inline or Inline_Always that is actually active. + + In_Place_Mode : Boolean := False; + -- GNATMAKE + -- Set True to store ALI and object files in place i.e. in the object + -- directory if these files already exist or in the source directory + -- if not. + + Keep_Going : Boolean := False; + -- GNATMAKE, GPRMAKE, GPRBUILD + -- When True signals to ignore compilation errors and keep processing + -- sources until there is no more work. + + Keep_Temporary_Files : Boolean := False; + -- GNATCMD + -- When True the temporary files created by the GNAT driver are not + -- deleted. Set by switch -dn or qualifier /KEEP_TEMPORARY_FILES. + + Leap_Seconds_Support : Boolean := False; + -- GNATBIND + -- Set to True to enable leap seconds support in Ada.Calendar and its + -- children. + + Link_Only : Boolean := False; + -- GNATMAKE, GPRMAKE, GPRBUILD + -- Set to True to skip compile and bind steps (except when Bind_Only is + -- set to True). + + List_Inherited_Aspects : Boolean := True; + -- GNAT + -- List inherited invariants, preconditions, and postconditions from + -- Invariant'Class, Pre'Class, and Post'Class aspects. + + List_Restrictions : Boolean := False; + -- GNATBIND + -- Set to True to list restrictions pragmas that could apply to partition + + List_Units : Boolean := False; + -- GNAT + -- List units in the active library for a compilation (-gnatu switch) + + List_Closure : Boolean := False; + -- GNATBIND + -- List all sources in the closure of a main (-R gnatbind switch) + + List_Dependencies : Boolean := False; + -- GNATMAKE + -- When True gnatmake verifies that the objects are up to date and + -- outputs the list of object dependencies (-M switch). + -- Output depends if -a switch is used or not. + -- This list can be used directly in a Makefile. + + List_Representation_Info : Int range 0 .. 3 := 0; + -- GNAT + -- Set non-zero by -gnatR switch to list representation information. + -- The settings are as follows: + -- + -- 0 = no listing of representation information (default as above) + -- 1 = list rep info for user defined record and array types + -- 2 = list rep info for all user defined types and objects + -- 3 = like 2, but variable fields are decoded symbolically + + List_Representation_Info_To_File : Boolean := False; + -- GNAT + -- Set true by -gnatRs switch. Causes information from -gnatR/1/2/3 to be + -- written to file.rep (where file is the name of the source file) instead + -- of stdout. For example, if file x.adb is compiled using -gnatR2s then + -- representation info is written to x.adb.ref. + + List_Representation_Info_Mechanisms : Boolean := False; + -- GNAT + -- Set true by -gnatRm switch. Causes information on mechanisms to be + -- included in the representation output information. + + List_Preprocessing_Symbols : Boolean := False; + -- GNAT, GNATPREP + -- Set to True if symbols for preprocessing a source are to be listed + -- before preprocessing occurs. Set to True by switch -s of gnatprep or + -- -s in preprocessing data file for the compiler. + + type Create_Repinfo_File_Proc is access procedure (Src : String); + type Write_Repinfo_Line_Proc is access procedure (Info : String); + type Close_Repinfo_File_Proc is access procedure; + -- Types used for procedure addresses below + + Create_Repinfo_File_Access : Create_Repinfo_File_Proc := null; + Write_Repinfo_Line_Access : Write_Repinfo_Line_Proc := null; + Close_Repinfo_File_Access : Close_Repinfo_File_Proc := null; + -- GNAT + -- These three locations are left null when operating in non-compiler (e.g. + -- ASIS mode), but when operating in compiler mode, they are set to point + -- to the three corresponding procedures in Osint-C. The reason for this + -- slightly strange interface is to stop Repinfo from dragging in Osint in + -- ASIS mode, which would include lots of unwanted units in the ASIS build. + + type Create_List_File_Proc is access procedure (S : String); + type Write_List_Info_Proc is access procedure (S : String); + type Close_List_File_Proc is access procedure; + -- Types used for procedure addresses below + + Create_List_File_Access : Create_List_File_Proc := null; + Write_List_Info_Access : Write_List_Info_Proc := null; + Close_List_File_Access : Close_List_File_Proc := null; + -- GNAT + -- These three locations are left null when operating in non-compiler + -- (e.g. from the binder), but when operating in compiler mode, they are + -- set to point to the three corresponding procedures in Osint-C. The + -- reason for this slightly strange interface is to prevent Repinfo + -- from dragging in Osint-C in the binder, which would include unwanted + -- units in the binder. + + Locking_Policy : Character := ' '; + -- GNAT, GNATBIND + -- Set to ' ' for the default case (no locking policy specified). Reset to + -- first character (uppercase) of locking policy name if a valid pragma + -- Locking_Policy is encountered. + + Locking_Policy_Sloc : Source_Ptr := No_Location; + -- GNAT, GNATBIND + -- Remember location of previous Locking_Policy pragma. This is used for + -- inconsistency error messages. A value of System_Location is used if the + -- policy is set in package System. + + Look_In_Primary_Dir : Boolean := True; + -- GNAT, GNATBIND, GNATMAKE, GNATCLEAN + -- Set to False if a -I- was present on the command line. When True we are + -- allowed to look in the primary directory to locate other source or + -- library files. + + Make_Steps : Boolean := False; + -- GNATMAKE + -- Set to True when either Compile_Only, Bind_Only or Link_Only is + -- set to True. + + Main_Index : Int := 0; + -- GNATMAKE + -- This is set to non-zero by gnatmake switch -eInnn to indicate that + -- the main program is the nnn unit in a multi-unit source file. + + Mapping_File_Name : String_Ptr := null; + -- GNAT + -- File name of mapping between unit names, file names and path names. + -- (given by switch -gnatem) + + Maximum_Messages : Int := 9999; + -- GNAT, GNATBIND + -- Maximum default number of errors before compilation is terminated, or in + -- the case of GNAT, maximum number of warnings before further warnings are + -- suppressed. Can be overridden by -gnatm (GNAT) or -m (GNATBIND) switch. + + Maximum_File_Name_Length : Int; + -- GNAT, GNATBIND + -- Maximum number of characters allowed in a file name, not counting the + -- extension, as set by the appropriate switch. If no switch is given, + -- then this value is initialized by Osint to the appropriate value. + + Maximum_Processes : Positive := 1; + -- GNATMAKE, GPRMAKE, GPRBUILD + -- Maximum number of processes that should be spawned to carry out + -- compilations. + + Minimal_Recompilation : Boolean := False; + -- GNATMAKE + -- Set to True if minimal recompilation mode requested + + Special_Exception_Package_Used : Boolean := False; + -- GNAT + -- Set to True if either of the unit GNAT.Most_Recent_Exception or + -- GNAT.Exception_Traces is with'ed. Used to inhibit transformation of + -- local raise statements into gotos in the presence of either package. + + Multiple_Unit_Index : Int; + -- GNAT + -- This is set non-zero if the current unit is being compiled in multiple + -- unit per file mode, meaning that the current unit is selected from the + -- sequence of units in the current source file, using the value stored + -- in this variable (e.g. 2 = select second unit in file). A value of + -- zero indicates that we are in normal (one unit per file) mode. + + No_Main_Subprogram : Boolean := False; + -- GNATMAKE, GNATBIND + -- Set to True if compilation/binding of a program without main + -- subprogram requested. + + No_Run_Time_Mode : Boolean := False; + -- GNAT, GNATBIND + -- This flag is set True if a No_Run_Time pragma is encountered. See + -- spec of Rtsfind for a full description of handling of this pragma. + + No_Split_Units : Boolean := False; + -- GPRBUILD + -- Set to True with switch --no-split-units. When True, unit sources, spec, + -- body and subunits, must all be in the same project.This is checked after + -- each compilation. + + No_Stdinc : Boolean := False; + -- GNAT, GNATBIND, GNATMAKE, GNATFIND, GNATXREF + -- Set to True if no default source search dirs added to search list + + No_Stdlib : Boolean := False; + -- GNATMAKE, GNATBIND, GNATFIND, GNATXREF + -- Set to True if no default library search dirs added to search list + + No_Strict_Aliasing : Boolean := False; + -- GNAT + -- Set True if pragma No_Strict_Aliasing with no parameters encountered + + Normalize_Scalars : Boolean := False; + -- GNAT, GNATBIND + -- Set True if a pragma Normalize_Scalars applies to the current unit. + -- Note that Init_Or_Norm_Scalars is also set to True if this is True. + + Object_Directory_Present : Boolean := False; + -- GNATMAKE + -- Set to True when an object directory is specified with option -D + + One_Compilation_Per_Obj_Dir : Boolean := False; + -- GNATMAKE, GPRBUILD + -- Set to True with switch --single-compile-per-obj-dir. When True, there + -- cannot be simultaneous compilations with the object files in the same + -- object directory, if project files are used. + + type Operating_Mode_Type is (Check_Syntax, Check_Semantics, Generate_Code); + Operating_Mode : Operating_Mode_Type := Generate_Code; + -- GNAT + -- Indicates the operating mode of the compiler. The default is generate + -- code, which runs the parser, semantics and backend. Switches can be + -- used to set syntax checking only mode, or syntax and semantics checking + -- only mode. Operating_Mode can also be modified as a result of detecting + -- errors during the compilation process. In particular if any serious + -- error is detected then this flag is reset from Generate_Code to + -- Check_Semantics after generating an error message. + + Optimize_Alignment : Character := 'O'; + -- Setting of Optimize_Alignment, set to T/S/O for time/space/off. Can + -- be modified by use of pragma Optimize_Alignment. + + Optimize_Alignment_Local : Boolean := False; + -- Set True if Optimize_Alignment mode is set by a local configuration + -- pragma that overrides the gnat.adc (or other configuration file) default + -- so that the unit is not dependent on the default setting. Also always + -- set True for internal units, since these always have a default setting + -- of Optimize_Alignment (Off) that is enforced (essentially equivalent to + -- them all having such an explicit pragma in each unit). + + Original_Operating_Mode : Operating_Mode_Type := Generate_Code; + -- GNAT + -- Indicates the original operating mode of the compiler as set by compiler + -- options. This is identical to Operating_Mode except that this is not + -- affected by errors. + + Optimization_Level : Int; + pragma Import (C, Optimization_Level, "optimize"); + -- Constant reflecting the optimization level (0,1,2,3 for -O0,-O1,-O2,-O3) + -- See jmissing.c and aamissing.c for definitions for dotnet/jgnat and + -- GNAAMP back ends. + + Optimize_Size : Int; + pragma Import (C, Optimize_Size, "optimize_size"); + -- Constant reflecting setting of -Os (optimize for size). Set to nonzero + -- in -Os mode and set to zero otherwise. See jmissing.c and aamissing.c + -- for definitions of "optimize_size" for dotnet/jgnat and GNAAMP backends + + Output_File_Name_Present : Boolean := False; + -- GNATBIND, GNAT, GNATMAKE, GPRMAKE + -- Set to True when the output C file name is given with option -o for + -- GNATBIND, when the object file name is given with option -gnatO for GNAT + -- or when the executable is given with option -o for GNATMAKE or GPRMAKE. + + Output_Linker_Option_List : Boolean := False; + -- GNATBIND + -- True if output of list of linker options is requested (-K switch set) + + Output_ALI_List : Boolean := False; + ALI_List_Filename : String_Ptr; + -- GNATBIND + -- True if output of list of ALIs is requested (-A switch set). List is + -- output under the given filename, or standard output if not specified. + + Output_Object_List : Boolean := False; + Object_List_Filename : String_Ptr; + -- GNATBIND + -- True if output of list of objects is requested (-O switch set). List is + -- output under the given filename, or standard output if not specified. + + Overflow_Checks_Unsuppressed : Boolean := False; + -- GNAT + -- Set to True if at least one occurrence of pragma Unsuppress + -- (All_Checks|Overflow_Checks) has been processed. + + Persistent_BSS_Mode : Boolean := False; + -- GNAT + -- True if a Persistent_BSS configuration pragma is in effect, causing + -- potentially persistent data to be placed in the persistent_bss section. + + Pessimistic_Elab_Order : Boolean := False; + -- GNATBIND + -- True if pessimistic elaboration order is to be chosen (-p switch set) + + Polling_Required : Boolean := False; + -- GNAT + -- Set to True if polling for asynchronous abort is enabled by using + -- the -gnatP option for GNAT. + + Preprocessing_Data_File : String_Ptr := null; + -- GNAT + -- Set by switch -gnatep=. The file name of the preprocessing data file. + + Print_Generated_Code : Boolean := False; + -- GNAT + -- Set to True to enable output of generated code in source form. This + -- flag is set by the -gnatG switch. + + Print_Standard : Boolean := False; + -- GNAT + -- Set to true to enable printing of package standard in source form. + -- This flag is set by the -gnatS switch + + Propagate_Exceptions : Boolean := False; + -- GNAT + -- Indicates if subprogram descriptor exception tables should be + -- built for imported subprograms. Set True if a Propagate_Exceptions + -- pragma applies to the extended main unit. + + type Usage is (Unknown, Not_In_Use, In_Use); + Project_File_In_Use : Usage := Unknown; + -- GNAT + -- Indicates if a project file is used or not. Set to In_Use by the first + -- SFNP pragma. + + Queuing_Policy : Character := ' '; + -- GNAT, GNATBIND + -- Set to ' ' for the default case (no queuing policy specified). Reset to + -- first character (uppercase) of locking policy name if a valid + -- Queuing_Policy pragma is encountered. + + Queuing_Policy_Sloc : Source_Ptr := No_Location; + -- GNAT, GNATBIND + -- Remember location of previous Queuing_Policy pragma. This is used for + -- inconsistency error messages. A value of System_Location is used if the + -- policy is set in package System. + + Quiet_Output : Boolean := False; + -- GNATMAKE, GNATCLEAN, GPRMAKE, GPRBUILD, GPRCLEAN + -- Set to True if the tool should not have any output if there are no + -- errors or warnings. + + Replace_In_Comments : Boolean := False; + -- GNATPREP + -- Set to True if -C switch used + + RTS_Lib_Path_Name : String_Ptr := null; + RTS_Src_Path_Name : String_Ptr := null; + -- GNAT + -- Set to the "adalib" and "adainclude" directories of the run time + -- specified by --RTS=. + + RTS_Switch : Boolean := False; + -- GNAT, GNATMAKE, GNATBIND, GNATLS, GNATFIND, GNATXREF + -- Set to True when the --RTS switch is set + + Run_Path_Option : Boolean := True; + -- GNATMAKE, GNATLINK + -- Set to False when no run_path_option should be issued to the linker + + Search_Directory_Present : Boolean := False; + -- GNAT + -- Set to True when argument is -I. Reset to False when next argument, a + -- search directory path is taken into account. Note that this is quite + -- different from other switches in this section in that it is only set in + -- a transitory manner as a result of scanning a -I switch with no file + -- name, and if set, is an indication that the next argument is to be + -- treated as a file name. + + Sec_Stack_Used : Boolean := False; + -- GNAT, GBATBIND + -- Set True if generated code uses the System.Secondary_Stack package. For + -- the binder, set if any unit uses the secondary stack package. + + Setup_Projects : Boolean := False; + -- GNAT DRIVER + -- Set to True for GNAT SETUP: the Project Manager creates non existing + -- object, library and exec directories. + + Shared_Libgnat : Boolean; + -- GNATBIND + -- Set to True if a shared libgnat is requested by using the -shared option + -- for GNATBIND and to False when using the -static option. The value of + -- this flag is set by Gnatbind.Scan_Bind_Arg. + + Short_Circuit_And_Or : Boolean := False; + -- GNAT + -- Set True if a pragma Short_Circuit_And_Or applies to the current unit. + + Short_Descriptors : Boolean := False; + -- GNAT + -- Set True if a pragma Short_Descriptors applies to the current unit. + + Sprint_Line_Limit : Nat := 72; + -- GNAT + -- Limit values for chopping long lines in Sprint output, can be reset + -- by use of NNN parameter with -gnatG or -gnatD switches. + + Stack_Checking_Enabled : Boolean; + -- GNAT + -- Set to indicate if -fstack-check switch is set for the compilation. True + -- means that the switch is set, so that stack checking is enabled. False + -- means that the switch is not set (no stack checking). This value is + -- obtained from the external imported value flag_stack_check in the gcc + -- backend (see Frontend) and may be referenced throughout the compilation + -- phases. + + Style_Check : Boolean := False; + -- GNAT + -- Set True to perform style checks. Activates checks carried out in + -- package Style (see body of this package for details of checks) This + -- flag is set True by either the -gnatg or -gnaty switches. + + Suppress_All_Inlining : Boolean := False; + -- GNAT + -- Set by -fno-inline. Suppresses all inlining, both front end and back end + -- regardless of any other switches that are set. + + Suppress_Control_Flow_Optimizations : Boolean := False; + -- GNAT + -- Set by -fpreserve-control-flow. Suppresses control flow optimizations + -- that interfere with coverage analysis based on the object code. + + System_Extend_Pragma_Arg : Node_Id := Empty; + -- GNAT + -- Set non-empty if and only if a correct Extend_System pragma was present + -- in which case it points to the argument of the pragma, and the name can + -- be located as Chars (Expression (System_Extend_Pragma_Arg)). + + System_Extend_Unit : Node_Id := Empty; + -- GNAT + -- This is set to Empty if GNAT_Mode is set, since pragma Extend_System + -- is never appropriate in GNAT_Mode (and causes troubles, including + -- bogus circularities, if we try to compile the run-time library with + -- a System extension). If GNAT_Mode is not set, then System_Extend_Unit + -- is a copy of the value set in System_Extend_Pragma_Arg. + + Subunits_Missing : Boolean := False; + -- GNAT + -- This flag is set true if missing subunits are detected with code + -- generation active. This causes code generation to be skipped. + + Suppress_Checks : Boolean := False; + -- GNAT + -- Set to True if -gnatp (suppress all checks) switch present. + + Suppress_Options : Suppress_Array; + -- GNAT + -- Flags set True to suppress corresponding check, i.e. add an implicit + -- pragma Suppress at the outer level of each unit compiled. Note that + -- these suppress actions can be overridden by the use of the Unsuppress + -- pragma. This variable is initialized by Osint.Initialize. + + Suppress_Back_Annotation : Boolean := False; + -- GNAT + -- This flag is set True if back annotation of representation information + -- is to be suppressed. This is set if neither -gnatt or -gnatR0-3 is set. + -- This avoids unnecessary time being spent on back annotation. + + Table_Factor : Int := 1; + -- GNAT + -- Factor by which all initial table sizes set in Alloc are multiplied. + -- Used in Table to calculate initial table sizes (the initial table size + -- is the value in Alloc, used as the Table_Initial parameter value, + -- multiplied by the factor given here. The default value is used if no + -- -gnatT switch appears. + + Tagged_Type_Expansion : Boolean := True; + -- GNAT + -- Set True if tagged types and interfaces should be expanded by the + -- front-end. If False, the original tree is left unexpanded for tagged + -- types and dispatching calls, assuming the underlying target supports + -- it (e.g. in the JVM case). + + Task_Dispatching_Policy : Character := ' '; + -- GNAT, GNATBIND + -- Set to ' ' for the default case (no task dispatching policy specified). + -- Reset to first character (uppercase) of task dispatching policy name + -- if a valid Task_Dispatching_Policy pragma is encountered. + + Task_Dispatching_Policy_Sloc : Source_Ptr := No_Location; + -- GNAT, GNATBIND + -- Remember location of previous Task_Dispatching_Policy pragma. This is + -- used for inconsistency error messages. A value of System_Location is + -- used if the policy is set in package System. + + Tasking_Used : Boolean := False; + -- Set True if any tasking construct is encountered. Used to activate the + -- output of the Q, L and T lines in ALI files. + + Time_Slice_Set : Boolean := False; + -- GNATBIND + -- Set True if a pragma Time_Slice is processed in the main unit, or + -- if the -gnatTnn switch is present to set a time slice value. + + Time_Slice_Value : Nat; + -- GNATBIND + -- Time slice value. Valid only if Time_Slice_Set is True, i.e. if + -- Time_Slice pragma has been processed. Set to the time slice value in + -- microseconds. Negative values are stored as zero, and the value is not + -- larger than 1_000_000_000 (1000 seconds). Values larger than this are + -- reset to this maximum. This can also be set with the -gnatTnn switch. + + Tolerate_Consistency_Errors : Boolean := False; + -- GNATBIND + -- Tolerate time stamp and other consistency errors. If this flag is set to + -- True (-t), then inconsistencies result in warnings rather than errors. + + Treat_Categorization_Errors_As_Warnings : Boolean := False; + -- Normally categorization errors are true illegalities. If this switch + -- is set, then such errors result in warning messages rather than error + -- messages. Set True by -gnateP (P for Pure/Preelaborate). + + Treat_Restrictions_As_Warnings : Boolean := False; + -- GNAT + -- Set True to treat pragma Restrictions as Restriction_Warnings. Set by + -- -gnatr switch. + + Tree_Output : Boolean := False; + -- GNAT + -- Set to True (-gnatt) to generate output tree file + + True_VMS_Target : Boolean := False; + -- Set True if we are on a VMS target. The setting of this flag reflects + -- the true state of the compile, unlike Targparm.OpenVMS_On_Target which + -- can also be true when debug flag m is set (-gnatdm). This is used in the + -- few cases where we do NOT want -gnatdm to trigger the VMS behavior. + + Try_Semantics : Boolean := False; + -- GNAT + -- Flag set to force attempt at semantic analysis, even if parser errors + -- occur. This will probably cause blowups at this stage in the game. On + -- the other hand, most such blowups will be caught cleanly and simply + -- say compilation abandoned. This flag is set to True by -gnatq or -gnatQ. + + Unchecked_Shared_Lib_Imports : Boolean := False; + -- GPRBUILD + -- Set to True when shared library projects are allowed to import projects + -- that are not shared library projects. Set by switch + -- --unchecked-shared-lib-imports. + + Undefined_Symbols_Are_False : Boolean := False; + -- GNAT, GNATPREP + -- Set to True by switch -u of gnatprep or -u in the preprocessing data + -- file for the compiler. Indicates that while preprocessing sources, + -- symbols that are not defined have the value FALSE. + + Unique_Error_Tag : Boolean := Tag_Errors; + -- GNAT + -- Indicates if error messages are to be prefixed by the string error: + -- Initialized from Tag_Errors, can be forced on with the -gnatU switch. + + Universal_Addressing_On_AAMP : Boolean := False; + -- GNAAMP + -- Indicates if library-level objects should be accessed and updated using + -- universal addressing instructions on the AAMP architecture. This flag is + -- set to True when pragma Universal_Data is given as a configuration + -- pragma. + + Unreserve_All_Interrupts : Boolean := False; + -- GNAT, GNATBIND + -- Normally set False, set True if a valid Unreserve_All_Interrupts pragma + -- appears anywhere in the main unit for GNAT, or if any ALI file has the + -- corresponding attribute set in GNATBIND. + + Upper_Half_Encoding : Boolean := False; + -- GNAT, GNATBIND + -- Normally set False, indicating that upper half ISO 8859-1 characters are + -- used in the normal way to represent themselves. If the wide character + -- encoding method uses the upper bit for this encoding, then this flag is + -- set True, and upper half characters in the source indicate the start of + -- a wide character sequence. Set by -gnatW or -W switches. + + Use_Include_Path_File : Boolean := False; + -- GNATMAKE, GPRBUILD + -- When True, create a source search path file, even when a mapping file + -- is used. + + Usage_Requested : Boolean := False; + -- GNAT, GNATBIND, GNATMAKE + -- Set to True if -h (-gnath for the compiler) switch encountered + -- requesting usage information + + Use_Expression_With_Actions : Boolean; + -- The N_Expression_With_Actions node has been introduced relatively + -- recently, and not all back ends are prepared to handle it yet. So + -- we use this flag to suppress its use during a transitional period. + -- Currently the default is False for all cases (set in gnat1drv). + -- The default can be modified using -gnatd.X/-gnatd.Y. + + Use_Pragma_Linker_Constructor : Boolean := False; + -- GNATBIND + -- True if pragma Linker_Constructor applies to adainit + + Use_VADS_Size : Boolean := False; + -- GNAT + -- Set to True if a valid pragma Use_VADS_Size is processed + + Validity_Checks_On : Boolean := True; + -- GNAT + -- This flag determines if validity checking is on or off. The initial + -- state is on, and the required default validity checks are active. The + -- actual set of checks that is performed if Validity_Checks_On is set is + -- defined by the switches in package Validsw. The Validity_Checks_On flag + -- is controlled by pragma Validity_Checks (On | Off), and also some + -- generated compiler code (typically code that has to do with validity + -- check generation) is compiled with this flag set to False. This flag is + -- set to False by the -gnatp switch. + + Verbose_Mode : Boolean := False; + -- GNAT, GNATBIND, GNATMAKE, GNATLINK, GNATLS, GNATNAME, GNATCLEAN, + -- GPRMAKE, GPRBUILD, GPRCLEAN + -- Set to True to get verbose mode (full error message text and location + -- information sent to standard output, also header, copyright and summary) + + type Verbosity_Level_Type is (None, Low, Medium, High); + pragma Ordered (Verbosity_Level_Type); + Verbosity_Level : Verbosity_Level_Type := High; + -- GNATMAKE, GPRMAKE + -- Modified by gnatmake or gprmake switches -v, -vl, -vm, -vh. Indicates + -- the level of verbosity of informational messages: + -- + -- In Low Verbosity, the reasons why a source is recompiled, the name + -- of the executable and the reason it must be rebuilt is output. + -- + -- In Medium Verbosity, additional lines are output for each ALI file + -- that is checked. + -- + -- In High Verbosity, additional lines are output when the ALI file + -- is part of an Ada library, is read-only or is part of the runtime. + + Warn_On_Ada_2005_Compatibility : Boolean := True; + -- GNAT + -- Set to True to generate all warnings on Ada 2005 compatibility issues, + -- including warnings on Ada 2005 obsolescent features used in Ada 2005 + -- mode. Set False by -gnatwY. + + Warn_On_Ada_2012_Compatibility : Boolean := True; + -- GNAT + -- Set to True to generate all warnings on Ada 2012 compatibility issues, + -- including warnings on Ada 2012 obsolescent features used in Ada 2012 + -- mode. Set False by -gnatwY. + + Warn_On_All_Unread_Out_Parameters : Boolean := False; + -- GNAT + -- Set to True to generate warnings in all cases where a variable is + -- modified by being passed as to an OUT formal, but the resulting value is + -- never read. The default is that this warning is suppressed, except in + -- the case of + + Warn_On_Assertion_Failure : Boolean := True; + -- GNAT + -- Set to True to activate warnings on assertions that can be determined + -- at compile time will always fail. Set false by -gnatw.A. + + Warn_On_Assumed_Low_Bound : Boolean := True; + -- GNAT + -- Set to True to activate warnings for string parameters that are indexed + -- with literals or S'Length, presumably assuming a lower bound of one. Set + -- False by -gnatwW. + + Warn_On_Bad_Fixed_Value : Boolean := False; + -- GNAT + -- Set to True to generate warnings for static fixed-point expression + -- values that are not an exact multiple of the small value of the type. + + Warn_On_Biased_Representation : Boolean := True; + -- GNAT + -- Set to True to generate warnings for size clauses, component clauses + -- and component_size clauses that force biased representation. Set False + -- by -gnatw.B. + + Warn_On_Constant : Boolean := False; + -- GNAT + -- Set to True to generate warnings for variables that could be declared + -- as constants. Modified by use of -gnatwk/K. + + Warn_On_Deleted_Code : Boolean := False; + -- GNAT + -- Set to True to generate warnings for code deleted by the front end + -- for conditional statements whose outcome is known at compile time. + -- Modified by use of -gnatwt/T. + + Warn_On_Dereference : Boolean := False; + -- GNAT + -- Set to True to generate warnings for implicit dereferences for array + -- indexing and record component access. Modified by use of -gnatwd/D. + + Warn_On_Export_Import : Boolean := True; + -- GNAT + -- Set to True to generate warnings for suspicious use of export or + -- import pragmas. Modified by use of -gnatwx/X. + + Warn_On_Hiding : Boolean := False; + -- GNAT + -- Set to True to generate warnings if a declared entity hides another + -- entity. The default is that this warning is suppressed. + + Warn_On_Modified_Unread : Boolean := False; + -- GNAT + -- Set to True to generate warnings if a variable is assigned but is never + -- read. Also controls warnings for similar cases involving out parameters, + -- but only if there is only one out parameter for the procedure involved. + -- The default is that this warning is suppressed. + + Warn_On_No_Value_Assigned : Boolean := True; + -- GNAT + -- Set to True to generate warnings if no value is ever assigned to a + -- variable that is at least partially uninitialized. Set to false to + -- suppress such warnings. The default is that such warnings are enabled. + + Warn_On_Non_Local_Exception : Boolean := False; + -- GNAT + -- Set to True to generate warnings for non-local exception raises and also + -- handlers that can never handle a local raise. This warning is only ever + -- generated if pragma Restrictions (No_Exception_Propagation) is set. The + -- default is not to generate the warnings except that if the source has + -- at least one exception handler, and this restriction is set, and the + -- warning was not explicitly turned off, then it is turned on by default. + + No_Warn_On_Non_Local_Exception : Boolean := False; + -- GNAT + -- This is set to True if the above warning is explicitly suppressed. We + -- use this to avoid turning it on by default when No_Exception_Propagation + -- restriction is set and an exception handler is present. + + Warn_On_Object_Renames_Function : Boolean := False; + -- GNAT + -- Set to True to generate warnings when a function result is renamed as + -- an object. The default is that this warning is disabled. + + Warn_On_Obsolescent_Feature : Boolean := False; + -- GNAT + -- Set to True to generate warnings on use of any feature in Annex or if a + -- subprogram is called for which a pragma Obsolescent applies. + + Warn_On_Overlap : Boolean := False; + -- GNAT + -- Set to True to generate warnings when a writable actual which is not + -- a by-copy type overlaps with another actual in a subprogram call. + + Warn_On_Questionable_Missing_Parens : Boolean := True; + -- GNAT + -- Set to True to generate warnings for cases where parentheses are missing + -- and the usage is questionable, because the intent is unclear. + + Warn_On_Parameter_Order : Boolean := False; + -- GNAT + -- Set to True to generate warnings for cases where the argument list for + -- a call is a sequence of identifiers that match the formal identifiers, + -- but are in the wrong order. + + Warn_On_Redundant_Constructs : Boolean := False; + -- GNAT + -- Set to True to generate warnings for redundant constructs (e.g. useless + -- assignments/conversions). The default is that this warning is disabled. + + Warn_On_Reverse_Bit_Order : Boolean := True; + -- GNAT + -- Set to True to generate warning (informational) messages for component + -- clauses that are affected by non-standard bit-order. The default is + -- that this warning is enabled. + + Warn_On_Suspicious_Modulus_Value : Boolean := True; + -- GNAT + -- Set to True to generate warnings for suspicious modulus values. The + -- default is that this warning is enabled. + + Warn_On_Unchecked_Conversion : Boolean := True; + -- GNAT + -- Set to True to generate warnings for unchecked conversions that may have + -- non-portable semantics (e.g. because sizes of types differ). The default + -- is that this warning is enabled. + + Warn_On_Unordered_Enumeration_Type : Boolean := False; + -- GNAT + -- Set to True to generate warnings for inappropriate uses (comparisons + -- and explicit ranges) on unordered enumeration types (which includes + -- all enumeration types for which pragma Ordered is not given). The + -- default is that this warning is disabled. + + Warn_On_Unrecognized_Pragma : Boolean := True; + -- GNAT + -- Set to True to generate warnings for unrecognized pragmas. The default + -- is that this warning is enabled. + + Warn_On_Unrepped_Components : Boolean := False; + -- GNAT + -- Set to True to generate warnings for the case of components of record + -- which have a record representation clause but this component does not + -- have a component clause. The default is that this warning is disabled. + + Warn_On_Warnings_Off : Boolean := False; + -- GNAT + -- Set to True to generate warnings for use of Pragma Warnings (Off, ent), + -- where either the pragma is never used, or it could be replaced by a + -- pragma Unmodified or Unreferenced. + + type Warning_Mode_Type is (Suppress, Normal, Treat_As_Error); + Warning_Mode : Warning_Mode_Type := Normal; + -- GNAT, GNATBIND + -- Controls treatment of warning messages. If set to Suppress, warning + -- messages are not generated at all. In Normal mode, they are generated + -- but do not count as errors. In Treat_As_Error mode, warning messages + -- are generated and are treated as errors. + + Wide_Character_Encoding_Method : WC_Encoding_Method := WCEM_Brackets; + -- GNAT, GNATBIND + -- Method used for encoding wide characters in the source program. See + -- description of type in unit System.WCh_Con for a list of the methods + -- that are currently supported. Note that brackets notation is always + -- recognized in source programs regardless of the setting of this + -- variable. The default setting causes only the brackets notation to be + -- recognized. If this is the main unit, this setting also controls the + -- output of the W=? parameter in the ALI file, which is used to provide + -- the default for encoding [Wide_[Wide_]]Text_IO files. For the binder, + -- the value set here overrides this main unit default. + + Wide_Character_Encoding_Method_Specified : Boolean := False; + -- GNAT, GNATBIND + -- Set True if the value in Wide_Character_Encoding_Method was set as + -- a result of an explicit -gnatW? or -W? switch. False otherwise. + + Xref_Active : Boolean := True; + -- GNAT + -- Set if cross-referencing is enabled (i.e. xref info in ALI files) + + Zero_Formatting : Boolean := False; + -- GNATBIND + -- Do no formatting (no title, no leading spaces, no empty lines) in + -- auxiliary outputs (-e, -K, -l, -R). + + ---------------------------- + -- Configuration Settings -- + ---------------------------- + + -- These are settings that are used to establish the mode at the start of + -- each unit. The values defined below can be affected either by command + -- line switches, or by the use of appropriate configuration pragmas in a + -- configuration pragma file. + + Ada_Version_Config : Ada_Version_Type; + -- GNAT + -- This is the value of the configuration switch for the Ada 83 mode, as + -- set by the command line switches -gnat83/95/05, and possibly modified by + -- the use of configuration pragmas Ada_83/Ada95/Ada05. This switch is used + -- to set the initial value for Ada_Version mode at the start of analysis + -- of a unit. Note however, that the setting of this flag is ignored for + -- internal and predefined units (which are always compiled in the most up + -- to date version of Ada). + + Ada_Version_Explicit_Config : Ada_Version_Type; + -- GNAT + -- This is set in the same manner as Ada_Version_Config. The difference is + -- that the setting of this flag is not ignored for internal and predefined + -- units, which for some purposes do indeed access this value, regardless + -- of the fact that they are compiled the most up to date ada version). + + Assertions_Enabled_Config : Boolean; + -- GNAT + -- This is the value of the configuration switch for assertions enabled + -- mode, as possibly set by the command line switch -gnata, and possibly + -- modified by the use of the configuration pragma Assertion_Policy. + + Assume_No_Invalid_Values_Config : Boolean; + -- GNAT + -- This is the value of the configuration switch for assuming "no invalid + -- values enabled" mode, as possibly set by the command line switch + -- -gnatB, and possibly modified by the use of the configuration pragma + -- Assume_No_Invalid_Values. + + Check_Policy_List_Config : Node_Id; + -- GNAT + -- This points to the list of N_Pragma nodes for Check_Policy pragmas + -- that are linked through the Next_Pragma fields, with the list being + -- terminated by Empty. The order is most recently processed first. This + -- list includes only those pragmas in configuration pragma files. + + Debug_Pragmas_Enabled_Config : Boolean; + -- GNAT + -- This is the value of the configuration switch for debug pragmas enabled + -- mode, as possibly set by the command line switch -gnata and possibly + -- modified by the use of the configuration pragma Debug_Policy. + + Default_Pool_Config : Node_Id := Empty; + -- GNAT + -- Same as Default_Pool above, except this is only for Default_Storage_Pool + -- pragmas that are configuration pragmas. + + Dynamic_Elaboration_Checks_Config : Boolean := False; + -- GNAT + -- Set True for dynamic elaboration checking mode, as set by the -gnatE + -- switch or by the use of pragma Elaboration_Checking (Dynamic). + + Exception_Locations_Suppressed_Config : Boolean := False; + -- GNAT + -- Set True by use of the configuration pragma Suppress_Exception_Messages + + Extensions_Allowed_Config : Boolean; + -- GNAT + -- This is the flag that indicates whether extensions are allowed. It can + -- be set True either by use of the -gnatX switch, or by use of the + -- configuration pragma Extensions_Allowed (On). It is always set to True + -- for internal GNAT units, since extensions are always permitted in such + -- units. + + External_Name_Exp_Casing_Config : External_Casing_Type; + -- GNAT + -- This is the value of the configuration switch that controls casing of + -- external symbols for which an explicit external name is given. It can be + -- set to Uppercase by the command line switch -gnatF, and further modified + -- by the use of the configuration pragma External_Name_Casing in the + -- gnat.adc file. This flag is used to set the initial value for + -- External_Name_Exp_Casing at the start of analyzing each unit. Note + -- however that the setting of this flag is ignored for internal and + -- predefined units (which are always compiled with As_Is mode). + + External_Name_Imp_Casing_Config : External_Casing_Type; + -- GNAT + -- This is the value of the configuration switch that controls casing of + -- external symbols where the external name is implicitly given. It can be + -- set to Uppercase by the command line switch -gnatF, and further modified + -- by the use of the configuration pragma External_Name_Casing in the + -- gnat.adc file. This flag is used to set the initial value for + -- External_Name_Imp_Casing at the start of analyzing each unit. Note + -- however that the setting of this flag is ignored for internal and + -- predefined units (which are always compiled with Lowercase mode). + + Fast_Math_Config : Boolean; + -- GNAT + -- This is the value of the configuration switch that controls Fast_Math + -- mode, as set by a Fast_Math pragma in configuration pragmas. It is + -- used to set the initial value of Fast_Math at the start of each new + -- compilation unit. + + Init_Or_Norm_Scalars_Config : Boolean; + -- GNAT + -- This is the value of the configuration switch that is set by one + -- of the pragmas Initialize_Scalars or Normalize_Scalars. + + Initialize_Scalars_Config : Boolean; + -- GNAT + -- This is the value of the configuration switch that is set by the + -- pragma Initialize_Scalars when it appears in the gnat.adc file. + -- This switch is not set when the pragma appears ahead of a given + -- unit, so it does not affect the compilation of other units. + + Optimize_Alignment_Config : Character; + -- GNAT + -- This is the value of the configuration switch that controls the + -- alignment optimization mode, as set by an Optimize_Alignment pragma. + -- It is used to set the initial value of Optimize_Alignment at the start + -- of each new compilation unit, except that it is always set to 'O' (off) + -- for internal units. + + Persistent_BSS_Mode_Config : Boolean; + -- GNAT + -- This is the value of the configuration switch that controls whether + -- potentially persistent data is to be placed in the persistent_bss + -- section. It can be set True by use of the pragma Persistent_BSS. + -- This flag is used to set the initial value of Persistent_BSS_Mode + -- at the start of each compilation unit, except that it is always + -- set False for predefined units. + + Polling_Required_Config : Boolean; + -- GNAT + -- This is the value of the configuration switch that controls polling + -- mode. It can be set True by the command line switch -gnatP, and then + -- further modified by the use of pragma Polling in the gnat.adc file. This + -- flag is used to set the initial value for Polling_Required at the start + -- of analyzing each unit. + + Short_Descriptors_Config : Boolean; + -- GNAT + -- This is the value of the configuration switch that controls the use of + -- Short_Descriptors for setting descriptor default sizes. It can be set + -- True by the use of the pragma Short_Descriptors in the gnat.adc file. + -- This flag is used to set the initial value for Short_Descriptors at the + -- start of analyzing each unit. + + Use_VADS_Size_Config : Boolean; + -- GNAT + -- This is the value of the configuration switch that controls the use of + -- VADS_Size instead of Size wherever the attribute Size is used. It can + -- be set True by the use of the pragma Use_VADS_Size in the gnat.adc file. + -- This flag is used to set the initial value for Use_VADS_Size at the + -- start of analyzing each unit. Note however that the setting of this flag + -- is ignored for internal and predefined units (which are always compiled + -- with the standard Size semantics). + + type Config_Switches_Type is private; + -- Type used to save values of the switches set from Config values + + procedure Save_Opt_Config_Switches (Save : out Config_Switches_Type); + -- This procedure saves the current values of the switches which are + -- initialized from the above Config values, and then resets these switches + -- according to the Config value settings. + + procedure Set_Opt_Config_Switches + (Internal_Unit : Boolean; + Main_Unit : Boolean); + -- This procedure sets the switches to the appropriate initial values. The + -- parameter Internal_Unit is True for an internal or predefined unit, and + -- affects the way the switches are set (see above). Main_Unit is true if + -- switches are being set for the main unit (this affects setting of the + -- assert/debug pragma switches, which are normally set false by default + -- for an internal unit, except when the internal unit is the main unit, + -- in which case we use the command line settings). + + procedure Restore_Opt_Config_Switches (Save : Config_Switches_Type); + -- This procedure restores a set of switch values previously saved by a + -- call to Save_Opt_Switches. + + procedure Register_Opt_Config_Switches; + -- This procedure is called after processing the gnat.adc file and other + -- configuration pragma files to record the values of the Config switches, + -- as possibly modified by the use of command line switches and pragmas + -- appearing in these files. + + ------------------------ + -- Other Global Flags -- + ------------------------ + + Expander_Active : Boolean := False; + -- A flag that indicates if expansion is active (True) or deactivated + -- (False). When expansion is deactivated all calls to expander routines + -- have no effect. Note that the initial setting of False is merely to + -- prevent saving of an undefined value for an initial call to the + -- Expander_Mode_Save_And_Set procedure. For more information on the use of + -- this flag, see package Expander. Indeed this flag might more logically + -- be in the spec of Expander, but it is referenced by Errout, and it + -- really seems wrong for Errout to depend on Expander. + + Static_Dispatch_Tables : Boolean := True; + -- This flag indicates if the backend supports generation of statically + -- allocated dispatch tables. If it is True, then the front end will + -- generate static aggregates for dispatch tables that contain forward + -- references to addresses of subprograms not seen yet, and the back end + -- must be prepared to handle this case. If it is False, then the front + -- end generates assignments to initialize the dispatch table, and there + -- are no such forward references. By default we build statically allocated + -- dispatch tables for all library level tagged types in all platforms.This + -- behavior can be disabled using switch -gnatd.t which will set this flag + -- to False and revert to the previous dynamic behavior. + + ----------------------- + -- Tree I/O Routines -- + ----------------------- + + procedure Tree_Read; + -- Reads switch settings from current tree file using Tree_Read + + procedure Tree_Write; + -- Writes out switch settings to current tree file using Tree_Write + + -------------------------- + -- ASIS Version Control -- + -------------------------- + + -- These two variables (Tree_Version_String and Tree_ASIS_Version_Number) + -- are supposed to be used in the GNAT/ASIS version check performed in + -- the ASIS code (this package is also a part of the ASIS implementation). + -- They are set by Tree_Read procedure, so they represent the version + -- number (and the version string) of the compiler which has created the + -- tree, and they are supposed to be compared with the corresponding values + -- from the Tree_IO and Gnatvsn packages which also are a part of ASIS + -- implementation. + + Tree_Version_String : String_Access; + -- Used to store the compiler version string read from a tree file to check + -- if it is from the same date as stored in the version string in Gnatvsn. + -- We require that ASIS Pro can be used only with GNAT Pro, but we allow + -- non-Pro ASIS and ASIS-based tools to be used with any version of the + -- GNAT compiler. Therefore, we need the possibility to compare the dates + -- of the corresponding source sets, using version strings that may be + -- of different lengths. + + Tree_ASIS_Version_Number : Int; + -- Used to store the ASIS version number read from a tree file to check if + -- it is the same as stored in the ASIS version number in Tree_IO. + +private + + -- The following type is used to save and restore settings of switches in + -- Opt that represent the configuration (i.e. result of config pragmas). + + -- Note that Ada_Version_Explicit is not included, since this is a sticky + -- flag that once set does not get reset, since the whole idea of this flag + -- is to record the setting for the main unit. + + type Config_Switches_Type is record + Ada_Version : Ada_Version_Type; + Ada_Version_Explicit : Ada_Version_Type; + Assertions_Enabled : Boolean; + Assume_No_Invalid_Values : Boolean; + Check_Policy_List : Node_Id; + Debug_Pragmas_Enabled : Boolean; + Default_Pool : Node_Id; + Dynamic_Elaboration_Checks : Boolean; + Exception_Locations_Suppressed : Boolean; + Extensions_Allowed : Boolean; + External_Name_Exp_Casing : External_Casing_Type; + External_Name_Imp_Casing : External_Casing_Type; + Fast_Math : Boolean; + Init_Or_Norm_Scalars : Boolean; + Initialize_Scalars : Boolean; + Optimize_Alignment : Character; + Optimize_Alignment_Local : Boolean; + Persistent_BSS_Mode : Boolean; + Polling_Required : Boolean; + Short_Descriptors : Boolean; + Use_VADS_Size : Boolean; + end record; + + -- The following declarations are for GCC version dependent flags. We do + -- not let client code in the compiler test GCC_Version directly, but + -- instead use deferred constants for relevant feature tags. + + -- Note: there currently are no such constants defined in this section, + -- since the compiler front end is currently entirely independent of the + -- GCC version, which is a desirable state of affairs. + + function get_gcc_version return Int; + pragma Import (C, get_gcc_version, "get_gcc_version"); + + GCC_Version : constant Nat := get_gcc_version; + -- GNATMAKE + -- Indicates which version of gcc is in use (3 = 3.x, 4 = 4.x). Note that + -- gcc 2.8.1 (which used to be a value of 2) is no longer supported. + +end Opt; diff --git a/gcc/ada/osint-b.adb b/gcc/ada/osint-b.adb new file mode 100644 index 000000000..39b7a99be --- /dev/null +++ b/gcc/ada/osint-b.adb @@ -0,0 +1,219 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O S I N T - B -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Opt; use Opt; +with Output; use Output; +with Targparm; use Targparm; + +package body Osint.B is + + Current_List_File : File_Descriptor := Invalid_FD; + + ------------------------- + -- Close_Binder_Output -- + ------------------------- + + procedure Close_Binder_Output is + Status : Boolean; + begin + Close (Output_FD, Status); + + if not Status then + Fail + ("error while closing generated file " + & Get_Name_String (Output_File_Name)); + end if; + + end Close_Binder_Output; + + --------------------- + -- Close_List_File -- + --------------------- + + procedure Close_List_File is + begin + if Current_List_File /= Invalid_FD then + Close (Current_List_File); + Current_List_File := Invalid_FD; + Set_Standard_Output; + end if; + end Close_List_File; + + -------------------------- + -- Create_Binder_Output -- + -------------------------- + + procedure Create_Binder_Output + (Output_File_Name : String; + Typ : Character; + Bfile : out Name_Id) + is + File_Name : String_Ptr; + Findex1 : Natural; + Findex2 : Natural; + Flength : Natural; + + Bind_File_Prefix_Len : Natural := 2; + -- Length of binder file prefix (normally set to 2 for b~, but gets + -- reset to 3 for VMS for b__). + + begin + if Output_File_Name /= "" then + Name_Buffer (1 .. Output_File_Name'Length) := Output_File_Name; + Name_Buffer (Output_File_Name'Length + 1) := ASCII.NUL; + + if Typ = 's' then + Name_Buffer (Output_File_Name'Last) := 's'; + end if; + + Name_Len := Output_File_Name'Last; + + else + Name_Buffer (1) := 'b'; + File_Name := File_Names (Current_File_Name_Index); + + Findex1 := File_Name'First; + + -- The ali file might be specified by a full path name. However, + -- the binder generated file should always be created in the + -- current directory, so the path might need to be stripped away. + -- In addition to the default directory_separator allow the '/' to + -- act as separator since this is allowed in MS-DOS and OS2 ports. + + for J in reverse File_Name'Range loop + if File_Name (J) = Directory_Separator + or else File_Name (J) = '/' + then + Findex1 := J + 1; + exit; + end if; + end loop; + + Findex2 := File_Name'Last; + while File_Name (Findex2) /= '.' loop + Findex2 := Findex2 - 1; + end loop; + + Flength := Findex2 - Findex1; + + if Maximum_File_Name_Length > 0 then + + if OpenVMS_On_Target and then Typ /= 'c' then + Bind_File_Prefix_Len := 3; + end if; + + -- Make room for the extra two characters in "b?" + + while Int (Flength) > + Maximum_File_Name_Length - Nat (Bind_File_Prefix_Len) + loop + Findex2 := Findex2 - 1; + Flength := Findex2 - Findex1; + end loop; + end if; + + Name_Buffer + (Bind_File_Prefix_Len + 1 .. Flength + Bind_File_Prefix_Len) := + File_Name (Findex1 .. Findex2 - 1); + Name_Buffer (Flength + Bind_File_Prefix_Len + 1) := '.'; + + -- C bind file, name is b_xxx.c + + if Typ = 'c' then + Name_Buffer (2) := '_'; + Name_Buffer (Flength + 4) := 'c'; + Name_Buffer (Flength + 5) := ASCII.NUL; + Name_Len := Flength + 4; + + -- Ada bind file, name is b~xxx.adb or b~xxx.ads + -- (with __ instead of ~ in VMS) + + else + if OpenVMS_On_Target then + Name_Buffer (2) := '_'; + Name_Buffer (3) := '_'; + else + Name_Buffer (2) := '~'; + end if; + + Name_Buffer (Flength + Bind_File_Prefix_Len + 2) := 'a'; + Name_Buffer (Flength + Bind_File_Prefix_Len + 3) := 'd'; + Name_Buffer (Flength + Bind_File_Prefix_Len + 4) := Typ; + Name_Buffer (Flength + Bind_File_Prefix_Len + 5) := ASCII.NUL; + Name_Len := Flength + Bind_File_Prefix_Len + 4; + end if; + end if; + + Bfile := Name_Find; + + Create_File_And_Check (Output_FD, Text); + end Create_Binder_Output; + + -------------------- + -- More_Lib_Files -- + -------------------- + + function More_Lib_Files return Boolean renames More_Files; + + ------------------------ + -- Next_Main_Lib_File -- + ------------------------ + + function Next_Main_Lib_File return File_Name_Type renames Next_Main_File; + + --------------------------------- + -- Set_Current_File_Name_Index -- + --------------------------------- + + procedure Set_Current_File_Name_Index (To : Int) is + begin + Current_File_Name_Index := To; + end Set_Current_File_Name_Index; + + ------------------- + -- Set_List_File -- + ------------------- + + procedure Set_List_File (Filename : String) is + begin + pragma Assert (Current_List_File = Invalid_FD); + Current_List_File := Create_File (Filename, Text); + + if Current_List_File = Invalid_FD then + Fail ("cannot create list file: " & Filename); + else + Set_Output (Current_List_File); + end if; + end Set_List_File; + + ----------------------- + -- Write_Binder_Info -- + ----------------------- + + procedure Write_Binder_Info (Info : String) renames Write_Info; + +begin + Set_Program (Binder); +end Osint.B; diff --git a/gcc/ada/osint-b.ads b/gcc/ada/osint-b.ads new file mode 100644 index 000000000..d24ec91ee --- /dev/null +++ b/gcc/ada/osint-b.ads @@ -0,0 +1,96 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O S I N T - B -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 low level, operating system routines used only +-- in the GNAT binder for command line processing and file input output. + +package Osint.B is + + function More_Lib_Files return Boolean; + -- Indicates whether more library information files remain to be processed. + -- Returns False right away if no source files, or if all source files + -- have been processed. + + function Next_Main_Lib_File return File_Name_Type; + -- This function returns the name of the next library info file specified + -- on the command line. It is an error to call Next_Main_Lib_File if no + -- more library information files exist (i.e. Next_Main_Lib_File may be + -- called only if a previous call to More_Lib_Files returned True). This + -- name is the simple name, excluding any directory information. + + ------------------- + -- Binder Output -- + ------------------- + + -- These routines are used by the binder to generate the C or Ada source + -- files containing the binder output. The format of these files is + -- described in package Bindgen. + + procedure Create_Binder_Output + (Output_File_Name : String; + Typ : Character; + Bfile : out Name_Id); + -- Creates the binder output file. Typ is one of + -- + -- 'c' create output file for case of generating C + -- 'b' create body file for case of generating Ada + -- 's' create spec file for case of generating Ada + -- + -- If Output_File_Name is null, then a default name is used based on + -- the name of the most recently accessed main source file name. If + -- Output_File_Name is non-null then it is the full path name of the + -- file to be output (in the case of Ada, it must have an extension + -- of adb, and the spec file is created by changing the last character + -- from b to s. On return, Bfile also contains the Name_Id for the + -- generated file name. + + procedure Write_Binder_Info (Info : String); + -- Writes the contents of the referenced string to the binder output file + -- created by a previous call to Create_Binder_Output. Info represents a + -- single line in the file, but does not contain any line termination + -- characters. The implementation of Write_Binder_Info is responsible + -- for adding necessary end of line and end of file control characters + -- as required by the operating system. + + procedure Close_Binder_Output; + -- Closes the file created by Create_Binder_Output, flushing any + -- buffers etc. from writes by Write_Binder_Info. + + procedure Set_Current_File_Name_Index (To : Int); + -- Set value of Current_File_Name_Index (in private part of Osint) to To + + ---------------------------------- + -- Other binder-generated files -- + ---------------------------------- + + procedure Set_List_File (Filename : String); + -- Create Filename as a text output file and set it as the current output + -- (see Output.Set_Output). + + procedure Close_List_File; + -- If a specific output file was created by Set_List_File, close it and + -- reset the current output file to standard output. + +end Osint.B; diff --git a/gcc/ada/osint-c.adb b/gcc/ada/osint-c.adb new file mode 100644 index 000000000..8b67befc6 --- /dev/null +++ b/gcc/ada/osint-c.adb @@ -0,0 +1,509 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O S I N T - C -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Hostparm; +with Opt; use Opt; +with Tree_IO; use Tree_IO; + +package body Osint.C is + + Output_Object_File_Name : String_Ptr; + -- Argument of -o compiler option, if given. This is needed to verify + -- consistency with the ALI file name. + + procedure Adjust_OS_Resource_Limits; + pragma Import (C, Adjust_OS_Resource_Limits, + "__gnat_adjust_os_resource_limits"); + -- Procedure to make system specific adjustments to make GNAT run better + + function Create_Auxiliary_File + (Src : File_Name_Type; + Suffix : String) return File_Name_Type; + -- Common processing for Create_List_File, Create_Repinfo_File and + -- Create_Debug_File. Src is the file name used to create the required + -- output file and Suffix is the desired suffix (dg/rep/xxx for debug/ + -- repinfo/list file where xxx is specified extension. + + procedure Set_Library_Info_Name; + -- Sets a default ALI file name from the main compiler source name. + -- This is used by Create_Output_Library_Info, and by the version of + -- Read_Library_Info that takes a default file name. The name is in + -- Name_Buffer (with length in Name_Len) on return from the call. + + ---------------------- + -- Close_Debug_File -- + ---------------------- + + procedure Close_Debug_File is + Status : Boolean; + + begin + Close (Output_FD, Status); + + if not Status then + Fail + ("error while closing expanded source file " + & Get_Name_String (Output_File_Name)); + end if; + end Close_Debug_File; + + --------------------- + -- Close_List_File -- + --------------------- + + procedure Close_List_File is + Status : Boolean; + + begin + Close (Output_FD, Status); + + if not Status then + Fail + ("error while closing list file " + & Get_Name_String (Output_File_Name)); + end if; + end Close_List_File; + + ------------------------------- + -- Close_Output_Library_Info -- + ------------------------------- + + procedure Close_Output_Library_Info is + Status : Boolean; + + begin + Close (Output_FD, Status); + + if not Status then + Fail + ("error while closing ALI file " + & Get_Name_String (Output_File_Name)); + end if; + end Close_Output_Library_Info; + + ------------------------ + -- Close_Repinfo_File -- + ------------------------ + + procedure Close_Repinfo_File is + Status : Boolean; + + begin + Close (Output_FD, Status); + + if not Status then + Fail + ("error while closing representation info file " + & Get_Name_String (Output_File_Name)); + end if; + end Close_Repinfo_File; + + --------------------------- + -- Create_Auxiliary_File -- + --------------------------- + + function Create_Auxiliary_File + (Src : File_Name_Type; + Suffix : String) return File_Name_Type + is + Result : File_Name_Type; + + begin + Get_Name_String (Src); + + if Hostparm.OpenVMS then + Name_Buffer (Name_Len + 1) := '_'; + else + Name_Buffer (Name_Len + 1) := '.'; + end if; + + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix; + Name_Len := Name_Len + Suffix'Length; + + if Output_Object_File_Name /= null then + for Index in reverse Output_Object_File_Name'Range loop + if Output_Object_File_Name (Index) = Directory_Separator then + declare + File_Name : constant String := Name_Buffer (1 .. Name_Len); + begin + Name_Len := Index - Output_Object_File_Name'First + 1; + Name_Buffer (1 .. Name_Len) := + Output_Object_File_Name + (Output_Object_File_Name'First .. Index); + Name_Buffer (Name_Len + 1 .. Name_Len + File_Name'Length) := + File_Name; + Name_Len := Name_Len + File_Name'Length; + end; + + exit; + end if; + end loop; + end if; + + Result := Name_Find; + Name_Buffer (Name_Len + 1) := ASCII.NUL; + Create_File_And_Check (Output_FD, Text); + return Result; + end Create_Auxiliary_File; + + ----------------------- + -- Create_Debug_File -- + ----------------------- + + function Create_Debug_File (Src : File_Name_Type) return File_Name_Type is + begin + return Create_Auxiliary_File (Src, "dg"); + end Create_Debug_File; + + ---------------------- + -- Create_List_File -- + ---------------------- + + procedure Create_List_File (S : String) is + F : File_Name_Type; + pragma Warnings (Off, F); + begin + if S (S'First) = '.' then + F := Create_Auxiliary_File (Current_Main, S (S'First + 1 .. S'Last)); + + else + Name_Buffer (1 .. S'Length) := S; + Name_Len := S'Length + 1; + Name_Buffer (Name_Len) := ASCII.NUL; + Create_File_And_Check (Output_FD, Text); + end if; + end Create_List_File; + + -------------------------------- + -- Create_Output_Library_Info -- + -------------------------------- + + procedure Create_Output_Library_Info is + Dummy : Boolean; + pragma Unreferenced (Dummy); + + begin + Set_Library_Info_Name; + Delete_File (Name_Buffer (1 .. Name_Len), Dummy); + Create_File_And_Check (Output_FD, Text); + end Create_Output_Library_Info; + + ------------------------- + -- Create_Repinfo_File -- + ------------------------- + + procedure Create_Repinfo_File (Src : String) is + Discard : File_Name_Type; + pragma Warnings (Off, Discard); + begin + Name_Buffer (1 .. Src'Length) := Src; + Name_Len := Src'Length; + Discard := Create_Auxiliary_File (Name_Find, "rep"); + return; + end Create_Repinfo_File; + + --------------------------- + -- Debug_File_Eol_Length -- + --------------------------- + + function Debug_File_Eol_Length return Nat is + begin + -- There has to be a cleaner way to do this! ??? + + if Directory_Separator = '/' then + return 1; + else + return 2; + end if; + end Debug_File_Eol_Length; + + --------------------------------- + -- Get_Output_Object_File_Name -- + --------------------------------- + + function Get_Output_Object_File_Name return String is + begin + pragma Assert (Output_Object_File_Name /= null); + + return Output_Object_File_Name.all; + end Get_Output_Object_File_Name; + + ----------------------- + -- More_Source_Files -- + ----------------------- + + function More_Source_Files return Boolean renames More_Files; + + ---------------------- + -- Next_Main_Source -- + ---------------------- + + function Next_Main_Source return File_Name_Type renames Next_Main_File; + + ----------------------- + -- Read_Library_Info -- + ----------------------- + + -- Version with default file name + + procedure Read_Library_Info + (Name : out File_Name_Type; + Text : out Text_Buffer_Ptr) + is + begin + Set_Library_Info_Name; + Name := Name_Find; + Text := Read_Library_Info (Name, Fatal_Err => False); + end Read_Library_Info; + + --------------------------- + -- Set_Library_Info_Name -- + --------------------------- + + procedure Set_Library_Info_Name is + Dot_Index : Natural; + + begin + Get_Name_String (Current_Main); + + -- Find last dot since we replace the existing extension by .ali. The + -- initialization to Name_Len + 1 provides for simply adding the .ali + -- extension if the source file name has no extension. + + Dot_Index := Name_Len + 1; + + for J in reverse 1 .. Name_Len loop + if Name_Buffer (J) = '.' then + Dot_Index := J; + exit; + end if; + end loop; + + -- Make sure that the output file name matches the source file name. + -- To compare them, remove file name directories and extensions. + + if Output_Object_File_Name /= null then + + -- Make sure there is a dot at Dot_Index. This may not be the case + -- if the source file name has no extension. + + Name_Buffer (Dot_Index) := '.'; + + -- If we are in multiple unit per file mode, then add ~nnn + -- extension to the name before doing the comparison. + + if Multiple_Unit_Index /= 0 then + declare + Exten : constant String := Name_Buffer (Dot_Index .. Name_Len); + begin + Name_Len := Dot_Index - 1; + Add_Char_To_Name_Buffer (Multi_Unit_Index_Character); + Add_Nat_To_Name_Buffer (Multiple_Unit_Index); + Dot_Index := Name_Len + 1; + Add_Str_To_Name_Buffer (Exten); + end; + end if; + + -- Remove extension preparing to replace it + + declare + Name : String := Name_Buffer (1 .. Dot_Index); + First : Positive; + + begin + Name_Buffer (1 .. Output_Object_File_Name'Length) := + Output_Object_File_Name.all; + + -- Put two names in canonical case, to allow object file names + -- with upper-case letters on Windows. + + Canonical_Case_File_Name (Name); + Canonical_Case_File_Name + (Name_Buffer (1 .. Output_Object_File_Name'Length)); + + Dot_Index := 0; + for J in reverse Output_Object_File_Name'Range loop + if Name_Buffer (J) = '.' then + Dot_Index := J; + exit; + end if; + end loop; + + -- Dot_Index should not be zero now (we check for extension + -- elsewhere). + + pragma Assert (Dot_Index /= 0); + + -- Look for first character of file name + + First := Dot_Index; + while First > 1 + and then Name_Buffer (First - 1) /= Directory_Separator + and then Name_Buffer (First - 1) /= '/' + loop + First := First - 1; + end loop; + + -- Check name of object file is what we expect + + if Name /= Name_Buffer (First .. Dot_Index) then + Fail ("incorrect object file name"); + end if; + end; + end if; + + Name_Buffer (Dot_Index) := '.'; + Name_Buffer (Dot_Index + 1 .. Dot_Index + 3) := ALI_Suffix.all; + Name_Buffer (Dot_Index + 4) := ASCII.NUL; + Name_Len := Dot_Index + 3; + end Set_Library_Info_Name; + + --------------------------------- + -- Set_Output_Object_File_Name -- + --------------------------------- + + procedure Set_Output_Object_File_Name (Name : String) is + Ext : constant String := Target_Object_Suffix; + NL : constant Natural := Name'Length; + EL : constant Natural := Ext'Length; + + begin + -- Make sure that the object file has the expected extension + + if NL <= EL + or else + (Name (NL - EL + Name'First .. Name'Last) /= Ext + and then Name (NL - 2 + Name'First .. Name'Last) /= ".o") + then + Fail ("incorrect object file extension"); + end if; + + Output_Object_File_Name := new String'(Name); + end Set_Output_Object_File_Name; + + ---------------- + -- Tree_Close -- + ---------------- + + procedure Tree_Close is + Status : Boolean; + begin + Tree_Write_Terminate; + Close (Output_FD, Status); + + if not Status then + Fail + ("error while closing tree file " + & Get_Name_String (Output_File_Name)); + end if; + end Tree_Close; + + ----------------- + -- Tree_Create -- + ----------------- + + procedure Tree_Create is + Dot_Index : Natural; + + begin + Get_Name_String (Current_Main); + + -- If an object file has been specified, then the ALI file + -- will be in the same directory as the object file; + -- so, we put the tree file in this same directory, + -- even though no object file needs to be generated. + + if Output_Object_File_Name /= null then + Name_Len := Output_Object_File_Name'Length; + Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all; + end if; + + Dot_Index := Name_Len + 1; + + for J in reverse 1 .. Name_Len loop + if Name_Buffer (J) = '.' then + Dot_Index := J; + exit; + end if; + end loop; + + -- Should be impossible to not have an extension + + pragma Assert (Dot_Index /= 0); + + -- Change extension to adt + + Name_Buffer (Dot_Index) := '.'; + Name_Buffer (Dot_Index + 1) := 'a'; + Name_Buffer (Dot_Index + 2) := 'd'; + Name_Buffer (Dot_Index + 3) := 't'; + Name_Buffer (Dot_Index + 4) := ASCII.NUL; + Name_Len := Dot_Index + 3; + Create_File_And_Check (Output_FD, Binary); + + Tree_Write_Initialize (Output_FD); + end Tree_Create; + + ----------------------- + -- Write_Debug_Info -- + ----------------------- + + procedure Write_Debug_Info (Info : String) renames Write_Info; + + ------------------------ + -- Write_Library_Info -- + ------------------------ + + procedure Write_Library_Info (Info : String) renames Write_Info; + + --------------------- + -- Write_List_Info -- + --------------------- + + procedure Write_List_Info (S : String) is + begin + Write_With_Check (S'Address, S'Length); + end Write_List_Info; + + ------------------------ + -- Write_Repinfo_Line -- + ------------------------ + + procedure Write_Repinfo_Line (Info : String) renames Write_Info; + +begin + Adjust_OS_Resource_Limits; + + Opt.Create_Repinfo_File_Access := Create_Repinfo_File'Access; + Opt.Write_Repinfo_Line_Access := Write_Repinfo_Line'Access; + Opt.Close_Repinfo_File_Access := Close_Repinfo_File'Access; + + Opt.Create_List_File_Access := Create_List_File'Access; + Opt.Write_List_Info_Access := Write_List_Info'Access; + Opt.Close_List_File_Access := Close_List_File'Access; + + Set_Program (Compiler); +end Osint.C; diff --git a/gcc/ada/osint-c.ads b/gcc/ada/osint-c.ads new file mode 100644 index 000000000..1060934f7 --- /dev/null +++ b/gcc/ada/osint-c.ads @@ -0,0 +1,174 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O S I N T - C -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 low level, operating system routines used only +-- in the GNAT compiler for command line processing and file input output. + +package Osint.C is + + procedure Set_Output_Object_File_Name (Name : String); + -- Called by the subprogram processing the command line when an + -- output object file name is found. + + function Get_Output_Object_File_Name return String; + -- Returns the name of the output object file as saved by a call to + -- Set_Output_Object_File_Name. Only valid to call if name has been set. + + function More_Source_Files return Boolean; + -- Indicates whether more source file remain to be processed. Returns + -- False right away if no source files, or if all source files have + -- been processed. + + function Next_Main_Source return File_Name_Type; + -- This function returns the name of the next main source file specified + -- on the command line. It is an error to call Next_Main_Source if no more + -- source files exist (i.e. Next_Main_Source may be called only if a + -- previous call to More_Source_Files returned True). This name is the + -- simple file name (without any directory information). + + ------------------------------ + -- Debug Source File Output -- + ------------------------------ + + -- These routines are used by the compiler to generate the debug source + -- file for the Debug_Generated_Code (-gnatD switch) option. Note that + -- debug source file writing occurs at a completely different point in + -- the processing from library information output, or representation + -- output, so the code in the body can assume that no two of these + -- functions are ever used at the same time. + + function Create_Debug_File (Src : File_Name_Type) return File_Name_Type; + -- Given the simple name of a source file, this routine creates the + -- corresponding debug file, and returns its full name. + + procedure Write_Debug_Info (Info : String); + -- Writes contents of given string as next line of the current debug + -- source file created by the most recent call to Create_Debug_File. + -- Info does not contain end of line or other formatting characters. + + procedure Close_Debug_File; + -- Close current debug file created by the most recent call to + -- Create_Debug_File. + + function Debug_File_Eol_Length return Nat; + -- Returns the number of characters (1 for NL, 2 for CR/LF) written + -- at the end of each line by Write_Debug_Info. + + -------------------------------- + -- Representation File Output -- + -------------------------------- + + -- These routines are used by the compiler to generate the representation + -- information to a file if this option is specified (-gnatR?s switch). + -- Note that the writing of this file occurs at a completely different + -- point in the processing from library information output, or from + -- debug file output, so the code in the body can assume that no two + -- of these functions are ever used at the same time. + + -- Note: these routines are called from Repinfo, but are not called + -- directly, since we do not want Repinfo to depend on Osint. That + -- would cause a lot of unwanted junk to be dragged into ASIS. So + -- what we do is we have Initialize set the addresses of these three + -- procedures in appropriate variables in Repinfo, so that they can + -- be called indirectly without creating a dependence. + + procedure Create_Repinfo_File (Src : String); + -- Given the simple name of a source file, this routine creates the + -- corresponding file to hold representation information. Note that the + -- call destroys the contents of Name_Buffer and Name_Len. + + procedure Write_Repinfo_Line (Info : String); + -- Writes contents of given string as next line of the current debug + -- source file created by the most recent call to Create_Repinfo_File. + -- Info does not contain end of line or other formatting characters. + + procedure Close_Repinfo_File; + -- Close current debug file created by the most recent call to + -- Create_Repinfo_File. + + -------------------------------- + -- Library Information Output -- + -------------------------------- + + -- These routines are used by the compiler to generate the library + -- information file for the main source file being compiled. See section + -- above for a discussion of how library information files are stored. + + procedure Create_Output_Library_Info; + -- Creates the output library information file for the source file which + -- is currently being compiled (i.e. the file which was most recently + -- returned by Next_Main_Source). + + procedure Write_Library_Info (Info : String); + -- Writes the contents of the referenced string to the library information + -- file for the main source file currently being compiled (i.e. the file + -- which was most recently opened with a call to Read_Next_File). Info + -- represents a single line in the file, but does not contain any line + -- termination characters. The implementation of Write_Library_Info is + -- responsible for adding necessary end of line and end of file control + -- characters to the generated file. + + procedure Close_Output_Library_Info; + -- Closes the file created by Create_Output_Library_Info, flushing any + -- buffers etc. from writes by Write_Library_Info. + + procedure Read_Library_Info + (Name : out File_Name_Type; + Text : out Text_Buffer_Ptr); + -- The procedure version of Read_Library_Info is used from the compiler + -- to read an existing ali file associated with the main unit. If the + -- ALI file exists, then its file name is returned in Name, and its + -- text is returned in Text. If the file does not exist, then Text is + -- set to null. + + ---------------------- + -- List File Output -- + ---------------------- + + procedure Create_List_File (S : String); + -- Creates the file whose name is given by S. If the name starts with a + -- period, then the name is xxx & S, where xxx is the name of the main + -- source file without the extension stripped. Information is written to + -- this file using Write_List_File. + + procedure Write_List_Info (S : String); + -- Writes given string to the list file created by Create_List_File + + procedure Close_List_File; + -- Close file previously opened by Create_List_File + + -------------------------------- + -- Semantic Tree Input-Output -- + -------------------------------- + + procedure Tree_Create; + -- Creates the tree output file for the source file which is currently + -- being compiled (i.e. the file which was most recently returned by + -- Next_Main_Source), and initializes Tree_IO.Tree_Write for output. + + procedure Tree_Close; + -- Closes the file previously opened by Tree_Create + +end Osint.C; diff --git a/gcc/ada/osint-l.adb b/gcc/ada/osint-l.adb new file mode 100644 index 000000000..9cc8f4c9b --- /dev/null +++ b/gcc/ada/osint-l.adb @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O S I N T - L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Osint.L is + + -------------------- + -- More_Lib_Files -- + -------------------- + + function More_Lib_Files return Boolean renames More_Files; + + ------------------------ + -- Next_Main_Lib_File -- + ------------------------ + + function Next_Main_Lib_File return File_Name_Type renames Next_Main_File; + +begin + Set_Program (Gnatls); +end Osint.L; diff --git a/gcc/ada/osint-l.ads b/gcc/ada/osint-l.ads new file mode 100644 index 000000000..b2061bfc1 --- /dev/null +++ b/gcc/ada/osint-l.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O S I N T - L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 low level, operating system routines used only +-- in gnatls for command line processing and file input output. + +package Osint.L is + + function More_Lib_Files return Boolean; + -- Indicates whether more library information files remain to be processed. + -- Returns False right away if no source files, or if all source files + -- have been processed. + + function Next_Main_Lib_File return File_Name_Type; + -- This function returns the name of the next library info file specified + -- on the command line. It is an error to call Next_Main_Lib_File if no + -- more library information files exist (i.e. Next_Main_Lib_File may be + -- called only if a previous call to More_Lib_Files returned True). This + -- name is the simple name, excluding any directory information. + +end Osint.L; diff --git a/gcc/ada/osint-m.adb b/gcc/ada/osint-m.adb new file mode 100644 index 000000000..b7344577b --- /dev/null +++ b/gcc/ada/osint-m.adb @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O S I N T - M -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Osint; + +pragma Elaborate_All (Osint); +-- This pragma is needed because of the call to Set_Program in the +-- elaboration of the package. We cannot rely on the static model +-- of elaboration since the compiler is routinely compiled with +-- checks off (-gnatp), and with older versions of the compiler +-- (up to and including most 5.04 wavefronts), -gnatp suppresses +-- the static elaboration check mechanisms. It could be removed +-- one day, but there really is no need to do so. + +package body Osint.M is + + ----------------------- + -- More_Source_Files -- + ----------------------- + + function More_Source_Files return Boolean renames More_Files; + + ---------------------- + -- Next_Main_Source -- + ---------------------- + + function Next_Main_Source return File_Name_Type renames Next_Main_File; + + ---------------------- + -- Object_File_Name -- + ---------------------- + + function Object_File_Name (N : File_Name_Type) return File_Name_Type + renames Osint.Object_File_Name; + +begin + Set_Program (Make); +end Osint.M; diff --git a/gcc/ada/osint-m.ads b/gcc/ada/osint-m.ads new file mode 100644 index 000000000..6f3d5551b --- /dev/null +++ b/gcc/ada/osint-m.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O S I N T - M -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 low level, operating system routines used only +-- in gnatmake for command line processing and file input output. + +package Osint.M is + + function More_Source_Files return Boolean; + -- Indicates whether more source file remain to be processed. Returns + -- False right away if no source files, or if all source files have + -- been processed. + + function Next_Main_Source return File_Name_Type; + -- This function returns the name of the next main source file specified + -- on the command line. It is an error to call Next_Main_Source if no more + -- source files exist (i.e. Next_Main_Source may be called only if a + -- previous call to More_Source_Files returned True). This name is the + -- simple file name (without any directory information). + + function Object_File_Name (N : File_Name_Type) return File_Name_Type; + -- Constructs the name of the object file corresponding to library + -- file N. If N is a full file name than the returned file name will + -- also be a full file name. Note that no lookup in the library file + -- directories is done for this file. This routine merely constructs + -- the name. + +end Osint.M; diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb new file mode 100644 index 000000000..248845f3f --- /dev/null +++ b/gcc/ada/osint.adb @@ -0,0 +1,3337 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O S I N T -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Alloc; +with Debug; +with Fmap; use Fmap; +with Gnatvsn; use Gnatvsn; +with Hostparm; +with Opt; use Opt; +with Output; use Output; +with Sdefault; use Sdefault; +with Table; +with Targparm; use Targparm; + +with Unchecked_Conversion; + +pragma Warnings (Off); +-- This package is used also by gnatcoll +with System.Case_Util; use System.Case_Util; +pragma Warnings (On); + +with GNAT.HTable; + +package body Osint is + + Running_Program : Program_Type := Unspecified; + -- comment required here ??? + + Program_Set : Boolean := False; + -- comment required here ??? + + Std_Prefix : String_Ptr; + -- Standard prefix, computed dynamically the first time Relocate_Path + -- is called, and cached for subsequent calls. + + Empty : aliased String := ""; + No_Dir : constant String_Ptr := Empty'Access; + -- Used in Locate_File as a fake directory when Name is already an + -- absolute path. + + ------------------------------------- + -- Use of Name_Find and Name_Enter -- + ------------------------------------- + + -- This package creates a number of source, ALI and object file names + -- that are used to locate the actual file and for the purpose of message + -- construction. These names need not be accessible by Name_Find, and can + -- be therefore created by using routine Name_Enter. The files in question + -- are file names with a prefix directory (i.e., the files not in the + -- current directory). File names without a prefix directory are entered + -- with Name_Find because special values might be attached to the various + -- Info fields of the corresponding name table entry. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Append_Suffix_To_File_Name + (Name : File_Name_Type; + Suffix : String) return File_Name_Type; + -- Appends Suffix to Name and returns the new name + + function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type; + -- Convert OS format time to GNAT format time stamp. If T is Invalid_Time, + -- then returns Empty_Time_Stamp. + + function Executable_Prefix return String_Ptr; + -- Returns the name of the root directory where the executable is stored. + -- The executable must be located in a directory called "bin", or under + -- root/lib/gcc-lib/..., or under root/libexec/gcc/... For example, if + -- executable is stored in directory "/foo/bar/bin", this routine returns + -- "/foo/bar/". Return "" if location is not recognized as described above. + + function Update_Path (Path : String_Ptr) return String_Ptr; + -- Update the specified path to replace the prefix with the location where + -- GNAT is installed. See the file prefix.c in GCC for details. + + procedure Locate_File + (N : File_Name_Type; + T : File_Type; + Dir : Natural; + Name : String; + Found : out File_Name_Type; + Attr : access File_Attributes); + -- See if the file N whose name is Name exists in directory Dir. Dir is an + -- index into the Lib_Search_Directories table if T = Library. Otherwise + -- if T = Source, Dir is an index into the Src_Search_Directories table. + -- Returns the File_Name_Type of the full file name if file found, or + -- No_File if not found. + -- + -- On exit, Found is set to the file that was found, and Attr to a cache of + -- its attributes (at least those that have been computed so far). Reusing + -- the cache will save some system calls. + -- + -- Attr is always reset in this call to Unknown_Attributes, even in case of + -- failure + + procedure Find_File + (N : File_Name_Type; + T : File_Type; + Found : out File_Name_Type; + Attr : access File_Attributes); + -- A version of Find_File that also returns a cache of the file attributes + -- for later reuse + + procedure Smart_Find_File + (N : File_Name_Type; + T : File_Type; + Found : out File_Name_Type; + Attr : out File_Attributes); + -- A version of Smart_Find_File that also returns a cache of the file + -- attributes for later reuse + + function C_String_Length (S : Address) return Integer; + -- Returns length of a C string (zero for a null address) + + function To_Path_String_Access + (Path_Addr : Address; + Path_Len : Integer) return String_Access; + -- Converts a C String to an Ada String. Are we doing this to avoid withing + -- Interfaces.C.Strings ??? + -- Caller must free result. + + function Include_Dir_Default_Prefix return String_Access; + -- Same as exported version, except returns a String_Access + + ------------------------------ + -- Other Local Declarations -- + ------------------------------ + + EOL : constant Character := ASCII.LF; + -- End of line character + + Number_File_Names : Int := 0; + -- Number of file names found on command line and placed in File_Names + + Look_In_Primary_Directory_For_Current_Main : Boolean := False; + -- When this variable is True, Find_File only looks in Primary_Directory + -- for the Current_Main file. This variable is always set to True for the + -- compiler. It is also True for gnatmake, when the source name given on + -- the command line has directory information. + + Current_Full_Source_Name : File_Name_Type := No_File; + Current_Full_Source_Stamp : Time_Stamp_Type := Empty_Time_Stamp; + Current_Full_Lib_Name : File_Name_Type := No_File; + Current_Full_Lib_Stamp : Time_Stamp_Type := Empty_Time_Stamp; + Current_Full_Obj_Name : File_Name_Type := No_File; + Current_Full_Obj_Stamp : Time_Stamp_Type := Empty_Time_Stamp; + -- Respectively full name (with directory info) and time stamp of the + -- latest source, library and object files opened by Read_Source_File and + -- Read_Library_Info. + + package File_Name_Chars is new Table.Table ( + Table_Component_Type => Character, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => Alloc.File_Name_Chars_Initial, + Table_Increment => Alloc.File_Name_Chars_Increment, + Table_Name => "File_Name_Chars"); + -- Table to store text to be printed by Dump_Source_File_Names + + The_Include_Dir_Default_Prefix : String_Access := null; + -- Value returned by Include_Dir_Default_Prefix. We don't initialize it + -- here, because that causes an elaboration cycle with Sdefault; we + -- initialize it lazily instead. + + ------------------ + -- Search Paths -- + ------------------ + + Primary_Directory : constant := 0; + -- This is index in the tables created below for the first directory to + -- search in for source or library information files. This is the directory + -- containing the latest main input file (a source file for the compiler or + -- a library file for the binder). + + package Src_Search_Directories is new Table.Table ( + Table_Component_Type => String_Ptr, + Table_Index_Type => Integer, + Table_Low_Bound => Primary_Directory, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Osint.Src_Search_Directories"); + -- Table of names of directories in which to search for source (Compiler) + -- files. This table is filled in the order in which the directories are + -- to be searched, and then used in that order. + + package Lib_Search_Directories is new Table.Table ( + Table_Component_Type => String_Ptr, + Table_Index_Type => Integer, + Table_Low_Bound => Primary_Directory, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Osint.Lib_Search_Directories"); + -- Table of names of directories in which to search for library (Binder) + -- files. This table is filled in the order in which the directories are + -- to be searched and then used in that order. The reason for having two + -- distinct tables is that we need them both in gnatmake. + + --------------------- + -- File Hash Table -- + --------------------- + + -- The file hash table is provided to free the programmer from any + -- efficiency concern when retrieving full file names or time stamps of + -- source files. If the programmer calls Source_File_Data (Cache => True) + -- he is guaranteed that the price to retrieve the full name (i.e. with + -- directory info) or time stamp of the file will be payed only once, the + -- first time the full name is actually searched (or the first time the + -- time stamp is actually retrieved). This is achieved by employing a hash + -- table that stores as a key the File_Name_Type of the file and associates + -- to that File_Name_Type the full file name and time stamp of the file. + + File_Cache_Enabled : Boolean := False; + -- Set to true if you want the enable the file data caching mechanism + + type File_Hash_Num is range 0 .. 1020; + + function File_Hash (F : File_Name_Type) return File_Hash_Num; + -- Compute hash index for use by Simple_HTable + + type File_Info_Cache is record + File : File_Name_Type; + Attr : aliased File_Attributes; + end record; + + No_File_Info_Cache : constant File_Info_Cache := + (No_File, Unknown_Attributes); + + package File_Name_Hash_Table is new GNAT.HTable.Simple_HTable ( + Header_Num => File_Hash_Num, + Element => File_Info_Cache, + No_Element => No_File_Info_Cache, + Key => File_Name_Type, + Hash => File_Hash, + Equal => "="); + + function Smart_Find_File + (N : File_Name_Type; + T : File_Type) return File_Name_Type; + -- Exactly like Find_File except that if File_Cache_Enabled is True this + -- routine looks first in the hash table to see if the full name of the + -- file is already available. + + function Smart_File_Stamp + (N : File_Name_Type; + T : File_Type) return Time_Stamp_Type; + -- Takes the same parameter as the routine above (N is a file name without + -- any prefix directory information) and behaves like File_Stamp except + -- that if File_Cache_Enabled is True this routine looks first in the hash + -- table to see if the file stamp of the file is already available. + + ----------------------------- + -- Add_Default_Search_Dirs -- + ----------------------------- + + procedure Add_Default_Search_Dirs is + Search_Dir : String_Access; + Search_Path : String_Access; + Path_File_Name : String_Access; + + procedure Add_Search_Dir + (Search_Dir : String; + Additional_Source_Dir : Boolean); + procedure Add_Search_Dir + (Search_Dir : String_Access; + Additional_Source_Dir : Boolean); + -- Add a source search dir or a library search dir, depending on the + -- value of Additional_Source_Dir. + + procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean); + -- Open a path file and read the directory to search, one per line + + function Get_Libraries_From_Registry return String_Ptr; + -- On Windows systems, get the list of installed standard libraries + -- from the registry key: + -- + -- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\ + -- GNAT\Standard Libraries + -- Return an empty string on other systems. + -- + -- Note that this is an undocumented legacy feature, and that it + -- works only when using the default runtime library (i.e. no --RTS= + -- command line switch). + + -------------------- + -- Add_Search_Dir -- + -------------------- + + procedure Add_Search_Dir + (Search_Dir : String; + Additional_Source_Dir : Boolean) + is + begin + if Additional_Source_Dir then + Add_Src_Search_Dir (Search_Dir); + else + Add_Lib_Search_Dir (Search_Dir); + end if; + end Add_Search_Dir; + + procedure Add_Search_Dir + (Search_Dir : String_Access; + Additional_Source_Dir : Boolean) + is + begin + if Additional_Source_Dir then + Add_Src_Search_Dir (Search_Dir.all); + else + Add_Lib_Search_Dir (Search_Dir.all); + end if; + end Add_Search_Dir; + + ------------------------ + -- Get_Dirs_From_File -- + ------------------------ + + procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean) is + File_FD : File_Descriptor; + Buffer : constant String := Path_File_Name.all & ASCII.NUL; + Len : Natural; + Actual_Len : Natural; + S : String_Access; + Curr : Natural; + First : Natural; + Ch : Character; + + Status : Boolean; + pragma Warnings (Off, Status); + -- For the call to Close where status is ignored + + begin + File_FD := Open_Read (Buffer'Address, Binary); + + -- If we cannot open the file, we ignore it, we don't fail + + if File_FD = Invalid_FD then + return; + end if; + + Len := Integer (File_Length (File_FD)); + + S := new String (1 .. Len); + + -- Read the file. Note that the loop is not necessary since the + -- whole file is read at once except on VMS. + + Curr := 1; + Actual_Len := Len; + while Curr <= Len and then Actual_Len /= 0 loop + Actual_Len := Read (File_FD, S (Curr)'Address, Len); + Curr := Curr + Actual_Len; + end loop; + + -- We are done with the file, so we close it (ignore any error on + -- the close, since we have successfully read the file). + + Close (File_FD, Status); + + -- Now, we read line by line + + First := 1; + Curr := 0; + while Curr < Len loop + Ch := S (Curr + 1); + + if Ch = ASCII.CR or else Ch = ASCII.LF + or else Ch = ASCII.FF or else Ch = ASCII.VT + then + if First <= Curr then + Add_Search_Dir (S (First .. Curr), Additional_Source_Dir); + end if; + + First := Curr + 2; + end if; + + Curr := Curr + 1; + end loop; + + -- Last line is a special case, if the file does not end with + -- an end of line mark. + + if First <= S'Last then + Add_Search_Dir (S (First .. S'Last), Additional_Source_Dir); + end if; + end Get_Dirs_From_File; + + --------------------------------- + -- Get_Libraries_From_Registry -- + --------------------------------- + + function Get_Libraries_From_Registry return String_Ptr is + function C_Get_Libraries_From_Registry return Address; + pragma Import (C, C_Get_Libraries_From_Registry, + "__gnat_get_libraries_from_registry"); + + function Strlen (Str : Address) return Integer; + pragma Import (C, Strlen, "strlen"); + + procedure Strncpy (X : Address; Y : Address; Length : Integer); + pragma Import (C, Strncpy, "strncpy"); + + procedure C_Free (Str : Address); + pragma Import (C, C_Free, "free"); + + Result_Ptr : Address; + Result_Length : Integer; + Out_String : String_Ptr; + + begin + Result_Ptr := C_Get_Libraries_From_Registry; + Result_Length := Strlen (Result_Ptr); + + Out_String := new String (1 .. Result_Length); + Strncpy (Out_String.all'Address, Result_Ptr, Result_Length); + + C_Free (Result_Ptr); + + return Out_String; + end Get_Libraries_From_Registry; + + -- Start of processing for Add_Default_Search_Dirs + + begin + -- After the locations specified on the command line, the next places + -- to look for files are the directories specified by the appropriate + -- environment variable. Get this value, extract the directory names + -- and store in the tables. + + -- Check for eventual project path file env vars + + Path_File_Name := Getenv (Project_Include_Path_File); + + if Path_File_Name'Length > 0 then + Get_Dirs_From_File (Additional_Source_Dir => True); + end if; + + Path_File_Name := Getenv (Project_Objects_Path_File); + + if Path_File_Name'Length > 0 then + Get_Dirs_From_File (Additional_Source_Dir => False); + end if; + + -- On VMS, don't expand the logical name (e.g. environment variable), + -- just put it into Unix (e.g. canonical) format. System services + -- will handle the expansion as part of the file processing. + + for Additional_Source_Dir in False .. True loop + if Additional_Source_Dir then + Search_Path := Getenv (Ada_Include_Path); + + if Search_Path'Length > 0 then + if Hostparm.OpenVMS then + Search_Path := To_Canonical_Path_Spec ("ADA_INCLUDE_PATH:"); + else + Search_Path := To_Canonical_Path_Spec (Search_Path.all); + end if; + end if; + + else + Search_Path := Getenv (Ada_Objects_Path); + + if Search_Path'Length > 0 then + if Hostparm.OpenVMS then + Search_Path := To_Canonical_Path_Spec ("ADA_OBJECTS_PATH:"); + else + Search_Path := To_Canonical_Path_Spec (Search_Path.all); + end if; + end if; + end if; + + Get_Next_Dir_In_Path_Init (Search_Path); + loop + Search_Dir := Get_Next_Dir_In_Path (Search_Path); + exit when Search_Dir = null; + Add_Search_Dir (Search_Dir, Additional_Source_Dir); + end loop; + end loop; + + -- For the compiler, if --RTS= was specified, add the runtime + -- directories. + + if RTS_Src_Path_Name /= null + and then RTS_Lib_Path_Name /= null + then + Add_Search_Dirs (RTS_Src_Path_Name, Include); + Add_Search_Dirs (RTS_Lib_Path_Name, Objects); + + else + if not Opt.No_Stdinc then + + -- For WIN32 systems, look for any system libraries defined in + -- the registry. These are added to both source and object + -- directories. + + Search_Path := String_Access (Get_Libraries_From_Registry); + + Get_Next_Dir_In_Path_Init (Search_Path); + loop + Search_Dir := Get_Next_Dir_In_Path (Search_Path); + exit when Search_Dir = null; + Add_Search_Dir (Search_Dir, False); + Add_Search_Dir (Search_Dir, True); + end loop; + + -- The last place to look are the defaults + + Search_Path := + Read_Default_Search_Dirs + (String_Access (Update_Path (Search_Dir_Prefix)), + Include_Search_File, + String_Access (Update_Path (Include_Dir_Default_Name))); + + Get_Next_Dir_In_Path_Init (Search_Path); + loop + Search_Dir := Get_Next_Dir_In_Path (Search_Path); + exit when Search_Dir = null; + Add_Search_Dir (Search_Dir, True); + end loop; + end if; + + -- Even when -nostdlib is used, we still want to have visibility on + -- the run-time object directory, as it is used by gnatbind to find + -- the run-time ALI files in "real" ZFP set up. + + if not Opt.RTS_Switch then + Search_Path := + Read_Default_Search_Dirs + (String_Access (Update_Path (Search_Dir_Prefix)), + Objects_Search_File, + String_Access (Update_Path (Object_Dir_Default_Name))); + + Get_Next_Dir_In_Path_Init (Search_Path); + loop + Search_Dir := Get_Next_Dir_In_Path (Search_Path); + exit when Search_Dir = null; + Add_Search_Dir (Search_Dir, False); + end loop; + end if; + end if; + end Add_Default_Search_Dirs; + + -------------- + -- Add_File -- + -------------- + + procedure Add_File (File_Name : String; Index : Int := No_Index) is + begin + Number_File_Names := Number_File_Names + 1; + + -- As Add_File may be called for mains specified inside a project file, + -- File_Names may be too short and needs to be extended. + + if Number_File_Names > File_Names'Last then + File_Names := new File_Name_Array'(File_Names.all & File_Names.all); + File_Indexes := + new File_Index_Array'(File_Indexes.all & File_Indexes.all); + end if; + + File_Names (Number_File_Names) := new String'(File_Name); + File_Indexes (Number_File_Names) := Index; + end Add_File; + + ------------------------ + -- Add_Lib_Search_Dir -- + ------------------------ + + procedure Add_Lib_Search_Dir (Dir : String) is + begin + if Dir'Length = 0 then + Fail ("missing library directory name"); + end if; + + declare + Norm : String_Ptr := Normalize_Directory_Name (Dir); + + begin + -- Do nothing if the directory is already in the list. This saves + -- system calls and avoid unneeded work + + for D in Lib_Search_Directories.First .. + Lib_Search_Directories.Last + loop + if Lib_Search_Directories.Table (D).all = Norm.all then + Free (Norm); + return; + end if; + end loop; + + Lib_Search_Directories.Increment_Last; + Lib_Search_Directories.Table (Lib_Search_Directories.Last) := Norm; + end; + end Add_Lib_Search_Dir; + + --------------------- + -- Add_Search_Dirs -- + --------------------- + + procedure Add_Search_Dirs + (Search_Path : String_Ptr; + Path_Type : Search_File_Type) + is + Current_Search_Path : String_Access; + + begin + Get_Next_Dir_In_Path_Init (String_Access (Search_Path)); + loop + Current_Search_Path := + Get_Next_Dir_In_Path (String_Access (Search_Path)); + exit when Current_Search_Path = null; + + if Path_Type = Include then + Add_Src_Search_Dir (Current_Search_Path.all); + else + Add_Lib_Search_Dir (Current_Search_Path.all); + end if; + end loop; + end Add_Search_Dirs; + + ------------------------ + -- Add_Src_Search_Dir -- + ------------------------ + + procedure Add_Src_Search_Dir (Dir : String) is + begin + if Dir'Length = 0 then + Fail ("missing source directory name"); + end if; + + Src_Search_Directories.Increment_Last; + Src_Search_Directories.Table (Src_Search_Directories.Last) := + Normalize_Directory_Name (Dir); + end Add_Src_Search_Dir; + + -------------------------------- + -- Append_Suffix_To_File_Name -- + -------------------------------- + + function Append_Suffix_To_File_Name + (Name : File_Name_Type; + Suffix : String) return File_Name_Type + is + begin + Get_Name_String (Name); + Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix; + Name_Len := Name_Len + Suffix'Length; + return Name_Find; + end Append_Suffix_To_File_Name; + + --------------------- + -- C_String_Length -- + --------------------- + + function C_String_Length (S : Address) return Integer is + function Strlen (S : Address) return Integer; + pragma Import (C, Strlen, "strlen"); + begin + if S = Null_Address then + return 0; + else + return Strlen (S); + end if; + end C_String_Length; + + ------------------------------ + -- Canonical_Case_File_Name -- + ------------------------------ + + procedure Canonical_Case_File_Name (S : in out String) is + begin + if not File_Names_Case_Sensitive then + To_Lower (S); + end if; + end Canonical_Case_File_Name; + + --------------------------------- + -- Canonical_Case_Env_Var_Name -- + --------------------------------- + + procedure Canonical_Case_Env_Var_Name (S : in out String) is + begin + if not Env_Vars_Case_Sensitive then + To_Lower (S); + end if; + end Canonical_Case_Env_Var_Name; + + --------------------------- + -- Create_File_And_Check -- + --------------------------- + + procedure Create_File_And_Check + (Fdesc : out File_Descriptor; + Fmode : Mode) + is + begin + Output_File_Name := Name_Enter; + Fdesc := Create_File (Name_Buffer'Address, Fmode); + + if Fdesc = Invalid_FD then + Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len)); + end if; + end Create_File_And_Check; + + ------------------------ + -- Current_File_Index -- + ------------------------ + + function Current_File_Index return Int is + begin + return File_Indexes (Current_File_Name_Index); + end Current_File_Index; + + -------------------------------- + -- Current_Library_File_Stamp -- + -------------------------------- + + function Current_Library_File_Stamp return Time_Stamp_Type is + begin + return Current_Full_Lib_Stamp; + end Current_Library_File_Stamp; + + ------------------------------- + -- Current_Object_File_Stamp -- + ------------------------------- + + function Current_Object_File_Stamp return Time_Stamp_Type is + begin + return Current_Full_Obj_Stamp; + end Current_Object_File_Stamp; + + ------------------------------- + -- Current_Source_File_Stamp -- + ------------------------------- + + function Current_Source_File_Stamp return Time_Stamp_Type is + begin + return Current_Full_Source_Stamp; + end Current_Source_File_Stamp; + + ---------------------------- + -- Dir_In_Obj_Search_Path -- + ---------------------------- + + function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr is + begin + if Opt.Look_In_Primary_Dir then + return + Lib_Search_Directories.Table (Primary_Directory + Position - 1); + else + return Lib_Search_Directories.Table (Primary_Directory + Position); + end if; + end Dir_In_Obj_Search_Path; + + ---------------------------- + -- Dir_In_Src_Search_Path -- + ---------------------------- + + function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr is + begin + if Opt.Look_In_Primary_Dir then + return + Src_Search_Directories.Table (Primary_Directory + Position - 1); + else + return Src_Search_Directories.Table (Primary_Directory + Position); + end if; + end Dir_In_Src_Search_Path; + + ---------------------------- + -- Dump_Source_File_Names -- + ---------------------------- + + procedure Dump_Source_File_Names is + subtype Rng is Int range File_Name_Chars.First .. File_Name_Chars.Last; + begin + Write_Str (String (File_Name_Chars.Table (Rng))); + end Dump_Source_File_Names; + + --------------------- + -- Executable_Name -- + --------------------- + + function Executable_Name + (Name : File_Name_Type; + Only_If_No_Suffix : Boolean := False) return File_Name_Type + is + Exec_Suffix : String_Access; + Add_Suffix : Boolean; + + begin + if Name = No_File then + return No_File; + end if; + + if Executable_Extension_On_Target = No_Name then + Exec_Suffix := Get_Target_Executable_Suffix; + else + Get_Name_String (Executable_Extension_On_Target); + Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len)); + end if; + + if Exec_Suffix'Length /= 0 then + Get_Name_String (Name); + + Add_Suffix := True; + if Only_If_No_Suffix then + for J in reverse 1 .. Name_Len loop + if Name_Buffer (J) = '.' then + Add_Suffix := False; + exit; + + elsif Name_Buffer (J) = '/' or else + Name_Buffer (J) = Directory_Separator + then + exit; + end if; + end loop; + end if; + + if Add_Suffix then + declare + Buffer : String := Name_Buffer (1 .. Name_Len); + + begin + -- Get the file name in canonical case to accept as is names + -- ending with ".EXE" on VMS and Windows. + + Canonical_Case_File_Name (Buffer); + + -- If Executable does not end with the executable suffix, add + -- it. + + if Buffer'Length <= Exec_Suffix'Length + or else + Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last) + /= Exec_Suffix.all + then + Name_Buffer + (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) := + Exec_Suffix.all; + Name_Len := Name_Len + Exec_Suffix'Length; + Free (Exec_Suffix); + return Name_Find; + end if; + end; + end if; + end if; + + Free (Exec_Suffix); + return Name; + end Executable_Name; + + function Executable_Name + (Name : String; + Only_If_No_Suffix : Boolean := False) return String + is + Exec_Suffix : String_Access; + Add_Suffix : Boolean; + Canonical_Name : String := Name; + + begin + if Executable_Extension_On_Target = No_Name then + Exec_Suffix := Get_Target_Executable_Suffix; + else + Get_Name_String (Executable_Extension_On_Target); + Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len)); + end if; + + if Exec_Suffix'Length = 0 then + Free (Exec_Suffix); + return Name; + + else + declare + Suffix : constant String := Exec_Suffix.all; + + begin + Free (Exec_Suffix); + Canonical_Case_File_Name (Canonical_Name); + + Add_Suffix := True; + if Only_If_No_Suffix then + for J in reverse Canonical_Name'Range loop + if Canonical_Name (J) = '.' then + Add_Suffix := False; + exit; + + elsif Canonical_Name (J) = '/' or else + Canonical_Name (J) = Directory_Separator + then + exit; + end if; + end loop; + end if; + + if Add_Suffix and then + (Canonical_Name'Length <= Suffix'Length + or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1 + .. Canonical_Name'Last) /= Suffix) + then + declare + Result : String (1 .. Name'Length + Suffix'Length); + begin + Result (1 .. Name'Length) := Name; + Result (Name'Length + 1 .. Result'Last) := Suffix; + return Result; + end; + else + return Name; + end if; + end; + end if; + end Executable_Name; + + ----------------------- + -- Executable_Prefix -- + ----------------------- + + function Executable_Prefix return String_Ptr is + + function Get_Install_Dir (Exec : String) return String_Ptr; + -- S is the executable name preceded by the absolute or relative + -- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc". + + --------------------- + -- Get_Install_Dir -- + --------------------- + + function Get_Install_Dir (Exec : String) return String_Ptr is + Full_Path : constant String := Normalize_Pathname (Exec); + -- Use the full path, so that we find "lib" or "bin", even when + -- the tool has been invoked with a relative path, as in + -- "./gnatls -v" invoked in the GNAT bin directory. + + begin + for J in reverse Full_Path'Range loop + if Is_Directory_Separator (Full_Path (J)) then + if J < Full_Path'Last - 5 then + if (To_Lower (Full_Path (J + 1)) = 'l' + and then To_Lower (Full_Path (J + 2)) = 'i' + and then To_Lower (Full_Path (J + 3)) = 'b') + or else + (To_Lower (Full_Path (J + 1)) = 'b' + and then To_Lower (Full_Path (J + 2)) = 'i' + and then To_Lower (Full_Path (J + 3)) = 'n') + then + return new String'(Full_Path (Full_Path'First .. J)); + end if; + end if; + end if; + end loop; + + return new String'(""); + end Get_Install_Dir; + + -- Start of processing for Executable_Prefix + + begin + if Exec_Name = null then + Exec_Name := new String (1 .. Len_Arg (0)); + Osint.Fill_Arg (Exec_Name (1)'Address, 0); + end if; + + -- First determine if a path prefix was placed in front of the + -- executable name. + + for J in reverse Exec_Name'Range loop + if Is_Directory_Separator (Exec_Name (J)) then + return Get_Install_Dir (Exec_Name.all); + end if; + end loop; + + -- If we come here, the user has typed the executable name with no + -- directory prefix. + + return Get_Install_Dir (Locate_Exec_On_Path (Exec_Name.all).all); + end Executable_Prefix; + + ------------------ + -- Exit_Program -- + ------------------ + + procedure Exit_Program (Exit_Code : Exit_Code_Type) is + begin + -- The program will exit with the following status: + + -- 0 if the object file has been generated (with or without warnings) + -- 1 if recompilation was not needed (smart recompilation) + -- 2 if gnat1 has been killed by a signal (detected by GCC) + -- 4 for a fatal error + -- 5 if there were errors + -- 6 if no code has been generated (spec) + + -- Note that exit code 3 is not used and must not be used as this is + -- the code returned by a program aborted via C abort() routine on + -- Windows. GCC checks for that case and thinks that the child process + -- has been aborted. This code (exit code 3) used to be the code used + -- for E_No_Code, but E_No_Code was changed to 6 for this reason. + + case Exit_Code is + when E_Success => OS_Exit (0); + when E_Warnings => OS_Exit (0); + when E_No_Compile => OS_Exit (1); + when E_Fatal => OS_Exit (4); + when E_Errors => OS_Exit (5); + when E_No_Code => OS_Exit (6); + when E_Abort => OS_Abort; + end case; + end Exit_Program; + + ---------- + -- Fail -- + ---------- + + procedure Fail (S : String) is + begin + -- We use Output in case there is a special output set up. + -- In this case Set_Standard_Error will have no immediate effect. + + Set_Standard_Error; + Osint.Write_Program_Name; + Write_Str (": "); + Write_Str (S); + Write_Eol; + + Exit_Program (E_Fatal); + end Fail; + + --------------- + -- File_Hash -- + --------------- + + function File_Hash (F : File_Name_Type) return File_Hash_Num is + begin + return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length); + end File_Hash; + + ----------------- + -- File_Length -- + ----------------- + + function File_Length + (Name : C_File_Name; + Attr : access File_Attributes) return Long_Integer + is + function Internal + (F : Integer; + N : C_File_Name; + A : System.Address) return Long_Integer; + pragma Import (C, Internal, "__gnat_file_length_attr"); + begin + return Internal (-1, Name, Attr.all'Address); + end File_Length; + + --------------------- + -- File_Time_Stamp -- + --------------------- + + function File_Time_Stamp + (Name : C_File_Name; + Attr : access File_Attributes) return OS_Time + is + function Internal (N : C_File_Name; A : System.Address) return OS_Time; + pragma Import (C, Internal, "__gnat_file_time_name_attr"); + begin + return Internal (Name, Attr.all'Address); + end File_Time_Stamp; + + function File_Time_Stamp + (Name : Path_Name_Type; + Attr : access File_Attributes) return Time_Stamp_Type + is + begin + if Name = No_Path then + return Empty_Time_Stamp; + end if; + + Get_Name_String (Name); + Name_Buffer (Name_Len + 1) := ASCII.NUL; + return OS_Time_To_GNAT_Time + (File_Time_Stamp (Name_Buffer'Address, Attr)); + end File_Time_Stamp; + + ---------------- + -- File_Stamp -- + ---------------- + + function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is + begin + if Name = No_File then + return Empty_Time_Stamp; + end if; + + Get_Name_String (Name); + + -- File_Time_Stamp will always return Invalid_Time if the file does + -- not exist, and OS_Time_To_GNAT_Time will convert this value to + -- Empty_Time_Stamp. Therefore we do not need to first test whether + -- the file actually exists, which saves a system call. + + return OS_Time_To_GNAT_Time + (File_Time_Stamp (Name_Buffer (1 .. Name_Len))); + end File_Stamp; + + function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is + begin + return File_Stamp (File_Name_Type (Name)); + end File_Stamp; + + --------------- + -- Find_File -- + --------------- + + function Find_File + (N : File_Name_Type; + T : File_Type) return File_Name_Type + is + Attr : aliased File_Attributes; + Found : File_Name_Type; + begin + Find_File (N, T, Found, Attr'Access); + return Found; + end Find_File; + + --------------- + -- Find_File -- + --------------- + + procedure Find_File + (N : File_Name_Type; + T : File_Type; + Found : out File_Name_Type; + Attr : access File_Attributes) is + begin + Get_Name_String (N); + + declare + File_Name : String renames Name_Buffer (1 .. Name_Len); + File : File_Name_Type := No_File; + Last_Dir : Natural; + + begin + -- If we are looking for a config file, look only in the current + -- directory, i.e. return input argument unchanged. Also look only in + -- the current directory if we are looking for a .dg file (happens in + -- -gnatD mode). + + if T = Config + or else (Debug_Generated_Code + and then Name_Len > 3 + and then + (Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg" + or else + (Hostparm.OpenVMS and then + Name_Buffer (Name_Len - 2 .. Name_Len) = "_dg"))) + then + Found := N; + Attr.all := Unknown_Attributes; + return; + + -- If we are trying to find the current main file just look in the + -- directory where the user said it was. + + elsif Look_In_Primary_Directory_For_Current_Main + and then Current_Main = N + then + Locate_File (N, T, Primary_Directory, File_Name, Found, Attr); + return; + + -- Otherwise do standard search for source file + + else + -- Check the mapping of this file name + + File := Mapped_Path_Name (N); + + -- If the file name is mapped to a path name, return the + -- corresponding path name + + if File /= No_File then + + -- For locally removed file, Error_Name is returned; then + -- return No_File, indicating the file is not a source. + + if File = Error_File_Name then + Found := No_File; + else + Found := File; + end if; + + Attr.all := Unknown_Attributes; + return; + end if; + + -- First place to look is in the primary directory (i.e. the same + -- directory as the source) unless this has been disabled with -I- + + if Opt.Look_In_Primary_Dir then + Locate_File (N, T, Primary_Directory, File_Name, Found, Attr); + + if Found /= No_File then + return; + end if; + end if; + + -- Finally look in directories specified with switches -I/-aI/-aO + + if T = Library then + Last_Dir := Lib_Search_Directories.Last; + else + Last_Dir := Src_Search_Directories.Last; + end if; + + for D in Primary_Directory + 1 .. Last_Dir loop + Locate_File (N, T, D, File_Name, Found, Attr); + + if Found /= No_File then + return; + end if; + end loop; + + Attr.all := Unknown_Attributes; + Found := No_File; + end if; + end; + end Find_File; + + ----------------------- + -- Find_Program_Name -- + ----------------------- + + procedure Find_Program_Name is + Command_Name : String (1 .. Len_Arg (0)); + Cindex1 : Integer := Command_Name'First; + Cindex2 : Integer := Command_Name'Last; + + begin + Fill_Arg (Command_Name'Address, 0); + + if Command_Name = "" then + Name_Len := 0; + return; + end if; + + -- The program name might be specified by a full path name. However, + -- we don't want to print that all out in an error message, so the + -- path might need to be stripped away. + + for J in reverse Cindex1 .. Cindex2 loop + if Is_Directory_Separator (Command_Name (J)) then + Cindex1 := J + 1; + exit; + end if; + end loop; + + -- Command_Name(Cindex1 .. Cindex2) is now the equivalent of the + -- POSIX command "basename argv[0]" + + -- Strip off any versioning information such as found on VMS. + -- This would take the form of TOOL.exe followed by a ";" or "." + -- and a sequence of one or more numbers. + + if Command_Name (Cindex2) in '0' .. '9' then + for J in reverse Cindex1 .. Cindex2 loop + if Command_Name (J) = '.' or else Command_Name (J) = ';' then + Cindex2 := J - 1; + exit; + end if; + + exit when Command_Name (J) not in '0' .. '9'; + end loop; + end if; + + -- Strip off any executable extension (usually nothing or .exe) + -- but formally reported by autoconf in the variable EXEEXT + + if Cindex2 - Cindex1 >= 4 then + if To_Lower (Command_Name (Cindex2 - 3)) = '.' + and then To_Lower (Command_Name (Cindex2 - 2)) = 'e' + and then To_Lower (Command_Name (Cindex2 - 1)) = 'x' + and then To_Lower (Command_Name (Cindex2)) = 'e' + then + Cindex2 := Cindex2 - 4; + end if; + end if; + + Name_Len := Cindex2 - Cindex1 + 1; + Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2); + end Find_Program_Name; + + ------------------------ + -- Full_Lib_File_Name -- + ------------------------ + + procedure Full_Lib_File_Name + (N : File_Name_Type; + Lib_File : out File_Name_Type; + Attr : out File_Attributes) + is + A : aliased File_Attributes; + begin + -- ??? seems we could use Smart_Find_File here + Find_File (N, Library, Lib_File, A'Access); + Attr := A; + end Full_Lib_File_Name; + + ------------------------ + -- Full_Lib_File_Name -- + ------------------------ + + function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is + Attr : File_Attributes; + File : File_Name_Type; + begin + Full_Lib_File_Name (N, File, Attr); + return File; + end Full_Lib_File_Name; + + ---------------------------- + -- Full_Library_Info_Name -- + ---------------------------- + + function Full_Library_Info_Name return File_Name_Type is + begin + return Current_Full_Lib_Name; + end Full_Library_Info_Name; + + --------------------------- + -- Full_Object_File_Name -- + --------------------------- + + function Full_Object_File_Name return File_Name_Type is + begin + return Current_Full_Obj_Name; + end Full_Object_File_Name; + + ---------------------- + -- Full_Source_Name -- + ---------------------- + + function Full_Source_Name return File_Name_Type is + begin + return Current_Full_Source_Name; + end Full_Source_Name; + + ---------------------- + -- Full_Source_Name -- + ---------------------- + + function Full_Source_Name (N : File_Name_Type) return File_Name_Type is + begin + return Smart_Find_File (N, Source); + end Full_Source_Name; + + ---------------------- + -- Full_Source_Name -- + ---------------------- + + procedure Full_Source_Name + (N : File_Name_Type; + Full_File : out File_Name_Type; + Attr : access File_Attributes) is + begin + Smart_Find_File (N, Source, Full_File, Attr.all); + end Full_Source_Name; + + ------------------- + -- Get_Directory -- + ------------------- + + function Get_Directory (Name : File_Name_Type) return File_Name_Type is + begin + Get_Name_String (Name); + + for J in reverse 1 .. Name_Len loop + if Is_Directory_Separator (Name_Buffer (J)) then + Name_Len := J; + return Name_Find; + end if; + end loop; + + Name_Len := Hostparm.Normalized_CWD'Length; + Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD; + return Name_Find; + end Get_Directory; + + -------------------------- + -- Get_Next_Dir_In_Path -- + -------------------------- + + Search_Path_Pos : Integer; + -- Keeps track of current position in search path. Initialized by the + -- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path. + + function Get_Next_Dir_In_Path + (Search_Path : String_Access) return String_Access + is + Lower_Bound : Positive := Search_Path_Pos; + Upper_Bound : Positive; + + begin + loop + while Lower_Bound <= Search_Path'Last + and then Search_Path.all (Lower_Bound) = Path_Separator + loop + Lower_Bound := Lower_Bound + 1; + end loop; + + exit when Lower_Bound > Search_Path'Last; + + Upper_Bound := Lower_Bound; + while Upper_Bound <= Search_Path'Last + and then Search_Path.all (Upper_Bound) /= Path_Separator + loop + Upper_Bound := Upper_Bound + 1; + end loop; + + Search_Path_Pos := Upper_Bound; + return new String'(Search_Path.all (Lower_Bound .. Upper_Bound - 1)); + end loop; + + return null; + end Get_Next_Dir_In_Path; + + ------------------------------- + -- Get_Next_Dir_In_Path_Init -- + ------------------------------- + + procedure Get_Next_Dir_In_Path_Init (Search_Path : String_Access) is + begin + Search_Path_Pos := Search_Path'First; + end Get_Next_Dir_In_Path_Init; + + -------------------------------------- + -- Get_Primary_Src_Search_Directory -- + -------------------------------------- + + function Get_Primary_Src_Search_Directory return String_Ptr is + begin + return Src_Search_Directories.Table (Primary_Directory); + end Get_Primary_Src_Search_Directory; + + ------------------------ + -- Get_RTS_Search_Dir -- + ------------------------ + + function Get_RTS_Search_Dir + (Search_Dir : String; + File_Type : Search_File_Type) return String_Ptr + is + procedure Get_Current_Dir + (Dir : System.Address; + Length : System.Address); + pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir"); + + Max_Path : Integer; + pragma Import (C, Max_Path, "__gnat_max_path_len"); + -- Maximum length of a path name + + Current_Dir : String_Ptr; + Default_Search_Dir : String_Access; + Default_Suffix_Dir : String_Access; + Local_Search_Dir : String_Access; + Norm_Search_Dir : String_Access; + Result_Search_Dir : String_Access; + Search_File : String_Access; + Temp_String : String_Ptr; + + begin + -- Add a directory separator at the end of the directory if necessary + -- so that we can directly append a file to the directory + + if Search_Dir (Search_Dir'Last) /= Directory_Separator then + Local_Search_Dir := + new String'(Search_Dir & String'(1 => Directory_Separator)); + else + Local_Search_Dir := new String'(Search_Dir); + end if; + + if File_Type = Include then + Search_File := Include_Search_File; + Default_Suffix_Dir := new String'("adainclude"); + else + Search_File := Objects_Search_File; + Default_Suffix_Dir := new String'("adalib"); + end if; + + Norm_Search_Dir := To_Canonical_Path_Spec (Local_Search_Dir.all); + + if Is_Absolute_Path (Norm_Search_Dir.all) then + + -- We first verify if there is a directory Include_Search_Dir + -- containing default search directories + + Result_Search_Dir := + Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null); + Default_Search_Dir := + new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all); + Free (Norm_Search_Dir); + + if Result_Search_Dir /= null then + return String_Ptr (Result_Search_Dir); + elsif Is_Directory (Default_Search_Dir.all) then + return String_Ptr (Default_Search_Dir); + else + return null; + end if; + + -- Search in the current directory + + else + -- Get the current directory + + declare + Buffer : String (1 .. Max_Path + 2); + Path_Len : Natural := Max_Path; + + begin + Get_Current_Dir (Buffer'Address, Path_Len'Address); + + if Buffer (Path_Len) /= Directory_Separator then + Path_Len := Path_Len + 1; + Buffer (Path_Len) := Directory_Separator; + end if; + + Current_Dir := new String'(Buffer (1 .. Path_Len)); + end; + + Norm_Search_Dir := + new String'(Current_Dir.all & Local_Search_Dir.all); + + Result_Search_Dir := + Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null); + + Default_Search_Dir := + new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all); + + Free (Norm_Search_Dir); + + if Result_Search_Dir /= null then + return String_Ptr (Result_Search_Dir); + + elsif Is_Directory (Default_Search_Dir.all) then + return String_Ptr (Default_Search_Dir); + + else + -- Search in Search_Dir_Prefix/Search_Dir + + Norm_Search_Dir := + new String' + (Update_Path (Search_Dir_Prefix).all & Local_Search_Dir.all); + + Result_Search_Dir := + Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null); + + Default_Search_Dir := + new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all); + + Free (Norm_Search_Dir); + + if Result_Search_Dir /= null then + return String_Ptr (Result_Search_Dir); + + elsif Is_Directory (Default_Search_Dir.all) then + return String_Ptr (Default_Search_Dir); + + else + -- We finally search in Search_Dir_Prefix/rts-Search_Dir + + Temp_String := + new String'(Update_Path (Search_Dir_Prefix).all & "rts-"); + + Norm_Search_Dir := + new String'(Temp_String.all & Local_Search_Dir.all); + + Result_Search_Dir := + Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null); + + Default_Search_Dir := + new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all); + Free (Norm_Search_Dir); + + if Result_Search_Dir /= null then + return String_Ptr (Result_Search_Dir); + + elsif Is_Directory (Default_Search_Dir.all) then + return String_Ptr (Default_Search_Dir); + + else + return null; + end if; + end if; + end if; + end if; + end Get_RTS_Search_Dir; + + -------------------------------- + -- Include_Dir_Default_Prefix -- + -------------------------------- + + function Include_Dir_Default_Prefix return String_Access is + begin + if The_Include_Dir_Default_Prefix = null then + The_Include_Dir_Default_Prefix := + String_Access (Update_Path (Include_Dir_Default_Name)); + end if; + + return The_Include_Dir_Default_Prefix; + end Include_Dir_Default_Prefix; + + function Include_Dir_Default_Prefix return String is + begin + return Include_Dir_Default_Prefix.all; + end Include_Dir_Default_Prefix; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Number_File_Names := 0; + Current_File_Name_Index := 0; + + Src_Search_Directories.Init; + Lib_Search_Directories.Init; + + -- Start off by setting all suppress options to False, these will + -- be reset later (turning some on if -gnato is not specified, and + -- turning all of them on if -gnatp is specified). + + Suppress_Options := (others => False); + + -- Reserve the first slot in the search paths table. This is the + -- directory of the main source file or main library file and is filled + -- in by each call to Next_Main_Source/Next_Main_Lib_File with the + -- directory specified for this main source or library file. This is the + -- directory which is searched first by default. This default search is + -- inhibited by the option -I- for both source and library files. + + Src_Search_Directories.Set_Last (Primary_Directory); + Src_Search_Directories.Table (Primary_Directory) := new String'(""); + + Lib_Search_Directories.Set_Last (Primary_Directory); + Lib_Search_Directories.Table (Primary_Directory) := new String'(""); + end Initialize; + + ------------------ + -- Is_Directory -- + ------------------ + + function Is_Directory + (Name : C_File_Name; Attr : access File_Attributes) return Boolean + is + function Internal (N : C_File_Name; A : System.Address) return Integer; + pragma Import (C, Internal, "__gnat_is_directory_attr"); + begin + return Internal (Name, Attr.all'Address) /= 0; + end Is_Directory; + + ---------------------------- + -- Is_Directory_Separator -- + ---------------------------- + + function Is_Directory_Separator (C : Character) return Boolean is + begin + -- In addition to the default directory_separator allow the '/' to + -- act as separator since this is allowed in MS-DOS, Windows 95/NT, + -- and OS2 ports. On VMS, the situation is more complicated because + -- there are two characters to check for. + + return + C = Directory_Separator + or else C = '/' + or else (Hostparm.OpenVMS + and then (C = ']' or else C = ':')); + end Is_Directory_Separator; + + ------------------------- + -- Is_Readonly_Library -- + ------------------------- + + function Is_Readonly_Library (File : File_Name_Type) return Boolean is + begin + Get_Name_String (File); + + pragma Assert (Name_Buffer (Name_Len - 3 .. Name_Len) = ".ali"); + + return not Is_Writable_File (Name_Buffer (1 .. Name_Len)); + end Is_Readonly_Library; + + ------------------------ + -- Is_Executable_File -- + ------------------------ + + function Is_Executable_File + (Name : C_File_Name; Attr : access File_Attributes) return Boolean + is + function Internal (N : C_File_Name; A : System.Address) return Integer; + pragma Import (C, Internal, "__gnat_is_executable_file_attr"); + begin + return Internal (Name, Attr.all'Address) /= 0; + end Is_Executable_File; + + ---------------------- + -- Is_Readable_File -- + ---------------------- + + function Is_Readable_File + (Name : C_File_Name; Attr : access File_Attributes) return Boolean + is + function Internal (N : C_File_Name; A : System.Address) return Integer; + pragma Import (C, Internal, "__gnat_is_readable_file_attr"); + begin + return Internal (Name, Attr.all'Address) /= 0; + end Is_Readable_File; + + --------------------- + -- Is_Regular_File -- + --------------------- + + function Is_Regular_File + (Name : C_File_Name; Attr : access File_Attributes) return Boolean + is + function Internal (N : C_File_Name; A : System.Address) return Integer; + pragma Import (C, Internal, "__gnat_is_regular_file_attr"); + begin + return Internal (Name, Attr.all'Address) /= 0; + end Is_Regular_File; + + ---------------------- + -- Is_Symbolic_Link -- + ---------------------- + + function Is_Symbolic_Link + (Name : C_File_Name; Attr : access File_Attributes) return Boolean + is + function Internal (N : C_File_Name; A : System.Address) return Integer; + pragma Import (C, Internal, "__gnat_is_symbolic_link_attr"); + begin + return Internal (Name, Attr.all'Address) /= 0; + end Is_Symbolic_Link; + + ---------------------- + -- Is_Writable_File -- + ---------------------- + + function Is_Writable_File + (Name : C_File_Name; Attr : access File_Attributes) return Boolean + is + function Internal (N : C_File_Name; A : System.Address) return Integer; + pragma Import (C, Internal, "__gnat_is_writable_file_attr"); + begin + return Internal (Name, Attr.all'Address) /= 0; + end Is_Writable_File; + + ------------------- + -- Lib_File_Name -- + ------------------- + + function Lib_File_Name + (Source_File : File_Name_Type; + Munit_Index : Nat := 0) return File_Name_Type + is + begin + Get_Name_String (Source_File); + + for J in reverse 2 .. Name_Len loop + if Name_Buffer (J) = '.' then + Name_Len := J - 1; + exit; + end if; + end loop; + + if Munit_Index /= 0 then + Add_Char_To_Name_Buffer (Multi_Unit_Index_Character); + Add_Nat_To_Name_Buffer (Munit_Index); + end if; + + Add_Char_To_Name_Buffer ('.'); + Add_Str_To_Name_Buffer (ALI_Suffix.all); + return Name_Find; + end Lib_File_Name; + + ----------------- + -- Locate_File -- + ----------------- + + procedure Locate_File + (N : File_Name_Type; + T : File_Type; + Dir : Natural; + Name : String; + Found : out File_Name_Type; + Attr : access File_Attributes) + is + Dir_Name : String_Ptr; + + begin + -- If Name is already an absolute path, do not look for a directory + + if Is_Absolute_Path (Name) then + Dir_Name := No_Dir; + + elsif T = Library then + Dir_Name := Lib_Search_Directories.Table (Dir); + + else + pragma Assert (T /= Config); + Dir_Name := Src_Search_Directories.Table (Dir); + end if; + + declare + Full_Name : String (1 .. Dir_Name'Length + Name'Length + 1); + + begin + Full_Name (1 .. Dir_Name'Length) := Dir_Name.all; + Full_Name (Dir_Name'Length + 1 .. Full_Name'Last - 1) := Name; + Full_Name (Full_Name'Last) := ASCII.NUL; + + Attr.all := Unknown_Attributes; + + if not Is_Regular_File (Full_Name'Address, Attr) then + Found := No_File; + + else + -- If the file is in the current directory then return N itself + + if Dir_Name'Length = 0 then + Found := N; + else + Name_Len := Full_Name'Length - 1; + Name_Buffer (1 .. Name_Len) := + Full_Name (1 .. Full_Name'Last - 1); + Found := Name_Find; -- ??? Was Name_Enter, no obvious reason + end if; + end if; + end; + end Locate_File; + + ------------------------------- + -- Matching_Full_Source_Name -- + ------------------------------- + + function Matching_Full_Source_Name + (N : File_Name_Type; + T : Time_Stamp_Type) return File_Name_Type + is + begin + Get_Name_String (N); + + declare + File_Name : constant String := Name_Buffer (1 .. Name_Len); + File : File_Name_Type := No_File; + Attr : aliased File_Attributes; + Last_Dir : Natural; + + begin + if Opt.Look_In_Primary_Dir then + Locate_File + (N, Source, Primary_Directory, File_Name, File, Attr'Access); + + if File /= No_File and then T = File_Stamp (N) then + return File; + end if; + end if; + + Last_Dir := Src_Search_Directories.Last; + + for D in Primary_Directory + 1 .. Last_Dir loop + Locate_File (N, Source, D, File_Name, File, Attr'Access); + + if File /= No_File and then T = File_Stamp (File) then + return File; + end if; + end loop; + + return No_File; + end; + end Matching_Full_Source_Name; + + ---------------- + -- More_Files -- + ---------------- + + function More_Files return Boolean is + begin + return (Current_File_Name_Index < Number_File_Names); + end More_Files; + + ------------------------------- + -- Nb_Dir_In_Obj_Search_Path -- + ------------------------------- + + function Nb_Dir_In_Obj_Search_Path return Natural is + begin + if Opt.Look_In_Primary_Dir then + return Lib_Search_Directories.Last - Primary_Directory + 1; + else + return Lib_Search_Directories.Last - Primary_Directory; + end if; + end Nb_Dir_In_Obj_Search_Path; + + ------------------------------- + -- Nb_Dir_In_Src_Search_Path -- + ------------------------------- + + function Nb_Dir_In_Src_Search_Path return Natural is + begin + if Opt.Look_In_Primary_Dir then + return Src_Search_Directories.Last - Primary_Directory + 1; + else + return Src_Search_Directories.Last - Primary_Directory; + end if; + end Nb_Dir_In_Src_Search_Path; + + -------------------- + -- Next_Main_File -- + -------------------- + + function Next_Main_File return File_Name_Type is + File_Name : String_Ptr; + Dir_Name : String_Ptr; + Fptr : Natural; + + begin + pragma Assert (More_Files); + + Current_File_Name_Index := Current_File_Name_Index + 1; + + -- Get the file and directory name + + File_Name := File_Names (Current_File_Name_Index); + Fptr := File_Name'First; + + for J in reverse File_Name'Range loop + if File_Name (J) = Directory_Separator + or else File_Name (J) = '/' + then + if J = File_Name'Last then + Fail ("File name missing"); + end if; + + Fptr := J + 1; + exit; + end if; + end loop; + + -- Save name of directory in which main unit resides for use in + -- locating other units + + Dir_Name := new String'(File_Name (File_Name'First .. Fptr - 1)); + + case Running_Program is + + when Compiler => + Src_Search_Directories.Table (Primary_Directory) := Dir_Name; + Look_In_Primary_Directory_For_Current_Main := True; + + when Make => + Src_Search_Directories.Table (Primary_Directory) := Dir_Name; + + if Fptr > File_Name'First then + Look_In_Primary_Directory_For_Current_Main := True; + end if; + + when Binder | Gnatls => + Dir_Name := Normalize_Directory_Name (Dir_Name.all); + Lib_Search_Directories.Table (Primary_Directory) := Dir_Name; + + when Unspecified => + null; + end case; + + Name_Len := File_Name'Last - Fptr + 1; + Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Current_Main := Name_Find; + + -- In the gnatmake case, the main file may have not have the + -- extension. Try ".adb" first then ".ads" + + if Running_Program = Make then + declare + Orig_Main : constant File_Name_Type := Current_Main; + + begin + if Strip_Suffix (Orig_Main) = Orig_Main then + Current_Main := + Append_Suffix_To_File_Name (Orig_Main, ".adb"); + + if Full_Source_Name (Current_Main) = No_File then + Current_Main := + Append_Suffix_To_File_Name (Orig_Main, ".ads"); + + if Full_Source_Name (Current_Main) = No_File then + Current_Main := Orig_Main; + end if; + end if; + end if; + end; + end if; + + return Current_Main; + end Next_Main_File; + + ------------------------------ + -- Normalize_Directory_Name -- + ------------------------------ + + function Normalize_Directory_Name (Directory : String) return String_Ptr is + + function Is_Quoted (Path : String) return Boolean; + pragma Inline (Is_Quoted); + -- Returns true if Path is quoted (either double or single quotes) + + --------------- + -- Is_Quoted -- + --------------- + + function Is_Quoted (Path : String) return Boolean is + First : constant Character := Path (Path'First); + Last : constant Character := Path (Path'Last); + + begin + if (First = ''' and then Last = ''') + or else + (First = '"' and then Last = '"') + then + return True; + else + return False; + end if; + end Is_Quoted; + + Result : String_Ptr; + + -- Start of processing for Normalize_Directory_Name + + begin + if Directory'Length = 0 then + Result := new String'(Hostparm.Normalized_CWD); + + elsif Is_Directory_Separator (Directory (Directory'Last)) then + Result := new String'(Directory); + + elsif Is_Quoted (Directory) then + + -- This is a quoted string, it certainly means that the directory + -- contains some spaces for example. We can safely remove the quotes + -- here as the OS_Lib.Normalize_Arguments will be called before any + -- spawn routines. This ensure that quotes will be added when needed. + + Result := new String (1 .. Directory'Length - 1); + Result (1 .. Directory'Length - 2) := + Directory (Directory'First + 1 .. Directory'Last - 1); + Result (Result'Last) := Directory_Separator; + + else + Result := new String (1 .. Directory'Length + 1); + Result (1 .. Directory'Length) := Directory; + Result (Directory'Length + 1) := Directory_Separator; + end if; + + return Result; + end Normalize_Directory_Name; + + --------------------- + -- Number_Of_Files -- + --------------------- + + function Number_Of_Files return Int is + begin + return Number_File_Names; + end Number_Of_Files; + + ------------------------------- + -- Object_Dir_Default_Prefix -- + ------------------------------- + + function Object_Dir_Default_Prefix return String is + Object_Dir : String_Access := + String_Access (Update_Path (Object_Dir_Default_Name)); + + begin + if Object_Dir = null then + return ""; + + else + declare + Result : constant String := Object_Dir.all; + begin + Free (Object_Dir); + return Result; + end; + end if; + end Object_Dir_Default_Prefix; + + ---------------------- + -- Object_File_Name -- + ---------------------- + + function Object_File_Name (N : File_Name_Type) return File_Name_Type is + begin + if N = No_File then + return No_File; + end if; + + Get_Name_String (N); + Name_Len := Name_Len - ALI_Suffix'Length - 1; + + for J in Target_Object_Suffix'Range loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Target_Object_Suffix (J); + end loop; + + return Name_Enter; + end Object_File_Name; + + ------------------------------- + -- OS_Exit_Through_Exception -- + ------------------------------- + + procedure OS_Exit_Through_Exception (Status : Integer) is + begin + Current_Exit_Status := Status; + raise Types.Terminate_Program; + end OS_Exit_Through_Exception; + + -------------------------- + -- OS_Time_To_GNAT_Time -- + -------------------------- + + function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is + GNAT_Time : Time_Stamp_Type; + + Y : Year_Type; + Mo : Month_Type; + D : Day_Type; + H : Hour_Type; + Mn : Minute_Type; + S : Second_Type; + + begin + if T = Invalid_Time then + return Empty_Time_Stamp; + end if; + + GM_Split (T, Y, Mo, D, H, Mn, S); + Make_Time_Stamp + (Year => Nat (Y), + Month => Nat (Mo), + Day => Nat (D), + Hour => Nat (H), + Minutes => Nat (Mn), + Seconds => Nat (S), + TS => GNAT_Time); + + return GNAT_Time; + end OS_Time_To_GNAT_Time; + + ------------------ + -- Program_Name -- + ------------------ + + function Program_Name (Nam : String; Prog : String) return String_Access is + End_Of_Prefix : Natural := 0; + Start_Of_Prefix : Positive := 1; + Start_Of_Suffix : Positive; + + begin + -- GNAAMP tool names require special treatment + + if AAMP_On_Target then + + -- The name "gcc" is mapped to "gnaamp" (the compiler driver) + + if Nam = "gcc" then + return new String'("gnaamp"); + + -- Tool names starting with "gnat" are mapped by substituting the + -- string "gnaamp" for "gnat" (for example, "gnatpp" => "gnaamppp"). + + elsif Nam'Length >= 4 + and then Nam (Nam'First .. Nam'First + 3) = "gnat" + then + return new String'("gnaamp" & Nam (Nam'First + 4 .. Nam'Last)); + + -- No other mapping rules, so we continue and handle any other forms + -- of tool names the same as on other targets. + + else + null; + end if; + end if; + + -- Get the name of the current program being executed + + Find_Program_Name; + + Start_Of_Suffix := Name_Len + 1; + + -- Find the target prefix if any, for the cross compilation case. + -- For instance in "powerpc-elf-gcc" the target prefix is + -- "powerpc-elf-" + -- Ditto for suffix, e.g. in "gcc-4.1", the suffix is "-4.1" + + for J in reverse 1 .. Name_Len loop + if Name_Buffer (J) = '/' + or else Name_Buffer (J) = Directory_Separator + or else Name_Buffer (J) = ':' + then + Start_Of_Prefix := J + 1; + exit; + end if; + end loop; + + -- Find End_Of_Prefix + + for J in Start_Of_Prefix .. Name_Len - Prog'Length + 1 loop + if Name_Buffer (J .. J + Prog'Length - 1) = Prog then + End_Of_Prefix := J - 1; + exit; + end if; + end loop; + + if End_Of_Prefix > 1 then + Start_Of_Suffix := End_Of_Prefix + Prog'Length + 1; + end if; + + -- Create the new program name + + return new String' + (Name_Buffer (Start_Of_Prefix .. End_Of_Prefix) + & Nam + & Name_Buffer (Start_Of_Suffix .. Name_Len)); + end Program_Name; + + ------------------------------ + -- Read_Default_Search_Dirs -- + ------------------------------ + + function Read_Default_Search_Dirs + (Search_Dir_Prefix : String_Access; + Search_File : String_Access; + Search_Dir_Default_Name : String_Access) return String_Access + is + Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length; + Buffer : String (1 .. Prefix_Len + Search_File.all'Length + 1); + File_FD : File_Descriptor; + S, S1 : String_Access; + Len : Integer; + Curr : Integer; + Actual_Len : Integer; + J1 : Integer; + + Prev_Was_Separator : Boolean; + Nb_Relative_Dir : Integer; + + function Is_Relative (S : String; K : Positive) return Boolean; + pragma Inline (Is_Relative); + -- Returns True if a relative directory specification is found + -- in S at position K, False otherwise. + + ----------------- + -- Is_Relative -- + ----------------- + + function Is_Relative (S : String; K : Positive) return Boolean is + begin + return not Is_Absolute_Path (S (K .. S'Last)); + end Is_Relative; + + -- Start of processing for Read_Default_Search_Dirs + + begin + -- Construct a C compatible character string buffer + + Buffer (1 .. Search_Dir_Prefix.all'Length) + := Search_Dir_Prefix.all; + Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1) + := Search_File.all; + Buffer (Buffer'Last) := ASCII.NUL; + + File_FD := Open_Read (Buffer'Address, Binary); + if File_FD = Invalid_FD then + return Search_Dir_Default_Name; + end if; + + Len := Integer (File_Length (File_FD)); + + -- An extra character for a trailing Path_Separator is allocated + + S := new String (1 .. Len + 1); + S (Len + 1) := Path_Separator; + + -- Read the file. Note that the loop is not necessary since the + -- whole file is read at once except on VMS. + + Curr := 1; + Actual_Len := Len; + while Actual_Len /= 0 loop + Actual_Len := Read (File_FD, S (Curr)'Address, Len); + Curr := Curr + Actual_Len; + end loop; + + -- Process the file, dealing with path separators + + Prev_Was_Separator := True; + Nb_Relative_Dir := 0; + for J in 1 .. Len loop + + -- Treat any control character as a path separator. Note that we do + -- not treat space as a path separator (we used to treat space as a + -- path separator in an earlier version). That way space can appear + -- as a legitimate character in a path name. + + -- Why do we treat all control characters as path separators??? + + if S (J) in ASCII.NUL .. ASCII.US then + S (J) := Path_Separator; + end if; + + -- Test for explicit path separator (or control char as above) + + if S (J) = Path_Separator then + Prev_Was_Separator := True; + + -- If not path separator, register use of relative directory + + else + if Prev_Was_Separator and then Is_Relative (S.all, J) then + Nb_Relative_Dir := Nb_Relative_Dir + 1; + end if; + + Prev_Was_Separator := False; + end if; + end loop; + + if Nb_Relative_Dir = 0 then + return S; + end if; + + -- Add the Search_Dir_Prefix to all relative paths + + S1 := new String (1 .. S'Length + Nb_Relative_Dir * Prefix_Len); + J1 := 1; + Prev_Was_Separator := True; + for J in 1 .. Len + 1 loop + if S (J) = Path_Separator then + Prev_Was_Separator := True; + + else + if Prev_Was_Separator and then Is_Relative (S.all, J) then + S1 (J1 .. J1 + Prefix_Len - 1) := Search_Dir_Prefix.all; + J1 := J1 + Prefix_Len; + end if; + + Prev_Was_Separator := False; + end if; + S1 (J1) := S (J); + J1 := J1 + 1; + end loop; + + Free (S); + return S1; + end Read_Default_Search_Dirs; + + ----------------------- + -- Read_Library_Info -- + ----------------------- + + function Read_Library_Info + (Lib_File : File_Name_Type; + Fatal_Err : Boolean := False) return Text_Buffer_Ptr + is + File : File_Name_Type; + Attr : aliased File_Attributes; + begin + Find_File (Lib_File, Library, File, Attr'Access); + return Read_Library_Info_From_Full + (Full_Lib_File => File, + Lib_File_Attr => Attr'Access, + Fatal_Err => Fatal_Err); + end Read_Library_Info; + + --------------------------------- + -- Read_Library_Info_From_Full -- + --------------------------------- + + function Read_Library_Info_From_Full + (Full_Lib_File : File_Name_Type; + Lib_File_Attr : access File_Attributes; + Fatal_Err : Boolean := False) return Text_Buffer_Ptr + is + Lib_FD : File_Descriptor; + -- The file descriptor for the current library file. A negative value + -- indicates failure to open the specified source file. + + Len : Integer; + -- Length of source file text (ALI). If it doesn't fit in an integer + -- we're probably stuck anyway (>2 gigs of source seems a lot!) + + Text : Text_Buffer_Ptr; + -- Allocated text buffer + + Status : Boolean; + pragma Warnings (Off, Status); + -- For the calls to Close + + begin + Current_Full_Lib_Name := Full_Lib_File; + Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name); + + if Current_Full_Lib_Name = No_File then + if Fatal_Err then + Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len)); + else + Current_Full_Obj_Stamp := Empty_Time_Stamp; + return null; + end if; + end if; + + Get_Name_String (Current_Full_Lib_Name); + Name_Buffer (Name_Len + 1) := ASCII.NUL; + + -- Open the library FD, note that we open in binary mode, because as + -- documented in the spec, the caller is expected to handle either + -- DOS or Unix mode files, and there is no point in wasting time on + -- text translation when it is not required. + + Lib_FD := Open_Read (Name_Buffer'Address, Binary); + + if Lib_FD = Invalid_FD then + if Fatal_Err then + Fail ("Cannot open: " & Name_Buffer (1 .. Name_Len)); + else + Current_Full_Obj_Stamp := Empty_Time_Stamp; + return null; + end if; + end if; + + -- Compute the length of the file (potentially also preparing other data + -- like the timestamp and whether the file is read-only, for future use) + + Len := Integer (File_Length (Name_Buffer'Address, Lib_File_Attr)); + + -- Check for object file consistency if requested + + if Opt.Check_Object_Consistency then + -- On most systems, this does not result in an extra system call + + Current_Full_Lib_Stamp := + OS_Time_To_GNAT_Time + (File_Time_Stamp (Name_Buffer'Address, Lib_File_Attr)); + + -- ??? One system call here + + Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name); + + if Current_Full_Obj_Stamp (1) = ' ' then + + -- When the library is readonly always assume object is consistent + -- The call to Is_Writable_File only results in a system call on + -- some systems, but in most cases it has already been computed as + -- part of the call to File_Length above. + + Get_Name_String (Current_Full_Lib_Name); + Name_Buffer (Name_Len + 1) := ASCII.NUL; + + if not Is_Writable_File (Name_Buffer'Address, Lib_File_Attr) then + Current_Full_Obj_Stamp := Current_Full_Lib_Stamp; + + elsif Fatal_Err then + Get_Name_String (Current_Full_Obj_Name); + Close (Lib_FD, Status); + + -- No need to check the status, we fail anyway + + Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len)); + + else + Current_Full_Obj_Stamp := Empty_Time_Stamp; + Close (Lib_FD, Status); + + -- No need to check the status, we return null anyway + + return null; + end if; + + elsif Current_Full_Obj_Stamp < Current_Full_Lib_Stamp then + Close (Lib_FD, Status); + + -- No need to check the status, we return null anyway + + return null; + end if; + end if; + + -- Read data from the file + + declare + Actual_Len : Integer := 0; + + Lo : constant Text_Ptr := 0; + -- Low bound for allocated text buffer + + Hi : Text_Ptr := Text_Ptr (Len); + -- High bound for allocated text buffer. Note length is Len + 1 + -- which allows for extra EOF character at the end of the buffer. + + begin + -- Allocate text buffer. Note extra character at end for EOF + + Text := new Text_Buffer (Lo .. Hi); + + -- Some systems (e.g. VMS) have file types that require one + -- read per line, so read until we get the Len bytes or until + -- there are no more characters. + + Hi := Lo; + loop + Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len); + Hi := Hi + Text_Ptr (Actual_Len); + exit when Actual_Len = Len or else Actual_Len <= 0; + end loop; + + Text (Hi) := EOF; + end; + + -- Read is complete, close file and we are done + + Close (Lib_FD, Status); + -- The status should never be False. But, if it is, what can we do? + -- So, we don't test it. + + return Text; + + end Read_Library_Info_From_Full; + + ---------------------- + -- Read_Source_File -- + ---------------------- + + procedure Read_Source_File + (N : File_Name_Type; + Lo : Source_Ptr; + Hi : out Source_Ptr; + Src : out Source_Buffer_Ptr; + T : File_Type := Source) + is + Source_File_FD : File_Descriptor; + -- The file descriptor for the current source file. A negative value + -- indicates failure to open the specified source file. + + Len : Integer; + -- Length of file. Assume no more than 2 gigabytes of source! + + Actual_Len : Integer; + + Status : Boolean; + pragma Warnings (Off, Status); + -- For the call to Close + + begin + Current_Full_Source_Name := Find_File (N, T); + Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name); + + if Current_Full_Source_Name = No_File then + + -- If we were trying to access the main file and we could not find + -- it, we have an error. + + if N = Current_Main then + Get_Name_String (N); + Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len)); + end if; + + Src := null; + Hi := No_Location; + return; + end if; + + Get_Name_String (Current_Full_Source_Name); + Name_Buffer (Name_Len + 1) := ASCII.NUL; + + -- Open the source FD, note that we open in binary mode, because as + -- documented in the spec, the caller is expected to handle either + -- DOS or Unix mode files, and there is no point in wasting time on + -- text translation when it is not required. + + Source_File_FD := Open_Read (Name_Buffer'Address, Binary); + + if Source_File_FD = Invalid_FD then + Src := null; + Hi := No_Location; + return; + end if; + + -- Print out the file name, if requested, and if it's not part of the + -- runtimes, store it in File_Name_Chars. + + declare + Name : String renames Name_Buffer (1 .. Name_Len); + Inc : String renames Include_Dir_Default_Prefix.all; + + begin + if Debug.Debug_Flag_Dot_N then + Write_Line (Name); + end if; + + if Inc /= "" + and then Inc'Length < Name_Len + and then Name_Buffer (1 .. Inc'Length) = Inc + then + -- Part of runtimes, so ignore it + + null; + + else + File_Name_Chars.Append_All (File_Name_Chars.Table_Type (Name)); + File_Name_Chars.Append (ASCII.LF); + end if; + end; + + -- Prepare to read data from the file + + Len := Integer (File_Length (Source_File_FD)); + + -- Set Hi so that length is one more than the physical length, + -- allowing for the extra EOF character at the end of the buffer + + Hi := Lo + Source_Ptr (Len); + + -- Do the actual read operation + + declare + subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi); + -- Physical buffer allocated + + type Actual_Source_Ptr is access Actual_Source_Buffer; + -- This is the pointer type for the physical buffer allocated + + Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer; + -- And this is the actual physical buffer + + begin + -- Allocate source buffer, allowing extra character at end for EOF + + -- Some systems (e.g. VMS) have file types that require one read per + -- line, so read until we get the Len bytes or until there are no + -- more characters. + + Hi := Lo; + loop + Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len); + Hi := Hi + Source_Ptr (Actual_Len); + exit when Actual_Len = Len or else Actual_Len <= 0; + end loop; + + Actual_Ptr (Hi) := EOF; + + -- Now we need to work out the proper virtual origin pointer to + -- return. This is exactly Actual_Ptr (0)'Address, but we have to + -- be careful to suppress checks to compute this address. + + declare + pragma Suppress (All_Checks); + + pragma Warnings (Off); + -- This use of unchecked conversion is aliasing safe + + function To_Source_Buffer_Ptr is new + Unchecked_Conversion (Address, Source_Buffer_Ptr); + + pragma Warnings (On); + + begin + Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address); + end; + end; + + -- Read is complete, get time stamp and close file and we are done + + Close (Source_File_FD, Status); + + -- The status should never be False. But, if it is, what can we do? + -- So, we don't test it. + + end Read_Source_File; + + ------------------- + -- Relocate_Path -- + ------------------- + + function Relocate_Path + (Prefix : String; + Path : String) return String_Ptr + is + S : String_Ptr; + + procedure set_std_prefix (S : String; Len : Integer); + pragma Import (C, set_std_prefix); + + begin + if Std_Prefix = null then + Std_Prefix := Executable_Prefix; + + if Std_Prefix.all /= "" then + + -- Remove trailing directory separator when calling set_std_prefix + + set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1); + end if; + end if; + + if Path (Prefix'Range) = Prefix then + if Std_Prefix.all /= "" then + S := new String + (1 .. Std_Prefix'Length + Path'Last - Prefix'Last); + S (1 .. Std_Prefix'Length) := Std_Prefix.all; + S (Std_Prefix'Length + 1 .. S'Last) := + Path (Prefix'Last + 1 .. Path'Last); + return S; + end if; + end if; + + return new String'(Path); + end Relocate_Path; + + ----------------- + -- Set_Program -- + ----------------- + + procedure Set_Program (P : Program_Type) is + begin + if Program_Set then + Fail ("Set_Program called twice"); + end if; + + Program_Set := True; + Running_Program := P; + end Set_Program; + + ---------------- + -- Shared_Lib -- + ---------------- + + function Shared_Lib (Name : String) return String is + Library : String (1 .. Name'Length + Library_Version'Length + 3); + -- 3 = 2 for "-l" + 1 for "-" before lib version + + begin + Library (1 .. 2) := "-l"; + Library (3 .. 2 + Name'Length) := Name; + Library (3 + Name'Length) := '-'; + Library (4 + Name'Length .. Library'Last) := Library_Version; + + if OpenVMS_On_Target then + for K in Library'First + 2 .. Library'Last loop + if Library (K) = '.' or else Library (K) = '-' then + Library (K) := '_'; + end if; + end loop; + end if; + + return Library; + end Shared_Lib; + + ---------------------- + -- Smart_File_Stamp -- + ---------------------- + + function Smart_File_Stamp + (N : File_Name_Type; + T : File_Type) return Time_Stamp_Type + is + File : File_Name_Type; + Attr : aliased File_Attributes; + + begin + if not File_Cache_Enabled then + Find_File (N, T, File, Attr'Access); + else + Smart_Find_File (N, T, File, Attr); + end if; + + if File = No_File then + return Empty_Time_Stamp; + else + Get_Name_String (File); + Name_Buffer (Name_Len + 1) := ASCII.NUL; + return + OS_Time_To_GNAT_Time + (File_Time_Stamp (Name_Buffer'Address, Attr'Access)); + end if; + end Smart_File_Stamp; + + --------------------- + -- Smart_Find_File -- + --------------------- + + function Smart_Find_File + (N : File_Name_Type; + T : File_Type) return File_Name_Type + is + File : File_Name_Type; + Attr : File_Attributes; + begin + Smart_Find_File (N, T, File, Attr); + return File; + end Smart_Find_File; + + --------------------- + -- Smart_Find_File -- + --------------------- + + procedure Smart_Find_File + (N : File_Name_Type; + T : File_Type; + Found : out File_Name_Type; + Attr : out File_Attributes) + is + Info : File_Info_Cache; + + begin + if not File_Cache_Enabled then + Find_File (N, T, Info.File, Info.Attr'Access); + + else + Info := File_Name_Hash_Table.Get (N); + + if Info.File = No_File then + Find_File (N, T, Info.File, Info.Attr'Access); + File_Name_Hash_Table.Set (N, Info); + end if; + end if; + + Found := Info.File; + Attr := Info.Attr; + end Smart_Find_File; + + ---------------------- + -- Source_File_Data -- + ---------------------- + + procedure Source_File_Data (Cache : Boolean) is + begin + File_Cache_Enabled := Cache; + end Source_File_Data; + + ----------------------- + -- Source_File_Stamp -- + ----------------------- + + function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is + begin + return Smart_File_Stamp (N, Source); + end Source_File_Stamp; + + --------------------- + -- Strip_Directory -- + --------------------- + + function Strip_Directory (Name : File_Name_Type) return File_Name_Type is + begin + Get_Name_String (Name); + + for J in reverse 1 .. Name_Len - 1 loop + + -- If we find the last directory separator + + if Is_Directory_Separator (Name_Buffer (J)) then + + -- Return part of Name that follows this last directory separator + + Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len); + Name_Len := Name_Len - J; + return Name_Find; + end if; + end loop; + + -- There were no directory separator, just return Name + + return Name; + end Strip_Directory; + + ------------------ + -- Strip_Suffix -- + ------------------ + + function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is + begin + Get_Name_String (Name); + + for J in reverse 2 .. Name_Len loop + + -- If we found the last '.', return part of Name that precedes it + + if Name_Buffer (J) = '.' then + Name_Len := J - 1; + return Name_Enter; + end if; + end loop; + + return Name; + end Strip_Suffix; + + --------------------------- + -- To_Canonical_Dir_Spec -- + --------------------------- + + function To_Canonical_Dir_Spec + (Host_Dir : String; + Prefix_Style : Boolean) return String_Access + is + function To_Canonical_Dir_Spec + (Host_Dir : Address; + Prefix_Flag : Integer) return Address; + pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec"); + + C_Host_Dir : String (1 .. Host_Dir'Length + 1); + Canonical_Dir_Addr : Address; + Canonical_Dir_Len : Integer; + + begin + C_Host_Dir (1 .. Host_Dir'Length) := Host_Dir; + C_Host_Dir (C_Host_Dir'Last) := ASCII.NUL; + + if Prefix_Style then + Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 1); + else + Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 0); + end if; + + Canonical_Dir_Len := C_String_Length (Canonical_Dir_Addr); + + if Canonical_Dir_Len = 0 then + return null; + else + return To_Path_String_Access (Canonical_Dir_Addr, Canonical_Dir_Len); + end if; + + exception + when others => + Fail ("erroneous directory spec: " & Host_Dir); + return null; + end To_Canonical_Dir_Spec; + + --------------------------- + -- To_Canonical_File_List -- + --------------------------- + + function To_Canonical_File_List + (Wildcard_Host_File : String; + Only_Dirs : Boolean) return String_Access_List_Access + is + function To_Canonical_File_List_Init + (Host_File : Address; + Only_Dirs : Integer) return Integer; + pragma Import (C, To_Canonical_File_List_Init, + "__gnat_to_canonical_file_list_init"); + + function To_Canonical_File_List_Next return Address; + pragma Import (C, To_Canonical_File_List_Next, + "__gnat_to_canonical_file_list_next"); + + procedure To_Canonical_File_List_Free; + pragma Import (C, To_Canonical_File_List_Free, + "__gnat_to_canonical_file_list_free"); + + Num_Files : Integer; + C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1); + + begin + C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) := + Wildcard_Host_File; + C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL; + + -- Do the expansion and say how many there are + + Num_Files := To_Canonical_File_List_Init + (C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs)); + + declare + Canonical_File_List : String_Access_List (1 .. Num_Files); + Canonical_File_Addr : Address; + Canonical_File_Len : Integer; + + begin + -- Retrieve the expanded directory names and build the list + + for J in 1 .. Num_Files loop + Canonical_File_Addr := To_Canonical_File_List_Next; + Canonical_File_Len := C_String_Length (Canonical_File_Addr); + Canonical_File_List (J) := To_Path_String_Access + (Canonical_File_Addr, Canonical_File_Len); + end loop; + + -- Free up the storage + + To_Canonical_File_List_Free; + + return new String_Access_List'(Canonical_File_List); + end; + end To_Canonical_File_List; + + ---------------------------- + -- To_Canonical_File_Spec -- + ---------------------------- + + function To_Canonical_File_Spec + (Host_File : String) return String_Access + is + function To_Canonical_File_Spec (Host_File : Address) return Address; + pragma Import + (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec"); + + C_Host_File : String (1 .. Host_File'Length + 1); + Canonical_File_Addr : Address; + Canonical_File_Len : Integer; + + begin + C_Host_File (1 .. Host_File'Length) := Host_File; + C_Host_File (C_Host_File'Last) := ASCII.NUL; + + Canonical_File_Addr := To_Canonical_File_Spec (C_Host_File'Address); + Canonical_File_Len := C_String_Length (Canonical_File_Addr); + + if Canonical_File_Len = 0 then + return null; + else + return To_Path_String_Access + (Canonical_File_Addr, Canonical_File_Len); + end if; + + exception + when others => + Fail ("erroneous file spec: " & Host_File); + return null; + end To_Canonical_File_Spec; + + ---------------------------- + -- To_Canonical_Path_Spec -- + ---------------------------- + + function To_Canonical_Path_Spec + (Host_Path : String) return String_Access + is + function To_Canonical_Path_Spec (Host_Path : Address) return Address; + pragma Import + (C, To_Canonical_Path_Spec, "__gnat_to_canonical_path_spec"); + + C_Host_Path : String (1 .. Host_Path'Length + 1); + Canonical_Path_Addr : Address; + Canonical_Path_Len : Integer; + + begin + C_Host_Path (1 .. Host_Path'Length) := Host_Path; + C_Host_Path (C_Host_Path'Last) := ASCII.NUL; + + Canonical_Path_Addr := To_Canonical_Path_Spec (C_Host_Path'Address); + Canonical_Path_Len := C_String_Length (Canonical_Path_Addr); + + -- Return a null string (vice a null) for zero length paths, for + -- compatibility with getenv(). + + return To_Path_String_Access (Canonical_Path_Addr, Canonical_Path_Len); + + exception + when others => + Fail ("erroneous path spec: " & Host_Path); + return null; + end To_Canonical_Path_Spec; + + --------------------------- + -- To_Host_Dir_Spec -- + --------------------------- + + function To_Host_Dir_Spec + (Canonical_Dir : String; + Prefix_Style : Boolean) return String_Access + is + function To_Host_Dir_Spec + (Canonical_Dir : Address; + Prefix_Flag : Integer) return Address; + pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec"); + + C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1); + Host_Dir_Addr : Address; + Host_Dir_Len : Integer; + + begin + C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir; + C_Canonical_Dir (C_Canonical_Dir'Last) := ASCII.NUL; + + if Prefix_Style then + Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1); + else + Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0); + end if; + Host_Dir_Len := C_String_Length (Host_Dir_Addr); + + if Host_Dir_Len = 0 then + return null; + else + return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len); + end if; + end To_Host_Dir_Spec; + + ---------------------------- + -- To_Host_File_Spec -- + ---------------------------- + + function To_Host_File_Spec + (Canonical_File : String) return String_Access + is + function To_Host_File_Spec (Canonical_File : Address) return Address; + pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec"); + + C_Canonical_File : String (1 .. Canonical_File'Length + 1); + Host_File_Addr : Address; + Host_File_Len : Integer; + + begin + C_Canonical_File (1 .. Canonical_File'Length) := Canonical_File; + C_Canonical_File (C_Canonical_File'Last) := ASCII.NUL; + + Host_File_Addr := To_Host_File_Spec (C_Canonical_File'Address); + Host_File_Len := C_String_Length (Host_File_Addr); + + if Host_File_Len = 0 then + return null; + else + return To_Path_String_Access + (Host_File_Addr, Host_File_Len); + end if; + end To_Host_File_Spec; + + --------------------------- + -- To_Path_String_Access -- + --------------------------- + + function To_Path_String_Access + (Path_Addr : Address; + Path_Len : Integer) return String_Access + is + subtype Path_String is String (1 .. Path_Len); + type Path_String_Access is access Path_String; + + function Address_To_Access is new + Unchecked_Conversion (Source => Address, + Target => Path_String_Access); + + Path_Access : constant Path_String_Access := + Address_To_Access (Path_Addr); + + Return_Val : String_Access; + + begin + Return_Val := new String (1 .. Path_Len); + + for J in 1 .. Path_Len loop + Return_Val (J) := Path_Access (J); + end loop; + + return Return_Val; + end To_Path_String_Access; + + ----------------- + -- Update_Path -- + ----------------- + + function Update_Path (Path : String_Ptr) return String_Ptr is + + function C_Update_Path (Path, Component : Address) return Address; + pragma Import (C, C_Update_Path, "update_path"); + + function Strlen (Str : Address) return Integer; + pragma Import (C, Strlen, "strlen"); + + procedure Strncpy (X : Address; Y : Address; Length : Integer); + pragma Import (C, Strncpy, "strncpy"); + + In_Length : constant Integer := Path'Length; + In_String : String (1 .. In_Length + 1); + Component_Name : aliased String := "GCC" & ASCII.NUL; + Result_Ptr : Address; + Result_Length : Integer; + Out_String : String_Ptr; + + begin + In_String (1 .. In_Length) := Path.all; + In_String (In_Length + 1) := ASCII.NUL; + Result_Ptr := C_Update_Path (In_String'Address, Component_Name'Address); + Result_Length := Strlen (Result_Ptr); + + Out_String := new String (1 .. Result_Length); + Strncpy (Out_String.all'Address, Result_Ptr, Result_Length); + return Out_String; + end Update_Path; + + ---------------- + -- Write_Info -- + ---------------- + + procedure Write_Info (Info : String) is + begin + Write_With_Check (Info'Address, Info'Length); + Write_With_Check (EOL'Address, 1); + end Write_Info; + + ------------------------ + -- Write_Program_Name -- + ------------------------ + + procedure Write_Program_Name is + Save_Buffer : constant String (1 .. Name_Len) := + Name_Buffer (1 .. Name_Len); + + begin + Find_Program_Name; + + -- Convert the name to lower case so error messages are the same on + -- all systems. + + for J in 1 .. Name_Len loop + if Name_Buffer (J) in 'A' .. 'Z' then + Name_Buffer (J) := + Character'Val (Character'Pos (Name_Buffer (J)) + 32); + end if; + end loop; + + Write_Str (Name_Buffer (1 .. Name_Len)); + + -- Restore Name_Buffer which was clobbered by the call to + -- Find_Program_Name + + Name_Len := Save_Buffer'Last; + Name_Buffer (1 .. Name_Len) := Save_Buffer; + end Write_Program_Name; + + ---------------------- + -- Write_With_Check -- + ---------------------- + + procedure Write_With_Check (A : Address; N : Integer) is + Ignore : Boolean; + pragma Warnings (Off, Ignore); + + begin + if N = Write (Output_FD, A, N) then + return; + + else + Write_Str ("error: disk full writing "); + Write_Name_Decoded (Output_File_Name); + Write_Eol; + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ASCII.NUL; + Delete_File (Name_Buffer'Address, Ignore); + Exit_Program (E_Fatal); + end if; + end Write_With_Check; + +---------------------------- +-- Package Initialization -- +---------------------------- + + procedure Reset_File_Attributes (Attr : System.Address); + pragma Import (C, Reset_File_Attributes, "__gnat_reset_attributes"); + +begin + Initialization : declare + + function Get_Default_Identifier_Character_Set return Character; + pragma Import (C, Get_Default_Identifier_Character_Set, + "__gnat_get_default_identifier_character_set"); + -- Function to determine the default identifier character set, + -- which is system dependent. See Opt package spec for a list of + -- the possible character codes and their interpretations. + + function Get_Maximum_File_Name_Length return Int; + pragma Import (C, Get_Maximum_File_Name_Length, + "__gnat_get_maximum_file_name_length"); + -- Function to get maximum file name length for system + + Sizeof_File_Attributes : Integer; + pragma Import (C, Sizeof_File_Attributes, + "__gnat_size_of_file_attributes"); + + begin + pragma Assert (Sizeof_File_Attributes <= File_Attributes_Size); + + Reset_File_Attributes (Unknown_Attributes'Address); + + Identifier_Character_Set := Get_Default_Identifier_Character_Set; + Maximum_File_Name_Length := Get_Maximum_File_Name_Length; + + -- Following should be removed by having above function return + -- Integer'Last as indication of no maximum instead of -1 ??? + + if Maximum_File_Name_Length = -1 then + Maximum_File_Name_Length := Int'Last; + end if; + + Src_Search_Directories.Set_Last (Primary_Directory); + Src_Search_Directories.Table (Primary_Directory) := new String'(""); + + Lib_Search_Directories.Set_Last (Primary_Directory); + Lib_Search_Directories.Table (Primary_Directory) := new String'(""); + + Osint.Initialize; + end Initialization; + +end Osint; diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads new file mode 100644 index 000000000..9ec26bff3 --- /dev/null +++ b/gcc/ada/osint.ads @@ -0,0 +1,776 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O S I N T -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 low level, operating system routines used in the +-- compiler and binder for command line processing and file input output. + +with Namet; use Namet; +with Types; use Types; + +with System; use System; + +pragma Warnings (Off); +-- This package is used also by gnatcoll +with System.OS_Lib; use System.OS_Lib; +pragma Warnings (On); + +with System.Storage_Elements; + +pragma Elaborate_All (System.OS_Lib); +-- For the call to function Get_Target_Object_Suffix in the private part + +package Osint is + + Multi_Unit_Index_Character : Character := '~'; + -- The character before the index of the unit in a multi-unit source in ALI + -- and object file names. Changed to '$' on VMS. + + Ada_Include_Path : constant String := "ADA_INCLUDE_PATH"; + Ada_Objects_Path : constant String := "ADA_OBJECTS_PATH"; + Project_Include_Path_File : constant String := "ADA_PRJ_INCLUDE_FILE"; + Project_Objects_Path_File : constant String := "ADA_PRJ_OBJECTS_FILE"; + + procedure Initialize; + -- Initialize internal tables + + function Normalize_Directory_Name (Directory : String) return String_Ptr; + -- Verify and normalize a directory name. If directory name is invalid, + -- this will return an empty string. Otherwise it will insure a trailing + -- slash and make other normalizations. + + type File_Type is (Source, Library, Config, Definition, Preprocessing_Data); + + function Find_File + (N : File_Name_Type; + T : File_Type) return File_Name_Type; + -- Finds a source, library or config file depending on the value of T + -- following the directory search order rules unless N is the name of the + -- file just read with Next_Main_File and already contains directory + -- information, in which case just look in the Primary_Directory. Returns + -- File_Name_Type of the full file name if found, No_File if file not + -- found. Note that for the special case of gnat.adc, only the compilation + -- environment directory is searched, i.e. the directory where the ali and + -- object files are written. Another special case is Debug_Generated_Code + -- set and the file name ends on ".dg", in which case we look for the + -- generated file only in the current directory, since that is where it is + -- always built. + + function Get_File_Names_Case_Sensitive return Int; + pragma Import (C, Get_File_Names_Case_Sensitive, + "__gnat_get_file_names_case_sensitive"); + File_Names_Case_Sensitive : constant Boolean := + Get_File_Names_Case_Sensitive /= 0; + -- Set to indicate whether the operating system convention is for file + -- names to be case sensitive (e.g., in Unix, set True), or non case + -- sensitive (e.g., in Windows, set False). + + procedure Canonical_Case_File_Name (S : in out String); + -- Given a file name, converts it to canonical case form. For systems + -- where file names are case sensitive, this procedure has no effect. + -- If file names are not case sensitive (i.e. for example if you have + -- the file "xyz.adb", you can refer to it as XYZ.adb or XyZ.AdB), then + -- this call converts the given string to canonical all lower case form, + -- so that two file names compare equal if they refer to the same file. + + function Get_Env_Vars_Case_Sensitive return Int; + pragma Import (C, Get_Env_Vars_Case_Sensitive, + "__gnat_get_env_vars_case_sensitive"); + Env_Vars_Case_Sensitive : constant Boolean := + Get_Env_Vars_Case_Sensitive /= 0; + -- Set to indicate whether the operating system convention is for + -- environment variable names to be case sensitive (e.g., in Unix, set + -- True), or non case sensitive (e.g., in Windows, set False). + + procedure Canonical_Case_Env_Var_Name (S : in out String); + -- Given an environment variable name, converts it to canonical case form. + -- For systems where environment variable names are case sensitive, this + -- procedure has no effect. If environment variable names are not case + -- sensitive, then this call converts the given string to canonical all + -- lower case form, so that two environment variable names compare equal if + -- they refer to the same environment variable. + + function Number_Of_Files return Int; + -- Gives the total number of filenames found on the command line + + No_Index : constant := -1; + -- Value used in Add_File to indicate no index is specified for main + + procedure Add_File (File_Name : String; Index : Int := No_Index); + -- Called by the subprogram processing the command line for each file name + -- found. The index, when not defaulted to No_Index is the index of the + -- subprogram in its source, zero indicating that the source is not + -- multi-unit. + + procedure Find_Program_Name; + -- Put simple name of current program being run (excluding the directory + -- path) in Name_Buffer, with the length in Name_Len. + + function Program_Name (Nam : String; Prog : String) return String_Access; + -- In the native compilation case, Create a string containing Nam. In the + -- cross compilation case, looks at the prefix of the current program being + -- run and prepend it to Nam. For instance if the program being run is + -- -gnatmake and Nam is "gcc", the returned value will be a pointer + -- to "-gcc". In the specific case where AAMP_On_Target is set, the + -- name "gcc" is mapped to "gnaamp", and names of the form "gnat*" are + -- mapped to "gnaamp*". This function clobbers Name_Buffer and Name_Len. + -- Also look at any suffix, e.g. gnatmake-4.1 -> "gcc-4.1". Prog is the + -- default name of the current program being executed, e.g. "gnatmake", + -- "gnatlink". + + procedure Write_Program_Name; + -- Writes name of program as invoked to the current output (normally + -- standard output). + + procedure Fail (S : String); + pragma No_Return (Fail); + -- Outputs error message S preceded by the name of the executing program + -- and exits with E_Fatal. The output goes to standard error, except if + -- special output is in effect (see Output). + + function Is_Directory_Separator (C : Character) return Boolean; + -- Returns True if C is a directory separator + + function Get_Directory (Name : File_Name_Type) return File_Name_Type; + -- Get the prefix directory name (if any) from Name. The last separator + -- is preserved. Return the normalized current directory if there is no + -- directory part in the name. + + function Is_Readonly_Library (File : File_Name_Type) return Boolean; + -- Check if this library file is a read-only file + + function Strip_Directory (Name : File_Name_Type) return File_Name_Type; + -- Strips the prefix directory name (if any) from Name. Returns the + -- stripped name. Name cannot end with a directory separator. + + function Strip_Suffix (Name : File_Name_Type) return File_Name_Type; + -- Strips the suffix (the last '.' and whatever comes after it) from Name. + -- Returns the stripped name. + + function Executable_Name + (Name : File_Name_Type; + Only_If_No_Suffix : Boolean := False) return File_Name_Type; + -- Given a file name it adds the appropriate suffix at the end so that + -- it becomes the name of the executable on the system at end. For + -- instance under DOS it adds the ".exe" suffix, whereas under UNIX no + -- suffix is added. + + function Executable_Name + (Name : String; + Only_If_No_Suffix : Boolean := False) return String; + -- Same as above, with String parameters + + function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type; + -- Returns the time stamp of file Name. Name should include relative path + -- information in order to locate it. If the source file cannot be opened, + -- or Name = No_File, and all blank time stamp is returned (this is not an + -- error situation). + + function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type; + -- Same as above for a path name + + type String_Access_List is array (Positive range <>) of String_Access; + -- Dereferenced type used to return a list of file specs in + -- To_Canonical_File_List. + + type String_Access_List_Access is access all String_Access_List; + -- Type used to return a String_Access_List without dragging in secondary + -- stack. + + function To_Canonical_File_List + (Wildcard_Host_File : String; + Only_Dirs : Boolean) return String_Access_List_Access; + -- Expand a wildcard host syntax file or directory specification (e.g. on + -- a VMS host, any file or directory spec that contains: "*", or "%", or + -- "...") and return a list of valid Unix syntax file or directory specs. + -- If Only_Dirs is True, then only return directories. + + function To_Canonical_Dir_Spec + (Host_Dir : String; + Prefix_Style : Boolean) return String_Access; + -- Convert a host syntax directory specification (e.g. on a VMS host: + -- "SYS$DEVICE:[DIR]") to canonical (Unix) syntax (e.g. "/sys$device/dir"). + -- If Prefix_Style then make it a valid file specification prefix. A file + -- specification prefix is a directory specification that can be appended + -- with a simple file specification to yield a valid absolute or relative + -- path to a file. On a conversion to Unix syntax this simply means the + -- spec has a trailing slash ("/"). + + function To_Canonical_File_Spec + (Host_File : String) return String_Access; + -- Convert a host syntax file specification (e.g. on a VMS host: + -- "SYS$DEVICE:[DIR]FILE.EXT;69 to canonical (Unix) syntax (e.g. + -- "/sys$device/dir/file.ext.69"). + + function To_Canonical_Path_Spec + (Host_Path : String) return String_Access; + -- Convert a host syntax Path specification (e.g. on a VMS host: + -- "SYS$DEVICE:[BAR],DISK$USER:[FOO] to canonical (Unix) syntax (e.g. + -- "/sys$device/foo:disk$user/foo"). + + function To_Host_Dir_Spec + (Canonical_Dir : String; + Prefix_Style : Boolean) return String_Access; + -- Convert a canonical syntax directory specification to host syntax. The + -- Prefix_Style flag is currently ignored but should be set to False. + -- Note that the caller must free result. + + function To_Host_File_Spec + (Canonical_File : String) return String_Access; + -- Convert a canonical syntax file specification to host syntax + + function Relocate_Path + (Prefix : String; + Path : String) return String_Ptr; + -- Given an absolute path and a prefix, if Path starts with Prefix, + -- replace the Prefix substring with the root installation directory. + -- By default, try to compute the root installation directory by looking + -- at the executable name as it was typed on the command line and, if + -- needed, use the PATH environment variable. If the above computation + -- fails, return Path. This function assumes Prefix'First = Path'First. + + function Shared_Lib (Name : String) return String; + -- Returns the runtime shared library in the form -l- where + -- version is the GNAT runtime library option for the platform. For example + -- this routine called with Name set to "gnat" will return "-lgnat-5.02" + -- on UNIX and Windows and -lgnat_5_02 on VMS. + + --------------------- + -- File attributes -- + --------------------- + + -- The following subprograms offer services similar to those found in + -- System.OS_Lib, but with the ability to extra multiple information from + -- a single system call, depending on the system. This can result in fewer + -- system calls when reused. + + -- In all these subprograms, the requested value is either read from the + -- File_Attributes parameter (resulting in no system call), or computed + -- from the disk and then cached in the File_Attributes parameter (possibly + -- along with other values). + + type File_Attributes is private; + Unknown_Attributes : constant File_Attributes; + -- A cache for various attributes for a file (length, accessibility,...) + -- This must be initialized to Unknown_Attributes prior to the first call. + + function Is_Directory + (Name : C_File_Name; + Attr : access File_Attributes) return Boolean; + function Is_Regular_File + (Name : C_File_Name; + Attr : access File_Attributes) return Boolean; + function Is_Symbolic_Link + (Name : C_File_Name; + Attr : access File_Attributes) return Boolean; + -- Return the type of the file, + + function File_Length + (Name : C_File_Name; + Attr : access File_Attributes) return Long_Integer; + -- Return the length (number of bytes) of the file + + function File_Time_Stamp + (Name : C_File_Name; + Attr : access File_Attributes) return OS_Time; + function File_Time_Stamp + (Name : Path_Name_Type; + Attr : access File_Attributes) return Time_Stamp_Type; + -- Return the time stamp of the file + + function Is_Readable_File + (Name : C_File_Name; + Attr : access File_Attributes) return Boolean; + function Is_Executable_File + (Name : C_File_Name; + Attr : access File_Attributes) return Boolean; + function Is_Writable_File + (Name : C_File_Name; + Attr : access File_Attributes) return Boolean; + -- Return the access rights for the file + + ------------------------- + -- Search Dir Routines -- + ------------------------- + + function Include_Dir_Default_Prefix return String; + -- Return the directory of the run-time library sources, as modified + -- by update_path. + + function Object_Dir_Default_Prefix return String; + -- Return the directory of the run-time library ALI and object files, as + -- modified by update_path. + + procedure Add_Default_Search_Dirs; + -- This routine adds the default search dirs indicated by the environment + -- variables and sdefault package. + + procedure Add_Lib_Search_Dir (Dir : String); + -- Add Dir at the end of the library file search path + + procedure Add_Src_Search_Dir (Dir : String); + -- Add Dir at the end of the source file search path + + procedure Get_Next_Dir_In_Path_Init + (Search_Path : String_Access); + function Get_Next_Dir_In_Path + (Search_Path : String_Access) return String_Access; + -- These subprograms are used to parse out the directory names in a search + -- path specified by a Search_Path argument. The procedure initializes an + -- internal pointer to point to the initial directory name, and calls to + -- the function return successive directory names, with a null pointer + -- marking the end of the list. + + type Search_File_Type is (Include, Objects); + + procedure Add_Search_Dirs + (Search_Path : String_Ptr; + Path_Type : Search_File_Type); + -- These procedure adds all the search directories that are in Search_Path + -- in the proper file search path (library or source) + + function Get_Primary_Src_Search_Directory return String_Ptr; + -- Retrieved the primary directory (directory containing the main source + -- file for Gnatmake. + + function Nb_Dir_In_Src_Search_Path return Natural; + function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr; + -- Functions to access the directory names in the source search path + + function Nb_Dir_In_Obj_Search_Path return Natural; + function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr; + -- Functions to access the directory names in the Object search path + + Include_Search_File : constant String_Access := + new String'("ada_source_path"); + Objects_Search_File : constant String_Access := + new String'("ada_object_path"); + -- Names of the files containing the default include or objects search + -- directories. These files, located in Sdefault.Search_Dir_Prefix, do + -- not necessarily exist. + + Exec_Name : String_Ptr; + -- Executable name as typed by the user (used to compute the + -- executable prefix). + + function Read_Default_Search_Dirs + (Search_Dir_Prefix : String_Access; + Search_File : String_Access; + Search_Dir_Default_Name : String_Access) return String_Access; + -- Read and return the default search directories from the file located + -- in Search_Dir_Prefix (as modified by update_path) and named Search_File. + -- If no such file exists or an error occurs then instead return the + -- Search_Dir_Default_Name (as modified by update_path). + + function Get_RTS_Search_Dir + (Search_Dir : String; + File_Type : Search_File_Type) return String_Ptr; + -- This function retrieves the paths to the search (resp. lib) dirs and + -- return them. The search dir can be absolute or relative. If the search + -- dir contains Include_Search_File (resp. Object_Search_File), then this + -- function reads and returns the default search directories from the file. + -- Otherwise, if the directory is absolute, it will try to find 'adalib' + -- (resp. 'adainclude'). If found, null is returned. If the directory is + -- relative, the following directories for the directories 'adalib' and + -- 'adainclude' will be scanned: + -- + -- - current directory (from which the tool has been spawned) + -- - $GNAT_ROOT/gcc/gcc-lib/$targ/$vers/ + -- - $GNAT_ROOT/gcc/gcc-lib/$targ/$vers/rts- + -- + -- The scan will stop as soon as the directory being searched for (adalib + -- or adainclude) is found. If the scan fails, null is returned. + + ----------------------- + -- Source File Input -- + ----------------------- + + -- Source file input routines are used by the compiler to read the main + -- source files and the subsidiary source files (e.g. with'ed units), and + -- also by the binder to check presence/time stamps of sources. + + procedure Read_Source_File + (N : File_Name_Type; + Lo : Source_Ptr; + Hi : out Source_Ptr; + Src : out Source_Buffer_Ptr; + T : File_Type := Source); + -- Allocates a Source_Buffer of appropriate length and then reads the + -- entire contents of the source file N into the buffer. The address of + -- the allocated buffer is returned in Src. + -- + -- Each line of text is terminated by one of the sequences: + -- + -- CR + -- CR/LF + -- LF + + -- The source is terminated by an EOF (16#1A#) character, which is the last + -- character of the returned source buffer (note that any EOF characters in + -- positions other than the last source character are treated as blanks). + -- + -- The logical lower bound of the source buffer is the input value of Lo, + -- and on exit Hi is set to the logical upper bound of the source buffer. + -- Note that the returned value in Src points to an array with a physical + -- lower bound of zero. This virtual origin addressing approach means that + -- a constrained array pointer can be used with a low bound of zero which + -- results in more efficient code. + -- + -- If the given file cannot be opened, then the action depends on whether + -- this file is the current main unit (i.e. its name matches the name + -- returned by the most recent call to Next_Main_Source). If so, then the + -- failure to find the file is a fatal error, an error message is output, + -- and program execution is terminated. Otherwise (for the case of a + -- subsidiary source loaded directly or indirectly using with), a file + -- not found condition causes null to be set as the result value. + -- + -- Note that the name passed to this function is the simple file name, + -- without any directory information. The implementation is responsible + -- for searching for the file in the appropriate directories. + -- + -- Note the special case that if the file name is gnat.adc, then the search + -- for the file is done ONLY in the directory corresponding to the current + -- compilation environment, i.e. in the same directory where the ali and + -- object files will be written. + + function Full_Source_Name return File_Name_Type; + function Current_Source_File_Stamp return Time_Stamp_Type; + -- Returns the full name/time stamp of the source file most recently read + -- using Read_Source_File. Calling this routine entails no source file + -- directory lookup penalty. + + procedure Full_Source_Name + (N : File_Name_Type; + Full_File : out File_Name_Type; + Attr : access File_Attributes); + function Full_Source_Name (N : File_Name_Type) return File_Name_Type; + function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type; + -- Returns the full name/time stamp of the source file whose simple name + -- is N which should not include path information. Note that if the file + -- cannot be located No_File is returned for the first routine and an all + -- blank time stamp is returned for the second (this is not an error + -- situation). The full name includes appropriate directory information. + -- The source file directory lookup penalty is incurred every single time + -- the routines are called unless you have previously called + -- Source_File_Data (Cache => True). See below. + -- + -- The procedural version also returns some file attributes for the ALI + -- file (to save on system calls later on). + + function Current_File_Index return Int; + -- Return the index in its source file of the current main unit + + function Matching_Full_Source_Name + (N : File_Name_Type; + T : Time_Stamp_Type) return File_Name_Type; + -- Same semantics than Full_Source_Name but will search on the source path + -- until a source file with time stamp matching T is found. If none is + -- found returns No_File. + + procedure Source_File_Data (Cache : Boolean); + -- By default source file data (full source file name and time stamp) + -- are looked up every time a call to Full_Source_Name (N) or + -- Source_File_Stamp (N) is made. This may be undesirable in certain + -- applications as this is uselessly slow if source file data does not + -- change during program execution. When this procedure is called with + -- Cache => True access to source file data does not incur a penalty if + -- this data was previously retrieved. + + procedure Dump_Source_File_Names; + -- Prints out the names of all source files that have been read by + -- Read_Source_File, except those that come from the run-time library + -- (i.e. Include_Dir_Default_Prefix). The text is sent to whatever Output + -- is currently using (e.g. standard output or standard error). + + ------------------------------------------- + -- Representation of Library Information -- + ------------------------------------------- + + -- Associated with each compiled source file is library information, a + -- string of bytes whose exact format is described in the body of Lib.Writ. + -- Compiling a source file generates this library information for the + -- compiled unit, and access the library information for units that were + -- compiled previously on which the unit being compiled depends. + + -- How this information is stored is up to the implementation of this + -- package. At the interface level, this information is simply associated + -- with its corresponding source. + + -- Several different implementations are possible: + + -- 1. The information could be directly associated with the source file, + -- e.g. placed in a resource fork of this file on the Mac, or on + -- MS-DOS, written to the source file after the end of file mark. + + -- 2. The information could be written into the generated object module + -- if the system supports the inclusion of arbitrary informational + -- byte streams into object files. In this case there must be a naming + -- convention that allows object files to be located given the name of + -- the corresponding source file. + + -- 3. The information could be written to a separate file, whose name is + -- related to the name of the source file by a fixed convention. + + -- Which of these three methods is chosen depends on the constraints of the + -- host operating system. The interface described here is independent of + -- which of these approaches is used. Currently all versions of GNAT use + -- the third approach with a file name of xxx.ali where xxx is the source + -- file name. + + ------------------------------- + -- Library Information Input -- + ------------------------------- + + -- These subprograms are used by the binder to read library information + -- files, see section above for representation of these files. + + function Read_Library_Info + (Lib_File : File_Name_Type; + Fatal_Err : Boolean := False) return Text_Buffer_Ptr; + -- Allocates a Text_Buffer of appropriate length and reads in the entire + -- source of the library information from the library information file + -- whose name is given by the parameter Name. + -- + -- See description of Read_Source_File for details on the format of the + -- returned text buffer (the format is identical). The lower bound of + -- the Text_Buffer is always zero + -- + -- If the specified file cannot be opened, then the action depends on + -- Fatal_Err. If Fatal_Err is True, an error message is given and the + -- compilation is abandoned. Otherwise if Fatal_Err is False, then null + -- is returned. Note that the Lib_File is a simple name which does not + -- include any directory information. The implementation is responsible + -- for searching for the file in appropriate directories. + -- + -- If Opt.Check_Object_Consistency is set to True then this routine checks + -- whether the object file corresponding to the Lib_File is consistent with + -- it. The object file is inconsistent if the object does not exist or if + -- it has an older time stamp than Lib_File. This check is not performed + -- when the Lib_File is "locked" (i.e. read/only) because in this case the + -- object file may be buried in a library. In case of inconsistencies + -- Read_Library_Info behaves as if it did not find Lib_File (namely if + -- Fatal_Err is False, null is returned). + + function Read_Library_Info_From_Full + (Full_Lib_File : File_Name_Type; + Lib_File_Attr : access File_Attributes; + Fatal_Err : Boolean := False) return Text_Buffer_Ptr; + -- Same as Read_Library_Info, except Full_Lib_File must contains the full + -- path to the library file (instead of having Read_Library_Info recompute + -- it). + -- Lib_File_Attr should be an initialized set of attributes for the + -- library file (it can be initialized to Unknown_Attributes, but in + -- general will have been initialized by a previous call to Find_File). + + function Full_Library_Info_Name return File_Name_Type; + function Full_Object_File_Name return File_Name_Type; + -- Returns the full name of the library/object file most recently read + -- using Read_Library_Info, including appropriate directory information. + -- Calling this routine entails no library file directory lookup + -- penalty. Note that the object file corresponding to a library file + -- is not actually read. Its time stamp is affected when the flag + -- Opt.Check_Object_Consistency is set. + + function Current_Library_File_Stamp return Time_Stamp_Type; + function Current_Object_File_Stamp return Time_Stamp_Type; + -- The time stamps of the files returned by the previous two routines. + -- It is an error to call Current_Object_File_Stamp if + -- Opt.Check_Object_Consistency is set to False. + + procedure Full_Lib_File_Name + (N : File_Name_Type; + Lib_File : out File_Name_Type; + Attr : out File_Attributes); + function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type; + -- Returns the full name of library file N. N should not include + -- path information. Note that if the file cannot be located No_File is + -- returned for the first routine and an all blank time stamp is returned + -- for the second (this is not an error situation). The full name includes + -- the appropriate directory information. The library file directory lookup + -- penalty is incurred every single time this routine is called. + -- The procedural version also returns some file attributes for the ALI + -- file (to save on system calls later on). + + function Lib_File_Name + (Source_File : File_Name_Type; + Munit_Index : Nat := 0) return File_Name_Type; + -- Given the name of a source file, returns the name of the corresponding + -- library information file. This may be the name of the object file or of + -- a separate file used to store the library information. In the current + -- implementation, a separate file (the ALI file) is always used. In either + -- case the returned result is suitable for calling Read_Library_Info. The + -- Munit_Index is the unit index in multiple unit per file mode, or zero in + -- normal single unit per file mode (used to add ~nnn suffix). Note: this + -- subprogram is in this section because it is used by the compiler to + -- determine the proper library information names to be placed in the + -- generated library information file. + + ----------------- + -- Termination -- + ----------------- + + Current_Exit_Status : Integer := 0; + -- Exit status that is set with procedure OS_Exit_Through_Exception below + -- and can be used in exception handler for Types.Terminate_Program to call + -- Set_Exit_Status as the last action of the program. + + procedure OS_Exit_Through_Exception (Status : Integer); + -- Set the Current_Exit_Status, then raise Types.Terminate_Program + + type Exit_Code_Type is ( + E_Success, -- No warnings or errors + E_Warnings, -- Compiler warnings generated + E_No_Code, -- No code generated + E_No_Compile, -- Compilation not needed (smart recompilation) + E_Errors, -- Compiler error messages generated + E_Fatal, -- Fatal (serious) error, e.g. source file not found + E_Abort); -- Internally detected compiler error + + procedure Exit_Program (Exit_Code : Exit_Code_Type); + pragma No_Return (Exit_Program); + -- A call to Exit_Program terminates execution with the given status. A + -- status of zero indicates normal completion, a non-zero status indicates + -- abnormal termination. + + ------------------------- + -- Command Line Access -- + ------------------------- + + -- Direct interface to command line parameters. (We don't want to use + -- the predefined command line package because it defines functions + -- returning string) + + function Arg_Count return Natural; + pragma Import (C, Arg_Count, "__gnat_arg_count"); + -- Get number of arguments (note: optional globbing may be enabled) + + procedure Fill_Arg (A : System.Address; Arg_Num : Integer); + pragma Import (C, Fill_Arg, "__gnat_fill_arg"); + -- Store one argument + + function Len_Arg (Arg_Num : Integer) return Integer; + pragma Import (C, Len_Arg, "__gnat_len_arg"); + -- Get length of argument + + ALI_Default_Suffix : constant String_Ptr := new String'("ali"); + ALI_Suffix : String_Ptr := ALI_Default_Suffix; + -- The suffixes used for the library files (also known as ALI files) + +private + + Current_Main : File_Name_Type := No_File; + -- Used to save a simple file name between calls to Next_Main_Source and + -- Read_Source_File. If the file name argument to Read_Source_File is + -- No_File, that indicates that the file whose name was returned by the + -- last call to Next_Main_Source (and stored here) is to be read. + + Target_Object_Suffix : constant String := Get_Target_Object_Suffix.all; + -- The suffix used for the target object files + + Output_FD : File_Descriptor; + -- File descriptor for current library info, list, tree, or binder output + + Output_File_Name : File_Name_Type; + -- File_Name_Type for name of open file whose FD is in Output_FD, the name + -- stored does not include the trailing NUL character. + + Argument_Count : constant Integer := Arg_Count - 1; + -- Number of arguments (excluding program name) + + type File_Name_Array is array (Int range <>) of String_Ptr; + type File_Name_Array_Ptr is access File_Name_Array; + File_Names : File_Name_Array_Ptr := + new File_Name_Array (1 .. Int (Argument_Count) + 2); + -- As arguments are scanned, file names are stored in this array. The + -- strings do not have terminating NUL files. The array is extensible, + -- because when using project files, there may be more files than + -- arguments on the command line. + + type File_Index_Array is array (Int range <>) of Int; + type File_Index_Array_Ptr is access File_Index_Array; + File_Indexes : File_Index_Array_Ptr := + new File_Index_Array (1 .. Int (Argument_Count) + 2); + + Current_File_Name_Index : Int := 0; + -- The index in File_Names of the last file opened by Next_Main_Source + -- or Next_Main_Lib_File. The value 0 indicates that no files have been + -- opened yet. + + procedure Create_File_And_Check + (Fdesc : out File_Descriptor; + Fmode : Mode); + -- Create file whose name (NUL terminated) is in Name_Buffer (with the + -- length in Name_Len), and place the resulting descriptor in Fdesc. Issue + -- message and exit with fatal error if file cannot be created. The Fmode + -- parameter is set to either Text or Binary (for details see description + -- of System.OS_Lib.Create_File). + + type Program_Type is (Compiler, Binder, Make, Gnatls, Unspecified); + -- Program currently running + procedure Set_Program (P : Program_Type); + -- Indicates to the body of Osint the program currently running. This + -- procedure is called by the child packages of Osint. A check is made + -- that this procedure is not called more than once. + + function More_Files return Boolean; + -- Implements More_Source_Files and More_Lib_Files + + function Next_Main_File return File_Name_Type; + -- Implements Next_Main_Source and Next_Main_Lib_File + + function Object_File_Name (N : File_Name_Type) return File_Name_Type; + -- Constructs the name of the object file corresponding to library file N. + -- If N is a full file name than the returned file name will also be a full + -- file name. Note that no lookup in the library file directories is done + -- for this file. This routine merely constructs the name. + + procedure Write_Info (Info : String); + -- Implementation of Write_Binder_Info, Write_Debug_Info and + -- Write_Library_Info (identical) + + procedure Write_With_Check (A : Address; N : Integer); + -- Writes N bytes from buffer starting at address A to file whose FD is + -- stored in Output_FD, and whose file name is stored as a File_Name_Type + -- in Output_File_Name. A check is made for disk full, and if this is + -- detected, the file being written is deleted, and a fatal error is + -- signalled. + + File_Attributes_Size : constant Natural := 24; + -- This should be big enough to fit a "struct file_attributes" on any + -- system. It doesn't cause any malfunction if it is too big (which avoids + -- the need for either mapping the struct exactly or importing the sizeof + -- from C, which would result in dynamic code). However, it does waste + -- space (e.g. when a component of this type appears in a record, if it is + -- unnecessarily large. + + type File_Attributes is + array (1 .. File_Attributes_Size) + of System.Storage_Elements.Storage_Element; + for File_Attributes'Alignment use Standard'Maximum_Alignment; + + Unknown_Attributes : constant File_Attributes := (others => 0); + -- Will be initialized properly at elaboration (for efficiency later on, + -- avoid function calls every time we want to reset the attributes). + +end Osint; diff --git a/gcc/ada/output.adb b/gcc/ada/output.adb new file mode 100644 index 000000000..5ac680176 --- /dev/null +++ b/gcc/ada/output.adb @@ -0,0 +1,431 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O U T P U T -- +-- -- +-- 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 Output is + + Current_FD : File_Descriptor := Standout; + -- File descriptor for current output + + Special_Output_Proc : Output_Proc := null; + -- Record argument to last call to Set_Special_Output. If this is + -- non-null, then we are in special output mode. + + Indentation_Amount : constant Positive := 3; + -- Number of spaces to output for each indentation level + + Indentation_Limit : constant Positive := 40; + -- Indentation beyond this number of spaces wraps around + + pragma Assert (Indentation_Limit < Buffer_Max / 2); + -- Make sure this is substantially shorter than the line length + + Cur_Indentation : Natural := 0; + -- Number of spaces to indent each line + + ----------------------- + -- Local_Subprograms -- + ----------------------- + + procedure Flush_Buffer; + -- Flush buffer if non-empty and reset column counter + + --------------------------- + -- Cancel_Special_Output -- + --------------------------- + + procedure Cancel_Special_Output is + begin + Special_Output_Proc := null; + end Cancel_Special_Output; + + ------------ + -- Column -- + ------------ + + function Column return Pos is + begin + return Pos (Next_Col); + end Column; + + ------------------ + -- Flush_Buffer -- + ------------------ + + procedure Flush_Buffer is + Write_Error : exception; + -- Raised if Write fails + + ------------------ + -- Write_Buffer -- + ------------------ + + procedure Write_Buffer (Buf : String); + -- Write out Buf, either using Special_Output_Proc, or the normal way + -- using Write. Raise Write_Error if Write fails (presumably due to disk + -- full). Write_Error is not used in the case of Special_Output_Proc. + + procedure Write_Buffer (Buf : String) is + begin + -- If Special_Output_Proc has been set, then use it + + if Special_Output_Proc /= null then + Special_Output_Proc.all (Buf); + + -- If output is not set, then output to either standard output + -- or standard error. + + elsif Write (Current_FD, Buf'Address, Buf'Length) /= Buf'Length then + raise Write_Error; + + end if; + end Write_Buffer; + + Len : constant Natural := Next_Col - 1; + + -- Start of processing for Flush_Buffer + + begin + if Len /= 0 then + begin + -- If there's no indentation, or if the line is too long with + -- indentation, or if it's a blank line, just write the buffer. + + if Cur_Indentation = 0 + or else Cur_Indentation + Len > Buffer_Max + or else Buffer (1 .. Len) = (1 => ASCII.LF) + then + Write_Buffer (Buffer (1 .. Len)); + + -- Otherwise, construct a new buffer with preceding spaces, and + -- write that. + + else + declare + Indented_Buffer : constant String := + (1 .. Cur_Indentation => ' ') & + Buffer (1 .. Len); + begin + Write_Buffer (Indented_Buffer); + end; + end if; + + exception + when Write_Error => + + -- If there are errors with standard error just quit. Otherwise + -- set the output to standard error before reporting a failure + -- and quitting. + + if Current_FD /= Standerr then + Current_FD := Standerr; + Next_Col := 1; + Write_Line ("fatal error: disk full"); + end if; + + OS_Exit (2); + end; + + -- Buffer is now empty + + Next_Col := 1; + end if; + end Flush_Buffer; + + ------------------- + -- Ignore_Output -- + ------------------- + + procedure Ignore_Output (S : String) is + begin + null; + end Ignore_Output; + + ------------ + -- Indent -- + ------------ + + procedure Indent is + begin + -- The "mod" in the following assignment is to cause a wrap around in + -- the case where there is too much indentation. + + Cur_Indentation := + (Cur_Indentation + Indentation_Amount) mod Indentation_Limit; + end Indent; + + ------------- + -- Outdent -- + ------------- + + procedure Outdent is + begin + -- The "mod" here undoes the wrap around from Indent above + + Cur_Indentation := + (Cur_Indentation - Indentation_Amount) mod Indentation_Limit; + end Outdent; + + --------------------------- + -- Restore_Output_Buffer -- + --------------------------- + + procedure Restore_Output_Buffer (S : Saved_Output_Buffer) is + begin + Next_Col := S.Next_Col; + Cur_Indentation := S.Cur_Indentation; + Buffer (1 .. Next_Col - 1) := S.Buffer (1 .. Next_Col - 1); + end Restore_Output_Buffer; + + ------------------------ + -- Save_Output_Buffer -- + ------------------------ + + function Save_Output_Buffer return Saved_Output_Buffer is + S : Saved_Output_Buffer; + begin + S.Buffer (1 .. Next_Col - 1) := Buffer (1 .. Next_Col - 1); + S.Next_Col := Next_Col; + S.Cur_Indentation := Cur_Indentation; + Next_Col := 1; + Cur_Indentation := 0; + return S; + end Save_Output_Buffer; + + ------------------------ + -- Set_Special_Output -- + ------------------------ + + procedure Set_Special_Output (P : Output_Proc) is + begin + Special_Output_Proc := P; + end Set_Special_Output; + + ---------------- + -- Set_Output -- + ---------------- + + procedure Set_Output (FD : File_Descriptor) is + begin + if Special_Output_Proc = null then + Flush_Buffer; + end if; + + Current_FD := FD; + end Set_Output; + + ------------------------ + -- Set_Standard_Error -- + ------------------------ + + procedure Set_Standard_Error is + begin + Set_Output (Standerr); + end Set_Standard_Error; + + ------------------------- + -- Set_Standard_Output -- + ------------------------- + + procedure Set_Standard_Output is + begin + Set_Output (Standout); + end Set_Standard_Output; + + ------- + -- w -- + ------- + + procedure w (C : Character) is + begin + Write_Char ('''); + Write_Char (C); + Write_Char ('''); + Write_Eol; + end w; + + procedure w (S : String) is + begin + Write_Str (S); + Write_Eol; + end w; + + procedure w (V : Int) is + begin + Write_Int (V); + Write_Eol; + end w; + + procedure w (B : Boolean) is + begin + if B then + w ("True"); + else + w ("False"); + end if; + end w; + + procedure w (L : String; C : Character) is + begin + Write_Str (L); + Write_Char (' '); + w (C); + end w; + + procedure w (L : String; S : String) is + begin + Write_Str (L); + Write_Char (' '); + w (S); + end w; + + procedure w (L : String; V : Int) is + begin + Write_Str (L); + Write_Char (' '); + w (V); + end w; + + procedure w (L : String; B : Boolean) is + begin + Write_Str (L); + Write_Char (' '); + w (B); + end w; + + ---------------- + -- Write_Char -- + ---------------- + + procedure Write_Char (C : Character) is + begin + if Next_Col = Buffer'Length then + Write_Eol; + end if; + + if C = ASCII.LF then + Write_Eol; + else + Buffer (Next_Col) := C; + Next_Col := Next_Col + 1; + end if; + end Write_Char; + + --------------- + -- Write_Eol -- + --------------- + + procedure Write_Eol is + begin + -- Remove any trailing space + + while Next_Col > 1 and then Buffer (Next_Col - 1) = ' ' loop + Next_Col := Next_Col - 1; + end loop; + + Buffer (Next_Col) := ASCII.LF; + Next_Col := Next_Col + 1; + Flush_Buffer; + end Write_Eol; + + --------------------------- + -- Write_Eol_Keep_Blanks -- + --------------------------- + + procedure Write_Eol_Keep_Blanks is + begin + Buffer (Next_Col) := ASCII.LF; + Next_Col := Next_Col + 1; + Flush_Buffer; + end Write_Eol_Keep_Blanks; + + ---------------------- + -- Write_Erase_Char -- + ---------------------- + + procedure Write_Erase_Char (C : Character) is + begin + if Next_Col /= 1 and then Buffer (Next_Col - 1) = C then + Next_Col := Next_Col - 1; + end if; + end Write_Erase_Char; + + --------------- + -- Write_Int -- + --------------- + + procedure Write_Int (Val : Int) is + begin + if Val < 0 then + Write_Char ('-'); + Write_Int (-Val); + + else + if Val > 9 then + Write_Int (Val / 10); + end if; + + Write_Char (Character'Val ((Val mod 10) + Character'Pos ('0'))); + end if; + end Write_Int; + + ---------------- + -- Write_Line -- + ---------------- + + procedure Write_Line (S : String) is + begin + Write_Str (S); + Write_Eol; + end Write_Line; + + ------------------ + -- Write_Spaces -- + ------------------ + + procedure Write_Spaces (N : Nat) is + begin + for J in 1 .. N loop + Write_Char (' '); + end loop; + end Write_Spaces; + + --------------- + -- Write_Str -- + --------------- + + procedure Write_Str (S : String) is + begin + for J in S'Range loop + Write_Char (S (J)); + end loop; + end Write_Str; + +end Output; diff --git a/gcc/ada/output.ads b/gcc/ada/output.ads new file mode 100644 index 000000000..ddc395448 --- /dev/null +++ b/gcc/ada/output.ads @@ -0,0 +1,222 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O U T P U T -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains low level output routines used by the compiler for +-- writing error messages and informational output. It is also used by the +-- debug source file output routines (see Sprint.Print_Debug_Line). + +with Hostparm; use Hostparm; +with Types; use Types; + +pragma Warnings (Off); +-- This package is used also by gnatcoll +with System.OS_Lib; use System.OS_Lib; +pragma Warnings (On); + +package Output is + pragma Elaborate_Body; + + type Output_Proc is access procedure (S : String); + -- This type is used for the Set_Special_Output procedure. If Output_Proc + -- is called, then instead of lines being written to standard error or + -- standard output, a call is made to the given procedure for each line, + -- passing the line with an end of line character (which is a single + -- ASCII.LF character, even in systems which normally use CR/LF or some + -- other sequence for line end). + + ----------------- + -- Subprograms -- + ----------------- + + procedure Set_Special_Output (P : Output_Proc); + -- Sets subsequent output to call procedure P. If P is null, then the call + -- cancels the effect of a previous call, reverting the output to standard + -- error or standard output depending on the mode at the time of previous + -- call. Any exception generated by by calls to P is simply propagated to + -- the caller of the routine causing the write operation. + + procedure Cancel_Special_Output; + -- Cancels the effect of a call to Set_Special_Output, if any. The output + -- is then directed to standard error or standard output depending on the + -- last call to Set_Standard_Error or Set_Standard_Output. It is never an + -- error to call Cancel_Special_Output. It has the same effect as calling + -- Set_Special_Output (null). + + procedure Ignore_Output (S : String); + -- Does nothing. To disable output, pass Ignore_Output'Access to + -- Set_Special_Output. + + procedure Set_Standard_Error; + -- Sets subsequent output to appear on the standard error file (whatever + -- that might mean for the host operating system, if anything) when + -- no special output is in effect. When a special output is in effect, + -- the output will appear on standard error only after special output + -- has been cancelled. + + procedure Set_Standard_Output; + -- Sets subsequent output to appear on the standard output file (whatever + -- that might mean for the host operating system, if anything) when no + -- special output is in effect. When a special output is in effect, the + -- output will appear on standard output only after special output has been + -- cancelled. Output to standard output is the default mode before any call + -- to either of the Set procedures. + + procedure Set_Output (FD : File_Descriptor); + -- Sets subsequent output to appear on the given file descriptor when no + -- special output is in effect. When a special output is in effect, the + -- output will appear on the given file descriptor only after special + -- output has been cancelled. + + procedure Indent; + -- Increases the current indentation level. Whenever a line is written + -- (triggered by Eol), an appropriate amount of whitespace is added to the + -- beginning of the line, wrapping around if it gets too long. + + procedure Outdent; + -- Decreases the current indentation level + + procedure Write_Char (C : Character); + -- Write one character to the standard output file. If the character is LF, + -- this is equivalent to Write_Eol. + + procedure Write_Erase_Char (C : Character); + -- If last character in buffer matches C, erase it, otherwise no effect + + procedure Write_Eol; + -- Write an end of line (whatever is required by the system in use, e.g. + -- CR/LF for DOS, or LF for Unix) to the standard output file. This routine + -- also empties the line buffer, actually writing it to the file. Note that + -- Write_Eol is the only routine that causes any actual output to be + -- written. Trailing spaces are removed. + + procedure Write_Eol_Keep_Blanks; + -- Similar as Write_Eol, except that trailing spaces are not removed + + procedure Write_Int (Val : Int); + -- Write an integer value with no leading blanks or zeroes. Negative values + -- are preceded by a minus sign). + + procedure Write_Spaces (N : Nat); + -- Write N spaces + + procedure Write_Str (S : String); + -- Write a string of characters to the standard output file. Note that + -- end of line is normally handled separately using WRITE_EOL, but it is + -- allowable for the string to contain LF (but not CR) characters, which + -- are properly interpreted as end of line characters. The string may also + -- contain horizontal tab characters. + + procedure Write_Line (S : String); + -- Equivalent to Write_Str (S) followed by Write_Eol; + + function Column return Pos; + pragma Inline (Column); + -- Returns the number of the column about to be written (e.g. a value of 1 + -- means the current line is empty). + + ------------------------- + -- Buffer Save/Restore -- + ------------------------- + + -- This facility allows the current line buffer to be saved and restored + + type Saved_Output_Buffer is private; + -- Type used for Save/Restore_Buffer + + Buffer_Max : constant := Hostparm.Max_Line_Length; + -- Maximal size of a buffered output line + + function Save_Output_Buffer return Saved_Output_Buffer; + -- Save current line buffer and reset line buffer to empty + + procedure Restore_Output_Buffer (S : Saved_Output_Buffer); + -- Restore previously saved output buffer. The value in S is not affected + -- so it is legitimate to restore a buffer more than once. + + -------------------------- + -- Debugging Procedures -- + -------------------------- + + -- The following procedures are intended only for debugging purposes, + -- for temporary insertion into the text in environments where a debugger + -- is not available. They all have non-standard very short lower case + -- names, precisely to make sure that they are only used for debugging! + + procedure w (C : Character); + -- Dump quote, character, quote, followed by line return + + procedure w (S : String); + -- Dump string followed by line return + + procedure w (V : Int); + -- Dump integer followed by line return + + procedure w (B : Boolean); + -- Dump Boolean followed by line return + + procedure w (L : String; C : Character); + -- Dump contents of string followed by blank, quote, character, quote + + procedure w (L : String; S : String); + -- Dump two strings separated by blanks, followed by line return + + procedure w (L : String; V : Int); + -- Dump contents of string followed by blank, integer, line return + + procedure w (L : String; B : Boolean); + -- Dump contents of string followed by blank, Boolean, line return + +private + -- Note: the following buffer and column position are maintained by the + -- subprograms defined in this package, and cannot be directly modified or + -- accessed by a client. + + Buffer : String (1 .. Buffer_Max + 1) := (others => '*'); + for Buffer'Alignment use 4; + -- Buffer used to build output line. We do line buffering because it + -- is needed for the support of the debug-generated-code option (-gnatD). + -- Historically it was first added because on VMS, line buffering is + -- needed with certain file formats. So in any case line buffering must + -- be retained for this purpose, even if other reasons disappear. Note + -- any attempt to write more output to a line than can fit in the buffer + -- will be silently ignored. The alignment clause improves the efficiency + -- of the save/restore procedures. + + Next_Col : Positive range 1 .. Buffer'Length + 1 := 1; + -- Column about to be written + + type Saved_Output_Buffer is record + Buffer : String (1 .. Buffer_Max + 1); + Next_Col : Positive; + Cur_Indentation : Natural; + end record; + +end Output; diff --git a/gcc/ada/par-ch10.adb b/gcc/ada/par-ch10.adb new file mode 100644 index 000000000..37992b600 --- /dev/null +++ b/gcc/ada/par-ch10.adb @@ -0,0 +1,1188 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 1 0 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +with Fname.UF; use Fname.UF; +with Uname; use Uname; + +separate (Par) +package body Ch10 is + + -- Local functions, used only in this chapter + + function P_Context_Clause return List_Id; + function P_Subunit return Node_Id; + + function Set_Location return Source_Ptr; + -- The current compilation unit starts with Token at Token_Ptr. This + -- function determines the corresponding source location for the start + -- of the unit, including any preceding comment lines. + + procedure Unit_Display + (Cunit : Node_Id; + Loc : Source_Ptr; + SR_Present : Boolean); + -- This procedure is used to generate a line of output for a unit in + -- the source program. Cunit is the node for the compilation unit, and + -- Loc is the source location for the start of the unit in the source + -- file (which is not necessarily the Sloc of the Cunit node). This + -- output is written to the standard output file for use by gnatchop. + + procedure Unit_Location (Sind : Source_File_Index; Loc : Source_Ptr); + -- This routine has the same calling sequence as Unit_Display, but + -- it outputs only the line number and offset of the location, Loc, + -- using Cunit to obtain the proper source file index. + + ------------------------- + -- 10.1.1 Compilation -- + ------------------------- + + -- COMPILATION ::= {COMPILATION_UNIT} + + -- There is no specific parsing routine for a compilation, since we only + -- permit a single compilation in a source file, so there is no explicit + -- occurrence of compilations as such (our representation of a compilation + -- is a series of separate source files). + + ------------------------------ + -- 10.1.1 Compilation unit -- + ------------------------------ + + -- COMPILATION_UNIT ::= + -- CONTEXT_CLAUSE LIBRARY_ITEM + -- | CONTEXT_CLAUSE SUBUNIT + + -- LIBRARY_ITEM ::= + -- private LIBRARY_UNIT_DECLARATION + -- | LIBRARY_UNIT_BODY + -- | [private] LIBRARY_UNIT_RENAMING_DECLARATION + + -- LIBRARY_UNIT_DECLARATION ::= + -- SUBPROGRAM_DECLARATION | PACKAGE_DECLARATION + -- | GENERIC_DECLARATION | GENERIC_INSTANTIATION + + -- LIBRARY_UNIT_RENAMING_DECLARATION ::= + -- PACKAGE_RENAMING_DECLARATION + -- | GENERIC_RENAMING_DECLARATION + -- | SUBPROGRAM_RENAMING_DECLARATION + + -- LIBRARY_UNIT_BODY ::= SUBPROGRAM_BODY | PACKAGE_BODY + + -- Error recovery: cannot raise Error_Resync. If an error occurs, tokens + -- are skipped up to the next possible beginning of a compilation unit. + + -- Note: if only configuration pragmas are found, Empty is returned + + -- Note: in syntax-only mode, it is possible for P_Compilation_Unit + -- to return strange things that are not really compilation units. + -- This is done to help out gnatchop when it is faced with nonsense. + + function P_Compilation_Unit return Node_Id is + Scan_State : Saved_Scan_State; + Body_Node : Node_Id; + Specification_Node : Node_Id; + Unit_Node : Node_Id; + Comp_Unit_Node : Node_Id; + Name_Node : Node_Id; + Item : Node_Id; + Private_Sloc : Source_Ptr := No_Location; + Config_Pragmas : List_Id; + P : Node_Id; + SR_Present : Boolean; + + Cunit_Error_Flag : Boolean := False; + -- This flag is set True if we have to scan for a compilation unit + -- token. It is used to ensure clean termination in such cases by + -- not insisting on being at the end of file, and, in the syntax only + -- case by not scanning for additional compilation units. + + Cunit_Location : Source_Ptr; + -- Location of unit for unit identification output (List_Unit option) + + begin + Num_Library_Units := Num_Library_Units + 1; + + -- Set location of the compilation unit if unit list option set + -- and we are in syntax check only mode + + if List_Units and then Operating_Mode = Check_Syntax then + Cunit_Location := Set_Location; + else + Cunit_Location := No_Location; + end if; + + -- Deal with initial pragmas + + Config_Pragmas := No_List; + + -- If we have an initial Source_Reference pragma, then remember the fact + -- to generate an NR parameter in the output line. + + SR_Present := False; + + if Token = Tok_Pragma then + Save_Scan_State (Scan_State); + Item := P_Pragma; + + if Item = Error + or else Pragma_Name (Item) /= Name_Source_Reference + then + Restore_Scan_State (Scan_State); + + else + SR_Present := True; + + -- If first unit, record the file name for gnatchop use + + if Operating_Mode = Check_Syntax + and then List_Units + and then Num_Library_Units = 1 + then + Write_Str ("Source_Reference pragma for file """); + Write_Name (Full_Ref_Name (Current_Source_File)); + Write_Char ('"'); + Write_Eol; + end if; + + Config_Pragmas := New_List (Item); + end if; + end if; + + -- Scan out any configuration pragmas + + while Token = Tok_Pragma loop + Save_Scan_State (Scan_State); + Item := P_Pragma; + + if Item = Error + or else not Is_Configuration_Pragma_Name (Pragma_Name (Item)) + then + Restore_Scan_State (Scan_State); + exit; + end if; + + if Config_Pragmas = No_List then + Config_Pragmas := Empty_List; + + if Operating_Mode = Check_Syntax and then List_Units then + Write_Str ("Configuration pragmas at"); + Unit_Location (Current_Source_File, Cunit_Location); + Write_Eol; + end if; + end if; + + Append (Item, Config_Pragmas); + Cunit_Location := Set_Location; + end loop; + + -- Establish compilation unit node and scan context items + + Comp_Unit_Node := New_Node (N_Compilation_Unit, No_Location); + Set_Cunit (Current_Source_Unit, Comp_Unit_Node); + Set_Context_Items (Comp_Unit_Node, P_Context_Clause); + Set_Aux_Decls_Node + (Comp_Unit_Node, New_Node (N_Compilation_Unit_Aux, No_Location)); + + if Present (Config_Pragmas) then + + -- Check for case of only configuration pragmas present + + if Token = Tok_EOF + and then Is_Empty_List (Context_Items (Comp_Unit_Node)) + then + if Operating_Mode = Check_Syntax then + return Empty; + + else + Item := First (Config_Pragmas); + Error_Msg_N + ("cannot compile configuration pragmas with gcc!", Item); + Error_Msg_N + ("\use gnatchop -c to process configuration pragmas!", Item); + raise Unrecoverable_Error; + end if; + + -- Otherwise configuration pragmas are simply prepended to the + -- context of the current unit. + + else + Append_List (Context_Items (Comp_Unit_Node), Config_Pragmas); + Set_Context_Items (Comp_Unit_Node, Config_Pragmas); + end if; + end if; + + -- Check for PRIVATE. Note that for the moment we allow this in + -- Ada_83 mode, since we do not yet know if we are compiling a + -- predefined unit, and if we are then it would be allowed anyway. + + if Token = Tok_Private then + Private_Sloc := Token_Ptr; + Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing); + + if Style_Check then + Style.Check_Indentation; + end if; + + Save_Scan_State (Scan_State); -- at PRIVATE + Scan; -- past PRIVATE + + if Token = Tok_Separate then + Error_Msg_SP ("cannot have private subunits!"); + + elsif Token = Tok_Package then + Scan; -- past PACKAGE + + if Token = Tok_Body then + Restore_Scan_State (Scan_State); -- to PRIVATE + Error_Msg_SC ("cannot have private package body!"); + Scan; -- ignore PRIVATE + + else + Restore_Scan_State (Scan_State); -- to PRIVATE + Scan; -- past PRIVATE + Set_Private_Present (Comp_Unit_Node, True); + end if; + + elsif Token = Tok_Procedure + or else Token = Tok_Function + or else Token = Tok_Generic + then + Set_Private_Present (Comp_Unit_Node, True); + end if; + end if; + + -- Loop to find our way to a compilation unit token + + loop + exit when Token in Token_Class_Cunit and then Token /= Tok_With; + + exit when Bad_Spelling_Of (Tok_Package) + or else Bad_Spelling_Of (Tok_Function) + or else Bad_Spelling_Of (Tok_Generic) + or else Bad_Spelling_Of (Tok_Separate) + or else Bad_Spelling_Of (Tok_Procedure); + + -- Allow task and protected for nice error recovery purposes + + exit when Token = Tok_Task + or else Token = Tok_Protected; + + if Token = Tok_With then + Error_Msg_SC ("misplaced WITH"); + Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node)); + + elsif Bad_Spelling_Of (Tok_With) then + Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node)); + + else + if Operating_Mode = Check_Syntax and then Token = Tok_EOF then + Error_Msg_SC ("?file contains no compilation units"); + else + Error_Msg_SC ("compilation unit expected"); + Cunit_Error_Flag := True; + Resync_Cunit; + end if; + + -- If we are at an end of file, then just quit, the above error + -- message was complaint enough. + + if Token = Tok_EOF then + return Error; + end if; + end if; + end loop; + + -- We have a compilation unit token, so that's a reasonable choice for + -- determining the standard casing convention used for keywords in case + -- it hasn't already been done on seeing a WITH or PRIVATE. + + Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing); + + if Style_Check then + Style.Check_Indentation; + end if; + + -- Remaining processing depends on particular type of compilation unit + + if Token = Tok_Package then + + -- A common error is to omit the body keyword after package. We can + -- often diagnose this early on (before getting loads of errors from + -- contained subprogram bodies), by knowing that the file we + -- are compiling has a name that requires a body to be found. + + Save_Scan_State (Scan_State); + Scan; -- past Package keyword + + if Token /= Tok_Body + and then + Get_Expected_Unit_Type + (File_Name (Current_Source_File)) = Expect_Body + then + Error_Msg_BC -- CODEFIX + ("keyword BODY expected here [see file name]"); + Restore_Scan_State (Scan_State); + Set_Unit (Comp_Unit_Node, P_Package (Pf_Pbod_Pexp)); + else + Restore_Scan_State (Scan_State); + Set_Unit (Comp_Unit_Node, P_Package (Pf_Decl_Gins_Pbod_Rnam_Pexp)); + end if; + + elsif Token = Tok_Generic then + Set_Unit (Comp_Unit_Node, P_Generic); + + elsif Token = Tok_Separate then + Set_Unit (Comp_Unit_Node, P_Subunit); + + elsif Token = Tok_Function + or else Token = Tok_Not + or else Token = Tok_Overriding + or else Token = Tok_Procedure + then + Set_Unit (Comp_Unit_Node, P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Pexp)); + + -- A little bit of an error recovery check here. If we just scanned + -- a subprogram declaration (as indicated by an SIS entry being + -- active), then if the following token is BEGIN or an identifier, + -- or a token which can reasonably start a declaration but cannot + -- start a compilation unit, then we assume that the semicolon in + -- the declaration should have been IS. + + if SIS_Entry_Active then + + if Token = Tok_Begin + or else Token = Tok_Identifier + or else Token in Token_Class_Deckn + then + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Sloc := SIS_Sloc; + Scope.Table (Scope.Last).Ecol := SIS_Ecol; + Scope.Table (Scope.Last).Lreq := False; + SIS_Entry_Active := False; + + -- If we had a missing semicolon in the declaration, then + -- change the message to from to + + if SIS_Missing_Semicolon_Message /= No_Error_Msg then + Change_Error_Text -- Replace: "missing "";"" " + (SIS_Missing_Semicolon_Message, "missing IS"); + + -- Otherwise we saved the semicolon position, so complain + + else + Error_Msg -- CODEFIX + (""";"" should be IS", SIS_Semicolon_Sloc); + end if; + + Body_Node := Unit (Comp_Unit_Node); + Specification_Node := Specification (Body_Node); + Change_Node (Body_Node, N_Subprogram_Body); + Set_Specification (Body_Node, Specification_Node); + Parse_Decls_Begin_End (Body_Node); + Set_Unit (Comp_Unit_Node, Body_Node); + end if; + + -- If we scanned a subprogram body, make sure we did not have private + + elsif Private_Sloc /= No_Location + and then + Nkind (Unit (Comp_Unit_Node)) not in N_Subprogram_Instantiation + and then + Nkind (Unit (Comp_Unit_Node)) /= N_Subprogram_Renaming_Declaration + then + Error_Msg ("cannot have private subprogram body", Private_Sloc); + + -- P_Subprogram can yield an abstract subprogram, but this cannot + -- be a compilation unit. Treat as a subprogram declaration. + + elsif + Nkind (Unit (Comp_Unit_Node)) = N_Abstract_Subprogram_Declaration + then + Error_Msg_N + ("compilation unit cannot be abstract subprogram", + Unit (Comp_Unit_Node)); + + Unit_Node := + New_Node (N_Subprogram_Declaration, Sloc (Comp_Unit_Node)); + Set_Specification (Unit_Node, + Specification (Unit (Comp_Unit_Node))); + Set_Unit (Comp_Unit_Node, Unit_Node); + end if; + + -- Otherwise we have TASK. This is not really an acceptable token, + -- but we accept it to improve error recovery. + + elsif Token = Tok_Task then + Scan; -- Past TASK + + if Token = Tok_Type then + Error_Msg_SP + ("task type cannot be used as compilation unit"); + else + Error_Msg_SP + ("task declaration cannot be used as compilation unit"); + end if; + + -- If in check syntax mode, accept the task anyway. This is done + -- particularly to improve the behavior of GNATCHOP in this case. + + if Operating_Mode = Check_Syntax then + Set_Unit (Comp_Unit_Node, P_Task); + + -- If not in syntax only mode, treat this as horrible error + + else + Cunit_Error_Flag := True; + return Error; + end if; + + else pragma Assert (Token = Tok_Protected); + Scan; -- Past PROTECTED + + if Token = Tok_Type then + Error_Msg_SP + ("protected type cannot be used as compilation unit"); + else + Error_Msg_SP + ("protected declaration cannot be used as compilation unit"); + end if; + + -- If in check syntax mode, accept protected anyway. This is done + -- particularly to improve the behavior of GNATCHOP in this case. + + if Operating_Mode = Check_Syntax then + Set_Unit (Comp_Unit_Node, P_Protected); + + -- If not in syntax only mode, treat this as horrible error + + else + Cunit_Error_Flag := True; + return Error; + end if; + end if; + + -- Here is where locate the compilation unit entity. This is a little + -- tricky, since it is buried in various places. + + Unit_Node := Unit (Comp_Unit_Node); + + -- Another error from which it is hard to recover + + if Nkind (Unit_Node) = N_Subprogram_Body_Stub + or else Nkind (Unit_Node) = N_Package_Body_Stub + then + Cunit_Error_Flag := True; + return Error; + end if; + + -- Only try this if we got an OK unit! + + if Unit_Node /= Error then + if Nkind (Unit_Node) = N_Subunit then + Unit_Node := Proper_Body (Unit_Node); + end if; + + if Nkind (Unit_Node) in N_Generic_Declaration then + Unit_Node := Specification (Unit_Node); + end if; + + if Nkind (Unit_Node) = N_Package_Declaration + or else Nkind (Unit_Node) = N_Subprogram_Declaration + or else Nkind (Unit_Node) = N_Subprogram_Body + or else Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration + then + Unit_Node := Specification (Unit_Node); + + elsif Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration then + if Ada_Version = Ada_83 then + Error_Msg_N + ("(Ada 83) library unit renaming not allowed", Unit_Node); + end if; + end if; + + if Nkind (Unit_Node) = N_Task_Body + or else Nkind (Unit_Node) = N_Protected_Body + or else Nkind (Unit_Node) = N_Task_Type_Declaration + or else Nkind (Unit_Node) = N_Protected_Type_Declaration + or else Nkind (Unit_Node) = N_Single_Task_Declaration + or else Nkind (Unit_Node) = N_Single_Protected_Declaration + then + Name_Node := Defining_Identifier (Unit_Node); + + elsif Nkind (Unit_Node) = N_Function_Instantiation + or else Nkind (Unit_Node) = N_Function_Specification + or else Nkind (Unit_Node) = N_Generic_Function_Renaming_Declaration + or else Nkind (Unit_Node) = N_Generic_Package_Renaming_Declaration + or else Nkind (Unit_Node) = N_Generic_Procedure_Renaming_Declaration + or else Nkind (Unit_Node) = N_Package_Body + or else Nkind (Unit_Node) = N_Package_Instantiation + or else Nkind (Unit_Node) = N_Package_Renaming_Declaration + or else Nkind (Unit_Node) = N_Package_Specification + or else Nkind (Unit_Node) = N_Procedure_Instantiation + or else Nkind (Unit_Node) = N_Procedure_Specification + then + Name_Node := Defining_Unit_Name (Unit_Node); + + -- Anything else is a serious error, abandon scan + + else + raise Error_Resync; + end if; + + Set_Sloc (Comp_Unit_Node, Sloc (Name_Node)); + Set_Sloc (Aux_Decls_Node (Comp_Unit_Node), Sloc (Name_Node)); + + -- Set Entity field in file table. Easier now that we have name! + -- Note that this is also skipped if we had a bad unit + + if Nkind (Name_Node) = N_Defining_Program_Unit_Name then + Set_Cunit_Entity + (Current_Source_Unit, Defining_Identifier (Name_Node)); + else + Set_Cunit_Entity (Current_Source_Unit, Name_Node); + end if; + + Set_Unit_Name + (Current_Source_Unit, Get_Unit_Name (Unit (Comp_Unit_Node))); + + -- If we had a bad unit, make sure the fatal flag is set in the file + -- table entry, since this is surely a fatal error and also set our + -- flag to inhibit the requirement that we be at end of file. + + else + Cunit_Error_Flag := True; + Set_Fatal_Error (Current_Source_Unit); + end if; + + -- Clear away any missing semicolon indication, we are done with that + -- unit, so what's done is done, and we don't want anything hanging + -- around from the attempt to parse it! + + SIS_Entry_Active := False; + + -- Scan out pragmas after unit + + while Token = Tok_Pragma loop + Save_Scan_State (Scan_State); + + -- If we are in syntax scan mode allowing multiple units, then start + -- the next unit if we encounter a configuration pragma, or a source + -- reference pragma. We take care not to actually scan the pragma in + -- this case (we don't want it to take effect for the current unit). + + if Operating_Mode = Check_Syntax then + Scan; -- past Pragma + + if Token = Tok_Identifier + and then + (Is_Configuration_Pragma_Name (Token_Name) + or else Token_Name = Name_Source_Reference) + then + Restore_Scan_State (Scan_State); -- to Pragma + exit; + end if; + end if; + + -- Otherwise eat the pragma, it definitely belongs with the + -- current unit, and not with the following unit. + + Restore_Scan_State (Scan_State); -- to Pragma + P := P_Pragma; + + if No (Pragmas_After (Aux_Decls_Node (Comp_Unit_Node))) then + Set_Pragmas_After + (Aux_Decls_Node (Comp_Unit_Node), New_List); + end if; + + Append (P, Pragmas_After (Aux_Decls_Node (Comp_Unit_Node))); + end loop; + + -- Cancel effect of any outstanding pragma Warnings (Off) + + Set_Warnings_Mode_On (Scan_Ptr); + + -- Ada 83 error checks + + if Ada_Version = Ada_83 then + + -- Check we did not with any child units + + Item := First (Context_Items (Comp_Unit_Node)); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then Nkind (Name (Item)) /= N_Identifier + then + Error_Msg_N ("(Ada 83) child units not allowed", Item); + end if; + + Next (Item); + end loop; + + -- Check that we did not have a PRIVATE keyword present + + if Private_Present (Comp_Unit_Node) then + Error_Msg + ("(Ada 83) private units not allowed", Private_Sloc); + end if; + end if; + + -- If no serious error, then output possible unit information line + -- for gnatchop if we are in syntax only, list units mode. + + if not Cunit_Error_Flag + and then List_Units + and then Operating_Mode = Check_Syntax + then + Unit_Display (Comp_Unit_Node, Cunit_Location, SR_Present); + end if; + + -- And now we should be at the end of file + + if Token /= Tok_EOF then + + -- If we already had to scan for a compilation unit, then don't + -- give any further error message, since it just seems to make + -- things worse, and we already gave a serious error message. + + if Cunit_Error_Flag then + null; + + -- If we are in check syntax mode, then we allow multiple units + -- so we just return with Token not set to Tok_EOF and no message. + + elsif Operating_Mode = Check_Syntax then + return Comp_Unit_Node; + + -- We also allow multiple units if we are in multiple unit mode + + elsif Multiple_Unit_Index /= 0 then + + -- Skip tokens to end of file, so that the -gnatl listing + -- will be complete in this situation, but no need to parse + -- the remaining units; no style checking either. + + declare + Save_Style_Check : constant Boolean := Style_Check; + + begin + Style_Check := False; + + while Token /= Tok_EOF loop + Scan; + end loop; + + Style_Check := Save_Style_Check; + end; + + return Comp_Unit_Node; + + -- Otherwise we have an error. We suppress the error message + -- if we already had a fatal error, since this stops junk + -- cascaded messages in some situations. + + else + if not Fatal_Error (Current_Source_Unit) then + if Token in Token_Class_Cunit then + Error_Msg_SC + ("end of file expected, " & + "file can have only one compilation unit"); + else + Error_Msg_SC ("end of file expected"); + end if; + end if; + end if; + + -- Skip tokens to end of file, so that the -gnatl listing + -- will be complete in this situation, but no error checking + -- other than that provided at the token level. + + while Token /= Tok_EOF loop + Scan; + end loop; + + return Error; + + -- Normal return (we were at the end of file as expected) + + else + return Comp_Unit_Node; + end if; + + exception + + -- An error resync is a serious bomb, so indicate result unit no good + + when Error_Resync => + Set_Fatal_Error (Current_Source_Unit); + return Error; + end P_Compilation_Unit; + + -------------------------- + -- 10.1.1 Library Item -- + -------------------------- + + -- Parsed by P_Compilation_Unit (10.1.1) + + -------------------------------------- + -- 10.1.1 Library Unit Declaration -- + -------------------------------------- + + -- Parsed by P_Compilation_Unit (10.1.1) + + ------------------------------------------------ + -- 10.1.1 Library Unit Renaming Declaration -- + ------------------------------------------------ + + -- Parsed by P_Compilation_Unit (10.1.1) + + ------------------------------- + -- 10.1.1 Library Unit Body -- + ------------------------------- + + -- Parsed by P_Compilation_Unit (10.1.1) + + ------------------------------ + -- 10.1.1 Parent Unit Name -- + ------------------------------ + + -- Parsed (as a name) by its parent construct + + ---------------------------- + -- 10.1.2 Context Clause -- + ---------------------------- + + -- CONTEXT_CLAUSE ::= {CONTEXT_ITEM} + + -- CONTEXT_ITEM ::= WITH_CLAUSE | USE_CLAUSE | WITH_TYPE_CLAUSE + + -- WITH_CLAUSE ::= + -- [LIMITED] [PRIVATE] with library_unit_NAME {,library_unit_NAME}; + -- Note: the two qualifiers are Ada 2005 extensions. + + -- WITH_TYPE_CLAUSE ::= + -- with type type_NAME is access; | with type type_NAME is tagged; + -- Note: this form is obsolete (old GNAT extension). + + -- Error recovery: Cannot raise Error_Resync + + function P_Context_Clause return List_Id is + Item_List : List_Id; + Has_Limited : Boolean := False; + Has_Private : Boolean := False; + Scan_State : Saved_Scan_State; + With_Node : Node_Id; + First_Flag : Boolean; + + begin + Item_List := New_List; + + -- Get keyword casing from WITH keyword in case not set yet + + if Token = Tok_With then + Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing); + end if; + + -- Loop through context items + + loop + if Style_Check then + Style.Check_Indentation; + end if; + + -- Gather any pragmas appearing in the context clause + + P_Pragmas_Opt (Item_List); + + -- Processing for WITH clause + + -- Ada 2005 (AI-50217, AI-262): First check for LIMITED WITH, + -- PRIVATE WITH, or both. + + if Token = Tok_Limited then + Has_Limited := True; + Has_Private := False; + Scan; -- past LIMITED + + -- In the context, LIMITED can only appear in a with_clause + + if Token = Tok_Private then + Has_Private := True; + Scan; -- past PRIVATE + end if; + + if Token /= Tok_With then + Error_Msg_SC -- CODEFIX + ("unexpected LIMITED ignored"); + end if; + + if Ada_Version < Ada_2005 then + Error_Msg_SP ("LIMITED WITH is an Ada 2005 extension"); + Error_Msg_SP + ("\unit must be compiled with -gnat05 switch"); + end if; + + elsif Token = Tok_Private then + Has_Limited := False; + Has_Private := True; + Save_Scan_State (Scan_State); + Scan; -- past PRIVATE + + if Token /= Tok_With then + + -- Keyword is beginning of private child unit + + Restore_Scan_State (Scan_State); -- to PRIVATE + return Item_List; + + elsif Ada_Version < Ada_2005 then + Error_Msg_SP ("`PRIVATE WITH` is an Ada 2005 extension"); + Error_Msg_SP + ("\unit must be compiled with -gnat05 switch"); + end if; + + else + Has_Limited := False; + Has_Private := False; + end if; + + if Token = Tok_With then + Scan; -- past WITH + + if Token = Tok_Type then + + -- WITH TYPE is an obsolete GNAT specific extension + + Error_Msg_SP ("`WITH TYPE` is an obsolete 'G'N'A'T extension"); + Error_Msg_SP ("\use Ada 2005 `LIMITED WITH` clause instead"); + + Scan; -- past TYPE + + T_Is; + + if Token = Tok_Tagged then + Scan; + + elsif Token = Tok_Access then + Scan; + + else + Error_Msg_SC ("expect tagged or access qualifier"); + end if; + + TF_Semicolon; + + else + First_Flag := True; + + -- Loop through names in one with clause, generating a separate + -- N_With_Clause node for each name encountered. + + loop + With_Node := New_Node (N_With_Clause, Token_Ptr); + Append (With_Node, Item_List); + + -- Note that we allow with'ing of child units, even in + -- Ada 83 mode, since presumably if this is not desired, + -- then the compilation of the child unit itself is the + -- place where such an "error" should be caught. + + Set_Name (With_Node, P_Qualified_Simple_Name); + if Name (With_Node) = Error then + Remove (With_Node); + end if; + + Set_First_Name (With_Node, First_Flag); + Set_Limited_Present (With_Node, Has_Limited); + Set_Private_Present (With_Node, Has_Private); + First_Flag := False; + + -- All done if no comma + + exit when Token /= Tok_Comma; + + -- If comma is followed by compilation unit token + -- or by USE, or PRAGMA, then it should have been a + -- semicolon after all + + Save_Scan_State (Scan_State); + Scan; -- past comma + + if Token in Token_Class_Cunit + or else Token = Tok_Use + or else Token = Tok_Pragma + then + Restore_Scan_State (Scan_State); + exit; + end if; + end loop; + + Set_Last_Name (With_Node, True); + TF_Semicolon; + end if; + + -- Processing for USE clause + + elsif Token = Tok_Use then + Append (P_Use_Clause, Item_List); + + -- Anything else is end of context clause + + else + exit; + end if; + end loop; + + return Item_List; + end P_Context_Clause; + + -------------------------- + -- 10.1.2 Context Item -- + -------------------------- + + -- Parsed by P_Context_Clause (10.1.2) + + ------------------------- + -- 10.1.2 With Clause -- + ------------------------- + + -- Parsed by P_Context_Clause (10.1.2) + + ----------------------- + -- 10.1.3 Body Stub -- + ----------------------- + + -- Subprogram stub parsed by P_Subprogram (6.1) + -- Package stub parsed by P_Package (7.1) + -- Task stub parsed by P_Task (9.1) + -- Protected stub parsed by P_Protected (9.4) + + ---------------------------------- + -- 10.1.3 Subprogram Body Stub -- + ---------------------------------- + + -- Parsed by P_Subprogram (6.1) + + ------------------------------- + -- 10.1.3 Package Body Stub -- + ------------------------------- + + -- Parsed by P_Package (7.1) + + ---------------------------- + -- 10.1.3 Task Body Stub -- + ---------------------------- + + -- Parsed by P_Task (9.1) + + --------------------------------- + -- 10.1.3 Protected Body Stub -- + --------------------------------- + + -- Parsed by P_Protected (9.4) + + --------------------- + -- 10.1.3 Subunit -- + --------------------- + + -- SUBUNIT ::= separate (PARENT_UNIT_NAME) PROPER_BODY + + -- PARENT_UNIT_NAME ::= NAME + + -- The caller has checked that the initial token is SEPARATE + + -- Error recovery: cannot raise Error_Resync + + function P_Subunit return Node_Id is + Subunit_Node : Node_Id; + Body_Node : Node_Id; + + begin + Subunit_Node := New_Node (N_Subunit, Token_Ptr); + Body_Node := Error; -- in case no good body found + Scan; -- past SEPARATE; + + U_Left_Paren; + Set_Name (Subunit_Node, P_Qualified_Simple_Name); + U_Right_Paren; + + Ignore (Tok_Semicolon); + + if Token = Tok_Function + or else Token = Tok_Not + or else Token = Tok_Overriding + or else Token = Tok_Procedure + then + Body_Node := P_Subprogram (Pf_Pbod_Pexp); + + elsif Token = Tok_Package then + Body_Node := P_Package (Pf_Pbod_Pexp); + + elsif Token = Tok_Protected then + Scan; -- past PROTECTED + + if Token = Tok_Body then + Body_Node := P_Protected; + else + Error_Msg_AP ("BODY expected"); + return Error; + end if; + + elsif Token = Tok_Task then + Scan; -- past TASK + + if Token = Tok_Body then + Body_Node := P_Task; + else + Error_Msg_AP ("BODY expected"); + return Error; + end if; + + else + Error_Msg_SC ("proper body expected"); + return Error; + end if; + + Set_Proper_Body (Subunit_Node, Body_Node); + return Subunit_Node; + end P_Subunit; + + ------------------ + -- Set_Location -- + ------------------ + + function Set_Location return Source_Ptr is + Physical : Boolean; + Loc : Source_Ptr; + Scan_State : Saved_Scan_State; + + begin + -- A special check. If the first token is pragma, and this is a + -- Source_Reference pragma, then do NOT eat previous comments, since + -- the Source_Reference pragma is required to be the first line in + -- the source file. + + if Token = Tok_Pragma then + Save_Scan_State (Scan_State); + Scan; -- past Pragma + + if Token = Tok_Identifier + and then Token_Name = Name_Source_Reference + then + Restore_Scan_State (Scan_State); + return Token_Ptr; + end if; + + Restore_Scan_State (Scan_State); + end if; + + -- Otherwise acquire previous comments and blank lines + + if Prev_Token = No_Token then + return Source_First (Current_Source_File); + + else + Loc := Prev_Token_Ptr; + loop + exit when Loc = Token_Ptr; + + -- Should we worry about UTF_32 line terminators here + + if Source (Loc) in Line_Terminator then + Skip_Line_Terminators (Loc, Physical); + exit when Physical; + end if; + + Loc := Loc + 1; + end loop; + + return Loc; + end if; + end Set_Location; + + ------------------ + -- Unit_Display -- + ------------------ + + -- The format of the generated line, as expected by GNATCHOP is + + -- Unit {unit} line {line}, file offset {offs} [, SR], file name {file} + + -- where + + -- {unit} unit name with terminating (spec) or (body) + -- {line} starting line number + -- {offs} offset to start of text in file + -- {file} source file name + + -- The SR parameter is present only if a source reference pragma was + -- scanned for this unit. The significance is that gnatchop should not + -- attempt to add another one. + + procedure Unit_Display + (Cunit : Node_Id; + Loc : Source_Ptr; + SR_Present : Boolean) + is + Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (Cunit); + Sind : constant Source_File_Index := Source_Index (Unum); + Unam : constant Unit_Name_Type := Unit_Name (Unum); + + begin + if List_Units then + Write_Str ("Unit "); + Write_Unit_Name (Unit_Name (Unum)); + Unit_Location (Sind, Loc); + + if SR_Present then + Write_Str (", SR"); + end if; + + Write_Str (", file name "); + Write_Name (Get_File_Name (Unam, Nkind (Unit (Cunit)) = N_Subunit)); + Write_Eol; + end if; + end Unit_Display; + + ------------------- + -- Unit_Location -- + ------------------- + + procedure Unit_Location (Sind : Source_File_Index; Loc : Source_Ptr) is + Line : constant Logical_Line_Number := Get_Logical_Line_Number (Loc); + -- Should the above be the physical line number ??? + + begin + Write_Str (" line "); + Write_Int (Int (Line)); + + Write_Str (", file offset "); + Write_Int (Int (Loc) - Int (Source_First (Sind))); + end Unit_Location; + +end Ch10; diff --git a/gcc/ada/par-ch11.adb b/gcc/ada/par-ch11.adb new file mode 100644 index 000000000..b0b0842b9 --- /dev/null +++ b/gcc/ada/par-ch11.adb @@ -0,0 +1,259 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 1 1 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +with Sinfo.CN; use Sinfo.CN; + +separate (Par) +package body Ch11 is + + -- Local functions, used only in this chapter + + function P_Exception_Handler return Node_Id; + function P_Exception_Choice return Node_Id; + + --------------------------------- + -- 11.1 Exception Declaration -- + --------------------------------- + + -- Parsed by P_Identifier_Declaration (3.3.1) + + ------------------------------------------ + -- 11.2 Handled Sequence Of Statements -- + ------------------------------------------ + + -- HANDLED_SEQUENCE_OF_STATEMENTS ::= + -- SEQUENCE_OF_STATEMENTS + -- [exception + -- EXCEPTION_HANDLER + -- {EXCEPTION_HANDLER}] + + -- Error_Recovery : Cannot raise Error_Resync + + function P_Handled_Sequence_Of_Statements return Node_Id is + Handled_Stmt_Seq_Node : Node_Id; + + begin + Handled_Stmt_Seq_Node := + New_Node (N_Handled_Sequence_Of_Statements, Token_Ptr); + Set_Statements + (Handled_Stmt_Seq_Node, P_Sequence_Of_Statements (SS_Extm_Sreq)); + + if Token = Tok_Exception then + Scan; -- past EXCEPTION + Set_Exception_Handlers + (Handled_Stmt_Seq_Node, Parse_Exception_Handlers); + end if; + + return Handled_Stmt_Seq_Node; + end P_Handled_Sequence_Of_Statements; + + ----------------------------- + -- 11.2 Exception Handler -- + ----------------------------- + + -- EXCEPTION_HANDLER ::= + -- when [CHOICE_PARAMETER_SPECIFICATION :] + -- EXCEPTION_CHOICE {| EXCEPTION_CHOICE} => + -- SEQUENCE_OF_STATEMENTS + + -- CHOICE_PARAMETER_SPECIFICATION ::= DEFINING_IDENTIFIER + + -- Error recovery: cannot raise Error_Resync + + function P_Exception_Handler return Node_Id is + Scan_State : Saved_Scan_State; + Handler_Node : Node_Id; + Choice_Param_Node : Node_Id; + + begin + Exception_Handler_Encountered := True; + Handler_Node := New_Node (N_Exception_Handler, Token_Ptr); + Set_Local_Raise_Statements (Handler_Node, No_Elist); + + if Style_Check then + Style.Check_Indentation; + end if; + + T_When; + + -- Test for possible choice parameter present + + if Token = Tok_Identifier then + Choice_Param_Node := Token_Node; + Save_Scan_State (Scan_State); -- at identifier + Scan; -- past identifier + + if Token = Tok_Colon then + if Ada_Version = Ada_83 then + Error_Msg_SP ("(Ada 83) choice parameter not allowed!"); + end if; + + Scan; -- past : + Change_Identifier_To_Defining_Identifier (Choice_Param_Node); + Set_Choice_Parameter (Handler_Node, Choice_Param_Node); + + elsif Token = Tok_Others then + Error_Msg_AP -- CODEFIX + ("missing "":"""); + Change_Identifier_To_Defining_Identifier (Choice_Param_Node); + Set_Choice_Parameter (Handler_Node, Choice_Param_Node); + + else + Restore_Scan_State (Scan_State); -- to identifier + end if; + end if; + + -- Loop through exception choices + + Set_Exception_Choices (Handler_Node, New_List); + + loop + Append (P_Exception_Choice, Exception_Choices (Handler_Node)); + exit when Token /= Tok_Vertical_Bar; + Scan; -- past vertical bar + end loop; + + TF_Arrow; + Set_Statements (Handler_Node, P_Sequence_Of_Statements (SS_Sreq_Whtm)); + return Handler_Node; + end P_Exception_Handler; + + ------------------------------------------ + -- 11.2 Choice Parameter Specification -- + ------------------------------------------ + + -- Parsed by P_Exception_Handler (11.2) + + ---------------------------- + -- 11.2 Exception Choice -- + ---------------------------- + + -- EXCEPTION_CHOICE ::= exception_NAME | others + + -- Error recovery: cannot raise Error_Resync. If an error occurs, then the + -- scan pointer is advanced to the next arrow or vertical bar or semicolon. + + function P_Exception_Choice return Node_Id is + begin + + if Token = Tok_Others then + Scan; -- past OTHERS + return New_Node (N_Others_Choice, Prev_Token_Ptr); + + else + return P_Name; -- exception name + end if; + + exception + when Error_Resync => + Resync_Choice; + return Error; + end P_Exception_Choice; + + --------------------------- + -- 11.3 Raise Statement -- + --------------------------- + + -- RAISE_STATEMENT ::= raise [exception_NAME]; + + -- The caller has verified that the initial token is RAISE + + -- Error recovery: can raise Error_Resync + + function P_Raise_Statement return Node_Id is + Raise_Node : Node_Id; + + begin + Raise_Node := New_Node (N_Raise_Statement, Token_Ptr); + Scan; -- past RAISE + + if Token /= Tok_Semicolon then + Set_Name (Raise_Node, P_Name); + end if; + + if Token = Tok_With then + if Ada_Version < Ada_2005 then + Error_Msg_SC ("string expression in raise is Ada 2005 extension"); + Error_Msg_SC ("\unit must be compiled with -gnat05 switch"); + end if; + + Scan; -- past WITH + Set_Expression (Raise_Node, P_Expression); + end if; + + TF_Semicolon; + return Raise_Node; + end P_Raise_Statement; + + ------------------------------ + -- Parse_Exception_Handlers -- + ------------------------------ + + -- This routine scans out a list of exception handlers appearing in a + -- construct as: + + -- exception + -- EXCEPTION_HANDLER {EXCEPTION_HANDLER} + + -- The caller has scanned out the EXCEPTION keyword + + -- Control returns after scanning the last exception handler, presumably + -- at the keyword END, but this is not checked in this routine. + + -- Error recovery: cannot raise Error_Resync + + function Parse_Exception_Handlers return List_Id is + Handler : Node_Id; + Handlers_List : List_Id; + + begin + Handlers_List := New_List; + P_Pragmas_Opt (Handlers_List); + + if Token = Tok_End then + Error_Msg_SC ("must have at least one exception handler!"); + + else + loop + Handler := P_Exception_Handler; + Append (Handler, Handlers_List); + + -- Note: no need to check for pragmas here. Although the + -- syntax officially allows them in this position, they + -- will have been swallowed up as part of the statement + -- sequence of the handler we just scanned out. + + exit when Token /= Tok_When; + end loop; + end if; + + return Handlers_List; + end Parse_Exception_Handlers; + +end Ch11; diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb new file mode 100644 index 000000000..9e8040389 --- /dev/null +++ b/gcc/ada/par-ch12.adb @@ -0,0 +1,1262 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 1 2 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +separate (Par) +package body Ch12 is + + -- Local functions, used only in this chapter + + function P_Formal_Derived_Type_Definition return Node_Id; + function P_Formal_Discrete_Type_Definition return Node_Id; + function P_Formal_Fixed_Point_Definition return Node_Id; + function P_Formal_Floating_Point_Definition return Node_Id; + function P_Formal_Modular_Type_Definition return Node_Id; + function P_Formal_Package_Declaration return Node_Id; + function P_Formal_Private_Type_Definition return Node_Id; + function P_Formal_Signed_Integer_Type_Definition return Node_Id; + function P_Formal_Subprogram_Declaration return Node_Id; + function P_Formal_Type_Declaration return Node_Id; + function P_Formal_Type_Definition return Node_Id; + function P_Generic_Association return Node_Id; + + procedure P_Formal_Object_Declarations (Decls : List_Id); + -- Scans one or more formal object declarations and appends them to + -- Decls. Scans more than one declaration only in the case where the + -- source has a declaration with multiple defining identifiers. + + -------------------------------- + -- 12.1 Generic (also 8.5.5) -- + -------------------------------- + + -- This routine parses either one of the forms of a generic declaration + -- or a generic renaming declaration. + + -- GENERIC_DECLARATION ::= + -- GENERIC_SUBPROGRAM_DECLARATION | GENERIC_PACKAGE_DECLARATION + + -- GENERIC_SUBPROGRAM_DECLARATION ::= + -- GENERIC_FORMAL_PART SUBPROGRAM_SPECIFICATION + -- [ASPECT_SPECIFICATIONS]; + + -- GENERIC_PACKAGE_DECLARATION ::= + -- GENERIC_FORMAL_PART PACKAGE_SPECIFICATION + -- [ASPECT_SPECIFICATIONS]; + + -- GENERIC_FORMAL_PART ::= + -- generic {GENERIC_FORMAL_PARAMETER_DECLARATION | USE_CLAUSE} + + -- GENERIC_RENAMING_DECLARATION ::= + -- generic package DEFINING_PROGRAM_UNIT_NAME + -- renames generic_package_NAME + -- | generic procedure DEFINING_PROGRAM_UNIT_NAME + -- renames generic_procedure_NAME + -- | generic function DEFINING_PROGRAM_UNIT_NAME + -- renames generic_function_NAME + + -- GENERIC_FORMAL_PARAMETER_DECLARATION ::= + -- FORMAL_OBJECT_DECLARATION + -- | FORMAL_TYPE_DECLARATION + -- | FORMAL_SUBPROGRAM_DECLARATION + -- | FORMAL_PACKAGE_DECLARATION + + -- The caller has checked that the initial token is GENERIC + + -- Error recovery: can raise Error_Resync + + function P_Generic return Node_Id is + Gen_Sloc : constant Source_Ptr := Token_Ptr; + Gen_Decl : Node_Id; + Decl_Node : Node_Id; + Decls : List_Id; + Def_Unit : Node_Id; + Ren_Token : Token_Type; + Scan_State : Saved_Scan_State; + + begin + Scan; -- past GENERIC + + if Token = Tok_Private then + Error_Msg_SC -- CODEFIX + ("PRIVATE goes before GENERIC, not after"); + Scan; -- past junk PRIVATE token + end if; + + Save_Scan_State (Scan_State); -- at token past GENERIC + + -- Check for generic renaming declaration case + + if Token = Tok_Package + or else Token = Tok_Function + or else Token = Tok_Procedure + then + Ren_Token := Token; + Scan; -- scan past PACKAGE, FUNCTION or PROCEDURE + + if Token = Tok_Identifier then + Def_Unit := P_Defining_Program_Unit_Name; + + Check_Misspelling_Of (Tok_Renames); + + if Token = Tok_Renames then + if Ren_Token = Tok_Package then + Decl_Node := New_Node + (N_Generic_Package_Renaming_Declaration, Gen_Sloc); + + elsif Ren_Token = Tok_Procedure then + Decl_Node := New_Node + (N_Generic_Procedure_Renaming_Declaration, Gen_Sloc); + + else -- Ren_Token = Tok_Function then + Decl_Node := New_Node + (N_Generic_Function_Renaming_Declaration, Gen_Sloc); + end if; + + Scan; -- past RENAMES + Set_Defining_Unit_Name (Decl_Node, Def_Unit); + Set_Name (Decl_Node, P_Name); + TF_Semicolon; + return Decl_Node; + end if; + end if; + end if; + + -- Fall through if this is *not* a generic renaming declaration + + Restore_Scan_State (Scan_State); + Decls := New_List; + + -- Loop through generic parameter declarations and use clauses + + Decl_Loop : loop + P_Pragmas_Opt (Decls); + + if Token = Tok_Private then + Error_Msg_S ("generic private child packages not permitted"); + Scan; -- past PRIVATE + end if; + + if Token = Tok_Use then + Append (P_Use_Clause, Decls); + else + -- Parse a generic parameter declaration + + if Token = Tok_Identifier then + P_Formal_Object_Declarations (Decls); + + elsif Token = Tok_Type then + Append (P_Formal_Type_Declaration, Decls); + + elsif Token = Tok_With then + Scan; -- past WITH + + if Token = Tok_Package then + Append (P_Formal_Package_Declaration, Decls); + + elsif Token = Tok_Procedure or Token = Tok_Function then + Append (P_Formal_Subprogram_Declaration, Decls); + + else + Error_Msg_BC -- CODEFIX + ("FUNCTION, PROCEDURE or PACKAGE expected here"); + Resync_Past_Semicolon; + end if; + + elsif Token = Tok_Subtype then + Error_Msg_SC ("subtype declaration not allowed " & + "as generic parameter declaration!"); + Resync_Past_Semicolon; + + else + exit Decl_Loop; + end if; + end if; + end loop Decl_Loop; + + -- Generic formal part is scanned, scan out subprogram or package spec + + if Token = Tok_Package then + Gen_Decl := New_Node (N_Generic_Package_Declaration, Gen_Sloc); + Set_Specification (Gen_Decl, P_Package (Pf_Spcn, Gen_Decl)); + + else + Gen_Decl := New_Node (N_Generic_Subprogram_Declaration, Gen_Sloc); + + Set_Specification (Gen_Decl, P_Subprogram_Specification); + + if Nkind (Defining_Unit_Name (Specification (Gen_Decl))) = + N_Defining_Program_Unit_Name + and then Scope.Last > 0 + then + Error_Msg_SP ("child unit allowed only at library level"); + end if; + + P_Aspect_Specifications (Gen_Decl); + end if; + + Set_Generic_Formal_Declarations (Gen_Decl, Decls); + return Gen_Decl; + end P_Generic; + + ------------------------------- + -- 12.1 Generic Declaration -- + ------------------------------- + + -- Parsed by P_Generic (12.1) + + ------------------------------------------ + -- 12.1 Generic Subprogram Declaration -- + ------------------------------------------ + + -- Parsed by P_Generic (12.1) + + --------------------------------------- + -- 12.1 Generic Package Declaration -- + --------------------------------------- + + -- Parsed by P_Generic (12.1) + + ------------------------------- + -- 12.1 Generic Formal Part -- + ------------------------------- + + -- Parsed by P_Generic (12.1) + + ------------------------------------------------- + -- 12.1 Generic Formal Parameter Declaration -- + ------------------------------------------------- + + -- Parsed by P_Generic (12.1) + + --------------------------------- + -- 12.3 Generic Instantiation -- + --------------------------------- + + -- Generic package instantiation parsed by P_Package (7.1) + -- Generic procedure instantiation parsed by P_Subprogram (6.1) + -- Generic function instantiation parsed by P_Subprogram (6.1) + + ------------------------------- + -- 12.3 Generic Actual Part -- + ------------------------------- + + -- GENERIC_ACTUAL_PART ::= + -- (GENERIC_ASSOCIATION {, GENERIC_ASSOCIATION}) + + -- Returns a list of generic associations, or Empty if none are present + + -- Error recovery: cannot raise Error_Resync + + function P_Generic_Actual_Part_Opt return List_Id is + Association_List : List_Id; + + begin + -- Figure out if a generic actual part operation is present. Clearly + -- there is no generic actual part if the current token is semicolon + -- or if we have aspect specifications present. + + if Token = Tok_Semicolon or else Aspect_Specifications_Present then + return No_List; + + -- If we don't have a left paren, then we have an error, and the job + -- is to figure out whether a left paren or semicolon was intended. + -- We assume a missing left paren (and hence a generic actual part + -- present) if the current token is not on a new line, or if it is + -- indented from the subprogram token. Otherwise assume missing + -- semicolon (which will be diagnosed by caller) and no generic part + + elsif Token /= Tok_Left_Paren + and then Token_Is_At_Start_Of_Line + and then Start_Column <= Scope.Table (Scope.Last).Ecol + then + return No_List; + + -- Otherwise we have a generic actual part (either a left paren is + -- present, or we have decided that there must be a missing left paren) + + else + Association_List := New_List; + T_Left_Paren; + + loop + Append (P_Generic_Association, Association_List); + exit when not Comma_Present; + end loop; + + T_Right_Paren; + return Association_List; + end if; + + end P_Generic_Actual_Part_Opt; + + ------------------------------- + -- 12.3 Generic Association -- + ------------------------------- + + -- GENERIC_ASSOCIATION ::= + -- [generic_formal_parameter_SELECTOR_NAME =>] + -- EXPLICIT_GENERIC_ACTUAL_PARAMETER + + -- EXPLICIT_GENERIC_ACTUAL_PARAMETER ::= + -- EXPRESSION | variable_NAME | subprogram_NAME + -- | entry_NAME | SUBTYPE_MARK | package_instance_NAME + + -- Error recovery: cannot raise Error_Resync + + function P_Generic_Association return Node_Id is + Scan_State : Saved_Scan_State; + Param_Name_Node : Node_Id; + Generic_Assoc_Node : Node_Id; + + begin + Generic_Assoc_Node := New_Node (N_Generic_Association, Token_Ptr); + + -- Ada2005: an association can be given by: others => <> + + if Token = Tok_Others then + if Ada_Version < Ada_2005 then + Error_Msg_SP + ("partial parametrization of formal packages" & + " is an Ada 2005 extension"); + Error_Msg_SP + ("\unit must be compiled with -gnat05 switch"); + end if; + + Scan; -- past OTHERS + + if Token /= Tok_Arrow then + Error_Msg_BC ("expect arrow after others"); + else + Scan; -- past arrow + end if; + + if Token /= Tok_Box then + Error_Msg_BC ("expect Box after arrow"); + else + Scan; -- past box + end if; + + -- Source position of the others choice is beginning of construct + + return New_Node (N_Others_Choice, Sloc (Generic_Assoc_Node)); + end if; + + if Token in Token_Class_Desig then + Param_Name_Node := Token_Node; + Save_Scan_State (Scan_State); -- at designator + Scan; -- past simple name or operator symbol + + if Token = Tok_Arrow then + Scan; -- past arrow + Set_Selector_Name (Generic_Assoc_Node, Param_Name_Node); + else + Restore_Scan_State (Scan_State); -- to designator + end if; + end if; + + -- In Ada 2005 the actual can be a box + + if Token = Tok_Box then + Scan; + Set_Box_Present (Generic_Assoc_Node); + Set_Explicit_Generic_Actual_Parameter (Generic_Assoc_Node, Empty); + + else + Set_Explicit_Generic_Actual_Parameter + (Generic_Assoc_Node, P_Expression); + end if; + + return Generic_Assoc_Node; + end P_Generic_Association; + + --------------------------------------------- + -- 12.3 Explicit Generic Actual Parameter -- + --------------------------------------------- + + -- Parsed by P_Generic_Association (12.3) + + -------------------------------------- + -- 12.4 Formal Object Declarations -- + -------------------------------------- + + -- FORMAL_OBJECT_DECLARATION ::= + -- DEFINING_IDENTIFIER_LIST : + -- MODE [NULL_EXCLUSION] SUBTYPE_MARK [:= DEFAULT_EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; + -- | DEFINING_IDENTIFIER_LIST : + -- MODE ACCESS_DEFINITION [:= DEFAULT_EXPRESSION]; + -- [ASPECT_SPECIFICATIONS]; + + -- The caller has checked that the initial token is an identifier + + -- Error recovery: cannot raise Error_Resync + + procedure P_Formal_Object_Declarations (Decls : List_Id) is + Decl_Node : Node_Id; + Ident : Nat; + Not_Null_Present : Boolean := False; + Num_Idents : Nat; + Scan_State : Saved_Scan_State; + + Idents : array (Int range 1 .. 4096) of Entity_Id; + -- This array holds the list of defining identifiers. The upper bound + -- of 4096 is intended to be essentially infinite, and we do not even + -- bother to check for it being exceeded. + + begin + Idents (1) := P_Defining_Identifier (C_Comma_Colon); + Num_Idents := 1; + while Comma_Present loop + Num_Idents := Num_Idents + 1; + Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon); + end loop; + + T_Colon; + + -- If there are multiple identifiers, we repeatedly scan the + -- type and initialization expression information by resetting + -- the scan pointer (so that we get completely separate trees + -- for each occurrence). + + if Num_Idents > 1 then + Save_Scan_State (Scan_State); + end if; + + -- Loop through defining identifiers in list + + Ident := 1; + Ident_Loop : loop + Decl_Node := New_Node (N_Formal_Object_Declaration, Token_Ptr); + Set_Defining_Identifier (Decl_Node, Idents (Ident)); + P_Mode (Decl_Node); + + Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-423) + + -- Ada 2005 (AI-423): Formal object with an access definition + + if Token = Tok_Access then + + -- The access definition is still parsed and set even though + -- the compilation may not use the proper switch. This action + -- ensures the required local error recovery. + + Set_Access_Definition (Decl_Node, + P_Access_Definition (Not_Null_Present)); + + if Ada_Version < Ada_2005 then + Error_Msg_SP + ("access definition not allowed in formal object " & + "declaration"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + end if; + + -- Formal object with a subtype mark + + else + Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); + Set_Subtype_Mark (Decl_Node, P_Subtype_Mark_Resync); + end if; + + No_Constraint; + Set_Default_Expression (Decl_Node, Init_Expr_Opt); + P_Aspect_Specifications (Decl_Node); + + if Ident > 1 then + Set_Prev_Ids (Decl_Node, True); + end if; + + if Ident < Num_Idents then + Set_More_Ids (Decl_Node, True); + end if; + + Append (Decl_Node, Decls); + + exit Ident_Loop when Ident = Num_Idents; + Ident := Ident + 1; + Restore_Scan_State (Scan_State); + end loop Ident_Loop; + end P_Formal_Object_Declarations; + + ----------------------------------- + -- 12.5 Formal Type Declaration -- + ----------------------------------- + + -- FORMAL_TYPE_DECLARATION ::= + -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] + -- is FORMAL_TYPE_DEFINITION + -- [ASPECT_SPECIFICATIONS]; + + -- The caller has checked that the initial token is TYPE + + -- Error recovery: cannot raise Error_Resync + + function P_Formal_Type_Declaration return Node_Id is + Decl_Node : Node_Id; + Def_Node : Node_Id; + + begin + Decl_Node := New_Node (N_Formal_Type_Declaration, Token_Ptr); + Scan; -- past TYPE + Set_Defining_Identifier (Decl_Node, P_Defining_Identifier); + + if P_Unknown_Discriminant_Part_Opt then + Set_Unknown_Discriminants_Present (Decl_Node, True); + else + Set_Discriminant_Specifications + (Decl_Node, P_Known_Discriminant_Part_Opt); + end if; + + T_Is; + + Def_Node := P_Formal_Type_Definition; + + if Def_Node /= Error then + Set_Formal_Type_Definition (Decl_Node, Def_Node); + P_Aspect_Specifications (Decl_Node); + + else + Decl_Node := Error; + + -- If we have aspect specifications, skip them + + if Aspect_Specifications_Present then + P_Aspect_Specifications (Error); + + -- If we have semicolon, skip it to avoid cascaded errors + + elsif Token = Tok_Semicolon then + Scan; -- past semicolon + end if; + end if; + + return Decl_Node; + end P_Formal_Type_Declaration; + + ---------------------------------- + -- 12.5 Formal Type Definition -- + ---------------------------------- + + -- FORMAL_TYPE_DEFINITION ::= + -- FORMAL_PRIVATE_TYPE_DEFINITION + -- | FORMAL_DERIVED_TYPE_DEFINITION + -- | FORMAL_DISCRETE_TYPE_DEFINITION + -- | FORMAL_SIGNED_INTEGER_TYPE_DEFINITION + -- | FORMAL_MODULAR_TYPE_DEFINITION + -- | FORMAL_FLOATING_POINT_DEFINITION + -- | FORMAL_ORDINARY_FIXED_POINT_DEFINITION + -- | FORMAL_DECIMAL_FIXED_POINT_DEFINITION + -- | FORMAL_ARRAY_TYPE_DEFINITION + -- | FORMAL_ACCESS_TYPE_DEFINITION + -- | FORMAL_INTERFACE_TYPE_DEFINITION + + -- FORMAL_ARRAY_TYPE_DEFINITION ::= ARRAY_TYPE_DEFINITION + + -- FORMAL_ACCESS_TYPE_DEFINITION ::= ACCESS_TYPE_DEFINITION + + -- FORMAL_INTERFACE_TYPE_DEFINITION ::= INTERFACE_TYPE_DEFINITION + + function P_Formal_Type_Definition return Node_Id is + Scan_State : Saved_Scan_State; + Typedef_Node : Node_Id; + + begin + if Token_Name = Name_Abstract then + Check_95_Keyword (Tok_Abstract, Tok_Tagged); + end if; + + if Token_Name = Name_Tagged then + Check_95_Keyword (Tok_Tagged, Tok_Private); + Check_95_Keyword (Tok_Tagged, Tok_Limited); + end if; + + case Token is + + -- Mostly we can tell what we have from the initial token. The one + -- exception is ABSTRACT, where we have to scan ahead to see if we + -- have a formal derived type or a formal private type definition. + + -- In addition, in Ada 2005 LIMITED may appear after abstract, so + -- that the lookahead must be extended by one more token. + + when Tok_Abstract => + Save_Scan_State (Scan_State); + Scan; -- past ABSTRACT + + if Token = Tok_New then + Restore_Scan_State (Scan_State); -- to ABSTRACT + return P_Formal_Derived_Type_Definition; + + elsif Token = Tok_Limited then + Scan; -- past LIMITED + + if Token = Tok_New then + Restore_Scan_State (Scan_State); -- to ABSTRACT + return P_Formal_Derived_Type_Definition; + + else + Restore_Scan_State (Scan_State); -- to ABSTRACT + return P_Formal_Private_Type_Definition; + end if; + + -- Ada 2005 (AI-443): Abstract synchronized formal derived type + + elsif Token = Tok_Synchronized then + Restore_Scan_State (Scan_State); -- to ABSTRACT + return P_Formal_Derived_Type_Definition; + + else + Restore_Scan_State (Scan_State); -- to ABSTRACT + return P_Formal_Private_Type_Definition; + end if; + + when Tok_Access => + return P_Access_Type_Definition; + + when Tok_Array => + return P_Array_Type_Definition; + + when Tok_Delta => + return P_Formal_Fixed_Point_Definition; + + when Tok_Digits => + return P_Formal_Floating_Point_Definition; + + when Tok_Interface => -- Ada 2005 (AI-251) + return P_Interface_Type_Definition (Abstract_Present => False); + + when Tok_Left_Paren => + return P_Formal_Discrete_Type_Definition; + + when Tok_Limited => + Save_Scan_State (Scan_State); + Scan; -- past LIMITED + + if Token = Tok_Interface then + Typedef_Node := + P_Interface_Type_Definition (Abstract_Present => False); + Set_Limited_Present (Typedef_Node); + return Typedef_Node; + + elsif Token = Tok_New then + Restore_Scan_State (Scan_State); -- to LIMITED + return P_Formal_Derived_Type_Definition; + + else + if Token = Tok_Abstract then + Error_Msg_SC -- CODEFIX + ("ABSTRACT must come before LIMITED"); + Scan; -- past improper ABSTRACT + + if Token = Tok_New then + Restore_Scan_State (Scan_State); -- to LIMITED + return P_Formal_Derived_Type_Definition; + + else + Restore_Scan_State (Scan_State); + return P_Formal_Private_Type_Definition; + end if; + end if; + + Restore_Scan_State (Scan_State); + return P_Formal_Private_Type_Definition; + end if; + + when Tok_Mod => + return P_Formal_Modular_Type_Definition; + + when Tok_New => + return P_Formal_Derived_Type_Definition; + + when Tok_Not => + if P_Null_Exclusion then + Typedef_Node := P_Access_Type_Definition; + Set_Null_Exclusion_Present (Typedef_Node); + return Typedef_Node; + + else + Error_Msg_SC ("expect valid formal access definition!"); + Resync_Past_Semicolon; + return Error; + end if; + + when Tok_Private | + Tok_Tagged => + return P_Formal_Private_Type_Definition; + + when Tok_Range => + return P_Formal_Signed_Integer_Type_Definition; + + when Tok_Record => + Error_Msg_SC ("record not allowed in generic type definition!"); + Discard_Junk_Node (P_Record_Definition); + return Error; + + -- Ada 2005 (AI-345): Task, Protected or Synchronized interface or + -- (AI-443): Synchronized formal derived type declaration. + + when Tok_Protected | + Tok_Synchronized | + Tok_Task => + + declare + Saved_Token : constant Token_Type := Token; + + begin + Scan; -- past TASK, PROTECTED or SYNCHRONIZED + + -- Synchronized derived type + + if Token = Tok_New then + Typedef_Node := P_Formal_Derived_Type_Definition; + + if Saved_Token = Tok_Synchronized then + Set_Synchronized_Present (Typedef_Node); + else + Error_Msg_SC ("invalid kind of formal derived type"); + end if; + + -- Interface + + else + Typedef_Node := + P_Interface_Type_Definition (Abstract_Present => False); + + case Saved_Token is + when Tok_Task => + Set_Task_Present (Typedef_Node); + + when Tok_Protected => + Set_Protected_Present (Typedef_Node); + + when Tok_Synchronized => + Set_Synchronized_Present (Typedef_Node); + + when others => + null; + end case; + end if; + + return Typedef_Node; + end; + + when others => + Error_Msg_BC ("expecting generic type definition here"); + Resync_Past_Semicolon; + return Error; + + end case; + end P_Formal_Type_Definition; + + -------------------------------------------- + -- 12.5.1 Formal Private Type Definition -- + -------------------------------------------- + + -- FORMAL_PRIVATE_TYPE_DEFINITION ::= + -- [[abstract] tagged] [limited] private + + -- The caller has checked the initial token is PRIVATE, ABSTRACT, + -- TAGGED or LIMITED + + -- Error recovery: cannot raise Error_Resync + + function P_Formal_Private_Type_Definition return Node_Id is + Def_Node : Node_Id; + + begin + Def_Node := New_Node (N_Formal_Private_Type_Definition, Token_Ptr); + + if Token = Tok_Abstract then + Scan; -- past ABSTRACT + + if Token_Name = Name_Tagged then + Check_95_Keyword (Tok_Tagged, Tok_Private); + Check_95_Keyword (Tok_Tagged, Tok_Limited); + end if; + + if Token /= Tok_Tagged then + Error_Msg_SP ("ABSTRACT must be followed by TAGGED"); + else + Set_Abstract_Present (Def_Node, True); + end if; + end if; + + if Token = Tok_Tagged then + Set_Tagged_Present (Def_Node, True); + Scan; -- past TAGGED + end if; + + if Token = Tok_Limited then + Set_Limited_Present (Def_Node, True); + Scan; -- past LIMITED + end if; + + if Token = Tok_Abstract then + if Prev_Token = Tok_Tagged then + Error_Msg_SC -- CODEFIX + ("ABSTRACT must come before TAGGED"); + elsif Prev_Token = Tok_Limited then + Error_Msg_SC -- CODEFIX + ("ABSTRACT must come before LIMITED"); + end if; + + Resync_Past_Semicolon; + + elsif Token = Tok_Tagged then + Error_Msg_SC -- CODEFIX + ("TAGGED must come before LIMITED"); + Resync_Past_Semicolon; + end if; + + Set_Sloc (Def_Node, Token_Ptr); + T_Private; + + if Token = Tok_Tagged then -- CODEFIX + Error_Msg_SC ("TAGGED must come before PRIVATE"); + Scan; -- past TAGGED + + elsif Token = Tok_Abstract then -- CODEFIX + Error_Msg_SC ("`ABSTRACT TAGGED` must come before PRIVATE"); + Scan; -- past ABSTRACT + + if Token = Tok_Tagged then + Scan; -- past TAGGED + end if; + end if; + + return Def_Node; + end P_Formal_Private_Type_Definition; + + -------------------------------------------- + -- 12.5.1 Formal Derived Type Definition -- + -------------------------------------------- + + -- FORMAL_DERIVED_TYPE_DEFINITION ::= + -- [abstract] [limited | synchronized] + -- new SUBTYPE_MARK [[and INTERFACE_LIST] with private] + + -- The caller has checked the initial token(s) is/are NEW, ABSTRACT NEW, + -- or LIMITED NEW, ABSTRACT LIMITED NEW, SYNCHRONIZED NEW or ABSTRACT + -- SYNCHRONIZED NEW. + + -- Error recovery: cannot raise Error_Resync + + function P_Formal_Derived_Type_Definition return Node_Id is + Def_Node : Node_Id; + + begin + Def_Node := New_Node (N_Formal_Derived_Type_Definition, Token_Ptr); + + if Token = Tok_Abstract then + Set_Abstract_Present (Def_Node); + Scan; -- past ABSTRACT + end if; + + if Token = Tok_Limited then + Set_Limited_Present (Def_Node); + Scan; -- past LIMITED + + if Ada_Version < Ada_2005 then + Error_Msg_SP + ("LIMITED in derived type is an Ada 2005 extension"); + Error_Msg_SP + ("\unit must be compiled with -gnat05 switch"); + end if; + + elsif Token = Tok_Synchronized then + Set_Synchronized_Present (Def_Node); + Scan; -- past SYNCHRONIZED + + if Ada_Version < Ada_2005 then + Error_Msg_SP + ("SYNCHRONIZED in derived type is an Ada 2005 extension"); + Error_Msg_SP + ("\unit must be compiled with -gnat05 switch"); + end if; + end if; + + if Token = Tok_Abstract then + Scan; -- past ABSTRACT, diagnosed already in caller. + end if; + + Scan; -- past NEW; + Set_Subtype_Mark (Def_Node, P_Subtype_Mark); + No_Constraint; + + -- Ada 2005 (AI-251): Deal with interfaces + + if Token = Tok_And then + Scan; -- past AND + + if Ada_Version < Ada_2005 then + Error_Msg_SP + ("abstract interface is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + end if; + + Set_Interface_List (Def_Node, New_List); + + loop + Append (P_Qualified_Simple_Name, Interface_List (Def_Node)); + exit when Token /= Tok_And; + Scan; -- past AND + end loop; + end if; + + if Token = Tok_With then + Scan; -- past WITH + Set_Private_Present (Def_Node, True); + T_Private; + + elsif Token = Tok_Tagged then + Scan; + + if Token = Tok_Private then + Error_Msg_SC -- CODEFIX + ("TAGGED should be WITH"); + Set_Private_Present (Def_Node, True); + T_Private; + else + Ignore (Tok_Tagged); + end if; + end if; + + return Def_Node; + end P_Formal_Derived_Type_Definition; + + --------------------------------------------- + -- 12.5.2 Formal Discrete Type Definition -- + --------------------------------------------- + + -- FORMAL_DISCRETE_TYPE_DEFINITION ::= (<>) + + -- The caller has checked the initial token is left paren + + -- Error recovery: cannot raise Error_Resync + + function P_Formal_Discrete_Type_Definition return Node_Id is + Def_Node : Node_Id; + + begin + Def_Node := New_Node (N_Formal_Discrete_Type_Definition, Token_Ptr); + Scan; -- past left paren + T_Box; + T_Right_Paren; + return Def_Node; + end P_Formal_Discrete_Type_Definition; + + --------------------------------------------------- + -- 12.5.2 Formal Signed Integer Type Definition -- + --------------------------------------------------- + + -- FORMAL_SIGNED_INTEGER_TYPE_DEFINITION ::= range <> + + -- The caller has checked the initial token is RANGE + + -- Error recovery: cannot raise Error_Resync + + function P_Formal_Signed_Integer_Type_Definition return Node_Id is + Def_Node : Node_Id; + + begin + Def_Node := + New_Node (N_Formal_Signed_Integer_Type_Definition, Token_Ptr); + Scan; -- past RANGE + T_Box; + return Def_Node; + end P_Formal_Signed_Integer_Type_Definition; + + -------------------------------------------- + -- 12.5.2 Formal Modular Type Definition -- + -------------------------------------------- + + -- FORMAL_MODULAR_TYPE_DEFINITION ::= mod <> + + -- The caller has checked the initial token is MOD + + -- Error recovery: cannot raise Error_Resync + + function P_Formal_Modular_Type_Definition return Node_Id is + Def_Node : Node_Id; + + begin + Def_Node := + New_Node (N_Formal_Modular_Type_Definition, Token_Ptr); + Scan; -- past MOD + T_Box; + return Def_Node; + end P_Formal_Modular_Type_Definition; + + ---------------------------------------------- + -- 12.5.2 Formal Floating Point Definition -- + ---------------------------------------------- + + -- FORMAL_FLOATING_POINT_DEFINITION ::= digits <> + + -- The caller has checked the initial token is DIGITS + + -- Error recovery: cannot raise Error_Resync + + function P_Formal_Floating_Point_Definition return Node_Id is + Def_Node : Node_Id; + + begin + Def_Node := + New_Node (N_Formal_Floating_Point_Definition, Token_Ptr); + Scan; -- past DIGITS + T_Box; + return Def_Node; + end P_Formal_Floating_Point_Definition; + + ------------------------------------------- + -- 12.5.2 Formal Fixed Point Definition -- + ------------------------------------------- + + -- This routine parses either a formal ordinary fixed point definition + -- or a formal decimal fixed point definition: + + -- FORMAL_ORDINARY_FIXED_POINT_DEFINITION ::= delta <> + + -- FORMAL_DECIMAL_FIXED_POINT_DEFINITION ::= delta <> digits <> + + -- The caller has checked the initial token is DELTA + + -- Error recovery: cannot raise Error_Resync + + function P_Formal_Fixed_Point_Definition return Node_Id is + Def_Node : Node_Id; + Delta_Sloc : Source_Ptr; + + begin + Delta_Sloc := Token_Ptr; + Scan; -- past DELTA + T_Box; + + if Token = Tok_Digits then + Def_Node := + New_Node (N_Formal_Decimal_Fixed_Point_Definition, Delta_Sloc); + Scan; -- past DIGITS + T_Box; + else + Def_Node := + New_Node (N_Formal_Ordinary_Fixed_Point_Definition, Delta_Sloc); + end if; + + return Def_Node; + end P_Formal_Fixed_Point_Definition; + + ---------------------------------------------------- + -- 12.5.2 Formal Ordinary Fixed Point Definition -- + ---------------------------------------------------- + + -- Parsed by P_Formal_Fixed_Point_Definition (12.5.2) + + --------------------------------------------------- + -- 12.5.2 Formal Decimal Fixed Point Definition -- + --------------------------------------------------- + + -- Parsed by P_Formal_Fixed_Point_Definition (12.5.2) + + ------------------------------------------ + -- 12.5.3 Formal Array Type Definition -- + ------------------------------------------ + + -- Parsed by P_Formal_Type_Definition (12.5) + + ------------------------------------------- + -- 12.5.4 Formal Access Type Definition -- + ------------------------------------------- + + -- Parsed by P_Formal_Type_Definition (12.5) + + ----------------------------------------- + -- 12.6 Formal Subprogram Declaration -- + ----------------------------------------- + + -- FORMAL_SUBPROGRAM_DECLARATION ::= + -- FORMAL_CONCRETE_SUBPROGRAM_DECLARATION + -- | FORMAL_ABSTRACT_SUBPROGRAM_DECLARATION + + -- FORMAL_CONCRETE_SUBPROGRAM_DECLARATION ::= + -- with SUBPROGRAM_SPECIFICATION [is SUBPROGRAM_DEFAULT] + -- [ASPECT_SPECIFICATIONS]; + + -- FORMAL_ABSTRACT_SUBPROGRAM_DECLARATION ::= + -- with SUBPROGRAM_SPECIFICATION is abstract [SUBPROGRAM_DEFAULT] + -- [ASPECT_SPECIFICATIONS]; + + -- SUBPROGRAM_DEFAULT ::= DEFAULT_NAME | <> + + -- DEFAULT_NAME ::= NAME | null + + -- The caller has checked that the initial tokens are WITH FUNCTION or + -- WITH PROCEDURE, and the initial WITH has been scanned out. + + -- A null default is an Ada 2005 feature + + -- Error recovery: cannot raise Error_Resync + + function P_Formal_Subprogram_Declaration return Node_Id is + Prev_Sloc : constant Source_Ptr := Prev_Token_Ptr; + Spec_Node : constant Node_Id := P_Subprogram_Specification; + Def_Node : Node_Id; + + begin + if Token = Tok_Is then + T_Is; -- past IS, skip extra IS or ";" + + if Token = Tok_Abstract then + Def_Node := + New_Node (N_Formal_Abstract_Subprogram_Declaration, Prev_Sloc); + Scan; -- past ABSTRACT + + if Ada_Version < Ada_2005 then + Error_Msg_SP + ("formal abstract subprograms are an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + end if; + + else + Def_Node := + New_Node (N_Formal_Concrete_Subprogram_Declaration, Prev_Sloc); + end if; + + Set_Specification (Def_Node, Spec_Node); + + if Token = Tok_Semicolon then + null; + + elsif Aspect_Specifications_Present then + null; + + elsif Token = Tok_Box then + Set_Box_Present (Def_Node, True); + Scan; -- past <> + + elsif Token = Tok_Null then + if Ada_Version < Ada_2005 then + Error_Msg_SP + ("null default subprograms are an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + end if; + + if Nkind (Spec_Node) = N_Procedure_Specification then + Set_Null_Present (Spec_Node); + else + Error_Msg_SP ("only procedures can be null"); + end if; + + Scan; -- past NULL + + else + Set_Default_Name (Def_Node, P_Name); + end if; + + else + Def_Node := + New_Node (N_Formal_Concrete_Subprogram_Declaration, Prev_Sloc); + Set_Specification (Def_Node, Spec_Node); + end if; + + P_Aspect_Specifications (Def_Node); + return Def_Node; + end P_Formal_Subprogram_Declaration; + + ------------------------------ + -- 12.6 Subprogram Default -- + ------------------------------ + + -- Parsed by P_Formal_Procedure_Declaration (12.6) + + ------------------------ + -- 12.6 Default Name -- + ------------------------ + + -- Parsed by P_Formal_Procedure_Declaration (12.6) + + -------------------------------------- + -- 12.7 Formal Package Declaration -- + -------------------------------------- + + -- FORMAL_PACKAGE_DECLARATION ::= + -- with package DEFINING_IDENTIFIER + -- is new generic_package_NAME FORMAL_PACKAGE_ACTUAL_PART + -- [ASPECT_SPECIFICATIONS]; + + -- FORMAL_PACKAGE_ACTUAL_PART ::= + -- ([OTHERS =>] <>) | + -- [GENERIC_ACTUAL_PART] + -- (FORMAL_PACKAGE_ASSOCIATION {, FORMAL_PACKAGE_ASSOCIATION} + -- [, OTHERS => <>) + + -- FORMAL_PACKAGE_ASSOCIATION ::= + -- GENERIC_ASSOCIATION + -- | GENERIC_FORMAL_PARAMETER_SELECTOR_NAME => <> + + -- The caller has checked that the initial tokens are WITH PACKAGE, + -- and the initial WITH has been scanned out (so Token = Tok_Package). + + -- Error recovery: cannot raise Error_Resync + + function P_Formal_Package_Declaration return Node_Id is + Def_Node : Node_Id; + Scan_State : Saved_Scan_State; + + begin + Def_Node := New_Node (N_Formal_Package_Declaration, Prev_Token_Ptr); + Scan; -- past PACKAGE + Set_Defining_Identifier (Def_Node, P_Defining_Identifier (C_Is)); + T_Is; + T_New; + Set_Name (Def_Node, P_Qualified_Simple_Name); + + if Token = Tok_Left_Paren then + Save_Scan_State (Scan_State); -- at the left paren + Scan; -- past the left paren + + if Token = Tok_Box then + Set_Box_Present (Def_Node, True); + Scan; -- past box + T_Right_Paren; + + else + Restore_Scan_State (Scan_State); -- to the left paren + Set_Generic_Associations (Def_Node, P_Generic_Actual_Part_Opt); + end if; + end if; + + P_Aspect_Specifications (Def_Node); + return Def_Node; + end P_Formal_Package_Declaration; + + -------------------------------------- + -- 12.7 Formal Package Actual Part -- + -------------------------------------- + + -- Parsed by P_Formal_Package_Declaration (12.7) + +end Ch12; diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb new file mode 100644 index 000000000..2e237e663 --- /dev/null +++ b/gcc/ada/par-ch13.adb @@ -0,0 +1,697 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 1 3 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +separate (Par) +package body Ch13 is + + -- Local functions, used only in this chapter + + function P_Component_Clause return Node_Id; + function P_Mod_Clause return Node_Id; + + ----------------------------------- + -- Aspect_Specifications_Present -- + ----------------------------------- + + function Aspect_Specifications_Present + (Strict : Boolean := Ada_Version < Ada_2012) return Boolean + is + Scan_State : Saved_Scan_State; + Result : Boolean; + + begin + Save_Scan_State (Scan_State); + + -- If we have a semicolon, test for semicolon followed by Aspect + -- Specifications, in which case we decide the semicolon is accidental. + + if Token = Tok_Semicolon then + Scan; -- past semicolon + + -- The recursive test is set Strict, since we already have one + -- error (the unexpected semicolon), so we will ignore that semicolon + -- only if we absolutely definitely have an aspect specification + -- following it. + + if Aspect_Specifications_Present (Strict => True) then + Error_Msg_SP ("|extra "";"" ignored"); + return True; + + else + Restore_Scan_State (Scan_State); + return False; + end if; + end if; + + -- Definitely must have WITH to consider aspect specs to be present + + if Token /= Tok_With then + return False; + end if; + + -- Have a WITH, see if it looks like an aspect specification + + Save_Scan_State (Scan_State); + Scan; -- past WITH + + -- If no identifier, then consider that we definitely do not have an + -- aspect specification. + + if Token /= Tok_Identifier then + Result := False; + + -- This is where we pay attention to the Strict mode. Normally when we + -- are in Ada 2012 mode, Strict is False, and we consider that we have + -- an aspect specification if the identifier is an aspect name (even if + -- not followed by =>) or the identifier is not an aspect name but is + -- followed by =>. P_Aspect_Specifications will generate messages if the + -- aspect specification is ill-formed. + + elsif not Strict then + if Get_Aspect_Id (Token_Name) /= No_Aspect then + Result := True; + else + Scan; -- past identifier + Result := Token = Tok_Arrow; + end if; + + -- If earlier than Ada 2012, check for valid aspect identifier followed + -- by an arrow, and consider that this is still an aspect specification + -- so we give an appropriate message. + + else + if Get_Aspect_Id (Token_Name) = No_Aspect then + Result := False; + + else + Scan; -- past aspect name + + if Token /= Tok_Arrow then + Result := False; + + else + Restore_Scan_State (Scan_State); + Error_Msg_SC ("|aspect specification is an Ada 2012 feature"); + Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch"); + return True; + end if; + end if; + end if; + + Restore_Scan_State (Scan_State); + return Result; + end Aspect_Specifications_Present; + + -------------------------------------------- + -- 13.1 Representation Clause (also I.7) -- + -------------------------------------------- + + -- REPRESENTATION_CLAUSE ::= + -- ATTRIBUTE_DEFINITION_CLAUSE + -- | ENUMERATION_REPRESENTATION_CLAUSE + -- | RECORD_REPRESENTATION_CLAUSE + -- | AT_CLAUSE + + -- ATTRIBUTE_DEFINITION_CLAUSE ::= + -- for LOCAL_NAME'ATTRIBUTE_DESIGNATOR use EXPRESSION; + -- | for LOCAL_NAME'ATTRIBUTE_DESIGNATOR use NAME; + + -- Note: in Ada 83, the expression must be a simple expression + + -- AT_CLAUSE ::= for DIRECT_NAME use at EXPRESSION; + + -- Note: in Ada 83, the expression must be a simple expression + + -- ENUMERATION_REPRESENTATION_CLAUSE ::= + -- for first_subtype_LOCAL_NAME use ENUMERATION_AGGREGATE; + + -- ENUMERATION_AGGREGATE ::= ARRAY_AGGREGATE + + -- RECORD_REPRESENTATION_CLAUSE ::= + -- for first_subtype_LOCAL_NAME use + -- record [MOD_CLAUSE] + -- {COMPONENT_CLAUSE} + -- end record; + + -- Note: for now we allow only a direct name as the local name in the + -- above constructs. This probably needs changing later on ??? + + -- The caller has checked that the initial token is FOR + + -- Error recovery: cannot raise Error_Resync, if an error occurs, + -- the scan is repositioned past the next semicolon. + + function P_Representation_Clause return Node_Id is + For_Loc : Source_Ptr; + Name_Node : Node_Id; + Prefix_Node : Node_Id; + Attr_Name : Name_Id; + Identifier_Node : Node_Id; + Rep_Clause_Node : Node_Id; + Expr_Node : Node_Id; + Record_Items : List_Id; + + begin + For_Loc := Token_Ptr; + Scan; -- past FOR + + -- Note that the name in a representation clause is always a simple + -- name, even in the attribute case, see AI-300 which made this so! + + Identifier_Node := P_Identifier (C_Use); + + -- Check case of qualified name to give good error message + + if Token = Tok_Dot then + Error_Msg_SC + ("representation clause requires simple name!"); + + loop + exit when Token /= Tok_Dot; + Scan; -- past dot + Discard_Junk_Node (P_Identifier); + end loop; + end if; + + -- Attribute Definition Clause + + if Token = Tok_Apostrophe then + + -- Allow local names of the form a'b'.... This enables + -- us to parse class-wide streams attributes correctly. + + Name_Node := Identifier_Node; + while Token = Tok_Apostrophe loop + + Scan; -- past apostrophe + + Identifier_Node := Token_Node; + Attr_Name := No_Name; + + if Token = Tok_Identifier then + Attr_Name := Token_Name; + + if not Is_Attribute_Name (Attr_Name) then + Signal_Bad_Attribute; + end if; + + if Style_Check then + Style.Check_Attribute_Name (False); + end if; + + -- Here for case of attribute designator is not an identifier + + else + if Token = Tok_Delta then + Attr_Name := Name_Delta; + + elsif Token = Tok_Digits then + Attr_Name := Name_Digits; + + elsif Token = Tok_Access then + Attr_Name := Name_Access; + + else + Error_Msg_AP ("attribute designator expected"); + raise Error_Resync; + end if; + + if Style_Check then + Style.Check_Attribute_Name (True); + end if; + end if; + + -- We come here with an OK attribute scanned, and the + -- corresponding Attribute identifier node stored in Ident_Node. + + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr); + Set_Prefix (Name_Node, Prefix_Node); + Set_Attribute_Name (Name_Node, Attr_Name); + Scan; + end loop; + + Rep_Clause_Node := New_Node (N_Attribute_Definition_Clause, For_Loc); + Set_Name (Rep_Clause_Node, Prefix_Node); + Set_Chars (Rep_Clause_Node, Attr_Name); + T_Use; + + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + Set_Expression (Rep_Clause_Node, Expr_Node); + + else + TF_Use; + Rep_Clause_Node := Empty; + + -- AT follows USE (At Clause) + + if Token = Tok_At then + Scan; -- past AT + Rep_Clause_Node := New_Node (N_At_Clause, For_Loc); + Set_Identifier (Rep_Clause_Node, Identifier_Node); + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + Set_Expression (Rep_Clause_Node, Expr_Node); + + -- RECORD follows USE (Record Representation Clause) + + elsif Token = Tok_Record then + Record_Items := P_Pragmas_Opt; + Rep_Clause_Node := + New_Node (N_Record_Representation_Clause, For_Loc); + Set_Identifier (Rep_Clause_Node, Identifier_Node); + + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Record; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scan; -- past RECORD + Record_Items := P_Pragmas_Opt; + + -- Possible Mod Clause + + if Token = Tok_At then + Set_Mod_Clause (Rep_Clause_Node, P_Mod_Clause); + Set_Pragmas_Before (Mod_Clause (Rep_Clause_Node), Record_Items); + Record_Items := P_Pragmas_Opt; + end if; + + if No (Record_Items) then + Record_Items := New_List; + end if; + + Set_Component_Clauses (Rep_Clause_Node, Record_Items); + + -- Loop through component clauses + + loop + if Token not in Token_Class_Name then + exit when Check_End; + end if; + + Append (P_Component_Clause, Record_Items); + P_Pragmas_Opt (Record_Items); + end loop; + + -- Left paren follows USE (Enumeration Representation Clause) + + elsif Token = Tok_Left_Paren then + Rep_Clause_Node := + New_Node (N_Enumeration_Representation_Clause, For_Loc); + Set_Identifier (Rep_Clause_Node, Identifier_Node); + Set_Array_Aggregate (Rep_Clause_Node, P_Aggregate); + + -- Some other token follows FOR (invalid representation clause) + + else + Error_Msg_SC ("invalid representation clause"); + raise Error_Resync; + end if; + end if; + + TF_Semicolon; + return Rep_Clause_Node; + + exception + when Error_Resync => + Resync_Past_Semicolon; + return Error; + + end P_Representation_Clause; + + ---------------------- + -- 13.1 Local Name -- + ---------------------- + + -- Local name is always parsed by its parent. In the case of its use in + -- pragmas, the check for a local name is handled in Par.Prag and allows + -- all the possible forms of local name. For the uses in chapter 13, we + -- currently only allow a direct name, but this should probably change??? + + --------------------------- + -- 13.1 At Clause (I.7) -- + --------------------------- + + -- Parsed by P_Representation_Clause (13.1) + + --------------------------------------- + -- 13.3 Attribute Definition Clause -- + --------------------------------------- + + -- Parsed by P_Representation_Clause (13.1) + + -------------------------------- + -- 13.1 Aspect Specification -- + -------------------------------- + + -- ASPECT_SPECIFICATION ::= + -- with ASPECT_MARK [=> ASPECT_DEFINITION] {. + -- ASPECT_MARK [=> ASPECT_DEFINITION] } + + -- ASPECT_MARK ::= aspect_IDENTIFIER['Class] + + -- ASPECT_DEFINITION ::= NAME | EXPRESSION + + -- Error recovery: cannot raise Error_Resync + + procedure P_Aspect_Specifications (Decl : Node_Id) is + Aspects : List_Id; + Aspect : Node_Id; + A_Id : Aspect_Id; + OK : Boolean; + Ptr : Source_Ptr; + + begin + -- Check if aspect specification present + + if not Aspect_Specifications_Present then + TF_Semicolon; + return; + end if; + + -- Aspect Specification is present + + Ptr := Token_Ptr; + Scan; -- past WITH + + -- Here we have an aspect specification to scan, note that we don;t + -- set the flag till later, because it may turn out that we have no + -- valid aspects in the list. + + Aspects := Empty_List; + loop + OK := True; + + if Token /= Tok_Identifier then + Error_Msg_SC ("aspect identifier expected"); + Resync_Past_Semicolon; + return; + end if; + + -- We have an identifier (which should be an aspect identifier) + + A_Id := Get_Aspect_Id (Token_Name); + Aspect := + Make_Aspect_Specification (Token_Ptr, + Identifier => Token_Node); + + -- No valid aspect identifier present + + if A_Id = No_Aspect then + Error_Msg_SC ("aspect identifier expected"); + + if Token = Tok_Apostrophe then + Scan; -- past ' + Scan; -- past presumably CLASS + end if; + + if Token = Tok_Arrow then + Scan; -- Past arrow + Set_Expression (Aspect, P_Expression); + OK := False; + + elsif Token = Tok_Comma then + OK := False; + + else + Resync_Past_Semicolon; + return; + end if; + + -- OK aspect scanned + + else + Scan; -- past identifier + + -- Check for 'Class present + + if Token = Tok_Apostrophe then + if not Class_Aspect_OK (A_Id) then + Error_Msg_Node_1 := Identifier (Aspect); + Error_Msg_SC ("aspect& does not permit attribute here"); + Scan; -- past apostrophe + Scan; -- past presumed CLASS + OK := False; + + else + Scan; -- past apostrophe + + if Token /= Tok_Identifier + or else Token_Name /= Name_Class + then + Error_Msg_SC ("Class attribute expected here"); + OK := False; + + if Token = Tok_Identifier then + Scan; -- past identifier not CLASS + end if; + + else + Scan; -- past CLASS + Set_Class_Present (Aspect); + end if; + end if; + end if; + + -- Test case of missing aspect definition + + if Token = Tok_Comma or else Token = Tok_Semicolon then + if Aspect_Argument (A_Id) /= Optional then + Error_Msg_Node_1 := Aspect; + Error_Msg_AP ("aspect& requires an aspect definition"); + OK := False; + end if; + + -- Here we have an aspect definition + + else + if Token = Tok_Arrow then + Scan; -- past arrow + else + T_Arrow; + OK := False; + end if; + + if Aspect_Argument (A_Id) = Name then + Set_Expression (Aspect, P_Name); + else + Set_Expression (Aspect, P_Expression); + end if; + end if; + + -- If OK clause scanned, add it to the list + + if OK then + Append (Aspect, Aspects); + end if; + + if Token = Tok_Comma then + Scan; -- past comma + else + T_Semicolon; + exit; + end if; + end if; + end loop; + + -- If aspects scanned, store them + + if Is_Non_Empty_List (Aspects) then + if Decl = Error then + Error_Msg ("aspect specifications not allowed here", Ptr); + else + Set_Parent (Aspects, Decl); + Set_Aspect_Specifications (Decl, Aspects); + end if; + end if; + end P_Aspect_Specifications; + + --------------------------------------------- + -- 13.4 Enumeration Representation Clause -- + --------------------------------------------- + + -- Parsed by P_Representation_Clause (13.1) + + --------------------------------- + -- 13.4 Enumeration Aggregate -- + --------------------------------- + + -- Parsed by P_Representation_Clause (13.1) + + ------------------------------------------ + -- 13.5.1 Record Representation Clause -- + ------------------------------------------ + + -- Parsed by P_Representation_Clause (13.1) + + ------------------------------ + -- 13.5.1 Mod Clause (I.8) -- + ------------------------------ + + -- MOD_CLAUSE ::= at mod static_EXPRESSION; + + -- Note: in Ada 83, the expression must be a simple expression + + -- The caller has checked that the initial Token is AT + + -- Error recovery: cannot raise Error_Resync + + -- Note: the caller is responsible for setting the Pragmas_Before field + + function P_Mod_Clause return Node_Id is + Mod_Node : Node_Id; + Expr_Node : Node_Id; + + begin + Mod_Node := New_Node (N_Mod_Clause, Token_Ptr); + Scan; -- past AT + T_Mod; + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + Set_Expression (Mod_Node, Expr_Node); + TF_Semicolon; + return Mod_Node; + end P_Mod_Clause; + + ------------------------------ + -- 13.5.1 Component Clause -- + ------------------------------ + + -- COMPONENT_CLAUSE ::= + -- COMPONENT_CLAUSE_COMPONENT_NAME at POSITION + -- range FIRST_BIT .. LAST_BIT; + + -- COMPONENT_CLAUSE_COMPONENT_NAME ::= + -- component_DIRECT_NAME + -- | component_DIRECT_NAME'ATTRIBUTE_DESIGNATOR + -- | FIRST_SUBTYPE_DIRECT_NAME'ATTRIBUTE_DESIGNATOR + + -- POSITION ::= static_EXPRESSION + + -- Note: in Ada 83, the expression must be a simple expression + + -- FIRST_BIT ::= static_SIMPLE_EXPRESSION + -- LAST_BIT ::= static_SIMPLE_EXPRESSION + + -- Note: the AARM V2.0 grammar has an error at this point, it uses + -- EXPRESSION instead of SIMPLE_EXPRESSION for FIRST_BIT and LAST_BIT + + -- Error recovery: cannot raise Error_Resync + + function P_Component_Clause return Node_Id is + Component_Node : Node_Id; + Comp_Name : Node_Id; + Expr_Node : Node_Id; + + begin + Component_Node := New_Node (N_Component_Clause, Token_Ptr); + Comp_Name := P_Name; + + if Nkind (Comp_Name) = N_Identifier + or else Nkind (Comp_Name) = N_Attribute_Reference + then + Set_Component_Name (Component_Node, Comp_Name); + else + Error_Msg_N + ("component name must be direct name or attribute", Comp_Name); + Set_Component_Name (Component_Node, Error); + end if; + + Set_Sloc (Component_Node, Token_Ptr); + T_At; + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + Set_Position (Component_Node, Expr_Node); + T_Range; + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + Set_First_Bit (Component_Node, Expr_Node); + T_Dot_Dot; + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + Set_Last_Bit (Component_Node, Expr_Node); + TF_Semicolon; + return Component_Node; + end P_Component_Clause; + + ---------------------- + -- 13.5.1 Position -- + ---------------------- + + -- Parsed by P_Component_Clause (13.5.1) + + ----------------------- + -- 13.5.1 First Bit -- + ----------------------- + + -- Parsed by P_Component_Clause (13.5.1) + + ---------------------- + -- 13.5.1 Last Bit -- + ---------------------- + + -- Parsed by P_Component_Clause (13.5.1) + + -------------------------- + -- 13.8 Code Statement -- + -------------------------- + + -- CODE_STATEMENT ::= QUALIFIED_EXPRESSION + + -- On entry the caller has scanned the SUBTYPE_MARK (passed in as the + -- single argument, and the scan points to the apostrophe. + + -- Error recovery: can raise Error_Resync + + function P_Code_Statement (Subtype_Mark : Node_Id) return Node_Id is + Node1 : Node_Id; + + begin + Scan; -- past apostrophe + + -- If left paren, then we have a possible code statement + + if Token = Tok_Left_Paren then + Node1 := New_Node (N_Code_Statement, Sloc (Subtype_Mark)); + Set_Expression (Node1, P_Qualified_Expression (Subtype_Mark)); + TF_Semicolon; + return Node1; + + -- Otherwise we have an illegal range attribute. Note that P_Name + -- ensures that Token = Tok_Range is the only possibility left here. + + else -- Token = Tok_Range + Error_Msg_SC ("RANGE attribute illegal here!"); + raise Error_Resync; + end if; + + end P_Code_Statement; + +end Ch13; diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb new file mode 100644 index 000000000..4892c8cc8 --- /dev/null +++ b/gcc/ada/par-ch2.adb @@ -0,0 +1,523 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 2 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +separate (Par) +package body Ch2 is + + -- Local functions, used only in this chapter + + procedure Scan_Pragma_Argument_Association + (Identifier_Seen : in out Boolean; + Association : out Node_Id); + -- Scans out a pragma argument association. Identifier_Seen is true on + -- entry if a previous association had an identifier, and gets set True if + -- the scanned association has an identifier (this is used to check the + -- rule that no associations without identifiers can follow an association + -- which has an identifier). The result is returned in Association. + + --------------------- + -- 2.3 Identifier -- + --------------------- + + -- IDENTIFIER ::= LETTER {[UNDERLINE] LETTER_OR_DIGIT} + + -- LETTER_OR_DIGIT ::= IDENTIFIER_LETTER | DIGIT + + -- An IDENTIFIER shall not be a reserved word + + -- Error recovery: can raise Error_Resync (cannot return Error) + + function P_Identifier (C : Id_Check := None) return Node_Id is + Ident_Node : Node_Id; + + begin + -- All set if we do indeed have an identifier + + if Token = Tok_Identifier then + + -- Ada 2005 (AI-284): Compiling in Ada95 mode we warn that INTERFACE, + -- OVERRIDING, and SYNCHRONIZED are new reserved words. + + if Ada_Version = Ada_95 + and then Warn_On_Ada_2005_Compatibility + then + if Token_Name = Name_Overriding + or else Token_Name = Name_Synchronized + or else (Token_Name = Name_Interface + and then Prev_Token /= Tok_Pragma) + then + Error_Msg_N ("& is a reserved word in Ada 2005?", Token_Node); + end if; + end if; + + Ident_Node := Token_Node; + Scan; -- past Identifier + return Ident_Node; + + -- If we have a reserved identifier, manufacture an identifier with + -- a corresponding name after posting an appropriate error message + + elsif Is_Reserved_Identifier (C) then + Scan_Reserved_Identifier (Force_Msg => False); + Ident_Node := Token_Node; + Scan; -- past the node + return Ident_Node; + + -- Otherwise we have junk that cannot be interpreted as an identifier + + else + T_Identifier; -- to give message + raise Error_Resync; + end if; + end P_Identifier; + + -------------------------- + -- 2.3 Letter Or Digit -- + -------------------------- + + -- Parsed by P_Identifier (2.3) + + -------------------------- + -- 2.4 Numeric Literal -- + -------------------------- + + -- NUMERIC_LITERAL ::= DECIMAL_LITERAL | BASED_LITERAL + + -- Numeric literal is returned by the scanner as either + -- Tok_Integer_Literal or Tok_Real_Literal + + ---------------------------- + -- 2.4.1 Decimal Literal -- + ---------------------------- + + -- DECIMAL_LITERAL ::= NUMERAL [.NUMERAL] [EXPONENT] + + -- Handled by scanner as part of numeric literal handing (see 2.4) + + -------------------- + -- 2.4.1 Numeral -- + -------------------- + + -- NUMERAL ::= DIGIT {[UNDERLINE] DIGIT} + + -- Handled by scanner as part of numeric literal handling (see 2.4) + + --------------------- + -- 2.4.1 Exponent -- + --------------------- + + -- EXPONENT ::= E [+] NUMERAL | E - NUMERAL + + -- Handled by scanner as part of numeric literal handling (see 2.4) + + -------------------------- + -- 2.4.2 Based Literal -- + -------------------------- + + -- BASED_LITERAL ::= + -- BASE # BASED_NUMERAL [.BASED_NUMERAL] # [EXPONENT] + + -- Handled by scanner as part of numeric literal handling (see 2.4) + + ----------------- + -- 2.4.2 Base -- + ----------------- + + -- BASE ::= NUMERAL + + -- Handled by scanner as part of numeric literal handling (see 2.4) + + -------------------------- + -- 2.4.2 Based Numeral -- + -------------------------- + + -- BASED_NUMERAL ::= + -- EXTENDED_DIGIT {[UNDERLINE] EXTENDED_DIGIT} + + -- Handled by scanner as part of numeric literal handling (see 2.4) + + --------------------------- + -- 2.4.2 Extended Digit -- + --------------------------- + + -- EXTENDED_DIGIT ::= DIGIT | A | B | C | D | E | F + + -- Handled by scanner as part of numeric literal handling (see 2.4) + + ---------------------------- + -- 2.5 Character Literal -- + ---------------------------- + + -- CHARACTER_LITERAL ::= ' GRAPHIC_CHARACTER ' + + -- Handled by the scanner and returned as Tok_Char_Literal + + ------------------------- + -- 2.6 String Literal -- + ------------------------- + + -- STRING LITERAL ::= "{STRING_ELEMENT}" + + -- Handled by the scanner and returned as Tok_String_Literal + -- or if the string looks like an operator as Tok_Operator_Symbol. + + ------------------------- + -- 2.6 String Element -- + ------------------------- + + -- STRING_ELEMENT ::= "" | non-quotation_mark_GRAPHIC_CHARACTER + + -- A STRING_ELEMENT is either a pair of quotation marks ("), + -- or a single GRAPHIC_CHARACTER other than a quotation mark. + + -- Handled by scanner as part of string literal handling (see 2.4) + + ------------------ + -- 2.7 Comment -- + ------------------ + + -- A COMMENT starts with two adjacent hyphens and extends up to the + -- end of the line. A COMMENT may appear on any line of a program. + + -- Handled by the scanner which simply skips past encountered comments + + ----------------- + -- 2.8 Pragma -- + ----------------- + + -- PRAGMA ::= pragma IDENTIFIER + -- [(PRAGMA_ARGUMENT_ASSOCIATION {, PRAGMA_ARGUMENT_ASSOCIATION})]; + + -- The caller has checked that the initial token is PRAGMA + + -- Error recovery: cannot raise Error_Resync + + -- One special piece of processing is needed in this routine. As described + -- in the section on "Handling semicolon used in place of IS" in module + -- Parse, the parser detects the case of missing subprogram bodies to + -- allow recovery from this syntactic error. Pragma INTERFACE (and, for + -- Ada 95, pragma IMPORT) can appear in place of the body. The parser must + -- recognize the use of these two pragmas in this context, otherwise it + -- will think there are missing bodies, and try to change ; to IS, when + -- in fact the bodies ARE present, supplied by these pragmas. + + function P_Pragma (Skipping : Boolean := False) return Node_Id is + Interface_Check_Required : Boolean := False; + -- Set True if check of pragma INTERFACE is required + + Import_Check_Required : Boolean := False; + -- Set True if check of pragma IMPORT is required + + Arg_Count : Int := 0; + -- Number of argument associations processed + + Identifier_Seen : Boolean := False; + -- Set True if an identifier is encountered for a pragma argument. Used + -- to check that there are no more arguments without identifiers. + + Prag_Node : Node_Id; + Prag_Name : Name_Id; + Semicolon_Loc : Source_Ptr; + Ident_Node : Node_Id; + Assoc_Node : Node_Id; + Result : Node_Id; + + procedure Skip_Pragma_Semicolon; + -- Skip past semicolon at end of pragma + + --------------------------- + -- Skip_Pragma_Semicolon -- + --------------------------- + + procedure Skip_Pragma_Semicolon is + begin + if Token /= Tok_Semicolon then + + -- If skipping the pragma, ignore a missing semicolon + + if Skipping then + null; + + -- Otherwise demand a semicolon + + else + T_Semicolon; + end if; + + -- Scan past semicolon if present + + else + Scan; + end if; + end Skip_Pragma_Semicolon; + + -- Start of processing for P_Pragma + + begin + Prag_Node := New_Node (N_Pragma, Token_Ptr); + Scan; -- past PRAGMA + Prag_Name := Token_Name; + + if Style_Check then + Style.Check_Pragma_Name; + end if; + + -- Ada 2005 (AI-284): INTERFACE is a new reserved word but it is + -- allowed as a pragma name. + + if Ada_Version >= Ada_2005 + and then Token = Tok_Interface + then + Prag_Name := Name_Interface; + Ident_Node := Make_Identifier (Token_Ptr, Name_Interface); + Scan; -- past INTERFACE + else + Ident_Node := P_Identifier; + end if; + + Set_Pragma_Identifier (Prag_Node, Ident_Node); + + -- See if special INTERFACE/IMPORT check is required + + if SIS_Entry_Active then + Interface_Check_Required := (Prag_Name = Name_Interface); + Import_Check_Required := (Prag_Name = Name_Import); + else + Interface_Check_Required := False; + Import_Check_Required := False; + end if; + + -- Scan arguments. We assume that arguments are present if there is + -- a left paren, or if a semicolon is missing and there is another + -- token on the same line as the pragma name. + + if Token = Tok_Left_Paren + or else (Token /= Tok_Semicolon + and then not Token_Is_At_Start_Of_Line) + then + Set_Pragma_Argument_Associations (Prag_Node, New_List); + T_Left_Paren; + + loop + Arg_Count := Arg_Count + 1; + Scan_Pragma_Argument_Association (Identifier_Seen, Assoc_Node); + + if Arg_Count = 2 + and then (Interface_Check_Required or else Import_Check_Required) + then + -- Here is where we cancel the SIS active status if this pragma + -- supplies a body for the currently active subprogram spec. + + if Nkind (Expression (Assoc_Node)) in N_Direct_Name + and then Chars (Expression (Assoc_Node)) = Chars (SIS_Labl) + then + SIS_Entry_Active := False; + end if; + end if; + + Append (Assoc_Node, Pragma_Argument_Associations (Prag_Node)); + exit when Token /= Tok_Comma; + Scan; -- past comma + end loop; + + -- If we have := for pragma Debug, it is worth special casing the + -- error message (it is easy to think of pragma Debug as taking a + -- statement, and an assignment statement is the most likely + -- candidate for this error) + + if Token = Tok_Colon_Equal and then Prag_Name = Name_Debug then + Error_Msg_SC ("argument for pragma Debug must be procedure call"); + Resync_To_Semicolon; + + -- Normal case, we expect a right paren here + + else + T_Right_Paren; + end if; + end if; + + Semicolon_Loc := Token_Ptr; + + -- Now we have two tasks left, we need to scan out the semicolon + -- following the pragma, and we have to call Par.Prag to process + -- the pragma. Normally we do them in this order, however, there + -- is one exception namely pragma Style_Checks where we like to + -- skip the semicolon after processing the pragma, since that way + -- the style checks for the scanning of the semicolon follow the + -- settings of the pragma. + + -- You might think we could just unconditionally do things in + -- the opposite order, but there are other pragmas, notably the + -- case of pragma Source_File_Name, which assume the semicolon + -- is already scanned out. + + if Prag_Name = Name_Style_Checks then + Result := Par.Prag (Prag_Node, Semicolon_Loc); + Skip_Pragma_Semicolon; + return Result; + else + Skip_Pragma_Semicolon; + return Par.Prag (Prag_Node, Semicolon_Loc); + end if; + + exception + when Error_Resync => + Resync_Past_Semicolon; + return Error; + + end P_Pragma; + + -- This routine is called if a pragma is encountered in an inappropriate + -- position, the pragma is scanned out and control returns to continue. + + -- The caller has checked that the initial token is pragma + + -- Error recovery: cannot raise Error_Resync + + procedure P_Pragmas_Misplaced is + begin + while Token = Tok_Pragma loop + Error_Msg_SC ("pragma not allowed here"); + Discard_Junk_Node (P_Pragma (Skipping => True)); + end loop; + end P_Pragmas_Misplaced; + + -- This function is called to scan out an optional sequence of pragmas. + -- If no pragmas are found, then No_List is returned. + + -- Error recovery: Cannot raise Error_Resync + + function P_Pragmas_Opt return List_Id is + L : List_Id; + + begin + if Token = Tok_Pragma then + L := New_List; + P_Pragmas_Opt (L); + return L; + + else + return No_List; + end if; + end P_Pragmas_Opt; + + -- This procedure is called to scan out an optional sequence of pragmas. + -- Any pragmas found are appended to the list provided as an argument. + + -- Error recovery: Cannot raise Error_Resync + + procedure P_Pragmas_Opt (List : List_Id) is + P : Node_Id; + + begin + while Token = Tok_Pragma loop + P := P_Pragma; + + if Nkind (P) /= N_Error + and then (Pragma_Name (P) = Name_Assert + or else + Pragma_Name (P) = Name_Debug) + then + Error_Msg_Name_1 := Pragma_Name (P); + Error_Msg_N + ("pragma% must be in declaration/statement context", P); + else + Append (P, List); + end if; + end loop; + end P_Pragmas_Opt; + + -------------------------------------- + -- 2.8 Pragma_Argument Association -- + -------------------------------------- + + -- PRAGMA_ARGUMENT_ASSOCIATION ::= + -- [pragma_argument_IDENTIFIER =>] NAME + -- | [pragma_argument_IDENTIFIER =>] EXPRESSION + + -- Error recovery: cannot raise Error_Resync + + procedure Scan_Pragma_Argument_Association + (Identifier_Seen : in out Boolean; + Association : out Node_Id) + is + Scan_State : Saved_Scan_State; + Identifier_Node : Node_Id; + Id_Present : Boolean; + + begin + Association := New_Node (N_Pragma_Argument_Association, Token_Ptr); + Set_Chars (Association, No_Name); + + -- Argument starts with identifier + + if Token = Tok_Identifier then + Identifier_Node := Token_Node; + Save_Scan_State (Scan_State); -- at Identifier + Scan; -- past Identifier + + if Token = Tok_Arrow then + Identifier_Seen := True; + Scan; -- past arrow + Set_Chars (Association, Chars (Identifier_Node)); + Id_Present := True; + + -- Case of argument with no identifier + + else + Restore_Scan_State (Scan_State); -- to Identifier + Id_Present := False; + end if; + + -- Argument does not start with identifier + + else + Id_Present := False; + end if; + + -- Diagnose error of "positional" argument for pragma appearing after + -- a "named" argument (quotes here are because that's not quite accurate + -- Ada RM terminology). + + -- Since older GNAT versions did not generate this error, disable this + -- message in codepeer mode to help legacy code using codepeer. + + if Identifier_Seen and not Id_Present and not CodePeer_Mode then + Error_Msg_SC ("|pragma argument identifier required here"); + Error_Msg_SC ("\since previous argument had identifier (RM 2.8(4))"); + end if; + + if Id_Present then + Set_Expression (Association, P_Expression); + else + Set_Expression (Association, P_Expression_If_OK); + end if; + end Scan_Pragma_Argument_Association; + +end Ch2; diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb new file mode 100644 index 000000000..059b40340 --- /dev/null +++ b/gcc/ada/par-ch3.adb @@ -0,0 +1,4674 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 3 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical. + +with Sinfo.CN; use Sinfo.CN; + +separate (Par) + +--------- +-- Ch3 -- +--------- + +package body Ch3 is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function P_Component_List return Node_Id; + function P_Defining_Character_Literal return Node_Id; + function P_Delta_Constraint return Node_Id; + function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id; + function P_Digits_Constraint return Node_Id; + function P_Discriminant_Association return Node_Id; + function P_Enumeration_Literal_Specification return Node_Id; + function P_Enumeration_Type_Definition return Node_Id; + function P_Fixed_Point_Definition return Node_Id; + function P_Floating_Point_Definition return Node_Id; + function P_Index_Or_Discriminant_Constraint return Node_Id; + function P_Real_Range_Specification_Opt return Node_Id; + function P_Subtype_Declaration return Node_Id; + function P_Type_Declaration return Node_Id; + function P_Modular_Type_Definition return Node_Id; + function P_Variant return Node_Id; + function P_Variant_Part return Node_Id; + + procedure Check_Restricted_Expression (N : Node_Id); + -- Check that the expression N meets the Restricted_Expression syntax. + -- The syntax is as follows: + -- + -- RESTRICTED_EXPRESSION ::= + -- RESTRICTED_RELATION {and RESTRICTED_RELATION} + -- | RESTRICTED_RELATION {and then RESTRICTED_RELATION} + -- | RESTRICTED_RELATION {or RESTRICTED_RELATION} + -- | RESTRICTED_RELATION {or else RESTRICTED_RELATION} + -- | RESTRICTED_RELATION {xor RESTRICTED_RELATION} + -- + -- RESTRICTED_RELATION ::= + -- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION] + -- + -- This syntax is used for choices when extensions (and set notations) + -- are enabled, to remove the ambiguity of "when X in A | B". We consider + -- it very unlikely that this will ever arise in practice. + + procedure P_Declarative_Items + (Decls : List_Id; + Done : out Boolean; + In_Spec : Boolean); + -- Scans out a single declarative item, or, in the case of a declaration + -- with a list of identifiers, a list of declarations, one for each of the + -- identifiers in the list. The declaration or declarations scanned are + -- appended to the given list. Done indicates whether or not there may be + -- additional declarative items to scan. If Done is True, then a decision + -- has been made that there are no more items to scan. If Done is False, + -- then there may be additional declarations to scan. In_Spec is true if + -- we are scanning a package declaration, and is used to generate an + -- appropriate message if a statement is encountered in such a context. + + procedure P_Identifier_Declarations + (Decls : List_Id; + Done : out Boolean; + In_Spec : Boolean); + -- Scans out a set of declarations for an identifier or list of + -- identifiers, and appends them to the given list. The parameters have + -- the same significance as for P_Declarative_Items. + + procedure Statement_When_Declaration_Expected + (Decls : List_Id; + Done : out Boolean; + In_Spec : Boolean); + -- Called when a statement is found at a point where a declaration was + -- expected. The parameters are as described for P_Declarative_Items. + + procedure Set_Declaration_Expected; + -- Posts a "declaration expected" error messages at the start of the + -- current token, and if this is the first such message issued, saves + -- the message id in Missing_Begin_Msg, for possible later replacement. + + --------------------------------- + -- Check_Restricted_Expression -- + --------------------------------- + + procedure Check_Restricted_Expression (N : Node_Id) is + begin + if Nkind_In (N, N_Op_And, N_Op_Or, N_Op_Xor, N_And_Then, N_Or_Else) then + Check_Restricted_Expression (Left_Opnd (N)); + Check_Restricted_Expression (Right_Opnd (N)); + + elsif Nkind_In (N, N_In, N_Not_In) + and then Paren_Count (N) = 0 + then + Error_Msg_N ("|this expression must be parenthesized!", N); + end if; + end Check_Restricted_Expression; + + ------------------- + -- Init_Expr_Opt -- + ------------------- + + function Init_Expr_Opt (P : Boolean := False) return Node_Id is + begin + -- For colon, assume it means := unless it is at the end of + -- a line, in which case guess that it means a semicolon. + + if Token = Tok_Colon then + if Token_Is_At_End_Of_Line then + T_Semicolon; + return Empty; + end if; + + -- Here if := or something that we will take as equivalent + + elsif Token = Tok_Colon_Equal + or else Token = Tok_Equal + or else Token = Tok_Is + then + null; + + -- Another possibility. If we have a literal followed by a semicolon, + -- we assume that we have a missing colon-equal. + + elsif Token in Token_Class_Literal then + declare + Scan_State : Saved_Scan_State; + + begin + Save_Scan_State (Scan_State); + Scan; -- past literal or identifier + + if Token = Tok_Semicolon then + Restore_Scan_State (Scan_State); + else + Restore_Scan_State (Scan_State); + return Empty; + end if; + end; + + -- Otherwise we definitely have no initialization expression + + else + return Empty; + end if; + + -- Merge here if we have an initialization expression + + T_Colon_Equal; + + if P then + return P_Expression; + else + return P_Expression_No_Right_Paren; + end if; + end Init_Expr_Opt; + + ---------------------------- + -- 3.1 Basic Declaration -- + ---------------------------- + + -- Parsed by P_Basic_Declarative_Items (3.9) + + ------------------------------ + -- 3.1 Defining Identifier -- + ------------------------------ + + -- DEFINING_IDENTIFIER ::= IDENTIFIER + + -- Error recovery: can raise Error_Resync + + function P_Defining_Identifier (C : Id_Check := None) return Node_Id is + Ident_Node : Node_Id; + + begin + -- Scan out the identifier. Note that this code is essentially identical + -- to P_Identifier, except that in the call to Scan_Reserved_Identifier + -- we set Force_Msg to True, since we want at least one message for each + -- separate declaration (but not use) of a reserved identifier. + + if Token = Tok_Identifier then + + -- Ada 2005 (AI-284): Compiling in Ada95 mode we warn that INTERFACE, + -- OVERRIDING, and SYNCHRONIZED are new reserved words. Note that + -- in the case where these keywords are misused in Ada 95 mode, + -- this routine will generally not be called at all. + + if Ada_Version = Ada_95 + and then Warn_On_Ada_2005_Compatibility + then + if Token_Name = Name_Overriding + or else Token_Name = Name_Synchronized + or else (Token_Name = Name_Interface + and then Prev_Token /= Tok_Pragma) + then + Error_Msg_N ("& is a reserved word in Ada 2005?", Token_Node); + end if; + end if; + + -- If we have a reserved identifier, manufacture an identifier with + -- a corresponding name after posting an appropriate error message + + elsif Is_Reserved_Identifier (C) then + Scan_Reserved_Identifier (Force_Msg => True); + + -- Otherwise we have junk that cannot be interpreted as an identifier + + else + T_Identifier; -- to give message + raise Error_Resync; + end if; + + Ident_Node := Token_Node; + Scan; -- past the reserved identifier + + -- If we already have a defining identifier, clean it out and make + -- a new clean identifier. This situation arises in some error cases + -- and we need to fix it. + + if Nkind (Ident_Node) = N_Defining_Identifier then + Ident_Node := Make_Identifier (Sloc (Ident_Node), Chars (Ident_Node)); + end if; + + -- Change identifier to defining identifier if not in error + + if Ident_Node /= Error then + Change_Identifier_To_Defining_Identifier (Ident_Node); + end if; + + return Ident_Node; + end P_Defining_Identifier; + + ----------------------------- + -- 3.2.1 Type Declaration -- + ----------------------------- + + -- TYPE_DECLARATION ::= + -- FULL_TYPE_DECLARATION + -- | INCOMPLETE_TYPE_DECLARATION + -- | PRIVATE_TYPE_DECLARATION + -- | PRIVATE_EXTENSION_DECLARATION + + -- FULL_TYPE_DECLARATION ::= + -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION + -- [ASPECT_SPECIFICATIONS]; + -- | CONCURRENT_TYPE_DECLARATION + + -- INCOMPLETE_TYPE_DECLARATION ::= + -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [is tagged]; + + -- PRIVATE_TYPE_DECLARATION ::= + -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] + -- is [abstract] [tagged] [limited] private; + + -- PRIVATE_EXTENSION_DECLARATION ::= + -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is + -- [abstract] [limited | synchronized] + -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST] + -- with private; + + -- TYPE_DEFINITION ::= + -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION + -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION + -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION + -- | DERIVED_TYPE_DEFINITION | INTERFACE_TYPE_DEFINITION + + -- INTEGER_TYPE_DEFINITION ::= + -- SIGNED_INTEGER_TYPE_DEFINITION + -- MODULAR_TYPE_DEFINITION + + -- INTERFACE_TYPE_DEFINITION ::= + -- [limited | task | protected | synchronized ] interface + -- [and INTERFACE_LIST] + + -- Error recovery: can raise Error_Resync + + -- The processing for full type declarations, incomplete type declarations, + -- private type declarations and type definitions is included in this + -- function. The processing for concurrent type declarations is NOT here, + -- but rather in chapter 9 (this function handles only declarations + -- starting with TYPE). + + function P_Type_Declaration return Node_Id is + Abstract_Present : Boolean := False; + Abstract_Loc : Source_Ptr := No_Location; + Decl_Node : Node_Id; + Discr_List : List_Id; + Discr_Sloc : Source_Ptr; + End_Labl : Node_Id; + Ident_Node : Node_Id; + Is_Derived_Iface : Boolean := False; + Type_Loc : Source_Ptr; + Type_Start_Col : Column_Number; + Unknown_Dis : Boolean; + + Typedef_Node : Node_Id; + -- Normally holds type definition, except in the case of a private + -- extension declaration, in which case it holds the declaration itself + + begin + Type_Loc := Token_Ptr; + Type_Start_Col := Start_Column; + + -- If we have TYPE, then proceed ahead and scan identifier + + if Token = Tok_Type then + Type_Token_Location := Type_Loc; + Scan; -- past TYPE + Ident_Node := P_Defining_Identifier (C_Is); + + -- Otherwise this is an error case + + else + T_Type; + Type_Token_Location := Type_Loc; + Ident_Node := P_Defining_Identifier (C_Is); + end if; + + Discr_Sloc := Token_Ptr; + + if P_Unknown_Discriminant_Part_Opt then + Unknown_Dis := True; + Discr_List := No_List; + else + Unknown_Dis := False; + Discr_List := P_Known_Discriminant_Part_Opt; + end if; + + -- Incomplete type declaration. We complete the processing for this + -- case here and return the resulting incomplete type declaration node + + if Token = Tok_Semicolon then + Scan; -- past ; + Decl_Node := New_Node (N_Incomplete_Type_Declaration, Type_Loc); + Set_Defining_Identifier (Decl_Node, Ident_Node); + Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis); + Set_Discriminant_Specifications (Decl_Node, Discr_List); + return Decl_Node; + + else + Decl_Node := Empty; + end if; + + -- Full type declaration or private type declaration, must have IS + + if Token = Tok_Equal then + TF_Is; + Scan; -- past = used in place of IS + + elsif Token = Tok_Renames then + Error_Msg_SC -- CODEFIX + ("RENAMES should be IS"); + Scan; -- past RENAMES used in place of IS + + else + TF_Is; + end if; + + -- First an error check, if we have two identifiers in a row, a likely + -- possibility is that the first of the identifiers is an incorrectly + -- spelled keyword. + + if Token = Tok_Identifier then + declare + SS : Saved_Scan_State; + I2 : Boolean; + + begin + Save_Scan_State (SS); + Scan; -- past initial identifier + I2 := (Token = Tok_Identifier); + Restore_Scan_State (SS); + + if I2 + and then + (Bad_Spelling_Of (Tok_Abstract) or else + Bad_Spelling_Of (Tok_Access) or else + Bad_Spelling_Of (Tok_Aliased) or else + Bad_Spelling_Of (Tok_Constant)) + then + null; + end if; + end; + end if; + + -- Check for misuse of Ada 95 keyword abstract in Ada 83 mode + + if Token_Name = Name_Abstract then + Check_95_Keyword (Tok_Abstract, Tok_Tagged); + Check_95_Keyword (Tok_Abstract, Tok_New); + end if; + + -- Check cases of misuse of ABSTRACT + + if Token = Tok_Abstract then + Abstract_Present := True; + Abstract_Loc := Token_Ptr; + Scan; -- past ABSTRACT + + -- Ada 2005 (AI-419): AARM 3.4 (2/2) + + if (Ada_Version < Ada_2005 and then Token = Tok_Limited) + or else Token = Tok_Private + or else Token = Tok_Record + or else Token = Tok_Null + then + Error_Msg_AP ("TAGGED expected"); + end if; + end if; + + -- Check for misuse of Ada 95 keyword Tagged + + if Token_Name = Name_Tagged then + Check_95_Keyword (Tok_Tagged, Tok_Private); + Check_95_Keyword (Tok_Tagged, Tok_Limited); + Check_95_Keyword (Tok_Tagged, Tok_Record); + end if; + + -- Special check for misuse of Aliased + + if Token = Tok_Aliased or else Token_Name = Name_Aliased then + Error_Msg_SC ("ALIASED not allowed in type definition"); + Scan; -- past ALIASED + end if; + + -- The following processing deals with either a private type declaration + -- or a full type declaration. In the private type case, we build the + -- N_Private_Type_Declaration node, setting its Tagged_Present and + -- Limited_Present flags, on encountering the Private keyword, and + -- leave Typedef_Node set to Empty. For the full type declaration + -- case, Typedef_Node gets set to the type definition. + + Typedef_Node := Empty; + + -- Switch on token following the IS. The loop normally runs once. It + -- only runs more than once if an error is detected, to try again after + -- detecting and fixing up the error. + + loop + case Token is + + when Tok_Access | + Tok_Not => -- Ada 2005 (AI-231) + Typedef_Node := P_Access_Type_Definition; + exit; + + when Tok_Array => + Typedef_Node := P_Array_Type_Definition; + exit; + + when Tok_Delta => + Typedef_Node := P_Fixed_Point_Definition; + exit; + + when Tok_Digits => + Typedef_Node := P_Floating_Point_Definition; + exit; + + when Tok_In => + Ignore (Tok_In); + + when Tok_Integer_Literal => + T_Range; + Typedef_Node := P_Signed_Integer_Type_Definition; + exit; + + when Tok_Null => + Typedef_Node := P_Record_Definition; + exit; + + when Tok_Left_Paren => + Typedef_Node := P_Enumeration_Type_Definition; + + End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node)); + Set_Comes_From_Source (End_Labl, False); + + Set_End_Label (Typedef_Node, End_Labl); + exit; + + when Tok_Mod => + Typedef_Node := P_Modular_Type_Definition; + exit; + + when Tok_New => + Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl; + + if Nkind (Typedef_Node) = N_Derived_Type_Definition + and then Present (Record_Extension_Part (Typedef_Node)) + then + End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node)); + Set_Comes_From_Source (End_Labl, False); + + Set_End_Label + (Record_Extension_Part (Typedef_Node), End_Labl); + end if; + + exit; + + when Tok_Range => + Typedef_Node := P_Signed_Integer_Type_Definition; + exit; + + when Tok_Record => + Typedef_Node := P_Record_Definition; + + End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node)); + Set_Comes_From_Source (End_Labl, False); + + Set_End_Label (Typedef_Node, End_Labl); + exit; + + when Tok_Tagged => + Scan; -- past TAGGED + + -- Ada 2005 (AI-326): If the words IS TAGGED appear, the type + -- is a tagged incomplete type. + + if Ada_Version >= Ada_2005 + and then Token = Tok_Semicolon + then + Scan; -- past ; + + Decl_Node := + New_Node (N_Incomplete_Type_Declaration, Type_Loc); + Set_Defining_Identifier (Decl_Node, Ident_Node); + Set_Tagged_Present (Decl_Node); + Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis); + Set_Discriminant_Specifications (Decl_Node, Discr_List); + + return Decl_Node; + end if; + + if Token = Tok_Abstract then + Error_Msg_SC -- CODEFIX + ("ABSTRACT must come before TAGGED"); + Abstract_Present := True; + Abstract_Loc := Token_Ptr; + Scan; -- past ABSTRACT + end if; + + if Token = Tok_Limited then + Scan; -- past LIMITED + + -- TAGGED LIMITED PRIVATE case + + if Token = Tok_Private then + Decl_Node := + New_Node (N_Private_Type_Declaration, Type_Loc); + Set_Tagged_Present (Decl_Node, True); + Set_Limited_Present (Decl_Node, True); + Scan; -- past PRIVATE + + -- TAGGED LIMITED RECORD + + else + Typedef_Node := P_Record_Definition; + Set_Tagged_Present (Typedef_Node, True); + Set_Limited_Present (Typedef_Node, True); + + End_Labl := + Make_Identifier (Token_Ptr, Chars (Ident_Node)); + Set_Comes_From_Source (End_Labl, False); + + Set_End_Label (Typedef_Node, End_Labl); + end if; + + else + -- TAGGED PRIVATE + + if Token = Tok_Private then + Decl_Node := + New_Node (N_Private_Type_Declaration, Type_Loc); + Set_Tagged_Present (Decl_Node, True); + Scan; -- past PRIVATE + + -- TAGGED RECORD + + else + Typedef_Node := P_Record_Definition; + Set_Tagged_Present (Typedef_Node, True); + + End_Labl := + Make_Identifier (Token_Ptr, Chars (Ident_Node)); + Set_Comes_From_Source (End_Labl, False); + + Set_End_Label (Typedef_Node, End_Labl); + end if; + end if; + + exit; + + when Tok_Limited => + Scan; -- past LIMITED + + loop + if Token = Tok_Tagged then + Error_Msg_SC -- CODEFIX + ("TAGGED must come before LIMITED"); + Scan; -- past TAGGED + + elsif Token = Tok_Abstract then + Error_Msg_SC -- CODEFIX + ("ABSTRACT must come before LIMITED"); + Scan; -- past ABSTRACT + + else + exit; + end if; + end loop; + + -- LIMITED RECORD or LIMITED NULL RECORD + + if Token = Tok_Record or else Token = Tok_Null then + if Ada_Version = Ada_83 then + Error_Msg_SP + ("(Ada 83) limited record declaration not allowed!"); + + -- In Ada2005, "abstract limited" can appear before "new", + -- but it cannot be part of an untagged record declaration. + + elsif Abstract_Present + and then Prev_Token /= Tok_Tagged + then + Error_Msg_SP ("TAGGED expected"); + end if; + + Typedef_Node := P_Record_Definition; + Set_Limited_Present (Typedef_Node, True); + + -- Ada 2005 (AI-251): LIMITED INTERFACE + + -- If we are compiling in Ada 83 or Ada 95 mode, "interface" + -- is not a reserved word but we force its analysis to + -- generate the corresponding usage error. + + elsif Token = Tok_Interface + or else (Token = Tok_Identifier + and then Chars (Token_Node) = Name_Interface) + then + Typedef_Node := + P_Interface_Type_Definition (Abstract_Present); + Abstract_Present := True; + Set_Limited_Present (Typedef_Node); + + if Nkind (Typedef_Node) = N_Derived_Type_Definition then + Is_Derived_Iface := True; + end if; + + -- Ada 2005 (AI-419): LIMITED NEW + + elsif Token = Tok_New then + if Ada_Version < Ada_2005 then + Error_Msg_SP + ("LIMITED in derived type is an Ada 2005 extension"); + Error_Msg_SP + ("\unit must be compiled with -gnat05 switch"); + end if; + + Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl; + Set_Limited_Present (Typedef_Node); + + if Nkind (Typedef_Node) = N_Derived_Type_Definition + and then Present (Record_Extension_Part (Typedef_Node)) + then + End_Labl := + Make_Identifier (Token_Ptr, Chars (Ident_Node)); + Set_Comes_From_Source (End_Labl, False); + + Set_End_Label + (Record_Extension_Part (Typedef_Node), End_Labl); + end if; + + -- LIMITED PRIVATE is the only remaining possibility here + + else + Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc); + Set_Limited_Present (Decl_Node, True); + T_Private; -- past PRIVATE (or complain if not there!) + end if; + + exit; + + -- Here we have an identifier after the IS, which is certainly + -- wrong and which might be one of several different mistakes. + + when Tok_Identifier => + + -- First case, if identifier is on same line, then probably we + -- have something like "type X is Integer .." and the best + -- diagnosis is a missing NEW. Note: the missing new message + -- will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl. + + if not Token_Is_At_Start_Of_Line then + Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl; + + -- If the identifier is at the start of the line, and is in the + -- same column as the type declaration itself then we consider + -- that we had a missing type definition on the previous line + + elsif Start_Column <= Type_Start_Col then + Error_Msg_AP ("type definition expected"); + Typedef_Node := Error; + + -- If the identifier is at the start of the line, and is in + -- a column to the right of the type declaration line, then we + -- may have something like: + + -- type x is + -- r : integer + + -- and the best diagnosis is a missing record keyword + + else + Typedef_Node := P_Record_Definition; + end if; + + exit; + + -- Ada 2005 (AI-251): INTERFACE + + when Tok_Interface => + Typedef_Node := P_Interface_Type_Definition (Abstract_Present); + Abstract_Present := True; + exit; + + when Tok_Private => + Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc); + Scan; -- past PRIVATE + + -- Check error cases of private [abstract] tagged + + if Token = Tok_Abstract then + Error_Msg_SC ("`ABSTRACT TAGGED` must come before PRIVATE"); + Scan; -- past ABSTRACT + + if Token = Tok_Tagged then + Scan; -- past TAGGED + end if; + + elsif Token = Tok_Tagged then + Error_Msg_SC ("TAGGED must come before PRIVATE"); + Scan; -- past TAGGED + end if; + + exit; + + -- Ada 2005 (AI-345): Protected, synchronized or task interface + -- or Ada 2005 (AI-443): Synchronized private extension. + + when Tok_Protected | + Tok_Synchronized | + Tok_Task => + + declare + Saved_Token : constant Token_Type := Token; + + begin + Scan; -- past TASK, PROTECTED or SYNCHRONIZED + + -- Synchronized private extension + + if Token = Tok_New then + Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl; + + if Saved_Token = Tok_Synchronized then + if Nkind (Typedef_Node) = + N_Derived_Type_Definition + then + Error_Msg_N + ("SYNCHRONIZED not allowed for record extension", + Typedef_Node); + else + Set_Synchronized_Present (Typedef_Node); + end if; + + else + Error_Msg_SC ("invalid kind of private extension"); + end if; + + -- Interface + + else + if Token /= Tok_Interface then + Error_Msg_SC ("NEW or INTERFACE expected"); + end if; + + Typedef_Node := + P_Interface_Type_Definition (Abstract_Present); + Abstract_Present := True; + + case Saved_Token is + when Tok_Task => + Set_Task_Present (Typedef_Node); + + when Tok_Protected => + Set_Protected_Present (Typedef_Node); + + when Tok_Synchronized => + Set_Synchronized_Present (Typedef_Node); + + when others => + pragma Assert (False); + null; + end case; + end if; + end; + + exit; + + -- Anything else is an error + + when others => + if Bad_Spelling_Of (Tok_Access) + or else + Bad_Spelling_Of (Tok_Array) + or else + Bad_Spelling_Of (Tok_Delta) + or else + Bad_Spelling_Of (Tok_Digits) + or else + Bad_Spelling_Of (Tok_Limited) + or else + Bad_Spelling_Of (Tok_Private) + or else + Bad_Spelling_Of (Tok_Range) + or else + Bad_Spelling_Of (Tok_Record) + or else + Bad_Spelling_Of (Tok_Tagged) + then + null; + + else + Error_Msg_AP ("type definition expected"); + raise Error_Resync; + end if; + + end case; + end loop; + + -- For the private type declaration case, the private type declaration + -- node has been built, with the Tagged_Present and Limited_Present + -- flags set as needed, and Typedef_Node is left set to Empty. + + if No (Typedef_Node) then + Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis); + Set_Abstract_Present (Decl_Node, Abstract_Present); + + -- For a private extension declaration, Typedef_Node contains the + -- N_Private_Extension_Declaration node, which we now complete. Note + -- that the private extension declaration, unlike a full type + -- declaration, does permit unknown discriminants. + + elsif Nkind (Typedef_Node) = N_Private_Extension_Declaration then + Decl_Node := Typedef_Node; + Set_Sloc (Decl_Node, Type_Loc); + Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis); + Set_Abstract_Present (Typedef_Node, Abstract_Present); + + -- In the full type declaration case, Typedef_Node has the type + -- definition and here is where we build the full type declaration + -- node. This is also where we check for improper use of an unknown + -- discriminant part (not allowed for full type declaration). + + else + if Nkind (Typedef_Node) = N_Record_Definition + or else (Nkind (Typedef_Node) = N_Derived_Type_Definition + and then Present (Record_Extension_Part (Typedef_Node))) + or else Is_Derived_Iface + then + Set_Abstract_Present (Typedef_Node, Abstract_Present); + + elsif Abstract_Present then + Error_Msg ("ABSTRACT not allowed here, ignored", Abstract_Loc); + end if; + + Decl_Node := New_Node (N_Full_Type_Declaration, Type_Loc); + Set_Type_Definition (Decl_Node, Typedef_Node); + + if Unknown_Dis then + Error_Msg + ("Full type declaration cannot have unknown discriminants", + Discr_Sloc); + end if; + end if; + + -- Remaining processing is common for all three cases + + Set_Defining_Identifier (Decl_Node, Ident_Node); + Set_Discriminant_Specifications (Decl_Node, Discr_List); + P_Aspect_Specifications (Decl_Node); + return Decl_Node; + end P_Type_Declaration; + + ---------------------------------- + -- 3.2.1 Full Type Declaration -- + ---------------------------------- + + -- Parsed by P_Type_Declaration (3.2.1) + + ---------------------------- + -- 3.2.1 Type Definition -- + ---------------------------- + + -- Parsed by P_Type_Declaration (3.2.1) + + -------------------------------- + -- 3.2.2 Subtype Declaration -- + -------------------------------- + + -- SUBTYPE_DECLARATION ::= + -- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION; + + -- The caller has checked that the initial token is SUBTYPE + + -- Error recovery: can raise Error_Resync + + function P_Subtype_Declaration return Node_Id is + Decl_Node : Node_Id; + Not_Null_Present : Boolean := False; + + begin + Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr); + Scan; -- past SUBTYPE + Set_Defining_Identifier (Decl_Node, P_Defining_Identifier (C_Is)); + TF_Is; + + if Token = Tok_New then + Error_Msg_SC -- CODEFIX + ("NEW ignored (only allowed in type declaration)"); + Scan; -- past NEW + end if; + + Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) + Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); + + Set_Subtype_Indication + (Decl_Node, P_Subtype_Indication (Not_Null_Present)); + P_Aspect_Specifications (Decl_Node); + return Decl_Node; + end P_Subtype_Declaration; + + ------------------------------- + -- 3.2.2 Subtype Indication -- + ------------------------------- + + -- SUBTYPE_INDICATION ::= + -- [not null] SUBTYPE_MARK [CONSTRAINT] + + -- Error recovery: can raise Error_Resync + + function P_Null_Exclusion + (Allow_Anonymous_In_95 : Boolean := False) return Boolean + is + Not_Loc : constant Source_Ptr := Token_Ptr; + -- Source position of "not", if present + + begin + if Token /= Tok_Not then + return False; + + else + Scan; -- past NOT + + if Token = Tok_Null then + Scan; -- past NULL + + -- Ada 2005 (AI-441, AI-447): null_exclusion is illegal in Ada 95, + -- except in the case of anonymous access types. + + -- Allow_Anonymous_In_95 will be True if we're parsing a formal + -- parameter or discriminant, which are the only places where + -- anonymous access types occur in Ada 95. "Formal : not null + -- access ..." is legal in Ada 95, whereas "Formal : not null + -- Named_Access_Type" is not. + + if Ada_Version >= Ada_2005 + or else (Ada_Version >= Ada_95 + and then Allow_Anonymous_In_95 + and then Token = Tok_Access) + then + null; -- OK + + else + Error_Msg + ("`NOT NULL` access type is an Ada 2005 extension", Not_Loc); + Error_Msg + ("\unit should be compiled with -gnat05 switch", Not_Loc); + end if; + + else + Error_Msg_SP ("NULL expected"); + end if; + + if Token = Tok_New then + Error_Msg ("`NOT NULL` comes after NEW, not before", Not_Loc); + end if; + + return True; + end if; + end P_Null_Exclusion; + + function P_Subtype_Indication + (Not_Null_Present : Boolean := False) return Node_Id + is + Type_Node : Node_Id; + + begin + if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then + Type_Node := P_Subtype_Mark; + return P_Subtype_Indication (Type_Node, Not_Null_Present); + + else + -- Check for error of using record definition and treat it nicely, + -- otherwise things are really messed up, so resynchronize. + + if Token = Tok_Record then + Error_Msg_SC ("anonymous record definitions are not permitted"); + Discard_Junk_Node (P_Record_Definition); + return Error; + + else + Error_Msg_AP ("subtype indication expected"); + raise Error_Resync; + end if; + end if; + end P_Subtype_Indication; + + -- The following function is identical except that it is called with + -- the subtype mark already scanned out, and it scans out the constraint + + -- Error recovery: can raise Error_Resync + + function P_Subtype_Indication + (Subtype_Mark : Node_Id; + Not_Null_Present : Boolean := False) return Node_Id + is + Indic_Node : Node_Id; + Constr_Node : Node_Id; + + begin + Constr_Node := P_Constraint_Opt; + + if No (Constr_Node) then + return Subtype_Mark; + else + if Not_Null_Present then + Error_Msg_SP ("`NOT NULL` not allowed if constraint given"); + end if; + + Indic_Node := New_Node (N_Subtype_Indication, Sloc (Subtype_Mark)); + Set_Subtype_Mark (Indic_Node, Check_Subtype_Mark (Subtype_Mark)); + Set_Constraint (Indic_Node, Constr_Node); + return Indic_Node; + end if; + end P_Subtype_Indication; + + ------------------------- + -- 3.2.2 Subtype Mark -- + ------------------------- + + -- SUBTYPE_MARK ::= subtype_NAME; + + -- Note: The subtype mark which appears after an IN or NOT IN + -- operator is parsed by P_Range_Or_Subtype_Mark (3.5) + + -- Error recovery: cannot raise Error_Resync + + function P_Subtype_Mark return Node_Id is + begin + return P_Subtype_Mark_Resync; + exception + when Error_Resync => + return Error; + end P_Subtype_Mark; + + -- This routine differs from P_Subtype_Mark in that it insists that an + -- identifier be present, and if it is not, it raises Error_Resync. + + -- Error recovery: can raise Error_Resync + + function P_Subtype_Mark_Resync return Node_Id is + Type_Node : Node_Id; + + begin + if Token = Tok_Access then + Error_Msg_SC ("anonymous access type definition not allowed here"); + Scan; -- past ACCESS + end if; + + if Token = Tok_Array then + Error_Msg_SC ("anonymous array definition not allowed here"); + Discard_Junk_Node (P_Array_Type_Definition); + return Error; + + -- If Some becomes a keyword, the following is needed to make it + -- acceptable in older versions of Ada. + + elsif Token = Tok_Some + and then Ada_Version < Ada_2012 + then + Scan_Reserved_Identifier (False); + Scan; + return Token_Node; + + else + Type_Node := P_Qualified_Simple_Name_Resync; + + -- Check for a subtype mark attribute. The only valid possibilities + -- are 'CLASS and 'BASE. Anything else is a definite error. We may + -- as well catch it here. + + if Token = Tok_Apostrophe then + return P_Subtype_Mark_Attribute (Type_Node); + else + return Type_Node; + end if; + end if; + end P_Subtype_Mark_Resync; + + -- The following function is called to scan out a subtype mark attribute. + -- The caller has already scanned out the subtype mark, which is passed in + -- as the argument, and has checked that the current token is apostrophe. + + -- Only a special subclass of attributes, called type attributes + -- (see Snames package) are allowed in this syntactic position. + + -- Note: if the apostrophe is followed by other than an identifier, then + -- the input expression is returned unchanged, and the scan pointer is + -- left pointing to the apostrophe. + + -- Error recovery: can raise Error_Resync + + function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id is + Attr_Node : Node_Id := Empty; + Scan_State : Saved_Scan_State; + Prefix : Node_Id; + + begin + Prefix := Check_Subtype_Mark (Type_Node); + + if Prefix = Error then + raise Error_Resync; + end if; + + -- Loop through attributes appearing (more than one can appear as for + -- for example in X'Base'Class). We are at an apostrophe on entry to + -- this loop, and it runs once for each attribute parsed, with + -- Prefix being the current possible prefix if it is an attribute. + + loop + Save_Scan_State (Scan_State); -- at Apostrophe + Scan; -- past apostrophe + + if Token /= Tok_Identifier then + Restore_Scan_State (Scan_State); -- to apostrophe + return Prefix; -- no attribute after all + + elsif not Is_Type_Attribute_Name (Token_Name) then + Error_Msg_N + ("attribute & may not be used in a subtype mark", Token_Node); + raise Error_Resync; + + else + Attr_Node := + Make_Attribute_Reference (Prev_Token_Ptr, + Prefix => Prefix, + Attribute_Name => Token_Name); + Scan; -- past type attribute identifier + end if; + + exit when Token /= Tok_Apostrophe; + Prefix := Attr_Node; + end loop; + + -- Fall through here after scanning type attribute + + return Attr_Node; + end P_Subtype_Mark_Attribute; + + ----------------------- + -- 3.2.2 Constraint -- + ----------------------- + + -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT + + -- SCALAR_CONSTRAINT ::= + -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT + + -- COMPOSITE_CONSTRAINT ::= + -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT + + -- If no constraint is present, this function returns Empty + + -- Error recovery: can raise Error_Resync + + function P_Constraint_Opt return Node_Id is + begin + if Token = Tok_Range + or else Bad_Spelling_Of (Tok_Range) + then + return P_Range_Constraint; + + elsif Token = Tok_Digits + or else Bad_Spelling_Of (Tok_Digits) + then + return P_Digits_Constraint; + + elsif Token = Tok_Delta + or else Bad_Spelling_Of (Tok_Delta) + then + return P_Delta_Constraint; + + elsif Token = Tok_Left_Paren then + return P_Index_Or_Discriminant_Constraint; + + elsif Token = Tok_In then + Ignore (Tok_In); + return P_Constraint_Opt; + + else + return Empty; + end if; + end P_Constraint_Opt; + + ------------------------------ + -- 3.2.2 Scalar Constraint -- + ------------------------------ + + -- Parsed by P_Constraint_Opt (3.2.2) + + --------------------------------- + -- 3.2.2 Composite Constraint -- + --------------------------------- + + -- Parsed by P_Constraint_Opt (3.2.2) + + -------------------------------------------------------- + -- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) -- + -------------------------------------------------------- + + -- This routine scans out a declaration starting with an identifier: + + -- OBJECT_DECLARATION ::= + -- DEFINING_IDENTIFIER_LIST : [aliased] [constant] + -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; + -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] + -- ACCESS_DEFINITION [:= EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; + -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] + -- ARRAY_TYPE_DEFINITION [:= EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; + + -- NUMBER_DECLARATION ::= + -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION; + + -- OBJECT_RENAMING_DECLARATION ::= + -- DEFINING_IDENTIFIER : + -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME; + -- | DEFINING_IDENTIFIER : + -- ACCESS_DEFINITION renames object_NAME; + + -- EXCEPTION_RENAMING_DECLARATION ::= + -- DEFINING_IDENTIFIER : exception renames exception_NAME; + + -- EXCEPTION_DECLARATION ::= + -- DEFINING_IDENTIFIER_LIST : exception + -- [ASPECT_SPECIFICATIONS]; + + -- Note that the ALIASED indication in an object declaration is + -- marked by a flag in the parent node. + + -- The caller has checked that the initial token is an identifier + + -- The value returned is a list of declarations, one for each identifier + -- in the list (as described in Sinfo, we always split up multiple + -- declarations into the equivalent sequence of single declarations + -- using the More_Ids and Prev_Ids flags to preserve the source). + + -- If the identifier turns out to be a probable statement rather than + -- an identifier, then the scan is left pointing to the identifier and + -- No_List is returned. + + -- Error recovery: can raise Error_Resync + + procedure P_Identifier_Declarations + (Decls : List_Id; + Done : out Boolean; + In_Spec : Boolean) + is + Acc_Node : Node_Id; + Decl_Node : Node_Id; + Type_Node : Node_Id; + Ident_Sloc : Source_Ptr; + Scan_State : Saved_Scan_State; + List_OK : Boolean := True; + Ident : Nat; + Init_Expr : Node_Id; + Init_Loc : Source_Ptr; + Con_Loc : Source_Ptr; + Not_Null_Present : Boolean := False; + + Idents : array (Int range 1 .. 4096) of Entity_Id; + -- Used to save identifiers in the identifier list. The upper bound + -- of 4096 is expected to be infinite in practice, and we do not even + -- bother to check if this upper bound is exceeded. + + Num_Idents : Nat := 1; + -- Number of identifiers stored in Idents + + procedure No_List; + -- This procedure is called in renames cases to make sure that we do + -- not have more than one identifier. If we do have more than one + -- then an error message is issued (and the declaration is split into + -- multiple declarations) + + function Token_Is_Renames return Boolean; + -- Checks if current token is RENAMES, and if so, scans past it and + -- returns True, otherwise returns False. Includes checking for some + -- common error cases. + + ------------- + -- No_List -- + ------------- + + procedure No_List is + begin + if Num_Idents > 1 then + Error_Msg + ("identifier list not allowed for RENAMES", + Sloc (Idents (2))); + end if; + + List_OK := False; + end No_List; + + ---------------------- + -- Token_Is_Renames -- + ---------------------- + + function Token_Is_Renames return Boolean is + At_Colon : Saved_Scan_State; + + begin + if Token = Tok_Colon then + Save_Scan_State (At_Colon); + Scan; -- past colon + Check_Misspelling_Of (Tok_Renames); + + if Token = Tok_Renames then + Error_Msg_SP -- CODEFIX + ("|extra "":"" ignored"); + Scan; -- past RENAMES + return True; + else + Restore_Scan_State (At_Colon); + return False; + end if; + + else + Check_Misspelling_Of (Tok_Renames); + + if Token = Tok_Renames then + Scan; -- past RENAMES + return True; + else + return False; + end if; + end if; + end Token_Is_Renames; + + -- Start of processing for P_Identifier_Declarations + + begin + Ident_Sloc := Token_Ptr; + Save_Scan_State (Scan_State); -- at first identifier + Idents (1) := P_Defining_Identifier (C_Comma_Colon); + + -- If we have a colon after the identifier, then we can assume that + -- this is in fact a valid identifier declaration and can steam ahead. + + if Token = Tok_Colon then + Scan; -- past colon + + -- If we have a comma, then scan out the list of identifiers + + elsif Token = Tok_Comma then + while Comma_Present loop + Num_Idents := Num_Idents + 1; + Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon); + end loop; + + Save_Scan_State (Scan_State); -- at colon + T_Colon; + + -- If we have identifier followed by := then we assume that what is + -- really meant is an assignment statement. The assignment statement + -- is scanned out and added to the list of declarations. An exception + -- occurs if the := is followed by the keyword constant, in which case + -- we assume it was meant to be a colon. + + elsif Token = Tok_Colon_Equal then + Scan; -- past := + + if Token = Tok_Constant then + Error_Msg_SP ("colon expected"); + + else + Restore_Scan_State (Scan_State); + Statement_When_Declaration_Expected (Decls, Done, In_Spec); + return; + end if; + + -- If we have an IS keyword, then assume the TYPE keyword was missing + + elsif Token = Tok_Is then + Restore_Scan_State (Scan_State); + Append_To (Decls, P_Type_Declaration); + Done := False; + return; + + -- Otherwise we have an error situation + + else + Restore_Scan_State (Scan_State); + + -- First case is possible misuse of PROTECTED in Ada 83 mode. If + -- so, fix the keyword and return to scan the protected declaration. + + if Token_Name = Name_Protected then + Check_95_Keyword (Tok_Protected, Tok_Identifier); + Check_95_Keyword (Tok_Protected, Tok_Type); + Check_95_Keyword (Tok_Protected, Tok_Body); + + if Token = Tok_Protected then + Done := False; + return; + end if; + + -- Check misspelling possibilities. If so, correct the misspelling + -- and return to scan out the resulting declaration. + + elsif Bad_Spelling_Of (Tok_Function) + or else Bad_Spelling_Of (Tok_Procedure) + or else Bad_Spelling_Of (Tok_Package) + or else Bad_Spelling_Of (Tok_Pragma) + or else Bad_Spelling_Of (Tok_Protected) + or else Bad_Spelling_Of (Tok_Generic) + or else Bad_Spelling_Of (Tok_Subtype) + or else Bad_Spelling_Of (Tok_Type) + or else Bad_Spelling_Of (Tok_Task) + or else Bad_Spelling_Of (Tok_Use) + or else Bad_Spelling_Of (Tok_For) + then + Done := False; + return; + + -- Otherwise we definitely have an ordinary identifier with a junk + -- token after it. Just complain that we expect a declaration, and + -- skip to a semicolon + + else + Set_Declaration_Expected; + Resync_Past_Semicolon; + Done := False; + return; + end if; + end if; + + -- Come here with an identifier list and colon scanned out. We now + -- build the nodes for the declarative items. One node is built for + -- each identifier in the list, with the type information being + -- repeated by rescanning the appropriate section of source. + + -- First an error check, if we have two identifiers in a row, a likely + -- possibility is that the first of the identifiers is an incorrectly + -- spelled keyword. + + if Token = Tok_Identifier then + declare + SS : Saved_Scan_State; + I2 : Boolean; + + begin + Save_Scan_State (SS); + Scan; -- past initial identifier + I2 := (Token = Tok_Identifier); + Restore_Scan_State (SS); + + if I2 + and then + (Bad_Spelling_Of (Tok_Access) or else + Bad_Spelling_Of (Tok_Aliased) or else + Bad_Spelling_Of (Tok_Constant)) + then + null; + end if; + end; + end if; + + -- Loop through identifiers + + Ident := 1; + Ident_Loop : loop + + -- Check for some cases of misused Ada 95 keywords + + if Token_Name = Name_Aliased then + Check_95_Keyword (Tok_Aliased, Tok_Array); + Check_95_Keyword (Tok_Aliased, Tok_Identifier); + Check_95_Keyword (Tok_Aliased, Tok_Constant); + end if; + + -- Constant cases + + if Token = Tok_Constant then + Con_Loc := Token_Ptr; + Scan; -- past CONSTANT + + -- Number declaration, initialization required + + Init_Expr := Init_Expr_Opt; + + if Present (Init_Expr) then + if Not_Null_Present then + Error_Msg_SP + ("`NOT NULL` not allowed in numeric expression"); + end if; + + Decl_Node := New_Node (N_Number_Declaration, Ident_Sloc); + Set_Expression (Decl_Node, Init_Expr); + + -- Constant object declaration + + else + Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); + Set_Constant_Present (Decl_Node, True); + + if Token_Name = Name_Aliased then + Check_95_Keyword (Tok_Aliased, Tok_Array); + Check_95_Keyword (Tok_Aliased, Tok_Identifier); + end if; + + if Token = Tok_Aliased then + Error_Msg_SC -- CODEFIX + ("ALIASED should be before CONSTANT"); + Scan; -- past ALIASED + Set_Aliased_Present (Decl_Node, True); + end if; + + if Token = Tok_Array then + Set_Object_Definition + (Decl_Node, P_Array_Type_Definition); + + else + Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) + Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); + + if Token = Tok_Access then + if Ada_Version < Ada_2005 then + Error_Msg_SP + ("generalized use of anonymous access types " & + "is an Ada 2005 extension"); + Error_Msg_SP + ("\unit must be compiled with -gnat05 switch"); + end if; + + Set_Object_Definition + (Decl_Node, P_Access_Definition (Not_Null_Present)); + else + Set_Object_Definition + (Decl_Node, P_Subtype_Indication (Not_Null_Present)); + end if; + end if; + + if Token = Tok_Renames then + Error_Msg + ("CONSTANT not permitted in renaming declaration", + Con_Loc); + Scan; -- Past renames + Discard_Junk_Node (P_Name); + end if; + end if; + + -- Exception cases + + elsif Token = Tok_Exception then + Scan; -- past EXCEPTION + + if Token_Is_Renames then + No_List; + Decl_Node := + New_Node (N_Exception_Renaming_Declaration, Ident_Sloc); + Set_Name (Decl_Node, P_Qualified_Simple_Name_Resync); + No_Constraint; + else + Decl_Node := New_Node (N_Exception_Declaration, Prev_Token_Ptr); + end if; + + -- Aliased case (note that an object definition is required) + + elsif Token = Tok_Aliased then + Scan; -- past ALIASED + Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); + Set_Aliased_Present (Decl_Node, True); + + if Token = Tok_Constant then + Scan; -- past CONSTANT + Set_Constant_Present (Decl_Node, True); + end if; + + if Token = Tok_Array then + Set_Object_Definition + (Decl_Node, P_Array_Type_Definition); + + else + Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) + Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); + + -- Access definition (AI-406) or subtype indication + + if Token = Tok_Access then + if Ada_Version < Ada_2005 then + Error_Msg_SP + ("generalized use of anonymous access types " & + "is an Ada 2005 extension"); + Error_Msg_SP + ("\unit must be compiled with -gnat05 switch"); + end if; + + Set_Object_Definition + (Decl_Node, P_Access_Definition (Not_Null_Present)); + else + Set_Object_Definition + (Decl_Node, P_Subtype_Indication (Not_Null_Present)); + end if; + end if; + + -- Array case + + elsif Token = Tok_Array then + Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); + Set_Object_Definition (Decl_Node, P_Array_Type_Definition); + + -- Ada 2005 (AI-254, AI-406) + + elsif Token = Tok_Not then + + -- OBJECT_DECLARATION ::= + -- DEFINING_IDENTIFIER_LIST : [aliased] [constant] + -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION]; + -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] + -- ACCESS_DEFINITION [:= EXPRESSION]; + + -- OBJECT_RENAMING_DECLARATION ::= + -- DEFINING_IDENTIFIER : + -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME; + -- | DEFINING_IDENTIFIER : + -- ACCESS_DEFINITION renames object_NAME; + + Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/423) + + if Token = Tok_Access then + if Ada_Version < Ada_2005 then + Error_Msg_SP + ("generalized use of anonymous access types " & + "is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + end if; + + Acc_Node := P_Access_Definition (Not_Null_Present); + + if Token /= Tok_Renames then + Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); + Set_Object_Definition (Decl_Node, Acc_Node); + + else + Scan; -- past renames + No_List; + Decl_Node := + New_Node (N_Object_Renaming_Declaration, Ident_Sloc); + Set_Access_Definition (Decl_Node, Acc_Node); + Set_Name (Decl_Node, P_Name); + end if; + + else + Type_Node := P_Subtype_Mark; + + -- Object renaming declaration + + if Token_Is_Renames then + if Ada_Version < Ada_2005 then + Error_Msg_SP + ("`NOT NULL` not allowed in object renaming"); + raise Error_Resync; + + -- Ada 2005 (AI-423): Object renaming declaration with + -- a null exclusion. + + else + No_List; + Decl_Node := + New_Node (N_Object_Renaming_Declaration, Ident_Sloc); + Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); + Set_Subtype_Mark (Decl_Node, Type_Node); + Set_Name (Decl_Node, P_Name); + end if; + + -- Object declaration + + else + Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); + Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); + Set_Object_Definition + (Decl_Node, + P_Subtype_Indication (Type_Node, Not_Null_Present)); + + -- RENAMES at this point means that we had the combination + -- of a constraint on the Type_Node and renames, which is + -- illegal + + if Token_Is_Renames then + Error_Msg_N + ("constraint not allowed in object renaming " + & "declaration", + Constraint (Object_Definition (Decl_Node))); + raise Error_Resync; + end if; + end if; + end if; + + -- Ada 2005 (AI-230): Access Definition case + + elsif Token = Tok_Access then + if Ada_Version < Ada_2005 then + Error_Msg_SP + ("generalized use of anonymous access types " & + "is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + end if; + + Acc_Node := P_Access_Definition (Null_Exclusion_Present => False); + + -- Object declaration with access definition, or renaming + + if Token /= Tok_Renames then + Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); + Set_Object_Definition (Decl_Node, Acc_Node); + + else + Scan; -- past renames + No_List; + Decl_Node := + New_Node (N_Object_Renaming_Declaration, Ident_Sloc); + Set_Access_Definition (Decl_Node, Acc_Node); + Set_Name (Decl_Node, P_Name); + end if; + + -- Subtype indication case + + else + Type_Node := P_Subtype_Mark; + + -- Object renaming declaration + + if Token_Is_Renames then + No_List; + Decl_Node := + New_Node (N_Object_Renaming_Declaration, Ident_Sloc); + Set_Subtype_Mark (Decl_Node, Type_Node); + Set_Name (Decl_Node, P_Name); + + -- Object declaration + + else + Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); + Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); + Set_Object_Definition + (Decl_Node, + P_Subtype_Indication (Type_Node, Not_Null_Present)); + + -- RENAMES at this point means that we had the combination of + -- a constraint on the Type_Node and renames, which is illegal + + if Token_Is_Renames then + Error_Msg_N + ("constraint not allowed in object renaming declaration", + Constraint (Object_Definition (Decl_Node))); + raise Error_Resync; + end if; + end if; + end if; + + -- Scan out initialization, allowed only for object declaration + + Init_Loc := Token_Ptr; + Init_Expr := Init_Expr_Opt; + + if Present (Init_Expr) then + if Nkind (Decl_Node) = N_Object_Declaration then + Set_Expression (Decl_Node, Init_Expr); + Set_Has_Init_Expression (Decl_Node); + else + Error_Msg ("initialization not allowed here", Init_Loc); + end if; + end if; + + Set_Defining_Identifier (Decl_Node, Idents (Ident)); + P_Aspect_Specifications (Decl_Node); + + if List_OK then + if Ident < Num_Idents then + Set_More_Ids (Decl_Node, True); + end if; + + if Ident > 1 then + Set_Prev_Ids (Decl_Node, True); + end if; + end if; + + Append (Decl_Node, Decls); + exit Ident_Loop when Ident = Num_Idents; + Restore_Scan_State (Scan_State); + T_Colon; + Ident := Ident + 1; + end loop Ident_Loop; + + Done := False; + end P_Identifier_Declarations; + + ------------------------------- + -- 3.3.1 Object Declaration -- + ------------------------------- + + -- OBJECT DECLARATION ::= + -- DEFINING_IDENTIFIER_LIST : [aliased] [constant] + -- SUBTYPE_INDICATION [:= EXPRESSION]; + -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] + -- ARRAY_TYPE_DEFINITION [:= EXPRESSION]; + -- | SINGLE_TASK_DECLARATION + -- | SINGLE_PROTECTED_DECLARATION + + -- Cases starting with TASK are parsed by P_Task (9.1) + -- Cases starting with PROTECTED are parsed by P_Protected (9.4) + -- All other cases are parsed by P_Identifier_Declarations (3.3) + + ------------------------------------- + -- 3.3.1 Defining Identifier List -- + ------------------------------------- + + -- DEFINING_IDENTIFIER_LIST ::= + -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER} + + -- Always parsed by the construct in which it appears. See special + -- section on "Handling of Defining Identifier Lists" in this unit. + + ------------------------------- + -- 3.3.2 Number Declaration -- + ------------------------------- + + -- Parsed by P_Identifier_Declarations (3.3) + + ------------------------------------------------------------------------- + -- 3.4 Derived Type Definition or Private Extension Declaration (7.3) -- + ------------------------------------------------------------------------- + + -- DERIVED_TYPE_DEFINITION ::= + -- [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION + -- [[and INTERFACE_LIST] RECORD_EXTENSION_PART] + + -- PRIVATE_EXTENSION_DECLARATION ::= + -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is + -- [abstract] [limited | synchronized] + -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST] + -- with private; + + -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION + + -- The caller has already scanned out the part up to the NEW, and Token + -- either contains Tok_New (or ought to, if it doesn't this procedure + -- will post an appropriate "NEW expected" message). + + -- Note: the caller is responsible for filling in the Sloc field of + -- the returned node in the private extension declaration case as + -- well as the stuff relating to the discriminant part. + + -- Error recovery: can raise Error_Resync; + + function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id is + Typedef_Node : Node_Id; + Typedecl_Node : Node_Id; + Not_Null_Present : Boolean := False; + + begin + Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr); + + if Ada_Version < Ada_2005 + and then Token = Tok_Identifier + and then Token_Name = Name_Interface + then + Error_Msg_SP + ("abstract interface is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + else + T_New; + end if; + + if Token = Tok_Abstract then + Error_Msg_SC -- CODEFIX + ("ABSTRACT must come before NEW, not after"); + Scan; + end if; + + Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) + Set_Null_Exclusion_Present (Typedef_Node, Not_Null_Present); + Set_Subtype_Indication (Typedef_Node, + P_Subtype_Indication (Not_Null_Present)); + + -- Ada 2005 (AI-251): Deal with interfaces + + if Token = Tok_And then + Scan; -- past AND + + if Ada_Version < Ada_2005 then + Error_Msg_SP + ("abstract interface is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + end if; + + Set_Interface_List (Typedef_Node, New_List); + + loop + Append (P_Qualified_Simple_Name, Interface_List (Typedef_Node)); + exit when Token /= Tok_And; + Scan; -- past AND + end loop; + + if Token /= Tok_With then + Error_Msg_SC ("WITH expected"); + raise Error_Resync; + end if; + end if; + + -- Deal with record extension, note that we assume that a WITH is + -- missing in the case of "type X is new Y record ..." or in the + -- case of "type X is new Y null record". + + -- First make sure we don't have an aspect specification. If we do + -- return now, so that our caller can check it (the WITH here is not + -- part of a type extension). + + if Aspect_Specifications_Present then + return Typedef_Node; + + -- OK, not an aspect specification, so continue test for extension + + elsif Token = Tok_With + or else Token = Tok_Record + or else Token = Tok_Null + then + T_With; -- past WITH or give error message + + if Token = Tok_Limited then + Error_Msg_SC ("LIMITED keyword not allowed in private extension"); + Scan; -- ignore LIMITED + end if; + + -- Private extension declaration + + if Token = Tok_Private then + Scan; -- past PRIVATE + + -- Throw away the type definition node and build the type + -- declaration node. Note the caller must set the Sloc, + -- Discriminant_Specifications, Unknown_Discriminants_Present, + -- and Defined_Identifier fields in the returned node. + + Typedecl_Node := + Make_Private_Extension_Declaration (No_Location, + Defining_Identifier => Empty, + Subtype_Indication => Subtype_Indication (Typedef_Node), + Abstract_Present => Abstract_Present (Typedef_Node), + Interface_List => Interface_List (Typedef_Node)); + + return Typedecl_Node; + + -- Derived type definition with record extension part + + else + Set_Record_Extension_Part (Typedef_Node, P_Record_Definition); + return Typedef_Node; + end if; + + -- Derived type definition with no record extension part + + else + return Typedef_Node; + end if; + end P_Derived_Type_Def_Or_Private_Ext_Decl; + + --------------------------- + -- 3.5 Range Constraint -- + --------------------------- + + -- RANGE_CONSTRAINT ::= range RANGE + + -- The caller has checked that the initial token is RANGE + + -- Error recovery: cannot raise Error_Resync + + function P_Range_Constraint return Node_Id is + Range_Node : Node_Id; + + begin + Range_Node := New_Node (N_Range_Constraint, Token_Ptr); + Scan; -- past RANGE + Set_Range_Expression (Range_Node, P_Range); + return Range_Node; + end P_Range_Constraint; + + ---------------- + -- 3.5 Range -- + ---------------- + + -- RANGE ::= + -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION + + -- Note: the range that appears in a membership test is parsed by + -- P_Range_Or_Subtype_Mark (3.5). + + -- Error recovery: cannot raise Error_Resync + + function P_Range return Node_Id is + Expr_Node : Node_Id; + Range_Node : Node_Id; + + begin + Expr_Node := P_Simple_Expression_Or_Range_Attribute; + + if Expr_Form = EF_Range_Attr then + return Expr_Node; + + elsif Token = Tok_Dot_Dot then + Range_Node := New_Node (N_Range, Token_Ptr); + Set_Low_Bound (Range_Node, Expr_Node); + Scan; -- past .. + Expr_Node := P_Expression; + Check_Simple_Expression (Expr_Node); + Set_High_Bound (Range_Node, Expr_Node); + return Range_Node; + + -- Anything else is an error + + else + T_Dot_Dot; -- force missing .. message + return Error; + end if; + end P_Range; + + ---------------------------------- + -- 3.5 P_Range_Or_Subtype_Mark -- + ---------------------------------- + + -- RANGE ::= + -- RANGE_ATTRIBUTE_REFERENCE + -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION + + -- This routine scans out the range or subtype mark that forms the right + -- operand of a membership test (it is not used in any other contexts, and + -- error messages are specialized with this knowledge in mind). + + -- Note: as documented in the Sinfo interface, although the syntax only + -- allows a subtype mark, we in fact allow any simple expression to be + -- returned from this routine. The semantics is responsible for issuing + -- an appropriate message complaining if the argument is not a name. + -- This simplifies the coding and error recovery processing in the + -- parser, and in any case it is preferable not to consider this a + -- syntax error and to continue with the semantic analysis. + + -- Error recovery: cannot raise Error_Resync + + function P_Range_Or_Subtype_Mark + (Allow_Simple_Expression : Boolean := False) return Node_Id + is + Expr_Node : Node_Id; + Range_Node : Node_Id; + Save_Loc : Source_Ptr; + + -- Start of processing for P_Range_Or_Subtype_Mark + + begin + -- Save location of possible junk parentheses + + Save_Loc := Token_Ptr; + + -- Scan out either a simple expression or a range (this accepts more + -- than is legal here, but as explained above, we like to allow more + -- with a proper diagnostic, and in the case of a membership operation + -- where sets are allowed, a simple expression is permissible anyway. + + Expr_Node := P_Simple_Expression_Or_Range_Attribute; + + -- Range attribute + + if Expr_Form = EF_Range_Attr then + return Expr_Node; + + -- Simple_Expression .. Simple_Expression + + elsif Token = Tok_Dot_Dot then + Check_Simple_Expression (Expr_Node); + Range_Node := New_Node (N_Range, Token_Ptr); + Set_Low_Bound (Range_Node, Expr_Node); + Scan; -- past .. + Set_High_Bound (Range_Node, P_Simple_Expression); + return Range_Node; + + -- Case of subtype mark (optionally qualified simple name or an + -- attribute whose prefix is an optionally qualified simple name) + + elsif Expr_Form = EF_Simple_Name + or else Nkind (Expr_Node) = N_Attribute_Reference + then + -- Check for error of range constraint after a subtype mark + + if Token = Tok_Range then + Error_Msg_SC ("range constraint not allowed in membership test"); + Scan; -- past RANGE + raise Error_Resync; + + -- Check for error of DIGITS or DELTA after a subtype mark + + elsif Token = Tok_Digits or else Token = Tok_Delta then + Error_Msg_SC + ("accuracy definition not allowed in membership test"); + Scan; -- past DIGITS or DELTA + raise Error_Resync; + + -- Attribute reference, may or may not be OK, but in any case we + -- will scan it out + + elsif Token = Tok_Apostrophe then + return P_Subtype_Mark_Attribute (Expr_Node); + + -- OK case of simple name, just return it + + else + return Expr_Node; + end if; + + -- Simple expression case + + elsif Expr_Form = EF_Simple and then Allow_Simple_Expression then + return Expr_Node; + + -- Here we have some kind of error situation. Check for junk parens + -- then return what we have, caller will deal with other errors. + + else + if Nkind (Expr_Node) in N_Subexpr + and then Paren_Count (Expr_Node) /= 0 + then + Error_Msg ("|parentheses not allowed for subtype mark", Save_Loc); + Set_Paren_Count (Expr_Node, 0); + end if; + + return Expr_Node; + end if; + end P_Range_Or_Subtype_Mark; + + ---------------------------------------- + -- 3.5.1 Enumeration Type Definition -- + ---------------------------------------- + + -- ENUMERATION_TYPE_DEFINITION ::= + -- (ENUMERATION_LITERAL_SPECIFICATION + -- {, ENUMERATION_LITERAL_SPECIFICATION}) + + -- The caller has already scanned out the TYPE keyword + + -- Error recovery: can raise Error_Resync; + + function P_Enumeration_Type_Definition return Node_Id is + Typedef_Node : Node_Id; + + begin + Typedef_Node := New_Node (N_Enumeration_Type_Definition, Token_Ptr); + Set_Literals (Typedef_Node, New_List); + + T_Left_Paren; + + loop + Append (P_Enumeration_Literal_Specification, Literals (Typedef_Node)); + exit when not Comma_Present; + end loop; + + T_Right_Paren; + return Typedef_Node; + end P_Enumeration_Type_Definition; + + ---------------------------------------------- + -- 3.5.1 Enumeration Literal Specification -- + ---------------------------------------------- + + -- ENUMERATION_LITERAL_SPECIFICATION ::= + -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL + + -- Error recovery: can raise Error_Resync + + function P_Enumeration_Literal_Specification return Node_Id is + begin + if Token = Tok_Char_Literal then + return P_Defining_Character_Literal; + else + return P_Defining_Identifier (C_Comma_Right_Paren); + end if; + end P_Enumeration_Literal_Specification; + + --------------------------------------- + -- 3.5.1 Defining_Character_Literal -- + --------------------------------------- + + -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL + + -- Error recovery: cannot raise Error_Resync + + -- The caller has checked that the current token is a character literal + + function P_Defining_Character_Literal return Node_Id is + Literal_Node : Node_Id; + begin + Literal_Node := Token_Node; + Change_Character_Literal_To_Defining_Character_Literal (Literal_Node); + Scan; -- past character literal + return Literal_Node; + end P_Defining_Character_Literal; + + ------------------------------------ + -- 3.5.4 Integer Type Definition -- + ------------------------------------ + + -- Parsed by P_Type_Declaration (3.2.1) + + ------------------------------------------- + -- 3.5.4 Signed Integer Type Definition -- + ------------------------------------------- + + -- SIGNED_INTEGER_TYPE_DEFINITION ::= + -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION + + -- Normally the initial token on entry is RANGE, but in some + -- error conditions, the range token was missing and control is + -- passed with Token pointing to first token of the first expression. + + -- Error recovery: cannot raise Error_Resync + + function P_Signed_Integer_Type_Definition return Node_Id is + Typedef_Node : Node_Id; + Expr_Node : Node_Id; + + begin + Typedef_Node := New_Node (N_Signed_Integer_Type_Definition, Token_Ptr); + + if Token = Tok_Range then + Scan; -- past RANGE + end if; + + Expr_Node := P_Expression; + Check_Simple_Expression (Expr_Node); + Set_Low_Bound (Typedef_Node, Expr_Node); + T_Dot_Dot; + Expr_Node := P_Expression; + Check_Simple_Expression (Expr_Node); + Set_High_Bound (Typedef_Node, Expr_Node); + return Typedef_Node; + end P_Signed_Integer_Type_Definition; + + ------------------------------------ + -- 3.5.4 Modular Type Definition -- + ------------------------------------ + + -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION + + -- The caller has checked that the initial token is MOD + + -- Error recovery: cannot raise Error_Resync + + function P_Modular_Type_Definition return Node_Id is + Typedef_Node : Node_Id; + + begin + if Ada_Version = Ada_83 then + Error_Msg_SC ("(Ada 83): modular types not allowed"); + end if; + + Typedef_Node := New_Node (N_Modular_Type_Definition, Token_Ptr); + Scan; -- past MOD + Set_Expression (Typedef_Node, P_Expression_No_Right_Paren); + + -- Handle mod L..R cleanly + + if Token = Tok_Dot_Dot then + Error_Msg_SC ("range not allowed for modular type"); + Scan; -- past .. + Set_Expression (Typedef_Node, P_Expression_No_Right_Paren); + end if; + + return Typedef_Node; + end P_Modular_Type_Definition; + + --------------------------------- + -- 3.5.6 Real Type Definition -- + --------------------------------- + + -- Parsed by P_Type_Declaration (3.2.1) + + -------------------------------------- + -- 3.5.7 Floating Point Definition -- + -------------------------------------- + + -- FLOATING_POINT_DEFINITION ::= + -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION] + + -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION + + -- The caller has checked that the initial token is DIGITS + + -- Error recovery: cannot raise Error_Resync + + function P_Floating_Point_Definition return Node_Id is + Digits_Loc : constant Source_Ptr := Token_Ptr; + Def_Node : Node_Id; + Expr_Node : Node_Id; + + begin + Scan; -- past DIGITS + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + + -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order + + if Token = Tok_Delta then + Error_Msg_SC -- CODEFIX + ("|DELTA must come before DIGITS"); + Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Digits_Loc); + Scan; -- past DELTA + Set_Delta_Expression (Def_Node, P_Expression_No_Right_Paren); + + -- OK floating-point definition + + else + Def_Node := New_Node (N_Floating_Point_Definition, Digits_Loc); + end if; + + Set_Digits_Expression (Def_Node, Expr_Node); + Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt); + return Def_Node; + end P_Floating_Point_Definition; + + ------------------------------------- + -- 3.5.7 Real Range Specification -- + ------------------------------------- + + -- REAL_RANGE_SPECIFICATION ::= + -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION + + -- Error recovery: cannot raise Error_Resync + + function P_Real_Range_Specification_Opt return Node_Id is + Specification_Node : Node_Id; + Expr_Node : Node_Id; + + begin + if Token = Tok_Range then + Specification_Node := + New_Node (N_Real_Range_Specification, Token_Ptr); + Scan; -- past RANGE + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression (Expr_Node); + Set_Low_Bound (Specification_Node, Expr_Node); + T_Dot_Dot; + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression (Expr_Node); + Set_High_Bound (Specification_Node, Expr_Node); + return Specification_Node; + else + return Empty; + end if; + end P_Real_Range_Specification_Opt; + + ----------------------------------- + -- 3.5.9 Fixed Point Definition -- + ----------------------------------- + + -- FIXED_POINT_DEFINITION ::= + -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION + + -- ORDINARY_FIXED_POINT_DEFINITION ::= + -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION + + -- DECIMAL_FIXED_POINT_DEFINITION ::= + -- delta static_EXPRESSION + -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION] + + -- The caller has checked that the initial token is DELTA + + -- Error recovery: cannot raise Error_Resync + + function P_Fixed_Point_Definition return Node_Id is + Delta_Node : Node_Id; + Delta_Loc : Source_Ptr; + Def_Node : Node_Id; + Expr_Node : Node_Id; + + begin + Delta_Loc := Token_Ptr; + Scan; -- past DELTA + Delta_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Delta_Node); + + if Token = Tok_Digits then + if Ada_Version = Ada_83 then + Error_Msg_SC ("(Ada 83) decimal fixed type not allowed!"); + end if; + + Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Delta_Loc); + Scan; -- past DIGITS + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + Set_Digits_Expression (Def_Node, Expr_Node); + + else + Def_Node := New_Node (N_Ordinary_Fixed_Point_Definition, Delta_Loc); + + -- Range is required in ordinary fixed point case + + if Token /= Tok_Range then + Error_Msg_AP ("range must be given for fixed-point type"); + T_Range; + end if; + end if; + + Set_Delta_Expression (Def_Node, Delta_Node); + Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt); + return Def_Node; + end P_Fixed_Point_Definition; + + -------------------------------------------- + -- 3.5.9 Ordinary Fixed Point Definition -- + -------------------------------------------- + + -- Parsed by P_Fixed_Point_Definition (3.5.9) + + ------------------------------------------- + -- 3.5.9 Decimal Fixed Point Definition -- + ------------------------------------------- + + -- Parsed by P_Decimal_Point_Definition (3.5.9) + + ------------------------------ + -- 3.5.9 Digits Constraint -- + ------------------------------ + + -- DIGITS_CONSTRAINT ::= + -- digits static_EXPRESSION [RANGE_CONSTRAINT] + + -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION + + -- The caller has checked that the initial token is DIGITS + + function P_Digits_Constraint return Node_Id is + Constraint_Node : Node_Id; + Expr_Node : Node_Id; + + begin + Constraint_Node := New_Node (N_Digits_Constraint, Token_Ptr); + Scan; -- past DIGITS + Expr_Node := P_Expression; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + Set_Digits_Expression (Constraint_Node, Expr_Node); + + if Token = Tok_Range then + Set_Range_Constraint (Constraint_Node, P_Range_Constraint); + end if; + + return Constraint_Node; + end P_Digits_Constraint; + + ----------------------------- + -- 3.5.9 Delta Constraint -- + ----------------------------- + + -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT] + + -- Note: this is an obsolescent feature in Ada 95 (I.3) + + -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION + + -- The caller has checked that the initial token is DELTA + + -- Error recovery: cannot raise Error_Resync + + function P_Delta_Constraint return Node_Id is + Constraint_Node : Node_Id; + Expr_Node : Node_Id; + + begin + Constraint_Node := New_Node (N_Delta_Constraint, Token_Ptr); + Scan; -- past DELTA + Expr_Node := P_Expression; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + Set_Delta_Expression (Constraint_Node, Expr_Node); + + if Token = Tok_Range then + Set_Range_Constraint (Constraint_Node, P_Range_Constraint); + end if; + + return Constraint_Node; + end P_Delta_Constraint; + + -------------------------------- + -- 3.6 Array Type Definition -- + -------------------------------- + + -- ARRAY_TYPE_DEFINITION ::= + -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION + + -- UNCONSTRAINED_ARRAY_DEFINITION ::= + -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of + -- COMPONENT_DEFINITION + + -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <> + + -- CONSTRAINED_ARRAY_DEFINITION ::= + -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of + -- COMPONENT_DEFINITION + + -- DISCRETE_SUBTYPE_DEFINITION ::= + -- DISCRETE_SUBTYPE_INDICATION | RANGE + + -- COMPONENT_DEFINITION ::= + -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION + + -- The caller has checked that the initial token is ARRAY + + -- Error recovery: can raise Error_Resync + + function P_Array_Type_Definition return Node_Id is + Array_Loc : Source_Ptr; + CompDef_Node : Node_Id; + Def_Node : Node_Id; + Not_Null_Present : Boolean := False; + Subs_List : List_Id; + Scan_State : Saved_Scan_State; + Aliased_Present : Boolean := False; + + begin + Array_Loc := Token_Ptr; + Scan; -- past ARRAY + Subs_List := New_List; + T_Left_Paren; + + -- It's quite tricky to disentangle these two possibilities, so we do + -- a prescan to determine which case we have and then reset the scan. + -- The prescan skips past possible subtype mark tokens. + + Save_Scan_State (Scan_State); -- just after paren + + while Token in Token_Class_Desig or else + Token = Tok_Dot or else + Token = Tok_Apostrophe -- because of 'BASE, 'CLASS + loop + Scan; + end loop; + + -- If we end up on RANGE <> then we have the unconstrained case. We + -- will also allow the RANGE to be omitted, just to improve error + -- handling for a case like array (integer <>) of integer; + + Scan; -- past possible RANGE or <> + + if (Prev_Token = Tok_Range and then Token = Tok_Box) or else + Prev_Token = Tok_Box + then + Def_Node := New_Node (N_Unconstrained_Array_Definition, Array_Loc); + Restore_Scan_State (Scan_State); -- to first subtype mark + + loop + Append (P_Subtype_Mark_Resync, Subs_List); + T_Range; + T_Box; + exit when Token = Tok_Right_Paren or else Token = Tok_Of; + T_Comma; + end loop; + + Set_Subtype_Marks (Def_Node, Subs_List); + + else + Def_Node := New_Node (N_Constrained_Array_Definition, Array_Loc); + Restore_Scan_State (Scan_State); -- to first discrete range + + loop + Append (P_Discrete_Subtype_Definition, Subs_List); + exit when not Comma_Present; + end loop; + + Set_Discrete_Subtype_Definitions (Def_Node, Subs_List); + end if; + + T_Right_Paren; + T_Of; + + CompDef_Node := New_Node (N_Component_Definition, Token_Ptr); + + if Token_Name = Name_Aliased then + Check_95_Keyword (Tok_Aliased, Tok_Identifier); + end if; + + if Token = Tok_Aliased then + Aliased_Present := True; + Scan; -- past ALIASED + end if; + + Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254) + + -- Ada 2005 (AI-230): Access Definition case + + if Token = Tok_Access then + if Ada_Version < Ada_2005 then + Error_Msg_SP + ("generalized use of anonymous access types " & + "is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + end if; + + if Aliased_Present then + Error_Msg_SP ("ALIASED not allowed here"); + end if; + + Set_Subtype_Indication (CompDef_Node, Empty); + Set_Aliased_Present (CompDef_Node, False); + Set_Access_Definition (CompDef_Node, + P_Access_Definition (Not_Null_Present)); + else + + Set_Access_Definition (CompDef_Node, Empty); + Set_Aliased_Present (CompDef_Node, Aliased_Present); + Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present); + Set_Subtype_Indication (CompDef_Node, + P_Subtype_Indication (Not_Null_Present)); + end if; + + Set_Component_Definition (Def_Node, CompDef_Node); + + return Def_Node; + end P_Array_Type_Definition; + + ----------------------------------------- + -- 3.6 Unconstrained Array Definition -- + ----------------------------------------- + + -- Parsed by P_Array_Type_Definition (3.6) + + --------------------------------------- + -- 3.6 Constrained Array Definition -- + --------------------------------------- + + -- Parsed by P_Array_Type_Definition (3.6) + + -------------------------------------- + -- 3.6 Discrete Subtype Definition -- + -------------------------------------- + + -- DISCRETE_SUBTYPE_DEFINITION ::= + -- discrete_SUBTYPE_INDICATION | RANGE + + -- Note: the discrete subtype definition appearing in a constrained + -- array definition is parsed by P_Array_Type_Definition (3.6) + + -- Error recovery: cannot raise Error_Resync + + function P_Discrete_Subtype_Definition return Node_Id is + begin + -- The syntax of a discrete subtype definition is identical to that + -- of a discrete range, so we simply share the same parsing code. + + return P_Discrete_Range; + end P_Discrete_Subtype_Definition; + + ------------------------------- + -- 3.6 Component Definition -- + ------------------------------- + + -- For the array case, parsed by P_Array_Type_Definition (3.6) + -- For the record case, parsed by P_Component_Declaration (3.8) + + ----------------------------- + -- 3.6.1 Index Constraint -- + ----------------------------- + + -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1) + + --------------------------- + -- 3.6.1 Discrete Range -- + --------------------------- + + -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE + + -- The possible forms for a discrete range are: + + -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2) + -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2) + -- Range_Attribute (RANGE, 3.5) + -- Simple_Expression .. Simple_Expression (RANGE, 3.5) + + -- Error recovery: cannot raise Error_Resync + + function P_Discrete_Range return Node_Id is + Expr_Node : Node_Id; + Range_Node : Node_Id; + + begin + Expr_Node := P_Simple_Expression_Or_Range_Attribute; + + if Expr_Form = EF_Range_Attr then + return Expr_Node; + + elsif Token = Tok_Range then + if Expr_Form /= EF_Simple_Name then + Error_Msg_SC ("range must be preceded by subtype mark"); + end if; + + return P_Subtype_Indication (Expr_Node); + + -- Check Expression .. Expression case + + elsif Token = Tok_Dot_Dot then + Range_Node := New_Node (N_Range, Token_Ptr); + Set_Low_Bound (Range_Node, Expr_Node); + Scan; -- past .. + Expr_Node := P_Expression; + Check_Simple_Expression (Expr_Node); + Set_High_Bound (Range_Node, Expr_Node); + return Range_Node; + + -- Otherwise we must have a subtype mark + + elsif Expr_Form = EF_Simple_Name then + return Expr_Node; + + -- If incorrect, complain that we expect .. + + else + T_Dot_Dot; + return Expr_Node; + end if; + end P_Discrete_Range; + + ---------------------------- + -- 3.7 Discriminant Part -- + ---------------------------- + + -- DISCRIMINANT_PART ::= + -- UNKNOWN_DISCRIMINANT_PART + -- | KNOWN_DISCRIMINANT_PART + + -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7) + -- or P_Unknown_Discriminant_Part (3.7), since we know which we want. + + ------------------------------------ + -- 3.7 Unknown Discriminant Part -- + ------------------------------------ + + -- UNKNOWN_DISCRIMINANT_PART ::= (<>) + + -- If no unknown discriminant part is present, then False is returned, + -- otherwise the unknown discriminant is scanned out and True is returned. + + -- Error recovery: cannot raise Error_Resync + + function P_Unknown_Discriminant_Part_Opt return Boolean is + Scan_State : Saved_Scan_State; + + begin + -- If <> right now, then this is missing left paren + + if Token = Tok_Box then + U_Left_Paren; + + -- If not <> or left paren, then definitely no box + + elsif Token /= Tok_Left_Paren then + return False; + + -- Left paren, so might be a box after it + + else + Save_Scan_State (Scan_State); + Scan; -- past the left paren + + if Token /= Tok_Box then + Restore_Scan_State (Scan_State); + return False; + end if; + end if; + + -- We are now pointing to the box + + if Ada_Version = Ada_83 then + Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!"); + end if; + + Scan; -- past the box + U_Right_Paren; -- must be followed by right paren + return True; + end P_Unknown_Discriminant_Part_Opt; + + ---------------------------------- + -- 3.7 Known Discriminant Part -- + ---------------------------------- + + -- KNOWN_DISCRIMINANT_PART ::= + -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION}) + + -- DISCRIMINANT_SPECIFICATION ::= + -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK + -- [:= DEFAULT_EXPRESSION] + -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION + -- [:= DEFAULT_EXPRESSION] + + -- If no known discriminant part is present, then No_List is returned + + -- Error recovery: cannot raise Error_Resync + + function P_Known_Discriminant_Part_Opt return List_Id is + Specification_Node : Node_Id; + Specification_List : List_Id; + Ident_Sloc : Source_Ptr; + Scan_State : Saved_Scan_State; + Num_Idents : Nat; + Not_Null_Present : Boolean; + Ident : Nat; + + Idents : array (Int range 1 .. 4096) of Entity_Id; + -- This array holds the list of defining identifiers. The upper bound + -- of 4096 is intended to be essentially infinite, and we do not even + -- bother to check for it being exceeded. + + begin + if Token = Tok_Left_Paren then + Specification_List := New_List; + Scan; -- past ( + P_Pragmas_Misplaced; + + Specification_Loop : loop + + Ident_Sloc := Token_Ptr; + Idents (1) := P_Defining_Identifier (C_Comma_Colon); + Num_Idents := 1; + + while Comma_Present loop + Num_Idents := Num_Idents + 1; + Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon); + end loop; + + -- If there are multiple identifiers, we repeatedly scan the + -- type and initialization expression information by resetting + -- the scan pointer (so that we get completely separate trees + -- for each occurrence). + + if Num_Idents > 1 then + Save_Scan_State (Scan_State); + end if; + + T_Colon; + + -- Loop through defining identifiers in list + + Ident := 1; + Ident_Loop : loop + Specification_Node := + New_Node (N_Discriminant_Specification, Ident_Sloc); + Set_Defining_Identifier (Specification_Node, Idents (Ident)); + Not_Null_Present := -- Ada 2005 (AI-231, AI-447) + P_Null_Exclusion (Allow_Anonymous_In_95 => True); + + if Token = Tok_Access then + if Ada_Version = Ada_83 then + Error_Msg_SC + ("(Ada 83) access discriminant not allowed!"); + end if; + + Set_Discriminant_Type + (Specification_Node, + P_Access_Definition (Not_Null_Present)); + else + + Set_Discriminant_Type + (Specification_Node, P_Subtype_Mark); + No_Constraint; + Set_Null_Exclusion_Present -- Ada 2005 (AI-231) + (Specification_Node, Not_Null_Present); + end if; + + Set_Expression + (Specification_Node, Init_Expr_Opt (True)); + + if Ident > 1 then + Set_Prev_Ids (Specification_Node, True); + end if; + + if Ident < Num_Idents then + Set_More_Ids (Specification_Node, True); + end if; + + Append (Specification_Node, Specification_List); + exit Ident_Loop when Ident = Num_Idents; + Ident := Ident + 1; + Restore_Scan_State (Scan_State); + T_Colon; + end loop Ident_Loop; + + exit Specification_Loop when Token /= Tok_Semicolon; + Scan; -- past ; + P_Pragmas_Misplaced; + end loop Specification_Loop; + + T_Right_Paren; + return Specification_List; + + else + return No_List; + end if; + end P_Known_Discriminant_Part_Opt; + + ------------------------------------- + -- 3.7 Discriminant Specification -- + ------------------------------------- + + -- Parsed by P_Known_Discriminant_Part_Opt (3.7) + + ----------------------------- + -- 3.7 Default Expression -- + ----------------------------- + + -- Always parsed (simply as an Expression) by the parent construct + + ------------------------------------ + -- 3.7.1 Discriminant Constraint -- + ------------------------------------ + + -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1) + + -------------------------------------------------------- + -- 3.7.1 Index or Discriminant Constraint (also 3.6) -- + -------------------------------------------------------- + + -- DISCRIMINANT_CONSTRAINT ::= + -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION}) + + -- DISCRIMINANT_ASSOCIATION ::= + -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>] + -- EXPRESSION + + -- This routine parses either an index or a discriminant constraint. As + -- is clear from the above grammar, it is often possible to clearly + -- determine which of the two possibilities we have, but there are + -- cases (those in which we have a series of expressions of the same + -- syntactic form as subtype indications), where we cannot tell. Since + -- this means that in any case the semantic phase has to distinguish + -- between the two, there is not much point in the parser trying to + -- distinguish even those cases where the difference is clear. In any + -- case, if we have a situation like: + + -- (A => 123, 235 .. 500) + + -- it is not clear which of the two items is the wrong one, better to + -- let the semantic phase give a clear message. Consequently, this + -- routine in general returns a list of items which can be either + -- discrete ranges or discriminant associations. + + -- The caller has checked that the initial token is a left paren + + -- Error recovery: can raise Error_Resync + + function P_Index_Or_Discriminant_Constraint return Node_Id is + Scan_State : Saved_Scan_State; + Constr_Node : Node_Id; + Constr_List : List_Id; + Expr_Node : Node_Id; + Result_Node : Node_Id; + + begin + Result_Node := New_Node (N_Index_Or_Discriminant_Constraint, Token_Ptr); + Scan; -- past ( + Constr_List := New_List; + Set_Constraints (Result_Node, Constr_List); + + -- The two syntactic forms are a little mixed up, so what we are doing + -- here is looking at the first entry to determine which case we have + + -- A discriminant constraint is a list of discriminant associations, + -- which have one of the following possible forms: + + -- Expression + -- Id => Expression + -- Id | Id | .. | Id => Expression + + -- An index constraint is a list of discrete ranges which have one + -- of the following possible forms: + + -- Subtype_Mark + -- Subtype_Mark range Range + -- Range_Attribute + -- Simple_Expression .. Simple_Expression + + -- Loop through discriminants in list + + loop + -- Check cases of Id => Expression or Id | Id => Expression + + if Token = Tok_Identifier then + Save_Scan_State (Scan_State); -- at Id + Scan; -- past Id + + if Token = Tok_Arrow or else Token = Tok_Vertical_Bar then + Restore_Scan_State (Scan_State); -- to Id + Append (P_Discriminant_Association, Constr_List); + goto Loop_Continue; + else + Restore_Scan_State (Scan_State); -- to Id + end if; + end if; + + -- Otherwise scan out an expression and see what we have got + + Expr_Node := P_Expression_Or_Range_Attribute; + + if Expr_Form = EF_Range_Attr then + Append (Expr_Node, Constr_List); + + elsif Token = Tok_Range then + if Expr_Form /= EF_Simple_Name then + Error_Msg_SC ("subtype mark required before RANGE"); + end if; + + Append (P_Subtype_Indication (Expr_Node), Constr_List); + goto Loop_Continue; + + -- Check Simple_Expression .. Simple_Expression case + + elsif Token = Tok_Dot_Dot then + Check_Simple_Expression (Expr_Node); + Constr_Node := New_Node (N_Range, Token_Ptr); + Set_Low_Bound (Constr_Node, Expr_Node); + Scan; -- past .. + Expr_Node := P_Expression; + Check_Simple_Expression (Expr_Node); + Set_High_Bound (Constr_Node, Expr_Node); + Append (Constr_Node, Constr_List); + goto Loop_Continue; + + -- Case of an expression which could be either form + + else + Append (Expr_Node, Constr_List); + goto Loop_Continue; + end if; + + -- Here with a single entry scanned + + <> + exit when not Comma_Present; + + end loop; + + T_Right_Paren; + return Result_Node; + end P_Index_Or_Discriminant_Constraint; + + ------------------------------------- + -- 3.7.1 Discriminant Association -- + ------------------------------------- + + -- DISCRIMINANT_ASSOCIATION ::= + -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>] + -- EXPRESSION + + -- This routine is used only when the name list is present and the caller + -- has already checked this (by scanning ahead and repositioning the + -- scan). + + -- Error_Recovery: cannot raise Error_Resync; + + function P_Discriminant_Association return Node_Id is + Discr_Node : Node_Id; + Names_List : List_Id; + Ident_Sloc : Source_Ptr; + + begin + Ident_Sloc := Token_Ptr; + Names_List := New_List; + + loop + Append (P_Identifier (C_Vertical_Bar_Arrow), Names_List); + exit when Token /= Tok_Vertical_Bar; + Scan; -- past | + end loop; + + Discr_Node := New_Node (N_Discriminant_Association, Ident_Sloc); + Set_Selector_Names (Discr_Node, Names_List); + TF_Arrow; + Set_Expression (Discr_Node, P_Expression); + return Discr_Node; + end P_Discriminant_Association; + + --------------------------------- + -- 3.8 Record Type Definition -- + --------------------------------- + + -- RECORD_TYPE_DEFINITION ::= + -- [[abstract] tagged] [limited] RECORD_DEFINITION + + -- There is no node in the tree for a record type definition. Instead + -- a record definition node appears, with possible Abstract_Present, + -- Tagged_Present, and Limited_Present flags set appropriately. + + ---------------------------- + -- 3.8 Record Definition -- + ---------------------------- + + -- RECORD_DEFINITION ::= + -- record + -- COMPONENT_LIST + -- end record + -- | null record + + -- Note: in the case where a record definition node is used to represent + -- a record type definition, the caller sets the Tagged_Present and + -- Limited_Present flags in the resulting N_Record_Definition node as + -- required. + + -- Note that the RECORD token at the start may be missing in certain + -- error situations, so this function is expected to post the error + + -- Error recovery: can raise Error_Resync + + function P_Record_Definition return Node_Id is + Rec_Node : Node_Id; + + begin + Rec_Node := New_Node (N_Record_Definition, Token_Ptr); + + -- Null record case + + if Token = Tok_Null then + Scan; -- past NULL + T_Record; + Set_Null_Present (Rec_Node, True); + + -- Catch incomplete declaration to prevent cascaded errors, see + -- ACATS B393002 for an example. + + elsif Token = Tok_Semicolon then + Error_Msg_AP ("missing record definition"); + + -- Case starting with RECORD keyword. Build scope stack entry. For the + -- column, we use the first non-blank character on the line, to deal + -- with situations such as: + + -- type X is record + -- ... + -- end record; + + -- which is not official RM indentation, but is not uncommon usage, and + -- in particular is standard GNAT coding style, so handle it nicely. + + else + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Record; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Labl := Error; + Scope.Table (Scope.Last).Junk := (Token /= Tok_Record); + + T_Record; + + Set_Component_List (Rec_Node, P_Component_List); + + loop + exit when Check_End; + Discard_Junk_Node (P_Component_List); + end loop; + end if; + + return Rec_Node; + end P_Record_Definition; + + ------------------------- + -- 3.8 Component List -- + ------------------------- + + -- COMPONENT_LIST ::= + -- COMPONENT_ITEM {COMPONENT_ITEM} + -- | {COMPONENT_ITEM} VARIANT_PART + -- | null; + + -- Error recovery: cannot raise Error_Resync + + function P_Component_List return Node_Id is + Component_List_Node : Node_Id; + Decls_List : List_Id; + Scan_State : Saved_Scan_State; + + begin + Component_List_Node := New_Node (N_Component_List, Token_Ptr); + Decls_List := New_List; + + if Token = Tok_Null then + Scan; -- past NULL + TF_Semicolon; + P_Pragmas_Opt (Decls_List); + Set_Null_Present (Component_List_Node, True); + return Component_List_Node; + + else + P_Pragmas_Opt (Decls_List); + + if Token /= Tok_Case then + Component_Scan_Loop : loop + P_Component_Items (Decls_List); + P_Pragmas_Opt (Decls_List); + + exit Component_Scan_Loop when Token = Tok_End + or else Token = Tok_Case + or else Token = Tok_When; + + -- We are done if we do not have an identifier. However, if + -- we have a misspelled reserved identifier that is in a column + -- to the right of the record definition, we will treat it as + -- an identifier. It turns out to be too dangerous in practice + -- to accept such a mis-spelled identifier which does not have + -- this additional clue that confirms the incorrect spelling. + + if Token /= Tok_Identifier then + if Start_Column > Scope.Table (Scope.Last).Ecol + and then Is_Reserved_Identifier + then + Save_Scan_State (Scan_State); -- at reserved id + Scan; -- possible reserved id + + if Token = Tok_Comma or else Token = Tok_Colon then + Restore_Scan_State (Scan_State); + Scan_Reserved_Identifier (Force_Msg => True); + + -- Note reserved identifier used as field name after + -- all because not followed by colon or comma + + else + Restore_Scan_State (Scan_State); + exit Component_Scan_Loop; + end if; + + -- Non-identifier that definitely was not reserved id + + else + exit Component_Scan_Loop; + end if; + end if; + end loop Component_Scan_Loop; + end if; + + if Token = Tok_Case then + Set_Variant_Part (Component_List_Node, P_Variant_Part); + + -- Check for junk after variant part + + if Token = Tok_Identifier then + Save_Scan_State (Scan_State); + Scan; -- past identifier + + if Token = Tok_Colon then + Restore_Scan_State (Scan_State); + Error_Msg_SC ("component may not follow variant part"); + Discard_Junk_Node (P_Component_List); + + elsif Token = Tok_Case then + Restore_Scan_State (Scan_State); + Error_Msg_SC ("only one variant part allowed in a record"); + Discard_Junk_Node (P_Component_List); + + else + Restore_Scan_State (Scan_State); + end if; + end if; + end if; + end if; + + Set_Component_Items (Component_List_Node, Decls_List); + return Component_List_Node; + end P_Component_List; + + ------------------------- + -- 3.8 Component Item -- + ------------------------- + + -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE + + -- COMPONENT_DECLARATION ::= + -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION + -- [:= DEFAULT_EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; + + -- COMPONENT_DEFINITION ::= + -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION + + -- Error recovery: cannot raise Error_Resync, if an error occurs, + -- the scan is positioned past the following semicolon. + + -- Note: we do not yet allow representation clauses to appear as component + -- items, do we need to add this capability sometime in the future ??? + + procedure P_Component_Items (Decls : List_Id) is + Aliased_Present : Boolean := False; + CompDef_Node : Node_Id; + Decl_Node : Node_Id; + Scan_State : Saved_Scan_State; + Not_Null_Present : Boolean := False; + Num_Idents : Nat; + Ident : Nat; + Ident_Sloc : Source_Ptr; + + Idents : array (Int range 1 .. 4096) of Entity_Id; + -- This array holds the list of defining identifiers. The upper bound + -- of 4096 is intended to be essentially infinite, and we do not even + -- bother to check for it being exceeded. + + begin + if Token /= Tok_Identifier then + Error_Msg_SC ("component declaration expected"); + Resync_Past_Semicolon; + return; + end if; + + Ident_Sloc := Token_Ptr; + Idents (1) := P_Defining_Identifier (C_Comma_Colon); + Num_Idents := 1; + + while Comma_Present loop + Num_Idents := Num_Idents + 1; + Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon); + end loop; + + -- If there are multiple identifiers, we repeatedly scan the + -- type and initialization expression information by resetting + -- the scan pointer (so that we get completely separate trees + -- for each occurrence). + + if Num_Idents > 1 then + Save_Scan_State (Scan_State); + end if; + + T_Colon; + + -- Loop through defining identifiers in list + + Ident := 1; + Ident_Loop : loop + + -- The following block is present to catch Error_Resync + -- which causes the parse to be reset past the semicolon + + begin + Decl_Node := New_Node (N_Component_Declaration, Ident_Sloc); + Set_Defining_Identifier (Decl_Node, Idents (Ident)); + + if Token = Tok_Constant then + Error_Msg_SC ("constant components are not permitted"); + Scan; + end if; + + CompDef_Node := New_Node (N_Component_Definition, Token_Ptr); + + if Token_Name = Name_Aliased then + Check_95_Keyword (Tok_Aliased, Tok_Identifier); + end if; + + if Token = Tok_Aliased then + Aliased_Present := True; + Scan; -- past ALIASED + end if; + + Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254) + + -- Ada 2005 (AI-230): Access Definition case + + if Token = Tok_Access then + if Ada_Version < Ada_2005 then + Error_Msg_SP + ("generalized use of anonymous access types " & + "is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + end if; + + if Aliased_Present then + Error_Msg_SP ("ALIASED not allowed here"); + end if; + + Set_Subtype_Indication (CompDef_Node, Empty); + Set_Aliased_Present (CompDef_Node, False); + Set_Access_Definition (CompDef_Node, + P_Access_Definition (Not_Null_Present)); + else + + Set_Access_Definition (CompDef_Node, Empty); + Set_Aliased_Present (CompDef_Node, Aliased_Present); + Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present); + + if Token = Tok_Array then + Error_Msg_SC ("anonymous arrays not allowed as components"); + raise Error_Resync; + end if; + + Set_Subtype_Indication (CompDef_Node, + P_Subtype_Indication (Not_Null_Present)); + end if; + + Set_Component_Definition (Decl_Node, CompDef_Node); + Set_Expression (Decl_Node, Init_Expr_Opt); + + if Ident > 1 then + Set_Prev_Ids (Decl_Node, True); + end if; + + if Ident < Num_Idents then + Set_More_Ids (Decl_Node, True); + end if; + + Append (Decl_Node, Decls); + + exception + when Error_Resync => + if Token /= Tok_End then + Resync_Past_Semicolon; + end if; + end; + + exit Ident_Loop when Ident = Num_Idents; + Ident := Ident + 1; + Restore_Scan_State (Scan_State); + T_Colon; + end loop Ident_Loop; + + P_Aspect_Specifications (Decl_Node); + end P_Component_Items; + + -------------------------------- + -- 3.8 Component Declaration -- + -------------------------------- + + -- Parsed by P_Component_Items (3.8) + + ------------------------- + -- 3.8.1 Variant Part -- + ------------------------- + + -- VARIANT_PART ::= + -- case discriminant_DIRECT_NAME is + -- VARIANT + -- {VARIANT} + -- end case; + + -- The caller has checked that the initial token is CASE + + -- Error recovery: cannot raise Error_Resync + + function P_Variant_Part return Node_Id is + Variant_Part_Node : Node_Id; + Variants_List : List_Id; + Case_Node : Node_Id; + + begin + Variant_Part_Node := New_Node (N_Variant_Part, Token_Ptr); + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Case; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Ecol := Start_Column; + + Scan; -- past CASE + Case_Node := P_Expression; + Set_Name (Variant_Part_Node, Case_Node); + + if Nkind (Case_Node) /= N_Identifier then + Set_Name (Variant_Part_Node, Error); + Error_Msg ("discriminant name expected", Sloc (Case_Node)); + + elsif Paren_Count (Case_Node) /= 0 then + Error_Msg + ("|discriminant name may not be parenthesized", + Sloc (Case_Node)); + Set_Paren_Count (Case_Node, 0); + end if; + + TF_Is; + Variants_List := New_List; + P_Pragmas_Opt (Variants_List); + + -- Test missing variant + + if Token = Tok_End then + Error_Msg_BC ("WHEN expected (must have at least one variant)"); + else + Append (P_Variant, Variants_List); + end if; + + -- Loop through variants, note that we allow if in place of when, + -- this error will be detected and handled in P_Variant. + + loop + P_Pragmas_Opt (Variants_List); + + if Token /= Tok_When + and then Token /= Tok_If + and then Token /= Tok_Others + then + exit when Check_End; + end if; + + Append (P_Variant, Variants_List); + end loop; + + Set_Variants (Variant_Part_Node, Variants_List); + return Variant_Part_Node; + end P_Variant_Part; + + -------------------- + -- 3.8.1 Variant -- + -------------------- + + -- VARIANT ::= + -- when DISCRETE_CHOICE_LIST => + -- COMPONENT_LIST + + -- Error recovery: cannot raise Error_Resync + + -- The initial token on entry is either WHEN, IF or OTHERS + + function P_Variant return Node_Id is + Variant_Node : Node_Id; + + begin + -- Special check to recover nicely from use of IF in place of WHEN + + if Token = Tok_If then + T_When; + Scan; -- past IF + else + T_When; + end if; + + Variant_Node := New_Node (N_Variant, Prev_Token_Ptr); + Set_Discrete_Choices (Variant_Node, P_Discrete_Choice_List); + TF_Arrow; + Set_Component_List (Variant_Node, P_Component_List); + return Variant_Node; + end P_Variant; + + --------------------------------- + -- 3.8.1 Discrete Choice List -- + --------------------------------- + + -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE} + + -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others + + -- Note: in Ada 83, the expression must be a simple expression + + -- Error recovery: cannot raise Error_Resync + + function P_Discrete_Choice_List return List_Id is + Choices : List_Id; + Expr_Node : Node_Id; + Choice_Node : Node_Id; + + begin + Choices := New_List; + loop + if Token = Tok_Others then + Append (New_Node (N_Others_Choice, Token_Ptr), Choices); + Scan; -- past OTHERS + + else + begin + -- Scan out expression or range attribute + + Expr_Node := P_Expression_Or_Range_Attribute; + Ignore (Tok_Right_Paren); + + if Token = Tok_Colon + and then Nkind (Expr_Node) = N_Identifier + then + Error_Msg_SP ("label not permitted in this context"); + Scan; -- past colon + + -- Range attribute + + elsif Expr_Form = EF_Range_Attr then + Append (Expr_Node, Choices); + + -- Explicit range + + elsif Token = Tok_Dot_Dot then + Check_Simple_Expression (Expr_Node); + Choice_Node := New_Node (N_Range, Token_Ptr); + Set_Low_Bound (Choice_Node, Expr_Node); + Scan; -- past .. + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression (Expr_Node); + Set_High_Bound (Choice_Node, Expr_Node); + Append (Choice_Node, Choices); + + -- Simple name, must be subtype, so range allowed + + elsif Expr_Form = EF_Simple_Name then + if Token = Tok_Range then + Append (P_Subtype_Indication (Expr_Node), Choices); + + elsif Token in Token_Class_Consk then + Error_Msg_SC + ("the only constraint allowed here " & + "is a range constraint"); + Discard_Junk_Node (P_Constraint_Opt); + Append (Expr_Node, Choices); + + else + Append (Expr_Node, Choices); + end if; + + -- Expression + + else + -- In Ada 2012 mode, the expression must be a simple + -- expression. The reason for this restriction (i.e. going + -- back to the Ada 83 rule) is to avoid ambiguities when set + -- membership operations are allowed, consider the + -- following: + + -- when A in 1 .. 10 | 12 => + + -- This is ambiguous without parentheses, so we require one + -- of the following two parenthesized forms to disambiguate: + + -- one of the following: + + -- when (A in 1 .. 10 | 12) => + -- when (A in 1 .. 10) | 12 => + + -- To solve this, in Ada 2012 mode, we disallow the use of + -- membership operations in expressions in choices. + + -- Technically in the grammar, the expression must match the + -- grammar for restricted expression. + + if Ada_Version >= Ada_2012 then + Check_Restricted_Expression (Expr_Node); + + -- In Ada 83 mode, the syntax required a simple expression + + else + Check_Simple_Expression_In_Ada_83 (Expr_Node); + end if; + + Append (Expr_Node, Choices); + end if; + + exception + when Error_Resync => + Resync_Choice; + return Error_List; + end; + end if; + + if Token = Tok_Comma then + Error_Msg_SC -- CODEFIX + (""","" should be ""'|"""); + else + exit when Token /= Tok_Vertical_Bar; + end if; + + Scan; -- past | or comma + end loop; + + return Choices; + end P_Discrete_Choice_List; + + ---------------------------- + -- 3.8.1 Discrete Choice -- + ---------------------------- + + -- Parsed by P_Discrete_Choice_List (3.8.1) + + ---------------------------------- + -- 3.9.1 Record Extension Part -- + ---------------------------------- + + -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION + + -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4) + + -------------------------------------- + -- 3.9.4 Interface Type Definition -- + -------------------------------------- + + -- INTERFACE_TYPE_DEFINITION ::= + -- [limited | task | protected | synchronized] interface + -- [and INTERFACE_LIST] + + -- Error recovery: cannot raise Error_Resync + + function P_Interface_Type_Definition + (Abstract_Present : Boolean) return Node_Id + is + Typedef_Node : Node_Id; + + begin + if Ada_Version < Ada_2005 then + Error_Msg_SP ("abstract interface is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + end if; + + if Abstract_Present then + Error_Msg_SP + ("ABSTRACT not allowed in interface type definition " & + "(RM 3.9.4(2/2))"); + end if; + + Scan; -- past INTERFACE + + -- Ada 2005 (AI-345): In case of interfaces with a null list of + -- interfaces we build a record_definition node. + + if Token = Tok_Semicolon or else Aspect_Specifications_Present then + Typedef_Node := New_Node (N_Record_Definition, Token_Ptr); + + Set_Abstract_Present (Typedef_Node); + Set_Tagged_Present (Typedef_Node); + Set_Null_Present (Typedef_Node); + Set_Interface_Present (Typedef_Node); + + -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have + -- a list of interfaces we build a derived_type_definition node. This + -- simplifies the semantic analysis (and hence further maintenance) + + else + if Token /= Tok_And then + Error_Msg_AP ("AND expected"); + else + Scan; -- past AND + end if; + + Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr); + + Set_Abstract_Present (Typedef_Node); + Set_Interface_Present (Typedef_Node); + Set_Subtype_Indication (Typedef_Node, P_Qualified_Simple_Name); + + Set_Record_Extension_Part (Typedef_Node, + New_Node (N_Record_Definition, Token_Ptr)); + Set_Null_Present (Record_Extension_Part (Typedef_Node)); + + if Token = Tok_And then + Set_Interface_List (Typedef_Node, New_List); + Scan; -- past AND + + loop + Append (P_Qualified_Simple_Name, + Interface_List (Typedef_Node)); + exit when Token /= Tok_And; + Scan; -- past AND + end loop; + end if; + end if; + + return Typedef_Node; + end P_Interface_Type_Definition; + + ---------------------------------- + -- 3.10 Access Type Definition -- + ---------------------------------- + + -- ACCESS_TYPE_DEFINITION ::= + -- ACCESS_TO_OBJECT_DEFINITION + -- | ACCESS_TO_SUBPROGRAM_DEFINITION + + -- ACCESS_TO_OBJECT_DEFINITION ::= + -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION + + -- GENERAL_ACCESS_MODIFIER ::= all | constant + + -- ACCESS_TO_SUBPROGRAM_DEFINITION + -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE + -- | [NULL_EXCLUSION] access [protected] function + -- PARAMETER_AND_RESULT_PROFILE + + -- PARAMETER_PROFILE ::= [FORMAL_PART] + + -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK + + -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already + -- parsed the null_exclusion part and has also removed the ACCESS token; + -- otherwise the caller has just checked that the initial token is ACCESS + + -- Error recovery: can raise Error_Resync + + function P_Access_Type_Definition + (Header_Already_Parsed : Boolean := False) return Node_Id + is + Access_Loc : constant Source_Ptr := Token_Ptr; + Prot_Flag : Boolean; + Not_Null_Present : Boolean := False; + Type_Def_Node : Node_Id; + Result_Not_Null : Boolean; + Result_Node : Node_Id; + + procedure Check_Junk_Subprogram_Name; + -- Used in access to subprogram definition cases to check for an + -- identifier or operator symbol that does not belong. + + -------------------------------- + -- Check_Junk_Subprogram_Name -- + -------------------------------- + + procedure Check_Junk_Subprogram_Name is + Saved_State : Saved_Scan_State; + + begin + if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then + Save_Scan_State (Saved_State); + Scan; -- past possible junk subprogram name + + if Token = Tok_Left_Paren or else Token = Tok_Semicolon then + Error_Msg_SP ("unexpected subprogram name ignored"); + return; + + else + Restore_Scan_State (Saved_State); + end if; + end if; + end Check_Junk_Subprogram_Name; + + -- Start of processing for P_Access_Type_Definition + + begin + if not Header_Already_Parsed then + Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) + Scan; -- past ACCESS + end if; + + if Token_Name = Name_Protected then + Check_95_Keyword (Tok_Protected, Tok_Procedure); + Check_95_Keyword (Tok_Protected, Tok_Function); + end if; + + Prot_Flag := (Token = Tok_Protected); + + if Prot_Flag then + Scan; -- past PROTECTED + + if Token /= Tok_Procedure and then Token /= Tok_Function then + Error_Msg_SC -- CODEFIX + ("FUNCTION or PROCEDURE expected"); + end if; + end if; + + if Token = Tok_Procedure then + if Ada_Version = Ada_83 then + Error_Msg_SC ("(Ada 83) access to procedure not allowed!"); + end if; + + Type_Def_Node := New_Node (N_Access_Procedure_Definition, Access_Loc); + Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present); + Scan; -- past PROCEDURE + Check_Junk_Subprogram_Name; + Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile); + Set_Protected_Present (Type_Def_Node, Prot_Flag); + + elsif Token = Tok_Function then + if Ada_Version = Ada_83 then + Error_Msg_SC ("(Ada 83) access to function not allowed!"); + end if; + + Type_Def_Node := New_Node (N_Access_Function_Definition, Access_Loc); + Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present); + Scan; -- past FUNCTION + Check_Junk_Subprogram_Name; + Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile); + Set_Protected_Present (Type_Def_Node, Prot_Flag); + TF_Return; + + Result_Not_Null := P_Null_Exclusion; -- Ada 2005 (AI-231) + + -- Ada 2005 (AI-318-02) + + if Token = Tok_Access then + if Ada_Version < Ada_2005 then + Error_Msg_SC + ("anonymous access result type is an Ada 2005 extension"); + Error_Msg_SC ("\unit must be compiled with -gnat05 switch"); + end if; + + Result_Node := P_Access_Definition (Result_Not_Null); + + else + Result_Node := P_Subtype_Mark; + No_Constraint; + + -- A null exclusion on the result type must be recorded in a flag + -- distinct from the one used for the access-to-subprogram type's + -- null exclusion. + + Set_Null_Exclusion_In_Return_Present + (Type_Def_Node, Result_Not_Null); + end if; + + Set_Result_Definition (Type_Def_Node, Result_Node); + + else + Type_Def_Node := + New_Node (N_Access_To_Object_Definition, Access_Loc); + Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present); + + if Token = Tok_All or else Token = Tok_Constant then + if Ada_Version = Ada_83 then + Error_Msg_SC ("(Ada 83) access modifier not allowed!"); + end if; + + if Token = Tok_All then + Set_All_Present (Type_Def_Node, True); + + else + Set_Constant_Present (Type_Def_Node, True); + end if; + + Scan; -- past ALL or CONSTANT + end if; + + Set_Subtype_Indication (Type_Def_Node, + P_Subtype_Indication (Not_Null_Present)); + end if; + + return Type_Def_Node; + end P_Access_Type_Definition; + + --------------------------------------- + -- 3.10 Access To Object Definition -- + --------------------------------------- + + -- Parsed by P_Access_Type_Definition (3.10) + + ----------------------------------- + -- 3.10 General Access Modifier -- + ----------------------------------- + + -- Parsed by P_Access_Type_Definition (3.10) + + ------------------------------------------- + -- 3.10 Access To Subprogram Definition -- + ------------------------------------------- + + -- Parsed by P_Access_Type_Definition (3.10) + + ----------------------------- + -- 3.10 Access Definition -- + ----------------------------- + + -- ACCESS_DEFINITION ::= + -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK + -- | ACCESS_TO_SUBPROGRAM_DEFINITION + -- + -- ACCESS_TO_SUBPROGRAM_DEFINITION + -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE + -- | [NULL_EXCLUSION] access [protected] function + -- PARAMETER_AND_RESULT_PROFILE + + -- The caller has parsed the null-exclusion part and it has also checked + -- that the next token is ACCESS + + -- Error recovery: cannot raise Error_Resync + + function P_Access_Definition + (Null_Exclusion_Present : Boolean) return Node_Id + is + Def_Node : Node_Id; + Subp_Node : Node_Id; + + begin + Def_Node := New_Node (N_Access_Definition, Token_Ptr); + Scan; -- past ACCESS + + -- Ada 2005 (AI-254): Access_To_Subprogram_Definition + + if Token = Tok_Protected + or else Token = Tok_Procedure + or else Token = Tok_Function + then + if Ada_Version < Ada_2005 then + Error_Msg_SP ("access-to-subprogram is an Ada 2005 extension"); + Error_Msg_SP ("\unit should be compiled with -gnat05 switch"); + end if; + + Subp_Node := P_Access_Type_Definition (Header_Already_Parsed => True); + Set_Null_Exclusion_Present (Subp_Node, Null_Exclusion_Present); + Set_Access_To_Subprogram_Definition (Def_Node, Subp_Node); + + -- Ada 2005 (AI-231) + -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK + + else + Set_Null_Exclusion_Present (Def_Node, Null_Exclusion_Present); + + if Token = Tok_All then + if Ada_Version < Ada_2005 then + Error_Msg_SP + ("ALL is not permitted for anonymous access types"); + end if; + + Scan; -- past ALL + Set_All_Present (Def_Node); + + elsif Token = Tok_Constant then + if Ada_Version < Ada_2005 then + Error_Msg_SP ("access-to-constant is an Ada 2005 extension"); + Error_Msg_SP ("\unit should be compiled with -gnat05 switch"); + end if; + + Scan; -- past CONSTANT + Set_Constant_Present (Def_Node); + end if; + + Set_Subtype_Mark (Def_Node, P_Subtype_Mark); + No_Constraint; + end if; + + return Def_Node; + end P_Access_Definition; + + ----------------------------------------- + -- 3.10.1 Incomplete Type Declaration -- + ----------------------------------------- + + -- Parsed by P_Type_Declaration (3.2.1) + + ---------------------------- + -- 3.11 Declarative Part -- + ---------------------------- + + -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM} + + -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items + -- handles errors, and returns cleanly after an error has occurred) + + function P_Declarative_Part return List_Id is + Decls : List_Id; + Done : Boolean; + + begin + -- Indicate no bad declarations detected yet. This will be reset by + -- P_Declarative_Items if a bad declaration is discovered. + + Missing_Begin_Msg := No_Error_Msg; + + -- Get rid of active SIS entry from outer scope. This means we will + -- miss some nested cases, but it doesn't seem worth the effort. See + -- discussion in Par for further details + + SIS_Entry_Active := False; + Decls := New_List; + + -- Loop to scan out the declarations + + loop + P_Declarative_Items (Decls, Done, In_Spec => False); + exit when Done; + end loop; + + -- Get rid of active SIS entry which is left set only if we scanned a + -- procedure declaration and have not found the body. We could give + -- an error message, but that really would be usurping the role of + -- semantic analysis (this really is a missing body case). + + SIS_Entry_Active := False; + return Decls; + end P_Declarative_Part; + + ---------------------------- + -- 3.11 Declarative Item -- + ---------------------------- + + -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY + + -- Can return Error if a junk declaration is found, or Empty if no + -- declaration is found (i.e. a token ending declarations, such as + -- BEGIN or END is encountered). + + -- Error recovery: cannot raise Error_Resync. If an error resync occurs, + -- then the scan is set past the next semicolon and Error is returned. + + procedure P_Declarative_Items + (Decls : List_Id; + Done : out Boolean; + In_Spec : Boolean) + is + Scan_State : Saved_Scan_State; + + begin + if Style_Check then + Style.Check_Indentation; + end if; + + case Token is + + when Tok_Function => + Check_Bad_Layout; + Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); + Done := False; + + when Tok_For => + Check_Bad_Layout; + + -- Check for loop (premature statement) + + Save_Scan_State (Scan_State); + Scan; -- past FOR + + if Token = Tok_Identifier then + Scan; -- past identifier + + if Token = Tok_In then + Restore_Scan_State (Scan_State); + Statement_When_Declaration_Expected (Decls, Done, In_Spec); + return; + end if; + end if; + + -- Not a loop, so must be rep clause + + Restore_Scan_State (Scan_State); + Append (P_Representation_Clause, Decls); + Done := False; + + when Tok_Generic => + Check_Bad_Layout; + Append (P_Generic, Decls); + Done := False; + + when Tok_Identifier => + Check_Bad_Layout; + + -- Special check for misuse of overriding not in Ada 2005 mode + + if Token_Name = Name_Overriding + and then not Next_Token_Is (Tok_Colon) + then + Error_Msg_SC ("overriding indicator is an Ada 2005 extension"); + Error_Msg_SC ("\unit must be compiled with -gnat05 switch"); + + Token := Tok_Overriding; + Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); + Done := False; + + -- Normal case, no overriding, or overriding followed by colon + + else + P_Identifier_Declarations (Decls, Done, In_Spec); + end if; + + -- Ada2005: A subprogram declaration can start with "not" or + -- "overriding". In older versions, "overriding" is handled + -- like an identifier, with the appropriate messages. + + when Tok_Not => + Check_Bad_Layout; + Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); + Done := False; + + when Tok_Overriding => + Check_Bad_Layout; + Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); + Done := False; + + when Tok_Package => + Check_Bad_Layout; + Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); + Done := False; + + when Tok_Pragma => + Append (P_Pragma, Decls); + Done := False; + + when Tok_Procedure => + Check_Bad_Layout; + Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); + Done := False; + + when Tok_Protected => + Check_Bad_Layout; + Scan; -- past PROTECTED + Append (P_Protected, Decls); + Done := False; + + when Tok_Subtype => + Check_Bad_Layout; + Append (P_Subtype_Declaration, Decls); + Done := False; + + when Tok_Task => + Check_Bad_Layout; + Scan; -- past TASK + Append (P_Task, Decls); + Done := False; + + when Tok_Type => + Check_Bad_Layout; + Append (P_Type_Declaration, Decls); + Done := False; + + when Tok_Use => + Check_Bad_Layout; + Append (P_Use_Clause, Decls); + Done := False; + + when Tok_With => + Check_Bad_Layout; + Error_Msg_SC ("WITH can only appear in context clause"); + raise Error_Resync; + + -- BEGIN terminates the scan of a sequence of declarations unless + -- there is a missing subprogram body, see section on handling + -- semicolon in place of IS. We only treat the begin as satisfying + -- the subprogram declaration if it falls in the expected column + -- or to its right. + + when Tok_Begin => + if SIS_Entry_Active and then Start_Column >= SIS_Ecol then + + -- Here we have the case where a BEGIN is encountered during + -- declarations in a declarative part, or at the outer level, + -- and there is a subprogram declaration outstanding for which + -- no body has been supplied. This is the case where we assume + -- that the semicolon in the subprogram declaration should + -- really have been is. The active SIS entry describes the + -- subprogram declaration. On return the declaration has been + -- modified to become a body. + + declare + Specification_Node : Node_Id; + Decl_Node : Node_Id; + Body_Node : Node_Id; + + begin + -- First issue the error message. If we had a missing + -- semicolon in the declaration, then change the message + -- to + + if SIS_Missing_Semicolon_Message /= No_Error_Msg then + Change_Error_Text -- Replace: "missing "";"" " + (SIS_Missing_Semicolon_Message, "missing ""is"""); + + -- Otherwise we saved the semicolon position, so complain + + else + Error_Msg -- CODEFIX + ("|"";"" should be IS", SIS_Semicolon_Sloc); + end if; + + -- The next job is to fix up any declarations that occurred + -- between the procedure header and the BEGIN. These got + -- chained to the outer declarative region (immediately + -- after the procedure declaration) and they should be + -- chained to the subprogram itself, which is a body + -- rather than a spec. + + Specification_Node := Specification (SIS_Declaration_Node); + Change_Node (SIS_Declaration_Node, N_Subprogram_Body); + Body_Node := SIS_Declaration_Node; + Set_Specification (Body_Node, Specification_Node); + Set_Declarations (Body_Node, New_List); + + loop + Decl_Node := Remove_Next (Body_Node); + exit when Decl_Node = Empty; + Append (Decl_Node, Declarations (Body_Node)); + end loop; + + -- Now make the scope table entry for the Begin-End and + -- scan it out + + Push_Scope_Stack; + Scope.Table (Scope.Last).Sloc := SIS_Sloc; + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Ecol := SIS_Ecol; + Scope.Table (Scope.Last).Labl := SIS_Labl; + Scope.Table (Scope.Last).Lreq := False; + SIS_Entry_Active := False; + Scan; -- past BEGIN + Set_Handled_Statement_Sequence (Body_Node, + P_Handled_Sequence_Of_Statements); + End_Statements (Handled_Statement_Sequence (Body_Node)); + end; + + Done := False; + + else + Done := True; + end if; + + -- Normally an END terminates the scan for basic declarative items. + -- The one exception is END RECORD, which is probably left over from + -- some other junk. + + when Tok_End => + Save_Scan_State (Scan_State); -- at END + Scan; -- past END + + if Token = Tok_Record then + Error_Msg_SP ("no RECORD for this `end record`!"); + Scan; -- past RECORD + TF_Semicolon; + + else + Restore_Scan_State (Scan_State); -- to END + Done := True; + end if; + + -- The following tokens which can only be the start of a statement + -- are considered to end a declarative part (i.e. we have a missing + -- BEGIN situation). We are fairly conservative in making this + -- judgment, because it is a real mess to go into statement mode + -- prematurely in response to a junk declaration. + + when Tok_Abort | + Tok_Accept | + Tok_Declare | + Tok_Delay | + Tok_Exit | + Tok_Goto | + Tok_If | + Tok_Loop | + Tok_Null | + Tok_Requeue | + Tok_Select | + Tok_While => + + -- But before we decide that it's a statement, let's check for + -- a reserved word misused as an identifier. + + if Is_Reserved_Identifier then + Save_Scan_State (Scan_State); + Scan; -- past the token + + -- If reserved identifier not followed by colon or comma, then + -- this is most likely an assignment statement to the bad id. + + if Token /= Tok_Colon and then Token /= Tok_Comma then + Restore_Scan_State (Scan_State); + Statement_When_Declaration_Expected (Decls, Done, In_Spec); + return; + + -- Otherwise we have a declaration of the bad id + + else + Restore_Scan_State (Scan_State); + Scan_Reserved_Identifier (Force_Msg => True); + P_Identifier_Declarations (Decls, Done, In_Spec); + end if; + + -- If not reserved identifier, then it's definitely a statement + + else + Statement_When_Declaration_Expected (Decls, Done, In_Spec); + return; + end if; + + -- The token RETURN may well also signal a missing BEGIN situation, + -- however, we never let it end the declarative part, because it may + -- also be part of a half-baked function declaration. + + when Tok_Return => + Error_Msg_SC ("misplaced RETURN statement"); + raise Error_Resync; + + -- PRIVATE definitely terminates the declarations in a spec, + -- and is an error in a body. + + when Tok_Private => + if In_Spec then + Done := True; + else + Error_Msg_SC ("PRIVATE not allowed in body"); + Scan; -- past PRIVATE + end if; + + -- An end of file definitely terminates the declarations! + + when Tok_EOF => + Done := True; + + -- The remaining tokens do not end the scan, but cannot start a + -- valid declaration, so we signal an error and resynchronize. + -- But first check for misuse of a reserved identifier. + + when others => + + -- Here we check for a reserved identifier + + if Is_Reserved_Identifier then + Save_Scan_State (Scan_State); + Scan; -- past the token + + if Token /= Tok_Colon and then Token /= Tok_Comma then + Restore_Scan_State (Scan_State); + Set_Declaration_Expected; + raise Error_Resync; + else + Restore_Scan_State (Scan_State); + Scan_Reserved_Identifier (Force_Msg => True); + Check_Bad_Layout; + P_Identifier_Declarations (Decls, Done, In_Spec); + end if; + + else + Set_Declaration_Expected; + raise Error_Resync; + end if; + end case; + + -- To resynchronize after an error, we scan to the next semicolon and + -- return with Done = False, indicating that there may still be more + -- valid declarations to come. + + exception + when Error_Resync => + Resync_Past_Semicolon; + Done := False; + end P_Declarative_Items; + + ---------------------------------- + -- 3.11 Basic Declarative Item -- + ---------------------------------- + + -- BASIC_DECLARATIVE_ITEM ::= + -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE + + -- Scan zero or more basic declarative items + + -- Error recovery: cannot raise Error_Resync. If an error is detected, then + -- the scan pointer is repositioned past the next semicolon, and the scan + -- for declarative items continues. + + function P_Basic_Declarative_Items return List_Id is + Decl : Node_Id; + Decls : List_Id; + Kind : Node_Kind; + Done : Boolean; + + begin + -- Indicate no bad declarations detected yet in the current context: + -- visible or private declarations of a package spec. + + Missing_Begin_Msg := No_Error_Msg; + + -- Get rid of active SIS entry from outer scope. This means we will + -- miss some nested cases, but it doesn't seem worth the effort. See + -- discussion in Par for further details + + SIS_Entry_Active := False; + + -- Loop to scan out declarations + + Decls := New_List; + + loop + P_Declarative_Items (Decls, Done, In_Spec => True); + exit when Done; + end loop; + + -- Get rid of active SIS entry. This is set only if we have scanned a + -- procedure declaration and have not found the body. We could give + -- an error message, but that really would be usurping the role of + -- semantic analysis (this really is a case of a missing body). + + SIS_Entry_Active := False; + + -- Test for assorted illegal declarations not diagnosed elsewhere + + Decl := First (Decls); + + while Present (Decl) loop + Kind := Nkind (Decl); + + -- Test for body scanned, not acceptable as basic decl item + + if Kind = N_Subprogram_Body or else + Kind = N_Package_Body or else + Kind = N_Task_Body or else + Kind = N_Protected_Body + then + Error_Msg ("proper body not allowed in package spec", Sloc (Decl)); + + -- Test for body stub scanned, not acceptable as basic decl item + + elsif Kind in N_Body_Stub then + Error_Msg ("body stub not allowed in package spec", Sloc (Decl)); + + elsif Kind = N_Assignment_Statement then + Error_Msg + ("assignment statement not allowed in package spec", + Sloc (Decl)); + end if; + + Next (Decl); + end loop; + + return Decls; + end P_Basic_Declarative_Items; + + ---------------- + -- 3.11 Body -- + ---------------- + + -- For proper body, see below + -- For body stub, see 10.1.3 + + ----------------------- + -- 3.11 Proper Body -- + ----------------------- + + -- Subprogram body is parsed by P_Subprogram (6.1) + -- Package body is parsed by P_Package (7.1) + -- Task body is parsed by P_Task (9.1) + -- Protected body is parsed by P_Protected (9.4) + + ------------------------------ + -- Set_Declaration_Expected -- + ------------------------------ + + procedure Set_Declaration_Expected is + begin + Error_Msg_SC ("declaration expected"); + + if Missing_Begin_Msg = No_Error_Msg then + Missing_Begin_Msg := Get_Msg_Id; + end if; + end Set_Declaration_Expected; + + ---------------------- + -- Skip_Declaration -- + ---------------------- + + procedure Skip_Declaration (S : List_Id) is + Dummy_Done : Boolean; + pragma Warnings (Off, Dummy_Done); + begin + P_Declarative_Items (S, Dummy_Done, False); + end Skip_Declaration; + + ----------------------------------------- + -- Statement_When_Declaration_Expected -- + ----------------------------------------- + + procedure Statement_When_Declaration_Expected + (Decls : List_Id; + Done : out Boolean; + In_Spec : Boolean) + is + begin + -- Case of second occurrence of statement in one declaration sequence + + if Missing_Begin_Msg /= No_Error_Msg then + + -- In the procedure spec case, just ignore it, we only give one + -- message for the first occurrence, since otherwise we may get + -- horrible cascading if BODY was missing in the header line. + + if In_Spec then + null; + + -- In the declarative part case, take a second statement as a sure + -- sign that we really have a missing BEGIN, and end the declarative + -- part now. Note that the caller will fix up the first message to + -- say "missing BEGIN" so that's how the error will be signalled. + + else + Done := True; + return; + end if; + + -- Case of first occurrence of unexpected statement + + else + -- If we are in a package spec, then give message of statement + -- not allowed in package spec. This message never gets changed. + + if In_Spec then + Error_Msg_SC ("statement not allowed in package spec"); + + -- If in declarative part, then we give the message complaining + -- about finding a statement when a declaration is expected. This + -- gets changed to a complaint about a missing BEGIN if we later + -- find that no BEGIN is present. + + else + Error_Msg_SC ("statement not allowed in declarative part"); + end if; + + -- Capture message Id. This is used for two purposes, first to + -- stop multiple messages, see test above, and second, to allow + -- the replacement of the message in the declarative part case. + + Missing_Begin_Msg := Get_Msg_Id; + end if; + + -- In all cases except the case in which we decided to terminate the + -- declaration sequence on a second error, we scan out the statement + -- and append it to the list of declarations (note that the semantics + -- can handle statements in a declaration list so if we proceed to + -- call the semantic phase, all will be (reasonably) well! + + Append_List_To (Decls, P_Sequence_Of_Statements (SS_Unco)); + + -- Done is set to False, since we want to continue the scan of + -- declarations, hoping that this statement was a temporary glitch. + -- If we indeed are now in the statement part (i.e. this was a missing + -- BEGIN, then it's not terrible, we will simply keep calling this + -- procedure to process the statements one by one, and then finally + -- hit the missing BEGIN, which will clean up the error message. + + Done := False; + end Statement_When_Declaration_Expected; + +end Ch3; diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb new file mode 100644 index 000000000..4c25c3ca6 --- /dev/null +++ b/gcc/ada/par-ch4.adb @@ -0,0 +1,3034 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 4 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +with Stringt; use Stringt; + +separate (Par) +package body Ch4 is + + -- Attributes that cannot have arguments + + Is_Parameterless_Attribute : constant Attribute_Class_Array := + (Attribute_Body_Version => True, + Attribute_External_Tag => True, + Attribute_Img => True, + Attribute_Version => True, + Attribute_Base => True, + Attribute_Class => True, + Attribute_Stub_Type => True, + Attribute_Type_Key => True, + others => False); + -- This map contains True for parameterless attributes that return a + -- string or a type. For those attributes, a left parenthesis after + -- the attribute should not be analyzed as the beginning of a parameters + -- list because it may denote a slice operation (X'Img (1 .. 2)) or + -- a type conversion (X'Class (Y)). + + -- Note that this map designates the minimum set of attributes where a + -- construct in parentheses that is not an argument can appear right + -- after the attribute. For attributes like 'Size, we do not put them + -- in the map. If someone writes X'Size (3), that's illegal in any case, + -- but we get a better error message by parsing the (3) as an illegal + -- argument to the attribute, rather than some meaningless junk that + -- follows the attribute. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function P_Aggregate_Or_Paren_Expr return Node_Id; + function P_Allocator return Node_Id; + function P_Case_Expression_Alternative return Node_Id; + function P_Record_Or_Array_Component_Association return Node_Id; + function P_Factor return Node_Id; + function P_Primary return Node_Id; + function P_Relation return Node_Id; + function P_Term return Node_Id; + + function P_Binary_Adding_Operator return Node_Kind; + function P_Logical_Operator return Node_Kind; + function P_Multiplying_Operator return Node_Kind; + function P_Relational_Operator return Node_Kind; + function P_Unary_Adding_Operator return Node_Kind; + + procedure Bad_Range_Attribute (Loc : Source_Ptr); + -- Called to place complaint about bad range attribute at the given + -- source location. Terminates by raising Error_Resync. + + procedure P_Membership_Test (N : Node_Id); + -- N is the node for a N_In or N_Not_In node whose right operand has not + -- yet been processed. It is called just after scanning out the IN keyword. + -- On return, either Right_Opnd or Alternatives is set, as appropriate. + + function P_Range_Attribute_Reference (Prefix_Node : Node_Id) return Node_Id; + -- Scan a range attribute reference. The caller has scanned out the + -- prefix. The current token is known to be an apostrophe and the + -- following token is known to be RANGE. + + ------------------------- + -- Bad_Range_Attribute -- + ------------------------- + + procedure Bad_Range_Attribute (Loc : Source_Ptr) is + begin + Error_Msg ("range attribute cannot be used in expression!", Loc); + Resync_Expression; + end Bad_Range_Attribute; + + -------------------------- + -- 4.1 Name (also 6.4) -- + -------------------------- + + -- NAME ::= + -- DIRECT_NAME | EXPLICIT_DEREFERENCE + -- | INDEXED_COMPONENT | SLICE + -- | SELECTED_COMPONENT | ATTRIBUTE + -- | TYPE_CONVERSION | FUNCTION_CALL + -- | CHARACTER_LITERAL + + -- DIRECT_NAME ::= IDENTIFIER | OPERATOR_SYMBOL + + -- PREFIX ::= NAME | IMPLICIT_DEREFERENCE + + -- EXPLICIT_DEREFERENCE ::= NAME . all + + -- IMPLICIT_DEREFERENCE ::= NAME + + -- INDEXED_COMPONENT ::= PREFIX (EXPRESSION {, EXPRESSION}) + + -- SLICE ::= PREFIX (DISCRETE_RANGE) + + -- SELECTED_COMPONENT ::= PREFIX . SELECTOR_NAME + + -- SELECTOR_NAME ::= IDENTIFIER | CHARACTER_LITERAL | OPERATOR_SYMBOL + + -- ATTRIBUTE_REFERENCE ::= PREFIX ' ATTRIBUTE_DESIGNATOR + + -- ATTRIBUTE_DESIGNATOR ::= + -- IDENTIFIER [(static_EXPRESSION)] + -- | access | delta | digits + + -- FUNCTION_CALL ::= + -- function_NAME + -- | function_PREFIX ACTUAL_PARAMETER_PART + + -- ACTUAL_PARAMETER_PART ::= + -- (PARAMETER_ASSOCIATION {,PARAMETER_ASSOCIATION}) + + -- PARAMETER_ASSOCIATION ::= + -- [formal_parameter_SELECTOR_NAME =>] EXPLICIT_ACTUAL_PARAMETER + + -- EXPLICIT_ACTUAL_PARAMETER ::= EXPRESSION | variable_NAME + + -- Note: syntactically a procedure call looks just like a function call, + -- so this routine is in practice used to scan out procedure calls as well. + + -- On return, Expr_Form is set to either EF_Name or EF_Simple_Name + + -- Error recovery: can raise Error_Resync + + -- Note: if on return Token = Tok_Apostrophe, then the apostrophe must be + -- followed by either a left paren (qualified expression case), or by + -- range (range attribute case). All other uses of apostrophe (i.e. all + -- other attributes) are handled in this routine. + + -- Error recovery: can raise Error_Resync + + function P_Name return Node_Id is + Scan_State : Saved_Scan_State; + Name_Node : Node_Id; + Prefix_Node : Node_Id; + Ident_Node : Node_Id; + Expr_Node : Node_Id; + Range_Node : Node_Id; + Arg_Node : Node_Id; + + Arg_List : List_Id := No_List; -- kill junk warning + Attr_Name : Name_Id := No_Name; -- kill junk warning + + begin + -- Case of not a name + + if Token not in Token_Class_Name then + + -- If it looks like start of expression, complain and scan expression + + if Token in Token_Class_Literal + or else Token = Tok_Left_Paren + then + Error_Msg_SC ("name expected"); + return P_Expression; + + -- Otherwise some other junk, not much we can do + + else + Error_Msg_AP ("name expected"); + raise Error_Resync; + end if; + end if; + + -- Loop through designators in qualified name + + Name_Node := Token_Node; + + loop + Scan; -- past designator + exit when Token /= Tok_Dot; + Save_Scan_State (Scan_State); -- at dot + Scan; -- past dot + + -- If we do not have another designator after the dot, then join + -- the normal circuit to handle a dot extension (may be .all or + -- character literal case). Otherwise loop back to scan the next + -- designator. + + if Token not in Token_Class_Desig then + goto Scan_Name_Extension_Dot; + else + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr); + Set_Prefix (Name_Node, Prefix_Node); + Set_Selector_Name (Name_Node, Token_Node); + end if; + end loop; + + -- We have now scanned out a qualified designator. If the last token is + -- an operator symbol, then we certainly do not have the Snam case, so + -- we can just use the normal name extension check circuit + + if Prev_Token = Tok_Operator_Symbol then + goto Scan_Name_Extension; + end if; + + -- We have scanned out a qualified simple name, check for name extension + -- Note that we know there is no dot here at this stage, so the only + -- possible cases of name extension are apostrophe and left paren. + + if Token = Tok_Apostrophe then + Save_Scan_State (Scan_State); -- at apostrophe + Scan; -- past apostrophe + + -- Qualified expression in Ada 2012 mode (treated as a name) + + if Ada_Version >= Ada_2012 and then Token = Tok_Left_Paren then + goto Scan_Name_Extension_Apostrophe; + + -- If left paren not in Ada 2012, then it is not part of the name, + -- since qualified expressions are not names in prior versions of + -- Ada, so return with Token backed up to point to the apostrophe. + -- The treatment for the range attribute is similar (we do not + -- consider x'range to be a name in this grammar). + + elsif Token = Tok_Left_Paren or else Token = Tok_Range then + Restore_Scan_State (Scan_State); -- to apostrophe + Expr_Form := EF_Simple_Name; + return Name_Node; + + -- Otherwise we have the case of a name extended by an attribute + + else + goto Scan_Name_Extension_Apostrophe; + end if; + + -- Check case of qualified simple name extended by a left parenthesis + + elsif Token = Tok_Left_Paren then + Scan; -- past left paren + goto Scan_Name_Extension_Left_Paren; + + -- Otherwise the qualified simple name is not extended, so return + + else + Expr_Form := EF_Simple_Name; + return Name_Node; + end if; + + -- Loop scanning past name extensions. A label is used for control + -- transfer for this loop for ease of interfacing with the finite state + -- machine in the parenthesis scanning circuit, and also to allow for + -- passing in control to the appropriate point from the above code. + + <> + + -- Character literal used as name cannot be extended. Also this + -- cannot be a call, since the name for a call must be a designator. + -- Return in these cases, or if there is no name extension + + if Token not in Token_Class_Namext + or else Prev_Token = Tok_Char_Literal + then + Expr_Form := EF_Name; + return Name_Node; + end if; + + -- Merge here when we know there is a name extension + + <> + + if Token = Tok_Left_Paren then + Scan; -- past left paren + goto Scan_Name_Extension_Left_Paren; + + elsif Token = Tok_Apostrophe then + Save_Scan_State (Scan_State); -- at apostrophe + Scan; -- past apostrophe + goto Scan_Name_Extension_Apostrophe; + + else -- Token = Tok_Dot + Save_Scan_State (Scan_State); -- at dot + Scan; -- past dot + goto Scan_Name_Extension_Dot; + end if; + + -- Case of name extended by dot (selection), dot is already skipped + -- and the scan state at the point of the dot is saved in Scan_State. + + <> + + -- Explicit dereference case + + if Token = Tok_All then + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Explicit_Dereference, Token_Ptr); + Set_Prefix (Name_Node, Prefix_Node); + Scan; -- past ALL + goto Scan_Name_Extension; + + -- Selected component case + + elsif Token in Token_Class_Name then + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr); + Set_Prefix (Name_Node, Prefix_Node); + Set_Selector_Name (Name_Node, Token_Node); + Scan; -- past selector + goto Scan_Name_Extension; + + -- Reserved identifier as selector + + elsif Is_Reserved_Identifier then + Scan_Reserved_Identifier (Force_Msg => False); + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr); + Set_Prefix (Name_Node, Prefix_Node); + Set_Selector_Name (Name_Node, Token_Node); + Scan; -- past identifier used as selector + goto Scan_Name_Extension; + + -- If dot is at end of line and followed by nothing legal, + -- then assume end of name and quit (dot will be taken as + -- an erroneous form of some other punctuation by our caller). + + elsif Token_Is_At_Start_Of_Line then + Restore_Scan_State (Scan_State); + return Name_Node; + + -- Here if nothing legal after the dot + + else + Error_Msg_AP ("selector expected"); + raise Error_Resync; + end if; + + -- Here for an apostrophe as name extension. The scan position at the + -- apostrophe has already been saved, and the apostrophe scanned out. + + <> + + Scan_Apostrophe : declare + function Apostrophe_Should_Be_Semicolon return Boolean; + -- Checks for case where apostrophe should probably be + -- a semicolon, and if so, gives appropriate message, + -- resets the scan pointer to the apostrophe, changes + -- the current token to Tok_Semicolon, and returns True. + -- Otherwise returns False. + + ------------------------------------ + -- Apostrophe_Should_Be_Semicolon -- + ------------------------------------ + + function Apostrophe_Should_Be_Semicolon return Boolean is + begin + if Token_Is_At_Start_Of_Line then + Restore_Scan_State (Scan_State); -- to apostrophe + Error_Msg_SC ("|""''"" should be "";"""); + Token := Tok_Semicolon; + return True; + else + return False; + end if; + end Apostrophe_Should_Be_Semicolon; + + -- Start of processing for Scan_Apostrophe + + begin + -- Check for qualified expression case in Ada 2012 mode + + if Ada_Version >= Ada_2012 and then Token = Tok_Left_Paren then + Name_Node := P_Qualified_Expression (Name_Node); + goto Scan_Name_Extension; + + -- If range attribute after apostrophe, then return with Token + -- pointing to the apostrophe. Note that in this case the prefix + -- need not be a simple name (cases like A.all'range). Similarly + -- if there is a left paren after the apostrophe, then we also + -- return with Token pointing to the apostrophe (this is the + -- aggregate case, or some error case). + + elsif Token = Tok_Range or else Token = Tok_Left_Paren then + Restore_Scan_State (Scan_State); -- to apostrophe + Expr_Form := EF_Name; + return Name_Node; + + -- Here for cases where attribute designator is an identifier + + elsif Token = Tok_Identifier then + Attr_Name := Token_Name; + + if not Is_Attribute_Name (Attr_Name) then + if Apostrophe_Should_Be_Semicolon then + Expr_Form := EF_Name; + return Name_Node; + + -- Here for a bad attribute name + + else + Signal_Bad_Attribute; + Scan; -- past bad identifier + + if Token = Tok_Left_Paren then + Scan; -- past left paren + + loop + Discard_Junk_Node (P_Expression_If_OK); + exit when not Comma_Present; + end loop; + + T_Right_Paren; + end if; + + return Error; + end if; + end if; + + if Style_Check then + Style.Check_Attribute_Name (False); + end if; + + -- Here for case of attribute designator is not an identifier + + else + if Token = Tok_Delta then + Attr_Name := Name_Delta; + + elsif Token = Tok_Digits then + Attr_Name := Name_Digits; + + elsif Token = Tok_Access then + Attr_Name := Name_Access; + + elsif Token = Tok_Mod and then Ada_Version >= Ada_95 then + Attr_Name := Name_Mod; + + elsif Apostrophe_Should_Be_Semicolon then + Expr_Form := EF_Name; + return Name_Node; + + else + Error_Msg_AP ("attribute designator expected"); + raise Error_Resync; + end if; + + if Style_Check then + Style.Check_Attribute_Name (True); + end if; + end if; + + -- We come here with an OK attribute scanned, and the + -- corresponding Attribute identifier node stored in Ident_Node. + + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr); + Scan; -- past attribute designator + Set_Prefix (Name_Node, Prefix_Node); + Set_Attribute_Name (Name_Node, Attr_Name); + + -- Scan attribute arguments/designator. We skip this if we know + -- that the attribute cannot have an argument. + + if Token = Tok_Left_Paren + and then not + Is_Parameterless_Attribute (Get_Attribute_Id (Attr_Name)) + then + Set_Expressions (Name_Node, New_List); + Scan; -- past left paren + + loop + declare + Expr : constant Node_Id := P_Expression_If_OK; + + begin + if Token = Tok_Arrow then + Error_Msg_SC + ("named parameters not permitted for attributes"); + Scan; -- past junk arrow + + else + Append (Expr, Expressions (Name_Node)); + exit when not Comma_Present; + end if; + end; + end loop; + + T_Right_Paren; + end if; + + goto Scan_Name_Extension; + end Scan_Apostrophe; + + -- Here for left parenthesis extending name (left paren skipped) + + <> + + -- We now have to scan through a list of items, terminated by a + -- right parenthesis. The scan is handled by a finite state + -- machine. The possibilities are: + + -- (discrete_range) + + -- This is a slice. This case is handled in LP_State_Init + + -- (expression, expression, ..) + + -- This is interpreted as an indexed component, i.e. as a + -- case of a name which can be extended in the normal manner. + -- This case is handled by LP_State_Name or LP_State_Expr. + + -- Note: conditional expressions (without an extra level of + -- parentheses) are permitted in this context). + + -- (..., identifier => expression , ...) + + -- If there is at least one occurrence of identifier => (but + -- none of the other cases apply), then we have a call. + + -- Test for Id => case + + if Token = Tok_Identifier then + Save_Scan_State (Scan_State); -- at Id + Scan; -- past Id + + -- Test for => (allow := as an error substitute) + + if Token = Tok_Arrow or else Token = Tok_Colon_Equal then + Restore_Scan_State (Scan_State); -- to Id + Arg_List := New_List; + goto LP_State_Call; + + else + Restore_Scan_State (Scan_State); -- to Id + end if; + end if; + + -- Here we have an expression after all + + Expr_Node := P_Expression_Or_Range_Attribute_If_OK; + + -- Check cases of discrete range for a slice + + -- First possibility: Range_Attribute_Reference + + if Expr_Form = EF_Range_Attr then + Range_Node := Expr_Node; + + -- Second possibility: Simple_expression .. Simple_expression + + elsif Token = Tok_Dot_Dot then + Check_Simple_Expression (Expr_Node); + Range_Node := New_Node (N_Range, Token_Ptr); + Set_Low_Bound (Range_Node, Expr_Node); + Scan; -- past .. + Expr_Node := P_Expression; + Check_Simple_Expression (Expr_Node); + Set_High_Bound (Range_Node, Expr_Node); + + -- Third possibility: Type_name range Range + + elsif Token = Tok_Range then + if Expr_Form /= EF_Simple_Name then + Error_Msg_SC ("subtype mark must precede RANGE"); + raise Error_Resync; + end if; + + Range_Node := P_Subtype_Indication (Expr_Node); + + -- Otherwise we just have an expression. It is true that we might + -- have a subtype mark without a range constraint but this case + -- is syntactically indistinguishable from the expression case. + + else + Arg_List := New_List; + goto LP_State_Expr; + end if; + + -- Fall through here with unmistakable Discrete range scanned, + -- which means that we definitely have the case of a slice. The + -- Discrete range is in Range_Node. + + if Token = Tok_Comma then + Error_Msg_SC ("slice cannot have more than one dimension"); + raise Error_Resync; + + elsif Token /= Tok_Right_Paren then + T_Right_Paren; + raise Error_Resync; + + else + Scan; -- past right paren + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Slice, Sloc (Prefix_Node)); + Set_Prefix (Name_Node, Prefix_Node); + Set_Discrete_Range (Name_Node, Range_Node); + + -- An operator node is legal as a prefix to other names, + -- but not for a slice. + + if Nkind (Prefix_Node) = N_Operator_Symbol then + Error_Msg_N ("illegal prefix for slice", Prefix_Node); + end if; + + -- If we have a name extension, go scan it + + if Token in Token_Class_Namext then + goto Scan_Name_Extension_OK; + + -- Otherwise return (a slice is a name, but is not a call) + + else + Expr_Form := EF_Name; + return Name_Node; + end if; + end if; + + -- In LP_State_Expr, we have scanned one or more expressions, and + -- so we have a call or an indexed component which is a name. On + -- entry we have the expression just scanned in Expr_Node and + -- Arg_List contains the list of expressions encountered so far + + <> + Append (Expr_Node, Arg_List); + + if Token = Tok_Arrow then + Error_Msg + ("expect identifier in parameter association", + Sloc (Expr_Node)); + Scan; -- past arrow + + elsif not Comma_Present then + T_Right_Paren; + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Indexed_Component, Sloc (Prefix_Node)); + Set_Prefix (Name_Node, Prefix_Node); + Set_Expressions (Name_Node, Arg_List); + goto Scan_Name_Extension; + end if; + + -- Comma present (and scanned out), test for identifier => case + -- Test for identifier => case + + if Token = Tok_Identifier then + Save_Scan_State (Scan_State); -- at Id + Scan; -- past Id + + -- Test for => (allow := as error substitute) + + if Token = Tok_Arrow or else Token = Tok_Colon_Equal then + Restore_Scan_State (Scan_State); -- to Id + goto LP_State_Call; + + -- Otherwise it's just an expression after all, so backup + + else + Restore_Scan_State (Scan_State); -- to Id + end if; + end if; + + -- Here we have an expression after all, so stay in this state + + Expr_Node := P_Expression_If_OK; + goto LP_State_Expr; + + -- LP_State_Call corresponds to the situation in which at least + -- one instance of Id => Expression has been encountered, so we + -- know that we do not have a name, but rather a call. We enter + -- it with the scan pointer pointing to the next argument to scan, + -- and Arg_List containing the list of arguments scanned so far. + + <> + + -- Test for case of Id => Expression (named parameter) + + if Token = Tok_Identifier then + Save_Scan_State (Scan_State); -- at Id + Ident_Node := Token_Node; + Scan; -- past Id + + -- Deal with => (allow := as erroneous substitute) + + if Token = Tok_Arrow or else Token = Tok_Colon_Equal then + Arg_Node := New_Node (N_Parameter_Association, Prev_Token_Ptr); + Set_Selector_Name (Arg_Node, Ident_Node); + T_Arrow; + Set_Explicit_Actual_Parameter (Arg_Node, P_Expression); + Append (Arg_Node, Arg_List); + + -- If a comma follows, go back and scan next entry + + if Comma_Present then + goto LP_State_Call; + + -- Otherwise we have the end of a call + + else + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Function_Call, Sloc (Prefix_Node)); + Set_Name (Name_Node, Prefix_Node); + Set_Parameter_Associations (Name_Node, Arg_List); + T_Right_Paren; + + if Token in Token_Class_Namext then + goto Scan_Name_Extension_OK; + + -- This is a case of a call which cannot be a name + + else + Expr_Form := EF_Name; + return Name_Node; + end if; + end if; + + -- Not named parameter: Id started an expression after all + + else + Restore_Scan_State (Scan_State); -- to Id + end if; + end if; + + -- Here if entry did not start with Id => which means that it + -- is a positional parameter, which is not allowed, since we + -- have seen at least one named parameter already. + + Error_Msg_SC + ("positional parameter association " & + "not allowed after named one"); + + Expr_Node := P_Expression_If_OK; + + -- Leaving the '>' in an association is not unusual, so suggest + -- a possible fix. + + if Nkind (Expr_Node) = N_Op_Eq then + Error_Msg_N ("\maybe `='>` was intended", Expr_Node); + end if; + + -- We go back to scanning out expressions, so that we do not get + -- multiple error messages when several positional parameters + -- follow a named parameter. + + goto LP_State_Expr; + + -- End of treatment for name extensions starting with left paren + + -- End of loop through name extensions + + end P_Name; + + -- This function parses a restricted form of Names which are either + -- designators, or designators preceded by a sequence of prefixes + -- that are direct names. + + -- Error recovery: cannot raise Error_Resync + + function P_Function_Name return Node_Id is + Designator_Node : Node_Id; + Prefix_Node : Node_Id; + Selector_Node : Node_Id; + Dot_Sloc : Source_Ptr := No_Location; + + begin + -- Prefix_Node is set to the gathered prefix so far, Empty means that + -- no prefix has been scanned. This allows us to build up the result + -- in the required right recursive manner. + + Prefix_Node := Empty; + + -- Loop through prefixes + + loop + Designator_Node := Token_Node; + + if Token not in Token_Class_Desig then + return P_Identifier; -- let P_Identifier issue the error message + + else -- Token in Token_Class_Desig + Scan; -- past designator + exit when Token /= Tok_Dot; + end if; + + -- Here at a dot, with token just before it in Designator_Node + + if No (Prefix_Node) then + Prefix_Node := Designator_Node; + else + Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); + Set_Prefix (Selector_Node, Prefix_Node); + Set_Selector_Name (Selector_Node, Designator_Node); + Prefix_Node := Selector_Node; + end if; + + Dot_Sloc := Token_Ptr; + Scan; -- past dot + end loop; + + -- Fall out of the loop having just scanned a designator + + if No (Prefix_Node) then + return Designator_Node; + else + Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); + Set_Prefix (Selector_Node, Prefix_Node); + Set_Selector_Name (Selector_Node, Designator_Node); + return Selector_Node; + end if; + + exception + when Error_Resync => + return Error; + end P_Function_Name; + + -- This function parses a restricted form of Names which are either + -- identifiers, or identifiers preceded by a sequence of prefixes + -- that are direct names. + + -- Error recovery: cannot raise Error_Resync + + function P_Qualified_Simple_Name return Node_Id is + Designator_Node : Node_Id; + Prefix_Node : Node_Id; + Selector_Node : Node_Id; + Dot_Sloc : Source_Ptr := No_Location; + + begin + -- Prefix node is set to the gathered prefix so far, Empty means that + -- no prefix has been scanned. This allows us to build up the result + -- in the required right recursive manner. + + Prefix_Node := Empty; + + -- Loop through prefixes + + loop + Designator_Node := Token_Node; + + if Token = Tok_Identifier then + Scan; -- past identifier + exit when Token /= Tok_Dot; + + elsif Token not in Token_Class_Desig then + return P_Identifier; -- let P_Identifier issue the error message + + else + Scan; -- past designator + + if Token /= Tok_Dot then + Error_Msg_SP ("identifier expected"); + return Error; + end if; + end if; + + -- Here at a dot, with token just before it in Designator_Node + + if No (Prefix_Node) then + Prefix_Node := Designator_Node; + else + Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); + Set_Prefix (Selector_Node, Prefix_Node); + Set_Selector_Name (Selector_Node, Designator_Node); + Prefix_Node := Selector_Node; + end if; + + Dot_Sloc := Token_Ptr; + Scan; -- past dot + end loop; + + -- Fall out of the loop having just scanned an identifier + + if No (Prefix_Node) then + return Designator_Node; + else + Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); + Set_Prefix (Selector_Node, Prefix_Node); + Set_Selector_Name (Selector_Node, Designator_Node); + return Selector_Node; + end if; + + exception + when Error_Resync => + return Error; + end P_Qualified_Simple_Name; + + -- This procedure differs from P_Qualified_Simple_Name only in that it + -- raises Error_Resync if any error is encountered. It only returns after + -- scanning a valid qualified simple name. + + -- Error recovery: can raise Error_Resync + + function P_Qualified_Simple_Name_Resync return Node_Id is + Designator_Node : Node_Id; + Prefix_Node : Node_Id; + Selector_Node : Node_Id; + Dot_Sloc : Source_Ptr := No_Location; + + begin + Prefix_Node := Empty; + + -- Loop through prefixes + + loop + Designator_Node := Token_Node; + + if Token = Tok_Identifier then + Scan; -- past identifier + exit when Token /= Tok_Dot; + + elsif Token not in Token_Class_Desig then + Discard_Junk_Node (P_Identifier); -- to issue the error message + raise Error_Resync; + + else + Scan; -- past designator + + if Token /= Tok_Dot then + Error_Msg_SP ("identifier expected"); + raise Error_Resync; + end if; + end if; + + -- Here at a dot, with token just before it in Designator_Node + + if No (Prefix_Node) then + Prefix_Node := Designator_Node; + else + Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); + Set_Prefix (Selector_Node, Prefix_Node); + Set_Selector_Name (Selector_Node, Designator_Node); + Prefix_Node := Selector_Node; + end if; + + Dot_Sloc := Token_Ptr; + Scan; -- past period + end loop; + + -- Fall out of the loop having just scanned an identifier + + if No (Prefix_Node) then + return Designator_Node; + else + Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); + Set_Prefix (Selector_Node, Prefix_Node); + Set_Selector_Name (Selector_Node, Designator_Node); + return Selector_Node; + end if; + end P_Qualified_Simple_Name_Resync; + + ---------------------- + -- 4.1 Direct_Name -- + ---------------------- + + -- Parsed by P_Name and other functions in section 4.1 + + ----------------- + -- 4.1 Prefix -- + ----------------- + + -- Parsed by P_Name (4.1) + + ------------------------------- + -- 4.1 Explicit Dereference -- + ------------------------------- + + -- Parsed by P_Name (4.1) + + ------------------------------- + -- 4.1 Implicit_Dereference -- + ------------------------------- + + -- Parsed by P_Name (4.1) + + ---------------------------- + -- 4.1 Indexed Component -- + ---------------------------- + + -- Parsed by P_Name (4.1) + + ---------------- + -- 4.1 Slice -- + ---------------- + + -- Parsed by P_Name (4.1) + + ----------------------------- + -- 4.1 Selected_Component -- + ----------------------------- + + -- Parsed by P_Name (4.1) + + ------------------------ + -- 4.1 Selector Name -- + ------------------------ + + -- Parsed by P_Name (4.1) + + ------------------------------ + -- 4.1 Attribute Reference -- + ------------------------------ + + -- Parsed by P_Name (4.1) + + ------------------------------- + -- 4.1 Attribute Designator -- + ------------------------------- + + -- Parsed by P_Name (4.1) + + -------------------------------------- + -- 4.1.4 Range Attribute Reference -- + -------------------------------------- + + -- RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR + + -- RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)] + + -- In the grammar, a RANGE attribute is simply a name, but its use is + -- highly restricted, so in the parser, we do not regard it as a name. + -- Instead, P_Name returns without scanning the 'RANGE part of the + -- attribute, and the caller uses the following function to construct + -- a range attribute in places where it is appropriate. + + -- Note that RANGE here is treated essentially as an identifier, + -- rather than a reserved word. + + -- The caller has parsed the prefix, i.e. a name, and Token points to + -- the apostrophe. The token after the apostrophe is known to be RANGE + -- at this point. The prefix node becomes the prefix of the attribute. + + -- Error_Recovery: Cannot raise Error_Resync + + function P_Range_Attribute_Reference + (Prefix_Node : Node_Id) + return Node_Id + is + Attr_Node : Node_Id; + + begin + Attr_Node := New_Node (N_Attribute_Reference, Token_Ptr); + Set_Prefix (Attr_Node, Prefix_Node); + Scan; -- past apostrophe + + if Style_Check then + Style.Check_Attribute_Name (True); + end if; + + Set_Attribute_Name (Attr_Node, Name_Range); + Scan; -- past RANGE + + if Token = Tok_Left_Paren then + Scan; -- past left paren + Set_Expressions (Attr_Node, New_List (P_Expression_If_OK)); + T_Right_Paren; + end if; + + return Attr_Node; + end P_Range_Attribute_Reference; + + --------------------------------------- + -- 4.1.4 Range Attribute Designator -- + --------------------------------------- + + -- Parsed by P_Range_Attribute_Reference (4.4) + + -------------------- + -- 4.3 Aggregate -- + -------------------- + + -- AGGREGATE ::= RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE + + -- Parsed by P_Aggregate_Or_Paren_Expr (4.3), except in the case where + -- an aggregate is known to be required (code statement, extension + -- aggregate), in which cases this routine performs the necessary check + -- that we have an aggregate rather than a parenthesized expression + + -- Error recovery: can raise Error_Resync + + function P_Aggregate return Node_Id is + Aggr_Sloc : constant Source_Ptr := Token_Ptr; + Aggr_Node : constant Node_Id := P_Aggregate_Or_Paren_Expr; + + begin + if Nkind (Aggr_Node) /= N_Aggregate + and then + Nkind (Aggr_Node) /= N_Extension_Aggregate + then + Error_Msg + ("aggregate may not have single positional component", Aggr_Sloc); + return Error; + else + return Aggr_Node; + end if; + end P_Aggregate; + + ------------------------------------------------ + -- 4.3 Aggregate or Parenthesized Expression -- + ------------------------------------------------ + + -- This procedure parses out either an aggregate or a parenthesized + -- expression (these two constructs are closely related, since a + -- parenthesized expression looks like an aggregate with a single + -- positional component). + + -- AGGREGATE ::= + -- RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE + + -- RECORD_AGGREGATE ::= (RECORD_COMPONENT_ASSOCIATION_LIST) + + -- RECORD_COMPONENT_ASSOCIATION_LIST ::= + -- RECORD_COMPONENT_ASSOCIATION {, RECORD_COMPONENT_ASSOCIATION} + -- | null record + + -- RECORD_COMPONENT_ASSOCIATION ::= + -- [COMPONENT_CHOICE_LIST =>] EXPRESSION + + -- COMPONENT_CHOICE_LIST ::= + -- component_SELECTOR_NAME {| component_SELECTOR_NAME} + -- | others + + -- EXTENSION_AGGREGATE ::= + -- (ANCESTOR_PART with RECORD_COMPONENT_ASSOCIATION_LIST) + + -- ANCESTOR_PART ::= EXPRESSION | SUBTYPE_MARK + + -- ARRAY_AGGREGATE ::= + -- POSITIONAL_ARRAY_AGGREGATE | NAMED_ARRAY_AGGREGATE + + -- POSITIONAL_ARRAY_AGGREGATE ::= + -- (EXPRESSION, EXPRESSION {, EXPRESSION}) + -- | (EXPRESSION {, EXPRESSION}, others => EXPRESSION) + -- | (EXPRESSION {, EXPRESSION}, others => <>) + + -- NAMED_ARRAY_AGGREGATE ::= + -- (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION}) + + -- PRIMARY ::= (EXPRESSION); + + -- Error recovery: can raise Error_Resync + + -- Note: POSITIONAL_ARRAY_AGGREGATE rule has been extended to give support + -- to Ada 2005 limited aggregates (AI-287) + + function P_Aggregate_Or_Paren_Expr return Node_Id is + Aggregate_Node : Node_Id; + Expr_List : List_Id; + Assoc_List : List_Id; + Expr_Node : Node_Id; + Lparen_Sloc : Source_Ptr; + Scan_State : Saved_Scan_State; + + procedure Box_Error; + -- Called if <> is encountered as positional aggregate element. Issues + -- error message and sets Expr_Node to Error. + + --------------- + -- Box_Error -- + --------------- + + procedure Box_Error is + begin + if Ada_Version < Ada_2005 then + Error_Msg_SC ("box in aggregate is an Ada 2005 extension"); + end if; + + -- Ada 2005 (AI-287): The box notation is allowed only with named + -- notation because positional notation might be error prone. For + -- example, in "(X, <>, Y, <>)", there is no type associated with + -- the boxes, so you might not be leaving out the components you + -- thought you were leaving out. + + Error_Msg_SC ("(Ada 2005) box only allowed with named notation"); + Scan; -- past box + Expr_Node := Error; + end Box_Error; + + -- Start of processing for P_Aggregate_Or_Paren_Expr + + begin + Lparen_Sloc := Token_Ptr; + T_Left_Paren; + + -- Conditional expression case + + if Token = Tok_If then + Expr_Node := P_Conditional_Expression; + T_Right_Paren; + return Expr_Node; + + -- Case expression case + + elsif Token = Tok_Case then + Expr_Node := P_Case_Expression; + T_Right_Paren; + return Expr_Node; + + -- Quantified expression case + + elsif Token = Tok_For then + Expr_Node := P_Quantified_Expression; + T_Right_Paren; + return Expr_Node; + + -- Note: the mechanism used here of rescanning the initial expression + -- is distinctly unpleasant, but it saves a lot of fiddling in scanning + -- out the discrete choice list. + + -- Deal with expression and extension aggregate cases first + + elsif Token /= Tok_Others then + Save_Scan_State (Scan_State); -- at start of expression + + -- Deal with (NULL RECORD) case + + if Token = Tok_Null then + Scan; -- past NULL + + if Token = Tok_Record then + Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc); + Set_Null_Record_Present (Aggregate_Node, True); + Scan; -- past RECORD + T_Right_Paren; + return Aggregate_Node; + else + Restore_Scan_State (Scan_State); -- to NULL that must be expr + end if; + end if; + + -- Scan expression, handling box appearing as positional argument + + if Token = Tok_Box then + Box_Error; + else + Expr_Node := P_Expression_Or_Range_Attribute_If_OK; + end if; + + -- Extension aggregate case + + if Token = Tok_With then + if Nkind (Expr_Node) = N_Attribute_Reference + and then Attribute_Name (Expr_Node) = Name_Range + then + Bad_Range_Attribute (Sloc (Expr_Node)); + return Error; + end if; + + if Ada_Version = Ada_83 then + Error_Msg_SC ("(Ada 83) extension aggregate not allowed"); + end if; + + Aggregate_Node := New_Node (N_Extension_Aggregate, Lparen_Sloc); + Set_Ancestor_Part (Aggregate_Node, Expr_Node); + Scan; -- past WITH + + -- Deal with WITH NULL RECORD case + + if Token = Tok_Null then + Save_Scan_State (Scan_State); -- at NULL + Scan; -- past NULL + + if Token = Tok_Record then + Scan; -- past RECORD + Set_Null_Record_Present (Aggregate_Node, True); + T_Right_Paren; + return Aggregate_Node; + + else + Restore_Scan_State (Scan_State); -- to NULL that must be expr + end if; + end if; + + if Token /= Tok_Others then + Save_Scan_State (Scan_State); + Expr_Node := P_Expression; + else + Expr_Node := Empty; + end if; + + -- Expression case + + elsif Token = Tok_Right_Paren or else Token in Token_Class_Eterm then + if Nkind (Expr_Node) = N_Attribute_Reference + and then Attribute_Name (Expr_Node) = Name_Range + then + Error_Msg + ("|parentheses not allowed for range attribute", Lparen_Sloc); + Scan; -- past right paren + return Expr_Node; + end if; + + -- Bump paren count of expression + + if Expr_Node /= Error then + Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1); + end if; + + T_Right_Paren; -- past right paren (error message if none) + return Expr_Node; + + -- Normal aggregate case + + else + Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc); + end if; + + -- Others case + + else + Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc); + Expr_Node := Empty; + end if; + + -- Prepare to scan list of component associations + + Expr_List := No_List; -- don't set yet, maybe all named entries + Assoc_List := No_List; -- don't set yet, maybe all positional entries + + -- This loop scans through component associations. On entry to the + -- loop, an expression has been scanned at the start of the current + -- association unless initial token was OTHERS, in which case + -- Expr_Node is set to Empty. + + loop + -- Deal with others association first. This is a named association + + if No (Expr_Node) then + if No (Assoc_List) then + Assoc_List := New_List; + end if; + + Append (P_Record_Or_Array_Component_Association, Assoc_List); + + -- Improper use of WITH + + elsif Token = Tok_With then + Error_Msg_SC ("WITH must be preceded by single expression in " & + "extension aggregate"); + raise Error_Resync; + + -- Range attribute can only appear as part of a discrete choice list + + elsif Nkind (Expr_Node) = N_Attribute_Reference + and then Attribute_Name (Expr_Node) = Name_Range + and then Token /= Tok_Arrow + and then Token /= Tok_Vertical_Bar + then + Bad_Range_Attribute (Sloc (Expr_Node)); + return Error; + + -- Assume positional case if comma, right paren, or literal or + -- identifier or OTHERS follows (the latter cases are missing + -- comma cases). Also assume positional if a semicolon follows, + -- which can happen if there are missing parens + + elsif Token = Tok_Comma + or else Token = Tok_Right_Paren + or else Token = Tok_Others + or else Token in Token_Class_Lit_Or_Name + or else Token = Tok_Semicolon + then + if Present (Assoc_List) then + Error_Msg_BC -- CODEFIX + ("""='>"" expected (positional association cannot follow " & + "named association)"); + end if; + + if No (Expr_List) then + Expr_List := New_List; + end if; + + Append (Expr_Node, Expr_List); + + -- Check for aggregate followed by left parent, maybe missing comma + + elsif Nkind (Expr_Node) = N_Aggregate + and then Token = Tok_Left_Paren + then + T_Comma; + + if No (Expr_List) then + Expr_List := New_List; + end if; + + Append (Expr_Node, Expr_List); + + -- Anything else is assumed to be a named association + + else + Restore_Scan_State (Scan_State); -- to start of expression + + if No (Assoc_List) then + Assoc_List := New_List; + end if; + + Append (P_Record_Or_Array_Component_Association, Assoc_List); + end if; + + exit when not Comma_Present; + + -- If we are at an expression terminator, something is seriously + -- wrong, so let's get out now, before we start eating up stuff + -- that doesn't belong to us! + + if Token in Token_Class_Eterm then + + -- If Some becomes a keyword, the following is needed to make it + -- acceptable in older versions of Ada. + + if Token = Tok_Some + and then Ada_Version < Ada_2012 + then + Scan_Reserved_Identifier (False); + else + Error_Msg_AP + ("expecting expression or component association"); + exit; + end if; + end if; + + -- Deal with misused box + + if Token = Tok_Box then + Box_Error; + + -- Otherwise initiate for reentry to top of loop by scanning an + -- initial expression, unless the first token is OTHERS. + + elsif Token = Tok_Others then + Expr_Node := Empty; + + else + Save_Scan_State (Scan_State); -- at start of expression + Expr_Node := P_Expression_Or_Range_Attribute_If_OK; + + end if; + end loop; + + -- All component associations (positional and named) have been scanned + + T_Right_Paren; + Set_Expressions (Aggregate_Node, Expr_List); + Set_Component_Associations (Aggregate_Node, Assoc_List); + return Aggregate_Node; + end P_Aggregate_Or_Paren_Expr; + + ------------------------------------------------ + -- 4.3 Record or Array Component Association -- + ------------------------------------------------ + + -- RECORD_COMPONENT_ASSOCIATION ::= + -- [COMPONENT_CHOICE_LIST =>] EXPRESSION + -- | COMPONENT_CHOICE_LIST => <> + + -- COMPONENT_CHOICE_LIST => + -- component_SELECTOR_NAME {| component_SELECTOR_NAME} + -- | others + + -- ARRAY_COMPONENT_ASSOCIATION ::= + -- DISCRETE_CHOICE_LIST => EXPRESSION + -- | DISCRETE_CHOICE_LIST => <> + + -- Note: this routine only handles the named cases, including others. + -- Cases where the component choice list is not present have already + -- been handled directly. + + -- Error recovery: can raise Error_Resync + + -- Note: RECORD_COMPONENT_ASSOCIATION and ARRAY_COMPONENT_ASSOCIATION + -- rules have been extended to give support to Ada 2005 limited + -- aggregates (AI-287) + + function P_Record_Or_Array_Component_Association return Node_Id is + Assoc_Node : Node_Id; + + begin + Assoc_Node := New_Node (N_Component_Association, Token_Ptr); + Set_Choices (Assoc_Node, P_Discrete_Choice_List); + Set_Sloc (Assoc_Node, Token_Ptr); + TF_Arrow; + + if Token = Tok_Box then + + -- Ada 2005(AI-287): The box notation is used to indicate the + -- default initialization of aggregate components + + if Ada_Version < Ada_2005 then + Error_Msg_SP + ("component association with '<'> is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + end if; + + Set_Box_Present (Assoc_Node); + Scan; -- Past box + else + Set_Expression (Assoc_Node, P_Expression); + end if; + + return Assoc_Node; + end P_Record_Or_Array_Component_Association; + + ----------------------------- + -- 4.3.1 Record Aggregate -- + ----------------------------- + + -- Case of enumeration aggregate is parsed by P_Aggregate (4.3) + -- All other cases are parsed by P_Aggregate_Or_Paren_Expr (4.3) + + ---------------------------------------------- + -- 4.3.1 Record Component Association List -- + ---------------------------------------------- + + -- Parsed by P_Aggregate_Or_Paren_Expr (4.3) + + ---------------------------------- + -- 4.3.1 Component Choice List -- + ---------------------------------- + + -- Parsed by P_Aggregate_Or_Paren_Expr (4.3) + + -------------------------------- + -- 4.3.1 Extension Aggregate -- + -------------------------------- + + -- Parsed by P_Aggregate_Or_Paren_Expr (4.3) + + -------------------------- + -- 4.3.1 Ancestor Part -- + -------------------------- + + -- Parsed by P_Aggregate_Or_Paren_Expr (4.3) + + ---------------------------- + -- 4.3.1 Array Aggregate -- + ---------------------------- + + -- Parsed by P_Aggregate_Or_Paren_Expr (4.3) + + --------------------------------------- + -- 4.3.1 Positional Array Aggregate -- + --------------------------------------- + + -- Parsed by P_Aggregate_Or_Paren_Expr (4.3) + + ---------------------------------- + -- 4.3.1 Named Array Aggregate -- + ---------------------------------- + + -- Parsed by P_Aggregate_Or_Paren_Expr (4.3) + + ---------------------------------------- + -- 4.3.1 Array Component Association -- + ---------------------------------------- + + -- Parsed by P_Aggregate_Or_Paren_Expr (4.3) + + --------------------- + -- 4.4 Expression -- + --------------------- + + -- This procedure parses EXPRESSION or CHOICE_EXPRESSION + + -- EXPRESSION ::= + -- RELATION {LOGICAL_OPERATOR RELATION} + + -- CHOICE_EXPRESSION ::= + -- CHOICE_RELATION {LOGICAL_OPERATOR CHOICE_RELATION} + + -- LOGICAL_OPERATOR ::= and | and then | or | or else | xor + + -- On return, Expr_Form indicates the categorization of the expression + -- EF_Range_Attr is not a possible value (if a range attribute is found, + -- an error message is given, and Error is returned). + + -- Error recovery: cannot raise Error_Resync + + function P_Expression return Node_Id is + Logical_Op : Node_Kind; + Prev_Logical_Op : Node_Kind; + Op_Location : Source_Ptr; + Node1 : Node_Id; + Node2 : Node_Id; + + begin + Node1 := P_Relation; + + if Token in Token_Class_Logop then + Prev_Logical_Op := N_Empty; + + loop + Op_Location := Token_Ptr; + Logical_Op := P_Logical_Operator; + + if Prev_Logical_Op /= N_Empty and then + Logical_Op /= Prev_Logical_Op + then + Error_Msg + ("mixed logical operators in expression", Op_Location); + Prev_Logical_Op := N_Empty; + else + Prev_Logical_Op := Logical_Op; + end if; + + Node2 := Node1; + Node1 := New_Op_Node (Logical_Op, Op_Location); + Set_Left_Opnd (Node1, Node2); + Set_Right_Opnd (Node1, P_Relation); + exit when Token not in Token_Class_Logop; + end loop; + + Expr_Form := EF_Non_Simple; + end if; + + if Token = Tok_Apostrophe then + Bad_Range_Attribute (Token_Ptr); + return Error; + else + return Node1; + end if; + end P_Expression; + + -- This function is identical to the normal P_Expression, except that it + -- also permits the appearance of a case, conditional, or quantified + -- expression without the usual surrounding parentheses. + + function P_Expression_If_OK return Node_Id is + begin + if Token = Tok_Case then + return P_Case_Expression; + + elsif Token = Tok_If then + return P_Conditional_Expression; + + elsif Token = Tok_For then + return P_Quantified_Expression; + + else + return P_Expression; + end if; + end P_Expression_If_OK; + + -- This function is identical to the normal P_Expression, except that it + -- checks that the expression scan did not stop on a right paren. It is + -- called in all contexts where a right parenthesis cannot legitimately + -- follow an expression. + + -- Error recovery: can not raise Error_Resync + + function P_Expression_No_Right_Paren return Node_Id is + Expr : constant Node_Id := P_Expression; + begin + Ignore (Tok_Right_Paren); + return Expr; + end P_Expression_No_Right_Paren; + + ---------------------------------------- + -- 4.4 Expression_Or_Range_Attribute -- + ---------------------------------------- + + -- EXPRESSION ::= + -- RELATION {and RELATION} | RELATION {and then RELATION} + -- | RELATION {or RELATION} | RELATION {or else RELATION} + -- | RELATION {xor RELATION} + + -- RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR + + -- RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)] + + -- On return, Expr_Form indicates the categorization of the expression + -- and EF_Range_Attr is one of the possibilities. + + -- Error recovery: cannot raise Error_Resync + + -- In the grammar, a RANGE attribute is simply a name, but its use is + -- highly restricted, so in the parser, we do not regard it as a name. + -- Instead, P_Name returns without scanning the 'RANGE part of the + -- attribute, and P_Expression_Or_Range_Attribute handles the range + -- attribute reference. In the normal case where a range attribute is + -- not allowed, an error message is issued by P_Expression. + + function P_Expression_Or_Range_Attribute return Node_Id is + Logical_Op : Node_Kind; + Prev_Logical_Op : Node_Kind; + Op_Location : Source_Ptr; + Node1 : Node_Id; + Node2 : Node_Id; + Attr_Node : Node_Id; + + begin + Node1 := P_Relation; + + if Token = Tok_Apostrophe then + Attr_Node := P_Range_Attribute_Reference (Node1); + Expr_Form := EF_Range_Attr; + return Attr_Node; + + elsif Token in Token_Class_Logop then + Prev_Logical_Op := N_Empty; + + loop + Op_Location := Token_Ptr; + Logical_Op := P_Logical_Operator; + + if Prev_Logical_Op /= N_Empty and then + Logical_Op /= Prev_Logical_Op + then + Error_Msg + ("mixed logical operators in expression", Op_Location); + Prev_Logical_Op := N_Empty; + else + Prev_Logical_Op := Logical_Op; + end if; + + Node2 := Node1; + Node1 := New_Op_Node (Logical_Op, Op_Location); + Set_Left_Opnd (Node1, Node2); + Set_Right_Opnd (Node1, P_Relation); + exit when Token not in Token_Class_Logop; + end loop; + + Expr_Form := EF_Non_Simple; + end if; + + if Token = Tok_Apostrophe then + Bad_Range_Attribute (Token_Ptr); + return Error; + else + return Node1; + end if; + end P_Expression_Or_Range_Attribute; + + -- Version that allows a non-parenthesized case, conditional, or quantified + -- expression + + function P_Expression_Or_Range_Attribute_If_OK return Node_Id is + begin + if Token = Tok_Case then + return P_Case_Expression; + + elsif Token = Tok_If then + return P_Conditional_Expression; + + elsif Token = Tok_For then + return P_Quantified_Expression; + + else + return P_Expression_Or_Range_Attribute; + end if; + end P_Expression_Or_Range_Attribute_If_OK; + + ------------------- + -- 4.4 Relation -- + ------------------- + + -- This procedure scans both relations and choice relations + + -- CHOICE_RELATION ::= + -- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION] + + -- RELATION ::= + -- SIMPLE_EXPRESSION [not] in MEMBERSHIP_CHOICE_LIST + + -- MEMBERSHIP_CHOICE_LIST ::= + -- MEMBERSHIP_CHOICE {'|' MEMBERSHIP CHOICE} + + -- MEMBERSHIP_CHOICE ::= + -- CHOICE_EXPRESSION | RANGE | SUBTYPE_MARK + + -- On return, Expr_Form indicates the categorization of the expression + + -- Note: if Token = Tok_Apostrophe on return, then Expr_Form is set to + -- EF_Simple_Name and the following token is RANGE (range attribute case). + + -- Error recovery: cannot raise Error_Resync. If an error occurs within an + -- expression, then tokens are scanned until either a non-expression token, + -- a right paren (not matched by a left paren) or a comma, is encountered. + + function P_Relation return Node_Id is + Node1, Node2 : Node_Id; + Optok : Source_Ptr; + + begin + Node1 := P_Simple_Expression; + + if Token not in Token_Class_Relop then + return Node1; + + else + -- Here we have a relational operator following. If so then scan it + -- out. Note that the assignment symbol := is treated as a relational + -- operator to improve the error recovery when it is misused for =. + -- P_Relational_Operator also parses the IN and NOT IN operations. + + Optok := Token_Ptr; + Node2 := New_Op_Node (P_Relational_Operator, Optok); + Set_Left_Opnd (Node2, Node1); + + -- Case of IN or NOT IN + + if Prev_Token = Tok_In then + P_Membership_Test (Node2); + + -- Case of relational operator (= /= < <= > >=) + + else + Set_Right_Opnd (Node2, P_Simple_Expression); + end if; + + Expr_Form := EF_Non_Simple; + + if Token in Token_Class_Relop then + Error_Msg_SC ("unexpected relational operator"); + raise Error_Resync; + end if; + + return Node2; + end if; + + -- If any error occurs, then scan to the next expression terminator symbol + -- or comma or right paren at the outer (i.e. current) parentheses level. + -- The flags are set to indicate a normal simple expression. + + exception + when Error_Resync => + Resync_Expression; + Expr_Form := EF_Simple; + return Error; + end P_Relation; + + ---------------------------- + -- 4.4 Simple Expression -- + ---------------------------- + + -- SIMPLE_EXPRESSION ::= + -- [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM} + + -- On return, Expr_Form indicates the categorization of the expression + + -- Note: if Token = Tok_Apostrophe on return, then Expr_Form is set to + -- EF_Simple_Name and the following token is RANGE (range attribute case). + + -- Error recovery: cannot raise Error_Resync. If an error occurs within an + -- expression, then tokens are scanned until either a non-expression token, + -- a right paren (not matched by a left paren) or a comma, is encountered. + + -- Note: P_Simple_Expression is called only internally by higher level + -- expression routines. In cases in the grammar where a simple expression + -- is required, the approach is to scan an expression, and then post an + -- appropriate error message if the expression obtained is not simple. This + -- gives better error recovery and treatment. + + function P_Simple_Expression return Node_Id is + Scan_State : Saved_Scan_State; + Node1 : Node_Id; + Node2 : Node_Id; + Tokptr : Source_Ptr; + + begin + -- Check for cases starting with a name. There are two reasons for + -- special casing. First speed things up by catching a common case + -- without going through several routine layers. Second the caller must + -- be informed via Expr_Form when the simple expression is a name. + + if Token in Token_Class_Name then + Node1 := P_Name; + + -- Deal with apostrophe cases + + if Token = Tok_Apostrophe then + Save_Scan_State (Scan_State); -- at apostrophe + Scan; -- past apostrophe + + -- If qualified expression, scan it out and fall through + + if Token = Tok_Left_Paren then + Node1 := P_Qualified_Expression (Node1); + Expr_Form := EF_Simple; + + -- If range attribute, then we return with Token pointing to the + -- apostrophe. Note: avoid the normal error check on exit. We + -- know that the expression really is complete in this case! + + else -- Token = Tok_Range then + Restore_Scan_State (Scan_State); -- to apostrophe + Expr_Form := EF_Simple_Name; + return Node1; + end if; + end if; + + -- If an expression terminator follows, the previous processing + -- completely scanned out the expression (a common case), and + -- left Expr_Form set appropriately for returning to our caller. + + if Token in Token_Class_Sterm then + null; + + -- If we do not have an expression terminator, then complete the + -- scan of a simple expression. This code duplicates the code + -- found in P_Term and P_Factor. + + else + if Token = Tok_Double_Asterisk then + if Style_Check then + Style.Check_Exponentiation_Operator; + end if; + + Node2 := New_Op_Node (N_Op_Expon, Token_Ptr); + Scan; -- past ** + Set_Left_Opnd (Node2, Node1); + Set_Right_Opnd (Node2, P_Primary); + Node1 := Node2; + end if; + + loop + exit when Token not in Token_Class_Mulop; + Tokptr := Token_Ptr; + Node2 := New_Op_Node (P_Multiplying_Operator, Tokptr); + + if Style_Check then + Style.Check_Binary_Operator; + end if; + + Scan; -- past operator + Set_Left_Opnd (Node2, Node1); + Set_Right_Opnd (Node2, P_Factor); + Node1 := Node2; + end loop; + + loop + exit when Token not in Token_Class_Binary_Addop; + Tokptr := Token_Ptr; + Node2 := New_Op_Node (P_Binary_Adding_Operator, Tokptr); + + if Style_Check then + Style.Check_Binary_Operator; + end if; + + Scan; -- past operator + Set_Left_Opnd (Node2, Node1); + Set_Right_Opnd (Node2, P_Term); + Node1 := Node2; + end loop; + + Expr_Form := EF_Simple; + end if; + + -- Cases where simple expression does not start with a name + + else + -- Scan initial sign and initial Term + + if Token in Token_Class_Unary_Addop then + Tokptr := Token_Ptr; + Node1 := New_Op_Node (P_Unary_Adding_Operator, Tokptr); + + if Style_Check then + Style.Check_Unary_Plus_Or_Minus; + end if; + + Scan; -- past operator + Set_Right_Opnd (Node1, P_Term); + else + Node1 := P_Term; + end if; + + -- In the following, we special-case a sequence of concatenations of + -- string literals, such as "aaa" & "bbb" & ... & "ccc", with nothing + -- else mixed in. For such a sequence, we return a tree representing + -- "" & "aaabbb...ccc" (a single concatenation). This is done only if + -- the number of concatenations is large. If semantic analysis + -- resolves the "&" to a predefined one, then this folding gives the + -- right answer. Otherwise, semantic analysis will complain about a + -- capacity-exceeded error. The purpose of this trick is to avoid + -- creating a deeply nested tree, which would cause deep recursion + -- during semantics, causing stack overflow. This way, we can handle + -- enormous concatenations in the normal case of predefined "&". We + -- first build up the normal tree, and then rewrite it if + -- appropriate. + + declare + Num_Concats_Threshold : constant Positive := 1000; + -- Arbitrary threshold value to enable optimization + + First_Node : constant Node_Id := Node1; + Is_Strlit_Concat : Boolean; + -- True iff we've parsed a sequence of concatenations of string + -- literals, with nothing else mixed in. + + Num_Concats : Natural; + -- Number of "&" operators if Is_Strlit_Concat is True + + begin + Is_Strlit_Concat := + Nkind (Node1) = N_String_Literal + and then Token = Tok_Ampersand; + Num_Concats := 0; + + -- Scan out sequence of terms separated by binary adding operators + + loop + exit when Token not in Token_Class_Binary_Addop; + Tokptr := Token_Ptr; + Node2 := New_Op_Node (P_Binary_Adding_Operator, Tokptr); + Scan; -- past operator + Set_Left_Opnd (Node2, Node1); + Node1 := P_Term; + Set_Right_Opnd (Node2, Node1); + + -- Check if we're still concatenating string literals + + Is_Strlit_Concat := + Is_Strlit_Concat + and then Nkind (Node2) = N_Op_Concat + and then Nkind (Node1) = N_String_Literal; + + if Is_Strlit_Concat then + Num_Concats := Num_Concats + 1; + end if; + + Node1 := Node2; + end loop; + + -- If we have an enormous series of concatenations of string + -- literals, rewrite as explained above. The Is_Folded_In_Parser + -- flag tells semantic analysis that if the "&" is not predefined, + -- the folded value is wrong. + + if Is_Strlit_Concat + and then Num_Concats >= Num_Concats_Threshold + then + declare + Empty_String_Val : String_Id; + -- String_Id for "" + + Strlit_Concat_Val : String_Id; + -- Contains the folded value (which will be correct if the + -- "&" operators are the predefined ones). + + Cur_Node : Node_Id; + -- For walking up the tree + + New_Node : Node_Id; + -- Folded node to replace Node1 + + Loc : constant Source_Ptr := Sloc (First_Node); + + begin + -- Walk up the tree starting at the leftmost string literal + -- (First_Node), building up the Strlit_Concat_Val as we + -- go. Note that we do not use recursion here -- the whole + -- point is to avoid recursively walking that enormous tree. + + Start_String; + Store_String_Chars (Strval (First_Node)); + + Cur_Node := Parent (First_Node); + while Present (Cur_Node) loop + pragma Assert (Nkind (Cur_Node) = N_Op_Concat and then + Nkind (Right_Opnd (Cur_Node)) = N_String_Literal); + + Store_String_Chars (Strval (Right_Opnd (Cur_Node))); + Cur_Node := Parent (Cur_Node); + end loop; + + Strlit_Concat_Val := End_String; + + -- Create new folded node, and rewrite result with a concat- + -- enation of an empty string literal and the folded node. + + Start_String; + Empty_String_Val := End_String; + New_Node := + Make_Op_Concat (Loc, + Make_String_Literal (Loc, Empty_String_Val), + Make_String_Literal (Loc, Strlit_Concat_Val, + Is_Folded_In_Parser => True)); + Rewrite (Node1, New_Node); + end; + end if; + end; + + -- All done, we clearly do not have name or numeric literal so this + -- is a case of a simple expression which is some other possibility. + + Expr_Form := EF_Simple; + end if; + + -- Come here at end of simple expression, where we do a couple of + -- special checks to improve error recovery. + + -- Special test to improve error recovery. If the current token + -- is a period, then someone is trying to do selection on something + -- that is not a name, e.g. a qualified expression. + + if Token = Tok_Dot then + Error_Msg_SC ("prefix for selection is not a name"); + + -- If qualified expression, comment and continue, otherwise something + -- is pretty nasty so do an Error_Resync call. + + if Ada_Version < Ada_2012 + and then Nkind (Node1) = N_Qualified_Expression + then + Error_Msg_SC ("\would be legal in Ada 2012 mode"); + else + raise Error_Resync; + end if; + end if; + + -- Special test to improve error recovery: If the current token is + -- not the first token on a line (as determined by checking the + -- previous token position with the start of the current line), + -- then we insist that we have an appropriate terminating token. + -- Consider the following two examples: + + -- 1) if A nad B then ... + + -- 2) A := B + -- C := D + + -- In the first example, we would like to issue a binary operator + -- expected message and resynchronize to the then. In the second + -- example, we do not want to issue a binary operator message, so + -- that instead we will get the missing semicolon message. This + -- distinction is of course a heuristic which does not always work, + -- but in practice it is quite effective. + + -- Note: the one case in which we do not go through this circuit is + -- when we have scanned a range attribute and want to return with + -- Token pointing to the apostrophe. The apostrophe is not normally + -- an expression terminator, and is not in Token_Class_Sterm, but + -- in this special case we know that the expression is complete. + + if not Token_Is_At_Start_Of_Line + and then Token not in Token_Class_Sterm + then + -- Normally the right error message is indeed that we expected a + -- binary operator, but in the case of being between a right and left + -- paren, e.g. in an aggregate, a more likely error is missing comma. + + if Prev_Token = Tok_Right_Paren and then Token = Tok_Left_Paren then + T_Comma; + else + Error_Msg_AP ("binary operator expected"); + end if; + + raise Error_Resync; + + else + return Node1; + end if; + + -- If any error occurs, then scan to next expression terminator symbol + -- or comma, right paren or vertical bar at the outer (i.e. current) paren + -- level. Expr_Form is set to indicate a normal simple expression. + + exception + when Error_Resync => + Resync_Expression; + Expr_Form := EF_Simple; + return Error; + end P_Simple_Expression; + + ----------------------------------------------- + -- 4.4 Simple Expression or Range Attribute -- + ----------------------------------------------- + + -- SIMPLE_EXPRESSION ::= + -- [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM} + + -- RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR + + -- RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)] + + -- Error recovery: cannot raise Error_Resync + + function P_Simple_Expression_Or_Range_Attribute return Node_Id is + Sexpr : Node_Id; + Attr_Node : Node_Id; + + begin + -- We don't just want to roar ahead and call P_Simple_Expression + -- here, since we want to handle the case of a parenthesized range + -- attribute cleanly. + + if Token = Tok_Left_Paren then + declare + Lptr : constant Source_Ptr := Token_Ptr; + Scan_State : Saved_Scan_State; + + begin + Save_Scan_State (Scan_State); + Scan; -- past left paren + Sexpr := P_Simple_Expression; + + if Token = Tok_Apostrophe then + Attr_Node := P_Range_Attribute_Reference (Sexpr); + Expr_Form := EF_Range_Attr; + + if Token = Tok_Right_Paren then + Scan; -- scan past right paren if present + end if; + + Error_Msg ("parentheses not allowed for range attribute", Lptr); + + return Attr_Node; + end if; + + Restore_Scan_State (Scan_State); + end; + end if; + + -- Here after dealing with parenthesized range attribute + + Sexpr := P_Simple_Expression; + + if Token = Tok_Apostrophe then + Attr_Node := P_Range_Attribute_Reference (Sexpr); + Expr_Form := EF_Range_Attr; + return Attr_Node; + + else + return Sexpr; + end if; + end P_Simple_Expression_Or_Range_Attribute; + + --------------- + -- 4.4 Term -- + --------------- + + -- TERM ::= FACTOR {MULTIPLYING_OPERATOR FACTOR} + + -- Error recovery: can raise Error_Resync + + function P_Term return Node_Id is + Node1, Node2 : Node_Id; + Tokptr : Source_Ptr; + + begin + Node1 := P_Factor; + + loop + exit when Token not in Token_Class_Mulop; + Tokptr := Token_Ptr; + Node2 := New_Op_Node (P_Multiplying_Operator, Tokptr); + Scan; -- past operator + Set_Left_Opnd (Node2, Node1); + Set_Right_Opnd (Node2, P_Factor); + Node1 := Node2; + end loop; + + return Node1; + end P_Term; + + ----------------- + -- 4.4 Factor -- + ----------------- + + -- FACTOR ::= PRIMARY [** PRIMARY] | abs PRIMARY | not PRIMARY + + -- Error recovery: can raise Error_Resync + + function P_Factor return Node_Id is + Node1 : Node_Id; + Node2 : Node_Id; + + begin + if Token = Tok_Abs then + Node1 := New_Op_Node (N_Op_Abs, Token_Ptr); + + if Style_Check then + Style.Check_Abs_Not; + end if; + + Scan; -- past ABS + Set_Right_Opnd (Node1, P_Primary); + return Node1; + + elsif Token = Tok_Not then + Node1 := New_Op_Node (N_Op_Not, Token_Ptr); + + if Style_Check then + Style.Check_Abs_Not; + end if; + + Scan; -- past NOT + Set_Right_Opnd (Node1, P_Primary); + return Node1; + + else + Node1 := P_Primary; + + if Token = Tok_Double_Asterisk then + Node2 := New_Op_Node (N_Op_Expon, Token_Ptr); + Scan; -- past ** + Set_Left_Opnd (Node2, Node1); + Set_Right_Opnd (Node2, P_Primary); + return Node2; + else + return Node1; + end if; + end if; + end P_Factor; + + ------------------ + -- 4.4 Primary -- + ------------------ + + -- PRIMARY ::= + -- NUMERIC_LITERAL | null + -- | STRING_LITERAL | AGGREGATE + -- | NAME | QUALIFIED_EXPRESSION + -- | ALLOCATOR | (EXPRESSION) | QUANTIFIED_EXPRESSION + + -- Error recovery: can raise Error_Resync + + function P_Primary return Node_Id is + Scan_State : Saved_Scan_State; + Node1 : Node_Id; + + begin + -- The loop runs more than once only if misplaced pragmas are found + + loop + case Token is + + -- Name token can start a name, call or qualified expression, all + -- of which are acceptable possibilities for primary. Note also + -- that string literal is included in name (as operator symbol) + -- and type conversion is included in name (as indexed component). + + when Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier => + Node1 := P_Name; + + -- All done unless apostrophe follows + + if Token /= Tok_Apostrophe then + return Node1; + + -- Apostrophe following means that we have either just parsed + -- the subtype mark of a qualified expression, or the prefix + -- or a range attribute. + + else -- Token = Tok_Apostrophe + Save_Scan_State (Scan_State); -- at apostrophe + Scan; -- past apostrophe + + -- If range attribute, then this is always an error, since + -- the only legitimate case (where the scanned expression is + -- a qualified simple name) is handled at the level of the + -- Simple_Expression processing. This case corresponds to a + -- usage such as 3 + A'Range, which is always illegal. + + if Token = Tok_Range then + Restore_Scan_State (Scan_State); -- to apostrophe + Bad_Range_Attribute (Token_Ptr); + return Error; + + -- If left paren, then we have a qualified expression. + -- Note that P_Name guarantees that in this case, where + -- Token = Tok_Apostrophe on return, the only two possible + -- tokens following the apostrophe are left paren and + -- RANGE, so we know we have a left paren here. + + else -- Token = Tok_Left_Paren + return P_Qualified_Expression (Node1); + + end if; + end if; + + -- Numeric or string literal + + when Tok_Integer_Literal | + Tok_Real_Literal | + Tok_String_Literal => + + Node1 := Token_Node; + Scan; -- past number + return Node1; + + -- Left paren, starts aggregate or parenthesized expression + + when Tok_Left_Paren => + declare + Expr : constant Node_Id := P_Aggregate_Or_Paren_Expr; + + begin + if Nkind (Expr) = N_Attribute_Reference + and then Attribute_Name (Expr) = Name_Range + then + Bad_Range_Attribute (Sloc (Expr)); + end if; + + return Expr; + end; + + -- Allocator + + when Tok_New => + return P_Allocator; + + -- Null + + when Tok_Null => + Scan; -- past NULL + return New_Node (N_Null, Prev_Token_Ptr); + + -- Pragma, not allowed here, so just skip past it + + when Tok_Pragma => + P_Pragmas_Misplaced; + + -- Deal with IF (possible unparenthesized conditional expression) + + when Tok_If => + + -- If this looks like a real if, defined as an IF appearing at + -- the start of a new line, then we consider we have a missing + -- operand. + + if Token_Is_At_Start_Of_Line then + Error_Msg_AP ("missing operand"); + return Error; + + -- If this looks like a conditional expression, then treat it + -- that way with an error message. + + elsif Ada_Version >= Ada_2012 then + Error_Msg_SC + ("conditional expression must be parenthesized"); + return P_Conditional_Expression; + + -- Otherwise treat as misused identifier + + else + return P_Identifier; + end if; + + -- Deal with CASE (possible unparenthesized case expression) + + when Tok_Case => + + -- If this looks like a real case, defined as a CASE appearing + -- the start of a new line, then we consider we have a missing + -- operand. + + if Token_Is_At_Start_Of_Line then + Error_Msg_AP ("missing operand"); + return Error; + + -- If this looks like a case expression, then treat it that way + -- with an error message. + + elsif Ada_Version >= Ada_2012 then + Error_Msg_SC ("case expression must be parenthesized"); + return P_Case_Expression; + + -- Otherwise treat as misused identifier + + else + return P_Identifier; + end if; + + -- For [all | some] indicates a quantified expression + + when Tok_For => + + if Token_Is_At_Start_Of_Line then + Error_Msg_AP ("misplaced loop"); + return Error; + + elsif Ada_Version >= Ada_2012 then + Error_Msg_SC ("quantified expression must be parenthesized"); + return P_Quantified_Expression; + + else + + -- Otherwise treat as misused identifier + + return P_Identifier; + end if; + + -- Anything else is illegal as the first token of a primary, but + -- we test for a reserved identifier so that it is treated nicely + + when others => + if Is_Reserved_Identifier then + return P_Identifier; + + elsif Prev_Token = Tok_Comma then + Error_Msg_SP -- CODEFIX + ("|extra "","" ignored"); + raise Error_Resync; + + else + Error_Msg_AP ("missing operand"); + raise Error_Resync; + end if; + + end case; + end loop; + end P_Primary; + + ------------------------------- + -- 4.4 Quantified_Expression -- + ------------------------------- + + -- QUANTIFIED_EXPRESSION ::= + -- for QUANTIFIER LOOP_PARAMETER_SPECIFICATION => PREDICATE | + -- for QUANTIFIER ITERATOR_SPECIFICATION => PREDICATE + + function P_Quantified_Expression return Node_Id is + I_Spec : Node_Id; + Node1 : Node_Id; + + begin + Scan; -- past FOR + + Node1 := New_Node (N_Quantified_Expression, Prev_Token_Ptr); + + if Token = Tok_All then + Set_All_Present (Node1); + + -- We treat Some as a non-reserved keyword, so it appears to the scanner + -- as an identifier. If Some is made into a reserved word, the check + -- below is against Tok_Some. + + elsif Token /= Tok_Identifier + or else Chars (Token_Node) /= Name_Some + then + Error_Msg_AP ("missing quantifier"); + raise Error_Resync; + end if; + + Scan; -- past SOME + I_Spec := P_Loop_Parameter_Specification; + + if Nkind (I_Spec) = N_Loop_Parameter_Specification then + Set_Loop_Parameter_Specification (Node1, I_Spec); + else + Set_Iterator_Specification (Node1, I_Spec); + end if; + + if Token = Tok_Arrow then + Scan; + Set_Condition (Node1, P_Expression); + return Node1; + else + Error_Msg_AP ("missing arrow"); + raise Error_Resync; + end if; + end P_Quantified_Expression; + + --------------------------- + -- 4.5 Logical Operator -- + --------------------------- + + -- LOGICAL_OPERATOR ::= and | or | xor + + -- Note: AND THEN and OR ELSE are also treated as logical operators + -- by the parser (even though they are not operators semantically) + + -- The value returned is the appropriate Node_Kind code for the operator + -- On return, Token points to the token following the scanned operator. + + -- The caller has checked that the first token is a legitimate logical + -- operator token (i.e. is either XOR, AND, OR). + + -- Error recovery: cannot raise Error_Resync + + function P_Logical_Operator return Node_Kind is + begin + if Token = Tok_And then + if Style_Check then + Style.Check_Binary_Operator; + end if; + + Scan; -- past AND + + if Token = Tok_Then then + Scan; -- past THEN + return N_And_Then; + else + return N_Op_And; + end if; + + elsif Token = Tok_Or then + if Style_Check then + Style.Check_Binary_Operator; + end if; + + Scan; -- past OR + + if Token = Tok_Else then + Scan; -- past ELSE + return N_Or_Else; + else + return N_Op_Or; + end if; + + else -- Token = Tok_Xor + if Style_Check then + Style.Check_Binary_Operator; + end if; + + Scan; -- past XOR + return N_Op_Xor; + end if; + end P_Logical_Operator; + + ------------------------------ + -- 4.5 Relational Operator -- + ------------------------------ + + -- RELATIONAL_OPERATOR ::= = | /= | < | <= | > | >= + + -- The value returned is the appropriate Node_Kind code for the operator. + -- On return, Token points to the operator token, NOT past it. + + -- The caller has checked that the first token is a legitimate relational + -- operator token (i.e. is one of the operator tokens listed above). + + -- Error recovery: cannot raise Error_Resync + + function P_Relational_Operator return Node_Kind is + Op_Kind : Node_Kind; + Relop_Node : constant array (Token_Class_Relop) of Node_Kind := + (Tok_Less => N_Op_Lt, + Tok_Equal => N_Op_Eq, + Tok_Greater => N_Op_Gt, + Tok_Not_Equal => N_Op_Ne, + Tok_Greater_Equal => N_Op_Ge, + Tok_Less_Equal => N_Op_Le, + Tok_In => N_In, + Tok_Not => N_Not_In, + Tok_Box => N_Op_Ne); + + begin + if Token = Tok_Box then + Error_Msg_SC -- CODEFIX + ("|""'<'>"" should be ""/="""); + end if; + + Op_Kind := Relop_Node (Token); + + if Style_Check then + Style.Check_Binary_Operator; + end if; + + Scan; -- past operator token + + if Prev_Token = Tok_Not then + T_In; + end if; + + return Op_Kind; + end P_Relational_Operator; + + --------------------------------- + -- 4.5 Binary Adding Operator -- + --------------------------------- + + -- BINARY_ADDING_OPERATOR ::= + | - | & + + -- The value returned is the appropriate Node_Kind code for the operator. + -- On return, Token points to the operator token (NOT past it). + + -- The caller has checked that the first token is a legitimate adding + -- operator token (i.e. is one of the operator tokens listed above). + + -- Error recovery: cannot raise Error_Resync + + function P_Binary_Adding_Operator return Node_Kind is + Addop_Node : constant array (Token_Class_Binary_Addop) of Node_Kind := + (Tok_Ampersand => N_Op_Concat, + Tok_Minus => N_Op_Subtract, + Tok_Plus => N_Op_Add); + begin + return Addop_Node (Token); + end P_Binary_Adding_Operator; + + -------------------------------- + -- 4.5 Unary Adding Operator -- + -------------------------------- + + -- UNARY_ADDING_OPERATOR ::= + | - + + -- The value returned is the appropriate Node_Kind code for the operator. + -- On return, Token points to the operator token (NOT past it). + + -- The caller has checked that the first token is a legitimate adding + -- operator token (i.e. is one of the operator tokens listed above). + + -- Error recovery: cannot raise Error_Resync + + function P_Unary_Adding_Operator return Node_Kind is + Addop_Node : constant array (Token_Class_Unary_Addop) of Node_Kind := + (Tok_Minus => N_Op_Minus, + Tok_Plus => N_Op_Plus); + begin + return Addop_Node (Token); + end P_Unary_Adding_Operator; + + ------------------------------- + -- 4.5 Multiplying Operator -- + ------------------------------- + + -- MULTIPLYING_OPERATOR ::= * | / | mod | rem + + -- The value returned is the appropriate Node_Kind code for the operator. + -- On return, Token points to the operator token (NOT past it). + + -- The caller has checked that the first token is a legitimate multiplying + -- operator token (i.e. is one of the operator tokens listed above). + + -- Error recovery: cannot raise Error_Resync + + function P_Multiplying_Operator return Node_Kind is + Mulop_Node : constant array (Token_Class_Mulop) of Node_Kind := + (Tok_Asterisk => N_Op_Multiply, + Tok_Mod => N_Op_Mod, + Tok_Rem => N_Op_Rem, + Tok_Slash => N_Op_Divide); + begin + return Mulop_Node (Token); + end P_Multiplying_Operator; + + -------------------------------------- + -- 4.5 Highest Precedence Operator -- + -------------------------------------- + + -- Parsed by P_Factor (4.4) + + -- Note: this rule is not in fact used by the grammar at any point! + + -------------------------- + -- 4.6 Type Conversion -- + -------------------------- + + -- Parsed by P_Primary as a Name (4.1) + + ------------------------------- + -- 4.7 Qualified Expression -- + ------------------------------- + + -- QUALIFIED_EXPRESSION ::= + -- SUBTYPE_MARK ' (EXPRESSION) | SUBTYPE_MARK ' AGGREGATE + + -- The caller has scanned the name which is the Subtype_Mark parameter + -- and scanned past the single quote following the subtype mark. The + -- caller has not checked that this name is in fact appropriate for + -- a subtype mark name (i.e. it is a selected component or identifier). + + -- Error_Recovery: cannot raise Error_Resync + + function P_Qualified_Expression (Subtype_Mark : Node_Id) return Node_Id is + Qual_Node : Node_Id; + begin + Qual_Node := New_Node (N_Qualified_Expression, Prev_Token_Ptr); + Set_Subtype_Mark (Qual_Node, Check_Subtype_Mark (Subtype_Mark)); + Set_Expression (Qual_Node, P_Aggregate_Or_Paren_Expr); + return Qual_Node; + end P_Qualified_Expression; + + -------------------- + -- 4.8 Allocator -- + -------------------- + + -- ALLOCATOR ::= + -- new [NULL_EXCLUSION] SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION + + -- The caller has checked that the initial token is NEW + + -- Error recovery: can raise Error_Resync + + function P_Allocator return Node_Id is + Alloc_Node : Node_Id; + Type_Node : Node_Id; + Null_Exclusion_Present : Boolean; + + begin + Alloc_Node := New_Node (N_Allocator, Token_Ptr); + T_New; + + -- Scan Null_Exclusion if present (Ada 2005 (AI-231)) + + Null_Exclusion_Present := P_Null_Exclusion; + Set_Null_Exclusion_Present (Alloc_Node, Null_Exclusion_Present); + Type_Node := P_Subtype_Mark_Resync; + + if Token = Tok_Apostrophe then + Scan; -- past apostrophe + Set_Expression (Alloc_Node, P_Qualified_Expression (Type_Node)); + else + Set_Expression + (Alloc_Node, + P_Subtype_Indication (Type_Node, Null_Exclusion_Present)); + end if; + + return Alloc_Node; + end P_Allocator; + + ----------------------- + -- P_Case_Expression -- + ----------------------- + + function P_Case_Expression return Node_Id is + Loc : constant Source_Ptr := Token_Ptr; + Case_Node : Node_Id; + Save_State : Saved_Scan_State; + + begin + if Ada_Version < Ada_2012 then + Error_Msg_SC ("|case expression is an Ada 2012 feature"); + Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch"); + end if; + + Scan; -- past CASE + Case_Node := + Make_Case_Expression (Loc, + Expression => P_Expression_No_Right_Paren, + Alternatives => New_List); + T_Is; + + -- We now have scanned out CASE expression IS, scan alternatives + + loop + T_When; + Append_To (Alternatives (Case_Node), P_Case_Expression_Alternative); + + -- Missing comma if WHEN (more alternatives present) + + if Token = Tok_When then + T_Comma; + + -- If comma/WHEN, skip comma and we have another alternative + + elsif Token = Tok_Comma then + Save_Scan_State (Save_State); + Scan; -- past comma + + if Token /= Tok_When then + Restore_Scan_State (Save_State); + exit; + end if; + + -- If no comma or WHEN, definitely done + + else + exit; + end if; + end loop; + + -- If we have an END CASE, diagnose as not needed + + if Token = Tok_End then + Error_Msg_SC ("`END CASE` not allowed at end of case expression"); + Scan; -- past END + + if Token = Tok_Case then + Scan; -- past CASE; + end if; + end if; + + -- Return the Case_Expression node + + return Case_Node; + end P_Case_Expression; + + ----------------------------------- + -- P_Case_Expression_Alternative -- + ----------------------------------- + + -- CASE_STATEMENT_ALTERNATIVE ::= + -- when DISCRETE_CHOICE_LIST => + -- EXPRESSION + + -- The caller has checked that and scanned past the initial WHEN token + -- Error recovery: can raise Error_Resync + + function P_Case_Expression_Alternative return Node_Id is + Case_Alt_Node : Node_Id; + begin + Case_Alt_Node := New_Node (N_Case_Expression_Alternative, Token_Ptr); + Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List); + TF_Arrow; + Set_Expression (Case_Alt_Node, P_Expression); + return Case_Alt_Node; + end P_Case_Expression_Alternative; + + ------------------------------ + -- P_Conditional_Expression -- + ------------------------------ + + function P_Conditional_Expression return Node_Id is + Exprs : constant List_Id := New_List; + Loc : constant Source_Ptr := Token_Ptr; + Expr : Node_Id; + State : Saved_Scan_State; + + begin + Inside_Conditional_Expression := Inside_Conditional_Expression + 1; + + if Token = Tok_If and then Ada_Version < Ada_2012 then + Error_Msg_SC ("|conditional expression is an Ada 2012 feature"); + Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch"); + end if; + + Scan; -- past IF or ELSIF + Append_To (Exprs, P_Condition); + TF_Then; + Append_To (Exprs, P_Expression); + + -- We now have scanned out IF expr THEN expr + + -- Check for common error of semicolon before the ELSE + + if Token = Tok_Semicolon then + Save_Scan_State (State); + Scan; -- past semicolon + + if Token = Tok_Else or else Token = Tok_Elsif then + Error_Msg_SP -- CODEFIX + ("|extra "";"" ignored"); + + else + Restore_Scan_State (State); + end if; + end if; + + -- Scan out ELSIF sequence if present + + if Token = Tok_Elsif then + Expr := P_Conditional_Expression; + Set_Is_Elsif (Expr); + Append_To (Exprs, Expr); + + -- Scan out ELSE phrase if present + + elsif Token = Tok_Else then + + -- Scan out ELSE expression + + Scan; -- Past ELSE + Append_To (Exprs, P_Expression); + + -- Two expression case (implied True, filled in during semantics) + + else + null; + end if; + + -- If we have an END IF, diagnose as not needed + + if Token = Tok_End then + Error_Msg_SC + ("`END IF` not allowed at end of conditional expression"); + Scan; -- past END + + if Token = Tok_If then + Scan; -- past IF; + end if; + end if; + + Inside_Conditional_Expression := Inside_Conditional_Expression - 1; + + -- Return the Conditional_Expression node + + return + Make_Conditional_Expression (Loc, + Expressions => Exprs); + end P_Conditional_Expression; + + ----------------------- + -- P_Membership_Test -- + ----------------------- + + -- MEMBERSHIP_CHOICE_LIST ::= MEMBERHIP_CHOICE {'|' MEMBERSHIP_CHOICE} + -- MEMBERSHIP_CHOICE ::= CHOICE_EXPRESSION | range | subtype_mark + + procedure P_Membership_Test (N : Node_Id) is + Alt : constant Node_Id := + P_Range_Or_Subtype_Mark + (Allow_Simple_Expression => (Ada_Version >= Ada_2012)); + + begin + -- Set case + + if Token = Tok_Vertical_Bar then + if Ada_Version < Ada_2012 then + Error_Msg_SC ("set notation is an Ada 2012 feature"); + Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch"); + end if; + + Set_Alternatives (N, New_List (Alt)); + Set_Right_Opnd (N, Empty); + + -- Loop to accumulate alternatives + + while Token = Tok_Vertical_Bar loop + Scan; -- past vertical bar + Append_To + (Alternatives (N), + P_Range_Or_Subtype_Mark (Allow_Simple_Expression => True)); + end loop; + + -- Not set case + + else + Set_Right_Opnd (N, Alt); + Set_Alternatives (N, No_List); + end if; + end P_Membership_Test; + +end Ch4; diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb new file mode 100644 index 000000000..194959572 --- /dev/null +++ b/gcc/ada/par-ch5.adb @@ -0,0 +1,2382 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 5 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +separate (Par) +package body Ch5 is + + -- Local functions, used only in this chapter + + function P_Case_Statement return Node_Id; + function P_Case_Statement_Alternative return Node_Id; + function P_Exit_Statement return Node_Id; + function P_Goto_Statement return Node_Id; + function P_If_Statement return Node_Id; + function P_Label return Node_Id; + function P_Null_Statement return Node_Id; + + function P_Assignment_Statement (LHS : Node_Id) return Node_Id; + -- Parse assignment statement. On entry, the caller has scanned the left + -- hand side (passed in as Lhs), and the colon-equal (or some symbol + -- taken to be an error equivalent such as equal). + + function P_Begin_Statement (Block_Name : Node_Id := Empty) return Node_Id; + -- Parse begin-end statement. If Block_Name is non-Empty on entry, it is + -- the N_Identifier node for the label on the block. If Block_Name is + -- Empty on entry (the default), then the block statement is unlabeled. + + function P_Declare_Statement (Block_Name : Node_Id := Empty) return Node_Id; + -- Parse declare block. If Block_Name is non-Empty on entry, it is + -- the N_Identifier node for the label on the block. If Block_Name is + -- Empty on entry (the default), then the block statement is unlabeled. + + function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id; + -- Parse for statement. If Loop_Name is non-Empty on entry, it is + -- the N_Identifier node for the label on the loop. If Loop_Name is + -- Empty on entry (the default), then the for statement is unlabeled. + + function P_Iterator_Specification (Def_Id : Node_Id) return Node_Id; + -- Parse an iterator specification. The defining identifier has already + -- been scanned, as it is the common prefix between loop and iterator + -- specification. + + function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id; + -- Parse loop statement. If Loop_Name is non-Empty on entry, it is + -- the N_Identifier node for the label on the loop. If Loop_Name is + -- Empty on entry (the default), then the loop statement is unlabeled. + + function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id; + -- Parse while statement. If Loop_Name is non-Empty on entry, it is + -- the N_Identifier node for the label on the loop. If Loop_Name is + -- Empty on entry (the default), then the while statement is unlabeled. + + function Set_Loop_Block_Name (L : Character) return Name_Id; + -- Given a letter 'L' for a loop or 'B' for a block, returns a name + -- of the form L_nn or B_nn where nn is a serial number obtained by + -- incrementing the variable Loop_Block_Count. + + procedure Then_Scan; + -- Scan past THEN token, testing for illegal junk after it + + --------------------------------- + -- 5.1 Sequence of Statements -- + --------------------------------- + + -- SEQUENCE_OF_STATEMENTS ::= STATEMENT {STATEMENT} {LABEL} + -- Note: the final label is an Ada 2012 addition. + + -- STATEMENT ::= + -- {LABEL} SIMPLE_STATEMENT | {LABEL} COMPOUND_STATEMENT + + -- SIMPLE_STATEMENT ::= NULL_STATEMENT + -- | ASSIGNMENT_STATEMENT | EXIT_STATEMENT + -- | GOTO_STATEMENT | PROCEDURE_CALL_STATEMENT + -- | RETURN_STATEMENT | ENTRY_CALL_STATEMENT + -- | REQUEUE_STATEMENT | DELAY_STATEMENT + -- | ABORT_STATEMENT | RAISE_STATEMENT + -- | CODE_STATEMENT + + -- COMPOUND_STATEMENT ::= + -- IF_STATEMENT | CASE_STATEMENT + -- | LOOP_STATEMENT | BLOCK_STATEMENT + -- | ACCEPT_STATEMENT | SELECT_STATEMENT + + -- This procedure scans a sequence of statements. The caller sets SS_Flags + -- to indicate acceptable termination conditions for the sequence: + + -- SS_Flags.Eftm Terminate on ELSIF + -- SS_Flags.Eltm Terminate on ELSE + -- SS_Flags.Extm Terminate on EXCEPTION + -- SS_Flags.Ortm Terminate on OR + -- SS_Flags.Tatm Terminate on THEN ABORT (Token = ABORT on return) + -- SS_Flags.Whtm Terminate on WHEN + -- SS_Flags.Unco Unconditional terminate after scanning one statement + + -- In addition, the scan is always terminated by encountering END or the + -- end of file (EOF) condition. If one of the six above terminators is + -- encountered with the corresponding SS_Flags flag not set, then the + -- action taken is as follows: + + -- If the keyword occurs to the left of the expected column of the end + -- for the current sequence (as recorded in the current end context), + -- then it is assumed to belong to an outer context, and is considered + -- to terminate the sequence of statements. + + -- If the keyword occurs to the right of, or in the expected column of + -- the end for the current sequence, then an error message is output, + -- the keyword together with its associated context is skipped, and + -- the statement scan continues until another terminator is found. + + -- Note that the first action means that control can return to the caller + -- with Token set to a terminator other than one of those specified by the + -- SS parameter. The caller should treat such a case as equivalent to END. + + -- In addition, the flag SS_Flags.Sreq is set to True to indicate that at + -- least one real statement (other than a pragma) is required in the + -- statement sequence. During the processing of the sequence, this + -- flag is manipulated to indicate the current status of the requirement + -- for a statement. For example, it is turned off by the occurrence of a + -- statement, and back on by a label (which requires a following statement) + + -- Error recovery: cannot raise Error_Resync. If an error occurs during + -- parsing a statement, then the scan pointer is advanced past the next + -- semicolon and the parse continues. + + function P_Sequence_Of_Statements (SS_Flags : SS_Rec) return List_Id is + + Statement_Required : Boolean; + -- This flag indicates if a subsequent statement (other than a pragma) + -- is required. It is initialized from the Sreq flag, and modified as + -- statements are scanned (a statement turns it off, and a label turns + -- it back on again since a statement must follow a label). + -- Note : this final requirement is lifted in Ada 2012. + + Statement_Seen : Boolean; + -- In Ada 2012, a label can end a sequence of statements, but the + -- sequence cannot contain only labels. This flag is set whenever a + -- label is encountered, to enforce this rule at the end of a sequence. + + Declaration_Found : Boolean := False; + -- This flag is set True if a declaration is encountered, so that the + -- error message about declarations in the statement part is only + -- given once for a given sequence of statements. + + Scan_State_Label : Saved_Scan_State; + Scan_State : Saved_Scan_State; + + Statement_List : List_Id; + Block_Label : Name_Id; + Id_Node : Node_Id; + Name_Node : Node_Id; + + procedure Junk_Declaration; + -- Procedure called to handle error of declaration encountered in + -- statement sequence. + + procedure Test_Statement_Required; + -- Flag error if Statement_Required flag set + + ---------------------- + -- Junk_Declaration -- + ---------------------- + + procedure Junk_Declaration is + begin + if (not Declaration_Found) or All_Errors_Mode then + Error_Msg_SC -- CODEFIX + ("declarations must come before BEGIN"); + Declaration_Found := True; + end if; + + Skip_Declaration (Statement_List); + end Junk_Declaration; + + ----------------------------- + -- Test_Statement_Required -- + ----------------------------- + + procedure Test_Statement_Required is + function All_Pragmas return Boolean; + -- Return True if statement list is all pragmas + + ----------------- + -- All_Pragmas -- + ----------------- + + function All_Pragmas return Boolean is + S : Node_Id; + begin + S := First (Statement_List); + while Present (S) loop + if Nkind (S) /= N_Pragma then + return False; + else + Next (S); + end if; + end loop; + + return True; + end All_Pragmas; + + -- Start of processing for Test_Statement_Required + + begin + if Statement_Required then + + -- Check no statement required after label in Ada 2012, and that + -- it is OK to have nothing but pragmas in a statement sequence. + + if Ada_Version >= Ada_2012 + and then not Is_Empty_List (Statement_List) + and then + ((Nkind (Last (Statement_List)) = N_Label + and then Statement_Seen) + or else All_Pragmas) + then + declare + Null_Stm : constant Node_Id := + Make_Null_Statement (Token_Ptr); + begin + Set_Comes_From_Source (Null_Stm, False); + Append_To (Statement_List, Null_Stm); + end; + + -- If not Ada 2012, or not special case above, give error message + + else + Error_Msg_BC -- CODEFIX + ("statement expected"); + end if; + end if; + end Test_Statement_Required; + + -- Start of processing for P_Sequence_Of_Statements + + begin + Statement_List := New_List; + Statement_Required := SS_Flags.Sreq; + Statement_Seen := False; + + loop + Ignore (Tok_Semicolon); + + begin + if Style_Check then + Style.Check_Indentation; + end if; + + -- Deal with reserved identifier (in assignment or call) + + if Is_Reserved_Identifier then + Save_Scan_State (Scan_State); -- at possible bad identifier + Scan; -- and scan past it + + -- We have an reserved word which is spelled in identifier + -- style, so the question is whether it really is intended + -- to be an identifier. + + if + -- If followed by a semicolon, then it is an identifier, + -- with the exception of the cases tested for below. + + (Token = Tok_Semicolon + and then Prev_Token /= Tok_Return + and then Prev_Token /= Tok_Null + and then Prev_Token /= Tok_Raise + and then Prev_Token /= Tok_End + and then Prev_Token /= Tok_Exit) + + -- If followed by colon, colon-equal, or dot, then we + -- definitely have an identifier (could not be reserved) + + or else Token = Tok_Colon + or else Token = Tok_Colon_Equal + or else Token = Tok_Dot + + -- Left paren means we have an identifier except for those + -- reserved words that can legitimately be followed by a + -- left paren. + + or else + (Token = Tok_Left_Paren + and then Prev_Token /= Tok_Case + and then Prev_Token /= Tok_Delay + and then Prev_Token /= Tok_If + and then Prev_Token /= Tok_Elsif + and then Prev_Token /= Tok_Return + and then Prev_Token /= Tok_When + and then Prev_Token /= Tok_While + and then Prev_Token /= Tok_Separate) + then + -- Here we have an apparent reserved identifier and the + -- token past it is appropriate to this usage (and would + -- be a definite error if this is not an identifier). What + -- we do is to use P_Identifier to fix up the identifier, + -- and then fall into the normal processing. + + Restore_Scan_State (Scan_State); -- back to the ID + Scan_Reserved_Identifier (Force_Msg => False); + + -- Not a reserved identifier after all (or at least we can't + -- be sure that it is), so reset the scan and continue. + + else + Restore_Scan_State (Scan_State); -- back to the reserved word + end if; + end if; + + -- Now look to see what kind of statement we have + + case Token is + + -- Case of end or EOF + + when Tok_End | Tok_EOF => + + -- These tokens always terminate the statement sequence + + Test_Statement_Required; + exit; + + -- Case of ELSIF + + when Tok_Elsif => + + -- Terminate if Eftm set or if the ELSIF is to the left + -- of the expected column of the end for this sequence + + if SS_Flags.Eftm + or else Start_Column < Scope.Table (Scope.Last).Ecol + then + Test_Statement_Required; + exit; + + -- Otherwise complain and skip past ELSIF Condition then + + else + Error_Msg_SC ("ELSIF not allowed here"); + Scan; -- past ELSIF + Discard_Junk_Node (P_Expression_No_Right_Paren); + Then_Scan; + Statement_Required := False; + end if; + + -- Case of ELSE + + when Tok_Else => + + -- Terminate if Eltm set or if the else is to the left + -- of the expected column of the end for this sequence + + if SS_Flags.Eltm + or else Start_Column < Scope.Table (Scope.Last).Ecol + then + Test_Statement_Required; + exit; + + -- Otherwise complain and skip past else + + else + Error_Msg_SC ("ELSE not allowed here"); + Scan; -- past ELSE + Statement_Required := False; + end if; + + -- Case of exception + + when Tok_Exception => + Test_Statement_Required; + + -- If Extm not set and the exception is not to the left of + -- the expected column of the end for this sequence, then we + -- assume it belongs to the current sequence, even though it + -- is not permitted. + + if not SS_Flags.Extm and then + Start_Column >= Scope.Table (Scope.Last).Ecol + + then + Error_Msg_SC ("exception handler not permitted here"); + Scan; -- past EXCEPTION + Discard_Junk_List (Parse_Exception_Handlers); + end if; + + -- Always return, in the case where we scanned out handlers + -- that we did not expect, Parse_Exception_Handlers returned + -- with Token being either end or EOF, so we are OK. + + exit; + + -- Case of OR + + when Tok_Or => + + -- Terminate if Ortm set or if the or is to the left of the + -- expected column of the end for this sequence. + + if SS_Flags.Ortm + or else Start_Column < Scope.Table (Scope.Last).Ecol + then + Test_Statement_Required; + exit; + + -- Otherwise complain and skip past or + + else + Error_Msg_SC ("OR not allowed here"); + Scan; -- past or + Statement_Required := False; + end if; + + -- Case of THEN (deal also with THEN ABORT) + + when Tok_Then => + Save_Scan_State (Scan_State); -- at THEN + Scan; -- past THEN + + -- Terminate if THEN ABORT allowed (ATC case) + + exit when SS_Flags.Tatm and then Token = Tok_Abort; + + -- Otherwise we treat THEN as some kind of mess where we did + -- not see the associated IF, but we pick up assuming it had + -- been there! + + Restore_Scan_State (Scan_State); -- to THEN + Append_To (Statement_List, P_If_Statement); + Statement_Required := False; + + -- Case of WHEN (error because we are not in a case) + + when Tok_When | Tok_Others => + + -- Terminate if Whtm set or if the WHEN is to the left of + -- the expected column of the end for this sequence. + + if SS_Flags.Whtm + or else Start_Column < Scope.Table (Scope.Last).Ecol + then + Test_Statement_Required; + exit; + + -- Otherwise complain and skip when Choice {| Choice} => + + else + Error_Msg_SC ("WHEN not allowed here"); + Scan; -- past when + Discard_Junk_List (P_Discrete_Choice_List); + TF_Arrow; + Statement_Required := False; + end if; + + -- Cases of statements starting with an identifier + + when Tok_Identifier => + Check_Bad_Layout; + + -- Save scan pointers and line number in case block label + + Id_Node := Token_Node; + Block_Label := Token_Name; + Save_Scan_State (Scan_State_Label); -- at possible label + Scan; -- past Id + + -- Check for common case of assignment, since it occurs + -- frequently, and we want to process it efficiently. + + if Token = Tok_Colon_Equal then + Scan; -- past the colon-equal + Append_To (Statement_List, + P_Assignment_Statement (Id_Node)); + Statement_Required := False; + + -- Check common case of procedure call, another case that + -- we want to speed up as much as possible. + + elsif Token = Tok_Semicolon then + Append_To (Statement_List, + P_Statement_Name (Id_Node)); + Scan; -- past semicolon + Statement_Required := False; + + -- Check for case of "go to" in place of "goto" + + elsif Token = Tok_Identifier + and then Block_Label = Name_Go + and then Token_Name = Name_To + then + Error_Msg_SP -- CODEFIX + ("goto is one word"); + Append_To (Statement_List, P_Goto_Statement); + Statement_Required := False; + + -- Check common case of = used instead of :=, just so we + -- give a better error message for this special misuse. + + elsif Token = Tok_Equal then + T_Colon_Equal; -- give := expected message + Append_To (Statement_List, + P_Assignment_Statement (Id_Node)); + Statement_Required := False; + + -- Check case of loop label or block label + + elsif Token = Tok_Colon + or else (Token in Token_Class_Labeled_Stmt + and then not Token_Is_At_Start_Of_Line) + then + T_Colon; -- past colon (if there, or msg for missing one) + + -- Test for more than one label + + loop + exit when Token /= Tok_Identifier; + Save_Scan_State (Scan_State); -- at second Id + Scan; -- past Id + + if Token = Tok_Colon then + Error_Msg_SP + ("only one label allowed on block or loop"); + Scan; -- past colon on extra label + + -- Use the second label as the "real" label + + Scan_State_Label := Scan_State; + + -- We will set Error_name as the Block_Label since + -- we really don't know which of the labels might + -- be used at the end of the loop or block! + + Block_Label := Error_Name; + + -- If Id with no colon, then backup to point to the + -- Id and we will issue the message below when we try + -- to scan out the statement as some other form. + + else + Restore_Scan_State (Scan_State); -- to second Id + exit; + end if; + end loop; + + -- Loop_Statement (labeled Loop_Statement) + + if Token = Tok_Loop then + Append_To (Statement_List, + P_Loop_Statement (Id_Node)); + + -- While statement (labeled loop statement with WHILE) + + elsif Token = Tok_While then + Append_To (Statement_List, + P_While_Statement (Id_Node)); + + -- Declare statement (labeled block statement with + -- DECLARE part) + + elsif Token = Tok_Declare then + Append_To (Statement_List, + P_Declare_Statement (Id_Node)); + + -- Begin statement (labeled block statement with no + -- DECLARE part) + + elsif Token = Tok_Begin then + Append_To (Statement_List, + P_Begin_Statement (Id_Node)); + + -- For statement (labeled loop statement with FOR) + + elsif Token = Tok_For then + Append_To (Statement_List, + P_For_Statement (Id_Node)); + + -- Improper statement follows label. If we have an + -- expression token, then assume the colon was part + -- of a misplaced declaration. + + elsif Token not in Token_Class_Eterm then + Restore_Scan_State (Scan_State_Label); + Junk_Declaration; + + -- Otherwise complain we have inappropriate statement + + else + Error_Msg_AP + ("loop or block statement must follow label"); + end if; + + Statement_Required := False; + + -- Here we have an identifier followed by something + -- other than a colon, semicolon or assignment symbol. + -- The only valid possibility is a name extension symbol + + elsif Token in Token_Class_Namext then + Restore_Scan_State (Scan_State_Label); -- to Id + Name_Node := P_Name; + + -- Skip junk right parens in this context + + Ignore (Tok_Right_Paren); + + -- Check context following call + + if Token = Tok_Colon_Equal then + Scan; -- past colon equal + Append_To (Statement_List, + P_Assignment_Statement (Name_Node)); + Statement_Required := False; + + -- Check common case of = used instead of := + + elsif Token = Tok_Equal then + T_Colon_Equal; -- give := expected message + Append_To (Statement_List, + P_Assignment_Statement (Name_Node)); + Statement_Required := False; + + -- Check apostrophe cases + + elsif Token = Tok_Apostrophe then + Append_To (Statement_List, + P_Code_Statement (Name_Node)); + Statement_Required := False; + + -- The only other valid item after a name is ; which + -- means that the item we just scanned was a call. + + elsif Token = Tok_Semicolon then + Append_To (Statement_List, + P_Statement_Name (Name_Node)); + Scan; -- past semicolon + Statement_Required := False; + + -- A slash following an identifier or a selected + -- component in this situation is most likely a period + -- (see location of keys on keyboard). + + elsif Token = Tok_Slash + and then (Nkind (Name_Node) = N_Identifier + or else + Nkind (Name_Node) = N_Selected_Component) + then + Error_Msg_SC -- CODEFIX + ("""/"" should be ""."""); + Statement_Required := False; + raise Error_Resync; + + -- Else we have a missing semicolon + + else + TF_Semicolon; + Statement_Required := False; + end if; + + -- If junk after identifier, check if identifier is an + -- instance of an incorrectly spelled keyword. If so, we + -- do nothing. The Bad_Spelling_Of will have reset Token + -- to the appropriate keyword, so the next time round the + -- loop we will process the modified token. Note that we + -- check for ELSIF before ELSE here. That's not accidental. + -- We don't want to identify a misspelling of ELSE as + -- ELSIF, and in particular we do not want to treat ELSEIF + -- as ELSE IF. + + else + Restore_Scan_State (Scan_State_Label); -- to identifier + + if Bad_Spelling_Of (Tok_Abort) + or else Bad_Spelling_Of (Tok_Accept) + or else Bad_Spelling_Of (Tok_Case) + or else Bad_Spelling_Of (Tok_Declare) + or else Bad_Spelling_Of (Tok_Delay) + or else Bad_Spelling_Of (Tok_Elsif) + or else Bad_Spelling_Of (Tok_Else) + or else Bad_Spelling_Of (Tok_End) + or else Bad_Spelling_Of (Tok_Exception) + or else Bad_Spelling_Of (Tok_Exit) + or else Bad_Spelling_Of (Tok_For) + or else Bad_Spelling_Of (Tok_Goto) + or else Bad_Spelling_Of (Tok_If) + or else Bad_Spelling_Of (Tok_Loop) + or else Bad_Spelling_Of (Tok_Or) + or else Bad_Spelling_Of (Tok_Pragma) + or else Bad_Spelling_Of (Tok_Raise) + or else Bad_Spelling_Of (Tok_Requeue) + or else Bad_Spelling_Of (Tok_Return) + or else Bad_Spelling_Of (Tok_Select) + or else Bad_Spelling_Of (Tok_When) + or else Bad_Spelling_Of (Tok_While) + then + null; + + -- If not a bad spelling, then we really have junk + + else + Scan; -- past identifier again + + -- If next token is first token on line, then we + -- consider that we were missing a semicolon after + -- the identifier, and process it as a procedure + -- call with no parameters. + + if Token_Is_At_Start_Of_Line then + Append_To (Statement_List, + P_Statement_Name (Id_Node)); + T_Semicolon; -- to give error message + Statement_Required := False; + + -- Otherwise we give a missing := message and + -- simply abandon the junk that is there now. + + else + T_Colon_Equal; -- give := expected message + raise Error_Resync; + end if; + + end if; + end if; + + -- Statement starting with operator symbol. This could be + -- a call, a name starting an assignment, or a qualified + -- expression. + + when Tok_Operator_Symbol => + Check_Bad_Layout; + Name_Node := P_Name; + + -- An attempt at a range attribute or a qualified expression + -- must be illegal here (a code statement cannot possibly + -- allow qualification by a function name). + + if Token = Tok_Apostrophe then + Error_Msg_SC ("apostrophe illegal here"); + raise Error_Resync; + end if; + + -- Scan possible assignment if we have a name + + if Expr_Form = EF_Name + and then Token = Tok_Colon_Equal + then + Scan; -- past colon equal + Append_To (Statement_List, + P_Assignment_Statement (Name_Node)); + else + Append_To (Statement_List, + P_Statement_Name (Name_Node)); + end if; + + TF_Semicolon; + Statement_Required := False; + + -- Label starting with << which must precede real statement + -- Note: in Ada 2012, the label may end the sequence. + + when Tok_Less_Less => + if Present (Last (Statement_List)) + and then Nkind (Last (Statement_List)) /= N_Label + then + Statement_Seen := True; + end if; + + Append_To (Statement_List, P_Label); + Statement_Required := True; + + -- Pragma appearing as a statement in a statement sequence + + when Tok_Pragma => + Check_Bad_Layout; + Append_To (Statement_List, P_Pragma); + + -- Abort_Statement + + when Tok_Abort => + Check_Bad_Layout; + Append_To (Statement_List, P_Abort_Statement); + Statement_Required := False; + + -- Accept_Statement + + when Tok_Accept => + Check_Bad_Layout; + Append_To (Statement_List, P_Accept_Statement); + Statement_Required := False; + + -- Begin_Statement (Block_Statement with no declare, no label) + + when Tok_Begin => + Check_Bad_Layout; + Append_To (Statement_List, P_Begin_Statement); + Statement_Required := False; + + -- Case_Statement + + when Tok_Case => + Check_Bad_Layout; + Append_To (Statement_List, P_Case_Statement); + Statement_Required := False; + + -- Block_Statement with DECLARE and no label + + when Tok_Declare => + Check_Bad_Layout; + Append_To (Statement_List, P_Declare_Statement); + Statement_Required := False; + + -- Delay_Statement + + when Tok_Delay => + Check_Bad_Layout; + Append_To (Statement_List, P_Delay_Statement); + Statement_Required := False; + + -- Exit_Statement + + when Tok_Exit => + Check_Bad_Layout; + Append_To (Statement_List, P_Exit_Statement); + Statement_Required := False; + + -- Loop_Statement with FOR and no label + + when Tok_For => + Check_Bad_Layout; + Append_To (Statement_List, P_For_Statement); + Statement_Required := False; + + -- Goto_Statement + + when Tok_Goto => + Check_Bad_Layout; + Append_To (Statement_List, P_Goto_Statement); + Statement_Required := False; + + -- If_Statement + + when Tok_If => + Check_Bad_Layout; + Append_To (Statement_List, P_If_Statement); + Statement_Required := False; + + -- Loop_Statement + + when Tok_Loop => + Check_Bad_Layout; + Append_To (Statement_List, P_Loop_Statement); + Statement_Required := False; + + -- Null_Statement + + when Tok_Null => + Check_Bad_Layout; + Append_To (Statement_List, P_Null_Statement); + Statement_Required := False; + + -- Raise_Statement + + when Tok_Raise => + Check_Bad_Layout; + Append_To (Statement_List, P_Raise_Statement); + Statement_Required := False; + + -- Requeue_Statement + + when Tok_Requeue => + Check_Bad_Layout; + Append_To (Statement_List, P_Requeue_Statement); + Statement_Required := False; + + -- Return_Statement + + when Tok_Return => + Check_Bad_Layout; + Append_To (Statement_List, P_Return_Statement); + Statement_Required := False; + + -- Select_Statement + + when Tok_Select => + Check_Bad_Layout; + Append_To (Statement_List, P_Select_Statement); + Statement_Required := False; + + -- While_Statement (Block_Statement with while and no loop) + + when Tok_While => + Check_Bad_Layout; + Append_To (Statement_List, P_While_Statement); + Statement_Required := False; + + -- Anything else is some kind of junk, signal an error message + -- and then raise Error_Resync, to merge with the normal + -- handling of a bad statement. + + when others => + + if Token in Token_Class_Declk then + Junk_Declaration; + + else + Error_Msg_BC -- CODEFIX + ("statement expected"); + raise Error_Resync; + end if; + end case; + + -- On error resynchronization, skip past next semicolon, and, since + -- we are still in the statement loop, look for next statement. We + -- set Statement_Required False to avoid an unnecessary error message + -- complaining that no statement was found (i.e. we consider the + -- junk to satisfy the requirement for a statement being present). + + exception + when Error_Resync => + Resync_Past_Semicolon_Or_To_Loop_Or_Then; + Statement_Required := False; + end; + + exit when SS_Flags.Unco; + + end loop; + + return Statement_List; + + end P_Sequence_Of_Statements; + + -------------------- + -- 5.1 Statement -- + -------------------- + + -- Parsed by P_Sequence_Of_Statements (5.1), except for the case + -- of a statement of the form of a name, which is handled here. The + -- argument passed in is the tree for the name which has been scanned + -- The returned value is the corresponding statement form. + + -- This routine is also used by Par.Prag for processing the procedure + -- call that appears as the second argument of a pragma Assert. + + -- Error recovery: cannot raise Error_Resync + + function P_Statement_Name (Name_Node : Node_Id) return Node_Id is + Stmt_Node : Node_Id; + + begin + -- Case of Indexed component, which is a procedure call with arguments + + if Nkind (Name_Node) = N_Indexed_Component then + declare + Prefix_Node : constant Node_Id := Prefix (Name_Node); + Exprs_Node : constant List_Id := Expressions (Name_Node); + + begin + Change_Node (Name_Node, N_Procedure_Call_Statement); + Set_Name (Name_Node, Prefix_Node); + Set_Parameter_Associations (Name_Node, Exprs_Node); + return Name_Node; + end; + + -- Case of function call node, which is a really a procedure call + + elsif Nkind (Name_Node) = N_Function_Call then + declare + Fname_Node : constant Node_Id := Name (Name_Node); + Params_List : constant List_Id := + Parameter_Associations (Name_Node); + + begin + Change_Node (Name_Node, N_Procedure_Call_Statement); + Set_Name (Name_Node, Fname_Node); + Set_Parameter_Associations (Name_Node, Params_List); + return Name_Node; + end; + + -- Case of call to attribute that denotes a procedure. Here we + -- just leave the attribute reference unchanged. + + elsif Nkind (Name_Node) = N_Attribute_Reference + and then Is_Procedure_Attribute_Name (Attribute_Name (Name_Node)) + then + return Name_Node; + + -- All other cases of names are parameterless procedure calls + + else + Stmt_Node := + New_Node (N_Procedure_Call_Statement, Sloc (Name_Node)); + Set_Name (Stmt_Node, Name_Node); + return Stmt_Node; + end if; + + end P_Statement_Name; + + --------------------------- + -- 5.1 Simple Statement -- + --------------------------- + + -- Parsed by P_Sequence_Of_Statements (5.1) + + ----------------------------- + -- 5.1 Compound Statement -- + ----------------------------- + + -- Parsed by P_Sequence_Of_Statements (5.1) + + ------------------------- + -- 5.1 Null Statement -- + ------------------------- + + -- NULL_STATEMENT ::= null; + + -- The caller has already checked that the current token is null + + -- Error recovery: cannot raise Error_Resync + + function P_Null_Statement return Node_Id is + Null_Stmt_Node : Node_Id; + + begin + Null_Stmt_Node := New_Node (N_Null_Statement, Token_Ptr); + Scan; -- past NULL + TF_Semicolon; + return Null_Stmt_Node; + end P_Null_Statement; + + ---------------- + -- 5.1 Label -- + ---------------- + + -- LABEL ::= <> + + -- STATEMENT_IDENTIFIER ::= DIRECT_NAME + + -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier + -- (not an OPERATOR_SYMBOL) + + -- The caller has already checked that the current token is << + + -- Error recovery: can raise Error_Resync + + function P_Label return Node_Id is + Label_Node : Node_Id; + + begin + Label_Node := New_Node (N_Label, Token_Ptr); + Scan; -- past << + Set_Identifier (Label_Node, P_Identifier (C_Greater_Greater)); + T_Greater_Greater; + Append_Elmt (Label_Node, Label_List); + return Label_Node; + end P_Label; + + ------------------------------- + -- 5.1 Statement Identifier -- + ------------------------------- + + -- Statement label is parsed by P_Label (5.1) + + -- Loop label is parsed by P_Loop_Statement (5.5), P_For_Statement (5.5) + -- or P_While_Statement (5.5) + + -- Block label is parsed by P_Begin_Statement (5.6) or + -- P_Declare_Statement (5.6) + + ------------------------------- + -- 5.2 Assignment Statement -- + ------------------------------- + + -- ASSIGNMENT_STATEMENT ::= + -- variable_NAME := EXPRESSION; + + -- Error recovery: can raise Error_Resync + + function P_Assignment_Statement (LHS : Node_Id) return Node_Id is + Assign_Node : Node_Id; + + begin + Assign_Node := New_Node (N_Assignment_Statement, Prev_Token_Ptr); + Set_Name (Assign_Node, LHS); + Set_Expression (Assign_Node, P_Expression_No_Right_Paren); + TF_Semicolon; + return Assign_Node; + end P_Assignment_Statement; + + ----------------------- + -- 5.3 If Statement -- + ----------------------- + + -- IF_STATEMENT ::= + -- if CONDITION then + -- SEQUENCE_OF_STATEMENTS + -- {elsif CONDITION then + -- SEQUENCE_OF_STATEMENTS} + -- [else + -- SEQUENCE_OF_STATEMENTS] + -- end if; + + -- The caller has checked that the initial token is IF (or in the error + -- case of a mysterious THEN, the initial token may simply be THEN, in + -- which case, no condition (or IF) was scanned). + + -- Error recovery: can raise Error_Resync + + function P_If_Statement return Node_Id is + If_Node : Node_Id; + Elsif_Node : Node_Id; + Loc : Source_Ptr; + + procedure Add_Elsif_Part; + -- An internal procedure used to scan out a single ELSIF part. On entry + -- the ELSIF (or an ELSE which has been determined should be ELSIF) is + -- scanned out and is in Prev_Token. + + procedure Check_If_Column; + -- An internal procedure used to check that THEN, ELSE, or ELSIF + -- appear in the right place if column checking is enabled (i.e. if + -- they are the first token on the line, then they must appear in + -- the same column as the opening IF). + + procedure Check_Then_Column; + -- This procedure carries out the style checks for a THEN token + -- Note that the caller has set Loc to the Source_Ptr value for + -- the previous IF or ELSIF token. These checks apply only to a + -- THEN at the start of a line. + + function Else_Should_Be_Elsif return Boolean; + -- An internal routine used to do a special error recovery check when + -- an ELSE is encountered. It determines if the ELSE should be treated + -- as an ELSIF. A positive decision (TRUE returned, is made if the ELSE + -- is followed by a sequence of tokens, starting on the same line as + -- the ELSE, which are not expression terminators, followed by a THEN. + -- On entry, the ELSE has been scanned out. + + procedure Add_Elsif_Part is + begin + if No (Elsif_Parts (If_Node)) then + Set_Elsif_Parts (If_Node, New_List); + end if; + + Elsif_Node := New_Node (N_Elsif_Part, Prev_Token_Ptr); + Loc := Prev_Token_Ptr; + Set_Condition (Elsif_Node, P_Condition); + Check_Then_Column; + Then_Scan; + Set_Then_Statements + (Elsif_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq)); + Append (Elsif_Node, Elsif_Parts (If_Node)); + end Add_Elsif_Part; + + procedure Check_If_Column is + begin + if RM_Column_Check and then Token_Is_At_Start_Of_Line + and then Start_Column /= Scope.Table (Scope.Last).Ecol + then + Error_Msg_Col := Scope.Table (Scope.Last).Ecol; + Error_Msg_SC ("(style) this token should be@"); + end if; + end Check_If_Column; + + procedure Check_Then_Column is + begin + if Token_Is_At_Start_Of_Line and then Token = Tok_Then then + Check_If_Column; + + if Style_Check then + Style.Check_Then (Loc); + end if; + end if; + end Check_Then_Column; + + function Else_Should_Be_Elsif return Boolean is + Scan_State : Saved_Scan_State; + + begin + if Token_Is_At_Start_Of_Line then + return False; + + else + Save_Scan_State (Scan_State); + + loop + if Token in Token_Class_Eterm then + Restore_Scan_State (Scan_State); + return False; + else + Scan; -- past non-expression terminating token + + if Token = Tok_Then then + Restore_Scan_State (Scan_State); + return True; + end if; + end if; + end loop; + end if; + end Else_Should_Be_Elsif; + + -- Start of processing for P_If_Statement + + begin + If_Node := New_Node (N_If_Statement, Token_Ptr); + + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_If; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Labl := Error; + Scope.Table (Scope.Last).Node := If_Node; + + if Token = Tok_If then + Loc := Token_Ptr; + Scan; -- past IF + Set_Condition (If_Node, P_Condition); + + -- Deal with misuse of IF expression => used instead + -- of WHEN expression => + + if Token = Tok_Arrow then + Error_Msg_SC -- CODEFIX + ("THEN expected"); + Scan; -- past the arrow + Pop_Scope_Stack; -- remove unneeded entry + raise Error_Resync; + end if; + + Check_Then_Column; + + else + Error_Msg_SC ("no IF for this THEN"); + Set_Condition (If_Node, Error); + end if; + + Then_Scan; + + Set_Then_Statements + (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq)); + + -- This loop scans out else and elsif parts + + loop + if Token = Tok_Elsif then + Check_If_Column; + + if Present (Else_Statements (If_Node)) then + Error_Msg_SP ("ELSIF cannot appear after ELSE"); + end if; + + Scan; -- past ELSIF + Add_Elsif_Part; + + elsif Token = Tok_Else then + Check_If_Column; + Scan; -- past ELSE + + if Else_Should_Be_Elsif then + Error_Msg_SP -- CODEFIX + ("ELSE should be ELSIF"); + Add_Elsif_Part; + + else + -- Here we have an else that really is an else + + if Present (Else_Statements (If_Node)) then + Error_Msg_SP ("only one ELSE part allowed"); + Append_List + (P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq), + Else_Statements (If_Node)); + else + Set_Else_Statements + (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq)); + end if; + end if; + + -- If anything other than ELSE or ELSIF, exit the loop. The token + -- had better be END (and in fact it had better be END IF), but + -- we will let End_Statements take care of checking that. + + else + exit; + end if; + end loop; + + End_Statements; + return If_Node; + + end P_If_Statement; + + -------------------- + -- 5.3 Condition -- + -------------------- + + -- CONDITION ::= boolean_EXPRESSION + + function P_Condition return Node_Id is + Cond : Node_Id; + + begin + Cond := P_Expression_No_Right_Paren; + + -- It is never possible for := to follow a condition, so if we get + -- a := we assume it is a mistyped equality. Note that we do not try + -- to reconstruct the tree correctly in this case, but we do at least + -- give an accurate error message. + + if Token = Tok_Colon_Equal then + while Token = Tok_Colon_Equal loop + Error_Msg_SC -- CODEFIX + (""":="" should be ""="""); + Scan; -- past junk := + Discard_Junk_Node (P_Expression_No_Right_Paren); + end loop; + + return Cond; + + -- Otherwise check for redundant parens + + else + if Style_Check + and then Paren_Count (Cond) > 0 + then + Style.Check_Xtra_Parens (First_Sloc (Cond)); + end if; + + -- And return the result + + return Cond; + end if; + end P_Condition; + + ------------------------- + -- 5.4 Case Statement -- + ------------------------- + + -- CASE_STATEMENT ::= + -- case EXPRESSION is + -- CASE_STATEMENT_ALTERNATIVE + -- {CASE_STATEMENT_ALTERNATIVE} + -- end case; + + -- The caller has checked that the first token is CASE + + -- Can raise Error_Resync + + function P_Case_Statement return Node_Id is + Case_Node : Node_Id; + Alternatives_List : List_Id; + First_When_Loc : Source_Ptr; + + begin + Case_Node := New_Node (N_Case_Statement, Token_Ptr); + + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Case; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Labl := Error; + Scope.Table (Scope.Last).Node := Case_Node; + + Scan; -- past CASE + Set_Expression (Case_Node, P_Expression_No_Right_Paren); + TF_Is; + + -- Prepare to parse case statement alternatives + + Alternatives_List := New_List; + P_Pragmas_Opt (Alternatives_List); + First_When_Loc := Token_Ptr; + + -- Loop through case statement alternatives + + loop + -- If we have a WHEN or OTHERS, then that's fine keep going. Note + -- that it is a semantic check to ensure the proper use of OTHERS + + if Token = Tok_When or else Token = Tok_Others then + Append (P_Case_Statement_Alternative, Alternatives_List); + + -- If we have an END, then probably we are at the end of the case + -- but we only exit if Check_End thinks the END was reasonable. + + elsif Token = Tok_End then + exit when Check_End; + + -- Here if token is other than WHEN, OTHERS or END. We definitely + -- have an error, but the question is whether or not to get out of + -- the case statement. We don't want to get out early, or we will + -- get a slew of junk error messages for subsequent when tokens. + + -- If the token is not at the start of the line, or if it is indented + -- with respect to the current case statement, then the best guess is + -- that we are still supposed to be inside the case statement. We + -- complain about the missing WHEN, and discard the junk statements. + + elsif not Token_Is_At_Start_Of_Line + or else Start_Column > Scope.Table (Scope.Last).Ecol + then + Error_Msg_BC ("WHEN (case statement alternative) expected"); + + -- Here is a possibility for infinite looping if we don't make + -- progress. So try to process statements, otherwise exit + + declare + Error_Ptr : constant Source_Ptr := Scan_Ptr; + begin + Discard_Junk_List (P_Sequence_Of_Statements (SS_Whtm)); + exit when Scan_Ptr = Error_Ptr and then Check_End; + end; + + -- Here we have a junk token at the start of the line and it is + -- not indented. If Check_End thinks there is a missing END, then + -- we will get out of the case, otherwise we keep going. + + else + exit when Check_End; + end if; + end loop; + + -- Make sure we have at least one alternative + + if No (First_Non_Pragma (Alternatives_List)) then + Error_Msg + ("WHEN expected, must have at least one alternative in case", + First_When_Loc); + return Error; + + else + Set_Alternatives (Case_Node, Alternatives_List); + return Case_Node; + end if; + end P_Case_Statement; + + ------------------------------------- + -- 5.4 Case Statement Alternative -- + ------------------------------------- + + -- CASE_STATEMENT_ALTERNATIVE ::= + -- when DISCRETE_CHOICE_LIST => + -- SEQUENCE_OF_STATEMENTS + + -- The caller has checked that the initial token is WHEN or OTHERS + -- Error recovery: can raise Error_Resync + + function P_Case_Statement_Alternative return Node_Id is + Case_Alt_Node : Node_Id; + + begin + if Style_Check then + Style.Check_Indentation; + end if; + + Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Token_Ptr); + T_When; -- past WHEN (or give error in OTHERS case) + Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List); + TF_Arrow; + Set_Statements (Case_Alt_Node, P_Sequence_Of_Statements (SS_Sreq_Whtm)); + return Case_Alt_Node; + end P_Case_Statement_Alternative; + + ------------------------- + -- 5.5 Loop Statement -- + ------------------------- + + -- LOOP_STATEMENT ::= + -- [LOOP_STATEMENT_IDENTIFIER:] + -- [ITERATION_SCHEME] loop + -- SEQUENCE_OF_STATEMENTS + -- end loop [loop_IDENTIFIER]; + + -- ITERATION_SCHEME ::= + -- while CONDITION + -- | for LOOP_PARAMETER_SPECIFICATION + + -- The parsing of loop statements is handled by one of three functions + -- P_Loop_Statement, P_For_Statement or P_While_Statement depending + -- on the initial keyword in the construct (excluding the identifier) + + -- P_Loop_Statement + + -- This function parses the case where no iteration scheme is present + + -- The caller has checked that the initial token is LOOP. The parameter + -- is the node identifiers for the loop label if any (or is set to Empty + -- if there is no loop label). + + -- Error recovery : cannot raise Error_Resync + + function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id is + Loop_Node : Node_Id; + Created_Name : Node_Id; + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Labl := Loop_Name; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Etyp := E_Loop; + + Loop_Node := New_Node (N_Loop_Statement, Token_Ptr); + TF_Loop; + + if No (Loop_Name) then + Created_Name := + Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L')); + Set_Comes_From_Source (Created_Name, False); + Set_Has_Created_Identifier (Loop_Node, True); + Set_Identifier (Loop_Node, Created_Name); + Scope.Table (Scope.Last).Labl := Created_Name; + else + Set_Identifier (Loop_Node, Loop_Name); + end if; + + Append_Elmt (Loop_Node, Label_List); + Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq)); + End_Statements (Loop_Node); + return Loop_Node; + end P_Loop_Statement; + + -- P_For_Statement + + -- This function parses a loop statement with a FOR iteration scheme + + -- The caller has checked that the initial token is FOR. The parameter + -- is the node identifier for the block label if any (or is set to Empty + -- if there is no block label). + + -- Note: the caller fills in the Identifier field if a label was present + + -- Error recovery: can raise Error_Resync + + function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id is + Loop_Node : Node_Id; + Iter_Scheme_Node : Node_Id; + Loop_For_Flag : Boolean; + Created_Name : Node_Id; + Spec : Node_Id; + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Labl := Loop_Name; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Etyp := E_Loop; + + Loop_For_Flag := (Prev_Token = Tok_Loop); + Scan; -- past FOR + Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr); + Spec := P_Loop_Parameter_Specification; + + if Nkind (Spec) = N_Loop_Parameter_Specification then + Set_Loop_Parameter_Specification (Iter_Scheme_Node, Spec); + else + Set_Iterator_Specification (Iter_Scheme_Node, Spec); + end if; + + -- The following is a special test so that a miswritten for loop such + -- as "loop for I in 1..10;" is handled nicely, without making an extra + -- entry in the scope stack. We don't bother to actually fix up the + -- tree in this case since it's not worth the effort. Instead we just + -- eat up the loop junk, leaving the entry for what now looks like an + -- unmodified loop intact. + + if Loop_For_Flag and then Token = Tok_Semicolon then + Error_Msg_SC ("LOOP belongs here, not before FOR"); + Pop_Scope_Stack; + return Error; + + -- Normal case + + else + Loop_Node := New_Node (N_Loop_Statement, Token_Ptr); + + if No (Loop_Name) then + Created_Name := + Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L')); + Set_Comes_From_Source (Created_Name, False); + Set_Has_Created_Identifier (Loop_Node, True); + Set_Identifier (Loop_Node, Created_Name); + Scope.Table (Scope.Last).Labl := Created_Name; + else + Set_Identifier (Loop_Node, Loop_Name); + end if; + + TF_Loop; + Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq)); + End_Statements (Loop_Node); + Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node); + Append_Elmt (Loop_Node, Label_List); + return Loop_Node; + end if; + end P_For_Statement; + + -- P_While_Statement + + -- This procedure scans a loop statement with a WHILE iteration scheme + + -- The caller has checked that the initial token is WHILE. The parameter + -- is the node identifier for the block label if any (or is set to Empty + -- if there is no block label). + + -- Error recovery: cannot raise Error_Resync + + function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id is + Loop_Node : Node_Id; + Iter_Scheme_Node : Node_Id; + Loop_While_Flag : Boolean; + Created_Name : Node_Id; + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Labl := Loop_Name; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Etyp := E_Loop; + + Loop_While_Flag := (Prev_Token = Tok_Loop); + Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr); + Scan; -- past WHILE + Set_Condition (Iter_Scheme_Node, P_Condition); + + -- The following is a special test so that a miswritten for loop such + -- as "loop while I > 10;" is handled nicely, without making an extra + -- entry in the scope stack. We don't bother to actually fix up the + -- tree in this case since it's not worth the effort. Instead we just + -- eat up the loop junk, leaving the entry for what now looks like an + -- unmodified loop intact. + + if Loop_While_Flag and then Token = Tok_Semicolon then + Error_Msg_SC ("LOOP belongs here, not before WHILE"); + Pop_Scope_Stack; + return Error; + + -- Normal case + + else + Loop_Node := New_Node (N_Loop_Statement, Token_Ptr); + TF_Loop; + + if No (Loop_Name) then + Created_Name := + Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L')); + Set_Comes_From_Source (Created_Name, False); + Set_Has_Created_Identifier (Loop_Node, True); + Set_Identifier (Loop_Node, Created_Name); + Scope.Table (Scope.Last).Labl := Created_Name; + else + Set_Identifier (Loop_Node, Loop_Name); + end if; + + Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq)); + End_Statements (Loop_Node); + Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node); + Append_Elmt (Loop_Node, Label_List); + return Loop_Node; + end if; + end P_While_Statement; + + --------------------------------------- + -- 5.5 Loop Parameter Specification -- + --------------------------------------- + + -- LOOP_PARAMETER_SPECIFICATION ::= + -- DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION + + -- Error recovery: cannot raise Error_Resync + + function P_Loop_Parameter_Specification return Node_Id is + Loop_Param_Specification_Node : Node_Id; + + ID_Node : Node_Id; + Scan_State : Saved_Scan_State; + + begin + + Save_Scan_State (Scan_State); + ID_Node := P_Defining_Identifier (C_In); + + -- If the next token is OF, it indicates an Ada 2012 iterator. If the + -- next token is a colon, this is also an Ada 2012 iterator, including + -- a subtype indication for the loop parameter. Otherwise we parse the + -- construct as a loop parameter specification. Note that the form + -- "for A in B" is ambiguous, and must be resolved semantically: if B + -- is a discrete subtype this is a loop specification, but if it is an + -- expression it is an iterator specification. Ambiguity is resolved + -- during analysis of the loop parameter specification. + + if Token = Tok_Of or else Token = Tok_Colon then + if Ada_Version < Ada_2012 then + Error_Msg_SC ("iterator is an Ada2012 feature"); + end if; + + return P_Iterator_Specification (ID_Node); + end if; + + -- The span of the Loop_Parameter_Specification starts at the + -- defining identifier. + + Loop_Param_Specification_Node := + New_Node (N_Loop_Parameter_Specification, Sloc (ID_Node)); + Set_Defining_Identifier (Loop_Param_Specification_Node, ID_Node); + + if Token = Tok_Left_Paren then + Error_Msg_SC ("subscripted loop parameter not allowed"); + Restore_Scan_State (Scan_State); + Discard_Junk_Node (P_Name); + + elsif Token = Tok_Dot then + Error_Msg_SC ("selected loop parameter not allowed"); + Restore_Scan_State (Scan_State); + Discard_Junk_Node (P_Name); + end if; + + T_In; + + if Token = Tok_Reverse then + Scan; -- past REVERSE + Set_Reverse_Present (Loop_Param_Specification_Node, True); + end if; + + Set_Discrete_Subtype_Definition + (Loop_Param_Specification_Node, P_Discrete_Subtype_Definition); + return Loop_Param_Specification_Node; + + exception + when Error_Resync => + return Error; + end P_Loop_Parameter_Specification; + + ---------------------------------- + -- 5.5.1 Iterator_Specification -- + ---------------------------------- + + function P_Iterator_Specification (Def_Id : Node_Id) return Node_Id is + Node1 : Node_Id; + + begin + Node1 := New_Node (N_Iterator_Specification, Sloc (Def_Id)); + Set_Defining_Identifier (Node1, Def_Id); + + if Token = Tok_Colon then + Scan; -- past : + Set_Subtype_Indication (Node1, P_Subtype_Indication); + end if; + + if Token = Tok_Of then + Set_Of_Present (Node1); + Scan; -- past OF + + elsif Token = Tok_In then + Scan; -- past IN + + else + return Error; + end if; + + if Token = Tok_Reverse then + Scan; -- past REVERSE + Set_Reverse_Present (Node1, True); + end if; + + Set_Name (Node1, P_Name); + return Node1; + end P_Iterator_Specification; + + -------------------------- + -- 5.6 Block Statement -- + -------------------------- + + -- BLOCK_STATEMENT ::= + -- [block_STATEMENT_IDENTIFIER:] + -- [declare + -- DECLARATIVE_PART] + -- begin + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end [block_IDENTIFIER]; + + -- The parsing of block statements is handled by one of the two functions + -- P_Declare_Statement or P_Begin_Statement depending on whether or not + -- a declare section is present + + -- P_Declare_Statement + + -- This function parses a block statement with DECLARE present + + -- The caller has checked that the initial token is DECLARE + + -- Error recovery: cannot raise Error_Resync + + function P_Declare_Statement + (Block_Name : Node_Id := Empty) + return Node_Id + is + Block_Node : Node_Id; + Created_Name : Node_Id; + + begin + Block_Node := New_Node (N_Block_Statement, Token_Ptr); + + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Lreq := Present (Block_Name); + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Labl := Block_Name; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + + Scan; -- past DECLARE + + if No (Block_Name) then + Created_Name := + Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B')); + Set_Comes_From_Source (Created_Name, False); + Set_Has_Created_Identifier (Block_Node, True); + Set_Identifier (Block_Node, Created_Name); + Scope.Table (Scope.Last).Labl := Created_Name; + else + Set_Identifier (Block_Node, Block_Name); + end if; + + Append_Elmt (Block_Node, Label_List); + Parse_Decls_Begin_End (Block_Node); + return Block_Node; + end P_Declare_Statement; + + -- P_Begin_Statement + + -- This function parses a block statement with no DECLARE present + + -- The caller has checked that the initial token is BEGIN + + -- Error recovery: cannot raise Error_Resync + + function P_Begin_Statement + (Block_Name : Node_Id := Empty) + return Node_Id + is + Block_Node : Node_Id; + Created_Name : Node_Id; + + begin + Block_Node := New_Node (N_Block_Statement, Token_Ptr); + + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Lreq := Present (Block_Name); + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Labl := Block_Name; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + + if No (Block_Name) then + Created_Name := + Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B')); + Set_Comes_From_Source (Created_Name, False); + Set_Has_Created_Identifier (Block_Node, True); + Set_Identifier (Block_Node, Created_Name); + Scope.Table (Scope.Last).Labl := Created_Name; + else + Set_Identifier (Block_Node, Block_Name); + end if; + + Append_Elmt (Block_Node, Label_List); + + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scan; -- past BEGIN + Set_Handled_Statement_Sequence + (Block_Node, P_Handled_Sequence_Of_Statements); + End_Statements (Handled_Statement_Sequence (Block_Node)); + return Block_Node; + end P_Begin_Statement; + + ------------------------- + -- 5.7 Exit Statement -- + ------------------------- + + -- EXIT_STATEMENT ::= + -- exit [loop_NAME] [when CONDITION]; + + -- The caller has checked that the initial token is EXIT + + -- Error recovery: can raise Error_Resync + + function P_Exit_Statement return Node_Id is + Exit_Node : Node_Id; + + function Missing_Semicolon_On_Exit return Boolean; + -- This function deals with the following specialized situation + -- + -- when 'x' => + -- exit [identifier] + -- when 'y' => + -- + -- This looks like a messed up EXIT WHEN, when in fact the problem + -- is a missing semicolon. It is called with Token pointing to the + -- WHEN token, and returns True if a semicolon is missing before + -- the WHEN as in the above example. + + ------------------------------- + -- Missing_Semicolon_On_Exit -- + ------------------------------- + + function Missing_Semicolon_On_Exit return Boolean is + State : Saved_Scan_State; + + begin + if not Token_Is_At_Start_Of_Line then + return False; + + elsif Scope.Table (Scope.Last).Etyp /= E_Case then + return False; + + else + Save_Scan_State (State); + Scan; -- past WHEN + Scan; -- past token after WHEN + + if Token = Tok_Arrow then + Restore_Scan_State (State); + return True; + else + Restore_Scan_State (State); + return False; + end if; + end if; + end Missing_Semicolon_On_Exit; + + -- Start of processing for P_Exit_Statement + + begin + Exit_Node := New_Node (N_Exit_Statement, Token_Ptr); + Scan; -- past EXIT + + if Token = Tok_Identifier then + Set_Name (Exit_Node, P_Qualified_Simple_Name); + + elsif Style_Check then + -- This EXIT has no name, so check that + -- the innermost loop is unnamed too. + + Check_No_Exit_Name : + for J in reverse 1 .. Scope.Last loop + if Scope.Table (J).Etyp = E_Loop then + if Present (Scope.Table (J).Labl) + and then Comes_From_Source (Scope.Table (J).Labl) + then + -- Innermost loop in fact had a name, style check fails + + Style.No_Exit_Name (Scope.Table (J).Labl); + end if; + + exit Check_No_Exit_Name; + end if; + end loop Check_No_Exit_Name; + end if; + + if Token = Tok_When and then not Missing_Semicolon_On_Exit then + Scan; -- past WHEN + Set_Condition (Exit_Node, P_Condition); + + -- Allow IF instead of WHEN, giving error message + + elsif Token = Tok_If then + T_When; + Scan; -- past IF used in place of WHEN + Set_Condition (Exit_Node, P_Expression_No_Right_Paren); + end if; + + TF_Semicolon; + return Exit_Node; + end P_Exit_Statement; + + ------------------------- + -- 5.8 Goto Statement -- + ------------------------- + + -- GOTO_STATEMENT ::= goto label_NAME; + + -- The caller has checked that the initial token is GOTO (or TO in the + -- error case where GO and TO were incorrectly separated). + + -- Error recovery: can raise Error_Resync + + function P_Goto_Statement return Node_Id is + Goto_Node : Node_Id; + + begin + Goto_Node := New_Node (N_Goto_Statement, Token_Ptr); + Scan; -- past GOTO (or TO) + Set_Name (Goto_Node, P_Qualified_Simple_Name_Resync); + Append_Elmt (Goto_Node, Goto_List); + No_Constraint; + TF_Semicolon; + return Goto_Node; + end P_Goto_Statement; + + --------------------------- + -- Parse_Decls_Begin_End -- + --------------------------- + + -- This function parses the construct: + + -- DECLARATIVE_PART + -- begin + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end [NAME]; + + -- The caller has built the scope stack entry, and created the node to + -- whose Declarations and Handled_Statement_Sequence fields are to be + -- set. On return these fields are filled in (except in the case of a + -- task body, where the handled statement sequence is optional, and may + -- thus be Empty), and the scan is positioned past the End sequence. + + -- If the BEGIN is missing, then the parent node is used to help construct + -- an appropriate missing BEGIN message. Possibilities for the parent are: + + -- N_Block_Statement declare block + -- N_Entry_Body entry body + -- N_Package_Body package body (begin part optional) + -- N_Subprogram_Body procedure or function body + -- N_Task_Body task body + + -- Note: in the case of a block statement, there is definitely a DECLARE + -- present (because a Begin statement without a DECLARE is handled by the + -- P_Begin_Statement procedure, which does not call Parse_Decls_Begin_End. + + -- Error recovery: cannot raise Error_Resync + + procedure Parse_Decls_Begin_End (Parent : Node_Id) is + Body_Decl : Node_Id; + Body_Sloc : Source_Ptr; + Decls : List_Id; + Decl : Node_Id; + Parent_Nkind : Node_Kind; + Spec_Node : Node_Id; + HSS : Node_Id; + + procedure Missing_Begin (Msg : String); + -- Called to post a missing begin message. In the normal case this is + -- posted at the start of the current token. A special case arises when + -- P_Declarative_Items has previously found a missing begin, in which + -- case we replace the original error message. + + procedure Set_Null_HSS (Parent : Node_Id); + -- Construct an empty handled statement sequence and install in Parent + -- Leaves HSS set to reference the newly constructed statement sequence. + + ------------------- + -- Missing_Begin -- + ------------------- + + procedure Missing_Begin (Msg : String) is + begin + if Missing_Begin_Msg = No_Error_Msg then + Error_Msg_BC (Msg); + else + Change_Error_Text (Missing_Begin_Msg, Msg); + + -- Purge any messages issued after than, since a missing begin + -- can cause a lot of havoc, and it is better not to dump these + -- cascaded messages on the user. + + Purge_Messages (Get_Location (Missing_Begin_Msg), Prev_Token_Ptr); + end if; + end Missing_Begin; + + ------------------ + -- Set_Null_HSS -- + ------------------ + + procedure Set_Null_HSS (Parent : Node_Id) is + Null_Stm : Node_Id; + + begin + Null_Stm := + Make_Null_Statement (Token_Ptr); + Set_Comes_From_Source (Null_Stm, False); + + HSS := + Make_Handled_Sequence_Of_Statements (Token_Ptr, + Statements => New_List (Null_Stm)); + Set_Comes_From_Source (HSS, False); + + Set_Handled_Statement_Sequence (Parent, HSS); + end Set_Null_HSS; + + -- Start of processing for Parse_Decls_Begin_End + + begin + Decls := P_Declarative_Part; + + -- Check for misplacement of later vs basic declarations in Ada 83 + + if Ada_Version = Ada_83 then + Decl := First (Decls); + + -- Loop through sequence of basic declarative items + + Outer : while Present (Decl) loop + if Nkind (Decl) /= N_Subprogram_Body + and then Nkind (Decl) /= N_Package_Body + and then Nkind (Decl) /= N_Task_Body + and then Nkind (Decl) not in N_Body_Stub + then + Next (Decl); + + -- Once a body is encountered, we only allow later declarative + -- items. The inner loop checks the rest of the list. + + else + Body_Sloc := Sloc (Decl); + + Inner : while Present (Decl) loop + if Nkind (Decl) not in N_Later_Decl_Item + and then Nkind (Decl) /= N_Pragma + then + if Ada_Version = Ada_83 then + Error_Msg_Sloc := Body_Sloc; + Error_Msg_N + ("(Ada 83) decl cannot appear after body#", Decl); + end if; + end if; + + Next (Decl); + end loop Inner; + end if; + end loop Outer; + end if; + + -- Here is where we deal with the case of IS used instead of semicolon. + -- Specifically, if the last declaration in the declarative part is a + -- subprogram body still marked as having a bad IS, then this is where + -- we decide that the IS should really have been a semicolon and that + -- the body should have been a declaration. Note that if the bad IS + -- had turned out to be OK (i.e. a decent begin/end was found for it), + -- then the Bad_Is_Detected flag would have been reset by now. + + Body_Decl := Last (Decls); + + if Present (Body_Decl) + and then Nkind (Body_Decl) = N_Subprogram_Body + and then Bad_Is_Detected (Body_Decl) + then + -- OK, we have the case of a bad IS, so we need to fix up the tree. + -- What we have now is a subprogram body with attached declarations + -- and a possible statement sequence. + + -- First step is to take the declarations that were part of the bogus + -- subprogram body and append them to the outer declaration chain. + -- In other words we append them past the body (which we will later + -- convert into a declaration). + + Append_List (Declarations (Body_Decl), Decls); + + -- Now take the handled statement sequence of the bogus body and + -- set it as the statement sequence for the outer construct. Note + -- that it may be empty (we specially allowed a missing BEGIN for + -- a subprogram body marked as having a bad IS -- see below). + + Set_Handled_Statement_Sequence (Parent, + Handled_Statement_Sequence (Body_Decl)); + + -- Next step is to convert the old body node to a declaration node + + Spec_Node := Specification (Body_Decl); + Change_Node (Body_Decl, N_Subprogram_Declaration); + Set_Specification (Body_Decl, Spec_Node); + + -- Final step is to put the declarations for the parent where + -- they belong, and then fall through the IF to scan out the + -- END statements. + + Set_Declarations (Parent, Decls); + + -- This is the normal case (i.e. any case except the bad IS case) + -- If we have a BEGIN, then scan out the sequence of statements, and + -- also reset the expected column for the END to match the BEGIN. + + else + Set_Declarations (Parent, Decls); + + if Token = Tok_Begin then + if Style_Check then + Style.Check_Indentation; + end if; + + Error_Msg_Col := Scope.Table (Scope.Last).Ecol; + + if RM_Column_Check + and then Token_Is_At_Start_Of_Line + and then Start_Column /= Error_Msg_Col + then + Error_Msg_SC ("(style) BEGIN in wrong column, should be@"); + + else + Scope.Table (Scope.Last).Ecol := Start_Column; + end if; + + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scan; -- past BEGIN + Set_Handled_Statement_Sequence (Parent, + P_Handled_Sequence_Of_Statements); + + -- No BEGIN present + + else + Parent_Nkind := Nkind (Parent); + + -- A special check for the missing IS case. If we have a + -- subprogram body that was marked as having a suspicious + -- IS, and the current token is END, then we simply confirm + -- the suspicion, and do not require a BEGIN to be present + + if Parent_Nkind = N_Subprogram_Body + and then Token = Tok_End + and then Scope.Table (Scope.Last).Etyp = E_Suspicious_Is + then + Scope.Table (Scope.Last).Etyp := E_Bad_Is; + + -- Otherwise BEGIN is not required for a package body, so we + -- don't mind if it is missing, but we do construct a dummy + -- one (so that we have somewhere to set End_Label). + + -- However if we have something other than a BEGIN which + -- looks like it might be statements, then we signal a missing + -- BEGIN for these cases as well. We define "something which + -- looks like it might be statements" as a token other than + -- END, EOF, or a token which starts declarations. + + elsif Parent_Nkind = N_Package_Body + and then (Token = Tok_End + or else Token = Tok_EOF + or else Token in Token_Class_Declk) + then + Set_Null_HSS (Parent); + + -- These are cases in which a BEGIN is required and not present + + else + Set_Null_HSS (Parent); + + -- Prepare to issue error message + + Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc; + Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl; + + -- Now issue appropriate message + + if Parent_Nkind = N_Block_Statement then + Missing_Begin ("missing BEGIN for DECLARE#!"); + + elsif Parent_Nkind = N_Entry_Body then + Missing_Begin ("missing BEGIN for ENTRY#!"); + + elsif Parent_Nkind = N_Subprogram_Body then + if Nkind (Specification (Parent)) + = N_Function_Specification + then + Missing_Begin ("missing BEGIN for function&#!"); + else + Missing_Begin ("missing BEGIN for procedure&#!"); + end if; + + -- The case for package body arises only when + -- we have possible statement junk present. + + elsif Parent_Nkind = N_Package_Body then + Missing_Begin ("missing BEGIN for package body&#!"); + + else + pragma Assert (Parent_Nkind = N_Task_Body); + Missing_Begin ("missing BEGIN for task body&#!"); + end if; + + -- Here we pick up the statements after the BEGIN that + -- should have been present but was not. We don't insist + -- on statements being present if P_Declarative_Part had + -- already found a missing BEGIN, since it might have + -- swallowed a lone statement into the declarative part. + + if Missing_Begin_Msg /= No_Error_Msg + and then Token = Tok_End + then + null; + else + Set_Handled_Statement_Sequence (Parent, + P_Handled_Sequence_Of_Statements); + end if; + end if; + end if; + end if; + + -- Here with declarations and handled statement sequence scanned + + if Present (Handled_Statement_Sequence (Parent)) then + End_Statements (Handled_Statement_Sequence (Parent)); + else + End_Statements; + end if; + + -- We know that End_Statements removed an entry from the scope stack + -- (because it is required to do so under all circumstances). We can + -- therefore reference the entry it removed one past the stack top. + -- What we are interested in is whether it was a case of a bad IS. + + if Scope.Table (Scope.Last + 1).Etyp = E_Bad_Is then + Error_Msg -- CODEFIX + ("|IS should be "";""", Scope.Table (Scope.Last + 1).S_Is); + Set_Bad_Is_Detected (Parent, True); + end if; + + end Parse_Decls_Begin_End; + + ------------------------- + -- Set_Loop_Block_Name -- + ------------------------- + + function Set_Loop_Block_Name (L : Character) return Name_Id is + begin + Name_Buffer (1) := L; + Name_Buffer (2) := '_'; + Name_Len := 2; + Loop_Block_Count := Loop_Block_Count + 1; + Add_Nat_To_Name_Buffer (Loop_Block_Count); + return Name_Find; + end Set_Loop_Block_Name; + + --------------- + -- Then_Scan -- + --------------- + + procedure Then_Scan is + begin + TF_Then; + + while Token = Tok_Then loop + Error_Msg_SC -- CODEFIX + ("redundant THEN"); + TF_Then; + end loop; + + if Token = Tok_And or else Token = Tok_Or then + Error_Msg_SC ("unexpected logical operator"); + Scan; -- past logical operator + + if (Prev_Token = Tok_And and then Token = Tok_Then) + or else + (Prev_Token = Tok_Or and then Token = Tok_Else) + then + Scan; + end if; + + Discard_Junk_Node (P_Expression); + end if; + + if Token = Tok_Then then + Scan; + end if; + end Then_Scan; + +end Ch5; diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb new file mode 100644 index 000000000..6fe1dea14 --- /dev/null +++ b/gcc/ada/par-ch6.adb @@ -0,0 +1,1727 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 6 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +with Sinfo.CN; use Sinfo.CN; + +separate (Par) +package body Ch6 is + + -- Local subprograms, used only in this chapter + + function P_Defining_Designator return Node_Id; + function P_Defining_Operator_Symbol return Node_Id; + function P_Return_Object_Declaration return Node_Id; + + procedure P_Return_Subtype_Indication (Decl_Node : Node_Id); + -- Decl_Node is a N_Object_Declaration. + -- Set the Null_Exclusion_Present and Object_Definition fields of + -- Decl_Node. + + procedure Check_Junk_Semicolon_Before_Return; + + -- Check for common error of junk semicolon before RETURN keyword of + -- function specification. If present, skip over it with appropriate + -- error message, leaving Scan_Ptr pointing to the RETURN after. This + -- routine also deals with a possibly misspelled version of Return. + + ---------------------------------------- + -- Check_Junk_Semicolon_Before_Return -- + ---------------------------------------- + + procedure Check_Junk_Semicolon_Before_Return is + Scan_State : Saved_Scan_State; + + begin + if Token = Tok_Semicolon then + Save_Scan_State (Scan_State); + Scan; -- past the semicolon + + if Token = Tok_Return then + Restore_Scan_State (Scan_State); + Error_Msg_SC -- CODEFIX + ("|extra "";"" ignored"); + Scan; -- rescan past junk semicolon + else + Restore_Scan_State (Scan_State); + end if; + + elsif Bad_Spelling_Of (Tok_Return) then + null; + end if; + end Check_Junk_Semicolon_Before_Return; + + ----------------------------------------------------- + -- 6.1 Subprogram (Also 6.3, 8.5.4, 10.1.3, 12.3) -- + ----------------------------------------------------- + + -- This routine scans out a subprogram declaration, subprogram body, + -- subprogram renaming declaration or subprogram generic instantiation. + -- It also handles the new Ada 2012 parameterized expression form + + -- SUBPROGRAM_DECLARATION ::= + -- SUBPROGRAM_SPECIFICATION + -- [ASPECT_SPECIFICATIONS]; + + -- ABSTRACT_SUBPROGRAM_DECLARATION ::= + -- SUBPROGRAM_SPECIFICATION is abstract + -- [ASPECT_SPECIFICATIONS]; + + -- SUBPROGRAM_SPECIFICATION ::= + -- procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE + -- | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE + + -- PARAMETER_PROFILE ::= [FORMAL_PART] + + -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK + + -- SUBPROGRAM_BODY ::= + -- SUBPROGRAM_SPECIFICATION is + -- DECLARATIVE_PART + -- begin + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end [DESIGNATOR]; + + -- SUBPROGRAM_RENAMING_DECLARATION ::= + -- SUBPROGRAM_SPECIFICATION renames callable_entity_NAME; + + -- SUBPROGRAM_BODY_STUB ::= + -- SUBPROGRAM_SPECIFICATION is separate; + + -- GENERIC_INSTANTIATION ::= + -- procedure DEFINING_PROGRAM_UNIT_NAME is + -- new generic_procedure_NAME [GENERIC_ACTUAL_PART]; + -- | function DEFINING_DESIGNATOR is + -- new generic_function_NAME [GENERIC_ACTUAL_PART]; + + -- NULL_PROCEDURE_DECLARATION ::= + -- SUBPROGRAM_SPECIFICATION is null; + + -- Null procedures are an Ada 2005 feature. A null procedure declaration + -- is classified as a basic declarative item, but it is parsed here, with + -- other subprogram constructs. + + -- PARAMETERIZED_EXPRESSION ::= + -- FUNCTION SPECIFICATION IS (EXPRESSION); + + -- The value in Pf_Flags indicates which of these possible declarations + -- is acceptable to the caller: + + -- Pf_Flags.Decl Set if declaration OK + -- Pf_Flags.Gins Set if generic instantiation OK + -- Pf_Flags.Pbod Set if proper body OK + -- Pf_Flags.Rnam Set if renaming declaration OK + -- Pf_Flags.Stub Set if body stub OK + -- Pf_Flags.Pexp Set if parameterized expression OK + + -- If an inappropriate form is encountered, it is scanned out but an + -- error message indicating that it is appearing in an inappropriate + -- context is issued. The only possible values for Pf_Flags are those + -- defined as constants in the Par package. + + -- The caller has checked that the initial token is FUNCTION, PROCEDURE, + -- NOT or OVERRIDING. + + -- Error recovery: cannot raise Error_Resync + + function P_Subprogram (Pf_Flags : Pf_Rec) return Node_Id is + Specification_Node : Node_Id; + Name_Node : Node_Id; + Fpart_List : List_Id; + Fpart_Sloc : Source_Ptr; + Result_Not_Null : Boolean := False; + Result_Node : Node_Id; + Inst_Node : Node_Id; + Body_Node : Node_Id; + Decl_Node : Node_Id; + Rename_Node : Node_Id; + Absdec_Node : Node_Id; + Stub_Node : Node_Id; + Fproc_Sloc : Source_Ptr; + Func : Boolean; + Scan_State : Saved_Scan_State; + + -- Flags for optional overriding indication. Two flags are needed, + -- to distinguish positive and negative overriding indicators from + -- the absence of any indicator. + + Is_Overriding : Boolean := False; + Not_Overriding : Boolean := False; + + begin + -- Set up scope stack entry. Note that the Labl field will be set later + + SIS_Entry_Active := False; + SIS_Missing_Semicolon_Message := No_Error_Msg; + Push_Scope_Stack; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Lreq := False; + + -- Ada2005: scan leading NOT OVERRIDING indicator + + if Token = Tok_Not then + Scan; -- past NOT + + if Token = Tok_Overriding then + Scan; -- past OVERRIDING + Not_Overriding := True; + + -- Overriding keyword used in non Ada 2005 mode + + elsif Token = Tok_Identifier + and then Token_Name = Name_Overriding + then + Error_Msg_SC ("overriding indicator is an Ada 2005 extension"); + Error_Msg_SC ("\unit must be compiled with -gnat05 switch"); + Scan; -- past Overriding + Not_Overriding := True; + + else + Error_Msg_SC -- CODEFIX + ("OVERRIDING expected!"); + end if; + + -- Ada 2005: scan leading OVERRIDING indicator + + -- Note: in the case of OVERRIDING keyword used in Ada 95 mode, the + -- declaration circuit already gave an error message and changed the + -- token to Tok_Overriding. + + elsif Token = Tok_Overriding then + Scan; -- past OVERRIDING + Is_Overriding := True; + end if; + + if Is_Overriding or else Not_Overriding then + + -- Note that if we are not in Ada_2005 mode, error messages have + -- already been given, so no need to give another message here. + + -- An overriding indicator is allowed for subprogram declarations, + -- bodies (including subunits), renamings, stubs, and instantiations. + -- The test against Pf_Decl_Pbod is added to account for the case of + -- subprograms declared in a protected type, where only subprogram + -- declarations and bodies can occur. The Pf_Pbod case is for + -- subunits. + + if Pf_Flags /= Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp + and then + Pf_Flags /= Pf_Decl_Pbod_Pexp + and then + Pf_Flags /= Pf_Pbod_Pexp + then + Error_Msg_SC ("overriding indicator not allowed here!"); + + elsif Token /= Tok_Function and then Token /= Tok_Procedure then + Error_Msg_SC -- CODEFIX + ("FUNCTION or PROCEDURE expected!"); + end if; + end if; + + Func := (Token = Tok_Function); + Fproc_Sloc := Token_Ptr; + Scan; -- past FUNCTION or PROCEDURE + Ignore (Tok_Type); + Ignore (Tok_Body); + + if Func then + Name_Node := P_Defining_Designator; + + if Nkind (Name_Node) = N_Defining_Operator_Symbol + and then Scope.Last = 1 + then + Error_Msg_SP ("operator symbol not allowed at library level"); + Name_Node := New_Entity (N_Defining_Identifier, Sloc (Name_Node)); + + -- Set name from file name, we need some junk name, and that's + -- as good as anything. This is only approximate, since we do + -- not do anything with non-standard name translations. + + Get_Name_String (File_Name (Current_Source_File)); + + for J in 1 .. Name_Len loop + if Name_Buffer (J) = '.' then + Name_Len := J - 1; + exit; + end if; + end loop; + + Set_Chars (Name_Node, Name_Find); + Set_Error_Posted (Name_Node); + end if; + + else + Name_Node := P_Defining_Program_Unit_Name; + end if; + + Scope.Table (Scope.Last).Labl := Name_Node; + Ignore (Tok_Colon); + + -- Deal with generic instantiation, the one case in which we do not + -- have a subprogram specification as part of whatever we are parsing + + if Token = Tok_Is then + Save_Scan_State (Scan_State); -- at the IS + T_Is; -- checks for redundant IS + + if Token = Tok_New then + if not Pf_Flags.Gins then + Error_Msg_SC ("generic instantiation not allowed here!"); + end if; + + Scan; -- past NEW + + if Func then + Inst_Node := New_Node (N_Function_Instantiation, Fproc_Sloc); + Set_Name (Inst_Node, P_Function_Name); + else + Inst_Node := New_Node (N_Procedure_Instantiation, Fproc_Sloc); + Set_Name (Inst_Node, P_Qualified_Simple_Name); + end if; + + Set_Defining_Unit_Name (Inst_Node, Name_Node); + Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt); + P_Aspect_Specifications (Inst_Node); + Pop_Scope_Stack; -- Don't need scope stack entry in this case + + if Is_Overriding then + Set_Must_Override (Inst_Node); + + elsif Not_Overriding then + Set_Must_Not_Override (Inst_Node); + end if; + + return Inst_Node; + + else + Restore_Scan_State (Scan_State); -- to the IS + end if; + end if; + + -- If not a generic instantiation, then we definitely have a subprogram + -- specification (all possibilities at this stage include one here) + + Fpart_Sloc := Token_Ptr; + + Check_Misspelling_Of (Tok_Return); + + -- Scan formal part. First a special error check. If we have an + -- identifier here, then we have a definite error. If this identifier + -- is on the same line as the designator, then we assume it is the + -- first formal after a missing left parenthesis + + if Token = Tok_Identifier + and then not Token_Is_At_Start_Of_Line + then + T_Left_Paren; -- to generate message + Fpart_List := P_Formal_Part; + + -- Otherwise scan out an optional formal part in the usual manner + + else + Fpart_List := P_Parameter_Profile; + end if; + + -- We treat what we have as a function specification if FUNCTION was + -- used, or if a RETURN is present. This gives better error recovery + -- since later RETURN statements will be valid in either case. + + Check_Junk_Semicolon_Before_Return; + Result_Node := Error; + + if Token = Tok_Return then + if not Func then + Error_Msg -- CODEFIX + ("PROCEDURE should be FUNCTION", Fproc_Sloc); + Func := True; + end if; + + Scan; -- past RETURN + + Result_Not_Null := P_Null_Exclusion; -- Ada 2005 (AI-231) + + -- Ada 2005 (AI-318-02) + + if Token = Tok_Access then + if Ada_Version < Ada_2005 then + Error_Msg_SC + ("anonymous access result type is an Ada 2005 extension"); + Error_Msg_SC ("\unit must be compiled with -gnat05 switch"); + end if; + + Result_Node := P_Access_Definition (Result_Not_Null); + + else + Result_Node := P_Subtype_Mark; + No_Constraint; + end if; + + else + -- Skip extra parenthesis at end of formal part + + Ignore (Tok_Right_Paren); + + -- For function, scan result subtype + + if Func then + TF_Return; + + if Prev_Token = Tok_Return then + Result_Node := P_Subtype_Mark; + end if; + end if; + end if; + + if Func then + Specification_Node := + New_Node (N_Function_Specification, Fproc_Sloc); + + Set_Null_Exclusion_Present (Specification_Node, Result_Not_Null); + Set_Result_Definition (Specification_Node, Result_Node); + + else + Specification_Node := + New_Node (N_Procedure_Specification, Fproc_Sloc); + end if; + + Set_Defining_Unit_Name (Specification_Node, Name_Node); + Set_Parameter_Specifications (Specification_Node, Fpart_List); + + if Is_Overriding then + Set_Must_Override (Specification_Node); + + elsif Not_Overriding then + Set_Must_Not_Override (Specification_Node); + end if; + + -- Error check: barriers not allowed on protected functions/procedures + + if Token = Tok_When then + if Func then + Error_Msg_SC ("barrier not allowed on function, only on entry"); + else + Error_Msg_SC ("barrier not allowed on procedure, only on entry"); + end if; + + Scan; -- past WHEN + Discard_Junk_Node (P_Expression); + end if; + + -- Deal with semicolon followed by IS. We want to treat this as IS + + if Token = Tok_Semicolon then + Save_Scan_State (Scan_State); + Scan; -- past semicolon + + if Token = Tok_Is then + Error_Msg_SP -- CODEFIX + ("extra "";"" ignored"); + else + Restore_Scan_State (Scan_State); + end if; + end if; + + -- Subprogram declaration ended by aspect specifications + + if Aspect_Specifications_Present then + goto Subprogram_Declaration; + + -- Deal with case of semicolon ending a subprogram declaration + + elsif Token = Tok_Semicolon then + if not Pf_Flags.Decl then + T_Is; + end if; + + Save_Scan_State (Scan_State); + Scan; -- past semicolon + + -- If semicolon is immediately followed by IS, then ignore the + -- semicolon, and go process the body. + + if Token = Tok_Is then + Error_Msg_SP -- CODEFIX + ("|extra "";"" ignored"); + T_Is; -- scan past IS + goto Subprogram_Body; + + -- If BEGIN follows in an appropriate column, we immediately + -- commence the error action of assuming that the previous + -- subprogram declaration should have been a subprogram body, + -- i.e. that the terminating semicolon should have been IS. + + elsif Token = Tok_Begin + and then Start_Column >= Scope.Table (Scope.Last).Ecol + then + Error_Msg_SP -- CODEFIX + ("|"";"" should be IS!"); + goto Subprogram_Body; + + else + Restore_Scan_State (Scan_State); + goto Subprogram_Declaration; + end if; + + -- Case of not followed by semicolon + + else + -- Subprogram renaming declaration case + + Check_Misspelling_Of (Tok_Renames); + + if Token = Tok_Renames then + if not Pf_Flags.Rnam then + Error_Msg_SC ("renaming declaration not allowed here!"); + end if; + + Rename_Node := + New_Node (N_Subprogram_Renaming_Declaration, Token_Ptr); + Scan; -- past RENAMES + Set_Name (Rename_Node, P_Name); + Set_Specification (Rename_Node, Specification_Node); + TF_Semicolon; + Pop_Scope_Stack; + return Rename_Node; + + -- Case of IS following subprogram specification + + elsif Token = Tok_Is then + T_Is; -- ignore redundant Is's + + if Token_Name = Name_Abstract then + Check_95_Keyword (Tok_Abstract, Tok_Semicolon); + end if; + + -- Deal nicely with (now obsolete) use of <> in place of abstract + + if Token = Tok_Box then + Error_Msg_SC -- CODEFIX + ("ABSTRACT expected"); + Token := Tok_Abstract; + end if; + + -- Abstract subprogram declaration case + + if Token = Tok_Abstract then + Absdec_Node := + New_Node (N_Abstract_Subprogram_Declaration, Token_Ptr); + Set_Specification (Absdec_Node, Specification_Node); + Pop_Scope_Stack; -- discard unneeded entry + Scan; -- past ABSTRACT + P_Aspect_Specifications (Absdec_Node); + return Absdec_Node; + + -- Ada 2005 (AI-248): Parse a null procedure declaration + + elsif Token = Tok_Null then + if Ada_Version < Ada_2005 then + Error_Msg_SP ("null procedures are an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + end if; + + Scan; -- past NULL + + if Func then + Error_Msg_SP ("only procedures can be null"); + else + Set_Null_Present (Specification_Node); + end if; + + goto Subprogram_Declaration; + + -- Check for IS NEW with Formal_Part present and handle nicely + + elsif Token = Tok_New then + Error_Msg + ("formal part not allowed in instantiation", Fpart_Sloc); + Scan; -- past NEW + + if Func then + Inst_Node := New_Node (N_Function_Instantiation, Fproc_Sloc); + else + Inst_Node := + New_Node (N_Procedure_Instantiation, Fproc_Sloc); + end if; + + Set_Defining_Unit_Name (Inst_Node, Name_Node); + Set_Name (Inst_Node, P_Name); + Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt); + TF_Semicolon; + Pop_Scope_Stack; -- Don't need scope stack entry in this case + return Inst_Node; + + else + goto Subprogram_Body; + end if; + + -- Aspect specifications present + + elsif Aspect_Specifications_Present then + goto Subprogram_Declaration; + + -- Here we have a missing IS or missing semicolon, we always guess + -- a missing semicolon, since we are pretty good at fixing up a + -- semicolon which should really be an IS + + else + Error_Msg_AP -- CODEFIX + ("|missing "";"""); + SIS_Missing_Semicolon_Message := Get_Msg_Id; + goto Subprogram_Declaration; + end if; + end if; + + -- Processing for stub or subprogram body or parameterized expression + + <> + + -- Subprogram body stub case + + if Separate_Present then + if not Pf_Flags.Stub then + Error_Msg_SC ("body stub not allowed here!"); + end if; + + if Nkind (Name_Node) = N_Defining_Operator_Symbol then + Error_Msg + ("operator symbol cannot be used as subunit name", + Sloc (Name_Node)); + end if; + + Stub_Node := + New_Node (N_Subprogram_Body_Stub, Sloc (Specification_Node)); + Set_Specification (Stub_Node, Specification_Node); + Scan; -- past SEPARATE + Pop_Scope_Stack; + TF_Semicolon; + return Stub_Node; + + -- Subprogram body or parameterized expression case + + else + Scan_Body_Or_Parameterized_Expression : declare + + function Likely_Parameterized_Expression return Boolean; + -- Returns True if we have a probably case of a parameterized + -- expression omitting the parentheses, if so, returns True + -- and emits an appropriate error message, else returns False. + + ------------------------------------- + -- Likely_Parameterized_Expression -- + ------------------------------------- + + function Likely_Parameterized_Expression return Boolean is + begin + -- If currently pointing to BEGIN or a declaration keyword + -- or a pragma, then we definitely have a subprogram body. + -- This is a common case, so worth testing first. + + if Token = Tok_Begin + or else Token in Token_Class_Declk + or else Token = Tok_Pragma + then + return False; + + -- Test for tokens which could only start an expression and + -- thus signal the case of a parameterized expression. + + elsif Token in Token_Class_Literal + or else Token in Token_Class_Unary_Addop + or else Token = Tok_Left_Paren + or else Token = Tok_Abs + or else Token = Tok_Null + or else Token = Tok_New + or else Token = Tok_Not + then + null; + + -- Anything other than an identifier must be a body + + elsif Token /= Tok_Identifier then + return False; + + -- Here for an identifier + + else + -- If the identifier is the first token on its line, then + -- let's assume that we have a missing begin and this is + -- intended as a subprogram body. + + if Token_Is_At_Start_Of_Line then + return False; + + -- Otherwise we have to scan ahead. If the identifier is + -- followed by a colon or a comma, it is a declaration + -- and hence we have a subprogram body. Otherwise assume + -- a parameterized expression. + + else + declare + Scan_State : Saved_Scan_State; + Tok : Token_Type; + begin + Save_Scan_State (Scan_State); + Scan; -- past identifier + Tok := Token; + Restore_Scan_State (Scan_State); + + if Tok = Tok_Colon or else Tok = Tok_Comma then + return False; + end if; + end; + end if; + end if; + + -- Fall through if we have a likely parameterized expression + + Error_Msg_SC + ("parameterized expression must be " + & "enclosed in parentheses"); + return True; + end Likely_Parameterized_Expression; + + -- Start of processing for Scan_Body_Or_Parameterized_Expression + + begin + -- Parameterized_Expression case + + if Token = Tok_Left_Paren + or else Likely_Parameterized_Expression + then + -- Check parameterized expression allowed here + + if not Pf_Flags.Pexp then + Error_Msg_SC + ("parameterized expression not allowed here!"); + end if; + + -- Check we are in Ada 2012 mode + + if Ada_Version < Ada_2012 then + Error_Msg_SC + ("parameterized expression is an Ada 2012 feature!"); + Error_Msg_SC + ("\unit must be compiled with -gnat2012 switch!"); + end if; + + -- Parse out expression and build parameterized expression + + Body_Node := + New_Node + (N_Parameterized_Expression, Sloc (Specification_Node)); + Set_Specification (Body_Node, Specification_Node); + Set_Expression (Body_Node, P_Expression); + T_Semicolon; + Pop_Scope_Stack; + + -- Subprogram body case + + else + -- Check body allowed here + + if not Pf_Flags.Pbod then + Error_Msg_SP ("subprogram body not allowed here!"); + end if; + + -- Here is the test for a suspicious IS (i.e. one that + -- looks like it might more properly be a semicolon). + -- See separate section describing use of IS instead + -- of semicolon in package Parse. + + if (Token in Token_Class_Declk + or else + Token = Tok_Identifier) + and then Start_Column <= Scope.Table (Scope.Last).Ecol + and then Scope.Last /= 1 + then + Scope.Table (Scope.Last).Etyp := E_Suspicious_Is; + Scope.Table (Scope.Last).S_Is := Prev_Token_Ptr; + end if; + + -- Build and return subprogram body, parsing declarations + -- and statement sequence that belong to the body. + + Body_Node := + New_Node (N_Subprogram_Body, Sloc (Specification_Node)); + Set_Specification (Body_Node, Specification_Node); + Parse_Decls_Begin_End (Body_Node); + end if; + + return Body_Node; + end Scan_Body_Or_Parameterized_Expression; + end if; + + -- Processing for subprogram declaration + + <> + Decl_Node := + New_Node (N_Subprogram_Declaration, Sloc (Specification_Node)); + Set_Specification (Decl_Node, Specification_Node); + P_Aspect_Specifications (Decl_Node); + + -- If this is a context in which a subprogram body is permitted, + -- set active SIS entry in case (see section titled "Handling + -- Semicolon Used in Place of IS" in body of Parser package) + -- Note that SIS_Missing_Semicolon_Message is already set properly. + + if Pf_Flags.Pbod then + SIS_Labl := Scope.Table (Scope.Last).Labl; + SIS_Sloc := Scope.Table (Scope.Last).Sloc; + SIS_Ecol := Scope.Table (Scope.Last).Ecol; + SIS_Declaration_Node := Decl_Node; + SIS_Semicolon_Sloc := Prev_Token_Ptr; + SIS_Entry_Active := True; + end if; + + Pop_Scope_Stack; + return Decl_Node; + end P_Subprogram; + + --------------------------------- + -- 6.1 Subprogram Declaration -- + --------------------------------- + + -- Parsed by P_Subprogram (6.1) + + ------------------------------------------ + -- 6.1 Abstract Subprogram Declaration -- + ------------------------------------------ + + -- Parsed by P_Subprogram (6.1) + + ----------------------------------- + -- 6.1 Subprogram Specification -- + ----------------------------------- + + -- SUBPROGRAM_SPECIFICATION ::= + -- procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE + -- | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE + + -- PARAMETER_PROFILE ::= [FORMAL_PART] + + -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK + + -- Subprogram specifications that appear in subprogram declarations + -- are parsed by P_Subprogram (6.1). This routine is used in other + -- contexts where subprogram specifications occur. + + -- Note: this routine does not affect the scope stack in any way + + -- Error recovery: can raise Error_Resync + + function P_Subprogram_Specification return Node_Id is + Specification_Node : Node_Id; + Result_Not_Null : Boolean; + Result_Node : Node_Id; + + begin + if Token = Tok_Function then + Specification_Node := New_Node (N_Function_Specification, Token_Ptr); + Scan; -- past FUNCTION + Ignore (Tok_Body); + Set_Defining_Unit_Name (Specification_Node, P_Defining_Designator); + Set_Parameter_Specifications + (Specification_Node, P_Parameter_Profile); + Check_Junk_Semicolon_Before_Return; + TF_Return; + + Result_Not_Null := P_Null_Exclusion; -- Ada 2005 (AI-231) + + -- Ada 2005 (AI-318-02) + + if Token = Tok_Access then + if Ada_Version < Ada_2005 then + Error_Msg_SC + ("anonymous access result type is an Ada 2005 extension"); + Error_Msg_SC ("\unit must be compiled with -gnat05 switch"); + end if; + + Result_Node := P_Access_Definition (Result_Not_Null); + + else + Result_Node := P_Subtype_Mark; + No_Constraint; + end if; + + Set_Null_Exclusion_Present (Specification_Node, Result_Not_Null); + Set_Result_Definition (Specification_Node, Result_Node); + return Specification_Node; + + elsif Token = Tok_Procedure then + Specification_Node := New_Node (N_Procedure_Specification, Token_Ptr); + Scan; -- past PROCEDURE + Ignore (Tok_Body); + Set_Defining_Unit_Name + (Specification_Node, P_Defining_Program_Unit_Name); + Set_Parameter_Specifications + (Specification_Node, P_Parameter_Profile); + return Specification_Node; + + else + Error_Msg_SC ("subprogram specification expected"); + raise Error_Resync; + end if; + end P_Subprogram_Specification; + + --------------------- + -- 6.1 Designator -- + --------------------- + + -- DESIGNATOR ::= + -- [PARENT_UNIT_NAME .] IDENTIFIER | OPERATOR_SYMBOL + + -- The caller has checked that the initial token is an identifier, + -- operator symbol, or string literal. Note that we don't bother to + -- do much error diagnosis in this routine, since it is only used for + -- the label on END lines, and the routines in package Par.Endh will + -- check that the label is appropriate. + + -- Error recovery: cannot raise Error_Resync + + function P_Designator return Node_Id is + Ident_Node : Node_Id; + Name_Node : Node_Id; + Prefix_Node : Node_Id; + + function Real_Dot return Boolean; + -- Tests if a current token is an interesting period, i.e. is followed + -- by an identifier or operator symbol or string literal. If not, it is + -- probably just incorrect punctuation to be caught by our caller. Note + -- that the case of an operator symbol or string literal is also an + -- error, but that is an error that we catch here. If the result is + -- True, a real dot has been scanned and we are positioned past it, + -- if the result is False, the scan position is unchanged. + + -------------- + -- Real_Dot -- + -------------- + + function Real_Dot return Boolean is + Scan_State : Saved_Scan_State; + + begin + if Token /= Tok_Dot then + return False; + + else + Save_Scan_State (Scan_State); + Scan; -- past dot + + if Token = Tok_Identifier + or else Token = Tok_Operator_Symbol + or else Token = Tok_String_Literal + then + return True; + + else + Restore_Scan_State (Scan_State); + return False; + end if; + end if; + end Real_Dot; + + -- Start of processing for P_Designator + + begin + Ident_Node := Token_Node; + Scan; -- past initial token + + if Prev_Token = Tok_Operator_Symbol + or else Prev_Token = Tok_String_Literal + or else not Real_Dot + then + return Ident_Node; + + -- Child name case + + else + Prefix_Node := Ident_Node; + + -- Loop through child names, on entry to this loop, Prefix contains + -- the name scanned so far, and Ident_Node is the last identifier. + + loop + Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr); + Set_Prefix (Name_Node, Prefix_Node); + Ident_Node := P_Identifier; + Set_Selector_Name (Name_Node, Ident_Node); + Prefix_Node := Name_Node; + exit when not Real_Dot; + end loop; + + -- On exit from the loop, Ident_Node is the last identifier scanned, + -- i.e. the defining identifier, and Prefix_Node is a node for the + -- entire name, structured (incorrectly!) as a selected component. + + Name_Node := Prefix (Prefix_Node); + Change_Node (Prefix_Node, N_Designator); + Set_Name (Prefix_Node, Name_Node); + Set_Identifier (Prefix_Node, Ident_Node); + return Prefix_Node; + end if; + + exception + when Error_Resync => + while Token = Tok_Dot or else Token = Tok_Identifier loop + Scan; + end loop; + + return Error; + end P_Designator; + + ------------------------------ + -- 6.1 Defining Designator -- + ------------------------------ + + -- DEFINING_DESIGNATOR ::= + -- DEFINING_PROGRAM_UNIT_NAME | DEFINING_OPERATOR_SYMBOL + + -- Error recovery: cannot raise Error_Resync + + function P_Defining_Designator return Node_Id is + begin + if Token = Tok_Operator_Symbol then + return P_Defining_Operator_Symbol; + + elsif Token = Tok_String_Literal then + Error_Msg_SC ("invalid operator name"); + Scan; -- past junk string + return Error; + + else + return P_Defining_Program_Unit_Name; + end if; + end P_Defining_Designator; + + ------------------------------------- + -- 6.1 Defining Program Unit Name -- + ------------------------------------- + + -- DEFINING_PROGRAM_UNIT_NAME ::= + -- [PARENT_UNIT_NAME .] DEFINING_IDENTIFIER + + -- Note: PARENT_UNIT_NAME may be present only in 95 mode at the outer level + + -- Error recovery: cannot raise Error_Resync + + function P_Defining_Program_Unit_Name return Node_Id is + Ident_Node : Node_Id; + Name_Node : Node_Id; + Prefix_Node : Node_Id; + + begin + -- Set identifier casing if not already set and scan initial identifier + + if Token = Tok_Identifier + and then Identifier_Casing (Current_Source_File) = Unknown + then + Set_Identifier_Casing (Current_Source_File, Determine_Token_Casing); + end if; + + Ident_Node := P_Identifier (C_Dot); + Merge_Identifier (Ident_Node, Tok_Return); + + -- Normal case (not child library unit name) + + if Token /= Tok_Dot then + Change_Identifier_To_Defining_Identifier (Ident_Node); + return Ident_Node; + + -- Child library unit name case + + else + if Scope.Last > 1 then + Error_Msg_SP ("child unit allowed only at library level"); + raise Error_Resync; + + elsif Ada_Version = Ada_83 then + Error_Msg_SP ("(Ada 83) child unit not allowed!"); + + end if; + + Prefix_Node := Ident_Node; + + -- Loop through child names, on entry to this loop, Prefix contains + -- the name scanned so far, and Ident_Node is the last identifier. + + loop + exit when Token /= Tok_Dot; + Name_Node := New_Node (N_Selected_Component, Token_Ptr); + Scan; -- past period + Set_Prefix (Name_Node, Prefix_Node); + Ident_Node := P_Identifier (C_Dot); + Set_Selector_Name (Name_Node, Ident_Node); + Prefix_Node := Name_Node; + end loop; + + -- On exit from the loop, Ident_Node is the last identifier scanned, + -- i.e. the defining identifier, and Prefix_Node is a node for the + -- entire name, structured (incorrectly!) as a selected component. + + Name_Node := Prefix (Prefix_Node); + Change_Node (Prefix_Node, N_Defining_Program_Unit_Name); + Set_Name (Prefix_Node, Name_Node); + Change_Identifier_To_Defining_Identifier (Ident_Node); + Set_Defining_Identifier (Prefix_Node, Ident_Node); + + -- All set with unit name parsed + + return Prefix_Node; + end if; + + exception + when Error_Resync => + while Token = Tok_Dot or else Token = Tok_Identifier loop + Scan; + end loop; + + return Error; + end P_Defining_Program_Unit_Name; + + -------------------------- + -- 6.1 Operator Symbol -- + -------------------------- + + -- OPERATOR_SYMBOL ::= STRING_LITERAL + + -- Operator symbol is returned by the scanner as Tok_Operator_Symbol + + ----------------------------------- + -- 6.1 Defining Operator Symbol -- + ----------------------------------- + + -- DEFINING_OPERATOR_SYMBOL ::= OPERATOR_SYMBOL + + -- The caller has checked that the initial symbol is an operator symbol + + function P_Defining_Operator_Symbol return Node_Id is + Op_Node : Node_Id; + + begin + Op_Node := Token_Node; + Change_Operator_Symbol_To_Defining_Operator_Symbol (Op_Node); + Scan; -- past operator symbol + return Op_Node; + end P_Defining_Operator_Symbol; + + ---------------------------- + -- 6.1 Parameter_Profile -- + ---------------------------- + + -- PARAMETER_PROFILE ::= [FORMAL_PART] + + -- Empty is returned if no formal part is present + + -- Error recovery: cannot raise Error_Resync + + function P_Parameter_Profile return List_Id is + begin + if Token = Tok_Left_Paren then + Scan; -- part left paren + return P_Formal_Part; + else + return No_List; + end if; + end P_Parameter_Profile; + + --------------------------------------- + -- 6.1 Parameter And Result Profile -- + --------------------------------------- + + -- Parsed by its parent construct, which uses P_Parameter_Profile to + -- parse the parameters, and P_Subtype_Mark to parse the return type. + + ---------------------- + -- 6.1 Formal part -- + ---------------------- + + -- FORMAL_PART ::= (PARAMETER_SPECIFICATION {; PARAMETER_SPECIFICATION}) + + -- PARAMETER_SPECIFICATION ::= + -- DEFINING_IDENTIFIER_LIST : MODE [NULL_EXCLUSION] SUBTYPE_MARK + -- [:= DEFAULT_EXPRESSION] + -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION + -- [:= DEFAULT_EXPRESSION] + + -- This scans the construct Formal_Part. The caller has already checked + -- that the initial token is a left parenthesis, and skipped past it, so + -- that on entry Token is the first token following the left parenthesis. + + -- Error recovery: cannot raise Error_Resync + + function P_Formal_Part return List_Id is + Specification_List : List_Id; + Specification_Node : Node_Id; + Scan_State : Saved_Scan_State; + Num_Idents : Nat; + Ident : Nat; + Ident_Sloc : Source_Ptr; + Not_Null_Present : Boolean := False; + Not_Null_Sloc : Source_Ptr; + + Idents : array (Int range 1 .. 4096) of Entity_Id; + -- This array holds the list of defining identifiers. The upper bound + -- of 4096 is intended to be essentially infinite, and we do not even + -- bother to check for it being exceeded. + + begin + Specification_List := New_List; + Specification_Loop : loop + begin + if Token = Tok_Pragma then + Error_Msg_SC ("pragma not allowed in formal part"); + Discard_Junk_Node (P_Pragma (Skipping => True)); + end if; + + Ignore (Tok_Left_Paren); + Ident_Sloc := Token_Ptr; + Idents (1) := P_Defining_Identifier (C_Comma_Colon); + Num_Idents := 1; + + Ident_Loop : loop + exit Ident_Loop when Token = Tok_Colon; + + -- The only valid tokens are colon and comma, so if we have + -- neither do a bit of investigation to see which is the + -- better choice for insertion. + + if Token /= Tok_Comma then + + -- Assume colon if IN or OUT keyword found + + exit Ident_Loop when Token = Tok_In or else Token = Tok_Out; + + -- Otherwise scan ahead + + Save_Scan_State (Scan_State); + Look_Ahead : loop + + -- If we run into a semicolon, then assume that a + -- colon was missing, e.g. Parms (X Y; ...). Also + -- assume missing colon on EOF (a real disaster!) + -- and on a right paren, e.g. Parms (X Y), and also + -- on an assignment symbol, e.g. Parms (X Y := ..) + + if Token = Tok_Semicolon + or else Token = Tok_Right_Paren + or else Token = Tok_EOF + or else Token = Tok_Colon_Equal + then + Restore_Scan_State (Scan_State); + exit Ident_Loop; + + -- If we run into a colon, assume that we had a missing + -- comma, e.g. Parms (A B : ...). Also assume a missing + -- comma if we hit another comma, e.g. Parms (A B, C ..) + + elsif Token = Tok_Colon + or else Token = Tok_Comma + then + Restore_Scan_State (Scan_State); + exit Look_Ahead; + end if; + + Scan; + end loop Look_Ahead; + end if; + + -- Here if a comma is present, or to be assumed + + T_Comma; + Num_Idents := Num_Idents + 1; + Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon); + end loop Ident_Loop; + + -- Fall through the loop on encountering a colon, or deciding + -- that there is a missing colon. + + T_Colon; + + -- If there are multiple identifiers, we repeatedly scan the + -- type and initialization expression information by resetting + -- the scan pointer (so that we get completely separate trees + -- for each occurrence). + + if Num_Idents > 1 then + Save_Scan_State (Scan_State); + end if; + + -- Loop through defining identifiers in list + + Ident := 1; + + Ident_List_Loop : loop + Specification_Node := + New_Node (N_Parameter_Specification, Ident_Sloc); + Set_Defining_Identifier (Specification_Node, Idents (Ident)); + + -- Scan possible NOT NULL for Ada 2005 (AI-231, AI-447) + + Not_Null_Sloc := Token_Ptr; + Not_Null_Present := + P_Null_Exclusion (Allow_Anonymous_In_95 => True); + + -- Case of ACCESS keyword present + + if Token = Tok_Access then + Set_Null_Exclusion_Present + (Specification_Node, Not_Null_Present); + + if Ada_Version = Ada_83 then + Error_Msg_SC ("(Ada 83) access parameters not allowed"); + end if; + + Set_Parameter_Type + (Specification_Node, + P_Access_Definition (Not_Null_Present)); + + -- Case of IN or OUT present + + else + if Token = Tok_In or else Token = Tok_Out then + if Not_Null_Present then + Error_Msg + ("`NOT NULL` can only be used with `ACCESS`", + Not_Null_Sloc); + + if Token = Tok_In then + Error_Msg + ("\`IN` not allowed together with `ACCESS`", + Not_Null_Sloc); + else + Error_Msg + ("\`OUT` not allowed together with `ACCESS`", + Not_Null_Sloc); + end if; + end if; + + P_Mode (Specification_Node); + Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) + end if; + + Set_Null_Exclusion_Present + (Specification_Node, Not_Null_Present); + + if Token = Tok_Procedure + or else + Token = Tok_Function + then + Error_Msg_SC ("formal subprogram parameter not allowed"); + Scan; + + if Token = Tok_Left_Paren then + Discard_Junk_List (P_Formal_Part); + end if; + + if Token = Tok_Return then + Scan; + Discard_Junk_Node (P_Subtype_Mark); + end if; + + Set_Parameter_Type (Specification_Node, Error); + + else + Set_Parameter_Type (Specification_Node, P_Subtype_Mark); + No_Constraint; + end if; + end if; + + Set_Expression (Specification_Node, Init_Expr_Opt (True)); + + if Ident > 1 then + Set_Prev_Ids (Specification_Node, True); + end if; + + if Ident < Num_Idents then + Set_More_Ids (Specification_Node, True); + end if; + + Append (Specification_Node, Specification_List); + exit Ident_List_Loop when Ident = Num_Idents; + Ident := Ident + 1; + Restore_Scan_State (Scan_State); + end loop Ident_List_Loop; + + exception + when Error_Resync => + Resync_Semicolon_List; + end; + + if Token = Tok_Semicolon then + Save_Scan_State (Scan_State); + Scan; -- past semicolon + + -- If we have RETURN or IS after the semicolon, then assume + -- that semicolon should have been a right parenthesis and exit + + if Token = Tok_Is or else Token = Tok_Return then + Error_Msg_SP -- CODEFIX + ("|"";"" should be "")"""); + exit Specification_Loop; + end if; + + -- If we have a declaration keyword after the semicolon, then + -- assume we had a missing right parenthesis and terminate list + + if Token in Token_Class_Declk then + Error_Msg_AP -- CODEFIX + ("missing "")"""); + Restore_Scan_State (Scan_State); + exit Specification_Loop; + end if; + + elsif Token = Tok_Right_Paren then + Scan; -- past right paren + exit Specification_Loop; + + -- Special check for common error of using comma instead of semicolon + + elsif Token = Tok_Comma then + T_Semicolon; + Scan; -- past comma + + -- Special check for omitted separator + + elsif Token = Tok_Identifier then + T_Semicolon; + + -- If nothing sensible, skip to next semicolon or right paren + + else + T_Semicolon; + Resync_Semicolon_List; + + if Token = Tok_Semicolon then + Scan; -- past semicolon + else + T_Right_Paren; + exit Specification_Loop; + end if; + end if; + end loop Specification_Loop; + + return Specification_List; + end P_Formal_Part; + + ---------------------------------- + -- 6.1 Parameter Specification -- + ---------------------------------- + + -- Parsed by P_Formal_Part (6.1) + + --------------- + -- 6.1 Mode -- + --------------- + + -- MODE ::= [in] | in out | out + + -- There is no explicit node in the tree for the Mode. Instead the + -- In_Present and Out_Present flags are set in the parent node to + -- record the presence of keywords specifying the mode. + + -- Error_Recovery: cannot raise Error_Resync + + procedure P_Mode (Node : Node_Id) is + begin + if Token = Tok_In then + Scan; -- past IN + Set_In_Present (Node, True); + + if Style.Mode_In_Check and then Token /= Tok_Out then + Error_Msg_SP -- CODEFIX + ("(style) IN should be omitted"); + end if; + + if Token = Tok_Access then + Error_Msg_SP ("IN not allowed together with ACCESS"); + Scan; -- past ACCESS + end if; + end if; + + if Token = Tok_Out then + Scan; -- past OUT + Set_Out_Present (Node, True); + end if; + + if Token = Tok_In then + Error_Msg_SC ("IN must precede OUT in parameter mode"); + Scan; -- past IN + Set_In_Present (Node, True); + end if; + end P_Mode; + + -------------------------- + -- 6.3 Subprogram Body -- + -------------------------- + + -- Parsed by P_Subprogram (6.1) + + ----------------------------------- + -- 6.4 Procedure Call Statement -- + ----------------------------------- + + -- Parsed by P_Sequence_Of_Statements (5.1) + + ------------------------ + -- 6.4 Function Call -- + ------------------------ + + -- Parsed by P_Call_Or_Name (4.1) + + -------------------------------- + -- 6.4 Actual Parameter Part -- + -------------------------------- + + -- Parsed by P_Call_Or_Name (4.1) + + -------------------------------- + -- 6.4 Parameter Association -- + -------------------------------- + + -- Parsed by P_Call_Or_Name (4.1) + + ------------------------------------ + -- 6.4 Explicit Actual Parameter -- + ------------------------------------ + + -- Parsed by P_Call_Or_Name (4.1) + + --------------------------- + -- 6.5 Return Statement -- + --------------------------- + + -- SIMPLE_RETURN_STATEMENT ::= return [EXPRESSION]; + -- + -- EXTENDED_RETURN_STATEMENT ::= + -- return DEFINING_IDENTIFIER : [aliased] RETURN_SUBTYPE_INDICATION + -- [:= EXPRESSION] [do + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end return]; + -- + -- RETURN_SUBTYPE_INDICATION ::= SUBTYPE_INDICATION | ACCESS_DEFINITION + + -- RETURN_STATEMENT ::= return [EXPRESSION]; + + -- Error recovery: can raise Error_Resync + + procedure P_Return_Subtype_Indication (Decl_Node : Node_Id) is + + -- Note: We don't need to check Ada_Version here, because this is + -- only called in >= Ada 2005 cases anyway. + + Not_Null_Present : constant Boolean := P_Null_Exclusion; + + begin + Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); + + if Token = Tok_Access then + Set_Object_Definition + (Decl_Node, P_Access_Definition (Not_Null_Present)); + else + Set_Object_Definition + (Decl_Node, P_Subtype_Indication (Not_Null_Present)); + end if; + end P_Return_Subtype_Indication; + + -- Error recovery: can raise Error_Resync + + function P_Return_Object_Declaration return Node_Id is + Return_Obj : Node_Id; + Decl_Node : Node_Id; + + begin + Return_Obj := Token_Node; + Change_Identifier_To_Defining_Identifier (Return_Obj); + Decl_Node := New_Node (N_Object_Declaration, Token_Ptr); + Set_Defining_Identifier (Decl_Node, Return_Obj); + + Scan; -- past identifier + Scan; -- past : + + -- First an error check, if we have two identifiers in a row, a likely + -- possibility is that the first of the identifiers is an incorrectly + -- spelled keyword. See similar check in P_Identifier_Declarations. + + if Token = Tok_Identifier then + declare + SS : Saved_Scan_State; + I2 : Boolean; + + begin + Save_Scan_State (SS); + Scan; -- past initial identifier + I2 := (Token = Tok_Identifier); + Restore_Scan_State (SS); + + if I2 + and then + (Bad_Spelling_Of (Tok_Access) or else + Bad_Spelling_Of (Tok_Aliased) or else + Bad_Spelling_Of (Tok_Constant)) + then + null; + end if; + end; + end if; + + -- We allow "constant" here (as in "return Result : constant + -- T..."). This is not in the latest RM, but the ARG is considering an + -- AI on the subject (see AI05-0015-1), which we expect to be approved. + + if Token = Tok_Constant then + Scan; -- past CONSTANT + Set_Constant_Present (Decl_Node); + + if Token = Tok_Aliased then + Error_Msg_SC -- CODEFIX + ("ALIASED should be before CONSTANT"); + Scan; -- past ALIASED + Set_Aliased_Present (Decl_Node); + end if; + + elsif Token = Tok_Aliased then + Scan; -- past ALIASED + Set_Aliased_Present (Decl_Node); + + if Token = Tok_Constant then + Scan; -- past CONSTANT + Set_Constant_Present (Decl_Node); + end if; + end if; + + P_Return_Subtype_Indication (Decl_Node); + + if Token = Tok_Colon_Equal then + Scan; -- past := + Set_Expression (Decl_Node, P_Expression_No_Right_Paren); + end if; + + return Decl_Node; + end P_Return_Object_Declaration; + + -- Error recovery: can raise Error_Resync + + function P_Return_Statement return Node_Id is + -- The caller has checked that the initial token is RETURN + + function Is_Simple return Boolean; + -- Scan state is just after RETURN (and is left that way). + -- Determine whether this is a simple or extended return statement + -- by looking ahead for "identifier :", which implies extended. + + --------------- + -- Is_Simple -- + --------------- + + function Is_Simple return Boolean is + Scan_State : Saved_Scan_State; + Result : Boolean := True; + + begin + if Token = Tok_Identifier then + Save_Scan_State (Scan_State); -- at identifier + Scan; -- past identifier + + if Token = Tok_Colon then + Result := False; -- It's an extended_return_statement. + end if; + + Restore_Scan_State (Scan_State); -- to identifier + end if; + + return Result; + end Is_Simple; + + Return_Sloc : constant Source_Ptr := Token_Ptr; + Return_Node : Node_Id; + + -- Start of processing for P_Return_Statement + + begin + Scan; -- past RETURN + + -- Simple_return_statement, no expression, return an + -- N_Simple_Return_Statement node with the expression field left Empty. + + if Token = Tok_Semicolon then + Scan; -- past ; + Return_Node := New_Node (N_Simple_Return_Statement, Return_Sloc); + + -- Non-trivial case + + else + -- Simple_return_statement with expression + + -- We avoid trying to scan an expression if we are at an + -- expression terminator since in that case the best error + -- message is probably that we have a missing semicolon. + + if Is_Simple then + Return_Node := New_Node (N_Simple_Return_Statement, Return_Sloc); + + if Token not in Token_Class_Eterm then + Set_Expression (Return_Node, P_Expression_No_Right_Paren); + end if; + + -- Extended_return_statement (Ada 2005 only -- AI-318): + + else + if Ada_Version < Ada_2005 then + Error_Msg_SP + (" extended_return_statement is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + end if; + + Return_Node := New_Node (N_Extended_Return_Statement, Return_Sloc); + Set_Return_Object_Declarations + (Return_Node, New_List (P_Return_Object_Declaration)); + + if Token = Tok_Do then + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Return; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Return_Sloc; + + Scan; -- past DO + Set_Handled_Statement_Sequence + (Return_Node, P_Handled_Sequence_Of_Statements); + End_Statements; + + -- Do we need to handle Error_Resync here??? + end if; + end if; + + TF_Semicolon; + end if; + + return Return_Node; + end P_Return_Statement; + +end Ch6; diff --git a/gcc/ada/par-ch7.adb b/gcc/ada/par-ch7.adb new file mode 100644 index 000000000..14fedc93a --- /dev/null +++ b/gcc/ada/par-ch7.adb @@ -0,0 +1,294 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 7 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +separate (Par) +package body Ch7 is + + --------------------------------------------- + -- 7.1 Package (also 8.5.3, 10.1.3, 12.3) -- + --------------------------------------------- + + -- This routine scans out a package declaration, package body, or a + -- renaming declaration or generic instantiation starting with PACKAGE + + -- PACKAGE_DECLARATION ::= + -- PACKAGE_SPECIFICATION + -- [ASPECT_SPECIFICATIONS]; + + -- PACKAGE_SPECIFICATION ::= + -- package DEFINING_PROGRAM_UNIT_NAME is + -- {BASIC_DECLARATIVE_ITEM} + -- [private + -- {BASIC_DECLARATIVE_ITEM}] + -- end [[PARENT_UNIT_NAME .] IDENTIFIER] + + -- PACKAGE_BODY ::= + -- package body DEFINING_PROGRAM_UNIT_NAME is + -- DECLARATIVE_PART + -- [begin + -- HANDLED_SEQUENCE_OF_STATEMENTS] + -- end [[PARENT_UNIT_NAME .] IDENTIFIER] + + -- PACKAGE_RENAMING_DECLARATION ::= + -- package DEFINING_IDENTIFIER renames package_NAME; + + -- PACKAGE_BODY_STUB ::= + -- package body DEFINING_IDENTIFIER is separate; + + -- PACKAGE_INSTANTIATION ::= + -- package DEFINING_PROGRAM_UNIT_NAME is + -- new generic_package_NAME [GENERIC_ACTUAL_PART] + -- [ASPECT_SPECIFICATIONS]; + + -- The value in Pf_Flags indicates which of these possible declarations + -- is acceptable to the caller: + + -- Pf_Flags.Spcn Set if specification OK + -- Pf_Flags.Decl Set if declaration OK + -- Pf_Flags.Gins Set if generic instantiation OK + -- Pf_Flags.Pbod Set if proper body OK + -- Pf_Flags.Rnam Set if renaming declaration OK + -- Pf_Flags.Stub Set if body stub OK + + -- If an inappropriate form is encountered, it is scanned out but an error + -- message indicating that it is appearing in an inappropriate context is + -- issued. The only possible settings for Pf_Flags are those defined as + -- constants in package Par. + + -- Note: in all contexts where a package specification is required, there + -- is a terminating semicolon. This semicolon is scanned out in the case + -- where Pf_Flags is set to Pf_Spcn, even though it is not strictly part + -- of the package specification (it's just too much trouble, and really + -- quite unnecessary, to deal with scanning out an END where the semicolon + -- after the END is not considered to be part of the END. + + -- The caller has checked that the initial token is PACKAGE + + -- Error recovery: cannot raise Error_Resync + + function P_Package + (Pf_Flags : Pf_Rec; + Decl : Node_Id := Empty) return Node_Id + is + Package_Node : Node_Id; + Specification_Node : Node_Id; + Name_Node : Node_Id; + Package_Sloc : Source_Ptr; + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Lreq := False; + + Package_Sloc := Token_Ptr; + Scan; -- past PACKAGE + + if Token = Tok_Type then + Error_Msg_SC -- CODEFIX + ("TYPE not allowed here"); + Scan; -- past TYPE + end if; + + -- Case of package body. Note that we demand a package body if that + -- is the only possibility (even if the BODY keyword is not present) + + if Token = Tok_Body or else Pf_Flags = Pf_Pbod_Pexp then + if not Pf_Flags.Pbod then + Error_Msg_SC ("package body cannot appear here!"); + end if; + + T_Body; + Name_Node := P_Defining_Program_Unit_Name; + Scope.Table (Scope.Last).Labl := Name_Node; + TF_Is; + + if Separate_Present then + if not Pf_Flags.Stub then + Error_Msg_SC ("body stub cannot appear here!"); + end if; + + Scan; -- past SEPARATE + TF_Semicolon; + Pop_Scope_Stack; + + Package_Node := New_Node (N_Package_Body_Stub, Package_Sloc); + Set_Defining_Identifier (Package_Node, Name_Node); + + else + Package_Node := New_Node (N_Package_Body, Package_Sloc); + Set_Defining_Unit_Name (Package_Node, Name_Node); + Parse_Decls_Begin_End (Package_Node); + end if; + + return Package_Node; + + -- Cases other than Package_Body + + else + Name_Node := P_Defining_Program_Unit_Name; + Scope.Table (Scope.Last).Labl := Name_Node; + + -- Case of renaming declaration + + Check_Misspelling_Of (Tok_Renames); + + if Token = Tok_Renames then + if not Pf_Flags.Rnam then + Error_Msg_SC ("renaming declaration cannot appear here!"); + end if; + + Scan; -- past RENAMES; + + Package_Node := + New_Node (N_Package_Renaming_Declaration, Package_Sloc); + Set_Defining_Unit_Name (Package_Node, Name_Node); + Set_Name (Package_Node, P_Qualified_Simple_Name); + + No_Constraint; + TF_Semicolon; + Pop_Scope_Stack; + return Package_Node; + + else + TF_Is; + + -- Case of generic instantiation + + if Token = Tok_New then + if not Pf_Flags.Gins then + Error_Msg_SC + ("generic instantiation cannot appear here!"); + end if; + + Scan; -- past NEW + + Package_Node := + New_Node (N_Package_Instantiation, Package_Sloc); + Set_Defining_Unit_Name (Package_Node, Name_Node); + Set_Name (Package_Node, P_Qualified_Simple_Name); + Set_Generic_Associations + (Package_Node, P_Generic_Actual_Part_Opt); + P_Aspect_Specifications (Package_Node); + Pop_Scope_Stack; + + -- Case of package declaration or package specification + + else + Specification_Node := + New_Node (N_Package_Specification, Package_Sloc); + + Set_Defining_Unit_Name (Specification_Node, Name_Node); + Set_Visible_Declarations + (Specification_Node, P_Basic_Declarative_Items); + + if Token = Tok_Private then + Error_Msg_Col := Scope.Table (Scope.Last).Ecol; + + if RM_Column_Check then + if Token_Is_At_Start_Of_Line + and then Start_Column /= Error_Msg_Col + then + Error_Msg_SC + ("(style) PRIVATE in wrong column, should be@"); + end if; + end if; + + Scan; -- past PRIVATE + Set_Private_Declarations + (Specification_Node, P_Basic_Declarative_Items); + + -- Deal gracefully with multiple PRIVATE parts + + while Token = Tok_Private loop + Error_Msg_SC + ("only one private part allowed per package"); + Scan; -- past PRIVATE + Append_List (P_Basic_Declarative_Items, + Private_Declarations (Specification_Node)); + end loop; + end if; + + if Pf_Flags = Pf_Spcn then + Package_Node := Specification_Node; + else + Package_Node := + New_Node (N_Package_Declaration, Package_Sloc); + Set_Specification (Package_Node, Specification_Node); + end if; + + if Token = Tok_Begin then + Error_Msg_SC ("begin block not allowed in package spec"); + Scan; -- past BEGIN + Discard_Junk_List (P_Sequence_Of_Statements (SS_None)); + end if; + + if Nkind (Package_Node) = N_Package_Declaration then + End_Statements (Specification_Node, Package_Node); + else + End_Statements (Specification_Node, Decl); + end if; + end if; + + return Package_Node; + end if; + end if; + end P_Package; + + ------------------------------ + -- 7.1 Package Declaration -- + ------------------------------ + + -- Parsed by P_Package (7.1) + + -------------------------------- + -- 7.1 Package Specification -- + -------------------------------- + + -- Parsed by P_Package (7.1) + + ----------------------- + -- 7.1 Package Body -- + ----------------------- + + -- Parsed by P_Package (7.1) + + ----------------------------------- + -- 7.3 Private Type Declaration -- + ----------------------------------- + + -- Parsed by P_Type_Declaration (3.2.1) + + ---------------------------------------- + -- 7.3 Private Extension Declaration -- + ---------------------------------------- + + -- Parsed by P_Type_Declaration (3.2.1) + +end Ch7; diff --git a/gcc/ada/par-ch8.adb b/gcc/ada/par-ch8.adb new file mode 100644 index 000000000..2e58c0058 --- /dev/null +++ b/gcc/ada/par-ch8.adb @@ -0,0 +1,188 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 8 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +separate (Par) +package body Ch8 is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function P_Use_Package_Clause return Node_Id; + function P_Use_Type_Clause return Node_Id; + + --------------------- + -- 8.4 Use Clause -- + --------------------- + + -- USE_CLAUSE ::= USE_PACKAGE_CLAUSE | USE_TYPE_CLAUSE + + -- The caller has checked that the initial token is USE + + -- Error recovery: cannot raise Error_Resync + + function P_Use_Clause return Node_Id is + begin + Scan; -- past USE + + if Token = Tok_Type or else Token = Tok_All then + return P_Use_Type_Clause; + else + return P_Use_Package_Clause; + end if; + end P_Use_Clause; + + ----------------------------- + -- 8.4 Use Package Clause -- + ----------------------------- + + -- USE_PACKAGE_CLAUSE ::= use package_NAME {, package_NAME}; + + -- The caller has scanned out the USE keyword + + -- Error recovery: cannot raise Error_Resync + + function P_Use_Package_Clause return Node_Id is + Use_Node : Node_Id; + + begin + Use_Node := New_Node (N_Use_Package_Clause, Prev_Token_Ptr); + Set_Names (Use_Node, New_List); + + if Token = Tok_Package then + Error_Msg_SC ("PACKAGE should not appear here"); + Scan; -- past PACKAGE + end if; + + loop + Append (P_Qualified_Simple_Name, Names (Use_Node)); + exit when Token /= Tok_Comma; + Scan; -- past comma + end loop; + + TF_Semicolon; + return Use_Node; + end P_Use_Package_Clause; + + -------------------------- + -- 8.4 Use Type Clause -- + -------------------------- + + -- USE_TYPE_CLAUSE ::= use [ALL] type SUBTYPE_MARK {, SUBTYPE_MARK}; + + -- The caller has checked that the initial token is USE, scanned it out + -- and that the current token is either ALL or TYPE. + + -- Note: Use of ALL is an Ada 2012 feature + + -- Error recovery: cannot raise Error_Resync + + function P_Use_Type_Clause return Node_Id is + Use_Node : Node_Id; + All_Present : Boolean; + + begin + if Token = Tok_All then + if Ada_Version < Ada_2012 then + Error_Msg_SC ("|`USE ALL TYPE` is an Ada 2012 feature"); + Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch"); + end if; + + All_Present := True; + Scan; -- past ALL + + else + All_Present := False; + end if; + + Use_Node := New_Node (N_Use_Type_Clause, Prev_Token_Ptr); + Set_All_Present (Use_Node, All_Present); + Set_Subtype_Marks (Use_Node, New_List); + + if Ada_Version = Ada_83 then + Error_Msg_SC ("(Ada 83) use type not allowed!"); + end if; + + Scan; -- past TYPE + + loop + Append (P_Subtype_Mark, Subtype_Marks (Use_Node)); + No_Constraint; + exit when Token /= Tok_Comma; + Scan; -- past comma + end loop; + + TF_Semicolon; + return Use_Node; + end P_Use_Type_Clause; + + ------------------------------- + -- 8.5 Renaming Declaration -- + ------------------------------- + + -- Object renaming declarations and exception renaming declarations + -- are parsed by P_Identifier_Declaration (3.3.1) + + -- Subprogram renaming declarations are parsed by P_Subprogram (6.1) + + -- Package renaming declarations are parsed by P_Package (7.1) + + -- Generic renaming declarations are parsed by P_Generic (12.1) + + ---------------------------------------- + -- 8.5.1 Object Renaming Declaration -- + ---------------------------------------- + + -- Parsed by P_Identifier_Declarations (3.3.1) + + ---------------------------------------- + -- 8.5.2 Exception Renaming Declaration -- + ---------------------------------------- + + -- Parsed by P_Identifier_Declarations (3.3.1) + + ----------------------------------------- + -- 8.5.3 Package Renaming Declaration -- + ----------------------------------------- + + -- Parsed by P_Package (7.1) + + -------------------------------------------- + -- 8.5.4 Subprogram Renaming Declaration -- + -------------------------------------------- + + -- Parsed by P_Subprogram (6.1) + + ----------------------------------------- + -- 8.5.2 Generic Renaming Declaration -- + ----------------------------------------- + + -- Parsed by P_Generic (12.1) + +end Ch8; diff --git a/gcc/ada/par-ch9.adb b/gcc/ada/par-ch9.adb new file mode 100644 index 000000000..5c18adf21 --- /dev/null +++ b/gcc/ada/par-ch9.adb @@ -0,0 +1,1861 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 9 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 subprogram body ordering check. Subprograms are in order by RM +-- section rather than alphabetical. + +separate (Par) +package body Ch9 is + + -- Local subprograms, used only in this chapter + + function P_Accept_Alternative return Node_Id; + function P_Delay_Alternative return Node_Id; + function P_Delay_Relative_Statement return Node_Id; + function P_Delay_Until_Statement return Node_Id; + function P_Entry_Barrier return Node_Id; + function P_Entry_Body_Formal_Part return Node_Id; + function P_Entry_Declaration return Node_Id; + function P_Entry_Index_Specification return Node_Id; + function P_Protected_Operation_Declaration_Opt return Node_Id; + function P_Protected_Operation_Items return List_Id; + function P_Task_Items return List_Id; + + function P_Protected_Definition (Decl : Node_Id) return Node_Id; + -- Parses protected definition and following aspect specifications if + -- present. The argument is the declaration node to which the aspect + -- specifications are to be attached. + + function P_Task_Definition (Decl : Node_Id) return Node_Id; + -- Parses task definition and following aspect specifications if present. + -- The argument is the declaration node to which the aspect specifications + -- are to be attached. + + ----------------------------- + -- 9.1 Task (also 10.1.3) -- + ----------------------------- + + -- TASK_TYPE_DECLARATION ::= + -- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] + -- [is [new INTERFACE_LIST with] TASK_DEFINITION] + -- [ASPECT_SPECIFICATIONS]; + + -- SINGLE_TASK_DECLARATION ::= + -- task DEFINING_IDENTIFIER + -- [is [new INTERFACE_LIST with] TASK_DEFINITION] + -- [ASPECT_SPECIFICATIONS]; + + -- TASK_BODY ::= + -- task body DEFINING_IDENTIFIER is + -- DECLARATIVE_PART + -- begin + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end [task_IDENTIFIER] + + -- TASK_BODY_STUB ::= + -- task body DEFINING_IDENTIFIER is separate; + + -- This routine scans out a task declaration, task body, or task stub + + -- The caller has checked that the initial token is TASK and scanned + -- past it, so that Token is set to the token after TASK + + -- Error recovery: cannot raise Error_Resync + + function P_Task return Node_Id is + Name_Node : Node_Id; + Task_Node : Node_Id; + Task_Sloc : Source_Ptr; + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Lreq := False; + Task_Sloc := Prev_Token_Ptr; + + if Token = Tok_Body then + Scan; -- past BODY + Name_Node := P_Defining_Identifier (C_Is); + Scope.Table (Scope.Last).Labl := Name_Node; + + if Token = Tok_Left_Paren then + Error_Msg_SC ("discriminant part not allowed in task body"); + Discard_Junk_List (P_Known_Discriminant_Part_Opt); + end if; + + TF_Is; + + -- Task stub + + if Token = Tok_Separate then + Scan; -- past SEPARATE + Task_Node := New_Node (N_Task_Body_Stub, Task_Sloc); + Set_Defining_Identifier (Task_Node, Name_Node); + TF_Semicolon; + Pop_Scope_Stack; -- remove unused entry + + -- Task body + + else + Task_Node := New_Node (N_Task_Body, Task_Sloc); + Set_Defining_Identifier (Task_Node, Name_Node); + Parse_Decls_Begin_End (Task_Node); + end if; + + return Task_Node; + + -- Otherwise we must have a task declaration + + else + if Token = Tok_Type then + Scan; -- past TYPE + Task_Node := New_Node (N_Task_Type_Declaration, Task_Sloc); + Name_Node := P_Defining_Identifier; + Set_Defining_Identifier (Task_Node, Name_Node); + Scope.Table (Scope.Last).Labl := Name_Node; + Set_Discriminant_Specifications + (Task_Node, P_Known_Discriminant_Part_Opt); + + else + Task_Node := New_Node (N_Single_Task_Declaration, Task_Sloc); + Name_Node := P_Defining_Identifier (C_Is); + Set_Defining_Identifier (Task_Node, Name_Node); + Scope.Table (Scope.Last).Labl := Name_Node; + + if Token = Tok_Left_Paren then + Error_Msg_SC ("discriminant part not allowed for single task"); + Discard_Junk_List (P_Known_Discriminant_Part_Opt); + end if; + end if; + + -- If we have aspect definitions present here, then we do not have + -- a task definition present. + + if Aspect_Specifications_Present then + P_Aspect_Specifications (Task_Node); + + -- Parse optional task definition. Note that P_Task_Definition scans + -- out the semicolon and possible aspect specifications as well as + -- the task definition itself. + + elsif Token = Tok_Semicolon then + + -- A little check, if the next token after semicolon is + -- Entry, then surely the semicolon should really be IS + + Scan; -- past semicolon + + if Token = Tok_Entry then + Error_Msg_SP -- CODEFIX + ("|"";"" should be IS"); + Set_Task_Definition (Task_Node, P_Task_Definition (Task_Node)); + else + Pop_Scope_Stack; -- Remove unused entry + end if; + + -- Here we have a task definition + + else + TF_Is; -- must have IS if no semicolon + + -- Ada 2005 (AI-345) + + if Token = Tok_New then + Scan; -- past NEW + + if Ada_Version < Ada_2005 then + Error_Msg_SP ("task interface is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + end if; + + Set_Interface_List (Task_Node, New_List); + + loop + Append (P_Qualified_Simple_Name, Interface_List (Task_Node)); + exit when Token /= Tok_And; + Scan; -- past AND + end loop; + + if Token /= Tok_With then + Error_Msg_SC -- CODEFIX + ("WITH expected"); + end if; + + Scan; -- past WITH + + if Token = Tok_Private then + Error_Msg_SP -- CODEFIX + ("PRIVATE not allowed in task type declaration"); + end if; + end if; + + Set_Task_Definition (Task_Node, P_Task_Definition (Task_Node)); + end if; + + return Task_Node; + end if; + end P_Task; + + -------------------------------- + -- 9.1 Task Type Declaration -- + -------------------------------- + + -- Parsed by P_Task (9.1) + + ---------------------------------- + -- 9.1 Single Task Declaration -- + ---------------------------------- + + -- Parsed by P_Task (9.1) + + -------------------------- + -- 9.1 Task Definition -- + -------------------------- + + -- TASK_DEFINITION ::= + -- {TASK_ITEM} + -- [private + -- {TASK_ITEM}] + -- end [task_IDENTIFIER]; + + -- The caller has already made the scope stack entry + + -- Note: there is a small deviation from official syntax here in that we + -- regard the semicolon after end as part of the Task_Definition, and in + -- the official syntax, it's part of the enclosing declaration. The reason + -- for this deviation is that otherwise the end processing would have to + -- be special cased, which would be a nuisance! + + -- Error recovery: cannot raise Error_Resync + + function P_Task_Definition (Decl : Node_Id) return Node_Id is + Def_Node : Node_Id; + + begin + Def_Node := New_Node (N_Task_Definition, Token_Ptr); + Set_Visible_Declarations (Def_Node, P_Task_Items); + + if Token = Tok_Private then + Scan; -- past PRIVATE + Set_Private_Declarations (Def_Node, P_Task_Items); + + -- Deal gracefully with multiple PRIVATE parts + + while Token = Tok_Private loop + Error_Msg_SC ("only one private part allowed per task"); + Scan; -- past PRIVATE + Append_List (P_Task_Items, Private_Declarations (Def_Node)); + end loop; + end if; + + End_Statements (Def_Node, Decl); + return Def_Node; + end P_Task_Definition; + + -------------------- + -- 9.1 Task Item -- + -------------------- + + -- TASK_ITEM ::= ENTRY_DECLARATION | REPRESENTATION_CLAUSE + + -- This subprogram scans a (possibly empty) list of task items and pragmas + + -- Error recovery: cannot raise Error_Resync + + -- Note: a pragma can also be returned in this position + + function P_Task_Items return List_Id is + Items : List_Id; + Item_Node : Node_Id; + Decl_Sloc : Source_Ptr; + + begin + -- Get rid of active SIS entry from outer scope. This means we will + -- miss some nested cases, but it doesn't seem worth the effort. See + -- discussion in Par for further details + + SIS_Entry_Active := False; + + -- Loop to scan out task items + + Items := New_List; + + Decl_Loop : loop + Decl_Sloc := Token_Ptr; + + if Token = Tok_Pragma then + Append (P_Pragma, Items); + + -- Ada 2005 (AI-397): Reserved words NOT and OVERRIDING + -- may begin an entry declaration. + + elsif Token = Tok_Entry + or else Token = Tok_Not + or else Token = Tok_Overriding + then + Append (P_Entry_Declaration, Items); + + elsif Token = Tok_For then + -- Representation clause in task declaration. The only rep + -- clause which is legal in a protected is an address clause, + -- so that is what we try to scan out. + + Item_Node := P_Representation_Clause; + + if Nkind (Item_Node) = N_At_Clause then + Append (Item_Node, Items); + + elsif Nkind (Item_Node) = N_Attribute_Definition_Clause + and then Chars (Item_Node) = Name_Address + then + Append (Item_Node, Items); + + else + Error_Msg + ("the only representation clause " & + "allowed here is an address clause!", Decl_Sloc); + end if; + + elsif Token = Tok_Identifier + or else Token in Token_Class_Declk + then + Error_Msg_SC ("illegal declaration in task definition"); + Resync_Past_Semicolon; + + else + exit Decl_Loop; + end if; + end loop Decl_Loop; + + return Items; + end P_Task_Items; + + -------------------- + -- 9.1 Task Body -- + -------------------- + + -- Parsed by P_Task (9.1) + + ---------------------------------- + -- 9.4 Protected (also 10.1.3) -- + ---------------------------------- + + -- PROTECTED_TYPE_DECLARATION ::= + -- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] + -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION + -- [ASPECT_SPECIFICATIONS]; + + -- SINGLE_PROTECTED_DECLARATION ::= + -- protected DEFINING_IDENTIFIER + -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION; + -- [ASPECT_SPECIFICATIONS]; + + -- PROTECTED_BODY ::= + -- protected body DEFINING_IDENTIFIER is + -- {PROTECTED_OPERATION_ITEM} + -- end [protected_IDENTIFIER]; + + -- PROTECTED_BODY_STUB ::= + -- protected body DEFINING_IDENTIFIER is separate; + + -- This routine scans out a protected declaration, protected body + -- or a protected stub. + + -- The caller has checked that the initial token is PROTECTED and + -- scanned past it, so Token is set to the following token. + + -- Error recovery: cannot raise Error_Resync + + function P_Protected return Node_Id is + Name_Node : Node_Id; + Protected_Node : Node_Id; + Protected_Sloc : Source_Ptr; + Scan_State : Saved_Scan_State; + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Lreq := False; + Protected_Sloc := Prev_Token_Ptr; + + if Token = Tok_Body then + Scan; -- past BODY + Name_Node := P_Defining_Identifier (C_Is); + Scope.Table (Scope.Last).Labl := Name_Node; + + if Token = Tok_Left_Paren then + Error_Msg_SC ("discriminant part not allowed in protected body"); + Discard_Junk_List (P_Known_Discriminant_Part_Opt); + end if; + + TF_Is; + + -- Protected stub + + if Token = Tok_Separate then + Scan; -- past SEPARATE + Protected_Node := New_Node (N_Protected_Body_Stub, Protected_Sloc); + Set_Defining_Identifier (Protected_Node, Name_Node); + TF_Semicolon; + Pop_Scope_Stack; -- remove unused entry + + -- Protected body + + else + Protected_Node := New_Node (N_Protected_Body, Protected_Sloc); + Set_Defining_Identifier (Protected_Node, Name_Node); + Set_Declarations (Protected_Node, P_Protected_Operation_Items); + End_Statements (Protected_Node); + end if; + + return Protected_Node; + + -- Otherwise we must have a protected declaration + + else + if Token = Tok_Type then + Scan; -- past TYPE + Protected_Node := + New_Node (N_Protected_Type_Declaration, Protected_Sloc); + Name_Node := P_Defining_Identifier (C_Is); + Set_Defining_Identifier (Protected_Node, Name_Node); + Scope.Table (Scope.Last).Labl := Name_Node; + Set_Discriminant_Specifications + (Protected_Node, P_Known_Discriminant_Part_Opt); + + else + Protected_Node := + New_Node (N_Single_Protected_Declaration, Protected_Sloc); + Name_Node := P_Defining_Identifier (C_Is); + Set_Defining_Identifier (Protected_Node, Name_Node); + + if Token = Tok_Left_Paren then + Error_Msg_SC + ("discriminant part not allowed for single protected"); + Discard_Junk_List (P_Known_Discriminant_Part_Opt); + end if; + + Scope.Table (Scope.Last).Labl := Name_Node; + end if; + + -- Check for semicolon not followed by IS, this is something like + + -- protected type r; + + -- where we want + + -- protected type r IS END; + + if Token = Tok_Semicolon then + Save_Scan_State (Scan_State); -- at semicolon + Scan; -- past semicolon + + if Token /= Tok_Is then + Restore_Scan_State (Scan_State); + Error_Msg_SC -- CODEFIX + ("missing IS"); + Set_Protected_Definition (Protected_Node, + Make_Protected_Definition (Token_Ptr, + Visible_Declarations => Empty_List, + End_Label => Empty)); + + SIS_Entry_Active := False; + End_Statements + (Protected_Definition (Protected_Node), Protected_Node); + return Protected_Node; + end if; + + Error_Msg_SP -- CODEFIX + ("|extra ""("" ignored"); + end if; + + T_Is; + + -- Ada 2005 (AI-345) + + if Token = Tok_New then + Scan; -- past NEW + + if Ada_Version < Ada_2005 then + Error_Msg_SP ("protected interface is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + end if; + + Set_Interface_List (Protected_Node, New_List); + + loop + Append (P_Qualified_Simple_Name, + Interface_List (Protected_Node)); + + exit when Token /= Tok_And; + Scan; -- past AND + end loop; + + if Token /= Tok_With then + Error_Msg_SC -- CODEFIX + ("WITH expected"); + end if; + + Scan; -- past WITH + end if; + + Set_Protected_Definition + (Protected_Node, P_Protected_Definition (Protected_Node)); + return Protected_Node; + end if; + end P_Protected; + + ------------------------------------- + -- 9.4 Protected Type Declaration -- + ------------------------------------- + + -- Parsed by P_Protected (9.4) + + --------------------------------------- + -- 9.4 Single Protected Declaration -- + --------------------------------------- + + -- Parsed by P_Protected (9.4) + + ------------------------------- + -- 9.4 Protected Definition -- + ------------------------------- + + -- PROTECTED_DEFINITION ::= + -- {PROTECTED_OPERATION_DECLARATION} + -- [private + -- {PROTECTED_ELEMENT_DECLARATION}] + -- end [protected_IDENTIFIER] + + -- PROTECTED_ELEMENT_DECLARATION ::= + -- PROTECTED_OPERATION_DECLARATION + -- | COMPONENT_DECLARATION + + -- The caller has already established the scope stack entry + + -- Error recovery: cannot raise Error_Resync + + function P_Protected_Definition (Decl : Node_Id) return Node_Id is + Def_Node : Node_Id; + Item_Node : Node_Id; + + begin + Def_Node := New_Node (N_Protected_Definition, Token_Ptr); + + -- Get rid of active SIS entry from outer scope. This means we will + -- miss some nested cases, but it doesn't seem worth the effort. See + -- discussion in Par for further details + + SIS_Entry_Active := False; + + -- Loop to scan visible declarations (protected operation declarations) + + Set_Visible_Declarations (Def_Node, New_List); + + loop + Item_Node := P_Protected_Operation_Declaration_Opt; + exit when No (Item_Node); + Append (Item_Node, Visible_Declarations (Def_Node)); + end loop; + + -- Deal with PRIVATE part (including graceful handling of multiple + -- PRIVATE parts). + + Private_Loop : while Token = Tok_Private loop + if No (Private_Declarations (Def_Node)) then + Set_Private_Declarations (Def_Node, New_List); + else + Error_Msg_SC ("duplicate private part"); + end if; + + Scan; -- past PRIVATE + + Declaration_Loop : loop + if Token = Tok_Identifier then + P_Component_Items (Private_Declarations (Def_Node)); + else + Item_Node := P_Protected_Operation_Declaration_Opt; + exit Declaration_Loop when No (Item_Node); + Append (Item_Node, Private_Declarations (Def_Node)); + end if; + end loop Declaration_Loop; + end loop Private_Loop; + + End_Statements (Def_Node, Decl); + return Def_Node; + end P_Protected_Definition; + + ------------------------------------------ + -- 9.4 Protected Operation Declaration -- + ------------------------------------------ + + -- PROTECTED_OPERATION_DECLARATION ::= + -- SUBPROGRAM_DECLARATION + -- | ENTRY_DECLARATION + -- | REPRESENTATION_CLAUSE + + -- Error recovery: cannot raise Error_Resync + + -- Note: a pragma can also be returned in this position + + -- We are not currently permitting representation clauses to appear as + -- protected operation declarations, do we have to rethink this??? + + function P_Protected_Operation_Declaration_Opt return Node_Id is + L : List_Id; + P : Source_Ptr; + + function P_Entry_Or_Subprogram_With_Indicator return Node_Id; + -- Ada 2005 (AI-397): Parse an entry or a subprogram with an overriding + -- indicator. The caller has checked that the initial token is NOT or + -- OVERRIDING. + + ------------------------------------------ + -- P_Entry_Or_Subprogram_With_Indicator -- + ------------------------------------------ + + function P_Entry_Or_Subprogram_With_Indicator return Node_Id is + Decl : Node_Id := Error; + Is_Overriding : Boolean := False; + Not_Overriding : Boolean := False; + + begin + if Token = Tok_Not then + Scan; -- past NOT + + if Token = Tok_Overriding then + Scan; -- past OVERRIDING + Not_Overriding := True; + else + Error_Msg_SC -- CODEFIX + ("OVERRIDING expected!"); + end if; + + else + Scan; -- past OVERRIDING + Is_Overriding := True; + end if; + + if Is_Overriding or else Not_Overriding then + if Ada_Version < Ada_2005 then + Error_Msg_SP ("overriding indicator is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + + elsif Token = Tok_Entry then + Decl := P_Entry_Declaration; + + Set_Must_Override (Decl, Is_Overriding); + Set_Must_Not_Override (Decl, Not_Overriding); + + elsif Token = Tok_Function or else Token = Tok_Procedure then + Decl := P_Subprogram (Pf_Decl_Pexp); + + Set_Must_Override (Specification (Decl), Is_Overriding); + Set_Must_Not_Override (Specification (Decl), Not_Overriding); + + else + Error_Msg_SC -- CODEFIX + ("ENTRY, FUNCTION or PROCEDURE expected!"); + end if; + end if; + + return Decl; + end P_Entry_Or_Subprogram_With_Indicator; + + -- Start of processing for P_Protected_Operation_Declaration_Opt + + begin + -- This loop runs more than once only when a junk declaration + -- is skipped. + + loop + if Token = Tok_Pragma then + return P_Pragma; + + elsif Token = Tok_Not or else Token = Tok_Overriding then + return P_Entry_Or_Subprogram_With_Indicator; + + elsif Token = Tok_Entry then + return P_Entry_Declaration; + + elsif Token = Tok_Function or else Token = Tok_Procedure then + return P_Subprogram (Pf_Decl_Pexp); + + elsif Token = Tok_Identifier then + L := New_List; + P := Token_Ptr; + Skip_Declaration (L); + + if Nkind (First (L)) = N_Object_Declaration then + Error_Msg + ("component must be declared in private part of " & + "protected type", P); + else + Error_Msg + ("illegal declaration in protected definition", P); + end if; + + elsif Token in Token_Class_Declk then + Error_Msg_SC ("illegal declaration in protected definition"); + Resync_Past_Semicolon; + + -- Return now to avoid cascaded messages if next declaration + -- is a valid component declaration. + + return Error; + + elsif Token = Tok_For then + Error_Msg_SC + ("representation clause not allowed in protected definition"); + Resync_Past_Semicolon; + + else + return Empty; + end if; + end loop; + end P_Protected_Operation_Declaration_Opt; + + ----------------------------------- + -- 9.4 Protected Operation Item -- + ----------------------------------- + + -- PROTECTED_OPERATION_ITEM ::= + -- SUBPROGRAM_DECLARATION + -- | SUBPROGRAM_BODY + -- | ENTRY_BODY + -- | REPRESENTATION_CLAUSE + + -- This procedure parses and returns a list of protected operation items + + -- We are not currently permitting representation clauses to appear + -- as protected operation items, do we have to rethink this??? + + function P_Protected_Operation_Items return List_Id is + Item_List : List_Id; + + begin + Item_List := New_List; + + loop + if Token = Tok_Entry or else Bad_Spelling_Of (Tok_Entry) then + Append (P_Entry_Body, Item_List); + + -- If the operation starts with procedure, function, or an overriding + -- indicator ("overriding" or "not overriding"), parse a subprogram. + + elsif Token = Tok_Function or else Bad_Spelling_Of (Tok_Function) + or else + Token = Tok_Procedure or else Bad_Spelling_Of (Tok_Procedure) + or else + Token = Tok_Overriding or else Bad_Spelling_Of (Tok_Overriding) + or else + Token = Tok_Not or else Bad_Spelling_Of (Tok_Not) + then + Append (P_Subprogram (Pf_Decl_Pbod_Pexp), Item_List); + + elsif Token = Tok_Pragma or else Bad_Spelling_Of (Tok_Pragma) then + P_Pragmas_Opt (Item_List); + + elsif Token = Tok_Private or else Bad_Spelling_Of (Tok_Private) then + Error_Msg_SC ("PRIVATE not allowed in protected body"); + Scan; -- past PRIVATE + + elsif Token = Tok_Identifier then + Error_Msg_SC ("all components must be declared in spec!"); + Resync_Past_Semicolon; + + elsif Token in Token_Class_Declk then + Error_Msg_SC ("this declaration not allowed in protected body"); + Resync_Past_Semicolon; + + else + exit; + end if; + end loop; + + return Item_List; + end P_Protected_Operation_Items; + + ------------------------------ + -- 9.5.2 Entry Declaration -- + ------------------------------ + + -- ENTRY_DECLARATION ::= + -- [OVERRIDING_INDICATOR] + -- entry DEFINING_IDENTIFIER [(DISCRETE_SUBTYPE_DEFINITION)] + -- PARAMETER_PROFILE; + -- [ASPECT_SPECIFICATIONS]; + + -- The caller has checked that the initial token is ENTRY, NOT or + -- OVERRIDING. + + -- Error recovery: cannot raise Error_Resync + + function P_Entry_Declaration return Node_Id is + Decl_Node : Node_Id; + Scan_State : Saved_Scan_State; + + -- Flags for optional overriding indication. Two flags are needed, + -- to distinguish positive and negative overriding indicators from + -- the absence of any indicator. + + Is_Overriding : Boolean := False; + Not_Overriding : Boolean := False; + + begin + -- Ada 2005 (AI-397): Scan leading overriding indicator + + if Token = Tok_Not then + Scan; -- past NOT + + if Token = Tok_Overriding then + Scan; -- part OVERRIDING + Not_Overriding := True; + else + Error_Msg_SC -- CODEFIX + ("OVERRIDING expected!"); + end if; + + elsif Token = Tok_Overriding then + Scan; -- part OVERRIDING + Is_Overriding := True; + end if; + + if Is_Overriding or else Not_Overriding then + if Ada_Version < Ada_2005 then + Error_Msg_SP ("overriding indicator is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + + elsif Token /= Tok_Entry then + Error_Msg_SC -- CODEFIX + ("ENTRY expected!"); + end if; + end if; + + Decl_Node := New_Node (N_Entry_Declaration, Token_Ptr); + Scan; -- past ENTRY + + Set_Defining_Identifier + (Decl_Node, P_Defining_Identifier (C_Left_Paren_Semicolon)); + + -- If left paren, could be (Discrete_Subtype_Definition) or Formal_Part + + if Token = Tok_Left_Paren then + Scan; -- past ( + + -- If identifier after left paren, could still be either + + if Token = Tok_Identifier then + Save_Scan_State (Scan_State); -- at Id + Scan; -- past Id + + -- If comma or colon after Id, must be Formal_Part + + if Token = Tok_Comma or else Token = Tok_Colon then + Restore_Scan_State (Scan_State); -- to Id + Set_Parameter_Specifications (Decl_Node, P_Formal_Part); + + -- Else if Id without comma or colon, must be discrete subtype + -- defn + + else + Restore_Scan_State (Scan_State); -- to Id + Set_Discrete_Subtype_Definition + (Decl_Node, P_Discrete_Subtype_Definition); + T_Right_Paren; + Set_Parameter_Specifications (Decl_Node, P_Parameter_Profile); + end if; + + -- If no Id, must be discrete subtype definition + + else + Set_Discrete_Subtype_Definition + (Decl_Node, P_Discrete_Subtype_Definition); + T_Right_Paren; + Set_Parameter_Specifications (Decl_Node, P_Parameter_Profile); + end if; + end if; + + if Is_Overriding then + Set_Must_Override (Decl_Node); + elsif Not_Overriding then + Set_Must_Not_Override (Decl_Node); + end if; + + -- Error recovery check for illegal return + + if Token = Tok_Return then + Error_Msg_SC ("entry cannot have return value!"); + Scan; + Discard_Junk_Node (P_Subtype_Indication); + end if; + + -- Error recovery check for improper use of entry barrier in spec + + if Token = Tok_When then + Error_Msg_SC ("barrier not allowed here (belongs in body)"); + Scan; -- past WHEN; + Discard_Junk_Node (P_Expression_No_Right_Paren); + end if; + + P_Aspect_Specifications (Decl_Node); + return Decl_Node; + + exception + when Error_Resync => + Resync_Past_Semicolon; + return Error; + end P_Entry_Declaration; + + ----------------------------- + -- 9.5.2 Accept Statement -- + ----------------------------- + + -- ACCEPT_STATEMENT ::= + -- accept entry_DIRECT_NAME + -- [(ENTRY_INDEX)] PARAMETER_PROFILE [do + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end [entry_IDENTIFIER]]; + + -- The caller has checked that the initial token is ACCEPT + + -- Error recovery: cannot raise Error_Resync. If an error occurs, the + -- scan is resynchronized past the next semicolon and control returns. + + function P_Accept_Statement return Node_Id is + Scan_State : Saved_Scan_State; + Accept_Node : Node_Id; + Hand_Seq : Node_Id; + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Ecol := Start_Column; + + Accept_Node := New_Node (N_Accept_Statement, Token_Ptr); + Scan; -- past ACCEPT + Scope.Table (Scope.Last).Labl := Token_Node; + + Set_Entry_Direct_Name (Accept_Node, P_Identifier (C_Do)); + + -- Left paren could be (Entry_Index) or Formal_Part, determine which + + if Token = Tok_Left_Paren then + Save_Scan_State (Scan_State); -- at left paren + Scan; -- past left paren + + -- If first token after left paren not identifier, then Entry_Index + + if Token /= Tok_Identifier then + Set_Entry_Index (Accept_Node, P_Expression); + T_Right_Paren; + Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile); + + -- First token after left paren is identifier, could be either case + + else -- Token = Tok_Identifier + Scan; -- past identifier + + -- If identifier followed by comma or colon, must be Formal_Part + + if Token = Tok_Comma or else Token = Tok_Colon then + Restore_Scan_State (Scan_State); -- to left paren + Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile); + + -- If identifier not followed by comma/colon, must be entry index + + else + Restore_Scan_State (Scan_State); -- to left paren + Scan; -- past left paren (again!) + Set_Entry_Index (Accept_Node, P_Expression); + T_Right_Paren; + Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile); + end if; + end if; + end if; + + -- Scan out DO if present + + if Token = Tok_Do then + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Lreq := False; + Scan; -- past DO + Hand_Seq := P_Handled_Sequence_Of_Statements; + Set_Handled_Statement_Sequence (Accept_Node, Hand_Seq); + End_Statements (Handled_Statement_Sequence (Accept_Node)); + + -- Exception handlers not allowed in Ada 95 node + + if Present (Exception_Handlers (Hand_Seq)) then + if Ada_Version = Ada_83 then + Error_Msg_N + ("(Ada 83) exception handlers in accept not allowed", + First_Non_Pragma (Exception_Handlers (Hand_Seq))); + end if; + end if; + + else + Pop_Scope_Stack; -- discard unused entry + TF_Semicolon; + end if; + + return Accept_Node; + + -- If error, resynchronize past semicolon + + exception + when Error_Resync => + Resync_Past_Semicolon; + Pop_Scope_Stack; -- discard unused entry + return Error; + + end P_Accept_Statement; + + ------------------------ + -- 9.5.2 Entry Index -- + ------------------------ + + -- Parsed by P_Expression (4.4) + + ----------------------- + -- 9.5.2 Entry Body -- + ----------------------- + + -- ENTRY_BODY ::= + -- entry DEFINING_IDENTIFIER ENTRY_BODY_FORMAL_PART ENTRY_BARRIER is + -- DECLARATIVE_PART + -- begin + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end [entry_IDENTIFIER]; + + -- The caller has checked that the initial token is ENTRY + + -- Error_Recovery: cannot raise Error_Resync + + function P_Entry_Body return Node_Id is + Entry_Node : Node_Id; + Formal_Part_Node : Node_Id; + Name_Node : Node_Id; + + begin + Push_Scope_Stack; + Entry_Node := New_Node (N_Entry_Body, Token_Ptr); + Scan; -- past ENTRY + + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Lreq := False; + Scope.Table (Scope.Last).Etyp := E_Name; + + Name_Node := P_Defining_Identifier; + Set_Defining_Identifier (Entry_Node, Name_Node); + Scope.Table (Scope.Last).Labl := Name_Node; + + Formal_Part_Node := P_Entry_Body_Formal_Part; + Set_Entry_Body_Formal_Part (Entry_Node, Formal_Part_Node); + + Set_Condition (Formal_Part_Node, P_Entry_Barrier); + Parse_Decls_Begin_End (Entry_Node); + return Entry_Node; + end P_Entry_Body; + + ----------------------------------- + -- 9.5.2 Entry Body Formal Part -- + ----------------------------------- + + -- ENTRY_BODY_FORMAL_PART ::= + -- [(ENTRY_INDEX_SPECIFICATION)] [PARAMETER_PART] + + -- Error_Recovery: cannot raise Error_Resync + + function P_Entry_Body_Formal_Part return Node_Id is + Fpart_Node : Node_Id; + Scan_State : Saved_Scan_State; + + begin + Fpart_Node := New_Node (N_Entry_Body_Formal_Part, Token_Ptr); + + -- See if entry index specification present, and if so parse it + + if Token = Tok_Left_Paren then + Save_Scan_State (Scan_State); -- at left paren + Scan; -- past left paren + + if Token = Tok_For then + Set_Entry_Index_Specification + (Fpart_Node, P_Entry_Index_Specification); + T_Right_Paren; + else + Restore_Scan_State (Scan_State); -- to left paren + end if; + + -- Check for (common?) case of left paren omitted before FOR. This + -- is a tricky case, because the corresponding missing left paren + -- can cause real havoc if a formal part is present which gets + -- treated as part of the discrete subtype definition of the + -- entry index specification, so just give error and resynchronize + + elsif Token = Tok_For then + T_Left_Paren; -- to give error message + Resync_To_When; + end if; + + Set_Parameter_Specifications (Fpart_Node, P_Parameter_Profile); + return Fpart_Node; + end P_Entry_Body_Formal_Part; + + -------------------------- + -- 9.5.2 Entry Barrier -- + -------------------------- + + -- ENTRY_BARRIER ::= when CONDITION + + -- Error_Recovery: cannot raise Error_Resync + + function P_Entry_Barrier return Node_Id is + Bnode : Node_Id; + + begin + if Token = Tok_When then + Scan; -- past WHEN; + Bnode := P_Expression_No_Right_Paren; + + if Token = Tok_Colon_Equal then + Error_Msg_SC -- CODEFIX + ("|"":="" should be ""="""); + Scan; + Bnode := P_Expression_No_Right_Paren; + end if; + + else + T_When; -- to give error message + Bnode := Error; + end if; + + TF_Is; + return Bnode; + end P_Entry_Barrier; + + -------------------------------------- + -- 9.5.2 Entry Index Specification -- + -------------------------------------- + + -- ENTRY_INDEX_SPECIFICATION ::= + -- for DEFINING_IDENTIFIER in DISCRETE_SUBTYPE_DEFINITION + + -- Error recovery: can raise Error_Resync + + function P_Entry_Index_Specification return Node_Id is + Iterator_Node : Node_Id; + + begin + Iterator_Node := New_Node (N_Entry_Index_Specification, Token_Ptr); + T_For; -- past FOR + Set_Defining_Identifier (Iterator_Node, P_Defining_Identifier (C_In)); + T_In; + Set_Discrete_Subtype_Definition + (Iterator_Node, P_Discrete_Subtype_Definition); + return Iterator_Node; + end P_Entry_Index_Specification; + + --------------------------------- + -- 9.5.3 Entry Call Statement -- + --------------------------------- + + -- Parsed by P_Name (4.1). Within a select, an entry call is parsed + -- by P_Select_Statement (9.7) + + ------------------------------ + -- 9.5.4 Requeue Statement -- + ------------------------------ + + -- REQUEUE_STATEMENT ::= requeue entry_NAME [with abort]; + + -- The caller has checked that the initial token is requeue + + -- Error recovery: can raise Error_Resync + + function P_Requeue_Statement return Node_Id is + Requeue_Node : Node_Id; + + begin + Requeue_Node := New_Node (N_Requeue_Statement, Token_Ptr); + Scan; -- past REQUEUE + Set_Name (Requeue_Node, P_Name); + + if Token = Tok_With then + Scan; -- past WITH + T_Abort; + Set_Abort_Present (Requeue_Node, True); + end if; + + TF_Semicolon; + return Requeue_Node; + end P_Requeue_Statement; + + -------------------------- + -- 9.6 Delay Statement -- + -------------------------- + + -- DELAY_STATEMENT ::= + -- DELAY_UNTIL_STATEMENT + -- | DELAY_RELATIVE_STATEMENT + + -- The caller has checked that the initial token is DELAY + + -- Error recovery: cannot raise Error_Resync + + function P_Delay_Statement return Node_Id is + begin + Scan; -- past DELAY + + -- The following check for delay until misused in Ada 83 doesn't catch + -- all cases, but it's good enough to catch most of them! + + if Token_Name = Name_Until then + Check_95_Keyword (Tok_Until, Tok_Left_Paren); + Check_95_Keyword (Tok_Until, Tok_Identifier); + end if; + + if Token = Tok_Until then + return P_Delay_Until_Statement; + else + return P_Delay_Relative_Statement; + end if; + end P_Delay_Statement; + + -------------------------------- + -- 9.6 Delay Until Statement -- + -------------------------------- + + -- DELAY_UNTIL_STATEMENT ::= delay until delay_EXPRESSION; + + -- The caller has checked that the initial token is DELAY, scanned it + -- out and checked that the current token is UNTIL + + -- Error recovery: cannot raise Error_Resync + + function P_Delay_Until_Statement return Node_Id is + Delay_Node : Node_Id; + + begin + Delay_Node := New_Node (N_Delay_Until_Statement, Prev_Token_Ptr); + Scan; -- past UNTIL + Set_Expression (Delay_Node, P_Expression_No_Right_Paren); + TF_Semicolon; + return Delay_Node; + end P_Delay_Until_Statement; + + ----------------------------------- + -- 9.6 Delay Relative Statement -- + ----------------------------------- + + -- DELAY_RELATIVE_STATEMENT ::= delay delay_EXPRESSION; + + -- The caller has checked that the initial token is DELAY, scanned it + -- out and determined that the current token is not UNTIL + + -- Error recovery: cannot raise Error_Resync + + function P_Delay_Relative_Statement return Node_Id is + Delay_Node : Node_Id; + + begin + Delay_Node := New_Node (N_Delay_Relative_Statement, Prev_Token_Ptr); + Set_Expression (Delay_Node, P_Expression_No_Right_Paren); + Check_Simple_Expression_In_Ada_83 (Expression (Delay_Node)); + TF_Semicolon; + return Delay_Node; + end P_Delay_Relative_Statement; + + --------------------------- + -- 9.7 Select Statement -- + --------------------------- + + -- SELECT_STATEMENT ::= + -- SELECTIVE_ACCEPT + -- | TIMED_ENTRY_CALL + -- | CONDITIONAL_ENTRY_CALL + -- | ASYNCHRONOUS_SELECT + + -- SELECTIVE_ACCEPT ::= + -- select + -- [GUARD] + -- SELECT_ALTERNATIVE + -- {or + -- [GUARD] + -- SELECT_ALTERNATIVE + -- [else + -- SEQUENCE_OF_STATEMENTS] + -- end select; + + -- GUARD ::= when CONDITION => + + -- Note: the guard preceding a select alternative is included as part + -- of the node generated for a selective accept alternative. + + -- SELECT_ALTERNATIVE ::= + -- ACCEPT_ALTERNATIVE + -- | DELAY_ALTERNATIVE + -- | TERMINATE_ALTERNATIVE + + -- TIMED_ENTRY_CALL ::= + -- select + -- ENTRY_CALL_ALTERNATIVE + -- or + -- DELAY_ALTERNATIVE + -- end select; + + -- CONDITIONAL_ENTRY_CALL ::= + -- select + -- ENTRY_CALL_ALTERNATIVE + -- else + -- SEQUENCE_OF_STATEMENTS + -- end select; + + -- ENTRY_CALL_ALTERNATIVE ::= + -- ENTRY_CALL_STATEMENT [SEQUENCE_OF_STATEMENTS] + + -- ASYNCHRONOUS_SELECT ::= + -- select + -- TRIGGERING_ALTERNATIVE + -- then abort + -- ABORTABLE_PART + -- end select; + + -- TRIGGERING_ALTERNATIVE ::= + -- TRIGGERING_STATEMENT [SEQUENCE_OF_STATEMENTS] + + -- TRIGGERING_STATEMENT ::= ENTRY_CALL_STATEMENT | DELAY_STATEMENT + + -- The caller has checked that the initial token is SELECT + + -- Error recovery: can raise Error_Resync + + function P_Select_Statement return Node_Id is + Select_Node : Node_Id; + Select_Sloc : Source_Ptr; + Stmnt_Sloc : Source_Ptr; + Ecall_Node : Node_Id; + Alternative : Node_Id; + Select_Pragmas : List_Id; + Alt_Pragmas : List_Id; + Statement_List : List_Id; + Alt_List : List_Id; + Cond_Expr : Node_Id; + Delay_Stmnt : Node_Id; + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Select; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Labl := Error; + + Select_Sloc := Token_Ptr; + Scan; -- past SELECT + Stmnt_Sloc := Token_Ptr; + Select_Pragmas := P_Pragmas_Opt; + + -- If first token after select is designator, then we have an entry + -- call, which must be the start of a conditional entry call, timed + -- entry call or asynchronous select + + if Token in Token_Class_Desig then + + -- Scan entry call statement + + begin + Ecall_Node := P_Name; + + -- ?? The following two clauses exactly parallel code in ch5 + -- and should be combined sometime + + if Nkind (Ecall_Node) = N_Indexed_Component then + declare + Prefix_Node : constant Node_Id := Prefix (Ecall_Node); + Exprs_Node : constant List_Id := Expressions (Ecall_Node); + + begin + Change_Node (Ecall_Node, N_Procedure_Call_Statement); + Set_Name (Ecall_Node, Prefix_Node); + Set_Parameter_Associations (Ecall_Node, Exprs_Node); + end; + + elsif Nkind (Ecall_Node) = N_Function_Call then + declare + Fname_Node : constant Node_Id := Name (Ecall_Node); + Params_List : constant List_Id := + Parameter_Associations (Ecall_Node); + + begin + Change_Node (Ecall_Node, N_Procedure_Call_Statement); + Set_Name (Ecall_Node, Fname_Node); + Set_Parameter_Associations (Ecall_Node, Params_List); + end; + + elsif Nkind (Ecall_Node) = N_Identifier + or else Nkind (Ecall_Node) = N_Selected_Component + then + -- Case of a call to a parameterless entry + + declare + C_Node : constant Node_Id := + New_Node (N_Procedure_Call_Statement, Stmnt_Sloc); + begin + Set_Name (C_Node, Ecall_Node); + Set_Parameter_Associations (C_Node, No_List); + Ecall_Node := C_Node; + end; + end if; + + TF_Semicolon; + + exception + when Error_Resync => + Resync_Past_Semicolon; + return Error; + end; + + Statement_List := P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm); + + -- OR follows, we have a timed entry call + + if Token = Tok_Or then + Scan; -- past OR + Alt_Pragmas := P_Pragmas_Opt; + + Select_Node := New_Node (N_Timed_Entry_Call, Select_Sloc); + Set_Entry_Call_Alternative (Select_Node, + Make_Entry_Call_Alternative (Stmnt_Sloc, + Entry_Call_Statement => Ecall_Node, + Pragmas_Before => Select_Pragmas, + Statements => Statement_List)); + + -- Only possibility is delay alternative. If we have anything + -- else, give message, and treat as conditional entry call. + + if Token /= Tok_Delay then + Error_Msg_SC + ("only allowed alternative in timed entry call is delay!"); + Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq)); + Set_Delay_Alternative (Select_Node, Error); + + else + Set_Delay_Alternative (Select_Node, P_Delay_Alternative); + Set_Pragmas_Before + (Delay_Alternative (Select_Node), Alt_Pragmas); + end if; + + -- ELSE follows, we have a conditional entry call + + elsif Token = Tok_Else then + Scan; -- past ELSE + Select_Node := New_Node (N_Conditional_Entry_Call, Select_Sloc); + + Set_Entry_Call_Alternative (Select_Node, + Make_Entry_Call_Alternative (Stmnt_Sloc, + Entry_Call_Statement => Ecall_Node, + Pragmas_Before => Select_Pragmas, + Statements => Statement_List)); + + Set_Else_Statements + (Select_Node, P_Sequence_Of_Statements (SS_Sreq)); + + -- Only remaining case is THEN ABORT (asynchronous select) + + elsif Token = Tok_Abort then + Select_Node := + Make_Asynchronous_Select (Select_Sloc, + Triggering_Alternative => + Make_Triggering_Alternative (Stmnt_Sloc, + Triggering_Statement => Ecall_Node, + Pragmas_Before => Select_Pragmas, + Statements => Statement_List), + Abortable_Part => P_Abortable_Part); + + -- Else error + + else + if Ada_Version = Ada_83 then + Error_Msg_BC ("OR or ELSE expected"); + else + Error_Msg_BC ("OR or ELSE or THEN ABORT expected"); + end if; + + Select_Node := Error; + end if; + + End_Statements; + + -- Here we have a selective accept or an asynchronous select (first + -- token after SELECT is other than a designator token). + + else + -- If we have delay with no guard, could be asynchronous select + + if Token = Tok_Delay then + Delay_Stmnt := P_Delay_Statement; + Statement_List := P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm); + + -- Asynchronous select + + if Token = Tok_Abort then + Select_Node := + Make_Asynchronous_Select (Select_Sloc, + Triggering_Alternative => + Make_Triggering_Alternative (Stmnt_Sloc, + Triggering_Statement => Delay_Stmnt, + Pragmas_Before => Select_Pragmas, + Statements => Statement_List), + Abortable_Part => P_Abortable_Part); + + End_Statements; + return Select_Node; + + -- Delay which was not an asynchronous select. Must be a selective + -- accept, and since at least one accept statement is required, + -- we must have at least one OR phrase present. + + else + Alt_List := New_List ( + Make_Delay_Alternative (Stmnt_Sloc, + Delay_Statement => Delay_Stmnt, + Pragmas_Before => Select_Pragmas, + Statements => Statement_List)); + T_Or; + Alt_Pragmas := P_Pragmas_Opt; + end if; + + -- If not a delay statement, then must be another possibility for + -- a selective accept alternative, or perhaps a guard is present + + else + Alt_List := New_List; + Alt_Pragmas := Select_Pragmas; + end if; + + Select_Node := New_Node (N_Selective_Accept, Select_Sloc); + Set_Select_Alternatives (Select_Node, Alt_List); + + -- Scan out selective accept alternatives. On entry to this loop, + -- we are just past a SELECT or OR token, and any pragmas that + -- immediately follow the SELECT or OR are in Alt_Pragmas. + + loop + if Token = Tok_When then + + if Present (Alt_Pragmas) then + Error_Msg_SC ("pragmas may not precede guard"); + end if; + + Scan; -- past WHEN + Cond_Expr := P_Expression_No_Right_Paren; + T_Arrow; + Alt_Pragmas := P_Pragmas_Opt; + + else + Cond_Expr := Empty; + end if; + + if Token = Tok_Accept then + Alternative := P_Accept_Alternative; + + -- Check for junk attempt at asynchronous select using + -- an Accept alternative as the triggering statement + + if Token = Tok_Abort + and then Is_Empty_List (Alt_List) + and then No (Cond_Expr) + then + Error_Msg + ("triggering statement must be entry call or delay", + Sloc (Alternative)); + Scan; -- past junk ABORT + Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq)); + End_Statements; + return Error; + end if; + + elsif Token = Tok_Delay then + Alternative := P_Delay_Alternative; + + elsif Token = Tok_Terminate then + Alternative := P_Terminate_Alternative; + + else + Error_Msg_SC + ("select alternative (ACCEPT, ABORT, DELAY) expected"); + Alternative := Error; + + if Token = Tok_Semicolon then + Scan; -- past junk semicolon + end if; + end if; + + -- THEN ABORT at this stage is just junk + + if Token = Tok_Abort then + Error_Msg_SP ("misplaced `THEN ABORT`"); + Scan; -- past junk ABORT + Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq)); + End_Statements; + return Error; + + else + if Alternative /= Error then + Set_Condition (Alternative, Cond_Expr); + Set_Pragmas_Before (Alternative, Alt_Pragmas); + Append (Alternative, Alt_List); + end if; + + exit when Token /= Tok_Or; + end if; + + T_Or; + Alt_Pragmas := P_Pragmas_Opt; + end loop; + + if Token = Tok_Else then + Scan; -- past ELSE + Set_Else_Statements + (Select_Node, P_Sequence_Of_Statements (SS_Ortm_Sreq)); + + if Token = Tok_Or then + Error_Msg_SC ("select alternative cannot follow else part!"); + end if; + end if; + + End_Statements; + end if; + + return Select_Node; + end P_Select_Statement; + + ----------------------------- + -- 9.7.1 Selective Accept -- + ----------------------------- + + -- Parsed by P_Select_Statement (9.7) + + ------------------ + -- 9.7.1 Guard -- + ------------------ + + -- Parsed by P_Select_Statement (9.7) + + ------------------------------- + -- 9.7.1 Select Alternative -- + ------------------------------- + + -- SELECT_ALTERNATIVE ::= + -- ACCEPT_ALTERNATIVE + -- | DELAY_ALTERNATIVE + -- | TERMINATE_ALTERNATIVE + + -- Note: the guard preceding a select alternative is included as part + -- of the node generated for a selective accept alternative. + + -- Error recovery: cannot raise Error_Resync + + ------------------------------- + -- 9.7.1 Accept Alternative -- + ------------------------------- + + -- ACCEPT_ALTERNATIVE ::= + -- ACCEPT_STATEMENT [SEQUENCE_OF_STATEMENTS] + + -- Error_Recovery: Cannot raise Error_Resync + + -- Note: the caller is responsible for setting the Pragmas_Before + -- field of the returned N_Terminate_Alternative node. + + function P_Accept_Alternative return Node_Id is + Accept_Alt_Node : Node_Id; + + begin + Accept_Alt_Node := New_Node (N_Accept_Alternative, Token_Ptr); + Set_Accept_Statement (Accept_Alt_Node, P_Accept_Statement); + + -- Note: the reason that we accept THEN ABORT as a terminator for + -- the sequence of statements is for error recovery which allows + -- for misuse of an accept statement as a triggering statement. + + Set_Statements + (Accept_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm)); + return Accept_Alt_Node; + end P_Accept_Alternative; + + ------------------------------ + -- 9.7.1 Delay Alternative -- + ------------------------------ + + -- DELAY_ALTERNATIVE ::= + -- DELAY_STATEMENT [SEQUENCE_OF_STATEMENTS] + + -- Error_Recovery: Cannot raise Error_Resync + + -- Note: the caller is responsible for setting the Pragmas_Before + -- field of the returned N_Terminate_Alternative node. + + function P_Delay_Alternative return Node_Id is + Delay_Alt_Node : Node_Id; + + begin + Delay_Alt_Node := New_Node (N_Delay_Alternative, Token_Ptr); + Set_Delay_Statement (Delay_Alt_Node, P_Delay_Statement); + + -- Note: the reason that we accept THEN ABORT as a terminator for + -- the sequence of statements is for error recovery which allows + -- for misuse of an accept statement as a triggering statement. + + Set_Statements + (Delay_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm)); + return Delay_Alt_Node; + end P_Delay_Alternative; + + ---------------------------------- + -- 9.7.1 Terminate Alternative -- + ---------------------------------- + + -- TERMINATE_ALTERNATIVE ::= terminate; + + -- Error_Recovery: Cannot raise Error_Resync + + -- Note: the caller is responsible for setting the Pragmas_Before + -- field of the returned N_Terminate_Alternative node. + + function P_Terminate_Alternative return Node_Id is + Terminate_Alt_Node : Node_Id; + + begin + Terminate_Alt_Node := New_Node (N_Terminate_Alternative, Token_Ptr); + Scan; -- past TERMINATE + TF_Semicolon; + + -- For all other select alternatives, the sequence of statements + -- after the alternative statement will swallow up any pragmas + -- coming in this position. But the terminate alternative has no + -- sequence of statements, so the pragmas here must be treated + -- specially. + + Set_Pragmas_After (Terminate_Alt_Node, P_Pragmas_Opt); + return Terminate_Alt_Node; + end P_Terminate_Alternative; + + ----------------------------- + -- 9.7.2 Timed Entry Call -- + ----------------------------- + + -- Parsed by P_Select_Statement (9.7) + + ----------------------------------- + -- 9.7.2 Entry Call Alternative -- + ----------------------------------- + + -- Parsed by P_Select_Statement (9.7) + + ----------------------------------- + -- 9.7.3 Conditional Entry Call -- + ----------------------------------- + + -- Parsed by P_Select_Statement (9.7) + + -------------------------------- + -- 9.7.4 Asynchronous Select -- + -------------------------------- + + -- Parsed by P_Select_Statement (9.7) + + ----------------------------------- + -- 9.7.4 Triggering Alternative -- + ----------------------------------- + + -- Parsed by P_Select_Statement (9.7) + + --------------------------------- + -- 9.7.4 Triggering Statement -- + --------------------------------- + + -- Parsed by P_Select_Statement (9.7) + + --------------------------- + -- 9.7.4 Abortable Part -- + --------------------------- + + -- ABORTABLE_PART ::= SEQUENCE_OF_STATEMENTS + + -- The caller has verified that THEN ABORT is present, and Token is + -- pointing to the ABORT on entry (or if not, then we have an error) + + -- Error recovery: cannot raise Error_Resync + + function P_Abortable_Part return Node_Id is + Abortable_Part_Node : Node_Id; + + begin + Abortable_Part_Node := New_Node (N_Abortable_Part, Token_Ptr); + T_Abort; -- scan past ABORT + + if Ada_Version = Ada_83 then + Error_Msg_SP ("(Ada 83) asynchronous select not allowed!"); + end if; + + Set_Statements (Abortable_Part_Node, P_Sequence_Of_Statements (SS_Sreq)); + return Abortable_Part_Node; + end P_Abortable_Part; + + -------------------------- + -- 9.8 Abort Statement -- + -------------------------- + + -- ABORT_STATEMENT ::= abort task_NAME {, task_NAME}; + + -- The caller has checked that the initial token is ABORT + + -- Error recovery: cannot raise Error_Resync + + function P_Abort_Statement return Node_Id is + Abort_Node : Node_Id; + + begin + Abort_Node := New_Node (N_Abort_Statement, Token_Ptr); + Scan; -- past ABORT + Set_Names (Abort_Node, New_List); + + loop + Append (P_Name, Names (Abort_Node)); + exit when Token /= Tok_Comma; + Scan; -- past comma + end loop; + + TF_Semicolon; + return Abort_Node; + end P_Abort_Statement; + +end Ch9; diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb new file mode 100644 index 000000000..b250ecb95 --- /dev/null +++ b/gcc/ada/par-endh.adb @@ -0,0 +1,1268 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . E N D H -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Namet.Sp; use Namet.Sp; +with Stringt; use Stringt; +with Uintp; use Uintp; + +with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; + +separate (Par) +package body Endh is + + ---------------- + -- Local Data -- + ---------------- + + type End_Action_Type is ( + -- Type used to describe the result of the Pop_End_Context call + + Accept_As_Scanned, + -- Current end sequence is entirely c correct. In this case Token and + -- the scan pointer are left pointing past the end sequence (i.e. they + -- are unchanged from the values set on entry to Pop_End_Context). + + Insert_And_Accept, + -- Current end sequence is to be left in place to satisfy some outer + -- scope. Token and the scan pointer are set to point to the end + -- token, and should be left there. A message has been generated + -- indicating a missing end sequence. This status is also used for + -- the case when no end token is present. + + Skip_And_Accept, + -- The end sequence is incorrect (and an error message has been + -- posted), but it will still be accepted. In this case Token and + -- the scan pointer point back to the end token, and the caller + -- should skip past the end sequence before proceeding. + + Skip_And_Reject); + -- The end sequence is judged to belong to an unrecognized inner + -- scope. An appropriate message has been issued and the caller + -- should skip past the end sequence and then proceed as though + -- no end sequence had been encountered. + + End_Action : End_Action_Type; + -- The variable set by Pop_End_Context call showing which of the four + -- decisions described above is judged the best. + + End_Sloc : Source_Ptr; + -- Source location of END token + + End_OK : Boolean; + -- Set False if error is found in END line + + End_Column : Column_Number; + -- Column of END line + + End_Type : SS_End_Type; + -- Type of END expected. The special value E_Dummy is set to indicate that + -- no END token was present (so a missing END inserted message is needed) + + End_Labl : Node_Id; + -- Node_Id value for explicit name on END line, or for compiler supplied + -- name in the case where an optional name is not given. Empty if no name + -- appears. If non-empty, then it is either an N_Designator node for a + -- child unit or a node with a Chars field identifying the actual label. + + End_Labl_Present : Boolean; + -- Indicates that the value in End_Labl was for an explicit label + + Syntax_OK : Boolean; + -- Set True if the entry is syntactically correct + + Token_OK : Boolean; + -- Set True if the keyword in the END sequence matches, or if neither + -- the END sequence nor the END stack entry has a keyword. + + Label_OK : Boolean; + -- Set True if both the END sequence and the END stack entry contained + -- labels (other than No_Name or Error_Name) and the labels matched. + -- This is a stronger condition than SYNTAX_OK, since it means that a + -- label was present, even in a case where it was optional. Note that + -- the case of no label required, and no label present does NOT set + -- Label_OK to True, it is True only if a positive label match is found. + + Column_OK : Boolean; + -- Column_OK is set True if the END sequence appears in the expected column + + Scan_State : Saved_Scan_State; + -- Save state at start of END sequence, in case we decide not to eat it up + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Evaluate_End_Entry (SS_Index : Nat); + -- Compare scanned END entry (as recorded by a prior call to P_End_Scan) + -- with a specified entry in the scope stack (the single parameter is the + -- entry index in the scope stack). Note that Scan is not called. The above + -- variables xxx_OK are set to indicate the result of the evaluation. + + function Explicit_Start_Label (SS_Index : Nat) return Boolean; + -- Determines whether the specified entry in the scope stack has an + -- explicit start label (i.e. one other than one that was created by + -- the parser when no explicit label was present) + + procedure Output_End_Deleted; + -- Output a message complaining that the current END structure does not + -- match anything and is being deleted. + + procedure Output_End_Expected (Ins : Boolean); + -- Output a message at the start of the current token which is always an + -- END, complaining that the END is not of the right form. The message + -- indicates the expected form. The information for the message is taken + -- from the top entry in the scope stack. The Ins parameter is True if + -- an end is being inserted, and false if an existing end is being + -- replaced. Note that in the case of a suspicious IS for the Ins case, + -- we do not output the message, but instead simply mark the scope stack + -- entry as being a case of a bad IS. + + procedure Output_End_Missing; + -- Output a message just before the current token, complaining that the + -- END is not of the right form. The message indicates the expected form. + -- The information for the message is taken from the top entry in the + -- scope stack. Note that in the case of a suspicious IS, we do not output + -- the message, but instead simply mark the scope stack entry as a bad IS. + + procedure Pop_End_Context; + -- Pop_End_Context is called after processing a construct, to pop the + -- top entry off the end stack. It decides on the appropriate action to + -- to take, signalling the result by setting End_Action as described in + -- the global variable section. + + function Same_Label (Label1, Label2 : Node_Id) return Boolean; + -- This function compares the two names associated with the given nodes. + -- If they are both simple (i.e. have Chars fields), then they have to + -- be the same name. Otherwise they must both be N_Selected_Component + -- nodes, referring to the same set of names, or Label1 is an N_Designator + -- referring to the same set of names as the N_Defining_Program_Unit_Name + -- in Label2. Any other combination returns False. This routine is used + -- to compare the End_Labl scanned from the End line with the saved label + -- value in the scope stack. + + --------------- + -- Check_End -- + --------------- + + function Check_End (Decl : Node_Id := Empty) return Boolean is + Name_On_Separate_Line : Boolean; + -- Set True if the name on an END line is on a separate source line + -- from the END. This is highly suspicious, but is allowed. The point + -- is that we want to make sure that we don't just have a missing + -- semicolon misleading us into swallowing an identifier from the + -- following line. + + Name_Scan_State : Saved_Scan_State; + -- Save state at start of name if Name_On_Separate_Line is TRUE + + Span_Node : constant Node_Id := Scope.Table (Scope.Last).Node; + + begin + End_Labl_Present := False; + End_Labl := Empty; + + -- Our first task is to scan out the END sequence if one is present. + -- If none is present, signal by setting End_Type to E_Dummy. + + if Token /= Tok_End then + End_Type := E_Dummy; + + else + Save_Scan_State (Scan_State); -- at END + End_Sloc := Token_Ptr; + End_Column := Start_Column; + End_OK := True; + Scan; -- past END + + -- Set End_Span if expected. note that this will be useless + -- if we do not have the right ending keyword, but in this + -- case we have a malformed program anyway, and the setting + -- of End_Span will simply be unreliable in this case anyway. + + if Present (Span_Node) then + Set_End_Location (Span_Node, Token_Ptr); + end if; + + -- Cases of keywords where no label is allowed + + if Token = Tok_Case then + End_Type := E_Case; + Scan; -- past CASE + + elsif Token = Tok_If then + End_Type := E_If; + Scan; -- past IF + + elsif Token = Tok_Record then + End_Type := E_Record; + Scan; -- past RECORD + + elsif Token = Tok_Return then + End_Type := E_Return; + Scan; -- past RETURN + + elsif Token = Tok_Select then + End_Type := E_Select; + Scan; -- past SELECT + + -- Cases which do allow labels + + else + -- LOOP + + if Token = Tok_Loop then + Scan; -- past LOOP + End_Type := E_Loop; + + -- FOR or WHILE allowed (signalling error) to substitute for LOOP + -- if on the same line as the END + + elsif (Token = Tok_For or else Token = Tok_While) + and then not Token_Is_At_Start_Of_Line + then + Scan; -- past FOR or WHILE + End_Type := E_Loop; + End_OK := False; + + -- Cases with no keyword + + else + End_Type := E_Name; + end if; + + -- Now see if a name is present + + if Token = Tok_Identifier or else + Token = Tok_String_Literal or else + Token = Tok_Operator_Symbol + then + if Token_Is_At_Start_Of_Line then + Name_On_Separate_Line := True; + Save_Scan_State (Name_Scan_State); + else + Name_On_Separate_Line := False; + end if; + + End_Labl := P_Designator; + End_Labl_Present := True; + + -- We have now scanned out a name. Here is where we do a check + -- to catch the cases like: + -- + -- end loop + -- X := 3; + -- + -- where the missing semicolon might make us swallow up the X + -- as a bogus end label. In a situation like this, where the + -- apparent name is on a separate line, we accept it only if + -- it matches the label and is followed by a semicolon. + + if Name_On_Separate_Line then + if Token /= Tok_Semicolon or else + not Same_Label (End_Labl, Scope.Table (Scope.Last).Labl) + then + Restore_Scan_State (Name_Scan_State); + End_Labl := Empty; + End_Labl_Present := False; + end if; + end if; + + -- Here for case of name allowed, but no name present. We will + -- supply an implicit matching name, with source location set + -- to the scan location past the END token. + + else + End_Labl := Scope.Table (Scope.Last).Labl; + + if End_Labl > Empty_Or_Error then + + -- The task here is to construct a designator from the + -- opening label, with the components all marked as not + -- from source, and Is_End_Label set in the identifier + -- or operator symbol. The location for all components + -- is the current token location. + + -- Case of child unit name + + if Nkind (End_Labl) = N_Defining_Program_Unit_Name then + Child_End : declare + Eref : constant Node_Id := + Make_Identifier (Token_Ptr, + Chars => + Chars (Defining_Identifier (End_Labl))); + + function Copy_Name (N : Node_Id) return Node_Id; + -- Copies a selected component or identifier + + --------------- + -- Copy_Name -- + --------------- + + function Copy_Name (N : Node_Id) return Node_Id is + R : Node_Id; + + begin + if Nkind (N) = N_Selected_Component then + return + Make_Selected_Component (Token_Ptr, + Prefix => + Copy_Name (Prefix (N)), + Selector_Name => + Copy_Name (Selector_Name (N))); + + else + R := Make_Identifier (Token_Ptr, Chars (N)); + Set_Comes_From_Source (N, False); + return R; + end if; + end Copy_Name; + + -- Start of processing for Child_End + + begin + Set_Comes_From_Source (Eref, False); + + End_Labl := + Make_Designator (Token_Ptr, + Name => Copy_Name (Name (End_Labl)), + Identifier => Eref); + end Child_End; + + -- Simple identifier case + + elsif Nkind (End_Labl) = N_Defining_Identifier + or else Nkind (End_Labl) = N_Identifier + then + End_Labl := Make_Identifier (Token_Ptr, Chars (End_Labl)); + + elsif Nkind (End_Labl) = N_Defining_Operator_Symbol + or else Nkind (End_Labl) = N_Operator_Symbol + then + Get_Decoded_Name_String (Chars (End_Labl)); + + End_Labl := + Make_Operator_Symbol (Token_Ptr, + Chars => Chars (End_Labl), + Strval => String_From_Name_Buffer); + end if; + + Set_Comes_From_Source (End_Labl, False); + End_Labl_Present := False; + + -- Do style check for missing label + + if Style_Check + and then End_Type = E_Name + and then Explicit_Start_Label (Scope.Last) + then + Style.No_End_Name (Scope.Table (Scope.Last).Labl); + end if; + end if; + end if; + end if; + + -- Deal with terminating aspect specifications and following semi- + -- colon. We skip this in the case of END RECORD, since in this + -- case the aspect specifications and semicolon are handled at + -- a higher level. + + if End_Type /= E_Record then + + -- Scan aspect specifications if permitted here + + if Aspect_Specifications_Present then + if No (Decl) then + P_Aspect_Specifications (Error); + else + P_Aspect_Specifications (Decl); + end if; + + -- If no aspect specifications, must have a semicolon + + elsif End_Type /= E_Record then + if Token = Tok_Semicolon then + T_Semicolon; + + -- Semicolon is missing. If the missing semicolon is at the end + -- of the line, i.e. we are at the start of the line now, then + -- a missing semicolon gets flagged, but is not serious enough + -- to consider the END statement to be bad in the sense that we + -- are dealing with (i.e. to be suspicious that this END is not + -- the END statement we are looking for). + + -- Similarly, if we are at a colon, we flag it but a colon for + -- a semicolon is not serious enough to consider the END to be + -- incorrect. Same thing for a period in place of a semicolon. + + elsif Token_Is_At_Start_Of_Line + or else Token = Tok_Colon + or else Token = Tok_Dot + then + T_Semicolon; + + -- If the missing semicolon is not at the start of the line, + -- then we consider the END line to be dubious in this sense. + + else + End_OK := False; + end if; + end if; + end if; + end if; + + -- Now we call the Pop_End_Context routine to get a recommendation + -- as to what should be done with the END sequence we have scanned. + + Pop_End_Context; + + -- Remaining action depends on End_Action set by Pop_End_Context + + case End_Action is + + -- Accept_As_Scanned. In this case, Pop_End_Context left Token + -- pointing past the last token of a syntactically correct END + + when Accept_As_Scanned => + + -- Syntactically correct included the possibility of a missing + -- semicolon. If we do have a missing semicolon, then we have + -- already given a message, but now we scan out possible rubbish + -- on the same line as the END + + while not Token_Is_At_Start_Of_Line + and then Prev_Token /= Tok_Record + and then Prev_Token /= Tok_Semicolon + and then Token /= Tok_End + and then Token /= Tok_EOF + loop + Scan; -- past junk + end loop; + + return True; + + -- Insert_And_Accept. In this case, Pop_End_Context has reset Token + -- to point to the start of the END sequence, and recommends that it + -- be left in place to satisfy an outer scope level END. This means + -- that we proceed as though an END were present, and leave the scan + -- pointer unchanged. + + when Insert_And_Accept => + return True; + + -- Skip_And_Accept. In this case, Pop_End_Context has reset Token + -- to point to the start of the END sequence. This END sequence is + -- syntactically incorrect, and an appropriate error message has + -- already been posted. Pop_End_Context recommends accepting the + -- END sequence as the one we want, so we skip past it and then + -- proceed as though an END were present. + + when Skip_And_Accept => + End_Skip; + return True; + + -- Skip_And_Reject. In this case, Pop_End_Context has reset Token + -- to point to the start of the END sequence. This END sequence is + -- syntactically incorrect, and an appropriate error message has + -- already been posted. Pop_End_Context recommends entirely ignoring + -- this END sequence, so we skip past it and then return False, since + -- as far as the caller is concerned, no END sequence is present. + + when Skip_And_Reject => + End_Skip; + return False; + end case; + end Check_End; + + -------------- + -- End Skip -- + -------------- + + -- This procedure skips past an END sequence. On entry Token contains + -- Tok_End, and we know that the END sequence is syntactically incorrect, + -- and that an appropriate error message has already been posted. The + -- mission is simply to position the scan pointer to be the best guess of + -- the position after the END sequence. We do not issue any additional + -- error messages while carrying this out. + + -- Error recovery: does not raise Error_Resync + + procedure End_Skip is + begin + Scan; -- past END + + -- If the scan past the END leaves us on the next line, that's probably + -- where we should quit the scan, since it is likely that what we have + -- is a missing semicolon. Consider the following: + + -- END + -- Process_Input; + + -- This will have looked like a syntactically valid END sequence to the + -- initial scan of the END, but subsequent checking will have determined + -- that the label Process_Input is not an appropriate label. The real + -- error is a missing semicolon after the END, and by leaving the scan + -- pointer just past the END, we will improve the error recovery. + + if Token_Is_At_Start_Of_Line then + return; + end if; + + -- If there is a semicolon after the END, scan it out and we are done + + if Token = Tok_Semicolon then + T_Semicolon; + return; + end if; + + -- Otherwise skip past a token after the END on the same line. Note + -- that we do not eat a token on the following line since it seems + -- very unlikely in any case that the END gets separated from its + -- token, and we do not want to swallow up a keyword that starts a + -- legitimate construct following the bad END. + + if not Token_Is_At_Start_Of_Line + and then + + -- Cases of normal tokens following an END + + (Token = Tok_Case or else + Token = Tok_For or else + Token = Tok_If or else + Token = Tok_Loop or else + Token = Tok_Record or else + Token = Tok_Select or else + + -- Cases of bogus keywords ending loops + + Token = Tok_For or else + Token = Tok_While or else + + -- Cases of operator symbol names without quotes + + Token = Tok_Abs or else + Token = Tok_And or else + Token = Tok_Mod or else + Token = Tok_Not or else + Token = Tok_Or or else + Token = Tok_Xor) + + then + Scan; -- past token after END + + -- If that leaves us on the next line, then we are done. This is the + -- same principle described above for the case of END at line end + + if Token_Is_At_Start_Of_Line then + return; + + -- If we just scanned out record, then we are done, since the + -- semicolon after END RECORD is not part of the END sequence + + elsif Prev_Token = Tok_Record then + return; + + -- If we have a semicolon, scan it out and we are done + + elsif Token = Tok_Semicolon then + T_Semicolon; + return; + end if; + end if; + + -- Check for a label present on the same line + + loop + if Token_Is_At_Start_Of_Line then + return; + end if; + + if Token /= Tok_Identifier + and then Token /= Tok_Operator_Symbol + and then Token /= Tok_String_Literal + then + exit; + end if; + + Scan; -- past identifier, operator symbol or string literal + + if Token_Is_At_Start_Of_Line then + return; + elsif Token = Tok_Dot then + Scan; -- past dot + end if; + end loop; + + -- Skip final semicolon + + if Token = Tok_Semicolon then + T_Semicolon; + + -- If we don't have a final semicolon, skip until we either encounter + -- an END token, or a semicolon or the start of the next line. This + -- allows general junk to follow the end line (normally it is hard to + -- think that anyone will put anything deliberate here, and remember + -- that we know there is a missing semicolon in any case). We also + -- quite on an EOF (or else we would get stuck in an infinite loop + -- if there is no line end at the end of the last line of the file) + + else + while Token /= Tok_End + and then Token /= Tok_EOF + and then Token /= Tok_Semicolon + and then not Token_Is_At_Start_Of_Line + loop + Scan; -- past junk token on same line + end loop; + end if; + + return; + end End_Skip; + + -------------------- + -- End Statements -- + -------------------- + + -- This procedure is called when END is required or expected to terminate + -- a sequence of statements. The caller has already made an appropriate + -- entry on the scope stack to describe the expected form of the END. + -- End_Statements should only be used in cases where the only appropriate + -- terminator is END. + + -- Error recovery: cannot raise Error_Resync; + + procedure End_Statements + (Parent : Node_Id := Empty; + Decl : Node_Id := Empty) is + begin + -- This loop runs more than once in the case where Check_End rejects + -- the END sequence, as indicated by Check_End returning False. + + loop + if Check_End (Decl) then + if Present (Parent) then + Set_End_Label (Parent, End_Labl); + end if; + + return; + end if; + + -- Extra statements past the bogus END are discarded. This is not + -- ideal for maximum error recovery, but it's too much trouble to + -- find an appropriate place to put them! + + Discard_Junk_List (P_Sequence_Of_Statements (SS_None)); + end loop; + end End_Statements; + + ------------------------ + -- Evaluate End Entry -- + ------------------------ + + procedure Evaluate_End_Entry (SS_Index : Nat) is + begin + Column_OK := (End_Column = Scope.Table (SS_Index).Ecol); + + Token_OK := (End_Type = Scope.Table (SS_Index).Etyp or else + (End_Type = E_Name and then + Scope.Table (SS_Index).Etyp >= E_Name)); + + Label_OK := End_Labl_Present + and then + (Same_Label (End_Labl, Scope.Table (SS_Index).Labl) + or else Scope.Table (SS_Index).Labl = Error); + + -- Compute setting of Syntax_OK. We definitely have a syntax error + -- if the Token does not match properly or if P_End_Scan detected + -- a syntax error such as a missing semicolon. + + if not Token_OK or not End_OK then + Syntax_OK := False; + + -- Final check is that label is OK. Certainly it is OK if there + -- was an exact match on the label (the END label = the stack label) + + elsif Label_OK then + Syntax_OK := True; + + -- Case of label present + + elsif End_Labl_Present then + + -- If probably misspelling, then complain, and pretend it is OK + + declare + Nam : constant Node_Or_Entity_Id := Scope.Table (SS_Index).Labl; + + begin + if Nkind (End_Labl) in N_Has_Chars + and then Comes_From_Source (Nam) + and then Nkind (Nam) in N_Has_Chars + and then Chars (End_Labl) > Error_Name + and then Chars (Nam) > Error_Name + then + Error_Msg_Name_1 := Chars (Nam); + + if Error_Msg_Name_1 > Error_Name then + if Is_Bad_Spelling_Of (Chars (Nam), Chars (End_Labl)) then + Error_Msg_Name_1 := Chars (Nam); + Error_Msg_N -- CODEFIX + ("misspelling of %", End_Labl); + Syntax_OK := True; + return; + end if; + end if; + end if; + end; + + Syntax_OK := False; + + -- Otherwise we have cases of no label on the END line. For the loop + -- case, this is acceptable only if the loop is unlabeled. + + elsif End_Type = E_Loop then + Syntax_OK := not Explicit_Start_Label (SS_Index); + + -- Cases where a label is definitely allowed on the END line + + elsif End_Type = E_Name then + Syntax_OK := (not Explicit_Start_Label (SS_Index)) + or else + (not Scope.Table (SS_Index).Lreq); + + -- Otherwise we have cases which don't allow labels anyway, so we + -- certainly accept an END which does not have a label. + + else + Syntax_OK := True; + end if; + end Evaluate_End_Entry; + + -------------------------- + -- Explicit_Start_Label -- + -------------------------- + + function Explicit_Start_Label (SS_Index : Nat) return Boolean is + L : constant Node_Id := Scope.Table (SS_Index).Labl; + Etyp : constant SS_End_Type := Scope.Table (SS_Index).Etyp; + + begin + if No (L) then + return False; + + -- In the following test we protect the call to Comes_From_Source + -- against lines containing previously reported syntax errors. + + elsif (Etyp = E_Loop + or else Etyp = E_Name + or else Etyp = E_Suspicious_Is + or else Etyp = E_Bad_Is) + and then Comes_From_Source (L) + then + return True; + else + return False; + end if; + end Explicit_Start_Label; + + ------------------------ + -- Output End Deleted -- + ------------------------ + + procedure Output_End_Deleted is + begin + + if End_Type = E_Loop then + Error_Msg_SC ("no LOOP for this `END LOOP`!"); + + elsif End_Type = E_Case then + Error_Msg_SC ("no CASE for this `END CASE`"); + + elsif End_Type = E_If then + Error_Msg_SC ("no IF for this `END IF`!"); + + elsif End_Type = E_Record then + Error_Msg_SC ("no RECORD for this `END RECORD`!"); + + elsif End_Type = E_Return then + Error_Msg_SC ("no RETURN for this `END RETURN`!"); + + elsif End_Type = E_Select then + Error_Msg_SC ("no SELECT for this `END SELECT`!"); + + else + Error_Msg_SC ("no BEGIN for this END!"); + end if; + end Output_End_Deleted; + + ------------------------- + -- Output End Expected -- + ------------------------- + + procedure Output_End_Expected (Ins : Boolean) is + End_Type : SS_End_Type; + + begin + -- Suppress message if this was a potentially junk entry (e.g. a + -- record entry where no record keyword was present. + + if Scope.Table (Scope.Last).Junk then + return; + end if; + + End_Type := Scope.Table (Scope.Last).Etyp; + Error_Msg_Col := Scope.Table (Scope.Last).Ecol; + Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc; + + if Explicit_Start_Label (Scope.Last) then + Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl; + else + Error_Msg_Node_1 := Empty; + end if; + + -- Suppress message if error was posted on opening label + + if Error_Msg_Node_1 > Empty_Or_Error + and then Error_Posted (Error_Msg_Node_1) + then + return; + end if; + + if End_Type = E_Case then + Error_Msg_SC -- CODEFIX + ("`END CASE;` expected@ for CASE#!"); + + elsif End_Type = E_If then + Error_Msg_SC -- CODEFIX + ("`END IF;` expected@ for IF#!"); + + elsif End_Type = E_Loop then + if Error_Msg_Node_1 = Empty then + Error_Msg_SC -- CODEFIX + ("`END LOOP;` expected@ for LOOP#!"); + else + Error_Msg_SC -- CODEFIX + ("`END LOOP &;` expected@!"); + end if; + + elsif End_Type = E_Record then + Error_Msg_SC -- CODEFIX + ("`END RECORD;` expected@ for RECORD#!"); + + elsif End_Type = E_Return then + Error_Msg_SC -- CODEFIX + ("`END RETURN;` expected@ for RETURN#!"); + + elsif End_Type = E_Select then + Error_Msg_SC -- CODEFIX + ("`END SELECT;` expected@ for SELECT#!"); + + -- All remaining cases are cases with a name (we do not treat + -- the suspicious is cases specially for a replaced end, only + -- for an inserted end). + + elsif End_Type = E_Name or else (not Ins) then + if Error_Msg_Node_1 = Empty then + Error_Msg_SC -- CODEFIX + ("`END;` expected@ for BEGIN#!"); + else + Error_Msg_SC -- CODEFIX + ("`END &;` expected@!"); + end if; + + -- The other possibility is a missing END for a subprogram with a + -- suspicious IS (that probably should have been a semicolon). The + -- Missing IS confirms the suspicion! + + else -- End_Type = E_Suspicious_Is or E_Bad_Is + Scope.Table (Scope.Last).Etyp := E_Bad_Is; + end if; + end Output_End_Expected; + + ------------------------ + -- Output End Missing -- + ------------------------ + + procedure Output_End_Missing is + End_Type : SS_End_Type; + + begin + -- Suppress message if this was a potentially junk entry (e.g. a + -- record entry where no record keyword was present. + + if Scope.Table (Scope.Last).Junk then + return; + end if; + + End_Type := Scope.Table (Scope.Last).Etyp; + Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc; + + if Explicit_Start_Label (Scope.Last) then + Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl; + else + Error_Msg_Node_1 := Empty; + end if; + + if End_Type = E_Case then + Error_Msg_BC ("missing `END CASE;` for CASE#!"); + + elsif End_Type = E_If then + Error_Msg_BC ("missing `END IF;` for IF#!"); + + elsif End_Type = E_Loop then + if Error_Msg_Node_1 = Empty then + Error_Msg_BC ("missing `END LOOP;` for LOOP#!"); + else + Error_Msg_BC ("missing `END LOOP &;`!"); + end if; + + elsif End_Type = E_Record then + Error_Msg_SC + ("missing `END RECORD;` for RECORD#!"); + + elsif End_Type = E_Return then + Error_Msg_SC + ("missing `END RETURN;` for RETURN#!"); + + elsif End_Type = E_Select then + Error_Msg_BC + ("missing `END SELECT;` for SELECT#!"); + + elsif End_Type = E_Name then + if Error_Msg_Node_1 = Empty then + Error_Msg_BC ("missing `END;` for BEGIN#!"); + else + Error_Msg_BC ("missing `END &;`!"); + end if; + + else -- End_Type = E_Suspicious_Is or E_Bad_Is + Scope.Table (Scope.Last).Etyp := E_Bad_Is; + end if; + end Output_End_Missing; + + --------------------- + -- Pop End Context -- + --------------------- + + procedure Pop_End_Context is + + Pretty_Good : Boolean; + -- This flag is set True if the END sequence is syntactically incorrect, + -- but is (from a heuristic point of view), pretty likely to be simply + -- a misspelling of the intended END. + + Outer_Match : Boolean; + -- This flag is set True if we decide that the current END sequence + -- belongs to some outer level entry in the scope stack, and thus + -- we will NOT eat it up in matching the current expected END. + + begin + -- If not at END, then output END expected message + + if End_Type = E_Dummy then + Output_End_Missing; + Pop_Scope_Stack; + End_Action := Insert_And_Accept; + return; + + -- Otherwise we do have an END present + + else + -- A special check. If we have END; followed by an end of file, + -- WITH or SEPARATE, then if we are not at the outer level, then + -- we have a syntax error. Consider the example: + + -- ... + -- declare + -- X : Integer; + -- begin + -- X := Father (A); + -- Process (X, X); + -- end; + -- with Package1; + -- ... + + -- Now the END; here is a syntactically correct closer for the + -- declare block, but if we eat it up, then we obviously have + -- a missing END for the outer context (since WITH can only appear + -- at the outer level. + + -- In this situation, we always reserve the END; for the outer level, + -- even if it is in the wrong column. This is because it's much more + -- useful to have the error message point to the DECLARE than to the + -- package header in this case. + + -- We also reserve an end with a name before the end of file if the + -- name is the one we expect at the outer level. + + if (Token = Tok_EOF or else + Token = Tok_With or else + Token = Tok_Separate) + and then End_Type >= E_Name + and then (not End_Labl_Present + or else Same_Label (End_Labl, Scope.Table (1).Labl)) + and then Scope.Last > 1 + then + Restore_Scan_State (Scan_State); -- to END + Output_End_Expected (Ins => True); + Pop_Scope_Stack; + End_Action := Insert_And_Accept; + return; + end if; + + -- Otherwise we go through the normal END evaluation procedure + + Evaluate_End_Entry (Scope.Last); + + -- If top entry in stack is syntactically correct, then we have + -- scanned it out and everything is fine. This is the required + -- action to properly process correct Ada programs. + + if Syntax_OK then + + -- Complain if checking columns and END is not in right column. + -- Right in this context means exactly right, or on the same + -- line as the opener. + + if RM_Column_Check then + if End_Column /= Scope.Table (Scope.Last).Ecol + and then Current_Line_Start > Scope.Table (Scope.Last).Sloc + + -- A special case, for END RECORD, we are also allowed to + -- line up with the TYPE keyword opening the declaration. + + and then (Scope.Table (Scope.Last).Etyp /= E_Record + or else Get_Column_Number (End_Sloc) /= + Get_Column_Number (Type_Token_Location)) + then + Error_Msg_Col := Scope.Table (Scope.Last).Ecol; + Error_Msg + ("(style) END in wrong column, should be@", End_Sloc); + end if; + end if; + + -- One final check. If the end had a label, check for an exact + -- duplicate of this end sequence, and if so, skip it with an + -- appropriate message. + + if End_Labl_Present and then Token = Tok_End then + declare + Scan_State : Saved_Scan_State; + End_Loc : constant Source_Ptr := Token_Ptr; + Nxt_Labl : Node_Id; + Dup_Found : Boolean := False; + + begin + Save_Scan_State (Scan_State); + + Scan; -- past END + + if Token = Tok_Identifier + or else Token = Tok_Operator_Symbol + then + Nxt_Labl := P_Designator; + + -- We only consider it an error if the label is a match + -- and would be wrong for the level one above us, and + -- the indentation is the same. + + if Token = Tok_Semicolon + and then Same_Label (End_Labl, Nxt_Labl) + and then End_Column = Start_Column + and then + (Scope.Last = 1 + or else + (not Explicit_Start_Label (Scope.Last - 1)) + or else + (not Same_Label + (End_Labl, + Scope.Table (Scope.Last - 1).Labl))) + then + T_Semicolon; + Error_Msg ("duplicate end line ignored", End_Loc); + Dup_Found := True; + end if; + end if; + + if not Dup_Found then + Restore_Scan_State (Scan_State); + end if; + end; + end if; + + -- All OK, so return to caller indicating END is OK + + Pop_Scope_Stack; + End_Action := Accept_As_Scanned; + return; + end if; + + -- If that check failed, then we definitely have an error. The issue + -- is how to choose among three possible courses of action: + + -- 1. Ignore the current END text completely, scanning past it, + -- deciding that it belongs neither to the current context, + -- nor to any outer context. + + -- 2. Accept the current END text, scanning past it, and issuing + -- an error message that it does not have the right form. + + -- 3. Leave the current END text in place, NOT scanning past it, + -- issuing an error message indicating the END expected for the + -- current context. In this case, the END is available to match + -- some outer END context. + + -- From a correct functioning point of view, it does not make any + -- difference which of these three approaches we take, the program + -- will work correctly in any case. However, making an accurate + -- choice among these alternatives, i.e. choosing the one that + -- corresponds to what the programmer had in mind, does make a + -- significant difference in the quality of error recovery. + + Restore_Scan_State (Scan_State); -- to END + + -- First we see how good the current END entry is with respect to + -- what we expect. It is considered pretty good if the token is OK, + -- and either the label or the column matches. An END for RECORD is + -- always considered to be pretty good in the record case. This is + -- because not only does a record disallow a nested structure, but + -- also it is unlikely that such nesting could occur by accident. + + Pretty_Good := (Token_OK and (Column_OK or Label_OK)) + or else Scope.Table (Scope.Last).Etyp = E_Record; + + -- Next check, if there is a deeper entry in the stack which + -- has a very high probability of being acceptable, then insert + -- the END entry we want, leaving the higher level entry for later + + for J in reverse 1 .. Scope.Last - 1 loop + Evaluate_End_Entry (J); + + -- To even consider the deeper entry to be immediately acceptable, + -- it must be syntactically correct. Furthermore it must either + -- have a correct label, or the correct column. If the current + -- entry was a close match (Pretty_Good set), then we are even + -- more strict in accepting the outer level one: even if it has + -- the right label, it must have the right column as well. + + if Syntax_OK then + if Pretty_Good then + Outer_Match := Label_OK and Column_OK; + else + Outer_Match := Label_OK or Column_OK; + end if; + else + Outer_Match := False; + end if; + + -- If the outer entry does convincingly match the END text, then + -- back up the scan to the start of the END sequence, issue an + -- error message indicating the END we expected, and return with + -- Token pointing to the END (case 3 from above discussion). + + if Outer_Match then + Output_End_Missing; + Pop_Scope_Stack; + End_Action := Insert_And_Accept; + return; + end if; + end loop; + + -- Here we have a situation in which the current END entry is + -- syntactically incorrect, but there is no deeper entry in the + -- END stack which convincingly matches it. + + -- If the END text was judged to be a Pretty_Good match for the + -- expected token or if it appears left of the expected column, + -- then we will accept it as the one we want, scanning past it, even + -- though it is not completely right (we issue a message showing what + -- we expected it to be). This is action 2 from the discussion above. + -- There is one other special case to consider: the LOOP case. + -- Consider the example: + + -- Lbl: loop + -- null; + -- end loop; + + -- Here the column lines up with Lbl, so END LOOP is to the right, + -- but it is still acceptable. LOOP is the one case where alignment + -- practices vary substantially in practice. + + if Pretty_Good + or else End_Column <= Scope.Table (Scope.Last).Ecol + or else (End_Type = Scope.Table (Scope.Last).Etyp + and then End_Type = E_Loop) + then + Output_End_Expected (Ins => False); + Pop_Scope_Stack; + End_Action := Skip_And_Accept; + return; + + -- Here we have the case where the END is to the right of the + -- expected column and does not have a correct label to convince + -- us that it nevertheless belongs to the current scope. For this + -- we consider that it probably belongs not to the current context, + -- but to some inner context that was not properly recognized (due to + -- other syntax errors), and for which no proper scope stack entry + -- was made. The proper action in this case is to delete the END text + -- and return False to the caller as a signal to keep on looking for + -- an acceptable END. This is action 1 from the discussion above. + + else + Output_End_Deleted; + End_Action := Skip_And_Reject; + return; + end if; + end if; + end Pop_End_Context; + + ---------------- + -- Same_Label -- + ---------------- + + function Same_Label (Label1, Label2 : Node_Id) return Boolean is + begin + if Nkind (Label1) in N_Has_Chars + and then Nkind (Label2) in N_Has_Chars + then + return Chars (Label1) = Chars (Label2); + + elsif Nkind (Label1) = N_Selected_Component + and then Nkind (Label2) = N_Selected_Component + then + return Same_Label (Prefix (Label1), Prefix (Label2)) and then + Same_Label (Selector_Name (Label1), Selector_Name (Label2)); + + elsif Nkind (Label1) = N_Designator + and then Nkind (Label2) = N_Defining_Program_Unit_Name + then + return Same_Label (Name (Label1), Name (Label2)) and then + Same_Label (Identifier (Label1), Defining_Identifier (Label2)); + + else + return False; + end if; + end Same_Label; + +end Endh; diff --git a/gcc/ada/par-labl.adb b/gcc/ada/par-labl.adb new file mode 100644 index 000000000..8520292ec --- /dev/null +++ b/gcc/ada/par-labl.adb @@ -0,0 +1,541 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . L A B L -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +separate (Par) +procedure Labl is + Enclosing_Body_Or_Block : Node_Id; + -- Innermost enclosing body or block statement + + Label_Decl_Node : Node_Id; + -- Implicit label declaration node + + Defining_Ident_Node : Node_Id; + -- Defining identifier node for implicit label declaration + + Next_Label_Elmt : Elmt_Id; + -- Next element on label element list + + Label_Node : Node_Id; + -- Next label node to process + + function Find_Enclosing_Body_Or_Block (N : Node_Id) return Node_Id; + -- Find the innermost body or block that encloses N + + function Find_Enclosing_Body (N : Node_Id) return Node_Id; + -- Find the innermost body that encloses N + + procedure Check_Distinct_Labels; + -- Checks the rule in RM-5.1(11), which requires distinct identifiers + -- for all the labels in a given body. + + procedure Find_Natural_Loops; + -- Recognizes loops created by backward gotos, and rewrites the + -- corresponding statements into a proper loop, for optimization + -- purposes (for example, to control reclaiming local storage). + + --------------------------- + -- Check_Distinct_Labels -- + --------------------------- + + procedure Check_Distinct_Labels is + Label_Id : constant Node_Id := Identifier (Label_Node); + + Enclosing_Body : constant Node_Id := + Find_Enclosing_Body (Enclosing_Body_Or_Block); + -- Innermost enclosing body + + Next_Other_Label_Elmt : Elmt_Id := First_Elmt (Label_List); + -- Next element on label element list + + Other_Label : Node_Id; + -- Next label node to process + + begin + -- Loop through all the labels, and if we find some other label + -- (i.e. not Label_Node) that has the same identifier, + -- and whose innermost enclosing body is the same, + -- then we have an error. + + -- Note that in the worst case, this is quadratic in the number + -- of labels. However, labels are not all that common, and this + -- is only called for explicit labels. + -- ???Nonetheless, the efficiency could be improved. For example, + -- call Labl for each body, rather than once per compilation. + + while Present (Next_Other_Label_Elmt) loop + Other_Label := Node (Next_Other_Label_Elmt); + + exit when Label_Node = Other_Label; + + if Chars (Label_Id) = Chars (Identifier (Other_Label)) + and then Enclosing_Body = Find_Enclosing_Body (Other_Label) + then + Error_Msg_Sloc := Sloc (Other_Label); + Error_Msg_N ("& conflicts with label#", Label_Id); + exit; + end if; + + Next_Elmt (Next_Other_Label_Elmt); + end loop; + end Check_Distinct_Labels; + + ------------------------- + -- Find_Enclosing_Body -- + ------------------------- + + function Find_Enclosing_Body (N : Node_Id) return Node_Id is + Result : Node_Id := N; + + begin + -- This is the same as Find_Enclosing_Body_Or_Block, except + -- that we skip block statements and accept statements, instead + -- of stopping at them. + + while Present (Result) + and then Nkind (Result) /= N_Entry_Body + and then Nkind (Result) /= N_Task_Body + and then Nkind (Result) /= N_Package_Body + and then Nkind (Result) /= N_Subprogram_Body + loop + Result := Parent (Result); + end loop; + + return Result; + end Find_Enclosing_Body; + + ---------------------------------- + -- Find_Enclosing_Body_Or_Block -- + ---------------------------------- + + function Find_Enclosing_Body_Or_Block (N : Node_Id) return Node_Id is + Result : Node_Id := Parent (N); + + begin + -- Climb up the parent chain until we find a body or block + + while Present (Result) + and then Nkind (Result) /= N_Accept_Statement + and then Nkind (Result) /= N_Entry_Body + and then Nkind (Result) /= N_Task_Body + and then Nkind (Result) /= N_Package_Body + and then Nkind (Result) /= N_Subprogram_Body + and then Nkind (Result) /= N_Block_Statement + loop + Result := Parent (Result); + end loop; + + return Result; + end Find_Enclosing_Body_Or_Block; + + ------------------------ + -- Find_Natural_Loops -- + ------------------------ + + procedure Find_Natural_Loops is + Node_List : constant Elist_Id := New_Elmt_List; + N : Elmt_Id; + Succ : Elmt_Id; + + function Goto_Id (Goto_Node : Node_Id) return Name_Id; + -- Find Name_Id of goto statement, which may be an expanded name + + function Matches + (Label_Node : Node_Id; + Goto_Node : Node_Id) return Boolean; + -- A label and a goto are candidates for a loop if the names match, + -- and both nodes appear in the same body. In addition, both must + -- appear in the same statement list. If they are not in the same + -- statement list, the goto is from within an nested structure, and + -- the label is not a header. We ignore the case where the goto is + -- within a conditional structure, and capture only infinite loops. + + procedure Merge; + -- Merge labels and goto statements in order of increasing sloc value. + -- Discard labels of loop and block statements. + + procedure No_Header (N : Elmt_Id); + -- The label N is known not to be a loop header. Scan forward and + -- remove all subsequent gotos that may have this node as a target. + + procedure Process_Goto (N : Elmt_Id); + -- N is a forward jump. Scan forward and remove all subsequent gotos + -- that may have the same target, to preclude spurious loops. + + procedure Rewrite_As_Loop + (Loop_Header : Node_Id; + Loop_End : Node_Id); + -- Given a label and a backwards goto, rewrite intervening statements + -- as a loop. Remove the label from the node list, and rewrite the + -- goto with the body of the new loop. + + procedure Try_Loop (N : Elmt_Id); + -- N is a label that may be a loop header. Scan forward to find some + -- backwards goto with which to make a loop. Do nothing if there is + -- an intervening label that is not part of a loop, or more than one + -- goto with this target. + + ------------- + -- Goto_Id -- + ------------- + + function Goto_Id (Goto_Node : Node_Id) return Name_Id is + begin + if Nkind (Name (Goto_Node)) = N_Identifier then + return Chars (Name (Goto_Node)); + + elsif Nkind (Name (Goto_Node)) = N_Selected_Component then + return Chars (Selector_Name (Name (Goto_Node))); + else + + -- In case of error, return Id that can't match anything + + return Name_Null; + end if; + end Goto_Id; + + ------------- + -- Matches -- + ------------- + + function Matches + (Label_Node : Node_Id; + Goto_Node : Node_Id) return Boolean + is + begin + return Chars (Identifier (Label_Node)) = Goto_Id (Goto_Node) + and then Find_Enclosing_Body (Label_Node) = + Find_Enclosing_Body (Goto_Node); + end Matches; + + ----------- + -- Merge -- + ----------- + + procedure Merge is + L1 : Elmt_Id; + G1 : Elmt_Id; + + begin + L1 := First_Elmt (Label_List); + G1 := First_Elmt (Goto_List); + + while Present (L1) + and then Present (G1) + loop + if Sloc (Node (L1)) < Sloc (Node (G1)) then + + -- Optimization: remove labels of loops and blocks, which + -- play no role in what follows. + + if Nkind (Node (L1)) /= N_Loop_Statement + and then Nkind (Node (L1)) /= N_Block_Statement + then + Append_Elmt (Node (L1), Node_List); + end if; + + Next_Elmt (L1); + + else + Append_Elmt (Node (G1), Node_List); + Next_Elmt (G1); + end if; + end loop; + + while Present (L1) loop + Append_Elmt (Node (L1), Node_List); + Next_Elmt (L1); + end loop; + + while Present (G1) loop + Append_Elmt (Node (G1), Node_List); + Next_Elmt (G1); + end loop; + end Merge; + + --------------- + -- No_Header -- + --------------- + + procedure No_Header (N : Elmt_Id) is + S1, S2 : Elmt_Id; + + begin + S1 := Next_Elmt (N); + while Present (S1) loop + S2 := Next_Elmt (S1); + if Nkind (Node (S1)) = N_Goto_Statement + and then Matches (Node (N), Node (S1)) + then + Remove_Elmt (Node_List, S1); + end if; + + S1 := S2; + end loop; + end No_Header; + + ------------------ + -- Process_Goto -- + ------------------ + + procedure Process_Goto (N : Elmt_Id) is + Goto1 : constant Node_Id := Node (N); + Goto2 : Node_Id; + S, S1 : Elmt_Id; + + begin + S := Next_Elmt (N); + + while Present (S) loop + S1 := Next_Elmt (S); + Goto2 := Node (S); + + if Nkind (Goto2) = N_Goto_Statement + and then Goto_Id (Goto1) = Goto_Id (Goto2) + and then Find_Enclosing_Body (Goto1) = + Find_Enclosing_Body (Goto2) + then + + -- Goto2 may have the same target, remove it from + -- consideration. + + Remove_Elmt (Node_List, S); + end if; + + S := S1; + end loop; + end Process_Goto; + + --------------------- + -- Rewrite_As_Loop -- + --------------------- + + procedure Rewrite_As_Loop + (Loop_Header : Node_Id; + Loop_End : Node_Id) + is + Loop_Body : constant List_Id := New_List; + Loop_Stmt : constant Node_Id := + New_Node (N_Loop_Statement, Sloc (Loop_Header)); + Stat : Node_Id; + Next_Stat : Node_Id; + begin + Stat := Next (Loop_Header); + while Stat /= Loop_End loop + Next_Stat := Next (Stat); + Remove (Stat); + Append (Stat, Loop_Body); + Stat := Next_Stat; + end loop; + + Set_Statements (Loop_Stmt, Loop_Body); + Set_Identifier (Loop_Stmt, Identifier (Loop_Header)); + + Remove (Loop_Header); + Rewrite (Loop_End, Loop_Stmt); + Error_Msg_N + ("code between label and backwards goto rewritten as loop?", + Loop_End); + end Rewrite_As_Loop; + + -------------- + -- Try_Loop -- + -------------- + + procedure Try_Loop (N : Elmt_Id) is + Source : Elmt_Id; + Found : Boolean := False; + S1 : Elmt_Id; + + begin + S1 := Next_Elmt (N); + while Present (S1) loop + if Nkind (Node (S1)) = N_Goto_Statement + and then Matches (Node (N), Node (S1)) + then + if not Found then + + -- If the label and the goto are both in the same statement + -- list, then we've found a loop. Note that labels and goto + -- statements are always part of some list, so In_Same_List + -- always makes sense. + + if In_Same_List (Node (N), Node (S1)) then + Source := S1; + Found := True; + + -- The goto is within some nested structure + + else + No_Header (N); + return; + end if; + + else + -- More than one goto with the same target + + No_Header (N); + return; + end if; + + elsif Nkind (Node (S1)) = N_Label + and then not Found + then + -- Intervening label before possible end of loop. Current + -- label is not a candidate. This is conservative, because + -- the label might not be the target of any jumps, but not + -- worth dealing with useless labels! + + No_Header (N); + return; + + else + -- If the node is a loop_statement, it corresponds to a + -- label-goto pair rewritten as a loop. Continue forward scan. + + null; + end if; + + Next_Elmt (S1); + end loop; + + if Found then + Rewrite_As_Loop (Node (N), Node (Source)); + Remove_Elmt (Node_List, N); + Remove_Elmt (Node_List, Source); + end if; + end Try_Loop; + + begin + -- Start of processing for Find_Natural_Loops + + Merge; + + N := First_Elmt (Node_List); + while Present (N) loop + Succ := Next_Elmt (N); + + if Nkind (Node (N)) = N_Label then + if No (Succ) then + exit; + + elsif Nkind (Node (Succ)) = N_Label then + Try_Loop (Succ); + + -- If a loop was found, the label has been removed, and + -- the following goto rewritten as the loop body. + + Succ := Next_Elmt (N); + + if Nkind (Node (Succ)) = N_Label then + + -- Following label was not removed, so current label + -- is not a candidate header. + + No_Header (N); + + else + + -- Following label was part of inner loop. Current + -- label is still a candidate. + + Try_Loop (N); + Succ := Next_Elmt (N); + end if; + + elsif Nkind (Node (Succ)) = N_Goto_Statement then + Try_Loop (N); + Succ := Next_Elmt (N); + end if; + + elsif Nkind (Node (N)) = N_Goto_Statement then + Process_Goto (N); + Succ := Next_Elmt (N); + end if; + + N := Succ; + end loop; + end Find_Natural_Loops; + +-- Start of processing for Par.Labl + +begin + Next_Label_Elmt := First_Elmt (Label_List); + while Present (Next_Label_Elmt) loop + Label_Node := Node (Next_Label_Elmt); + + if not Comes_From_Source (Label_Node) then + goto Next_Label; + end if; + + -- Find the innermost enclosing body or block, which is where + -- we need to implicitly declare this label + + Enclosing_Body_Or_Block := Find_Enclosing_Body_Or_Block (Label_Node); + + -- If we didn't find a parent, then the label in question never got + -- hooked into a reasonable declarative part. This happens only in + -- error situations, and we simply ignore the entry (we aren't going + -- to get into the semantics in any case given the error). + + if Present (Enclosing_Body_Or_Block) then + Check_Distinct_Labels; + + -- Now create the implicit label declaration node and its + -- corresponding defining identifier. Note that the defining + -- occurrence of a label is the implicit label declaration that + -- we are creating. The label itself is an applied occurrence. + + Label_Decl_Node := + New_Node (N_Implicit_Label_Declaration, Sloc (Label_Node)); + Defining_Ident_Node := + New_Entity (N_Defining_Identifier, Sloc (Identifier (Label_Node))); + Set_Chars (Defining_Ident_Node, Chars (Identifier (Label_Node))); + Set_Defining_Identifier (Label_Decl_Node, Defining_Ident_Node); + Set_Label_Construct (Label_Decl_Node, Label_Node); + + -- The following makes sure that Comes_From_Source is appropriately + -- set for the entity, depending on whether the label appeared in + -- the source explicitly or not. + + Set_Comes_From_Source + (Defining_Ident_Node, Comes_From_Source (Identifier (Label_Node))); + + -- Now attach the implicit label declaration to the appropriate + -- declarative region, creating a declaration list if none exists + + if No (Declarations (Enclosing_Body_Or_Block)) then + Set_Declarations (Enclosing_Body_Or_Block, New_List); + end if; + + Append (Label_Decl_Node, Declarations (Enclosing_Body_Or_Block)); + end if; + + <> + Next_Elmt (Next_Label_Elmt); + end loop; + + Find_Natural_Loops; + +end Labl; diff --git a/gcc/ada/par-load.adb b/gcc/ada/par-load.adb new file mode 100644 index 000000000..e30ffc02a --- /dev/null +++ b/gcc/ada/par-load.adb @@ -0,0 +1,475 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . L O A D -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- The Par.Load procedure loads all units that are definitely required before +-- it makes any sense at all to proceed with semantic analysis, including +-- with'ed units, corresponding specs for bodies, parents of child specs, +-- and parents of subunits. All these units are loaded and pointers installed +-- in the tree as described in the spec of package Lib. + +with Fname.UF; use Fname.UF; +with Lib.Load; use Lib.Load; +with Namet.Sp; use Namet.Sp; +with Uname; use Uname; +with Osint; use Osint; +with Sinput.L; use Sinput.L; +with Stylesw; use Stylesw; +with Validsw; use Validsw; + +with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; + +separate (Par) +procedure Load is + + File_Name : File_Name_Type; + -- Name of file for current unit, derived from unit name + + Cur_Unum : constant Unit_Number_Type := Current_Source_Unit; + -- Unit number of unit that we just finished parsing. Note that we need + -- to capture this, because Source_Unit will change as we parse new + -- source files in the multiple main source file case. + + Curunit : constant Node_Id := Cunit (Cur_Unum); + -- Compilation unit node for current compilation unit + + Loc : Source_Ptr := Sloc (Curunit); + -- Source location for compilation unit node + + Save_Style_Check : Boolean; + Save_Style_Checks : Style_Check_Options; + -- Save style check so it can be restored later + + Save_Validity_Check : Boolean; + Save_Validity_Checks : Validity_Check_Options; + -- Save validity check so it can be restored later + + With_Cunit : Node_Id; + -- Compilation unit node for withed unit + + Context_Node : Node_Id; + -- Next node in context items list + + With_Node : Node_Id; + -- N_With_Clause node + + Spec_Name : Unit_Name_Type; + -- Unit name of required spec + + Body_Name : Unit_Name_Type; + -- Unit name of corresponding body + + Unum : Unit_Number_Type; + -- Unit number of loaded unit + + Limited_With_Found : Boolean := False; + -- We load the context items in two rounds: the first round handles normal + -- withed units and the second round handles Ada 2005 limited-withed units. + -- This is required to allow the low-level circuitry that detects circular + -- dependencies of units the correct notification of errors (see comment + -- bellow). This variable is used to indicate that the second round is + -- required. + + function Same_File_Name_Except_For_Case + (Expected_File_Name : File_Name_Type; + Actual_File_Name : File_Name_Type) return Boolean; + -- Given an actual file name and an expected file name (the latter being + -- derived from the unit name), determine if they are the same except for + -- possibly different casing of letters. + + ------------------------------------ + -- Same_File_Name_Except_For_Case -- + ------------------------------------ + + function Same_File_Name_Except_For_Case + (Expected_File_Name : File_Name_Type; + Actual_File_Name : File_Name_Type) return Boolean + is + begin + Get_Name_String (Actual_File_Name); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + + declare + Lower_Case_Actual_File_Name : String (1 .. Name_Len); + + begin + Lower_Case_Actual_File_Name := Name_Buffer (1 .. Name_Len); + Get_Name_String (Expected_File_Name); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + return Lower_Case_Actual_File_Name = Name_Buffer (1 .. Name_Len); + end; + + end Same_File_Name_Except_For_Case; + +-- Start of processing for Load + +begin + -- Don't do any loads if we already had a fatal error + + if Fatal_Error (Cur_Unum) then + return; + end if; + + Save_Style_Check_Options (Save_Style_Checks); + Save_Style_Check := Opt.Style_Check; + + Save_Validity_Check_Options (Save_Validity_Checks); + Save_Validity_Check := Opt.Validity_Checks_On; + + -- If main unit, set Main_Unit_Entity (this will get overwritten if + -- the main unit has a separate spec, that happens later on in Load) + + if Cur_Unum = Main_Unit then + Main_Unit_Entity := Cunit_Entity (Main_Unit); + end if; + + -- If we have no unit name, things are seriously messed up by previous + -- errors, and we should not try to continue compilation. + + if Unit_Name (Cur_Unum) = No_Unit_Name then + raise Unrecoverable_Error; + end if; + + -- Next step, make sure that the unit name matches the file name + -- and issue a warning message if not. We only output this for the + -- main unit, since for other units it is more serious and is + -- caught in a separate test below. We also inhibit the message in + -- multiple unit per file mode, because in this case the relation + -- between file name and unit name is broken. + + File_Name := + Get_File_Name + (Unit_Name (Cur_Unum), + Subunit => Nkind (Unit (Cunit (Cur_Unum))) = N_Subunit); + + if Cur_Unum = Main_Unit + and then Multiple_Unit_Index = 0 + and then File_Name /= Unit_File_Name (Cur_Unum) + and then (File_Names_Case_Sensitive + or not Same_File_Name_Except_For_Case + (File_Name, Unit_File_Name (Cur_Unum))) + then + Error_Msg_File_1 := File_Name; + Error_Msg + ("?file name does not match unit name, should be{", Sloc (Curunit)); + end if; + + -- For units other than the main unit, the expected unit name is set and + -- must be the same as the actual unit name, or we are in big trouble, and + -- abandon the compilation since there are situations where this really + -- gets us into bad trouble (e.g. some subunit situations). + + if Cur_Unum /= Main_Unit + and then Expected_Unit (Cur_Unum) /= Unit_Name (Cur_Unum) + then + Loc := Error_Location (Cur_Unum); + Error_Msg_File_1 := Unit_File_Name (Cur_Unum); + Get_Name_String (Error_Msg_File_1); + + -- Check for predefined file case + + if Name_Len > 1 + and then Name_Buffer (2) = '-' + and then (Name_Buffer (1) = 'a' + or else + Name_Buffer (1) = 's' + or else + Name_Buffer (1) = 'i' + or else + Name_Buffer (1) = 'g') + then + declare + Expect_Name : constant Unit_Name_Type := Expected_Unit (Cur_Unum); + Actual_Name : constant Unit_Name_Type := Unit_Name (Cur_Unum); + + begin + Error_Msg_Unit_1 := Expect_Name; + Error_Msg -- CODEFIX + ("$$ is not a predefined library unit!", Loc); + + -- In the predefined file case, we know the user did not + -- construct their own package, but we got the wrong one. + -- This means that the name supplied by the user crunched + -- to something we recognized, but then the file did not + -- contain the unit expected. Most likely this is due to + -- a misspelling, e.g. + + -- with Ada.Calender; + + -- This crunches to a-calend, which indeed contains the unit + -- Ada.Calendar, and we can diagnose the misspelling. This + -- is a simple heuristic, but it catches many common cases + -- of misspelling of predefined unit names without needing + -- a full list of them. + + -- Before actually issuing the message, we will check that the + -- unit name is indeed a plausible misspelling of the one we got. + + if Is_Bad_Spelling_Of + (Name_Id (Expect_Name), Name_Id (Actual_Name)) + then + Error_Msg_Unit_1 := Actual_Name; + Error_Msg -- CODEFIX + ("possible misspelling of $$!", Loc); + end if; + end; + + -- Non-predefined file name case. In this case we generate a message + -- and then we quit, because we are in big trouble, and if we try + -- to continue compilation, we get into some nasty situations + -- (for example in some subunit cases). + + else + Error_Msg ("file { does not contain expected unit!", Loc); + Error_Msg_Unit_1 := Expected_Unit (Cur_Unum); + Error_Msg ("\\expected unit $!", Loc); + Error_Msg_Unit_1 := Unit_Name (Cur_Unum); + Error_Msg ("\\found unit $!", Loc); + end if; + + -- In both cases, remove the unit if it is the last unit (which it + -- normally (always?) will be) so that it is out of the way later. + + Remove_Unit (Cur_Unum); + end if; + + -- If current unit is a body, load its corresponding spec + + if Nkind (Unit (Curunit)) = N_Package_Body + or else Nkind (Unit (Curunit)) = N_Subprogram_Body + then + Spec_Name := Get_Spec_Name (Unit_Name (Cur_Unum)); + Unum := + Load_Unit + (Load_Name => Spec_Name, + Required => False, + Subunit => False, + Error_Node => Curunit, + Corr_Body => Cur_Unum, + PMES => (Cur_Unum = Main_Unit)); + + -- If we successfully load the unit, then set the spec/body pointers. + -- Once again note that if the loaded unit has a fatal error, Load will + -- have set our Fatal_Error flag to propagate this condition. + + if Unum /= No_Unit then + Set_Library_Unit (Curunit, Cunit (Unum)); + Set_Library_Unit (Cunit (Unum), Curunit); + + -- If this is a separate spec for the main unit, then we reset + -- Main_Unit_Entity to point to the entity for this separate spec + -- and this is also where we generate the SCO's for this spec. + + if Cur_Unum = Main_Unit then + Main_Unit_Entity := Cunit_Entity (Unum); + + if Generate_SCO then + SCO_Record (Unum); + end if; + end if; + + -- If we don't find the spec, then if we have a subprogram body, we + -- are still OK, we just have a case of a body acting as its own spec + + elsif Nkind (Unit (Curunit)) = N_Subprogram_Body then + Set_Acts_As_Spec (Curunit, True); + Set_Library_Unit (Curunit, Curunit); + + -- Otherwise we do have an error, repeat the load request for the spec + -- with Required set True to generate an appropriate error message. + + else + Unum := + Load_Unit + (Load_Name => Spec_Name, + Required => True, + Subunit => False, + Error_Node => Curunit); + return; + end if; + + -- If current unit is a child unit spec, load its parent. If the child unit + -- is loaded through a limited with, the parent must be as well. + + elsif Nkind (Unit (Curunit)) = N_Package_Declaration + or else Nkind (Unit (Curunit)) = N_Subprogram_Declaration + or else Nkind (Unit (Curunit)) in N_Generic_Declaration + or else Nkind (Unit (Curunit)) in N_Generic_Instantiation + or else Nkind (Unit (Curunit)) in N_Renaming_Declaration + then + -- Turn style and validity checks off for parent unit + + if not GNAT_Mode then + Reset_Style_Check_Options; + Reset_Validity_Check_Options; + end if; + + Spec_Name := Get_Parent_Spec_Name (Unit_Name (Cur_Unum)); + + if Spec_Name /= No_Unit_Name then + Unum := + Load_Unit + (Load_Name => Spec_Name, + Required => True, + Subunit => False, + Error_Node => Curunit); + + if Unum /= No_Unit then + Set_Parent_Spec (Unit (Curunit), Cunit (Unum)); + end if; + end if; + + -- If current unit is a subunit, then load its parent body + + elsif Nkind (Unit (Curunit)) = N_Subunit then + Body_Name := Get_Parent_Body_Name (Unit_Name (Cur_Unum)); + Unum := + Load_Unit + (Load_Name => Body_Name, + Required => True, + Subunit => False, + Error_Node => Name (Unit (Curunit))); + + if Unum /= No_Unit then + Set_Library_Unit (Curunit, Cunit (Unum)); + end if; + end if; + + -- Now we load with'ed units, with style/validity checks turned off + + if not GNAT_Mode then + Reset_Style_Check_Options; + Reset_Validity_Check_Options; + end if; + + -- Load the context items in two rounds: the first round handles normal + -- withed units and the second round handles Ada 2005 limited-withed units. + -- This is required to allow the low-level circuitry that detects circular + -- dependencies of units the correct notification of the following error: + + -- limited with D; + -- with D; with C; + -- package C is ... package D is ... + + for Round in 1 .. 2 loop + Context_Node := First (Context_Items (Curunit)); + while Present (Context_Node) loop + + -- During the first round we check if there is some limited-with + -- context clause; otherwise the second round will be skipped + + if Nkind (Context_Node) = N_With_Clause + and then Round = 1 + and then Limited_Present (Context_Node) + then + Limited_With_Found := True; + end if; + + if Nkind (Context_Node) = N_With_Clause + and then ((Round = 1 and then not Limited_Present (Context_Node)) + or else + (Round = 2 and then Limited_Present (Context_Node))) + then + With_Node := Context_Node; + Spec_Name := Get_Unit_Name (With_Node); + + Unum := + Load_Unit + (Load_Name => Spec_Name, + Required => False, + Subunit => False, + Error_Node => With_Node, + Renamings => True, + With_Node => Context_Node); + + -- If we find the unit, then set spec pointer in the N_With_Clause + -- to point to the compilation unit for the spec. Remember that + -- the Load routine itself sets our Fatal_Error flag if the loaded + -- unit gets a fatal error, so we don't need to worry about that. + + if Unum /= No_Unit then + Set_Library_Unit (With_Node, Cunit (Unum)); + + -- If the spec isn't found, then try finding the corresponding + -- body, since it is possible that we have a subprogram body + -- that is acting as a spec (since no spec is present). + + else + Body_Name := Get_Body_Name (Spec_Name); + Unum := + Load_Unit + (Load_Name => Body_Name, + Required => False, + Subunit => False, + Error_Node => With_Node, + Renamings => True); + + -- If we got a subprogram body, then mark that we are using + -- the body as a spec in the file table, and set the spec + -- pointer in the N_With_Clause to point to the body entity. + + if Unum /= No_Unit + and then Nkind (Unit (Cunit (Unum))) = N_Subprogram_Body + then + With_Cunit := Cunit (Unum); + Set_Library_Unit (With_Node, With_Cunit); + Set_Acts_As_Spec (With_Cunit, True); + Set_Library_Unit (With_Cunit, With_Cunit); + + -- If we couldn't find the body, or if it wasn't a body spec + -- then we are in trouble. We make one more call to Load to + -- require the spec. We know it will fail of course, the + -- purpose is to generate the required error message (we prefer + -- that this message refer to the missing spec, not the body) + + else + Unum := + Load_Unit + (Load_Name => Spec_Name, + Required => True, + Subunit => False, + Error_Node => With_Node, + Renamings => True); + + -- Here we create a dummy package unit for the missing unit + + Unum := Create_Dummy_Package_Unit (With_Node, Spec_Name); + Set_Library_Unit (With_Node, Cunit (Unum)); + end if; + end if; + end if; + + Next (Context_Node); + end loop; + + exit when not Limited_With_Found; + end loop; + + -- Restore style/validity check mode for main unit + + Set_Style_Check_Options (Save_Style_Checks); + Opt.Style_Check := Save_Style_Check; + Set_Validity_Check_Options (Save_Validity_Checks); + Opt.Validity_Checks_On := Save_Validity_Check; +end Load; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb new file mode 100644 index 000000000..8ddd2209a --- /dev/null +++ b/gcc/ada/par-prag.adb @@ -0,0 +1,1286 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . P R A G -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Generally the parser checks the basic syntax of pragmas, but does not +-- do specialized syntax checks for individual pragmas, these are deferred +-- to semantic analysis time (see unit Sem_Prag). There are some pragmas +-- which require recognition and either partial or complete processing +-- during parsing, and this unit performs this required processing. + +with Fname.UF; use Fname.UF; +with Osint; use Osint; +with Rident; use Rident; +with Restrict; use Restrict; +with Stringt; use Stringt; +with Stylesw; use Stylesw; +with Uintp; use Uintp; +with Uname; use Uname; + +with System.WCh_Con; use System.WCh_Con; + +separate (Par) + +function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is + Prag_Name : constant Name_Id := Pragma_Name (Pragma_Node); + Prag_Id : constant Pragma_Id := Get_Pragma_Id (Prag_Name); + Pragma_Sloc : constant Source_Ptr := Sloc (Pragma_Node); + Arg_Count : Nat; + Arg_Node : Node_Id; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Arg1 return Node_Id; + function Arg2 return Node_Id; + function Arg3 return Node_Id; + -- Obtain specified Pragma_Argument_Association. It is allowable to call + -- the routine for the argument one past the last present argument, but + -- that is the only case in which a non-present argument can be referenced. + + procedure Check_Arg_Count (Required : Int); + -- Check argument count for pragma = Required. + -- If not give error and raise Error_Resync. + + procedure Check_Arg_Is_String_Literal (Arg : Node_Id); + -- Check the expression of the specified argument to make sure that it + -- is a string literal. If not give error and raise Error_Resync. + + procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id); + -- Check the expression of the specified argument to make sure that it + -- is an identifier which is either ON or OFF, and if not, then issue + -- an error message and raise Error_Resync. + + procedure Check_No_Identifier (Arg : Node_Id); + -- Checks that the given argument does not have an identifier. If + -- an identifier is present, then an error message is issued, and + -- Error_Resync is raised. + + procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id); + -- Checks if the given argument has an identifier, and if so, requires + -- it to match the given identifier name. If there is a non-matching + -- identifier, then an error message is given and Error_Resync raised. + + procedure Check_Required_Identifier (Arg : Node_Id; Id : Name_Id); + -- Same as Check_Optional_Identifier, except that the name is required + -- to be present and to match the given Id value. + + procedure Process_Restrictions_Or_Restriction_Warnings; + -- Common processing for Restrictions and Restriction_Warnings pragmas. + -- This routine only processes the case of No_Obsolescent_Features, + -- which is the only restriction that has syntactic effects. No general + -- error checking is done, since this will be done in Sem_Prag. The + -- other case processed is pragma Restrictions No_Dependence, since + -- otherwise this is done too late. + + ---------- + -- Arg1 -- + ---------- + + function Arg1 return Node_Id is + begin + return First (Pragma_Argument_Associations (Pragma_Node)); + end Arg1; + + ---------- + -- Arg2 -- + ---------- + + function Arg2 return Node_Id is + begin + return Next (Arg1); + end Arg2; + + ---------- + -- Arg3 -- + ---------- + + function Arg3 return Node_Id is + begin + return Next (Arg2); + end Arg3; + + --------------------- + -- Check_Arg_Count -- + --------------------- + + procedure Check_Arg_Count (Required : Int) is + begin + if Arg_Count /= Required then + Error_Msg ("wrong number of arguments for pragma%", Pragma_Sloc); + raise Error_Resync; + end if; + end Check_Arg_Count; + + ---------------------------- + -- Check_Arg_Is_On_Or_Off -- + ---------------------------- + + procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id) is + Argx : constant Node_Id := Expression (Arg); + + begin + if Nkind (Expression (Arg)) /= N_Identifier + or else (Chars (Argx) /= Name_On + and then + Chars (Argx) /= Name_Off) + then + Error_Msg_Name_2 := Name_On; + Error_Msg_Name_3 := Name_Off; + + Error_Msg ("argument for pragma% must be% or%", Sloc (Argx)); + raise Error_Resync; + end if; + end Check_Arg_Is_On_Or_Off; + + --------------------------------- + -- Check_Arg_Is_String_Literal -- + --------------------------------- + + procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is + begin + if Nkind (Expression (Arg)) /= N_String_Literal then + Error_Msg + ("argument for pragma% must be string literal", + Sloc (Expression (Arg))); + raise Error_Resync; + end if; + end Check_Arg_Is_String_Literal; + + ------------------------- + -- Check_No_Identifier -- + ------------------------- + + procedure Check_No_Identifier (Arg : Node_Id) is + begin + if Chars (Arg) /= No_Name then + Error_Msg_N ("pragma% does not permit named arguments", Arg); + raise Error_Resync; + end if; + end Check_No_Identifier; + + ------------------------------- + -- Check_Optional_Identifier -- + ------------------------------- + + procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is + begin + if Present (Arg) and then Chars (Arg) /= No_Name then + if Chars (Arg) /= Id then + Error_Msg_Name_2 := Id; + Error_Msg_N ("pragma% argument expects identifier%", Arg); + end if; + end if; + end Check_Optional_Identifier; + + ------------------------------- + -- Check_Required_Identifier -- + ------------------------------- + + procedure Check_Required_Identifier (Arg : Node_Id; Id : Name_Id) is + begin + if Chars (Arg) /= Id then + Error_Msg_Name_2 := Id; + Error_Msg_N ("pragma% argument must have identifier%", Arg); + end if; + end Check_Required_Identifier; + + -------------------------------------------------- + -- Process_Restrictions_Or_Restriction_Warnings -- + -------------------------------------------------- + + procedure Process_Restrictions_Or_Restriction_Warnings is + Arg : Node_Id; + Id : Name_Id; + Expr : Node_Id; + + begin + Arg := Arg1; + while Present (Arg) loop + Id := Chars (Arg); + Expr := Expression (Arg); + + if Id = No_Name + and then Nkind (Expr) = N_Identifier + and then Get_Restriction_Id (Chars (Expr)) = No_Obsolescent_Features + then + Set_Restriction (No_Obsolescent_Features, Pragma_Node); + Restriction_Warnings (No_Obsolescent_Features) := + Prag_Id = Pragma_Restriction_Warnings; + + elsif Id = Name_No_Dependence then + Set_Restriction_No_Dependence + (Unit => Expr, + Warn => Prag_Id = Pragma_Restriction_Warnings + or else Treat_Restrictions_As_Warnings); + end if; + + Next (Arg); + end loop; + end Process_Restrictions_Or_Restriction_Warnings; + +-- Start of processing for Prag + +begin + Error_Msg_Name_1 := Prag_Name; + + -- Ignore unrecognized pragma. We let Sem post the warning for this, since + -- it is a semantic error, not a syntactic one (we have already checked + -- the syntax for the unrecognized pragma as required by (RM 2.8(11)). + + if Prag_Id = Unknown_Pragma then + return Pragma_Node; + end if; + + -- Count number of arguments. This loop also checks if any of the arguments + -- are Error, indicating a syntax error as they were parsed. If so, we + -- simply return, because we get into trouble with cascaded errors if we + -- try to perform our error checks on junk arguments. + + Arg_Count := 0; + + if Present (Pragma_Argument_Associations (Pragma_Node)) then + Arg_Node := Arg1; + while Arg_Node /= Empty loop + Arg_Count := Arg_Count + 1; + + if Expression (Arg_Node) = Error then + return Error; + end if; + + Next (Arg_Node); + end loop; + end if; + + -- Remaining processing is pragma dependent + + case Prag_Id is + + ------------ + -- Ada_83 -- + ------------ + + -- This pragma must be processed at parse time, since we want to set + -- the Ada version properly at parse time to recognize the appropriate + -- Ada version syntax. + + when Pragma_Ada_83 => + Ada_Version := Ada_83; + Ada_Version_Explicit := Ada_Version; + + ------------ + -- Ada_95 -- + ------------ + + -- This pragma must be processed at parse time, since we want to set + -- the Ada version properly at parse time to recognize the appropriate + -- Ada version syntax. + + when Pragma_Ada_95 => + Ada_Version := Ada_95; + Ada_Version_Explicit := Ada_Version; + + --------------------- + -- Ada_05/Ada_2005 -- + --------------------- + + -- These pragmas must be processed at parse time, since we want to set + -- the Ada version properly at parse time to recognize the appropriate + -- Ada version syntax. However, it is only the zero argument form that + -- must be processed at parse time. + + when Pragma_Ada_05 | Pragma_Ada_2005 => + if Arg_Count = 0 then + Ada_Version := Ada_2005; + Ada_Version_Explicit := Ada_2005; + end if; + + --------------------- + -- Ada_12/Ada_2012 -- + --------------------- + + -- These pragmas must be processed at parse time, since we want to set + -- the Ada version properly at parse time to recognize the appropriate + -- Ada version syntax. However, it is only the zero argument form that + -- must be processed at parse time. + + when Pragma_Ada_12 | Pragma_Ada_2012 => + if Arg_Count = 0 then + Ada_Version := Ada_2012; + Ada_Version_Explicit := Ada_2012; + end if; + + ----------- + -- Debug -- + ----------- + + -- pragma Debug (PROCEDURE_CALL_STATEMENT); + + -- This has to be processed by the parser because of the very peculiar + -- form of the second parameter, which is syntactically from a formal + -- point of view a function call (since it must be an expression), but + -- semantically we treat it as a procedure call (which has exactly the + -- same syntactic form, so that's why we can get away with this!) + + when Pragma_Debug => Debug : declare + Expr : Node_Id; + + begin + if Arg_Count = 2 then + Check_No_Identifier (Arg1); + Check_No_Identifier (Arg2); + Expr := New_Copy (Expression (Arg2)); + + else + Check_Arg_Count (1); + Check_No_Identifier (Arg1); + Expr := New_Copy (Expression (Arg1)); + end if; + + if Nkind (Expr) /= N_Indexed_Component + and then Nkind (Expr) /= N_Function_Call + and then Nkind (Expr) /= N_Identifier + and then Nkind (Expr) /= N_Selected_Component + then + Error_Msg + ("argument of pragma% is not procedure call", Sloc (Expr)); + raise Error_Resync; + else + Set_Debug_Statement + (Pragma_Node, P_Statement_Name (Expr)); + end if; + end Debug; + + ------------------------------- + -- Extensions_Allowed (GNAT) -- + ------------------------------- + + -- pragma Extensions_Allowed (Off | On) + + -- The processing for pragma Extensions_Allowed must be done at + -- parse time, since extensions mode may affect what is accepted. + + when Pragma_Extensions_Allowed => + Check_Arg_Count (1); + Check_No_Identifier (Arg1); + Check_Arg_Is_On_Or_Off (Arg1); + + if Chars (Expression (Arg1)) = Name_On then + Extensions_Allowed := True; + Ada_Version := Ada_2012; + else + Extensions_Allowed := False; + Ada_Version := Ada_Version_Explicit; + end if; + + ---------------- + -- List (2.8) -- + ---------------- + + -- pragma List (Off | On) + + -- The processing for pragma List must be done at parse time, + -- since a listing can be generated in parse only mode. + + when Pragma_List => + Check_Arg_Count (1); + Check_No_Identifier (Arg1); + Check_Arg_Is_On_Or_Off (Arg1); + + -- We unconditionally make a List_On entry for the pragma, so that + -- in the List (Off) case, the pragma will print even in a region + -- of code with listing turned off (this is required!) + + List_Pragmas.Increment_Last; + List_Pragmas.Table (List_Pragmas.Last) := + (Ptyp => List_On, Ploc => Sloc (Pragma_Node)); + + -- Now generate the list off entry for pragma List (Off) + + if Chars (Expression (Arg1)) = Name_Off then + List_Pragmas.Increment_Last; + List_Pragmas.Table (List_Pragmas.Last) := + (Ptyp => List_Off, Ploc => Semi); + end if; + + ---------------- + -- Page (2.8) -- + ---------------- + + -- pragma Page; + + -- Processing for this pragma must be done at parse time, since a + -- listing can be generated in parse only mode with semantics off. + + when Pragma_Page => + Check_Arg_Count (0); + List_Pragmas.Increment_Last; + List_Pragmas.Table (List_Pragmas.Last) := (Page, Semi); + + ------------------ + -- Restrictions -- + ------------------ + + -- pragma Restrictions (RESTRICTION {, RESTRICTION}); + + -- RESTRICTION ::= + -- restriction_IDENTIFIER + -- | restriction_parameter_IDENTIFIER => EXPRESSION + + -- We process the case of No_Obsolescent_Features, since this has + -- a syntactic effect that we need to detect at parse time (the use + -- of replacement characters such as colon for pound sign). + + when Pragma_Restrictions => + Process_Restrictions_Or_Restriction_Warnings; + + -------------------------- + -- Restriction_Warnings -- + -------------------------- + + -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION}); + + -- RESTRICTION ::= + -- restriction_IDENTIFIER + -- | restriction_parameter_IDENTIFIER => EXPRESSION + + -- See above comment for pragma Restrictions + + when Pragma_Restriction_Warnings => + Process_Restrictions_Or_Restriction_Warnings; + + ---------------------------------------------------------- + -- Source_File_Name and Source_File_Name_Project (GNAT) -- + ---------------------------------------------------------- + + -- These two pragmas have the same syntax and semantics. + -- There are five forms of these pragmas: + + -- pragma Source_File_Name[_Project] ( + -- [UNIT_NAME =>] unit_NAME, + -- BODY_FILE_NAME => STRING_LITERAL + -- [, [INDEX =>] INTEGER_LITERAL]); + + -- pragma Source_File_Name[_Project] ( + -- [UNIT_NAME =>] unit_NAME, + -- SPEC_FILE_NAME => STRING_LITERAL + -- [, [INDEX =>] INTEGER_LITERAL]); + + -- pragma Source_File_Name[_Project] ( + -- BODY_FILE_NAME => STRING_LITERAL + -- [, DOT_REPLACEMENT => STRING_LITERAL] + -- [, CASING => CASING_SPEC]); + + -- pragma Source_File_Name[_Project] ( + -- SPEC_FILE_NAME => STRING_LITERAL + -- [, DOT_REPLACEMENT => STRING_LITERAL] + -- [, CASING => CASING_SPEC]); + + -- pragma Source_File_Name[_Project] ( + -- SUBUNIT_FILE_NAME => STRING_LITERAL + -- [, DOT_REPLACEMENT => STRING_LITERAL] + -- [, CASING => CASING_SPEC]); + + -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase + + -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma + -- Source_File_Name (SFN), however their usage is exclusive: + -- SFN can only be used when no project file is used, while + -- SFNP can only be used when a project file is used. + + -- The Project Manager produces a configuration pragmas file that + -- is communicated to the compiler with -gnatec switch. This file + -- contains only SFNP pragmas (at least two for the default naming + -- scheme. As this configuration pragmas file is always the first + -- processed by the compiler, it prevents the use of pragmas SFN in + -- other config files when a project file is in use. + + -- Note: we process this during parsing, since we need to have the + -- source file names set well before the semantic analysis starts, + -- since we load the spec and with'ed packages before analysis. + + when Pragma_Source_File_Name | Pragma_Source_File_Name_Project => + Source_File_Name : declare + Unam : Unit_Name_Type; + Expr1 : Node_Id; + Pat : String_Ptr; + Typ : Character; + Dot : String_Ptr; + Cas : Casing_Type; + Nast : Nat; + Expr : Node_Id; + Index : Nat; + + function Get_Fname (Arg : Node_Id) return File_Name_Type; + -- Process file name from unit name form of pragma + + function Get_String_Argument (Arg : Node_Id) return String_Ptr; + -- Process string literal value from argument + + procedure Process_Casing (Arg : Node_Id); + -- Process Casing argument of pattern form of pragma + + procedure Process_Dot_Replacement (Arg : Node_Id); + -- Process Dot_Replacement argument of pattern form of pragma + + --------------- + -- Get_Fname -- + --------------- + + function Get_Fname (Arg : Node_Id) return File_Name_Type is + begin + String_To_Name_Buffer (Strval (Expression (Arg))); + + for J in 1 .. Name_Len loop + if Is_Directory_Separator (Name_Buffer (J)) then + Error_Msg + ("directory separator character not allowed", + Sloc (Expression (Arg)) + Source_Ptr (J)); + end if; + end loop; + + return Name_Find; + end Get_Fname; + + ------------------------- + -- Get_String_Argument -- + ------------------------- + + function Get_String_Argument (Arg : Node_Id) return String_Ptr is + Str : String_Id; + + begin + if Nkind (Expression (Arg)) /= N_String_Literal + and then + Nkind (Expression (Arg)) /= N_Operator_Symbol + then + Error_Msg_N + ("argument for pragma% must be string literal", Arg); + raise Error_Resync; + end if; + + Str := Strval (Expression (Arg)); + + -- Check string has no wide chars + + for J in 1 .. String_Length (Str) loop + if Get_String_Char (Str, J) > 255 then + Error_Msg + ("wide character not allowed in pattern for pragma%", + Sloc (Expression (Arg2)) + Text_Ptr (J) - 1); + end if; + end loop; + + -- Acquire string + + String_To_Name_Buffer (Str); + return new String'(Name_Buffer (1 .. Name_Len)); + end Get_String_Argument; + + -------------------- + -- Process_Casing -- + -------------------- + + procedure Process_Casing (Arg : Node_Id) is + Expr : constant Node_Id := Expression (Arg); + + begin + Check_Required_Identifier (Arg, Name_Casing); + + if Nkind (Expr) = N_Identifier then + if Chars (Expr) = Name_Lowercase then + Cas := All_Lower_Case; + return; + elsif Chars (Expr) = Name_Uppercase then + Cas := All_Upper_Case; + return; + elsif Chars (Expr) = Name_Mixedcase then + Cas := Mixed_Case; + return; + end if; + end if; + + Error_Msg_N + ("Casing argument for pragma% must be " & + "one of Mixedcase, Lowercase, Uppercase", + Arg); + end Process_Casing; + + ----------------------------- + -- Process_Dot_Replacement -- + ----------------------------- + + procedure Process_Dot_Replacement (Arg : Node_Id) is + begin + Check_Required_Identifier (Arg, Name_Dot_Replacement); + Dot := Get_String_Argument (Arg); + end Process_Dot_Replacement; + + -- Start of processing for Source_File_Name and + -- Source_File_Name_Project pragmas. + + begin + if Prag_Id = Pragma_Source_File_Name then + if Project_File_In_Use = In_Use then + Error_Msg + ("pragma Source_File_Name cannot be used " & + "with a project file", Pragma_Sloc); + + else + Project_File_In_Use := Not_In_Use; + end if; + + else + if Project_File_In_Use = Not_In_Use then + Error_Msg + ("pragma Source_File_Name_Project should only be used " & + "with a project file", Pragma_Sloc); + else + Project_File_In_Use := In_Use; + end if; + end if; + + -- We permit from 1 to 3 arguments + + if Arg_Count not in 1 .. 3 then + Check_Arg_Count (1); + end if; + + Expr1 := Expression (Arg1); + + -- If first argument is identifier or selected component, then + -- we have the specific file case of the Source_File_Name pragma, + -- and the first argument is a unit name. + + if Nkind (Expr1) = N_Identifier + or else + (Nkind (Expr1) = N_Selected_Component + and then + Nkind (Selector_Name (Expr1)) = N_Identifier) + then + if Nkind (Expr1) = N_Identifier + and then Chars (Expr1) = Name_System + then + Error_Msg_N + ("pragma Source_File_Name may not be used for System", + Arg1); + return Error; + end if; + + -- Process index argument if present + + if Arg_Count = 3 then + Expr := Expression (Arg3); + + if Nkind (Expr) /= N_Integer_Literal + or else not UI_Is_In_Int_Range (Intval (Expr)) + or else Intval (Expr) > 999 + or else Intval (Expr) <= 0 + then + Error_Msg + ("pragma% index must be integer literal" & + " in range 1 .. 999", Sloc (Expr)); + raise Error_Resync; + else + Index := UI_To_Int (Intval (Expr)); + end if; + + -- No index argument present + + else + Check_Arg_Count (2); + Index := 0; + end if; + + Check_Optional_Identifier (Arg1, Name_Unit_Name); + Unam := Get_Unit_Name (Expr1); + + Check_Arg_Is_String_Literal (Arg2); + + if Chars (Arg2) = Name_Spec_File_Name then + Set_File_Name + (Get_Spec_Name (Unam), Get_Fname (Arg2), Index); + + elsif Chars (Arg2) = Name_Body_File_Name then + Set_File_Name + (Unam, Get_Fname (Arg2), Index); + + else + Error_Msg_N + ("pragma% argument has incorrect identifier", Arg2); + return Pragma_Node; + end if; + + -- If the first argument is not an identifier, then we must have + -- the pattern form of the pragma, and the first argument must be + -- the pattern string with an appropriate name. + + else + if Chars (Arg1) = Name_Spec_File_Name then + Typ := 's'; + + elsif Chars (Arg1) = Name_Body_File_Name then + Typ := 'b'; + + elsif Chars (Arg1) = Name_Subunit_File_Name then + Typ := 'u'; + + elsif Chars (Arg1) = Name_Unit_Name then + Error_Msg_N + ("Unit_Name parameter for pragma% must be an identifier", + Arg1); + raise Error_Resync; + + else + Error_Msg_N + ("pragma% argument has incorrect identifier", Arg1); + raise Error_Resync; + end if; + + Pat := Get_String_Argument (Arg1); + + -- Check pattern has exactly one asterisk + + Nast := 0; + for J in Pat'Range loop + if Pat (J) = '*' then + Nast := Nast + 1; + end if; + end loop; + + if Nast /= 1 then + Error_Msg_N + ("file name pattern must have exactly one * character", + Arg1); + return Pragma_Node; + end if; + + -- Set defaults for Casing and Dot_Separator parameters + + Cas := All_Lower_Case; + Dot := new String'("."); + + -- Process second and third arguments if present + + if Arg_Count > 1 then + if Chars (Arg2) = Name_Casing then + Process_Casing (Arg2); + + if Arg_Count = 3 then + Process_Dot_Replacement (Arg3); + end if; + + else + Process_Dot_Replacement (Arg2); + + if Arg_Count = 3 then + Process_Casing (Arg3); + end if; + end if; + end if; + + Set_File_Name_Pattern (Pat, Typ, Dot, Cas); + end if; + end Source_File_Name; + + ----------------------------- + -- Source_Reference (GNAT) -- + ----------------------------- + + -- pragma Source_Reference + -- (INTEGER_LITERAL [, STRING_LITERAL] ); + + -- Processing for this pragma must be done at parse time, since error + -- messages needing the proper line numbers can be generated in parse + -- only mode with semantic checking turned off, and indeed we usually + -- turn off semantic checking anyway if any parse errors are found. + + when Pragma_Source_Reference => Source_Reference : declare + Fname : File_Name_Type; + + begin + if Arg_Count /= 1 then + Check_Arg_Count (2); + Check_No_Identifier (Arg2); + end if; + + -- Check that this is first line of file. We skip this test if + -- we are in syntax check only mode, since we may be dealing with + -- multiple compilation units. + + if Get_Physical_Line_Number (Pragma_Sloc) /= 1 + and then Num_SRef_Pragmas (Current_Source_File) = 0 + and then Operating_Mode /= Check_Syntax + then + Error_Msg -- CODEFIX + ("first % pragma must be first line of file", Pragma_Sloc); + raise Error_Resync; + end if; + + Check_No_Identifier (Arg1); + + if Arg_Count = 1 then + if Num_SRef_Pragmas (Current_Source_File) = 0 then + Error_Msg + ("file name required for first % pragma in file", + Pragma_Sloc); + raise Error_Resync; + else + Fname := No_File; + end if; + + -- File name present + + else + Check_Arg_Is_String_Literal (Arg2); + String_To_Name_Buffer (Strval (Expression (Arg2))); + Fname := Name_Find; + + if Num_SRef_Pragmas (Current_Source_File) > 0 then + if Fname /= Full_Ref_Name (Current_Source_File) then + Error_Msg + ("file name must be same in all % pragmas", Pragma_Sloc); + raise Error_Resync; + end if; + end if; + end if; + + if Nkind (Expression (Arg1)) /= N_Integer_Literal then + Error_Msg + ("argument for pragma% must be integer literal", + Sloc (Expression (Arg1))); + raise Error_Resync; + + -- OK, this source reference pragma is effective, however, we + -- ignore it if it is not in the first unit in the multiple unit + -- case. This is because the only purpose in this case is to + -- provide source pragmas for subsequent use by gnatchop. + + else + if Num_Library_Units = 1 then + Register_Source_Ref_Pragma + (Fname, + Strip_Directory (Fname), + UI_To_Int (Intval (Expression (Arg1))), + Get_Physical_Line_Number (Pragma_Sloc) + 1); + end if; + end if; + end Source_Reference; + + ------------------------- + -- Style_Checks (GNAT) -- + ------------------------- + + -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); + + -- This is processed by the parser since some of the style + -- checks take place during source scanning and parsing. + + when Pragma_Style_Checks => Style_Checks : declare + A : Node_Id; + S : String_Id; + C : Char_Code; + OK : Boolean := True; + + begin + -- Two argument case is only for semantics + + if Arg_Count = 2 then + null; + + else + Check_Arg_Count (1); + Check_No_Identifier (Arg1); + A := Expression (Arg1); + + if Nkind (A) = N_String_Literal then + S := Strval (A); + + declare + Slen : constant Natural := Natural (String_Length (S)); + Options : String (1 .. Slen); + J : Natural; + Ptr : Natural; + + begin + J := 1; + loop + C := Get_String_Char (S, Int (J)); + + if not In_Character_Range (C) then + OK := False; + Ptr := J; + exit; + + else + Options (J) := Get_Character (C); + end if; + + if J = Slen then + Set_Style_Check_Options (Options, OK, Ptr); + exit; + + else + J := J + 1; + end if; + end loop; + + if not OK then + Error_Msg + (Style_Msg_Buf (1 .. Style_Msg_Len), + Sloc (Expression (Arg1)) + Source_Ptr (Ptr)); + raise Error_Resync; + end if; + end; + + elsif Nkind (A) /= N_Identifier then + OK := False; + + elsif Chars (A) = Name_All_Checks then + if GNAT_Mode then + Stylesw.Set_GNAT_Style_Check_Options; + else + Stylesw.Set_Default_Style_Check_Options; + end if; + + elsif Chars (A) = Name_On then + Style_Check := True; + + elsif Chars (A) = Name_Off then + Style_Check := False; + + else + OK := False; + end if; + + if not OK then + Error_Msg ("incorrect argument for pragma%", Sloc (A)); + raise Error_Resync; + end if; + end if; + end Style_Checks; + + ------------------------- + -- Suppress_All (GNAT) -- + ------------------------- + + -- pragma Suppress_All + + -- This is a rather odd pragma, because other compilers allow it in + -- strange places. DEC allows it at the end of units, and Rational + -- allows it as a program unit pragma, when it would be more natural + -- if it were a configuration pragma. + + -- Since the reason we provide this pragma is for compatibility with + -- these other compilers, we want to accommodate these strange placement + -- rules, and the easiest thing is simply to allow it anywhere in a + -- unit. If this pragma appears anywhere within a unit, then the effect + -- is as though a pragma Suppress (All_Checks) had appeared as the first + -- line of the current file, i.e. as the first configuration pragma in + -- the current unit. + + -- To get this effect, we set the flag Has_Pragma_Suppress_All in the + -- compilation unit node for the current source file then in the last + -- stage of parsing a file, if this flag is set, we materialize the + -- Suppress (All_Checks) pragma, marked as not coming from Source. + + when Pragma_Suppress_All => + Set_Has_Pragma_Suppress_All (Cunit (Current_Source_Unit)); + + --------------------- + -- Warnings (GNAT) -- + --------------------- + + -- pragma Warnings (On | Off); + -- pragma Warnings (On | Off, LOCAL_NAME); + -- pragma Warnings (static_string_EXPRESSION); + -- pragma Warnings (On | Off, static_string_EXPRESSION); + + -- The one argument ON/OFF case is processed by the parser, since it may + -- control parser warnings as well as semantic warnings, and in any case + -- we want to be absolutely sure that the range in the warnings table is + -- set well before any semantic analysis is performed. Note that we + -- ignore this pragma if debug flag -gnatd.i is set. + + when Pragma_Warnings => + if Arg_Count = 1 and then not Debug_Flag_Dot_I then + Check_No_Identifier (Arg1); + + declare + Argx : constant Node_Id := Expression (Arg1); + begin + if Nkind (Argx) = N_Identifier then + if Chars (Argx) = Name_On then + Set_Warnings_Mode_On (Pragma_Sloc); + elsif Chars (Argx) = Name_Off then + Set_Warnings_Mode_Off (Pragma_Sloc); + end if; + end if; + end; + end if; + + ----------------------------- + -- Wide_Character_Encoding -- + ----------------------------- + + -- pragma Wide_Character_Encoding (IDENTIFIER | CHARACTER_LITERAL); + + -- This is processed by the parser, since the scanner is affected + + when Pragma_Wide_Character_Encoding => Wide_Character_Encoding : declare + A : Node_Id; + + begin + Check_Arg_Count (1); + Check_No_Identifier (Arg1); + A := Expression (Arg1); + + if Nkind (A) = N_Identifier then + Get_Name_String (Chars (A)); + Wide_Character_Encoding_Method := + Get_WC_Encoding_Method (Name_Buffer (1 .. Name_Len)); + + elsif Nkind (A) = N_Character_Literal then + declare + R : constant Char_Code := + Char_Code (UI_To_Int (Char_Literal_Value (A))); + begin + if In_Character_Range (R) then + Wide_Character_Encoding_Method := + Get_WC_Encoding_Method (Get_Character (R)); + else + raise Constraint_Error; + end if; + end; + + else + raise Constraint_Error; + end if; + + Upper_Half_Encoding := + Wide_Character_Encoding_Method in + WC_Upper_Half_Encoding_Method; + + exception + when Constraint_Error => + Error_Msg_N ("invalid argument for pragma%", Arg1); + end Wide_Character_Encoding; + + ----------------------- + -- All Other Pragmas -- + ----------------------- + + -- For all other pragmas, checking and processing is handled + -- entirely in Sem_Prag, and no further checking is done by Par. + + when Pragma_Abort_Defer | + Pragma_Assertion_Policy | + Pragma_Assume_No_Invalid_Values | + Pragma_AST_Entry | + Pragma_All_Calls_Remote | + Pragma_Annotate | + Pragma_Assert | + Pragma_Asynchronous | + Pragma_Atomic | + Pragma_Atomic_Components | + Pragma_Attach_Handler | + Pragma_Check | + Pragma_Check_Name | + Pragma_Check_Policy | + Pragma_CIL_Constructor | + Pragma_Compile_Time_Error | + Pragma_Compile_Time_Warning | + Pragma_Compiler_Unit | + Pragma_Convention_Identifier | + Pragma_CPP_Class | + Pragma_CPP_Constructor | + Pragma_CPP_Virtual | + Pragma_CPP_Vtable | + Pragma_CPU | + Pragma_C_Pass_By_Copy | + Pragma_Comment | + Pragma_Common_Object | + Pragma_Complete_Representation | + Pragma_Complex_Representation | + Pragma_Component_Alignment | + Pragma_Controlled | + Pragma_Convention | + Pragma_Debug_Policy | + Pragma_Detect_Blocking | + Pragma_Default_Storage_Pool | + Pragma_Dimension | + Pragma_Discard_Names | + Pragma_Eliminate | + Pragma_Elaborate | + Pragma_Elaborate_All | + Pragma_Elaborate_Body | + Pragma_Elaboration_Checks | + Pragma_Export | + Pragma_Export_Exception | + Pragma_Export_Function | + Pragma_Export_Object | + Pragma_Export_Procedure | + Pragma_Export_Value | + Pragma_Export_Valued_Procedure | + Pragma_Extend_System | + Pragma_External | + Pragma_External_Name_Casing | + Pragma_Favor_Top_Level | + Pragma_Fast_Math | + Pragma_Finalize_Storage_Only | + Pragma_Float_Representation | + Pragma_Ident | + Pragma_Implemented | + Pragma_Implicit_Packing | + Pragma_Import | + Pragma_Import_Exception | + Pragma_Import_Function | + Pragma_Import_Object | + Pragma_Import_Procedure | + Pragma_Import_Valued_Procedure | + Pragma_Independent | + Pragma_Independent_Components | + Pragma_Initialize_Scalars | + Pragma_Inline | + Pragma_Inline_Always | + Pragma_Inline_Generic | + Pragma_Inspection_Point | + Pragma_Interface | + Pragma_Interface_Name | + Pragma_Interrupt_Handler | + Pragma_Interrupt_State | + Pragma_Interrupt_Priority | + Pragma_Invariant | + Pragma_Java_Constructor | + Pragma_Java_Interface | + Pragma_Keep_Names | + Pragma_License | + Pragma_Link_With | + Pragma_Linker_Alias | + Pragma_Linker_Constructor | + Pragma_Linker_Destructor | + Pragma_Linker_Options | + Pragma_Linker_Section | + Pragma_Locking_Policy | + Pragma_Long_Float | + Pragma_Machine_Attribute | + Pragma_Main | + Pragma_Main_Storage | + Pragma_Memory_Size | + Pragma_No_Body | + Pragma_No_Return | + Pragma_No_Run_Time | + Pragma_No_Strict_Aliasing | + Pragma_Normalize_Scalars | + Pragma_Obsolescent | + Pragma_Ordered | + Pragma_Optimize | + Pragma_Optimize_Alignment | + Pragma_Pack | + Pragma_Passive | + Pragma_Preelaborable_Initialization | + Pragma_Polling | + Pragma_Persistent_BSS | + Pragma_Postcondition | + Pragma_Precondition | + Pragma_Predicate | + Pragma_Preelaborate | + Pragma_Preelaborate_05 | + Pragma_Priority | + Pragma_Priority_Specific_Dispatching | + Pragma_Profile | + Pragma_Profile_Warnings | + Pragma_Propagate_Exceptions | + Pragma_Psect_Object | + Pragma_Pure | + Pragma_Pure_05 | + Pragma_Pure_Function | + Pragma_Queuing_Policy | + Pragma_Relative_Deadline | + Pragma_Remote_Call_Interface | + Pragma_Remote_Types | + Pragma_Restricted_Run_Time | + Pragma_Ravenscar | + Pragma_Reviewable | + Pragma_Share_Generic | + Pragma_Shared | + Pragma_Shared_Passive | + Pragma_Short_Circuit_And_Or | + Pragma_Short_Descriptors | + Pragma_Storage_Size | + Pragma_Storage_Unit | + Pragma_Static_Elaboration_Desired | + Pragma_Stream_Convert | + Pragma_Subtitle | + Pragma_Suppress | + Pragma_Suppress_Debug_Info | + Pragma_Suppress_Exception_Locations | + Pragma_Suppress_Initialization | + Pragma_System_Name | + Pragma_Task_Dispatching_Policy | + Pragma_Task_Info | + Pragma_Task_Name | + Pragma_Task_Storage | + Pragma_Thread_Local_Storage | + Pragma_Time_Slice | + Pragma_Title | + Pragma_Unchecked_Union | + Pragma_Unimplemented_Unit | + Pragma_Universal_Aliasing | + Pragma_Universal_Data | + Pragma_Unmodified | + Pragma_Unreferenced | + Pragma_Unreferenced_Objects | + Pragma_Unreserve_All_Interrupts | + Pragma_Unsuppress | + Pragma_Use_VADS_Size | + Pragma_Volatile | + Pragma_Volatile_Components | + Pragma_Weak_External | + Pragma_Validity_Checks => + null; + + -------------------- + -- Unknown_Pragma -- + -------------------- + + -- Should be impossible, since we excluded this case earlier on + + when Unknown_Pragma => + raise Program_Error; + + end case; + + return Pragma_Node; + + -------------------- + -- Error Handling -- + -------------------- + +exception + when Error_Resync => + return Error; + +end Prag; diff --git a/gcc/ada/par-sync.adb b/gcc/ada/par-sync.adb new file mode 100644 index 000000000..cbf1d1ef0 --- /dev/null +++ b/gcc/ada/par-sync.adb @@ -0,0 +1,343 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . S Y N C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +separate (Par) +package body Sync is + + procedure Resync_Init; + -- This routine is called on initiating a resynchronization action + + procedure Resync_Resume; + -- This routine is called on completing a resynchronization action + + ------------------- + -- Resync_Choice -- + ------------------- + + procedure Resync_Choice is + begin + Resync_Init; + + -- Loop till we get a token that terminates a choice. Note that EOF is + -- one such token, so we are sure to get out of this loop eventually! + + while Token not in Token_Class_Cterm loop + Scan; + end loop; + + Resync_Resume; + end Resync_Choice; + + ------------------ + -- Resync_Cunit -- + ------------------ + + procedure Resync_Cunit is + begin + Resync_Init; + + while Token not in Token_Class_Cunit + and then Token /= Tok_EOF + loop + Scan; + end loop; + + Resync_Resume; + end Resync_Cunit; + + ----------------------- + -- Resync_Expression -- + ----------------------- + + procedure Resync_Expression is + Paren_Count : Int; + + begin + Resync_Init; + Paren_Count := 0; + + loop + -- Terminating tokens are those in class Eterm and also RANGE, + -- DIGITS or DELTA if not preceded by an apostrophe (if they are + -- preceded by an apostrophe, then they are attributes). In addition, + -- at the outer parentheses level only, we also consider a comma, + -- right parenthesis or vertical bar to terminate an expression. + + if Token in Token_Class_Eterm + + or else (Token in Token_Class_Atkwd + and then Prev_Token /= Tok_Apostrophe) + + or else (Paren_Count = 0 + and then + (Token = Tok_Comma + or else Token = Tok_Right_Paren + or else Token = Tok_Vertical_Bar)) + then + -- A special check: if we stop on the ELSE of OR ELSE or the + -- THEN of AND THEN, keep going, because this is not really an + -- expression terminator after all. Also, keep going past WITH + -- since this can be part of an extension aggregate + + if (Token = Tok_Else and then Prev_Token = Tok_Or) + or else (Token = Tok_Then and then Prev_Token = Tok_And) + or else Token = Tok_With + then + null; + else + exit; + end if; + end if; + + if Token = Tok_Left_Paren then + Paren_Count := Paren_Count + 1; + + elsif Token = Tok_Right_Paren then + Paren_Count := Paren_Count - 1; + + end if; + + Scan; -- past token to be skipped + end loop; + + Resync_Resume; + end Resync_Expression; + + ----------------- + -- Resync_Init -- + ----------------- + + procedure Resync_Init is + begin + -- The following check makes sure we do not get stuck in an infinite + -- loop resynchronizing and getting nowhere. If we are called to do a + -- resynchronize and we are exactly at the same point that we left off + -- on the last resynchronize call, then we force at least one token to + -- be skipped so that we make progress! + + if Token_Ptr = Last_Resync_Point then + Scan; -- to skip at least one token + end if; + + -- Output extra error message if debug R flag is set + + if Debug_Flag_R then + Error_Msg_SC ("resynchronizing!"); + end if; + end Resync_Init; + + --------------------------- + -- Resync_Past_Semicolon -- + --------------------------- + + procedure Resync_Past_Semicolon is + begin + Resync_Init; + + loop + -- Done if we are at a semicolon + + if Token = Tok_Semicolon then + Scan; -- past semicolon + exit; + + -- Done if we are at a token which normally appears only after + -- a semicolon. One special glitch is that the keyword private is + -- in this category only if it does NOT appear after WITH. + + elsif Token in Token_Class_After_SM + and then (Token /= Tok_Private or else Prev_Token /= Tok_With) + then + exit; + + -- Otherwise keep going + + else + Scan; + end if; + end loop; + + -- Fall out of loop with resynchronization complete + + Resync_Resume; + end Resync_Past_Semicolon; + + ------------------------- + -- Resync_To_Semicolon -- + ------------------------- + + procedure Resync_To_Semicolon is + begin + Resync_Init; + + loop + -- Done if we are at a semicolon + + if Token = Tok_Semicolon then + exit; + + -- Done if we are at a token which normally appears only after + -- a semicolon. One special glitch is that the keyword private is + -- in this category only if it does NOT appear after WITH. + + elsif Token in Token_Class_After_SM + and then (Token /= Tok_Private or else Prev_Token /= Tok_With) + then + exit; + + -- Otherwise keep going + + else + Scan; + end if; + end loop; + + -- Fall out of loop with resynchronization complete + + Resync_Resume; + end Resync_To_Semicolon; + + ---------------------------------------------- + -- Resync_Past_Semicolon_Or_To_Loop_Or_Then -- + ---------------------------------------------- + + procedure Resync_Past_Semicolon_Or_To_Loop_Or_Then is + begin + Resync_Init; + + loop + -- Done if at semicolon + + if Token = Tok_Semicolon then + Scan; -- past the semicolon + exit; + + -- Done if we are at a token which normally appears only after + -- a semicolon. One special glitch is that the keyword private is + -- in this category only if it does NOT appear after WITH. + + elsif Token in Token_Class_After_SM + and then (Token /= Tok_Private or else Prev_Token /= Tok_With) + then + exit; + + -- Done if we are at THEN or LOOP + + elsif Token = Tok_Then or else Token = Tok_Loop then + exit; + + -- Otherwise keep going + + else + Scan; + end if; + end loop; + + -- Fall out of loop with resynchronization complete + + Resync_Resume; + end Resync_Past_Semicolon_Or_To_Loop_Or_Then; + + ------------------- + -- Resync_Resume -- + ------------------- + + procedure Resync_Resume is + begin + -- Save resync point (see special test in Resync_Init) + + Last_Resync_Point := Token_Ptr; + + if Debug_Flag_R then + Error_Msg_SC ("resuming here!"); + end if; + end Resync_Resume; + + -------------------- + -- Resync_To_When -- + -------------------- + + procedure Resync_To_When is + begin + Resync_Init; + + loop + -- Done if at semicolon, WHEN or IS + + if Token = Tok_Semicolon + or else Token = Tok_When + or else Token = Tok_Is + then + exit; + + -- Otherwise keep going + + else + Scan; + end if; + end loop; + + -- Fall out of loop with resynchronization complete + + Resync_Resume; + end Resync_To_When; + + --------------------------- + -- Resync_Semicolon_List -- + --------------------------- + + procedure Resync_Semicolon_List is + Paren_Count : Int; + + begin + Resync_Init; + Paren_Count := 0; + + loop + if Token = Tok_EOF + or else Token = Tok_Semicolon + or else Token = Tok_Is + or else Token in Token_Class_After_SM + then + exit; + + elsif Token = Tok_Left_Paren then + Paren_Count := Paren_Count + 1; + + elsif Token = Tok_Right_Paren then + if Paren_Count = 0 then + exit; + else + Paren_Count := Paren_Count - 1; + end if; + end if; + + Scan; + end loop; + + Resync_Resume; + end Resync_Semicolon_List; + +end Sync; diff --git a/gcc/ada/par-tchk.adb b/gcc/ada/par-tchk.adb new file mode 100644 index 000000000..c92b20fbf --- /dev/null +++ b/gcc/ada/par-tchk.adb @@ -0,0 +1,904 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . T C H K -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Token scan routines + +-- Error recovery: none of the T_xxx or TF_xxx routines raise Error_Resync + +separate (Par) +package body Tchk is + + type Position is (SC, BC, AP); + -- Specify position of error message (see Error_Msg_SC/BC/AP) + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Check_Token (T : Token_Type; P : Position); + pragma Inline (Check_Token); + -- Called by T_xx routines to check for reserved keyword token. P is the + -- position of the error message if the token is missing (see Wrong_Token) + + procedure Wrong_Token (T : Token_Type; P : Position); + -- Called when scanning a reserved keyword when the keyword is not + -- present. T is the token type for the keyword, and P indicates the + -- position to be used to place a message relative to the current + -- token if the keyword is not located nearby. + + ----------------- + -- Check_Token -- + ----------------- + + procedure Check_Token (T : Token_Type; P : Position) is + begin + if Token = T then + Scan; + return; + else + Wrong_Token (T, P); + end if; + end Check_Token; + + ------------- + -- T_Abort -- + ------------- + + procedure T_Abort is + begin + Check_Token (Tok_Abort, SC); + end T_Abort; + + ------------- + -- T_Arrow -- + ------------- + + procedure T_Arrow is + begin + if Token = Tok_Arrow then + Scan; + + -- A little recovery helper, accept then in place of => + + elsif Token = Tok_Then then + Error_Msg_BC -- CODEFIX + ("|THEN should be ""='>"""); + Scan; -- past THEN used in place of => + + elsif Token = Tok_Colon_Equal then + Error_Msg_SC -- CODEFIX + ("|"":="" should be ""='>"""); + Scan; -- past := used in place of => + + else + Error_Msg_AP -- CODEFIX + ("missing ""='>"""); + end if; + end T_Arrow; + + ---------- + -- T_At -- + ---------- + + procedure T_At is + begin + Check_Token (Tok_At, SC); + end T_At; + + ------------ + -- T_Body -- + ------------ + + procedure T_Body is + begin + Check_Token (Tok_Body, BC); + end T_Body; + + ----------- + -- T_Box -- + ----------- + + procedure T_Box is + begin + if Token = Tok_Box then + Scan; + else + Error_Msg_AP -- CODEFIX + ("missing ""'<'>"""); + end if; + end T_Box; + + ------------- + -- T_Colon -- + ------------- + + procedure T_Colon is + begin + if Token = Tok_Colon then + Scan; + else + Error_Msg_AP -- CODEFIX + ("missing "":"""); + end if; + end T_Colon; + + ------------------- + -- T_Colon_Equal -- + ------------------- + + procedure T_Colon_Equal is + begin + if Token = Tok_Colon_Equal then + Scan; + + elsif Token = Tok_Equal then + Error_Msg_SC -- CODEFIX + ("|""="" should be "":="""); + Scan; + + elsif Token = Tok_Colon then + Error_Msg_SC -- CODEFIX + ("|"":"" should be "":="""); + Scan; + + elsif Token = Tok_Is then + Error_Msg_SC -- CODEFIX + ("|IS should be "":="""); + Scan; + + else + Error_Msg_AP -- CODEFIX + ("missing "":="""); + end if; + end T_Colon_Equal; + + ------------- + -- T_Comma -- + ------------- + + procedure T_Comma is + begin + if Token = Tok_Comma then + Scan; + + else + if Token = Tok_Pragma then + P_Pragmas_Misplaced; + end if; + + if Token = Tok_Comma then + Scan; + else + Error_Msg_AP -- CODEFIX + ("missing "","""); + end if; + end if; + + if Token = Tok_Pragma then + P_Pragmas_Misplaced; + end if; + end T_Comma; + + --------------- + -- T_Dot_Dot -- + --------------- + + procedure T_Dot_Dot is + begin + if Token = Tok_Dot_Dot then + Scan; + else + Error_Msg_AP -- CODEFIX + ("missing "".."""); + end if; + end T_Dot_Dot; + + ----------- + -- T_For -- + ----------- + + procedure T_For is + begin + Check_Token (Tok_For, AP); + end T_For; + + ----------------------- + -- T_Greater_Greater -- + ----------------------- + + procedure T_Greater_Greater is + begin + if Token = Tok_Greater_Greater then + Scan; + else + Error_Msg_AP -- CODEFIX + ("missing ""'>'>"""); + end if; + end T_Greater_Greater; + + ------------------ + -- T_Identifier -- + ------------------ + + procedure T_Identifier is + begin + if Token = Tok_Identifier then + Scan; + elsif Token in Token_Class_Literal then + Error_Msg_SC ("identifier expected"); + Scan; + else + Error_Msg_AP ("identifier expected"); + end if; + end T_Identifier; + + ---------- + -- T_In -- + ---------- + + procedure T_In is + begin + Check_Token (Tok_In, AP); + end T_In; + + ---------- + -- T_Is -- + ---------- + + procedure T_Is is + begin + Ignore (Tok_Semicolon); + + -- If we have IS scan past it + + if Token = Tok_Is then + Scan; + + -- And ignore any following semicolons + + Ignore (Tok_Semicolon); + + -- Allow OF, => or = to substitute for IS with complaint + + elsif Token = Tok_Arrow then + Error_Msg_SC -- CODEFIX + ("|""=>"" should be IS"); + Scan; -- past => + + elsif Token = Tok_Of then + Error_Msg_SC -- CODEFIX + ("|OF should be IS"); + Scan; -- past OF + + elsif Token = Tok_Equal then + Error_Msg_SC -- CODEFIX + ("|""="" should be IS"); + Scan; -- past = + + else + Wrong_Token (Tok_Is, AP); + end if; + + -- Ignore extra IS keywords + + while Token = Tok_Is loop + Error_Msg_SC -- CODEFIX + ("|extra IS ignored"); + Scan; + end loop; + end T_Is; + + ------------------ + -- T_Left_Paren -- + ------------------ + + procedure T_Left_Paren is + begin + if Token = Tok_Left_Paren then + Scan; + else + Error_Msg_AP -- CODEFIX + ("missing ""("""); + end if; + end T_Left_Paren; + + ------------ + -- T_Loop -- + ------------ + + procedure T_Loop is + begin + if Token = Tok_Do then + Error_Msg_SC -- CODEFIX + ("LOOP expected"); + Scan; + else + Check_Token (Tok_Loop, AP); + end if; + end T_Loop; + + ----------- + -- T_Mod -- + ----------- + + procedure T_Mod is + begin + Check_Token (Tok_Mod, AP); + end T_Mod; + + ----------- + -- T_New -- + ----------- + + procedure T_New is + begin + Check_Token (Tok_New, AP); + end T_New; + + ---------- + -- T_Of -- + ---------- + + procedure T_Of is + begin + Check_Token (Tok_Of, AP); + end T_Of; + + ---------- + -- T_Or -- + ---------- + + procedure T_Or is + begin + Check_Token (Tok_Or, AP); + end T_Or; + + --------------- + -- T_Private -- + --------------- + + procedure T_Private is + begin + Check_Token (Tok_Private, SC); + end T_Private; + + ------------- + -- T_Range -- + ------------- + + procedure T_Range is + begin + Check_Token (Tok_Range, AP); + end T_Range; + + -------------- + -- T_Record -- + -------------- + + procedure T_Record is + begin + Check_Token (Tok_Record, AP); + end T_Record; + + ------------------- + -- T_Right_Paren -- + ------------------- + + procedure T_Right_Paren is + begin + if Token = Tok_Right_Paren then + Scan; + else + Error_Msg_AP -- CODEFIX + ("|missing "")"""); + end if; + end T_Right_Paren; + + ----------------- + -- T_Semicolon -- + ----------------- + + procedure T_Semicolon is + begin + + if Token = Tok_Semicolon then + Scan; + + if Token = Tok_Semicolon then + Error_Msg_SC -- CODEFIX + ("|extra "";"" ignored"); + Scan; + end if; + + return; + + elsif Token = Tok_Colon then + Error_Msg_SC -- CODEFIX + ("|"":"" should be "";"""); + Scan; + return; + + elsif Token = Tok_Comma then + Error_Msg_SC -- CODEFIX + ("|"","" should be "";"""); + Scan; + return; + + elsif Token = Tok_Dot then + Error_Msg_SC -- CODEFIX + ("|""."" should be "";"""); + Scan; + return; + + -- An interesting little kludge here. If the previous token is a + -- semicolon, then there is no way that we can legitimately need another + -- semicolon. This could only arise in an error situation where an error + -- has already been signalled. By simply ignoring the request for a + -- semicolon in this case, we avoid some spurious missing semicolon + -- messages. + + elsif Prev_Token = Tok_Semicolon then + return; + + -- If the current token is | then this is a reasonable place to suggest + -- the possibility of a "C" confusion. + + elsif Token = Tok_Vertical_Bar then + Error_Msg_SC -- CODEFIX + ("unexpected occurrence of ""'|"", did you mean OR'?"); + Resync_Past_Semicolon; + return; + + -- Deal with pragma. If pragma is not at start of line, it is considered + -- misplaced otherwise we treat it as a normal missing semicolon case. + + elsif Token = Tok_Pragma + and then not Token_Is_At_Start_Of_Line + then + P_Pragmas_Misplaced; + + if Token = Tok_Semicolon then + Scan; + return; + end if; + end if; + + -- If none of those tests return, we really have a missing semicolon + + Error_Msg_AP -- CODEFIX + ("|missing "";"""); + return; + end T_Semicolon; + + ------------ + -- T_Then -- + ------------ + + procedure T_Then is + begin + Check_Token (Tok_Then, AP); + end T_Then; + + ------------ + -- T_Type -- + ------------ + + procedure T_Type is + begin + Check_Token (Tok_Type, BC); + end T_Type; + + ----------- + -- T_Use -- + ----------- + + procedure T_Use is + begin + Check_Token (Tok_Use, SC); + end T_Use; + + ------------ + -- T_When -- + ------------ + + procedure T_When is + begin + Check_Token (Tok_When, SC); + end T_When; + + ------------ + -- T_With -- + ------------ + + procedure T_With is + begin + Check_Token (Tok_With, BC); + end T_With; + + -------------- + -- TF_Arrow -- + -------------- + + procedure TF_Arrow is + Scan_State : Saved_Scan_State; + + begin + if Token = Tok_Arrow then + Scan; -- skip arrow and we are done + + elsif Token = Tok_Colon_Equal then + T_Arrow; -- Let T_Arrow give the message + + else + T_Arrow; -- give missing arrow message + Save_Scan_State (Scan_State); -- at start of junk tokens + + loop + if Prev_Token_Ptr < Current_Line_Start + or else Token = Tok_Semicolon + or else Token = Tok_EOF + then + Restore_Scan_State (Scan_State); -- to where we were! + return; + end if; + + Scan; -- continue search! + + if Token = Tok_Arrow then + Scan; -- past arrow + return; + end if; + end loop; + end if; + end TF_Arrow; + + ----------- + -- TF_Is -- + ----------- + + procedure TF_Is is + Scan_State : Saved_Scan_State; + + begin + if Token = Tok_Is then + T_Is; -- past IS and we are done + + -- Allow OF or => or = in place of IS (with error message) + + elsif Token = Tok_Of + or else Token = Tok_Arrow + or else Token = Tok_Equal + then + T_Is; -- give missing IS message and skip bad token + + else + T_Is; -- give missing IS message + Save_Scan_State (Scan_State); -- at start of junk tokens + + loop + if Prev_Token_Ptr < Current_Line_Start + or else Token = Tok_Semicolon + or else Token = Tok_EOF + then + Restore_Scan_State (Scan_State); -- to where we were! + return; + end if; + + Scan; -- continue search! + + if Token = Tok_Is + or else Token = Tok_Of + or else Token = Tok_Arrow + then + Scan; -- past IS or OF or => + return; + end if; + end loop; + end if; + end TF_Is; + + ------------- + -- TF_Loop -- + ------------- + + procedure TF_Loop is + Scan_State : Saved_Scan_State; + + begin + if Token = Tok_Loop then + Scan; -- past LOOP and we are done + + -- Allow DO or THEN in place of LOOP + + elsif Token = Tok_Then or else Token = Tok_Do then + T_Loop; -- give missing LOOP message + + else + T_Loop; -- give missing LOOP message + Save_Scan_State (Scan_State); -- at start of junk tokens + + loop + if Prev_Token_Ptr < Current_Line_Start + or else Token = Tok_Semicolon + or else Token = Tok_EOF + then + Restore_Scan_State (Scan_State); -- to where we were! + return; + end if; + + Scan; -- continue search! + + if Token = Tok_Loop or else Token = Tok_Then then + Scan; -- past loop or then (message already generated) + return; + end if; + end loop; + end if; + end TF_Loop; + + -------------- + -- TF_Return-- + -------------- + + procedure TF_Return is + Scan_State : Saved_Scan_State; + + begin + if Token = Tok_Return then + Scan; -- skip RETURN and we are done + + else + Error_Msg_SC -- CODEFIX + ("missing RETURN"); + Save_Scan_State (Scan_State); -- at start of junk tokens + + loop + if Prev_Token_Ptr < Current_Line_Start + or else Token = Tok_Semicolon + or else Token = Tok_EOF + then + Restore_Scan_State (Scan_State); -- to where we were! + return; + end if; + + Scan; -- continue search! + + if Token = Tok_Return then + Scan; -- past RETURN + return; + end if; + end loop; + end if; + end TF_Return; + + ------------------ + -- TF_Semicolon -- + ------------------ + + procedure TF_Semicolon is + Scan_State : Saved_Scan_State; + + begin + if Token = Tok_Semicolon then + T_Semicolon; + return; + + -- An interesting little kludge here. If the previous token is a + -- semicolon, then there is no way that we can legitimately need + -- another semicolon. This could only arise in an error situation + -- where an error has already been signalled. By simply ignoring + -- the request for a semicolon in this case, we avoid some spurious + -- missing semicolon messages. + + elsif Prev_Token = Tok_Semicolon then + return; + + else + -- Deal with pragma. If pragma is not at start of line, it is + -- considered misplaced otherwise we treat it as a normal + -- missing semicolon case. + + if Token = Tok_Pragma + and then not Token_Is_At_Start_Of_Line + then + P_Pragmas_Misplaced; + + if Token = Tok_Semicolon then + T_Semicolon; + return; + end if; + end if; + + -- Here we definitely have a missing semicolon, so give message + + T_Semicolon; + + -- Scan out junk on rest of line. Scan stops on END keyword, since + -- that seems to help avoid cascaded errors. + + Save_Scan_State (Scan_State); -- at start of junk tokens + + loop + if Prev_Token_Ptr < Current_Line_Start + or else Token = Tok_EOF + or else Token = Tok_End + then + Restore_Scan_State (Scan_State); -- to where we were + return; + end if; + + Scan; -- continue search + + if Token = Tok_Semicolon then + T_Semicolon; + return; + + elsif Token in Token_Class_After_SM then + return; + end if; + end loop; + end if; + end TF_Semicolon; + + ------------- + -- TF_Then -- + ------------- + + procedure TF_Then is + Scan_State : Saved_Scan_State; + + begin + if Token = Tok_Then then + Scan; -- past THEN and we are done + + else + T_Then; -- give missing THEN message + Save_Scan_State (Scan_State); -- at start of junk tokens + + loop + if Prev_Token_Ptr < Current_Line_Start + or else Token = Tok_Semicolon + or else Token = Tok_EOF + then + Restore_Scan_State (Scan_State); -- to where we were + return; + end if; + + Scan; -- continue search! + + if Token = Tok_Then then + Scan; -- past THEN + return; + end if; + end loop; + end if; + end TF_Then; + + ------------ + -- TF_Use -- + ------------ + + procedure TF_Use is + Scan_State : Saved_Scan_State; + + begin + if Token = Tok_Use then + Scan; -- past USE and we are done + + else + T_Use; -- give USE expected message + Save_Scan_State (Scan_State); -- at start of junk tokens + + loop + if Prev_Token_Ptr < Current_Line_Start + or else Token = Tok_Semicolon + or else Token = Tok_EOF + then + Restore_Scan_State (Scan_State); -- to where we were + return; + end if; + + Scan; -- continue search! + + if Token = Tok_Use then + Scan; -- past use + return; + end if; + end loop; + end if; + end TF_Use; + + ------------------ + -- U_Left_Paren -- + ------------------ + + procedure U_Left_Paren is + begin + if Token = Tok_Left_Paren then + Scan; + else + Error_Msg_AP -- CODEFIX + ("missing ""(""!"); + end if; + end U_Left_Paren; + + ------------------- + -- U_Right_Paren -- + ------------------- + + procedure U_Right_Paren is + begin + if Token = Tok_Right_Paren then + Scan; + else + Error_Msg_AP -- CODEFIX + ("|missing "")""!"); + end if; + end U_Right_Paren; + + ----------------- + -- Wrong_Token -- + ----------------- + + procedure Wrong_Token (T : Token_Type; P : Position) is + Missing : constant String := "missing "; + Image : constant String := Token_Type'Image (T); + Tok_Name : constant String := Image (5 .. Image'Length); + M : constant String := Missing & Tok_Name; + + begin + if Token = Tok_Semicolon then + Scan; + + if Token = T then + Error_Msg_SP -- CODEFIX + ("|extra "";"" ignored"); + Scan; + else + Error_Msg_SP (M); + end if; + + elsif Token = Tok_Comma then + Scan; + + if Token = T then + Error_Msg_SP -- CODEFIX + ("|extra "","" ignored"); + Scan; + + else + Error_Msg_SP (M); + end if; + + else + case P is + when SC => Error_Msg_SC (M); + when BC => Error_Msg_BC (M); + when AP => Error_Msg_AP (M); + end case; + end if; + end Wrong_Token; + +end Tchk; diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb new file mode 100644 index 000000000..6a0e8efc6 --- /dev/null +++ b/gcc/ada/par-util.adb @@ -0,0 +1,728 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . U T I L -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Csets; use Csets; +with Namet.Sp; use Namet.Sp; +with Stylesw; use Stylesw; +with Uintp; use Uintp; + +with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; + +separate (Par) +package body Util is + + --------------------- + -- Bad_Spelling_Of -- + --------------------- + + function Bad_Spelling_Of (T : Token_Type) return Boolean is + Tname : constant String := Token_Type'Image (T); + -- Characters of token name + + S : String (1 .. Tname'Last - 4); + -- Characters of token name folded to lower case, omitting TOK_ at start + + M1 : String (1 .. 42) := "incorrect spelling of keyword ************"; + M2 : String (1 .. 44) := "illegal abbreviation of keyword ************"; + -- Buffers used to construct error message + + P1 : constant := 30; + P2 : constant := 32; + -- Starting subscripts in M1, M2 for keyword name + + SL : constant Natural := S'Length; + -- Length of expected token name excluding TOK_ at start + + begin + if Token /= Tok_Identifier then + return False; + end if; + + for J in S'Range loop + S (J) := Fold_Lower (Tname (J + 4)); + end loop; + + Get_Name_String (Token_Name); + + -- A special check for case of PROGRAM used for PROCEDURE + + if T = Tok_Procedure + and then Name_Len = 7 + and then Name_Buffer (1 .. 7) = "program" + then + Error_Msg_SC -- CODEFIX + ("PROCEDURE expected"); + Token := T; + return True; + + -- A special check for an illegal abbreviation + + elsif Name_Len < S'Length + and then Name_Len >= 4 + and then Name_Buffer (1 .. Name_Len) = S (1 .. Name_Len) + then + for J in 1 .. S'Last loop + M2 (P2 + J - 1) := Fold_Upper (S (J)); + end loop; + + Error_Msg_SC (M2 (1 .. P2 - 1 + S'Last)); + Token := T; + return True; + end if; + + -- Now we go into the full circuit to check for a misspelling + + -- Never consider something a misspelling if either the actual or + -- expected string is less than 3 characters (before this check we + -- used to consider i to be a misspelled if in some cases!) + + if SL < 3 or else Name_Len < 3 then + return False; + + -- Special case: prefix matches, i.e. the leading characters of the + -- token that we have exactly match the required keyword. If there + -- are at least two characters left over, assume that we have a case + -- of two keywords joined together which should not be joined. + + elsif Name_Len > SL + 1 + and then S = Name_Buffer (1 .. SL) + then + Scan_Ptr := Token_Ptr + S'Length; + Error_Msg_S ("|missing space"); + Token := T; + return True; + end if; + + if Is_Bad_Spelling_Of (Name_Buffer (1 .. Name_Len), S) then + for J in 1 .. S'Last loop + M1 (P1 + J - 1) := Fold_Upper (S (J)); + end loop; + + Error_Msg_SC -- CODFIX + (M1 (1 .. P1 - 1 + S'Last)); + Token := T; + return True; + + else + return False; + end if; + end Bad_Spelling_Of; + + ---------------------- + -- Check_95_Keyword -- + ---------------------- + + -- On entry, the caller has checked that current token is an identifier + -- whose name matches the name of the 95 keyword New_Tok. + + procedure Check_95_Keyword (Token_95, Next : Token_Type) is + Scan_State : Saved_Scan_State; + + begin + Save_Scan_State (Scan_State); -- at identifier/keyword + Scan; -- past identifier/keyword + + if Token = Next then + Restore_Scan_State (Scan_State); -- to identifier + Error_Msg_Name_1 := Token_Name; + Error_Msg_SC ("(Ada 83) keyword* cannot be used!"); + Token := Token_95; + else + Restore_Scan_State (Scan_State); -- to identifier + end if; + end Check_95_Keyword; + + ---------------------- + -- Check_Bad_Layout -- + ---------------------- + + procedure Check_Bad_Layout is + begin + if RM_Column_Check and then Token_Is_At_Start_Of_Line + and then Start_Column <= Scope.Table (Scope.Last).Ecol + then + Error_Msg_BC -- CODEFIX + ("(style) incorrect layout"); + end if; + end Check_Bad_Layout; + + -------------------------- + -- Check_Misspelling_Of -- + -------------------------- + + procedure Check_Misspelling_Of (T : Token_Type) is + begin + if Bad_Spelling_Of (T) then + null; + end if; + end Check_Misspelling_Of; + + ----------------------------- + -- Check_Simple_Expression -- + ----------------------------- + + procedure Check_Simple_Expression (E : Node_Id) is + begin + if Expr_Form = EF_Non_Simple then + Error_Msg_N ("this expression must be parenthesized", E); + end if; + end Check_Simple_Expression; + + --------------------------------------- + -- Check_Simple_Expression_In_Ada_83 -- + --------------------------------------- + + procedure Check_Simple_Expression_In_Ada_83 (E : Node_Id) is + begin + if Expr_Form = EF_Non_Simple then + if Ada_Version = Ada_83 then + Error_Msg_N ("(Ada 83) this expression must be parenthesized!", E); + end if; + end if; + end Check_Simple_Expression_In_Ada_83; + + ------------------------ + -- Check_Subtype_Mark -- + ------------------------ + + function Check_Subtype_Mark (Mark : Node_Id) return Node_Id is + begin + if Nkind (Mark) = N_Identifier + or else Nkind (Mark) = N_Selected_Component + or else (Nkind (Mark) = N_Attribute_Reference + and then Is_Type_Attribute_Name (Attribute_Name (Mark))) + or else Mark = Error + then + return Mark; + else + Error_Msg ("subtype mark expected", Sloc (Mark)); + return Error; + end if; + end Check_Subtype_Mark; + + ------------------- + -- Comma_Present -- + ------------------- + + function Comma_Present return Boolean is + Scan_State : Saved_Scan_State; + Paren_Count : Nat; + + begin + -- First check, if a comma is present, then a comma is present! + + if Token = Tok_Comma then + T_Comma; + return True; + + -- If we have a right paren, then that is taken as ending the list + -- i.e. no comma is present. + + elsif Token = Tok_Right_Paren then + return False; + + -- If pragmas, then get rid of them and make a recursive call + -- to process what follows these pragmas. + + elsif Token = Tok_Pragma then + P_Pragmas_Misplaced; + return Comma_Present; + + -- At this stage we have an error, and the goal is to decide on whether + -- or not we should diagnose an error and report a (non-existent) + -- comma as being present, or simply to report no comma is present + + -- If we are a semicolon, then the question is whether we have a missing + -- right paren, or whether the semicolon should have been a comma. To + -- guess the right answer, we scan ahead keeping track of the paren + -- level, looking for a clue that helps us make the right decision. + + -- This approach is highly accurate in the single error case, and does + -- not make bad mistakes in the multiple error case (indeed we can't + -- really make a very bad decision at this point in any case). + + elsif Token = Tok_Semicolon then + Save_Scan_State (Scan_State); + Scan; -- past semicolon + + -- Check for being followed by identifier => which almost certainly + -- means we are still in a parameter list and the comma should have + -- been a semicolon (such a sequence could not follow a semicolon) + + if Token = Tok_Identifier then + Scan; + + if Token = Tok_Arrow then + goto Assume_Comma; + end if; + end if; + + -- If that test didn't work, loop ahead looking for a comma or + -- semicolon at the same parenthesis level. Always remember that + -- we can't go badly wrong in an error situation like this! + + Paren_Count := 0; + + -- Here is the look ahead loop, Paren_Count tells us whether the + -- token we are looking at is at the same paren level as the + -- suspicious semicolon that we are trying to figure out. + + loop + + -- If we hit another semicolon or an end of file, and we have + -- not seen a right paren or another comma on the way, then + -- probably the semicolon did end the list. Indeed that is + -- certainly the only single error correction possible here. + + if Token = Tok_Semicolon or else Token = Tok_EOF then + Restore_Scan_State (Scan_State); + return False; + + -- A comma at the same paren level as the semicolon is a strong + -- indicator that the semicolon should have been a comma, indeed + -- again this is the only possible single error correction. + + elsif Token = Tok_Comma then + exit when Paren_Count = 0; + + -- A left paren just bumps the paren count + + elsif Token = Tok_Left_Paren then + Paren_Count := Paren_Count + 1; + + -- A right paren that is at the same paren level as the semicolon + -- also means that the only possible single error correction is + -- to assume that the semicolon should have been a comma. If we + -- are not at the same paren level, then adjust the paren level. + + elsif Token = Tok_Right_Paren then + exit when Paren_Count = 0; + Paren_Count := Paren_Count - 1; + end if; + + -- Keep going, we haven't made a decision yet + + Scan; + end loop; + + -- If we fall through the loop, it means that we found a terminating + -- right paren or another comma. In either case it is reasonable to + -- assume that the semicolon was really intended to be a comma. Also + -- come here for the identifier arrow case. + + <> + Restore_Scan_State (Scan_State); + Error_Msg_SC -- CODEFIX + ("|"";"" should be "","""); + Scan; -- past the semicolon + return True; + + -- If we are not at semicolon or a right paren, then we base the + -- decision on whether or not the next token can be part of an + -- expression. If not, then decide that no comma is present (the + -- caller will eventually generate a missing right parent message) + + elsif Token in Token_Class_Eterm then + return False; + + -- Otherwise we assume a comma is present, even if none is present, + -- since the next token must be part of an expression, so if we were + -- at the end of the list, then there is more than one error present. + + else + T_Comma; -- to give error + return True; + end if; + end Comma_Present; + + ----------------------- + -- Discard_Junk_List -- + ----------------------- + + procedure Discard_Junk_List (L : List_Id) is + pragma Warnings (Off, L); + begin + null; + end Discard_Junk_List; + + ----------------------- + -- Discard_Junk_Node -- + ----------------------- + + procedure Discard_Junk_Node (N : Node_Id) is + pragma Warnings (Off, N); + begin + null; + end Discard_Junk_Node; + + ------------ + -- Ignore -- + ------------ + + procedure Ignore (T : Token_Type) is + begin + while Token = T loop + if T = Tok_Comma then + Error_Msg_SC -- CODEFIX + ("|extra "","" ignored"); + + elsif T = Tok_Left_Paren then + Error_Msg_SC -- CODEFIX + ("|extra ""("" ignored"); + + elsif T = Tok_Right_Paren then + Error_Msg_SC -- CODEFIX + ("|extra "")"" ignored"); + + elsif T = Tok_Semicolon then + Error_Msg_SC -- CODEFIX + ("|extra "";"" ignored"); + + elsif T = Tok_Colon then + Error_Msg_SC -- CODEFIX + ("|extra "":"" ignored"); + + else + declare + Tname : constant String := Token_Type'Image (Token); + begin + Error_Msg_SC ("|extra " & Tname (5 .. Tname'Last) & "ignored"); + end; + end if; + + Scan; -- Scan past ignored token + end loop; + end Ignore; + + ---------------------------- + -- Is_Reserved_Identifier -- + ---------------------------- + + function Is_Reserved_Identifier (C : Id_Check := None) return Boolean is + begin + if not Is_Reserved_Keyword (Token) then + return False; + + else + declare + Ident_Casing : constant Casing_Type := + Identifier_Casing (Current_Source_File); + Key_Casing : constant Casing_Type := + Keyword_Casing (Current_Source_File); + + begin + -- If the casing of identifiers and keywords is different in + -- this source file, and the casing of this token matches the + -- keyword casing, then we return False, since it is pretty + -- clearly intended to be a keyword. + + if Ident_Casing = Unknown + or else Key_Casing = Unknown + or else Ident_Casing = Key_Casing + or else Determine_Token_Casing /= Key_Casing + then + return True; + + -- Here we have a keyword written clearly with keyword casing. + -- In default mode, we would not be willing to consider this as + -- a reserved identifier, but if C is set, we may still accept it + + elsif C /= None then + declare + Scan_State : Saved_Scan_State; + OK_Next_Tok : Boolean; + + begin + Save_Scan_State (Scan_State); + Scan; + + if Token_Is_At_Start_Of_Line then + return False; + end if; + + case C is + when None => + raise Program_Error; + + when C_Comma_Right_Paren => + OK_Next_Tok := + Token = Tok_Comma or else Token = Tok_Right_Paren; + + when C_Comma_Colon => + OK_Next_Tok := + Token = Tok_Comma or else Token = Tok_Colon; + + when C_Do => + OK_Next_Tok := + Token = Tok_Do; + + when C_Dot => + OK_Next_Tok := + Token = Tok_Dot; + + when C_Greater_Greater => + OK_Next_Tok := + Token = Tok_Greater_Greater; + + when C_In => + OK_Next_Tok := + Token = Tok_In; + + when C_Is => + OK_Next_Tok := + Token = Tok_Is; + + when C_Left_Paren_Semicolon => + OK_Next_Tok := + Token = Tok_Left_Paren or else Token = Tok_Semicolon; + + when C_Use => + OK_Next_Tok := + Token = Tok_Use; + + when C_Vertical_Bar_Arrow => + OK_Next_Tok := + Token = Tok_Vertical_Bar or else Token = Tok_Arrow; + end case; + + Restore_Scan_State (Scan_State); + + if OK_Next_Tok then + return True; + end if; + end; + end if; + end; + end if; + + -- If we fall through it is not a reserved identifier + + return False; + end Is_Reserved_Identifier; + + ---------------------- + -- Merge_Identifier -- + ---------------------- + + procedure Merge_Identifier (Prev : Node_Id; Nxt : Token_Type) is + begin + if Token /= Tok_Identifier then + return; + end if; + + declare + S : Saved_Scan_State; + T : Token_Type; + + begin + Save_Scan_State (S); + Scan; + T := Token; + Restore_Scan_State (S); + + if T /= Nxt then + return; + end if; + end; + + -- Check exactly one space between identifiers + + if Source (Token_Ptr - 1) /= ' ' + or else Int (Token_Ptr) /= + Int (Prev_Token_Ptr) + Length_Of_Name (Chars (Prev)) + 1 + then + return; + end if; + + -- Do the merge + + Get_Name_String (Chars (Token_Node)); + + declare + Buf : constant String (1 .. Name_Len) := + Name_Buffer (1 .. Name_Len); + + begin + Get_Name_String (Chars (Prev)); + Add_Char_To_Name_Buffer ('_'); + Add_Str_To_Name_Buffer (Buf); + Set_Chars (Prev, Name_Find); + end; + + Error_Msg_Node_1 := Prev; + Error_Msg_SC ("unexpected identifier, possibly & was meant here"); + Scan; + end Merge_Identifier; + + ------------------- + -- Next_Token_Is -- + ------------------- + + function Next_Token_Is (Tok : Token_Type) return Boolean is + Scan_State : Saved_Scan_State; + Result : Boolean; + begin + Save_Scan_State (Scan_State); + Scan; + Result := (Token = Tok); + Restore_Scan_State (Scan_State); + return Result; + end Next_Token_Is; + + ------------------- + -- No_Constraint -- + ------------------- + + procedure No_Constraint is + begin + if Token in Token_Class_Consk then + Error_Msg_SC ("constraint not allowed here"); + Discard_Junk_Node (P_Constraint_Opt); + end if; + end No_Constraint; + + --------------------- + -- Pop_Scope_Stack -- + --------------------- + + procedure Pop_Scope_Stack is + begin + pragma Assert (Scope.Last > 0); + Scope.Decrement_Last; + + if Debug_Flag_P then + Error_Msg_Uint_1 := UI_From_Int (Scope.Last); + Error_Msg_SC ("decrement scope stack ptr, new value = ^!"); + end if; + end Pop_Scope_Stack; + + ---------------------- + -- Push_Scope_Stack -- + ---------------------- + + procedure Push_Scope_Stack is + begin + Scope.Increment_Last; + + if Style_Check_Max_Nesting_Level + and then Scope.Last = Style_Max_Nesting_Level + 1 + then + Error_Msg + ("(style) maximum nesting level exceeded", + First_Non_Blank_Location); + end if; + + Scope.Table (Scope.Last).Junk := False; + Scope.Table (Scope.Last).Node := Empty; + + if Debug_Flag_P then + Error_Msg_Uint_1 := UI_From_Int (Scope.Last); + Error_Msg_SC ("increment scope stack ptr, new value = ^!"); + end if; + end Push_Scope_Stack; + + ---------------------- + -- Separate_Present -- + ---------------------- + + function Separate_Present return Boolean is + Scan_State : Saved_Scan_State; + + begin + if Token = Tok_Separate then + return True; + + elsif Token /= Tok_Identifier then + return False; + + else + Save_Scan_State (Scan_State); + Scan; -- past identifier + + if Token = Tok_Semicolon then + Restore_Scan_State (Scan_State); + return Bad_Spelling_Of (Tok_Separate); + + else + Restore_Scan_State (Scan_State); + return False; + end if; + end if; + end Separate_Present; + + -------------------------- + -- Signal_Bad_Attribute -- + -------------------------- + + procedure Signal_Bad_Attribute is + begin + Error_Msg_N ("unrecognized attribute&", Token_Node); + + -- Check for possible misspelling + + Error_Msg_Name_1 := First_Attribute_Name; + while Error_Msg_Name_1 <= Last_Attribute_Name loop + if Is_Bad_Spelling_Of (Token_Name, Error_Msg_Name_1) then + Error_Msg_N -- CODEFIX + ("\possible misspelling of %", Token_Node); + exit; + end if; + + Error_Msg_Name_1 := Error_Msg_Name_1 + 1; + end loop; + end Signal_Bad_Attribute; + + ----------------------------- + -- Token_Is_At_End_Of_Line -- + ----------------------------- + + function Token_Is_At_End_Of_Line return Boolean is + S : Source_Ptr; + + begin + -- Skip past blanks and horizontal tabs + + S := Scan_Ptr; + while Source (S) = ' ' or else Source (S) = ASCII.HT loop + S := S + 1; + end loop; + + -- We are at end of line if at a control character (CR/LF/VT/FF/EOF) + -- or if we are at the start of an end of line comment sequence. + + return Source (S) < ' ' + or else (Source (S) = '-' and then Source (S + 1) = '-'); + end Token_Is_At_End_Of_Line; + + ------------------------------- + -- Token_Is_At_Start_Of_Line -- + ------------------------------- + + function Token_Is_At_Start_Of_Line return Boolean is + begin + return (Token_Ptr = First_Non_Blank_Location or else Token = Tok_EOF); + end Token_Is_At_Start_Of_Line; + +end Util; diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb new file mode 100644 index 000000000..776e6bd75 --- /dev/null +++ b/gcc/ada/par.adb @@ -0,0 +1,1541 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Aspects; use Aspects; +with Atree; use Atree; +with Casing; use Casing; +with Debug; use Debug; +with Elists; use Elists; +with Errout; use Errout; +with Fname; use Fname; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Output; use Output; +with Par_SCO; use Par_SCO; +with Scans; use Scans; +with Scn; use Scn; +with Sinput; use Sinput; +with Sinput.L; use Sinput.L; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Style; +with Stylesw; use Stylesw; +with Table; +with Tbuild; use Tbuild; + +--------- +-- Par -- +--------- + +function Par (Configuration_Pragmas : Boolean) return List_Id is + + Num_Library_Units : Natural := 0; + -- Count number of units parsed (relevant only in syntax check only mode, + -- since in semantics check mode only a single unit is permitted anyway) + + Save_Config_Switches : Config_Switches_Type; + -- Variable used to save values of config switches while we parse the + -- new unit, to be restored on exit for proper recursive behavior. + + Loop_Block_Count : Nat := 0; + -- Counter used for constructing loop/block names (see the routine + -- Par.Ch5.Get_Loop_Block_Name) + + -------------------- + -- Error Recovery -- + -------------------- + + -- When an error is encountered, a call is made to one of the Error_Msg + -- routines to record the error. If the syntax scan is not derailed by the + -- error (e.g. a complaint that logical operators are inconsistent in an + -- EXPRESSION), then control returns from the Error_Msg call, and the + -- parse continues unimpeded. + + -- If on the other hand, the Error_Msg represents a situation from which + -- the parser cannot recover locally, the exception Error_Resync is raised + -- immediately after the call to Error_Msg. Handlers for Error_Resync + -- are located at strategic points to resynchronize the parse. For example, + -- when an error occurs in a statement, the handler skips to the next + -- semicolon and continues the scan from there. + + -- Each parsing procedure contains a note with the heading "Error recovery" + -- which shows if it can propagate the Error_Resync exception. In order + -- not to propagate the exception, a procedure must either contain its own + -- handler for this exception, or it must not call any other routines which + -- propagate the exception. + + -- Note: the arrangement of Error_Resync handlers is such that it should + -- never be possible to transfer control through a procedure which made + -- an entry in the scope stack, invalidating the contents of the stack. + + Error_Resync : exception; + -- Exception raised on error that is not handled locally, see above + + Last_Resync_Point : Source_Ptr; + -- The resynchronization routines in Par.Sync run a risk of getting + -- stuck in an infinite loop if they do not skip a token, and the caller + -- keeps repeating the same resync call. On the other hand, if they skip + -- a token unconditionally, some recovery opportunities are missed. The + -- variable Last_Resync_Point records the token location previously set + -- by a Resync call, and if a subsequent Resync call occurs at the same + -- location, then the Resync routine does guarantee to skip a token. + + -------------------------------------------- + -- Handling Semicolon Used in Place of IS -- + -------------------------------------------- + + -- The following global variables are used in handling the error situation + -- of using a semicolon in place of IS in a subprogram declaration as in: + + -- procedure X (Y : Integer); + -- Q : Integer; + -- begin + -- ... + -- end; + + -- The two contexts in which this can appear are at the outer level, and + -- within a declarative region. At the outer level, we know something is + -- wrong as soon as we see the Q (or begin, if there are no declarations), + -- and we can immediately decide that the semicolon should have been IS. + + -- The situation in a declarative region is more complex. The declaration + -- of Q could belong to the outer region, and we do not know that we have + -- an error until we hit the begin. It is still not clear at this point + -- from a syntactic point of view that something is wrong, because the + -- begin could belong to the enclosing subprogram or package. However, we + -- can incorporate a bit of semantic knowledge and note that the body of + -- X is missing, so we definitely DO have an error. We diagnose this error + -- as semicolon in place of IS on the subprogram line. + + -- There are two styles for this diagnostic. If the begin immediately + -- follows the semicolon, then we can place a flag (IS expected) right + -- on the semicolon. Otherwise we do not detect the error until we hit + -- the begin which refers back to the line with the semicolon. + + -- To control the process in the second case, the following global + -- variables are set to indicate that we have a subprogram declaration + -- whose body is required and has not yet been found. The prefix SIS + -- stands for "Subprogram IS" handling. + + SIS_Entry_Active : Boolean := False; + -- Set True to indicate that an entry is active (i.e. that a subprogram + -- declaration has been encountered, and no body for this subprogram has + -- been encountered). The remaining fields are valid only if this is True. + + SIS_Labl : Node_Id; + -- Subprogram designator + + SIS_Sloc : Source_Ptr; + -- Source location of FUNCTION/PROCEDURE keyword + + SIS_Ecol : Column_Number; + -- Column number of FUNCTION/PROCEDURE keyword + + SIS_Semicolon_Sloc : Source_Ptr; + -- Source location of semicolon at end of subprogram declaration + + SIS_Declaration_Node : Node_Id; + -- Pointer to tree node for subprogram declaration + + SIS_Missing_Semicolon_Message : Error_Msg_Id; + -- Used to save message ID of missing semicolon message (which will be + -- modified to missing IS if necessary). Set to No_Error_Msg in the + -- normal (non-error) case. + + -- Five things can happen to an active SIS entry + + -- 1. If a BEGIN is encountered with an SIS entry active, then we have + -- exactly the situation in which we know the body of the subprogram is + -- missing. After posting an error message, we change the spec to a body, + -- rechaining the declarations that intervened between the spec and BEGIN. + + -- 2. Another subprogram declaration or body is encountered. In this + -- case the entry gets overwritten with the information for the new + -- subprogram declaration. We don't catch some nested cases this way, + -- but it doesn't seem worth the effort. + + -- 3. A nested declarative region (e.g. package declaration or package + -- body) is encountered. The SIS active indication is reset at the start + -- of such a nested region. Again, like case 2, this causes us to miss + -- some nested cases, but it doesn't seen worth the effort to stack and + -- unstack the SIS information. Maybe we will reconsider this if we ever + -- get a complaint about a missed case. + + -- 4. We encounter a valid pragma INTERFACE or IMPORT that effectively + -- supplies the missing body. In this case we reset the entry. + + -- 5. We encounter the end of the declarative region without encountering + -- a BEGIN first. In this situation we simply reset the entry. We know + -- that there is a missing body, but it seems more reasonable to let the + -- later semantic checking discover this. + + ---------------------------------------------------- + -- Handling of Reserved Words Used as Identifiers -- + ---------------------------------------------------- + + -- Note: throughout the parser, the terms reserved word and keyword are + -- used interchangeably to refer to the same set of reserved keywords + -- (including until, protected, etc). + + -- If a reserved word is used in place of an identifier, the parser where + -- possible tries to recover gracefully. In particular, if the keyword is + -- clearly spelled using identifier casing, e.g. Until in a source program + -- using mixed case identifiers and lower case keywords, then the keyword + -- is treated as an identifier if it appears in a place where an identifier + -- is required. + + -- The situation is more complex if the keyword is spelled with normal + -- keyword casing. In this case, the parser is more reluctant to consider + -- it to be intended as an identifier, unless it has some further + -- confirmation. + + -- In the case of an identifier appearing in the identifier list of a + -- declaration, the appearance of a comma or colon right after the keyword + -- on the same line is taken as confirmation. For an enumeration literal, + -- a comma or right paren right after the identifier is also treated as + -- adequate confirmation. + + -- The following type is used in calls to Is_Reserved_Identifier and + -- also to P_Defining_Identifier and P_Identifier. The default for all + -- these functions is that reserved words in reserved word case are not + -- considered to be reserved identifiers. The Id_Check value indicates + -- tokens, which if they appear immediately after the identifier, are + -- taken as confirming that the use of an identifier was expected + + type Id_Check is + (None, + -- Default, no special token test + + C_Comma_Right_Paren, + -- Consider as identifier if followed by comma or right paren + + C_Comma_Colon, + -- Consider as identifier if followed by comma or colon + + C_Do, + -- Consider as identifier if followed by DO + + C_Dot, + -- Consider as identifier if followed by period + + C_Greater_Greater, + -- Consider as identifier if followed by >> + + C_In, + -- Consider as identifier if followed by IN + + C_Is, + -- Consider as identifier if followed by IS + + C_Left_Paren_Semicolon, + -- Consider as identifier if followed by left paren or semicolon + + C_Use, + -- Consider as identifier if followed by USE + + C_Vertical_Bar_Arrow); + -- Consider as identifier if followed by | or => + + -------------------------------------------- + -- Handling IS Used in Place of Semicolon -- + -------------------------------------------- + + -- This is a somewhat trickier situation, and we can't catch it in all + -- cases, but we do our best to detect common situations resulting from + -- a "cut and paste" operation which forgets to change the IS to semicolon. + -- Consider the following example: + + -- package body X is + -- procedure A; + -- procedure B is + -- procedure C; + -- ... + -- procedure D is + -- begin + -- ... + -- end; + -- begin + -- ... + -- end; + + -- The trouble is that the section of text from PROCEDURE B through END; + -- constitutes a valid procedure body, and the danger is that we find out + -- far too late that something is wrong (indeed most compilers will behave + -- uncomfortably on the above example). + + -- We have two approaches to helping to control this situation. First we + -- make every attempt to avoid swallowing the last END; if we can be sure + -- that some error will result from doing so. In particular, we won't + -- accept the END; unless it is exactly correct (in particular it must not + -- have incorrect name tokens), and we won't accept it if it is immediately + -- followed by end of file, WITH or SEPARATE (all tokens that unmistakeably + -- signal the start of a compilation unit, and which therefore allow us to + -- reserve the END; for the outer level.) For more details on this aspect + -- of the handling, see package Par.Endh. + + -- If we can avoid eating up the END; then the result in the absence of + -- any additional steps would be to post a missing END referring back to + -- the subprogram with the bogus IS. Similarly, if the enclosing package + -- has no BEGIN, then the result is a missing BEGIN message, which again + -- refers back to the subprogram header. + + -- Such an error message is not too bad (it's already a big improvement + -- over what many parsers do), but it's not ideal, because the declarations + -- following the IS have been absorbed into the wrong scope. In the above + -- case, this could result for example in a bogus complaint that the body + -- of D was missing from the package. + + -- To catch at least some of these cases, we take the following additional + -- steps. First, a subprogram body is marked as having a suspicious IS if + -- the declaration line is followed by a line which starts with a symbol + -- that can start a declaration in the same column, or to the left of the + -- column in which the FUNCTION or PROCEDURE starts (normal style is to + -- indent any declarations which really belong a subprogram). If such a + -- subprogram encounters a missing BEGIN or missing END, then we decide + -- that the IS should have been a semicolon, and the subprogram body node + -- is marked (by setting the Bad_Is_Detected flag true. Note that we do + -- not do this for library level procedures, only for nested procedures, + -- since for library level procedures, we must have a body. + + -- The processing for a declarative part checks to see if the last + -- declaration scanned is marked in this way, and if it is, the tree + -- is modified to reflect the IS being interpreted as a semicolon. + + --------------------------------------------------- + -- Parser Type Definitions and Control Variables -- + --------------------------------------------------- + + -- The following variable and associated type declaration are used by the + -- expression parsing routines to return more detailed information about + -- the categorization of a parsed expression. + + type Expr_Form_Type is ( + EF_Simple_Name, -- Simple name, i.e. possibly qualified identifier + EF_Name, -- Simple expression which could also be a name + EF_Simple, -- Simple expression which is not call or name + EF_Range_Attr, -- Range attribute reference + EF_Non_Simple); -- Expression that is not a simple expression + + Expr_Form : Expr_Form_Type; + + -- The following type is used for calls to P_Subprogram, P_Package, P_Task, + -- P_Protected to indicate which of several possibilities is acceptable. + + type Pf_Rec is record + Spcn : Boolean; -- True if specification OK + Decl : Boolean; -- True if declaration OK + Gins : Boolean; -- True if generic instantiation OK + Pbod : Boolean; -- True if proper body OK + Rnam : Boolean; -- True if renaming declaration OK + Stub : Boolean; -- True if body stub OK + Pexp : Boolean; -- True if parametrized expression OK + Fil2 : Boolean; -- Filler to fill to 8 bits + end record; + pragma Pack (Pf_Rec); + + function T return Boolean renames True; + function F return Boolean renames False; + + Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp : constant Pf_Rec := + Pf_Rec'(F, T, T, T, T, T, T, F); + Pf_Decl_Pexp : constant Pf_Rec := + Pf_Rec'(F, T, F, F, F, F, T, F); + Pf_Decl_Gins_Pbod_Rnam_Pexp : constant Pf_Rec := + Pf_Rec'(F, T, T, T, T, F, T, F); + Pf_Decl_Pbod_Pexp : constant Pf_Rec := + Pf_Rec'(F, T, F, T, F, F, T, F); + Pf_Pbod_Pexp : constant Pf_Rec := + Pf_Rec'(F, F, F, T, F, F, T, F); + Pf_Spcn : constant Pf_Rec := + Pf_Rec'(T, F, F, F, F, F, F, F); + -- The above are the only allowed values of Pf_Rec arguments + + type SS_Rec is record + Eftm : Boolean; -- ELSIF can terminate sequence + Eltm : Boolean; -- ELSE can terminate sequence + Extm : Boolean; -- EXCEPTION can terminate sequence + Ortm : Boolean; -- OR can terminate sequence + Sreq : Boolean; -- at least one statement required + Tatm : Boolean; -- THEN ABORT can terminate sequence + Whtm : Boolean; -- WHEN can terminate sequence + Unco : Boolean; -- Unconditional terminate after one statement + end record; + pragma Pack (SS_Rec); + + SS_Eftm_Eltm_Sreq : constant SS_Rec := SS_Rec'(T, T, F, F, T, F, F, F); + SS_Eltm_Ortm_Tatm : constant SS_Rec := SS_Rec'(F, T, F, T, F, T, F, F); + SS_Extm_Sreq : constant SS_Rec := SS_Rec'(F, F, T, F, T, F, F, F); + SS_None : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, F, F); + SS_Ortm_Sreq : constant SS_Rec := SS_Rec'(F, F, F, T, T, F, F, F); + SS_Sreq : constant SS_Rec := SS_Rec'(F, F, F, F, T, F, F, F); + SS_Sreq_Whtm : constant SS_Rec := SS_Rec'(F, F, F, F, T, F, T, F); + SS_Whtm : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, T, F); + SS_Unco : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, F, T); + + Goto_List : Elist_Id; + -- List of goto nodes appearing in the current compilation. Used to + -- recognize natural loops and convert them into bona fide loops for + -- optimization purposes. + + Label_List : Elist_Id; + -- List of label nodes for labels appearing in the current compilation. + -- Used by Par.Labl to construct the corresponding implicit declarations. + + ----------------- + -- Scope Table -- + ----------------- + + -- The scope table, also referred to as the scope stack, is used to record + -- the current scope context. It is organized as a stack, with inner nested + -- entries corresponding to higher entries on the stack. An entry is made + -- when the parser encounters the opening of a nested construct (such as a + -- record, task, package etc.), and then package Par.Endh uses this stack + -- to deal with END lines (including properly dealing with END nesting + -- errors). + + type SS_End_Type is + -- Type of end entry required for this scope. The last two entries are + -- used only in the subprogram body case to mark the case of a suspicious + -- IS, or a bad IS (i.e. suspicions confirmed by missing BEGIN or END). + -- See separate section on dealing with IS used in place of semicolon. + -- Note that for many purposes E_Name, E_Suspicious_Is and E_Bad_Is are + -- treated the same (E_Suspicious_Is and E_Bad_Is are simply special cases + -- of E_Name). They are placed at the end of the enumeration so that a + -- test for >= E_Name catches all three cases efficiently. + + (E_Dummy, -- dummy entry at outer level + E_Case, -- END CASE; + E_If, -- END IF; + E_Loop, -- END LOOP; + E_Record, -- END RECORD; + E_Return, -- END RETURN; + E_Select, -- END SELECT; + E_Name, -- END [name]; + E_Suspicious_Is, -- END [name]; (case of suspicious IS) + E_Bad_Is); -- END [name]; (case of bad IS) + + -- The following describes a single entry in the scope table + + type Scope_Table_Entry is record + Etyp : SS_End_Type; + -- Type of end entry, as per above description + + Lreq : Boolean; + -- A flag indicating whether the label, if present, is required to + -- appear on the end line. It is referenced only in the case of Etyp is + -- equal to E_Name or E_Suspicious_Is where the name may or may not be + -- required (yes for labeled block, no in other cases). Note that for + -- all cases except begin, the question of whether a label is required + -- can be determined from the other fields (for loop, it is required if + -- it is present, and for the other constructs it is never required or + -- allowed). + + Ecol : Column_Number; + -- Contains the absolute column number (with tabs expanded) of the + -- expected column of the end assuming normal Ada indentation usage. If + -- the RM_Column_Check mode is set, this value is used for generating + -- error messages about indentation. Otherwise it is used only to + -- control heuristic error recovery actions. + + Labl : Node_Id; + -- This field is used only for the LOOP and BEGIN cases, and is the + -- Node_Id value of the label name. For all cases except child units, + -- this value is an entity whose Chars field contains the name pointer + -- that identifies the label uniquely. For the child unit case the Labl + -- field references an N_Defining_Program_Unit_Name node for the name. + -- For cases other than LOOP or BEGIN, the Label field is set to Error, + -- indicating that it is an error to have a label on the end line. + -- (this is really a misuse of Error since there is no Error ???) + + Decl : List_Id; + -- Points to the list of declarations (i.e. the declarative part) + -- associated with this construct. It is set only in the END [name] + -- cases, and is set to No_List for all other cases which do not have a + -- declarative unit associated with them. This is used for determining + -- the proper location for implicit label declarations. + + Node : Node_Id; + -- Empty except in the case of entries for IF and CASE statements, in + -- which case it contains the N_If_Statement or N_Case_Statement node. + -- This is used for setting the End_Span field. + + Sloc : Source_Ptr; + -- Source location of the opening token of the construct. This is used + -- to refer back to this line in error messages (such as missing or + -- incorrect end lines). The Sloc field is not used, and is not set, if + -- a label is present (the Labl field provides the text name of the + -- label in this case, which is fine for error messages). + + S_Is : Source_Ptr; + -- S_Is is relevant only if Etyp is set to E_Suspicious_Is or E_Bad_Is. + -- It records the location of the IS that is considered to be + -- suspicious. + + Junk : Boolean; + -- A boolean flag that is set true if the opening entry is the dubious + -- result of some prior error, e.g. a record entry where the record + -- keyword was missing. It is used to suppress the issuing of a + -- corresponding junk complaint about the end line (we do not want + -- to complain about a missing end record when there was no record). + end record; + + -- The following declares the scope table itself. The Last field is the + -- stack pointer, so that Scope.Table (Scope.Last) is the top entry. The + -- oldest entry, at Scope_Stack (0), is a dummy entry with Etyp set to + -- E_Dummy, and the other fields undefined. This dummy entry ensures that + -- Scope_Stack (Scope_Stack_Ptr).Etyp can always be tested, and that the + -- scope stack pointer is always in range. + + package Scope is new Table.Table ( + Table_Component_Type => Scope_Table_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 50, + Table_Increment => 100, + Table_Name => "Scope"); + + --------------------------------- + -- Parsing Routines by Chapter -- + --------------------------------- + + -- Uncommented declarations in this section simply parse the construct + -- corresponding to their name, and return an ID value for the Node or + -- List that is created. + + ------------- + -- Par.Ch2 -- + ------------- + + package Ch2 is + function P_Pragma (Skipping : Boolean := False) return Node_Id; + -- Scan out a pragma. If Skipping is True, then the caller is skipping + -- the pragma in the context of illegal placement (this is used to avoid + -- some junk cascaded messages). + + function P_Identifier (C : Id_Check := None) return Node_Id; + -- Scans out an identifier. The parameter C determines the treatment + -- of reserved identifiers. See declaration of Id_Check for details. + + function P_Pragmas_Opt return List_Id; + -- This function scans for a sequence of pragmas in other than a + -- declaration sequence or statement sequence context. All pragmas + -- can appear except pragmas Assert and Debug, which are only allowed + -- in a declaration or statement sequence context. + + procedure P_Pragmas_Misplaced; + -- Skips misplaced pragmas with a complaint + + procedure P_Pragmas_Opt (List : List_Id); + -- Parses optional pragmas and appends them to the List + end Ch2; + + ------------- + -- Par.Ch3 -- + ------------- + + package Ch3 is + Missing_Begin_Msg : Error_Msg_Id; + -- This variable is set by a call to P_Declarative_Part. Normally it + -- is set to No_Error_Msg, indicating that no special processing is + -- required by the caller. The special case arises when a statement + -- is found in the sequence of declarations. In this case the Id of + -- the message issued ("declaration expected") is preserved in this + -- variable, then the caller can change it to an appropriate missing + -- begin message if indeed the BEGIN is missing. + + function P_Array_Type_Definition return Node_Id; + function P_Basic_Declarative_Items return List_Id; + function P_Constraint_Opt return Node_Id; + function P_Declarative_Part return List_Id; + function P_Discrete_Choice_List return List_Id; + function P_Discrete_Range return Node_Id; + function P_Discrete_Subtype_Definition return Node_Id; + function P_Known_Discriminant_Part_Opt return List_Id; + function P_Signed_Integer_Type_Definition return Node_Id; + function P_Range return Node_Id; + function P_Range_Constraint return Node_Id; + function P_Record_Definition return Node_Id; + function P_Subtype_Mark return Node_Id; + function P_Subtype_Mark_Resync return Node_Id; + function P_Unknown_Discriminant_Part_Opt return Boolean; + + function P_Access_Definition + (Null_Exclusion_Present : Boolean) return Node_Id; + -- Ada 2005 (AI-231/AI-254): The caller parses the null-exclusion part + -- and indicates if it was present + + function P_Access_Type_Definition + (Header_Already_Parsed : Boolean := False) return Node_Id; + -- Ada 2005 (AI-254): The formal is used to indicate if the caller has + -- parsed the null_exclusion part. In this case the caller has also + -- removed the ACCESS token + + procedure P_Component_Items (Decls : List_Id); + -- Scan out one or more component items and append them to the given + -- list. Only scans out more than one declaration in the case where the + -- source has a single declaration with multiple defining identifiers. + + function P_Defining_Identifier (C : Id_Check := None) return Node_Id; + -- Scan out a defining identifier. The parameter C controls the + -- treatment of errors in case a reserved word is scanned. See the + -- declaration of this type for details. + + function P_Interface_Type_Definition + (Abstract_Present : Boolean) return Node_Id; + -- Ada 2005 (AI-251): Parse the interface type definition part. Abstract + -- Present indicates if the reserved word "abstract" has been previously + -- found. It is used to report an error message because interface types + -- are by definition abstract tagged. We generate a record_definition + -- node if the list of interfaces is empty; otherwise we generate a + -- derived_type_definition node (the first interface in this list is the + -- ancestor interface). + + function P_Null_Exclusion + (Allow_Anonymous_In_95 : Boolean := False) return Boolean; + -- Ada 2005 (AI-231): Parse the null-excluding part. A True result + -- indicates that the null-excluding part was present. + -- + -- Allow_Anonymous_In_95 is True if we are in a context that allows + -- anonymous access types in Ada 95, in which case "not null" is legal + -- if it precedes "access". + + function P_Subtype_Indication + (Not_Null_Present : Boolean := False) return Node_Id; + -- Ada 2005 (AI-231): The flag Not_Null_Present indicates that the + -- null-excluding part has been scanned out and it was present. + + function P_Range_Or_Subtype_Mark + (Allow_Simple_Expression : Boolean := False) return Node_Id; + -- Scans out a range or subtype mark, and also permits a general simple + -- expression if Allow_Simple_Expression is set to True. + + function Init_Expr_Opt (P : Boolean := False) return Node_Id; + -- If an initialization expression is present (:= expression), then + -- it is scanned out and returned, otherwise Empty is returned if no + -- initialization expression is present. This procedure also handles + -- certain common error cases cleanly. The parameter P indicates if + -- a right paren can follow the expression (default = no right paren + -- allowed). + + procedure Skip_Declaration (S : List_Id); + -- Used when scanning statements to skip past a misplaced declaration + -- The declaration is scanned out and appended to the given list. + -- Token is known to be a declaration token (in Token_Class_Declk) + -- on entry, so there definition is a declaration to be scanned. + + function P_Subtype_Indication + (Subtype_Mark : Node_Id; + Not_Null_Present : Boolean := False) return Node_Id; + -- This version of P_Subtype_Indication is called when the caller has + -- already scanned out the subtype mark which is passed as a parameter. + -- Ada 2005 (AI-231): The flag Not_Null_Present indicates that the + -- null-excluding part has been scanned out and it was present. + + function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id; + -- Parse a subtype mark attribute. The caller has already parsed the + -- subtype mark, which is passed in as the argument, and has checked + -- that the current token is apostrophe. + end Ch3; + + ------------- + -- Par.Ch4 -- + ------------- + + package Ch4 is + function P_Aggregate return Node_Id; + function P_Expression return Node_Id; + function P_Expression_Or_Range_Attribute return Node_Id; + function P_Function_Name return Node_Id; + function P_Name return Node_Id; + function P_Qualified_Simple_Name return Node_Id; + function P_Qualified_Simple_Name_Resync return Node_Id; + function P_Simple_Expression return Node_Id; + function P_Simple_Expression_Or_Range_Attribute return Node_Id; + + function P_Case_Expression return Node_Id; + -- Scans out a case expression. Called with Token pointing to the CASE + -- keyword, and returns pointing to the terminating right parent, + -- semicolon, or comma, but does not consume this terminating token. + + function P_Conditional_Expression return Node_Id; + -- Scans out a conditional expression. Called with Token pointing to + -- the IF keyword, and returns pointing to the terminating right paren, + -- semicolon or comma, but does not consume this terminating token. + + function P_Expression_If_OK return Node_Id; + -- Scans out an expression in a context where a conditional expression + -- is permitted to appear without surrounding parentheses. + + function P_Expression_No_Right_Paren return Node_Id; + -- Scans out an expression in contexts where the expression cannot be + -- terminated by a right paren (gives better error recovery if an errant + -- right paren is found after the expression). + + function P_Expression_Or_Range_Attribute_If_OK return Node_Id; + -- Scans out an expression or range attribute where a conditional + -- expression is permitted to appear without surrounding parentheses. + + function P_Qualified_Expression (Subtype_Mark : Node_Id) return Node_Id; + -- This routine scans out a qualified expression when the caller has + -- already scanned out the name and apostrophe of the construct. + + function P_Quantified_Expression return Node_Id; + -- This routine scans out a quantified expression when the caller has + -- already scanned out the keyword "for" of the construct. + end Ch4; + + ------------- + -- Par.Ch5 -- + ------------- + + package Ch5 is + function P_Condition return Node_Id; + -- Scan out and return a condition + + function P_Loop_Parameter_Specification return Node_Id; + -- Used in loop constructs and quantified expressions. + + function P_Statement_Name (Name_Node : Node_Id) return Node_Id; + -- Given a node representing a name (which is a call), converts it + -- to the syntactically corresponding procedure call statement. + + function P_Sequence_Of_Statements (SS_Flags : SS_Rec) return List_Id; + -- The argument indicates the acceptable termination tokens. + -- See body in Par.Ch5 for details of the use of this parameter. + + procedure Parse_Decls_Begin_End (Parent : Node_Id); + -- Parses declarations and handled statement sequence, setting + -- fields of Parent node appropriately. + end Ch5; + + ------------- + -- Par.Ch6 -- + ------------- + + package Ch6 is + function P_Designator return Node_Id; + function P_Defining_Program_Unit_Name return Node_Id; + function P_Formal_Part return List_Id; + function P_Parameter_Profile return List_Id; + function P_Return_Statement return Node_Id; + function P_Subprogram_Specification return Node_Id; + + procedure P_Mode (Node : Node_Id); + -- Sets In_Present and/or Out_Present flags in Node scanning past IN, + -- OUT or IN OUT tokens in the source. + + function P_Subprogram (Pf_Flags : Pf_Rec) return Node_Id; + -- Scans out any construct starting with either of the keywords + -- PROCEDURE or FUNCTION. The parameter indicates which possible + -- possible kinds of construct (body, spec, instantiation etc.) + -- are permissible in the current context. + end Ch6; + + ------------- + -- Par.Ch7 -- + ------------- + + package Ch7 is + function P_Package + (Pf_Flags : Pf_Rec; + Decl : Node_Id := Empty) return Node_Id; + -- Scans out any construct starting with the keyword PACKAGE. The + -- parameter indicates which possible kinds of construct (body, spec, + -- instantiation etc.) are permissible in the current context. Decl + -- is set in the specification case to request that if there are aspect + -- specifications present, they be associated with this declaration. + end Ch7; + + ------------- + -- Par.Ch8 -- + ------------- + + package Ch8 is + function P_Use_Clause return Node_Id; + end Ch8; + + ------------- + -- Par.Ch9 -- + ------------- + + package Ch9 is + function P_Abort_Statement return Node_Id; + function P_Abortable_Part return Node_Id; + function P_Accept_Statement return Node_Id; + function P_Delay_Statement return Node_Id; + function P_Entry_Body return Node_Id; + function P_Protected return Node_Id; + function P_Requeue_Statement return Node_Id; + function P_Select_Statement return Node_Id; + function P_Task return Node_Id; + function P_Terminate_Alternative return Node_Id; + end Ch9; + + -------------- + -- Par.Ch10 -- + -------------- + + package Ch10 is + function P_Compilation_Unit return Node_Id; + -- Note: this function scans a single compilation unit, and checks that + -- an end of file follows this unit, diagnosing any unexpected input as + -- an error, and then skipping it, so that Token is set to Tok_EOF on + -- return. An exception is in syntax-only mode, where multiple + -- compilation units are permitted. In this case, P_Compilation_Unit + -- does not check for end of file and there may be more compilation + -- units to scan. The caller can uniquely detect this situation by the + -- fact that Token is not set to Tok_EOF on return. + -- + -- What about multiple unit/file capability that now exists??? + -- + -- The Ignore parameter is normally set False. It is set True in the + -- multiple unit per file mode if we are skipping past a unit that we + -- are not interested in. + end Ch10; + + -------------- + -- Par.Ch11 -- + -------------- + + package Ch11 is + function P_Handled_Sequence_Of_Statements return Node_Id; + function P_Raise_Statement return Node_Id; + + function Parse_Exception_Handlers return List_Id; + -- Parses the partial construct EXCEPTION followed by a list of + -- exception handlers which appears in a number of productions, and + -- returns the list of exception handlers. + end Ch11; + + -------------- + -- Par.Ch12 -- + -------------- + + package Ch12 is + function P_Generic return Node_Id; + function P_Generic_Actual_Part_Opt return List_Id; + end Ch12; + + -------------- + -- Par.Ch13 -- + -------------- + + package Ch13 is + function P_Representation_Clause return Node_Id; + + function Aspect_Specifications_Present + (Strict : Boolean := Ada_Version < Ada_2012) return Boolean; + -- This function tests whether the next keyword is WITH followed by + -- something that looks reasonably like an aspect specification. If so, + -- True is returned. Otherwise False is returned. In either case control + -- returns with the token pointer unchanged (i.e. pointing to the WITH + -- token in the case where True is returned). This function takes care + -- of generating appropriate messages if aspect specifications appear + -- in versions of Ada prior to Ada 2012. The parameter strict can be + -- set to True, to be rather strict about considering something to be + -- an aspect specification. If Strict is False, then the circuitry is + -- rather more generous in considering something ill-formed to be an + -- attempt at an aspect specification. The default is more strict for + -- Ada versions before Ada 2012 (where aspect specifications are not + -- permitted). + + procedure P_Aspect_Specifications (Decl : Node_Id); + -- This subprogram is called with the current token pointing to either a + -- WITH keyword starting an aspect specification, or a semicolon. In the + -- former case, the aspect specifications are scanned out including the + -- terminating semicolon, the Has_Aspect_Specifications flag is set in + -- the given declaration node, and the list of aspect specifications is + -- constructed and associated with this declaration node using a call to + -- Set_Aspect_Specifications. If no WITH keyword is present, then this + -- call has no effect other than scanning out the semicolon. If Decl is + -- Error on entry, any scanned aspect specifications are ignored and a + -- message is output saying aspect specifications not permitted here. + + function P_Code_Statement (Subtype_Mark : Node_Id) return Node_Id; + -- Function to parse a code statement. The caller has scanned out + -- the name to be used as the subtype mark (but has not checked that + -- it is suitable for use as a subtype mark, i.e. is either an + -- identifier or a selected component). The current token is an + -- apostrophe and the following token is either a left paren or + -- RANGE (the latter being an error to be caught by P_Code_Statement. + end Ch13; + + -- Note: the parsing for annexe J features (i.e. obsolescent features) + -- is found in the logical section where these features would be if + -- they were not obsolescent. In particular: + + -- Delta constraint is parsed by P_Delta_Constraint (3.5.9) + -- At clause is parsed by P_At_Clause (13.1) + -- Mod clause is parsed by P_Mod_Clause (13.5.1) + + -------------- + -- Par.Endh -- + -------------- + + -- Routines for handling end lines, including scope recovery + + package Endh is + function Check_End (Decl : Node_Id := Empty) return Boolean; + -- Called when an end sequence is required. In the absence of an error + -- situation, Token contains Tok_End on entry, but in a missing end + -- case, this may not be the case. Pop_End_Context is used to determine + -- the appropriate action to be taken. The returned result is True if + -- an End sequence was encountered and False if no End sequence was + -- present. This occurs if the END keyword encountered was determined + -- to be improper and deleted (i.e. Pop_End_Context set End_Action to + -- Skip_And_Reject). Note that the END sequence includes a semicolon, + -- except in the case of END RECORD, where a semicolon follows the END + -- RECORD, but is not part of the record type definition itself. + -- + -- If Decl is non-empty, then aspect specifications are permitted + -- following the end, and Decl is the declaration node with which + -- these aspect specifications are to be associated. + + procedure End_Skip; + -- Skip past an end sequence. On entry Token contains Tok_End, and we + -- we know that the end sequence is syntactically incorrect, and that + -- an appropriate error message has already been posted. The mission + -- is simply to position the scan pointer to be the best guess of the + -- position after the end sequence. We do not issue any additional + -- error messages while carrying this out. + + procedure End_Statements + (Parent : Node_Id := Empty; + Decl : Node_Id := Empty); + -- Called when an end is required or expected to terminate a sequence + -- of statements. The caller has already made an appropriate entry in + -- the Scope.Table to describe the expected form of the end. This can + -- only be used in cases where the only appropriate terminator is end. + -- If Parent is non-empty, then if a correct END line is encountered, + -- the End_Label field of Parent is set appropriately. + -- + -- If Decl is non-null, then it is a declaration node, and aspect + -- specifications are permitted after the end statement. These aspect + -- specifications, if present, are stored in this declaration node. + end Endh; + + -------------- + -- Par.Sync -- + -------------- + + -- These procedures are used to resynchronize after errors. Following an + -- error which is not immediately locally recoverable, the exception + -- Error_Resync is raised. The handler for Error_Resync typically calls + -- one of these recovery procedures to resynchronize the source position + -- to a point from which parsing can be restarted. + + -- Note: these procedures output an information message that tokens are + -- being skipped, but this message is output only if the option for + -- Multiple_Errors_Per_Line is set in Options. + + package Sync is + procedure Resync_Choice; + -- Used if an error occurs scanning a choice. The scan pointer is + -- advanced to the next vertical bar, arrow, or semicolon, whichever + -- comes first. We also quit if we encounter an end of file. + + procedure Resync_Expression; + -- Used if an error is detected during the parsing of an expression. + -- It skips past tokens until either a token which cannot be part of + -- an expression is encountered (an expression terminator), or if a + -- comma or right parenthesis or vertical bar is encountered at the + -- current parenthesis level (a parenthesis level counter is maintained + -- to carry out this test). + + procedure Resync_Past_Semicolon; + -- Used if an error occurs while scanning a sequence of declarations. + -- The scan pointer is positioned past the next semicolon and the scan + -- resumes. The scan is also resumed on encountering a token which + -- starts a declaration (but we make sure to skip at least one token + -- in this case, to avoid getting stuck in a loop). + + procedure Resync_To_Semicolon; + -- Similar to Resync_Past_Semicolon, except that the scan pointer is + -- left pointing to the semicolon rather than past it. + + procedure Resync_Past_Semicolon_Or_To_Loop_Or_Then; + -- Used if an error occurs while scanning a sequence of statements. The + -- scan pointer is positioned past the next semicolon, or to the next + -- occurrence of either then or loop, and the scan resumes. + + procedure Resync_To_When; + -- Used when an error occurs scanning an entry index specification. The + -- scan pointer is positioned to the next WHEN (or to IS or semicolon if + -- either of these appear before WHEN, indicating another error has + -- occurred). + + procedure Resync_Semicolon_List; + -- Used if an error occurs while scanning a parenthesized list of items + -- separated by semicolons. The scan pointer is advanced to the next + -- semicolon or right parenthesis at the outer parenthesis level, or + -- to the next is or RETURN keyword occurrence, whichever comes first. + + procedure Resync_Cunit; + -- Synchronize to next token which could be the start of a compilation + -- unit, or to the end of file token. + end Sync; + + -------------- + -- Par.Tchk -- + -------------- + + -- Routines to check for expected tokens + + package Tchk is + + -- Procedures with names of the form T_xxx, where Tok_xxx is a token + -- name, check that the current token matches the required token, and + -- if so, scan past it. If not, an error is issued indicating that + -- the required token is not present (xxx expected). In most cases, the + -- scan pointer is not moved in the not-found case, but there are some + -- exceptions to this, see for example T_Id, where the scan pointer is + -- moved across a literal appearing where an identifier is expected. + + procedure T_Abort; + procedure T_Arrow; + procedure T_At; + procedure T_Body; + procedure T_Box; + procedure T_Colon; + procedure T_Colon_Equal; + procedure T_Comma; + procedure T_Dot_Dot; + procedure T_For; + procedure T_Greater_Greater; + procedure T_Identifier; + procedure T_In; + procedure T_Is; + procedure T_Left_Paren; + procedure T_Loop; + procedure T_Mod; + procedure T_New; + procedure T_Of; + procedure T_Or; + procedure T_Private; + procedure T_Range; + procedure T_Record; + procedure T_Right_Paren; + procedure T_Semicolon; + procedure T_Then; + procedure T_Type; + procedure T_Use; + procedure T_When; + procedure T_With; + + -- Procedures having names of the form TF_xxx, where Tok_xxx is a token + -- name check that the current token matches the required token, and + -- if so, scan past it. If not, an error message is issued indicating + -- that the required token is not present (xxx expected). + + -- If the missing token is at the end of the line, then control returns + -- immediately after posting the message. If there are remaining tokens + -- on the current line, a search is conducted to see if the token + -- appears later on the current line, as follows: + + -- A call to Scan_Save is issued and a forward search for the token + -- is carried out. If the token is found on the current line before a + -- semicolon, then it is scanned out and the scan continues from that + -- point. If not the scan is restored to the point where it was missing. + + procedure TF_Arrow; + procedure TF_Is; + procedure TF_Loop; + procedure TF_Return; + procedure TF_Semicolon; + procedure TF_Then; + procedure TF_Use; + + -- Procedures with names of the form U_xxx, where Tok_xxx is a token + -- name, are just like the corresponding T_xxx procedures except that + -- an error message, if given, is unconditional. + + procedure U_Left_Paren; + procedure U_Right_Paren; + end Tchk; + + -------------- + -- Par.Util -- + -------------- + + package Util is + function Bad_Spelling_Of (T : Token_Type) return Boolean; + -- This function is called in an error situation. It checks if the + -- current token is an identifier whose name is a plausible bad + -- spelling of the given keyword token, and if so, issues an error + -- message, sets Token from T, and returns True. Otherwise Token is + -- unchanged, and False is returned. + + procedure Check_Bad_Layout; + -- Check for bad indentation in RM checking mode. Used for statements + -- and declarations. Checks if current token is at start of line and + -- is exdented from the current expected end column, and if so an + -- error message is generated. + + procedure Check_Misspelling_Of (T : Token_Type); + pragma Inline (Check_Misspelling_Of); + -- This is similar to the function above, except that it does not + -- return a result. It is typically used in a situation where any + -- identifier is an error, and it makes sense to simply convert it + -- to the given token if it is a plausible misspelling of it. + + procedure Check_95_Keyword (Token_95, Next : Token_Type); + -- This routine checks if the token after the current one matches the + -- Next argument. If so, the scan is backed up to the current token + -- and Token_Type is changed to Token_95 after issuing an appropriate + -- error message ("(Ada 83) keyword xx cannot be used"). If not, + -- the scan is backed up with Token_Type unchanged. This routine + -- is used to deal with an attempt to use a 95 keyword in Ada 83 + -- mode. The caller has typically checked that the current token, + -- an identifier, matches one of the 95 keywords. + + procedure Check_Simple_Expression (E : Node_Id); + -- Given an expression E, that has just been scanned, so that Expr_Form + -- is still set, outputs an error if E is a non-simple expression. E is + -- not modified by this call. + + procedure Check_Simple_Expression_In_Ada_83 (E : Node_Id); + -- Like Check_Simple_Expression, except that the error message is only + -- given when operating in Ada 83 mode, and includes "in Ada 83". + + function Check_Subtype_Mark (Mark : Node_Id) return Node_Id; + -- Called to check that a node representing a name (or call) is + -- suitable for a subtype mark, i.e, that it is an identifier or + -- a selected component. If so, or if it is already Error, then + -- it is returned unchanged. Otherwise an error message is issued + -- and Error is returned. + + function Comma_Present return Boolean; + -- Used in comma delimited lists to determine if a comma is present, or + -- can reasonably be assumed to have been present (an error message is + -- generated in the latter case). If True is returned, the scan has been + -- positioned past the comma. If False is returned, the scan position + -- is unchanged. Note that all comma-delimited lists are terminated by + -- a right paren, so the only legitimate tokens when Comma_Present is + -- called are right paren and comma. If some other token is found, then + -- Comma_Present has the job of deciding whether it is better to pretend + -- a comma was present, post a message for a missing comma and return + -- True, or return False and let the caller diagnose the missing right + -- parenthesis. + + procedure Discard_Junk_Node (N : Node_Id); + procedure Discard_Junk_List (L : List_Id); + pragma Inline (Discard_Junk_Node); + pragma Inline (Discard_Junk_List); + -- These procedures do nothing at all, their effect is simply to discard + -- the argument. A typical use is to skip by some junk that is not + -- expected in the current context. + + procedure Ignore (T : Token_Type); + -- If current token matches T, then give an error message and skip + -- past it, otherwise the call has no effect at all. T may be any + -- reserved word token, or comma, left or right paren, or semicolon. + + function Is_Reserved_Identifier (C : Id_Check := None) return Boolean; + -- Test if current token is a reserved identifier. This test is based + -- on the token being a keyword and being spelled in typical identifier + -- style (i.e. starting with an upper case letter). The parameter C + -- determines the special treatment if a reserved word is encountered + -- that has the normal casing of a reserved word. + + procedure Merge_Identifier (Prev : Node_Id; Nxt : Token_Type); + -- Called when the previous token is an identifier (whose Token_Node + -- value is given by Prev) to check if current token is an identifier + -- that can be merged with the previous one adding an underscore. The + -- merge is only attempted if the following token matches Nxt. If all + -- conditions are met, an error message is issued, and the merge is + -- carried out, modifying the Chars field of Prev. + + function Next_Token_Is (Tok : Token_Type) return Boolean; + -- Looks at token after current one and returns True if the token type + -- matches Tok. The scan is unconditionally restored on return. + + procedure No_Constraint; + -- Called in a place where no constraint is allowed, but one might + -- appear due to a common error (e.g. after the type mark in a procedure + -- parameter. If a constraint is present, an error message is posted, + -- and the constraint is scanned and discarded. + + procedure Push_Scope_Stack; + pragma Inline (Push_Scope_Stack); + -- Push a new entry onto the scope stack. Scope.Last (the stack pointer) + -- is incremented. The Junk field is preinitialized to False. The caller + -- is expected to fill in all remaining entries of the new top stack + -- entry at Scope.Table (Scope.Last). + + procedure Pop_Scope_Stack; + -- Pop an entry off the top of the scope stack. Scope_Last (the scope + -- table stack pointer) is decremented by one. It is a fatal error to + -- try to pop off the dummy entry at the bottom of the stack (i.e. + -- Scope.Last must be non-zero at the time of call). + + function Separate_Present return Boolean; + -- Determines if the current token is either Tok_Separate, or an + -- identifier that is a possible misspelling of "separate" followed + -- by a semicolon. True is returned if so, otherwise False. + + procedure Signal_Bad_Attribute; + -- The current token is an identifier that is supposed to be an + -- attribute identifier but is not. This routine posts appropriate + -- error messages, including a check for a near misspelling. + + function Token_Is_At_Start_Of_Line return Boolean; + pragma Inline (Token_Is_At_Start_Of_Line); + -- Determines if the current token is the first token on the line + + function Token_Is_At_End_Of_Line return Boolean; + -- Determines if the current token is the last token on the line + + end Util; + + -------------- + -- Par.Prag -- + -------------- + + -- The processing for pragmas is split off from chapter 2 + + function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id; + -- This function is passed a tree for a pragma that has been scanned out. + -- The pragma is syntactically well formed according to the general syntax + -- for pragmas and the pragma identifier is for one of the recognized + -- pragmas. It performs specific syntactic checks for specific pragmas. + -- The result is the input node if it is OK, or Error otherwise. The + -- reason that this is separated out is to facilitate the addition + -- of implementation defined pragmas. The second parameter records the + -- location of the semicolon following the pragma (this is needed for + -- correct processing of the List and Page pragmas). The returned value + -- is a copy of Pragma_Node, or Error if an error is found. Note that + -- at the point where Prag is called, the right paren ending the pragma + -- has been scanned out, and except in the case of pragma Style_Checks, + -- so has the following semicolon. For Style_Checks, the caller delays + -- the scanning of the semicolon so that it will be scanned using the + -- settings from the Style_Checks pragma preceding it. + + -------------- + -- Par.Labl -- + -------------- + + procedure Labl; + -- This procedure creates implicit label declarations for all labels that + -- are declared in the current unit. Note that this could conceptually be + -- done at the point where the labels are declared, but it is tricky to do + -- it then, since the tree is not hooked up at the point where the label is + -- declared (e.g. a sequence of statements is not yet attached to its + -- containing scope at the point a label in the sequence is found). + + -------------- + -- Par.Load -- + -------------- + + procedure Load; + -- This procedure loads all subsidiary units that are required by this + -- unit, including with'ed units, specs for bodies, and parents for child + -- units. It does not load bodies for inlined procedures and generics, + -- since we don't know till semantic analysis is complete what is needed. + + ----------- + -- Stubs -- + ----------- + + -- The package bodies can see all routines defined in all other subpackages + + use Ch2; + use Ch3; + use Ch4; + use Ch5; + use Ch6; + use Ch7; + use Ch8; + use Ch9; + use Ch10; + use Ch11; + use Ch12; + use Ch13; + + use Endh; + use Tchk; + use Sync; + use Util; + + package body Ch2 is separate; + package body Ch3 is separate; + package body Ch4 is separate; + package body Ch5 is separate; + package body Ch6 is separate; + package body Ch7 is separate; + package body Ch8 is separate; + package body Ch9 is separate; + package body Ch10 is separate; + package body Ch11 is separate; + package body Ch12 is separate; + package body Ch13 is separate; + + package body Endh is separate; + package body Tchk is separate; + package body Sync is separate; + package body Util is separate; + + function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id + is separate; + + procedure Labl is separate; + procedure Load is separate; + +-- Start of processing for Par + +begin + Compiler_State := Parsing; + + -- Deal with configuration pragmas case first + + if Configuration_Pragmas then + declare + Pragmas : constant List_Id := Empty_List; + P_Node : Node_Id; + + begin + loop + if Token = Tok_EOF then + Compiler_State := Analyzing; + return Pragmas; + + elsif Token /= Tok_Pragma then + Error_Msg_SC ("only pragmas allowed in configuration file"); + Compiler_State := Analyzing; + return Error_List; + + else + P_Node := P_Pragma; + + if Nkind (P_Node) = N_Pragma then + + -- Give error if bad pragma + + if not Is_Configuration_Pragma_Name (Pragma_Name (P_Node)) + and then Pragma_Name (P_Node) /= Name_Source_Reference + then + if Is_Pragma_Name (Pragma_Name (P_Node)) then + Error_Msg_N + ("only configuration pragmas allowed " & + "in configuration file", P_Node); + else + Error_Msg_N + ("unrecognized pragma in configuration file", + P_Node); + end if; + + -- Pragma is OK config pragma, so collect it + + else + Append (P_Node, Pragmas); + end if; + end if; + end if; + end loop; + end; + + -- Normal case of compilation unit + + else + Save_Opt_Config_Switches (Save_Config_Switches); + + -- The following loop runs more than once in syntax check mode + -- where we allow multiple compilation units in the same file + -- and in Multiple_Unit_Per_file mode where we skip units till + -- we get to the unit we want. + + for Ucount in Pos loop + Set_Opt_Config_Switches + (Is_Internal_File_Name (File_Name (Current_Source_File)), + Current_Source_Unit = Main_Unit); + + -- Initialize scope table and other parser control variables + + Compiler_State := Parsing; + Scope.Init; + Scope.Increment_Last; + Scope.Table (0).Etyp := E_Dummy; + SIS_Entry_Active := False; + Last_Resync_Point := No_Location; + + Goto_List := New_Elmt_List; + Label_List := New_Elmt_List; + + -- If in multiple unit per file mode, skip past ignored unit + + if Ucount < Multiple_Unit_Index then + + -- We skip in syntax check only mode, since we don't want to do + -- anything more than skip past the unit and ignore it. This means + -- we skip processing like setting up a unit table entry. + + declare + Save_Operating_Mode : constant Operating_Mode_Type := + Operating_Mode; + + Save_Style_Check : constant Boolean := Style_Check; + + begin + Operating_Mode := Check_Syntax; + Style_Check := False; + Discard_Node (P_Compilation_Unit); + Operating_Mode := Save_Operating_Mode; + Style_Check := Save_Style_Check; + + -- If we are at an end of file, and not yet at the right unit, + -- then we have a fatal error. The unit is missing. + + if Token = Tok_EOF then + Error_Msg_SC ("file has too few compilation units"); + raise Unrecoverable_Error; + end if; + end; + + -- Here if we are not skipping a file in multiple unit per file mode. + -- Parse the unit that we are interested in. Note that in check + -- syntax mode we are interested in all units in the file. + + else + declare + Comp_Unit_Node : constant Node_Id := P_Compilation_Unit; + + begin + -- If parsing was successful and we are not in check syntax + -- mode, check that language-defined units are compiled in GNAT + -- mode. For this purpose we do NOT consider renamings in annex + -- J as predefined. That allows users to compile their own + -- versions of these files, and in particular, in the VMS + -- implementation, the DEC versions can be substituted for the + -- standard Ada 95 versions. Another exception is System.RPC + -- and its children. This allows a user to supply their own + -- communication layer. + + if Comp_Unit_Node /= Error + and then Operating_Mode = Generate_Code + and then Current_Source_Unit = Main_Unit + and then not GNAT_Mode + then + declare + Uname : constant String := + Get_Name_String + (Unit_Name (Current_Source_Unit)); + Name : String (1 .. Uname'Length - 2); + + begin + -- Because Unit_Name includes "%s"/"%b", we need to strip + -- the last two characters to get the real unit name. + + Name := Uname (Uname'First .. Uname'Last - 2); + + if Name = "ada" or else + Name = "interfaces" or else + Name = "system" + then + Error_Msg + ("language-defined units cannot be recompiled", + Sloc (Unit (Comp_Unit_Node))); + + elsif Name'Length > 4 + and then + Name (Name'First .. Name'First + 3) = "ada." + then + Error_Msg + ("user-defined descendents of package Ada " & + "are not allowed", + Sloc (Unit (Comp_Unit_Node))); + + elsif Name'Length > 11 + and then + Name (Name'First .. Name'First + 10) = "interfaces." + then + Error_Msg + ("user-defined descendents of package Interfaces " & + "are not allowed", + Sloc (Unit (Comp_Unit_Node))); + + elsif Name'Length > 7 + and then Name (Name'First .. Name'First + 6) = "system." + and then Name /= "system.rpc" + and then + (Name'Length < 11 + or else Name (Name'First .. Name'First + 10) /= + "system.rpc.") + then + Error_Msg + ("user-defined descendents of package System " & + "are not allowed", + Sloc (Unit (Comp_Unit_Node))); + end if; + end; + end if; + end; + + -- All done if at end of file + + exit when Token = Tok_EOF; + + -- If we are not at an end of file, it means we are in syntax + -- check only mode, and we keep the loop going to parse all + -- remaining units in the file. + + end if; + + Restore_Opt_Config_Switches (Save_Config_Switches); + end loop; + + -- Now that we have completely parsed the source file, we can complete + -- the source file table entry. + + Complete_Source_File_Entry; + + -- An internal error check, the scope stack should now be empty + + pragma Assert (Scope.Last = 0); + + -- Here we make the SCO table entries for the main unit + + if Generate_SCO then + SCO_Record (Main_Unit); + end if; + + -- Remaining steps are to create implicit label declarations and to load + -- required subsidiary sources. These steps are required only if we are + -- doing semantic checking. + + if Operating_Mode /= Check_Syntax or else Debug_Flag_F then + Par.Labl; + Par.Load; + end if; + + -- Restore settings of switches saved on entry + + Restore_Opt_Config_Switches (Save_Config_Switches); + Set_Comes_From_Source_Default (False); + Compiler_State := Analyzing; + return Empty_List; + end if; +end Par; diff --git a/gcc/ada/par.ads b/gcc/ada/par.ads new file mode 100644 index 000000000..d3fc0e730 --- /dev/null +++ b/gcc/ada/par.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- The Par function and its subunits contains all the parsing routines +-- for the top down recursive descent parser that constructs the parse tree + +with Types; use Types; + +function Par (Configuration_Pragmas : Boolean) return List_Id; +-- Top level parsing routine. There are two cases: +-- +-- If Configuration_Pragmas is False, Par parses a compilation unit in the +-- current source file and sets the Cunit, Cunit_Entity and Unit_Name fields +-- of the units table entry for Current_Source_Unit. On return the parse tree +-- is complete, and decorated with any required implicit label declarations. +-- The value returned in this case is always No_List. +-- +-- If Configuration_Pragmas is True, Par parses a list of configuration +-- pragmas from the current source file, and returns the list of pragmas. diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb new file mode 100644 index 000000000..251c6e23c --- /dev/null +++ b/gcc/ada/par_sco.adb @@ -0,0 +1,1510 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R _ S C O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Debug; use Debug; +with Lib; use Lib; +with Lib.Util; use Lib.Util; +with Namet; use Namet; +with Nlists; use Nlists; +with Opt; use Opt; +with Output; use Output; +with Put_SCOs; +with SCOs; use SCOs; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with Table; + +with GNAT.HTable; use GNAT.HTable; +with GNAT.Heap_Sort_G; + +package body Par_SCO is + + ----------------------- + -- Unit Number Table -- + ----------------------- + + -- This table parallels the SCO_Unit_Table, keeping track of the unit + -- numbers corresponding to the entries made in this table, so that before + -- writing out the SCO information to the ALI file, we can fill in the + -- proper dependency numbers and file names. + + -- Note that the zero'th entry is here for convenience in sorting the + -- table, the real lower bound is 1. + + package SCO_Unit_Number_Table is new Table.Table ( + Table_Component_Type => Unit_Number_Type, + Table_Index_Type => SCO_Unit_Index, + Table_Low_Bound => 0, -- see note above on sort + Table_Initial => 20, + Table_Increment => 200, + Table_Name => "SCO_Unit_Number_Entry"); + + --------------------------------- + -- Condition/Pragma Hash Table -- + --------------------------------- + + -- We need to be able to get to conditions quickly for handling the calls + -- to Set_SCO_Condition efficiently, and similarly to get to pragmas to + -- handle calls to Set_SCO_Pragma_Enabled. For this purpose we identify the + -- conditions and pragmas in the table by their starting sloc, and use this + -- hash table to map from these starting sloc values to SCO_Table indexes. + + type Header_Num is new Integer range 0 .. 996; + -- Type for hash table headers + + function Hash (F : Source_Ptr) return Header_Num; + -- Function to Hash source pointer value + + function Equal (F1, F2 : Source_Ptr) return Boolean; + -- Function to test two keys for equality + + package Condition_Pragma_Hash_Table is new Simple_HTable + (Header_Num, Int, 0, Source_Ptr, Hash, Equal); + -- The actual hash table + + -------------------------- + -- Internal Subprograms -- + -------------------------- + + function Has_Decision (N : Node_Id) return Boolean; + -- N is the node for a subexpression. Returns True if the subexpression + -- contains a nested decision (i.e. either is a logical operator, or + -- contains a logical operator in its subtree). + + function Is_Logical_Operator (N : Node_Id) return Boolean; + -- N is the node for a subexpression. This procedure just tests N to see + -- if it is a logical operator (including short circuit conditions, but + -- excluding OR and AND) and returns True if so, False otherwise, it does + -- no other processing. + + procedure Process_Decisions (N : Node_Id; T : Character); + -- If N is Empty, has no effect. Otherwise scans the tree for the node N, + -- to output any decisions it contains. T is one of IEPWX (for context of + -- expression: if/exit when/pragma/while/expression). If T is other than X, + -- the node N is the conditional expression involved, and a decision is + -- always present (at the very least a simple decision is present at the + -- top level). + + procedure Process_Decisions (L : List_Id; T : Character); + -- Calls above procedure for each element of the list L + + procedure Set_Table_Entry + (C1 : Character; + C2 : Character; + From : Source_Ptr; + To : Source_Ptr; + Last : Boolean); + -- Append an entry to SCO_Table with fields set as per arguments + + procedure Traverse_Declarations_Or_Statements (L : List_Id); + procedure Traverse_Generic_Instantiation (N : Node_Id); + procedure Traverse_Generic_Package_Declaration (N : Node_Id); + procedure Traverse_Handled_Statement_Sequence (N : Node_Id); + procedure Traverse_Package_Body (N : Node_Id); + procedure Traverse_Package_Declaration (N : Node_Id); + procedure Traverse_Subprogram_Body (N : Node_Id); + procedure Traverse_Subprogram_Declaration (N : Node_Id); + -- Traverse the corresponding construct, generating SCO table entries + + procedure Write_SCOs_To_ALI_File is new Put_SCOs; + -- Write SCO information to the ALI file using routines in Lib.Util + + ---------- + -- dsco -- + ---------- + + procedure dsco is + begin + -- Dump SCO unit table + + Write_Line ("SCO Unit Table"); + Write_Line ("--------------"); + + for Index in 1 .. SCO_Unit_Table.Last loop + declare + UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (Index); + + begin + Write_Str (" "); + Write_Int (Int (Index)); + Write_Str (". Dep_Num = "); + Write_Int (Int (UTE.Dep_Num)); + Write_Str (" From = "); + Write_Int (Int (UTE.From)); + Write_Str (" To = "); + Write_Int (Int (UTE.To)); + + Write_Str (" File_Name = """); + + if UTE.File_Name /= null then + Write_Str (UTE.File_Name.all); + end if; + + Write_Char ('"'); + Write_Eol; + end; + end loop; + + -- Dump SCO Unit number table if it contains any entries + + if SCO_Unit_Number_Table.Last >= 1 then + Write_Eol; + Write_Line ("SCO Unit Number Table"); + Write_Line ("---------------------"); + + for Index in 1 .. SCO_Unit_Number_Table.Last loop + Write_Str (" "); + Write_Int (Int (Index)); + Write_Str (". Unit_Number = "); + Write_Int (Int (SCO_Unit_Number_Table.Table (Index))); + Write_Eol; + end loop; + end if; + + -- Dump SCO table itself + + Write_Eol; + Write_Line ("SCO Table"); + Write_Line ("---------"); + + for Index in 1 .. SCO_Table.Last loop + declare + T : SCO_Table_Entry renames SCO_Table.Table (Index); + + begin + Write_Str (" "); + Write_Int (Index); + Write_Char ('.'); + + if T.C1 /= ' ' then + Write_Str (" C1 = '"); + Write_Char (T.C1); + Write_Char ('''); + end if; + + if T.C2 /= ' ' then + Write_Str (" C2 = '"); + Write_Char (T.C2); + Write_Char ('''); + end if; + + if T.From /= No_Source_Location then + Write_Str (" From = "); + Write_Int (Int (T.From.Line)); + Write_Char (':'); + Write_Int (Int (T.From.Col)); + end if; + + if T.To /= No_Source_Location then + Write_Str (" To = "); + Write_Int (Int (T.To.Line)); + Write_Char (':'); + Write_Int (Int (T.To.Col)); + end if; + + if T.Last then + Write_Str (" True"); + else + Write_Str (" False"); + end if; + + Write_Eol; + end; + end loop; + end dsco; + + ----------- + -- Equal -- + ----------- + + function Equal (F1, F2 : Source_Ptr) return Boolean is + begin + return F1 = F2; + end Equal; + + ------------------ + -- Has_Decision -- + ------------------ + + function Has_Decision (N : Node_Id) return Boolean is + + function Check_Node (N : Node_Id) return Traverse_Result; + + ---------------- + -- Check_Node -- + ---------------- + + function Check_Node (N : Node_Id) return Traverse_Result is + begin + if Is_Logical_Operator (N) then + return Abandon; + else + return OK; + end if; + end Check_Node; + + function Traverse is new Traverse_Func (Check_Node); + + -- Start of processing for Has_Decision + + begin + return Traverse (N) = Abandon; + end Has_Decision; + + ---------- + -- Hash -- + ---------- + + function Hash (F : Source_Ptr) return Header_Num is + begin + return Header_Num (Nat (F) mod 997); + end Hash; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + SCO_Unit_Number_Table.Init; + + -- Set dummy 0'th entry in place for sort + + SCO_Unit_Number_Table.Increment_Last; + end Initialize; + + ------------------------- + -- Is_Logical_Operator -- + ------------------------- + + function Is_Logical_Operator (N : Node_Id) return Boolean is + begin + return Nkind_In (N, N_Op_Not, + N_And_Then, + N_Or_Else); + end Is_Logical_Operator; + + ----------------------- + -- Process_Decisions -- + ----------------------- + + -- Version taking a list + + procedure Process_Decisions (L : List_Id; T : Character) is + N : Node_Id; + begin + if L /= No_List then + N := First (L); + while Present (N) loop + Process_Decisions (N, T); + Next (N); + end loop; + end if; + end Process_Decisions; + + -- Version taking a node + + procedure Process_Decisions (N : Node_Id; T : Character) is + + Mark : Nat; + -- This is used to mark the location of a decision sequence in the SCO + -- table. We use it for backing out a simple decision in an expression + -- context that contains only NOT operators. + + X_Not_Decision : Boolean; + -- This flag keeps track of whether a decision sequence in the SCO table + -- contains only NOT operators, and is for an expression context (T=X). + -- The flag will be set False if T is other than X, or if an operator + -- other than NOT is in the sequence. + + function Process_Node (N : Node_Id) return Traverse_Result; + -- Processes one node in the traversal, looking for logical operators, + -- and if one is found, outputs the appropriate table entries. + + procedure Output_Decision_Operand (N : Node_Id); + -- The node N is the top level logical operator of a decision, or it is + -- one of the operands of a logical operator belonging to a single + -- complex decision. This routine outputs the sequence of table entries + -- corresponding to the node. Note that we do not process the sub- + -- operands to look for further decisions, that processing is done in + -- Process_Decision_Operand, because we can't get decisions mixed up in + -- the global table. Call has no effect if N is Empty. + + procedure Output_Element (N : Node_Id); + -- Node N is an operand of a logical operator that is not itself a + -- logical operator, or it is a simple decision. This routine outputs + -- the table entry for the element, with C1 set to ' '. Last is set + -- False, and an entry is made in the condition hash table. + + procedure Output_Header (T : Character); + -- Outputs a decision header node. T is I/W/E/P for IF/WHILE/EXIT WHEN/ + -- PRAGMA, and 'X' for the expression case. + + procedure Process_Decision_Operand (N : Node_Id); + -- This is called on node N, the top level node of a decision, or on one + -- of its operands or suboperands after generating the full output for + -- the complex decision. It process the suboperands of the decision + -- looking for nested decisions. + + ----------------------------- + -- Output_Decision_Operand -- + ----------------------------- + + procedure Output_Decision_Operand (N : Node_Id) is + C : Character; + L : Node_Id; + + begin + if No (N) then + return; + + -- Logical operator + + elsif Is_Logical_Operator (N) then + if Nkind (N) = N_Op_Not then + C := '!'; + L := Empty; + + else + L := Left_Opnd (N); + + if Nkind_In (N, N_Op_Or, N_Or_Else) then + C := '|'; + else + C := '&'; + end if; + end if; + + Set_Table_Entry + (C1 => C, + C2 => ' ', + From => Sloc (N), + To => No_Location, + Last => False); + + Output_Decision_Operand (L); + Output_Decision_Operand (Right_Opnd (N)); + + -- Not a logical operator + + else + Output_Element (N); + end if; + end Output_Decision_Operand; + + -------------------- + -- Output_Element -- + -------------------- + + procedure Output_Element (N : Node_Id) is + FSloc : Source_Ptr; + LSloc : Source_Ptr; + begin + Sloc_Range (N, FSloc, LSloc); + Set_Table_Entry + (C1 => ' ', + C2 => 'c', + From => FSloc, + To => LSloc, + Last => False); + Condition_Pragma_Hash_Table.Set (FSloc, SCO_Table.Last); + end Output_Element; + + ------------------- + -- Output_Header -- + ------------------- + + procedure Output_Header (T : Character) is + begin + case T is + when 'I' | 'E' | 'W' => + + -- For IF, EXIT, WHILE, the token SLOC can be found from + -- the SLOC of the parent of the expression. + + Set_Table_Entry + (C1 => T, + C2 => ' ', + From => Sloc (Parent (N)), + To => No_Location, + Last => False); + + when 'P' => + + -- For PRAGMA, we must get the location from the pragma node. + -- Argument N is the pragma argument, and we have to go up two + -- levels (through the pragma argument association) to get to + -- the pragma node itself. + + declare + Loc : constant Source_Ptr := Sloc (Parent (Parent (N))); + + begin + Set_Table_Entry + (C1 => 'P', + C2 => 'd', + From => Loc, + To => No_Location, + Last => False); + + -- For pragmas we also must make an entry in the hash table + -- for later access by Set_SCO_Pragma_Enabled. We set the + -- pragma as disabled above, the call will change C2 to 'e' + -- to enable the pragma header entry. + + Condition_Pragma_Hash_Table.Set (Loc, SCO_Table.Last); + end; + + when 'X' => + + -- For an expression, no Sloc + + Set_Table_Entry + (C1 => 'X', + C2 => ' ', + From => No_Location, + To => No_Location, + Last => False); + + -- No other possibilities + + when others => + raise Program_Error; + end case; + end Output_Header; + + ------------------------------ + -- Process_Decision_Operand -- + ------------------------------ + + procedure Process_Decision_Operand (N : Node_Id) is + begin + if Is_Logical_Operator (N) then + if Nkind (N) /= N_Op_Not then + Process_Decision_Operand (Left_Opnd (N)); + X_Not_Decision := False; + end if; + + Process_Decision_Operand (Right_Opnd (N)); + + else + Process_Decisions (N, 'X'); + end if; + end Process_Decision_Operand; + + ------------------ + -- Process_Node -- + ------------------ + + function Process_Node (N : Node_Id) return Traverse_Result is + begin + case Nkind (N) is + + -- Logical operators, output table entries and then process + -- operands recursively to deal with nested conditions. + + when N_And_Then | + N_Or_Else | + N_Op_Not => + + declare + T : Character; + + begin + -- If outer level, then type comes from call, otherwise it + -- is more deeply nested and counts as X for expression. + + if N = Process_Decisions.N then + T := Process_Decisions.T; + else + T := 'X'; + end if; + + -- Output header for sequence + + X_Not_Decision := T = 'X' and then Nkind (N) = N_Op_Not; + Mark := SCO_Table.Last; + Output_Header (T); + + -- Output the decision + + Output_Decision_Operand (N); + + -- If the decision was in an expression context (T = 'X') + -- and contained only NOT operators, then we don't output + -- it, so delete it. + + if X_Not_Decision then + SCO_Table.Set_Last (Mark); + + -- Otherwise, set Last in last table entry to mark end + + else + SCO_Table.Table (SCO_Table.Last).Last := True; + end if; + + -- Process any embedded decisions + + Process_Decision_Operand (N); + return Skip; + end; + + -- Case expression + + when N_Case_Expression => + return OK; -- ??? + + -- Conditional expression, processed like an if statement + + when N_Conditional_Expression => + declare + Cond : constant Node_Id := First (Expressions (N)); + Thnx : constant Node_Id := Next (Cond); + Elsx : constant Node_Id := Next (Thnx); + begin + Process_Decisions (Cond, 'I'); + Process_Decisions (Thnx, 'X'); + Process_Decisions (Elsx, 'X'); + return Skip; + end; + + -- All other cases, continue scan + + when others => + return OK; + + end case; + end Process_Node; + + procedure Traverse is new Traverse_Proc (Process_Node); + + -- Start of processing for Process_Decisions + + begin + if No (N) then + return; + end if; + + -- See if we have simple decision at outer level and if so then + -- generate the decision entry for this simple decision. A simple + -- decision is a boolean expression (which is not a logical operator + -- or short circuit form) appearing as the operand of an IF, WHILE, + -- EXIT WHEN, or special PRAGMA construct. + + if T /= 'X' and then not Is_Logical_Operator (N) then + Output_Header (T); + Output_Element (N); + + -- Change Last in last table entry to True to mark end of + -- sequence, which is this case is only one element long. + + SCO_Table.Table (SCO_Table.Last).Last := True; + end if; + + Traverse (N); + end Process_Decisions; + + ----------- + -- pscos -- + ----------- + + procedure pscos is + + procedure Write_Info_Char (C : Character) renames Write_Char; + -- Write one character; + + procedure Write_Info_Initiate (Key : Character) renames Write_Char; + -- Start new one and write one character; + + procedure Write_Info_Nat (N : Nat); + -- Write value of N + + procedure Write_Info_Terminate renames Write_Eol; + -- Terminate current line + + -------------------- + -- Write_Info_Nat -- + -------------------- + + procedure Write_Info_Nat (N : Nat) is + begin + Write_Int (N); + end Write_Info_Nat; + + procedure Debug_Put_SCOs is new Put_SCOs; + + -- Start of processing for pscos + + begin + Debug_Put_SCOs; + end pscos; + + ---------------- + -- SCO_Output -- + ---------------- + + procedure SCO_Output is + begin + if Debug_Flag_Dot_OO then + dsco; + end if; + + -- Sort the unit tables based on dependency numbers + + Unit_Table_Sort : declare + + function Lt (Op1, Op2 : Natural) return Boolean; + -- Comparison routine for sort call + + procedure Move (From : Natural; To : Natural); + -- Move routine for sort call + + -------- + -- Lt -- + -------- + + function Lt (Op1, Op2 : Natural) return Boolean is + begin + return + Dependency_Num + (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op1))) + < + Dependency_Num + (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op2))); + end Lt; + + ---------- + -- Move -- + ---------- + + procedure Move (From : Natural; To : Natural) is + begin + SCO_Unit_Table.Table (SCO_Unit_Index (To)) := + SCO_Unit_Table.Table (SCO_Unit_Index (From)); + SCO_Unit_Number_Table.Table (SCO_Unit_Index (To)) := + SCO_Unit_Number_Table.Table (SCO_Unit_Index (From)); + end Move; + + package Sorting is new GNAT.Heap_Sort_G (Move, Lt); + + -- Start of processing for Unit_Table_Sort + + begin + Sorting.Sort (Integer (SCO_Unit_Table.Last)); + end Unit_Table_Sort; + + -- Loop through entries in the unit table to set file name and + -- dependency number entries. + + for J in 1 .. SCO_Unit_Table.Last loop + declare + U : constant Unit_Number_Type := SCO_Unit_Number_Table.Table (J); + UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (J); + begin + Get_Name_String (Reference_Name (Source_Index (U))); + UTE.File_Name := new String'(Name_Buffer (1 .. Name_Len)); + UTE.Dep_Num := Dependency_Num (U); + end; + end loop; + + -- Now the tables are all setup for output to the ALI file + + Write_SCOs_To_ALI_File; + end SCO_Output; + + ---------------- + -- SCO_Record -- + ---------------- + + procedure SCO_Record (U : Unit_Number_Type) is + Lu : Node_Id; + From : Nat; + + begin + -- Ignore call if not generating code and generating SCO's + + if not (Generate_SCO and then Operating_Mode = Generate_Code) then + return; + end if; + + -- Ignore call if this unit already recorded + + for J in 1 .. SCO_Unit_Number_Table.Last loop + if U = SCO_Unit_Number_Table.Table (J) then + return; + end if; + end loop; + + -- Otherwise record starting entry + + From := SCO_Table.Last + 1; + + -- Get Unit (checking case of subunit) + + Lu := Unit (Cunit (U)); + + if Nkind (Lu) = N_Subunit then + Lu := Proper_Body (Lu); + end if; + + -- Traverse the unit + + if Nkind (Lu) = N_Subprogram_Body then + Traverse_Subprogram_Body (Lu); + + elsif Nkind (Lu) = N_Subprogram_Declaration then + Traverse_Subprogram_Declaration (Lu); + + elsif Nkind (Lu) = N_Package_Declaration then + Traverse_Package_Declaration (Lu); + + elsif Nkind (Lu) = N_Package_Body then + Traverse_Package_Body (Lu); + + elsif Nkind (Lu) = N_Generic_Package_Declaration then + Traverse_Generic_Package_Declaration (Lu); + + elsif Nkind (Lu) in N_Generic_Instantiation then + Traverse_Generic_Instantiation (Lu); + + -- All other cases of compilation units (e.g. renamings), generate + -- no SCO information. + + else + null; + end if; + + -- Make entry for new unit in unit tables, we will fill in the file + -- name and dependency numbers later. + + SCO_Unit_Table.Append ( + (Dep_Num => 0, + File_Name => null, + From => From, + To => SCO_Table.Last)); + + SCO_Unit_Number_Table.Append (U); + end SCO_Record; + + ----------------------- + -- Set_SCO_Condition -- + ----------------------- + + procedure Set_SCO_Condition (Cond : Node_Id; Val : Boolean) is + Orig : constant Node_Id := Original_Node (Cond); + Index : Nat; + Start : Source_Ptr; + Dummy : Source_Ptr; + + Constant_Condition_Code : constant array (Boolean) of Character := + (False => 'f', True => 't'); + begin + Sloc_Range (Orig, Start, Dummy); + Index := Condition_Pragma_Hash_Table.Get (Start); + + -- The test here for zero is to deal with possible previous errors + + if Index /= 0 then + pragma Assert (SCO_Table.Table (Index).C1 = ' '); + SCO_Table.Table (Index).C2 := Constant_Condition_Code (Val); + end if; + end Set_SCO_Condition; + + ---------------------------- + -- Set_SCO_Pragma_Enabled -- + ---------------------------- + + procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr) is + Index : Nat; + + begin + -- Note: the reason we use the Sloc value as the key is that in the + -- generic case, the call to this procedure is made on a copy of the + -- original node, so we can't use the Node_Id value. + + Index := Condition_Pragma_Hash_Table.Get (Loc); + + -- The test here for zero is to deal with possible previous errors + + if Index /= 0 then + pragma Assert (SCO_Table.Table (Index).C1 = 'P'); + SCO_Table.Table (Index).C2 := 'e'; + end if; + end Set_SCO_Pragma_Enabled; + + --------------------- + -- Set_Table_Entry -- + --------------------- + + procedure Set_Table_Entry + (C1 : Character; + C2 : Character; + From : Source_Ptr; + To : Source_Ptr; + Last : Boolean) + is + function To_Source_Location (S : Source_Ptr) return Source_Location; + -- Converts Source_Ptr value to Source_Location (line/col) format + + ------------------------ + -- To_Source_Location -- + ------------------------ + + function To_Source_Location (S : Source_Ptr) return Source_Location is + begin + if S = No_Location then + return No_Source_Location; + else + return + (Line => Get_Logical_Line_Number (S), + Col => Get_Column_Number (S)); + end if; + end To_Source_Location; + + -- Start of processing for Set_Table_Entry + + begin + Add_SCO + (C1 => C1, + C2 => C2, + From => To_Source_Location (From), + To => To_Source_Location (To), + Last => Last); + end Set_Table_Entry; + + ----------------------------------------- + -- Traverse_Declarations_Or_Statements -- + ----------------------------------------- + + -- Tables used by Traverse_Declarations_Or_Statements for temporarily + -- holding statement and decision entries. These are declared globally + -- since they are shared by recursive calls to this procedure. + + type SC_Entry is record + From : Source_Ptr; + To : Source_Ptr; + Typ : Character; + end record; + -- Used to store a single entry in the following table, From:To represents + -- the range of entries in the CS line entry, and typ is the type, with + -- space meaning that no type letter will accompany the entry. + + package SC is new Table.Table ( + Table_Component_Type => SC_Entry, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 1000, + Table_Increment => 200, + Table_Name => "SCO_SC"); + -- Used to store statement components for a CS entry to be output + -- as a result of the call to this procedure. SC.Last is the last + -- entry stored, so the current statement sequence is represented + -- by SC_Array (SC_First .. SC.Last), where SC_First is saved on + -- entry to each recursive call to the routine. + -- + -- Extend_Statement_Sequence adds an entry to this array, and then + -- Set_Statement_Entry clears the entries starting with SC_First, + -- copying these entries to the main SCO output table. The reason that + -- we do the temporary caching of results in this array is that we want + -- the SCO table entries for a given CS line to be contiguous, and the + -- processing may output intermediate entries such as decision entries. + + type SD_Entry is record + Nod : Node_Id; + Lst : List_Id; + Typ : Character; + end record; + -- Used to store a single entry in the following table. Nod is the node to + -- be searched for decisions for the case of Process_Decisions_Defer with a + -- node argument (with Lst set to No_List. Lst is the list to be searched + -- for decisions for the case of Process_Decisions_Defer with a List + -- argument (in which case Nod is set to Empty). + + package SD is new Table.Table ( + Table_Component_Type => SD_Entry, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 1000, + Table_Increment => 200, + Table_Name => "SCO_SD"); + -- Used to store possible decision information. Instead of calling the + -- Process_Decisions procedures directly, we call Process_Decisions_Defer, + -- which simply stores the arguments in this table. Then when we clear + -- out a statement sequence using Set_Statement_Entry, after generating + -- the CS lines for the statements, the entries in this table result in + -- calls to Process_Decision. The reason for doing things this way is to + -- ensure that decisions are output after the CS line for the statements + -- in which the decisions occur. + + procedure Traverse_Declarations_Or_Statements (L : List_Id) is + N : Node_Id; + Dummy : Source_Ptr; + + SC_First : constant Nat := SC.Last + 1; + SD_First : constant Nat := SD.Last + 1; + -- Record first entries used in SC/SD at this recursive level + + procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character); + -- Extend the current statement sequence to encompass the node N. Typ + -- is the letter that identifies the type of statement/declaration that + -- is being added to the sequence. + + procedure Extend_Statement_Sequence + (From : Node_Id; + To : Node_Id; + Typ : Character); + -- This version extends the current statement sequence with an entry + -- that starts with the first token of From, and ends with the last + -- token of To. It is used for example in a CASE statement to cover + -- the range from the CASE token to the last token of the expression. + + procedure Set_Statement_Entry; + -- If Start is No_Location, does nothing, otherwise outputs a SCO_Table + -- statement entry for the range Start-Stop and then sets both Start + -- and Stop to No_Location. Unconditionally sets Term to True. This is + -- called when we find a statement or declaration that generates its + -- own table entry, so that we must end the current statement sequence. + + procedure Process_Decisions_Defer (N : Node_Id; T : Character); + pragma Inline (Process_Decisions_Defer); + -- This routine is logically the same as Process_Decisions, except that + -- the arguments are saved in the SD table, for later processing when + -- Set_Statement_Entry is called, which goes through the saved entries + -- making the corresponding calls to Process_Decision. + + procedure Process_Decisions_Defer (L : List_Id; T : Character); + pragma Inline (Process_Decisions_Defer); + -- Same case for list arguments, deferred call to Process_Decisions + + ------------------------- + -- Set_Statement_Entry -- + ------------------------- + + procedure Set_Statement_Entry is + C1 : Character; + SC_Last : constant Int := SC.Last; + SD_Last : constant Int := SD.Last; + + begin + -- Output statement entries from saved entries in SC table + + for J in SC_First .. SC_Last loop + if J = SC_First then + C1 := 'S'; + else + C1 := 's'; + end if; + + declare + SCE : SC_Entry renames SC.Table (J); + begin + Set_Table_Entry + (C1 => C1, + C2 => SCE.Typ, + From => SCE.From, + To => SCE.To, + Last => (J = SC_Last)); + end; + end loop; + + -- Clear out used section of SC table + + SC.Set_Last (SC_First - 1); + + -- Output any embedded decisions + + for J in SD_First .. SD_Last loop + declare + SDE : SD_Entry renames SD.Table (J); + begin + if Present (SDE.Nod) then + Process_Decisions (SDE.Nod, SDE.Typ); + else + Process_Decisions (SDE.Lst, SDE.Typ); + end if; + end; + end loop; + + -- Clear out used section of SD table + + SD.Set_Last (SD_First - 1); + end Set_Statement_Entry; + + ------------------------------- + -- Extend_Statement_Sequence -- + ------------------------------- + + procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is + F : Source_Ptr; + T : Source_Ptr; + begin + Sloc_Range (N, F, T); + SC.Append ((F, T, Typ)); + end Extend_Statement_Sequence; + + procedure Extend_Statement_Sequence + (From : Node_Id; + To : Node_Id; + Typ : Character) + is + F : Source_Ptr; + T : Source_Ptr; + begin + Sloc_Range (From, F, Dummy); + Sloc_Range (To, Dummy, T); + SC.Append ((F, T, Typ)); + end Extend_Statement_Sequence; + + ----------------------------- + -- Process_Decisions_Defer -- + ----------------------------- + + procedure Process_Decisions_Defer (N : Node_Id; T : Character) is + begin + SD.Append ((N, No_List, T)); + end Process_Decisions_Defer; + + procedure Process_Decisions_Defer (L : List_Id; T : Character) is + begin + SD.Append ((Empty, L, T)); + end Process_Decisions_Defer; + + -- Start of processing for Traverse_Declarations_Or_Statements + + begin + if Is_Non_Empty_List (L) then + + -- Loop through statements or declarations + + N := First (L); + while Present (N) loop + + -- Initialize or extend current statement sequence. Note that for + -- special cases such as IF and Case statements we will modify + -- the range to exclude internal statements that should not be + -- counted as part of the current statement sequence. + + case Nkind (N) is + + -- Package declaration + + when N_Package_Declaration => + Set_Statement_Entry; + Traverse_Package_Declaration (N); + + -- Generic package declaration + + when N_Generic_Package_Declaration => + Set_Statement_Entry; + Traverse_Generic_Package_Declaration (N); + + -- Package body + + when N_Package_Body => + Set_Statement_Entry; + Traverse_Package_Body (N); + + -- Subprogram declaration + + when N_Subprogram_Declaration => + Process_Decisions_Defer + (Parameter_Specifications (Specification (N)), 'X'); + Set_Statement_Entry; + + -- Generic subprogram declaration + + when N_Generic_Subprogram_Declaration => + Process_Decisions_Defer + (Generic_Formal_Declarations (N), 'X'); + Process_Decisions_Defer + (Parameter_Specifications (Specification (N)), 'X'); + Set_Statement_Entry; + + -- Subprogram_Body + + when N_Subprogram_Body => + Set_Statement_Entry; + Traverse_Subprogram_Body (N); + + -- Exit statement, which is an exit statement in the SCO sense, + -- so it is included in the current statement sequence, but + -- then it terminates this sequence. We also have to process + -- any decisions in the exit statement expression. + + when N_Exit_Statement => + Extend_Statement_Sequence (N, ' '); + Process_Decisions_Defer (Condition (N), 'E'); + Set_Statement_Entry; + + -- Label, which breaks the current statement sequence, but the + -- label itself is not included in the next statement sequence, + -- since it generates no code. + + when N_Label => + Set_Statement_Entry; + + -- Block statement, which breaks the current statement sequence + + when N_Block_Statement => + Set_Statement_Entry; + Traverse_Declarations_Or_Statements (Declarations (N)); + Traverse_Handled_Statement_Sequence + (Handled_Statement_Sequence (N)); + + -- If statement, which breaks the current statement sequence, + -- but we include the condition in the current sequence. + + when N_If_Statement => + Extend_Statement_Sequence (N, Condition (N), 'I'); + Process_Decisions_Defer (Condition (N), 'I'); + Set_Statement_Entry; + + -- Now we traverse the statements in the THEN part + + Traverse_Declarations_Or_Statements (Then_Statements (N)); + + -- Loop through ELSIF parts if present + + if Present (Elsif_Parts (N)) then + declare + Elif : Node_Id := First (Elsif_Parts (N)); + + begin + while Present (Elif) loop + + -- We generate a statement sequence for the + -- construct "ELSIF condition", so that we have + -- a statement for the resulting decisions. + + Extend_Statement_Sequence + (Elif, Condition (Elif), 'I'); + Process_Decisions_Defer (Condition (Elif), 'I'); + Set_Statement_Entry; + + -- Traverse the statements in the ELSIF + + Traverse_Declarations_Or_Statements + (Then_Statements (Elif)); + Next (Elif); + end loop; + end; + end if; + + -- Finally traverse the ELSE statements if present + + Traverse_Declarations_Or_Statements (Else_Statements (N)); + + -- Case statement, which breaks the current statement sequence, + -- but we include the expression in the current sequence. + + when N_Case_Statement => + Extend_Statement_Sequence (N, Expression (N), 'C'); + Process_Decisions_Defer (Expression (N), 'X'); + Set_Statement_Entry; + + -- Process case branches + + declare + Alt : Node_Id; + begin + Alt := First (Alternatives (N)); + while Present (Alt) loop + Traverse_Declarations_Or_Statements (Statements (Alt)); + Next (Alt); + end loop; + end; + + -- Unconditional exit points, which are included in the current + -- statement sequence, but then terminate it + + when N_Requeue_Statement | + N_Goto_Statement | + N_Raise_Statement => + Extend_Statement_Sequence (N, ' '); + Set_Statement_Entry; + + -- Simple return statement. which is an exit point, but we + -- have to process the return expression for decisions. + + when N_Simple_Return_Statement => + Extend_Statement_Sequence (N, ' '); + Process_Decisions_Defer (Expression (N), 'X'); + Set_Statement_Entry; + + -- Extended return statement + + when N_Extended_Return_Statement => + Extend_Statement_Sequence + (N, Last (Return_Object_Declarations (N)), 'R'); + Process_Decisions_Defer + (Return_Object_Declarations (N), 'X'); + Set_Statement_Entry; + + Traverse_Handled_Statement_Sequence + (Handled_Statement_Sequence (N)); + + -- Loop ends the current statement sequence, but we include + -- the iteration scheme if present in the current sequence. + -- But the body of the loop starts a new sequence, since it + -- may not be executed as part of the current sequence. + + when N_Loop_Statement => + if Present (Iteration_Scheme (N)) then + + -- If iteration scheme present, extend the current + -- statement sequence to include the iteration scheme + -- and process any decisions it contains. + + declare + ISC : constant Node_Id := Iteration_Scheme (N); + + begin + -- While statement + + if Present (Condition (ISC)) then + Extend_Statement_Sequence (N, ISC, 'W'); + Process_Decisions_Defer (Condition (ISC), 'W'); + + -- For statement + + else + Extend_Statement_Sequence (N, ISC, 'F'); + Process_Decisions_Defer + (Loop_Parameter_Specification (ISC), 'X'); + end if; + end; + end if; + + Set_Statement_Entry; + Traverse_Declarations_Or_Statements (Statements (N)); + + -- Pragma + + when N_Pragma => + Extend_Statement_Sequence (N, 'P'); + + -- Processing depends on the kind of pragma + + case Pragma_Name (N) is + when Name_Assert | + Name_Check | + Name_Precondition | + Name_Postcondition => + + -- For Assert/Check/Precondition/Postcondition, we + -- must generate a P entry for the decision. Note that + -- this is done unconditionally at this stage. Output + -- for disabled pragmas is suppressed later on, when + -- we output the decision line in Put_SCOs. + + declare + Nam : constant Name_Id := + Chars (Pragma_Identifier (N)); + Arg : Node_Id := + First (Pragma_Argument_Associations (N)); + + begin + if Nam = Name_Check then + Next (Arg); + end if; + + Process_Decisions_Defer (Expression (Arg), 'P'); + end; + + -- For all other pragmas, we generate decision entries + -- for any embedded expressions. + + when others => + Process_Decisions_Defer (N, 'X'); + end case; + + -- Object declaration. Ignored if Prev_Ids is set, since the + -- parser generates multiple instances of the whole declaration + -- if there is more than one identifier declared, and we only + -- want one entry in the SCO's, so we take the first, for which + -- Prev_Ids is False. + + when N_Object_Declaration => + if not Prev_Ids (N) then + Extend_Statement_Sequence (N, 'o'); + + if Has_Decision (N) then + Process_Decisions_Defer (N, 'X'); + end if; + end if; + + -- All other cases, which extend the current statement sequence + -- but do not terminate it, even if they have nested decisions. + + when others => + + -- Determine required type character code + + declare + Typ : Character; + + begin + case Nkind (N) is + when N_Full_Type_Declaration | + N_Incomplete_Type_Declaration | + N_Private_Type_Declaration | + N_Private_Extension_Declaration => + Typ := 't'; + + when N_Subtype_Declaration => + Typ := 's'; + + when N_Renaming_Declaration => + Typ := 'r'; + + when N_Generic_Instantiation => + Typ := 'i'; + + when others => + Typ := ' '; + end case; + + Extend_Statement_Sequence (N, Typ); + end; + + -- Process any embedded decisions + + if Has_Decision (N) then + Process_Decisions_Defer (N, 'X'); + end if; + end case; + + Next (N); + end loop; + + Set_Statement_Entry; + end if; + end Traverse_Declarations_Or_Statements; + + ------------------------------------ + -- Traverse_Generic_Instantiation -- + ------------------------------------ + + procedure Traverse_Generic_Instantiation (N : Node_Id) is + First : Source_Ptr; + Last : Source_Ptr; + + begin + -- First we need a statement entry to cover the instantiation + + Sloc_Range (N, First, Last); + Set_Table_Entry + (C1 => 'S', + C2 => ' ', + From => First, + To => Last, + Last => True); + + -- Now output any embedded decisions + + Process_Decisions (N, 'X'); + end Traverse_Generic_Instantiation; + + ------------------------------------------ + -- Traverse_Generic_Package_Declaration -- + ------------------------------------------ + + procedure Traverse_Generic_Package_Declaration (N : Node_Id) is + begin + Process_Decisions (Generic_Formal_Declarations (N), 'X'); + Traverse_Package_Declaration (N); + end Traverse_Generic_Package_Declaration; + + ----------------------------------------- + -- Traverse_Handled_Statement_Sequence -- + ----------------------------------------- + + procedure Traverse_Handled_Statement_Sequence (N : Node_Id) is + Handler : Node_Id; + + begin + -- For package bodies without a statement part, the parser adds an empty + -- one, to normalize the representation. The null statement therein, + -- which does not come from source, does not get a SCO. + + if Present (N) and then Comes_From_Source (N) then + Traverse_Declarations_Or_Statements (Statements (N)); + + if Present (Exception_Handlers (N)) then + Handler := First (Exception_Handlers (N)); + while Present (Handler) loop + Traverse_Declarations_Or_Statements (Statements (Handler)); + Next (Handler); + end loop; + end if; + end if; + end Traverse_Handled_Statement_Sequence; + + --------------------------- + -- Traverse_Package_Body -- + --------------------------- + + procedure Traverse_Package_Body (N : Node_Id) is + begin + Traverse_Declarations_Or_Statements (Declarations (N)); + Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N)); + end Traverse_Package_Body; + + ---------------------------------- + -- Traverse_Package_Declaration -- + ---------------------------------- + + procedure Traverse_Package_Declaration (N : Node_Id) is + Spec : constant Node_Id := Specification (N); + begin + Traverse_Declarations_Or_Statements (Visible_Declarations (Spec)); + Traverse_Declarations_Or_Statements (Private_Declarations (Spec)); + end Traverse_Package_Declaration; + + ------------------------------ + -- Traverse_Subprogram_Body -- + ------------------------------ + + procedure Traverse_Subprogram_Body (N : Node_Id) is + begin + Traverse_Declarations_Or_Statements (Declarations (N)); + Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N)); + end Traverse_Subprogram_Body; + + ------------------------------------- + -- Traverse_Subprogram_Declaration -- + ------------------------------------- + + procedure Traverse_Subprogram_Declaration (N : Node_Id) is + ADN : constant Node_Id := Aux_Decls_Node (Parent (N)); + begin + Traverse_Declarations_Or_Statements (Config_Pragmas (ADN)); + Traverse_Declarations_Or_Statements (Declarations (ADN)); + Traverse_Declarations_Or_Statements (Pragmas_After (ADN)); + end Traverse_Subprogram_Declaration; + +end Par_SCO; diff --git a/gcc/ada/par_sco.ads b/gcc/ada/par_sco.ads new file mode 100644 index 000000000..97e4a6a61 --- /dev/null +++ b/gcc/ada/par_sco.ads @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R _ S C O -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 to deal with generation and output +-- of Soure Coverage Obligations (SCO's) used for coverage analysis purposes. +-- See package SCOs for full documentation of format of SCO information. + +with Types; use Types; + +package Par_SCO is + + ----------------- + -- Subprograms -- + ----------------- + + procedure Initialize; + -- Initialize internal tables for a new compilation + + procedure SCO_Record (U : Unit_Number_Type); + -- This procedure scans the tree for the unit identified by U, populating + -- internal tables recording the SCO information. Note that this is done + -- before any semantic analysis/expansion happens. + + procedure Set_SCO_Condition (Cond : Node_Id; Val : Boolean); + -- This procedure is called during semantic analysis to record a condition + -- which has been identified as always True or always False, as indicated + -- by Val. The condition is identified by the First_Sloc value in the + -- original tree associated with Cond. + + procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr); + -- This procedure is called from Sem_Prag when a pragma is enabled (i.e. + -- when the Pragma_Enabled flag is set). Loc is the Sloc of the N_Pragma + -- node. This is used to enable the corresponding SCO table entry. Note + -- that we use the Sloc as the key here, since in the generic case, the + -- analysis is on a copy of the node, which is different from the node + -- seen by Par_SCO in the parse tree (but the Sloc values are the same). + + procedure SCO_Output; + -- Outputs SCO lines for all units, with appropriate section headers, for + -- unit U in the ALI file, as recorded by previous calls to SCO_Record, + -- possibly modified by calls to Set_SCO_Condition. + + procedure dsco; + -- Debug routine to dump internal SCO table. This is a raw format dump + -- showing exactly what the table contains. + + procedure pscos; + -- Debugging procedure to output contents of SCO binary tables in the + -- format in which they appear in an ALI file. + +end Par_SCO; diff --git a/gcc/ada/prep.adb b/gcc/ada/prep.adb new file mode 100644 index 000000000..2b0e1378b --- /dev/null +++ b/gcc/ada/prep.adb @@ -0,0 +1,1483 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R E P -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Csets; use Csets; +with Err_Vars; use Err_Vars; +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; +with Scans; use Scans; +with Snames; use Snames; +with Sinput; +with Stringt; use Stringt; +with Table; + +with GNAT.Heap_Sort_G; + +package body Prep is + + use Symbol_Table; + + type Token_Name_Array is array (Token_Type) of Name_Id; + Token_Names : constant Token_Name_Array := + (Tok_Abort => Name_Abort, + Tok_Abs => Name_Abs, + Tok_Abstract => Name_Abstract, + Tok_Accept => Name_Accept, + Tok_Aliased => Name_Aliased, + Tok_All => Name_All, + Tok_Array => Name_Array, + Tok_And => Name_And, + Tok_At => Name_At, + Tok_Begin => Name_Begin, + Tok_Body => Name_Body, + Tok_Case => Name_Case, + Tok_Constant => Name_Constant, + Tok_Declare => Name_Declare, + Tok_Delay => Name_Delay, + Tok_Delta => Name_Delta, + Tok_Digits => Name_Digits, + Tok_Else => Name_Else, + Tok_Elsif => Name_Elsif, + Tok_End => Name_End, + Tok_Entry => Name_Entry, + Tok_Exception => Name_Exception, + Tok_Exit => Name_Exit, + Tok_For => Name_For, + Tok_Function => Name_Function, + Tok_Generic => Name_Generic, + Tok_Goto => Name_Goto, + Tok_If => Name_If, + Tok_Is => Name_Is, + Tok_Limited => Name_Limited, + Tok_Loop => Name_Loop, + Tok_Mod => Name_Mod, + Tok_New => Name_New, + Tok_Null => Name_Null, + Tok_Of => Name_Of, + Tok_Or => Name_Or, + Tok_Others => Name_Others, + Tok_Out => Name_Out, + Tok_Package => Name_Package, + Tok_Pragma => Name_Pragma, + Tok_Private => Name_Private, + Tok_Procedure => Name_Procedure, + Tok_Protected => Name_Protected, + Tok_Raise => Name_Raise, + Tok_Range => Name_Range, + Tok_Record => Name_Record, + Tok_Rem => Name_Rem, + Tok_Renames => Name_Renames, + Tok_Requeue => Name_Requeue, + Tok_Return => Name_Return, + Tok_Reverse => Name_Reverse, + Tok_Select => Name_Select, + Tok_Separate => Name_Separate, + Tok_Subtype => Name_Subtype, + Tok_Tagged => Name_Tagged, + Tok_Task => Name_Task, + Tok_Terminate => Name_Terminate, + Tok_Then => Name_Then, + Tok_Type => Name_Type, + Tok_Until => Name_Until, + Tok_Use => Name_Use, + Tok_When => Name_When, + Tok_While => Name_While, + Tok_With => Name_With, + Tok_Xor => Name_Xor, + others => No_Name); + + Already_Initialized : Boolean := False; + -- Used to avoid repetition of the part of the initialisation that needs + -- to be done only once. + + Empty_String : String_Id; + -- "", as a string_id + + String_False : String_Id; + -- "false", as a string_id + + --------------- + -- Behaviour -- + --------------- + + -- Accesses to procedure specified by procedure Initialize + + Error_Msg : Error_Msg_Proc; + -- Report an error + + Scan : Scan_Proc; + -- Scan one token + + Set_Ignore_Errors : Set_Ignore_Errors_Proc; + -- Indicate if error should be taken into account + + Put_Char : Put_Char_Proc; + -- Output one character + + New_EOL : New_EOL_Proc; + -- Output an end of line indication + + ------------------------------- + -- State of the Preprocessor -- + ------------------------------- + + type Pp_State is record + If_Ptr : Source_Ptr; + -- The location of the #if statement. + -- Used to flag #if with no corresponding #end if, at the end. + + Else_Ptr : Source_Ptr; + -- The location of the #else statement. + -- Used to detect multiple #else. + + Deleting : Boolean; + -- Set to True when the code should be deleted or commented out + + Match_Seen : Boolean; + -- Set to True when a condition in an #if or an #elsif is True. + -- Also set to True if Deleting at the previous level is True. + -- Used to decide if Deleting should be set to True in a following + -- #elsif or #else. + + end record; + + type Pp_Depth is new Nat; + + Ground : constant Pp_Depth := 0; + + package Pp_States is new Table.Table + (Table_Component_Type => Pp_State, + Table_Index_Type => Pp_Depth, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Prep.Pp_States"); + -- A stack of the states of the preprocessor, for nested #if + + type Operator is (None, Op_Or, Op_And); + + ----------------- + -- Subprograms -- + ----------------- + + function Deleting return Boolean; + -- Return True if code should be deleted or commented out + + function Expression + (Evaluate_It : Boolean; + Complemented : Boolean := False) return Boolean; + -- Evaluate a condition in an #if or an #elsif statement. + -- If Evaluate_It is False, the condition is effectively evaluated, + -- otherwise, only the syntax is checked. + + procedure Go_To_End_Of_Line; + -- Advance the scan pointer until we reach an end of line or the end + -- of the buffer. + + function Matching_Strings (S1, S2 : String_Id) return Boolean; + -- Returns True if the two string parameters are equal (case insensitive) + + --------------------------------------- + -- Change_Reserved_Keyword_To_Symbol -- + --------------------------------------- + + procedure Change_Reserved_Keyword_To_Symbol + (All_Keywords : Boolean := False) + is + New_Name : constant Name_Id := Token_Names (Token); + + begin + if New_Name /= No_Name then + case Token is + when Tok_If | Tok_Else | Tok_Elsif | Tok_End | + Tok_And | Tok_Or | Tok_Then => + if All_Keywords then + Token := Tok_Identifier; + Token_Name := New_Name; + end if; + + when others => + Token := Tok_Identifier; + Token_Name := New_Name; + end case; + end if; + end Change_Reserved_Keyword_To_Symbol; + + ------------------------------------------ + -- Check_Command_Line_Symbol_Definition -- + ------------------------------------------ + + procedure Check_Command_Line_Symbol_Definition + (Definition : String; + Data : out Symbol_Data) + is + Index : Natural := 0; + Result : Symbol_Data; + + begin + -- Look for the character '=' + + for J in Definition'Range loop + if Definition (J) = '=' then + Index := J; + exit; + end if; + end loop; + + -- If no character '=', then the value is True + + if Index = 0 then + -- Put the symbol in the name buffer + + Name_Len := Definition'Length; + Name_Buffer (1 .. Name_Len) := Definition; + Result := True_Value; + + elsif Index = Definition'First then + Fail ("invalid symbol definition """ & Definition & """"); + + else + -- Put the symbol in the name buffer + + Name_Len := Index - Definition'First; + Name_Buffer (1 .. Name_Len) := + String'(Definition (Definition'First .. Index - 1)); + + -- Check the syntax of the value + + if Definition (Index + 1) /= '"' + or else Definition (Definition'Last) /= '"' + then + for J in Index + 1 .. Definition'Last loop + case Definition (J) is + when '_' | '.' | '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' => + null; + + when others => + Fail ("illegal value """ + & Definition (Index + 1 .. Definition'Last) + & """"); + end case; + end loop; + end if; + + -- And put the value in the result + + Result.Is_A_String := False; + Start_String; + Store_String_Chars (Definition (Index + 1 .. Definition'Last)); + Result.Value := End_String; + end if; + + -- Now, check the syntax of the symbol (we don't allow accented and + -- wide characters) + + if Name_Buffer (1) not in 'a' .. 'z' + and then Name_Buffer (1) not in 'A' .. 'Z' + then + Fail ("symbol """ + & Name_Buffer (1 .. Name_Len) + & """ does not start with a letter"); + end if; + + for J in 2 .. Name_Len loop + case Name_Buffer (J) is + when 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' => + null; + + when '_' => + if J = Name_Len then + Fail ("symbol """ + & Name_Buffer (1 .. Name_Len) + & """ end with a '_'"); + + elsif Name_Buffer (J + 1) = '_' then + Fail ("symbol """ + & Name_Buffer (1 .. Name_Len) + & """ contains consecutive '_'"); + end if; + + when others => + Fail ("symbol """ + & Name_Buffer (1 .. Name_Len) + & """ contains illegal character(s)"); + end case; + end loop; + + Result.On_The_Command_Line := True; + + -- Put the symbol name in the result + + declare + Sym : constant String := Name_Buffer (1 .. Name_Len); + + begin + for Index in 1 .. Name_Len loop + Name_Buffer (Index) := Fold_Lower (Name_Buffer (Index)); + end loop; + + Result.Symbol := Name_Find; + Name_Len := Sym'Length; + Name_Buffer (1 .. Name_Len) := Sym; + Result.Original := Name_Find; + end; + + Data := Result; + end Check_Command_Line_Symbol_Definition; + + -------------- + -- Deleting -- + -------------- + + function Deleting return Boolean is + begin + -- Always return False when not inside an #if statement + + if Pp_States.Last = Ground then + return False; + else + return Pp_States.Table (Pp_States.Last).Deleting; + end if; + end Deleting; + + ---------------- + -- Expression -- + ---------------- + + function Expression + (Evaluate_It : Boolean; + Complemented : Boolean := False) return Boolean + is + Evaluation : Boolean := Evaluate_It; + -- Is set to False after an "or else" when left term is True and + -- after an "and then" when left term is False. + + Final_Result : Boolean := False; + + Current_Result : Boolean := False; + -- Value of a term + + Current_Operator : Operator := None; + Symbol1 : Symbol_Id; + Symbol2 : Symbol_Id; + Symbol_Name1 : Name_Id; + Symbol_Name2 : Name_Id; + Symbol_Pos1 : Source_Ptr; + Symbol_Pos2 : Source_Ptr; + Symbol_Value1 : String_Id; + Symbol_Value2 : String_Id; + + begin + -- Loop for each term + + loop + Change_Reserved_Keyword_To_Symbol; + + Current_Result := False; + + case Token is + + when Tok_Left_Paren => + + -- ( expression ) + + Scan.all; + Current_Result := Expression (Evaluation); + + if Token = Tok_Right_Paren then + Scan.all; + + else + Error_Msg -- CODEFIX + ("`)` expected", Token_Ptr); + end if; + + when Tok_Not => + + -- not expression + + Scan.all; + Current_Result := + not Expression (Evaluation, Complemented => True); + + when Tok_Identifier => + Symbol_Name1 := Token_Name; + Symbol_Pos1 := Token_Ptr; + Scan.all; + + if Token = Tok_Apostrophe then + + -- symbol'Defined + + Scan.all; + + if Token = Tok_Identifier + and then Token_Name = Name_Defined + then + Scan.all; + + else + Error_Msg ("identifier `Defined` expected", Token_Ptr); + end if; + + if Evaluation then + Current_Result := Index_Of (Symbol_Name1) /= No_Symbol; + end if; + + elsif Token = Tok_Equal then + Scan.all; + + Change_Reserved_Keyword_To_Symbol; + + if Token = Tok_Identifier then + + -- symbol = symbol + + Symbol_Name2 := Token_Name; + Symbol_Pos2 := Token_Ptr; + Scan.all; + + if Evaluation then + Symbol1 := Index_Of (Symbol_Name1); + + if Symbol1 = No_Symbol then + if Undefined_Symbols_Are_False then + Symbol_Value1 := String_False; + + else + Error_Msg_Name_1 := Symbol_Name1; + Error_Msg ("unknown symbol %", Symbol_Pos1); + Symbol_Value1 := No_String; + end if; + + else + Symbol_Value1 := + Mapping.Table (Symbol1).Value; + end if; + + Symbol2 := Index_Of (Symbol_Name2); + + if Symbol2 = No_Symbol then + if Undefined_Symbols_Are_False then + Symbol_Value2 := String_False; + + else + Error_Msg_Name_1 := Symbol_Name2; + Error_Msg ("unknown symbol %", Symbol_Pos2); + Symbol_Value2 := No_String; + end if; + + else + Symbol_Value2 := Mapping.Table (Symbol2).Value; + end if; + + if Symbol_Value1 /= No_String + and then Symbol_Value2 /= No_String + then + Current_Result := Matching_Strings + (Symbol_Value1, Symbol_Value2); + end if; + end if; + + elsif Token = Tok_String_Literal then + + -- symbol = "value" + + if Evaluation then + Symbol1 := Index_Of (Symbol_Name1); + + if Symbol1 = No_Symbol then + if Undefined_Symbols_Are_False then + Symbol_Value1 := String_False; + + else + Error_Msg_Name_1 := Symbol_Name1; + Error_Msg ("unknown symbol %", Symbol_Pos1); + Symbol_Value1 := No_String; + end if; + + else + Symbol_Value1 := Mapping.Table (Symbol1).Value; + end if; + + if Symbol_Value1 /= No_String then + Current_Result := + Matching_Strings + (Symbol_Value1, + String_Literal_Id); + end if; + end if; + + Scan.all; + + else + Error_Msg + ("symbol or literal string expected", Token_Ptr); + end if; + + else + -- symbol (True or False) + + if Evaluation then + Symbol1 := Index_Of (Symbol_Name1); + + if Symbol1 = No_Symbol then + if Undefined_Symbols_Are_False then + Symbol_Value1 := String_False; + + else + Error_Msg_Name_1 := Symbol_Name1; + Error_Msg ("unknown symbol %", Symbol_Pos1); + Symbol_Value1 := No_String; + end if; + + else + Symbol_Value1 := Mapping.Table (Symbol1).Value; + end if; + + if Symbol_Value1 /= No_String then + String_To_Name_Buffer (Symbol_Value1); + + for Index in 1 .. Name_Len loop + Name_Buffer (Index) := + Fold_Lower (Name_Buffer (Index)); + end loop; + + if Name_Buffer (1 .. Name_Len) = "true" then + Current_Result := True; + + elsif Name_Buffer (1 .. Name_Len) = "false" then + Current_Result := False; + + else + Error_Msg_Name_1 := Symbol_Name1; + Error_Msg + ("value of symbol % is not True or False", + Symbol_Pos1); + end if; + end if; + end if; + end if; + + when others => + Error_Msg ("`(`, NOT or symbol expected", Token_Ptr); + end case; + + -- Update the cumulative final result + + case Current_Operator is + when None => + Final_Result := Current_Result; + + when Op_Or => + Final_Result := Final_Result or Current_Result; + + when Op_And => + Final_Result := Final_Result and Current_Result; + end case; + + -- Check the next operator + + if Token = Tok_And then + if Complemented then + Error_Msg + ("mixing NOT and AND is not allowed, parentheses are required", + Token_Ptr); + + elsif Current_Operator = Op_Or then + Error_Msg ("mixing OR and AND is not allowed", Token_Ptr); + end if; + + Current_Operator := Op_And; + Scan.all; + + if Token = Tok_Then then + Scan.all; + + if Final_Result = False then + Evaluation := False; + end if; + end if; + + elsif Token = Tok_Or then + if Complemented then + Error_Msg + ("mixing NOT and OR is not allowed, parentheses are required", + Token_Ptr); + + elsif Current_Operator = Op_And then + Error_Msg ("mixing AND and OR is not allowed", Token_Ptr); + end if; + + Current_Operator := Op_Or; + Scan.all; + + if Token = Tok_Else then + Scan.all; + + if Final_Result then + Evaluation := False; + end if; + end if; + + else + -- No operator: exit the term loop + + exit; + end if; + end loop; + + return Final_Result; + end Expression; + + ----------------------- + -- Go_To_End_Of_Line -- + ----------------------- + + procedure Go_To_End_Of_Line is + begin + -- Scan until we get an end of line or we reach the end of the buffer + + while Token /= Tok_End_Of_Line + and then Token /= Tok_EOF + loop + Scan.all; + end loop; + end Go_To_End_Of_Line; + + -------------- + -- Index_Of -- + -------------- + + function Index_Of (Symbol : Name_Id) return Symbol_Id is + begin + if Mapping.Table /= null then + for J in Symbol_Id range 1 .. Symbol_Table.Last (Mapping) loop + if Mapping.Table (J).Symbol = Symbol then + return J; + end if; + end loop; + end if; + + return No_Symbol; + end Index_Of; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + if not Already_Initialized then + Start_String; + Store_String_Chars ("True"); + True_Value.Value := End_String; + + Start_String; + Empty_String := End_String; + + Start_String; + Store_String_Chars ("False"); + String_False := End_String; + + Already_Initialized := True; + end if; + end Initialize; + + ------------------ + -- List_Symbols -- + ------------------ + + procedure List_Symbols (Foreword : String) is + Order : array (0 .. Integer (Symbol_Table.Last (Mapping))) + of Symbol_Id; + -- After alphabetical sorting, this array stores the indexes of the + -- symbols in the order they are displayed. + + function Lt (Op1, Op2 : Natural) return Boolean; + -- Comparison routine for sort call + + procedure Move (From : Natural; To : Natural); + -- Move routine for sort call + + -------- + -- Lt -- + -------- + + function Lt (Op1, Op2 : Natural) return Boolean is + S1 : constant String := + Get_Name_String (Mapping.Table (Order (Op1)).Symbol); + S2 : constant String := + Get_Name_String (Mapping.Table (Order (Op2)).Symbol); + + begin + return S1 < S2; + end Lt; + + ---------- + -- Move -- + ---------- + + procedure Move (From : Natural; To : Natural) is + begin + Order (To) := Order (From); + end Move; + + package Sort_Syms is new GNAT.Heap_Sort_G (Move, Lt); + + Max_L : Natural; + -- Maximum length of any symbol + + -- Start of processing for List_Symbols_Case + + begin + if Symbol_Table.Last (Mapping) = 0 then + return; + end if; + + if Foreword'Length > 0 then + Write_Eol; + Write_Line (Foreword); + + for J in Foreword'Range loop + Write_Char ('='); + end loop; + end if; + + -- Initialize the order + + for J in Order'Range loop + Order (J) := Symbol_Id (J); + end loop; + + -- Sort alphabetically + + Sort_Syms.Sort (Order'Last); + + Max_L := 7; + + for J in 1 .. Symbol_Table.Last (Mapping) loop + Get_Name_String (Mapping.Table (J).Original); + Max_L := Integer'Max (Max_L, Name_Len); + end loop; + + Write_Eol; + Write_Str ("Symbol"); + + for J in 1 .. Max_L - 5 loop + Write_Char (' '); + end loop; + + Write_Line ("Value"); + + Write_Str ("------"); + + for J in 1 .. Max_L - 5 loop + Write_Char (' '); + end loop; + + Write_Line ("------"); + + for J in 1 .. Order'Last loop + declare + Data : constant Symbol_Data := Mapping.Table (Order (J)); + + begin + Get_Name_String (Data.Original); + Write_Str (Name_Buffer (1 .. Name_Len)); + + for K in Name_Len .. Max_L loop + Write_Char (' '); + end loop; + + String_To_Name_Buffer (Data.Value); + + if Data.Is_A_String then + Write_Char ('"'); + + for J in 1 .. Name_Len loop + Write_Char (Name_Buffer (J)); + + if Name_Buffer (J) = '"' then + Write_Char ('"'); + end if; + end loop; + + Write_Char ('"'); + + else + Write_Str (Name_Buffer (1 .. Name_Len)); + end if; + end; + + Write_Eol; + end loop; + + Write_Eol; + end List_Symbols; + + ---------------------- + -- Matching_Strings -- + ---------------------- + + function Matching_Strings (S1, S2 : String_Id) return Boolean is + begin + String_To_Name_Buffer (S1); + + for Index in 1 .. Name_Len loop + Name_Buffer (Index) := Fold_Lower (Name_Buffer (Index)); + end loop; + + declare + String1 : constant String := Name_Buffer (1 .. Name_Len); + + begin + String_To_Name_Buffer (S2); + + for Index in 1 .. Name_Len loop + Name_Buffer (Index) := Fold_Lower (Name_Buffer (Index)); + end loop; + + return String1 = Name_Buffer (1 .. Name_Len); + end; + end Matching_Strings; + + -------------------- + -- Parse_Def_File -- + -------------------- + + procedure Parse_Def_File is + Symbol : Symbol_Id; + Symbol_Name : Name_Id; + Original_Name : Name_Id; + Data : Symbol_Data; + Value_Start : Source_Ptr; + Value_End : Source_Ptr; + Ch : Character; + + use ASCII; + + begin + Def_Line_Loop : + loop + Scan.all; + + exit Def_Line_Loop when Token = Tok_EOF; + + if Token /= Tok_End_Of_Line then + Change_Reserved_Keyword_To_Symbol; + + if Token /= Tok_Identifier then + Error_Msg ("identifier expected", Token_Ptr); + goto Cleanup; + end if; + + Symbol_Name := Token_Name; + Name_Len := 0; + + for Ptr in Token_Ptr .. Scan_Ptr - 1 loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Sinput.Source (Ptr); + end loop; + + Original_Name := Name_Find; + Scan.all; + + if Token /= Tok_Colon_Equal then + Error_Msg -- CODEFIX + ("`:=` expected", Token_Ptr); + goto Cleanup; + end if; + + Scan.all; + + if Token = Tok_String_Literal then + Data := (Symbol => Symbol_Name, + Original => Original_Name, + On_The_Command_Line => False, + Is_A_String => True, + Value => String_Literal_Id); + + Scan.all; + + if Token /= Tok_End_Of_Line and then Token /= Tok_EOF then + Error_Msg ("extraneous text in definition", Token_Ptr); + goto Cleanup; + end if; + + elsif Token = Tok_End_Of_Line or else Token = Tok_EOF then + Data := (Symbol => Symbol_Name, + Original => Original_Name, + On_The_Command_Line => False, + Is_A_String => False, + Value => Empty_String); + + else + Value_Start := Token_Ptr; + Value_End := Token_Ptr - 1; + Scan_Ptr := Token_Ptr; + + Value_Chars_Loop : + loop + Ch := Sinput.Source (Scan_Ptr); + + case Ch is + when '_' | '.' | '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' => + Value_End := Scan_Ptr; + Scan_Ptr := Scan_Ptr + 1; + + when ' ' | HT | VT | CR | LF | FF => + exit Value_Chars_Loop; + + when others => + Error_Msg ("illegal character", Scan_Ptr); + goto Cleanup; + end case; + end loop Value_Chars_Loop; + + Scan.all; + + if Token /= Tok_End_Of_Line and then Token /= Tok_EOF then + Error_Msg ("extraneous text in definition", Token_Ptr); + goto Cleanup; + end if; + + Start_String; + + while Value_Start <= Value_End loop + Store_String_Char (Sinput.Source (Value_Start)); + Value_Start := Value_Start + 1; + end loop; + + Data := (Symbol => Symbol_Name, + Original => Original_Name, + On_The_Command_Line => False, + Is_A_String => False, + Value => End_String); + end if; + + -- Now that we have the value, get the symbol index + + Symbol := Index_Of (Symbol_Name); + + if Symbol /= No_Symbol then + -- If we already have an entry for this symbol, replace it + -- with the new value, except if the symbol was declared + -- on the command line. + + if Mapping.Table (Symbol).On_The_Command_Line then + goto Continue; + end if; + + else + -- As it is the first time we see this symbol, create a new + -- entry in the table. + + if Mapping.Table = null then + Symbol_Table.Init (Mapping); + end if; + + Symbol_Table.Increment_Last (Mapping); + Symbol := Symbol_Table.Last (Mapping); + end if; + + Mapping.Table (Symbol) := Data; + goto Continue; + + <> + Set_Ignore_Errors (To => True); + + while Token /= Tok_End_Of_Line and then Token /= Tok_EOF loop + Scan.all; + end loop; + + Set_Ignore_Errors (To => False); + + <> + null; + end if; + end loop Def_Line_Loop; + end Parse_Def_File; + + ---------------- + -- Preprocess -- + ---------------- + + procedure Preprocess (Source_Modified : out Boolean) is + Start_Of_Processing : Source_Ptr; + Cond : Boolean; + Preprocessor_Line : Boolean := False; + No_Error_Found : Boolean := True; + Modified : Boolean := False; + + procedure Output (From, To : Source_Ptr); + -- Output the characters with indexes From .. To in the buffer to the + -- output file. + + procedure Output_Line (From, To : Source_Ptr); + -- Output a line or the end of a line from the buffer to the output + -- file, followed by an end of line terminator. Depending on the value + -- of Deleting and the switches, the line may be commented out, blank or + -- not output at all. + + ------------ + -- Output -- + ------------ + + procedure Output (From, To : Source_Ptr) is + begin + for J in From .. To loop + Put_Char (Sinput.Source (J)); + end loop; + end Output; + + ----------------- + -- Output_Line -- + ----------------- + + procedure Output_Line (From, To : Source_Ptr) is + begin + if Deleting or else Preprocessor_Line then + if Blank_Deleted_Lines then + New_EOL.all; + + elsif Comment_Deleted_Lines then + Put_Char ('-'); + Put_Char ('-'); + Put_Char ('!'); + + if From < To then + Put_Char (' '); + Output (From, To); + end if; + + New_EOL.all; + end if; + + else + Output (From, To); + New_EOL.all; + end if; + end Output_Line; + + -- Start of processing for Preprocess + + begin + Start_Of_Processing := Scan_Ptr; + + -- We need to call Scan for the first time, because Initialize_Scanner + -- is no longer doing it. + + Scan.all; + + Input_Line_Loop : loop + exit Input_Line_Loop when Token = Tok_EOF; + + Preprocessor_Line := False; + + if Token /= Tok_End_Of_Line then + + -- Preprocessor line + + if Token = Tok_Special and then Special_Character = '#' then + Modified := True; + Preprocessor_Line := True; + Scan.all; + + case Token is + + -- #if + + when Tok_If => + declare + If_Ptr : constant Source_Ptr := Token_Ptr; + + begin + Scan.all; + Cond := Expression (not Deleting); + + -- Check for an eventual "then" + + if Token = Tok_Then then + Scan.all; + end if; + + -- It is an error to have trailing characters after + -- the condition or "then". + + if Token /= Tok_End_Of_Line + and then Token /= Tok_EOF + then + Error_Msg + ("extraneous text on preprocessor line", + Token_Ptr); + No_Error_Found := False; + Go_To_End_Of_Line; + end if; + + declare + -- Set the initial state of this new "#if". This + -- must be done before incrementing the Last of + -- the table, otherwise function Deleting does + -- not report the correct value. + + New_State : constant Pp_State := + (If_Ptr => If_Ptr, + Else_Ptr => 0, + Deleting => Deleting + or else not Cond, + Match_Seen => Deleting or else Cond); + + begin + Pp_States.Increment_Last; + Pp_States.Table (Pp_States.Last) := New_State; + end; + end; + + -- #elsif + + when Tok_Elsif => + Cond := False; + + if Pp_States.Last = 0 + or else Pp_States.Table (Pp_States.Last).Else_Ptr /= 0 + then + Error_Msg ("no IF for this ELSIF", Token_Ptr); + No_Error_Found := False; + + else + Cond := + not Pp_States.Table (Pp_States.Last).Match_Seen; + end if; + + Scan.all; + Cond := Expression (Cond); + + -- Check for an eventual "then" + + if Token = Tok_Then then + Scan.all; + end if; + + -- It is an error to have trailing characters after + -- the condition or "then". + + if Token /= Tok_End_Of_Line + and then Token /= Tok_EOF + then + Error_Msg + ("extraneous text on preprocessor line", + Token_Ptr); + No_Error_Found := False; + + Go_To_End_Of_Line; + end if; + + -- Depending on the value of the condition, set the + -- new values of Deleting and Match_Seen. + if Pp_States.Last > 0 then + if Pp_States.Table (Pp_States.Last).Match_Seen then + Pp_States.Table (Pp_States.Last).Deleting := True; + else + if Cond then + Pp_States.Table (Pp_States.Last).Match_Seen := + True; + Pp_States.Table (Pp_States.Last).Deleting := + False; + end if; + end if; + end if; + + -- #else + + when Tok_Else => + if Pp_States.Last = 0 then + Error_Msg ("no IF for this ELSE", Token_Ptr); + No_Error_Found := False; + + elsif + Pp_States.Table (Pp_States.Last).Else_Ptr /= 0 + then + Error_Msg -- CODEFIX + ("duplicate ELSE line", Token_Ptr); + No_Error_Found := False; + end if; + + -- Set the possibly new values of Deleting and + -- Match_Seen. + + if Pp_States.Last > 0 then + if Pp_States.Table (Pp_States.Last).Match_Seen then + Pp_States.Table (Pp_States.Last).Deleting := + True; + + else + Pp_States.Table (Pp_States.Last).Match_Seen := + True; + Pp_States.Table (Pp_States.Last).Deleting := + False; + end if; + + -- Set the Else_Ptr to check for illegal #elsif + -- later. + + Pp_States.Table (Pp_States.Last).Else_Ptr := + Token_Ptr; + end if; + + Scan.all; + + -- It is an error to have characters after "#else" + if Token /= Tok_End_Of_Line + and then Token /= Tok_EOF + then + Error_Msg + ("extraneous text on preprocessor line", + Token_Ptr); + No_Error_Found := False; + Go_To_End_Of_Line; + end if; + + -- #end if; + + when Tok_End => + if Pp_States.Last = 0 then + Error_Msg ("no IF for this END", Token_Ptr); + No_Error_Found := False; + end if; + + Scan.all; + + if Token /= Tok_If then + Error_Msg -- CODEFIX + ("IF expected", Token_Ptr); + No_Error_Found := False; + + else + Scan.all; + + if Token /= Tok_Semicolon then + Error_Msg -- CODEFIX + ("`;` Expected", Token_Ptr); + No_Error_Found := False; + + else + Scan.all; + + -- It is an error to have character after + -- "#end if;". + if Token /= Tok_End_Of_Line + and then Token /= Tok_EOF + then + Error_Msg + ("extraneous text on preprocessor line", + Token_Ptr); + No_Error_Found := False; + end if; + end if; + end if; + + -- In case of one of the errors above, skip the tokens + -- until the end of line is reached. + + Go_To_End_Of_Line; + + -- Decrement the depth of the #if stack + + if Pp_States.Last > 0 then + Pp_States.Decrement_Last; + end if; + + -- Illegal preprocessor line + + when others => + No_Error_Found := False; + + if Pp_States.Last = 0 then + Error_Msg -- CODEFIX + ("IF expected", Token_Ptr); + + elsif + Pp_States.Table (Pp_States.Last).Else_Ptr = 0 + then + Error_Msg + ("IF, ELSIF, ELSE, or `END IF` expected", + Token_Ptr); + + else + Error_Msg ("IF or `END IF` expected", Token_Ptr); + end if; + + -- Skip to the end of this illegal line + + Go_To_End_Of_Line; + end case; + + -- Not a preprocessor line + + else + -- Do not report errors for those lines, even if there are + -- Ada parsing errors. + + Set_Ignore_Errors (To => True); + + if Deleting then + Go_To_End_Of_Line; + + else + while Token /= Tok_End_Of_Line + and then Token /= Tok_EOF + loop + if Token = Tok_Special + and then Special_Character = '$' + then + Modified := True; + + declare + Dollar_Ptr : constant Source_Ptr := Token_Ptr; + Symbol : Symbol_Id; + + begin + Scan.all; + Change_Reserved_Keyword_To_Symbol; + + if Token = Tok_Identifier + and then Token_Ptr = Dollar_Ptr + 1 + then + -- $symbol + + Symbol := Index_Of (Token_Name); + + -- If symbol exists, replace by its value + + if Symbol /= No_Symbol then + Output (Start_Of_Processing, Dollar_Ptr - 1); + Start_Of_Processing := Scan_Ptr; + String_To_Name_Buffer + (Mapping.Table (Symbol).Value); + + if Mapping.Table (Symbol).Is_A_String then + + -- Value is an Ada string + + Put_Char ('"'); + + for J in 1 .. Name_Len loop + Put_Char (Name_Buffer (J)); + + if Name_Buffer (J) = '"' then + Put_Char ('"'); + end if; + end loop; + + Put_Char ('"'); + + else + -- Value is a sequence of characters, not + -- an Ada string. + + for J in 1 .. Name_Len loop + Put_Char (Name_Buffer (J)); + end loop; + end if; + end if; + end if; + end; + end if; + + Scan.all; + end loop; + end if; + + Set_Ignore_Errors (To => False); + end if; + end if; + + pragma Assert (Token = Tok_End_Of_Line or else Token = Tok_EOF); + + -- At this point, the token is either end of line or EOF. + -- The line to possibly output stops just before the token. + + Output_Line (Start_Of_Processing, Token_Ptr - 1); + + -- If we are at the end of a line, the scan pointer is at the first + -- non blank character, not necessarily the first character of the + -- line; so, we have to deduct Start_Of_Processing from the token + -- pointer. + + if Token = Tok_End_Of_Line then + if (Sinput.Source (Token_Ptr) = ASCII.CR + and then Sinput.Source (Token_Ptr + 1) = ASCII.LF) + or else + (Sinput.Source (Token_Ptr) = ASCII.CR + and then Sinput.Source (Token_Ptr + 1) = ASCII.LF) + then + Start_Of_Processing := Token_Ptr + 2; + else + Start_Of_Processing := Token_Ptr + 1; + end if; + end if; + + -- Now, scan the first token of the next line. If the token is EOF, + -- the scan pointer will not move, and the token will still be EOF. + + Set_Ignore_Errors (To => True); + Scan.all; + Set_Ignore_Errors (To => False); + end loop Input_Line_Loop; + + -- Report an error for any missing some "#end if;" + + for Level in reverse 1 .. Pp_States.Last loop + Error_Msg ("no `END IF` for this IF", Pp_States.Table (Level).If_Ptr); + No_Error_Found := False; + end loop; + + Source_Modified := No_Error_Found and Modified; + end Preprocess; + + ----------------- + -- Setup_Hooks -- + ----------------- + + procedure Setup_Hooks + (Error_Msg : Error_Msg_Proc; + Scan : Scan_Proc; + Set_Ignore_Errors : Set_Ignore_Errors_Proc; + Put_Char : Put_Char_Proc; + New_EOL : New_EOL_Proc) + is + begin + pragma Assert (Already_Initialized); + + Prep.Error_Msg := Error_Msg; + Prep.Scan := Scan; + Prep.Set_Ignore_Errors := Set_Ignore_Errors; + Prep.Put_Char := Put_Char; + Prep.New_EOL := New_EOL; + end Setup_Hooks; + +end Prep; diff --git a/gcc/ada/prep.ads b/gcc/ada/prep.ads new file mode 100644 index 000000000..801167ee5 --- /dev/null +++ b/gcc/ada/prep.ads @@ -0,0 +1,135 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R E P -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.Dynamic_Tables; + +with Namet; use Namet; +with Types; use Types; + +package Prep is + + ----------------- + -- Symbol Data -- + ----------------- + + type Symbol_Data is record + Symbol : Name_Id := No_Name; + -- The symbol in lower case + + Original : Name_Id := No_Name; + -- The symbol as originally given in the definition file or on + -- the command line. + + On_The_Command_Line : Boolean := False; + -- Set to True if symbol is defined on the command line. + -- Used to prevent replacement of command line symbols by definition + -- file symbols. + + Is_A_String : Boolean := False; + -- Indicate if the value of the symbol has been specified as a string + -- or simply as a sequence of characters. + + Value : String_Id := No_String; + -- The value of the symbol (string or sequence of characters) + + end record; + + True_Value : Symbol_Data := + (Symbol => No_Name, + Original => No_Name, + On_The_Command_Line => False, + Is_A_String => False, + Value => No_String); + + type Symbol_Id is new Nat; + No_Symbol : constant Symbol_Id := 0; + + package Symbol_Table is new GNAT.Dynamic_Tables + (Table_Component_Type => Symbol_Data, + Table_Index_Type => Symbol_Id, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100); + -- The table of all symbols + + Mapping : Symbol_Table.Instance; + -- The mapping table of symbols to values used by procedure Parse_Def_File + -- and Preprocess. + + function Index_Of (Symbol : Name_Id) return Symbol_Id; + -- Return the index in the Mapping table of Symbol. + -- Return No_Symbol if Symbol in not in the Mapping table. + + -- Access to procedure types used by procedure Initialize below: + + type Error_Msg_Proc is access procedure + (Msg : String; Flag_Location : Source_Ptr); + + type Scan_Proc is access procedure; + + type Set_Ignore_Errors_Proc is access procedure (To : Boolean); + + type Put_Char_Proc is access procedure (C : Character); + + type New_EOL_Proc is access procedure; + + procedure Initialize; + -- Initialize the preprocessor's global structures + + procedure Setup_Hooks + (Error_Msg : Error_Msg_Proc; + Scan : Scan_Proc; + Set_Ignore_Errors : Set_Ignore_Errors_Proc; + Put_Char : Put_Char_Proc; + New_EOL : New_EOL_Proc); + -- Set the i/o hooks used by the preprocessor + + procedure Parse_Def_File; + -- Parse the definition file. The definition file must have already been + -- loaded and the scanner initialized. + + procedure Preprocess (Source_Modified : out Boolean); + -- Preprocess the input file. The input file must have already been loaded + -- and the scanner initialized. Source_Modified is set to True iff the + -- preprocessor modified the source text. + + procedure Check_Command_Line_Symbol_Definition + (Definition : String; + Data : out Symbol_Data); + -- Check the validity of a command line definition =. + -- Return the symbol and its value in Data if the definition is valid, + -- fail if it is not valid. + + procedure Change_Reserved_Keyword_To_Symbol + (All_Keywords : Boolean := False); + -- If Token is an Ada reserved word (other than IF, ELSIF, ELSE, + -- END, AND, OR, THEN when All_Keywords is False), change it to + -- Tok_Identifier with the corresponding Token_Name. + + procedure List_Symbols (Foreword : String); + -- List the symbols used for preprocessing a file, with their values. + -- If Foreword is not empty, Output Foreword before the list. + +end Prep; diff --git a/gcc/ada/prepcomp.adb b/gcc/ada/prepcomp.adb new file mode 100644 index 000000000..62f962aa4 --- /dev/null +++ b/gcc/ada/prepcomp.adb @@ -0,0 +1,788 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R E P C O M P -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 Errout; use Errout; +with Lib.Writ; use Lib.Writ; +with Opt; use Opt; +with Osint; use Osint; +with Prep; use Prep; +with Scans; use Scans; +with Scn; use Scn; +with Sinput.L; use Sinput.L; +with Stringt; use Stringt; +with Table; +with Types; use Types; + +package body Prepcomp is + + No_Preprocessing : Boolean := True; + -- Set to False if there is at least one source that needs to be + -- preprocessed. + + Source_Index_Of_Preproc_Data_File : Source_File_Index := No_Source_File; + + -- The following variable should be a constant, but this is not possible + -- because its type GNAT.Dynamic_Tables.Instance has a component P of + -- uninitialized private type GNAT.Dynamic_Tables.Table_Private and there + -- are no exported values for this private type. Warnings are Off because + -- it is never assigned a value. + + pragma Warnings (Off); + No_Mapping : Prep.Symbol_Table.Instance; + pragma Warnings (On); + + type String_Ptr is access String; + type String_Array is array (Positive range <>) of String_Ptr; + type String_Array_Ptr is access String_Array; + + procedure Free is + new Ada.Unchecked_Deallocation (String_Array, String_Array_Ptr); + + Symbol_Definitions : String_Array_Ptr := new String_Array (1 .. 4); + -- An extensible array to temporarily stores symbol definitions specified + -- on the command line with -gnateD switches. + + Last_Definition : Natural := 0; + -- Index of last symbol definition in array Symbol_Definitions + + type Preproc_Data is record + Mapping : Symbol_Table.Instance; + File_Name : File_Name_Type := No_File; + Deffile : String_Id := No_String; + Undef_False : Boolean := False; + Always_Blank : Boolean := False; + Comments : Boolean := False; + List_Symbols : Boolean := False; + Processed : Boolean := False; + end record; + -- Structure to keep the preprocessing data for a file name or for the + -- default (when Name_Id = No_Name). + + No_Preproc_Data : constant Preproc_Data := + (Mapping => No_Mapping, + File_Name => No_File, + Deffile => No_String, + Undef_False => False, + Always_Blank => False, + Comments => False, + List_Symbols => False, + Processed => False); + + Default_Data : Preproc_Data := No_Preproc_Data; + -- The preprocessing data to be used when no specific preprocessing data + -- is specified for a source. + + Default_Data_Defined : Boolean := False; + -- True if source for which no specific preprocessing is specified need to + -- be preprocess with the Default_Data. + + Current_Data : Preproc_Data := No_Preproc_Data; + + package Preproc_Data_Table is new Table.Table + (Table_Component_Type => Preproc_Data, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 5, + Table_Increment => 100, + Table_Name => "Prepcomp.Preproc_Data_Table"); + -- Table to store the specific preprocessing data + + Command_Line_Symbols : Symbol_Table.Instance; + -- A table to store symbol definitions specified on the command line with + -- -gnateD switches. + + package Dependencies is new Table.Table + (Table_Component_Type => Source_File_Index, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Prepcomp.Dependencies"); + -- Table to store the dependencies on preprocessing files + + procedure Add_Command_Line_Symbols; + -- Add the command line symbol definitions, if any, to Prep.Mapping table + + procedure Skip_To_End_Of_Line; + -- Ignore errors and scan up to the next end of line or the end of file + + ------------------------------ + -- Add_Command_Line_Symbols -- + ------------------------------ + + procedure Add_Command_Line_Symbols is + Symbol_Id : Prep.Symbol_Id; + + begin + for J in 1 .. Symbol_Table.Last (Command_Line_Symbols) loop + Symbol_Id := Prep.Index_Of (Command_Line_Symbols.Table (J).Symbol); + + if Symbol_Id = No_Symbol then + Symbol_Table.Increment_Last (Prep.Mapping); + Symbol_Id := Symbol_Table.Last (Prep.Mapping); + end if; + + Prep.Mapping.Table (Symbol_Id) := Command_Line_Symbols.Table (J); + end loop; + end Add_Command_Line_Symbols; + + ---------------------- + -- Add_Dependencies -- + ---------------------- + + procedure Add_Dependencies is + begin + for Index in 1 .. Dependencies.Last loop + Add_Preprocessing_Dependency (Dependencies.Table (Index)); + end loop; + end Add_Dependencies; + + --------------------------- + -- Add_Symbol_Definition -- + --------------------------- + + procedure Add_Symbol_Definition (Def : String) is + begin + -- If Symbol_Definitions is not large enough, double it + + if Last_Definition = Symbol_Definitions'Last then + declare + New_Symbol_Definitions : constant String_Array_Ptr := + new String_Array (1 .. 2 * Last_Definition); + + begin + New_Symbol_Definitions (Symbol_Definitions'Range) := + Symbol_Definitions.all; + Free (Symbol_Definitions); + Symbol_Definitions := New_Symbol_Definitions; + end; + end if; + + Last_Definition := Last_Definition + 1; + Symbol_Definitions (Last_Definition) := new String'(Def); + end Add_Symbol_Definition; + + ------------------- + -- Check_Symbols -- + ------------------- + + procedure Check_Symbols is + begin + -- If there is at least one switch -gnateD specified + + if Symbol_Table.Last (Command_Line_Symbols) >= 1 then + Current_Data := No_Preproc_Data; + No_Preprocessing := False; + Current_Data.Processed := True; + + -- Start with an empty, initialized mapping table; use Prep.Mapping, + -- because Prep.Index_Of uses Prep.Mapping. + + Prep.Mapping := No_Mapping; + Symbol_Table.Init (Prep.Mapping); + + -- Add the command line symbols + + Add_Command_Line_Symbols; + + -- Put the resulting Prep.Mapping in Current_Data, and immediately + -- set Prep.Mapping to nil. + + Current_Data.Mapping := Prep.Mapping; + Prep.Mapping := No_Mapping; + + -- Set the default data + + Default_Data := Current_Data; + Default_Data_Defined := True; + end if; + end Check_Symbols; + + ------------------------------ + -- Parse_Preprocessing_Data -- + ------------------------------ + + procedure Parse_Preprocessing_Data_File (N : File_Name_Type) is + OK : Boolean := False; + Dash_Location : Source_Ptr; + Symbol_Data : Prep.Symbol_Data; + Symbol_Id : Prep.Symbol_Id; + T : constant Nat := Total_Errors_Detected; + + begin + -- Load the preprocessing data file + + Source_Index_Of_Preproc_Data_File := Load_Preprocessing_Data_File (N); + + -- Fail if preprocessing data file cannot be found + + if Source_Index_Of_Preproc_Data_File = No_Source_File then + Get_Name_String (N); + Fail ("preprocessing data file """ + & Name_Buffer (1 .. Name_Len) + & """ not found"); + end if; + + -- Initialize scanner and set its behavior for processing a data file + + Scn.Scanner.Initialize_Scanner (Source_Index_Of_Preproc_Data_File); + Scn.Scanner.Set_End_Of_Line_As_Token (True); + Scn.Scanner.Reset_Special_Characters; + + For_Each_Line : loop + <> + Scan; + + exit For_Each_Line when Token = Tok_EOF; + + if Token = Tok_End_Of_Line then + goto Scan_Line; + end if; + + -- Line is not empty + + OK := False; + No_Preprocessing := False; + Current_Data := No_Preproc_Data; + + case Token is + when Tok_Asterisk => + + -- Default data + + if Default_Data_Defined then + Error_Msg + ("multiple default preprocessing data", Token_Ptr); + + else + OK := True; + Default_Data_Defined := True; + end if; + + when Tok_String_Literal => + + -- Specific data + + String_To_Name_Buffer (String_Literal_Id); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Current_Data.File_Name := Name_Find; + OK := True; + + for Index in 1 .. Preproc_Data_Table.Last loop + if Current_Data.File_Name = + Preproc_Data_Table.Table (Index).File_Name + then + Error_Msg_File_1 := Current_Data.File_Name; + Error_Msg + ("multiple preprocessing data for{", Token_Ptr); + OK := False; + exit; + end if; + end loop; + + when others => + Error_Msg ("`'*` or literal string expected", Token_Ptr); + end case; + + -- If there is a problem, skip the line + + if not OK then + Skip_To_End_Of_Line; + goto Scan_Line; + end if; + + -- Scan past the * or the literal string + + Scan; + + -- A literal string in second position is a definition file + + if Token = Tok_String_Literal then + Current_Data.Deffile := String_Literal_Id; + Current_Data.Processed := False; + Scan; + + else + -- If there is no definition file, set Processed to True now + + Current_Data.Processed := True; + end if; + + -- Start with an empty, initialized mapping table; use Prep.Mapping, + -- because Prep.Index_Of uses Prep.Mapping. + + Prep.Mapping := No_Mapping; + Symbol_Table.Init (Prep.Mapping); + + -- Check the switches that may follow + + while Token /= Tok_End_Of_Line and then Token /= Tok_EOF loop + if Token /= Tok_Minus then + Error_Msg -- CODEFIX + ("`'-` expected", Token_Ptr); + Skip_To_End_Of_Line; + goto Scan_Line; + end if; + + -- Keep the location of the '-' for possible error reporting + + Dash_Location := Token_Ptr; + + -- Scan past the '-' + + Scan; + OK := False; + Change_Reserved_Keyword_To_Symbol; + + -- An identifier (or a reserved word converted to an + -- identifier) is expected and there must be no blank space + -- between the '-' and the identifier. + + if Token = Tok_Identifier + and then Token_Ptr = Dash_Location + 1 + then + Get_Name_String (Token_Name); + + -- Check the character in the source, because the case is + -- significant. + + case Sinput.Source (Token_Ptr) is + when 'u' => + + -- Undefined symbol are False + + if Name_Len = 1 then + Current_Data.Undef_False := True; + OK := True; + end if; + + when 'b' => + + -- Blank lines + + if Name_Len = 1 then + Current_Data.Always_Blank := True; + OK := True; + end if; + + when 'c' => + + -- Comment removed lines + + if Name_Len = 1 then + Current_Data.Comments := True; + OK := True; + end if; + + when 's' => + + -- List symbols + + if Name_Len = 1 then + Current_Data.List_Symbols := True; + OK := True; + end if; + + when 'D' => + + -- Symbol definition + + OK := Name_Len > 1; + + if OK then + + -- A symbol must be an Ada identifier; it cannot start + -- with an underline or a digit. + + if Name_Buffer (2) = '_' + or else Name_Buffer (2) in '0' .. '9' + then + Error_Msg ("symbol expected", Token_Ptr + 1); + Skip_To_End_Of_Line; + goto Scan_Line; + end if; + + -- Get the name id of the symbol + + Symbol_Data.On_The_Command_Line := True; + Name_Buffer (1 .. Name_Len - 1) := + Name_Buffer (2 .. Name_Len); + Name_Len := Name_Len - 1; + Symbol_Data.Symbol := Name_Find; + + if Name_Buffer (1 .. Name_Len) = "if" + or else Name_Buffer (1 .. Name_Len) = "else" + or else Name_Buffer (1 .. Name_Len) = "elsif" + or else Name_Buffer (1 .. Name_Len) = "end" + or else Name_Buffer (1 .. Name_Len) = "not" + or else Name_Buffer (1 .. Name_Len) = "and" + or else Name_Buffer (1 .. Name_Len) = "then" + then + Error_Msg ("symbol expected", Token_Ptr + 1); + Skip_To_End_Of_Line; + goto Scan_Line; + end if; + + -- Get the name id of the original symbol, with + -- possibly capital letters. + + Name_Len := Integer (Scan_Ptr - Token_Ptr - 1); + + for J in 1 .. Name_Len loop + Name_Buffer (J) := + Sinput.Source (Token_Ptr + Text_Ptr (J)); + end loop; + + Symbol_Data.Original := Name_Find; + + -- Scan past D + + Scan; + + if Token /= Tok_Equal then + Error_Msg -- CODEFIX + ("`=` expected", Token_Ptr); + Skip_To_End_Of_Line; + goto Scan_Line; + end if; + + -- Scan past '=' + + Scan; + + -- Here any reserved word is OK + + Change_Reserved_Keyword_To_Symbol + (All_Keywords => True); + + -- Value can be an identifier (or a reserved word) + -- or a literal string. + + case Token is + when Tok_String_Literal => + Symbol_Data.Is_A_String := True; + Symbol_Data.Value := String_Literal_Id; + + when Tok_Identifier => + Symbol_Data.Is_A_String := False; + Start_String; + + for J in Token_Ptr .. Scan_Ptr - 1 loop + Store_String_Char (Sinput.Source (J)); + end loop; + + Symbol_Data.Value := End_String; + + when others => + Error_Msg + ("literal string or identifier expected", + Token_Ptr); + Skip_To_End_Of_Line; + goto Scan_Line; + end case; + + -- If symbol already exists, replace old definition + -- by new one. + + Symbol_Id := Prep.Index_Of (Symbol_Data.Symbol); + + -- Otherwise, add a new entry in the table + + if Symbol_Id = No_Symbol then + Symbol_Table.Increment_Last (Prep.Mapping); + Symbol_Id := Symbol_Table.Last (Mapping); + end if; + + Prep.Mapping.Table (Symbol_Id) := Symbol_Data; + end if; + + when others => + null; + end case; + + Scan; + end if; + + if not OK then + Error_Msg ("invalid switch", Dash_Location); + Skip_To_End_Of_Line; + goto Scan_Line; + end if; + end loop; + + -- Add the command line symbols, if any, possibly replacing symbols + -- just defined. + + Add_Command_Line_Symbols; + + -- Put the resulting Prep.Mapping in Current_Data, and immediately + -- set Prep.Mapping to nil. + + Current_Data.Mapping := Prep.Mapping; + Prep.Mapping := No_Mapping; + + -- Record Current_Data + + if Current_Data.File_Name = No_File then + Default_Data := Current_Data; + + else + Preproc_Data_Table.Increment_Last; + Preproc_Data_Table.Table (Preproc_Data_Table.Last) := Current_Data; + end if; + + Current_Data := No_Preproc_Data; + end loop For_Each_Line; + + Scn.Scanner.Set_End_Of_Line_As_Token (False); + + -- Fail if there were errors in the preprocessing data file + + if Total_Errors_Detected > T then + Errout.Finalize (Last_Call => True); + Errout.Output_Messages; + Fail ("errors found in preprocessing data file """ + & Get_Name_String (N) & """"); + end if; + + -- Record the dependency on the preprocessor data file + + Dependencies.Increment_Last; + Dependencies.Table (Dependencies.Last) := + Source_Index_Of_Preproc_Data_File; + end Parse_Preprocessing_Data_File; + + --------------------------- + -- Prepare_To_Preprocess -- + --------------------------- + + procedure Prepare_To_Preprocess + (Source : File_Name_Type; + Preprocessing_Needed : out Boolean) + is + Default : Boolean := False; + Index : Int := 0; + + begin + -- By default, preprocessing is not needed + + Preprocessing_Needed := False; + + if No_Preprocessing then + return; + end if; + + -- First, look for preprocessing data specific to the current source + + for J in 1 .. Preproc_Data_Table.Last loop + if Preproc_Data_Table.Table (J).File_Name = Source then + Index := J; + Current_Data := Preproc_Data_Table.Table (J); + exit; + end if; + end loop; + + -- If no specific preprocessing data, then take the default + + if Index = 0 then + if Default_Data_Defined then + Current_Data := Default_Data; + Default := True; + + else + -- If no default, then nothing to do + + return; + end if; + end if; + + -- Set the preprocessing flags according to the preprocessing data + + if Current_Data.Comments and then not Current_Data.Always_Blank then + Comment_Deleted_Lines := True; + Blank_Deleted_Lines := False; + + else + Comment_Deleted_Lines := False; + Blank_Deleted_Lines := True; + end if; + + Undefined_Symbols_Are_False := Current_Data.Undef_False; + List_Preprocessing_Symbols := Current_Data.List_Symbols; + + -- If not already done it, process the definition file + + if Current_Data.Processed then + + -- Set Prep.Mapping + + Prep.Mapping := Current_Data.Mapping; + + else + -- First put the mapping in Prep.Mapping, because Prep.Parse_Def_File + -- works on Prep.Mapping. + + Prep.Mapping := Current_Data.Mapping; + + String_To_Name_Buffer (Current_Data.Deffile); + + declare + N : constant File_Name_Type := Name_Find; + Deffile : constant Source_File_Index := + Load_Definition_File (N); + Add_Deffile : Boolean := True; + T : constant Nat := Total_Errors_Detected; + + begin + if Deffile = No_Source_File then + Fail ("definition file """ + & Get_Name_String (N) + & """ not found"); + end if; + + -- Initialize the preprocessor and set the characteristics of the + -- scanner for a definition file. + + Prep.Setup_Hooks + (Error_Msg => Errout.Error_Msg'Access, + Scan => Scn.Scanner.Scan'Access, + Set_Ignore_Errors => Errout.Set_Ignore_Errors'Access, + Put_Char => null, + New_EOL => null); + + Scn.Scanner.Set_End_Of_Line_As_Token (True); + Scn.Scanner.Reset_Special_Characters; + + -- Initialize the scanner and process the definition file + + Scn.Scanner.Initialize_Scanner (Deffile); + Prep.Parse_Def_File; + + -- Reset the behaviour of the scanner to the default + + Scn.Scanner.Set_End_Of_Line_As_Token (False); + + -- Fail if errors were found while processing the definition file + + if T /= Total_Errors_Detected then + Errout.Finalize (Last_Call => True); + Errout.Output_Messages; + Fail ("errors found in definition file """ + & Get_Name_String (N) + & """"); + end if; + + for Index in 1 .. Dependencies.Last loop + if Dependencies.Table (Index) = Deffile then + Add_Deffile := False; + exit; + end if; + end loop; + + if Add_Deffile then + Dependencies.Increment_Last; + Dependencies.Table (Dependencies.Last) := Deffile; + end if; + end; + + -- Get back the mapping, indicate that the definition file is + -- processed and store back the preprocessing data. + + Current_Data.Mapping := Prep.Mapping; + Current_Data.Processed := True; + + if Default then + Default_Data := Current_Data; + + else + Preproc_Data_Table.Table (Index) := Current_Data; + end if; + end if; + + Preprocessing_Needed := True; + end Prepare_To_Preprocess; + + --------------------------------------------- + -- Process_Command_Line_Symbol_Definitions -- + --------------------------------------------- + + procedure Process_Command_Line_Symbol_Definitions is + Symbol_Data : Prep.Symbol_Data; + Found : Boolean := False; + + begin + Symbol_Table.Init (Command_Line_Symbols); + + -- The command line definitions have been stored temporarily in + -- array Symbol_Definitions. + + for Index in 1 .. Last_Definition loop + -- Check each symbol definition, fail immediately if syntax is not + -- correct. + + Check_Command_Line_Symbol_Definition + (Definition => Symbol_Definitions (Index).all, + Data => Symbol_Data); + Found := False; + + -- If there is already a definition for this symbol, replace the old + -- definition by this one. + + for J in 1 .. Symbol_Table.Last (Command_Line_Symbols) loop + if Command_Line_Symbols.Table (J).Symbol = Symbol_Data.Symbol then + Command_Line_Symbols.Table (J) := Symbol_Data; + Found := True; + exit; + end if; + end loop; + + -- Otherwise, create a new entry in the table + + if not Found then + Symbol_Table.Increment_Last (Command_Line_Symbols); + Command_Line_Symbols.Table + (Symbol_Table.Last (Command_Line_Symbols)) := Symbol_Data; + end if; + end loop; + end Process_Command_Line_Symbol_Definitions; + + ------------------------- + -- Skip_To_End_Of_Line -- + ------------------------- + + procedure Skip_To_End_Of_Line is + begin + Set_Ignore_Errors (To => True); + + while Token /= Tok_End_Of_Line and then Token /= Tok_EOF loop + Scan; + end loop; + + Set_Ignore_Errors (To => False); + end Skip_To_End_Of_Line; + +end Prepcomp; diff --git a/gcc/ada/prepcomp.ads b/gcc/ada/prepcomp.ads new file mode 100644 index 000000000..5e747a148 --- /dev/null +++ b/gcc/ada/prepcomp.ads @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R E P C O M P -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package stores all preprocessing data for the compiler + +with Namet; use Namet; + +package Prepcomp is + + procedure Add_Dependencies; + -- Add dependencies on the preprocessing data file and the + -- preprocessing definition files, if any. + + procedure Add_Symbol_Definition (Def : String); + -- Add a symbol definition from the command line. + -- Fail if definition is illegal. + + procedure Check_Symbols; + -- Check if there are preprocessing symbols on the command line and + -- set preprocessing if there are some: all files are preprocessed with + -- these symbols. This procedure should not be called if there is a + -- preprocessing data file specified on the command line. Procedure + -- Parse_Preprocessing_Data_File should be called instead. + + procedure Parse_Preprocessing_Data_File (N : File_Name_Type); + -- Parse a preprocessing data file, specified with a -gnatep= switch + + procedure Prepare_To_Preprocess + (Source : File_Name_Type; + Preprocessing_Needed : out Boolean); + -- Prepare, if necessary, the preprocessor for a source file. + -- If the source file needs to be preprocessed, Preprocessing_Needed + -- is set to True. Otherwise, Preprocessing_Needed is set to False + -- and no preprocessing needs to be done. + + procedure Process_Command_Line_Symbol_Definitions; + -- Check symbol definitions that have been added by calls to procedure + -- Add_Symbol_Definition and stored as pointers to string, and put them in + -- a table. The reason the definitions were stored as pointer to strings is + -- that the name table is not yest initialized when we process the command + -- line switches. These symbol definitions will be later used in + -- the call to Prepare_To_Preprocess. + +end Prepcomp; diff --git a/gcc/ada/prj-attr-pm.adb b/gcc/ada/prj-attr-pm.adb new file mode 100644 index 000000000..9b75c0526 --- /dev/null +++ b/gcc/ada/prj-attr-pm.adb @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . A T T R . P M -- +-- -- +-- B o d y -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Prj.Attr.PM is + + ------------------- + -- Add_Attribute -- + ------------------- + + procedure Add_Attribute + (To_Package : Package_Node_Id; + Attribute_Name : Name_Id; + Attribute_Node : out Attribute_Node_Id) + is + begin + -- Only add attribute if package is already defined and is not unknown + + if To_Package /= Empty_Package and then + To_Package /= Unknown_Package + then + Attrs.Append ( + (Name => Attribute_Name, + Var_Kind => Undefined, + Optional_Index => False, + Attr_Kind => Unknown, + Read_Only => False, + Others_Allowed => False, + Next => + Package_Attributes.Table (To_Package.Value).First_Attribute)); + + Package_Attributes.Table (To_Package.Value).First_Attribute := + Attrs.Last; + Attribute_Node := (Value => Attrs.Last); + end if; + end Add_Attribute; + + ------------------------- + -- Add_Unknown_Package -- + ------------------------- + + procedure Add_Unknown_Package (Name : Name_Id; Id : out Package_Node_Id) is + begin + Package_Attributes.Increment_Last; + Id := (Value => Package_Attributes.Last); + Package_Attributes.Table (Id.Value) := + (Name => Name, + Known => False, + First_Attribute => Empty_Attr); + end Add_Unknown_Package; + +end Prj.Attr.PM; diff --git a/gcc/ada/prj-attr-pm.ads b/gcc/ada/prj-attr-pm.ads new file mode 100644 index 000000000..0c6ce2e0f --- /dev/null +++ b/gcc/ada/prj-attr-pm.ads @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . A T T R . P M -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains insecure procedures that are intended to be used +-- only inside the Prj and MLib hierarchies. It should not be imported by +-- other tools, such as GPS. + +package Prj.Attr.PM is + + -- The following procedures are not secure and should only be used by the + -- Project Manager, that is the packages of the Prj or MLib hierarchies. + -- What does "not secure" mean??? + + procedure Add_Unknown_Package (Name : Name_Id; Id : out Package_Node_Id); + -- Add a new unknown package. The Name cannot be the name of a predefined + -- or already registered package, but this is not checked. + + procedure Add_Attribute + (To_Package : Package_Node_Id; + Attribute_Name : Name_Id; + Attribute_Node : out Attribute_Node_Id); + -- Add an attribute to the list for package To_Package. Attribute_Name + -- cannot be the name of an existing attribute of the package, but this is + -- not checked. Does nothing if To_Package is Empty_Package. + +end Prj.Attr.PM; diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb new file mode 100644 index 000000000..6fb2c0a3e --- /dev/null +++ b/gcc/ada/prj-attr.adb @@ -0,0 +1,990 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . A T T R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Osint; +with Prj.Com; use Prj.Com; + +with GNAT.Case_Util; use GNAT.Case_Util; + +package body Prj.Attr is + + use GNAT; + + -- Data for predefined attributes and packages + + -- Names are in lower case and end with '#' + + -- Package names are preceded by 'P' + + -- Attribute names are preceded by two or three letters: + + -- The first letter is one of + -- 'S' for Single + -- 's' for Single with optional index + -- 'L' for List + -- 'l' for List of strings with optional indexes + + -- The second letter is one of + -- 'V' for single variable + -- 'A' for associative array + -- 'a' for case insensitive associative array + -- 'b' for associative array, case insensitive if file names are case + -- insensitive + -- 'c' same as 'b', with optional index + + -- The third optional letter is + -- 'R' to indicate that the attribute is read-only + -- 'O' to indicate that others is allowed as an index for an associative + -- array + + -- End is indicated by two consecutive '#' + + Initialization_Data : constant String := + + -- project level attributes + + -- General + + "SVRname#" & + "SVRproject_dir#" & + "lVmain#" & + "LVlanguages#" & + "Lbroots#" & + "SVexternally_built#" & + + -- Directories + + "SVobject_dir#" & + "SVexec_dir#" & + "LVsource_dirs#" & + "Lainherit_source_path#" & + "LVexcluded_source_dirs#" & + "LVignore_source_sub_dirs#" & + + -- Source files + + "LVsource_files#" & + "LVlocally_removed_files#" & + "LVexcluded_source_files#" & + "SVsource_list_file#" & + "SVexcluded_source_list_file#" & + "LVinterfaces#" & + + -- Projects (in aggregate projects) + + "LVproject_files#" & + "LVproject_path#" & + "SAexternal#" & + + -- Libraries + + "SVlibrary_dir#" & + "SVlibrary_name#" & + "SVlibrary_kind#" & + "SVlibrary_version#" & + "LVlibrary_interface#" & + "SVlibrary_auto_init#" & + "LVleading_library_options#" & + "LVlibrary_options#" & + "SVlibrary_src_dir#" & + "SVlibrary_ali_dir#" & + "SVlibrary_gcc#" & + "SVlibrary_symbol_file#" & + "SVlibrary_symbol_policy#" & + "SVlibrary_reference_symbol_file#" & + + -- Configuration - General + + "SVdefault_language#" & + "LVrun_path_option#" & + "SVrun_path_origin#" & + "SVseparate_run_path_options#" & + "Satoolchain_version#" & + "Satoolchain_description#" & + "Saobject_generated#" & + "Saobjects_linked#" & + "SVtarget#" & + + -- Configuration - Libraries + + "SVlibrary_builder#" & + "SVlibrary_support#" & + + -- Configuration - Archives + + "LVarchive_builder#" & + "LVarchive_builder_append_option#" & + "LVarchive_indexer#" & + "SVarchive_suffix#" & + "LVlibrary_partial_linker#" & + + -- Configuration - Shared libraries + + "SVshared_library_prefix#" & + "SVshared_library_suffix#" & + "SVsymbolic_link_supported#" & + "SVlibrary_major_minor_id_supported#" & + "SVlibrary_auto_init_supported#" & + "LVshared_library_minimum_switches#" & + "LVlibrary_version_switches#" & + "SVlibrary_install_name_option#" & + "Saruntime_library_dir#" & + "Saruntime_source_dir#" & + + -- package Naming + -- Some attributes are obsolescent, and renamed in the tree (see + -- Prj.Dect.Rename_Obsolescent_Attributes). + + "Pnaming#" & + "Saspecification_suffix#" & -- Always renamed to "spec_suffix" in tree + "Saspec_suffix#" & + "Saimplementation_suffix#" & -- Always renamed to "body_suffix" in tree + "Sabody_suffix#" & + "SVseparate_suffix#" & + "SVcasing#" & + "SVdot_replacement#" & + "sAspecification#" & -- Always renamed to "spec" in project tree + "sAspec#" & + "sAimplementation#" & -- Always renamed to "body" in project tree + "sAbody#" & + "Laspecification_exceptions#" & + "Laimplementation_exceptions#" & + + -- package Compiler + + "Pcompiler#" & + "Ladefault_switches#" & + "LcOswitches#" & + "SVlocal_configuration_pragmas#" & + "Salocal_config_file#" & + + -- Configuration - Compiling + + "Sadriver#" & + "Larequired_switches#" & + "Laleading_required_switches#" & + "Latrailing_required_switches#" & + "Lapic_option#" & + "Sapath_syntax#" & + "Saobject_file_suffix#" & + "Laobject_file_switches#" & + "Lamulti_unit_switches#" & + "Samulti_unit_object_separator#" & + + -- Configuration - Mapping files + + "Lamapping_file_switches#" & + "Samapping_spec_suffix#" & + "Samapping_body_suffix#" & + + -- Configuration - Config files + + "Laconfig_file_switches#" & + "Saconfig_body_file_name#" & + "Saconfig_body_file_name_index#" & + "Saconfig_body_file_name_pattern#" & + "Saconfig_spec_file_name#" & + "Saconfig_spec_file_name_index#" & + "Saconfig_spec_file_name_pattern#" & + "Saconfig_file_unique#" & + + -- Configuration - Dependencies + + "Ladependency_switches#" & + "Ladependency_driver#" & + + -- Configuration - Search paths + + "Lainclude_switches#" & + "Sainclude_path#" & + "Sainclude_path_file#" & + + -- package Builder + + "Pbuilder#" & + "Ladefault_switches#" & + "LcOswitches#" & + "Lcglobal_compilation_switches#" & + "Scexecutable#" & + "SVexecutable_suffix#" & + "SVglobal_configuration_pragmas#" & + "Saglobal_config_file#" & + + -- package gnatls + + "Pgnatls#" & + "LVswitches#" & + + -- package Binder + + "Pbinder#" & + "Ladefault_switches#" & + "LcOswitches#" & + + -- Configuration - Binding + + "Sadriver#" & + "Larequired_switches#" & + "Saprefix#" & + "Saobjects_path#" & + "Saobjects_path_file#" & + + -- package Linker + + "Plinker#" & + "LVrequired_switches#" & + "Ladefault_switches#" & + "LcOleading_switches#" & + "LcOswitches#" & + "LVlinker_options#" & + "SVmap_file_option#" & + + -- Configuration - Linking + + "SVdriver#" & + "LVexecutable_switch#" & + "SVlib_dir_switch#" & + "SVlib_name_switch#" & + + -- Configuration - Response files + + "SVmax_command_line_length#" & + "SVresponse_file_format#" & + "LVresponse_file_switches#" & + + -- package Cross_Reference + + "Pcross_reference#" & + "Ladefault_switches#" & + "LbOswitches#" & + + -- package Finder + + "Pfinder#" & + "Ladefault_switches#" & + "LbOswitches#" & + + -- package Pretty_Printer + + "Ppretty_printer#" & + "Ladefault_switches#" & + "LbOswitches#" & + + -- package gnatstub + + "Pgnatstub#" & + "Ladefault_switches#" & + "LbOswitches#" & + + -- package Check + + "Pcheck#" & + "Ladefault_switches#" & + "LbOswitches#" & + + -- package Synchronize + + "Psynchronize#" & + "Ladefault_switches#" & + "LbOswitches#" & + + -- package Eliminate + + "Peliminate#" & + "Ladefault_switches#" & + "LbOswitches#" & + + -- package Metrics + + "Pmetrics#" & + "Ladefault_switches#" & + "LbOswitches#" & + + -- package Ide + + "Pide#" & + "Ladefault_switches#" & + "SVremote_host#" & + "SVprogram_host#" & + "SVcommunication_protocol#" & + "Sacompiler_command#" & + "SVdebugger_command#" & + "SVgnatlist#" & + "SVvcs_kind#" & + "SVvcs_file_check#" & + "SVvcs_log_check#" & + "SVdocumentation_dir#" & + + -- package Stack + + "Pstack#" & + "LVswitches#" & + + "#"; + + Initialized : Boolean := False; + -- A flag to avoid multiple initialization + + Package_Names : String_List_Access := new Strings.String_List (1 .. 20); + Last_Package_Name : Natural := 0; + -- Package_Names (1 .. Last_Package_Name) contains the list of the known + -- package names, coming from the Initialization_Data string or from + -- calls to one of the two procedures Register_New_Package. + + procedure Add_Package_Name (Name : String); + -- Add a package name in the Package_Name list, extending it, if necessary + + function Name_Id_Of (Name : String) return Name_Id; + -- Returns the Name_Id for Name in lower case + + ---------------------- + -- Add_Package_Name -- + ---------------------- + + procedure Add_Package_Name (Name : String) is + begin + if Last_Package_Name = Package_Names'Last then + declare + New_List : constant Strings.String_List_Access := + new Strings.String_List (1 .. Package_Names'Last * 2); + begin + New_List (Package_Names'Range) := Package_Names.all; + Package_Names := New_List; + end; + end if; + + Last_Package_Name := Last_Package_Name + 1; + Package_Names (Last_Package_Name) := new String'(Name); + end Add_Package_Name; + + ----------------------- + -- Attribute_Kind_Of -- + ----------------------- + + function Attribute_Kind_Of + (Attribute : Attribute_Node_Id) return Attribute_Kind + is + begin + if Attribute = Empty_Attribute then + return Unknown; + else + return Attrs.Table (Attribute.Value).Attr_Kind; + end if; + end Attribute_Kind_Of; + + ----------------------- + -- Attribute_Name_Of -- + ----------------------- + + function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id is + begin + if Attribute = Empty_Attribute then + return No_Name; + else + return Attrs.Table (Attribute.Value).Name; + end if; + end Attribute_Name_Of; + + -------------------------- + -- Attribute_Node_Id_Of -- + -------------------------- + + function Attribute_Node_Id_Of + (Name : Name_Id; + Starting_At : Attribute_Node_Id) return Attribute_Node_Id + is + Id : Attr_Node_Id := Starting_At.Value; + + begin + while Id /= Empty_Attr + and then Attrs.Table (Id).Name /= Name + loop + Id := Attrs.Table (Id).Next; + end loop; + + return (Value => Id); + end Attribute_Node_Id_Of; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + Start : Positive := Initialization_Data'First; + Finish : Positive := Start; + Current_Package : Pkg_Node_Id := Empty_Pkg; + Current_Attribute : Attr_Node_Id := Empty_Attr; + Is_An_Attribute : Boolean := False; + Var_Kind : Variable_Kind := Undefined; + Optional_Index : Boolean := False; + Attr_Kind : Attribute_Kind := Single; + Package_Name : Name_Id := No_Name; + Attribute_Name : Name_Id := No_Name; + First_Attribute : Attr_Node_Id := Attr.First_Attribute; + Read_Only : Boolean; + Others_Allowed : Boolean; + + function Attribute_Location return String; + -- Returns a string depending if we are in the project level attributes + -- or in the attributes of a package. + + ------------------------ + -- Attribute_Location -- + ------------------------ + + function Attribute_Location return String is + begin + if Package_Name = No_Name then + return "project level attributes"; + + else + return "attribute of package """ & + Get_Name_String (Package_Name) & """"; + end if; + end Attribute_Location; + + -- Start of processing for Initialize + + begin + -- Don't allow Initialize action to be repeated + + if Initialized then + return; + end if; + + -- Make sure the two tables are empty + + Attrs.Init; + Package_Attributes.Init; + + while Initialization_Data (Start) /= '#' loop + Is_An_Attribute := True; + case Initialization_Data (Start) is + when 'P' => + + -- New allowed package + + Start := Start + 1; + + Finish := Start; + while Initialization_Data (Finish) /= '#' loop + Finish := Finish + 1; + end loop; + + Package_Name := + Name_Id_Of (Initialization_Data (Start .. Finish - 1)); + + for Index in First_Package .. Package_Attributes.Last loop + if Package_Name = Package_Attributes.Table (Index).Name then + Osint.Fail ("duplicate name """ + & Initialization_Data (Start .. Finish - 1) + & """ in predefined packages."); + end if; + end loop; + + Is_An_Attribute := False; + Current_Attribute := Empty_Attr; + Package_Attributes.Increment_Last; + Current_Package := Package_Attributes.Last; + Package_Attributes.Table (Current_Package) := + (Name => Package_Name, + Known => True, + First_Attribute => Empty_Attr); + Start := Finish + 1; + + Add_Package_Name (Get_Name_String (Package_Name)); + + when 'S' => + Var_Kind := Single; + Optional_Index := False; + + when 's' => + Var_Kind := Single; + Optional_Index := True; + + when 'L' => + Var_Kind := List; + Optional_Index := False; + + when 'l' => + Var_Kind := List; + Optional_Index := True; + + when others => + raise Program_Error; + end case; + + if Is_An_Attribute then + + -- New attribute + + Start := Start + 1; + case Initialization_Data (Start) is + when 'V' => + Attr_Kind := Single; + + when 'A' => + Attr_Kind := Associative_Array; + + when 'a' => + Attr_Kind := Case_Insensitive_Associative_Array; + + when 'b' => + if Osint.File_Names_Case_Sensitive then + Attr_Kind := Associative_Array; + else + Attr_Kind := Case_Insensitive_Associative_Array; + end if; + + when 'c' => + if Osint.File_Names_Case_Sensitive then + Attr_Kind := Optional_Index_Associative_Array; + else + Attr_Kind := + Optional_Index_Case_Insensitive_Associative_Array; + end if; + + when others => + raise Program_Error; + end case; + + Start := Start + 1; + + Read_Only := False; + Others_Allowed := False; + + if Initialization_Data (Start) = 'R' then + Read_Only := True; + Start := Start + 1; + + elsif Initialization_Data (Start) = 'O' then + Others_Allowed := True; + Start := Start + 1; + end if; + + Finish := Start; + + while Initialization_Data (Finish) /= '#' loop + Finish := Finish + 1; + end loop; + + Attribute_Name := + Name_Id_Of (Initialization_Data (Start .. Finish - 1)); + Attrs.Increment_Last; + + if Current_Attribute = Empty_Attr then + First_Attribute := Attrs.Last; + + if Current_Package /= Empty_Pkg then + Package_Attributes.Table (Current_Package).First_Attribute + := Attrs.Last; + end if; + + else + -- Check that there are no duplicate attributes + + for Index in First_Attribute .. Attrs.Last - 1 loop + if Attribute_Name = Attrs.Table (Index).Name then + Osint.Fail ("duplicate attribute """ + & Initialization_Data (Start .. Finish - 1) + & """ in " & Attribute_Location); + end if; + end loop; + + Attrs.Table (Current_Attribute).Next := + Attrs.Last; + end if; + + Current_Attribute := Attrs.Last; + Attrs.Table (Current_Attribute) := + (Name => Attribute_Name, + Var_Kind => Var_Kind, + Optional_Index => Optional_Index, + Attr_Kind => Attr_Kind, + Read_Only => Read_Only, + Others_Allowed => Others_Allowed, + Next => Empty_Attr); + Start := Finish + 1; + end if; + end loop; + + Initialized := True; + end Initialize; + + ------------------ + -- Is_Read_Only -- + ------------------ + + function Is_Read_Only (Attribute : Attribute_Node_Id) return Boolean is + begin + return Attrs.Table (Attribute.Value).Read_Only; + end Is_Read_Only; + + ---------------- + -- Name_Id_Of -- + ---------------- + + function Name_Id_Of (Name : String) return Name_Id is + begin + Name_Len := 0; + Add_Str_To_Name_Buffer (Name); + To_Lower (Name_Buffer (1 .. Name_Len)); + return Name_Find; + end Name_Id_Of; + + -------------------- + -- Next_Attribute -- + -------------------- + + function Next_Attribute + (After : Attribute_Node_Id) return Attribute_Node_Id + is + begin + if After = Empty_Attribute then + return Empty_Attribute; + else + return (Value => Attrs.Table (After.Value).Next); + end if; + end Next_Attribute; + + ----------------------- + -- Optional_Index_Of -- + ----------------------- + + function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean is + begin + if Attribute = Empty_Attribute then + return False; + else + return Attrs.Table (Attribute.Value).Optional_Index; + end if; + end Optional_Index_Of; + + function Others_Allowed_For + (Attribute : Attribute_Node_Id) return Boolean + is + begin + if Attribute = Empty_Attribute then + return False; + else + return Attrs.Table (Attribute.Value).Others_Allowed; + end if; + end Others_Allowed_For; + + ----------------------- + -- Package_Name_List -- + ----------------------- + + function Package_Name_List return Strings.String_List is + begin + return Package_Names (1 .. Last_Package_Name); + end Package_Name_List; + + ------------------------ + -- Package_Node_Id_Of -- + ------------------------ + + function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id is + begin + for Index in Package_Attributes.First .. Package_Attributes.Last loop + if Package_Attributes.Table (Index).Name = Name then + if Package_Attributes.Table (Index).Known then + return (Value => Index); + else + return Unknown_Package; + end if; + end if; + end loop; + + -- If there is no package with this name, return Empty_Package + + return Empty_Package; + end Package_Node_Id_Of; + + ---------------------------- + -- Register_New_Attribute -- + ---------------------------- + + procedure Register_New_Attribute + (Name : String; + In_Package : Package_Node_Id; + Attr_Kind : Defined_Attribute_Kind; + Var_Kind : Defined_Variable_Kind; + Index_Is_File_Name : Boolean := False; + Opt_Index : Boolean := False) + is + Attr_Name : Name_Id; + First_Attr : Attr_Node_Id := Empty_Attr; + Curr_Attr : Attr_Node_Id; + Real_Attr_Kind : Attribute_Kind; + + begin + if Name'Length = 0 then + Fail ("cannot register an attribute with no name"); + raise Project_Error; + end if; + + if In_Package = Empty_Package then + Fail ("attempt to add attribute """ + & Name + & """ to an undefined package"); + raise Project_Error; + end if; + + Attr_Name := Name_Id_Of (Name); + + First_Attr := + Package_Attributes.Table (In_Package.Value).First_Attribute; + + -- Check if attribute name is a duplicate + + Curr_Attr := First_Attr; + while Curr_Attr /= Empty_Attr loop + if Attrs.Table (Curr_Attr).Name = Attr_Name then + Fail ("duplicate attribute name """ + & Name + & """ in package """ + & Get_Name_String + (Package_Attributes.Table (In_Package.Value).Name) + & """"); + raise Project_Error; + end if; + + Curr_Attr := Attrs.Table (Curr_Attr).Next; + end loop; + + Real_Attr_Kind := Attr_Kind; + + -- If Index_Is_File_Name, change the attribute kind if necessary + + if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then + case Attr_Kind is + when Associative_Array => + Real_Attr_Kind := Case_Insensitive_Associative_Array; + + when Optional_Index_Associative_Array => + Real_Attr_Kind := + Optional_Index_Case_Insensitive_Associative_Array; + + when others => + null; + end case; + end if; + + -- Add the new attribute + + Attrs.Increment_Last; + Attrs.Table (Attrs.Last) := + (Name => Attr_Name, + Var_Kind => Var_Kind, + Optional_Index => Opt_Index, + Attr_Kind => Real_Attr_Kind, + Read_Only => False, + Others_Allowed => False, + Next => First_Attr); + + Package_Attributes.Table (In_Package.Value).First_Attribute := + Attrs.Last; + end Register_New_Attribute; + + -------------------------- + -- Register_New_Package -- + -------------------------- + + procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is + Pkg_Name : Name_Id; + + begin + if Name'Length = 0 then + Fail ("cannot register a package with no name"); + Id := Empty_Package; + return; + end if; + + Pkg_Name := Name_Id_Of (Name); + + for Index in Package_Attributes.First .. Package_Attributes.Last loop + if Package_Attributes.Table (Index).Name = Pkg_Name then + Fail ("cannot register a package with a non unique name""" + & Name + & """"); + Id := Empty_Package; + return; + end if; + end loop; + + Package_Attributes.Increment_Last; + Id := (Value => Package_Attributes.Last); + Package_Attributes.Table (Package_Attributes.Last) := + (Name => Pkg_Name, + Known => True, + First_Attribute => Empty_Attr); + + Add_Package_Name (Get_Name_String (Pkg_Name)); + end Register_New_Package; + + procedure Register_New_Package + (Name : String; + Attributes : Attribute_Data_Array) + is + Pkg_Name : Name_Id; + Attr_Name : Name_Id; + First_Attr : Attr_Node_Id := Empty_Attr; + Curr_Attr : Attr_Node_Id; + Attr_Kind : Attribute_Kind; + + begin + if Name'Length = 0 then + Fail ("cannot register a package with no name"); + raise Project_Error; + end if; + + Pkg_Name := Name_Id_Of (Name); + + for Index in Package_Attributes.First .. Package_Attributes.Last loop + if Package_Attributes.Table (Index).Name = Pkg_Name then + Fail ("cannot register a package with a non unique name""" + & Name + & """"); + raise Project_Error; + end if; + end loop; + + for Index in Attributes'Range loop + Attr_Name := Name_Id_Of (Attributes (Index).Name); + + Curr_Attr := First_Attr; + while Curr_Attr /= Empty_Attr loop + if Attrs.Table (Curr_Attr).Name = Attr_Name then + Fail ("duplicate attribute name """ + & Attributes (Index).Name + & """ in new package """ + & Name + & """"); + raise Project_Error; + end if; + + Curr_Attr := Attrs.Table (Curr_Attr).Next; + end loop; + + Attr_Kind := Attributes (Index).Attr_Kind; + + if Attributes (Index).Index_Is_File_Name + and then not Osint.File_Names_Case_Sensitive + then + case Attr_Kind is + when Associative_Array => + Attr_Kind := Case_Insensitive_Associative_Array; + + when Optional_Index_Associative_Array => + Attr_Kind := + Optional_Index_Case_Insensitive_Associative_Array; + + when others => + null; + end case; + end if; + + Attrs.Increment_Last; + Attrs.Table (Attrs.Last) := + (Name => Attr_Name, + Var_Kind => Attributes (Index).Var_Kind, + Optional_Index => Attributes (Index).Opt_Index, + Attr_Kind => Attr_Kind, + Read_Only => False, + Others_Allowed => False, + Next => First_Attr); + First_Attr := Attrs.Last; + end loop; + + Package_Attributes.Increment_Last; + Package_Attributes.Table (Package_Attributes.Last) := + (Name => Pkg_Name, + Known => True, + First_Attribute => First_Attr); + + Add_Package_Name (Get_Name_String (Pkg_Name)); + end Register_New_Package; + + --------------------------- + -- Set_Attribute_Kind_Of -- + --------------------------- + + procedure Set_Attribute_Kind_Of + (Attribute : Attribute_Node_Id; + To : Attribute_Kind) + is + begin + if Attribute /= Empty_Attribute then + Attrs.Table (Attribute.Value).Attr_Kind := To; + end if; + end Set_Attribute_Kind_Of; + + -------------------------- + -- Set_Variable_Kind_Of -- + -------------------------- + + procedure Set_Variable_Kind_Of + (Attribute : Attribute_Node_Id; + To : Variable_Kind) + is + begin + if Attribute /= Empty_Attribute then + Attrs.Table (Attribute.Value).Var_Kind := To; + end if; + end Set_Variable_Kind_Of; + + ---------------------- + -- Variable_Kind_Of -- + ---------------------- + + function Variable_Kind_Of + (Attribute : Attribute_Node_Id) return Variable_Kind + is + begin + if Attribute = Empty_Attribute then + return Undefined; + else + return Attrs.Table (Attribute.Value).Var_Kind; + end if; + end Variable_Kind_Of; + + ------------------------ + -- First_Attribute_Of -- + ------------------------ + + function First_Attribute_Of + (Pkg : Package_Node_Id) return Attribute_Node_Id + is + begin + if Pkg = Empty_Package then + return Empty_Attribute; + else + return + (Value => Package_Attributes.Table (Pkg.Value).First_Attribute); + end if; + end First_Attribute_Of; + +end Prj.Attr; diff --git a/gcc/ada/prj-attr.ads b/gcc/ada/prj-attr.ads new file mode 100644 index 000000000..a16e6f3d1 --- /dev/null +++ b/gcc/ada/prj-attr.ads @@ -0,0 +1,340 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . A T T R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package defines packages and attributes in GNAT project files. +-- There are predefined packages and attributes. + +-- It is also possible to define new packages with their attributes + +with Table; + +with GNAT.Strings; + +package Prj.Attr is + + function Package_Name_List return GNAT.Strings.String_List; + -- Returns the list of valid package names, including those added by + -- procedures Register_New_Package below. The String_Access components of + -- the returned String_List should never be freed. + + procedure Initialize; + -- Initialize the predefined project level attributes and the predefined + -- packages and their attribute. This procedure should be called by + -- Prj.Initialize. + + type Attribute_Kind is ( + Unknown, + -- The attribute does not exist + + Single, + -- Single variable attribute (not an associative array) + + Associative_Array, + -- Associative array attribute with a case sensitive index + + Optional_Index_Associative_Array, + -- Associative array attribute with a case sensitive index and an + -- optional source index. + + Case_Insensitive_Associative_Array, + -- Associative array attribute with a case insensitive index + + Optional_Index_Case_Insensitive_Associative_Array + -- Associative array attribute with a case insensitive index and an + -- optional source index. + ); + -- Characteristics of an attribute. Optional_Index indicates that there + -- may be an optional index in the index of the associative array, as in + -- for Switches ("files.ada" at 2) use ... + + subtype Defined_Attribute_Kind is Attribute_Kind + range Single .. Optional_Index_Case_Insensitive_Associative_Array; + -- Subset of Attribute_Kinds that may be used for the attributes that is + -- used when defining a new package. + + subtype All_Case_Insensitive_Associative_Array is Attribute_Kind range + Case_Insensitive_Associative_Array .. + Optional_Index_Case_Insensitive_Associative_Array; + -- Subtype including both cases of Case_Insensitive_Associative_Array + + Max_Attribute_Name_Length : constant := 64; + -- The maximum length of attribute names + + subtype Attribute_Name_Length is + Positive range 1 .. Max_Attribute_Name_Length; + + type Attribute_Data (Name_Length : Attribute_Name_Length := 1) is record + Name : String (1 .. Name_Length); + -- The name of the attribute + + Attr_Kind : Defined_Attribute_Kind; + -- The type of the attribute + + Index_Is_File_Name : Boolean; + -- For associative arrays, indicate if the index is a file name, so + -- that the attribute kind may be modified depending on the case + -- sensitivity of file names. This is only taken into account when + -- Attr_Kind is Associative_Array or Optional_Index_Associative_Array. + + Opt_Index : Boolean; + -- True if there may be an optional index in the value of the index, + -- as in: + -- "file.ada" at 2 + -- ("main.adb", "file.ada" at 1) + + Var_Kind : Defined_Variable_Kind; + -- The attribute value kind: single or list + + end record; + -- Name and characteristics of an attribute in a package registered + -- explicitly with Register_New_Package (see below). + + type Attribute_Data_Array is array (Positive range <>) of Attribute_Data; + -- A list of attribute name/characteristics to be used as parameter of + -- procedure Register_New_Package below. + + -- In the subprograms below, when it is specified that the subprogram + -- "fails", procedure Prj.Com.Fail is called. Unless it is specified + -- otherwise, if Prj.Com.Fail returns, exception Prj.Prj_Error is raised. + + procedure Register_New_Package + (Name : String; + Attributes : Attribute_Data_Array); + -- Add a new package with its attributes. This procedure can only be + -- called after Initialize, but before any other call to a service of + -- the Project Manager. Fail if the name of the package is empty or not + -- unique, or if the names of the attributes are not different. + + ---------------- + -- Attributes -- + ---------------- + + type Attribute_Node_Id is private; + -- The type to refers to an attribute, self-initialized + + Empty_Attribute : constant Attribute_Node_Id; + -- Indicates no attribute. Default value of Attribute_Node_Id objects + + Attribute_First : constant Attribute_Node_Id; + -- First attribute node id of project level attributes + + function Attribute_Node_Id_Of + (Name : Name_Id; + Starting_At : Attribute_Node_Id) return Attribute_Node_Id; + -- Returns the node id of an attribute at the project level or in + -- a package. Starting_At indicates the first known attribute node where + -- to start the search. Returns Empty_Attribute if the attribute cannot + -- be found. + + function Attribute_Kind_Of + (Attribute : Attribute_Node_Id) return Attribute_Kind; + -- Returns the attribute kind of a known attribute. Returns Unknown if + -- Attribute is Empty_Attribute. + + procedure Set_Attribute_Kind_Of + (Attribute : Attribute_Node_Id; + To : Attribute_Kind); + -- Set the attribute kind of a known attribute. Does nothing if + -- Attribute is Empty_Attribute. + + function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id; + -- Returns the name of a known attribute. Returns No_Name if Attribute is + -- Empty_Attribute. + + function Variable_Kind_Of + (Attribute : Attribute_Node_Id) return Variable_Kind; + -- Returns the variable kind of a known attribute. Returns Undefined if + -- Attribute is Empty_Attribute. + + procedure Set_Variable_Kind_Of + (Attribute : Attribute_Node_Id; + To : Variable_Kind); + -- Set the variable kind of a known attribute. Does nothing if Attribute is + -- Empty_Attribute. + + function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean; + -- Returns True if Attribute is a known attribute and may have an + -- optional index. Returns False otherwise. + + function Is_Read_Only (Attribute : Attribute_Node_Id) return Boolean; + + function Next_Attribute + (After : Attribute_Node_Id) return Attribute_Node_Id; + -- Returns the attribute that follow After in the list of project level + -- attributes or the list of attributes in a package. + -- Returns Empty_Attribute if After is either Empty_Attribute or is the + -- last of the list. + + function Others_Allowed_For (Attribute : Attribute_Node_Id) return Boolean; + -- True iff the index for an associative array attributes may be others + + -------------- + -- Packages -- + -------------- + + type Package_Node_Id is private; + -- Type to refer to a package, self initialized + + Empty_Package : constant Package_Node_Id; + -- Default value of Package_Node_Id objects + + Unknown_Package : constant Package_Node_Id; + -- Value of an unknown package that has been found but is unknown + + procedure Register_New_Package (Name : String; Id : out Package_Node_Id); + -- Add a new package. Fails if Name (the package name) is empty or is + -- already the name of a package, and set Id to Empty_Package, + -- if Prj.Com.Fail returns. Initially, the new package has no attributes. + -- Id may be used to add attributes using procedure Register_New_Attribute + -- below. + + procedure Register_New_Attribute + (Name : String; + In_Package : Package_Node_Id; + Attr_Kind : Defined_Attribute_Kind; + Var_Kind : Defined_Variable_Kind; + Index_Is_File_Name : Boolean := False; + Opt_Index : Boolean := False); + -- Add a new attribute to registered package In_Package. Fails if Name + -- (the attribute name) is empty, if In_Package is Empty_Package or if + -- the attribute name has a duplicate name. See definition of type + -- Attribute_Data above for the meaning of parameters Attr_Kind, Var_Kind, + -- Index_Is_File_Name and Opt_Index. + + function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id; + -- Returns the package node id of the package with name Name. Returns + -- Empty_Package if there is no package with this name. + + function First_Attribute_Of + (Pkg : Package_Node_Id) return Attribute_Node_Id; + -- Returns the first attribute in the list of attributes of package Pkg. + -- Returns Empty_Attribute if Pkg is Empty_Package. + +private + ---------------- + -- Attributes -- + ---------------- + + Attributes_Initial : constant := 50; + Attributes_Increment : constant := 100; + + Attribute_Node_Low_Bound : constant := 0; + Attribute_Node_High_Bound : constant := 099_999_999; + + type Attr_Node_Id is + range Attribute_Node_Low_Bound .. Attribute_Node_High_Bound; + -- Index type for table Attrs in the body + + type Attribute_Node_Id is record + Value : Attr_Node_Id := Attribute_Node_Low_Bound; + end record; + -- Full declaration of self-initialized private type + + Empty_Attr : constant Attr_Node_Id := Attribute_Node_Low_Bound; + + Empty_Attribute : constant Attribute_Node_Id := (Value => Empty_Attr); + + First_Attribute : constant Attr_Node_Id := Attribute_Node_Low_Bound + 1; + + First_Attribute_Node_Id : constant Attribute_Node_Id := + (Value => First_Attribute); + + Attribute_First : constant Attribute_Node_Id := First_Attribute_Node_Id; + + -------------- + -- Packages -- + -------------- + + Packages_Initial : constant := 10; + Packages_Increment : constant := 100; + + Package_Node_Low_Bound : constant := 0; + Package_Node_High_Bound : constant := 099_999_999; + + type Pkg_Node_Id is + range Package_Node_Low_Bound .. Package_Node_High_Bound; + -- Index type for table Package_Attributes in the body + + type Package_Node_Id is record + Value : Pkg_Node_Id := Package_Node_Low_Bound; + end record; + -- Full declaration of self-initialized private type + + Empty_Pkg : constant Pkg_Node_Id := Package_Node_Low_Bound; + Empty_Package : constant Package_Node_Id := (Value => Empty_Pkg); + Unknown_Pkg : constant Pkg_Node_Id := Package_Node_High_Bound; + Unknown_Package : constant Package_Node_Id := (Value => Unknown_Pkg); + First_Package : constant Pkg_Node_Id := Package_Node_Low_Bound + 1; + + First_Package_Node_Id : constant Package_Node_Id := + (Value => First_Package); + + Package_First : constant Package_Node_Id := First_Package_Node_Id; + + ---------------- + -- Attributes -- + ---------------- + + type Attribute_Record is record + Name : Name_Id; + Var_Kind : Variable_Kind; + Optional_Index : Boolean; + Attr_Kind : Attribute_Kind; + Read_Only : Boolean; + Others_Allowed : Boolean; + Next : Attr_Node_Id; + end record; + -- Data for an attribute + + package Attrs is + new Table.Table (Table_Component_Type => Attribute_Record, + Table_Index_Type => Attr_Node_Id, + Table_Low_Bound => First_Attribute, + Table_Initial => Attributes_Initial, + Table_Increment => Attributes_Increment, + Table_Name => "Prj.Attr.Attrs"); + -- The table of the attributes + + -------------- + -- Packages -- + -------------- + + type Package_Record is record + Name : Name_Id; + Known : Boolean := True; + First_Attribute : Attr_Node_Id; + end record; + -- Data for a package + + package Package_Attributes is + new Table.Table (Table_Component_Type => Package_Record, + Table_Index_Type => Pkg_Node_Id, + Table_Low_Bound => First_Package, + Table_Initial => Packages_Initial, + Table_Increment => Packages_Increment, + Table_Name => "Prj.Attr.Packages"); + -- The table of the packages + +end Prj.Attr; diff --git a/gcc/ada/prj-com.ads b/gcc/ada/prj-com.ads new file mode 100644 index 000000000..f5f2fa689 --- /dev/null +++ b/gcc/ada/prj-com.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . C O M -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- The following package declares a Fail procedure that is used in the +-- Project Manager. + +with Osint; + +package Prj.Com is + + type Fail_Proc is access procedure (S : String); + + Fail : Fail_Proc := Osint.Fail'Access; + -- This procedure is used in the project facility, instead of directly + -- calling Osint.Fail. It may be specified by tools to do clean up before + -- calling Osint.Fail, or to simply report an error and return. + +end Prj.Com; diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb new file mode 100644 index 000000000..921811e0d --- /dev/null +++ b/gcc/ada/prj-conf.adb @@ -0,0 +1,1394 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . C O N F -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2006-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Hostparm; +with Makeutl; use Makeutl; +with MLib.Tgt; +with Opt; use Opt; +with Output; use Output; +with Prj.Env; +with Prj.Err; +with Prj.Part; +with Prj.PP; +with Prj.Proc; use Prj.Proc; +with Prj.Tree; use Prj.Tree; +with Prj.Util; use Prj.Util; +with Prj; use Prj; +with Snames; use Snames; + +with Ada.Directories; use Ada.Directories; +with Ada.Exceptions; use Ada.Exceptions; + +with GNAT.Case_Util; use GNAT.Case_Util; +with GNAT.HTable; use GNAT.HTable; + +package body Prj.Conf is + + Auto_Cgpr : constant String := "auto.cgpr"; + + Default_Name : constant String := "default.cgpr"; + -- Default configuration file that will be used if found + + Config_Project_Env_Var : constant String := "GPR_CONFIG"; + -- Name of the environment variable that provides the name of the + -- configuration file to use. + + Gprconfig_Name : constant String := "gprconfig"; + + package RTS_Languages is new GNAT.HTable.Simple_HTable + (Header_Num => Prj.Header_Num, + Element => Name_Id, + No_Element => No_Name, + Key => Name_Id, + Hash => Prj.Hash, + Equal => "="); + -- Stores the runtime names for the various languages. This is in general + -- set from a --RTS command line option. + + ----------------------- + -- Local_Subprograms -- + ----------------------- + + procedure Add_Attributes + (Project_Tree : Project_Tree_Ref; + Conf_Decl : Declarations; + User_Decl : in out Declarations); + -- Process the attributes in the config declarations. + -- For single string values, if the attribute is not declared in the user + -- declarations, declare it with the value in the config declarations. + -- For string list values, prepend the value in the user declarations with + -- the value in the config declarations. + + function Check_Target + (Config_File : Prj.Project_Id; + Autoconf_Specified : Boolean; + Project_Tree : Prj.Project_Tree_Ref; + Target : String := "") return Boolean; + -- Check that the config file's target matches Target. + -- Target should be set to the empty string when the user did not specify + -- a target. If the target in the configuration file is invalid, this + -- function will raise Invalid_Config with an appropriate message. + -- Autoconf_Specified should be set to True if the user has used + -- autoconf. + + function Locate_Config_File (Name : String) return String_Access; + -- Search for Name in the config files directory. Return full path if + -- found, or null otherwise. + + procedure Raise_Invalid_Config (Msg : String); + pragma No_Return (Raise_Invalid_Config); + -- Raises exception Invalid_Config with given message + + -------------------- + -- Add_Attributes -- + -------------------- + + procedure Add_Attributes + (Project_Tree : Project_Tree_Ref; + Conf_Decl : Declarations; + User_Decl : in out Declarations) + is + Conf_Attr_Id : Variable_Id; + Conf_Attr : Variable; + Conf_Array_Id : Array_Id; + Conf_Array : Array_Data; + Conf_Array_Elem_Id : Array_Element_Id; + Conf_Array_Elem : Array_Element; + Conf_List : String_List_Id; + Conf_List_Elem : String_Element; + + User_Attr_Id : Variable_Id; + User_Attr : Variable; + User_Array_Id : Array_Id; + User_Array : Array_Data; + User_Array_Elem_Id : Array_Element_Id; + User_Array_Elem : Array_Element; + + begin + Conf_Attr_Id := Conf_Decl.Attributes; + User_Attr_Id := User_Decl.Attributes; + while Conf_Attr_Id /= No_Variable loop + Conf_Attr := + Project_Tree.Variable_Elements.Table (Conf_Attr_Id); + User_Attr := + Project_Tree.Variable_Elements.Table (User_Attr_Id); + + if not Conf_Attr.Value.Default then + if User_Attr.Value.Default then + + -- No attribute declared in user project file: just copy the + -- value of the configuration attribute. + + User_Attr.Value := Conf_Attr.Value; + Project_Tree.Variable_Elements.Table (User_Attr_Id) := + User_Attr; + + elsif User_Attr.Value.Kind = List + and then Conf_Attr.Value.Values /= Nil_String + then + -- List attribute declared in both the user project and the + -- configuration project: prepend the user list with the + -- configuration list. + + declare + Conf_List : String_List_Id := Conf_Attr.Value.Values; + Conf_Elem : String_Element; + User_List : constant String_List_Id := + User_Attr.Value.Values; + New_List : String_List_Id; + New_Elem : String_Element; + + begin + -- Create new list + + String_Element_Table.Increment_Last + (Project_Tree.String_Elements); + New_List := String_Element_Table.Last + (Project_Tree.String_Elements); + + -- Value of attribute is new list + + User_Attr.Value.Values := New_List; + Project_Tree.Variable_Elements.Table (User_Attr_Id) := + User_Attr; + + loop + + -- Get each element of configuration list + + Conf_Elem := + Project_Tree.String_Elements.Table (Conf_List); + New_Elem := Conf_Elem; + Conf_List := Conf_Elem.Next; + + if Conf_List = Nil_String then + + -- If it is the last element in the list, connect to + -- first element of user list, and we are done. + + New_Elem.Next := User_List; + Project_Tree.String_Elements.Table + (New_List) := New_Elem; + exit; + + else + -- If it is not the last element in the list, add to + -- new list. + + String_Element_Table.Increment_Last + (Project_Tree.String_Elements); + New_Elem.Next := + String_Element_Table.Last + (Project_Tree.String_Elements); + Project_Tree.String_Elements.Table + (New_List) := New_Elem; + New_List := New_Elem.Next; + end if; + end loop; + end; + end if; + end if; + + Conf_Attr_Id := Conf_Attr.Next; + User_Attr_Id := User_Attr.Next; + end loop; + + Conf_Array_Id := Conf_Decl.Arrays; + while Conf_Array_Id /= No_Array loop + Conf_Array := Project_Tree.Arrays.Table (Conf_Array_Id); + + User_Array_Id := User_Decl.Arrays; + while User_Array_Id /= No_Array loop + User_Array := Project_Tree.Arrays.Table (User_Array_Id); + exit when User_Array.Name = Conf_Array.Name; + User_Array_Id := User_Array.Next; + end loop; + + -- If this associative array does not exist in the user project file, + -- do a shallow copy of the full associative array. + + if User_Array_Id = No_Array then + Array_Table.Increment_Last (Project_Tree.Arrays); + User_Array := Conf_Array; + User_Array.Next := User_Decl.Arrays; + User_Decl.Arrays := Array_Table.Last (Project_Tree.Arrays); + Project_Tree.Arrays.Table (User_Decl.Arrays) := User_Array; + + else + -- Otherwise, check each array element + + Conf_Array_Elem_Id := Conf_Array.Value; + while Conf_Array_Elem_Id /= No_Array_Element loop + Conf_Array_Elem := + Project_Tree.Array_Elements.Table (Conf_Array_Elem_Id); + + User_Array_Elem_Id := User_Array.Value; + while User_Array_Elem_Id /= No_Array_Element loop + User_Array_Elem := + Project_Tree.Array_Elements.Table (User_Array_Elem_Id); + exit when User_Array_Elem.Index = Conf_Array_Elem.Index; + User_Array_Elem_Id := User_Array_Elem.Next; + end loop; + + -- If the array element does not exist in the user array, + -- insert a shallow copy of the conf array element in the + -- user array. + + if User_Array_Elem_Id = No_Array_Element then + Array_Element_Table.Increment_Last + (Project_Tree.Array_Elements); + User_Array_Elem := Conf_Array_Elem; + User_Array_Elem.Next := User_Array.Value; + User_Array.Value := + Array_Element_Table.Last (Project_Tree.Array_Elements); + Project_Tree.Array_Elements.Table (User_Array.Value) := + User_Array_Elem; + Project_Tree.Arrays.Table (User_Array_Id) := User_Array; + + -- Otherwise, if the value is a string list, prepend the + -- user array element with the conf array element value. + + elsif Conf_Array_Elem.Value.Kind = List then + Conf_List := Conf_Array_Elem.Value.Values; + + if Conf_List /= Nil_String then + declare + Link : constant String_List_Id := + User_Array_Elem.Value.Values; + Previous : String_List_Id := Nil_String; + Next : String_List_Id; + + begin + loop + Conf_List_Elem := + Project_Tree.String_Elements.Table + (Conf_List); + String_Element_Table.Increment_Last + (Project_Tree.String_Elements); + Next := + String_Element_Table.Last + (Project_Tree.String_Elements); + Project_Tree.String_Elements.Table (Next) := + Conf_List_Elem; + + if Previous = Nil_String then + User_Array_Elem.Value.Values := Next; + Project_Tree.Array_Elements.Table + (User_Array_Elem_Id) := User_Array_Elem; + + else + Project_Tree.String_Elements.Table + (Previous).Next := Next; + end if; + + Previous := Next; + + Conf_List := Conf_List_Elem.Next; + + if Conf_List = Nil_String then + Project_Tree.String_Elements.Table + (Previous).Next := Link; + exit; + end if; + end loop; + end; + end if; + end if; + + Conf_Array_Elem_Id := Conf_Array_Elem.Next; + end loop; + end if; + + Conf_Array_Id := Conf_Array.Next; + end loop; + end Add_Attributes; + + ------------------------------------ + -- Add_Default_GNAT_Naming_Scheme -- + ------------------------------------ + + procedure Add_Default_GNAT_Naming_Scheme + (Config_File : in out Project_Node_Id; + Project_Tree : Project_Node_Tree_Ref) + is + procedure Create_Attribute + (Name : Name_Id; + Value : String; + Index : String := ""; + Pkg : Project_Node_Id := Empty_Node); + + ---------------------- + -- Create_Attribute -- + ---------------------- + + procedure Create_Attribute + (Name : Name_Id; + Value : String; + Index : String := ""; + Pkg : Project_Node_Id := Empty_Node) + is + Attr : Project_Node_Id; + pragma Unreferenced (Attr); + + Expr : Name_Id := No_Name; + Val : Name_Id := No_Name; + Parent : Project_Node_Id := Config_File; + begin + if Index /= "" then + Name_Len := Index'Length; + Name_Buffer (1 .. Name_Len) := Index; + Val := Name_Find; + end if; + + if Pkg /= Empty_Node then + Parent := Pkg; + end if; + + Name_Len := Value'Length; + Name_Buffer (1 .. Name_Len) := Value; + Expr := Name_Find; + + Attr := Create_Attribute + (Tree => Project_Tree, + Prj_Or_Pkg => Parent, + Name => Name, + Index_Name => Val, + Kind => Prj.Single, + Value => Create_Literal_String (Expr, Project_Tree)); + end Create_Attribute; + + -- Local variables + + Name : Name_Id; + Naming : Project_Node_Id; + + -- Start of processing for Add_Default_GNAT_Naming_Scheme + + begin + if Config_File = Empty_Node then + + -- Create a dummy config file is none was found + + Name_Len := Auto_Cgpr'Length; + Name_Buffer (1 .. Name_Len) := Auto_Cgpr; + Name := Name_Find; + + -- An invalid project name to avoid conflicts with user-created ones + + Name_Len := 5; + Name_Buffer (1 .. Name_Len) := "_auto"; + + Config_File := + Create_Project + (In_Tree => Project_Tree, + Name => Name_Find, + Full_Path => Path_Name_Type (Name), + Is_Config_File => True); + + -- Setup library support + + case MLib.Tgt.Support_For_Libraries is + when None => + null; + + when Static_Only => + Create_Attribute (Name_Library_Support, "static_only"); + + when Full => + Create_Attribute (Name_Library_Support, "full"); + end case; + + if MLib.Tgt.Standalone_Library_Auto_Init_Is_Supported then + Create_Attribute (Name_Library_Auto_Init_Supported, "true"); + else + Create_Attribute (Name_Library_Auto_Init_Supported, "false"); + end if; + + -- Setup Ada support (Ada is the default language here, since this + -- is only called when no config file existed initially, ie for + -- gnatmake). + + Create_Attribute (Name_Default_Language, "ada"); + + Naming := Create_Package (Project_Tree, Config_File, "naming"); + Create_Attribute (Name_Spec_Suffix, ".ads", "ada", Pkg => Naming); + Create_Attribute (Name_Separate_Suffix, ".adb", "ada", Pkg => Naming); + Create_Attribute (Name_Body_Suffix, ".adb", "ada", Pkg => Naming); + Create_Attribute (Name_Dot_Replacement, "-", Pkg => Naming); + Create_Attribute (Name_Casing, "lowercase", Pkg => Naming); + + if Current_Verbosity = High then + Write_Line ("Automatically generated (in-memory) config file"); + Prj.PP.Pretty_Print + (Project => Config_File, + In_Tree => Project_Tree, + Backward_Compatibility => False); + end if; + end if; + end Add_Default_GNAT_Naming_Scheme; + + ----------------------- + -- Apply_Config_File -- + ----------------------- + + procedure Apply_Config_File + (Config_File : Prj.Project_Id; + Project_Tree : Prj.Project_Tree_Ref) + is + Conf_Decl : constant Declarations := Config_File.Decl; + Conf_Pack_Id : Package_Id; + Conf_Pack : Package_Element; + + User_Decl : Declarations; + User_Pack_Id : Package_Id; + User_Pack : Package_Element; + Proj : Project_List; + + begin + Proj := Project_Tree.Projects; + while Proj /= null loop + if Proj.Project /= Config_File then + User_Decl := Proj.Project.Decl; + Add_Attributes + (Project_Tree => Project_Tree, + Conf_Decl => Conf_Decl, + User_Decl => User_Decl); + + Conf_Pack_Id := Conf_Decl.Packages; + while Conf_Pack_Id /= No_Package loop + Conf_Pack := Project_Tree.Packages.Table (Conf_Pack_Id); + + User_Pack_Id := User_Decl.Packages; + while User_Pack_Id /= No_Package loop + User_Pack := Project_Tree.Packages.Table (User_Pack_Id); + exit when User_Pack.Name = Conf_Pack.Name; + User_Pack_Id := User_Pack.Next; + end loop; + + if User_Pack_Id = No_Package then + Package_Table.Increment_Last (Project_Tree.Packages); + User_Pack := Conf_Pack; + User_Pack.Next := User_Decl.Packages; + User_Decl.Packages := + Package_Table.Last (Project_Tree.Packages); + Project_Tree.Packages.Table (User_Decl.Packages) := + User_Pack; + + else + Add_Attributes + (Project_Tree => Project_Tree, + Conf_Decl => Conf_Pack.Decl, + User_Decl => Project_Tree.Packages.Table + (User_Pack_Id).Decl); + end if; + + Conf_Pack_Id := Conf_Pack.Next; + end loop; + + Proj.Project.Decl := User_Decl; + end if; + + Proj := Proj.Next; + end loop; + end Apply_Config_File; + + ------------------ + -- Check_Target -- + ------------------ + + function Check_Target + (Config_File : Project_Id; + Autoconf_Specified : Boolean; + Project_Tree : Prj.Project_Tree_Ref; + Target : String := "") return Boolean + is + Variable : constant Variable_Value := + Value_Of + (Name_Target, Config_File.Decl.Attributes, Project_Tree); + Tgt_Name : Name_Id := No_Name; + OK : Boolean; + + begin + if Variable /= Nil_Variable_Value and then not Variable.Default then + Tgt_Name := Variable.Value; + end if; + + if Target = "" then + OK := not Autoconf_Specified or else Tgt_Name = No_Name; + else + OK := Tgt_Name /= No_Name + and then Target = Get_Name_String (Tgt_Name); + end if; + + if not OK then + if Autoconf_Specified then + if Verbose_Mode then + Write_Line ("inconsistent targets, performing autoconf"); + end if; + + return False; + + else + if Tgt_Name /= No_Name then + Raise_Invalid_Config + ("invalid target name """ + & Get_Name_String (Tgt_Name) & """ in configuration"); + else + Raise_Invalid_Config + ("no target specified in configuration file"); + end if; + end if; + end if; + + return True; + end Check_Target; + + -------------------------------------- + -- Get_Or_Create_Configuration_File -- + -------------------------------------- + + procedure Get_Or_Create_Configuration_File + (Project : Project_Id; + Project_Tree : Project_Tree_Ref; + Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref; + Allow_Automatic_Generation : Boolean; + Config_File_Name : String := ""; + Autoconf_Specified : Boolean; + Target_Name : String := ""; + Normalized_Hostname : String; + Packages_To_Check : String_List_Access := null; + Config : out Prj.Project_Id; + Config_File_Path : out String_Access; + Automatically_Generated : out Boolean; + Flags : Processing_Flags; + On_Load_Config : Config_File_Hook := null) + is + + At_Least_One_Compiler_Command : Boolean := False; + -- Set to True if at least one attribute Ide'Compiler_Command is + -- specified for one language of the system. + + function Default_File_Name return String; + -- Return the name of the default config file that should be tested + + procedure Do_Autoconf; + -- Generate a new config file through gprconfig. In case of error, this + -- raises the Invalid_Config exception with an appropriate message + + function Get_Config_Switches return Argument_List_Access; + -- Return the --config switches to use for gprconfig + + function Might_Have_Sources (Project : Project_Id) return Boolean; + -- True if the specified project might have sources (ie the user has not + -- explicitly specified it. We haven't checked the file system, nor do + -- we need to at this stage. + + ----------------------- + -- Default_File_Name -- + ----------------------- + + function Default_File_Name return String is + Ada_RTS : constant String := Runtime_Name_For (Name_Ada); + Tmp : String_Access; + + begin + if Target_Name /= "" then + if Ada_RTS /= "" then + return Target_Name & '-' & Ada_RTS + & Config_Project_File_Extension; + else + return Target_Name & Config_Project_File_Extension; + end if; + + elsif Ada_RTS /= "" then + return Ada_RTS & Config_Project_File_Extension; + + else + Tmp := Getenv (Config_Project_Env_Var); + + declare + T : constant String := Tmp.all; + + begin + Free (Tmp); + + if T'Length = 0 then + return Default_Name; + else + return T; + end if; + end; + end if; + end Default_File_Name; + + ------------------------ + -- Might_Have_Sources -- + ------------------------ + + function Might_Have_Sources (Project : Project_Id) return Boolean is + Variable : Variable_Value; + + begin + Variable := + Value_Of + (Name_Source_Dirs, + Project.Decl.Attributes, + Project_Tree); + + if Variable = Nil_Variable_Value + or else Variable.Default + or else Variable.Values /= Nil_String + then + Variable := + Value_Of + (Name_Source_Files, + Project.Decl.Attributes, + Project_Tree); + return Variable = Nil_Variable_Value + or else Variable.Default + or else Variable.Values /= Nil_String; + + else + return False; + end if; + end Might_Have_Sources; + + ------------------------- + -- Get_Config_Switches -- + ------------------------- + + function Get_Config_Switches return Argument_List_Access is + package Language_Htable is new GNAT.HTable.Simple_HTable + (Header_Num => Prj.Header_Num, + Element => Name_Id, + No_Element => No_Name, + Key => Name_Id, + Hash => Prj.Hash, + Equal => "="); + -- Hash table to keep the languages used in the project tree + + IDE : constant Package_Id := + Value_Of + (Name_Ide, + Project.Decl.Packages, + Project_Tree); + + Prj_Iter : Project_List; + List : String_List_Id; + Elem : String_Element; + Lang : Name_Id; + Variable : Variable_Value; + Name : Name_Id; + Count : Natural; + Result : Argument_List_Access; + + Check_Default : Boolean; + + begin + Prj_Iter := Project_Tree.Projects; + while Prj_Iter /= null loop + if Might_Have_Sources (Prj_Iter.Project) then + Variable := + Value_Of + (Name_Languages, + Prj_Iter.Project.Decl.Attributes, + Project_Tree); + + if Variable = Nil_Variable_Value + or else Variable.Default + then + -- Languages is not declared. If it is not an extending + -- project, or if it extends a project with no Languages, + -- check for Default_Language. + + Check_Default := Prj_Iter.Project.Extends = No_Project; + + if not Check_Default then + Variable := + Value_Of + (Name_Languages, + Prj_Iter.Project.Extends.Decl.Attributes, + Project_Tree); + Check_Default := + Variable /= Nil_Variable_Value + and then Variable.Values = Nil_String; + end if; + + if Check_Default then + Variable := + Value_Of + (Name_Default_Language, + Prj_Iter.Project.Decl.Attributes, + Project_Tree); + + if Variable /= Nil_Variable_Value + and then not Variable.Default + then + Get_Name_String (Variable.Value); + To_Lower (Name_Buffer (1 .. Name_Len)); + Lang := Name_Find; + Language_Htable.Set (Lang, Lang); + + else + -- If no default language is declared, default to Ada + + Language_Htable.Set (Name_Ada, Name_Ada); + end if; + end if; + + elsif Variable.Values /= Nil_String then + + -- Attribute Languages is declared with a non empty + -- list: put all the languages in Language_HTable. + + List := Variable.Values; + while List /= Nil_String loop + Elem := Project_Tree.String_Elements.Table (List); + + Get_Name_String (Elem.Value); + To_Lower (Name_Buffer (1 .. Name_Len)); + Lang := Name_Find; + Language_Htable.Set (Lang, Lang); + + List := Elem.Next; + end loop; + end if; + end if; + + Prj_Iter := Prj_Iter.Next; + end loop; + + Name := Language_Htable.Get_First; + Count := 0; + while Name /= No_Name loop + Count := Count + 1; + Name := Language_Htable.Get_Next; + end loop; + + Result := new String_List (1 .. Count); + + Count := 1; + Name := Language_Htable.Get_First; + while Name /= No_Name loop + -- Check if IDE'Compiler_Command is declared for the language. + -- If it is, use its value to invoke gprconfig. + + Variable := + Value_Of + (Name, + Attribute_Or_Array_Name => Name_Compiler_Command, + In_Package => IDE, + In_Tree => Project_Tree, + Force_Lower_Case_Index => True); + + declare + Config_Command : constant String := + "--config=" & Get_Name_String (Name); + + Runtime_Name : constant String := + Runtime_Name_For (Name); + + begin + if Variable = Nil_Variable_Value + or else Length_Of_Name (Variable.Value) = 0 + then + Result (Count) := + new String'(Config_Command & ",," & Runtime_Name); + + else + At_Least_One_Compiler_Command := True; + + declare + Compiler_Command : constant String := + Get_Name_String (Variable.Value); + + begin + if Is_Absolute_Path (Compiler_Command) then + Result (Count) := + new String' + (Config_Command & ",," & Runtime_Name & "," & + Containing_Directory (Compiler_Command) & "," & + Simple_Name (Compiler_Command)); + else + Result (Count) := + new String' + (Config_Command & ",," & Runtime_Name & ",," & + Compiler_Command); + end if; + end; + end if; + end; + + Count := Count + 1; + Name := Language_Htable.Get_Next; + end loop; + + return Result; + end Get_Config_Switches; + + ----------------- + -- Do_Autoconf -- + ----------------- + + procedure Do_Autoconf is + Obj_Dir : constant Variable_Value := + Value_Of + (Name_Object_Dir, + Project.Decl.Attributes, + Project_Tree); + + Gprconfig_Path : String_Access; + Success : Boolean; + + begin + Gprconfig_Path := Locate_Exec_On_Path (Gprconfig_Name); + + if Gprconfig_Path = null then + Raise_Invalid_Config + ("could not locate gprconfig for auto-configuration"); + end if; + + -- First, find the object directory of the user's project + + if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then + Get_Name_String (Project.Directory.Display_Name); + + else + if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then + Get_Name_String (Obj_Dir.Value); + + else + Name_Len := 0; + Add_Str_To_Name_Buffer + (Get_Name_String (Project.Directory.Display_Name)); + Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value)); + end if; + end if; + + if Subdirs /= null then + Add_Char_To_Name_Buffer (Directory_Separator); + Add_Str_To_Name_Buffer (Subdirs.all); + end if; + + for J in 1 .. Name_Len loop + if Name_Buffer (J) = '/' then + Name_Buffer (J) := Directory_Separator; + end if; + end loop; + + declare + Obj_Dir : constant String := Name_Buffer (1 .. Name_Len); + Switches : Argument_List_Access := Get_Config_Switches; + Args : Argument_List (1 .. 5); + Arg_Last : Positive; + + Obj_Dir_Exists : Boolean := True; + + begin + -- Check if the object directory exists. If Setup_Projects is True + -- (-p) and directory does not exist, attempt to create it. + -- Otherwise, if directory does not exist, fail without calling + -- gprconfig. + + if not Is_Directory (Obj_Dir) + and then (Setup_Projects or else Subdirs /= null) + then + begin + Create_Path (Obj_Dir); + + if not Quiet_Output then + Write_Str ("object directory """); + Write_Str (Obj_Dir); + Write_Line (""" created"); + end if; + + exception + when others => + Raise_Invalid_Config + ("could not create object directory " & Obj_Dir); + end; + end if; + + if not Is_Directory (Obj_Dir) then + case Flags.Require_Obj_Dirs is + when Error => + Raise_Invalid_Config + ("object directory " & Obj_Dir & " does not exist"); + when Warning => + Prj.Err.Error_Msg + (Flags, + "?object directory " & Obj_Dir & " does not exist"); + Obj_Dir_Exists := False; + when Silent => + null; + end case; + end if; + + -- Invoke gprconfig + + Args (1) := new String'("--batch"); + Args (2) := new String'("-o"); + + -- If no config file was specified, set the auto.cgpr one + + if Config_File_Name = "" then + if Obj_Dir_Exists then + Args (3) := + new String'(Obj_Dir & Directory_Separator & Auto_Cgpr); + + else + declare + Path_FD : File_Descriptor; + Path_Name : Path_Name_Type; + + begin + Prj.Env.Create_Temp_File + (In_Tree => Project_Tree, + Path_FD => Path_FD, + Path_Name => Path_Name, + File_Use => "configuration file"); + + if Path_FD /= Invalid_FD then + Args (3) := new String'(Get_Name_String (Path_Name)); + GNAT.OS_Lib.Close (Path_FD); + + else + -- We'll have an error message later on + + Args (3) := + new String' + (Obj_Dir & Directory_Separator & Auto_Cgpr); + end if; + end; + end if; + else + Args (3) := new String'(Config_File_Name); + end if; + + if Normalized_Hostname = "" then + Arg_Last := 3; + else + if Target_Name = "" then + if At_Least_One_Compiler_Command then + Args (4) := new String'("--target=all"); + + else + Args (4) := + new String'("--target=" & Normalized_Hostname); + end if; + + else + Args (4) := new String'("--target=" & Target_Name); + end if; + + Arg_Last := 4; + end if; + + if not Verbose_Mode then + Arg_Last := Arg_Last + 1; + Args (Arg_Last) := new String'("-q"); + end if; + + if Verbose_Mode then + Write_Str (Gprconfig_Name); + + for J in 1 .. Arg_Last loop + Write_Char (' '); + Write_Str (Args (J).all); + end loop; + + for J in Switches'Range loop + Write_Char (' '); + Write_Str (Switches (J).all); + end loop; + + Write_Eol; + + elsif not Quiet_Output then + -- Display no message if we are creating auto.cgpr, unless in + -- verbose mode + + if Config_File_Name /= "" + or else Verbose_Mode + then + Write_Str ("creating "); + Write_Str (Simple_Name (Args (3).all)); + Write_Eol; + end if; + end if; + + Spawn (Gprconfig_Path.all, Args (1 .. Arg_Last) & Switches.all, + Success); + + Free (Switches); + + Config_File_Path := Locate_Config_File (Args (3).all); + + if Config_File_Path = null then + Raise_Invalid_Config + ("could not create " & Args (3).all); + end if; + + for F in Args'Range loop + Free (Args (F)); + end loop; + end; + end Do_Autoconf; + + Success : Boolean; + Config_Project_Node : Project_Node_Id := Empty_Node; + + begin + Free (Config_File_Path); + Config := No_Project; + + if Config_File_Name /= "" then + Config_File_Path := Locate_Config_File (Config_File_Name); + else + Config_File_Path := Locate_Config_File (Default_File_Name); + end if; + + if Config_File_Path = null then + if (not Allow_Automatic_Generation) and then + Config_File_Name /= "" + then + Raise_Invalid_Config + ("could not locate main configuration project " + & Config_File_Name); + end if; + end if; + + Automatically_Generated := + Allow_Automatic_Generation and then Config_File_Path = null; + + <> + + if Automatically_Generated then + if Hostparm.OpenVMS then + + -- There is no gprconfig on VMS + + Raise_Invalid_Config + ("could not locate any configuration project file"); + + else + -- This might raise an Invalid_Config exception + + Do_Autoconf; + end if; + end if; + + -- Parse the configuration file + + if Verbose_Mode and then Config_File_Path /= null then + Write_Str ("Checking configuration "); + Write_Line (Config_File_Path.all); + end if; + + if Config_File_Path /= null then + Prj.Part.Parse + (In_Tree => Project_Node_Tree, + Project => Config_Project_Node, + Project_File_Name => Config_File_Path.all, + Always_Errout_Finalize => False, + Packages_To_Check => Packages_To_Check, + Current_Directory => Current_Directory, + Is_Config_File => True, + Flags => Flags); + else + -- Maybe the user will want to create his own configuration file + Config_Project_Node := Empty_Node; + end if; + + if On_Load_Config /= null then + On_Load_Config + (Config_File => Config_Project_Node, + Project_Node_Tree => Project_Node_Tree); + end if; + + if Config_Project_Node /= Empty_Node then + Prj.Proc.Process_Project_Tree_Phase_1 + (In_Tree => Project_Tree, + Project => Config, + Success => Success, + From_Project_Node => Config_Project_Node, + From_Project_Node_Tree => Project_Node_Tree, + Flags => Flags, + Reset_Tree => False); + end if; + + if Config_Project_Node = Empty_Node + or else Config = No_Project + then + Raise_Invalid_Config + ("processing of configuration project """ + & Config_File_Path.all & """ failed"); + end if; + + -- Check that the target of the configuration file is the one the user + -- specified on the command line. We do not need to check that when in + -- auto-conf mode, since the appropriate target was passed to gprconfig. + + if not Automatically_Generated + and then not + Check_Target (Config, Autoconf_Specified, Project_Tree, Target_Name) + then + Automatically_Generated := True; + goto Process_Config_File; + end if; + end Get_Or_Create_Configuration_File; + + ------------------------ + -- Locate_Config_File -- + ------------------------ + + function Locate_Config_File (Name : String) return String_Access is + Prefix_Path : constant String := Executable_Prefix_Path; + begin + if Prefix_Path'Length /= 0 then + return Locate_Regular_File + (Name, + "." & Path_Separator & + Prefix_Path & "share" & Directory_Separator & "gpr"); + else + return Locate_Regular_File (Name, "."); + end if; + end Locate_Config_File; + + ------------------------------------ + -- Parse_Project_And_Apply_Config -- + ------------------------------------ + + procedure Parse_Project_And_Apply_Config + (Main_Project : out Prj.Project_Id; + User_Project_Node : out Prj.Tree.Project_Node_Id; + Config_File_Name : String := ""; + Autoconf_Specified : Boolean; + Project_File_Name : String; + Project_Tree : Prj.Project_Tree_Ref; + Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref; + Packages_To_Check : String_List_Access; + Allow_Automatic_Generation : Boolean := True; + Automatically_Generated : out Boolean; + Config_File_Path : out String_Access; + Target_Name : String := ""; + Normalized_Hostname : String; + Flags : Processing_Flags; + On_Load_Config : Config_File_Hook := null) + is + begin + -- Parse the user project tree + + Prj.Initialize (Project_Tree); + + Main_Project := No_Project; + Automatically_Generated := False; + + Prj.Part.Parse + (In_Tree => Project_Node_Tree, + Project => User_Project_Node, + Project_File_Name => Project_File_Name, + Always_Errout_Finalize => False, + Packages_To_Check => Packages_To_Check, + Current_Directory => Current_Directory, + Is_Config_File => False, + Flags => Flags); + + if User_Project_Node = Empty_Node then + User_Project_Node := Empty_Node; + return; + end if; + + Process_Project_And_Apply_Config + (Main_Project => Main_Project, + User_Project_Node => User_Project_Node, + Config_File_Name => Config_File_Name, + Autoconf_Specified => Autoconf_Specified, + Project_Tree => Project_Tree, + Project_Node_Tree => Project_Node_Tree, + Packages_To_Check => Packages_To_Check, + Allow_Automatic_Generation => Allow_Automatic_Generation, + Automatically_Generated => Automatically_Generated, + Config_File_Path => Config_File_Path, + Target_Name => Target_Name, + Normalized_Hostname => Normalized_Hostname, + Flags => Flags, + On_Load_Config => On_Load_Config); + end Parse_Project_And_Apply_Config; + + -------------------------------------- + -- Process_Project_And_Apply_Config -- + -------------------------------------- + + procedure Process_Project_And_Apply_Config + (Main_Project : out Prj.Project_Id; + User_Project_Node : Prj.Tree.Project_Node_Id; + Config_File_Name : String := ""; + Autoconf_Specified : Boolean; + Project_Tree : Prj.Project_Tree_Ref; + Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref; + Packages_To_Check : String_List_Access; + Allow_Automatic_Generation : Boolean := True; + Automatically_Generated : out Boolean; + Config_File_Path : out String_Access; + Target_Name : String := ""; + Normalized_Hostname : String; + Flags : Processing_Flags; + On_Load_Config : Config_File_Hook := null; + Reset_Tree : Boolean := True) + is + Main_Config_Project : Project_Id; + Success : Boolean; + + begin + Main_Project := No_Project; + Automatically_Generated := False; + + Process_Project_Tree_Phase_1 + (In_Tree => Project_Tree, + Project => Main_Project, + Success => Success, + From_Project_Node => User_Project_Node, + From_Project_Node_Tree => Project_Node_Tree, + Flags => Flags, + Reset_Tree => Reset_Tree); + + if not Success then + Main_Project := No_Project; + return; + end if; + + if Project_Tree.Source_Info_File_Name /= null then + if not Is_Absolute_Path (Project_Tree.Source_Info_File_Name.all) then + declare + Obj_Dir : constant Variable_Value := + Value_Of + (Name_Object_Dir, + Main_Project.Decl.Attributes, + Project_Tree); + + begin + if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then + Get_Name_String (Main_Project.Directory.Display_Name); + + else + if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then + Get_Name_String (Obj_Dir.Value); + + else + Name_Len := 0; + Add_Str_To_Name_Buffer + (Get_Name_String (Main_Project.Directory.Display_Name)); + Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value)); + end if; + end if; + + Add_Char_To_Name_Buffer (Directory_Separator); + Add_Str_To_Name_Buffer (Project_Tree.Source_Info_File_Name.all); + Free (Project_Tree.Source_Info_File_Name); + Project_Tree.Source_Info_File_Name := + new String'(Name_Buffer (1 .. Name_Len)); + end; + end if; + + Read_Source_Info_File (Project_Tree); + end if; + + -- Find configuration file + + Get_Or_Create_Configuration_File + (Config => Main_Config_Project, + Project => Main_Project, + Project_Tree => Project_Tree, + Project_Node_Tree => Project_Node_Tree, + Allow_Automatic_Generation => Allow_Automatic_Generation, + Config_File_Name => Config_File_Name, + Autoconf_Specified => Autoconf_Specified, + Target_Name => Target_Name, + Normalized_Hostname => Normalized_Hostname, + Packages_To_Check => Packages_To_Check, + Config_File_Path => Config_File_Path, + Automatically_Generated => Automatically_Generated, + Flags => Flags, + On_Load_Config => On_Load_Config); + + Apply_Config_File (Main_Config_Project, Project_Tree); + + -- Finish processing the user's project + + Prj.Proc.Process_Project_Tree_Phase_2 + (In_Tree => Project_Tree, + Project => Main_Project, + Success => Success, + From_Project_Node => User_Project_Node, + From_Project_Node_Tree => Project_Node_Tree, + Flags => Flags); + + if Success then + if Project_Tree.Source_Info_File_Name /= null and then + not Project_Tree.Source_Info_File_Exists + then + Write_Source_Info_File (Project_Tree); + end if; + + else + Main_Project := No_Project; + end if; + end Process_Project_And_Apply_Config; + + -------------------------- + -- Raise_Invalid_Config -- + -------------------------- + + procedure Raise_Invalid_Config (Msg : String) is + begin + Raise_Exception (Invalid_Config'Identity, Msg); + end Raise_Invalid_Config; + + ---------------------- + -- Runtime_Name_For -- + ---------------------- + + function Runtime_Name_For (Language : Name_Id) return String is + begin + if RTS_Languages.Get (Language) /= No_Name then + return Get_Name_String (RTS_Languages.Get (Language)); + else + return ""; + end if; + end Runtime_Name_For; + + --------------------- + -- Set_Runtime_For -- + --------------------- + + procedure Set_Runtime_For (Language : Name_Id; RTS_Name : String) is + begin + Name_Len := RTS_Name'Length; + Name_Buffer (1 .. Name_Len) := RTS_Name; + RTS_Languages.Set (Language, Name_Find); + end Set_Runtime_For; + +end Prj.Conf; diff --git a/gcc/ada/prj-conf.ads b/gcc/ada/prj-conf.ads new file mode 100644 index 000000000..199e3e809 --- /dev/null +++ b/gcc/ada/prj-conf.ads @@ -0,0 +1,200 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . C O N F -- +-- -- +-- S p e c -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- The following package manipulates the configuration files + +with Prj.Tree; + +package Prj.Conf is + + type Config_File_Hook is access procedure + (Config_File : in out Prj.Tree.Project_Node_Id; + Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref); + -- Hook called after the config file has been parsed. This lets the + -- application do last minute changes to it (GPS uses this to add the + -- default naming schemes for instance). At that point, the config file + -- has not been applied to the project yet. When no config file was found, + -- and automatic generation is disabled, it is possible that Config_File + -- is set to Empty_Node when this procedure is called. You can then decide + -- to create a new config file if you need. + + procedure Parse_Project_And_Apply_Config + (Main_Project : out Prj.Project_Id; + User_Project_Node : out Prj.Tree.Project_Node_Id; + Config_File_Name : String := ""; + Autoconf_Specified : Boolean; + Project_File_Name : String; + Project_Tree : Prj.Project_Tree_Ref; + Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref; + Packages_To_Check : String_List_Access; + Allow_Automatic_Generation : Boolean := True; + Automatically_Generated : out Boolean; + Config_File_Path : out String_Access; + Target_Name : String := ""; + Normalized_Hostname : String; + Flags : Processing_Flags; + On_Load_Config : Config_File_Hook := null); + -- Find the main configuration project and parse the project tree rooted at + -- this configuration project. + -- + -- Project_Node_Tree must have been initialized first (and possibly the + -- value for external references and project path should also have been + -- set). + -- + -- If the processing fails, Main_Project is set to No_Project. If the error + -- happened while parsing the project itself (i.e. creating the tree), + -- User_Project_Node is also set to Empty_Node. + -- + -- Autoconf_Specified indicates whether the user has specified --autoconf. + -- If this is the case, the config file might be (re)generated, as + -- appropriate, to match languages and target if the one specified doesn't + -- already match. + -- + -- Normalized_Hostname is the host on which gprbuild is returned, + -- normalized so that we can more easily compare it with what is stored in + -- configuration files. It is used when the target is unspecified, although + -- we need to know the target specified by the user (Target_Name) when + -- computing the name of the default config file that should be used. + -- + -- If specified, On_Load_Config is called just after the config file has + -- been created/loaded. You can then modify it before it is later applied + -- to the project itself. + -- + -- Any error in generating or parsing the config file is reported via the + -- Invalid_Config exception, with an appropriate message. Any error while + -- parsing the project file results in No_Project. + + procedure Process_Project_And_Apply_Config + (Main_Project : out Prj.Project_Id; + User_Project_Node : Prj.Tree.Project_Node_Id; + Config_File_Name : String := ""; + Autoconf_Specified : Boolean; + Project_Tree : Prj.Project_Tree_Ref; + Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref; + Packages_To_Check : String_List_Access; + Allow_Automatic_Generation : Boolean := True; + Automatically_Generated : out Boolean; + Config_File_Path : out String_Access; + Target_Name : String := ""; + Normalized_Hostname : String; + Flags : Processing_Flags; + On_Load_Config : Config_File_Hook := null; + Reset_Tree : Boolean := True); + -- Same as above, except the project must already have been parsed through + -- Prj.Part.Parse, and only the processing of the project and the + -- configuration is done at this level. + -- + -- If Reset_Tree is true, all projects are first removed from the tree. + -- When_No_Sources indicates what should be done when no sources are found + -- for one of the languages of the project. + -- + -- If Require_Sources_Other_Lang is true, then all languages must have at + -- least one source file, or an error is reported via When_No_Sources. If + -- it is false, this is only required for Ada (and only if it is a language + -- of the project). + + Invalid_Config : exception; + + procedure Get_Or_Create_Configuration_File + (Project : Prj.Project_Id; + Project_Tree : Prj.Project_Tree_Ref; + Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref; + Allow_Automatic_Generation : Boolean; + Config_File_Name : String := ""; + Autoconf_Specified : Boolean; + Target_Name : String := ""; + Normalized_Hostname : String; + Packages_To_Check : String_List_Access := null; + Config : out Prj.Project_Id; + Config_File_Path : out String_Access; + Automatically_Generated : out Boolean; + Flags : Processing_Flags; + On_Load_Config : Config_File_Hook := null); + -- Compute the name of the configuration file that should be used. If no + -- default configuration file is found, a new one will be automatically + -- generated if Allow_Automatic_Generation is true. + -- + -- Any error in generating or parsing the config file is reported via the + -- Invalid_Config exception, with an appropriate message. + -- + -- On exit, Configuration_Project_Path is never null (if none could be + -- found, Os.Fail was called and the program exited anyway). + -- + -- The choice and generation of a configuration file depends on several + -- attributes of the user's project file (given by the Project argument), + -- e.g. list of languages that must be supported. Project must therefore + -- have been partially processed (phase one of the processing only). + -- + -- Config_File_Name should be set to the name of the config file specified + -- by the user (either through gprbuild's --config or --autoconf switches). + -- In the latter case, Autoconf_Specified should be set to true to indicate + -- that the configuration file can be regenerated to match target and + -- languages. This name can either be an absolute path, or the base name + -- that will be searched in the default config file directories (which + -- depends on the installation path for the tools). + -- + -- Target_Name is used to chose the configuration file that will be used + -- from among several possibilities. + -- + -- If a project file could be found, it is automatically parsed and + -- processed (and Packages_To_Check is used to indicate which packages + -- should be processed) + + procedure Apply_Config_File + (Config_File : Prj.Project_Id; + Project_Tree : Prj.Project_Tree_Ref); + -- Apply the configuration file settings to all the projects in the + -- project tree. The Project_Tree must have been parsed first, and + -- processed through the first phase so that all its projects are known. + -- + -- Currently, this will add new attributes and packages in the various + -- projects, so that when the second phase of the processing is performed + -- these attributes are automatically taken into account. + + procedure Add_Default_GNAT_Naming_Scheme + (Config_File : in out Prj.Tree.Project_Node_Id; + Project_Tree : Prj.Tree.Project_Node_Tree_Ref); + -- A hook that will create a new config file (in memory), used for + -- Get_Or_Create_Configuration_File and Process_Project_And_Apply_Config + -- and add the default GNAT naming scheme to it. Nothing is done if the + -- config_file already exists, to avoid overriding what the user might + -- have put in there. + + -------------- + -- Runtimes -- + -------------- + + procedure Set_Runtime_For (Language : Name_Id; RTS_Name : String); + -- Specifies the runtime to use for a specific language. Most of the time + -- this should be used for Ada, but other languages can also specify their + -- own runtime. This is in general specified via the --RTS command line + -- switch, and results in a specific component passed to gprconfig's + -- --config switch then automatically generating a configuration file. + + function Runtime_Name_For (Language : Name_Id) return String; + -- Returns the runtime name for a language. Returns an empty string if no + -- runtime was specified for the language using option --RTS. + +end Prj.Conf; diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb new file mode 100644 index 000000000..83ec3575b --- /dev/null +++ b/gcc/ada/prj-dect.adb @@ -0,0 +1,1791 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . D E C T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Err_Vars; use Err_Vars; + +with GNAT.Case_Util; use GNAT.Case_Util; +with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; + +with Opt; use Opt; +with Prj.Attr; use Prj.Attr; +with Prj.Attr.PM; use Prj.Attr.PM; +with Prj.Err; use Prj.Err; +with Prj.Strt; use Prj.Strt; +with Prj.Tree; use Prj.Tree; +with Snames; +with Uintp; use Uintp; + +with GNAT.Strings; + +package body Prj.Dect is + + use GNAT; + + type Zone is (In_Project, In_Package, In_Case_Construction); + -- Used to indicate if we are parsing a package (In_Package), + -- a case construction (In_Case_Construction) or none of those two + -- (In_Project). + + procedure Rename_Obsolescent_Attributes + (In_Tree : Project_Node_Tree_Ref; + Attribute : Project_Node_Id; + Current_Package : Project_Node_Id); + -- Rename obsolescent attributes in the tree. + -- When the attribute has been renamed since its initial introduction in + -- the design of projects, we replace the old name in the tree with the + -- new name, so that the code does not have to check both names forever. + + procedure Check_Attribute_Allowed + (In_Tree : Project_Node_Tree_Ref; + Project : Project_Node_Id; + Attribute : Project_Node_Id; + Flags : Processing_Flags); + -- Check whether the attribute is valid in this project. + -- In particular, depending on the type of project (qualifier), some + -- attributes might be disabled. + + procedure Check_Package_Allowed + (In_Tree : Project_Node_Tree_Ref; + Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Flags : Processing_Flags); + -- Check whether the package is valid in this project + + procedure Parse_Attribute_Declaration + (In_Tree : Project_Node_Tree_Ref; + Attribute : out Project_Node_Id; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Packages_To_Check : String_List_Access; + Flags : Processing_Flags); + -- Parse an attribute declaration + + procedure Parse_Case_Construction + (In_Tree : Project_Node_Tree_Ref; + Case_Construction : out Project_Node_Id; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Packages_To_Check : String_List_Access; + Is_Config_File : Boolean; + Flags : Processing_Flags); + -- Parse a case construction + + procedure Parse_Declarative_Items + (In_Tree : Project_Node_Tree_Ref; + Declarations : out Project_Node_Id; + In_Zone : Zone; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Packages_To_Check : String_List_Access; + Is_Config_File : Boolean; + Flags : Processing_Flags); + -- Parse declarative items. Depending on In_Zone, some declarative items + -- may be forbidden. Is_Config_File should be set to True if the project + -- represents a config file (.cgpr) since some specific checks apply. + + procedure Parse_Package_Declaration + (In_Tree : Project_Node_Tree_Ref; + Package_Declaration : out Project_Node_Id; + Current_Project : Project_Node_Id; + Packages_To_Check : String_List_Access; + Is_Config_File : Boolean; + Flags : Processing_Flags); + -- Parse a package declaration. + -- Is_Config_File should be set to True if the project represents a config + -- file (.cgpr) since some specific checks apply. + + procedure Parse_String_Type_Declaration + (In_Tree : Project_Node_Tree_Ref; + String_Type : out Project_Node_Id; + Current_Project : Project_Node_Id; + Flags : Processing_Flags); + -- type is ( { , } ) ; + + procedure Parse_Variable_Declaration + (In_Tree : Project_Node_Tree_Ref; + Variable : out Project_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Flags : Processing_Flags); + -- Parse a variable assignment + -- := ; OR + -- : := ; + + ----------- + -- Parse -- + ----------- + + procedure Parse + (In_Tree : Project_Node_Tree_Ref; + Declarations : out Project_Node_Id; + Current_Project : Project_Node_Id; + Extends : Project_Node_Id; + Packages_To_Check : String_List_Access; + Is_Config_File : Boolean; + Flags : Processing_Flags) + is + First_Declarative_Item : Project_Node_Id := Empty_Node; + + begin + Declarations := + Default_Project_Node + (Of_Kind => N_Project_Declaration, In_Tree => In_Tree); + Set_Location_Of (Declarations, In_Tree, To => Token_Ptr); + Set_Extended_Project_Of (Declarations, In_Tree, To => Extends); + Set_Project_Declaration_Of (Current_Project, In_Tree, Declarations); + Parse_Declarative_Items + (Declarations => First_Declarative_Item, + In_Tree => In_Tree, + In_Zone => In_Project, + First_Attribute => Prj.Attr.Attribute_First, + Current_Project => Current_Project, + Current_Package => Empty_Node, + Packages_To_Check => Packages_To_Check, + Is_Config_File => Is_Config_File, + Flags => Flags); + Set_First_Declarative_Item_Of + (Declarations, In_Tree, To => First_Declarative_Item); + end Parse; + + ----------------------------------- + -- Rename_Obsolescent_Attributes -- + ----------------------------------- + + procedure Rename_Obsolescent_Attributes + (In_Tree : Project_Node_Tree_Ref; + Attribute : Project_Node_Id; + Current_Package : Project_Node_Id) + is + begin + if Present (Current_Package) + and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored + then + case Name_Of (Attribute, In_Tree) is + when Snames.Name_Specification => + Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec); + + when Snames.Name_Specification_Suffix => + Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix); + + when Snames.Name_Implementation => + Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body); + + when Snames.Name_Implementation_Suffix => + Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix); + + when others => + null; + end case; + end if; + end Rename_Obsolescent_Attributes; + + --------------------------- + -- Check_Package_Allowed -- + --------------------------- + + procedure Check_Package_Allowed + (In_Tree : Project_Node_Tree_Ref; + Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Flags : Processing_Flags) + is + Qualif : constant Project_Qualifier := + Project_Qualifier_Of (Project, In_Tree); + Name : constant Name_Id := Name_Of (Current_Package, In_Tree); + begin + if Qualif = Aggregate + and then Name /= Snames.Name_Builder + then + Error_Msg_Name_1 := Name; + Error_Msg + (Flags, + "package %% is forbidden in aggregate projects", + Location_Of (Current_Package, In_Tree)); + end if; + end Check_Package_Allowed; + + ----------------------------- + -- Check_Attribute_Allowed -- + ----------------------------- + + procedure Check_Attribute_Allowed + (In_Tree : Project_Node_Tree_Ref; + Project : Project_Node_Id; + Attribute : Project_Node_Id; + Flags : Processing_Flags) + is + Qualif : constant Project_Qualifier := + Project_Qualifier_Of (Project, In_Tree); + Name : constant Name_Id := Name_Of (Attribute, In_Tree); + + begin + case Qualif is + when Aggregate => + if Name = Snames.Name_Languages + or else Name = Snames.Name_Source_Files + or else Name = Snames.Name_Source_List_File + or else Name = Snames.Name_Locally_Removed_Files + or else Name = Snames.Name_Excluded_Source_Files + or else Name = Snames.Name_Excluded_Source_List_File + or else Name = Snames.Name_Interfaces + or else Name = Snames.Name_Object_Dir + or else Name = Snames.Name_Exec_Dir + or else Name = Snames.Name_Source_Dirs + or else Name = Snames.Name_Inherit_Source_Path + then + Error_Msg_Name_1 := Name; + Error_Msg + (Flags, + "%% is not valid in aggregate projects", + Location_Of (Attribute, In_Tree)); + end if; + + when others => + if Name = Snames.Name_Project_Files + or else Name = Snames.Name_Project_Path + or else Name = Snames.Name_External + then + Error_Msg_Name_1 := Name; + Error_Msg + (Flags, + "%% is only valid in aggregate projects", + Location_Of (Attribute, In_Tree)); + end if; + end case; + end Check_Attribute_Allowed; + + --------------------------------- + -- Parse_Attribute_Declaration -- + --------------------------------- + + procedure Parse_Attribute_Declaration + (In_Tree : Project_Node_Tree_Ref; + Attribute : out Project_Node_Id; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Packages_To_Check : String_List_Access; + Flags : Processing_Flags) + is + Current_Attribute : Attribute_Node_Id := First_Attribute; + Full_Associative_Array : Boolean := False; + Attribute_Name : Name_Id := No_Name; + Optional_Index : Boolean := False; + Pkg_Id : Package_Node_Id := Empty_Package; + + procedure Process_Attribute_Name; + -- Read the name of the attribute, and check its type + + procedure Process_Associative_Array_Index; + -- Read the index of the associative array and check its validity + + ---------------------------- + -- Process_Attribute_Name -- + ---------------------------- + + procedure Process_Attribute_Name is + Ignore : Boolean; + + begin + Attribute_Name := Token_Name; + Set_Name_Of (Attribute, In_Tree, To => Attribute_Name); + Set_Location_Of (Attribute, In_Tree, To => Token_Ptr); + + -- Find the attribute + + Current_Attribute := + Attribute_Node_Id_Of (Attribute_Name, First_Attribute); + + -- If the attribute cannot be found, create the attribute if inside + -- an unknown package. + + if Current_Attribute = Empty_Attribute then + if Present (Current_Package) + and then Expression_Kind_Of (Current_Package, In_Tree) = Ignored + then + Pkg_Id := Package_Id_Of (Current_Package, In_Tree); + Add_Attribute (Pkg_Id, Token_Name, Current_Attribute); + + else + -- If not a valid attribute name, issue an error if inside + -- a package that need to be checked. + + Ignore := Present (Current_Package) and then + Packages_To_Check /= All_Packages; + + if Ignore then + + -- Check that we are not in a package to check + + Get_Name_String (Name_Of (Current_Package, In_Tree)); + + for Index in Packages_To_Check'Range loop + if Name_Buffer (1 .. Name_Len) = + Packages_To_Check (Index).all + then + Ignore := False; + exit; + end if; + end loop; + end if; + + if not Ignore then + Error_Msg_Name_1 := Token_Name; + Error_Msg (Flags, "undefined attribute %%", Token_Ptr); + end if; + end if; + + -- Set, if appropriate the index case insensitivity flag + + else + if Is_Read_Only (Current_Attribute) then + Error_Msg_Name_1 := Token_Name; + Error_Msg + (Flags, "read-only attribute %% cannot be given a value", + Token_Ptr); + end if; + + if Attribute_Kind_Of (Current_Attribute) in + All_Case_Insensitive_Associative_Array + then + Set_Case_Insensitive (Attribute, In_Tree, To => True); + end if; + end if; + + Scan (In_Tree); -- past the attribute name + + -- Set the expression kind of the attribute + + if Current_Attribute /= Empty_Attribute then + Set_Expression_Kind_Of + (Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute)); + Optional_Index := Optional_Index_Of (Current_Attribute); + end if; + end Process_Attribute_Name; + + ------------------------------------- + -- Process_Associative_Array_Index -- + ------------------------------------- + + procedure Process_Associative_Array_Index is + begin + -- If the attribute is not an associative array attribute, report + -- an error. If this information is still unknown, set the kind + -- to Associative_Array. + + if Current_Attribute /= Empty_Attribute + and then Attribute_Kind_Of (Current_Attribute) = Single + then + Error_Msg (Flags, + "the attribute """ & + Get_Name_String (Attribute_Name_Of (Current_Attribute)) + & """ cannot be an associative array", + Location_Of (Attribute, In_Tree)); + + elsif Attribute_Kind_Of (Current_Attribute) = Unknown then + Set_Attribute_Kind_Of (Current_Attribute, To => Associative_Array); + end if; + + Scan (In_Tree); -- past the left parenthesis + + if Others_Allowed_For (Current_Attribute) + and then Token = Tok_Others + then + Set_Associative_Array_Index_Of + (Attribute, In_Tree, All_Other_Names); + Scan (In_Tree); -- past others + + else + if Others_Allowed_For (Current_Attribute) then + Expect (Tok_String_Literal, "literal string or others"); + else + Expect (Tok_String_Literal, "literal string"); + end if; + + if Token = Tok_String_Literal then + Get_Name_String (Token_Name); + + if Case_Insensitive (Attribute, In_Tree) then + To_Lower (Name_Buffer (1 .. Name_Len)); + end if; + + Set_Associative_Array_Index_Of (Attribute, In_Tree, Name_Find); + Scan (In_Tree); -- past the literal string index + + if Token = Tok_At then + case Attribute_Kind_Of (Current_Attribute) is + when Optional_Index_Associative_Array | + Optional_Index_Case_Insensitive_Associative_Array => + Scan (In_Tree); + Expect (Tok_Integer_Literal, "integer literal"); + + if Token = Tok_Integer_Literal then + + -- Set the source index value from given literal + + declare + Index : constant Int := + UI_To_Int (Int_Literal_Value); + begin + if Index = 0 then + Error_Msg + (Flags, "index cannot be zero", Token_Ptr); + else + Set_Source_Index_Of + (Attribute, In_Tree, To => Index); + end if; + end; + + Scan (In_Tree); + end if; + + when others => + Error_Msg (Flags, "index not allowed here", Token_Ptr); + Scan (In_Tree); + + if Token = Tok_Integer_Literal then + Scan (In_Tree); + end if; + end case; + end if; + end if; + end if; + + Expect (Tok_Right_Paren, "`)`"); + + if Token = Tok_Right_Paren then + Scan (In_Tree); -- past the right parenthesis + end if; + end Process_Associative_Array_Index; + + begin + Attribute := + Default_Project_Node + (Of_Kind => N_Attribute_Declaration, In_Tree => In_Tree); + Set_Location_Of (Attribute, In_Tree, To => Token_Ptr); + Set_Previous_Line_Node (Attribute); + + -- Scan past "for" + + Scan (In_Tree); + + -- Body may be an attribute name + + if Token = Tok_Body then + Token := Tok_Identifier; + Token_Name := Snames.Name_Body; + end if; + + Expect (Tok_Identifier, "identifier"); + Process_Attribute_Name; + Rename_Obsolescent_Attributes (In_Tree, Attribute, Current_Package); + Check_Attribute_Allowed (In_Tree, Current_Project, Attribute, Flags); + + -- Associative array attributes + + if Token = Tok_Left_Paren then + Process_Associative_Array_Index; + + else + -- If it is an associative array attribute and there are no left + -- parenthesis, then this is a full associative array declaration. + -- Flag it as such for later processing of its value. + + if Current_Attribute /= Empty_Attribute + and then + Attribute_Kind_Of (Current_Attribute) /= Single + then + if Attribute_Kind_Of (Current_Attribute) = Unknown then + Set_Attribute_Kind_Of (Current_Attribute, To => Single); + + else + Full_Associative_Array := True; + end if; + end if; + end if; + + Expect (Tok_Use, "USE"); + + if Token = Tok_Use then + Scan (In_Tree); + + if Full_Associative_Array then + + -- Expect ', or + -- .' + + declare + The_Project : Project_Node_Id := Empty_Node; + -- The node of the project where the associative array is + -- declared. + + The_Package : Project_Node_Id := Empty_Node; + -- The node of the package where the associative array is + -- declared, if any. + + Project_Name : Name_Id := No_Name; + -- The name of the project where the associative array is + -- declared. + + Location : Source_Ptr := No_Location; + -- The location of the project name + + begin + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + Location := Token_Ptr; + + -- Find the project node in the imported project or + -- in the project being extended. + + The_Project := Imported_Or_Extended_Project_Of + (Current_Project, In_Tree, Token_Name); + + if No (The_Project) then + Error_Msg (Flags, "unknown project", Location); + Scan (In_Tree); -- past the project name + + else + Project_Name := Token_Name; + Scan (In_Tree); -- past the project name + + -- If this is inside a package, a dot followed by the + -- name of the package must followed the project name. + + if Present (Current_Package) then + Expect (Tok_Dot, "`.`"); + + if Token /= Tok_Dot then + The_Project := Empty_Node; + + else + Scan (In_Tree); -- past the dot + Expect (Tok_Identifier, "identifier"); + + if Token /= Tok_Identifier then + The_Project := Empty_Node; + + -- If it is not the same package name, issue error + + elsif + Token_Name /= Name_Of (Current_Package, In_Tree) + then + The_Project := Empty_Node; + Error_Msg + (Flags, "not the same package as " & + Get_Name_String + (Name_Of (Current_Package, In_Tree)), + Token_Ptr); + + else + The_Package := + First_Package_Of (The_Project, In_Tree); + + -- Look for the package node + + while Present (The_Package) + and then + Name_Of (The_Package, In_Tree) /= Token_Name + loop + The_Package := + Next_Package_In_Project + (The_Package, In_Tree); + end loop; + + -- If the package cannot be found in the + -- project, issue an error. + + if No (The_Package) then + The_Project := Empty_Node; + Error_Msg_Name_2 := Project_Name; + Error_Msg_Name_1 := Token_Name; + Error_Msg + (Flags, + "package % not declared in project %", + Token_Ptr); + end if; + + Scan (In_Tree); -- past the package name + end if; + end if; + end if; + end if; + end if; + + if Present (The_Project) then + + -- Looking for ' + + Expect (Tok_Apostrophe, "`''`"); + + if Token /= Tok_Apostrophe then + The_Project := Empty_Node; + + else + Scan (In_Tree); -- past the apostrophe + Expect (Tok_Identifier, "identifier"); + + if Token /= Tok_Identifier then + The_Project := Empty_Node; + + else + -- If it is not the same attribute name, issue error + + if Token_Name /= Attribute_Name then + The_Project := Empty_Node; + Error_Msg_Name_1 := Attribute_Name; + Error_Msg + (Flags, "invalid name, should be %", Token_Ptr); + end if; + + Scan (In_Tree); -- past the attribute name + end if; + end if; + end if; + + if No (The_Project) then + + -- If there were any problem, set the attribute id to null, + -- so that the node will not be recorded. + + Current_Attribute := Empty_Attribute; + + else + -- Set the appropriate field in the node. + -- Note that the index and the expression are nil. This + -- characterizes full associative array attribute + -- declarations. + + Set_Associative_Project_Of (Attribute, In_Tree, The_Project); + Set_Associative_Package_Of (Attribute, In_Tree, The_Package); + end if; + end; + + -- Other attribute declarations (not full associative array) + + else + declare + Expression_Location : constant Source_Ptr := Token_Ptr; + -- The location of the first token of the expression + + Expression : Project_Node_Id := Empty_Node; + -- The expression, value for the attribute declaration + + begin + -- Get the expression value and set it in the attribute node + + Parse_Expression + (In_Tree => In_Tree, + Expression => Expression, + Flags => Flags, + Current_Project => Current_Project, + Current_Package => Current_Package, + Optional_Index => Optional_Index); + Set_Expression_Of (Attribute, In_Tree, To => Expression); + + -- If the expression is legal, but not of the right kind + -- for the attribute, issue an error. + + if Current_Attribute /= Empty_Attribute + and then Present (Expression) + and then Variable_Kind_Of (Current_Attribute) /= + Expression_Kind_Of (Expression, In_Tree) + then + if Variable_Kind_Of (Current_Attribute) = Undefined then + Set_Variable_Kind_Of + (Current_Attribute, + To => Expression_Kind_Of (Expression, In_Tree)); + + else + Error_Msg + (Flags, "wrong expression kind for attribute """ & + Get_Name_String + (Attribute_Name_Of (Current_Attribute)) & + """", + Expression_Location); + end if; + end if; + end; + end if; + end if; + + -- If the attribute was not recognized, return an empty node. + -- It may be that it is not in a package to check, and the node will + -- not be added to the tree. + + if Current_Attribute = Empty_Attribute then + Attribute := Empty_Node; + end if; + + Set_End_Of_Line (Attribute); + Set_Previous_Line_Node (Attribute); + end Parse_Attribute_Declaration; + + ----------------------------- + -- Parse_Case_Construction -- + ----------------------------- + + procedure Parse_Case_Construction + (In_Tree : Project_Node_Tree_Ref; + Case_Construction : out Project_Node_Id; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Packages_To_Check : String_List_Access; + Is_Config_File : Boolean; + Flags : Processing_Flags) + is + Current_Item : Project_Node_Id := Empty_Node; + Next_Item : Project_Node_Id := Empty_Node; + First_Case_Item : Boolean := True; + + Variable_Location : Source_Ptr := No_Location; + + String_Type : Project_Node_Id := Empty_Node; + + Case_Variable : Project_Node_Id := Empty_Node; + + First_Declarative_Item : Project_Node_Id := Empty_Node; + + First_Choice : Project_Node_Id := Empty_Node; + + When_Others : Boolean := False; + -- Set to True when there is a "when others =>" clause + + begin + Case_Construction := + Default_Project_Node + (Of_Kind => N_Case_Construction, In_Tree => In_Tree); + Set_Location_Of (Case_Construction, In_Tree, To => Token_Ptr); + + -- Scan past "case" + + Scan (In_Tree); + + -- Get the switch variable + + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + Variable_Location := Token_Ptr; + Parse_Variable_Reference + (In_Tree => In_Tree, + Variable => Case_Variable, + Flags => Flags, + Current_Project => Current_Project, + Current_Package => Current_Package); + Set_Case_Variable_Reference_Of + (Case_Construction, In_Tree, To => Case_Variable); + + else + if Token /= Tok_Is then + Scan (In_Tree); + end if; + end if; + + if Present (Case_Variable) then + String_Type := String_Type_Of (Case_Variable, In_Tree); + + if No (String_Type) then + Error_Msg (Flags, + "variable """ & + Get_Name_String (Name_Of (Case_Variable, In_Tree)) & + """ is not typed", + Variable_Location); + end if; + end if; + + Expect (Tok_Is, "IS"); + + if Token = Tok_Is then + Set_End_Of_Line (Case_Construction); + Set_Previous_Line_Node (Case_Construction); + Set_Next_End_Node (Case_Construction); + + -- Scan past "is" + + Scan (In_Tree); + end if; + + Start_New_Case_Construction (In_Tree, String_Type); + + When_Loop : + + while Token = Tok_When loop + + if First_Case_Item then + Current_Item := + Default_Project_Node + (Of_Kind => N_Case_Item, In_Tree => In_Tree); + Set_First_Case_Item_Of + (Case_Construction, In_Tree, To => Current_Item); + First_Case_Item := False; + + else + Next_Item := + Default_Project_Node + (Of_Kind => N_Case_Item, In_Tree => In_Tree); + Set_Next_Case_Item (Current_Item, In_Tree, To => Next_Item); + Current_Item := Next_Item; + end if; + + Set_Location_Of (Current_Item, In_Tree, To => Token_Ptr); + + -- Scan past "when" + + Scan (In_Tree); + + if Token = Tok_Others then + When_Others := True; + + -- Scan past "others" + + Scan (In_Tree); + + Expect (Tok_Arrow, "`=>`"); + Set_End_Of_Line (Current_Item); + Set_Previous_Line_Node (Current_Item); + + -- Empty_Node in Field1 of a Case_Item indicates + -- the "when others =>" branch. + + Set_First_Choice_Of (Current_Item, In_Tree, To => Empty_Node); + + Parse_Declarative_Items + (In_Tree => In_Tree, + Declarations => First_Declarative_Item, + In_Zone => In_Case_Construction, + First_Attribute => First_Attribute, + Current_Project => Current_Project, + Current_Package => Current_Package, + Packages_To_Check => Packages_To_Check, + Is_Config_File => Is_Config_File, + Flags => Flags); + + -- "when others =>" must be the last branch, so save the + -- Case_Item and exit + + Set_First_Declarative_Item_Of + (Current_Item, In_Tree, To => First_Declarative_Item); + exit When_Loop; + + else + Parse_Choice_List + (In_Tree => In_Tree, + First_Choice => First_Choice, + Flags => Flags); + Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice); + + Expect (Tok_Arrow, "`=>`"); + Set_End_Of_Line (Current_Item); + Set_Previous_Line_Node (Current_Item); + + Parse_Declarative_Items + (In_Tree => In_Tree, + Declarations => First_Declarative_Item, + In_Zone => In_Case_Construction, + First_Attribute => First_Attribute, + Current_Project => Current_Project, + Current_Package => Current_Package, + Packages_To_Check => Packages_To_Check, + Is_Config_File => Is_Config_File, + Flags => Flags); + + Set_First_Declarative_Item_Of + (Current_Item, In_Tree, To => First_Declarative_Item); + + end if; + end loop When_Loop; + + End_Case_Construction + (Check_All_Labels => not When_Others and not Quiet_Output, + Case_Location => Location_Of (Case_Construction, In_Tree), + Flags => Flags); + + Expect (Tok_End, "`END CASE`"); + Remove_Next_End_Node; + + if Token = Tok_End then + + -- Scan past "end" + + Scan (In_Tree); + + Expect (Tok_Case, "CASE"); + + end if; + + -- Scan past "case" + + Scan (In_Tree); + + Expect (Tok_Semicolon, "`;`"); + Set_Previous_End_Node (Case_Construction); + + end Parse_Case_Construction; + + ----------------------------- + -- Parse_Declarative_Items -- + ----------------------------- + + procedure Parse_Declarative_Items + (In_Tree : Project_Node_Tree_Ref; + Declarations : out Project_Node_Id; + In_Zone : Zone; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Packages_To_Check : String_List_Access; + Is_Config_File : Boolean; + Flags : Processing_Flags) + is + Current_Declarative_Item : Project_Node_Id := Empty_Node; + Next_Declarative_Item : Project_Node_Id := Empty_Node; + Current_Declaration : Project_Node_Id := Empty_Node; + Item_Location : Source_Ptr := No_Location; + + begin + Declarations := Empty_Node; + + loop + -- We are always positioned at the token that precedes the first + -- token of the declarative element. Scan past it. + + Scan (In_Tree); + + Item_Location := Token_Ptr; + + case Token is + when Tok_Identifier => + + if In_Zone = In_Case_Construction then + + -- Check if the variable has already been declared + + declare + The_Variable : Project_Node_Id := Empty_Node; + + begin + if Present (Current_Package) then + The_Variable := + First_Variable_Of (Current_Package, In_Tree); + elsif Present (Current_Project) then + The_Variable := + First_Variable_Of (Current_Project, In_Tree); + end if; + + while Present (The_Variable) + and then Name_Of (The_Variable, In_Tree) /= + Token_Name + loop + The_Variable := Next_Variable (The_Variable, In_Tree); + end loop; + + -- It is an error to declare a variable in a case + -- construction for the first time. + + if No (The_Variable) then + Error_Msg + (Flags, + "a variable cannot be declared " & + "for the first time here", + Token_Ptr); + end if; + end; + end if; + + Parse_Variable_Declaration + (In_Tree, + Current_Declaration, + Current_Project => Current_Project, + Current_Package => Current_Package, + Flags => Flags); + + Set_End_Of_Line (Current_Declaration); + Set_Previous_Line_Node (Current_Declaration); + + when Tok_For => + + Parse_Attribute_Declaration + (In_Tree => In_Tree, + Attribute => Current_Declaration, + First_Attribute => First_Attribute, + Current_Project => Current_Project, + Current_Package => Current_Package, + Packages_To_Check => Packages_To_Check, + Flags => Flags); + + Set_End_Of_Line (Current_Declaration); + Set_Previous_Line_Node (Current_Declaration); + + when Tok_Null => + + Scan (In_Tree); -- past "null" + + when Tok_Package => + + -- Package declaration + + if In_Zone /= In_Project then + Error_Msg + (Flags, "a package cannot be declared here", Token_Ptr); + end if; + + Parse_Package_Declaration + (In_Tree => In_Tree, + Package_Declaration => Current_Declaration, + Current_Project => Current_Project, + Packages_To_Check => Packages_To_Check, + Is_Config_File => Is_Config_File, + Flags => Flags); + + Set_Previous_End_Node (Current_Declaration); + + when Tok_Type => + + -- Type String Declaration + + if In_Zone /= In_Project then + Error_Msg (Flags, + "a string type cannot be declared here", + Token_Ptr); + end if; + + Parse_String_Type_Declaration + (In_Tree => In_Tree, + String_Type => Current_Declaration, + Current_Project => Current_Project, + Flags => Flags); + + Set_End_Of_Line (Current_Declaration); + Set_Previous_Line_Node (Current_Declaration); + + when Tok_Case => + + -- Case construction + + Parse_Case_Construction + (In_Tree => In_Tree, + Case_Construction => Current_Declaration, + First_Attribute => First_Attribute, + Current_Project => Current_Project, + Current_Package => Current_Package, + Packages_To_Check => Packages_To_Check, + Is_Config_File => Is_Config_File, + Flags => Flags); + + Set_Previous_End_Node (Current_Declaration); + + when others => + exit; + + -- We are leaving Parse_Declarative_Items positioned + -- at the first token after the list of declarative items. + -- It could be "end" (for a project, a package declaration or + -- a case construction) or "when" (for a case construction) + + end case; + + Expect (Tok_Semicolon, "`;` after declarative items"); + + -- Insert an N_Declarative_Item in the tree, but only if + -- Current_Declaration is not an empty node. + + if Present (Current_Declaration) then + if No (Current_Declarative_Item) then + Current_Declarative_Item := + Default_Project_Node + (Of_Kind => N_Declarative_Item, In_Tree => In_Tree); + Declarations := Current_Declarative_Item; + + else + Next_Declarative_Item := + Default_Project_Node + (Of_Kind => N_Declarative_Item, In_Tree => In_Tree); + Set_Next_Declarative_Item + (Current_Declarative_Item, In_Tree, + To => Next_Declarative_Item); + Current_Declarative_Item := Next_Declarative_Item; + end if; + + Set_Current_Item_Node + (Current_Declarative_Item, In_Tree, + To => Current_Declaration); + Set_Location_Of + (Current_Declarative_Item, In_Tree, To => Item_Location); + end if; + end loop; + end Parse_Declarative_Items; + + ------------------------------- + -- Parse_Package_Declaration -- + ------------------------------- + + procedure Parse_Package_Declaration + (In_Tree : Project_Node_Tree_Ref; + Package_Declaration : out Project_Node_Id; + Current_Project : Project_Node_Id; + Packages_To_Check : String_List_Access; + Is_Config_File : Boolean; + Flags : Processing_Flags) + is + First_Attribute : Attribute_Node_Id := Empty_Attribute; + Current_Package : Package_Node_Id := Empty_Package; + First_Declarative_Item : Project_Node_Id := Empty_Node; + Package_Location : constant Source_Ptr := Token_Ptr; + Renaming : Boolean := False; + Extending : Boolean := False; + + begin + Package_Declaration := + Default_Project_Node + (Of_Kind => N_Package_Declaration, In_Tree => In_Tree); + Set_Location_Of (Package_Declaration, In_Tree, To => Package_Location); + + -- Scan past "package" + + Scan (In_Tree); + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + Set_Name_Of (Package_Declaration, In_Tree, To => Token_Name); + + Current_Package := Package_Node_Id_Of (Token_Name); + + if Current_Package = Empty_Package then + if not Quiet_Output then + declare + List : constant Strings.String_List := Package_Name_List; + Index : Natural; + Name : constant String := Get_Name_String (Token_Name); + + begin + -- Check for possible misspelling of a known package name + + Index := 0; + loop + if Index >= List'Last then + Index := 0; + exit; + end if; + + Index := Index + 1; + exit when + GNAT.Spelling_Checker.Is_Bad_Spelling_Of + (Name, List (Index).all); + end loop; + + -- Issue warning(s) in verbose mode or when a possible + -- misspelling has been found. + + if Verbose_Mode or else Index /= 0 then + Error_Msg (Flags, + "?""" & + Get_Name_String + (Name_Of (Package_Declaration, In_Tree)) & + """ is not a known package name", + Token_Ptr); + end if; + + if Index /= 0 then + Error_Msg -- CODEFIX + (Flags, + "\?possible misspelling of """ & + List (Index).all & """", Token_Ptr); + end if; + end; + end if; + + -- Set the package declaration to "ignored" so that it is not + -- processed by Prj.Proc.Process. + + Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored); + + -- Add the unknown package in the list of packages + + Add_Unknown_Package (Token_Name, Current_Package); + + elsif Current_Package = Unknown_Package then + + -- Set the package declaration to "ignored" so that it is not + -- processed by Prj.Proc.Process. + + Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored); + + else + First_Attribute := First_Attribute_Of (Current_Package); + end if; + + Set_Package_Id_Of + (Package_Declaration, In_Tree, To => Current_Package); + + declare + Current : Project_Node_Id := + First_Package_Of (Current_Project, In_Tree); + + begin + while Present (Current) + and then Name_Of (Current, In_Tree) /= Token_Name + loop + Current := Next_Package_In_Project (Current, In_Tree); + end loop; + + if Present (Current) then + Error_Msg + (Flags, + "package """ & + Get_Name_String (Name_Of (Package_Declaration, In_Tree)) & + """ is declared twice in the same project", + Token_Ptr); + + else + -- Add the package to the project list + + Set_Next_Package_In_Project + (Package_Declaration, In_Tree, + To => First_Package_Of (Current_Project, In_Tree)); + Set_First_Package_Of + (Current_Project, In_Tree, To => Package_Declaration); + end if; + end; + + -- Scan past the package name + + Scan (In_Tree); + end if; + + Check_Package_Allowed + (In_Tree, Current_Project, Package_Declaration, Flags); + + if Token = Tok_Renames then + Renaming := True; + elsif Token = Tok_Extends then + Extending := True; + end if; + + if Renaming or else Extending then + if Is_Config_File then + Error_Msg + (Flags, + "no package rename or extension in configuration projects", + Token_Ptr); + end if; + + -- Scan past "renames" or "extends" + + Scan (In_Tree); + + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + declare + Project_Name : constant Name_Id := Token_Name; + + Clause : Project_Node_Id := + First_With_Clause_Of (Current_Project, In_Tree); + The_Project : Project_Node_Id := Empty_Node; + Extended : constant Project_Node_Id := + Extended_Project_Of + (Project_Declaration_Of + (Current_Project, In_Tree), + In_Tree); + begin + while Present (Clause) loop + -- Only non limited imported projects may be used in a + -- renames declaration. + + The_Project := + Non_Limited_Project_Node_Of (Clause, In_Tree); + exit when Present (The_Project) + and then Name_Of (The_Project, In_Tree) = Project_Name; + Clause := Next_With_Clause_Of (Clause, In_Tree); + end loop; + + if No (Clause) then + -- As we have not found the project in the imports, we check + -- if it's the name of an eventual extended project. + + if Present (Extended) + and then Name_Of (Extended, In_Tree) = Project_Name + then + Set_Project_Of_Renamed_Package_Of + (Package_Declaration, In_Tree, To => Extended); + else + Error_Msg_Name_1 := Project_Name; + Error_Msg + (Flags, + "% is not an imported or extended project", Token_Ptr); + end if; + else + Set_Project_Of_Renamed_Package_Of + (Package_Declaration, In_Tree, To => The_Project); + end if; + end; + + Scan (In_Tree); + Expect (Tok_Dot, "`.`"); + + if Token = Tok_Dot then + Scan (In_Tree); + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + if Name_Of (Package_Declaration, In_Tree) /= Token_Name then + Error_Msg (Flags, "not the same package name", Token_Ptr); + elsif + Present (Project_Of_Renamed_Package_Of + (Package_Declaration, In_Tree)) + then + declare + Current : Project_Node_Id := + First_Package_Of + (Project_Of_Renamed_Package_Of + (Package_Declaration, In_Tree), + In_Tree); + + begin + while Present (Current) + and then Name_Of (Current, In_Tree) /= Token_Name + loop + Current := + Next_Package_In_Project (Current, In_Tree); + end loop; + + if No (Current) then + Error_Msg + (Flags, """" & + Get_Name_String (Token_Name) & + """ is not a package declared by the project", + Token_Ptr); + end if; + end; + end if; + + Scan (In_Tree); + end if; + end if; + end if; + end if; + + if Renaming then + Expect (Tok_Semicolon, "`;`"); + Set_End_Of_Line (Package_Declaration); + Set_Previous_Line_Node (Package_Declaration); + + elsif Token = Tok_Is then + Set_End_Of_Line (Package_Declaration); + Set_Previous_Line_Node (Package_Declaration); + Set_Next_End_Node (Package_Declaration); + + Parse_Declarative_Items + (In_Tree => In_Tree, + Declarations => First_Declarative_Item, + In_Zone => In_Package, + First_Attribute => First_Attribute, + Current_Project => Current_Project, + Current_Package => Package_Declaration, + Packages_To_Check => Packages_To_Check, + Is_Config_File => Is_Config_File, + Flags => Flags); + + Set_First_Declarative_Item_Of + (Package_Declaration, In_Tree, To => First_Declarative_Item); + + Expect (Tok_End, "END"); + + if Token = Tok_End then + + -- Scan past "end" + + Scan (In_Tree); + end if; + + -- We should have the name of the package after "end" + + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier + and then Name_Of (Package_Declaration, In_Tree) /= No_Name + and then Token_Name /= Name_Of (Package_Declaration, In_Tree) + then + Error_Msg_Name_1 := Name_Of (Package_Declaration, In_Tree); + Error_Msg (Flags, "expected %%", Token_Ptr); + end if; + + if Token /= Tok_Semicolon then + + -- Scan past the package name + + Scan (In_Tree); + end if; + + Expect (Tok_Semicolon, "`;`"); + Remove_Next_End_Node; + + else + Error_Msg (Flags, "expected IS", Token_Ptr); + end if; + + end Parse_Package_Declaration; + + ----------------------------------- + -- Parse_String_Type_Declaration -- + ----------------------------------- + + procedure Parse_String_Type_Declaration + (In_Tree : Project_Node_Tree_Ref; + String_Type : out Project_Node_Id; + Current_Project : Project_Node_Id; + Flags : Processing_Flags) + is + Current : Project_Node_Id := Empty_Node; + First_String : Project_Node_Id := Empty_Node; + + begin + String_Type := + Default_Project_Node + (Of_Kind => N_String_Type_Declaration, In_Tree => In_Tree); + + Set_Location_Of (String_Type, In_Tree, To => Token_Ptr); + + -- Scan past "type" + + Scan (In_Tree); + + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + Set_Name_Of (String_Type, In_Tree, To => Token_Name); + + Current := First_String_Type_Of (Current_Project, In_Tree); + while Present (Current) + and then + Name_Of (Current, In_Tree) /= Token_Name + loop + Current := Next_String_Type (Current, In_Tree); + end loop; + + if Present (Current) then + Error_Msg (Flags, + "duplicate string type name """ & + Get_Name_String (Token_Name) & + """", + Token_Ptr); + else + Current := First_Variable_Of (Current_Project, In_Tree); + while Present (Current) + and then Name_Of (Current, In_Tree) /= Token_Name + loop + Current := Next_Variable (Current, In_Tree); + end loop; + + if Present (Current) then + Error_Msg (Flags, + """" & + Get_Name_String (Token_Name) & + """ is already a variable name", Token_Ptr); + else + Set_Next_String_Type + (String_Type, In_Tree, + To => First_String_Type_Of (Current_Project, In_Tree)); + Set_First_String_Type_Of + (Current_Project, In_Tree, To => String_Type); + end if; + end if; + + -- Scan past the name + + Scan (In_Tree); + end if; + + Expect (Tok_Is, "IS"); + + if Token = Tok_Is then + Scan (In_Tree); + end if; + + Expect (Tok_Left_Paren, "`(`"); + + if Token = Tok_Left_Paren then + Scan (In_Tree); + end if; + + Parse_String_Type_List + (In_Tree => In_Tree, First_String => First_String, Flags => Flags); + Set_First_Literal_String (String_Type, In_Tree, To => First_String); + + Expect (Tok_Right_Paren, "`)`"); + + if Token = Tok_Right_Paren then + Scan (In_Tree); + end if; + + end Parse_String_Type_Declaration; + + -------------------------------- + -- Parse_Variable_Declaration -- + -------------------------------- + + procedure Parse_Variable_Declaration + (In_Tree : Project_Node_Tree_Ref; + Variable : out Project_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Flags : Processing_Flags) + is + Expression_Location : Source_Ptr; + String_Type_Name : Name_Id := No_Name; + Project_String_Type_Name : Name_Id := No_Name; + Type_Location : Source_Ptr := No_Location; + Project_Location : Source_Ptr := No_Location; + Expression : Project_Node_Id := Empty_Node; + Variable_Name : constant Name_Id := Token_Name; + OK : Boolean := True; + + begin + Variable := + Default_Project_Node + (Of_Kind => N_Variable_Declaration, In_Tree => In_Tree); + Set_Name_Of (Variable, In_Tree, To => Variable_Name); + Set_Location_Of (Variable, In_Tree, To => Token_Ptr); + + -- Scan past the variable name + + Scan (In_Tree); + + if Token = Tok_Colon then + + -- Typed string variable declaration + + Scan (In_Tree); + Set_Kind_Of (Variable, In_Tree, N_Typed_Variable_Declaration); + Expect (Tok_Identifier, "identifier"); + + OK := Token = Tok_Identifier; + + if OK then + String_Type_Name := Token_Name; + Type_Location := Token_Ptr; + Scan (In_Tree); + + if Token = Tok_Dot then + Project_String_Type_Name := String_Type_Name; + Project_Location := Type_Location; + + -- Scan past the dot + + Scan (In_Tree); + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + String_Type_Name := Token_Name; + Type_Location := Token_Ptr; + Scan (In_Tree); + else + OK := False; + end if; + end if; + + if OK then + declare + Proj : Project_Node_Id := Current_Project; + Current : Project_Node_Id := Empty_Node; + + begin + if Project_String_Type_Name /= No_Name then + declare + The_Project_Name_And_Node : constant + Tree_Private_Part.Project_Name_And_Node := + Tree_Private_Part.Projects_Htable.Get + (In_Tree.Projects_HT, Project_String_Type_Name); + + use Tree_Private_Part; + + begin + if The_Project_Name_And_Node = + Tree_Private_Part.No_Project_Name_And_Node + then + Error_Msg (Flags, + "unknown project """ & + Get_Name_String + (Project_String_Type_Name) & + """", + Project_Location); + Current := Empty_Node; + else + Current := + First_String_Type_Of + (The_Project_Name_And_Node.Node, In_Tree); + while + Present (Current) + and then + Name_Of (Current, In_Tree) /= String_Type_Name + loop + Current := Next_String_Type (Current, In_Tree); + end loop; + end if; + end; + + else + -- Look for a string type with the correct name in this + -- project or in any of its ancestors. + + loop + Current := + First_String_Type_Of (Proj, In_Tree); + while + Present (Current) + and then + Name_Of (Current, In_Tree) /= String_Type_Name + loop + Current := Next_String_Type (Current, In_Tree); + end loop; + + exit when Present (Current); + + Proj := Parent_Project_Of (Proj, In_Tree); + exit when No (Proj); + end loop; + end if; + + if No (Current) then + Error_Msg (Flags, + "unknown string type """ & + Get_Name_String (String_Type_Name) & + """", + Type_Location); + OK := False; + + else + Set_String_Type_Of + (Variable, In_Tree, To => Current); + end if; + end; + end if; + end if; + end if; + + Expect (Tok_Colon_Equal, "`:=`"); + + OK := OK and then Token = Tok_Colon_Equal; + + if Token = Tok_Colon_Equal then + Scan (In_Tree); + end if; + + -- Get the single string or string list value + + Expression_Location := Token_Ptr; + + Parse_Expression + (In_Tree => In_Tree, + Expression => Expression, + Flags => Flags, + Current_Project => Current_Project, + Current_Package => Current_Package, + Optional_Index => False); + Set_Expression_Of (Variable, In_Tree, To => Expression); + + if Present (Expression) then + -- A typed string must have a single string value, not a list + + if Kind_Of (Variable, In_Tree) = N_Typed_Variable_Declaration + and then Expression_Kind_Of (Expression, In_Tree) = List + then + Error_Msg + (Flags, + "expression must be a single string", Expression_Location); + end if; + + Set_Expression_Kind_Of + (Variable, In_Tree, + To => Expression_Kind_Of (Expression, In_Tree)); + end if; + + if OK then + declare + The_Variable : Project_Node_Id := Empty_Node; + + begin + if Present (Current_Package) then + The_Variable := First_Variable_Of (Current_Package, In_Tree); + elsif Present (Current_Project) then + The_Variable := First_Variable_Of (Current_Project, In_Tree); + end if; + + while Present (The_Variable) + and then Name_Of (The_Variable, In_Tree) /= Variable_Name + loop + The_Variable := Next_Variable (The_Variable, In_Tree); + end loop; + + if No (The_Variable) then + if Present (Current_Package) then + Set_Next_Variable + (Variable, In_Tree, + To => First_Variable_Of (Current_Package, In_Tree)); + Set_First_Variable_Of + (Current_Package, In_Tree, To => Variable); + + elsif Present (Current_Project) then + Set_Next_Variable + (Variable, In_Tree, + To => First_Variable_Of (Current_Project, In_Tree)); + Set_First_Variable_Of + (Current_Project, In_Tree, To => Variable); + end if; + + else + if Expression_Kind_Of (Variable, In_Tree) /= Undefined then + if Expression_Kind_Of (The_Variable, In_Tree) = + Undefined + then + Set_Expression_Kind_Of + (The_Variable, In_Tree, + To => Expression_Kind_Of (Variable, In_Tree)); + + else + if Expression_Kind_Of (The_Variable, In_Tree) /= + Expression_Kind_Of (Variable, In_Tree) + then + Error_Msg (Flags, + "wrong expression kind for variable """ & + Get_Name_String + (Name_Of (The_Variable, In_Tree)) & + """", + Expression_Location); + end if; + end if; + end if; + end if; + end; + end if; + end Parse_Variable_Declaration; + +end Prj.Dect; diff --git a/gcc/ada/prj-dect.ads b/gcc/ada/prj-dect.ads new file mode 100644 index 000000000..2af6e27fd --- /dev/null +++ b/gcc/ada/prj-dect.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . D E C T -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Parse a list of declarative items in a project file + +with Prj.Tree; + +private package Prj.Dect is + + procedure Parse + (In_Tree : Prj.Tree.Project_Node_Tree_Ref; + Declarations : out Prj.Tree.Project_Node_Id; + Current_Project : Prj.Tree.Project_Node_Id; + Extends : Prj.Tree.Project_Node_Id; + Packages_To_Check : String_List_Access; + Is_Config_File : Boolean; + Flags : Processing_Flags); + -- Parse project declarative items + -- + -- In_Tree is the project node tree + -- + -- Declarations is the resulting project node + -- + -- Current_Project is the project node of the project for which the + -- declarative items are parsed. + -- + -- Extends is the project node of the project that project Current_Project + -- extends. If project Current-Project does not extend any project, + -- Extends has the value Empty_Node. + -- + -- Packages_To_Check is the list of packages that needs to be checked. + -- For legal packages declared in project Current_Project that are not in + -- Packages_To_Check, only the syntax of the declarations are checked, not + -- the attribute names and kinds. + -- + -- Is_Config_File should be set to True if the project represents a config + -- file (.cgpr) since some specific checks apply. + +end Prj.Dect; diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb new file mode 100644 index 000000000..1114ab342 --- /dev/null +++ b/gcc/ada/prj-env.adb @@ -0,0 +1,2189 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . E N V -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Fmap; +with Hostparm; +with Makeutl; use Makeutl; +with Opt; +with Osint; use Osint; +with Output; use Output; +with Prj.Com; use Prj.Com; +with Sdefault; +with Tempdir; + +with GNAT.Directory_Operations; use GNAT.Directory_Operations; + +package body Prj.Env is + + Buffer_Initial : constant := 1_000; + -- Initial size of Buffer + + Uninitialized_Prefix : constant String := '#' & Path_Separator; + -- Prefix to indicate that the project path has not been initialized yet. + -- Must be two characters long + + No_Project_Default_Dir : constant String := "-"; + -- Indicator in the project path to indicate that the default search + -- directories should not be added to the path + + ----------------------- + -- Local Subprograms -- + ----------------------- + + package Source_Path_Table is new GNAT.Dynamic_Tables + (Table_Component_Type => Name_Id, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 100); + -- A table to store the source dirs before creating the source path file + + package Object_Path_Table is new GNAT.Dynamic_Tables + (Table_Component_Type => Path_Name_Type, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 100); + -- A table to store the object dirs, before creating the object path file + + procedure Add_To_Buffer + (S : String; + Buffer : in out String_Access; + Buffer_Last : in out Natural); + -- Add a string to Buffer, extending Buffer if needed + + procedure Add_To_Path + (Source_Dirs : String_List_Id; + In_Tree : Project_Tree_Ref; + Buffer : in out String_Access; + Buffer_Last : in out Natural); + -- Add to Ada_Path_Buffer all the source directories in string list + -- Source_Dirs, if any. + + procedure Add_To_Path + (Dir : String; + Buffer : in out String_Access; + Buffer_Last : in out Natural); + -- If Dir is not already in the global variable Ada_Path_Buffer, add it. + -- If Buffer_Last /= 0, prepend a Path_Separator character to Path. + + procedure Add_To_Source_Path + (Source_Dirs : String_List_Id; + In_Tree : Project_Tree_Ref; + Source_Paths : in out Source_Path_Table.Instance); + -- Add to Ada_Path_B all the source directories in string list + -- Source_Dirs, if any. Increment Ada_Path_Length. + + procedure Add_To_Object_Path + (Object_Dir : Path_Name_Type; + Object_Paths : in out Object_Path_Table.Instance); + -- Add Object_Dir to object path table. Make sure it is not duplicate + -- and it is the last one in the current table. + + procedure Set_Path_File_Var (Name : String; Value : String); + -- Call Setenv, after calling To_Host_File_Spec + + function Ultimate_Extension_Of + (Project : Project_Id) return Project_Id; + -- Return a project that is either Project or an extended ancestor of + -- Project that itself is not extended. + + procedure Initialize_Project_Path + (Self : in out Project_Search_Path; + Target_Name : String); + -- Initialize Current_Project_Path. Does nothing if the path has already + -- been initialized properly. + + ---------------------- + -- Ada_Include_Path -- + ---------------------- + + function Ada_Include_Path + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Recursive : Boolean := False) return String + is + Buffer : String_Access; + Buffer_Last : Natural := 0; + + procedure Add (Project : Project_Id; Dummy : in out Boolean); + -- Add source dirs of Project to the path + + --------- + -- Add -- + --------- + + procedure Add (Project : Project_Id; Dummy : in out Boolean) is + pragma Unreferenced (Dummy); + begin + Add_To_Path (Project.Source_Dirs, In_Tree, Buffer, Buffer_Last); + end Add; + + procedure For_All_Projects is + new For_Every_Project_Imported (Boolean, Add); + + Dummy : Boolean := False; + + -- Start of processing for Ada_Include_Path + + begin + if Recursive then + + -- If it is the first time we call this function for + -- this project, compute the source path + + if Project.Ada_Include_Path = null then + Buffer := new String (1 .. 4096); + For_All_Projects (Project, Dummy); + Project.Ada_Include_Path := new String'(Buffer (1 .. Buffer_Last)); + Free (Buffer); + end if; + + return Project.Ada_Include_Path.all; + + else + Buffer := new String (1 .. 4096); + Add_To_Path (Project.Source_Dirs, In_Tree, Buffer, Buffer_Last); + + declare + Result : constant String := Buffer (1 .. Buffer_Last); + begin + Free (Buffer); + return Result; + end; + end if; + end Ada_Include_Path; + + ---------------------- + -- Ada_Objects_Path -- + ---------------------- + + function Ada_Objects_Path + (Project : Project_Id; + Including_Libraries : Boolean := True) return String_Access + is + Buffer : String_Access; + Buffer_Last : Natural := 0; + + procedure Add (Project : Project_Id; Dummy : in out Boolean); + -- Add all the object directories of a project to the path + + --------- + -- Add -- + --------- + + procedure Add (Project : Project_Id; Dummy : in out Boolean) is + pragma Unreferenced (Dummy); + Path : constant Path_Name_Type := + Get_Object_Directory + (Project, + Including_Libraries => Including_Libraries, + Only_If_Ada => False); + begin + if Path /= No_Path then + Add_To_Path (Get_Name_String (Path), Buffer, Buffer_Last); + end if; + end Add; + + procedure For_All_Projects is + new For_Every_Project_Imported (Boolean, Add); + + Dummy : Boolean := False; + + -- Start of processing for Ada_Objects_Path + + begin + -- If it is the first time we call this function for + -- this project, compute the objects path + + if Project.Ada_Objects_Path = null then + Buffer := new String (1 .. 4096); + For_All_Projects (Project, Dummy); + + Project.Ada_Objects_Path := new String'(Buffer (1 .. Buffer_Last)); + Free (Buffer); + end if; + + return Project.Ada_Objects_Path; + end Ada_Objects_Path; + + ------------------- + -- Add_To_Buffer -- + ------------------- + + procedure Add_To_Buffer + (S : String; + Buffer : in out String_Access; + Buffer_Last : in out Natural) + is + Last : constant Natural := Buffer_Last + S'Length; + + begin + while Last > Buffer'Last loop + declare + New_Buffer : constant String_Access := + new String (1 .. 2 * Buffer'Last); + begin + New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last); + Free (Buffer); + Buffer := New_Buffer; + end; + end loop; + + Buffer (Buffer_Last + 1 .. Last) := S; + Buffer_Last := Last; + end Add_To_Buffer; + + ------------------------ + -- Add_To_Object_Path -- + ------------------------ + + procedure Add_To_Object_Path + (Object_Dir : Path_Name_Type; + Object_Paths : in out Object_Path_Table.Instance) + is + begin + -- Check if the directory is already in the table + + for Index in Object_Path_Table.First .. + Object_Path_Table.Last (Object_Paths) + loop + + -- If it is, remove it, and add it as the last one + + if Object_Paths.Table (Index) = Object_Dir then + for Index2 in Index + 1 .. + Object_Path_Table.Last (Object_Paths) + loop + Object_Paths.Table (Index2 - 1) := Object_Paths.Table (Index2); + end loop; + + Object_Paths.Table + (Object_Path_Table.Last (Object_Paths)) := Object_Dir; + return; + end if; + end loop; + + -- The directory is not already in the table, add it + + Object_Path_Table.Append (Object_Paths, Object_Dir); + end Add_To_Object_Path; + + ----------------- + -- Add_To_Path -- + ----------------- + + procedure Add_To_Path + (Source_Dirs : String_List_Id; + In_Tree : Project_Tree_Ref; + Buffer : in out String_Access; + Buffer_Last : in out Natural) + is + Current : String_List_Id := Source_Dirs; + Source_Dir : String_Element; + begin + while Current /= Nil_String loop + Source_Dir := In_Tree.String_Elements.Table (Current); + Add_To_Path (Get_Name_String (Source_Dir.Display_Value), + Buffer, Buffer_Last); + Current := Source_Dir.Next; + end loop; + end Add_To_Path; + + procedure Add_To_Path + (Dir : String; + Buffer : in out String_Access; + Buffer_Last : in out Natural) + is + Len : Natural; + New_Buffer : String_Access; + Min_Len : Natural; + + function Is_Present (Path : String; Dir : String) return Boolean; + -- Return True if Dir is part of Path + + ---------------- + -- Is_Present -- + ---------------- + + function Is_Present (Path : String; Dir : String) return Boolean is + Last : constant Integer := Path'Last - Dir'Length + 1; + + begin + for J in Path'First .. Last loop + + -- Note: the order of the conditions below is important, since + -- it ensures a minimal number of string comparisons. + + if (J = Path'First + or else Path (J - 1) = Path_Separator) + and then + (J + Dir'Length > Path'Last + or else Path (J + Dir'Length) = Path_Separator) + and then Dir = Path (J .. J + Dir'Length - 1) + then + return True; + end if; + end loop; + + return False; + end Is_Present; + + -- Start of processing for Add_To_Path + + begin + if Is_Present (Buffer (1 .. Buffer_Last), Dir) then + + -- Dir is already in the path, nothing to do + + return; + end if; + + Min_Len := Buffer_Last + Dir'Length; + + if Buffer_Last > 0 then + + -- Add 1 for the Path_Separator character + + Min_Len := Min_Len + 1; + end if; + + -- If Ada_Path_Buffer is too small, increase it + + Len := Buffer'Last; + + if Len < Min_Len then + loop + Len := Len * 2; + exit when Len >= Min_Len; + end loop; + + New_Buffer := new String (1 .. Len); + New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last); + Free (Buffer); + Buffer := New_Buffer; + end if; + + if Buffer_Last > 0 then + Buffer_Last := Buffer_Last + 1; + Buffer (Buffer_Last) := Path_Separator; + end if; + + Buffer (Buffer_Last + 1 .. Buffer_Last + Dir'Length) := Dir; + Buffer_Last := Buffer_Last + Dir'Length; + end Add_To_Path; + + ------------------------ + -- Add_To_Source_Path -- + ------------------------ + + procedure Add_To_Source_Path + (Source_Dirs : String_List_Id; + In_Tree : Project_Tree_Ref; + Source_Paths : in out Source_Path_Table.Instance) + is + Current : String_List_Id := Source_Dirs; + Source_Dir : String_Element; + Add_It : Boolean; + + begin + -- Add each source directory + + while Current /= Nil_String loop + Source_Dir := In_Tree.String_Elements.Table (Current); + Add_It := True; + + -- Check if the source directory is already in the table + + for Index in Source_Path_Table.First .. + Source_Path_Table.Last (Source_Paths) + loop + -- If it is already, no need to add it + + if Source_Paths.Table (Index) = Source_Dir.Value then + Add_It := False; + exit; + end if; + end loop; + + if Add_It then + Source_Path_Table.Append (Source_Paths, Source_Dir.Display_Value); + end if; + + -- Next source directory + + Current := Source_Dir.Next; + end loop; + end Add_To_Source_Path; + + -------------------------------- + -- Create_Config_Pragmas_File -- + -------------------------------- + + procedure Create_Config_Pragmas_File + (For_Project : Project_Id; + In_Tree : Project_Tree_Ref) + is + type Naming_Id is new Nat; + package Naming_Table is new GNAT.Dynamic_Tables + (Table_Component_Type => Lang_Naming_Data, + Table_Index_Type => Naming_Id, + Table_Low_Bound => 1, + Table_Initial => 5, + Table_Increment => 100); + Default_Naming : constant Naming_Id := Naming_Table.First; + Namings : Naming_Table.Instance; + -- Table storing the naming data for gnatmake/gprmake + + Buffer : String_Access := new String (1 .. Buffer_Initial); + Buffer_Last : Natural := 0; + + File_Name : Path_Name_Type := No_Path; + File : File_Descriptor := Invalid_FD; + + Current_Naming : Naming_Id; + Iter : Source_Iterator; + Source : Source_Id; + + procedure Check (Project : Project_Id; State : in out Integer); + -- Recursive procedure that put in the config pragmas file any non + -- standard naming schemes, if it is not already in the file, then call + -- itself for any imported project. + + procedure Put (Source : Source_Id); + -- Put an SFN pragma in the temporary file + + procedure Put (S : String); + procedure Put_Line (S : String); + -- Output procedures, analogous to normal Text_IO procs of same name. + -- The text is put in Buffer, then it will be written into a temporary + -- file with procedure Write_Temp_File below. + + procedure Write_Temp_File; + -- Create a temporary file and put the content of the buffer in it + + ----------- + -- Check -- + ----------- + + procedure Check (Project : Project_Id; State : in out Integer) is + pragma Unreferenced (State); + Lang : constant Language_Ptr := + Get_Language_From_Name (Project, "ada"); + Naming : Lang_Naming_Data; + + begin + if Current_Verbosity = High then + Write_Str ("Checking project file """); + Write_Str (Namet.Get_Name_String (Project.Name)); + Write_Str ("""."); + Write_Eol; + end if; + + if Lang = null then + if Current_Verbosity = High then + Write_Line (" Languages does not contain Ada, nothing to do"); + end if; + + return; + end if; + + Naming := Lang.Config.Naming_Data; + + -- Is the naming scheme of this project one that we know? + + Current_Naming := Default_Naming; + while Current_Naming <= Naming_Table.Last (Namings) + and then Namings.Table (Current_Naming).Dot_Replacement = + Naming.Dot_Replacement + and then Namings.Table (Current_Naming).Casing = + Naming.Casing + and then Namings.Table (Current_Naming).Separate_Suffix = + Naming.Separate_Suffix + loop + Current_Naming := Current_Naming + 1; + end loop; + + -- If we don't know it, add it + + if Current_Naming > Naming_Table.Last (Namings) then + Naming_Table.Increment_Last (Namings); + Namings.Table (Naming_Table.Last (Namings)) := Naming; + + -- Put the SFN pragmas for the naming scheme + + -- Spec + + Put_Line + ("pragma Source_File_Name_Project"); + Put_Line + (" (Spec_File_Name => ""*" & + Get_Name_String (Naming.Spec_Suffix) & ""","); + Put_Line + (" Casing => " & + Image (Naming.Casing) & ","); + Put_Line + (" Dot_Replacement => """ & + Get_Name_String (Naming.Dot_Replacement) & """);"); + + -- and body + + Put_Line + ("pragma Source_File_Name_Project"); + Put_Line + (" (Body_File_Name => ""*" & + Get_Name_String (Naming.Body_Suffix) & ""","); + Put_Line + (" Casing => " & + Image (Naming.Casing) & ","); + Put_Line + (" Dot_Replacement => """ & + Get_Name_String (Naming.Dot_Replacement) & + """);"); + + -- and maybe separate + + if Naming.Body_Suffix /= Naming.Separate_Suffix then + Put_Line ("pragma Source_File_Name_Project"); + Put_Line + (" (Subunit_File_Name => ""*" & + Get_Name_String (Naming.Separate_Suffix) & ""","); + Put_Line + (" Casing => " & + Image (Naming.Casing) & ","); + Put_Line + (" Dot_Replacement => """ & + Get_Name_String (Naming.Dot_Replacement) & + """);"); + end if; + end if; + end Check; + + --------- + -- Put -- + --------- + + procedure Put (Source : Source_Id) is + begin + -- Put the pragma SFN for the unit kind (spec or body) + + Put ("pragma Source_File_Name_Project ("); + Put (Namet.Get_Name_String (Source.Unit.Name)); + + if Source.Kind = Spec then + Put (", Spec_File_Name => """); + else + Put (", Body_File_Name => """); + end if; + + Put (Namet.Get_Name_String (Source.File)); + Put (""""); + + if Source.Index /= 0 then + Put (", Index =>"); + Put (Source.Index'Img); + end if; + + Put_Line (");"); + end Put; + + procedure Put (S : String) is + begin + Add_To_Buffer (S, Buffer, Buffer_Last); + + if Current_Verbosity = High then + Write_Str (S); + end if; + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (S : String) is + begin + -- Add an ASCII.LF to the string. As this config file is supposed to + -- be used only by the compiler, we don't care about the characters + -- for the end of line. In fact we could have put a space, but + -- it is more convenient to be able to read gnat.adc during + -- development, for which the ASCII.LF is fine. + + Put (S); + Put (S => (1 => ASCII.LF)); + end Put_Line; + + --------------------- + -- Write_Temp_File -- + --------------------- + + procedure Write_Temp_File is + Status : Boolean := False; + Last : Natural; + + begin + Tempdir.Create_Temp_File (File, File_Name); + + if File /= Invalid_FD then + Last := Write (File, Buffer (1)'Address, Buffer_Last); + + if Last = Buffer_Last then + Close (File, Status); + end if; + end if; + + if not Status then + Prj.Com.Fail ("unable to create temporary file"); + end if; + end Write_Temp_File; + + procedure Check_Imported_Projects is + new For_Every_Project_Imported (Integer, Check); + + Dummy : Integer := 0; + + -- Start of processing for Create_Config_Pragmas_File + + begin + if not For_Project.Config_Checked then + Naming_Table.Init (Namings); + + -- Check the naming schemes + + Check_Imported_Projects (For_Project, Dummy, Imported_First => False); + + -- Visit all the files and process those that need an SFN pragma + + Iter := For_Each_Source (In_Tree, For_Project); + while Element (Iter) /= No_Source loop + Source := Element (Iter); + + if Source.Index >= 1 + and then not Source.Locally_Removed + and then Source.Unit /= null + then + Put (Source); + end if; + + Next (Iter); + end loop; + + -- If there are no non standard naming scheme, issue the GNAT + -- standard naming scheme. This will tell the compiler that + -- a project file is used and will forbid any pragma SFN. + + if Buffer_Last = 0 then + + Put_Line ("pragma Source_File_Name_Project"); + Put_Line (" (Spec_File_Name => ""*.ads"","); + Put_Line (" Dot_Replacement => ""-"","); + Put_Line (" Casing => lowercase);"); + + Put_Line ("pragma Source_File_Name_Project"); + Put_Line (" (Body_File_Name => ""*.adb"","); + Put_Line (" Dot_Replacement => ""-"","); + Put_Line (" Casing => lowercase);"); + end if; + + -- Close the temporary file + + Write_Temp_File; + + if Opt.Verbose_Mode then + Write_Str ("Created configuration file """); + Write_Str (Get_Name_String (File_Name)); + Write_Line (""""); + end if; + + For_Project.Config_File_Name := File_Name; + For_Project.Config_File_Temp := True; + For_Project.Config_Checked := True; + end if; + + Free (Buffer); + end Create_Config_Pragmas_File; + + -------------------- + -- Create_Mapping -- + -------------------- + + procedure Create_Mapping (In_Tree : Project_Tree_Ref) is + Data : Source_Id; + Iter : Source_Iterator; + + begin + Fmap.Reset_Tables; + + Iter := For_Each_Source (In_Tree); + loop + Data := Element (Iter); + exit when Data = No_Source; + + if Data.Unit /= No_Unit_Index then + if Data.Locally_Removed then + Fmap.Add_Forbidden_File_Name (Data.File); + else + Fmap.Add_To_File_Map + (Unit_Name => Unit_Name_Type (Data.Unit.Name), + File_Name => Data.File, + Path_Name => File_Name_Type (Data.Path.Display_Name)); + end if; + end if; + + Next (Iter); + end loop; + end Create_Mapping; + + ------------------------- + -- Create_Mapping_File -- + ------------------------- + + procedure Create_Mapping_File + (Project : Project_Id; + Language : Name_Id; + In_Tree : Project_Tree_Ref; + Name : out Path_Name_Type) + is + File : File_Descriptor := Invalid_FD; + + Buffer : String_Access := new String (1 .. Buffer_Initial); + Buffer_Last : Natural := 0; + + procedure Put_Name_Buffer; + -- Put the line contained in the Name_Buffer in the global buffer + + procedure Process (Project : Project_Id; State : in out Integer); + -- Generate the mapping file for Project (not recursively) + + --------------------- + -- Put_Name_Buffer -- + --------------------- + + procedure Put_Name_Buffer is + begin + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ASCII.LF; + + if Current_Verbosity = High then + Write_Str ("Mapping file: " & Name_Buffer (1 .. Name_Len)); + end if; + + Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); + end Put_Name_Buffer; + + ------------- + -- Process -- + ------------- + + procedure Process (Project : Project_Id; State : in out Integer) is + pragma Unreferenced (State); + Source : Source_Id; + Suffix : File_Name_Type; + Iter : Source_Iterator; + + begin + Iter := For_Each_Source (In_Tree, Project, Language => Language); + + loop + Source := Prj.Element (Iter); + exit when Source = No_Source; + + if Source.Replaced_By = No_Source + and then Source.Path.Name /= No_Path + and then + (Source.Language.Config.Kind = File_Based + or else Source.Unit /= No_Unit_Index) + then + if Source.Unit /= No_Unit_Index then + Get_Name_String (Source.Unit.Name); + + if Source.Language.Config.Kind = Unit_Based then + + -- ??? Mapping_Spec_Suffix could be set in the case of + -- gnatmake as well + + Add_Char_To_Name_Buffer ('%'); + + if Source.Kind = Spec then + Add_Char_To_Name_Buffer ('s'); + else + Add_Char_To_Name_Buffer ('b'); + end if; + + else + case Source.Kind is + when Spec => + Suffix := + Source.Language.Config.Mapping_Spec_Suffix; + when Impl | Sep => + Suffix := + Source.Language.Config.Mapping_Body_Suffix; + end case; + + if Suffix /= No_File then + Add_Str_To_Name_Buffer + (Get_Name_String (Suffix)); + end if; + end if; + + Put_Name_Buffer; + end if; + + Get_Name_String (Source.Display_File); + Put_Name_Buffer; + + if Source.Locally_Removed then + Name_Len := 1; + Name_Buffer (1) := '/'; + else + Get_Name_String (Source.Path.Display_Name); + end if; + + Put_Name_Buffer; + end if; + + Next (Iter); + end loop; + end Process; + + procedure For_Every_Imported_Project is new + For_Every_Project_Imported (State => Integer, Action => Process); + + Dummy : Integer := 0; + + -- Start of processing for Create_Mapping_File + + begin + For_Every_Imported_Project (Project, Dummy); + + declare + Last : Natural; + Status : Boolean := False; + + begin + Create_Temp_File (In_Tree, File, Name, "mapping"); + + if File /= Invalid_FD then + Last := Write (File, Buffer (1)'Address, Buffer_Last); + + if Last = Buffer_Last then + GNAT.OS_Lib.Close (File, Status); + end if; + end if; + + if not Status then + Prj.Com.Fail ("could not write mapping file"); + end if; + end; + + Free (Buffer); + end Create_Mapping_File; + + ---------------------- + -- Create_Temp_File -- + ---------------------- + + procedure Create_Temp_File + (In_Tree : Project_Tree_Ref; + Path_FD : out File_Descriptor; + Path_Name : out Path_Name_Type; + File_Use : String) + is + begin + Tempdir.Create_Temp_File (Path_FD, Path_Name); + + if Path_Name /= No_Path then + if Current_Verbosity = High then + Write_Line ("Create temp file (" & File_Use & ") " + & Get_Name_String (Path_Name)); + end if; + + Record_Temp_File (In_Tree, Path_Name); + + else + Prj.Com.Fail + ("unable to create temporary " & File_Use & " file"); + end if; + end Create_Temp_File; + + -------------------------- + -- Create_New_Path_File -- + -------------------------- + + procedure Create_New_Path_File + (In_Tree : Project_Tree_Ref; + Path_FD : out File_Descriptor; + Path_Name : out Path_Name_Type) + is + begin + Create_Temp_File (In_Tree, Path_FD, Path_Name, "path file"); + end Create_New_Path_File; + + ------------------------------------ + -- File_Name_Of_Library_Unit_Body -- + ------------------------------------ + + function File_Name_Of_Library_Unit_Body + (Name : String; + Project : Project_Id; + In_Tree : Project_Tree_Ref; + Main_Project_Only : Boolean := True; + Full_Path : Boolean := False) return String + is + The_Project : Project_Id := Project; + Original_Name : String := Name; + + Lang : constant Language_Ptr := + Get_Language_From_Name (Project, "ada"); + + Unit : Unit_Index; + The_Original_Name : Name_Id; + The_Spec_Name : Name_Id; + The_Body_Name : Name_Id; + + begin + -- ??? Same block in Project_Of + Canonical_Case_File_Name (Original_Name); + Name_Len := Original_Name'Length; + Name_Buffer (1 .. Name_Len) := Original_Name; + The_Original_Name := Name_Find; + + if Lang /= null then + declare + Naming : constant Lang_Naming_Data := Lang.Config.Naming_Data; + Extended_Spec_Name : String := + Name & Namet.Get_Name_String + (Naming.Spec_Suffix); + Extended_Body_Name : String := + Name & Namet.Get_Name_String + (Naming.Body_Suffix); + + begin + Canonical_Case_File_Name (Extended_Spec_Name); + Name_Len := Extended_Spec_Name'Length; + Name_Buffer (1 .. Name_Len) := Extended_Spec_Name; + The_Spec_Name := Name_Find; + + Canonical_Case_File_Name (Extended_Body_Name); + Name_Len := Extended_Body_Name'Length; + Name_Buffer (1 .. Name_Len) := Extended_Body_Name; + The_Body_Name := Name_Find; + end; + + else + Name_Len := Name'Length; + Name_Buffer (1 .. Name_Len) := Name; + Canonical_Case_File_Name (Name_Buffer); + The_Spec_Name := Name_Find; + The_Body_Name := The_Spec_Name; + end if; + + if Current_Verbosity = High then + Write_Str ("Looking for file name of """); + Write_Str (Name); + Write_Char ('"'); + Write_Eol; + Write_Str (" Extended Spec Name = """); + Write_Str (Get_Name_String (The_Spec_Name)); + Write_Char ('"'); + Write_Eol; + Write_Str (" Extended Body Name = """); + Write_Str (Get_Name_String (The_Body_Name)); + Write_Char ('"'); + Write_Eol; + end if; + + -- For extending project, search in the extended project if the source + -- is not found. For non extending projects, this loop will be run only + -- once. + + loop + -- Loop through units + + Unit := Units_Htable.Get_First (In_Tree.Units_HT); + while Unit /= null loop + -- Check for body + + if not Main_Project_Only + or else + (Unit.File_Names (Impl) /= null + and then Unit.File_Names (Impl).Project = The_Project) + then + declare + Current_Name : File_Name_Type; + begin + -- Case of a body present + + if Unit.File_Names (Impl) /= null then + Current_Name := Unit.File_Names (Impl).File; + + if Current_Verbosity = High then + Write_Str (" Comparing with """); + Write_Str (Get_Name_String (Current_Name)); + Write_Char ('"'); + Write_Eol; + end if; + + -- If it has the name of the original name, return the + -- original name. + + if Unit.Name = The_Original_Name + or else + Current_Name = File_Name_Type (The_Original_Name) + then + if Current_Verbosity = High then + Write_Line (" OK"); + end if; + + if Full_Path then + return Get_Name_String + (Unit.File_Names (Impl).Path.Name); + + else + return Get_Name_String (Current_Name); + end if; + + -- If it has the name of the extended body name, + -- return the extended body name + + elsif Current_Name = File_Name_Type (The_Body_Name) then + if Current_Verbosity = High then + Write_Line (" OK"); + end if; + + if Full_Path then + return Get_Name_String + (Unit.File_Names (Impl).Path.Name); + + else + return Get_Name_String (The_Body_Name); + end if; + + else + if Current_Verbosity = High then + Write_Line (" not good"); + end if; + end if; + end if; + end; + end if; + + -- Check for spec + + if not Main_Project_Only + or else + (Unit.File_Names (Spec) /= null + and then Unit.File_Names (Spec).Project = + The_Project) + then + declare + Current_Name : File_Name_Type; + + begin + -- Case of spec present + + if Unit.File_Names (Spec) /= null then + Current_Name := Unit.File_Names (Spec).File; + if Current_Verbosity = High then + Write_Str (" Comparing with """); + Write_Str (Get_Name_String (Current_Name)); + Write_Char ('"'); + Write_Eol; + end if; + + -- If name same as original name, return original name + + if Unit.Name = The_Original_Name + or else + Current_Name = File_Name_Type (The_Original_Name) + then + if Current_Verbosity = High then + Write_Line (" OK"); + end if; + + if Full_Path then + return Get_Name_String + (Unit.File_Names (Spec).Path.Name); + else + return Get_Name_String (Current_Name); + end if; + + -- If it has the same name as the extended spec name, + -- return the extended spec name. + + elsif Current_Name = File_Name_Type (The_Spec_Name) then + if Current_Verbosity = High then + Write_Line (" OK"); + end if; + + if Full_Path then + return Get_Name_String + (Unit.File_Names (Spec).Path.Name); + else + return Get_Name_String (The_Spec_Name); + end if; + + else + if Current_Verbosity = High then + Write_Line (" not good"); + end if; + end if; + end if; + end; + end if; + + Unit := Units_Htable.Get_Next (In_Tree.Units_HT); + end loop; + + -- If we are not in an extending project, give up + + exit when not Main_Project_Only + or else The_Project.Extends = No_Project; + + -- Otherwise, look in the project we are extending + + The_Project := The_Project.Extends; + end loop; + + -- We don't know this file name, return an empty string + + return ""; + end File_Name_Of_Library_Unit_Body; + + ------------------------- + -- For_All_Object_Dirs -- + ------------------------- + + procedure For_All_Object_Dirs (Project : Project_Id) is + procedure For_Project (Prj : Project_Id; Dummy : in out Integer); + -- Get all object directories of Prj + + ----------------- + -- For_Project -- + ----------------- + + procedure For_Project (Prj : Project_Id; Dummy : in out Integer) is + pragma Unreferenced (Dummy); + begin + -- ??? Set_Ada_Paths has a different behavior for library project + -- files, should we have the same ? + + if Prj.Object_Directory /= No_Path_Information then + Get_Name_String (Prj.Object_Directory.Display_Name); + Action (Name_Buffer (1 .. Name_Len)); + end if; + end For_Project; + + procedure Get_Object_Dirs is + new For_Every_Project_Imported (Integer, For_Project); + Dummy : Integer := 1; + + -- Start of processing for For_All_Object_Dirs + + begin + Get_Object_Dirs (Project, Dummy); + end For_All_Object_Dirs; + + ------------------------- + -- For_All_Source_Dirs -- + ------------------------- + + procedure For_All_Source_Dirs + (Project : Project_Id; + In_Tree : Project_Tree_Ref) + is + procedure For_Project (Prj : Project_Id; Dummy : in out Integer); + -- Get all object directories of Prj + + ----------------- + -- For_Project -- + ----------------- + + procedure For_Project (Prj : Project_Id; Dummy : in out Integer) is + pragma Unreferenced (Dummy); + Current : String_List_Id := Prj.Source_Dirs; + The_String : String_Element; + + begin + -- If there are Ada sources, call action with the name of every + -- source directory. + + if Has_Ada_Sources (Project) then + while Current /= Nil_String loop + The_String := In_Tree.String_Elements.Table (Current); + Action (Get_Name_String (The_String.Display_Value)); + Current := The_String.Next; + end loop; + end if; + end For_Project; + + procedure Get_Source_Dirs is + new For_Every_Project_Imported (Integer, For_Project); + Dummy : Integer := 1; + + -- Start of processing for For_All_Source_Dirs + + begin + Get_Source_Dirs (Project, Dummy); + end For_All_Source_Dirs; + + ------------------- + -- Get_Reference -- + ------------------- + + procedure Get_Reference + (Source_File_Name : String; + In_Tree : Project_Tree_Ref; + Project : out Project_Id; + Path : out Path_Name_Type) + is + begin + -- Body below could use some comments ??? + + if Current_Verbosity > Default then + Write_Str ("Getting Reference_Of ("""); + Write_Str (Source_File_Name); + Write_Str (""") ... "); + end if; + + declare + Original_Name : String := Source_File_Name; + Unit : Unit_Index; + + begin + Canonical_Case_File_Name (Original_Name); + Unit := Units_Htable.Get_First (In_Tree.Units_HT); + + while Unit /= null loop + if Unit.File_Names (Spec) /= null + and then Unit.File_Names (Spec).File /= No_File + and then + (Namet.Get_Name_String + (Unit.File_Names (Spec).File) = Original_Name + or else (Unit.File_Names (Spec).Path /= + No_Path_Information + and then + Namet.Get_Name_String + (Unit.File_Names (Spec).Path.Name) = + Original_Name)) + then + Project := Ultimate_Extension_Of + (Project => Unit.File_Names (Spec).Project); + Path := Unit.File_Names (Spec).Path.Display_Name; + + if Current_Verbosity > Default then + Write_Str ("Done: Spec."); + Write_Eol; + end if; + + return; + + elsif Unit.File_Names (Impl) /= null + and then Unit.File_Names (Impl).File /= No_File + and then + (Namet.Get_Name_String + (Unit.File_Names (Impl).File) = Original_Name + or else (Unit.File_Names (Impl).Path /= + No_Path_Information + and then Namet.Get_Name_String + (Unit.File_Names (Impl).Path.Name) = + Original_Name)) + then + Project := Ultimate_Extension_Of + (Project => Unit.File_Names (Impl).Project); + Path := Unit.File_Names (Impl).Path.Display_Name; + + if Current_Verbosity > Default then + Write_Str ("Done: Body."); + Write_Eol; + end if; + + return; + end if; + + Unit := Units_Htable.Get_Next (In_Tree.Units_HT); + end loop; + end; + + Project := No_Project; + Path := No_Path; + + if Current_Verbosity > Default then + Write_Str ("Cannot be found."); + Write_Eol; + end if; + end Get_Reference; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (In_Tree : Project_Tree_Ref) is + begin + In_Tree.Private_Part.Current_Source_Path_File := No_Path; + In_Tree.Private_Part.Current_Object_Path_File := No_Path; + end Initialize; + + ------------------- + -- Print_Sources -- + ------------------- + + -- Could use some comments in this body ??? + + procedure Print_Sources (In_Tree : Project_Tree_Ref) is + Unit : Unit_Index; + + begin + Write_Line ("List of Sources:"); + + Unit := Units_Htable.Get_First (In_Tree.Units_HT); + + while Unit /= No_Unit_Index loop + Write_Str (" "); + Write_Line (Namet.Get_Name_String (Unit.Name)); + + if Unit.File_Names (Spec).File /= No_File then + if Unit.File_Names (Spec).Project = No_Project then + Write_Line (" No project"); + + else + Write_Str (" Project: "); + Get_Name_String + (Unit.File_Names (Spec).Project.Path.Name); + Write_Line (Name_Buffer (1 .. Name_Len)); + end if; + + Write_Str (" spec: "); + Write_Line + (Namet.Get_Name_String + (Unit.File_Names (Spec).File)); + end if; + + if Unit.File_Names (Impl).File /= No_File then + if Unit.File_Names (Impl).Project = No_Project then + Write_Line (" No project"); + + else + Write_Str (" Project: "); + Get_Name_String + (Unit.File_Names (Impl).Project.Path.Name); + Write_Line (Name_Buffer (1 .. Name_Len)); + end if; + + Write_Str (" body: "); + Write_Line + (Namet.Get_Name_String (Unit.File_Names (Impl).File)); + end if; + + Unit := Units_Htable.Get_Next (In_Tree.Units_HT); + end loop; + + Write_Line ("end of List of Sources."); + end Print_Sources; + + ---------------- + -- Project_Of -- + ---------------- + + function Project_Of + (Name : String; + Main_Project : Project_Id; + In_Tree : Project_Tree_Ref) return Project_Id + is + Result : Project_Id := No_Project; + + Original_Name : String := Name; + + Lang : constant Language_Ptr := + Get_Language_From_Name (Main_Project, "ada"); + + Unit : Unit_Index; + + Current_Name : File_Name_Type; + The_Original_Name : File_Name_Type; + The_Spec_Name : File_Name_Type; + The_Body_Name : File_Name_Type; + + begin + -- ??? Same block in File_Name_Of_Library_Unit_Body + Canonical_Case_File_Name (Original_Name); + Name_Len := Original_Name'Length; + Name_Buffer (1 .. Name_Len) := Original_Name; + The_Original_Name := Name_Find; + + if Lang /= null then + declare + Naming : Lang_Naming_Data renames Lang.Config.Naming_Data; + Extended_Spec_Name : String := + Name & Namet.Get_Name_String + (Naming.Spec_Suffix); + Extended_Body_Name : String := + Name & Namet.Get_Name_String + (Naming.Body_Suffix); + + begin + Canonical_Case_File_Name (Extended_Spec_Name); + Name_Len := Extended_Spec_Name'Length; + Name_Buffer (1 .. Name_Len) := Extended_Spec_Name; + The_Spec_Name := Name_Find; + + Canonical_Case_File_Name (Extended_Body_Name); + Name_Len := Extended_Body_Name'Length; + Name_Buffer (1 .. Name_Len) := Extended_Body_Name; + The_Body_Name := Name_Find; + end; + + else + The_Spec_Name := The_Original_Name; + The_Body_Name := The_Original_Name; + end if; + + Unit := Units_Htable.Get_First (In_Tree.Units_HT); + while Unit /= null loop + + -- Case of a body present + + if Unit.File_Names (Impl) /= null then + Current_Name := Unit.File_Names (Impl).File; + + -- If it has the name of the original name or the body name, + -- we have found the project. + + if Unit.Name = Name_Id (The_Original_Name) + or else Current_Name = The_Original_Name + or else Current_Name = The_Body_Name + then + Result := Unit.File_Names (Impl).Project; + exit; + end if; + end if; + + -- Check for spec + + if Unit.File_Names (Spec) /= null then + Current_Name := Unit.File_Names (Spec).File; + + -- If name same as the original name, or the spec name, we have + -- found the project. + + if Unit.Name = Name_Id (The_Original_Name) + or else Current_Name = The_Original_Name + or else Current_Name = The_Spec_Name + then + Result := Unit.File_Names (Spec).Project; + exit; + end if; + end if; + + Unit := Units_Htable.Get_Next (In_Tree.Units_HT); + end loop; + + -- Get the ultimate extending project + + if Result /= No_Project then + while Result.Extended_By /= No_Project loop + Result := Result.Extended_By; + end loop; + end if; + + return Result; + end Project_Of; + + ------------------- + -- Set_Ada_Paths -- + ------------------- + + procedure Set_Ada_Paths + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Including_Libraries : Boolean; + Include_Path : Boolean := True; + Objects_Path : Boolean := True) + + is + Source_Paths : Source_Path_Table.Instance; + Object_Paths : Object_Path_Table.Instance; + -- List of source or object dirs. Only computed the first time this + -- procedure is called (since Source_FD is then reused) + + Source_FD : File_Descriptor := Invalid_FD; + Object_FD : File_Descriptor := Invalid_FD; + -- The temporary files to store the paths. These are only created the + -- first time this procedure is called, and reused from then on. + + Process_Source_Dirs : Boolean := False; + Process_Object_Dirs : Boolean := False; + + Status : Boolean; + -- For calls to Close + + Last : Natural; + Buffer : String_Access := new String (1 .. Buffer_Initial); + Buffer_Last : Natural := 0; + + procedure Recursive_Add (Project : Project_Id; Dummy : in out Boolean); + -- Recursive procedure to add the source/object paths of extended/ + -- imported projects. + + ------------------- + -- Recursive_Add -- + ------------------- + + procedure Recursive_Add (Project : Project_Id; Dummy : in out Boolean) is + pragma Unreferenced (Dummy); + + Path : Path_Name_Type; + + begin + -- ??? This is almost the equivalent of For_All_Source_Dirs + + if Process_Source_Dirs then + + -- Add to path all source directories of this project if there are + -- Ada sources. + + if Has_Ada_Sources (Project) then + Add_To_Source_Path (Project.Source_Dirs, In_Tree, Source_Paths); + end if; + end if; + + if Process_Object_Dirs then + Path := Get_Object_Directory + (Project, + Including_Libraries => Including_Libraries, + Only_If_Ada => True); + + if Path /= No_Path then + Add_To_Object_Path (Path, Object_Paths); + end if; + end if; + end Recursive_Add; + + procedure For_All_Projects is + new For_Every_Project_Imported (Boolean, Recursive_Add); + + Dummy : Boolean := False; + + -- Start of processing for Set_Ada_Paths + + begin + -- If it is the first time we call this procedure for this project, + -- compute the source path and/or the object path. + + if Include_Path and then Project.Include_Path_File = No_Path then + Source_Path_Table.Init (Source_Paths); + Process_Source_Dirs := True; + Create_New_Path_File + (In_Tree, Source_FD, Project.Include_Path_File); + end if; + + -- For the object path, we make a distinction depending on + -- Including_Libraries. + + if Objects_Path and Including_Libraries then + if Project.Objects_Path_File_With_Libs = No_Path then + Object_Path_Table.Init (Object_Paths); + Process_Object_Dirs := True; + Create_New_Path_File + (In_Tree, Object_FD, Project.Objects_Path_File_With_Libs); + end if; + + elsif Objects_Path then + if Project.Objects_Path_File_Without_Libs = No_Path then + Object_Path_Table.Init (Object_Paths); + Process_Object_Dirs := True; + Create_New_Path_File + (In_Tree, Object_FD, Project.Objects_Path_File_Without_Libs); + end if; + end if; + + -- If there is something to do, set Seen to False for all projects, + -- then call the recursive procedure Add for Project. + + if Process_Source_Dirs or Process_Object_Dirs then + For_All_Projects (Project, Dummy); + end if; + + -- Write and close any file that has been created. Source_FD is not set + -- when this subprogram is called a second time or more, since we reuse + -- the previous version of the file. + + if Source_FD /= Invalid_FD then + Buffer_Last := 0; + + for Index in Source_Path_Table.First .. + Source_Path_Table.Last (Source_Paths) + loop + Get_Name_String (Source_Paths.Table (Index)); + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ASCII.LF; + Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); + end loop; + + Last := Write (Source_FD, Buffer (1)'Address, Buffer_Last); + + if Last = Buffer_Last then + Close (Source_FD, Status); + + else + Status := False; + end if; + + if not Status then + Prj.Com.Fail ("could not write temporary file"); + end if; + end if; + + if Object_FD /= Invalid_FD then + Buffer_Last := 0; + + for Index in Object_Path_Table.First .. + Object_Path_Table.Last (Object_Paths) + loop + Get_Name_String (Object_Paths.Table (Index)); + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ASCII.LF; + Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); + end loop; + + Last := Write (Object_FD, Buffer (1)'Address, Buffer_Last); + + if Last = Buffer_Last then + Close (Object_FD, Status); + else + Status := False; + end if; + + if not Status then + Prj.Com.Fail ("could not write temporary file"); + end if; + end if; + + -- Set the env vars, if they need to be changed, and set the + -- corresponding flags. + + if Include_Path and then + In_Tree.Private_Part.Current_Source_Path_File /= + Project.Include_Path_File + then + In_Tree.Private_Part.Current_Source_Path_File := + Project.Include_Path_File; + Set_Path_File_Var + (Project_Include_Path_File, + Get_Name_String (In_Tree.Private_Part.Current_Source_Path_File)); + end if; + + if Objects_Path then + if Including_Libraries then + if In_Tree.Private_Part.Current_Object_Path_File /= + Project.Objects_Path_File_With_Libs + then + In_Tree.Private_Part.Current_Object_Path_File := + Project.Objects_Path_File_With_Libs; + Set_Path_File_Var + (Project_Objects_Path_File, + Get_Name_String + (In_Tree.Private_Part.Current_Object_Path_File)); + end if; + + else + if In_Tree.Private_Part.Current_Object_Path_File /= + Project.Objects_Path_File_Without_Libs + then + In_Tree.Private_Part.Current_Object_Path_File := + Project.Objects_Path_File_Without_Libs; + Set_Path_File_Var + (Project_Objects_Path_File, + Get_Name_String + (In_Tree.Private_Part.Current_Object_Path_File)); + end if; + end if; + end if; + + Free (Buffer); + end Set_Ada_Paths; + + ----------------------- + -- Set_Path_File_Var -- + ----------------------- + + procedure Set_Path_File_Var (Name : String; Value : String) is + Host_Spec : String_Access := To_Host_File_Spec (Value); + begin + if Host_Spec = null then + Prj.Com.Fail + ("could not convert file name """ & Value & """ to host spec"); + else + Setenv (Name, Host_Spec.all); + Free (Host_Spec); + end if; + end Set_Path_File_Var; + + --------------------------- + -- Ultimate_Extension_Of -- + --------------------------- + + function Ultimate_Extension_Of + (Project : Project_Id) return Project_Id + is + Result : Project_Id; + + begin + Result := Project; + while Result.Extended_By /= No_Project loop + Result := Result.Extended_By; + end loop; + + return Result; + end Ultimate_Extension_Of; + + --------------------- + -- Add_Directories -- + --------------------- + + procedure Add_Directories + (Self : in out Project_Search_Path; + Path : String) + is + Tmp : String_Access; + begin + if Self.Path = null then + Self.Path := new String'(Uninitialized_Prefix & Path); + else + Tmp := Self.Path; + Self.Path := new String'(Tmp.all & Path_Separator & Path); + Free (Tmp); + end if; + end Add_Directories; + + ----------------------------- + -- Initialize_Project_Path -- + ----------------------------- + + procedure Initialize_Project_Path + (Self : in out Project_Search_Path; + Target_Name : String) + is + Add_Default_Dir : Boolean := True; + First : Positive; + Last : Positive; + New_Len : Positive; + New_Last : Positive; + + Ada_Project_Path : constant String := "ADA_PROJECT_PATH"; + Gpr_Project_Path : constant String := "GPR_PROJECT_PATH"; + -- Name of alternate env. variable that contain path name(s) of + -- directories where project files may reside. GPR_PROJECT_PATH has + -- precedence over ADA_PROJECT_PATH. + + Gpr_Prj_Path : String_Access; + Ada_Prj_Path : String_Access; + -- The path name(s) of directories where project files may reside. + -- May be empty. + + begin + -- If already initialized, nothing else to do + + if Self.Path /= null + and then Self.Path (Self.Path'First) /= '#' + then + return; + end if; + + -- The current directory is always first in the search path. Since the + -- Project_Path currently starts with '#:' as a sign that it isn't + -- initialized, we simply replace '#' with '.' + + if Self.Path = null then + Self.Path := new String'('.' & Path_Separator); + else + Self.Path (Self.Path'First) := '.'; + end if; + + -- Then the reset of the project path (if any) currently contains the + -- directories added through Add_Search_Project_Directory + + -- If environment variables are defined and not empty, add their content + + Gpr_Prj_Path := Getenv (Gpr_Project_Path); + Ada_Prj_Path := Getenv (Ada_Project_Path); + + if Gpr_Prj_Path.all /= "" then + Add_Directories (Self, Gpr_Prj_Path.all); + end if; + + Free (Gpr_Prj_Path); + + if Ada_Prj_Path.all /= "" then + Add_Directories (Self, Ada_Prj_Path.all); + end if; + + Free (Ada_Prj_Path); + + -- Copy to Name_Buffer, since we will need to manipulate the path + + Name_Len := Self.Path'Length; + Name_Buffer (1 .. Name_Len) := Self.Path.all; + + -- Scan the directory path to see if "-" is one of the directories. + -- Remove each occurrence of "-" and set Add_Default_Dir to False. + -- Also resolve relative paths and symbolic links. + + First := 3; + loop + while First <= Name_Len + and then (Name_Buffer (First) = Path_Separator) + loop + First := First + 1; + end loop; + + exit when First > Name_Len; + + Last := First; + + while Last < Name_Len + and then Name_Buffer (Last + 1) /= Path_Separator + loop + Last := Last + 1; + end loop; + + -- If the directory is "-", set Add_Default_Dir to False and + -- remove from path. + + if Name_Buffer (First .. Last) = No_Project_Default_Dir then + Add_Default_Dir := False; + + for J in Last + 1 .. Name_Len loop + Name_Buffer (J - No_Project_Default_Dir'Length - 1) := + Name_Buffer (J); + end loop; + + Name_Len := Name_Len - No_Project_Default_Dir'Length - 1; + + -- After removing the '-', go back one character to get the next + -- directory correctly. + + Last := Last - 1; + + elsif not Hostparm.OpenVMS + or else not Is_Absolute_Path (Name_Buffer (First .. Last)) + then + -- On VMS, only expand relative path names, as absolute paths + -- may correspond to multi-valued VMS logical names. + + declare + New_Dir : constant String := + Normalize_Pathname + (Name_Buffer (First .. Last), + Resolve_Links => Opt.Follow_Links_For_Dirs); + + begin + -- If the absolute path was resolved and is different from + -- the original, replace original with the resolved path. + + if New_Dir /= Name_Buffer (First .. Last) + and then New_Dir'Length /= 0 + then + New_Len := Name_Len + New_Dir'Length - (Last - First + 1); + New_Last := First + New_Dir'Length - 1; + Name_Buffer (New_Last + 1 .. New_Len) := + Name_Buffer (Last + 1 .. Name_Len); + Name_Buffer (First .. New_Last) := New_Dir; + Name_Len := New_Len; + Last := New_Last; + end if; + end; + end if; + + First := Last + 1; + end loop; + + Free (Self.Path); + + -- Set the initial value of Current_Project_Path + + if Add_Default_Dir then + declare + Prefix : String_Ptr := Sdefault.Search_Dir_Prefix; + + begin + if Prefix = null then + Prefix := new String'(Executable_Prefix_Path); + + if Prefix.all /= "" then + if Target_Name /= "" then + Add_Str_To_Name_Buffer + (Path_Separator & Prefix.all & + "lib" & Directory_Separator & "gpr" & + Directory_Separator & Target_Name); + end if; + + Add_Str_To_Name_Buffer + (Path_Separator & Prefix.all & + "share" & Directory_Separator & "gpr"); + Add_Str_To_Name_Buffer + (Path_Separator & Prefix.all & + "lib" & Directory_Separator & "gnat"); + end if; + + else + Self.Path := + new String'(Name_Buffer (1 .. Name_Len) & Path_Separator & + Prefix.all & + ".." & Directory_Separator & + ".." & Directory_Separator & + ".." & Directory_Separator & "gnat"); + end if; + + Free (Prefix); + end; + end if; + + if Self.Path = null then + Self.Path := new String'(Name_Buffer (1 .. Name_Len)); + end if; + end Initialize_Project_Path; + + -------------- + -- Get_Path -- + -------------- + + procedure Get_Path + (Self : in out Project_Search_Path; + Path : out String_Access) + is + begin + Initialize_Project_Path (Self, ""); -- ??? Target_Name unspecified + Path := Self.Path; + end Get_Path; + + -------------- + -- Set_Path -- + -------------- + + procedure Set_Path + (Self : in out Project_Search_Path; Path : String) is + begin + Free (Self.Path); + Self.Path := new String'(Path); + Projects_Paths.Reset (Self.Cache); + end Set_Path; + + ------------------ + -- Find_Project -- + ------------------ + + procedure Find_Project + (Self : in out Project_Search_Path; + Project_File_Name : String; + Directory : String; + Path : out Namet.Path_Name_Type) + is + File : constant String := Project_File_Name; + -- Have to do a copy, in case the parameter is Name_Buffer, which we + -- modify below + + function Try_Path_Name (Path : String) return String_Access; + pragma Inline (Try_Path_Name); + -- Try the specified Path + + ------------------- + -- Try_Path_Name -- + ------------------- + + function Try_Path_Name (Path : String) return String_Access is + First : Natural; + Last : Natural; + Result : String_Access := null; + + begin + if Current_Verbosity = High then + Write_Str (" Trying "); + Write_Line (Path); + end if; + + if Is_Absolute_Path (Path) then + if Is_Regular_File (Path) then + Result := new String'(Path); + end if; + + else + -- Because we don't want to resolve symbolic links, we cannot use + -- Locate_Regular_File. So, we try each possible path + -- successively. + + First := Self.Path'First; + while First <= Self.Path'Last loop + while First <= Self.Path'Last + and then Self.Path (First) = Path_Separator + loop + First := First + 1; + end loop; + + exit when First > Self.Path'Last; + + Last := First; + while Last < Self.Path'Last + and then Self.Path (Last + 1) /= Path_Separator + loop + Last := Last + 1; + end loop; + + Name_Len := 0; + + if not Is_Absolute_Path (Self.Path (First .. Last)) then + Add_Str_To_Name_Buffer (Get_Current_Dir); -- ??? System call + Add_Char_To_Name_Buffer (Directory_Separator); + end if; + + Add_Str_To_Name_Buffer (Self.Path (First .. Last)); + Add_Char_To_Name_Buffer (Directory_Separator); + Add_Str_To_Name_Buffer (Path); + + if Current_Verbosity = High then + Write_Str (" Testing file "); + Write_Line (Name_Buffer (1 .. Name_Len)); + end if; + + if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then + Result := new String'(Name_Buffer (1 .. Name_Len)); + exit; + end if; + + First := Last + 1; + end loop; + end if; + + return Result; + end Try_Path_Name; + + -- Local Declarations + + Result : String_Access; + Has_Dot : Boolean := False; + Key : Name_Id; + + -- Start of processing for Find_Project + + begin + Initialize_Project_Path (Self, ""); + + if Current_Verbosity = High then + Write_Str ("Searching for project ("""); + Write_Str (File); + Write_Str (""", """); + Write_Str (Directory); + Write_Line (""");"); + end if; + + -- Check the project cache + + Name_Len := File'Length; + Name_Buffer (1 .. Name_Len) := File; + Key := Name_Find; + Path := Projects_Paths.Get (Self.Cache, Key); + + if Path /= No_Path then + return; + end if; + + -- Check if File contains an extension (a dot before a + -- directory separator). If it is the case we do not try project file + -- with an added extension as it is not possible to have multiple dots + -- on a project file name. + + Check_Dot : for K in reverse File'Range loop + if File (K) = '.' then + Has_Dot := True; + exit Check_Dot; + end if; + + exit Check_Dot when File (K) = Directory_Separator + or else File (K) = '/'; + end loop Check_Dot; + + if not Is_Absolute_Path (File) then + + -- First we try /. + + if not Has_Dot then + Result := Try_Path_Name + (Directory & Directory_Separator & + File & Project_File_Extension); + end if; + + -- Then we try / + + if Result = null then + Result := Try_Path_Name (Directory & Directory_Separator & File); + end if; + end if; + + -- Then we try . + + if Result = null and then not Has_Dot then + Result := Try_Path_Name (File & Project_File_Extension); + end if; + + -- Then we try + + if Result = null then + Result := Try_Path_Name (File); + end if; + + -- If we cannot find the project file, we return an empty string + + if Result = null then + Path := Namet.No_Path; + return; + + else + declare + Final_Result : constant String := + GNAT.OS_Lib.Normalize_Pathname + (Result.all, + Directory => Directory, + Resolve_Links => Opt.Follow_Links_For_Files, + Case_Sensitive => True); + begin + Free (Result); + Name_Len := Final_Result'Length; + Name_Buffer (1 .. Name_Len) := Final_Result; + Path := Name_Find; + Projects_Paths.Set (Self.Cache, Key, Path); + end; + end if; + end Find_Project; + + ---------- + -- Free -- + ---------- + + procedure Free (Self : in out Project_Search_Path) is + begin + Free (Self.Path); + Projects_Paths.Reset (Self.Cache); + end Free; + +end Prj.Env; diff --git a/gcc/ada/prj-env.ads b/gcc/ada/prj-env.ads new file mode 100644 index 000000000..c75002368 --- /dev/null +++ b/gcc/ada/prj-env.ads @@ -0,0 +1,227 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . E N V -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package implements services for Project-aware tools, mostly related +-- to the environment (configuration pragma files, path files, mapping files). + +with GNAT.Dynamic_HTables; +with GNAT.OS_Lib; + +package Prj.Env is + + procedure Initialize (In_Tree : Project_Tree_Ref); + -- Initialize global components relative to environment variables + + procedure Print_Sources (In_Tree : Project_Tree_Ref); + -- Output the list of sources, after Project files have been scanned + + procedure Create_Mapping (In_Tree : Project_Tree_Ref); + -- Create in memory mapping from the sources of all the projects (in body + -- of package Fmap), so that Osint.Find_File will find the correct path + -- corresponding to a source. + + procedure Create_Temp_File + (In_Tree : Project_Tree_Ref; + Path_FD : out File_Descriptor; + Path_Name : out Path_Name_Type; + File_Use : String); + -- Create temporary file, and fail with an error if it could not be created + + procedure Create_Mapping_File + (Project : Project_Id; + Language : Name_Id; + In_Tree : Project_Tree_Ref; + Name : out Path_Name_Type); + -- Create a temporary mapping file for project Project. For each source or + -- template of Language in the Project, put the mapping of its file + -- name and path name in this file. + -- + -- Implementation note: we pass a language name, not a language_index here, + -- since the latter would have to match exactly the index of that language + -- for the specified project, and that is not information available in + -- buildgpr.adb. + -- + -- See fmap for a description of the format of the mapping file + + procedure Create_Config_Pragmas_File + (For_Project : Project_Id; + In_Tree : Project_Tree_Ref); + -- If there needs to have SFN pragmas, either for non standard naming + -- schemes or for individual units. + + procedure Create_New_Path_File + (In_Tree : Project_Tree_Ref; + Path_FD : out File_Descriptor; + Path_Name : out Path_Name_Type); + -- Create a new temporary path file. Get the file name in Path_Name. + + function Ada_Include_Path + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Recursive : Boolean := False) return String; + -- Get the source search path of a Project file. If Recursive it True, get + -- all the source directories of the imported and modified project files + -- (recursively). If Recursive is False, just get the path for the source + -- directories of Project. Note: the resulting String may be empty if there + -- is no source directory in the project file. + + function Ada_Objects_Path + (Project : Project_Id; + Including_Libraries : Boolean := True) return String_Access; + -- Get the ADA_OBJECTS_PATH of a Project file. For the first call, compute + -- it and cache it. When Including_Libraries is False, do not include the + -- object directories of the library projects, and do not cache the result. + + procedure Set_Ada_Paths + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Including_Libraries : Boolean; + Include_Path : Boolean := True; + Objects_Path : Boolean := True); + -- Set the environment variables for additional project path files, after + -- creating the path files if necessary. + + function File_Name_Of_Library_Unit_Body + (Name : String; + Project : Project_Id; + In_Tree : Project_Tree_Ref; + Main_Project_Only : Boolean := True; + Full_Path : Boolean := False) return String; + -- Returns the file name of a library unit, in canonical case. Name may or + -- may not have an extension (corresponding to the naming scheme of the + -- project). If there is no body with this name, but there is a spec, the + -- name of the spec is returned. + -- + -- If Full_Path is False (the default), the simple file name is returned. + -- + -- If Full_Path is True, the absolute path name is returned. + -- + -- If neither a body nor a spec can be found, an empty string is returned. + -- If Main_Project_Only is True, the unit must be an immediate source of + -- Project. If it is False, it may be a source of one of its imported + -- projects. + + function Project_Of + (Name : String; + Main_Project : Project_Id; + In_Tree : Project_Tree_Ref) return Project_Id; + -- Get the project of a source. The source file name may be truncated + -- (".adb" or ".ads" may be missing). If the source is in a project being + -- extended, return the ultimate extending project. If it is not a source + -- of any project, return No_Project. + + procedure Get_Reference + (Source_File_Name : String; + In_Tree : Project_Tree_Ref; + Project : out Project_Id; + Path : out Path_Name_Type); + -- Returns the project of a source and its path in displayable form + + generic + with procedure Action (Path : String); + procedure For_All_Source_Dirs + (Project : Project_Id; + In_Tree : Project_Tree_Ref); + -- Iterate through all the source directories of a project, including those + -- of imported or modified projects. Only returns those directories that + -- potentially contain Ada sources (ie ignore projects that have no Ada + -- sources + + generic + with procedure Action (Path : String); + procedure For_All_Object_Dirs (Project : Project_Id); + -- Iterate through all the object directories of a project, including + -- those of imported or modified projects. + + ------------------ + -- Project Path -- + ------------------ + + type Project_Search_Path is private; + -- An abstraction of the project path. This object provides subprograms to + -- search for projects on the path (and caches the results for more + -- efficiency). + + procedure Free (Self : in out Project_Search_Path); + -- Free the memory used by Self + + procedure Add_Directories + (Self : in out Project_Search_Path; + Path : String); + -- Add one or more directories to the path. Directories added with this + -- procedure are added in order after the current directory and before the + -- path given by the environment variable GPR_PROJECT_PATH. A value of "-" + -- will remove the default project directory from the project path. + -- + -- Calls to this subprogram must be performed before the first call to + -- Find_Project below, or PATH will be added at the end of the search + -- path. + + procedure Get_Path + (Self : in out Project_Search_Path; + Path : out String_Access); + -- Return the current value of the project path, either the value set + -- during elaboration of the package or, if procedure Set_Project_Path has + -- been called, the value set by the last call to Set_Project_Path. + -- The returned value must not be modified. + + procedure Set_Path + (Self : in out Project_Search_Path; Path : String); + -- Override the value of the project path. + -- This also removes the implicit default search directories + + procedure Find_Project + (Self : in out Project_Search_Path; + Project_File_Name : String; + Directory : String; + Path : out Namet.Path_Name_Type); + -- Search for a project with the given name either in Directory (which + -- often will be the directory contain the project we are currently parsing + -- and which we found a reference to another project), or in the project + -- path. Extra_Project_Path contains additional directories to search. + -- + -- Project_File_Name can optionally contain directories, and the extension + -- (.gpr) for the file name is optional. + -- + -- Returns No_Name if no such project was found + +private + package Projects_Paths is new GNAT.Dynamic_HTables.Simple_HTable + (Header_Num => Header_Num, + Element => Path_Name_Type, + No_Element => No_Path, + Key => Name_Id, + Hash => Hash, + Equal => "="); + + type Project_Search_Path is record + Path : GNAT.OS_Lib.String_Access; + -- As a special case, if the first character is '#:" or this variable is + -- unset, this means that the PATH has not been fully initialized yet + -- (although subprograms above will properly take care of that). + + Cache : Projects_Paths.Instance; + end record; +end Prj.Env; diff --git a/gcc/ada/prj-err.adb b/gcc/ada/prj-err.adb new file mode 100644 index 000000000..4f5aea10b --- /dev/null +++ b/gcc/ada/prj-err.adb @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . E R R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Err_Vars; +with Output; use Output; +with Stringt; use Stringt; + +package body Prj.Err is + + --------------- + -- Post_Scan -- + --------------- + + procedure Post_Scan is + Debug_Tokens : constant Boolean := False; + + begin + -- Change operator symbol to literal strings, since that's the way + -- we treat all strings in a project file. + + if Token = Tok_Operator_Symbol + or else Token = Tok_String_Literal + then + Token := Tok_String_Literal; + String_To_Name_Buffer (String_Literal_Id); + Token_Name := Name_Find; + end if; + + if Debug_Tokens then + Write_Line (Token_Type'Image (Token)); + + if Token = Tok_Identifier + or else Token = Tok_String_Literal + then + Write_Line (" " & Get_Name_String (Token_Name)); + end if; + end if; + end Post_Scan; + + --------------- + -- Error_Msg -- + --------------- + + procedure Error_Msg + (Flags : Processing_Flags; + Msg : String; + Location : Source_Ptr := No_Location; + Project : Project_Id := null) + is + Real_Location : Source_Ptr := Location; + + begin + -- Display the error message in the traces so that it appears in the + -- correct location in the traces (otherwise error messages are only + -- displayed at the end and it is difficult to see when they were + -- triggered) + + if Current_Verbosity = High then + Write_Line ("ERROR: " & Msg); + end if; + + -- If location of error is unknown, use the location of the project + + if Real_Location = No_Location + and then Project /= null + then + Real_Location := Project.Location; + end if; + + if Real_Location = No_Location then + + -- If still null, we are parsing a project that was created in-memory + -- so we shouldn't report errors for projects that the user has no + -- access to in any case. + + if Current_Verbosity = High then + Write_Line ("Error in in-memory project, ignored"); + end if; + + return; + end if; + + -- Report the error through Errutil, so that duplicate errors are + -- properly removed, messages are sorted, and correctly interpreted,... + + Errutil.Error_Msg (Msg, Real_Location); + + -- Let the application know there was an error + + if Flags.Report_Error /= null then + Flags.Report_Error + (Project, + Is_Warning => + Msg (Msg'First) = '?' + or else (Msg (Msg'First) = '<' + and then Err_Vars.Error_Msg_Warn) + or else (Msg (Msg'First) = '\' + and then Msg (Msg'First + 1) = '<' + and then Err_Vars.Error_Msg_Warn)); + end if; + end Error_Msg; + +end Prj.Err; diff --git a/gcc/ada/prj-err.ads b/gcc/ada/prj-err.ads new file mode 100644 index 000000000..3f6b68413 --- /dev/null +++ b/gcc/ada/prj-err.ads @@ -0,0 +1,97 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . E R R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 to output error messages and the scanner +-- for the project files. It replaces Errout and Scn. It is not dependent on +-- the GNAT tree packages (Atree, Sinfo, ...). It uses exactly the same global +-- variables as Errout, located in package Err_Vars. Like Errout, it also uses +-- the common variables and routines in package Erroutc. +-- +-- Parameters are set through Err_Vars.Error_Msg_File_* or +-- Err_Vars.Error_Msg_Name_*, and replaced automatically in the messages +-- ("{{" for files, "%%" for names). +-- +-- However, in this package you can configure the error messages to be sent +-- to your own callback by setting Report_Error in the flags. This ensures +-- that applications can control where error messages are displayed. + +with Scng; +with Errutil; + +package Prj.Err is + + --------------------------------------------------------- + -- Error Message Text and Message Insertion Characters -- + --------------------------------------------------------- + + -- See errutil.ads + + ----------------------------------------------------- + -- Format of Messages and Manual Quotation Control -- + ----------------------------------------------------- + + -- See errutil.ads + + ------------------------------ + -- Error Output Subprograms -- + ------------------------------ + + procedure Initialize renames Errutil.Initialize; + -- Initializes for output of error messages. Must be called for each + -- file before using any of the other routines in the package. + + procedure Finalize (Source_Type : String := "project") + renames Errutil.Finalize; + -- Finalize processing of error messages for one file and output message + -- indicating the number of detected errors. + + procedure Error_Msg + (Flags : Processing_Flags; + Msg : String; + Location : Source_Ptr := No_Location; + Project : Project_Id := null); + -- Output an error message, either through Flags.Error_Report or through + -- Errutil. The location defaults to the project's location ("project" + -- in the source code). If Msg starts with "?", this is a warning, and + -- Warning: is added at the beginning. If Msg starts with "<", see comment + -- for Err_Vars.Error_Msg_Warn. + + ------------- + -- Scanner -- + ------------- + + procedure Post_Scan; + -- Convert an Ada operator symbol into a standard string + + package Scanner is new Scng + (Post_Scan => Post_Scan, + Error_Msg => Errutil.Error_Msg, + Error_Msg_S => Errutil.Error_Msg_S, + Error_Msg_SC => Errutil.Error_Msg_SC, + Error_Msg_SP => Errutil.Error_Msg_SP, + Style => Errutil.Style); + -- Instantiation of the generic scanner + +end Prj.Err; diff --git a/gcc/ada/prj-ext.adb b/gcc/ada/prj-ext.adb new file mode 100644 index 000000000..9c7458e95 --- /dev/null +++ b/gcc/ada/prj-ext.adb @@ -0,0 +1,133 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . E X T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2000-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Osint; use Osint; +with Prj.Tree; use Prj.Tree; + +package body Prj.Ext is + + --------- + -- Add -- + --------- + + procedure Add + (Tree : Prj.Tree.Project_Node_Tree_Ref; + External_Name : String; + Value : String) + is + The_Key : Name_Id; + The_Value : Name_Id; + begin + Name_Len := Value'Length; + Name_Buffer (1 .. Name_Len) := Value; + The_Value := Name_Find; + Name_Len := External_Name'Length; + Name_Buffer (1 .. Name_Len) := External_Name; + Canonical_Case_Env_Var_Name (Name_Buffer (1 .. Name_Len)); + The_Key := Name_Find; + Name_To_Name_HTable.Set (Tree.External_References, The_Key, The_Value); + end Add; + + ----------- + -- Check -- + ----------- + + function Check + (Tree : Prj.Tree.Project_Node_Tree_Ref; + Declaration : String) return Boolean + is + begin + for Equal_Pos in Declaration'Range loop + if Declaration (Equal_Pos) = '=' then + exit when Equal_Pos = Declaration'First; + Add + (Tree => Tree, + External_Name => + Declaration (Declaration'First .. Equal_Pos - 1), + Value => + Declaration (Equal_Pos + 1 .. Declaration'Last)); + return True; + end if; + end loop; + + return False; + end Check; + + ----------- + -- Reset -- + ----------- + + procedure Reset (Tree : Prj.Tree.Project_Node_Tree_Ref) is + begin + Name_To_Name_HTable.Reset (Tree.External_References); + end Reset; + + -------------- + -- Value_Of -- + -------------- + + function Value_Of + (Tree : Prj.Tree.Project_Node_Tree_Ref; + External_Name : Name_Id; + With_Default : Name_Id := No_Name) + return Name_Id + is + The_Value : Name_Id; + Name : String := Get_Name_String (External_Name); + + begin + Canonical_Case_Env_Var_Name (Name); + Name_Len := Name'Length; + Name_Buffer (1 .. Name_Len) := Name; + The_Value := + Name_To_Name_HTable.Get (Tree.External_References, Name_Find); + + if The_Value /= No_Name then + return The_Value; + end if; + + -- Find if it is an environment, if it is, put value in the hash table + + declare + Env_Value : String_Access := Getenv (Name); + + begin + if Env_Value /= null and then Env_Value'Length > 0 then + Name_Len := Env_Value'Length; + Name_Buffer (1 .. Name_Len) := Env_Value.all; + The_Value := Name_Find; + Name_To_Name_HTable.Set + (Tree.External_References, External_Name, The_Value); + Free (Env_Value); + return The_Value; + + else + Free (Env_Value); + return With_Default; + end if; + end; + end Value_Of; + +end Prj.Ext; diff --git a/gcc/ada/prj-ext.ads b/gcc/ada/prj-ext.ads new file mode 100644 index 000000000..1fb389c4a --- /dev/null +++ b/gcc/ada/prj-ext.ads @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . E X T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Subprograms to set, get and cache external references, to be used as +-- External functions in project files. + +with Prj.Tree; + +package Prj.Ext is + + ------------------------- + -- External References -- + ------------------------- + + -- External references influence the way a project tree is processed (in + -- particular they provide the values for the typed string variables that + -- are then used in case constructions). + + -- External references are project-tree specific, so that when multiple + -- trees are loaded in parallel we can have different scenarios (or even + -- load the same tree twice and see different views of it). + + procedure Add + (Tree : Prj.Tree.Project_Node_Tree_Ref; + External_Name : String; + Value : String); + -- Add an external reference (or modify an existing one) + + function Value_Of + (Tree : Prj.Tree.Project_Node_Tree_Ref; + External_Name : Name_Id; + With_Default : Name_Id := No_Name) + return Name_Id; + -- Get the value of an external reference, and cache it for future uses + + function Check + (Tree : Prj.Tree.Project_Node_Tree_Ref; + Declaration : String) return Boolean; + -- Check that an external declaration = is correct. + -- If it is correct, the external reference is Added. + + procedure Reset (Tree : Prj.Tree.Project_Node_Tree_Ref); + -- Clear the internal data structure that stores the external references + -- and free any allocated memory. + +end Prj.Ext; diff --git a/gcc/ada/prj-makr.adb b/gcc/ada/prj-makr.adb new file mode 100644 index 000000000..3e02783aa --- /dev/null +++ b/gcc/ada/prj-makr.adb @@ -0,0 +1,1522 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . M A K R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Csets; +with Opt; +with Output; +with Osint; use Osint; +with Prj; use Prj; +with Prj.Com; +with Prj.Part; +with Prj.PP; +with Prj.Tree; use Prj.Tree; +with Prj.Util; use Prj.Util; +with Snames; use Snames; +with Table; use Table; + +with Ada.Characters.Handling; use Ada.Characters.Handling; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; + +with System.Case_Util; use System.Case_Util; +with System.CRTL; +with System.HTable; + +package body Prj.Makr is + + -- Packages of project files where unknown attributes are errors + + -- All the following need comments ??? All global variables and + -- subprograms must be fully commented. + + Very_Verbose : Boolean := False; + -- Set in call to Initialize to indicate very verbose output + + Project_File : Boolean := False; + -- True when gnatname is creating/modifying a project file. False when + -- gnatname is creating a configuration pragmas file. + + Tree : constant Project_Node_Tree_Ref := new Project_Node_Tree_Data; + -- The project tree where the project file is parsed + + Args : Argument_List_Access; + -- The list of arguments for calls to the compiler to get the unit names + -- and kinds (spec or body) in the Ada sources. + + Path_Name : String_Access; + + Path_Last : Natural; + + Directory_Last : Natural := 0; + + Output_Name : String_Access; + Output_Name_Last : Natural; + Output_Name_Id : Name_Id; + + Project_Naming_File_Name : String_Access; + -- String (1 .. Output_Name'Length + Naming_File_Suffix'Length); + + Project_Naming_Last : Natural; + Project_Naming_Id : Name_Id := No_Name; + + Source_List_Path : String_Access; + -- (1 .. Output_Name'Length + Source_List_File_Suffix'Length); + Source_List_Last : Natural; + + Source_List_FD : File_Descriptor; + + Project_Node : Project_Node_Id := Empty_Node; + Project_Declaration : Project_Node_Id := Empty_Node; + Source_Dirs_List : Project_Node_Id := Empty_Node; + + Project_Naming_Node : Project_Node_Id := Empty_Node; + Project_Naming_Decl : Project_Node_Id := Empty_Node; + Naming_Package : Project_Node_Id := Empty_Node; + Naming_Package_Comments : Project_Node_Id := Empty_Node; + + Source_Files_Comments : Project_Node_Id := Empty_Node; + Source_Dirs_Comments : Project_Node_Id := Empty_Node; + Source_List_File_Comments : Project_Node_Id := Empty_Node; + + Naming_String : aliased String := "naming"; + + Gnatname_Packages : aliased String_List := (1 => Naming_String'Access); + + Packages_To_Check_By_Gnatname : constant String_List_Access := + Gnatname_Packages'Access; + + function Dup (Fd : File_Descriptor) return File_Descriptor; + + procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); + + Gcc : constant String := "gcc"; + Gcc_Path : String_Access := null; + + Non_Empty_Node : constant Project_Node_Id := 1; + -- Used for the With_Clause of the naming project + + type Matched_Type is (True, False, Excluded); + + Naming_File_Suffix : constant String := "_naming"; + Source_List_File_Suffix : constant String := "_source_list.txt"; + + Output_FD : File_Descriptor; + -- To save the project file and its naming project file + + procedure Write_Eol; + -- Output an empty line + + procedure Write_A_Char (C : Character); + -- Write one character to Output_FD + + procedure Write_A_String (S : String); + -- Write a String to Output_FD + + package Processed_Directories is new Table.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Prj.Makr.Processed_Directories"); + -- The list of already processed directories for each section, to avoid + -- processing several times the same directory in the same section. + + package Source_Directories is new Table.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Prj.Makr.Source_Directories"); + -- The complete list of directories to be put in attribute Source_Dirs in + -- the project file. + + type Source is record + File_Name : Name_Id; + Unit_Name : Name_Id; + Index : Int := 0; + Spec : Boolean; + end record; + + package Sources is new Table.Table + (Table_Component_Type => Source, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Prj.Makr.Sources"); + -- The list of Ada sources found, with their unit name and kind, to be put + -- in the source attribute and package Naming of the project file, or in + -- the pragmas Source_File_Name in the configuration pragmas file. + + package Source_Files is new System.HTable.Simple_HTable + (Header_Num => Prj.Header_Num, + Element => Boolean, + No_Element => False, + Key => Name_Id, + Hash => Prj.Hash, + Equal => "="); + -- Hash table to keep track of source file names, to avoid putting several + -- times the same file name in case of multi-unit files. + + --------- + -- Dup -- + --------- + + function Dup (Fd : File_Descriptor) return File_Descriptor is + begin + return File_Descriptor (System.CRTL.dup (Integer (Fd))); + end Dup; + + ---------- + -- Dup2 -- + ---------- + + procedure Dup2 (Old_Fd, New_Fd : File_Descriptor) is + Fd : Integer; + pragma Warnings (Off, Fd); + begin + Fd := System.CRTL.dup2 (Integer (Old_Fd), Integer (New_Fd)); + end Dup2; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + Discard : Boolean; + pragma Warnings (Off, Discard); + + Current_Source_Dir : Project_Node_Id := Empty_Node; + + begin + if Project_File then + -- If there were no already existing project file, or if the parsing + -- was unsuccessful, create an empty project node with the correct + -- name and its project declaration node. + + if No (Project_Node) then + Project_Node := + Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree); + Set_Name_Of (Project_Node, Tree, To => Output_Name_Id); + Set_Project_Declaration_Of + (Project_Node, Tree, + To => Default_Project_Node + (Of_Kind => N_Project_Declaration, In_Tree => Tree)); + + end if; + + end if; + + -- Delete the file if it already exists + + Delete_File + (Path_Name (Directory_Last + 1 .. Path_Last), + Success => Discard); + + -- Create a new one + + if Opt.Verbose_Mode then + Output.Write_Str ("Creating new file """); + Output.Write_Str (Path_Name (Directory_Last + 1 .. Path_Last)); + Output.Write_Line (""""); + end if; + + Output_FD := Create_New_File + (Path_Name (Directory_Last + 1 .. Path_Last), + Fmode => Text); + + -- Fails if project file cannot be created + + if Output_FD = Invalid_FD then + Prj.Com.Fail + ("cannot create new """ & Path_Name (1 .. Path_Last) & """"); + end if; + + if Project_File then + + -- Delete the source list file, if it already exists + + declare + Discard : Boolean; + pragma Warnings (Off, Discard); + begin + Delete_File + (Source_List_Path (1 .. Source_List_Last), + Success => Discard); + end; + + -- And create a new source list file, fail if file cannot be created + + Source_List_FD := Create_New_File + (Name => Source_List_Path (1 .. Source_List_Last), + Fmode => Text); + + if Source_List_FD = Invalid_FD then + Prj.Com.Fail + ("cannot create file """ + & Source_List_Path (1 .. Source_List_Last) + & """"); + end if; + + if Opt.Verbose_Mode then + Output.Write_Str ("Naming project file name is """); + Output.Write_Str + (Project_Naming_File_Name (1 .. Project_Naming_Last)); + Output.Write_Line (""""); + end if; + + -- Create the naming project node + + Project_Naming_Node := + Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree); + Set_Name_Of (Project_Naming_Node, Tree, To => Project_Naming_Id); + Project_Naming_Decl := + Default_Project_Node + (Of_Kind => N_Project_Declaration, In_Tree => Tree); + Set_Project_Declaration_Of + (Project_Naming_Node, Tree, Project_Naming_Decl); + Naming_Package := + Default_Project_Node + (Of_Kind => N_Package_Declaration, In_Tree => Tree); + Set_Name_Of (Naming_Package, Tree, To => Name_Naming); + + -- Add an attribute declaration for Source_Files as an empty list (to + -- indicate there are no sources in the naming project) and a package + -- Naming (that will be filled later). + + declare + Decl_Item : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Declarative_Item, In_Tree => Tree); + + Attribute : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Attribute_Declaration, + In_Tree => Tree, + And_Expr_Kind => List); + + Expression : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Expression, + In_Tree => Tree, + And_Expr_Kind => List); + + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, + In_Tree => Tree, + And_Expr_Kind => List); + + Empty_List : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Literal_String_List, + In_Tree => Tree); + + begin + Set_First_Declarative_Item_Of + (Project_Naming_Decl, Tree, To => Decl_Item); + Set_Next_Declarative_Item (Decl_Item, Tree, Naming_Package); + Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); + Set_Name_Of (Attribute, Tree, To => Name_Source_Files); + Set_Expression_Of (Attribute, Tree, To => Expression); + Set_First_Term (Expression, Tree, To => Term); + Set_Current_Term (Term, Tree, To => Empty_List); + end; + + -- Add a with clause on the naming project in the main project, if + -- there is not already one. + + declare + With_Clause : Project_Node_Id := + First_With_Clause_Of (Project_Node, Tree); + + begin + while Present (With_Clause) loop + exit when + Prj.Tree.Name_Of (With_Clause, Tree) = Project_Naming_Id; + With_Clause := Next_With_Clause_Of (With_Clause, Tree); + end loop; + + if No (With_Clause) then + With_Clause := Default_Project_Node + (Of_Kind => N_With_Clause, In_Tree => Tree); + Set_Next_With_Clause_Of + (With_Clause, Tree, + To => First_With_Clause_Of (Project_Node, Tree)); + Set_First_With_Clause_Of + (Project_Node, Tree, To => With_Clause); + Set_Name_Of (With_Clause, Tree, To => Project_Naming_Id); + + -- We set the project node to something different than + -- Empty_Node, so that Prj.PP does not generate a limited + -- with clause. + + Set_Project_Node_Of (With_Clause, Tree, Non_Empty_Node); + + Name_Len := Project_Naming_Last; + Name_Buffer (1 .. Name_Len) := + Project_Naming_File_Name (1 .. Project_Naming_Last); + Set_String_Value_Of (With_Clause, Tree, To => Name_Find); + end if; + end; + + Project_Declaration := Project_Declaration_Of (Project_Node, Tree); + + -- Add a package Naming in the main project, that is a renaming of + -- package Naming in the naming project. + + declare + Decl_Item : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Declarative_Item, + In_Tree => Tree); + + Naming : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Package_Declaration, + In_Tree => Tree); + + begin + Set_Next_Declarative_Item + (Decl_Item, Tree, + To => First_Declarative_Item_Of (Project_Declaration, Tree)); + Set_First_Declarative_Item_Of + (Project_Declaration, Tree, To => Decl_Item); + Set_Current_Item_Node (Decl_Item, Tree, To => Naming); + Set_Name_Of (Naming, Tree, To => Name_Naming); + Set_Project_Of_Renamed_Package_Of + (Naming, Tree, To => Project_Naming_Node); + + -- Attach the comments, if any, that were saved for package + -- Naming. + + Tree.Project_Nodes.Table (Naming).Comments := + Naming_Package_Comments; + end; + + -- Add an attribute declaration for Source_Dirs, initialized as an + -- empty list. + + declare + Decl_Item : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Declarative_Item, + In_Tree => Tree); + + Attribute : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Attribute_Declaration, + In_Tree => Tree, + And_Expr_Kind => List); + + Expression : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Expression, + In_Tree => Tree, + And_Expr_Kind => List); + + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, In_Tree => Tree, + And_Expr_Kind => List); + + begin + Set_Next_Declarative_Item + (Decl_Item, Tree, + To => First_Declarative_Item_Of (Project_Declaration, Tree)); + Set_First_Declarative_Item_Of + (Project_Declaration, Tree, To => Decl_Item); + Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); + Set_Name_Of (Attribute, Tree, To => Name_Source_Dirs); + Set_Expression_Of (Attribute, Tree, To => Expression); + Set_First_Term (Expression, Tree, To => Term); + Source_Dirs_List := + Default_Project_Node + (Of_Kind => N_Literal_String_List, + In_Tree => Tree, + And_Expr_Kind => List); + Set_Current_Term (Term, Tree, To => Source_Dirs_List); + + -- Attach the comments, if any, that were saved for attribute + -- Source_Dirs. + + Tree.Project_Nodes.Table (Attribute).Comments := + Source_Dirs_Comments; + end; + + -- Put the source directories in attribute Source_Dirs + + for Source_Dir_Index in 1 .. Source_Directories.Last loop + declare + Expression : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Expression, + In_Tree => Tree, + And_Expr_Kind => Single); + + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, + In_Tree => Tree, + And_Expr_Kind => Single); + + Value : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Literal_String, + In_Tree => Tree, + And_Expr_Kind => Single); + + begin + if No (Current_Source_Dir) then + Set_First_Expression_In_List + (Source_Dirs_List, Tree, To => Expression); + else + Set_Next_Expression_In_List + (Current_Source_Dir, Tree, To => Expression); + end if; + + Current_Source_Dir := Expression; + Set_First_Term (Expression, Tree, To => Term); + Set_Current_Term (Term, Tree, To => Value); + Name_Len := 0; + Add_Str_To_Name_Buffer + (Source_Directories.Table (Source_Dir_Index).all); + Set_String_Value_Of (Value, Tree, To => Name_Find); + end; + end loop; + + -- Add an attribute declaration for Source_Files or Source_List_File + -- with the source list file name that will be created. + + declare + Decl_Item : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Declarative_Item, + In_Tree => Tree); + + Attribute : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Attribute_Declaration, + In_Tree => Tree, + And_Expr_Kind => Single); + + Expression : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Expression, + In_Tree => Tree, + And_Expr_Kind => Single); + + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, + In_Tree => Tree, + And_Expr_Kind => Single); + + Value : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Literal_String, + In_Tree => Tree, + And_Expr_Kind => Single); + + begin + Set_Next_Declarative_Item + (Decl_Item, Tree, + To => First_Declarative_Item_Of (Project_Declaration, Tree)); + Set_First_Declarative_Item_Of + (Project_Declaration, Tree, To => Decl_Item); + Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); + + Set_Name_Of (Attribute, Tree, To => Name_Source_List_File); + Set_Expression_Of (Attribute, Tree, To => Expression); + Set_First_Term (Expression, Tree, To => Term); + Set_Current_Term (Term, Tree, To => Value); + Name_Len := Source_List_Last; + Name_Buffer (1 .. Name_Len) := + Source_List_Path (1 .. Source_List_Last); + Set_String_Value_Of (Value, Tree, To => Name_Find); + + -- If there was no comments for attribute Source_List_File, put + -- those for Source_Files, if they exist. + + if Present (Source_List_File_Comments) then + Tree.Project_Nodes.Table (Attribute).Comments := + Source_List_File_Comments; + else + Tree.Project_Nodes.Table (Attribute).Comments := + Source_Files_Comments; + end if; + end; + + -- Put the sources in the source list files and in the naming + -- project. + + for Source_Index in 1 .. Sources.Last loop + + -- Add the corresponding attribute in the + -- Naming package of the naming project. + + declare + Current_Source : constant Source := + Sources.Table (Source_Index); + + Decl_Item : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => + N_Declarative_Item, + In_Tree => Tree); + + Attribute : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => + N_Attribute_Declaration, + In_Tree => Tree); + + Expression : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Expression, + And_Expr_Kind => Single, + In_Tree => Tree); + + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, + And_Expr_Kind => Single, + In_Tree => Tree); + + Value : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Literal_String, + And_Expr_Kind => Single, + In_Tree => Tree); + + begin + -- Add source file name to the source list file if it is not + -- already there. + + if not Source_Files.Get (Current_Source.File_Name) then + Source_Files.Set (Current_Source.File_Name, True); + Get_Name_String (Current_Source.File_Name); + Add_Char_To_Name_Buffer (ASCII.LF); + + if Write (Source_List_FD, + Name_Buffer (1)'Address, + Name_Len) /= Name_Len + then + Prj.Com.Fail ("disk full"); + end if; + end if; + + -- For an Ada source, add entry in package Naming + + if Current_Source.Unit_Name /= No_Name then + Set_Next_Declarative_Item + (Decl_Item, + To => First_Declarative_Item_Of + (Naming_Package, Tree), + In_Tree => Tree); + Set_First_Declarative_Item_Of + (Naming_Package, + To => Decl_Item, + In_Tree => Tree); + Set_Current_Item_Node + (Decl_Item, + To => Attribute, + In_Tree => Tree); + + -- Is it a spec or a body? + + if Current_Source.Spec then + Set_Name_Of + (Attribute, Tree, + To => Name_Spec); + else + Set_Name_Of + (Attribute, Tree, + To => Name_Body); + end if; + + -- Get the name of the unit + + Get_Name_String (Current_Source.Unit_Name); + To_Lower (Name_Buffer (1 .. Name_Len)); + Set_Associative_Array_Index_Of + (Attribute, Tree, To => Name_Find); + + Set_Expression_Of + (Attribute, Tree, To => Expression); + Set_First_Term + (Expression, Tree, To => Term); + Set_Current_Term + (Term, Tree, To => Value); + + -- And set the name of the file + + Set_String_Value_Of + (Value, Tree, To => Current_Source.File_Name); + Set_Source_Index_Of + (Value, Tree, To => Current_Source.Index); + end if; + end; + end loop; + + -- Close the source list file + + Close (Source_List_FD); + + -- Output the project file + + Prj.PP.Pretty_Print + (Project_Node, Tree, + W_Char => Write_A_Char'Access, + W_Eol => Write_Eol'Access, + W_Str => Write_A_String'Access, + Backward_Compatibility => False, + Max_Line_Length => 79); + Close (Output_FD); + + -- Delete the naming project file if it already exists + + Delete_File + (Project_Naming_File_Name (1 .. Project_Naming_Last), + Success => Discard); + + -- Create a new one + + if Opt.Verbose_Mode then + Output.Write_Str ("Creating new naming project file """); + Output.Write_Str (Project_Naming_File_Name + (1 .. Project_Naming_Last)); + Output.Write_Line (""""); + end if; + + Output_FD := Create_New_File + (Project_Naming_File_Name (1 .. Project_Naming_Last), + Fmode => Text); + + -- Fails if naming project file cannot be created + + if Output_FD = Invalid_FD then + Prj.Com.Fail + ("cannot create new """ + & Project_Naming_File_Name (1 .. Project_Naming_Last) + & """"); + end if; + + -- Output the naming project file + + Prj.PP.Pretty_Print + (Project_Naming_Node, Tree, + W_Char => Write_A_Char'Access, + W_Eol => Write_Eol'Access, + W_Str => Write_A_String'Access, + Backward_Compatibility => False); + Close (Output_FD); + + else + -- For each Ada source, write a pragma Source_File_Name to the + -- configuration pragmas file. + + for Index in 1 .. Sources.Last loop + if Sources.Table (Index).Unit_Name /= No_Name then + Write_A_String ("pragma Source_File_Name"); + Write_Eol; + Write_A_String (" ("); + Write_A_String + (Get_Name_String (Sources.Table (Index).Unit_Name)); + Write_A_String (","); + Write_Eol; + + if Sources.Table (Index).Spec then + Write_A_String (" Spec_File_Name => """); + + else + Write_A_String (" Body_File_Name => """); + end if; + + Write_A_String + (Get_Name_String (Sources.Table (Index).File_Name)); + + Write_A_String (""""); + + if Sources.Table (Index).Index /= 0 then + Write_A_String (", Index =>"); + Write_A_String (Sources.Table (Index).Index'Img); + end if; + + Write_A_String (");"); + Write_Eol; + end if; + end loop; + + Close (Output_FD); + end if; + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize + (File_Path : String; + Project_File : Boolean; + Preproc_Switches : Argument_List; + Very_Verbose : Boolean; + Flags : Processing_Flags) + is + begin + Makr.Very_Verbose := Initialize.Very_Verbose; + Makr.Project_File := Initialize.Project_File; + + -- Do some needed initializations + + Csets.Initialize; + Snames.Initialize; + Prj.Initialize (No_Project_Tree); + Prj.Tree.Initialize (Tree); + + Sources.Set_Last (0); + Source_Directories.Set_Last (0); + + -- Initialize the compiler switches + + Args := new Argument_List (1 .. Preproc_Switches'Length + 6); + Args (1) := new String'("-c"); + Args (2) := new String'("-gnats"); + Args (3) := new String'("-gnatu"); + Args (4 .. 3 + Preproc_Switches'Length) := Preproc_Switches; + Args (4 + Preproc_Switches'Length) := new String'("-x"); + Args (5 + Preproc_Switches'Length) := new String'("ada"); + + -- Get the path and file names + + Path_Name := new + String (1 .. File_Path'Length + Project_File_Extension'Length); + Path_Last := File_Path'Length; + + if File_Names_Case_Sensitive then + Path_Name (1 .. Path_Last) := File_Path; + else + Path_Name (1 .. Path_Last) := To_Lower (File_Path); + end if; + + Path_Name (Path_Last + 1 .. Path_Name'Last) := + Project_File_Extension; + + -- Get the end of directory information, if any + + for Index in reverse 1 .. Path_Last loop + if Path_Name (Index) = Directory_Separator then + Directory_Last := Index; + exit; + end if; + end loop; + + if Project_File then + if Path_Last < Project_File_Extension'Length + 1 + or else Path_Name + (Path_Last - Project_File_Extension'Length + 1 .. Path_Last) + /= Project_File_Extension + then + Path_Last := Path_Name'Last; + end if; + + Output_Name := new String'(To_Lower (Path_Name (1 .. Path_Last))); + Output_Name_Last := Output_Name'Last - 4; + + -- If there is already a project file with the specified name, parse + -- it to get the components that are not automatically generated. + + if Is_Regular_File (Output_Name (1 .. Path_Last)) then + if Opt.Verbose_Mode then + Output.Write_Str ("Parsing already existing project file """); + Output.Write_Str (Output_Name.all); + Output.Write_Line (""""); + end if; + + Part.Parse + (In_Tree => Tree, + Project => Project_Node, + Project_File_Name => Output_Name.all, + Always_Errout_Finalize => False, + Store_Comments => True, + Is_Config_File => False, + Flags => Flags, + Current_Directory => Get_Current_Dir, + Packages_To_Check => Packages_To_Check_By_Gnatname); + + -- Fail if parsing was not successful + + if No (Project_Node) then + Prj.Com.Fail ("parsing of existing project file failed"); + + else + -- If parsing was successful, remove the components that are + -- automatically generated, if any, so that they will be + -- unconditionally added later. + + -- Remove the with clause for the naming project file + + declare + With_Clause : Project_Node_Id := + First_With_Clause_Of (Project_Node, Tree); + Previous : Project_Node_Id := Empty_Node; + + begin + while Present (With_Clause) loop + if Prj.Tree.Name_Of (With_Clause, Tree) = + Project_Naming_Id + then + if No (Previous) then + Set_First_With_Clause_Of + (Project_Node, Tree, + To => Next_With_Clause_Of (With_Clause, Tree)); + else + Set_Next_With_Clause_Of + (Previous, Tree, + To => Next_With_Clause_Of (With_Clause, Tree)); + end if; + + exit; + end if; + + Previous := With_Clause; + With_Clause := Next_With_Clause_Of (With_Clause, Tree); + end loop; + end; + + -- Remove attribute declarations of Source_Files, + -- Source_List_File, Source_Dirs, and the declaration of + -- package Naming, if they exist, but preserve the comments + -- attached to these nodes. + + declare + Declaration : Project_Node_Id := + First_Declarative_Item_Of + (Project_Declaration_Of + (Project_Node, Tree), + Tree); + Previous : Project_Node_Id := Empty_Node; + Current_Node : Project_Node_Id := Empty_Node; + + Name : Name_Id; + Kind_Of_Node : Project_Node_Kind; + Comments : Project_Node_Id; + + begin + while Present (Declaration) loop + Current_Node := Current_Item_Node (Declaration, Tree); + + Kind_Of_Node := Kind_Of (Current_Node, Tree); + + if Kind_Of_Node = N_Attribute_Declaration or else + Kind_Of_Node = N_Package_Declaration + then + Name := Prj.Tree.Name_Of (Current_Node, Tree); + + if Name = Name_Source_Files or else + Name = Name_Source_List_File or else + Name = Name_Source_Dirs or else + Name = Name_Naming + then + Comments := + Tree.Project_Nodes.Table (Current_Node).Comments; + + if Name = Name_Source_Files then + Source_Files_Comments := Comments; + + elsif Name = Name_Source_List_File then + Source_List_File_Comments := Comments; + + elsif Name = Name_Source_Dirs then + Source_Dirs_Comments := Comments; + + elsif Name = Name_Naming then + Naming_Package_Comments := Comments; + end if; + + if No (Previous) then + Set_First_Declarative_Item_Of + (Project_Declaration_Of (Project_Node, Tree), + Tree, + To => Next_Declarative_Item + (Declaration, Tree)); + + else + Set_Next_Declarative_Item + (Previous, Tree, + To => Next_Declarative_Item + (Declaration, Tree)); + end if; + + else + Previous := Declaration; + end if; + end if; + + Declaration := Next_Declarative_Item (Declaration, Tree); + end loop; + end; + end if; + end if; + + if Directory_Last /= 0 then + Output_Name (1 .. Output_Name_Last - Directory_Last) := + Output_Name (Directory_Last + 1 .. Output_Name_Last); + Output_Name_Last := Output_Name_Last - Directory_Last; + end if; + + -- Get the project name id + + Name_Len := Output_Name_Last; + Name_Buffer (1 .. Name_Len) := Output_Name (1 .. Name_Len); + Output_Name_Id := Name_Find; + + -- Create the project naming file name + + Project_Naming_Last := Output_Name_Last; + Project_Naming_File_Name := + new String'(Output_Name (1 .. Output_Name_Last) & + Naming_File_Suffix & + Project_File_Extension); + Project_Naming_Last := + Project_Naming_Last + Naming_File_Suffix'Length; + + -- Get the project naming id + + Name_Len := Project_Naming_Last; + Name_Buffer (1 .. Name_Len) := + Project_Naming_File_Name (1 .. Name_Len); + Project_Naming_Id := Name_Find; + + Project_Naming_Last := + Project_Naming_Last + Project_File_Extension'Length; + + -- Create the source list file name + + Source_List_Last := Output_Name_Last; + Source_List_Path := + new String'(Output_Name (1 .. Output_Name_Last) & + Source_List_File_Suffix); + Source_List_Last := + Output_Name_Last + Source_List_File_Suffix'Length; + + -- Add the project file extension to the project name + + Output_Name + (Output_Name_Last + 1 .. + Output_Name_Last + Project_File_Extension'Length) := + Project_File_Extension; + Output_Name_Last := Output_Name_Last + Project_File_Extension'Length; + + end if; + + -- Change the current directory to the directory of the project file, + -- if any directory information is specified. + + if Directory_Last /= 0 then + begin + Change_Dir (Path_Name (1 .. Directory_Last)); + exception + when Directory_Error => + Prj.Com.Fail + ("unknown directory """ + & Path_Name (1 .. Directory_Last) + & """"); + end; + end if; + end Initialize; + + ------------- + -- Process -- + ------------- + + procedure Process + (Directories : Argument_List; + Name_Patterns : Regexp_List; + Excluded_Patterns : Regexp_List; + Foreign_Patterns : Regexp_List) + is + procedure Process_Directory (Dir_Name : String; Recursively : Boolean); + -- Look for Ada and foreign sources in a directory, according to the + -- patterns. When Recursively is True, after looking for sources in + -- Dir_Name, look also in its subdirectories, if any. + + ----------------------- + -- Process_Directory -- + ----------------------- + + procedure Process_Directory (Dir_Name : String; Recursively : Boolean) is + Matched : Matched_Type := False; + Str : String (1 .. 2_000); + Canon : String (1 .. 2_000); + Last : Natural; + Dir : Dir_Type; + Do_Process : Boolean := True; + + Temp_File_Name : String_Access := null; + Save_Last_Source_Index : Natural := 0; + File_Name_Id : Name_Id := No_Name; + + Current_Source : Source; + + begin + -- Avoid processing the same directory more than once + + for Index in 1 .. Processed_Directories.Last loop + if Processed_Directories.Table (Index).all = Dir_Name then + Do_Process := False; + exit; + end if; + end loop; + + if Do_Process then + if Opt.Verbose_Mode then + Output.Write_Str ("Processing directory """); + Output.Write_Str (Dir_Name); + Output.Write_Line (""""); + end if; + + Processed_Directories. Increment_Last; + Processed_Directories.Table (Processed_Directories.Last) := + new String'(Dir_Name); + + -- Get the source file names from the directory. Fails if the + -- directory does not exist. + + begin + Open (Dir, Dir_Name); + exception + when Directory_Error => + Prj.Com.Fail ("cannot open directory """ & Dir_Name & """"); + end; + + -- Process each regular file in the directory + + File_Loop : loop + Read (Dir, Str, Last); + exit File_Loop when Last = 0; + + -- Copy the file name and put it in canonical case to match + -- against the patterns that have themselves already been put + -- in canonical case. + + Canon (1 .. Last) := Str (1 .. Last); + Canonical_Case_File_Name (Canon (1 .. Last)); + + if Is_Regular_File + (Dir_Name & Directory_Separator & Str (1 .. Last)) + then + Matched := True; + + Name_Len := Last; + Name_Buffer (1 .. Name_Len) := Str (1 .. Last); + File_Name_Id := Name_Find; + + -- First, check if the file name matches at least one of + -- the excluded expressions; + + for Index in Excluded_Patterns'Range loop + if + Match (Canon (1 .. Last), Excluded_Patterns (Index)) + then + Matched := Excluded; + exit; + end if; + end loop; + + -- If it does not match any of the excluded expressions, + -- check if the file name matches at least one of the + -- regular expressions. + + if Matched = True then + Matched := False; + + for Index in Name_Patterns'Range loop + if + Match + (Canon (1 .. Last), Name_Patterns (Index)) + then + Matched := True; + exit; + end if; + end loop; + end if; + + if Very_Verbose + or else (Matched = True and then Opt.Verbose_Mode) + then + Output.Write_Str (" Checking """); + Output.Write_Str (Str (1 .. Last)); + Output.Write_Line (""": "); + end if; + + -- If the file name matches one of the regular expressions, + -- parse it to get its unit name. + + if Matched = True then + declare + FD : File_Descriptor; + Success : Boolean; + Saved_Output : File_Descriptor; + Saved_Error : File_Descriptor; + + begin + -- If we don't have the path of the compiler yet, + -- get it now. The compiler name may have a prefix, + -- so we get the potentially prefixed name. + + if Gcc_Path = null then + declare + Prefix_Gcc : String_Access := + Program_Name (Gcc, "gnatname"); + begin + Gcc_Path := + Locate_Exec_On_Path (Prefix_Gcc.all); + Free (Prefix_Gcc); + end; + + if Gcc_Path = null then + Prj.Com.Fail ("could not locate " & Gcc); + end if; + end if; + + -- If we don't have yet the file name of the + -- temporary file, get it now. + + if Temp_File_Name = null then + Create_Temp_File (FD, Temp_File_Name); + + if FD = Invalid_FD then + Prj.Com.Fail + ("could not create temporary file"); + end if; + + Close (FD); + Delete_File (Temp_File_Name.all, Success); + end if; + + Args (Args'Last) := new String' + (Dir_Name & + Directory_Separator & + Str (1 .. Last)); + + -- Create the temporary file + + FD := Create_Output_Text_File + (Name => Temp_File_Name.all); + + if FD = Invalid_FD then + Prj.Com.Fail + ("could not create temporary file"); + end if; + + -- Save the standard output and error + + Saved_Output := Dup (Standout); + Saved_Error := Dup (Standerr); + + -- Set standard output and error to the temporary file + + Dup2 (FD, Standout); + Dup2 (FD, Standerr); + + -- And spawn the compiler + + Spawn (Gcc_Path.all, Args.all, Success); + + -- Restore the standard output and error + + Dup2 (Saved_Output, Standout); + Dup2 (Saved_Error, Standerr); + + -- Close the temporary file + + Close (FD); + + -- And close the saved standard output and error to + -- avoid too many file descriptors. + + Close (Saved_Output); + Close (Saved_Error); + + -- Now that standard output is restored, check if + -- the compiler ran correctly. + + -- Read the lines of the temporary file: + -- they should contain the kind and name of the unit. + + declare + File : Text_File; + Text_Line : String (1 .. 1_000); + Text_Last : Natural; + + begin + Open (File, Temp_File_Name.all); + + if not Is_Valid (File) then + Prj.Com.Fail + ("could not read temporary file"); + end if; + + Save_Last_Source_Index := Sources.Last; + + if End_Of_File (File) then + if Opt.Verbose_Mode then + if not Success then + Output.Write_Str (" (process died) "); + end if; + end if; + + else + Line_Loop : while not End_Of_File (File) loop + Get_Line (File, Text_Line, Text_Last); + + -- Find the first closing parenthesis + + Char_Loop : for J in 1 .. Text_Last loop + if Text_Line (J) = ')' then + if J >= 13 and then + Text_Line (1 .. 4) = "Unit" + then + -- Add entry to Sources table + + Name_Len := J - 12; + Name_Buffer (1 .. Name_Len) := + Text_Line (6 .. J - 7); + Current_Source := + (Unit_Name => Name_Find, + File_Name => File_Name_Id, + Index => 0, + Spec => Text_Line (J - 5 .. J) = + "(spec)"); + + Sources.Append (Current_Source); + end if; + + exit Char_Loop; + end if; + end loop Char_Loop; + end loop Line_Loop; + end if; + + if Save_Last_Source_Index = Sources.Last then + if Opt.Verbose_Mode then + Output.Write_Line (" not a unit"); + end if; + + else + if Sources.Last > + Save_Last_Source_Index + 1 + then + for Index in Save_Last_Source_Index + 1 .. + Sources.Last + loop + Sources.Table (Index).Index := + Int (Index - Save_Last_Source_Index); + end loop; + end if; + + for Index in Save_Last_Source_Index + 1 .. + Sources.Last + loop + Current_Source := Sources.Table (Index); + + if Opt.Verbose_Mode then + if Current_Source.Spec then + Output.Write_Str (" spec of "); + + else + Output.Write_Str (" body of "); + end if; + + Output.Write_Line + (Get_Name_String + (Current_Source.Unit_Name)); + end if; + end loop; + end if; + + Close (File); + + Delete_File (Temp_File_Name.all, Success); + end; + end; + + -- File name matches none of the regular expressions + + else + -- If file is not excluded, see if this is foreign source + + if Matched /= Excluded then + for Index in Foreign_Patterns'Range loop + if Match (Canon (1 .. Last), + Foreign_Patterns (Index)) + then + Matched := True; + exit; + end if; + end loop; + end if; + + if Very_Verbose then + case Matched is + when False => + Output.Write_Line ("no match"); + + when Excluded => + Output.Write_Line ("excluded"); + + when True => + Output.Write_Line ("foreign source"); + end case; + end if; + + if Matched = True then + + -- Add source file name without unit name + + Name_Len := 0; + Add_Str_To_Name_Buffer (Canon (1 .. Last)); + Sources.Append + ((File_Name => Name_Find, + Unit_Name => No_Name, + Index => 0, + Spec => False)); + end if; + end if; + end if; + end loop File_Loop; + + Close (Dir); + end if; + + -- If Recursively is True, call itself for each subdirectory. + -- We do that, even when this directory has already been processed, + -- because all of its subdirectories may not have been processed. + + if Recursively then + Open (Dir, Dir_Name); + + loop + Read (Dir, Str, Last); + exit when Last = 0; + + -- Do not call itself for "." or ".." + + if Is_Directory + (Dir_Name & Directory_Separator & Str (1 .. Last)) + and then Str (1 .. Last) /= "." + and then Str (1 .. Last) /= ".." + then + Process_Directory + (Dir_Name & Directory_Separator & Str (1 .. Last), + Recursively => True); + end if; + end loop; + + Close (Dir); + end if; + end Process_Directory; + + -- Start of processing for Process + + begin + Processed_Directories.Set_Last (0); + + -- Process each directory + + for Index in Directories'Range loop + + declare + Dir_Name : constant String := Directories (Index).all; + Last : Natural := Dir_Name'Last; + Recursively : Boolean := False; + Found : Boolean; + Canonical : String (1 .. Dir_Name'Length) := Dir_Name; + + begin + Canonical_Case_File_Name (Canonical); + + Found := False; + for J in 1 .. Source_Directories.Last loop + if Source_Directories.Table (J).all = Canonical then + Found := True; + exit; + end if; + end loop; + + if not Found then + Source_Directories.Append (new String'(Canonical)); + end if; + + if Dir_Name'Length >= 4 + and then (Dir_Name (Last - 2 .. Last) = "/**") + then + Last := Last - 3; + Recursively := True; + end if; + + Process_Directory (Dir_Name (Dir_Name'First .. Last), Recursively); + end; + + end loop; + end Process; + + ---------------- + -- Write_Char -- + ---------------- + procedure Write_A_Char (C : Character) is + begin + Write_A_String ((1 => C)); + end Write_A_Char; + + --------------- + -- Write_Eol -- + --------------- + + procedure Write_Eol is + begin + Write_A_String ((1 => ASCII.LF)); + end Write_Eol; + + -------------------- + -- Write_A_String -- + -------------------- + + procedure Write_A_String (S : String) is + Str : String (1 .. S'Length); + + begin + if S'Length > 0 then + Str := S; + + if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length then + Prj.Com.Fail ("disk full"); + end if; + end if; + end Write_A_String; + +end Prj.Makr; diff --git a/gcc/ada/prj-makr.ads b/gcc/ada/prj-makr.ads new file mode 100644 index 000000000..91543a2ff --- /dev/null +++ b/gcc/ada/prj-makr.ads @@ -0,0 +1,88 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . M A K R -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Support for procedure Gnatname + +-- For arbitrary naming schemes, create or update a project file, or create a +-- configuration pragmas file. + +with System.Regexp; use System.Regexp; + +package Prj.Makr is + + procedure Initialize + (File_Path : String; + Project_File : Boolean; + Preproc_Switches : Argument_List; + Very_Verbose : Boolean; + Flags : Processing_Flags); + -- Start the creation of a configuration pragmas file or the creation or + -- modification of a project file, for gnatname. + -- + -- When Project_File is False, File_Path is the name of a configuration + -- pragmas file to create. When Project_File is True, File_Path is the name + -- of a project file to create if it does not exist or to modify if it + -- already exists. + -- + -- Preproc_Switches is a list of switches to be used when invoking the + -- compiler to get the name and kind of unit of a source file. + -- + -- Very_Verbose controls the verbosity of the output, in conjunction with + -- Opt.Verbose_Mode. + + type Regexp_List is array (Positive range <>) of Regexp; + + procedure Process + (Directories : Argument_List; + Name_Patterns : Regexp_List; + Excluded_Patterns : Regexp_List; + Foreign_Patterns : Regexp_List); + -- Look for source files in the specified directories, with the specified + -- patterns. + -- + -- Directories is the list of source directories where to look for sources. + -- + -- Name_Patterns is a potentially empty list of file name patterns to check + -- for Ada Sources. + -- + -- Excluded_Patterns is a potentially empty list of file name patterns that + -- should not be checked for Ada or non Ada sources. + -- + -- Foreign_Patterns is a potentially empty list of file name patterns to + -- check for non Ada sources. + -- + -- At least one of Name_Patterns and Foreign_Patterns is not empty + -- + -- Note that this procedure currently assumes that it is only used by + -- gnatname. If other processes start using it, then an additional + -- parameter would need to be added, and call to Osint.Program_Name + -- updated accordingly in the body. + + procedure Finalize; + -- Write the configuration pragmas file or the project file indicated in a + -- call to procedure Initialize, after one or several calls to procedure + -- Process. + +end Prj.Makr; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb new file mode 100644 index 000000000..5175d01ab --- /dev/null +++ b/gcc/ada/prj-nmsc.adb @@ -0,0 +1,8025 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . N M S C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2000-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Err_Vars; use Err_Vars; +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; +with Prj.Com; +with Prj.Err; use Prj.Err; +with Prj.Util; use Prj.Util; +with Sinput.P; +with Snames; use Snames; +with Targparm; use Targparm; + +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Directories; use Ada.Directories; +with Ada.Strings; use Ada.Strings; +with Ada.Strings.Fixed; use Ada.Strings.Fixed; +with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; + +with GNAT.Case_Util; use GNAT.Case_Util; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.Dynamic_HTables; +with GNAT.Regexp; use GNAT.Regexp; +with GNAT.Table; + +package body Prj.Nmsc is + + No_Continuation_String : aliased String := ""; + Continuation_String : aliased String := "\"; + -- Used in Check_Library for continuation error messages at the same + -- location. + + type Name_Location is record + Name : File_Name_Type; + -- Key is duplicated, so that it is known when using functions Get_First + -- and Get_Next, as these functions only return an Element. + + Location : Source_Ptr; + Source : Source_Id := No_Source; + Listed : Boolean := False; + Found : Boolean := False; + end record; + + No_Name_Location : constant Name_Location := + (Name => No_File, + Location => No_Location, + Source => No_Source, + Listed => False, + Found => False); + + package Source_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable + (Header_Num => Header_Num, + Element => Name_Location, + No_Element => No_Name_Location, + Key => File_Name_Type, + Hash => Hash, + Equal => "="); + -- File name information found in string list attribute (Source_Files or + -- Source_List_File). Except is set to True if source is a naming exception + -- in the project. Used to check that all referenced files were indeed + -- found on the disk. + + type Unit_Exception is record + Name : Name_Id; + -- Key is duplicated, so that it is known when using functions Get_First + -- and Get_Next, as these functions only return an Element. + + Spec : File_Name_Type; + Impl : File_Name_Type; + end record; + + No_Unit_Exception : constant Unit_Exception := (No_Name, No_File, No_File); + + package Unit_Exceptions_Htable is new GNAT.Dynamic_HTables.Simple_HTable + (Header_Num => Header_Num, + Element => Unit_Exception, + No_Element => No_Unit_Exception, + Key => Name_Id, + Hash => Hash, + Equal => "="); + -- Record special naming schemes for Ada units (name of spec file and name + -- of implementation file). The elements in this list come from the naming + -- exceptions specified in the project files. + + type File_Found is record + File : File_Name_Type := No_File; + Found : Boolean := False; + Location : Source_Ptr := No_Location; + end record; + + No_File_Found : constant File_Found := (No_File, False, No_Location); + + package Excluded_Sources_Htable is new GNAT.Dynamic_HTables.Simple_HTable + (Header_Num => Header_Num, + Element => File_Found, + No_Element => No_File_Found, + Key => File_Name_Type, + Hash => Hash, + Equal => "="); + -- A hash table to store the base names of excluded files, if any + + package Object_File_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable + (Header_Num => Header_Num, + Element => Source_Id, + No_Element => No_Source, + Key => File_Name_Type, + Hash => Hash, + Equal => "="); + -- A hash table to store the object file names for a project, to check that + -- two different sources have different object file names. + + type Project_Processing_Data is record + Project : Project_Id; + Source_Names : Source_Names_Htable.Instance; + Unit_Exceptions : Unit_Exceptions_Htable.Instance; + Excluded : Excluded_Sources_Htable.Instance; + + Source_List_File_Location : Source_Ptr; + -- Location of the Source_List_File attribute, for error messages + end record; + -- This is similar to Tree_Processing_Data, but contains project-specific + -- information which is only useful while processing the project, and can + -- be discarded as soon as we have finished processing the project + + package Files_Htable is new GNAT.Dynamic_HTables.Simple_HTable + (Header_Num => Header_Num, + Element => Source_Id, + No_Element => No_Source, + Key => File_Name_Type, + Hash => Hash, + Equal => "="); + -- Mapping from base file names to Source_Id (containing full info about + -- the source). + + type Tree_Processing_Data is record + Tree : Project_Tree_Ref; + Node_Tree : Prj.Tree.Project_Node_Tree_Ref; + File_To_Source : Files_Htable.Instance; + Flags : Prj.Processing_Flags; + end record; + -- Temporary data which is needed while parsing a project. It does not need + -- to be kept in memory once a project has been fully loaded, but is + -- necessary while performing consistency checks (duplicate sources,...) + -- This data must be initialized before processing any project, and the + -- same data is used for processing all projects in the tree. + + type Lib_Data is record + Name : Name_Id; + Proj : Project_Id; + end record; + + package Lib_Data_Table is new GNAT.Table + (Table_Component_Type => Lib_Data, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100); + -- A table to record library names in order to check that two library + -- projects do not have the same library names. + + procedure Initialize + (Data : out Tree_Processing_Data; + Tree : Project_Tree_Ref; + Node_Tree : Prj.Tree.Project_Node_Tree_Ref; + Flags : Prj.Processing_Flags); + -- Initialize Data + + procedure Free (Data : in out Tree_Processing_Data); + -- Free the memory occupied by Data + + procedure Check + (Project : Project_Id; + Data : in out Tree_Processing_Data); + -- Process the naming scheme for a single project + + procedure Initialize + (Data : in out Project_Processing_Data; + Project : Project_Id); + procedure Free (Data : in out Project_Processing_Data); + -- Initialize or free memory for a project-specific data + + procedure Find_Excluded_Sources + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data); + -- Find the list of files that should not be considered as source files + -- for this project. Sets the list in the Project.Excluded_Sources_Htable. + + procedure Override_Kind (Source : Source_Id; Kind : Source_Kind); + -- Override the reference kind for a source file. This properly updates + -- the unit data if necessary. + + procedure Load_Naming_Exceptions + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data); + -- All source files in Data.First_Source are considered as naming + -- exceptions, and copied into the Source_Names and Unit_Exceptions tables + -- as appropriate. + + type Search_Type is (Search_Files, Search_Directories); + + generic + with procedure Callback + (Path : Path_Information; + Pattern_Index : Natural); + procedure Expand_Subdirectory_Pattern + (Project : Project_Id; + Data : in out Tree_Processing_Data; + Patterns : String_List_Id; + Ignore : String_List_Id; + Search_For : Search_Type; + Resolve_Links : Boolean); + -- Search the subdirectories of Project's directory for files or + -- directories that match the globbing patterns found in Patterns (for + -- instance "**/*.adb"). Typically, Patterns will be the value of the + -- Source_Dirs or Excluded_Source_Dirs attributes. + -- Every time such a file or directory is found, the callback is called. + -- Resolve_Links indicates whether we should resolve links while + -- normalizing names. + -- In the callback, Pattern_Index is the index within Patterns where the + -- expanded pattern was found (1 for the first element of Patterns and + -- all its matching directories, then 2,...). + -- We use a generic and not an access-to-subprogram because in some cases + -- this code is compiled with the restriction No_Implicit_Dynamic_Code + + procedure Add_Source + (Id : out Source_Id; + Data : in out Tree_Processing_Data; + Project : Project_Id; + Source_Dir_Rank : Natural; + Lang_Id : Language_Ptr; + Kind : Source_Kind; + File_Name : File_Name_Type; + Display_File : File_Name_Type; + Naming_Exception : Boolean := False; + Path : Path_Information := No_Path_Information; + Alternate_Languages : Language_List := null; + Unit : Name_Id := No_Name; + Index : Int := 0; + Locally_Removed : Boolean := False; + Location : Source_Ptr := No_Location); + -- Add a new source to the different lists: list of all sources in the + -- project tree, list of source of a project and list of sources of a + -- language. + -- + -- If Path is specified, the file is also added to Source_Paths_HT. + -- + -- Location is used for error messages + + function Canonical_Case_File_Name (Name : Name_Id) return File_Name_Type; + -- Same as Osint.Canonical_Case_File_Name but applies to Name_Id. + -- This alters Name_Buffer + + function Suffix_Matches + (Filename : String; + Suffix : File_Name_Type) return Boolean; + -- True if the file name ends with the given suffix. Always returns False + -- if Suffix is No_Name. + + procedure Replace_Into_Name_Buffer + (Str : String; + Pattern : String; + Replacement : Character); + -- Copy Str into Name_Buffer, replacing Pattern with Replacement. Str is + -- converted to lower-case at the same time. + + procedure Check_Ada_Name (Name : String; Unit : out Name_Id); + -- Check that a name is a valid Ada unit name + + procedure Check_Package_Naming + (Project : Project_Id; + Data : in out Tree_Processing_Data); + -- Check the naming scheme part of Data, and initialize the naming scheme + -- data in the config of the various languages. + + procedure Check_Configuration + (Project : Project_Id; + Data : in out Tree_Processing_Data); + -- Check the configuration attributes for the project + + procedure Check_If_Externally_Built + (Project : Project_Id; + Data : in out Tree_Processing_Data); + -- Check attribute Externally_Built of project Project in project tree + -- Data.Tree and modify its data Data if it has the value "true". + + procedure Check_Interfaces + (Project : Project_Id; + Data : in out Tree_Processing_Data); + -- If a list of sources is specified in attribute Interfaces, set + -- In_Interfaces only for the sources specified in the list. + + procedure Check_Library_Attributes + (Project : Project_Id; + Data : in out Tree_Processing_Data); + -- Check the library attributes of project Project in project tree + -- and modify its data Data accordingly. + + procedure Check_Aggregate_Project + (Project : Project_Id; + Data : in out Tree_Processing_Data); + -- Check aggregate projects attributes, and find the list of aggregated + -- projects. They are stored as a "project_files" language in Project. + + procedure Check_Abstract_Project + (Project : Project_Id; + Data : in out Tree_Processing_Data); + -- Check abstract projects attributes + + procedure Check_Programming_Languages + (Project : Project_Id; + Data : in out Tree_Processing_Data); + -- Check attribute Languages for the project with data Data in project + -- tree Data.Tree and set the components of Data for all the programming + -- languages indicated in attribute Languages, if any. + + procedure Check_Stand_Alone_Library + (Project : Project_Id; + Data : in out Tree_Processing_Data); + -- Check if project Project in project tree Data.Tree is a Stand-Alone + -- Library project, and modify its data Data accordingly if it is one. + + function Compute_Directory_Last (Dir : String) return Natural; + -- Return the index of the last significant character in Dir. This is used + -- to avoid duplicate '/' (slash) characters at the end of directory names. + + procedure Search_Directories + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data; + For_All_Sources : Boolean); + -- Search the source directories to find the sources. If For_All_Sources is + -- True, check each regular file name against the naming schemes of the + -- various languages. Otherwise consider only the file names in hash table + -- Source_Names. If Allow_Duplicate_Basenames then files with identical + -- base names are permitted within a project for source-based languages + -- (never for unit based languages). + + procedure Check_File + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data; + Source_Dir_Rank : Natural; + Path : Path_Name_Type; + Display_Path : Path_Name_Type; + File_Name : File_Name_Type; + Display_File_Name : File_Name_Type; + Locally_Removed : Boolean; + For_All_Sources : Boolean); + -- Check if file File_Name is a valid source of the project. This is used + -- in multi-language mode only. When the file matches one of the naming + -- schemes, it is added to various htables through Add_Source and to + -- Source_Paths_Htable. + -- + -- File_Name is the same as Display_File_Name, but has been normalized. + -- They do not include the directory information. + -- + -- Path and Display_Path on the other hand are the full path to the file. + -- Path must have been normalized (canonical casing and possibly links + -- resolved). + -- + -- Source_Directory is the directory in which the file was found. It is + -- neither normalized nor has had links resolved, and must not end with a + -- a directory separator, to avoid duplicates later on. + -- + -- If For_All_Sources is True, then all possible file names are analyzed + -- otherwise only those currently set in the Source_Names hash table. + + procedure Check_File_Naming_Schemes + (In_Tree : Project_Tree_Ref; + Project : Project_Processing_Data; + File_Name : File_Name_Type; + Alternate_Languages : out Language_List; + Language : out Language_Ptr; + Display_Language_Name : out Name_Id; + Unit : out Name_Id; + Lang_Kind : out Language_Kind; + Kind : out Source_Kind); + -- Check if the file name File_Name conforms to one of the naming schemes + -- of the project. If the file does not match one of the naming schemes, + -- set Language to No_Language_Index. Filename is the name of the file + -- being investigated. It has been normalized (case-folded). File_Name is + -- the same value. + + procedure Get_Directories + (Project : Project_Id; + Data : in out Tree_Processing_Data); + -- Get the object directory, the exec directory and the source directories + -- of a project. + + procedure Get_Mains + (Project : Project_Id; + Data : in out Tree_Processing_Data); + -- Get the mains of a project from attribute Main, if it exists, and put + -- them in the project data. + + procedure Get_Sources_From_File + (Path : String; + Location : Source_Ptr; + Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data); + -- Get the list of sources from a text file and put them in hash table + -- Source_Names. + + procedure Find_Sources + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data); + -- Process the Source_Files and Source_List_File attributes, and store the + -- list of source files into the Source_Names htable. When these attributes + -- are not defined, find all files matching the naming schemes in the + -- source directories. If Allow_Duplicate_Basenames, then files with the + -- same base names are authorized within a project for source-based + -- languages (never for unit based languages) + + procedure Compute_Unit_Name + (File_Name : File_Name_Type; + Naming : Lang_Naming_Data; + Kind : out Source_Kind; + Unit : out Name_Id; + Project : Project_Processing_Data; + In_Tree : Project_Tree_Ref); + -- Check whether the file matches the naming scheme. If it does, + -- compute its unit name. If Unit is set to No_Name on exit, none of the + -- other out parameters are relevant. + + procedure Check_Illegal_Suffix + (Project : Project_Id; + Suffix : File_Name_Type; + Dot_Replacement : File_Name_Type; + Attribute_Name : String; + Location : Source_Ptr; + Data : in out Tree_Processing_Data); + -- Display an error message if the given suffix is illegal for some reason. + -- The name of the attribute we are testing is specified in Attribute_Name, + -- which is used in the error message. Location is the location where the + -- suffix is defined. + + procedure Locate_Directory + (Project : Project_Id; + Name : File_Name_Type; + Path : out Path_Information; + Dir_Exists : out Boolean; + Data : in out Tree_Processing_Data; + Create : String := ""; + Location : Source_Ptr := No_Location; + Must_Exist : Boolean := True; + Externally_Built : Boolean := False); + -- Locate a directory. Name is the directory name. Relative paths are + -- resolved relative to the project's directory. If the directory does not + -- exist and Setup_Projects is True and Create is a non null string, an + -- attempt is made to create the directory. If the directory does not + -- exist, it is either created if Setup_Projects is False (and then + -- returned), or simply returned without checking for its existence (if + -- Must_Exist is False) or No_Path_Information is returned. In all cases, + -- Dir_Exists indicates whether the directory now exists. Create is also + -- used for debugging traces to show which path we are computing. + + procedure Look_For_Sources + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data); + -- Find all the sources of project Project in project tree Data.Tree and + -- update its Data accordingly. This assumes that the special naming + -- exceptions have already been processed. + + function Path_Name_Of + (File_Name : File_Name_Type; + Directory : Path_Name_Type) return String; + -- Returns the path name of a (non project) file. Returns an empty string + -- if file cannot be found. + + procedure Remove_Source + (Tree : Project_Tree_Ref; + Id : Source_Id; + Replaced_By : Source_Id); + -- Remove a file from the list of sources of a project. This might be + -- because the file is replaced by another one in an extending project, + -- or because a file was added as a naming exception but was not found + -- in the end. + + procedure Report_No_Sources + (Project : Project_Id; + Lang_Name : String; + Data : Tree_Processing_Data; + Location : Source_Ptr; + Continuation : Boolean := False); + -- Report an error or a warning depending on the value of When_No_Sources + -- when there are no sources for language Lang_Name. + + procedure Show_Source_Dirs + (Project : Project_Id; In_Tree : Project_Tree_Ref); + -- List all the source directories of a project + + procedure Write_Attr (Name, Value : String); + -- Debug print a value for a specific property. Does nothing when not in + -- debug mode + + procedure Error_Or_Warning + (Flags : Processing_Flags; + Kind : Error_Warning; + Msg : String; + Location : Source_Ptr; + Project : Project_Id); + -- Emits either an error or warning message (or nothing), depending on Kind + + ---------------------- + -- Error_Or_Warning -- + ---------------------- + + procedure Error_Or_Warning + (Flags : Processing_Flags; + Kind : Error_Warning; + Msg : String; + Location : Source_Ptr; + Project : Project_Id) is + begin + case Kind is + when Error => Error_Msg (Flags, Msg, Location, Project); + when Warning => Error_Msg (Flags, "?" & Msg, Location, Project); + when Silent => null; + end case; + end Error_Or_Warning; + + ------------------------------ + -- Replace_Into_Name_Buffer -- + ------------------------------ + + procedure Replace_Into_Name_Buffer + (Str : String; + Pattern : String; + Replacement : Character) + is + Max : constant Integer := Str'Last - Pattern'Length + 1; + J : Positive; + + begin + Name_Len := 0; + + J := Str'First; + while J <= Str'Last loop + Name_Len := Name_Len + 1; + + if J <= Max + and then Str (J .. J + Pattern'Length - 1) = Pattern + then + Name_Buffer (Name_Len) := Replacement; + J := J + Pattern'Length; + + else + Name_Buffer (Name_Len) := GNAT.Case_Util.To_Lower (Str (J)); + J := J + 1; + end if; + end loop; + end Replace_Into_Name_Buffer; + + -------------------- + -- Suffix_Matches -- + -------------------- + + function Suffix_Matches + (Filename : String; + Suffix : File_Name_Type) return Boolean + is + Min_Prefix_Length : Natural := 0; + + begin + if Suffix = No_File or else Suffix = Empty_File then + return False; + end if; + + declare + Suf : String := Get_Name_String (Suffix); + + begin + -- On non case-sensitive systems, use proper suffix casing + + Canonical_Case_File_Name (Suf); + + -- The file name must end with the suffix (which is not an extension) + -- For instance a suffix "configure.in" must match a file with the + -- same name. To avoid dummy cases, though, a suffix starting with + -- '.' requires a file that is at least one character longer ('.cpp' + -- should not match a file with the same name) + + if Suf (Suf'First) = '.' then + Min_Prefix_Length := 1; + end if; + + return Filename'Length >= Suf'Length + Min_Prefix_Length + and then Filename + (Filename'Last - Suf'Length + 1 .. Filename'Last) = Suf; + end; + end Suffix_Matches; + + ---------------- + -- Write_Attr -- + ---------------- + + procedure Write_Attr (Name, Value : String) is + begin + if Current_Verbosity = High then + Write_Str (" " & Name & " = """); + Write_Str (Value); + Write_Char ('"'); + Write_Eol; + end if; + end Write_Attr; + + ---------------- + -- Add_Source -- + ---------------- + + procedure Add_Source + (Id : out Source_Id; + Data : in out Tree_Processing_Data; + Project : Project_Id; + Source_Dir_Rank : Natural; + Lang_Id : Language_Ptr; + Kind : Source_Kind; + File_Name : File_Name_Type; + Display_File : File_Name_Type; + Naming_Exception : Boolean := False; + Path : Path_Information := No_Path_Information; + Alternate_Languages : Language_List := null; + Unit : Name_Id := No_Name; + Index : Int := 0; + Locally_Removed : Boolean := False; + Location : Source_Ptr := No_Location) + is + Config : constant Language_Config := Lang_Id.Config; + UData : Unit_Index; + Add_Src : Boolean; + Source : Source_Id; + Prev_Unit : Unit_Index := No_Unit_Index; + + Source_To_Replace : Source_Id := No_Source; + + begin + -- Check if the same file name or unit is used in the prj tree + + Add_Src := True; + + if Unit /= No_Name then + Prev_Unit := Units_Htable.Get (Data.Tree.Units_HT, Unit); + end if; + + if Prev_Unit /= No_Unit_Index + and then (Kind = Impl or else Kind = Spec) + and then Prev_Unit.File_Names (Kind) /= null + then + -- Suspicious, we need to check later whether this is authorized + + Add_Src := False; + Source := Prev_Unit.File_Names (Kind); + + else + Source := Files_Htable.Get (Data.File_To_Source, File_Name); + + if Source /= No_Source + and then Source.Index = Index + then + Add_Src := False; + end if; + end if; + + -- Duplication of file/unit in same project is allowed if order of + -- source directories is known. + + if Add_Src = False then + Add_Src := True; + + if Project = Source.Project then + if Prev_Unit = No_Unit_Index then + if Data.Flags.Allow_Duplicate_Basenames then + Add_Src := True; + + elsif Source_Dir_Rank /= Source.Source_Dir_Rank then + Add_Src := False; + + else + Error_Msg_File_1 := File_Name; + Error_Msg + (Data.Flags, "duplicate source file name {", + Location, Project); + Add_Src := False; + end if; + + else + if Source_Dir_Rank /= Source.Source_Dir_Rank then + Add_Src := False; + + -- We might be seeing the same file through a different path + -- (for instance because of symbolic links). + + elsif Source.Path.Name /= Path.Name then + if not Source.Duplicate_Unit then + Error_Msg_Name_1 := Unit; + Error_Msg + (Data.Flags, "\duplicate unit %%", Location, Project); + Source.Duplicate_Unit := True; + end if; + + Add_Src := False; + end if; + end if; + + -- Do not allow the same unit name in different projects, except + -- if one is extending the other. + + -- For a file based language, the same file name replaces a file + -- in a project being extended, but it is allowed to have the same + -- file name in unrelated projects. + + elsif Is_Extending (Project, Source.Project) then + if not Locally_Removed then + Source_To_Replace := Source; + end if; + + elsif Prev_Unit /= No_Unit_Index + and then Prev_Unit.File_Names (Kind) /= null + and then not Source.Locally_Removed + then + -- Path is set if this is a source we found on the disk, in which + -- case we can provide more explicit error message. Path is unset + -- when the source is added from one of the naming exceptions in + -- the project. + + if Path /= No_Path_Information then + Error_Msg_Name_1 := Unit; + Error_Msg + (Data.Flags, + "unit %% cannot belong to several projects", + Location, Project); + + Error_Msg_Name_1 := Project.Name; + Error_Msg_Name_2 := Name_Id (Path.Display_Name); + Error_Msg + (Data.Flags, "\ project %%, %%", Location, Project); + + Error_Msg_Name_1 := Source.Project.Name; + Error_Msg_Name_2 := Name_Id (Source.Path.Display_Name); + Error_Msg + (Data.Flags, "\ project %%, %%", Location, Project); + + else + Error_Msg_Name_1 := Unit; + Error_Msg_Name_2 := Source.Project.Name; + Error_Msg + (Data.Flags, "unit %% already belongs to project %%", + Location, Project); + end if; + + Add_Src := False; + + elsif not Source.Locally_Removed + and then not Data.Flags.Allow_Duplicate_Basenames + and then Lang_Id.Config.Kind = Unit_Based + and then Source.Language.Config.Kind = Unit_Based + then + Error_Msg_File_1 := File_Name; + Error_Msg_File_2 := File_Name_Type (Source.Project.Name); + Error_Msg + (Data.Flags, + "{ is already a source of project {", Location, Project); + + -- Add the file anyway, to avoid further warnings like "language + -- unknown". + + Add_Src := True; + end if; + end if; + + if not Add_Src then + return; + end if; + + -- Add the new file + + Id := new Source_Data; + + if Current_Verbosity = High then + Write_Str ("Adding source File: "); + Write_Str (Get_Name_String (Display_File)); + + if Index /= 0 then + Write_Str (" at" & Index'Img); + end if; + + if Lang_Id.Config.Kind = Unit_Based then + Write_Str (" Unit: "); + + -- ??? in gprclean, it seems we sometimes pass an empty Unit name + -- (see test extended_projects). + + if Unit /= No_Name then + Write_Str (Get_Name_String (Unit)); + end if; + + Write_Str (" Kind: "); + Write_Str (Source_Kind'Image (Kind)); + end if; + + Write_Eol; + end if; + + Id.Project := Project; + Id.Location := Location; + Id.Source_Dir_Rank := Source_Dir_Rank; + Id.Language := Lang_Id; + Id.Kind := Kind; + Id.Alternate_Languages := Alternate_Languages; + Id.Locally_Removed := Locally_Removed; + Id.Index := Index; + Id.File := File_Name; + Id.Display_File := Display_File; + Id.Dep_Name := Dependency_Name + (File_Name, Lang_Id.Config.Dependency_Kind); + Id.Naming_Exception := Naming_Exception; + Id.Object := Object_Name + (File_Name, Config.Object_File_Suffix); + Id.Switches := Switches_Name (File_Name); + + -- Add the source id to the Unit_Sources_HT hash table, if the unit name + -- is not null. + + if Unit /= No_Name then + + -- Note: we might be creating a dummy unit here, when we in fact have + -- a separate. For instance, file file-bar.adb will initially be + -- assumed to be the IMPL of unit "file.bar". Only later on (in + -- Check_Object_Files) will we parse those units that only have an + -- impl and no spec to make sure whether we have a Separate in fact + -- (that significantly reduces the number of times we need to parse + -- the files, since we are then only interested in those with no + -- spec). We still need those dummy units in the table, since that's + -- the name we find in the ALI file + + UData := Units_Htable.Get (Data.Tree.Units_HT, Unit); + + if UData = No_Unit_Index then + UData := new Unit_Data; + UData.Name := Unit; + Units_Htable.Set (Data.Tree.Units_HT, Unit, UData); + end if; + + Id.Unit := UData; + + -- Note that this updates Unit information as well + + Override_Kind (Id, Kind); + end if; + + if Path /= No_Path_Information then + Id.Path := Path; + Source_Paths_Htable.Set (Data.Tree.Source_Paths_HT, Path.Name, Id); + end if; + + Id.Next_With_File_Name := + Source_Files_Htable.Get (Data.Tree.Source_Files_HT, File_Name); + Source_Files_Htable.Set (Data.Tree.Source_Files_HT, File_Name, Id); + + if Index /= 0 then + Project.Has_Multi_Unit_Sources := True; + end if; + + -- Add the source to the language list + + Id.Next_In_Lang := Lang_Id.First_Source; + Lang_Id.First_Source := Id; + + if Source_To_Replace /= No_Source then + Remove_Source (Data.Tree, Source_To_Replace, Id); + end if; + + if Data.Tree.Replaced_Source_Number > 0 and then + Replaced_Source_HTable.Get (Data.Tree.Replaced_Sources, Id.File) /= + No_File + then + Replaced_Source_HTable.Remove (Data.Tree.Replaced_Sources, Id.File); + Data.Tree.Replaced_Source_Number := + Data.Tree.Replaced_Source_Number - 1; + end if; + + Files_Htable.Set (Data.File_To_Source, File_Name, Id); + end Add_Source; + + ------------------------------ + -- Canonical_Case_File_Name -- + ------------------------------ + + function Canonical_Case_File_Name (Name : Name_Id) return File_Name_Type is + begin + if Osint.File_Names_Case_Sensitive then + return File_Name_Type (Name); + else + Get_Name_String (Name); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + return Name_Find; + end if; + end Canonical_Case_File_Name; + + ----------------------------- + -- Check_Aggregate_Project -- + ----------------------------- + + procedure Check_Aggregate_Project + (Project : Project_Id; + Data : in out Tree_Processing_Data) + is + Project_Files : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Project_Files, + Project.Decl.Attributes, + Data.Tree); + + procedure Found_Project_File (Path : Path_Information; Rank : Natural); + -- Comments required ??? + + procedure Expand_Project_Files is + new Expand_Subdirectory_Pattern (Callback => Found_Project_File); + -- Comments required ??? + + ------------------------ + -- Found_Project_File -- + ------------------------ + + procedure Found_Project_File (Path : Path_Information; Rank : Natural) is + pragma Unreferenced (Rank); + begin + if Current_Verbosity = High then + Write_Str (" Aggregates:"); + Write_Line (Get_Name_String (Path.Display_Name)); + end if; + end Found_Project_File; + + -- Start of processing for Check_Aggregate_Project + + begin + if Project_Files.Default then + Error_Msg_Name_1 := Snames.Name_Project_Files; + Error_Msg + (Data.Flags, + "Attribute %% must be specified in aggregate project", + Project.Location, Project); + return; + end if; + + -- Look for aggregated projects. For similarity with source files and + -- dirs, the aggregated project files are not searched for on the + -- project path, and are only found through the path specified in + -- the Project_Files attribute. + + Expand_Project_Files + (Project => Project, + Data => Data, + Patterns => Project_Files.Values, + Ignore => Nil_String, + Search_For => Search_Files, + Resolve_Links => Opt.Follow_Links_For_Files); + + end Check_Aggregate_Project; + + ---------------------------- + -- Check_Abstract_Project -- + ---------------------------- + + procedure Check_Abstract_Project + (Project : Project_Id; + Data : in out Tree_Processing_Data) + is + Source_Dirs : constant Variable_Value := + Util.Value_Of + (Name_Source_Dirs, + Project.Decl.Attributes, Data.Tree); + Source_Files : constant Variable_Value := + Util.Value_Of + (Name_Source_Files, + Project.Decl.Attributes, Data.Tree); + Source_List_File : constant Variable_Value := + Util.Value_Of + (Name_Source_List_File, + Project.Decl.Attributes, Data.Tree); + Languages : constant Variable_Value := + Util.Value_Of + (Name_Languages, + Project.Decl.Attributes, Data.Tree); + + begin + if Project.Source_Dirs /= Nil_String then + if Source_Dirs.Values = Nil_String + and then Source_Files.Values = Nil_String + and then Languages.Values = Nil_String + and then Source_List_File.Default + then + Project.Source_Dirs := Nil_String; + + else + Error_Msg + (Data.Flags, + "at least one of Source_Files, Source_Dirs or Languages " + & "must be declared empty for an abstract project", + Project.Location, Project); + end if; + end if; + end Check_Abstract_Project; + + ----------- + -- Check -- + ----------- + + procedure Check + (Project : Project_Id; + Data : in out Tree_Processing_Data) + is + Prj_Data : Project_Processing_Data; + + begin + Initialize (Prj_Data, Project); + + Check_If_Externally_Built (Project, Data); + + if Project.Qualifier /= Aggregate then + Get_Directories (Project, Data); + Check_Programming_Languages (Project, Data); + + if Current_Verbosity = High then + Show_Source_Dirs (Project, Data.Tree); + end if; + end if; + + case Project.Qualifier is + when Aggregate => Check_Aggregate_Project (Project, Data); + when Dry => Check_Abstract_Project (Project, Data); + when others => null; + end case; + + -- Check configuration. This must be done even for gnatmake (even though + -- no user configuration file was provided) since the default config we + -- generate indicates whether libraries are supported for instance. + + Check_Configuration (Project, Data); + + if Project.Qualifier /= Aggregate then + Check_Library_Attributes (Project, Data); + Check_Package_Naming (Project, Data); + Look_For_Sources (Prj_Data, Data); + Check_Interfaces (Project, Data); + + if Project.Library then + Check_Stand_Alone_Library (Project, Data); + end if; + + Get_Mains (Project, Data); + end if; + + Free (Prj_Data); + end Check; + + -------------------- + -- Check_Ada_Name -- + -------------------- + + procedure Check_Ada_Name (Name : String; Unit : out Name_Id) is + The_Name : String := Name; + Real_Name : Name_Id; + Need_Letter : Boolean := True; + Last_Underscore : Boolean := False; + OK : Boolean := The_Name'Length > 0; + First : Positive; + + function Is_Reserved (Name : Name_Id) return Boolean; + function Is_Reserved (S : String) return Boolean; + -- Check that the given name is not an Ada 95 reserved word. The reason + -- for the Ada 95 here is that we do not want to exclude the case of an + -- Ada 95 unit called Interface (for example). In Ada 2005, such a unit + -- name would be rejected anyway by the compiler. That means there is no + -- requirement that the project file parser reject this. + + ----------------- + -- Is_Reserved -- + ----------------- + + function Is_Reserved (S : String) return Boolean is + begin + Name_Len := 0; + Add_Str_To_Name_Buffer (S); + return Is_Reserved (Name_Find); + end Is_Reserved; + + ----------------- + -- Is_Reserved -- + ----------------- + + function Is_Reserved (Name : Name_Id) return Boolean is + begin + if Get_Name_Table_Byte (Name) /= 0 + and then Name /= Name_Project + and then Name /= Name_Extends + and then Name /= Name_External + and then Name not in Ada_2005_Reserved_Words + then + Unit := No_Name; + + if Current_Verbosity = High then + Write_Str (The_Name); + Write_Line (" is an Ada reserved word."); + end if; + + return True; + + else + return False; + end if; + end Is_Reserved; + + -- Start of processing for Check_Ada_Name + + begin + To_Lower (The_Name); + + Name_Len := The_Name'Length; + Name_Buffer (1 .. Name_Len) := The_Name; + + -- Special cases of children of packages A, G, I and S on VMS + + if OpenVMS_On_Target + and then Name_Len > 3 + and then Name_Buffer (2 .. 3) = "__" + and then + ((Name_Buffer (1) = 'a') or else + (Name_Buffer (1) = 'g') or else + (Name_Buffer (1) = 'i') or else + (Name_Buffer (1) = 's')) + then + Name_Buffer (2) := '.'; + Name_Buffer (3 .. Name_Len - 1) := Name_Buffer (4 .. Name_Len); + Name_Len := Name_Len - 1; + end if; + + Real_Name := Name_Find; + + if Is_Reserved (Real_Name) then + return; + end if; + + First := The_Name'First; + + for Index in The_Name'Range loop + if Need_Letter then + + -- We need a letter (at the beginning, and following a dot), + -- but we don't have one. + + if Is_Letter (The_Name (Index)) then + Need_Letter := False; + + else + OK := False; + + if Current_Verbosity = High then + Write_Int (Types.Int (Index)); + Write_Str (": '"); + Write_Char (The_Name (Index)); + Write_Line ("' is not a letter."); + end if; + + exit; + end if; + + elsif Last_Underscore + and then (The_Name (Index) = '_' or else The_Name (Index) = '.') + then + -- Two underscores are illegal, and a dot cannot follow + -- an underscore. + + OK := False; + + if Current_Verbosity = High then + Write_Int (Types.Int (Index)); + Write_Str (": '"); + Write_Char (The_Name (Index)); + Write_Line ("' is illegal here."); + end if; + + exit; + + elsif The_Name (Index) = '.' then + + -- First, check if the name before the dot is not a reserved word + + if Is_Reserved (The_Name (First .. Index - 1)) then + return; + end if; + + First := Index + 1; + + -- We need a letter after a dot + + Need_Letter := True; + + elsif The_Name (Index) = '_' then + Last_Underscore := True; + + else + -- We need an letter or a digit + + Last_Underscore := False; + + if not Is_Alphanumeric (The_Name (Index)) then + OK := False; + + if Current_Verbosity = High then + Write_Int (Types.Int (Index)); + Write_Str (": '"); + Write_Char (The_Name (Index)); + Write_Line ("' is not alphanumeric."); + end if; + + exit; + end if; + end if; + end loop; + + -- Cannot end with an underscore or a dot + + OK := OK and then not Need_Letter and then not Last_Underscore; + + if OK then + if First /= Name'First and then + Is_Reserved (The_Name (First .. The_Name'Last)) + then + return; + end if; + + Unit := Real_Name; + + else + -- Signal a problem with No_Name + + Unit := No_Name; + end if; + end Check_Ada_Name; + + ------------------------- + -- Check_Configuration -- + ------------------------- + + procedure Check_Configuration + (Project : Project_Id; + Data : in out Tree_Processing_Data) + is + Dot_Replacement : File_Name_Type := No_File; + Casing : Casing_Type := All_Lower_Case; + Separate_Suffix : File_Name_Type := No_File; + + Lang_Index : Language_Ptr := No_Language_Index; + -- The index of the language data being checked + + Prev_Index : Language_Ptr := No_Language_Index; + -- The index of the previous language + + procedure Process_Project_Level_Simple_Attributes; + -- Process the simple attributes at the project level + + procedure Process_Project_Level_Array_Attributes; + -- Process the associate array attributes at the project level + + procedure Process_Packages; + -- Read the packages of the project + + ---------------------- + -- Process_Packages -- + ---------------------- + + procedure Process_Packages is + Packages : Package_Id; + Element : Package_Element; + + procedure Process_Binder (Arrays : Array_Id); + -- Process the associate array attributes of package Binder + + procedure Process_Builder (Attributes : Variable_Id); + -- Process the simple attributes of package Builder + + procedure Process_Compiler (Arrays : Array_Id); + -- Process the associate array attributes of package Compiler + + procedure Process_Naming (Attributes : Variable_Id); + -- Process the simple attributes of package Naming + + procedure Process_Naming (Arrays : Array_Id); + -- Process the associate array attributes of package Naming + + procedure Process_Linker (Attributes : Variable_Id); + -- Process the simple attributes of package Linker of a + -- configuration project. + + -------------------- + -- Process_Binder -- + -------------------- + + procedure Process_Binder (Arrays : Array_Id) is + Current_Array_Id : Array_Id; + Current_Array : Array_Data; + Element_Id : Array_Element_Id; + Element : Array_Element; + + begin + -- Process the associative array attribute of package Binder + + Current_Array_Id := Arrays; + while Current_Array_Id /= No_Array loop + Current_Array := Data.Tree.Arrays.Table (Current_Array_Id); + + Element_Id := Current_Array.Value; + while Element_Id /= No_Array_Element loop + Element := Data.Tree.Array_Elements.Table (Element_Id); + + if Element.Index /= All_Other_Names then + + -- Get the name of the language + + Lang_Index := + Get_Language_From_Name + (Project, Get_Name_String (Element.Index)); + + if Lang_Index /= No_Language_Index then + case Current_Array.Name is + when Name_Driver => + + -- Attribute Driver () + + Lang_Index.Config.Binder_Driver := + File_Name_Type (Element.Value.Value); + + when Name_Required_Switches => + Put + (Into_List => + Lang_Index.Config.Binder_Required_Switches, + From_List => Element.Value.Values, + In_Tree => Data.Tree); + + when Name_Prefix => + + -- Attribute Prefix () + + Lang_Index.Config.Binder_Prefix := + Element.Value.Value; + + when Name_Objects_Path => + + -- Attribute Objects_Path () + + Lang_Index.Config.Objects_Path := + Element.Value.Value; + + when Name_Objects_Path_File => + + -- Attribute Objects_Path () + + Lang_Index.Config.Objects_Path_File := + Element.Value.Value; + + when others => + null; + end case; + end if; + end if; + + Element_Id := Element.Next; + end loop; + + Current_Array_Id := Current_Array.Next; + end loop; + end Process_Binder; + + --------------------- + -- Process_Builder -- + --------------------- + + procedure Process_Builder (Attributes : Variable_Id) is + Attribute_Id : Variable_Id; + Attribute : Variable; + + begin + -- Process non associated array attribute from package Builder + + Attribute_Id := Attributes; + while Attribute_Id /= No_Variable loop + Attribute := + Data.Tree.Variable_Elements.Table (Attribute_Id); + + if not Attribute.Value.Default then + if Attribute.Name = Name_Executable_Suffix then + + -- Attribute Executable_Suffix: the suffix of the + -- executables. + + Project.Config.Executable_Suffix := + Attribute.Value.Value; + end if; + end if; + + Attribute_Id := Attribute.Next; + end loop; + end Process_Builder; + + ---------------------- + -- Process_Compiler -- + ---------------------- + + procedure Process_Compiler (Arrays : Array_Id) is + Current_Array_Id : Array_Id; + Current_Array : Array_Data; + Element_Id : Array_Element_Id; + Element : Array_Element; + List : String_List_Id; + + begin + -- Process the associative array attribute of package Compiler + + Current_Array_Id := Arrays; + while Current_Array_Id /= No_Array loop + Current_Array := Data.Tree.Arrays.Table (Current_Array_Id); + + Element_Id := Current_Array.Value; + while Element_Id /= No_Array_Element loop + Element := Data.Tree.Array_Elements.Table (Element_Id); + + if Element.Index /= All_Other_Names then + + -- Get the name of the language + + Lang_Index := Get_Language_From_Name + (Project, Get_Name_String (Element.Index)); + + if Lang_Index /= No_Language_Index then + case Current_Array.Name is + when Name_Dependency_Switches => + + -- Attribute Dependency_Switches () + + if Lang_Index.Config.Dependency_Kind = None then + Lang_Index.Config.Dependency_Kind := Makefile; + end if; + + List := Element.Value.Values; + + if List /= Nil_String then + Put (Into_List => + Lang_Index.Config.Dependency_Option, + From_List => List, + In_Tree => Data.Tree); + end if; + + when Name_Dependency_Driver => + + -- Attribute Dependency_Driver () + + if Lang_Index.Config.Dependency_Kind = None then + Lang_Index.Config.Dependency_Kind := Makefile; + end if; + + List := Element.Value.Values; + + if List /= Nil_String then + Put (Into_List => + Lang_Index.Config.Compute_Dependency, + From_List => List, + In_Tree => Data.Tree); + end if; + + when Name_Include_Switches => + + -- Attribute Include_Switches () + + List := Element.Value.Values; + + if List = Nil_String then + Error_Msg + (Data.Flags, "include option cannot be null", + Element.Value.Location, Project); + end if; + + Put (Into_List => Lang_Index.Config.Include_Option, + From_List => List, + In_Tree => Data.Tree); + + when Name_Include_Path => + + -- Attribute Include_Path () + + Lang_Index.Config.Include_Path := + Element.Value.Value; + + when Name_Include_Path_File => + + -- Attribute Include_Path_File () + + Lang_Index.Config.Include_Path_File := + Element.Value.Value; + + when Name_Driver => + + -- Attribute Driver () + + Lang_Index.Config.Compiler_Driver := + File_Name_Type (Element.Value.Value); + + when Name_Required_Switches | + Name_Leading_Required_Switches => + Put (Into_List => + Lang_Index.Config. + Compiler_Leading_Required_Switches, + From_List => Element.Value.Values, + In_Tree => Data.Tree); + + when Name_Trailing_Required_Switches => + Put (Into_List => + Lang_Index.Config. + Compiler_Trailing_Required_Switches, + From_List => Element.Value.Values, + In_Tree => Data.Tree); + + when Name_Multi_Unit_Switches => + Put (Into_List => + Lang_Index.Config.Multi_Unit_Switches, + From_List => Element.Value.Values, + In_Tree => Data.Tree); + + when Name_Multi_Unit_Object_Separator => + Get_Name_String (Element.Value.Value); + + if Name_Len /= 1 then + Error_Msg + (Data.Flags, + "multi-unit object separator must have " & + "a single character", + Element.Value.Location, Project); + + elsif Name_Buffer (1) = ' ' then + Error_Msg + (Data.Flags, + "multi-unit object separator cannot be " & + "a space", + Element.Value.Location, Project); + + else + Lang_Index.Config.Multi_Unit_Object_Separator := + Name_Buffer (1); + end if; + + when Name_Path_Syntax => + begin + Lang_Index.Config.Path_Syntax := + Path_Syntax_Kind'Value + (Get_Name_String (Element.Value.Value)); + + exception + when Constraint_Error => + Error_Msg + (Data.Flags, + "invalid value for Path_Syntax", + Element.Value.Location, Project); + end; + + when Name_Object_File_Suffix => + if Get_Name_String (Element.Value.Value) = "" then + Error_Msg + (Data.Flags, + "object file suffix cannot be empty", + Element.Value.Location, Project); + + else + Lang_Index.Config.Object_File_Suffix := + Element.Value.Value; + end if; + + when Name_Object_File_Switches => + Put (Into_List => + Lang_Index.Config.Object_File_Switches, + From_List => Element.Value.Values, + In_Tree => Data.Tree); + + when Name_Pic_Option => + + -- Attribute Compiler_Pic_Option () + + List := Element.Value.Values; + + if List = Nil_String then + Error_Msg + (Data.Flags, + "compiler PIC option cannot be null", + Element.Value.Location, Project); + end if; + + Put (Into_List => + Lang_Index.Config.Compilation_PIC_Option, + From_List => List, + In_Tree => Data.Tree); + + when Name_Mapping_File_Switches => + + -- Attribute Mapping_File_Switches () + + List := Element.Value.Values; + + if List = Nil_String then + Error_Msg + (Data.Flags, + "mapping file switches cannot be null", + Element.Value.Location, Project); + end if; + + Put (Into_List => + Lang_Index.Config.Mapping_File_Switches, + From_List => List, + In_Tree => Data.Tree); + + when Name_Mapping_Spec_Suffix => + + -- Attribute Mapping_Spec_Suffix () + + Lang_Index.Config.Mapping_Spec_Suffix := + File_Name_Type (Element.Value.Value); + + when Name_Mapping_Body_Suffix => + + -- Attribute Mapping_Body_Suffix () + + Lang_Index.Config.Mapping_Body_Suffix := + File_Name_Type (Element.Value.Value); + + when Name_Config_File_Switches => + + -- Attribute Config_File_Switches () + + List := Element.Value.Values; + + if List = Nil_String then + Error_Msg + (Data.Flags, + "config file switches cannot be null", + Element.Value.Location, Project); + end if; + + Put (Into_List => + Lang_Index.Config.Config_File_Switches, + From_List => List, + In_Tree => Data.Tree); + + when Name_Objects_Path => + + -- Attribute Objects_Path () + + Lang_Index.Config.Objects_Path := + Element.Value.Value; + + when Name_Objects_Path_File => + + -- Attribute Objects_Path_File () + + Lang_Index.Config.Objects_Path_File := + Element.Value.Value; + + when Name_Config_Body_File_Name => + + -- Attribute Config_Body_File_Name () + + Lang_Index.Config.Config_Body := + Element.Value.Value; + + when Name_Config_Body_File_Name_Index => + + -- Attribute Config_Body_File_Name_Index + -- ( < Language > ) + + Lang_Index.Config.Config_Body_Index := + Element.Value.Value; + + when Name_Config_Body_File_Name_Pattern => + + -- Attribute Config_Body_File_Name_Pattern + -- () + + Lang_Index.Config.Config_Body_Pattern := + Element.Value.Value; + + when Name_Config_Spec_File_Name => + + -- Attribute Config_Spec_File_Name () + + Lang_Index.Config.Config_Spec := + Element.Value.Value; + + when Name_Config_Spec_File_Name_Index => + + -- Attribute Config_Spec_File_Name_Index + -- ( < Language > ) + + Lang_Index.Config.Config_Spec_Index := + Element.Value.Value; + + when Name_Config_Spec_File_Name_Pattern => + + -- Attribute Config_Spec_File_Name_Pattern + -- () + + Lang_Index.Config.Config_Spec_Pattern := + Element.Value.Value; + + when Name_Config_File_Unique => + + -- Attribute Config_File_Unique () + + begin + Lang_Index.Config.Config_File_Unique := + Boolean'Value + (Get_Name_String (Element.Value.Value)); + exception + when Constraint_Error => + Error_Msg + (Data.Flags, + "illegal value for Config_File_Unique", + Element.Value.Location, Project); + end; + + when others => + null; + end case; + end if; + end if; + + Element_Id := Element.Next; + end loop; + + Current_Array_Id := Current_Array.Next; + end loop; + end Process_Compiler; + + -------------------- + -- Process_Naming -- + -------------------- + + procedure Process_Naming (Attributes : Variable_Id) is + Attribute_Id : Variable_Id; + Attribute : Variable; + + begin + -- Process non associated array attribute from package Naming + + Attribute_Id := Attributes; + while Attribute_Id /= No_Variable loop + Attribute := Data.Tree.Variable_Elements.Table (Attribute_Id); + + if not Attribute.Value.Default then + if Attribute.Name = Name_Separate_Suffix then + + -- Attribute Separate_Suffix + + Get_Name_String (Attribute.Value.Value); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Separate_Suffix := Name_Find; + + elsif Attribute.Name = Name_Casing then + + -- Attribute Casing + + begin + Casing := + Value (Get_Name_String (Attribute.Value.Value)); + + exception + when Constraint_Error => + Error_Msg + (Data.Flags, + "invalid value for Casing", + Attribute.Value.Location, Project); + end; + + elsif Attribute.Name = Name_Dot_Replacement then + + -- Attribute Dot_Replacement + + Dot_Replacement := File_Name_Type (Attribute.Value.Value); + + end if; + end if; + + Attribute_Id := Attribute.Next; + end loop; + end Process_Naming; + + procedure Process_Naming (Arrays : Array_Id) is + Current_Array_Id : Array_Id; + Current_Array : Array_Data; + Element_Id : Array_Element_Id; + Element : Array_Element; + + begin + -- Process the associative array attribute of package Naming + + Current_Array_Id := Arrays; + while Current_Array_Id /= No_Array loop + Current_Array := Data.Tree.Arrays.Table (Current_Array_Id); + + Element_Id := Current_Array.Value; + while Element_Id /= No_Array_Element loop + Element := Data.Tree.Array_Elements.Table (Element_Id); + + -- Get the name of the language + + Lang_Index := Get_Language_From_Name + (Project, Get_Name_String (Element.Index)); + + if Lang_Index /= No_Language_Index then + case Current_Array.Name is + when Name_Spec_Suffix | Name_Specification_Suffix => + + -- Attribute Spec_Suffix () + + Get_Name_String (Element.Value.Value); + Canonical_Case_File_Name + (Name_Buffer (1 .. Name_Len)); + Lang_Index.Config.Naming_Data.Spec_Suffix := + Name_Find; + + when Name_Implementation_Suffix | Name_Body_Suffix => + + Get_Name_String (Element.Value.Value); + Canonical_Case_File_Name + (Name_Buffer (1 .. Name_Len)); + + -- Attribute Body_Suffix () + + Lang_Index.Config.Naming_Data.Body_Suffix := + Name_Find; + Lang_Index.Config.Naming_Data.Separate_Suffix := + Lang_Index.Config.Naming_Data.Body_Suffix; + + when others => + null; + end case; + end if; + + Element_Id := Element.Next; + end loop; + + Current_Array_Id := Current_Array.Next; + end loop; + end Process_Naming; + + -------------------- + -- Process_Linker -- + -------------------- + + procedure Process_Linker (Attributes : Variable_Id) is + Attribute_Id : Variable_Id; + Attribute : Variable; + + begin + -- Process non associated array attribute from package Linker + + Attribute_Id := Attributes; + while Attribute_Id /= No_Variable loop + Attribute := + Data.Tree.Variable_Elements.Table (Attribute_Id); + + if not Attribute.Value.Default then + if Attribute.Name = Name_Driver then + + -- Attribute Linker'Driver: the default linker to use + + Project.Config.Linker := + Path_Name_Type (Attribute.Value.Value); + + -- Linker'Driver is also used to link shared libraries + -- if the obsolescent attribute Library_GCC has not been + -- specified. + + if Project.Config.Shared_Lib_Driver = No_File then + Project.Config.Shared_Lib_Driver := + File_Name_Type (Attribute.Value.Value); + end if; + + elsif Attribute.Name = Name_Required_Switches then + + -- Attribute Required_Switches: the minimum trailing + -- options to use when invoking the linker + + Put (Into_List => + Project.Config.Trailing_Linker_Required_Switches, + From_List => Attribute.Value.Values, + In_Tree => Data.Tree); + + elsif Attribute.Name = Name_Map_File_Option then + Project.Config.Map_File_Option := Attribute.Value.Value; + + elsif Attribute.Name = Name_Max_Command_Line_Length then + begin + Project.Config.Max_Command_Line_Length := + Natural'Value (Get_Name_String + (Attribute.Value.Value)); + + exception + when Constraint_Error => + Error_Msg + (Data.Flags, + "value must be positive or equal to 0", + Attribute.Value.Location, Project); + end; + + elsif Attribute.Name = Name_Response_File_Format then + declare + Name : Name_Id; + + begin + Get_Name_String (Attribute.Value.Value); + To_Lower (Name_Buffer (1 .. Name_Len)); + Name := Name_Find; + + if Name = Name_None then + Project.Config.Resp_File_Format := None; + + elsif Name = Name_Gnu then + Project.Config.Resp_File_Format := GNU; + + elsif Name = Name_Object_List then + Project.Config.Resp_File_Format := Object_List; + + elsif Name = Name_Option_List then + Project.Config.Resp_File_Format := Option_List; + + elsif Name_Buffer (1 .. Name_Len) = "gcc" then + Project.Config.Resp_File_Format := GCC; + + elsif Name_Buffer (1 .. Name_Len) = "gcc_gnu" then + Project.Config.Resp_File_Format := GCC_GNU; + + elsif + Name_Buffer (1 .. Name_Len) = "gcc_option_list" + then + Project.Config.Resp_File_Format := GCC_Option_List; + + elsif + Name_Buffer (1 .. Name_Len) = "gcc_object_list" + then + Project.Config.Resp_File_Format := GCC_Object_List; + + else + Error_Msg + (Data.Flags, + "illegal response file format", + Attribute.Value.Location, Project); + end if; + end; + + elsif Attribute.Name = Name_Response_File_Switches then + Put (Into_List => Project.Config.Resp_File_Options, + From_List => Attribute.Value.Values, + In_Tree => Data.Tree); + end if; + end if; + + Attribute_Id := Attribute.Next; + end loop; + end Process_Linker; + + -- Start of processing for Process_Packages + + begin + Packages := Project.Decl.Packages; + while Packages /= No_Package loop + Element := Data.Tree.Packages.Table (Packages); + + case Element.Name is + when Name_Binder => + + -- Process attributes of package Binder + + Process_Binder (Element.Decl.Arrays); + + when Name_Builder => + + -- Process attributes of package Builder + + Process_Builder (Element.Decl.Attributes); + + when Name_Compiler => + + -- Process attributes of package Compiler + + Process_Compiler (Element.Decl.Arrays); + + when Name_Linker => + + -- Process attributes of package Linker + + Process_Linker (Element.Decl.Attributes); + + when Name_Naming => + + -- Process attributes of package Naming + + Process_Naming (Element.Decl.Attributes); + Process_Naming (Element.Decl.Arrays); + + when others => + null; + end case; + + Packages := Element.Next; + end loop; + end Process_Packages; + + --------------------------------------------- + -- Process_Project_Level_Simple_Attributes -- + --------------------------------------------- + + procedure Process_Project_Level_Simple_Attributes is + Attribute_Id : Variable_Id; + Attribute : Variable; + List : String_List_Id; + + begin + -- Process non associated array attribute at project level + + Attribute_Id := Project.Decl.Attributes; + while Attribute_Id /= No_Variable loop + Attribute := + Data.Tree.Variable_Elements.Table (Attribute_Id); + + if not Attribute.Value.Default then + if Attribute.Name = Name_Target then + + -- Attribute Target: the target specified + + Project.Config.Target := Attribute.Value.Value; + + elsif Attribute.Name = Name_Library_Builder then + + -- Attribute Library_Builder: the application to invoke + -- to build libraries. + + Project.Config.Library_Builder := + Path_Name_Type (Attribute.Value.Value); + + elsif Attribute.Name = Name_Archive_Builder then + + -- Attribute Archive_Builder: the archive builder + -- (usually "ar") and its minimum options (usually "cr"). + + List := Attribute.Value.Values; + + if List = Nil_String then + Error_Msg + (Data.Flags, + "archive builder cannot be null", + Attribute.Value.Location, Project); + end if; + + Put (Into_List => Project.Config.Archive_Builder, + From_List => List, + In_Tree => Data.Tree); + + elsif Attribute.Name = Name_Archive_Builder_Append_Option then + + -- Attribute Archive_Builder: the archive builder + -- (usually "ar") and its minimum options (usually "cr"). + + List := Attribute.Value.Values; + + if List /= Nil_String then + Put + (Into_List => + Project.Config.Archive_Builder_Append_Option, + From_List => List, + In_Tree => Data.Tree); + end if; + + elsif Attribute.Name = Name_Archive_Indexer then + + -- Attribute Archive_Indexer: the optional archive + -- indexer (usually "ranlib") with its minimum options + -- (usually none). + + List := Attribute.Value.Values; + + if List = Nil_String then + Error_Msg + (Data.Flags, + "archive indexer cannot be null", + Attribute.Value.Location, Project); + end if; + + Put (Into_List => Project.Config.Archive_Indexer, + From_List => List, + In_Tree => Data.Tree); + + elsif Attribute.Name = Name_Library_Partial_Linker then + + -- Attribute Library_Partial_Linker: the optional linker + -- driver with its minimum options, to partially link + -- archives. + + List := Attribute.Value.Values; + + if List = Nil_String then + Error_Msg + (Data.Flags, + "partial linker cannot be null", + Attribute.Value.Location, Project); + end if; + + Put (Into_List => Project.Config.Lib_Partial_Linker, + From_List => List, + In_Tree => Data.Tree); + + elsif Attribute.Name = Name_Library_GCC then + Project.Config.Shared_Lib_Driver := + File_Name_Type (Attribute.Value.Value); + Error_Msg + (Data.Flags, + "?Library_'G'C'C is an obsolescent attribute, " & + "use Linker''Driver instead", + Attribute.Value.Location, Project); + + elsif Attribute.Name = Name_Archive_Suffix then + Project.Config.Archive_Suffix := + File_Name_Type (Attribute.Value.Value); + + elsif Attribute.Name = Name_Linker_Executable_Option then + + -- Attribute Linker_Executable_Option: optional options + -- to specify an executable name. Defaults to "-o". + + List := Attribute.Value.Values; + + if List = Nil_String then + Error_Msg + (Data.Flags, + "linker executable option cannot be null", + Attribute.Value.Location, Project); + end if; + + Put (Into_List => Project.Config.Linker_Executable_Option, + From_List => List, + In_Tree => Data.Tree); + + elsif Attribute.Name = Name_Linker_Lib_Dir_Option then + + -- Attribute Linker_Lib_Dir_Option: optional options + -- to specify a library search directory. Defaults to + -- "-L". + + Get_Name_String (Attribute.Value.Value); + + if Name_Len = 0 then + Error_Msg + (Data.Flags, + "linker library directory option cannot be empty", + Attribute.Value.Location, Project); + end if; + + Project.Config.Linker_Lib_Dir_Option := + Attribute.Value.Value; + + elsif Attribute.Name = Name_Linker_Lib_Name_Option then + + -- Attribute Linker_Lib_Name_Option: optional options + -- to specify the name of a library to be linked in. + -- Defaults to "-l". + + Get_Name_String (Attribute.Value.Value); + + if Name_Len = 0 then + Error_Msg + (Data.Flags, + "linker library name option cannot be empty", + Attribute.Value.Location, Project); + end if; + + Project.Config.Linker_Lib_Name_Option := + Attribute.Value.Value; + + elsif Attribute.Name = Name_Run_Path_Option then + + -- Attribute Run_Path_Option: optional options to + -- specify a path for libraries. + + List := Attribute.Value.Values; + + if List /= Nil_String then + Put (Into_List => Project.Config.Run_Path_Option, + From_List => List, + In_Tree => Data.Tree); + end if; + + elsif Attribute.Name = Name_Run_Path_Origin then + Get_Name_String (Attribute.Value.Value); + + if Name_Len = 0 then + Error_Msg + (Data.Flags, + "run path origin cannot be empty", + Attribute.Value.Location, Project); + end if; + + Project.Config.Run_Path_Origin := Attribute.Value.Value; + + elsif Attribute.Name = Name_Library_Install_Name_Option then + Project.Config.Library_Install_Name_Option := + Attribute.Value.Value; + + elsif Attribute.Name = Name_Separate_Run_Path_Options then + declare + pragma Unsuppress (All_Checks); + begin + Project.Config.Separate_Run_Path_Options := + Boolean'Value (Get_Name_String (Attribute.Value.Value)); + exception + when Constraint_Error => + Error_Msg + (Data.Flags, + "invalid value """ & + Get_Name_String (Attribute.Value.Value) & + """ for Separate_Run_Path_Options", + Attribute.Value.Location, Project); + end; + + elsif Attribute.Name = Name_Library_Support then + declare + pragma Unsuppress (All_Checks); + begin + Project.Config.Lib_Support := + Library_Support'Value (Get_Name_String + (Attribute.Value.Value)); + exception + when Constraint_Error => + Error_Msg + (Data.Flags, + "invalid value """ & + Get_Name_String (Attribute.Value.Value) & + """ for Library_Support", + Attribute.Value.Location, Project); + end; + + elsif Attribute.Name = Name_Shared_Library_Prefix then + Project.Config.Shared_Lib_Prefix := + File_Name_Type (Attribute.Value.Value); + + elsif Attribute.Name = Name_Shared_Library_Suffix then + Project.Config.Shared_Lib_Suffix := + File_Name_Type (Attribute.Value.Value); + + elsif Attribute.Name = Name_Symbolic_Link_Supported then + declare + pragma Unsuppress (All_Checks); + begin + Project.Config.Symbolic_Link_Supported := + Boolean'Value (Get_Name_String + (Attribute.Value.Value)); + exception + when Constraint_Error => + Error_Msg + (Data.Flags, + "invalid value """ + & Get_Name_String (Attribute.Value.Value) + & """ for Symbolic_Link_Supported", + Attribute.Value.Location, Project); + end; + + elsif + Attribute.Name = Name_Library_Major_Minor_Id_Supported + then + declare + pragma Unsuppress (All_Checks); + begin + Project.Config.Lib_Maj_Min_Id_Supported := + Boolean'Value (Get_Name_String + (Attribute.Value.Value)); + exception + when Constraint_Error => + Error_Msg + (Data.Flags, + "invalid value """ & + Get_Name_String (Attribute.Value.Value) & + """ for Library_Major_Minor_Id_Supported", + Attribute.Value.Location, Project); + end; + + elsif Attribute.Name = Name_Library_Auto_Init_Supported then + declare + pragma Unsuppress (All_Checks); + begin + Project.Config.Auto_Init_Supported := + Boolean'Value (Get_Name_String (Attribute.Value.Value)); + exception + when Constraint_Error => + Error_Msg + (Data.Flags, + "invalid value """ + & Get_Name_String (Attribute.Value.Value) + & """ for Library_Auto_Init_Supported", + Attribute.Value.Location, Project); + end; + + elsif Attribute.Name = Name_Shared_Library_Minimum_Switches then + List := Attribute.Value.Values; + + if List /= Nil_String then + Put (Into_List => Project.Config.Shared_Lib_Min_Options, + From_List => List, + In_Tree => Data.Tree); + end if; + + elsif Attribute.Name = Name_Library_Version_Switches then + List := Attribute.Value.Values; + + if List /= Nil_String then + Put (Into_List => Project.Config.Lib_Version_Options, + From_List => List, + In_Tree => Data.Tree); + end if; + end if; + end if; + + Attribute_Id := Attribute.Next; + end loop; + end Process_Project_Level_Simple_Attributes; + + -------------------------------------------- + -- Process_Project_Level_Array_Attributes -- + -------------------------------------------- + + procedure Process_Project_Level_Array_Attributes is + Current_Array_Id : Array_Id; + Current_Array : Array_Data; + Element_Id : Array_Element_Id; + Element : Array_Element; + List : String_List_Id; + + begin + -- Process the associative array attributes at project level + + Current_Array_Id := Project.Decl.Arrays; + while Current_Array_Id /= No_Array loop + Current_Array := Data.Tree.Arrays.Table (Current_Array_Id); + + Element_Id := Current_Array.Value; + while Element_Id /= No_Array_Element loop + Element := Data.Tree.Array_Elements.Table (Element_Id); + + -- Get the name of the language + + Lang_Index := + Get_Language_From_Name + (Project, Get_Name_String (Element.Index)); + + if Lang_Index /= No_Language_Index then + case Current_Array.Name is + when Name_Inherit_Source_Path => + List := Element.Value.Values; + + if List /= Nil_String then + Put + (Into_List => + Lang_Index.Config.Include_Compatible_Languages, + From_List => List, + In_Tree => Data.Tree, + Lower_Case => True); + end if; + + when Name_Toolchain_Description => + + -- Attribute Toolchain_Description () + + Lang_Index.Config.Toolchain_Description := + Element.Value.Value; + + when Name_Toolchain_Version => + + -- Attribute Toolchain_Version () + + Lang_Index.Config.Toolchain_Version := + Element.Value.Value; + + -- For Ada, set proper checksum computation mode + + if Lang_Index.Name = Name_Ada then + declare + Vers : constant String := + Get_Name_String (Element.Value.Value); + pragma Assert (Vers'First = 1); + + begin + -- Version 6.3 or earlier + + if Vers'Length >= 8 + and then Vers (1 .. 5) = "GNAT " + and then Vers (7) = '.' + and then + (Vers (6) < '6' + or else + (Vers (6) = '6' and then Vers (8) < '4')) + then + Checksum_GNAT_6_3 := True; + + -- Version 5.03 or earlier + + if Vers (6) < '5' + or else (Vers (6) = '5' + and then Vers (Vers'Last) < '4') + then + Checksum_GNAT_5_03 := True; + + -- Version 5.02 or earlier + + if Vers (6) /= '5' + or else Vers (Vers'Last) < '3' + then + Checksum_Accumulate_Token_Checksum := + False; + end if; + end if; + end if; + end; + end if; + + when Name_Runtime_Library_Dir => + + -- Attribute Runtime_Library_Dir () + + Lang_Index.Config.Runtime_Library_Dir := + Element.Value.Value; + + when Name_Runtime_Source_Dir => + + -- Attribute Runtime_Library_Dir () + + Lang_Index.Config.Runtime_Source_Dir := + Element.Value.Value; + + when Name_Object_Generated => + declare + pragma Unsuppress (All_Checks); + Value : Boolean; + + begin + Value := + Boolean'Value + (Get_Name_String (Element.Value.Value)); + + Lang_Index.Config.Object_Generated := Value; + + -- If no object is generated, no object may be + -- linked. + + if not Value then + Lang_Index.Config.Objects_Linked := False; + end if; + + exception + when Constraint_Error => + Error_Msg + (Data.Flags, + "invalid value """ + & Get_Name_String (Element.Value.Value) + & """ for Object_Generated", + Element.Value.Location, Project); + end; + + when Name_Objects_Linked => + declare + pragma Unsuppress (All_Checks); + Value : Boolean; + + begin + Value := + Boolean'Value + (Get_Name_String (Element.Value.Value)); + + -- No change if Object_Generated is False, as this + -- forces Objects_Linked to be False too. + + if Lang_Index.Config.Object_Generated then + Lang_Index.Config.Objects_Linked := Value; + end if; + + exception + when Constraint_Error => + Error_Msg + (Data.Flags, + "invalid value """ + & Get_Name_String (Element.Value.Value) + & """ for Objects_Linked", + Element.Value.Location, Project); + end; + when others => + null; + end case; + end if; + + Element_Id := Element.Next; + end loop; + + Current_Array_Id := Current_Array.Next; + end loop; + end Process_Project_Level_Array_Attributes; + + -- Start of processing for Check_Configuration + + begin + Process_Project_Level_Simple_Attributes; + Process_Project_Level_Array_Attributes; + Process_Packages; + + -- For unit based languages, set Casing, Dot_Replacement and + -- Separate_Suffix in Naming_Data. + + Lang_Index := Project.Languages; + while Lang_Index /= No_Language_Index loop + if Lang_Index.Name = Name_Ada then + Lang_Index.Config.Naming_Data.Casing := Casing; + Lang_Index.Config.Naming_Data.Dot_Replacement := Dot_Replacement; + + if Separate_Suffix /= No_File then + Lang_Index.Config.Naming_Data.Separate_Suffix := + Separate_Suffix; + end if; + + exit; + end if; + + Lang_Index := Lang_Index.Next; + end loop; + + -- Give empty names to various prefixes/suffixes, if they have not + -- been specified in the configuration. + + if Project.Config.Archive_Suffix = No_File then + Project.Config.Archive_Suffix := Empty_File; + end if; + + if Project.Config.Shared_Lib_Prefix = No_File then + Project.Config.Shared_Lib_Prefix := Empty_File; + end if; + + if Project.Config.Shared_Lib_Suffix = No_File then + Project.Config.Shared_Lib_Suffix := Empty_File; + end if; + + Lang_Index := Project.Languages; + while Lang_Index /= No_Language_Index loop + + -- For all languages, Compiler_Driver needs to be specified. This is + -- only needed if we do intend to compile (not in GPS for instance). + + if Data.Flags.Compiler_Driver_Mandatory + and then Lang_Index.Config.Compiler_Driver = No_File + then + Error_Msg_Name_1 := Lang_Index.Display_Name; + Error_Msg + (Data.Flags, + "?no compiler specified for language %%" & + ", ignoring all its sources", + No_Location, Project); + + if Lang_Index = Project.Languages then + Project.Languages := Lang_Index.Next; + else + Prev_Index.Next := Lang_Index.Next; + end if; + + elsif Lang_Index.Name = Name_Ada then + Prev_Index := Lang_Index; + + -- For unit based languages, Dot_Replacement, Spec_Suffix and + -- Body_Suffix need to be specified. + + if Lang_Index.Config.Naming_Data.Dot_Replacement = No_File then + Error_Msg + (Data.Flags, + "Dot_Replacement not specified for Ada", + No_Location, Project); + end if; + + if Lang_Index.Config.Naming_Data.Spec_Suffix = No_File then + Error_Msg + (Data.Flags, + "Spec_Suffix not specified for Ada", + No_Location, Project); + end if; + + if Lang_Index.Config.Naming_Data.Body_Suffix = No_File then + Error_Msg + (Data.Flags, + "Body_Suffix not specified for Ada", + No_Location, Project); + end if; + + else + Prev_Index := Lang_Index; + + -- For file based languages, either Spec_Suffix or Body_Suffix + -- need to be specified. + + if Data.Flags.Require_Sources_Other_Lang + and then Lang_Index.Config.Naming_Data.Spec_Suffix = No_File + and then Lang_Index.Config.Naming_Data.Body_Suffix = No_File + then + Error_Msg_Name_1 := Lang_Index.Display_Name; + Error_Msg + (Data.Flags, + "no suffixes specified for %%", + No_Location, Project); + end if; + end if; + + Lang_Index := Lang_Index.Next; + end loop; + end Check_Configuration; + + ------------------------------- + -- Check_If_Externally_Built -- + ------------------------------- + + procedure Check_If_Externally_Built + (Project : Project_Id; + Data : in out Tree_Processing_Data) + is + Externally_Built : constant Variable_Value := + Util.Value_Of + (Name_Externally_Built, + Project.Decl.Attributes, Data.Tree); + + begin + if not Externally_Built.Default then + Get_Name_String (Externally_Built.Value); + To_Lower (Name_Buffer (1 .. Name_Len)); + + if Name_Buffer (1 .. Name_Len) = "true" then + Project.Externally_Built := True; + + elsif Name_Buffer (1 .. Name_Len) /= "false" then + Error_Msg (Data.Flags, + "Externally_Built may only be true or false", + Externally_Built.Location, Project); + end if; + end if; + + -- A virtual project extending an externally built project is itself + -- externally built. + + if Project.Virtual and then Project.Extends /= No_Project then + Project.Externally_Built := Project.Extends.Externally_Built; + end if; + + if Current_Verbosity = High then + Write_Str ("Project is "); + + if not Project.Externally_Built then + Write_Str ("not "); + end if; + + Write_Line ("externally built."); + end if; + end Check_If_Externally_Built; + + ---------------------- + -- Check_Interfaces -- + ---------------------- + + procedure Check_Interfaces + (Project : Project_Id; + Data : in out Tree_Processing_Data) + is + Interfaces : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Interfaces, + Project.Decl.Attributes, + Data.Tree); + + Library_Interface : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Interface, + Project.Decl.Attributes, + Data.Tree); + + List : String_List_Id; + Element : String_Element; + Name : File_Name_Type; + Iter : Source_Iterator; + Source : Source_Id; + Project_2 : Project_Id; + Other : Source_Id; + + begin + if not Interfaces.Default then + + -- Set In_Interfaces to False for all sources. It will be set to True + -- later for the sources in the Interfaces list. + + Project_2 := Project; + while Project_2 /= No_Project loop + Iter := For_Each_Source (Data.Tree, Project_2); + loop + Source := Prj.Element (Iter); + exit when Source = No_Source; + Source.In_Interfaces := False; + Next (Iter); + end loop; + + Project_2 := Project_2.Extends; + end loop; + + List := Interfaces.Values; + while List /= Nil_String loop + Element := Data.Tree.String_Elements.Table (List); + Name := Canonical_Case_File_Name (Element.Value); + + Project_2 := Project; + Big_Loop : + while Project_2 /= No_Project loop + Iter := For_Each_Source (Data.Tree, Project_2); + + loop + Source := Prj.Element (Iter); + exit when Source = No_Source; + + if Source.File = Name then + if not Source.Locally_Removed then + Source.In_Interfaces := True; + Source.Declared_In_Interfaces := True; + + Other := Other_Part (Source); + + if Other /= No_Source then + Other.In_Interfaces := True; + Other.Declared_In_Interfaces := True; + end if; + + if Current_Verbosity = High then + Write_Str (" interface: "); + Write_Line (Get_Name_String (Source.Path.Name)); + end if; + end if; + + exit Big_Loop; + end if; + + Next (Iter); + end loop; + + Project_2 := Project_2.Extends; + end loop Big_Loop; + + if Source = No_Source then + Error_Msg_File_1 := File_Name_Type (Element.Value); + Error_Msg_Name_1 := Project.Name; + + Error_Msg + (Data.Flags, + "{ cannot be an interface of project %% " + & "as it is not one of its sources", + Element.Location, Project); + end if; + + List := Element.Next; + end loop; + + Project.Interfaces_Defined := True; + + elsif Project.Library and then not Library_Interface.Default then + + -- Set In_Interfaces to False for all sources. It will be set to True + -- later for the sources in the Library_Interface list. + + Project_2 := Project; + while Project_2 /= No_Project loop + Iter := For_Each_Source (Data.Tree, Project_2); + loop + Source := Prj.Element (Iter); + exit when Source = No_Source; + Source.In_Interfaces := False; + Next (Iter); + end loop; + + Project_2 := Project_2.Extends; + end loop; + + List := Library_Interface.Values; + while List /= Nil_String loop + Element := Data.Tree.String_Elements.Table (List); + Get_Name_String (Element.Value); + To_Lower (Name_Buffer (1 .. Name_Len)); + Name := Name_Find; + + Project_2 := Project; + Big_Loop_2 : + while Project_2 /= No_Project loop + Iter := For_Each_Source (Data.Tree, Project_2); + + loop + Source := Prj.Element (Iter); + exit when Source = No_Source; + + if Source.Unit /= No_Unit_Index and then + Source.Unit.Name = Name_Id (Name) + then + if not Source.Locally_Removed then + Source.In_Interfaces := True; + Source.Declared_In_Interfaces := True; + + Other := Other_Part (Source); + + if Other /= No_Source then + Other.In_Interfaces := True; + Other.Declared_In_Interfaces := True; + end if; + + if Current_Verbosity = High then + Write_Str (" interface: "); + Write_Line (Get_Name_String (Source.Path.Name)); + end if; + end if; + + exit Big_Loop_2; + end if; + + Next (Iter); + end loop; + + Project_2 := Project_2.Extends; + end loop Big_Loop_2; + + List := Element.Next; + end loop; + + Project.Interfaces_Defined := True; + + elsif Project.Extends /= No_Project + and then Project.Extends.Interfaces_Defined + then + Project.Interfaces_Defined := True; + + Iter := For_Each_Source (Data.Tree, Project); + loop + Source := Prj.Element (Iter); + exit when Source = No_Source; + + if not Source.Declared_In_Interfaces then + Source.In_Interfaces := False; + end if; + + Next (Iter); + end loop; + end if; + end Check_Interfaces; + + -------------------------- + -- Check_Package_Naming -- + -------------------------- + + procedure Check_Package_Naming + (Project : Project_Id; + Data : in out Tree_Processing_Data) + is + Naming_Id : constant Package_Id := + Util.Value_Of + (Name_Naming, Project.Decl.Packages, Data.Tree); + Naming : Package_Element; + + Ada_Body_Suffix_Loc : Source_Ptr := No_Location; + + procedure Check_Naming; + -- Check the validity of the Naming package (suffixes valid, ...) + + procedure Check_Common + (Dot_Replacement : in out File_Name_Type; + Casing : in out Casing_Type; + Casing_Defined : out Boolean; + Separate_Suffix : in out File_Name_Type; + Sep_Suffix_Loc : out Source_Ptr); + -- Check attributes common + + procedure Process_Exceptions_File_Based + (Lang_Id : Language_Ptr; + Kind : Source_Kind); + procedure Process_Exceptions_Unit_Based + (Lang_Id : Language_Ptr; + Kind : Source_Kind); + -- Process the naming exceptions for the two types of languages + + procedure Initialize_Naming_Data; + -- Initialize internal naming data for the various languages + + ------------------ + -- Check_Common -- + ------------------ + + procedure Check_Common + (Dot_Replacement : in out File_Name_Type; + Casing : in out Casing_Type; + Casing_Defined : out Boolean; + Separate_Suffix : in out File_Name_Type; + Sep_Suffix_Loc : out Source_Ptr) + is + Dot_Repl : constant Variable_Value := + Util.Value_Of + (Name_Dot_Replacement, + Naming.Decl.Attributes, + Data.Tree); + Casing_String : constant Variable_Value := + Util.Value_Of + (Name_Casing, + Naming.Decl.Attributes, + Data.Tree); + Sep_Suffix : constant Variable_Value := + Util.Value_Of + (Name_Separate_Suffix, + Naming.Decl.Attributes, + Data.Tree); + Dot_Repl_Loc : Source_Ptr; + + begin + Sep_Suffix_Loc := No_Location; + + if not Dot_Repl.Default then + pragma Assert + (Dot_Repl.Kind = Single, "Dot_Replacement is not a string"); + + if Length_Of_Name (Dot_Repl.Value) = 0 then + Error_Msg + (Data.Flags, "Dot_Replacement cannot be empty", + Dot_Repl.Location, Project); + end if; + + Dot_Replacement := Canonical_Case_File_Name (Dot_Repl.Value); + Dot_Repl_Loc := Dot_Repl.Location; + + declare + Repl : constant String := Get_Name_String (Dot_Replacement); + + begin + -- Dot_Replacement cannot + -- - be empty + -- - start or end with an alphanumeric + -- - be a single '_' + -- - start with an '_' followed by an alphanumeric + -- - contain a '.' except if it is "." + + if Repl'Length = 0 + or else Is_Alphanumeric (Repl (Repl'First)) + or else Is_Alphanumeric (Repl (Repl'Last)) + or else (Repl (Repl'First) = '_' + and then + (Repl'Length = 1 + or else + Is_Alphanumeric (Repl (Repl'First + 1)))) + or else (Repl'Length > 1 + and then + Index (Source => Repl, Pattern => ".") /= 0) + then + Error_Msg + (Data.Flags, + '"' & Repl & + """ is illegal for Dot_Replacement.", + Dot_Repl_Loc, Project); + end if; + end; + end if; + + if Dot_Replacement /= No_File then + Write_Attr + ("Dot_Replacement", Get_Name_String (Dot_Replacement)); + end if; + + Casing_Defined := False; + + if not Casing_String.Default then + pragma Assert + (Casing_String.Kind = Single, "Casing is not a string"); + + declare + Casing_Image : constant String := + Get_Name_String (Casing_String.Value); + + begin + if Casing_Image'Length = 0 then + Error_Msg + (Data.Flags, + "Casing cannot be an empty string", + Casing_String.Location, Project); + end if; + + Casing := Value (Casing_Image); + Casing_Defined := True; + + exception + when Constraint_Error => + Name_Len := Casing_Image'Length; + Name_Buffer (1 .. Name_Len) := Casing_Image; + Err_Vars.Error_Msg_Name_1 := Name_Find; + Error_Msg + (Data.Flags, + "%% is not a correct Casing", + Casing_String.Location, Project); + end; + end if; + + Write_Attr ("Casing", Image (Casing)); + + if not Sep_Suffix.Default then + if Length_Of_Name (Sep_Suffix.Value) = 0 then + Error_Msg + (Data.Flags, + "Separate_Suffix cannot be empty", + Sep_Suffix.Location, Project); + + else + Separate_Suffix := Canonical_Case_File_Name (Sep_Suffix.Value); + Sep_Suffix_Loc := Sep_Suffix.Location; + + Check_Illegal_Suffix + (Project, Separate_Suffix, + Dot_Replacement, "Separate_Suffix", Sep_Suffix.Location, + Data); + end if; + end if; + + if Separate_Suffix /= No_File then + Write_Attr + ("Separate_Suffix", Get_Name_String (Separate_Suffix)); + end if; + end Check_Common; + + ----------------------------------- + -- Process_Exceptions_File_Based -- + ----------------------------------- + + procedure Process_Exceptions_File_Based + (Lang_Id : Language_Ptr; + Kind : Source_Kind) + is + Lang : constant Name_Id := Lang_Id.Name; + Exceptions : Array_Element_Id; + Exception_List : Variable_Value; + Element_Id : String_List_Id; + Element : String_Element; + File_Name : File_Name_Type; + Source : Source_Id; + + begin + case Kind is + when Impl | Sep => + Exceptions := + Value_Of + (Name_Implementation_Exceptions, + In_Arrays => Naming.Decl.Arrays, + In_Tree => Data.Tree); + + when Spec => + Exceptions := + Value_Of + (Name_Specification_Exceptions, + In_Arrays => Naming.Decl.Arrays, + In_Tree => Data.Tree); + end case; + + Exception_List := + Value_Of + (Index => Lang, + In_Array => Exceptions, + In_Tree => Data.Tree); + + if Exception_List /= Nil_Variable_Value then + Element_Id := Exception_List.Values; + while Element_Id /= Nil_String loop + Element := Data.Tree.String_Elements.Table (Element_Id); + File_Name := Canonical_Case_File_Name (Element.Value); + + Source := + Source_Files_Htable.Get + (Data.Tree.Source_Files_HT, File_Name); + while Source /= No_Source + and then Source.Project /= Project + loop + Source := Source.Next_With_File_Name; + end loop; + + if Source = No_Source then + Add_Source + (Id => Source, + Data => Data, + Project => Project, + Source_Dir_Rank => 0, + Lang_Id => Lang_Id, + Kind => Kind, + File_Name => File_Name, + Display_File => File_Name_Type (Element.Value), + Naming_Exception => True, + Location => Element.Location); + + else + -- Check if the file name is already recorded for another + -- language or another kind. + + if Source.Language /= Lang_Id then + Error_Msg + (Data.Flags, + "the same file cannot be a source of two languages", + Element.Location, Project); + + elsif Source.Kind /= Kind then + Error_Msg + (Data.Flags, + "the same file cannot be a source and a template", + Element.Location, Project); + end if; + + -- If the file is already recorded for the same + -- language and the same kind, it means that the file + -- name appears several times in the *_Exceptions + -- attribute; so there is nothing to do. + end if; + + Element_Id := Element.Next; + end loop; + end if; + end Process_Exceptions_File_Based; + + ----------------------------------- + -- Process_Exceptions_Unit_Based -- + ----------------------------------- + + procedure Process_Exceptions_Unit_Based + (Lang_Id : Language_Ptr; + Kind : Source_Kind) + is + Lang : constant Name_Id := Lang_Id.Name; + Exceptions : Array_Element_Id; + Element : Array_Element; + Unit : Name_Id; + Index : Int; + File_Name : File_Name_Type; + Source : Source_Id; + + begin + case Kind is + when Impl | Sep => + Exceptions := + Value_Of + (Name_Body, + In_Arrays => Naming.Decl.Arrays, + In_Tree => Data.Tree); + + if Exceptions = No_Array_Element then + Exceptions := + Value_Of + (Name_Implementation, + In_Arrays => Naming.Decl.Arrays, + In_Tree => Data.Tree); + end if; + + when Spec => + Exceptions := + Value_Of + (Name_Spec, + In_Arrays => Naming.Decl.Arrays, + In_Tree => Data.Tree); + + if Exceptions = No_Array_Element then + Exceptions := + Value_Of + (Name_Spec, + In_Arrays => Naming.Decl.Arrays, + In_Tree => Data.Tree); + end if; + end case; + + while Exceptions /= No_Array_Element loop + Element := Data.Tree.Array_Elements.Table (Exceptions); + File_Name := Canonical_Case_File_Name (Element.Value.Value); + + Get_Name_String (Element.Index); + To_Lower (Name_Buffer (1 .. Name_Len)); + Unit := Name_Find; + Index := Element.Value.Index; + + -- For Ada, check if it is a valid unit name + + if Lang = Name_Ada then + Get_Name_String (Element.Index); + Check_Ada_Name (Name_Buffer (1 .. Name_Len), Unit); + + if Unit = No_Name then + Err_Vars.Error_Msg_Name_1 := Element.Index; + Error_Msg + (Data.Flags, + "%% is not a valid unit name.", + Element.Value.Location, Project); + end if; + end if; + + if Unit /= No_Name then + Add_Source + (Id => Source, + Data => Data, + Project => Project, + Source_Dir_Rank => 0, + Lang_Id => Lang_Id, + Kind => Kind, + File_Name => File_Name, + Display_File => File_Name_Type (Element.Value.Value), + Unit => Unit, + Index => Index, + Location => Element.Value.Location, + Naming_Exception => True); + end if; + + Exceptions := Element.Next; + end loop; + end Process_Exceptions_Unit_Based; + + ------------------ + -- Check_Naming -- + ------------------ + + procedure Check_Naming is + Dot_Replacement : File_Name_Type := + File_Name_Type + (First_Name_Id + Character'Pos ('-')); + Separate_Suffix : File_Name_Type := No_File; + Casing : Casing_Type := All_Lower_Case; + Casing_Defined : Boolean; + Lang_Id : Language_Ptr; + Sep_Suffix_Loc : Source_Ptr; + Suffix : Variable_Value; + Lang : Name_Id; + + begin + Check_Common + (Dot_Replacement => Dot_Replacement, + Casing => Casing, + Casing_Defined => Casing_Defined, + Separate_Suffix => Separate_Suffix, + Sep_Suffix_Loc => Sep_Suffix_Loc); + + -- For all unit based languages, if any, set the specified value + -- of Dot_Replacement, Casing and/or Separate_Suffix. Do not + -- systematically overwrite, since the defaults come from the + -- configuration file. + + if Dot_Replacement /= No_File + or else Casing_Defined + or else Separate_Suffix /= No_File + then + Lang_Id := Project.Languages; + while Lang_Id /= No_Language_Index loop + if Lang_Id.Config.Kind = Unit_Based then + if Dot_Replacement /= No_File then + Lang_Id.Config.Naming_Data.Dot_Replacement := + Dot_Replacement; + end if; + + if Casing_Defined then + Lang_Id.Config.Naming_Data.Casing := Casing; + end if; + end if; + + Lang_Id := Lang_Id.Next; + end loop; + end if; + + -- Next, get the spec and body suffixes + + Lang_Id := Project.Languages; + while Lang_Id /= No_Language_Index loop + Lang := Lang_Id.Name; + + -- Spec_Suffix + + Suffix := Value_Of + (Name => Lang, + Attribute_Or_Array_Name => Name_Spec_Suffix, + In_Package => Naming_Id, + In_Tree => Data.Tree); + + if Suffix = Nil_Variable_Value then + Suffix := Value_Of + (Name => Lang, + Attribute_Or_Array_Name => Name_Specification_Suffix, + In_Package => Naming_Id, + In_Tree => Data.Tree); + end if; + + if Suffix /= Nil_Variable_Value then + Lang_Id.Config.Naming_Data.Spec_Suffix := + File_Name_Type (Suffix.Value); + + Check_Illegal_Suffix + (Project, + Lang_Id.Config.Naming_Data.Spec_Suffix, + Lang_Id.Config.Naming_Data.Dot_Replacement, + "Spec_Suffix", Suffix.Location, Data); + + Write_Attr + ("Spec_Suffix", + Get_Name_String (Lang_Id.Config.Naming_Data.Spec_Suffix)); + end if; + + -- Body_Suffix + + Suffix := + Value_Of + (Name => Lang, + Attribute_Or_Array_Name => Name_Body_Suffix, + In_Package => Naming_Id, + In_Tree => Data.Tree); + + if Suffix = Nil_Variable_Value then + Suffix := + Value_Of + (Name => Lang, + Attribute_Or_Array_Name => Name_Implementation_Suffix, + In_Package => Naming_Id, + In_Tree => Data.Tree); + end if; + + if Suffix /= Nil_Variable_Value then + Lang_Id.Config.Naming_Data.Body_Suffix := + File_Name_Type (Suffix.Value); + + -- The default value of separate suffix should be the same as + -- the body suffix, so we need to compute that first. + + if Separate_Suffix = No_File then + Lang_Id.Config.Naming_Data.Separate_Suffix := + Lang_Id.Config.Naming_Data.Body_Suffix; + Write_Attr + ("Sep_Suffix", + Get_Name_String + (Lang_Id.Config.Naming_Data.Separate_Suffix)); + else + Lang_Id.Config.Naming_Data.Separate_Suffix := + Separate_Suffix; + end if; + + Check_Illegal_Suffix + (Project, + Lang_Id.Config.Naming_Data.Body_Suffix, + Lang_Id.Config.Naming_Data.Dot_Replacement, + "Body_Suffix", Suffix.Location, Data); + + Write_Attr + ("Body_Suffix", + Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix)); + + elsif Separate_Suffix /= No_File then + Lang_Id.Config.Naming_Data.Separate_Suffix := Separate_Suffix; + end if; + + -- Spec_Suffix cannot be equal to Body_Suffix or Separate_Suffix, + -- since that would cause a clear ambiguity. Note that we do allow + -- a Spec_Suffix to have the same termination as one of these, + -- which causes a potential ambiguity, but we resolve that by + -- matching the longest possible suffix. + + if Lang_Id.Config.Naming_Data.Spec_Suffix /= No_File + and then Lang_Id.Config.Naming_Data.Spec_Suffix = + Lang_Id.Config.Naming_Data.Body_Suffix + then + Error_Msg + (Data.Flags, + "Body_Suffix (""" + & Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix) + & """) cannot be the same as Spec_Suffix.", + Ada_Body_Suffix_Loc, Project); + end if; + + if Lang_Id.Config.Naming_Data.Body_Suffix /= + Lang_Id.Config.Naming_Data.Separate_Suffix + and then Lang_Id.Config.Naming_Data.Spec_Suffix = + Lang_Id.Config.Naming_Data.Separate_Suffix + then + Error_Msg + (Data.Flags, + "Separate_Suffix (""" + & Get_Name_String + (Lang_Id.Config.Naming_Data.Separate_Suffix) + & """) cannot be the same as Spec_Suffix.", + Sep_Suffix_Loc, Project); + end if; + + Lang_Id := Lang_Id.Next; + end loop; + + -- Get the naming exceptions for all languages + + for Kind in Spec_Or_Body loop + Lang_Id := Project.Languages; + while Lang_Id /= No_Language_Index loop + case Lang_Id.Config.Kind is + when File_Based => + Process_Exceptions_File_Based (Lang_Id, Kind); + + when Unit_Based => + Process_Exceptions_Unit_Based (Lang_Id, Kind); + end case; + + Lang_Id := Lang_Id.Next; + end loop; + end loop; + end Check_Naming; + + ---------------------------- + -- Initialize_Naming_Data -- + ---------------------------- + + procedure Initialize_Naming_Data is + Specs : Array_Element_Id := + Util.Value_Of + (Name_Spec_Suffix, + Naming.Decl.Arrays, + Data.Tree); + + Impls : Array_Element_Id := + Util.Value_Of + (Name_Body_Suffix, + Naming.Decl.Arrays, + Data.Tree); + + Lang : Language_Ptr; + Lang_Name : Name_Id; + Value : Variable_Value; + Extended : Project_Id; + + begin + -- At this stage, the project already contains the default extensions + -- for the various languages. We now merge those suffixes read in the + -- user project, and they override the default. + + while Specs /= No_Array_Element loop + Lang_Name := Data.Tree.Array_Elements.Table (Specs).Index; + Lang := + Get_Language_From_Name + (Project, Name => Get_Name_String (Lang_Name)); + + -- An extending project inherits its parent projects' languages + -- so if needed we should create entries for those languages + + if Lang = null then + Extended := Project.Extends; + while Extended /= null loop + Lang := Get_Language_From_Name + (Extended, Name => Get_Name_String (Lang_Name)); + exit when Lang /= null; + + Extended := Extended.Extends; + end loop; + + if Lang /= null then + Lang := new Language_Data'(Lang.all); + Lang.First_Source := null; + Lang.Next := Project.Languages; + Project.Languages := Lang; + end if; + end if; + + -- If language was not found in project or the projects it extends + + if Lang = null then + if Current_Verbosity = High then + Write_Line + ("Ignoring spec naming data for " + & Get_Name_String (Lang_Name) + & " since language is not defined for this project"); + end if; + + else + Value := Data.Tree.Array_Elements.Table (Specs).Value; + + if Value.Kind = Single then + Lang.Config.Naming_Data.Spec_Suffix := + Canonical_Case_File_Name (Value.Value); + end if; + end if; + + Specs := Data.Tree.Array_Elements.Table (Specs).Next; + end loop; + + while Impls /= No_Array_Element loop + Lang_Name := Data.Tree.Array_Elements.Table (Impls).Index; + Lang := + Get_Language_From_Name + (Project, Name => Get_Name_String (Lang_Name)); + + if Lang = null then + if Current_Verbosity = High then + Write_Line + ("Ignoring impl naming data for " + & Get_Name_String (Lang_Name) + & " since language is not defined for this project"); + end if; + else + Value := Data.Tree.Array_Elements.Table (Impls).Value; + + if Lang.Name = Name_Ada then + Ada_Body_Suffix_Loc := Value.Location; + end if; + + if Value.Kind = Single then + Lang.Config.Naming_Data.Body_Suffix := + Canonical_Case_File_Name (Value.Value); + end if; + end if; + + Impls := Data.Tree.Array_Elements.Table (Impls).Next; + end loop; + end Initialize_Naming_Data; + + -- Start of processing for Check_Naming_Schemes + + begin + -- No Naming package or parsing a configuration file? nothing to do + + if Naming_Id /= No_Package + and then Project.Qualifier /= Configuration + then + Naming := Data.Tree.Packages.Table (Naming_Id); + + if Current_Verbosity = High then + Write_Line ("Checking package Naming for project " + & Get_Name_String (Project.Name)); + end if; + + Initialize_Naming_Data; + Check_Naming; + end if; + end Check_Package_Naming; + + ------------------------------ + -- Check_Library_Attributes -- + ------------------------------ + + procedure Check_Library_Attributes + (Project : Project_Id; + Data : in out Tree_Processing_Data) + is + Attributes : constant Prj.Variable_Id := Project.Decl.Attributes; + + Lib_Dir : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Dir, Attributes, Data.Tree); + + Lib_Name : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Name, Attributes, Data.Tree); + + Lib_Version : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Version, Attributes, Data.Tree); + + Lib_ALI_Dir : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Ali_Dir, Attributes, Data.Tree); + + Lib_GCC : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_GCC, Attributes, Data.Tree); + + The_Lib_Kind : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Kind, Attributes, Data.Tree); + + Imported_Project_List : Project_List; + + Continuation : String_Access := No_Continuation_String'Access; + + Support_For_Libraries : Library_Support; + + Library_Directory_Present : Boolean; + + procedure Check_Library (Proj : Project_Id; Extends : Boolean); + -- Check if an imported or extended project if also a library project + + ------------------- + -- Check_Library -- + ------------------- + + procedure Check_Library (Proj : Project_Id; Extends : Boolean) is + Src_Id : Source_Id; + Iter : Source_Iterator; + + begin + if Proj /= No_Project then + if not Proj.Library then + + -- The only not library projects that are OK are those that + -- have no sources. However, header files from non-Ada + -- languages are OK, as there is nothing to compile. + + Iter := For_Each_Source (Data.Tree, Proj); + loop + Src_Id := Prj.Element (Iter); + exit when Src_Id = No_Source + or else Src_Id.Language.Config.Kind /= File_Based + or else Src_Id.Kind /= Spec; + Next (Iter); + end loop; + + if Src_Id /= No_Source then + Error_Msg_Name_1 := Project.Name; + Error_Msg_Name_2 := Proj.Name; + + if Extends then + if Project.Library_Kind /= Static then + Error_Msg + (Data.Flags, + Continuation.all & + "shared library project %% cannot extend " & + "project %% that is not a library project", + Project.Location, Project); + Continuation := Continuation_String'Access; + end if; + + elsif (not Unchecked_Shared_Lib_Imports) + and then Project.Library_Kind /= Static + then + Error_Msg + (Data.Flags, + Continuation.all & + "shared library project %% cannot import project %% " & + "that is not a shared library project", + Project.Location, Project); + Continuation := Continuation_String'Access; + end if; + end if; + + elsif Project.Library_Kind /= Static and then + Proj.Library_Kind = Static + then + Error_Msg_Name_1 := Project.Name; + Error_Msg_Name_2 := Proj.Name; + + if Extends then + Error_Msg + (Data.Flags, + Continuation.all & + "shared library project %% cannot extend static " & + "library project %%", + Project.Location, Project); + Continuation := Continuation_String'Access; + + elsif not Unchecked_Shared_Lib_Imports then + Error_Msg + (Data.Flags, + Continuation.all & + "shared library project %% cannot import static " & + "library project %%", + Project.Location, Project); + Continuation := Continuation_String'Access; + end if; + + end if; + end if; + end Check_Library; + + Dir_Exists : Boolean; + + -- Start of processing for Check_Library_Attributes + + begin + Library_Directory_Present := Lib_Dir.Value /= Empty_String; + + -- Special case of extending project + + if Project.Extends /= No_Project then + + -- If the project extended is a library project, we inherit the + -- library name, if it is not redefined; we check that the library + -- directory is specified. + + if Project.Extends.Library then + if Project.Qualifier = Standard then + Error_Msg + (Data.Flags, + "a standard project cannot extend a library project", + Project.Location, Project); + + else + if Lib_Name.Default then + Project.Library_Name := Project.Extends.Library_Name; + end if; + + if Lib_Dir.Default then + if not Project.Virtual then + Error_Msg + (Data.Flags, + "a project extending a library project must " & + "specify an attribute Library_Dir", + Project.Location, Project); + + else + -- For a virtual project extending a library project, + -- inherit library directory. + + Project.Library_Dir := Project.Extends.Library_Dir; + Library_Directory_Present := True; + end if; + end if; + end if; + end if; + end if; + + pragma Assert (Lib_Name.Kind = Single); + + if Lib_Name.Value = Empty_String then + if Current_Verbosity = High + and then Project.Library_Name = No_Name + then + Write_Line ("No library name"); + end if; + + else + -- There is no restriction on the syntax of library names + + Project.Library_Name := Lib_Name.Value; + end if; + + if Project.Library_Name /= No_Name then + if Current_Verbosity = High then + Write_Attr + ("Library name", Get_Name_String (Project.Library_Name)); + end if; + + pragma Assert (Lib_Dir.Kind = Single); + + if not Library_Directory_Present then + if Current_Verbosity = High then + Write_Line ("No library directory"); + end if; + + else + -- Find path name (unless inherited), check that it is a directory + + if Project.Library_Dir = No_Path_Information then + Locate_Directory + (Project, + File_Name_Type (Lib_Dir.Value), + Path => Project.Library_Dir, + Dir_Exists => Dir_Exists, + Data => Data, + Create => "library", + Must_Exist => False, + Location => Lib_Dir.Location, + Externally_Built => Project.Externally_Built); + + else + Dir_Exists := + Is_Directory + (Get_Name_String + (Project.Library_Dir.Display_Name)); + end if; + + if not Dir_Exists then + + -- Get the absolute name of the library directory that + -- does not exist, to report an error. + + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Project.Library_Dir.Display_Name); + Error_Msg + (Data.Flags, + "library directory { does not exist", + Lib_Dir.Location, Project); + + elsif not Project.Externally_Built then + + -- The library directory cannot be the same as the Object + -- directory. + + if Project.Library_Dir.Name = Project.Object_Directory.Name then + Error_Msg + (Data.Flags, + "library directory cannot be the same " & + "as object directory", + Lib_Dir.Location, Project); + Project.Library_Dir := No_Path_Information; + + else + declare + OK : Boolean := True; + Dirs_Id : String_List_Id; + Dir_Elem : String_Element; + Pid : Project_List; + + begin + -- The library directory cannot be the same as a source + -- directory of the current project. + + Dirs_Id := Project.Source_Dirs; + while Dirs_Id /= Nil_String loop + Dir_Elem := Data.Tree.String_Elements.Table (Dirs_Id); + Dirs_Id := Dir_Elem.Next; + + if Project.Library_Dir.Name = + Path_Name_Type (Dir_Elem.Value) + then + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Dir_Elem.Value); + Error_Msg + (Data.Flags, + "library directory cannot be the same " & + "as source directory {", + Lib_Dir.Location, Project); + OK := False; + exit; + end if; + end loop; + + if OK then + + -- The library directory cannot be the same as a + -- source directory of another project either. + + Pid := Data.Tree.Projects; + Project_Loop : loop + exit Project_Loop when Pid = null; + + if Pid.Project /= Project then + Dirs_Id := Pid.Project.Source_Dirs; + + Dir_Loop : while Dirs_Id /= Nil_String loop + Dir_Elem := + Data.Tree.String_Elements.Table (Dirs_Id); + Dirs_Id := Dir_Elem.Next; + + if Project.Library_Dir.Name = + Path_Name_Type (Dir_Elem.Value) + then + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Dir_Elem.Value); + Err_Vars.Error_Msg_Name_1 := + Pid.Project.Name; + + Error_Msg + (Data.Flags, + "library directory cannot be the same" & + " as source directory { of project %%", + Lib_Dir.Location, Project); + OK := False; + exit Project_Loop; + end if; + end loop Dir_Loop; + end if; + + Pid := Pid.Next; + end loop Project_Loop; + end if; + + if not OK then + Project.Library_Dir := No_Path_Information; + + elsif Current_Verbosity = High then + + -- Display the Library directory in high verbosity + + Write_Attr + ("Library directory", + Get_Name_String (Project.Library_Dir.Display_Name)); + end if; + end; + end if; + end if; + end if; + + end if; + + Project.Library := + Project.Library_Dir /= No_Path_Information + and then Project.Library_Name /= No_Name; + + if Project.Extends = No_Project then + case Project.Qualifier is + when Standard => + if Project.Library then + Error_Msg + (Data.Flags, + "a standard project cannot be a library project", + Lib_Name.Location, Project); + end if; + + when Library => + if not Project.Library then + if Project.Library_Dir = No_Path_Information then + Error_Msg + (Data.Flags, + "\attribute Library_Dir not declared", + Project.Location, Project); + end if; + + if Project.Library_Name = No_Name then + Error_Msg + (Data.Flags, + "\attribute Library_Name not declared", + Project.Location, Project); + end if; + end if; + + when others => + null; + + end case; + end if; + + if Project.Library then + Support_For_Libraries := Project.Config.Lib_Support; + + if Support_For_Libraries = Prj.None then + Error_Msg + (Data.Flags, + "?libraries are not supported on this platform", + Lib_Name.Location, Project); + Project.Library := False; + + else + if Lib_ALI_Dir.Value = Empty_String then + if Current_Verbosity = High then + Write_Line ("No library ALI directory specified"); + end if; + + Project.Library_ALI_Dir := Project.Library_Dir; + + else + -- Find path name, check that it is a directory + + Locate_Directory + (Project, + File_Name_Type (Lib_ALI_Dir.Value), + Path => Project.Library_ALI_Dir, + Create => "library ALI", + Dir_Exists => Dir_Exists, + Data => Data, + Must_Exist => False, + Location => Lib_ALI_Dir.Location, + Externally_Built => Project.Externally_Built); + + if not Dir_Exists then + + -- Get the absolute name of the library ALI directory that + -- does not exist, to report an error. + + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Project.Library_ALI_Dir.Display_Name); + Error_Msg + (Data.Flags, + "library 'A'L'I directory { does not exist", + Lib_ALI_Dir.Location, Project); + end if; + + if (not Project.Externally_Built) and then + Project.Library_ALI_Dir /= Project.Library_Dir + then + -- The library ALI directory cannot be the same as the + -- Object directory. + + if Project.Library_ALI_Dir = Project.Object_Directory then + Error_Msg + (Data.Flags, + "library 'A'L'I directory cannot be the same " & + "as object directory", + Lib_ALI_Dir.Location, Project); + Project.Library_ALI_Dir := No_Path_Information; + + else + declare + OK : Boolean := True; + Dirs_Id : String_List_Id; + Dir_Elem : String_Element; + Pid : Project_List; + + begin + -- The library ALI directory cannot be the same as + -- a source directory of the current project. + + Dirs_Id := Project.Source_Dirs; + while Dirs_Id /= Nil_String loop + Dir_Elem := + Data.Tree.String_Elements.Table (Dirs_Id); + Dirs_Id := Dir_Elem.Next; + + if Project.Library_ALI_Dir.Name = + Path_Name_Type (Dir_Elem.Value) + then + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Dir_Elem.Value); + Error_Msg + (Data.Flags, + "library 'A'L'I directory cannot be " & + "the same as source directory {", + Lib_ALI_Dir.Location, Project); + OK := False; + exit; + end if; + end loop; + + if OK then + + -- The library ALI directory cannot be the same as + -- a source directory of another project either. + + Pid := Data.Tree.Projects; + ALI_Project_Loop : loop + exit ALI_Project_Loop when Pid = null; + + if Pid.Project /= Project then + Dirs_Id := Pid.Project.Source_Dirs; + + ALI_Dir_Loop : + while Dirs_Id /= Nil_String loop + Dir_Elem := + Data.Tree.String_Elements.Table + (Dirs_Id); + Dirs_Id := Dir_Elem.Next; + + if Project.Library_ALI_Dir.Name = + Path_Name_Type (Dir_Elem.Value) + then + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Dir_Elem.Value); + Err_Vars.Error_Msg_Name_1 := + Pid.Project.Name; + + Error_Msg + (Data.Flags, + "library 'A'L'I directory cannot " & + "be the same as source directory " & + "{ of project %%", + Lib_ALI_Dir.Location, Project); + OK := False; + exit ALI_Project_Loop; + end if; + end loop ALI_Dir_Loop; + end if; + Pid := Pid.Next; + end loop ALI_Project_Loop; + end if; + + if not OK then + Project.Library_ALI_Dir := No_Path_Information; + + elsif Current_Verbosity = High then + + -- Display Library ALI directory in high verbosity + + Write_Attr + ("Library ALI dir", + Get_Name_String + (Project.Library_ALI_Dir.Display_Name)); + end if; + end; + end if; + end if; + end if; + + pragma Assert (Lib_Version.Kind = Single); + + if Lib_Version.Value = Empty_String then + if Current_Verbosity = High then + Write_Line ("No library version specified"); + end if; + + else + Project.Lib_Internal_Name := Lib_Version.Value; + end if; + + pragma Assert (The_Lib_Kind.Kind = Single); + + if The_Lib_Kind.Value = Empty_String then + if Current_Verbosity = High then + Write_Line ("No library kind specified"); + end if; + + else + Get_Name_String (The_Lib_Kind.Value); + + declare + Kind_Name : constant String := + To_Lower (Name_Buffer (1 .. Name_Len)); + + OK : Boolean := True; + + begin + if Kind_Name = "static" then + Project.Library_Kind := Static; + + elsif Kind_Name = "dynamic" then + Project.Library_Kind := Dynamic; + + elsif Kind_Name = "relocatable" then + Project.Library_Kind := Relocatable; + + else + Error_Msg + (Data.Flags, + "illegal value for Library_Kind", + The_Lib_Kind.Location, Project); + OK := False; + end if; + + if Current_Verbosity = High and then OK then + Write_Attr ("Library kind", Kind_Name); + end if; + + if Project.Library_Kind /= Static then + if Support_For_Libraries = Prj.Static_Only then + Error_Msg + (Data.Flags, + "only static libraries are supported " & + "on this platform", + The_Lib_Kind.Location, Project); + Project.Library := False; + + else + -- Check if (obsolescent) attribute Library_GCC or + -- Linker'Driver is declared. + + if Lib_GCC.Value /= Empty_String then + Error_Msg + (Data.Flags, + "?Library_'G'C'C is an obsolescent attribute, " & + "use Linker''Driver instead", + Lib_GCC.Location, Project); + Project.Config.Shared_Lib_Driver := + File_Name_Type (Lib_GCC.Value); + + else + declare + Linker : constant Package_Id := + Value_Of + (Name_Linker, + Project.Decl.Packages, + Data.Tree); + Driver : constant Variable_Value := + Value_Of + (Name => No_Name, + Attribute_Or_Array_Name => + Name_Driver, + In_Package => Linker, + In_Tree => Data.Tree); + + begin + if Driver /= Nil_Variable_Value + and then Driver.Value /= Empty_String + then + Project.Config.Shared_Lib_Driver := + File_Name_Type (Driver.Value); + end if; + end; + end if; + end if; + end if; + end; + end if; + + if Project.Library then + if Current_Verbosity = High then + Write_Line ("This is a library project file"); + end if; + + Check_Library (Project.Extends, Extends => True); + + Imported_Project_List := Project.Imported_Projects; + while Imported_Project_List /= null loop + Check_Library + (Imported_Project_List.Project, + Extends => False); + Imported_Project_List := Imported_Project_List.Next; + end loop; + end if; + + end if; + end if; + + -- Check if Linker'Switches or Linker'Default_Switches are declared. + -- Warn if they are declared, as it is a common error to think that + -- library are "linked" with Linker switches. + + if Project.Library then + declare + Linker_Package_Id : constant Package_Id := + Util.Value_Of + (Name_Linker, + Project.Decl.Packages, Data.Tree); + Linker_Package : Package_Element; + Switches : Array_Element_Id := No_Array_Element; + + begin + if Linker_Package_Id /= No_Package then + Linker_Package := Data.Tree.Packages.Table (Linker_Package_Id); + + Switches := + Value_Of + (Name => Name_Switches, + In_Arrays => Linker_Package.Decl.Arrays, + In_Tree => Data.Tree); + + if Switches = No_Array_Element then + Switches := + Value_Of + (Name => Name_Default_Switches, + In_Arrays => Linker_Package.Decl.Arrays, + In_Tree => Data.Tree); + end if; + + if Switches /= No_Array_Element then + Error_Msg + (Data.Flags, + "?Linker switches not taken into account in library " & + "projects", + No_Location, Project); + end if; + end if; + end; + end if; + + if Project.Extends /= No_Project and then Project.Extends.Library then + + -- Remove the library name from Lib_Data_Table + + for J in 1 .. Lib_Data_Table.Last loop + if Lib_Data_Table.Table (J).Proj = Project.Extends then + Lib_Data_Table.Table (J) := + Lib_Data_Table.Table (Lib_Data_Table.Last); + Lib_Data_Table.Set_Last (Lib_Data_Table.Last - 1); + exit; + end if; + end loop; + + Project.Extends.Library := False; + end if; + + if Project.Library and then not Lib_Name.Default then + + -- Check if the same library name is used in an other library project + + for J in 1 .. Lib_Data_Table.Last loop + if Lib_Data_Table.Table (J).Name = Project.Library_Name then + Error_Msg_Name_1 := Lib_Data_Table.Table (J).Proj.Name; + Error_Msg + (Data.Flags, + "Library name cannot be the same as in project %%", + Lib_Name.Location, Project); + Project.Library := False; + exit; + end if; + end loop; + end if; + + if Project.Library then + + -- Record the library name + + Lib_Data_Table.Append + ((Name => Project.Library_Name, Proj => Project)); + end if; + end Check_Library_Attributes; + + --------------------------------- + -- Check_Programming_Languages -- + --------------------------------- + + procedure Check_Programming_Languages + (Project : Project_Id; + Data : in out Tree_Processing_Data) + is + Languages : Variable_Value := Nil_Variable_Value; + Def_Lang : Variable_Value := Nil_Variable_Value; + Def_Lang_Id : Name_Id; + + procedure Add_Language (Name, Display_Name : Name_Id); + -- Add a new language to the list of languages for the project. + -- Nothing is done if the language has already been defined + + ------------------ + -- Add_Language -- + ------------------ + + procedure Add_Language (Name, Display_Name : Name_Id) is + Lang : Language_Ptr; + + begin + Lang := Project.Languages; + while Lang /= No_Language_Index loop + if Name = Lang.Name then + return; + end if; + + Lang := Lang.Next; + end loop; + + Lang := new Language_Data'(No_Language_Data); + Lang.Next := Project.Languages; + Project.Languages := Lang; + Lang.Name := Name; + Lang.Display_Name := Display_Name; + + if Name = Name_Ada then + Lang.Config.Kind := Unit_Based; + Lang.Config.Dependency_Kind := ALI_File; + else + Lang.Config.Kind := File_Based; + end if; + end Add_Language; + + -- Start of processing for Check_Programming_Languages + + begin + Project.Languages := null; + Languages := + Prj.Util.Value_Of (Name_Languages, Project.Decl.Attributes, Data.Tree); + Def_Lang := + Prj.Util.Value_Of + (Name_Default_Language, Project.Decl.Attributes, Data.Tree); + + if Project.Source_Dirs /= Nil_String then + + -- Check if languages are specified in this project + + if Languages.Default then + + -- Fail if there is no default language defined + + if Def_Lang.Default then + Error_Msg + (Data.Flags, + "no languages defined for this project", + Project.Location, Project); + Def_Lang_Id := No_Name; + + else + Get_Name_String (Def_Lang.Value); + To_Lower (Name_Buffer (1 .. Name_Len)); + Def_Lang_Id := Name_Find; + end if; + + if Def_Lang_Id /= No_Name then + Get_Name_String (Def_Lang_Id); + Name_Buffer (1) := GNAT.Case_Util.To_Upper (Name_Buffer (1)); + Add_Language + (Name => Def_Lang_Id, + Display_Name => Name_Find); + end if; + + else + declare + Current : String_List_Id := Languages.Values; + Element : String_Element; + + begin + -- If there are no languages declared, there are no sources + + if Current = Nil_String then + Project.Source_Dirs := Nil_String; + + if Project.Qualifier = Standard then + Error_Msg + (Data.Flags, + "a standard project must have at least one language", + Languages.Location, Project); + end if; + + else + -- Look through all the languages specified in attribute + -- Languages. + + while Current /= Nil_String loop + Element := Data.Tree.String_Elements.Table (Current); + Get_Name_String (Element.Value); + To_Lower (Name_Buffer (1 .. Name_Len)); + + Add_Language + (Name => Name_Find, + Display_Name => Element.Value); + + Current := Element.Next; + end loop; + end if; + end; + end if; + end if; + end Check_Programming_Languages; + + ------------------------------- + -- Check_Stand_Alone_Library -- + ------------------------------- + + procedure Check_Stand_Alone_Library + (Project : Project_Id; + Data : in out Tree_Processing_Data) + is + Lib_Interfaces : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Interface, + Project.Decl.Attributes, + Data.Tree); + + Lib_Auto_Init : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Auto_Init, + Project.Decl.Attributes, + Data.Tree); + + Lib_Src_Dir : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Src_Dir, + Project.Decl.Attributes, + Data.Tree); + + Lib_Symbol_File : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Symbol_File, + Project.Decl.Attributes, + Data.Tree); + + Lib_Symbol_Policy : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Symbol_Policy, + Project.Decl.Attributes, + Data.Tree); + + Lib_Ref_Symbol_File : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Reference_Symbol_File, + Project.Decl.Attributes, + Data.Tree); + + Auto_Init_Supported : Boolean; + OK : Boolean := True; + Source : Source_Id; + Next_Proj : Project_Id; + Iter : Source_Iterator; + + begin + Auto_Init_Supported := Project.Config.Auto_Init_Supported; + + pragma Assert (Lib_Interfaces.Kind = List); + + -- It is a stand-alone library project file if attribute + -- Library_Interface is defined. + + if not Lib_Interfaces.Default then + declare + Interfaces : String_List_Id := Lib_Interfaces.Values; + Interface_ALIs : String_List_Id := Nil_String; + Unit : Name_Id; + + begin + Project.Standalone_Library := True; + + -- Library_Interface cannot be an empty list + + if Interfaces = Nil_String then + Error_Msg + (Data.Flags, + "Library_Interface cannot be an empty list", + Lib_Interfaces.Location, Project); + end if; + + -- Process each unit name specified in the attribute + -- Library_Interface. + + while Interfaces /= Nil_String loop + Get_Name_String + (Data.Tree.String_Elements.Table (Interfaces).Value); + To_Lower (Name_Buffer (1 .. Name_Len)); + + if Name_Len = 0 then + Error_Msg + (Data.Flags, + "an interface cannot be an empty string", + Data.Tree.String_Elements.Table (Interfaces).Location, + Project); + + else + Unit := Name_Find; + Error_Msg_Name_1 := Unit; + + Next_Proj := Project.Extends; + Iter := For_Each_Source (Data.Tree, Project); + loop + while Prj.Element (Iter) /= No_Source + and then + (Prj.Element (Iter).Unit = null + or else Prj.Element (Iter).Unit.Name /= Unit) + loop + Next (Iter); + end loop; + + Source := Prj.Element (Iter); + exit when Source /= No_Source + or else Next_Proj = No_Project; + + Iter := For_Each_Source (Data.Tree, Next_Proj); + Next_Proj := Next_Proj.Extends; + end loop; + + if Source /= No_Source then + if Source.Kind = Sep then + Source := No_Source; + + elsif Source.Kind = Spec + and then Other_Part (Source) /= No_Source + then + Source := Other_Part (Source); + end if; + end if; + + if Source /= No_Source then + if Source.Project /= Project + and then not Is_Extending (Project, Source.Project) + then + Source := No_Source; + end if; + end if; + + if Source = No_Source then + Error_Msg + (Data.Flags, + "%% is not a unit of this project", + Data.Tree.String_Elements.Table + (Interfaces).Location, Project); + + else + if Source.Kind = Spec + and then Other_Part (Source) /= No_Source + then + Source := Other_Part (Source); + end if; + + String_Element_Table.Increment_Last + (Data.Tree.String_Elements); + + Data.Tree.String_Elements.Table + (String_Element_Table.Last + (Data.Tree.String_Elements)) := + (Value => Name_Id (Source.Dep_Name), + Index => 0, + Display_Value => Name_Id (Source.Dep_Name), + Location => + Data.Tree.String_Elements.Table + (Interfaces).Location, + Flag => False, + Next => Interface_ALIs); + + Interface_ALIs := + String_Element_Table.Last + (Data.Tree.String_Elements); + end if; + end if; + + Interfaces := Data.Tree.String_Elements.Table (Interfaces).Next; + end loop; + + -- Put the list of Interface ALIs in the project data + + Project.Lib_Interface_ALIs := Interface_ALIs; + + -- Check value of attribute Library_Auto_Init and set + -- Lib_Auto_Init accordingly. + + if Lib_Auto_Init.Default then + + -- If no attribute Library_Auto_Init is declared, then set auto + -- init only if it is supported. + + Project.Lib_Auto_Init := Auto_Init_Supported; + + else + Get_Name_String (Lib_Auto_Init.Value); + To_Lower (Name_Buffer (1 .. Name_Len)); + + if Name_Buffer (1 .. Name_Len) = "false" then + Project.Lib_Auto_Init := False; + + elsif Name_Buffer (1 .. Name_Len) = "true" then + if Auto_Init_Supported then + Project.Lib_Auto_Init := True; + + else + -- Library_Auto_Init cannot be "true" if auto init is not + -- supported. + + Error_Msg + (Data.Flags, + "library auto init not supported " & + "on this platform", + Lib_Auto_Init.Location, Project); + end if; + + else + Error_Msg + (Data.Flags, + "invalid value for attribute Library_Auto_Init", + Lib_Auto_Init.Location, Project); + end if; + end if; + end; + + -- If attribute Library_Src_Dir is defined and not the empty string, + -- check if the directory exist and is not the object directory or + -- one of the source directories. This is the directory where copies + -- of the interface sources will be copied. Note that this directory + -- may be the library directory. + + if Lib_Src_Dir.Value /= Empty_String then + declare + Dir_Id : constant File_Name_Type := + File_Name_Type (Lib_Src_Dir.Value); + Dir_Exists : Boolean; + + begin + Locate_Directory + (Project, + Dir_Id, + Path => Project.Library_Src_Dir, + Dir_Exists => Dir_Exists, + Data => Data, + Must_Exist => False, + Create => "library source copy", + Location => Lib_Src_Dir.Location, + Externally_Built => Project.Externally_Built); + + -- If directory does not exist, report an error + + if not Dir_Exists then + + -- Get the absolute name of the library directory that does + -- not exist, to report an error. + + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Project.Library_Src_Dir.Display_Name); + Error_Msg + (Data.Flags, + "Directory { does not exist", + Lib_Src_Dir.Location, Project); + + -- Report error if it is the same as the object directory + + elsif Project.Library_Src_Dir = Project.Object_Directory then + Error_Msg + (Data.Flags, + "directory to copy interfaces cannot be " & + "the object directory", + Lib_Src_Dir.Location, Project); + Project.Library_Src_Dir := No_Path_Information; + + else + declare + Src_Dirs : String_List_Id; + Src_Dir : String_Element; + Pid : Project_List; + + begin + -- Interface copy directory cannot be one of the source + -- directory of the current project. + + Src_Dirs := Project.Source_Dirs; + while Src_Dirs /= Nil_String loop + Src_Dir := Data.Tree.String_Elements.Table (Src_Dirs); + + -- Report error if it is one of the source directories + + if Project.Library_Src_Dir.Name = + Path_Name_Type (Src_Dir.Value) + then + Error_Msg + (Data.Flags, + "directory to copy interfaces cannot " & + "be one of the source directories", + Lib_Src_Dir.Location, Project); + Project.Library_Src_Dir := No_Path_Information; + exit; + end if; + + Src_Dirs := Src_Dir.Next; + end loop; + + if Project.Library_Src_Dir /= No_Path_Information then + + -- It cannot be a source directory of any other + -- project either. + + Pid := Data.Tree.Projects; + Project_Loop : loop + exit Project_Loop when Pid = null; + + Src_Dirs := Pid.Project.Source_Dirs; + Dir_Loop : while Src_Dirs /= Nil_String loop + Src_Dir := + Data.Tree.String_Elements.Table (Src_Dirs); + + -- Report error if it is one of the source + -- directories. + + if Project.Library_Src_Dir.Name = + Path_Name_Type (Src_Dir.Value) + then + Error_Msg_File_1 := + File_Name_Type (Src_Dir.Value); + Error_Msg_Name_1 := Pid.Project.Name; + Error_Msg + (Data.Flags, + "directory to copy interfaces cannot " & + "be the same as source directory { of " & + "project %%", + Lib_Src_Dir.Location, Project); + Project.Library_Src_Dir := + No_Path_Information; + exit Project_Loop; + end if; + + Src_Dirs := Src_Dir.Next; + end loop Dir_Loop; + + Pid := Pid.Next; + end loop Project_Loop; + end if; + end; + + -- In high verbosity, if there is a valid Library_Src_Dir, + -- display its path name. + + if Project.Library_Src_Dir /= No_Path_Information + and then Current_Verbosity = High + then + Write_Attr + ("Directory to copy interfaces", + Get_Name_String (Project.Library_Src_Dir.Name)); + end if; + end if; + end; + end if; + + -- Check the symbol related attributes + + -- First, the symbol policy + + if not Lib_Symbol_Policy.Default then + declare + Value : constant String := + To_Lower + (Get_Name_String (Lib_Symbol_Policy.Value)); + + begin + -- Symbol policy must hove one of a limited number of values + + if Value = "autonomous" or else Value = "default" then + Project.Symbol_Data.Symbol_Policy := Autonomous; + + elsif Value = "compliant" then + Project.Symbol_Data.Symbol_Policy := Compliant; + + elsif Value = "controlled" then + Project.Symbol_Data.Symbol_Policy := Controlled; + + elsif Value = "restricted" then + Project.Symbol_Data.Symbol_Policy := Restricted; + + elsif Value = "direct" then + Project.Symbol_Data.Symbol_Policy := Direct; + + else + Error_Msg + (Data.Flags, + "illegal value for Library_Symbol_Policy", + Lib_Symbol_Policy.Location, Project); + end if; + end; + end if; + + -- If attribute Library_Symbol_File is not specified, symbol policy + -- cannot be Restricted. + + if Lib_Symbol_File.Default then + if Project.Symbol_Data.Symbol_Policy = Restricted then + Error_Msg + (Data.Flags, + "Library_Symbol_File needs to be defined when " & + "symbol policy is Restricted", + Lib_Symbol_Policy.Location, Project); + end if; + + else + -- Library_Symbol_File is defined + + Project.Symbol_Data.Symbol_File := + Path_Name_Type (Lib_Symbol_File.Value); + + Get_Name_String (Lib_Symbol_File.Value); + + if Name_Len = 0 then + Error_Msg + (Data.Flags, + "symbol file name cannot be an empty string", + Lib_Symbol_File.Location, Project); + + else + OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)); + + if OK then + for J in 1 .. Name_Len loop + if Name_Buffer (J) = '/' + or else Name_Buffer (J) = Directory_Separator + then + OK := False; + exit; + end if; + end loop; + end if; + + if not OK then + Error_Msg_File_1 := File_Name_Type (Lib_Symbol_File.Value); + Error_Msg + (Data.Flags, + "symbol file name { is illegal. " & + "Name cannot include directory info.", + Lib_Symbol_File.Location, Project); + end if; + end if; + end if; + + -- If attribute Library_Reference_Symbol_File is not defined, + -- symbol policy cannot be Compliant or Controlled. + + if Lib_Ref_Symbol_File.Default then + if Project.Symbol_Data.Symbol_Policy = Compliant + or else Project.Symbol_Data.Symbol_Policy = Controlled + then + Error_Msg + (Data.Flags, + "a reference symbol file needs to be defined", + Lib_Symbol_Policy.Location, Project); + end if; + + else + -- Library_Reference_Symbol_File is defined, check file exists + + Project.Symbol_Data.Reference := + Path_Name_Type (Lib_Ref_Symbol_File.Value); + + Get_Name_String (Lib_Ref_Symbol_File.Value); + + if Name_Len = 0 then + Error_Msg + (Data.Flags, + "reference symbol file name cannot be an empty string", + Lib_Symbol_File.Location, Project); + + else + if not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)) then + Name_Len := 0; + Add_Str_To_Name_Buffer + (Get_Name_String (Project.Directory.Name)); + Add_Str_To_Name_Buffer + (Get_Name_String (Lib_Ref_Symbol_File.Value)); + Project.Symbol_Data.Reference := Name_Find; + end if; + + if not Is_Regular_File + (Get_Name_String (Project.Symbol_Data.Reference)) + then + Error_Msg_File_1 := + File_Name_Type (Lib_Ref_Symbol_File.Value); + + -- For controlled and direct symbol policies, it is an error + -- if the reference symbol file does not exist. For other + -- symbol policies, this is just a warning + + Error_Msg_Warn := + Project.Symbol_Data.Symbol_Policy /= Controlled + and then Project.Symbol_Data.Symbol_Policy /= Direct; + + Error_Msg + (Data.Flags, + " 0 then + declare + -- We do not need to pass a Directory to + -- Normalize_Pathname, since the path_information + -- already contains absolute information. + + Symb_Path : constant String := + Normalize_Pathname + (Get_Name_String + (Project.Object_Directory.Name) & + Name_Buffer (1 .. Name_Len), + Directory => "/", + Resolve_Links => + Opt.Follow_Links_For_Files); + Ref_Path : constant String := + Normalize_Pathname + (Get_Name_String + (Project.Symbol_Data.Reference), + Directory => "/", + Resolve_Links => + Opt.Follow_Links_For_Files); + begin + if Symb_Path = Ref_Path then + Error_Msg + (Data.Flags, + "library reference symbol file and library" & + " symbol file cannot be the same file", + Lib_Ref_Symbol_File.Location, Project); + end if; + end; + end if; + end if; + end if; + end if; + end if; + end Check_Stand_Alone_Library; + + ---------------------------- + -- Compute_Directory_Last -- + ---------------------------- + + function Compute_Directory_Last (Dir : String) return Natural is + begin + if Dir'Length > 1 + and then (Dir (Dir'Last - 1) = Directory_Separator + or else + Dir (Dir'Last - 1) = '/') + then + return Dir'Last - 1; + else + return Dir'Last; + end if; + end Compute_Directory_Last; + + --------------------- + -- Get_Directories -- + --------------------- + + procedure Get_Directories + (Project : Project_Id; + Data : in out Tree_Processing_Data) + is + Object_Dir : constant Variable_Value := + Util.Value_Of + (Name_Object_Dir, Project.Decl.Attributes, Data.Tree); + + Exec_Dir : constant Variable_Value := + Util.Value_Of + (Name_Exec_Dir, Project.Decl.Attributes, Data.Tree); + + Source_Dirs : constant Variable_Value := + Util.Value_Of + (Name_Source_Dirs, Project.Decl.Attributes, Data.Tree); + + Ignore_Source_Sub_Dirs : constant Variable_Value := + Util.Value_Of + (Name_Ignore_Source_Sub_Dirs, + Project.Decl.Attributes, + Data.Tree); + + Excluded_Source_Dirs : constant Variable_Value := + Util.Value_Of + (Name_Excluded_Source_Dirs, + Project.Decl.Attributes, + Data.Tree); + + Source_Files : constant Variable_Value := + Util.Value_Of + (Name_Source_Files, + Project.Decl.Attributes, Data.Tree); + + Last_Source_Dir : String_List_Id := Nil_String; + Last_Src_Dir_Rank : Number_List_Index := No_Number_List; + + Languages : constant Variable_Value := + Prj.Util.Value_Of + (Name_Languages, Project.Decl.Attributes, Data.Tree); + + Remove_Source_Dirs : Boolean := False; + + procedure Add_To_Or_Remove_From_Source_Dirs + (Path : Path_Information; + Rank : Natural); + -- When Removed = False, the directory Path_Id to the list of + -- source_dirs if not already in the list. When Removed = True, + -- removed directory Path_Id if in the list. + + procedure Find_Source_Dirs is new Expand_Subdirectory_Pattern + (Add_To_Or_Remove_From_Source_Dirs); + + --------------------------------------- + -- Add_To_Or_Remove_From_Source_Dirs -- + --------------------------------------- + + procedure Add_To_Or_Remove_From_Source_Dirs + (Path : Path_Information; + Rank : Natural) + is + List : String_List_Id; + Prev : String_List_Id; + Rank_List : Number_List_Index; + Prev_Rank : Number_List_Index; + Element : String_Element; + + begin + Prev := Nil_String; + Prev_Rank := No_Number_List; + List := Project.Source_Dirs; + Rank_List := Project.Source_Dir_Ranks; + while List /= Nil_String loop + Element := Data.Tree.String_Elements.Table (List); + exit when Element.Value = Name_Id (Path.Name); + Prev := List; + List := Element.Next; + Prev_Rank := Rank_List; + Rank_List := Data.Tree.Number_Lists.Table (Prev_Rank).Next; + end loop; + + -- The directory is in the list if List is not Nil_String + + if not Remove_Source_Dirs and then List = Nil_String then + if Current_Verbosity = High then + Write_Str (" Adding Source Dir="); + Write_Line (Get_Name_String (Path.Display_Name)); + end if; + + String_Element_Table.Increment_Last (Data.Tree.String_Elements); + Element := + (Value => Name_Id (Path.Name), + Index => 0, + Display_Value => Name_Id (Path.Display_Name), + Location => No_Location, + Flag => False, + Next => Nil_String); + + Number_List_Table.Increment_Last (Data.Tree.Number_Lists); + + if Last_Source_Dir = Nil_String then + + -- This is the first source directory + + Project.Source_Dirs := + String_Element_Table.Last (Data.Tree.String_Elements); + Project.Source_Dir_Ranks := + Number_List_Table.Last (Data.Tree.Number_Lists); + + else + -- We already have source directories, link the previous + -- last to the new one. + + Data.Tree.String_Elements.Table (Last_Source_Dir).Next := + String_Element_Table.Last (Data.Tree.String_Elements); + Data.Tree.Number_Lists.Table (Last_Src_Dir_Rank).Next := + Number_List_Table.Last (Data.Tree.Number_Lists); + end if; + + -- And register this source directory as the new last + + Last_Source_Dir := + String_Element_Table.Last (Data.Tree.String_Elements); + Data.Tree.String_Elements.Table (Last_Source_Dir) := Element; + Last_Src_Dir_Rank := + Number_List_Table.Last (Data.Tree.Number_Lists); + Data.Tree.Number_Lists.Table (Last_Src_Dir_Rank) := + (Number => Rank, Next => No_Number_List); + + elsif Remove_Source_Dirs and then List /= Nil_String then + + -- Remove source dir if present + + if Prev = Nil_String then + Project.Source_Dirs := + Data.Tree.String_Elements.Table (List).Next; + Project.Source_Dir_Ranks := + Data.Tree.Number_Lists.Table (Rank_List).Next; + + else + Data.Tree.String_Elements.Table (Prev).Next := + Data.Tree.String_Elements.Table (List).Next; + Data.Tree.Number_Lists.Table (Prev_Rank).Next := + Data.Tree.Number_Lists.Table (Rank_List).Next; + end if; + end if; + end Add_To_Or_Remove_From_Source_Dirs; + + -- Local declarations + + Dir_Exists : Boolean; + + No_Sources : constant Boolean := + ((not Source_Files.Default + and then Source_Files.Values = Nil_String) + or else + (not Source_Dirs.Default + and then Source_Dirs.Values = Nil_String) + or else + (not Languages.Default + and then Languages.Values = Nil_String)) + and then Project.Extends = No_Project; + + -- Start of processing for Get_Directories + + begin + if Current_Verbosity = High then + Write_Line ("Starting to look for directories"); + end if; + + -- Set the object directory to its default which may be nil, if there + -- is no sources in the project. + + if No_Sources then + Project.Object_Directory := No_Path_Information; + else + Project.Object_Directory := Project.Directory; + end if; + + -- Check the object directory + + if Object_Dir.Value /= Empty_String then + Get_Name_String (Object_Dir.Value); + + if Name_Len = 0 then + Error_Msg + (Data.Flags, + "Object_Dir cannot be empty", + Object_Dir.Location, Project); + + elsif not No_Sources then + + -- We check that the specified object directory does exist. + -- However, even when it doesn't exist, we set it to a default + -- value. This is for the benefit of tools that recover from + -- errors; for example, these tools could create the non existent + -- directory. We always return an absolute directory name though. + + Locate_Directory + (Project, + File_Name_Type (Object_Dir.Value), + Path => Project.Object_Directory, + Create => "object", + Dir_Exists => Dir_Exists, + Data => Data, + Location => Object_Dir.Location, + Must_Exist => False, + Externally_Built => Project.Externally_Built); + + if not Dir_Exists + and then not Project.Externally_Built + then + -- The object directory does not exist, report an error if the + -- project is not externally built. + + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Object_Dir.Value); + Error_Or_Warning + (Data.Flags, Data.Flags.Require_Obj_Dirs, + "object directory { not found", Project.Location, Project); + end if; + end if; + + elsif not No_Sources and then Subdirs /= null then + Name_Len := 1; + Name_Buffer (1) := '.'; + Locate_Directory + (Project, + Name_Find, + Path => Project.Object_Directory, + Create => "object", + Dir_Exists => Dir_Exists, + Data => Data, + Location => Object_Dir.Location, + Externally_Built => Project.Externally_Built); + end if; + + if Current_Verbosity = High then + if Project.Object_Directory = No_Path_Information then + Write_Line ("No object directory"); + else + Write_Attr + ("Object directory", + Get_Name_String (Project.Object_Directory.Display_Name)); + end if; + end if; + + -- Check the exec directory + + -- We set the object directory to its default + + Project.Exec_Directory := Project.Object_Directory; + + if Exec_Dir.Value /= Empty_String then + Get_Name_String (Exec_Dir.Value); + + if Name_Len = 0 then + Error_Msg + (Data.Flags, + "Exec_Dir cannot be empty", + Exec_Dir.Location, Project); + + elsif not No_Sources then + + -- We check that the specified exec directory does exist + + Locate_Directory + (Project, + File_Name_Type (Exec_Dir.Value), + Path => Project.Exec_Directory, + Dir_Exists => Dir_Exists, + Data => Data, + Create => "exec", + Location => Exec_Dir.Location, + Externally_Built => Project.Externally_Built); + + if not Dir_Exists then + Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value); + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, + "exec directory { not found", Project.Location, Project); + end if; + end if; + end if; + + if Current_Verbosity = High then + if Project.Exec_Directory = No_Path_Information then + Write_Line ("No exec directory"); + else + Write_Str ("Exec directory: """); + Write_Str (Get_Name_String (Project.Exec_Directory.Display_Name)); + Write_Line (""""); + end if; + end if; + + -- Look for the source directories + + if Current_Verbosity = High then + Write_Line ("Starting to look for source directories"); + end if; + + pragma Assert (Source_Dirs.Kind = List, "Source_Dirs is not a list"); + + if not Source_Files.Default + and then Source_Files.Values = Nil_String + then + Project.Source_Dirs := Nil_String; + + if Project.Qualifier = Standard then + Error_Msg + (Data.Flags, + "a standard project cannot have no sources", + Source_Files.Location, Project); + end if; + + elsif Source_Dirs.Default then + + -- No Source_Dirs specified: the single source directory is the one + -- containing the project file. + + Remove_Source_Dirs := False; + Add_To_Or_Remove_From_Source_Dirs + (Path => (Name => Project.Directory.Name, + Display_Name => Project.Directory.Display_Name), + Rank => 1); + + else + Remove_Source_Dirs := False; + Find_Source_Dirs + (Project => Project, + Data => Data, + Patterns => Source_Dirs.Values, + Ignore => Ignore_Source_Sub_Dirs.Values, + Search_For => Search_Directories, + Resolve_Links => Opt.Follow_Links_For_Dirs); + + if Project.Source_Dirs = Nil_String + and then Project.Qualifier = Standard + then + Error_Msg + (Data.Flags, + "a standard project cannot have no source directories", + Source_Dirs.Location, Project); + end if; + end if; + + if not Excluded_Source_Dirs.Default + and then Excluded_Source_Dirs.Values /= Nil_String + then + Remove_Source_Dirs := True; + Find_Source_Dirs + (Project => Project, + Data => Data, + Patterns => Excluded_Source_Dirs.Values, + Ignore => Nil_String, + Search_For => Search_Directories, + Resolve_Links => Opt.Follow_Links_For_Dirs); + end if; + + if Current_Verbosity = High then + Write_Line ("Putting source directories in canonical cases"); + end if; + + declare + Current : String_List_Id := Project.Source_Dirs; + Element : String_Element; + + begin + while Current /= Nil_String loop + Element := Data.Tree.String_Elements.Table (Current); + if Element.Value /= No_Name then + Element.Value := + Name_Id (Canonical_Case_File_Name (Element.Value)); + Data.Tree.String_Elements.Table (Current) := Element; + end if; + + Current := Element.Next; + end loop; + end; + end Get_Directories; + + --------------- + -- Get_Mains -- + --------------- + + procedure Get_Mains + (Project : Project_Id; + Data : in out Tree_Processing_Data) + is + Mains : constant Variable_Value := + Prj.Util.Value_Of + (Name_Main, Project.Decl.Attributes, Data.Tree); + List : String_List_Id; + Elem : String_Element; + + begin + Project.Mains := Mains.Values; + + -- If no Mains were specified, and if we are an extending project, + -- inherit the Mains from the project we are extending. + + if Mains.Default then + if not Project.Library and then Project.Extends /= No_Project then + Project.Mains := Project.Extends.Mains; + end if; + + -- In a library project file, Main cannot be specified + + elsif Project.Library then + Error_Msg + (Data.Flags, + "a library project file cannot have Main specified", + Mains.Location, Project); + + else + List := Mains.Values; + while List /= Nil_String loop + Elem := Data.Tree.String_Elements.Table (List); + + if Length_Of_Name (Elem.Value) = 0 then + Error_Msg + (Data.Flags, + "?a main cannot have an empty name", + Elem.Location, Project); + exit; + end if; + + List := Elem.Next; + end loop; + end if; + end Get_Mains; + + --------------------------- + -- Get_Sources_From_File -- + --------------------------- + + procedure Get_Sources_From_File + (Path : String; + Location : Source_Ptr; + Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data) + is + File : Prj.Util.Text_File; + Line : String (1 .. 250); + Last : Natural; + Source_Name : File_Name_Type; + Name_Loc : Name_Location; + + begin + if Current_Verbosity = High then + Write_Str ("Opening """); + Write_Str (Path); + Write_Line ("""."); + end if; + + -- Open the file + + Prj.Util.Open (File, Path); + + if not Prj.Util.Is_Valid (File) then + Error_Msg + (Data.Flags, "file does not exist", Location, Project.Project); + + else + -- Read the lines one by one + + while not Prj.Util.End_Of_File (File) loop + Prj.Util.Get_Line (File, Line, Last); + + -- A non empty, non comment line should contain a file name + + if Last /= 0 + and then (Last = 1 or else Line (1 .. 2) /= "--") + then + Name_Len := Last; + Name_Buffer (1 .. Name_Len) := Line (1 .. Last); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Source_Name := Name_Find; + + -- Check that there is no directory information + + for J in 1 .. Last loop + if Line (J) = '/' or else Line (J) = Directory_Separator then + Error_Msg_File_1 := Source_Name; + Error_Msg + (Data.Flags, + "file name cannot include directory information ({)", + Location, Project.Project); + exit; + end if; + end loop; + + Name_Loc := Source_Names_Htable.Get + (Project.Source_Names, Source_Name); + + if Name_Loc = No_Name_Location then + Name_Loc := + (Name => Source_Name, + Location => Location, + Source => No_Source, + Listed => True, + Found => False); + + else + Name_Loc.Listed := True; + end if; + + Source_Names_Htable.Set + (Project.Source_Names, Source_Name, Name_Loc); + end if; + end loop; + + Prj.Util.Close (File); + + end if; + end Get_Sources_From_File; + + ----------------------- + -- Compute_Unit_Name -- + ----------------------- + + procedure Compute_Unit_Name + (File_Name : File_Name_Type; + Naming : Lang_Naming_Data; + Kind : out Source_Kind; + Unit : out Name_Id; + Project : Project_Processing_Data; + In_Tree : Project_Tree_Ref) + is + Filename : constant String := Get_Name_String (File_Name); + Last : Integer := Filename'Last; + Sep_Len : Integer; + Body_Len : Integer; + Spec_Len : Integer; + + Unit_Except : Unit_Exception; + Masked : Boolean := False; + + begin + Unit := No_Name; + Kind := Spec; + + if Naming.Separate_Suffix = No_File + or else Naming.Body_Suffix = No_File + or else Naming.Spec_Suffix = No_File + then + return; + end if; + + if Naming.Dot_Replacement = No_File then + if Current_Verbosity = High then + Write_Line (" No dot_replacement specified"); + end if; + + return; + end if; + + Sep_Len := Integer (Length_Of_Name (Naming.Separate_Suffix)); + Spec_Len := Integer (Length_Of_Name (Naming.Spec_Suffix)); + Body_Len := Integer (Length_Of_Name (Naming.Body_Suffix)); + + -- Choose the longest suffix that matches. If there are several matches, + -- give priority to specs, then bodies, then separates. + + if Naming.Separate_Suffix /= Naming.Body_Suffix + and then Suffix_Matches (Filename, Naming.Separate_Suffix) + then + Last := Filename'Last - Sep_Len; + Kind := Sep; + end if; + + if Filename'Last - Body_Len <= Last + and then Suffix_Matches (Filename, Naming.Body_Suffix) + then + Last := Natural'Min (Last, Filename'Last - Body_Len); + Kind := Impl; + end if; + + if Filename'Last - Spec_Len <= Last + and then Suffix_Matches (Filename, Naming.Spec_Suffix) + then + Last := Natural'Min (Last, Filename'Last - Spec_Len); + Kind := Spec; + end if; + + if Last = Filename'Last then + if Current_Verbosity = High then + Write_Line (" no matching suffix"); + end if; + + return; + end if; + + -- Check that the casing matches + + if File_Names_Case_Sensitive then + case Naming.Casing is + when All_Lower_Case => + for J in Filename'First .. Last loop + if Is_Letter (Filename (J)) + and then not Is_Lower (Filename (J)) + then + if Current_Verbosity = High then + Write_Line (" Invalid casing"); + end if; + + return; + end if; + end loop; + + when All_Upper_Case => + for J in Filename'First .. Last loop + if Is_Letter (Filename (J)) + and then not Is_Upper (Filename (J)) + then + if Current_Verbosity = High then + Write_Line (" Invalid casing"); + end if; + + return; + end if; + end loop; + + when Mixed_Case | Unknown => + null; + end case; + end if; + + -- If Dot_Replacement is not a single dot, then there should not + -- be any dot in the name. + + declare + Dot_Repl : constant String := + Get_Name_String (Naming.Dot_Replacement); + + begin + if Dot_Repl /= "." then + for Index in Filename'First .. Last loop + if Filename (Index) = '.' then + if Current_Verbosity = High then + Write_Line (" Invalid name, contains dot"); + end if; + + return; + end if; + end loop; + + Replace_Into_Name_Buffer + (Filename (Filename'First .. Last), Dot_Repl, '.'); + + else + Name_Len := Last - Filename'First + 1; + Name_Buffer (1 .. Name_Len) := Filename (Filename'First .. Last); + Fixed.Translate + (Source => Name_Buffer (1 .. Name_Len), + Mapping => Lower_Case_Map); + end if; + end; + + -- In the standard GNAT naming scheme, check for special cases: children + -- or separates of A, G, I or S, and run time sources. + + if Is_Standard_GNAT_Naming (Naming) + and then Name_Len >= 3 + then + declare + S1 : constant Character := Name_Buffer (1); + S2 : constant Character := Name_Buffer (2); + S3 : constant Character := Name_Buffer (3); + + begin + if S1 = 'a' + or else S1 = 'g' + or else S1 = 'i' + or else S1 = 's' + then + -- Children or separates of packages A, G, I or S. These names + -- are x__ ... or x~... (where x is a, g, i, or s). Both + -- versions (x__... and x~...) are allowed in all platforms, + -- because it is not possible to know the platform before + -- processing of the project files. + + if S2 = '_' and then S3 = '_' then + Name_Buffer (2) := '.'; + Name_Buffer (3 .. Name_Len - 1) := + Name_Buffer (4 .. Name_Len); + Name_Len := Name_Len - 1; + + elsif S2 = '~' then + Name_Buffer (2) := '.'; + + elsif S2 = '.' then + + -- If it is potentially a run time source + + null; + end if; + end if; + end; + end if; + + -- Name_Buffer contains the name of the unit in lower-cases. Check + -- that this is a valid unit name + + Check_Ada_Name (Name_Buffer (1 .. Name_Len), Unit); + + -- If there is a naming exception for the same unit, the file is not + -- a source for the unit. + + if Unit /= No_Name then + Unit_Except := + Unit_Exceptions_Htable.Get (Project.Unit_Exceptions, Unit); + + if Kind = Spec then + Masked := Unit_Except.Spec /= No_File + and then + Unit_Except.Spec /= File_Name; + else + Masked := Unit_Except.Impl /= No_File + and then + Unit_Except.Impl /= File_Name; + end if; + + if Masked then + if Current_Verbosity = High then + Write_Str (" """ & Filename & """ contains the "); + + if Kind = Spec then + Write_Str ("spec of a unit found in """); + Write_Str (Get_Name_String (Unit_Except.Spec)); + else + Write_Str ("body of a unit found in """); + Write_Str (Get_Name_String (Unit_Except.Impl)); + end if; + + Write_Line (""" (ignored)"); + end if; + + Unit := No_Name; + end if; + end if; + + if Unit /= No_Name + and then Current_Verbosity = High + then + case Kind is + when Spec => Write_Str (" spec of "); + when Impl => Write_Str (" body of "); + when Sep => Write_Str (" sep of "); + end case; + + Write_Line (Get_Name_String (Unit)); + end if; + end Compute_Unit_Name; + + -------------------------- + -- Check_Illegal_Suffix -- + -------------------------- + + procedure Check_Illegal_Suffix + (Project : Project_Id; + Suffix : File_Name_Type; + Dot_Replacement : File_Name_Type; + Attribute_Name : String; + Location : Source_Ptr; + Data : in out Tree_Processing_Data) + is + Suffix_Str : constant String := Get_Name_String (Suffix); + + begin + if Suffix_Str'Length = 0 then + + -- Always valid + + return; + + elsif Index (Suffix_Str, ".") = 0 then + Err_Vars.Error_Msg_File_1 := Suffix; + Error_Msg + (Data.Flags, + "{ is illegal for " & Attribute_Name & ": must have a dot", + Location, Project); + return; + end if; + + -- Case of dot replacement is a single dot, and first character of + -- suffix is also a dot. + + if Dot_Replacement /= No_File + and then Get_Name_String (Dot_Replacement) = "." + and then Suffix_Str (Suffix_Str'First) = '.' + then + for Index in Suffix_Str'First + 1 .. Suffix_Str'Last loop + + -- If there are multiple dots in the name + + if Suffix_Str (Index) = '.' then + + -- It is illegal to have a letter following the initial dot + + if Is_Letter (Suffix_Str (Suffix_Str'First + 1)) then + Err_Vars.Error_Msg_File_1 := Suffix; + Error_Msg + (Data.Flags, + "{ is illegal for " & Attribute_Name + & ": ambiguous prefix when Dot_Replacement is a dot", + Location, Project); + end if; + return; + end if; + end loop; + end if; + end Check_Illegal_Suffix; + + ---------------------- + -- Locate_Directory -- + ---------------------- + + procedure Locate_Directory + (Project : Project_Id; + Name : File_Name_Type; + Path : out Path_Information; + Dir_Exists : out Boolean; + Data : in out Tree_Processing_Data; + Create : String := ""; + Location : Source_Ptr := No_Location; + Must_Exist : Boolean := True; + Externally_Built : Boolean := False) + is + Parent : constant Path_Name_Type := + Project.Directory.Display_Name; + The_Parent : constant String := + Get_Name_String (Parent); + The_Parent_Last : constant Natural := + Compute_Directory_Last (The_Parent); + Full_Name : File_Name_Type; + The_Name : File_Name_Type; + + begin + Get_Name_String (Name); + + -- Add Subdirs.all if it is a directory that may be created and + -- Subdirs is not null; + + if Create /= "" and then Subdirs /= null then + if Name_Buffer (Name_Len) /= Directory_Separator then + Add_Char_To_Name_Buffer (Directory_Separator); + end if; + + Add_Str_To_Name_Buffer (Subdirs.all); + end if; + + -- Convert '/' to directory separator (for Windows) + + for J in 1 .. Name_Len loop + if Name_Buffer (J) = '/' then + Name_Buffer (J) := Directory_Separator; + end if; + end loop; + + The_Name := Name_Find; + + if Current_Verbosity = High then + Write_Str ("Locate_Directory ("""); + Write_Str (Get_Name_String (The_Name)); + Write_Str (""", """); + Write_Str (The_Parent); + Write_Line (""")"); + end if; + + Path := No_Path_Information; + Dir_Exists := False; + + if Is_Absolute_Path (Get_Name_String (The_Name)) then + Full_Name := The_Name; + + else + Name_Len := 0; + Add_Str_To_Name_Buffer + (The_Parent (The_Parent'First .. The_Parent_Last)); + Add_Str_To_Name_Buffer (Get_Name_String (The_Name)); + Full_Name := Name_Find; + end if; + + declare + Full_Path_Name : String_Access := + new String'(Get_Name_String (Full_Name)); + + begin + if (Setup_Projects or else Subdirs /= null) + and then Create'Length > 0 + then + if not Is_Directory (Full_Path_Name.all) then + + -- If project is externally built, do not create a subdir, + -- use the specified directory, without the subdir. + + if Externally_Built then + if Is_Absolute_Path (Get_Name_String (Name)) then + Get_Name_String (Name); + + else + Name_Len := 0; + Add_Str_To_Name_Buffer + (The_Parent (The_Parent'First .. The_Parent_Last)); + Add_Str_To_Name_Buffer (Get_Name_String (Name)); + end if; + + Full_Path_Name := new String'(Name_Buffer (1 .. Name_Len)); + + else + begin + Create_Path (Full_Path_Name.all); + + if not Quiet_Output then + Write_Str (Create); + Write_Str (" directory """); + Write_Str (Full_Path_Name.all); + Write_Str (""" created for project "); + Write_Line (Get_Name_String (Project.Name)); + end if; + + exception + when Use_Error => + Error_Msg + (Data.Flags, + "could not create " & Create & + " directory " & Full_Path_Name.all, + Location, Project); + end; + end if; + end if; + end if; + + Dir_Exists := Is_Directory (Full_Path_Name.all); + + if not Must_Exist or else Dir_Exists then + declare + Normed : constant String := + Normalize_Pathname + (Full_Path_Name.all, + Directory => + The_Parent (The_Parent'First .. The_Parent_Last), + Resolve_Links => False, + Case_Sensitive => True); + + Canonical_Path : constant String := + Normalize_Pathname + (Normed, + Directory => + The_Parent + (The_Parent'First .. The_Parent_Last), + Resolve_Links => + Opt.Follow_Links_For_Dirs, + Case_Sensitive => False); + + begin + Name_Len := Normed'Length; + Name_Buffer (1 .. Name_Len) := Normed; + + -- Directories should always end with a directory separator + + if Name_Buffer (Name_Len) /= Directory_Separator then + Add_Char_To_Name_Buffer (Directory_Separator); + end if; + + Path.Display_Name := Name_Find; + + Name_Len := Canonical_Path'Length; + Name_Buffer (1 .. Name_Len) := Canonical_Path; + + if Name_Buffer (Name_Len) /= Directory_Separator then + Add_Char_To_Name_Buffer (Directory_Separator); + end if; + + Path.Name := Name_Find; + end; + end if; + + Free (Full_Path_Name); + end; + end Locate_Directory; + + --------------------------- + -- Find_Excluded_Sources -- + --------------------------- + + procedure Find_Excluded_Sources + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data) + is + Excluded_Source_List_File : constant Variable_Value := + Util.Value_Of + (Name_Excluded_Source_List_File, + Project.Project.Decl.Attributes, + Data.Tree); + Excluded_Sources : Variable_Value := Util.Value_Of + (Name_Excluded_Source_Files, + Project.Project.Decl.Attributes, + Data.Tree); + + Current : String_List_Id; + Element : String_Element; + Location : Source_Ptr; + Name : File_Name_Type; + File : Prj.Util.Text_File; + Line : String (1 .. 300); + Last : Natural; + Locally_Removed : Boolean := False; + + begin + -- If Excluded_Source_Files is not declared, check Locally_Removed_Files + + if Excluded_Sources.Default then + Locally_Removed := True; + Excluded_Sources := + Util.Value_Of + (Name_Locally_Removed_Files, + Project.Project.Decl.Attributes, Data.Tree); + end if; + + -- If there are excluded sources, put them in the table + + if not Excluded_Sources.Default then + if not Excluded_Source_List_File.Default then + if Locally_Removed then + Error_Msg + (Data.Flags, + "?both attributes Locally_Removed_Files and " & + "Excluded_Source_List_File are present", + Excluded_Source_List_File.Location, Project.Project); + else + Error_Msg + (Data.Flags, + "?both attributes Excluded_Source_Files and " & + "Excluded_Source_List_File are present", + Excluded_Source_List_File.Location, Project.Project); + end if; + end if; + + Current := Excluded_Sources.Values; + while Current /= Nil_String loop + Element := Data.Tree.String_Elements.Table (Current); + Name := Canonical_Case_File_Name (Element.Value); + + -- If the element has no location, then use the location of + -- Excluded_Sources to report possible errors. + + if Element.Location = No_Location then + Location := Excluded_Sources.Location; + else + Location := Element.Location; + end if; + + Excluded_Sources_Htable.Set + (Project.Excluded, Name, (Name, False, Location)); + Current := Element.Next; + end loop; + + elsif not Excluded_Source_List_File.Default then + Location := Excluded_Source_List_File.Location; + + declare + Source_File_Path_Name : constant String := + Path_Name_Of + (File_Name_Type + (Excluded_Source_List_File.Value), + Project.Project.Directory.Name); + + begin + if Source_File_Path_Name'Length = 0 then + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Excluded_Source_List_File.Value); + Error_Msg + (Data.Flags, + "file with excluded sources { does not exist", + Excluded_Source_List_File.Location, Project.Project); + + else + -- Open the file + + Prj.Util.Open (File, Source_File_Path_Name); + + if not Prj.Util.Is_Valid (File) then + Error_Msg + (Data.Flags, "file does not exist", + Location, Project.Project); + else + -- Read the lines one by one + + while not Prj.Util.End_Of_File (File) loop + Prj.Util.Get_Line (File, Line, Last); + + -- Non empty, non comment line should contain a file name + + if Last /= 0 + and then (Last = 1 or else Line (1 .. 2) /= "--") + then + Name_Len := Last; + Name_Buffer (1 .. Name_Len) := Line (1 .. Last); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Name := Name_Find; + + -- Check that there is no directory information + + for J in 1 .. Last loop + if Line (J) = '/' + or else Line (J) = Directory_Separator + then + Error_Msg_File_1 := Name; + Error_Msg + (Data.Flags, + "file name cannot include " & + "directory information ({)", + Location, Project.Project); + exit; + end if; + end loop; + + Excluded_Sources_Htable.Set + (Project.Excluded, Name, (Name, False, Location)); + end if; + end loop; + + Prj.Util.Close (File); + end if; + end if; + end; + end if; + end Find_Excluded_Sources; + + ------------------ + -- Find_Sources -- + ------------------ + + procedure Find_Sources + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data) + is + Sources : constant Variable_Value := + Util.Value_Of + (Name_Source_Files, + Project.Project.Decl.Attributes, + Data.Tree); + + Source_List_File : constant Variable_Value := + Util.Value_Of + (Name_Source_List_File, + Project.Project.Decl.Attributes, + Data.Tree); + + Name_Loc : Name_Location; + Has_Explicit_Sources : Boolean; + + begin + pragma Assert (Sources.Kind = List, "Source_Files is not a list"); + pragma Assert + (Source_List_File.Kind = Single, + "Source_List_File is not a single string"); + + Project.Source_List_File_Location := Source_List_File.Location; + + -- If the user has specified a Source_Files attribute + + if not Sources.Default then + if not Source_List_File.Default then + Error_Msg + (Data.Flags, + "?both attributes source_files and " & + "source_list_file are present", + Source_List_File.Location, Project.Project); + end if; + + -- Sources is a list of file names + + declare + Current : String_List_Id := Sources.Values; + Element : String_Element; + Location : Source_Ptr; + Name : File_Name_Type; + + begin + if Current = Nil_String then + Project.Project.Languages := No_Language_Index; + + -- This project contains no source. For projects that don't + -- extend other projects, this also means that there is no + -- need for an object directory, if not specified. + + if Project.Project.Extends = No_Project + and then Project.Project.Object_Directory = + Project.Project.Directory + then + Project.Project.Object_Directory := No_Path_Information; + end if; + end if; + + while Current /= Nil_String loop + Element := Data.Tree.String_Elements.Table (Current); + Name := Canonical_Case_File_Name (Element.Value); + Get_Name_String (Element.Value); + + -- If the element has no location, then use the location of + -- Sources to report possible errors. + + if Element.Location = No_Location then + Location := Sources.Location; + else + Location := Element.Location; + end if; + + -- Check that there is no directory information + + for J in 1 .. Name_Len loop + if Name_Buffer (J) = '/' + or else Name_Buffer (J) = Directory_Separator + then + Error_Msg_File_1 := Name; + Error_Msg + (Data.Flags, + "file name cannot include directory " & + "information ({)", + Location, Project.Project); + exit; + end if; + end loop; + + -- Check whether the file is already there: the same file name + -- may be in the list. If the source is missing, the error will + -- be on the first mention of the source file name. + + Name_Loc := Source_Names_Htable.Get + (Project.Source_Names, Name); + + if Name_Loc = No_Name_Location then + Name_Loc := + (Name => Name, + Location => Location, + Source => No_Source, + Listed => True, + Found => False); + + else + Name_Loc.Listed := True; + end if; + + Source_Names_Htable.Set + (Project.Source_Names, Name, Name_Loc); + + Current := Element.Next; + end loop; + + Has_Explicit_Sources := True; + end; + + -- If we have no Source_Files attribute, check the Source_List_File + -- attribute. + + elsif not Source_List_File.Default then + + -- Source_List_File is the name of the file that contains the source + -- file names. + + declare + Source_File_Path_Name : constant String := + Path_Name_Of + (File_Name_Type (Source_List_File.Value), + Project.Project.Directory.Name); + + begin + Has_Explicit_Sources := True; + + if Source_File_Path_Name'Length = 0 then + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Source_List_File.Value); + Error_Msg + (Data.Flags, + "file with sources { does not exist", + Source_List_File.Location, Project.Project); + + else + Get_Sources_From_File + (Source_File_Path_Name, Source_List_File.Location, + Project, Data); + end if; + end; + + else + -- Neither Source_Files nor Source_List_File has been specified. Find + -- all the files that satisfy the naming scheme in all the source + -- directories. + + Has_Explicit_Sources := False; + end if; + + -- Remove any exception that is not in the specified list of sources + + if Has_Explicit_Sources then + declare + Source : Source_Id; + Iter : Source_Iterator; + NL : Name_Location; + Again : Boolean; + begin + Iter_Loop : + loop + Again := False; + Iter := For_Each_Source (Data.Tree, Project.Project); + + Source_Loop : + loop + Source := Prj.Element (Iter); + exit Source_Loop when Source = No_Source; + + if Source.Naming_Exception then + NL := Source_Names_Htable.Get + (Project.Source_Names, Source.File); + + if NL /= No_Name_Location and then not NL.Listed then + -- Remove the exception + Source_Names_Htable.Set + (Project.Source_Names, + Source.File, + No_Name_Location); + Remove_Source (Data.Tree, Source, No_Source); + + Error_Msg_Name_1 := Name_Id (Source.File); + Error_Msg + (Data.Flags, + "? unknown source file %%", + NL.Location, + Project.Project); + + Again := True; + exit Source_Loop; + end if; + end if; + + Next (Iter); + end loop Source_Loop; + + exit Iter_Loop when not Again; + end loop Iter_Loop; + end; + end if; + + Search_Directories + (Project, + Data => Data, + For_All_Sources => Sources.Default and then Source_List_File.Default); + + -- Check if all exceptions have been found + + declare + Source : Source_Id; + Iter : Source_Iterator; + Found : Boolean := False; + Path : Path_Information; + + begin + Iter := For_Each_Source (Data.Tree, Project.Project); + loop + Source := Prj.Element (Iter); + exit when Source = No_Source; + + if Source.Naming_Exception + and then Source.Path = No_Path_Information + then + if Source.Unit /= No_Unit_Index then + Found := False; + + -- For multi-unit source files, source_id gets duplicated + -- once for every unit. Only the first source_id got its + -- full path set. + + if Source.Index /= 0 then + Path := Files_Htable.Get + (Data.File_To_Source, Source.File).Path; + + if Path /= No_Path_Information then + Found := True; + end if; + end if; + + if not Found then + Error_Msg_Name_1 := Name_Id (Source.Display_File); + Error_Msg_Name_2 := Source.Unit.Name; + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, + "source file %% for unit %% not found", + No_Location, Project.Project); + + else + Source.Path := Path; + + if Current_Verbosity = High then + if Source.Path /= No_Path_Information then + Write_Line ("Setting full path for " + & Get_Name_String (Source.File) + & " at" & Source.Index'Img + & " to " + & Get_Name_String (Path.Name)); + end if; + end if; + end if; + end if; + + if Source.Path = No_Path_Information then + Remove_Source (Data.Tree, Source, No_Source); + end if; + end if; + + Next (Iter); + end loop; + end; + + -- It is an error if a source file name in a source list or in a source + -- list file is not found. + + if Has_Explicit_Sources then + declare + NL : Name_Location; + First_Error : Boolean; + + begin + NL := Source_Names_Htable.Get_First (Project.Source_Names); + First_Error := True; + while NL /= No_Name_Location loop + if not NL.Found then + Err_Vars.Error_Msg_File_1 := NL.Name; + if First_Error then + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, + "source file { not found", + NL.Location, Project.Project); + First_Error := False; + else + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, + "\source file { not found", + NL.Location, Project.Project); + end if; + end if; + + NL := Source_Names_Htable.Get_Next (Project.Source_Names); + end loop; + end; + end if; + end Find_Sources; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize + (Data : out Tree_Processing_Data; + Tree : Project_Tree_Ref; + Node_Tree : Prj.Tree.Project_Node_Tree_Ref; + Flags : Prj.Processing_Flags) + is + begin + Files_Htable.Reset (Data.File_To_Source); + Data.Tree := Tree; + Data.Node_Tree := Node_Tree; + Data.Flags := Flags; + end Initialize; + + ---------- + -- Free -- + ---------- + + procedure Free (Data : in out Tree_Processing_Data) is + begin + Files_Htable.Reset (Data.File_To_Source); + end Free; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize + (Data : in out Project_Processing_Data; + Project : Project_Id) + is + begin + Data.Project := Project; + end Initialize; + + ---------- + -- Free -- + ---------- + + procedure Free (Data : in out Project_Processing_Data) is + begin + Source_Names_Htable.Reset (Data.Source_Names); + Unit_Exceptions_Htable.Reset (Data.Unit_Exceptions); + Excluded_Sources_Htable.Reset (Data.Excluded); + end Free; + + ------------------------------- + -- Check_File_Naming_Schemes -- + ------------------------------- + + procedure Check_File_Naming_Schemes + (In_Tree : Project_Tree_Ref; + Project : Project_Processing_Data; + File_Name : File_Name_Type; + Alternate_Languages : out Language_List; + Language : out Language_Ptr; + Display_Language_Name : out Name_Id; + Unit : out Name_Id; + Lang_Kind : out Language_Kind; + Kind : out Source_Kind) + is + Filename : constant String := Get_Name_String (File_Name); + Config : Language_Config; + Tmp_Lang : Language_Ptr; + + Header_File : Boolean := False; + -- True if we found at least one language for which the file is a header + -- In such a case, we search for all possible languages where this is + -- also a header (C and C++ for instance), since the file might be used + -- for several such languages. + + procedure Check_File_Based_Lang; + -- Does the naming scheme test for file-based languages. For those, + -- there is no Unit. Just check if the file name has the implementation + -- or, if it is specified, the template suffix of the language. + -- + -- Returns True if the file belongs to the current language and we + -- should stop searching for matching languages. Not that a given header + -- file could belong to several languages (C and C++ for instance). Thus + -- if we found a header we'll check whether it matches other languages. + + --------------------------- + -- Check_File_Based_Lang -- + --------------------------- + + procedure Check_File_Based_Lang is + begin + if not Header_File + and then Suffix_Matches (Filename, Config.Naming_Data.Body_Suffix) + then + Unit := No_Name; + Kind := Impl; + Language := Tmp_Lang; + + if Current_Verbosity = High then + Write_Str (" implementation of language "); + Write_Line (Get_Name_String (Display_Language_Name)); + end if; + + elsif Suffix_Matches (Filename, Config.Naming_Data.Spec_Suffix) then + if Current_Verbosity = High then + Write_Str (" header of language "); + Write_Line (Get_Name_String (Display_Language_Name)); + end if; + + if Header_File then + Alternate_Languages := new Language_List_Element' + (Language => Language, + Next => Alternate_Languages); + + else + Header_File := True; + Kind := Spec; + Unit := No_Name; + Language := Tmp_Lang; + end if; + end if; + end Check_File_Based_Lang; + + -- Start of processing for Check_File_Naming_Schemes + + begin + Language := No_Language_Index; + Alternate_Languages := null; + Display_Language_Name := No_Name; + Unit := No_Name; + Lang_Kind := File_Based; + Kind := Spec; + + Tmp_Lang := Project.Project.Languages; + while Tmp_Lang /= No_Language_Index loop + if Current_Verbosity = High then + Write_Line + (" Testing language " + & Get_Name_String (Tmp_Lang.Name) + & " Header_File=" & Header_File'Img); + end if; + + Display_Language_Name := Tmp_Lang.Display_Name; + Config := Tmp_Lang.Config; + Lang_Kind := Config.Kind; + + case Config.Kind is + when File_Based => + Check_File_Based_Lang; + exit when Kind = Impl; + + when Unit_Based => + + -- We know it belongs to a least a file_based language, no + -- need to check unit-based ones. + + if not Header_File then + Compute_Unit_Name + (File_Name => File_Name, + Naming => Config.Naming_Data, + Kind => Kind, + Unit => Unit, + Project => Project, + In_Tree => In_Tree); + + if Unit /= No_Name then + Language := Tmp_Lang; + exit; + end if; + end if; + end case; + + Tmp_Lang := Tmp_Lang.Next; + end loop; + + if Language = No_Language_Index + and then Current_Verbosity = High + then + Write_Line (" not a source of any language"); + end if; + end Check_File_Naming_Schemes; + + ------------------- + -- Override_Kind -- + ------------------- + + procedure Override_Kind (Source : Source_Id; Kind : Source_Kind) is + begin + -- If the file was previously already associated with a unit, change it + + if Source.Unit /= null + and then Source.Kind in Spec_Or_Body + and then Source.Unit.File_Names (Source.Kind) /= null + then + -- If we had another file referencing the same unit (for instance it + -- was in an extended project), that source file is in fact invisible + -- from now on, and in particular doesn't belong to the same unit. + + if Source.Unit.File_Names (Source.Kind) /= Source then + Source.Unit.File_Names (Source.Kind).Unit := No_Unit_Index; + end if; + + Source.Unit.File_Names (Source.Kind) := null; + end if; + + Source.Kind := Kind; + + if Current_Verbosity = High + and then Source.File /= No_File + then + Write_Line ("Override kind for " + & Get_Name_String (Source.File) + & " kind=" & Source.Kind'Img); + end if; + + if Source.Kind in Spec_Or_Body and then Source.Unit /= null then + Source.Unit.File_Names (Source.Kind) := Source; + end if; + end Override_Kind; + + ---------------- + -- Check_File -- + ---------------- + + procedure Check_File + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data; + Source_Dir_Rank : Natural; + Path : Path_Name_Type; + Display_Path : Path_Name_Type; + File_Name : File_Name_Type; + Display_File_Name : File_Name_Type; + Locally_Removed : Boolean; + For_All_Sources : Boolean) + is + Name_Loc : Name_Location := + Source_Names_Htable.Get + (Project.Source_Names, File_Name); + Check_Name : Boolean := False; + Alternate_Languages : Language_List; + Language : Language_Ptr; + Source : Source_Id; + Src_Ind : Source_File_Index; + Unit : Name_Id; + Display_Language_Name : Name_Id; + Lang_Kind : Language_Kind; + Kind : Source_Kind := Spec; + + begin + if Current_Verbosity = High then + Write_Line ("Checking file:"); + Write_Str (" Path = "); + Write_Line (Get_Name_String (Path)); + Write_Str (" Rank ="); + Write_Line (Source_Dir_Rank'Img); + end if; + + if Name_Loc = No_Name_Location then + Check_Name := For_All_Sources; + + else + if Name_Loc.Found then + + -- Check if it is OK to have the same file name in several + -- source directories. + + if Source_Dir_Rank = Name_Loc.Source.Source_Dir_Rank then + Error_Msg_File_1 := File_Name; + Error_Msg + (Data.Flags, + "{ is found in several source directories", + Name_Loc.Location, Project.Project); + end if; + + else + Name_Loc.Found := True; + + Source_Names_Htable.Set + (Project.Source_Names, File_Name, Name_Loc); + + if Name_Loc.Source = No_Source then + Check_Name := True; + + else + Name_Loc.Source.Path := (Path, Display_Path); + + Source_Paths_Htable.Set + (Data.Tree.Source_Paths_HT, + Path, + Name_Loc.Source); + + -- Check if this is a subunit + + if Name_Loc.Source.Unit /= No_Unit_Index + and then Name_Loc.Source.Kind = Impl + then + Src_Ind := Sinput.P.Load_Project_File + (Get_Name_String (Display_Path)); + + if Sinput.P.Source_File_Is_Subunit (Src_Ind) then + Override_Kind (Name_Loc.Source, Sep); + end if; + end if; + + Files_Htable.Set + (Data.File_To_Source, File_Name, Name_Loc.Source); + end if; + end if; + end if; + + if Check_Name then + Check_File_Naming_Schemes + (In_Tree => Data.Tree, + Project => Project, + File_Name => File_Name, + Alternate_Languages => Alternate_Languages, + Language => Language, + Display_Language_Name => Display_Language_Name, + Unit => Unit, + Lang_Kind => Lang_Kind, + Kind => Kind); + + if Language = No_Language_Index then + + -- A file name in a list must be a source of a language + + if Data.Flags.Error_On_Unknown_Language + and then Name_Loc.Found + then + Error_Msg_File_1 := File_Name; + Error_Msg + (Data.Flags, + "language unknown for {", + Name_Loc.Location, Project.Project); + end if; + + else + Add_Source + (Id => Source, + Project => Project.Project, + Source_Dir_Rank => Source_Dir_Rank, + Lang_Id => Language, + Kind => Kind, + Data => Data, + Alternate_Languages => Alternate_Languages, + File_Name => File_Name, + Display_File => Display_File_Name, + Unit => Unit, + Locally_Removed => Locally_Removed, + Path => (Path, Display_Path)); + + -- If it is a source specified in a list, update the entry in + -- the Source_Names table. + + if Name_Loc.Found and then Name_Loc.Source = No_Source then + Name_Loc.Source := Source; + Source_Names_Htable.Set + (Project.Source_Names, File_Name, Name_Loc); + end if; + end if; + end if; + end Check_File; + + --------------------------------- + -- Expand_Subdirectory_Pattern -- + --------------------------------- + + procedure Expand_Subdirectory_Pattern + (Project : Project_Id; + Data : in out Tree_Processing_Data; + Patterns : String_List_Id; + Ignore : String_List_Id; + Search_For : Search_Type; + Resolve_Links : Boolean) + is + package Recursive_Dirs is new GNAT.Dynamic_HTables.Simple_HTable + (Header_Num => Header_Num, + Element => Boolean, + No_Element => False, + Key => Path_Name_Type, + Hash => Hash, + Equal => "="); + -- Hash table stores recursive source directories, to avoid looking + -- several times, and to avoid cycles that may be introduced by symbolic + -- links. + + File_Pattern : GNAT.Regexp.Regexp; + -- Pattern to use when matching file names. + + Visited : Recursive_Dirs.Instance; + + procedure Find_Pattern + (Pattern_Id : Name_Id; + Rank : Natural; + Location : Source_Ptr); + -- Find a specific pattern + + function Recursive_Find_Dirs + (Path : Path_Information; + Rank : Natural) return Boolean; + -- Search all the subdirectories (recursively) of Path. + -- Return True if at least one file or directory was processed + + function Subdirectory_Matches + (Path : Path_Information; + Rank : Natural) return Boolean; + -- Called when a matching directory was found. If the user is in fact + -- searching for files, we then search for those files matching the + -- pattern within the directory. + -- Return True if at least one file or directory was processed + + -------------------------- + -- Subdirectory_Matches -- + -------------------------- + + function Subdirectory_Matches + (Path : Path_Information; + Rank : Natural) return Boolean + is + Dir : Dir_Type; + Name : String (1 .. 250); + Last : Natural; + Found : Path_Information; + Success : Boolean := False; + + begin + case Search_For is + when Search_Directories => + Callback (Path, Rank); + return True; + + when Search_Files => + Open (Dir, Get_Name_String (Path.Display_Name)); + loop + Read (Dir, Name, Last); + exit when Last = 0; + + if Name (Name'First .. Last) /= "." + and then Name (Name'First .. Last) /= ".." + and then Match (Name (Name'First .. Last), File_Pattern) + then + Get_Name_String (Path.Display_Name); + Add_Str_To_Name_Buffer (Name (Name'First .. Last)); + + Found.Display_Name := Name_Find; + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Found.Name := Name_Find; + + Callback (Found, Rank); + Success := True; + end if; + end loop; + + Close (Dir); + + return Success; + end case; + end Subdirectory_Matches; + + ------------------------- + -- Recursive_Find_Dirs -- + ------------------------- + + function Recursive_Find_Dirs + (Path : Path_Information; + Rank : Natural) return Boolean + is + Path_Str : constant String := Get_Name_String (Path.Display_Name); + Dir : Dir_Type; + Name : String (1 .. 250); + Last : Natural; + Success : Boolean := False; + + begin + if Current_Verbosity = High then + Write_Str (" Looking for subdirs of """); + Write_Str (Path_Str); + Write_Line (""""); + end if; + + if Recursive_Dirs.Get (Visited, Path.Name) then + return Success; + end if; + + Recursive_Dirs.Set (Visited, Path.Name, True); + + Success := Subdirectory_Matches (Path, Rank) or Success; + + Open (Dir, Path_Str); + + loop + Read (Dir, Name, Last); + exit when Last = 0; + + if Name (1 .. Last) /= "." + and then Name (1 .. Last) /= ".." + then + declare + Path_Name : constant String := + Normalize_Pathname + (Name => Name (1 .. Last), + Directory => Path_Str, + Resolve_Links => Resolve_Links) + & Directory_Separator; + Path2 : Path_Information; + OK : Boolean := True; + + begin + if Is_Directory (Path_Name) then + if Ignore /= Nil_String then + declare + Dir_Name : String := Name (1 .. Last); + List : String_List_Id := Ignore; + + begin + Canonical_Case_File_Name (Dir_Name); + + while List /= Nil_String loop + Get_Name_String + (Data.Tree.String_Elements.Table (List).Value); + Canonical_Case_File_Name + (Name_Buffer (1 .. Name_Len)); + OK := Name_Buffer (1 .. Name_Len) /= Dir_Name; + exit when not OK; + List := + Data.Tree.String_Elements.Table (List).Next; + end loop; + end; + end if; + + if OK then + Name_Len := 0; + Add_Str_To_Name_Buffer (Path_Name); + Path2.Display_Name := Name_Find; + + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Path2.Name := Name_Find; + + Success := + Recursive_Find_Dirs (Path2, Rank) or Success; + end if; + end if; + end; + end if; + end loop; + + Close (Dir); + + return Success; + + exception + when Directory_Error => + return Success; + end Recursive_Find_Dirs; + + ------------------ + -- Find_Pattern -- + ------------------ + + procedure Find_Pattern + (Pattern_Id : Name_Id; + Rank : Natural; + Location : Source_Ptr) + is + Pattern : constant String := Get_Name_String (Pattern_Id); + Pattern_End : Natural := Pattern'Last; + Recursive : Boolean; + Dir : File_Name_Type; + Path_Name : Path_Information; + Dir_Exists : Boolean; + Has_Error : Boolean := False; + Success : Boolean; + + begin + if Current_Verbosity = High then + Write_Str ("Expand_Subdirectory_Pattern ("""); + Write_Str (Pattern); + Write_Line (""")"); + end if; + + -- If we are looking for files, find the pattern for the files + + if Search_For = Search_Files then + while Pattern_End >= Pattern'First + and then Pattern (Pattern_End) /= '/' + and then Pattern (Pattern_End) /= Directory_Separator + loop + Pattern_End := Pattern_End - 1; + end loop; + + if Pattern_End = Pattern'Last then + Err_Vars.Error_Msg_File_1 := File_Name_Type (Pattern_Id); + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, + "Missing file name or pattern in {", Location, Project); + return; + end if; + + if Current_Verbosity = High then + Write_Str (" file pattern="); + Write_Line (Pattern (Pattern_End + 1 .. Pattern'Last)); + Write_Str (" Expand directory pattern="); + Write_Line (Pattern (Pattern'First .. Pattern_End)); + end if; + + File_Pattern := Compile + (Pattern (Pattern_End + 1 .. Pattern'Last), + Glob => True, + Case_Sensitive => File_Names_Case_Sensitive); + + -- If we had just "*.gpr", this is equivalent to "./*.gpr" + + if Pattern_End > Pattern'First then + Pattern_End := Pattern_End - 1; -- Skip directory separator + end if; + end if; + + Recursive := + Pattern_End - 1 >= Pattern'First + and then Pattern (Pattern_End - 1 .. Pattern_End) = "**" + and then (Pattern_End - 1 = Pattern'First + or else Pattern (Pattern_End - 2) = '/' + or else Pattern (Pattern_End - 2) = Directory_Separator); + + if Recursive then + Pattern_End := Pattern_End - 2; + if Pattern_End > Pattern'First then + Pattern_End := Pattern_End - 1; -- Skip '/' + end if; + end if; + + Name_Len := Pattern_End - Pattern'First + 1; + Name_Buffer (1 .. Name_Len) := Pattern (Pattern'First .. Pattern_End); + Dir := Name_Find; + + Locate_Directory + (Project => Project, + Name => Dir, + Path => Path_Name, + Dir_Exists => Dir_Exists, + Data => Data, + Must_Exist => False); + + if not Dir_Exists then + Err_Vars.Error_Msg_File_1 := Dir; + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, + "{ is not a valid directory", Location, Project); + Has_Error := Data.Flags.Missing_Source_Files = Error; + end if; + + if not Has_Error then + -- Links have been resolved if necessary, and Path_Name + -- always ends with a directory separator. + + if Recursive then + Success := Recursive_Find_Dirs (Path_Name, Rank); + else + Success := Subdirectory_Matches (Path_Name, Rank); + end if; + + if not Success then + case Search_For is + when Search_Directories => + null; -- Error can't occur + + when Search_Files => + Err_Vars.Error_Msg_File_1 := File_Name_Type (Pattern_Id); + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, + "file { not found", Location, Project); + end case; + end if; + end if; + end Find_Pattern; + + -- Local variables + + Pattern_Id : String_List_Id := Patterns; + Element : String_Element; + Rank : Natural := 1; + + -- Start of processing for Expand_Subdirectory_Pattern + + begin + while Pattern_Id /= Nil_String loop + Element := Data.Tree.String_Elements.Table (Pattern_Id); + Find_Pattern (Element.Value, Rank, Element.Location); + Rank := Rank + 1; + Pattern_Id := Element.Next; + end loop; + + Recursive_Dirs.Reset (Visited); + end Expand_Subdirectory_Pattern; + + ------------------------ + -- Search_Directories -- + ------------------------ + + procedure Search_Directories + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data; + For_All_Sources : Boolean) + is + Source_Dir : String_List_Id; + Element : String_Element; + Src_Dir_Rank : Number_List_Index; + Num_Nod : Number_Node; + Dir : Dir_Type; + Name : String (1 .. 1_000); + Last : Natural; + File_Name : File_Name_Type; + Display_File_Name : File_Name_Type; + + begin + if Current_Verbosity = High then + Write_Line ("Looking for sources:"); + end if; + + -- Loop through subdirectories + + Source_Dir := Project.Project.Source_Dirs; + Src_Dir_Rank := Project.Project.Source_Dir_Ranks; + while Source_Dir /= Nil_String loop + begin + Num_Nod := Data.Tree.Number_Lists.Table (Src_Dir_Rank); + Element := Data.Tree.String_Elements.Table (Source_Dir); + + -- Use Element.Value in this test, not Display_Value, because we + -- want the symbolic links to be resolved when appropriate. + + if Element.Value /= No_Name then + declare + Source_Directory : constant String := + Get_Name_String (Element.Value) + & Directory_Separator; + + Dir_Last : constant Natural := + Compute_Directory_Last (Source_Directory); + + Display_Source_Directory : constant String := + Get_Name_String + (Element.Display_Value) + & Directory_Separator; + -- Display_Source_Directory is to allow us to open a UTF-8 + -- encoded directory on Windows. + + begin + if Current_Verbosity = High then + Write_Attr + ("Source_Dir", + Source_Directory (Source_Directory'First .. Dir_Last)); + Write_Line (Num_Nod.Number'Img); + end if; + + -- We look to every entry in the source directory + + Open (Dir, Display_Source_Directory); + + loop + Read (Dir, Name, Last); + + exit when Last = 0; + + -- In fast project loading mode (without -eL), the user + -- guarantees that no directory has a name which is a + -- valid source name, so we can avoid doing a system call + -- here. This provides a very significant speed up on + -- slow file systems (remote files for instance). + + if not Opt.Follow_Links_For_Files + or else Is_Regular_File + (Display_Source_Directory & Name (1 .. Last)) + then + if Current_Verbosity = High then + Write_Str (" Checking "); + Write_Line (Name (1 .. Last)); + end if; + + Name_Len := Last; + Name_Buffer (1 .. Name_Len) := Name (1 .. Last); + Display_File_Name := Name_Find; + + if Osint.File_Names_Case_Sensitive then + File_Name := Display_File_Name; + else + Canonical_Case_File_Name + (Name_Buffer (1 .. Name_Len)); + File_Name := Name_Find; + end if; + + declare + Path_Name : constant String := + Normalize_Pathname + (Name (1 .. Last), + Directory => + Source_Directory + (Source_Directory'First .. + Dir_Last), + Resolve_Links => + Opt.Follow_Links_For_Files, + Case_Sensitive => True); + + Path : Path_Name_Type; + FF : File_Found := + Excluded_Sources_Htable.Get + (Project.Excluded, File_Name); + To_Remove : Boolean := False; + + begin + Name_Len := Path_Name'Length; + Name_Buffer (1 .. Name_Len) := Path_Name; + + if Osint.File_Names_Case_Sensitive then + Path := Name_Find; + else + Canonical_Case_File_Name + (Name_Buffer (1 .. Name_Len)); + Path := Name_Find; + end if; + + if FF /= No_File_Found then + if not FF.Found then + FF.Found := True; + Excluded_Sources_Htable.Set + (Project.Excluded, File_Name, FF); + + if Current_Verbosity = High then + Write_Str (" excluded source """); + Write_Str + (Get_Name_String (Display_File_Name)); + Write_Line (""""); + end if; + + -- Will mark the file as removed, but we + -- still need to add it to the list: if we + -- don't, the file will not appear in the + -- mapping file and will cause the compiler + -- to fail. + + To_Remove := True; + end if; + end if; + + -- Preserve the user's original casing and use of + -- links. The display_value (a directory) already + -- ends with a directory separator by construction, + -- so no need to add one. + + Get_Name_String (Element.Display_Value); + Get_Name_String_And_Append (Display_File_Name); + + Check_File + (Project => Project, + Source_Dir_Rank => Num_Nod.Number, + Data => Data, + Path => Path, + Display_Path => Name_Find, + File_Name => File_Name, + Locally_Removed => To_Remove, + Display_File_Name => Display_File_Name, + For_All_Sources => For_All_Sources); + end; + end if; + end loop; + + Close (Dir); + end; + end if; + + exception + when Directory_Error => + null; + end; + + Source_Dir := Element.Next; + Src_Dir_Rank := Num_Nod.Next; + end loop; + + if Current_Verbosity = High then + Write_Line ("end Looking for sources."); + end if; + end Search_Directories; + + ---------------------------- + -- Load_Naming_Exceptions -- + ---------------------------- + + procedure Load_Naming_Exceptions + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data) + is + Source : Source_Id; + Iter : Source_Iterator; + + begin + Iter := For_Each_Source (Data.Tree, Project.Project); + loop + Source := Prj.Element (Iter); + exit when Source = No_Source; + + -- An excluded file cannot also be an exception file name + + if Excluded_Sources_Htable.Get (Project.Excluded, Source.File) /= + No_File_Found + then + Error_Msg_File_1 := Source.File; + Error_Msg + (Data.Flags, + "{ cannot be both excluded and an exception file name", + No_Location, Project.Project); + end if; + + if Current_Verbosity = High then + Write_Str ("Naming exception: Putting source file "); + Write_Str (Get_Name_String (Source.File)); + Write_Line (" in Source_Names"); + end if; + + Source_Names_Htable.Set + (Project.Source_Names, + K => Source.File, + E => Name_Location' + (Name => Source.File, + Location => Source.Location, + Source => Source, + Listed => False, + Found => False)); + + -- If this is an Ada exception, record in table Unit_Exceptions + + if Source.Unit /= No_Unit_Index then + declare + Unit_Except : Unit_Exception := + Unit_Exceptions_Htable.Get + (Project.Unit_Exceptions, Source.Unit.Name); + + begin + Unit_Except.Name := Source.Unit.Name; + + if Source.Kind = Spec then + Unit_Except.Spec := Source.File; + else + Unit_Except.Impl := Source.File; + end if; + + Unit_Exceptions_Htable.Set + (Project.Unit_Exceptions, Source.Unit.Name, Unit_Except); + end; + end if; + + Next (Iter); + end loop; + end Load_Naming_Exceptions; + + ---------------------- + -- Look_For_Sources -- + ---------------------- + + procedure Look_For_Sources + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data) + is + Object_Files : Object_File_Names_Htable.Instance; + Iter : Source_Iterator; + Src : Source_Id; + + procedure Check_Object (Src : Source_Id); + -- Check if object file name of Src is already used in the project tree, + -- and report an error if so. + + procedure Check_Object_Files; + -- Check that no two sources of this project have the same object file + + procedure Mark_Excluded_Sources; + -- Mark as such the sources that are declared as excluded + + procedure Check_Missing_Sources; + -- Check whether one of the languages has no sources, and report an + -- error when appropriate + + procedure Get_Sources_From_Source_Info; + -- Get the source information from the tables that were created when a + -- source info fie was read. + + --------------------------- + -- Check_Missing_Sources -- + --------------------------- + + procedure Check_Missing_Sources is + Extending : constant Boolean := + Project.Project.Extends /= No_Project; + Language : Language_Ptr; + Source : Source_Id; + Alt_Lang : Language_List; + Continuation : Boolean := False; + Iter : Source_Iterator; + begin + if not Project.Project.Externally_Built + and then not Extending + then + Language := Project.Project.Languages; + while Language /= No_Language_Index loop + + -- If there are no sources for this language, check if there + -- are sources for which this is an alternate language. + + if Language.First_Source = No_Source + and then (Data.Flags.Require_Sources_Other_Lang + or else Language.Name = Name_Ada) + then + Iter := For_Each_Source (In_Tree => Data.Tree, + Project => Project.Project); + Source_Loop : loop + Source := Element (Iter); + exit Source_Loop when Source = No_Source + or else Source.Language = Language; + + Alt_Lang := Source.Alternate_Languages; + while Alt_Lang /= null loop + exit Source_Loop when Alt_Lang.Language = Language; + Alt_Lang := Alt_Lang.Next; + end loop; + + Next (Iter); + end loop Source_Loop; + + if Source = No_Source then + Report_No_Sources + (Project.Project, + Get_Name_String (Language.Display_Name), + Data, + Project.Source_List_File_Location, + Continuation); + Continuation := True; + end if; + end if; + + Language := Language.Next; + end loop; + end if; + end Check_Missing_Sources; + + ------------------ + -- Check_Object -- + ------------------ + + procedure Check_Object (Src : Source_Id) is + Source : Source_Id; + + begin + Source := Object_File_Names_Htable.Get (Object_Files, Src.Object); + + -- We cannot just check on "Source /= Src", since we might have + -- two different entries for the same file (and since that's + -- the same file it is expected that it has the same object) + + if Source /= No_Source + and then Source.Path /= Src.Path + then + Error_Msg_File_1 := Src.File; + Error_Msg_File_2 := Source.File; + Error_Msg + (Data.Flags, + "{ and { have the same object file name", + No_Location, Project.Project); + + else + Object_File_Names_Htable.Set (Object_Files, Src.Object, Src); + end if; + end Check_Object; + + --------------------------- + -- Mark_Excluded_Sources -- + --------------------------- + + procedure Mark_Excluded_Sources is + Source : Source_Id := No_Source; + Excluded : File_Found; + Proj : Project_Id; + + begin + -- Minor optimization: if there are no excluded files, no need to + -- traverse the list of sources. We cannot however also check whether + -- the existing exceptions have ".Found" set to True (indicating we + -- found them before) because we need to do some final processing on + -- them in any case. + + if Excluded_Sources_Htable.Get_First (Project.Excluded) /= + No_File_Found + then + Proj := Project.Project; + while Proj /= No_Project loop + Iter := For_Each_Source (Data.Tree, Proj); + while Prj.Element (Iter) /= No_Source loop + Source := Prj.Element (Iter); + Excluded := Excluded_Sources_Htable.Get + (Project.Excluded, Source.File); + + if Excluded /= No_File_Found then + Source.Locally_Removed := True; + Source.In_Interfaces := False; + + if Current_Verbosity = High then + Write_Str ("Removing file "); + Write_Line + (Get_Name_String (Excluded.File) + & " " & Get_Name_String (Source.Project.Name)); + end if; + + Excluded_Sources_Htable.Remove + (Project.Excluded, Source.File); + end if; + + Next (Iter); + end loop; + + Proj := Proj.Extends; + end loop; + end if; + + -- If we have any excluded element left, that means we did not find + -- the source file + + Excluded := Excluded_Sources_Htable.Get_First (Project.Excluded); + while Excluded /= No_File_Found loop + if not Excluded.Found then + + -- Check if the file belongs to another imported project to + -- provide a better error message. + + Src := Find_Source + (In_Tree => Data.Tree, + Project => Project.Project, + In_Imported_Only => True, + Base_Name => Excluded.File); + + Err_Vars.Error_Msg_File_1 := Excluded.File; + + if Src = No_Source then + Error_Msg + (Data.Flags, + "unknown file {", Excluded.Location, Project.Project); + else + Error_Msg + (Data.Flags, + "cannot remove a source from an imported project: {", + Excluded.Location, Project.Project); + end if; + end if; + + Excluded := Excluded_Sources_Htable.Get_Next (Project.Excluded); + end loop; + end Mark_Excluded_Sources; + + ------------------------ + -- Check_Object_Files -- + ------------------------ + + procedure Check_Object_Files is + Iter : Source_Iterator; + Src_Id : Source_Id; + Src_Ind : Source_File_Index; + + begin + Iter := For_Each_Source (Data.Tree); + loop + Src_Id := Prj.Element (Iter); + exit when Src_Id = No_Source; + + if Is_Compilable (Src_Id) + and then Src_Id.Language.Config.Object_Generated + and then Is_Extending (Project.Project, Src_Id.Project) + then + if Src_Id.Unit = No_Unit_Index then + if Src_Id.Kind = Impl then + Check_Object (Src_Id); + end if; + + else + case Src_Id.Kind is + when Spec => + if Other_Part (Src_Id) = No_Source then + Check_Object (Src_Id); + end if; + + when Sep => + null; + + when Impl => + if Other_Part (Src_Id) /= No_Source then + Check_Object (Src_Id); + + else + -- Check if it is a subunit + + Src_Ind := + Sinput.P.Load_Project_File + (Get_Name_String (Src_Id.Path.Display_Name)); + + if Sinput.P.Source_File_Is_Subunit (Src_Ind) then + Override_Kind (Src_Id, Sep); + else + Check_Object (Src_Id); + end if; + end if; + end case; + end if; + end if; + + Next (Iter); + end loop; + end Check_Object_Files; + + ---------------------------------- + -- Get_Sources_From_Source_Info -- + ---------------------------------- + + procedure Get_Sources_From_Source_Info is + Iter : Source_Info_Iterator; + Src : Source_Info; + Id : Source_Id; + Lang_Id : Language_Ptr; + begin + Initialize (Iter, Project.Project.Name); + + loop + Src := Source_Info_Of (Iter); + + exit when Src = No_Source_Info; + + Id := new Source_Data; + + Id.Project := Project.Project; + + Lang_Id := Project.Project.Languages; + while Lang_Id /= No_Language_Index and then + Lang_Id.Name /= Src.Language + loop + Lang_Id := Lang_Id.Next; + end loop; + + if Lang_Id = No_Language_Index then + Prj.Com.Fail + ("unknown language " & + Get_Name_String (Src.Language) & + " for project " & + Get_Name_String (Src.Project) & + " in source info file"); + end if; + + Id.Language := Lang_Id; + Id.Kind := Src.Kind; + + Id.Index := Src.Index; + + Id.Path := + (Path_Name_Type (Src.Display_Path_Name), + Path_Name_Type (Src.Path_Name)); + + Name_Len := 0; + Add_Str_To_Name_Buffer + (Ada.Directories.Simple_Name + (Get_Name_String (Src.Path_Name))); + Id.File := Name_Find; + + Id.Next_With_File_Name := + Source_Files_Htable.Get (Data.Tree.Source_Files_HT, Id.File); + Source_Files_Htable.Set (Data.Tree.Source_Files_HT, Id.File, Id); + + Name_Len := 0; + Add_Str_To_Name_Buffer + (Ada.Directories.Simple_Name + (Get_Name_String (Src.Display_Path_Name))); + Id.Display_File := Name_Find; + + Id.Dep_Name := Dependency_Name + (Id.File, Id.Language.Config.Dependency_Kind); + Id.Naming_Exception := Src.Naming_Exception; + Id.Object := Object_Name + (Id.File, Id.Language.Config.Object_File_Suffix); + Id.Switches := Switches_Name (Id.File); + + -- Add the source id to the Unit_Sources_HT hash table, if the + -- unit name is not null. + + if Src.Kind /= Sep and then Src.Unit_Name /= No_Name then + + declare + UData : Unit_Index := + Units_Htable.Get (Data.Tree.Units_HT, Src.Unit_Name); + begin + if UData = No_Unit_Index then + UData := new Unit_Data; + UData.Name := Src.Unit_Name; + Units_Htable.Set + (Data.Tree.Units_HT, Src.Unit_Name, UData); + end if; + + Id.Unit := UData; + end; + + -- Note that this updates Unit information as well + + Override_Kind (Id, Id.Kind); + end if; + + if Src.Index /= 0 then + Project.Project.Has_Multi_Unit_Sources := True; + end if; + + -- Add the source to the language list + + Id.Next_In_Lang := Id.Language.First_Source; + Id.Language.First_Source := Id; + + Files_Htable.Set (Data.File_To_Source, Id.File, Id); + + Next (Iter); + end loop; + end Get_Sources_From_Source_Info; + + -- Start of processing for Look_For_Sources + + begin + if Data.Tree.Source_Info_File_Exists then + Get_Sources_From_Source_Info; + + else + if Project.Project.Source_Dirs /= Nil_String then + Find_Excluded_Sources (Project, Data); + + if Project.Project.Languages /= No_Language_Index then + Load_Naming_Exceptions (Project, Data); + Find_Sources (Project, Data); + Mark_Excluded_Sources; + Check_Object_Files; + Check_Missing_Sources; + end if; + end if; + + Object_File_Names_Htable.Reset (Object_Files); + end if; + end Look_For_Sources; + + ------------------ + -- Path_Name_Of -- + ------------------ + + function Path_Name_Of + (File_Name : File_Name_Type; + Directory : Path_Name_Type) return String + is + Result : String_Access; + The_Directory : constant String := Get_Name_String (Directory); + + begin + Get_Name_String (File_Name); + Result := + Locate_Regular_File + (File_Name => Name_Buffer (1 .. Name_Len), + Path => The_Directory); + + if Result = null then + return ""; + else + declare + R : String := Result.all; + begin + Free (Result); + Canonical_Case_File_Name (R); + return R; + end; + end if; + end Path_Name_Of; + + ------------------- + -- Remove_Source -- + ------------------- + + procedure Remove_Source + (Tree : Project_Tree_Ref; + Id : Source_Id; + Replaced_By : Source_Id) + is + Source : Source_Id; + + begin + if Current_Verbosity = High then + Write_Str ("Removing source "); + Write_Str (Get_Name_String (Id.File)); + + if Id.Index /= 0 then + Write_Str (" at" & Id.Index'Img); + end if; + + Write_Eol; + end if; + + if Replaced_By /= No_Source then + Id.Replaced_By := Replaced_By; + Replaced_By.Declared_In_Interfaces := Id.Declared_In_Interfaces; + + if Id.File /= Replaced_By.File then + declare + Replacement : constant File_Name_Type := + Replaced_Source_HTable.Get + (Tree.Replaced_Sources, Id.File); + + begin + Replaced_Source_HTable.Set + (Tree.Replaced_Sources, Id.File, Replaced_By.File); + + if Replacement = No_File then + Tree.Replaced_Source_Number := + Tree.Replaced_Source_Number + 1; + end if; + end; + end if; + end if; + + Id.In_Interfaces := False; + Id.Locally_Removed := True; + + -- ??? Should we remove the source from the unit ? The file is not used, + -- so probably should not be referenced from the unit. On the other hand + -- it might give useful additional info + -- if Id.Unit /= null then + -- Id.Unit.File_Names (Id.Kind) := null; + -- end if; + + Source := Id.Language.First_Source; + + if Source = Id then + Id.Language.First_Source := Id.Next_In_Lang; + + else + while Source.Next_In_Lang /= Id loop + Source := Source.Next_In_Lang; + end loop; + + Source.Next_In_Lang := Id.Next_In_Lang; + end if; + end Remove_Source; + + ----------------------- + -- Report_No_Sources -- + ----------------------- + + procedure Report_No_Sources + (Project : Project_Id; + Lang_Name : String; + Data : Tree_Processing_Data; + Location : Source_Ptr; + Continuation : Boolean := False) + is + begin + case Data.Flags.When_No_Sources is + when Silent => + null; + + when Warning | Error => + declare + Msg : constant String := + " Tree, Node_Tree => Node_Tree, Flags => Flags); + Check_All_Projects (Root_Project, Data, Imported_First => True); + Free (Data); + + -- Adjust language configs for projects that are extended + + declare + List : Project_List; + Proj : Project_Id; + Exte : Project_Id; + Lang : Language_Ptr; + Elng : Language_Ptr; + + begin + List := Tree.Projects; + while List /= null loop + Proj := List.Project; + Exte := Proj; + while Exte.Extended_By /= No_Project loop + Exte := Exte.Extended_By; + end loop; + + if Exte /= Proj then + Lang := Proj.Languages; + + if Lang /= No_Language_Index then + loop + Elng := Get_Language_From_Name + (Exte, Get_Name_String (Lang.Name)); + exit when Elng /= No_Language_Index; + Exte := Exte.Extends; + end loop; + + if Elng /= Lang then + Lang.Config := Elng.Config; + end if; + end if; + end if; + + List := List.Next; + end loop; + end; + end Process_Naming_Scheme; + +end Prj.Nmsc; diff --git a/gcc/ada/prj-nmsc.ads b/gcc/ada/prj-nmsc.ads new file mode 100644 index 000000000..ce57e9007 --- /dev/null +++ b/gcc/ada/prj-nmsc.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . N M S C -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Find source dirs and source files for a project + +with Prj.Tree; + +private package Prj.Nmsc is + + procedure Process_Naming_Scheme + (Tree : Project_Tree_Ref; + Root_Project : Project_Id; + Node_Tree : Prj.Tree.Project_Node_Tree_Ref; + Flags : Processing_Flags); + -- Perform consistency and semantic checks on all the projects in the tree. + -- This procedure interprets the various case statements in the project + -- based on the current external references. After checking the validity of + -- the naming scheme, it searches for all the source files of the project. + -- The result of this procedure is a filled-in data structure for + -- Project_Id which contains all the information about the project. This + -- information is only valid while the external references are preserved. + +end Prj.Nmsc; diff --git a/gcc/ada/prj-pars.adb b/gcc/ada/prj-pars.adb new file mode 100644 index 000000000..7ab7ea047 --- /dev/null +++ b/gcc/ada/prj-pars.adb @@ -0,0 +1,142 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . P A R S -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 GNAT.Directory_Operations; use GNAT.Directory_Operations; + +with Output; use Output; +with Prj.Conf; use Prj.Conf; +with Prj.Err; use Prj.Err; +with Prj.Part; +with Prj.Tree; use Prj.Tree; +with Sinput.P; + +package body Prj.Pars is + + ----------- + -- Parse -- + ----------- + + procedure Parse + (In_Tree : Project_Tree_Ref; + Project : out Project_Id; + Project_File_Name : String; + Packages_To_Check : String_List_Access := All_Packages; + Flags : Processing_Flags; + Reset_Tree : Boolean := True; + In_Node_Tree : Prj.Tree.Project_Node_Tree_Ref := null) + is + Project_Node : Project_Node_Id := Empty_Node; + The_Project : Project_Id := No_Project; + Success : Boolean := True; + Current_Dir : constant String := Get_Current_Dir; + Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref := In_Node_Tree; + Automatically_Generated : Boolean; + Config_File_Path : String_Access; + + begin + if Project_Node_Tree = null then + Project_Node_Tree := new Project_Node_Tree_Data; + Prj.Tree.Initialize (Project_Node_Tree); + end if; + + -- Parse the main project file into a tree + + Sinput.P.Reset_First; + Prj.Part.Parse + (In_Tree => Project_Node_Tree, + Project => Project_Node, + Project_File_Name => Project_File_Name, + Always_Errout_Finalize => False, + Packages_To_Check => Packages_To_Check, + Current_Directory => Current_Dir, + Flags => Flags, + Is_Config_File => False); + + -- If there were no error, process the tree + + if Project_Node /= Empty_Node then + begin + -- No config file should be read from the disk for gnatmake. + -- However, we will simulate one that only contains the + -- default GNAT naming scheme. + + Process_Project_And_Apply_Config + (Main_Project => The_Project, + User_Project_Node => Project_Node, + Config_File_Name => "", + Autoconf_Specified => False, + Project_Tree => In_Tree, + Project_Node_Tree => Project_Node_Tree, + Packages_To_Check => null, + Allow_Automatic_Generation => False, + Automatically_Generated => Automatically_Generated, + Config_File_Path => Config_File_Path, + Flags => Flags, + Normalized_Hostname => "", + On_Load_Config => + Add_Default_GNAT_Naming_Scheme'Access, + Reset_Tree => Reset_Tree); + + Success := The_Project /= No_Project; + + exception + when Invalid_Config => + Success := False; + end; + + Prj.Err.Finalize; + + if not Success then + The_Project := No_Project; + end if; + end if; + + Project := The_Project; + + -- ??? Should free the project_node_tree, no longer useful + + exception + when X : others => + + -- Internal error + + Write_Line (Exception_Information (X)); + Write_Str ("Exception "); + Write_Str (Exception_Name (X)); + Write_Line (" raised, while processing project file"); + Project := No_Project; + end Parse; + + ------------------- + -- Set_Verbosity -- + ------------------- + + procedure Set_Verbosity (To : Verbosity) is + begin + Current_Verbosity := To; + end Set_Verbosity; + +end Prj.Pars; diff --git a/gcc/ada/prj-pars.ads b/gcc/ada/prj-pars.ads new file mode 100644 index 000000000..4e7d4808d --- /dev/null +++ b/gcc/ada/prj-pars.ads @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . P A R 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- General wrapper for the parsing of project files + +with Prj.Tree; + +package Prj.Pars is + + procedure Set_Verbosity (To : Verbosity); + -- Set the verbosity when parsing the project files + + procedure Parse + (In_Tree : Project_Tree_Ref; + Project : out Project_Id; + Project_File_Name : String; + Packages_To_Check : String_List_Access := All_Packages; + Flags : Processing_Flags; + Reset_Tree : Boolean := True; + In_Node_Tree : Prj.Tree.Project_Node_Tree_Ref := null); + -- Parse and process a project files and all its imported project files, in + -- the project tree In_Tree. + -- All the project files are parsed (through Prj.Tree) to create a tree in + -- memory. That tree is then processed (through Prj.Proc) to create a + -- expanded representation of the tree based on the current external + -- references. This function is only a convenient wrapper over other + -- services provided in the Prj.* package hierarchy. + -- + -- If parsing is successful, Project is the project ID of the root project + -- file; otherwise, Project_Id is set to No_Project. Project_Node_Tree is + -- set to the tree (unprocessed) representation of the project file. This + -- tree is permanently correct, whereas Project will need to be recomputed + -- if the external references change. + -- + -- Packages_To_Check indicates the packages where any unknown attribute + -- produces an error. For other packages, an unknown attribute produces a + -- warning. + -- + -- When Reset_Tree is True, all the project data are removed from the + -- project table before processing. + -- + -- In_Node_Tree (if given) must have been Initialized. The main reason to + -- pass an existing tree, is to pass the external references that will then + -- be used to process the tree. + +end Prj.Pars; diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb new file mode 100644 index 000000000..9fb5a06c8 --- /dev/null +++ b/gcc/ada/prj-part.adb @@ -0,0 +1,2003 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . P A R T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Err_Vars; use Err_Vars; +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; +with Prj.Com; use Prj.Com; +with Prj.Dect; +with Prj.Env; use Prj.Env; +with Prj.Err; use Prj.Err; +with Sinput; use Sinput; +with Sinput.P; use Sinput.P; +with Snames; +with Table; + +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Exceptions; use Ada.Exceptions; + +with GNAT.HTable; use GNAT.HTable; + +package body Prj.Part is + + Buffer : String_Access; + Buffer_Last : Natural := 0; + + Dir_Sep : Character renames GNAT.OS_Lib.Directory_Separator; + + ------------------------------------ + -- Local Packages and Subprograms -- + ------------------------------------ + + type With_Id is new Nat; + No_With : constant With_Id := 0; + + type With_Record is record + Path : Path_Name_Type; + Location : Source_Ptr; + Limited_With : Boolean; + Node : Project_Node_Id; + Next : With_Id; + end record; + -- Information about an imported project, to be put in table Withs below + + package Withs is new Table.Table + (Table_Component_Type => With_Record, + Table_Index_Type => With_Id, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Prj.Part.Withs"); + -- Table used to store temporarily paths and locations of imported + -- projects. These imported projects will be effectively parsed later: just + -- before parsing the current project for the non limited withed projects, + -- after getting its name; after complete parsing of the current project + -- for the limited withed projects. + + type Names_And_Id is record + Path_Name : Path_Name_Type; + Canonical_Path_Name : Path_Name_Type; + Id : Project_Node_Id; + Limited_With : Boolean; + end record; + + package Project_Stack is new Table.Table + (Table_Component_Type => Names_And_Id, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Prj.Part.Project_Stack"); + -- This table is used to detect circular dependencies + -- for imported and extended projects and to get the project ids of + -- limited imported projects when there is a circularity with at least + -- one limited imported project file. + + package Virtual_Hash is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Project_Node_Id, + No_Element => Empty_Node, + Key => Project_Node_Id, + Hash => Prj.Tree.Hash, + Equal => "="); + -- Hash table to store the node id of the project for which a virtual + -- extending project need to be created. + + package Processed_Hash is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Boolean, + No_Element => False, + Key => Project_Node_Id, + Hash => Prj.Tree.Hash, + Equal => "="); + -- Hash table to store the project process when looking for project that + -- need to have a virtual extending project, to avoid processing the same + -- project twice. + + function Has_Circular_Dependencies + (Flags : Processing_Flags; + Normed_Path_Name : Path_Name_Type; + Canonical_Path_Name : Path_Name_Type) return Boolean; + -- Check for a circular dependency in the loaded project. + -- Generates an error message in such a case. + + procedure Read_Project_Qualifier + (Flags : Processing_Flags; + In_Tree : Project_Node_Tree_Ref; + Is_Config_File : Boolean; + Qualifier_Location : out Source_Ptr; + Project : Project_Node_Id); + -- Check if there is a qualifier before the reserved word "project" + + -- Hash table to cache project path to avoid looking for them on the path + + procedure Check_Extending_All_Imports + (Flags : Processing_Flags; + In_Tree : Project_Node_Tree_Ref; + Project : Project_Node_Id); + -- Check that a non extending-all project does not import an + -- extending-all project. + + procedure Check_Aggregate_Imports + (Flags : Processing_Flags; + In_Tree : Project_Node_Tree_Ref; + Project : Project_Node_Id); + -- Check that an aggregate project only imports abstract projects + + procedure Create_Virtual_Extending_Project + (For_Project : Project_Node_Id; + Main_Project : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref); + -- Create a virtual extending project of For_Project. Main_Project is + -- the extending all project. + -- + -- The String_Value_Of is not set for the automatically added with + -- clause and keeps the default value of No_Name. This enables Prj.PP + -- to skip these automatically added with clauses to be processed. + + procedure Look_For_Virtual_Projects_For + (Proj : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + Potentially_Virtual : Boolean); + -- Look for projects that need to have a virtual extending project. + -- This procedure is recursive. If called with Potentially_Virtual set to + -- True, then Proj may need an virtual extending project; otherwise it + -- does not (because it is already extended), but other projects that it + -- imports may need to be virtually extended. + + type Extension_Origin is (None, Extending_Simple, Extending_All); + -- Type of parameter From_Extended for procedures Parse_Single_Project and + -- Post_Parse_Context_Clause. Extending_All means that we are parsing the + -- tree rooted at an extending all project. + + procedure Parse_Single_Project + (In_Tree : Project_Node_Tree_Ref; + Project : out Project_Node_Id; + Extends_All : out Boolean; + Path_Name_Id : Path_Name_Type; + Extended : Boolean; + From_Extended : Extension_Origin; + In_Limited : Boolean; + Packages_To_Check : String_List_Access; + Depth : Natural; + Current_Dir : String; + Is_Config_File : Boolean; + Flags : Processing_Flags); + -- Parse a project file. This is a recursive procedure: it calls itself for + -- imported and extended projects. When From_Extended is not None, if the + -- project has already been parsed and is an extended project A, return the + -- ultimate (not extended) project that extends A. When In_Limited is True, + -- the importing path includes at least one "limited with". When parsing + -- configuration projects, do not allow a depth > 1. + -- + -- Is_Config_File should be set to True if the project represents a config + -- file (.cgpr) since some specific checks apply. + + procedure Pre_Parse_Context_Clause + (In_Tree : Project_Node_Tree_Ref; + Context_Clause : out With_Id; + Is_Config_File : Boolean; + Flags : Processing_Flags); + -- Parse the context clause of a project. Store the paths and locations of + -- the imported projects in table Withs. Does nothing if there is no + -- context clause (if the current token is not "with" or "limited" followed + -- by "with"). + -- Is_Config_File should be set to True if the project represents a config + -- file (.cgpr) since some specific checks apply. + + procedure Post_Parse_Context_Clause + (Context_Clause : With_Id; + In_Tree : Project_Node_Tree_Ref; + Limited_Withs : Boolean; + Imported_Projects : in out Project_Node_Id; + Project_Directory : Path_Name_Type; + From_Extended : Extension_Origin; + In_Limited : Boolean; + Packages_To_Check : String_List_Access; + Depth : Natural; + Current_Dir : String; + Is_Config_File : Boolean; + Flags : Processing_Flags); + -- Parse the imported projects that have been stored in table Withs, if + -- any. From_Extended is used for the call to Parse_Single_Project below. + -- When In_Limited is True, the importing path includes at least one + -- "limited with". When Limited_Withs is False, only non limited withed + -- projects are parsed. When Limited_Withs is True, only limited withed + -- projects are parsed. + -- Is_Config_File should be set to True if the project represents a config + -- file (.cgpr) since some specific checks apply. + + function Project_Name_From + (Path_Name : String; + Is_Config_File : Boolean) return Name_Id; + -- Returns the name of the project that corresponds to its path name. + -- Returns No_Name if the path name is invalid, because the corresponding + -- project name does not have the syntax of an ada identifier. + + -------------------------------------- + -- Create_Virtual_Extending_Project -- + -------------------------------------- + + procedure Create_Virtual_Extending_Project + (For_Project : Project_Node_Id; + Main_Project : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) + is + + Virtual_Name : constant String := + Virtual_Prefix & + Get_Name_String (Name_Of (For_Project, In_Tree)); + -- The name of the virtual extending project + + Virtual_Name_Id : Name_Id; + -- Virtual extending project name id + + Virtual_Path_Id : Path_Name_Type; + -- Fake path name of the virtual extending project. The directory is + -- the same directory as the extending all project. + + -- The source of the virtual extending project is something like: + + -- project V$ extends is + + -- for Source_Dirs use (); + + -- end V$; + + -- The project directory cannot be specified during parsing; it will be + -- put directly in the virtual extending project data during processing. + + -- Nodes that made up the virtual extending project + + Virtual_Project : Project_Node_Id; + With_Clause : constant Project_Node_Id := + Default_Project_Node + (In_Tree, N_With_Clause); + Project_Declaration : Project_Node_Id; + Source_Dirs_Declaration : constant Project_Node_Id := + Default_Project_Node + (In_Tree, N_Declarative_Item); + Source_Dirs_Attribute : constant Project_Node_Id := + Default_Project_Node + (In_Tree, N_Attribute_Declaration, List); + Source_Dirs_Expression : constant Project_Node_Id := + Default_Project_Node + (In_Tree, N_Expression, List); + Source_Dirs_Term : constant Project_Node_Id := + Default_Project_Node + (In_Tree, N_Term, List); + Source_Dirs_List : constant Project_Node_Id := + Default_Project_Node + (In_Tree, N_Literal_String_List, List); + + begin + -- Get the virtual path name + + Get_Name_String (Path_Name_Of (Main_Project, In_Tree)); + + while Name_Len > 0 + and then Name_Buffer (Name_Len) /= Directory_Separator + and then Name_Buffer (Name_Len) /= '/' + loop + Name_Len := Name_Len - 1; + end loop; + + Name_Buffer (Name_Len + 1 .. Name_Len + Virtual_Name'Length) := + Virtual_Name; + Name_Len := Name_Len + Virtual_Name'Length; + Virtual_Path_Id := Name_Find; + + -- Get the virtual name id + + Name_Len := Virtual_Name'Length; + Name_Buffer (1 .. Name_Len) := Virtual_Name; + Virtual_Name_Id := Name_Find; + + Virtual_Project := Create_Project + (In_Tree => In_Tree, + Name => Virtual_Name_Id, + Full_Path => Virtual_Path_Id, + Is_Config_File => False); + + Project_Declaration := Project_Declaration_Of (Virtual_Project, In_Tree); + + -- With clause + + Set_Name_Of (With_Clause, In_Tree, Virtual_Name_Id); + Set_Path_Name_Of (With_Clause, In_Tree, Virtual_Path_Id); + Set_Project_Node_Of (With_Clause, In_Tree, Virtual_Project); + Set_Next_With_Clause_Of + (With_Clause, In_Tree, First_With_Clause_Of (Main_Project, In_Tree)); + Set_First_With_Clause_Of (Main_Project, In_Tree, With_Clause); + + -- Virtual project node + + Set_Location_Of + (Virtual_Project, In_Tree, Location_Of (Main_Project, In_Tree)); + Set_Extended_Project_Path_Of + (Virtual_Project, In_Tree, Path_Name_Of (For_Project, In_Tree)); + + -- Project declaration + + Set_First_Declarative_Item_Of + (Project_Declaration, In_Tree, Source_Dirs_Declaration); + Set_Extended_Project_Of (Project_Declaration, In_Tree, For_Project); + + -- Source_Dirs declaration + + Set_Current_Item_Node + (Source_Dirs_Declaration, In_Tree, Source_Dirs_Attribute); + + -- Source_Dirs attribute + + Set_Name_Of (Source_Dirs_Attribute, In_Tree, Snames.Name_Source_Dirs); + Set_Expression_Of + (Source_Dirs_Attribute, In_Tree, Source_Dirs_Expression); + + -- Source_Dirs expression + + Set_First_Term (Source_Dirs_Expression, In_Tree, Source_Dirs_Term); + + -- Source_Dirs term + + Set_Current_Term (Source_Dirs_Term, In_Tree, Source_Dirs_List); + + -- Source_Dirs empty list: nothing to do + end Create_Virtual_Extending_Project; + + ----------------------------------- + -- Look_For_Virtual_Projects_For -- + ----------------------------------- + + procedure Look_For_Virtual_Projects_For + (Proj : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + Potentially_Virtual : Boolean) + is + Declaration : Project_Node_Id := Empty_Node; + -- Node for the project declaration of Proj + + With_Clause : Project_Node_Id := Empty_Node; + -- Node for a with clause of Proj + + Imported : Project_Node_Id := Empty_Node; + -- Node for a project imported by Proj + + Extended : Project_Node_Id := Empty_Node; + -- Node for the eventual project extended by Proj + + begin + -- Nothing to do if Proj is not defined or if it has already been + -- processed. + + if Present (Proj) and then not Processed_Hash.Get (Proj) then + -- Make sure the project will not be processed again + + Processed_Hash.Set (Proj, True); + + Declaration := Project_Declaration_Of (Proj, In_Tree); + + if Present (Declaration) then + Extended := Extended_Project_Of (Declaration, In_Tree); + end if; + + -- If this is a project that may need a virtual extending project + -- and it is not itself an extending project, put it in the list. + + if Potentially_Virtual and then No (Extended) then + Virtual_Hash.Set (Proj, Proj); + end if; + + -- Now check the projects it imports + + With_Clause := First_With_Clause_Of (Proj, In_Tree); + + while Present (With_Clause) loop + Imported := Project_Node_Of (With_Clause, In_Tree); + + if Present (Imported) then + Look_For_Virtual_Projects_For + (Imported, In_Tree, Potentially_Virtual => True); + end if; + + With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); + end loop; + + -- Check also the eventual project extended by Proj. As this project + -- is already extended, call recursively with Potentially_Virtual + -- being False. + + Look_For_Virtual_Projects_For + (Extended, In_Tree, Potentially_Virtual => False); + end if; + end Look_For_Virtual_Projects_For; + + ----------- + -- Parse -- + ----------- + + procedure Parse + (In_Tree : Project_Node_Tree_Ref; + Project : out Project_Node_Id; + Project_File_Name : String; + Always_Errout_Finalize : Boolean; + Packages_To_Check : String_List_Access := All_Packages; + Store_Comments : Boolean := False; + Current_Directory : String := ""; + Is_Config_File : Boolean; + Flags : Processing_Flags) + is + Dummy : Boolean; + pragma Warnings (Off, Dummy); + + Real_Project_File_Name : String_Access := + Osint.To_Canonical_File_Spec + (Project_File_Name); + Path_Name_Id : Path_Name_Type; + + begin + if Real_Project_File_Name = null then + Real_Project_File_Name := new String'(Project_File_Name); + end if; + + Project := Empty_Node; + + Find_Project (In_Tree.Project_Path, + Project_File_Name => Real_Project_File_Name.all, + Directory => Current_Directory, + Path => Path_Name_Id); + Free (Real_Project_File_Name); + + Prj.Err.Initialize; + Prj.Err.Scanner.Set_Comment_As_Token (Store_Comments); + Prj.Err.Scanner.Set_End_Of_Line_As_Token (Store_Comments); + + if Path_Name_Id = No_Path then + declare + P : String_Access; + begin + Get_Path (In_Tree.Project_Path, Path => P); + Prj.Com.Fail + ("project file """ + & Project_File_Name + & """ not found in " + & P.all); + Project := Empty_Node; + return; + end; + end if; + + -- Parse the main project file + + begin + Parse_Single_Project + (In_Tree => In_Tree, + Project => Project, + Extends_All => Dummy, + Path_Name_Id => Path_Name_Id, + Extended => False, + From_Extended => None, + In_Limited => False, + Packages_To_Check => Packages_To_Check, + Depth => 0, + Current_Dir => Current_Directory, + Is_Config_File => Is_Config_File, + Flags => Flags); + + exception + when Types.Unrecoverable_Error => + + -- Unrecoverable_Error is raised when a line is too long. + -- A meaningful error message will be displayed later. + + Project := Empty_Node; + end; + + -- If Project is an extending-all project, create the eventual + -- virtual extending projects and check that there are no illegally + -- imported projects. + + if Present (Project) + and then Is_Extending_All (Project, In_Tree) + then + -- First look for projects that potentially need a virtual + -- extending project. + + Virtual_Hash.Reset; + Processed_Hash.Reset; + + -- Mark the extending all project as processed, to avoid checking + -- the imported projects in case of a "limited with" on this + -- extending all project. + + Processed_Hash.Set (Project, True); + + declare + Declaration : constant Project_Node_Id := + Project_Declaration_Of (Project, In_Tree); + begin + Look_For_Virtual_Projects_For + (Extended_Project_Of (Declaration, In_Tree), In_Tree, + Potentially_Virtual => False); + end; + + -- Now, check the projects directly imported by the main project. + -- Remove from the potentially virtual any project extended by one + -- of these imported projects. For non extending imported projects, + -- check that they do not belong to the project tree of the project + -- being "extended-all" by the main project. + + declare + With_Clause : Project_Node_Id; + Imported : Project_Node_Id := Empty_Node; + Declaration : Project_Node_Id := Empty_Node; + + begin + With_Clause := First_With_Clause_Of (Project, In_Tree); + while Present (With_Clause) loop + Imported := Project_Node_Of (With_Clause, In_Tree); + + if Present (Imported) then + Declaration := Project_Declaration_Of (Imported, In_Tree); + + if Extended_Project_Of (Declaration, In_Tree) /= + Empty_Node + then + loop + Imported := + Extended_Project_Of (Declaration, In_Tree); + exit when No (Imported); + Virtual_Hash.Remove (Imported); + Declaration := + Project_Declaration_Of (Imported, In_Tree); + end loop; + end if; + end if; + + With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); + end loop; + end; + + -- Now create all the virtual extending projects + + declare + Proj : Project_Node_Id := Virtual_Hash.Get_First; + begin + while Present (Proj) loop + Create_Virtual_Extending_Project (Proj, Project, In_Tree); + Proj := Virtual_Hash.Get_Next; + end loop; + end; + end if; + + -- If there were any kind of error during the parsing, serious + -- or not, then the parsing fails. + + if Err_Vars.Total_Errors_Detected > 0 then + Project := Empty_Node; + end if; + + if No (Project) or else Always_Errout_Finalize then + Prj.Err.Finalize; + + -- Reinitialize to avoid duplicate warnings later on + + Prj.Err.Initialize; + end if; + + exception + when X : others => + + -- Internal error + + Write_Line (Exception_Information (X)); + Write_Str ("Exception "); + Write_Str (Exception_Name (X)); + Write_Line (" raised, while processing project file"); + Project := Empty_Node; + end Parse; + + ------------------------------ + -- Pre_Parse_Context_Clause -- + ------------------------------ + + procedure Pre_Parse_Context_Clause + (In_Tree : Project_Node_Tree_Ref; + Context_Clause : out With_Id; + Is_Config_File : Boolean; + Flags : Processing_Flags) + is + Current_With_Clause : With_Id := No_With; + Limited_With : Boolean := False; + Current_With : With_Record; + Current_With_Node : Project_Node_Id := Empty_Node; + + begin + -- Assume no context clause + + Context_Clause := No_With; + With_Loop : + + -- If Token is not WITH or LIMITED, there is no context clause, or we + -- have exhausted the with clauses. + + while Token = Tok_With or else Token = Tok_Limited loop + Current_With_Node := + Default_Project_Node (Of_Kind => N_With_Clause, In_Tree => In_Tree); + Limited_With := Token = Tok_Limited; + + if Is_Config_File then + Error_Msg + (Flags, + "configuration project cannot import " & + "other configuration projects", + Token_Ptr); + end if; + + if Limited_With then + Scan (In_Tree); -- scan past LIMITED + Expect (Tok_With, "WITH"); + exit With_Loop when Token /= Tok_With; + end if; + + Comma_Loop : + loop + Scan (In_Tree); -- past WITH or "," + + Expect (Tok_String_Literal, "literal string"); + + if Token /= Tok_String_Literal then + return; + end if; + + -- Store path and location in table Withs + + Current_With := + (Path => Path_Name_Type (Token_Name), + Location => Token_Ptr, + Limited_With => Limited_With, + Node => Current_With_Node, + Next => No_With); + + Withs.Increment_Last; + Withs.Table (Withs.Last) := Current_With; + + if Current_With_Clause = No_With then + Context_Clause := Withs.Last; + + else + Withs.Table (Current_With_Clause).Next := Withs.Last; + end if; + + Current_With_Clause := Withs.Last; + + Scan (In_Tree); + + if Token = Tok_Semicolon then + Set_End_Of_Line (Current_With_Node); + Set_Previous_Line_Node (Current_With_Node); + + -- End of (possibly multiple) with clause; + + Scan (In_Tree); -- past the semicolon + exit Comma_Loop; + + elsif Token = Tok_Comma then + Set_Is_Not_Last_In_List (Current_With_Node, In_Tree); + + else + Error_Msg (Flags, "expected comma or semi colon", Token_Ptr); + exit Comma_Loop; + end if; + + Current_With_Node := + Default_Project_Node + (Of_Kind => N_With_Clause, In_Tree => In_Tree); + end loop Comma_Loop; + end loop With_Loop; + end Pre_Parse_Context_Clause; + + ------------------------------- + -- Post_Parse_Context_Clause -- + ------------------------------- + + procedure Post_Parse_Context_Clause + (Context_Clause : With_Id; + In_Tree : Project_Node_Tree_Ref; + Limited_Withs : Boolean; + Imported_Projects : in out Project_Node_Id; + Project_Directory : Path_Name_Type; + From_Extended : Extension_Origin; + In_Limited : Boolean; + Packages_To_Check : String_List_Access; + Depth : Natural; + Current_Dir : String; + Is_Config_File : Boolean; + Flags : Processing_Flags) + is + Current_With_Clause : With_Id := Context_Clause; + + Current_Project : Project_Node_Id := Imported_Projects; + Previous_Project : Project_Node_Id := Empty_Node; + Next_Project : Project_Node_Id := Empty_Node; + + Project_Directory_Path : constant String := + Get_Name_String (Project_Directory); + + Current_With : With_Record; + Extends_All : Boolean := False; + Imported_Path_Name_Id : Path_Name_Type; + + begin + -- Set Current_Project to the last project in the current list, if the + -- list is not empty. + + if Present (Current_Project) then + while + Present (Next_With_Clause_Of (Current_Project, In_Tree)) + loop + Current_Project := Next_With_Clause_Of (Current_Project, In_Tree); + end loop; + end if; + + while Current_With_Clause /= No_With loop + Current_With := Withs.Table (Current_With_Clause); + Current_With_Clause := Current_With.Next; + + if Limited_Withs = Current_With.Limited_With then + Find_Project + (In_Tree.Project_Path, + Project_File_Name => Get_Name_String (Current_With.Path), + Directory => Project_Directory_Path, + Path => Imported_Path_Name_Id); + + if Imported_Path_Name_Id = No_Path then + + -- The project file cannot be found + + Error_Msg_File_1 := File_Name_Type (Current_With.Path); + Error_Msg + (Flags, "unknown project file: {", Current_With.Location); + + -- If this is not imported by the main project file, display + -- the import path. + + if Project_Stack.Last > 1 then + for Index in reverse 1 .. Project_Stack.Last loop + Error_Msg_File_1 := + File_Name_Type + (Project_Stack.Table (Index).Path_Name); + Error_Msg + (Flags, "\imported by {", Current_With.Location); + end loop; + end if; + + else + -- New with clause + + declare + Resolved_Path : constant String := + Normalize_Pathname + (Get_Name_String (Imported_Path_Name_Id), + Directory => Current_Dir, + Resolve_Links => + Opt.Follow_Links_For_Files, + Case_Sensitive => True); + + Withed_Project : Project_Node_Id := Empty_Node; + + begin + Previous_Project := Current_Project; + + if No (Current_Project) then + + -- First with clause of the context clause + + Current_Project := Current_With.Node; + Imported_Projects := Current_Project; + + else + Next_Project := Current_With.Node; + Set_Next_With_Clause_Of + (Current_Project, In_Tree, Next_Project); + Current_Project := Next_Project; + end if; + + Set_String_Value_Of + (Current_Project, + In_Tree, + Name_Id (Current_With.Path)); + Set_Location_Of + (Current_Project, In_Tree, Current_With.Location); + + -- If it is a limited with, check if we have a circularity. + -- If we have one, get the project id of the limited + -- imported project file, and do not parse it. + + if Limited_Withs and then Project_Stack.Last > 1 then + declare + Canonical_Path_Name : Path_Name_Type; + + begin + Name_Len := Resolved_Path'Length; + Name_Buffer (1 .. Name_Len) := Resolved_Path; + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Canonical_Path_Name := Name_Find; + + for Index in 1 .. Project_Stack.Last loop + if Project_Stack.Table (Index).Canonical_Path_Name = + Canonical_Path_Name + then + -- We have found the limited imported project, + -- get its project id, and do not parse it. + + Withed_Project := Project_Stack.Table (Index).Id; + exit; + end if; + end loop; + end; + end if; + + -- Parse the imported project, if its project id is unknown + + if No (Withed_Project) then + Parse_Single_Project + (In_Tree => In_Tree, + Project => Withed_Project, + Extends_All => Extends_All, + Path_Name_Id => Imported_Path_Name_Id, + Extended => False, + From_Extended => From_Extended, + In_Limited => Limited_Withs, + Packages_To_Check => Packages_To_Check, + Depth => Depth, + Current_Dir => Current_Dir, + Is_Config_File => Is_Config_File, + Flags => Flags); + + else + Extends_All := Is_Extending_All (Withed_Project, In_Tree); + end if; + + if No (Withed_Project) then + + -- If parsing unsuccessful, remove the context clause + + Current_Project := Previous_Project; + + if No (Current_Project) then + Imported_Projects := Empty_Node; + + else + Set_Next_With_Clause_Of + (Current_Project, In_Tree, Empty_Node); + end if; + else + -- If parsing was successful, record project name and + -- path name in with clause + + Set_Project_Node_Of + (Node => Current_Project, + In_Tree => In_Tree, + To => Withed_Project, + Limited_With => Current_With.Limited_With); + Set_Name_Of + (Current_Project, + In_Tree, + Name_Of (Withed_Project, In_Tree)); + + Name_Len := Resolved_Path'Length; + Name_Buffer (1 .. Name_Len) := Resolved_Path; + Set_Path_Name_Of (Current_Project, In_Tree, Name_Find); + + if Extends_All then + Set_Is_Extending_All (Current_Project, In_Tree); + end if; + end if; + end; + end if; + end if; + end loop; + end Post_Parse_Context_Clause; + + --------------------------------- + -- Check_Extending_All_Imports -- + --------------------------------- + + procedure Check_Extending_All_Imports + (Flags : Processing_Flags; + In_Tree : Project_Node_Tree_Ref; + Project : Project_Node_Id) + is + With_Clause : Project_Node_Id; + Imported : Project_Node_Id; + + begin + if not Is_Extending_All (Project, In_Tree) then + With_Clause := First_With_Clause_Of (Project, In_Tree); + while Present (With_Clause) loop + Imported := Project_Node_Of (With_Clause, In_Tree); + + if Is_Extending_All (With_Clause, In_Tree) then + Error_Msg_Name_1 := Name_Of (Imported, In_Tree); + Error_Msg (Flags, "cannot import extending-all project %%", + Token_Ptr); + exit; + end if; + + With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); + end loop; + end if; + end Check_Extending_All_Imports; + + ----------------------------- + -- Check_Aggregate_Imports -- + ----------------------------- + + procedure Check_Aggregate_Imports + (Flags : Processing_Flags; + In_Tree : Project_Node_Tree_Ref; + Project : Project_Node_Id) + is + With_Clause, Imported : Project_Node_Id; + begin + if Project_Qualifier_Of (Project, In_Tree) = Aggregate then + With_Clause := First_With_Clause_Of (Project, In_Tree); + + while Present (With_Clause) loop + Imported := Project_Node_Of (With_Clause, In_Tree); + + if Project_Qualifier_Of (Imported, In_Tree) /= Dry then + Error_Msg_Name_1 := Name_Id (Path_Name_Of (Imported, In_Tree)); + Error_Msg (Flags, "can only import abstract projects, not %%", + Token_Ptr); + exit; + end if; + + With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); + end loop; + end if; + end Check_Aggregate_Imports; + + ---------------------------- + -- Read_Project_Qualifier -- + ---------------------------- + + procedure Read_Project_Qualifier + (Flags : Processing_Flags; + In_Tree : Project_Node_Tree_Ref; + Is_Config_File : Boolean; + Qualifier_Location : out Source_Ptr; + Project : Project_Node_Id) + is + Proj_Qualifier : Project_Qualifier := Unspecified; + begin + Qualifier_Location := Token_Ptr; + + if Token = Tok_Abstract then + Proj_Qualifier := Dry; + Scan (In_Tree); + + elsif Token = Tok_Identifier then + case Token_Name is + when Snames.Name_Standard => + Proj_Qualifier := Standard; + Scan (In_Tree); + + when Snames.Name_Aggregate => + Proj_Qualifier := Aggregate; + Scan (In_Tree); + + if Token = Tok_Identifier and then + Token_Name = Snames.Name_Library + then + Proj_Qualifier := Aggregate_Library; + Scan (In_Tree); + end if; + + when Snames.Name_Library => + Proj_Qualifier := Library; + Scan (In_Tree); + + when Snames.Name_Configuration => + if not Is_Config_File then + Error_Msg + (Flags, + "configuration projects cannot belong to a user" & + " project tree", + Token_Ptr); + end if; + + Proj_Qualifier := Configuration; + Scan (In_Tree); + + when others => + null; + end case; + end if; + + if Is_Config_File and then Proj_Qualifier = Unspecified then + + -- Set the qualifier to Configuration, even if the token doesn't + -- exist in the source file itself, so that we can differentiate + -- project files and configuration files later on. + + Proj_Qualifier := Configuration; + end if; + + if Proj_Qualifier /= Unspecified then + if Is_Config_File + and then Proj_Qualifier /= Configuration + then + Error_Msg (Flags, + "a configuration project cannot be qualified except " & + "as configuration project", + Qualifier_Location); + end if; + + Set_Project_Qualifier_Of (Project, In_Tree, Proj_Qualifier); + end if; + end Read_Project_Qualifier; + + ------------------------------- + -- Has_Circular_Dependencies -- + ------------------------------- + + function Has_Circular_Dependencies + (Flags : Processing_Flags; + Normed_Path_Name : Path_Name_Type; + Canonical_Path_Name : Path_Name_Type) return Boolean is + begin + for Index in reverse 1 .. Project_Stack.Last loop + exit when Project_Stack.Table (Index).Limited_With; + + if Canonical_Path_Name = + Project_Stack.Table (Index).Canonical_Path_Name + then + Error_Msg (Flags, "circular dependency detected", Token_Ptr); + Error_Msg_Name_1 := Name_Id (Normed_Path_Name); + Error_Msg (Flags, "\ %% is imported by", Token_Ptr); + + for Current in reverse 1 .. Project_Stack.Last loop + Error_Msg_Name_1 := + Name_Id (Project_Stack.Table (Current).Path_Name); + + if Project_Stack.Table (Current).Canonical_Path_Name /= + Canonical_Path_Name + then + Error_Msg + (Flags, "\ %% which itself is imported by", Token_Ptr); + + else + Error_Msg (Flags, "\ %%", Token_Ptr); + exit; + end if; + end loop; + + return True; + end if; + end loop; + return False; + end Has_Circular_Dependencies; + + -------------------------- + -- Parse_Single_Project -- + -------------------------- + + procedure Parse_Single_Project + (In_Tree : Project_Node_Tree_Ref; + Project : out Project_Node_Id; + Extends_All : out Boolean; + Path_Name_Id : Path_Name_Type; + Extended : Boolean; + From_Extended : Extension_Origin; + In_Limited : Boolean; + Packages_To_Check : String_List_Access; + Depth : Natural; + Current_Dir : String; + Is_Config_File : Boolean; + Flags : Processing_Flags) + is + Path_Name : constant String := Get_Name_String (Path_Name_Id); + + Normed_Path_Name : Path_Name_Type; + Canonical_Path_Name : Path_Name_Type; + Project_Directory : Path_Name_Type; + Project_Scan_State : Saved_Project_Scan_State; + Source_Index : Source_File_Index; + + Extending : Boolean := False; + + Extended_Project : Project_Node_Id := Empty_Node; + + A_Project_Name_And_Node : Tree_Private_Part.Project_Name_And_Node := + Tree_Private_Part.Projects_Htable.Get_First + (In_Tree.Projects_HT); + + Name_From_Path : constant Name_Id := + Project_Name_From (Path_Name, Is_Config_File => Is_Config_File); + Name_Of_Project : Name_Id := No_Name; + Display_Name_Of_Project : Name_Id := No_Name; + + Duplicated : Boolean := False; + + First_With : With_Id; + Imported_Projects : Project_Node_Id := Empty_Node; + + use Tree_Private_Part; + + Project_Comment_State : Tree.Comment_State; + + Qualifier_Location : Source_Ptr; + + begin + Extends_All := False; + + declare + Normed_Path : constant String := Normalize_Pathname + (Path_Name, + Directory => Current_Dir, + Resolve_Links => False, + Case_Sensitive => True); + Canonical_Path : constant String := Normalize_Pathname + (Normed_Path, + Directory => Current_Dir, + Resolve_Links => Opt.Follow_Links_For_Files, + Case_Sensitive => False); + begin + Name_Len := Normed_Path'Length; + Name_Buffer (1 .. Name_Len) := Normed_Path; + Normed_Path_Name := Name_Find; + Name_Len := Canonical_Path'Length; + Name_Buffer (1 .. Name_Len) := Canonical_Path; + Canonical_Path_Name := Name_Find; + end; + + if Has_Circular_Dependencies + (Flags, Normed_Path_Name, Canonical_Path_Name) + then + Project := Empty_Node; + return; + end if; + + -- Put the new path name on the stack + + Project_Stack.Append + ((Path_Name => Normed_Path_Name, + Canonical_Path_Name => Canonical_Path_Name, + Id => Empty_Node, + Limited_With => In_Limited)); + + -- Check if the project file has already been parsed + + while + A_Project_Name_And_Node /= Tree_Private_Part.No_Project_Name_And_Node + loop + if A_Project_Name_And_Node.Canonical_Path = Canonical_Path_Name then + if Extended then + + if A_Project_Name_And_Node.Extended then + if A_Project_Name_And_Node.Proj_Qualifier /= Dry then + Error_Msg + (Flags, + "cannot extend the same project file several times", + Token_Ptr); + end if; + else + Error_Msg + (Flags, + "cannot extend an already imported project file", + Token_Ptr); + end if; + + elsif A_Project_Name_And_Node.Extended then + Extends_All := + Is_Extending_All (A_Project_Name_And_Node.Node, In_Tree); + + -- If the imported project is an extended project A, and we are + -- in an extended project, replace A with the ultimate project + -- extending A. + + if From_Extended /= None then + declare + Decl : Project_Node_Id := + Project_Declaration_Of + (A_Project_Name_And_Node.Node, In_Tree); + + Prj : Project_Node_Id := + A_Project_Name_And_Node.Node; + + begin + -- Loop through extending projects to find the ultimate + -- extending project, that is the one that is not + -- extended. For an abstract project, as it can be + -- extended several times, there is no extending project + -- registered, so the loop does not execute and the + -- resulting project is the abstract project. + + while + Extending_Project_Of (Decl, In_Tree) /= Empty_Node + loop + Prj := Extending_Project_Of (Decl, In_Tree); + Decl := Project_Declaration_Of (Prj, In_Tree); + end loop; + + A_Project_Name_And_Node.Node := Prj; + end; + else + Error_Msg + (Flags, + "cannot import an already extended project file", + Token_Ptr); + end if; + end if; + + Project := A_Project_Name_And_Node.Node; + Project_Stack.Decrement_Last; + return; + end if; + + A_Project_Name_And_Node := + Tree_Private_Part.Projects_Htable.Get_Next (In_Tree.Projects_HT); + end loop; + + -- We never encountered this project file. Save the scan state, load the + -- project file and start to scan it. + + Save_Project_Scan_State (Project_Scan_State); + Source_Index := Load_Project_File (Path_Name); + Tree.Save (Project_Comment_State); + + -- If we cannot find it, we stop + + if Source_Index = No_Source_File then + Project := Empty_Node; + Project_Stack.Decrement_Last; + return; + end if; + + Prj.Err.Scanner.Initialize_Scanner (Source_Index); + Tree.Reset_State; + Scan (In_Tree); + + if not Is_Config_File and then Name_From_Path = No_Name then + + -- The project file name is not correct (no or bad extension, or not + -- following Ada identifier's syntax). + + Error_Msg_File_1 := File_Name_Type (Canonical_Path_Name); + Error_Msg (Flags, + "?{ is not a valid path name for a project file", + Token_Ptr); + end if; + + if Current_Verbosity >= Medium then + Write_Str ("Parsing """); + Write_Str (Path_Name); + Write_Char ('"'); + Write_Eol; + end if; + + Project_Directory := + Path_Name_Type (Get_Directory (File_Name_Type (Normed_Path_Name))); + + -- Is there any imported project? + + Pre_Parse_Context_Clause + (In_Tree => In_Tree, + Is_Config_File => Is_Config_File, + Context_Clause => First_With, + Flags => Flags); + + Project := Default_Project_Node + (Of_Kind => N_Project, In_Tree => In_Tree); + Project_Stack.Table (Project_Stack.Last).Id := Project; + Set_Directory_Of (Project, In_Tree, Project_Directory); + Set_Path_Name_Of (Project, In_Tree, Normed_Path_Name); + + Read_Project_Qualifier + (Flags, In_Tree, Is_Config_File, Qualifier_Location, Project); + + Set_Location_Of (Project, In_Tree, Token_Ptr); + + Expect (Tok_Project, "PROJECT"); + + -- Mark location of PROJECT token if present + + if Token = Tok_Project then + Scan (In_Tree); -- past PROJECT + Set_Location_Of (Project, In_Tree, Token_Ptr); + end if; + + -- Clear the Buffer + + Buffer_Last := 0; + loop + Expect (Tok_Identifier, "identifier"); + + -- If the token is not an identifier, clear the buffer before + -- exiting to indicate that the name of the project is ill-formed. + + if Token /= Tok_Identifier then + Buffer_Last := 0; + exit; + end if; + + -- Add the identifier name to the buffer + + Get_Name_String (Token_Name); + Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); + + -- Scan past the identifier + + Scan (In_Tree); + + -- If we have a dot, add a dot to the Buffer and look for the next + -- identifier. + + exit when Token /= Tok_Dot; + Add_To_Buffer (".", Buffer, Buffer_Last); + + -- Scan past the dot + + Scan (In_Tree); + end loop; + + -- See if this is an extending project + + if Token = Tok_Extends then + + if Is_Config_File then + Error_Msg + (Flags, + "extending configuration project not allowed", Token_Ptr); + end if; + + -- Make sure that gnatmake will use mapping files + + Opt.Create_Mapping_File := True; + + -- We are extending another project + + Extending := True; + + Scan (In_Tree); -- past EXTENDS + + if Token = Tok_All then + Extends_All := True; + Set_Is_Extending_All (Project, In_Tree); + Scan (In_Tree); -- scan past ALL + end if; + end if; + + -- If the name is well formed, Buffer_Last is > 0 + + if Buffer_Last > 0 then + + -- The Buffer contains the name of the project + + Name_Len := Buffer_Last; + Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last); + Name_Of_Project := Name_Find; + Set_Name_Of (Project, In_Tree, Name_Of_Project); + + -- To get expected name of the project file, replace dots by dashes + + for Index in 1 .. Name_Len loop + if Name_Buffer (Index) = '.' then + Name_Buffer (Index) := '-'; + end if; + end loop; + + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + + declare + Expected_Name : constant Name_Id := Name_Find; + Extension : String_Access; + + begin + -- Output a warning if the actual name is not the expected name + + if not Is_Config_File + and then (Name_From_Path /= No_Name) + and then Expected_Name /= Name_From_Path + then + Error_Msg_Name_1 := Expected_Name; + + if Is_Config_File then + Extension := new String'(Config_Project_File_Extension); + + else + Extension := new String'(Project_File_Extension); + end if; + + Error_Msg + (Flags, + "?file name does not match project name, should be `%%" + & Extension.all & "`", + Token_Ptr); + end if; + end; + + -- Read the original casing of the project name + + declare + Loc : Source_Ptr; + + begin + Loc := Location_Of (Project, In_Tree); + for J in 1 .. Name_Len loop + Name_Buffer (J) := Sinput.Source (Loc); + Loc := Loc + 1; + end loop; + + Display_Name_Of_Project := Name_Find; + end; + + declare + From_Ext : Extension_Origin := None; + + begin + -- Extending_All is always propagated + + if From_Extended = Extending_All or else Extends_All then + From_Ext := Extending_All; + + -- Otherwise, From_Extended is set to Extending_Single if the + -- current project is an extending project. + + elsif Extended then + From_Ext := Extending_Simple; + end if; + + Post_Parse_Context_Clause + (In_Tree => In_Tree, + Context_Clause => First_With, + Limited_Withs => False, + Imported_Projects => Imported_Projects, + Project_Directory => Project_Directory, + From_Extended => From_Ext, + In_Limited => In_Limited, + Packages_To_Check => Packages_To_Check, + Depth => Depth + 1, + Current_Dir => Current_Dir, + Is_Config_File => Is_Config_File, + Flags => Flags); + Set_First_With_Clause_Of (Project, In_Tree, Imported_Projects); + end; + + if not Is_Config_File then + declare + Name_And_Node : Tree_Private_Part.Project_Name_And_Node := + Tree_Private_Part.Projects_Htable.Get_First + (In_Tree.Projects_HT); + Project_Name : Name_Id := Name_And_Node.Name; + + begin + -- Check if we already have a project with this name + + while Project_Name /= No_Name + and then Project_Name /= Name_Of_Project + loop + Name_And_Node := + Tree_Private_Part.Projects_Htable.Get_Next + (In_Tree.Projects_HT); + Project_Name := Name_And_Node.Name; + end loop; + + -- Report an error if we already have a project with this name + + if Project_Name /= No_Name then + Duplicated := True; + Error_Msg_Name_1 := Project_Name; + Error_Msg + (Flags, "duplicate project name %%", + Location_Of (Project, In_Tree)); + Error_Msg_Name_1 := + Name_Id (Path_Name_Of (Name_And_Node.Node, In_Tree)); + Error_Msg + (Flags, "\already in %%", Location_Of (Project, In_Tree)); + end if; + end; + end if; + + end if; + + if Extending then + Expect (Tok_String_Literal, "literal string"); + + if Token = Tok_String_Literal then + Set_Extended_Project_Path_Of + (Project, + In_Tree, + Path_Name_Type (Token_Name)); + + declare + Original_Path_Name : constant String := + Get_Name_String (Token_Name); + Extended_Project_Path_Name_Id : Path_Name_Type; + begin + Find_Project + (In_Tree.Project_Path, + Project_File_Name => Original_Path_Name, + Directory => Get_Name_String (Project_Directory), + Path => Extended_Project_Path_Name_Id); + + if Extended_Project_Path_Name_Id = No_Path then + + -- We could not find the project file to extend + + Error_Msg_Name_1 := Token_Name; + + Error_Msg (Flags, "unknown project file: %%", Token_Ptr); + + -- If we are not in the main project file, display the + -- import path. + + if Project_Stack.Last > 1 then + Error_Msg_Name_1 := + Name_Id + (Project_Stack.Table (Project_Stack.Last).Path_Name); + Error_Msg (Flags, "\extended by %%", Token_Ptr); + + for Index in reverse 1 .. Project_Stack.Last - 1 loop + Error_Msg_Name_1 := + Name_Id + (Project_Stack.Table (Index).Path_Name); + Error_Msg (Flags, "\imported by %%", Token_Ptr); + end loop; + end if; + + else + declare + From_Ext : Extension_Origin := None; + + begin + if From_Extended = Extending_All or else Extends_All then + From_Ext := Extending_All; + end if; + + Parse_Single_Project + (In_Tree => In_Tree, + Project => Extended_Project, + Extends_All => Extends_All, + Path_Name_Id => Extended_Project_Path_Name_Id, + Extended => True, + From_Extended => From_Ext, + In_Limited => In_Limited, + Packages_To_Check => Packages_To_Check, + Depth => Depth + 1, + Current_Dir => Current_Dir, + Is_Config_File => Is_Config_File, + Flags => Flags); + end; + + if Present (Extended_Project) then + + -- A project that extends an extending-all project is + -- also an extending-all project. + + if Is_Extending_All (Extended_Project, In_Tree) then + Set_Is_Extending_All (Project, In_Tree); + end if; + + -- An abstract project can only extend an abstract + -- project, otherwise we may have an abstract project + -- with sources, if it inherits sources from the project + -- it extends. + + if Project_Qualifier_Of (Project, In_Tree) = Dry and then + Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry + then + Error_Msg + (Flags, "an abstract project can only extend " & + "another abstract project", + Qualifier_Location); + end if; + end if; + end if; + end; + + Scan (In_Tree); -- past the extended project path + end if; + end if; + + Check_Extending_All_Imports (Flags, In_Tree, Project); + Check_Aggregate_Imports (Flags, In_Tree, Project); + + -- Check that a project with a name including a dot either imports + -- or extends the project whose name precedes the last dot. + + if Name_Of_Project /= No_Name then + Get_Name_String (Name_Of_Project); + + else + Name_Len := 0; + end if; + + -- Look for the last dot + + while Name_Len > 0 and then Name_Buffer (Name_Len) /= '.' loop + Name_Len := Name_Len - 1; + end loop; + + -- If a dot was found, check if parent project is imported or extended + + if Name_Len > 0 then + Name_Len := Name_Len - 1; + + declare + Parent_Name : constant Name_Id := Name_Find; + Parent_Found : Boolean := False; + Parent_Node : Project_Node_Id := Empty_Node; + With_Clause : Project_Node_Id := + First_With_Clause_Of (Project, In_Tree); + Imp_Proj_Name : Name_Id; + + begin + -- If there is an extended project, check its name + + if Present (Extended_Project) then + Parent_Node := Extended_Project; + Parent_Found := + Name_Of (Extended_Project, In_Tree) = Parent_Name; + end if; + + -- If the parent project is not the extended project, + -- check each imported project until we find the parent project. + + Imported_Loop : + while not Parent_Found and then Present (With_Clause) loop + Parent_Node := Project_Node_Of (With_Clause, In_Tree); + Extension_Loop : while Present (Parent_Node) loop + Imp_Proj_Name := Name_Of (Parent_Node, In_Tree); + Parent_Found := Imp_Proj_Name = Parent_Name; + exit Imported_Loop when Parent_Found; + Parent_Node := + Extended_Project_Of + (Project_Declaration_Of (Parent_Node, In_Tree), + In_Tree); + end loop Extension_Loop; + + With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); + end loop Imported_Loop; + + if Parent_Found then + Set_Parent_Project_Of (Project, In_Tree, To => Parent_Node); + + else + -- If the parent project was not found, report an error + + Error_Msg_Name_1 := Name_Of_Project; + Error_Msg_Name_2 := Parent_Name; + Error_Msg (Flags, + "project %% does not import or extend project %%", + Location_Of (Project, In_Tree)); + end if; + end; + end if; + + Expect (Tok_Is, "IS"); + Set_End_Of_Line (Project); + Set_Previous_Line_Node (Project); + Set_Next_End_Node (Project); + + declare + Project_Declaration : Project_Node_Id := Empty_Node; + + begin + -- No need to Scan past "is", Prj.Dect.Parse will do it + + Prj.Dect.Parse + (In_Tree => In_Tree, + Declarations => Project_Declaration, + Current_Project => Project, + Extends => Extended_Project, + Packages_To_Check => Packages_To_Check, + Is_Config_File => Is_Config_File, + Flags => Flags); + Set_Project_Declaration_Of (Project, In_Tree, Project_Declaration); + + if Present (Extended_Project) + and then Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry + then + Set_Extending_Project_Of + (Project_Declaration_Of (Extended_Project, In_Tree), In_Tree, + To => Project); + end if; + end; + + Expect (Tok_End, "END"); + Remove_Next_End_Node; + + -- Skip "end" if present + + if Token = Tok_End then + Scan (In_Tree); + end if; + + -- Clear the Buffer + + Buffer_Last := 0; + + -- Store the name following "end" in the Buffer. The name may be made of + -- several simple names. + + loop + Expect (Tok_Identifier, "identifier"); + + -- If we don't have an identifier, clear the buffer before exiting to + -- avoid checking the name. + + if Token /= Tok_Identifier then + Buffer_Last := 0; + exit; + end if; + + -- Add the identifier to the Buffer + Get_Name_String (Token_Name); + Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); + + -- Scan past the identifier + + Scan (In_Tree); + exit when Token /= Tok_Dot; + Add_To_Buffer (".", Buffer, Buffer_Last); + Scan (In_Tree); + end loop; + + -- If we have a valid name, check if it is the name of the project + + if Name_Of_Project /= No_Name and then Buffer_Last > 0 then + if To_Lower (Buffer (1 .. Buffer_Last)) /= + Get_Name_String (Name_Of (Project, In_Tree)) + then + -- Invalid name: report an error + + Error_Msg (Flags, "expected """ & + Get_Name_String (Name_Of (Project, In_Tree)) & """", + Token_Ptr); + end if; + end if; + + Expect (Tok_Semicolon, "`;`"); + + -- Check that there is no more text following the end of the project + -- source. + + if Token = Tok_Semicolon then + Set_Previous_End_Node (Project); + Scan (In_Tree); + + if Token /= Tok_EOF then + Error_Msg + (Flags, "unexpected text following end of project", Token_Ptr); + end if; + end if; + + if not Duplicated and then Name_Of_Project /= No_Name then + + -- Add the name of the project to the hash table, so that we can + -- check that no other subsequent project will have the same name. + + Tree_Private_Part.Projects_Htable.Set + (T => In_Tree.Projects_HT, + K => Name_Of_Project, + E => (Name => Name_Of_Project, + Display_Name => Display_Name_Of_Project, + Node => Project, + Canonical_Path => Canonical_Path_Name, + Extended => Extended, + Proj_Qualifier => Project_Qualifier_Of (Project, In_Tree))); + end if; + + declare + From_Ext : Extension_Origin := None; + + begin + -- Extending_All is always propagated + + if From_Extended = Extending_All or else Extends_All then + From_Ext := Extending_All; + + -- Otherwise, From_Extended is set to Extending_Single if the + -- current project is an extending project. + + elsif Extended then + From_Ext := Extending_Simple; + end if; + + Post_Parse_Context_Clause + (In_Tree => In_Tree, + Context_Clause => First_With, + Limited_Withs => True, + Imported_Projects => Imported_Projects, + Project_Directory => Project_Directory, + From_Extended => From_Ext, + In_Limited => In_Limited, + Packages_To_Check => Packages_To_Check, + Depth => Depth + 1, + Current_Dir => Current_Dir, + Is_Config_File => Is_Config_File, + Flags => Flags); + Set_First_With_Clause_Of (Project, In_Tree, Imported_Projects); + end; + + -- Restore the scan state, in case we are not the main project + + Restore_Project_Scan_State (Project_Scan_State); + + -- And remove the project from the project stack + + Project_Stack.Decrement_Last; + + -- Indicate if there are unkept comments + + Tree.Set_Project_File_Includes_Unkept_Comments + (Node => Project, + In_Tree => In_Tree, + To => Tree.There_Are_Unkept_Comments); + + -- And restore the comment state that was saved + + Tree.Restore_And_Free (Project_Comment_State); + end Parse_Single_Project; + + ----------------------- + -- Project_Name_From -- + ----------------------- + + function Project_Name_From + (Path_Name : String; + Is_Config_File : Boolean) return Name_Id + is + Canonical : String (1 .. Path_Name'Length) := Path_Name; + First : Natural := Canonical'Last; + Last : Natural := First; + Index : Positive; + + begin + if Current_Verbosity = High then + Write_Str ("Project_Name_From ("""); + Write_Str (Canonical); + Write_Line (""")"); + end if; + + -- If the path name is empty, return No_Name to indicate failure + + if First = 0 then + return No_Name; + end if; + + Canonical_Case_File_Name (Canonical); + + -- Look for the last dot in the path name + + while First > 0 + and then + Canonical (First) /= '.' + loop + First := First - 1; + end loop; + + -- If we have a dot, check that it is followed by the correct extension + + if First > 0 and then Canonical (First) = '.' then + if (not Is_Config_File + and then Canonical (First .. Last) = Project_File_Extension + and then First /= 1) + or else + (Is_Config_File + and then + Canonical (First .. Last) = Config_Project_File_Extension + and then First /= 1) + then + -- Look for the last directory separator, if any + + First := First - 1; + Last := First; + while First > 0 + and then Canonical (First) /= '/' + and then Canonical (First) /= Dir_Sep + loop + First := First - 1; + end loop; + + else + -- Not the correct extension, return No_Name to indicate failure + + return No_Name; + end if; + + -- If no dot in the path name, return No_Name to indicate failure + + else + return No_Name; + end if; + + First := First + 1; + + -- If the extension is the file name, return No_Name to indicate failure + + if First > Last then + return No_Name; + end if; + + -- Put the name in lower case into Name_Buffer + + Name_Len := Last - First + 1; + Name_Buffer (1 .. Name_Len) := To_Lower (Canonical (First .. Last)); + + Index := 1; + + -- Check if it is a well formed project name. Return No_Name if it is + -- ill formed. + + loop + if not Is_Letter (Name_Buffer (Index)) then + return No_Name; + + else + loop + Index := Index + 1; + + exit when Index >= Name_Len; + + if Name_Buffer (Index) = '_' then + if Name_Buffer (Index + 1) = '_' then + return No_Name; + end if; + end if; + + exit when Name_Buffer (Index) = '-'; + + if Name_Buffer (Index) /= '_' + and then not Is_Alphanumeric (Name_Buffer (Index)) + then + return No_Name; + end if; + + end loop; + end if; + + if Index >= Name_Len then + if Is_Alphanumeric (Name_Buffer (Name_Len)) then + + -- All checks have succeeded. Return name in Name_Buffer + + return Name_Find; + + else + return No_Name; + end if; + + elsif Name_Buffer (Index) = '-' then + Index := Index + 1; + end if; + end loop; + end Project_Name_From; + +end Prj.Part; diff --git a/gcc/ada/prj-part.ads b/gcc/ada/prj-part.ads new file mode 100644 index 000000000..4e9acee9d --- /dev/null +++ b/gcc/ada/prj-part.ads @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . P A R T -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Implements the parsing of project files into a tree + +with Prj.Tree; use Prj.Tree; + +package Prj.Part is + + procedure Parse + (In_Tree : Project_Node_Tree_Ref; + Project : out Project_Node_Id; + Project_File_Name : String; + Always_Errout_Finalize : Boolean; + Packages_To_Check : String_List_Access := All_Packages; + Store_Comments : Boolean := False; + Current_Directory : String := ""; + Is_Config_File : Boolean; + Flags : Processing_Flags); + -- Parse project file and all its imported project files and create a tree. + -- Return the node for the project (or Empty_Node if parsing failed). If + -- Always_Errout_Finalize is True, Errout.Finalize is called in all cases, + -- Otherwise, Errout.Finalize is only called if there are errors (but not + -- if there are only warnings). Packages_To_Check indicates the packages + -- where any unknown attribute produces an error. For other packages, an + -- unknown attribute produces a warning. When Store_Comments is True, + -- comments are stored in the parse tree. + -- + -- Current_Directory is used for optimization purposes only, avoiding extra + -- system calls. + -- + -- Is_Config_File should be set to True if the project represents a config + -- file (.cgpr) since some specific checks apply. + +end Prj.Part; diff --git a/gcc/ada/prj-pp.adb b/gcc/ada/prj-pp.adb new file mode 100644 index 000000000..e03146ce4 --- /dev/null +++ b/gcc/ada/prj-pp.adb @@ -0,0 +1,959 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . P P -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; use Ada.Characters.Handling; + +with Output; use Output; +with Snames; + +package body Prj.PP is + + use Prj.Tree; + + Not_Tested : array (Project_Node_Kind) of Boolean := (others => True); + + procedure Indicate_Tested (Kind : Project_Node_Kind); + -- Set the corresponding component of array Not_Tested to False. + -- Only called by pragmas Debug. + + --------------------- + -- Indicate_Tested -- + --------------------- + + procedure Indicate_Tested (Kind : Project_Node_Kind) is + begin + Not_Tested (Kind) := False; + end Indicate_Tested; + + ------------------ + -- Pretty_Print -- + ------------------ + + procedure Pretty_Print + (Project : Prj.Tree.Project_Node_Id; + In_Tree : Prj.Tree.Project_Node_Tree_Ref; + Increment : Positive := 3; + Eliminate_Empty_Case_Constructions : Boolean := False; + Minimize_Empty_Lines : Boolean := False; + W_Char : Write_Char_Ap := null; + W_Eol : Write_Eol_Ap := null; + W_Str : Write_Str_Ap := null; + Backward_Compatibility : Boolean; + Id : Prj.Project_Id := Prj.No_Project; + Max_Line_Length : Max_Length_Of_Line := + Max_Length_Of_Line'Last) + is + procedure Print (Node : Project_Node_Id; Indent : Natural); + -- A recursive procedure that traverses a project file tree and outputs + -- its source. Current_Prj is the project that we are printing. This + -- is used when printing attributes, since in nested packages they + -- need to use a fully qualified name. + + procedure Output_Attribute_Name (Name : Name_Id; Indent : Natural); + -- Outputs an attribute name, taking into account the value of + -- Backward_Compatibility. + + procedure Output_Name + (Name : Name_Id; + Indent : Natural; + Capitalize : Boolean := True); + -- Outputs a name + + procedure Start_Line (Indent : Natural); + -- Outputs the indentation at the beginning of the line + + procedure Output_String (S : Name_Id; Indent : Natural); + procedure Output_String (S : Path_Name_Type; Indent : Natural); + -- Outputs a string using the default output procedures + + procedure Write_Empty_Line (Always : Boolean := False); + -- Outputs an empty line, only if the previous line was not empty + -- already and either Always is True or Minimize_Empty_Lines is + -- False. + + procedure Write_Line (S : String); + -- Outputs S followed by a new line + + procedure Write_String + (S : String; + Indent : Natural; + Truncated : Boolean := False); + -- Outputs S using Write_Str, starting a new line if line would + -- become too long, when Truncated = False. + -- When Truncated = True, only the part of the string that can fit on + -- the line is output. + + procedure Write_End_Of_Line_Comment (Node : Project_Node_Id); + + Write_Char : Write_Char_Ap := Output.Write_Char'Access; + Write_Eol : Write_Eol_Ap := Output.Write_Eol'Access; + Write_Str : Write_Str_Ap := Output.Write_Str'Access; + -- These three access to procedure values are used for the output + + Last_Line_Is_Empty : Boolean := False; + -- Used to avoid two consecutive empty lines + + Column : Natural := 0; + -- Column number of the last character in the line. Used to avoid + -- outputting lines longer than Max_Line_Length. + + First_With_In_List : Boolean := True; + -- Indicate that the next with clause is first in a list such as + -- with "A", "B"; + -- First_With_In_List will be True for "A", but not for "B". + + --------------------------- + -- Output_Attribute_Name -- + --------------------------- + + procedure Output_Attribute_Name (Name : Name_Id; Indent : Natural) is + begin + if Backward_Compatibility then + case Name is + when Snames.Name_Spec => + Output_Name (Snames.Name_Specification, Indent); + + when Snames.Name_Spec_Suffix => + Output_Name (Snames.Name_Specification_Suffix, Indent); + + when Snames.Name_Body => + Output_Name (Snames.Name_Implementation, Indent); + + when Snames.Name_Body_Suffix => + Output_Name (Snames.Name_Implementation_Suffix, Indent); + + when others => + Output_Name (Name, Indent); + end case; + + else + Output_Name (Name, Indent); + end if; + end Output_Attribute_Name; + + ----------------- + -- Output_Name -- + ----------------- + + procedure Output_Name + (Name : Name_Id; + Indent : Natural; + Capitalize : Boolean := True) + is + Capital : Boolean := Capitalize; + + begin + if Column = 0 and then Indent /= 0 then + Start_Line (Indent + Increment); + end if; + + Get_Name_String (Name); + + -- If line would become too long, create new line + + if Column + Name_Len > Max_Line_Length then + Write_Eol.all; + Column := 0; + + if Indent /= 0 then + Start_Line (Indent + Increment); + end if; + end if; + + for J in 1 .. Name_Len loop + if Capital then + Write_Char (To_Upper (Name_Buffer (J))); + else + Write_Char (Name_Buffer (J)); + end if; + + if Capitalize then + Capital := + Name_Buffer (J) = '_' + or else Is_Digit (Name_Buffer (J)); + end if; + end loop; + + Column := Column + Name_Len; + end Output_Name; + + ------------------- + -- Output_String -- + ------------------- + + procedure Output_String (S : Name_Id; Indent : Natural) is + begin + if Column = 0 and then Indent /= 0 then + Start_Line (Indent + Increment); + end if; + + Get_Name_String (S); + + -- If line could become too long, create new line. Note that the + -- number of characters on the line could be twice the number of + -- character in the string (if every character is a '"') plus two + -- (the initial and final '"'). + + if Column + Name_Len + Name_Len + 2 > Max_Line_Length then + Write_Eol.all; + Column := 0; + + if Indent /= 0 then + Start_Line (Indent + Increment); + end if; + end if; + + Write_Char ('"'); + Column := Column + 1; + Get_Name_String (S); + + for J in 1 .. Name_Len loop + if Name_Buffer (J) = '"' then + Write_Char ('"'); + Write_Char ('"'); + Column := Column + 2; + else + Write_Char (Name_Buffer (J)); + Column := Column + 1; + end if; + + -- If the string does not fit on one line, cut it in parts and + -- concatenate. + + if J < Name_Len and then Column >= Max_Line_Length then + Write_Str (""" &"); + Write_Eol.all; + Column := 0; + Start_Line (Indent + Increment); + Write_Char ('"'); + Column := Column + 1; + end if; + end loop; + + Write_Char ('"'); + Column := Column + 1; + end Output_String; + + procedure Output_String (S : Path_Name_Type; Indent : Natural) is + begin + Output_String (Name_Id (S), Indent); + end Output_String; + + ---------------- + -- Start_Line -- + ---------------- + + procedure Start_Line (Indent : Natural) is + begin + if not Minimize_Empty_Lines then + Write_Str ((1 .. Indent => ' ')); + Column := Column + Indent; + end if; + end Start_Line; + + ---------------------- + -- Write_Empty_Line -- + ---------------------- + + procedure Write_Empty_Line (Always : Boolean := False) is + begin + if (Always or else not Minimize_Empty_Lines) + and then not Last_Line_Is_Empty then + Write_Eol.all; + Column := 0; + Last_Line_Is_Empty := True; + end if; + end Write_Empty_Line; + + ------------------------------- + -- Write_End_Of_Line_Comment -- + ------------------------------- + + procedure Write_End_Of_Line_Comment (Node : Project_Node_Id) is + Value : constant Name_Id := End_Of_Line_Comment (Node, In_Tree); + + begin + if Value /= No_Name then + Write_String (" --", 0); + Write_String (Get_Name_String (Value), 0, Truncated => True); + end if; + + Write_Line (""); + end Write_End_Of_Line_Comment; + + ---------------- + -- Write_Line -- + ---------------- + + procedure Write_Line (S : String) is + begin + Write_String (S, 0); + Last_Line_Is_Empty := False; + Write_Eol.all; + Column := 0; + end Write_Line; + + ------------------ + -- Write_String -- + ------------------ + + procedure Write_String + (S : String; + Indent : Natural; + Truncated : Boolean := False) is + Length : Natural := S'Length; + begin + if Column = 0 and then Indent /= 0 then + Start_Line (Indent + Increment); + end if; + + -- If the string would not fit on the line, + -- start a new line. + + if Column + Length > Max_Line_Length then + if Truncated then + Length := Max_Line_Length - Column; + + else + Write_Eol.all; + Column := 0; + + if Indent /= 0 then + Start_Line (Indent + Increment); + end if; + end if; + end if; + + Write_Str (S (S'First .. S'First + Length - 1)); + Column := Column + Length; + end Write_String; + + ----------- + -- Print -- + ----------- + + procedure Print (Node : Project_Node_Id; Indent : Natural) is + begin + if Present (Node) then + + case Kind_Of (Node, In_Tree) is + + when N_Project => + pragma Debug (Indicate_Tested (N_Project)); + if Present (First_With_Clause_Of (Node, In_Tree)) then + + -- with clause(s) + + First_With_In_List := True; + Print (First_With_Clause_Of (Node, In_Tree), Indent); + Write_Empty_Line (Always => True); + end if; + + Print (First_Comment_Before (Node, In_Tree), Indent); + Start_Line (Indent); + Write_String ("project ", Indent); + + if Id /= Prj.No_Project then + Output_Name (Id.Display_Name, Indent); + else + Output_Name (Name_Of (Node, In_Tree), Indent); + end if; + + -- Check if this project extends another project + + if Extended_Project_Path_Of (Node, In_Tree) /= No_Path then + Write_String (" extends ", Indent); + + if Is_Extending_All (Node, In_Tree) then + Write_String ("all ", Indent); + end if; + + Output_String + (Extended_Project_Path_Of (Node, In_Tree), + Indent); + end if; + + Write_String (" is", Indent); + Write_End_Of_Line_Comment (Node); + Print + (First_Comment_After (Node, In_Tree), Indent + Increment); + Write_Empty_Line (Always => True); + + -- Output all of the declarations in the project + + Print (Project_Declaration_Of (Node, In_Tree), Indent); + Print + (First_Comment_Before_End (Node, In_Tree), + Indent + Increment); + Start_Line (Indent); + Write_String ("end ", Indent); + + if Id /= Prj.No_Project then + Output_Name (Id.Display_Name, Indent); + else + Output_Name (Name_Of (Node, In_Tree), Indent); + end if; + + Write_Line (";"); + Print (First_Comment_After_End (Node, In_Tree), Indent); + + when N_With_Clause => + pragma Debug (Indicate_Tested (N_With_Clause)); + + -- The with clause will sometimes contain an invalid name + -- when we are importing a virtual project from an + -- extending all project. Do not output anything in this + -- case + + if Name_Of (Node, In_Tree) /= No_Name + and then String_Value_Of (Node, In_Tree) /= No_Name + then + if First_With_In_List then + Print (First_Comment_Before (Node, In_Tree), Indent); + Start_Line (Indent); + + if Non_Limited_Project_Node_Of (Node, In_Tree) = + Empty_Node + then + Write_String ("limited ", Indent); + end if; + + Write_String ("with ", Indent); + end if; + + Output_String (String_Value_Of (Node, In_Tree), Indent); + + if Is_Not_Last_In_List (Node, In_Tree) then + Write_String (", ", Indent); + First_With_In_List := False; + + else + Write_String (";", Indent); + Write_End_Of_Line_Comment (Node); + Print (First_Comment_After (Node, In_Tree), Indent); + First_With_In_List := True; + end if; + end if; + + Print (Next_With_Clause_Of (Node, In_Tree), Indent); + + when N_Project_Declaration => + pragma Debug (Indicate_Tested (N_Project_Declaration)); + + if + Present (First_Declarative_Item_Of (Node, In_Tree)) + then + Print + (First_Declarative_Item_Of (Node, In_Tree), + Indent + Increment); + Write_Empty_Line (Always => True); + end if; + + when N_Declarative_Item => + pragma Debug (Indicate_Tested (N_Declarative_Item)); + Print (Current_Item_Node (Node, In_Tree), Indent); + Print (Next_Declarative_Item (Node, In_Tree), Indent); + + when N_Package_Declaration => + pragma Debug (Indicate_Tested (N_Package_Declaration)); + Write_Empty_Line (Always => True); + Print (First_Comment_Before (Node, In_Tree), Indent); + Start_Line (Indent); + Write_String ("package ", Indent); + Output_Name (Name_Of (Node, In_Tree), Indent); + + if Project_Of_Renamed_Package_Of (Node, In_Tree) /= + Empty_Node + then + Write_String (" renames ", Indent); + Output_Name + (Name_Of + (Project_Of_Renamed_Package_Of (Node, In_Tree), + In_Tree), + Indent); + Write_String (".", Indent); + Output_Name (Name_Of (Node, In_Tree), Indent); + Write_String (";", Indent); + Write_End_Of_Line_Comment (Node); + Print (First_Comment_After_End (Node, In_Tree), Indent); + + else + Write_String (" is", Indent); + Write_End_Of_Line_Comment (Node); + Print (First_Comment_After (Node, In_Tree), + Indent + Increment); + + if First_Declarative_Item_Of (Node, In_Tree) /= + Empty_Node + then + Print + (First_Declarative_Item_Of (Node, In_Tree), + Indent + Increment); + end if; + + Print (First_Comment_Before_End (Node, In_Tree), + Indent + Increment); + Start_Line (Indent); + Write_String ("end ", Indent); + Output_Name (Name_Of (Node, In_Tree), Indent); + Write_Line (";"); + Print (First_Comment_After_End (Node, In_Tree), Indent); + Write_Empty_Line; + end if; + + when N_String_Type_Declaration => + pragma Debug (Indicate_Tested (N_String_Type_Declaration)); + Print (First_Comment_Before (Node, In_Tree), Indent); + Start_Line (Indent); + Write_String ("type ", Indent); + Output_Name (Name_Of (Node, In_Tree), Indent); + Write_Line (" is"); + Start_Line (Indent + Increment); + Write_String ("(", Indent); + + declare + String_Node : Project_Node_Id := + First_Literal_String (Node, In_Tree); + + begin + while Present (String_Node) loop + Output_String + (String_Value_Of (String_Node, In_Tree), + Indent); + String_Node := + Next_Literal_String (String_Node, In_Tree); + + if Present (String_Node) then + Write_String (", ", Indent); + end if; + end loop; + end; + + Write_String (");", Indent); + Write_End_Of_Line_Comment (Node); + Print (First_Comment_After (Node, In_Tree), Indent); + + when N_Literal_String => + pragma Debug (Indicate_Tested (N_Literal_String)); + Output_String (String_Value_Of (Node, In_Tree), Indent); + + if Source_Index_Of (Node, In_Tree) /= 0 then + Write_String (" at", Indent); + Write_String + (Source_Index_Of (Node, In_Tree)'Img, + Indent); + end if; + + when N_Attribute_Declaration => + pragma Debug (Indicate_Tested (N_Attribute_Declaration)); + Print (First_Comment_Before (Node, In_Tree), Indent); + Start_Line (Indent); + Write_String ("for ", Indent); + Output_Attribute_Name (Name_Of (Node, In_Tree), Indent); + + if Associative_Array_Index_Of (Node, In_Tree) /= No_Name then + Write_String (" (", Indent); + Output_String + (Associative_Array_Index_Of (Node, In_Tree), + Indent); + + if Source_Index_Of (Node, In_Tree) /= 0 then + Write_String (" at", Indent); + Write_String + (Source_Index_Of (Node, In_Tree)'Img, + Indent); + end if; + + Write_String (")", Indent); + end if; + + Write_String (" use ", Indent); + + if Present (Expression_Of (Node, In_Tree)) then + Print (Expression_Of (Node, In_Tree), Indent); + + else + -- Full associative array declaration + + if + Present (Associative_Project_Of (Node, In_Tree)) + then + Output_Name + (Name_Of + (Associative_Project_Of (Node, In_Tree), + In_Tree), + Indent); + + if + Present (Associative_Package_Of (Node, In_Tree)) + then + Write_String (".", Indent); + Output_Name + (Name_Of + (Associative_Package_Of (Node, In_Tree), + In_Tree), + Indent); + end if; + + elsif + Present (Associative_Package_Of (Node, In_Tree)) + then + Output_Name + (Name_Of + (Associative_Package_Of (Node, In_Tree), + In_Tree), + Indent); + end if; + + Write_String ("'", Indent); + Output_Attribute_Name (Name_Of (Node, In_Tree), Indent); + end if; + + Write_String (";", Indent); + Write_End_Of_Line_Comment (Node); + Print (First_Comment_After (Node, In_Tree), Indent); + + when N_Typed_Variable_Declaration => + pragma Debug + (Indicate_Tested (N_Typed_Variable_Declaration)); + Print (First_Comment_Before (Node, In_Tree), Indent); + Start_Line (Indent); + Output_Name (Name_Of (Node, In_Tree), Indent); + Write_String (" : ", Indent); + Output_Name + (Name_Of (String_Type_Of (Node, In_Tree), In_Tree), + Indent); + Write_String (" := ", Indent); + Print (Expression_Of (Node, In_Tree), Indent); + Write_String (";", Indent); + Write_End_Of_Line_Comment (Node); + Print (First_Comment_After (Node, In_Tree), Indent); + + when N_Variable_Declaration => + pragma Debug (Indicate_Tested (N_Variable_Declaration)); + Print (First_Comment_Before (Node, In_Tree), Indent); + Start_Line (Indent); + Output_Name (Name_Of (Node, In_Tree), Indent); + Write_String (" := ", Indent); + Print (Expression_Of (Node, In_Tree), Indent); + Write_String (";", Indent); + Write_End_Of_Line_Comment (Node); + Print (First_Comment_After (Node, In_Tree), Indent); + + when N_Expression => + pragma Debug (Indicate_Tested (N_Expression)); + declare + Term : Project_Node_Id := First_Term (Node, In_Tree); + + begin + while Present (Term) loop + Print (Term, Indent); + Term := Next_Term (Term, In_Tree); + + if Present (Term) then + Write_String (" & ", Indent); + end if; + end loop; + end; + + when N_Term => + pragma Debug (Indicate_Tested (N_Term)); + Print (Current_Term (Node, In_Tree), Indent); + + when N_Literal_String_List => + pragma Debug (Indicate_Tested (N_Literal_String_List)); + Write_String ("(", Indent); + + declare + Expression : Project_Node_Id := + First_Expression_In_List (Node, In_Tree); + + begin + while Present (Expression) loop + Print (Expression, Indent); + Expression := + Next_Expression_In_List (Expression, In_Tree); + + if Present (Expression) then + Write_String (", ", Indent); + end if; + end loop; + end; + + Write_String (")", Indent); + + when N_Variable_Reference => + pragma Debug (Indicate_Tested (N_Variable_Reference)); + if Present (Project_Node_Of (Node, In_Tree)) then + Output_Name + (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree), + Indent); + Write_String (".", Indent); + end if; + + if Present (Package_Node_Of (Node, In_Tree)) then + Output_Name + (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree), + Indent); + Write_String (".", Indent); + end if; + + Output_Name (Name_Of (Node, In_Tree), Indent); + + when N_External_Value => + pragma Debug (Indicate_Tested (N_External_Value)); + Write_String ("external (", Indent); + Print (External_Reference_Of (Node, In_Tree), Indent); + + if Present (External_Default_Of (Node, In_Tree)) then + Write_String (", ", Indent); + Print (External_Default_Of (Node, In_Tree), Indent); + end if; + + Write_String (")", Indent); + + when N_Attribute_Reference => + pragma Debug (Indicate_Tested (N_Attribute_Reference)); + + if Present (Project_Node_Of (Node, In_Tree)) + and then Project_Node_Of (Node, In_Tree) /= Project + then + Output_Name + (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree), + Indent); + + if Present (Package_Node_Of (Node, In_Tree)) then + Write_String (".", Indent); + Output_Name + (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree), + Indent); + end if; + + elsif Present (Package_Node_Of (Node, In_Tree)) then + Output_Name + (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree), + Indent); + + else + Write_String ("project", Indent); + end if; + + Write_String ("'", Indent); + Output_Attribute_Name (Name_Of (Node, In_Tree), Indent); + + declare + Index : constant Name_Id := + Associative_Array_Index_Of (Node, In_Tree); + + begin + if Index /= No_Name then + Write_String (" (", Indent); + Output_String (Index, Indent); + Write_String (")", Indent); + end if; + end; + + when N_Case_Construction => + pragma Debug (Indicate_Tested (N_Case_Construction)); + + declare + Case_Item : Project_Node_Id; + Is_Non_Empty : Boolean := False; + + begin + Case_Item := First_Case_Item_Of (Node, In_Tree); + while Present (Case_Item) loop + if Present + (First_Declarative_Item_Of (Case_Item, In_Tree)) + or else not Eliminate_Empty_Case_Constructions + then + Is_Non_Empty := True; + exit; + end if; + + Case_Item := Next_Case_Item (Case_Item, In_Tree); + end loop; + + if Is_Non_Empty then + Write_Empty_Line; + Print (First_Comment_Before (Node, In_Tree), Indent); + Start_Line (Indent); + Write_String ("case ", Indent); + Print + (Case_Variable_Reference_Of (Node, In_Tree), + Indent); + Write_String (" is", Indent); + Write_End_Of_Line_Comment (Node); + Print + (First_Comment_After (Node, In_Tree), + Indent + Increment); + + declare + Case_Item : Project_Node_Id := + First_Case_Item_Of (Node, In_Tree); + begin + while Present (Case_Item) loop + pragma Assert + (Kind_Of (Case_Item, In_Tree) = N_Case_Item); + Print (Case_Item, Indent + Increment); + Case_Item := + Next_Case_Item (Case_Item, In_Tree); + end loop; + end; + + Print (First_Comment_Before_End (Node, In_Tree), + Indent + Increment); + Start_Line (Indent); + Write_Line ("end case;"); + Print + (First_Comment_After_End (Node, In_Tree), Indent); + end if; + end; + + when N_Case_Item => + pragma Debug (Indicate_Tested (N_Case_Item)); + + if Present (First_Declarative_Item_Of (Node, In_Tree)) + or else not Eliminate_Empty_Case_Constructions + then + Write_Empty_Line; + Print (First_Comment_Before (Node, In_Tree), Indent); + Start_Line (Indent); + Write_String ("when ", Indent); + + if No (First_Choice_Of (Node, In_Tree)) then + Write_String ("others", Indent); + + else + declare + Label : Project_Node_Id := + First_Choice_Of (Node, In_Tree); + begin + while Present (Label) loop + Print (Label, Indent); + Label := Next_Literal_String (Label, In_Tree); + + if Present (Label) then + Write_String (" | ", Indent); + end if; + end loop; + end; + end if; + + Write_String (" =>", Indent); + Write_End_Of_Line_Comment (Node); + Print + (First_Comment_After (Node, In_Tree), + Indent + Increment); + + declare + First : constant Project_Node_Id := + First_Declarative_Item_Of (Node, In_Tree); + begin + if No (First) then + Write_Empty_Line; + else + Print (First, Indent + Increment); + end if; + end; + end if; + + when N_Comment_Zones => + + -- Nothing to do, because it will not be processed directly + + null; + + when N_Comment => + pragma Debug (Indicate_Tested (N_Comment)); + + if Follows_Empty_Line (Node, In_Tree) then + Write_Empty_Line; + end if; + + Start_Line (Indent); + Write_String ("--", Indent); + Write_String + (Get_Name_String (String_Value_Of (Node, In_Tree)), + Indent, + Truncated => True); + Write_Line (""); + + if Is_Followed_By_Empty_Line (Node, In_Tree) then + Write_Empty_Line; + end if; + + Print (Next_Comment (Node, In_Tree), Indent); + end case; + end if; + end Print; + + -- Start of processing for Pretty_Print + + begin + if W_Char = null then + Write_Char := Output.Write_Char'Access; + else + Write_Char := W_Char; + end if; + + if W_Eol = null then + Write_Eol := Output.Write_Eol'Access; + else + Write_Eol := W_Eol; + end if; + + if W_Str = null then + Write_Str := Output.Write_Str'Access; + else + Write_Str := W_Str; + end if; + + Print (Project, 0); + + if W_Char = null or else W_Str = null then + Output.Write_Eol; + end if; + end Pretty_Print; + + ----------------------- + -- Output_Statistics -- + ----------------------- + + procedure Output_Statistics is + begin + Output.Write_Line ("Project_Node_Kinds not tested:"); + + for Kind in Project_Node_Kind loop + if Kind /= N_Comment_Zones and then Not_Tested (Kind) then + Output.Write_Str (" "); + Output.Write_Line (Project_Node_Kind'Image (Kind)); + end if; + end loop; + + Output.Write_Eol; + end Output_Statistics; + +end Prj.PP; diff --git a/gcc/ada/prj-pp.ads b/gcc/ada/prj-pp.ads new file mode 100644 index 000000000..f47e0582b --- /dev/null +++ b/gcc/ada/prj-pp.ads @@ -0,0 +1,94 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . P P -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 Project File Pretty Printer + +-- Used to output a project file from a project file tree. +-- Used by gnatname to update or create project files. +-- Also used GPS to display project file trees. +-- Also be used for debugging tools that create project file trees. + +with Prj.Tree; + +package Prj.PP is + + -- The following access to procedure types are used to redirect output when + -- calling Pretty_Print. + + type Write_Char_Ap is access procedure (C : Character); + + type Write_Eol_Ap is access procedure; + + type Write_Str_Ap is access procedure (S : String); + + subtype Max_Length_Of_Line is Positive range 50 .. 255; + + procedure Pretty_Print + (Project : Prj.Tree.Project_Node_Id; + In_Tree : Prj.Tree.Project_Node_Tree_Ref; + Increment : Positive := 3; + Eliminate_Empty_Case_Constructions : Boolean := False; + Minimize_Empty_Lines : Boolean := False; + W_Char : Write_Char_Ap := null; + W_Eol : Write_Eol_Ap := null; + W_Str : Write_Str_Ap := null; + Backward_Compatibility : Boolean; + Id : Prj.Project_Id := Prj.No_Project; + Max_Line_Length : Max_Length_Of_Line := + Max_Length_Of_Line'Last); + -- Output a project file, using either the default output routines, or the + -- ones specified by W_Char, W_Eol and W_Str. + -- + -- Increment is the number of spaces for each indentation level + -- + -- W_Char, W_Eol and W_Str can be used to change the default output + -- procedures. The default values force the output to Standard_Output. + -- + -- If Eliminate_Empty_Case_Constructions is True, then case constructions + -- and case items that do not include any declarations will not be output. + -- + -- If Minimize_Empty_Lines is True, empty lines will be output only after + -- the last with clause, after the line declaring the project name, after + -- the last declarative item of the project and before each package + -- declaration. Otherwise, more empty lines are output. + -- + -- If Backward_Compatibility is True, then new attributes (Spec, + -- Spec_Suffix, Body, Body_Suffix) will be replaced by obsolete ones + -- (Specification, Specification_Suffix, Implementation, + -- Implementation_Suffix). + -- + -- Id is used to compute the display name of the project including its + -- proper casing. + -- + -- Max_Line_Length is the maximum line length in the project file + +private + + procedure Output_Statistics; + -- This procedure can be used after one or more calls to Pretty_Print to + -- display what Project_Node_Kinds have not been exercised by the call(s) + -- to Pretty_Print. It is used only for testing purposes. + +end Prj.PP; diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb new file mode 100644 index 000000000..0553d33ff --- /dev/null +++ b/gcc/ada/prj-proc.adb @@ -0,0 +1,2862 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . P R O C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Err_Vars; use Err_Vars; +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; +with Prj.Attr; use Prj.Attr; +with Prj.Err; use Prj.Err; +with Prj.Ext; use Prj.Ext; +with Prj.Nmsc; use Prj.Nmsc; +with Snames; + +with Ada.Strings.Fixed; use Ada.Strings.Fixed; + +with GNAT.Case_Util; use GNAT.Case_Util; +with GNAT.HTable; + +package body Prj.Proc is + + package Processed_Projects is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Project_Id, + No_Element => No_Project, + Key => Name_Id, + Hash => Hash, + Equal => "="); + -- This hash table contains all processed projects + + package Unit_Htable is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Source_Id, + No_Element => No_Source, + Key => Name_Id, + Hash => Hash, + Equal => "="); + -- This hash table contains all processed projects + + procedure Add (To_Exp : in out Name_Id; Str : Name_Id); + -- Concatenate two strings and returns another string if both + -- arguments are not null string. + + -- In the following procedures, we are expected to guess the meaning of + -- the parameters from their names, this is never a good idea, comments + -- should be added precisely defining every formal ??? + + procedure Add_Attributes + (Project : Project_Id; + Project_Name : Name_Id; + Project_Dir : Name_Id; + In_Tree : Project_Tree_Ref; + Decl : in out Declarations; + First : Attribute_Node_Id; + Project_Level : Boolean); + -- Add all attributes, starting with First, with their default values to + -- the package or project with declarations Decl. + + procedure Check + (In_Tree : Project_Tree_Ref; + Project : Project_Id; + Node_Tree : Prj.Tree.Project_Node_Tree_Ref; + Flags : Processing_Flags); + -- Set all projects to not checked, then call Recursive_Check for the + -- main project Project. Project is set to No_Project if errors occurred. + -- Current_Dir is for optimization purposes, avoiding extra system calls. + -- If Allow_Duplicate_Basenames, then files with the same base names are + -- authorized within a project for source-based languages (never for unit + -- based languages) + + procedure Copy_Package_Declarations + (From : Declarations; + To : in out Declarations; + New_Loc : Source_Ptr; + Restricted : Boolean; + In_Tree : Project_Tree_Ref); + -- Copy a package declaration From to To for a renamed package. Change the + -- locations of all the attributes to New_Loc. When Restricted is + -- True, do not copy attributes Body, Spec, Implementation, Specification + -- and Linker_Options. + + function Expression + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Flags : Processing_Flags; + From_Project_Node : Project_Node_Id; + From_Project_Node_Tree : Project_Node_Tree_Ref; + Pkg : Package_Id; + First_Term : Project_Node_Id; + Kind : Variable_Kind) return Variable_Value; + -- From N_Expression project node From_Project_Node, compute the value + -- of an expression and return it as a Variable_Value. + + function Imported_Or_Extended_Project_From + (Project : Project_Id; + With_Name : Name_Id) return Project_Id; + -- Find an imported or extended project of Project whose name is With_Name + + function Package_From + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + With_Name : Name_Id) return Package_Id; + -- Find the package of Project whose name is With_Name + + procedure Process_Declarative_Items + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Flags : Processing_Flags; + From_Project_Node : Project_Node_Id; + From_Project_Node_Tree : Project_Node_Tree_Ref; + Pkg : Package_Id; + Item : Project_Node_Id); + -- Process declarative items starting with From_Project_Node, and put them + -- in declarations Decl. This is a recursive procedure; it calls itself for + -- a package declaration or a case construction. + + procedure Recursive_Process + (In_Tree : Project_Tree_Ref; + Project : out Project_Id; + Flags : Processing_Flags; + From_Project_Node : Project_Node_Id; + From_Project_Node_Tree : Project_Node_Tree_Ref; + Extended_By : Project_Id); + -- Process project with node From_Project_Node in the tree. Do nothing if + -- From_Project_Node is Empty_Node. If project has already been processed, + -- simply return its project id. Otherwise create a new project id, mark it + -- as processed, call itself recursively for all imported projects and a + -- extended project, if any. Then process the declarative items of the + -- project. + + function Get_Attribute_Index + (Tree : Project_Node_Tree_Ref; + Attr : Project_Node_Id; + Index : Name_Id) return Name_Id; + -- Copy the index of the attribute into Name_Buffer, converting to lower + -- case if the attribute is case-insensitive. + + --------- + -- Add -- + --------- + + procedure Add (To_Exp : in out Name_Id; Str : Name_Id) is + begin + if To_Exp = No_Name or else To_Exp = Empty_String then + + -- To_Exp is nil or empty. The result is Str + + To_Exp := Str; + + -- If Str is nil, then do not change To_Ext + + elsif Str /= No_Name and then Str /= Empty_String then + declare + S : constant String := Get_Name_String (Str); + begin + Get_Name_String (To_Exp); + Add_Str_To_Name_Buffer (S); + To_Exp := Name_Find; + end; + end if; + end Add; + + -------------------- + -- Add_Attributes -- + -------------------- + + procedure Add_Attributes + (Project : Project_Id; + Project_Name : Name_Id; + Project_Dir : Name_Id; + In_Tree : Project_Tree_Ref; + Decl : in out Declarations; + First : Attribute_Node_Id; + Project_Level : Boolean) + is + The_Attribute : Attribute_Node_Id := First; + + begin + while The_Attribute /= Empty_Attribute loop + if Attribute_Kind_Of (The_Attribute) = Single then + declare + New_Attribute : Variable_Value; + + begin + case Variable_Kind_Of (The_Attribute) is + + -- Undefined should not happen + + when Undefined => + pragma Assert + (False, "attribute with an undefined kind"); + raise Program_Error; + + -- Single attributes have a default value of empty string + + when Single => + New_Attribute := + (Project => Project, + Kind => Single, + Location => No_Location, + Default => True, + Value => Empty_String, + Index => 0); + + -- Special cases of 'Name and + -- 'Project_Dir. + + if Project_Level then + if Attribute_Name_Of (The_Attribute) = + Snames.Name_Name + then + New_Attribute.Value := Project_Name; + + elsif Attribute_Name_Of (The_Attribute) = + Snames.Name_Project_Dir + then + New_Attribute.Value := Project_Dir; + end if; + end if; + + -- List attributes have a default value of nil list + + when List => + New_Attribute := + (Project => Project, + Kind => List, + Location => No_Location, + Default => True, + Values => Nil_String); + + end case; + + Variable_Element_Table.Increment_Last + (In_Tree.Variable_Elements); + In_Tree.Variable_Elements.Table + (Variable_Element_Table.Last + (In_Tree.Variable_Elements)) := + (Next => Decl.Attributes, + Name => Attribute_Name_Of (The_Attribute), + Value => New_Attribute); + Decl.Attributes := Variable_Element_Table.Last + (In_Tree.Variable_Elements); + end; + end if; + + The_Attribute := Next_Attribute (After => The_Attribute); + end loop; + end Add_Attributes; + + ----------- + -- Check -- + ----------- + + procedure Check + (In_Tree : Project_Tree_Ref; + Project : Project_Id; + Node_Tree : Prj.Tree.Project_Node_Tree_Ref; + Flags : Processing_Flags) + is + begin + Process_Naming_Scheme (In_Tree, Project, Node_Tree, Flags); + + -- Set the Other_Part field for the units + + declare + Source1 : Source_Id; + Name : Name_Id; + Source2 : Source_Id; + Iter : Source_Iterator; + + begin + Unit_Htable.Reset; + + Iter := For_Each_Source (In_Tree); + loop + Source1 := Prj.Element (Iter); + exit when Source1 = No_Source; + + if Source1.Unit /= No_Unit_Index then + Name := Source1.Unit.Name; + Source2 := Unit_Htable.Get (Name); + + if Source2 = No_Source then + Unit_Htable.Set (K => Name, E => Source1); + else + Unit_Htable.Remove (Name); + end if; + end if; + + Next (Iter); + end loop; + end; + end Check; + + ------------------------------- + -- Copy_Package_Declarations -- + ------------------------------- + + procedure Copy_Package_Declarations + (From : Declarations; + To : in out Declarations; + New_Loc : Source_Ptr; + Restricted : Boolean; + In_Tree : Project_Tree_Ref) + is + V1 : Variable_Id; + V2 : Variable_Id := No_Variable; + Var : Variable; + A1 : Array_Id; + A2 : Array_Id := No_Array; + Arr : Array_Data; + E1 : Array_Element_Id; + E2 : Array_Element_Id := No_Array_Element; + Elm : Array_Element; + + begin + -- To avoid references in error messages to attribute declarations in + -- an original package that has been renamed, copy all the attribute + -- declarations of the package and change all locations to New_Loc, + -- the location of the renamed package. + + -- First single attributes + + V1 := From.Attributes; + while V1 /= No_Variable loop + + -- Copy the attribute + + Var := In_Tree.Variable_Elements.Table (V1); + V1 := Var.Next; + + -- Do not copy the value of attribute Linker_Options if Restricted + + if Restricted and then Var.Name = Snames.Name_Linker_Options then + Var.Value.Values := Nil_String; + end if; + + -- Remove the Next component + + Var.Next := No_Variable; + + -- Change the location to New_Loc + + Var.Value.Location := New_Loc; + Variable_Element_Table.Increment_Last (In_Tree.Variable_Elements); + + -- Put in new declaration + + if To.Attributes = No_Variable then + To.Attributes := + Variable_Element_Table.Last (In_Tree.Variable_Elements); + else + In_Tree.Variable_Elements.Table (V2).Next := + Variable_Element_Table.Last (In_Tree.Variable_Elements); + end if; + + V2 := Variable_Element_Table.Last (In_Tree.Variable_Elements); + In_Tree.Variable_Elements.Table (V2) := Var; + end loop; + + -- Then the associated array attributes + + A1 := From.Arrays; + while A1 /= No_Array loop + Arr := In_Tree.Arrays.Table (A1); + A1 := Arr.Next; + + if not Restricted + or else + (Arr.Name /= Snames.Name_Body and then + Arr.Name /= Snames.Name_Spec and then + Arr.Name /= Snames.Name_Implementation and then + Arr.Name /= Snames.Name_Specification) + then + -- Remove the Next component + + Arr.Next := No_Array; + Array_Table.Increment_Last (In_Tree.Arrays); + + -- Create new Array declaration + + if To.Arrays = No_Array then + To.Arrays := Array_Table.Last (In_Tree.Arrays); + else + In_Tree.Arrays.Table (A2).Next := + Array_Table.Last (In_Tree.Arrays); + end if; + + A2 := Array_Table.Last (In_Tree.Arrays); + + -- Don't store the array as its first element has not been set yet + + -- Copy the array elements of the array + + E1 := Arr.Value; + Arr.Value := No_Array_Element; + while E1 /= No_Array_Element loop + + -- Copy the array element + + Elm := In_Tree.Array_Elements.Table (E1); + E1 := Elm.Next; + + -- Remove the Next component + + Elm.Next := No_Array_Element; + + -- Change the location + + Elm.Value.Location := New_Loc; + Array_Element_Table.Increment_Last (In_Tree.Array_Elements); + + -- Create new array element + + if Arr.Value = No_Array_Element then + Arr.Value := + Array_Element_Table.Last (In_Tree.Array_Elements); + else + In_Tree.Array_Elements.Table (E2).Next := + Array_Element_Table.Last (In_Tree.Array_Elements); + end if; + + E2 := Array_Element_Table.Last (In_Tree.Array_Elements); + In_Tree.Array_Elements.Table (E2) := Elm; + end loop; + + -- Finally, store the new array + + In_Tree.Arrays.Table (A2) := Arr; + end if; + end loop; + end Copy_Package_Declarations; + + ------------------------- + -- Get_Attribute_Index -- + ------------------------- + + function Get_Attribute_Index + (Tree : Project_Node_Tree_Ref; + Attr : Project_Node_Id; + Index : Name_Id) return Name_Id + is + Lower : Boolean; + + begin + if Index = All_Other_Names then + return Index; + end if; + + Get_Name_String (Index); + Lower := Case_Insensitive (Attr, Tree); + + -- The index is always case insensitive if it does not include any dot. + -- ??? Why not use the properties from prj-attr, simply, maybe because + -- we don't know whether we have a file as an index? + + if not Lower then + Lower := True; + + for J in 1 .. Name_Len loop + if Name_Buffer (J) = '.' then + Lower := False; + exit; + end if; + end loop; + end if; + + if Lower then + To_Lower (Name_Buffer (1 .. Name_Len)); + return Name_Find; + else + return Index; + end if; + end Get_Attribute_Index; + + ---------------- + -- Expression -- + ---------------- + + function Expression + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Flags : Processing_Flags; + From_Project_Node : Project_Node_Id; + From_Project_Node_Tree : Project_Node_Tree_Ref; + Pkg : Package_Id; + First_Term : Project_Node_Id; + Kind : Variable_Kind) return Variable_Value + is + The_Term : Project_Node_Id; + -- The term in the expression list + + The_Current_Term : Project_Node_Id := Empty_Node; + -- The current term node id + + Result : Variable_Value (Kind => Kind); + -- The returned result + + Last : String_List_Id := Nil_String; + -- Reference to the last string elements in Result, when Kind is List + + begin + Result.Project := Project; + Result.Location := Location_Of (First_Term, From_Project_Node_Tree); + + -- Process each term of the expression, starting with First_Term + + The_Term := First_Term; + while Present (The_Term) loop + The_Current_Term := Current_Term (The_Term, From_Project_Node_Tree); + + case Kind_Of (The_Current_Term, From_Project_Node_Tree) is + + when N_Literal_String => + + case Kind is + + when Undefined => + + -- Should never happen + + pragma Assert (False, "Undefined expression kind"); + raise Program_Error; + + when Single => + Add (Result.Value, + String_Value_Of + (The_Current_Term, From_Project_Node_Tree)); + Result.Index := + Source_Index_Of + (The_Current_Term, From_Project_Node_Tree); + + when List => + + String_Element_Table.Increment_Last + (In_Tree.String_Elements); + + if Last = Nil_String then + + -- This can happen in an expression like () & "toto" + + Result.Values := String_Element_Table.Last + (In_Tree.String_Elements); + + else + In_Tree.String_Elements.Table + (Last).Next := String_Element_Table.Last + (In_Tree.String_Elements); + end if; + + Last := String_Element_Table.Last + (In_Tree.String_Elements); + + In_Tree.String_Elements.Table (Last) := + (Value => String_Value_Of + (The_Current_Term, + From_Project_Node_Tree), + Index => Source_Index_Of + (The_Current_Term, + From_Project_Node_Tree), + Display_Value => No_Name, + Location => Location_Of + (The_Current_Term, + From_Project_Node_Tree), + Flag => False, + Next => Nil_String); + end case; + + when N_Literal_String_List => + + declare + String_Node : Project_Node_Id := + First_Expression_In_List + (The_Current_Term, + From_Project_Node_Tree); + + Value : Variable_Value; + + begin + if Present (String_Node) then + + -- If String_Node is nil, it is an empty list, there is + -- nothing to do + + Value := Expression + (Project => Project, + In_Tree => In_Tree, + Flags => Flags, + From_Project_Node => From_Project_Node, + From_Project_Node_Tree => From_Project_Node_Tree, + Pkg => Pkg, + First_Term => + Tree.First_Term + (String_Node, From_Project_Node_Tree), + Kind => Single); + String_Element_Table.Increment_Last + (In_Tree.String_Elements); + + if Result.Values = Nil_String then + + -- This literal string list is the first term in a + -- string list expression + + Result.Values := + String_Element_Table.Last (In_Tree.String_Elements); + + else + In_Tree.String_Elements.Table + (Last).Next := + String_Element_Table.Last (In_Tree.String_Elements); + end if; + + Last := + String_Element_Table.Last (In_Tree.String_Elements); + + In_Tree.String_Elements.Table (Last) := + (Value => Value.Value, + Display_Value => No_Name, + Location => Value.Location, + Flag => False, + Next => Nil_String, + Index => Value.Index); + + loop + -- Add the other element of the literal string list + -- one after the other + + String_Node := + Next_Expression_In_List + (String_Node, From_Project_Node_Tree); + + exit when No (String_Node); + + Value := + Expression + (Project => Project, + In_Tree => In_Tree, + Flags => Flags, + From_Project_Node => From_Project_Node, + From_Project_Node_Tree => From_Project_Node_Tree, + Pkg => Pkg, + First_Term => + Tree.First_Term + (String_Node, From_Project_Node_Tree), + Kind => Single); + + String_Element_Table.Increment_Last + (In_Tree.String_Elements); + In_Tree.String_Elements.Table + (Last).Next := String_Element_Table.Last + (In_Tree.String_Elements); + Last := String_Element_Table.Last + (In_Tree.String_Elements); + In_Tree.String_Elements.Table (Last) := + (Value => Value.Value, + Display_Value => No_Name, + Location => Value.Location, + Flag => False, + Next => Nil_String, + Index => Value.Index); + end loop; + end if; + end; + + when N_Variable_Reference | N_Attribute_Reference => + + declare + The_Project : Project_Id := Project; + The_Package : Package_Id := Pkg; + The_Name : Name_Id := No_Name; + The_Variable_Id : Variable_Id := No_Variable; + The_Variable : Variable_Value; + Term_Project : constant Project_Node_Id := + Project_Node_Of + (The_Current_Term, + From_Project_Node_Tree); + Term_Package : constant Project_Node_Id := + Package_Node_Of + (The_Current_Term, + From_Project_Node_Tree); + Index : Name_Id := No_Name; + + begin + if Present (Term_Project) and then + Term_Project /= From_Project_Node + then + -- This variable or attribute comes from another project + + The_Name := + Name_Of (Term_Project, From_Project_Node_Tree); + The_Project := Imported_Or_Extended_Project_From + (Project => Project, + With_Name => The_Name); + end if; + + if Present (Term_Package) then + + -- This is an attribute of a package + + The_Name := + Name_Of (Term_Package, From_Project_Node_Tree); + The_Package := The_Project.Decl.Packages; + + while The_Package /= No_Package + and then In_Tree.Packages.Table + (The_Package).Name /= The_Name + loop + The_Package := + In_Tree.Packages.Table + (The_Package).Next; + end loop; + + pragma Assert + (The_Package /= No_Package, + "package not found."); + + elsif Kind_Of (The_Current_Term, From_Project_Node_Tree) = + N_Attribute_Reference + then + The_Package := No_Package; + end if; + + The_Name := + Name_Of (The_Current_Term, From_Project_Node_Tree); + + if Kind_Of (The_Current_Term, From_Project_Node_Tree) = + N_Attribute_Reference + then + Index := + Associative_Array_Index_Of + (The_Current_Term, From_Project_Node_Tree); + end if; + + -- If it is not an associative array attribute + + if Index = No_Name then + + -- It is not an associative array attribute + + if The_Package /= No_Package then + + -- First, if there is a package, look into the package + + if Kind_Of (The_Current_Term, From_Project_Node_Tree) = + N_Variable_Reference + then + The_Variable_Id := + In_Tree.Packages.Table + (The_Package).Decl.Variables; + else + The_Variable_Id := + In_Tree.Packages.Table + (The_Package).Decl.Attributes; + end if; + + while The_Variable_Id /= No_Variable + and then + In_Tree.Variable_Elements.Table + (The_Variable_Id).Name /= The_Name + loop + The_Variable_Id := + In_Tree.Variable_Elements.Table + (The_Variable_Id).Next; + end loop; + + end if; + + if The_Variable_Id = No_Variable then + + -- If we have not found it, look into the project + + if Kind_Of (The_Current_Term, From_Project_Node_Tree) = + N_Variable_Reference + then + The_Variable_Id := The_Project.Decl.Variables; + else + The_Variable_Id := The_Project.Decl.Attributes; + end if; + + while The_Variable_Id /= No_Variable + and then + In_Tree.Variable_Elements.Table + (The_Variable_Id).Name /= The_Name + loop + The_Variable_Id := + In_Tree.Variable_Elements.Table + (The_Variable_Id).Next; + end loop; + + end if; + + pragma Assert (The_Variable_Id /= No_Variable, + "variable or attribute not found"); + + The_Variable := + In_Tree.Variable_Elements.Table + (The_Variable_Id).Value; + + else + + -- It is an associative array attribute + + declare + The_Array : Array_Id := No_Array; + The_Element : Array_Element_Id := No_Array_Element; + Array_Index : Name_Id := No_Name; + + begin + if The_Package /= No_Package then + The_Array := + In_Tree.Packages.Table + (The_Package).Decl.Arrays; + else + The_Array := The_Project.Decl.Arrays; + end if; + + while The_Array /= No_Array + and then In_Tree.Arrays.Table + (The_Array).Name /= The_Name + loop + The_Array := In_Tree.Arrays.Table + (The_Array).Next; + end loop; + + if The_Array /= No_Array then + The_Element := In_Tree.Arrays.Table + (The_Array).Value; + Array_Index := + Get_Attribute_Index + (From_Project_Node_Tree, + The_Current_Term, + Index); + + while The_Element /= No_Array_Element + and then + In_Tree.Array_Elements.Table + (The_Element).Index /= Array_Index + loop + The_Element := + In_Tree.Array_Elements.Table + (The_Element).Next; + end loop; + + end if; + + if The_Element /= No_Array_Element then + The_Variable := + In_Tree.Array_Elements.Table + (The_Element).Value; + + else + if Expression_Kind_Of + (The_Current_Term, From_Project_Node_Tree) = + List + then + The_Variable := + (Project => Project, + Kind => List, + Location => No_Location, + Default => True, + Values => Nil_String); + else + The_Variable := + (Project => Project, + Kind => Single, + Location => No_Location, + Default => True, + Value => Empty_String, + Index => 0); + end if; + end if; + end; + end if; + + case Kind is + + when Undefined => + + -- Should never happen + + pragma Assert (False, "undefined expression kind"); + null; + + when Single => + + case The_Variable.Kind is + + when Undefined => + null; + + when Single => + Add (Result.Value, The_Variable.Value); + + when List => + + -- Should never happen + + pragma Assert + (False, + "list cannot appear in single " & + "string expression"); + null; + end case; + + when List => + case The_Variable.Kind is + + when Undefined => + null; + + when Single => + String_Element_Table.Increment_Last + (In_Tree.String_Elements); + + if Last = Nil_String then + + -- This can happen in an expression such as + -- () & Var + + Result.Values := + String_Element_Table.Last + (In_Tree.String_Elements); + + else + In_Tree.String_Elements.Table + (Last).Next := + String_Element_Table.Last + (In_Tree.String_Elements); + end if; + + Last := + String_Element_Table.Last + (In_Tree.String_Elements); + + In_Tree.String_Elements.Table (Last) := + (Value => The_Variable.Value, + Display_Value => No_Name, + Location => Location_Of + (The_Current_Term, + From_Project_Node_Tree), + Flag => False, + Next => Nil_String, + Index => 0); + + when List => + + declare + The_List : String_List_Id := + The_Variable.Values; + + begin + while The_List /= Nil_String loop + String_Element_Table.Increment_Last + (In_Tree.String_Elements); + + if Last = Nil_String then + Result.Values := + String_Element_Table.Last + (In_Tree. + String_Elements); + + else + In_Tree. + String_Elements.Table (Last).Next := + String_Element_Table.Last + (In_Tree. + String_Elements); + + end if; + + Last := + String_Element_Table.Last + (In_Tree.String_Elements); + + In_Tree.String_Elements.Table (Last) := + (Value => + In_Tree.String_Elements.Table + (The_List).Value, + Display_Value => No_Name, + Location => + Location_Of + (The_Current_Term, + From_Project_Node_Tree), + Flag => False, + Next => Nil_String, + Index => 0); + + The_List := + In_Tree. String_Elements.Table + (The_List).Next; + end loop; + end; + end case; + end case; + end; + + when N_External_Value => + Get_Name_String + (String_Value_Of + (External_Reference_Of + (The_Current_Term, From_Project_Node_Tree), + From_Project_Node_Tree)); + + declare + Name : constant Name_Id := Name_Find; + Default : Name_Id := No_Name; + Value : Name_Id := No_Name; + Ext_List : Boolean := False; + Str_List : String_List_Access := null; + Def_Var : Variable_Value; + + Default_Node : constant Project_Node_Id := + External_Default_Of + (The_Current_Term, + From_Project_Node_Tree); + + begin + -- If there is a default value for the external reference, + -- get its value. + + if Present (Default_Node) then + Def_Var := Expression + (Project => Project, + In_Tree => In_Tree, + Flags => Flags, + From_Project_Node => From_Project_Node, + From_Project_Node_Tree => From_Project_Node_Tree, + Pkg => Pkg, + First_Term => + Tree.First_Term + (Default_Node, From_Project_Node_Tree), + Kind => Single); + + if Def_Var /= Nil_Variable_Value then + Default := Def_Var.Value; + end if; + end if; + + Ext_List := Expression_Kind_Of + (The_Current_Term, + From_Project_Node_Tree) = List; + + if Ext_List then + Value := + Prj.Ext.Value_Of + (From_Project_Node_Tree, Name, No_Name); + + if Value /= No_Name then + declare + Sep : constant String := + Get_Name_String (Default); + First : Positive := 1; + Lst : Natural; + Done : Boolean := False; + Nmb : Natural; + + begin + Get_Name_String (Value); + + if Name_Len = 0 + or else Sep'Length = 0 + or else Name_Buffer (1 .. Name_Len) = Sep + then + Done := True; + end if; + + if not Done and then Name_Len < Sep'Length then + Str_List := + new String_List' + (1 => new String' + (Name_Buffer (1 .. Name_Len))); + Done := True; + end if; + + if not Done then + if Name_Buffer (1 .. Sep'Length) = Sep then + First := Sep'Length + 1; + end if; + + if Name_Len - First + 1 >= Sep'Length + and then + Name_Buffer (Name_Len - Sep'Length + 1 .. + Name_Len) = Sep + then + Name_Len := Name_Len - Sep'Length; + end if; + + if Name_Len = 0 then + Str_List := + new String_List'(1 => new String'("")); + Done := True; + end if; + end if; + + if not Done then + -- Count the number of string + + declare + Saved : constant Positive := First; + begin + + Nmb := 1; + loop + Lst := + Index + (Source => + Name_Buffer (First .. Name_Len), + Pattern => Sep); + exit when Lst = 0; + Nmb := Nmb + 1; + First := Lst + Sep'Length; + end loop; + + First := Saved; + end; + + Str_List := new String_List (1 .. Nmb); + + -- Populate the string list + + Nmb := 1; + loop + Lst := + Index + (Source => + Name_Buffer (First .. Name_Len), + Pattern => Sep); + + if Lst = 0 then + Str_List (Nmb) := + new String' + (Name_Buffer (First .. Name_Len)); + exit; + + else + Str_List (Nmb) := + new String' + (Name_Buffer (First .. Lst - 1)); + Nmb := Nmb + 1; + First := Lst + Sep'Length; + end if; + end loop; + end if; + end; + end if; + + else + -- Get the value + + Value := + Prj.Ext.Value_Of + (From_Project_Node_Tree, Name, Default); + + if Value = No_Name then + if not Quiet_Output then + Error_Msg + (Flags, "?undefined external reference", + Location_Of + (The_Current_Term, From_Project_Node_Tree), + Project); + end if; + + Value := Empty_String; + end if; + end if; + + case Kind is + + when Undefined => + null; + + when Single => + if Ext_List then + null; -- error + + else + Add (Result.Value, Value); + end if; + + when List => + if not Ext_List or else Str_List /= null then + String_Element_Table.Increment_Last + (In_Tree.String_Elements); + + if Last = Nil_String then + Result.Values := + String_Element_Table.Last + (In_Tree.String_Elements); + + else + In_Tree.String_Elements.Table (Last).Next := + String_Element_Table.Last + (In_Tree.String_Elements); + end if; + + Last := + String_Element_Table.Last + (In_Tree.String_Elements); + + if Ext_List then + for Ind in Str_List'Range loop + Name_Len := 0; + Add_Str_To_Name_Buffer (Str_List (Ind).all); + Value := Name_Find; + In_Tree.String_Elements.Table (Last) := + (Value => Value, + Display_Value => No_Name, + Location => + Location_Of + (The_Current_Term, + From_Project_Node_Tree), + Flag => False, + Next => Nil_String, + Index => 0); + + if Ind /= Str_List'Last then + String_Element_Table.Increment_Last + (In_Tree.String_Elements); + In_Tree.String_Elements.Table + (Last).Next := + String_Element_Table.Last + (In_Tree.String_Elements); + Last := + String_Element_Table.Last + (In_Tree.String_Elements); + end if; + end loop; + + else + In_Tree.String_Elements.Table (Last) := + (Value => Value, + Display_Value => No_Name, + Location => + Location_Of + (The_Current_Term, + From_Project_Node_Tree), + Flag => False, + Next => Nil_String, + Index => 0); + end if; + end if; + end case; + end; + + when others => + + -- Should never happen + + pragma Assert + (False, + "illegal node kind in an expression"); + raise Program_Error; + + end case; + + The_Term := Next_Term (The_Term, From_Project_Node_Tree); + end loop; + + return Result; + end Expression; + + --------------------------------------- + -- Imported_Or_Extended_Project_From -- + --------------------------------------- + + function Imported_Or_Extended_Project_From + (Project : Project_Id; + With_Name : Name_Id) return Project_Id + is + List : Project_List; + Result : Project_Id; + Temp_Result : Project_Id; + + begin + -- First check if it is the name of an extended project + + Result := Project.Extends; + while Result /= No_Project loop + if Result.Name = With_Name then + return Result; + else + Result := Result.Extends; + end if; + end loop; + + -- Then check the name of each imported project + + Temp_Result := No_Project; + List := Project.Imported_Projects; + while List /= null loop + Result := List.Project; + + -- If the project is directly imported, then returns its ID + + if Result.Name = With_Name then + return Result; + end if; + + -- If a project extending the project is imported, then keep this + -- extending project as a possibility. It will be the returned ID + -- if the project is not imported directly. + + declare + Proj : Project_Id; + + begin + Proj := Result.Extends; + while Proj /= No_Project loop + if Proj.Name = With_Name then + Temp_Result := Result; + exit; + end if; + + Proj := Proj.Extends; + end loop; + end; + + List := List.Next; + end loop; + + pragma Assert (Temp_Result /= No_Project, "project not found"); + return Temp_Result; + end Imported_Or_Extended_Project_From; + + ------------------ + -- Package_From -- + ------------------ + + function Package_From + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + With_Name : Name_Id) return Package_Id + is + Result : Package_Id := Project.Decl.Packages; + + begin + -- Check the name of each existing package of Project + + while Result /= No_Package + and then In_Tree.Packages.Table (Result).Name /= With_Name + loop + Result := In_Tree.Packages.Table (Result).Next; + end loop; + + if Result = No_Package then + + -- Should never happen + + Write_Line ("package """ & Get_Name_String (With_Name) & + """ not found"); + raise Program_Error; + + else + return Result; + end if; + end Package_From; + + ------------- + -- Process -- + ------------- + + procedure Process + (In_Tree : Project_Tree_Ref; + Project : out Project_Id; + Success : out Boolean; + From_Project_Node : Project_Node_Id; + From_Project_Node_Tree : Project_Node_Tree_Ref; + Flags : Processing_Flags; + Reset_Tree : Boolean := True) + is + begin + Process_Project_Tree_Phase_1 + (In_Tree => In_Tree, + Project => Project, + Success => Success, + From_Project_Node => From_Project_Node, + From_Project_Node_Tree => From_Project_Node_Tree, + Flags => Flags, + Reset_Tree => Reset_Tree); + + if Project_Qualifier_Of (From_Project_Node, From_Project_Node_Tree) /= + Configuration + then + Process_Project_Tree_Phase_2 + (In_Tree => In_Tree, + Project => Project, + Success => Success, + From_Project_Node => From_Project_Node, + From_Project_Node_Tree => From_Project_Node_Tree, + Flags => Flags); + end if; + end Process; + + ------------------------------- + -- Process_Declarative_Items -- + ------------------------------- + + procedure Process_Declarative_Items + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Flags : Processing_Flags; + From_Project_Node : Project_Node_Id; + From_Project_Node_Tree : Project_Node_Tree_Ref; + Pkg : Package_Id; + Item : Project_Node_Id) + is + procedure Check_Or_Set_Typed_Variable + (Value : in out Variable_Value; + Declaration : Project_Node_Id); + -- Check whether Value is valid for this typed variable declaration. If + -- it is an error, the behavior depends on the flags: either an error is + -- reported, or a warning, or nothing. In the last two cases, the value + -- of the variable is set to a valid value, replacing Value. + + --------------------------------- + -- Check_Or_Set_Typed_Variable -- + --------------------------------- + + procedure Check_Or_Set_Typed_Variable + (Value : in out Variable_Value; + Declaration : Project_Node_Id) + is + Loc : constant Source_Ptr := + Location_Of (Declaration, From_Project_Node_Tree); + + Reset_Value : Boolean := False; + Current_String : Project_Node_Id; + + begin + -- Report an error for an empty string + + if Value.Value = Empty_String then + Error_Msg_Name_1 := Name_Of (Declaration, From_Project_Node_Tree); + + case Flags.Allow_Invalid_External is + when Error => + Error_Msg (Flags, "no value defined for %%", Loc, Project); + when Warning => + Reset_Value := True; + Error_Msg (Flags, "?no value defined for %%", Loc, Project); + when Silent => + Reset_Value := True; + end case; + + else + -- Loop through all the valid strings for the + -- string type and compare to the string value. + + Current_String := + First_Literal_String + (String_Type_Of (Declaration, From_Project_Node_Tree), + From_Project_Node_Tree); + while Present (Current_String) + and then String_Value_Of + (Current_String, From_Project_Node_Tree) /= Value.Value + loop + Current_String := + Next_Literal_String (Current_String, From_Project_Node_Tree); + end loop; + + -- Report error if string value is not one for the string type + + if No (Current_String) then + Error_Msg_Name_1 := Value.Value; + Error_Msg_Name_2 := + Name_Of (Declaration, From_Project_Node_Tree); + + case Flags.Allow_Invalid_External is + when Error => + Error_Msg + (Flags, "value %% is illegal for typed string %%", + Loc, Project); + when Warning => + Error_Msg + (Flags, "?value %% is illegal for typed string %%", + Loc, Project); + Reset_Value := True; + when Silent => + Reset_Value := True; + end case; + end if; + end if; + + if Reset_Value then + Current_String := + First_Literal_String + (String_Type_Of (Declaration, From_Project_Node_Tree), + From_Project_Node_Tree); + + Value.Value := String_Value_Of + (Current_String, From_Project_Node_Tree); + end if; + end Check_Or_Set_Typed_Variable; + + -- Local variables + + Current_Declarative_Item : Project_Node_Id; + Current_Item : Project_Node_Id; + + -- Start of processing for Process_Declarative_Items + + begin + -- Loop through declarative items + + Current_Item := Empty_Node; + + Current_Declarative_Item := Item; + while Present (Current_Declarative_Item) loop + + -- Get its data + + Current_Item := + Current_Item_Node + (Current_Declarative_Item, From_Project_Node_Tree); + + -- And set Current_Declarative_Item to the next declarative item + -- ready for the next iteration. + + Current_Declarative_Item := + Next_Declarative_Item + (Current_Declarative_Item, From_Project_Node_Tree); + + case Kind_Of (Current_Item, From_Project_Node_Tree) is + + when N_Package_Declaration => + + -- Do not process a package declaration that should be ignored + + if Expression_Kind_Of + (Current_Item, From_Project_Node_Tree) /= Ignored + then + -- Create the new package + + Package_Table.Increment_Last (In_Tree.Packages); + + declare + New_Pkg : constant Package_Id := + Package_Table.Last (In_Tree.Packages); + The_New_Package : Package_Element; + + Project_Of_Renamed_Package : + constant Project_Node_Id := + Project_Of_Renamed_Package_Of + (Current_Item, From_Project_Node_Tree); + + begin + -- Set the name of the new package + + The_New_Package.Name := + Name_Of (Current_Item, From_Project_Node_Tree); + + -- Insert the new package in the appropriate list + + if Pkg /= No_Package then + The_New_Package.Next := + In_Tree.Packages.Table (Pkg).Decl.Packages; + In_Tree.Packages.Table (Pkg).Decl.Packages := + New_Pkg; + + else + The_New_Package.Next := Project.Decl.Packages; + Project.Decl.Packages := New_Pkg; + end if; + + In_Tree.Packages.Table (New_Pkg) := + The_New_Package; + + if Present (Project_Of_Renamed_Package) then + + -- Renamed or extending package + + declare + Project_Name : constant Name_Id := + Name_Of + (Project_Of_Renamed_Package, + From_Project_Node_Tree); + + Renamed_Project : + constant Project_Id := + Imported_Or_Extended_Project_From + (Project, Project_Name); + + Renamed_Package : constant Package_Id := + Package_From + (Renamed_Project, In_Tree, + Name_Of + (Current_Item, + From_Project_Node_Tree)); + + begin + -- For a renamed package, copy the declarations of + -- the renamed package, but set all the locations + -- to the location of the package name in the + -- renaming declaration. + + Copy_Package_Declarations + (From => + In_Tree.Packages.Table (Renamed_Package).Decl, + To => + In_Tree.Packages.Table (New_Pkg).Decl, + New_Loc => + Location_Of + (Current_Item, From_Project_Node_Tree), + Restricted => False, + In_Tree => In_Tree); + end; + + else + -- Set the default values of the attributes + + Add_Attributes + (Project, + Project.Name, + Name_Id (Project.Directory.Name), + In_Tree, + In_Tree.Packages.Table (New_Pkg).Decl, + First_Attribute_Of + (Package_Id_Of + (Current_Item, From_Project_Node_Tree)), + Project_Level => False); + + end if; + + -- Process declarative items (nothing to do when the + -- package is renaming, as the first declarative item is + -- null). + + Process_Declarative_Items + (Project => Project, + In_Tree => In_Tree, + Flags => Flags, + From_Project_Node => From_Project_Node, + From_Project_Node_Tree => From_Project_Node_Tree, + Pkg => New_Pkg, + Item => + First_Declarative_Item_Of + (Current_Item, From_Project_Node_Tree)); + end; + end if; + + when N_String_Type_Declaration => + + -- There is nothing to process + + null; + + when N_Attribute_Declaration | + N_Typed_Variable_Declaration | + N_Variable_Declaration => + + if Expression_Of (Current_Item, From_Project_Node_Tree) = + Empty_Node + then + + -- It must be a full associative array attribute declaration + + declare + Current_Item_Name : constant Name_Id := + Name_Of + (Current_Item, + From_Project_Node_Tree); + -- The name of the attribute + + Current_Location : constant Source_Ptr := + Location_Of + (Current_Item, + From_Project_Node_Tree); + + New_Array : Array_Id; + -- The new associative array created + + Orig_Array : Array_Id; + -- The associative array value + + Orig_Project_Name : Name_Id := No_Name; + -- The name of the project where the associative array + -- value is. + + Orig_Project : Project_Id := No_Project; + -- The id of the project where the associative array + -- value is. + + Orig_Package_Name : Name_Id := No_Name; + -- The name of the package, if any, where the associative + -- array value is. + + Orig_Package : Package_Id := No_Package; + -- The id of the package, if any, where the associative + -- array value is. + + New_Element : Array_Element_Id := No_Array_Element; + -- Id of a new array element created + + Prev_Element : Array_Element_Id := No_Array_Element; + -- Last new element id created + + Orig_Element : Array_Element_Id := No_Array_Element; + -- Current array element in original associative array + + Next_Element : Array_Element_Id := No_Array_Element; + -- Id of the array element that follows the new element. + -- This is not always nil, because values for the + -- associative array attribute may already have been + -- declared, and the array elements declared are reused. + + Prj : Project_List; + + begin + -- First find if the associative array attribute already + -- has elements declared. + + if Pkg /= No_Package then + New_Array := In_Tree.Packages.Table + (Pkg).Decl.Arrays; + + else + New_Array := Project.Decl.Arrays; + end if; + + while New_Array /= No_Array + and then In_Tree.Arrays.Table (New_Array).Name /= + Current_Item_Name + loop + New_Array := In_Tree.Arrays.Table (New_Array).Next; + end loop; + + -- If the attribute has never been declared add new entry + -- in the arrays of the project/package and link it. + + if New_Array = No_Array then + Array_Table.Increment_Last (In_Tree.Arrays); + New_Array := Array_Table.Last (In_Tree.Arrays); + + if Pkg /= No_Package then + In_Tree.Arrays.Table (New_Array) := + (Name => Current_Item_Name, + Location => Current_Location, + Value => No_Array_Element, + Next => In_Tree.Packages.Table + (Pkg).Decl.Arrays); + + In_Tree.Packages.Table (Pkg).Decl.Arrays := + New_Array; + + else + In_Tree.Arrays.Table (New_Array) := + (Name => Current_Item_Name, + Location => Current_Location, + Value => No_Array_Element, + Next => Project.Decl.Arrays); + + Project.Decl.Arrays := New_Array; + end if; + end if; + + -- Find the project where the value is declared + + Orig_Project_Name := + Name_Of + (Associative_Project_Of + (Current_Item, From_Project_Node_Tree), + From_Project_Node_Tree); + + Prj := In_Tree.Projects; + while Prj /= null loop + if Prj.Project.Name = Orig_Project_Name then + Orig_Project := Prj.Project; + exit; + end if; + Prj := Prj.Next; + end loop; + + pragma Assert (Orig_Project /= No_Project, + "original project not found"); + + if No (Associative_Package_Of + (Current_Item, From_Project_Node_Tree)) + then + Orig_Array := Orig_Project.Decl.Arrays; + + else + -- If in a package, find the package where the value + -- is declared. + + Orig_Package_Name := + Name_Of + (Associative_Package_Of + (Current_Item, From_Project_Node_Tree), + From_Project_Node_Tree); + + Orig_Package := Orig_Project.Decl.Packages; + pragma Assert (Orig_Package /= No_Package, + "original package not found"); + + while In_Tree.Packages.Table + (Orig_Package).Name /= Orig_Package_Name + loop + Orig_Package := In_Tree.Packages.Table + (Orig_Package).Next; + pragma Assert (Orig_Package /= No_Package, + "original package not found"); + end loop; + + Orig_Array := + In_Tree.Packages.Table (Orig_Package).Decl.Arrays; + end if; + + -- Now look for the array + + while Orig_Array /= No_Array + and then In_Tree.Arrays.Table (Orig_Array).Name /= + Current_Item_Name + loop + Orig_Array := In_Tree.Arrays.Table + (Orig_Array).Next; + end loop; + + if Orig_Array = No_Array then + Error_Msg + (Flags, + "associative array value not found", + Location_Of (Current_Item, From_Project_Node_Tree), + Project); + + else + Orig_Element := + In_Tree.Arrays.Table (Orig_Array).Value; + + -- Copy each array element + + while Orig_Element /= No_Array_Element loop + + -- Case of first element + + if Prev_Element = No_Array_Element then + + -- And there is no array element declared yet, + -- create a new first array element. + + if In_Tree.Arrays.Table (New_Array).Value = + No_Array_Element + then + Array_Element_Table.Increment_Last + (In_Tree.Array_Elements); + New_Element := Array_Element_Table.Last + (In_Tree.Array_Elements); + In_Tree.Arrays.Table + (New_Array).Value := New_Element; + Next_Element := No_Array_Element; + + -- Otherwise, the new element is the first + + else + New_Element := In_Tree.Arrays. + Table (New_Array).Value; + Next_Element := + In_Tree.Array_Elements.Table + (New_Element).Next; + end if; + + -- Otherwise, reuse an existing element, or create + -- one if necessary. + + else + Next_Element := + In_Tree.Array_Elements.Table + (Prev_Element).Next; + + if Next_Element = No_Array_Element then + Array_Element_Table.Increment_Last + (In_Tree.Array_Elements); + New_Element := + Array_Element_Table.Last + (In_Tree.Array_Elements); + In_Tree.Array_Elements.Table + (Prev_Element).Next := New_Element; + + else + New_Element := Next_Element; + Next_Element := + In_Tree.Array_Elements.Table + (New_Element).Next; + end if; + end if; + + -- Copy the value of the element + + In_Tree.Array_Elements.Table + (New_Element) := + In_Tree.Array_Elements.Table (Orig_Element); + In_Tree.Array_Elements.Table + (New_Element).Value.Project := Project; + + -- Adjust the Next link + + In_Tree.Array_Elements.Table + (New_Element).Next := Next_Element; + + -- Adjust the previous id for the next element + + Prev_Element := New_Element; + + -- Go to the next element in the original array + + Orig_Element := + In_Tree.Array_Elements.Table + (Orig_Element).Next; + end loop; + + -- Make sure that the array ends here, in case there + -- previously a greater number of elements. + + In_Tree.Array_Elements.Table + (New_Element).Next := No_Array_Element; + end if; + end; + + -- Declarations other that full associative arrays + + else + declare + New_Value : Variable_Value := + Expression + (Project => Project, + In_Tree => In_Tree, + Flags => Flags, + From_Project_Node => From_Project_Node, + From_Project_Node_Tree => From_Project_Node_Tree, + Pkg => Pkg, + First_Term => + Tree.First_Term + (Expression_Of + (Current_Item, From_Project_Node_Tree), + From_Project_Node_Tree), + Kind => + Expression_Kind_Of + (Current_Item, From_Project_Node_Tree)); + -- The expression value + + The_Variable : Variable_Id := No_Variable; + + Current_Item_Name : constant Name_Id := + Name_Of + (Current_Item, + From_Project_Node_Tree); + + Current_Location : constant Source_Ptr := + Location_Of + (Current_Item, + From_Project_Node_Tree); + + begin + -- Process a typed variable declaration + + if Kind_Of (Current_Item, From_Project_Node_Tree) = + N_Typed_Variable_Declaration + then + Check_Or_Set_Typed_Variable + (Value => New_Value, + Declaration => Current_Item); + end if; + + -- Comment here ??? + + if Kind_Of (Current_Item, From_Project_Node_Tree) /= + N_Attribute_Declaration + or else + Associative_Array_Index_Of + (Current_Item, From_Project_Node_Tree) = No_Name + then + -- Case of a variable declaration or of a not + -- associative array attribute. + + -- First, find the list where to find the variable + -- or attribute. + + if Kind_Of (Current_Item, From_Project_Node_Tree) = + N_Attribute_Declaration + then + if Pkg /= No_Package then + The_Variable := + In_Tree.Packages.Table + (Pkg).Decl.Attributes; + else + The_Variable := Project.Decl.Attributes; + end if; + + else + if Pkg /= No_Package then + The_Variable := + In_Tree.Packages.Table + (Pkg).Decl.Variables; + else + The_Variable := Project.Decl.Variables; + end if; + + end if; + + -- Loop through the list, to find if it has already + -- been declared. + + while The_Variable /= No_Variable + and then + In_Tree.Variable_Elements.Table + (The_Variable).Name /= Current_Item_Name + loop + The_Variable := + In_Tree.Variable_Elements.Table + (The_Variable).Next; + end loop; + + -- If it has not been declared, create a new entry + -- in the list. + + if The_Variable = No_Variable then + + -- All single string attribute should already have + -- been declared with a default empty string value. + + pragma Assert + (Kind_Of (Current_Item, From_Project_Node_Tree) /= + N_Attribute_Declaration, + "illegal attribute declaration for " + & Get_Name_String (Current_Item_Name)); + + Variable_Element_Table.Increment_Last + (In_Tree.Variable_Elements); + The_Variable := Variable_Element_Table.Last + (In_Tree.Variable_Elements); + + -- Put the new variable in the appropriate list + + if Pkg /= No_Package then + In_Tree.Variable_Elements.Table (The_Variable) := + (Next => + In_Tree.Packages.Table + (Pkg).Decl.Variables, + Name => Current_Item_Name, + Value => New_Value); + In_Tree.Packages.Table + (Pkg).Decl.Variables := The_Variable; + + else + In_Tree.Variable_Elements.Table (The_Variable) := + (Next => Project.Decl.Variables, + Name => Current_Item_Name, + Value => New_Value); + Project.Decl.Variables := The_Variable; + end if; + + -- If the variable/attribute has already been + -- declared, just change the value. + + else + In_Tree.Variable_Elements.Table + (The_Variable).Value := New_Value; + end if; + + -- Associative array attribute + + else + declare + Index_Name : Name_Id := + Associative_Array_Index_Of + (Current_Item, + From_Project_Node_Tree); + + Source_Index : constant Int := + Source_Index_Of + (Current_Item, + From_Project_Node_Tree); + + The_Array : Array_Id; + The_Array_Element : Array_Element_Id := + No_Array_Element; + + begin + if Index_Name /= All_Other_Names then + Index_Name := Get_Attribute_Index + (From_Project_Node_Tree, + Current_Item, + Associative_Array_Index_Of + (Current_Item, From_Project_Node_Tree)); + end if; + + -- Look for the array in the appropriate list + + if Pkg /= No_Package then + The_Array := + In_Tree.Packages.Table (Pkg).Decl.Arrays; + else + The_Array := + Project.Decl.Arrays; + end if; + + while + The_Array /= No_Array + and then + In_Tree.Arrays.Table (The_Array).Name /= + Current_Item_Name + loop + The_Array := + In_Tree.Arrays.Table (The_Array).Next; + end loop; + + -- If the array cannot be found, create a new entry + -- in the list. As The_Array_Element is initialized + -- to No_Array_Element, a new element will be + -- created automatically later + + if The_Array = No_Array then + Array_Table.Increment_Last (In_Tree.Arrays); + The_Array := Array_Table.Last (In_Tree.Arrays); + + if Pkg /= No_Package then + In_Tree.Arrays.Table (The_Array) := + (Name => Current_Item_Name, + Location => Current_Location, + Value => No_Array_Element, + Next => In_Tree.Packages.Table + (Pkg).Decl.Arrays); + + In_Tree.Packages.Table (Pkg).Decl.Arrays := + The_Array; + + else + In_Tree.Arrays.Table (The_Array) := + (Name => Current_Item_Name, + Location => Current_Location, + Value => No_Array_Element, + Next => Project.Decl.Arrays); + + Project.Decl.Arrays := The_Array; + end if; + + -- Otherwise initialize The_Array_Element as the + -- head of the element list. + + else + The_Array_Element := + In_Tree.Arrays.Table (The_Array).Value; + end if; + + -- Look in the list, if any, to find an element + -- with the same index and same source index. + + while The_Array_Element /= No_Array_Element + and then + (In_Tree.Array_Elements.Table + (The_Array_Element).Index /= Index_Name + or else + In_Tree.Array_Elements.Table + (The_Array_Element).Src_Index /= Source_Index) + loop + The_Array_Element := + In_Tree.Array_Elements.Table + (The_Array_Element).Next; + end loop; + + -- If no such element were found, create a new one + -- and insert it in the element list, with the + -- proper value. + + if The_Array_Element = No_Array_Element then + Array_Element_Table.Increment_Last + (In_Tree.Array_Elements); + The_Array_Element := + Array_Element_Table.Last + (In_Tree.Array_Elements); + + In_Tree.Array_Elements.Table + (The_Array_Element) := + (Index => Index_Name, + Src_Index => Source_Index, + Index_Case_Sensitive => + not Case_Insensitive + (Current_Item, From_Project_Node_Tree), + Value => New_Value, + Next => + In_Tree.Arrays.Table (The_Array).Value); + + In_Tree.Arrays.Table (The_Array).Value := + The_Array_Element; + + -- An element with the same index already exists, + -- just replace its value with the new one. + + else + In_Tree.Array_Elements.Table + (The_Array_Element).Value := New_Value; + end if; + end; + end if; + end; + end if; + + when N_Case_Construction => + declare + The_Project : Project_Id := Project; + -- The id of the project of the case variable + + The_Package : Package_Id := Pkg; + -- The id of the package, if any, of the case variable + + The_Variable : Variable_Value := Nil_Variable_Value; + -- The case variable + + Case_Value : Name_Id := No_Name; + -- The case variable value + + Case_Item : Project_Node_Id := Empty_Node; + Choice_String : Project_Node_Id := Empty_Node; + Decl_Item : Project_Node_Id := Empty_Node; + + begin + declare + Variable_Node : constant Project_Node_Id := + Case_Variable_Reference_Of + (Current_Item, + From_Project_Node_Tree); + + Var_Id : Variable_Id := No_Variable; + Name : Name_Id := No_Name; + + begin + -- If a project was specified for the case variable, + -- get its id. + + if Present (Project_Node_Of + (Variable_Node, From_Project_Node_Tree)) + then + Name := + Name_Of + (Project_Node_Of + (Variable_Node, From_Project_Node_Tree), + From_Project_Node_Tree); + The_Project := + Imported_Or_Extended_Project_From (Project, Name); + end if; + + -- If a package were specified for the case variable, + -- get its id. + + if Present (Package_Node_Of + (Variable_Node, From_Project_Node_Tree)) + then + Name := + Name_Of + (Package_Node_Of + (Variable_Node, From_Project_Node_Tree), + From_Project_Node_Tree); + The_Package := + Package_From (The_Project, In_Tree, Name); + end if; + + Name := Name_Of (Variable_Node, From_Project_Node_Tree); + + -- First, look for the case variable into the package, + -- if any. + + if The_Package /= No_Package then + Var_Id := In_Tree.Packages.Table + (The_Package).Decl.Variables; + Name := + Name_Of (Variable_Node, From_Project_Node_Tree); + while Var_Id /= No_Variable + and then + In_Tree.Variable_Elements.Table + (Var_Id).Name /= Name + loop + Var_Id := In_Tree.Variable_Elements. + Table (Var_Id).Next; + end loop; + end if; + + -- If not found in the package, or if there is no + -- package, look at the project level. + + if Var_Id = No_Variable + and then + No (Package_Node_Of + (Variable_Node, From_Project_Node_Tree)) + then + Var_Id := The_Project.Decl.Variables; + while Var_Id /= No_Variable + and then + In_Tree.Variable_Elements.Table + (Var_Id).Name /= Name + loop + Var_Id := In_Tree.Variable_Elements. + Table (Var_Id).Next; + end loop; + end if; + + if Var_Id = No_Variable then + + -- Should never happen, because this has already been + -- checked during parsing. + + Write_Line ("variable """ & + Get_Name_String (Name) & + """ not found"); + raise Program_Error; + end if; + + -- Get the case variable + + The_Variable := In_Tree.Variable_Elements. + Table (Var_Id).Value; + + if The_Variable.Kind /= Single then + + -- Should never happen, because this has already been + -- checked during parsing. + + Write_Line ("variable""" & + Get_Name_String (Name) & + """ is not a single string variable"); + raise Program_Error; + end if; + + -- Get the case variable value + Case_Value := The_Variable.Value; + end; + + -- Now look into all the case items of the case construction + + Case_Item := + First_Case_Item_Of (Current_Item, From_Project_Node_Tree); + Case_Item_Loop : + while Present (Case_Item) loop + Choice_String := + First_Choice_Of (Case_Item, From_Project_Node_Tree); + + -- When Choice_String is nil, it means that it is + -- the "when others =>" alternative. + + if No (Choice_String) then + Decl_Item := + First_Declarative_Item_Of + (Case_Item, From_Project_Node_Tree); + exit Case_Item_Loop; + end if; + + -- Look into all the alternative of this case item + + Choice_Loop : + while Present (Choice_String) loop + if Case_Value = + String_Value_Of + (Choice_String, From_Project_Node_Tree) + then + Decl_Item := + First_Declarative_Item_Of + (Case_Item, From_Project_Node_Tree); + exit Case_Item_Loop; + end if; + + Choice_String := + Next_Literal_String + (Choice_String, From_Project_Node_Tree); + end loop Choice_Loop; + + Case_Item := + Next_Case_Item (Case_Item, From_Project_Node_Tree); + end loop Case_Item_Loop; + + -- If there is an alternative, then we process it + + if Present (Decl_Item) then + Process_Declarative_Items + (Project => Project, + In_Tree => In_Tree, + Flags => Flags, + From_Project_Node => From_Project_Node, + From_Project_Node_Tree => From_Project_Node_Tree, + Pkg => Pkg, + Item => Decl_Item); + end if; + end; + + when others => + + -- Should never happen + + Write_Line ("Illegal declarative item: " & + Project_Node_Kind'Image + (Kind_Of + (Current_Item, From_Project_Node_Tree))); + raise Program_Error; + end case; + end loop; + end Process_Declarative_Items; + + ---------------------------------- + -- Process_Project_Tree_Phase_1 -- + ---------------------------------- + + procedure Process_Project_Tree_Phase_1 + (In_Tree : Project_Tree_Ref; + Project : out Project_Id; + Success : out Boolean; + From_Project_Node : Project_Node_Id; + From_Project_Node_Tree : Project_Node_Tree_Ref; + Flags : Processing_Flags; + Reset_Tree : Boolean := True) + is + begin + if Reset_Tree then + + -- Make sure there are no projects in the data structure + + Free_List (In_Tree.Projects, Free_Project => True); + end if; + + Processed_Projects.Reset; + + -- And process the main project and all of the projects it depends on, + -- recursively. + + Recursive_Process + (Project => Project, + In_Tree => In_Tree, + Flags => Flags, + From_Project_Node => From_Project_Node, + From_Project_Node_Tree => From_Project_Node_Tree, + Extended_By => No_Project); + + Success := + Total_Errors_Detected = 0 + and then + (Warning_Mode /= Treat_As_Error or else Warnings_Detected = 0); + end Process_Project_Tree_Phase_1; + + ---------------------------------- + -- Process_Project_Tree_Phase_2 -- + ---------------------------------- + + procedure Process_Project_Tree_Phase_2 + (In_Tree : Project_Tree_Ref; + Project : Project_Id; + Success : out Boolean; + From_Project_Node : Project_Node_Id; + From_Project_Node_Tree : Project_Node_Tree_Ref; + Flags : Processing_Flags) + is + Obj_Dir : Path_Name_Type; + Extending : Project_Id; + Extending2 : Project_Id; + Prj : Project_List; + + -- Start of processing for Process_Project_Tree_Phase_2 + + begin + Success := True; + + if Project /= No_Project then + Check (In_Tree, Project, From_Project_Node_Tree, Flags); + end if; + + -- If main project is an extending all project, set object directory of + -- all virtual extending projects to object directory of main project. + + if Project /= No_Project + and then + Is_Extending_All (From_Project_Node, From_Project_Node_Tree) + then + declare + Object_Dir : constant Path_Information := + Project.Object_Directory; + begin + Prj := In_Tree.Projects; + while Prj /= null loop + if Prj.Project.Virtual then + Prj.Project.Object_Directory := Object_Dir; + end if; + Prj := Prj.Next; + end loop; + end; + end if; + + -- Check that no extending project shares its object directory with + -- the project(s) it extends. + + if Project /= No_Project then + Prj := In_Tree.Projects; + while Prj /= null loop + Extending := Prj.Project.Extended_By; + + if Extending /= No_Project then + Obj_Dir := Prj.Project.Object_Directory.Name; + + -- Check that a project being extended does not share its + -- object directory with any project that extends it, directly + -- or indirectly, including a virtual extending project. + + -- Start with the project directly extending it + + Extending2 := Extending; + while Extending2 /= No_Project loop + if Has_Ada_Sources (Extending2) + and then Extending2.Object_Directory.Name = Obj_Dir + then + if Extending2.Virtual then + Error_Msg_Name_1 := Prj.Project.Display_Name; + Error_Msg + (Flags, + "project %% cannot be extended by a virtual" & + " project with the same object directory", + Prj.Project.Location, Project); + + else + Error_Msg_Name_1 := Extending2.Display_Name; + Error_Msg_Name_2 := Prj.Project.Display_Name; + Error_Msg + (Flags, + "project %% cannot extend project %%", + Extending2.Location, Project); + Error_Msg + (Flags, + "\they share the same object directory", + Extending2.Location, Project); + end if; + end if; + + -- Continue with the next extending project, if any + + Extending2 := Extending2.Extended_By; + end loop; + end if; + + Prj := Prj.Next; + end loop; + end if; + + Success := + Total_Errors_Detected = 0 + and then + (Warning_Mode /= Treat_As_Error or else Warnings_Detected = 0); + end Process_Project_Tree_Phase_2; + + ----------------------- + -- Recursive_Process -- + ----------------------- + + procedure Recursive_Process + (In_Tree : Project_Tree_Ref; + Project : out Project_Id; + Flags : Processing_Flags; + From_Project_Node : Project_Node_Id; + From_Project_Node_Tree : Project_Node_Tree_Ref; + Extended_By : Project_Id) + is + procedure Process_Imported_Projects + (Imported : in out Project_List; + Limited_With : Boolean); + -- Process imported projects. If Limited_With is True, then only + -- projects processed through a "limited with" are processed, otherwise + -- only projects imported through a standard "with" are processed. + -- Imported is the id of the last imported project. + + ------------------------------- + -- Process_Imported_Projects -- + ------------------------------- + + procedure Process_Imported_Projects + (Imported : in out Project_List; + Limited_With : Boolean) + is + With_Clause : Project_Node_Id; + New_Project : Project_Id; + Proj_Node : Project_Node_Id; + + begin + With_Clause := + First_With_Clause_Of + (From_Project_Node, From_Project_Node_Tree); + while Present (With_Clause) loop + Proj_Node := + Non_Limited_Project_Node_Of + (With_Clause, From_Project_Node_Tree); + New_Project := No_Project; + + if (Limited_With and then No (Proj_Node)) + or else (not Limited_With and then Present (Proj_Node)) + then + Recursive_Process + (In_Tree => In_Tree, + Project => New_Project, + Flags => Flags, + From_Project_Node => + Project_Node_Of + (With_Clause, From_Project_Node_Tree), + From_Project_Node_Tree => From_Project_Node_Tree, + Extended_By => No_Project); + + -- Imported is the id of the last imported project. If + -- it is nil, then this imported project is our first. + + if Imported = null then + Project.Imported_Projects := + new Project_List_Element' + (Project => New_Project, + Next => null); + Imported := Project.Imported_Projects; + else + Imported.Next := new Project_List_Element' + (Project => New_Project, + Next => null); + Imported := Imported.Next; + end if; + end if; + + With_Clause := + Next_With_Clause_Of (With_Clause, From_Project_Node_Tree); + end loop; + end Process_Imported_Projects; + + -- Start of processing for Recursive_Process + + begin + if No (From_Project_Node) then + Project := No_Project; + + else + declare + Imported : Project_List; + Declaration_Node : Project_Node_Id := Empty_Node; + + Name : constant Name_Id := + Name_Of (From_Project_Node, From_Project_Node_Tree); + + Name_Node : constant Tree_Private_Part.Project_Name_And_Node := + Tree_Private_Part.Projects_Htable.Get + (From_Project_Node_Tree.Projects_HT, Name); + + begin + Project := Processed_Projects.Get (Name); + + if Project /= No_Project then + + -- Make sure that, when a project is extended, the project id + -- of the project extending it is recorded in its data, even + -- when it has already been processed as an imported project. + -- This is for virtually extended projects. + + if Extended_By /= No_Project then + Project.Extended_By := Extended_By; + end if; + + return; + end if; + + Project := new Project_Data'(Empty_Project); + In_Tree.Projects := new Project_List_Element' + (Project => Project, + Next => In_Tree.Projects); + + Processed_Projects.Set (Name, Project); + + Project.Name := Name; + Project.Display_Name := Name_Node.Display_Name; + Project.Qualifier := + Project_Qualifier_Of (From_Project_Node, From_Project_Node_Tree); + + Get_Name_String (Name); + + -- If name starts with the virtual prefix, flag the project as + -- being a virtual extending project. + + if Name_Len > Virtual_Prefix'Length + and then Name_Buffer (1 .. Virtual_Prefix'Length) = + Virtual_Prefix + then + Project.Virtual := True; + + end if; + + Project.Path.Display_Name := + Path_Name_Of (From_Project_Node, From_Project_Node_Tree); + Get_Name_String (Project.Path.Display_Name); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Project.Path.Name := Name_Find; + + Project.Location := + Location_Of (From_Project_Node, From_Project_Node_Tree); + + Project.Directory.Display_Name := + Directory_Of (From_Project_Node, From_Project_Node_Tree); + Get_Name_String (Project.Directory.Display_Name); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Project.Directory.Name := Name_Find; + + Project.Extended_By := Extended_By; + + Add_Attributes + (Project, + Name, + Name_Id (Project.Directory.Name), + In_Tree, + Project.Decl, + Prj.Attr.Attribute_First, + Project_Level => True); + + Process_Imported_Projects (Imported, Limited_With => False); + + Declaration_Node := + Project_Declaration_Of + (From_Project_Node, From_Project_Node_Tree); + + Recursive_Process + (In_Tree => In_Tree, + Project => Project.Extends, + Flags => Flags, + From_Project_Node => Extended_Project_Of + (Declaration_Node, + From_Project_Node_Tree), + From_Project_Node_Tree => From_Project_Node_Tree, + Extended_By => Project); + + Process_Declarative_Items + (Project => Project, + In_Tree => In_Tree, + Flags => Flags, + From_Project_Node => From_Project_Node, + From_Project_Node_Tree => From_Project_Node_Tree, + Pkg => No_Package, + Item => First_Declarative_Item_Of + (Declaration_Node, + From_Project_Node_Tree)); + + -- If it is an extending project, inherit all packages + -- from the extended project that are not explicitly defined + -- or renamed. Also inherit the languages, if attribute Languages + -- is not explicitly defined. + + if Project.Extends /= No_Project then + declare + Extended_Pkg : Package_Id; + Current_Pkg : Package_Id; + Element : Package_Element; + First : constant Package_Id := + Project.Decl.Packages; + Attribute1 : Variable_Id; + Attribute2 : Variable_Id; + Attr_Value1 : Variable; + Attr_Value2 : Variable; + + begin + Extended_Pkg := Project.Extends.Decl.Packages; + while Extended_Pkg /= No_Package loop + Element := In_Tree.Packages.Table (Extended_Pkg); + + Current_Pkg := First; + while Current_Pkg /= No_Package + and then In_Tree.Packages.Table (Current_Pkg).Name /= + Element.Name + loop + Current_Pkg := + In_Tree.Packages.Table (Current_Pkg).Next; + end loop; + + if Current_Pkg = No_Package then + Package_Table.Increment_Last + (In_Tree.Packages); + Current_Pkg := Package_Table.Last (In_Tree.Packages); + In_Tree.Packages.Table (Current_Pkg) := + (Name => Element.Name, + Decl => No_Declarations, + Parent => No_Package, + Next => Project.Decl.Packages); + Project.Decl.Packages := Current_Pkg; + Copy_Package_Declarations + (From => Element.Decl, + To => + In_Tree.Packages.Table (Current_Pkg).Decl, + New_Loc => No_Location, + Restricted => True, + In_Tree => In_Tree); + end if; + + Extended_Pkg := Element.Next; + end loop; + + -- Check if attribute Languages is declared in the + -- extending project. + + Attribute1 := Project.Decl.Attributes; + while Attribute1 /= No_Variable loop + Attr_Value1 := In_Tree.Variable_Elements. + Table (Attribute1); + exit when Attr_Value1.Name = Snames.Name_Languages; + Attribute1 := Attr_Value1.Next; + end loop; + + if Attribute1 = No_Variable or else + Attr_Value1.Value.Default + then + -- Attribute Languages is not declared in the extending + -- project. Check if it is declared in the project being + -- extended. + + Attribute2 := Project.Extends.Decl.Attributes; + while Attribute2 /= No_Variable loop + Attr_Value2 := In_Tree.Variable_Elements. + Table (Attribute2); + exit when Attr_Value2.Name = Snames.Name_Languages; + Attribute2 := Attr_Value2.Next; + end loop; + + if Attribute2 /= No_Variable and then + not Attr_Value2.Value.Default + then + -- As attribute Languages is declared in the project + -- being extended, copy its value for the extending + -- project. + + if Attribute1 = No_Variable then + Variable_Element_Table.Increment_Last + (In_Tree.Variable_Elements); + Attribute1 := Variable_Element_Table.Last + (In_Tree.Variable_Elements); + Attr_Value1.Next := Project.Decl.Attributes; + Project.Decl.Attributes := Attribute1; + end if; + + Attr_Value1.Name := Snames.Name_Languages; + Attr_Value1.Value := Attr_Value2.Value; + In_Tree.Variable_Elements.Table + (Attribute1) := Attr_Value1; + end if; + end if; + end; + end if; + + Process_Imported_Projects (Imported, Limited_With => True); + end; + end if; + end Recursive_Process; + +end Prj.Proc; diff --git a/gcc/ada/prj-proc.ads b/gcc/ada/prj-proc.ads new file mode 100644 index 000000000..4257c9004 --- /dev/null +++ b/gcc/ada/prj-proc.ads @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . P R O C -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 convert a project file tree (see prj-tree.ads) to +-- project file data structures (see prj.ads), taking into account the +-- environment (external references). + +with Prj.Tree; use Prj.Tree; + +package Prj.Proc is + + procedure Process_Project_Tree_Phase_1 + (In_Tree : Project_Tree_Ref; + Project : out Project_Id; + Success : out Boolean; + From_Project_Node : Project_Node_Id; + From_Project_Node_Tree : Project_Node_Tree_Ref; + Flags : Prj.Processing_Flags; + Reset_Tree : Boolean := True); + -- Process a project tree (ie the direct resulting of parsing a .gpr file) + -- based on the current external references. + -- + -- The result of this phase_1 is a partial project tree (Project) where + -- only a few fields have been initialized (in particular the list of + -- languages). These are the fields that are necessary to run gprconfig if + -- needed to automatically generate a configuration file. This first phase + -- of the processing does not require a configuration file. + -- + -- When Reset_Tree is True, all the project data are removed from the + -- project table before processing. + + procedure Process_Project_Tree_Phase_2 + (In_Tree : Project_Tree_Ref; + Project : Project_Id; + Success : out Boolean; + From_Project_Node : Project_Node_Id; + From_Project_Node_Tree : Project_Node_Tree_Ref; + Flags : Processing_Flags); + -- Perform the second phase of the processing, filling the rest of the + -- project with the information extracted from the project tree. This phase + -- requires that the configuration file has already been parsed (in fact + -- we currently assume that the contents of the configuration file has + -- been included in Project through Confgpr.Apply_Config_File). The + -- parameters are the same as for phase_1, with the addition of: + + procedure Process + (In_Tree : Project_Tree_Ref; + Project : out Project_Id; + Success : out Boolean; + From_Project_Node : Project_Node_Id; + From_Project_Node_Tree : Project_Node_Tree_Ref; + Flags : Processing_Flags; + Reset_Tree : Boolean := True); + -- Performs the two phases of the processing + +end Prj.Proc; diff --git a/gcc/ada/prj-strt.adb b/gcc/ada/prj-strt.adb new file mode 100644 index 000000000..271a913e7 --- /dev/null +++ b/gcc/ada/prj-strt.adb @@ -0,0 +1,1556 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . S T R T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Err_Vars; use Err_Vars; +with Prj.Attr; use Prj.Attr; +with Prj.Err; use Prj.Err; +with Snames; +with Table; +with Uintp; use Uintp; + +package body Prj.Strt is + + Buffer : String_Access; + Buffer_Last : Natural := 0; + + type Choice_String is record + The_String : Name_Id; + Already_Used : Boolean := False; + end record; + -- The string of a case label, and an indication that it has already + -- been used (to avoid duplicate case labels). + + Choices_Initial : constant := 10; + Choices_Increment : constant := 100; + -- These should be in alloc.ads + + Choice_Node_Low_Bound : constant := 0; + Choice_Node_High_Bound : constant := 099_999_999; + -- In practice, infinite + + type Choice_Node_Id is + range Choice_Node_Low_Bound .. Choice_Node_High_Bound; + + First_Choice_Node_Id : constant Choice_Node_Id := + Choice_Node_Low_Bound; + + package Choices is + new Table.Table + (Table_Component_Type => Choice_String, + Table_Index_Type => Choice_Node_Id'Base, + Table_Low_Bound => First_Choice_Node_Id, + Table_Initial => Choices_Initial, + Table_Increment => Choices_Increment, + Table_Name => "Prj.Strt.Choices"); + -- Used to store the case labels and check that there is no duplicate + + package Choice_Lasts is + new Table.Table + (Table_Component_Type => Choice_Node_Id, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Prj.Strt.Choice_Lasts"); + -- Used to store the indexes of the choices in table Choices, to + -- distinguish nested case constructions. + + Choice_First : Choice_Node_Id := 0; + -- Index in table Choices of the first case label of the current + -- case construction. Zero means no current case construction. + + type Name_Location is record + Name : Name_Id := No_Name; + Location : Source_Ptr := No_Location; + end record; + -- Store the identifier and the location of a simple name + + package Names is + new Table.Table + (Table_Component_Type => Name_Location, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Prj.Strt.Names"); + -- Used to accumulate the single names of a name + + procedure Add (This_String : Name_Id); + -- Add a string to the case label list, indicating that it has not + -- yet been used. + + procedure Add_To_Names (NL : Name_Location); + -- Add one single names to table Names + + procedure External_Reference + (In_Tree : Project_Node_Tree_Ref; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + External_Value : out Project_Node_Id; + Expr_Kind : in out Variable_Kind; + Flags : Processing_Flags); + -- Parse an external reference. Current token is "external" + + procedure Attribute_Reference + (In_Tree : Project_Node_Tree_Ref; + Reference : out Project_Node_Id; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Flags : Processing_Flags); + -- Parse an attribute reference. Current token is an apostrophe + + procedure Terms + (In_Tree : Project_Node_Tree_Ref; + Term : out Project_Node_Id; + Expr_Kind : in out Variable_Kind; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Optional_Index : Boolean; + Flags : Processing_Flags); + -- Recursive procedure to parse one term or several terms concatenated + -- using "&". + + --------- + -- Add -- + --------- + + procedure Add (This_String : Name_Id) is + begin + Choices.Increment_Last; + Choices.Table (Choices.Last) := + (The_String => This_String, + Already_Used => False); + end Add; + + ------------------ + -- Add_To_Names -- + ------------------ + + procedure Add_To_Names (NL : Name_Location) is + begin + Names.Increment_Last; + Names.Table (Names.Last) := NL; + end Add_To_Names; + + ------------------------- + -- Attribute_Reference -- + ------------------------- + + procedure Attribute_Reference + (In_Tree : Project_Node_Tree_Ref; + Reference : out Project_Node_Id; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Flags : Processing_Flags) + is + Current_Attribute : Attribute_Node_Id := First_Attribute; + + begin + -- Declare the node of the attribute reference + + Reference := + Default_Project_Node + (Of_Kind => N_Attribute_Reference, In_Tree => In_Tree); + Set_Location_Of (Reference, In_Tree, To => Token_Ptr); + Scan (In_Tree); -- past apostrophe + + -- Body may be an attribute name + + if Token = Tok_Body then + Token := Tok_Identifier; + Token_Name := Snames.Name_Body; + end if; + + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + Set_Name_Of (Reference, In_Tree, To => Token_Name); + + -- Check if the identifier is one of the attribute identifiers in the + -- context (package or project level attributes). + + Current_Attribute := + Attribute_Node_Id_Of (Token_Name, Starting_At => First_Attribute); + + -- If the identifier is not allowed, report an error + + if Current_Attribute = Empty_Attribute then + Error_Msg_Name_1 := Token_Name; + Error_Msg (Flags, "unknown attribute %%", Token_Ptr); + Reference := Empty_Node; + + -- Scan past the attribute name + + Scan (In_Tree); + + else + -- Give its characteristics to this attribute reference + + Set_Project_Node_Of (Reference, In_Tree, To => Current_Project); + Set_Package_Node_Of (Reference, In_Tree, To => Current_Package); + Set_Expression_Kind_Of + (Reference, In_Tree, To => Variable_Kind_Of (Current_Attribute)); + Set_Case_Insensitive + (Reference, In_Tree, + To => Attribute_Kind_Of (Current_Attribute) in + All_Case_Insensitive_Associative_Array); + + -- Scan past the attribute name + + Scan (In_Tree); + + -- If the attribute is an associative array, get the index + + if Attribute_Kind_Of (Current_Attribute) /= Single then + Expect (Tok_Left_Paren, "`(`"); + + if Token = Tok_Left_Paren then + Scan (In_Tree); + + if Others_Allowed_For (Current_Attribute) + and then Token = Tok_Others + then + Set_Associative_Array_Index_Of + (Reference, In_Tree, To => All_Other_Names); + Scan (In_Tree); + + else + if Others_Allowed_For (Current_Attribute) then + Expect + (Tok_String_Literal, "literal string or others"); + else + Expect (Tok_String_Literal, "literal string"); + end if; + + if Token = Tok_String_Literal then + Set_Associative_Array_Index_Of + (Reference, In_Tree, To => Token_Name); + Scan (In_Tree); + end if; + end if; + end if; + + Expect (Tok_Right_Paren, "`)`"); + + if Token = Tok_Right_Paren then + Scan (In_Tree); + end if; + end if; + end if; + + -- Change name of obsolete attributes + + if Present (Reference) then + case Name_Of (Reference, In_Tree) is + when Snames.Name_Specification => + Set_Name_Of (Reference, In_Tree, To => Snames.Name_Spec); + + when Snames.Name_Specification_Suffix => + Set_Name_Of + (Reference, In_Tree, To => Snames.Name_Spec_Suffix); + + when Snames.Name_Implementation => + Set_Name_Of (Reference, In_Tree, To => Snames.Name_Body); + + when Snames.Name_Implementation_Suffix => + Set_Name_Of + (Reference, In_Tree, To => Snames.Name_Body_Suffix); + + when others => + null; + end case; + end if; + end if; + end Attribute_Reference; + + --------------------------- + -- End_Case_Construction -- + --------------------------- + + procedure End_Case_Construction + (Check_All_Labels : Boolean; + Case_Location : Source_Ptr; + Flags : Processing_Flags) + is + Non_Used : Natural := 0; + First_Non_Used : Choice_Node_Id := First_Choice_Node_Id; + begin + -- First, if Check_All_Labels is True, check if all values + -- of the string type have been used. + + if Check_All_Labels then + for Choice in Choice_First .. Choices.Last loop + if not Choices.Table (Choice).Already_Used then + Non_Used := Non_Used + 1; + + if Non_Used = 1 then + First_Non_Used := Choice; + end if; + end if; + end loop; + + -- If only one is not used, report a single warning for this value + + if Non_Used = 1 then + Error_Msg_Name_1 := Choices.Table (First_Non_Used).The_String; + Error_Msg (Flags, "?value %% is not used as label", Case_Location); + + -- If several are not used, report a warning for each one of them + + elsif Non_Used > 1 then + Error_Msg + (Flags, "?the following values are not used as labels:", + Case_Location); + + for Choice in First_Non_Used .. Choices.Last loop + if not Choices.Table (Choice).Already_Used then + Error_Msg_Name_1 := Choices.Table (Choice).The_String; + Error_Msg (Flags, "\?%%", Case_Location); + end if; + end loop; + end if; + end if; + + -- If this is the only case construction, empty the tables + + if Choice_Lasts.Last = 1 then + Choice_Lasts.Set_Last (0); + Choices.Set_Last (First_Choice_Node_Id); + Choice_First := 0; + + elsif Choice_Lasts.Last = 2 then + + -- This is the second case construction, set the tables to the first + + Choice_Lasts.Set_Last (1); + Choices.Set_Last (Choice_Lasts.Table (1)); + Choice_First := 1; + + else + -- This is the 3rd or more case construction, set the tables to the + -- previous one. + + Choice_Lasts.Decrement_Last; + Choices.Set_Last (Choice_Lasts.Table (Choice_Lasts.Last)); + Choice_First := Choice_Lasts.Table (Choice_Lasts.Last - 1) + 1; + end if; + end End_Case_Construction; + + ------------------------ + -- External_Reference -- + ------------------------ + + procedure External_Reference + (In_Tree : Project_Node_Tree_Ref; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + External_Value : out Project_Node_Id; + Expr_Kind : in out Variable_Kind; + Flags : Processing_Flags) + is + Field_Id : Project_Node_Id := Empty_Node; + Ext_List : Boolean := False; + + begin + External_Value := + Default_Project_Node + (Of_Kind => N_External_Value, + In_Tree => In_Tree); + Set_Location_Of (External_Value, In_Tree, To => Token_Ptr); + + -- The current token is either external or external_as_list + + Ext_List := Token = Tok_External_As_List; + Scan (In_Tree); + + if Ext_List then + Set_Expression_Kind_Of (External_Value, In_Tree, To => List); + else + Set_Expression_Kind_Of (External_Value, In_Tree, To => Single); + end if; + + if Expr_Kind = Undefined then + if Ext_List then + Expr_Kind := List; + else + Expr_Kind := Single; + end if; + end if; + + Expect (Tok_Left_Paren, "`(`"); + + -- Scan past the left parenthesis + + if Token = Tok_Left_Paren then + Scan (In_Tree); + end if; + + -- Get the name of the external reference + + Expect (Tok_String_Literal, "literal string"); + + if Token = Tok_String_Literal then + Field_Id := + Default_Project_Node + (Of_Kind => N_Literal_String, + In_Tree => In_Tree, + And_Expr_Kind => Single); + Set_String_Value_Of (Field_Id, In_Tree, To => Token_Name); + Set_External_Reference_Of (External_Value, In_Tree, To => Field_Id); + + -- Scan past the first argument + + Scan (In_Tree); + + case Token is + + when Tok_Right_Paren => + if Ext_List then + Error_Msg (Flags, "`,` expected", Token_Ptr); + end if; + + Scan (In_Tree); -- scan past right paren + + when Tok_Comma => + Scan (In_Tree); -- scan past comma + + -- Get the string expression for the default + + declare + Loc : constant Source_Ptr := Token_Ptr; + + begin + Parse_Expression + (In_Tree => In_Tree, + Expression => Field_Id, + Flags => Flags, + Current_Project => Current_Project, + Current_Package => Current_Package, + Optional_Index => False); + + if Expression_Kind_Of (Field_Id, In_Tree) = List then + Error_Msg + (Flags, "expression must be a single string", Loc); + else + Set_External_Default_Of + (External_Value, In_Tree, To => Field_Id); + end if; + end; + + Expect (Tok_Right_Paren, "`)`"); + + if Token = Tok_Right_Paren then + Scan (In_Tree); -- scan past right paren + end if; + + when others => + if Ext_List then + Error_Msg (Flags, "`,` expected", Token_Ptr); + else + Error_Msg (Flags, "`,` or `)` expected", Token_Ptr); + end if; + end case; + end if; + end External_Reference; + + ----------------------- + -- Parse_Choice_List -- + ----------------------- + + procedure Parse_Choice_List + (In_Tree : Project_Node_Tree_Ref; + First_Choice : out Project_Node_Id; + Flags : Processing_Flags) + is + Current_Choice : Project_Node_Id := Empty_Node; + Next_Choice : Project_Node_Id := Empty_Node; + Choice_String : Name_Id := No_Name; + Found : Boolean := False; + + begin + -- Declare the node of the first choice + + First_Choice := + Default_Project_Node + (Of_Kind => N_Literal_String, + In_Tree => In_Tree, + And_Expr_Kind => Single); + + -- Initially Current_Choice is the same as First_Choice + + Current_Choice := First_Choice; + + loop + Expect (Tok_String_Literal, "literal string"); + exit when Token /= Tok_String_Literal; + Set_Location_Of (Current_Choice, In_Tree, To => Token_Ptr); + Choice_String := Token_Name; + + -- Give the string value to the current choice + + Set_String_Value_Of (Current_Choice, In_Tree, To => Choice_String); + + -- Check if the label is part of the string type and if it has not + -- been already used. + + Found := False; + for Choice in Choice_First .. Choices.Last loop + if Choices.Table (Choice).The_String = Choice_String then + + -- This label is part of the string type + + Found := True; + + if Choices.Table (Choice).Already_Used then + + -- But it has already appeared in a choice list for this + -- case construction so report an error. + + Error_Msg_Name_1 := Choice_String; + Error_Msg (Flags, "duplicate case label %%", Token_Ptr); + + else + Choices.Table (Choice).Already_Used := True; + end if; + + exit; + end if; + end loop; + + -- If the label is not part of the string list, report an error + + if not Found then + Error_Msg_Name_1 := Choice_String; + Error_Msg (Flags, "illegal case label %%", Token_Ptr); + end if; + + -- Scan past the label + + Scan (In_Tree); + + -- If there is no '|', we are done + + if Token = Tok_Vertical_Bar then + + -- Otherwise, declare the node of the next choice, link it to + -- Current_Choice and set Current_Choice to this new node. + + Next_Choice := + Default_Project_Node + (Of_Kind => N_Literal_String, + In_Tree => In_Tree, + And_Expr_Kind => Single); + Set_Next_Literal_String + (Current_Choice, In_Tree, To => Next_Choice); + Current_Choice := Next_Choice; + Scan (In_Tree); + else + exit; + end if; + end loop; + end Parse_Choice_List; + + ---------------------- + -- Parse_Expression -- + ---------------------- + + procedure Parse_Expression + (In_Tree : Project_Node_Tree_Ref; + Expression : out Project_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Optional_Index : Boolean; + Flags : Processing_Flags) + is + First_Term : Project_Node_Id := Empty_Node; + Expression_Kind : Variable_Kind := Undefined; + + begin + -- Declare the node of the expression + + Expression := + Default_Project_Node (Of_Kind => N_Expression, In_Tree => In_Tree); + Set_Location_Of (Expression, In_Tree, To => Token_Ptr); + + -- Parse the term or terms of the expression + + Terms (In_Tree => In_Tree, + Term => First_Term, + Expr_Kind => Expression_Kind, + Flags => Flags, + Current_Project => Current_Project, + Current_Package => Current_Package, + Optional_Index => Optional_Index); + + -- Set the first term and the expression kind + + Set_First_Term (Expression, In_Tree, To => First_Term); + Set_Expression_Kind_Of (Expression, In_Tree, To => Expression_Kind); + end Parse_Expression; + + ---------------------------- + -- Parse_String_Type_List -- + ---------------------------- + + procedure Parse_String_Type_List + (In_Tree : Project_Node_Tree_Ref; + First_String : out Project_Node_Id; + Flags : Processing_Flags) + is + Last_String : Project_Node_Id := Empty_Node; + Next_String : Project_Node_Id := Empty_Node; + String_Value : Name_Id := No_Name; + + begin + -- Declare the node of the first string + + First_String := + Default_Project_Node + (Of_Kind => N_Literal_String, + In_Tree => In_Tree, + And_Expr_Kind => Single); + + -- Initially, Last_String is the same as First_String + + Last_String := First_String; + + loop + Expect (Tok_String_Literal, "literal string"); + exit when Token /= Tok_String_Literal; + String_Value := Token_Name; + + -- Give its string value to Last_String + + Set_String_Value_Of (Last_String, In_Tree, To => String_Value); + Set_Location_Of (Last_String, In_Tree, To => Token_Ptr); + + -- Now, check if the string is already part of the string type + + declare + Current : Project_Node_Id := First_String; + + begin + while Current /= Last_String loop + if String_Value_Of (Current, In_Tree) = String_Value then + + -- This is a repetition, report an error + + Error_Msg_Name_1 := String_Value; + Error_Msg (Flags, "duplicate value %% in type", Token_Ptr); + exit; + end if; + + Current := Next_Literal_String (Current, In_Tree); + end loop; + end; + + -- Scan past the literal string + + Scan (In_Tree); + + -- If there is no comma following the literal string, we are done + + if Token /= Tok_Comma then + exit; + + else + -- Declare the next string, link it to Last_String and set + -- Last_String to its node. + + Next_String := + Default_Project_Node + (Of_Kind => N_Literal_String, + In_Tree => In_Tree, + And_Expr_Kind => Single); + Set_Next_Literal_String (Last_String, In_Tree, To => Next_String); + Last_String := Next_String; + Scan (In_Tree); + end if; + end loop; + end Parse_String_Type_List; + + ------------------------------ + -- Parse_Variable_Reference -- + ------------------------------ + + procedure Parse_Variable_Reference + (In_Tree : Project_Node_Tree_Ref; + Variable : out Project_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Flags : Processing_Flags) + is + Current_Variable : Project_Node_Id := Empty_Node; + + The_Package : Project_Node_Id := Current_Package; + The_Project : Project_Node_Id := Current_Project; + + Specified_Project : Project_Node_Id := Empty_Node; + Specified_Package : Project_Node_Id := Empty_Node; + Look_For_Variable : Boolean := True; + First_Attribute : Attribute_Node_Id := Empty_Attribute; + Variable_Name : Name_Id; + + begin + Names.Init; + + loop + Expect (Tok_Identifier, "identifier"); + + if Token /= Tok_Identifier then + Look_For_Variable := False; + exit; + end if; + + Add_To_Names (NL => (Name => Token_Name, Location => Token_Ptr)); + Scan (In_Tree); + exit when Token /= Tok_Dot; + Scan (In_Tree); + end loop; + + if Look_For_Variable then + + if Token = Tok_Apostrophe then + + -- Attribute reference + + case Names.Last is + when 0 => + + -- Cannot happen + + null; + + when 1 => + -- This may be a project name or a package name. + -- Project name have precedence. + + -- First, look if it can be a package name + + First_Attribute := + First_Attribute_Of + (Package_Node_Id_Of (Names.Table (1).Name)); + + -- Now, look if it can be a project name + + if Names.Table (1).Name = + Name_Of (Current_Project, In_Tree) + then + The_Project := Current_Project; + + else + The_Project := + Imported_Or_Extended_Project_Of + (Current_Project, In_Tree, Names.Table (1).Name); + end if; + + if No (The_Project) then + + -- If it is neither a project name nor a package name, + -- report an error. + + if First_Attribute = Empty_Attribute then + Error_Msg_Name_1 := Names.Table (1).Name; + Error_Msg (Flags, "unknown project %", + Names.Table (1).Location); + First_Attribute := Attribute_First; + + else + -- If it is a package name, check if the package has + -- already been declared in the current project. + + The_Package := + First_Package_Of (Current_Project, In_Tree); + + while Present (The_Package) + and then Name_Of (The_Package, In_Tree) /= + Names.Table (1).Name + loop + The_Package := + Next_Package_In_Project (The_Package, In_Tree); + end loop; + + -- If it has not been already declared, report an + -- error. + + if No (The_Package) then + Error_Msg_Name_1 := Names.Table (1).Name; + Error_Msg (Flags, "package % not yet defined", + Names.Table (1).Location); + end if; + end if; + + else + -- It is a project name + + First_Attribute := Attribute_First; + The_Package := Empty_Node; + end if; + + when others => + + -- We have either a project name made of several simple + -- names (long project), or a project name (short project) + -- followed by a package name. The long project name has + -- precedence. + + declare + Short_Project : Name_Id; + Long_Project : Name_Id; + + begin + -- Clear the Buffer + + Buffer_Last := 0; + + -- Get the name of the short project + + for Index in 1 .. Names.Last - 1 loop + Add_To_Buffer + (Get_Name_String (Names.Table (Index).Name), + Buffer, Buffer_Last); + + if Index /= Names.Last - 1 then + Add_To_Buffer (".", Buffer, Buffer_Last); + end if; + end loop; + + Name_Len := Buffer_Last; + Name_Buffer (1 .. Buffer_Last) := + Buffer (1 .. Buffer_Last); + Short_Project := Name_Find; + + -- Now, add the last simple name to get the name of the + -- long project. + + Add_To_Buffer (".", Buffer, Buffer_Last); + Add_To_Buffer + (Get_Name_String (Names.Table (Names.Last).Name), + Buffer, Buffer_Last); + Name_Len := Buffer_Last; + Name_Buffer (1 .. Buffer_Last) := + Buffer (1 .. Buffer_Last); + Long_Project := Name_Find; + + -- Check if the long project is imported or extended + + if Long_Project = Name_Of (Current_Project, In_Tree) then + The_Project := Current_Project; + + else + The_Project := + Imported_Or_Extended_Project_Of + (Current_Project, + In_Tree, + Long_Project); + end if; + + -- If the long project exists, then this is the prefix + -- of the attribute. + + if Present (The_Project) then + First_Attribute := Attribute_First; + The_Package := Empty_Node; + + else + -- Otherwise, check if the short project is imported + -- or extended. + + if Short_Project = + Name_Of (Current_Project, In_Tree) + then + The_Project := Current_Project; + + else + The_Project := Imported_Or_Extended_Project_Of + (Current_Project, In_Tree, + Short_Project); + end if; + + -- If short project does not exist, report an error + + if No (The_Project) then + Error_Msg_Name_1 := Long_Project; + Error_Msg_Name_2 := Short_Project; + Error_Msg (Flags, "unknown projects % or %", + Names.Table (1).Location); + The_Package := Empty_Node; + First_Attribute := Attribute_First; + + else + -- Now, we check if the package has been declared + -- in this project. + + The_Package := + First_Package_Of (The_Project, In_Tree); + while Present (The_Package) + and then Name_Of (The_Package, In_Tree) /= + Names.Table (Names.Last).Name + loop + The_Package := + Next_Package_In_Project (The_Package, In_Tree); + end loop; + + -- If it has not, then we report an error + + if No (The_Package) then + Error_Msg_Name_1 := + Names.Table (Names.Last).Name; + Error_Msg_Name_2 := Short_Project; + Error_Msg (Flags, + "package % not declared in project %", + Names.Table (Names.Last).Location); + First_Attribute := Attribute_First; + + else + -- Otherwise, we have the correct project and + -- package. + + First_Attribute := + First_Attribute_Of + (Package_Id_Of (The_Package, In_Tree)); + end if; + end if; + end if; + end; + end case; + + Attribute_Reference + (In_Tree, + Variable, + Flags => Flags, + Current_Project => The_Project, + Current_Package => The_Package, + First_Attribute => First_Attribute); + return; + end if; + end if; + + Variable := + Default_Project_Node + (Of_Kind => N_Variable_Reference, In_Tree => In_Tree); + + if Look_For_Variable then + case Names.Last is + when 0 => + + -- Cannot happen (so why null instead of raise PE???) + + null; + + when 1 => + + -- Simple variable name + + Set_Name_Of (Variable, In_Tree, To => Names.Table (1).Name); + + when 2 => + + -- Variable name with a simple name prefix that can be + -- a project name or a package name. Project names have + -- priority over package names. + + Set_Name_Of (Variable, In_Tree, To => Names.Table (2).Name); + + -- Check if it can be a package name + + The_Package := First_Package_Of (Current_Project, In_Tree); + + while Present (The_Package) + and then Name_Of (The_Package, In_Tree) /= + Names.Table (1).Name + loop + The_Package := + Next_Package_In_Project (The_Package, In_Tree); + end loop; + + -- Now look for a possible project name + + The_Project := Imported_Or_Extended_Project_Of + (Current_Project, In_Tree, Names.Table (1).Name); + + if Present (The_Project) then + Specified_Project := The_Project; + + elsif No (The_Package) then + Error_Msg_Name_1 := Names.Table (1).Name; + Error_Msg (Flags, "unknown package or project %", + Names.Table (1).Location); + Look_For_Variable := False; + + else + Specified_Package := The_Package; + end if; + + when others => + + -- Variable name with a prefix that is either a project name + -- made of several simple names, or a project name followed + -- by a package name. + + Set_Name_Of + (Variable, In_Tree, To => Names.Table (Names.Last).Name); + + declare + Short_Project : Name_Id; + Long_Project : Name_Id; + + begin + -- First, we get the two possible project names + + -- Clear the buffer + + Buffer_Last := 0; + + -- Add all the simple names, except the last two + + for Index in 1 .. Names.Last - 2 loop + Add_To_Buffer + (Get_Name_String (Names.Table (Index).Name), + Buffer, Buffer_Last); + + if Index /= Names.Last - 2 then + Add_To_Buffer (".", Buffer, Buffer_Last); + end if; + end loop; + + Name_Len := Buffer_Last; + Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last); + Short_Project := Name_Find; + + -- Add the simple name before the name of the variable + + Add_To_Buffer (".", Buffer, Buffer_Last); + Add_To_Buffer + (Get_Name_String (Names.Table (Names.Last - 1).Name), + Buffer, Buffer_Last); + Name_Len := Buffer_Last; + Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last); + Long_Project := Name_Find; + + -- Check if the prefix is the name of an imported or + -- extended project. + + The_Project := Imported_Or_Extended_Project_Of + (Current_Project, In_Tree, Long_Project); + + if Present (The_Project) then + Specified_Project := The_Project; + + else + -- Now check if the prefix may be a project name followed + -- by a package name. + + -- First check for a possible project name + + The_Project := + Imported_Or_Extended_Project_Of + (Current_Project, In_Tree, Short_Project); + + if No (The_Project) then + -- Unknown prefix, report an error + + Error_Msg_Name_1 := Long_Project; + Error_Msg_Name_2 := Short_Project; + Error_Msg + (Flags, "unknown projects % or %", + Names.Table (1).Location); + Look_For_Variable := False; + + else + Specified_Project := The_Project; + + -- Now look for the package in this project + + The_Package := First_Package_Of (The_Project, In_Tree); + + while Present (The_Package) + and then Name_Of (The_Package, In_Tree) /= + Names.Table (Names.Last - 1).Name + loop + The_Package := + Next_Package_In_Project (The_Package, In_Tree); + end loop; + + if No (The_Package) then + + -- The package does not exist, report an error + + Error_Msg_Name_1 := Names.Table (2).Name; + Error_Msg (Flags, "unknown package %", + Names.Table (Names.Last - 1).Location); + Look_For_Variable := False; + + else + Specified_Package := The_Package; + end if; + end if; + end if; + end; + end case; + end if; + + if Look_For_Variable then + Variable_Name := Name_Of (Variable, In_Tree); + Set_Project_Node_Of (Variable, In_Tree, To => Specified_Project); + Set_Package_Node_Of (Variable, In_Tree, To => Specified_Package); + + if Present (Specified_Project) then + The_Project := Specified_Project; + else + The_Project := Current_Project; + end if; + + Current_Variable := Empty_Node; + + -- Look for this variable + + -- If a package was specified, check if the variable has been + -- declared in this package. + + if Present (Specified_Package) then + Current_Variable := + First_Variable_Of (Specified_Package, In_Tree); + while Present (Current_Variable) + and then + Name_Of (Current_Variable, In_Tree) /= Variable_Name + loop + Current_Variable := Next_Variable (Current_Variable, In_Tree); + end loop; + + else + -- Otherwise, if no project has been specified and we are in + -- a package, first check if the variable has been declared in + -- the package. + + if No (Specified_Project) + and then Present (Current_Package) + then + Current_Variable := + First_Variable_Of (Current_Package, In_Tree); + while Present (Current_Variable) + and then Name_Of (Current_Variable, In_Tree) /= Variable_Name + loop + Current_Variable := + Next_Variable (Current_Variable, In_Tree); + end loop; + end if; + + -- If we have not found the variable in the package, check if the + -- variable has been declared in the project, or in any of its + -- ancestors. + + if No (Current_Variable) then + declare + Proj : Project_Node_Id := The_Project; + + begin + loop + Current_Variable := First_Variable_Of (Proj, In_Tree); + while + Present (Current_Variable) + and then + Name_Of (Current_Variable, In_Tree) /= Variable_Name + loop + Current_Variable := + Next_Variable (Current_Variable, In_Tree); + end loop; + + exit when Present (Current_Variable); + + Proj := Parent_Project_Of (Proj, In_Tree); + + Set_Project_Node_Of (Variable, In_Tree, To => Proj); + + exit when No (Proj); + end loop; + end; + end if; + end if; + + -- If the variable was not found, report an error + + if No (Current_Variable) then + Error_Msg_Name_1 := Variable_Name; + Error_Msg + (Flags, "unknown variable %", Names.Table (Names.Last).Location); + end if; + end if; + + if Present (Current_Variable) then + Set_Expression_Kind_Of + (Variable, In_Tree, + To => Expression_Kind_Of (Current_Variable, In_Tree)); + + if Kind_Of (Current_Variable, In_Tree) = + N_Typed_Variable_Declaration + then + Set_String_Type_Of + (Variable, In_Tree, + To => String_Type_Of (Current_Variable, In_Tree)); + end if; + end if; + + -- If the variable is followed by a left parenthesis, report an error + -- but attempt to scan the index. + + if Token = Tok_Left_Paren then + Error_Msg + (Flags, "\variables cannot be associative arrays", Token_Ptr); + Scan (In_Tree); + Expect (Tok_String_Literal, "literal string"); + + if Token = Tok_String_Literal then + Scan (In_Tree); + Expect (Tok_Right_Paren, "`)`"); + + if Token = Tok_Right_Paren then + Scan (In_Tree); + end if; + end if; + end if; + end Parse_Variable_Reference; + + --------------------------------- + -- Start_New_Case_Construction -- + --------------------------------- + + procedure Start_New_Case_Construction + (In_Tree : Project_Node_Tree_Ref; + String_Type : Project_Node_Id) + is + Current_String : Project_Node_Id; + + begin + -- Set Choice_First, depending on whether this is the first case + -- construction or not. + + if Choice_First = 0 then + Choice_First := 1; + Choices.Set_Last (First_Choice_Node_Id); + else + Choice_First := Choices.Last + 1; + end if; + + -- Add the literal of the string type to the Choices table + + if Present (String_Type) then + Current_String := First_Literal_String (String_Type, In_Tree); + while Present (Current_String) loop + Add (This_String => String_Value_Of (Current_String, In_Tree)); + Current_String := Next_Literal_String (Current_String, In_Tree); + end loop; + end if; + + -- Set the value of the last choice in table Choice_Lasts + + Choice_Lasts.Increment_Last; + Choice_Lasts.Table (Choice_Lasts.Last) := Choices.Last; + end Start_New_Case_Construction; + + ----------- + -- Terms -- + ----------- + + procedure Terms + (In_Tree : Project_Node_Tree_Ref; + Term : out Project_Node_Id; + Expr_Kind : in out Variable_Kind; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Optional_Index : Boolean; + Flags : Processing_Flags) + is + Next_Term : Project_Node_Id := Empty_Node; + Term_Id : Project_Node_Id := Empty_Node; + Current_Expression : Project_Node_Id := Empty_Node; + Next_Expression : Project_Node_Id := Empty_Node; + Current_Location : Source_Ptr := No_Location; + Reference : Project_Node_Id := Empty_Node; + + begin + -- Declare a new node for the term + + Term := Default_Project_Node (Of_Kind => N_Term, In_Tree => In_Tree); + Set_Location_Of (Term, In_Tree, To => Token_Ptr); + + case Token is + when Tok_Left_Paren => + + -- If we have a left parenthesis and we don't know the expression + -- kind, then this is a string list. + + case Expr_Kind is + when Undefined => + Expr_Kind := List; + + when List => + null; + + when Single => + + -- If we already know that this is a single string, report + -- an error, but set the expression kind to string list to + -- avoid several errors. + + Expr_Kind := List; + Error_Msg + (Flags, "literal string list cannot appear in a string", + Token_Ptr); + end case; + + -- Declare a new node for this literal string list + + Term_Id := Default_Project_Node + (Of_Kind => N_Literal_String_List, + In_Tree => In_Tree, + And_Expr_Kind => List); + Set_Current_Term (Term, In_Tree, To => Term_Id); + Set_Location_Of (Term, In_Tree, To => Token_Ptr); + + -- Scan past the left parenthesis + + Scan (In_Tree); + + -- If the left parenthesis is immediately followed by a right + -- parenthesis, the literal string list is empty. + + if Token = Tok_Right_Paren then + Scan (In_Tree); + + else + -- Otherwise parse the expression(s) in the literal string list + + loop + Current_Location := Token_Ptr; + Parse_Expression + (In_Tree => In_Tree, + Expression => Next_Expression, + Flags => Flags, + Current_Project => Current_Project, + Current_Package => Current_Package, + Optional_Index => Optional_Index); + + -- The expression kind is String list, report an error + + if Expression_Kind_Of (Next_Expression, In_Tree) = List then + Error_Msg (Flags, "single expression expected", + Current_Location); + end if; + + -- If Current_Expression is empty, it means that the + -- expression is the first in the string list. + + if No (Current_Expression) then + Set_First_Expression_In_List + (Term_Id, In_Tree, To => Next_Expression); + else + Set_Next_Expression_In_List + (Current_Expression, In_Tree, To => Next_Expression); + end if; + + Current_Expression := Next_Expression; + + -- If there is a comma, continue with the next expression + + exit when Token /= Tok_Comma; + Scan (In_Tree); -- past the comma + end loop; + + -- We expect a closing right parenthesis + + Expect (Tok_Right_Paren, "`)`"); + + if Token = Tok_Right_Paren then + Scan (In_Tree); + end if; + end if; + + when Tok_String_Literal => + + -- If we don't know the expression kind (first term), then it is + -- a simple string. + + if Expr_Kind = Undefined then + Expr_Kind := Single; + end if; + + -- Declare a new node for the string literal + + Term_Id := + Default_Project_Node + (Of_Kind => N_Literal_String, In_Tree => In_Tree); + Set_Current_Term (Term, In_Tree, To => Term_Id); + Set_String_Value_Of (Term_Id, In_Tree, To => Token_Name); + + -- Scan past the string literal + + Scan (In_Tree); + + -- Check for possible index expression + + if Token = Tok_At then + if not Optional_Index then + Error_Msg (Flags, "index not allowed here", Token_Ptr); + Scan (In_Tree); + + if Token = Tok_Integer_Literal then + Scan (In_Tree); + end if; + + -- Set the index value + + else + Scan (In_Tree); + Expect (Tok_Integer_Literal, "integer literal"); + + if Token = Tok_Integer_Literal then + declare + Index : constant Int := UI_To_Int (Int_Literal_Value); + begin + if Index = 0 then + Error_Msg + (Flags, "index cannot be zero", Token_Ptr); + else + Set_Source_Index_Of + (Term_Id, In_Tree, To => Index); + end if; + end; + + Scan (In_Tree); + end if; + end if; + end if; + + when Tok_Identifier => + Current_Location := Token_Ptr; + + -- Get the variable or attribute reference + + Parse_Variable_Reference + (In_Tree => In_Tree, + Variable => Reference, + Flags => Flags, + Current_Project => Current_Project, + Current_Package => Current_Package); + Set_Current_Term (Term, In_Tree, To => Reference); + + if Present (Reference) then + + -- If we don't know the expression kind (first term), then it + -- has the kind of the variable or attribute reference. + + if Expr_Kind = Undefined then + Expr_Kind := Expression_Kind_Of (Reference, In_Tree); + + elsif Expr_Kind = Single + and then Expression_Kind_Of (Reference, In_Tree) = List + then + -- If the expression is a single list, and the reference is + -- a string list, report an error, and set the expression + -- kind to string list to avoid multiple errors. + + Expr_Kind := List; + Error_Msg + (Flags, + "list variable cannot appear in single string expression", + Current_Location); + end if; + end if; + + when Tok_Project => + + -- Project can appear in an expression as the prefix of an + -- attribute reference of the current project. + + Current_Location := Token_Ptr; + Scan (In_Tree); + Expect (Tok_Apostrophe, "`'`"); + + if Token = Tok_Apostrophe then + Attribute_Reference + (In_Tree => In_Tree, + Reference => Reference, + Flags => Flags, + First_Attribute => Prj.Attr.Attribute_First, + Current_Project => Current_Project, + Current_Package => Empty_Node); + Set_Current_Term (Term, In_Tree, To => Reference); + end if; + + -- Same checks as above for the expression kind + + if Present (Reference) then + if Expr_Kind = Undefined then + Expr_Kind := Expression_Kind_Of (Reference, In_Tree); + + elsif Expr_Kind = Single + and then Expression_Kind_Of (Reference, In_Tree) = List + then + Error_Msg + (Flags, "lists cannot appear in single string expression", + Current_Location); + end if; + end if; + + when Tok_External | Tok_External_As_List => + External_Reference + (In_Tree => In_Tree, + Flags => Flags, + Current_Project => Current_Project, + Current_Package => Current_Package, + Expr_Kind => Expr_Kind, + External_Value => Reference); + Set_Current_Term (Term, In_Tree, To => Reference); + + when others => + Error_Msg (Flags, "cannot be part of an expression", Token_Ptr); + Term := Empty_Node; + return; + end case; + + -- If there is an '&', call Terms recursively + + if Token = Tok_Ampersand then + Scan (In_Tree); -- scan past ampersand + + Terms + (In_Tree => In_Tree, + Term => Next_Term, + Expr_Kind => Expr_Kind, + Flags => Flags, + Current_Project => Current_Project, + Current_Package => Current_Package, + Optional_Index => Optional_Index); + + -- And link the next term to this term + + Set_Next_Term (Term, In_Tree, To => Next_Term); + end if; + end Terms; + +end Prj.Strt; diff --git a/gcc/ada/prj-strt.ads b/gcc/ada/prj-strt.ads new file mode 100644 index 000000000..7dbe53027 --- /dev/null +++ b/gcc/ada/prj-strt.ads @@ -0,0 +1,109 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . S T R T -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package implements parsing of string expressions in project files + +with Prj.Tree; use Prj.Tree; + +private package Prj.Strt is + + procedure Parse_String_Type_List + (In_Tree : Project_Node_Tree_Ref; + First_String : out Project_Node_Id; + Flags : Processing_Flags); + -- Get the list of literal strings that are allowed for a typed string. + -- On entry, the current token is the first literal string following + -- a left parenthesis in a string type declaration such as: + -- type Toto is ("string_1", "string_2", "string_3"); + -- + -- On exit, the current token is the right parenthesis. The parameter + -- First_String is a node that contained the first literal string of the + -- string type, linked with the following literal strings. + -- + -- Report an error if + -- - a literal string is not found at the beginning of the list + -- or after a comma + -- - two literal strings in the list are equal + + procedure Start_New_Case_Construction + (In_Tree : Project_Node_Tree_Ref; + String_Type : Project_Node_Id); + -- This procedure is called at the beginning of a case construction The + -- parameter String_Type is the node for the string type of the case label + -- variable. The different literal strings of the string type are stored + -- into a table to be checked against the case labels of the case + -- construction. + + procedure End_Case_Construction + (Check_All_Labels : Boolean; + Case_Location : Source_Ptr; + Flags : Processing_Flags); + -- This procedure is called at the end of a case construction to remove the + -- case labels and to restore the previous state. In particular, in the + -- case of nested case constructions, the case labels of the enclosing case + -- construction are restored. When When_Others is False and we are not in + -- quiet output, a warning is emitted for each value of the case variable + -- string type that has not been specified. + + procedure Parse_Choice_List + (In_Tree : Project_Node_Tree_Ref; + First_Choice : out Project_Node_Id; + Flags : Processing_Flags); + -- Get the label for a choice list. + -- Report an error if + -- - a case label is not a literal string + -- - a case label is not in the typed string list + -- - the same case label is repeated in the same case construction + + procedure Parse_Expression + (In_Tree : Project_Node_Tree_Ref; + Expression : out Project_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Optional_Index : Boolean; + Flags : Processing_Flags); + -- Parse a simple string expression or a string list expression + -- + -- Current_Project is the node of the project file being parsed + -- + -- Current_Package is the node of the package being parsed, or Empty_Node + -- when we are at the project level (not in a package). On exit, Expression + -- is the node of the expression that has been parsed. + + procedure Parse_Variable_Reference + (In_Tree : Project_Node_Tree_Ref; + Variable : out Project_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Flags : Processing_Flags); + -- Parse variable or attribute reference. Used internally (in expressions) + -- and for case variables (in Prj.Dect). Current_Package is the node of the + -- package being parsed, or Empty_Node when we are at the project level + -- (not in a package). On exit, Variable is the node of the variable or + -- attribute reference. A variable reference is made of one to three simple + -- names. An attribute reference is made of one or two simple names, + -- followed by an apostrophe, followed by the attribute simple name. + +end Prj.Strt; diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb new file mode 100644 index 000000000..f1b700bd9 --- /dev/null +++ b/gcc/ada/prj-tree.adb @@ -0,0 +1,3112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . T R E E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Osint; use Osint; +with Prj.Env; use Prj.Env; +with Prj.Err; + +with Ada.Unchecked_Deallocation; + +package body Prj.Tree is + + Node_With_Comments : constant array (Project_Node_Kind) of Boolean := + (N_Project => True, + N_With_Clause => True, + N_Project_Declaration => False, + N_Declarative_Item => False, + N_Package_Declaration => True, + N_String_Type_Declaration => True, + N_Literal_String => False, + N_Attribute_Declaration => True, + N_Typed_Variable_Declaration => True, + N_Variable_Declaration => True, + N_Expression => False, + N_Term => False, + N_Literal_String_List => False, + N_Variable_Reference => False, + N_External_Value => False, + N_Attribute_Reference => False, + N_Case_Construction => True, + N_Case_Item => True, + N_Comment_Zones => True, + N_Comment => True); + -- Indicates the kinds of node that may have associated comments + + package Next_End_Nodes is new Table.Table + (Table_Component_Type => Project_Node_Id, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Next_End_Nodes"); + -- A stack of nodes to indicates to what node the next "end" is associated + + use Tree_Private_Part; + + End_Of_Line_Node : Project_Node_Id := Empty_Node; + -- The node an end of line comment may be associated with + + Previous_Line_Node : Project_Node_Id := Empty_Node; + -- The node an immediately following comment may be associated with + + Previous_End_Node : Project_Node_Id := Empty_Node; + -- The node comments immediately following an "end" line may be + -- associated with. + + Unkept_Comments : Boolean := False; + -- Set to True when some comments may not be associated with any node + + function Comment_Zones_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + -- Returns the ID of the N_Comment_Zones node associated with node Node. + -- If there is not already an N_Comment_Zones node, create one and + -- associate it with node Node. + + ------------------ + -- Add_Comments -- + ------------------ + + procedure Add_Comments + (To : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + Where : Comment_Location) is + Zone : Project_Node_Id := Empty_Node; + Previous : Project_Node_Id := Empty_Node; + + begin + pragma Assert + (Present (To) + and then In_Tree.Project_Nodes.Table (To).Kind /= N_Comment); + + Zone := In_Tree.Project_Nodes.Table (To).Comments; + + if No (Zone) then + + -- Create new N_Comment_Zones node + + Project_Node_Table.Increment_Last (In_Tree.Project_Nodes); + In_Tree.Project_Nodes.Table + (Project_Node_Table.Last (In_Tree.Project_Nodes)) := + (Kind => N_Comment_Zones, + Qualifier => Unspecified, + Expr_Kind => Undefined, + Location => No_Location, + Directory => No_Path, + Variables => Empty_Node, + Packages => Empty_Node, + Pkg_Id => Empty_Package, + Name => No_Name, + Src_Index => 0, + Path_Name => No_Path, + Value => No_Name, + Field1 => Empty_Node, + Field2 => Empty_Node, + Field3 => Empty_Node, + Field4 => Empty_Node, + Flag1 => False, + Flag2 => False, + Comments => Empty_Node); + + Zone := Project_Node_Table.Last (In_Tree.Project_Nodes); + In_Tree.Project_Nodes.Table (To).Comments := Zone; + end if; + + if Where = End_Of_Line then + In_Tree.Project_Nodes.Table (Zone).Value := Comments.Table (1).Value; + + else + -- Get each comments in the Comments table and link them to node To + + for J in 1 .. Comments.Last loop + + -- Create new N_Comment node + + if (Where = After or else Where = After_End) and then + Token /= Tok_EOF and then + Comments.Table (J).Follows_Empty_Line + then + Comments.Table (1 .. Comments.Last - J + 1) := + Comments.Table (J .. Comments.Last); + Comments.Set_Last (Comments.Last - J + 1); + return; + end if; + + Project_Node_Table.Increment_Last (In_Tree.Project_Nodes); + In_Tree.Project_Nodes.Table + (Project_Node_Table.Last (In_Tree.Project_Nodes)) := + (Kind => N_Comment, + Qualifier => Unspecified, + Expr_Kind => Undefined, + Flag1 => Comments.Table (J).Follows_Empty_Line, + Flag2 => + Comments.Table (J).Is_Followed_By_Empty_Line, + Location => No_Location, + Directory => No_Path, + Variables => Empty_Node, + Packages => Empty_Node, + Pkg_Id => Empty_Package, + Name => No_Name, + Src_Index => 0, + Path_Name => No_Path, + Value => Comments.Table (J).Value, + Field1 => Empty_Node, + Field2 => Empty_Node, + Field3 => Empty_Node, + Field4 => Empty_Node, + Comments => Empty_Node); + + -- If this is the first comment, put it in the right field of + -- the node Zone. + + if No (Previous) then + case Where is + when Before => + In_Tree.Project_Nodes.Table (Zone).Field1 := + Project_Node_Table.Last (In_Tree.Project_Nodes); + + when After => + In_Tree.Project_Nodes.Table (Zone).Field2 := + Project_Node_Table.Last (In_Tree.Project_Nodes); + + when Before_End => + In_Tree.Project_Nodes.Table (Zone).Field3 := + Project_Node_Table.Last (In_Tree.Project_Nodes); + + when After_End => + In_Tree.Project_Nodes.Table (Zone).Comments := + Project_Node_Table.Last (In_Tree.Project_Nodes); + + when End_Of_Line => + null; + end case; + + else + -- When it is not the first, link it to the previous one + + In_Tree.Project_Nodes.Table (Previous).Comments := + Project_Node_Table.Last (In_Tree.Project_Nodes); + end if; + + -- This node becomes the previous one for the next comment, if + -- there is one. + + Previous := Project_Node_Table.Last (In_Tree.Project_Nodes); + end loop; + end if; + + -- Empty the Comments table, so that there is no risk to link the same + -- comments to another node. + + Comments.Set_Last (0); + end Add_Comments; + + -------------------------------- + -- Associative_Array_Index_Of -- + -------------------------------- + + function Associative_Array_Index_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Name_Id + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference)); + return In_Tree.Project_Nodes.Table (Node).Value; + end Associative_Array_Index_Of; + + ---------------------------- + -- Associative_Package_Of -- + ---------------------------- + + function Associative_Package_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration)); + return In_Tree.Project_Nodes.Table (Node).Field3; + end Associative_Package_Of; + + ---------------------------- + -- Associative_Project_Of -- + ---------------------------- + + function Associative_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration)); + return In_Tree.Project_Nodes.Table (Node).Field2; + end Associative_Project_Of; + + ---------------------- + -- Case_Insensitive -- + ---------------------- + + function Case_Insensitive + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Boolean is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference)); + return In_Tree.Project_Nodes.Table (Node).Flag1; + end Case_Insensitive; + + -------------------------------- + -- Case_Variable_Reference_Of -- + -------------------------------- + + function Case_Variable_Reference_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction); + return In_Tree.Project_Nodes.Table (Node).Field1; + end Case_Variable_Reference_Of; + + ---------------------- + -- Comment_Zones_Of -- + ---------------------- + + function Comment_Zones_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + Zone : Project_Node_Id; + + begin + pragma Assert (Present (Node)); + Zone := In_Tree.Project_Nodes.Table (Node).Comments; + + -- If there is not already an N_Comment_Zones associated, create a new + -- one and associate it with node Node. + + if No (Zone) then + Project_Node_Table.Increment_Last (In_Tree.Project_Nodes); + Zone := Project_Node_Table.Last (In_Tree.Project_Nodes); + In_Tree.Project_Nodes.Table (Zone) := + (Kind => N_Comment_Zones, + Qualifier => Unspecified, + Location => No_Location, + Directory => No_Path, + Expr_Kind => Undefined, + Variables => Empty_Node, + Packages => Empty_Node, + Pkg_Id => Empty_Package, + Name => No_Name, + Src_Index => 0, + Path_Name => No_Path, + Value => No_Name, + Field1 => Empty_Node, + Field2 => Empty_Node, + Field3 => Empty_Node, + Field4 => Empty_Node, + Flag1 => False, + Flag2 => False, + Comments => Empty_Node); + In_Tree.Project_Nodes.Table (Node).Comments := Zone; + end if; + + return Zone; + end Comment_Zones_Of; + + ----------------------- + -- Current_Item_Node -- + ----------------------- + + function Current_Item_Node + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item); + return In_Tree.Project_Nodes.Table (Node).Field1; + end Current_Item_Node; + + ------------------ + -- Current_Term -- + ------------------ + + function Current_Term + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Term); + return In_Tree.Project_Nodes.Table (Node).Field1; + end Current_Term; + + -------------------------- + -- Default_Project_Node -- + -------------------------- + + function Default_Project_Node + (In_Tree : Project_Node_Tree_Ref; + Of_Kind : Project_Node_Kind; + And_Expr_Kind : Variable_Kind := Undefined) return Project_Node_Id + is + Result : Project_Node_Id; + Zone : Project_Node_Id; + Previous : Project_Node_Id; + + begin + -- Create new node with specified kind and expression kind + + Project_Node_Table.Increment_Last (In_Tree.Project_Nodes); + In_Tree.Project_Nodes.Table + (Project_Node_Table.Last (In_Tree.Project_Nodes)) := + (Kind => Of_Kind, + Qualifier => Unspecified, + Location => No_Location, + Directory => No_Path, + Expr_Kind => And_Expr_Kind, + Variables => Empty_Node, + Packages => Empty_Node, + Pkg_Id => Empty_Package, + Name => No_Name, + Src_Index => 0, + Path_Name => No_Path, + Value => No_Name, + Field1 => Empty_Node, + Field2 => Empty_Node, + Field3 => Empty_Node, + Field4 => Empty_Node, + Flag1 => False, + Flag2 => False, + Comments => Empty_Node); + + -- Save the new node for the returned value + + Result := Project_Node_Table.Last (In_Tree.Project_Nodes); + + if Comments.Last > 0 then + + -- If this is not a node with comments, then set the flag + + if not Node_With_Comments (Of_Kind) then + Unkept_Comments := True; + + elsif Of_Kind /= N_Comment and then Of_Kind /= N_Comment_Zones then + + Project_Node_Table.Increment_Last (In_Tree.Project_Nodes); + In_Tree.Project_Nodes.Table + (Project_Node_Table.Last (In_Tree.Project_Nodes)) := + (Kind => N_Comment_Zones, + Qualifier => Unspecified, + Expr_Kind => Undefined, + Location => No_Location, + Directory => No_Path, + Variables => Empty_Node, + Packages => Empty_Node, + Pkg_Id => Empty_Package, + Name => No_Name, + Src_Index => 0, + Path_Name => No_Path, + Value => No_Name, + Field1 => Empty_Node, + Field2 => Empty_Node, + Field3 => Empty_Node, + Field4 => Empty_Node, + Flag1 => False, + Flag2 => False, + Comments => Empty_Node); + + Zone := Project_Node_Table.Last (In_Tree.Project_Nodes); + In_Tree.Project_Nodes.Table (Result).Comments := Zone; + Previous := Empty_Node; + + for J in 1 .. Comments.Last loop + + -- Create a new N_Comment node + + Project_Node_Table.Increment_Last (In_Tree.Project_Nodes); + In_Tree.Project_Nodes.Table + (Project_Node_Table.Last (In_Tree.Project_Nodes)) := + (Kind => N_Comment, + Qualifier => Unspecified, + Expr_Kind => Undefined, + Flag1 => Comments.Table (J).Follows_Empty_Line, + Flag2 => + Comments.Table (J).Is_Followed_By_Empty_Line, + Location => No_Location, + Directory => No_Path, + Variables => Empty_Node, + Packages => Empty_Node, + Pkg_Id => Empty_Package, + Name => No_Name, + Src_Index => 0, + Path_Name => No_Path, + Value => Comments.Table (J).Value, + Field1 => Empty_Node, + Field2 => Empty_Node, + Field3 => Empty_Node, + Field4 => Empty_Node, + Comments => Empty_Node); + + -- Link it to the N_Comment_Zones node, if it is the first, + -- otherwise to the previous one. + + if No (Previous) then + In_Tree.Project_Nodes.Table (Zone).Field1 := + Project_Node_Table.Last (In_Tree.Project_Nodes); + + else + In_Tree.Project_Nodes.Table (Previous).Comments := + Project_Node_Table.Last (In_Tree.Project_Nodes); + end if; + + -- This new node will be the previous one for the next + -- N_Comment node, if there is one. + + Previous := Project_Node_Table.Last (In_Tree.Project_Nodes); + end loop; + + -- Empty the Comments table after all comments have been processed + + Comments.Set_Last (0); + end if; + end if; + + return Result; + end Default_Project_Node; + + ------------------ + -- Directory_Of -- + ------------------ + + function Directory_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Path_Name_Type is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Project); + return In_Tree.Project_Nodes.Table (Node).Directory; + end Directory_Of; + + ------------------------- + -- End_Of_Line_Comment -- + ------------------------- + + function End_Of_Line_Comment + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Name_Id is + Zone : Project_Node_Id := Empty_Node; + + begin + pragma Assert (Present (Node)); + Zone := In_Tree.Project_Nodes.Table (Node).Comments; + + if No (Zone) then + return No_Name; + else + return In_Tree.Project_Nodes.Table (Zone).Value; + end if; + end End_Of_Line_Comment; + + ------------------------ + -- Expression_Kind_Of -- + ------------------------ + + function Expression_Kind_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Variable_Kind + is + begin + pragma Assert + (Present (Node) + and then -- should use Nkind_In here ??? why not??? + (In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Declaration + or else + In_Tree.Project_Nodes.Table (Node).Kind = + N_Typed_Variable_Declaration + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Expression + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Term + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value)); + return In_Tree.Project_Nodes.Table (Node).Expr_Kind; + end Expression_Kind_Of; + + ------------------- + -- Expression_Of -- + ------------------- + + function Expression_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = + N_Attribute_Declaration + or else + In_Tree.Project_Nodes.Table (Node).Kind = + N_Typed_Variable_Declaration + or else + In_Tree.Project_Nodes.Table (Node).Kind = + N_Variable_Declaration)); + + return In_Tree.Project_Nodes.Table (Node).Field1; + end Expression_Of; + + ------------------------- + -- Extended_Project_Of -- + ------------------------- + + function Extended_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration); + return In_Tree.Project_Nodes.Table (Node).Field2; + end Extended_Project_Of; + + ------------------------------ + -- Extended_Project_Path_Of -- + ------------------------------ + + function Extended_Project_Path_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Path_Name_Type + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Project); + return Path_Name_Type (In_Tree.Project_Nodes.Table (Node).Value); + end Extended_Project_Path_Of; + + -------------------------- + -- Extending_Project_Of -- + -------------------------- + function Extending_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration); + return In_Tree.Project_Nodes.Table (Node).Field3; + end Extending_Project_Of; + + --------------------------- + -- External_Reference_Of -- + --------------------------- + + function External_Reference_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value); + return In_Tree.Project_Nodes.Table (Node).Field1; + end External_Reference_Of; + + ------------------------- + -- External_Default_Of -- + ------------------------- + + function External_Default_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) + return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value); + return In_Tree.Project_Nodes.Table (Node).Field2; + end External_Default_Of; + + ------------------------ + -- First_Case_Item_Of -- + ------------------------ + + function First_Case_Item_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction); + return In_Tree.Project_Nodes.Table (Node).Field2; + end First_Case_Item_Of; + + --------------------- + -- First_Choice_Of -- + --------------------- + + function First_Choice_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) + return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item); + return In_Tree.Project_Nodes.Table (Node).Field1; + end First_Choice_Of; + + ------------------------- + -- First_Comment_After -- + ------------------------- + + function First_Comment_After + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + Zone : Project_Node_Id := Empty_Node; + begin + pragma Assert (Present (Node)); + Zone := In_Tree.Project_Nodes.Table (Node).Comments; + + if No (Zone) then + return Empty_Node; + + else + return In_Tree.Project_Nodes.Table (Zone).Field2; + end if; + end First_Comment_After; + + ----------------------------- + -- First_Comment_After_End -- + ----------------------------- + + function First_Comment_After_End + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) + return Project_Node_Id + is + Zone : Project_Node_Id := Empty_Node; + + begin + pragma Assert (Present (Node)); + Zone := In_Tree.Project_Nodes.Table (Node).Comments; + + if No (Zone) then + return Empty_Node; + + else + return In_Tree.Project_Nodes.Table (Zone).Comments; + end if; + end First_Comment_After_End; + + -------------------------- + -- First_Comment_Before -- + -------------------------- + + function First_Comment_Before + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + Zone : Project_Node_Id := Empty_Node; + + begin + pragma Assert (Present (Node)); + Zone := In_Tree.Project_Nodes.Table (Node).Comments; + + if No (Zone) then + return Empty_Node; + + else + return In_Tree.Project_Nodes.Table (Zone).Field1; + end if; + end First_Comment_Before; + + ------------------------------ + -- First_Comment_Before_End -- + ------------------------------ + + function First_Comment_Before_End + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + Zone : Project_Node_Id := Empty_Node; + + begin + pragma Assert (Present (Node)); + Zone := In_Tree.Project_Nodes.Table (Node).Comments; + + if No (Zone) then + return Empty_Node; + + else + return In_Tree.Project_Nodes.Table (Zone).Field3; + end if; + end First_Comment_Before_End; + + ------------------------------- + -- First_Declarative_Item_Of -- + ------------------------------- + + function First_Declarative_Item_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration)); + + if In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration then + return In_Tree.Project_Nodes.Table (Node).Field1; + else + return In_Tree.Project_Nodes.Table (Node).Field2; + end if; + end First_Declarative_Item_Of; + + ------------------------------ + -- First_Expression_In_List -- + ------------------------------ + + function First_Expression_In_List + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String_List); + return In_Tree.Project_Nodes.Table (Node).Field1; + end First_Expression_In_List; + + -------------------------- + -- First_Literal_String -- + -------------------------- + + function First_Literal_String + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = + N_String_Type_Declaration); + return In_Tree.Project_Nodes.Table (Node).Field1; + end First_Literal_String; + + ---------------------- + -- First_Package_Of -- + ---------------------- + + function First_Package_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Package_Declaration_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Project); + return In_Tree.Project_Nodes.Table (Node).Packages; + end First_Package_Of; + + -------------------------- + -- First_String_Type_Of -- + -------------------------- + + function First_String_Type_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Project); + return In_Tree.Project_Nodes.Table (Node).Field3; + end First_String_Type_Of; + + ---------------- + -- First_Term -- + ---------------- + + function First_Term + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Expression); + return In_Tree.Project_Nodes.Table (Node).Field1; + end First_Term; + + ----------------------- + -- First_Variable_Of -- + ----------------------- + + function First_Variable_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Variable_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = N_Project + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration)); + + return In_Tree.Project_Nodes.Table (Node).Variables; + end First_Variable_Of; + + -------------------------- + -- First_With_Clause_Of -- + -------------------------- + + function First_With_Clause_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Project); + return In_Tree.Project_Nodes.Table (Node).Field1; + end First_With_Clause_Of; + + ------------------------ + -- Follows_Empty_Line -- + ------------------------ + + function Follows_Empty_Line + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Boolean is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Comment); + return In_Tree.Project_Nodes.Table (Node).Flag1; + end Follows_Empty_Line; + + ---------- + -- Hash -- + ---------- + + function Hash (N : Project_Node_Id) return Header_Num is + begin + return Header_Num (N mod Project_Node_Id (Header_Num'Last)); + end Hash; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Tree : Project_Node_Tree_Ref) is + begin + Project_Node_Table.Init (Tree.Project_Nodes); + Projects_Htable.Reset (Tree.Projects_HT); + + -- Do not reset the external references, in case we are reloading a + -- project, since we want to preserve the current environment + -- Name_To_Name_HTable.Reset (Tree.External_References); + end Initialize; + + ---------- + -- Free -- + ---------- + + procedure Free (Proj : in out Project_Node_Tree_Ref) is + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Project_Node_Tree_Data, Project_Node_Tree_Ref); + begin + if Proj /= null then + Project_Node_Table.Free (Proj.Project_Nodes); + Projects_Htable.Reset (Proj.Projects_HT); + Name_To_Name_HTable.Reset (Proj.External_References); + Free (Proj.Project_Path); + Unchecked_Free (Proj); + end if; + end Free; + + ------------------------------- + -- Is_Followed_By_Empty_Line -- + ------------------------------- + + function Is_Followed_By_Empty_Line + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Boolean + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Comment); + return In_Tree.Project_Nodes.Table (Node).Flag2; + end Is_Followed_By_Empty_Line; + + ---------------------- + -- Is_Extending_All -- + ---------------------- + + function Is_Extending_All + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Boolean is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = N_Project + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause)); + return In_Tree.Project_Nodes.Table (Node).Flag2; + end Is_Extending_All; + + ------------------------- + -- Is_Not_Last_In_List -- + ------------------------- + + function Is_Not_Last_In_List + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Boolean is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause); + return In_Tree.Project_Nodes.Table (Node).Flag1; + end Is_Not_Last_In_List; + + ------------------------------------- + -- Imported_Or_Extended_Project_Of -- + ------------------------------------- + + function Imported_Or_Extended_Project_Of + (Project : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + With_Name : Name_Id) return Project_Node_Id + is + With_Clause : Project_Node_Id := + First_With_Clause_Of (Project, In_Tree); + Result : Project_Node_Id := Empty_Node; + + begin + -- First check all the imported projects + + while Present (With_Clause) loop + + -- Only non limited imported project may be used as prefix + -- of variable or attributes. + + Result := Non_Limited_Project_Node_Of (With_Clause, In_Tree); + exit when Present (Result) + and then Name_Of (Result, In_Tree) = With_Name; + With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); + end loop; + + -- If it is not an imported project, it might be an extended project + + if No (With_Clause) then + Result := Project; + loop + Result := + Extended_Project_Of + (Project_Declaration_Of (Result, In_Tree), In_Tree); + + exit when No (Result) + or else Name_Of (Result, In_Tree) = With_Name; + end loop; + end if; + + return Result; + end Imported_Or_Extended_Project_Of; + + ------------- + -- Kind_Of -- + ------------- + + function Kind_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Kind is + begin + pragma Assert (Present (Node)); + return In_Tree.Project_Nodes.Table (Node).Kind; + end Kind_Of; + + ----------------- + -- Location_Of -- + ----------------- + + function Location_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Source_Ptr is + begin + pragma Assert (Present (Node)); + return In_Tree.Project_Nodes.Table (Node).Location; + end Location_Of; + + ------------- + -- Name_Of -- + ------------- + + function Name_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Name_Id is + begin + pragma Assert (Present (Node)); + return In_Tree.Project_Nodes.Table (Node).Name; + end Name_Of; + + -------------------- + -- Next_Case_Item -- + -------------------- + + function Next_Case_Item + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item); + return In_Tree.Project_Nodes.Table (Node).Field3; + end Next_Case_Item; + + ------------------ + -- Next_Comment -- + ------------------ + + function Next_Comment + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Comment); + return In_Tree.Project_Nodes.Table (Node).Comments; + end Next_Comment; + + --------------------------- + -- Next_Declarative_Item -- + --------------------------- + + function Next_Declarative_Item + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item); + return In_Tree.Project_Nodes.Table (Node).Field2; + end Next_Declarative_Item; + + ----------------------------- + -- Next_Expression_In_List -- + ----------------------------- + + function Next_Expression_In_List + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Expression); + return In_Tree.Project_Nodes.Table (Node).Field2; + end Next_Expression_In_List; + + ------------------------- + -- Next_Literal_String -- + ------------------------- + + function Next_Literal_String + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) + return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String); + return In_Tree.Project_Nodes.Table (Node).Field1; + end Next_Literal_String; + + ----------------------------- + -- Next_Package_In_Project -- + ----------------------------- + + function Next_Package_In_Project + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); + return In_Tree.Project_Nodes.Table (Node).Field3; + end Next_Package_In_Project; + + ---------------------- + -- Next_String_Type -- + ---------------------- + + function Next_String_Type + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) + return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = + N_String_Type_Declaration); + return In_Tree.Project_Nodes.Table (Node).Field2; + end Next_String_Type; + + --------------- + -- Next_Term -- + --------------- + + function Next_Term + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Term); + return In_Tree.Project_Nodes.Table (Node).Field2; + end Next_Term; + + ------------------- + -- Next_Variable -- + ------------------- + + function Next_Variable + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) + return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = + N_Typed_Variable_Declaration + or else + In_Tree.Project_Nodes.Table (Node).Kind = + N_Variable_Declaration)); + + return In_Tree.Project_Nodes.Table (Node).Field3; + end Next_Variable; + + ------------------------- + -- Next_With_Clause_Of -- + ------------------------- + + function Next_With_Clause_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause); + return In_Tree.Project_Nodes.Table (Node).Field2; + end Next_With_Clause_Of; + + -------- + -- No -- + -------- + + function No (Node : Project_Node_Id) return Boolean is + begin + return Node = Empty_Node; + end No; + + --------------------------------- + -- Non_Limited_Project_Node_Of -- + --------------------------------- + + function Non_Limited_Project_Node_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause)); + return In_Tree.Project_Nodes.Table (Node).Field3; + end Non_Limited_Project_Node_Of; + + ------------------- + -- Package_Id_Of -- + ------------------- + + function Package_Id_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Package_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); + return In_Tree.Project_Nodes.Table (Node).Pkg_Id; + end Package_Id_Of; + + --------------------- + -- Package_Node_Of -- + --------------------- + + function Package_Node_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference)); + return In_Tree.Project_Nodes.Table (Node).Field2; + end Package_Node_Of; + + ------------------ + -- Path_Name_Of -- + ------------------ + + function Path_Name_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Path_Name_Type + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = N_Project + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause)); + return In_Tree.Project_Nodes.Table (Node).Path_Name; + end Path_Name_Of; + + ------------- + -- Present -- + ------------- + + function Present (Node : Project_Node_Id) return Boolean is + begin + return Node /= Empty_Node; + end Present; + + ---------------------------- + -- Project_Declaration_Of -- + ---------------------------- + + function Project_Declaration_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Project); + return In_Tree.Project_Nodes.Table (Node).Field2; + end Project_Declaration_Of; + + -------------------------- + -- Project_Qualifier_Of -- + -------------------------- + + function Project_Qualifier_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Qualifier + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Project); + return In_Tree.Project_Nodes.Table (Node).Qualifier; + end Project_Qualifier_Of; + + ----------------------- + -- Parent_Project_Of -- + ----------------------- + + function Parent_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Project); + return In_Tree.Project_Nodes.Table (Node).Field4; + end Parent_Project_Of; + + ------------------------------------------- + -- Project_File_Includes_Unkept_Comments -- + ------------------------------------------- + + function Project_File_Includes_Unkept_Comments + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Boolean + is + Declaration : constant Project_Node_Id := + Project_Declaration_Of (Node, In_Tree); + begin + return In_Tree.Project_Nodes.Table (Declaration).Flag1; + end Project_File_Includes_Unkept_Comments; + + --------------------- + -- Project_Node_Of -- + --------------------- + + function Project_Node_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference)); + return In_Tree.Project_Nodes.Table (Node).Field1; + end Project_Node_Of; + + ----------------------------------- + -- Project_Of_Renamed_Package_Of -- + ----------------------------------- + + function Project_Of_Renamed_Package_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); + return In_Tree.Project_Nodes.Table (Node).Field1; + end Project_Of_Renamed_Package_Of; + + -------------------------- + -- Remove_Next_End_Node -- + -------------------------- + + procedure Remove_Next_End_Node is + begin + Next_End_Nodes.Decrement_Last; + end Remove_Next_End_Node; + + ----------------- + -- Reset_State -- + ----------------- + + procedure Reset_State is + begin + End_Of_Line_Node := Empty_Node; + Previous_Line_Node := Empty_Node; + Previous_End_Node := Empty_Node; + Unkept_Comments := False; + Comments.Set_Last (0); + end Reset_State; + + ---------------------- + -- Restore_And_Free -- + ---------------------- + + procedure Restore_And_Free (S : in out Comment_State) is + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation (Comment_Array, Comments_Ptr); + + begin + End_Of_Line_Node := S.End_Of_Line_Node; + Previous_Line_Node := S.Previous_Line_Node; + Previous_End_Node := S.Previous_End_Node; + Next_End_Nodes.Set_Last (0); + Unkept_Comments := S.Unkept_Comments; + + Comments.Set_Last (0); + + for J in S.Comments'Range loop + Comments.Increment_Last; + Comments.Table (Comments.Last) := S.Comments (J); + end loop; + + Unchecked_Free (S.Comments); + end Restore_And_Free; + + ---------- + -- Save -- + ---------- + + procedure Save (S : out Comment_State) is + Cmts : constant Comments_Ptr := new Comment_Array (1 .. Comments.Last); + + begin + for J in 1 .. Comments.Last loop + Cmts (J) := Comments.Table (J); + end loop; + + S := + (End_Of_Line_Node => End_Of_Line_Node, + Previous_Line_Node => Previous_Line_Node, + Previous_End_Node => Previous_End_Node, + Unkept_Comments => Unkept_Comments, + Comments => Cmts); + end Save; + + ---------- + -- Scan -- + ---------- + + procedure Scan (In_Tree : Project_Node_Tree_Ref) is + Empty_Line : Boolean := False; + + begin + -- If there are comments, then they will not be kept. Set the flag and + -- clear the comments. + + if Comments.Last > 0 then + Unkept_Comments := True; + Comments.Set_Last (0); + end if; + + -- Loop until a token other that End_Of_Line or Comment is found + + loop + Prj.Err.Scanner.Scan; + + case Token is + when Tok_End_Of_Line => + if Prev_Token = Tok_End_Of_Line then + Empty_Line := True; + + if Comments.Last > 0 then + Comments.Table (Comments.Last).Is_Followed_By_Empty_Line + := True; + end if; + end if; + + when Tok_Comment => + -- If this is a line comment, add it to the comment table + + if Prev_Token = Tok_End_Of_Line + or else Prev_Token = No_Token + then + Comments.Increment_Last; + Comments.Table (Comments.Last) := + (Value => Comment_Id, + Follows_Empty_Line => Empty_Line, + Is_Followed_By_Empty_Line => False); + + -- Otherwise, it is an end of line comment. If there is + -- an end of line node specified, associate the comment with + -- this node. + + elsif Present (End_Of_Line_Node) then + declare + Zones : constant Project_Node_Id := + Comment_Zones_Of (End_Of_Line_Node, In_Tree); + begin + In_Tree.Project_Nodes.Table (Zones).Value := Comment_Id; + end; + + -- Otherwise, this end of line node cannot be kept + + else + Unkept_Comments := True; + Comments.Set_Last (0); + end if; + + Empty_Line := False; + + when others => + -- If there are comments, where the first comment is not + -- following an empty line, put the initial uninterrupted + -- comment zone with the node of the preceding line (either + -- a Previous_Line or a Previous_End node), if any. + + if Comments.Last > 0 and then + not Comments.Table (1).Follows_Empty_Line then + if Present (Previous_Line_Node) then + Add_Comments + (To => Previous_Line_Node, + Where => After, + In_Tree => In_Tree); + + elsif Present (Previous_End_Node) then + Add_Comments + (To => Previous_End_Node, + Where => After_End, + In_Tree => In_Tree); + end if; + end if; + + -- If there are still comments and the token is "end", then + -- put these comments with the Next_End node, if any; + -- otherwise, these comments cannot be kept. Always clear + -- the comments. + + if Comments.Last > 0 and then Token = Tok_End then + if Next_End_Nodes.Last > 0 then + Add_Comments + (To => Next_End_Nodes.Table (Next_End_Nodes.Last), + Where => Before_End, + In_Tree => In_Tree); + + else + Unkept_Comments := True; + end if; + + Comments.Set_Last (0); + end if; + + -- Reset the End_Of_Line, Previous_Line and Previous_End nodes + -- so that they are not used again. + + End_Of_Line_Node := Empty_Node; + Previous_Line_Node := Empty_Node; + Previous_End_Node := Empty_Node; + + -- And return + + exit; + end case; + end loop; + end Scan; + + ------------------------------------ + -- Set_Associative_Array_Index_Of -- + ------------------------------------ + + procedure Set_Associative_Array_Index_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Name_Id) + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference)); + In_Tree.Project_Nodes.Table (Node).Value := To; + end Set_Associative_Array_Index_Of; + + -------------------------------- + -- Set_Associative_Package_Of -- + -------------------------------- + + procedure Set_Associative_Package_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration); + In_Tree.Project_Nodes.Table (Node).Field3 := To; + end Set_Associative_Package_Of; + + -------------------------------- + -- Set_Associative_Project_Of -- + -------------------------------- + + procedure Set_Associative_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = + N_Attribute_Declaration)); + In_Tree.Project_Nodes.Table (Node).Field2 := To; + end Set_Associative_Project_Of; + + -------------------------- + -- Set_Case_Insensitive -- + -------------------------- + + procedure Set_Case_Insensitive + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Boolean) + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference)); + In_Tree.Project_Nodes.Table (Node).Flag1 := To; + end Set_Case_Insensitive; + + ------------------------------------ + -- Set_Case_Variable_Reference_Of -- + ------------------------------------ + + procedure Set_Case_Variable_Reference_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction); + In_Tree.Project_Nodes.Table (Node).Field1 := To; + end Set_Case_Variable_Reference_Of; + + --------------------------- + -- Set_Current_Item_Node -- + --------------------------- + + procedure Set_Current_Item_Node + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item); + In_Tree.Project_Nodes.Table (Node).Field1 := To; + end Set_Current_Item_Node; + + ---------------------- + -- Set_Current_Term -- + ---------------------- + + procedure Set_Current_Term + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Term); + In_Tree.Project_Nodes.Table (Node).Field1 := To; + end Set_Current_Term; + + ---------------------- + -- Set_Directory_Of -- + ---------------------- + + procedure Set_Directory_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Path_Name_Type) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Project); + In_Tree.Project_Nodes.Table (Node).Directory := To; + end Set_Directory_Of; + + --------------------- + -- Set_End_Of_Line -- + --------------------- + + procedure Set_End_Of_Line (To : Project_Node_Id) is + begin + End_Of_Line_Node := To; + end Set_End_Of_Line; + + ---------------------------- + -- Set_Expression_Kind_Of -- + ---------------------------- + + procedure Set_Expression_Kind_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Variable_Kind) + is + begin + pragma Assert + (Present (Node) + and then -- should use Nkind_In here ??? why not??? + (In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Declaration + or else + In_Tree.Project_Nodes.Table (Node).Kind = + N_Typed_Variable_Declaration + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Expression + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Term + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value)); + In_Tree.Project_Nodes.Table (Node).Expr_Kind := To; + end Set_Expression_Kind_Of; + + ----------------------- + -- Set_Expression_Of -- + ----------------------- + + procedure Set_Expression_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = + N_Attribute_Declaration + or else + In_Tree.Project_Nodes.Table (Node).Kind = + N_Typed_Variable_Declaration + or else + In_Tree.Project_Nodes.Table (Node).Kind = + N_Variable_Declaration)); + In_Tree.Project_Nodes.Table (Node).Field1 := To; + end Set_Expression_Of; + + ------------------------------- + -- Set_External_Reference_Of -- + ------------------------------- + + procedure Set_External_Reference_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value); + In_Tree.Project_Nodes.Table (Node).Field1 := To; + end Set_External_Reference_Of; + + ----------------------------- + -- Set_External_Default_Of -- + ----------------------------- + + procedure Set_External_Default_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value); + In_Tree.Project_Nodes.Table (Node).Field2 := To; + end Set_External_Default_Of; + + ---------------------------- + -- Set_First_Case_Item_Of -- + ---------------------------- + + procedure Set_First_Case_Item_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction); + In_Tree.Project_Nodes.Table (Node).Field2 := To; + end Set_First_Case_Item_Of; + + ------------------------- + -- Set_First_Choice_Of -- + ------------------------- + + procedure Set_First_Choice_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item); + In_Tree.Project_Nodes.Table (Node).Field1 := To; + end Set_First_Choice_Of; + + ----------------------------- + -- Set_First_Comment_After -- + ----------------------------- + + procedure Set_First_Comment_After + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + Zone : constant Project_Node_Id := Comment_Zones_Of (Node, In_Tree); + begin + In_Tree.Project_Nodes.Table (Zone).Field2 := To; + end Set_First_Comment_After; + + --------------------------------- + -- Set_First_Comment_After_End -- + --------------------------------- + + procedure Set_First_Comment_After_End + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + Zone : constant Project_Node_Id := Comment_Zones_Of (Node, In_Tree); + begin + In_Tree.Project_Nodes.Table (Zone).Comments := To; + end Set_First_Comment_After_End; + + ------------------------------ + -- Set_First_Comment_Before -- + ------------------------------ + + procedure Set_First_Comment_Before + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + + is + Zone : constant Project_Node_Id := Comment_Zones_Of (Node, In_Tree); + begin + In_Tree.Project_Nodes.Table (Zone).Field1 := To; + end Set_First_Comment_Before; + + ---------------------------------- + -- Set_First_Comment_Before_End -- + ---------------------------------- + + procedure Set_First_Comment_Before_End + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + Zone : constant Project_Node_Id := Comment_Zones_Of (Node, In_Tree); + begin + In_Tree.Project_Nodes.Table (Zone).Field2 := To; + end Set_First_Comment_Before_End; + + ------------------------ + -- Set_Next_Case_Item -- + ------------------------ + + procedure Set_Next_Case_Item + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item); + In_Tree.Project_Nodes.Table (Node).Field3 := To; + end Set_Next_Case_Item; + + ---------------------- + -- Set_Next_Comment -- + ---------------------- + + procedure Set_Next_Comment + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Comment); + In_Tree.Project_Nodes.Table (Node).Comments := To; + end Set_Next_Comment; + + ----------------------------------- + -- Set_First_Declarative_Item_Of -- + ----------------------------------- + + procedure Set_First_Declarative_Item_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration)); + + if In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration then + In_Tree.Project_Nodes.Table (Node).Field1 := To; + else + In_Tree.Project_Nodes.Table (Node).Field2 := To; + end if; + end Set_First_Declarative_Item_Of; + + ---------------------------------- + -- Set_First_Expression_In_List -- + ---------------------------------- + + procedure Set_First_Expression_In_List + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String_List); + In_Tree.Project_Nodes.Table (Node).Field1 := To; + end Set_First_Expression_In_List; + + ------------------------------ + -- Set_First_Literal_String -- + ------------------------------ + + procedure Set_First_Literal_String + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = + N_String_Type_Declaration); + In_Tree.Project_Nodes.Table (Node).Field1 := To; + end Set_First_Literal_String; + + -------------------------- + -- Set_First_Package_Of -- + -------------------------- + + procedure Set_First_Package_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Package_Declaration_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Project); + In_Tree.Project_Nodes.Table (Node).Packages := To; + end Set_First_Package_Of; + + ------------------------------ + -- Set_First_String_Type_Of -- + ------------------------------ + + procedure Set_First_String_Type_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Project); + In_Tree.Project_Nodes.Table (Node).Field3 := To; + end Set_First_String_Type_Of; + + -------------------- + -- Set_First_Term -- + -------------------- + + procedure Set_First_Term + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Expression); + In_Tree.Project_Nodes.Table (Node).Field1 := To; + end Set_First_Term; + + --------------------------- + -- Set_First_Variable_Of -- + --------------------------- + + procedure Set_First_Variable_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Variable_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = N_Project + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration)); + In_Tree.Project_Nodes.Table (Node).Variables := To; + end Set_First_Variable_Of; + + ------------------------------ + -- Set_First_With_Clause_Of -- + ------------------------------ + + procedure Set_First_With_Clause_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Project); + In_Tree.Project_Nodes.Table (Node).Field1 := To; + end Set_First_With_Clause_Of; + + -------------------------- + -- Set_Is_Extending_All -- + -------------------------- + + procedure Set_Is_Extending_All + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = N_Project + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause)); + In_Tree.Project_Nodes.Table (Node).Flag2 := True; + end Set_Is_Extending_All; + + ----------------------------- + -- Set_Is_Not_Last_In_List -- + ----------------------------- + + procedure Set_Is_Not_Last_In_List + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause); + In_Tree.Project_Nodes.Table (Node).Flag1 := True; + end Set_Is_Not_Last_In_List; + + ----------------- + -- Set_Kind_Of -- + ----------------- + + procedure Set_Kind_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Kind) + is + begin + pragma Assert (Present (Node)); + In_Tree.Project_Nodes.Table (Node).Kind := To; + end Set_Kind_Of; + + --------------------- + -- Set_Location_Of -- + --------------------- + + procedure Set_Location_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Source_Ptr) + is + begin + pragma Assert (Present (Node)); + In_Tree.Project_Nodes.Table (Node).Location := To; + end Set_Location_Of; + + ----------------------------- + -- Set_Extended_Project_Of -- + ----------------------------- + + procedure Set_Extended_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration); + In_Tree.Project_Nodes.Table (Node).Field2 := To; + end Set_Extended_Project_Of; + + ---------------------------------- + -- Set_Extended_Project_Path_Of -- + ---------------------------------- + + procedure Set_Extended_Project_Path_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Path_Name_Type) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Project); + In_Tree.Project_Nodes.Table (Node).Value := Name_Id (To); + end Set_Extended_Project_Path_Of; + + ------------------------------ + -- Set_Extending_Project_Of -- + ------------------------------ + + procedure Set_Extending_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration); + In_Tree.Project_Nodes.Table (Node).Field3 := To; + end Set_Extending_Project_Of; + + ----------------- + -- Set_Name_Of -- + ----------------- + + procedure Set_Name_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Name_Id) + is + begin + pragma Assert (Present (Node)); + In_Tree.Project_Nodes.Table (Node).Name := To; + end Set_Name_Of; + + ------------------------------- + -- Set_Next_Declarative_Item -- + ------------------------------- + + procedure Set_Next_Declarative_Item + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item); + In_Tree.Project_Nodes.Table (Node).Field2 := To; + end Set_Next_Declarative_Item; + + ----------------------- + -- Set_Next_End_Node -- + ----------------------- + + procedure Set_Next_End_Node (To : Project_Node_Id) is + begin + Next_End_Nodes.Increment_Last; + Next_End_Nodes.Table (Next_End_Nodes.Last) := To; + end Set_Next_End_Node; + + --------------------------------- + -- Set_Next_Expression_In_List -- + --------------------------------- + + procedure Set_Next_Expression_In_List + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Expression); + In_Tree.Project_Nodes.Table (Node).Field2 := To; + end Set_Next_Expression_In_List; + + ----------------------------- + -- Set_Next_Literal_String -- + ----------------------------- + + procedure Set_Next_Literal_String + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String); + In_Tree.Project_Nodes.Table (Node).Field1 := To; + end Set_Next_Literal_String; + + --------------------------------- + -- Set_Next_Package_In_Project -- + --------------------------------- + + procedure Set_Next_Package_In_Project + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); + In_Tree.Project_Nodes.Table (Node).Field3 := To; + end Set_Next_Package_In_Project; + + -------------------------- + -- Set_Next_String_Type -- + -------------------------- + + procedure Set_Next_String_Type + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = + N_String_Type_Declaration); + In_Tree.Project_Nodes.Table (Node).Field2 := To; + end Set_Next_String_Type; + + ------------------- + -- Set_Next_Term -- + ------------------- + + procedure Set_Next_Term + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Term); + In_Tree.Project_Nodes.Table (Node).Field2 := To; + end Set_Next_Term; + + ----------------------- + -- Set_Next_Variable -- + ----------------------- + + procedure Set_Next_Variable + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = + N_Typed_Variable_Declaration + or else + In_Tree.Project_Nodes.Table (Node).Kind = + N_Variable_Declaration)); + In_Tree.Project_Nodes.Table (Node).Field3 := To; + end Set_Next_Variable; + + ----------------------------- + -- Set_Next_With_Clause_Of -- + ----------------------------- + + procedure Set_Next_With_Clause_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause); + In_Tree.Project_Nodes.Table (Node).Field2 := To; + end Set_Next_With_Clause_Of; + + ----------------------- + -- Set_Package_Id_Of -- + ----------------------- + + procedure Set_Package_Id_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Package_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); + In_Tree.Project_Nodes.Table (Node).Pkg_Id := To; + end Set_Package_Id_Of; + + ------------------------- + -- Set_Package_Node_Of -- + ------------------------- + + procedure Set_Package_Node_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference)); + In_Tree.Project_Nodes.Table (Node).Field2 := To; + end Set_Package_Node_Of; + + ---------------------- + -- Set_Path_Name_Of -- + ---------------------- + + procedure Set_Path_Name_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Path_Name_Type) + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = N_Project + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause)); + In_Tree.Project_Nodes.Table (Node).Path_Name := To; + end Set_Path_Name_Of; + + --------------------------- + -- Set_Previous_End_Node -- + --------------------------- + procedure Set_Previous_End_Node (To : Project_Node_Id) is + begin + Previous_End_Node := To; + end Set_Previous_End_Node; + + ---------------------------- + -- Set_Previous_Line_Node -- + ---------------------------- + + procedure Set_Previous_Line_Node (To : Project_Node_Id) is + begin + Previous_Line_Node := To; + end Set_Previous_Line_Node; + + -------------------------------- + -- Set_Project_Declaration_Of -- + -------------------------------- + + procedure Set_Project_Declaration_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Project); + In_Tree.Project_Nodes.Table (Node).Field2 := To; + end Set_Project_Declaration_Of; + + ------------------------------ + -- Set_Project_Qualifier_Of -- + ------------------------------ + + procedure Set_Project_Qualifier_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Qualifier) + is + begin + pragma Assert + (Present (Node) + and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); + In_Tree.Project_Nodes.Table (Node).Qualifier := To; + end Set_Project_Qualifier_Of; + + --------------------------- + -- Set_Parent_Project_Of -- + --------------------------- + + procedure Set_Parent_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); + In_Tree.Project_Nodes.Table (Node).Field4 := To; + end Set_Parent_Project_Of; + + ----------------------------------------------- + -- Set_Project_File_Includes_Unkept_Comments -- + ----------------------------------------------- + + procedure Set_Project_File_Includes_Unkept_Comments + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Boolean) + is + Declaration : constant Project_Node_Id := + Project_Declaration_Of (Node, In_Tree); + begin + In_Tree.Project_Nodes.Table (Declaration).Flag1 := To; + end Set_Project_File_Includes_Unkept_Comments; + + ------------------------- + -- Set_Project_Node_Of -- + ------------------------- + + procedure Set_Project_Node_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id; + Limited_With : Boolean := False) + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference)); + In_Tree.Project_Nodes.Table (Node).Field1 := To; + + if In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause + and then not Limited_With + then + In_Tree.Project_Nodes.Table (Node).Field3 := To; + end if; + end Set_Project_Node_Of; + + --------------------------------------- + -- Set_Project_Of_Renamed_Package_Of -- + --------------------------------------- + + procedure Set_Project_Of_Renamed_Package_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); + In_Tree.Project_Nodes.Table (Node).Field1 := To; + end Set_Project_Of_Renamed_Package_Of; + + ------------------------- + -- Set_Source_Index_Of -- + ------------------------- + + procedure Set_Source_Index_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Int) + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String + or else + In_Tree.Project_Nodes.Table (Node).Kind = + N_Attribute_Declaration)); + In_Tree.Project_Nodes.Table (Node).Src_Index := To; + end Set_Source_Index_Of; + + ------------------------ + -- Set_String_Type_Of -- + ------------------------ + + procedure Set_String_Type_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = + N_Variable_Reference + or else + In_Tree.Project_Nodes.Table (Node).Kind = + N_Typed_Variable_Declaration) + and then + In_Tree.Project_Nodes.Table (To).Kind = N_String_Type_Declaration); + + if In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference then + In_Tree.Project_Nodes.Table (Node).Field3 := To; + else + In_Tree.Project_Nodes.Table (Node).Field2 := To; + end if; + end Set_String_Type_Of; + + ------------------------- + -- Set_String_Value_Of -- + ------------------------- + + procedure Set_String_Value_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Name_Id) + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Comment + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String)); + In_Tree.Project_Nodes.Table (Node).Value := To; + end Set_String_Value_Of; + + --------------------- + -- Source_Index_Of -- + --------------------- + + function Source_Index_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Int + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String + or else + In_Tree.Project_Nodes.Table (Node).Kind = + N_Attribute_Declaration)); + return In_Tree.Project_Nodes.Table (Node).Src_Index; + end Source_Index_Of; + + -------------------- + -- String_Type_Of -- + -------------------- + + function String_Type_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = + N_Variable_Reference + or else + In_Tree.Project_Nodes.Table (Node).Kind = + N_Typed_Variable_Declaration)); + + if In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference then + return In_Tree.Project_Nodes.Table (Node).Field3; + else + return In_Tree.Project_Nodes.Table (Node).Field2; + end if; + end String_Type_Of; + + --------------------- + -- String_Value_Of -- + --------------------- + + function String_Value_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Name_Id + is + begin + pragma Assert + (Present (Node) + and then + (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Comment + or else + In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String)); + return In_Tree.Project_Nodes.Table (Node).Value; + end String_Value_Of; + + -------------------- + -- Value_Is_Valid -- + -------------------- + + function Value_Is_Valid + (For_Typed_Variable : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + Value : Name_Id) return Boolean + is + begin + pragma Assert + (Present (For_Typed_Variable) + and then + (In_Tree.Project_Nodes.Table (For_Typed_Variable).Kind = + N_Typed_Variable_Declaration)); + + declare + Current_String : Project_Node_Id := + First_Literal_String + (String_Type_Of (For_Typed_Variable, In_Tree), + In_Tree); + + begin + while Present (Current_String) + and then + String_Value_Of (Current_String, In_Tree) /= Value + loop + Current_String := + Next_Literal_String (Current_String, In_Tree); + end loop; + + return Present (Current_String); + end; + + end Value_Is_Valid; + + ------------------------------- + -- There_Are_Unkept_Comments -- + ------------------------------- + + function There_Are_Unkept_Comments return Boolean is + begin + return Unkept_Comments; + end There_Are_Unkept_Comments; + + -------------------- + -- Create_Project -- + -------------------- + + function Create_Project + (In_Tree : Project_Node_Tree_Ref; + Name : Name_Id; + Full_Path : Path_Name_Type; + Is_Config_File : Boolean := False) return Project_Node_Id + is + Project : Project_Node_Id; + Qualifier : Project_Qualifier := Unspecified; + begin + Project := Default_Project_Node (In_Tree, N_Project); + Set_Name_Of (Project, In_Tree, Name); + Set_Directory_Of + (Project, In_Tree, + Path_Name_Type (Get_Directory (File_Name_Type (Full_Path)))); + Set_Path_Name_Of (Project, In_Tree, Full_Path); + + Set_Project_Declaration_Of + (Project, In_Tree, + Default_Project_Node (In_Tree, N_Project_Declaration)); + + if Is_Config_File then + Qualifier := Configuration; + end if; + + if not Is_Config_File then + Prj.Tree.Tree_Private_Part.Projects_Htable.Set + (In_Tree.Projects_HT, + Name, + Prj.Tree.Tree_Private_Part.Project_Name_And_Node' + (Name => Name, + Display_Name => Name, + Canonical_Path => No_Path, + Node => Project, + Extended => False, + Proj_Qualifier => Qualifier)); + end if; + + return Project; + end Create_Project; + + ---------------- + -- Add_At_End -- + ---------------- + + procedure Add_At_End + (Tree : Project_Node_Tree_Ref; + Parent : Project_Node_Id; + Expr : Project_Node_Id; + Add_Before_First_Pkg : Boolean := False; + Add_Before_First_Case : Boolean := False) + is + Real_Parent : Project_Node_Id; + New_Decl, Decl, Next : Project_Node_Id; + Last, L : Project_Node_Id; + + begin + if Kind_Of (Expr, Tree) /= N_Declarative_Item then + New_Decl := Default_Project_Node (Tree, N_Declarative_Item); + Set_Current_Item_Node (New_Decl, Tree, Expr); + else + New_Decl := Expr; + end if; + + if Kind_Of (Parent, Tree) = N_Project then + Real_Parent := Project_Declaration_Of (Parent, Tree); + else + Real_Parent := Parent; + end if; + + Decl := First_Declarative_Item_Of (Real_Parent, Tree); + + if Decl = Empty_Node then + Set_First_Declarative_Item_Of (Real_Parent, Tree, New_Decl); + else + loop + Next := Next_Declarative_Item (Decl, Tree); + exit when Next = Empty_Node + or else + (Add_Before_First_Pkg + and then Kind_Of (Current_Item_Node (Next, Tree), Tree) = + N_Package_Declaration) + or else + (Add_Before_First_Case + and then Kind_Of (Current_Item_Node (Next, Tree), Tree) = + N_Case_Construction); + Decl := Next; + end loop; + + -- In case Expr is in fact a range of declarative items + + Last := New_Decl; + loop + L := Next_Declarative_Item (Last, Tree); + exit when L = Empty_Node; + Last := L; + end loop; + + -- In case Expr is in fact a range of declarative items + + Last := New_Decl; + loop + L := Next_Declarative_Item (Last, Tree); + exit when L = Empty_Node; + Last := L; + end loop; + + Set_Next_Declarative_Item (Last, Tree, Next); + Set_Next_Declarative_Item (Decl, Tree, New_Decl); + end if; + end Add_At_End; + + --------------------------- + -- Create_Literal_String -- + --------------------------- + + function Create_Literal_String + (Str : Namet.Name_Id; + Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + Node : Project_Node_Id; + begin + Node := Default_Project_Node (Tree, N_Literal_String, Prj.Single); + Set_Next_Literal_String (Node, Tree, Empty_Node); + Set_String_Value_Of (Node, Tree, Str); + return Node; + end Create_Literal_String; + + --------------------------- + -- Enclose_In_Expression -- + --------------------------- + + function Enclose_In_Expression + (Node : Project_Node_Id; + Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + Expr : Project_Node_Id; + begin + if Kind_Of (Node, Tree) /= N_Expression then + Expr := Default_Project_Node (Tree, N_Expression, Single); + Set_First_Term + (Expr, Tree, Default_Project_Node (Tree, N_Term, Single)); + Set_Current_Term (First_Term (Expr, Tree), Tree, Node); + return Expr; + else + return Node; + end if; + end Enclose_In_Expression; + + -------------------- + -- Create_Package -- + -------------------- + + function Create_Package + (Tree : Project_Node_Tree_Ref; + Project : Project_Node_Id; + Pkg : String) return Project_Node_Id + is + Pack : Project_Node_Id; + N : Name_Id; + + begin + Name_Len := Pkg'Length; + Name_Buffer (1 .. Name_Len) := Pkg; + N := Name_Find; + + -- Check if the package already exists + + Pack := First_Package_Of (Project, Tree); + while Pack /= Empty_Node loop + if Prj.Tree.Name_Of (Pack, Tree) = N then + return Pack; + end if; + + Pack := Next_Package_In_Project (Pack, Tree); + end loop; + + -- Create the package and add it to the declarative item + + Pack := Default_Project_Node (Tree, N_Package_Declaration); + Set_Name_Of (Pack, Tree, N); + + -- Find the correct package id to use + + Set_Package_Id_Of (Pack, Tree, Package_Node_Id_Of (N)); + + -- Add it to the list of packages + + Set_Next_Package_In_Project + (Pack, Tree, First_Package_Of (Project, Tree)); + Set_First_Package_Of (Project, Tree, Pack); + + Add_At_End (Tree, Project_Declaration_Of (Project, Tree), Pack); + + return Pack; + end Create_Package; + + ---------------------- + -- Create_Attribute -- + ---------------------- + + function Create_Attribute + (Tree : Project_Node_Tree_Ref; + Prj_Or_Pkg : Project_Node_Id; + Name : Name_Id; + Index_Name : Name_Id := No_Name; + Kind : Variable_Kind := List; + At_Index : Integer := 0; + Value : Project_Node_Id := Empty_Node) return Project_Node_Id + is + Node : constant Project_Node_Id := + Default_Project_Node (Tree, N_Attribute_Declaration, Kind); + + Case_Insensitive : Boolean; + + Pkg : Package_Node_Id; + Start_At : Attribute_Node_Id; + Expr : Project_Node_Id; + + begin + Set_Name_Of (Node, Tree, Name); + + if Index_Name /= No_Name then + Set_Associative_Array_Index_Of (Node, Tree, Index_Name); + end if; + + if Prj_Or_Pkg /= Empty_Node then + Add_At_End (Tree, Prj_Or_Pkg, Node); + end if; + + -- Find out the case sensitivity of the attribute + + if Prj_Or_Pkg /= Empty_Node + and then Kind_Of (Prj_Or_Pkg, Tree) = N_Package_Declaration + then + Pkg := Prj.Attr.Package_Node_Id_Of (Name_Of (Prj_Or_Pkg, Tree)); + Start_At := First_Attribute_Of (Pkg); + else + Start_At := Attribute_First; + end if; + + Start_At := Attribute_Node_Id_Of (Name, Start_At); + Case_Insensitive := + Attribute_Kind_Of (Start_At) = Case_Insensitive_Associative_Array; + Tree.Project_Nodes.Table (Node).Flag1 := Case_Insensitive; + + if At_Index /= 0 then + if Attribute_Kind_Of (Start_At) = + Optional_Index_Associative_Array + or else Attribute_Kind_Of (Start_At) = + Optional_Index_Case_Insensitive_Associative_Array + then + -- Results in: for Name ("index" at index) use "value"; + -- This is currently only used for executables. + + Set_Source_Index_Of (Node, Tree, To => Int (At_Index)); + + else + -- Results in: for Name ("index") use "value" at index; + + -- ??? This limitation makes no sense, we should be able to + -- set the source index on an expression. + + pragma Assert (Kind_Of (Value, Tree) = N_Literal_String); + Set_Source_Index_Of (Value, Tree, To => Int (At_Index)); + end if; + end if; + + if Value /= Empty_Node then + Expr := Enclose_In_Expression (Value, Tree); + Set_Expression_Of (Node, Tree, Expr); + end if; + + return Node; + end Create_Attribute; + +end Prj.Tree; diff --git a/gcc/ada/prj-tree.ads b/gcc/ada/prj-tree.ads new file mode 100644 index 000000000..4cd66c0d2 --- /dev/null +++ b/gcc/ada/prj-tree.ads @@ -0,0 +1,1502 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . T R E E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 structure of the Project File tree + +with GNAT.Dynamic_HTables; +with GNAT.Dynamic_Tables; + +with Table; + +with Prj.Attr; use Prj.Attr; +with Prj.Env; + +package Prj.Tree is + + type Project_Node_Tree_Data; + type Project_Node_Tree_Ref is access all Project_Node_Tree_Data; + -- Type to designate a project node tree, so that several project node + -- trees can coexist in memory. + + Project_Nodes_Initial : constant := 1_000; + Project_Nodes_Increment : constant := 100; + -- Allocation parameters for initializing and extending number + -- of nodes in table Tree_Private_Part.Project_Nodes + + Project_Node_Low_Bound : constant := 0; + Project_Node_High_Bound : constant := 099_999_999; + -- Range of values for project node id's (in practice infinite) + + type Project_Node_Id is range + Project_Node_Low_Bound .. Project_Node_High_Bound; + -- The index of table Tree_Private_Part.Project_Nodes + + Empty_Node : constant Project_Node_Id := Project_Node_Low_Bound; + -- Designates no node in table Project_Nodes + + First_Node_Id : constant Project_Node_Id := Project_Node_Low_Bound + 1; + + subtype Variable_Node_Id is Project_Node_Id; + -- Used to designate a node whose expected kind is one of + -- N_Typed_Variable_Declaration, N_Variable_Declaration or + -- N_Variable_Reference. + + subtype Package_Declaration_Id is Project_Node_Id; + -- Used to designate a node whose expected kind is N_Project_Declaration + + type Project_Node_Kind is + (N_Project, + N_With_Clause, + N_Project_Declaration, + N_Declarative_Item, + N_Package_Declaration, + N_String_Type_Declaration, + N_Literal_String, + N_Attribute_Declaration, + N_Typed_Variable_Declaration, + N_Variable_Declaration, + N_Expression, + N_Term, + N_Literal_String_List, + N_Variable_Reference, + N_External_Value, + N_Attribute_Reference, + N_Case_Construction, + N_Case_Item, + N_Comment_Zones, + N_Comment); + -- Each node in the tree is of a Project_Node_Kind. For the signification + -- of the fields in each node of Project_Node_Kind, look at package + -- Tree_Private_Part. + + function Present (Node : Project_Node_Id) return Boolean; + pragma Inline (Present); + -- Return True if Node /= Empty_Node + + function No (Node : Project_Node_Id) return Boolean; + pragma Inline (No); + -- Return True if Node = Empty_Node + + procedure Initialize (Tree : Project_Node_Tree_Ref); + -- Initialize the Project File tree: empty the Project_Nodes table + -- and reset the Projects_Htable. + + function Default_Project_Node + (In_Tree : Project_Node_Tree_Ref; + Of_Kind : Project_Node_Kind; + And_Expr_Kind : Variable_Kind := Undefined) return Project_Node_Id; + -- Returns a Project_Node_Record with the specified Kind and Expr_Kind. All + -- the other components have default nil values. + -- To create a node for a project itself, see Create_Project below instead + + function Hash (N : Project_Node_Id) return Header_Num; + -- Used for hash tables where the key is a Project_Node_Id + + function Imported_Or_Extended_Project_Of + (Project : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + With_Name : Name_Id) return Project_Node_Id; + -- Return the node of a project imported or extended by project Project and + -- whose name is With_Name. Return Empty_Node if there is no such project. + + -------------- + -- Comments -- + -------------- + + type Comment_State is private; + -- A type to store the values of several global variables related to + -- comments. + + procedure Save (S : out Comment_State); + -- Save in variable S the comment state. Called before scanning a new + -- project file. + + procedure Restore_And_Free (S : in out Comment_State); + -- Restore the comment state to a previously saved value. Called after + -- scanning a project file. Frees the memory occupied by S + + procedure Reset_State; + -- Set the comment state to its initial value. Called before scanning a + -- new project file. + + function There_Are_Unkept_Comments return Boolean; + -- Indicates that some of the comments in a project file could not be + -- stored in the parse tree. + + procedure Set_Previous_Line_Node (To : Project_Node_Id); + -- Indicate the node on the previous line. If there are comments + -- immediately following this line, then they should be associated with + -- this node. + + procedure Set_Previous_End_Node (To : Project_Node_Id); + -- Indicate that on the previous line the "end" belongs to node To. + -- If there are comments immediately following this "end" line, they + -- should be associated with this node. + + procedure Set_End_Of_Line (To : Project_Node_Id); + -- Indicate the node on the current line. If there is an end of line + -- comment, then it should be associated with this node. + + procedure Set_Next_End_Node (To : Project_Node_Id); + -- Put node To on the top of the end node stack. When an END line is found + -- with this node on the top of the end node stack, the comments, if any, + -- immediately preceding this "end" line will be associated with this node. + + procedure Remove_Next_End_Node; + -- Remove the top of the end node stack + + ------------------------ + -- Comment Processing -- + ------------------------ + + type Comment_Data is record + Value : Name_Id := No_Name; + Follows_Empty_Line : Boolean := False; + Is_Followed_By_Empty_Line : Boolean := False; + end record; + -- Component type for Comments Table below + + package Comments is new Table.Table + (Table_Component_Type => Comment_Data, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Prj.Tree.Comments"); + -- A table to store the comments that may be stored is the tree + + procedure Scan (In_Tree : Project_Node_Tree_Ref); + -- Scan the tokens and accumulate comments + + type Comment_Location is + (Before, After, Before_End, After_End, End_Of_Line); + -- Used in call to Add_Comments below + + procedure Add_Comments + (To : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + Where : Comment_Location); + -- Add comments to this node + + ---------------------- + -- Access Functions -- + ---------------------- + + -- The following query functions are part of the abstract interface + -- of the Project File tree. They provide access to fields of a project. + + -- The access functions should be called only with valid arguments. + -- For each function the condition of validity is specified. If an access + -- function is called with invalid arguments, then exception + -- Assertion_Error is raised if assertions are enabled, otherwise the + -- behaviour is not defined and may result in a crash. + + function Name_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Name_Id; + pragma Inline (Name_Of); + -- Valid for all non empty nodes. May return No_Name for nodes that have + -- no names. + + function Kind_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Kind; + pragma Inline (Kind_Of); + -- Valid for all non empty nodes + + function Location_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Source_Ptr; + pragma Inline (Location_Of); + -- Valid for all non empty nodes + + function First_Comment_After + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + -- Valid only for N_Comment_Zones nodes + + function First_Comment_After_End + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + -- Valid only for N_Comment_Zones nodes + + function First_Comment_Before + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + -- Valid only for N_Comment_Zones nodes + + function First_Comment_Before_End + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + -- Valid only for N_Comment_Zones nodes + + function Next_Comment + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + -- Valid only for N_Comment nodes + + function End_Of_Line_Comment + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Name_Id; + -- Valid only for non empty nodes + + function Follows_Empty_Line + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Boolean; + -- Valid only for N_Comment nodes + + function Is_Followed_By_Empty_Line + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Boolean; + -- Valid only for N_Comment nodes + + function Parent_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (Parent_Project_Of); + -- Valid only for N_Project nodes + + function Project_File_Includes_Unkept_Comments + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Boolean; + -- Valid only for N_Project nodes + + function Directory_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Path_Name_Type; + pragma Inline (Directory_Of); + -- Returns the directory that contains the project file. This always ends + -- with a directory separator. Only valid for N_Project nodes. + + function Expression_Kind_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Variable_Kind; + pragma Inline (Expression_Kind_Of); + -- Only valid for N_Literal_String, N_Attribute_Declaration, + -- N_Variable_Declaration, N_Typed_Variable_Declaration, N_Expression, + -- N_Term, N_Variable_Reference, N_Attribute_Reference nodes or + -- N_External_Value. + + function Is_Extending_All + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Boolean; + pragma Inline (Is_Extending_All); + -- Only valid for N_Project and N_With_Clause + + function Is_Not_Last_In_List + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Boolean; + pragma Inline (Is_Not_Last_In_List); + -- Only valid for N_With_Clause + + function First_Variable_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Variable_Node_Id; + pragma Inline (First_Variable_Of); + -- Only valid for N_Project or N_Package_Declaration nodes + + function First_Package_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Package_Declaration_Id; + pragma Inline (First_Package_Of); + -- Only valid for N_Project nodes + + function Package_Id_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Package_Node_Id; + pragma Inline (Package_Id_Of); + -- Only valid for N_Package_Declaration nodes + + function Path_Name_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Path_Name_Type; + pragma Inline (Path_Name_Of); + -- Only valid for N_Project and N_With_Clause nodes + + function String_Value_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Name_Id; + pragma Inline (String_Value_Of); + -- Only valid for N_With_Clause, N_Literal_String nodes or N_Comment. + -- For a N_With_Clause created automatically for a virtual extending + -- project, No_Name is returned. + + function Source_Index_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Int; + pragma Inline (Source_Index_Of); + -- Only valid for N_Literal_String and N_Attribute_Declaration nodes + + function First_With_Clause_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (First_With_Clause_Of); + -- Only valid for N_Project nodes + + function Project_Declaration_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (Project_Declaration_Of); + -- Only valid for N_Project nodes + + function Project_Qualifier_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Qualifier; + pragma Inline (Project_Qualifier_Of); + -- Only valid for N_Project nodes + + function Extending_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (Extending_Project_Of); + -- Only valid for N_Project_Declaration nodes + + function First_String_Type_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (First_String_Type_Of); + -- Only valid for N_Project nodes + + function Extended_Project_Path_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Path_Name_Type; + pragma Inline (Extended_Project_Path_Of); + -- Only valid for N_With_Clause nodes + + function Project_Node_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (Project_Node_Of); + -- Only valid for N_With_Clause, N_Variable_Reference and + -- N_Attribute_Reference nodes. + + function Non_Limited_Project_Node_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (Non_Limited_Project_Node_Of); + -- Only valid for N_With_Clause nodes. Returns Empty_Node for limited + -- imported project files, otherwise returns the same result as + -- Project_Node_Of. + + function Next_With_Clause_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (Next_With_Clause_Of); + -- Only valid for N_With_Clause nodes + + function First_Declarative_Item_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (First_Declarative_Item_Of); + -- Only valid for N_Project_Declaration, N_Case_Item and + -- N_Package_Declaration. + + function Extended_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (Extended_Project_Of); + -- Only valid for N_Project_Declaration nodes + + function Current_Item_Node + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (Current_Item_Node); + -- Only valid for N_Declarative_Item nodes + + function Next_Declarative_Item + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (Next_Declarative_Item); + -- Only valid for N_Declarative_Item node + + function Project_Of_Renamed_Package_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (Project_Of_Renamed_Package_Of); + -- Only valid for N_Package_Declaration nodes. May return Empty_Node. + + function Next_Package_In_Project + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (Next_Package_In_Project); + -- Only valid for N_Package_Declaration nodes + + function First_Literal_String + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (First_Literal_String); + -- Only valid for N_String_Type_Declaration nodes + + function Next_String_Type + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (Next_String_Type); + -- Only valid for N_String_Type_Declaration nodes + + function Next_Literal_String + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (Next_Literal_String); + -- Only valid for N_Literal_String nodes + + function Expression_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (Expression_Of); + -- Only valid for N_Attribute_Declaration, N_Typed_Variable_Declaration + -- or N_Variable_Declaration nodes + + function Associative_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) + return Project_Node_Id; + pragma Inline (Associative_Project_Of); + -- Only valid for N_Attribute_Declaration nodes + + function Associative_Package_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) + return Project_Node_Id; + pragma Inline (Associative_Package_Of); + -- Only valid for N_Attribute_Declaration nodes + + function Value_Is_Valid + (For_Typed_Variable : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + Value : Name_Id) return Boolean; + pragma Inline (Value_Is_Valid); + -- Only valid for N_Typed_Variable_Declaration. Returns True if Value is + -- in the list of allowed strings for For_Typed_Variable. False otherwise. + + function Associative_Array_Index_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Name_Id; + pragma Inline (Associative_Array_Index_Of); + -- Only valid for N_Attribute_Declaration and N_Attribute_Reference. + -- Returns No_Name for non associative array attributes. + + function Next_Variable + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (Next_Variable); + -- Only valid for N_Typed_Variable_Declaration or N_Variable_Declaration + -- nodes. + + function First_Term + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (First_Term); + -- Only valid for N_Expression nodes + + function Next_Expression_In_List + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (Next_Expression_In_List); + -- Only valid for N_Expression nodes + + function Current_Term + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (Current_Term); + -- Only valid for N_Term nodes + + function Next_Term + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (Next_Term); + -- Only valid for N_Term nodes + + function First_Expression_In_List + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (First_Expression_In_List); + -- Only valid for N_Literal_String_List nodes + + function Package_Node_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (Package_Node_Of); + -- Only valid for N_Variable_Reference or N_Attribute_Reference nodes. + -- May return Empty_Node. + + function String_Type_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (String_Type_Of); + -- Only valid for N_Variable_Reference or N_Typed_Variable_Declaration + -- nodes. + + function External_Reference_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (External_Reference_Of); + -- Only valid for N_External_Value nodes + + function External_Default_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (External_Default_Of); + -- Only valid for N_External_Value nodes + + function Case_Variable_Reference_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (Case_Variable_Reference_Of); + -- Only valid for N_Case_Construction nodes + + function First_Case_Item_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (First_Case_Item_Of); + -- Only valid for N_Case_Construction nodes + + function First_Choice_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (First_Choice_Of); + -- Only valid for N_Case_Item nodes. Return the first choice in a + -- N_Case_Item, or Empty_Node if this is when others. + + function Next_Case_Item + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (Next_Case_Item); + -- Only valid for N_Case_Item nodes + + function Case_Insensitive + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Boolean; + -- Only valid for N_Attribute_Declaration and N_Attribute_Reference nodes + + ----------------------- + -- Create procedures -- + ----------------------- + -- The following procedures are used to edit a project file tree. They are + -- slightly higher-level than the Set_* procedures below + + function Create_Project + (In_Tree : Project_Node_Tree_Ref; + Name : Name_Id; + Full_Path : Path_Name_Type; + Is_Config_File : Boolean := False) return Project_Node_Id; + -- Create a new node for a project and register it in the tree so that it + -- can be retrieved later on. + + function Create_Package + (Tree : Project_Node_Tree_Ref; + Project : Project_Node_Id; + Pkg : String) return Project_Node_Id; + -- Create a new package in Project. If the package already exists, it is + -- returned. The name of the package *must* be lower-cases, or none of its + -- attributes will be recognized. + + function Create_Attribute + (Tree : Project_Node_Tree_Ref; + Prj_Or_Pkg : Project_Node_Id; + Name : Name_Id; + Index_Name : Name_Id := No_Name; + Kind : Variable_Kind := List; + At_Index : Integer := 0; + Value : Project_Node_Id := Empty_Node) return Project_Node_Id; + -- Create a new attribute. The new declaration is added at the end of the + -- declarative item list for Prj_Or_Pkg (a project or a package), but + -- before any package declaration). No addition is done if Prj_Or_Pkg is + -- Empty_Node. If Index_Name is not "", then if creates an attribute value + -- for a specific index. At_Index is used for the " at " in the naming + -- exceptions. + -- + -- To set the value of the attribute, either provide a value for Value, or + -- use Set_Expression_Of to set the value of the attribute (in which case + -- Enclose_In_Expression might be useful). The former is recommended since + -- it will more correctly handle cases where the index needs to be set on + -- the expression rather than on the index of the attribute (i.e. 'for + -- Specification ("unit") use "file" at 3', versus 'for Executable ("file" + -- at 3) use "name"'). Value must be a N_String_Literal if an index will be + -- added to it. + + function Create_Literal_String + (Str : Namet.Name_Id; + Tree : Project_Node_Tree_Ref) return Project_Node_Id; + -- Create a literal string whose value is Str + + procedure Add_At_End + (Tree : Project_Node_Tree_Ref; + Parent : Project_Node_Id; + Expr : Project_Node_Id; + Add_Before_First_Pkg : Boolean := False; + Add_Before_First_Case : Boolean := False); + -- Add a new declarative item in the list in Parent. This new declarative + -- item will contain Expr (unless Expr is already a declarative item, in + -- which case it is added directly to the list). The new item is inserted + -- at the end of the list, unless Add_Before_First_Pkg is True. In the + -- latter case, it is added just before the first case construction is + -- seen, or before the first package (this assumes that all packages are + -- found at the end of the project, which isn't true in the general case + -- unless you have normalized the project to match this description). + + function Enclose_In_Expression + (Node : Project_Node_Id; + Tree : Project_Node_Tree_Ref) return Project_Node_Id; + -- Enclose the Node inside a N_Expression node, and return this expression. + -- This does nothing if Node is already a N_Expression. + + -------------------- + -- Set Procedures -- + -------------------- + + -- The following procedures are part of the abstract interface of the + -- Project File tree. + + -- Foe each Set_* procedure the condition of validity is specified. If an + -- access function is called with invalid arguments, then exception + -- Assertion_Error is raised if assertions are enabled, otherwise the + -- behaviour is not defined and may result in a crash. + + -- These are very low-level, and manipulate the tree itself directly. You + -- should look at the Create_* procedure instead if you want to use higher + -- level constructs + + procedure Set_Name_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Name_Id); + pragma Inline (Set_Name_Of); + -- Valid for all non empty nodes. + + procedure Set_Kind_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Kind); + pragma Inline (Set_Kind_Of); + -- Valid for all non empty nodes + + procedure Set_Location_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Source_Ptr); + pragma Inline (Set_Location_Of); + -- Valid for all non empty nodes + + procedure Set_First_Comment_After + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_First_Comment_After); + -- Valid only for N_Comment_Zones nodes + + procedure Set_First_Comment_After_End + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_First_Comment_After_End); + -- Valid only for N_Comment_Zones nodes + + procedure Set_First_Comment_Before + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_First_Comment_Before); + -- Valid only for N_Comment_Zones nodes + + procedure Set_First_Comment_Before_End + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_First_Comment_Before_End); + -- Valid only for N_Comment_Zones nodes + + procedure Set_Next_Comment + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_Next_Comment); + -- Valid only for N_Comment nodes + + procedure Set_Parent_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + -- Valid only for N_Project nodes + + procedure Set_Project_File_Includes_Unkept_Comments + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Boolean); + -- Valid only for N_Project nodes + + procedure Set_Directory_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Path_Name_Type); + pragma Inline (Set_Directory_Of); + -- Valid only for N_Project nodes + + procedure Set_Expression_Kind_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Variable_Kind); + pragma Inline (Set_Expression_Kind_Of); + -- Only valid for N_Literal_String, N_Attribute_Declaration, + -- N_Variable_Declaration, N_Typed_Variable_Declaration, N_Expression, + -- N_Term, N_Variable_Reference, N_Attribute_Reference or N_External_Value + -- nodes. + + procedure Set_Is_Extending_All + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref); + pragma Inline (Set_Is_Extending_All); + -- Only valid for N_Project and N_With_Clause + + procedure Set_Is_Not_Last_In_List + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref); + pragma Inline (Set_Is_Not_Last_In_List); + -- Only valid for N_With_Clause + + procedure Set_First_Variable_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Variable_Node_Id); + pragma Inline (Set_First_Variable_Of); + -- Only valid for N_Project or N_Package_Declaration nodes + + procedure Set_First_Package_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Package_Declaration_Id); + pragma Inline (Set_First_Package_Of); + -- Only valid for N_Project nodes + + procedure Set_Package_Id_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Package_Node_Id); + pragma Inline (Set_Package_Id_Of); + -- Only valid for N_Package_Declaration nodes + + procedure Set_Path_Name_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Path_Name_Type); + pragma Inline (Set_Path_Name_Of); + -- Only valid for N_Project and N_With_Clause nodes + + procedure Set_String_Value_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Name_Id); + pragma Inline (Set_String_Value_Of); + -- Only valid for N_With_Clause, N_Literal_String nodes or N_Comment. + + procedure Set_Source_Index_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Int); + pragma Inline (Set_Source_Index_Of); + -- Only valid for N_Literal_String and N_Attribute_Declaration nodes. For + -- N_Literal_String, set the source index of the literal string. For + -- N_Attribute_Declaration, set the source index of the index of the + -- associative array element. + + procedure Set_First_With_Clause_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_First_With_Clause_Of); + -- Only valid for N_Project nodes + + procedure Set_Project_Declaration_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_Project_Declaration_Of); + -- Only valid for N_Project nodes + + procedure Set_Project_Qualifier_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Qualifier); + pragma Inline (Set_Project_Qualifier_Of); + -- Only valid for N_Project nodes + + procedure Set_Extending_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_Extending_Project_Of); + -- Only valid for N_Project_Declaration nodes + + procedure Set_First_String_Type_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_First_String_Type_Of); + -- Only valid for N_Project nodes + + procedure Set_Extended_Project_Path_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Path_Name_Type); + pragma Inline (Set_Extended_Project_Path_Of); + -- Only valid for N_With_Clause nodes + + procedure Set_Project_Node_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id; + Limited_With : Boolean := False); + pragma Inline (Set_Project_Node_Of); + -- Only valid for N_With_Clause, N_Variable_Reference and + -- N_Attribute_Reference nodes. + + procedure Set_Next_With_Clause_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_Next_With_Clause_Of); + -- Only valid for N_With_Clause nodes + + procedure Set_First_Declarative_Item_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_First_Declarative_Item_Of); + -- Only valid for N_Project_Declaration, N_Case_Item and + -- N_Package_Declaration. + + procedure Set_Extended_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_Extended_Project_Of); + -- Only valid for N_Project_Declaration nodes + + procedure Set_Current_Item_Node + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_Current_Item_Node); + -- Only valid for N_Declarative_Item nodes + + procedure Set_Next_Declarative_Item + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_Next_Declarative_Item); + -- Only valid for N_Declarative_Item node + + procedure Set_Project_Of_Renamed_Package_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_Project_Of_Renamed_Package_Of); + -- Only valid for N_Package_Declaration nodes. + + procedure Set_Next_Package_In_Project + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_Next_Package_In_Project); + -- Only valid for N_Package_Declaration nodes + + procedure Set_First_Literal_String + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_First_Literal_String); + -- Only valid for N_String_Type_Declaration nodes + + procedure Set_Next_String_Type + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_Next_String_Type); + -- Only valid for N_String_Type_Declaration nodes + + procedure Set_Next_Literal_String + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_Next_Literal_String); + -- Only valid for N_Literal_String nodes + + procedure Set_Expression_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_Expression_Of); + -- Only valid for N_Attribute_Declaration, N_Typed_Variable_Declaration + -- or N_Variable_Declaration nodes + + procedure Set_Associative_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_Associative_Project_Of); + -- Only valid for N_Attribute_Declaration nodes + + procedure Set_Associative_Package_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_Associative_Package_Of); + -- Only valid for N_Attribute_Declaration nodes + + procedure Set_Associative_Array_Index_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Name_Id); + pragma Inline (Set_Associative_Array_Index_Of); + -- Only valid for N_Attribute_Declaration and N_Attribute_Reference. + + procedure Set_Next_Variable + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_Next_Variable); + -- Only valid for N_Typed_Variable_Declaration or N_Variable_Declaration + -- nodes. + + procedure Set_First_Term + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_First_Term); + -- Only valid for N_Expression nodes + + procedure Set_Next_Expression_In_List + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_Next_Expression_In_List); + -- Only valid for N_Expression nodes + + procedure Set_Current_Term + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_Current_Term); + -- Only valid for N_Term nodes + + procedure Set_Next_Term + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_Next_Term); + -- Only valid for N_Term nodes + + procedure Set_First_Expression_In_List + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_First_Expression_In_List); + -- Only valid for N_Literal_String_List nodes + + procedure Set_Package_Node_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_Package_Node_Of); + -- Only valid for N_Variable_Reference or N_Attribute_Reference nodes. + + procedure Set_String_Type_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_String_Type_Of); + -- Only valid for N_Variable_Reference or N_Typed_Variable_Declaration + -- nodes. + + procedure Set_External_Reference_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_External_Reference_Of); + -- Only valid for N_External_Value nodes + + procedure Set_External_Default_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_External_Default_Of); + -- Only valid for N_External_Value nodes + + procedure Set_Case_Variable_Reference_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_Case_Variable_Reference_Of); + -- Only valid for N_Case_Construction nodes + + procedure Set_First_Case_Item_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_First_Case_Item_Of); + -- Only valid for N_Case_Construction nodes + + procedure Set_First_Choice_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_First_Choice_Of); + -- Only valid for N_Case_Item nodes. + + procedure Set_Next_Case_Item + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + pragma Inline (Set_Next_Case_Item); + -- Only valid for N_Case_Item nodes. + + procedure Set_Case_Insensitive + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Boolean); + -- Only valid for N_Attribute_Declaration and N_Attribute_Reference nodes + + ------------------------------- + -- Restricted Access Section -- + ------------------------------- + + package Tree_Private_Part is + + -- This is conceptually in the private part. However, for efficiency, + -- some packages are accessing it directly. + + type Project_Node_Record is record + + Kind : Project_Node_Kind; + + Qualifier : Project_Qualifier := Unspecified; + + Location : Source_Ptr := No_Location; + + Directory : Path_Name_Type := No_Path; + -- Only for N_Project + + Expr_Kind : Variable_Kind := Undefined; + -- See below for what Project_Node_Kind it is used + + Variables : Variable_Node_Id := Empty_Node; + -- First variable in a project or a package + + Packages : Package_Declaration_Id := Empty_Node; + -- First package declaration in a project + + Pkg_Id : Package_Node_Id := Empty_Package; + -- Only used for N_Package_Declaration + -- + -- The component Pkg_Id is an entry into the table Package_Attributes + -- (in Prj.Attr). It is used to indicate all the attributes of the + -- package with their characteristics. + -- + -- The tables Prj.Attr.Attributes and Prj.Attr.Package_Attributes + -- are built once and for all through a call (from Prj.Initialize) + -- to procedure Prj.Attr.Initialize. It is never modified after that. + + Name : Name_Id := No_Name; + -- See below for what Project_Node_Kind it is used + + Src_Index : Int := 0; + -- Index of a unit in a multi-unit source. + -- Only for some N_Attribute_Declaration and N_Literal_String. + + Path_Name : Path_Name_Type := No_Path; + -- See below for what Project_Node_Kind it is used + + Value : Name_Id := No_Name; + -- See below for what Project_Node_Kind it is used + + Field1 : Project_Node_Id := Empty_Node; + -- See below the meaning for each Project_Node_Kind + + Field2 : Project_Node_Id := Empty_Node; + -- See below the meaning for each Project_Node_Kind + + Field3 : Project_Node_Id := Empty_Node; + -- See below the meaning for each Project_Node_Kind + + Field4 : Project_Node_Id := Empty_Node; + -- See below the meaning for each Project_Node_Kind + + Flag1 : Boolean := False; + -- This flag is significant only for: + -- + -- N_Attribute_Declaration and N_Attribute_Reference + -- Indicates for an associative array attribute, that the + -- index is case insensitive. + -- + -- N_Comment + -- Indicates that the comment is preceded by an empty line. + -- + -- N_Project + -- Indicates that there are comments in the project source that + -- cannot be kept in the tree. + -- + -- N_Project_Declaration + -- Indicates that there are unkept comments in the project. + -- + -- N_With_Clause + -- Indicates that this is not the last with in a with clause. + -- Set for "A", but not for "B" in with "B"; and with "A", "B"; + + Flag2 : Boolean := False; + -- This flag is significant only for: + -- + -- N_Project + -- Indicates that the project "extends all" another project. + -- + -- N_Comment + -- Indicates that the comment is followed by an empty line. + -- + -- N_With_Clause + -- Indicates that the originally imported project is an extending + -- all project. + + Comments : Project_Node_Id := Empty_Node; + -- For nodes other that N_Comment_Zones or N_Comment, designates the + -- comment zones associated with the node. + -- + -- For N_Comment_Zones, designates the comment after the "end" of + -- the construct. + -- + -- For N_Comment, designates the next comment, if any. + + end record; + + -- type Project_Node_Kind is + + -- (N_Project, + -- -- Name: project name + -- -- Path_Name: project path name + -- -- Expr_Kind: Undefined + -- -- Field1: first with clause + -- -- Field2: project declaration + -- -- Field3: first string type + -- -- Field4: parent project, if any + -- -- Value: extended project path name (if any) + + -- N_With_Clause, + -- -- Name: imported project name + -- -- Path_Name: imported project path name + -- -- Expr_Kind: Undefined + -- -- Field1: project node + -- -- Field2: next with clause + -- -- Field3: project node or empty if "limited with" + -- -- Field4: not used + -- -- Value: literal string withed + + -- N_Project_Declaration, + -- -- Name: not used + -- -- Path_Name: not used + -- -- Expr_Kind: Undefined + -- -- Field1: first declarative item + -- -- Field2: extended project + -- -- Field3: extending project + -- -- Field4: not used + -- -- Value: not used + + -- N_Declarative_Item, + -- -- Name: not used + -- -- Path_Name: not used + -- -- Expr_Kind: Undefined + -- -- Field1: current item node + -- -- Field2: next declarative item + -- -- Field3: not used + -- -- Field4: not used + -- -- Value: not used + + -- N_Package_Declaration, + -- -- Name: package name + -- -- Path_Name: not used + -- -- Expr_Kind: Undefined + -- -- Field1: project of renamed package (if any) + -- -- Field2: first declarative item + -- -- Field3: next package in project + -- -- Field4: not used + -- -- Value: not used + + -- N_String_Type_Declaration, + -- -- Name: type name + -- -- Path_Name: not used + -- -- Expr_Kind: Undefined + -- -- Field1: first literal string + -- -- Field2: next string type + -- -- Field3: not used + -- -- Field4: not used + -- -- Value: not used + + -- N_Literal_String, + -- -- Name: not used + -- -- Path_Name: not used + -- -- Expr_Kind: Single + -- -- Field1: next literal string + -- -- Field2: not used + -- -- Field3: not used + -- -- Field4: not used + -- -- Value: string value + + -- N_Attribute_Declaration, + -- -- Name: attribute name + -- -- Path_Name: not used + -- -- Expr_Kind: attribute kind + -- -- Field1: expression + -- -- Field2: project of full associative array + -- -- Field3: package of full associative array + -- -- Field4: not used + -- -- Value: associative array index + -- -- (if an associative array element) + + -- N_Typed_Variable_Declaration, + -- -- Name: variable name + -- -- Path_Name: not used + -- -- Expr_Kind: Single + -- -- Field1: expression + -- -- Field2: type of variable (N_String_Type_Declaration) + -- -- Field3: next variable + -- -- Field4: not used + -- -- Value: not used + + -- N_Variable_Declaration, + -- -- Name: variable name + -- -- Path_Name: not used + -- -- Expr_Kind: variable kind + -- -- Field1: expression + -- -- Field2: not used + -- -- Field3 is used for next variable, instead of Field2, + -- -- so that it is the same field for + -- -- N_Variable_Declaration and + -- -- N_Typed_Variable_Declaration + -- -- Field3: next variable + -- -- Field4: not used + -- -- Value: not used + + -- N_Expression, + -- -- Name: not used + -- -- Path_Name: not used + -- -- Expr_Kind: expression kind + -- -- Field1: first term + -- -- Field2: next expression in list + -- -- Field3: not used + -- -- Value: not used + + -- N_Term, + -- -- Name: not used + -- -- Path_Name: not used + -- -- Expr_Kind: term kind + -- -- Field1: current term + -- -- Field2: next term in the expression + -- -- Field3: not used + -- -- Field4: not used + -- -- Value: not used + + -- N_Literal_String_List, + -- -- Designates a list of string expressions between brackets + -- -- separated by commas. The string expressions are not necessarily + -- -- literal strings. + -- -- Name: not used + -- -- Path_Name: not used + -- -- Expr_Kind: List + -- -- Field1: first expression + -- -- Field2: not used + -- -- Field3: not used + -- -- Field4: not used + -- -- Value: not used + + -- N_Variable_Reference, + -- -- Name: variable name + -- -- Path_Name: not used + -- -- Expr_Kind: variable kind + -- -- Field1: project (if specified) + -- -- Field2: package (if specified) + -- -- Field3: type of variable (N_String_Type_Declaration), if any + -- -- Field4: not used + -- -- Value: not used + + -- N_External_Value, + -- -- Name: not used + -- -- Path_Name: not used + -- -- Expr_Kind: Single + -- -- Field1: Name of the external reference (literal string) + -- -- Field2: Default (literal string) + -- -- Field3: not used + -- -- Value: not used + + -- N_Attribute_Reference, + -- -- Name: attribute name + -- -- Path_Name: not used + -- -- Expr_Kind: attribute kind + -- -- Field1: project + -- -- Field2: package (if attribute of a package) + -- -- Field3: not used + -- -- Field4: not used + -- -- Value: associative array index + -- -- (if an associative array element) + + -- N_Case_Construction, + -- -- Name: not used + -- -- Path_Name: not used + -- -- Expr_Kind: Undefined + -- -- Field1: case variable reference + -- -- Field2: first case item + -- -- Field3: not used + -- -- Field4: not used + -- -- Value: not used + + -- N_Case_Item + -- -- Name: not used + -- -- Path_Name: not used + -- -- Expr_Kind: not used + -- -- Field1: first choice (literal string), or Empty_Node + -- -- for when others + -- -- Field2: first declarative item + -- -- Field3: next case item + -- -- Field4: not used + -- -- Value: not used + + -- N_Comment_zones + -- -- Name: not used + -- -- Path_Name: not used + -- -- Expr_Kind: not used + -- -- Field1: comment before the construct + -- -- Field2: comment after the construct + -- -- Field3: comment before the "end" of the construct + -- -- Value: end of line comment + -- -- Field4: not used + -- -- Comments: comment after the "end" of the construct + + -- N_Comment + -- -- Name: not used + -- -- Path_Name: not used + -- -- Expr_Kind: not used + -- -- Field1: not used + -- -- Field2: not used + -- -- Field3: not used + -- -- Field4: not used + -- -- Value: comment + -- -- Flag1: comment is preceded by an empty line + -- -- Flag2: comment is followed by an empty line + -- -- Comments: next comment + + package Project_Node_Table is new + GNAT.Dynamic_Tables + (Table_Component_Type => Project_Node_Record, + Table_Index_Type => Project_Node_Id, + Table_Low_Bound => First_Node_Id, + Table_Initial => Project_Nodes_Initial, + Table_Increment => Project_Nodes_Increment); + -- Table contains the syntactic tree of project data from project files + + type Project_Name_And_Node is record + Name : Name_Id; + -- Name of the project + + Display_Name : Name_Id; + -- The name of the project as it appears in the .gpr file + + Node : Project_Node_Id; + -- Node of the project in table Project_Nodes + + Canonical_Path : Path_Name_Type; + -- Resolved and canonical path of a real project file. + -- No_Name in case of virtual projects. + + Extended : Boolean; + -- True when the project is being extended by another project + + Proj_Qualifier : Project_Qualifier; + -- The project qualifier of the project, if any + end record; + + No_Project_Name_And_Node : constant Project_Name_And_Node := + (Name => No_Name, + Display_Name => No_Name, + Node => Empty_Node, + Canonical_Path => No_Path, + Extended => True, + Proj_Qualifier => Unspecified); + + package Projects_Htable is new GNAT.Dynamic_HTables.Simple_HTable + (Header_Num => Header_Num, + Element => Project_Name_And_Node, + No_Element => No_Project_Name_And_Node, + Key => Name_Id, + Hash => Hash, + Equal => "="); + -- This hash table contains a mapping of project names to project nodes. + -- Note that this hash table contains only the nodes whose Kind is + -- N_Project. It is used to find the node of a project from its name, + -- and to verify if a project has already been parsed, knowing its name. + + end Tree_Private_Part; + + package Name_To_Name_HTable is new GNAT.Dynamic_HTables.Simple_HTable + (Header_Num => Header_Num, + Element => Name_Id, + No_Element => No_Name, + Key => Name_Id, + Hash => Hash, + Equal => "="); + -- General type for htables associating name_id to name_id. This is in + -- particular used to store the values of external references. + + type Project_Node_Tree_Data is record + Project_Nodes : Tree_Private_Part.Project_Node_Table.Instance; + Projects_HT : Tree_Private_Part.Projects_Htable.Instance; + + External_References : Name_To_Name_HTable.Instance; + -- External references are stored in this hash table (and manipulated + -- through subprograms in prj-ext.ads). External references are + -- project-tree specific so that one can load the same tree twice but + -- have two views of it, for instance. + + Target_Name : String_Access := null; + -- The target name, if any, specified with the gprbuild or gprclean + -- switch --target=. + + Project_Path : aliased Prj.Env.Project_Search_Path; + -- The project path is tree specific, since we might want to load + -- simultaneously multiple projects, each with its own search path, in + -- particular when using different compilers with different default + -- search directories. + end record; + + procedure Free (Proj : in out Project_Node_Tree_Ref); + -- Free memory used by Prj + +private + type Comment_Array is array (Positive range <>) of Comment_Data; + type Comments_Ptr is access Comment_Array; + + type Comment_State is record + End_Of_Line_Node : Project_Node_Id := Empty_Node; + Previous_Line_Node : Project_Node_Id := Empty_Node; + Previous_End_Node : Project_Node_Id := Empty_Node; + Unkept_Comments : Boolean := False; + Comments : Comments_Ptr := null; + end record; + +end Prj.Tree; diff --git a/gcc/ada/prj-util.adb b/gcc/ada/prj-util.adb new file mode 100644 index 000000000..494b04c48 --- /dev/null +++ b/gcc/ada/prj-util.adb @@ -0,0 +1,1191 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . U T I L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 GNAT.Case_Util; use GNAT.Case_Util; +with GNAT.Regexp; use GNAT.Regexp; + +with Osint; use Osint; +with Output; use Output; +with Opt; +with Prj.Com; +with Snames; use Snames; +with Table; +with Targparm; use Targparm; + +with GNAT.HTable; + +package body Prj.Util is + + package Source_Info_Table is new Table.Table + (Table_Component_Type => Source_Info_Iterator, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Makeutl.Source_Info_Table"); + + package Source_Info_Project_HTable is new GNAT.HTable.Simple_HTable + (Header_Num => Prj.Header_Num, + Element => Natural, + No_Element => 0, + Key => Name_Id, + Hash => Prj.Hash, + Equal => "="); + + procedure Free is new Ada.Unchecked_Deallocation + (Text_File_Data, Text_File); + + ----------- + -- Close -- + ----------- + + procedure Close (File : in out Text_File) is + Len : Integer; + Status : Boolean; + + begin + if File = null then + Prj.Com.Fail ("Close attempted on an invalid Text_File"); + end if; + + if File.Out_File then + if File.Buffer_Len > 0 then + Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len); + + if Len /= File.Buffer_Len then + Prj.Com.Fail ("Unable to write to an out Text_File"); + end if; + end if; + + Close (File.FD, Status); + + if not Status then + Prj.Com.Fail ("Unable to close an out Text_File"); + end if; + + else + + -- Close in file, no need to test status, since this is a file that + -- we read, and the file was read successfully before we closed it. + + Close (File.FD); + end if; + + Free (File); + end Close; + + ------------ + -- Create -- + ------------ + + procedure Create (File : out Text_File; Name : String) is + FD : File_Descriptor; + File_Name : String (1 .. Name'Length + 1); + + begin + File_Name (1 .. Name'Length) := Name; + File_Name (File_Name'Last) := ASCII.NUL; + FD := Create_File (Name => File_Name'Address, + Fmode => GNAT.OS_Lib.Text); + + if FD = Invalid_FD then + File := null; + + else + File := new Text_File_Data; + File.FD := FD; + File.Out_File := True; + File.End_Of_File_Reached := True; + end if; + end Create; + + --------------- + -- Duplicate -- + --------------- + + procedure Duplicate + (This : in out Name_List_Index; + In_Tree : Project_Tree_Ref) + is + Old_Current : Name_List_Index; + New_Current : Name_List_Index; + + begin + if This /= No_Name_List then + Old_Current := This; + Name_List_Table.Increment_Last (In_Tree.Name_Lists); + New_Current := Name_List_Table.Last (In_Tree.Name_Lists); + This := New_Current; + In_Tree.Name_Lists.Table (New_Current) := + (In_Tree.Name_Lists.Table (Old_Current).Name, No_Name_List); + + loop + Old_Current := In_Tree.Name_Lists.Table (Old_Current).Next; + exit when Old_Current = No_Name_List; + In_Tree.Name_Lists.Table (New_Current).Next := New_Current + 1; + Name_List_Table.Increment_Last (In_Tree.Name_Lists); + New_Current := New_Current + 1; + In_Tree.Name_Lists.Table (New_Current) := + (In_Tree.Name_Lists.Table (Old_Current).Name, No_Name_List); + end loop; + end if; + end Duplicate; + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File (File : Text_File) return Boolean is + begin + if File = null then + Prj.Com.Fail ("End_Of_File attempted on an invalid Text_File"); + end if; + + return File.End_Of_File_Reached; + end End_Of_File; + + ------------------- + -- Executable_Of -- + ------------------- + + function Executable_Of + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Main : File_Name_Type; + Index : Int; + Ada_Main : Boolean := True; + Language : String := ""; + Include_Suffix : Boolean := True) return File_Name_Type + is + pragma Assert (Project /= No_Project); + + The_Packages : constant Package_Id := Project.Decl.Packages; + + Builder_Package : constant Prj.Package_Id := + Prj.Util.Value_Of + (Name => Name_Builder, + In_Packages => The_Packages, + In_Tree => In_Tree); + + Executable : Variable_Value := + Prj.Util.Value_Of + (Name => Name_Id (Main), + Index => Index, + Attribute_Or_Array_Name => Name_Executable, + In_Package => Builder_Package, + In_Tree => In_Tree); + + Lang : Language_Ptr; + + Spec_Suffix : Name_Id := No_Name; + Body_Suffix : Name_Id := No_Name; + + Spec_Suffix_Length : Natural := 0; + Body_Suffix_Length : Natural := 0; + + procedure Get_Suffixes + (B_Suffix : File_Name_Type; + S_Suffix : File_Name_Type); + -- Get the non empty suffixes in variables Spec_Suffix and Body_Suffix + + function Add_Suffix (File : File_Name_Type) return File_Name_Type; + -- Return the name of the executable, based on File, and adding the + -- executable suffix if needed + + ------------------ + -- Get_Suffixes -- + ------------------ + + procedure Get_Suffixes + (B_Suffix : File_Name_Type; + S_Suffix : File_Name_Type) + is + begin + if B_Suffix /= No_File then + Body_Suffix := Name_Id (B_Suffix); + Body_Suffix_Length := Natural (Length_Of_Name (Body_Suffix)); + end if; + + if S_Suffix /= No_File then + Spec_Suffix := Name_Id (S_Suffix); + Spec_Suffix_Length := Natural (Length_Of_Name (Spec_Suffix)); + end if; + end Get_Suffixes; + + ---------------- + -- Add_Suffix -- + ---------------- + + function Add_Suffix (File : File_Name_Type) return File_Name_Type is + Saved_EEOT : constant Name_Id := Executable_Extension_On_Target; + Result : File_Name_Type; + Suffix_From_Project : Variable_Value; + begin + if Include_Suffix then + if Project.Config.Executable_Suffix /= No_Name then + Executable_Extension_On_Target := + Project.Config.Executable_Suffix; + end if; + + Result := Executable_Name (File); + Executable_Extension_On_Target := Saved_EEOT; + return Result; + + elsif Builder_Package /= No_Package then + + -- If the suffix is specified in the project itself, as opposed to + -- the config file, it needs to be taken into account. However, + -- when the project was processed, in both cases the suffix was + -- stored in Project.Config, so get it from the project again. + + Suffix_From_Project := + Prj.Util.Value_Of + (Variable_Name => Name_Executable_Suffix, + In_Variables => + In_Tree.Packages.Table (Builder_Package).Decl.Attributes, + In_Tree => In_Tree); + + if Suffix_From_Project /= Nil_Variable_Value + and then Suffix_From_Project.Value /= No_Name + then + Executable_Extension_On_Target := Suffix_From_Project.Value; + Result := Executable_Name (File); + Executable_Extension_On_Target := Saved_EEOT; + return Result; + end if; + end if; + + return File; + end Add_Suffix; + + -- Start of processing for Executable_Of + + begin + if Ada_Main then + Lang := Get_Language_From_Name (Project, "ada"); + elsif Language /= "" then + Lang := Get_Language_From_Name (Project, Language); + end if; + + if Lang /= null then + Get_Suffixes + (B_Suffix => Lang.Config.Naming_Data.Body_Suffix, + S_Suffix => Lang.Config.Naming_Data.Spec_Suffix); + end if; + + if Builder_Package /= No_Package then + if Executable = Nil_Variable_Value and then Ada_Main then + Get_Name_String (Main); + + -- Try as index the name minus the implementation suffix or minus + -- the specification suffix. + + declare + Name : constant String (1 .. Name_Len) := + Name_Buffer (1 .. Name_Len); + Last : Positive := Name_Len; + + Truncated : Boolean := False; + + begin + if Body_Suffix /= No_Name + and then Last > Natural (Length_Of_Name (Body_Suffix)) + and then Name (Last - Body_Suffix_Length + 1 .. Last) = + Get_Name_String (Body_Suffix) + then + Truncated := True; + Last := Last - Body_Suffix_Length; + end if; + + if Spec_Suffix /= No_Name + and then not Truncated + and then Last > Spec_Suffix_Length + and then Name (Last - Spec_Suffix_Length + 1 .. Last) = + Get_Name_String (Spec_Suffix) + then + Truncated := True; + Last := Last - Spec_Suffix_Length; + end if; + + if Truncated then + Name_Len := Last; + Name_Buffer (1 .. Name_Len) := Name (1 .. Last); + Executable := + Prj.Util.Value_Of + (Name => Name_Find, + Index => 0, + Attribute_Or_Array_Name => Name_Executable, + In_Package => Builder_Package, + In_Tree => In_Tree); + end if; + end; + end if; + + -- If we have found an Executable attribute, return its value, + -- possibly suffixed by the executable suffix. + + if Executable /= Nil_Variable_Value + and then Executable.Value /= No_Name + and then Length_Of_Name (Executable.Value) /= 0 + then + return Add_Suffix (File_Name_Type (Executable.Value)); + end if; + end if; + + Get_Name_String (Main); + + -- If there is a body suffix or a spec suffix, remove this suffix, + -- otherwise remove any suffix ('.' followed by other characters), if + -- there is one. + + if Body_Suffix /= No_Name + and then Name_Len > Body_Suffix_Length + and then Name_Buffer (Name_Len - Body_Suffix_Length + 1 .. Name_Len) = + Get_Name_String (Body_Suffix) + then + -- Found the body termination, remove it + + Name_Len := Name_Len - Body_Suffix_Length; + + elsif Spec_Suffix /= No_Name + and then Name_Len > Spec_Suffix_Length + and then + Name_Buffer (Name_Len - Spec_Suffix_Length + 1 .. Name_Len) = + Get_Name_String (Spec_Suffix) + then + -- Found the spec termination, remove it + + Name_Len := Name_Len - Spec_Suffix_Length; + + else + -- Remove any suffix, if there is one + + Get_Name_String (Strip_Suffix (Main)); + end if; + + return Add_Suffix (Name_Find); + end Executable_Of; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line + (File : Text_File; + Line : out String; + Last : out Natural) + is + C : Character; + + procedure Advance; + + ------------- + -- Advance -- + ------------- + + procedure Advance is + begin + if File.Cursor = File.Buffer_Len then + File.Buffer_Len := + Read + (FD => File.FD, + A => File.Buffer'Address, + N => File.Buffer'Length); + + if File.Buffer_Len = 0 then + File.End_Of_File_Reached := True; + return; + else + File.Cursor := 1; + end if; + + else + File.Cursor := File.Cursor + 1; + end if; + end Advance; + + -- Start of processing for Get_Line + + begin + if File = null then + Prj.Com.Fail ("Get_Line attempted on an invalid Text_File"); + + elsif File.Out_File then + Prj.Com.Fail ("Get_Line attempted on an out file"); + end if; + + Last := Line'First - 1; + + if not File.End_Of_File_Reached then + loop + C := File.Buffer (File.Cursor); + exit when C = ASCII.CR or else C = ASCII.LF; + Last := Last + 1; + Line (Last) := C; + Advance; + + if File.End_Of_File_Reached then + return; + end if; + + exit when Last = Line'Last; + end loop; + + if C = ASCII.CR or else C = ASCII.LF then + Advance; + + if File.End_Of_File_Reached then + return; + end if; + end if; + + if C = ASCII.CR + and then File.Buffer (File.Cursor) = ASCII.LF + then + Advance; + end if; + end if; + end Get_Line; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize + (Iter : out Source_Info_Iterator; + For_Project : Name_Id) + is + Ind : constant Natural := Source_Info_Project_HTable.Get (For_Project); + begin + if Ind = 0 then + Iter := (No_Source_Info, 0); + else + Iter := Source_Info_Table.Table (Ind); + end if; + end Initialize; + + -------------- + -- Is_Valid -- + -------------- + + function Is_Valid (File : Text_File) return Boolean is + begin + return File /= null; + end Is_Valid; + + ---------- + -- Next -- + ---------- + + procedure Next (Iter : in out Source_Info_Iterator) is + begin + if Iter.Next = 0 then + Iter.Info := No_Source_Info; + + else + Iter := Source_Info_Table.Table (Iter.Next); + end if; + end Next; + + ---------- + -- Open -- + ---------- + + procedure Open (File : out Text_File; Name : String) is + FD : File_Descriptor; + File_Name : String (1 .. Name'Length + 1); + + begin + File_Name (1 .. Name'Length) := Name; + File_Name (File_Name'Last) := ASCII.NUL; + FD := Open_Read (Name => File_Name'Address, + Fmode => GNAT.OS_Lib.Text); + + if FD = Invalid_FD then + File := null; + + else + File := new Text_File_Data; + File.FD := FD; + File.Buffer_Len := + Read (FD => FD, + A => File.Buffer'Address, + N => File.Buffer'Length); + + if File.Buffer_Len = 0 then + File.End_Of_File_Reached := True; + else + File.Cursor := 1; + end if; + end if; + end Open; + + --------- + -- Put -- + --------- + + procedure Put + (Into_List : in out Name_List_Index; + From_List : String_List_Id; + In_Tree : Project_Tree_Ref; + Lower_Case : Boolean := False) + is + Current_Name : Name_List_Index; + List : String_List_Id; + Element : String_Element; + Last : Name_List_Index := + Name_List_Table.Last (In_Tree.Name_Lists); + Value : Name_Id; + + begin + Current_Name := Into_List; + while Current_Name /= No_Name_List + and then In_Tree.Name_Lists.Table (Current_Name).Next /= No_Name_List + loop + Current_Name := In_Tree.Name_Lists.Table (Current_Name).Next; + end loop; + + List := From_List; + while List /= Nil_String loop + Element := In_Tree.String_Elements.Table (List); + Value := Element.Value; + + if Lower_Case then + Get_Name_String (Value); + To_Lower (Name_Buffer (1 .. Name_Len)); + Value := Name_Find; + end if; + + Name_List_Table.Append + (In_Tree.Name_Lists, (Name => Value, Next => No_Name_List)); + + Last := Last + 1; + + if Current_Name = No_Name_List then + Into_List := Last; + + else + In_Tree.Name_Lists.Table (Current_Name).Next := Last; + end if; + + Current_Name := Last; + + List := Element.Next; + end loop; + end Put; + + procedure Put (File : Text_File; S : String) is + Len : Integer; + begin + if File = null then + Prj.Com.Fail ("Attempted to write on an invalid Text_File"); + + elsif not File.Out_File then + Prj.Com.Fail ("Attempted to write an in Text_File"); + end if; + + if File.Buffer_Len + S'Length > File.Buffer'Last then + -- Write buffer + Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len); + + if Len /= File.Buffer_Len then + Prj.Com.Fail ("Failed to write to an out Text_File"); + end if; + + File.Buffer_Len := 0; + end if; + + File.Buffer (File.Buffer_Len + 1 .. File.Buffer_Len + S'Length) := S; + File.Buffer_Len := File.Buffer_Len + S'Length; + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (File : Text_File; Line : String) is + L : String (1 .. Line'Length + 1); + begin + L (1 .. Line'Length) := Line; + L (L'Last) := ASCII.LF; + Put (File, L); + end Put_Line; + + --------------------------- + -- Read_Source_Info_File -- + --------------------------- + + procedure Read_Source_Info_File (Tree : Project_Tree_Ref) is + File : Text_File; + Info : Source_Info_Iterator; + Proj : Name_Id; + + procedure Report_Error; + + ------------------ + -- Report_Error -- + ------------------ + + procedure Report_Error is + begin + Write_Line ("errors in source info file """ & + Tree.Source_Info_File_Name.all & '"'); + Tree.Source_Info_File_Exists := False; + end Report_Error; + + begin + Source_Info_Project_HTable.Reset; + Source_Info_Table.Init; + + if Tree.Source_Info_File_Name = null then + Tree.Source_Info_File_Exists := False; + return; + end if; + + Open (File, Tree.Source_Info_File_Name.all); + + if not Is_Valid (File) then + if Opt.Verbose_Mode then + Write_Line ("source info file " & Tree.Source_Info_File_Name.all & + " does not exist"); + end if; + + Tree.Source_Info_File_Exists := False; + return; + end if; + + Tree.Source_Info_File_Exists := True; + + if Opt.Verbose_Mode then + Write_Line ("Reading source info file " & + Tree.Source_Info_File_Name.all); + end if; + + Source_Loop : + while not End_Of_File (File) loop + Info := (new Source_Info_Data, 0); + Source_Info_Table.Increment_Last; + + -- project name + Get_Line (File, Name_Buffer, Name_Len); + Proj := Name_Find; + Info.Info.Project := Proj; + Info.Next := Source_Info_Project_HTable.Get (Proj); + Source_Info_Project_HTable.Set (Proj, Source_Info_Table.Last); + + if End_Of_File (File) then + Report_Error; + exit Source_Loop; + end if; + + -- language name + Get_Line (File, Name_Buffer, Name_Len); + Info.Info.Language := Name_Find; + + if End_Of_File (File) then + Report_Error; + exit Source_Loop; + end if; + + -- kind + Get_Line (File, Name_Buffer, Name_Len); + Info.Info.Kind := Source_Kind'Value (Name_Buffer (1 .. Name_Len)); + + if End_Of_File (File) then + Report_Error; + exit Source_Loop; + end if; + + -- display path name + Get_Line (File, Name_Buffer, Name_Len); + Info.Info.Display_Path_Name := Name_Find; + Info.Info.Path_Name := Info.Info.Display_Path_Name; + + if End_Of_File (File) then + Report_Error; + exit Source_Loop; + end if; + + -- optional fields + Option_Loop : + loop + Get_Line (File, Name_Buffer, Name_Len); + exit Option_Loop when Name_Len = 0; + + if Name_Len <= 2 then + Report_Error; + exit Source_Loop; + + else + if Name_Buffer (1 .. 2) = "P=" then + Name_Buffer (1 .. Name_Len - 2) := + Name_Buffer (3 .. Name_Len); + Name_Len := Name_Len - 2; + Info.Info.Path_Name := Name_Find; + + elsif Name_Buffer (1 .. 2) = "U=" then + Name_Buffer (1 .. Name_Len - 2) := + Name_Buffer (3 .. Name_Len); + Name_Len := Name_Len - 2; + Info.Info.Unit_Name := Name_Find; + + elsif Name_Buffer (1 .. 2) = "I=" then + Info.Info.Index := Int'Value (Name_Buffer (3 .. Name_Len)); + + elsif Name_Buffer (1 .. Name_Len) = "N=T" then + Info.Info.Naming_Exception := True; + + else + Report_Error; + exit Source_Loop; + end if; + end if; + end loop Option_Loop; + + Source_Info_Table.Table (Source_Info_Table.Last) := Info; + end loop Source_Loop; + + Close (File); + + exception + when others => + Close (File); + Report_Error; + end Read_Source_Info_File; + + -------------------- + -- Source_Info_Of -- + -------------------- + + function Source_Info_Of (Iter : Source_Info_Iterator) return Source_Info is + begin + return Iter.Info; + end Source_Info_Of; + + -------------- + -- Value_Of -- + -------------- + + function Value_Of + (Variable : Variable_Value; + Default : String) return String + is + begin + if Variable.Kind /= Single + or else Variable.Default + or else Variable.Value = No_Name + then + return Default; + else + return Get_Name_String (Variable.Value); + end if; + end Value_Of; + + function Value_Of + (Index : Name_Id; + In_Array : Array_Element_Id; + In_Tree : Project_Tree_Ref) return Name_Id + is + Current : Array_Element_Id; + Element : Array_Element; + Real_Index : Name_Id := Index; + + begin + Current := In_Array; + + if Current = No_Array_Element then + return No_Name; + end if; + + Element := In_Tree.Array_Elements.Table (Current); + + if not Element.Index_Case_Sensitive then + Get_Name_String (Index); + To_Lower (Name_Buffer (1 .. Name_Len)); + Real_Index := Name_Find; + end if; + + while Current /= No_Array_Element loop + Element := In_Tree.Array_Elements.Table (Current); + + if Real_Index = Element.Index then + exit when Element.Value.Kind /= Single; + exit when Element.Value.Value = Empty_String; + return Element.Value.Value; + else + Current := Element.Next; + end if; + end loop; + + return No_Name; + end Value_Of; + + function Value_Of + (Index : Name_Id; + Src_Index : Int := 0; + In_Array : Array_Element_Id; + In_Tree : Project_Tree_Ref; + Force_Lower_Case_Index : Boolean := False; + Allow_Wildcards : Boolean := False) return Variable_Value + is + Current : Array_Element_Id; + Element : Array_Element; + Real_Index_1 : Name_Id; + Real_Index_2 : Name_Id; + + begin + Current := In_Array; + + if Current = No_Array_Element then + return Nil_Variable_Value; + end if; + + Element := In_Tree.Array_Elements.Table (Current); + + Real_Index_1 := Index; + + if not Element.Index_Case_Sensitive or else Force_Lower_Case_Index then + if Index /= All_Other_Names then + Get_Name_String (Index); + To_Lower (Name_Buffer (1 .. Name_Len)); + Real_Index_1 := Name_Find; + end if; + end if; + + while Current /= No_Array_Element loop + Element := In_Tree.Array_Elements.Table (Current); + Real_Index_2 := Element.Index; + + if not Element.Index_Case_Sensitive + or else Force_Lower_Case_Index + then + if Element.Index /= All_Other_Names then + Get_Name_String (Element.Index); + To_Lower (Name_Buffer (1 .. Name_Len)); + Real_Index_2 := Name_Find; + end if; + end if; + + if Src_Index = Element.Src_Index and then + (Real_Index_1 = Real_Index_2 or else + (Real_Index_2 /= All_Other_Names and then + Allow_Wildcards and then + Match (Get_Name_String (Real_Index_1), + Compile (Get_Name_String (Real_Index_2), + Glob => True)))) + then + return Element.Value; + else + Current := Element.Next; + end if; + end loop; + + return Nil_Variable_Value; + end Value_Of; + + function Value_Of + (Name : Name_Id; + Index : Int := 0; + Attribute_Or_Array_Name : Name_Id; + In_Package : Package_Id; + In_Tree : Project_Tree_Ref; + Force_Lower_Case_Index : Boolean := False; + Allow_Wildcards : Boolean := False) return Variable_Value + is + The_Array : Array_Element_Id; + The_Attribute : Variable_Value := Nil_Variable_Value; + + begin + if In_Package /= No_Package then + + -- First, look if there is an array element that fits + + The_Array := + Value_Of + (Name => Attribute_Or_Array_Name, + In_Arrays => In_Tree.Packages.Table (In_Package).Decl.Arrays, + In_Tree => In_Tree); + The_Attribute := + Value_Of + (Index => Name, + Src_Index => Index, + In_Array => The_Array, + In_Tree => In_Tree, + Force_Lower_Case_Index => Force_Lower_Case_Index, + Allow_Wildcards => Allow_Wildcards); + + -- If there is no array element, look for a variable + + if The_Attribute = Nil_Variable_Value then + The_Attribute := + Value_Of + (Variable_Name => Attribute_Or_Array_Name, + In_Variables => In_Tree.Packages.Table + (In_Package).Decl.Attributes, + In_Tree => In_Tree); + end if; + end if; + + return The_Attribute; + end Value_Of; + + function Value_Of + (Index : Name_Id; + In_Array : Name_Id; + In_Arrays : Array_Id; + In_Tree : Project_Tree_Ref) return Name_Id + is + Current : Array_Id; + The_Array : Array_Data; + + begin + Current := In_Arrays; + while Current /= No_Array loop + The_Array := In_Tree.Arrays.Table (Current); + if The_Array.Name = In_Array then + return Value_Of + (Index, In_Array => The_Array.Value, In_Tree => In_Tree); + else + Current := The_Array.Next; + end if; + end loop; + + return No_Name; + end Value_Of; + + function Value_Of + (Name : Name_Id; + In_Arrays : Array_Id; + In_Tree : Project_Tree_Ref) return Array_Element_Id + is + Current : Array_Id; + The_Array : Array_Data; + + begin + Current := In_Arrays; + while Current /= No_Array loop + The_Array := In_Tree.Arrays.Table (Current); + + if The_Array.Name = Name then + return The_Array.Value; + else + Current := The_Array.Next; + end if; + end loop; + + return No_Array_Element; + end Value_Of; + + function Value_Of + (Name : Name_Id; + In_Packages : Package_Id; + In_Tree : Project_Tree_Ref) return Package_Id + is + Current : Package_Id; + The_Package : Package_Element; + + begin + Current := In_Packages; + while Current /= No_Package loop + The_Package := In_Tree.Packages.Table (Current); + exit when The_Package.Name /= No_Name + and then The_Package.Name = Name; + Current := The_Package.Next; + end loop; + + return Current; + end Value_Of; + + function Value_Of + (Variable_Name : Name_Id; + In_Variables : Variable_Id; + In_Tree : Project_Tree_Ref) return Variable_Value + is + Current : Variable_Id; + The_Variable : Variable; + + begin + Current := In_Variables; + while Current /= No_Variable loop + The_Variable := + In_Tree.Variable_Elements.Table (Current); + + if Variable_Name = The_Variable.Name then + return The_Variable.Value; + else + Current := The_Variable.Next; + end if; + end loop; + + return Nil_Variable_Value; + end Value_Of; + + ---------------------------- + -- Write_Source_Info_File -- + ---------------------------- + + procedure Write_Source_Info_File (Tree : Project_Tree_Ref) is + Iter : Source_Iterator := For_Each_Source (Tree); + Source : Prj.Source_Id; + File : Text_File; + + begin + if Opt.Verbose_Mode then + Write_Line ("Writing new source info file " & + Tree.Source_Info_File_Name.all); + end if; + + Create (File, Tree.Source_Info_File_Name.all); + + if not Is_Valid (File) then + Write_Line ("warning: unable to create source info file """ & + Tree.Source_Info_File_Name.all & '"'); + return; + end if; + + loop + Source := Element (Iter); + exit when Source = No_Source; + + if not Source.Locally_Removed and then + Source.Replaced_By = No_Source + then + -- Project name + + Put_Line (File, Get_Name_String (Source.Project.Name)); + + -- Language name + + Put_Line (File, Get_Name_String (Source.Language.Name)); + + -- Kind + + Put_Line (File, Source.Kind'Img); + + -- Display path name + + Put_Line (File, Get_Name_String (Source.Path.Display_Name)); + + -- Optional lines: + + -- Path name (P=) + + if Source.Path.Name /= Source.Path.Display_Name then + Put (File, "P="); + Put_Line (File, Get_Name_String (Source.Path.Name)); + end if; + + -- Unit name (U=) + + if Source.Unit /= No_Unit_Index then + Put (File, "U="); + Put_Line (File, Get_Name_String (Source.Unit.Name)); + end if; + + -- Multi-source index (I=) + + if Source.Index /= 0 then + Put (File, "I="); + Put_Line (File, Source.Index'Img); + end if; + + -- Naming exception ("N=T"); + + if Source.Naming_Exception then + Put_Line (File, "N=T"); + end if; + + -- Empty line to indicate end of info on this source + + Put_Line (File, ""); + end if; + + Next (Iter); + end loop; + + Close (File); + end Write_Source_Info_File; + + --------------- + -- Write_Str -- + --------------- + + procedure Write_Str + (S : String; + Max_Length : Positive; + Separator : Character) + is + First : Positive := S'First; + Last : Natural := S'Last; + + begin + -- Nothing to do for empty strings + + if S'Length > 0 then + + -- Start on a new line if current line is already longer than + -- Max_Length. + + if Positive (Column) >= Max_Length then + Write_Eol; + end if; + + -- If length of remainder is longer than Max_Length, we need to + -- cut the remainder in several lines. + + while Positive (Column) + S'Last - First > Max_Length loop + + -- Try the maximum length possible + + Last := First + Max_Length - Positive (Column); + + -- Look for last Separator in the line + + while Last >= First and then S (Last) /= Separator loop + Last := Last - 1; + end loop; + + -- If we do not find a separator, we output the maximum length + -- possible. + + if Last < First then + Last := First + Max_Length - Positive (Column); + end if; + + Write_Line (S (First .. Last)); + + -- Set the beginning of the new remainder + + First := Last + 1; + end loop; + + -- What is left goes to the buffer, without EOL + + Write_Str (S (First .. S'Last)); + end if; + end Write_Str; +end Prj.Util; diff --git a/gcc/ada/prj-util.ads b/gcc/ada/prj-util.ads new file mode 100644 index 000000000..741dc7f04 --- /dev/null +++ b/gcc/ada/prj-util.ads @@ -0,0 +1,253 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . U T I L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Utilities for use in processing project files + +package Prj.Util is + + function Executable_Of + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Main : File_Name_Type; + Index : Int; + Ada_Main : Boolean := True; + Language : String := ""; + Include_Suffix : Boolean := True) return File_Name_Type; + -- Return the value of the attribute Builder'Executable for file Main in + -- the project Project, if it exists. If there is no attribute Executable + -- for Main, remove the suffix from Main; then, if the attribute + -- Executable_Suffix is specified, add this suffix, otherwise add the + -- standard executable suffix for the platform. + -- + -- If Include_Suffix is true, then the ".exe" suffix (or any suffix defined + -- in the config) will be added. The suffix defined by the user in his own + -- project file is always taken into account. Otherwise, such a suffix is + -- not added. In particular, the prefix should not be added if you are + -- potentially testing for cross-platforms, since the suffix might not be + -- known (its default value comes from the ...-gnatmake prefix). + -- + -- What is Ada_Main??? + -- What is Language??? + + procedure Put + (Into_List : in out Name_List_Index; + From_List : String_List_Id; + In_Tree : Project_Tree_Ref; + Lower_Case : Boolean := False); + -- Append a name list to a string list + -- Describe parameters??? + + procedure Duplicate + (This : in out Name_List_Index; + In_Tree : Project_Tree_Ref); + -- Duplicate a name list + + function Value_Of + (Variable : Variable_Value; + Default : String) return String; + -- Get the value of a single string variable. If Variable is a string list, + -- is Nil_Variable_Value,or is defaulted, return Default. + + function Value_Of + (Index : Name_Id; + In_Array : Array_Element_Id; + In_Tree : Project_Tree_Ref) return Name_Id; + -- Get a single string array component. Returns No_Name if there is no + -- component Index, if In_Array is null, or if the component is a String + -- list. Depending on the attribute (only attributes may be associative + -- arrays) the index may or may not be case sensitive. If the index is not + -- case sensitive, it is first set to lower case before the search in the + -- associative array. + + function Value_Of + (Index : Name_Id; + Src_Index : Int := 0; + In_Array : Array_Element_Id; + In_Tree : Project_Tree_Ref; + Force_Lower_Case_Index : Boolean := False; + Allow_Wildcards : Boolean := False) return Variable_Value; + -- Get a string array component (single String or String list). Returns + -- Nil_Variable_Value if no component Index or if In_Array is null. + -- + -- Depending on the attribute (only attributes may be associative arrays) + -- the index may or may not be case sensitive. If the index is not case + -- sensitive, it is first set to lower case before the search in the + -- associative array. + + function Value_Of + (Name : Name_Id; + Index : Int := 0; + Attribute_Or_Array_Name : Name_Id; + In_Package : Package_Id; + In_Tree : Project_Tree_Ref; + Force_Lower_Case_Index : Boolean := False; + Allow_Wildcards : Boolean := False) return Variable_Value; + -- In a specific package: + -- - if there exists an array Attribute_Or_Array_Name with an index Name, + -- returns the corresponding component (depending on the attribute, the + -- index may or may not be case sensitive, see previous function), + -- - otherwise if there is a single attribute Attribute_Or_Array_Name, + -- returns this attribute, + -- - otherwise, returns Nil_Variable_Value. + -- If In_Package is null, returns Nil_Variable_Value. + + function Value_Of + (Index : Name_Id; + In_Array : Name_Id; + In_Arrays : Array_Id; + In_Tree : Project_Tree_Ref) return Name_Id; + -- Get a string array component in an array of an array list. Returns + -- No_Name if there is no component Index, if In_Arrays is null, if + -- In_Array is not found in In_Arrays or if the component is a String list. + + function Value_Of + (Name : Name_Id; + In_Arrays : Array_Id; + In_Tree : Project_Tree_Ref) return Array_Element_Id; + -- Returns a specified array in an array list. Returns No_Array_Element + -- if In_Arrays is null or if Name is not the name of an array in + -- In_Arrays. The caller must ensure that Name is in lower case. + + function Value_Of + (Name : Name_Id; + In_Packages : Package_Id; + In_Tree : Project_Tree_Ref) return Package_Id; + -- Returns a specified package in a package list. Returns No_Package + -- if In_Packages is null or if Name is not the name of a package in + -- Package_List. The caller must ensure that Name is in lower case. + + function Value_Of + (Variable_Name : Name_Id; + In_Variables : Variable_Id; + In_Tree : Project_Tree_Ref) return Variable_Value; + -- Returns a specified variable in a variable list. Returns null if + -- In_Variables is null or if Variable_Name is not the name of a + -- variable in In_Variables. Caller must ensure that Name is lower case. + + procedure Write_Str + (S : String; + Max_Length : Positive; + Separator : Character); + -- Output string S using Output.Write_Str. If S is too long to fit in one + -- line of Max_Length, cut it in several lines, using Separator as the last + -- character of each line, if possible. + + type Text_File is limited private; + -- Represents a text file (default is invalid text file) + + function Is_Valid (File : Text_File) return Boolean; + -- Returns True if File designates an open text file that has not yet been + -- closed. + + procedure Open (File : out Text_File; Name : String); + -- Open a text file to read (File is invalid if text file cannot be opened) + + procedure Create (File : out Text_File; Name : String); + -- Create a text file to write (File is invalid if text file cannot be + -- created). + + function End_Of_File (File : Text_File) return Boolean; + -- Returns True if the end of the text file File has been reached. Fails if + -- File is invalid. Return True if File is an out file. + + procedure Get_Line + (File : Text_File; + Line : out String; + Last : out Natural); + -- Reads a line from an open text file (fails if File is invalid or in an + -- out file). + + procedure Put (File : Text_File; S : String); + procedure Put_Line (File : Text_File; Line : String); + -- Output a string or a line to an out text file (fails if File is invalid + -- or in an in file). + + procedure Close (File : in out Text_File); + -- Close an open text file. File becomes invalid. Fails if File is already + -- invalid or if an out file cannot be closed successfully. + + ----------------------- + -- Source info files -- + ----------------------- + + procedure Write_Source_Info_File (Tree : Project_Tree_Ref); + -- Create a new source info file, with the path name specified in the + -- project tree data. Issue a warning if it is not possible to create + -- the new file. + + procedure Read_Source_Info_File (Tree : Project_Tree_Ref); + -- Check if there is a source info file specified for the project Tree. If + -- so, attempt to read it. If the file exists and is successfully read, set + -- the flag Source_Info_File_Exists to True for the tree. + + type Source_Info_Data is record + Project : Name_Id; + Language : Name_Id; + Kind : Source_Kind; + Display_Path_Name : Name_Id; + Path_Name : Name_Id; + Unit_Name : Name_Id := No_Name; + Index : Int := 0; + Naming_Exception : Boolean := False; + end record; + -- Data read from a source info file for a single source + + type Source_Info is access all Source_Info_Data; + No_Source_Info : constant Source_Info := null; + + type Source_Info_Iterator is private; + -- Iterator to get the sources for a single project + + procedure Initialize + (Iter : out Source_Info_Iterator; + For_Project : Name_Id); + -- Initialize Iter for the project + + function Source_Info_Of (Iter : Source_Info_Iterator) return Source_Info; + -- Get the source info for the source corresponding to the current value of + -- the iterator. Returns No_Source_Info if there is no source corresponding + -- to the iterator. + + procedure Next (Iter : in out Source_Info_Iterator); + -- Advance the iterator to the next source in the project + +private + type Text_File_Data is record + FD : File_Descriptor := Invalid_FD; + Out_File : Boolean := False; + Buffer : String (1 .. 1_000); + Buffer_Len : Natural := 0; + Cursor : Natural := 0; + End_Of_File_Reached : Boolean := False; + end record; + + type Text_File is access Text_File_Data; + + type Source_Info_Iterator is record + Info : Source_Info; + Next : Natural; + end record; + +end Prj.Util; diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb new file mode 100644 index 000000000..2ad07b13e --- /dev/null +++ b/gcc/ada/prj.adb @@ -0,0 +1,1309 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Debug; +with Osint; use Osint; +with Output; use Output; +with Prj.Attr; +with Prj.Err; use Prj.Err; +with Snames; use Snames; +with Uintp; use Uintp; + +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Unchecked_Deallocation; + +with GNAT.Case_Util; use GNAT.Case_Util; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.HTable; + +package body Prj is + + Object_Suffix : constant String := Get_Target_Object_Suffix.all; + -- File suffix for object files + + Initial_Buffer_Size : constant := 100; + -- Initial size for extensible buffer used in Add_To_Buffer + + The_Empty_String : Name_Id := No_Name; + + type Cst_String_Access is access constant String; + + All_Lower_Case_Image : aliased constant String := "lowercase"; + All_Upper_Case_Image : aliased constant String := "UPPERCASE"; + Mixed_Case_Image : aliased constant String := "MixedCase"; + + The_Casing_Images : constant array (Known_Casing) of Cst_String_Access := + (All_Lower_Case => All_Lower_Case_Image'Access, + All_Upper_Case => All_Upper_Case_Image'Access, + Mixed_Case => Mixed_Case_Image'Access); + + Project_Empty : constant Project_Data := + (Qualifier => Unspecified, + Externally_Built => False, + Config => Default_Project_Config, + Name => No_Name, + Display_Name => No_Name, + Path => No_Path_Information, + Virtual => False, + Location => No_Location, + Mains => Nil_String, + Directory => No_Path_Information, + Library => False, + Library_Dir => No_Path_Information, + Library_Src_Dir => No_Path_Information, + Library_ALI_Dir => No_Path_Information, + Library_Name => No_Name, + Library_Kind => Static, + Lib_Internal_Name => No_Name, + Standalone_Library => False, + Lib_Interface_ALIs => Nil_String, + Lib_Auto_Init => False, + Libgnarl_Needed => Unknown, + Symbol_Data => No_Symbols, + Interfaces_Defined => False, + Source_Dirs => Nil_String, + Source_Dir_Ranks => No_Number_List, + Object_Directory => No_Path_Information, + Library_TS => Empty_Time_Stamp, + Exec_Directory => No_Path_Information, + Extends => No_Project, + Extended_By => No_Project, + Languages => No_Language_Index, + Decl => No_Declarations, + Imported_Projects => null, + Include_Path_File => No_Path, + All_Imported_Projects => null, + Ada_Include_Path => null, + Ada_Objects_Path => null, + Objects_Path => null, + Objects_Path_File_With_Libs => No_Path, + Objects_Path_File_Without_Libs => No_Path, + Config_File_Name => No_Path, + Config_File_Temp => False, + Config_Checked => False, + Need_To_Build_Lib => False, + Has_Multi_Unit_Sources => False, + Depth => 0, + Unkept_Comments => False); + + procedure Free (Project : in out Project_Id); + -- Free memory allocated for Project + + procedure Free_List (Languages : in out Language_Ptr); + procedure Free_List (Source : in out Source_Id); + procedure Free_List (Languages : in out Language_List); + -- Free memory allocated for the list of languages or sources + + procedure Free_Units (Table : in out Units_Htable.Instance); + -- Free memory allocated for unit information in the project + + procedure Language_Changed (Iter : in out Source_Iterator); + procedure Project_Changed (Iter : in out Source_Iterator); + -- Called when a new project or language was selected for this iterator + + function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean; + -- Return True if there is at least one ALI file in the directory Dir + + ------------------- + -- Add_To_Buffer -- + ------------------- + + procedure Add_To_Buffer + (S : String; + To : in out String_Access; + Last : in out Natural) + is + begin + if To = null then + To := new String (1 .. Initial_Buffer_Size); + Last := 0; + end if; + + -- If Buffer is too small, double its size + + while Last + S'Length > To'Last loop + declare + New_Buffer : constant String_Access := + new String (1 .. 2 * Last); + + begin + New_Buffer (1 .. Last) := To (1 .. Last); + Free (To); + To := New_Buffer; + end; + end loop; + + To (Last + 1 .. Last + S'Length) := S; + Last := Last + S'Length; + end Add_To_Buffer; + + --------------------------- + -- Delete_Temporary_File -- + --------------------------- + + procedure Delete_Temporary_File + (Tree : Project_Tree_Ref; + Path : Path_Name_Type) + is + Dont_Care : Boolean; + pragma Warnings (Off, Dont_Care); + + begin + if not Debug.Debug_Flag_N then + if Current_Verbosity = High then + Write_Line ("Removing temp file: " & Get_Name_String (Path)); + end if; + + Delete_File (Get_Name_String (Path), Dont_Care); + + for Index in + 1 .. Temp_Files_Table.Last (Tree.Private_Part.Temp_Files) + loop + if Tree.Private_Part.Temp_Files.Table (Index) = Path then + Tree.Private_Part.Temp_Files.Table (Index) := No_Path; + end if; + end loop; + end if; + end Delete_Temporary_File; + + --------------------------- + -- Delete_All_Temp_Files -- + --------------------------- + + procedure Delete_All_Temp_Files (Tree : Project_Tree_Ref) is + Dont_Care : Boolean; + pragma Warnings (Off, Dont_Care); + + Path : Path_Name_Type; + + begin + if not Debug.Debug_Flag_N then + for Index in + 1 .. Temp_Files_Table.Last (Tree.Private_Part.Temp_Files) + loop + Path := Tree.Private_Part.Temp_Files.Table (Index); + + if Path /= No_Path then + if Current_Verbosity = High then + Write_Line ("Removing temp file: " + & Get_Name_String (Path)); + end if; + + Delete_File (Get_Name_String (Path), Dont_Care); + end if; + end loop; + + Temp_Files_Table.Free (Tree.Private_Part.Temp_Files); + Temp_Files_Table.Init (Tree.Private_Part.Temp_Files); + end if; + + -- If any of the environment variables ADA_PRJ_INCLUDE_FILE or + -- ADA_PRJ_OBJECTS_FILE has been set, then reset their value to + -- the empty string. On VMS, this has the effect of deassigning + -- the logical names. + + if Tree.Private_Part.Current_Source_Path_File /= No_Path then + Setenv (Project_Include_Path_File, ""); + end if; + + if Tree.Private_Part.Current_Object_Path_File /= No_Path then + Setenv (Project_Objects_Path_File, ""); + end if; + end Delete_All_Temp_Files; + + --------------------- + -- Dependency_Name -- + --------------------- + + function Dependency_Name + (Source_File_Name : File_Name_Type; + Dependency : Dependency_File_Kind) return File_Name_Type + is + begin + case Dependency is + when None => + return No_File; + + when Makefile => + return Extend_Name (Source_File_Name, Makefile_Dependency_Suffix); + + when ALI_File => + return Extend_Name (Source_File_Name, ALI_Dependency_Suffix); + end case; + end Dependency_Name; + + ---------------- + -- Empty_File -- + ---------------- + + function Empty_File return File_Name_Type is + begin + return File_Name_Type (The_Empty_String); + end Empty_File; + + ------------------- + -- Empty_Project -- + ------------------- + + function Empty_Project return Project_Data is + begin + Prj.Initialize (Tree => No_Project_Tree); + return Project_Empty; + end Empty_Project; + + ------------------ + -- Empty_String -- + ------------------ + + function Empty_String return Name_Id is + begin + return The_Empty_String; + end Empty_String; + + ------------ + -- Expect -- + ------------ + + procedure Expect (The_Token : Token_Type; Token_Image : String) is + begin + if Token /= The_Token then + -- ??? Should pass user flags here instead + Error_Msg (Gnatmake_Flags, Token_Image & " expected", Token_Ptr); + end if; + end Expect; + + ----------------- + -- Extend_Name -- + ----------------- + + function Extend_Name + (File : File_Name_Type; + With_Suffix : String) return File_Name_Type + is + Last : Positive; + + begin + Get_Name_String (File); + Last := Name_Len + 1; + + while Name_Len /= 0 and then Name_Buffer (Name_Len) /= '.' loop + Name_Len := Name_Len - 1; + end loop; + + if Name_Len <= 1 then + Name_Len := Last; + end if; + + for J in With_Suffix'Range loop + Name_Buffer (Name_Len) := With_Suffix (J); + Name_Len := Name_Len + 1; + end loop; + + Name_Len := Name_Len - 1; + return Name_Find; + + end Extend_Name; + + --------------------- + -- Project_Changed -- + --------------------- + + procedure Project_Changed (Iter : in out Source_Iterator) is + begin + Iter.Language := Iter.Project.Project.Languages; + Language_Changed (Iter); + end Project_Changed; + + ---------------------- + -- Language_Changed -- + ---------------------- + + procedure Language_Changed (Iter : in out Source_Iterator) is + begin + Iter.Current := No_Source; + + if Iter.Language_Name /= No_Name then + while Iter.Language /= null + and then Iter.Language.Name /= Iter.Language_Name + loop + Iter.Language := Iter.Language.Next; + end loop; + end if; + + -- If there is no matching language in this project, move to next + + if Iter.Language = No_Language_Index then + if Iter.All_Projects then + Iter.Project := Iter.Project.Next; + + if Iter.Project /= null then + Project_Changed (Iter); + end if; + + else + Iter.Project := null; + end if; + + else + Iter.Current := Iter.Language.First_Source; + + if Iter.Current = No_Source then + Iter.Language := Iter.Language.Next; + Language_Changed (Iter); + end if; + end if; + end Language_Changed; + + --------------------- + -- For_Each_Source -- + --------------------- + + function For_Each_Source + (In_Tree : Project_Tree_Ref; + Project : Project_Id := No_Project; + Language : Name_Id := No_Name) return Source_Iterator + is + Iter : Source_Iterator; + begin + Iter := Source_Iterator' + (In_Tree => In_Tree, + Project => In_Tree.Projects, + All_Projects => Project = No_Project, + Language_Name => Language, + Language => No_Language_Index, + Current => No_Source); + + if Project /= null then + while Iter.Project /= null + and then Iter.Project.Project /= Project + loop + Iter.Project := Iter.Project.Next; + end loop; + end if; + + Project_Changed (Iter); + + return Iter; + end For_Each_Source; + + ------------- + -- Element -- + ------------- + + function Element (Iter : Source_Iterator) return Source_Id is + begin + return Iter.Current; + end Element; + + ---------- + -- Next -- + ---------- + + procedure Next (Iter : in out Source_Iterator) is + begin + Iter.Current := Iter.Current.Next_In_Lang; + if Iter.Current = No_Source then + Iter.Language := Iter.Language.Next; + Language_Changed (Iter); + end if; + end Next; + + -------------------------------- + -- For_Every_Project_Imported -- + -------------------------------- + + procedure For_Every_Project_Imported + (By : Project_Id; + With_State : in out State; + Imported_First : Boolean := False) + is + use Project_Boolean_Htable; + Seen : Project_Boolean_Htable.Instance := Project_Boolean_Htable.Nil; + + procedure Recursive_Check (Project : Project_Id); + -- Check if a project has already been seen. If not seen, mark it as + -- Seen, Call Action, and check all its imported projects. + + --------------------- + -- Recursive_Check -- + --------------------- + + procedure Recursive_Check (Project : Project_Id) is + List : Project_List; + + begin + if not Get (Seen, Project) then + Set (Seen, Project, True); + + if not Imported_First then + Action (Project, With_State); + end if; + + -- Visited all extended projects + + if Project.Extends /= No_Project then + Recursive_Check (Project.Extends); + end if; + + -- Visited all imported projects + + List := Project.Imported_Projects; + while List /= null loop + Recursive_Check (List.Project); + List := List.Next; + end loop; + + if Imported_First then + Action (Project, With_State); + end if; + end if; + end Recursive_Check; + + -- Start of processing for For_Every_Project_Imported + + begin + Recursive_Check (Project => By); + Reset (Seen); + end For_Every_Project_Imported; + + ----------------- + -- Find_Source -- + ----------------- + + function Find_Source + (In_Tree : Project_Tree_Ref; + Project : Project_Id; + In_Imported_Only : Boolean := False; + In_Extended_Only : Boolean := False; + Base_Name : File_Name_Type) return Source_Id + is + Result : Source_Id := No_Source; + + procedure Look_For_Sources (Proj : Project_Id; Src : in out Source_Id); + -- Look for Base_Name in the sources of Proj + + ---------------------- + -- Look_For_Sources -- + ---------------------- + + procedure Look_For_Sources (Proj : Project_Id; Src : in out Source_Id) is + Iterator : Source_Iterator; + + begin + Iterator := For_Each_Source (In_Tree => In_Tree, Project => Proj); + while Element (Iterator) /= No_Source loop + if Element (Iterator).File = Base_Name then + Src := Element (Iterator); + return; + end if; + + Next (Iterator); + end loop; + end Look_For_Sources; + + procedure For_Imported_Projects is new For_Every_Project_Imported + (State => Source_Id, Action => Look_For_Sources); + + Proj : Project_Id; + + -- Start of processing for Find_Source + + begin + if In_Extended_Only then + Proj := Project; + while Proj /= No_Project loop + Look_For_Sources (Proj, Result); + exit when Result /= No_Source; + + Proj := Proj.Extends; + end loop; + + elsif In_Imported_Only then + Look_For_Sources (Project, Result); + + if Result = No_Source then + For_Imported_Projects + (By => Project, + With_State => Result); + end if; + else + Look_For_Sources (No_Project, Result); + end if; + + return Result; + end Find_Source; + + ---------- + -- Hash -- + ---------- + + function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num); + -- Used in implementation of other functions Hash below + + function Hash (Name : File_Name_Type) return Header_Num is + begin + return Hash (Get_Name_String (Name)); + end Hash; + + function Hash (Name : Name_Id) return Header_Num is + begin + return Hash (Get_Name_String (Name)); + end Hash; + + function Hash (Name : Path_Name_Type) return Header_Num is + begin + return Hash (Get_Name_String (Name)); + end Hash; + + function Hash (Project : Project_Id) return Header_Num is + begin + if Project = No_Project then + return Header_Num'First; + else + return Hash (Get_Name_String (Project.Name)); + end if; + end Hash; + + ----------- + -- Image -- + ----------- + + function Image (The_Casing : Casing_Type) return String is + begin + return The_Casing_Images (The_Casing).all; + end Image; + + ----------------------------- + -- Is_Standard_GNAT_Naming -- + ----------------------------- + + function Is_Standard_GNAT_Naming + (Naming : Lang_Naming_Data) return Boolean + is + begin + return Get_Name_String (Naming.Spec_Suffix) = ".ads" + and then Get_Name_String (Naming.Body_Suffix) = ".adb" + and then Get_Name_String (Naming.Dot_Replacement) = "-"; + end Is_Standard_GNAT_Naming; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Tree : Project_Tree_Ref) is + begin + if The_Empty_String = No_Name then + Uintp.Initialize; + Name_Len := 0; + The_Empty_String := Name_Find; + + Prj.Attr.Initialize; + + Set_Name_Table_Byte + (Name_Project, Token_Type'Pos (Tok_Project)); + Set_Name_Table_Byte + (Name_Extends, Token_Type'Pos (Tok_Extends)); + Set_Name_Table_Byte + (Name_External, Token_Type'Pos (Tok_External)); + Set_Name_Table_Byte + (Name_External_As_List, Token_Type'Pos (Tok_External_As_List)); + end if; + + if Tree /= No_Project_Tree then + Reset (Tree); + end if; + end Initialize; + + ------------------ + -- Is_Extending -- + ------------------ + + function Is_Extending + (Extending : Project_Id; + Extended : Project_Id) return Boolean + is + Proj : Project_Id; + + begin + Proj := Extending; + while Proj /= No_Project loop + if Proj = Extended then + return True; + end if; + + Proj := Proj.Extends; + end loop; + + return False; + end Is_Extending; + + ----------------- + -- Object_Name -- + ----------------- + + function Object_Name + (Source_File_Name : File_Name_Type; + Object_File_Suffix : Name_Id := No_Name) return File_Name_Type + is + begin + if Object_File_Suffix = No_Name then + return Extend_Name + (Source_File_Name, Object_Suffix); + else + return Extend_Name + (Source_File_Name, Get_Name_String (Object_File_Suffix)); + end if; + end Object_Name; + + function Object_Name + (Source_File_Name : File_Name_Type; + Source_Index : Int; + Index_Separator : Character; + Object_File_Suffix : Name_Id := No_Name) return File_Name_Type + is + Index_Img : constant String := Source_Index'Img; + Last : Natural; + + begin + Get_Name_String (Source_File_Name); + + Last := Name_Len; + while Last > 1 and then Name_Buffer (Last) /= '.' loop + Last := Last - 1; + end loop; + + if Last > 1 then + Name_Len := Last - 1; + end if; + + Add_Char_To_Name_Buffer (Index_Separator); + Add_Str_To_Name_Buffer (Index_Img (2 .. Index_Img'Last)); + + if Object_File_Suffix = No_Name then + Add_Str_To_Name_Buffer (Object_Suffix); + else + Add_Str_To_Name_Buffer (Get_Name_String (Object_File_Suffix)); + end if; + + return Name_Find; + end Object_Name; + + ---------------------- + -- Record_Temp_File -- + ---------------------- + + procedure Record_Temp_File + (Tree : Project_Tree_Ref; + Path : Path_Name_Type) + is + begin + Temp_Files_Table.Append (Tree.Private_Part.Temp_Files, Path); + end Record_Temp_File; + + ---------- + -- Free -- + ---------- + + procedure Free (Project : in out Project_Id) is + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Project_Data, Project_Id); + + begin + if Project /= null then + Free (Project.Ada_Include_Path); + Free (Project.Objects_Path); + Free (Project.Ada_Objects_Path); + Free_List (Project.Imported_Projects, Free_Project => False); + Free_List (Project.All_Imported_Projects, Free_Project => False); + Free_List (Project.Languages); + + Unchecked_Free (Project); + end if; + end Free; + + --------------- + -- Free_List -- + --------------- + + procedure Free_List (Languages : in out Language_List) is + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Language_List_Element, Language_List); + Tmp : Language_List; + begin + while Languages /= null loop + Tmp := Languages.Next; + Unchecked_Free (Languages); + Languages := Tmp; + end loop; + end Free_List; + + --------------- + -- Free_List -- + --------------- + + procedure Free_List (Source : in out Source_Id) is + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation (Source_Data, Source_Id); + + Tmp : Source_Id; + + begin + while Source /= No_Source loop + Tmp := Source.Next_In_Lang; + Free_List (Source.Alternate_Languages); + + if Source.Unit /= null + and then Source.Kind in Spec_Or_Body + then + Source.Unit.File_Names (Source.Kind) := null; + end if; + + Unchecked_Free (Source); + Source := Tmp; + end loop; + end Free_List; + + --------------- + -- Free_List -- + --------------- + + procedure Free_List + (List : in out Project_List; + Free_Project : Boolean) + is + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation (Project_List_Element, Project_List); + + Tmp : Project_List; + + begin + while List /= null loop + Tmp := List.Next; + + if Free_Project then + Free (List.Project); + end if; + + Unchecked_Free (List); + List := Tmp; + end loop; + end Free_List; + + --------------- + -- Free_List -- + --------------- + + procedure Free_List (Languages : in out Language_Ptr) is + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation (Language_Data, Language_Ptr); + + Tmp : Language_Ptr; + + begin + while Languages /= null loop + Tmp := Languages.Next; + Free_List (Languages.First_Source); + Unchecked_Free (Languages); + Languages := Tmp; + end loop; + end Free_List; + + ---------------- + -- Free_Units -- + ---------------- + + procedure Free_Units (Table : in out Units_Htable.Instance) is + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation (Unit_Data, Unit_Index); + + Unit : Unit_Index; + + begin + Unit := Units_Htable.Get_First (Table); + while Unit /= No_Unit_Index loop + if Unit.File_Names (Spec) /= null then + Unit.File_Names (Spec).Unit := No_Unit_Index; + end if; + + if Unit.File_Names (Impl) /= null then + Unit.File_Names (Impl).Unit := No_Unit_Index; + end if; + + Unchecked_Free (Unit); + Unit := Units_Htable.Get_Next (Table); + end loop; + + Units_Htable.Reset (Table); + end Free_Units; + + ---------- + -- Free -- + ---------- + + procedure Free (Tree : in out Project_Tree_Ref) is + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation (Project_Tree_Data, Project_Tree_Ref); + + begin + if Tree /= null then + Name_List_Table.Free (Tree.Name_Lists); + Number_List_Table.Free (Tree.Number_Lists); + String_Element_Table.Free (Tree.String_Elements); + Variable_Element_Table.Free (Tree.Variable_Elements); + Array_Element_Table.Free (Tree.Array_Elements); + Array_Table.Free (Tree.Arrays); + Package_Table.Free (Tree.Packages); + Source_Paths_Htable.Reset (Tree.Source_Paths_HT); + Source_Files_Htable.Reset (Tree.Source_Files_HT); + + Free_List (Tree.Projects, Free_Project => True); + Free_Units (Tree.Units_HT); + + -- Private part + + Temp_Files_Table.Free (Tree.Private_Part.Temp_Files); + + Unchecked_Free (Tree); + end if; + end Free; + + ----------- + -- Reset -- + ----------- + + procedure Reset (Tree : Project_Tree_Ref) is + begin + -- Visible tables + + Name_List_Table.Init (Tree.Name_Lists); + Number_List_Table.Init (Tree.Number_Lists); + String_Element_Table.Init (Tree.String_Elements); + Variable_Element_Table.Init (Tree.Variable_Elements); + Array_Element_Table.Init (Tree.Array_Elements); + Array_Table.Init (Tree.Arrays); + Package_Table.Init (Tree.Packages); + Source_Paths_Htable.Reset (Tree.Source_Paths_HT); + Source_Files_Htable.Reset (Tree.Source_Files_HT); + Replaced_Source_HTable.Reset (Tree.Replaced_Sources); + + Tree.Replaced_Source_Number := 0; + + Free_List (Tree.Projects, Free_Project => True); + Free_Units (Tree.Units_HT); + + -- Private part table + + Temp_Files_Table.Init (Tree.Private_Part.Temp_Files); + + Tree.Private_Part.Current_Source_Path_File := No_Path; + Tree.Private_Part.Current_Object_Path_File := No_Path; + end Reset; + + ------------------- + -- Switches_Name -- + ------------------- + + function Switches_Name + (Source_File_Name : File_Name_Type) return File_Name_Type + is + begin + return Extend_Name (Source_File_Name, Switches_Dependency_Suffix); + end Switches_Name; + + ----------- + -- Value -- + ----------- + + function Value (Image : String) return Casing_Type is + begin + for Casing in The_Casing_Images'Range loop + if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then + return Casing; + end if; + end loop; + + raise Constraint_Error; + end Value; + + --------------------- + -- Has_Ada_Sources -- + --------------------- + + function Has_Ada_Sources (Data : Project_Id) return Boolean is + Lang : Language_Ptr; + + begin + Lang := Data.Languages; + while Lang /= No_Language_Index loop + if Lang.Name = Name_Ada then + return Lang.First_Source /= No_Source; + end if; + Lang := Lang.Next; + end loop; + + return False; + end Has_Ada_Sources; + + ------------------------ + -- Contains_ALI_Files -- + ------------------------ + + function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean is + Dir_Name : constant String := Get_Name_String (Dir); + Direct : Dir_Type; + Name : String (1 .. 1_000); + Last : Natural; + Result : Boolean := False; + + begin + Open (Direct, Dir_Name); + + -- For each file in the directory, check if it is an ALI file + + loop + Read (Direct, Name, Last); + exit when Last = 0; + Canonical_Case_File_Name (Name (1 .. Last)); + Result := Last >= 5 and then Name (Last - 3 .. Last) = ".ali"; + exit when Result; + end loop; + + Close (Direct); + return Result; + + exception + -- If there is any problem, close the directory if open and return True. + -- The library directory will be added to the path. + + when others => + if Is_Open (Direct) then + Close (Direct); + end if; + + return True; + end Contains_ALI_Files; + + -------------------------- + -- Get_Object_Directory -- + -------------------------- + + function Get_Object_Directory + (Project : Project_Id; + Including_Libraries : Boolean; + Only_If_Ada : Boolean := False) return Path_Name_Type + is + begin + if (Project.Library and then Including_Libraries) + or else + (Project.Object_Directory /= No_Path_Information + and then (not Including_Libraries or else not Project.Library)) + then + -- For a library project, add the library ALI directory if there is + -- no object directory or if the library ALI directory contains ALI + -- files; otherwise add the object directory. + + if Project.Library then + if Project.Object_Directory = No_Path_Information + or else Contains_ALI_Files (Project.Library_ALI_Dir.Display_Name) + then + return Project.Library_ALI_Dir.Display_Name; + else + return Project.Object_Directory.Display_Name; + end if; + + -- For a non-library project, add object directory if it is not a + -- virtual project, and if there are Ada sources in the project or + -- one of the projects it extends. If there are no Ada sources, + -- adding the object directory could disrupt the order of the + -- object dirs in the path. + + elsif not Project.Virtual then + declare + Add_Object_Dir : Boolean; + Prj : Project_Id; + + begin + Add_Object_Dir := not Only_If_Ada; + Prj := Project; + while not Add_Object_Dir and then Prj /= No_Project loop + if Has_Ada_Sources (Prj) then + Add_Object_Dir := True; + else + Prj := Prj.Extends; + end if; + end loop; + + if Add_Object_Dir then + return Project.Object_Directory.Display_Name; + end if; + end; + end if; + end if; + + return No_Path; + end Get_Object_Directory; + + ----------------------------------- + -- Ultimate_Extending_Project_Of -- + ----------------------------------- + + function Ultimate_Extending_Project_Of + (Proj : Project_Id) return Project_Id + is + Prj : Project_Id; + + begin + Prj := Proj; + while Prj /= null and then Prj.Extended_By /= No_Project loop + Prj := Prj.Extended_By; + end loop; + + return Prj; + end Ultimate_Extending_Project_Of; + + ----------------------------------- + -- Compute_All_Imported_Projects -- + ----------------------------------- + + procedure Compute_All_Imported_Projects (Tree : Project_Tree_Ref) is + Project : Project_Id; + + procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean); + -- Recursively add the projects imported by project Project, but not + -- those that are extended. + + ------------------- + -- Recursive_Add -- + ------------------- + + procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean) is + pragma Unreferenced (Dummy); + List : Project_List; + Prj2 : Project_Id; + + begin + -- A project is not importing itself + + Prj2 := Ultimate_Extending_Project_Of (Prj); + + if Project /= Prj2 then + + -- Check that the project is not already in the list. We know the + -- one passed to Recursive_Add have never been visited before, but + -- the one passed it are the extended projects. + + List := Project.All_Imported_Projects; + while List /= null loop + if List.Project = Prj2 then + return; + end if; + + List := List.Next; + end loop; + + -- Add it to the list + + Project.All_Imported_Projects := + new Project_List_Element' + (Project => Prj2, + Next => Project.All_Imported_Projects); + end if; + end Recursive_Add; + + procedure For_All_Projects is + new For_Every_Project_Imported (Boolean, Recursive_Add); + + Dummy : Boolean := False; + List : Project_List; + + begin + List := Tree.Projects; + while List /= null loop + Project := List.Project; + Free_List (Project.All_Imported_Projects, Free_Project => False); + For_All_Projects (Project, Dummy); + List := List.Next; + end loop; + end Compute_All_Imported_Projects; + + ------------------- + -- Is_Compilable -- + ------------------- + + function Is_Compilable (Source : Source_Id) return Boolean is + begin + case Source.Compilable is + when Unknown => + if Source.Language.Config.Compiler_Driver /= No_File + and then + Length_Of_Name (Source.Language.Config.Compiler_Driver) /= 0 + and then not Source.Locally_Removed + and then (Source.Language.Config.Kind /= File_Based + or else Source.Kind /= Spec) + then + -- Do not modify Source.Compilable before the source record + -- has been initialized. + + if Source.Source_TS /= Empty_Time_Stamp then + Source.Compilable := Yes; + end if; + + return True; + + else + if Source.Source_TS /= Empty_Time_Stamp then + Source.Compilable := No; + end if; + + return False; + end if; + + when Yes => + return True; + + when No => + return False; + end case; + end Is_Compilable; + + ------------------------------ + -- Object_To_Global_Archive -- + ------------------------------ + + function Object_To_Global_Archive (Source : Source_Id) return Boolean is + begin + return Source.Language.Config.Kind = File_Based + and then Source.Kind = Impl + and then Source.Language.Config.Objects_Linked + and then Is_Compilable (Source) + and then Source.Language.Config.Object_Generated; + end Object_To_Global_Archive; + + ---------------------------- + -- Get_Language_From_Name -- + ---------------------------- + + function Get_Language_From_Name + (Project : Project_Id; + Name : String) return Language_Ptr + is + N : Name_Id; + Result : Language_Ptr; + + begin + Name_Len := Name'Length; + Name_Buffer (1 .. Name_Len) := Name; + To_Lower (Name_Buffer (1 .. Name_Len)); + N := Name_Find; + + Result := Project.Languages; + while Result /= No_Language_Index loop + if Result.Name = N then + return Result; + end if; + + Result := Result.Next; + end loop; + + return No_Language_Index; + end Get_Language_From_Name; + + ---------------- + -- Other_Part -- + ---------------- + + function Other_Part (Source : Source_Id) return Source_Id is + begin + if Source.Unit /= No_Unit_Index then + case Source.Kind is + when Impl => + return Source.Unit.File_Names (Spec); + when Spec => + return Source.Unit.File_Names (Impl); + when Sep => + return No_Source; + end case; + else + return No_Source; + end if; + end Other_Part; + + ------------------ + -- Create_Flags -- + ------------------ + + function Create_Flags + (Report_Error : Error_Handler; + When_No_Sources : Error_Warning; + Require_Sources_Other_Lang : Boolean := True; + Allow_Duplicate_Basenames : Boolean := True; + Compiler_Driver_Mandatory : Boolean := False; + Error_On_Unknown_Language : Boolean := True; + Require_Obj_Dirs : Error_Warning := Error; + Allow_Invalid_External : Error_Warning := Error; + Missing_Source_Files : Error_Warning := Error) + return Processing_Flags + is + begin + return Processing_Flags' + (Report_Error => Report_Error, + When_No_Sources => When_No_Sources, + Require_Sources_Other_Lang => Require_Sources_Other_Lang, + Allow_Duplicate_Basenames => Allow_Duplicate_Basenames, + Error_On_Unknown_Language => Error_On_Unknown_Language, + Compiler_Driver_Mandatory => Compiler_Driver_Mandatory, + Require_Obj_Dirs => Require_Obj_Dirs, + Allow_Invalid_External => Allow_Invalid_External, + Missing_Source_Files => Missing_Source_Files); + end Create_Flags; + + ------------ + -- Length -- + ------------ + + function Length + (Table : Name_List_Table.Instance; + List : Name_List_Index) return Natural + is + Count : Natural := 0; + Tmp : Name_List_Index; + + begin + Tmp := List; + while Tmp /= No_Name_List loop + Count := Count + 1; + Tmp := Table.Table (Tmp).Next; + end loop; + + return Count; + end Length; + +begin + -- Make sure that the standard config and user project file extensions are + -- compatible with canonical case file naming. + + Canonical_Case_File_Name (Config_Project_File_Extension); + Canonical_Case_File_Name (Project_File_Extension); +end Prj; diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads new file mode 100644 index 000000000..b1e01efbd --- /dev/null +++ b/gcc/ada/prj.ads @@ -0,0 +1,1709 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- The following package declares the data types for GNAT project. +-- These data types may be used by GNAT Project-aware tools. + +-- Children of these package implements various services on these data types. +-- See in particular Prj.Pars and Prj.Env. + +with Casing; use Casing; +with Namet; use Namet; +with Osint; +with Scans; use Scans; +with Types; use Types; + +with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; +with GNAT.Dynamic_Tables; +with GNAT.OS_Lib; use GNAT.OS_Lib; + +package Prj is + + All_Other_Names : constant Name_Id := Names_High_Bound; + -- Name used to replace others as an index of an associative array + -- attribute in situations where this is allowed. + + Subdirs : String_Ptr := null; + -- The value after the equal sign in switch --subdirs=... + -- Contains the relative subdirectory. + + type Library_Support is (None, Static_Only, Full); + -- Support for Library Project File. + -- - None: Library Project Files are not supported at all + -- - Static_Only: Library Project Files are only supported for static + -- libraries. + -- - Full: Library Project Files are supported for static and dynamic + -- (shared) libraries. + + type Yes_No_Unknown is (Yes, No, Unknown); + -- Tri-state to decide if -lgnarl is needed when linking + + type Project_Qualifier is + (Unspecified, + Standard, + Library, + Configuration, + Dry, + Aggregate, + Aggregate_Library); + -- Qualifiers that can prefix the reserved word "project" in a project + -- file: + -- Standard: standard project ... + -- Library: library project is ... + -- Dry: abstract project is + -- Aggregate: aggregate project is + -- Aggregate_Library: aggregate library project is ... + -- Configuration: configuration project is ... + + All_Packages : constant String_List_Access; + -- Default value of parameter Packages of procedures Parse, in Prj.Pars and + -- Prj.Part, indicating that all packages should be checked. + + type Project_Tree_Data; + type Project_Tree_Ref is access all Project_Tree_Data; + -- Reference to a project tree. Several project trees may exist in memory + -- at the same time. + + No_Project_Tree : constant Project_Tree_Ref; + + procedure Free (Tree : in out Project_Tree_Ref); + -- Free memory associated with the tree + + Config_Project_File_Extension : String := ".cgpr"; + Project_File_Extension : String := ".gpr"; + -- The standard config and user project file name extensions. They are not + -- constants, because Canonical_Case_File_Name is called on these variables + -- in the body of Prj. + + function Empty_File return File_Name_Type; + function Empty_String return Name_Id; + -- Return the id for an empty string "" + + type Path_Information is record + Name : Path_Name_Type := No_Path; + Display_Name : Path_Name_Type := No_Path; + end record; + -- Directory names always end with a directory separator + + No_Path_Information : constant Path_Information := (No_Path, No_Path); + + type Project_Data; + type Project_Id is access all Project_Data; + No_Project : constant Project_Id := null; + -- Id of a Project File + + type String_List_Id is new Nat; + Nil_String : constant String_List_Id := 0; + type String_Element is record + Value : Name_Id := No_Name; + Index : Int := 0; + Display_Value : Name_Id := No_Name; + Location : Source_Ptr := No_Location; + Flag : Boolean := False; + Next : String_List_Id := Nil_String; + end record; + -- To hold values for string list variables and array elements. + -- Component Flag may be used for various purposes. For source + -- directories, it indicates if the directory contains Ada source(s). + + package String_Element_Table is new GNAT.Dynamic_Tables + (Table_Component_Type => String_Element, + Table_Index_Type => String_List_Id, + Table_Low_Bound => 1, + Table_Initial => 200, + Table_Increment => 100); + -- The table for string elements in string lists + + type Variable_Kind is (Undefined, List, Single); + -- Different kinds of variables + + subtype Defined_Variable_Kind is Variable_Kind range List .. Single; + -- The defined kinds of variables + + Ignored : constant Variable_Kind; + -- Used to indicate that a package declaration must be ignored + -- while processing the project tree (unknown package name). + + type Variable_Value (Kind : Variable_Kind := Undefined) is record + Project : Project_Id := No_Project; + Location : Source_Ptr := No_Location; + Default : Boolean := False; + case Kind is + when Undefined => + null; + when List => + Values : String_List_Id := Nil_String; + when Single => + Value : Name_Id := No_Name; + Index : Int := 0; + end case; + end record; + -- Values for variables and array elements. Default is True if the + -- current value is the default one for the variable. + + Nil_Variable_Value : constant Variable_Value; + -- Value of a non existing variable or array element + + type Variable_Id is new Nat; + No_Variable : constant Variable_Id := 0; + type Variable is record + Next : Variable_Id := No_Variable; + Name : Name_Id; + Value : Variable_Value; + end record; + -- To hold the list of variables in a project file and in packages + + package Variable_Element_Table is new GNAT.Dynamic_Tables + (Table_Component_Type => Variable, + Table_Index_Type => Variable_Id, + Table_Low_Bound => 1, + Table_Initial => 200, + Table_Increment => 100); + -- The table of variable in list of variables + + type Array_Element_Id is new Nat; + No_Array_Element : constant Array_Element_Id := 0; + type Array_Element is record + Index : Name_Id; + Src_Index : Int := 0; + Index_Case_Sensitive : Boolean := True; + Value : Variable_Value; + Next : Array_Element_Id := No_Array_Element; + end record; + -- Each Array_Element represents an array element and is linked (Next) + -- to the next array element, if any, in the array. + + package Array_Element_Table is new GNAT.Dynamic_Tables + (Table_Component_Type => Array_Element, + Table_Index_Type => Array_Element_Id, + Table_Low_Bound => 1, + Table_Initial => 200, + Table_Increment => 100); + -- The table that contains all array elements + + type Array_Id is new Nat; + No_Array : constant Array_Id := 0; + type Array_Data is record + Name : Name_Id := No_Name; + Location : Source_Ptr := No_Location; + Value : Array_Element_Id := No_Array_Element; + Next : Array_Id := No_Array; + end record; + -- Each Array_Data value represents an array. + -- Value is the id of the first element. + -- Next is the id of the next array in the project file or package. + + package Array_Table is new GNAT.Dynamic_Tables + (Table_Component_Type => Array_Data, + Table_Index_Type => Array_Id, + Table_Low_Bound => 1, + Table_Initial => 200, + Table_Increment => 100); + -- The table that contains all arrays + + type Package_Id is new Nat; + No_Package : constant Package_Id := 0; + type Declarations is record + Variables : Variable_Id := No_Variable; + Attributes : Variable_Id := No_Variable; + Arrays : Array_Id := No_Array; + Packages : Package_Id := No_Package; + end record; + -- Contains the declarations (variables, single and array attributes, + -- packages) for a project or a package in a project. + + No_Declarations : constant Declarations := + (Variables => No_Variable, + Attributes => No_Variable, + Arrays => No_Array, + Packages => No_Package); + -- Default value of Declarations: indicates that there is no declarations + + type Package_Element is record + Name : Name_Id := No_Name; + Decl : Declarations := No_Declarations; + Parent : Package_Id := No_Package; + Next : Package_Id := No_Package; + end record; + -- A package (includes declarations that may include other packages) + + package Package_Table is new GNAT.Dynamic_Tables + (Table_Component_Type => Package_Element, + Table_Index_Type => Package_Id, + Table_Low_Bound => 1, + Table_Initial => 100, + Table_Increment => 100); + -- The table that contains all packages + + type Language_Data; + type Language_Ptr is access all Language_Data; + -- Index of language data + + No_Language_Index : constant Language_Ptr := null; + -- Constant indicating that there is no language data + + function Get_Language_From_Name + (Project : Project_Id; + Name : String) return Language_Ptr; + -- Get a language from a project. This might return null if no such + -- language exists in the project + + Max_Header_Num : constant := 6150; + type Header_Num is range 0 .. Max_Header_Num; + -- Size for hash table below. The upper bound is an arbitrary value, the + -- value here was chosen after testing to determine a good compromise + -- between speed of access and memory usage. + + function Hash (Name : Name_Id) return Header_Num; + function Hash (Name : File_Name_Type) return Header_Num; + function Hash (Name : Path_Name_Type) return Header_Num; + function Hash (Project : Project_Id) return Header_Num; + -- Used for computing hash values for names put into hash tables + + type Language_Kind is (File_Based, Unit_Based); + -- Type for the kind of language. All languages are file based, except Ada + -- which is unit based. + + type Dependency_File_Kind is (None, Makefile, ALI_File); + -- Type of dependency to be checked: no dependency file, Makefile fragment + -- or ALI file (for Ada). + + Makefile_Dependency_Suffix : constant String := ".d"; + ALI_Dependency_Suffix : constant String := ".ali"; + Switches_Dependency_Suffix : constant String := ".cswi"; + + Binder_Exchange_Suffix : constant String := ".bexch"; + -- Suffix for binder exchange files + + Library_Exchange_Suffix : constant String := ".lexch"; + -- Suffix for library exchange files + + type Name_List_Index is new Nat; + No_Name_List : constant Name_List_Index := 0; + + type Name_Node is record + Name : Name_Id := No_Name; + Next : Name_List_Index := No_Name_List; + end record; + + package Name_List_Table is new GNAT.Dynamic_Tables + (Table_Component_Type => Name_Node, + Table_Index_Type => Name_List_Index, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100); + -- The table for lists of names + + function Length + (Table : Name_List_Table.Instance; + List : Name_List_Index) return Natural; + -- Return the number of elements in specified list + + type Number_List_Index is new Nat; + No_Number_List : constant Number_List_Index := 0; + + type Number_Node is record + Number : Natural := 0; + Next : Number_List_Index := No_Number_List; + end record; + + package Number_List_Table is new GNAT.Dynamic_Tables + (Table_Component_Type => Number_Node, + Table_Index_Type => Number_List_Index, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100); + -- The table for lists of numbers + + package Mapping_Files_Htable is new Simple_HTable + (Header_Num => Header_Num, + Element => Path_Name_Type, + No_Element => No_Path, + Key => Path_Name_Type, + Hash => Hash, + Equal => "="); + -- A hash table to store the mapping files that are not used + + -- The following record ??? + + type Lang_Naming_Data is record + Dot_Replacement : File_Name_Type := No_File; + -- The string to replace '.' in the source file name (for Ada) + + Casing : Casing_Type := All_Lower_Case; + -- The casing of the source file name (for Ada) + + Separate_Suffix : File_Name_Type := No_File; + -- String to append to unit name for source file name of an Ada subunit + + Spec_Suffix : File_Name_Type := No_File; + -- The string to append to the unit name for the + -- source file name of a spec. + + Body_Suffix : File_Name_Type := No_File; + -- The string to append to the unit name for the + -- source file name of a body. + end record; + + No_Lang_Naming_Data : constant Lang_Naming_Data := + (Dot_Replacement => No_File, + Casing => All_Lower_Case, + Separate_Suffix => No_File, + Spec_Suffix => No_File, + Body_Suffix => No_File); + + function Is_Standard_GNAT_Naming (Naming : Lang_Naming_Data) return Boolean; + -- True if the naming scheme is GNAT's default naming scheme. This + -- is to take into account shortened names like "Ada." (a-), "System." (s-) + -- and so on. + + type Source_Data; + type Source_Id is access all Source_Data; + + function Is_Compilable (Source : Source_Id) return Boolean; + pragma Inline (Is_Compilable); + -- Return True if we know how to compile Source (i.e. if a compiler is + -- defined). This doesn't indicate whether the source should be compiled. + + function Object_To_Global_Archive (Source : Source_Id) return Boolean; + pragma Inline (Object_To_Global_Archive); + -- Return True if the object file should be put in the global archive. + -- This is for Ada, when only the closure of a main needs to be + -- (re)compiled. + + function Other_Part (Source : Source_Id) return Source_Id; + pragma Inline (Other_Part); + -- Source ID for the other part, if any: for a spec, indicates its body; + -- for a body, indicates its spec. + + No_Source : constant Source_Id := null; + + type Path_Syntax_Kind is + (Canonical, + -- Unix style + Host); + -- Host specific syntax, for example on VMS (the default) + + -- The following record describes the configuration of a language + + type Language_Config is record + Kind : Language_Kind := File_Based; + -- Kind of language. All languages are file based, except Ada which is + -- unit based. + + Naming_Data : Lang_Naming_Data; + -- The naming data for the languages (prefixes, etc.) + + Include_Compatible_Languages : Name_List_Index := No_Name_List; + -- List of languages that are "include compatible" with this language. A + -- language B (for example "C") is "include compatible" with a language + -- A (for example "C++") if it is expected that sources of language A + -- may "include" header files from language B. + + Compiler_Driver : File_Name_Type := No_File; + -- The name of the executable for the compiler of the language + + Compiler_Driver_Path : String_Access := null; + -- The path name of the executable for the compiler of the language + + Compiler_Leading_Required_Switches : Name_List_Index := No_Name_List; + -- The list of initial switches that are required as a minimum to invoke + -- the compiler driver. + + Compiler_Trailing_Required_Switches : Name_List_Index := No_Name_List; + -- The list of final switches that are required as a minimum to invoke + -- the compiler driver. + + Multi_Unit_Switches : Name_List_Index := No_Name_List; + -- The switch(es) to indicate the index of a unit in a multi-source file + + Multi_Unit_Object_Separator : Character := ' '; + -- The string separating the base name of a source from the index of the + -- unit in a multi-source file, in the object file name. + + Path_Syntax : Path_Syntax_Kind := Host; + -- Value may be Canonical (Unix style) or Host (host syntax, for example + -- on VMS for DEC C). + + Object_File_Suffix : Name_Id := No_Name; + -- Optional alternate object file suffix + + Object_File_Switches : Name_List_Index := No_Name_List; + -- Optional object file switches. When this is defined, the switches + -- are used to specify the object file. The object file name is appended + -- to the last switch in the list. Example: ("-o", ""). + + Compilation_PIC_Option : Name_List_Index := No_Name_List; + -- The option(s) to compile a source in Position Independent Code for + -- shared libraries. Specified in the configuration. When not specified, + -- there is no need for such switch. + + Object_Generated : Boolean := True; + -- False in no object file is generated + + Objects_Linked : Boolean := True; + -- False if object files are not use to link executables and build + -- libraries. + + Runtime_Library_Dir : Name_Id := No_Name; + -- Path name of the runtime library directory, if any + + Runtime_Source_Dir : Name_Id := No_Name; + -- Path name of the runtime source directory, if any + + Mapping_File_Switches : Name_List_Index := No_Name_List; + -- The option(s) to provide a mapping file to the compiler. Specified in + -- the configuration. When value is No_Name_List, there is no mapping + -- file. + + Mapping_Spec_Suffix : File_Name_Type := No_File; + -- Placeholder representing the spec suffix in a mapping file + + Mapping_Body_Suffix : File_Name_Type := No_File; + -- Placeholder representing the body suffix in a mapping file + + Config_File_Switches : Name_List_Index := No_Name_List; + -- The option(s) to provide a config file to the compiler. Specified in + -- the configuration. If value is No_Name_List there is no config file. + + Dependency_Kind : Dependency_File_Kind := None; + -- The kind of dependency to be checked: none, Makefile fragment or + -- ALI file (for Ada). + + Dependency_Option : Name_List_Index := No_Name_List; + -- The option(s) to be used to create the dependency file. When value is + -- No_Name_List, there is not such option(s). + + Compute_Dependency : Name_List_Index := No_Name_List; + -- Hold the value of attribute Dependency_Driver, if declared for the + -- language. + + Include_Option : Name_List_Index := No_Name_List; + -- Hold the value of attribute Include_Switches, if declared for the + -- language. + + Include_Path : Name_Id := No_Name; + -- Name of environment variable declared by attribute Include_Path for + -- the language. + + Include_Path_File : Name_Id := No_Name; + -- Name of environment variable declared by attribute Include_Path_File + -- for the language. + + Objects_Path : Name_Id := No_Name; + -- Name of environment variable declared by attribute Objects_Path for + -- the language. + + Objects_Path_File : Name_Id := No_Name; + -- Name of environment variable declared by attribute Objects_Path_File + -- for the language. + + Config_Body : Name_Id := No_Name; + -- The template for a pragma Source_File_Name(_Project) for a specific + -- file name of a body. + + Config_Body_Index : Name_Id := No_Name; + -- The template for a pragma Source_File_Name(_Project) for a specific + -- file name of a body in a multi-source file. + + Config_Body_Pattern : Name_Id := No_Name; + -- The template for a pragma Source_File_Name(_Project) for a naming + -- body pattern. + + Config_Spec : Name_Id := No_Name; + -- The template for a pragma Source_File_Name(_Project) for a specific + -- file name of a spec. + + Config_Spec_Index : Name_Id := No_Name; + -- The template for a pragma Source_File_Name(_Project) for a specific + -- file name of a spec in a multi-source file. + + Config_Spec_Pattern : Name_Id := No_Name; + -- The template for a pragma Source_File_Name(_Project) for a naming + -- spec pattern. + + Config_File_Unique : Boolean := False; + -- Indicate if the config file specified to the compiler needs to be + -- unique. If it is unique, then all config files are concatenated into + -- a temp config file. + + Binder_Driver : File_Name_Type := No_File; + -- The name of the binder driver for the language, if any + + Binder_Driver_Path : Path_Name_Type := No_Path; + -- The path name of the binder driver + + Binder_Required_Switches : Name_List_Index := No_Name_List; + -- Hold the value of attribute Binder'Required_Switches for the language + + Binder_Prefix : Name_Id := No_Name; + -- Hold the value of attribute Binder'Prefix for the language + + Toolchain_Version : Name_Id := No_Name; + -- Hold the value of attribute Toolchain_Version for the language + + Toolchain_Description : Name_Id := No_Name; + -- Hold the value of attribute Toolchain_Description for the language + + end record; + + No_Language_Config : constant Language_Config := + (Kind => File_Based, + Naming_Data => No_Lang_Naming_Data, + Include_Compatible_Languages => No_Name_List, + Compiler_Driver => No_File, + Compiler_Driver_Path => null, + Compiler_Leading_Required_Switches => No_Name_List, + Compiler_Trailing_Required_Switches => No_Name_List, + Multi_Unit_Switches => No_Name_List, + Multi_Unit_Object_Separator => ' ', + Path_Syntax => Canonical, + Object_File_Suffix => No_Name, + Object_File_Switches => No_Name_List, + Compilation_PIC_Option => No_Name_List, + Object_Generated => True, + Objects_Linked => True, + Runtime_Library_Dir => No_Name, + Runtime_Source_Dir => No_Name, + Mapping_File_Switches => No_Name_List, + Mapping_Spec_Suffix => No_File, + Mapping_Body_Suffix => No_File, + Config_File_Switches => No_Name_List, + Dependency_Kind => None, + Dependency_Option => No_Name_List, + Compute_Dependency => No_Name_List, + Include_Option => No_Name_List, + Include_Path => No_Name, + Include_Path_File => No_Name, + Objects_Path => No_Name, + Objects_Path_File => No_Name, + Config_Body => No_Name, + Config_Body_Index => No_Name, + Config_Body_Pattern => No_Name, + Config_Spec => No_Name, + Config_Spec_Index => No_Name, + Config_Spec_Pattern => No_Name, + Config_File_Unique => False, + Binder_Driver => No_File, + Binder_Driver_Path => No_Path, + Binder_Required_Switches => No_Name_List, + Binder_Prefix => No_Name, + Toolchain_Version => No_Name, + Toolchain_Description => No_Name); + + -- The following record ??? + + type Language_Data is record + Name : Name_Id := No_Name; + Display_Name : Name_Id := No_Name; + Config : Language_Config := No_Language_Config; + First_Source : Source_Id := No_Source; + Mapping_Files : Mapping_Files_Htable.Instance := + Mapping_Files_Htable.Nil; + Next : Language_Ptr := No_Language_Index; + end record; + + No_Language_Data : constant Language_Data := + (Name => No_Name, + Display_Name => No_Name, + Config => No_Language_Config, + First_Source => No_Source, + Mapping_Files => Mapping_Files_Htable.Nil, + Next => No_Language_Index); + + type Language_List_Element; + type Language_List is access all Language_List_Element; + type Language_List_Element is record + Language : Language_Ptr := No_Language_Index; + Next : Language_List; + end record; + + type Source_Kind is (Spec, Impl, Sep); + subtype Spec_Or_Body is Source_Kind range Spec .. Impl; + + -- The following declarations declare a structure used to store the Name + -- and File and Path names of a unit, with a reference to its GNAT Project + -- File(s). Some units might have neither Spec nor Impl when they were + -- created for a "separate". + + type File_Names_Data is array (Spec_Or_Body) of Source_Id; + + type Unit_Data is record + Name : Name_Id := No_Name; + File_Names : File_Names_Data; + end record; + + type Unit_Index is access all Unit_Data; + + No_Unit_Index : constant Unit_Index := null; + -- Used to indicate a null entry for no unit + + -- Structure to define source data + + type Source_Data is record + Initialized : Boolean := False; + -- Set to True when Source_Data is completely initialized + + Project : Project_Id := No_Project; + -- Project of the source + + Location : Source_Ptr := No_Location; + -- Location in the project file of the declaration of the source in + -- package Naming. + + Source_Dir_Rank : Natural := 0; + -- The rank of the source directory in list declared with attribute + -- Source_Dirs. Two source files with the same name cannot appears in + -- different directory with the same rank. That can happen when the + -- recursive notation /** is used in attribute Source_Dirs. + + Language : Language_Ptr := No_Language_Index; + -- Index of the language. This is an index into + -- Project_Tree.Languages_Data. + + In_Interfaces : Boolean := True; + -- False when the source is not included in interfaces, when attribute + -- Interfaces is declared. + + Declared_In_Interfaces : Boolean := False; + -- True when source is declared in attribute Interfaces + + Alternate_Languages : Language_List := null; + -- List of languages a header file may also be, in addition of language + -- Language_Name. + + Kind : Source_Kind := Spec; + -- Kind of the source: spec, body or subunit + + Unit : Unit_Index := No_Unit_Index; + -- Name of the unit, if language is unit based. This is only set for + -- those files that are part of the compilation set (for instance a + -- file in an extended project that is overridden will not have this + -- field set). + + Index : Int := 0; + -- Index of the source in a multi unit source file (the same Source_Data + -- is duplicated several times when there are several units in the same + -- file). Index is 0 if there is either no unit or a single one, and + -- starts at 1 when there are multiple units + + Compilable : Yes_No_Unknown := Unknown; + -- Updated at the first call to Is_Compilable. Yes if source file is + -- compilable. + + In_The_Queue : Boolean := False; + -- True if the source has been put in the queue + + Locally_Removed : Boolean := False; + -- True if the source has been "excluded" + + Replaced_By : Source_Id := No_Source; + -- Missing comment ??? + + File : File_Name_Type := No_File; + -- Canonical file name of the source + + Display_File : File_Name_Type := No_File; + -- File name of the source, for display purposes + + Path : Path_Information := No_Path_Information; + -- Path name of the source + + Source_TS : Time_Stamp_Type := Empty_Time_Stamp; + -- Time stamp of the source file + + Object_Project : Project_Id := No_Project; + -- Project where the object file is. This might be different from + -- Project when using extending project files. + + Object : File_Name_Type := No_File; + -- File name of the object file + + Current_Object_Path : Path_Name_Type := No_Path; + -- Object path of an existing object file + + Object_Path : Path_Name_Type := No_Path; + -- Object path of the real object file + + Object_TS : Time_Stamp_Type := Empty_Time_Stamp; + -- Object file time stamp + + Dep_Name : File_Name_Type := No_File; + -- Dependency file simple name + + Current_Dep_Path : Path_Name_Type := No_Path; + -- Path name of an existing dependency file + + Dep_Path : Path_Name_Type := No_Path; + -- Path name of the real dependency file + + Dep_TS : aliased Osint.File_Attributes := Osint.Unknown_Attributes; + -- Dependency file time stamp + + Switches : File_Name_Type := No_File; + -- File name of the switches file. For all languages, this is a file + -- that ends with the .cswi extension. + + Switches_Path : Path_Name_Type := No_Path; + -- Path name of the switches file + + Switches_TS : Time_Stamp_Type := Empty_Time_Stamp; + -- Switches file time stamp + + Naming_Exception : Boolean := False; + -- True if the source has an exceptional name + + Duplicate_Unit : Boolean := False; + -- True when a duplicate unit has been reported for this source + + Next_In_Lang : Source_Id := No_Source; + -- Link to another source of the same language in the same project + + Next_With_File_Name : Source_Id := No_Source; + -- Link to another source with the same base file name + + end record; + + No_Source_Data : constant Source_Data := + (Initialized => False, + Project => No_Project, + Location => No_Location, + Source_Dir_Rank => 0, + Language => No_Language_Index, + In_Interfaces => True, + Declared_In_Interfaces => False, + Alternate_Languages => null, + Kind => Spec, + Unit => No_Unit_Index, + Index => 0, + Locally_Removed => False, + Compilable => Unknown, + In_The_Queue => False, + Replaced_By => No_Source, + File => No_File, + Display_File => No_File, + Path => No_Path_Information, + Source_TS => Empty_Time_Stamp, + Object_Project => No_Project, + Object => No_File, + Current_Object_Path => No_Path, + Object_Path => No_Path, + Object_TS => Empty_Time_Stamp, + Dep_Name => No_File, + Current_Dep_Path => No_Path, + Dep_Path => No_Path, + Dep_TS => Osint.Unknown_Attributes, + Switches => No_File, + Switches_Path => No_Path, + Switches_TS => Empty_Time_Stamp, + Naming_Exception => False, + Duplicate_Unit => False, + Next_In_Lang => No_Source, + Next_With_File_Name => No_Source); + + package Source_Files_Htable is new Simple_HTable + (Header_Num => Header_Num, + Element => Source_Id, + No_Element => No_Source, + Key => File_Name_Type, + Hash => Hash, + Equal => "="); + -- Mapping of source file names to source ids + + package Source_Paths_Htable is new Simple_HTable + (Header_Num => Header_Num, + Element => Source_Id, + No_Element => No_Source, + Key => Path_Name_Type, + Hash => Hash, + Equal => "="); + -- Mapping of source paths to source ids + + package Unit_Sources_Htable is new Simple_HTable + (Header_Num => Header_Num, + Element => Source_Id, + No_Element => No_Source, + Key => Name_Id, + Hash => Hash, + Equal => "="); + + type Verbosity is (Default, Medium, High); + pragma Ordered (Verbosity); + -- Verbosity when parsing GNAT Project Files + -- Default is default (very quiet, if no errors). + -- Medium is more verbose. + -- High is extremely verbose. + + Current_Verbosity : Verbosity := Default; + -- The current value of the verbosity the project files are parsed with + + type Lib_Kind is (Static, Dynamic, Relocatable); + + type Policy is (Autonomous, Compliant, Controlled, Restricted, Direct); + -- Type to specify the symbol policy, when symbol control is supported. + -- See full explanation about this type in package Symbols. + -- Autonomous: Create a symbol file without considering any reference + -- Compliant: Try to be as compatible as possible with an existing ref + -- Controlled: Fail if symbols are not the same as those in the reference + -- Restricted: Restrict the symbols to those in the symbol file + -- Direct: The symbol file is used as is + + type Symbol_Record is record + Symbol_File : Path_Name_Type := No_Path; + Reference : Path_Name_Type := No_Path; + Symbol_Policy : Policy := Autonomous; + end record; + -- Type to keep the symbol data to be used when building a shared library + + No_Symbols : constant Symbol_Record := + (Symbol_File => No_Path, + Reference => No_Path, + Symbol_Policy => Autonomous); + -- The default value of the symbol data + + function Image (The_Casing : Casing_Type) return String; + -- Similar to 'Image (but avoid use of this attribute in compiler) + + function Value (Image : String) return Casing_Type; + -- Similar to 'Value (but avoid use of this attribute in compiler) + -- Raises Constraint_Error if not a Casing_Type image. + + -- The following record contains data for a naming scheme + + function Get_Object_Directory + (Project : Project_Id; + Including_Libraries : Boolean; + Only_If_Ada : Boolean := False) return Path_Name_Type; + -- Return the object directory to use for the project. This depends on + -- whether we have a library project or a standard project. This function + -- might return No_Name when no directory applies. + -- If we have a library project file and Including_Libraries is True then + -- the library dir is returned instead of the object dir. + -- If Only_If_Ada is True, then No_Name will be returned when the project + -- doesn't Ada sources. + + procedure Compute_All_Imported_Projects (Tree : Project_Tree_Ref); + -- For all projects in the tree, compute the list of the projects imported + -- directly or indirectly by project Project. The result is stored in + -- Project.All_Imported_Projects for each project + + function Ultimate_Extending_Project_Of + (Proj : Project_Id) return Project_Id; + -- Returns the ultimate extending project of project Proj. If project Proj + -- is not extended, returns Proj. + + type Project_List_Element; + type Project_List is access all Project_List_Element; + type Project_List_Element is record + Project : Project_Id := No_Project; + Next : Project_List := null; + end record; + -- A list of projects + + procedure Free_List + (List : in out Project_List; + Free_Project : Boolean); + -- Free the list of projects, if Free_Project, each project is also freed + + type Response_File_Format is + (None, + GNU, + Object_List, + Option_List, + GCC, + GCC_GNU, + GCC_Object_List, + GCC_Option_List); + -- The format of the different response files + + type Project_Configuration is record + Target : Name_Id := No_Name; + -- The target of the configuration, when specified + + Run_Path_Option : Name_List_Index := No_Name_List; + -- The option to use when linking to specify the path where to look for + -- libraries. + + Run_Path_Origin : Name_Id := No_Name; + -- Specify the string (such as "$ORIGIN") to indicate paths relative to + -- the directory of the executable in the run path option. + + Library_Install_Name_Option : Name_Id := No_Name; + -- When this is not an empty list, this option, followed by the single + -- name of the shared library file is used when linking a shared + -- library. + + Separate_Run_Path_Options : Boolean := False; + -- True if each directory needs to be specified in a separate run path + -- option. + + Executable_Suffix : Name_Id := No_Name; + -- The suffix of executables, when specified in the configuration or in + -- package Builder of the main project. When this is not specified, the + -- executable suffix is the default for the platform. + + -- Linking + + Linker : Path_Name_Type := No_Path; + -- Path name of the linker driver. Specified in the configuration or in + -- the package Builder of the main project. + + Map_File_Option : Name_Id := No_Name; + -- Option to use when invoking the linker to build a map file + + Trailing_Linker_Required_Switches : Name_List_Index := No_Name_List; + -- The minimum options for the linker driver. Specified in the + -- configuration. + + Linker_Executable_Option : Name_List_Index := No_Name_List; + -- The option(s) to indicate the name of the executable in the linker + -- command. Specified in the configuration. When not specified, default + -- to -o . + + Linker_Lib_Dir_Option : Name_Id := No_Name; + -- The option to specify where to find a library for linking. Specified + -- in the configuration. When not specified, defaults to "-L". + + Linker_Lib_Name_Option : Name_Id := No_Name; + -- The option to specify the name of a library for linking. Specified in + -- the configuration. When not specified, defaults to "-l". + + Max_Command_Line_Length : Natural := 0; + -- When positive and when Resp_File_Format (see below) is not None, + -- if the command line for the invocation of the linker would be greater + -- than this value, a response file is used to invoke the linker. + + Resp_File_Format : Response_File_Format := None; + -- The format of a response file, when linking with a response file is + -- supported. + + Resp_File_Options : Name_List_Index := No_Name_List; + -- The switches, if any, that precede the path name of the response + -- file in the invocation of the linker. + + -- Libraries + + Library_Builder : Path_Name_Type := No_Path; + -- The executable to build library (specified in the configuration) + + Lib_Support : Library_Support := None; + -- The level of library support. Specified in the configuration. Support + -- is none, static libraries only or both static and shared libraries. + + Archive_Builder : Name_List_Index := No_Name_List; + -- The name of the executable to build archives, with the minimum + -- switches. Specified in the configuration. + + Archive_Builder_Append_Option : Name_List_Index := No_Name_List; + -- The options to append object files to an archive + + Archive_Indexer : Name_List_Index := No_Name_List; + -- The name of the executable to index archives, with the minimum + -- switches. Specified in the configuration. + + Archive_Suffix : File_Name_Type := No_File; + -- The suffix of archives. Specified in the configuration. When not + -- specified, defaults to ".a". + + Lib_Partial_Linker : Name_List_Index := No_Name_List; + + -- Shared libraries + + Shared_Lib_Driver : File_Name_Type := No_File; + -- The driver to link shared libraries. Set with attribute Library_GCC. + -- Default to gcc. + + Shared_Lib_Prefix : File_Name_Type := No_File; + -- Part of a shared library file name that precedes the name of the + -- library. Specified in the configuration. When not specified, defaults + -- to "lib". + + Shared_Lib_Suffix : File_Name_Type := No_File; + -- Suffix of shared libraries, after the library name in the shared + -- library name. Specified in the configuration. When not specified, + -- default to ".so". + + Shared_Lib_Min_Options : Name_List_Index := No_Name_List; + -- The minimum options to use when building a shared library + + Lib_Version_Options : Name_List_Index := No_Name_List; + -- The options to use to specify a library version + + Symbolic_Link_Supported : Boolean := False; + -- True if the platform supports symbolic link files + + Lib_Maj_Min_Id_Supported : Boolean := False; + -- True if platform supports library major and minor options, such as + -- libname.so -> libname.so.2 -> libname.so.2.4 + + Auto_Init_Supported : Boolean := False; + -- True if automatic initialisation is supported for shared stand-alone + -- libraries. + end record; + + Default_Project_Config : constant Project_Configuration := + (Target => No_Name, + Run_Path_Option => No_Name_List, + Run_Path_Origin => No_Name, + Library_Install_Name_Option => No_Name, + Separate_Run_Path_Options => False, + Executable_Suffix => No_Name, + Linker => No_Path, + Map_File_Option => No_Name, + Trailing_Linker_Required_Switches => + No_Name_List, + Linker_Executable_Option => No_Name_List, + Linker_Lib_Dir_Option => No_Name, + Linker_Lib_Name_Option => No_Name, + Library_Builder => No_Path, + Max_Command_Line_Length => 0, + Resp_File_Format => None, + Resp_File_Options => No_Name_List, + Lib_Support => None, + Archive_Builder => No_Name_List, + Archive_Builder_Append_Option => No_Name_List, + Archive_Indexer => No_Name_List, + Archive_Suffix => No_File, + Lib_Partial_Linker => No_Name_List, + Shared_Lib_Driver => No_File, + Shared_Lib_Prefix => No_File, + Shared_Lib_Suffix => No_File, + Shared_Lib_Min_Options => No_Name_List, + Lib_Version_Options => No_Name_List, + Symbolic_Link_Supported => False, + Lib_Maj_Min_Id_Supported => False, + Auto_Init_Supported => False); + + -- The following record describes a project file representation + + -- Note that it is not specified if the path names of directories (source, + -- object, library or exec directories) end with or without a directory + -- separator. + + type Project_Data is record + + ------------- + -- General -- + ------------- + + Name : Name_Id := No_Name; + -- The name of the project + + Display_Name : Name_Id := No_Name; + -- The name of the project with the spelling of its declaration + + Qualifier : Project_Qualifier := Unspecified; + -- The eventual qualifier for this project + + Externally_Built : Boolean := False; + -- True if the project is externally built. In such case, the Project + -- Manager will not modify anything in this project. + + Config : Project_Configuration; + + Path : Path_Information := No_Path_Information; + -- The path name of the project file. This include base name of the + -- project file. + + Virtual : Boolean := False; + -- True for virtual extending projects + + Location : Source_Ptr := No_Location; + -- The location in the project file source of the reserved word project + + --------------- + -- Languages -- + --------------- + + Languages : Language_Ptr := No_Language_Index; + -- First index of the language data in the project. + -- This is an index into the project_tree_data.languages_data. + -- Traversing the list gives access to all the languages supported by + -- the project. + + -------------- + -- Projects -- + -------------- + + Mains : String_List_Id := Nil_String; + -- List of mains specified by attribute Main + + Extends : Project_Id := No_Project; + -- The reference of the project file, if any, that this project file + -- extends. + + Extended_By : Project_Id := No_Project; + -- The reference of the project file, if any, that extends this project + -- file. + + Decl : Declarations := No_Declarations; + -- The declarations (variables, attributes and packages) of this project + -- file. + + Imported_Projects : Project_List; + -- The list of all directly imported projects, if any + + All_Imported_Projects : Project_List; + -- The list of all projects imported directly or indirectly, if any. + -- This does not include the project itself. + + ----------------- + -- Directories -- + ----------------- + + Directory : Path_Information := No_Path_Information; + -- Path name of the directory where the project file resides + + Object_Directory : Path_Information := No_Path_Information; + -- The path name of the object directory of this project file + + Exec_Directory : Path_Information := No_Path_Information; + -- The path name of the exec directory of this project file. Default is + -- equal to Object_Directory. + + ------------- + -- Library -- + ------------- + + Library : Boolean := False; + -- True if this is a library project + + Library_Name : Name_Id := No_Name; + -- If a library project, name of the library + + Library_Kind : Lib_Kind := Static; + -- If a library project, kind of library + + Library_Dir : Path_Information := No_Path_Information; + -- If a library project, path name of the directory where the library + -- resides. + + Library_TS : Time_Stamp_Type := Empty_Time_Stamp; + -- The timestamp of a library file in a library project + + Library_Src_Dir : Path_Information := No_Path_Information; + -- If a Stand-Alone Library project, path name of the directory where + -- the sources of the interfaces of the library are copied. By default, + -- if attribute Library_Src_Dir is not specified, sources of the + -- interfaces are not copied anywhere. + + Library_ALI_Dir : Path_Information := No_Path_Information; + -- In a library project, path name of the directory where the ALI files + -- are copied. If attribute Library_ALI_Dir is not specified, ALI files + -- are copied in the Library_Dir. + + Lib_Internal_Name : Name_Id := No_Name; + -- If a library project, internal name store inside the library + + Standalone_Library : Boolean := False; + -- Indicate that this is a Standalone Library Project File + + Lib_Interface_ALIs : String_List_Id := Nil_String; + -- For Standalone Library Project Files, indicate the list of Interface + -- ALI files. + + Lib_Auto_Init : Boolean := False; + -- For non static Stand-Alone Library Project Files, indicate if + -- the library initialisation should be automatic. + + Symbol_Data : Symbol_Record := No_Symbols; + -- Symbol file name, reference symbol file name, symbol policy + + Need_To_Build_Lib : Boolean := False; + -- Indicates that the library of a Library Project needs to be built or + -- rebuilt. + + ------------- + -- Sources -- + ------------- + -- The sources for all languages including Ada are accessible through + -- the Source_Iterator type + + Interfaces_Defined : Boolean := False; + -- True if attribute Interfaces is declared for the project or any + -- project it extends. + + Include_Path_File : Path_Name_Type := No_Path; + -- The path name of the of the source search directory file. + -- This is only used by gnatmake + + Source_Dirs : String_List_Id := Nil_String; + -- The list of all the source directories + + Source_Dir_Ranks : Number_List_Index := No_Number_List; + + Ada_Include_Path : String_Access := null; + -- The cached value of source search path for this project file. Set by + -- the first call to Prj.Env.Ada_Include_Path for the project. Do not + -- use this field directly outside of the project manager, use + -- Prj.Env.Ada_Include_Path instead. + + Has_Multi_Unit_Sources : Boolean := False; + -- Whether there is at least one source file containing multiple units + + ------------------- + -- Miscellaneous -- + ------------------- + + Ada_Objects_Path : String_Access := null; + -- The cached value of ADA_OBJECTS_PATH for this project file. Do not + -- use this field directly outside of the compiler, use + -- Prj.Env.Ada_Objects_Path instead. + + Libgnarl_Needed : Yes_No_Unknown := Unknown; + -- Set to True when libgnarl is needed to link + + Objects_Path : String_Access := null; + -- The cached value of the object dir path, used during the binding + -- phase of gprbuild. + + Objects_Path_File_With_Libs : Path_Name_Type := No_Path; + -- The cached value of the object path temp file (including library + -- dirs) for this project file. + + Objects_Path_File_Without_Libs : Path_Name_Type := No_Path; + -- The cached value of the object path temp file (excluding library + -- dirs) for this project file. + + Config_File_Name : Path_Name_Type := No_Path; + -- The path name of the configuration pragmas file, if any + + Config_File_Temp : Boolean := False; + -- An indication that the configuration pragmas file is a temporary file + -- that must be deleted at the end. + + Config_Checked : Boolean := False; + -- A flag to avoid checking repetitively the configuration pragmas file + + Depth : Natural := 0; + -- The maximum depth of a project in the project graph. Depth of main + -- project is 0. + + Unkept_Comments : Boolean := False; + -- True if there are comments in the project sources that cannot be kept + -- in the project tree. + + end record; + + function Empty_Project return Project_Data; + -- Return the representation of an empty project + + function Is_Extending + (Extending : Project_Id; + Extended : Project_Id) return Boolean; + -- Return True if Extending is extending the Extended project + + function Has_Ada_Sources (Data : Project_Id) return Boolean; + -- Return True if the project has Ada sources + + Project_Error : exception; + -- Raised by some subprograms in Prj.Attr + + package Units_Htable is new Simple_HTable + (Header_Num => Header_Num, + Element => Unit_Index, + No_Element => No_Unit_Index, + Key => Name_Id, + Hash => Hash, + Equal => "="); + -- Mapping of unit names to indexes in the Units table + + --------------------- + -- Source_Iterator -- + --------------------- + + type Source_Iterator is private; + + function For_Each_Source + (In_Tree : Project_Tree_Ref; + Project : Project_Id := No_Project; + Language : Name_Id := No_Name) return Source_Iterator; + -- Returns an iterator for all the sources of a project tree, or a specific + -- project, or a specific language. + + function Element (Iter : Source_Iterator) return Source_Id; + -- Return the current source (or No_Source if there are no more sources) + + procedure Next (Iter : in out Source_Iterator); + -- Move on to the next source + + function Find_Source + (In_Tree : Project_Tree_Ref; + Project : Project_Id; + In_Imported_Only : Boolean := False; + In_Extended_Only : Boolean := False; + Base_Name : File_Name_Type) return Source_Id; + -- Find the first source file with the given name either in the whole tree + -- (if In_Imported_Only is False) or in the projects imported or extended + -- by Project otherwise. In_Extended_Only implies In_Imported_Only, and + -- will only look in Project and the projects it extends + + ----------------------- + -- Project_Tree_Data -- + ----------------------- + + package Replaced_Source_HTable is new Simple_HTable + (Header_Num => Header_Num, + Element => File_Name_Type, + No_Element => No_File, + Key => File_Name_Type, + Hash => Hash, + Equal => "="); + + type Private_Project_Tree_Data is private; + -- Data for a project tree that is used only by the Project Manager + + type Project_Tree_Data is + record + Name_Lists : Name_List_Table.Instance; + Number_Lists : Number_List_Table.Instance; + String_Elements : String_Element_Table.Instance; + Variable_Elements : Variable_Element_Table.Instance; + Array_Elements : Array_Element_Table.Instance; + Arrays : Array_Table.Instance; + Packages : Package_Table.Instance; + Projects : Project_List; + + Replaced_Sources : Replaced_Source_HTable.Instance; + -- The list of sources that have been replaced by sources with + -- different file names. + + Replaced_Source_Number : Natural := 0; + -- The number of entries in Replaced_Sources + + Units_HT : Units_Htable.Instance; + -- Unit name to Unit_Index (and from there to Source_Id) + + Source_Files_HT : Source_Files_Htable.Instance; + -- Base source file names to Source_Id list. + + Source_Paths_HT : Source_Paths_Htable.Instance; + -- Full path to Source_Id + + Source_Info_File_Name : String_Access := null; + -- The name of the source info file, if specified by the builder + + Source_Info_File_Exists : Boolean := False; + -- True when a source info file has been successfully read + + Private_Part : Private_Project_Tree_Data; + end record; + -- Data for a project tree + + procedure Expect (The_Token : Token_Type; Token_Image : String); + -- Check that the current token is The_Token. If it is not, then output + -- an error message. + + procedure Initialize (Tree : Project_Tree_Ref); + -- This procedure must be called before using any services from the Prj + -- hierarchy. Namet.Initialize must be called before Prj.Initialize. + + procedure Reset (Tree : Project_Tree_Ref); + -- This procedure resets all the tables that are used when processing a + -- project file tree. Initialize must be called before the call to Reset. + + package Project_Boolean_Htable is new Simple_HTable + (Header_Num => Header_Num, + Element => Boolean, + No_Element => False, + Key => Project_Id, + Hash => Hash, + Equal => "="); + -- A table that associates a project to a boolean. This is used to detect + -- whether a project was already processed for instance. + + generic + type State is limited private; + with procedure Action + (Project : Project_Id; + With_State : in out State); + procedure For_Every_Project_Imported + (By : Project_Id; + With_State : in out State; + Imported_First : Boolean := False); + -- Call Action for each project imported directly or indirectly by project + -- By, as well as extended projects. + -- + -- The order of processing depends on Imported_First: + -- + -- If False, Action is called according to the order of importation: if A + -- imports B, directly or indirectly, Action will be called for A before + -- it is called for B. If two projects import each other directly or + -- indirectly (using at least one "limited with"), it is not specified + -- for which of these two projects Action will be called first. + -- + -- The order is reversed if Imported_First is True + -- + -- With_State may be used by Action to choose a behavior or to report some + -- global result. + + function Extend_Name + (File : File_Name_Type; + With_Suffix : String) return File_Name_Type; + -- Replace the extension of File with With_Suffix + + function Object_Name + (Source_File_Name : File_Name_Type; + Object_File_Suffix : Name_Id := No_Name) return File_Name_Type; + -- Returns the object file name corresponding to a source file name + + function Object_Name + (Source_File_Name : File_Name_Type; + Source_Index : Int; + Index_Separator : Character; + Object_File_Suffix : Name_Id := No_Name) return File_Name_Type; + -- Returns the object file name corresponding to a unit in a multi-source + -- file. + + function Dependency_Name + (Source_File_Name : File_Name_Type; + Dependency : Dependency_File_Kind) return File_Name_Type; + -- Returns the dependency file name corresponding to a source file name + + function Switches_Name + (Source_File_Name : File_Name_Type) return File_Name_Type; + -- Returns the switches file name corresponding to a source file name + + ----------- + -- Flags -- + ----------- + + type Processing_Flags is private; + -- Flags used while parsing and processing a project tree to configure the + -- behavior of the parser, and indicate how to report error messages. This + -- structure does not allocate memory and never needs to be freed + + type Error_Warning is (Silent, Warning, Error); + -- Severity of some situations, such as: no Ada sources in a project where + -- Ada is one of the language. + -- + -- When the situation occurs, the behaviour depends on the setting: + -- + -- - Silent: no action + -- - Warning: issue a warning, does not cause the tool to fail + -- - Error: issue an error, causes the tool to fail + + type Error_Handler is access procedure + (Project : Project_Id; + Is_Warning : Boolean); + -- This warns when an error was found when parsing a project. The error + -- itself is handled through Prj.Err (and Prj.Err.Finalize should be called + -- to actually print the error). This ensures that duplicate error messages + -- are always correctly removed, that errors msgs are sorted, and that all + -- tools will report the same error to the user. + + function Create_Flags + (Report_Error : Error_Handler; + When_No_Sources : Error_Warning; + Require_Sources_Other_Lang : Boolean := True; + Allow_Duplicate_Basenames : Boolean := True; + Compiler_Driver_Mandatory : Boolean := False; + Error_On_Unknown_Language : Boolean := True; + Require_Obj_Dirs : Error_Warning := Error; + Allow_Invalid_External : Error_Warning := Error; + Missing_Source_Files : Error_Warning := Error) + return Processing_Flags; + -- Function used to create Processing_Flags structure + -- + -- If Allow_Duplicate_Basenames, then files with the same base names are + -- authorized within a project for source-based languages (never for unit + -- based languages). + -- + -- If Compiler_Driver_Mandatory is true, then a Compiler.Driver attribute + -- for each language must be defined, or we will not look for its source + -- files. + -- + -- When_No_Sources indicates what should be done when no sources of a + -- language are found in a project where this language is declared. + -- If Require_Sources_Other_Lang is true, then all languages must have at + -- least one source file, or an error is reported via When_No_Sources. If + -- it is false, this is only required for Ada (and only if it is a language + -- of the project). When this parameter is set to False, we do not check + -- that a proper naming scheme is defined for languages other than Ada. + -- + -- If Report_Error is null, use the standard error reporting mechanism + -- (Errout). Otherwise, report errors using Report_Error. + -- + -- If Error_On_Unknown_Language is true, an error is displayed if some of + -- the source files listed in the project do not match any naming scheme + -- + -- If Require_Obj_Dirs is true, then all object directories must exist + -- (possibly after they have been created automatically if the appropriate + -- switches were specified), or an error is raised. + -- + -- If Allow_Invalid_External is Silent, then no error is reported when an + -- invalid value is used for an external variable (and it doesn't match its + -- type). Instead, the first possible value is used. + -- + -- Missing_Source_Files indicates whether it is an error or a warning that + -- a source file mentioned in the Source_Files attributes is not actually + -- found in the source directories. This also impacts errors for missing + -- source directories. + + Gprbuild_Flags : constant Processing_Flags; + Gprclean_Flags : constant Processing_Flags; + Gnatmake_Flags : constant Processing_Flags; + -- Flags used by the various tools. They all display the error messages + -- through Prj.Err. + + ---------------- + -- Temp Files -- + ---------------- + + procedure Record_Temp_File + (Tree : Project_Tree_Ref; + Path : Path_Name_Type); + -- Record the path of a newly created temporary file, so that it can be + -- deleted later. + + procedure Delete_All_Temp_Files (Tree : Project_Tree_Ref); + -- Delete all recorded temporary files. + -- Does nothing if Debug.Debug_Flag_N is set + + procedure Delete_Temporary_File + (Tree : Project_Tree_Ref; + Path : Path_Name_Type); + -- Delete a temporary file from the disk. The file is also removed from the + -- list of temporary files to delete at the end of the program, in case + -- another program running on the same machine has recreated it. + -- Does nothing if Debug.Debug_Flag_N is set + + Virtual_Prefix : constant String := "v$"; + -- The prefix for virtual extending projects. Because of the '$', which is + -- normally forbidden for project names, there cannot be any name clash. + +private + + All_Packages : constant String_List_Access := null; + + No_Project_Tree : constant Project_Tree_Ref := null; + + Ignored : constant Variable_Kind := Single; + + Nil_Variable_Value : constant Variable_Value := + (Project => No_Project, + Kind => Undefined, + Location => No_Location, + Default => False); + + type Source_Iterator is record + In_Tree : Project_Tree_Ref; + + Project : Project_List; + All_Projects : Boolean; + -- Current project and whether we should move on to the next + + Language : Language_Ptr; + -- Current language processed + + Language_Name : Name_Id; + -- Only sources of this language will be returned (or all if No_Name) + + Current : Source_Id; + end record; + + procedure Add_To_Buffer + (S : String; + To : in out String_Access; + Last : in out Natural); + -- Append a String to the Buffer + + package Temp_Files_Table is new GNAT.Dynamic_Tables + (Table_Component_Type => Path_Name_Type, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 10); + -- Table to store the path name of all the created temporary files, so that + -- they can be deleted at the end, or when the program is interrupted. + + type Private_Project_Tree_Data is record + Temp_Files : Temp_Files_Table.Instance; + -- Temporary files created as part of running tools (pragma files, + -- mapping files,...) + + Current_Source_Path_File : Path_Name_Type := No_Path; + -- Current value of project source path file env var. Used to avoid + -- setting the env var to the same value. When different from No_Path, + -- this indicates that logical names (VMS) or environment variables were + -- created and should be deassigned to avoid polluting the environment + -- on VMS. + -- gnatmake only + + Current_Object_Path_File : Path_Name_Type := No_Path; + -- Current value of project object path file env var. Used to avoid + -- setting the env var to the same value. + -- gnatmake only + + end record; + -- Type to represent the part of a project tree which is private to the + -- Project Manager. + + type Processing_Flags is record + Require_Sources_Other_Lang : Boolean; + Report_Error : Error_Handler; + When_No_Sources : Error_Warning; + Allow_Duplicate_Basenames : Boolean; + Compiler_Driver_Mandatory : Boolean; + Error_On_Unknown_Language : Boolean; + Require_Obj_Dirs : Error_Warning; + Allow_Invalid_External : Error_Warning; + Missing_Source_Files : Error_Warning; + end record; + + Gprbuild_Flags : constant Processing_Flags := + (Report_Error => null, + When_No_Sources => Warning, + Require_Sources_Other_Lang => True, + Allow_Duplicate_Basenames => False, + Compiler_Driver_Mandatory => True, + Error_On_Unknown_Language => True, + Require_Obj_Dirs => Error, + Allow_Invalid_External => Error, + Missing_Source_Files => Error); + + Gprclean_Flags : constant Processing_Flags := + (Report_Error => null, + When_No_Sources => Warning, + Require_Sources_Other_Lang => True, + Allow_Duplicate_Basenames => False, + Compiler_Driver_Mandatory => True, + Error_On_Unknown_Language => True, + Require_Obj_Dirs => Warning, + Allow_Invalid_External => Error, + Missing_Source_Files => Error); + + Gnatmake_Flags : constant Processing_Flags := + (Report_Error => null, + When_No_Sources => Error, + Require_Sources_Other_Lang => False, + Allow_Duplicate_Basenames => False, + Compiler_Driver_Mandatory => False, + Error_On_Unknown_Language => False, + Require_Obj_Dirs => Error, + Allow_Invalid_External => Error, + Missing_Source_Files => Error); + +end Prj; diff --git a/gcc/ada/projects.texi b/gcc/ada/projects.texi new file mode 100644 index 000000000..36c915ffe --- /dev/null +++ b/gcc/ada/projects.texi @@ -0,0 +1,3969 @@ +@set gprconfig GPRconfig + +@c ------ projects.texi +@c This file is shared between the GNAT user's guide and gprbuild. It is not +@c compilable on its own, you should instead compile the other two manuals. +@c For that reason, there is no toplevel @menu + +@c --------------------------------------------- +@node GNAT Project Manager +@chapter GNAT Project Manager +@c --------------------------------------------- + +@noindent +@menu +* Introduction:: +* Building With Projects:: +* Organizing Projects into Subsystems:: +* Scenarios in Projects:: +* Library Projects:: +* Project Extension:: +* Project File Reference:: +@end menu + +@c --------------------------------------------- +@node Introduction +@section Introduction +@c --------------------------------------------- + +@noindent +This chapter describes GNAT's @emph{Project Manager}, a facility that allows +you to manage complex builds involving a number of source files, directories, +and options for different system configurations. In particular, +project files allow you to specify: + +@itemize @bullet +@item The directory or set of directories containing the source files, and/or the + names of the specific source files themselves +@item The directory in which the compiler's output + (@file{ALI} files, object files, tree files, etc.) is to be placed +@item The directory in which the executable programs are to be placed +@item Switch settings for any of the project-enabled tools; + you can apply these settings either globally or to individual compilation units. +@item The source files containing the main subprogram(s) to be built +@item The source programming language(s) +@item Source file naming conventions; you can specify these either globally or for + individual compilation units (@pxref{Naming Schemes}). +@item Change any of the above settings depending on external values, thus enabling + the reuse of the projects in various @b{scenarios} (@pxref{Scenarios in Projects}). +@item Automatically build libraries as part of the build process + (@pxref{Library Projects}). + +@end itemize + +@noindent +Project files are written in a syntax close to that of Ada, using familiar +notions such as packages, context clauses, declarations, default values, +assignments, and inheritance (@pxref{Project File Reference}). + +Project files can be built hierarchically from other project files, simplifying +complex system integration and project reuse (@pxref{Organizing Projects into +Subsystems}). + +@itemize @bullet +@item One project can import other projects containing needed source files. + More generally, the Project Manager lets you structure large development + efforts into hierarchical subsystems, where build decisions are delegated + to the subsystem level, and thus different compilation environments + (switch settings) used for different subsystems. +@item You can organize GNAT projects in a hierarchy: a child project + can extend a parent project, inheriting the parent's source files and + optionally overriding any of them with alternative versions + (@pxref{Project Extension}). + +@end itemize + +@noindent +Several tools support project files, generally in addition to specifying +the information on the command line itself). They share common switches +to control the loading of the project (in particular +@option{^-P^/PROJECT_FILE=^@emph{projectfile}} and +@option{^-X^/EXTERNAL_REFERENCE=^@emph{vbl}=@emph{value}}). +@xref{Switches Related to Project Files}. + +The Project Manager supports a wide range of development strategies, +for systems of all sizes. Here are some typical practices that are +easily handled: + +@itemize @bullet +@item Using a common set of source files and generating object files in different + directories via different switch settings. It can be used for instance, for + generating separate sets of object files for debugging and for production. +@item Using a mostly-shared set of source files with different versions of + some units or subunits. It can be used for instance, for grouping and hiding +@end itemize + +@noindent +all OS dependencies in a small number of implementation units. + +Project files can be used to achieve some of the effects of a source +versioning system (for example, defining separate projects for +the different sets of sources that comprise different releases) but the +Project Manager is independent of any source configuration management tool +that might be used by the developers. + +The various sections below introduce the different concepts related to +projects. Each section starts with examples and use cases, and then goes into +the details of related project file capabilities. + +@c --------------------------------------------- +@node Building With Projects +@section Building With Projects +@c --------------------------------------------- + +@noindent +In its simplest form, a unique project is used to build a single executable. +This section concentrates on such a simple setup. Later sections will extend +this basic model to more complex setups. + +The following concepts are the foundation of project files, and will be further +detailed later in this documentation. They are summarized here as a reference. + +@table @asis +@item @b{Project file}: + A text file using an Ada-like syntax, generally using the @file{.gpr} + extension. It defines build-related characteristics of an application. + The characteristics include the list of sources, the location of those + sources, the location for the generated object files, the name of + the main program, and the options for the various tools involved in the + build process. + +@item @b{Project attribute}: + A specific project characteristic is defined by an attribute clause. Its + value is a string or a sequence of strings. All settings in a project + are defined through a list of predefined attributes with precise + semantics. @xref{Attributes}. + +@item @b{Package in a project}: + Global attributes are defined at the top level of a project. + Attributes affecting specific tools are grouped in a + package whose name is related to tool's function. The most common + packages are @code{Builder}, @code{Compiler}, @code{Binder}, + and @code{Linker}. @xref{Packages}. + +@item @b{Project variables}: + In addition to attributes, a project can use variables to store intermediate + values and avoid duplication in complex expressions. It can be initialized + with a value coming from the environment. + A frequent use of variables is to define scenarios. + @xref{External Values}, @xref{Scenarios in Projects}, and @xref{Variables}. + +@item @b{Source files} and @b{source directories}: + A source file is associated with a language through a naming convention. For + instance, @code{foo.c} is typically the name of a C source file; + @code{bar.ads} or @code{bar.1.ada} are two common naming conventions for a + file containing an Ada spec. A compilation unit is often composed of a main + source file and potentially several auxiliary ones, such as header files in C. + The naming conventions can be user defined @xref{Naming Schemes}, and will + drive the builder to call the appropriate compiler for the given source file. + Source files are searched for in the source directories associated with the + project through the @b{Source_Dirs} attribute. By default, all the files (in + these source directories) following the naming conventions associated with the + declared languages are considered to be part of the project. It is also + possible to limit the list of source files using the @b{Source_Files} or + @b{Source_List_File} attributes. Note that those last two attributes only + accept basenames with no directory information. + +@item @b{Object files} and @b{object directory}: + An object file is an intermediate file produced by the compiler from a + compilation unit. It is used by post-compilation tools to produce + final executables or libraries. Object files produced in the context of + a given project are stored in a single directory that can be specified by the + @b{Object_Dir} attribute. In order to store objects in + two or more object directories, the system must be split into + distinct subsystems with their own project file. + +@end table + +The following subsections introduce gradually all the attributes of interest +for simple build needs. Here is the simple setup that will be used in the +following examples. + +The Ada source files @file{pack.ads}, @file{pack.adb}, and @file{proc.adb} are in +the @file{common/} directory. The file @file{proc.adb} contains an Ada main +subprogram @code{Proc} that @code{with}s package @code{Pack}. We want to compile +these source files with the switch @option{-O2}, and put the resulting files in +the directory @file{obj/}. + +@smallexample +@group +^common/^[COMMON]^ + pack.ads + pack.adb + proc.adb +@end group +@group +^common/release/^[COMMON.RELEASE]^ + proc.ali, proc.o pack.ali, pack.o +@end group +@end smallexample + +@noindent +Our project is to be called @emph{Build}. The name of the +file is the name of the project (case-insensitive) with the +@file{.gpr} extension, therefore the project file name is @file{build.gpr}. This +is not mandatory, but a warning is issued when this convention is not followed. + +This is a very simple example, and as stated above, a single project +file is enough for it. We will thus create a new file, that for now +should contain the following code: + +@smallexample +@b{project} Build @b{is} +@b{end} Build; +@end smallexample + +@menu +* Source Files and Directories:: +* Object and Exec Directory:: +* Main Subprograms:: +* Tools Options in Project Files:: +* Compiling with Project Files:: +* Executable File Names:: +* Avoid Duplication With Variables:: +* Naming Schemes:: +@end menu + +@c --------------------------------------------- +@node Source Files and Directories +@subsection Source Files and Directories +@c --------------------------------------------- + +@noindent +When you create a new project, the first thing to describe is how to find the +corresponding source files. This is the only settings that are needed by all +the tools that will use this project (builder, compiler, binder and linker for +the compilation, IDEs to edit the source files,@dots{}). + +@cindex Source directories +First step is to declare the source directories, which are the directories +to be searched to find source files. In the case of the example, +the @file{common} directory is the only source directory. + +@cindex @code{Source_Dirs} +There are several ways of defining source directories: + +@itemize @bullet +@item When the attribute @b{Source_Dirs} is not used, a project contains a + single source directory which is the one where the project file itself + resides. In our example, if @file{build.gpr} is placed in the @file{common} + directory, the project has the needed implicit source directory. + +@item The attribute @b{Source_Dirs} can be set to a list of path names, one + for each of the source directories. Such paths can either be absolute + names (for instance @file{"/usr/local/common/"} on UNIX), or relative to the + directory in which the project file resides (for instance "." if + @file{build.gpr} is inside @file{common/}, or "common" if it is one level up). + Each of the source directories must exist and be readable. + +@cindex portability + The syntax for directories is platform specific. For portability, however, + the project manager will always properly translate UNIX-like path names to + the native format of specific platform. For instance, when the same project + file is to be used both on Unix and Windows, "/" should be used as the + directory separator rather than "\". + +@item The attribute @b{Source_Dirs} can automatically include subdirectories + using a special syntax inspired by some UNIX shells. If any of the path in + the list ends with @emph{"/**"}, then that path and all its subdirectories + (recursively) are included in the list of source directories. For instance, + @file{./**} represent the complete directory tree rooted at ".". +@cindex Source directories, recursive + +@cindex @code{Excluded_Source_Dirs} + When using that construct, it can sometimes be convenient to also use the + attribute @b{Excluded_Source_Dirs}, which is also a list of paths. Each entry + specifies a directory whose immediate content, not including subdirs, is to + be excluded. It is also possible to exclude a complete directory subtree + using the "/**" notation. + +@cindex @code{Ignore_Source_Sub_Dirs} + It is often desirable to remove, from the source directories, directory + subtrees rooted at some subdirectories. An example is the subdirectories + created by a Version Control System such as Subversion that creates directory + subtrees .svn/**. To do that, attribute @b{Ignore_Source_Sub_Dirs} can be + used. It specifies the list of simple file names for the root of these + undesirable directory subtrees. + +@end itemize + +@noindent +When applied to the simple example, and because we generally prefer to have +the project file at the toplevel directory rather than mixed with the sources, +we will create the following file + +@smallexample + build.gpr + @b{project} Build @b{is} + @b{for} Source_Dirs @b{use} ("common"); -- <<<< + @b{end} Build; +@end smallexample + +@noindent +Once source directories have been specified, one may need to indicate +source files of interest. By default, all source files present in the source +directories are considered by the project manager. When this is not desired, +it is possible to specify the list of sources to consider explicitly. +In such a case, only source file base names are indicated and not +their absolute or relative path names. The project manager is in charge of +locating the specified source files in the specified source directories. + +@itemize @bullet +@item By default, the project manager search for all source files of all + specified languages in all the source directories. + + Since the project manager was initially developed for Ada environments, the + default language is usually Ada and the above project file is complete: it + defines without ambiguity the sources composing the project: that is to say, + all the sources in subdirectory "common" for the default language (Ada) using + the default naming convention. + +@cindex @code{Languages} + However, when compiling a multi-language application, or a pure C + application, the project manager must be told which languages are of + interest, which is done by setting the @b{Languages} attribute to a list of + strings, each of which is the name of a language. Tools like + @command{gnatmake} only know about Ada, while other tools like + @command{gprbuild} know about many more languages such as C, C++, Fortran, + assembly and others can be added dynamically. + +@cindex Naming scheme + Even when using only Ada, the default naming might not be suitable. Indeed, + how does the project manager recognizes an "Ada file" from any other + file? Project files can describe the naming scheme used for source files, + and override the default (@pxref{Naming Schemes}). The default is the + standard GNAT extension (@file{.adb} for bodies and @file{.ads} for + specs), which is what is used in our example, explaining why no naming scheme + is explicitly specified. + @xref{Naming Schemes}. + +@item @code{Source Files} + @cindex @code{Source_Files} + In some cases, source directories might contain files that should not be + included in a project. One can specify the explicit list of file names to + be considered through the @b{Source_Files} attribute. + When this attribute is defined, instead of looking at every file in the + source directories, the project manager takes only those names into + consideration reports errors if they cannot be found in the source + directories or does not correspond to the naming scheme. + +@item For various reasons, it is sometimes useful to have a project with no + sources (most of the time because the attributes defined in the project + file will be reused in other projects, as explained in + @pxref{Organizing Projects into Subsystems}. To do this, the attribute + @emph{Source_Files} is set to the empty list, i.e. @code{()}. Alternatively, + @emph{Source_Dirs} can be set to the empty list, with the same + result. + +@item @code{Source_List_File} +@cindex @code{Source_List_File} + If there is a great number of files, it might be more convenient to use + the attribute @b{Source_List_File}, which specifies the full path of a file. + This file must contain a list of source file names (one per line, no + directory information) that are searched as if they had been defined + through @emph{Source_Files}. Such a file can easily be created through + external tools. + + A warning is issued if both attributes @code{Source_Files} and + @code{Source_List_File} are given explicit values. In this case, the + attribute @code{Source_Files} prevails. + +@item @code{Excluded_Source_Files} +@cindex @code{Excluded_Source_Files} +@cindex @code{Locally_Removed_Files} +@cindex @code{Excluded_Source_List_File} + Specifying an explicit list of files is not always convenient.It might be + more convenient to use the default search rules with specific exceptions. + This can be done thanks to the attribute @b{Excluded_Source_Files} + (or its synonym @b{Locally_Removed_Files}). + Its value is the list of file names that should not be taken into account. + This attribute is often used when extending a project, + @xref{Project Extension}. A similar attribute + @b{Excluded_Source_List_File} plays the same + role but takes the name of file containing file names similarly to + @code{Source_List_File}. + +@end itemize + +@noindent +In most simple cases, such as the above example, the default source file search +behavior provides the expected result, and we do not need to add anything after +setting @code{Source_Dirs}. The project manager automatically finds +@file{pack.ads}, @file{pack.adb} and @file{proc.adb} as source files of the +project. + +Note that it is considered an error for a project file to have no sources +attached to it unless explicitly declared as mentioned above. + +If the order of the source directories is known statically, that is if +@code{"/**"} is not used in the string list @code{Source_Dirs}, then there may +be several files with the same source file name sitting in different +directories of the project. In this case, only the file in the first directory +is considered as a source of the project and the others are hidden. If +@code{"/**"} is not used in the string list @code{Source_Dirs}, it is an error +to have several files with the same source file name in the same directory +@code{"/**"} subtree, since there would be an ambiguity as to which one should +be used. However, two files with the same source file name may in two single +directories or directory subtrees. In this case, the one in the first directory +or directory subtree is a source of the project. + +@c --------------------------------------------- +@node Object and Exec Directory +@subsection Object and Exec Directory +@c --------------------------------------------- + +@noindent +The next step when writing a project is to indicate where the compiler should +put the object files. In fact, the compiler and other tools might create +several different kind of files (for GNAT, there is the object file and the ALI +file for instance). One of the important concepts in projects is that most +tools may consider source directories as read-only and do not attempt to create +new or temporary files there. Instead, all files are created in the object +directory. It is of course not true for project-aware IDEs, whose purpose it is +to create the source files. + +@cindex @code{Object_Dir} +The object directory is specified through the @b{Object_Dir} attribute. +Its value is the path to the object directory, either absolute or +relative to the directory containing the project file. This +directory must already exist and be readable and writable, although +some tools have a switch to create the directory if needed (See +the switch @code{-p} for @command{gnatmake} and @command{gprbuild}). + +If the attribute @code{Object_Dir} is not specified, it defaults to +the project directory, that is the directory containing the project file. + +For our example, we can specify the object dir in this way: + +@smallexample + @b{project} Build @b{is} + @b{for} Source_Dirs @b{use} ("common"); + @b{for} Object_Dir @b{use} "obj"; -- <<<< + @b{end} Build; +@end smallexample + +@noindent +As mentioned earlier, there is a single object directory per project. As a +result, if you have an existing system where the object files are spread in +several directories, you can either move all of them into the same directory if +you want to build it with a single project file, or study the section on +subsystems (@pxref{Organizing Projects into Subsystems}) to see how each +separate object directory can be associated with one of the subsystem +constituting the application. + +When the @command{linker} is called, it usually creates an executable. By +default, this executable is placed in the object directory of the project. It +might be convenient to store it in its own directory. + +@cindex @code{Exec_Dir} +This can be done through the @code{Exec_Dir} attribute, which, like +@emph{Object_Dir} contains a single absolute or relative path and must point to +an existing and writable directory, unless you ask the tool to create it on +your behalf. When not specified, It defaults to the object directory and +therefore to the project file's directory if neither @emph{Object_Dir} nor +@emph{Exec_Dir} was specified. + +In the case of the example, let's place the executable in the root +of the hierarchy, ie the same directory as @file{build.gpr}. Hence +the project file is now + +@smallexample + @b{project} Build @b{is} + @b{for} Source_Dirs @b{use} ("common"); + @b{for} Object_Dir @b{use} "obj"; + @b{for} Exec_Dir @b{use} "."; -- <<<< + @b{end} Build; +@end smallexample + +@c --------------------------------------------- +@node Main Subprograms +@subsection Main Subprograms +@c --------------------------------------------- + +@noindent +In the previous section, executables were mentioned. The project manager needs +to be taught what they are. In a project file, an executable is indicated by +pointing to source file of the main subprogram. In C this is the file that +contains the @code{main} function, and in Ada the file that contains the main +unit. + +There can be any number of such main files within a given project, and thus +several executables can be built in the context of a single project file. Of +course, one given executable might not (and in fact will not) need all the +source files referenced by the project. As opposed to other build environments +such as @command{makefile}, one does not need to specify the list of +dependencies of each executable, the project-aware builders knows enough of the +semantics of the languages to build ands link only the necessary elements. + +@cindex @code{Main} +The list of main files is specified via the @b{Main} attribute. It contains +a list of file names (no directories). If a project defines this +attribute, it is not necessary to identify main files on the +command line when invoking a builder, and editors like +@command{GPS} will be able to create extra menus to spawn or debug the +corresponding executables. + +@smallexample + @b{project} Build @b{is} + @b{for} Source_Dirs @b{use} ("common"); + @b{for} Object_Dir @b{use} "obj"; + @b{for} Exec_Dir @b{use} "."; + @b{for} Main @b{use} ("proc.adb"); -- <<<< + @b{end} Build; +@end smallexample + +@noindent +If this attribute is defined in the project, then spawning the builder +with a command such as + +@smallexample + gnatmake ^-Pbuild^/PROJECT_FILE=build^ +@end smallexample + +@noindent +automatically builds all the executables corresponding to the files +listed in the @emph{Main} attribute. It is possible to specify one +or more executables on the command line to build a subset of them. + +@c --------------------------------------------- +@node Tools Options in Project Files +@subsection Tools Options in Project Files +@c --------------------------------------------- + +@noindent +We now have a project file that fully describes our environment, and can be +used to build the application with a simple @command{gnatmake} command as seen +in the previous section. In fact, the empty project we showed immediately at +the beginning (with no attribute at all) could already fulfill that need if it +was put in the @file{common} directory. + +Of course, we always want more control. This section will show you how to +specify the compilation switches that the various tools involved in the +building of the executable should use. + +@cindex command line length +Since source names and locations are described into the project file, it is not +necessary to use switches on the command line for this purpose (switches such +as -I for gcc). This removes a major source of command line length overflow. +Clearly, the builders will have to communicate this information one way or +another to the underlying compilers and tools they call but they usually use +response files for this and thus should not be subject to command line +overflows. + +Several tools are participating to the creation of an executable: the compiler +produces object files from the source files; the binder (in the Ada case) +creates an source file that takes care, among other things, of elaboration +issues and global variables initialization; and the linker gathers everything +into a single executable that users can execute. All these tools are known by +the project manager and will be called with user defined switches from the +project files. However, we need to introduce a new project file concept to +express which switches to be used for any of the tools involved in the build. + +@cindex project file packages +A project file is subdivided into zero or more @b{packages}, each of which +contains the attributes specific to one tool (or one set of tools). Project +files use an Ada-like syntax for packages. Package names permitted in project +files are restricted to a predefined set (@pxref{Packages}), and the contents +of packages are limited to a small set of constructs and attributes +(@pxref{Attributes}). + +Our example project file can be extended with the following empty packages. At +this stage, they could all be omitted since they are empty, but they show which +packages would be involved in the build process. + +@smallexample + @b{project} Build @b{is} + @b{for} Source_Dirs @b{use} ("common"); + @b{for} Object_Dir @b{use} "obj"; + @b{for} Exec_Dir @b{use} "."; + @b{for} Main @b{use} ("proc.adb"); + @b{end} Build; + + @b{package} Builder @b{is} --<<< for gnatmake and gprbuild + @b{end} Builder; + + @b{package} Compiler @b{is} --<<< for the compiler + @b{end} Compiler; + + @b{package} Binder @b{is} --<<< for the binder + @b{end} Binder; + + @b{package} Linker @b{is} --<<< for the linker + @b{end} Linker; +@end smallexample + +@noindent +Let's first examine the compiler switches. As stated in the initial description +of the example, we want to compile all files with @option{-O2}. This is a +compiler switch, although it is usual, on the command line, to pass it to the +builder which then passes it to the compiler. It is recommended to use directly +the right package, which will make the setup easier to understand for other +people. + +Several attributes can be used to specify the switches: + +@table @asis +@item @b{Default_Switches}: +@cindex @code{Default_Switches} + This is the first mention in this manual of an @b{indexed attribute}. When + this attribute is defined, one must supply an @emph{index} in the form of a + literal string. + In the case of @emph{Default_Switches}, the index is the name of the + language to which the switches apply (since a different compiler will + likely be used for each language, and each compiler has its own set of + switches). The value of the attribute is a list of switches. + + In this example, we want to compile all Ada source files with the + @option{-O2} switch, and the resulting project file is as follows + (only the @code{Compiler} package is shown): + + @smallexample + @b{package} Compiler @b{is} + @b{for} Default_Switches ("Ada") @b{use} ("-O2"); + @b{end} Compiler; + @end smallexample + +@item @b{Switches}: +@cindex @code{Switches} + in some cases, we might want to use specific switches + for one or more files. For instance, compiling @file{proc.adb} might not be + possible at high level of optimization because of a compiler issue. + In such a case, the @emph{Switches} + attribute (indexed on the file name) can be used and will override the + switches defined by @emph{Default_Switches}. Our project file would + become: + + @smallexample + @b{package} Compiler @b{is} + @b{for} Default_Switches ("Ada") @b{use} ("-O2"); + @b{for} Switches ("proc.adb") @b{use} ("-O0"); + @b{end} Compiler; + @end smallexample + + @noindent + @code{Switches} may take a pattern as an index, such as in: + + @smallexample + @b{package} Compiler @b{is} + @b{for} Default_Switches ("Ada") @b{use} ("-O2"); + @b{for} Switches ("pkg*") @b{use} ("-O0"); + @b{end} Compiler; + @end smallexample + + @noindent + Sources @file{pkg.adb} and @file{pkg-child.adb} would be compiled with -O0, + not -O2. + + @noindent + @code{Switches} can also be given a language name as index instead of a file + name in which case it has the same semantics as @emph{Default_Switches}. + However, indexes with wild cards are never valid for language name. + +@item @b{Local_Configuration_Pragmas}: +@cindex @code{Local_Configuration_Pragmas} + this attribute may specify the path + of a file containing configuration pragmas for use by the Ada compiler, + such as @code{pragma Restrictions (No_Tasking)}. These pragmas will be + used for all the sources of the project. + +@end table + +The switches for the other tools are defined in a similar manner through the +@b{Default_Switches} and @b{Switches} attributes, respectively in the +@emph{Builder} package (for @command{gnatmake} and @command{gprbuild}), +the @emph{Binder} package (binding Ada executables) and the @emph{Linker} +package (for linking executables). + +@c --------------------------------------------- +@node Compiling with Project Files +@subsection Compiling with Project Files +@c --------------------------------------------- + +@noindent +Now that our project files are written, let's build our executable. +Here is the command we would use from the command line: + +@smallexample + gnatmake ^-Pbuild^/PROJECT_FILE=build^ +@end smallexample + +@noindent +This will automatically build the executables specified through the +@emph{Main} attribute: for each, it will compile or recompile the +sources for which the object file does not exist or is not up-to-date; it +will then run the binder; and finally run the linker to create the +executable itself. + +@command{gnatmake} only knows how to handle Ada files. By using +@command{gprbuild} as a builder, you could automatically manage C files the +same way: create the file @file{utils.c} in the @file{common} directory, +set the attribute @emph{Languages} to @code{"(Ada, C)"}, and run + +@smallexample + gprbuild ^-Pbuild^/PROJECT_FILE=build^ +@end smallexample + +@noindent +Gprbuild knows how to recompile the C files and will +recompile them only if one of their dependencies has changed. No direct +indication on how to build the various elements is given in the +project file, which describes the project properties rather than a +set of actions to be executed. Here is the invocation of +@command{gprbuild} when building a multi-language program: + +@smallexample +$ gprbuild -Pbuild +gcc -c proc.adb +gcc -c pack.adb +gcc -c utils.c +gprbind proc +... +gcc proc.o -o proc +@end smallexample + +@noindent +Notice the three steps described earlier: + +@itemize @bullet +@item The first three gcc commands correspond to the compilation phase. +@item The gprbind command corresponds to the post-compilation phase. +@item The last gcc command corresponds to the final link. + +@end itemize + +@noindent +@cindex @option{-v} option (for GPRbuild) +The default output of GPRbuild's execution is kept reasonably simple and easy +to understand. In particular, some of the less frequently used commands are not +shown, and some parameters are abbreviated. So it is not possible to rerun the +effect of the gprbuild command by cut-and-pasting its output. GPRbuild's option +@code{-v} provides a much more verbose output which includes, among other +information, more complete compilation, post-compilation and link commands. + +@c --------------------------------------------- +@node Executable File Names +@subsection Executable File Names +@c --------------------------------------------- + +@noindent +@cindex @code{Executable} +By default, the executable name corresponding to a main file is +computed from the main source file name. Through the attribute +@b{Builder.Executable}, it is possible to change this default. + +For instance, instead of building @command{proc} (or @command{proc.exe} +on Windows), we could configure our project file to build "proc1" +(resp proc1.exe) with the following addition: + +@smallexample @c projectfile + project Build is + ... -- same as before + package Builder is + for Executable ("proc.adb") use "proc1"; + end Builder + end Build; +@end smallexample + +@noindent +@cindex @code{Executable_Suffix} +Attribute @b{Executable_Suffix}, when specified, may change the suffix +of the executable files, when no attribute @code{Executable} applies: +its value replace the platform-specific executable suffix. +The default executable suffix is empty on UNIX and ".exe" on Windows. + +It is also possible to change the name of the produced executable by using the +command line switch @option{-o}. When several mains are defined in the project, +it is not possible to use the @option{-o} switch and the only way to change the +names of the executable is provided by Attributes @code{Executable} and +@code{Executable_Suffix}. + +@c --------------------------------------------- +@node Avoid Duplication With Variables +@subsection Avoid Duplication With Variables +@c --------------------------------------------- + +@noindent +To illustrate some other project capabilities, here is a slightly more complex +project using similar sources and a main program in C: + +@smallexample @c projectfile +project C_Main is + for Languages use ("Ada", "C"); + for Source_Dirs use ("common"); + for Object_Dir use "obj"; + for Main use ("main.c"); + package Compiler is + C_Switches := ("-pedantic"); + for Default_Switches ("C") use C_Switches; + for Default_Switches ("Ada") use ("-gnaty"); + for Switches ("main.c") use C_Switches & ("-g"); + end Compiler; +end C_Main; +@end smallexample + +@noindent +This project has many similarities with the previous one. +As expected, its @code{Main} attribute now refers to a C source. +The attribute @emph{Exec_Dir} is now omitted, thus the resulting +executable will be put in the directory @file{obj}. + +The most noticeable difference is the use of a variable in the +@emph{Compiler} package to store settings used in several attributes. +This avoids text duplication, and eases maintenance (a single place to +modify if we want to add new switches for C files). We will revisit +the use of variables in the context of scenarios (@pxref{Scenarios in +Projects}). + +In this example, we see how the file @file{main.c} can be compiled with +the switches used for all the other C files, plus @option{-g}. +In this specific situation the use of a variable could have been +replaced by a reference to the @code{Default_Switches} attribute: + +@smallexample @c projectfile + for Switches ("c_main.c") use Compiler'Default_Switches ("C") & ("-g"); +@end smallexample + +@noindent +Note the tick (@emph{'}) used to refer to attributes defined in a package. + +Here is the output of the GPRbuild command using this project: + +@smallexample +$gprbuild -Pc_main +gcc -c -pedantic -g main.c +gcc -c -gnaty proc.adb +gcc -c -gnaty pack.adb +gcc -c -pedantic utils.c +gprbind main.bexch +... +gcc main.o -o main +@end smallexample + +@noindent +The default switches for Ada sources, +the default switches for C sources (in the compilation of @file{lib.c}), +and the specific switches for @file{main.c} have all been taken into +account. + +@c --------------------------------------------- +@node Naming Schemes +@subsection Naming Schemes +@c --------------------------------------------- + +@noindent +Sometimes an Ada software system is ported from one compilation environment to +another (say GNAT), and the file are not named using the default GNAT +conventions. Instead of changing all the file names, which for a variety of +reasons might not be possible, you can define the relevant file naming scheme +in the @b{Naming} package of your project file. + +The naming scheme has two distinct goals for the project manager: it +allows finding of source files when searching in the source +directories, and given a source file name it makes it possible to guess +the associated language, and thus the compiler to use. + +Note that the use by the Ada compiler of pragmas Source_File_Name is not +supported when using project files. You must use the features described in this +paragraph. You can however specify other configuration pragmas +(@pxref{Specifying Configuration Pragmas}). + +The following attributes can be defined in package @code{Naming}: + +@table @asis +@item @b{Casing}: +@cindex @code{Casing} + Its value must be one of @code{"lowercase"} (the default if + unspecified), @code{"uppercase"} or @code{"mixedcase"}. It describes the + casing of file names with regards to the Ada unit name. Given an Ada unit + My_Unit, the file name will respectively be @file{my_unit.adb} (lowercase), + @file{MY_UNIT.ADB} (uppercase) or @file{My_Unit.adb} (mixedcase). + On Windows, file names are case insensitive, so this attribute is + irrelevant. + +@item @b{Dot_Replacement}: +@cindex @code{Dot_Replacement} + This attribute specifies the string that should replace the "." in unit + names. Its default value is @code{"-"} so that a unit + @code{Parent.Child} is expected to be found in the file + @file{parent-child.adb}. The replacement string must satisfy the following + requirements to avoid ambiguities in the naming scheme: + + @itemize - + @item It must not be empty + @item It cannot start or end with an alphanumeric character + @item It cannot be a single underscore + @item It cannot start with an underscore followed by an alphanumeric + @item It cannot contain a dot @code{'.'} except if the entire string + is @code{"."} + + @end itemize + +@item @b{Spec_Suffix} and @b{Specification_Suffix}: +@cindex @code{Spec_Suffix} +@cindex @code{Specification_Suffix} + For Ada, these attributes give the suffix used in file names that contain + specifications. For other languages, they give the extension for files + that contain declaration (header files in C for instance). The attribute + is indexed on the language. + The two attributes are equivalent, but the latter is obsolescent. + If @code{Spec_Suffix ("Ada")} is not specified, then the default is + @code{"^.ads^.ADS^"}. + The value must satisfy the following requirements: + + @itemize - + @item It must not be empty + @item It cannot start with an alphanumeric character + @item It cannot start with an underscore followed by an alphanumeric character + @item It must include at least one dot + + @end itemize + +@item @b{Body_Suffix} and @b{Implementation_Suffix}: +@cindex @code{Body_Suffix} +@cindex @code{Implementation_Suffix} + These attributes give the extension used for file names that contain + code (bodies in Ada). They are indexed on the language. The second + version is obsolescent and fully replaced by the first attribute. + + These attributes must satisfy the same requirements as @code{Spec_Suffix}. + In addition, they must be different from any of the values in + @code{Spec_Suffix}. + If @code{Body_Suffix ("Ada")} is not specified, then the default is + @code{"^.adb^.ADB^"}. + + If @code{Body_Suffix ("Ada")} and @code{Spec_Suffix ("Ada")} end with the + same string, then a file name that ends with the longest of these two + suffixes will be a body if the longest suffix is @code{Body_Suffix ("Ada")} + or a spec if the longest suffix is @code{Spec_Suffix ("Ada")}. + + If the suffix does not start with a '.', a file with a name exactly equal + to the suffix will also be part of the project (for instance if you define + the suffix as @code{Makefile}, a file called @file{Makefile} will be part + of the project. This capability is usually not interesting when building. + However, it might become useful when a project is also used to + find the list of source files in an editor, like the GNAT Programming System + (GPS). + +@item @b{Separate_Suffix}: +@cindex @code{Separate_Suffix} + This attribute is specific to Ada. It denotes the suffix used in file names + that contain separate bodies. If it is not specified, then it defaults to + same value as @code{Body_Suffix ("Ada")}. The same rules apply as for the + @code{Body_Suffix} attribute. The only accepted index is "Ada". + +@item @b{Spec} or @b{Specification}: +@cindex @code{Spec} +@cindex @code{Specification} + This attribute @code{Spec} can be used to define the source file name for a + given Ada compilation unit's spec. The index is the literal name of the Ada + unit (case insensitive). The value is the literal base name of the file that + contains this unit's spec (case sensitive or insensitive depending on the + operating system). This attribute allows the definition of exceptions to the + general naming scheme, in case some files do not follow the usual + convention. + + When a source file contains several units, the relative position of the unit + can be indicated. The first unit in the file is at position 1 + + @smallexample @c projectfile + for Spec ("MyPack.MyChild") use "mypack.mychild.spec"; + for Spec ("top") use "foo.a" at 1; + for Spec ("foo") use "foo.a" at 2; + @end smallexample + +@item @b{Body} or @b{Implementation}: +@cindex @code{Body} +@cindex @code{Implementation} + These attribute play the same role as @emph{Spec} for Ada bodies. + +@item @b{Specification_Exceptions} and @b{Implementation_Exceptions}: +@cindex @code{Specification_Exceptions} +@cindex @code{Implementation_Exceptions} + These attributes define exceptions to the naming scheme for languages + other than Ada. They are indexed on the language name, and contain + a list of file names respectively for headers and source code. + + +@end table + +@ifclear vms +For example, the following package models the Apex file naming rules: + +@smallexample @c projectfile +@group + package Naming is + for Casing use "lowercase"; + for Dot_Replacement use "."; + for Spec_Suffix ("Ada") use ".1.ada"; + for Body_Suffix ("Ada") use ".2.ada"; + end Naming; +@end group +@end smallexample +@end ifclear + +@ifset vms +For example, the following package models the DEC Ada file naming rules: + +@smallexample @c projectfile +@group + package Naming is + for Casing use "lowercase"; + for Dot_Replacement use "__"; + for Spec_Suffix ("Ada") use "_.ada"; + for Body_Suffix ("Ada") use ".ada"; + end Naming; +@end group +@end smallexample + +@noindent +(Note that @code{Casing} is @code{"lowercase"} because GNAT gets the file +names in lower case) +@end ifset + +@c --------------------------------------------- +@node Organizing Projects into Subsystems +@section Organizing Projects into Subsystems +@c --------------------------------------------- + +@noindent +A @b{subsystem} is a coherent part of the complete system to be built. It is +represented by a set of sources and one single object directory. A system can +be composed of a single subsystem when it is simple as we have seen in the +first section. Complex systems are usually composed of several interdependent +subsystems. A subsystem is dependent on another subsystem if knowledge of the +other one is required to build it, and in particular if visibility on some of +the sources of this other subsystem is required. Each subsystem is usually +represented by its own project file. + +In this section, the previous example is being extended. Let's assume some +sources of our @code{Build} project depend on other sources. +For instance, when building a graphical interface, it is usual to depend upon +a graphical library toolkit such as GtkAda. Furthermore, we also need +sources from a logging module we had previously written. + +@menu +* Project Dependencies:: +* Cyclic Project Dependencies:: +* Sharing Between Projects:: +* Global Attributes:: +@end menu + +@c --------------------------------------------- +@node Project Dependencies +@subsection Project Dependencies +@c --------------------------------------------- + +@noindent +GtkAda comes with its own project file (appropriately called +@file{gtkada.gpr}), and we will assume we have already built a project +called @file{logging.gpr} for the logging module. With the information provided +so far in @file{build.gpr}, building the application would fail with an error +indicating that the gtkada and logging units that are relied upon by the sources +of this project cannot be found. + +This is easily solved by adding the following @b{with} clauses at the beginning +of our project: + +@smallexample @c projectfile + with "gtkada.gpr"; + with "a/b/logging.gpr"; + project Build is + ... -- as before + end Build; +@end smallexample + +@noindent +@cindex @code{Externally_Built} +When such a project is compiled, @command{gnatmake} will automatically +check the other projects and recompile their sources when needed. It will also +recompile the sources from @code{Build} when needed, and finally create the +executable. In some cases, the implementation units needed to recompile a +project are not available, or come from some third-party and you do not want to +recompile it yourself. In this case, the attribute @b{Externally_Built} to +"true" can be set, indicating to the builder that this project can be assumed +to be up-to-date, and should not be considered for recompilation. In Ada, if +the sources of this externally built project were compiled with another version +of the compiler or with incompatible options, the binder will issue an error. + +The project's @code{with} clause has several effects. It provides source +visibility between projects during the compilation process. It also guarantees +that the necessary object files from @code{Logging} and @code{GtkAda} are +available when linking @code{Build}. + +As can be seen in this example, the syntax for importing projects is similar +to the syntax for importing compilation units in Ada. However, project files +use literal strings instead of names, and the @code{with} clause identifies +project files rather than packages. + +Each literal string after @code{with} is the path +(absolute or relative) to a project file. The @code{.gpr} extension is +optional, although we recommend adding it. If no extension is specified, +and no project file with the @file{^.gpr^.GPR^} extension is found, then +the file is searched for exactly as written in the @code{with} clause, +that is with no extension. + +@cindex project path +When a relative path or a base name is used, the +project files are searched relative to each of the directories in the +@b{project path}. This path includes all the directories found with the +following algorithm, in that order, as soon as a matching file is found, +the search stops: + +@itemize @bullet +@item First, the file is searched relative to the directory that contains the + current project file. +@item +@cindex @code{ADA_PROJECT_PATH} +@cindex @code{GPR_PROJECT_PATH} + Then it is searched relative to all the directories specified in the + ^environment variables^logical names^ @b{GPR_PROJECT_PATH} and + @b{ADA_PROJECT_PATH} (in that order) if they exist. The former is + recommended, the latter is kept for backward compatibility. +@item Finally, it is searched relative to the default project directories. + Such directories depends on the tool used. For @command{gnatmake}, there is + one default project directory: @file{/lib/gnat/}. In our example, + @file{gtkada.gpr} is found in the predefined directory if it was installed at + the same root as GNAT. + +@end itemize + +@noindent +Some tools also support extending the project path from the command line, +generally through the @option{-aP}. You can see the value of the project +path by using the @command{gnatls -v} command. + +Any symbolic link will be fully resolved in the directory of the +importing project file before the imported project file is examined. + +Any source file in the imported project can be used by the sources of the +importing project, transitively. +Thus if @code{A} imports @code{B}, which imports @code{C}, the sources of +@code{A} may depend on the sources of @code{C}, even if @code{A} does not +import @code{C} explicitly. However, this is not recommended, because if +and when @code{B} ceases to import @code{C}, some sources in @code{A} will +no longer compile. @command{gprbuild} has a switch @option{--no-indirect-imports} +that will report such indirect dependencies. + +One very important aspect of a project hierarchy is that +@b{a given source can only belong to one project} (otherwise the project manager +would not know which settings apply to it and when to recompile it). It means +that different project files do not usually share source directories or +when they do, they need to specify precisely which project owns which sources +using attribute @code{Source_Files} or equivalent. By contrast, 2 projects +can each own a source with the same base file name as long as they live in +different directories. The latter is not true for Ada Sources because of the +correlation between source files and Ada units. + +@c --------------------------------------------- +@node Cyclic Project Dependencies +@subsection Cyclic Project Dependencies +@c --------------------------------------------- + +@noindent +Cyclic dependencies are mostly forbidden: +if @code{A} imports @code{B} (directly or indirectly) then @code{B} +is not allowed to import @code{A}. However, there are cases when cyclic +dependencies would be beneficial. For these cases, another form of import +between projects exists: the @b{limited with}. A project @code{A} that +imports a project @code{B} with a straight @code{with} may also be imported, +directly or indirectly, by @code{B} through a @code{limited with}. + +The difference between straight @code{with} and @code{limited with} is that +the name of a project imported with a @code{limited with} cannot be used in the +project importing it. In particular, its packages cannot be renamed and +its variables cannot be referred to. + +@smallexample @c 0projectfile +with "b.gpr"; +with "c.gpr"; +project A is + For Exec_Dir use B'Exec_Dir; -- ok +end A; + +limited with "a.gpr"; -- Cyclic dependency: A -> B -> A +project B is + For Exec_Dir use A'Exec_Dir; -- not ok +end B; + +with "d.gpr"; +project C is +end C; + +limited with "a.gpr"; -- Cyclic dependency: A -> C -> D -> A +project D is + For Exec_Dir use A'Exec_Dir; -- not ok +end D; +@end smallexample + +@c --------------------------------------------- +@node Sharing Between Projects +@subsection Sharing Between Projects +@c --------------------------------------------- + +@noindent +When building an application, it is common to have similar needs in several of +the projects corresponding to the subsystems under construction. For instance, +they will all have the same compilation switches. + +As seen before (@pxref{Tools Options in Project Files}), setting compilation +switches for all sources of a subsystem is simple: it is just a matter of +adding a @code{Compiler.Default_Switches} attribute to each project files with +the same value. Of course, that means duplication of data, and both places need +to be changed in order to recompile the whole application with different +switches. It can become a real problem if there are many subsystems and thus +many project files to edit. + +There are two main approaches to avoiding this duplication: + +@itemize @bullet +@item Since @file{build.gpr} imports @file{logging.gpr}, we could change it + to reference the attribute in Logging, either through a package renaming, + or by referencing the attribute. The following example shows both cases: + + @smallexample @c projectfile + project Logging is + package Compiler is + for Switches ("Ada") use ("-O2"); + end Compiler; + package Binder is + for Switches ("Ada") use ("-E"); + end Binder; + end Logging; + + with "logging.gpr"; + project Build is + package Compiler renames Logging.Compiler; + package Binder is + for Switches ("Ada") use Logging.Binder'Switches ("Ada"); + end Binder; + end Build; + @end smallexample + + @noindent + The solution used for @code{Compiler} gets the same value for all + attributes of the package, but you cannot modify anything from the + package (adding extra switches or some exceptions). The second + version is more flexible, but more verbose. + + If you need to refer to the value of a variable in an imported + project, rather than an attribute, the syntax is similar but uses + a "." rather than an apostrophe. For instance: + + @smallexample @c projectfile + with "imported"; + project Main is + Var1 := Imported.Var; + end Main; + @end smallexample + +@item The second approach is to define the switches in a third project. + That project is setup without any sources (so that, as opposed to + the first example, none of the project plays a special role), and + will only be used to define the attributes. Such a project is + typically called @file{shared.gpr}. + + @smallexample @c projectfile + abstract project Shared is + for Source_Files use (); -- no project + package Compiler is + for Switches ("Ada") use ("-O2"); + end Compiler; + end Shared; + + with "shared.gpr"; + project Logging is + package Compiler renames Shared.Compiler; + end Logging; + + with "shared.gpr"; + project Build is + package Compiler renames Shared.Compiler; + end Build; + @end smallexample + + @noindent + As for the first example, we could have chosen to set the attributes + one by one rather than to rename a package. The reason we explicitly + indicate that @code{Shared} has no sources is so that it can be created + in any directory and we are sure it shares no sources with @code{Build} + or @code{Logging}, which of course would be invalid. + +@cindex project qualifier + Note the additional use of the @b{abstract} qualifier in @file{shared.gpr}. + This qualifier is optional, but helps convey the message that we do not + intend this project to have sources (@pxref{Qualified Projects} for + more qualifiers). +@end itemize + + +@c --------------------------------------------- +@node Global Attributes +@subsection Global Attributes +@c --------------------------------------------- + +@noindent +We have already seen many examples of attributes used to specify a special +option of one of the tools involved in the build process. Most of those +attributes are project specific. That it to say, they only affect the invocation +of tools on the sources of the project where they are defined. + +There are a few additional attributes that apply to all projects in a +hierarchy as long as they are defined on the "main" project. +The main project is the project explicitly mentioned on the command-line. +The project hierarchy is the "with"-closure of the main project. + +Here is a list of commonly used global attributes: + +@table @asis +@item @b{Builder.Global_Configuration_Pragmas}: +@cindex @code{Global_Configuration_Pragmas} + This attribute points to a file that contains configuration pragmas + to use when building executables. These pragmas apply for all + executables build from this project hierarchy. As we have seen before, + additional pragmas can be specified on a per-project basis by setting the + @code{Compiler.Local_Configuration_Pragmas} attribute. + +@item @b{Builder.Global_Compilation_Switches}: +@cindex @code{Global_Compilation_Switches} + This attribute is a list of compiler switches to use when compiling any + source file in the project hierarchy. These switches are used in addition + to the ones defined in the @code{Compiler} package, which only apply to + the sources of the corresponding project. This attribute is indexed on + the name of the language. + +@end table + +Using such global capabilities is convenient. It can also lead to unexpected +behavior. Especially when several subsystems are shared among different main +projects and the different global attributes are not +compatible. Note that using aggregate projects can be a safer and more powerful +replacement to global attributes. + +@c --------------------------------------------- +@node Scenarios in Projects +@section Scenarios in Projects +@c --------------------------------------------- + +@noindent +Various aspects of the projects can be modified based on @b{scenarios}. These +are user-defined modes that change the behavior of a project. Typical +examples are the setup of platform-specific compiler options, or the use of +a debug and a release mode (the former would activate the generation of debug +information, when the second will focus on improving code optimization). + +Let's enhance our example to support a debug and a release modes.The issue is to +let the user choose what kind of system he is building: +use @option{-g} as compiler switches in debug mode and @option{-O2} +in release mode. We will also setup the projects so that we do not share the +same object directory in both modes, otherwise switching from one to the other +might trigger more recompilations than needed or mix objects from the 2 modes. + +One naive approach is to create two different project files, say +@file{build_debug.gpr} and @file{build_release.gpr}, that set the appropriate +attributes as explained in previous sections. This solution does not scale well, +because in presence of multiple projects depending on each other, +you will also have to duplicate the complete hierarchy and adapt the project +files to point to the right copies. + +@cindex scenarios +Instead, project files support the notion of scenarios controlled +by external values. Such values can come from several sources (in decreasing +order of priority): + +@table @asis +@item @b{Command line}: +@cindex @option{-X} + When launching @command{gnatmake} or @command{gprbuild}, the user can pass + extra @option{-X} switches to define the external value. In + our case, the command line might look like + + @smallexample + gnatmake -Pbuild.gpr -Xmode=debug + or gnatmake -Pbuild.gpr -Xmode=release + @end smallexample + +@item @b{^Environment variables^Logical names^}: + When the external value does not come from the command line, it can come from + the value of ^environment variables^logical names^ of the appropriate name. + In our case, if ^an environment variable^a logical name^ called "mode" + exist, its value will be taken into account. + +@item @b{External function second parameter} + +@end table + +@cindex @code{external} +We now need to get that value in the project. The general form is to use +the predefined function @b{external} which returns the current value of +the external. For instance, we could setup the object directory to point to +either @file{obj/debug} or @file{obj/release} by changing our project to + +@smallexample @c projectfile + project Build is + for Object_Dir use "obj/" & external ("mode", "debug"); + ... -- as before + end Build; +@end smallexample + +@noindent +The second parameter to @code{external} is optional, and is the default +value to use if "mode" is not set from the command line or the environment. + +In order to set the switches according to the different scenarios, other +constructs have to be introduced such as typed variables and case statements. + +@cindex typed variable +@cindex case statement +A @b{typed variable} is a variable that +can take only a limited number of values, similar to an enumeration in Ada. +Such a variable can then be used in a @b{case statement} and create conditional +sections in the project. The following example shows how this can be done: + +@smallexample @c projectfile + project Build is + type Mode_Type is ("debug", "release"); -- all possible values + Mode : Mode_Type := external ("mode", "debug"); -- a typed variable + + package Compiler is + case Mode is + when "debug" => + for Switches ("Ada") use ("-g"); + when "release" => + for Switches ("Ada") use ("-O2"); + end case; + end Compiler; + end Build; +@end smallexample + +@noindent +The project has suddenly grown in size, but has become much more flexible. +@code{Mode_Type} defines the only valid values for the @code{mode} variable. If +any other value is read from the environment, an error is reported and the +project is considered as invalid. + +The @code{Mode} variable is initialized with an external value +defaulting to @code{"debug"}. This default could be omitted and that would +force the user to define the value. Finally, we can use a case statement to set the +switches depending on the scenario the user has chosen. + +Most aspects of the projects can depend on scenarios. The notable exception +are project dependencies (@code{with} clauses), which may not depend on a scenario. + +Scenarios work the same way with @b{project hierarchies}: you can either +duplicate a variable similar to @code{Mode} in each of the project (as long +as the first argument to @code{external} is always the same and the type is +the same), or simply set the variable in the @file{shared.gpr} project +(@pxref{Sharing Between Projects}). + +@c --------------------------------------------- +@node Library Projects +@section Library Projects +@c --------------------------------------------- + +@noindent +So far, we have seen examples of projects that create executables. However, +it is also possible to create libraries instead. A @b{library} is a specific +type of subsystem where, for convenience, objects are grouped together +using system-specific means such as archives or windows DLLs. + +Library projects provide a system- and language-independent way of building both @b{static} +and @b{dynamic} libraries. They also support the concept of @b{standalone +libraries} (SAL) which offers two significant properties: the elaboration +(e.g. initialization) of the library is either automatic or very simple; +a change in the +implementation part of the library implies minimal post-compilation actions on +the complete system and potentially no action at all for the rest of the +system in the case of dynamic SALs. + +The GNAT Project Manager takes complete care of the library build, rebuild and +installation tasks, including recompilation of the source files for which +objects do not exist or are not up to date, assembly of the library archive, and +installation of the library (i.e., copying associated source, object and +@file{ALI} files to the specified location). + +@menu +* Building Libraries:: +* Using Library Projects:: +* Stand-alone Library Projects:: +* Installing a library with project files:: +@end menu + +@c --------------------------------------------- +@node Building Libraries +@subsection Building Libraries +@c --------------------------------------------- + +@noindent +Let's enhance our example and transform the @code{logging} subsystem into a +library. In order to do so, a few changes need to be made to @file{logging.gpr}. +A number of specific attributes needs to be defined: at least @code{Library_Name} +and @code{Library_Dir}; in addition, a number of other attributes can be used +to specify specific aspects of the library. For readability, it is also +recommended (although not mandatory), to use the qualifier @code{library} in +front of the @code{project} keyword. + +@table @asis +@item @b{Library_Name}: +@cindex @code{Library_Name} + This attribute is the name of the library to be built. There is no + restriction on the name of a library imposed by the project manager; + however, there may be system specific restrictions on the name. + In general, it is recommended to stick to alphanumeric characters + (and possibly underscores) to help portability. + +@item @b{Library_Dir}: +@cindex @code{Library_Dir} + This attribute is the path (absolute or relative) of the directory where + the library is to be installed. In the process of building a library, + the sources are compiled, the object files end up in the explicit or + implicit @code{Object_Dir} directory. When all sources of a library + are compiled, some of the compilation artifacts, including the library itself, + are copied to the library_dir directory. This directory must exists and be + writable. It must also be different from the object directory so that cleanup + activities in the Library_Dir do not affect recompilation needs. + +@end table + +Here is the new version of @file{logging.gpr} that makes it a library: + +@smallexample @c projectfile +library project Logging is -- "library" is optional + for Library_Name use "logging"; -- will create "liblogging.a" on Unix + for Object_Dir use "obj"; + for Library_Dir use "lib"; -- different from object_dir +end Logging; +@end smallexample + +@noindent +Once the above two attributes are defined, the library project is valid and +is enough for building a library with default characteristics. +Other library-related attributes can be used to change the defaults: + +@table @asis +@item @b{Library_Kind}: +@cindex @code{Library_Kind} + The value of this attribute must be either @code{"static"}, @code{"dynamic"} or + @code{"relocatable"} (the latter is a synonym for dynamic). It indicates + which kind of library should be build (the default is to build a + static library, that is an archive of object files that can potentially + be linked into a static executable). When the library is set to be dynamic, + a separate image is created that will be loaded independently, usually + at the start of the main program execution. Support for dynamic libraries is + very platform specific, for instance on Windows it takes the form of a DLL + while on GNU/Linux, it is a dynamic elf image whose suffix is usually + @file{.so}. Library project files, on the other hand, can be written in + a platform independent way so that the same project file can be used to build + a library on different operating systems. + + If you need to build both a static and a dynamic library, it is recommended + use two different object directories, since in some cases some extra code + needs to be generated for the latter. For such cases, one can + either define two different project files, or a single one which uses scenarios + to indicate at the various kinds of library to be build and their + corresponding object_dir. + +@cindex @code{Library_ALI_Dir} +@item @b{Library_ALI_Dir}: + This attribute may be specified to indicate the directory where the ALI + files of the library are installed. By default, they are copied into the + @code{Library_Dir} directory, but as for the executables where we have a + separate @code{Exec_Dir} attribute, you might want to put them in a separate + directory since there can be hundreds of them. The same restrictions as for + the @code{Library_Dir} attribute apply. + +@cindex @code{Library_Version} +@item @b{Library_Version}: + This attribute is platform dependent, and has no effect on VMS and Windows. + On Unix, it is used only for dynamic libraries as the internal + name of the library (the @code{"soname"}). If the library file name (built + from the @code{Library_Name}) is different from the @code{Library_Version}, + then the library file will be a symbolic link to the actual file whose name + will be @code{Library_Version}. This follows the usual installation schemes + for dynamic libraries on many Unix systems. + +@smallexample @c projectfile +@group + project Logging is + Version := "1"; + for Library_Dir use "lib"; + for Library_Name use "logging"; + for Library_Kind use "dynamic"; + for Library_Version use "liblogging.so." & Version; + end Logging; +@end group +@end smallexample + + @noindent + After the compilation, the directory @file{lib} will contain both a + @file{libdummy.so.1} library and a symbolic link to it called + @file{libdummy.so}. + +@cindex @code{Library_GCC} +@item @b{Library_GCC}: + This attribute is the name of the tool to use instead of "gcc" to link shared + libraries. A common use of this attribute is to define a wrapper script that + accomplishes specific actions before calling gcc (which itself is calling the + linker to build the library image). + +@item @b{Library_Options}: +@cindex @code{Library_Options} + This attribute may be used to specified additional switches (last switches) + when linking a shared library. + +@item @b{Leading_Library_Options}: +@cindex @code{Leading_Library_Options} + This attribute, that is taken into account only by @command{gprbuild}, may be + used to specified leading options (first switches) when linking a shared + library. + +@cindex @code{Linker_Options} +@item @b{Linker.Linker_Options}: + This attribute specifies additional switches to be given to the linker when + linking an executable. It is ignored when defined in the main project and + taken into account in all other projects that are imported directly or + indirectly. These switches complement the @code{Linker.Switches} + defined in the main project. This is useful when a particular subsystem + depends on an external library: adding this dependency as a + @code{Linker_Options} in the project of the subsystem is more convenient than + adding it to all the @code{Linker.Switches} of the main projects that depend + upon this subsystem. +@end table + + +@c --------------------------------------------- +@node Using Library Projects +@subsection Using Library Projects +@c --------------------------------------------- + +@noindent +When the builder detects that a project file is a library project file, it +recompiles all sources of the project that need recompilation and rebuild the +library if any of the sources have been recompiled. It then groups all object +files into a single file, which is a shared or a static library. This library +can later on be linked with multiple executables. Note that the use +of shard libraries reduces the size of the final executable and can also reduce +the memory footprint at execution time when the library is shared among several +executables. + +It is also possible to build @b{multi-language libraries}. When using +@command{gprbuild} as a builder, multi-language library projects allow naturally +the creation of multi-language libraries . @command{gnatmake}, does not try to +compile non Ada sources. However, when the project is multi-language, it will +automatically link all object files found in the object directory, whether or +not they were compiled from an Ada source file. This specific behavior does not +apply to Ada-only projects which only take into account the objects +corresponding to the sources of the project. + +A non-library project can import a library project. When the builder is invoked +on the former, the library of the latter is only rebuilt when absolutely +necessary. For instance, if a unit of the +library is not up-to-date but non of the executables need this unit, then the +unit is not recompiled and the library is not reassembled. +For instance, let's assume in our example that logging has the following +sources: @file{log1.ads}, @file{log1.adb}, @file{log2.ads} and +@file{log2.adb}. If @file{log1.adb} has been modified, then the library +@file{liblogging} will be rebuilt when compiling all the sources of +@code{Build} only if @file{proc.ads}, @file{pack.ads} or @file{pack.adb} +include a @code{"with Log1"}. + +To ensure that all the sources in the @code{Logging} library are +up to date, and that all the sources of @code{Build} are also up to date, +the following two commands needs to be used: + +@smallexample +gnatmake -Plogging.gpr +gnatmake -Pbuild.gpr +@end smallexample + +@noindent +All @file{ALI} files will also be copied from the object directory to the +library directory. To build executables, @command{gnatmake} will use the +library rather than the individual object files. + +@ifclear vms +Library projects can also be useful to describe a library that need to be used +but, for some reason, cannot be rebuilt. For instance, it is the case when some +of the library sources are not available. Such library projects need simply to +use the @code{Externally_Built} attribute as in the example below: + +@smallexample @c projectfile +library project Extern_Lib is + for Languages use ("Ada", "C"); + for Source_Dirs use ("lib_src"); + for Library_Dir use "lib2"; + for Library_Kind use "dynamic"; + for Library_Name use "l2"; + for Externally_Built use "true"; -- <<<< +end Extern_Lib; +@end smallexample + +@noindent +In the case of externally built libraries, the @code{Object_Dir} +attribute does not need to be specified because it will never be +used. + +The main effect of using such an externally built library project is mostly to +affect the linker command in order to reference the desired library. It can +also be achieved by using @code{Linker.Linker_Options} or @code{Linker.Switches} +in the project corresponding to the subsystem needing this external library. +This latter method is more straightforward in simple cases but when several +subsystems depend upon the same external library, finding the proper place +for the @code{Linker.Linker_Options} might not be easy and if it is +not placed properly, the final link command is likely to present ordering issues. +In such a situation, it is better to use the externally built library project +so that all other subsystems depending on it can declare this dependency thanks +to a project @code{with} clause, which in turn will trigger the builder to find +the proper order of libraries in the final link command. +@end ifclear + +@c --------------------------------------------- +@node Stand-alone Library Projects +@subsection Stand-alone Library Projects +@c --------------------------------------------- + +@noindent +@cindex standalone libraries +A @b{stand-alone library} is a library that contains the necessary code to +elaborate the Ada units that are included in the library. A stand-alone +library is a convenient way to add an Ada subsystem to a more global system +whose main is not in Ada since it makes the elaboration of the Ada part mostly +transparent. However, stand-alone libraries are also useful when the main is in +Ada: they provide a means for minimizing relinking & redeployment of complex +systems when localized changes are made. + +The most prominent characteristic of a stand-alone library is that it offers a +distinction between interface units and implementation units. Only the former +are visible to units outside the library. A stand-alone library project is thus +characterised by a third attribute, @b{Library_Interface}, in addition to the +two attributes that make a project a Library Project (@code{Library_Name} and +@code{Library_Dir}). + +@table @asis +@item @b{Library_Interface}: +@cindex @code{Library_Interface} + This attribute defines an explicit subset of the units of the project. + Projects importing this library project may only "with" units whose sources + are listed in the @code{Library_Interface}. Other sources are considered + implementation units. + +@smallexample @c projectfile +@group + for Library_Dir use "lib"; + for Library_Name use "loggin"; + for Library_Interface use ("lib1", "lib2"); -- unit names +@end group +@end smallexample + +@end table + +In order to include the elaboration code in the stand-alone library, the binder +is invoked on the closure of the library units creating a package whose name +depends on the library name (^b~logging.ads/b^B$LOGGING.ADS/B^ in the example). +This binder-generated package includes @b{initialization} and @b{finalization} +procedures whose names depend on the library name (@code{logginginit} and +@code{loggingfinal} in the example). The object corresponding to this package is +included in the library. + +@table @asis +@item @b{Library_Auto_Init}: +@cindex @code{Library_Auto_Init} + A dynamic stand-alone Library is automatically initialized + if automatic initialization of Stand-alone Libraries is supported on the + platform and if attribute @b{Library_Auto_Init} is not specified or + is specified with the value "true". A static Stand-alone Library is never + automatically initialized. Specifying "false" for this attribute + prevent automatic initialization. + + When a non-automatically initialized stand-alone library is used in an + executable, its initialization procedure must be called before any service of + the library is used. When the main subprogram is in Ada, it may mean that the + initialization procedure has to be called during elaboration of another + package. + +@item @b{Library_Dir}: +@cindex @code{Library_Dir} + For a stand-alone library, only the @file{ALI} files of the interface units + (those that are listed in attribute @code{Library_Interface}) are copied to + the library directory. As a consequence, only the interface units may be + imported from Ada units outside of the library. If other units are imported, + the binding phase will fail. + +@item @b{Binder.Default_Switches}: + When a stand-alone library is bound, the switches that are specified in + the attribute @b{Binder.Default_Switches ("Ada")} are + used in the call to @command{gnatbind}. + +@item @b{Library_Src_Dir}: +@cindex @code{Library_Src_Dir} + This attribute defines the location (absolute or relative to the project + directory) where the sources of the interface units are copied at + installation time. + These sources includes the specs of the interface units along with the closure + of sources necessary to compile them successfully. That may include bodies and + subunits, when pragmas @code{Inline} are used, or when there is a generic + units in the spec. This directory cannot point to the object directory or + one of the source directories, but it can point to the library directory, + which is the default value for this attribute. + +@item @b{Library_Symbol_Policy}: +@cindex @code{Library_Symbol_Policy} + This attribute controls the export of symbols and, on some platforms (like + VMS) that have the notions of major and minor IDs built in the library + files, it controls the setting of these IDs. It is not supported on all + platforms (where it will just have no effect). It may have one of the + following values: + + @itemize - + @item @code{"autonomous"} or @code{"default"}: exported symbols are not controlled + @item @code{"compliant"}: if attribute @b{Library_Reference_Symbol_File} + is not defined, then it is equivalent to policy "autonomous". If there + are exported symbols in the reference symbol file that are not in the + object files of the interfaces, the major ID of the library is increased. + If there are symbols in the object files of the interfaces that are not + in the reference symbol file, these symbols are put at the end of the list + in the newly created symbol file and the minor ID is increased. + @item @code{"controlled"}: the attribute @b{Library_Reference_Symbol_File} must be + defined. The library will fail to build if the exported symbols in the + object files of the interfaces do not match exactly the symbol in the + symbol file. + @item @code{"restricted"}: The attribute @b{Library_Symbol_File} must be defined. + The library will fail to build if there are symbols in the symbol file that + are not in the exported symbols of the object files of the interfaces. + Additional symbols in the object files are not added to the symbol file. + @item @code{"direct"}: The attribute @b{Library_Symbol_File} must be defined and + must designate an existing file in the object directory. This symbol file + is passed directly to the underlying linker without any symbol processing. + + @end itemize + +@item @b{Library_Reference_Symbol_File} +@cindex @code{Library_Reference_Symbol_File} + This attribute may define the path name of a reference symbol file that is + read when the symbol policy is either "compliant" or "controlled", on + platforms that support symbol control, such as VMS, when building a + stand-alone library. The path may be an absolute path or a path relative + to the project directory. + +@item @b{Library_Symbol_File} +@cindex @code{Library_Symbol_File} + This attribute may define the name of the symbol file to be created when + building a stand-alone library when the symbol policy is either "compliant", + "controlled" or "restricted", on platforms that support symbol control, + such as VMS. When symbol policy is "direct", then a file with this name + must exist in the object directory. +@end table + + +@c --------------------------------------------- +@node Installing a library with project files +@subsection Installing a library with project files +@c --------------------------------------------- + +@noindent +When using project files, library installation is part of the library build +process. Thus no further action is needed in order to make use of the +libraries that are built as part of the general application build. A usable +version of the library is installed in the directory specified by the +@code{Library_Dir} attribute of the library project file. + +You may want to install a library in a context different from where the library +is built. This situation arises with third party suppliers, who may want +to distribute a library in binary form where the user is not expected to be +able to recompile the library. The simplest option in this case is to provide +a project file slightly different from the one used to build the library, by +using the @code{externally_built} attribute. @ref{Using Library Projects} + +@c --------------------------------------------- +@node Project Extension +@section Project Extension +@c --------------------------------------------- + +@noindent +During development of a large system, it is sometimes necessary to use +modified versions of some of the source files, without changing the original +sources. This can be achieved through the @b{project extension} facility. + +Suppose for instance that our example @code{Build} project is build every night +for the whole team, in some shared directory. A developer usually need to work +on a small part of the system, and might not want to have a copy of all the +sources and all the object files (mostly because that would require too much +disk space, time to recompile everything). He prefers to be able to override +some of the source files in his directory, while taking advantage of all the +object files generated at night. + +Another example can be taken from large software systems, where it is common to have +multiple implementations of a common interface; in Ada terms, multiple +versions of a package body for the same spec. For example, one implementation +might be safe for use in tasking programs, while another might only be used +in sequential applications. This can be modeled in GNAT using the concept +of @emph{project extension}. If one project (the ``child'') @emph{extends} +another project (the ``parent'') then by default all source files of the +parent project are inherited by the child, but the child project can +override any of the parent's source files with new versions, and can also +add new files or remove unnecessary ones. +This facility is the project analog of a type extension in +object-oriented programming. Project hierarchies are permitted (an extending +project may itself be extended), and a project that +extends a project can also import other projects. + +A third example is that of using project extensions to provide different +versions of the same system. For instance, assume that a @code{Common} +project is used by two development branches. One of the branches has now +been frozen, and no further change can be done to it or to @code{Common}. +However, the other development branch still needs evolution of @code{Common}. +Project extensions provide a flexible solution to create a new version +of a subsystem while sharing and reusing as much as possible from the original +one. + +A project extension inherits implicitly all the sources and objects from the +project it extends. It is possible to create a new version of some of the +sources in one of the additional source dirs of the extending project. Those new +versions hide the original versions. Adding new sources or removing existing +ones is also possible. Here is an example on how to extend the project +@code{Build} from previous examples: + +@smallexample @c projectfile + project Work extends "../bld/build.gpr" is + end Work; +@end smallexample + +@noindent +The project after @b{extends} is the one being extended. As usual, it can be +specified using an absolute path, or a path relative to any of the directories +in the project path (@pxref{Project Dependencies}). This project does not +specify source or object directories, so the default value for these attribute +will be used that is to say the current directory (where project @code{Work} is +placed). We can already compile that project with + +@smallexample + gnatmake -Pwork +@end smallexample + +@noindent +If no sources have been placed in the current directory, this command +won't do anything, since this project does not change the +sources it inherited from @code{Build}, therefore all the object files +in @code{Build} and its dependencies are still valid and are reused +automatically. + +Suppose we now want to supply an alternate version of @file{pack.adb} +but use the existing versions of @file{pack.ads} and @file{proc.adb}. +We can create the new file Work's current directory (likely +by copying the one from the @code{Build} project and making changes to +it. If new packages are needed at the same time, we simply create +new files in the source directory of the extending project. + +When we recompile, @command{gnatmake} will now automatically recompile +this file (thus creating @file{pack.o} in the current directory) and +any file that depends on it (thus creating @file{proc.o}). Finally, the +executable is also linked locally. + +Note that we could have obtained the desired behavior using project import +rather than project inheritance. A @code{base} project would contain the +sources for @file{pack.ads} and @file{proc.adb}, and @code{Work} would +import @code{base} and add @file{pack.adb}. In this scenario, @code{base} +cannot contain the original version of @file{pack.adb} otherwise there would be +2 versions of the same unit in the closure of the project and this is not +allowed. Generally speaking, it is not recommended to put the spec and the +body of a unit in different projects since this affects their autonomy and +reusability. + +In a project file that extends another project, it is possible to +indicate that an inherited source is @b{not part} of the sources of the +extending project. This is necessary sometimes when a package spec has +been overridden and no longer requires a body: in this case, it is +necessary to indicate that the inherited body is not part of the sources +of the project, otherwise there will be a compilation error +when compiling the spec. + +@cindex @code{Excluded_Source_Files} +@cindex @code{Excluded_Source_List_File} +For that purpose, the attribute @b{Excluded_Source_Files} is used. +Its value is a list of file names. +It is also possible to use attribute @code{Excluded_Source_List_File}. +Its value is the path of a text file containing one file name per +line. + +@smallexample @c @projectfile +project Work extends "../bld/build.gpr" is + for Source_Files use ("pack.ads"); + -- New spec of Pkg does not need a completion + for Excluded_Source_Files use ("pack.adb"); +end Work; +@end smallexample + +@noindent +An extending project retains all the switches specified in the +extended project. + +@menu +* Project Hierarchy Extension:: +@end menu + +@c --------------------------------------------- +@node Project Hierarchy Extension +@subsection Project Hierarchy Extension +@c --------------------------------------------- + +@noindent +One of the fundamental restrictions in project extension is the following: +@b{A project is not allowed to import directly or indirectly at the same time an +extending project and one of its ancestors}. + +By means of example, consider the following hierarchy of projects. + +@smallexample + a.gpr contains package A1 + b.gpr, imports a.gpr and contains B1, which depends on A1 + c.gpr, imports b.gpr and contains C1, which depends on B1 +@end smallexample + +@noindent +If we want to locally extend the packages @code{A1} and @code{C1}, we need to +create several extending projects: + +@smallexample + a_ext.gpr which extends a.gpr, and overrides A1 + b_ext.gpr which extends b.gpr and imports a_ext.gpr + c_ext.gpr which extends c.gpr, imports b_ext.gpr and overrides C1 +@end smallexample + +@noindent +@smallexample @c projectfile + project A_Ext extends "a.gpr" is + for Source_Files use ("a1.adb", "a1.ads"); + end A_Ext; + + with "a_ext.gpr"; + project B_Ext extends "b.gpr" is + end B_Ext; + + with "b_ext.gpr"; + project C_Ext extends "c.gpr" is + for Source_Files use ("c1.adb"); + end C_Ext; +@end smallexample + +@noindent +The extension @file{b_ext.gpr} is required, even though we are not overriding +any of the sources of @file{b.gpr} because otherwise @file{c_expr.gpr} would +import @file{b.gpr} which itself knows nothing about @file{a_ext.gpr}. + +@cindex extends all +When extending a large system spanning multiple projects, it is often +inconvenient to extend every project in the hierarchy that is impacted by a +small change introduced in a low layer. In such cases, it is possible to create +an @b{implicit extension} of entire hierarchy using @b{extends all} +relationship. + +When the project is extended using @code{extends all} inheritance, all projects +that are imported by it, both directly and indirectly, are considered virtually +extended. That is, the project manager creates implicit projects +that extend every project in the hierarchy; all these implicit projects do not +control sources on their own and use the object directory of +the "extending all" project. + +It is possible to explicitly extend one or more projects in the hierarchy +in order to modify the sources. These extending projects must be imported by +the "extending all" project, which will replace the corresponding virtual +projects with the explicit ones. + +When building such a project hierarchy extension, the project manager will +ensure that both modified sources and sources in implicit extending projects +that depend on them, are recompiled. + +Thus, in our example we could create the following projects instead: + +@smallexample + a_ext.gpr, extends a.gpr and overrides A1 + c_ext.gpr, "extends all" c.gpr, imports a_ext.gpr and overrides C1 + +@end smallexample + +@noindent +@smallexample @c projectfile + project A_Ext extends "a.gpr" is + for Source_Files use ("a1.adb", "a1.ads"); + end A_Ext; + + with "a_ext.gpr"; + project C_Ext extends all "c.gpr" is + for Source_Files use ("c1.adb"); + end C_Ext; +@end smallexample + +@noindent +When building project @file{c_ext.gpr}, the entire modified project space is +considered for recompilation, including the sources of @file{b.gpr} that are +impacted by the changes in @code{A1} and @code{C1}. + +@c --------------------------------------------- +@node Project File Reference +@section Project File Reference +@c --------------------------------------------- + +@noindent +This section describes the syntactic structure of project files, the various +constructs that can be used. Finally, it ends with a summary of all available +attributes. + +@menu +* Project Declaration:: +* Qualified Projects:: +* Declarations:: +* Packages:: +* Expressions:: +* External Values:: +* Typed String Declaration:: +* Variables:: +* Attributes:: +* Case Statements:: +@end menu + +@c --------------------------------------------- +@node Project Declaration +@subsection Project Declaration +@c --------------------------------------------- + +@noindent +Project files have an Ada-like syntax. The minimal project file is: + +@smallexample @c projectfile +@group +project Empty is +end Empty; +@end group +@end smallexample + +@noindent +The identifier @code{Empty} is the name of the project. +This project name must be present after the reserved +word @code{end} at the end of the project file, followed by a semi-colon. + +@b{Identifiers} (i.e.@: the user-defined names such as project or variable names) +have the same syntax as Ada identifiers: they must start with a letter, +and be followed by zero or more letters, digits or underscore characters; +it is also illegal to have two underscores next to each other. Identifiers +are always case-insensitive ("Name" is the same as "name"). + +@smallexample +simple_name ::= identifier +name ::= simple_name @{ . simple_name @} +@end smallexample + +@noindent +@b{Strings} are used for values of attributes or as indexes for these +attributes. They are in general case sensitive, except when noted +otherwise (in particular, strings representing file names will be case +insensitive on some systems, so that "file.adb" and "File.adb" both +represent the same file). + +@b{Reserved words} are the same as for standard Ada 95, and cannot +be used for identifiers. In particular, the following words are currently +used in project files, but others could be added later on. In bold are the +extra reserved words in project files: @code{all, at, case, end, for, is, +limited, null, others, package, renames, type, use, when, with, @b{extends}, +@b{external}, @b{project}}. + +@b{Comments} in project files have the same syntax as in Ada, two consecutive +hyphens through the end of the line. + +A project may be an @b{independent project}, entirely defined by a single +project file. Any source file in an independent project depends only +on the predefined library and other source files in the same project. +But a project may also depend on other projects, either by importing them +through @b{with clauses}, or by @b{extending} at most one other project. Both +types of dependency can be used in the same project. + +A path name denotes a project file. It can be absolute or relative. +An absolute path name includes a sequence of directories, in the syntax of +the host operating system, that identifies uniquely the project file in the +file system. A relative path name identifies the project file, relative +to the directory that contains the current project, or relative to a +directory listed in the environment variables ADA_PROJECT_PATH and +GPR_PROJECT_PATH. Path names are case sensitive if file names in the host +operating system are case sensitive. As a special case, the directory +separator can always be "/" even on Windows systems, so that project files +can be made portable across architectures. +The syntax of the environment variable ADA_PROJECT_PATH and +GPR_PROJECT_PATH is a list of directory names separated by colons on UNIX and +semicolons on Windows. + +A given project name can appear only once in a context clause. + +It is illegal for a project imported by a context clause to refer, directly +or indirectly, to the project in which this context clause appears (the +dependency graph cannot contain cycles), except when one of the with clause +in the cycle is a @b{limited with}. +@c ??? Need more details here + +@smallexample @c projectfile +with "other_project.gpr"; +project My_Project extends "extended.gpr" is +end My_Project; +@end smallexample + +@noindent +These dependencies form a @b{directed graph}, potentially cyclic when using +@b{limited with}. The subprogram reflecting the @b{extends} relations is a +tree. + +A project's @b{immediate sources} are the source files directly defined by +that project, either implicitly by residing in the project source directories, +or explicitly through any of the source-related attributes. +More generally, a project sources are the immediate sources of the project +together with the immediate sources (unless overridden) of any +project on which it depends directly or indirectly. + +A @b{project hierarchy} can be created, where projects are children of +other projects. The name of such a child project must be @code{Parent.Child}, +where @code{Parent} is the name of the parent project. In particular, this +makes all @code{with} clauses of the parent project automatically visible +in the child project. + +@smallexample +project ::= context_clause project_declaration + +context_clause ::= @{with_clause@} +with_clause ::= @i{with} path_name @{ , path_name @} ; +path_name ::= string_literal + +project_declaration ::= simple_project_declaration | project_extension +simple_project_declaration ::= + @i{project} @i{}name @i{is} + @{declarative_item@} + @i{end} simple_name; +@end smallexample + +@c --------------------------------------------- +@node Qualified Projects +@subsection Qualified Projects +@c --------------------------------------------- + +@noindent +Before the reserved @code{project}, there may be one or two @b{qualifiers}, that +is identifiers or reserved words, to qualify the project. +The current list of qualifiers is: + +@table @asis +@item @b{abstract}: qualifies a project with no sources. Such a + project must either have no declaration of attributes @code{Source_Dirs}, + @code{Source_Files}, @code{Languages} or @code{Source_List_File}, or one of + @code{Source_Dirs}, @code{Source_Files}, or @code{Languages} must be declared + as empty. If it extends another project, the project it extends must also be a + qualified abstract project. +@item @b{standard}: a standard project is a non library project with sources. + This is the default (implicit) qualifier. +@item @b{aggregate}: for future extension +@item @b{aggregate library}: for future extension +@item @b{library}: a library project must declare both attributes + @code{Library_Name} and @code{Library_Dir}. +@item @b{configuration}: a configuration project cannot be in a project tree. + It describes compilers and other tools to @code{gprbuild}. +@end table + + +@c --------------------------------------------- +@node Declarations +@subsection Declarations +@c --------------------------------------------- + +@noindent +Declarations introduce new entities that denote types, variables, attributes, +and packages. Some declarations can only appear immediately within a project +declaration. Others can appear within a project or within a package. + +@smallexample +declarative_item ::= simple_declarative_item + | typed_string_declaration + | package_declaration + +simple_declarative_item ::= variable_declaration + | typed_variable_declaration + | attribute_declaration + | case_construction + | empty_declaration + +empty_declaration ::= @i{null} ; +@end smallexample + +@noindent +An empty declaration is allowed anywhere a declaration is allowed. It has +no effect. + +@c --------------------------------------------- +@node Packages +@subsection Packages +@c --------------------------------------------- + +@noindent +A project file may contain @b{packages}, that group attributes (typically +all the attributes that are used by one of the GNAT tools). + +A package with a given name may only appear once in a project file. +The following packages are currently supported in project files +(See @pxref{Attributes} for the list of attributes that each can contain). + +@table @code +@item Binder + This package specifies characteristics useful when invoking the binder either + directly via the @command{gnat} driver or when using a builder such as + @command{gnatmake} or @command{gprbuild}. @xref{Main Subprograms}. +@item Builder + This package specifies the compilation options used when building an + executable or a library for a project. Most of the options should be + set in one of @code{Compiler}, @code{Binder} or @code{Linker} packages, + but there are some general options that should be defined in this + package. @xref{Main Subprograms}, and @pxref{Executable File Names} in + particular. +@item Check + This package specifies the options used when calling the checking tool + @command{gnatcheck} via the @command{gnat} driver. Its attribute + @b{Default_Switches} has the same semantics as for the package + @code{Builder}. The first string should always be @code{-rules} to specify + that all the other options belong to the @code{-rules} section of the + parameters to @command{gnatcheck}. +@item Compiler + This package specifies the compilation options used by the compiler for + each languages. @xref{Tools Options in Project Files}. +@item Cross_Reference + This package specifies the options used when calling the library tool + @command{gnatxref} via the @command{gnat} driver. Its attributes + @b{Default_Switches} and @b{Switches} have the same semantics as for the + package @code{Builder}. +@item Eliminate + This package specifies the options used when calling the tool + @command{gnatelim} via the @command{gnat} driver. Its attributes + @b{Default_Switches} and @b{Switches} have the same semantics as for the + package @code{Builder}. +@item Finder + This package specifies the options used when calling the search tool + @command{gnatfind} via the @command{gnat} driver. Its attributes + @b{Default_Switches} and @b{Switches} have the same semantics as for the + package @code{Builder}. +@item Gnatls + This package the options to use when invoking @command{gnatls} via the + @command{gnat} driver. +@item Gnatstub + This package specifies the options used when calling the tool + @command{gnatstub} via the @command{gnat} driver. Its attributes + @b{Default_Switches} and @b{Switches} have the same semantics as for the + package @code{Builder}. +@item IDE + This package specifies the options used when starting an integrated + development environment, for instance @command{GPS} or @command{Gnatbench}. + @xref{The Development Environments}. +@item Linker + This package specifies the options used by the linker. + @xref{Main Subprograms}. +@item Metrics + This package specifies the options used when calling the tool + @command{gnatmetric} via the @command{gnat} driver. Its attributes + @b{Default_Switches} and @b{Switches} have the same semantics as for the + package @code{Builder}. +@item Naming + This package specifies the naming conventions that apply + to the source files in a project. In particular, these conventions are + used to automatically find all source files in the source directories, + or given a file name to find out its language for proper processing. + @xref{Naming Schemes}. +@item Pretty_Printer + This package specifies the options used when calling the formatting tool + @command{gnatpp} via the @command{gnat} driver. Its attributes + @b{Default_Switches} and @b{Switches} have the same semantics as for the + package @code{Builder}. +@item Stack + This package specifies the options used when calling the tool + @command{gnatstack} via the @command{gnat} driver. Its attributes + @b{Default_Switches} and @b{Switches} have the same semantics as for the + package @code{Builder}. +@item Synchronize + This package specifies the options used when calling the tool + @command{gnatsync} via the @command{gnat} driver. + +@end table + +In its simplest form, a package may be empty: + +@smallexample @c projectfile +@group +project Simple is + package Builder is + end Builder; +end Simple; +@end group +@end smallexample + +@noindent +A package may contain @b{attribute declarations}, +@b{variable declarations} and @b{case constructions}, as will be +described below. + +When there is ambiguity between a project name and a package name, +the name always designates the project. To avoid possible confusion, it is +always a good idea to avoid naming a project with one of the +names allowed for packages or any name that starts with @code{gnat}. + +A package can also be defined by a @b{renaming declaration}. The new package +renames a package declared in a different project file, and has the same +attributes as the package it renames. The name of the renamed package +must be the same as the name of the renaming package. The project must +contain a package declaration with this name, and the project +must appear in the context clause of the current project, or be its parent +project. It is not possible to add or override attributes to the renaming +project. If you need to do so, you should use an @b{extending declaration} +(see below). + +Packages that are renamed in other project files often come from project files +that have no sources: they are just used as templates. Any modification in the +template will be reflected automatically in all the project files that rename +a package from the template. This is a very common way to share settings +between projects. + +Finally, a package can also be defined by an @b{extending declaration}. This is +similar to a @b{renaming declaration}, except that it is possible to add or +override attributes. + +@smallexample +package_declaration ::= package_spec | package_renaming | package_extension +package_spec ::= + @i{package} @i{}simple_name @i{is} + @{simple_declarative_item@} + @i{end} package_identifier ; +package_renaming ::== + @i{package} @i{}simple_name @i{renames} @i{}simple_name.package_identifier ; +package_extension ::== + @i{package} @i{}simple_name @i{extends} @i{}simple_name.package_identifier @i{is} + @{simple_declarative_item@} + @i{end} package_identifier ; +@end smallexample + +@c --------------------------------------------- +@node Expressions +@subsection Expressions +@c --------------------------------------------- + +@noindent +An expression is any value that can be assigned to an attribute or a +variable. It is either a literal value, or a construct requiring runtime +computation by the project manager. In a project file, the computed value of +an expression is either a string or a list of strings. + +A string value is one of: +@itemize @bullet +@item A literal string, for instance @code{"comm/my_proj.gpr"} +@item The name of a variable that evaluates to a string (@pxref{Variables}) +@item The name of an attribute that evaluates to a string (@pxref{Attributes}) +@item An external reference (@pxref{External Values}) +@item A concatenation of the above, as in @code{"prefix_" & Var}. + +@end itemize + +@noindent +A list of strings is one of the following: + +@itemize @bullet +@item A parenthesized comma-separated list of zero or more string expressions, for + instance @code{(File_Name, "gnat.adc", File_Name & ".orig")} or @code{()}. +@item The name of a variable that evaluates to a list of strings +@item The name of an attribute that evaluates to a list of strings +@item A concatenation of a list of strings and a string (as defined above), for + instance @code{("A", "B") & "C"} +@item A concatenation of two lists of strings + +@end itemize + +@noindent +The following is the grammar for expressions + +@smallexample +string_literal ::= "@{string_element@}" -- Same as Ada +string_expression ::= string_literal + | @i{variable_}name + | external_value + | attribute_reference + | ( string_expression @{ & string_expression @} ) +string_list ::= ( string_expression @{ , string_expression @} ) + | @i{string_variable}_name + | @i{string_}attribute_reference +term ::= string_expression | string_list +expression ::= term @{ & term @} -- Concatenation +@end smallexample + +@noindent +Concatenation involves strings and list of strings. As soon as a list of +strings is involved, the result of the concatenation is a list of strings. The +following Ada declarations show the existing operators: + +@smallexample @c ada + function "&" (X : String; Y : String) return String; + function "&" (X : String_List; Y : String) return String_List; + function "&" (X : String_List; Y : String_List) return String_List; +@end smallexample + +@noindent +Here are some specific examples: + +@smallexample @c projectfile +@group + List := () & File_Name; -- One string in this list + List2 := List & (File_Name & ".orig"); -- Two strings + Big_List := List & Lists2; -- Three strings + Illegal := "gnat.adc" & List2; -- Illegal, must start with list +@end group +@end smallexample + +@c --------------------------------------------- +@node External Values +@subsection External Values +@c --------------------------------------------- + +@noindent +An external value is an expression whose value is obtained from the command +that invoked the processing of the current project file (typically a +gnatmake or gprbuild command). + +There are two kinds of external values, one that returns a single string, and +one that returns a string list. + +The syntax of a single string external value is: + +@smallexample +external_value ::= @i{external} ( string_literal [, string_literal] ) +@end smallexample + +@noindent +The first string_literal is the string to be used on the command line or +in the environment to specify the external value. The second string_literal, +if present, is the default to use if there is no specification for this +external value either on the command line or in the environment. + +Typically, the external value will either exist in the +^environment variables^logical name^ +or be specified on the command line through the +@option{^-X^/EXTERNAL_REFERENCE=^@emph{vbl}=@emph{value}} switch. If both +are specified, then the command line value is used, so that a user can more +easily override the value. + +The function @code{external} always returns a string. It is an error if the +value was not found in the environment and no default was specified in the +call to @code{external}. + +An external reference may be part of a string expression or of a string +list expression, and can therefore appear in a variable declaration or +an attribute declaration. + +Most of the time, this construct is used to initialize typed variables, which +are then used in @b{case} statements to control the value assigned to +attributes in various scenarios. Thus such variables are often called +@b{scenario variables}. + +The syntax for a string list external value is: + +@smallexample +external_value ::= @i{external_as_list} ( string_literal , string_literal ) +@end smallexample + +@noindent +The first string_literal is the string to be used on the command line or +in the environment to specify the external value. The second string_literal is +the separator between each component of the string list. + +If the external value does not exist in the environment or on the command line, +the result is an empty list. This is also the case, if the separator is an +empty string or if the external value is only one separator. + +Any separator at the beginning or at the end of the external value is +discarded. Then, if there is no separator in the external value, the result is +a string list with only one string. Otherwise, any string between the beginning +and the first separator, between two consecutive separators and between the +last separator and the end are components of the string list. + +@smallexample + @i{external_as_list} ("SWITCHES", ",") +@end smallexample + +@noindent +If the external value is "-O2,-g", the result is ("-O2", "-g"). + +If the external value is ",-O2,-g,", the result is also ("-O2", "-g"). + +if the external value is "-gnav", the result is ("-gnatv"). + +If the external value is ",,", the result is (""). + +If the external value is ",", the result is (), the empty string list. + +@c --------------------------------------------- +@node Typed String Declaration +@subsection Typed String Declaration +@c --------------------------------------------- + +@noindent +A @b{type declaration} introduces a discrete set of string literals. +If a string variable is declared to have this type, its value +is restricted to the given set of literals. These are the only named +types in project files. A string type may only be declared at the project +level, not inside a package. + +@smallexample +typed_string_declaration ::= + @i{type} @i{}_simple_name @i{is} ( string_literal @{, string_literal@} ); +@end smallexample + +@noindent +The string literals in the list are case sensitive and must all be different. +They may include any graphic characters allowed in Ada, including spaces. +Here is an example of a string type declaration: + +@smallexample @c projectfile + type OS is ("NT", "nt", "Unix", "GNU/Linux", "other OS"); +@end smallexample + +@noindent +Variables of a string type are called @b{typed variables}; all other +variables are called @b{untyped variables}. Typed variables are +particularly useful in @code{case} constructions, to support conditional +attribute declarations. (@pxref{Case Statements}). + +A string type may be referenced by its name if it has been declared in the same +project file, or by an expanded name whose prefix is the name of the project +in which it is declared. + +@c --------------------------------------------- +@node Variables +@subsection Variables +@c --------------------------------------------- + +@noindent +@b{Variables} store values (strings or list of strings) and can appear +as part of an expression. The declaration of a variable creates the +variable and assigns the value of the expression to it. The name of the +variable is available immediately after the assignment symbol, if you +need to reuse its old value to compute the new value. Before the completion +of its first declaration, the value of a variable defaults to the empty +string (""). + +A @b{typed} variable can be used as part of a @b{case} expression to +compute the value, but it can only be declared once in the project file, +so that all case statements see the same value for the variable. This +provides more consistency and makes the project easier to understand. +The syntax for its declaration is identical to the Ada syntax for an +object declaration. In effect, a typed variable acts as a constant. + +An @b{untyped} variable can be declared and overridden multiple times +within the same project. It is declared implicitly through an Ada +assignment. The first declaration establishes the kind of the variable +(string or list of strings) and successive declarations must respect +the initial kind. Assignments are executed in the order in which they +appear, so the new value replaces the old one and any subsequent reference +to the variable uses the new value. + +A variable may be declared at the project file level, or within a package. + +@smallexample +typed_variable_declaration ::= + @i{}simple_name : @i{}name := string_expression; +variable_declaration ::= @i{}simple_name := expression; +@end smallexample + +@noindent +Here are some examples of variable declarations: + +@smallexample @c projectfile +@group + This_OS : OS := external ("OS"); -- a typed variable declaration + That_OS := "GNU/Linux"; -- an untyped variable declaration + + Name := "readme.txt"; + Save_Name := Name & ".saved"; + + Empty_List := (); + List_With_One_Element := ("-gnaty"); + List_With_Two_Elements := List_With_One_Element & "-gnatg"; + Long_List := ("main.ada", "pack1_.ada", "pack1.ada", "pack2_.ada"); +@end group +@end smallexample + +@noindent +A @b{variable reference} may take several forms: + +@itemize @bullet +@item The simple variable name, for a variable in the current package (if any) + or in the current project +@item An expanded name, whose prefix is a context name. + +@end itemize + +@noindent +A @b{context} may be one of the following: + +@itemize @bullet +@item The name of an existing package in the current project +@item The name of an imported project of the current project +@item The name of an ancestor project (i.e., a project extended by the current + project, either directly or indirectly) +@item An expanded name whose prefix is an imported/parent project name, and + whose selector is a package name in that project. +@end itemize + + +@c --------------------------------------------- +@node Attributes +@subsection Attributes +@c --------------------------------------------- + +@noindent +A project (and its packages) may have @b{attributes} that define +the project's properties. Some attributes have values that are strings; +others have values that are string lists. + +@smallexample +attribute_declaration ::= + simple_attribute_declaration | indexed_attribute_declaration +simple_attribute_declaration ::= @i{for} attribute_designator @i{use} expression ; +indexed_attribute_declaration ::= + @i{for} @i{}simple_name ( string_literal) @i{use} expression ; +attribute_designator ::= + @i{}simple_name + | @i{}simple_name ( string_literal ) +@end smallexample + +@noindent +There are two categories of attributes: @b{simple attributes} +and @b{indexed attributes}. +Each simple attribute has a default value: the empty string (for string +attributes) and the empty list (for string list attributes). +An attribute declaration defines a new value for an attribute, and overrides +the previous value. The syntax of a simple attribute declaration is similar to +that of an attribute definition clause in Ada. + +Some attributes are indexed. These attributes are mappings whose +domain is a set of strings. They are declared one association +at a time, by specifying a point in the domain and the corresponding image +of the attribute. +Like untyped variables and simple attributes, indexed attributes +may be declared several times. Each declaration supplies a new value for the +attribute, and replaces the previous setting. + +Here are some examples of attribute declarations: + +@smallexample @c projectfile + -- simple attributes + for Object_Dir use "objects"; + for Source_Dirs use ("units", "test/drivers"); + + -- indexed attributes + for Body ("main") use "Main.ada"; + for Switches ("main.ada") use ("-v", "-gnatv"); + for Switches ("main.ada") use Builder'Switches ("main.ada") & "-g"; + + -- indexed attributes copy (from package Builder in project Default) + -- The package name must always be specified, even if it is the current + -- package. + for Default_Switches use Default.Builder'Default_Switches; +@end smallexample + +@noindent +Attributes references may be appear anywhere in expressions, and are used +to retrieve the value previously assigned to the attribute. If an attribute +has not been set in a given package or project, its value defaults to the +empty string or the empty list. + +@smallexample +attribute_reference ::= attribute_prefix ' @i{_}simple_name [ (string_literal) ] +attribute_prefix ::= @i{project} + | @i{}simple_name + | package_identifier + | @i{}simple_name . package_identifier +@end smallexample + +@noindent +Examples are: + +@smallexample @c projectfile + project'Object_Dir + Naming'Dot_Replacement + Imported_Project'Source_Dirs + Imported_Project.Naming'Casing + Builder'Default_Switches ("Ada") +@end smallexample + +@noindent +The prefix of an attribute may be: + +@itemize @bullet +@item @code{project} for an attribute of the current project +@item The name of an existing package of the current project +@item The name of an imported project +@item The name of a parent project that is extended by the current project +@item An expanded name whose prefix is imported/parent project name, + and whose selector is a package name + +@end itemize + +@noindent +Legal attribute names are listed below, including the package in +which they must be declared. These names are case-insensitive. The +semantics for the attributes is explained in great details in other sections. + +The column @emph{index} indicates whether the attribute is an indexed attribute, +and when it is whether its index is case sensitive (sensitive) or not (insensitive), or if case sensitivity depends is the same as file names sensitivity on the +system (file). The text is between brackets ([]) if the index is optional. + +@multitable @columnfractions .3 .1 .2 .4 +@headitem Attribute Name @tab Value @tab Package @tab Index +@headitem General attributes @tab @tab @tab @pxref{Building With Projects} +@item Name @tab string @tab - @tab (Read-only, name of project) +@item Project_Dir @tab string @tab - @tab (Read-only, directory of project) +@item Source_Files @tab list @tab - @tab - +@item Source_Dirs @tab list @tab - @tab - +@item Source_List_File @tab string @tab - @tab - +@item Locally_Removed_Files @tab list @tab - @tab - +@item Excluded_Source_Files @tab list @tab - @tab - +@item Object_Dir @tab string @tab - @tab - +@item Exec_Dir @tab string @tab - @tab - +@item Excluded_Source_Dirs @tab list @tab - @tab - +@item Excluded_Source_Files @tab list @tab - @tab - +@item Excluded_Source_List_File @tab list @tab - @tab - +@item Inherit_Source_Path @tab list @tab - @tab insensitive +@item Languages @tab list @tab - @tab - +@item Main @tab list @tab - @tab - +@item Main_Language @tab string @tab - @tab - +@item Externally_Built @tab string @tab - @tab - +@item Roots @tab list @tab - @tab file +@headitem + Library-related attributes @tab @tab @tab @pxref{Library Projects} +@item Library_Dir @tab string @tab - @tab - +@item Library_Name @tab string @tab - @tab - +@item Library_Kind @tab string @tab - @tab - +@item Library_Version @tab string @tab - @tab - +@item Library_Interface @tab string @tab - @tab - +@item Library_Auto_Init @tab string @tab - @tab - +@item Library_Options @tab list @tab - @tab - +@item Leading_Library_Options @tab list @tab - @tab - +@item Library_Src_Dir @tab string @tab - @tab - +@item Library_ALI_Dir @tab string @tab - @tab - +@item Library_GCC @tab string @tab - @tab - +@item Library_Symbol_File @tab string @tab - @tab - +@item Library_Symbol_Policy @tab string @tab - @tab - +@item Library_Reference_Symbol_File @tab string @tab - @tab - +@item Interfaces @tab list @tab - @tab - +@headitem + Naming @tab @tab @tab @pxref{Naming Schemes} +@item Spec_Suffix @tab string @tab Naming @tab insensitive (language) +@item Body_Suffix @tab string @tab Naming @tab insensitive (language) +@item Separate_Suffix @tab string @tab Naming @tab - +@item Casing @tab string @tab Naming @tab - +@item Dot_Replacement @tab string @tab Naming @tab - +@item Spec @tab string @tab Naming @tab insensitive (Ada unit) +@item Body @tab string @tab Naming @tab insensitive (Ada unit) +@item Specification_Exceptions @tab list @tab Naming @tab insensitive (language) +@item Implementation_Exceptions @tab list @tab Naming @tab insensitive (language) +@headitem + Building @tab @tab @tab @pxref{Switches and Project Files} +@item Default_Switches @tab list @tab Builder, Compiler, Binder, Linker, Cross_Reference, Finder, Pretty_Printer, gnatstub, Check, Synchronize, Eliminate, Metrics, IDE @tab insensitive (language name) +@item Switches @tab list @tab Builder, Compiler, Binder, Linker, Cross_Reference, Finder, gnatls, Pretty_Printer, gnatstub, Check, Synchronize, Eliminate, Metrics, Stack @tab [file] (file name) +@item Local_Configuration_Pragmas @tab string @tab Compiler @tab - +@item Local_Config_File @tab string @tab insensitive @tab - +@item Global_Configuration_Pragmas @tab list @tab Builder @tab - +@item Global_Compilation_Switches @tab list @tab Builder @tab language +@item Executable @tab string @tab Builder @tab [file] +@item Executable_Suffix @tab string @tab Builder @tab - +@item Global_Config_File @tab string @tab Builder @tab insensitive (language) +@headitem + IDE (used and created by GPS) @tab @tab @tab +@item Remote_Host @tab string @tab IDE @tab - +@item Program_Host @tab string @tab IDE @tab - +@item Communication_Protocol @tab string @tab IDE @tab - +@item Compiler_Command @tab string @tab IDE @tab insensitive (language) +@item Debugger_Command @tab string @tab IDE @tab - +@item Gnatlist @tab string @tab IDE @tab - +@item VCS_Kind @tab string @tab IDE @tab - +@item VCS_File_Check @tab string @tab IDE @tab - +@item VCS_Log_Check @tab string @tab IDE @tab - +@item Documentation_Dir @tab string @tab IDE @tab - +@headitem + Configuration files @tab @tab @tab See gprbuild manual +@item Default_Language @tab string @tab - @tab - +@item Run_Path_Option @tab list @tab - @tab - +@item Run_Path_Origin @tab string @tab - @tab - +@item Separate_Run_Path_Options @tab string @tab - @tab - +@item Toolchain_Version @tab string @tab - @tab insensitive +@item Toolchain_Description @tab string @tab - @tab insensitive +@item Object_Generated @tab string @tab - @tab insensitive +@item Objects_Linked @tab string @tab - @tab insensitive +@item Target @tab string @tab - @tab - +@item Library_Builder @tab string @tab - @tab - +@item Library_Support @tab string @tab - @tab - +@item Archive_Builder @tab list @tab - @tab - +@item Archive_Builder_Append_Option @tab list @tab - @tab - +@item Archive_Indexer @tab list @tab - @tab - +@item Archive_Suffix @tab string @tab - @tab - +@item Library_Partial_Linker @tab list @tab - @tab - +@item Shared_Library_Prefix @tab string @tab - @tab - +@item Shared_Library_Suffix @tab string @tab - @tab - +@item Symbolic_Link_Supported @tab string @tab - @tab - +@item Library_Major_Minor_Id_Supported @tab string @tab - @tab - +@item Library_Auto_Init_Supported @tab string @tab - @tab - +@item Shared_Library_Minimum_Switches @tab list @tab - @tab - +@item Library_Version_Switches @tab list @tab - @tab - +@item Library_Install_Name_Option @tab string @tab - @tab - +@item Runtime_Library_Dir @tab string @tab - @tab insensitive +@item Runtime_Source_Dir @tab string @tab - @tab insensitive +@item Driver @tab string @tab Compiler,Binder,Linker @tab insensitive (language) +@item Required_Switches @tab list @tab Compiler,Binder,Linker @tab insensitive (language) +@item Leading_Required_Switches @tab list @tab Compiler @tab insensitive (language) +@item Trailing_Required_Switches @tab list @tab Compiler @tab insensitive (language) +@item Pic_Options @tab list @tab Compiler @tab insensitive (language) +@item Path_Syntax @tab string @tab Compiler @tab insensitive (language) +@item Object_File_Suffix @tab string @tab Compiler @tab insensitive (language) +@item Object_File_Switches @tab list @tab Compiler @tab insensitive (language) +@item Multi_Unit_Switches @tab list @tab Compiler @tab insensitive (language) +@item Multi_Unit_Object_Separator @tab string @tab Compiler @tab insensitive (language) +@item Mapping_File_Switches @tab list @tab Compiler @tab insensitive (language) +@item Mapping_Spec_Suffix @tab string @tab Compiler @tab insensitive (language) +@item Mapping_body_Suffix @tab string @tab Compiler @tab insensitive (language) +@item Config_File_Switches @tab list @tab Compiler @tab insensitive (language) +@item Config_Body_File_Name @tab string @tab Compiler @tab insensitive (language) +@item Config_Body_File_Name_Index @tab string @tab Compiler @tab insensitive (language) +@item Config_Body_File_Name_Pattern @tab string @tab Compiler @tab insensitive (language) +@item Config_Spec_File_Name @tab string @tab Compiler @tab insensitive (language) +@item Config_Spec_File_Name_Index @tab string @tab Compiler @tab insensitive (language) +@item Config_Spec_File_Name_Pattern @tab string @tab Compiler @tab insensitive (language) +@item Config_File_Unique @tab string @tab Compiler @tab insensitive (language) +@item Dependency_Switches @tab list @tab Compiler @tab insensitive (language) +@item Dependency_Driver @tab list @tab Compiler @tab insensitive (language) +@item Include_Switches @tab list @tab Compiler @tab insensitive (language) +@item Include_Path @tab string @tab Compiler @tab insensitive (language) +@item Include_Path_File @tab string @tab Compiler @tab insensitive (language) +@item Prefix @tab string @tab Binder @tab insensitive (language) +@item Objects_Path @tab string @tab Binder @tab insensitive (language) +@item Objects_Path_File @tab string @tab Binder @tab insensitive (language) +@item Linker_Options @tab list @tab Linker @tab - +@item Leading_Switches @tab list @tab Linker @tab - +@item Map_File_Options @tab string @tab Linker @tab - +@item Executable_Switches @tab list @tab Linker @tab - +@item Lib_Dir_Switch @tab string @tab Linker @tab - +@item Lib_Name_Switch @tab string @tab Linker @tab - +@item Max_Command_Line_Length @tab string @tab Linker @tab - +@item Response_File_Format @tab string @tab Linker @tab - +@item Response_File_Switches @tab list @tab Linker @tab - +@end multitable + +@c --------------------------------------------- +@node Case Statements +@subsection Case Statements +@c --------------------------------------------- + +@noindent +A @b{case} statement is used in a project file to effect conditional +behavior. Through this statement, you can set the value of attributes +and variables depending on the value previously assigned to a typed +variable. + +All choices in a choice list must be distinct. Unlike Ada, the choice +lists of all alternatives do not need to include all values of the type. +An @code{others} choice must appear last in the list of alternatives. + +The syntax of a @code{case} construction is based on the Ada case statement +(although the @code{null} statement for empty alternatives is optional). + +The case expression must be a typed string variable, whose value is often +given by an external reference (@pxref{External Values}). + +Each alternative starts with the reserved word @code{when}, either a list of +literal strings separated by the @code{"|"} character or the reserved word +@code{others}, and the @code{"=>"} token. +Each literal string must belong to the string type that is the type of the +case variable. +After each @code{=>}, there are zero or more statements. The only +statements allowed in a case construction are other case statements, +attribute declarations and variable declarations. String type declarations and +package declarations are not allowed. Variable declarations are restricted to +variables that have already been declared before the case construction. + +@smallexample +case_statement ::= + @i{case} @i{}name @i{is} @{case_item@} @i{end case} ; + +case_item ::= + @i{when} discrete_choice_list => + @{case_statement + | attribute_declaration + | variable_declaration + | empty_declaration@} + +discrete_choice_list ::= string_literal @{| string_literal@} | @i{others} +@end smallexample + +@noindent +Here is a typical example: + +@smallexample @c projectfile +@group +project MyProj is + type OS_Type is ("GNU/Linux", "Unix", "NT", "VMS"); + OS : OS_Type := external ("OS", "GNU/Linux"); + + package Compiler is + case OS is + when "GNU/Linux" | "Unix" => + for Switches ("Ada") use ("-gnath"); + when "NT" => + for Switches ("Ada") use ("-gnatP"); + when others => + null; + end case; + end Compiler; +end MyProj; +@end group +@end smallexample + +@c --------------------------------------------- +@node Tools Supporting Project Files +@chapter Tools Supporting Project Files +@c --------------------------------------------- + +@noindent + + +@menu +* gnatmake and Project Files:: +* The GNAT Driver and Project Files:: +* The Development Environments:: +* Cleaning up with GPRclean:: +@end menu + +@c --------------------------------------------- +@node gnatmake and Project Files +@section gnatmake and Project Files +@c --------------------------------------------- + +@noindent +This section covers several topics related to @command{gnatmake} and +project files: defining ^switches^switches^ for @command{gnatmake} +and for the tools that it invokes; specifying configuration pragmas; +the use of the @code{Main} attribute; building and rebuilding library project +files. + +@menu +* Switches Related to Project Files:: +* Switches and Project Files:: +* Specifying Configuration Pragmas:: +* Project Files and Main Subprograms:: +* Library Project Files:: +@end menu + +@c --------------------------------------------- +@node Switches Related to Project Files +@subsection Switches Related to Project Files +@c --------------------------------------------- + +@noindent +The following switches are used by GNAT tools that support project files: + +@table @option + +@item ^-P^/PROJECT_FILE=^@var{project} +@cindex @option{^-P^/PROJECT_FILE^} (any project-aware tool) +Indicates the name of a project file. This project file will be parsed with +the verbosity indicated by @option{^-vP^MESSAGE_PROJECT_FILES=^@emph{x}}, +if any, and using the external references indicated +by @option{^-X^/EXTERNAL_REFERENCE^} switches, if any. +@ifclear vms +There may zero, one or more spaces between @option{-P} and @var{project}. +@end ifclear + +There must be only one @option{^-P^/PROJECT_FILE^} switch on the command line. + +Since the Project Manager parses the project file only after all the switches +on the command line are checked, the order of the switches +@option{^-P^/PROJECT_FILE^}, +@option{^-vP^/MESSAGES_PROJECT_FILE=^@emph{x}} +or @option{^-X^/EXTERNAL_REFERENCE^} is not significant. + +@item ^-X^/EXTERNAL_REFERENCE=^@var{name=value} +@cindex @option{^-X^/EXTERNAL_REFERENCE^} (any project-aware tool) +Indicates that external variable @var{name} has the value @var{value}. +The Project Manager will use this value for occurrences of +@code{external(name)} when parsing the project file. + +@ifclear vms +If @var{name} or @var{value} includes a space, then @var{name=value} should be +put between quotes. +@smallexample + -XOS=NT + -X"user=John Doe" +@end smallexample +@end ifclear + +Several @option{^-X^/EXTERNAL_REFERENCE^} switches can be used simultaneously. +If several @option{^-X^/EXTERNAL_REFERENCE^} switches specify the same +@var{name}, only the last one is used. + +An external variable specified with a @option{^-X^/EXTERNAL_REFERENCE^} switch +takes precedence over the value of the same name in the environment. + +@item ^-vP^/MESSAGES_PROJECT_FILE=^@emph{x} +@cindex @option{^-vP^/MESSAGES_PROJECT_FILE^} (any project-aware tool) +Indicates the verbosity of the parsing of GNAT project files. + +@ifclear vms +@option{-vP0} means Default; +@option{-vP1} means Medium; +@option{-vP2} means High. +@end ifclear + +@ifset vms +There are three possible options for this qualifier: DEFAULT, MEDIUM and +HIGH. +@end ifset + +The default is ^Default^DEFAULT^: no output for syntactically correct +project files. +If several @option{^-vP^/MESSAGES_PROJECT_FILE=^@emph{x}} switches are present, +only the last one is used. + +@item ^-aP^/ADD_PROJECT_SEARCH_DIR=^ +@cindex @option{^-aP^/ADD_PROJECT_SEARCH_DIR=^} (any project-aware tool) +Add directory at the beginning of the project search path, in order, +after the current working directory. + +@ifclear vms +@item -eL +@cindex @option{-eL} (any project-aware tool) +Follow all symbolic links when processing project files. +@end ifclear + +@item ^--subdirs^/SUBDIRS^= +@cindex @option{^--subdirs^/SUBDIRS^=} (gnatmake and gnatclean) +This switch is recognized by gnatmake and gnatclean. It indicate that the real +directories (except the source directories) are the subdirectories +of the directories specified in the project files. This applies in particular +to object directories, library directories and exec directories. If the +subdirectories do not exist, they are created automatically. + +@end table + +@c --------------------------------------------- +@node Switches and Project Files +@subsection Switches and Project Files +@c --------------------------------------------- + +@noindent +@ifset vms +It is not currently possible to specify VMS style qualifiers in the project +files; only Unix style ^switches^switches^ may be specified. +@end ifset + +For each of the packages @code{Builder}, @code{Compiler}, @code{Binder}, and +@code{Linker}, you can specify a @code{^Default_Switches^Default_Switches^} +attribute, a @code{Switches} attribute, or both; +as their names imply, these ^switch^switch^-related +attributes affect the ^switches^switches^ that are used for each of these GNAT +components when +@command{gnatmake} is invoked. As will be explained below, these +component-specific ^switches^switches^ precede +the ^switches^switches^ provided on the @command{gnatmake} command line. + +The @code{^Default_Switches^Default_Switches^} attribute is an attribute +indexed by language name (case insensitive) whose value is a string list. +For example: + +@smallexample @c projectfile +@group +package Compiler is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-gnaty^-gnaty^", + "^-v^-v^"); +end Compiler; +@end group +@end smallexample + +@noindent +The @code{Switches} attribute is indexed on a file name (which may or may +not be case sensitive, depending +on the operating system) whose value is a string list. For example: + +@smallexample @c projectfile +@group +package Builder is + for Switches ("main1.adb") + use ("^-O2^-O2^"); + for Switches ("main2.adb") + use ("^-g^-g^"); +end Builder; +@end group +@end smallexample + +@noindent +For the @code{Builder} package, the file names must designate source files +for main subprograms. For the @code{Binder} and @code{Linker} packages, the +file names must designate @file{ALI} or source files for main subprograms. +In each case just the file name without an explicit extension is acceptable. + +For each tool used in a program build (@command{gnatmake}, the compiler, the +binder, and the linker), the corresponding package @dfn{contributes} a set of +^switches^switches^ for each file on which the tool is invoked, based on the +^switch^switch^-related attributes defined in the package. +In particular, the ^switches^switches^ +that each of these packages contributes for a given file @var{f} comprise: + +@itemize @bullet +@item the value of attribute @code{Switches (@var{f})}, + if it is specified in the package for the given file, +@item otherwise, the value of @code{^Default_Switches^Default_Switches^ ("Ada")}, + if it is specified in the package. + +@end itemize + +@noindent +If neither of these attributes is defined in the package, then the package does +not contribute any ^switches^switches^ for the given file. + +When @command{gnatmake} is invoked on a file, the ^switches^switches^ comprise +two sets, in the following order: those contributed for the file +by the @code{Builder} package; +and the switches passed on the command line. + +When @command{gnatmake} invokes a tool (compiler, binder, linker) on a file, +the ^switches^switches^ passed to the tool comprise three sets, +in the following order: + +@enumerate +@item +the applicable ^switches^switches^ contributed for the file +by the @code{Builder} package in the project file supplied on the command line; + +@item +those contributed for the file by the package (in the relevant project file -- +see below) corresponding to the tool; and + +@item +the applicable switches passed on the command line. +@end enumerate + +The term @emph{applicable ^switches^switches^} reflects the fact that +@command{gnatmake} ^switches^switches^ may or may not be passed to individual +tools, depending on the individual ^switch^switch^. + +@command{gnatmake} may invoke the compiler on source files from different +projects. The Project Manager will use the appropriate project file to +determine the @code{Compiler} package for each source file being compiled. +Likewise for the @code{Binder} and @code{Linker} packages. + +As an example, consider the following package in a project file: + +@smallexample @c projectfile +@group +project Proj1 is + package Compiler is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-g^-g^"); + for Switches ("a.adb") + use ("^-O1^-O1^"); + for Switches ("b.adb") + use ("^-O2^-O2^", + "^-gnaty^-gnaty^"); + end Compiler; +end Proj1; +@end group +@end smallexample + +@noindent +If @command{gnatmake} is invoked with this project file, and it needs to +compile, say, the files @file{a.adb}, @file{b.adb}, and @file{c.adb}, then +@file{a.adb} will be compiled with the ^switch^switch^ +@option{^-O1^-O1^}, +@file{b.adb} with ^switches^switches^ +@option{^-O2^-O2^} +and @option{^-gnaty^-gnaty^}, +and @file{c.adb} with @option{^-g^-g^}. + +The following example illustrates the ordering of the ^switches^switches^ +contributed by different packages: + +@smallexample @c projectfile +@group +project Proj2 is + package Builder is + for Switches ("main.adb") + use ("^-g^-g^", + "^-O1^-)1^", + "^-f^-f^"); + end Builder; +@end group + +@group + package Compiler is + for Switches ("main.adb") + use ("^-O2^-O2^"); + end Compiler; +end Proj2; +@end group +@end smallexample + +@noindent +If you issue the command: + +@smallexample + gnatmake ^-Pproj2^/PROJECT_FILE=PROJ2^ -O0 main +@end smallexample + +@noindent +then the compiler will be invoked on @file{main.adb} with the following +sequence of ^switches^switches^ + +@smallexample + ^-g -O1 -O2 -O0^-g -O1 -O2 -O0^ +@end smallexample + +@noindent +with the last @option{^-O^-O^} +^switch^switch^ having precedence over the earlier ones; +several other ^switches^switches^ +(such as @option{^-c^-c^}) are added implicitly. + +The ^switches^switches^ +@option{^-g^-g^} +and @option{^-O1^-O1^} are contributed by package +@code{Builder}, @option{^-O2^-O2^} is contributed +by the package @code{Compiler} +and @option{^-O0^-O0^} comes from the command line. + +The @option{^-g^-g^} +^switch^switch^ will also be passed in the invocation of +@command{Gnatlink.} + +A final example illustrates switch contributions from packages in different +project files: + +@smallexample @c projectfile +@group +project Proj3 is + for Source_Files use ("pack.ads", "pack.adb"); + package Compiler is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-gnata^-gnata^"); + end Compiler; +end Proj3; +@end group + +@group +with "Proj3"; +project Proj4 is + for Source_Files use ("foo_main.adb", "bar_main.adb"); + package Builder is + for Switches ("foo_main.adb") + use ("^-s^-s^", + "^-g^-g^"); + end Builder; +end Proj4; +@end group + +@group +-- Ada source file: +with Pack; +procedure Foo_Main is + @dots{} +end Foo_Main; +@end group +@end smallexample + +@noindent +If the command is +@smallexample +gnatmake ^-PProj4^/PROJECT_FILE=PROJ4^ foo_main.adb -cargs -gnato +@end smallexample + +@noindent +then the ^switches^switches^ passed to the compiler for @file{foo_main.adb} are +@option{^-g^-g^} (contributed by the package @code{Proj4.Builder}) and +@option{^-gnato^-gnato^} (passed on the command line). +When the imported package @code{Pack} is compiled, the ^switches^switches^ used +are @option{^-g^-g^} from @code{Proj4.Builder}, +@option{^-gnata^-gnata^} (contributed from package @code{Proj3.Compiler}, +and @option{^-gnato^-gnato^} from the command line. + +When using @command{gnatmake} with project files, some ^switches^switches^ or +arguments may be expressed as relative paths. As the working directory where +compilation occurs may change, these relative paths are converted to absolute +paths. For the ^switches^switches^ found in a project file, the relative paths +are relative to the project file directory, for the switches on the command +line, they are relative to the directory where @command{gnatmake} is invoked. +The ^switches^switches^ for which this occurs are: +^-I^-I^, +^-A^-A^, +^-L^-L^, +^-aO^-aO^, +^-aL^-aL^, +^-aI^-aI^, as well as all arguments that are not switches (arguments to +^switch^switch^ +^-o^-o^, object files specified in package @code{Linker} or after +-largs on the command line). The exception to this rule is the ^switch^switch^ +^--RTS=^--RTS=^ for which a relative path argument is never converted. + +@c --------------------------------------------- +@node Specifying Configuration Pragmas +@subsection Specifying Configuration Pragmas +@c --------------------------------------------- + +@noindent +When using @command{gnatmake} with project files, if there exists a file +@file{gnat.adc} that contains configuration pragmas, this file will be +ignored. + +Configuration pragmas can be defined by means of the following attributes in +project files: @code{Global_Configuration_Pragmas} in package @code{Builder} +and @code{Local_Configuration_Pragmas} in package @code{Compiler}. + +Both these attributes are single string attributes. Their values is the path +name of a file containing configuration pragmas. If a path name is relative, +then it is relative to the project directory of the project file where the +attribute is defined. + +When compiling a source, the configuration pragmas used are, in order, +those listed in the file designated by attribute +@code{Global_Configuration_Pragmas} in package @code{Builder} of the main +project file, if it is specified, and those listed in the file designated by +attribute @code{Local_Configuration_Pragmas} in package @code{Compiler} of +the project file of the source, if it exists. + +@c --------------------------------------------- +@node Project Files and Main Subprograms +@subsection Project Files and Main Subprograms +@c --------------------------------------------- + +@noindent +When using a project file, you can invoke @command{gnatmake} +with one or several main subprograms, by specifying their source files on the +command line. + +@smallexample + gnatmake ^-P^/PROJECT_FILE=^prj main1 main2 main3 +@end smallexample + +@noindent +Each of these needs to be a source file of the same project, except +when the switch ^-u^/UNIQUE^ is used. + +When ^-u^/UNIQUE^ is not used, all the mains need to be sources of the +same project, one of the project in the tree rooted at the project specified +on the command line. The package @code{Builder} of this common project, the +"main project" is the one that is considered by @command{gnatmake}. + +When ^-u^/UNIQUE^ is used, the specified source files may be in projects +imported directly or indirectly by the project specified on the command line. +Note that if such a source file is not part of the project specified on the +command line, the ^switches^switches^ found in package @code{Builder} of the +project specified on the command line, if any, that are transmitted +to the compiler will still be used, not those found in the project file of +the source file. + +When using a project file, you can also invoke @command{gnatmake} without +explicitly specifying any main, and the effect depends on whether you have +defined the @code{Main} attribute. This attribute has a string list value, +where each element in the list is the name of a source file (the file +extension is optional) that contains a unit that can be a main subprogram. + +If the @code{Main} attribute is defined in a project file as a non-empty +string list and the switch @option{^-u^/UNIQUE^} is not used on the command +line, then invoking @command{gnatmake} with this project file but without any +main on the command line is equivalent to invoking @command{gnatmake} with all +the file names in the @code{Main} attribute on the command line. + +Example: +@smallexample @c projectfile +@group + project Prj is + for Main use ("main1", "main2", "main3"); + end Prj; +@end group +@end smallexample + +@noindent +With this project file, @code{"gnatmake ^-Pprj^/PROJECT_FILE=PRJ^"} +is equivalent to +@code{"gnatmake ^-Pprj^/PROJECT_FILE=PRJ^ main1 main2 main3"}. + +When the project attribute @code{Main} is not specified, or is specified +as an empty string list, or when the switch @option{-u} is used on the command +line, then invoking @command{gnatmake} with no main on the command line will +result in all immediate sources of the project file being checked, and +potentially recompiled. Depending on the presence of the switch @option{-u}, +sources from other project files on which the immediate sources of the main +project file depend are also checked and potentially recompiled. In other +words, the @option{-u} switch is applied to all of the immediate sources of the +main project file. + +When no main is specified on the command line and attribute @code{Main} exists +and includes several mains, or when several mains are specified on the +command line, the default ^switches^switches^ in package @code{Builder} will +be used for all mains, even if there are specific ^switches^switches^ +specified for one or several mains. + +But the ^switches^switches^ from package @code{Binder} or @code{Linker} will be +the specific ^switches^switches^ for each main, if they are specified. + +@c --------------------------------------------- +@node Library Project Files +@subsection Library Project Files +@c --------------------------------------------- + +@noindent +When @command{gnatmake} is invoked with a main project file that is a library +project file, it is not allowed to specify one or more mains on the command +line. + +When a library project file is specified, switches ^-b^/ACTION=BIND^ and +^-l^/ACTION=LINK^ have special meanings. + +@itemize @bullet +@item ^-b^/ACTION=BIND^ is only allowed for stand-alone libraries. It indicates + to @command{gnatmake} that @command{gnatbind} should be invoked for the + library. + +@item ^-l^/ACTION=LINK^ may be used for all library projects. It indicates + to @command{gnatmake} that the binder generated file should be compiled + (in the case of a stand-alone library) and that the library should be built. +@end itemize + + +@c --------------------------------------------- +@node The GNAT Driver and Project Files +@section The GNAT Driver and Project Files +@c --------------------------------------------- + +@noindent +A number of GNAT tools, other than @command{^gnatmake^gnatmake^} +can benefit from project files: +(@command{^gnatbind^gnatbind^}, +@command{^gnatcheck^gnatcheck^}, +@command{^gnatclean^gnatclean^}, +@command{^gnatelim^gnatelim^}, +@command{^gnatfind^gnatfind^}, +@command{^gnatlink^gnatlink^}, +@command{^gnatls^gnatls^}, +@command{^gnatmetric^gnatmetric^}, +@command{^gnatpp^gnatpp^}, +@command{^gnatstub^gnatstub^}, +and @command{^gnatxref^gnatxref^}). However, none of these tools can be invoked +directly with a project file switch (@option{^-P^/PROJECT_FILE=^}). +They must be invoked through the @command{gnat} driver. + +The @command{gnat} driver is a wrapper that accepts a number of commands and +calls the corresponding tool. It was designed initially for VMS platforms (to +convert VMS qualifiers to Unix-style switches), but it is now available on all +GNAT platforms. + +On non-VMS platforms, the @command{gnat} driver accepts the following commands +(case insensitive): + +@itemize @bullet +@item BIND to invoke @command{^gnatbind^gnatbind^} +@item CHOP to invoke @command{^gnatchop^gnatchop^} +@item CLEAN to invoke @command{^gnatclean^gnatclean^} +@item COMP or COMPILE to invoke the compiler +@item ELIM to invoke @command{^gnatelim^gnatelim^} +@item FIND to invoke @command{^gnatfind^gnatfind^} +@item KR or KRUNCH to invoke @command{^gnatkr^gnatkr^} +@item LINK to invoke @command{^gnatlink^gnatlink^} +@item LS or LIST to invoke @command{^gnatls^gnatls^} +@item MAKE to invoke @command{^gnatmake^gnatmake^} +@item NAME to invoke @command{^gnatname^gnatname^} +@item PREP or PREPROCESS to invoke @command{^gnatprep^gnatprep^} +@item PP or PRETTY to invoke @command{^gnatpp^gnatpp^} +@item METRIC to invoke @command{^gnatmetric^gnatmetric^} +@item STUB to invoke @command{^gnatstub^gnatstub^} +@item XREF to invoke @command{^gnatxref^gnatxref^} + +@end itemize + +@noindent +(note that the compiler is invoked using the command +@command{^gnatmake -f -u -c^gnatmake -f -u -c^}). + +On non-VMS platforms, between @command{gnat} and the command, two +special switches may be used: + +@itemize @bullet +@item @command{-v} to display the invocation of the tool. +@item @command{-dn} to prevent the @command{gnat} driver from removing + the temporary files it has created. These temporary files are + configuration files and temporary file list files. + +@end itemize + +@noindent +The command may be followed by switches and arguments for the invoked +tool. + +@smallexample + gnat bind -C main.ali + gnat ls -a main + gnat chop foo.txt +@end smallexample + +@noindent +Switches may also be put in text files, one switch per line, and the text +files may be specified with their path name preceded by '@@'. + +@smallexample + gnat bind @@args.txt main.ali +@end smallexample + +@noindent +In addition, for commands BIND, COMP or COMPILE, FIND, ELIM, LS or LIST, LINK, +METRIC, PP or PRETTY, STUB and XREF, the project file related switches +(@option{^-P^/PROJECT_FILE^}, +@option{^-X^/EXTERNAL_REFERENCE^} and +@option{^-vP^/MESSAGES_PROJECT_FILE=^x}) may be used in addition to +the switches of the invoking tool. + +When GNAT PP or GNAT PRETTY is used with a project file, but with no source +specified on the command line, it invokes @command{^gnatpp^gnatpp^} with all +the immediate sources of the specified project file. + +When GNAT METRIC is used with a project file, but with no source +specified on the command line, it invokes @command{^gnatmetric^gnatmetric^} +with all the immediate sources of the specified project file and with +@option{^-d^/DIRECTORY^} with the parameter pointing to the object directory +of the project. + +In addition, when GNAT PP, GNAT PRETTY or GNAT METRIC is used with +a project file, no source is specified on the command line and +switch ^-U^/ALL_PROJECTS^ is specified on the command line, then +the underlying tool (^gnatpp^gnatpp^ or +^gnatmetric^gnatmetric^) is invoked for all sources of all projects, +not only for the immediate sources of the main project. +@ifclear vms +(-U stands for Universal or Union of the project files of the project tree) +@end ifclear + +For each of the following commands, there is optionally a corresponding +package in the main project. + +@itemize @bullet +@item package @code{Binder} for command BIND (invoking @code{^gnatbind^gnatbind^}) + +@item package @code{Check} for command CHECK (invoking + @code{^gnatcheck^gnatcheck^}) + +@item package @code{Compiler} for command COMP or COMPILE (invoking the compiler) + +@item package @code{Cross_Reference} for command XREF (invoking + @code{^gnatxref^gnatxref^}) + +@item package @code{Eliminate} for command ELIM (invoking + @code{^gnatelim^gnatelim^}) + +@item package @code{Finder} for command FIND (invoking @code{^gnatfind^gnatfind^}) + +@item package @code{Gnatls} for command LS or LIST (invoking @code{^gnatls^gnatls^}) + +@item package @code{Gnatstub} for command STUB + (invoking @code{^gnatstub^gnatstub^}) + +@item package @code{Linker} for command LINK (invoking @code{^gnatlink^gnatlink^}) + +@item package @code{Check} for command CHECK + (invoking @code{^gnatcheck^gnatcheck^}) + +@item package @code{Metrics} for command METRIC + (invoking @code{^gnatmetric^gnatmetric^}) + +@item package @code{Pretty_Printer} for command PP or PRETTY + (invoking @code{^gnatpp^gnatpp^}) + +@end itemize + +@noindent +Package @code{Gnatls} has a unique attribute @code{Switches}, +a simple variable with a string list value. It contains ^switches^switches^ +for the invocation of @code{^gnatls^gnatls^}. + +@smallexample @c projectfile +@group +project Proj1 is + package gnatls is + for Switches + use ("^-a^-a^", + "^-v^-v^"); + end gnatls; +end Proj1; +@end group +@end smallexample + +@noindent +All other packages have two attribute @code{Switches} and +@code{^Default_Switches^Default_Switches^}. + +@code{Switches} is an indexed attribute, indexed by the +source file name, that has a string list value: the ^switches^switches^ to be +used when the tool corresponding to the package is invoked for the specific +source file. + +@code{^Default_Switches^Default_Switches^} is an attribute, +indexed by the programming language that has a string list value. +@code{^Default_Switches^Default_Switches^ ("Ada")} contains the +^switches^switches^ for the invocation of the tool corresponding +to the package, except if a specific @code{Switches} attribute +is specified for the source file. + +@smallexample @c projectfile +@group +project Proj is + + for Source_Dirs use ("./**"); + + package gnatls is + for Switches use + ("^-a^-a^", + "^-v^-v^"); + end gnatls; +@end group +@group + + package Compiler is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-gnatv^-gnatv^", + "^-gnatwa^-gnatwa^"); + end Binder; +@end group +@group + + package Binder is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-C^-C^", + "^-e^-e^"); + end Binder; +@end group +@group + + package Linker is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-C^-C^"); + for Switches ("main.adb") + use ("^-C^-C^", + "^-v^-v^", + "^-v^-v^"); + end Linker; +@end group +@group + + package Finder is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-a^-a^", + "^-f^-f^"); + end Finder; +@end group +@group + + package Cross_Reference is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-a^-a^", + "^-f^-f^", + "^-d^-d^", + "^-u^-u^"); + end Cross_Reference; +end Proj; +@end group +@end smallexample + +@noindent +With the above project file, commands such as + +@smallexample + ^gnat comp -Pproj main^GNAT COMP /PROJECT_FILE=PROJ MAIN^ + ^gnat ls -Pproj main^GNAT LIST /PROJECT_FILE=PROJ MAIN^ + ^gnat xref -Pproj main^GNAT XREF /PROJECT_FILE=PROJ MAIN^ + ^gnat bind -Pproj main.ali^GNAT BIND /PROJECT_FILE=PROJ MAIN.ALI^ + ^gnat link -Pproj main.ali^GNAT LINK /PROJECT_FILE=PROJ MAIN.ALI^ +@end smallexample + +@noindent +will set up the environment properly and invoke the tool with the switches +found in the package corresponding to the tool: +@code{^Default_Switches^Default_Switches^ ("Ada")} for all tools, +except @code{Switches ("main.adb")} +for @code{^gnatlink^gnatlink^}. +It is also possible to invoke some of the tools, +(@code{^gnatcheck^gnatcheck^}, +@code{^gnatmetric^gnatmetric^}, +and @code{^gnatpp^gnatpp^}) +on a set of project units thanks to the combination of the switches +@option{-P}, @option{-U} and possibly the main unit when one is interested +in its closure. For instance, +@smallexample +gnat metric -Pproj +@end smallexample + +@noindent +will compute the metrics for all the immediate units of project +@code{proj}. +@smallexample +gnat metric -Pproj -U +@end smallexample + +@noindent +will compute the metrics for all the units of the closure of projects +rooted at @code{proj}. +@smallexample +gnat metric -Pproj -U main_unit +@end smallexample + +@noindent +will compute the metrics for the closure of units rooted at +@code{main_unit}. This last possibility relies implicitly +on @command{gnatbind}'s option @option{-R}. But if the argument files for the +tool invoked by the @command{gnat} driver are explicitly specified +either directly or through the tool @option{-files} option, then the tool +is called only for these explicitly specified files. + +@c --------------------------------------------- +@node The Development Environments +@section The Development Environments +@c --------------------------------------------- + +@noindent +See the appropriate manuals for more details. These environments will +store a number of settings in the project itself, when they are meant +to be shared by the whole team working on the project. Here are the +attributes defined in the package @b{IDE} in projects. + +@table @code +@item Remote_Host +This is a simple attribute. Its value is a string that designates the remote +host in a cross-compilation environment, to be used for remote compilation and +debugging. This field should not be specified when running on the local +machine. + +@item Program_Host +This is a simple attribute. Its value is a string that specifies the +name of IP address of the embedded target in a cross-compilation environment, +on which the program should execute. + +@item Communication_Protocol +This is a simple string attribute. Its value is the name of the protocol +to use to communicate with the target in a cross-compilation environment, +e.g.@: @code{"wtx"} or @code{"vxworks"}. + +@item Compiler_Command +This is an associative array attribute, whose domain is a language name. Its +value is string that denotes the command to be used to invoke the compiler. +The value of @code{Compiler_Command ("Ada")} is expected to be compatible with +gnatmake, in particular in the handling of switches. + +@item Debugger_Command +This is simple attribute, Its value is a string that specifies the name of +the debugger to be used, such as gdb, powerpc-wrs-vxworks-gdb or gdb-4. + +@item Default_Switches +This is an associative array attribute. Its indexes are the name of the +external tools that the GNAT Programming System (GPS) is supporting. Its +value is a list of switches to use when invoking that tool. + +@item Gnatlist +This is a simple attribute. Its value is a string that specifies the name +of the @command{gnatls} utility to be used to retrieve information about the +predefined path; e.g., @code{"gnatls"}, @code{"powerpc-wrs-vxworks-gnatls"}. +@item VCS_Kind +This is a simple attribute. Its value is a string used to specify the +Version Control System (VCS) to be used for this project, e.g.@: CVS, RCS +ClearCase or Perforce. + +@item VCS_File_Check +This is a simple attribute. Its value is a string that specifies the +command used by the VCS to check the validity of a file, either +when the user explicitly asks for a check, or as a sanity check before +doing the check-in. + +@item VCS_Log_Check +This is a simple attribute. Its value is a string that specifies +the command used by the VCS to check the validity of a log file. + +@item VCS_Repository_Root +The VCS repository root path. This is used to create tags or branches +of the repository. For subversion the value should be the @code{URL} +as specified to check-out the working copy of the repository. + +@item VCS_Patch_Root +The local root directory to use for building patch file. All patch chunks +will be relative to this path. The root project directory is used if +this value is not defined. + +@end table + +@c --------------------------------------------- +@node Cleaning up with GPRclean +@section Cleaning up with GPRclean +@c --------------------------------------------- + +@noindent +The GPRclean tool removes the files created by GPRbuild. +At a minimum, to invoke GPRclean you must specify a main project file +in a command such as @code{gprclean proj.gpr} or @code{gprclean -P proj.gpr}. + +Examples of invocation of GPRclean: + +@smallexample + gprclean -r prj1.gpr + gprclean -c -P prj2.gpr +@end smallexample + +@menu +* Switches for GPRclean:: +@end menu + +@c --------------------------------------------- +@node Switches for GPRclean +@subsection Switches for GPRclean +@c --------------------------------------------- + +@noindent +The switches for GPRclean are: + +@itemize @bullet +@item @option{--config=
    } : Specify the + configuration project file name + +@item @option{--autoconf=} + + This specifies a configuration project file name that already exists or will + be created automatically. Option @option{--autoconf=} + cannot be specified more than once. If the configuration project file + specified with @option{--autoconf=} exists, then it is used. Otherwise, + @value{gprconfig} is invoked to create it automatically. + +@item @option{-c} : Only delete compiler-generated files. Do not delete + executables and libraries. + +@item @option{-f} : Force deletions of unwritable files + +@item @option{-F} : Display full project path name in brief error messages + +@item @option{-h} : Display this message + +@item @option{-n} : Do not delete files, only list files to delete + +@item @option{-P} : Use Project File @emph{}. + +@item @option{-q} : Be quiet/terse. There is no output, except to report + problems. + +@item @option{-r} : (recursive) Clean all projects referenced by the main + project directly or indirectly. Without this switch, GPRclean only + cleans the main project. + +@item @option{-v} : Verbose mode + +@item @option{-vPx} : Specify verbosity when parsing Project Files. + x = 0 (default), 1 or 2. + +@item @option{-Xnm=val} : Specify an external reference for Project Files. + +@end itemize + + + diff --git a/gcc/ada/put_scos.adb b/gcc/ada/put_scos.adb new file mode 100644 index 000000000..9d3bcd7bb --- /dev/null +++ b/gcc/ada/put_scos.adb @@ -0,0 +1,205 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P U T _ S C O S -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with SCOs; use SCOs; + +procedure Put_SCOs is + Ctr : Nat; + + procedure Output_Range (T : SCO_Table_Entry); + -- Outputs T.From and T.To in line:col-line:col format + + procedure Output_Source_Location (Loc : Source_Location); + -- Output source location in line:col format + + ------------------ + -- Output_Range -- + ------------------ + + procedure Output_Range (T : SCO_Table_Entry) is + begin + Output_Source_Location (T.From); + Write_Info_Char ('-'); + Output_Source_Location (T.To); + end Output_Range; + + ---------------------------- + -- Output_Source_Location -- + ---------------------------- + + procedure Output_Source_Location (Loc : Source_Location) is + begin + Write_Info_Nat (Nat (Loc.Line)); + Write_Info_Char (':'); + Write_Info_Nat (Nat (Loc.Col)); + end Output_Source_Location; + +-- Start of processing for Put_SCOs + +begin + -- Loop through entries in SCO_Unit_Table + + for U in 1 .. SCO_Unit_Table.Last loop + declare + SUT : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (U); + + Start : Nat; + Stop : Nat; + + begin + Start := SUT.From; + Stop := SUT.To; + + -- Write unit header (omitted if no SCOs are generated for this unit) + + if Start <= Stop then + Write_Info_Initiate ('C'); + Write_Info_Char (' '); + Write_Info_Nat (SUT.Dep_Num); + Write_Info_Char (' '); + + for N in SUT.File_Name'Range loop + Write_Info_Char (SUT.File_Name (N)); + end loop; + + Write_Info_Terminate; + end if; + + -- Loop through SCO entries for this unit + + loop + exit when Start = Stop + 1; + pragma Assert (Start <= Stop); + + Output_SCO_Line : declare + T : SCO_Table_Entry renames SCO_Table.Table (Start); + + begin + case T.C1 is + + -- Statements + + when 'S' => + Write_Info_Initiate ('C'); + Write_Info_Char ('S'); + + Ctr := 0; + loop + Write_Info_Char (' '); + + if SCO_Table.Table (Start).C2 /= ' ' then + Write_Info_Char (SCO_Table.Table (Start).C2); + end if; + + Output_Range (SCO_Table.Table (Start)); + exit when SCO_Table.Table (Start).Last; + + Start := Start + 1; + pragma Assert (SCO_Table.Table (Start).C1 = 's'); + + Ctr := Ctr + 1; + + -- Up to 6 items on a line, if more than 6 items, + -- continuation lines are marked Cs. + + if Ctr = 6 then + Write_Info_Terminate; + Write_Info_Initiate ('C'); + Write_Info_Char ('s'); + Ctr := 0; + end if; + end loop; + + Write_Info_Terminate; + + -- Statement continuations should not occur since they + -- are supposed to have been handled in the loop above. + + when 's' => + raise Program_Error; + + -- Decision + + when 'I' | 'E' | 'P' | 'W' | 'X' => + Start := Start + 1; + + -- For disabled pragma, skip decision output + + if T.C1 = 'P' and then T.C2 = 'd' then + while not SCO_Table.Table (Start).Last loop + Start := Start + 1; + end loop; + + -- For all other cases output decision line + + else + Write_Info_Initiate ('C'); + Write_Info_Char (T.C1); + + if T.C1 /= 'X' then + Write_Info_Char (' '); + Output_Source_Location (T.From); + end if; + + -- Loop through table entries for this decision + + loop + declare + T : SCO_Table_Entry + renames SCO_Table.Table (Start); + + begin + Write_Info_Char (' '); + + if T.C1 = '!' or else + T.C1 = '&' or else + T.C1 = '|' + then + Write_Info_Char (T.C1); + Output_Source_Location (T.From); + + else + Write_Info_Char (T.C2); + Output_Range (T); + end if; + + exit when T.Last; + Start := Start + 1; + end; + end loop; + + Write_Info_Terminate; + end if; + + when others => + raise Program_Error; + end case; + end Output_SCO_Line; + + Start := Start + 1; + end loop; + end; + end loop; +end Put_SCOs; diff --git a/gcc/ada/put_scos.ads b/gcc/ada/put_scos.ads new file mode 100644 index 000000000..d8d77202b --- /dev/null +++ b/gcc/ada/put_scos.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P U T _ S C O 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 used to read SCO information from the +-- internal tables defined in package SCOs, and output text information for +-- the ALI file. The interface allows control over the destination of the +-- output, so that this routine can also be used for debugging purposes. + +with Types; use Types; + +generic + -- The following procedures are used to output text information. The + -- destination of the text information is thus under control of the + -- particular instantiation. In particular, this procedure is used to + -- write output to the ALI file, and also for debugging output. + + with procedure Write_Info_Char (C : Character) is <>; + -- Outputs one character + + with procedure Write_Info_Initiate (Key : Character) is <>; + -- Initiates write of new line to output file, the parameter is the + -- keyword character for the line. + + with procedure Write_Info_Nat (N : Nat) is <>; + -- Writes image of N to output file with no leading or trailing blanks + + with procedure Write_Info_Terminate is <>; + -- Terminate current info line and output lines built in Info_Buffer + +procedure Put_SCOs; +-- Read information from SCOs.SCO_Table and SCOs.SCO_Unit_Table and output +-- corresponding information in ALI format using the Write_Info procedures. diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c new file mode 100644 index 000000000..9c6aef930 --- /dev/null +++ b/gcc/ada/raise-gcc.c @@ -0,0 +1,1237 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * R A I S E - G C C * + * * + * C Implementation File * + * * + * 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. * + * * + ****************************************************************************/ + +/* Code related to the integration of the GCC mechanism for exception + handling. */ + +#ifdef IN_RTS +#include "tconfig.h" +#include "tsystem.h" +/* In the top-of-tree GCC, tconfig does not include tm.h, but in GCC 3.2 + it does. To avoid branching raise.c just for that purpose, we kludge by + looking for a symbol always defined by tm.h and if it's not defined, + we include it. */ +#ifndef FIRST_PSEUDO_REGISTER +#include "coretypes.h" +#include "tm.h" +#endif +#include +#include +typedef char bool; +# define true 1 +# define false 0 +#else +#include "config.h" +#include "system.h" +#endif + +#include "adaint.h" +#include "raise.h" + +#ifdef __APPLE__ +/* On MacOS X, versions older than 10.5 don't export _Unwind_GetIPInfo. */ +#undef HAVE_GETIPINFO +#if __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ >= 1050 +#define HAVE_GETIPINFO 1 +#endif +#endif + +/* The names of a couple of "standard" routines for unwinding/propagation + actually vary depending on the underlying GCC scheme for exception handling + (SJLJ or DWARF). We need a consistently named interface to import from + a-except, so wrappers are defined here. + + Besides, even though the compiler is never setup to use the GCC propagation + circuitry, it still relies on exceptions internally and part of the sources + to handle to exceptions are shared with the run-time library. We need + dummy definitions for the wrappers to satisfy the linker in this case. + + The types to be used by those wrappers in the run-time library are target + types exported by unwind.h. We used to piggyback on them for the compiler + stubs, but there is no guarantee that unwind.h is always in sight so we + define our own set below. These are dummy types as the wrappers are never + called in the compiler case. */ + +#ifdef IN_RTS + +#include "unwind.h" + +typedef struct _Unwind_Context _Unwind_Context; +typedef struct _Unwind_Exception _Unwind_Exception; + +#else + +typedef void _Unwind_Context; +typedef void _Unwind_Exception; +typedef int _Unwind_Reason_Code; + +#endif + +_Unwind_Reason_Code +__gnat_Unwind_RaiseException (_Unwind_Exception *); + +_Unwind_Reason_Code +__gnat_Unwind_ForcedUnwind (_Unwind_Exception *, void *, void *); + + +#ifdef IN_RTS /* For eh personality routine */ + +#include "dwarf2.h" +#include "unwind-dw2-fde.h" +#include "unwind-pe.h" + + +/* -------------------------------------------------------------- + -- The DB stuff below is there for debugging purposes only. -- + -------------------------------------------------------------- */ + +#define DB_PHASES 0x1 +#define DB_CSITE 0x2 +#define DB_ACTIONS 0x4 +#define DB_REGIONS 0x8 + +#define DB_ERR 0x1000 + +/* The "action" stuff below is also there for debugging purposes only. */ + +typedef struct +{ + _Unwind_Action phase; + char * description; +} phase_descriptor; + +static phase_descriptor phase_descriptors[] + = {{ _UA_SEARCH_PHASE, "SEARCH_PHASE" }, + { _UA_CLEANUP_PHASE, "CLEANUP_PHASE" }, + { _UA_HANDLER_FRAME, "HANDLER_FRAME" }, + { _UA_FORCE_UNWIND, "FORCE_UNWIND" }, + { -1, 0}}; + +static int +db_accepted_codes (void) +{ + static int accepted_codes = -1; + + if (accepted_codes == -1) + { + char * db_env = (char *) getenv ("EH_DEBUG"); + + accepted_codes = db_env ? (atoi (db_env) | DB_ERR) : 0; + /* Arranged for ERR stuff to always be visible when the variable + is defined. One may just set the variable to 0 to see the ERR + stuff only. */ + } + + return accepted_codes; +} + +#define DB_INDENT_INCREASE 0x01 +#define DB_INDENT_DECREASE 0x02 +#define DB_INDENT_OUTPUT 0x04 +#define DB_INDENT_NEWLINE 0x08 +#define DB_INDENT_RESET 0x10 + +#define DB_INDENT_UNIT 8 + +static void +db_indent (int requests) +{ + static int current_indentation_level = 0; + + if (requests & DB_INDENT_RESET) + { + current_indentation_level = 0; + } + + if (requests & DB_INDENT_INCREASE) + { + current_indentation_level ++; + } + + if (requests & DB_INDENT_DECREASE) + { + current_indentation_level --; + } + + if (requests & DB_INDENT_NEWLINE) + { + fprintf (stderr, "\n"); + } + + if (requests & DB_INDENT_OUTPUT) + { + fprintf (stderr, "%*s", + current_indentation_level * DB_INDENT_UNIT, " "); + } + +} + +static void ATTRIBUTE_PRINTF_2 +db (int db_code, char * msg_format, ...) +{ + if (db_accepted_codes () & db_code) + { + va_list msg_args; + + db_indent (DB_INDENT_OUTPUT); + + va_start (msg_args, msg_format); + vfprintf (stderr, msg_format, msg_args); + va_end (msg_args); + } +} + +static void +db_phases (int phases) +{ + phase_descriptor *a = phase_descriptors; + + if (! (db_accepted_codes() & DB_PHASES)) + return; + + db (DB_PHASES, "\n"); + + for (; a->description != 0; a++) + if (phases & a->phase) + db (DB_PHASES, "%s ", a->description); + + db (DB_PHASES, " :\n"); +} + + +/* --------------------------------------------------------------- + -- Now come a set of useful structures and helper routines. -- + --------------------------------------------------------------- */ + +/* There are three major runtime tables involved, generated by the + GCC back-end. Contents slightly vary depending on the underlying + implementation scheme (dwarf zero cost / sjlj). + + ======================================= + * Tables for the dwarf zero cost case * + ======================================= + + call_site [] + ------------------------------------------------------------------- + * region-start | region-length | landing-pad | first-action-index * + ------------------------------------------------------------------- + + Identify possible actions to be taken and where to resume control + for that when an exception propagates through a pc inside the region + delimited by start and length. + + A null landing-pad indicates that nothing is to be done. + + Otherwise, first-action-index provides an entry into the action[] + table which heads a list of possible actions to be taken (see below). + + If it is determined that indeed an action should be taken, that + is, if one action filter matches the exception being propagated, + then control should be transfered to landing-pad. + + A null first-action-index indicates that there are only cleanups + to run there. + + action [] + ------------------------------- + * action-filter | next-action * + ------------------------------- + + This table contains lists (called action chains) of possible actions + associated with call-site entries described in the call-site [] table. + There is at most one action list per call-site entry. + + A null action-filter indicates a cleanup. + + Non null action-filters provide an index into the ttypes [] table + (see below), from which information may be retrieved to check if it + matches the exception being propagated. + + action-filter > 0 means there is a regular handler to be run, + + action-filter < 0 means there is a some "exception_specification" + data to retrieve, which is only relevant for C++ + and should never show up for Ada. + + next-action indexes the next entry in the list. 0 indicates there is + no other entry. + + ttypes [] + --------------- + * ttype-value * + --------------- + + A null value indicates a catch-all handler in C++, and an "others" + handler in Ada. + + Non null values are used to match the exception being propagated: + In C++ this is a pointer to some rtti data, while in Ada this is an + exception id. + + The special id value 1 indicates an "all_others" handler. + + For C++, this table is actually also used to store "exception + specification" data. The differentiation between the two kinds + of entries is made by the sign of the associated action filter, + which translates into positive or negative offsets from the + so called base of the table: + + Exception Specification data is stored at positive offsets from + the ttypes table base, which Exception Type data is stored at + negative offsets: + + --------------------------------------------------------------------------- + + Here is a quick summary of the tables organization: + + +-- Unwind_Context (pc, ...) + | + |(pc) + | + | CALL-SITE[] + | + | +=============================================================+ + | | region-start + length | landing-pad | first-action-index | + | +=============================================================+ + +-> | pc range 0 => no-action 0 => cleanups only | + | !0 => jump @ N --+ | + +====================================================== | ====+ + | + | + ACTION [] | + | + +==========================================================+ | + | action-filter | next-action | | + +==========================================================+ | + | 0 => cleanup | | + | >0 => ttype index for handler ------+ 0 => end of chain | <-+ + | <0 => ttype index for spec data | | + +==================================== | ===================+ + | + | + TTYPES [] | + | Offset negated from + +=====================+ | the actual base. + | ttype-value | | + +============+=====================+ | + | | 0 => "others" | | + | ... | 1 => "all others" | <---+ + | | X => exception id | + | handlers +---------------------+ + | | ... | + | ... | ... | + | | ... | + +============+=====================+ <<------ Table base + | ... | ... | + | specs | ... | (should not see negative filter + | ... | ... | values for Ada). + +============+=====================+ + + + ============================ + * Tables for the sjlj case * + ============================ + + So called "function contexts" are pushed on a context stack by calls to + _Unwind_SjLj_Register on function entry, and popped off at exit points by + calls to _Unwind_SjLj_Unregister. The current call_site for a function is + updated in the function context as the function's code runs along. + + The generic unwinding engine in _Unwind_RaiseException walks the function + context stack and not the actual call chain. + + The ACTION and TTYPES tables remain unchanged, which allows to search them + during the propagation phase to determine whether or not the propagated + exception is handled somewhere. When it is, we only "jump" up once directly + to the context where the handler will be found. Besides, this allows "break + exception unhandled" to work also + + The CALL-SITE table is setup differently, though: the pc attached to the + unwind context is a direct index into the table, so the entries in this + table do not hold region bounds any more. + + A special index (-1) is used to indicate that no action is possibly + connected with the context at hand, so null landing pads cannot appear + in the table. + + Additionally, landing pad values in the table do not represent code address + to jump at, but so called "dispatch" indices used by a common landing pad + for the function to switch to the appropriate post-landing-pad. + + +-- Unwind_Context (pc, ...) + | + | pc = call-site index + | 0 => terminate (should not see this for Ada) + | -1 => no-action + | + | CALL-SITE[] + | + | +=====================================+ + | | landing-pad | first-action-index | + | +=====================================+ + +-> | 0 => cleanups only | + | dispatch index N | + +=====================================+ + + + =================================== + * Basic organization of this unit * + =================================== + + The major point of this unit is to provide an exception propagation + personality routine for Ada. This is __gnat_personality_v0. + + It is provided with a pointer to the propagated exception, an unwind + context describing a location the propagation is going through, and a + couple of other arguments including a description of the current + propagation phase. + + It shall return to the generic propagation engine what is to be performed + next, after possible context adjustments, depending on what it finds in the + traversed context (a handler for the exception, a cleanup, nothing, ...), + and on the propagation phase. + + A number of structures and subroutines are used for this purpose, as + sketched below: + + o region_descriptor: General data associated with the context (base pc, + call-site table, action table, ttypes table, ...) + + o action_descriptor: Data describing the action to be taken for the + propagated exception in the provided context (kind of action: nothing, + handler, cleanup; pointer to the action table entry, ...). + + raise + | + ... (a-except.adb) + | + Propagate_Exception (a-exexpr.adb) + | + | + _Unwind_RaiseException (libgcc) + | + | (Ada frame) + | + +--> __gnat_personality_v0 (context, exception) + | + +--> get_region_descriptor_for (context) + | + +--> get_action_descriptor_for (context, exception, region) + | | + | +--> get_call_site_action_for (context, region) + | (one version for each underlying scheme) + | + +--> setup_to_install (context) + + This unit is inspired from the C++ version found in eh_personality.cc, + part of libstdc++-v3. + +*/ + + +/* This is an incomplete "proxy" of the structure of exception objects as + built by the GNAT runtime library. Accesses to other fields than the common + header are performed through subprogram calls to alleviate the need of an + exact counterpart here and potential alignment/size issues for the common + header. See a-exexpr.adb. */ + +typedef struct +{ + _Unwind_Exception common; + /* ABI header, maximally aligned. */ +} _GNAT_Exception; + +/* The two constants below are specific ttype identifiers for special + exception ids. Their type should match what a-exexpr exports. */ + +extern const int __gnat_others_value; +#define GNAT_OTHERS ((_Unwind_Ptr) &__gnat_others_value) + +extern const int __gnat_all_others_value; +#define GNAT_ALL_OTHERS ((_Unwind_Ptr) &__gnat_all_others_value) + +/* Describe the useful region data associated with an unwind context. */ + +typedef struct +{ + /* The base pc of the region. */ + _Unwind_Ptr base; + + /* Pointer to the Language Specific Data for the region. */ + _Unwind_Ptr lsda; + + /* Call-Site data associated with this region. */ + unsigned char call_site_encoding; + const unsigned char *call_site_table; + + /* The base to which are relative landing pad offsets inside the call-site + entries . */ + _Unwind_Ptr lp_base; + + /* Action-Table associated with this region. */ + const unsigned char *action_table; + + /* Ttype data associated with this region. */ + unsigned char ttype_encoding; + const unsigned char *ttype_table; + _Unwind_Ptr ttype_base; + +} region_descriptor; + +static void +db_region_for (region_descriptor *region, _Unwind_Context *uw_context) +{ + int ip_before_insn = 0; +#ifdef HAVE_GETIPINFO + _Unwind_Ptr ip = _Unwind_GetIPInfo (uw_context, &ip_before_insn); +#else + _Unwind_Ptr ip = _Unwind_GetIP (uw_context); +#endif + if (!ip_before_insn) + ip--; + + if (! (db_accepted_codes () & DB_REGIONS)) + return; + + db (DB_REGIONS, "For ip @ 0x%08x => ", ip); + + if (region->lsda) + db (DB_REGIONS, "lsda @ 0x%x", region->lsda); + else + db (DB_REGIONS, "no lsda"); + + db (DB_REGIONS, "\n"); +} + +/* Retrieve the ttype entry associated with FILTER in the REGION's + ttype table. */ + +static const _Unwind_Ptr +get_ttype_entry_for (region_descriptor *region, long filter) +{ + _Unwind_Ptr ttype_entry; + + filter *= size_of_encoded_value (region->ttype_encoding); + read_encoded_value_with_base + (region->ttype_encoding, region->ttype_base, + region->ttype_table - filter, &ttype_entry); + + return ttype_entry; +} + +/* Fill out the REGION descriptor for the provided UW_CONTEXT. */ + +static void +get_region_description_for (_Unwind_Context *uw_context, + region_descriptor *region) +{ + const unsigned char * p; + _uleb128_t tmp; + unsigned char lpbase_encoding; + + /* Get the base address of the lsda information. If the provided context + is null or if there is no associated language specific data, there's + nothing we can/should do. */ + region->lsda + = (_Unwind_Ptr) (uw_context + ? _Unwind_GetLanguageSpecificData (uw_context) : 0); + + if (! region->lsda) + return; + + /* Parse the lsda and fill the region descriptor. */ + p = (char *)region->lsda; + + region->base = _Unwind_GetRegionStart (uw_context); + + /* Find @LPStart, the base to which landing pad offsets are relative. */ + lpbase_encoding = *p++; + if (lpbase_encoding != DW_EH_PE_omit) + p = read_encoded_value + (uw_context, lpbase_encoding, p, ®ion->lp_base); + else + region->lp_base = region->base; + + /* Find @TType, the base of the handler and exception spec type data. */ + region->ttype_encoding = *p++; + if (region->ttype_encoding != DW_EH_PE_omit) + { + p = read_uleb128 (p, &tmp); + region->ttype_table = p + tmp; + } + else + region->ttype_table = 0; + + region->ttype_base + = base_of_encoded_value (region->ttype_encoding, uw_context); + + /* Get the encoding and length of the call-site table; the action table + immediately follows. */ + region->call_site_encoding = *p++; + region->call_site_table = read_uleb128 (p, &tmp); + + region->action_table = region->call_site_table + tmp; +} + + +/* Describe an action to be taken when propagating an exception up to + some context. */ + +typedef enum +{ + /* Found some call site base data, but need to analyze further + before being able to decide. */ + unknown, + + /* There is nothing relevant in the context at hand. */ + nothing, + + /* There are only cleanups to run in this context. */ + cleanup, + + /* There is a handler for the exception in this context. */ + handler +} action_kind; + +/* filter value for cleanup actions. */ +const int cleanup_filter = 0; + +typedef struct +{ + /* The kind of action to be taken. */ + action_kind kind; + + /* A pointer to the action record entry. */ + const unsigned char *table_entry; + + /* Where we should jump to actually take an action (trigger a cleanup or an + exception handler). */ + _Unwind_Ptr landing_pad; + + /* If we have a handler matching our exception, these are the filter to + trigger it and the corresponding id. */ + _Unwind_Sword ttype_filter; + _Unwind_Ptr ttype_entry; + +} action_descriptor; + +static void +db_action_for (action_descriptor *action, _Unwind_Context *uw_context) +{ + int ip_before_insn = 0; +#ifdef HAVE_GETIPINFO + _Unwind_Ptr ip = _Unwind_GetIPInfo (uw_context, &ip_before_insn); +#else + _Unwind_Ptr ip = _Unwind_GetIP (uw_context); +#endif + if (!ip_before_insn) + ip--; + + db (DB_ACTIONS, "For ip @ 0x%08x => ", ip); + + switch (action->kind) + { + case unknown: + db (DB_ACTIONS, "lpad @ 0x%x, record @ 0x%x\n", + action->landing_pad, action->table_entry); + break; + + case nothing: + db (DB_ACTIONS, "Nothing\n"); + break; + + case cleanup: + db (DB_ACTIONS, "Cleanup\n"); + break; + + case handler: + db (DB_ACTIONS, "Handler, filter = %d\n", action->ttype_filter); + break; + + default: + db (DB_ACTIONS, "Err? Unexpected action kind !\n"); + break; + } + + return; +} + +/* Search the call_site_table of REGION for an entry appropriate for the + UW_CONTEXT's IP. If one is found, store the associated landing_pad + and action_table entry, and set the ACTION kind to unknown for further + analysis. Otherwise, set the ACTION kind to nothing. + + There are two variants of this routine, depending on the underlying + mechanism (DWARF/SJLJ), which account for differences in the tables. */ + +#ifdef __USING_SJLJ_EXCEPTIONS__ + +#define __builtin_eh_return_data_regno(x) x + +static void +get_call_site_action_for (_Unwind_Context *uw_context, + region_descriptor *region, + action_descriptor *action) +{ + int ip_before_insn = 0; +#ifdef HAVE_GETIPINFO + _Unwind_Ptr call_site = _Unwind_GetIPInfo (uw_context, &ip_before_insn); +#else + _Unwind_Ptr call_site = _Unwind_GetIP (uw_context); +#endif + /* Subtract 1 if necessary because GetIPInfo returns the actual call site + value + 1 in this case. */ + if (!ip_before_insn) + call_site--; + + /* call_site is a direct index into the call-site table, with two special + values : -1 for no-action and 0 for "terminate". The latter should never + show up for Ada. To test for the former, beware that _Unwind_Ptr might + be unsigned. */ + + if ((int)call_site < 0) + { + action->kind = nothing; + return; + } + else if (call_site == 0) + { + db (DB_ERR, "========> Err, null call_site for Ada/sjlj\n"); + action->kind = nothing; + return; + } + else + { + _uleb128_t cs_lp, cs_action; + + /* Let the caller know there may be an action to take, but let it + determine the kind. */ + action->kind = unknown; + + /* We have a direct index into the call-site table, but this table is + made of leb128 values, the encoding length of which is variable. We + can't merely compute an offset from the index, then, but have to read + all the entries before the one of interest. */ + + const unsigned char *p = region->call_site_table; + + do { + p = read_uleb128 (p, &cs_lp); + p = read_uleb128 (p, &cs_action); + } while (--call_site); + + action->landing_pad = cs_lp + 1; + + if (cs_action) + action->table_entry = region->action_table + cs_action - 1; + else + action->table_entry = 0; + + return; + } +} + +#else /* !__USING_SJLJ_EXCEPTIONS__ */ + +static void +get_call_site_action_for (_Unwind_Context *uw_context, + region_descriptor *region, + action_descriptor *action) +{ + const unsigned char *p = region->call_site_table; + int ip_before_insn = 0; +#ifdef HAVE_GETIPINFO + _Unwind_Ptr ip = _Unwind_GetIPInfo (uw_context, &ip_before_insn); +#else + _Unwind_Ptr ip = _Unwind_GetIP (uw_context); +#endif + /* Subtract 1 if necessary because GetIPInfo yields a call return address + in this case, while we are interested in information for the call point. + This does not always yield the exact call instruction address but always + brings the IP back within the corresponding region. */ + if (!ip_before_insn) + ip--; + + /* Unless we are able to determine otherwise... */ + action->kind = nothing; + + db (DB_CSITE, "\n"); + + while (p < region->action_table) + { + _Unwind_Ptr cs_start, cs_len, cs_lp; + _uleb128_t cs_action; + + /* Note that all call-site encodings are "absolute" displacements. */ + p = read_encoded_value (0, region->call_site_encoding, p, &cs_start); + p = read_encoded_value (0, region->call_site_encoding, p, &cs_len); + p = read_encoded_value (0, region->call_site_encoding, p, &cs_lp); + p = read_uleb128 (p, &cs_action); + + db (DB_CSITE, + "c_site @ 0x%08x (+0x%03x), len = %3d, lpad @ 0x%08x (+0x%03x)\n", + region->base+cs_start, cs_start, cs_len, + region->lp_base+cs_lp, cs_lp); + + /* The table is sorted, so if we've passed the IP, stop. */ + if (ip < region->base + cs_start) + break; + + /* If we have a match, fill the ACTION fields accordingly. */ + else if (ip < region->base + cs_start + cs_len) + { + /* Let the caller know there may be an action to take, but let it + determine the kind. */ + action->kind = unknown; + + if (cs_lp) + action->landing_pad = region->lp_base + cs_lp; + else + action->landing_pad = 0; + + if (cs_action) + action->table_entry = region->action_table + cs_action - 1; + else + action->table_entry = 0; + + db (DB_CSITE, "+++\n"); + return; + } + } + + db (DB_CSITE, "---\n"); +} + +#endif /* __USING_SJLJ_EXCEPTIONS__ */ + +/* With CHOICE an exception choice representing an "exception - when" + argument, and PROPAGATED_EXCEPTION a pointer to the currently propagated + occurrence, return true if the latter matches the former, that is, if + PROPAGATED_EXCEPTION is caught by the handling code controlled by CHOICE. + This takes care of the special Non_Ada_Error case on VMS. */ + +#define Is_Handled_By_Others __gnat_is_handled_by_others +#define Language_For __gnat_language_for +#define Import_Code_For __gnat_import_code_for +#define EID_For __gnat_eid_for +#define Adjust_N_Cleanups_For __gnat_adjust_n_cleanups_for + +extern bool Is_Handled_By_Others (_Unwind_Ptr eid); +extern char Language_For (_Unwind_Ptr eid); + +extern Exception_Code Import_Code_For (_Unwind_Ptr eid); + +extern Exception_Id EID_For (_GNAT_Exception * e); +extern void Adjust_N_Cleanups_For (_GNAT_Exception * e, int n); + +static int +is_handled_by (_Unwind_Ptr choice, _GNAT_Exception * propagated_exception) +{ + /* Pointer to the GNAT exception data corresponding to the propagated + occurrence. */ + _Unwind_Ptr E = (_Unwind_Ptr) EID_For (propagated_exception); + + /* Base matching rules: An exception data (id) matches itself, "when + all_others" matches anything and "when others" matches anything unless + explicitly stated otherwise in the propagated occurrence. */ + + bool is_handled = + choice == E + || choice == GNAT_ALL_OTHERS + || (choice == GNAT_OTHERS && Is_Handled_By_Others (E)); + + /* In addition, on OpenVMS, Non_Ada_Error matches VMS exceptions, and we + may have different exception data pointers that should match for the + same condition code, if both an export and an import have been + registered. The import code for both the choice and the propagated + occurrence are expected to have been masked off regarding severity + bits already (at registration time for the former and from within the + low level exception vector for the latter). */ +#ifdef VMS + #define Non_Ada_Error system__aux_dec__non_ada_error + extern struct Exception_Data Non_Ada_Error; + + is_handled |= + (Language_For (E) == 'V' + && choice != GNAT_OTHERS && choice != GNAT_ALL_OTHERS + && ((Language_For (choice) == 'V' && Import_Code_For (choice) != 0 + && Import_Code_For (choice) == Import_Code_For (E)) + || choice == (_Unwind_Ptr)&Non_Ada_Error)); +#endif + + return is_handled; +} + +/* Fill out the ACTION to be taken from propagating UW_EXCEPTION up to + UW_CONTEXT in REGION. */ + +static void +get_action_description_for (_Unwind_Context *uw_context, + _Unwind_Exception *uw_exception, + region_descriptor *region, + action_descriptor *action) +{ + _GNAT_Exception * gnat_exception = (_GNAT_Exception *) uw_exception; + + /* Search the call site table first, which may get us a landing pad as well + as the head of an action record list. */ + get_call_site_action_for (uw_context, region, action); + db_action_for (action, uw_context); + + /* If there is not even a call_site entry, we are done. */ + if (action->kind == nothing) + return; + + /* Otherwise, check what we have at the place of the call site. */ + + /* No landing pad => no cleanups or handlers. */ + if (action->landing_pad == 0) + { + action->kind = nothing; + return; + } + + /* Landing pad + null table entry => only cleanups. */ + else if (action->table_entry == 0) + { + action->kind = cleanup; + action->ttype_filter = cleanup_filter; + /* The filter initialization is not strictly necessary, as cleanup-only + landing pads don't look at the filter value. It is there to ensure + we don't pass random values and so trigger potential confusion when + installing the context later on. */ + return; + } + + /* Landing pad + Table entry => handlers + possible cleanups. */ + else + { + const unsigned char * p = action->table_entry; + + _sleb128_t ar_filter, ar_disp; + + action->kind = nothing; + + while (1) + { + p = read_sleb128 (p, &ar_filter); + read_sleb128 (p, &ar_disp); + /* Don't assign p here, as it will be incremented by ar_disp + below. */ + + /* Null filters are for cleanups. */ + if (ar_filter == cleanup_filter) + { + action->kind = cleanup; + action->ttype_filter = cleanup_filter; + /* The filter initialization is required here, to ensure + the target landing pad branches to the cleanup code if + we happen not to find a matching handler. */ + } + + /* Positive filters are for regular handlers. */ + else if (ar_filter > 0) + { + /* See if the filter we have is for an exception which matches + the one we are propagating. */ + _Unwind_Ptr choice = get_ttype_entry_for (region, ar_filter); + + if (is_handled_by (choice, gnat_exception)) + { + action->kind = handler; + action->ttype_filter = ar_filter; + action->ttype_entry = choice; + return; + } + } + + /* Negative filter values are for C++ exception specifications. + Should not be there for Ada :/ */ + else + db (DB_ERR, "========> Err, filter < 0 for Ada/dwarf\n"); + + if (ar_disp == 0) + return; + + p += ar_disp; + } + } +} + +/* Setup in UW_CONTEXT the eh return target IP and data registers, which will + be restored with the others and retrieved by the landing pad once the jump + occurred. */ + +static void +setup_to_install (_Unwind_Context *uw_context, + _Unwind_Exception *uw_exception, + _Unwind_Ptr uw_landing_pad, + int uw_filter) +{ +#ifndef EH_RETURN_DATA_REGNO + /* We should not be called if the appropriate underlying support is not + there. */ + abort (); +#else + /* 1/ exception object pointer, which might be provided back to + _Unwind_Resume (and thus to this personality routine) if we are jumping + to a cleanup. */ + _Unwind_SetGR (uw_context, __builtin_eh_return_data_regno (0), + (_Unwind_Word)uw_exception); + + /* 2/ handler switch value register, which will also be used by the target + landing pad to decide what action it shall take. */ + _Unwind_SetGR (uw_context, __builtin_eh_return_data_regno (1), + (_Unwind_Word)uw_filter); + + /* Setup the address we should jump at to reach the code where there is the + "something" we found. */ + _Unwind_SetIP (uw_context, uw_landing_pad); +#endif +} + +/* The following is defined from a-except.adb. Its purpose is to enable + automatic backtraces upon exception raise, as provided through the + GNAT.Traceback facilities. */ +extern void __gnat_notify_handled_exception (void); +extern void __gnat_notify_unhandled_exception (void); + +/* Below is the eh personality routine per se. We currently assume that only + GNU-Ada exceptions are met. */ + +#ifdef __USING_SJLJ_EXCEPTIONS__ +#define PERSONALITY_FUNCTION __gnat_personality_sj0 +#else +#define PERSONALITY_FUNCTION __gnat_personality_v0 +#endif + +/* Major tweak for ia64-vms : the CHF propagation phase calls this personality + routine with sigargs/mechargs arguments and has very specific expectations + on possible return values. + + We handle this with a number of specific tricks: + + 1. We tweak the personality routine prototype to have the "version" and + "phases" two first arguments be void * instead of int and _Unwind_Action + as nominally expected in the GCC context. + + This allows us to access the full range of bits passed in every case and + has no impact on the callers side since each argument remains assigned + the same single 64bit slot. + + 2. We retrieve the corresponding int and _Unwind_Action values within the + routine for regular use with truncating conversions. This is a noop when + called from the libgcc unwinder. + + 3. We assume we're called by the VMS CHF when unexpected bits are set in + both those values. The incoming arguments are then real sigargs and + mechargs pointers, which we then redirect to __gnat_handle_vms_condition + for proper processing. +*/ +#if defined (VMS) && defined (__IA64) +typedef void * version_arg_t; +typedef void * phases_arg_t; +#else +typedef int version_arg_t; +typedef _Unwind_Action phases_arg_t; +#endif + +_Unwind_Reason_Code +PERSONALITY_FUNCTION (version_arg_t version_arg, + phases_arg_t phases_arg, + _Unwind_Exception_Class uw_exception_class, + _Unwind_Exception *uw_exception, + _Unwind_Context *uw_context) +{ + /* Fetch the version and phases args with their nominal ABI types for later + use. This is a noop everywhere except on ia64-vms when called from the + Condition Handling Facility. */ + int uw_version = (int) version_arg; + _Unwind_Action uw_phases = (_Unwind_Action) phases_arg; + + _GNAT_Exception * gnat_exception = (_GNAT_Exception *) uw_exception; + + region_descriptor region; + action_descriptor action; + + /* Check that we're called from the ABI context we expect, with a major + possible variation on VMS for IA64. */ + if (uw_version != 1) + { + #if defined (VMS) && defined (__IA64) + + /* Assume we're called with sigargs/mechargs arguments if really + unexpected bits are set in our first two formals. Redirect to the + GNAT condition handling code in this case. */ + + extern long __gnat_handle_vms_condition (void *, void *); + + unsigned int version_unexpected_bits_mask = 0xffffff00U; + unsigned int phases_unexpected_bits_mask = 0xffffff00U; + + if ((unsigned int)uw_version & version_unexpected_bits_mask + && (unsigned int)uw_phases & phases_unexpected_bits_mask) + return __gnat_handle_vms_condition (version_arg, phases_arg); + #endif + + return _URC_FATAL_PHASE1_ERROR; + } + + db_indent (DB_INDENT_RESET); + db_phases (uw_phases); + db_indent (DB_INDENT_INCREASE); + + /* Get the region description for the context we were provided with. This + will tell us if there is some lsda, call_site, action and/or ttype data + for the associated ip. */ + get_region_description_for (uw_context, ®ion); + db_region_for (®ion, uw_context); + + /* No LSDA => no handlers or cleanups => we shall unwind further up. */ + if (! region.lsda) + return _URC_CONTINUE_UNWIND; + + /* Search the call-site and action-record tables for the action associated + with this IP. */ + get_action_description_for (uw_context, uw_exception, ®ion, &action); + db_action_for (&action, uw_context); + + /* Whatever the phase, if there is nothing relevant in this frame, + unwinding should just go on. */ + if (action.kind == nothing) + return _URC_CONTINUE_UNWIND; + + /* If we found something in search phase, we should return a code indicating + what to do next depending on what we found. If we only have cleanups + around, we shall try to unwind further up to find a handler, otherwise, + tell we have a handler, which will trigger the second phase. */ + if (uw_phases & _UA_SEARCH_PHASE) + { + if (action.kind == cleanup) + { + Adjust_N_Cleanups_For (gnat_exception, 1); + return _URC_CONTINUE_UNWIND; + } + else + { + /* Trigger the appropriate notification routines before the second + phase starts, which ensures the stack is still intact. */ + __gnat_notify_handled_exception (); + + return _URC_HANDLER_FOUND; + } + } + + /* We found something in cleanup/handler phase, which might be the handler + or a cleanup for a handled occurrence, or a cleanup for an unhandled + occurrence (we are in a FORCED_UNWIND phase in this case). Install the + context to get there. */ + + /* If we are going to install a cleanup context, decrement the cleanup + count. This is required in a FORCED_UNWINDing phase (for an unhandled + exception), as this is used from the forced unwinding handler in + Ada.Exceptions.Exception_Propagation to decide whether unwinding should + proceed further or Unhandled_Exception_Terminate should be called. */ + if (action.kind == cleanup) + Adjust_N_Cleanups_For (gnat_exception, -1); + + setup_to_install + (uw_context, uw_exception, action.landing_pad, action.ttype_filter); + + return _URC_INSTALL_CONTEXT; +} + +/* Define the consistently named wrappers imported by Propagate_Exception. */ + +#ifdef __USING_SJLJ_EXCEPTIONS__ + +#undef _Unwind_RaiseException + +_Unwind_Reason_Code +__gnat_Unwind_RaiseException (_Unwind_Exception *e) +{ + return _Unwind_SjLj_RaiseException (e); +} + + +#undef _Unwind_ForcedUnwind + +_Unwind_Reason_Code +__gnat_Unwind_ForcedUnwind (_Unwind_Exception *e, + void * handler, + void * argument) +{ + return _Unwind_SjLj_ForcedUnwind (e, handler, argument); +} + + +#else /* __USING_SJLJ_EXCEPTIONS__ */ + +_Unwind_Reason_Code +__gnat_Unwind_RaiseException (_Unwind_Exception *e) +{ + return _Unwind_RaiseException (e); +} + +_Unwind_Reason_Code +__gnat_Unwind_ForcedUnwind (_Unwind_Exception *e, + void * handler, + void * argument) +{ + return _Unwind_ForcedUnwind (e, handler, argument); +} + +#endif /* __USING_SJLJ_EXCEPTIONS__ */ + +#else +/* ! IN_RTS */ + +/* Define the corresponding stubs for the compiler. */ + +/* We don't want fancy_abort here. */ +#undef abort + +_Unwind_Reason_Code +__gnat_Unwind_RaiseException (_Unwind_Exception *e ATTRIBUTE_UNUSED) +{ + abort (); +} + + +_Unwind_Reason_Code +__gnat_Unwind_ForcedUnwind (_Unwind_Exception *e ATTRIBUTE_UNUSED, + void * handler ATTRIBUTE_UNUSED, + void * argument ATTRIBUTE_UNUSED) +{ + abort (); +} + +#endif /* IN_RTS */ diff --git a/gcc/ada/raise.c b/gcc/ada/raise.c new file mode 100644 index 000000000..1f087783b --- /dev/null +++ b/gcc/ada/raise.c @@ -0,0 +1,81 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * R A I S E * + * * + * C Implementation File * + * * + * Copyright (C) 1992-2009, Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. * + * * + * As a special exception under Section 7 of GPL version 3, you are granted * + * additional permissions described in the GCC Runtime Library Exception, * + * version 3.1, as published by the Free Software Foundation. * + * * + * You should have received a copy of the GNU General Public License and * + * a copy of the GCC Runtime Library Exception along with this program; * + * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* Shared routines to support exception handling. __gnat_unhandled_terminate + is shared between all exception handling mechanisms. */ + +#ifdef IN_RTS +#include "tconfig.h" +#include "tsystem.h" +#else +#include "config.h" +#include "system.h" +#endif + +#include "adaint.h" +#include "raise.h" + +/* Wrapper to builtin_longjmp. This is for the compiler eh only, as the sjlj + runtime library interfaces directly to the intrinsic. We can't yet do + this for the compiler itself, because this capability relies on changes + made in april 2008 and we need to preserve the possibility to bootstrap + with an older base version. */ + +#if defined (IN_GCC) && !defined (IN_RTS) +void +_gnat_builtin_longjmp (void *ptr, int flag ATTRIBUTE_UNUSED) +{ + __builtin_longjmp (ptr, 1); +} +#endif + +/* When an exception is raised for which no handler exists, the procedure + Ada.Exceptions.Unhandled_Exception is called, which performs the call to + adafinal to complete finalization, and then prints out the error messages + for the unhandled exception. The final step is to call this routine, which + performs any system dependent cleanup required. */ + +void +__gnat_unhandled_terminate (void) +{ +#ifdef VMS + /* Special termination handling for VMS */ + long prvhnd; + + /* Remove the exception vector so it won't intercept any errors + in the call to exit, and go into and endless loop */ + + SYS$SETEXV (1, 0, 3, &prvhnd); +#endif + + /* Default termination handling */ + __gnat_os_exit (1); +} diff --git a/gcc/ada/raise.h b/gcc/ada/raise.h new file mode 100644 index 000000000..1ccc37bca --- /dev/null +++ b/gcc/ada/raise.h @@ -0,0 +1,62 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * R A I S E * + * * + * C Header File * + * * + * Copyright (C) 1992-2009, Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. * + * * + * As a special exception under Section 7 of GPL version 3, you are granted * + * additional permissions described in the GCC Runtime Library Exception, * + * version 3.1, as published by the Free Software Foundation. * + * * + * You should have received a copy of the GNU General Public License and * + * a copy of the GCC Runtime Library Exception along with this program; * + * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* C counterparts of what System.Standard_Library defines. */ + +typedef unsigned Exception_Code; + +struct Exception_Data +{ + char Not_Handled_By_Others; + char Lang; + int Name_Length; + char *Full_Name, *Htable_Ptr; + Exception_Code Import_Code; + void (*Raise_Hook)(void); +}; + +typedef struct Exception_Data *Exception_Id; + +extern void _gnat_builtin_longjmp (void *, int); +extern void __gnat_unhandled_terminate (void); +extern void *__gnat_malloc (__SIZE_TYPE__); +extern void __gnat_free (void *); +extern void *__gnat_realloc (void *, __SIZE_TYPE__); +extern void __gnat_finalize (void); +extern void set_gnat_exit_status (int); +extern void __gnat_set_globals (void); +extern void __gnat_initialize (void *); +extern void __gnat_init_float (void); +extern void __gnat_install_handler (void); +extern void __gnat_install_SEH_handler (void *); +extern void __gnat_adjust_context_for_raise (int, void *); + +extern int gnat_exit_status; diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb new file mode 100644 index 000000000..3f3f488e1 --- /dev/null +++ b/gcc/ada/repinfo.adb @@ -0,0 +1,1435 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- R E P I N F O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-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 Alloc; use Alloc; +with Atree; use Atree; +with Casing; use Casing; +with Debug; use Debug; +with Einfo; use Einfo; +with Lib; use Lib; +with Namet; use Namet; +with Opt; use Opt; +with Output; use Output; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with Stand; use Stand; +with Table; use Table; +with Uname; use Uname; +with Urealp; use Urealp; + +with Ada.Unchecked_Conversion; + +package body Repinfo is + + SSU : constant := 8; + -- Value for Storage_Unit, we do not want to get this from TTypes, since + -- this introduces problematic dependencies in ASIS, and in any case this + -- value is assumed to be 8 for the implementation of the DDA. + + -- This is wrong for AAMP??? + + --------------------------------------- + -- Representation of gcc Expressions -- + --------------------------------------- + + -- This table is used only if Frontend_Layout_On_Target is False, so gigi + -- lays out dynamic size/offset fields using encoded gcc expressions. + + -- A table internal to this unit is used to hold the values of back + -- annotated expressions. This table is written out by -gnatt and read + -- back in for ASIS processing. + + -- Node values are stored as Uint values using the negative of the node + -- index in this table. Constants appear as non-negative Uint values. + + type Exp_Node is record + Expr : TCode; + Op1 : Node_Ref_Or_Val; + Op2 : Node_Ref_Or_Val; + Op3 : Node_Ref_Or_Val; + end record; + + -- The following representation clause ensures that the above record + -- has no holes. We do this so that when instances of this record are + -- written by Tree_Gen, we do not write uninitialized values to the file. + + for Exp_Node use record + Expr at 0 range 0 .. 31; + Op1 at 4 range 0 .. 31; + Op2 at 8 range 0 .. 31; + Op3 at 12 range 0 .. 31; + end record; + + for Exp_Node'Size use 16 * 8; + -- This ensures that we did not leave out any fields + + package Rep_Table is new Table.Table ( + Table_Component_Type => Exp_Node, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => Alloc.Rep_Table_Initial, + Table_Increment => Alloc.Rep_Table_Increment, + Table_Name => "BE_Rep_Table"); + + -------------------------------------------------------------- + -- Representation of Front-End Dynamic Size/Offset Entities -- + -------------------------------------------------------------- + + package Dynamic_SO_Entity_Table is new Table.Table ( + Table_Component_Type => Entity_Id, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => Alloc.Rep_Table_Initial, + Table_Increment => Alloc.Rep_Table_Increment, + Table_Name => "FE_Rep_Table"); + + Unit_Casing : Casing_Type; + -- Identifier casing for current unit + + Need_Blank_Line : Boolean; + -- Set True if a blank line is needed before outputting any information for + -- the current entity. Set True when a new entity is processed, and false + -- when the blank line is output. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Back_End_Layout return Boolean; + -- Test for layout mode, True = back end, False = front end. This function + -- is used rather than checking the configuration parameter because we do + -- not want Repinfo to depend on Targparm (for ASIS) + + procedure Blank_Line; + -- Called before outputting anything for an entity. Ensures that + -- a blank line precedes the output for a particular entity. + + procedure List_Entities (Ent : Entity_Id); + -- This procedure lists the entities associated with the entity E, starting + -- with the First_Entity and using the Next_Entity link. If a nested + -- package is found, entities within the package are recursively processed. + + procedure List_Name (Ent : Entity_Id); + -- List name of entity Ent in appropriate case. The name is listed with + -- full qualification up to but not including the compilation unit name. + + procedure List_Array_Info (Ent : Entity_Id); + -- List representation info for array type Ent + + procedure List_Mechanisms (Ent : Entity_Id); + -- List mechanism information for parameters of Ent, which is subprogram, + -- subprogram type, or an entry or entry family. + + procedure List_Object_Info (Ent : Entity_Id); + -- List representation info for object Ent + + procedure List_Record_Info (Ent : Entity_Id); + -- List representation info for record type Ent + + procedure List_Type_Info (Ent : Entity_Id); + -- List type info for type Ent + + function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean; + -- Returns True if Val represents a variable value, and False if it + -- represents a value that is fixed at compile time. + + procedure Spaces (N : Natural); + -- Output given number of spaces + + procedure Write_Info_Line (S : String); + -- Routine to write a line to Repinfo output file. This routine is passed + -- as a special output procedure to Output.Set_Special_Output. Note that + -- Write_Info_Line is called with an EOL character at the end of each line, + -- as per the Output spec, but the internal call to the appropriate routine + -- in Osint requires that the end of line sequence be stripped off. + + procedure Write_Mechanism (M : Mechanism_Type); + -- Writes symbolic string for mechanism represented by M + + procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False); + -- Given a representation value, write it out. No_Uint values or values + -- dependent on discriminants are written as two question marks. If the + -- flag Paren is set, then the output is surrounded in parentheses if it is + -- other than a simple value. + + --------------------- + -- Back_End_Layout -- + --------------------- + + function Back_End_Layout return Boolean is + begin + -- We have back end layout if the back end has made any entries in the + -- table of GCC expressions, otherwise we have front end layout. + + return Rep_Table.Last > 0; + end Back_End_Layout; + + ---------------- + -- Blank_Line -- + ---------------- + + procedure Blank_Line is + begin + if Need_Blank_Line then + Write_Eol; + Need_Blank_Line := False; + end if; + end Blank_Line; + + ------------------------ + -- Create_Discrim_Ref -- + ------------------------ + + function Create_Discrim_Ref (Discr : Entity_Id) return Node_Ref is + begin + return Create_Node + (Expr => Discrim_Val, + Op1 => Discriminant_Number (Discr)); + end Create_Discrim_Ref; + + --------------------------- + -- Create_Dynamic_SO_Ref -- + --------------------------- + + function Create_Dynamic_SO_Ref (E : Entity_Id) return Dynamic_SO_Ref is + begin + Dynamic_SO_Entity_Table.Append (E); + return UI_From_Int (-Dynamic_SO_Entity_Table.Last); + end Create_Dynamic_SO_Ref; + + ----------------- + -- Create_Node -- + ----------------- + + function Create_Node + (Expr : TCode; + Op1 : Node_Ref_Or_Val; + Op2 : Node_Ref_Or_Val := No_Uint; + Op3 : Node_Ref_Or_Val := No_Uint) return Node_Ref + is + begin + Rep_Table.Append ( + (Expr => Expr, + Op1 => Op1, + Op2 => Op2, + Op3 => Op3)); + return UI_From_Int (-Rep_Table.Last); + end Create_Node; + + --------------------------- + -- Get_Dynamic_SO_Entity -- + --------------------------- + + function Get_Dynamic_SO_Entity (U : Dynamic_SO_Ref) return Entity_Id is + begin + return Dynamic_SO_Entity_Table.Table (-UI_To_Int (U)); + end Get_Dynamic_SO_Entity; + + ----------------------- + -- Is_Dynamic_SO_Ref -- + ----------------------- + + function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean is + begin + return U < Uint_0; + end Is_Dynamic_SO_Ref; + + ---------------------- + -- Is_Static_SO_Ref -- + ---------------------- + + function Is_Static_SO_Ref (U : SO_Ref) return Boolean is + begin + return U >= Uint_0; + end Is_Static_SO_Ref; + + --------- + -- lgx -- + --------- + + procedure lgx (U : Node_Ref_Or_Val) is + begin + List_GCC_Expression (U); + Write_Eol; + end lgx; + + ---------------------- + -- List_Array_Info -- + ---------------------- + + procedure List_Array_Info (Ent : Entity_Id) is + begin + List_Type_Info (Ent); + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Component_Size use "); + Write_Val (Component_Size (Ent)); + Write_Line (";"); + end List_Array_Info; + + ------------------- + -- List_Entities -- + ------------------- + + procedure List_Entities (Ent : Entity_Id) is + Body_E : Entity_Id; + E : Entity_Id; + + function Find_Declaration (E : Entity_Id) return Node_Id; + -- Utility to retrieve declaration node for entity in the + -- case of package bodies and subprograms. + + ---------------------- + -- Find_Declaration -- + ---------------------- + + function Find_Declaration (E : Entity_Id) return Node_Id is + Decl : Node_Id; + + begin + Decl := Parent (E); + while Present (Decl) + and then Nkind (Decl) /= N_Package_Body + and then Nkind (Decl) /= N_Subprogram_Declaration + and then Nkind (Decl) /= N_Subprogram_Body + loop + Decl := Parent (Decl); + end loop; + + return Decl; + end Find_Declaration; + + -- Start of processing for List_Entities + + begin + -- List entity if we have one, and it is not a renaming declaration. + -- For renamings, we don't get proper information, and really it makes + -- sense to restrict the output to the renamed entity. + + if Present (Ent) + and then Nkind (Declaration_Node (Ent)) not in N_Renaming_Declaration + then + -- If entity is a subprogram and we are listing mechanisms, + -- then we need to list mechanisms for this entity. + + if List_Representation_Info_Mechanisms + and then (Is_Subprogram (Ent) + or else Ekind (Ent) = E_Entry + or else Ekind (Ent) = E_Entry_Family) + then + Need_Blank_Line := True; + List_Mechanisms (Ent); + end if; + + E := First_Entity (Ent); + while Present (E) loop + Need_Blank_Line := True; + + -- We list entities that come from source (excluding private or + -- incomplete types or deferred constants, where we will list the + -- info for the full view). If debug flag A is set, then all + -- entities are listed + + if (Comes_From_Source (E) + and then not Is_Incomplete_Or_Private_Type (E) + and then not (Ekind (E) = E_Constant + and then Present (Full_View (E)))) + or else Debug_Flag_AA + then + if Is_Subprogram (E) + or else + Ekind (E) = E_Entry + or else + Ekind (E) = E_Entry_Family + or else + Ekind (E) = E_Subprogram_Type + then + if List_Representation_Info_Mechanisms then + List_Mechanisms (E); + end if; + + elsif Is_Record_Type (E) then + if List_Representation_Info >= 1 then + List_Record_Info (E); + end if; + + elsif Is_Array_Type (E) then + if List_Representation_Info >= 1 then + List_Array_Info (E); + end if; + + elsif Is_Type (E) then + if List_Representation_Info >= 2 then + List_Type_Info (E); + end if; + + elsif Ekind (E) = E_Variable + or else + Ekind (E) = E_Constant + or else + Ekind (E) = E_Loop_Parameter + or else + Is_Formal (E) + then + if List_Representation_Info >= 2 then + List_Object_Info (E); + end if; + end if; + + -- Recurse into nested package, but not if they are package + -- renamings (in particular renamings of the enclosing package, + -- as for some Java bindings and for generic instances). + + if Ekind (E) = E_Package then + if No (Renamed_Object (E)) then + List_Entities (E); + end if; + + -- Recurse into bodies + + elsif Ekind (E) = E_Protected_Type + or else + Ekind (E) = E_Task_Type + or else + Ekind (E) = E_Subprogram_Body + or else + Ekind (E) = E_Package_Body + or else + Ekind (E) = E_Task_Body + or else + Ekind (E) = E_Protected_Body + then + List_Entities (E); + + -- Recurse into blocks + + elsif Ekind (E) = E_Block then + List_Entities (E); + end if; + end if; + + E := Next_Entity (E); + end loop; + + -- For a package body, the entities of the visible subprograms are + -- declared in the corresponding spec. Iterate over its entities in + -- order to handle properly the subprogram bodies. Skip bodies in + -- subunits, which are listed independently. + + if Ekind (Ent) = E_Package_Body + and then Present (Corresponding_Spec (Find_Declaration (Ent))) + then + E := First_Entity (Corresponding_Spec (Find_Declaration (Ent))); + + while Present (E) loop + if Is_Subprogram (E) + and then + Nkind (Find_Declaration (E)) = N_Subprogram_Declaration + then + Body_E := Corresponding_Body (Find_Declaration (E)); + + if Present (Body_E) + and then + Nkind (Parent (Find_Declaration (Body_E))) /= N_Subunit + then + List_Entities (Body_E); + end if; + end if; + + Next_Entity (E); + end loop; + end if; + end if; + end List_Entities; + + ------------------------- + -- List_GCC_Expression -- + ------------------------- + + procedure List_GCC_Expression (U : Node_Ref_Or_Val) is + + procedure Print_Expr (Val : Node_Ref_Or_Val); + -- Internal recursive procedure to print expression + + ---------------- + -- Print_Expr -- + ---------------- + + procedure Print_Expr (Val : Node_Ref_Or_Val) is + begin + if Val >= 0 then + UI_Write (Val, Decimal); + + else + declare + Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val)); + + procedure Binop (S : String); + -- Output text for binary operator with S being operator name + + ----------- + -- Binop -- + ----------- + + procedure Binop (S : String) is + begin + Write_Char ('('); + Print_Expr (Node.Op1); + Write_Str (S); + Print_Expr (Node.Op2); + Write_Char (')'); + end Binop; + + -- Start of processing for Print_Expr + + begin + case Node.Expr is + when Cond_Expr => + Write_Str ("(if "); + Print_Expr (Node.Op1); + Write_Str (" then "); + Print_Expr (Node.Op2); + Write_Str (" else "); + Print_Expr (Node.Op3); + Write_Str (" end)"); + + when Plus_Expr => + Binop (" + "); + + when Minus_Expr => + Binop (" - "); + + when Mult_Expr => + Binop (" * "); + + when Trunc_Div_Expr => + Binop (" /t "); + + when Ceil_Div_Expr => + Binop (" /c "); + + when Floor_Div_Expr => + Binop (" /f "); + + when Trunc_Mod_Expr => + Binop (" modt "); + + when Floor_Mod_Expr => + Binop (" modf "); + + when Ceil_Mod_Expr => + Binop (" modc "); + + when Exact_Div_Expr => + Binop (" /e "); + + when Negate_Expr => + Write_Char ('-'); + Print_Expr (Node.Op1); + + when Min_Expr => + Binop (" min "); + + when Max_Expr => + Binop (" max "); + + when Abs_Expr => + Write_Str ("abs "); + Print_Expr (Node.Op1); + + when Truth_Andif_Expr => + Binop (" and if "); + + when Truth_Orif_Expr => + Binop (" or if "); + + when Truth_And_Expr => + Binop (" and "); + + when Truth_Or_Expr => + Binop (" or "); + + when Truth_Xor_Expr => + Binop (" xor "); + + when Truth_Not_Expr => + Write_Str ("not "); + Print_Expr (Node.Op1); + + when Bit_And_Expr => + Binop (" & "); + + when Lt_Expr => + Binop (" < "); + + when Le_Expr => + Binop (" <= "); + + when Gt_Expr => + Binop (" > "); + + when Ge_Expr => + Binop (" >= "); + + when Eq_Expr => + Binop (" == "); + + when Ne_Expr => + Binop (" != "); + + when Discrim_Val => + Write_Char ('#'); + UI_Write (Node.Op1); + + end case; + end; + end if; + end Print_Expr; + + -- Start of processing for List_GCC_Expression + + begin + if U = No_Uint then + Write_Str ("??"); + else + Print_Expr (U); + end if; + end List_GCC_Expression; + + --------------------- + -- List_Mechanisms -- + --------------------- + + procedure List_Mechanisms (Ent : Entity_Id) is + Plen : Natural; + Form : Entity_Id; + + begin + Blank_Line; + + case Ekind (Ent) is + when E_Function => + Write_Str ("function "); + + when E_Operator => + Write_Str ("operator "); + + when E_Procedure => + Write_Str ("procedure "); + + when E_Subprogram_Type => + Write_Str ("type "); + + when E_Entry | E_Entry_Family => + Write_Str ("entry "); + + when others => + raise Program_Error; + end case; + + Get_Unqualified_Decoded_Name_String (Chars (Ent)); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Str (" declared at "); + Write_Location (Sloc (Ent)); + Write_Eol; + + Write_Str (" convention : "); + + case Convention (Ent) is + when Convention_Ada => Write_Line ("Ada"); + when Convention_Intrinsic => Write_Line ("InLineinsic"); + when Convention_Entry => Write_Line ("Entry"); + when Convention_Protected => Write_Line ("Protected"); + when Convention_Assembler => Write_Line ("Assembler"); + when Convention_C => Write_Line ("C"); + when Convention_CIL => Write_Line ("CIL"); + when Convention_COBOL => Write_Line ("COBOL"); + when Convention_CPP => Write_Line ("C++"); + when Convention_Fortran => Write_Line ("Fortran"); + when Convention_Java => Write_Line ("Java"); + when Convention_Stdcall => Write_Line ("Stdcall"); + when Convention_Stubbed => Write_Line ("Stubbed"); + end case; + + -- Find max length of formal name + + Plen := 0; + Form := First_Formal (Ent); + while Present (Form) loop + Get_Unqualified_Decoded_Name_String (Chars (Form)); + + if Name_Len > Plen then + Plen := Name_Len; + end if; + + Next_Formal (Form); + end loop; + + -- Output formals and mechanisms + + Form := First_Formal (Ent); + while Present (Form) loop + Get_Unqualified_Decoded_Name_String (Chars (Form)); + + while Name_Len <= Plen loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ' '; + end loop; + + Write_Str (" "); + Write_Str (Name_Buffer (1 .. Plen + 1)); + Write_Str (": passed by "); + + Write_Mechanism (Mechanism (Form)); + Write_Eol; + Next_Formal (Form); + end loop; + + if Etype (Ent) /= Standard_Void_Type then + Write_Str (" returns by "); + Write_Mechanism (Mechanism (Ent)); + Write_Eol; + end if; + end List_Mechanisms; + + --------------- + -- List_Name -- + --------------- + + procedure List_Name (Ent : Entity_Id) is + begin + if not Is_Compilation_Unit (Scope (Ent)) then + List_Name (Scope (Ent)); + Write_Char ('.'); + end if; + + Get_Unqualified_Decoded_Name_String (Chars (Ent)); + Set_Casing (Unit_Casing); + Write_Str (Name_Buffer (1 .. Name_Len)); + end List_Name; + + --------------------- + -- List_Object_Info -- + --------------------- + + procedure List_Object_Info (Ent : Entity_Id) is + begin + Blank_Line; + + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Size use "); + Write_Val (Esize (Ent)); + Write_Line (";"); + + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Alignment use "); + Write_Val (Alignment (Ent)); + Write_Line (";"); + end List_Object_Info; + + ---------------------- + -- List_Record_Info -- + ---------------------- + + procedure List_Record_Info (Ent : Entity_Id) is + Comp : Entity_Id; + Cfbit : Uint; + Sunit : Uint; + + Max_Name_Length : Natural; + Max_Suni_Length : Natural; + + begin + Blank_Line; + List_Type_Info (Ent); + + Write_Str ("for "); + List_Name (Ent); + Write_Line (" use record"); + + -- First loop finds out max line length and max starting position + -- length, for the purpose of lining things up nicely. + + Max_Name_Length := 0; + Max_Suni_Length := 0; + + Comp := First_Component_Or_Discriminant (Ent); + while Present (Comp) loop + Get_Decoded_Name_String (Chars (Comp)); + Max_Name_Length := Natural'Max (Max_Name_Length, Name_Len); + + Cfbit := Component_Bit_Offset (Comp); + + if Rep_Not_Constant (Cfbit) then + UI_Image_Length := 2; + + else + -- Complete annotation in case not done + + Set_Normalized_Position (Comp, Cfbit / SSU); + Set_Normalized_First_Bit (Comp, Cfbit mod SSU); + + Sunit := Cfbit / SSU; + UI_Image (Sunit); + end if; + + -- If the record is not packed, then we know that all fields whose + -- position is not specified have a starting normalized bit position + -- of zero. + + if Unknown_Normalized_First_Bit (Comp) + and then not Is_Packed (Ent) + then + Set_Normalized_First_Bit (Comp, Uint_0); + end if; + + Max_Suni_Length := + Natural'Max (Max_Suni_Length, UI_Image_Length); + + Next_Component_Or_Discriminant (Comp); + end loop; + + -- Second loop does actual output based on those values + + Comp := First_Component_Or_Discriminant (Ent); + while Present (Comp) loop + declare + Esiz : constant Uint := Esize (Comp); + Bofs : constant Uint := Component_Bit_Offset (Comp); + Npos : constant Uint := Normalized_Position (Comp); + Fbit : constant Uint := Normalized_First_Bit (Comp); + Lbit : Uint; + + begin + Write_Str (" "); + Get_Decoded_Name_String (Chars (Comp)); + Set_Casing (Unit_Casing); + Write_Str (Name_Buffer (1 .. Name_Len)); + + for J in 1 .. Max_Name_Length - Name_Len loop + Write_Char (' '); + end loop; + + Write_Str (" at "); + + if Known_Static_Normalized_Position (Comp) then + UI_Image (Npos); + Spaces (Max_Suni_Length - UI_Image_Length); + Write_Str (UI_Image_Buffer (1 .. UI_Image_Length)); + + elsif Known_Component_Bit_Offset (Comp) + and then List_Representation_Info = 3 + then + Spaces (Max_Suni_Length - 2); + Write_Str ("bit offset"); + Write_Val (Bofs, Paren => True); + Write_Str (" size in bits = "); + Write_Val (Esiz, Paren => True); + Write_Eol; + goto Continue; + + elsif Known_Normalized_Position (Comp) + and then List_Representation_Info = 3 + then + Spaces (Max_Suni_Length - 2); + Write_Val (Npos); + + else + -- For the packed case, we don't know the bit positions if we + -- don't know the starting position! + + if Is_Packed (Ent) then + Write_Line ("?? range ? .. ??;"); + goto Continue; + + -- Otherwise we can continue + + else + Write_Str ("??"); + end if; + end if; + + Write_Str (" range "); + UI_Write (Fbit); + Write_Str (" .. "); + + -- Allowing Uint_0 here is a kludge, really this should be a + -- fine Esize value but currently it means unknown, except that + -- we know after gigi has back annotated that a size of zero is + -- real, since otherwise gigi back annotates using No_Uint as + -- the value to indicate unknown). + + if (Esize (Comp) = Uint_0 or else Known_Static_Esize (Comp)) + and then Known_Static_Normalized_First_Bit (Comp) + then + Lbit := Fbit + Esiz - 1; + + if Lbit < 10 then + Write_Char (' '); + end if; + + UI_Write (Lbit); + + -- The test for Esize (Comp) not being Uint_0 here is a kludge. + -- Officially a value of zero for Esize means unknown, but here + -- we use the fact that we know that gigi annotates Esize with + -- No_Uint, not Uint_0. Really everyone should use No_Uint??? + + elsif List_Representation_Info < 3 + or else (Esize (Comp) /= Uint_0 and then Unknown_Esize (Comp)) + then + Write_Str ("??"); + + -- List_Representation >= 3 and Known_Esize (Comp) + + else + Write_Val (Esiz, Paren => True); + + -- If in front end layout mode, then dynamic size is stored + -- in storage units, so renormalize for output + + if not Back_End_Layout then + Write_Str (" * "); + Write_Int (SSU); + end if; + + -- Add appropriate first bit offset + + if Fbit = 0 then + Write_Str (" - 1"); + + elsif Fbit = 1 then + null; + + else + Write_Str (" + "); + Write_Int (UI_To_Int (Fbit) - 1); + end if; + end if; + + Write_Line (";"); + end; + + <> + Next_Component_Or_Discriminant (Comp); + end loop; + + Write_Line ("end record;"); + end List_Record_Info; + + ------------------- + -- List_Rep_Info -- + ------------------- + + procedure List_Rep_Info is + Col : Nat; + + begin + if List_Representation_Info /= 0 + or else List_Representation_Info_Mechanisms + then + for U in Main_Unit .. Last_Unit loop + if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then + + -- Normal case, list to standard output + + if not List_Representation_Info_To_File then + Unit_Casing := Identifier_Casing (Source_Index (U)); + Write_Eol; + Write_Str ("Representation information for unit "); + Write_Unit_Name (Unit_Name (U)); + Col := Column; + Write_Eol; + + for J in 1 .. Col - 1 loop + Write_Char ('-'); + end loop; + + Write_Eol; + List_Entities (Cunit_Entity (U)); + + -- List representation information to file + + else + Create_Repinfo_File_Access.all + (Get_Name_String (File_Name (Source_Index (U)))); + Set_Special_Output (Write_Info_Line'Access); + List_Entities (Cunit_Entity (U)); + Set_Special_Output (null); + Close_Repinfo_File_Access.all; + end if; + end if; + end loop; + end if; + end List_Rep_Info; + + -------------------- + -- List_Type_Info -- + -------------------- + + procedure List_Type_Info (Ent : Entity_Id) is + begin + Blank_Line; + + -- Do not list size info for unconstrained arrays, not meaningful + + if Is_Array_Type (Ent) and then not Is_Constrained (Ent) then + null; + + else + -- If Esize and RM_Size are the same and known, list as Size. This + -- is a common case, which we may as well list in simple form. + + if Esize (Ent) = RM_Size (Ent) then + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Size use "); + Write_Val (Esize (Ent)); + Write_Line (";"); + + -- For now, temporary case, to be removed when gigi properly back + -- annotates RM_Size, if RM_Size is not set, then list Esize as Size. + -- This avoids odd Object_Size output till we fix things??? + + elsif Unknown_RM_Size (Ent) then + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Size use "); + Write_Val (Esize (Ent)); + Write_Line (";"); + + -- Otherwise list size values separately if they are set + + else + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Object_Size use "); + Write_Val (Esize (Ent)); + Write_Line (";"); + + -- Note on following check: The RM_Size of a discrete type can + -- legitimately be set to zero, so a special check is needed. + + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Value_Size use "); + Write_Val (RM_Size (Ent)); + Write_Line (";"); + end if; + end if; + + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Alignment use "); + Write_Val (Alignment (Ent)); + Write_Line (";"); + + -- Special stuff for fixed-point + + if Is_Fixed_Point_Type (Ent) then + + -- Write small (always a static constant) + + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Small use "); + UR_Write (Small_Value (Ent)); + Write_Line (";"); + + -- Write range if static + + declare + R : constant Node_Id := Scalar_Range (Ent); + + begin + if Nkind (Low_Bound (R)) = N_Real_Literal + and then + Nkind (High_Bound (R)) = N_Real_Literal + then + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Range use "); + UR_Write (Realval (Low_Bound (R))); + Write_Str (" .. "); + UR_Write (Realval (High_Bound (R))); + Write_Line (";"); + end if; + end; + end if; + end List_Type_Info; + + ---------------------- + -- Rep_Not_Constant -- + ---------------------- + + function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean is + begin + if Val = No_Uint or else Val < 0 then + return True; + else + return False; + end if; + end Rep_Not_Constant; + + --------------- + -- Rep_Value -- + --------------- + + function Rep_Value + (Val : Node_Ref_Or_Val; + D : Discrim_List) return Uint + is + function B (Val : Boolean) return Uint; + -- Returns Uint_0 for False, Uint_1 for True + + function T (Val : Node_Ref_Or_Val) return Boolean; + -- Returns True for 0, False for any non-zero (i.e. True) + + function V (Val : Node_Ref_Or_Val) return Uint; + -- Internal recursive routine to evaluate tree + + function W (Val : Uint) return Word; + -- Convert Val to Word, assuming Val is always in the Int range. This + -- is a helper function for the evaluation of bitwise expressions like + -- Bit_And_Expr, for which there is no direct support in uintp. Uint + -- values out of the Int range are expected to be seen in such + -- expressions only with overflowing byte sizes around, introducing + -- inherent unreliabilities in computations anyway. + + ------- + -- B -- + ------- + + function B (Val : Boolean) return Uint is + begin + if Val then + return Uint_1; + else + return Uint_0; + end if; + end B; + + ------- + -- T -- + ------- + + function T (Val : Node_Ref_Or_Val) return Boolean is + begin + if V (Val) = 0 then + return False; + else + return True; + end if; + end T; + + ------- + -- V -- + ------- + + function V (Val : Node_Ref_Or_Val) return Uint is + L, R, Q : Uint; + + begin + if Val >= 0 then + return Val; + + else + declare + Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val)); + + begin + case Node.Expr is + when Cond_Expr => + if T (Node.Op1) then + return V (Node.Op2); + else + return V (Node.Op3); + end if; + + when Plus_Expr => + return V (Node.Op1) + V (Node.Op2); + + when Minus_Expr => + return V (Node.Op1) - V (Node.Op2); + + when Mult_Expr => + return V (Node.Op1) * V (Node.Op2); + + when Trunc_Div_Expr => + return V (Node.Op1) / V (Node.Op2); + + when Ceil_Div_Expr => + return + UR_Ceiling + (V (Node.Op1) / UR_From_Uint (V (Node.Op2))); + + when Floor_Div_Expr => + return + UR_Floor + (V (Node.Op1) / UR_From_Uint (V (Node.Op2))); + + when Trunc_Mod_Expr => + return V (Node.Op1) rem V (Node.Op2); + + when Floor_Mod_Expr => + return V (Node.Op1) mod V (Node.Op2); + + when Ceil_Mod_Expr => + L := V (Node.Op1); + R := V (Node.Op2); + Q := UR_Ceiling (L / UR_From_Uint (R)); + return L - R * Q; + + when Exact_Div_Expr => + return V (Node.Op1) / V (Node.Op2); + + when Negate_Expr => + return -V (Node.Op1); + + when Min_Expr => + return UI_Min (V (Node.Op1), V (Node.Op2)); + + when Max_Expr => + return UI_Max (V (Node.Op1), V (Node.Op2)); + + when Abs_Expr => + return UI_Abs (V (Node.Op1)); + + when Truth_Andif_Expr => + return B (T (Node.Op1) and then T (Node.Op2)); + + when Truth_Orif_Expr => + return B (T (Node.Op1) or else T (Node.Op2)); + + when Truth_And_Expr => + return B (T (Node.Op1) and then T (Node.Op2)); + + when Truth_Or_Expr => + return B (T (Node.Op1) or else T (Node.Op2)); + + when Truth_Xor_Expr => + return B (T (Node.Op1) xor T (Node.Op2)); + + when Truth_Not_Expr => + return B (not T (Node.Op1)); + + when Bit_And_Expr => + L := V (Node.Op1); + R := V (Node.Op2); + return UI_From_Int (Int (W (L) and W (R))); + + when Lt_Expr => + return B (V (Node.Op1) < V (Node.Op2)); + + when Le_Expr => + return B (V (Node.Op1) <= V (Node.Op2)); + + when Gt_Expr => + return B (V (Node.Op1) > V (Node.Op2)); + + when Ge_Expr => + return B (V (Node.Op1) >= V (Node.Op2)); + + when Eq_Expr => + return B (V (Node.Op1) = V (Node.Op2)); + + when Ne_Expr => + return B (V (Node.Op1) /= V (Node.Op2)); + + when Discrim_Val => + declare + Sub : constant Int := UI_To_Int (Node.Op1); + + begin + pragma Assert (Sub in D'Range); + return D (Sub); + end; + + end case; + end; + end if; + end V; + + ------- + -- W -- + ------- + + -- We use an unchecked conversion to map Int values to their Word + -- bitwise equivalent, which we could not achieve with a normal type + -- conversion for negative Ints. We want bitwise equivalents because W + -- is used as a helper for bit operators like Bit_And_Expr, and can be + -- called for negative Ints in the context of aligning expressions like + -- X+Align & -Align. + + function W (Val : Uint) return Word is + function To_Word is new Ada.Unchecked_Conversion (Int, Word); + begin + return To_Word (UI_To_Int (Val)); + end W; + + -- Start of processing for Rep_Value + + begin + if Val = No_Uint then + return No_Uint; + + else + return V (Val); + end if; + end Rep_Value; + + ------------ + -- Spaces -- + ------------ + + procedure Spaces (N : Natural) is + begin + for J in 1 .. N loop + Write_Char (' '); + end loop; + end Spaces; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + begin + Rep_Table.Tree_Read; + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + begin + Rep_Table.Tree_Write; + end Tree_Write; + + --------------------- + -- Write_Info_Line -- + --------------------- + + procedure Write_Info_Line (S : String) is + begin + Write_Repinfo_Line_Access.all (S (S'First .. S'Last - 1)); + end Write_Info_Line; + + --------------------- + -- Write_Mechanism -- + --------------------- + + procedure Write_Mechanism (M : Mechanism_Type) is + begin + case M is + when 0 => + Write_Str ("default"); + + when -1 => + Write_Str ("copy"); + + when -2 => + Write_Str ("reference"); + + when -3 => + Write_Str ("descriptor"); + + when -4 => + Write_Str ("descriptor (UBS)"); + + when -5 => + Write_Str ("descriptor (UBSB)"); + + when -6 => + Write_Str ("descriptor (UBA)"); + + when -7 => + Write_Str ("descriptor (S)"); + + when -8 => + Write_Str ("descriptor (SB)"); + + when -9 => + Write_Str ("descriptor (A)"); + + when -10 => + Write_Str ("descriptor (NCA)"); + + when others => + raise Program_Error; + end case; + end Write_Mechanism; + + --------------- + -- Write_Val -- + --------------- + + procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False) is + begin + if Rep_Not_Constant (Val) then + if List_Representation_Info < 3 or else Val = No_Uint then + Write_Str ("??"); + + else + if Back_End_Layout then + Write_Char (' '); + + if Paren then + Write_Char ('('); + List_GCC_Expression (Val); + Write_Char (')'); + else + List_GCC_Expression (Val); + end if; + + Write_Char (' '); + + else + if Paren then + Write_Char ('('); + Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val))); + Write_Char (')'); + else + Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val))); + end if; + end if; + end if; + + else + UI_Write (Val); + end if; + end Write_Val; + +end Repinfo; diff --git a/gcc/ada/repinfo.ads b/gcc/ada/repinfo.ads new file mode 100644 index 000000000..652769924 --- /dev/null +++ b/gcc/ada/repinfo.ads @@ -0,0 +1,311 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- R E P I N F O -- +-- -- +-- 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 routines to handle back annotation of the +-- tree to fill in representation information, and also the routine used +-- by -gnatR to print this information. This unit is used both in the +-- compiler and in ASIS (it is used in ASIS as part of the implementation +-- of the data decomposition annex). + +with Types; use Types; +with Uintp; use Uintp; + +package Repinfo is + + -------------------------------- + -- Representation Information -- + -------------------------------- + + -- The representation information of interest here is size and + -- component information for arrays and records. For primitive + -- types, the front end computes the Esize and RM_Size fields of + -- the corresponding entities as constant non-negative integers, + -- and the Uint values are stored directly in these fields. + + -- For composite types, there are three cases: + + -- 1. In some cases the front end knows the values statically, + -- for example in the case where representation clauses or + -- pragmas specify the values. + + -- 2. If Backend_Layout is True, then the backend is responsible + -- for layout of all types and objects not laid out by the + -- front end. This includes all dynamic values, and also + -- static values (e.g. record sizes) when not set by the + -- front end. + + -- 3. If Backend_Layout is False, then the front end lays out + -- all data, according to target dependent size and alignment + -- information, creating dynamic inlinable functions where + -- needed in the case of sizes not known till runtime. + + ----------------------------- + -- Back-Annotation by Gigi -- + ----------------------------- + + -- The following interface is used by gigi if Backend_Layout is True + + -- As part of the processing in gigi, the types are laid out and + -- appropriate values computed for the sizes and component positions + -- and sizes of records and arrays. + + -- The back-annotation circuit in gigi is responsible for updating the + -- relevant fields in the tree to reflect these computations, as follows: + + -- For E_Array_Type entities, the Component_Size field + + -- For all record and array types and subtypes, the Esize field, + -- which contains the Size (more accurately the Object_SIze) value + -- for the type or subtype. + + -- For E_Component and E_Discriminant entities, the Esize (size + -- of component) and Component_Bit_Offset fields. Note that gigi + -- does not (yet ???) back annotate Normalized_Position/First_Bit. + + -- There are three cases to consider: + + -- 1. The value is constant. In this case, the back annotation works + -- by simply storing the non-negative universal integer value in + -- the appropriate field corresponding to this constant size. + + -- 2. The value depends on variables other than discriminants of the + -- current record. In this case, the value is not known, even if + -- the complete data of the record is available, and gigi marks + -- this situation by storing the special value No_Uint. + + -- 3. The value depends on the discriminant values for the current + -- record. In this case, gigi back annotates the field with a + -- representation of the expression for computing the value in + -- terms of the discriminants. A negative Uint value is used to + -- represent the value of such an expression, as explained in + -- the following section. + + -- GCC expressions are represented with a Uint value that is negative. + -- See the body of this package for details on the representation used. + + -- One other case in which gigi back annotates GCC expressions is in + -- the Present_Expr field of an N_Variant node. This expression which + -- will always depend on discriminants, and hence always be represented + -- as a negative Uint value, provides an expression which, when evaluated + -- with a given set of discriminant values, indicates whether the variant + -- is present for that set of values (result is True, i.e. non-zero) or + -- not present (result is False, i.e. zero). + + subtype Node_Ref is Uint; + -- Subtype used for negative Uint values used to represent nodes + + subtype Node_Ref_Or_Val is Uint; + -- Subtype used for values that can either be a Node_Ref (negative) + -- or a value (non-negative) + + type TCode is range 0 .. 28; + -- Type used on Ada side to represent DEFTREECODE values defined in + -- tree.def. Only a subset of these tree codes can actually appear. + -- The names are the names from tree.def in Ada casing. + + -- name code description operands + + Cond_Expr : constant TCode := 1; -- conditional 3 + Plus_Expr : constant TCode := 2; -- addition 2 + Minus_Expr : constant TCode := 3; -- subtraction 2 + Mult_Expr : constant TCode := 4; -- multiplication 2 + Trunc_Div_Expr : constant TCode := 5; -- truncating division 2 + Ceil_Div_Expr : constant TCode := 6; -- division rounding up 2 + Floor_Div_Expr : constant TCode := 7; -- division rounding down 2 + Trunc_Mod_Expr : constant TCode := 8; -- mod for trunc_div 2 + Ceil_Mod_Expr : constant TCode := 9; -- mod for ceil_div 2 + Floor_Mod_Expr : constant TCode := 10; -- mod for floor_div 2 + Exact_Div_Expr : constant TCode := 11; -- exact div 2 + Negate_Expr : constant TCode := 12; -- negation 1 + Min_Expr : constant TCode := 13; -- minimum 2 + Max_Expr : constant TCode := 14; -- maximum 2 + Abs_Expr : constant TCode := 15; -- absolute value 1 + Truth_Andif_Expr : constant TCode := 16; -- Boolean and then 2 + Truth_Orif_Expr : constant TCode := 17; -- Boolean or else 2 + Truth_And_Expr : constant TCode := 18; -- Boolean and 2 + Truth_Or_Expr : constant TCode := 19; -- Boolean or 2 + Truth_Xor_Expr : constant TCode := 20; -- Boolean xor 2 + Truth_Not_Expr : constant TCode := 21; -- Boolean not 1 + Lt_Expr : constant TCode := 22; -- comparison < 2 + Le_Expr : constant TCode := 23; -- comparison <= 2 + Gt_Expr : constant TCode := 24; -- comparison > 2 + Ge_Expr : constant TCode := 25; -- comparison >= 2 + Eq_Expr : constant TCode := 26; -- comparison = 2 + Ne_Expr : constant TCode := 27; -- comparison /= 2 + Bit_And_Expr : constant TCode := 28; -- Binary and 2 + + -- The following entry is used to represent a discriminant value in + -- the tree. It has a special tree code that does not correspond + -- directly to a gcc node. The single operand is the number of the + -- discriminant in the record (1 = first discriminant). + + Discrim_Val : constant TCode := 0; -- discriminant value 1 + + ------------------------ + -- The gigi Interface -- + ------------------------ + + -- The following declarations are for use by gigi for back annotation + + function Create_Node + (Expr : TCode; + Op1 : Node_Ref_Or_Val; + Op2 : Node_Ref_Or_Val := No_Uint; + Op3 : Node_Ref_Or_Val := No_Uint) return Node_Ref; + -- Creates a node using the tree code defined by Expr and from one to three + -- operands as required (unused operands set as shown to No_Uint) Note that + -- this call can be used to create a discriminant reference by using (Expr + -- => Discrim_Val, Op1 => discriminant_number). + + function Create_Discrim_Ref (Discr : Entity_Id) return Node_Ref; + -- Creates a reference to the discriminant whose entity is Discr + + -------------------------------------------------------- + -- Front-End Interface for Dynamic Size/Offset Values -- + -------------------------------------------------------- + + -- If Backend_Layout is False, then the front-end deals with all + -- dynamic size and offset fields. There are two cases: + + -- 1. The value can be computed at the time of type freezing, and + -- is stored in a run-time constant. In this case, the field + -- contains a reference to this entity. In the case of sizes + -- the value stored is the size in storage units, since dynamic + -- sizes are always a multiple of storage units. + + -- 2. The size/offset depends on the value of discriminants at + -- run-time. In this case, the front end builds a function to + -- compute the value. This function has a single parameter + -- which is the discriminated record object in question. Any + -- references to discriminant values are simply references to + -- the appropriate discriminant in this single argument, and + -- to compute the required size/offset value at run time, the + -- code generator simply constructs a call to the function + -- with the appropriate argument. The size/offset field in + -- this case contains a reference to the function entity. + -- Note that as for case 1, if such a function is used to + -- return a size, then the size in storage units is returned, + -- not the size in bits. + + -- The interface here allows these created entities to be referenced + -- using negative Unit values, so that they can be stored in the + -- appropriate size and offset fields in the tree. + + -- In the case of components, if the location of the component is static, + -- then all four fields (Component_Bit_Offset, Normalized_Position, Esize, + -- and Normalized_First_Bit) are set to appropriate values. In the case of + -- a non-static component location, Component_Bit_Offset is not used and + -- is left set to Unknown. Normalized_Position and Normalized_First_Bit + -- are set appropriately. + + subtype SO_Ref is Uint; + -- Type used to represent a Uint value that represents a static or + -- dynamic size/offset value (non-negative if static, negative if + -- the size value is dynamic). + + subtype Dynamic_SO_Ref is Uint; + -- Type used to represent a negative Uint value used to store + -- a dynamic size/offset value. + + function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean; + pragma Inline (Is_Dynamic_SO_Ref); + -- Given a SO_Ref (Uint) value, returns True iff the SO_Ref value + -- represents a dynamic Size/Offset value (i.e. it is negative). + + function Is_Static_SO_Ref (U : SO_Ref) return Boolean; + pragma Inline (Is_Static_SO_Ref); + -- Given a SO_Ref (Uint) value, returns True iff the SO_Ref value + -- represents a static Size/Offset value (i.e. it is non-negative). + + function Create_Dynamic_SO_Ref (E : Entity_Id) return Dynamic_SO_Ref; + -- Given the Entity_Id for a constant (case 1), the Node_Id for an + -- expression (case 2), or the Entity_Id for a function (case 3), + -- this function returns a (negative) Uint value that can be used + -- to retrieve the entity or expression for later use. + + function Get_Dynamic_SO_Entity (U : Dynamic_SO_Ref) return Entity_Id; + -- Retrieve the Node_Id or Entity_Id stored by a previous call to + -- Create_Dynamic_SO_Ref. The approach is that the front end makes + -- the necessary Create_Dynamic_SO_Ref calls to associate the node + -- and entity id values and the back end makes Get_Dynamic_SO_Ref + -- calls to retrieve them. + + -------------------- + -- ASIS_Interface -- + -------------------- + + type Discrim_List is array (Pos range <>) of Uint; + -- Type used to represent list of discriminant values + + function Rep_Value + (Val : Node_Ref_Or_Val; + D : Discrim_List) return Uint; + -- Given the contents of a First_Bit_Position or Esize field containing + -- a node reference (i.e. a negative Uint value) and D, the list of + -- discriminant values, returns the interpreted value of this field. + -- For convenience, Rep_Value will take a non-negative Uint value + -- as an argument value, and return it unmodified. A No_Uint value is + -- also returned unmodified. + + procedure Tree_Read; + -- Initializes internal tables from current tree file using the relevant + -- Table.Tree_Read routines. + + ------------------------ + -- Compiler Interface -- + ------------------------ + + procedure List_Rep_Info; + -- Procedure to list representation information + + procedure Tree_Write; + -- Writes out internal tables to current tree file using the relevant + -- Table.Tree_Write routines. + + -------------------------- + -- Debugging Procedures -- + -------------------------- + + procedure List_GCC_Expression (U : Node_Ref_Or_Val); + -- Prints out given expression in symbolic form. Constants are listed + -- in decimal numeric form, Discriminants are listed with a # followed + -- by the discriminant number, and operators are output in appropriate + -- symbolic form No_Uint displays as two question marks. The output is + -- on a single line but has no line return after it. This procedure is + -- useful only if operating in backend layout mode. + + procedure lgx (U : Node_Ref_Or_Val); + -- In backend layout mode, this is like List_GCC_Expression, but + -- includes a line return at the end. If operating in front end + -- layout mode, then the name of the entity for the size (either + -- a function of a variable) is listed followed by a line return. + +end Repinfo; diff --git a/gcc/ada/repinfo.h b/gcc/ada/repinfo.h new file mode 100644 index 000000000..668f520ff --- /dev/null +++ b/gcc/ada/repinfo.h @@ -0,0 +1,77 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * R E P I N F O * + * * + * C Header File * + * * + * 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 file corresponds to the Ada file repinfo.ads. */ + +typedef Uint Node_Ref; +typedef Uint Node_Ref_Or_Val; +typedef char TCode; + +/* These are the values of TCcode that correspond to tree codes in tree.def, + except for the first, which is how we encode discriminants. */ + +#define Discrim_Val 0 +#define Cond_Expr 1 +#define Plus_Expr 2 +#define Minus_Expr 3 +#define Mult_Expr 4 +#define Trunc_Div_Expr 5 +#define Ceil_Div_Expr 6 +#define Floor_Div_Expr 7 +#define Trunc_Mod_Expr 8 +#define Ceil_Mod_Expr 9 +#define Floor_Mod_Expr 10 +#define Exact_Div_Expr 11 +#define Negate_Expr 12 +#define Min_Expr 13 +#define Max_Expr 14 +#define Abs_Expr 15 +#define Truth_Andif_Expr 16 +#define Truth_Orif_Expr 17 +#define Truth_And_Expr 18 +#define Truth_Or_Expr 19 +#define Truth_Xor_Expr 20 +#define Truth_Not_Expr 21 +#define Lt_Expr 22 +#define Le_Expr 23 +#define Gt_Expr 24 +#define Ge_Expr 25 +#define Eq_Expr 26 +#define Ne_Expr 27 +#define Bit_And_Expr 28 + +/* Creates a node using the tree code defined by Expr and from 1-3 + operands as required (unused operands set as shown to No_Uint) Note + that this call can be used to create a discriminant reference by + using (Expr => Discrim_Val, Op1 => discriminant_number). */ +#define Create_Node repinfo__create_node +extern Node_Ref Create_Node (TCode, Node_Ref_Or_Val, + Node_Ref_Or_Val, Node_Ref_Or_Val); diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb new file mode 100644 index 000000000..755aabc15 --- /dev/null +++ b/gcc/ada/restrict.adb @@ -0,0 +1,994 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- R E S T R I C T -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Casing; use Casing; +with Einfo; use Einfo; +with Errout; use Errout; +with Debug; use Debug; +with Fname; use Fname; +with Fname.UF; use Fname.UF; +with Lib; use Lib; +with Opt; use Opt; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with Stand; use Stand; +with Uname; use Uname; + +package body Restrict is + + Restricted_Profile_Result : Boolean := False; + -- This switch memoizes the result of Restricted_Profile function + -- calls for improved efficiency. Its setting is valid only if + -- Restricted_Profile_Cached is True. Note that if this switch + -- is ever set True, it need never be turned off again. + + Restricted_Profile_Cached : Boolean := False; + -- This flag is set to True if the Restricted_Profile_Result + -- contains the correct cached result of Restricted_Profile calls. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Restriction_Msg (R : Restriction_Id; N : Node_Id); + -- Called if a violation of restriction R at node N is found. This routine + -- outputs the appropriate message or messages taking care of warning vs + -- real violation, serious vs non-serious, implicit vs explicit, the second + -- message giving the profile name if needed, and the location information. + + function Same_Unit (U1, U2 : Node_Id) return Boolean; + -- Returns True iff U1 and U2 represent the same library unit. Used for + -- handling of No_Dependence => Unit restriction case. + + function Suppress_Restriction_Message (N : Node_Id) return Boolean; + -- N is the node for a possible restriction violation message, but the + -- message is to be suppressed if this is an internal file and this file is + -- not the main unit. Returns True if message is to be suppressed. + + ------------------- + -- Abort_Allowed -- + ------------------- + + function Abort_Allowed return Boolean is + begin + if Restrictions.Set (No_Abort_Statements) + and then Restrictions.Set (Max_Asynchronous_Select_Nesting) + and then Restrictions.Value (Max_Asynchronous_Select_Nesting) = 0 + then + return False; + else + return True; + end if; + end Abort_Allowed; + + ------------------------- + -- Check_Compiler_Unit -- + ------------------------- + + procedure Check_Compiler_Unit (N : Node_Id) is + begin + if Is_Compiler_Unit (Get_Source_Unit (N)) then + Error_Msg_N ("use of construct not allowed in compiler", N); + end if; + end Check_Compiler_Unit; + + ------------------------------------ + -- Check_Elaboration_Code_Allowed -- + ------------------------------------ + + procedure Check_Elaboration_Code_Allowed (N : Node_Id) is + begin + Check_Restriction (No_Elaboration_Code, N); + end Check_Elaboration_Code_Allowed; + + ----------------------------------------- + -- Check_Implicit_Dynamic_Code_Allowed -- + ----------------------------------------- + + procedure Check_Implicit_Dynamic_Code_Allowed (N : Node_Id) is + begin + Check_Restriction (No_Implicit_Dynamic_Code, N); + end Check_Implicit_Dynamic_Code_Allowed; + + ---------------------------------- + -- Check_No_Implicit_Heap_Alloc -- + ---------------------------------- + + procedure Check_No_Implicit_Heap_Alloc (N : Node_Id) is + begin + Check_Restriction (No_Implicit_Heap_Allocations, N); + end Check_No_Implicit_Heap_Alloc; + + ----------------------------------- + -- Check_Obsolescent_2005_Entity -- + ----------------------------------- + + procedure Check_Obsolescent_2005_Entity (E : Entity_Id; N : Node_Id) is + function Chars_Is (E : Entity_Id; S : String) return Boolean; + -- Return True iff Chars (E) matches S (given in lower case) + + function Chars_Is (E : Entity_Id; S : String) return Boolean is + Nam : constant Name_Id := Chars (E); + begin + if Length_Of_Name (Nam) /= S'Length then + return False; + else + return Get_Name_String (Nam) = S; + end if; + end Chars_Is; + + -- Start of processing for Check_Obsolescent_2005_Entity + + begin + if Restriction_Check_Required (No_Obsolescent_Features) + and then Ada_Version >= Ada_2005 + and then Chars_Is (Scope (E), "handling") + and then Chars_Is (Scope (Scope (E)), "characters") + and then Chars_Is (Scope (Scope (Scope (E))), "ada") + and then Scope (Scope (Scope (Scope (E)))) = Standard_Standard + then + if Chars_Is (E, "is_character") or else + Chars_Is (E, "is_string") or else + Chars_Is (E, "to_character") or else + Chars_Is (E, "to_string") or else + Chars_Is (E, "to_wide_character") or else + Chars_Is (E, "to_wide_string") + then + Check_Restriction (No_Obsolescent_Features, N); + end if; + end if; + end Check_Obsolescent_2005_Entity; + + --------------------------- + -- Check_Restricted_Unit -- + --------------------------- + + procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id) is + begin + if Suppress_Restriction_Message (N) then + return; + + elsif Is_Spec_Name (U) then + declare + Fnam : constant File_Name_Type := + Get_File_Name (U, Subunit => False); + + begin + -- Get file name + + Get_Name_String (Fnam); + + -- Nothing to do if name not at least 5 characters long ending + -- in .ads or .adb extension, which we strip. + + if Name_Len < 5 + or else (Name_Buffer (Name_Len - 3 .. Name_Len) /= ".ads" + and then + Name_Buffer (Name_Len - 3 .. Name_Len) /= ".adb") + then + return; + end if; + + -- Strip extension and pad to eight characters + + Name_Len := Name_Len - 4; + Add_Str_To_Name_Buffer ((Name_Len + 1 .. 8 => ' ')); + + -- If predefined unit, check the list of restricted units + + if Is_Predefined_File_Name (Fnam) then + for J in Unit_Array'Range loop + if Name_Len = 8 + and then Name_Buffer (1 .. 8) = Unit_Array (J).Filenm + then + Check_Restriction (Unit_Array (J).Res_Id, N); + end if; + end loop; + + -- If not predefined unit, then one special check still + -- remains. GNAT.Current_Exception is not allowed if we have + -- restriction No_Exception_Propagation active. + + else + if Name_Buffer (1 .. 8) = "g-curexc" then + Check_Restriction (No_Exception_Propagation, N); + end if; + end if; + end; + end if; + end Check_Restricted_Unit; + + ----------------------- + -- Check_Restriction -- + ----------------------- + + procedure Check_Restriction + (R : Restriction_Id; + N : Node_Id; + V : Uint := Uint_Minus_1) + is + VV : Integer; + -- V converted to integer form. If V is greater than Integer'Last, + -- it is reset to minus 1 (unknown value). + + procedure Update_Restrictions (Info : in out Restrictions_Info); + -- Update violation information in Info.Violated and Info.Count + + ------------------------- + -- Update_Restrictions -- + ------------------------- + + procedure Update_Restrictions (Info : in out Restrictions_Info) is + begin + -- If not violated, set as violated now + + if not Info.Violated (R) then + Info.Violated (R) := True; + + if R in All_Parameter_Restrictions then + if VV < 0 then + Info.Unknown (R) := True; + Info.Count (R) := 1; + else + Info.Count (R) := VV; + end if; + end if; + + -- Otherwise if violated already and a parameter restriction, + -- update count by maximizing or summing depending on restriction. + + elsif R in All_Parameter_Restrictions then + + -- If new value is unknown, result is unknown + + if VV < 0 then + Info.Unknown (R) := True; + + -- If checked by maximization, do maximization + + elsif R in Checked_Max_Parameter_Restrictions then + Info.Count (R) := Integer'Max (Info.Count (R), VV); + + -- If checked by adding, do add, checking for overflow + + elsif R in Checked_Add_Parameter_Restrictions then + declare + pragma Unsuppress (Overflow_Check); + begin + Info.Count (R) := Info.Count (R) + VV; + exception + when Constraint_Error => + Info.Count (R) := Integer'Last; + Info.Unknown (R) := True; + end; + + -- Should not be able to come here, known counts should only + -- occur for restrictions that are Checked_max or Checked_Sum. + + else + raise Program_Error; + end if; + end if; + end Update_Restrictions; + + -- Start of processing for Check_Restriction + + begin + -- In CodePeer mode, we do not want to check for any restriction, or set + -- additional restrictions other than those already set in gnat1drv.adb + -- so that we have consistency between each compilation. + + if CodePeer_Mode then + return; + end if; + + if UI_Is_In_Int_Range (V) then + VV := Integer (UI_To_Int (V)); + else + VV := -1; + end if; + + -- Count can only be specified in the checked val parameter case + + pragma Assert (VV < 0 or else R in Checked_Val_Parameter_Restrictions); + + -- Nothing to do if value of zero specified for parameter restriction + + if VV = 0 then + return; + end if; + + -- Update current restrictions + + Update_Restrictions (Restrictions); + + -- If in main extended unit, update main restrictions as well + + if Current_Sem_Unit = Main_Unit + or else In_Extended_Main_Source_Unit (N) + then + Update_Restrictions (Main_Restrictions); + end if; + + -- Nothing to do if restriction message suppressed + + if Suppress_Restriction_Message (N) then + null; + + -- If restriction not set, nothing to do + + elsif not Restrictions.Set (R) then + null; + + -- Here if restriction set, check for violation (either this is a + -- Boolean restriction, or a parameter restriction with a value of + -- zero and an unknown count, or a parameter restriction with a + -- known value that exceeds the restriction count). + + elsif R in All_Boolean_Restrictions + or else (Restrictions.Unknown (R) + and then Restrictions.Value (R) = 0) + or else Restrictions.Count (R) > Restrictions.Value (R) + then + Restriction_Msg (R, N); + end if; + end Check_Restriction; + + ------------------------------------- + -- Check_Restriction_No_Dependence -- + ------------------------------------- + + procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id) is + DU : Node_Id; + + begin + -- Ignore call if node U is not in the main source unit. This avoids + -- cascaded errors, e.g. when Ada.Containers units with other units. + + if not In_Extended_Main_Source_Unit (U) then + return; + end if; + + -- Loop through entries in No_Dependence table to check each one in turn + + for J in No_Dependence.First .. No_Dependence.Last loop + DU := No_Dependence.Table (J).Unit; + + if Same_Unit (U, DU) then + Error_Msg_Sloc := Sloc (DU); + Error_Msg_Node_1 := DU; + + if No_Dependence.Table (J).Warn then + Error_Msg + ("?violation of restriction `No_Dependence '='> &`#", + Sloc (Err)); + else + Error_Msg + ("|violation of restriction `No_Dependence '='> &`#", + Sloc (Err)); + end if; + + return; + end if; + end loop; + end Check_Restriction_No_Dependence; + + -------------------------------------- + -- Check_Wide_Character_Restriction -- + -------------------------------------- + + procedure Check_Wide_Character_Restriction (E : Entity_Id; N : Node_Id) is + begin + if Restriction_Check_Required (No_Wide_Characters) + and then Comes_From_Source (N) + then + declare + T : constant Entity_Id := Root_Type (E); + begin + if T = Standard_Wide_Character or else + T = Standard_Wide_String or else + T = Standard_Wide_Wide_Character or else + T = Standard_Wide_Wide_String + then + Check_Restriction (No_Wide_Characters, N); + end if; + end; + end if; + end Check_Wide_Character_Restriction; + + ---------------------------------------- + -- Cunit_Boolean_Restrictions_Restore -- + ---------------------------------------- + + procedure Cunit_Boolean_Restrictions_Restore + (R : Save_Cunit_Boolean_Restrictions) + is + begin + for J in Cunit_Boolean_Restrictions loop + Restrictions.Set (J) := R (J); + end loop; + end Cunit_Boolean_Restrictions_Restore; + + ------------------------------------- + -- Cunit_Boolean_Restrictions_Save -- + ------------------------------------- + + function Cunit_Boolean_Restrictions_Save + return Save_Cunit_Boolean_Restrictions + is + R : Save_Cunit_Boolean_Restrictions; + + begin + for J in Cunit_Boolean_Restrictions loop + R (J) := Restrictions.Set (J); + Restrictions.Set (J) := False; + end loop; + + return R; + end Cunit_Boolean_Restrictions_Save; + + ------------------------ + -- Get_Restriction_Id -- + ------------------------ + + function Get_Restriction_Id + (N : Name_Id) return Restriction_Id + is + begin + Get_Name_String (N); + Set_Casing (All_Upper_Case); + + for J in All_Restrictions loop + declare + S : constant String := Restriction_Id'Image (J); + begin + if S = Name_Buffer (1 .. Name_Len) then + return J; + end if; + end; + end loop; + + return Not_A_Restriction_Id; + end Get_Restriction_Id; + + ------------------------------- + -- No_Exception_Handlers_Set -- + ------------------------------- + + function No_Exception_Handlers_Set return Boolean is + begin + return (No_Run_Time_Mode or else Configurable_Run_Time_Mode) + and then (Restrictions.Set (No_Exception_Handlers) + or else + Restrictions.Set (No_Exception_Propagation)); + end No_Exception_Handlers_Set; + + ------------------------------------- + -- No_Exception_Propagation_Active -- + ------------------------------------- + + function No_Exception_Propagation_Active return Boolean is + begin + return (No_Run_Time_Mode + or else Configurable_Run_Time_Mode + or else Debug_Flag_Dot_G) + and then Restriction_Active (No_Exception_Propagation); + end No_Exception_Propagation_Active; + + ---------------------------------- + -- Process_Restriction_Synonyms -- + ---------------------------------- + + -- Note: body of this function must be coordinated with list of + -- renaming declarations in System.Rident. + + function Process_Restriction_Synonyms (N : Node_Id) return Name_Id + is + Old_Name : constant Name_Id := Chars (N); + New_Name : Name_Id; + + begin + case Old_Name is + when Name_Boolean_Entry_Barriers => + New_Name := Name_Simple_Barriers; + + when Name_Max_Entry_Queue_Depth => + New_Name := Name_Max_Entry_Queue_Length; + + when Name_No_Dynamic_Interrupts => + New_Name := Name_No_Dynamic_Attachment; + + when Name_No_Requeue => + New_Name := Name_No_Requeue_Statements; + + when Name_No_Task_Attributes => + New_Name := Name_No_Task_Attributes_Package; + + when others => + return Old_Name; + end case; + + if Warn_On_Obsolescent_Feature then + Error_Msg_Name_1 := Old_Name; + Error_Msg_N ("restriction identifier % is obsolescent?", N); + Error_Msg_Name_1 := New_Name; + Error_Msg_N ("|use restriction identifier % instead", N); + end if; + + return New_Name; + end Process_Restriction_Synonyms; + + ------------------------ + -- Restricted_Profile -- + ------------------------ + + function Restricted_Profile return Boolean is + begin + if Restricted_Profile_Cached then + return Restricted_Profile_Result; + + else + Restricted_Profile_Result := True; + Restricted_Profile_Cached := True; + + declare + R : Restriction_Flags renames Profile_Info (Restricted).Set; + V : Restriction_Values renames Profile_Info (Restricted).Value; + begin + for J in R'Range loop + if R (J) + and then (Restrictions.Set (J) = False + or else Restriction_Warnings (J) + or else + (J in All_Parameter_Restrictions + and then Restrictions.Value (J) > V (J))) + then + Restricted_Profile_Result := False; + exit; + end if; + end loop; + + return Restricted_Profile_Result; + end; + end if; + end Restricted_Profile; + + ------------------------ + -- Restriction_Active -- + ------------------------ + + function Restriction_Active (R : All_Restrictions) return Boolean is + begin + return Restrictions.Set (R) and then not Restriction_Warnings (R); + end Restriction_Active; + + -------------------------------- + -- Restriction_Check_Required -- + -------------------------------- + + function Restriction_Check_Required (R : All_Restrictions) return Boolean is + begin + return Restrictions.Set (R); + end Restriction_Check_Required; + + --------------------- + -- Restriction_Msg -- + --------------------- + + procedure Restriction_Msg (R : Restriction_Id; N : Node_Id) is + Msg : String (1 .. 100); + Len : Natural := 0; + + procedure Add_Char (C : Character); + -- Append given character to Msg, bumping Len + + procedure Add_Str (S : String); + -- Append given string to Msg, bumping Len appropriately + + procedure Id_Case (S : String; Quotes : Boolean := True); + -- Given a string S, case it according to current identifier casing, + -- and store in Error_Msg_String. Then append `~` to the message buffer + -- to output the string unchanged surrounded in quotes. The quotes are + -- suppressed if Quotes = False. + + -------------- + -- Add_Char -- + -------------- + + procedure Add_Char (C : Character) is + begin + Len := Len + 1; + Msg (Len) := C; + end Add_Char; + + ------------- + -- Add_Str -- + ------------- + + procedure Add_Str (S : String) is + begin + Msg (Len + 1 .. Len + S'Length) := S; + Len := Len + S'Length; + end Add_Str; + + ------------- + -- Id_Case -- + ------------- + + procedure Id_Case (S : String; Quotes : Boolean := True) is + begin + Name_Buffer (1 .. S'Last) := S; + Name_Len := S'Length; + Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N)))); + Error_Msg_Strlen := Name_Len; + Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); + + if Quotes then + Add_Str ("`~`"); + else + Add_Char ('~'); + end if; + end Id_Case; + + -- Start of processing for Restriction_Msg + + begin + -- Set warning message if warning + + if Restriction_Warnings (R) then + Add_Char ('?'); + + -- If real violation (not warning), then mark it as non-serious unless + -- it is a violation of No_Finalization in which case we leave it as a + -- serious message, since otherwise we get crashes during attempts to + -- expand stuff that is not properly formed due to assumptions made + -- about no finalization being present. + + elsif R /= No_Finalization then + Add_Char ('|'); + end if; + + Error_Msg_Sloc := Restrictions_Loc (R); + + -- Set main message, adding implicit if no source location + + if Error_Msg_Sloc > No_Location + or else Error_Msg_Sloc = System_Location + then + Add_Str ("violation of restriction "); + else + Add_Str ("violation of implicit restriction "); + Error_Msg_Sloc := No_Location; + end if; + + -- Case of parameterized restriction + + if R in All_Parameter_Restrictions then + Add_Char ('`'); + Id_Case (Restriction_Id'Image (R), Quotes => False); + Add_Str (" = ^`"); + Error_Msg_Uint_1 := UI_From_Int (Int (Restrictions.Value (R))); + + -- Case of boolean restriction + + else + Id_Case (Restriction_Id'Image (R)); + end if; + + -- Case of no secondary profile continuation message + + if Restriction_Profile_Name (R) = No_Profile then + if Error_Msg_Sloc /= No_Location then + Add_Char ('#'); + end if; + + Add_Char ('!'); + Error_Msg_N (Msg (1 .. Len), N); + + -- Case of secondary profile continuation message present + + else + Add_Char ('!'); + Error_Msg_N (Msg (1 .. Len), N); + + Len := 0; + Add_Char ('\'); + + -- Set as warning if warning case + + if Restriction_Warnings (R) then + Add_Char ('?'); + end if; + + -- Set main message + + Add_Str ("from profile "); + Id_Case (Profile_Name'Image (Restriction_Profile_Name (R))); + + -- Add location if we have one + + if Error_Msg_Sloc /= No_Location then + Add_Char ('#'); + end if; + + -- Output unconditional message and we are done + + Add_Char ('!'); + Error_Msg_N (Msg (1 .. Len), N); + end if; + end Restriction_Msg; + + --------------- + -- Same_Unit -- + --------------- + + function Same_Unit (U1, U2 : Node_Id) return Boolean is + begin + if Nkind (U1) = N_Identifier then + return Nkind (U2) = N_Identifier and then Chars (U1) = Chars (U2); + + elsif Nkind (U2) = N_Identifier then + return False; + + elsif (Nkind (U1) = N_Selected_Component + or else Nkind (U1) = N_Expanded_Name) + and then + (Nkind (U2) = N_Selected_Component + or else Nkind (U2) = N_Expanded_Name) + then + return Same_Unit (Prefix (U1), Prefix (U2)) + and then Same_Unit (Selector_Name (U1), Selector_Name (U2)); + else + return False; + end if; + end Same_Unit; + + ------------------------------ + -- Set_Profile_Restrictions -- + ------------------------------ + + procedure Set_Profile_Restrictions + (P : Profile_Name; + N : Node_Id; + Warn : Boolean) + is + R : Restriction_Flags renames Profile_Info (P).Set; + V : Restriction_Values renames Profile_Info (P).Value; + + begin + for J in R'Range loop + if R (J) then + declare + Already_Restricted : constant Boolean := Restriction_Active (J); + + begin + -- Set the restriction + + if J in All_Boolean_Restrictions then + Set_Restriction (J, N); + else + Set_Restriction (J, N, V (J)); + end if; + + -- Record that this came from a Profile[_Warnings] restriction + + Restriction_Profile_Name (J) := P; + + -- Set warning flag, except that we do not set the warning + -- flag if the restriction was already active and this is + -- the warning case. That avoids a warning overriding a real + -- restriction, which should never happen. + + if not (Warn and Already_Restricted) then + Restriction_Warnings (J) := Warn; + end if; + end; + end if; + end loop; + end Set_Profile_Restrictions; + + --------------------- + -- Set_Restriction -- + --------------------- + + -- Case of Boolean restriction + + procedure Set_Restriction + (R : All_Boolean_Restrictions; + N : Node_Id) + is + begin + -- Restriction No_Elaboration_Code must be enforced on a unit by unit + -- basis. Hence, we avoid setting the restriction when processing an + -- unit which is not the main one being compiled (or its corresponding + -- spec). It can happen, for example, when processing an inlined body + -- (the package containing the inlined subprogram is analyzed, + -- including its pragma Restrictions). + + -- This seems like a very nasty kludge??? This is not the only per unit + -- restriction why is this treated specially ??? + + if R = No_Elaboration_Code + and then Current_Sem_Unit /= Main_Unit + and then Cunit (Current_Sem_Unit) /= Library_Unit (Cunit (Main_Unit)) + then + return; + end if; + + Restrictions.Set (R) := True; + + if Restricted_Profile_Cached and Restricted_Profile_Result then + null; + else + Restricted_Profile_Cached := False; + end if; + + -- Set location, but preserve location of system restriction for nice + -- error msg with run time name. + + if Restrictions_Loc (R) /= System_Location then + Restrictions_Loc (R) := Sloc (N); + end if; + + -- Note restriction came from restriction pragma, not profile + + Restriction_Profile_Name (R) := No_Profile; + + -- Record the restriction if we are in the main unit, or in the extended + -- main unit. The reason that we test separately for Main_Unit is that + -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in + -- gnat.adc do not appear to be in the extended main source unit (they + -- probably should do ???) + + if Current_Sem_Unit = Main_Unit + or else In_Extended_Main_Source_Unit (N) + then + if not Restriction_Warnings (R) then + Main_Restrictions.Set (R) := True; + end if; + end if; + end Set_Restriction; + + -- Case of parameter restriction + + procedure Set_Restriction + (R : All_Parameter_Restrictions; + N : Node_Id; + V : Integer) + is + begin + if Restricted_Profile_Cached and Restricted_Profile_Result then + null; + else + Restricted_Profile_Cached := False; + end if; + + if Restrictions.Set (R) then + if V < Restrictions.Value (R) then + Restrictions.Value (R) := V; + Restrictions_Loc (R) := Sloc (N); + end if; + + else + Restrictions.Set (R) := True; + Restrictions.Value (R) := V; + Restrictions_Loc (R) := Sloc (N); + end if; + + -- Record the restriction if we are in the main unit, or in the extended + -- main unit. The reason that we test separately for Main_Unit is that + -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in + -- gnat.adc do not appear to be the extended main source unit (they + -- probably should do ???) + + if Current_Sem_Unit = Main_Unit + or else In_Extended_Main_Source_Unit (N) + then + if Main_Restrictions.Set (R) then + if V < Main_Restrictions.Value (R) then + Main_Restrictions.Value (R) := V; + end if; + + elsif not Restriction_Warnings (R) then + Main_Restrictions.Set (R) := True; + Main_Restrictions.Value (R) := V; + end if; + end if; + + -- Note restriction came from restriction pragma, not profile + + Restriction_Profile_Name (R) := No_Profile; + end Set_Restriction; + + ----------------------------------- + -- Set_Restriction_No_Dependence -- + ----------------------------------- + + procedure Set_Restriction_No_Dependence + (Unit : Node_Id; + Warn : Boolean; + Profile : Profile_Name := No_Profile) + is + begin + -- Loop to check for duplicate entry + + for J in No_Dependence.First .. No_Dependence.Last loop + + -- Case of entry already in table + + if Same_Unit (Unit, No_Dependence.Table (J).Unit) then + + -- Error has precedence over warning + + if not Warn then + No_Dependence.Table (J).Warn := False; + end if; + + return; + end if; + end loop; + + -- Entry is not currently in table + + No_Dependence.Append ((Unit, Warn, Profile)); + end Set_Restriction_No_Dependence; + + ---------------------------------- + -- Suppress_Restriction_Message -- + ---------------------------------- + + function Suppress_Restriction_Message (N : Node_Id) return Boolean is + begin + -- We only output messages for the extended main source unit + + if In_Extended_Main_Source_Unit (N) then + return False; + + -- If loaded by rtsfind, then suppress message + + elsif Sloc (N) <= No_Location then + return True; + + -- Otherwise suppress message if internal file + + else + return Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N))); + end if; + end Suppress_Restriction_Message; + + --------------------- + -- Tasking_Allowed -- + --------------------- + + function Tasking_Allowed return Boolean is + begin + return not Restrictions.Set (No_Tasking) + and then (not Restrictions.Set (Max_Tasks) + or else Restrictions.Value (Max_Tasks) > 0); + end Tasking_Allowed; + +end Restrict; diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads new file mode 100644 index 000000000..50d542789 --- /dev/null +++ b/gcc/ada/restrict.ads @@ -0,0 +1,361 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- R E S T R I C T -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package deals with the implementation of the Restrictions pragma + +with Namet; use Namet; +with Rident; use Rident; +with Table; +with Types; use Types; +with Uintp; use Uintp; + +package Restrict is + + Restrictions : Restrictions_Info := No_Restrictions; + -- This variable records restrictions found in any units in the main + -- extended unit, and in the case of restrictions checked for partition + -- consistency, restrictions found in any with'ed units, parent specs + -- etc., since we may as well check as much as we can at compile time. + -- These variables should not be referenced directly by clients. Instead + -- use Check_Restrictions to record a violation of a restriction, and + -- Restriction_Active to test if a given restriction is active. + + Restrictions_Loc : array (All_Restrictions) of Source_Ptr := + (others => No_Location); + -- Locations of Restrictions pragmas for error message purposes. + -- Valid only if corresponding entry in Restrictions is set. A value + -- of No_Location is used for implicit restrictions set by another + -- pragma, and a value of System_Location is used for restrictions + -- set from package Standard by the processing in Targparm. + + Restriction_Profile_Name : array (All_Restrictions) of Profile_Name; + -- Entries in this array are valid only if the corresponding restriction + -- in Restrictions set. The value is the corresponding profile name if the + -- restriction was set by a Profile or Profile_Warnings pragma. The value + -- is No_Profile in all other cases. + + Main_Restrictions : Restrictions_Info := No_Restrictions; + -- This variable records only restrictions found in any units of the + -- main extended unit. These are the variables used for ali file output, + -- since we want the binder to be able to accurately diagnose inter-unit + -- restriction violations. + + Restriction_Warnings : Rident.Restriction_Flags; + -- If one of these flags is set, then it means that violation of the + -- corresponding restriction results only in a warning message, not + -- in an error message, and the restriction is not otherwise enforced. + -- Note that the flags in Restrictions are set to indicate that the + -- restriction is set in this case, but Main_Restrictions is never + -- set if Restriction_Warnings is set, so this does not look like a + -- restriction to the binder. + + type Save_Cunit_Boolean_Restrictions is private; + -- Type used for saving and restoring compilation unit restrictions. + -- See Cunit_Boolean_Restrictions_[Save|Restore] subprograms. + + -- The following declarations establish a mapping between restriction + -- identifiers, and the names of corresponding restriction library units. + + type Unit_Entry is record + Res_Id : Restriction_Id; + Filenm : String (1 .. 8); + end record; + + Unit_Array : constant array (Positive range <>) of Unit_Entry := ( + (No_Asynchronous_Control, "a-astaco"), + (No_Calendar, "a-calend"), + (No_Calendar, "calendar"), + (No_Delay, "a-calend"), + (No_Delay, "calendar"), + (No_Dynamic_Priorities, "a-dynpri"), + (No_Finalization, "a-finali"), + (No_IO, "a-direio"), + (No_IO, "directio"), + (No_IO, "a-sequio"), + (No_IO, "sequenio"), + (No_IO, "a-ststio"), + (No_IO, "a-textio"), + (No_IO, "text_io "), + (No_IO, "a-witeio"), + (No_Task_Attributes_Package, "a-tasatt"), + (No_Unchecked_Conversion, "a-unccon"), + (No_Unchecked_Conversion, "unchconv"), + (No_Unchecked_Deallocation, "a-uncdea"), + (No_Unchecked_Deallocation, "unchdeal")); + + -- The following map has True for all GNAT pragmas. It is used to + -- implement pragma Restrictions (No_Implementation_Restrictions) + -- (which is why this restriction itself is excluded from the list). + + Implementation_Restriction : array (All_Restrictions) of Boolean := + (Simple_Barriers => True, + No_Asynchronous_Control => True, + No_Calendar => True, + No_Dispatching_Calls => True, + No_Dynamic_Attachment => True, + No_Elaboration_Code => True, + No_Enumeration_Maps => True, + No_Entry_Calls_In_Elaboration_Code => True, + No_Entry_Queue => True, + No_Exception_Handlers => True, + No_Exception_Registration => True, + No_Implementation_Attributes => True, + No_Implementation_Pragmas => True, + No_Implicit_Conditionals => True, + No_Implicit_Dynamic_Code => True, + No_Implicit_Loops => True, + No_Local_Protected_Objects => True, + No_Protected_Type_Allocators => True, + No_Relative_Delay => True, + No_Requeue_Statements => True, + No_Secondary_Stack => True, + No_Select_Statements => True, + No_Standard_Storage_Pools => True, + No_Streams => True, + No_Task_Attributes_Package => True, + No_Task_Termination => True, + No_Unchecked_Conversion => True, + No_Unchecked_Deallocation => True, + No_Wide_Characters => True, + Static_Priorities => True, + Static_Storage_Size => True, + others => False); + + -- The following table records entries made by Restrictions pragmas + -- that specify a parameter for No_Dependence. Each such pragma makes + -- an entry in this table. + + -- Note: we have chosen to implement this restriction in the "syntactic" + -- form, where we do not check that the named package is a language defined + -- package, but instead we allow arbitrary package names. The discussion of + -- this issue is not complete in the ARG, but the sense seems to be leaning + -- in this direction, which makes more sense to us, since it is much more + -- useful, and much easier to implement. + + type ND_Entry is record + Unit : Node_Id; + -- The unit parameter from the No_Dependence pragma + + Warn : Boolean; + -- True if from Restriction_Warnings, False if from Restrictions + + Profile : Profile_Name; + -- Set to name of profile from which No_Dependence entry came, or to + -- No_Profile if a pragma Restriction set the No_Dependence entry. + end record; + + package No_Dependence is new Table.Table ( + Table_Component_Type => ND_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 200, + Table_Increment => 200, + Table_Name => "Name_No_Dependence"); + + ----------------- + -- 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. + + procedure Check_Compiler_Unit (N : Node_Id); + -- If unit N is in a unit that has a pragma Compiler_Unit, then a message + -- is posted on node N noting use of a construct that is not permitted in + -- the compiler. + + procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id); + -- Checks if loading of unit U is prohibited by the setting of some + -- restriction (e.g. No_IO restricts the loading of unit Ada.Text_IO). + -- If a restriction exists post error message at the given node. + + procedure Check_Restriction + (R : Restriction_Id; + N : Node_Id; + V : Uint := Uint_Minus_1); + -- Checks that the given restriction is not set, and if it is set, an + -- appropriate message is posted on the given node. Also records the + -- violation in the appropriate internal arrays. Note that it is mandatory + -- to always use this routine to check if a restriction is violated. Such + -- checks must never be done directly by the caller, since otherwise + -- violations in the absence of restrictions are not properly recorded. The + -- value of V is relevant only for parameter restrictions, and in this case + -- indicates the exact count for the violation. If the exact count is not + -- known, V is left at its default of -1 which indicates an unknown count. + + procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id); + -- Called when a dependence on a unit is created (either implicitly, or by + -- an explicit WITH clause). U is a node for the unit involved, and Err + -- is the node to which an error will be attached if necessary. + + procedure Check_Elaboration_Code_Allowed (N : Node_Id); + -- Tests to see if elaboration code is allowed by the current restrictions + -- settings. This function is called by Gigi when it needs to define + -- an elaboration routine. If elaboration code is not allowed, an error + -- message is posted on the node given as argument. + + procedure Check_Implicit_Dynamic_Code_Allowed (N : Node_Id); + -- Tests to see if dynamic code generation (dynamically generated + -- trampolines, in particular) is allowed by the current restrictions + -- settings. This function is called by Gigi when it needs to generate code + -- that generates a trampoline. If not allowed, an error message is posted + -- on the node given as argument. + + procedure Check_No_Implicit_Heap_Alloc (N : Node_Id); + -- Equivalent to Check_Restriction (No_Implicit_Heap_Allocations, N). + -- Provided for easy use by back end, which has to check this restriction. + + procedure Check_Obsolescent_2005_Entity (E : Entity_Id; N : Node_Id); + -- This routine checks if the entity E is one of the obsolescent entries + -- in Ada.Characters.Handling in Ada 2005 and No_Obsolescent_Features + -- restriction is active. If so an appropriate message is given. N is + -- the node on which the message is to be placed. It's a bit kludgy to + -- have this highly specialized routine rather than some wonderful general + -- mechanism (e.g. a special pragma) to handle this case, but there are + -- only six cases, and it is not worth the effort to do something general. + + procedure Check_Wide_Character_Restriction (E : Entity_Id; N : Node_Id); + -- This procedure checks if the No_Wide_Character restriction is active, + -- and if so, if N Comes_From_Source, and the root type of E is one of + -- [Wide_]Wide_Character or [Wide_]Wide_String, then the restriction + -- violation is recorded, and an appropriate message given. + + function Cunit_Boolean_Restrictions_Save + return Save_Cunit_Boolean_Restrictions; + -- This function saves the compilation unit restriction settings, and + -- resets them to False. This is used e.g. when compiling a with'ed + -- unit to avoid incorrectly propagating restrictions. Note that it + -- would not be wrong to also save and reset the partition restrictions, + -- since the binder would catch inconsistencies, but actually it is a + -- good thing to acquire restrictions from with'ed units if they are + -- required to be partition wide, because it allows the restriction + -- violation message to be given at compile time instead of link time. + + procedure Cunit_Boolean_Restrictions_Restore + (R : Save_Cunit_Boolean_Restrictions); + -- This is the corresponding restore procedure to restore restrictions + -- previously saved by Cunit_Boolean_Restrictions_Save. + + function Get_Restriction_Id + (N : Name_Id) return Restriction_Id; + -- Given an identifier name, determines if it is a valid restriction + -- identifier, and if so returns the corresponding Restriction_Id + -- value, otherwise returns Not_A_Restriction_Id. + + function No_Exception_Handlers_Set return Boolean; + -- Test to see if current restrictions settings specify that no exception + -- handlers are present. This function is called by Gigi when it needs to + -- expand an AT END clean up identifier with no exception handler. True + -- will be returned if the configurable run-time is activated, and either + -- of the restrictions No_Exception_Handlers or No_Exception_Propagation is + -- set. In the latter case, the source may contain handlers but they either + -- get converted using the local goto transformation or deleted. + + function No_Exception_Propagation_Active return Boolean; + -- Test to see if current restrictions settings specify that no + -- exception propagation is activated. + + function Process_Restriction_Synonyms (N : Node_Id) return Name_Id; + -- Id is a node whose Chars field contains the name of a restriction. + -- If it is one of synonyms that we allow for historical purposes (for + -- list see System.Rident), then the proper official name is returned. + -- Otherwise the Chars field of the argument is returned unchanged. + + function Restriction_Active (R : All_Restrictions) return Boolean; + pragma Inline (Restriction_Active); + -- Determines if a given restriction is active. This call should only be + -- used where the compiled code depends on whether the restriction is + -- active. Always use Check_Restriction to record a violation. Note that + -- this returns False if we only have a Restriction_Warnings set, since + -- restriction warnings should never affect generated code. If you want + -- to know if a call to Check_Restriction is needed then use the function + -- Restriction_Check_Required instead. + + function Restriction_Check_Required (R : All_Restrictions) return Boolean; + pragma Inline (Restriction_Check_Required); + -- Determines if either a Restriction_Warnings or Restrictions pragma has + -- been given for the specified restriction. If true, then a subsequent + -- call to Check_Restriction is required if the restriction is violated. + -- This must not be used to guard code generation that depends on whether + -- a restriction is active (see Restriction_Active above). Typically it + -- is used to avoid complex code to determine if a restriction is violated, + -- executing this code only if needed. + + function Restricted_Profile return Boolean; + -- Tests if set of restrictions corresponding to Profile (Restricted) is + -- currently in effect (set by pragma Profile, or by an appropriate set + -- of individual Restrictions pragmas). Returns True only if all the + -- required restrictions are set. + + procedure Set_Profile_Restrictions + (P : Profile_Name; + N : Node_Id; + Warn : Boolean); + -- Sets the set of restrictions associated with the given profile name. N + -- is the node of the construct to which error messages are to be attached + -- as required. Warn is set True for the case of Profile_Warnings where the + -- restrictions are set as warnings rather than legality requirements, and + -- is also True for Profile if the Treat_Restrictions_As_Warnings flag is + -- set. It is false for Profile if this flag is not set. + + procedure Set_Restriction + (R : All_Boolean_Restrictions; + N : Node_Id); + -- N is a node (typically a pragma node) that has the effect of setting + -- Boolean restriction R. The restriction is set in Restrictions, and + -- also in Main_Restrictions if this is the main unit. + + procedure Set_Restriction + (R : All_Parameter_Restrictions; + N : Node_Id; + V : Integer); + -- Similar to the above, except that this is used for the case of a + -- parameter restriction, and the corresponding value V is given. + + procedure Set_Restriction_No_Dependence + (Unit : Node_Id; + Warn : Boolean; + Profile : Profile_Name := No_Profile); + -- Sets given No_Dependence restriction in table if not there already. + -- Warn is True if from Restriction_Warnings, or for Restrictions if flag + -- Treat_Restrictions_As_Warnings is set. False if from Restrictions and + -- this flag is not set. Profile is set to a non-default value if the + -- No_Dependence restriction comes from a Profile pragma. + + function Tasking_Allowed return Boolean; + pragma Inline (Tasking_Allowed); + -- Tests if tasking operations are allowed by the current restrictions + -- settings. For tasking to be allowed Max_Tasks must be non-zero. + +private + type Save_Cunit_Boolean_Restrictions is + array (Cunit_Boolean_Restrictions) of Boolean; + -- Type used for saving and restoring compilation unit restrictions. + -- See Compilation_Unit_Restrictions_[Save|Restore] subprograms. + +end Restrict; diff --git a/gcc/ada/rident.ads b/gcc/ada/rident.ads new file mode 100644 index 000000000..6f771145f --- /dev/null +++ b/gcc/ada/rident.ads @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- R I D E 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 defines the set of restriction identifiers for use by the +-- compiler and binder. It is in a separate package from Restrict so that +-- it can be used by the binder without dragging in unneeded compiler +-- packages. + +-- Note: the actual definitions of the types are in package System.Rident, +-- and this package is merely an instantiation of that package. The point +-- of this level of generic indirection is to allow the compile time use +-- to have the image tables available (this package is not compiled with +-- Discard_Names), while at run-time we do not want those image tables. + +-- Rather than have clients instantiate System.Rident directly, we have the +-- single instantiation here at the library level, which means that we only +-- have one copy of the image tables + +with System.Rident; + +package Rident is new System.Rident; diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb new file mode 100644 index 000000000..9742cb20b --- /dev/null +++ b/gcc/ada/rtsfind.adb @@ -0,0 +1,1490 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- R T S F I N D -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Casing; use Casing; +with Csets; use Csets; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Dist; use Exp_Dist; +with Fname; use Fname; +with Fname.UF; use Fname.UF; +with Lib; use Lib; +with Lib.Load; use Lib.Load; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Output; use Output; +with Opt; use Opt; +with Restrict; use Restrict; +with Sem; use Sem; +with Sem_Ch7; use Sem_Ch7; +with Sem_Dist; use Sem_Dist; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Stand; use Stand; +with Snames; use Snames; +with Tbuild; use Tbuild; +with Uname; use Uname; + +package body Rtsfind is + + RTE_Available_Call : Boolean := False; + -- Set True during call to RTE from RTE_Available (or from call to + -- RTE_Record_Component from RTE_Record_Component_Available). Tells + -- the called subprogram to set RTE_Is_Available to False rather than + -- generating an error message. + + RTE_Is_Available : Boolean; + -- Set True by RTE_Available on entry. When RTE_Available_Call is set + -- True, set False if RTE would otherwise generate an error message. + + ---------------- + -- Unit table -- + ---------------- + + -- The unit table has one entry for each unit included in the definition + -- of the type RTU_Id in the spec. The table entries are initialized in + -- Initialize to set the Entity field to Empty, indicating that the + -- corresponding unit has not yet been loaded. The fields are set when + -- a unit is loaded to contain the defining entity for the unit, the + -- unit name, and the unit number. + + -- Note that a unit can be loaded either by a call to find an entity + -- within the unit (e.g. RTE), or by an explicit with of the unit. In + -- the latter case it is critical to make a call to Set_RTU_Loaded to + -- ensure that the entry in this table reflects the load. + + -- A unit retrieved through rtsfind may end up in the context of several + -- other units, in addition to the main unit. These additional with_clauses + -- are needed to generate a proper traversal order for Inspector. To + -- minimize somewhat the redundancy created by numerous calls to rtsfind + -- from different units, we keep track of the list of implicit with_clauses + -- already created for the current loaded unit. + + type RT_Unit_Table_Record is record + Entity : Entity_Id; + Uname : Unit_Name_Type; + First_Implicit_With : Node_Id; + Unum : Unit_Number_Type; + end record; + + RT_Unit_Table : array (RTU_Id) of RT_Unit_Table_Record; + + -------------------------- + -- Runtime Entity Table -- + -------------------------- + + -- There is one entry in the runtime entity table for each entity that is + -- included in the definition of the RE_Id type in the spec. The entries + -- are set by Initialize_Rtsfind to contain Empty, indicating that the + -- entity has not yet been located. Once the entity is located for the + -- first time, its ID is stored in this array, so that subsequent calls + -- for the same entity can be satisfied immediately. + + -- NOTE: In order to avoid conflicts between record components and subprgs + -- that have the same name (i.e. subprogram External_Tag and + -- component External_Tag of package Ada.Tags) this table is not used + -- with Record_Components. + + RE_Table : array (RE_Id) of Entity_Id; + + -------------------------------- + -- Generation of with_clauses -- + -------------------------------- + + -- When a unit is implicitly loaded as a result of a call to RTE, it is + -- necessary to create one or two implicit with_clauses. We add such + -- with_clauses to the extended main unit if needed, and also to whatever + -- unit needs them, which is not necessarily the main unit. The former + -- ensures that the object is correctly loaded by the binder. The latter + -- is necessary for SofCheck Inspector. + + -- The field First_Implicit_With in the unit table record are used to + -- avoid creating duplicate with_clauses. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Check_CRT (E : RE_Id; Eid : Entity_Id) return Entity_Id; + -- Check entity Eid to ensure that configurable run-time restrictions are + -- met. May generate an error message (if RTE_Available_Call is false) and + -- raise RE_Not_Available if entity E does not exist (e.g. Eid is Empty). + -- Above documentation not clear ??? + + procedure Entity_Not_Defined (Id : RE_Id); + -- Outputs error messages for an entity that is not defined in the run-time + -- library (the form of the error message is tailored for no run time or + -- configurable run time mode as required). + + function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type; + -- Retrieves the Unit Name given a unit id represented by its enumeration + -- value in RTU_Id. + + procedure Load_Fail (S : String; U_Id : RTU_Id; Id : RE_Id); + -- Internal procedure called if we can't successfully locate or process a + -- run-time unit. The parameters give information about the error message + -- to be given. S is a reason for failing to compile the file and U_Id is + -- the unit id. RE_Id is the RE_Id originally passed to RTE. The message in + -- S is one of the following: + -- + -- "not found" + -- "had parser errors" + -- "had semantic errors" + -- + -- The "not found" case is treated specially in that it is considered + -- a normal situation in configurable run-time mode, and generates + -- a warning, but is otherwise ignored. + + procedure Load_RTU + (U_Id : RTU_Id; + Id : RE_Id := RE_Null; + Use_Setting : Boolean := False); + -- Load the unit whose Id is given if not already loaded. The unit is + -- loaded and analyzed, and the entry in RT_Unit_Table is updated to + -- reflect the load. Use_Setting is used to indicate the initial setting + -- for the Is_Potentially_Use_Visible flag of the entity for the loaded + -- unit (if it is indeed loaded). A value of False means nothing special + -- need be done. A value of True indicates that this flag must be set to + -- True. It is needed only in the Text_IO_Kludge procedure, which may + -- materialize an entity of Text_IO (or [Wide_]Wide_Text_IO) that was + -- previously unknown. Id is the RE_Id value of the entity which was + -- originally requested. Id is used only for error message detail, and if + -- it is RE_Null, then the attempt to output the entity name is ignored. + + function Make_Unit_Name + (U : RT_Unit_Table_Record; + N : Node_Id) return Node_Id; + -- If the unit is a child unit, build fully qualified name for use in + -- With_Clause. + + procedure Maybe_Add_With (U : in out RT_Unit_Table_Record); + -- If necessary, add an implicit with_clause from the current unit to the + -- one represented by U. + + procedure Output_Entity_Name (Id : RE_Id; Msg : String); + -- Output continuation error message giving qualified name of entity + -- corresponding to Id, appending the string given by Msg. This call + -- is only effective in All_Errors mode. + + function RE_Chars (E : RE_Id) return Name_Id; + -- Given a RE_Id value returns the Chars of the corresponding entity + + procedure RTE_Error_Msg (Msg : String); + -- Generates a message by calling Error_Msg_N specifying Current_Error_Node + -- as the node location using the given Msg text. Special processing in the + -- case where RTE_Available_Call is set. In this case, no message is output + -- and instead RTE_Is_Available is set to False. Note that this can only be + -- used if you are sure that the message comes directly or indirectly from + -- a call to the RTE function. + + --------------- + -- Check_CRT -- + --------------- + + function Check_CRT (E : RE_Id; Eid : Entity_Id) return Entity_Id is + U_Id : constant RTU_Id := RE_Unit_Table (E); + + begin + if No (Eid) then + if RTE_Available_Call then + RTE_Is_Available := False; + else + Entity_Not_Defined (E); + end if; + + raise RE_Not_Available; + + -- Entity is available + + else + -- If in No_Run_Time mode and entity is not in one of the + -- specially permitted units, raise the exception. + + if No_Run_Time_Mode + and then not OK_No_Run_Time_Unit (U_Id) + then + Entity_Not_Defined (E); + raise RE_Not_Available; + end if; + + -- Otherwise entity is accessible + + return Eid; + end if; + end Check_CRT; + + ------------------------ + -- Entity_Not_Defined -- + ------------------------ + + procedure Entity_Not_Defined (Id : RE_Id) is + begin + if No_Run_Time_Mode then + + -- If the error occurs when compiling the body of a predefined + -- unit for inlining purposes, the body must be illegal in this + -- mode, and there is no point in continuing. + + if Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Sloc (Current_Error_Node)))) + then + Error_Msg_N + ("construct not allowed in no run time mode!", + Current_Error_Node); + raise Unrecoverable_Error; + + else + RTE_Error_Msg ("|construct not allowed in no run time mode"); + end if; + + elsif Configurable_Run_Time_Mode then + RTE_Error_Msg ("|construct not allowed in this configuration>"); + else + RTE_Error_Msg ("run-time configuration error"); + end if; + + Output_Entity_Name (Id, "not defined"); + end Entity_Not_Defined; + + ------------------- + -- Get_Unit_Name -- + ------------------- + + function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type is + Uname_Chars : constant String := RTU_Id'Image (U_Id); + + begin + Name_Len := Uname_Chars'Length; + Name_Buffer (1 .. Name_Len) := Uname_Chars; + Set_Casing (All_Lower_Case); + + if U_Id in Ada_Child then + Name_Buffer (4) := '.'; + + if U_Id in Ada_Calendar_Child then + Name_Buffer (13) := '.'; + + elsif U_Id in Ada_Dispatching_Child then + Name_Buffer (16) := '.'; + + elsif U_Id in Ada_Finalization_Child then + Name_Buffer (17) := '.'; + + elsif U_Id in Ada_Interrupts_Child then + Name_Buffer (15) := '.'; + + elsif U_Id in Ada_Real_Time_Child then + Name_Buffer (14) := '.'; + + elsif U_Id in Ada_Streams_Child then + Name_Buffer (12) := '.'; + + elsif U_Id in Ada_Strings_Child then + Name_Buffer (12) := '.'; + + elsif U_Id in Ada_Text_IO_Child then + Name_Buffer (12) := '.'; + + elsif U_Id in Ada_Wide_Text_IO_Child then + Name_Buffer (17) := '.'; + + elsif U_Id in Ada_Wide_Wide_Text_IO_Child then + Name_Buffer (22) := '.'; + end if; + + elsif U_Id in Interfaces_Child then + Name_Buffer (11) := '.'; + + elsif U_Id in System_Child then + Name_Buffer (7) := '.'; + + if U_Id in System_Strings_Child then + Name_Buffer (15) := '.'; + end if; + + if U_Id in System_Tasking_Child then + Name_Buffer (15) := '.'; + end if; + + if U_Id in System_Tasking_Restricted_Child then + Name_Buffer (26) := '.'; + end if; + + if U_Id in System_Tasking_Protected_Objects_Child then + Name_Buffer (33) := '.'; + end if; + + if U_Id in System_Tasking_Async_Delays_Child then + Name_Buffer (28) := '.'; + end if; + end if; + + -- Add %s at end for spec + + Name_Buffer (Name_Len + 1) := '%'; + Name_Buffer (Name_Len + 2) := 's'; + Name_Len := Name_Len + 2; + + return Name_Find; + end Get_Unit_Name; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + -- Initialize the unit table + + for J in RTU_Id loop + RT_Unit_Table (J).Entity := Empty; + end loop; + + for J in RE_Id loop + RE_Table (J) := Empty; + end loop; + + RTE_Is_Available := False; + end Initialize; + + ------------ + -- Is_RTE -- + ------------ + + function Is_RTE (Ent : Entity_Id; E : RE_Id) return Boolean is + E_Unit_Name : Unit_Name_Type; + Ent_Unit_Name : Unit_Name_Type; + + S : Entity_Id; + E1 : Entity_Id; + E2 : Entity_Id; + + begin + if No (Ent) then + return False; + + -- If E has already a corresponding entity, check it directly, + -- going to full views if they exist to deal with the incomplete + -- and private type cases properly. + + elsif Present (RE_Table (E)) then + E1 := Ent; + + if Is_Type (E1) and then Present (Full_View (E1)) then + E1 := Full_View (E1); + end if; + + E2 := RE_Table (E); + + if Is_Type (E2) and then Present (Full_View (E2)) then + E2 := Full_View (E2); + end if; + + return E1 = E2; + end if; + + -- If the unit containing E is not loaded, we already know that + -- the entity we have cannot have come from this unit. + + E_Unit_Name := Get_Unit_Name (RE_Unit_Table (E)); + + if not Is_Loaded (E_Unit_Name) then + return False; + end if; + + -- Here the unit containing the entity is loaded. We have not made + -- an explicit call to RTE to get the entity in question, but we may + -- have obtained a reference to it indirectly from some other entity + -- in the same unit, or some other unit that references it. + + -- Get the defining unit of the entity + + S := Scope (Ent); + + if Ekind (S) /= E_Package then + return False; + end if; + + Ent_Unit_Name := Get_Unit_Name (Unit_Declaration_Node (S)); + + -- If the defining unit of the entity we are testing is not the + -- unit containing E, then they cannot possibly match. + + if Ent_Unit_Name /= E_Unit_Name then + return False; + end if; + + -- If the units match, then compare the names (remember that no + -- overloading is permitted in entities fetched using Rtsfind). + + if RE_Chars (E) = Chars (Ent) then + RE_Table (E) := Ent; + + -- If front-end inlining is enabled, we may be within a body that + -- contains inlined functions, which has not been retrieved through + -- rtsfind, and therefore is not yet recorded in the RT_Unit_Table. + -- Add the unit information now, it must be fully available. + + declare + U : RT_Unit_Table_Record + renames RT_Unit_Table (RE_Unit_Table (E)); + begin + if No (U.Entity) then + U.Entity := S; + U.Uname := E_Unit_Name; + U.Unum := Get_Source_Unit (S); + end if; + end; + + return True; + else + return False; + end if; + end Is_RTE; + + ------------ + -- Is_RTU -- + ------------ + + function Is_RTU (Ent : Entity_Id; U : RTU_Id) return Boolean is + E : constant Entity_Id := RT_Unit_Table (U).Entity; + begin + return Present (E) and then E = Ent; + end Is_RTU; + + ---------------------------- + -- Is_Text_IO_Kludge_Unit -- + ---------------------------- + + function Is_Text_IO_Kludge_Unit (Nam : Node_Id) return Boolean is + Prf : Node_Id; + Sel : Node_Id; + + begin + if Nkind (Nam) /= N_Expanded_Name then + return False; + end if; + + Prf := Prefix (Nam); + Sel := Selector_Name (Nam); + + if Nkind (Sel) /= N_Expanded_Name + or else Nkind (Prf) /= N_Identifier + or else Chars (Prf) /= Name_Ada + then + return False; + end if; + + Prf := Prefix (Sel); + Sel := Selector_Name (Sel); + + return + Nkind (Prf) = N_Identifier + and then + (Chars (Prf) = Name_Text_IO + or else + Chars (Prf) = Name_Wide_Text_IO + or else + Chars (Prf) = Name_Wide_Wide_Text_IO) + and then + Nkind (Sel) = N_Identifier + and then + Chars (Sel) in Text_IO_Package_Name; + end Is_Text_IO_Kludge_Unit; + + --------------- + -- Load_Fail -- + --------------- + + procedure Load_Fail (S : String; U_Id : RTU_Id; Id : RE_Id) is + M : String (1 .. 100); + P : Natural := 0; + + begin + -- Output header message + + if Configurable_Run_Time_Mode then + RTE_Error_Msg ("construct not allowed in configurable run-time mode"); + else + RTE_Error_Msg ("run-time library configuration error"); + end if; + + -- Output file name and reason string + + M (1 .. 6) := "\file "; + P := 6; + + Get_Name_String + (Get_File_Name (RT_Unit_Table (U_Id).Uname, Subunit => False)); + M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len); + P := P + Name_Len; + + M (P + 1) := ' '; + P := P + 1; + + M (P + 1 .. P + S'Length) := S; + P := P + S'Length; + + RTE_Error_Msg (M (1 .. P)); + + -- Output entity name + + Output_Entity_Name (Id, "not available"); + + -- In configurable run time mode, we raise RE_Not_Available, and the + -- caller is expected to deal gracefully with this. In the case of a + -- call to RTE_Available, this exception will be caught in Rtsfind, + -- and result in a returned value of False for the call. + + if Configurable_Run_Time_Mode then + raise RE_Not_Available; + + -- Here we have a load failure in normal full run time mode. See if we + -- are in the context of an RTE_Available call. If so, we just raise + -- RE_Not_Available. This can happen if a unit is unavailable, which + -- happens for example in the VM case, where the run-time is not + -- complete, but we do not regard it as a configurable run-time. + -- If the caller has done an explicit call to RTE_Available, then + -- clearly the caller is prepared to deal with a result of False. + + elsif RTE_Available_Call then + RTE_Is_Available := False; + raise RE_Not_Available; + + -- If we are not in the context of an RTE_Available call, we are really + -- trying to load an entity that is not there, and that should never + -- happen, so in this case we signal a fatal error. + + else + raise Unrecoverable_Error; + end if; + end Load_Fail; + + -------------- + -- Load_RTU -- + -------------- + + procedure Load_RTU + (U_Id : RTU_Id; + Id : RE_Id := RE_Null; + Use_Setting : Boolean := False) + is + U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); + Priv_Par : constant Elist_Id := New_Elmt_List; + Lib_Unit : Node_Id; + + procedure Save_Private_Visibility; + -- If the current unit is the body of child unit or the spec of a + -- private child unit, the private declarations of the parent(s) are + -- visible. If the unit to be loaded is another public sibling, its + -- compilation will affect the visibility of the common ancestors. + -- Indicate those that must be restored. + + procedure Restore_Private_Visibility; + -- Restore the visibility of ancestors after compiling RTU + + -------------------------------- + -- Restore_Private_Visibility -- + -------------------------------- + + procedure Restore_Private_Visibility is + E_Par : Elmt_Id; + + begin + E_Par := First_Elmt (Priv_Par); + while Present (E_Par) loop + if not In_Private_Part (Node (E_Par)) then + Install_Private_Declarations (Node (E_Par)); + end if; + + Next_Elmt (E_Par); + end loop; + end Restore_Private_Visibility; + + ----------------------------- + -- Save_Private_Visibility -- + ----------------------------- + + procedure Save_Private_Visibility is + Par : Entity_Id; + + begin + Par := Scope (Current_Scope); + while Present (Par) + and then Par /= Standard_Standard + loop + if Ekind (Par) = E_Package + and then Is_Compilation_Unit (Par) + and then In_Private_Part (Par) + then + Append_Elmt (Par, Priv_Par); + end if; + + Par := Scope (Par); + end loop; + end Save_Private_Visibility; + + -- Start of processing for Load_RTU + + begin + -- Nothing to do if unit is already loaded + + if Present (U.Entity) then + return; + end if; + + -- Note if secondary stack is used + + if U_Id = System_Secondary_Stack then + Opt.Sec_Stack_Used := True; + end if; + + -- Otherwise we need to load the unit, First build unit name + -- from the enumeration literal name in type RTU_Id. + + U.Uname := Get_Unit_Name (U_Id); + U. First_Implicit_With := Empty; + + -- Now do the load call, note that setting Error_Node to Empty is + -- a signal to Load_Unit that we will regard a failure to find the + -- file as a fatal error, and that it should not output any kind + -- of diagnostics, since we will take care of it here. + + -- We save style checking switches and turn off style checking for + -- loading the unit, since we don't want any style checking! + + declare + Save_Style_Check : constant Boolean := Style_Check; + begin + Style_Check := False; + U.Unum := + Load_Unit + (Load_Name => U.Uname, + Required => False, + Subunit => False, + Error_Node => Empty); + Style_Check := Save_Style_Check; + end; + + -- Check for bad unit load + + if U.Unum = No_Unit then + Load_Fail ("not found", U_Id, Id); + elsif Fatal_Error (U.Unum) then + Load_Fail ("had parser errors", U_Id, Id); + end if; + + -- Make sure that the unit is analyzed + + declare + Was_Analyzed : constant Boolean := + Analyzed (Cunit (Current_Sem_Unit)); + + begin + -- Pretend that the current unit is analyzed, in case it is System + -- or some such. This allows us to put some declarations, such as + -- exceptions and packed arrays of Boolean, into System even though + -- expanding them requires System... + + -- This is a bit odd but works fine. If the RTS unit does not depend + -- in any way on the current unit, then it never gets back into the + -- current unit's tree, and the change we make to the current unit + -- tree is never noticed by anyone (it is undone in a moment). That + -- is the normal situation. + + -- If the RTS Unit *does* depend on the current unit, for instance, + -- when you are compiling System, then you had better have finished + -- analyzing the part of System that is depended on before you try to + -- load the RTS Unit. This means having the code in System ordered in + -- an appropriate manner. + + Set_Analyzed (Cunit (Current_Sem_Unit), True); + + if not Analyzed (Cunit (U.Unum)) then + + -- If the unit is already loaded through a limited_with_clause, + -- the relevant entities must already be available. We do not + -- want to load and analyze the unit because this would create + -- a real semantic dependence when the purpose of the limited_with + -- is precisely to avoid such. + + if From_With_Type (Cunit_Entity (U.Unum)) then + null; + + else + Save_Private_Visibility; + Semantics (Cunit (U.Unum)); + Restore_Private_Visibility; + + if Fatal_Error (U.Unum) then + Load_Fail ("had semantic errors", U_Id, Id); + end if; + end if; + end if; + + -- Undo the pretence + + Set_Analyzed (Cunit (Current_Sem_Unit), Was_Analyzed); + end; + + Lib_Unit := Unit (Cunit (U.Unum)); + U.Entity := Defining_Entity (Lib_Unit); + + if Use_Setting then + Set_Is_Potentially_Use_Visible (U.Entity, True); + end if; + end Load_RTU; + + -------------------- + -- Make_Unit_Name -- + -------------------- + + function Make_Unit_Name + (U : RT_Unit_Table_Record; + N : Node_Id) return Node_Id is + + Nam : Node_Id; + Scop : Entity_Id; + + begin + Nam := New_Reference_To (U.Entity, Standard_Location); + Scop := Scope (U.Entity); + + if Nkind (N) = N_Defining_Program_Unit_Name then + while Scop /= Standard_Standard loop + Nam := + Make_Expanded_Name (Standard_Location, + Chars => Chars (U.Entity), + Prefix => New_Reference_To (Scop, Standard_Location), + Selector_Name => Nam); + Set_Entity (Nam, U.Entity); + + Scop := Scope (Scop); + end loop; + end if; + + return Nam; + end Make_Unit_Name; + + -------------------- + -- Maybe_Add_With -- + -------------------- + + procedure Maybe_Add_With (U : in out RT_Unit_Table_Record) is + begin + -- We do not need to generate a with_clause for a call issued from + -- RTE_Component_Available. However, for CodePeer, we need these + -- additional with's, because for a sequence like "if RTE_Available (X) + -- then ... RTE (X)" the RTE call fails to create some necessary + -- with's. + + if RTE_Available_Call and then not Generate_SCIL then + return; + end if; + + -- Avoid creating directly self-referential with clauses + + if Current_Sem_Unit = U.Unum then + return; + end if; + + -- Add the with_clause, if not already in the context of the + -- current compilation unit. + + declare + LibUnit : constant Node_Id := Unit (Cunit (U.Unum)); + Clause : Node_Id; + Withn : Node_Id; + + begin + Clause := U.First_Implicit_With; + while Present (Clause) loop + if Parent (Clause) = Cunit (Current_Sem_Unit) then + return; + end if; + + Clause := Next_Implicit_With (Clause); + end loop; + + Withn := + Make_With_Clause (Standard_Location, + Name => + Make_Unit_Name + (U, Defining_Unit_Name (Specification (LibUnit)))); + + Set_Library_Unit (Withn, Cunit (U.Unum)); + Set_Corresponding_Spec (Withn, U.Entity); + Set_First_Name (Withn, True); + Set_Implicit_With (Withn, True); + Set_Next_Implicit_With (Withn, U.First_Implicit_With); + + U.First_Implicit_With := Withn; + + Mark_Rewrite_Insertion (Withn); + Append (Withn, Context_Items (Cunit (Current_Sem_Unit))); + Check_Restriction_No_Dependence (Name (Withn), Current_Error_Node); + end; + end Maybe_Add_With; + + ------------------------ + -- Output_Entity_Name -- + ------------------------ + + procedure Output_Entity_Name (Id : RE_Id; Msg : String) is + M : String (1 .. 2048); + P : Natural := 0; + -- M (1 .. P) is current message to be output + + RE_Image : constant String := RE_Id'Image (Id); + + begin + if Id = RE_Null then + return; + end if; + + M (1 .. 9) := "\entity """; + P := 9; + + -- Add unit name to message, excluding %s or %b at end + + Get_Name_String (Get_Unit_Name (RE_Unit_Table (Id))); + Name_Len := Name_Len - 2; + Set_Casing (Mixed_Case); + M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len); + P := P + Name_Len; + + -- Add a qualifying period + + M (P + 1) := '.'; + P := P + 1; + + -- Add entity name and closing quote to message + + Name_Len := RE_Image'Length - 3; + Name_Buffer (1 .. Name_Len) := RE_Image (4 .. RE_Image'Length); + Set_Casing (Mixed_Case); + M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len); + P := P + Name_Len; + M (P + 1) := '"'; + P := P + 1; + + -- Add message + + M (P + 1) := ' '; + P := P + 1; + M (P + 1 .. P + Msg'Length) := Msg; + P := P + Msg'Length; + + -- Output message at current error node location + + RTE_Error_Msg (M (1 .. P)); + end Output_Entity_Name; + + -------------- + -- RE_Chars -- + -------------- + + function RE_Chars (E : RE_Id) return Name_Id is + RE_Name_Chars : constant String := RE_Id'Image (E); + + begin + -- Copy name skipping initial RE_ or RO_XX characters + + if RE_Name_Chars (1 .. 2) = "RE" then + for J in 4 .. RE_Name_Chars'Last loop + Name_Buffer (J - 3) := Fold_Lower (RE_Name_Chars (J)); + end loop; + + Name_Len := RE_Name_Chars'Length - 3; + + else + for J in 7 .. RE_Name_Chars'Last loop + Name_Buffer (J - 6) := Fold_Lower (RE_Name_Chars (J)); + end loop; + + Name_Len := RE_Name_Chars'Length - 6; + end if; + + return Name_Find; + end RE_Chars; + + --------- + -- RTE -- + --------- + + function RTE (E : RE_Id) return Entity_Id is + U_Id : constant RTU_Id := RE_Unit_Table (E); + U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); + + Lib_Unit : Node_Id; + Pkg_Ent : Entity_Id; + Ename : Name_Id; + + -- The following flag is used to disable front-end inlining when RTE + -- is invoked. This prevents the analysis of other runtime bodies when + -- a particular spec is loaded through Rtsfind. This is both efficient, + -- and it prevents spurious visibility conflicts between use-visible + -- user entities, and entities in run-time packages. + + Save_Front_End_Inlining : Boolean; + + procedure Check_RPC; + -- Reject programs that make use of distribution features not supported + -- on the current target. Also check that the PCS is compatible with + -- the code generator version. On such targets (VMS, Vxworks, others?) + -- we provide a minimal body for System.Rpc that only supplies an + -- implementation of Partition_Id. + + function Find_Local_Entity (E : RE_Id) return Entity_Id; + -- This function is used when entity E is in this compilation's main + -- unit. It gets the value from the already compiled declaration. + + --------------- + -- Check_RPC -- + --------------- + + procedure Check_RPC is + begin + -- Bypass this check if debug flag -gnatdR set + + if Debug_Flag_RR then + return; + end if; + + -- Otherwise we need the check if we are going after one of the + -- critical entities in System.RPC / System.Partition_Interface. + + if E = RE_Do_Rpc + or else + E = RE_Do_Apc + or else + E = RE_Params_Stream_Type + or else + E = RE_Request_Access + then + -- If generating RCI stubs, check that we have a real PCS + + if (Distribution_Stub_Mode = Generate_Receiver_Stub_Body + or else + Distribution_Stub_Mode = Generate_Caller_Stub_Body) + and then Get_PCS_Name = Name_No_DSA + then + Set_Standard_Error; + Write_Str ("distribution feature not supported"); + Write_Eol; + raise Unrecoverable_Error; + + -- In all cases, check Exp_Dist and System.Partition_Interface + -- consistency. + + elsif Get_PCS_Version /= + Exp_Dist.PCS_Version_Number (Get_PCS_Name) + then + Set_Standard_Error; + Write_Str ("PCS version mismatch: expander "); + Write_Int (Exp_Dist.PCS_Version_Number (Get_PCS_Name)); + Write_Str (", PCS ("); + Write_Name (Get_PCS_Name); + Write_Str (") "); + Write_Int (Get_PCS_Version); + Write_Eol; + raise Unrecoverable_Error; + end if; + end if; + end Check_RPC; + + ----------------------- + -- Find_Local_Entity -- + ----------------------- + + function Find_Local_Entity (E : RE_Id) return Entity_Id is + RE_Str : constant String := RE_Id'Image (E); + Nam : Name_Id; + Ent : Entity_Id; + + Save_Nam : constant String := Name_Buffer (1 .. Name_Len); + -- Save name buffer and length over call + + begin + Name_Len := Natural'Max (0, RE_Str'Length - 3); + Name_Buffer (1 .. Name_Len) := + RE_Str (RE_Str'First + 3 .. RE_Str'Last); + + Nam := Name_Find; + Ent := Entity_Id (Get_Name_Table_Info (Nam)); + + Name_Len := Save_Nam'Length; + Name_Buffer (1 .. Name_Len) := Save_Nam; + + return Ent; + end Find_Local_Entity; + + -- Start of processing for RTE + + begin + -- Doing a rtsfind in system.ads is special, as we cannot do this + -- when compiling System itself. So if we are compiling system then + -- we should already have acquired and processed the declaration + -- of the entity. The test is to see if this compilation's main unit + -- is System. If so, return the value from the already compiled + -- declaration and otherwise do a regular find. + + -- Not pleasant, but these kinds of annoying recursion when + -- writing an Ada compiler in Ada have to be broken somewhere! + + if Present (Main_Unit_Entity) + and then Chars (Main_Unit_Entity) = Name_System + and then Analyzed (Main_Unit_Entity) + and then not Is_Child_Unit (Main_Unit_Entity) + then + return Check_CRT (E, Find_Local_Entity (E)); + end if; + + Save_Front_End_Inlining := Front_End_Inlining; + Front_End_Inlining := False; + + -- Load unit if unit not previously loaded + + if No (RE_Table (E)) then + Load_RTU (U_Id, Id => E); + Lib_Unit := Unit (Cunit (U.Unum)); + + -- In the subprogram case, we are all done, the entity we want + -- is the entity for the subprogram itself. Note that we do not + -- bother to check that it is the entity that was requested. + -- the only way that could fail to be the case is if runtime is + -- hopelessly misconfigured, and it isn't worth testing for this. + + if Nkind (Lib_Unit) = N_Subprogram_Declaration then + RE_Table (E) := U.Entity; + + -- Otherwise we must have the package case. First check package + -- entity itself (e.g. RTE_Name for System.Interrupts.Name) + + else + pragma Assert (Nkind (Lib_Unit) = N_Package_Declaration); + Ename := RE_Chars (E); + + -- First we search the package entity chain. If the package + -- only has a limited view, scan the corresponding list of + -- incomplete types. + + if From_With_Type (U.Entity) then + Pkg_Ent := First_Entity (Limited_View (U.Entity)); + else + Pkg_Ent := First_Entity (U.Entity); + end if; + + while Present (Pkg_Ent) loop + if Ename = Chars (Pkg_Ent) then + RE_Table (E) := Pkg_Ent; + Check_RPC; + goto Found; + end if; + + Next_Entity (Pkg_Ent); + end loop; + + -- If we did not find the entity in the package entity chain, + -- then check if the package entity itself matches. Note that + -- we do this check after searching the entity chain, since + -- the rule is that in case of ambiguity, we prefer the entity + -- defined within the package, rather than the package itself. + + if Ename = Chars (U.Entity) then + RE_Table (E) := U.Entity; + end if; + + -- If we didn't find the entity we want, something is wrong. + -- We just leave RE_Table (E) set to Empty and the appropriate + -- action will be taken by Check_CRT when we exit. + + end if; + end if; + + <> + Maybe_Add_With (U); + + Front_End_Inlining := Save_Front_End_Inlining; + return Check_CRT (E, RE_Table (E)); + end RTE; + + ------------------- + -- RTE_Available -- + ------------------- + + function RTE_Available (E : RE_Id) return Boolean is + Dummy : Entity_Id; + pragma Warnings (Off, Dummy); + + Result : Boolean; + + Save_RTE_Available_Call : constant Boolean := RTE_Available_Call; + Save_RTE_Is_Available : constant Boolean := RTE_Is_Available; + -- These are saved recursively because the call to load a unit + -- caused by an upper level call may perform a recursive call + -- to this routine during analysis of the corresponding unit. + + begin + RTE_Available_Call := True; + RTE_Is_Available := True; + Dummy := RTE (E); + Result := RTE_Is_Available; + RTE_Available_Call := Save_RTE_Available_Call; + RTE_Is_Available := Save_RTE_Is_Available; + return Result; + + exception + when RE_Not_Available => + RTE_Available_Call := Save_RTE_Available_Call; + RTE_Is_Available := Save_RTE_Is_Available; + return False; + end RTE_Available; + + -------------------------- + -- RTE_Record_Component -- + -------------------------- + + function RTE_Record_Component (E : RE_Id) return Entity_Id is + U_Id : constant RTU_Id := RE_Unit_Table (E); + U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); + E1 : Entity_Id; + Ename : Name_Id; + Found_E : Entity_Id; + Lib_Unit : Node_Id; + Pkg_Ent : Entity_Id; + + -- The following flag is used to disable front-end inlining when + -- RTE_Record_Component is invoked. This prevents the analysis of other + -- runtime bodies when a particular spec is loaded through Rtsfind. This + -- is both efficient, and it prevents spurious visibility conflicts + -- between use-visible user entities, and entities in run-time packages. + + Save_Front_End_Inlining : Boolean; + + begin + -- Note: Contrary to subprogram RTE, there is no need to do any special + -- management with package system.ads because it has no record type + -- declarations. + + Save_Front_End_Inlining := Front_End_Inlining; + Front_End_Inlining := False; + + -- Load unit if unit not previously loaded + + if not Present (U.Entity) then + Load_RTU (U_Id, Id => E); + end if; + + Lib_Unit := Unit (Cunit (U.Unum)); + + pragma Assert (Nkind (Lib_Unit) = N_Package_Declaration); + Ename := RE_Chars (E); + + -- Search the entity in the components of record type declarations + -- found in the package entity chain. + + Found_E := Empty; + Pkg_Ent := First_Entity (U.Entity); + Search : while Present (Pkg_Ent) loop + if Is_Record_Type (Pkg_Ent) then + E1 := First_Entity (Pkg_Ent); + while Present (E1) loop + if Ename = Chars (E1) then + pragma Assert (not Present (Found_E)); + Found_E := E1; + end if; + + Next_Entity (E1); + end loop; + end if; + + Next_Entity (Pkg_Ent); + end loop Search; + + -- If we didn't find the entity we want, something is wrong. The + -- appropriate action will be taken by Check_CRT when we exit. + + Maybe_Add_With (U); + + Front_End_Inlining := Save_Front_End_Inlining; + return Check_CRT (E, Found_E); + end RTE_Record_Component; + + ------------------------------------ + -- RTE_Record_Component_Available -- + ------------------------------------ + + function RTE_Record_Component_Available (E : RE_Id) return Boolean is + Dummy : Entity_Id; + pragma Warnings (Off, Dummy); + + Result : Boolean; + + Save_RTE_Available_Call : constant Boolean := RTE_Available_Call; + Save_RTE_Is_Available : constant Boolean := RTE_Is_Available; + -- These are saved recursively because the call to load a unit + -- caused by an upper level call may perform a recursive call + -- to this routine during analysis of the corresponding unit. + + begin + RTE_Available_Call := True; + RTE_Is_Available := True; + Dummy := RTE_Record_Component (E); + Result := RTE_Is_Available; + RTE_Available_Call := Save_RTE_Available_Call; + RTE_Is_Available := Save_RTE_Is_Available; + return Result; + + exception + when RE_Not_Available => + RTE_Available_Call := Save_RTE_Available_Call; + RTE_Is_Available := Save_RTE_Is_Available; + return False; + end RTE_Record_Component_Available; + + ------------------- + -- RTE_Error_Msg -- + ------------------- + + procedure RTE_Error_Msg (Msg : String) is + begin + if RTE_Available_Call then + RTE_Is_Available := False; + else + Error_Msg_N (Msg, Current_Error_Node); + + -- Bump count of violations if we are in configurable run-time + -- mode and this is not a continuation message. + + if Configurable_Run_Time_Mode and then Msg (Msg'First) /= '\' then + Configurable_Run_Time_Violations := + Configurable_Run_Time_Violations + 1; + end if; + end if; + end RTE_Error_Msg; + + ---------------- + -- RTU_Entity -- + ---------------- + + function RTU_Entity (U : RTU_Id) return Entity_Id is + begin + return RT_Unit_Table (U).Entity; + end RTU_Entity; + + ---------------- + -- RTU_Loaded -- + ---------------- + + function RTU_Loaded (U : RTU_Id) return Boolean is + begin + return Present (RT_Unit_Table (U).Entity); + end RTU_Loaded; + + -------------------- + -- Set_RTU_Loaded -- + -------------------- + + procedure Set_RTU_Loaded (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Unum : constant Unit_Number_Type := Get_Source_Unit (Loc); + Uname : constant Unit_Name_Type := Unit_Name (Unum); + E : constant Entity_Id := + Defining_Entity (Unit (Cunit (Unum))); + begin + pragma Assert (Is_Predefined_File_Name (Unit_File_Name (Unum))); + + -- Loop through entries in RTU table looking for matching entry + + for U_Id in RTU_Id'Range loop + + -- Here we have a match + + if Get_Unit_Name (U_Id) = Uname then + declare + U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); + -- The RT_Unit_Table entry that may need updating + + begin + -- If entry is not set, set it now, and indicate that it was + -- loaded through an explicit context clause. + + if No (U.Entity) then + U := (Entity => E, + Uname => Get_Unit_Name (U_Id), + Unum => Unum, + First_Implicit_With => Empty); + end if; + + return; + end; + end if; + end loop; + end Set_RTU_Loaded; + + -------------------- + -- Text_IO_Kludge -- + -------------------- + + procedure Text_IO_Kludge (Nam : Node_Id) is + Chrs : Name_Id; + + type Name_Map_Type is array (Text_IO_Package_Name) of RTU_Id; + + Name_Map : constant Name_Map_Type := Name_Map_Type'( + Name_Decimal_IO => Ada_Text_IO_Decimal_IO, + Name_Enumeration_IO => Ada_Text_IO_Enumeration_IO, + Name_Fixed_IO => Ada_Text_IO_Fixed_IO, + Name_Float_IO => Ada_Text_IO_Float_IO, + Name_Integer_IO => Ada_Text_IO_Integer_IO, + Name_Modular_IO => Ada_Text_IO_Modular_IO); + + Wide_Name_Map : constant Name_Map_Type := Name_Map_Type'( + Name_Decimal_IO => Ada_Wide_Text_IO_Decimal_IO, + Name_Enumeration_IO => Ada_Wide_Text_IO_Enumeration_IO, + Name_Fixed_IO => Ada_Wide_Text_IO_Fixed_IO, + Name_Float_IO => Ada_Wide_Text_IO_Float_IO, + Name_Integer_IO => Ada_Wide_Text_IO_Integer_IO, + Name_Modular_IO => Ada_Wide_Text_IO_Modular_IO); + + Wide_Wide_Name_Map : constant Name_Map_Type := Name_Map_Type'( + Name_Decimal_IO => Ada_Wide_Wide_Text_IO_Decimal_IO, + Name_Enumeration_IO => Ada_Wide_Wide_Text_IO_Enumeration_IO, + Name_Fixed_IO => Ada_Wide_Wide_Text_IO_Fixed_IO, + Name_Float_IO => Ada_Wide_Wide_Text_IO_Float_IO, + Name_Integer_IO => Ada_Wide_Wide_Text_IO_Integer_IO, + Name_Modular_IO => Ada_Wide_Wide_Text_IO_Modular_IO); + + To_Load : RTU_Id; + -- Unit to be loaded, from one of the above maps + + begin + -- Nothing to do if name is not an identifier or a selected component + -- whose selector_name is an identifier. + + if Nkind (Nam) = N_Identifier then + Chrs := Chars (Nam); + + elsif Nkind (Nam) = N_Selected_Component + and then Nkind (Selector_Name (Nam)) = N_Identifier + then + Chrs := Chars (Selector_Name (Nam)); + + else + return; + end if; + + -- Nothing to do if name is not one of the Text_IO subpackages + -- Otherwise look through loaded units, and if we find Text_IO + -- or [Wide_]Wide_Text_IO already loaded, then load the proper child. + + if Chrs in Text_IO_Package_Name then + for U in Main_Unit .. Last_Unit loop + Get_Name_String (Unit_File_Name (U)); + + if Name_Len = 12 then + + -- Here is where we do the loads if we find one of the units + -- Ada.Text_IO or Ada.[Wide_]Wide_Text_IO. An interesting + -- detail is that these units may already be used (i.e. their + -- In_Use flags may be set). Normally when the In_Use flag is + -- set, the Is_Potentially_Use_Visible flag of all entities in + -- the package is set, but the new entity we are mysteriously + -- adding was not there to have its flag set at the time. So + -- that's why we pass the extra parameter to RTU_Find, to make + -- sure the flag does get set now. Given that those generic + -- packages are in fact child units, we must indicate that + -- they are visible. + + if Name_Buffer (1 .. 12) = "a-textio.ads" then + To_Load := Name_Map (Chrs); + + elsif Name_Buffer (1 .. 12) = "a-witeio.ads" then + To_Load := Wide_Name_Map (Chrs); + + elsif Name_Buffer (1 .. 12) = "a-ztexio.ads" then + To_Load := Wide_Wide_Name_Map (Chrs); + + else + goto Continue; + end if; + + Load_RTU (To_Load, Use_Setting => In_Use (Cunit_Entity (U))); + Set_Is_Visible_Child_Unit (RT_Unit_Table (To_Load).Entity); + + -- Prevent creation of an implicit 'with' from (for example) + -- Ada.Wide_Text_IO.Integer_IO to Ada.Text_IO.Integer_IO, + -- because these could create cycles. First check whether the + -- simple names match ("integer_io" = "integer_io"), and then + -- check whether the parent is indeed one of the + -- [[Wide_]Wide_]Text_IO packages. + + if Chrs = Chars (Cunit_Entity (Current_Sem_Unit)) then + declare + Parent_Name : constant Unit_Name_Type := + Get_Parent_Spec_Name + (Unit_Name (Current_Sem_Unit)); + + begin + if Parent_Name /= No_Unit_Name then + Get_Name_String (Parent_Name); + + declare + P : String renames Name_Buffer (1 .. Name_Len); + begin + if P = "ada.text_io%s" or else + P = "ada.wide_text_io%s" or else + P = "ada.wide_wide_text_io%s" + then + goto Continue; + end if; + end; + end if; + end; + end if; + + -- Add an implicit with clause from the current unit to the + -- [[Wide_]Wide_]Text_IO child (if necessary). + + Maybe_Add_With (RT_Unit_Table (To_Load)); + end if; + + <> null; + end loop; + end if; + + exception + -- Generate error message if run-time unit not available + + when RE_Not_Available => + Error_Msg_N ("& not available", Nam); + end Text_IO_Kludge; + +end Rtsfind; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads new file mode 100644 index 000000000..ca8bfb854 --- /dev/null +++ b/gcc/ada/rtsfind.ads @@ -0,0 +1,3057 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- R T S F I N D -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Types; use Types; + +package Rtsfind is + +-- This package contains the routine that is used to obtain runtime library +-- entities, loading in the required runtime library packages on demand. It +-- is also used for such purposes as finding System.Address when System has +-- not been explicitly With'ed. + + ------------------------ + -- Runtime Unit Table -- + ------------------------ + + -- The following type includes an enumeration entry for each runtime unit. + -- The enumeration literal represents the fully qualified name of the unit, + -- as follows: + + -- Names of the form Ada_xxx are first level children of Ada, whose name + -- is Ada.xxx. For example, the name Ada_Tags refers to package Ada.Tags. + + -- Names of the form Ada_Calendar_xxx are second level children of + -- Ada.Calendar. This is part of a temporary implementation of delays; + -- eventually, packages implementing delays will be found relative to + -- the package that declares the time type. + + -- Names of the form Ada_Finalization_xxx are second level children of + -- Ada.Finalization. + + -- Names of the form Ada_Interrupts_xxx are second level children of + -- Ada.Interrupts. This is needed for Ada.Interrupts.Names which is used + -- by pragma Interrupt_State. + + -- Names of the form Ada_Real_Time_xxx are second level children of + -- Ada.Real_Time. + + -- Names of the form Ada_Streams_xxx are second level children + -- of Ada.Streams. + + -- Names of the form Ada_Strings_xxx are second level children + -- of Ada.Strings. + + -- Names of the form Ada_Text_IO_xxx are second level children of + -- Ada.Text_IO. + + -- Names of the form Ada_Wide_Text_IO_xxx are second level children of + -- Ada.Wide_Text_IO. + + -- Names of the form Ada_Wide_Wide_Text_IO_xxx are second level children + -- of Ada.Wide_Wide_Text_IO. + + -- Names of the form Interfaces_xxx are first level children of + -- Interfaces_CPP refers to package Interfaces.CPP + + -- Names of the form System_xxx are first level children of System, whose + -- name is System.xxx. For example, the name System_Str_Concat refers to + -- package System.Str_Concat. + + -- Names of the form System_Strings_xxx are second level children of the + -- package System.Strings. + + -- Names of the form System_Tasking_xxx are second level children of the + -- package System.Tasking. For example, System_Tasking_Stages refers to + -- the package System.Tasking.Stages. + + -- Other names stand for themselves (e.g. System for package System) + + -- This list can contain both subprogram and package unit names. For + -- packages, the accessible entities in the package are separately listed + -- in the package entity table. The units must be either library level + -- package declarations, or library level subprogram declarations. Generic + -- units, library level instantiations and subprogram bodies acting as + -- specs may not be referenced (all these cases could be added at the + -- expense of additional complexity in the body of Rtsfind, but it doesn't + -- seem worthwhile, since the implementation controls the set of units that + -- are referenced, and this restriction is easily met. + + -- IMPORTANT NOTE: the specs of packages and procedures with'ed using this + -- mechanism may not contain use clauses. This is because these subprograms + -- are compiled in the current visibility environment, and it would be too + -- much trouble to establish a clean environment for the compilation. The + -- presence of extraneous visible stuff has no effect on the compilation + -- except in the presence of use clauses (which might result in unexpected + -- ambiguities). + + type RTU_Id is ( + -- Runtime packages, for list of accessible entities in each + -- package see declarations in the runtime entity table below. + + RTU_Null, + -- Used as a null entry. Will cause an error if referenced + + -- Children of Ada + + Ada_Calendar, + Ada_Dispatching, + Ada_Exceptions, + Ada_Finalization, + Ada_Interrupts, + Ada_Real_Time, + Ada_Streams, + Ada_Strings, + Ada_Tags, + Ada_Task_Identification, + Ada_Task_Termination, + + -- Children of Ada.Calendar + + Ada_Calendar_Delays, + + -- Children of Ada.Dispatching + + Ada_Dispatching_EDF, + + -- Children of Ada.Finalization + + Ada_Finalization_List_Controller, + + -- Children of Ada.Interrupts + + Ada_Interrupts_Names, + + -- Children of Ada.Real_Time + + Ada_Real_Time_Delays, + Ada_Real_Time_Timing_Events, + + -- Children of Ada.Streams + + Ada_Streams_Stream_IO, + + -- Children of Ada.Strings + + Ada_Strings_Unbounded, + + -- Children of Ada.Text_IO (for Text_IO_Kludge) + + Ada_Text_IO_Decimal_IO, + Ada_Text_IO_Enumeration_IO, + Ada_Text_IO_Fixed_IO, + Ada_Text_IO_Float_IO, + Ada_Text_IO_Integer_IO, + Ada_Text_IO_Modular_IO, + + -- Children of Ada.Wide_Text_IO (for Text_IO_Kludge) + + Ada_Wide_Text_IO_Decimal_IO, + Ada_Wide_Text_IO_Enumeration_IO, + Ada_Wide_Text_IO_Fixed_IO, + Ada_Wide_Text_IO_Float_IO, + Ada_Wide_Text_IO_Integer_IO, + Ada_Wide_Text_IO_Modular_IO, + + -- Children of Ada.Wide_Wide_Text_IO (for Text_IO_Kludge) + + Ada_Wide_Wide_Text_IO_Decimal_IO, + Ada_Wide_Wide_Text_IO_Enumeration_IO, + Ada_Wide_Wide_Text_IO_Fixed_IO, + Ada_Wide_Wide_Text_IO_Float_IO, + Ada_Wide_Wide_Text_IO_Integer_IO, + Ada_Wide_Wide_Text_IO_Modular_IO, + + -- Interfaces + + Interfaces, + + -- Children of Interfaces + + Interfaces_CPP, + Interfaces_Packed_Decimal, + + -- Package System + + System, + + -- Children of System + + System_Address_Image, + System_Arith_64, + System_AST_Handling, + System_Assertions, + System_Aux_DEC, + System_Bit_Ops, + System_Boolean_Array_Operations, + System_Checked_Pools, + System_Compare_Array_Signed_16, + System_Compare_Array_Signed_32, + System_Compare_Array_Signed_64, + System_Compare_Array_Signed_8, + System_Compare_Array_Unsigned_16, + System_Compare_Array_Unsigned_32, + System_Compare_Array_Unsigned_64, + System_Compare_Array_Unsigned_8, + System_Concat_2, + System_Concat_3, + System_Concat_4, + System_Concat_5, + System_Concat_6, + System_Concat_7, + System_Concat_8, + System_Concat_9, + System_DSA_Services, + System_DSA_Types, + System_Exception_Table, + System_Exceptions, + System_Exn_Int, + System_Exn_LLF, + System_Exn_LLI, + System_Exp_Int, + System_Exp_LInt, + System_Exp_LLI, + System_Exp_LLU, + System_Exp_Mod, + System_Exp_Uns, + System_Fat_Flt, + System_Fat_IEEE_Long_Float, + System_Fat_IEEE_Short_Float, + System_Fat_LFlt, + System_Fat_LLF, + System_Fat_SFlt, + System_Fat_VAX_D_Float, + System_Fat_VAX_F_Float, + System_Fat_VAX_G_Float, + System_Finalization_Implementation, + System_Finalization_Root, + System_Fore, + System_Img_Bool, + System_Img_Char, + System_Img_Dec, + System_Img_Enum, + System_Img_Enum_New, + System_Img_Int, + System_Img_LLD, + System_Img_LLI, + System_Img_LLU, + System_Img_Name, + System_Img_Real, + System_Img_Uns, + System_Img_WChar, + System_Interrupts, + System_Machine_Code, + System_Mantissa, + System_Memcop, + System_Multiprocessors, + System_Pack_03, + System_Pack_05, + System_Pack_06, + System_Pack_07, + System_Pack_09, + System_Pack_10, + System_Pack_11, + System_Pack_12, + System_Pack_13, + System_Pack_14, + System_Pack_15, + System_Pack_17, + System_Pack_18, + System_Pack_19, + System_Pack_20, + System_Pack_21, + System_Pack_22, + System_Pack_23, + System_Pack_24, + System_Pack_25, + System_Pack_26, + System_Pack_27, + System_Pack_28, + System_Pack_29, + System_Pack_30, + System_Pack_31, + System_Pack_33, + System_Pack_34, + System_Pack_35, + System_Pack_36, + System_Pack_37, + System_Pack_38, + System_Pack_39, + System_Pack_40, + System_Pack_41, + System_Pack_42, + System_Pack_43, + System_Pack_44, + System_Pack_45, + System_Pack_46, + System_Pack_47, + System_Pack_48, + System_Pack_49, + System_Pack_50, + System_Pack_51, + System_Pack_52, + System_Pack_53, + System_Pack_54, + System_Pack_55, + System_Pack_56, + System_Pack_57, + System_Pack_58, + System_Pack_59, + System_Pack_60, + System_Pack_61, + System_Pack_62, + System_Pack_63, + System_Parameters, + System_Partition_Interface, + System_Pool_Global, + System_Pool_Empty, + System_Pool_Local, + System_Pool_Size, + System_RPC, + System_Scalar_Values, + System_Secondary_Stack, + System_Shared_Storage, + System_Soft_Links, + System_Standard_Library, + System_Storage_Elements, + System_Storage_Pools, + System_Stream_Attributes, + System_Task_Info, + System_Tasking, + System_Threads, + System_Unsigned_Types, + System_Val_Bool, + System_Val_Char, + System_Val_Dec, + System_Val_Enum, + System_Val_Int, + System_Val_LLD, + System_Val_LLI, + System_Val_LLU, + System_Val_Name, + System_Val_Real, + System_Val_Uns, + System_Val_WChar, + System_Vax_Float_Operations, + System_Version_Control, + System_VMS_Exception_Table, + System_WCh_StW, + System_WCh_WtS, + System_Wid_Bool, + System_Wid_Char, + System_Wid_Enum, + System_Wid_LLI, + System_Wid_LLU, + System_Wid_Name, + System_Wid_WChar, + System_WWd_Char, + System_WWd_Enum, + System_WWd_Wchar, + + -- Children of System.Strings + + System_Strings_Stream_Ops, + + -- Children of System.Tasking + + System_Tasking_Async_Delays, + System_Tasking_Async_Delays_Enqueue_Calendar, + System_Tasking_Async_Delays_Enqueue_RT, + System_Tasking_Protected_Objects, + System_Tasking_Protected_Objects_Entries, + System_Tasking_Protected_Objects_Operations, + System_Tasking_Protected_Objects_Single_Entry, + System_Tasking_Restricted_Stages, + System_Tasking_Rendezvous, + System_Tasking_Stages); + + subtype Ada_Child is RTU_Id + range Ada_Calendar .. Ada_Wide_Wide_Text_IO_Modular_IO; + -- Range of values for children or grand-children of Ada + + subtype Ada_Calendar_Child is Ada_Child + range Ada_Calendar_Delays .. Ada_Calendar_Delays; + -- Range of values for children of Ada.Calendar + + subtype Ada_Dispatching_Child is RTU_Id + range Ada_Dispatching_EDF .. Ada_Dispatching_EDF; + -- Range of values for children of Ada.Dispatching + + subtype Ada_Finalization_Child is Ada_Child range + Ada_Finalization_List_Controller .. Ada_Finalization_List_Controller; + -- Range of values for children of Ada.Finalization + + subtype Ada_Interrupts_Child is Ada_Child range + Ada_Interrupts_Names .. Ada_Interrupts_Names; + -- Range of values for children of Ada.Interrupts + + subtype Ada_Real_Time_Child is Ada_Child + range Ada_Real_Time_Delays .. Ada_Real_Time_Timing_Events; + -- Range of values for children of Ada.Real_Time + + subtype Ada_Streams_Child is Ada_Child + range Ada_Streams_Stream_IO .. Ada_Streams_Stream_IO; + -- Range of values for children of Ada.Streams + + subtype Ada_Strings_Child is Ada_Child + range Ada_Strings_Unbounded .. Ada_Strings_Unbounded; + -- Range of values for children of Ada.Strings + + subtype Ada_Text_IO_Child is Ada_Child + range Ada_Text_IO_Decimal_IO .. Ada_Text_IO_Modular_IO; + -- Range of values for children of Ada.Text_IO + + subtype Ada_Wide_Text_IO_Child is Ada_Child + range Ada_Wide_Text_IO_Decimal_IO .. Ada_Wide_Text_IO_Modular_IO; + -- Range of values for children of Ada.Text_IO + + subtype Ada_Wide_Wide_Text_IO_Child is Ada_Child + range Ada_Wide_Wide_Text_IO_Decimal_IO .. + Ada_Wide_Wide_Text_IO_Modular_IO; + + subtype Interfaces_Child is RTU_Id + range Interfaces_CPP .. Interfaces_Packed_Decimal; + -- Range of values for children of Interfaces + + subtype System_Child is RTU_Id + range System_Address_Image .. System_Tasking_Stages; + -- Range of values for children or grandchildren of System + + subtype System_Strings_Child is RTU_Id + range System_Strings_Stream_Ops .. System_Strings_Stream_Ops; + + subtype System_Tasking_Child is System_Child + range System_Tasking_Async_Delays .. System_Tasking_Stages; + -- Range of values for children of System.Tasking + + subtype System_Tasking_Protected_Objects_Child is System_Tasking_Child + range System_Tasking_Protected_Objects_Entries .. + System_Tasking_Protected_Objects_Single_Entry; + -- Range of values for children of System.Tasking.Protected_Objects + + subtype System_Tasking_Restricted_Child is System_Tasking_Child + range System_Tasking_Restricted_Stages .. + System_Tasking_Restricted_Stages; + -- Range of values for children of System.Tasking.Restricted + + subtype System_Tasking_Async_Delays_Child is System_Tasking_Child + range System_Tasking_Async_Delays_Enqueue_Calendar .. + System_Tasking_Async_Delays_Enqueue_RT; + -- Range of values for children of System.Tasking.Async_Delays + + -------------------------- + -- Runtime Entity Table -- + -------------------------- + + -- This is the enumeration type used to define the argument passed to + -- the RTE function. The name must exactly match the name of the entity + -- involved, and in the case of a package entity, this name must uniquely + -- imply the package containing the entity. + + -- As far as possible, we avoid duplicate names in runtime packages, so + -- that the name RE_nnn uniquely identifies the entity nnn. In some cases, + -- it is impossible to avoid such duplication because the names come from + -- RM defined packages. In such cases, the name is of the form RO_XX_nnn + -- where XX is two letters used to differentiate the multiple occurrences + -- of the name xx, and nnn is the entity name. + + -- Note that not all entities in the units contained in the run-time unit + -- table are included in the following table, only those that actually + -- have to be referenced from generated code. + + -- Note on RE_Null. This value is used as a null entry where an RE_Id + -- value is required syntactically, but no real entry is required or + -- needed. Use of this value will cause a fatal error in an RTE call. + + type RE_Id is ( + + RE_Null, + + RO_CA_Time, -- Ada.Calendar + + RO_CA_Delay_For, -- Ada.Calendar.Delays + RO_CA_Delay_Until, -- Ada.Calendar.Delays + RO_CA_To_Duration, -- Ada.Calendar.Delays + + RE_Set_Deadline, -- Ada.Dispatching.EDF + + RE_Code_Loc, -- Ada.Exceptions + RE_Current_Target_Exception, -- Ada.Exceptions (JGNAT use only) + RE_Exception_Id, -- Ada.Exceptions + RE_Exception_Information, -- Ada.Exceptions + RE_Exception_Message, -- Ada.Exceptions + RE_Exception_Name_Simple, -- Ada.Exceptions + RE_Exception_Occurrence, -- Ada.Exceptions + RE_Null_Id, -- Ada.Exceptions + RE_Null_Occurrence, -- Ada.Exceptions + RE_Poll, -- Ada.Exceptions + RE_Raise_Exception, -- Ada.Exceptions + RE_Raise_Exception_Always, -- Ada.Exceptions + RE_Raise_From_Controlled_Operation, -- Ada.Exceptions + RE_Reraise_Occurrence, -- Ada.Exceptions + RE_Reraise_Occurrence_Always, -- Ada.Exceptions + RE_Reraise_Occurrence_No_Defer, -- Ada.Exceptions + RE_Save_Occurrence, -- Ada.Exceptions + + RE_Simple_List_Controller, -- Ada.Finalization.List_Controller + RE_List_Controller, -- Ada.Finalization.List_Controller + + RE_Interrupt_ID, -- Ada.Interrupts + RE_Is_Reserved, -- Ada.Interrupts + RE_Is_Attached, -- Ada.Interrupts + RE_Current_Handler, -- Ada.Interrupts + RE_Attach_Handler, -- Ada.Interrupts + RE_Exchange_Handler, -- Ada.Interrupts + RE_Detach_Handler, -- Ada.Interrupts + RE_Reference, -- Ada.Interrupts + + RE_Names, -- Ada.Interrupts.Names + + RE_Clock, -- Ada.Real_Time + RE_Time_Span, -- Ada.Real_Time + RE_Time_Span_Zero, -- Ada.Real_Time + RO_RT_Time, -- Ada.Real_Time + + RO_RT_Delay_Until, -- Ada.Real_Time.Delays + RO_RT_To_Duration, -- Ada.Real_Time.Delays + + RE_Set_Handler, -- Ada_Real_Time.Timing_Events + RE_Timing_Event, -- Ada_Real_Time.Timing_Events + + RE_Root_Stream_Type, -- Ada.Streams + RE_Stream_Element, -- Ada.Streams + + RE_Stream_Access, -- Ada.Streams.Stream_IO + + RE_Unbounded_String, -- Ada.Strings.Unbounded + + RE_Access_Level, -- Ada.Tags + RE_Address_Array, -- Ada.Tags + RE_Addr_Ptr, -- Ada.Tags + RE_Base_Address, -- Ada.Tags + RE_Cstring_Ptr, -- Ada.Tags + RE_Descendant_Tag, -- Ada.Tags + RE_Dispatch_Table, -- Ada.Tags + RE_Dispatch_Table_Wrapper, -- Ada.Tags + RE_Displace, -- Ada.Tags + RE_DT, -- Ada.Tags + RE_DT_Offset_To_Top_Offset, -- Ada.Tags + RE_DT_Predef_Prims_Offset, -- Ada.Tags + RE_DT_Typeinfo_Ptr_Size, -- Ada.Tags + RE_External_Tag, -- Ada.Tags + RO_TA_External_Tag, -- Ada.Tags + RE_Get_Access_Level, -- Ada.Tags + RE_Get_Entry_Index, -- Ada.Tags + RE_Get_Offset_Index, -- Ada.Tags + RE_Get_Prim_Op_Kind, -- Ada.Tags + RE_Get_Tagged_Kind, -- Ada.Tags + RE_Idepth, -- Ada.Tags + RE_Interfaces_Array, -- Ada.Tags + RE_Interfaces_Table, -- Ada.Tags + RE_Interface_Data, -- Ada.Tags + RE_Interface_Data_Element, -- Ada.Tags + RE_Interface_Tag, -- Ada.Tags + RE_IW_Membership, -- Ada.Tags + RE_Max_Predef_Prims, -- Ada.Tags + RE_No_Dispatch_Table_Wrapper, -- Ada.Tags + RE_NDT_Prims_Ptr, -- Ada.Tags + RE_NDT_TSD, -- Ada.Tags + RE_Num_Prims, -- Ada.Tags + RE_Object_Specific_Data, -- Ada.Tags + RE_Offset_To_Top, -- Ada.Tags + RE_Offset_To_Top_Ptr, -- Ada.Tags + RE_Offset_To_Top_Function_Ptr, -- Ada.Tags + RE_OSD_Table, -- Ada.Tags + RE_OSD_Num_Prims, -- Ada.Tags + RE_POK_Function, -- Ada.Tags + RE_POK_Procedure, -- Ada.Tags + RE_POK_Protected_Entry, -- Ada.Tags + RE_POK_Protected_Function, -- Ada.Tags + RE_POK_Protected_Procedure, -- Ada.Tags + RE_POK_Task_Entry, -- Ada.Tags + RE_POK_Task_Function, -- Ada.Tags + RE_POK_Task_Procedure, -- Ada.Tags + RE_Predef_Prims, -- Ada.Tags + RE_Predef_Prims_Table_Ptr, -- Ada.Tags + RE_Prim_Op_Kind, -- Ada.Tags + RE_Prim_Ptr, -- Ada.Tags + RE_Prims_Ptr, -- Ada.Tags + RE_Primary_DT, -- Ada.Tags + RE_Signature, -- Ada.Tags + RE_SSD, -- Ada.Tags + RE_TSD, -- Ada.Tags + RE_Type_Is_Abstract, -- Ada.Tags + RE_Type_Specific_Data, -- Ada.Tags + RE_Register_Interface_Offset, -- Ada.Tags + RE_Register_Tag, -- Ada.Tags + RE_Transportable, -- Ada.Tags + RE_Secondary_DT, -- Ada.Tags + RE_Secondary_Tag, -- Ada.Tags + RE_Select_Specific_Data, -- Ada.Tags + RE_Set_Entry_Index, -- Ada.Tags + RE_Set_Dynamic_Offset_To_Top, -- Ada.Tags + RE_Set_Prim_Op_Kind, -- Ada.Tags + RE_Size_Func, -- Ada.Tags + RE_Size_Ptr, -- Ada.Tags + RE_Tag, -- Ada.Tags + RE_Tag_Error, -- Ada.Tags + RE_Tag_Kind, -- Ada.Tags + RE_Tag_Ptr, -- Ada.Tags + RE_Tag_Table, -- Ada.Tags + RE_Tags_Table, -- Ada.Tags + RE_Tagged_Kind, -- Ada.Tags + RE_Type_Specific_Data_Ptr, -- Ada.Tags + RE_TK_Abstract_Limited_Tagged, -- Ada.Tags + RE_TK_Abstract_Tagged, -- Ada.Tags + RE_TK_Limited_Tagged, -- Ada.Tags + RE_TK_Protected, -- Ada.Tags + RE_TK_Tagged, -- Ada.Tags + RE_TK_Task, -- Ada.Tags + + RE_Set_Specific_Handler, -- Ada.Task_Termination + RE_Specific_Handler, -- Ada.Task_Termination + + RE_Abort_Task, -- Ada.Task_Identification + RE_Current_Task, -- Ada.Task_Identification + RO_AT_Task_Id, -- Ada.Task_Identification + + RE_Integer_64, -- Interfaces + RE_Unsigned_8, -- Interfaces + RE_Unsigned_16, -- Interfaces + RE_Unsigned_32, -- Interfaces + RE_Unsigned_64, -- Interfaces + + RE_Address, -- System + RE_Any_Priority, -- System + RE_Bit_Order, -- System + RE_High_Order_First, -- System + RE_Interrupt_Priority, -- System + RE_Lib_Stop, -- System + RE_Low_Order_First, -- System + RE_Max_Priority, -- System + RE_Null_Address, -- System + RE_Priority, -- System + + RE_Address_Image, -- System.Address_Image + + RE_Add_With_Ovflo_Check, -- System.Arith_64 + RE_Double_Divide, -- System.Arith_64 + RE_Multiply_With_Ovflo_Check, -- System.Arith_64 + RE_Scaled_Divide, -- System.Arith_64 + RE_Subtract_With_Ovflo_Check, -- System.Arith_64 + + RE_Create_AST_Handler, -- System.AST_Handling + + RE_Assert_Failure, -- System.Assertions + RE_Raise_Assert_Failure, -- System.Assertions + + RE_AST_Handler, -- System.Aux_DEC + RE_Import_Value, -- System.Aux_DEC + RE_No_AST_Handler, -- System.Aux_DEC + RE_Type_Class, -- System.Aux_DEC + RE_Type_Class_Enumeration, -- System.Aux_DEC + RE_Type_Class_Integer, -- System.Aux_DEC + RE_Type_Class_Fixed_Point, -- System.Aux_DEC + RE_Type_Class_Floating_Point, -- System.Aux_DEC + RE_Type_Class_Array, -- System.Aux_DEC + RE_Type_Class_Record, -- System.Aux_DEC + RE_Type_Class_Access, -- System.Aux_DEC + RE_Type_Class_Task, -- System.Aux_DEC + RE_Type_Class_Address, -- System.Aux_DEC + + RE_Bit_And, -- System.Bit_Ops + RE_Bit_Eq, -- System.Bit_Ops + RE_Bit_Not, -- System.Bit_Ops + RE_Bit_Or, -- System.Bit_Ops + RE_Bit_Xor, -- System.Bit_Ops + + RE_Vector_Not, -- System_Boolean_Array_Operations, + RE_Vector_And, -- System_Boolean_Array_Operations, + RE_Vector_Or, -- System_Boolean_Array_Operations, + RE_Vector_Nand, -- System_Boolean_Array_Operations, + RE_Vector_Nor, -- System_Boolean_Array_Operations, + RE_Vector_Nxor, -- System_Boolean_Array_Operations, + RE_Vector_Xor, -- System_Boolean_Array_Operations, + + RE_Checked_Pool, -- System.Checked_Pools + + RE_Compare_Array_S8, -- System.Compare_Array_Signed_8 + RE_Compare_Array_S8_Unaligned, -- System.Compare_Array_Signed_8 + + RE_Compare_Array_S16, -- System.Compare_Array_Signed_16 + + RE_Compare_Array_S32, -- System.Compare_Array_Signed_16 + + RE_Compare_Array_S64, -- System.Compare_Array_Signed_16 + + RE_Compare_Array_U8, -- System.Compare_Array_Unsigned_8 + RE_Compare_Array_U8_Unaligned, -- System.Compare_Array_Unsigned_8 + + RE_Compare_Array_U16, -- System.Compare_Array_Unsigned_16 + + RE_Compare_Array_U32, -- System.Compare_Array_Unsigned_16 + + RE_Compare_Array_U64, -- System.Compare_Array_Unsigned_16 + + RE_Str_Concat_2, -- System.Concat_2 + RE_Str_Concat_3, -- System.Concat_3 + RE_Str_Concat_4, -- System.Concat_4 + RE_Str_Concat_5, -- System.Concat_5 + RE_Str_Concat_6, -- System.Concat_6 + RE_Str_Concat_7, -- System.Concat_7 + RE_Str_Concat_8, -- System.Concat_8 + RE_Str_Concat_9, -- System.Concat_9 + + RE_Str_Concat_Bounds_2, -- System.Concat_2 + RE_Str_Concat_Bounds_3, -- System.Concat_3 + RE_Str_Concat_Bounds_4, -- System.Concat_4 + RE_Str_Concat_Bounds_5, -- System.Concat_5 + RE_Str_Concat_Bounds_6, -- System.Concat_6 + RE_Str_Concat_Bounds_7, -- System.Concat_7 + RE_Str_Concat_Bounds_8, -- System.Concat_8 + RE_Str_Concat_Bounds_9, -- System.Concat_9 + + RE_Get_Active_Partition_Id, -- System.DSA_Services + RE_Get_Local_Partition_Id, -- System.DSA_Services + RE_Get_Passive_Partition_Id, -- System.DSA_Services + + RE_Any_Container_Ptr, -- System.DSA_Types + + RE_Register_Exception, -- System.Exception_Table + + RE_Local_Raise, -- System.Exceptions + + RE_Exn_Integer, -- System.Exn_Int + + RE_Exn_Long_Long_Float, -- System.Exn_LLF + + RE_Exn_Long_Long_Integer, -- System.Exn_LLI + + RE_Exp_Integer, -- System.Exp_Int + + RE_Exp_Long_Long_Integer, -- System.Exp_LLI + + RE_Exp_Long_Long_Unsigned, -- System.Exp_LLU + + RE_Exp_Modular, -- System.Exp_Mod + + RE_Exp_Unsigned, -- System.Exp_Uns + + RE_Attr_Float, -- System.Fat_Flt + + RE_Attr_IEEE_Long, -- System.Fat_IEEE_Long_Float + RE_Fat_IEEE_Long, -- System.Fat_IEEE_Long_Float + + RE_Attr_IEEE_Short, -- System.Fat_IEEE_Short_Float + RE_Fat_IEEE_Short, -- System.Fat_IEEE_Short_Float + + RE_Attr_Long_Float, -- System.Fat_LFlt + + RE_Attr_Long_Long_Float, -- System.Fat_LLF + + RE_Attr_Short_Float, -- System.Fat_SFlt + + RE_Attr_VAX_D_Float, -- System.Fat_VAX_D_Float + RE_Fat_VAX_D, -- System.Fat_VAX_D_Float + + RE_Attr_VAX_F_Float, -- System.Fat_VAX_F_Float + RE_Fat_VAX_F, -- System.Fat_VAX_F_Float + + RE_Attr_VAX_G_Float, -- System.Fat_VAX_G_Float + RE_Fat_VAX_G, -- System.Fat_VAX_G_Float + + RE_Attach_To_Final_List, -- System.Finalization_Implementation + RE_Finalizable_Ptr_Ptr, -- System.Finalization_Implementation + RE_Move_Final_List, -- System.Finalization_Implementation + RE_Finalize_List, -- System.Finalization_Implementation + RE_Finalize_One, -- System.Finalization_Implementation + RE_Global_Final_List, -- System.Finalization_Implementation + RE_Record_Controller, -- System.Finalization_Implementation + RE_Limited_Record_Controller, -- System.Finalization_Implementation + RE_Deep_Tag_Attach, -- System.Finalization_Implementation + + RE_Root_Controlled, -- System.Finalization_Root + RE_Finalizable, -- System.Finalization_Root + RE_Finalizable_Ptr, -- System.Finalization_Root + + RE_Fore, -- System.Fore + + RE_Image_Boolean, -- System.Img_Bool + + RE_Image_Character, -- System.Img_Char + RE_Image_Character_05, -- System.Img_Char + + RE_Image_Decimal, -- System.Img_Dec + + RE_Image_Enumeration_8, -- System.Img_Enum_New + RE_Image_Enumeration_16, -- System.Img_Enum_New + RE_Image_Enumeration_32, -- System.Img_Enum_New + + RE_Image_Integer, -- System.Img_Int + + RE_Image_Long_Long_Decimal, -- System.Img_LLD + + RE_Image_Long_Long_Integer, -- System.Img_LLI + + RE_Image_Long_Long_Unsigned, -- System.Img_LLU + + RE_Image_Ordinary_Fixed_Point, -- System.Img_Real + RE_Image_Floating_Point, -- System.Img_Real + + RE_Image_Unsigned, -- System.Img_Uns + + RE_Image_Wide_Character, -- System.Img_WChar + RE_Image_Wide_Wide_Character, -- System.Img_WChar + + RE_Bind_Interrupt_To_Entry, -- System.Interrupts + RE_Default_Interrupt_Priority, -- System.Interrupts + RE_Dynamic_Interrupt_Protection, -- System.Interrupts + RE_Install_Handlers, -- System.Interrupts + RE_Install_Restricted_Handlers, -- System.Interrupts + RE_Register_Interrupt_Handler, -- System.Interrupts + RE_Static_Interrupt_Protection, -- System.Interrupts + RE_System_Interrupt_Id, -- System.Interrupts + + RE_Asm_Insn, -- System.Machine_Code + RE_Asm_Input_Operand, -- System.Machine_Code + RE_Asm_Output_Operand, -- System.Machine_Code + + RE_Mantissa_Value, -- System_Mantissa + + RE_CPU_Range, -- System.Multiprocessors + + RE_Bits_03, -- System.Pack_03 + RE_Get_03, -- System.Pack_03 + RE_Set_03, -- System.Pack_03 + + RE_Bits_05, -- System.Pack_05 + RE_Get_05, -- System.Pack_05 + RE_Set_05, -- System.Pack_05 + + RE_Bits_06, -- System.Pack_06 + RE_Get_06, -- System.Pack_06 + RE_GetU_06, -- System.Pack_06 + RE_Set_06, -- System.Pack_06 + RE_SetU_06, -- System.Pack_06 + + RE_Bits_07, -- System.Pack_07 + RE_Get_07, -- System.Pack_07 + RE_Set_07, -- System.Pack_07 + + RE_Bits_09, -- System.Pack_09 + RE_Get_09, -- System.Pack_09 + RE_Set_09, -- System.Pack_09 + + RE_Bits_10, -- System.Pack_10 + RE_Get_10, -- System.Pack_10 + RE_GetU_10, -- System.Pack_10 + RE_Set_10, -- System.Pack_10 + RE_SetU_10, -- System.Pack_10 + + RE_Bits_11, -- System.Pack_11 + RE_Get_11, -- System.Pack_11 + RE_Set_11, -- System.Pack_11 + + RE_Bits_12, -- System.Pack_12 + RE_Get_12, -- System.Pack_12 + RE_GetU_12, -- System.Pack_12 + RE_Set_12, -- System.Pack_12 + RE_SetU_12, -- System.Pack_12 + + RE_Bits_13, -- System.Pack_13 + RE_Get_13, -- System.Pack_13 + RE_Set_13, -- System.Pack_13 + + RE_Bits_14, -- System.Pack_14 + RE_Get_14, -- System.Pack_14 + RE_GetU_14, -- System.Pack_14 + RE_Set_14, -- System.Pack_14 + RE_SetU_14, -- System.Pack_14 + + RE_Bits_15, -- System.Pack_15 + RE_Get_15, -- System.Pack_15 + RE_Set_15, -- System.Pack_15 + + RE_Bits_17, -- System.Pack_17 + RE_Get_17, -- System.Pack_17 + RE_Set_17, -- System.Pack_17 + + RE_Bits_18, -- System.Pack_18 + RE_Get_18, -- System.Pack_18 + RE_GetU_18, -- System.Pack_18 + RE_Set_18, -- System.Pack_18 + RE_SetU_18, -- System.Pack_18 + + RE_Bits_19, -- System.Pack_19 + RE_Get_19, -- System.Pack_19 + RE_Set_19, -- System.Pack_19 + + RE_Bits_20, -- System.Pack_20 + RE_Get_20, -- System.Pack_20 + RE_GetU_20, -- System.Pack_20 + RE_Set_20, -- System.Pack_20 + RE_SetU_20, -- System.Pack_20 + + RE_Bits_21, -- System.Pack_21 + RE_Get_21, -- System.Pack_21 + RE_Set_21, -- System.Pack_21 + + RE_Bits_22, -- System.Pack_22 + RE_Get_22, -- System.Pack_22 + RE_GetU_22, -- System.Pack_22 + RE_Set_22, -- System.Pack_22 + RE_SetU_22, -- System.Pack_22 + + RE_Bits_23, -- System.Pack_23 + RE_Get_23, -- System.Pack_23 + RE_Set_23, -- System.Pack_23 + + RE_Bits_24, -- System.Pack_24 + RE_Get_24, -- System.Pack_24 + RE_GetU_24, -- System.Pack_24 + RE_Set_24, -- System.Pack_24 + RE_SetU_24, -- System.Pack_24 + + RE_Bits_25, -- System.Pack_25 + RE_Get_25, -- System.Pack_25 + RE_Set_25, -- System.Pack_25 + + RE_Bits_26, -- System.Pack_26 + RE_Get_26, -- System.Pack_26 + RE_GetU_26, -- System.Pack_26 + RE_Set_26, -- System.Pack_26 + RE_SetU_26, -- System.Pack_26 + + RE_Bits_27, -- System.Pack_27 + RE_Get_27, -- System.Pack_27 + RE_Set_27, -- System.Pack_27 + + RE_Bits_28, -- System.Pack_28 + RE_Get_28, -- System.Pack_28 + RE_GetU_28, -- System.Pack_28 + RE_Set_28, -- System.Pack_28 + RE_SetU_28, -- System.Pack_28 + + RE_Bits_29, -- System.Pack_29 + RE_Get_29, -- System.Pack_29 + RE_Set_29, -- System.Pack_29 + + RE_Bits_30, -- System.Pack_30 + RE_Get_30, -- System.Pack_30 + RE_GetU_30, -- System.Pack_30 + RE_Set_30, -- System.Pack_30 + RE_SetU_30, -- System.Pack_30 + + RE_Bits_31, -- System.Pack_31 + RE_Get_31, -- System.Pack_31 + RE_Set_31, -- System.Pack_31 + + RE_Bits_33, -- System.Pack_33 + RE_Get_33, -- System.Pack_33 + RE_Set_33, -- System.Pack_33 + + RE_Bits_34, -- System.Pack_34 + RE_Get_34, -- System.Pack_34 + RE_GetU_34, -- System.Pack_34 + RE_Set_34, -- System.Pack_34 + RE_SetU_34, -- System.Pack_34 + + RE_Bits_35, -- System.Pack_35 + RE_Get_35, -- System.Pack_35 + RE_Set_35, -- System.Pack_35 + + RE_Bits_36, -- System.Pack_36 + RE_Get_36, -- System.Pack_36 + RE_GetU_36, -- System.Pack_36 + RE_Set_36, -- System.Pack_36 + RE_SetU_36, -- System.Pack_36 + + RE_Bits_37, -- System.Pack_37 + RE_Get_37, -- System.Pack_37 + RE_Set_37, -- System.Pack_37 + + RE_Bits_38, -- System.Pack_38 + RE_Get_38, -- System.Pack_38 + RE_GetU_38, -- System.Pack_38 + RE_Set_38, -- System.Pack_38 + RE_SetU_38, -- System.Pack_38 + + RE_Bits_39, -- System.Pack_39 + RE_Get_39, -- System.Pack_39 + RE_Set_39, -- System.Pack_39 + + RE_Bits_40, -- System.Pack_40 + RE_Get_40, -- System.Pack_40 + RE_GetU_40, -- System.Pack_40 + RE_Set_40, -- System.Pack_40 + RE_SetU_40, -- System.Pack_40 + + RE_Bits_41, -- System.Pack_41 + RE_Get_41, -- System.Pack_41 + RE_Set_41, -- System.Pack_41 + + RE_Bits_42, -- System.Pack_42 + RE_Get_42, -- System.Pack_42 + RE_GetU_42, -- System.Pack_42 + RE_Set_42, -- System.Pack_42 + RE_SetU_42, -- System.Pack_42 + + RE_Bits_43, -- System.Pack_43 + RE_Get_43, -- System.Pack_43 + RE_Set_43, -- System.Pack_43 + + RE_Bits_44, -- System.Pack_44 + RE_Get_44, -- System.Pack_44 + RE_GetU_44, -- System.Pack_44 + RE_Set_44, -- System.Pack_44 + RE_SetU_44, -- System.Pack_44 + + RE_Bits_45, -- System.Pack_45 + RE_Get_45, -- System.Pack_45 + RE_Set_45, -- System.Pack_45 + + RE_Bits_46, -- System.Pack_46 + RE_Get_46, -- System.Pack_46 + RE_GetU_46, -- System.Pack_46 + RE_Set_46, -- System.Pack_46 + RE_SetU_46, -- System.Pack_46 + + RE_Bits_47, -- System.Pack_47 + RE_Get_47, -- System.Pack_47 + RE_Set_47, -- System.Pack_47 + + RE_Bits_48, -- System.Pack_48 + RE_Get_48, -- System.Pack_48 + RE_GetU_48, -- System.Pack_48 + RE_Set_48, -- System.Pack_48 + RE_SetU_48, -- System.Pack_48 + + RE_Bits_49, -- System.Pack_49 + RE_Get_49, -- System.Pack_49 + RE_Set_49, -- System.Pack_49 + + RE_Bits_50, -- System.Pack_50 + RE_Get_50, -- System.Pack_50 + RE_GetU_50, -- System.Pack_50 + RE_Set_50, -- System.Pack_50 + RE_SetU_50, -- System.Pack_50 + + RE_Bits_51, -- System.Pack_51 + RE_Get_51, -- System.Pack_51 + RE_Set_51, -- System.Pack_51 + + RE_Bits_52, -- System.Pack_52 + RE_Get_52, -- System.Pack_52 + RE_GetU_52, -- System.Pack_52 + RE_Set_52, -- System.Pack_52 + RE_SetU_52, -- System.Pack_52 + + RE_Bits_53, -- System.Pack_53 + RE_Get_53, -- System.Pack_53 + RE_Set_53, -- System.Pack_53 + + RE_Bits_54, -- System.Pack_54 + RE_Get_54, -- System.Pack_54 + RE_GetU_54, -- System.Pack_54 + RE_Set_54, -- System.Pack_54 + RE_SetU_54, -- System.Pack_54 + + RE_Bits_55, -- System.Pack_55 + RE_Get_55, -- System.Pack_55 + RE_Set_55, -- System.Pack_55 + + RE_Bits_56, -- System.Pack_56 + RE_Get_56, -- System.Pack_56 + RE_GetU_56, -- System.Pack_56 + RE_Set_56, -- System.Pack_56 + RE_SetU_56, -- System.Pack_56 + + RE_Bits_57, -- System.Pack_57 + RE_Get_57, -- System.Pack_57 + RE_Set_57, -- System.Pack_57 + + RE_Bits_58, -- System.Pack_58 + RE_Get_58, -- System.Pack_58 + RE_GetU_58, -- System.Pack_58 + RE_Set_58, -- System.Pack_58 + RE_SetU_58, -- System.Pack_58 + + RE_Bits_59, -- System.Pack_59 + RE_Get_59, -- System.Pack_59 + RE_Set_59, -- System.Pack_59 + + RE_Bits_60, -- System.Pack_60 + RE_Get_60, -- System.Pack_60 + RE_GetU_60, -- System.Pack_60 + RE_Set_60, -- System.Pack_60 + RE_SetU_60, -- System.Pack_60 + + RE_Bits_61, -- System.Pack_61 + RE_Get_61, -- System.Pack_61 + RE_Set_61, -- System.Pack_61 + + RE_Bits_62, -- System.Pack_62 + RE_Get_62, -- System.Pack_62 + RE_GetU_62, -- System.Pack_62 + RE_Set_62, -- System.Pack_62 + RE_SetU_62, -- System.Pack_62 + + RE_Bits_63, -- System.Pack_63 + RE_Get_63, -- System.Pack_63 + RE_Set_63, -- System.Pack_63 + + RE_Adjust_Storage_Size, -- System_Parameters + RE_Default_Stack_Size, -- System.Parameters + RE_Garbage_Collected, -- System.Parameters + RE_Size_Type, -- System.Parameters + RE_Unspecified_Size, -- System.Parameters + + RE_DSA_Implementation, -- System.Partition_Interface + RE_PCS_Version, -- System.Partition_Interface + RE_Get_RACW, -- System.Partition_Interface + RE_Get_RCI_Package_Receiver, -- System.Partition_Interface + RE_Get_Unique_Remote_Pointer, -- System.Partition_Interface + RE_RACW_Stub_Type_Access, -- System.Partition_Interface + RE_RAS_Proxy_Type_Access, -- System.Partition_Interface + RE_Raise_Program_Error_Unknown_Tag, -- System.Partition_Interface + RE_Register_Passive_Package, -- System.Partition_Interface + RE_Register_Receiving_Stub, -- System.Partition_Interface + RE_Request, -- System.Partition_Interface + RE_Request_Access, -- System.Partition_Interface + RE_RCI_Locator, -- System.Partition_Interface + RE_RCI_Subp_Info, -- System.Partition_Interface + RE_RCI_Subp_Info_Array, -- System.Partition_Interface + RE_Same_Partition, -- System.Partition_Interface + RE_Subprogram_Id, -- System.Partition_Interface + RE_Get_RAS_Info, -- System.Partition_Interface + + RE_Global_Pool_Object, -- System.Pool_Global + + RE_Stack_Bounded_Pool, -- System.Pool_Size + + RE_Do_Apc, -- System.RPC + RE_Do_Rpc, -- System.RPC + RE_Params_Stream_Type, -- System.RPC + RE_Partition_ID, -- System.RPC + + RE_To_PolyORB_String, -- System.Partition_Interface + RE_Caseless_String_Eq, -- System.Partition_Interface + RE_TypeCode, -- System.Partition_Interface + RE_Any, -- System.Partition_Interface + RE_Mode_In, -- System.Partition_Interface + RE_Mode_Out, -- System.Partition_Interface + RE_Mode_Inout, -- System.Partition_Interface + RE_NamedValue, -- System.Partition_Interface + RE_Result_Name, -- System.Partition_Interface + RE_Object_Ref, -- System.Partition_Interface + RE_Create_Any, -- System.Partition_Interface + RE_Any_Aggregate_Build, -- System.Partition_Interface + RE_Add_Aggregate_Element, -- System.Partition_Interface + RE_Get_Aggregate_Element, -- System.Partition_Interface + RE_Content_Type, -- System.Partition_Interface + RE_Any_Member_Type, -- System.Partition_Interface + RE_Get_Nested_Sequence_Length, -- System.Partition_Interface + RE_Get_Any_Type, -- System.Partition_Interface + RE_Extract_Union_Value, -- System.Partition_Interface + RE_NVList_Ref, -- System.Partition_Interface + RE_NVList_Create, -- System.Partition_Interface + RE_NVList_Add_Item, -- System.Partition_Interface + RE_Request_Arguments, -- System.Partition_Interface + RE_Request_Invoke, -- System.Partition_Interface + RE_Request_Raise_Occurrence, -- System.Partition_Interface + RE_Request_Set_Out, -- System.Partition_Interface + RE_Request_Setup, -- System.Partition_Interface + RE_Nil_Exc_List, -- System.Partition_Interface + RE_Servant, -- System.Partition_Interface + RE_Move_Any_Value, -- System.Partition_Interface + RE_Set_Result, -- System.Partition_Interface + RE_Register_Obj_Receiving_Stub, -- System.Partition_Interface + RE_Register_Pkg_Receiving_Stub, -- System.Partition_Interface + RE_Is_Nil, -- System.Partition_Interface + RE_Entity_Ptr, -- System.Partition_Interface + RE_Entity_Of, -- System.Partition_Interface + RE_Inc_Usage, -- System.Partition_Interface + RE_Set_Ref, -- System.Partition_Interface + RE_Make_Ref, -- System.Partition_Interface + RE_Get_Local_Address, -- System.Partition_Interface + RE_Get_Reference, -- System.Partition_Interface + RE_Asynchronous_P_To_Sync_Scope, -- System.Partition_Interface + RE_Buffer_Stream_Type, -- System.Partition_Interface + RE_Release_Buffer, -- System.Partition_Interface + RE_BS_To_Any, -- System.Partition_Interface + RE_Any_To_BS, -- System.Partition_Interface + + RE_FA_A, -- System.Partition_Interface + RE_FA_B, -- System.Partition_Interface + RE_FA_C, -- System.Partition_Interface + RE_FA_F, -- System.Partition_Interface + RE_FA_I, -- System.Partition_Interface + RE_FA_LF, -- System.Partition_Interface + RE_FA_LI, -- System.Partition_Interface + RE_FA_LLF, -- System.Partition_Interface + RE_FA_LLI, -- System.Partition_Interface + RE_FA_LLU, -- System.Partition_Interface + RE_FA_LU, -- System.Partition_Interface + RE_FA_SF, -- System.Partition_Interface + RE_FA_SI, -- System.Partition_Interface + RE_FA_SSI, -- System.Partition_Interface + RE_FA_SSU, -- System.Partition_Interface + RE_FA_SU, -- System.Partition_Interface + RE_FA_U, -- System.Partition_Interface + RE_FA_WC, -- System.Partition_Interface + RE_FA_WWC, -- System.Partition_Interface + RE_FA_String, -- System.Partition_Interface + RE_FA_ObjRef, -- System.Partition_Interface + + RE_TA_A, -- System.Partition_Interface + RE_TA_B, -- System.Partition_Interface + RE_TA_C, -- System.Partition_Interface + RE_TA_F, -- System.Partition_Interface + RE_TA_I, -- System.Partition_Interface + RE_TA_LF, -- System.Partition_Interface + RE_TA_LI, -- System.Partition_Interface + RE_TA_LLF, -- System.Partition_Interface + RE_TA_LLI, -- System.Partition_Interface + RE_TA_LLU, -- System.Partition_Interface + RE_TA_LU, -- System.Partition_Interface + RE_TA_SF, -- System.Partition_Interface + RE_TA_SI, -- System.Partition_Interface + RE_TA_SSI, -- System.Partition_Interface + RE_TA_SSU, -- System.Partition_Interface + RE_TA_SU, -- System.Partition_Interface + RE_TA_U, -- System.Partition_Interface + RE_TA_WC, -- System.Partition_Interface + RE_TA_WWC, -- System.Partition_Interface + RE_TA_String, -- System.Partition_Interface + RE_TA_ObjRef, -- System.Partition_Interface + RE_TA_Std_String, -- System.Partition_Interface + RE_TA_TC, -- System.Partition_Interface + + RE_TC_Alias, -- System.Partition_Interface + RE_TC_Build, -- System.Partition_Interface + RE_Get_TC, -- System.Partition_Interface + RE_Set_TC, -- System.Partition_Interface + RE_TC_A, -- System.Partition_Interface + RE_TC_B, -- System.Partition_Interface + RE_TC_C, -- System.Partition_Interface + RE_TC_F, -- System.Partition_Interface + RE_TC_I, -- System.Partition_Interface + RE_TC_LF, -- System.Partition_Interface + RE_TC_LI, -- System.Partition_Interface + RE_TC_LLF, -- System.Partition_Interface + RE_TC_LLI, -- System.Partition_Interface + RE_TC_LLU, -- System.Partition_Interface + RE_TC_LU, -- System.Partition_Interface + RE_TC_SF, -- System.Partition_Interface + RE_TC_SI, -- System.Partition_Interface + RE_TC_SSI, -- System.Partition_Interface + RE_TC_SSU, -- System.Partition_Interface + RE_TC_SU, -- System.Partition_Interface + RE_TC_U, -- System.Partition_Interface + RE_TC_Void, -- System.Partition_Interface + RE_TC_Opaque, -- System.Partition_Interface + RE_TC_WC, -- System.Partition_Interface + RE_TC_WWC, -- System.Partition_Interface + RE_TC_Array, -- System.Partition_Interface + RE_TC_Sequence, -- System.Partition_Interface + RE_TC_String, -- System.Partition_Interface + RE_TC_Struct, -- System.Partition_Interface + RE_TC_Union, -- System.Partition_Interface + RE_TC_Object, -- System.Partition_Interface + + RE_IS_Is1, -- System.Scalar_Values + RE_IS_Is2, -- System.Scalar_Values + RE_IS_Is4, -- System.Scalar_Values + RE_IS_Is8, -- System.Scalar_Values + RE_IS_Iu1, -- System.Scalar_Values + RE_IS_Iu2, -- System.Scalar_Values + RE_IS_Iu4, -- System.Scalar_Values + RE_IS_Iu8, -- System.Scalar_Values + RE_IS_Iz1, -- System.Scalar_Values + RE_IS_Iz2, -- System.Scalar_Values + RE_IS_Iz4, -- System.Scalar_Values + RE_IS_Iz8, -- System.Scalar_Values + RE_IS_Isf, -- System.Scalar_Values + RE_IS_Ifl, -- System.Scalar_Values + RE_IS_Ilf, -- System.Scalar_Values + RE_IS_Ill, -- System.Scalar_Values + + RE_Default_Secondary_Stack_Size, -- System.Secondary_Stack + RE_Mark_Id, -- System.Secondary_Stack + RE_SS_Allocate, -- System.Secondary_Stack + RE_SS_Pool, -- System.Secondary_Stack + RE_SS_Mark, -- System.Secondary_Stack + RE_SS_Release, -- System.Secondary_Stack + + RE_Shared_Var_Lock, -- System.Shared_Storage + RE_Shared_Var_Unlock, -- System.Shared_Storage + RE_Shared_Var_Procs, -- System.Shared_Storage + + RE_Abort_Undefer_Direct, -- System.Standard_Library + RE_Exception_Code, -- System.Standard_Library + RE_Exception_Data_Ptr, -- System.Standard_Library + + RE_Integer_Address, -- System.Storage_Elements + RE_Storage_Offset, -- System.Storage_Elements + RE_Storage_Array, -- System.Storage_Elements + RE_To_Address, -- System.Storage_Elements + + RE_Root_Storage_Pool, -- System.Storage_Pools + RE_Allocate_Any, -- System.Storage_Pools, + RE_Deallocate_Any, -- System.Storage_Pools, + + RE_I_AD, -- System.Stream_Attributes + RE_I_AS, -- System.Stream_Attributes + RE_I_B, -- System.Stream_Attributes + RE_I_C, -- System.Stream_Attributes + RE_I_F, -- System.Stream_Attributes + RE_I_I, -- System.Stream_Attributes + RE_I_LF, -- System.Stream_Attributes + RE_I_LI, -- System.Stream_Attributes + RE_I_LLF, -- System.Stream_Attributes + RE_I_LLI, -- System.Stream_Attributes + RE_I_LLU, -- System.Stream_Attributes + RE_I_LU, -- System.Stream_Attributes + RE_I_SF, -- System.Stream_Attributes + RE_I_SI, -- System.Stream_Attributes + RE_I_SSI, -- System.Stream_Attributes + RE_I_SSU, -- System.Stream_Attributes + RE_I_SU, -- System.Stream_Attributes + RE_I_U, -- System.Stream_Attributes + RE_I_WC, -- System.Stream_Attributes + RE_I_WWC, -- System.Stream_Attributes + + RE_W_AD, -- System.Stream_Attributes + RE_W_AS, -- System.Stream_Attributes + RE_W_B, -- System.Stream_Attributes + RE_W_C, -- System.Stream_Attributes + RE_W_F, -- System.Stream_Attributes + RE_W_I, -- System.Stream_Attributes + RE_W_LF, -- System.Stream_Attributes + RE_W_LI, -- System.Stream_Attributes + RE_W_LLF, -- System.Stream_Attributes + RE_W_LLI, -- System.Stream_Attributes + RE_W_LLU, -- System.Stream_Attributes + RE_W_LU, -- System.Stream_Attributes + RE_W_SF, -- System.Stream_Attributes + RE_W_SI, -- System.Stream_Attributes + RE_W_SSI, -- System.Stream_Attributes + RE_W_SSU, -- System.Stream_Attributes + RE_W_SU, -- System.Stream_Attributes + RE_W_U, -- System.Stream_Attributes + RE_W_WC, -- System.Stream_Attributes + RE_W_WWC, -- System.Stream_Attributes + + RE_String_Input, -- System.Strings.Stream_Ops + RE_String_Input_Blk_IO, -- System.Strings.Stream_Ops + RE_String_Output, -- System.Strings.Stream_Ops + RE_String_Output_Blk_IO, -- System.Strings.Stream_Ops + RE_String_Read, -- System.Strings.Stream_Ops + RE_String_Read_Blk_IO, -- System.Strings.Stream_Ops + RE_String_Write, -- System.Strings.Stream_Ops + RE_String_Write_Blk_IO, -- System.Strings.Stream_Ops + RE_Wide_String_Input, -- System.Strings.Stream_Ops + RE_Wide_String_Input_Blk_IO, -- System.Strings.Stream_Ops + RE_Wide_String_Output, -- System.Strings.Stream_Ops + RE_Wide_String_Output_Blk_IO, -- System.Strings.Stream_Ops + RE_Wide_String_Read, -- System.Strings.Stream_Ops + RE_Wide_String_Read_Blk_IO, -- System.Strings.Stream_Ops + RE_Wide_String_Write, -- System.Strings.Stream_Ops + RE_Wide_String_Write_Blk_IO, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Input, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Input_Blk_IO, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Output, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Output_Blk_IO, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Read, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Read_Blk_IO, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Write, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Write_Blk_IO, -- System.Strings.Stream_Ops + + RE_Task_Info_Type, -- System.Task_Info + RE_Unspecified_Task_Info, -- System.Task_Info + + RE_Task_Procedure_Access, -- System.Tasking + + RO_ST_Task_Id, -- System.Tasking + RO_ST_Null_Task, -- System.Tasking + + RE_Call_Modes, -- System.Tasking + RE_Simple_Call, -- System.Tasking + RE_Conditional_Call, -- System.Tasking + RE_Asynchronous_Call, -- System.Tasking + + RE_Foreign_Task_Level, -- System.Tasking + RE_Environment_Task_Level, -- System.Tasking + RE_Independent_Task_Level, -- System.Tasking + RE_Library_Task_Level, -- System.Tasking + + RE_Ada_Task_Control_Block, -- System.Tasking + + RE_Task_List, -- System.Tasking + + RE_Accept_List, -- System.Tasking + RE_No_Rendezvous, -- System.Tasking + RE_Null_Task_Entry, -- System.Tasking + RE_Select_Index, -- System.Tasking + RE_Else_Mode, -- System.Tasking + RE_Simple_Mode, -- System.Tasking + RE_Terminate_Mode, -- System.Tasking + RE_Delay_Mode, -- System.Tasking + RE_Task_Entry_Index, -- System.Tasking + RE_Self, -- System.Tasking + + RE_Master_Id, -- System.Tasking + RE_Unspecified_Priority, -- System.Tasking + + RE_Activation_Chain, -- System.Tasking + RE_Activation_Chain_Access, -- System.Tasking + RE_Storage_Size, -- System.Tasking + + RE_Unspecified_CPU, -- System.Tasking + + RE_Abort_Defer, -- System.Soft_Links + RE_Abort_Undefer, -- System.Soft_Links + RE_Complete_Master, -- System.Soft_Links + RE_Current_Master, -- System.Soft_Links + RE_Dummy_Communication_Block, -- System.Soft_Links + RE_Enter_Master, -- System.Soft_Links + RE_Get_Current_Excep, -- System.Soft_Links + RE_Get_GNAT_Exception, -- System.Soft_Links + RE_Update_Exception, -- System.Soft_Links + + RE_Bits_1, -- System.Unsigned_Types + RE_Bits_2, -- System.Unsigned_Types + RE_Bits_4, -- System.Unsigned_Types + RE_Float_Unsigned, -- System.Unsigned_Types + RE_Long_Unsigned, -- System.Unsigned_Types + RE_Long_Long_Unsigned, -- System.Unsigned_Types + RE_Packed_Byte, -- System.Unsigned_Types + RE_Packed_Bytes1, -- System.Unsigned_Types + RE_Packed_Bytes2, -- System.Unsigned_Types + RE_Packed_Bytes4, -- System.Unsigned_Types + RE_Short_Unsigned, -- System.Unsigned_Types + RE_Short_Short_Unsigned, -- System.Unsigned_Types + RE_Unsigned, -- System.Unsigned_Types + + RE_Value_Boolean, -- System.Val_Bool + + RE_Value_Character, -- System.Val_Char + + RE_Value_Decimal, -- System.Val_Dec + + RE_Value_Enumeration_8, -- System.Val_Enum + RE_Value_Enumeration_16, -- System.Val_Enum + RE_Value_Enumeration_32, -- System.Val_Enum + + RE_Value_Integer, -- System.Val_Int + + RE_Value_Long_Long_Decimal, -- System.Val_LLD + + RE_Value_Long_Long_Integer, -- System.Val_LLI + + RE_Value_Long_Long_Unsigned, -- System.Val_LLU + + RE_Value_Real, -- System.Val_Real + + RE_Value_Unsigned, -- System.Val_Uns + + RE_Value_Wide_Character, -- System.Val_WChar + RE_Value_Wide_Wide_Character, -- System.Val_WChar + + RE_D, -- System.Vax_Float_Operations + RE_F, -- System.Vax_Float_Operations + RE_G, -- System.Vax_Float_Operations + RE_Q, -- System.Vax_Float_Operations + RE_S, -- System.Vax_Float_Operations + RE_T, -- System.Vax_Float_Operations + + RE_D_To_G, -- System.Vax_Float_Operations + RE_F_To_G, -- System.Vax_Float_Operations + RE_F_To_Q, -- System.Vax_Float_Operations + RE_F_To_S, -- System.Vax_Float_Operations + RE_G_To_D, -- System.Vax_Float_Operations + RE_G_To_F, -- System.Vax_Float_Operations + RE_G_To_Q, -- System.Vax_Float_Operations + RE_G_To_T, -- System.Vax_Float_Operations + RE_Q_To_F, -- System.Vax_Float_Operations + RE_Q_To_G, -- System.Vax_Float_Operations + RE_S_To_F, -- System.Vax_Float_Operations + RE_T_To_D, -- System.Vax_Float_Operations + RE_T_To_G, -- System.Vax_Float_Operations + + RE_Abs_F, -- System.Vax_Float_Operations + RE_Abs_G, -- System.Vax_Float_Operations + RE_Add_F, -- System.Vax_Float_Operations + RE_Add_G, -- System.Vax_Float_Operations + RE_Div_F, -- System.Vax_Float_Operations + RE_Div_G, -- System.Vax_Float_Operations + RE_Mul_F, -- System.Vax_Float_Operations + RE_Mul_G, -- System.Vax_Float_Operations + RE_Neg_F, -- System.Vax_Float_Operations + RE_Neg_G, -- System.Vax_Float_Operations + RE_Return_D, -- System.Vax_Float_Operations + RE_Return_F, -- System.Vax_Float_Operations + RE_Return_G, -- System.Vax_Float_Operations + RE_Sub_F, -- System.Vax_Float_Operations + RE_Sub_G, -- System.Vax_Float_Operations + + RE_Eq_F, -- System.Vax_Float_Operations + RE_Eq_G, -- System.Vax_Float_Operations + RE_Le_F, -- System.Vax_Float_Operations + RE_Le_G, -- System.Vax_Float_Operations + RE_Lt_F, -- System.Vax_Float_Operations + RE_Lt_G, -- System.Vax_Float_Operations + RE_Ne_F, -- System.Vax_Float_Operations + RE_Ne_G, -- System.Vax_Float_Operations + + RE_Valid_D, -- System.Vax_Float_Operations + RE_Valid_F, -- System.Vax_Float_Operations + RE_Valid_G, -- System.Vax_Float_Operations + + RE_Version_String, -- System.Version_Control + RE_Get_Version_String, -- System.Version_Control + + RE_Register_VMS_Exception, -- System.VMS_Exception_Table + + RE_String_To_Wide_String, -- System.WCh_StW + RE_String_To_Wide_Wide_String, -- System.WCh_StW + + RE_Wide_String_To_String, -- System.WCh_WtS + RE_Wide_Wide_String_To_String, -- System.WCh_WtS + + RE_Wide_Width_Character, -- System.WWd_Char + RE_Wide_Wide_Width_Character, -- System.WWd_Char + + RE_Wide_Wide_Width_Enumeration_8, -- System.WWd_Enum + RE_Wide_Wide_Width_Enumeration_16, -- System.WWd_Enum + RE_Wide_Wide_Width_Enumeration_32, -- System.WWd_Enum + + RE_Wide_Width_Enumeration_8, -- System.WWd_Enum + RE_Wide_Width_Enumeration_16, -- System.WWd_Enum + RE_Wide_Width_Enumeration_32, -- System.WWd_Enum + + RE_Wide_Wide_Width_Wide_Character, -- System.WWd_Wchar + RE_Wide_Wide_Width_Wide_Wide_Char, -- System.WWd_Wchar + RE_Wide_Width_Wide_Character, -- System.WWd_Wchar + RE_Wide_Width_Wide_Wide_Character, -- System.WWd_Wchar + + RE_Width_Boolean, -- System.Wid_Bool + + RE_Width_Character, -- System.Wid_Char + + RE_Width_Enumeration_8, -- System.Wid_Enum + RE_Width_Enumeration_16, -- System.Wid_Enum + RE_Width_Enumeration_32, -- System.Wid_Enum + + RE_Width_Long_Long_Integer, -- System.Wid_LLI + + RE_Width_Long_Long_Unsigned, -- System.Wid_LLU + + RE_Width_Wide_Character, -- System.Wid_WChar + RE_Width_Wide_Wide_Character, -- System.Wid_WChar + + RE_Protected_Entry_Body_Array, -- Tasking.Protected_Objects.Entries + RE_Protection_Entries, -- Tasking.Protected_Objects.Entries + RE_Protection_Entries_Access, -- Tasking.Protected_Objects.Entries + RE_Initialize_Protection_Entries, -- Tasking.Protected_Objects.Entries + RE_Lock_Entries, -- Tasking.Protected_Objects.Entries + RO_PE_Get_Ceiling, -- Tasking.Protected_Objects.Entries + RO_PE_Set_Ceiling, -- Tasking.Protected_Objects.Entries + RO_PE_Set_Entry_Name, -- Tasking.Protected_Objects.Entries + RE_Unlock_Entries, -- Tasking.Protected_Objects.Entries + + RE_Communication_Block, -- Protected_Objects.Operations + RE_Protected_Entry_Call, -- Protected_Objects.Operations + RE_Service_Entries, -- Protected_Objects.Operations + RE_Cancel_Protected_Entry_Call, -- Protected_Objects.Operations + RE_Enqueued, -- Protected_Objects.Operations + RE_Cancelled, -- Protected_Objects.Operations + RE_Complete_Entry_Body, -- Protected_Objects.Operations + RE_Exceptional_Complete_Entry_Body, -- Protected_Objects.Operations + RE_Requeue_Protected_Entry, -- Protected_Objects.Operations + RE_Requeue_Task_To_Protected_Entry, -- Protected_Objects.Operations + RE_Protected_Count, -- Protected_Objects.Operations + RE_Protected_Entry_Caller, -- Protected_Objects.Operations + RE_Timed_Protected_Entry_Call, -- Protected_Objects.Operations + + RE_Protection_Entry, -- Protected_Objects.Single_Entry + RE_Initialize_Protection_Entry, -- Protected_Objects.Single_Entry + RE_Lock_Entry, -- Protected_Objects.Single_Entry + RE_Unlock_Entry, -- Protected_Objects.Single_Entry + RE_Protected_Single_Entry_Call, -- Protected_Objects.Single_Entry + RE_Service_Entry, -- Protected_Objects.Single_Entry + RE_Complete_Single_Entry_Body, -- Protected_Objects.Single_Entry + RE_Exceptional_Complete_Single_Entry_Body, + RE_Protected_Count_Entry, -- Protected_Objects.Single_Entry + RE_Protected_Single_Entry_Caller, -- Protected_Objects.Single_Entry + RE_Timed_Protected_Single_Entry_Call, + + RE_Protected_Entry_Index, -- System.Tasking.Protected_Objects + RE_Entry_Body, -- System.Tasking.Protected_Objects + RE_Protection, -- System.Tasking.Protected_Objects + RE_Initialize_Protection, -- System.Tasking.Protected_Objects + RE_Finalize_Protection, -- System.Tasking.Protected_Objects + RE_Lock, -- System.Tasking.Protected_Objects + RE_Get_Ceiling, -- System.Tasking.Protected_Objects + RE_Set_Ceiling, -- System.Tasking.Protected_Objects + RE_Unlock, -- System.Tasking.Protected_Objects + + RE_Delay_Block, -- System.Tasking.Async_Delays + RE_Timed_Out, -- System.Tasking.Async_Delays + RE_Cancel_Async_Delay, -- System.Tasking.Async_Delays + RE_Enqueue_Duration, -- System.Tasking.Async_Delays + RE_Enqueue_Calendar, -- System.Tasking.Async_Delays + RE_Enqueue_RT, -- System.Tasking.Async_Delays + + RE_Accept_Call, -- System.Tasking.Rendezvous + RE_Accept_Trivial, -- System.Tasking.Rendezvous + RE_Callable, -- System.Tasking.Rendezvous + RE_Call_Simple, -- System.Tasking.Rendezvous + RE_Requeue_Task_Entry, -- System.Tasking.Rendezvous + RE_Requeue_Protected_To_Task_Entry, -- System.Tasking.Rendezvous + RE_Cancel_Task_Entry_Call, -- System.Tasking.Rendezvous + RE_Complete_Rendezvous, -- System.Tasking.Rendezvous + RE_Task_Count, -- System.Tasking.Rendezvous + RE_Exceptional_Complete_Rendezvous, -- System.Tasking.Rendezvous + RE_Selective_Wait, -- System.Tasking.Rendezvous + RE_Task_Entry_Call, -- System.Tasking.Rendezvous + RE_Task_Entry_Caller, -- System.Tasking.Rendezvous + RE_Timed_Task_Entry_Call, -- System.Tasking.Rendezvous + RE_Timed_Selective_Wait, -- System.Tasking.Rendezvous + + RE_Activate_Restricted_Tasks, -- System.Tasking.Restricted.Stages + RE_Complete_Restricted_Activation, -- System.Tasking.Restricted.Stages + RE_Create_Restricted_Task, -- System.Tasking.Restricted.Stages + RE_Complete_Restricted_Task, -- System.Tasking.Restricted.Stages + RE_Restricted_Terminated, -- System.Tasking.Restricted.Stages + + RE_Abort_Tasks, -- System.Tasking.Stages + RE_Activate_Tasks, -- System.Tasking.Stages + RE_Complete_Activation, -- System.Tasking.Stages + RE_Create_Task, -- System.Tasking.Stages + RE_Complete_Task, -- System.Tasking.Stages + RE_Free_Task, -- System.Tasking.Stages + RE_Expunge_Unactivated_Tasks, -- System.Tasking.Stages + RE_Move_Activation_Chain, -- System_Tasking_Stages + RO_TS_Set_Entry_Name, -- System.Tasking.Stages + RE_Terminated); -- System.Tasking.Stages + + -- The following declarations build a table that is indexed by the RTE + -- function to determine the unit containing the given entity. This table + -- is sorted in order of package names. + + RE_Unit_Table : constant array (RE_Id) of RTU_Id := ( + + RE_Null => RTU_Null, + + RO_CA_Time => Ada_Calendar, + + RO_CA_Delay_For => Ada_Calendar_Delays, + RO_CA_Delay_Until => Ada_Calendar_Delays, + RO_CA_To_Duration => Ada_Calendar_Delays, + + RE_Set_Deadline => Ada_Dispatching_EDF, + + RE_Code_Loc => Ada_Exceptions, + RE_Current_Target_Exception => Ada_Exceptions, -- of JGNAT + RE_Exception_Id => Ada_Exceptions, + RE_Exception_Information => Ada_Exceptions, + RE_Exception_Message => Ada_Exceptions, + RE_Exception_Name_Simple => Ada_Exceptions, + RE_Exception_Occurrence => Ada_Exceptions, + RE_Null_Id => Ada_Exceptions, + RE_Null_Occurrence => Ada_Exceptions, + RE_Poll => Ada_Exceptions, + RE_Raise_Exception => Ada_Exceptions, + RE_Raise_Exception_Always => Ada_Exceptions, + RE_Raise_From_Controlled_Operation => Ada_Exceptions, + RE_Reraise_Occurrence => Ada_Exceptions, + RE_Reraise_Occurrence_Always => Ada_Exceptions, + RE_Reraise_Occurrence_No_Defer => Ada_Exceptions, + RE_Save_Occurrence => Ada_Exceptions, + + RE_Simple_List_Controller => Ada_Finalization_List_Controller, + RE_List_Controller => Ada_Finalization_List_Controller, + + RE_Interrupt_ID => Ada_Interrupts, + RE_Is_Reserved => Ada_Interrupts, + RE_Is_Attached => Ada_Interrupts, + RE_Current_Handler => Ada_Interrupts, + RE_Attach_Handler => Ada_Interrupts, + RE_Exchange_Handler => Ada_Interrupts, + RE_Detach_Handler => Ada_Interrupts, + RE_Reference => Ada_Interrupts, + + RE_Names => Ada_Interrupts_Names, + + RE_Clock => Ada_Real_Time, + RE_Time_Span => Ada_Real_Time, + RE_Time_Span_Zero => Ada_Real_Time, + RO_RT_Time => Ada_Real_Time, + + RO_RT_Delay_Until => Ada_Real_Time_Delays, + RO_RT_To_Duration => Ada_Real_Time_Delays, + + RE_Set_Handler => Ada_Real_Time_Timing_Events, + RE_Timing_Event => Ada_Real_Time_Timing_Events, + + RE_Root_Stream_Type => Ada_Streams, + RE_Stream_Element => Ada_Streams, + + RE_Stream_Access => Ada_Streams_Stream_IO, + + RE_Unbounded_String => Ada_Strings_Unbounded, + + RE_Access_Level => Ada_Tags, + RE_Address_Array => Ada_Tags, + RE_Addr_Ptr => Ada_Tags, + RE_Base_Address => Ada_Tags, + RE_Cstring_Ptr => Ada_Tags, + RE_Descendant_Tag => Ada_Tags, + RE_Dispatch_Table => Ada_Tags, + RE_Dispatch_Table_Wrapper => Ada_Tags, + RE_Displace => Ada_Tags, + RE_DT => Ada_Tags, + RE_DT_Offset_To_Top_Offset => Ada_Tags, + RE_DT_Predef_Prims_Offset => Ada_Tags, + RE_DT_Typeinfo_Ptr_Size => Ada_Tags, + RE_External_Tag => Ada_Tags, + RO_TA_External_Tag => Ada_Tags, + RE_Get_Access_Level => Ada_Tags, + RE_Get_Entry_Index => Ada_Tags, + RE_Get_Offset_Index => Ada_Tags, + RE_Get_Prim_Op_Kind => Ada_Tags, + RE_Get_Tagged_Kind => Ada_Tags, + RE_Idepth => Ada_Tags, + RE_Interfaces_Array => Ada_Tags, + RE_Interfaces_Table => Ada_Tags, + RE_Interface_Data => Ada_Tags, + RE_Interface_Data_Element => Ada_Tags, + RE_Interface_Tag => Ada_Tags, + RE_IW_Membership => Ada_Tags, + RE_Max_Predef_Prims => Ada_Tags, + RE_No_Dispatch_Table_Wrapper => Ada_Tags, + RE_NDT_Prims_Ptr => Ada_Tags, + RE_NDT_TSD => Ada_Tags, + RE_Num_Prims => Ada_Tags, + RE_Object_Specific_Data => Ada_Tags, + RE_Offset_To_Top => Ada_Tags, + RE_Offset_To_Top_Ptr => Ada_Tags, + RE_Offset_To_Top_Function_Ptr => Ada_Tags, + RE_OSD_Table => Ada_Tags, + RE_OSD_Num_Prims => Ada_Tags, + RE_POK_Function => Ada_Tags, + RE_POK_Procedure => Ada_Tags, + RE_POK_Protected_Entry => Ada_Tags, + RE_POK_Protected_Function => Ada_Tags, + RE_POK_Protected_Procedure => Ada_Tags, + RE_POK_Task_Entry => Ada_Tags, + RE_POK_Task_Function => Ada_Tags, + RE_POK_Task_Procedure => Ada_Tags, + RE_Predef_Prims => Ada_Tags, + RE_Predef_Prims_Table_Ptr => Ada_Tags, + RE_Prim_Op_Kind => Ada_Tags, + RE_Prim_Ptr => Ada_Tags, + RE_Prims_Ptr => Ada_Tags, + RE_Primary_DT => Ada_Tags, + RE_Signature => Ada_Tags, + RE_SSD => Ada_Tags, + RE_TSD => Ada_Tags, + RE_Type_Is_Abstract => Ada_Tags, + RE_Type_Specific_Data => Ada_Tags, + RE_Register_Interface_Offset => Ada_Tags, + RE_Register_Tag => Ada_Tags, + RE_Transportable => Ada_Tags, + RE_Secondary_DT => Ada_Tags, + RE_Secondary_Tag => Ada_Tags, + RE_Select_Specific_Data => Ada_Tags, + RE_Set_Entry_Index => Ada_Tags, + RE_Set_Dynamic_Offset_To_Top => Ada_Tags, + RE_Set_Prim_Op_Kind => Ada_Tags, + RE_Size_Func => Ada_Tags, + RE_Size_Ptr => Ada_Tags, + RE_Tag => Ada_Tags, + RE_Tag_Error => Ada_Tags, + RE_Tag_Kind => Ada_Tags, + RE_Tag_Ptr => Ada_Tags, + RE_Tag_Table => Ada_Tags, + RE_Tags_Table => Ada_Tags, + RE_Tagged_Kind => Ada_Tags, + RE_Type_Specific_Data_Ptr => Ada_Tags, + RE_TK_Abstract_Limited_Tagged => Ada_Tags, + RE_TK_Abstract_Tagged => Ada_Tags, + RE_TK_Limited_Tagged => Ada_Tags, + RE_TK_Protected => Ada_Tags, + RE_TK_Tagged => Ada_Tags, + RE_TK_Task => Ada_Tags, + + RE_Set_Specific_Handler => Ada_Task_Termination, + RE_Specific_Handler => Ada_Task_Termination, + + RE_Abort_Task => Ada_Task_Identification, + RE_Current_Task => Ada_Task_Identification, + RO_AT_Task_Id => Ada_Task_Identification, + + RE_Integer_64 => Interfaces, + RE_Unsigned_8 => Interfaces, + RE_Unsigned_16 => Interfaces, + RE_Unsigned_32 => Interfaces, + RE_Unsigned_64 => Interfaces, + + RE_Address => System, + RE_Any_Priority => System, + RE_Bit_Order => System, + RE_High_Order_First => System, + RE_Interrupt_Priority => System, + RE_Lib_Stop => System, + RE_Low_Order_First => System, + RE_Max_Priority => System, + RE_Null_Address => System, + RE_Priority => System, + + RE_Address_Image => System_Address_Image, + + RE_Add_With_Ovflo_Check => System_Arith_64, + RE_Double_Divide => System_Arith_64, + RE_Multiply_With_Ovflo_Check => System_Arith_64, + RE_Scaled_Divide => System_Arith_64, + RE_Subtract_With_Ovflo_Check => System_Arith_64, + + RE_Create_AST_Handler => System_AST_Handling, + + RE_Assert_Failure => System_Assertions, + RE_Raise_Assert_Failure => System_Assertions, + + RE_AST_Handler => System_Aux_DEC, + RE_Import_Value => System_Aux_DEC, + RE_No_AST_Handler => System_Aux_DEC, + RE_Type_Class => System_Aux_DEC, + RE_Type_Class_Enumeration => System_Aux_DEC, + RE_Type_Class_Integer => System_Aux_DEC, + RE_Type_Class_Fixed_Point => System_Aux_DEC, + RE_Type_Class_Floating_Point => System_Aux_DEC, + RE_Type_Class_Array => System_Aux_DEC, + RE_Type_Class_Record => System_Aux_DEC, + RE_Type_Class_Access => System_Aux_DEC, + RE_Type_Class_Task => System_Aux_DEC, + RE_Type_Class_Address => System_Aux_DEC, + + RE_Bit_And => System_Bit_Ops, + RE_Bit_Eq => System_Bit_Ops, + RE_Bit_Not => System_Bit_Ops, + RE_Bit_Or => System_Bit_Ops, + RE_Bit_Xor => System_Bit_Ops, + + RE_Checked_Pool => System_Checked_Pools, + + RE_Vector_Not => System_Boolean_Array_Operations, + RE_Vector_And => System_Boolean_Array_Operations, + RE_Vector_Or => System_Boolean_Array_Operations, + RE_Vector_Nand => System_Boolean_Array_Operations, + RE_Vector_Nor => System_Boolean_Array_Operations, + RE_Vector_Nxor => System_Boolean_Array_Operations, + RE_Vector_Xor => System_Boolean_Array_Operations, + + RE_Compare_Array_S8 => System_Compare_Array_Signed_8, + RE_Compare_Array_S8_Unaligned => System_Compare_Array_Signed_8, + + RE_Compare_Array_S16 => System_Compare_Array_Signed_16, + + RE_Compare_Array_S32 => System_Compare_Array_Signed_32, + + RE_Compare_Array_S64 => System_Compare_Array_Signed_64, + + RE_Compare_Array_U8 => System_Compare_Array_Unsigned_8, + RE_Compare_Array_U8_Unaligned => System_Compare_Array_Unsigned_8, + + RE_Compare_Array_U16 => System_Compare_Array_Unsigned_16, + + RE_Compare_Array_U32 => System_Compare_Array_Unsigned_32, + + RE_Compare_Array_U64 => System_Compare_Array_Unsigned_64, + + RE_Str_Concat_2 => System_Concat_2, + RE_Str_Concat_3 => System_Concat_3, + RE_Str_Concat_4 => System_Concat_4, + RE_Str_Concat_5 => System_Concat_5, + RE_Str_Concat_6 => System_Concat_6, + RE_Str_Concat_7 => System_Concat_7, + RE_Str_Concat_8 => System_Concat_8, + RE_Str_Concat_9 => System_Concat_9, + + RE_Str_Concat_Bounds_2 => System_Concat_2, + RE_Str_Concat_Bounds_3 => System_Concat_3, + RE_Str_Concat_Bounds_4 => System_Concat_4, + RE_Str_Concat_Bounds_5 => System_Concat_5, + RE_Str_Concat_Bounds_6 => System_Concat_6, + RE_Str_Concat_Bounds_7 => System_Concat_7, + RE_Str_Concat_Bounds_8 => System_Concat_8, + RE_Str_Concat_Bounds_9 => System_Concat_9, + + RE_Get_Active_Partition_Id => System_DSA_Services, + RE_Get_Local_Partition_Id => System_DSA_Services, + RE_Get_Passive_Partition_Id => System_DSA_Services, + + RE_Any_Container_Ptr => System_DSA_Types, + + RE_Register_Exception => System_Exception_Table, + + RE_Local_Raise => System_Exceptions, + + RE_Exn_Integer => System_Exn_Int, + + RE_Exn_Long_Long_Float => System_Exn_LLF, + + RE_Exn_Long_Long_Integer => System_Exn_LLI, + + RE_Exp_Integer => System_Exp_Int, + + RE_Exp_Long_Long_Integer => System_Exp_LLI, + + RE_Exp_Long_Long_Unsigned => System_Exp_LLU, + + RE_Exp_Modular => System_Exp_Mod, + + RE_Exp_Unsigned => System_Exp_Uns, + + RE_Attr_Float => System_Fat_Flt, + + RE_Attr_IEEE_Long => System_Fat_IEEE_Long_Float, + RE_Fat_IEEE_Long => System_Fat_IEEE_Long_Float, + + RE_Attr_IEEE_Short => System_Fat_IEEE_Short_Float, + RE_Fat_IEEE_Short => System_Fat_IEEE_Short_Float, + + RE_Attr_Long_Float => System_Fat_LFlt, + + RE_Attr_Long_Long_Float => System_Fat_LLF, + + RE_Attr_Short_Float => System_Fat_SFlt, + + RE_Attr_VAX_D_Float => System_Fat_VAX_D_Float, + RE_Fat_VAX_D => System_Fat_VAX_D_Float, + + RE_Attr_VAX_F_Float => System_Fat_VAX_F_Float, + RE_Fat_VAX_F => System_Fat_VAX_F_Float, + + RE_Attr_VAX_G_Float => System_Fat_VAX_G_Float, + RE_Fat_VAX_G => System_Fat_VAX_G_Float, + + RE_Attach_To_Final_List => System_Finalization_Implementation, + RE_Finalizable_Ptr_Ptr => System_Finalization_Implementation, + RE_Move_Final_List => System_Finalization_Implementation, + RE_Finalize_List => System_Finalization_Implementation, + RE_Finalize_One => System_Finalization_Implementation, + RE_Global_Final_List => System_Finalization_Implementation, + RE_Record_Controller => System_Finalization_Implementation, + RE_Limited_Record_Controller => System_Finalization_Implementation, + RE_Deep_Tag_Attach => System_Finalization_Implementation, + + RE_Root_Controlled => System_Finalization_Root, + RE_Finalizable => System_Finalization_Root, + RE_Finalizable_Ptr => System_Finalization_Root, + + RE_Fore => System_Fore, + + RE_Image_Boolean => System_Img_Bool, + + RE_Image_Character => System_Img_Char, + RE_Image_Character_05 => System_Img_Char, + + RE_Image_Decimal => System_Img_Dec, + + RE_Image_Enumeration_8 => System_Img_Enum_New, + RE_Image_Enumeration_16 => System_Img_Enum_New, + RE_Image_Enumeration_32 => System_Img_Enum_New, + + RE_Image_Integer => System_Img_Int, + + RE_Image_Long_Long_Decimal => System_Img_LLD, + + RE_Image_Long_Long_Integer => System_Img_LLI, + + RE_Image_Long_Long_Unsigned => System_Img_LLU, + + RE_Image_Ordinary_Fixed_Point => System_Img_Real, + RE_Image_Floating_Point => System_Img_Real, + + RE_Image_Unsigned => System_Img_Uns, + + RE_Image_Wide_Character => System_Img_WChar, + RE_Image_Wide_Wide_Character => System_Img_WChar, + + RE_Bind_Interrupt_To_Entry => System_Interrupts, + RE_Default_Interrupt_Priority => System_Interrupts, + RE_Dynamic_Interrupt_Protection => System_Interrupts, + RE_Install_Handlers => System_Interrupts, + RE_Install_Restricted_Handlers => System_Interrupts, + RE_Register_Interrupt_Handler => System_Interrupts, + RE_Static_Interrupt_Protection => System_Interrupts, + RE_System_Interrupt_Id => System_Interrupts, + + RE_Asm_Insn => System_Machine_Code, + RE_Asm_Input_Operand => System_Machine_Code, + RE_Asm_Output_Operand => System_Machine_Code, + + RE_Mantissa_Value => System_Mantissa, + + RE_CPU_Range => System_Multiprocessors, + + RE_Bits_03 => System_Pack_03, + RE_Get_03 => System_Pack_03, + RE_Set_03 => System_Pack_03, + + RE_Bits_05 => System_Pack_05, + RE_Get_05 => System_Pack_05, + RE_Set_05 => System_Pack_05, + + RE_Bits_06 => System_Pack_06, + RE_Get_06 => System_Pack_06, + RE_GetU_06 => System_Pack_06, + RE_Set_06 => System_Pack_06, + RE_SetU_06 => System_Pack_06, + + RE_Bits_07 => System_Pack_07, + RE_Get_07 => System_Pack_07, + RE_Set_07 => System_Pack_07, + + RE_Bits_09 => System_Pack_09, + RE_Get_09 => System_Pack_09, + RE_Set_09 => System_Pack_09, + + RE_Bits_10 => System_Pack_10, + RE_Get_10 => System_Pack_10, + RE_GetU_10 => System_Pack_10, + RE_Set_10 => System_Pack_10, + RE_SetU_10 => System_Pack_10, + + RE_Bits_11 => System_Pack_11, + RE_Get_11 => System_Pack_11, + RE_Set_11 => System_Pack_11, + + RE_Bits_12 => System_Pack_12, + RE_Get_12 => System_Pack_12, + RE_GetU_12 => System_Pack_12, + RE_Set_12 => System_Pack_12, + RE_SetU_12 => System_Pack_12, + + RE_Bits_13 => System_Pack_13, + RE_Get_13 => System_Pack_13, + RE_Set_13 => System_Pack_13, + + RE_Bits_14 => System_Pack_14, + RE_Get_14 => System_Pack_14, + RE_GetU_14 => System_Pack_14, + RE_Set_14 => System_Pack_14, + RE_SetU_14 => System_Pack_14, + + RE_Bits_15 => System_Pack_15, + RE_Get_15 => System_Pack_15, + RE_Set_15 => System_Pack_15, + + RE_Bits_17 => System_Pack_17, + RE_Get_17 => System_Pack_17, + RE_Set_17 => System_Pack_17, + + RE_Bits_18 => System_Pack_18, + RE_Get_18 => System_Pack_18, + RE_GetU_18 => System_Pack_18, + RE_Set_18 => System_Pack_18, + RE_SetU_18 => System_Pack_18, + + RE_Bits_19 => System_Pack_19, + RE_Get_19 => System_Pack_19, + RE_Set_19 => System_Pack_19, + + RE_Bits_20 => System_Pack_20, + RE_Get_20 => System_Pack_20, + RE_GetU_20 => System_Pack_20, + RE_Set_20 => System_Pack_20, + RE_SetU_20 => System_Pack_20, + + RE_Bits_21 => System_Pack_21, + RE_Get_21 => System_Pack_21, + RE_Set_21 => System_Pack_21, + + RE_Bits_22 => System_Pack_22, + RE_Get_22 => System_Pack_22, + RE_GetU_22 => System_Pack_22, + RE_Set_22 => System_Pack_22, + RE_SetU_22 => System_Pack_22, + + RE_Bits_23 => System_Pack_23, + RE_Get_23 => System_Pack_23, + RE_Set_23 => System_Pack_23, + + RE_Bits_24 => System_Pack_24, + RE_Get_24 => System_Pack_24, + RE_GetU_24 => System_Pack_24, + RE_Set_24 => System_Pack_24, + RE_SetU_24 => System_Pack_24, + + RE_Bits_25 => System_Pack_25, + RE_Get_25 => System_Pack_25, + RE_Set_25 => System_Pack_25, + + RE_Bits_26 => System_Pack_26, + RE_Get_26 => System_Pack_26, + RE_GetU_26 => System_Pack_26, + RE_Set_26 => System_Pack_26, + RE_SetU_26 => System_Pack_26, + + RE_Bits_27 => System_Pack_27, + RE_Get_27 => System_Pack_27, + RE_Set_27 => System_Pack_27, + + RE_Bits_28 => System_Pack_28, + RE_Get_28 => System_Pack_28, + RE_GetU_28 => System_Pack_28, + RE_Set_28 => System_Pack_28, + RE_SetU_28 => System_Pack_28, + + RE_Bits_29 => System_Pack_29, + RE_Get_29 => System_Pack_29, + RE_Set_29 => System_Pack_29, + + RE_Bits_30 => System_Pack_30, + RE_Get_30 => System_Pack_30, + RE_GetU_30 => System_Pack_30, + RE_Set_30 => System_Pack_30, + RE_SetU_30 => System_Pack_30, + + RE_Bits_31 => System_Pack_31, + RE_Get_31 => System_Pack_31, + RE_Set_31 => System_Pack_31, + + RE_Bits_33 => System_Pack_33, + RE_Get_33 => System_Pack_33, + RE_Set_33 => System_Pack_33, + + RE_Bits_34 => System_Pack_34, + RE_Get_34 => System_Pack_34, + RE_GetU_34 => System_Pack_34, + RE_Set_34 => System_Pack_34, + RE_SetU_34 => System_Pack_34, + + RE_Bits_35 => System_Pack_35, + RE_Get_35 => System_Pack_35, + RE_Set_35 => System_Pack_35, + + RE_Bits_36 => System_Pack_36, + RE_Get_36 => System_Pack_36, + RE_GetU_36 => System_Pack_36, + RE_Set_36 => System_Pack_36, + RE_SetU_36 => System_Pack_36, + + RE_Bits_37 => System_Pack_37, + RE_Get_37 => System_Pack_37, + RE_Set_37 => System_Pack_37, + + RE_Bits_38 => System_Pack_38, + RE_Get_38 => System_Pack_38, + RE_GetU_38 => System_Pack_38, + RE_Set_38 => System_Pack_38, + RE_SetU_38 => System_Pack_38, + + RE_Bits_39 => System_Pack_39, + RE_Get_39 => System_Pack_39, + RE_Set_39 => System_Pack_39, + + RE_Bits_40 => System_Pack_40, + RE_Get_40 => System_Pack_40, + RE_GetU_40 => System_Pack_40, + RE_Set_40 => System_Pack_40, + RE_SetU_40 => System_Pack_40, + + RE_Bits_41 => System_Pack_41, + RE_Get_41 => System_Pack_41, + RE_Set_41 => System_Pack_41, + + RE_Bits_42 => System_Pack_42, + RE_Get_42 => System_Pack_42, + RE_GetU_42 => System_Pack_42, + RE_Set_42 => System_Pack_42, + RE_SetU_42 => System_Pack_42, + + RE_Bits_43 => System_Pack_43, + RE_Get_43 => System_Pack_43, + RE_Set_43 => System_Pack_43, + + RE_Bits_44 => System_Pack_44, + RE_Get_44 => System_Pack_44, + RE_GetU_44 => System_Pack_44, + RE_Set_44 => System_Pack_44, + RE_SetU_44 => System_Pack_44, + + RE_Bits_45 => System_Pack_45, + RE_Get_45 => System_Pack_45, + RE_Set_45 => System_Pack_45, + + RE_Bits_46 => System_Pack_46, + RE_Get_46 => System_Pack_46, + RE_GetU_46 => System_Pack_46, + RE_Set_46 => System_Pack_46, + RE_SetU_46 => System_Pack_46, + + RE_Bits_47 => System_Pack_47, + RE_Get_47 => System_Pack_47, + RE_Set_47 => System_Pack_47, + + RE_Bits_48 => System_Pack_48, + RE_Get_48 => System_Pack_48, + RE_GetU_48 => System_Pack_48, + RE_Set_48 => System_Pack_48, + RE_SetU_48 => System_Pack_48, + + RE_Bits_49 => System_Pack_49, + RE_Get_49 => System_Pack_49, + RE_Set_49 => System_Pack_49, + + RE_Bits_50 => System_Pack_50, + RE_Get_50 => System_Pack_50, + RE_GetU_50 => System_Pack_50, + RE_Set_50 => System_Pack_50, + RE_SetU_50 => System_Pack_50, + + RE_Bits_51 => System_Pack_51, + RE_Get_51 => System_Pack_51, + RE_Set_51 => System_Pack_51, + + RE_Bits_52 => System_Pack_52, + RE_Get_52 => System_Pack_52, + RE_GetU_52 => System_Pack_52, + RE_Set_52 => System_Pack_52, + RE_SetU_52 => System_Pack_52, + + RE_Bits_53 => System_Pack_53, + RE_Get_53 => System_Pack_53, + RE_Set_53 => System_Pack_53, + + RE_Bits_54 => System_Pack_54, + RE_Get_54 => System_Pack_54, + RE_GetU_54 => System_Pack_54, + RE_Set_54 => System_Pack_54, + RE_SetU_54 => System_Pack_54, + + RE_Bits_55 => System_Pack_55, + RE_Get_55 => System_Pack_55, + RE_Set_55 => System_Pack_55, + + RE_Bits_56 => System_Pack_56, + RE_Get_56 => System_Pack_56, + RE_GetU_56 => System_Pack_56, + RE_Set_56 => System_Pack_56, + RE_SetU_56 => System_Pack_56, + + RE_Bits_57 => System_Pack_57, + RE_Get_57 => System_Pack_57, + RE_Set_57 => System_Pack_57, + + RE_Bits_58 => System_Pack_58, + RE_Get_58 => System_Pack_58, + RE_GetU_58 => System_Pack_58, + RE_Set_58 => System_Pack_58, + RE_SetU_58 => System_Pack_58, + + RE_Bits_59 => System_Pack_59, + RE_Get_59 => System_Pack_59, + RE_Set_59 => System_Pack_59, + + RE_Bits_60 => System_Pack_60, + RE_Get_60 => System_Pack_60, + RE_GetU_60 => System_Pack_60, + RE_Set_60 => System_Pack_60, + RE_SetU_60 => System_Pack_60, + + RE_Bits_61 => System_Pack_61, + RE_Get_61 => System_Pack_61, + RE_Set_61 => System_Pack_61, + + RE_Bits_62 => System_Pack_62, + RE_Get_62 => System_Pack_62, + RE_GetU_62 => System_Pack_62, + RE_Set_62 => System_Pack_62, + RE_SetU_62 => System_Pack_62, + + RE_Bits_63 => System_Pack_63, + RE_Get_63 => System_Pack_63, + RE_Set_63 => System_Pack_63, + + RE_Adjust_Storage_Size => System_Parameters, + RE_Default_Stack_Size => System_Parameters, + RE_Garbage_Collected => System_Parameters, + RE_Size_Type => System_Parameters, + RE_Unspecified_Size => System_Parameters, + + RE_DSA_Implementation => System_Partition_Interface, + RE_PCS_Version => System_Partition_Interface, + RE_Get_RACW => System_Partition_Interface, + RE_Get_RCI_Package_Receiver => System_Partition_Interface, + RE_Get_Unique_Remote_Pointer => System_Partition_Interface, + RE_RACW_Stub_Type_Access => System_Partition_Interface, + RE_RAS_Proxy_Type_Access => System_Partition_Interface, + RE_Raise_Program_Error_Unknown_Tag => System_Partition_Interface, + RE_Register_Passive_Package => System_Partition_Interface, + RE_Register_Receiving_Stub => System_Partition_Interface, + RE_Request => System_Partition_Interface, + RE_Request_Access => System_Partition_Interface, + RE_RCI_Locator => System_Partition_Interface, + RE_RCI_Subp_Info => System_Partition_Interface, + RE_RCI_Subp_Info_Array => System_Partition_Interface, + RE_Same_Partition => System_Partition_Interface, + RE_Subprogram_Id => System_Partition_Interface, + RE_Get_RAS_Info => System_Partition_Interface, + + RE_To_PolyORB_String => System_Partition_Interface, + RE_Caseless_String_Eq => System_Partition_Interface, + RE_TypeCode => System_Partition_Interface, + RE_Any => System_Partition_Interface, + RE_Mode_In => System_Partition_Interface, + RE_Mode_Out => System_Partition_Interface, + RE_Mode_Inout => System_Partition_Interface, + RE_NamedValue => System_Partition_Interface, + RE_Result_Name => System_Partition_Interface, + RE_Object_Ref => System_Partition_Interface, + RE_Create_Any => System_Partition_Interface, + RE_Any_Aggregate_Build => System_Partition_Interface, + RE_Add_Aggregate_Element => System_Partition_Interface, + RE_Get_Aggregate_Element => System_Partition_Interface, + RE_Content_Type => System_Partition_Interface, + RE_Any_Member_Type => System_Partition_Interface, + RE_Get_Nested_Sequence_Length => System_Partition_Interface, + RE_Get_Any_Type => System_Partition_Interface, + RE_Extract_Union_Value => System_Partition_Interface, + RE_NVList_Ref => System_Partition_Interface, + RE_NVList_Create => System_Partition_Interface, + RE_NVList_Add_Item => System_Partition_Interface, + RE_Request_Arguments => System_Partition_Interface, + RE_Request_Invoke => System_Partition_Interface, + RE_Request_Raise_Occurrence => System_Partition_Interface, + RE_Request_Set_Out => System_Partition_Interface, + RE_Request_Setup => System_Partition_Interface, + RE_Nil_Exc_List => System_Partition_Interface, + RE_Servant => System_Partition_Interface, + RE_Move_Any_Value => System_Partition_Interface, + RE_Set_Result => System_Partition_Interface, + RE_Register_Obj_Receiving_Stub => System_Partition_Interface, + RE_Register_Pkg_Receiving_Stub => System_Partition_Interface, + RE_Is_Nil => System_Partition_Interface, + RE_Entity_Ptr => System_Partition_Interface, + RE_Entity_Of => System_Partition_Interface, + RE_Inc_Usage => System_Partition_Interface, + RE_Set_Ref => System_Partition_Interface, + RE_Make_Ref => System_Partition_Interface, + RE_Get_Local_Address => System_Partition_Interface, + RE_Get_Reference => System_Partition_Interface, + RE_Asynchronous_P_To_Sync_Scope => System_Partition_Interface, + RE_Buffer_Stream_Type => System_Partition_Interface, + RE_Release_Buffer => System_Partition_Interface, + RE_BS_To_Any => System_Partition_Interface, + RE_Any_To_BS => System_Partition_Interface, + + RE_FA_A => System_Partition_Interface, + RE_FA_B => System_Partition_Interface, + RE_FA_C => System_Partition_Interface, + RE_FA_F => System_Partition_Interface, + RE_FA_I => System_Partition_Interface, + RE_FA_LF => System_Partition_Interface, + RE_FA_LI => System_Partition_Interface, + RE_FA_LLF => System_Partition_Interface, + RE_FA_LLI => System_Partition_Interface, + RE_FA_LLU => System_Partition_Interface, + RE_FA_LU => System_Partition_Interface, + RE_FA_SF => System_Partition_Interface, + RE_FA_SI => System_Partition_Interface, + RE_FA_SSI => System_Partition_Interface, + RE_FA_SSU => System_Partition_Interface, + RE_FA_SU => System_Partition_Interface, + RE_FA_U => System_Partition_Interface, + RE_FA_WC => System_Partition_Interface, + RE_FA_WWC => System_Partition_Interface, + RE_FA_String => System_Partition_Interface, + RE_FA_ObjRef => System_Partition_Interface, + + RE_TA_A => System_Partition_Interface, + RE_TA_B => System_Partition_Interface, + RE_TA_C => System_Partition_Interface, + RE_TA_F => System_Partition_Interface, + RE_TA_I => System_Partition_Interface, + RE_TA_LF => System_Partition_Interface, + RE_TA_LI => System_Partition_Interface, + RE_TA_LLF => System_Partition_Interface, + RE_TA_LLI => System_Partition_Interface, + RE_TA_LLU => System_Partition_Interface, + RE_TA_LU => System_Partition_Interface, + RE_TA_SF => System_Partition_Interface, + RE_TA_SI => System_Partition_Interface, + RE_TA_SSI => System_Partition_Interface, + RE_TA_SSU => System_Partition_Interface, + RE_TA_SU => System_Partition_Interface, + RE_TA_U => System_Partition_Interface, + RE_TA_WC => System_Partition_Interface, + RE_TA_WWC => System_Partition_Interface, + RE_TA_String => System_Partition_Interface, + RE_TA_ObjRef => System_Partition_Interface, + RE_TA_Std_String => System_Partition_Interface, + RE_TA_TC => System_Partition_Interface, + + RE_TC_Alias => System_Partition_Interface, + RE_TC_Build => System_Partition_Interface, + RE_Get_TC => System_Partition_Interface, + RE_Set_TC => System_Partition_Interface, + RE_TC_A => System_Partition_Interface, + RE_TC_B => System_Partition_Interface, + RE_TC_C => System_Partition_Interface, + RE_TC_F => System_Partition_Interface, + RE_TC_I => System_Partition_Interface, + RE_TC_LF => System_Partition_Interface, + RE_TC_LI => System_Partition_Interface, + RE_TC_LLF => System_Partition_Interface, + RE_TC_LLI => System_Partition_Interface, + RE_TC_LLU => System_Partition_Interface, + RE_TC_LU => System_Partition_Interface, + RE_TC_SF => System_Partition_Interface, + RE_TC_SI => System_Partition_Interface, + RE_TC_SSI => System_Partition_Interface, + RE_TC_SSU => System_Partition_Interface, + RE_TC_SU => System_Partition_Interface, + RE_TC_U => System_Partition_Interface, + RE_TC_Void => System_Partition_Interface, + RE_TC_Opaque => System_Partition_Interface, + RE_TC_WC => System_Partition_Interface, + RE_TC_WWC => System_Partition_Interface, + RE_TC_Array => System_Partition_Interface, + RE_TC_Sequence => System_Partition_Interface, + RE_TC_String => System_Partition_Interface, + RE_TC_Struct => System_Partition_Interface, + RE_TC_Union => System_Partition_Interface, + RE_TC_Object => System_Partition_Interface, + + RE_Global_Pool_Object => System_Pool_Global, + + RE_Stack_Bounded_Pool => System_Pool_Size, + + RE_Do_Apc => System_RPC, + RE_Do_Rpc => System_RPC, + RE_Params_Stream_Type => System_RPC, + RE_Partition_ID => System_RPC, + + RE_IS_Is1 => System_Scalar_Values, + RE_IS_Is2 => System_Scalar_Values, + RE_IS_Is4 => System_Scalar_Values, + RE_IS_Is8 => System_Scalar_Values, + RE_IS_Iu1 => System_Scalar_Values, + RE_IS_Iu2 => System_Scalar_Values, + RE_IS_Iu4 => System_Scalar_Values, + RE_IS_Iu8 => System_Scalar_Values, + RE_IS_Iz1 => System_Scalar_Values, + RE_IS_Iz2 => System_Scalar_Values, + RE_IS_Iz4 => System_Scalar_Values, + RE_IS_Iz8 => System_Scalar_Values, + RE_IS_Isf => System_Scalar_Values, + RE_IS_Ifl => System_Scalar_Values, + RE_IS_Ilf => System_Scalar_Values, + RE_IS_Ill => System_Scalar_Values, + + RE_Default_Secondary_Stack_Size => System_Secondary_Stack, + RE_Mark_Id => System_Secondary_Stack, + RE_SS_Allocate => System_Secondary_Stack, + RE_SS_Mark => System_Secondary_Stack, + RE_SS_Pool => System_Secondary_Stack, + RE_SS_Release => System_Secondary_Stack, + + RE_Shared_Var_Lock => System_Shared_Storage, + RE_Shared_Var_Unlock => System_Shared_Storage, + RE_Shared_Var_Procs => System_Shared_Storage, + + RE_Abort_Undefer_Direct => System_Standard_Library, + RE_Exception_Code => System_Standard_Library, + RE_Exception_Data_Ptr => System_Standard_Library, + + RE_Integer_Address => System_Storage_Elements, + RE_Storage_Offset => System_Storage_Elements, + RE_Storage_Array => System_Storage_Elements, + RE_To_Address => System_Storage_Elements, + + RE_Root_Storage_Pool => System_Storage_Pools, + RE_Allocate_Any => System_Storage_Pools, + RE_Deallocate_Any => System_Storage_Pools, + + RE_I_AD => System_Stream_Attributes, + RE_I_AS => System_Stream_Attributes, + RE_I_B => System_Stream_Attributes, + RE_I_C => System_Stream_Attributes, + RE_I_F => System_Stream_Attributes, + RE_I_I => System_Stream_Attributes, + RE_I_LF => System_Stream_Attributes, + RE_I_LI => System_Stream_Attributes, + RE_I_LLF => System_Stream_Attributes, + RE_I_LLI => System_Stream_Attributes, + RE_I_LLU => System_Stream_Attributes, + RE_I_LU => System_Stream_Attributes, + RE_I_SF => System_Stream_Attributes, + RE_I_SI => System_Stream_Attributes, + RE_I_SSI => System_Stream_Attributes, + RE_I_SSU => System_Stream_Attributes, + RE_I_SU => System_Stream_Attributes, + RE_I_U => System_Stream_Attributes, + RE_I_WC => System_Stream_Attributes, + RE_I_WWC => System_Stream_Attributes, + + RE_W_AD => System_Stream_Attributes, + RE_W_AS => System_Stream_Attributes, + RE_W_B => System_Stream_Attributes, + RE_W_C => System_Stream_Attributes, + RE_W_F => System_Stream_Attributes, + RE_W_I => System_Stream_Attributes, + RE_W_LF => System_Stream_Attributes, + RE_W_LI => System_Stream_Attributes, + RE_W_LLF => System_Stream_Attributes, + RE_W_LLI => System_Stream_Attributes, + RE_W_LLU => System_Stream_Attributes, + RE_W_LU => System_Stream_Attributes, + RE_W_SF => System_Stream_Attributes, + RE_W_SI => System_Stream_Attributes, + RE_W_SSI => System_Stream_Attributes, + RE_W_SSU => System_Stream_Attributes, + RE_W_SU => System_Stream_Attributes, + RE_W_U => System_Stream_Attributes, + RE_W_WC => System_Stream_Attributes, + RE_W_WWC => System_Stream_Attributes, + + RE_String_Input => System_Strings_Stream_Ops, + RE_String_Input_Blk_IO => System_Strings_Stream_Ops, + RE_String_Output => System_Strings_Stream_Ops, + RE_String_Output_Blk_IO => System_Strings_Stream_Ops, + RE_String_Read => System_Strings_Stream_Ops, + RE_String_Read_Blk_IO => System_Strings_Stream_Ops, + RE_String_Write => System_Strings_Stream_Ops, + RE_String_Write_Blk_IO => System_Strings_Stream_Ops, + RE_Wide_String_Input => System_Strings_Stream_Ops, + RE_Wide_String_Input_Blk_IO => System_Strings_Stream_Ops, + RE_Wide_String_Output => System_Strings_Stream_Ops, + RE_Wide_String_Output_Blk_IO => System_Strings_Stream_Ops, + RE_Wide_String_Read => System_Strings_Stream_Ops, + RE_Wide_String_Read_Blk_IO => System_Strings_Stream_Ops, + RE_Wide_String_Write => System_Strings_Stream_Ops, + RE_Wide_String_Write_Blk_IO => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Input => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Input_Blk_IO => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Output => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Output_Blk_IO => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Read => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Read_Blk_IO => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Write => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Write_Blk_IO => System_Strings_Stream_Ops, + + RE_Task_Info_Type => System_Task_Info, + RE_Unspecified_Task_Info => System_Task_Info, + + RE_Task_Procedure_Access => System_Tasking, + + RO_ST_Task_Id => System_Tasking, + RO_ST_Null_Task => System_Tasking, + + RE_Call_Modes => System_Tasking, + RE_Simple_Call => System_Tasking, + RE_Conditional_Call => System_Tasking, + RE_Asynchronous_Call => System_Tasking, + + RE_Foreign_Task_Level => System_Tasking, + RE_Environment_Task_Level => System_Tasking, + RE_Independent_Task_Level => System_Tasking, + RE_Library_Task_Level => System_Tasking, + + RE_Ada_Task_Control_Block => System_Tasking, + + RE_Task_List => System_Tasking, + + RE_Accept_List => System_Tasking, + RE_No_Rendezvous => System_Tasking, + RE_Null_Task_Entry => System_Tasking, + RE_Select_Index => System_Tasking, + RE_Else_Mode => System_Tasking, + RE_Simple_Mode => System_Tasking, + RE_Terminate_Mode => System_Tasking, + RE_Delay_Mode => System_Tasking, + RE_Task_Entry_Index => System_Tasking, + RE_Self => System_Tasking, + + RE_Master_Id => System_Tasking, + RE_Unspecified_Priority => System_Tasking, + + RE_Activation_Chain => System_Tasking, + RE_Activation_Chain_Access => System_Tasking, + RE_Storage_Size => System_Tasking, + + RE_Unspecified_CPU => System_Tasking, + + RE_Abort_Defer => System_Soft_Links, + RE_Abort_Undefer => System_Soft_Links, + RE_Complete_Master => System_Soft_Links, + RE_Current_Master => System_Soft_Links, + RE_Dummy_Communication_Block => System_Soft_Links, + RE_Enter_Master => System_Soft_Links, + RE_Get_Current_Excep => System_Soft_Links, + RE_Get_GNAT_Exception => System_Soft_Links, + RE_Update_Exception => System_Soft_Links, + + RE_Bits_1 => System_Unsigned_Types, + RE_Bits_2 => System_Unsigned_Types, + RE_Bits_4 => System_Unsigned_Types, + RE_Float_Unsigned => System_Unsigned_Types, + RE_Long_Unsigned => System_Unsigned_Types, + RE_Long_Long_Unsigned => System_Unsigned_Types, + RE_Packed_Byte => System_Unsigned_Types, + RE_Packed_Bytes1 => System_Unsigned_Types, + RE_Packed_Bytes2 => System_Unsigned_Types, + RE_Packed_Bytes4 => System_Unsigned_Types, + RE_Short_Unsigned => System_Unsigned_Types, + RE_Short_Short_Unsigned => System_Unsigned_Types, + RE_Unsigned => System_Unsigned_Types, + + RE_Value_Boolean => System_Val_Bool, + + RE_Value_Character => System_Val_Char, + + RE_Value_Decimal => System_Val_Dec, + + RE_Value_Enumeration_8 => System_Val_Enum, + RE_Value_Enumeration_16 => System_Val_Enum, + RE_Value_Enumeration_32 => System_Val_Enum, + + RE_Value_Integer => System_Val_Int, + + RE_Value_Long_Long_Decimal => System_Val_LLD, + + RE_Value_Long_Long_Integer => System_Val_LLI, + + RE_Value_Long_Long_Unsigned => System_Val_LLU, + + RE_Value_Real => System_Val_Real, + + RE_Value_Unsigned => System_Val_Uns, + + RE_Value_Wide_Character => System_Val_WChar, + RE_Value_Wide_Wide_Character => System_Val_WChar, + + RE_D => System_Vax_Float_Operations, + RE_F => System_Vax_Float_Operations, + RE_G => System_Vax_Float_Operations, + RE_Q => System_Vax_Float_Operations, + RE_S => System_Vax_Float_Operations, + RE_T => System_Vax_Float_Operations, + + RE_D_To_G => System_Vax_Float_Operations, + RE_F_To_G => System_Vax_Float_Operations, + RE_F_To_Q => System_Vax_Float_Operations, + RE_F_To_S => System_Vax_Float_Operations, + RE_G_To_D => System_Vax_Float_Operations, + RE_G_To_F => System_Vax_Float_Operations, + RE_G_To_Q => System_Vax_Float_Operations, + RE_G_To_T => System_Vax_Float_Operations, + RE_Q_To_F => System_Vax_Float_Operations, + RE_Q_To_G => System_Vax_Float_Operations, + RE_S_To_F => System_Vax_Float_Operations, + RE_T_To_D => System_Vax_Float_Operations, + RE_T_To_G => System_Vax_Float_Operations, + + RE_Abs_F => System_Vax_Float_Operations, + RE_Abs_G => System_Vax_Float_Operations, + RE_Add_F => System_Vax_Float_Operations, + RE_Add_G => System_Vax_Float_Operations, + RE_Div_F => System_Vax_Float_Operations, + RE_Div_G => System_Vax_Float_Operations, + RE_Mul_F => System_Vax_Float_Operations, + RE_Mul_G => System_Vax_Float_Operations, + RE_Neg_F => System_Vax_Float_Operations, + RE_Neg_G => System_Vax_Float_Operations, + RE_Return_D => System_Vax_Float_Operations, + RE_Return_F => System_Vax_Float_Operations, + RE_Return_G => System_Vax_Float_Operations, + RE_Sub_F => System_Vax_Float_Operations, + RE_Sub_G => System_Vax_Float_Operations, + + RE_Eq_F => System_Vax_Float_Operations, + RE_Eq_G => System_Vax_Float_Operations, + RE_Le_F => System_Vax_Float_Operations, + RE_Le_G => System_Vax_Float_Operations, + RE_Lt_F => System_Vax_Float_Operations, + RE_Lt_G => System_Vax_Float_Operations, + RE_Ne_F => System_Vax_Float_Operations, + RE_Ne_G => System_Vax_Float_Operations, + + RE_Valid_D => System_Vax_Float_Operations, + RE_Valid_F => System_Vax_Float_Operations, + RE_Valid_G => System_Vax_Float_Operations, + + RE_Version_String => System_Version_Control, + RE_Get_Version_String => System_Version_Control, + + RE_Register_VMS_Exception => System_VMS_Exception_Table, + + RE_String_To_Wide_String => System_WCh_StW, + RE_String_To_Wide_Wide_String => System_WCh_StW, + + RE_Wide_String_To_String => System_WCh_WtS, + RE_Wide_Wide_String_To_String => System_WCh_WtS, + + RE_Wide_Wide_Width_Character => System_WWd_Char, + RE_Wide_Width_Character => System_WWd_Char, + + RE_Wide_Wide_Width_Enumeration_8 => System_WWd_Enum, + RE_Wide_Wide_Width_Enumeration_16 => System_WWd_Enum, + RE_Wide_Wide_Width_Enumeration_32 => System_WWd_Enum, + + RE_Wide_Width_Enumeration_8 => System_WWd_Enum, + RE_Wide_Width_Enumeration_16 => System_WWd_Enum, + RE_Wide_Width_Enumeration_32 => System_WWd_Enum, + + RE_Wide_Wide_Width_Wide_Character => System_WWd_Wchar, + RE_Wide_Wide_Width_Wide_Wide_Char => System_WWd_Wchar, + + RE_Wide_Width_Wide_Character => System_WWd_Wchar, + RE_Wide_Width_Wide_Wide_Character => System_WWd_Wchar, + + RE_Width_Boolean => System_Wid_Bool, + + RE_Width_Character => System_Wid_Char, + + RE_Width_Enumeration_8 => System_Wid_Enum, + RE_Width_Enumeration_16 => System_Wid_Enum, + RE_Width_Enumeration_32 => System_Wid_Enum, + + RE_Width_Long_Long_Integer => System_Wid_LLI, + + RE_Width_Long_Long_Unsigned => System_Wid_LLU, + + RE_Width_Wide_Character => System_Wid_WChar, + RE_Width_Wide_Wide_Character => System_Wid_WChar, + + RE_Protected_Entry_Body_Array => + System_Tasking_Protected_Objects_Entries, + RE_Protection_Entries => + System_Tasking_Protected_Objects_Entries, + RE_Protection_Entries_Access => + System_Tasking_Protected_Objects_Entries, + RE_Initialize_Protection_Entries => + System_Tasking_Protected_Objects_Entries, + RE_Lock_Entries => + System_Tasking_Protected_Objects_Entries, + RO_PE_Get_Ceiling => + System_Tasking_Protected_Objects_Entries, + RO_PE_Set_Ceiling => + System_Tasking_Protected_Objects_Entries, + RO_PE_Set_Entry_Name => + System_Tasking_Protected_Objects_Entries, + RE_Unlock_Entries => + System_Tasking_Protected_Objects_Entries, + + RE_Communication_Block => + System_Tasking_Protected_Objects_Operations, + RE_Protected_Entry_Call => + System_Tasking_Protected_Objects_Operations, + RE_Service_Entries => + System_Tasking_Protected_Objects_Operations, + RE_Cancel_Protected_Entry_Call => + System_Tasking_Protected_Objects_Operations, + RE_Enqueued => + System_Tasking_Protected_Objects_Operations, + RE_Cancelled => + System_Tasking_Protected_Objects_Operations, + RE_Complete_Entry_Body => + System_Tasking_Protected_Objects_Operations, + RE_Exceptional_Complete_Entry_Body => + System_Tasking_Protected_Objects_Operations, + RE_Requeue_Protected_Entry => + System_Tasking_Protected_Objects_Operations, + RE_Requeue_Task_To_Protected_Entry => + System_Tasking_Protected_Objects_Operations, + RE_Protected_Count => + System_Tasking_Protected_Objects_Operations, + RE_Protected_Entry_Caller => + System_Tasking_Protected_Objects_Operations, + RE_Timed_Protected_Entry_Call => + System_Tasking_Protected_Objects_Operations, + + RE_Protection_Entry => + System_Tasking_Protected_Objects_Single_Entry, + RE_Initialize_Protection_Entry => + System_Tasking_Protected_Objects_Single_Entry, + RE_Lock_Entry => + System_Tasking_Protected_Objects_Single_Entry, + RE_Unlock_Entry => + System_Tasking_Protected_Objects_Single_Entry, + RE_Protected_Single_Entry_Call => + System_Tasking_Protected_Objects_Single_Entry, + RE_Service_Entry => + System_Tasking_Protected_Objects_Single_Entry, + RE_Complete_Single_Entry_Body => + System_Tasking_Protected_Objects_Single_Entry, + RE_Exceptional_Complete_Single_Entry_Body => + System_Tasking_Protected_Objects_Single_Entry, + RE_Protected_Count_Entry => + System_Tasking_Protected_Objects_Single_Entry, + RE_Protected_Single_Entry_Caller => + System_Tasking_Protected_Objects_Single_Entry, + RE_Timed_Protected_Single_Entry_Call => + System_Tasking_Protected_Objects_Single_Entry, + + RE_Protected_Entry_Index => System_Tasking_Protected_Objects, + RE_Entry_Body => System_Tasking_Protected_Objects, + RE_Protection => System_Tasking_Protected_Objects, + RE_Initialize_Protection => System_Tasking_Protected_Objects, + RE_Finalize_Protection => System_Tasking_Protected_Objects, + RE_Lock => System_Tasking_Protected_Objects, + RE_Get_Ceiling => System_Tasking_Protected_Objects, + RE_Set_Ceiling => System_Tasking_Protected_Objects, + RE_Unlock => System_Tasking_Protected_Objects, + + RE_Delay_Block => System_Tasking_Async_Delays, + RE_Timed_Out => System_Tasking_Async_Delays, + RE_Cancel_Async_Delay => System_Tasking_Async_Delays, + RE_Enqueue_Duration => System_Tasking_Async_Delays, + + RE_Enqueue_Calendar => + System_Tasking_Async_Delays_Enqueue_Calendar, + RE_Enqueue_RT => + System_Tasking_Async_Delays_Enqueue_RT, + + RE_Accept_Call => System_Tasking_Rendezvous, + RE_Accept_Trivial => System_Tasking_Rendezvous, + RE_Callable => System_Tasking_Rendezvous, + RE_Call_Simple => System_Tasking_Rendezvous, + RE_Cancel_Task_Entry_Call => System_Tasking_Rendezvous, + RE_Requeue_Task_Entry => System_Tasking_Rendezvous, + RE_Requeue_Protected_To_Task_Entry => System_Tasking_Rendezvous, + RE_Complete_Rendezvous => System_Tasking_Rendezvous, + RE_Task_Count => System_Tasking_Rendezvous, + RE_Exceptional_Complete_Rendezvous => System_Tasking_Rendezvous, + RE_Selective_Wait => System_Tasking_Rendezvous, + RE_Task_Entry_Call => System_Tasking_Rendezvous, + RE_Task_Entry_Caller => System_Tasking_Rendezvous, + RE_Timed_Task_Entry_Call => System_Tasking_Rendezvous, + RE_Timed_Selective_Wait => System_Tasking_Rendezvous, + + RE_Activate_Restricted_Tasks => System_Tasking_Restricted_Stages, + RE_Complete_Restricted_Activation => System_Tasking_Restricted_Stages, + RE_Create_Restricted_Task => System_Tasking_Restricted_Stages, + RE_Complete_Restricted_Task => System_Tasking_Restricted_Stages, + RE_Restricted_Terminated => System_Tasking_Restricted_Stages, + + RE_Abort_Tasks => System_Tasking_Stages, + RE_Activate_Tasks => System_Tasking_Stages, + RE_Complete_Activation => System_Tasking_Stages, + RE_Create_Task => System_Tasking_Stages, + RE_Complete_Task => System_Tasking_Stages, + RE_Free_Task => System_Tasking_Stages, + RE_Expunge_Unactivated_Tasks => System_Tasking_Stages, + RE_Move_Activation_Chain => System_Tasking_Stages, + RO_TS_Set_Entry_Name => System_Tasking_Stages, + RE_Terminated => System_Tasking_Stages); + + -------------------------------- + -- Configurable Run-Time Mode -- + -------------------------------- + + -- Part of the job of Rtsfind is to enforce run-time restrictions in + -- configurable run-time mode. This is done by monitoring implicit access + -- to the run time library requested by calls to the RTE function. A call + -- may be invalid in configurable run-time mode for either of the + -- following two reasons: + + -- 1. File in which entity lives is not present in run-time library + -- 2. File is present, but entity is not defined in the file + + -- In normal mode, either or these two situations is a fatal error + -- that indicates that the run-time library is incorrectly configured, + -- and a fatal error message is issued to signal this error. + + -- In configurable run-time mode, either of these two situations indicates + -- simply that the corresponding operation is not available in the current + -- run-time that is use. This is not a configuration error, but rather a + -- natural result of a limited run-time. This situation is signalled by + -- raising the exception RE_Not_Available. The caller must respond to + -- this exception by posting an appropriate error message. + + ---------------------- + -- No_Run_Time_Mode -- + ---------------------- + + -- For backwards compatibility with previous versions of GNAT, the + -- compiler recognizes the pragma No_Run_Time. This provides a special + -- version of configurable run-time mode that operates with the standard + -- run-time library, but allows only a subset of entities to be + -- accessed. If any other entity is accessed, then it is treated + -- as a configurable run-time violation, and the exception + -- RE_Not_Available is raised. + + -- The following array defines the set of units that contain entities + -- that can be referenced in No_Run_Time mode. For each of these units, + -- all entities defined in the unit can be used in this mode. + + OK_No_Run_Time_Unit : constant array (RTU_Id) of Boolean := + (Ada_Exceptions => True, + Ada_Tags => True, + Interfaces => True, + System => True, + System_Parameters => True, + System_Fat_Flt => True, + System_Fat_LFlt => True, + System_Fat_LLF => True, + System_Fat_SFlt => True, + System_Machine_Code => True, + System_Secondary_Stack => True, + System_Storage_Elements => True, + System_Task_Info => True, + System_Unsigned_Types => True, + others => False); + + ----------------- + -- Subprograms -- + ----------------- + + RE_Not_Available : exception; + -- Raised by RTE if the requested entity is not available. This can + -- occur either because the file in which the entity should be found + -- does not exist, or because the entity is not present in the file. + + procedure Initialize; + -- Procedure to initialize data structures used by RTE. Called at the + -- start of processing a new main source file. Must be called after + -- Initialize_Snames (since names it enters into name table must come + -- after names entered by Snames). + + function Is_RTE (Ent : Entity_Id; E : RE_Id) return Boolean; + -- This function determines if the given entity corresponds to the entity + -- referenced by RE_Id. It is similar in effect to (Ent = RTE (E)) except + -- that the latter would unconditionally load the unit containing E. For + -- this call, if the unit is not loaded, then a result of False is returned + -- immediately, since obviously Ent cannot be the entity in question if the + -- corresponding unit has not been loaded. + + function Is_RTU (Ent : Entity_Id; U : RTU_Id) return Boolean; + pragma Inline (Is_RTU); + -- This function determines if the given entity corresponds to the entity + -- for the unit referenced by U. If this unit has not been loaded, the + -- answer will always be False. If the unit has been loaded, then the + -- entity id values are compared and True is returned if Ent is the + -- entity for this unit. + + function Is_Text_IO_Kludge_Unit (Nam : Node_Id) return Boolean; + -- Returns True if the given Nam is an Expanded Name, whose Prefix is Ada, + -- and whose selector is either Text_IO.xxx or Wide_Text_IO.xxx or + -- Wide_Wide_Text_IO.xxx, where xxx is one of the subpackages of Text_IO + -- that is specially handled as described below for Text_IO_Kludge. + + function RTE (E : RE_Id) return Entity_Id; + -- Given the entity defined in the above tables, as identified by the + -- corresponding value in the RE_Id enumeration type, returns the Id of the + -- corresponding entity, first loading in (parsing, analyzing and + -- expanding) its spec if the unit has not already been loaded. For + -- efficiency reasons, this routine restricts the search to the package + -- entity chain. + -- + -- Note: In the case of a package, RTE can return either an entity that is + -- declared at the top level of the package, or the package entity itself. + -- If an entity within the package has the same simple name as the package, + -- then the entity within the package is returned. + -- + -- If RTE returns, the returned value is the required entity + -- + -- If the entity is not available, then an error message is given. The + -- form of the message depends on whether we are in configurable run time + -- mode or not. In configurable run time mode, a missing entity is not + -- that surprising and merely says that the particular construct is not + -- supported by the run-time in use. If we are not in configurable run + -- time mode, a missing entity is some kind of run-time configuration + -- error. In either case, the result of the call is to raise the exception + -- RE_Not_Available, which should terminate the expansion of the current + -- construct. + + function RTE_Available (E : RE_Id) return Boolean; + -- Returns true if a call to RTE will succeed without raising an exception + -- and without generating an error message, i.e. if the call will obtain + -- the desired entity without any problems. + + function RTE_Record_Component (E : RE_Id) return Entity_Id; + -- Given the entity defined in the above tables, as identified by the + -- corresponding value in the RE_Id enumeration type, returns the Id of + -- the corresponding entity, first loading in (parsing, analyzing and + -- expanding) its spec if the unit has not already been loaded. For + -- efficiency reasons, this routine restricts the search of E to fields + -- of record type declarations found in the package entity chain. + -- + -- Note: In the case of a package, RTE can return either an entity that is + -- declared at the top level of the package, or the package entity itself. + -- If an entity within the package has the same simple name as the package, + -- then the entity within the package is returned. + -- + -- If RTE returns, the returned value is the required entity + -- + -- If the entity is not available, then an error message is given. The + -- form of the message depends on whether we are in configurable run time + -- mode or not. In configurable run time mode, a missing entity is not + -- that surprising and merely says that the particular construct is not + -- supported by the run-time in use. If we are not in configurable run + -- time mode, a missing entity is some kind of run-time configuration + -- error. In either case, the result of the call is to raise the exception + -- RE_Not_Available, which should terminate the expansion of the current + -- construct. + + function RTE_Record_Component_Available (E : RE_Id) return Boolean; + -- Returns true if a call to RTE_Record_Component will succeed without + -- raising an exception and without generating an error message, i.e. + -- if the call will obtain the desired entity without any problems. + + function RTU_Entity (U : RTU_Id) return Entity_Id; + pragma Inline (RTU_Entity); + -- This function returns the entity for the unit referenced by U. If + -- this unit has not been loaded, it returns Empty. + + function RTU_Loaded (U : RTU_Id) return Boolean; + pragma Inline (RTU_Loaded); + -- Returns true if indicated unit has already been successfully loaded. + -- If the unit has not been loaded, returns False. Note that this does + -- not mean that an attempt to load it subsequently would fail. + + procedure Set_RTU_Loaded (N : Node_Id); + -- Register the predefined unit N as already loaded + + procedure Text_IO_Kludge (Nam : Node_Id); + -- In Ada 83, and hence for compatibility in Ada 9X, package Text_IO has + -- generic subpackages (e.g. Integer_IO). They really should be child + -- packages, and in GNAT, they *are* child packages. To maintain the + -- required compatibility, this routine is called for package renamings + -- and generic instantiations, with the simple name of the referenced + -- package. If Text_IO has been with'ed and if the simple name of Nam + -- matches one of the subpackages of Text_IO, then this subpackage is + -- with'ed automatically. The important result of this approach is that + -- Text_IO does not drag in all the code for the subpackages unless they + -- are used. Our test is a little crude, and could drag in stuff when it + -- is not necessary, but that doesn't matter. Wide_[Wide_]Text_IO is + -- handled in a similar manner. + +end Rtsfind; diff --git a/gcc/ada/s-addima.adb b/gcc/ada/s-addima.adb new file mode 100644 index 000000000..cfde5c101 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..5797db92f --- /dev/null +++ b/gcc/ada/s-addima.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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). diff --git a/gcc/ada/s-addope.adb b/gcc/ada/s-addope.adb new file mode 100644 index 000000000..2c957584d --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..2d3f58946 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +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 new file mode 100644 index 000000000..b6f253585 --- /dev/null +++ b/gcc/ada/s-arit64.adb @@ -0,0 +1,673 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A R I T H _ 6 4 -- +-- -- +-- 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 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; + function "+" (A : Uns64; B : Uns32) return Uns64; + pragma Inline ("+"); + -- Length doubling additions + + function "*" (A, B : Uns32) return Uns64; + pragma Inline ("*"); + -- Length doubling multiplication + + function "/" (A : Uns64; B : Uns32) return Uns64; + pragma Inline ("/"); + -- Length doubling division + + function "rem" (A : Uns64; B : Uns32) return Uns64; + pragma Inline ("rem"); + -- Length doubling remainder + + function "&" (Hi, Lo : Uns32) return Uns64; + pragma Inline ("&"); + -- Concatenate hi, lo values to form 64-bit result + + 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; + pragma Inline (Lo); + -- Low order half of 64-bit value + + function Hi (A : Uns64) return Uns32; + pragma Inline (Hi); + -- 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; + -- 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; + -- 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; + pragma No_Return (Raise_Error); + -- Raise constraint error with appropriate message + + --------- + -- "&" -- + --------- + + function "&" (Hi, Lo : Uns32) return Uns64 is + begin + return Shift_Left (Uns64 (Hi), 32) or Uns64 (Lo); + end "&"; + + --------- + -- "*" -- + --------- + + function "*" (A, B : Uns32) return Uns64 is + begin + return Uns64 (A) * Uns64 (B); + end "*"; + + --------- + -- "+" -- + --------- + + function "+" (A, B : Uns32) return Uns64 is + begin + return Uns64 (A) + Uns64 (B); + end "+"; + + function "+" (A : Uns64; B : Uns32) return Uns64 is + begin + return A + Uns64 (B); + end "+"; + + --------- + -- "/" -- + --------- + + function "/" (A : Uns64; B : Uns32) return Uns64 is + begin + return A / Uns64 (B); + end "/"; + + ----------- + -- "rem" -- + ----------- + + function "rem" (A : Uns64; B : Uns32) return Uns64 is + begin + return A rem Uns64 (B); + end "rem"; + + -------------------------- + -- 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 := To_Uns (abs X); + Yu : constant Uns64 := To_Uns (abs Y); + + Yhi : constant Uns32 := Hi (Yu); + Ylo : constant Uns32 := Lo (Yu); + + Zu : constant Uns64 := To_Uns (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; + + -------- + -- Hi -- + -------- + + function Hi (A : Uns64) return Uns32 is + begin + return Uns32 (Shift_Right (A, 32)); + end Hi; + + --------- + -- 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; + + -------- + -- Lo -- + -------- + + function Lo (A : Uns64) return Uns32 is + begin + return Uns32 (A and 16#FFFF_FFFF#); + end Lo; + + ------------------------------- + -- Multiply_With_Ovflo_Check -- + ------------------------------- + + function Multiply_With_Ovflo_Check (X, Y : Int64) return Int64 is + Xu : constant Uns64 := To_Uns (abs X); + Xhi : constant Uns32 := Hi (Xu); + Xlo : constant Uns32 := Lo (Xu); + + Yu : constant Uns64 := To_Uns (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 := To_Uns (abs X); + Xhi : constant Uns32 := Hi (Xu); + Xlo : constant Uns32 := Lo (Xu); + + Yu : constant Uns64 := To_Uns (abs Y); + Yhi : constant Uns32 := Hi (Yu); + Ylo : constant Uns32 := Lo (Yu); + + Zu : Uns64 := To_Uns (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 := -To_Int (A); + + 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 new file mode 100644 index 000000000..8ecbfede1 --- /dev/null +++ b/gcc/ada/s-arit64.ads @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A R I T H _ 6 4 -- +-- -- +-- 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 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. + +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; + -- Raises Constraint_Error if product of operands overflows 64 + -- bits, otherwise returns the 64-bit signed integer product. + + 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 new file mode 100644 index 000000000..030ec1719 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +with Ada.Exceptions; +with System.Exceptions; + +package body System.Assertions is + + -------------------------- + -- Raise_Assert_Failure -- + -------------------------- + + procedure Raise_Assert_Failure (Msg : String) is + begin + System.Exceptions.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 new file mode 100644 index 000000000..433e276c6 --- /dev/null +++ b/gcc/ada/s-assert.ads @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 GNAT assert pragma + +-- 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; + +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-asthan-vms-alpha.adb b/gcc/ada/s-asthan-vms-alpha.adb new file mode 100644 index 000000000..623538f86 --- /dev/null +++ b/gcc/ada/s-asthan-vms-alpha.adb @@ -0,0 +1,603 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A S T _ H A N D L I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1996-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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the OpenVMS/Alpha version + +with System; use System; + +with System.IO; + +with System.Machine_Code; +with System.Parameters; +with System.Storage_Elements; + +with System.Tasking; +with System.Tasking.Rendezvous; +with System.Tasking.Initialization; +with System.Tasking.Utilities; + +with System.Task_Primitives; +with System.Task_Primitives.Operations; +with System.Task_Primitives.Operations.DEC; + +with Ada.Finalization; +with Ada.Task_Attributes; + +with Ada.Exceptions; use Ada.Exceptions; + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +package body System.AST_Handling is + + package ATID renames Ada.Task_Identification; + + package SP renames System.Parameters; + package ST renames System.Tasking; + package STR renames System.Tasking.Rendezvous; + package STI renames System.Tasking.Initialization; + package STU renames System.Tasking.Utilities; + + package SSE renames System.Storage_Elements; + package STPO renames System.Task_Primitives.Operations; + package STPOD renames System.Task_Primitives.Operations.DEC; + + AST_Lock : aliased System.Task_Primitives.RTS_Lock; + -- This is a global lock; it is used to execute in mutual exclusion + -- from all other AST tasks. It is only used by Lock_AST and + -- Unlock_AST. + + procedure Lock_AST (Self_ID : ST.Task_Id); + -- Locks out other AST tasks. Preceding a section of code by Lock_AST and + -- following it by Unlock_AST creates a critical region. + + procedure Unlock_AST (Self_ID : ST.Task_Id); + -- Releases lock previously set by call to Lock_AST. + -- All nested locks must be released before other tasks competing for the + -- tasking lock are released. + + -------------- + -- Lock_AST -- + -------------- + + procedure Lock_AST (Self_ID : ST.Task_Id) is + begin + STI.Defer_Abort_Nestable (Self_ID); + STPO.Write_Lock (AST_Lock'Access, Global_Lock => True); + end Lock_AST; + + ---------------- + -- Unlock_AST -- + ---------------- + + procedure Unlock_AST (Self_ID : ST.Task_Id) is + begin + STPO.Unlock (AST_Lock'Access, Global_Lock => True); + STI.Undefer_Abort_Nestable (Self_ID); + end Unlock_AST; + + --------------------------------- + -- AST_Handler Data Structures -- + --------------------------------- + + -- As noted in the private part of the spec of System.Aux_DEC, the + -- AST_Handler type is simply a pointer to a procedure that takes + -- a single 64bit parameter. The following is a local copy + -- of that definition. + + -- We need our own copy because we need to get our hands on this + -- and we cannot see the private part of System.Aux_DEC. We don't + -- want to be a child of Aux_Dec because of complications resulting + -- from the use of pragma Extend_System. We will use unchecked + -- conversions between the two versions of the declarations. + + type AST_Handler is access procedure (Param : Long_Integer); + + -- However, this declaration is somewhat misleading, since the values + -- referenced by AST_Handler values (all produced in this package by + -- calls to Create_AST_Handler) are highly stylized. + + -- The first point is that in VMS/Alpha, procedure pointers do not in + -- fact point to code, but rather to a 48-byte procedure descriptor. + -- So a value of type AST_Handler is in fact a pointer to one of these + -- 48-byte descriptors. + + type Descriptor_Type is new SSE.Storage_Array (1 .. 48); + for Descriptor_Type'Alignment use Standard'Maximum_Alignment; + + type Descriptor_Ref is access all Descriptor_Type; + + -- Normally, there is only one such descriptor for a given procedure, but + -- it works fine to make a copy of the single allocated descriptor, and + -- use the copy itself, and we take advantage of this in the design here. + -- The idea is that AST_Handler values will all point to a record with the + -- following structure: + + -- Note: When we say it works fine, there is one delicate point, which + -- is that the code for the AST procedure itself requires the original + -- descriptor address. We handle this by saving the original descriptor + -- address in this structure and restoring in Process_AST. + + type AST_Handler_Data is record + Descriptor : Descriptor_Type; + Original_Descriptor_Ref : Descriptor_Ref; + Taskid : ATID.Task_Id; + Entryno : Natural; + end record; + + type AST_Handler_Data_Ref is access all AST_Handler_Data; + + function To_AST_Handler is new Ada.Unchecked_Conversion + (AST_Handler_Data_Ref, System.Aux_DEC.AST_Handler); + + -- Each time Create_AST_Handler is called, a new value of this record + -- type is created, containing a copy of the procedure descriptor for + -- the routine used to handle all AST's (Process_AST), and the Task_Id + -- and entry number parameters identifying the task entry involved. + + -- The AST_Handler value returned is a pointer to this record. Since + -- the record starts with the procedure descriptor, it can be used + -- by the system in the normal way to call the procedure. But now + -- when the procedure gets control, it can determine the address of + -- the procedure descriptor used to call it (since the ABI specifies + -- that this is left sitting in register r27 on entry), and then use + -- that address to retrieve the Task_Id and entry number so that it + -- knows on which entry to queue the AST request. + + -- The next issue is where are these records placed. Since we intend + -- to pass pointers to these records to asynchronous system service + -- routines, they have to be on the heap, which means we have to worry + -- about when to allocate them and deallocate them. + + -- We solve this problem by introducing a task attribute that points to + -- a vector, indexed by the entry number, of AST_Handler_Data records + -- for a given task. The pointer itself is a controlled object allowing + -- us to write a finalization routine that frees the referenced vector. + + -- An entry in this vector is either initialized (Entryno non-zero) and + -- can be used for any subsequent reference to the same entry, or it is + -- unused, marked by the Entryno value being zero. + + type AST_Handler_Vector is array (Natural range <>) of AST_Handler_Data; + type AST_Handler_Vector_Ref is access all AST_Handler_Vector; + + type AST_Vector_Ptr is new Ada.Finalization.Controlled with record + Vector : AST_Handler_Vector_Ref; + end record; + + procedure Finalize (Obj : in out AST_Vector_Ptr); + -- Override Finalize so that the AST Vector gets freed. + + procedure Finalize (Obj : in out AST_Vector_Ptr) is + procedure Free is new + Ada.Unchecked_Deallocation (AST_Handler_Vector, AST_Handler_Vector_Ref); + begin + if Obj.Vector /= null then + Free (Obj.Vector); + end if; + end Finalize; + + AST_Vector_Init : AST_Vector_Ptr; + -- Initial value, treated as constant, Vector will be null + + package AST_Attribute is new Ada.Task_Attributes + (Attribute => AST_Vector_Ptr, + Initial_Value => AST_Vector_Init); + + use AST_Attribute; + + ----------------------- + -- AST Service Queue -- + ----------------------- + + -- The following global data structures are used to queue pending + -- AST requests. When an AST is signalled, the AST service routine + -- Process_AST is called, and it makes an entry in this structure. + + type AST_Instance is record + Taskid : ATID.Task_Id; + Entryno : Natural; + Param : Long_Integer; + end record; + -- The Taskid and Entryno indicate the entry on which this AST is to + -- be queued, and Param is the parameter provided from the AST itself. + + AST_Service_Queue_Size : constant := 256; + AST_Service_Queue_Limit : constant := 250; + type AST_Service_Queue_Index is mod AST_Service_Queue_Size; + -- Index used to refer to entries in the circular buffer which holds + -- active AST_Instance values. The upper bound reflects the maximum + -- number of AST instances that can be stored in the buffer. Since + -- these entries are immediately serviced by the high priority server + -- task that does the actual entry queuing, it is very unusual to have + -- any significant number of entries simultaneously queued. + + AST_Service_Queue : array (AST_Service_Queue_Index) of AST_Instance; + pragma Volatile_Components (AST_Service_Queue); + -- The circular buffer used to store active AST requests + + AST_Service_Queue_Put : AST_Service_Queue_Index := 0; + AST_Service_Queue_Get : AST_Service_Queue_Index := 0; + pragma Atomic (AST_Service_Queue_Put); + pragma Atomic (AST_Service_Queue_Get); + -- These two variables point to the next slots in the AST_Service_Queue + -- to be used for putting a new entry in and taking an entry out. This + -- is a circular buffer, so these pointers wrap around. If the two values + -- are equal the buffer is currently empty. The pointers are atomic to + -- ensure proper synchronization between the single producer (namely the + -- Process_AST procedure), and the single consumer (the AST_Service_Task). + + -------------------------------- + -- AST Server Task Structures -- + -------------------------------- + + -- The basic approach is that when an AST comes in, a call is made to + -- the Process_AST procedure. It queues the request in the service queue + -- and then wakes up an AST server task to perform the actual call to the + -- required entry. We use this intermediate server task, since the AST + -- procedure itself cannot wait to return, and we need some caller for + -- the rendezvous so that we can use the normal rendezvous mechanism. + + -- It would work to have only one AST server task, but then we would lose + -- all overlap in AST processing, and furthermore, we could get priority + -- inversion effects resulting in starvation of AST requests. + + -- We therefore maintain a small pool of AST server tasks. We adjust + -- the size of the pool dynamically to reflect traffic, so that we have + -- a sufficient number of server tasks to avoid starvation. + + Max_AST_Servers : constant Natural := 16; + -- Maximum number of AST server tasks that can be allocated + + Num_AST_Servers : Natural := 0; + -- Number of AST server tasks currently active + + Num_Waiting_AST_Servers : Natural := 0; + -- This is the number of AST server tasks that are either waiting for + -- work, or just about to go to sleep and wait for work. + + Is_Waiting : array (1 .. Max_AST_Servers) of Boolean := (others => False); + -- An array of flags showing which AST server tasks are currently waiting + + AST_Task_Ids : array (1 .. Max_AST_Servers) of ST.Task_Id; + -- Task Id's of allocated AST server tasks + + task type AST_Server_Task (Num : Natural) is + pragma Priority (Priority'Last); + end AST_Server_Task; + -- Declaration for AST server task. This task has no entries, it is + -- controlled by sleep and wakeup calls at the task primitives level. + + type AST_Server_Task_Ptr is access all AST_Server_Task; + -- Type used to allocate server tasks + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Allocate_New_AST_Server; + -- Allocate an additional AST server task + + procedure Process_AST (Param : Long_Integer); + -- This is the central routine for processing all AST's, it is referenced + -- as the code address of all created AST_Handler values. See detailed + -- description in body to understand how it works to have a single such + -- procedure for all AST's even though it does not get any indication of + -- the entry involved passed as an explicit parameter. The single explicit + -- parameter Param is the parameter passed by the system with the AST. + + ----------------------------- + -- Allocate_New_AST_Server -- + ----------------------------- + + procedure Allocate_New_AST_Server is + Dummy : AST_Server_Task_Ptr; + pragma Unreferenced (Dummy); + + begin + if Num_AST_Servers = Max_AST_Servers then + return; + + else + -- Note: it is safe to increment Num_AST_Servers immediately, since + -- no one will try to activate this task until it indicates that it + -- is sleeping by setting its entry in Is_Waiting to True. + + Num_AST_Servers := Num_AST_Servers + 1; + Dummy := new AST_Server_Task (Num_AST_Servers); + end if; + end Allocate_New_AST_Server; + + --------------------- + -- AST_Server_Task -- + --------------------- + + task body AST_Server_Task is + Taskid : ATID.Task_Id; + Entryno : Natural; + Param : aliased Long_Integer; + Self_Id : constant ST.Task_Id := ST.Self; + + pragma Volatile (Param); + + begin + -- By making this task independent of master, when the environment + -- task is finalizing, the AST_Server_Task will be notified that it + -- should terminate. + + STU.Make_Independent; + + -- Record our task Id for access by Process_AST + + AST_Task_Ids (Num) := Self_Id; + + -- Note: this entire task operates with the main task lock set, except + -- when it is sleeping waiting for work, or busy doing a rendezvous + -- with an AST server. This lock protects the data structures that + -- are shared by multiple instances of the server task. + + Lock_AST (Self_Id); + + -- This is the main infinite loop of the task. We go to sleep and + -- wait to be woken up by Process_AST when there is some work to do. + + loop + Num_Waiting_AST_Servers := Num_Waiting_AST_Servers + 1; + + Unlock_AST (Self_Id); + + STI.Defer_Abort (Self_Id); + + if SP.Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Self_Id); + + Is_Waiting (Num) := True; + + Self_Id.Common.State := ST.AST_Server_Sleep; + STPO.Sleep (Self_Id, ST.AST_Server_Sleep); + Self_Id.Common.State := ST.Runnable; + + STPO.Unlock (Self_Id); + + if SP.Single_Lock then + STPO.Unlock_RTS; + end if; + + -- If the process is finalizing, Undefer_Abort will simply end + -- this task. + + STI.Undefer_Abort (Self_Id); + + -- We are awake, there is something to do! + + Lock_AST (Self_Id); + Num_Waiting_AST_Servers := Num_Waiting_AST_Servers - 1; + + -- Loop here to service outstanding requests. We are always + -- locked on entry to this loop. + + while AST_Service_Queue_Get /= AST_Service_Queue_Put loop + Taskid := AST_Service_Queue (AST_Service_Queue_Get).Taskid; + Entryno := AST_Service_Queue (AST_Service_Queue_Get).Entryno; + Param := AST_Service_Queue (AST_Service_Queue_Get).Param; + + AST_Service_Queue_Get := AST_Service_Queue_Get + 1; + + -- This is a manual expansion of the normal call simple code + + declare + type AA is access all Long_Integer; + P : AA := Param'Unrestricted_Access; + + function To_ST_Task_Id is new Ada.Unchecked_Conversion + (ATID.Task_Id, ST.Task_Id); + + begin + Unlock_AST (Self_Id); + STR.Call_Simple + (Acceptor => To_ST_Task_Id (Taskid), + E => ST.Task_Entry_Index (Entryno), + Uninterpreted_Data => P'Address); + + exception + when E : others => + System.IO.Put_Line ("%Debugging event"); + System.IO.Put_Line (Exception_Name (E) & + " raised when trying to deliver an AST."); + + if Exception_Message (E)'Length /= 0 then + System.IO.Put_Line (Exception_Message (E)); + end if; + + System.IO.Put_Line ("Task type is " & "Receiver_Type"); + System.IO.Put_Line ("Task id is " & ATID.Image (Taskid)); + end; + + Lock_AST (Self_Id); + end loop; + end loop; + end AST_Server_Task; + + ------------------------ + -- Create_AST_Handler -- + ------------------------ + + function Create_AST_Handler + (Taskid : ATID.Task_Id; + Entryno : Natural) return System.Aux_DEC.AST_Handler + is + Attr_Ref : Attribute_Handle; + + Process_AST_Ptr : constant AST_Handler := Process_AST'Access; + -- Reference to standard procedure descriptor for Process_AST + + pragma Warnings (Off, "*alignment*"); + -- Suppress harmless warnings about alignment. + -- Should explain why this warning is harmless ??? + + function To_Descriptor_Ref is new Ada.Unchecked_Conversion + (AST_Handler, Descriptor_Ref); + + Original_Descriptor_Ref : constant Descriptor_Ref := + To_Descriptor_Ref (Process_AST_Ptr); + + pragma Warnings (On, "*alignment*"); + + begin + if ATID.Is_Terminated (Taskid) then + raise Program_Error; + end if; + + Attr_Ref := Reference (Taskid); + + -- Allocate another server if supply is getting low + + if Num_Waiting_AST_Servers < 2 then + Allocate_New_AST_Server; + end if; + + -- No point in creating more if we have zillions waiting to + -- be serviced. + + while AST_Service_Queue_Put - AST_Service_Queue_Get + > AST_Service_Queue_Limit + loop + delay 0.01; + end loop; + + -- If no AST vector allocated, or the one we have is too short, then + -- allocate one of right size and initialize all entries except the + -- one we will use to unused. Note that the assignment automatically + -- frees the old allocated table if there is one. + + if Attr_Ref.Vector = null + or else Attr_Ref.Vector'Length < Entryno + then + Attr_Ref.Vector := new AST_Handler_Vector (1 .. Entryno); + + for E in 1 .. Entryno loop + Attr_Ref.Vector (E).Descriptor := + Original_Descriptor_Ref.all; + Attr_Ref.Vector (E).Original_Descriptor_Ref := + Original_Descriptor_Ref; + Attr_Ref.Vector (E).Taskid := Taskid; + Attr_Ref.Vector (E).Entryno := E; + end loop; + end if; + + return To_AST_Handler (Attr_Ref.Vector (Entryno)'Unrestricted_Access); + end Create_AST_Handler; + + ---------------------------- + -- Expand_AST_Packet_Pool -- + ---------------------------- + + procedure Expand_AST_Packet_Pool + (Requested_Packets : Natural; + Actual_Number : out Natural; + Total_Number : out Natural) + is + pragma Unreferenced (Requested_Packets); + begin + -- The AST implementation of GNAT does not permit dynamic expansion + -- of the pool, so we simply add no entries and return the total. If + -- it is necessary to expand the allocation, then this package body + -- must be recompiled with a larger value for AST_Service_Queue_Size. + + Actual_Number := 0; + Total_Number := AST_Service_Queue_Size; + end Expand_AST_Packet_Pool; + + ----------------- + -- Process_AST -- + ----------------- + + procedure Process_AST (Param : Long_Integer) is + + Handler_Data_Ptr : AST_Handler_Data_Ref; + -- This variable is set to the address of the descriptor through + -- which Process_AST is called. Since the descriptor is part of + -- an AST_Handler value, this is also the address of this value, + -- from which we can obtain the task and entry number information. + + function To_Address is new Ada.Unchecked_Conversion + (ST.Task_Id, System.Task_Primitives.Task_Address); + + begin + System.Machine_Code.Asm + (Template => "addq $27,0,%0", + Outputs => AST_Handler_Data_Ref'Asm_Output ("=r", Handler_Data_Ptr), + Volatile => True); + + System.Machine_Code.Asm + (Template => "ldq $27,%0", + Inputs => Descriptor_Ref'Asm_Input + ("m", Handler_Data_Ptr.Original_Descriptor_Ref), + Volatile => True); + + AST_Service_Queue (AST_Service_Queue_Put) := AST_Instance' + (Taskid => Handler_Data_Ptr.Taskid, + Entryno => Handler_Data_Ptr.Entryno, + Param => Param); + + -- OpenVMS Programming Concepts manual, chapter 8.2.3: + -- "Implicit synchronization can be achieved for data that is shared + -- for write by using only AST routines to write the data, since only + -- one AST can be running at any one time." + + -- This subprogram runs at AST level so is guaranteed to be + -- called sequentially at a given access level. + + AST_Service_Queue_Put := AST_Service_Queue_Put + 1; + + -- Need to wake up processing task. If there is no waiting server + -- then we have temporarily run out, but things should still be + -- OK, since one of the active ones will eventually pick up the + -- service request queued in the AST_Service_Queue. + + for J in 1 .. Num_AST_Servers loop + if Is_Waiting (J) then + Is_Waiting (J) := False; + + -- Sleeps are handled by ASTs on VMS, so don't call Wakeup + + STPOD.Interrupt_AST_Handler (To_Address (AST_Task_Ids (J))); + exit; + end if; + end loop; + end Process_AST; + +begin + STPO.Initialize_Lock (AST_Lock'Access, STPO.Global_Task_Level); +end System.AST_Handling; diff --git a/gcc/ada/s-asthan.adb b/gcc/ada/s-asthan.adb new file mode 100644 index 000000000..5cce4103f --- /dev/null +++ b/gcc/ada/s-asthan.adb @@ -0,0 +1,58 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNT-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A S T _ H A N D L I N G -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the dummy version used on non-VMS systems + +package body System.AST_Handling is + + ------------------------ + -- Create_AST_Handler -- + ------------------------ + + function Create_AST_Handler + (Taskid : Ada.Task_Identification.Task_Id; + Entryno : Natural) return System.Aux_DEC.AST_Handler + is + begin + raise Program_Error with "AST is implemented only on VMS systems"; + return System.Aux_DEC.No_AST_Handler; + end Create_AST_Handler; + + procedure Expand_AST_Packet_Pool + (Requested_Packets : Natural; + Actual_Number : out Natural; + Total_Number : out Natural) + is + begin + raise Program_Error with "AST is implemented only on VMS systems"; + end Expand_AST_Packet_Pool; + +end System.AST_Handling; diff --git a/gcc/ada/s-asthan.ads b/gcc/ada/s-asthan.ads new file mode 100644 index 000000000..6ee2228df --- /dev/null +++ b/gcc/ada/s-asthan.ads @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A S T _ H A N D L I N G -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Runtime support for Handling of AST's (Used on VMS implementations only) + +with Ada.Task_Identification; +with System; +with System.Aux_DEC; + +package System.AST_Handling is + + function Create_AST_Handler + (Taskid : Ada.Task_Identification.Task_Id; + Entryno : Natural) return System.Aux_DEC.AST_Handler; + -- This function implements the appropriate semantics for a use of the + -- AST_Entry pragma. See body for details of implementation approach. + -- The parameters are the Task_Id for the task containing the entry + -- and the entry Index for the specified entry. + + procedure Expand_AST_Packet_Pool + (Requested_Packets : Natural; + Actual_Number : out Natural; + Total_Number : out Natural); + -- This function takes a request for zero or more extra AST packets and + -- returns the number actually added to the pool and the total number + -- now available or in use. + -- This function is not yet fully implemented. + +end System.AST_Handling; diff --git a/gcc/ada/s-atacco.adb b/gcc/ada/s-atacco.adb new file mode 100644 index 000000000..ccd5ffd5a --- /dev/null +++ b/gcc/ada/s-atacco.adb @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 version of this package that is needed to solve bootstrap +-- problems when compiling a library that doesn't require s-atacco.adb from +-- a compiler that contains one. + +package body System.Address_To_Access_Conversions is + +end System.Address_To_Access_Conversions; diff --git a/gcc/ada/s-atacco.ads b/gcc/ada/s-atacco.ads new file mode 100644 index 000000000..031240ed8 --- /dev/null +++ b/gcc/ada/s-atacco.ads @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 Object (<>) is limited private; + +package System.Address_To_Access_Conversions is + pragma Preelaborate; + pragma Elaborate_Body; + -- This pragma Elaborate_Body is there to ensure the requirement of what is + -- at the moment a dummy null body. The reason this null body is there is + -- that we used to have a real body, and it causes bootstrap problems with + -- old compilers if we try to remove the corresponding file. + + pragma Compile_Time_Warning + (Object'Unconstrained_Array, + "Object is unconstrained array type" & ASCII.LF & + "To_Pointer results may not have bounds"); + + -- Capture constrained status, suppressing warnings, since this is + -- an obsolescent feature to use Constrained in this way (RM J.4). + + pragma Warnings (Off); + Xyz : Boolean := Object'Constrained; + pragma Warnings (On); + + 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-auxdec-empty.adb b/gcc/ada/s-auxdec-empty.adb new file mode 100644 index 000000000..eddc34351 --- /dev/null +++ b/gcc/ada/s-auxdec-empty.adb @@ -0,0 +1,34 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A U X _ D E C -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Aux_DEC is + +end System.Aux_DEC; diff --git a/gcc/ada/s-auxdec-empty.ads b/gcc/ada/s-auxdec-empty.ads new file mode 100644 index 000000000..c25f0ef0f --- /dev/null +++ b/gcc/ada/s-auxdec-empty.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A U X _ D E C -- +-- -- +-- 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 is to be used when the extra definitions in package +-- System for DEC Ada implementations are not supported by the target. + +package System.Aux_DEC is + pragma Pure; + pragma Elaborate_Body; + + type AST_Handler is limited private; + No_AST_Handler : constant AST_Handler; + +private + + type AST_Handler is new Integer; + No_AST_Handler : constant AST_Handler := 0; + +end System.Aux_DEC; diff --git a/gcc/ada/s-auxdec-vms-alpha.adb b/gcc/ada/s-auxdec-vms-alpha.adb new file mode 100644 index 000000000..86c462989 --- /dev/null +++ b/gcc/ada/s-auxdec-vms-alpha.adb @@ -0,0 +1,809 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A U X _ D E C -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Alpha/VMS version. + +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.Machine_Code; use System.Machine_Code; +package body System.Aux_DEC is + + ------------------------ + -- 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; + + ----------------------- + -- Clear_Interlocked -- + ----------------------- + + procedure Clear_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean) + is + use ASCII; + Clr_Bit : Boolean := Bit; + Old_Bit : Boolean; + + begin + -- All these ASM sequences should be commented. I suggest defining + -- a constant called E which is LF & HT and then you have more space + -- for line by line comments ??? + + System.Machine_Code.Asm + ( + "lda $16, %2" & LF & HT & + "mb" & LF & HT & + "sll $16, 3, $17 " & LF & HT & + "bis $31, 1, $1" & LF & HT & + "and $17, 63, $18" & LF & HT & + "bic $17, 63, $17" & LF & HT & + "sra $17, 3, $17" & LF & HT & + "bis $31, 1, %1" & LF & HT & + "sll %1, $18, $18" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, 0($17)" & LF & HT & + "and $1, $18, %1" & LF & HT & + "bic $1, $18, $1" & LF & HT & + "stq_c $1, 0($17)" & LF & HT & + "cmpeq %1, 0, %1" & LF & HT & + "beq $1, 1b" & LF & HT & + "mb" & LF & HT & + "xor %1, 1, %1" & LF & HT & + "trapb", + Outputs => (Boolean'Asm_Output ("=m", Clr_Bit), + Boolean'Asm_Output ("=r", Old_Bit)), + Inputs => Boolean'Asm_Input ("m", Clr_Bit), + Clobber => "$1, $16, $17, $18", + Volatile => True); + + Bit := Clr_Bit; + Old_Value := Old_Bit; + end Clear_Interlocked; + + procedure Clear_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean; + Retry_Count : Natural; + Success_Flag : out Boolean) + is + use ASCII; + Clr_Bit : Boolean := Bit; + Succ, Old_Bit : Boolean; + + begin + System.Machine_Code.Asm + ( + "lda $16, %3" & LF & HT & + "mb" & LF & HT & + "sll $16, 3, $18 " & LF & HT & + "bis $31, 1, %1" & LF & HT & + "and $18, 63, $19" & LF & HT & + "bic $18, 63, $18" & LF & HT & + "sra $18, 3, $18" & LF & HT & + "bis $31, %4, $17" & LF & HT & + "sll %1, $19, $19" & LF & HT & + "1:" & LF & HT & + "ldq_l %2, 0($18)" & LF & HT & + "and %2, $19, %1" & LF & HT & + "bic %2, $19, %2" & LF & HT & + "stq_c %2, 0($18)" & LF & HT & + "beq %2, 2f" & LF & HT & + "cmpeq %1, 0, %1" & LF & HT & + "br 3f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "xor %1, 1, %1" & LF & HT & + "trapb", + Outputs => (Boolean'Asm_Output ("=m", Clr_Bit), + Boolean'Asm_Output ("=r", Old_Bit), + Boolean'Asm_Output ("=r", Succ)), + Inputs => (Boolean'Asm_Input ("m", Clr_Bit), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$16, $17, $18, $19", + Volatile => True); + + Bit := Clr_Bit; + Old_Value := Old_Bit; + Success_Flag := Succ; + end Clear_Interlocked; + + --------------------- + -- Set_Interlocked -- + --------------------- + + procedure Set_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean) + is + use ASCII; + Set_Bit : Boolean := Bit; + Old_Bit : Boolean; + + begin + -- Don't we need comments on these long asm sequences??? + + System.Machine_Code.Asm + ( + "lda $16, %2" & LF & HT & + "sll $16, 3, $17 " & LF & HT & + "bis $31, 1, $1" & LF & HT & + "and $17, 63, $18" & LF & HT & + "mb" & LF & HT & + "bic $17, 63, $17" & LF & HT & + "sra $17, 3, $17" & LF & HT & + "bis $31, 1, %1" & LF & HT & + "sll %1, $18, $18" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, 0($17)" & LF & HT & + "and $1, $18, %1" & LF & HT & + "bis $1, $18, $1" & LF & HT & + "stq_c $1, 0($17)" & LF & HT & + "cmovne %1, 1, %1" & LF & HT & + "beq $1, 1b" & LF & HT & + "mb" & LF & HT & + "trapb", + Outputs => (Boolean'Asm_Output ("=m", Set_Bit), + Boolean'Asm_Output ("=r", Old_Bit)), + Inputs => Boolean'Asm_Input ("m", Set_Bit), + Clobber => "$1, $16, $17, $18", + Volatile => True); + + Bit := Set_Bit; + Old_Value := Old_Bit; + end Set_Interlocked; + + procedure Set_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean; + Retry_Count : Natural; + Success_Flag : out Boolean) + is + use ASCII; + Set_Bit : Boolean := Bit; + Succ, Old_Bit : Boolean; + + begin + System.Machine_Code.Asm + ( + "lda $16, %3" & LF & HT & + "mb" & LF & HT & + "sll $16, 3, $18 " & LF & HT & + "bis $31, 1, %1" & LF & HT & + "and $18, 63, $19" & LF & HT & + "bic $18, 63, $18" & LF & HT & + "sra $18, 3, $18" & LF & HT & + "bis $31, %4, $17" & LF & HT & + "sll %1, $19, $19" & LF & HT & + "1:" & LF & HT & + "ldq_l %2, 0($18)" & LF & HT & + "and %2, $19, %1" & LF & HT & + "bis %2, $19, %2" & LF & HT & + "stq_c %2, 0($18)" & LF & HT & + "beq %2, 2f" & LF & HT & + "cmovne %1, 1, %1" & LF & HT & + "br 3f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "trapb", + Outputs => (Boolean'Asm_Output ("=m", Set_Bit), + Boolean'Asm_Output ("=r", Old_Bit), + Boolean'Asm_Output ("=r", Succ)), + Inputs => (Boolean'Asm_Input ("m", Set_Bit), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$16, $17, $18, $19", + Volatile => True); + + Bit := Set_Bit; + Old_Value := Old_Bit; + Success_Flag := Succ; + end Set_Interlocked; + + --------------------- + -- Add_Interlocked -- + --------------------- + + procedure Add_Interlocked + (Addend : Short_Integer; + Augend : in out Aligned_Word; + Sign : out Integer) + is + use ASCII; + Overflowed : Boolean := False; + + begin + System.Machine_Code.Asm + ( + "lda $18, %0" & LF & HT & + "bic $18, 6, $21" & LF & HT & + "mb" & LF & HT & + "1:" & LF & HT & + "ldq_l $0, 0($21)" & LF & HT & + "extwl $0, $18, $19" & LF & HT & + "mskwl $0, $18, $0" & LF & HT & + "addq $19, %3, $20" & LF & HT & + "inswl $20, $18, $17" & LF & HT & + "xor $19, %3, $19" & LF & HT & + "bis $17, $0, $0" & LF & HT & + "stq_c $0, 0($21)" & LF & HT & + "beq $0, 1b" & LF & HT & + "srl $20, 16, $0" & LF & HT & + "mb" & LF & HT & + "srl $20, 12, $21" & LF & HT & + "zapnot $20, 3, $20" & LF & HT & + "and $0, 1, $0" & LF & HT & + "and $21, 8, $21" & LF & HT & + "bis $21, $0, $0" & LF & HT & + "cmpeq $20, 0, $21" & LF & HT & + "xor $20, 2, $20" & LF & HT & + "sll $21, 2, $21" & LF & HT & + "bis $21, $0, $0" & LF & HT & + "bic $20, $19, $21" & LF & HT & + "srl $21, 14, $21" & LF & HT & + "and $21, 2, $21" & LF & HT & + "bis $21, $0, $0" & LF & HT & + "and $0, 2, %2" & LF & HT & + "bne %2, 2f" & LF & HT & + "and $0, 4, %1" & LF & HT & + "cmpeq %1, 0, %1" & LF & HT & + "and $0, 8, $0" & LF & HT & + "lda $16, -1" & LF & HT & + "cmovne $0, $16, %1" & LF & HT & + "2:", + Outputs => (Aligned_Word'Asm_Output ("=m", Augend), + Integer'Asm_Output ("=r", Sign), + Boolean'Asm_Output ("=r", Overflowed)), + Inputs => (Short_Integer'Asm_Input ("r", Addend), + Aligned_Word'Asm_Input ("m", Augend)), + Clobber => "$0, $1, $16, $17, $18, $19, $20, $21", + Volatile => True); + + if Overflowed then + raise Constraint_Error; + end if; + end Add_Interlocked; + + ---------------- + -- Add_Atomic -- + ---------------- + + procedure Add_Atomic + (To : in out Aligned_Integer; + Amount : Integer) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "addl $1, %2, $0" & LF & HT & + "stl_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", Amount)), + Clobber => "$0, $1", + Volatile => True); + 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 + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "addl $1, %4, $0" & LF & HT & + "stl_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stl $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Integer'Asm_Output ("=m", To), + Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", Amount), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end Add_Atomic; + + procedure Add_Atomic + (To : in out Aligned_Long_Integer; + Amount : Long_Integer) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "addq $1, %2, $0" & LF & HT & + "stq_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Long_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", Amount)), + Clobber => "$0, $1", + Volatile => True); + 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 + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "addq $1, %4, $0" & LF & HT & + "stq_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stq $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To), + Long_Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", Amount), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end Add_Atomic; + + ---------------- + -- And_Atomic -- + ---------------- + + procedure And_Atomic + (To : in out Aligned_Integer; + From : Integer) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "and $1, %2, $0" & LF & HT & + "stl_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", From)), + Clobber => "$0, $1", + Volatile => True); + 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 + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "and $1, %4, $0" & LF & HT & + "stl_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stl $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Integer'Asm_Output ("=m", To), + Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", From), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end And_Atomic; + + procedure And_Atomic + (To : in out Aligned_Long_Integer; + From : Long_Integer) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "and $1, %2, $0" & LF & HT & + "stq_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Long_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", From)), + Clobber => "$0, $1", + Volatile => True); + 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 + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "and $1, %4, $0" & LF & HT & + "stq_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stq $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To), + Long_Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", From), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end And_Atomic; + + --------------- + -- Or_Atomic -- + --------------- + + procedure Or_Atomic + (To : in out Aligned_Integer; + From : Integer) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "bis $1, %2, $0" & LF & HT & + "stl_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", From)), + Clobber => "$0, $1", + Volatile => True); + 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 + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "bis $1, %4, $0" & LF & HT & + "stl_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stl $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Integer'Asm_Output ("=m", To), + Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", From), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end Or_Atomic; + + procedure Or_Atomic + (To : in out Aligned_Long_Integer; + From : Long_Integer) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "bis $1, %2, $0" & LF & HT & + "stq_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Long_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", From)), + Clobber => "$0, $1", + Volatile => True); + 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 + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "bis $1, %4, $0" & LF & HT & + "stq_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stq $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To), + Long_Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", From), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end Or_Atomic; + + ------------ + -- Insqhi -- + ------------ + + procedure Insqhi + (Item : Address; + Header : Address; + Status : out Insq_Status) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "bis $31, %1, $17" & LF & HT & + "bis $31, %2, $16" & LF & HT & + "mb" & LF & HT & + "call_pal 0x87" & LF & HT & + "mb", + Outputs => Insq_Status'Asm_Output ("=v", Status), + Inputs => (Address'Asm_Input ("rJ", Item), + Address'Asm_Input ("rJ", Header)), + Clobber => "$16, $17", + Volatile => True); + end Insqhi; + + ------------ + -- Remqhi -- + ------------ + + procedure Remqhi + (Header : Address; + Item : out Address; + Status : out Remq_Status) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "bis $31, %2, $16" & LF & HT & + "mb" & LF & HT & + "call_pal 0x93" & LF & HT & + "mb" & LF & HT & + "bis $31, $1, %1", + Outputs => (Remq_Status'Asm_Output ("=v", Status), + Address'Asm_Output ("=r", Item)), + Inputs => Address'Asm_Input ("rJ", Header), + Clobber => "$1, $16", + Volatile => True); + end Remqhi; + + ------------ + -- Insqti -- + ------------ + + procedure Insqti + (Item : Address; + Header : Address; + Status : out Insq_Status) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "bis $31, %1, $17" & LF & HT & + "bis $31, %2, $16" & LF & HT & + "mb" & LF & HT & + "call_pal 0x88" & LF & HT & + "mb", + Outputs => Insq_Status'Asm_Output ("=v", Status), + Inputs => (Address'Asm_Input ("rJ", Item), + Address'Asm_Input ("rJ", Header)), + Clobber => "$16, $17", + Volatile => True); + end Insqti; + + ------------ + -- Remqti -- + ------------ + + procedure Remqti + (Header : Address; + Item : out Address; + Status : out Remq_Status) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "bis $31, %2, $16" & LF & HT & + "mb" & LF & HT & + "call_pal 0x94" & LF & HT & + "mb" & LF & HT & + "bis $31, $1, %1", + Outputs => (Remq_Status'Asm_Output ("=v", Status), + Address'Asm_Output ("=r", Item)), + Inputs => Address'Asm_Input ("rJ", Header), + Clobber => "$1, $16", + Volatile => True); + end Remqti; + +end System.Aux_DEC; diff --git a/gcc/ada/s-auxdec-vms_64.ads b/gcc/ada/s-auxdec-vms_64.ads new file mode 100644 index 000000000..202cdbc98 --- /dev/null +++ b/gcc/ada/s-auxdec-vms_64.ads @@ -0,0 +1,695 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A U X _ D E C -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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) + +-- This is the VMS 64 bit version + +with Ada.Unchecked_Conversion; + +package System.Aux_DEC is + pragma Preelaborate; + + type Short_Integer_Address is + range -2 ** (32 - 1) .. +2 ** (32 - 1) - 1; + -- Integer literals cannot appear naked in an address context, as a + -- result the bounds of Short_Address cannot be given simply as 2^32 etc. + + subtype Short_Address is Address + range Address (Short_Integer_Address'First) .. + Address (Short_Integer_Address'Last); + for Short_Address'Object_Size use 32; + -- This subtype allows addresses to be converted from 64 bits to 32 bits + -- with an appropriate range check. Note that since this is a subtype of + -- type System.Address, the same limitations apply to this subtype. Namely + -- there are no visible arithmetic operations, and integer literals are + -- not available. + + Short_Memory_Size : constant := 2 ** 32; + -- Defined for convenience of porting + + 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 := 32; + + 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; + + pragma Import (Intrinsic, "+"); + pragma Import (Intrinsic, "-"); + + 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 + + pragma Warnings (Off); + -- ??? needs comment + + type F_Float is digits 6; + pragma Float_Representation (VAX_Float, F_Float); + + type D_Float is digits 9; + pragma Float_Representation (Vax_Float, D_Float); + + type G_Float is digits 15; + pragma Float_Representation (Vax_Float, G_Float); + + -- Floating point type declarations for IEEE floating point data types + + type IEEE_Single_Float is digits 6; + pragma Float_Representation (IEEE_Float, IEEE_Single_Float); + + type IEEE_Double_Float is digits 15; + pragma Float_Representation (IEEE_Float, IEEE_Double_Float); + + pragma Warnings (On); + + 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 Short_Address; + pragma Pure_Function (To_Address); + + function To_Address_Long (X : Unsigned_Longword) return Short_Address; + pragma Pure_Function (To_Address_Long); + + function To_Integer (X : Short_Address) return Integer; + + function To_Unsigned_Longword (X : Short_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 64bit 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 Import (Intrinsic, "not"); + pragma Import (Intrinsic, "and"); + pragma Import (Intrinsic, "or"); + pragma Import (Intrinsic, "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); + + -- Inline the VAX Queue Functions + + pragma Inline_Always (Insqhi); + pragma Inline_Always (Remqhi); + pragma Inline_Always (Insqti); + pragma Inline_Always (Remqti); + + -- 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, Short_Address); + pragma Pure_Function (To_Address_A); + + function To_Address (X : Integer) return Short_Address + renames To_Address_A; + pragma Pure_Function (To_Address); + + function To_Address_Long_A is new + Ada.Unchecked_Conversion (Unsigned_Longword, Short_Address); + pragma Pure_Function (To_Address_Long_A); + + function To_Address_Long (X : Unsigned_Longword) return Short_Address + renames To_Address_Long_A; + pragma Pure_Function (To_Address_Long); + + function To_Integer_A is new + Ada.Unchecked_Conversion (Short_Address, Integer); + + function To_Integer (X : Short_Address) return Integer + renames To_Integer_A; + + function To_Unsigned_Longword_A is new + Ada.Unchecked_Conversion (Short_Address, Unsigned_Longword); + + function To_Unsigned_Longword (X : Short_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-auxdec.adb b/gcc/ada/s-auxdec.adb new file mode 100644 index 000000000..bfb489477 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/Or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..4b56bafff --- /dev/null +++ b/gcc/ada/s-auxdec.ads @@ -0,0 +1,677 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A U X _ D E C -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + -- In some versions of System.Aux_DEC, notably that for VMS on the + -- ia64, there are two address types (64-bit and 32-bit), and the + -- name Short_Address is used for the short address form. To avoid + -- difficulties (in regression tests and elsewhere) with units that + -- reference Short_Address, it is provided for other targets as a + -- synonym for the normal Address type, and, as in the case where + -- the lengths are different, Address and Short_Address can be + -- freely inter-converted. + + 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 + + pragma Warnings (Off); + -- ??? needs comment + + type F_Float is digits 6; + pragma Float_Representation (VAX_Float, F_Float); + + type D_Float is digits 9; + pragma Float_Representation (Vax_Float, D_Float); + + type G_Float is digits 15; + pragma Float_Representation (Vax_Float, G_Float); + + -- Floating point type declarations for IEEE floating point data types + + type IEEE_Single_Float is digits 6; + pragma Float_Representation (IEEE_Float, IEEE_Single_Float); + + type IEEE_Double_Float is digits 15; + pragma Float_Representation (IEEE_Float, IEEE_Double_Float); + + pragma Warnings (On); + + 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 64bit 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-bitops.adb b/gcc/ada/s-bitops.adb new file mode 100644 index 000000000..dbf30ddd5 --- /dev/null +++ b/gcc/ada/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-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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit; + +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 new file mode 100644 index 000000000..b78180977 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..c321995d2 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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-carsi8.adb b/gcc/ada/s-carsi8.adb new file mode 100644 index 000000000..6e4fd4289 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..995cd2079 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..450e04765 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..aa0d4e0f7 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +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 new file mode 100644 index 000000000..88a758a95 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..e9bfe92d8 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..04161144d --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..b5af1bc06 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..858a22ff8 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..e276a56b6 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..8517db7c0 --- /dev/null +++ b/gcc/ada/s-casuti.adb @@ -0,0 +1,107 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit; + +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 new file mode 100644 index 000000000..84b92f6e6 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..37abb9c28 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..c152dc4cc --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..070df3a3b --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..a2f9b5626 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..e4f35abd6 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..fe0d0e819 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..7f614ec67 --- /dev/null +++ b/gcc/ada/s-chepoo.ads @@ -0,0 +1,58 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..afeec6dfc --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..c59a2c7e4 --- /dev/null +++ b/gcc/ada/s-commun.ads @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- Common support unit for GNAT.Sockets and GNAT.Serial_Communication + +with Ada.Streams; +with System.CRTL; + +package System.Communication is + + 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 new file mode 100644 index 000000000..a1d424b85 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..c5c7a2808 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +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 new file mode 100644 index 000000000..48e4d8651 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..c79e24a39 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +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 new file mode 100644 index 000000000..19fa32483 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..43ce1bc3b --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +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 new file mode 100644 index 000000000..f0019961a --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..996dbf936 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +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 new file mode 100644 index 000000000..115b36ec0 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..91cc10e68 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +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 new file mode 100644 index 000000000..5436fbd8c --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..139a816d2 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +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 new file mode 100644 index 000000000..dfc5bf7df --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..5978a39dc --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +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 new file mode 100644 index 000000000..530eee193 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..1890c90e1 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +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 new file mode 100644 index 000000000..b133780a9 --- /dev/null +++ b/gcc/ada/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-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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit; + +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 new file mode 100644 index 000000000..b450c8cd3 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +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 new file mode 100644 index 000000000..345e9a570 --- /dev/null +++ b/gcc/ada/s-crtl.ads @@ -0,0 +1,199 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . C R T L -- +-- -- +-- S p e c -- +-- -- +-- 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 package provides the low level interface to the C runtime library + +pragma Compiler_Unit; + +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 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 + + 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 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 ftell (stream : FILEs) return long; + pragma Import (C, ftell, "ftell"); + + 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 setvbuf + (stream : FILEs; + buffer : chars; + mode : int; + size : size_t) return int; + pragma Import (C, setvbuf, "setvbuf"); + + procedure tmpnam (string : 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, "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-crtrun.ads b/gcc/ada/s-crtrun.ads new file mode 100644 index 000000000..281e54fe5 --- /dev/null +++ b/gcc/ada/s-crtrun.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . C R T L . R U N T I M E -- +-- -- +-- 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 the low level interface to the C runtime library +-- (additional declarations for use in the Ada runtime only, not in the +-- compiler itself). + +with Interfaces.C.Strings; + +package System.CRTL.Runtime is + pragma Preelaborate; + + subtype chars_ptr is Interfaces.C.Strings.chars_ptr; + + function strerror (errno : int) return chars_ptr; + pragma Import (C, strerror, "strerror"); + +end System.CRTL.Runtime; diff --git a/gcc/ada/s-direio.adb b/gcc/ada/s-direio.adb new file mode 100644 index 000000000..ef4c3ea9c --- /dev/null +++ b/gcc/ada/s-direio.adb @@ -0,0 +1,389 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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.IO_Exceptions; use Ada.IO_Exceptions; +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System; use System; +with System.CRTL; +with System.File_IO; +with System.Soft_Links; +with Ada.Unchecked_Deallocation; + +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.long; + 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 + begin + if fseek + (File.Stream, long (File.Bytes) * + long (File.Index - 1), SEEK_SET) /= 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)); + File.Last_Op := Op_Other; + + if fseek (File.Stream, 0, SEEK_END) /= 0 then + raise Device_Error; + end if; + + return Count (ftell (File.Stream) / long (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 new file mode 100644 index 000000000..35fcef05d --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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.long; + -- 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-dsaser.ads b/gcc/ada/s-dsaser.ads new file mode 100644 index 000000000..ff9c1478b --- /dev/null +++ b/gcc/ada/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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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-except.adb b/gcc/ada/s-except.adb new file mode 100755 index 000000000..3d04b4b14 --- /dev/null +++ b/gcc/ada/s-except.adb @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +package body System.Exceptions is + + --------------------------- + -- Debug_Raise_Exception -- + --------------------------- + + procedure Debug_Raise_Exception (E : SSL.Exception_Data_Ptr) is + pragma Inspection_Point (E); + 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; diff --git a/gcc/ada/s-except.ads b/gcc/ada/s-except.ads new file mode 100644 index 000000000..102329782 --- /dev/null +++ b/gcc/ada/s-except.ads @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +with System.Standard_Library; + +package System.Exceptions is + + pragma Preelaborate_05; + -- 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); + 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; diff --git a/gcc/ada/s-exctab.adb b/gcc/ada/s-exctab.adb new file mode 100644 index 000000000..5f2228ceb --- /dev/null +++ b/gcc/ada/s-exctab.adb @@ -0,0 +1,246 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +with System.HTable; +with System.Soft_Links; use System.Soft_Links; + +package body System.Exception_Table is + + use System.Standard_Library; + + type HTable_Headers is range 1 .. 37; + + procedure Set_HT_Link (T : Exception_Data_Ptr; Next : Exception_Data_Ptr); + function Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr; + + function Hash (F : System.Address) return HTable_Headers; + function Equal (A, B : System.Address) return Boolean; + function Get_Key (T : Exception_Data_Ptr) return System.Address; + + package Exception_HTable is new System.HTable.Static_HTable ( + Header_Num => HTable_Headers, + Element => Exception_Data, + Elmt_Ptr => Exception_Data_Ptr, + Null_Ptr => null, + Set_Next => Set_HT_Link, + Next => Get_HT_Link, + Key => System.Address, + Get_Key => Get_Key, + Hash => Hash, + Equal => Equal); + + ----------- + -- Equal -- + ----------- + + function Equal (A, B : System.Address) return Boolean is + S1 : constant Big_String_Ptr := To_Ptr (A); + S2 : constant Big_String_Ptr := To_Ptr (B); + J : Integer := 1; + + begin + loop + if S1 (J) /= S2 (J) then + return False; + + elsif S1 (J) = ASCII.NUL then + return True; + + else + J := J + 1; + end if; + end loop; + end Equal; + + ----------------- + -- Get_HT_Link -- + ----------------- + + function Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr is + begin + return T.HTable_Ptr; + end Get_HT_Link; + + ------------- + -- Get_Key -- + ------------- + + function Get_Key (T : Exception_Data_Ptr) return System.Address is + begin + return T.Full_Name; + end Get_Key; + + ------------------------------- + -- Get_Registered_Exceptions -- + ------------------------------- + + procedure Get_Registered_Exceptions + (List : out Exception_Data_Array; + Last : out Integer) + is + Data : Exception_Data_Ptr := Exception_HTable.Get_First; + + begin + Lock_Task.all; + Last := List'First - 1; + + while Last < List'Last and then Data /= null loop + Last := Last + 1; + List (Last) := Data; + Data := Exception_HTable.Get_Next; + end loop; + + Unlock_Task.all; + end Get_Registered_Exceptions; + + ---------- + -- Hash -- + ---------- + + function Hash (F : System.Address) return HTable_Headers is + type S is mod 2**8; + + Str : constant Big_String_Ptr := To_Ptr (F); + Size : constant S := S (HTable_Headers'Last - HTable_Headers'First + 1); + Tmp : S := 0; + J : Positive; + + begin + J := 1; + loop + if Str (J) = ASCII.NUL then + return HTable_Headers'First + HTable_Headers'Base (Tmp mod Size); + else + Tmp := Tmp xor S (Character'Pos (Str (J))); + end if; + J := J + 1; + end loop; + end Hash; + + ------------------------ + -- Internal_Exception -- + ------------------------ + + function Internal_Exception + (X : String; + Create_If_Not_Exist : Boolean := True) return Exception_Data_Ptr + is + type String_Ptr is access all String; + + Copy : aliased String (X'First .. X'Last + 1); + Res : Exception_Data_Ptr; + Dyn_Copy : String_Ptr; + + begin + Copy (X'Range) := X; + Copy (Copy'Last) := ASCII.NUL; + Res := Exception_HTable.Get (Copy'Address); + + -- 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 Res = null and then Create_If_Not_Exist then + Dyn_Copy := new String'(Copy); + + Res := + new Exception_Data' + (Not_Handled_By_Others => False, + Lang => 'A', + Name_Length => Copy'Length, + Full_Name => Dyn_Copy.all'Address, + HTable_Ptr => null, + Import_Code => 0, + Raise_Hook => null); + + Register_Exception (Res); + end if; + + return Res; + end Internal_Exception; + + ------------------------ + -- Register_Exception -- + ------------------------ + + procedure Register_Exception (X : Exception_Data_Ptr) is + begin + Exception_HTable.Set (X); + end Register_Exception; + + --------------------------------- + -- Registered_Exceptions_Count -- + --------------------------------- + + function Registered_Exceptions_Count return Natural is + Count : Natural := 0; + Data : Exception_Data_Ptr := Exception_HTable.Get_First; + + begin + -- We need to lock the runtime in the meantime, to avoid concurrent + -- access since we have only one iterator. + + Lock_Task.all; + + while Data /= null loop + Count := Count + 1; + Data := Exception_HTable.Get_Next; + end loop; + + Unlock_Task.all; + return Count; + end Registered_Exceptions_Count; + + ----------------- + -- Set_HT_Link -- + ----------------- + + procedure Set_HT_Link + (T : Exception_Data_Ptr; + Next : Exception_Data_Ptr) + is + begin + T.HTable_Ptr := Next; + end Set_HT_Link; + +-- Register the standard exceptions at elaboration time + +begin + Register_Exception (Abort_Signal_Def'Access); + Register_Exception (Tasking_Error_Def'Access); + Register_Exception (Storage_Error_Def'Access); + Register_Exception (Program_Error_Def'Access); + Register_Exception (Numeric_Error_Def'Access); + Register_Exception (Constraint_Error_Def'Access); + +end System.Exception_Table; diff --git a/gcc/ada/s-exctab.ads b/gcc/ada/s-exctab.ads new file mode 100644 index 000000000..c9fe6980b --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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; + +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-exnint.adb b/gcc/ada/s-exnint.adb new file mode 100644 index 000000000..bce8fd61c --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..fde7af65a --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..a1e59c179 --- /dev/null +++ b/gcc/ada/s-exnllf.adb @@ -0,0 +1,97 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X N _ L L F -- +-- -- +-- 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.Exn_LLF is + + ------------------------- + -- Exn_Long_Long_Float -- + ------------------------- + + function Exn_Long_Long_Float + (Left : Long_Long_Float; + Right : Integer) + return Long_Long_Float + is + Result : Long_Long_Float := 1.0; + Factor : Long_Long_Float := 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. If the low order bit or Exp is + -- set, multiply the result by this factor. For negative exponents, + -- invert result upon return. + + 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; + + return Result; + + -- Here we have a negative exponent, and 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: The coding of this routine assumes that the + -- target generates infinities with standard IEEE semantics. If this + -- is not the case, then the code below may raise Constraint_Error. + -- This follows the implementation permission given in RM 4.5.6(12). + + else + begin + 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 1.0 / Result; + end; + end if; + end Exn_Long_Long_Float; + +end System.Exn_LLF; diff --git a/gcc/ada/s-exnllf.ads b/gcc/ada/s-exnllf.ads new file mode 100644 index 000000000..59575b0e0 --- /dev/null +++ b/gcc/ada/s-exnllf.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X N _ 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Long_Long_Float exponentiation (checks off) + +package System.Exn_LLF is + pragma Pure; + + 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 new file mode 100644 index 000000000..f060ee3b0 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..5713bbc92 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..58b82eb97 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..d0d1cf852 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..b19aaf5bf --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..d9d8a1320 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..23ca437e5 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..e4c1ce915 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This procedure 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 new file mode 100644 index 000000000..ecd736f20 --- /dev/null +++ b/gcc/ada/s-expmod.adb @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P _ M O 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 System.Exp_Mod is + + ----------------- + -- Exp_Modular -- + ----------------- + + function Exp_Modular + (Left : Integer; + Modulus : Integer; + Right : Natural) + return Integer + is + Result : Integer := 1; + Factor : Integer := Left; + Exp : Natural := Right; + + function Mult (X, Y : Integer) return Integer; + pragma Inline (Mult); + -- Modular multiplication. Note that we can't take advantage of the + -- compiler's circuit, because the modulus is not known statically. + + function Mult (X, Y : Integer) return Integer is + begin + return Integer + (Long_Long_Integer (X) * Long_Long_Integer (Y) + mod Long_Long_Integer (Modulus)); + end Mult; + + -- Start of processing for Exp_Modular + + 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 new file mode 100644 index 000000000..99cf46ec7 --- /dev/null +++ b/gcc/ada/s-expmod.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P _ M O 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 procedure performs exponentiation of a modular type with non-binary +-- modulus values. Arithmetic is done in Long_Long_Unsigned, with explicit +-- accounting for the modulus value which is passed as the second argument. + +package System.Exp_Mod is + pragma Pure; + + function Exp_Modular + (Left : Integer; + Modulus : Integer; + Right : Natural) + return Integer; + +end System.Exp_Mod; diff --git a/gcc/ada/s-expuns.adb b/gcc/ada/s-expuns.adb new file mode 100644 index 000000000..4bda9509b --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..948330613 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This procedure 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 new file mode 100644 index 000000000..5897128a5 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains an instantiation of the floating-point attribute +-- runtime routines for the type Float. + +with System.Fat_Gen; + +package System.Fat_Flt is + pragma Pure; + + -- Note the only entity from this package that is accessed by Rtsfind + -- is the name of the package instantiation. Entities within this package + -- (i.e. the individual floating-point attribute routines) are accessed + -- by name using selected notation. + + package Attr_Float is new System.Fat_Gen (Float); + +end System.Fat_Flt; diff --git a/gcc/ada/s-fatgen.adb b/gcc/ada/s-fatgen.adb new file mode 100644 index 000000000..128890427 --- /dev/null +++ b/gcc/ada/s-fatgen.adb @@ -0,0 +1,921 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F A T _ G E N -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- The implementation here is portable to any IEEE implementation. It does +-- not handle non-binary radix, and also assumes that model numbers and +-- machine numbers are basically identical, which is not true of all possible +-- floating-point implementations. On a non-IEEE machine, this body must be +-- specialized appropriately, or better still, its generic instantiations +-- should be replaced by efficient machine-specific code. + +with Ada.Unchecked_Conversion; +with System; +package body System.Fat_Gen is + + Float_Radix : constant T := T (T'Machine_Radix); + Radix_To_M_Minus_1 : constant T := Float_Radix ** (T'Machine_Mantissa - 1); + + pragma Assert (T'Machine_Radix = 2); + -- This version does not handle radix 16 + + -- Constants for Decompose and Scaling + + Rad : constant T := T (T'Machine_Radix); + Invrad : constant T := 1.0 / Rad; + + subtype Expbits is Integer range 0 .. 6; + -- 2 ** (2 ** 7) might overflow. How big can radix-16 exponents get? + + Log_Power : constant array (Expbits) of Integer := (1, 2, 4, 8, 16, 32, 64); + + R_Power : constant array (Expbits) of T := + (Rad ** 1, + Rad ** 2, + Rad ** 4, + Rad ** 8, + Rad ** 16, + Rad ** 32, + Rad ** 64); + + R_Neg_Power : constant array (Expbits) of T := + (Invrad ** 1, + Invrad ** 2, + Invrad ** 4, + Invrad ** 8, + Invrad ** 16, + Invrad ** 32, + Invrad ** 64); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Decompose (XX : T; Frac : out T; Expo : out UI); + -- Decomposes a floating-point number into fraction and exponent parts. + -- Both results are signed, with Frac having the sign of XX, and UI has + -- the sign of the exponent. The absolute value of Frac is in the range + -- 0.0 <= Frac < 1.0. If Frac = 0.0 or -0.0, then Expo is always zero. + + function Gradual_Scaling (Adjustment : UI) return T; + -- Like Scaling with a first argument of 1.0, but returns the smallest + -- denormal rather than zero when the adjustment is smaller than + -- Machine_Emin. Used for Succ and Pred. + + -------------- + -- Adjacent -- + -------------- + + function Adjacent (X, Towards : T) return T is + begin + if Towards = X then + return X; + elsif Towards > X then + return Succ (X); + else + return Pred (X); + end if; + end Adjacent; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (X : T) return T is + XT : constant T := Truncation (X); + begin + if X <= 0.0 then + return XT; + elsif X = XT then + return X; + else + return XT + 1.0; + end if; + end Ceiling; + + ------------- + -- Compose -- + ------------- + + function Compose (Fraction : T; Exponent : UI) return T is + Arg_Frac : T; + Arg_Exp : UI; + pragma Unreferenced (Arg_Exp); + begin + Decompose (Fraction, Arg_Frac, Arg_Exp); + return Scaling (Arg_Frac, Exponent); + end Compose; + + --------------- + -- Copy_Sign -- + --------------- + + function Copy_Sign (Value, Sign : T) return T is + Result : T; + + function Is_Negative (V : T) return Boolean; + pragma Import (Intrinsic, Is_Negative); + + begin + Result := abs Value; + + if Is_Negative (Sign) then + return -Result; + else + return Result; + end if; + end Copy_Sign; + + --------------- + -- Decompose -- + --------------- + + procedure Decompose (XX : T; Frac : out T; Expo : out UI) is + X : constant T := T'Machine (XX); + + begin + if X = 0.0 then + + -- The normalized exponent of zero is zero, see RM A.5.2(15) + + Frac := X; + Expo := 0; + + -- Check for infinities, transfinites, whatnot + + elsif X > T'Safe_Last then + Frac := Invrad; + Expo := T'Machine_Emax + 1; + + elsif X < T'Safe_First then + Frac := -Invrad; + Expo := T'Machine_Emax + 2; -- how many extra negative values? + + else + -- Case of nonzero finite x. Essentially, we just multiply + -- by Rad ** (+-2**N) to reduce the range. + + declare + Ax : T := abs X; + Ex : UI := 0; + + -- Ax * Rad ** Ex is invariant + + begin + if Ax >= 1.0 then + while Ax >= R_Power (Expbits'Last) loop + Ax := Ax * R_Neg_Power (Expbits'Last); + Ex := Ex + Log_Power (Expbits'Last); + end loop; + + -- Ax < Rad ** 64 + + for N in reverse Expbits'First .. Expbits'Last - 1 loop + if Ax >= R_Power (N) then + Ax := Ax * R_Neg_Power (N); + Ex := Ex + Log_Power (N); + end if; + + -- Ax < R_Power (N) + + end loop; + + -- 1 <= Ax < Rad + + Ax := Ax * Invrad; + Ex := Ex + 1; + + else + -- 0 < ax < 1 + + while Ax < R_Neg_Power (Expbits'Last) loop + Ax := Ax * R_Power (Expbits'Last); + Ex := Ex - Log_Power (Expbits'Last); + end loop; + + -- Rad ** -64 <= Ax < 1 + + for N in reverse Expbits'First .. Expbits'Last - 1 loop + if Ax < R_Neg_Power (N) then + Ax := Ax * R_Power (N); + Ex := Ex - Log_Power (N); + end if; + + -- R_Neg_Power (N) <= Ax < 1 + + end loop; + end if; + + Frac := (if X > 0.0 then Ax else -Ax); + Expo := Ex; + end; + end if; + end Decompose; + + -------------- + -- Exponent -- + -------------- + + function Exponent (X : T) return UI is + X_Frac : T; + X_Exp : UI; + pragma Unreferenced (X_Frac); + begin + Decompose (X, X_Frac, X_Exp); + return X_Exp; + end Exponent; + + ----------- + -- Floor -- + ----------- + + function Floor (X : T) return T is + XT : constant T := Truncation (X); + begin + if X >= 0.0 then + return XT; + elsif XT = X then + return X; + else + return XT - 1.0; + end if; + end Floor; + + -------------- + -- Fraction -- + -------------- + + function Fraction (X : T) return T is + X_Frac : T; + X_Exp : UI; + pragma Unreferenced (X_Exp); + begin + Decompose (X, X_Frac, X_Exp); + return X_Frac; + end Fraction; + + --------------------- + -- Gradual_Scaling -- + --------------------- + + function Gradual_Scaling (Adjustment : UI) return T is + Y : T; + Y1 : T; + Ex : UI := Adjustment; + + begin + if Adjustment < T'Machine_Emin - 1 then + Y := 2.0 ** T'Machine_Emin; + Y1 := Y; + Ex := Ex - T'Machine_Emin; + while Ex < 0 loop + Y := T'Machine (Y / 2.0); + + if Y = 0.0 then + return Y1; + end if; + + Ex := Ex + 1; + Y1 := Y; + end loop; + + return Y1; + + else + return Scaling (1.0, Adjustment); + end if; + end Gradual_Scaling; + + ------------------ + -- Leading_Part -- + ------------------ + + function Leading_Part (X : T; Radix_Digits : UI) return T is + L : UI; + Y, Z : T; + + begin + if Radix_Digits >= T'Machine_Mantissa then + return X; + + elsif Radix_Digits <= 0 then + raise Constraint_Error; + + else + L := Exponent (X) - Radix_Digits; + Y := Truncation (Scaling (X, -L)); + Z := Scaling (Y, L); + return Z; + end if; + end Leading_Part; + + ------------- + -- Machine -- + ------------- + + -- The trick with Machine is to force the compiler to store the result + -- in memory so that we do not have extra precision used. The compiler + -- is clever, so we have to outwit its possible optimizations! We do + -- this by using an intermediate pragma Volatile location. + + function Machine (X : T) return T is + Temp : T; + pragma Volatile (Temp); + begin + Temp := X; + return Temp; + end Machine; + + ---------------------- + -- Machine_Rounding -- + ---------------------- + + -- For now, the implementation is identical to that of Rounding, which is + -- a permissible behavior, but is not the most efficient possible approach. + + function Machine_Rounding (X : T) return T is + Result : T; + Tail : T; + + begin + Result := Truncation (abs X); + Tail := abs X - Result; + + if Tail >= 0.5 then + Result := Result + 1.0; + end if; + + if X > 0.0 then + return Result; + + elsif X < 0.0 then + return -Result; + + -- For zero case, make sure sign of zero is preserved + + else + return X; + end if; + end Machine_Rounding; + + ----------- + -- Model -- + ----------- + + -- We treat Model as identical to Machine. This is true of IEEE and other + -- nice floating-point systems, but not necessarily true of all systems. + + function Model (X : T) return T is + begin + return Machine (X); + end Model; + + ---------- + -- Pred -- + ---------- + + -- Subtract from the given number a number equivalent to the value of its + -- least significant bit. Given that the most significant bit represents + -- a value of 1.0 * radix ** (exp - 1), the value we want is obtained by + -- shifting this by (mantissa-1) bits to the right, i.e. decreasing the + -- exponent by that amount. + + -- Zero has to be treated specially, since its exponent is zero + + function Pred (X : T) return T is + X_Frac : T; + X_Exp : UI; + + begin + if X = 0.0 then + return -Succ (X); + + else + Decompose (X, X_Frac, X_Exp); + + -- A special case, if the number we had was a positive power of + -- two, then we want to subtract half of what we would otherwise + -- subtract, since the exponent is going to be reduced. + + -- Note that X_Frac has the same sign as X, so if X_Frac is 0.5, + -- then we know that we have a positive number (and hence a + -- positive power of 2). + + if X_Frac = 0.5 then + return X - Gradual_Scaling (X_Exp - T'Machine_Mantissa - 1); + + -- Otherwise the exponent is unchanged + + else + return X - Gradual_Scaling (X_Exp - T'Machine_Mantissa); + end if; + end if; + end Pred; + + --------------- + -- Remainder -- + --------------- + + function Remainder (X, Y : T) return T is + A : T; + B : T; + Arg : T; + P : T; + P_Frac : T; + Sign_X : T; + IEEE_Rem : T; + Arg_Exp : UI; + P_Exp : UI; + K : UI; + P_Even : Boolean; + + Arg_Frac : T; + pragma Unreferenced (Arg_Frac); + + begin + if Y = 0.0 then + raise Constraint_Error; + end if; + + if X > 0.0 then + Sign_X := 1.0; + Arg := X; + else + Sign_X := -1.0; + Arg := -X; + end if; + + P := abs Y; + + if Arg < P then + P_Even := True; + IEEE_Rem := Arg; + P_Exp := Exponent (P); + + else + Decompose (Arg, Arg_Frac, Arg_Exp); + Decompose (P, P_Frac, P_Exp); + + P := Compose (P_Frac, Arg_Exp); + K := Arg_Exp - P_Exp; + P_Even := True; + IEEE_Rem := Arg; + + for Cnt in reverse 0 .. K loop + if IEEE_Rem >= P then + P_Even := False; + IEEE_Rem := IEEE_Rem - P; + else + P_Even := True; + end if; + + P := P * 0.5; + end loop; + end if; + + -- That completes the calculation of modulus remainder. The final + -- step is get the IEEE remainder. Here we need to compare Rem with + -- (abs Y) / 2. We must be careful of unrepresentable Y/2 value + -- caused by subnormal numbers + + if P_Exp >= 0 then + A := IEEE_Rem; + B := abs Y * 0.5; + + else + A := IEEE_Rem * 2.0; + B := abs Y; + end if; + + if A > B or else (A = B and then not P_Even) then + IEEE_Rem := IEEE_Rem - abs Y; + end if; + + return Sign_X * IEEE_Rem; + end Remainder; + + -------------- + -- Rounding -- + -------------- + + function Rounding (X : T) return T is + Result : T; + Tail : T; + + begin + Result := Truncation (abs X); + Tail := abs X - Result; + + if Tail >= 0.5 then + Result := Result + 1.0; + end if; + + if X > 0.0 then + return Result; + + elsif X < 0.0 then + return -Result; + + -- For zero case, make sure sign of zero is preserved + + else + return X; + end if; + end Rounding; + + ------------- + -- Scaling -- + ------------- + + -- Return x * rad ** adjustment quickly, or quietly underflow to zero, + -- or overflow naturally. + + function Scaling (X : T; Adjustment : UI) return T is + begin + if X = 0.0 or else Adjustment = 0 then + return X; + end if; + + -- Nonzero x essentially, just multiply repeatedly by Rad ** (+-2**n) + + declare + Y : T := X; + Ex : UI := Adjustment; + + -- Y * Rad ** Ex is invariant + + begin + if Ex < 0 then + while Ex <= -Log_Power (Expbits'Last) loop + Y := Y * R_Neg_Power (Expbits'Last); + Ex := Ex + Log_Power (Expbits'Last); + end loop; + + -- -64 < Ex <= 0 + + for N in reverse Expbits'First .. Expbits'Last - 1 loop + if Ex <= -Log_Power (N) then + Y := Y * R_Neg_Power (N); + Ex := Ex + Log_Power (N); + end if; + + -- -Log_Power (N) < Ex <= 0 + + end loop; + + -- Ex = 0 + + else + -- Ex >= 0 + + while Ex >= Log_Power (Expbits'Last) loop + Y := Y * R_Power (Expbits'Last); + Ex := Ex - Log_Power (Expbits'Last); + end loop; + + -- 0 <= Ex < 64 + + for N in reverse Expbits'First .. Expbits'Last - 1 loop + if Ex >= Log_Power (N) then + Y := Y * R_Power (N); + Ex := Ex - Log_Power (N); + end if; + + -- 0 <= Ex < Log_Power (N) + + end loop; + + -- Ex = 0 + + end if; + + return Y; + end; + end Scaling; + + ---------- + -- Succ -- + ---------- + + -- Similar computation to that of Pred: find value of least significant + -- bit of given number, and add. Zero has to be treated specially since + -- the exponent can be zero, and also we want the smallest denormal if + -- denormals are supported. + + function Succ (X : T) return T is + X_Frac : T; + X_Exp : UI; + X1, X2 : T; + + begin + if X = 0.0 then + X1 := 2.0 ** T'Machine_Emin; + + -- Following loop generates smallest denormal + + loop + X2 := T'Machine (X1 / 2.0); + exit when X2 = 0.0; + X1 := X2; + end loop; + + return X1; + + else + Decompose (X, X_Frac, X_Exp); + + -- A special case, if the number we had was a negative power of two, + -- then we want to add half of what we would otherwise add, since the + -- exponent is going to be reduced. + + -- Note that X_Frac has the same sign as X, so if X_Frac is -0.5, + -- then we know that we have a negative number (and hence a negative + -- power of 2). + + if X_Frac = -0.5 then + return X + Gradual_Scaling (X_Exp - T'Machine_Mantissa - 1); + + -- Otherwise the exponent is unchanged + + else + return X + Gradual_Scaling (X_Exp - T'Machine_Mantissa); + end if; + end if; + end Succ; + + ---------------- + -- Truncation -- + ---------------- + + -- The basic approach is to compute + + -- T'Machine (RM1 + N) - RM1 + + -- where N >= 0.0 and RM1 = radix ** (mantissa - 1) + + -- This works provided that the intermediate result (RM1 + N) does not + -- have extra precision (which is why we call Machine). When we compute + -- RM1 + N, the exponent of N will be normalized and the mantissa shifted + -- shifted appropriately so the lower order bits, which cannot contribute + -- to the integer part of N, fall off on the right. When we subtract RM1 + -- again, the significant bits of N are shifted to the left, and what we + -- have is an integer, because only the first e bits are different from + -- zero (assuming binary radix here). + + function Truncation (X : T) return T is + Result : T; + + begin + Result := abs X; + + if Result >= Radix_To_M_Minus_1 then + return Machine (X); + + else + Result := Machine (Radix_To_M_Minus_1 + Result) - Radix_To_M_Minus_1; + + if Result > abs X then + Result := Result - 1.0; + end if; + + if X > 0.0 then + return Result; + + elsif X < 0.0 then + return -Result; + + -- For zero case, make sure sign of zero is preserved + + else + return X; + end if; + end if; + end Truncation; + + ----------------------- + -- Unbiased_Rounding -- + ----------------------- + + function Unbiased_Rounding (X : T) return T is + Abs_X : constant T := abs X; + Result : T; + Tail : T; + + begin + Result := Truncation (Abs_X); + Tail := Abs_X - Result; + + if Tail > 0.5 then + Result := Result + 1.0; + + elsif Tail = 0.5 then + Result := 2.0 * Truncation ((Result / 2.0) + 0.5); + end if; + + if X > 0.0 then + return Result; + + elsif X < 0.0 then + return -Result; + + -- For zero case, make sure sign of zero is preserved + + else + return X; + end if; + end Unbiased_Rounding; + + ----------- + -- Valid -- + ----------- + + -- Note: this routine does not work for VAX float. We compensate for this + -- in Exp_Attr by using the Valid functions in Vax_Float_Operations rather + -- than the corresponding instantiation of this function. + + function Valid (X : not null access T) return Boolean is + + IEEE_Emin : constant Integer := T'Machine_Emin - 1; + IEEE_Emax : constant Integer := T'Machine_Emax - 1; + + IEEE_Bias : constant Integer := -(IEEE_Emin - 1); + + subtype IEEE_Exponent_Range is + Integer range IEEE_Emin - 1 .. IEEE_Emax + 1; + + -- The implementation of this floating point attribute uses a + -- representation type Float_Rep that allows direct access to the + -- exponent and mantissa parts of a floating point number. + + -- The Float_Rep type is an array of Float_Word elements. This + -- representation is chosen to make it possible to size the type based + -- on a generic parameter. Since the array size is known at compile + -- time, efficient code can still be generated. The size of Float_Word + -- elements should be large enough to allow accessing the exponent in + -- one read, but small enough so that all floating point object sizes + -- are a multiple of the Float_Word'Size. + + -- The following conditions must be met for all possible instantiations + -- of the attributes package: + + -- - T'Size is an integral multiple of Float_Word'Size + + -- - The exponent and sign are completely contained in a single + -- component of Float_Rep, named Most_Significant_Word (MSW). + + -- - The sign occupies the most significant bit of the MSW and the + -- exponent is in the following bits. Unused bits (if any) are in + -- the least significant part. + + type Float_Word is mod 2**Positive'Min (System.Word_Size, 32); + type Rep_Index is range 0 .. 7; + + Rep_Words : constant Positive := + (T'Size + Float_Word'Size - 1) / Float_Word'Size; + Rep_Last : constant Rep_Index := + Rep_Index'Min + (Rep_Index (Rep_Words - 1), + (T'Mantissa + 16) / Float_Word'Size); + -- Determine the number of Float_Words needed for representing the + -- entire floating-point value. Do not take into account excessive + -- padding, as occurs on IA-64 where 80 bits floats get padded to 128 + -- bits. In general, the exponent field cannot be larger than 15 bits, + -- even for 128-bit floating-point types, so the final format size + -- won't be larger than T'Mantissa + 16. + + type Float_Rep is + array (Rep_Index range 0 .. Rep_Index (Rep_Words - 1)) of Float_Word; + + pragma Suppress_Initialization (Float_Rep); + -- This pragma suppresses the generation of an initialization procedure + -- for type Float_Rep when operating in Initialize/Normalize_Scalars + -- mode. This is not just a matter of efficiency, but of functionality, + -- since Valid has a pragma Inline_Always, which is not permitted if + -- there are nested subprograms present. + + Most_Significant_Word : constant Rep_Index := + Rep_Last * Standard'Default_Bit_Order; + -- Finding the location of the Exponent_Word is a bit tricky. In general + -- we assume Word_Order = Bit_Order. This expression needs to be refined + -- for VMS. + + Exponent_Factor : constant Float_Word := + 2**(Float_Word'Size - 1) / + Float_Word (IEEE_Emax - IEEE_Emin + 3) * + Boolean'Pos (Most_Significant_Word /= 2) + + Boolean'Pos (Most_Significant_Word = 2); + -- Factor that the extracted exponent needs to be divided by to be in + -- range 0 .. IEEE_Emax - IEEE_Emin + 2. Special kludge: Exponent_Factor + -- is 1 for x86/IA64 double extended as GCC adds unused bits to the + -- type. + + Exponent_Mask : constant Float_Word := + Float_Word (IEEE_Emax - IEEE_Emin + 2) * + Exponent_Factor; + -- Value needed to mask out the exponent field. This assumes that the + -- range IEEE_Emin - 1 .. IEEE_Emax + contains 2**N values, for some N + -- in Natural. + + function To_Float is new Ada.Unchecked_Conversion (Float_Rep, T); + + type Float_Access is access all T; + function To_Address is + new Ada.Unchecked_Conversion (Float_Access, System.Address); + + XA : constant System.Address := To_Address (Float_Access (X)); + + R : Float_Rep; + pragma Import (Ada, R); + for R'Address use XA; + -- R is a view of the input floating-point parameter. Note that we + -- must avoid copying the actual bits of this parameter in float + -- form (since it may be a signalling NaN. + + E : constant IEEE_Exponent_Range := + Integer ((R (Most_Significant_Word) and Exponent_Mask) / + Exponent_Factor) + - IEEE_Bias; + -- Mask/Shift T to only get bits from the exponent. Then convert biased + -- value to integer value. + + SR : Float_Rep; + -- Float_Rep representation of significant of X.all + + begin + if T'Denorm then + + -- All denormalized numbers are valid, so the only invalid numbers + -- are overflows and NaNs, both with exponent = Emax + 1. + + return E /= IEEE_Emax + 1; + + end if; + + -- All denormalized numbers except 0.0 are invalid + + -- Set exponent of X to zero, so we end up with the significand, which + -- definitely is a valid number and can be converted back to a float. + + SR := R; + SR (Most_Significant_Word) := + (SR (Most_Significant_Word) + and not Exponent_Mask) + Float_Word (IEEE_Bias) * Exponent_Factor; + + return (E in IEEE_Emin .. IEEE_Emax) or else + ((E = IEEE_Emin - 1) and then abs To_Float (SR) = 1.0); + end Valid; + + --------------------- + -- Unaligned_Valid -- + --------------------- + + function Unaligned_Valid (A : System.Address) return Boolean is + subtype FS is String (1 .. T'Size / Character'Size); + type FSP is access FS; + + function To_FSP is new Ada.Unchecked_Conversion (Address, FSP); + + Local_T : aliased T; + + begin + -- Note that we have to be sure that we do not load the value into a + -- floating-point register, since a signalling NaN may cause a trap. + -- The following assignment is what does the actual alignment, since + -- we know that the target Local_T is aligned. + + To_FSP (Local_T'Address).all := To_FSP (A).all; + + -- Now that we have an aligned value, we can use the normal aligned + -- version of Valid to obtain the required result. + + return Valid (Local_T'Access); + end Unaligned_Valid; + +end System.Fat_Gen; diff --git a/gcc/ada/s-fatgen.ads b/gcc/ada/s-fatgen.ads new file mode 100644 index 000000000..81d6b1b9e --- /dev/null +++ b/gcc/ada/s-fatgen.ads @@ -0,0 +1,129 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F A T _ G E N -- +-- -- +-- 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 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. See Unaligned_Valid for further discussion. + -- + -- Note: this routine does not work for Vax_Float ??? + + function Unaligned_Valid (A : System.Address) return Boolean; + -- This version of Valid is used if the floating-point value to + -- be checked is not known to be aligned (for example it appears + -- in a packed record). In this case, we cannot call Valid since + -- Valid assumes proper full alignment. Instead Unaligned_Valid + -- performs the same processing for a possibly unaligned float, + -- by first doing a copy and then calling Valid. One might think + -- that the front end could simply do a copy to an aligned temp, + -- but remember that we may have an abnormal value that cannot + -- be copied into a floating-point register, so things are a bit + -- trickier than one might expect. + -- + -- Note: Unaligned_Valid is never called for a target which does + -- not require strict alignment (e.g. the ia32/x86), since on a + -- target not requiring strict alignment, it is fine to pass a + -- non-aligned value to the standard Valid routine. + -- + -- Note: this routine does not work for Vax_Float ??? + +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 new file mode 100644 index 000000000..1f5cd5e0c --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..03dee6020 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..63f3a431e --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..c8f6bc662 --- /dev/null +++ b/gcc/ada/s-ficobl.ads @@ -0,0 +1,161 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 + + ---------------------------- + -- 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 null-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, using tmpfile). This + -- is currently not used since temporary files are deleted by the + -- operating system, but it is set properly in case some systems + -- need this information in the future. + + Is_System_File : Boolean; + -- A flag set only for system files (stdin, stdout, stderr) + + Is_Text_File : Boolean; + -- A flag set if the file was opened in text mode + + 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-fileio.adb b/gcc/ada/s-fileio.adb new file mode 100644 index 000000000..a11d83311 --- /dev/null +++ b/gcc/ada/s-fileio.adb @@ -0,0 +1,1234 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F I L E _ I O -- +-- -- +-- 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.Finalization; use Ada.Finalization; +with Ada.IO_Exceptions; use Ada.IO_Exceptions; + +with Interfaces.C; +with Interfaces.C.Strings; use Interfaces.C.Strings; +with Interfaces.C_Streams; use Interfaces.C_Streams; + +with System.CRTL.Runtime; +with System.Case_Util; use System.Case_Util; +with System.OS_Lib; +with System.Soft_Links; + +with Ada.Unchecked_Deallocation; + +package body System.File_IO is + + use System.File_Control_Block; + + package SSL renames System.Soft_Links; + + use type Interfaces.C.int; + use type CRTL.size_t; + + ---------------------- + -- Global Variables -- + ---------------------- + + Open_Files : AFCB_Ptr; + -- This points to a list of AFCB's for all open files. This is a doubly + -- linked list, with the Prev pointer of the first entry, and the Next + -- pointer of the last entry containing null. Note that this global + -- variable must be properly protected to provide thread safety. + + type Temp_File_Record; + type Temp_File_Record_Ptr is access all Temp_File_Record; + + type Temp_File_Record is record + Name : String (1 .. max_path_len + 1); + Next : Temp_File_Record_Ptr; + end record; + -- One of these is allocated for each temporary file created + + Temp_Files : Temp_File_Record_Ptr; + -- Points to list of names of temporary files. Note that this global + -- variable must be properly protected to provide thread safety. + + type File_IO_Clean_Up_Type is new Limited_Controlled with null record; + -- The closing of all open files and deletion of temporary files is an + -- action that takes place at the end of execution of the main program. + -- This action is implemented using a library level object which gets + -- finalized at the end of program execution. Note that the type is + -- limited, in order to stop the compiler optimizing away the declaration + -- which would be allowed in the non-limited case. + + procedure Finalize (V : in out File_IO_Clean_Up_Type); + -- This is the finalize operation that is used to do the cleanup + + File_IO_Clean_Up_Object : File_IO_Clean_Up_Type; + pragma Warnings (Off, File_IO_Clean_Up_Object); + -- This is the single object of the type that triggers the finalization + -- call. Since it is at the library level, this happens just before the + -- environment task is finalized. + + text_translation_required : Boolean; + for text_translation_required'Size use Character'Size; + pragma Import + (C, text_translation_required, "__gnat_text_translation_required"); + -- If true, add appropriate suffix to control string for Open + + function Get_Case_Sensitive return Integer; + pragma Import (C, Get_Case_Sensitive, + "__gnat_get_file_names_case_sensitive"); + File_Names_Case_Sensitive : constant Boolean := Get_Case_Sensitive /= 0; + -- Set to indicate whether the operating system convention is for file + -- names to be case sensitive (e.g., in Unix, set True), or non case + -- sensitive (e.g., in Windows, set False). + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Free_String is new Ada.Unchecked_Deallocation (String, Pstring); + + subtype Fopen_String is String (1 .. 4); + -- Holds open string (longest is "w+b" & nul) + + procedure Fopen_Mode + (Mode : File_Mode; + Text : Boolean; + Creat : Boolean; + Amethod : Character; + Fopstr : out Fopen_String); + -- Determines proper open mode for a file to be opened in the given + -- Ada mode. Text is true for a text file and false otherwise, and + -- Creat is true for a create call, and False for an open call. The + -- value stored in Fopstr is a nul-terminated string suitable for a + -- call to fopen or freopen. Amethod is the character designating + -- the access method from the Access_Method field of the FCB. + + function Errno_Message + (Errno : Integer := OS_Lib.Errno) return String; + function Errno_Message + (Name : String; + Errno : Integer := OS_Lib.Errno) return String; + -- Return a message suitable for "raise ... with Errno_Message (...)". + -- Errno defaults to the current errno, but should be passed explicitly if + -- there is significant code in between the call that sets errno and the + -- call to Errno_Message, in case that code also sets errno. The version + -- with Name includes that file name in the message. + + procedure Raise_Device_Error + (File : AFCB_Ptr; Errno : Integer := OS_Lib.Errno); + pragma No_Return (Raise_Device_Error); + -- Clear error indication on File and raise Device_Error with an exception + -- message providing errno information. + + ---------------- + -- Append_Set -- + ---------------- + + procedure Append_Set (File : AFCB_Ptr) is + begin + if File.Mode = Append_File then + if fseek (File.Stream, 0, SEEK_END) /= 0 then + Raise_Device_Error (File); + end if; + end if; + end Append_Set; + + ---------------- + -- Chain_File -- + ---------------- + + procedure Chain_File (File : AFCB_Ptr) is + begin + -- Take a task lock, to protect the global data value Open_Files + + SSL.Lock_Task.all; + + -- Do the chaining operation locked + + File.Next := Open_Files; + File.Prev := null; + Open_Files := File; + + if File.Next /= null then + File.Next.Prev := File; + end if; + + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Chain_File; + + --------------------- + -- Check_File_Open -- + --------------------- + + procedure Check_File_Open (File : AFCB_Ptr) is + begin + if File = null then + raise Status_Error with "file not open"; + end if; + end Check_File_Open; + + ----------------------- + -- Check_Read_Status -- + ----------------------- + + procedure Check_Read_Status (File : AFCB_Ptr) is + begin + if File = null then + raise Status_Error with "file not open"; + elsif File.Mode not in Read_File_Mode then + raise Mode_Error with "file not readable"; + end if; + end Check_Read_Status; + + ------------------------ + -- Check_Write_Status -- + ------------------------ + + procedure Check_Write_Status (File : AFCB_Ptr) is + begin + if File = null then + raise Status_Error with "file not open"; + elsif File.Mode = In_File then + raise Mode_Error with "file not writable"; + end if; + end Check_Write_Status; + + ----------- + -- Close -- + ----------- + + procedure Close (File_Ptr : access AFCB_Ptr) is + Close_Status : int := 0; + Dup_Strm : Boolean := False; + File : AFCB_Ptr renames File_Ptr.all; + Errno : Integer; + + begin + -- Take a task lock, to protect the global data value Open_Files + + SSL.Lock_Task.all; + + Check_File_Open (File); + AFCB_Close (File); + + -- Sever the association between the given file and its associated + -- external file. The given file is left closed. Do not perform system + -- closes on the standard input, output and error files and also do not + -- attempt to close a stream that does not exist (signalled by a null + -- stream value -- happens in some error situations). + + if not File.Is_System_File and then File.Stream /= NULL_Stream then + + -- Do not do an fclose if this is a shared file and there is at least + -- one other instance of the stream that is open. + + if File.Shared_Status = Yes then + declare + P : AFCB_Ptr; + + begin + P := Open_Files; + while P /= null loop + if P /= File and then File.Stream = P.Stream then + Dup_Strm := True; + exit; + end if; + + P := P.Next; + end loop; + end; + end if; + + -- Do the fclose unless this was a duplicate in the shared case + + if not Dup_Strm then + Close_Status := fclose (File.Stream); + + if Close_Status /= 0 then + Errno := OS_Lib.Errno; + end if; + end if; + end if; + + -- Dechain file from list of open files and then free the storage + + if File.Prev = null then + Open_Files := File.Next; + else + File.Prev.Next := File.Next; + end if; + + if File.Next /= null then + File.Next.Prev := File.Prev; + end if; + + -- Deallocate some parts of the file structure that were kept in heap + -- storage with the exception of system files (standard input, output + -- and error) since they had some information allocated in the stack. + + if not File.Is_System_File then + Free_String (File.Name); + Free_String (File.Form); + AFCB_Free (File); + end if; + + File := null; + + if Close_Status /= 0 then + Raise_Device_Error (null, Errno); + end if; + + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Close; + + ------------ + -- Delete -- + ------------ + + procedure Delete (File_Ptr : access AFCB_Ptr) is + File : AFCB_Ptr renames File_Ptr.all; + + begin + Check_File_Open (File); + + if not File.Is_Regular_File then + raise Use_Error with "cannot delete non-regular file"; + end if; + + declare + Filename : aliased constant String := File.Name.all; + + begin + Close (File_Ptr); + + -- Now unlink the external file. Note that we use the full name in + -- this unlink, because the working directory may have changed since + -- we did the open, and we want to unlink the right file! + + if unlink (Filename'Address) = -1 then + raise Use_Error with Errno_Message; + end if; + end; + end Delete; + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File (File : AFCB_Ptr) return Boolean is + begin + Check_File_Open (File); + + if feof (File.Stream) /= 0 then + return True; + + else + Check_Read_Status (File); + + if ungetc (fgetc (File.Stream), File.Stream) = EOF then + clearerr (File.Stream); + return True; + else + return False; + end if; + end if; + end End_Of_File; + + ------------------- + -- Errno_Message -- + ------------------- + + function Errno_Message (Errno : Integer := OS_Lib.Errno) return String is + Message : constant chars_ptr := CRTL.Runtime.strerror (Errno); + + begin + if Message = Null_Ptr then + return "errno =" & Errno'Img; + else + return Value (Message); + end if; + end Errno_Message; + + function Errno_Message + (Name : String; + Errno : Integer := OS_Lib.Errno) return String + is + begin + return Name & ": " & String'(Errno_Message (Errno)); + end Errno_Message; + + -------------- + -- Finalize -- + -------------- + + -- Note: we do not need to worry about locking against multiple task access + -- in this routine, since it is called only from the environment task just + -- before terminating execution. + + procedure Finalize (V : in out File_IO_Clean_Up_Type) is + pragma Warnings (Off, V); + + Fptr1 : aliased AFCB_Ptr; + Fptr2 : AFCB_Ptr; + + Discard : int; + pragma Unreferenced (Discard); + + begin + -- Take a lock to protect global Open_Files data structure + + SSL.Lock_Task.all; + + -- First close all open files (the slightly complex form of this loop is + -- required because Close as a side effect nulls out its argument). + + Fptr1 := Open_Files; + while Fptr1 /= null loop + Fptr2 := Fptr1.Next; + Close (Fptr1'Access); + Fptr1 := Fptr2; + end loop; + + -- Now unlink all temporary files. We do not bother to free the blocks + -- because we are just about to terminate the program. We also ignore + -- any errors while attempting these unlink operations. + + while Temp_Files /= null loop + Discard := unlink (Temp_Files.Name'Address); + Temp_Files := Temp_Files.Next; + end loop; + + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Finalize; + + ----------- + -- Flush -- + ----------- + + procedure Flush (File : AFCB_Ptr) is + begin + Check_Write_Status (File); + + if fflush (File.Stream) /= 0 then + Raise_Device_Error (File); + end if; + end Flush; + + ---------------- + -- Fopen_Mode -- + ---------------- + + -- The fopen mode to be used is shown by the following table: + + -- OPEN CREATE + -- Append_File "r+" "w+" + -- In_File "r" "w+" + -- Out_File (Direct_IO) "r+" "w" + -- Out_File (all others) "w" "w" + -- Inout_File "r+" "w+" + + -- Note: we do not use "a" or "a+" for Append_File, since this would not + -- work in the case of stream files, where even if in append file mode, + -- you can reset to earlier points in the file. The caller must use the + -- Append_Set routine to deal with the necessary positioning. + + -- Note: in several cases, the fopen mode used allows reading and writing, + -- but the setting of the Ada mode is more restrictive. For instance, + -- Create in In_File mode uses "w+" which allows writing, but the Ada mode + -- In_File will cause any write operations to be rejected with Mode_Error + -- in any case. + + -- Note: for the Out_File/Open cases for other than the Direct_IO case, an + -- initial call will be made by the caller to first open the file in "r" + -- mode to be sure that it exists. The real open, in "w" mode, will then + -- destroy this file. This is peculiar, but that's what Ada semantics + -- require and the ACATS tests insist on! + + -- If text file translation is required, then either "b" or "t" is appended + -- to the mode, depending on the setting of Text. + + procedure Fopen_Mode + (Mode : File_Mode; + Text : Boolean; + Creat : Boolean; + Amethod : Character; + Fopstr : out Fopen_String) + is + Fptr : Positive; + + begin + case Mode is + when In_File => + if Creat then + Fopstr (1) := 'w'; + Fopstr (2) := '+'; + Fptr := 3; + else + Fopstr (1) := 'r'; + Fptr := 2; + end if; + + when Out_File => + if Amethod = 'D' and then not Creat then + Fopstr (1) := 'r'; + Fopstr (2) := '+'; + Fptr := 3; + else + Fopstr (1) := 'w'; + Fptr := 2; + end if; + + when Inout_File | Append_File => + Fopstr (1) := (if Creat then 'w' else 'r'); + Fopstr (2) := '+'; + Fptr := 3; + + end case; + + -- If text_translation_required is true then we need to append either a + -- "t" or "b" to the string to get the right mode. + + if text_translation_required then + Fopstr (Fptr) := (if Text then 't' else 'b'); + Fptr := Fptr + 1; + end if; + + Fopstr (Fptr) := ASCII.NUL; + end Fopen_Mode; + + ---------- + -- Form -- + ---------- + + function Form (File : AFCB_Ptr) return String is + begin + if File = null then + raise Status_Error with "Form: file not open"; + else + return File.Form.all (1 .. File.Form'Length - 1); + end if; + end Form; + + ------------------ + -- Form_Boolean -- + ------------------ + + function Form_Boolean + (Form : String; + Keyword : String; + Default : Boolean) return Boolean + is + V1, V2 : Natural; + pragma Unreferenced (V2); + + begin + Form_Parameter (Form, Keyword, V1, V2); + + if V1 = 0 then + return Default; + + elsif Form (V1) = 'y' then + return True; + + elsif Form (V1) = 'n' then + return False; + + else + raise Use_Error with "invalid Form"; + end if; + end Form_Boolean; + + ------------------ + -- Form_Integer -- + ------------------ + + function Form_Integer + (Form : String; + Keyword : String; + Default : Integer) return Integer + is + V1, V2 : Natural; + V : Integer; + + begin + Form_Parameter (Form, Keyword, V1, V2); + + if V1 = 0 then + return Default; + + else + V := 0; + + for J in V1 .. V2 loop + if Form (J) not in '0' .. '9' then + raise Use_Error with "invalid Form"; + else + V := V * 10 + Character'Pos (Form (J)) - Character'Pos ('0'); + end if; + + if V > 999_999 then + raise Use_Error with "invalid Form"; + end if; + end loop; + + return V; + end if; + end Form_Integer; + + -------------------- + -- Form_Parameter -- + -------------------- + + procedure Form_Parameter + (Form : String; + Keyword : String; + Start : out Natural; + Stop : out Natural) + is + Klen : constant Integer := Keyword'Length; + + begin + for J in Form'First + Klen .. Form'Last - 1 loop + if Form (J) = '=' + and then Form (J - Klen .. J - 1) = Keyword + then + Start := J + 1; + Stop := Start - 1; + + while Form (Stop + 1) /= ASCII.NUL + and then Form (Stop + 1) /= ',' + loop + Stop := Stop + 1; + end loop; + + return; + end if; + end loop; + + Start := 0; + Stop := 0; + end Form_Parameter; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (File : AFCB_Ptr) return Boolean is + begin + -- We return True if the file is open, and the underlying file stream is + -- usable. In particular on Windows an application linked with -mwindows + -- option set does not have a console attached. In this case standard + -- files (Current_Output, Current_Error, Current_Input) are not created. + -- We want Is_Open (Current_Output) to return False in this case. + + return File /= null and then fileno (File.Stream) /= -1; + end Is_Open; + + ------------------- + -- Make_Buffered -- + ------------------- + + procedure Make_Buffered + (File : AFCB_Ptr; + Buf_Siz : Interfaces.C_Streams.size_t) + is + status : Integer; + pragma Unreferenced (status); + + begin + status := setvbuf (File.Stream, Null_Address, IOFBF, Buf_Siz); + end Make_Buffered; + + ------------------------ + -- Make_Line_Buffered -- + ------------------------ + + procedure Make_Line_Buffered + (File : AFCB_Ptr; + Line_Siz : Interfaces.C_Streams.size_t) + is + status : Integer; + pragma Unreferenced (status); + + begin + status := setvbuf (File.Stream, Null_Address, IOLBF, Line_Siz); + -- No error checking??? + end Make_Line_Buffered; + + --------------------- + -- Make_Unbuffered -- + --------------------- + + procedure Make_Unbuffered (File : AFCB_Ptr) is + status : Integer; + pragma Unreferenced (status); + + begin + status := setvbuf (File.Stream, Null_Address, IONBF, 0); + -- No error checking??? + end Make_Unbuffered; + + ---------- + -- Mode -- + ---------- + + function Mode (File : AFCB_Ptr) return File_Mode is + begin + if File = null then + raise Status_Error with "Mode: file not open"; + else + return File.Mode; + end if; + end Mode; + + ---------- + -- Name -- + ---------- + + function Name (File : AFCB_Ptr) return String is + begin + if File = null then + raise Status_Error with "Name: file not open"; + else + return File.Name.all (1 .. File.Name'Length - 1); + end if; + end Name; + + ---------- + -- Open -- + ---------- + + procedure Open + (File_Ptr : in out AFCB_Ptr; + Dummy_FCB : AFCB'Class; + Mode : File_Mode; + Name : String; + Form : String; + Amethod : Character; + Creat : Boolean; + Text : Boolean; + C_Stream : FILEs := NULL_Stream) + is + pragma Warnings (Off, Dummy_FCB); + -- Yes we know this is never assigned a value. That's intended, since + -- all we ever use of this value is the tag for dispatching purposes. + + procedure Tmp_Name (Buffer : Address); + pragma Import (C, Tmp_Name, "__gnat_tmp_name"); + -- Set buffer (a String address) with a temporary filename + + Stream : FILEs := C_Stream; + -- Stream which we open in response to this request + + Shared : Shared_Status_Type; + -- Setting of Shared_Status field for file + + Fopstr : aliased Fopen_String; + -- Mode string used in fopen call + + Formstr : aliased String (1 .. Form'Length + 1); + -- Form string with ASCII.NUL appended, folded to lower case + + Is_Text_File : Boolean; + + Tempfile : constant Boolean := (Name'Length = 0); + -- Indicates temporary file case + + Namelen : constant Integer := max_path_len; + -- Length required for file name, not including final ASCII.NUL. + -- Note that we used to reference L_tmpnam here, which is not reliable + -- since __gnat_tmp_name does not always use tmpnam. + + Namestr : aliased String (1 .. Namelen + 1); + -- Name as given or temporary file name with ASCII.NUL appended + + Fullname : aliased String (1 .. max_path_len + 1); + -- Full name (as required for Name function, and as stored in the + -- control block in the Name field) with ASCII.NUL appended. + + Full_Name_Len : Integer; + -- Length of name actually stored in Fullname + + Encoding : CRTL.Filename_Encoding; + -- Filename encoding specified into the form parameter + + begin + if File_Ptr /= null then + raise Status_Error with "file already open"; + end if; + + -- Acquire form string, setting required NUL terminator + + Formstr (1 .. Form'Length) := Form; + Formstr (Formstr'Last) := ASCII.NUL; + + -- Convert form string to lower case + + for J in Formstr'Range loop + if Formstr (J) in 'A' .. 'Z' then + Formstr (J) := Character'Val (Character'Pos (Formstr (J)) + 32); + end if; + end loop; + + -- Acquire setting of shared parameter + + declare + V1, V2 : Natural; + + begin + Form_Parameter (Formstr, "shared", V1, V2); + + if V1 = 0 then + Shared := None; + + elsif Formstr (V1 .. V2) = "yes" then + Shared := Yes; + + elsif Formstr (V1 .. V2) = "no" then + Shared := No; + + else + raise Use_Error with "invalid Form"; + end if; + end; + + -- Acquire setting of encoding parameter + + declare + V1, V2 : Natural; + + begin + Form_Parameter (Formstr, "encoding", V1, V2); + + if V1 = 0 then + Encoding := CRTL.Unspecified; + + elsif Formstr (V1 .. V2) = "utf8" then + Encoding := CRTL.UTF8; + + elsif Formstr (V1 .. V2) = "8bits" then + Encoding := CRTL.ASCII_8bits; + + else + raise Use_Error with "invalid Form"; + end if; + end; + + -- Acquire setting of text_translation parameter. Only needed if this is + -- a [Wide_[Wide_]]Text_IO file, in which case we default to True, but + -- if the Form says Text_Translation=No, we use binary mode, so new-line + -- will be just LF, even on Windows. + + Is_Text_File := Text; + + if Is_Text_File then + Is_Text_File := + Form_Boolean (Formstr, "text_translation", Default => True); + end if; + + -- If we were given a stream (call from xxx.C_Streams.Open), then set + -- the full name to the given one, and skip to end of processing. + + if Stream /= NULL_Stream then + Full_Name_Len := Name'Length + 1; + Fullname (1 .. Full_Name_Len - 1) := Name; + Fullname (Full_Name_Len) := ASCII.NUL; + + -- Normal case of Open or Create + + else + -- If temporary file case, get temporary file name and add to the + -- list of temporary files to be deleted on exit. + + if Tempfile then + if not Creat then + raise Name_Error with "opening temp file without creating it"; + end if; + + Tmp_Name (Namestr'Address); + + if Namestr (1) = ASCII.NUL then + raise Use_Error with "invalid temp file name"; + end if; + + -- Chain to temp file list, ensuring thread safety with a lock + + begin + SSL.Lock_Task.all; + Temp_Files := + new Temp_File_Record'(Name => Namestr, Next => Temp_Files); + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end; + + -- Normal case of non-null name given + + else + if Name'Length > Namelen then + raise Name_Error with "file name too long"; + end if; + + Namestr (1 .. Name'Length) := Name; + Namestr (Name'Length + 1) := ASCII.NUL; + end if; + + -- Get full name in accordance with the advice of RM A.8.2(22) + + full_name (Namestr'Address, Fullname'Address); + + if Fullname (1) = ASCII.NUL then + raise Use_Error with Errno_Message (Name); + end if; + + Full_Name_Len := 1; + while Full_Name_Len < Fullname'Last + and then Fullname (Full_Name_Len) /= ASCII.NUL + loop + Full_Name_Len := Full_Name_Len + 1; + end loop; + + -- Fullname is generated by calling system's full_name. The problem + -- is, full_name does nothing about the casing, so a file name + -- comparison may generally speaking not be valid on non-case- + -- sensitive systems, and in particular we get unexpected failures + -- on Windows/Vista because of this. So we use s-casuti to force + -- the name to lower case. + + if not File_Names_Case_Sensitive then + To_Lower (Fullname (1 .. Full_Name_Len)); + end if; + + -- If Shared=None or Shared=Yes, then check for the existence of + -- another file with exactly the same full name. + + if Shared /= No then + declare + P : AFCB_Ptr; + + begin + -- Take a task lock to protect Open_Files + + SSL.Lock_Task.all; + + -- Search list of open files + + P := Open_Files; + while P /= null loop + if Fullname (1 .. Full_Name_Len) = P.Name.all then + + -- If we get a match, and either file has Shared=None, + -- then raise Use_Error, since we don't allow two files + -- of the same name to be opened unless they specify the + -- required sharing mode. + + if Shared = None + or else P.Shared_Status = None + then + raise Use_Error with "reopening shared file"; + + -- If both files have Shared=Yes, then we acquire the + -- stream from the located file to use as our stream. + + elsif Shared = Yes + and then P.Shared_Status = Yes + then + Stream := P.Stream; + exit; + + -- Otherwise one of the files has Shared=Yes and one has + -- Shared=No. If the current file has Shared=No then all + -- is well but we don't want to share any other file's + -- stream. If the current file has Shared=Yes, we would + -- like to share a stream, but not from a file that has + -- Shared=No, so either way, we just continue the search. + + else + null; + end if; + end if; + + P := P.Next; + end loop; + + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end; + end if; + + -- Open specified file if we did not find an existing stream + + if Stream = NULL_Stream then + Fopen_Mode (Mode, Is_Text_File, Creat, Amethod, Fopstr); + + -- A special case, if we are opening (OPEN case) a file and the + -- mode returned by Fopen_Mode is not "r" or "r+", then we first + -- make sure that the file exists as required by Ada semantics. + + if not Creat and then Fopstr (1) /= 'r' then + if file_exists (Namestr'Address) = 0 then + raise Name_Error with Errno_Message (Name); + end if; + end if; + + -- Now open the file. Note that we use the name as given in the + -- original Open call for this purpose, since that seems the + -- clearest implementation of the intent. It would presumably + -- work to use the full name here, but if there is any difference, + -- then we should use the name used in the call. + + -- Note: for a corresponding delete, we will use the full name, + -- since by the time of the delete, the current working directory + -- may have changed and we do not want to delete a different file! + + Stream := fopen (Namestr'Address, Fopstr'Address, Encoding); + + if Stream = NULL_Stream then + + -- Raise Name_Error if trying to open a non-existent file. + -- Otherwise raise Use_Error. + + -- Should we raise Device_Error for ENOSPC??? + + declare + function Is_File_Not_Found_Error + (Errno_Value : Integer) return Integer; + -- Non-zero when the given errno value indicates a non- + -- existing file. + + pragma Import + (C, Is_File_Not_Found_Error, + "__gnat_is_file_not_found_error"); + + Errno : constant Integer := OS_Lib.Errno; + Message : constant String := Errno_Message (Name, Errno); + begin + if Is_File_Not_Found_Error (Errno) /= 0 then + raise Name_Error with Message; + else + raise Use_Error with Message; + end if; + end; + end if; + end if; + end if; + + -- Stream has been successfully located or opened, so now we are + -- committed to completing the opening of the file. Allocate block on + -- heap and fill in its fields. + + File_Ptr := AFCB_Allocate (Dummy_FCB); + + File_Ptr.Is_Regular_File := (is_regular_file (fileno (Stream)) /= 0); + File_Ptr.Is_System_File := False; + File_Ptr.Is_Text_File := Is_Text_File; + File_Ptr.Shared_Status := Shared; + File_Ptr.Access_Method := Amethod; + File_Ptr.Stream := Stream; + File_Ptr.Form := new String'(Formstr); + File_Ptr.Name := new String'(Fullname (1 .. Full_Name_Len)); + File_Ptr.Mode := Mode; + File_Ptr.Is_Temporary_File := Tempfile; + File_Ptr.Encoding := Encoding; + + Chain_File (File_Ptr); + Append_Set (File_Ptr); + end Open; + + ------------------------ + -- Raise_Device_Error -- + ------------------------ + + procedure Raise_Device_Error + (File : AFCB_Ptr; Errno : Integer := OS_Lib.Errno) + is + begin + -- Clear error status so that the same error is not reported twice + + if File /= null then + clearerr (File.Stream); + end if; + + raise Device_Error with Errno_Message (Errno); + end Raise_Device_Error; + + -------------- + -- Read_Buf -- + -------------- + + procedure Read_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is + Nread : size_t; + + begin + Nread := fread (Buf, 1, Siz, File.Stream); + + if Nread = Siz then + return; + + elsif ferror (File.Stream) /= 0 then + Raise_Device_Error (File); + + elsif Nread = 0 then + raise End_Error; + + else -- 0 < Nread < Siz + raise Data_Error with "not enough data read"; + end if; + + end Read_Buf; + + procedure Read_Buf + (File : AFCB_Ptr; + Buf : Address; + Siz : Interfaces.C_Streams.size_t; + Count : out Interfaces.C_Streams.size_t) + is + begin + Count := fread (Buf, 1, Siz, File.Stream); + + if Count = 0 and then ferror (File.Stream) /= 0 then + Raise_Device_Error (File); + end if; + end Read_Buf; + + ----------- + -- Reset -- + ----------- + + -- The reset which does not change the mode simply does a rewind + + procedure Reset (File_Ptr : access AFCB_Ptr) is + File : AFCB_Ptr renames File_Ptr.all; + begin + Check_File_Open (File); + Reset (File_Ptr, File.Mode); + end Reset; + + -- The reset with a change in mode is done using freopen, and is not + -- permitted except for regular files (since otherwise there is no name for + -- the freopen, and in any case it seems meaningless). + + procedure Reset (File_Ptr : access AFCB_Ptr; Mode : File_Mode) is + File : AFCB_Ptr renames File_Ptr.all; + Fopstr : aliased Fopen_String; + + begin + Check_File_Open (File); + + -- Change of mode not allowed for shared file or file with no name or + -- file that is not a regular file, or for a system file. Note that we + -- allow the "change" of mode if it is not in fact doing a change. + + if Mode /= File.Mode then + if File.Shared_Status = Yes then + raise Use_Error with "cannot change mode of shared file"; + elsif File.Name'Length <= 1 then + raise Use_Error with "cannot change mode of temp file"; + elsif File.Is_System_File then + raise Use_Error with "cannot change mode of system file"; + elsif not File.Is_Regular_File then + raise Use_Error with "cannot change mode of non-regular file"; + end if; + end if; + + -- For In_File or Inout_File for a regular file, we can just do a rewind + -- if the mode is unchanged, which is more efficient than doing a full + -- reopen. + + if Mode = File.Mode + and then Mode in Read_File_Mode + then + rewind (File.Stream); + + -- Here the change of mode is permitted, we do it by reopening the file + -- in the new mode and replacing the stream with a new stream. + + else + Fopen_Mode + (Mode, File.Is_Text_File, False, File.Access_Method, Fopstr); + + File.Stream := freopen + (File.Name.all'Address, Fopstr'Address, File.Stream, File.Encoding); + + if File.Stream = NULL_Stream then + Close (File_Ptr); + raise Use_Error; + + else + File.Mode := Mode; + Append_Set (File); + end if; + end if; + end Reset; + + --------------- + -- Write_Buf -- + --------------- + + procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is + begin + -- Note: for most purposes, the Siz and 1 parameters in the fwrite call + -- could be reversed, but on VMS, this is a better choice, since for + -- some file formats, reversing the parameters results in records of one + -- byte each. + + SSL.Abort_Defer.all; + + if fwrite (Buf, Siz, 1, File.Stream) /= 1 then + if Siz /= 0 then + SSL.Abort_Undefer.all; + Raise_Device_Error (File); + end if; + end if; + + SSL.Abort_Undefer.all; + end Write_Buf; + +end System.File_IO; diff --git a/gcc/ada/s-fileio.ads b/gcc/ada/s-fileio.ads new file mode 100644 index 000000000..5ee0c5b99 --- /dev/null +++ b/gcc/ada/s-fileio.ads @@ -0,0 +1,254 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F I L E _ 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 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 + + 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-filofl.ads b/gcc/ada/s-filofl.ads new file mode 100644 index 000000000..e3aba15d5 --- /dev/null +++ b/gcc/ada/s-filofl.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F A T _ I E E E _ L O N G _ F L O A 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 IEEE long float. This is used on VMS targets where +-- we can't just use Long_Float, since this may have been mapped to Vax_Float +-- using a Float_Representation configuration pragma. + +with System.Fat_Gen; + +package System.Fat_IEEE_Long_Float is + pragma Pure; + + type Fat_IEEE_Long is digits 15; + pragma Float_Representation (IEEE_Float, Fat_IEEE_Long); + + -- 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_IEEE_Long is new System.Fat_Gen (Fat_IEEE_Long); + +end System.Fat_IEEE_Long_Float; diff --git a/gcc/ada/s-finimp.adb b/gcc/ada/s-finimp.adb new file mode 100644 index 000000000..050f79995 --- /dev/null +++ b/gcc/ada/s-finimp.adb @@ -0,0 +1,540 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F I N A L I Z A T I O N _ I M P L E M E N T A T I O 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Exceptions; +with Ada.Tags; + +with System.Soft_Links; + +with System.Restrictions; + +package body System.Finalization_Implementation is + + use Ada.Exceptions; + use System.Finalization_Root; + + package SSL renames System.Soft_Links; + + use type SSE.Storage_Offset; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + type RC_Ptr is access all Record_Controller; + + function To_RC_Ptr is + new Ada.Unchecked_Conversion (Address, RC_Ptr); + + procedure Raise_From_Controlled_Operation (X : Exception_Occurrence); + pragma Import + (Ada, Raise_From_Controlled_Operation, + "ada__exceptions__raise_from_controlled_operation"); + pragma No_Return (Raise_From_Controlled_Operation); + -- Raise Program_Error from an exception that occurred during an Adjust or + -- Finalize operation. We use this rather kludgy Ada Import interface + -- because this procedure is not available in the visible part of the + -- Ada.Exceptions spec. + + procedure Raise_From_Finalize + (L : Finalizable_Ptr; + From_Abort : Boolean; + E_Occ : Exception_Occurrence); + -- Deal with an exception raised during finalization of a list. L is a + -- pointer to the list of element not yet finalized. From_Abort is true + -- if the finalization actions come from an abort rather than a normal + -- exit. E_Occ represents the exception being raised. + + function RC_Offset (T : Ada.Tags.Tag) return SSE.Storage_Offset; + pragma Import (Ada, RC_Offset, "ada__tags__get_rc_offset"); + + function Parent_Size (Obj : Address; T : Ada.Tags.Tag) + return SSE.Storage_Count; + pragma Import (Ada, Parent_Size, "ada__tags__parent_size"); + + function Get_Deep_Controller (Obj : System.Address) return RC_Ptr; + -- Given the address (obj) of a tagged object, return a + -- pointer to the record controller of this object. + + ------------ + -- Adjust -- + ------------ + + overriding procedure Adjust (Object : in out Record_Controller) is + + First_Comp : Finalizable_Ptr; + My_Offset : constant SSE.Storage_Offset := + Object.My_Address - Object'Address; + + procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr); + -- Subtract the offset to the pointer + + procedure Reverse_Adjust (P : Finalizable_Ptr); + -- Adjust the components in the reverse order in which they are stored + -- on the finalization list. (Adjust and Finalization are not done in + -- the same order) + + ---------------- + -- Ptr_Adjust -- + ---------------- + + procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr) is + begin + if Ptr /= null then + Ptr := To_Finalizable_Ptr (To_Addr (Ptr) - My_Offset); + end if; + end Ptr_Adjust; + + -------------------- + -- Reverse_Adjust -- + -------------------- + + procedure Reverse_Adjust (P : Finalizable_Ptr) is + begin + if P /= null then + Ptr_Adjust (P.Next); + Reverse_Adjust (P.Next); + Adjust (P.all); + Object.F := P; -- Successfully adjusted, so place in list + end if; + end Reverse_Adjust; + + -- Start of processing for Adjust + + begin + -- Adjust the components and their finalization pointers next. We must + -- protect against an exception in some call to Adjust, so we keep + -- pointing to the list of successfully adjusted components, which can + -- be finalized if an exception is raised. + + First_Comp := Object.F; + Object.F := null; -- nothing adjusted yet. + Ptr_Adjust (First_Comp); -- set address of first component. + Reverse_Adjust (First_Comp); + + -- Then Adjust the controller itself + + Object.My_Address := Object'Address; + + exception + when others => + -- Finalize those components that were successfully adjusted, and + -- propagate exception. The object itself is not yet attached to + -- global finalization list, so we cannot rely on the outer call to + -- Clean to take care of these components. + + Finalize (Object); + raise; + end Adjust; + + -------------------------- + -- Attach_To_Final_List -- + -------------------------- + + procedure Attach_To_Final_List + (L : in out Finalizable_Ptr; + Obj : in out Finalizable; + Nb_Link : Short_Short_Integer) + is + begin + -- Simple case: attachment to a one way list + + if Nb_Link = 1 then + Obj.Next := L; + L := Obj'Unchecked_Access; + + -- Dynamically allocated objects: they are attached to a doubly linked + -- list, so that an element can be finalized at any moment by means of + -- an unchecked deallocation. Attachment is protected against + -- multi-threaded access. + + elsif Nb_Link = 2 then + + -- Raise Program_Error if we're trying to allocate an object in a + -- collection whose finalization has already started. + + if L = Collection_Finalization_Started then + raise Program_Error with + "allocation after collection finalization started"; + end if; + + Locked_Processing : begin + SSL.Lock_Task.all; + Obj.Next := L.Next; + Obj.Prev := L.Next.Prev; + L.Next.Prev := Obj'Unchecked_Access; + L.Next := Obj'Unchecked_Access; + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Locked_Processing; + + -- Attachment of arrays to the final list (used only for objects + -- returned by function). Obj, in this case is the last element, + -- but all other elements are already threaded after it. We just + -- attach the rest of the final list at the end of the array list. + + elsif Nb_Link = 3 then + declare + P : Finalizable_Ptr := Obj'Unchecked_Access; + + begin + while P.Next /= null loop + P := P.Next; + end loop; + + P.Next := L; + L := Obj'Unchecked_Access; + end; + + -- Make the object completely unattached (case of a library-level, + -- Finalize_Storage_Only object). + + elsif Nb_Link = 4 then + Obj.Prev := null; + Obj.Next := null; + end if; + end Attach_To_Final_List; + + --------------------- + -- Deep_Tag_Attach -- + ---------------------- + + procedure Deep_Tag_Attach + (L : in out SFR.Finalizable_Ptr; + A : System.Address; + B : Short_Short_Integer) + is + V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A); + Controller : constant RC_Ptr := Get_Deep_Controller (A); + + begin + if Controller /= null then + Attach_To_Final_List (L, Controller.all, B); + end if; + + -- Is controlled + + if V.all in Finalizable then + Attach_To_Final_List (L, V.all, B); + end if; + end Deep_Tag_Attach; + + ----------------------------- + -- Detach_From_Final_List -- + ----------------------------- + + -- We know that the detach object is neither at the beginning nor at the + -- end of the list, thanks to the dummy First and Last Elements, but the + -- object may not be attached at all if it is Finalize_Storage_Only + + procedure Detach_From_Final_List (Obj : in out Finalizable) is + begin + -- When objects are not properly attached to a doubly linked list do + -- not try to detach them. The only case where it can happen is when + -- dealing with Finalize_Storage_Only objects which are not always + -- attached to the finalization list. + + if Obj.Next /= null and then Obj.Prev /= null then + SSL.Lock_Task.all; + Obj.Next.Prev := Obj.Prev; + Obj.Prev.Next := Obj.Next; + + -- Reset the pointers so that a new finalization of the same object + -- has no effect on the finalization list. + + Obj.Next := null; + Obj.Prev := null; + + SSL.Unlock_Task.all; + end if; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Detach_From_Final_List; + + -------------- + -- Finalize -- + -------------- + + overriding procedure Finalize (Object : in out Limited_Record_Controller) is + begin + Finalize_List (Object.F); + end Finalize; + + -------------------------- + -- Finalize_Global_List -- + -------------------------- + + procedure Finalize_Global_List is + begin + -- There are three case here: + + -- a. the application uses tasks, in which case Finalize_Global_Tasks + -- will defer abort. + + -- b. the application doesn't use tasks but uses other tasking + -- constructs, such as ATCs and protected objects. In this case, + -- the binder will call Finalize_Global_List instead of + -- Finalize_Global_Tasks, letting abort undeferred, and leading + -- to assertion failures in the GNULL + + -- c. the application doesn't use any tasking construct in which case + -- deferring abort isn't necessary. + + -- Until another solution is found to deal with case b, we need to + -- call abort_defer here to pass the checks, but we do not need to + -- undefer abort, since Finalize_Global_List is the last procedure + -- called before exiting the partition. + + SSL.Abort_Defer.all; + Finalize_List (Global_Final_List); + end Finalize_Global_List; + + ------------------- + -- Finalize_List -- + ------------------- + + procedure Finalize_List (L : Finalizable_Ptr) is + P : Finalizable_Ptr := L; + Q : Finalizable_Ptr; + + type Fake_Exception_Occurrence is record + Id : Exception_Id; + end record; + type Ptr is access all Fake_Exception_Occurrence; + + function To_Ptr is new + Ada.Unchecked_Conversion (Exception_Occurrence_Access, Ptr); + + X : Exception_Id := Null_Id; + + begin + -- If abort is allowed, we get the current exception before starting + -- to finalize in order to check if we are in the abort case if an + -- exception is raised. When abort is not allowed, avoid accessing the + -- current exception since this can be a pretty costly operation in + -- programs using controlled types heavily. + + if System.Restrictions.Abort_Allowed then + X := To_Ptr (SSL.Get_Current_Excep.all).Id; + end if; + + while P /= null loop + Q := P.Next; + Finalize (P.all); + P := Q; + end loop; + + exception + when E_Occ : others => + Raise_From_Finalize ( + Q, + X = Standard'Abort_Signal'Identity, + E_Occ); + end Finalize_List; + + ------------------ + -- Finalize_One -- + ------------------ + + procedure Finalize_One (Obj : in out Finalizable) is + begin + Detach_From_Final_List (Obj); + Finalize (Obj); + exception + when E_Occ : others => Raise_From_Finalize (null, False, E_Occ); + end Finalize_One; + + ------------------------- + -- Get_Deep_Controller -- + ------------------------- + + function Get_Deep_Controller (Obj : System.Address) return RC_Ptr is + The_Tag : Ada.Tags.Tag := To_Finalizable_Ptr (Obj)'Tag; + Offset : SSE.Storage_Offset := RC_Offset (The_Tag); + + begin + -- Fetch the controller from the Parent or above if necessary + -- when there are no controller at this level. + + while Offset = -2 loop + The_Tag := Ada.Tags.Parent_Tag (The_Tag); + Offset := RC_Offset (The_Tag); + end loop; + + -- No Controlled component case + + if Offset = 0 then + return null; + + -- The _controller Offset is known statically + + elsif Offset > 0 then + return To_RC_Ptr (Obj + Offset); + + -- At this stage, we know that the controller is part of the + -- ancestor corresponding to the tag "The_Tag" and that its parent + -- is variable sized. We assume that the _controller is the first + -- component right after the parent. + + -- ??? note that it may not be true if there are new discriminants + + else -- Offset = -1 + + declare + -- define a faked record controller to avoid generating + -- unnecessary expanded code for controlled types + + type Faked_Record_Controller is record + Tag, Prec, Next : Address; + end record; + + -- Reconstruction of a type with characteristics + -- comparable to the original type + + D : constant := SSE.Storage_Offset (Storage_Unit - 1); + + type Parent_Type is new SSE.Storage_Array + (1 .. (Parent_Size (Obj, The_Tag) + D) / + SSE.Storage_Offset (Storage_Unit)); + for Parent_Type'Alignment use Address'Alignment; + + type Faked_Type_Of_Obj is record + Parent : Parent_Type; + Controller : Faked_Record_Controller; + end record; + + type Obj_Ptr is access all Faked_Type_Of_Obj; + function To_Obj_Ptr is + new Ada.Unchecked_Conversion (Address, Obj_Ptr); + + begin + return To_RC_Ptr (To_Obj_Ptr (Obj).Controller'Address); + end; + end if; + end Get_Deep_Controller; + + ---------------- + -- Initialize -- + ---------------- + + overriding procedure Initialize + (Object : in out Limited_Record_Controller) + is + pragma Warnings (Off, Object); + begin + null; + end Initialize; + + overriding procedure Initialize (Object : in out Record_Controller) is + begin + Object.My_Address := Object'Address; + end Initialize; + + --------------------- + -- Move_Final_List -- + --------------------- + + procedure Move_Final_List + (From : in out SFR.Finalizable_Ptr; + To : Finalizable_Ptr_Ptr) + is + begin + -- This is currently called at the end of the return statement, and the + -- caller does NOT defer aborts. We need to defer aborts to prevent + -- mangling the finalization lists. + + SSL.Abort_Defer.all; + + -- Put the return statement's finalization list onto the caller's one, + -- thus transferring responsibility for finalization of the return + -- object to the caller. + + Attach_To_Final_List (To.all, From.all, Nb_Link => 3); + + -- Empty the return statement's finalization list, so that when the + -- cleanup code executes, there will be nothing to finalize. + From := null; + + SSL.Abort_Undefer.all; + end Move_Final_List; + + ------------------------- + -- Raise_From_Finalize -- + ------------------------- + + procedure Raise_From_Finalize + (L : Finalizable_Ptr; + From_Abort : Boolean; + E_Occ : Exception_Occurrence) + is + P : Finalizable_Ptr := L; + Q : Finalizable_Ptr; + + begin + -- We already got an exception. We now finalize the remainder of + -- the list, ignoring all further exceptions. + + while P /= null loop + Q := P.Next; + + begin + Finalize (P.all); + exception + when others => null; + end; + + P := Q; + end loop; + + if From_Abort then + -- If finalization from an Abort, then nothing to do + + null; + + else + -- Else raise Program_Error with an appropriate message + + Raise_From_Controlled_Operation (E_Occ); + end if; + end Raise_From_Finalize; + +-- Initialization of package, set Adafinal soft link + +begin + SSL.Finalize_Global_List := Finalize_Global_List'Access; +end System.Finalization_Implementation; diff --git a/gcc/ada/s-finimp.ads b/gcc/ada/s-finimp.ads new file mode 100644 index 000000000..944fe6f11 --- /dev/null +++ b/gcc/ada/s-finimp.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F I N A L I Z A T I O N _ I M P L E M E N T A T I O N -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +with System.Storage_Elements; +with System.Finalization_Root; + +package System.Finalization_Implementation is + pragma Elaborate_Body; + + package SSE renames System.Storage_Elements; + package SFR renames System.Finalization_Root; + + ------------------------------------------------ + -- Finalization Management Abstract Interface -- + ------------------------------------------------ + + function To_Finalizable_Ptr is new Ada.Unchecked_Conversion + (Source => System.Address, Target => SFR.Finalizable_Ptr); + + Collection_Finalization_Started : constant SFR.Finalizable_Ptr := + To_Finalizable_Ptr (SSE.To_Address (1)); + -- This is used to implement the rule in RM 4.8(10.2/2) that requires an + -- allocator to raise Program_Error if the collection finalization has + -- already started. See also Ada.Finalization.List_Controller. Finalize on + -- List_Controller first sets the list to Collection_Finalization_Started, + -- to indicate that finalization has started. An allocator will call + -- Attach_To_Final_List, which checks for the special value and raises + -- Program_Error if appropriate. The Collection_Finalization_Started value + -- must be different from 'Access of any finalizable object, and different + -- from null. See AI-280. + + Global_Final_List : SFR.Finalizable_Ptr; + -- This list stores the controlled objects defined in library-level + -- packages. They will be finalized after the main program completion. + + procedure Finalize_Global_List; + -- The procedure to be called in order to finalize the global list + + procedure Attach_To_Final_List + (L : in out SFR.Finalizable_Ptr; + Obj : in out SFR.Finalizable; + Nb_Link : Short_Short_Integer); + -- Attach finalizable object Obj to the linked list L. Nb_Link controls the + -- number of link of the linked_list, and is one of: 0 for no attachment, 1 + -- for simple linked lists or 2 for doubly linked lists or even 3 for a + -- simple attachment of a whole array of elements. Attachment to a simply + -- linked list is not protected against concurrent access and should only + -- be used in contexts where it doesn't matter, such as for objects + -- allocated on the stack. In the case of an attachment on a doubly linked + -- list, L must not be null and Obj will be inserted AFTER the first + -- element and the attachment is protected against concurrent call. + -- Typically used to attach to a dynamically allocated object to a + -- List_Controller (whose first element is always a dummy element) + + type Finalizable_Ptr_Ptr is access all SFR.Finalizable_Ptr; + -- A pointer to a finalization list. This is used as the type of the extra + -- implicit formal which are passed to build-in-place functions that return + -- controlled types (see Sem_Ch6). That extra formal is then passed on to + -- Move_Final_List (below). + + procedure Move_Final_List + (From : in out SFR.Finalizable_Ptr; + To : Finalizable_Ptr_Ptr); + -- Move all objects on From list to To list. This is used to implement + -- build-in-place function returns. The return object is initially placed + -- on a finalization list local to the return statement, in case the + -- return statement is left prematurely (due to raising an exception, + -- being aborted, or a goto or exit statement). Once the return statement + -- has completed successfully, Move_Final_List is called to move the + -- return object to the caller's finalization list. + + procedure Finalize_List (L : SFR.Finalizable_Ptr); + -- Call Finalize on each element of the list L + + procedure Finalize_One (Obj : in out SFR.Finalizable); + -- Call Finalize on Obj and remove its final list + + --------------------- + -- Deep Procedures -- + --------------------- + + procedure Deep_Tag_Attach + (L : in out SFR.Finalizable_Ptr; + A : System.Address; + B : Short_Short_Integer); + -- Generic attachment for tagged objects with controlled components. + -- A is the address of the object, L the finalization list when it needs + -- to be attached and B the attachment level (see Attach_To_Final_List). + + ----------------------------- + -- Record Controller Types -- + ----------------------------- + + -- Definition of the types of the controller component that is included + -- in records containing controlled components. This controller is + -- attached to the finalization chain of the upper-level and carries + -- the pointer of the finalization chain for the lower level. + + type Limited_Record_Controller is new SFR.Root_Controlled with record + F : SFR.Finalizable_Ptr; + end record; + + overriding procedure Initialize (Object : in out Limited_Record_Controller); + -- Does nothing currently + + overriding procedure Finalize (Object : in out Limited_Record_Controller); + -- Finalize the controlled components of the enclosing record by following + -- the list starting at Object.F. + + type Record_Controller is + new Limited_Record_Controller with record + My_Address : System.Address; + end record; + + overriding procedure Initialize (Object : in out Record_Controller); + -- Initialize the field My_Address to the Object'Address + + overriding procedure Adjust (Object : in out Record_Controller); + -- Adjust the components and their finalization pointers by subtracting by + -- the offset of the target and the source addresses of the assignment. + + -- Inherit Finalize from Limited_Record_Controller + + procedure Detach_From_Final_List (Obj : in out SFR.Finalizable); + -- Remove the specified object from its Final list, which must be a doubly + -- linked list. + +end System.Finalization_Implementation; diff --git a/gcc/ada/s-finroo.adb b/gcc/ada/s-finroo.adb new file mode 100644 index 000000000..ec8792338 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..da373f7c3 --- /dev/null +++ b/gcc/ada/s-finroo.ads @@ -0,0 +1,85 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 + +with Ada.Streams; +with Ada.Unchecked_Conversion; + +package System.Finalization_Root is + pragma Preelaborate; + + type Root_Controlled is tagged; + + type Finalizable_Ptr is access all Root_Controlled'Class; + + function To_Finalizable_Ptr is + new Ada.Unchecked_Conversion (Address, Finalizable_Ptr); + + function To_Addr is + new Ada.Unchecked_Conversion (Finalizable_Ptr, Address); + + type Empty_Root_Controlled is abstract tagged null record; + -- Just for the sake of Controlled equality (see Ada.Finalization) + + type Root_Controlled is new Empty_Root_Controlled with record + Prev, Next : Finalizable_Ptr; + end record; + subtype Finalizable is Root_Controlled'Class; + + procedure Initialize (Object : in out Root_Controlled); + procedure Finalize (Object : in out Root_Controlled); + procedure Adjust (Object : in out Root_Controlled); + + -- Stream-oriented attributes for Root_Controlled. These must be empty so + -- as to not copy the finalization chain pointers. They are declared in + -- a nested package so that they do not create primitive operations of + -- Root_Controlled. Otherwise this would add unwanted primitives to (the + -- full view of) Ada.Finalization.Limited_Controlled, which would cause + -- trouble in cases where a limited controlled type is used as the + -- designated type of a remote access-to-classwide type. + + package Stream_Attributes is + + procedure Write + (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + Item : Root_Controlled) is null; + + procedure Read + (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + Item : out Root_Controlled) is null; + + end Stream_Attributes; + + for Root_Controlled'Read use Stream_Attributes.Read; + for Root_Controlled'Write use Stream_Attributes.Write; + +end System.Finalization_Root; diff --git a/gcc/ada/s-fishfl.ads b/gcc/ada/s-fishfl.ads new file mode 100644 index 000000000..335b714b6 --- /dev/null +++ b/gcc/ada/s-fishfl.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F A T _ I E E E _ S H O R T _ F L O A T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-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 contains an instantiation of the floating-point attribute +-- runtime routines for IEEE short float. This is used on VMS targets where +-- we can't just use Float, since this may have been mapped to Vax_Float +-- using a Float_Representation configuration pragma. + +with System.Fat_Gen; + +package System.Fat_IEEE_Short_Float is + pragma Pure; + + type Fat_IEEE_Short is digits 6; + pragma Float_Representation (IEEE_Float, Fat_IEEE_Short); + + -- 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_IEEE_Short is new System.Fat_Gen (Fat_IEEE_Short); + +end System.Fat_IEEE_Short_Float; diff --git a/gcc/ada/s-fore.adb b/gcc/ada/s-fore.adb new file mode 100644 index 000000000..5d5a2836e --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..b25024ada --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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-fvadfl.ads b/gcc/ada/s-fvadfl.ads new file mode 100644 index 000000000..a007fdf76 --- /dev/null +++ b/gcc/ada/s-fvadfl.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F A T _ V A X _ D _ F L O A T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-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 contains an instantiation of the floating-point attribute +-- runtime routines for VAX D-float for use on VMS targets. + +with System.Fat_Gen; + +package System.Fat_VAX_D_Float is + pragma Pure; + + pragma Warnings (Off); + -- This unit is normally used only for VMS, but we compile it for other + -- targets for the convenience of testing vms code using -gnatdm. + + type Fat_VAX_D is digits 9; + pragma Float_Representation (VAX_Float, Fat_VAX_D); + + -- 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_VAX_D_Float is new System.Fat_Gen (Fat_VAX_D); + +end System.Fat_VAX_D_Float; diff --git a/gcc/ada/s-fvaffl.ads b/gcc/ada/s-fvaffl.ads new file mode 100644 index 000000000..13dd0c794 --- /dev/null +++ b/gcc/ada/s-fvaffl.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F A T _ V A X _ F _ F L O A T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-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 contains an instantiation of the floating-point attribute +-- runtime routines for VAX F-float for use on VMS targets. + +with System.Fat_Gen; + +package System.Fat_VAX_F_Float is + pragma Pure; + + pragma Warnings (Off); + -- This unit is normally used only for VMS, but we compile it for other + -- targets for the convenience of testing vms code using -gnatdm. + + type Fat_VAX_F is digits 6; + pragma Float_Representation (VAX_Float, Fat_VAX_F); + + -- 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_VAX_F_Float is new System.Fat_Gen (Fat_VAX_F); + +end System.Fat_VAX_F_Float; diff --git a/gcc/ada/s-fvagfl.ads b/gcc/ada/s-fvagfl.ads new file mode 100644 index 000000000..18ce99684 --- /dev/null +++ b/gcc/ada/s-fvagfl.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F A T _ V A X _ G _ F L O A T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-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 contains an instantiation of the floating-point attribute +-- runtime routines for VAX F-float for use on VMS targets. + +with System.Fat_Gen; + +package System.Fat_VAX_G_Float is + pragma Pure; + + pragma Warnings (Off); + -- This unit is normally used only for VMS, but we compile it for other + -- targets for the convenience of testing vms code using -gnatdm. + + type Fat_VAX_G is digits 15; + pragma Float_Representation (VAX_Float, Fat_VAX_G); + + -- 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_VAX_G_Float is new System.Fat_Gen (Fat_VAX_G); + +end System.Fat_VAX_G_Float; diff --git a/gcc/ada/s-gearop.adb b/gcc/ada/s-gearop.adb new file mode 100644 index 000000000..7fc79b93d --- /dev/null +++ b/gcc/ada/s-gearop.adb @@ -0,0 +1,526 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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.Generic_Array_Operations is + + -- The local function Check_Unit_Last computes the index + -- of the 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. + + function Check_Unit_Last + (Index : Integer; + Order : Positive; + First : Integer) return Integer; + pragma Inline_Always (Check_Unit_Last); + + 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"; + end if; + + return A'Length (1); + 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; + + ------------------- + -- 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; + + ---------------------------------- + -- Matrix_Elementwise_Operation -- + ---------------------------------- + + function Matrix_Elementwise_Operation (X : X_Matrix) return Result_Matrix is + R : Result_Matrix (X'Range (1), X'Range (2)); + + begin + 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; + + return R; + end Matrix_Elementwise_Operation; + + ---------------------------------- + -- Vector_Elementwise_Operation -- + ---------------------------------- + + function Vector_Elementwise_Operation (X : X_Vector) return Result_Vector is + R : Result_Vector (X'Range); + + begin + for J in R'Range loop + R (J) := Operation (X (J)); + end loop; + + return R; + end Vector_Elementwise_Operation; + + ----------------------------------------- + -- Matrix_Matrix_Elementwise_Operation -- + ----------------------------------------- + + function Matrix_Matrix_Elementwise_Operation + (Left : Left_Matrix; + Right : Right_Matrix) + return Result_Matrix + is + R : Result_Matrix (Left'Range (1), Left'Range (2)); + begin + 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; + + return R; + 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 + R : Result_Matrix (X'Range (1), X'Range (2)); + + 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 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; + + return R; + 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 + R : Result_Vector (Left'Range); + + begin + 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; + + return R; + 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 + R : Result_Vector (X'Range); + + begin + 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; + + return R; + 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 + R : Result_Matrix (Left'Range (1), Left'Range (2)); + + begin + 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; + + return R; + end Matrix_Scalar_Elementwise_Operation; + + ----------------------------------------- + -- Vector_Scalar_Elementwise_Operation -- + ----------------------------------------- + + function Vector_Scalar_Elementwise_Operation + (Left : Left_Vector; + Right : Right_Scalar) return Result_Vector + is + R : Result_Vector (Left'Range); + + begin + for J in R'Range loop + R (J) := Operation (Left (J), Right); + end loop; + + return R; + end Vector_Scalar_Elementwise_Operation; + + ----------------------------------------- + -- Scalar_Matrix_Elementwise_Operation -- + ----------------------------------------- + + function Scalar_Matrix_Elementwise_Operation + (Left : Left_Scalar; + Right : Right_Matrix) return Result_Matrix + is + R : Result_Matrix (Right'Range (1), Right'Range (2)); + + begin + 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; + + return R; + end Scalar_Matrix_Elementwise_Operation; + + ----------------------------------------- + -- Scalar_Vector_Elementwise_Operation -- + ----------------------------------------- + + function Scalar_Vector_Elementwise_Operation + (Left : Left_Scalar; + Right : Right_Vector) return Result_Vector + is + R : Result_Vector (Right'Range); + + begin + for J in R'Range loop + R (J) := Operation (Left, Right (J)); + end loop; + + return R; + end Scalar_Vector_Elementwise_Operation; + + --------------------------- + -- Matrix_Matrix_Product -- + --------------------------- + + function Matrix_Matrix_Product + (Left : Left_Matrix; + Right : Right_Matrix) return Result_Matrix + is + R : Result_Matrix (Left'Range (1), Right'Range (2)); + + begin + 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; + + return R; + end Matrix_Matrix_Product; + + --------------------------- + -- Matrix_Vector_Product -- + --------------------------- + + function Matrix_Vector_Product + (Left : Matrix; + Right : Right_Vector) return Result_Vector + is + R : Result_Vector (Left'Range (1)); + + begin + 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; + + return R; + end Matrix_Vector_Product; + + ------------------- + -- Outer_Product -- + ------------------- + + function Outer_Product + (Left : Left_Vector; + Right : Right_Vector) return Matrix + is + R : Matrix (Left'Range, Right'Range); + + begin + 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; + + return R; + end Outer_Product; + + --------------- + -- 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 + R : Matrix (First_1 .. Check_Unit_Last (First_1, Order, First_1), + First_2 .. Check_Unit_Last (First_2, Order, First_2)); + + begin + R := (others => (others => Zero)); + + for J in 0 .. Order - 1 loop + R (First_1 + J, First_2 + J) := One; + end loop; + + return R; + end Unit_Matrix; + + ----------------- + -- Unit_Vector -- + ----------------- + + function Unit_Vector + (Index : Integer; + Order : Positive; + First : Integer := 1) return Vector + is + R : Vector (First .. Check_Unit_Last (Index, Order, First)); + begin + R := (others => Zero); + R (Index) := One; + return R; + end Unit_Vector; + + --------------------------- + -- Vector_Matrix_Product -- + --------------------------- + + function Vector_Matrix_Product + (Left : Left_Vector; + Right : Matrix) return Result_Vector + is + R : Result_Vector (Right'Range (2)); + + begin + 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; + + return R; + end Vector_Matrix_Product; + +end System.Generic_Array_Operations; diff --git a/gcc/ada/s-gearop.ads b/gcc/ada/s-gearop.ads new file mode 100644 index 000000000..dfbceb3d0 --- /dev/null +++ b/gcc/ada/s-gearop.ads @@ -0,0 +1,396 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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); + + -------------------------- + -- 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; + + ------------------- + -- 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; + + --------------- + -- 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-gecobl.adb b/gcc/ada/s-gecobl.adb new file mode 100644 index 000000000..d20b53f31 --- /dev/null +++ b/gcc/ada/s-gecobl.adb @@ -0,0 +1,350 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . G E N E R I C _ C O M P L E X _ B L A S -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; use Ada; +with Interfaces; use Interfaces; +with Interfaces.Fortran; use Interfaces.Fortran; +with Interfaces.Fortran.BLAS; use Interfaces.Fortran.BLAS; +with System.Generic_Array_Operations; use System.Generic_Array_Operations; + +package body System.Generic_Complex_BLAS is + + Is_Single : constant Boolean := + Real'Machine_Mantissa = Fortran.Real'Machine_Mantissa + and then Fortran.Real (Real'First) = Fortran.Real'First + and then Fortran.Real (Real'Last) = Fortran.Real'Last; + + Is_Double : constant Boolean := + Real'Machine_Mantissa = Double_Precision'Machine_Mantissa + and then + Double_Precision (Real'First) = Double_Precision'First + and then + Double_Precision (Real'Last) = Double_Precision'Last; + + subtype Complex is Complex_Types.Complex; + + -- Local subprograms + + function To_Double_Precision (X : Real) return Double_Precision; + pragma Inline (To_Double_Precision); + + function To_Double_Complex (X : Complex) return Double_Complex; + pragma Inline (To_Double_Complex); + + function To_Complex (X : Double_Complex) return Complex; + function To_Complex (X : Fortran.Complex) return Complex; + pragma Inline (To_Complex); + + function To_Fortran (X : Complex) return Fortran.Complex; + pragma Inline (To_Fortran); + + -- Instantiations + + function To_Double_Complex is new + Vector_Elementwise_Operation + (X_Scalar => Complex_Types.Complex, + Result_Scalar => Fortran.Double_Complex, + X_Vector => Complex_Vector, + Result_Vector => BLAS.Double_Complex_Vector, + Operation => To_Double_Complex); + + function To_Complex is new + Vector_Elementwise_Operation + (X_Scalar => Fortran.Double_Complex, + Result_Scalar => Complex, + X_Vector => BLAS.Double_Complex_Vector, + Result_Vector => Complex_Vector, + Operation => To_Complex); + + function To_Double_Complex is new + Matrix_Elementwise_Operation + (X_Scalar => Complex, + Result_Scalar => Double_Complex, + X_Matrix => Complex_Matrix, + Result_Matrix => BLAS.Double_Complex_Matrix, + Operation => To_Double_Complex); + + function To_Complex is new + Matrix_Elementwise_Operation + (X_Scalar => Double_Complex, + Result_Scalar => Complex, + X_Matrix => BLAS.Double_Complex_Matrix, + Result_Matrix => Complex_Matrix, + Operation => To_Complex); + + function To_Double_Precision (X : Real) return Double_Precision is + begin + return Double_Precision (X); + end To_Double_Precision; + + function To_Double_Complex (X : Complex) return Double_Complex is + begin + return (To_Double_Precision (X.Re), To_Double_Precision (X.Im)); + end To_Double_Complex; + + function To_Complex (X : Double_Complex) return Complex is + begin + return (Real (X.Re), Real (X.Im)); + end To_Complex; + + function To_Complex (X : Fortran.Complex) return Complex is + begin + return (Real (X.Re), Real (X.Im)); + end To_Complex; + + function To_Fortran (X : Complex) return Fortran.Complex is + begin + return (Fortran.Real (X.Re), Fortran.Real (X.Im)); + end To_Fortran; + + --------- + -- dot -- + --------- + + function dot + (N : Positive; + X : Complex_Vector; + Inc_X : Integer := 1; + Y : Complex_Vector; + Inc_Y : Integer := 1) return Complex + is + begin + if Is_Single then + declare + type X_Ptr is access all BLAS.Complex_Vector (X'Range); + type Y_Ptr is access all BLAS.Complex_Vector (Y'Range); + function Conv_X is new Unchecked_Conversion (Address, X_Ptr); + function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr); + begin + return To_Complex (BLAS.cdotu (N, Conv_X (X'Address).all, Inc_X, + Conv_Y (Y'Address).all, Inc_Y)); + end; + + elsif Is_Double then + declare + type X_Ptr is access all BLAS.Double_Complex_Vector (X'Range); + type Y_Ptr is access all BLAS.Double_Complex_Vector (Y'Range); + function Conv_X is new Unchecked_Conversion (Address, X_Ptr); + function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr); + begin + return To_Complex (BLAS.zdotu (N, Conv_X (X'Address).all, Inc_X, + Conv_Y (Y'Address).all, Inc_Y)); + end; + + else + return To_Complex (BLAS.zdotu (N, To_Double_Complex (X), Inc_X, + To_Double_Complex (Y), Inc_Y)); + end if; + end dot; + + ---------- + -- gemm -- + ---------- + + procedure gemm + (Trans_A : access constant Character; + Trans_B : access constant Character; + M : Positive; + N : Positive; + K : Positive; + Alpha : Complex := (1.0, 0.0); + A : Complex_Matrix; + Ld_A : Integer; + B : Complex_Matrix; + Ld_B : Integer; + Beta : Complex := (0.0, 0.0); + C : in out Complex_Matrix; + Ld_C : Integer) + is + begin + if Is_Single then + declare + subtype A_Type is BLAS.Complex_Matrix (A'Range (1), A'Range (2)); + subtype B_Type is BLAS.Complex_Matrix (B'Range (1), B'Range (2)); + type C_Ptr is + access all BLAS.Complex_Matrix (C'Range (1), C'Range (2)); + function Conv_A is + new Unchecked_Conversion (Complex_Matrix, A_Type); + function Conv_B is + new Unchecked_Conversion (Complex_Matrix, B_Type); + function Conv_C is + new Unchecked_Conversion (Address, C_Ptr); + begin + BLAS.cgemm (Trans_A, Trans_B, M, N, K, To_Fortran (Alpha), + Conv_A (A), Ld_A, Conv_B (B), Ld_B, To_Fortran (Beta), + Conv_C (C'Address).all, Ld_C); + end; + + elsif Is_Double then + declare + subtype A_Type is + BLAS.Double_Complex_Matrix (A'Range (1), A'Range (2)); + subtype B_Type is + BLAS.Double_Complex_Matrix (B'Range (1), B'Range (2)); + type C_Ptr is access all + BLAS.Double_Complex_Matrix (C'Range (1), C'Range (2)); + function Conv_A is + new Unchecked_Conversion (Complex_Matrix, A_Type); + function Conv_B is + new Unchecked_Conversion (Complex_Matrix, B_Type); + function Conv_C is new Unchecked_Conversion (Address, C_Ptr); + begin + BLAS.zgemm (Trans_A, Trans_B, M, N, K, To_Double_Complex (Alpha), + Conv_A (A), Ld_A, Conv_B (B), Ld_B, + To_Double_Complex (Beta), + Conv_C (C'Address).all, Ld_C); + end; + + else + declare + DP_C : BLAS.Double_Complex_Matrix (C'Range (1), C'Range (2)); + begin + if Beta.Re /= 0.0 or else Beta.Im /= 0.0 then + DP_C := To_Double_Complex (C); + end if; + + BLAS.zgemm (Trans_A, Trans_B, M, N, K, To_Double_Complex (Alpha), + To_Double_Complex (A), Ld_A, + To_Double_Complex (B), Ld_B, To_Double_Complex (Beta), + DP_C, Ld_C); + + C := To_Complex (DP_C); + end; + end if; + end gemm; + + ---------- + -- gemv -- + ---------- + + procedure gemv + (Trans : access constant Character; + M : Natural := 0; + N : Natural := 0; + Alpha : Complex := (1.0, 0.0); + A : Complex_Matrix; + Ld_A : Positive; + X : Complex_Vector; + Inc_X : Integer := 1; + Beta : Complex := (0.0, 0.0); + Y : in out Complex_Vector; + Inc_Y : Integer := 1) + is + begin + if Is_Single then + declare + subtype A_Type is BLAS.Complex_Matrix (A'Range (1), A'Range (2)); + subtype X_Type is BLAS.Complex_Vector (X'Range); + type Y_Ptr is access all BLAS.Complex_Vector (Y'Range); + function Conv_A is + new Unchecked_Conversion (Complex_Matrix, A_Type); + function Conv_X is + new Unchecked_Conversion (Complex_Vector, X_Type); + function Conv_Y is + new Unchecked_Conversion (Address, Y_Ptr); + begin + BLAS.cgemv (Trans, M, N, To_Fortran (Alpha), + Conv_A (A), Ld_A, Conv_X (X), Inc_X, To_Fortran (Beta), + Conv_Y (Y'Address).all, Inc_Y); + end; + + elsif Is_Double then + declare + subtype A_Type is + BLAS.Double_Complex_Matrix (A'Range (1), A'Range (2)); + subtype X_Type is + BLAS.Double_Complex_Vector (X'Range); + type Y_Ptr is access all BLAS.Double_Complex_Vector (Y'Range); + function Conv_A is + new Unchecked_Conversion (Complex_Matrix, A_Type); + function Conv_X is + new Unchecked_Conversion (Complex_Vector, X_Type); + function Conv_Y is + new Unchecked_Conversion (Address, Y_Ptr); + begin + BLAS.zgemv (Trans, M, N, To_Double_Complex (Alpha), + Conv_A (A), Ld_A, Conv_X (X), Inc_X, + To_Double_Complex (Beta), + Conv_Y (Y'Address).all, Inc_Y); + end; + + else + declare + DP_Y : BLAS.Double_Complex_Vector (Y'Range); + begin + if Beta.Re /= 0.0 or else Beta.Im /= 0.0 then + DP_Y := To_Double_Complex (Y); + end if; + + BLAS.zgemv (Trans, M, N, To_Double_Complex (Alpha), + To_Double_Complex (A), Ld_A, + To_Double_Complex (X), Inc_X, To_Double_Complex (Beta), + DP_Y, Inc_Y); + + Y := To_Complex (DP_Y); + end; + end if; + end gemv; + + ---------- + -- nrm2 -- + ---------- + + function nrm2 + (N : Natural; + X : Complex_Vector; + Inc_X : Integer := 1) return Real + is + begin + if Is_Single then + declare + subtype X_Type is BLAS.Complex_Vector (X'Range); + function Conv_X is + new Unchecked_Conversion (Complex_Vector, X_Type); + begin + return Real (BLAS.scnrm2 (N, Conv_X (X), Inc_X)); + end; + + elsif Is_Double then + declare + subtype X_Type is BLAS.Double_Complex_Vector (X'Range); + function Conv_X is + new Unchecked_Conversion (Complex_Vector, X_Type); + begin + return Real (BLAS.dznrm2 (N, Conv_X (X), Inc_X)); + end; + + else + return Real (BLAS.dznrm2 (N, To_Double_Complex (X), Inc_X)); + end if; + end nrm2; + +end System.Generic_Complex_BLAS; diff --git a/gcc/ada/s-gecobl.ads b/gcc/ada/s-gecobl.ads new file mode 100644 index 000000000..85bd3b50b --- /dev/null +++ b/gcc/ada/s-gecobl.ads @@ -0,0 +1,102 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . G E N E R I C _ C O M P L E X _ B L A S -- +-- -- +-- S p e c -- +-- -- +-- 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 comment required ??? + +with Ada.Numerics.Generic_Complex_Types; + +generic + type Real is digits <>; + with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (Real); + use Complex_Types; + + type Complex_Vector is array (Integer range <>) of Complex; + type Complex_Matrix is array (Integer range <>, Integer range <>) + of Complex; +package System.Generic_Complex_BLAS is + pragma Pure; + + -- Although BLAS support is only available for IEEE single and double + -- compatible floating-point types, this unit will accept any type + -- and apply conversions as necessary, with possible loss of + -- precision and range. + + No_Trans : aliased constant Character := 'N'; + Trans : aliased constant Character := 'T'; + Conj_Trans : aliased constant Character := 'C'; + + -- BLAS Level 1 Subprograms and Types + + function dot + (N : Positive; + X : Complex_Vector; + Inc_X : Integer := 1; + Y : Complex_Vector; + Inc_Y : Integer := 1) return Complex; + + function nrm2 + (N : Natural; + X : Complex_Vector; + Inc_X : Integer := 1) return Real; + + procedure gemv + (Trans : access constant Character; + M : Natural := 0; + N : Natural := 0; + Alpha : Complex := (1.0, 0.0); + A : Complex_Matrix; + Ld_A : Positive; + X : Complex_Vector; + Inc_X : Integer := 1; -- must be non-zero + Beta : Complex := (0.0, 0.0); + Y : in out Complex_Vector; + Inc_Y : Integer := 1); -- must be non-zero + + -- BLAS Level 3 + + -- gemm s, d, c, z Matrix-matrix product of general matrices + + procedure gemm + (Trans_A : access constant Character; + Trans_B : access constant Character; + M : Positive; + N : Positive; + K : Positive; + Alpha : Complex := (1.0, 0.0); + A : Complex_Matrix; + Ld_A : Integer; + B : Complex_Matrix; + Ld_B : Integer; + Beta : Complex := (0.0, 0.0); + C : in out Complex_Matrix; + Ld_C : Integer); + +end System.Generic_Complex_BLAS; diff --git a/gcc/ada/s-gecola.adb b/gcc/ada/s-gecola.adb new file mode 100644 index 000000000..ad69fee9b --- /dev/null +++ b/gcc/ada/s-gecola.adb @@ -0,0 +1,493 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . G E N E R I C _ C O M P L E X _ L A P A C K -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; use Ada; +with Interfaces; use Interfaces; +with Interfaces.Fortran; use Interfaces.Fortran; +with Interfaces.Fortran.BLAS; use Interfaces.Fortran.BLAS; +with Interfaces.Fortran.LAPACK; use Interfaces.Fortran.LAPACK; +with System.Generic_Array_Operations; use System.Generic_Array_Operations; + +package body System.Generic_Complex_LAPACK is + + Is_Single : constant Boolean := + Real'Machine_Mantissa = Fortran.Real'Machine_Mantissa + and then Fortran.Real (Real'First) = Fortran.Real'First + and then Fortran.Real (Real'Last) = Fortran.Real'Last; + + Is_Double : constant Boolean := + Real'Machine_Mantissa = Double_Precision'Machine_Mantissa + and then + Double_Precision (Real'First) = Double_Precision'First + and then + Double_Precision (Real'Last) = Double_Precision'Last; + + subtype Complex is Complex_Types.Complex; + + -- Local subprograms + + function To_Double_Precision (X : Real) return Double_Precision; + pragma Inline (To_Double_Precision); + + function To_Real (X : Double_Precision) return Real; + pragma Inline (To_Real); + + function To_Double_Complex (X : Complex) return Double_Complex; + pragma Inline (To_Double_Complex); + + function To_Complex (X : Double_Complex) return Complex; + pragma Inline (To_Complex); + + -- Instantiations + + function To_Double_Precision is new + Vector_Elementwise_Operation + (X_Scalar => Real, + Result_Scalar => Double_Precision, + X_Vector => Real_Vector, + Result_Vector => Double_Precision_Vector, + Operation => To_Double_Precision); + + function To_Real is new + Vector_Elementwise_Operation + (X_Scalar => Double_Precision, + Result_Scalar => Real, + X_Vector => Double_Precision_Vector, + Result_Vector => Real_Vector, + Operation => To_Real); + + function To_Double_Complex is new + Matrix_Elementwise_Operation + (X_Scalar => Complex, + Result_Scalar => Double_Complex, + X_Matrix => Complex_Matrix, + Result_Matrix => Double_Complex_Matrix, + Operation => To_Double_Complex); + + function To_Complex is new + Matrix_Elementwise_Operation + (X_Scalar => Double_Complex, + Result_Scalar => Complex, + X_Matrix => Double_Complex_Matrix, + Result_Matrix => Complex_Matrix, + Operation => To_Complex); + + function To_Double_Precision (X : Real) return Double_Precision is + begin + return Double_Precision (X); + end To_Double_Precision; + + function To_Real (X : Double_Precision) return Real is + begin + return Real (X); + end To_Real; + + function To_Double_Complex (X : Complex) return Double_Complex is + begin + return (To_Double_Precision (X.Re), To_Double_Precision (X.Im)); + end To_Double_Complex; + + function To_Complex (X : Double_Complex) return Complex is + begin + return (Real (X.Re), Real (X.Im)); + end To_Complex; + + ----------- + -- getrf -- + ----------- + + procedure getrf + (M : Natural; + N : Natural; + A : in out Complex_Matrix; + Ld_A : Positive; + I_Piv : out Integer_Vector; + Info : access Integer) + is + begin + if Is_Single then + declare + type A_Ptr is + access all BLAS.Complex_Matrix (A'Range (1), A'Range (2)); + function Conv_A is new Unchecked_Conversion (Address, A_Ptr); + begin + cgetrf (M, N, Conv_A (A'Address).all, Ld_A, + LAPACK.Integer_Vector (I_Piv), Info); + end; + + elsif Is_Double then + declare + type A_Ptr is + access all Double_Complex_Matrix (A'Range (1), A'Range (2)); + function Conv_A is new Unchecked_Conversion (Address, A_Ptr); + begin + zgetrf (M, N, Conv_A (A'Address).all, Ld_A, + LAPACK.Integer_Vector (I_Piv), Info); + end; + + else + declare + DP_A : Double_Complex_Matrix (A'Range (1), A'Range (2)); + begin + DP_A := To_Double_Complex (A); + zgetrf (M, N, DP_A, Ld_A, LAPACK.Integer_Vector (I_Piv), Info); + A := To_Complex (DP_A); + end; + end if; + end getrf; + + ----------- + -- getri -- + ----------- + + procedure getri + (N : Natural; + A : in out Complex_Matrix; + Ld_A : Positive; + I_Piv : Integer_Vector; + Work : in out Complex_Vector; + L_Work : Integer; + Info : access Integer) + is + begin + if Is_Single then + declare + type A_Ptr is + access all BLAS.Complex_Matrix (A'Range (1), A'Range (2)); + type Work_Ptr is + access all BLAS.Complex_Vector (Work'Range); + function Conv_A is new Unchecked_Conversion (Address, A_Ptr); + function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); + begin + cgetri (N, Conv_A (A'Address).all, Ld_A, + LAPACK.Integer_Vector (I_Piv), + Conv_Work (Work'Address).all, L_Work, + Info); + end; + + elsif Is_Double then + declare + type A_Ptr is + access all Double_Complex_Matrix (A'Range (1), A'Range (2)); + type Work_Ptr is + access all Double_Complex_Vector (Work'Range); + function Conv_A is new Unchecked_Conversion (Address, A_Ptr); + function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); + begin + zgetri (N, Conv_A (A'Address).all, Ld_A, + LAPACK.Integer_Vector (I_Piv), + Conv_Work (Work'Address).all, L_Work, + Info); + end; + + else + declare + DP_A : Double_Complex_Matrix (A'Range (1), A'Range (2)); + DP_Work : Double_Complex_Vector (Work'Range); + begin + DP_A := To_Double_Complex (A); + zgetri (N, DP_A, Ld_A, LAPACK.Integer_Vector (I_Piv), + DP_Work, L_Work, Info); + A := To_Complex (DP_A); + Work (1) := To_Complex (DP_Work (1)); + end; + end if; + end getri; + + ----------- + -- getrs -- + ----------- + + procedure getrs + (Trans : access constant Character; + N : Natural; + N_Rhs : Natural; + A : Complex_Matrix; + Ld_A : Positive; + I_Piv : Integer_Vector; + B : in out Complex_Matrix; + Ld_B : Positive; + Info : access Integer) + is + begin + if Is_Single then + declare + subtype A_Type is BLAS.Complex_Matrix (A'Range (1), A'Range (2)); + type B_Ptr is + access all BLAS.Complex_Matrix (B'Range (1), B'Range (2)); + function Conv_A is + new Unchecked_Conversion (Complex_Matrix, A_Type); + function Conv_B is new Unchecked_Conversion (Address, B_Ptr); + begin + cgetrs (Trans, N, N_Rhs, + Conv_A (A), Ld_A, + LAPACK.Integer_Vector (I_Piv), + Conv_B (B'Address).all, Ld_B, + Info); + end; + + elsif Is_Double then + declare + subtype A_Type is + Double_Complex_Matrix (A'Range (1), A'Range (2)); + type B_Ptr is + access all Double_Complex_Matrix (B'Range (1), B'Range (2)); + function Conv_A is + new Unchecked_Conversion (Complex_Matrix, A_Type); + function Conv_B is new Unchecked_Conversion (Address, B_Ptr); + begin + zgetrs (Trans, N, N_Rhs, + Conv_A (A), Ld_A, + LAPACK.Integer_Vector (I_Piv), + Conv_B (B'Address).all, Ld_B, + Info); + end; + + else + declare + DP_A : Double_Complex_Matrix (A'Range (1), A'Range (2)); + DP_B : Double_Complex_Matrix (B'Range (1), B'Range (2)); + begin + DP_A := To_Double_Complex (A); + DP_B := To_Double_Complex (B); + zgetrs (Trans, N, N_Rhs, + DP_A, Ld_A, + LAPACK.Integer_Vector (I_Piv), + DP_B, Ld_B, + Info); + B := To_Complex (DP_B); + end; + end if; + end getrs; + + procedure heevr + (Job_Z : access constant Character; + Rng : access constant Character; + Uplo : access constant Character; + N : Natural; + A : in out Complex_Matrix; + Ld_A : Positive; + Vl, Vu : Real := 0.0; + Il, Iu : Integer := 1; + Abs_Tol : Real := 0.0; + M : out Integer; + W : out Real_Vector; + Z : out Complex_Matrix; + Ld_Z : Positive; + I_Supp_Z : out Integer_Vector; + Work : out Complex_Vector; + L_Work : Integer; + R_Work : out Real_Vector; + LR_Work : Integer; + I_Work : out Integer_Vector; + LI_Work : Integer; + Info : access Integer) + is + begin + if Is_Single then + declare + type A_Ptr is + access all BLAS.Complex_Matrix (A'Range (1), A'Range (2)); + type W_Ptr is + access all BLAS.Real_Vector (W'Range); + type Z_Ptr is + access all BLAS.Complex_Matrix (Z'Range (1), Z'Range (2)); + type Work_Ptr is access all BLAS.Complex_Vector (Work'Range); + type R_Work_Ptr is access all BLAS.Real_Vector (R_Work'Range); + + function Conv_A is new Unchecked_Conversion (Address, A_Ptr); + function Conv_W is new Unchecked_Conversion (Address, W_Ptr); + function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr); + function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); + function Conv_R_Work is + new Unchecked_Conversion (Address, R_Work_Ptr); + begin + cheevr (Job_Z, Rng, Uplo, N, + Conv_A (A'Address).all, Ld_A, + Fortran.Real (Vl), Fortran.Real (Vu), + Il, Iu, Fortran.Real (Abs_Tol), M, + Conv_W (W'Address).all, + Conv_Z (Z'Address).all, Ld_Z, + LAPACK.Integer_Vector (I_Supp_Z), + Conv_Work (Work'Address).all, L_Work, + Conv_R_Work (R_Work'Address).all, LR_Work, + LAPACK.Integer_Vector (I_Work), LI_Work, Info); + end; + + elsif Is_Double then + declare + type A_Ptr is + access all BLAS.Double_Complex_Matrix (A'Range (1), A'Range (2)); + type W_Ptr is + access all BLAS.Double_Precision_Vector (W'Range); + type Z_Ptr is + access all BLAS.Double_Complex_Matrix (Z'Range (1), Z'Range (2)); + type Work_Ptr is + access all BLAS.Double_Complex_Vector (Work'Range); + type R_Work_Ptr is + access all BLAS.Double_Precision_Vector (R_Work'Range); + + function Conv_A is new Unchecked_Conversion (Address, A_Ptr); + function Conv_W is new Unchecked_Conversion (Address, W_Ptr); + function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr); + function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); + function Conv_R_Work is + new Unchecked_Conversion (Address, R_Work_Ptr); + begin + zheevr (Job_Z, Rng, Uplo, N, + Conv_A (A'Address).all, Ld_A, + Double_Precision (Vl), Double_Precision (Vu), + Il, Iu, Double_Precision (Abs_Tol), M, + Conv_W (W'Address).all, + Conv_Z (Z'Address).all, Ld_Z, + LAPACK.Integer_Vector (I_Supp_Z), + Conv_Work (Work'Address).all, L_Work, + Conv_R_Work (R_Work'Address).all, LR_Work, + LAPACK.Integer_Vector (I_Work), LI_Work, Info); + end; + + else + declare + DP_A : Double_Complex_Matrix (A'Range (1), A'Range (2)); + DP_W : Double_Precision_Vector (W'Range); + DP_Z : Double_Complex_Matrix (Z'Range (1), Z'Range (2)); + DP_Work : Double_Complex_Vector (Work'Range); + DP_R_Work : Double_Precision_Vector (R_Work'Range); + + begin + DP_A := To_Double_Complex (A); + + zheevr (Job_Z, Rng, Uplo, N, + DP_A, Ld_A, + Double_Precision (Vl), Double_Precision (Vu), + Il, Iu, Double_Precision (Abs_Tol), M, + DP_W, DP_Z, Ld_Z, + LAPACK.Integer_Vector (I_Supp_Z), + DP_Work, L_Work, + DP_R_Work, LR_Work, + LAPACK.Integer_Vector (I_Work), LI_Work, Info); + + A := To_Complex (DP_A); + W := To_Real (DP_W); + Z := To_Complex (DP_Z); + + Work (1) := To_Complex (DP_Work (1)); + R_Work (1) := To_Real (DP_R_Work (1)); + end; + end if; + end heevr; + + ----------- + -- steqr -- + ----------- + + procedure steqr + (Comp_Z : access constant Character; + N : Natural; + D : in out Real_Vector; + E : in out Real_Vector; + Z : in out Complex_Matrix; + Ld_Z : Positive; + Work : out Real_Vector; + Info : access Integer) + is + begin + if Is_Single then + declare + type D_Ptr is access all BLAS.Real_Vector (D'Range); + type E_Ptr is access all BLAS.Real_Vector (E'Range); + type Z_Ptr is + access all BLAS.Complex_Matrix (Z'Range (1), Z'Range (2)); + type Work_Ptr is + access all BLAS.Real_Vector (Work'Range); + function Conv_D is new Unchecked_Conversion (Address, D_Ptr); + function Conv_E is new Unchecked_Conversion (Address, E_Ptr); + function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr); + function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); + begin + csteqr (Comp_Z, N, + Conv_D (D'Address).all, + Conv_E (E'Address).all, + Conv_Z (Z'Address).all, + Ld_Z, + Conv_Work (Work'Address).all, + Info); + end; + + elsif Is_Double then + declare + type D_Ptr is access all Double_Precision_Vector (D'Range); + type E_Ptr is access all Double_Precision_Vector (E'Range); + type Z_Ptr is + access all Double_Complex_Matrix (Z'Range (1), Z'Range (2)); + type Work_Ptr is + access all Double_Precision_Vector (Work'Range); + function Conv_D is new Unchecked_Conversion (Address, D_Ptr); + function Conv_E is new Unchecked_Conversion (Address, E_Ptr); + function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr); + function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); + begin + zsteqr (Comp_Z, N, + Conv_D (D'Address).all, + Conv_E (E'Address).all, + Conv_Z (Z'Address).all, + Ld_Z, + Conv_Work (Work'Address).all, + Info); + end; + + else + declare + DP_D : Double_Precision_Vector (D'Range); + DP_E : Double_Precision_Vector (E'Range); + DP_Z : Double_Complex_Matrix (Z'Range (1), Z'Range (2)); + DP_Work : Double_Precision_Vector (Work'Range); + begin + DP_D := To_Double_Precision (D); + DP_E := To_Double_Precision (E); + + if Comp_Z.all = 'V' then + DP_Z := To_Double_Complex (Z); + end if; + + zsteqr (Comp_Z, N, DP_D, DP_E, DP_Z, Ld_Z, DP_Work, Info); + + D := To_Real (DP_D); + E := To_Real (DP_E); + + if Comp_Z.all /= 'N' then + Z := To_Complex (DP_Z); + end if; + end; + end if; + end steqr; + +end System.Generic_Complex_LAPACK; diff --git a/gcc/ada/s-gecola.ads b/gcc/ada/s-gecola.ads new file mode 100644 index 000000000..eb8741ac0 --- /dev/null +++ b/gcc/ada/s-gecola.ads @@ -0,0 +1,131 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . G E N E R I C _ C O M P L E X _ L A P A C K -- +-- -- +-- S p e c -- +-- -- +-- 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 comment required ??? + +with Ada.Numerics.Generic_Complex_Types; +generic + type Real is digits <>; + type Real_Vector is array (Integer range <>) of Real; + + with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (Real); + use Complex_Types; + + type Complex_Vector is array (Integer range <>) of Complex; + type Complex_Matrix is array (Integer range <>, Integer range <>) + of Complex; +package System.Generic_Complex_LAPACK is + pragma Pure; + + type Integer_Vector is array (Integer range <>) of Integer; + + Upper : aliased constant Character := 'U'; + Lower : aliased constant Character := 'L'; + + -- LAPACK Computational Routines + + -- getrf computes LU factorization of a general m-by-n matrix + + procedure getrf + (M : Natural; + N : Natural; + A : in out Complex_Matrix; + Ld_A : Positive; + I_Piv : out Integer_Vector; + Info : access Integer); + + -- getri computes inverse of an LU-factored square matrix, + -- with multiple right-hand sides + + procedure getri + (N : Natural; + A : in out Complex_Matrix; + Ld_A : Positive; + I_Piv : Integer_Vector; + Work : in out Complex_Vector; + L_Work : Integer; + Info : access Integer); + + -- getrs solves a system of linear equations with an LU-factored + -- square matrix, with multiple right-hand sides + + procedure getrs + (Trans : access constant Character; + N : Natural; + N_Rhs : Natural; + A : Complex_Matrix; + Ld_A : Positive; + I_Piv : Integer_Vector; + B : in out Complex_Matrix; + Ld_B : Positive; + Info : access Integer); + + -- heevr computes selected eigenvalues and, optionally, + -- eigenvectors of a Hermitian matrix using the Relatively + -- Robust Representations + + procedure heevr + (Job_Z : access constant Character; + Rng : access constant Character; + Uplo : access constant Character; + N : Natural; + A : in out Complex_Matrix; + Ld_A : Positive; + Vl, Vu : Real := 0.0; + Il, Iu : Integer := 1; + Abs_Tol : Real := 0.0; + M : out Integer; + W : out Real_Vector; + Z : out Complex_Matrix; + Ld_Z : Positive; + I_Supp_Z : out Integer_Vector; + Work : out Complex_Vector; + L_Work : Integer; + R_Work : out Real_Vector; + LR_Work : Integer; + I_Work : out Integer_Vector; + LI_Work : Integer; + Info : access Integer); + + -- steqr computes all eigenvalues and eigenvectors of a symmetric or + -- Hermitian matrix reduced to tridiagonal form (QR algorithm) + + procedure steqr + (Comp_Z : access constant Character; + N : Natural; + D : in out Real_Vector; + E : in out Real_Vector; + Z : in out Complex_Matrix; + Ld_Z : Positive; + Work : out Real_Vector; + Info : access Integer); + +end System.Generic_Complex_LAPACK; diff --git a/gcc/ada/s-gerebl.adb b/gcc/ada/s-gerebl.adb new file mode 100644 index 000000000..fc2f5d7d6 --- /dev/null +++ b/gcc/ada/s-gerebl.adb @@ -0,0 +1,311 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . G E N E R I C _ R E A L _ B L A S -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; use Ada; +with Interfaces; use Interfaces; +with Interfaces.Fortran; use Interfaces.Fortran; +with Interfaces.Fortran.BLAS; use Interfaces.Fortran.BLAS; +with System.Generic_Array_Operations; use System.Generic_Array_Operations; + +package body System.Generic_Real_BLAS is + + Is_Single : constant Boolean := + Real'Machine_Mantissa = Fortran.Real'Machine_Mantissa + and then Fortran.Real (Real'First) = Fortran.Real'First + and then Fortran.Real (Real'Last) = Fortran.Real'Last; + + Is_Double : constant Boolean := + Real'Machine_Mantissa = Double_Precision'Machine_Mantissa + and then + Double_Precision (Real'First) = Double_Precision'First + and then + Double_Precision (Real'Last) = Double_Precision'Last; + + -- Local subprograms + + function To_Double_Precision (X : Real) return Double_Precision; + pragma Inline_Always (To_Double_Precision); + + function To_Real (X : Double_Precision) return Real; + pragma Inline_Always (To_Real); + + -- Instantiations + + function To_Double_Precision is new + Vector_Elementwise_Operation + (X_Scalar => Real, + Result_Scalar => Double_Precision, + X_Vector => Real_Vector, + Result_Vector => Double_Precision_Vector, + Operation => To_Double_Precision); + + function To_Real is new + Vector_Elementwise_Operation + (X_Scalar => Double_Precision, + Result_Scalar => Real, + X_Vector => Double_Precision_Vector, + Result_Vector => Real_Vector, + Operation => To_Real); + + function To_Double_Precision is new + Matrix_Elementwise_Operation + (X_Scalar => Real, + Result_Scalar => Double_Precision, + X_Matrix => Real_Matrix, + Result_Matrix => Double_Precision_Matrix, + Operation => To_Double_Precision); + + function To_Real is new + Matrix_Elementwise_Operation + (X_Scalar => Double_Precision, + Result_Scalar => Real, + X_Matrix => Double_Precision_Matrix, + Result_Matrix => Real_Matrix, + Operation => To_Real); + + function To_Double_Precision (X : Real) return Double_Precision is + begin + return Double_Precision (X); + end To_Double_Precision; + + function To_Real (X : Double_Precision) return Real is + begin + return Real (X); + end To_Real; + + --------- + -- dot -- + --------- + + function dot + (N : Positive; + X : Real_Vector; + Inc_X : Integer := 1; + Y : Real_Vector; + Inc_Y : Integer := 1) return Real + is + begin + if Is_Single then + declare + type X_Ptr is access all BLAS.Real_Vector (X'Range); + type Y_Ptr is access all BLAS.Real_Vector (Y'Range); + function Conv_X is new Unchecked_Conversion (Address, X_Ptr); + function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr); + begin + return Real (sdot (N, Conv_X (X'Address).all, Inc_X, + Conv_Y (Y'Address).all, Inc_Y)); + end; + + elsif Is_Double then + declare + type X_Ptr is access all BLAS.Double_Precision_Vector (X'Range); + type Y_Ptr is access all BLAS.Double_Precision_Vector (Y'Range); + function Conv_X is new Unchecked_Conversion (Address, X_Ptr); + function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr); + begin + return Real (ddot (N, Conv_X (X'Address).all, Inc_X, + Conv_Y (Y'Address).all, Inc_Y)); + end; + + else + return Real (ddot (N, To_Double_Precision (X), Inc_X, + To_Double_Precision (Y), Inc_Y)); + end if; + end dot; + + ---------- + -- gemm -- + ---------- + + procedure gemm + (Trans_A : access constant Character; + Trans_B : access constant Character; + M : Positive; + N : Positive; + K : Positive; + Alpha : Real := 1.0; + A : Real_Matrix; + Ld_A : Integer; + B : Real_Matrix; + Ld_B : Integer; + Beta : Real := 0.0; + C : in out Real_Matrix; + Ld_C : Integer) + is + begin + if Is_Single then + declare + subtype A_Type is BLAS.Real_Matrix (A'Range (1), A'Range (2)); + subtype B_Type is BLAS.Real_Matrix (B'Range (1), B'Range (2)); + type C_Ptr is + access all BLAS.Real_Matrix (C'Range (1), C'Range (2)); + function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type); + function Conv_B is new Unchecked_Conversion (Real_Matrix, B_Type); + function Conv_C is new Unchecked_Conversion (Address, C_Ptr); + begin + sgemm (Trans_A, Trans_B, M, N, K, Fortran.Real (Alpha), + Conv_A (A), Ld_A, Conv_B (B), Ld_B, Fortran.Real (Beta), + Conv_C (C'Address).all, Ld_C); + end; + + elsif Is_Double then + declare + subtype A_Type is + Double_Precision_Matrix (A'Range (1), A'Range (2)); + subtype B_Type is + Double_Precision_Matrix (B'Range (1), B'Range (2)); + type C_Ptr is + access all Double_Precision_Matrix (C'Range (1), C'Range (2)); + function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type); + function Conv_B is new Unchecked_Conversion (Real_Matrix, B_Type); + function Conv_C is new Unchecked_Conversion (Address, C_Ptr); + begin + dgemm (Trans_A, Trans_B, M, N, K, Double_Precision (Alpha), + Conv_A (A), Ld_A, Conv_B (B), Ld_B, Double_Precision (Beta), + Conv_C (C'Address).all, Ld_C); + end; + + else + declare + DP_C : Double_Precision_Matrix (C'Range (1), C'Range (2)); + begin + if Beta /= 0.0 then + DP_C := To_Double_Precision (C); + end if; + + dgemm (Trans_A, Trans_B, M, N, K, Double_Precision (Alpha), + To_Double_Precision (A), Ld_A, + To_Double_Precision (B), Ld_B, Double_Precision (Beta), + DP_C, Ld_C); + + C := To_Real (DP_C); + end; + end if; + end gemm; + + ---------- + -- gemv -- + ---------- + + procedure gemv + (Trans : access constant Character; + M : Natural := 0; + N : Natural := 0; + Alpha : Real := 1.0; + A : Real_Matrix; + Ld_A : Positive; + X : Real_Vector; + Inc_X : Integer := 1; + Beta : Real := 0.0; + Y : in out Real_Vector; + Inc_Y : Integer := 1) + is + begin + if Is_Single then + declare + subtype A_Type is BLAS.Real_Matrix (A'Range (1), A'Range (2)); + subtype X_Type is BLAS.Real_Vector (X'Range); + type Y_Ptr is access all BLAS.Real_Vector (Y'Range); + function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type); + function Conv_X is new Unchecked_Conversion (Real_Vector, X_Type); + function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr); + begin + sgemv (Trans, M, N, Fortran.Real (Alpha), + Conv_A (A), Ld_A, Conv_X (X), Inc_X, Fortran.Real (Beta), + Conv_Y (Y'Address).all, Inc_Y); + end; + + elsif Is_Double then + declare + subtype A_Type is + Double_Precision_Matrix (A'Range (1), A'Range (2)); + subtype X_Type is Double_Precision_Vector (X'Range); + type Y_Ptr is access all Double_Precision_Vector (Y'Range); + function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type); + function Conv_X is new Unchecked_Conversion (Real_Vector, X_Type); + function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr); + begin + dgemv (Trans, M, N, Double_Precision (Alpha), + Conv_A (A), Ld_A, Conv_X (X), Inc_X, + Double_Precision (Beta), + Conv_Y (Y'Address).all, Inc_Y); + end; + + else + declare + DP_Y : Double_Precision_Vector (Y'Range); + begin + if Beta /= 0.0 then + DP_Y := To_Double_Precision (Y); + end if; + + dgemv (Trans, M, N, Double_Precision (Alpha), + To_Double_Precision (A), Ld_A, + To_Double_Precision (X), Inc_X, Double_Precision (Beta), + DP_Y, Inc_Y); + + Y := To_Real (DP_Y); + end; + end if; + end gemv; + + ---------- + -- nrm2 -- + ---------- + + function nrm2 + (N : Natural; + X : Real_Vector; + Inc_X : Integer := 1) return Real + is + begin + if Is_Single then + declare + subtype X_Type is BLAS.Real_Vector (X'Range); + function Conv_X is new Unchecked_Conversion (Real_Vector, X_Type); + begin + return Real (snrm2 (N, Conv_X (X), Inc_X)); + end; + + elsif Is_Double then + declare + subtype X_Type is Double_Precision_Vector (X'Range); + function Conv_X is new Unchecked_Conversion (Real_Vector, X_Type); + begin + return Real (dnrm2 (N, Conv_X (X), Inc_X)); + end; + + else + return Real (dnrm2 (N, To_Double_Precision (X), Inc_X)); + end if; + end nrm2; + +end System.Generic_Real_BLAS; diff --git a/gcc/ada/s-gerebl.ads b/gcc/ada/s-gerebl.ads new file mode 100644 index 000000000..dacbf7bdb --- /dev/null +++ b/gcc/ada/s-gerebl.ads @@ -0,0 +1,96 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- SYSTEM.GENERIC_REAL_BLAS -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Package comment required ??? + +generic + type Real is digits <>; + type Real_Vector is array (Integer range <>) of Real; + type Real_Matrix is array (Integer range <>, Integer range <>) of Real; +package System.Generic_Real_BLAS is + pragma Pure; + + -- Although BLAS support is only available for IEEE single and double + -- compatible floating-point types, this unit will accept any type + -- and apply conversions as necessary, with possible loss of + -- precision and range. + + No_Trans : aliased constant Character := 'N'; + Trans : aliased constant Character := 'T'; + Conj_Trans : aliased constant Character := 'C'; + + -- BLAS Level 1 Subprograms and Types + + function dot + (N : Positive; + X : Real_Vector; + Inc_X : Integer := 1; + Y : Real_Vector; + Inc_Y : Integer := 1) return Real; + + function nrm2 + (N : Natural; + X : Real_Vector; + Inc_X : Integer := 1) return Real; + + procedure gemv + (Trans : access constant Character; + M : Natural := 0; + N : Natural := 0; + Alpha : Real := 1.0; + A : Real_Matrix; + Ld_A : Positive; + X : Real_Vector; + Inc_X : Integer := 1; -- must be non-zero + Beta : Real := 0.0; + Y : in out Real_Vector; + Inc_Y : Integer := 1); -- must be non-zero + + -- BLAS Level 3 + + -- gemm s, d, c, z Matrix-matrix product of general matrices + + procedure gemm + (Trans_A : access constant Character; + Trans_B : access constant Character; + M : Positive; + N : Positive; + K : Positive; + Alpha : Real := 1.0; + A : Real_Matrix; + Ld_A : Integer; + B : Real_Matrix; + Ld_B : Integer; + Beta : Real := 0.0; + C : in out Real_Matrix; + Ld_C : Integer); + +end System.Generic_Real_BLAS; diff --git a/gcc/ada/s-gerela.adb b/gcc/ada/s-gerela.adb new file mode 100644 index 000000000..57d3640ad --- /dev/null +++ b/gcc/ada/s-gerela.adb @@ -0,0 +1,564 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- SYSTEM.GENERIC_REAL_LAPACK -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; use Ada; +with Interfaces; use Interfaces; +with Interfaces.Fortran; use Interfaces.Fortran; +with Interfaces.Fortran.BLAS; use Interfaces.Fortran.BLAS; +with Interfaces.Fortran.LAPACK; use Interfaces.Fortran.LAPACK; +with System.Generic_Array_Operations; use System.Generic_Array_Operations; + +package body System.Generic_Real_LAPACK is + + Is_Real : constant Boolean := + Real'Machine_Mantissa = Fortran.Real'Machine_Mantissa + and then Fortran.Real (Real'First) = Fortran.Real'First + and then Fortran.Real (Real'Last) = Fortran.Real'Last; + + Is_Double_Precision : constant Boolean := + Real'Machine_Mantissa = + Double_Precision'Machine_Mantissa + and then + Double_Precision (Real'First) = + Double_Precision'First + and then + Double_Precision (Real'Last) = + Double_Precision'Last; + + -- Local subprograms + + function To_Double_Precision (X : Real) return Double_Precision; + pragma Inline_Always (To_Double_Precision); + + function To_Real (X : Double_Precision) return Real; + pragma Inline_Always (To_Real); + + -- Instantiations + + function To_Double_Precision is new + Vector_Elementwise_Operation + (X_Scalar => Real, + Result_Scalar => Double_Precision, + X_Vector => Real_Vector, + Result_Vector => Double_Precision_Vector, + Operation => To_Double_Precision); + + function To_Real is new + Vector_Elementwise_Operation + (X_Scalar => Double_Precision, + Result_Scalar => Real, + X_Vector => Double_Precision_Vector, + Result_Vector => Real_Vector, + Operation => To_Real); + + function To_Double_Precision is new + Matrix_Elementwise_Operation + (X_Scalar => Real, + Result_Scalar => Double_Precision, + X_Matrix => Real_Matrix, + Result_Matrix => Double_Precision_Matrix, + Operation => To_Double_Precision); + + function To_Real is new + Matrix_Elementwise_Operation + (X_Scalar => Double_Precision, + Result_Scalar => Real, + X_Matrix => Double_Precision_Matrix, + Result_Matrix => Real_Matrix, + Operation => To_Real); + + function To_Double_Precision (X : Real) return Double_Precision is + begin + return Double_Precision (X); + end To_Double_Precision; + + function To_Real (X : Double_Precision) return Real is + begin + return Real (X); + end To_Real; + + ----------- + -- getrf -- + ----------- + + procedure getrf + (M : Natural; + N : Natural; + A : in out Real_Matrix; + Ld_A : Positive; + I_Piv : out Integer_Vector; + Info : access Integer) + is + begin + if Is_Real then + declare + type A_Ptr is + access all BLAS.Real_Matrix (A'Range (1), A'Range (2)); + function Conv_A is new Unchecked_Conversion (Address, A_Ptr); + begin + sgetrf (M, N, Conv_A (A'Address).all, Ld_A, + LAPACK.Integer_Vector (I_Piv), Info); + end; + + elsif Is_Double_Precision then + declare + type A_Ptr is + access all Double_Precision_Matrix (A'Range (1), A'Range (2)); + function Conv_A is new Unchecked_Conversion (Address, A_Ptr); + begin + dgetrf (M, N, Conv_A (A'Address).all, Ld_A, + LAPACK.Integer_Vector (I_Piv), Info); + end; + + else + declare + DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2)); + begin + DP_A := To_Double_Precision (A); + dgetrf (M, N, DP_A, Ld_A, LAPACK.Integer_Vector (I_Piv), Info); + A := To_Real (DP_A); + end; + end if; + end getrf; + + ----------- + -- getri -- + ----------- + + procedure getri + (N : Natural; + A : in out Real_Matrix; + Ld_A : Positive; + I_Piv : Integer_Vector; + Work : in out Real_Vector; + L_Work : Integer; + Info : access Integer) + is + begin + if Is_Real then + declare + type A_Ptr is + access all BLAS.Real_Matrix (A'Range (1), A'Range (2)); + type Work_Ptr is + access all BLAS.Real_Vector (Work'Range); + function Conv_A is new Unchecked_Conversion (Address, A_Ptr); + function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); + begin + sgetri (N, Conv_A (A'Address).all, Ld_A, + LAPACK.Integer_Vector (I_Piv), + Conv_Work (Work'Address).all, L_Work, + Info); + end; + + elsif Is_Double_Precision then + declare + type A_Ptr is + access all Double_Precision_Matrix (A'Range (1), A'Range (2)); + type Work_Ptr is + access all Double_Precision_Vector (Work'Range); + function Conv_A is new Unchecked_Conversion (Address, A_Ptr); + function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); + begin + dgetri (N, Conv_A (A'Address).all, Ld_A, + LAPACK.Integer_Vector (I_Piv), + Conv_Work (Work'Address).all, L_Work, + Info); + end; + + else + declare + DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2)); + DP_Work : Double_Precision_Vector (Work'Range); + begin + DP_A := To_Double_Precision (A); + dgetri (N, DP_A, Ld_A, LAPACK.Integer_Vector (I_Piv), + DP_Work, L_Work, Info); + A := To_Real (DP_A); + Work (1) := To_Real (DP_Work (1)); + end; + end if; + end getri; + + ----------- + -- getrs -- + ----------- + + procedure getrs + (Trans : access constant Character; + N : Natural; + N_Rhs : Natural; + A : Real_Matrix; + Ld_A : Positive; + I_Piv : Integer_Vector; + B : in out Real_Matrix; + Ld_B : Positive; + Info : access Integer) + is + begin + if Is_Real then + declare + subtype A_Type is BLAS.Real_Matrix (A'Range (1), A'Range (2)); + type B_Ptr is + access all BLAS.Real_Matrix (B'Range (1), B'Range (2)); + function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type); + function Conv_B is new Unchecked_Conversion (Address, B_Ptr); + begin + sgetrs (Trans, N, N_Rhs, + Conv_A (A), Ld_A, + LAPACK.Integer_Vector (I_Piv), + Conv_B (B'Address).all, Ld_B, + Info); + end; + + elsif Is_Double_Precision then + declare + subtype A_Type is + Double_Precision_Matrix (A'Range (1), A'Range (2)); + type B_Ptr is + access all Double_Precision_Matrix (B'Range (1), B'Range (2)); + function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type); + function Conv_B is new Unchecked_Conversion (Address, B_Ptr); + begin + dgetrs (Trans, N, N_Rhs, + Conv_A (A), Ld_A, + LAPACK.Integer_Vector (I_Piv), + Conv_B (B'Address).all, Ld_B, + Info); + end; + + else + declare + DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2)); + DP_B : Double_Precision_Matrix (B'Range (1), B'Range (2)); + begin + DP_A := To_Double_Precision (A); + DP_B := To_Double_Precision (B); + dgetrs (Trans, N, N_Rhs, + DP_A, Ld_A, + LAPACK.Integer_Vector (I_Piv), + DP_B, Ld_B, + Info); + B := To_Real (DP_B); + end; + end if; + end getrs; + + ----------- + -- orgtr -- + ----------- + + procedure orgtr + (Uplo : access constant Character; + N : Natural; + A : in out Real_Matrix; + Ld_A : Positive; + Tau : Real_Vector; + Work : out Real_Vector; + L_Work : Integer; + Info : access Integer) + is + begin + if Is_Real then + declare + type A_Ptr is + access all BLAS.Real_Matrix (A'Range (1), A'Range (2)); + subtype Tau_Type is BLAS.Real_Vector (Tau'Range); + type Work_Ptr is + access all BLAS.Real_Vector (Work'Range); + function Conv_A is new Unchecked_Conversion (Address, A_Ptr); + function Conv_Tau is + new Unchecked_Conversion (Real_Vector, Tau_Type); + function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); + begin + sorgtr (Uplo, N, + Conv_A (A'Address).all, Ld_A, + Conv_Tau (Tau), + Conv_Work (Work'Address).all, L_Work, + Info); + end; + + elsif Is_Double_Precision then + declare + type A_Ptr is + access all Double_Precision_Matrix (A'Range (1), A'Range (2)); + subtype Tau_Type is Double_Precision_Vector (Tau'Range); + type Work_Ptr is + access all Double_Precision_Vector (Work'Range); + function Conv_A is new Unchecked_Conversion (Address, A_Ptr); + function Conv_Tau is + new Unchecked_Conversion (Real_Vector, Tau_Type); + function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); + begin + dorgtr (Uplo, N, + Conv_A (A'Address).all, Ld_A, + Conv_Tau (Tau), + Conv_Work (Work'Address).all, L_Work, + Info); + end; + + else + declare + DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2)); + DP_Work : Double_Precision_Vector (Work'Range); + DP_Tau : Double_Precision_Vector (Tau'Range); + begin + DP_A := To_Double_Precision (A); + DP_Tau := To_Double_Precision (Tau); + dorgtr (Uplo, N, DP_A, Ld_A, DP_Tau, DP_Work, L_Work, Info); + A := To_Real (DP_A); + Work (1) := To_Real (DP_Work (1)); + end; + end if; + end orgtr; + + ----------- + -- steqr -- + ----------- + + procedure steqr + (Comp_Z : access constant Character; + N : Natural; + D : in out Real_Vector; + E : in out Real_Vector; + Z : in out Real_Matrix; + Ld_Z : Positive; + Work : out Real_Vector; + Info : access Integer) + is + begin + if Is_Real then + declare + type D_Ptr is access all BLAS.Real_Vector (D'Range); + type E_Ptr is access all BLAS.Real_Vector (E'Range); + type Z_Ptr is + access all BLAS.Real_Matrix (Z'Range (1), Z'Range (2)); + type Work_Ptr is + access all BLAS.Real_Vector (Work'Range); + function Conv_D is new Unchecked_Conversion (Address, D_Ptr); + function Conv_E is new Unchecked_Conversion (Address, E_Ptr); + function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr); + function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); + begin + ssteqr (Comp_Z, N, + Conv_D (D'Address).all, + Conv_E (E'Address).all, + Conv_Z (Z'Address).all, + Ld_Z, + Conv_Work (Work'Address).all, + Info); + end; + + elsif Is_Double_Precision then + declare + type D_Ptr is access all Double_Precision_Vector (D'Range); + type E_Ptr is access all Double_Precision_Vector (E'Range); + type Z_Ptr is + access all Double_Precision_Matrix (Z'Range (1), Z'Range (2)); + type Work_Ptr is + access all Double_Precision_Vector (Work'Range); + function Conv_D is new Unchecked_Conversion (Address, D_Ptr); + function Conv_E is new Unchecked_Conversion (Address, E_Ptr); + function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr); + function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); + begin + dsteqr (Comp_Z, N, + Conv_D (D'Address).all, + Conv_E (E'Address).all, + Conv_Z (Z'Address).all, + Ld_Z, + Conv_Work (Work'Address).all, + Info); + end; + + else + declare + DP_D : Double_Precision_Vector (D'Range); + DP_E : Double_Precision_Vector (E'Range); + DP_Z : Double_Precision_Matrix (Z'Range (1), Z'Range (2)); + DP_Work : Double_Precision_Vector (Work'Range); + begin + DP_D := To_Double_Precision (D); + DP_E := To_Double_Precision (E); + + if Comp_Z.all = 'V' then + DP_Z := To_Double_Precision (Z); + end if; + + dsteqr (Comp_Z, N, DP_D, DP_E, DP_Z, Ld_Z, DP_Work, Info); + + D := To_Real (DP_D); + E := To_Real (DP_E); + Z := To_Real (DP_Z); + end; + end if; + end steqr; + + ----------- + -- sterf -- + ----------- + + procedure sterf + (N : Natural; + D : in out Real_Vector; + E : in out Real_Vector; + Info : access Integer) + is + begin + if Is_Real then + declare + type D_Ptr is access all BLAS.Real_Vector (D'Range); + type E_Ptr is access all BLAS.Real_Vector (E'Range); + function Conv_D is new Unchecked_Conversion (Address, D_Ptr); + function Conv_E is new Unchecked_Conversion (Address, E_Ptr); + begin + ssterf (N, Conv_D (D'Address).all, Conv_E (E'Address).all, Info); + end; + + elsif Is_Double_Precision then + declare + type D_Ptr is access all Double_Precision_Vector (D'Range); + type E_Ptr is access all Double_Precision_Vector (E'Range); + function Conv_D is new Unchecked_Conversion (Address, D_Ptr); + function Conv_E is new Unchecked_Conversion (Address, E_Ptr); + begin + dsterf (N, Conv_D (D'Address).all, Conv_E (E'Address).all, Info); + end; + + else + declare + DP_D : Double_Precision_Vector (D'Range); + DP_E : Double_Precision_Vector (E'Range); + + begin + DP_D := To_Double_Precision (D); + DP_E := To_Double_Precision (E); + + dsterf (N, DP_D, DP_E, Info); + + D := To_Real (DP_D); + E := To_Real (DP_E); + end; + end if; + end sterf; + + ----------- + -- sytrd -- + ----------- + + procedure sytrd + (Uplo : access constant Character; + N : Natural; + A : in out Real_Matrix; + Ld_A : Positive; + D : out Real_Vector; + E : out Real_Vector; + Tau : out Real_Vector; + Work : out Real_Vector; + L_Work : Integer; + Info : access Integer) + is + begin + if Is_Real then + declare + type A_Ptr is + access all BLAS.Real_Matrix (A'Range (1), A'Range (2)); + type D_Ptr is access all BLAS.Real_Vector (D'Range); + type E_Ptr is access all BLAS.Real_Vector (E'Range); + type Tau_Ptr is access all BLAS.Real_Vector (Tau'Range); + type Work_Ptr is + access all BLAS.Real_Vector (Work'Range); + function Conv_A is new Unchecked_Conversion (Address, A_Ptr); + function Conv_D is new Unchecked_Conversion (Address, D_Ptr); + function Conv_E is new Unchecked_Conversion (Address, E_Ptr); + function Conv_Tau is new Unchecked_Conversion (Address, Tau_Ptr); + function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); + begin + ssytrd (Uplo, N, + Conv_A (A'Address).all, Ld_A, + Conv_D (D'Address).all, + Conv_E (E'Address).all, + Conv_Tau (Tau'Address).all, + Conv_Work (Work'Address).all, + L_Work, + Info); + end; + + elsif Is_Double_Precision then + declare + type A_Ptr is + access all Double_Precision_Matrix (A'Range (1), A'Range (2)); + type D_Ptr is access all Double_Precision_Vector (D'Range); + type E_Ptr is access all Double_Precision_Vector (E'Range); + type Tau_Ptr is access all Double_Precision_Vector (Tau'Range); + type Work_Ptr is + access all Double_Precision_Vector (Work'Range); + function Conv_A is new Unchecked_Conversion (Address, A_Ptr); + function Conv_D is new Unchecked_Conversion (Address, D_Ptr); + function Conv_E is new Unchecked_Conversion (Address, E_Ptr); + function Conv_Tau is new Unchecked_Conversion (Address, Tau_Ptr); + function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); + begin + dsytrd (Uplo, N, + Conv_A (A'Address).all, Ld_A, + Conv_D (D'Address).all, + Conv_E (E'Address).all, + Conv_Tau (Tau'Address).all, + Conv_Work (Work'Address).all, + L_Work, + Info); + end; + + else + declare + DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2)); + DP_D : Double_Precision_Vector (D'Range); + DP_E : Double_Precision_Vector (E'Range); + DP_Tau : Double_Precision_Vector (Tau'Range); + DP_Work : Double_Precision_Vector (Work'Range); + begin + DP_A := To_Double_Precision (A); + + dsytrd (Uplo, N, DP_A, Ld_A, DP_D, DP_E, DP_Tau, + DP_Work, L_Work, Info); + + if L_Work /= -1 then + A := To_Real (DP_A); + D := To_Real (DP_D); + E := To_Real (DP_E); + Tau := To_Real (DP_Tau); + end if; + + Work (1) := To_Real (DP_Work (1)); + end; + end if; + end sytrd; + +end System.Generic_Real_LAPACK; diff --git a/gcc/ada/s-gerela.ads b/gcc/ada/s-gerela.ads new file mode 100644 index 000000000..c09ce81d0 --- /dev/null +++ b/gcc/ada/s-gerela.ads @@ -0,0 +1,128 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . G E N E R I C _ R E A L _ L A P A C K -- +-- -- +-- S p e c -- +-- -- +-- 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 comment required ??? + +generic + type Real is digits <>; + type Real_Vector is array (Integer range <>) of Real; + type Real_Matrix is array (Integer range <>, Integer range <>) of Real; +package System.Generic_Real_LAPACK is + pragma Pure; + + type Integer_Vector is array (Integer range <>) of Integer; + + Upper : aliased constant Character := 'U'; + Lower : aliased constant Character := 'L'; + + -- LAPACK Computational Routines + + -- gerfs Refines the solution of a system of linear equations with + -- a general matrix and estimates its error + -- getrf Computes LU factorization of a general m-by-n matrix + -- getri Computes inverse of an LU-factored general matrix + -- square matrix, with multiple right-hand sides + -- getrs Solves a system of linear equations with an LU-factored + -- square matrix, with multiple right-hand sides + -- orgtr Generates the Float orthogonal matrix Q determined by sytrd + -- steqr Computes all eigenvalues and eigenvectors of a symmetric or + -- Hermitian matrix reduced to tridiagonal form (QR algorithm) + -- sterf Computes all eigenvalues of a Float symmetric + -- tridiagonal matrix using QR algorithm + -- sytrd Reduces a Float symmetric matrix to tridiagonal form + + procedure getrf + (M : Natural; + N : Natural; + A : in out Real_Matrix; + Ld_A : Positive; + I_Piv : out Integer_Vector; + Info : access Integer); + + procedure getri + (N : Natural; + A : in out Real_Matrix; + Ld_A : Positive; + I_Piv : Integer_Vector; + Work : in out Real_Vector; + L_Work : Integer; + Info : access Integer); + + procedure getrs + (Trans : access constant Character; + N : Natural; + N_Rhs : Natural; + A : Real_Matrix; + Ld_A : Positive; + I_Piv : Integer_Vector; + B : in out Real_Matrix; + Ld_B : Positive; + Info : access Integer); + + procedure orgtr + (Uplo : access constant Character; + N : Natural; + A : in out Real_Matrix; + Ld_A : Positive; + Tau : Real_Vector; + Work : out Real_Vector; + L_Work : Integer; + Info : access Integer); + + procedure sterf + (N : Natural; + D : in out Real_Vector; + E : in out Real_Vector; + Info : access Integer); + + procedure steqr + (Comp_Z : access constant Character; + N : Natural; + D : in out Real_Vector; + E : in out Real_Vector; + Z : in out Real_Matrix; + Ld_Z : Positive; + Work : out Real_Vector; + Info : access Integer); + + procedure sytrd + (Uplo : access constant Character; + N : Natural; + A : in out Real_Matrix; + Ld_A : Positive; + D : out Real_Vector; + E : out Real_Vector; + Tau : out Real_Vector; + Work : out Real_Vector; + L_Work : Integer; + Info : access Integer); + +end System.Generic_Real_LAPACK; diff --git a/gcc/ada/s-geveop.adb b/gcc/ada/s-geveop.adb new file mode 100644 index 000000000..e04032485 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..3fa7204b1 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..39c8abf09 --- /dev/null +++ b/gcc/ada/s-gloloc-mingw.adb @@ -0,0 +1,109 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This 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 new file mode 100644 index 000000000..331e67ffb --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..4a0aa22fa --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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-hibaen.ads b/gcc/ada/s-hibaen.ads new file mode 100644 index 000000000..fb8c2c8aa --- /dev/null +++ b/gcc/ada/s-hibaen.ads @@ -0,0 +1,99 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . H I E _ B A C K _ E N D -- +-- -- +-- 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 provides an interface used in HI-E mode to determine +-- whether or not the back end can handle certain constructs in a manner +-- that is consistent with certification requirements. + +-- The approach is to define entities which may or may not be present in +-- a HI-E configured library. If the entity is present then the compiler +-- operating in HI-E mode will allow the corresponding operation. If the +-- entity is not present, the corresponding construct will be flagged as +-- not permitted in High Integrity mode. + +-- The default version of this unit delivered with the HI-E compiler is +-- configured in a manner appropriate for the target, but it is possible +-- to reconfigure the run-time to change the settings as required. + +-- This unit is not used and never accessed by the compiler unless it is +-- operating in HI-E mode, so the settings are irrelevant. However, we +-- do include a standard version with all entities present in the standard +-- run-time for use when pragma No_Run_Time is specified. + +package System.HIE_Back_End is + + type Dummy is null record; + pragma Suppress_Initialization (Dummy); + -- This is the type used for the entities below. No properties of this + -- type are ever referenced, and in particular, the entities are defined + -- as variables, but their values are never referenced + + HIE_64_Bit_Divides : Dummy; + -- This entity controls whether the front end allows 64-bit integer + -- divide operations, including the case where division of 32-bit + -- fixed-point operands requires 64-bit arithmetic. This can safely + -- be set as High_Integrity on 64-bit machines which provide this + -- operation as a native instruction, but on most 32-bit machines + -- a run time call (e.g. to __divdi3 in gcclib) is required. If a + -- certifiable version of this routine is available, then setting + -- this entity to High_Integrity with a pragma will cause appropriate + -- calls to be generated, allowing 64-bit integer division operations. + + HIE_Long_Shifts : Dummy; + -- This entity controls whether the front end allows generation of + -- long shift instructions, i.e. shifts that operate on 64-bit values. + -- Such shifts are required for the implementation of fixed-point + -- types longer than 32 bits. This can safely be set as High_Integrity + -- on 64-bit machines that provide this operation at the hardware level, + -- but on some 32-bit machines a run time call is required. If there + -- is a certifiable version available of the relevant run-time routines, + -- then setting this entity to High_Integrity with a pragma will cause + -- appropriate calls to be generated, allowing the declaration and use + -- of fixed-point types longer than 32 bits. + + HIE_Aggregates : Dummy; + -- In the general case, the use of aggregates may generate calls + -- to run-time routines in the C library, including memset, memcpy, + -- memmove, and bcopy. This entity can be set to High_Integrity with + -- a pragma if certifiable versions of all these routines are available, + -- in which case aggregates are permitted in HI-E mode. Otherwise the + -- HI-E compiler will reject any use of aggregates. + + HIE_Composite_Assignments : Dummy; + -- The assignment of composite objects other than small records and + -- arrays whose size is 64-bits or less and is set by an explicit + -- size clause may generate calls to memcpy, memmove, and bcopy. + -- If certifiable versions of all these routines are available, then + -- this entity may be set to High_Integrity using a pragma, in which + -- case such assignments are permitted. Otherwise the HI-E compiler + -- will reject any such composite assignments. + +end System.HIE_Back_End; diff --git a/gcc/ada/s-htable.adb b/gcc/ada/s-htable.adb new file mode 100644 index 000000000..2a54ed162 --- /dev/null +++ b/gcc/ada/s-htable.adb @@ -0,0 +1,376 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . H T A B L E -- +-- -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit; + +with Ada.Unchecked_Deallocation; +with System.String_Hash; + +package body System.HTable is + + ------------------- + -- Static_HTable -- + ------------------- + + package body Static_HTable is + + Table : array (Header_Num) of Elmt_Ptr; + + Iterator_Index : Header_Num; + Iterator_Ptr : Elmt_Ptr; + Iterator_Started : Boolean := False; + + function Get_Non_Null return Elmt_Ptr; + -- Returns Null_Ptr if Iterator_Started is false or the Table is empty. + -- Returns Iterator_Ptr if non null, or the next non null element in + -- table if any. + + --------- + -- Get -- + --------- + + function Get (K : Key) return Elmt_Ptr is + Elmt : Elmt_Ptr; + + begin + Elmt := Table (Hash (K)); + + loop + if Elmt = Null_Ptr then + return Null_Ptr; + + elsif Equal (Get_Key (Elmt), K) then + return Elmt; + + else + Elmt := Next (Elmt); + end if; + end loop; + end Get; + + --------------- + -- Get_First -- + --------------- + + function Get_First return Elmt_Ptr is + begin + Iterator_Started := True; + Iterator_Index := Table'First; + Iterator_Ptr := Table (Iterator_Index); + return Get_Non_Null; + end Get_First; + + -------------- + -- Get_Next -- + -------------- + + function Get_Next return Elmt_Ptr is + begin + if not Iterator_Started then + return Null_Ptr; + end if; + + Iterator_Ptr := Next (Iterator_Ptr); + return Get_Non_Null; + end Get_Next; + + ------------------ + -- Get_Non_Null -- + ------------------ + + function Get_Non_Null return Elmt_Ptr is + begin + while Iterator_Ptr = Null_Ptr loop + if Iterator_Index = Table'Last then + Iterator_Started := False; + return Null_Ptr; + end if; + + Iterator_Index := Iterator_Index + 1; + Iterator_Ptr := Table (Iterator_Index); + end loop; + + return Iterator_Ptr; + end Get_Non_Null; + + ------------ + -- Remove -- + ------------ + + procedure Remove (K : Key) is + Index : constant Header_Num := Hash (K); + Elmt : Elmt_Ptr; + Next_Elmt : Elmt_Ptr; + + begin + Elmt := Table (Index); + + if Elmt = Null_Ptr then + return; + + elsif Equal (Get_Key (Elmt), K) then + Table (Index) := Next (Elmt); + + else + loop + Next_Elmt := Next (Elmt); + + if Next_Elmt = Null_Ptr then + return; + + elsif Equal (Get_Key (Next_Elmt), K) then + Set_Next (Elmt, Next (Next_Elmt)); + return; + + else + Elmt := Next_Elmt; + end if; + end loop; + end if; + end Remove; + + ----------- + -- Reset -- + ----------- + + procedure Reset is + begin + for J in Table'Range loop + Table (J) := Null_Ptr; + end loop; + end Reset; + + --------- + -- Set -- + --------- + + procedure Set (E : Elmt_Ptr) is + Index : Header_Num; + + begin + Index := Hash (Get_Key (E)); + Set_Next (E, Table (Index)); + Table (Index) := E; + end Set; + + end Static_HTable; + + ------------------- + -- Simple_HTable -- + ------------------- + + package body Simple_HTable is + + type Element_Wrapper; + type Elmt_Ptr is access all Element_Wrapper; + type Element_Wrapper is record + K : Key; + E : Element; + Next : Elmt_Ptr; + end record; + + procedure Free is new + Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr); + + procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); + function Next (E : Elmt_Ptr) return Elmt_Ptr; + function Get_Key (E : Elmt_Ptr) return Key; + + package Tab is new Static_HTable ( + Header_Num => Header_Num, + Element => Element_Wrapper, + Elmt_Ptr => Elmt_Ptr, + Null_Ptr => null, + Set_Next => Set_Next, + Next => Next, + Key => Key, + Get_Key => Get_Key, + Hash => Hash, + Equal => Equal); + + --------- + -- Get -- + --------- + + function Get (K : Key) return Element is + Tmp : constant Elmt_Ptr := Tab.Get (K); + begin + if Tmp = null then + return No_Element; + else + return Tmp.E; + end if; + end Get; + + --------------- + -- Get_First -- + --------------- + + function Get_First return Element is + Tmp : constant Elmt_Ptr := Tab.Get_First; + begin + if Tmp = null then + return No_Element; + else + return Tmp.E; + end if; + end Get_First; + + procedure Get_First (K : in out Key; E : out Element) is + Tmp : constant Elmt_Ptr := Tab.Get_First; + begin + if Tmp = null then + E := No_Element; + else + K := Tmp.K; + E := Tmp.E; + end if; + end Get_First; + + ------------- + -- Get_Key -- + ------------- + + function Get_Key (E : Elmt_Ptr) return Key is + begin + return E.K; + end Get_Key; + + -------------- + -- Get_Next -- + -------------- + + function Get_Next return Element is + Tmp : constant Elmt_Ptr := Tab.Get_Next; + begin + if Tmp = null then + return No_Element; + else + return Tmp.E; + end if; + end Get_Next; + + procedure Get_Next (K : in out Key; E : out Element) is + Tmp : constant Elmt_Ptr := Tab.Get_Next; + begin + if Tmp = null then + E := No_Element; + else + K := Tmp.K; + E := Tmp.E; + end if; + end Get_Next; + + ---------- + -- Next -- + ---------- + + function Next (E : Elmt_Ptr) return Elmt_Ptr is + begin + return E.Next; + end Next; + + ------------ + -- Remove -- + ------------ + + procedure Remove (K : Key) is + Tmp : Elmt_Ptr; + + begin + Tmp := Tab.Get (K); + + if Tmp /= null then + Tab.Remove (K); + Free (Tmp); + end if; + end Remove; + + ----------- + -- Reset -- + ----------- + + procedure Reset is + E1, E2 : Elmt_Ptr; + + begin + E1 := Tab.Get_First; + while E1 /= null loop + E2 := Tab.Get_Next; + Free (E1); + E1 := E2; + end loop; + + Tab.Reset; + end Reset; + + --------- + -- Set -- + --------- + + procedure Set (K : Key; E : Element) is + Tmp : constant Elmt_Ptr := Tab.Get (K); + begin + if Tmp = null then + Tab.Set (new Element_Wrapper'(K, E, null)); + else + Tmp.E := E; + end if; + end Set; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is + begin + E.Next := Next; + end Set_Next; + end Simple_HTable; + + ---------- + -- Hash -- + ---------- + + function Hash (Key : String) return Header_Num is + type Uns is mod 2 ** 32; + + function Hash_Fun is + new System.String_Hash.Hash (Character, String, Uns); + + begin + return Header_Num'First + + Header_Num'Base (Hash_Fun (Key) mod Header_Num'Range_Length); + end Hash; + +end System.HTable; diff --git a/gcc/ada/s-htable.ads b/gcc/ada/s-htable.ads new file mode 100644 index 000000000..8f02b95f4 --- /dev/null +++ b/gcc/ada/s-htable.ads @@ -0,0 +1,216 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . H T A B L E -- +-- -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + +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. + + 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 new file mode 100644 index 000000000..37ef4a7e6 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..a76883d6f --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..f7b0f4521 --- /dev/null +++ b/gcc/ada/s-imgbiu.adb @@ -0,0 +1,154 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ B I 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.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 + + 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 new file mode 100644 index 000000000..2ddce2886 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..1fc21e765 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..e97e87dd6 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..67613ddbd --- /dev/null +++ b/gcc/ada/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-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 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 new file mode 100644 index 000000000..6faf2f309 --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..6ddf5e0f9 --- /dev/null +++ b/gcc/ada/s-imgdec.adb @@ -0,0 +1,400 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ 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. -- +-- -- +------------------------------------------------------------------------------ + +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'Max (0, Integer'Min (DA, -Digits_Before_Point)); + -- Number of leading zeroes after point + + begin + Set_Zeroes (LZ); + DA := DA - LZ; + + if DA < ND then + 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 new file mode 100644 index 000000000..1bc2135d2 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..99c6acfa9 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..24afb3a3a --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..12bc0f26f --- /dev/null +++ b/gcc/ada/s-imgint.adb @@ -0,0 +1,122 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ I N 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.Img_Int is + + ------------------- + -- Image_Integer -- + ------------------- + + procedure Image_Integer + (V : Integer; + S : in out String; + P : out Natural) + is + pragma Assert (S'First = 1); + + procedure Set_Digits (T : Integer); + -- 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. + + ---------------- + -- Set_Digits -- + ---------------- + + procedure Set_Digits (T : Integer) is + begin + if T <= -10 then + Set_Digits (T / 10); + 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; + + -- Start of processing for Image_Integer + + begin + P := 1; + + if V >= 0 then + S (P) := ' '; + Set_Digits (-V); + else + S (P) := '-'; + Set_Digits (V); + end if; + end Image_Integer; + + ----------------------- + -- Set_Image_Integer -- + ----------------------- + + procedure Set_Image_Integer + (V : Integer; + S : in out String; + P : in out Natural) + is + procedure Set_Digits (T : Integer); + -- 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. + + ---------------- + -- Set_Digits -- + ---------------- + + procedure Set_Digits (T : Integer) is + begin + if T <= -10 then + Set_Digits (T / 10); + 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; + + -- Start of processing for Set_Image_Integer + + begin + if V >= 0 then + Set_Digits (-V); + else + P := P + 1; + S (P) := '-'; + Set_Digits (V); + end if; + end Set_Image_Integer; + +end System.Img_Int; diff --git a/gcc/ada/s-imgint.ads b/gcc/ada/s-imgint.ads new file mode 100644 index 000000000..3d141f9f3 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..2ab1e4d76 --- /dev/null +++ b/gcc/ada/s-imgllb.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L B -- +-- -- +-- 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.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 + + 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 new file mode 100644 index 000000000..1a5636bd0 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..bc938c829 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..86b146b12 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..05154fadc --- /dev/null +++ b/gcc/ada/s-imglli.adb @@ -0,0 +1,98 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ 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.Img_LLI is + + ----------------------------- + -- 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_Image_Long_Long_Integer -- + ----------------------------- + + procedure Set_Image_Long_Long_Integer + (V : Long_Long_Integer; + S : in out String; + P : in out Natural) + is + procedure Set_Digits (T : Long_Long_Integer); + -- 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. + + ---------------- + -- Set_Digits -- + ---------------- + + procedure Set_Digits (T : Long_Long_Integer) is + begin + if T <= -10 then + Set_Digits (T / 10); + 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; + + -- Start of processing for Set_Image_Long_Long_Integer + + begin + if V >= 0 then + Set_Digits (-V); + else + P := P + 1; + S (P) := '-'; + Set_Digits (V); + 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 new file mode 100644 index 000000000..8695d9580 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..d1e9dd414 --- /dev/null +++ b/gcc/ada/s-imgllu.adb @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ 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.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 + 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 (48 + (T rem 10)); + + else + P := P + 1; + S (P) := Character'Val (48 + T); + end if; + end Set_Digits; + + -- Start of processing for Set_Image_Long_Long_Unsigned + + begin + Set_Digits (V); + end Set_Image_Long_Long_Unsigned; + +end System.Img_LLU; diff --git a/gcc/ada/s-imgllu.ads b/gcc/ada/s-imgllu.ads new file mode 100644 index 000000000..f9220c758 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..c4670d288 --- /dev/null +++ b/gcc/ada/s-imgllw.adb @@ -0,0 +1,136 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L 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.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 + + 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 new file mode 100644 index 000000000..e84a8f098 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..1415a8b80 --- /dev/null +++ b/gcc/ada/s-imgrea.adb @@ -0,0 +1,704 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ R E 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. -- +-- -- +------------------------------------------------------------------------------ + +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; + +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). + + if not Is_Negative (V) + 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 + procedure Reset; + pragma Import (C, Reset, "__gnat_init_float"); + -- We import the floating-point processor reset routine so that we can + -- be sure the floating-point processor is properly set for conversion + -- calls (see description of Reset in GNAT.Float_Control (g-flocon.ads). + -- This is notably need on Windows, where calls to the operating system + -- randomly reset the processor into 64-bit mode. + + NFrac : constant Natural := Natural'Max (Aft, 1); + Sign : Character; + X : aliased Long_Long_Float; + -- This is declared aliased because the expansion of X'Valid passes + -- X by access and JGNAT requires all access parameters to be aliased. + -- The Valid attribute probably needs to be handled via a different + -- expansion for JGNAT, and this use of aliased should be removed + -- once Valid is handled properly. ??? + 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 + 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 behaviour, + -- 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 new file mode 100644 index 000000000..3c4f64f25 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..a2cce144c --- /dev/null +++ b/gcc/ada/s-imguns.adb @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ U N 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.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 + procedure Set_Digits (T : Unsigned); + -- Set decimal digits of 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 (48 + (T rem 10)); + + else + P := P + 1; + S (P) := Character'Val (48 + T); + end if; + end Set_Digits; + + -- Start of processing for Set_Image_Unsigned + + begin + Set_Digits (V); + end Set_Image_Unsigned; + +end System.Img_Uns; diff --git a/gcc/ada/s-imguns.ads b/gcc/ada/s-imguns.ads new file mode 100644 index 000000000..2686a3450 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 Modular'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 new file mode 100644 index 000000000..44cca3996 --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..6fbe67aac --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..62dd9c135 --- /dev/null +++ b/gcc/ada/s-imgwiu.adb @@ -0,0 +1,134 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ W I 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.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 + + 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 new file mode 100644 index 000000000..9eb006f13 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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-inmaop-dummy.adb b/gcc/ada/s-inmaop-dummy.adb new file mode 100644 index 000000000..080550abe --- /dev/null +++ b/gcc/ada/s-inmaop-dummy.adb @@ -0,0 +1,201 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a NO tasking version of this package + +package body System.Interrupt_Management.Operations is + + -- Turn off warnings since many unused formals + + pragma Warnings (Off); + + ---------------------------- + -- Thread_Block_Interrupt -- + ---------------------------- + + procedure Thread_Block_Interrupt + (Interrupt : Interrupt_ID) + is + begin + null; + end Thread_Block_Interrupt; + + ------------------------------ + -- Thread_Unblock_Interrupt -- + ------------------------------ + + procedure Thread_Unblock_Interrupt + (Interrupt : Interrupt_ID) + is + begin + null; + end Thread_Unblock_Interrupt; + + ------------------------ + -- Set_Interrupt_Mask -- + ------------------------ + + procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is + begin + null; + end Set_Interrupt_Mask; + + procedure Set_Interrupt_Mask + (Mask : access Interrupt_Mask; + OMask : access Interrupt_Mask) is + begin + null; + end Set_Interrupt_Mask; + + ------------------------ + -- Get_Interrupt_Mask -- + ------------------------ + + procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is + begin + null; + end Get_Interrupt_Mask; + + -------------------- + -- Interrupt_Wait -- + -------------------- + + function Interrupt_Wait + (Mask : access Interrupt_Mask) + return Interrupt_ID + is + begin + return 0; + end Interrupt_Wait; + + ---------------------------- + -- Install_Default_Action -- + ---------------------------- + + procedure Install_Default_Action (Interrupt : Interrupt_ID) is + begin + null; + end Install_Default_Action; + + --------------------------- + -- Install_Ignore_Action -- + --------------------------- + + procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is + begin + null; + end Install_Ignore_Action; + + ------------------------- + -- Fill_Interrupt_Mask -- + ------------------------- + + procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is + begin + null; + end Fill_Interrupt_Mask; + + -------------------------- + -- Empty_Interrupt_Mask -- + -------------------------- + + procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is + begin + null; + end Empty_Interrupt_Mask; + + --------------------------- + -- Add_To_Interrupt_Mask -- + --------------------------- + + procedure Add_To_Interrupt_Mask + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID) + is + begin + null; + end Add_To_Interrupt_Mask; + + -------------------------------- + -- Delete_From_Interrupt_Mask -- + -------------------------------- + + procedure Delete_From_Interrupt_Mask + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID) + is + begin + null; + end Delete_From_Interrupt_Mask; + + --------------- + -- Is_Member -- + --------------- + + function Is_Member + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID) return Boolean + is + begin + return False; + end Is_Member; + + ------------------------- + -- Copy_Interrupt_Mask -- + ------------------------- + + procedure Copy_Interrupt_Mask + (X : out Interrupt_Mask; + Y : Interrupt_Mask) + is + begin + X := Y; + end Copy_Interrupt_Mask; + + ------------------------- + -- Interrupt_Self_Process -- + ------------------------- + + procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is + begin + null; + end Interrupt_Self_Process; + + -------------------------- + -- Setup_Interrupt_Mask -- + -------------------------- + + procedure Setup_Interrupt_Mask is + begin + null; + end Setup_Interrupt_Mask; + +end System.Interrupt_Management.Operations; diff --git a/gcc/ada/s-inmaop-posix.adb b/gcc/ada/s-inmaop-posix.adb new file mode 100644 index 000000000..3a10e73bc --- /dev/null +++ b/gcc/ada/s-inmaop-posix.adb @@ -0,0 +1,338 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2008, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a POSIX-like version of this package + +-- Note: this file can only be used for POSIX compliant systems + +with Interfaces.C; + +with System.OS_Interface; +with System.Storage_Elements; + +package body System.Interrupt_Management.Operations is + + use Interfaces.C; + use System.OS_Interface; + + --------------------- + -- Local Variables -- + --------------------- + + Initial_Action : array (Signal) of aliased struct_sigaction; + + Default_Action : aliased struct_sigaction; + pragma Warnings (Off, Default_Action); + + Ignore_Action : aliased struct_sigaction; + + ---------------------------- + -- Thread_Block_Interrupt -- + ---------------------------- + + procedure Thread_Block_Interrupt + (Interrupt : Interrupt_ID) + is + Result : Interfaces.C.int; + Mask : aliased sigset_t; + begin + Result := sigemptyset (Mask'Access); + pragma Assert (Result = 0); + Result := sigaddset (Mask'Access, Signal (Interrupt)); + pragma Assert (Result = 0); + Result := pthread_sigmask (SIG_BLOCK, Mask'Access, null); + pragma Assert (Result = 0); + end Thread_Block_Interrupt; + + ------------------------------ + -- Thread_Unblock_Interrupt -- + ------------------------------ + + procedure Thread_Unblock_Interrupt + (Interrupt : Interrupt_ID) + is + Mask : aliased sigset_t; + Result : Interfaces.C.int; + begin + Result := sigemptyset (Mask'Access); + pragma Assert (Result = 0); + Result := sigaddset (Mask'Access, Signal (Interrupt)); + pragma Assert (Result = 0); + Result := pthread_sigmask (SIG_UNBLOCK, Mask'Access, null); + pragma Assert (Result = 0); + end Thread_Unblock_Interrupt; + + ------------------------ + -- Set_Interrupt_Mask -- + ------------------------ + + procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is + Result : Interfaces.C.int; + begin + Result := pthread_sigmask (SIG_SETMASK, Mask, null); + pragma Assert (Result = 0); + end Set_Interrupt_Mask; + + procedure Set_Interrupt_Mask + (Mask : access Interrupt_Mask; + OMask : access Interrupt_Mask) + is + Result : Interfaces.C.int; + begin + Result := pthread_sigmask (SIG_SETMASK, Mask, OMask); + pragma Assert (Result = 0); + end Set_Interrupt_Mask; + + ------------------------ + -- Get_Interrupt_Mask -- + ------------------------ + + procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is + Result : Interfaces.C.int; + begin + Result := pthread_sigmask (SIG_SETMASK, null, Mask); + pragma Assert (Result = 0); + end Get_Interrupt_Mask; + + -------------------- + -- Interrupt_Wait -- + -------------------- + + function Interrupt_Wait + (Mask : access Interrupt_Mask) return Interrupt_ID + is + Result : Interfaces.C.int; + Sig : aliased Signal; + + begin + Result := sigwait (Mask, Sig'Access); + + if Result /= 0 then + return 0; + end if; + + return Interrupt_ID (Sig); + end Interrupt_Wait; + + ---------------------------- + -- Install_Default_Action -- + ---------------------------- + + procedure Install_Default_Action (Interrupt : Interrupt_ID) is + Result : Interfaces.C.int; + begin + Result := sigaction + (Signal (Interrupt), + Initial_Action (Signal (Interrupt))'Access, null); + pragma Assert (Result = 0); + end Install_Default_Action; + + --------------------------- + -- Install_Ignore_Action -- + --------------------------- + + procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is + Result : Interfaces.C.int; + begin + Result := sigaction (Signal (Interrupt), Ignore_Action'Access, null); + pragma Assert (Result = 0); + end Install_Ignore_Action; + + ------------------------- + -- Fill_Interrupt_Mask -- + ------------------------- + + procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is + Result : Interfaces.C.int; + begin + Result := sigfillset (Mask); + pragma Assert (Result = 0); + end Fill_Interrupt_Mask; + + -------------------------- + -- Empty_Interrupt_Mask -- + -------------------------- + + procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is + Result : Interfaces.C.int; + begin + Result := sigemptyset (Mask); + pragma Assert (Result = 0); + end Empty_Interrupt_Mask; + + --------------------------- + -- Add_To_Interrupt_Mask -- + --------------------------- + + procedure Add_To_Interrupt_Mask + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID) + is + Result : Interfaces.C.int; + begin + Result := sigaddset (Mask, Signal (Interrupt)); + pragma Assert (Result = 0); + end Add_To_Interrupt_Mask; + + -------------------------------- + -- Delete_From_Interrupt_Mask -- + -------------------------------- + + procedure Delete_From_Interrupt_Mask + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID) + is + Result : Interfaces.C.int; + begin + Result := sigdelset (Mask, Signal (Interrupt)); + pragma Assert (Result = 0); + end Delete_From_Interrupt_Mask; + + --------------- + -- Is_Member -- + --------------- + + function Is_Member + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID) return Boolean + is + Result : Interfaces.C.int; + begin + Result := sigismember (Mask, Signal (Interrupt)); + pragma Assert (Result = 0 or else Result = 1); + return Result = 1; + end Is_Member; + + ------------------------- + -- Copy_Interrupt_Mask -- + ------------------------- + + procedure Copy_Interrupt_Mask + (X : out Interrupt_Mask; + Y : Interrupt_Mask) is + begin + X := Y; + end Copy_Interrupt_Mask; + + ---------------------------- + -- Interrupt_Self_Process -- + ---------------------------- + + procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is + Result : Interfaces.C.int; + begin + Result := kill (getpid, Signal (Interrupt)); + pragma Assert (Result = 0); + end Interrupt_Self_Process; + + -------------------------- + -- Setup_Interrupt_Mask -- + -------------------------- + + procedure Setup_Interrupt_Mask is + begin + -- Mask task for all signals. The original mask of the Environment task + -- will be recovered by Interrupt_Manager task during the elaboration + -- of s-interr.adb. + + Set_Interrupt_Mask (All_Tasks_Mask'Access); + end Setup_Interrupt_Mask; + +begin + declare + mask : aliased sigset_t; + allmask : aliased sigset_t; + Result : Interfaces.C.int; + + begin + Interrupt_Management.Initialize; + + for Sig in 1 .. Signal'Last loop + Result := sigaction + (Sig, null, Initial_Action (Sig)'Access); + + -- ??? [assert 1] + -- we can't check Result here since sigaction will fail on + -- SIGKILL, SIGSTOP, and possibly other signals + -- pragma Assert (Result = 0); + + end loop; + + -- Setup the masks to be exported + + Result := sigemptyset (mask'Access); + pragma Assert (Result = 0); + + Result := sigfillset (allmask'Access); + pragma Assert (Result = 0); + + Default_Action.sa_flags := 0; + Default_Action.sa_mask := mask; + Default_Action.sa_handler := + Storage_Elements.To_Address + (Storage_Elements.Integer_Address (SIG_DFL)); + + Ignore_Action.sa_flags := 0; + Ignore_Action.sa_mask := mask; + Ignore_Action.sa_handler := + Storage_Elements.To_Address + (Storage_Elements.Integer_Address (SIG_IGN)); + + for J in Interrupt_ID loop + if Keep_Unmasked (J) then + Result := sigaddset (mask'Access, Signal (J)); + pragma Assert (Result = 0); + Result := sigdelset (allmask'Access, Signal (J)); + pragma Assert (Result = 0); + end if; + end loop; + + -- The Keep_Unmasked signals should be unmasked for Environment task + + Result := pthread_sigmask (SIG_UNBLOCK, mask'Access, null); + pragma Assert (Result = 0); + + -- Get the signal mask of the Environment Task + + Result := pthread_sigmask (SIG_SETMASK, null, mask'Access); + pragma Assert (Result = 0); + + -- Setup the constants exported + + Environment_Mask := Interrupt_Mask (mask); + + All_Tasks_Mask := Interrupt_Mask (allmask); + end; + +end System.Interrupt_Management.Operations; diff --git a/gcc/ada/s-inmaop-vms.adb b/gcc/ada/s-inmaop-vms.adb new file mode 100644 index 000000000..b99b155f3 --- /dev/null +++ b/gcc/ada/s-inmaop-vms.adb @@ -0,0 +1,303 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a OpenVMS/Alpha version of this package + +with System.OS_Interface; +with System.Aux_DEC; +with System.Parameters; +with System.Tasking; +with System.Tasking.Initialization; +with System.Task_Primitives; +with System.Task_Primitives.Operations; +with System.Task_Primitives.Operations.DEC; + +with Ada.Unchecked_Conversion; + +package body System.Interrupt_Management.Operations is + + use System.OS_Interface; + use System.Parameters; + use System.Tasking; + use type unsigned_short; + + function To_Address is + new Ada.Unchecked_Conversion + (Task_Id, System.Task_Primitives.Task_Address); + + package POP renames System.Task_Primitives.Operations; + + ---------------------------- + -- Thread_Block_Interrupt -- + ---------------------------- + + procedure Thread_Block_Interrupt (Interrupt : Interrupt_ID) is + pragma Warnings (Off, Interrupt); + begin + null; + end Thread_Block_Interrupt; + + ------------------------------ + -- Thread_Unblock_Interrupt -- + ------------------------------ + + procedure Thread_Unblock_Interrupt (Interrupt : Interrupt_ID) is + pragma Warnings (Off, Interrupt); + begin + null; + end Thread_Unblock_Interrupt; + + ------------------------ + -- Set_Interrupt_Mask -- + ------------------------ + + procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is + pragma Warnings (Off, Mask); + begin + null; + end Set_Interrupt_Mask; + + procedure Set_Interrupt_Mask + (Mask : access Interrupt_Mask; + OMask : access Interrupt_Mask) + is + pragma Warnings (Off, Mask); + pragma Warnings (Off, OMask); + begin + null; + end Set_Interrupt_Mask; + + ------------------------ + -- Get_Interrupt_Mask -- + ------------------------ + + procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is + pragma Warnings (Off, Mask); + begin + null; + end Get_Interrupt_Mask; + + -------------------- + -- Interrupt_Wait -- + -------------------- + + function To_unsigned_long is new + Ada.Unchecked_Conversion (System.Aux_DEC.Short_Address, unsigned_long); + + function Interrupt_Wait (Mask : access Interrupt_Mask) + return Interrupt_ID + is + Self_ID : constant Task_Id := Self; + Iosb : IO_Status_Block_Type := (0, 0, 0); + Status : Cond_Value_Type; + + begin + + -- A QIO read is registered. The system call returns immediately + -- after scheduling an AST to be fired when the operation + -- completes. + + Sys_QIO + (Status => Status, + Chan => Rcv_Interrupt_Chan, + Func => IO_READVBLK, + Iosb => Iosb, + Astadr => + POP.DEC.Interrupt_AST_Handler'Access, + Astprm => To_Address (Self_ID), + P1 => To_unsigned_long (Interrupt_Mailbox'Address), + P2 => Interrupt_ID'Size / 8); + + pragma Assert ((Status and 1) = 1); + + loop + + -- Wait to be woken up. Could be that the AST has fired, + -- in which case the Iosb.Status variable will be non-zero, + -- or maybe the wait is being aborted. + + POP.Sleep + (Self_ID, + System.Tasking.Interrupt_Server_Blocked_On_Event_Flag); + + if Iosb.Status /= 0 then + if (Iosb.Status and 1) = 1 + and then Mask (Signal (Interrupt_Mailbox)) + then + return Interrupt_Mailbox; + else + return 0; + end if; + else + POP.Unlock (Self_ID); + + if Single_Lock then + POP.Unlock_RTS; + end if; + + System.Tasking.Initialization.Undefer_Abort (Self_ID); + System.Tasking.Initialization.Defer_Abort (Self_ID); + + if Single_Lock then + POP.Lock_RTS; + end if; + + POP.Write_Lock (Self_ID); + end if; + end loop; + end Interrupt_Wait; + + ---------------------------- + -- Install_Default_Action -- + ---------------------------- + + procedure Install_Default_Action (Interrupt : Interrupt_ID) is + pragma Warnings (Off, Interrupt); + begin + null; + end Install_Default_Action; + + --------------------------- + -- Install_Ignore_Action -- + --------------------------- + + procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is + pragma Warnings (Off, Interrupt); + begin + null; + end Install_Ignore_Action; + + ------------------------- + -- Fill_Interrupt_Mask -- + ------------------------- + + procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is + begin + Mask.all := (others => True); + end Fill_Interrupt_Mask; + + -------------------------- + -- Empty_Interrupt_Mask -- + -------------------------- + + procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is + begin + Mask.all := (others => False); + end Empty_Interrupt_Mask; + + --------------------------- + -- Add_To_Interrupt_Mask -- + --------------------------- + + procedure Add_To_Interrupt_Mask + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID) + is + begin + Mask (Signal (Interrupt)) := True; + end Add_To_Interrupt_Mask; + + -------------------------------- + -- Delete_From_Interrupt_Mask -- + -------------------------------- + + procedure Delete_From_Interrupt_Mask + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID) + is + begin + Mask (Signal (Interrupt)) := False; + end Delete_From_Interrupt_Mask; + + --------------- + -- Is_Member -- + --------------- + + function Is_Member + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID) return Boolean + is + begin + return Mask (Signal (Interrupt)); + end Is_Member; + + ------------------------- + -- Copy_Interrupt_Mask -- + ------------------------- + + procedure Copy_Interrupt_Mask + (X : out Interrupt_Mask; + Y : Interrupt_Mask) + is + begin + X := Y; + end Copy_Interrupt_Mask; + + ---------------------------- + -- Interrupt_Self_Process -- + ---------------------------- + + procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is + Status : Cond_Value_Type; + begin + Sys_QIO + (Status => Status, + Chan => Snd_Interrupt_Chan, + Func => IO_WRITEVBLK, + P1 => To_unsigned_long (Interrupt'Address), + P2 => Interrupt_ID'Size / 8); + + -- The following could use a comment ??? + + pragma Assert ((Status and 1) = 1); + end Interrupt_Self_Process; + + -------------------------- + -- Setup_Interrupt_Mask -- + -------------------------- + + procedure Setup_Interrupt_Mask is + begin + null; + end Setup_Interrupt_Mask; + +begin + Interrupt_Management.Initialize; + Environment_Mask := (others => False); + All_Tasks_Mask := (others => True); + + for J in Interrupt_ID loop + if Keep_Unmasked (J) then + Environment_Mask (Signal (J)) := True; + All_Tasks_Mask (Signal (J)) := False; + end if; + end loop; +end System.Interrupt_Management.Operations; diff --git a/gcc/ada/s-inmaop.ads b/gcc/ada/s-inmaop.ads new file mode 100644 index 000000000..78d2dcbe9 --- /dev/null +++ b/gcc/ada/s-inmaop.ads @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +package System.Interrupt_Management.Operations is + + procedure Thread_Block_Interrupt (Interrupt : Interrupt_ID); + pragma Inline (Thread_Block_Interrupt); + -- Mask the calling thread for the interrupt + + procedure Thread_Unblock_Interrupt (Interrupt : Interrupt_ID); + pragma Inline (Thread_Unblock_Interrupt); + -- Unmask the calling thread for the interrupt + + procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask); + -- Set the interrupt mask of the calling thread + + procedure Set_Interrupt_Mask + (Mask : access Interrupt_Mask; + OMask : access Interrupt_Mask); + pragma Inline (Set_Interrupt_Mask); + -- Set the interrupt mask of the calling thread while returning the + -- previous Mask. + + procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask); + pragma Inline (Get_Interrupt_Mask); + -- Get the interrupt mask of the calling thread + + function Interrupt_Wait (Mask : access Interrupt_Mask) return Interrupt_ID; + pragma Inline (Interrupt_Wait); + -- Wait for the interrupts specified in Mask and return + -- the interrupt received. Return 0 upon error. + + procedure Install_Default_Action (Interrupt : Interrupt_ID); + pragma Inline (Install_Default_Action); + -- Set the sigaction of the Interrupt to default (SIG_DFL) + + procedure Install_Ignore_Action (Interrupt : Interrupt_ID); + pragma Inline (Install_Ignore_Action); + -- Set the sigaction of the Interrupt to ignore (SIG_IGN) + + procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask); + pragma Inline (Fill_Interrupt_Mask); + -- Get a Interrupt_Mask with all the interrupt masked + + procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask); + pragma Inline (Empty_Interrupt_Mask); + -- Get a Interrupt_Mask with all the interrupt unmasked + + procedure Add_To_Interrupt_Mask + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID); + pragma Inline (Add_To_Interrupt_Mask); + -- Mask the given interrupt in the Interrupt_Mask + + procedure Delete_From_Interrupt_Mask + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID); + pragma Inline (Delete_From_Interrupt_Mask); + -- Unmask the given interrupt in the Interrupt_Mask + + function Is_Member + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID) return Boolean; + pragma Inline (Is_Member); + -- See if a given interrupt is masked in the Interrupt_Mask + + procedure Copy_Interrupt_Mask (X : out Interrupt_Mask; Y : Interrupt_Mask); + pragma Inline (Copy_Interrupt_Mask); + -- Assignment needed for limited private type Interrupt_Mask + + procedure Interrupt_Self_Process (Interrupt : Interrupt_ID); + pragma Inline (Interrupt_Self_Process); + -- Raise an Interrupt process-level + + procedure Setup_Interrupt_Mask; + -- Mask Environment task for all signals + -- This function should be called by the elaboration of System.Interrupt + -- to set up proper signal masking in all tasks. + + -- The following objects serve as constants, but are initialized in the + -- body to aid portability. These should be in System.Interrupt_Management + -- but since Interrupt_Mask is private type we cannot have them declared + -- there. + + -- Why not make these deferred constants that are initialized using + -- function calls in the private part??? + + Environment_Mask : aliased Interrupt_Mask; + -- This mask represents the mask of Environment task when this package is + -- being elaborated, except the signals being forced to be unmasked by RTS + -- (items in Keep_Unmasked) + + All_Tasks_Mask : aliased Interrupt_Mask; + -- This is the mask of all tasks created in RTS. Only one task in RTS + -- is responsible for masking/unmasking signals (see s-interr.adb). + +end System.Interrupt_Management.Operations; diff --git a/gcc/ada/s-interr-dummy.adb b/gcc/ada/s-interr-dummy.adb new file mode 100644 index 000000000..343f8f559 --- /dev/null +++ b/gcc/ada/s-interr-dummy.adb @@ -0,0 +1,306 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2008, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is for systems that do not support interrupts (or signals) + +package body System.Interrupts is + + pragma Warnings (Off); -- kill warnings on unreferenced formals + + use System.Tasking; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Unimplemented; + -- This procedure raises a Program_Error with an appropriate message + -- indicating that an unimplemented feature has been used. + + -------------------- + -- Attach_Handler -- + -------------------- + + procedure Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False) + is + begin + Unimplemented; + end Attach_Handler; + + ----------------------------- + -- Bind_Interrupt_To_Entry -- + ----------------------------- + + procedure Bind_Interrupt_To_Entry + (T : Task_Id; + E : Task_Entry_Index; + Int_Ref : System.Address) + is + begin + Unimplemented; + end Bind_Interrupt_To_Entry; + + --------------------- + -- Block_Interrupt -- + --------------------- + + procedure Block_Interrupt (Interrupt : Interrupt_ID) is + begin + Unimplemented; + end Block_Interrupt; + + --------------------- + -- Current_Handler -- + --------------------- + + function Current_Handler + (Interrupt : Interrupt_ID) return Parameterless_Handler + is + begin + Unimplemented; + return null; + end Current_Handler; + + -------------------- + -- Detach_Handler -- + -------------------- + + procedure Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean := False) + is + begin + Unimplemented; + end Detach_Handler; + + ------------------------------ + -- Detach_Interrupt_Entries -- + ------------------------------ + + procedure Detach_Interrupt_Entries (T : Task_Id) is + begin + Unimplemented; + end Detach_Interrupt_Entries; + + ---------------------- + -- Exchange_Handler -- + ---------------------- + + procedure Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False) + is + begin + Old_Handler := null; + Unimplemented; + end Exchange_Handler; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Static_Interrupt_Protection) is + begin + Unimplemented; + end Finalize; + + ------------------------------------- + -- Has_Interrupt_Or_Attach_Handler -- + ------------------------------------- + + function Has_Interrupt_Or_Attach_Handler + (Object : access Dynamic_Interrupt_Protection) + return Boolean + is + pragma Warnings (Off, Object); + begin + Unimplemented; + return True; + end Has_Interrupt_Or_Attach_Handler; + + function Has_Interrupt_Or_Attach_Handler + (Object : access Static_Interrupt_Protection) + return Boolean + is + pragma Warnings (Off, Object); + begin + Unimplemented; + return True; + end Has_Interrupt_Or_Attach_Handler; + + ---------------------- + -- Ignore_Interrupt -- + ---------------------- + + procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is + begin + Unimplemented; + end Ignore_Interrupt; + + ---------------------- + -- Install_Handlers -- + ---------------------- + + procedure Install_Handlers + (Object : access Static_Interrupt_Protection; + New_Handlers : New_Handler_Array) + is + begin + Unimplemented; + end Install_Handlers; + + --------------------------------- + -- Install_Restricted_Handlers -- + --------------------------------- + + procedure Install_Restricted_Handlers (Handlers : New_Handler_Array) is + begin + Unimplemented; + end Install_Restricted_Handlers; + + ---------------- + -- Is_Blocked -- + ---------------- + + function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is + begin + Unimplemented; + return True; + end Is_Blocked; + + ----------------------- + -- Is_Entry_Attached -- + ----------------------- + + function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + Unimplemented; + return True; + end Is_Entry_Attached; + + ------------------------- + -- Is_Handler_Attached -- + ------------------------- + + function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + Unimplemented; + return True; + end Is_Handler_Attached; + + ---------------- + -- Is_Ignored -- + ---------------- + + function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is + begin + Unimplemented; + return True; + end Is_Ignored; + + ----------------- + -- Is_Reserved -- + ----------------- + + function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is + begin + Unimplemented; + return True; + end Is_Reserved; + + --------------- + -- Reference -- + --------------- + + function Reference (Interrupt : Interrupt_ID) return System.Address is + begin + Unimplemented; + return Interrupt'Address; + end Reference; + + -------------------------------- + -- Register_Interrupt_Handler -- + -------------------------------- + + procedure Register_Interrupt_Handler + (Handler_Addr : System.Address) + is + begin + Unimplemented; + end Register_Interrupt_Handler; + + ----------------------- + -- Unblock_Interrupt -- + ----------------------- + + procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is + begin + Unimplemented; + end Unblock_Interrupt; + + ------------------ + -- Unblocked_By -- + ------------------ + + function Unblocked_By (Interrupt : Interrupt_ID) + return System.Tasking.Task_Id is + begin + Unimplemented; + return null; + end Unblocked_By; + + ------------------------ + -- Unignore_Interrupt -- + ------------------------ + + procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is + begin + Unimplemented; + end Unignore_Interrupt; + + ------------------- + -- Unimplemented; -- + ------------------- + + procedure Unimplemented is + begin + raise Program_Error with "interrupts/signals not implemented"; + end Unimplemented; + +end System.Interrupts; diff --git a/gcc/ada/s-interr-hwint.adb b/gcc/ada/s-interr-hwint.adb new file mode 100644 index 000000000..038db362f --- /dev/null +++ b/gcc/ada/s-interr-hwint.adb @@ -0,0 +1,1105 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T S -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Invariants: + +-- All user-handleable signals are masked at all times in all tasks/threads +-- except possibly for the Interrupt_Manager task. + +-- When a user task wants to have the effect of masking/unmasking an signal, +-- it must call Block_Interrupt/Unblock_Interrupt, which will have the effect +-- of unmasking/masking the signal in the Interrupt_Manager task. These +-- comments do not apply to vectored hardware interrupts, which may be masked +-- or unmasked using routined interfaced to the relevant embedded RTOS system +-- calls. + +-- Once we associate a Signal_Server_Task with an signal, the task never goes +-- away, and we never remove the association. On the other hand, it is more +-- convenient to terminate an associated Interrupt_Server_Task for a vectored +-- hardware interrupt (since we use a binary semaphore for synchronization +-- with the umbrella handler). + +-- There is no more than one signal per Signal_Server_Task and no more than +-- one Signal_Server_Task per signal. The same relation holds for hardware +-- interrupts and Interrupt_Server_Task's at any given time. That is, only +-- one non-terminated Interrupt_Server_Task exists for a give interrupt at +-- any time. + +-- Within this package, the lock L is used to protect the various status +-- tables. If there is a Server_Task associated with a signal or interrupt, we +-- use the per-task lock of the Server_Task instead so that we protect the +-- status between Interrupt_Manager and Server_Task. Protection among service +-- requests are ensured via user calls to the Interrupt_Manager entries. + +-- This is reasonably generic version of this package, supporting vectored +-- hardware interrupts using non-RTOS specific adapter routines which +-- should easily implemented on any RTOS capable of supporting GNAT. + +with Ada.Unchecked_Conversion; +with Ada.Task_Identification; + +with Interfaces.C; use Interfaces.C; +with System.OS_Interface; use System.OS_Interface; +with System.Interrupt_Management; +with System.Task_Primitives.Operations; +with System.Storage_Elements; +with System.Tasking.Utilities; + +with System.Tasking.Rendezvous; +pragma Elaborate_All (System.Tasking.Rendezvous); + +package body System.Interrupts is + + use Tasking; + + package POP renames System.Task_Primitives.Operations; + + function To_Ada is new Ada.Unchecked_Conversion + (System.Tasking.Task_Id, Ada.Task_Identification.Task_Id); + + function To_System is new Ada.Unchecked_Conversion + (Ada.Task_Identification.Task_Id, Task_Id); + + ----------------- + -- Local Tasks -- + ----------------- + + -- WARNING: System.Tasking.Stages performs calls to this task with + -- low-level constructs. Do not change this spec without synchronizing it. + + task Interrupt_Manager is + entry Detach_Interrupt_Entries (T : Task_Id); + + entry Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False); + + entry Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean); + + entry Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean); + + entry Bind_Interrupt_To_Entry + (T : Task_Id; + E : Task_Entry_Index; + Interrupt : Interrupt_ID); + + pragma Interrupt_Priority (System.Interrupt_Priority'First); + end Interrupt_Manager; + + task type Interrupt_Server_Task + (Interrupt : Interrupt_ID; Int_Sema : Binary_Semaphore_Id) is + -- Server task for vectored hardware interrupt handling + pragma Interrupt_Priority (System.Interrupt_Priority'First + 2); + end Interrupt_Server_Task; + + type Interrupt_Task_Access is access Interrupt_Server_Task; + + ------------------------------- + -- Local Types and Variables -- + ------------------------------- + + type Entry_Assoc is record + T : Task_Id; + E : Task_Entry_Index; + end record; + + type Handler_Assoc is record + H : Parameterless_Handler; + Static : Boolean; -- Indicates static binding; + end record; + + User_Handler : array (Interrupt_ID) of Handler_Assoc := + (others => (null, Static => False)); + pragma Volatile_Components (User_Handler); + -- Holds the protected procedure handler (if any) and its Static + -- information for each interrupt or signal. A handler is static + -- iff it is specified through the pragma Attach_Handler. + + User_Entry : array (Interrupt_ID) of Entry_Assoc := + (others => (T => Null_Task, E => Null_Task_Entry)); + pragma Volatile_Components (User_Entry); + -- Holds the task and entry index (if any) for each interrupt / signal + + -- Type and Head, Tail of the list containing Registered Interrupt + -- Handlers. These definitions are used to register the handlers + -- specified by the pragma Interrupt_Handler. + + type Registered_Handler; + type R_Link is access all Registered_Handler; + + type Registered_Handler is record + H : System.Address := System.Null_Address; + Next : R_Link := null; + end record; + + Registered_Handler_Head : R_Link := null; + Registered_Handler_Tail : R_Link := null; + + Server_ID : array (Interrupt_ID) of System.Tasking.Task_Id := + (others => System.Tasking.Null_Task); + pragma Atomic_Components (Server_ID); + -- Holds the Task_Id of the Server_Task for each interrupt / signal. + -- Task_Id is needed to accomplish locking per interrupt base. Also + -- is needed to determine whether to create a new Server_Task. + + Semaphore_ID_Map : array + (Interrupt_ID range 0 .. System.OS_Interface.Max_HW_Interrupt) + of Binary_Semaphore_Id := (others => 0); + -- Array of binary semaphores associated with vectored interrupts + -- Note that the last bound should be Max_HW_Interrupt, but this will raise + -- Storage_Error if Num_HW_Interrupts is null, so use an extra 4 bytes + -- instead. + + Interrupt_Access_Hold : Interrupt_Task_Access; + -- Variable for allocating an Interrupt_Server_Task + + Handler_Installed : array (HW_Interrupt) of Boolean := (others => False); + -- True if Notify_Interrupt was connected to the interrupt. Handlers + -- can be connected but disconnection is not possible on VxWorks. + -- Therefore we ensure Notify_Installed is connected at most once. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID); + -- Check if Id is a reserved interrupt, and if so raise Program_Error + -- with an appropriate message, otherwise return. + + procedure Finalize_Interrupt_Servers; + -- Unbind the handlers for hardware interrupt server tasks at program + -- termination. + + function Is_Registered (Handler : Parameterless_Handler) return Boolean; + -- See if Handler has been "pragma"ed using Interrupt_Handler. + -- Always consider a null handler as registered. + + procedure Notify_Interrupt (Param : System.Address); + pragma Convention (C, Notify_Interrupt); + -- Umbrella handler for vectored interrupts (not signals) + + procedure Install_Umbrella_Handler + (Interrupt : HW_Interrupt; + Handler : System.OS_Interface.Interrupt_Handler); + -- Install the runtime umbrella handler for a vectored hardware + -- interrupt + + procedure Unimplemented (Feature : String); + pragma No_Return (Unimplemented); + -- Used to mark a call to an unimplemented function. Raises Program_Error + -- with an appropriate message noting that Feature is unimplemented. + + -------------------- + -- Attach_Handler -- + -------------------- + + -- Calling this procedure with New_Handler = null and Static = True + -- means we want to detach the current handler regardless of the + -- previous handler's binding status (i.e. do not care if it is a + -- dynamic or static handler). + + -- This option is needed so that during the finalization of a PO, we + -- can detach handlers attached through pragma Attach_Handler. + + procedure Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False) is + begin + Check_Reserved_Interrupt (Interrupt); + Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static); + end Attach_Handler; + + ----------------------------- + -- Bind_Interrupt_To_Entry -- + ----------------------------- + + -- This procedure raises a Program_Error if it tries to + -- bind an interrupt to which an Entry or a Procedure is + -- already bound. + + procedure Bind_Interrupt_To_Entry + (T : Task_Id; + E : Task_Entry_Index; + Int_Ref : System.Address) + is + Interrupt : constant Interrupt_ID := + Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); + + begin + Check_Reserved_Interrupt (Interrupt); + Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt); + end Bind_Interrupt_To_Entry; + + --------------------- + -- Block_Interrupt -- + --------------------- + + procedure Block_Interrupt (Interrupt : Interrupt_ID) is + begin + Unimplemented ("Block_Interrupt"); + end Block_Interrupt; + + ------------------------------ + -- Check_Reserved_Interrupt -- + ------------------------------ + + procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID) is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + else + return; + end if; + end Check_Reserved_Interrupt; + + --------------------- + -- Current_Handler -- + --------------------- + + function Current_Handler + (Interrupt : Interrupt_ID) return Parameterless_Handler + is + begin + Check_Reserved_Interrupt (Interrupt); + + -- ??? Since Parameterless_Handler is not Atomic, the + -- current implementation is wrong. We need a new service in + -- Interrupt_Manager to ensure atomicity. + + return User_Handler (Interrupt).H; + end Current_Handler; + + -------------------- + -- Detach_Handler -- + -------------------- + + -- Calling this procedure with Static = True means we want to Detach the + -- current handler regardless of the previous handler's binding status + -- (i.e. do not care if it is a dynamic or static handler). + + -- This option is needed so that during the finalization of a PO, we can + -- detach handlers attached through pragma Attach_Handler. + + procedure Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean := False) is + begin + Check_Reserved_Interrupt (Interrupt); + Interrupt_Manager.Detach_Handler (Interrupt, Static); + end Detach_Handler; + + ------------------------------ + -- Detach_Interrupt_Entries -- + ------------------------------ + + procedure Detach_Interrupt_Entries (T : Task_Id) is + begin + Interrupt_Manager.Detach_Interrupt_Entries (T); + end Detach_Interrupt_Entries; + + ---------------------- + -- Exchange_Handler -- + ---------------------- + + -- Calling this procedure with New_Handler = null and Static = True + -- means we want to detach the current handler regardless of the + -- previous handler's binding status (i.e. do not care if it is a + -- dynamic or static handler). + + -- This option is needed so that during the finalization of a PO, we + -- can detach handlers attached through pragma Attach_Handler. + + procedure Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False) + is + begin + Check_Reserved_Interrupt (Interrupt); + Interrupt_Manager.Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static); + end Exchange_Handler; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Static_Interrupt_Protection) is + begin + -- ??? loop to be executed only when we're not doing library level + -- finalization, since in this case all interrupt / signal tasks are + -- gone. + + if not Interrupt_Manager'Terminated then + for N in reverse Object.Previous_Handlers'Range loop + Interrupt_Manager.Attach_Handler + (New_Handler => Object.Previous_Handlers (N).Handler, + Interrupt => Object.Previous_Handlers (N).Interrupt, + Static => Object.Previous_Handlers (N).Static, + Restoration => True); + end loop; + end if; + + Tasking.Protected_Objects.Entries.Finalize + (Tasking.Protected_Objects.Entries.Protection_Entries (Object)); + end Finalize; + + -------------------------------- + -- Finalize_Interrupt_Servers -- + -------------------------------- + + -- Restore default handlers for interrupt servers + + -- This is called by the Interrupt_Manager task when it receives the abort + -- signal during program finalization. + + procedure Finalize_Interrupt_Servers is + HW_Interrupts : constant Boolean := HW_Interrupt'Last >= 0; + + begin + if HW_Interrupts then + for Int in HW_Interrupt loop + if Server_ID (Interrupt_ID (Int)) /= null + and then + not Ada.Task_Identification.Is_Terminated + (To_Ada (Server_ID (Interrupt_ID (Int)))) + then + Interrupt_Manager.Attach_Handler + (New_Handler => null, + Interrupt => Interrupt_ID (Int), + Static => True, + Restoration => True); + end if; + end loop; + end if; + end Finalize_Interrupt_Servers; + + ------------------------------------- + -- Has_Interrupt_Or_Attach_Handler -- + ------------------------------------- + + function Has_Interrupt_Or_Attach_Handler + (Object : access Dynamic_Interrupt_Protection) + return Boolean + is + pragma Unreferenced (Object); + begin + return True; + end Has_Interrupt_Or_Attach_Handler; + + function Has_Interrupt_Or_Attach_Handler + (Object : access Static_Interrupt_Protection) + return Boolean + is + pragma Unreferenced (Object); + begin + return True; + end Has_Interrupt_Or_Attach_Handler; + + ---------------------- + -- Ignore_Interrupt -- + ---------------------- + + procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is + begin + Unimplemented ("Ignore_Interrupt"); + end Ignore_Interrupt; + + ---------------------- + -- Install_Handlers -- + ---------------------- + + procedure Install_Handlers + (Object : access Static_Interrupt_Protection; + New_Handlers : New_Handler_Array) + is + begin + for N in New_Handlers'Range loop + + -- We need a lock around this ??? + + Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt; + Object.Previous_Handlers (N).Static := User_Handler + (New_Handlers (N).Interrupt).Static; + + -- We call Exchange_Handler and not directly Interrupt_Manager. + -- Exchange_Handler so we get the Is_Reserved check. + + Exchange_Handler + (Old_Handler => Object.Previous_Handlers (N).Handler, + New_Handler => New_Handlers (N).Handler, + Interrupt => New_Handlers (N).Interrupt, + Static => True); + end loop; + end Install_Handlers; + + --------------------------------- + -- Install_Restricted_Handlers -- + --------------------------------- + + procedure Install_Restricted_Handlers (Handlers : New_Handler_Array) is + begin + for N in Handlers'Range loop + Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True); + end loop; + end Install_Restricted_Handlers; + + ------------------------------ + -- Install_Umbrella_Handler -- + ------------------------------ + + procedure Install_Umbrella_Handler + (Interrupt : HW_Interrupt; + Handler : System.OS_Interface.Interrupt_Handler) + is + Vec : constant Interrupt_Vector := + Interrupt_Number_To_Vector (int (Interrupt)); + + Status : int; + + begin + -- Only install umbrella handler when no Ada handler has already been + -- installed. Note that the interrupt number is passed as a parameter + -- when an interrupt occurs, so the umbrella handler has a different + -- wrapper generated by intConnect for each interrupt number. + + if not Handler_Installed (Interrupt) then + Status := + Interrupt_Connect (Vec, Handler, System.Address (Interrupt)); + pragma Assert (Status = 0); + + Handler_Installed (Interrupt) := True; + end if; + end Install_Umbrella_Handler; + + ---------------- + -- Is_Blocked -- + ---------------- + + function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is + begin + Unimplemented ("Is_Blocked"); + return False; + end Is_Blocked; + + ----------------------- + -- Is_Entry_Attached -- + ----------------------- + + function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + Check_Reserved_Interrupt (Interrupt); + return User_Entry (Interrupt).T /= Null_Task; + end Is_Entry_Attached; + + ------------------------- + -- Is_Handler_Attached -- + ------------------------- + + function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + Check_Reserved_Interrupt (Interrupt); + return User_Handler (Interrupt).H /= null; + end Is_Handler_Attached; + + ---------------- + -- Is_Ignored -- + ---------------- + + function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is + begin + Unimplemented ("Is_Ignored"); + return False; + end Is_Ignored; + + ------------------- + -- Is_Registered -- + ------------------- + + function Is_Registered (Handler : Parameterless_Handler) return Boolean is + type Fat_Ptr is record + Object_Addr : System.Address; + Handler_Addr : System.Address; + end record; + + function To_Fat_Ptr is new Ada.Unchecked_Conversion + (Parameterless_Handler, Fat_Ptr); + + Ptr : R_Link; + Fat : Fat_Ptr; + + begin + if Handler = null then + return True; + end if; + + Fat := To_Fat_Ptr (Handler); + + Ptr := Registered_Handler_Head; + + while Ptr /= null loop + if Ptr.H = Fat.Handler_Addr then + return True; + end if; + + Ptr := Ptr.Next; + end loop; + + return False; + end Is_Registered; + + ----------------- + -- Is_Reserved -- + ----------------- + + function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is + use System.Interrupt_Management; + begin + return Reserve (System.Interrupt_Management.Interrupt_ID (Interrupt)); + end Is_Reserved; + + ---------------------- + -- Notify_Interrupt -- + ---------------------- + + -- Umbrella handler for vectored hardware interrupts (as opposed to + -- signals and exceptions). As opposed to the signal implementation, + -- this handler is installed in the vector table when the first Ada + -- handler is attached to the interrupt. However because VxWorks don't + -- support disconnecting handlers, this subprogram always test whether + -- or not an Ada handler is effectively attached. + + -- Otherwise, the handler that existed prior to program startup is + -- in the vector table. This ensures that handlers installed by + -- the BSP are active unless explicitly replaced in the program text. + + -- Each Interrupt_Server_Task has an associated binary semaphore + -- on which it pends once it's been started. This routine determines + -- The appropriate semaphore and issues a semGive call, waking + -- the server task. When a handler is unbound, + -- System.Interrupts.Unbind_Handler issues a Binary_Semaphore_Flush, + -- and the server task deletes its semaphore and terminates. + + procedure Notify_Interrupt (Param : System.Address) is + Interrupt : constant Interrupt_ID := Interrupt_ID (Param); + + Id : constant Binary_Semaphore_Id := Semaphore_ID_Map (Interrupt); + + Status : int; + + begin + if Id /= 0 then + Status := Binary_Semaphore_Release (Id); + pragma Assert (Status = 0); + end if; + end Notify_Interrupt; + + --------------- + -- Reference -- + --------------- + + function Reference (Interrupt : Interrupt_ID) return System.Address is + begin + Check_Reserved_Interrupt (Interrupt); + return Storage_Elements.To_Address + (Storage_Elements.Integer_Address (Interrupt)); + end Reference; + + -------------------------------- + -- Register_Interrupt_Handler -- + -------------------------------- + + procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is + New_Node_Ptr : R_Link; + + begin + -- This routine registers a handler as usable for dynamic + -- interrupt handler association. Routines attaching and detaching + -- handlers dynamically should determine whether the handler is + -- registered. Program_Error should be raised if it is not registered. + + -- Pragma Interrupt_Handler can only appear in a library + -- level PO definition and instantiation. Therefore, we do not need + -- to implement an unregister operation. Nor do we need to + -- protect the queue structure with a lock. + + pragma Assert (Handler_Addr /= System.Null_Address); + + New_Node_Ptr := new Registered_Handler; + New_Node_Ptr.H := Handler_Addr; + + if Registered_Handler_Head = null then + Registered_Handler_Head := New_Node_Ptr; + Registered_Handler_Tail := New_Node_Ptr; + + else + Registered_Handler_Tail.Next := New_Node_Ptr; + Registered_Handler_Tail := New_Node_Ptr; + end if; + end Register_Interrupt_Handler; + + ----------------------- + -- Unblock_Interrupt -- + ----------------------- + + procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is + begin + Unimplemented ("Unblock_Interrupt"); + end Unblock_Interrupt; + + ------------------ + -- Unblocked_By -- + ------------------ + + function Unblocked_By + (Interrupt : Interrupt_ID) return System.Tasking.Task_Id + is + begin + Unimplemented ("Unblocked_By"); + return Null_Task; + end Unblocked_By; + + ------------------------ + -- Unignore_Interrupt -- + ------------------------ + + procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is + begin + Unimplemented ("Unignore_Interrupt"); + end Unignore_Interrupt; + + ------------------- + -- Unimplemented -- + ------------------- + + procedure Unimplemented (Feature : String) is + begin + raise Program_Error with Feature & " not implemented on VxWorks"; + end Unimplemented; + + ----------------------- + -- Interrupt_Manager -- + ----------------------- + + task body Interrupt_Manager is + + -------------------- + -- Local Routines -- + -------------------- + + procedure Bind_Handler (Interrupt : Interrupt_ID); + -- This procedure does not do anything if a signal is blocked. + -- Otherwise, we have to interrupt Server_Task for status change through + -- a wakeup signal. + + procedure Unbind_Handler (Interrupt : Interrupt_ID); + -- This procedure does not do anything if a signal is blocked. + -- Otherwise, we have to interrupt Server_Task for status change + -- through an abort signal. + + procedure Unprotected_Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False); + + procedure Unprotected_Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean); + + ------------------ + -- Bind_Handler -- + ------------------ + + procedure Bind_Handler (Interrupt : Interrupt_ID) is + begin + Install_Umbrella_Handler + (HW_Interrupt (Interrupt), Notify_Interrupt'Access); + end Bind_Handler; + + -------------------- + -- Unbind_Handler -- + -------------------- + + procedure Unbind_Handler (Interrupt : Interrupt_ID) is + Status : int; + begin + + -- Flush server task off semaphore, allowing it to terminate + + Status := Binary_Semaphore_Flush (Semaphore_ID_Map (Interrupt)); + pragma Assert (Status = 0); + end Unbind_Handler; + + -------------------------------- + -- Unprotected_Detach_Handler -- + -------------------------------- + + procedure Unprotected_Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean) + is + Old_Handler : Parameterless_Handler; + begin + if User_Entry (Interrupt).T /= Null_Task then + -- If an interrupt entry is installed raise + -- Program_Error. (propagate it to the caller). + + raise Program_Error with + "An interrupt entry is already installed"; + end if; + + -- Note : Static = True will pass the following check. This is the + -- case when we want to detach a handler regardless of the static + -- status of the Current_Handler. + + if not Static and then User_Handler (Interrupt).Static then + + -- Trying to detach a static Interrupt Handler. raise + -- Program_Error. + + raise Program_Error with + "Trying to detach a static Interrupt Handler"; + end if; + + Old_Handler := User_Handler (Interrupt).H; + + -- The new handler + + User_Handler (Interrupt).H := null; + User_Handler (Interrupt).Static := False; + + if Old_Handler /= null then + Unbind_Handler (Interrupt); + end if; + end Unprotected_Detach_Handler; + + ---------------------------------- + -- Unprotected_Exchange_Handler -- + ---------------------------------- + + procedure Unprotected_Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False) + is + begin + if User_Entry (Interrupt).T /= Null_Task then + + -- If an interrupt entry is already installed, raise + -- Program_Error. (propagate it to the caller). + + raise Program_Error with "An interrupt is already installed"; + end if; + + -- Note : A null handler with Static = True will + -- pass the following check. This is the case when we want to + -- detach a handler regardless of the Static status + -- of Current_Handler. + -- We don't check anything if Restoration is True, since we + -- may be detaching a static handler to restore a dynamic one. + + if not Restoration and then not Static + and then (User_Handler (Interrupt).Static + + -- Trying to overwrite a static Interrupt Handler with a + -- dynamic Handler + + -- The new handler is not specified as an + -- Interrupt Handler by a pragma. + + or else not Is_Registered (New_Handler)) + then + raise Program_Error with + "Trying to overwrite a static Interrupt Handler with a " & + "dynamic Handler"; + end if; + + -- Save the old handler + + Old_Handler := User_Handler (Interrupt).H; + + -- The new handler + + User_Handler (Interrupt).H := New_Handler; + + if New_Handler = null then + + -- The null handler means we are detaching the handler + + User_Handler (Interrupt).Static := False; + + else + User_Handler (Interrupt).Static := Static; + end if; + + -- Invoke a corresponding Server_Task if not yet created. + -- Place Task_Id info in Server_ID array. + + if New_Handler /= null + and then + (Server_ID (Interrupt) = Null_Task + or else + Ada.Task_Identification.Is_Terminated + (To_Ada (Server_ID (Interrupt)))) + then + Interrupt_Access_Hold := + new Interrupt_Server_Task (Interrupt, Binary_Semaphore_Create); + Server_ID (Interrupt) := + To_System (Interrupt_Access_Hold.all'Identity); + end if; + + if (New_Handler = null) and then Old_Handler /= null then + + -- Restore default handler + + Unbind_Handler (Interrupt); + + elsif Old_Handler = null then + + -- Save default handler + + Bind_Handler (Interrupt); + end if; + end Unprotected_Exchange_Handler; + + -- Start of processing for Interrupt_Manager + + begin + -- By making this task independent of any master, when the process + -- goes away, the Interrupt_Manager will terminate gracefully. + + System.Tasking.Utilities.Make_Independent; + + loop + -- A block is needed to absorb Program_Error exception + + declare + Old_Handler : Parameterless_Handler; + + begin + select + accept Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False) + do + Unprotected_Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static, Restoration); + end Attach_Handler; + + or + accept Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean) + do + Unprotected_Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static); + end Exchange_Handler; + + or + accept Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean) + do + Unprotected_Detach_Handler (Interrupt, Static); + end Detach_Handler; + or + accept Bind_Interrupt_To_Entry + (T : Task_Id; + E : Task_Entry_Index; + Interrupt : Interrupt_ID) + do + -- If there is a binding already (either a procedure or an + -- entry), raise Program_Error (propagate it to the caller). + + if User_Handler (Interrupt).H /= null + or else User_Entry (Interrupt).T /= Null_Task + then + raise Program_Error with + "A binding for this interrupt is already present"; + end if; + + User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E); + + -- Indicate the attachment of interrupt entry in the ATCB. + -- This is needed so when an interrupt entry task terminates + -- the binding can be cleaned. The call to unbinding must be + -- make by the task before it terminates. + + T.Interrupt_Entry := True; + + -- Invoke a corresponding Server_Task if not yet created. + -- Place Task_Id info in Server_ID array. + + if Server_ID (Interrupt) = Null_Task + or else + Ada.Task_Identification.Is_Terminated + (To_Ada (Server_ID (Interrupt))) + then + Interrupt_Access_Hold := new Interrupt_Server_Task + (Interrupt, Binary_Semaphore_Create); + Server_ID (Interrupt) := + To_System (Interrupt_Access_Hold.all'Identity); + end if; + + Bind_Handler (Interrupt); + end Bind_Interrupt_To_Entry; + + or + accept Detach_Interrupt_Entries (T : Task_Id) do + for Int in Interrupt_ID'Range loop + if not Is_Reserved (Int) then + if User_Entry (Int).T = T then + User_Entry (Int) := + Entry_Assoc' + (T => Null_Task, E => Null_Task_Entry); + Unbind_Handler (Int); + end if; + end if; + end loop; + + -- Indicate in ATCB that no interrupt entries are attached + + T.Interrupt_Entry := False; + end Detach_Interrupt_Entries; + end select; + + exception + -- If there is a Program_Error we just want to propagate it to + -- the caller and do not want to stop this task. + + when Program_Error => + null; + + when others => + pragma Assert (False); + null; + end; + end loop; + + exception + when Standard'Abort_Signal => + -- Flush interrupt server semaphores, so they can terminate + Finalize_Interrupt_Servers; + raise; + end Interrupt_Manager; + + --------------------------- + -- Interrupt_Server_Task -- + --------------------------- + + -- Server task for vectored hardware interrupt handling + + task body Interrupt_Server_Task is + Self_Id : constant Task_Id := Self; + Tmp_Handler : Parameterless_Handler; + Tmp_ID : Task_Id; + Tmp_Entry_Index : Task_Entry_Index; + Status : int; + + begin + System.Tasking.Utilities.Make_Independent; + Semaphore_ID_Map (Interrupt) := Int_Sema; + + loop + -- Pend on semaphore that will be triggered by the + -- umbrella handler when the associated interrupt comes in + + Status := Binary_Semaphore_Obtain (Int_Sema); + pragma Assert (Status = 0); + + if User_Handler (Interrupt).H /= null then + + -- Protected procedure handler + + Tmp_Handler := User_Handler (Interrupt).H; + Tmp_Handler.all; + + elsif User_Entry (Interrupt).T /= Null_Task then + + -- Interrupt entry handler + + Tmp_ID := User_Entry (Interrupt).T; + Tmp_Entry_Index := User_Entry (Interrupt).E; + System.Tasking.Rendezvous.Call_Simple + (Tmp_ID, Tmp_Entry_Index, System.Null_Address); + + else + -- Semaphore has been flushed by an unbind operation in + -- the Interrupt_Manager. Terminate the server task. + + -- Wait for the Interrupt_Manager to complete its work + + POP.Write_Lock (Self_Id); + + -- Unassociate the interrupt handler + + Semaphore_ID_Map (Interrupt) := 0; + + -- Delete the associated semaphore + + Status := Binary_Semaphore_Delete (Int_Sema); + + pragma Assert (Status = 0); + + -- Set status for the Interrupt_Manager + + Server_ID (Interrupt) := Null_Task; + POP.Unlock (Self_Id); + + exit; + end if; + end loop; + end Interrupt_Server_Task; + +begin + -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent + + Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity); +end System.Interrupts; diff --git a/gcc/ada/s-interr-sigaction.adb b/gcc/ada/s-interr-sigaction.adb new file mode 100644 index 000000000..b405bb74f --- /dev/null +++ b/gcc/ada/s-interr-sigaction.adb @@ -0,0 +1,664 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the IRIX & NT version of this package + +with Ada.Task_Identification; +with Ada.Unchecked_Conversion; + +with Interfaces.C; + +with System.Storage_Elements; +with System.Task_Primitives.Operations; +with System.Tasking.Utilities; +with System.Tasking.Rendezvous; +with System.Tasking.Initialization; +with System.Interrupt_Management; +with System.Parameters; + +package body System.Interrupts is + + use Parameters; + use Tasking; + use System.OS_Interface; + use Interfaces.C; + + package STPO renames System.Task_Primitives.Operations; + package IMNG renames System.Interrupt_Management; + + subtype int is Interfaces.C.int; + + function To_System is new Ada.Unchecked_Conversion + (Ada.Task_Identification.Task_Id, Task_Id); + + type Handler_Kind is (Unknown, Task_Entry, Protected_Procedure); + + type Handler_Desc is record + Kind : Handler_Kind := Unknown; + T : Task_Id; + E : Task_Entry_Index; + H : Parameterless_Handler; + Static : Boolean := False; + end record; + + task type Server_Task (Interrupt : Interrupt_ID) is + pragma Interrupt_Priority (System.Interrupt_Priority'Last); + end Server_Task; + + type Server_Task_Access is access Server_Task; + + Handlers : array (Interrupt_ID) of Task_Id; + Descriptors : array (Interrupt_ID) of Handler_Desc; + Interrupt_Count : array (Interrupt_ID) of Integer := (others => 0); + + pragma Volatile_Components (Interrupt_Count); + + procedure Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean); + -- This internal procedure is needed to finalize protected objects + -- that contain interrupt handlers. + + procedure Signal_Handler (Sig : Interrupt_ID); + pragma Convention (C, Signal_Handler); + -- This procedure is used to handle all the signals + + -- Type and Head, Tail of the list containing Registered Interrupt + -- Handlers. These definitions are used to register the handlers + -- specified by the pragma Interrupt_Handler. + + -------------------------- + -- Handler Registration -- + -------------------------- + + type Registered_Handler; + type R_Link is access all Registered_Handler; + + type Registered_Handler is record + H : System.Address := System.Null_Address; + Next : R_Link := null; + end record; + + Registered_Handlers : R_Link := null; + + function Is_Registered (Handler : Parameterless_Handler) return Boolean; + -- See if the Handler has been "pragma"ed using Interrupt_Handler. + -- Always consider a null handler as registered. + + type Handler_Ptr is access procedure (Sig : Interrupt_ID); + pragma Convention (C, Handler_Ptr); + + function TISR is new Ada.Unchecked_Conversion (Handler_Ptr, isr_address); + + -------------------- + -- Signal_Handler -- + -------------------- + + procedure Signal_Handler (Sig : Interrupt_ID) is + Handler : Task_Id renames Handlers (Sig); + + begin + if Intr_Attach_Reset and then + intr_attach (int (Sig), TISR (Signal_Handler'Access)) = FUNC_ERR + then + raise Program_Error; + end if; + + if Handler /= null then + Interrupt_Count (Sig) := Interrupt_Count (Sig) + 1; + STPO.Wakeup (Handler, Interrupt_Server_Idle_Sleep); + end if; + end Signal_Handler; + + ----------------- + -- Is_Reserved -- + ----------------- + + function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is + begin + return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt)); + end Is_Reserved; + + ----------------------- + -- Is_Entry_Attached -- + ----------------------- + + function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + return Descriptors (Interrupt).T /= Null_Task; + end Is_Entry_Attached; + + ------------------------- + -- Is_Handler_Attached -- + ------------------------- + + function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + else + return Descriptors (Interrupt).Kind /= Unknown; + end if; + end Is_Handler_Attached; + + ---------------- + -- Is_Ignored -- + ---------------- + + function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is + begin + raise Program_Error; + return False; + end Is_Ignored; + + ------------------ + -- Unblocked_By -- + ------------------ + + function Unblocked_By (Interrupt : Interrupt_ID) return Task_Id is + begin + raise Program_Error; + return Null_Task; + end Unblocked_By; + + ---------------------- + -- Ignore_Interrupt -- + ---------------------- + + procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is + begin + raise Program_Error; + end Ignore_Interrupt; + + ------------------------ + -- Unignore_Interrupt -- + ------------------------ + + procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is + begin + raise Program_Error; + end Unignore_Interrupt; + + ------------------------------------- + -- Has_Interrupt_Or_Attach_Handler -- + ------------------------------------- + + function Has_Interrupt_Or_Attach_Handler + (Object : access Dynamic_Interrupt_Protection) return Boolean + is + pragma Unreferenced (Object); + begin + return True; + end Has_Interrupt_Or_Attach_Handler; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Static_Interrupt_Protection) is + begin + -- ??? loop to be executed only when we're not doing library level + -- finalization, since in this case all interrupt tasks are gone. + + for N in reverse Object.Previous_Handlers'Range loop + Attach_Handler + (New_Handler => Object.Previous_Handlers (N).Handler, + Interrupt => Object.Previous_Handlers (N).Interrupt, + Static => Object.Previous_Handlers (N).Static, + Restoration => True); + end loop; + + Tasking.Protected_Objects.Entries.Finalize + (Tasking.Protected_Objects.Entries.Protection_Entries (Object)); + end Finalize; + + ------------------------------------- + -- Has_Interrupt_Or_Attach_Handler -- + ------------------------------------- + + function Has_Interrupt_Or_Attach_Handler + (Object : access Static_Interrupt_Protection) return Boolean + is + pragma Unreferenced (Object); + begin + return True; + end Has_Interrupt_Or_Attach_Handler; + + ---------------------- + -- Install_Handlers -- + ---------------------- + + procedure Install_Handlers + (Object : access Static_Interrupt_Protection; + New_Handlers : New_Handler_Array) + is + begin + for N in New_Handlers'Range loop + + -- We need a lock around this ??? + + Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt; + Object.Previous_Handlers (N).Static := Descriptors + (New_Handlers (N).Interrupt).Static; + + -- We call Exchange_Handler and not directly Interrupt_Manager. + -- Exchange_Handler so we get the Is_Reserved check. + + Exchange_Handler + (Old_Handler => Object.Previous_Handlers (N).Handler, + New_Handler => New_Handlers (N).Handler, + Interrupt => New_Handlers (N).Interrupt, + Static => True); + end loop; + end Install_Handlers; + + --------------------------------- + -- Install_Restricted_Handlers -- + --------------------------------- + + procedure Install_Restricted_Handlers (Handlers : New_Handler_Array) is + begin + for N in Handlers'Range loop + Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True); + end loop; + end Install_Restricted_Handlers; + + --------------------- + -- Current_Handler -- + --------------------- + + function Current_Handler + (Interrupt : Interrupt_ID) return Parameterless_Handler + is + begin + if Is_Reserved (Interrupt) then + raise Program_Error; + end if; + + if Descriptors (Interrupt).Kind = Protected_Procedure then + return Descriptors (Interrupt).H; + else + return null; + end if; + end Current_Handler; + + -------------------- + -- Attach_Handler -- + -------------------- + + procedure Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False) is + begin + Attach_Handler (New_Handler, Interrupt, Static, False); + end Attach_Handler; + + procedure Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean) + is + New_Task : Server_Task_Access; + + begin + if Is_Reserved (Interrupt) then + raise Program_Error; + end if; + + if not Restoration and then not Static + + -- Tries to overwrite a static Interrupt Handler with dynamic handle + + and then + (Descriptors (Interrupt).Static + + -- New handler not specified as an Interrupt Handler by a pragma + + or else not Is_Registered (New_Handler)) + then + raise Program_Error with + "Trying to overwrite a static Interrupt Handler with a " & + "dynamic Handler"; + end if; + + if Handlers (Interrupt) = null then + New_Task := new Server_Task (Interrupt); + Handlers (Interrupt) := To_System (New_Task.all'Identity); + end if; + + if intr_attach (int (Interrupt), + TISR (Signal_Handler'Access)) = FUNC_ERR + then + raise Program_Error; + end if; + + if New_Handler = null then + + -- The null handler means we are detaching the handler + + Descriptors (Interrupt) := + (Kind => Unknown, T => null, E => 0, H => null, Static => False); + + else + Descriptors (Interrupt).Kind := Protected_Procedure; + Descriptors (Interrupt).H := New_Handler; + Descriptors (Interrupt).Static := Static; + end if; + end Attach_Handler; + + ---------------------- + -- Exchange_Handler -- + ---------------------- + + procedure Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False) + is + begin + if Is_Reserved (Interrupt) then + raise Program_Error; + end if; + + if Descriptors (Interrupt).Kind = Task_Entry then + + -- In case we have an Interrupt Entry already installed. + -- raise a program error. (propagate it to the caller). + + raise Program_Error with "An interrupt is already installed"; + + else + Old_Handler := Current_Handler (Interrupt); + Attach_Handler (New_Handler, Interrupt, Static); + end if; + end Exchange_Handler; + + -------------------- + -- Detach_Handler -- + -------------------- + + procedure Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean := False) + is + begin + if Is_Reserved (Interrupt) then + raise Program_Error; + end if; + + if Descriptors (Interrupt).Kind = Task_Entry then + raise Program_Error with "Trying to detach an Interrupt Entry"; + end if; + + if not Static and then Descriptors (Interrupt).Static then + raise Program_Error with + "Trying to detach a static Interrupt Handler"; + end if; + + Descriptors (Interrupt) := + (Kind => Unknown, T => null, E => 0, H => null, Static => False); + + if intr_attach (int (Interrupt), null) = FUNC_ERR then + raise Program_Error; + end if; + end Detach_Handler; + + --------------- + -- Reference -- + --------------- + + function Reference (Interrupt : Interrupt_ID) return System.Address is + Signal : constant System.Address := + System.Storage_Elements.To_Address + (System.Storage_Elements.Integer_Address (Interrupt)); + + begin + if Is_Reserved (Interrupt) then + + -- Only usable Interrupts can be used for binding it to an Entry + + raise Program_Error; + end if; + + return Signal; + end Reference; + + -------------------------------- + -- Register_Interrupt_Handler -- + -------------------------------- + + procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is + begin + Registered_Handlers := + new Registered_Handler'(H => Handler_Addr, Next => Registered_Handlers); + end Register_Interrupt_Handler; + + ------------------- + -- Is_Registered -- + ------------------- + + -- See if the Handler has been "pragma"ed using Interrupt_Handler. + -- Always consider a null handler as registered. + + function Is_Registered (Handler : Parameterless_Handler) return Boolean is + Ptr : R_Link := Registered_Handlers; + + type Fat_Ptr is record + Object_Addr : System.Address; + Handler_Addr : System.Address; + end record; + + function To_Fat_Ptr is new Ada.Unchecked_Conversion + (Parameterless_Handler, Fat_Ptr); + + Fat : Fat_Ptr; + + begin + if Handler = null then + return True; + end if; + + Fat := To_Fat_Ptr (Handler); + + while Ptr /= null loop + + if Ptr.H = Fat.Handler_Addr then + return True; + end if; + + Ptr := Ptr.Next; + end loop; + + return False; + end Is_Registered; + + ----------------------------- + -- Bind_Interrupt_To_Entry -- + ----------------------------- + + procedure Bind_Interrupt_To_Entry + (T : Task_Id; + E : Task_Entry_Index; + Int_Ref : System.Address) + is + Interrupt : constant Interrupt_ID := + Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); + + New_Task : Server_Task_Access; + + begin + if Is_Reserved (Interrupt) then + raise Program_Error; + end if; + + if Descriptors (Interrupt).Kind /= Unknown then + raise Program_Error with + "A binding for this interrupt is already present"; + end if; + + if Handlers (Interrupt) = null then + New_Task := new Server_Task (Interrupt); + Handlers (Interrupt) := To_System (New_Task.all'Identity); + end if; + + if intr_attach (int (Interrupt), + TISR (Signal_Handler'Access)) = FUNC_ERR + then + raise Program_Error; + end if; + + Descriptors (Interrupt).Kind := Task_Entry; + Descriptors (Interrupt).T := T; + Descriptors (Interrupt).E := E; + + -- Indicate the attachment of Interrupt Entry in ATCB. This is needed so + -- that when an Interrupt Entry task terminates the binding can be + -- cleaned up. The call to unbinding must be make by the task before it + -- terminates. + + T.Interrupt_Entry := True; + end Bind_Interrupt_To_Entry; + + ------------------------------ + -- Detach_Interrupt_Entries -- + ------------------------------ + + procedure Detach_Interrupt_Entries (T : Task_Id) is + begin + for J in Interrupt_ID loop + if not Is_Reserved (J) then + if Descriptors (J).Kind = Task_Entry + and then Descriptors (J).T = T + then + Descriptors (J).Kind := Unknown; + + if intr_attach (int (J), null) = FUNC_ERR then + raise Program_Error; + end if; + end if; + end if; + end loop; + + -- Indicate in ATCB that no Interrupt Entries are attached + + T.Interrupt_Entry := True; + end Detach_Interrupt_Entries; + + --------------------- + -- Block_Interrupt -- + --------------------- + + procedure Block_Interrupt (Interrupt : Interrupt_ID) is + begin + raise Program_Error; + end Block_Interrupt; + + ----------------------- + -- Unblock_Interrupt -- + ----------------------- + + procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is + begin + raise Program_Error; + end Unblock_Interrupt; + + ---------------- + -- Is_Blocked -- + ---------------- + + function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is + begin + raise Program_Error; + return False; + end Is_Blocked; + + task body Server_Task is + Desc : Handler_Desc renames Descriptors (Interrupt); + Self_Id : constant Task_Id := STPO.Self; + Temp : Parameterless_Handler; + + begin + Utilities.Make_Independent; + + loop + while Interrupt_Count (Interrupt) > 0 loop + Interrupt_Count (Interrupt) := Interrupt_Count (Interrupt) - 1; + begin + case Desc.Kind is + when Unknown => + null; + when Task_Entry => + Rendezvous.Call_Simple (Desc.T, Desc.E, Null_Address); + when Protected_Procedure => + Temp := Desc.H; + Temp.all; + end case; + exception + when others => null; + end; + end loop; + + Initialization.Defer_Abort (Self_Id); + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Self_Id); + Self_Id.Common.State := Interrupt_Server_Idle_Sleep; + STPO.Sleep (Self_Id, Interrupt_Server_Idle_Sleep); + Self_Id.Common.State := Runnable; + STPO.Unlock (Self_Id); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + + -- Undefer abort here to allow a window for this task to be aborted + -- at the time of system shutdown. + + end loop; + end Server_Task; + +end System.Interrupts; diff --git a/gcc/ada/s-interr-vms.adb b/gcc/ada/s-interr-vms.adb new file mode 100644 index 000000000..c43b04368 --- /dev/null +++ b/gcc/ada/s-interr-vms.adb @@ -0,0 +1,1128 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T S -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an OpenVMS/Alpha version of this package + +-- Invariants: + +-- Once we associate a Server_Task with an interrupt, the task never +-- goes away, and we never remove the association. + +-- There is no more than one interrupt per Server_Task and no more than +-- one Server_Task per interrupt. + +-- Within this package, the lock L is used to protect the various status +-- tables. If there is a Server_Task associated with an interrupt, we use +-- the per-task lock of the Server_Task instead so that we protect the +-- status between Interrupt_Manager and Server_Task. Protection among +-- service requests are done using User Request to Interrupt_Manager +-- rendezvous. + +with Ada.Task_Identification; +with Ada.Unchecked_Conversion; + +with System.Task_Primitives; +with System.Interrupt_Management; + +with System.Interrupt_Management.Operations; +pragma Elaborate_All (System.Interrupt_Management.Operations); + +with System.Task_Primitives.Operations; +with System.Task_Primitives.Interrupt_Operations; +with System.Storage_Elements; +with System.Tasking.Utilities; + +with System.Tasking.Rendezvous; +pragma Elaborate_All (System.Tasking.Rendezvous); + +with System.Tasking.Initialization; +with System.Parameters; + +package body System.Interrupts is + + use Tasking; + use System.Parameters; + + package POP renames System.Task_Primitives.Operations; + package PIO renames System.Task_Primitives.Interrupt_Operations; + package IMNG renames System.Interrupt_Management; + package IMOP renames System.Interrupt_Management.Operations; + + function To_System is new Ada.Unchecked_Conversion + (Ada.Task_Identification.Task_Id, Task_Id); + + ----------------- + -- Local Tasks -- + ----------------- + + -- WARNING: System.Tasking.Stages performs calls to this task with + -- low-level constructs. Do not change this spec without synchronizing it. + + task Interrupt_Manager is + entry Detach_Interrupt_Entries (T : Task_Id); + + entry Initialize (Mask : IMNG.Interrupt_Mask); + + entry Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False); + + entry Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean); + + entry Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean); + + entry Bind_Interrupt_To_Entry + (T : Task_Id; + E : Task_Entry_Index; + Interrupt : Interrupt_ID); + + entry Block_Interrupt (Interrupt : Interrupt_ID); + + entry Unblock_Interrupt (Interrupt : Interrupt_ID); + + entry Ignore_Interrupt (Interrupt : Interrupt_ID); + + entry Unignore_Interrupt (Interrupt : Interrupt_ID); + + pragma Interrupt_Priority (System.Interrupt_Priority'Last); + end Interrupt_Manager; + + task type Server_Task (Interrupt : Interrupt_ID) is + pragma Priority (System.Interrupt_Priority'Last); + -- Note: the above pragma Priority is strictly speaking improper since + -- it is outside the range of allowed priorities, but the compiler + -- treats system units specially and does not apply this range checking + -- rule to system units. + + end Server_Task; + + type Server_Task_Access is access Server_Task; + + ------------------------------- + -- Local Types and Variables -- + ------------------------------- + + type Entry_Assoc is record + T : Task_Id; + E : Task_Entry_Index; + end record; + + type Handler_Assoc is record + H : Parameterless_Handler; + Static : Boolean; -- Indicates static binding; + end record; + + User_Handler : array (Interrupt_ID'Range) of Handler_Assoc := + (others => (null, Static => False)); + pragma Volatile_Components (User_Handler); + -- Holds the protected procedure handler (if any) and its Static + -- information for each interrupt. A handler is a Static one if it is + -- specified through the pragma Attach_Handler. Attach_Handler. Otherwise, + -- not static) + + User_Entry : array (Interrupt_ID'Range) of Entry_Assoc := + (others => (T => Null_Task, E => Null_Task_Entry)); + pragma Volatile_Components (User_Entry); + -- Holds the task and entry index (if any) for each interrupt + + Blocked : constant array (Interrupt_ID'Range) of Boolean := + (others => False); + -- ??? pragma Volatile_Components (Blocked); + -- True iff the corresponding interrupt is blocked in the process level + + Ignored : array (Interrupt_ID'Range) of Boolean := (others => False); + pragma Volatile_Components (Ignored); + -- True iff the corresponding interrupt is blocked in the process level + + Last_Unblocker : constant array (Interrupt_ID'Range) of Task_Id := + (others => Null_Task); +-- ??? pragma Volatile_Components (Last_Unblocker); + -- Holds the ID of the last Task which Unblocked this Interrupt. + -- It contains Null_Task if no tasks have ever requested the + -- Unblocking operation or the Interrupt is currently Blocked. + + Server_ID : array (Interrupt_ID'Range) of Task_Id := + (others => Null_Task); + pragma Atomic_Components (Server_ID); + -- Holds the Task_Id of the Server_Task for each interrupt. Task_Id is + -- needed to accomplish locking per Interrupt base. Also is needed to + -- decide whether to create a new Server_Task. + + -- Type and Head, Tail of the list containing Registered Interrupt + -- Handlers. These definitions are used to register the handlers specified + -- by the pragma Interrupt_Handler. + + type Registered_Handler; + type R_Link is access all Registered_Handler; + + type Registered_Handler is record + H : System.Address := System.Null_Address; + Next : R_Link := null; + end record; + + Registered_Handler_Head : R_Link := null; + Registered_Handler_Tail : R_Link := null; + + Access_Hold : Server_Task_Access; + -- variable used to allocate Server_Task using "new" + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Is_Registered (Handler : Parameterless_Handler) return Boolean; + -- See if the Handler has been "pragma"ed using Interrupt_Handler. + -- Always consider a null handler as registered. + + -------------------------------- + -- Register_Interrupt_Handler -- + -------------------------------- + + procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is + New_Node_Ptr : R_Link; + + begin + -- This routine registers the Handler as usable for Dynamic + -- Interrupt Handler. Routines attaching and detaching Handler + -- dynamically should first consult if the Handler is registered. + -- A Program Error should be raised if it is not registered. + + -- The pragma Interrupt_Handler can only appear in the library + -- level PO definition and instantiation. Therefore, we do not need + -- to implement Unregistering operation. Neither we need to + -- protect the queue structure using a Lock. + + pragma Assert (Handler_Addr /= System.Null_Address); + + New_Node_Ptr := new Registered_Handler; + New_Node_Ptr.H := Handler_Addr; + + if Registered_Handler_Head = null then + Registered_Handler_Head := New_Node_Ptr; + Registered_Handler_Tail := New_Node_Ptr; + + else + Registered_Handler_Tail.Next := New_Node_Ptr; + Registered_Handler_Tail := New_Node_Ptr; + end if; + end Register_Interrupt_Handler; + + ------------------- + -- Is_Registered -- + ------------------- + + function Is_Registered (Handler : Parameterless_Handler) return Boolean is + type Fat_Ptr is record + Object_Addr : System.Address; + Handler_Addr : System.Address; + end record; + + function To_Fat_Ptr is new Ada.Unchecked_Conversion + (Parameterless_Handler, Fat_Ptr); + + Ptr : R_Link; + Fat : Fat_Ptr; + + begin + if Handler = null then + return True; + end if; + + Fat := To_Fat_Ptr (Handler); + + Ptr := Registered_Handler_Head; + + while Ptr /= null loop + if Ptr.H = Fat.Handler_Addr then + return True; + end if; + + Ptr := Ptr.Next; + end loop; + + return False; + end Is_Registered; + + ----------------- + -- Is_Reserved -- + ----------------- + + function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is + begin + return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt)); + end Is_Reserved; + + ----------------------- + -- Is_Entry_Attached -- + ----------------------- + + function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + return User_Entry (Interrupt).T /= Null_Task; + end Is_Entry_Attached; + + ------------------------- + -- Is_Handler_Attached -- + ------------------------- + + function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + return User_Handler (Interrupt).H /= null; + end Is_Handler_Attached; + + ---------------- + -- Is_Blocked -- + ---------------- + + function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + return Blocked (Interrupt); + end Is_Blocked; + + ---------------- + -- Is_Ignored -- + ---------------- + + function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + return Ignored (Interrupt); + end Is_Ignored; + + --------------------- + -- Current_Handler -- + --------------------- + + function Current_Handler + (Interrupt : Interrupt_ID) return Parameterless_Handler + is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + -- ??? Since Parameterless_Handler is not Atomic, the current + -- implementation is wrong. We need a new service in Interrupt_Manager + -- to ensure atomicity. + + return User_Handler (Interrupt).H; + end Current_Handler; + + -------------------- + -- Attach_Handler -- + -------------------- + + -- Calling this procedure with New_Handler = null and Static = True + -- means we want to detach the current handler regardless of the + -- previous handler's binding status (i.e. do not care if it is a + -- dynamic or static handler). + + -- This option is needed so that during the finalization of a PO, we + -- can detach handlers attached through pragma Attach_Handler. + + procedure Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False) is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static); + + end Attach_Handler; + + ---------------------- + -- Exchange_Handler -- + ---------------------- + + -- Calling this procedure with New_Handler = null and Static = True means + -- we want to detach the current handler regardless of the previous + -- handler's binding status (i.e. do not care if it is dynamic or static + -- handler). + + -- This option is needed so that during the finalization of a PO, we can + -- detach handlers attached through pragma Attach_Handler. + + procedure Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False) + is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + Interrupt_Manager.Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static); + + end Exchange_Handler; + + -------------------- + -- Detach_Handler -- + -------------------- + + -- Calling this procedure with Static = True means we want to Detach the + -- current handler regardless of the previous handler's binding status + -- (i.e. do not care if it is a dynamic or static handler). + + -- This option is needed so that during the finalization of a PO, we can + -- detach handlers attached through pragma Attach_Handler. + + procedure Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean := False) + is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + Interrupt_Manager.Detach_Handler (Interrupt, Static); + end Detach_Handler; + + --------------- + -- Reference -- + --------------- + + function Reference (Interrupt : Interrupt_ID) return System.Address is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + return Storage_Elements.To_Address + (Storage_Elements.Integer_Address (Interrupt)); + end Reference; + + ----------------------------- + -- Bind_Interrupt_To_Entry -- + ----------------------------- + + -- This procedure raises a Program_Error if it tries to + -- bind an interrupt to which an Entry or a Procedure is + -- already bound. + + procedure Bind_Interrupt_To_Entry + (T : Task_Id; + E : Task_Entry_Index; + Int_Ref : System.Address) + is + Interrupt : constant Interrupt_ID := + Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); + + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt); + + end Bind_Interrupt_To_Entry; + + ------------------------------ + -- Detach_Interrupt_Entries -- + ------------------------------ + + procedure Detach_Interrupt_Entries (T : Task_Id) is + begin + Interrupt_Manager.Detach_Interrupt_Entries (T); + end Detach_Interrupt_Entries; + + --------------------- + -- Block_Interrupt -- + --------------------- + + procedure Block_Interrupt (Interrupt : Interrupt_ID) is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + Interrupt_Manager.Block_Interrupt (Interrupt); + end Block_Interrupt; + + ----------------------- + -- Unblock_Interrupt -- + ----------------------- + + procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + Interrupt_Manager.Unblock_Interrupt (Interrupt); + end Unblock_Interrupt; + + ------------------ + -- Unblocked_By -- + ------------------ + + function Unblocked_By + (Interrupt : Interrupt_ID) return System.Tasking.Task_Id is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + return Last_Unblocker (Interrupt); + end Unblocked_By; + + ---------------------- + -- Ignore_Interrupt -- + ---------------------- + + procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + Interrupt_Manager.Ignore_Interrupt (Interrupt); + end Ignore_Interrupt; + + ------------------------ + -- Unignore_Interrupt -- + ------------------------ + + procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + Interrupt_Manager.Unignore_Interrupt (Interrupt); + end Unignore_Interrupt; + + ----------------------- + -- Interrupt_Manager -- + ----------------------- + + task body Interrupt_Manager is + + -------------------- + -- Local Routines -- + -------------------- + + procedure Unprotected_Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False); + + procedure Unprotected_Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean); + + ---------------------------------- + -- Unprotected_Exchange_Handler -- + ---------------------------------- + + procedure Unprotected_Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False) + is + begin + if User_Entry (Interrupt).T /= Null_Task then + + -- In case we have an Interrupt Entry already installed. + -- raise a program error. (propagate it to the caller). + + raise Program_Error with "An interrupt is already installed"; + end if; + + -- Note: A null handler with Static=True will pass the following + -- check. That is the case when we want to Detach a handler + -- regardless of the Static status of the current_Handler. We don't + -- check anything if Restoration is True, since we may be detaching + -- a static handler to restore a dynamic one. + + if not Restoration and then not Static + + -- Tries to overwrite a static Interrupt Handler with a + -- dynamic Handler + + and then (User_Handler (Interrupt).Static + + -- The new handler is not specified as an + -- Interrupt Handler by a pragma. + + or else not Is_Registered (New_Handler)) + then + raise Program_Error with + "Trying to overwrite a static Interrupt Handler with a " & + "dynamic Handler"; + end if; + + -- The interrupt should no longer be ignored if it was ever ignored + + Ignored (Interrupt) := False; + + -- Save the old handler + + Old_Handler := User_Handler (Interrupt).H; + + -- The new handler + + User_Handler (Interrupt).H := New_Handler; + + if New_Handler = null then + + -- The null handler means we are detaching the handler + + User_Handler (Interrupt).Static := False; + + else + User_Handler (Interrupt).Static := Static; + end if; + + -- Invoke a corresponding Server_Task if not yet created. + -- Place Task_Id info in Server_ID array. + + if Server_ID (Interrupt) = Null_Task then + Access_Hold := new Server_Task (Interrupt); + Server_ID (Interrupt) := To_System (Access_Hold.all'Identity); + else + POP.Wakeup (Server_ID (Interrupt), Interrupt_Server_Idle_Sleep); + end if; + + end Unprotected_Exchange_Handler; + + -------------------------------- + -- Unprotected_Detach_Handler -- + -------------------------------- + + procedure Unprotected_Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean) + is + begin + if User_Entry (Interrupt).T /= Null_Task then + + -- In case we have an Interrupt Entry installed. + -- raise a program error. (propagate it to the caller). + + raise Program_Error with + "An interrupt entry is already installed"; + end if; + + -- Note : Static = True will pass the following check. That is the + -- case when we want to detach a handler regardless of the static + -- status of the current_Handler. + + if not Static and then User_Handler (Interrupt).Static then + -- Tries to detach a static Interrupt Handler. + -- raise a program error. + + raise Program_Error with + "Trying to detach a static Interrupt Handler"; + end if; + + -- The interrupt should no longer be ignored if + -- it was ever ignored. + + Ignored (Interrupt) := False; + + -- The new handler + + User_Handler (Interrupt).H := null; + User_Handler (Interrupt).Static := False; + IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (Interrupt)); + + end Unprotected_Detach_Handler; + + -- Start of processing for Interrupt_Manager + + begin + -- By making this task independent of master, when the process + -- goes away, the Interrupt_Manager will terminate gracefully. + + System.Tasking.Utilities.Make_Independent; + + -- Environment task gets its own interrupt mask, saves it, + -- and then masks all interrupts except the Keep_Unmasked set. + + -- During rendezvous, the Interrupt_Manager receives the old + -- interrupt mask of the environment task, and sets its own + -- interrupt mask to that value. + + -- The environment task will call the entry of Interrupt_Manager some + -- during elaboration of the body of this package. + + accept Initialize (Mask : IMNG.Interrupt_Mask) do + pragma Warnings (Off, Mask); + null; + end Initialize; + + -- Note: All tasks in RTS will have all the Reserve Interrupts + -- being masked (except the Interrupt_Manager) and Keep_Unmasked + -- unmasked when created. + + -- Abort_Task_Interrupt is one of the Interrupt unmasked + -- in all tasks. We mask the Interrupt in this particular task + -- so that "sigwait" is possible to catch an explicitly sent + -- Abort_Task_Interrupt from the Server_Tasks. + + -- This sigwaiting is needed so that we make sure a Server_Task is + -- out of its own sigwait state. This extra synchronization is + -- necessary to prevent following scenarios. + + -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the + -- Server_Task then changes its own interrupt mask (OS level). + -- If an interrupt (corresponding to the Server_Task) arrives + -- in the mean time we have the Interrupt_Manager unmasked and + -- the Server_Task waiting on sigwait. + + -- 2) For unbinding handler, we install a default action in the + -- Interrupt_Manager. POSIX.1c states that the result of using + -- "sigwait" and "sigaction" simultaneously on the same interrupt + -- is undefined. Therefore, we need to be informed from the + -- Server_Task of the fact that the Server_Task is out of its + -- sigwait stage. + + loop + -- A block is needed to absorb Program_Error exception + + declare + Old_Handler : Parameterless_Handler; + begin + select + + accept Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False) + do + Unprotected_Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static, Restoration); + end Attach_Handler; + + or accept Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean) + do + Unprotected_Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static); + end Exchange_Handler; + + or accept Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean) + do + Unprotected_Detach_Handler (Interrupt, Static); + end Detach_Handler; + + or accept Bind_Interrupt_To_Entry + (T : Task_Id; + E : Task_Entry_Index; + Interrupt : Interrupt_ID) + do + -- if there is a binding already (either a procedure or an + -- entry), raise Program_Error (propagate it to the caller). + + if User_Handler (Interrupt).H /= null + or else User_Entry (Interrupt).T /= Null_Task + then + raise Program_Error with + "A binding for this interrupt is already present"; + end if; + + -- The interrupt should no longer be ignored if + -- it was ever ignored. + + Ignored (Interrupt) := False; + User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E); + + -- Indicate the attachment of Interrupt Entry in ATCB. + -- This is need so that when an Interrupt Entry task + -- terminates the binding can be cleaned. + -- The call to unbinding must be + -- make by the task before it terminates. + + T.Interrupt_Entry := True; + + -- Invoke a corresponding Server_Task if not yet created. + -- Place Task_Id info in Server_ID array. + + if Server_ID (Interrupt) = Null_Task then + + Access_Hold := new Server_Task (Interrupt); + Server_ID (Interrupt) := + To_System (Access_Hold.all'Identity); + else + POP.Wakeup (Server_ID (Interrupt), + Interrupt_Server_Idle_Sleep); + end if; + end Bind_Interrupt_To_Entry; + + or accept Detach_Interrupt_Entries (T : Task_Id) + do + for J in Interrupt_ID'Range loop + if not Is_Reserved (J) then + if User_Entry (J).T = T then + + -- The interrupt should no longer be ignored if + -- it was ever ignored. + + Ignored (J) := False; + User_Entry (J) := + Entry_Assoc'(T => Null_Task, E => Null_Task_Entry); + IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (J)); + end if; + end if; + end loop; + + -- Indicate in ATCB that no Interrupt Entries are attached + + T.Interrupt_Entry := False; + end Detach_Interrupt_Entries; + + or accept Block_Interrupt (Interrupt : Interrupt_ID) do + pragma Warnings (Off, Interrupt); + raise Program_Error; + end Block_Interrupt; + + or accept Unblock_Interrupt (Interrupt : Interrupt_ID) do + pragma Warnings (Off, Interrupt); + raise Program_Error; + end Unblock_Interrupt; + + or accept Ignore_Interrupt (Interrupt : Interrupt_ID) do + pragma Warnings (Off, Interrupt); + raise Program_Error; + end Ignore_Interrupt; + + or accept Unignore_Interrupt (Interrupt : Interrupt_ID) do + pragma Warnings (Off, Interrupt); + raise Program_Error; + end Unignore_Interrupt; + + end select; + + exception + -- If there is a program error we just want to propagate it + -- to the caller and do not want to stop this task. + + when Program_Error => + null; + + when others => + pragma Assert (False); + null; + end; + end loop; + end Interrupt_Manager; + + ----------------- + -- Server_Task -- + ----------------- + + task body Server_Task is + Self_ID : constant Task_Id := Self; + Tmp_Handler : Parameterless_Handler; + Tmp_ID : Task_Id; + Tmp_Entry_Index : Task_Entry_Index; + Intwait_Mask : aliased IMNG.Interrupt_Mask; + + begin + -- By making this task independent of master, when the process + -- goes away, the Server_Task will terminate gracefully. + + System.Tasking.Utilities.Make_Independent; + + -- Install default action in system level + + IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); + + -- Set up the mask (also clears the event flag) + + IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access); + IMOP.Add_To_Interrupt_Mask + (Intwait_Mask'Access, IMNG.Interrupt_ID (Interrupt)); + + -- Remember the Interrupt_ID for Abort_Task + + PIO.Set_Interrupt_ID (IMNG.Interrupt_ID (Interrupt), Self_ID); + + -- Note: All tasks in RTS will have all the Reserve Interrupts + -- being masked (except the Interrupt_Manager) and Keep_Unmasked + -- unmasked when created. + + loop + System.Tasking.Initialization.Defer_Abort (Self_ID); + + -- A Handler or an Entry is installed. At this point all tasks + -- mask for the Interrupt is masked. Catch the Interrupt using + -- sigwait. + + -- This task may wake up from sigwait by receiving an interrupt + -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding + -- a Procedure Handler or an Entry. Or it could be a wake up + -- from status change (Unblocked -> Blocked). If that is not + -- the case, we should execute the attached Procedure or Entry. + + if Single_Lock then + POP.Lock_RTS; + end if; + + POP.Write_Lock (Self_ID); + + if User_Handler (Interrupt).H = null + and then User_Entry (Interrupt).T = Null_Task + then + -- No Interrupt binding. If there is an interrupt, + -- Interrupt_Manager will take default action. + + Self_ID.Common.State := Interrupt_Server_Idle_Sleep; + POP.Sleep (Self_ID, Interrupt_Server_Idle_Sleep); + Self_ID.Common.State := Runnable; + + else + Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag; + Self_ID.Common.State := Runnable; + + if not (Self_ID.Deferral_Level = 0 + and then Self_ID.Pending_ATC_Level + < Self_ID.ATC_Nesting_Level) + then + if User_Handler (Interrupt).H /= null then + Tmp_Handler := User_Handler (Interrupt).H; + + -- RTS calls should not be made with self being locked + + POP.Unlock (Self_ID); + + if Single_Lock then + POP.Unlock_RTS; + end if; + + Tmp_Handler.all; + + if Single_Lock then + POP.Lock_RTS; + end if; + + POP.Write_Lock (Self_ID); + + elsif User_Entry (Interrupt).T /= Null_Task then + Tmp_ID := User_Entry (Interrupt).T; + Tmp_Entry_Index := User_Entry (Interrupt).E; + + -- RTS calls should not be made with self being locked + + POP.Unlock (Self_ID); + + if Single_Lock then + POP.Unlock_RTS; + end if; + + System.Tasking.Rendezvous.Call_Simple + (Tmp_ID, Tmp_Entry_Index, System.Null_Address); + + if Single_Lock then + POP.Lock_RTS; + end if; + + POP.Write_Lock (Self_ID); + end if; + end if; + end if; + + POP.Unlock (Self_ID); + + if Single_Lock then + POP.Unlock_RTS; + end if; + + System.Tasking.Initialization.Undefer_Abort (Self_ID); + + -- Undefer abort here to allow a window for this task + -- to be aborted at the time of system shutdown. + end loop; + end Server_Task; + + ------------------------------------- + -- Has_Interrupt_Or_Attach_Handler -- + ------------------------------------- + + function Has_Interrupt_Or_Attach_Handler + (Object : access Dynamic_Interrupt_Protection) return Boolean + is + pragma Warnings (Off, Object); + + begin + return True; + end Has_Interrupt_Or_Attach_Handler; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Static_Interrupt_Protection) is + begin + -- ??? loop to be executed only when we're not doing library level + -- finalization, since in this case all interrupt tasks are gone. + + if not Interrupt_Manager'Terminated then + for N in reverse Object.Previous_Handlers'Range loop + Interrupt_Manager.Attach_Handler + (New_Handler => Object.Previous_Handlers (N).Handler, + Interrupt => Object.Previous_Handlers (N).Interrupt, + Static => Object.Previous_Handlers (N).Static, + Restoration => True); + end loop; + end if; + + Tasking.Protected_Objects.Entries.Finalize + (Tasking.Protected_Objects.Entries.Protection_Entries (Object)); + end Finalize; + + ------------------------------------- + -- Has_Interrupt_Or_Attach_Handler -- + ------------------------------------- + + function Has_Interrupt_Or_Attach_Handler + (Object : access Static_Interrupt_Protection) return Boolean + is + pragma Warnings (Off, Object); + begin + return True; + end Has_Interrupt_Or_Attach_Handler; + + ---------------------- + -- Install_Handlers -- + ---------------------- + + procedure Install_Handlers + (Object : access Static_Interrupt_Protection; + New_Handlers : New_Handler_Array) + is + begin + for N in New_Handlers'Range loop + + -- We need a lock around this ??? + + Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt; + Object.Previous_Handlers (N).Static := User_Handler + (New_Handlers (N).Interrupt).Static; + + -- We call Exchange_Handler and not directly Interrupt_Manager. + -- Exchange_Handler so we get the Is_Reserved check. + + Exchange_Handler + (Old_Handler => Object.Previous_Handlers (N).Handler, + New_Handler => New_Handlers (N).Handler, + Interrupt => New_Handlers (N).Interrupt, + Static => True); + end loop; + end Install_Handlers; + + --------------------------------- + -- Install_Restricted_Handlers -- + --------------------------------- + + procedure Install_Restricted_Handlers (Handlers : New_Handler_Array) is + begin + for N in Handlers'Range loop + Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True); + end loop; + end Install_Restricted_Handlers; + +-- Elaboration code for package System.Interrupts + +begin + -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent + + Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity); + + -- During the elaboration of this package body we want RTS to inherit the + -- interrupt mask from the Environment Task. + + -- The Environment Task should have gotten its mask from the enclosing + -- process during the RTS start up. (See in s-inmaop.adb). Pass the + -- Interrupt_Mask of the Environment task to the Interrupt_Manager. + + -- Note : At this point we know that all tasks (including RTS internal + -- servers) are masked for non-reserved signals (see s-taprop.adb). Only + -- the Interrupt_Manager will have masks set up differently inheriting the + -- original Environment Task's mask. + + Interrupt_Manager.Initialize (IMOP.Environment_Mask); +end System.Interrupts; diff --git a/gcc/ada/s-interr.adb b/gcc/ada/s-interr.adb new file mode 100644 index 000000000..3d33f6c9e --- /dev/null +++ b/gcc/ada/s-interr.adb @@ -0,0 +1,1467 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T S -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Invariants: + +-- All user-handleable interrupts are masked at all times in all +-- tasks/threads except possibly for the Interrupt_Manager task. + +-- When a user task wants to have the effect of masking/unmasking an +-- interrupt, it must call Block_Interrupt/Unblock_Interrupt, which +-- will have the effect of unmasking/masking the interrupt in the +-- Interrupt_Manager task. + +-- Note : Direct calls to sigaction, sigprocmask, pthread_sigsetmask or any +-- other low-level interface that changes the interrupt action or +-- interrupt mask needs a careful thought. +-- One may achieve the effect of system calls first masking RTS blocked +-- (by calling Block_Interrupt) for the interrupt under consideration. +-- This will make all the tasks in RTS blocked for the Interrupt. + +-- Once we associate a Server_Task with an interrupt, the task never +-- goes away, and we never remove the association. + +-- There is no more than one interrupt per Server_Task and no more than +-- one Server_Task per interrupt. + +with Ada.Task_Identification; + +with System.Task_Primitives; +with System.Interrupt_Management; + +with System.Interrupt_Management.Operations; +pragma Elaborate_All (System.Interrupt_Management.Operations); + +with System.Task_Primitives.Operations; +with System.Task_Primitives.Interrupt_Operations; +with System.Storage_Elements; +with System.Tasking.Utilities; + +with System.Tasking.Rendezvous; +pragma Elaborate_All (System.Tasking.Rendezvous); + +with System.Tasking.Initialization; +with System.Parameters; + +with Ada.Unchecked_Conversion; + +package body System.Interrupts is + + use Parameters; + use Tasking; + + package POP renames System.Task_Primitives.Operations; + package PIO renames System.Task_Primitives.Interrupt_Operations; + package IMNG renames System.Interrupt_Management; + package IMOP renames System.Interrupt_Management.Operations; + + function To_System is new Ada.Unchecked_Conversion + (Ada.Task_Identification.Task_Id, Task_Id); + + ----------------- + -- Local Tasks -- + ----------------- + + -- WARNING: System.Tasking.Stages performs calls to this task with + -- low-level constructs. Do not change this spec without synchronizing it. + + task Interrupt_Manager is + entry Detach_Interrupt_Entries (T : Task_Id); + + entry Initialize (Mask : IMNG.Interrupt_Mask); + + entry Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False); + + entry Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean); + + entry Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean); + + entry Bind_Interrupt_To_Entry + (T : Task_Id; + E : Task_Entry_Index; + Interrupt : Interrupt_ID); + + entry Block_Interrupt (Interrupt : Interrupt_ID); + + entry Unblock_Interrupt (Interrupt : Interrupt_ID); + + entry Ignore_Interrupt (Interrupt : Interrupt_ID); + + entry Unignore_Interrupt (Interrupt : Interrupt_ID); + + pragma Interrupt_Priority (System.Interrupt_Priority'Last); + end Interrupt_Manager; + + task type Server_Task (Interrupt : Interrupt_ID) is + pragma Priority (System.Interrupt_Priority'Last); + -- Note: the above pragma Priority is strictly speaking improper since + -- it is outside the range of allowed priorities, but the compiler + -- treats system units specially and does not apply this range checking + -- rule to system units. + + end Server_Task; + + type Server_Task_Access is access Server_Task; + + ------------------------------- + -- Local Types and Variables -- + ------------------------------- + + type Entry_Assoc is record + T : Task_Id; + E : Task_Entry_Index; + end record; + + type Handler_Assoc is record + H : Parameterless_Handler; + Static : Boolean; -- Indicates static binding; + end record; + + User_Handler : array (Interrupt_ID'Range) of Handler_Assoc := + (others => (null, Static => False)); + pragma Volatile_Components (User_Handler); + -- Holds the protected procedure handler (if any) and its Static + -- information for each interrupt. A handler is a Static one if it is + -- specified through the pragma Attach_Handler. Attach_Handler. Otherwise, + -- not static) + + User_Entry : array (Interrupt_ID'Range) of Entry_Assoc := + (others => (T => Null_Task, E => Null_Task_Entry)); + pragma Volatile_Components (User_Entry); + -- Holds the task and entry index (if any) for each interrupt + + Blocked : array (Interrupt_ID'Range) of Boolean := (others => False); + pragma Atomic_Components (Blocked); + -- True iff the corresponding interrupt is blocked in the process level + + Ignored : array (Interrupt_ID'Range) of Boolean := (others => False); + pragma Atomic_Components (Ignored); + -- True iff the corresponding interrupt is blocked in the process level + + Last_Unblocker : + array (Interrupt_ID'Range) of Task_Id := (others => Null_Task); + pragma Atomic_Components (Last_Unblocker); + -- Holds the ID of the last Task which Unblocked this Interrupt. It + -- contains Null_Task if no tasks have ever requested the Unblocking + -- operation or the Interrupt is currently Blocked. + + Server_ID : array (Interrupt_ID'Range) of Task_Id := + (others => Null_Task); + pragma Atomic_Components (Server_ID); + -- Holds the Task_Id of the Server_Task for each interrupt. Task_Id is + -- needed to accomplish locking per Interrupt base. Also is needed to + -- decide whether to create a new Server_Task. + + -- Type and Head, Tail of the list containing Registered Interrupt + -- Handlers. These definitions are used to register the handlers + -- specified by the pragma Interrupt_Handler. + + type Registered_Handler; + type R_Link is access all Registered_Handler; + + type Registered_Handler is record + H : System.Address := System.Null_Address; + Next : R_Link := null; + end record; + + Registered_Handler_Head : R_Link := null; + Registered_Handler_Tail : R_Link := null; + + Access_Hold : Server_Task_Access; + -- Variable used to allocate Server_Task using "new" + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Is_Registered (Handler : Parameterless_Handler) return Boolean; + -- See if the Handler has been "pragma"ed using Interrupt_Handler. Always + -- consider a null handler as registered. + + -------------------- + -- Attach_Handler -- + -------------------- + + -- Calling this procedure with New_Handler = null and Static = True means + -- we want to detach the current handler regardless of the previous + -- handler's binding status (i.e. do not care if it is a dynamic or static + -- handler). + + -- This option is needed so that during the finalization of a PO, we can + -- detach handlers attached through pragma Attach_Handler. + + procedure Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False) + is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static); + + end Attach_Handler; + + ----------------------------- + -- Bind_Interrupt_To_Entry -- + ----------------------------- + + -- This procedure raises a Program_Error if it tries to bind an interrupt + -- to which an Entry or a Procedure is already bound. + + procedure Bind_Interrupt_To_Entry + (T : Task_Id; + E : Task_Entry_Index; + Int_Ref : System.Address) + is + Interrupt : constant Interrupt_ID := + Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); + + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt); + end Bind_Interrupt_To_Entry; + + --------------------- + -- Block_Interrupt -- + --------------------- + + procedure Block_Interrupt (Interrupt : Interrupt_ID) is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + Interrupt_Manager.Block_Interrupt (Interrupt); + end Block_Interrupt; + + --------------------- + -- Current_Handler -- + --------------------- + + function Current_Handler + (Interrupt : Interrupt_ID) return Parameterless_Handler + is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + -- ??? Since Parameterless_Handler is not Atomic, the current + -- implementation is wrong. We need a new service in Interrupt_Manager + -- to ensure atomicity. + + return User_Handler (Interrupt).H; + end Current_Handler; + + -------------------- + -- Detach_Handler -- + -------------------- + + -- Calling this procedure with Static = True means we want to Detach the + -- current handler regardless of the previous handler's binding status + -- (i.e. do not care if it is a dynamic or static handler). + + -- This option is needed so that during the finalization of a PO, we can + -- detach handlers attached through pragma Attach_Handler. + + procedure Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean := False) + is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + Interrupt_Manager.Detach_Handler (Interrupt, Static); + end Detach_Handler; + + ------------------------------ + -- Detach_Interrupt_Entries -- + ------------------------------ + + procedure Detach_Interrupt_Entries (T : Task_Id) is + begin + Interrupt_Manager.Detach_Interrupt_Entries (T); + end Detach_Interrupt_Entries; + + ---------------------- + -- Exchange_Handler -- + ---------------------- + + -- Calling this procedure with New_Handler = null and Static = True means + -- we want to detach the current handler regardless of the previous + -- handler's binding status (i.e. do not care if it is a dynamic or static + -- handler). + + -- This option is needed so that during the finalization of a PO, we can + -- detach handlers attached through pragma Attach_Handler. + + procedure Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False) + is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + Interrupt_Manager.Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static); + end Exchange_Handler; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Static_Interrupt_Protection) is + function State + (Int : System.Interrupt_Management.Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state for interrupt number Int. Defined in init.c + + Default : constant Character := 's'; + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + + begin + -- ??? loop to be executed only when we're not doing library level + -- finalization, since in this case all interrupt tasks are gone. + + -- If the Abort_Task signal is set to system, it means that we cannot + -- reset interrupt handlers since this would require sending the abort + -- signal to the Server_Task + + if not Interrupt_Manager'Terminated + and then State (System.Interrupt_Management.Abort_Task_Interrupt) + /= Default + then + for N in reverse Object.Previous_Handlers'Range loop + Interrupt_Manager.Attach_Handler + (New_Handler => Object.Previous_Handlers (N).Handler, + Interrupt => Object.Previous_Handlers (N).Interrupt, + Static => Object.Previous_Handlers (N).Static, + Restoration => True); + end loop; + end if; + + Tasking.Protected_Objects.Entries.Finalize + (Tasking.Protected_Objects.Entries.Protection_Entries (Object)); + end Finalize; + + ------------------------------------- + -- Has_Interrupt_Or_Attach_Handler -- + ------------------------------------- + + -- Need comments as to why these always return True ??? + + function Has_Interrupt_Or_Attach_Handler + (Object : access Dynamic_Interrupt_Protection) return Boolean + is + pragma Unreferenced (Object); + begin + return True; + end Has_Interrupt_Or_Attach_Handler; + + function Has_Interrupt_Or_Attach_Handler + (Object : access Static_Interrupt_Protection) return Boolean + is + pragma Unreferenced (Object); + begin + return True; + end Has_Interrupt_Or_Attach_Handler; + + ---------------------- + -- Ignore_Interrupt -- + ---------------------- + + procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + Interrupt_Manager.Ignore_Interrupt (Interrupt); + end Ignore_Interrupt; + + ---------------------- + -- Install_Handlers -- + ---------------------- + + procedure Install_Handlers + (Object : access Static_Interrupt_Protection; + New_Handlers : New_Handler_Array) + is + begin + for N in New_Handlers'Range loop + + -- We need a lock around this ??? + + Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt; + Object.Previous_Handlers (N).Static := User_Handler + (New_Handlers (N).Interrupt).Static; + + -- We call Exchange_Handler and not directly Interrupt_Manager. + -- Exchange_Handler so we get the Is_Reserved check. + + Exchange_Handler + (Old_Handler => Object.Previous_Handlers (N).Handler, + New_Handler => New_Handlers (N).Handler, + Interrupt => New_Handlers (N).Interrupt, + Static => True); + end loop; + end Install_Handlers; + + --------------------------------- + -- Install_Restricted_Handlers -- + --------------------------------- + + procedure Install_Restricted_Handlers (Handlers : New_Handler_Array) is + begin + for N in Handlers'Range loop + Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True); + end loop; + end Install_Restricted_Handlers; + + ---------------- + -- Is_Blocked -- + ---------------- + + function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + return Blocked (Interrupt); + end Is_Blocked; + + ----------------------- + -- Is_Entry_Attached -- + ----------------------- + + function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + return User_Entry (Interrupt).T /= Null_Task; + end Is_Entry_Attached; + + ------------------------- + -- Is_Handler_Attached -- + ------------------------- + + function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + return User_Handler (Interrupt).H /= null; + end Is_Handler_Attached; + + ---------------- + -- Is_Ignored -- + ---------------- + + function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + return Ignored (Interrupt); + end Is_Ignored; + + ------------------- + -- Is_Registered -- + ------------------- + + function Is_Registered (Handler : Parameterless_Handler) return Boolean is + + type Fat_Ptr is record + Object_Addr : System.Address; + Handler_Addr : System.Address; + end record; + + function To_Fat_Ptr is new Ada.Unchecked_Conversion + (Parameterless_Handler, Fat_Ptr); + + Ptr : R_Link; + Fat : Fat_Ptr; + + begin + if Handler = null then + return True; + end if; + + Fat := To_Fat_Ptr (Handler); + + Ptr := Registered_Handler_Head; + + while Ptr /= null loop + if Ptr.H = Fat.Handler_Addr then + return True; + end if; + + Ptr := Ptr.Next; + end loop; + + return False; + end Is_Registered; + + ----------------- + -- Is_Reserved -- + ----------------- + + function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is + begin + return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt)); + end Is_Reserved; + + --------------- + -- Reference -- + --------------- + + function Reference (Interrupt : Interrupt_ID) return System.Address is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + return Storage_Elements.To_Address + (Storage_Elements.Integer_Address (Interrupt)); + end Reference; + + --------------------------------- + -- Register_Interrupt_Handler -- + --------------------------------- + + procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is + New_Node_Ptr : R_Link; + + begin + -- This routine registers the Handler as usable for Dynamic Interrupt + -- Handler. Routines attaching and detaching Handler dynamically should + -- first consult if the Handler is registered. A Program Error should + -- be raised if it is not registered. + + -- The pragma Interrupt_Handler can only appear in the library level PO + -- definition and instantiation. Therefore, we do not need to implement + -- Unregistering operation. Neither we need to protect the queue + -- structure using a Lock. + + pragma Assert (Handler_Addr /= System.Null_Address); + + New_Node_Ptr := new Registered_Handler; + New_Node_Ptr.H := Handler_Addr; + + if Registered_Handler_Head = null then + Registered_Handler_Head := New_Node_Ptr; + Registered_Handler_Tail := New_Node_Ptr; + + else + Registered_Handler_Tail.Next := New_Node_Ptr; + Registered_Handler_Tail := New_Node_Ptr; + end if; + end Register_Interrupt_Handler; + + ----------------------- + -- Unblock_Interrupt -- + ----------------------- + + procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + Interrupt_Manager.Unblock_Interrupt (Interrupt); + end Unblock_Interrupt; + + ------------------ + -- Unblocked_By -- + ------------------ + + function Unblocked_By + (Interrupt : Interrupt_ID) return System.Tasking.Task_Id + is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + return Last_Unblocker (Interrupt); + end Unblocked_By; + + ------------------------ + -- Unignore_Interrupt -- + ------------------------ + + procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + Interrupt_Manager.Unignore_Interrupt (Interrupt); + end Unignore_Interrupt; + + ----------------------- + -- Interrupt_Manager -- + ----------------------- + + task body Interrupt_Manager is + + --------------------- + -- Local Variables -- + --------------------- + + Intwait_Mask : aliased IMNG.Interrupt_Mask; + Ret_Interrupt : Interrupt_ID; + Old_Mask : aliased IMNG.Interrupt_Mask; + Old_Handler : Parameterless_Handler; + + -------------------- + -- Local Routines -- + -------------------- + + procedure Bind_Handler (Interrupt : Interrupt_ID); + -- This procedure does not do anything if the Interrupt is blocked. + -- Otherwise, we have to interrupt Server_Task for status change through + -- Wakeup interrupt. + + procedure Unbind_Handler (Interrupt : Interrupt_ID); + -- This procedure does not do anything if the Interrupt is blocked. + -- Otherwise, we have to interrupt Server_Task for status change + -- through abort interrupt. + + procedure Unprotected_Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False); + + procedure Unprotected_Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean); + + ------------------ + -- Bind_Handler -- + ------------------ + + procedure Bind_Handler (Interrupt : Interrupt_ID) is + begin + if not Blocked (Interrupt) then + + -- Mask this task for the given Interrupt so that all tasks + -- are masked for the Interrupt and the actual delivery of the + -- Interrupt will be caught using "sigwait" by the + -- corresponding Server_Task. + + IMOP.Thread_Block_Interrupt (IMNG.Interrupt_ID (Interrupt)); + + -- We have installed a Handler or an Entry before we called + -- this procedure. If the Handler Task is waiting to be awakened, + -- do it here. Otherwise, the interrupt will be discarded. + + POP.Wakeup (Server_ID (Interrupt), Interrupt_Server_Idle_Sleep); + end if; + end Bind_Handler; + + -------------------- + -- Unbind_Handler -- + -------------------- + + procedure Unbind_Handler (Interrupt : Interrupt_ID) is + Server : System.Tasking.Task_Id; + begin + if not Blocked (Interrupt) then + -- Currently, there is a Handler or an Entry attached and + -- corresponding Server_Task is waiting on "sigwait." + -- We have to wake up the Server_Task and make it + -- wait on condition variable by sending an + -- Abort_Task_Interrupt + + Server := Server_ID (Interrupt); + + case Server.Common.State is + when Interrupt_Server_Idle_Sleep | + Interrupt_Server_Blocked_Interrupt_Sleep + => + POP.Wakeup (Server, Server.Common.State); + + when Interrupt_Server_Blocked_On_Event_Flag => + POP.Abort_Task (Server); + + -- Make sure corresponding Server_Task is out of its + -- own sigwait state. + + Ret_Interrupt := + Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access)); + pragma Assert + (Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt)); + + when Runnable => + null; + + when others => + pragma Assert (False); + null; + end case; + + IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); + + -- Unmake the Interrupt for this task in order to allow default + -- action again. + + IMOP.Thread_Unblock_Interrupt (IMNG.Interrupt_ID (Interrupt)); + + else + IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); + end if; + end Unbind_Handler; + + -------------------------------- + -- Unprotected_Detach_Handler -- + -------------------------------- + + procedure Unprotected_Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean) + is + Old_Handler : Parameterless_Handler; + + begin + if User_Entry (Interrupt).T /= Null_Task then + + -- In case we have an Interrupt Entry installed. + -- raise a program error. (propagate it to the caller). + + raise Program_Error with + "An interrupt entry is already installed"; + end if; + + -- Note : Static = True will pass the following check. That is the + -- case when we want to detach a handler regardless of the static + -- status of the current_Handler. + + if not Static and then User_Handler (Interrupt).Static then + + -- Tries to detach a static Interrupt Handler. + -- raise a program error. + + raise Program_Error with + "Trying to detach a static Interrupt Handler"; + end if; + + -- The interrupt should no longer be ignored if + -- it was ever ignored. + + Ignored (Interrupt) := False; + + Old_Handler := User_Handler (Interrupt).H; + + -- The new handler + + User_Handler (Interrupt).H := null; + User_Handler (Interrupt).Static := False; + + if Old_Handler /= null then + Unbind_Handler (Interrupt); + end if; + end Unprotected_Detach_Handler; + + ---------------------------------- + -- Unprotected_Exchange_Handler -- + ---------------------------------- + + procedure Unprotected_Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False) + is + begin + if User_Entry (Interrupt).T /= Null_Task then + + -- In case we have an Interrupt Entry already installed. + -- raise a program error. (propagate it to the caller). + + raise Program_Error with + "An interrupt is already installed"; + end if; + + -- Note : A null handler with Static = True will pass the + -- following check. That is the case when we want to Detach a + -- handler regardless of the Static status of the current_Handler. + + -- We don't check anything if Restoration is True, since we + -- may be detaching a static handler to restore a dynamic one. + + if not Restoration and then not Static + + -- Tries to overwrite a static Interrupt Handler with a + -- dynamic Handler + + and then (User_Handler (Interrupt).Static + + -- The new handler is not specified as an + -- Interrupt Handler by a pragma. + + or else not Is_Registered (New_Handler)) + then + raise Program_Error with + "Trying to overwrite a static Interrupt Handler with a " & + "dynamic Handler"; + end if; + + -- The interrupt should no longer be ignored if + -- it was ever ignored. + + Ignored (Interrupt) := False; + + -- Save the old handler + + Old_Handler := User_Handler (Interrupt).H; + + -- The new handler + + User_Handler (Interrupt).H := New_Handler; + + if New_Handler = null then + + -- The null handler means we are detaching the handler + + User_Handler (Interrupt).Static := False; + + else + User_Handler (Interrupt).Static := Static; + end if; + + -- Invoke a corresponding Server_Task if not yet created. + -- Place Task_Id info in Server_ID array. + + if Server_ID (Interrupt) = Null_Task then + + -- When a new Server_Task is created, it should have its + -- signal mask set to the All_Tasks_Mask. + + IMOP.Set_Interrupt_Mask + (IMOP.All_Tasks_Mask'Access, Old_Mask'Access); + Access_Hold := new Server_Task (Interrupt); + IMOP.Set_Interrupt_Mask (Old_Mask'Access); + + Server_ID (Interrupt) := To_System (Access_Hold.all'Identity); + end if; + + if New_Handler = null then + if Old_Handler /= null then + Unbind_Handler (Interrupt); + end if; + + return; + end if; + + if Old_Handler = null then + Bind_Handler (Interrupt); + end if; + end Unprotected_Exchange_Handler; + + -- Start of processing for Interrupt_Manager + + begin + -- By making this task independent of master, when the process + -- goes away, the Interrupt_Manager will terminate gracefully. + + System.Tasking.Utilities.Make_Independent; + + -- Environment task gets its own interrupt mask, saves it, + -- and then masks all interrupts except the Keep_Unmasked set. + + -- During rendezvous, the Interrupt_Manager receives the old + -- interrupt mask of the environment task, and sets its own + -- interrupt mask to that value. + + -- The environment task will call the entry of Interrupt_Manager some + -- during elaboration of the body of this package. + + accept Initialize (Mask : IMNG.Interrupt_Mask) do + declare + The_Mask : aliased IMNG.Interrupt_Mask; + + begin + IMOP.Copy_Interrupt_Mask (The_Mask, Mask); + IMOP.Set_Interrupt_Mask (The_Mask'Access); + end; + end Initialize; + + -- Note: All tasks in RTS will have all the Reserve Interrupts + -- being masked (except the Interrupt_Manager) and Keep_Unmasked + -- unmasked when created. + + -- Abort_Task_Interrupt is one of the Interrupt unmasked + -- in all tasks. We mask the Interrupt in this particular task + -- so that "sigwait" is possible to catch an explicitly sent + -- Abort_Task_Interrupt from the Server_Tasks. + + -- This sigwaiting is needed so that we make sure a Server_Task is + -- out of its own sigwait state. This extra synchronization is + -- necessary to prevent following scenarios. + + -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the + -- Server_Task then changes its own interrupt mask (OS level). + -- If an interrupt (corresponding to the Server_Task) arrives + -- in the mean time we have the Interrupt_Manager unmasked and + -- the Server_Task waiting on sigwait. + + -- 2) For unbinding handler, we install a default action in the + -- Interrupt_Manager. POSIX.1c states that the result of using + -- "sigwait" and "sigaction" simultaneously on the same interrupt + -- is undefined. Therefore, we need to be informed from the + -- Server_Task of the fact that the Server_Task is out of its + -- sigwait stage. + + IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access); + IMOP.Add_To_Interrupt_Mask + (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt); + IMOP.Thread_Block_Interrupt + (IMNG.Abort_Task_Interrupt); + + loop + -- A block is needed to absorb Program_Error exception + + begin + select + accept Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False) + do + Unprotected_Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static, Restoration); + end Attach_Handler; + + or + accept Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean) + do + Unprotected_Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static); + end Exchange_Handler; + + or + accept Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean) + do + Unprotected_Detach_Handler (Interrupt, Static); + end Detach_Handler; + + or + accept Bind_Interrupt_To_Entry + (T : Task_Id; + E : Task_Entry_Index; + Interrupt : Interrupt_ID) + do + -- if there is a binding already (either a procedure or an + -- entry), raise Program_Error (propagate it to the caller). + + if User_Handler (Interrupt).H /= null + or else User_Entry (Interrupt).T /= Null_Task + then + raise Program_Error with + "A binding for this interrupt is already present"; + end if; + + -- The interrupt should no longer be ignored if + -- it was ever ignored. + + Ignored (Interrupt) := False; + User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E); + + -- Indicate the attachment of Interrupt Entry in ATCB. + -- This is need so that when an Interrupt Entry task + -- terminates the binding can be cleaned. The call to + -- unbinding must be made by the task before it terminates. + + T.Interrupt_Entry := True; + + -- Invoke a corresponding Server_Task if not yet created. + -- Place Task_Id info in Server_ID array. + + if Server_ID (Interrupt) = Null_Task then + + -- When a new Server_Task is created, it should have its + -- signal mask set to the All_Tasks_Mask. + + IMOP.Set_Interrupt_Mask + (IMOP.All_Tasks_Mask'Access, Old_Mask'Access); + Access_Hold := new Server_Task (Interrupt); + IMOP.Set_Interrupt_Mask (Old_Mask'Access); + Server_ID (Interrupt) := + To_System (Access_Hold.all'Identity); + end if; + + Bind_Handler (Interrupt); + end Bind_Interrupt_To_Entry; + + or + accept Detach_Interrupt_Entries (T : Task_Id) do + for J in Interrupt_ID'Range loop + if not Is_Reserved (J) then + if User_Entry (J).T = T then + + -- The interrupt should no longer be ignored if + -- it was ever ignored. + + Ignored (J) := False; + User_Entry (J) := Entry_Assoc' + (T => Null_Task, E => Null_Task_Entry); + Unbind_Handler (J); + end if; + end if; + end loop; + + -- Indicate in ATCB that no Interrupt Entries are attached + + T.Interrupt_Entry := False; + end Detach_Interrupt_Entries; + + or + accept Block_Interrupt (Interrupt : Interrupt_ID) do + if Blocked (Interrupt) then + return; + end if; + + Blocked (Interrupt) := True; + Last_Unblocker (Interrupt) := Null_Task; + + -- Mask this task for the given Interrupt so that all tasks + -- are masked for the Interrupt. + + IMOP.Thread_Block_Interrupt (IMNG.Interrupt_ID (Interrupt)); + + if User_Handler (Interrupt).H /= null + or else User_Entry (Interrupt).T /= Null_Task + then + -- This is the case where the Server_Task is waiting + -- on "sigwait." Wake it up by sending an + -- Abort_Task_Interrupt so that the Server_Task + -- waits on Cond. + + POP.Abort_Task (Server_ID (Interrupt)); + + -- Make sure corresponding Server_Task is out of its own + -- sigwait state. + + Ret_Interrupt := Interrupt_ID + (IMOP.Interrupt_Wait (Intwait_Mask'Access)); + pragma Assert + (Ret_Interrupt = + Interrupt_ID (IMNG.Abort_Task_Interrupt)); + end if; + end Block_Interrupt; + + or + accept Unblock_Interrupt (Interrupt : Interrupt_ID) do + if not Blocked (Interrupt) then + return; + end if; + + Blocked (Interrupt) := False; + Last_Unblocker (Interrupt) := + To_System (Unblock_Interrupt'Caller); + + if User_Handler (Interrupt).H = null + and then User_Entry (Interrupt).T = Null_Task + then + -- No handler is attached. Unmask the Interrupt so that + -- the default action can be carried out. + + IMOP.Thread_Unblock_Interrupt + (IMNG.Interrupt_ID (Interrupt)); + + else + -- The Server_Task must be waiting on the Cond variable + -- since it was being blocked and an Interrupt Hander or + -- an Entry was there. Wake it up and let it change + -- it place of waiting according to its new state. + + POP.Wakeup (Server_ID (Interrupt), + Interrupt_Server_Blocked_Interrupt_Sleep); + end if; + end Unblock_Interrupt; + + or + accept Ignore_Interrupt (Interrupt : Interrupt_ID) do + if Ignored (Interrupt) then + return; + end if; + + Ignored (Interrupt) := True; + + -- If there is a handler associated with the Interrupt, + -- detach it first. In this way we make sure that the + -- Server_Task is not on sigwait. This is legal since + -- Unignore_Interrupt is to install the default action. + + if User_Handler (Interrupt).H /= null then + Unprotected_Detach_Handler + (Interrupt => Interrupt, Static => True); + + elsif User_Entry (Interrupt).T /= Null_Task then + User_Entry (Interrupt) := Entry_Assoc' + (T => Null_Task, E => Null_Task_Entry); + Unbind_Handler (Interrupt); + end if; + + IMOP.Install_Ignore_Action (IMNG.Interrupt_ID (Interrupt)); + end Ignore_Interrupt; + + or + accept Unignore_Interrupt (Interrupt : Interrupt_ID) do + Ignored (Interrupt) := False; + + -- If there is a handler associated with the Interrupt, + -- detach it first. In this way we make sure that the + -- Server_Task is not on sigwait. This is legal since + -- Unignore_Interrupt is to install the default action. + + if User_Handler (Interrupt).H /= null then + Unprotected_Detach_Handler + (Interrupt => Interrupt, Static => True); + + elsif User_Entry (Interrupt).T /= Null_Task then + User_Entry (Interrupt) := Entry_Assoc' + (T => Null_Task, E => Null_Task_Entry); + Unbind_Handler (Interrupt); + end if; + + IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); + end Unignore_Interrupt; + end select; + + exception + -- If there is a program error we just want to propagate it to + -- the caller and do not want to stop this task. + + when Program_Error => + null; + + when others => + pragma Assert (False); + null; + end; + end loop; + end Interrupt_Manager; + + ----------------- + -- Server_Task -- + ----------------- + + task body Server_Task is + Intwait_Mask : aliased IMNG.Interrupt_Mask; + Ret_Interrupt : Interrupt_ID; + Self_ID : constant Task_Id := Self; + Tmp_Handler : Parameterless_Handler; + Tmp_ID : Task_Id; + Tmp_Entry_Index : Task_Entry_Index; + + begin + -- By making this task independent of master, when the process + -- goes away, the Server_Task will terminate gracefully. + + System.Tasking.Utilities.Make_Independent; + + -- Install default action in system level + + IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); + + -- Note: All tasks in RTS will have all the Reserve Interrupts being + -- masked (except the Interrupt_Manager) and Keep_Unmasked unmasked when + -- created. + + -- Abort_Task_Interrupt is one of the Interrupt unmasked in all tasks. + -- We mask the Interrupt in this particular task so that "sigwait" is + -- possible to catch an explicitly sent Abort_Task_Interrupt from the + -- Interrupt_Manager. + + -- There are two Interrupt interrupts that this task catch through + -- "sigwait." One is the Interrupt this task is designated to catch + -- in order to execute user handler or entry. The other one is the + -- Abort_Task_Interrupt. This interrupt is being sent from the + -- Interrupt_Manager to inform status changes (e.g: become Blocked, + -- Handler or Entry is to be detached). + + -- Prepare a mask to used for sigwait + + IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access); + + IMOP.Add_To_Interrupt_Mask + (Intwait_Mask'Access, IMNG.Interrupt_ID (Interrupt)); + + IMOP.Add_To_Interrupt_Mask + (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt); + + IMOP.Thread_Block_Interrupt + (IMNG.Abort_Task_Interrupt); + + PIO.Set_Interrupt_ID (IMNG.Interrupt_ID (Interrupt), Self_ID); + + loop + System.Tasking.Initialization.Defer_Abort (Self_ID); + + if Single_Lock then + POP.Lock_RTS; + end if; + + POP.Write_Lock (Self_ID); + + if User_Handler (Interrupt).H = null + and then User_Entry (Interrupt).T = Null_Task + then + -- No Interrupt binding. If there is an interrupt, + -- Interrupt_Manager will take default action. + + Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep; + POP.Sleep (Self_ID, Interrupt_Server_Idle_Sleep); + Self_ID.Common.State := Runnable; + + elsif Blocked (Interrupt) then + + -- Interrupt is blocked. Stay here, so we won't catch + -- the Interrupt. + + Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep; + POP.Sleep (Self_ID, Interrupt_Server_Blocked_Interrupt_Sleep); + Self_ID.Common.State := Runnable; + + else + -- A Handler or an Entry is installed. At this point all tasks + -- mask for the Interrupt is masked. Catch the Interrupt using + -- sigwait. + + -- This task may wake up from sigwait by receiving an interrupt + -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding + -- a Procedure Handler or an Entry. Or it could be a wake up + -- from status change (Unblocked -> Blocked). If that is not + -- the case, we should execute the attached Procedure or Entry. + + Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag; + POP.Unlock (Self_ID); + + if Single_Lock then + POP.Unlock_RTS; + end if; + + -- Avoid race condition when terminating application and + -- System.Parameters.No_Abort is True. + + if Parameters.No_Abort and then Self_ID.Pending_Action then + Initialization.Do_Pending_Action (Self_ID); + end if; + + Ret_Interrupt := + Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access)); + Self_ID.Common.State := Runnable; + + if Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt) then + + -- Inform the Interrupt_Manager of wakeup from above sigwait + + POP.Abort_Task (Interrupt_Manager_ID); + + if Single_Lock then + POP.Lock_RTS; + end if; + + POP.Write_Lock (Self_ID); + + else + if Single_Lock then + POP.Lock_RTS; + end if; + + POP.Write_Lock (Self_ID); + + if Ret_Interrupt /= Interrupt then + + -- On some systems (e.g. recent linux kernels), sigwait + -- may return unexpectedly (with errno set to EINTR). + + null; + + else + -- Even though we have received an Interrupt the status may + -- have changed already before we got the Self_ID lock above + -- Therefore we make sure a Handler or an Entry is still + -- there and make appropriate call. + + -- If there is no calls to make we need to regenerate the + -- Interrupt in order not to lose it. + + if User_Handler (Interrupt).H /= null then + Tmp_Handler := User_Handler (Interrupt).H; + + -- RTS calls should not be made with self being locked + + POP.Unlock (Self_ID); + + if Single_Lock then + POP.Unlock_RTS; + end if; + + Tmp_Handler.all; + + if Single_Lock then + POP.Lock_RTS; + end if; + + POP.Write_Lock (Self_ID); + + elsif User_Entry (Interrupt).T /= Null_Task then + Tmp_ID := User_Entry (Interrupt).T; + Tmp_Entry_Index := User_Entry (Interrupt).E; + + -- RTS calls should not be made with self being locked + + if Single_Lock then + POP.Unlock_RTS; + end if; + + POP.Unlock (Self_ID); + + System.Tasking.Rendezvous.Call_Simple + (Tmp_ID, Tmp_Entry_Index, System.Null_Address); + + POP.Write_Lock (Self_ID); + + if Single_Lock then + POP.Lock_RTS; + end if; + + else + -- This is a situation that this task wakes up receiving + -- an Interrupt and before it gets the lock the Interrupt + -- is blocked. We do not want to lose the interrupt in + -- this case so we regenerate the Interrupt to process + -- level. + + IMOP.Interrupt_Self_Process + (IMNG.Interrupt_ID (Interrupt)); + end if; + end if; + end if; + end if; + + POP.Unlock (Self_ID); + + if Single_Lock then + POP.Unlock_RTS; + end if; + + System.Tasking.Initialization.Undefer_Abort (Self_ID); + + if Self_ID.Pending_Action then + Initialization.Do_Pending_Action (Self_ID); + end if; + + -- Undefer abort here to allow a window for this task to be aborted + -- at the time of system shutdown. We also explicitly test for + -- Pending_Action in case System.Parameters.No_Abort is True. + + end loop; + end Server_Task; + +-- Elaboration code for package System.Interrupts + +begin + -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent + + Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity); + + -- During the elaboration of this package body we want the RTS + -- to inherit the interrupt mask from the Environment Task. + + IMOP.Setup_Interrupt_Mask; + + -- The environment task should have gotten its mask from the enclosing + -- process during the RTS start up. (See processing in s-inmaop.adb). Pass + -- the Interrupt_Mask of the environment task to the Interrupt_Manager. + + -- Note: At this point we know that all tasks are masked for non-reserved + -- signals. Only the Interrupt_Manager will have masks set up differently + -- inheriting the original environment task's mask. + + Interrupt_Manager.Initialize (IMOP.Environment_Mask); +end System.Interrupts; diff --git a/gcc/ada/s-interr.ads b/gcc/ada/s-interr.ads new file mode 100644 index 000000000..3b66f067e --- /dev/null +++ b/gcc/ada/s-interr.ads @@ -0,0 +1,276 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T S -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +-- This package encapsulates the implementation of interrupt or signal +-- handlers. It is logically an extension of the body of Ada.Interrupts. It +-- is made a child of System to allow visibility of various runtime system +-- internal data and operations. + +-- See System.Interrupt_Management for core interrupt/signal interfaces + +-- These two packages are separated to allow System.Interrupt_Management to be +-- used without requiring the whole tasking implementation to be linked and +-- elaborated. + +with System.Tasking; +with System.Tasking.Protected_Objects.Entries; +with System.OS_Interface; + +package System.Interrupts is + + pragma Elaborate_Body; + -- Comment needed on why this is here ??? + + ------------------------- + -- Constants and types -- + ------------------------- + + Default_Interrupt_Priority : constant System.Interrupt_Priority := + System.Interrupt_Priority'Last; + -- Default value used when a pragma Interrupt_Handler or Attach_Handler is + -- specified without an Interrupt_Priority pragma, see D.3(10). + + type Ada_Interrupt_ID is range 0 .. System.OS_Interface.Max_Interrupt; + -- Avoid inheritance by Ada.Interrupts.Interrupt_ID of unwanted operations + + type Interrupt_ID is range 0 .. System.OS_Interface.Max_Interrupt; + + subtype System_Interrupt_Id is Interrupt_ID; + -- This synonym is introduced so that the type is accessible through + -- rtsfind, otherwise the name clashes with its homonym in Ada.Interrupts. + + type Parameterless_Handler is access protected procedure; + + ---------------------- + -- General services -- + ---------------------- + + -- Attempt to attach a Handler to an Interrupt to which an Entry is + -- already bound will raise a Program_Error. + + function Is_Reserved (Interrupt : Interrupt_ID) return Boolean; + + function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean; + + function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean; + + function Current_Handler + (Interrupt : Interrupt_ID) return Parameterless_Handler; + + -- Calling the following procedures with New_Handler = null and Static = + -- true means that we want to modify the current handler regardless of the + -- previous handler's binding status. (i.e. we do not care whether it is a + -- dynamic or static handler) + + procedure Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False); + + procedure Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False); + + procedure Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean := False); + + function Reference + (Interrupt : Interrupt_ID) return System.Address; + + -------------------------------- + -- Interrupt Entries Services -- + -------------------------------- + + -- Routines needed for Interrupt Entries + + procedure Bind_Interrupt_To_Entry + (T : System.Tasking.Task_Id; + E : System.Tasking.Task_Entry_Index; + Int_Ref : System.Address); + -- Bind the given interrupt to the given entry. If the interrupt is + -- already bound to another entry, Program_Error will be raised. + + procedure Detach_Interrupt_Entries (T : System.Tasking.Task_Id); + -- This procedure detaches all the Interrupt Entries bound to a task + + ------------------------------ + -- POSIX.5 Signals Services -- + ------------------------------ + + -- Routines needed for POSIX dot5 POSIX_Signals + + procedure Block_Interrupt (Interrupt : Interrupt_ID); + -- Block the Interrupt on the process level + + procedure Unblock_Interrupt (Interrupt : Interrupt_ID); + + function Unblocked_By + (Interrupt : Interrupt_ID) return System.Tasking.Task_Id; + -- It returns the ID of the last Task which Unblocked this Interrupt. + -- It returns Null_Task if no tasks have ever requested the Unblocking + -- operation or the Interrupt is currently Blocked. + + function Is_Blocked (Interrupt : Interrupt_ID) return Boolean; + -- Comment needed ??? + + procedure Ignore_Interrupt (Interrupt : Interrupt_ID); + -- Set the sigaction for the interrupt to SIG_IGN + + procedure Unignore_Interrupt (Interrupt : Interrupt_ID); + -- Comment needed ??? + + function Is_Ignored (Interrupt : Interrupt_ID) return Boolean; + -- Comment needed ??? + + -- Note : Direct calls to sigaction, sigprocmask, thr_sigsetmask or any + -- other low-level interface that changes the signal action or signal mask + -- needs a careful thought. + + -- One may achieve the effect of system calls first making RTS blocked (by + -- calling Block_Interrupt) for the signal under consideration. This will + -- make all the tasks in RTS blocked for the Interrupt. + + ---------------------- + -- Protection Types -- + ---------------------- + + -- Routines and types needed to implement Interrupt_Handler and + -- Attach_Handler. + + -- There are two kinds of protected objects that deal with interrupts: + + -- (1) Only Interrupt_Handler pragmas are used. We need to be able to tell + -- if an Interrupt_Handler applies to a given procedure, so + -- Register_Interrupt_Handler has to be called for all the potential + -- handlers, it should be done by calling Register_Interrupt_Handler with + -- the handler code address. On finalization, which can happen only has + -- part of library level finalization since PO with Interrupt_Handler + -- pragmas can only be declared at library level, nothing special needs to + -- be done since the default handlers have been restored as part of task + -- completion which is done just before global finalization. + -- Dynamic_Interrupt_Protection should be used in this case. + + -- (2) Attach_Handler pragmas are used, and possibly Interrupt_Handler + -- pragma. We need to attach the handlers to the given interrupts when the + -- object is elaborated. This should be done by constructing an array of + -- pairs (interrupt, handler) from the pragmas and calling Install_Handlers + -- with it (types to be used are New_Handler_Item and New_Handler_Array). + -- On finalization, we need to restore the handlers that were installed + -- before the elaboration of the PO, so we need to store these previous + -- handlers. This is also done by Install_Handlers, the room for these + -- informations is provided by adding a discriminant which is the number + -- of Attach_Handler pragmas and an array of this size in the protection + -- type, Static_Interrupt_Protection. + + procedure Register_Interrupt_Handler + (Handler_Addr : System.Address); + -- This routine should be called by the compiler to allow the handler be + -- used as an Interrupt Handler. That means call this procedure for each + -- pragma Interrupt_Handler providing the address of the handler (not + -- including the pointer to the actual PO, this way this routine is called + -- only once for each type definition of PO). + + type Static_Handler_Index is range 0 .. Integer'Last; + subtype Positive_Static_Handler_Index is + Static_Handler_Index range 1 .. Static_Handler_Index'Last; + -- Comment needed ??? + + type Previous_Handler_Item is record + Interrupt : Interrupt_ID; + Handler : Parameterless_Handler; + Static : Boolean; + end record; + -- Contains all the information needed to restore a previous handler + + type Previous_Handler_Array is array + (Positive_Static_Handler_Index range <>) of Previous_Handler_Item; + + type New_Handler_Item is record + Interrupt : Interrupt_ID; + Handler : Parameterless_Handler; + end record; + -- Contains all the information from an Attach_Handler pragma + + type New_Handler_Array is + array (Positive_Static_Handler_Index range <>) of New_Handler_Item; + -- Comment needed ??? + + -- Case (1) + + type Dynamic_Interrupt_Protection is new + Tasking.Protected_Objects.Entries.Protection_Entries with null record; + + -- ??? Finalize is not overloaded since we currently have no + -- way to detach the handlers during library level finalization. + + function Has_Interrupt_Or_Attach_Handler + (Object : access Dynamic_Interrupt_Protection) return Boolean; + -- Returns True + + -- Case (2) + + type Static_Interrupt_Protection + (Num_Entries : Tasking.Protected_Objects.Protected_Entry_Index; + Num_Attach_Handler : Static_Handler_Index) + is new + Tasking.Protected_Objects.Entries.Protection_Entries (Num_Entries) with + record + Previous_Handlers : Previous_Handler_Array (1 .. Num_Attach_Handler); + end record; + + function Has_Interrupt_Or_Attach_Handler + (Object : access Static_Interrupt_Protection) return Boolean; + -- Returns True + + procedure Finalize (Object : in out Static_Interrupt_Protection); + -- Restore previous handlers as required by C.3.1(12) then call + -- Finalize (Protection). + + procedure Install_Handlers + (Object : access Static_Interrupt_Protection; + New_Handlers : New_Handler_Array); + -- Store the old handlers in Object.Previous_Handlers and install + -- the new static handlers. + + procedure Install_Restricted_Handlers (Handlers : New_Handler_Array); + -- Install the static Handlers for the given interrupts and do not store + -- previously installed handlers. This procedure is used when the Ravenscar + -- restrictions are in place since in that case there are only + -- library-level protected handlers that will be installed at + -- initialization and never be replaced. + +end System.Interrupts; diff --git a/gcc/ada/s-intman-dummy.adb b/gcc/ada/s-intman-dummy.adb new file mode 100644 index 000000000..d3e222ce6 --- /dev/null +++ b/gcc/ada/s-intman-dummy.adb @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a NO tasking version of this package + +package body System.Interrupt_Management is + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + null; + end Initialize; + +end System.Interrupt_Management; diff --git a/gcc/ada/s-intman-irix.adb b/gcc/ada/s-intman-irix.adb new file mode 100644 index 000000000..ccd91bfa7 --- /dev/null +++ b/gcc/ada/s-intman-irix.adb @@ -0,0 +1,139 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2007, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a SGI Pthread version of this package + +-- Make a careful study of all signals available under the OS, to see which +-- need to be reserved, kept always unmasked, or kept always unmasked. Be on +-- the lookout for special signals that may be used by the thread library. + +package body System.Interrupt_Management is + + use System.OS_Interface; + + type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID; + Exception_Interrupts : constant Interrupt_List := + (SIGTSTP, SIGILL, SIGTRAP, SIGEMT, SIGFPE, SIGBUS, SIGSTOP, SIGKILL, + SIGSEGV, SIGSYS, SIGXCPU, SIGXFSZ, SIGPROF, SIGPTINTR, SIGPTRESCHED, + SIGABRT, SIGPIPE); + + Unreserve_All_Interrupts : Interfaces.C.int; + pragma Import + (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts"); + + function State (Int : Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + + -- Get interrupt state. Defined in a-init.c + -- The input argument is the interrupt number, + -- and the result is one of the following: + + User : constant Character := 'u'; + Runtime : constant Character := 'r'; + Default : constant Character := 's'; + -- 'n' this interrupt not set by any Interrupt_State pragma + -- 'u' Interrupt_State pragma set state to User + -- 'r' Interrupt_State pragma set state to Runtime + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + + ---------------- + -- Initialize -- + ---------------- + + Initialized : Boolean := False; + + procedure Initialize is + use type Interfaces.C.int; + begin + if Initialized then + return; + end if; + + Initialized := True; + Abort_Task_Interrupt := SIGABRT; + + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False)); + pragma Assert (Reserve = (Interrupt_ID'Range => False)); + + -- Process state of exception signals + + for J in Exception_Interrupts'Range loop + if State (Exception_Interrupts (J)) /= User then + Keep_Unmasked (Exception_Interrupts (J)) := True; + Reserve (Exception_Interrupts (J)) := True; + end if; + end loop; + + if State (Abort_Task_Interrupt) /= User then + Keep_Unmasked (Abort_Task_Interrupt) := True; + Reserve (Abort_Task_Interrupt) := True; + end if; + + -- Set SIGINT to unmasked state as long as it's + -- not in "User" state. Check for Unreserve_All_Interrupts last + + if State (SIGINT) /= User then + Keep_Unmasked (SIGINT) := True; + end if; + + -- Check all signals for state that requires keeping them + -- unmasked and reserved + + for J in Interrupt_ID'Range loop + if State (J) = Default or else State (J) = Runtime then + Keep_Unmasked (J) := True; + Reserve (J) := True; + end if; + end loop; + + -- Process pragma Unreserve_All_Interrupts. This overrides any + -- settings due to pragma Interrupt_State: + + if Unreserve_All_Interrupts /= 0 then + Keep_Unmasked (SIGINT) := False; + Reserve (SIGINT) := False; + end if; + + -- We do not have Signal 0 in reality. We just use this value + -- to identify not existing signals (see s-intnam.ads). Therefore, + -- Signal 0 should not be used in all signal related operations hence + -- mark it as reserved. + + Reserve (0) := True; + end Initialize; + +end System.Interrupt_Management; diff --git a/gcc/ada/s-intman-mingw.adb b/gcc/ada/s-intman-mingw.adb new file mode 100644 index 000000000..ab9f08ee5 --- /dev/null +++ b/gcc/ada/s-intman-mingw.adb @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the NT version of this package + +with System.OS_Interface; use System.OS_Interface; + +package body System.Interrupt_Management is + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + -- "Reserve" all the interrupts, except those that are explicitly + -- defined. + + for J in Interrupt_ID'Range loop + Reserve (J) := True; + end loop; + + Reserve (SIGINT) := False; + Reserve (SIGILL) := False; + Reserve (SIGABRT) := False; + Reserve (SIGFPE) := False; + Reserve (SIGSEGV) := False; + Reserve (SIGTERM) := False; + end Initialize; + +end System.Interrupt_Management; diff --git a/gcc/ada/s-intman-posix.adb b/gcc/ada/s-intman-posix.adb new file mode 100644 index 000000000..cbe0ea877 --- /dev/null +++ b/gcc/ada/s-intman-posix.adb @@ -0,0 +1,293 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the POSIX threads version of this package + +-- Make a careful study of all signals available under the OS, to see which +-- need to be reserved, kept always unmasked, or kept always unmasked. Be on +-- the lookout for special signals that may be used by the thread library. + +-- Since this is a multi target file, the signal <-> exception mapping +-- is simple minded. If you need a more precise and target specific +-- signal handling, create a new s-intman.adb that will fit your needs. + +-- This file assumes that: + +-- SIGFPE, SIGILL, SIGSEGV and SIGBUS exist. They are mapped as follows: +-- SIGPFE => Constraint_Error +-- SIGILL => Program_Error +-- SIGSEGV => Storage_Error +-- SIGBUS => Storage_Error + +-- SIGINT exists and will be kept unmasked unless the pragma +-- Unreserve_All_Interrupts is specified anywhere in the application. + +-- System.OS_Interface contains the following: +-- SIGADAABORT: the signal that will be used to abort tasks. +-- Unmasked: the OS specific set of signals that should be unmasked in +-- all the threads. SIGADAABORT is unmasked by +-- default +-- Reserved: the OS specific set of signals that are reserved. + +with System.Task_Primitives; + +package body System.Interrupt_Management is + + use Interfaces.C; + use System.OS_Interface; + + type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID; + Exception_Interrupts : constant Interrupt_List := + (SIGFPE, SIGILL, SIGSEGV, SIGBUS); + + Unreserve_All_Interrupts : Interfaces.C.int; + pragma Import + (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts"); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function State (Int : Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state. Defined in init.c The input argument is the + -- interrupt number, and the result is one of the following: + + User : constant Character := 'u'; + Runtime : constant Character := 'r'; + Default : constant Character := 's'; + -- 'n' this interrupt not set by any Interrupt_State pragma + -- 'u' Interrupt_State pragma set state to User + -- 'r' Interrupt_State pragma set state to Runtime + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + + procedure Notify_Exception + (signo : Signal; + siginfo : System.Address; + ucontext : System.Address); + -- This function identifies the Ada exception to be raised using the + -- information when the system received a synchronous signal. Since this + -- function is machine and OS dependent, different code has to be provided + -- for different target. + + ---------------------- + -- Notify_Exception -- + ---------------------- + + Signal_Mask : aliased sigset_t; + -- The set of signals handled by Notify_Exception + + procedure Notify_Exception + (signo : Signal; + siginfo : System.Address; + ucontext : System.Address) + is + pragma Unreferenced (siginfo); + + Result : Interfaces.C.int; + + begin + -- With the __builtin_longjmp, the signal mask is not restored, so we + -- need to restore it explicitly. + + Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null); + pragma Assert (Result = 0); + + -- Perform the necessary context adjustments prior to a raise + -- from a signal handler. + + Adjust_Context_For_Raise (signo, ucontext); + + -- Check that treatment of exception propagation here is consistent with + -- treatment of the abort signal in System.Task_Primitives.Operations. + + case signo is + when SIGFPE => + raise Constraint_Error; + when SIGILL => + raise Program_Error; + when SIGSEGV => + raise Storage_Error; + when SIGBUS => + raise Storage_Error; + when others => + null; + end case; + end Notify_Exception; + + ---------------- + -- Initialize -- + ---------------- + + Initialized : Boolean := False; + + procedure Initialize is + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + Result : System.OS_Interface.int; + + Use_Alternate_Stack : constant Boolean := + System.Task_Primitives.Alternate_Stack_Size /= 0; + -- Whether to use an alternate signal stack for stack overflows + + begin + if Initialized then + return; + end if; + + Initialized := True; + + -- Need to call pthread_init very early because it is doing signal + -- initializations. + + pthread_init; + + Abort_Task_Interrupt := SIGADAABORT; + + act.sa_handler := Notify_Exception'Address; + + -- Setting SA_SIGINFO asks the kernel to pass more than just the signal + -- number argument to the handler when it is called. The set of extra + -- parameters includes a pointer to the interrupted context, which the + -- ZCX propagation scheme needs. + + -- Most man pages for sigaction mention that sa_sigaction should be set + -- instead of sa_handler when SA_SIGINFO is on. In practice, the two + -- fields are actually union'ed and located at the same offset. + + -- On some targets, we set sa_flags to SA_NODEFER so that during the + -- handler execution we do not change the Signal_Mask to be masked for + -- the Signal. + + -- This is a temporary fix to the problem that the Signal_Mask is not + -- restored after the exception (longjmp) from the handler. The right + -- fix should be made in sigsetjmp so that we save the Signal_Set and + -- restore it after a longjmp. + + -- Since SA_NODEFER is obsolete, instead we reset explicitly the mask + -- in the exception handler. + + Result := sigemptyset (Signal_Mask'Access); + pragma Assert (Result = 0); + + -- Add signals that map to Ada exceptions to the mask + + for J in Exception_Interrupts'Range loop + if State (Exception_Interrupts (J)) /= Default then + Result := + sigaddset (Signal_Mask'Access, Signal (Exception_Interrupts (J))); + pragma Assert (Result = 0); + end if; + end loop; + + act.sa_mask := Signal_Mask; + + pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False)); + pragma Assert (Reserve = (Interrupt_ID'Range => False)); + + -- Process state of exception signals + + for J in Exception_Interrupts'Range loop + if State (Exception_Interrupts (J)) /= User then + Keep_Unmasked (Exception_Interrupts (J)) := True; + Reserve (Exception_Interrupts (J)) := True; + + if State (Exception_Interrupts (J)) /= Default then + act.sa_flags := SA_SIGINFO; + + if Use_Alternate_Stack + and then Exception_Interrupts (J) = SIGSEGV + then + act.sa_flags := act.sa_flags + SA_ONSTACK; + end if; + + Result := + sigaction + (Signal (Exception_Interrupts (J)), act'Unchecked_Access, + old_act'Unchecked_Access); + pragma Assert (Result = 0); + end if; + end if; + end loop; + + if State (Abort_Task_Interrupt) /= User then + Keep_Unmasked (Abort_Task_Interrupt) := True; + Reserve (Abort_Task_Interrupt) := True; + end if; + + -- Set SIGINT to unmasked state as long as it is not in "User" state. + -- Check for Unreserve_All_Interrupts last. + + if State (SIGINT) /= User then + Keep_Unmasked (SIGINT) := True; + Reserve (SIGINT) := True; + end if; + + -- Check all signals for state that requires keeping them unmasked and + -- reserved. + + for J in Interrupt_ID'Range loop + if State (J) = Default or else State (J) = Runtime then + Keep_Unmasked (J) := True; + Reserve (J) := True; + end if; + end loop; + + -- Add the set of signals that must always be unmasked for this target + + for J in Unmasked'Range loop + Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True; + Reserve (Interrupt_ID (Unmasked (J))) := True; + end loop; + + -- Add target-specific reserved signals + + for J in Reserved'Range loop + Reserve (Interrupt_ID (Reserved (J))) := True; + end loop; + + -- Process pragma Unreserve_All_Interrupts. This overrides any settings + -- due to pragma Interrupt_State: + + if Unreserve_All_Interrupts /= 0 then + Keep_Unmasked (SIGINT) := False; + Reserve (SIGINT) := False; + end if; + + -- We do not really have Signal 0. We just use this value to identify + -- non-existent signals (see s-intnam.ads). Therefore, Signal should not + -- be used in all signal related operations hence mark it as reserved. + + Reserve (0) := True; + end Initialize; + +end System.Interrupt_Management; diff --git a/gcc/ada/s-intman-solaris.adb b/gcc/ada/s-intman-solaris.adb new file mode 100644 index 000000000..170cd82f8 --- /dev/null +++ b/gcc/ada/s-intman-solaris.adb @@ -0,0 +1,237 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a Solaris version of this package + +-- Make a careful study of all signals available under the OS, to see which +-- need to be reserved, kept always unmasked, or kept always unmasked. + +-- Be on the lookout for special signals that may be used by the thread +-- library. + +package body System.Interrupt_Management is + + use Interfaces.C; + use System.OS_Interface; + + type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID; + + Exception_Interrupts : constant Interrupt_List := + (SIGFPE, SIGILL, SIGSEGV, SIGBUS); + + Unreserve_All_Interrupts : Interfaces.C.int; + pragma Import + (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts"); + + function State (Int : Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state. Defined in init.c + -- The input argument is the interrupt number, + -- and the result is one of the following: + + User : constant Character := 'u'; + Runtime : constant Character := 'r'; + Default : constant Character := 's'; + -- 'n' this interrupt not set by any Interrupt_State pragma + -- 'u' Interrupt_State pragma set state to User + -- 'r' Interrupt_State pragma set state to Runtime + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + + ---------------------- + -- Notify_Exception -- + ---------------------- + + -- This function identifies the Ada exception to be raised using the + -- information when the system received a synchronous signal. Since this + -- function is machine and OS dependent, different code has to be provided + -- for different target. + + procedure Notify_Exception + (signo : Signal; + info : access siginfo_t; + context : access ucontext_t); + + ---------------------- + -- Notify_Exception -- + ---------------------- + + procedure Notify_Exception + (signo : Signal; + info : access siginfo_t; + context : access ucontext_t) + is + pragma Unreferenced (info); + + begin + -- Perform the necessary context adjustments prior to a raise + -- from a signal handler. + + Adjust_Context_For_Raise (signo, context.all'Address); + + -- Check that treatment of exception propagation here is consistent with + -- treatment of the abort signal in System.Task_Primitives.Operations. + + case signo is + when SIGFPE => + raise Constraint_Error; + when SIGILL => + raise Program_Error; + when SIGSEGV => + raise Storage_Error; + when SIGBUS => + raise Storage_Error; + when others => + null; + end case; + end Notify_Exception; + + ---------------- + -- Initialize -- + ---------------- + + Initialized : Boolean := False; + + procedure Initialize is + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + mask : aliased sigset_t; + Result : Interfaces.C.int; + + begin + if Initialized then + return; + end if; + + Initialized := True; + + -- Need to call pthread_init very early because it is doing signal + -- initializations. + + pthread_init; + + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + Abort_Task_Interrupt := SIGABRT; + + act.sa_handler := Notify_Exception'Address; + + -- Set sa_flags to SA_NODEFER so that during the handler execution + -- we do not change the Signal_Mask to be masked for the Signal. + -- This is a temporary fix to the problem that the Signal_Mask is + -- not restored after the exception (longjmp) from the handler. + -- The right fix should be made in sigsetjmp so that we save + -- the Signal_Set and restore it after a longjmp. + + -- In that case, this field should be changed back to 0. ??? (Dong-Ik) + + act.sa_flags := 16; + + Result := sigemptyset (mask'Access); + pragma Assert (Result = 0); + + -- ??? For the same reason explained above, we can't mask these signals + -- because otherwise we won't be able to catch more than one signal. + + act.sa_mask := mask; + + pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False)); + pragma Assert (Reserve = (Interrupt_ID'Range => False)); + + for J in Exception_Interrupts'Range loop + if State (Exception_Interrupts (J)) /= User then + Keep_Unmasked (Exception_Interrupts (J)) := True; + Reserve (Exception_Interrupts (J)) := True; + + if State (Exception_Interrupts (J)) /= Default then + Result := + sigaction + (Signal (Exception_Interrupts (J)), act'Unchecked_Access, + old_act'Unchecked_Access); + pragma Assert (Result = 0); + end if; + end if; + end loop; + + if State (Abort_Task_Interrupt) /= User then + Keep_Unmasked (Abort_Task_Interrupt) := True; + Reserve (Abort_Task_Interrupt) := True; + end if; + + -- Set SIGINT to unmasked state as long as it's + -- not in "User" state. Check for Unreserve_All_Interrupts last + + if State (SIGINT) /= User then + Keep_Unmasked (SIGINT) := True; + Reserve (SIGINT) := True; + end if; + + -- Check all signals for state that requires keeping them + -- unmasked and reserved + + for J in Interrupt_ID'Range loop + if State (J) = Default or else State (J) = Runtime then + Keep_Unmasked (J) := True; + Reserve (J) := True; + end if; + end loop; + + -- Add the set of signals that must always be unmasked for this target + + for J in Unmasked'Range loop + Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True; + Reserve (Interrupt_ID (Unmasked (J))) := True; + end loop; + + -- Add target-specific reserved signals + + for J in Reserved'Range loop + Reserve (Interrupt_ID (Reserved (J))) := True; + end loop; + + -- Process pragma Unreserve_All_Interrupts. This overrides any + -- settings due to pragma Interrupt_State: + + if Unreserve_All_Interrupts /= 0 then + Keep_Unmasked (SIGINT) := False; + Reserve (SIGINT) := False; + end if; + + -- We do not have Signal 0 in reality. We just use this value to + -- identify not existing signals (see s-intnam.ads). Therefore, Signal 0 + -- should not be used in all signal related operations hence mark it as + -- reserved. + + Reserve (0) := True; + end Initialize; + +end System.Interrupt_Management; diff --git a/gcc/ada/s-intman-susv3.adb b/gcc/ada/s-intman-susv3.adb new file mode 100644 index 000000000..864d7e1d2 --- /dev/null +++ b/gcc/ada/s-intman-susv3.adb @@ -0,0 +1,170 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the SuSV3 threads version of this package + +-- Make a careful study of all signals available under the OS, to see which +-- need to be reserved, kept always unmasked, or kept always unmasked. Be on +-- the lookout for special signals that may be used by the thread library. + +-- Since this is a multi target file, the signal <-> exception mapping +-- is simple minded. If you need a more precise and target specific +-- signal handling, create a new s-intman.adb that will fit your needs. + +-- This file assumes that: + +-- SIGINT exists and will be kept unmasked unless the pragma +-- Unreserve_All_Interrupts is specified anywhere in the application. + +-- System.OS_Interface contains the following: +-- SIGADAABORT: the signal that will be used to abort tasks. +-- Unmasked: the OS specific set of signals that should be unmasked in +-- all the threads. SIGADAABORT is unmasked by +-- default +-- Reserved: the OS specific set of signals that are reserved. + +package body System.Interrupt_Management is + + use Interfaces.C; + use System.OS_Interface; + + Unreserve_All_Interrupts : Interfaces.C.int; + pragma Import + (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts"); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function State (Int : Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state. Defined in init.c The input argument is the + -- interrupt number, and the result is one of the following: + + User : constant Character := 'u'; + Runtime : constant Character := 'r'; + Default : constant Character := 's'; + -- 'n' this interrupt not set by any Interrupt_State pragma + -- 'u' Interrupt_State pragma set state to User + -- 'r' Interrupt_State pragma set state to Runtime + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + + ---------------- + -- Initialize -- + ---------------- + + Initialized : Boolean := False; + + procedure Initialize is + begin + if Initialized then + return; + end if; + + Initialized := True; + + -- Need to call pthread_init very early because it is doing signal + -- initializations. + + pthread_init; + + Abort_Task_Interrupt := SIGADAABORT; + + pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False)); + pragma Assert (Reserve = (Interrupt_ID'Range => False)); + + -- Process state of exception signals + + for J in Exception_Signals'Range loop + declare + Sig : constant Signal := Exception_Signals (J); + Id : constant Interrupt_ID := Interrupt_ID (Sig); + begin + if State (Id) /= User then + Keep_Unmasked (Id) := True; + Reserve (Id) := True; + end if; + end; + end loop; + + if State (Abort_Task_Interrupt) /= User then + Keep_Unmasked (Abort_Task_Interrupt) := True; + Reserve (Abort_Task_Interrupt) := True; + end if; + + -- Set SIGINT to unmasked state as long as it is not in "User" state. + -- Check for Unreserve_All_Interrupts last. + + if State (SIGINT) /= User then + Keep_Unmasked (SIGINT) := True; + Reserve (SIGINT) := True; + end if; + + -- Check all signals for state that requires keeping them unmasked and + -- reserved. + + for J in Interrupt_ID'Range loop + if State (J) = Default or else State (J) = Runtime then + Keep_Unmasked (J) := True; + Reserve (J) := True; + end if; + end loop; + + -- Add the set of signals that must always be unmasked for this target + + for J in Unmasked'Range loop + Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True; + Reserve (Interrupt_ID (Unmasked (J))) := True; + end loop; + + -- Add target-specific reserved signals + + for J in Reserved'Range loop + Reserve (Interrupt_ID (Reserved (J))) := True; + end loop; + + -- Process pragma Unreserve_All_Interrupts. This overrides any settings + -- due to pragma Interrupt_State: + + if Unreserve_All_Interrupts /= 0 then + Keep_Unmasked (SIGINT) := False; + Reserve (SIGINT) := False; + end if; + + -- We do not really have Signal 0. We just use this value to identify + -- non-existent signals (see s-intnam.ads). Therefore, Signal should not + -- be used in all signal related operations hence mark it as reserved. + + Reserve (0) := True; + end Initialize; + +end System.Interrupt_Management; diff --git a/gcc/ada/s-intman-vms.adb b/gcc/ada/s-intman-vms.adb new file mode 100644 index 000000000..0f198f152 --- /dev/null +++ b/gcc/ada/s-intman-vms.adb @@ -0,0 +1,76 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a OpenVMS/Alpha version of this package + +package body System.Interrupt_Management is + + ---------------- + -- Initialize -- + ---------------- + + Initialized : Boolean := False; + + procedure Initialize is + use System.OS_Interface; + Status : Cond_Value_Type; + + begin + if Initialized then + return; + end if; + + Initialized := True; + Abort_Task_Interrupt := Interrupt_ID_0; + -- Unused + + Reserve := Reserve or Keep_Unmasked or Keep_Masked; + Reserve (Interrupt_ID_0) := True; + + Sys_Crembx + (Status => Status, + Prmflg => 0, + Chan => Rcv_Interrupt_Chan, + Maxmsg => Interrupt_ID'Size, + Bufquo => Interrupt_Bufquo, + Lognam => "GNAT_Interrupt_Mailbox", + Flags => CMB_M_READONLY); + pragma Assert ((Status and 1) = 1); + + Sys_Assign + (Status => Status, + Devnam => "GNAT_Interrupt_Mailbox", + Chan => Snd_Interrupt_Chan, + Flags => AGN_M_WRITEONLY); + pragma Assert ((Status and 1) = 1); + end Initialize; + +end System.Interrupt_Management; diff --git a/gcc/ada/s-intman-vms.ads b/gcc/ada/s-intman-vms.ads new file mode 100644 index 000000000..cc5124217 --- /dev/null +++ b/gcc/ada/s-intman-vms.ads @@ -0,0 +1,119 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Alpha/VMS version of this package + +-- This package encapsulates and centralizes information about all uses of +-- interrupts (or signals), including the target-dependent mapping of +-- interrupts (or signals) to exceptions. + +-- PLEASE DO NOT add any with-clauses to this package + +-- PLEASE DO NOT put any subprogram declarations with arguments of type +-- Interrupt_ID into the visible part of this package. + +-- The type Interrupt_ID is used to derive the type in Ada.Interrupts, and +-- adding more operations to that type would be illegal according to the Ada +-- Reference Manual. (This is the reason why the signals sets below are +-- implemented as visible arrays rather than functions.) + +with System.OS_Interface; + +package System.Interrupt_Management is + pragma Preelaborate; + + type Interrupt_Mask is limited private; + + type Interrupt_ID is new System.OS_Interface.Signal; + + type Interrupt_Set is array (Interrupt_ID) of Boolean; + + -- The following objects serve as constants, but are initialized in the + -- body to aid portability. This permits us to use more portable names for + -- interrupts, where distinct names may map to the same interrupt ID + -- value. For example, suppose SIGRARE is a signal that is not defined on + -- all systems, but is always reserved when it is defined. If we have the + -- convention that ID zero is not used for any "real" signals, and SIGRARE + -- = 0 when SIGRARE is not one of the locally supported signals, we can + -- write: + -- Reserved (SIGRARE) := true; + -- Then the initialization code will be portable. + + Abort_Task_Interrupt : Interrupt_ID; + -- The interrupt that is used to implement task abort, if an interrupt is + -- used for that purpose. This is one of the reserved interrupts. + + Keep_Unmasked : Interrupt_Set := (others => False); + -- Keep_Unmasked (I) is true iff the interrupt I is one that must be kept + -- unmasked at all times, except (perhaps) for short critical sections. + -- This includes interrupts that are mapped to exceptions (see + -- System.Interrupt_Exceptions.Is_Exception), but may also include + -- interrupts (e.g. timer) that need to be kept unmasked for other + -- reasons. Where interrupts are implemented as OS signals, and signal + -- masking is per-task, the interrupt should be unmasked in ALL TASKS. + + Reserve : Interrupt_Set := (others => False); + -- Reserve (I) is true iff the interrupt I is one that cannot be permitted + -- to be attached to a user handler. The possible reasons are many. For + -- example it may be mapped to an exception used to implement task abort. + + Keep_Masked : Interrupt_Set := (others => False); + -- Keep_Masked (I) is true iff the interrupt I must always be masked. + -- Where interrupts are implemented as OS signals, and signal masking is + -- per-task, the interrupt should be masked in ALL TASKS. There might not + -- be any interrupts in this class, depending on the environment. For + -- example, if interrupts are OS signals and signal masking is per-task, + -- use of the sigwait operation requires the signal be masked in all tasks. + + procedure Initialize; + -- Initialize the various variables defined in this package. + -- This procedure must be called before accessing any object from this + -- package and can be called multiple times. + +private + use type System.OS_Interface.unsigned_long; + + type Interrupt_Mask is new System.OS_Interface.sigset_t; + + -- Interrupts on VMS are implemented with a mailbox. A QIO read is + -- registered on the Rcv channel and the interrupt occurs by registering + -- a QIO write on the Snd channel. The maximum number of pending + -- interrupts is arbitrarily set at 1000. One nice feature of using + -- a mailbox is that it is trivially extendable to cross process + -- interrupts. + + Rcv_Interrupt_Chan : System.OS_Interface.unsigned_short := 0; + Snd_Interrupt_Chan : System.OS_Interface.unsigned_short := 0; + Interrupt_Mailbox : Interrupt_ID := 0; + Interrupt_Bufquo : System.OS_Interface.unsigned_long := + 1000 * (Interrupt_ID'Size / 8); + +end System.Interrupt_Management; diff --git a/gcc/ada/s-intman-vxworks.adb b/gcc/ada/s-intman-vxworks.adb new file mode 100644 index 000000000..dacc418f0 --- /dev/null +++ b/gcc/ada/s-intman-vxworks.adb @@ -0,0 +1,153 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VxWorks version of this package + +-- Make a careful study of all signals available under the OS, to see which +-- need to be reserved, kept always unmasked, or kept always unmasked. Be on +-- the lookout for special signals that may be used by the thread library. + +package body System.Interrupt_Management is + + use System.OS_Interface; + use type Interfaces.C.int; + + type Signal_List is array (Signal_ID range <>) of Signal_ID; + Exception_Signals : constant Signal_List (1 .. 4) := + (SIGFPE, SIGILL, SIGSEGV, SIGBUS); + + Exception_Action : aliased struct_sigaction; + -- Keep this variable global so that it is initialized only once + + procedure Notify_Exception + (signo : Signal; + siginfo : System.Address; + sigcontext : System.Address); + pragma Import (C, Notify_Exception, "__gnat_error_handler"); + -- Map signal to Ada exception and raise it. Different versions + -- of VxWorks need different mappings. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function State (Int : Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state. Defined in init.c The input argument is the + -- interrupt number, and the result is one of the following: + + Runtime : constant Character := 'r'; + Default : constant Character := 's'; + -- 'n' this interrupt not set by any Interrupt_State pragma + -- 'u' Interrupt_State pragma set state to User + -- 'r' Interrupt_State pragma set state to Runtime + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + + --------------------------- + -- Initialize_Interrupts -- + --------------------------- + + -- Since there is no signal inheritance between VxWorks tasks, we need + -- to initialize signal handling in each task. + + procedure Initialize_Interrupts is + Result : int; + old_act : aliased struct_sigaction; + begin + for J in Exception_Signals'Range loop + Result := + sigaction + (Signal (Exception_Signals (J)), Exception_Action'Access, + old_act'Unchecked_Access); + pragma Assert (Result = 0); + end loop; + end Initialize_Interrupts; + + ---------------- + -- Initialize -- + ---------------- + + Initialized : Boolean := False; + -- Set to True once Initialize is called, further calls have no effect + + procedure Initialize is + mask : aliased sigset_t; + Result : int; + + begin + if Initialized then + return; + end if; + + Initialized := True; + + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + Abort_Task_Interrupt := SIGABRT; + + Exception_Action.sa_handler := Notify_Exception'Address; + Exception_Action.sa_flags := SA_ONSTACK + SA_SIGINFO; + Result := sigemptyset (mask'Access); + pragma Assert (Result = 0); + + for J in Exception_Signals'Range loop + Result := sigaddset (mask'Access, Signal (Exception_Signals (J))); + pragma Assert (Result = 0); + end loop; + + Exception_Action.sa_mask := mask; + + -- Initialize hardware interrupt handling + + pragma Assert (Reserve = (Interrupt_ID'Range => False)); + + -- Check all interrupts for state that requires keeping them reserved + + for J in Interrupt_ID'Range loop + if State (J) = Default or else State (J) = Runtime then + Reserve (J) := True; + end if; + end loop; + + -- Add exception signals to the set of unmasked signals + + for J in Exception_Signals'Range loop + Keep_Unmasked (Exception_Signals (J)) := True; + end loop; + + -- The abort signal must also be unmasked + + Keep_Unmasked (Abort_Task_Interrupt) := True; + end Initialize; + +end System.Interrupt_Management; diff --git a/gcc/ada/s-intman-vxworks.ads b/gcc/ada/s-intman-vxworks.ads new file mode 100644 index 000000000..5614553c7 --- /dev/null +++ b/gcc/ada/s-intman-vxworks.ads @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2010, 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 VxWorks version of this package + +-- This package encapsulates and centralizes information about all +-- uses of interrupts (or signals), including the target-dependent +-- mapping of interrupts (or signals) to exceptions. + +-- Unlike the original design, System.Interrupt_Management can only +-- be used for tasking systems. + +-- PLEASE DO NOT put any subprogram declarations with arguments of +-- type Interrupt_ID into the visible part of this package. The type +-- Interrupt_ID is used to derive the type in Ada.Interrupts, and +-- adding more operations to that type would be illegal according +-- to the Ada Reference Manual. This is the reason why the signals +-- sets are implemented using visible arrays rather than functions. + +with System.OS_Interface; + +with Interfaces.C; + +package System.Interrupt_Management is + pragma Preelaborate; + + type Interrupt_Mask is limited private; + + type Interrupt_ID is new Interfaces.C.int + range 0 .. System.OS_Interface.Max_Interrupt; + + type Interrupt_Set is array (Interrupt_ID) of Boolean; + + subtype Signal_ID is Interrupt_ID range 0 .. System.OS_Interface.NSIG - 1; + + type Signal_Set is array (Signal_ID) of Boolean; + + -- The following objects serve as constants, but are initialized in the + -- body to aid portability. This permits us to use more portable names for + -- interrupts, where distinct names may map to the same interrupt ID + -- value. + + -- For example, suppose SIGRARE is a signal that is not defined on all + -- systems, but is always reserved when it is defined. If we have the + -- convention that ID zero is not used for any "real" signals, and SIGRARE + -- = 0 when SIGRARE is not one of the locally supported signals, we can + -- write: + -- Reserved (SIGRARE) := True; + -- and the initialization code will be portable. + + Abort_Task_Interrupt : Signal_ID; + -- The signal that is used to implement task abort if an interrupt is used + -- for that purpose. This is one of the reserved signals. + + Keep_Unmasked : Signal_Set := (others => False); + -- Keep_Unmasked (I) is true iff the signal I is one that must that must + -- be kept unmasked at all times, except (perhaps) for short critical + -- sections. This includes signals that are mapped to exceptions, but may + -- also include interrupts (e.g. timer) that need to be kept unmasked for + -- other reasons. Where signal masking is per-task, the signal should be + -- unmasked in ALL TASKS. + + Reserve : Interrupt_Set := (others => False); + -- Reserve (I) is true iff the interrupt I is one that cannot be permitted + -- to be attached to a user handler. The possible reasons are many. For + -- example, it may be mapped to an exception used to implement task abort, + -- or used to implement time delays. + + procedure Initialize_Interrupts; + -- Under VxWorks, there is no signal inheritance between tasks. + -- This procedure is used to initialize signal-to-exception mapping in + -- each task. + + procedure Initialize; + -- Initialize the various variables defined in this package. This procedure + -- must be called before accessing any object from this package and can be + -- called multiple times (only the first call has any effect). + +private + type Interrupt_Mask is new System.OS_Interface.sigset_t; + -- In some implementation Interrupt_Mask can be represented as a linked + -- list. + +end System.Interrupt_Management; diff --git a/gcc/ada/s-intman.ads b/gcc/ada/s-intman.ads new file mode 100644 index 000000000..5f3f4d500 --- /dev/null +++ b/gcc/ada/s-intman.ads @@ -0,0 +1,111 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package encapsulates and centralizes information about all uses of +-- interrupts (or signals), including the target-dependent mapping of +-- interrupts (or signals) to exceptions. + +-- Unlike the original design, System.Interrupt_Management can only be used +-- for tasking systems. + +-- PLEASE DO NOT put any subprogram declarations with arguments of type +-- Interrupt_ID into the visible part of this package. The type Interrupt_ID +-- is used to derive the type in Ada.Interrupts, and adding more operations +-- to that type would be illegal according to the Ada Reference Manual. This +-- is the reason why the signals sets are implemented using visible arrays +-- rather than functions. + +with System.OS_Interface; + +with Interfaces.C; + +package System.Interrupt_Management is + pragma Preelaborate; + + type Interrupt_Mask is limited private; + + type Interrupt_ID is new Interfaces.C.int + range 0 .. System.OS_Interface.Max_Interrupt; + + type Interrupt_Set is array (Interrupt_ID) of Boolean; + + -- The following objects serve as constants, but are initialized in the + -- body to aid portability. This permits us to use more portable names for + -- interrupts, where distinct names may map to the same interrupt ID + -- value. + + -- For example, suppose SIGRARE is a signal that is not defined on all + -- systems, but is always reserved when it is defined. If we have the + -- convention that ID zero is not used for any "real" signals, and SIGRARE + -- = 0 when SIGRARE is not one of the locally supported signals, we can + -- write: + -- Reserved (SIGRARE) := True; + -- and the initialization code will be portable. + + Abort_Task_Interrupt : Interrupt_ID; + -- The interrupt that is used to implement task abort if an interrupt is + -- used for that purpose. This is one of the reserved interrupts. + + Keep_Unmasked : Interrupt_Set := (others => False); + -- Keep_Unmasked (I) is true iff the interrupt I is one that must that + -- must be kept unmasked at all times, except (perhaps) for short critical + -- sections. This includes interrupts that are mapped to exceptions (see + -- System.Interrupt_Exceptions.Is_Exception), but may also include + -- interrupts (e.g. timer) that need to be kept unmasked for other + -- reasons. Where interrupts are implemented as OS signals, and signal + -- masking is per-task, the interrupt should be unmasked in ALL TASKS. + + Reserve : Interrupt_Set := (others => False); + -- Reserve (I) is true iff the interrupt I is one that cannot be permitted + -- to be attached to a user handler. The possible reasons are many. For + -- example, it may be mapped to an exception used to implement task abort, + -- or used to implement time delays. + + procedure Initialize; + -- Initialize the various variables defined in this package. This procedure + -- must be called before accessing any object from this package, and can be + -- called multiple times. + +private + type Interrupt_Mask is new System.OS_Interface.sigset_t; + -- In some implementations Interrupt_Mask is represented as a linked list + + procedure Adjust_Context_For_Raise + (Signo : System.OS_Interface.Signal; + Ucontext : System.Address); + pragma Import + (C, Adjust_Context_For_Raise, "__gnat_adjust_context_for_raise"); + -- Target specific hook performing adjustments to the signal's machine + -- context, to be called before an exception may be raised from a signal + -- handler. This service is provided by init.c, together with the + -- non-tasking signal handler. + +end System.Interrupt_Management; diff --git a/gcc/ada/s-io.adb b/gcc/ada/s-io.adb new file mode 100644 index 000000000..4925471ff --- /dev/null +++ b/gcc/ada/s-io.adb @@ -0,0 +1,129 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . 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. -- +-- -- +------------------------------------------------------------------------------ + +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 new file mode 100644 index 000000000..71897adc8 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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-linux-alpha.ads b/gcc/ada/s-linux-alpha.ads new file mode 100644 index 000000000..cdc716c72 --- /dev/null +++ b/gcc/ada/s-linux-alpha.ads @@ -0,0 +1,119 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . L I N U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 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 -- +-- . -- +-- -- +-- -- +------------------------------------------------------------------------------ + +-- This is the alpha version of this package + +-- This package encapsulates cpu specific differences between implementations +-- of GNU/Linux, in order to share s-osinte-linux.ads. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; + +package System.Linux is + pragma Preelaborate; + + ----------- + -- Errno -- + ----------- + + EAGAIN : constant := 35; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + EPERM : constant := 1; + ETIMEDOUT : constant := 60; + + ------------- + -- Signals -- + ------------- + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGURG : constant := 16; -- urgent condition on IO channel + SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 18; -- user stop requested from tty + SIGCONT : constant := 19; -- stopped process has been continued + SIGCLD : constant := 20; -- alias for SIGCHLD + SIGCHLD : constant := 20; -- child status change + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGIO : constant := 23; -- I/O now possible (4.2 BSD) + SIGPOLL : constant := 23; -- pollable event occurred + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 27; -- profiling timer expired + SIGWINCH : constant := 28; -- window size change + SIGPWR : constant := 29; -- power-fail restart + SIGUSR1 : constant := 30; -- user defined signal 1 + SIGUSR2 : constant := 31; -- user defined signal 2 + + SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal + SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal + SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal + + SIGADAABORT : constant := SIGABRT; + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + SIGUNUSED : constant := 0; + SIGSTKFLT : constant := 0; + SIGLOST : constant := 0; + -- These don't exist for Linux/Alpha. The constants are present + -- so that we can continue to use a-intnam-linux.ads. + + -- struct_sigaction offsets + + sa_handler_pos : constant := 0; + sa_mask_pos : constant := Standard'Address_Size / 8; + sa_flags_pos : constant := 128 + sa_mask_pos; + + SA_SIGINFO : constant := 16#40#; + SA_ONSTACK : constant := 16#01#; + + type pthread_mutex_t is record + dum0, dum1, dum2, dum3, dum4 : Interfaces.C.unsigned_long; + end record; + pragma Convention (C, pthread_mutex_t); + +end System.Linux; diff --git a/gcc/ada/s-linux-hppa.ads b/gcc/ada/s-linux-hppa.ads new file mode 100644 index 000000000..6176376cb --- /dev/null +++ b/gcc/ada/s-linux-hppa.ads @@ -0,0 +1,128 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . L I N U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2008-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 -- +-- . -- +-- -- +-- -- +------------------------------------------------------------------------------ + +-- This is the hppa version of this package + +-- This package encapsulates cpu specific differences between implementations +-- of GNU/Linux, in order to share s-osinte-linux.ads. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +package System.Linux is + pragma Preelaborate; + + ----------- + -- Errno -- + ----------- + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + EPERM : constant := 1; + ETIMEDOUT : constant := 238; + + ------------- + -- Signals -- + ------------- + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 7; -- EMT + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 16; -- user defined signal 1 + SIGUSR2 : constant := 17; -- user defined signal 2 + SIGCLD : constant := 18; -- alias for SIGCHLD + SIGCHLD : constant := 18; -- child status change + SIGPWR : constant := 19; -- power-fail restart + SIGVTALRM : constant := 20; -- virtual timer expired + SIGPROF : constant := 21; -- profiling timer expired + SIGPOLL : constant := 22; -- pollable event occurred + SIGIO : constant := 22; -- I/O now possible (4.2 BSD) + SIGWINCH : constant := 23; -- window size change + SIGSTOP : constant := 24; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 25; -- user stop requested from tty + SIGCONT : constant := 26; -- stopped process has been continued + SIGTTIN : constant := 27; -- background tty read attempted + SIGTTOU : constant := 28; -- background tty write attempted + SIGURG : constant := 29; -- urgent condition on IO channel + SIGLOST : constant := 30; -- File lock lost + SIGUNUSED : constant := 31; -- unused signal (GNU/Linux) + SIGXCPU : constant := 33; -- CPU time limit exceeded + SIGXFSZ : constant := 34; -- filesize limit exceeded + SIGSTKFLT : constant := 36; -- coprocessor stack fault (Linux) + SIGLTHRRES : constant := 37; -- GNU/LinuxThreads restart signal + SIGLTHRCAN : constant := 38; -- GNU/LinuxThreads cancel signal + SIGLTHRDBG : constant := 39; -- GNU/LinuxThreads debugger signal + + -- struct_sigaction offsets + + sa_handler_pos : constant := 0; + sa_flags_pos : constant := Standard'Address_Size / 8; + sa_mask_pos : constant := sa_flags_pos * 2; + + SA_SIGINFO : constant := 16#10#; + SA_ONSTACK : constant := 16#01#; + + type lock_array is array (1 .. 4) of Integer; + type atomic_lock_t is record + lock : lock_array; + end record; + pragma Convention (C, atomic_lock_t); + for atomic_lock_t'Alignment use 16; + + type struct_pthread_fast_lock is record + spinlock : atomic_lock_t; + status : Long_Integer; + end record; + pragma Convention (C, struct_pthread_fast_lock); + + type pthread_mutex_t is record + m_reserved : Integer; + m_count : Integer; + m_owner : System.Address; + m_kind : Integer; + m_lock : struct_pthread_fast_lock; + end record; + pragma Convention (C, pthread_mutex_t); + +end System.Linux; diff --git a/gcc/ada/s-linux-mipsel.ads b/gcc/ada/s-linux-mipsel.ads new file mode 100644 index 000000000..c0911d8d1 --- /dev/null +++ b/gcc/ada/s-linux-mipsel.ads @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . L I N U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 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 -- +-- . -- +-- -- +------------------------------------------------------------------------------ + +-- This is the mipsel version of this package + +-- This package encapsulates cpu specific differences between implementations +-- of GNU/Linux, in order to share s-osinte-linux.ads. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package + +package System.Linux is + pragma Preelaborate; + + ----------- + -- Errno -- + ----------- + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + EPERM : constant := 1; + ETIMEDOUT : constant := 110; + + ------------- + -- Signals -- + ------------- + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 7; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 10; -- user defined signal 1 + SIGUSR2 : constant := 12; -- user defined signal 2 + SIGCLD : constant := 17; -- alias for SIGCHLD + SIGCHLD : constant := 17; -- child status change + SIGPWR : constant := 30; -- power-fail restart + SIGWINCH : constant := 28; -- window size change + SIGURG : constant := 23; -- urgent condition on IO channel + SIGPOLL : constant := 29; -- pollable event occurred + SIGIO : constant := 29; -- I/O now possible (4.2 BSD) + SIGLOST : constant := 29; -- File lock lost + SIGSTOP : constant := 19; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 20; -- user stop requested from tty + SIGCONT : constant := 18; -- stopped process has been continued + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 27; -- profiling timer expired + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGUNUSED : constant := 31; -- unused signal (GNU/Linux) + SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux) + SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal + SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal + SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal + + -- struct_sigaction offsets + + sa_handler_pos : constant := Standard'Address_Size / 8; + sa_mask_pos : constant := 2 * Standard'Address_Size / 8; + sa_flags_pos : constant := 0; + + SA_SIGINFO : constant := 16#04#; + SA_ONSTACK : constant := 16#08000000#; + + type struct_pthread_fast_lock is record + status : Long_Integer; + spinlock : Integer; + end record; + pragma Convention (C, struct_pthread_fast_lock); + + type pthread_mutex_t is record + m_reserved : Integer; + m_count : Integer; + m_owner : System.Address; + m_kind : Integer; + m_lock : struct_pthread_fast_lock; + end record; + pragma Convention (C, pthread_mutex_t); + +end System.Linux; diff --git a/gcc/ada/s-linux-sparc.ads b/gcc/ada/s-linux-sparc.ads new file mode 100644 index 000000000..206eb86a0 --- /dev/null +++ b/gcc/ada/s-linux-sparc.ads @@ -0,0 +1,119 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . L I N U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 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 -- +-- . -- +-- -- +-- -- +------------------------------------------------------------------------------ + +-- This is the SPARC version of this package + +-- This package encapsulates cpu specific differences between implementations +-- of GNU/Linux, in order to share s-osinte-linux.ads. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package + +with Interfaces.C; + +package System.Linux is + pragma Preelaborate; + + ----------- + -- Errno -- + ----------- + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + EPERM : constant := 1; + ETIMEDOUT : constant := 110; + + ------------- + -- Signals -- + ------------- + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGIOT : constant := 6; -- IOT instruction + SIGEMT : constant := 7; -- EMT + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGURG : constant := 16; -- urgent condition on IO channel + SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 18; -- user stop requested from tty + SIGCONT : constant := 19; -- stopped process has been continued + SIGCHLD : constant := 20; -- child status change + SIGCLD : constant := 20; -- alias for SIGCHLD + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGIO : constant := 23; -- I/O now possible (4.2 BSD) + SIGPOLL : constant := 23; -- pollable event occurred + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 27; -- profiling timer expired + SIGWINCH : constant := 28; -- window size change + SIGLOST : constant := 29; -- File lock lost + SIGPWR : constant := 29; -- power-fail restart + SIGUSR1 : constant := 30; -- user defined signal 1 + SIGUSR2 : constant := 31; -- user defined signal 2 + + SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal + SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal + SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal + + SIGUNUSED : constant := 0; + SIGSTKFLT : constant := 0; + -- These don't exist for Linux/SPARC. The constants are present + -- so that we can continue to use a-intnam-linux.ads. + + -- struct_sigaction offsets + + sa_handler_pos : constant := 0; + sa_mask_pos : constant := Standard'Address_Size / 8; + sa_flags_pos : constant := 128 + sa_mask_pos; + + SA_SIGINFO : constant := 16#200#; + SA_ONSTACK : constant := 16#001#; + + type pthread_mutex_t is record + L1, L2, L3, L4 : Interfaces.C.long; + I1, I2 : Interfaces.C.int; + end record; + pragma Convention (C, pthread_mutex_t); + -- 24 bytes for 32-bit and 40 bytes for 64-bit, aligned like 'long' + +end System.Linux; diff --git a/gcc/ada/s-linux.ads b/gcc/ada/s-linux.ads new file mode 100644 index 000000000..29918d7d4 --- /dev/null +++ b/gcc/ada/s-linux.ads @@ -0,0 +1,119 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . L I N U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2008-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 -- +-- . -- +-- -- +-- -- +------------------------------------------------------------------------------ + +-- This is the default version of this package + +-- This package encapsulates cpu specific differences between implementations +-- of GNU/Linux, in order to share s-osinte-linux.ads. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package + +package System.Linux is + pragma Preelaborate; + + ----------- + -- Errno -- + ----------- + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + EPERM : constant := 1; + ETIMEDOUT : constant := 110; + + ------------- + -- Signals -- + ------------- + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 7; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 10; -- user defined signal 1 + SIGUSR2 : constant := 12; -- user defined signal 2 + SIGCLD : constant := 17; -- alias for SIGCHLD + SIGCHLD : constant := 17; -- child status change + SIGPWR : constant := 30; -- power-fail restart + SIGWINCH : constant := 28; -- window size change + SIGURG : constant := 23; -- urgent condition on IO channel + SIGPOLL : constant := 29; -- pollable event occurred + SIGIO : constant := 29; -- I/O now possible (4.2 BSD) + SIGLOST : constant := 29; -- File lock lost + SIGSTOP : constant := 19; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 20; -- user stop requested from tty + SIGCONT : constant := 18; -- stopped process has been continued + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 27; -- profiling timer expired + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGUNUSED : constant := 31; -- unused signal (GNU/Linux) + SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux) + SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal + SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal + SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal + + -- struct_sigaction offsets + + sa_handler_pos : constant := 0; + sa_mask_pos : constant := Standard'Address_Size / 8; + sa_flags_pos : constant := 128 + sa_mask_pos; + + SA_SIGINFO : constant := 16#04#; + SA_ONSTACK : constant := 16#08000000#; + + type struct_pthread_fast_lock is record + status : Long_Integer; + spinlock : Integer; + end record; + pragma Convention (C, struct_pthread_fast_lock); + + type pthread_mutex_t is record + m_reserved : Integer; + m_count : Integer; + m_owner : System.Address; + m_kind : Integer; + m_lock : struct_pthread_fast_lock; + end record; + pragma Convention (C, pthread_mutex_t); + +end System.Linux; diff --git a/gcc/ada/s-maccod.ads b/gcc/ada/s-maccod.ads new file mode 100644 index 000000000..c1bfbf1b8 --- /dev/null +++ b/gcc/ada/s-maccod.ads @@ -0,0 +1,126 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 Pure; + + 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 new file mode 100644 index 000000000..035362107 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..de5a6f261 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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-irix.adb b/gcc/ada/s-mastop-irix.adb new file mode 100644 index 000000000..2c8968b54 --- /dev/null +++ b/gcc/ada/s-mastop-irix.adb @@ -0,0 +1,351 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- SYSTEM.MACHINE_STATE_OPERATIONS -- +-- -- +-- B o d y -- +-- (Version for IRIX/MIPS) -- +-- -- +-- 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 version of Ada.Exceptions.Machine_State_Operations is for use on +-- SGI Irix systems. By means of compile time conditional calculations, it +-- can handle both n32/n64 and o32 modes. + +with System.Machine_Code; use System.Machine_Code; +with System.Memory; +with System.Soft_Links; use System.Soft_Links; +with Ada.Unchecked_Conversion; + +package body System.Machine_State_Operations is + + use System.Storage_Elements; + + -- The exc_unwind function in libexc operates on a Sigcontext + + -- Type sigcontext_t is defined in /usr/include/sys/signal.h. + -- We define an equivalent Ada type here. From the comments in + -- signal.h: + + -- sigcontext is not part of the ABI - so this version is used to + -- handle 32 and 64 bit applications - it is a constant size regardless + -- of compilation mode, and always returns 64 bit register values + + type Uns32 is mod 2 ** 32; + type Uns64 is mod 2 ** 64; + + type Uns32_Ptr is access all Uns32; + type Uns64_Array is array (Integer range <>) of Uns64; + + type Reg_Array is array (0 .. 31) of Uns64; + + type Sigcontext is record + SC_Regmask : Uns32; -- 0 + SC_Status : Uns32; -- 4 + SC_PC : Uns64; -- 8 + SC_Regs : Reg_Array; -- 16 + SC_Fpregs : Reg_Array; -- 272 + SC_Ownedfp : Uns32; -- 528 + SC_Fpc_Csr : Uns32; -- 532 + SC_Fpc_Eir : Uns32; -- 536 + SC_Ssflags : Uns32; -- 540 + SC_Mdhi : Uns64; -- 544 + SC_Mdlo : Uns64; -- 552 + SC_Cause : Uns64; -- 560 + SC_Badvaddr : Uns64; -- 568 + SC_Triggersave : Uns64; -- 576 + SC_Sigset : Uns64; -- 584 + SC_Fp_Rounded_Result : Uns64; -- 592 + SC_Pancake : Uns64_Array (0 .. 5); + SC_Pad : Uns64_Array (0 .. 26); + end record; + + type Sigcontext_Ptr is access all Sigcontext; + + SC_Regs_Pos : constant String := "16"; + SC_Fpregs_Pos : constant String := "272"; + -- Byte offset of the Integer and Floating Point register save areas + -- within the Sigcontext. + + function To_Sigcontext_Ptr is + new Ada.Unchecked_Conversion (Machine_State, Sigcontext_Ptr); + + type Addr_Int is mod 2 ** Long_Integer'Size; + -- An unsigned integer type whose size is the same as System.Address. + -- We rely on the fact that Long_Integer'Size = System.Address'Size in + -- all ABIs. Type Addr_Int can be converted to Uns64. + + function To_Code_Loc is + new Ada.Unchecked_Conversion (Addr_Int, Code_Loc); + function To_Addr_Int is + new Ada.Unchecked_Conversion (System.Address, Addr_Int); + function To_Uns32_Ptr is + new Ada.Unchecked_Conversion (Addr_Int, Uns32_Ptr); + + -------------------------------- + -- ABI-Dependent Declarations -- + -------------------------------- + + o32 : constant Boolean := System.Word_Size = 32; + n32 : constant Boolean := System.Word_Size = 64; + o32n : constant Natural := Boolean'Pos (o32); + n32n : constant Natural := Boolean'Pos (n32); + -- Flags to indicate which ABI is in effect for this compilation. For the + -- purposes of this unit, the n32 and n64 ABIs are identical. + + LSC : constant Character := Character'Val (o32n * Character'Pos ('w') + + n32n * Character'Pos ('d')); + -- This is 'w' for o32, and 'd' for n32/n64, used for constructing the + -- load/store instructions used to save/restore machine instructions. + + Roff : constant Character := Character'Val (o32n * Character'Pos ('4') + + n32n * Character'Pos ('0')); + -- Offset from first byte of a __uint64 register save location where + -- the register value is stored. For n32/64 we store the entire 64 + -- bit register into the uint64. For o32, only 32 bits are stored + -- at an offset of 4 bytes. This is used as part of expressions with + -- '+' signs on both sides, so a null offset has to be '0' and not ' ' + -- to avoid assembler syntax errors on "X + + Y" in the latter case. + + procedure Update_GP (Scp : Sigcontext_Ptr); + + --------------- + -- Update_GP -- + --------------- + + procedure Update_GP (Scp : Sigcontext_Ptr) is + + type F_op is mod 2 ** 6; + type F_reg is mod 2 ** 5; + type F_imm is new Short_Integer; + + type I_Type is record + op : F_op; + rs : F_reg; + rt : F_reg; + imm : F_imm; + end record; + + pragma Pack (I_Type); + for I_Type'Size use 32; + + type I_Type_Ptr is access all I_Type; + + LW : constant F_op := 2#100011#; + Reg_GP : constant := 28; + + type Address_Int is mod 2 ** Standard'Address_Size; + function To_I_Type_Ptr is new + Ada.Unchecked_Conversion (Address_Int, I_Type_Ptr); + + Ret_Ins : constant I_Type_Ptr := To_I_Type_Ptr (Address_Int (Scp.SC_PC)); + GP_Ptr : Uns32_Ptr; + + begin + if Ret_Ins.op = LW and then Ret_Ins.rt = Reg_GP then + GP_Ptr := To_Uns32_Ptr + (Addr_Int (Scp.SC_Regs (Integer (Ret_Ins.rs))) + + Addr_Int (Ret_Ins.imm)); + Scp.SC_Regs (Reg_GP) := Uns64 (GP_Ptr.all); + end if; + end Update_GP; + + ---------------------------- + -- Allocate_Machine_State -- + ---------------------------- + + function Allocate_Machine_State return Machine_State is + begin + return Machine_State + (Memory.Alloc (Sigcontext'Max_Size_In_Storage_Elements)); + 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 + Memory.Free (Address (M)); + M := Machine_State (Null_Address); + end Free_Machine_State; + + ------------------ + -- Get_Code_Loc -- + ------------------ + + function Get_Code_Loc (M : Machine_State) return Code_Loc is + SC : constant Sigcontext_Ptr := To_Sigcontext_Ptr (M); + begin + return To_Code_Loc (Addr_Int (SC.SC_PC)); + end Get_Code_Loc; + + -------------------------- + -- Machine_State_Length -- + -------------------------- + + function Machine_State_Length return Storage_Offset is + begin + return Sigcontext'Max_Size_In_Storage_Elements; + end Machine_State_Length; + + --------------- + -- Pop_Frame -- + --------------- + + procedure Pop_Frame (M : Machine_State) is + Scp : constant Sigcontext_Ptr := To_Sigcontext_Ptr (M); + + procedure Exc_Unwind (Scp : Sigcontext_Ptr; Fde : Long_Integer := 0); + pragma Import (C, Exc_Unwind, "exc_unwind"); + + pragma Linker_Options ("-lexc"); + + begin + -- exc_unwind is apparently not thread-safe under IRIX, so protect it + -- against race conditions within the GNAT run time. + -- ??? Note that we might want to use a fine grained lock here since + -- Lock_Task is used in many other places. + + Lock_Task.all; + + Exc_Unwind (Scp); + + Unlock_Task.all; + + if Scp.SC_PC = 0 or else Scp.SC_PC = 1 then + + -- A return value of 0 or 1 means exc_unwind couldn't find a parent + -- frame. Propagate_Exception expects a zero return address to + -- indicate TOS. + + Scp.SC_PC := 0; + + else + -- Set the GP to restore to the caller value (not callee value) + -- This is done only in o32 mode. In n32/n64 mode, GP is a normal + -- callee save register + + if o32 then + Update_GP (Scp); + end if; + + -- Adjust the return address to the call site, not the + -- instruction following the branch delay slot. This may + -- be necessary if the last instruction of a pragma No_Return + -- subprogram is a call. The first instruction following the + -- delay slot may be the start of another subprogram. We back + -- off the address by 8, which points safely into the middle + -- of the generated subprogram code, avoiding end effects. + + Scp.SC_PC := Scp.SC_PC - 8; + end if; + end Pop_Frame; + + ----------------------- + -- Set_Machine_State -- + ----------------------- + + procedure Set_Machine_State (M : Machine_State) is + + SI : constant String (1 .. 2) := 's' & LSC; + -- This is "sw" in o32 mode, and "sd" in n32 mode + + SF : constant String (1 .. 4) := 's' & LSC & "c1"; + -- This is "swc1" in o32 mode and "sdc1" in n32 mode + + PI : String renames SC_Regs_Pos; + PF : String renames SC_Fpregs_Pos; + + Scp : Sigcontext_Ptr; + + begin + -- Save the integer registers. Note that we know that $4 points + -- to M, since that is where the first parameter is passed. + -- Restore integer registers from machine state. Note that we know + -- that $4 points to M since this is the standard calling sequence + + <> + + Asm (SI & " $16, 16*8+" & Roff & "+" & PI & "($4)", Volatile => True); + Asm (SI & " $17, 17*8+" & Roff & "+" & PI & "($4)", Volatile => True); + Asm (SI & " $18, 18*8+" & Roff & "+" & PI & "($4)", Volatile => True); + Asm (SI & " $19, 19*8+" & Roff & "+" & PI & "($4)", Volatile => True); + Asm (SI & " $20, 20*8+" & Roff & "+" & PI & "($4)", Volatile => True); + Asm (SI & " $21, 21*8+" & Roff & "+" & PI & "($4)", Volatile => True); + Asm (SI & " $22, 22*8+" & Roff & "+" & PI & "($4)", Volatile => True); + Asm (SI & " $23, 23*8+" & Roff & "+" & PI & "($4)", Volatile => True); + Asm (SI & " $24, 24*8+" & Roff & "+" & PI & "($4)", Volatile => True); + Asm (SI & " $25, 25*8+" & Roff & "+" & PI & "($4)", Volatile => True); + Asm (SI & " $26, 26*8+" & Roff & "+" & PI & "($4)", Volatile => True); + Asm (SI & " $27, 27*8+" & Roff & "+" & PI & "($4)", Volatile => True); + Asm (SI & " $28, 28*8+" & Roff & "+" & PI & "($4)", Volatile => True); + Asm (SI & " $29, 29*8+" & Roff & "+" & PI & "($4)", Volatile => True); + Asm (SI & " $30, 30*8+" & Roff & "+" & PI & "($4)", Volatile => True); + Asm (SI & " $31, 31*8+" & Roff & "+" & PI & "($4)", Volatile => True); + + -- Restore floating-point registers from machine state + + Asm (SF & " $f16, 16*8+" & Roff & "+" & PF & "($4)", Volatile => True); + Asm (SF & " $f17, 17*8+" & Roff & "+" & PF & "($4)", Volatile => True); + Asm (SF & " $f18, 18*8+" & Roff & "+" & PF & "($4)", Volatile => True); + Asm (SF & " $f19, 19*8+" & Roff & "+" & PF & "($4)", Volatile => True); + Asm (SF & " $f20, 20*8+" & Roff & "+" & PF & "($4)", Volatile => True); + Asm (SF & " $f21, 21*8+" & Roff & "+" & PF & "($4)", Volatile => True); + Asm (SF & " $f22, 22*8+" & Roff & "+" & PF & "($4)", Volatile => True); + Asm (SF & " $f23, 23*8+" & Roff & "+" & PF & "($4)", Volatile => True); + Asm (SF & " $f24, 24*8+" & Roff & "+" & PF & "($4)", Volatile => True); + Asm (SF & " $f25, 25*8+" & Roff & "+" & PF & "($4)", Volatile => True); + Asm (SF & " $f26, 26*8+" & Roff & "+" & PF & "($4)", Volatile => True); + Asm (SF & " $f27, 27*8+" & Roff & "+" & PF & "($4)", Volatile => True); + Asm (SF & " $f28, 28*8+" & Roff & "+" & PF & "($4)", Volatile => True); + Asm (SF & " $f29, 29*8+" & Roff & "+" & PF & "($4)", Volatile => True); + Asm (SF & " $f30, 30*8+" & Roff & "+" & PF & "($4)", Volatile => True); + Asm (SF & " $f31, 31*8+" & Roff & "+" & PF & "($4)", Volatile => True); + + -- Set the PC value for the context to a location after the + -- prolog has been executed. + + Scp := To_Sigcontext_Ptr (M); + Scp.SC_PC := Uns64 (To_Addr_Int (Past_Prolog'Address)); + + -- We saved the state *inside* this routine, but what we want is + -- the state at the call site. So we need to do one pop operation. + -- This pop operation will properly set the PC value in the machine + -- state, so there is no need to save PC in the above code. + + Pop_Frame (M); + end Set_Machine_State; + +end System.Machine_State_Operations; diff --git a/gcc/ada/s-mastop-tru64.adb b/gcc/ada/s-mastop-tru64.adb new file mode 100644 index 000000000..ce379033a --- /dev/null +++ b/gcc/ada/s-mastop-tru64.adb @@ -0,0 +1,165 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- SYSTEM.MACHINE_STATE_OPERATIONS -- +-- -- +-- B o d y -- +-- (Version for Alpha/Dec Unix) -- +-- -- +-- Copyright (C) 1999-2005, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version of System.Machine_State_Operations is for use on +-- Alpha systems running DEC Unix. + +with System.Memory; + +package body System.Machine_State_Operations is + + pragma Linker_Options ("-lexc"); + -- Needed for definitions of exc_capture_context and exc_virtual_unwind + + ---------------------------- + -- Allocate_Machine_State -- + ---------------------------- + + function Allocate_Machine_State return Machine_State is + use System.Storage_Elements; + + function c_machine_state_length return Storage_Offset; + pragma Import (C, c_machine_state_length, "__gnat_machine_state_length"); + + begin + return Machine_State + (Memory.Alloc (Memory.size_t (c_machine_state_length))); + 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 + Memory.Free (Address (M)); + M := Machine_State (Null_Address); + end Free_Machine_State; + + ------------------ + -- Get_Code_Loc -- + ------------------ + + function Get_Code_Loc (M : Machine_State) return Code_Loc is + Asm_Call_Size : constant := 4; + + function c_get_code_loc (M : Machine_State) return Code_Loc; + pragma Import (C, c_get_code_loc, "__gnat_get_code_loc"); + + -- Code_Loc returned by c_get_code_loc is the return point but here we + -- want Get_Code_Loc to return the call point. Under DEC Unix a call + -- asm instruction takes 4 bytes. So we must remove this value from + -- c_get_code_loc to have the call point. + + Loc : constant Code_Loc := c_get_code_loc (M); + + begin + if Loc = 0 then + return 0; + else + return Loc - Asm_Call_Size; + end if; + end Get_Code_Loc; + + -------------------------- + -- Machine_State_Length -- + -------------------------- + + function Machine_State_Length + return System.Storage_Elements.Storage_Offset + is + use System.Storage_Elements; + + function c_machine_state_length return Storage_Offset; + pragma Import (C, c_machine_state_length, "__gnat_machine_state_length"); + + begin + return c_machine_state_length; + end Machine_State_Length; + + --------------- + -- Pop_Frame -- + --------------- + + procedure Pop_Frame (M : Machine_State) is + procedure exc_virtual_unwind (Fcn : System.Address; M : Machine_State); + pragma Import (C, exc_virtual_unwind, "exc_virtual_unwind"); + + function exc_lookup_function (Loc : Code_Loc) return System.Address; + pragma Import (C, exc_lookup_function, "exc_lookup_function_entry"); + + procedure c_set_code_loc (M : Machine_State; Loc : Code_Loc); + pragma Import (C, c_set_code_loc, "__gnat_set_code_loc"); + + -- Look for a code-range descriptor table containing the PC of the + -- specified machine state. If we don't find any, attempting to unwind + -- further would fail so we set the machine state's code location to a + -- value indicating that the top of the call chain is reached. This + -- happens when the function at the address pointed to by PC has not + -- been registered with the unwinding machinery, as with the __istart + -- functions generated by the linker in presence of initialization + -- routines for example. + + Prf : constant System.Address := exc_lookup_function (Get_Code_Loc (M)); + + begin + if Prf = System.Null_Address then + c_set_code_loc (M, 0); + else + exc_virtual_unwind (Prf, M); + end if; + end Pop_Frame; + + ----------------------- + -- Set_Machine_State -- + ----------------------- + + procedure Set_Machine_State (M : Machine_State) is + procedure c_capture_context (M : Machine_State); + pragma Import (C, c_capture_context, "exc_capture_context"); + begin + c_capture_context (M); + Pop_Frame (M); + end Set_Machine_State; + +end System.Machine_State_Operations; diff --git a/gcc/ada/s-mastop-vms.adb b/gcc/ada/s-mastop-vms.adb new file mode 100644 index 000000000..08773343c --- /dev/null +++ b/gcc/ada/s-mastop-vms.adb @@ -0,0 +1,276 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- SYSTEM.MACHINE_STATE_OPERATIONS -- +-- -- +-- B o d y -- +-- (Version for Alpha/VMS) -- +-- -- +-- Copyright (C) 2001-2007, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version of System.Machine_State_Operations is for use on +-- Alpha systems running VMS. + +with System.Memory; +with System.Aux_DEC; use System.Aux_DEC; +with Ada.Unchecked_Conversion; + +package body System.Machine_State_Operations is + + subtype Cond_Value_Type is Unsigned_Longword; + + -- Record layouts copied from Starlet + + type ICB_Fflags_Bits_Type is record + Exception_Frame : Boolean; + Ast_Frame : Boolean; + Bottom_Of_Stack : Boolean; + Base_Frame : Boolean; + Filler_1 : Unsigned_20; + end record; + + for ICB_Fflags_Bits_Type use record + Exception_Frame at 0 range 0 .. 0; + Ast_Frame at 0 range 1 .. 1; + Bottom_Of_Stack at 0 range 2 .. 2; + Base_Frame at 0 range 3 .. 3; + Filler_1 at 0 range 4 .. 23; + end record; + for ICB_Fflags_Bits_Type'Size use 24; + + type ICB_Hdr_Quad_Type is record + Context_Length : Unsigned_Longword; + Fflags_Bits : ICB_Fflags_Bits_Type; + Block_Version : Unsigned_Byte; + end record; + + for ICB_Hdr_Quad_Type use record + Context_Length at 0 range 0 .. 31; + Fflags_Bits at 4 range 0 .. 23; + Block_Version at 7 range 0 .. 7; + end record; + for ICB_Hdr_Quad_Type'Size use 64; + + type Invo_Context_Blk_Type is record + + Hdr_Quad : ICB_Hdr_Quad_Type; + -- The first quadword contains: + -- o The length of the structure in bytes (a longword field) + -- o The frame flags (a 3 byte field of bits) + -- o The version number (a 1 byte field) + + Procedure_Descriptor : Unsigned_Quadword; + -- The address of the procedure descriptor for the procedure + + Program_Counter : Integer_64; + -- The current PC of a given procedure invocation + + Processor_Status : Integer_64; + -- The current PS of a given procedure invocation + + Ireg : Unsigned_Quadword_Array (0 .. 30); + Freg : Unsigned_Quadword_Array (0 .. 30); + -- The register contents areas. 31 for scalars, 31 for float + + System_Defined : Unsigned_Quadword_Array (0 .. 1); + -- The following is an "internal" area that's reserved for use by + -- the operating system. It's size may vary over time. + + -- Chfctx_Addr : Unsigned_Quadword; + -- Defined as a comment since it overlaps other fields + + Filler_1 : String (1 .. 0); + -- Align to octaword + end record; + + for Invo_Context_Blk_Type use record + Hdr_Quad at 0 range 0 .. 63; + Procedure_Descriptor at 8 range 0 .. 63; + Program_Counter at 16 range 0 .. 63; + Processor_Status at 24 range 0 .. 63; + Ireg at 32 range 0 .. 1983; + Freg at 280 range 0 .. 1983; + System_Defined at 528 range 0 .. 127; + + -- Component representation spec(s) below are defined as + -- comments since they overlap other fields + + -- Chfctx_Addr at 528 range 0 .. 63; + + Filler_1 at 544 range 0 .. -1; + end record; + for Invo_Context_Blk_Type'Size use 4352; + + subtype Invo_Handle_Type is Unsigned_Longword; + + type Invo_Handle_Access_Type is access all Invo_Handle_Type; + + function Fetch is new Fetch_From_Address (Code_Loc); + + function To_Invo_Handle_Access is new Ada.Unchecked_Conversion + (Machine_State, Invo_Handle_Access_Type); + + function To_Machine_State is new Ada.Unchecked_Conversion + (System.Address, Machine_State); + + ---------------------------- + -- Allocate_Machine_State -- + ---------------------------- + + function Allocate_Machine_State return Machine_State is + begin + return To_Machine_State + (Memory.Alloc (Invo_Handle_Type'Max_Size_In_Storage_Elements)); + end Allocate_Machine_State; + + ---------------- + -- Fetch_Code -- + ---------------- + + function Fetch_Code (Loc : Code_Loc) return Code_Loc is + begin + -- The starting address is in the second longword pointed to by Loc + + return Fetch (System.Aux_DEC."+" (Loc, 8)); + end Fetch_Code; + + ------------------------ + -- Free_Machine_State -- + ------------------------ + + procedure Free_Machine_State (M : in out Machine_State) is + begin + Memory.Free (Address (M)); + M := Machine_State (Null_Address); + end Free_Machine_State; + + ------------------ + -- Get_Code_Loc -- + ------------------ + + function Get_Code_Loc (M : Machine_State) return Code_Loc is + procedure Get_Invo_Context ( + Result : out Unsigned_Longword; -- return value + Invo_Handle : Invo_Handle_Type; + Invo_Context : out Invo_Context_Blk_Type); + + pragma Interface (External, Get_Invo_Context); + + pragma Import_Valued_Procedure (Get_Invo_Context, "LIB$GET_INVO_CONTEXT", + (Unsigned_Longword, Invo_Handle_Type, Invo_Context_Blk_Type), + (Value, Value, Reference)); + + Asm_Call_Size : constant := 4; + -- Under VMS a call + -- asm instruction takes 4 bytes. So we must remove this amount. + + ICB : Invo_Context_Blk_Type; + Status : Cond_Value_Type; + + begin + Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB); + + if (Status and 1) /= 1 then + return Code_Loc (System.Null_Address); + end if; + + return Code_Loc (ICB.Program_Counter - Asm_Call_Size); + end Get_Code_Loc; + + -------------------------- + -- Machine_State_Length -- + -------------------------- + + function Machine_State_Length + return System.Storage_Elements.Storage_Offset + is + use System.Storage_Elements; + + begin + return Invo_Handle_Type'Size / 8; + end Machine_State_Length; + + --------------- + -- Pop_Frame -- + --------------- + + procedure Pop_Frame (M : Machine_State) is + procedure Get_Prev_Invo_Handle ( + Result : out Invo_Handle_Type; -- return value + ICB : Invo_Handle_Type); + + pragma Interface (External, Get_Prev_Invo_Handle); + + pragma Import_Valued_Procedure + (Get_Prev_Invo_Handle, "LIB$GET_PREV_INVO_HANDLE", + (Invo_Handle_Type, Invo_Handle_Type), + (Value, Value)); + + Prev_Handle : aliased Invo_Handle_Type; + + begin + Get_Prev_Invo_Handle (Prev_Handle, To_Invo_Handle_Access (M).all); + To_Invo_Handle_Access (M).all := Prev_Handle; + end Pop_Frame; + + ----------------------- + -- Set_Machine_State -- + ----------------------- + + procedure Set_Machine_State (M : Machine_State) is + + procedure Get_Curr_Invo_Context + (Invo_Context : out Invo_Context_Blk_Type); + + pragma Interface (External, Get_Curr_Invo_Context); + + pragma Import_Valued_Procedure + (Get_Curr_Invo_Context, "LIB$GET_CURR_INVO_CONTEXT", + (Invo_Context_Blk_Type), + (Reference)); + + procedure Get_Invo_Handle ( + Result : out Invo_Handle_Type; -- return value + Invo_Context : Invo_Context_Blk_Type); + + pragma Interface (External, Get_Invo_Handle); + + pragma Import_Valued_Procedure (Get_Invo_Handle, "LIB$GET_INVO_HANDLE", + (Invo_Handle_Type, Invo_Context_Blk_Type), + (Value, Reference)); + + ICB : Invo_Context_Blk_Type; + Invo_Handle : aliased Invo_Handle_Type; + + begin + Get_Curr_Invo_Context (ICB); + Get_Invo_Handle (Invo_Handle, ICB); + To_Invo_Handle_Access (M).all := Invo_Handle; + Pop_Frame (M, System.Null_Address); + end Set_Machine_State; + +end System.Machine_State_Operations; diff --git a/gcc/ada/s-mastop.adb b/gcc/ada/s-mastop.adb new file mode 100644 index 000000000..fba5bb133 --- /dev/null +++ b/gcc/ada/s-mastop.adb @@ -0,0 +1,108 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- SYSTEM.MACHINE_STATE_OPERATIONS -- +-- -- +-- B o d y -- +-- (Dummy version) -- +-- -- +-- 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 dummy version of System.Machine_State_Operations is used +-- on targets for which zero cost exception handling is not implemented. + +pragma Compiler_Unit; + +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 new file mode 100644 index 000000000..74ff217c6 --- /dev/null +++ b/gcc/ada/s-mastop.ads @@ -0,0 +1,107 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- SYSTEM.MACHINE_STATE_OPERATIONS -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit; + +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 VMS) use a descriptor to describe + -- a subprogram address. This function computes the actual starting + -- address of the code from Loc. + -- + -- ??? This function will go away when 'Code_Address is fixed on VMS. + -- + -- 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 new file mode 100644 index 000000000..96219f1e1 --- /dev/null +++ b/gcc/ada/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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 new file mode 100644 index 000000000..31fe0d8a0 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 new file mode 100644 index 000000000..3fb1cda9b --- /dev/null +++ b/gcc/ada/s-memory.adb @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 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; + +with Ada.Exceptions; +with System.Soft_Links; +with System.Parameters; +with System.CRTL; + +package body System.Memory is + + use Ada.Exceptions; + 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; + 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; + + if Parameters.No_Abort then + Result := c_malloc (System.CRTL.size_t (Actual_Size)); + else + Abort_Defer.all; + Result := c_malloc (System.CRTL.size_t (Actual_Size)); + Abort_Undefer.all; + end if; + + if Result = System.Null_Address then + Raise_Exception (Storage_Error'Identity, "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; + Actual_Size : constant size_t := Size; + + begin + if Size = size_t'Last then + Raise_Exception (Storage_Error'Identity, "object too large"); + end if; + + if Parameters.No_Abort then + Result := c_realloc (Ptr, System.CRTL.size_t (Actual_Size)); + else + Abort_Defer.all; + Result := c_realloc (Ptr, System.CRTL.size_t (Actual_Size)); + Abort_Undefer.all; + end if; + + 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.ads b/gcc/ada/s-memory.ads new file mode 100644 index 000000000..4af600205 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +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_t is set to size_t'Last on entry, then a Storage_Error + -- exception is raised with a message "object too large". + -- + -- If size_t 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_t is set to size_t'Last on entry, then a Storage_Error + -- exception is raised with a message "object too large". + -- + -- If size_t 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-multip.adb b/gcc/ada/s-multip.adb new file mode 100644 index 000000000..ea1f15c06 --- /dev/null +++ b/gcc/ada/s-multip.adb @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- 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, 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 -- +-- . -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C; use Interfaces.C; + +package body System.Multiprocessors is + + function Gnat_Number_Of_CPUs return int; + pragma Import (C, Gnat_Number_Of_CPUs, "__gnat_number_of_cpus"); + + -------------------- + -- Number_Of_CPUs -- + -------------------- + + function Number_Of_CPUs return CPU is + begin + return CPU (Gnat_Number_Of_CPUs); + end Number_Of_CPUs; + +end System.Multiprocessors; diff --git a/gcc/ada/s-multip.ads b/gcc/ada/s-multip.ads new file mode 100644 index 000000000..7eb8dd6a3 --- /dev/null +++ b/gcc/ada/s-multip.ads @@ -0,0 +1,28 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . M U L T I P R O C E S S O R S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package System.Multiprocessors is + pragma Preelaborate (Multiprocessors); + + type CPU_Range is range 0 .. 2 ** 16 - 1; + + subtype CPU is CPU_Range range 1 .. CPU_Range'Last; + + Not_A_Specific_CPU : constant CPU_Range := 0; + + function Number_Of_CPUs return CPU; + -- Number of available CPUs + +end System.Multiprocessors; diff --git a/gcc/ada/s-os_lib.adb b/gcc/ada/s-os_lib.adb new file mode 100755 index 000000000..c7ca149ab --- /dev/null +++ b/gcc/ada/s-os_lib.adb @@ -0,0 +1,2731 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . O S _ L I B -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit; + +with System.Case_Util; +with System.CRTL; +with System.Soft_Links; +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with System; use System; + +package body System.OS_Lib is + + -- Imported procedures Dup and Dup2 are used in procedures Spawn and + -- Non_Blocking_Spawn. + + function Dup (Fd : File_Descriptor) return File_Descriptor; + pragma Import (C, Dup, "__gnat_dup"); + + procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); + pragma Import (C, Dup2, "__gnat_dup2"); + + On_Windows : constant Boolean := Directory_Separator = '\'; + -- An indication that we are on Windows. Used in Normalize_Pathname, to + -- deal with drive letters in the beginning of absolute paths. + + package SSL renames System.Soft_Links; + + -- The following are used by Create_Temp_File + + First_Temp_File_Name : constant String := "GNAT-TEMP-000000.TMP"; + -- Used to initialize Current_Temp_File_Name and Temp_File_Name_Last_Digit + + Current_Temp_File_Name : String := First_Temp_File_Name; + -- Name of the temp file last created + + Temp_File_Name_Last_Digit : constant Positive := + First_Temp_File_Name'Last - 4; + -- Position of the last digit in Current_Temp_File_Name + + Max_Attempts : constant := 100; + -- The maximum number of attempts to create a new temp file + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Args_Length (Args : Argument_List) return Natural; + -- Returns total number of characters needed to create a string of all Args + -- terminated by ASCII.NUL characters. + + procedure Create_Temp_File_Internal + (FD : out File_Descriptor; + Name : out String_Access; + Stdout : Boolean); + -- Internal routine to implement two Create_Temp_File routines. If Stdout + -- is set to True the created descriptor is stdout-compatible, otherwise + -- it might not be depending on the OS (VMS is one example). The first two + -- parameters are as in Create_Temp_File. + + function C_String_Length (S : Address) return Integer; + -- Returns the length of a C string. Does check for null address + -- (returns 0). + + procedure Spawn_Internal + (Program_Name : String; + Args : Argument_List; + Result : out Integer; + Pid : out Process_Id; + Blocking : Boolean); + -- Internal routine to implement the two Spawn (blocking/non blocking) + -- routines. If Blocking is set to True then the spawn is blocking + -- otherwise it is non blocking. In this latter case the Pid contains the + -- process id number. The first three parameters are as in Spawn. Note that + -- Spawn_Internal normalizes the argument list before calling the low level + -- system spawn routines (see Normalize_Arguments). + -- + -- Note: Normalize_Arguments is designed to do nothing if it is called more + -- than once, so calling Normalize_Arguments before calling one of the + -- spawn routines is fine. + + function To_Path_String_Access + (Path_Addr : Address; + Path_Len : Integer) return String_Access; + -- Converts a C String to an Ada String. We could do this making use of + -- Interfaces.C.Strings but we prefer not to import that entire package + + --------- + -- "<" -- + --------- + + function "<" (X, Y : OS_Time) return Boolean is + begin + return Long_Integer (X) < Long_Integer (Y); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" (X, Y : OS_Time) return Boolean is + begin + return Long_Integer (X) <= Long_Integer (Y); + end "<="; + + --------- + -- ">" -- + --------- + + function ">" (X, Y : OS_Time) return Boolean is + begin + return Long_Integer (X) > Long_Integer (Y); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" (X, Y : OS_Time) return Boolean is + begin + return Long_Integer (X) >= Long_Integer (Y); + end ">="; + + ----------------- + -- Args_Length -- + ----------------- + + function Args_Length (Args : Argument_List) return Natural is + Len : Natural := 0; + + begin + for J in Args'Range loop + Len := Len + Args (J)'Length + 1; -- One extra for ASCII.NUL + end loop; + + return Len; + end Args_Length; + + ----------------------------- + -- Argument_String_To_List -- + ----------------------------- + + function Argument_String_To_List + (Arg_String : String) return Argument_List_Access + is + Max_Args : constant Integer := Arg_String'Length; + New_Argv : Argument_List (1 .. Max_Args); + New_Argc : Natural := 0; + Idx : Integer; + + begin + Idx := Arg_String'First; + + loop + exit when Idx > Arg_String'Last; + + declare + Quoted : Boolean := False; + Backqd : Boolean := False; + Old_Idx : Integer; + + begin + Old_Idx := Idx; + + loop + -- An unquoted space is the end of an argument + + if not (Backqd or Quoted) + and then Arg_String (Idx) = ' ' + then + exit; + + -- Start of a quoted string + + elsif not (Backqd or Quoted) + and then Arg_String (Idx) = '"' + then + Quoted := True; + + -- End of a quoted string and end of an argument + + elsif (Quoted and not Backqd) + and then Arg_String (Idx) = '"' + then + Idx := Idx + 1; + exit; + + -- Following character is backquoted + + elsif Arg_String (Idx) = '\' then + Backqd := True; + + -- Turn off backquoting after advancing one character + + elsif Backqd then + Backqd := False; + + end if; + + Idx := Idx + 1; + exit when Idx > Arg_String'Last; + end loop; + + -- Found an argument + + New_Argc := New_Argc + 1; + New_Argv (New_Argc) := + new String'(Arg_String (Old_Idx .. Idx - 1)); + + -- Skip extraneous spaces + + while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop + Idx := Idx + 1; + end loop; + end; + end loop; + + return new Argument_List'(New_Argv (1 .. New_Argc)); + end Argument_String_To_List; + + --------------------- + -- C_String_Length -- + --------------------- + + function C_String_Length (S : Address) return Integer is + function Strlen (S : Address) return Integer; + pragma Import (C, Strlen, "strlen"); + begin + if S = Null_Address then + return 0; + else + return Strlen (S); + end if; + end C_String_Length; + + ----------- + -- Close -- + ----------- + + procedure Close (FD : File_Descriptor) is + procedure C_Close (FD : File_Descriptor); + pragma Import (C, C_Close, "close"); + begin + C_Close (FD); + end Close; + + procedure Close (FD : File_Descriptor; Status : out Boolean) is + function C_Close (FD : File_Descriptor) return Integer; + pragma Import (C, C_Close, "close"); + begin + Status := (C_Close (FD) = 0); + end Close; + + --------------- + -- Copy_File -- + --------------- + + procedure Copy_File + (Name : String; + Pathname : String; + Success : out Boolean; + Mode : Copy_Mode := Copy; + Preserve : Attribute := Time_Stamps) + is + From : File_Descriptor; + To : File_Descriptor; + + Copy_Error : exception; + -- Internal exception raised to signal error in copy + + function Build_Path (Dir : String; File : String) return String; + -- Returns pathname Dir concatenated with File adding the directory + -- separator only if needed. + + procedure Copy (From, To : File_Descriptor); + -- Read data from From and place them into To. In both cases the + -- operations uses the current file position. Raises Constraint_Error + -- if a problem occurs during the copy. + + procedure Copy_To (To_Name : String); + -- Does a straight copy from source to designated destination file + + ---------------- + -- Build_Path -- + ---------------- + + function Build_Path (Dir : String; File : String) return String is + Res : String (1 .. Dir'Length + File'Length + 1); + + Base_File_Ptr : Integer; + -- The base file name is File (Base_File_Ptr + 1 .. File'Last) + + function Is_Dirsep (C : Character) return Boolean; + pragma Inline (Is_Dirsep); + -- Returns True if C is a directory separator. On Windows we + -- handle both styles of directory separator. + + --------------- + -- Is_Dirsep -- + --------------- + + function Is_Dirsep (C : Character) return Boolean is + begin + return C = Directory_Separator or else C = '/'; + end Is_Dirsep; + + -- Start of processing for Build_Path + + begin + -- Find base file name + + Base_File_Ptr := File'Last; + while Base_File_Ptr >= File'First loop + exit when Is_Dirsep (File (Base_File_Ptr)); + Base_File_Ptr := Base_File_Ptr - 1; + end loop; + + declare + Base_File : String renames + File (Base_File_Ptr + 1 .. File'Last); + + begin + Res (1 .. Dir'Length) := Dir; + + if Is_Dirsep (Dir (Dir'Last)) then + Res (Dir'Length + 1 .. Dir'Length + Base_File'Length) := + Base_File; + return Res (1 .. Dir'Length + Base_File'Length); + + else + Res (Dir'Length + 1) := Directory_Separator; + Res (Dir'Length + 2 .. Dir'Length + 1 + Base_File'Length) := + Base_File; + return Res (1 .. Dir'Length + 1 + Base_File'Length); + end if; + end; + end Build_Path; + + ---------- + -- Copy -- + ---------- + + procedure Copy (From, To : File_Descriptor) is + Buf_Size : constant := 200_000; + type Buf is array (1 .. Buf_Size) of Character; + type Buf_Ptr is access Buf; + + Buffer : Buf_Ptr; + R : Integer; + W : Integer; + + Status_From : Boolean; + Status_To : Boolean; + -- Statuses for the calls to Close + + procedure Free is new Ada.Unchecked_Deallocation (Buf, Buf_Ptr); + + begin + -- Check for invalid descriptors, making sure that we do not + -- accidentally leave an open file descriptor around. + + if From = Invalid_FD then + if To /= Invalid_FD then + Close (To, Status_To); + end if; + + raise Copy_Error; + + elsif To = Invalid_FD then + Close (From, Status_From); + raise Copy_Error; + end if; + + -- Allocate the buffer on the heap + + Buffer := new Buf; + + loop + R := Read (From, Buffer (1)'Address, Buf_Size); + + -- For VMS, the buffer may not be full. So, we need to try again + -- until there is nothing to read. + + exit when R = 0; + + W := Write (To, Buffer (1)'Address, R); + + if W < R then + + -- Problem writing data, could be a disk full. Close files + -- without worrying about status, since we are raising a + -- Copy_Error exception in any case. + + Close (From, Status_From); + Close (To, Status_To); + + Free (Buffer); + + raise Copy_Error; + end if; + end loop; + + Close (From, Status_From); + Close (To, Status_To); + + Free (Buffer); + + if not (Status_From and Status_To) then + raise Copy_Error; + end if; + end Copy; + + ------------- + -- Copy_To -- + ------------- + + procedure Copy_To (To_Name : String) is + + function Copy_Attributes + (From, To : System.Address; + Mode : Integer) return Integer; + pragma Import (C, Copy_Attributes, "__gnat_copy_attribs"); + -- Mode = 0 - copy only time stamps. + -- Mode = 1 - copy time stamps and read/write/execute attributes + + C_From : String (1 .. Name'Length + 1); + C_To : String (1 .. To_Name'Length + 1); + + begin + From := Open_Read (Name, Binary); + + -- Do not clobber destination file if source file could not be opened + + if From /= Invalid_FD then + To := Create_File (To_Name, Binary); + end if; + + Copy (From, To); + + -- Copy attributes + + C_From (1 .. Name'Length) := Name; + C_From (C_From'Last) := ASCII.NUL; + + C_To (1 .. To_Name'Length) := To_Name; + C_To (C_To'Last) := ASCII.NUL; + + case Preserve is + + when Time_Stamps => + if Copy_Attributes (C_From'Address, C_To'Address, 0) = -1 then + raise Copy_Error; + end if; + + when Full => + if Copy_Attributes (C_From'Address, C_To'Address, 1) = -1 then + raise Copy_Error; + end if; + + when None => + null; + end case; + + end Copy_To; + + -- Start of processing for Copy_File + + begin + Success := True; + + -- The source file must exist + + if not Is_Regular_File (Name) then + raise Copy_Error; + end if; + + -- The source file exists + + case Mode is + + -- Copy case, target file must not exist + + when Copy => + + -- If the target file exists, we have an error + + if Is_Regular_File (Pathname) then + raise Copy_Error; + + -- Case of target is a directory + + elsif Is_Directory (Pathname) then + declare + Dest : constant String := Build_Path (Pathname, Name); + + begin + -- If target file exists, we have an error, else do copy + + if Is_Regular_File (Dest) then + raise Copy_Error; + else + Copy_To (Dest); + end if; + end; + + -- Case of normal copy to file (destination does not exist) + + else + Copy_To (Pathname); + end if; + + -- Overwrite case (destination file may or may not exist) + + when Overwrite => + if Is_Directory (Pathname) then + Copy_To (Build_Path (Pathname, Name)); + else + Copy_To (Pathname); + end if; + + -- Append case (destination file may or may not exist) + + when Append => + + -- Appending to existing file + + if Is_Regular_File (Pathname) then + + -- Append mode and destination file exists, append data at the + -- end of Pathname. But if we fail to open source file, do not + -- touch destination file at all. + + From := Open_Read (Name, Binary); + if From /= Invalid_FD then + To := Open_Read_Write (Pathname, Binary); + end if; + + Lseek (To, 0, Seek_End); + + Copy (From, To); + + -- Appending to directory, not allowed + + elsif Is_Directory (Pathname) then + raise Copy_Error; + + -- Appending when target file does not exist + + else + Copy_To (Pathname); + end if; + end case; + + -- All error cases are caught here + + exception + when Copy_Error => + Success := False; + end Copy_File; + + procedure Copy_File + (Name : C_File_Name; + Pathname : C_File_Name; + Success : out Boolean; + Mode : Copy_Mode := Copy; + Preserve : Attribute := Time_Stamps) + is + Ada_Name : String_Access := + To_Path_String_Access + (Name, C_String_Length (Name)); + Ada_Pathname : String_Access := + To_Path_String_Access + (Pathname, C_String_Length (Pathname)); + begin + Copy_File (Ada_Name.all, Ada_Pathname.all, Success, Mode, Preserve); + Free (Ada_Name); + Free (Ada_Pathname); + end Copy_File; + + ---------------------- + -- Copy_Time_Stamps -- + ---------------------- + + procedure Copy_Time_Stamps (Source, Dest : String; Success : out Boolean) is + + function Copy_Attributes + (From, To : System.Address; + Mode : Integer) return Integer; + pragma Import (C, Copy_Attributes, "__gnat_copy_attribs"); + -- Mode = 0 - copy only time stamps. + -- Mode = 1 - copy time stamps and read/write/execute attributes + + begin + if Is_Regular_File (Source) and then Is_Writable_File (Dest) then + declare + C_Source : String (1 .. Source'Length + 1); + C_Dest : String (1 .. Dest'Length + 1); + + begin + C_Source (1 .. Source'Length) := Source; + C_Source (C_Source'Last) := ASCII.NUL; + + C_Dest (1 .. Dest'Length) := Dest; + C_Dest (C_Dest'Last) := ASCII.NUL; + + if Copy_Attributes (C_Source'Address, C_Dest'Address, 0) = -1 then + Success := False; + else + Success := True; + end if; + end; + + else + Success := False; + end if; + end Copy_Time_Stamps; + + procedure Copy_Time_Stamps + (Source, Dest : C_File_Name; + Success : out Boolean) + is + Ada_Source : String_Access := + To_Path_String_Access + (Source, C_String_Length (Source)); + Ada_Dest : String_Access := + To_Path_String_Access + (Dest, C_String_Length (Dest)); + begin + Copy_Time_Stamps (Ada_Source.all, Ada_Dest.all, Success); + Free (Ada_Source); + Free (Ada_Dest); + end Copy_Time_Stamps; + + ----------------- + -- Create_File -- + ----------------- + + function Create_File + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor + is + function C_Create_File + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + pragma Import (C, C_Create_File, "__gnat_open_create"); + + begin + return C_Create_File (Name, Fmode); + end Create_File; + + function Create_File + (Name : String; + Fmode : Mode) return File_Descriptor + is + C_Name : String (1 .. Name'Length + 1); + + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return Create_File (C_Name (C_Name'First)'Address, Fmode); + end Create_File; + + --------------------- + -- Create_New_File -- + --------------------- + + function Create_New_File + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor + is + function C_Create_New_File + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + pragma Import (C, C_Create_New_File, "__gnat_open_new"); + + begin + return C_Create_New_File (Name, Fmode); + end Create_New_File; + + function Create_New_File + (Name : String; + Fmode : Mode) return File_Descriptor + is + C_Name : String (1 .. Name'Length + 1); + + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return Create_New_File (C_Name (C_Name'First)'Address, Fmode); + end Create_New_File; + + ----------------------------- + -- Create_Output_Text_File -- + ----------------------------- + + function Create_Output_Text_File (Name : String) return File_Descriptor is + function C_Create_File + (Name : C_File_Name) return File_Descriptor; + pragma Import (C, C_Create_File, "__gnat_create_output_file"); + + C_Name : String (1 .. Name'Length + 1); + + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return C_Create_File (C_Name (C_Name'First)'Address); + end Create_Output_Text_File; + + ---------------------- + -- Create_Temp_File -- + ---------------------- + + procedure Create_Temp_File + (FD : out File_Descriptor; + Name : out Temp_File_Name) + is + function Open_New_Temp + (Name : System.Address; + Fmode : Mode) return File_Descriptor; + pragma Import (C, Open_New_Temp, "__gnat_open_new_temp"); + + begin + FD := Open_New_Temp (Name'Address, Binary); + end Create_Temp_File; + + procedure Create_Temp_File + (FD : out File_Descriptor; + Name : out String_Access) + is + begin + Create_Temp_File_Internal (FD, Name, Stdout => False); + end Create_Temp_File; + + procedure Create_Temp_Output_File + (FD : out File_Descriptor; + Name : out String_Access) + is + begin + Create_Temp_File_Internal (FD, Name, Stdout => True); + end Create_Temp_Output_File; + + ------------------------------- + -- Create_Temp_File_Internal -- + ------------------------------- + + procedure Create_Temp_File_Internal + (FD : out File_Descriptor; + Name : out String_Access; + Stdout : Boolean) + is + Pos : Positive; + Attempts : Natural := 0; + Current : String (Current_Temp_File_Name'Range); + + --------------------------------- + -- Create_New_Output_Text_File -- + --------------------------------- + + function Create_New_Output_Text_File + (Name : String) return File_Descriptor; + -- Similar to Create_Output_Text_File, except it fails if the file + -- already exists. We need this behavior to ensure we don't accidentally + -- open a temp file that has just been created by a concurrently running + -- process. There is no point exposing this function, as it's generally + -- not particularly useful. + + function Create_New_Output_Text_File + (Name : String) return File_Descriptor is + function C_Create_File + (Name : C_File_Name) return File_Descriptor; + pragma Import (C, C_Create_File, "__gnat_create_output_file_new"); + + C_Name : String (1 .. Name'Length + 1); + + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return C_Create_File (C_Name (C_Name'First)'Address); + end Create_New_Output_Text_File; + + begin + -- Loop until a new temp file can be created + + File_Loop : loop + Locked : begin + -- We need to protect global variable Current_Temp_File_Name + -- against concurrent access by different tasks. + + SSL.Lock_Task.all; + + -- Start at the last digit + + Pos := Temp_File_Name_Last_Digit; + + Digit_Loop : + loop + -- Increment the digit by one + + case Current_Temp_File_Name (Pos) is + when '0' .. '8' => + Current_Temp_File_Name (Pos) := + Character'Succ (Current_Temp_File_Name (Pos)); + exit Digit_Loop; + + when '9' => + + -- For 9, set the digit to 0 and go to the previous digit + + Current_Temp_File_Name (Pos) := '0'; + Pos := Pos - 1; + + when others => + + -- If it is not a digit, then there are no available + -- temp file names. Return Invalid_FD. There is almost + -- no chance that this code will be ever be executed, + -- since it would mean that there are one million temp + -- files in the same directory! + + SSL.Unlock_Task.all; + FD := Invalid_FD; + Name := null; + exit File_Loop; + end case; + end loop Digit_Loop; + + Current := Current_Temp_File_Name; + + -- We can now release the lock, because we are no longer + -- accessing Current_Temp_File_Name. + + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Locked; + + -- Attempt to create the file + + if Stdout then + FD := Create_New_Output_Text_File (Current); + else + FD := Create_New_File (Current, Binary); + end if; + + if FD /= Invalid_FD then + Name := new String'(Current); + exit File_Loop; + end if; + + if not Is_Regular_File (Current) then + + -- If the file does not already exist and we are unable to create + -- it, we give up after Max_Attempts. Otherwise, we try again with + -- the next available file name. + + Attempts := Attempts + 1; + + if Attempts >= Max_Attempts then + FD := Invalid_FD; + Name := null; + exit File_Loop; + end if; + end if; + end loop File_Loop; + end Create_Temp_File_Internal; + + ----------------- + -- Delete_File -- + ----------------- + + procedure Delete_File (Name : Address; Success : out Boolean) is + R : Integer; + begin + R := System.CRTL.unlink (Name); + Success := (R = 0); + end Delete_File; + + procedure Delete_File (Name : String; Success : out Boolean) is + C_Name : String (1 .. Name'Length + 1); + + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + + Delete_File (C_Name'Address, Success); + end Delete_File; + + --------------------- + -- File_Time_Stamp -- + --------------------- + + function File_Time_Stamp (FD : File_Descriptor) return OS_Time is + function File_Time (FD : File_Descriptor) return OS_Time; + pragma Import (C, File_Time, "__gnat_file_time_fd"); + begin + return File_Time (FD); + end File_Time_Stamp; + + function File_Time_Stamp (Name : C_File_Name) return OS_Time is + function File_Time (Name : Address) return OS_Time; + pragma Import (C, File_Time, "__gnat_file_time_name"); + begin + return File_Time (Name); + end File_Time_Stamp; + + function File_Time_Stamp (Name : String) return OS_Time is + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return File_Time_Stamp (F_Name'Address); + end File_Time_Stamp; + + --------------------------- + -- Get_Debuggable_Suffix -- + --------------------------- + + function Get_Debuggable_Suffix return String_Access is + procedure Get_Suffix_Ptr (Length, Ptr : Address); + pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr"); + + procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); + pragma Import (C, Strncpy, "strncpy"); + + Suffix_Ptr : Address; + Suffix_Length : Integer; + Result : String_Access; + + begin + Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); + + Result := new String (1 .. Suffix_Length); + + if Suffix_Length > 0 then + Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length); + end if; + + return Result; + end Get_Debuggable_Suffix; + + --------------------------- + -- Get_Executable_Suffix -- + --------------------------- + + function Get_Executable_Suffix return String_Access is + procedure Get_Suffix_Ptr (Length, Ptr : Address); + pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr"); + + procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); + pragma Import (C, Strncpy, "strncpy"); + + Suffix_Ptr : Address; + Suffix_Length : Integer; + Result : String_Access; + + begin + Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); + + Result := new String (1 .. Suffix_Length); + + if Suffix_Length > 0 then + Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length); + end if; + + return Result; + end Get_Executable_Suffix; + + ----------------------- + -- Get_Object_Suffix -- + ----------------------- + + function Get_Object_Suffix return String_Access is + procedure Get_Suffix_Ptr (Length, Ptr : Address); + pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr"); + + procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); + pragma Import (C, Strncpy, "strncpy"); + + Suffix_Ptr : Address; + Suffix_Length : Integer; + Result : String_Access; + + begin + Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); + + Result := new String (1 .. Suffix_Length); + + if Suffix_Length > 0 then + Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length); + end if; + + return Result; + end Get_Object_Suffix; + + ---------------------------------- + -- Get_Target_Debuggable_Suffix -- + ---------------------------------- + + function Get_Target_Debuggable_Suffix return String_Access is + Target_Exec_Ext_Ptr : Address; + pragma Import + (C, Target_Exec_Ext_Ptr, "__gnat_target_debuggable_extension"); + + procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); + pragma Import (C, Strncpy, "strncpy"); + + function Strlen (Cstring : Address) return Integer; + pragma Import (C, Strlen, "strlen"); + + Suffix_Length : Integer; + Result : String_Access; + + begin + Suffix_Length := Strlen (Target_Exec_Ext_Ptr); + + Result := new String (1 .. Suffix_Length); + + if Suffix_Length > 0 then + Strncpy (Result.all'Address, Target_Exec_Ext_Ptr, Suffix_Length); + end if; + + return Result; + end Get_Target_Debuggable_Suffix; + + ---------------------------------- + -- Get_Target_Executable_Suffix -- + ---------------------------------- + + function Get_Target_Executable_Suffix return String_Access is + Target_Exec_Ext_Ptr : Address; + pragma Import + (C, Target_Exec_Ext_Ptr, "__gnat_target_executable_extension"); + + procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); + pragma Import (C, Strncpy, "strncpy"); + + function Strlen (Cstring : Address) return Integer; + pragma Import (C, Strlen, "strlen"); + + Suffix_Length : Integer; + Result : String_Access; + + begin + Suffix_Length := Strlen (Target_Exec_Ext_Ptr); + + Result := new String (1 .. Suffix_Length); + + if Suffix_Length > 0 then + Strncpy (Result.all'Address, Target_Exec_Ext_Ptr, Suffix_Length); + end if; + + return Result; + end Get_Target_Executable_Suffix; + + ------------------------------ + -- Get_Target_Object_Suffix -- + ------------------------------ + + function Get_Target_Object_Suffix return String_Access is + Target_Object_Ext_Ptr : Address; + pragma Import + (C, Target_Object_Ext_Ptr, "__gnat_target_object_extension"); + + procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); + pragma Import (C, Strncpy, "strncpy"); + + function Strlen (Cstring : Address) return Integer; + pragma Import (C, Strlen, "strlen"); + + Suffix_Length : Integer; + Result : String_Access; + + begin + Suffix_Length := Strlen (Target_Object_Ext_Ptr); + + Result := new String (1 .. Suffix_Length); + + if Suffix_Length > 0 then + Strncpy (Result.all'Address, Target_Object_Ext_Ptr, Suffix_Length); + end if; + + return Result; + end Get_Target_Object_Suffix; + + ------------ + -- Getenv -- + ------------ + + function Getenv (Name : String) return String_Access is + procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); + pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv"); + + procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); + pragma Import (C, Strncpy, "strncpy"); + + Env_Value_Ptr : aliased Address; + Env_Value_Length : aliased Integer; + F_Name : aliased String (1 .. Name'Length + 1); + Result : String_Access; + + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + + Get_Env_Value_Ptr + (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address); + + Result := new String (1 .. Env_Value_Length); + + if Env_Value_Length > 0 then + Strncpy (Result.all'Address, Env_Value_Ptr, Env_Value_Length); + end if; + + return Result; + end Getenv; + + ------------ + -- GM_Day -- + ------------ + + function GM_Day (Date : OS_Time) return Day_Type is + D : Day_Type; + + pragma Warnings (Off); + Y : Year_Type; + Mo : Month_Type; + H : Hour_Type; + Mn : Minute_Type; + S : Second_Type; + pragma Warnings (On); + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return D; + end GM_Day; + + ------------- + -- GM_Hour -- + ------------- + + function GM_Hour (Date : OS_Time) return Hour_Type is + H : Hour_Type; + + pragma Warnings (Off); + Y : Year_Type; + Mo : Month_Type; + D : Day_Type; + Mn : Minute_Type; + S : Second_Type; + pragma Warnings (On); + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return H; + end GM_Hour; + + --------------- + -- GM_Minute -- + --------------- + + function GM_Minute (Date : OS_Time) return Minute_Type is + Mn : Minute_Type; + + pragma Warnings (Off); + Y : Year_Type; + Mo : Month_Type; + D : Day_Type; + H : Hour_Type; + S : Second_Type; + pragma Warnings (On); + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return Mn; + end GM_Minute; + + -------------- + -- GM_Month -- + -------------- + + function GM_Month (Date : OS_Time) return Month_Type is + Mo : Month_Type; + + pragma Warnings (Off); + Y : Year_Type; + D : Day_Type; + H : Hour_Type; + Mn : Minute_Type; + S : Second_Type; + pragma Warnings (On); + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return Mo; + end GM_Month; + + --------------- + -- GM_Second -- + --------------- + + function GM_Second (Date : OS_Time) return Second_Type is + S : Second_Type; + + pragma Warnings (Off); + Y : Year_Type; + Mo : Month_Type; + D : Day_Type; + H : Hour_Type; + Mn : Minute_Type; + pragma Warnings (On); + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return S; + end GM_Second; + + -------------- + -- GM_Split -- + -------------- + + procedure GM_Split + (Date : OS_Time; + Year : out Year_Type; + Month : out Month_Type; + Day : out Day_Type; + Hour : out Hour_Type; + Minute : out Minute_Type; + Second : out Second_Type) + is + procedure To_GM_Time + (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address); + pragma Import (C, To_GM_Time, "__gnat_to_gm_time"); + + T : OS_Time := Date; + Y : Integer; + Mo : Integer; + D : Integer; + H : Integer; + Mn : Integer; + S : Integer; + + begin + -- Use the global lock because To_GM_Time is not thread safe + + Locked_Processing : begin + SSL.Lock_Task.all; + To_GM_Time + (T'Address, Y'Address, Mo'Address, D'Address, + H'Address, Mn'Address, S'Address); + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Locked_Processing; + + Year := Y + 1900; + Month := Mo + 1; + Day := D; + Hour := H; + Minute := Mn; + Second := S; + end GM_Split; + + ------------- + -- GM_Year -- + ------------- + + function GM_Year (Date : OS_Time) return Year_Type is + Y : Year_Type; + + pragma Warnings (Off); + Mo : Month_Type; + D : Day_Type; + H : Hour_Type; + Mn : Minute_Type; + S : Second_Type; + pragma Warnings (On); + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return Y; + end GM_Year; + + ---------------------- + -- Is_Absolute_Path -- + ---------------------- + + function Is_Absolute_Path (Name : String) return Boolean is + function Is_Absolute_Path + (Name : Address; + Length : Integer) return Integer; + pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path"); + begin + return Is_Absolute_Path (Name'Address, Name'Length) /= 0; + end Is_Absolute_Path; + + ------------------ + -- Is_Directory -- + ------------------ + + function Is_Directory (Name : C_File_Name) return Boolean is + function Is_Directory (Name : Address) return Integer; + pragma Import (C, Is_Directory, "__gnat_is_directory"); + begin + return Is_Directory (Name) /= 0; + end Is_Directory; + + function Is_Directory (Name : String) return Boolean is + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Directory (F_Name'Address); + end Is_Directory; + + ---------------------- + -- Is_Readable_File -- + ---------------------- + + function Is_Readable_File (Name : C_File_Name) return Boolean is + function Is_Readable_File (Name : Address) return Integer; + pragma Import (C, Is_Readable_File, "__gnat_is_readable_file"); + begin + return Is_Readable_File (Name) /= 0; + end Is_Readable_File; + + function Is_Readable_File (Name : String) return Boolean is + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Readable_File (F_Name'Address); + end Is_Readable_File; + + ------------------------ + -- Is_Executable_File -- + ------------------------ + + function Is_Executable_File (Name : C_File_Name) return Boolean is + function Is_Executable_File (Name : Address) return Integer; + pragma Import (C, Is_Executable_File, "__gnat_is_executable_file"); + begin + return Is_Executable_File (Name) /= 0; + end Is_Executable_File; + + function Is_Executable_File (Name : String) return Boolean is + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Executable_File (F_Name'Address); + end Is_Executable_File; + + --------------------- + -- Is_Regular_File -- + --------------------- + + function Is_Regular_File (Name : C_File_Name) return Boolean is + function Is_Regular_File (Name : Address) return Integer; + pragma Import (C, Is_Regular_File, "__gnat_is_regular_file"); + begin + return Is_Regular_File (Name) /= 0; + end Is_Regular_File; + + function Is_Regular_File (Name : String) return Boolean is + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Regular_File (F_Name'Address); + end Is_Regular_File; + + ---------------------- + -- Is_Symbolic_Link -- + ---------------------- + + function Is_Symbolic_Link (Name : C_File_Name) return Boolean is + function Is_Symbolic_Link (Name : Address) return Integer; + pragma Import (C, Is_Symbolic_Link, "__gnat_is_symbolic_link"); + begin + return Is_Symbolic_Link (Name) /= 0; + end Is_Symbolic_Link; + + function Is_Symbolic_Link (Name : String) return Boolean is + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Symbolic_Link (F_Name'Address); + end Is_Symbolic_Link; + + ---------------------- + -- Is_Writable_File -- + ---------------------- + + function Is_Writable_File (Name : C_File_Name) return Boolean is + function Is_Writable_File (Name : Address) return Integer; + pragma Import (C, Is_Writable_File, "__gnat_is_writable_file"); + begin + return Is_Writable_File (Name) /= 0; + end Is_Writable_File; + + function Is_Writable_File (Name : String) return Boolean is + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Writable_File (F_Name'Address); + end Is_Writable_File; + + ------------------------- + -- Locate_Exec_On_Path -- + ------------------------- + + function Locate_Exec_On_Path + (Exec_Name : String) return String_Access + is + function Locate_Exec_On_Path (C_Exec_Name : Address) return Address; + pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path"); + + procedure Free (Ptr : System.Address); + pragma Import (C, Free, "free"); + + C_Exec_Name : String (1 .. Exec_Name'Length + 1); + Path_Addr : Address; + Path_Len : Integer; + Result : String_Access; + + begin + C_Exec_Name (1 .. Exec_Name'Length) := Exec_Name; + C_Exec_Name (C_Exec_Name'Last) := ASCII.NUL; + + Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address); + Path_Len := C_String_Length (Path_Addr); + + if Path_Len = 0 then + return null; + + else + Result := To_Path_String_Access (Path_Addr, Path_Len); + Free (Path_Addr); + + -- Always return an absolute path name + + if not Is_Absolute_Path (Result.all) then + declare + Absolute_Path : constant String := + Normalize_Pathname (Result.all); + begin + Free (Result); + Result := new String'(Absolute_Path); + end; + end if; + + return Result; + end if; + end Locate_Exec_On_Path; + + ------------------------- + -- Locate_Regular_File -- + ------------------------- + + function Locate_Regular_File + (File_Name : C_File_Name; + Path : C_File_Name) return String_Access + is + function Locate_Regular_File + (C_File_Name, Path_Val : Address) return Address; + pragma Import (C, Locate_Regular_File, "__gnat_locate_regular_file"); + + procedure Free (Ptr : System.Address); + pragma Import (C, Free, "free"); + + Path_Addr : Address; + Path_Len : Integer; + Result : String_Access; + + begin + Path_Addr := Locate_Regular_File (File_Name, Path); + Path_Len := C_String_Length (Path_Addr); + + if Path_Len = 0 then + return null; + + else + Result := To_Path_String_Access (Path_Addr, Path_Len); + Free (Path_Addr); + return Result; + end if; + end Locate_Regular_File; + + function Locate_Regular_File + (File_Name : String; + Path : String) return String_Access + is + C_File_Name : String (1 .. File_Name'Length + 1); + C_Path : String (1 .. Path'Length + 1); + Result : String_Access; + + begin + C_File_Name (1 .. File_Name'Length) := File_Name; + C_File_Name (C_File_Name'Last) := ASCII.NUL; + + C_Path (1 .. Path'Length) := Path; + C_Path (C_Path'Last) := ASCII.NUL; + + Result := Locate_Regular_File (C_File_Name'Address, C_Path'Address); + + -- Always return an absolute path name + + if Result /= null and then not Is_Absolute_Path (Result.all) then + declare + Absolute_Path : constant String := Normalize_Pathname (Result.all); + begin + Free (Result); + Result := new String'(Absolute_Path); + end; + end if; + + return Result; + end Locate_Regular_File; + + ------------------------ + -- Non_Blocking_Spawn -- + ------------------------ + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List) return Process_Id + is + Pid : Process_Id; + Junk : Integer; + pragma Warnings (Off, Junk); + begin + Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False); + return Pid; + end Non_Blocking_Spawn; + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List; + Output_File_Descriptor : File_Descriptor; + Err_To_Out : Boolean := True) return Process_Id + is + Saved_Output : File_Descriptor; + Saved_Error : File_Descriptor := Invalid_FD; -- prevent warning + Pid : Process_Id; + + begin + if Output_File_Descriptor = Invalid_FD then + return Invalid_Pid; + end if; + + -- Set standard output and, if specified, error to the temporary file + + Saved_Output := Dup (Standout); + Dup2 (Output_File_Descriptor, Standout); + + if Err_To_Out then + Saved_Error := Dup (Standerr); + Dup2 (Output_File_Descriptor, Standerr); + end if; + + -- Spawn the program + + Pid := Non_Blocking_Spawn (Program_Name, Args); + + -- Restore the standard output and error + + Dup2 (Saved_Output, Standout); + + if Err_To_Out then + Dup2 (Saved_Error, Standerr); + end if; + + -- And close the saved standard output and error file descriptors + + Close (Saved_Output); + + if Err_To_Out then + Close (Saved_Error); + end if; + + return Pid; + end Non_Blocking_Spawn; + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List; + Output_File : String; + Err_To_Out : Boolean := True) return Process_Id + is + Output_File_Descriptor : constant File_Descriptor := + Create_Output_Text_File (Output_File); + Result : Process_Id; + + begin + -- Do not attempt to spawn if the output file could not be created + + if Output_File_Descriptor = Invalid_FD then + return Invalid_Pid; + + else + Result := Non_Blocking_Spawn + (Program_Name, Args, Output_File_Descriptor, Err_To_Out); + + -- Close the file just created for the output, as the file descriptor + -- cannot be used anywhere, being a local value. It is safe to do + -- that, as the file descriptor has been duplicated to form + -- standard output and error of the spawned process. + + Close (Output_File_Descriptor); + + return Result; + end if; + end Non_Blocking_Spawn; + + ------------------------- + -- Normalize_Arguments -- + ------------------------- + + procedure Normalize_Arguments (Args : in out Argument_List) is + + procedure Quote_Argument (Arg : in out String_Access); + -- Add quote around argument if it contains spaces + + C_Argument_Needs_Quote : Integer; + pragma Import (C, C_Argument_Needs_Quote, "__gnat_argument_needs_quote"); + Argument_Needs_Quote : constant Boolean := C_Argument_Needs_Quote /= 0; + + -------------------- + -- Quote_Argument -- + -------------------- + + procedure Quote_Argument (Arg : in out String_Access) is + Res : String (1 .. Arg'Length * 2); + J : Positive := 1; + Quote_Needed : Boolean := False; + + begin + if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then + + -- Starting quote + + Res (J) := '"'; + + for K in Arg'Range loop + + J := J + 1; + + if Arg (K) = '"' then + Res (J) := '\'; + J := J + 1; + Res (J) := '"'; + Quote_Needed := True; + + elsif Arg (K) = ' ' then + Res (J) := Arg (K); + Quote_Needed := True; + + else + Res (J) := Arg (K); + end if; + + end loop; + + if Quote_Needed then + + -- If null terminated string, put the quote before + + if Res (J) = ASCII.NUL then + Res (J) := '"'; + J := J + 1; + Res (J) := ASCII.NUL; + + -- If argument is terminated by '\', then double it. Otherwise + -- the ending quote will be taken as-is. This is quite strange + -- spawn behavior from Windows, but this is what we see! + + else + if Res (J) = '\' then + J := J + 1; + Res (J) := '\'; + end if; + + -- Ending quote + + J := J + 1; + Res (J) := '"'; + end if; + + declare + Old : String_Access := Arg; + + begin + Arg := new String'(Res (1 .. J)); + Free (Old); + end; + end if; + + end if; + end Quote_Argument; + + -- Start of processing for Normalize_Arguments + + begin + if Argument_Needs_Quote then + for K in Args'Range loop + if Args (K) /= null and then Args (K)'Length /= 0 then + Quote_Argument (Args (K)); + end if; + end loop; + end if; + end Normalize_Arguments; + + ------------------------ + -- Normalize_Pathname -- + ------------------------ + + function Normalize_Pathname + (Name : String; + Directory : String := ""; + Resolve_Links : Boolean := True; + Case_Sensitive : Boolean := True) return String + is + Max_Path : Integer; + pragma Import (C, Max_Path, "__gnat_max_path_len"); + -- Maximum length of a path name + + procedure Get_Current_Dir + (Dir : System.Address; + Length : System.Address); + pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir"); + + Path_Buffer : String (1 .. Max_Path + Max_Path + 2); + End_Path : Natural := 0; + Link_Buffer : String (1 .. Max_Path + 2); + Status : Integer; + Last : Positive; + Start : Natural; + Finish : Positive; + + Max_Iterations : constant := 500; + + function Get_File_Names_Case_Sensitive return Integer; + pragma Import + (C, Get_File_Names_Case_Sensitive, + "__gnat_get_file_names_case_sensitive"); + + Fold_To_Lower_Case : constant Boolean := + not Case_Sensitive + and then Get_File_Names_Case_Sensitive = 0; + + function Readlink + (Path : System.Address; + Buf : System.Address; + Bufsiz : Integer) return Integer; + pragma Import (C, Readlink, "__gnat_readlink"); + + function To_Canonical_File_Spec + (Host_File : System.Address) return System.Address; + pragma Import + (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec"); + + The_Name : String (1 .. Name'Length + 1); + Canonical_File_Addr : System.Address; + Canonical_File_Len : Integer; + + function Strlen (S : System.Address) return Integer; + pragma Import (C, Strlen, "strlen"); + + function Final_Value (S : String) return String; + -- Make final adjustment to the returned string. This function strips + -- trailing directory separators, and folds returned string to lower + -- case if required. + + function Get_Directory (Dir : String) return String; + -- If Dir is not empty, return it, adding a directory separator + -- if not already present, otherwise return current working directory + -- with terminating directory separator. + + ----------------- + -- Final_Value -- + ----------------- + + function Final_Value (S : String) return String is + S1 : String := S; + -- We may need to fold S to lower case, so we need a variable + + Last : Natural; + + begin + if Fold_To_Lower_Case then + System.Case_Util.To_Lower (S1); + end if; + + -- Remove trailing directory separator, if any + + Last := S1'Last; + + if Last > 1 + and then (S1 (Last) = '/' + or else + S1 (Last) = Directory_Separator) + then + -- Special case for Windows: C:\ + + if Last = 3 + and then S1 (1) /= Directory_Separator + and then S1 (2) = ':' + then + null; + + else + Last := Last - 1; + end if; + end if; + + return S1 (1 .. Last); + end Final_Value; + + ------------------- + -- Get_Directory -- + ------------------- + + function Get_Directory (Dir : String) return String is + Result : String (1 .. Dir'Length + 1); + Length : constant Natural := Dir'Length; + + begin + -- Directory given, add directory separator if needed + + if Length > 0 then + Result (1 .. Length) := Dir; + + -- On Windows, change all '/' to '\' + + if On_Windows then + for J in 1 .. Length loop + if Result (J) = '/' then + Result (J) := Directory_Separator; + end if; + end loop; + end if; + + -- Add directory separator, if needed + + if Result (Length) = Directory_Separator then + return Result (1 .. Length); + else + Result (Result'Length) := Directory_Separator; + return Result; + end if; + + -- Directory name not given, get current directory + + else + declare + Buffer : String (1 .. Max_Path + 2); + Path_Len : Natural := Max_Path; + + begin + Get_Current_Dir (Buffer'Address, Path_Len'Address); + + if Buffer (Path_Len) /= Directory_Separator then + Path_Len := Path_Len + 1; + Buffer (Path_Len) := Directory_Separator; + end if; + + -- By default, the drive letter on Windows is in upper case + + if On_Windows + and then Path_Len >= 2 + and then Buffer (2) = ':' + then + System.Case_Util.To_Upper (Buffer (1 .. 1)); + end if; + + return Buffer (1 .. Path_Len); + end; + end if; + end Get_Directory; + + -- Start of processing for Normalize_Pathname + + begin + -- Special case, if name is null, then return null + + if Name'Length = 0 then + return ""; + end if; + + -- First, convert VMS file spec to Unix file spec. + -- If Name is not in VMS syntax, then this is equivalent + -- to put Name at the beginning of Path_Buffer. + + VMS_Conversion : begin + The_Name (1 .. Name'Length) := Name; + The_Name (The_Name'Last) := ASCII.NUL; + + Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address); + Canonical_File_Len := Strlen (Canonical_File_Addr); + + -- If VMS syntax conversion has failed, return an empty string + -- to indicate the failure. + + if Canonical_File_Len = 0 then + return ""; + end if; + + declare + subtype Path_String is String (1 .. Canonical_File_Len); + type Path_String_Access is access Path_String; + + function Address_To_Access is new + Ada.Unchecked_Conversion (Source => Address, + Target => Path_String_Access); + + Path_Access : constant Path_String_Access := + Address_To_Access (Canonical_File_Addr); + + begin + Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all; + End_Path := Canonical_File_Len; + Last := 1; + end; + end VMS_Conversion; + + -- Replace all '/' by Directory Separators (this is for Windows) + + if Directory_Separator /= '/' then + for Index in 1 .. End_Path loop + if Path_Buffer (Index) = '/' then + Path_Buffer (Index) := Directory_Separator; + end if; + end loop; + end if; + + -- Resolve directory names for Windows (formerly also VMS) + + -- On VMS, if we have a Unix path such as /temp/..., and TEMP is a + -- logical name, we must not try to resolve this logical name, because + -- it may have multiple equivalences and if resolved we will only + -- get the first one. + + if On_Windows then + + -- On Windows, if we have an absolute path starting with a directory + -- separator, we need to have the drive letter appended in front. + + -- On Windows, Get_Current_Dir will return a suitable directory name + -- (path starting with a drive letter on Windows). So we take this + -- drive letter and prepend it to the current path. + + if Path_Buffer (1) = Directory_Separator + and then Path_Buffer (2) /= Directory_Separator + then + declare + Cur_Dir : constant String := Get_Directory (""); + -- Get the current directory to get the drive letter + + begin + if Cur_Dir'Length > 2 + and then Cur_Dir (Cur_Dir'First + 1) = ':' + then + Path_Buffer (3 .. End_Path + 2) := + Path_Buffer (1 .. End_Path); + Path_Buffer (1 .. 2) := + Cur_Dir (Cur_Dir'First .. Cur_Dir'First + 1); + End_Path := End_Path + 2; + end if; + end; + + -- We have a drive letter, ensure it is upper-case + + elsif Path_Buffer (1) in 'a' .. 'z' + and then Path_Buffer (2) = ':' + then + System.Case_Util.To_Upper (Path_Buffer (1 .. 1)); + end if; + end if; + + -- On Windows, remove all double-quotes that are possibly part of the + -- path but can cause problems with other methods. + + if On_Windows then + declare + Index : Natural; + + begin + Index := Path_Buffer'First; + for Current in Path_Buffer'First .. End_Path loop + if Path_Buffer (Current) /= '"' then + Path_Buffer (Index) := Path_Buffer (Current); + Index := Index + 1; + end if; + end loop; + + End_Path := Index - 1; + end; + end if; + + -- Start the conversions + + -- If this is not finished after Max_Iterations, give up and return an + -- empty string. + + for J in 1 .. Max_Iterations loop + + -- If we don't have an absolute pathname, prepend the directory + -- Reference_Dir. + + if Last = 1 + and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path)) + then + declare + Reference_Dir : constant String := Get_Directory (Directory); + Ref_Dir_Len : constant Natural := Reference_Dir'Length; + -- Current directory name specified and its length + + begin + Path_Buffer (Ref_Dir_Len + 1 .. Ref_Dir_Len + End_Path) := + Path_Buffer (1 .. End_Path); + End_Path := Ref_Dir_Len + End_Path; + Path_Buffer (1 .. Ref_Dir_Len) := Reference_Dir; + Last := Ref_Dir_Len; + end; + end if; + + Start := Last + 1; + Finish := Last; + + -- Ensure that Windows network drives are kept, e.g: \\server\drive-c + + if Start = 2 + and then Directory_Separator = '\' + and then Path_Buffer (1 .. 2) = "\\" + then + Start := 3; + end if; + + -- If we have traversed the full pathname, return it + + if Start > End_Path then + return Final_Value (Path_Buffer (1 .. End_Path)); + end if; + + -- Remove duplicate directory separators + + while Path_Buffer (Start) = Directory_Separator loop + if Start = End_Path then + return Final_Value (Path_Buffer (1 .. End_Path - 1)); + + else + Path_Buffer (Start .. End_Path - 1) := + Path_Buffer (Start + 1 .. End_Path); + End_Path := End_Path - 1; + end if; + end loop; + + -- Find the end of the current field: last character or the one + -- preceding the next directory separator. + + while Finish < End_Path + and then Path_Buffer (Finish + 1) /= Directory_Separator + loop + Finish := Finish + 1; + end loop; + + -- Remove "." field + + if Start = Finish and then Path_Buffer (Start) = '.' then + if Start = End_Path then + if Last = 1 then + return (1 => Directory_Separator); + else + + if Fold_To_Lower_Case then + System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1)); + end if; + + return Path_Buffer (1 .. Last - 1); + + end if; + + else + Path_Buffer (Last + 1 .. End_Path - 2) := + Path_Buffer (Last + 3 .. End_Path); + End_Path := End_Path - 2; + end if; + + -- Remove ".." fields + + elsif Finish = Start + 1 + and then Path_Buffer (Start .. Finish) = ".." + then + Start := Last; + loop + Start := Start - 1; + exit when Start < 1 or else + Path_Buffer (Start) = Directory_Separator; + end loop; + + if Start <= 1 then + if Finish = End_Path then + return (1 => Directory_Separator); + + else + Path_Buffer (1 .. End_Path - Finish) := + Path_Buffer (Finish + 1 .. End_Path); + End_Path := End_Path - Finish; + Last := 1; + end if; + + else + if Finish = End_Path then + return Final_Value (Path_Buffer (1 .. Start - 1)); + + else + Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) := + Path_Buffer (Finish + 2 .. End_Path); + End_Path := Start + End_Path - Finish - 1; + Last := Start; + end if; + end if; + + -- Check if current field is a symbolic link + + elsif Resolve_Links then + declare + Saved : constant Character := Path_Buffer (Finish + 1); + + begin + Path_Buffer (Finish + 1) := ASCII.NUL; + Status := Readlink (Path_Buffer'Address, + Link_Buffer'Address, + Link_Buffer'Length); + Path_Buffer (Finish + 1) := Saved; + end; + + -- Not a symbolic link, move to the next field, if any + + if Status <= 0 then + Last := Finish + 1; + + -- Replace symbolic link with its value + + else + if Is_Absolute_Path (Link_Buffer (1 .. Status)) then + Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) := + Path_Buffer (Finish + 1 .. End_Path); + End_Path := End_Path - (Finish - Status); + Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status); + Last := 1; + + else + Path_Buffer + (Last + Status + 1 .. End_Path - Finish + Last + Status) := + Path_Buffer (Finish + 1 .. End_Path); + End_Path := End_Path - Finish + Last + Status; + Path_Buffer (Last + 1 .. Last + Status) := + Link_Buffer (1 .. Status); + end if; + end if; + + else + Last := Finish + 1; + end if; + end loop; + + -- Too many iterations: give up + + -- This can happen when there is a circularity in the symbolic links: A + -- is a symbolic link for B, which itself is a symbolic link, and the + -- target of B or of another symbolic link target of B is A. In this + -- case, we return an empty string to indicate failure to resolve. + + return ""; + end Normalize_Pathname; + + --------------- + -- Open_Read -- + --------------- + + function Open_Read + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor + is + function C_Open_Read + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + pragma Import (C, C_Open_Read, "__gnat_open_read"); + begin + return C_Open_Read (Name, Fmode); + end Open_Read; + + function Open_Read + (Name : String; + Fmode : Mode) return File_Descriptor + is + C_Name : String (1 .. Name'Length + 1); + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return Open_Read (C_Name (C_Name'First)'Address, Fmode); + end Open_Read; + + --------------------- + -- Open_Read_Write -- + --------------------- + + function Open_Read_Write + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor + is + function C_Open_Read_Write + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + pragma Import (C, C_Open_Read_Write, "__gnat_open_rw"); + begin + return C_Open_Read_Write (Name, Fmode); + end Open_Read_Write; + + function Open_Read_Write + (Name : String; + Fmode : Mode) return File_Descriptor + is + C_Name : String (1 .. Name'Length + 1); + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode); + end Open_Read_Write; + + ------------- + -- OS_Exit -- + ------------- + + procedure OS_Exit (Status : Integer) is + begin + OS_Exit_Ptr (Status); + raise Program_Error; + end OS_Exit; + + --------------------- + -- OS_Exit_Default -- + --------------------- + + procedure OS_Exit_Default (Status : Integer) is + procedure GNAT_OS_Exit (Status : Integer); + pragma Import (C, GNAT_OS_Exit, "__gnat_os_exit"); + pragma No_Return (GNAT_OS_Exit); + begin + GNAT_OS_Exit (Status); + end OS_Exit_Default; + + -------------------- + -- Pid_To_Integer -- + -------------------- + + function Pid_To_Integer (Pid : Process_Id) return Integer is + begin + return Integer (Pid); + end Pid_To_Integer; + + ---------- + -- Read -- + ---------- + + function Read + (FD : File_Descriptor; + A : System.Address; + N : Integer) return Integer + is + begin + return + Integer (System.CRTL.read + (System.CRTL.int (FD), + System.CRTL.chars (A), + System.CRTL.size_t (N))); + end Read; + + ----------------- + -- Rename_File -- + ----------------- + + procedure Rename_File + (Old_Name : C_File_Name; + New_Name : C_File_Name; + Success : out Boolean) + is + function rename (From, To : Address) return Integer; + pragma Import (C, rename, "__gnat_rename"); + R : Integer; + begin + R := rename (Old_Name, New_Name); + Success := (R = 0); + end Rename_File; + + procedure Rename_File + (Old_Name : String; + New_Name : String; + Success : out Boolean) + is + C_Old_Name : String (1 .. Old_Name'Length + 1); + C_New_Name : String (1 .. New_Name'Length + 1); + begin + C_Old_Name (1 .. Old_Name'Length) := Old_Name; + C_Old_Name (C_Old_Name'Last) := ASCII.NUL; + C_New_Name (1 .. New_Name'Length) := New_Name; + C_New_Name (C_New_Name'Last) := ASCII.NUL; + Rename_File (C_Old_Name'Address, C_New_Name'Address, Success); + end Rename_File; + + ----------------------- + -- Set_Close_On_Exec -- + ----------------------- + + procedure Set_Close_On_Exec + (FD : File_Descriptor; + Close_On_Exec : Boolean; + Status : out Boolean) + is + function C_Set_Close_On_Exec + (FD : File_Descriptor; Close_On_Exec : System.CRTL.int) + return System.CRTL.int; + pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec"); + begin + Status := C_Set_Close_On_Exec (FD, Boolean'Pos (Close_On_Exec)) = 0; + end Set_Close_On_Exec; + + -------------------- + -- Set_Executable -- + -------------------- + + procedure Set_Executable (Name : String) is + procedure C_Set_Executable (Name : C_File_Name); + pragma Import (C, C_Set_Executable, "__gnat_set_executable"); + C_Name : aliased String (Name'First .. Name'Last + 1); + begin + C_Name (Name'Range) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + C_Set_Executable (C_Name (C_Name'First)'Address); + end Set_Executable; + + ---------------------- + -- Set_Non_Readable -- + ---------------------- + + procedure Set_Non_Readable (Name : String) is + procedure C_Set_Non_Readable (Name : C_File_Name); + pragma Import (C, C_Set_Non_Readable, "__gnat_set_non_readable"); + C_Name : aliased String (Name'First .. Name'Last + 1); + begin + C_Name (Name'Range) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + C_Set_Non_Readable (C_Name (C_Name'First)'Address); + end Set_Non_Readable; + + ---------------------- + -- Set_Non_Writable -- + ---------------------- + + procedure Set_Non_Writable (Name : String) is + procedure C_Set_Non_Writable (Name : C_File_Name); + pragma Import (C, C_Set_Non_Writable, "__gnat_set_non_writable"); + C_Name : aliased String (Name'First .. Name'Last + 1); + begin + C_Name (Name'Range) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + C_Set_Non_Writable (C_Name (C_Name'First)'Address); + end Set_Non_Writable; + + ------------------ + -- Set_Readable -- + ------------------ + + procedure Set_Readable (Name : String) is + procedure C_Set_Readable (Name : C_File_Name); + pragma Import (C, C_Set_Readable, "__gnat_set_readable"); + C_Name : aliased String (Name'First .. Name'Last + 1); + begin + C_Name (Name'Range) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + C_Set_Readable (C_Name (C_Name'First)'Address); + end Set_Readable; + + -------------------- + -- Set_Writable -- + -------------------- + + procedure Set_Writable (Name : String) is + procedure C_Set_Writable (Name : C_File_Name); + pragma Import (C, C_Set_Writable, "__gnat_set_writable"); + C_Name : aliased String (Name'First .. Name'Last + 1); + begin + C_Name (Name'Range) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + C_Set_Writable (C_Name (C_Name'First)'Address); + end Set_Writable; + + ------------ + -- Setenv -- + ------------ + + procedure Setenv (Name : String; Value : String) is + F_Name : String (1 .. Name'Length + 1); + F_Value : String (1 .. Value'Length + 1); + + procedure Set_Env_Value (Name, Value : System.Address); + pragma Import (C, Set_Env_Value, "__gnat_setenv"); + + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + + F_Value (1 .. Value'Length) := Value; + F_Value (F_Value'Last) := ASCII.NUL; + + Set_Env_Value (F_Name'Address, F_Value'Address); + end Setenv; + + ----------- + -- Spawn -- + ----------- + + function Spawn + (Program_Name : String; + Args : Argument_List) return Integer + is + Result : Integer; + Junk : Process_Id; + pragma Warnings (Off, Junk); + begin + Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True); + return Result; + end Spawn; + + procedure Spawn + (Program_Name : String; + Args : Argument_List; + Success : out Boolean) + is + begin + Success := (Spawn (Program_Name, Args) = 0); + end Spawn; + + procedure Spawn + (Program_Name : String; + Args : Argument_List; + Output_File_Descriptor : File_Descriptor; + Return_Code : out Integer; + Err_To_Out : Boolean := True) + is + Saved_Output : File_Descriptor; + Saved_Error : File_Descriptor := Invalid_FD; -- prevent compiler warning + + begin + -- Set standard output and error to the temporary file + + Saved_Output := Dup (Standout); + Dup2 (Output_File_Descriptor, Standout); + + if Err_To_Out then + Saved_Error := Dup (Standerr); + Dup2 (Output_File_Descriptor, Standerr); + end if; + + -- Spawn the program + + Return_Code := Spawn (Program_Name, Args); + + -- Restore the standard output and error + + Dup2 (Saved_Output, Standout); + + if Err_To_Out then + Dup2 (Saved_Error, Standerr); + end if; + + -- And close the saved standard output and error file descriptors + + Close (Saved_Output); + + if Err_To_Out then + Close (Saved_Error); + end if; + end Spawn; + + procedure Spawn + (Program_Name : String; + Args : Argument_List; + Output_File : String; + Success : out Boolean; + Return_Code : out Integer; + Err_To_Out : Boolean := True) + is + FD : File_Descriptor; + + begin + Success := True; + Return_Code := 0; + + FD := Create_Output_Text_File (Output_File); + + if FD = Invalid_FD then + Success := False; + return; + end if; + + Spawn (Program_Name, Args, FD, Return_Code, Err_To_Out); + + Close (FD, Success); + end Spawn; + + -------------------- + -- Spawn_Internal -- + -------------------- + + procedure Spawn_Internal + (Program_Name : String; + Args : Argument_List; + Result : out Integer; + Pid : out Process_Id; + Blocking : Boolean) + is + + procedure Spawn (Args : Argument_List); + -- Call Spawn with given argument list + + N_Args : Argument_List (Args'Range); + -- Normalized arguments + + ----------- + -- Spawn -- + ----------- + + procedure Spawn (Args : Argument_List) is + type Chars is array (Positive range <>) of aliased Character; + type Char_Ptr is access constant Character; + + Command_Len : constant Positive := Program_Name'Length + 1 + + Args_Length (Args); + Command_Last : Natural := 0; + Command : aliased Chars (1 .. Command_Len); + -- Command contains all characters of the Program_Name and Args, all + -- terminated by ASCII.NUL characters. + + Arg_List_Len : constant Positive := Args'Length + 2; + Arg_List_Last : Natural := 0; + Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr; + -- List with pointers to NUL-terminated strings of the Program_Name + -- and the Args and terminated with a null pointer. We rely on the + -- default initialization for the last null pointer. + + procedure Add_To_Command (S : String); + -- Add S and a NUL character to Command, updating Last + + function Portable_Spawn (Args : Address) return Integer; + pragma Import (C, Portable_Spawn, "__gnat_portable_spawn"); + + function Portable_No_Block_Spawn (Args : Address) return Process_Id; + pragma Import + (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn"); + + -------------------- + -- Add_To_Command -- + -------------------- + + procedure Add_To_Command (S : String) is + First : constant Natural := Command_Last + 1; + + begin + Command_Last := Command_Last + S'Length; + + -- Move characters one at a time, because Command has aliased + -- components. + + -- But not volatile, so why is this necessary ??? + + for J in S'Range loop + Command (First + J - S'First) := S (J); + end loop; + + Command_Last := Command_Last + 1; + Command (Command_Last) := ASCII.NUL; + + Arg_List_Last := Arg_List_Last + 1; + Arg_List (Arg_List_Last) := Command (First)'Access; + end Add_To_Command; + + -- Start of processing for Spawn + + begin + Add_To_Command (Program_Name); + + for J in Args'Range loop + Add_To_Command (Args (J).all); + end loop; + + if Blocking then + Pid := Invalid_Pid; + Result := Portable_Spawn (Arg_List'Address); + else + Pid := Portable_No_Block_Spawn (Arg_List'Address); + Result := Boolean'Pos (Pid /= Invalid_Pid); + end if; + end Spawn; + + -- Start of processing for Spawn_Internal + + begin + -- Copy arguments into a local structure + + for K in N_Args'Range loop + N_Args (K) := new String'(Args (K).all); + end loop; + + -- Normalize those arguments + + Normalize_Arguments (N_Args); + + -- Call spawn using the normalized arguments + + Spawn (N_Args); + + -- Free arguments list + + for K in N_Args'Range loop + Free (N_Args (K)); + end loop; + end Spawn_Internal; + + --------------------------- + -- To_Path_String_Access -- + --------------------------- + + function To_Path_String_Access + (Path_Addr : Address; + Path_Len : Integer) return String_Access + is + subtype Path_String is String (1 .. Path_Len); + type Path_String_Access is access Path_String; + + function Address_To_Access is new Ada.Unchecked_Conversion + (Source => Address, Target => Path_String_Access); + + Path_Access : constant Path_String_Access := + Address_To_Access (Path_Addr); + + Return_Val : String_Access; + + begin + Return_Val := new String (1 .. Path_Len); + + for J in 1 .. Path_Len loop + Return_Val (J) := Path_Access (J); + end loop; + + return Return_Val; + end To_Path_String_Access; + + ------------------ + -- Wait_Process -- + ------------------ + + procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is + Status : Integer; + + function Portable_Wait (S : Address) return Process_Id; + pragma Import (C, Portable_Wait, "__gnat_portable_wait"); + + begin + Pid := Portable_Wait (Status'Address); + Success := (Status = 0); + end Wait_Process; + + ----------- + -- Write -- + ----------- + + function Write + (FD : File_Descriptor; + A : System.Address; + N : Integer) return Integer + is + begin + return + Integer (System.CRTL.write + (System.CRTL.int (FD), + System.CRTL.chars (A), + System.CRTL.size_t (N))); + end Write; + +end System.OS_Lib; diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/s-os_lib.ads new file mode 100755 index 000000000..a6418debf --- /dev/null +++ b/gcc/ada/s-os_lib.ads @@ -0,0 +1,992 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . O S _ L I B -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-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. -- +-- -- +------------------------------------------------------------------------------ + +-- Operating system interface facilities + +-- This package contains types and procedures for interfacing to the +-- underlying OS. It is used by the GNAT compiler and by tools associated +-- with the GNAT compiler, and therefore works for the various operating +-- systems to which GNAT has been ported. This package will undoubtedly grow +-- as new services are needed by various tools. + +-- This package tends to use fairly low-level Ada in order to not bring in +-- large portions of the RTL. For example, functions return access to string +-- as part of avoiding functions returning unconstrained types. + +-- Except where specifically noted, these routines are portable across all +-- GNAT implementations on all supported operating systems. + +-- Note: this package is in the System hierarchy so that it can be directly +-- be used by other predefined packages. User access to this package is via +-- a renaming of this package in GNAT.OS_Lib (file g-os_lib.ads). + +pragma Compiler_Unit; + +with System; +with System.Strings; + +package System.OS_Lib is + pragma Elaborate_Body (OS_Lib); + + ----------------------- + -- String Operations -- + ----------------------- + + -- These are reexported from package Strings (which was introduced to + -- avoid different packages declaring different types unnecessarily). + -- See package System.Strings for details. + + subtype String_Access is Strings.String_Access; + + function "=" (Left, Right : String_Access) return Boolean + renames Strings."="; + + procedure Free (X : in out String_Access) renames Strings.Free; + + subtype String_List is Strings.String_List; + + function "=" (Left, Right : String_List) return Boolean + renames Strings."="; + + function "&" (Left : String_Access; Right : String_Access) + return String_List renames Strings."&"; + function "&" (Left : String_Access; Right : String_List) + return String_List renames Strings."&"; + function "&" (Left : String_List; Right : String_Access) + return String_List renames Strings."&"; + function "&" (Left : String_List; Right : String_List) + return String_List renames Strings."&"; + + subtype String_List_Access is Strings.String_List_Access; + + function "=" (Left, Right : String_List_Access) return Boolean + renames Strings."="; + + procedure Free (Arg : in out String_List_Access) + renames Strings.Free; + + --------------------- + -- Time/Date Stuff -- + --------------------- + + type OS_Time is private; + -- The OS's notion of time is represented by the private type OS_Time. + -- This is the type returned by the File_Time_Stamp functions to obtain + -- the time stamp of a specified file. Functions and a procedure (modeled + -- after the similar subprograms in package Calendar) are provided for + -- extracting information from a value of this type. Although these are + -- called GM, the intention is not that they provide GMT times in all + -- cases but rather the actual (time-zone independent) time stamp of the + -- file (of course in Unix systems, this *is* in GMT form). + + Invalid_Time : constant OS_Time; + -- A special unique value used to flag an invalid time stamp value + + subtype Year_Type is Integer range 1900 .. 2099; + subtype Month_Type is Integer range 1 .. 12; + subtype Day_Type is Integer range 1 .. 31; + subtype Hour_Type is Integer range 0 .. 23; + subtype Minute_Type is Integer range 0 .. 59; + subtype Second_Type is Integer range 0 .. 59; + -- Declarations similar to those in Calendar, breaking down the time + + function Current_Time return OS_Time; + -- Return the system clock value as OS_Time + + function GM_Year (Date : OS_Time) return Year_Type; + function GM_Month (Date : OS_Time) return Month_Type; + function GM_Day (Date : OS_Time) return Day_Type; + function GM_Hour (Date : OS_Time) return Hour_Type; + function GM_Minute (Date : OS_Time) return Minute_Type; + function GM_Second (Date : OS_Time) return Second_Type; + -- Functions to extract information from OS_Time value + + function "<" (X, Y : OS_Time) return Boolean; + function ">" (X, Y : OS_Time) return Boolean; + function ">=" (X, Y : OS_Time) return Boolean; + function "<=" (X, Y : OS_Time) return Boolean; + -- Basic comparison operators on OS_Time with obvious meanings. Note that + -- these have Intrinsic convention, so for example it is not permissible + -- to create accesses to any of these functions. + + procedure GM_Split + (Date : OS_Time; + Year : out Year_Type; + Month : out Month_Type; + Day : out Day_Type; + Hour : out Hour_Type; + Minute : out Minute_Type; + Second : out Second_Type); + -- Analogous to the Split routine in Ada.Calendar, takes an OS_Time and + -- provides a representation of it as a set of component parts, to be + -- interpreted as a date point in UTC. + + ---------------- + -- File Stuff -- + ---------------- + + -- These routines give access to the open/creat/close/read/write level of + -- I/O routines in the typical C library (these functions are not part of + -- the ANSI C standard, but are typically available in all systems). See + -- also package Interfaces.C_Streams for access to the stream level + -- routines. + + -- Note on file names. If a file name is passed as type String in any of + -- the following specifications, then the name is a normal Ada string and + -- need not be NUL-terminated. However, a trailing NUL character is + -- permitted, and will be ignored (more accurately, the NUL and any + -- characters that follow it will be ignored). + + type File_Descriptor is new Integer; + -- Corresponds to the int file handle values used in the C routines + + Standin : constant File_Descriptor := 0; + Standout : constant File_Descriptor := 1; + Standerr : constant File_Descriptor := 2; + -- File descriptors for standard input output files + + Invalid_FD : constant File_Descriptor := -1; + -- File descriptor returned when error in opening/creating file; + + type Mode is (Binary, Text); + for Mode'Size use Integer'Size; + for Mode use (Binary => 0, Text => 1); + -- Used in all the Open and Create calls to specify if the file is to be + -- opened in binary mode or text mode. In systems like Unix, this has no + -- effect, but in systems capable of text mode translation, the use of + -- Text as the mode parameter causes the system to do CR/LF translation + -- and also to recognize the DOS end of file character on input. The use + -- of Text where appropriate allows programs to take a portable Unix view + -- of DOS-format files and process them appropriately. + + function Open_Read + (Name : String; + Fmode : Mode) return File_Descriptor; + -- Open file Name for reading, returning file descriptor File descriptor + -- returned is Invalid_FD if file cannot be opened. + + function Open_Read_Write + (Name : String; + Fmode : Mode) return File_Descriptor; + -- Open file Name for both reading and writing, returning file descriptor. + -- File descriptor returned is Invalid_FD if file cannot be opened. + + function Create_File + (Name : String; + Fmode : Mode) return File_Descriptor; + -- Creates new file with given name for writing, returning file descriptor + -- for subsequent use in Write calls. If the file already exists, it is + -- overwritten. File descriptor returned is Invalid_FD if file cannot be + -- successfully created. + + function Create_Output_Text_File (Name : String) return File_Descriptor; + -- Creates new text file with given name suitable to redirect standard + -- output, returning file descriptor. File descriptor returned is + -- Invalid_FD if file cannot be successfully created. + + function Create_New_File + (Name : String; + Fmode : Mode) return File_Descriptor; + -- Create new file with given name for writing, returning file descriptor + -- for subsequent use in Write calls. This differs from Create_File in + -- that it fails if the file already exists. File descriptor returned is + -- Invalid_FD if the file exists or cannot be created. + + Temp_File_Len : constant Integer := 12; + -- Length of name returned by Create_Temp_File call (GNAT-XXXXXX & NUL) + + subtype Temp_File_Name is String (1 .. Temp_File_Len); + -- String subtype set by Create_Temp_File + + procedure Create_Temp_File + (FD : out File_Descriptor; + Name : out Temp_File_Name); + -- Create and open for writing a temporary file in the current working + -- directory. The name of the file and the File Descriptor are returned. + -- The File Descriptor returned is Invalid_FD in the case of failure. No + -- mode parameter is provided. Since this is a temporary file, there is no + -- point in doing text translation on it. + -- + -- On some operating systems, the maximum number of temp files that can be + -- created with this procedure may be limited. When the maximum is reached, + -- this procedure returns Invalid_FD. On some operating systems, there may + -- be a race condition between processes trying to create temp files at the + -- same time in the same directory using this procedure. + + procedure Create_Temp_File + (FD : out File_Descriptor; + Name : out String_Access); + -- Create and open for writing a temporary file in the current working + -- directory. The name of the file and the File Descriptor are returned. + -- It is the responsibility of the caller to deallocate the access value + -- returned in Name. + -- + -- The file is opened in binary mode (no text translation). + -- + -- This procedure will always succeed if the current working directory is + -- writable. If the current working directory is not writable, then + -- Invalid_FD is returned for the file descriptor and null for the Name. + -- There is no race condition problem between processes trying to create + -- temp files at the same time in the same directory. + + procedure Create_Temp_Output_File + (FD : out File_Descriptor; + Name : out String_Access); + -- Create and open for writing a temporary file in the current working + -- directory suitable to redirect standard output. The name of the file and + -- the File Descriptor are returned. It is the responsibility of the caller + -- to deallocate the access value returned in Name. + -- + -- The file is opened in text mode + -- + -- This procedure will always succeed if the current working directory is + -- writable. If the current working directory is not writable, then + -- Invalid_FD is returned for the file descriptor and null for the Name. + -- There is no race condition problem between processes trying to create + -- temp files at the same time in the same directory. + + procedure Close (FD : File_Descriptor; Status : out Boolean); + -- Close file referenced by FD. Status is False if the underlying service + -- failed. Reasons for failure include: disk full, disk quotas exceeded + -- and invalid file descriptor (the file may have been closed twice). + + procedure Close (FD : File_Descriptor); + -- Close file referenced by FD. This form is used when the caller wants to + -- ignore any possible error (see above for error cases). + + procedure Set_Close_On_Exec + (FD : File_Descriptor; + Close_On_Exec : Boolean; + Status : out Boolean); + -- When Close_On_Exec is True, mark FD to be closed automatically when new + -- program is executed by the calling process (i.e. prevent FD from being + -- inherited by child processes). When Close_On_Exec is False, mark FD to + -- not be closed on exec (i.e. allow it to be inherited). Status is False + -- if the operation could not be performed. + + procedure Delete_File (Name : String; Success : out Boolean); + -- Deletes file. Success is set True or False indicating if the delete is + -- successful. + + procedure Rename_File + (Old_Name : String; + New_Name : String; + Success : out Boolean); + -- Rename a file. Success is set True or False indicating if the rename is + -- successful or not. + + -- The following defines the mode for the Copy_File procedure below. Note + -- that "time stamps and other file attributes" in the descriptions below + -- refers to the creation and last modification times, and also the file + -- access (read/write/execute) status flags. + + type Copy_Mode is + (Copy, + -- Copy the file. It is an error if the target file already exists. The + -- time stamps and other file attributes are preserved in the copy. + + Overwrite, + -- If the target file exists, the file is replaced otherwise the file + -- is just copied. The time stamps and other file attributes are + -- preserved in the copy. + + Append); + -- If the target file exists, the contents of the source file is + -- appended at the end. Otherwise the source file is just copied. The + -- time stamps and other file attributes are preserved if the + -- destination file does not exist. + + type Attribute is + (Time_Stamps, + -- Copy time stamps from source file to target file. All other + -- attributes are set to normal default values for file creation. + + Full, + -- All attributes are copied from the source file to the target file. + -- This includes the timestamps, and for example also includes + -- read/write/execute attributes in Unix systems. + + None); + -- No attributes are copied. All attributes including the time stamp + -- values are set to normal default values for file creation. + + -- Note: The default is Time_Stamps, which corresponds to the normal + -- default on Windows style systems. Full corresponds to the typical + -- effect of "cp -p" on Unix systems, and None corresponds to the typical + -- effect of "cp" on Unix systems. + + -- Note: Time_Stamps and Full are not supported on VMS and VxWorks + + procedure Copy_File + (Name : String; + Pathname : String; + Success : out Boolean; + Mode : Copy_Mode := Copy; + Preserve : Attribute := Time_Stamps); + -- Copy a file. Name must designate a single file (no wild cards allowed). + -- Pathname can be a filename or directory name. In the latter case Name + -- is copied into the directory preserving the same file name. Mode + -- defines the kind of copy, see above with the default being a normal + -- copy in which the target file must not already exist. Success is set to + -- True or False indicating if the copy is successful (depending on the + -- specified Mode). + -- + -- Note: this procedure is only supported to a very limited extent on VMS. + -- The only supported mode is Overwrite, and the only supported value for + -- Preserve is None, resulting in the default action which for Overwrite + -- is to leave attributes unchanged. Furthermore, the copy only works for + -- simple text files. + + procedure Copy_Time_Stamps (Source, Dest : String; Success : out Boolean); + -- Copy Source file time stamps (last modification and last access time + -- stamps) to Dest file. Source and Dest must be valid filenames, + -- furthermore Dest must be writable. Success will be set to True if the + -- operation was successful and False otherwise. + -- + -- Note: this procedure is not supported on VMS and VxWorks. On these + -- platforms, Success is always set to False. + + function Read + (FD : File_Descriptor; + A : System.Address; + N : Integer) return Integer; + -- Read N bytes to address A from file referenced by FD. Returned value is + -- count of bytes actually read, which can be less than N at EOF. + + function Write + (FD : File_Descriptor; + A : System.Address; + N : Integer) return Integer; + -- Write N bytes from address A to file referenced by FD. The returned + -- value is the number of bytes written, which can be less than N if a + -- disk full condition was detected. + + Seek_Cur : constant := 1; + Seek_End : constant := 2; + Seek_Set : constant := 0; + -- Used to indicate origin for Lseek call + + procedure Lseek + (FD : File_Descriptor; + offset : Long_Integer; + origin : Integer); + pragma Import (C, Lseek, "__gnat_lseek"); + -- Sets the current file pointer to the indicated offset value, relative + -- to the current position (origin = SEEK_CUR), end of file (origin = + -- SEEK_END), or start of file (origin = SEEK_SET). + + function File_Length (FD : File_Descriptor) return Long_Integer; + pragma Import (C, File_Length, "__gnat_file_length"); + -- Get length of file from file descriptor FD + + function File_Time_Stamp (Name : String) return OS_Time; + -- Given the name of a file or directory, Name, obtains and returns the + -- time stamp. This function can be used for an unopened file. Returns + -- Invalid_Time is Name doesn't correspond to an existing file. + + function File_Time_Stamp (FD : File_Descriptor) return OS_Time; + -- Get time stamp of file from file descriptor FD Returns Invalid_Time is + -- FD doesn't correspond to an existing file. + + function Normalize_Pathname + (Name : String; + Directory : String := ""; + Resolve_Links : Boolean := True; + Case_Sensitive : Boolean := True) return String; + -- Returns a file name as an absolute path name, resolving all relative + -- directories, and symbolic links. The parameter Directory is a fully + -- resolved path name for a directory, or the empty string (the default). + -- Name is the name of a file, which is either relative to the given + -- directory name, if Directory is non-null, or to the current working + -- directory if Directory is null. The result returned is the normalized + -- name of the file. For most cases, if two file names designate the same + -- file through different paths, Normalize_Pathname will return the same + -- canonical name in both cases. However, there are cases when this is not + -- true; for example, this is not true in Unix for two hard links + -- designating the same file. + -- + -- On Windows, the returned path will start with a drive letter except + -- when Directory is not empty and does not include a drive letter. If + -- Directory is empty (the default) and Name is a relative path or an + -- absolute path without drive letter, the letter of the current drive + -- will start the returned path. If Case_Sensitive is True (the default), + -- then this drive letter will be forced to upper case ("C:\..."). + -- + -- If Resolve_Links is set to True, then the symbolic links, on systems + -- that support them, will be fully converted to the name of the file or + -- directory pointed to. This is slightly less efficient, since it + -- requires system calls. + -- + -- If Name cannot be resolved or is null on entry (for example if there is + -- symbolic link circularity, e.g. A is a symbolic link for B, and B is a + -- symbolic link for A), then Normalize_Pathname returns an empty string. + -- + -- In VMS, if Name follows the VMS syntax file specification, it is first + -- converted into Unix syntax. If the conversion fails, Normalize_Pathname + -- returns an empty string. + -- + -- For case-sensitive file systems, the value of Case_Sensitive parameter + -- is ignored. For file systems that are not case-sensitive, such as + -- Windows and OpenVMS, if this parameter is set to False, then the file + -- and directory names are folded to lower case. This allows checking + -- whether two files are the same by applying this function to their names + -- and comparing the results. If Case_Sensitive is set to True, this + -- function does not change the casing of file and directory names. + + function Is_Absolute_Path (Name : String) return Boolean; + -- Returns True if Name is an absolute path name, i.e. it designates a + -- file or directory absolutely rather than relative to another directory. + + function Is_Regular_File (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of an existing + -- regular file. Returns True if so, False otherwise. Name may be an + -- absolute path name or a relative path name, including a simple file + -- name. If it is a relative path name, it is relative to the current + -- working directory. + + function Is_Directory (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of a directory. + -- Returns True if so, False otherwise. Name may be an absolute path + -- name or a relative path name, including a simple file name. If it is + -- a relative path name, it is relative to the current working directory. + + function Is_Readable_File (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of an existing file + -- that is readable. Returns True if so, False otherwise. Note that this + -- function simply interrogates the file attributes (e.g. using the C + -- function stat), so it does not indicate a situation in which a file may + -- not actually be readable due to some other process having exclusive + -- access. + + function Is_Executable_File (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of an existing file + -- that is executable. Returns True if so, False otherwise. Note that this + -- function simply interrogates the file attributes (e.g. using the C + -- function stat), so it does not indicate a situation in which a file may + -- not actually be readable due to some other process having exclusive + -- access. + + function Is_Writable_File (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of an existing file + -- that is writable. Returns True if so, False otherwise. Note that this + -- function simply interrogates the file attributes (e.g. using the C + -- function stat), so it does not indicate a situation in which a file may + -- not actually be writeable due to some other process having exclusive + -- access. + + function Is_Symbolic_Link (Name : String) return Boolean; + -- Determines if the given string, Name, is the path of a symbolic link on + -- systems that support it. Returns True if so, False if the path is not a + -- symbolic link or if the system does not support symbolic links. + -- + -- A symbolic link is an indirect pointer to a file; its directory entry + -- contains the name of the file to which it is linked. Symbolic links may + -- span file systems and may refer to directories. + + procedure Set_Writable (Name : String); + -- Change permissions on the named file to make it writable for its owner + + procedure Set_Non_Writable (Name : String); + -- Change permissions on the named file to make it non-writable for its + -- owner. The readable and executable permissions are not modified. + + procedure Set_Read_Only (Name : String) renames Set_Non_Writable; + -- This renaming is provided for backwards compatibility with previous + -- versions. The use of Set_Non_Writable is preferred (clearer name). + + procedure Set_Executable (Name : String); + -- Change permissions on the named file to make it executable for its owner + + procedure Set_Readable (Name : String); + -- Change permissions on the named file to make it readable for its + -- owner. + + procedure Set_Non_Readable (Name : String); + -- Change permissions on the named file to make it non-readable for + -- its owner. The writable and executable permissions are not + -- modified. + + function Locate_Exec_On_Path + (Exec_Name : String) return String_Access; + -- Try to locate an executable whose name is given by Exec_Name in the + -- directories listed in the environment Path. If the Exec_Name does not + -- have the executable suffix, it will be appended before the search. + -- Otherwise works like Locate_Regular_File below. If the executable is + -- not found, null is returned. + -- + -- Note that this function allocates memory for the returned value. This + -- memory needs to be deallocated after use. + + function Locate_Regular_File + (File_Name : String; + Path : String) return String_Access; + -- Try to locate a regular file whose name is given by File_Name in the + -- directories listed in Path. If a file is found, its full pathname is + -- returned; otherwise, a null pointer is returned. If the File_Name given + -- is an absolute pathname, then Locate_Regular_File just checks that the + -- file exists and is a regular file. Otherwise, if the File_Name given + -- includes directory information, Locate_Regular_File first checks if the + -- file exists relative to the current directory. If it does not, or if + -- the File_Name given is a simple file name, the Path argument is parsed + -- according to OS conventions, and for each directory in the Path a check + -- is made if File_Name is a relative pathname of a regular file from that + -- directory. + -- + -- Note that this function allocates some memory for the returned value. + -- This memory needs to be deallocated after use. + + function Get_Debuggable_Suffix return String_Access; + -- Return the debuggable suffix convention. Usually this is the same as + -- the convention for Get_Executable_Suffix. The result is allocated on + -- the heap and should be freed after use to avoid storage leaks. + + function Get_Target_Debuggable_Suffix return String_Access; + -- Return the target debuggable suffix convention. Usually this is the same + -- as the convention for Get_Executable_Suffix. The result is allocated on + -- the heap and should be freed after use to avoid storage leaks. + + function Get_Executable_Suffix return String_Access; + -- Return the executable suffix convention. The result is allocated on the + -- heap and should be freed after use to avoid storage leaks. + + function Get_Object_Suffix return String_Access; + -- Return the object suffix convention. The result is allocated on the heap + -- and should be freed after use to avoid storage leaks. + + function Get_Target_Executable_Suffix return String_Access; + -- Return the target executable suffix convention. The result is allocated + -- on the heap and should be freed after use to avoid storage leaks. + + function Get_Target_Object_Suffix return String_Access; + -- Return the target object suffix convention. The result is allocated on + -- the heap and should be freed after use to avoid storage leaks. + + -- The following section contains low-level routines using addresses to + -- pass file name and executable name. In each routine the name must be + -- Nul-Terminated. For complete documentation refer to the equivalent + -- routine (using String in place of C_File_Name) defined above. + + subtype C_File_Name is System.Address; + -- This subtype is used to document that a parameter is the address of a + -- null-terminated string containing the name of a file. + + -- All the following functions need comments ??? + + function Open_Read + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + + function Open_Read_Write + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + + function Create_File + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + + function Create_New_File + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + + procedure Delete_File (Name : C_File_Name; Success : out Boolean); + + procedure Rename_File + (Old_Name : C_File_Name; + New_Name : C_File_Name; + Success : out Boolean); + + procedure Copy_File + (Name : C_File_Name; + Pathname : C_File_Name; + Success : out Boolean; + Mode : Copy_Mode := Copy; + Preserve : Attribute := Time_Stamps); + + procedure Copy_Time_Stamps + (Source, Dest : C_File_Name; + Success : out Boolean); + + function File_Time_Stamp (Name : C_File_Name) return OS_Time; + -- Returns Invalid_Time is Name doesn't correspond to an existing file + + function Is_Regular_File (Name : C_File_Name) return Boolean; + function Is_Directory (Name : C_File_Name) return Boolean; + function Is_Readable_File (Name : C_File_Name) return Boolean; + function Is_Executable_File (Name : C_File_Name) return Boolean; + function Is_Writable_File (Name : C_File_Name) return Boolean; + function Is_Symbolic_Link (Name : C_File_Name) return Boolean; + + function Locate_Regular_File + (File_Name : C_File_Name; + Path : C_File_Name) return String_Access; + + ------------------ + -- Subprocesses -- + ------------------ + + subtype Argument_List is String_List; + -- Type used for argument list in call to Spawn. The lower bound of the + -- array should be 1, and the length of the array indicates the number of + -- arguments. + + subtype Argument_List_Access is String_List_Access; + -- Type used to return Argument_List without dragging in secondary stack. + -- Note that there is a Free procedure declared for this subtype which + -- frees the array and all referenced strings. + + procedure Normalize_Arguments (Args : in out Argument_List); + -- Normalize all arguments in the list. This ensure that the argument list + -- is compatible with the running OS and will works fine with Spawn and + -- Non_Blocking_Spawn for example. If Normalize_Arguments is called twice + -- on the same list it will do nothing the second time. Note that Spawn + -- and Non_Blocking_Spawn call Normalize_Arguments automatically, but + -- since there is a guarantee that a second call does nothing, this + -- internal call will have no effect if Normalize_Arguments is called + -- before calling Spawn. The call to Normalize_Arguments assumes that the + -- individual referenced arguments in Argument_List are on the heap, and + -- may free them and reallocate if they are modified. + + procedure Spawn + (Program_Name : String; + Args : Argument_List; + Success : out Boolean); + -- This procedure spawns a program with a given list of arguments. The + -- first parameter of is the name of the executable. The second parameter + -- contains the arguments to be passed to this program. Success is False + -- if the named program could not be spawned or its execution completed + -- unsuccessfully. Note that the caller will be blocked until the + -- execution of the spawned program is complete. For maximum portability, + -- use a full path name for the Program_Name argument. On some systems + -- (notably Unix systems) a simple file name may also work (if the + -- executable can be located in the path). + -- + -- Spawning processes from tasking programs is not recommended. See + -- "NOTE: Spawn in tasking programs" below. + -- + -- Note: Arguments in Args that contain spaces and/or quotes such as + -- "--GCC=gcc -v" or "--GCC=""gcc -v""" are not portable across all + -- operating systems, and would not have the desired effect if they were + -- passed directly to the operating system. To avoid this problem, Spawn + -- makes an internal call to Normalize_Arguments, which ensures that such + -- arguments are modified in a manner that ensures that the desired effect + -- is obtained on all operating systems. The caller may call + -- Normalize_Arguments explicitly before the call (e.g. to print out the + -- exact form of arguments passed to the operating system). In this case + -- the guarantee a second call to Normalize_Arguments has no effect + -- ensures that the internal call will not affect the result. Note that + -- the implicit call to Normalize_Arguments may free and reallocate some + -- of the individual arguments. + -- + -- This function will always set Success to False under VxWorks and other + -- similar operating systems which have no notion of the concept of + -- dynamically executable file. + + function Spawn + (Program_Name : String; + Args : Argument_List) return Integer; + -- Similar to the above procedure, but returns the actual status returned + -- by the operating system, or -1 under VxWorks and any other similar + -- operating systems which have no notion of separately spawnable programs. + -- + -- Spawning processes from tasking programs is not recommended. See + -- "NOTE: Spawn in tasking programs" below. + + procedure Spawn + (Program_Name : String; + Args : Argument_List; + Output_File_Descriptor : File_Descriptor; + Return_Code : out Integer; + Err_To_Out : Boolean := True); + -- Similar to the procedure above, but redirects the output to the file + -- designated by Output_File_Descriptor. If Err_To_Out is True, then the + -- Standard Error output is also redirected. + -- Return_Code is set to the status code returned by the operating system + -- + -- Spawning processes from tasking programs is not recommended. See + -- "NOTE: Spawn in tasking programs" below. + + procedure Spawn + (Program_Name : String; + Args : Argument_List; + Output_File : String; + Success : out Boolean; + Return_Code : out Integer; + Err_To_Out : Boolean := True); + -- Similar to the procedure above, but saves the output of the command to + -- a file with the name Output_File. + -- + -- Success is set to True if the command is executed and its output + -- successfully written to the file. If Success is True, then Return_Code + -- will be set to the status code returned by the operating system. + -- Otherwise, Return_Code is undefined. + -- + -- Spawning processes from tasking programs is not recommended. See + -- "NOTE: Spawn in tasking programs" below. + + type Process_Id is private; + -- A private type used to identify a process activated by the following + -- non-blocking calls. The only meaningful operation on this type is a + -- comparison for equality. + + Invalid_Pid : constant Process_Id; + -- A special value used to indicate errors, as described below + + function Pid_To_Integer (Pid : Process_Id) return Integer; + -- Convert a process id to an Integer. Useful for writing hash functions + -- for type Process_Id or to compare two Process_Id (e.g. for sorting). + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List) return Process_Id; + -- This is a non blocking call. The Process_Id of the spawned process is + -- returned. Parameters are to be used as in Spawn. If Invalid_Pid is + -- returned the program could not be spawned. + -- + -- Spawning processes from tasking programs is not recommended. See + -- "NOTE: Spawn in tasking programs" below. + -- + -- This function will always return Invalid_Pid under VxWorks, since there + -- is no notion of executables under this OS. + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List; + Output_File_Descriptor : File_Descriptor; + Err_To_Out : Boolean := True) return Process_Id; + -- Similar to the procedure above, but redirects the output to the file + -- designated by Output_File_Descriptor. If Err_To_Out is True, then the + -- Standard Error output is also redirected. Invalid_Pid is returned + -- if the program could not be spawned successfully. + -- + -- Spawning processes from tasking programs is not recommended. See + -- "NOTE: Spawn in tasking programs" below. + -- + -- This function will always return Invalid_Pid under VxWorks, since there + -- is no notion of executables under this OS. + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List; + Output_File : String; + Err_To_Out : Boolean := True) return Process_Id; + -- Similar to the procedure above, but saves the output of the command to + -- a file with the name Output_File. + -- + -- Success is set to True if the command is executed and its output + -- successfully written to the file. Invalid_Pid is returned if the output + -- file could not be created or if the program could not be spawned + -- successfully. + -- + -- Spawning processes from tasking programs is not recommended. See + -- "NOTE: Spawn in tasking programs" below. + -- + -- This function will always return Invalid_Pid under VxWorks, since there + -- is no notion of executables under this OS. + + procedure Wait_Process (Pid : out Process_Id; Success : out Boolean); + -- Wait for the completion of any of the processes created by previous + -- calls to Non_Blocking_Spawn. The caller will be suspended until one of + -- these processes terminates (normally or abnormally). If any of these + -- subprocesses terminates prior to the call to Wait_Process (and has not + -- been returned by a previous call to Wait_Process), then the call to + -- Wait_Process is immediate. Pid identifies the process that has + -- terminated (matching the value returned from Non_Blocking_Spawn). + -- Success is set to True if this sub-process terminated successfully. If + -- Pid = Invalid_Pid, there were no subprocesses left to wait on. + -- + -- This function will always set success to False under VxWorks, since + -- there is no notion of executables under this OS. + + function Argument_String_To_List + (Arg_String : String) return Argument_List_Access; + -- Take a string that is a program and its arguments and parse it into an + -- Argument_List. Note that the result is allocated on the heap, and must + -- be freed by the programmer (when it is no longer needed) to avoid + -- memory leaks. + + ------------------------------------- + -- NOTE: Spawn in Tasking Programs -- + ------------------------------------- + + -- Spawning processes in tasking programs using the above Spawn and + -- Non_Blocking_Spawn subprograms is not recommended, because there are + -- subtle interactions between creating a process and signals/locks that + -- can cause trouble. These issues are not specific to Ada; they depend + -- primarily on the operating system. + + -- If you need to spawn processes in a tasking program, you will need to + -- understand the semantics of your operating system, and you are likely to + -- write non-portable code, because operating systems differ in this area. + + -- The Spawn and Non_Blocking_Spawn subprograms call the following + -- operating system functions: + + -- On Windows: spawnvp (blocking) or CreateProcess (non-blocking) + + -- On Solaris: fork1, followed in the child process by execv + + -- On other Unix-like systems, and on VMS: fork, followed in the child + -- process by execv. + + -- On vxworks, nucleus, and RTX, spawning of processes is not supported + + -- For details, look at the functions __gnat_portable_spawn and + -- __gnat_portable_no_block_spawn in adaint.c. + + -- You should read the operating-system-specific documentation for the + -- above functions, paying special attention to subtle interactions with + -- threading, signals, locks, and file descriptors. Most of the issues are + -- related to the fact that on Unix, there is a window of time between fork + -- and execv; Windows does not have this problem, because spawning is done + -- in a single operation. + + -- On Posix-compliant systems, such as Linux, fork duplicates just the + -- calling thread. (On Solaris, fork1 is the Posix-compliant version of + -- fork.) + + -- You should avoid using signals while spawning. This includes signals + -- used internally by the Ada run-time system, such as timer signals used + -- to implement delay statements. + + -- It is best to spawn any subprocesses very early, before the parent + -- process creates tasks, locks, or installs signal handlers. Certainly + -- avoid doing simultaneous spawns from multiple threads of the same + -- process. + + -- There is no problem spawning a subprocess that uses tasking: the + -- problems are caused only by tasking in the parent. + + -- If the parent is using tasking, and needs to spawn subprocesses at + -- arbitrary times, one technique is for the parent to spawn (very early) + -- a particular spawn-manager subprocess whose job is to spawn other + -- processes. The spawn-manager avoids tasking. The parent sends messages + -- to the spawn-manager requesting it to spawn processes, using whatever + -- inter-process communication mechanism you like, such as sockets. + + -- In short, mixing spawning of subprocesses with tasking is a tricky + -- business, and should be avoided if possible, but if it is necessary, + -- the above guidelines should be followed, and you should beware of + -- portability problems. + + ------------------- + -- Miscellaneous -- + ------------------- + + function Getenv (Name : String) return String_Access; + -- Get the value of the environment variable. Returns an access to the + -- empty string if the environment variable does not exist or has an + -- explicit null value (in some operating systems these are distinct + -- cases, in others they are not; this interface abstracts away that + -- difference. The argument is allocated on the heap (even in the null + -- case), and needs to be freed explicitly when no longer needed to avoid + -- memory leaks. + + procedure Setenv (Name : String; Value : String); + -- Set the value of the environment variable Name to Value. This call + -- modifies the current environment, but does not modify the parent + -- process environment. After a call to Setenv, Getenv (Name) will always + -- return a String_Access referencing the same String as Value. This is + -- true also for the null string case (the actual effect may be to either + -- set an explicit null as the value, or to remove the entry, this is + -- operating system dependent). Note that any following calls to Spawn + -- will pass an environment to the spawned process that includes the + -- changes made by Setenv calls. This procedure is not available on VMS. + + procedure OS_Exit (Status : Integer); + pragma No_Return (OS_Exit); + + -- Exit to OS with given status code (program is terminated). Note that + -- this is abrupt termination. All tasks are immediately terminated. There + -- are no finalization or other Ada-specific cleanup actions performed. On + -- systems with atexit handlers (such as Unix and Windows), atexit handlers + -- are called. + + type OS_Exit_Subprogram is access procedure (Status : Integer); + + procedure OS_Exit_Default (Status : Integer); + pragma No_Return (OS_Exit_Default); + -- Default implementation of procedure OS_Exit + + OS_Exit_Ptr : OS_Exit_Subprogram := OS_Exit_Default'Access; + -- OS_Exit is implemented through this access value. It it then possible to + -- change the implementation of OS_Exit by redirecting OS_Exit_Ptr to an + -- other implementation. + + procedure OS_Abort; + pragma Import (C, OS_Abort, "abort"); + pragma No_Return (OS_Abort); + -- Exit to OS signalling an abort (traceback or other appropriate + -- diagnostic information should be given if possible, or entry made to + -- the debugger if that is possible). + + function Errno return Integer; + pragma Import (C, Errno, "__get_errno"); + -- Return the task-safe last error number + + procedure Set_Errno (Errno : Integer); + pragma Import (C, Set_Errno, "__set_errno"); + -- Set the task-safe error number + + Directory_Separator : constant Character; + -- The character that is used to separate parts of a pathname + + Path_Separator : constant Character; + -- The character to separate paths in an environment variable value + +private + pragma Import (C, Path_Separator, "__gnat_path_separator"); + pragma Import (C, Directory_Separator, "__gnat_dir_separator"); + pragma Import (C, Current_Time, "__gnat_current_time"); + + type OS_Time is + range -(2 ** (Standard'Address_Size - Integer'(1))) .. + +(2 ** (Standard'Address_Size - Integer'(1)) - 1); + -- Type used for timestamps in the compiler. This type is used to hold + -- time stamps, but may have a different representation than C's time_t. + -- This type needs to match the declaration of OS_Time in adaint.h. + + -- Add pragma Inline statements for comparison operations on OS_Time. It + -- would actually be nice to use pragma Import (Intrinsic) here, but this + -- was not properly supported till GNAT 3.15a, so that would cause + -- bootstrap path problems. To be changed later ??? + + Invalid_Time : constant OS_Time := -1; + -- This value should match the return value from __gnat_file_time_* + + pragma Inline ("<"); + pragma Inline (">"); + pragma Inline ("<="); + pragma Inline (">="); + + type Process_Id is new Integer; + Invalid_Pid : constant Process_Id := -1; + +end System.OS_Lib; diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c new file mode 100644 index 000000000..ed3653a48 --- /dev/null +++ b/gcc/ada/s-oscons-tmplt.c @@ -0,0 +1,1372 @@ +/* +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . O 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks ("M32766"); +-- Allow long lines + +*/ + +/** + ** This template file is used while building the GNAT runtime library to + ** generate package System.OS_Constants (s-oscons.ads). + ** + ** The generation process is: + ** 1. the platform-independent extraction tool xoscons is built with the + ** base native compiler + ** 2. this template is processed by the cross C compiler to produce + ** a list of constant values + ** 3. the comments in this template and the list of values are processed + ** by xoscons to generate s-oscons.ads. + ** + ** Any comment occurring in this file whose start and end markers are on + ** a line by themselves (see above) is copied verbatim to s-oscons.ads. + ** All other comments are ignored. Note that the build process first passes + ** this file through the C preprocessor, so comments that occur in a section + ** that is conditioned by a #if directive will be copied to the output only + ** when it applies. + ** + ** Two methods are supported to generate the list of constant values, + ** s-oscons-tmpl.s. + ** + ** The default one assumes that the template can be compiled by the newly- + ** built cross compiler. It uses markup produced in the (pseudo-)assembly + ** listing: + ** + ** xgcc -DTARGET=\"$target\" -C -E s-oscons-tmplt.c > s-oscons-tmplt.i + ** xgcc -S s-oscons-tmplt.i + ** xoscons + ** + ** Alternatively, if s-oscons-tmplt.c must be compiled with a proprietary + ** compiler (e.g. the native DEC CC on OpenVMS), the NATIVE macro should + ** be defined, and the resulting program executed: + ** + ** $ CC/DEFINE=("TARGET=""OpenVMS""",NATIVE) + ** /PREPROCESS_ONLY /COMMENTS=AS_IS s-oscons-tmplt + ** $ CC/DEFINE=("TARGET=""OpenVMS""",NATIVE) s-oscons-tmplt + ** $ LINK s-oscons-tmplt + ** $ DEFINE/USER SYS$OUTPUT s-oscons-tmplt.s + ** $ RUN s-oscons-tmplt + ** $ RUN xoscons + **/ + +#if defined (__linux__) && !defined (_XOPEN_SOURCE) +/** For Linux _XOPEN_SOURCE must be defined, otherwise IOV_MAX is not defined + **/ +#define _XOPEN_SOURCE 500 + +#elif defined (__mips) && defined (__sgi) +/** For IRIX 6, _XOPEN5 must be defined and _XOPEN_IOV_MAX must be used as + ** IOV_MAX, otherwise IOV_MAX is not defined. IRIX 5 has neither. + **/ +#ifdef _XOPEN_IOV_MAX +#define _XOPEN5 +#define IOV_MAX _XOPEN_IOV_MAX +#endif +#endif + +#include +#include +#include +#include + +#if defined (__alpha__) && defined (__osf__) +/** Tru64 is unable to do vector IO operations with default value of IOV_MAX, + ** so its value is redefined to a small one which is known to work properly. + **/ +#undef IOV_MAX +#define IOV_MAX 16 +#endif + +#if defined (__VMS) +/** VMS is unable to do vector IO operations with default value of IOV_MAX, + ** so its value is redefined to a small one which is known to work properly. + **/ +#undef IOV_MAX +#define IOV_MAX 16 +#endif + +#if ! (defined (__vxworks) || defined (__VMS) || defined (__MINGW32__) || \ + defined (__nucleus__)) +# define HAVE_TERMIOS +#endif + +#if defined (__vxworks) + +/** + ** For VxWorks, always include vxWorks.h (gsocket.h provides it only for + ** the case of runtime libraries that support sockets). + **/ + +# include +#endif + +#include "gsocket.h" + +#ifdef DUMMY + +# if defined (TARGET) +# error TARGET may not be defined when generating the dummy version +# else +# define TARGET "batch runtime compilation (dummy values)" +# endif + +# if !(defined (HAVE_SOCKETS) && defined (HAVE_TERMIOS)) +# error Features missing on platform +# endif + +# define NATIVE + +#endif + +#ifndef TARGET +# error Please define TARGET +#endif + +#ifndef HAVE_SOCKETS +# include +#endif + +#ifdef HAVE_TERMIOS +# include +#endif + +#ifdef __APPLE__ +# include <_types.h> +#endif + +#ifdef NATIVE +#include + +#ifdef DUMMY +int counter = 0; +# define _VAL(x) counter++ +#else +# define _VAL(x) x +#endif + +#define CND(name,comment) \ + printf ("\n->CND:$%d:" #name ":$%d:" comment, __LINE__, ((int) _VAL (name))); + +#define CNS(name,comment) \ + printf ("\n->CNS:$%d:" #name ":" name ":" comment, __LINE__); + +#define C(sname,type,value,comment)\ + printf ("\n->C:$%d:" sname ":" #type ":" value ":" comment, __LINE__); + +#define TXT(text) \ + printf ("\n->TXT:$%d:" text, __LINE__); + +#else + +#define CND(name, comment) \ + asm volatile("\n->CND:%0:" #name ":%1:" comment \ + : : "i" (__LINE__), "i" ((int) name)); +/* Decimal constant in the range of type "int" */ + +#define CNS(name, comment) \ + asm volatile("\n->CNS:%0:" #name ":" name ":" comment \ + : : "i" (__LINE__)); +/* General expression named number */ + +#define C(sname, type, value, comment) \ + asm volatile("\n->C:%0:" sname ":" #type ":" value ":" comment \ + : : "i" (__LINE__)); +/* Typed constant */ + +#define TXT(text) \ + asm volatile("\n->TXT:%0:" text \ + : : "i" (__LINE__)); +/* Freeform text */ + +#endif + +#define CST(name,comment) C(#name,String,name,comment) + +#define STR(x) STR1(x) +#define STR1(x) #x + +#ifdef __MINGW32__ +unsigned int _CRT_fmode = _O_BINARY; +#endif + +int +main (void) { + +/* +-- This package provides target dependent definitions of constant for use +-- by the GNAT runtime library. This package should not be directly with'd +-- by an application program. + +-- This file is generated automatically, do not modify it by hand! Instead, +-- make changes to s-oscons-tmplt.c and rebuild the GNAT runtime library. +*/ + +/** + ** Do not change the format of the line below without also updating the + ** MaRTE Makefile. + **/ +TXT("-- This is the version for " TARGET) +TXT("") + +#ifdef HAVE_SOCKETS +/** + ** The type definitions for struct hostent components uses Interfaces.C + **/ + +TXT("with Interfaces.C;") +#endif + +/* +package System.OS_Constants is + + pragma Pure; +*/ + +/** + ** General constants (all platforms) + **/ + +/* + + ----------------------------- + -- Platform identification -- + ----------------------------- + + type OS_Type is (Windows, VMS, Other_OS); +*/ +#if defined (__MINGW32__) +# define TARGET_OS "Windows" +#elif defined (__VMS) +# define TARGET_OS "VMS" +#else +# define TARGET_OS "Other_OS" +#endif +C("Target_OS", OS_Type, TARGET_OS, "") +#define Target_Name TARGET +CST(Target_Name, "") +/* + + ------------------- + -- System limits -- + ------------------- + +*/ + +#ifndef IOV_MAX +# define IOV_MAX INT_MAX +#endif +CND(IOV_MAX, "Maximum writev iovcnt") + +/* + + --------------------- + -- File open modes -- + --------------------- + +*/ + +#ifndef O_RDWR +# define O_RDWR -1 +#endif +CND(O_RDWR, "Read/write") + +#ifndef O_NOCTTY +# define O_NOCTTY -1 +#endif +CND(O_NOCTTY, "Don't change ctrl tty") + +#ifndef O_NDELAY +# define O_NDELAY -1 +#endif +CND(O_NDELAY, "Nonblocking") + +/* + + ---------------------- + -- Fcntl operations -- + ---------------------- + +*/ + +#ifndef F_GETFL +# define F_GETFL -1 +#endif +CND(F_GETFL, "Get flags") + +#ifndef F_SETFL +# define F_SETFL -1 +#endif +CND(F_SETFL, "Set flags") + +/* + + ----------------- + -- Fcntl flags -- + ----------------- + +*/ + +#ifndef FNDELAY +# define FNDELAY -1 +#endif +CND(FNDELAY, "Nonblocking") + +/* + + ---------------------- + -- Ioctl operations -- + ---------------------- + +*/ + +#ifndef FIONBIO +# define FIONBIO -1 +#endif +CND(FIONBIO, "Set/clear non-blocking io") + +#ifndef FIONREAD +# define FIONREAD -1 +#endif +CND(FIONREAD, "How many bytes to read") + +/* + + ------------------ + -- Errno values -- + ------------------ + + -- The following constants are defined from + +*/ +#ifndef EAGAIN +# define EAGAIN -1 +#endif +CND(EAGAIN, "Try again") + +#ifndef ENOENT +# define ENOENT -1 +#endif +CND(ENOENT, "File not found") + +#ifndef ENOMEM +# define ENOMEM -1 +#endif +CND(ENOMEM, "Out of memory") + +#ifdef __MINGW32__ +/* + + -- The following constants are defined from (WSA*) + +*/ + +/** + ** For sockets-related errno values on Windows, gsocket.h redefines + ** Exxx as WSAExxx. + **/ + +#endif + +#ifndef EACCES +# define EACCES -1 +#endif +CND(EACCES, "Permission denied") + +#ifndef EADDRINUSE +# define EADDRINUSE -1 +#endif +CND(EADDRINUSE, "Address already in use") + +#ifndef EADDRNOTAVAIL +# define EADDRNOTAVAIL -1 +#endif +CND(EADDRNOTAVAIL, "Cannot assign address") + +#ifndef EAFNOSUPPORT +# define EAFNOSUPPORT -1 +#endif +CND(EAFNOSUPPORT, "Addr family not supported") + +#ifndef EALREADY +# define EALREADY -1 +#endif +CND(EALREADY, "Operation in progress") + +#ifndef EBADF +# define EBADF -1 +#endif +CND(EBADF, "Bad file descriptor") + +#ifndef ECONNABORTED +# define ECONNABORTED -1 +#endif +CND(ECONNABORTED, "Connection aborted") + +#ifndef ECONNREFUSED +# define ECONNREFUSED -1 +#endif +CND(ECONNREFUSED, "Connection refused") + +#ifndef ECONNRESET +# define ECONNRESET -1 +#endif +CND(ECONNRESET, "Connection reset by peer") + +#ifndef EDESTADDRREQ +# define EDESTADDRREQ -1 +#endif +CND(EDESTADDRREQ, "Destination addr required") + +#ifndef EFAULT +# define EFAULT -1 +#endif +CND(EFAULT, "Bad address") + +#ifndef EHOSTDOWN +# define EHOSTDOWN -1 +#endif +CND(EHOSTDOWN, "Host is down") + +#ifndef EHOSTUNREACH +# define EHOSTUNREACH -1 +#endif +CND(EHOSTUNREACH, "No route to host") + +#ifndef EINPROGRESS +# define EINPROGRESS -1 +#endif +CND(EINPROGRESS, "Operation now in progress") + +#ifndef EINTR +# define EINTR -1 +#endif +CND(EINTR, "Interrupted system call") + +#ifndef EINVAL +# define EINVAL -1 +#endif +CND(EINVAL, "Invalid argument") + +#ifndef EIO +# define EIO -1 +#endif +CND(EIO, "Input output error") + +#ifndef EISCONN +# define EISCONN -1 +#endif +CND(EISCONN, "Socket already connected") + +#ifndef ELOOP +# define ELOOP -1 +#endif +CND(ELOOP, "Too many symbolic links") + +#ifndef EMFILE +# define EMFILE -1 +#endif +CND(EMFILE, "Too many open files") + +#ifndef EMSGSIZE +# define EMSGSIZE -1 +#endif +CND(EMSGSIZE, "Message too long") + +#ifndef ENAMETOOLONG +# define ENAMETOOLONG -1 +#endif +CND(ENAMETOOLONG, "Name too long") + +#ifndef ENETDOWN +# define ENETDOWN -1 +#endif +CND(ENETDOWN, "Network is down") + +#ifndef ENETRESET +# define ENETRESET -1 +#endif +CND(ENETRESET, "Disconn. on network reset") + +#ifndef ENETUNREACH +# define ENETUNREACH -1 +#endif +CND(ENETUNREACH, "Network is unreachable") + +#ifndef ENOBUFS +# define ENOBUFS -1 +#endif +CND(ENOBUFS, "No buffer space available") + +#ifndef ENOPROTOOPT +# define ENOPROTOOPT -1 +#endif +CND(ENOPROTOOPT, "Protocol not available") + +#ifndef ENOTCONN +# define ENOTCONN -1 +#endif +CND(ENOTCONN, "Socket not connected") + +#ifndef ENOTSOCK +# define ENOTSOCK -1 +#endif +CND(ENOTSOCK, "Operation on non socket") + +#ifndef EOPNOTSUPP +# define EOPNOTSUPP -1 +#endif +CND(EOPNOTSUPP, "Operation not supported") + +#ifndef EPIPE +# define EPIPE -1 +#endif +CND(EPIPE, "Broken pipe") + +#ifndef EPFNOSUPPORT +# define EPFNOSUPPORT -1 +#endif +CND(EPFNOSUPPORT, "Unknown protocol family") + +#ifndef EPROTONOSUPPORT +# define EPROTONOSUPPORT -1 +#endif +CND(EPROTONOSUPPORT, "Unknown protocol") + +#ifndef EPROTOTYPE +# define EPROTOTYPE -1 +#endif +CND(EPROTOTYPE, "Unknown protocol type") + +#ifndef ERANGE +# define ERANGE -1 +#endif +CND(ERANGE, "Result too large") + +#ifndef ESHUTDOWN +# define ESHUTDOWN -1 +#endif +CND(ESHUTDOWN, "Cannot send once shutdown") + +#ifndef ESOCKTNOSUPPORT +# define ESOCKTNOSUPPORT -1 +#endif +CND(ESOCKTNOSUPPORT, "Socket type not supported") + +#ifndef ETIMEDOUT +# define ETIMEDOUT -1 +#endif +CND(ETIMEDOUT, "Connection timed out") + +#ifndef ETOOMANYREFS +# define ETOOMANYREFS -1 +#endif +CND(ETOOMANYREFS, "Too many references") + +#ifndef EWOULDBLOCK +# define EWOULDBLOCK -1 +#endif +CND(EWOULDBLOCK, "Operation would block") + +/** + ** Terminal I/O constants + **/ + +#ifdef HAVE_TERMIOS + +/* + + ---------------------- + -- Terminal control -- + ---------------------- + +*/ + +#ifndef TCSANOW +# define TCSANOW -1 +#endif +CND(TCSANOW, "Immediate") + +#ifndef TCIFLUSH +# define TCIFLUSH -1 +#endif +CND(TCIFLUSH, "Flush input") + +#ifndef CLOCAL +# define CLOCAL -1 +#endif +CND(CLOCAL, "Local") + +#ifndef CRTSCTS +# define CRTSCTS -1 +#endif +CND(CRTSCTS, "Hardware flow control") + +#ifndef CREAD +# define CREAD -1 +#endif +CND(CREAD, "Read") + +#ifndef CS5 +# define CS5 -1 +#endif +CND(CS5, "5 data bits") + +#ifndef CS6 +# define CS6 -1 +#endif +CND(CS6, "6 data bits") + +#ifndef CS7 +# define CS7 -1 +#endif +CND(CS7, "7 data bits") + +#ifndef CS8 +# define CS8 -1 +#endif +CND(CS8, "8 data bits") + +#ifndef CSTOPB +# define CSTOPB -1 +#endif +CND(CSTOPB, "2 stop bits") + +#ifndef PARENB +# define PARENB -1 +#endif +CND(PARENB, "Parity enable") + +#ifndef PARODD +# define PARODD -1 +#endif +CND(PARODD, "Parity odd") + +#ifndef B0 +# define B0 -1 +#endif +CND(B0, "0 bps") + +#ifndef B50 +# define B50 -1 +#endif +CND(B50, "50 bps") + +#ifndef B75 +# define B75 -1 +#endif +CND(B75, "75 bps") + +#ifndef B110 +# define B110 -1 +#endif +CND(B110, "110 bps") + +#ifndef B134 +# define B134 -1 +#endif +CND(B134, "134 bps") + +#ifndef B150 +# define B150 -1 +#endif +CND(B150, "150 bps") + +#ifndef B200 +# define B200 -1 +#endif +CND(B200, "200 bps") + +#ifndef B300 +# define B300 -1 +#endif +CND(B300, "300 bps") + +#ifndef B600 +# define B600 -1 +#endif +CND(B600, "600 bps") + +#ifndef B1200 +# define B1200 -1 +#endif +CND(B1200, "1200 bps") + +#ifndef B1800 +# define B1800 -1 +#endif +CND(B1800, "1800 bps") + +#ifndef B2400 +# define B2400 -1 +#endif +CND(B2400, "2400 bps") + +#ifndef B4800 +# define B4800 -1 +#endif +CND(B4800, "4800 bps") + +#ifndef B9600 +# define B9600 -1 +#endif +CND(B9600, "9600 bps") + +#ifndef B19200 +# define B19200 -1 +#endif +CND(B19200, "19200 bps") + +#ifndef B38400 +# define B38400 -1 +#endif +CND(B38400, "38400 bps") + +#ifndef B57600 +# define B57600 -1 +#endif +CND(B57600, "57600 bps") + +#ifndef B115200 +# define B115200 -1 +#endif +CND(B115200, "115200 bps") + +#ifndef B230400 +# define B230400 -1 +#endif +CND(B230400, "230400 bps") + +#ifndef B460800 +# define B460800 -1 +#endif +CND(B460800, "460800 bps") + +#ifndef B500000 +# define B500000 -1 +#endif +CND(B500000, "500000 bps") + +#ifndef B576000 +# define B576000 -1 +#endif +CND(B576000, "576000 bps") + +#ifndef B921600 +# define B921600 -1 +#endif +CND(B921600, "921600 bps") + +#ifndef B1000000 +# define B1000000 -1 +#endif +CND(B1000000, "1000000 bps") + +#ifndef B1152000 +# define B1152000 -1 +#endif +CND(B1152000, "1152000 bps") + +#ifndef B1500000 +# define B1500000 -1 +#endif +CND(B1500000, "1500000 bps") + +#ifndef B2000000 +# define B2000000 -1 +#endif +CND(B2000000, "2000000 bps") + +#ifndef B2500000 +# define B2500000 -1 +#endif +CND(B2500000, "2500000 bps") + +#ifndef B3000000 +# define B3000000 -1 +#endif +CND(B3000000, "3000000 bps") + +#ifndef B3500000 +# define B3500000 -1 +#endif +CND(B3500000, "3500000 bps") + +#ifndef B4000000 +# define B4000000 -1 +#endif +CND(B4000000, "4000000 bps") + +/* + + --------------------------------- + -- Terminal control characters -- + --------------------------------- + +*/ + +#ifndef VINTR +# define VINTR -1 +#endif +CND(VINTR, "Interrupt") + +#ifndef VQUIT +# define VQUIT -1 +#endif +CND(VQUIT, "Quit") + +#ifndef VERASE +# define VERASE -1 +#endif +CND(VERASE, "Erase") + +#ifndef VKILL +# define VKILL -1 +#endif +CND(VKILL, "Kill") + +#ifndef VEOF +# define VEOF -1 +#endif +CND(VEOF, "EOF") + +#ifndef VTIME +# define VTIME -1 +#endif +CND(VTIME, "Read timeout") + +#ifndef VMIN +# define VMIN -1 +#endif +CND(VMIN, "Read min chars") + +#ifndef VSWTC +# define VSWTC -1 +#endif +CND(VSWTC, "Switch") + +#ifndef VSTART +# define VSTART -1 +#endif +CND(VSTART, "Flow control start") + +#ifndef VSTOP +# define VSTOP -1 +#endif +CND(VSTOP, "Flow control stop") + +#ifndef VSUSP +# define VSUSP -1 +#endif +CND(VSUSP, "Suspend") + +#ifndef VEOL +# define VEOL -1 +#endif +CND(VEOL, "EOL") + +#ifndef VREPRINT +# define VREPRINT -1 +#endif +CND(VREPRINT, "Reprint unread") + +#ifndef VDISCARD +# define VDISCARD -1 +#endif +CND(VDISCARD, "Discard pending") + +#ifndef VWERASE +# define VWERASE -1 +#endif +CND(VWERASE, "Word erase") + +#ifndef VLNEXT +# define VLNEXT -1 +#endif +CND(VLNEXT, "Literal next") + +#ifndef VEOL2 +# define VEOL2 -1 +#endif +CND(VEOL2, "Alternative EOL") + +#endif /* HAVE_TERMIOS */ + +/** + ** Sockets constants + **/ + +#ifdef HAVE_SOCKETS + +/* + + -------------- + -- Families -- + -------------- + +*/ + +#ifndef AF_INET +# define AF_INET -1 +#endif +CND(AF_INET, "IPv4 address family") + +/** + ** RTEMS lies and defines AF_INET6 even though there is no IPV6 support. + ** Its TCP/IP stack is in transition. It has newer .h files but no IPV6 yet. + **/ +#if defined(__rtems__) +# undef AF_INET6 +#endif + +/** + ** Tru64 UNIX V4.0F defines AF_INET6 without IPv6 support, specifically + ** without struct sockaddr_in6. We use _SS_MAXSIZE (used for the definition + ** of struct sockaddr_storage on Tru64 UNIX V5.1) to detect this. + **/ +#if defined(__osf__) && !defined(_SS_MAXSIZE) +# undef AF_INET6 +#endif + +#ifndef AF_INET6 +# define AF_INET6 -1 +#else +# define HAVE_AF_INET6 1 +#endif +CND(AF_INET6, "IPv6 address family") + +/* + + ------------------ + -- Socket modes -- + ------------------ + +*/ + +#ifndef SOCK_STREAM +# define SOCK_STREAM -1 +#endif +CND(SOCK_STREAM, "Stream socket") + +#ifndef SOCK_DGRAM +# define SOCK_DGRAM -1 +#endif +CND(SOCK_DGRAM, "Datagram socket") + +/* + + ----------------- + -- Host errors -- + ----------------- + +*/ + +#ifndef HOST_NOT_FOUND +# define HOST_NOT_FOUND -1 +#endif +CND(HOST_NOT_FOUND, "Unknown host") + +#ifndef TRY_AGAIN +# define TRY_AGAIN -1 +#endif +CND(TRY_AGAIN, "Host name lookup failure") + +#ifndef NO_DATA +# define NO_DATA -1 +#endif +CND(NO_DATA, "No data record for name") + +#ifndef NO_RECOVERY +# define NO_RECOVERY -1 +#endif +CND(NO_RECOVERY, "Non recoverable errors") + +/* + + -------------------- + -- Shutdown modes -- + -------------------- + +*/ + +#ifndef SHUT_RD +# define SHUT_RD -1 +#endif +CND(SHUT_RD, "No more recv") + +#ifndef SHUT_WR +# define SHUT_WR -1 +#endif +CND(SHUT_WR, "No more send") + +#ifndef SHUT_RDWR +# define SHUT_RDWR -1 +#endif +CND(SHUT_RDWR, "No more recv/send") + +/* + + --------------------- + -- Protocol levels -- + --------------------- + +*/ + +#ifndef SOL_SOCKET +# define SOL_SOCKET -1 +#endif +CND(SOL_SOCKET, "Options for socket level") + +#ifndef IPPROTO_IP +# define IPPROTO_IP -1 +#endif +CND(IPPROTO_IP, "Dummy protocol for IP") + +#ifndef IPPROTO_UDP +# define IPPROTO_UDP -1 +#endif +CND(IPPROTO_UDP, "UDP") + +#ifndef IPPROTO_TCP +# define IPPROTO_TCP -1 +#endif +CND(IPPROTO_TCP, "TCP") + +/* + + ------------------- + -- Request flags -- + ------------------- + +*/ + +#ifndef MSG_OOB +# define MSG_OOB -1 +#endif +CND(MSG_OOB, "Process out-of-band data") + +#ifndef MSG_PEEK +# define MSG_PEEK -1 +#endif +CND(MSG_PEEK, "Peek at incoming data") + +#ifndef MSG_EOR +# define MSG_EOR -1 +#endif +CND(MSG_EOR, "Send end of record") + +#ifndef MSG_WAITALL +# define MSG_WAITALL -1 +#endif +CND(MSG_WAITALL, "Wait for full reception") + +#ifndef MSG_NOSIGNAL +# define MSG_NOSIGNAL -1 +#endif +CND(MSG_NOSIGNAL, "No SIGPIPE on send") + +#ifdef __linux__ +# define MSG_Forced_Flags "MSG_NOSIGNAL" +#else +# define MSG_Forced_Flags "0" +#endif +CNS(MSG_Forced_Flags, "") +/* + -- Flags set on all send(2) calls +*/ + +/* + + -------------------- + -- Socket options -- + -------------------- + +*/ + +#ifndef TCP_NODELAY +# define TCP_NODELAY -1 +#endif +CND(TCP_NODELAY, "Do not coalesce packets") + +#ifndef SO_REUSEADDR +# define SO_REUSEADDR -1 +#endif +CND(SO_REUSEADDR, "Bind reuse local address") + +#ifndef SO_REUSEPORT +# define SO_REUSEPORT -1 +#endif +CND(SO_REUSEPORT, "Bind reuse port number") + +#ifndef SO_KEEPALIVE +# define SO_KEEPALIVE -1 +#endif +CND(SO_KEEPALIVE, "Enable keep-alive msgs") + +#ifndef SO_LINGER +# define SO_LINGER -1 +#endif +CND(SO_LINGER, "Defer close to flush data") + +#ifndef SO_BROADCAST +# define SO_BROADCAST -1 +#endif +CND(SO_BROADCAST, "Can send broadcast msgs") + +#ifndef SO_SNDBUF +# define SO_SNDBUF -1 +#endif +CND(SO_SNDBUF, "Set/get send buffer size") + +#ifndef SO_RCVBUF +# define SO_RCVBUF -1 +#endif +CND(SO_RCVBUF, "Set/get recv buffer size") + +#ifndef SO_SNDTIMEO +# define SO_SNDTIMEO -1 +#endif +CND(SO_SNDTIMEO, "Emission timeout") + +#ifndef SO_RCVTIMEO +# define SO_RCVTIMEO -1 +#endif +CND(SO_RCVTIMEO, "Reception timeout") + +#ifndef SO_ERROR +# define SO_ERROR -1 +#endif +CND(SO_ERROR, "Get/clear error status") + +#ifndef IP_MULTICAST_IF +# define IP_MULTICAST_IF -1 +#endif +CND(IP_MULTICAST_IF, "Set/get mcast interface") + +#ifndef IP_MULTICAST_TTL +# define IP_MULTICAST_TTL -1 +#endif +CND(IP_MULTICAST_TTL, "Set/get multicast TTL") + +#ifndef IP_MULTICAST_LOOP +# define IP_MULTICAST_LOOP -1 +#endif +CND(IP_MULTICAST_LOOP, "Set/get mcast loopback") + +#ifndef IP_ADD_MEMBERSHIP +# define IP_ADD_MEMBERSHIP -1 +#endif +CND(IP_ADD_MEMBERSHIP, "Join a multicast group") + +#ifndef IP_DROP_MEMBERSHIP +# define IP_DROP_MEMBERSHIP -1 +#endif +CND(IP_DROP_MEMBERSHIP, "Leave a multicast group") + +#ifndef IP_PKTINFO +# define IP_PKTINFO -1 +#endif +CND(IP_PKTINFO, "Get datagram info") + +/* + + ---------------------- + -- Type definitions -- + ---------------------- + +*/ + +{ + struct timeval tv; +/* + -- Sizes (in bytes) of the components of struct timeval +*/ +#define SIZEOF_tv_sec (sizeof tv.tv_sec) +CND(SIZEOF_tv_sec, "tv_sec") +#define SIZEOF_tv_usec (sizeof tv.tv_usec) +CND(SIZEOF_tv_usec, "tv_usec") +} +/* + + -- Sizes of various data types +*/ + +#define SIZEOF_sockaddr_in (sizeof (struct sockaddr_in)) +CND(SIZEOF_sockaddr_in, "struct sockaddr_in") +#ifdef HAVE_AF_INET6 +# define SIZEOF_sockaddr_in6 (sizeof (struct sockaddr_in6)) +#else +# define SIZEOF_sockaddr_in6 0 +#endif +CND(SIZEOF_sockaddr_in6, "struct sockaddr_in6") + +#define SIZEOF_fd_set (sizeof (fd_set)) +CND(SIZEOF_fd_set, "fd_set"); + +#define SIZEOF_struct_hostent (sizeof (struct hostent)) +CND(SIZEOF_struct_hostent, "struct hostent"); + +#define SIZEOF_struct_servent (sizeof (struct servent)) +CND(SIZEOF_struct_servent, "struct servent"); +/* + + -- Fields of struct msghdr +*/ + +#if defined (__sun__) || defined (__hpux__) +# define msg_iovlen_t "int" +#else +# define msg_iovlen_t "size_t" +#endif + +TXT(" subtype Msg_Iovlen_T is Interfaces.C." msg_iovlen_t ";") + +/* + + ---------------------------------------- + -- Properties of supported interfaces -- + ---------------------------------------- + +*/ + +CND(Need_Netdb_Buffer, "Need buffer for Netdb ops") +CND(Need_Netdb_Lock, "Need lock for Netdb ops") +CND(Has_Sockaddr_Len, "Sockaddr has sa_len field") + +/** + ** Do not change the format of the line below without also updating the + ** MaRTE Makefile. + **/ +C("Thread_Blocking_IO", Boolean, "True", "") +/* + -- Set False for contexts where socket i/o are process blocking + +*/ + +#ifdef HAVE_INET_PTON +# define Inet_Pton_Linkname "inet_pton" +#else +# define Inet_Pton_Linkname "__gnat_inet_pton" +#endif +CST(Inet_Pton_Linkname, "") + +#endif /* HAVE_SOCKETS */ + +/** + ** System-specific constants follow + ** Each section should be activated if compiling for the corresponding + ** platform *or* generating the dummy version for runtime test compilation. + **/ + +#if defined (__vxworks) || defined (DUMMY) + +/* + + -------------------------------- + -- VxWorks-specific constants -- + -------------------------------- + + -- These constants may be used only within the VxWorks version of + -- GNAT.Sockets.Thin. +*/ + +CND(OK, "VxWorks generic success") +CND(ERROR, "VxWorks generic error") + +#endif + +#if defined (__MINGW32__) || defined (DUMMY) +/* + + ------------------------------ + -- MinGW-specific constants -- + ------------------------------ + + -- These constants may be used only within the MinGW version of + -- GNAT.Sockets.Thin. +*/ + +CND(WSASYSNOTREADY, "System not ready") +CND(WSAVERNOTSUPPORTED, "Version not supported") +CND(WSANOTINITIALISED, "Winsock not initialized") +CND(WSAEDISCON, "Disconnected") + +#endif + +#ifdef NATIVE + putchar ('\n'); +#endif + +#if defined (__APPLE__) || defined (DUMMY) +/* + + ------------------------------- + -- Darwin-specific constants -- + ------------------------------- + + -- These constants may be used only within the Darwin version of the GNAT + -- runtime library. +*/ + +#define PTHREAD_SIZE __PTHREAD_SIZE__ +CND(PTHREAD_SIZE, "Pad in pthread_t") + +#define PTHREAD_ATTR_SIZE __PTHREAD_ATTR_SIZE__ +CND(PTHREAD_ATTR_SIZE, "Pad in pthread_attr_t") + +#define PTHREAD_MUTEXATTR_SIZE __PTHREAD_MUTEXATTR_SIZE__ +CND(PTHREAD_MUTEXATTR_SIZE, "Pad in pthread_mutexattr_t") + +#define PTHREAD_MUTEX_SIZE __PTHREAD_MUTEX_SIZE__ +CND(PTHREAD_MUTEX_SIZE, "Pad in pthread_mutex_t") + +#define PTHREAD_CONDATTR_SIZE __PTHREAD_CONDATTR_SIZE__ +CND(PTHREAD_CONDATTR_SIZE, "Pad in pthread_condattr_t") + +#define PTHREAD_COND_SIZE __PTHREAD_COND_SIZE__ +CND(PTHREAD_COND_SIZE, "Pad in pthread_cond_t") + +#define PTHREAD_RWLOCKATTR_SIZE __PTHREAD_RWLOCKATTR_SIZE__ +CND(PTHREAD_RWLOCKATTR_SIZE, "Pad in pthread_rwlockattr_t") + +#define PTHREAD_RWLOCK_SIZE __PTHREAD_RWLOCK_SIZE__ +CND(PTHREAD_RWLOCK_SIZE, "Pad in pthread_rwlock_t") + +#define PTHREAD_ONCE_SIZE __PTHREAD_ONCE_SIZE__ +CND(PTHREAD_ONCE_SIZE, "Pad in pthread_once_t") + +#endif + +/* + +end System.OS_Constants; +*/ +} diff --git a/gcc/ada/s-osinte-aix.adb b/gcc/ada/s-osinte-aix.adb new file mode 100644 index 000000000..bfe03a637 --- /dev/null +++ b/gcc/ada/s-osinte-aix.adb @@ -0,0 +1,232 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a AIX (Native) version of this package + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +package body System.OS_Interface is + + use Interfaces.C; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; + end To_Duration; + + ------------------------ + -- To_Target_Priority -- + ------------------------ + + function To_Target_Priority + (Prio : System.Any_Priority) return Interfaces.C.int + is + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + begin + -- For the case SCHED_OTHER the only valid priority across all supported + -- versions of AIX is 1 (note that the scheduling policy can be set + -- with the pragma Task_Dispatching_Policy or setting the time slice + -- value). Otherwise, for SCHED_RR and SCHED_FIFO, the system defines + -- priorities in the range 1 .. 127. This means that we must map + -- System.Any_Priority in the range 0 .. 126 to 1 .. 127. + + if Dispatching_Policy = ' ' and then Time_Slice_Val < 0 then + return 1; + else + return Interfaces.C.int (Prio) + 1; + end if; + end To_Target_Priority; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F is negative due to a round-up, adjust for positive F value + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return timespec'(tv_sec => S, + tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ------------------- + -- clock_gettime -- + ------------------- + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) + return int + is + pragma Unreferenced (clock_id); + + -- Older AIX don't have clock_gettime, so use gettimeofday + + use Interfaces; + + type timeval is array (1 .. 2) of C.long; + + procedure timeval_to_duration + (T : not null access timeval; + sec : not null access C.long; + usec : not null access C.long); + pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); + + Micro : constant := 10**6; + sec : aliased C.long; + usec : aliased C.long; + TV : aliased timeval; + Result : int; + + function gettimeofday + (Tv : access timeval; + Tz : System.Address := System.Null_Address) return int; + pragma Import (C, gettimeofday, "gettimeofday"); + + begin + Result := gettimeofday (TV'Access, System.Null_Address); + pragma Assert (Result = 0); + timeval_to_duration (TV'Access, sec'Access, usec'Access); + tp.all := To_Timespec (Duration (sec) + Duration (usec) / Micro); + return Result; + end clock_gettime; + + ----------------- + -- sched_yield -- + ----------------- + + -- AIX Thread does not have sched_yield; + + function sched_yield return int is + procedure pthread_yield; + pragma Import (C, pthread_yield, "sched_yield"); + begin + pthread_yield; + return 0; + end sched_yield; + + -------------------- + -- Get_Stack_Base -- + -------------------- + + function Get_Stack_Base (thread : pthread_t) return Address is + pragma Warnings (Off, thread); + begin + return Null_Address; + end Get_Stack_Base; + + -------------------------- + -- PTHREAD_PRIO_INHERIT -- + -------------------------- + + AIX_Version : Integer := 0; + -- AIX version in the form xy for AIX version x.y (0 means not set) + + SYS_NMLN : constant := 32; + -- AIX system constant used to define utsname, see sys/utsname.h + + subtype String_NMLN is String (1 .. SYS_NMLN); + + type utsname is record + sysname : String_NMLN; + nodename : String_NMLN; + release : String_NMLN; + version : String_NMLN; + machine : String_NMLN; + procserial : String_NMLN; + end record; + pragma Convention (C, utsname); + + procedure uname (name : out utsname); + pragma Import (C, uname); + + function PTHREAD_PRIO_INHERIT return int is + name : utsname; + + function Val (C : Character) return Integer; + -- Transform a numeric character ('0' .. '9') to an integer + + --------- + -- Val -- + --------- + + function Val (C : Character) return Integer is + begin + return Character'Pos (C) - Character'Pos ('0'); + end Val; + + -- Start of processing for PTHREAD_PRIO_INHERIT + + begin + if AIX_Version = 0 then + + -- Set AIX_Version + + uname (name); + AIX_Version := Val (name.version (1)) * 10 + Val (name.release (1)); + end if; + + if AIX_Version < 53 then + + -- Under AIX < 5.3, PTHREAD_PRIO_INHERIT is defined as 0 in pthread.h + + return 0; + + else + -- Under AIX >= 5.3, PTHREAD_PRIO_INHERIT is defined as 3 + + return 3; + end if; + end PTHREAD_PRIO_INHERIT; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-aix.ads b/gcc/ada/s-osinte-aix.ads new file mode 100644 index 000000000..64907fb30 --- /dev/null +++ b/gcc/ada/s-osinte-aix.ads @@ -0,0 +1,602 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a AIX (Native THREADS) version of this package + +-- This package encapsulates all direct interfaces to OS services that are +-- needed by the tasking run-time (libgnarl). + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Ada.Unchecked_Conversion; + +with Interfaces.C; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-pthread"); + -- This implies -lpthreads + other things depending on the GCC + -- configuration, such as the selection of a proper libgcc variant + -- for table-based exception handling when it is available. + + pragma Linker_Options ("-lc_r"); + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIMEDOUT : constant := 78; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 63; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 30; -- user defined signal 1 + SIGUSR2 : constant := 31; -- user defined signal 2 + SIGCLD : constant := 20; -- alias for SIGCHLD + SIGCHLD : constant := 20; -- child status change + SIGPWR : constant := 29; -- power-fail restart + SIGWINCH : constant := 28; -- window size change + SIGURG : constant := 16; -- urgent condition on IO channel + SIGPOLL : constant := 23; -- pollable event occurred + SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias) + SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 18; -- user stop requested from tty + SIGCONT : constant := 19; -- stopped process has been continued + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGVTALRM : constant := 34; -- virtual timer expired + SIGPROF : constant := 32; -- profiling timer expired + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGWAITING : constant := 39; -- m:n scheduling + + -- The following signals are AIX specific + + SIGMSG : constant := 27; -- input data is in the ring buffer + SIGDANGER : constant := 33; -- system crash imminent + SIGMIGRATE : constant := 35; -- migrate process + SIGPRE : constant := 36; -- programming exception + SIGVIRT : constant := 37; -- AIX virtual time alarm + SIGALRM1 : constant := 38; -- m:n condition variables + SIGCPUFAIL : constant := 59; -- Predictive De-configuration of Processors + SIGKAP : constant := 60; -- keep alive poll from native keyboard + SIGGRANT : constant := SIGKAP; -- monitor mode granted + SIGRETRACT : constant := 61; -- monitor mode should be relinquished + SIGSOUND : constant := 62; -- sound control has completed + SIGSAK : constant := 63; -- secure attention key + + SIGADAABORT : constant := SIGEMT; + -- Note: on other targets, we usually use SIGABRT, but on AIX, it appears + -- that SIGABRT can't be used in sigwait(), so we use SIGEMT. + -- SIGEMT is "Emulator Trap Instruction" from the PDP-11, and does not + -- have a standardized usage. + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := + (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF); + Reserved : constant Signal_Set := + (SIGABRT, SIGKILL, SIGSTOP, SIGALRM1, SIGWAITING, SIGCPUFAIL); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SA_SIGINFO : constant := 16#0100#; + SA_ONSTACK : constant := 16#0001#; + + SIG_BLOCK : constant := 0; + SIG_UNBLOCK : constant := 1; + SIG_SETMASK : constant := 2; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + Time_Slice_Supported : constant Boolean := True; + -- Indicates whether time slicing is supported + + type timespec is private; + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int; + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timezone is record + tz_minuteswest : int; + tz_dsttime : int; + end record; + pragma Convention (C, struct_timezone); + type struct_timezone_ptr is access all struct_timezone; + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 1; + SCHED_RR : constant := 2; + SCHED_OTHER : constant := 0; + + function To_Target_Priority + (Prio : System.Any_Priority) return Interfaces.C.int; + -- Maps System.Any_Priority to a POSIX priority + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------- + -- LWP -- + --------- + + function lwp_self return System.Address; + pragma Import (C, lwp_self, "thread_self"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + pragma Convention (C, Thread_Body); + + function Thread_Body_Access is new + Ada.Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 1; + + PTHREAD_SCOPE_PROCESS : constant := 1; + PTHREAD_SCOPE_SYSTEM : constant := 0; + + ----------- + -- Stack -- + ----------- + + type stack_t is record + ss_sp : System.Address; + ss_size : size_t; + ss_flags : int; + end record; + pragma Convention (C, stack_t); + + function sigaltstack + (ss : not null access stack_t; + oss : access stack_t) return int; + pragma Import (C, sigaltstack, "sigaltstack"); + + Alternate_Stack : aliased System.Address; + -- This is a dummy definition, never used (Alternate_Stack_Size is null) + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + + Stack_Base_Available : constant Boolean := False; + -- Indicates whether the stack base is available on this target + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- Returns the stack base of the specified thread. Only call this function + -- when Stack_Base_Available is True. + + function Get_Page_Size return size_t; + function Get_Page_Size return Address; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- Returns the size of a page + + PROT_NONE : constant := 0; + PROT_READ : constant := 1; + PROT_WRITE : constant := 2; + PROT_EXEC : constant := 4; + PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; + PROT_ON : constant := PROT_READ; + PROT_OFF : constant := PROT_ALL; + + function mprotect (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + -- Though not documented, pthread_init *must* be called before any other + -- pthread call. + + procedure pthread_init; + pragma Import (C, pthread_init, "pthread_init"); + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Import (C, sigwait, "sigwait"); + + function pthread_kill + (thread : pthread_t; + sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + function pthread_sigmask + (how : int; + set : access sigset_t; + oset : access sigset_t) return int; + pragma Import (C, pthread_sigmask, "sigthreadmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); + + Relative_Timed_Wait : constant Boolean := False; + -- pthread_cond_timedwait requires an absolute delay time + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + PTHREAD_PRIO_PROTECT : constant := 2; + + function PTHREAD_PRIO_INHERIT return int; + -- Return value of C macro PTHREAD_PRIO_INHERIT. This function is needed + -- since the value is different between AIX versions. + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import (C, pthread_mutexattr_setprioceiling); + + type Array_5_Int is array (0 .. 5) of int; + type struct_sched_param is record + sched_priority : int; + sched_policy : int; + sched_reserved : Array_5_Int; + end record; + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import (C, pthread_attr_setinheritsched); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy); + + function pthread_attr_setschedparam + (attr : access pthread_attr_t; + sched_param : int) return int; + pragma Import (C, pthread_attr_setschedparam); + + function sched_yield return int; + -- AIX have a nonstandard sched_yield + + -------------------------- + -- P1003.1c Section 16 -- + -------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import (C, pthread_attr_setdetachstate); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) + return int; + pragma Import (C, pthread_create, "pthread_create"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Import (C, pthread_getspecific, "pthread_getspecific"); + + type destructor_pointer is access procedure (arg : System.Address); + pragma Convention (C, destructor_pointer); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + +private + type sigset_t is record + losigs : unsigned_long; + hisigs : unsigned_long; + end record; + pragma Convention (C_Pass_By_Copy, sigset_t); + + type pid_t is new int; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 0; + + type pthread_attr_t is new System.Address; + pragma Convention (C, pthread_attr_t); + -- typedef struct __pt_attr *pthread_attr_t; + + type pthread_condattr_t is new System.Address; + pragma Convention (C, pthread_condattr_t); + -- typedef struct __pt_attr *pthread_condattr_t; + + type pthread_mutexattr_t is new System.Address; + pragma Convention (C, pthread_mutexattr_t); + -- typedef struct __pt_attr *pthread_mutexattr_t; + + type pthread_t is new System.Address; + pragma Convention (C, pthread_t); + -- typedef void *pthread_t; + + type ptq_queue; + type ptq_queue_ptr is access all ptq_queue; + + type ptq_queue is record + ptq_next : ptq_queue_ptr; + ptq_prev : ptq_queue_ptr; + end record; + + type Array_3_Int is array (0 .. 3) of int; + type pthread_mutex_t is record + link : ptq_queue; + ptmtx_lock : int; + ptmtx_flags : long; + protocol : int; + prioceiling : int; + ptmtx_owner : pthread_t; + mtx_id : int; + attr : pthread_attr_t; + mtx_kind : int; + lock_cpt : int; + reserved : Array_3_Int; + end record; + pragma Convention (C, pthread_mutex_t); + type pthread_mutex_t_ptr is access pthread_mutex_t; + + type pthread_cond_t is record + link : ptq_queue; + ptcv_lock : int; + ptcv_flags : long; + ptcv_waiters : ptq_queue; + cv_id : int; + attr : pthread_attr_t; + mutex : pthread_mutex_t_ptr; + cptwait : int; + reserved : int; + end record; + pragma Convention (C, pthread_cond_t); + + type pthread_key_t is new unsigned; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-darwin.adb b/gcc/ada/s-osinte-darwin.adb new file mode 100644 index 000000000..3bf0bb96d --- /dev/null +++ b/gcc/ada/s-osinte-darwin.adb @@ -0,0 +1,170 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a Darwin Threads version of this package + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +package body System.OS_Interface is + + use Interfaces.C; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; + end To_Duration; + + ------------------------ + -- To_Target_Priority -- + ------------------------ + + function To_Target_Priority + (Prio : System.Any_Priority) return Interfaces.C.int + is + begin + return Interfaces.C.int (Prio); + end To_Target_Priority; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return timespec'(tv_sec => S, + tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ------------------- + -- clock_gettime -- + ------------------- + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int + is + pragma Unreferenced (clock_id); + + -- Darwin Threads don't have clock_gettime, so use gettimeofday + + use Interfaces; + + type timeval is array (1 .. 2) of C.long; + + procedure timeval_to_duration + (T : not null access timeval; + sec : not null access C.long; + usec : not null access C.long); + pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); + + Micro : constant := 10**6; + sec : aliased C.long; + usec : aliased C.long; + TV : aliased timeval; + Result : int; + + function gettimeofday + (Tv : access timeval; + Tz : System.Address := System.Null_Address) return int; + pragma Import (C, gettimeofday, "gettimeofday"); + + begin + Result := gettimeofday (TV'Access, System.Null_Address); + pragma Assert (Result = 0); + timeval_to_duration (TV'Access, sec'Access, usec'Access); + tp.all := To_Timespec (Duration (sec) + Duration (usec) / Micro); + return Result; + end clock_gettime; + + ----------------- + -- sched_yield -- + ----------------- + + function sched_yield return int is + procedure sched_yield_base (arg : System.Address); + pragma Import (C, sched_yield_base, "pthread_yield_np"); + + begin + sched_yield_base (System.Null_Address); + return 0; + end sched_yield; + + -------------- + -- lwp_self -- + -------------- + + function lwp_self return Address is + function pthread_mach_thread_np (thread : pthread_t) return Address; + pragma Import (C, pthread_mach_thread_np, "pthread_mach_thread_np"); + begin + return pthread_mach_thread_np (pthread_self); + end lwp_self; + + ------------------ + -- pthread_init -- + ------------------ + + procedure pthread_init is + begin + null; + end pthread_init; + + ---------------- + -- Stack_Base -- + ---------------- + + function Get_Stack_Base (thread : pthread_t) return Address is + pragma Unreferenced (thread); + begin + return System.Null_Address; + end Get_Stack_Base; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-darwin.ads b/gcc/ada/s-osinte-darwin.ads new file mode 100644 index 000000000..ed2f93124 --- /dev/null +++ b/gcc/ada/s-osinte-darwin.ads @@ -0,0 +1,596 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is Darwin pthreads version of this package + +-- This package includes all direct interfaces to OS services that are needed +-- by the tasking run-time (libgnarl). + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Elaborate_Body. It is designed to be a bottom-level (leaf) package. + +with Interfaces.C; +with System.OS_Constants; + +package System.OS_Interface is + pragma Preelaborate; + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EINTR : constant := 4; + ENOMEM : constant := 12; + EINVAL : constant := 22; + EAGAIN : constant := 35; + ETIMEDOUT : constant := 60; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 31; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGURG : constant := 16; -- urgent condition on IO channel + SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 18; -- user stop requested from tty + SIGCONT : constant := 19; -- stopped process has been continued + SIGCHLD : constant := 20; -- child status change + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias) + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 27; -- profiling timer expired + SIGWINCH : constant := 28; -- window size change + SIGINFO : constant := 29; -- information request + SIGUSR1 : constant := 30; -- user defined signal 1 + SIGUSR2 : constant := 31; -- user defined signal 2 + + SIGADAABORT : constant := SIGTERM; + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := + (SIGTTIN, SIGTTOU, SIGSTOP, SIGTSTP); + + Reserved : constant Signal_Set := + (SIGKILL, SIGSTOP); + + Exception_Signals : constant Signal_Set := + (SIGFPE, SIGILL, SIGSEGV, SIGBUS); + -- These signals (when runtime or system) will be caught and converted + -- into an Ada exception. + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type siginfo_t is private; + type ucontext_t is private; + + type Signal_Handler is access procedure + (signo : Signal; + info : access siginfo_t; + context : access ucontext_t); + + type struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SIG_BLOCK : constant := 1; + SIG_UNBLOCK : constant := 2; + SIG_SETMASK : constant := 3; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + SA_SIGINFO : constant := 16#0040#; + SA_ONSTACK : constant := 16#0001#; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + Time_Slice_Supported : constant Boolean := True; + -- Indicates whether time slicing is supported + + type timespec is private; + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int; + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_OTHER : constant := 1; + SCHED_RR : constant := 2; + SCHED_FIFO : constant := 4; + + function To_Target_Priority + (Prio : System.Any_Priority) return Interfaces.C.int; + -- Maps System.Any_Priority to a POSIX priority + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------- + -- LWP -- + --------- + + function lwp_self return System.Address; + -- Return the mach thread bound to the current thread. The value is not + -- used by the run-time library but made available to debuggers. + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + pragma Convention (C, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + type pthread_mutex_ptr is access all pthread_mutex_t; + type pthread_cond_ptr is access all pthread_cond_t; + + PTHREAD_CREATE_DETACHED : constant := 2; + + PTHREAD_SCOPE_PROCESS : constant := 2; + PTHREAD_SCOPE_SYSTEM : constant := 1; + + ----------- + -- Stack -- + ----------- + + type stack_t is record + ss_sp : System.Address; + ss_size : size_t; + ss_flags : int; + end record; + pragma Convention (C, stack_t); + + function sigaltstack + (ss : not null access stack_t; + oss : access stack_t) return int; + pragma Import (C, sigaltstack, "sigaltstack"); + + Alternate_Stack : aliased System.Address; + pragma Import (C, Alternate_Stack, "__gnat_alternate_stack"); + -- The alternate signal stack for stack overflows + + Alternate_Stack_Size : constant := 32 * 1024; + -- This must be in keeping with init.c:__gnat_alternate_stack + + Stack_Base_Available : constant Boolean := False; + -- Indicates whether the stack base is available on this target. This + -- allows us to share s-osinte.adb between all the FSU run time. Note that + -- this value can only be true if pthread_t has a complete definition that + -- corresponds exactly to the C header files. + + function Get_Stack_Base (thread : pthread_t) return System.Address; + pragma Inline (Get_Stack_Base); + -- returns the stack base of the specified thread. Only call this function + -- when Stack_Base_Available is True. + + function Get_Page_Size return size_t; + function Get_Page_Size return System.Address; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- Returns the size of a page + + PROT_NONE : constant := 0; + PROT_READ : constant := 1; + PROT_WRITE : constant := 2; + PROT_EXEC : constant := 4; + PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; + + PROT_ON : constant := PROT_NONE; + PROT_OFF : constant := PROT_ALL; + + function mprotect + (addr : System.Address; + len : size_t; + prot : int) return int; + pragma Import (C, mprotect); + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + procedure pthread_init; + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait (set : access sigset_t; sig : access Signal) return int; + pragma Import (C, sigwait, "sigwait"); + + function pthread_kill (thread : pthread_t; sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + function pthread_sigmask + (how : int; + set : access sigset_t; + oset : access sigset_t) return int; + pragma Import (C, pthread_sigmask, "pthread_sigmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); + + Relative_Timed_Wait : constant Boolean := False; + -- pthread_cond_timedwait requires an absolute delay time + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + PTHREAD_PRIO_NONE : constant := 0; + PTHREAD_PRIO_INHERIT : constant := 1; + PTHREAD_PRIO_PROTECT : constant := 2; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import + (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol"); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import + (C, pthread_mutexattr_setprioceiling, + "pthread_mutexattr_setprioceiling"); + + type padding is array (int range <>) of Interfaces.C.char; + + type struct_sched_param is record + sched_priority : int; -- scheduling priority + opaque : padding (1 .. 4); + end record; + pragma Convention (C, struct_sched_param); + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import + (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched"); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy, "pthread_attr_setsched"); + + function sched_yield return int; + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import + (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate"); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import + (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "pthread_create"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Import (C, pthread_getspecific, "pthread_getspecific"); + + type destructor_pointer is access procedure (arg : System.Address); + pragma Convention (C, destructor_pointer); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + +private + + type sigset_t is new unsigned; + + type int32_t is new int; + + type pid_t is new int32_t; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 0; + + -- + -- Darwin specific signal implementation + -- + type Pad_Type is array (1 .. 7) of unsigned_long; + type siginfo_t is record + si_signo : int; -- signal number + si_errno : int; -- errno association + si_code : int; -- signal code + si_pid : int; -- sending process + si_uid : unsigned; -- sender's ruid + si_status : int; -- exit value + si_addr : System.Address; -- faulting instruction + si_value : System.Address; -- signal value + si_band : long; -- band event for SIGPOLL + pad : Pad_Type; -- RFU + end record; + pragma Convention (C, siginfo_t); + + type mcontext_t is new System.Address; + + type ucontext_t is record + uc_onstack : int; + uc_sigmask : sigset_t; -- Signal Mask Used By This Context + uc_stack : stack_t; -- Stack Used By This Context + uc_link : System.Address; -- Pointer To Resuming Context + uc_mcsize : size_t; -- Size of The Machine Context + uc_mcontext : mcontext_t; -- Machine Specific Context + end record; + pragma Convention (C, ucontext_t); + + -- + -- Darwin specific pthread implementation + -- + type pthread_t is new System.Address; + + type pthread_attr_t is record + sig : long; + opaque : padding (1 .. System.OS_Constants.PTHREAD_ATTR_SIZE); + end record; + pragma Convention (C, pthread_attr_t); + + type pthread_mutexattr_t is record + sig : long; + opaque : padding (1 .. System.OS_Constants.PTHREAD_MUTEXATTR_SIZE); + end record; + pragma Convention (C, pthread_mutexattr_t); + + type pthread_mutex_t is record + sig : long; + opaque : padding (1 .. System.OS_Constants.PTHREAD_MUTEX_SIZE); + end record; + pragma Convention (C, pthread_mutex_t); + + type pthread_condattr_t is record + sig : long; + opaque : padding (1 .. System.OS_Constants.PTHREAD_CONDATTR_SIZE); + end record; + pragma Convention (C, pthread_condattr_t); + + type pthread_cond_t is record + sig : long; + opaque : padding (1 .. System.OS_Constants.PTHREAD_COND_SIZE); + end record; + pragma Convention (C, pthread_cond_t); + + type pthread_once_t is record + sig : long; + opaque : padding (1 .. System.OS_Constants.PTHREAD_ONCE_SIZE); + end record; + pragma Convention (C, pthread_once_t); + + type pthread_key_t is new unsigned_long; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-dummy.ads b/gcc/ada/s-osinte-dummy.ads new file mode 100644 index 000000000..f459a64fd --- /dev/null +++ b/gcc/ada/s-osinte-dummy.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the no tasking version + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +package System.OS_Interface is + pragma Preelaborate; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 2; + type Signal is new Integer range 0 .. Max_Interrupt; + + type sigset_t is new Integer; + type Thread_Id is new Integer; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-freebsd.adb b/gcc/ada/s-osinte-freebsd.adb new file mode 100644 index 000000000..9ad969e8b --- /dev/null +++ b/gcc/ada/s-osinte-freebsd.adb @@ -0,0 +1,115 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. It is -- +-- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- +-- State University (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This is the FreeBSD THREADS version of this package + +with Interfaces.C; use Interfaces.C; + +package body System.OS_Interface is + + ----------- + -- Errno -- + ----------- + + function Errno return int is + type int_ptr is access all int; + + function internal_errno return int_ptr; + pragma Import (C, internal_errno, "__error"); + + begin + return (internal_errno.all); + end Errno; + + -------------------- + -- Get_Stack_Base -- + -------------------- + + function Get_Stack_Base (thread : pthread_t) return Address is + pragma Unreferenced (thread); + begin + return (0); + end Get_Stack_Base; + + ------------------ + -- pthread_init -- + ------------------ + + procedure pthread_init is + begin + null; + end pthread_init; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9; + end To_Duration; + + ------------------------ + -- To_Target_Priority -- + ------------------------ + + function To_Target_Priority + (Prio : System.Any_Priority) return Interfaces.C.int + is + begin + return Interfaces.C.int (Prio); + end To_Target_Priority; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return timespec'(ts_sec => S, + ts_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-freebsd.ads b/gcc/ada/s-osinte-freebsd.ads new file mode 100644 index 000000000..c83782921 --- /dev/null +++ b/gcc/ada/s-osinte-freebsd.ads @@ -0,0 +1,650 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. It is -- +-- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- +-- State University (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This is the FreeBSD PTHREADS version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by the tasking run-time (libgnarl). + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Ada.Unchecked_Conversion; + +with Interfaces.C; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-pthread"); + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function Errno return int; + pragma Inline (Errno); + + EAGAIN : constant := 35; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIMEDOUT : constant := 60; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 31; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGURG : constant := 16; -- urgent condition on IO channel + SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 18; -- user stop requested from tty + SIGCONT : constant := 19; -- stopped process has been continued + SIGCLD : constant := 20; -- alias for SIGCHLD + SIGCHLD : constant := 20; -- child status change + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias) + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 27; -- profiling timer expired + SIGWINCH : constant := 28; -- window size change + SIGINFO : constant := 29; -- information request (NetBSD/FreeBSD) + SIGUSR1 : constant := 30; -- user defined signal 1 + SIGUSR2 : constant := 31; -- user defined signal 2 + + SIGADAABORT : constant := SIGABRT; + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + type Signal_Set is array (Natural range <>) of Signal; + + -- Interrupts that must be unmasked at all times. FreeBSD + -- pthreads will not allow an application to mask out any + -- interrupt needed by the threads library. + Unmasked : constant Signal_Set := + (SIGTRAP, SIGBUS, SIGTTIN, SIGTTOU, SIGTSTP); + + -- FreeBSD will uses SIGPROF for timing. Do not allow a + -- handler to attach to this signal. + Reserved : constant Signal_Set := (0 .. 0 => SIGPROF); + + type sigset_t is private; + + function sigaddset + (set : access sigset_t; + sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset + (set : access sigset_t; + sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember + (set : access sigset_t; + sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + -- sigcontext is architecture dependent, so define it private + type struct_sigcontext is private; + + type old_struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; + end record; + pragma Convention (C, old_struct_sigaction); + + type new_struct_sigaction is record + sa_handler : System.Address; + sa_flags : int; + sa_mask : sigset_t; + end record; + pragma Convention (C, new_struct_sigaction); + + subtype struct_sigaction is new_struct_sigaction; + type struct_sigaction_ptr is access all struct_sigaction; + + SIG_BLOCK : constant := 1; + SIG_UNBLOCK : constant := 2; + SIG_SETMASK : constant := 3; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + SA_SIGINFO : constant := 16#0040#; + SA_ONSTACK : constant := 16#0001#; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + Time_Slice_Supported : constant Boolean := True; + -- Indicates whether time slicing is supported (i.e SCHED_RR is supported) + + type timespec is private; + + function nanosleep (rqtp, rmtp : access timespec) return int; + pragma Import (C, nanosleep, "nanosleep"); + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) + return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timezone is record + tz_minuteswest : int; + tz_dsttime : int; + end record; + pragma Convention (C, struct_timezone); + + procedure usleep (useconds : unsigned_long); + pragma Import (C, usleep, "usleep"); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 1; + SCHED_OTHER : constant := 2; + SCHED_RR : constant := 3; + + function To_Target_Priority + (Prio : System.Any_Priority) return Interfaces.C.int; + -- Maps System.Any_Priority to a POSIX priority + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + Self_PID : constant pid_t; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------- + -- LWP -- + --------- + + function lwp_self return System.Address; + -- lwp_self does not exist on this thread library, revert to pthread_self + -- which is the closest approximation (with getpid). This function is + -- needed to share 7staprop.adb across POSIX-like targets. + pragma Import (C, lwp_self, "pthread_self"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + pragma Convention (C, Thread_Body); + + function Thread_Body_Access is new + Ada.Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 1; + PTHREAD_CREATE_JOINABLE : constant := 0; + + PTHREAD_SCOPE_PROCESS : constant := 0; + PTHREAD_SCOPE_SYSTEM : constant := 2; + + ----------- + -- Stack -- + ----------- + + type stack_t is record + ss_sp : System.Address; + ss_size : size_t; + ss_flags : int; + end record; + pragma Convention (C, stack_t); + + function sigaltstack + (ss : not null access stack_t; + oss : access stack_t) return int; + pragma Import (C, sigaltstack, "sigaltstack"); + + Alternate_Stack : aliased System.Address; + -- This is a dummy definition, never used (Alternate_Stack_Size is null) + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + + Stack_Base_Available : constant Boolean := False; + -- Indicates whether the stack base is available on this target. This + -- allows us to share s-osinte.adb between all the FSU run time. Note that + -- this value can only be true if pthread_t has a complete definition that + -- corresponds exactly to the C header files. + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- returns the stack base of the specified thread. Only call this function + -- when Stack_Base_Available is True. + + function Get_Page_Size return size_t; + function Get_Page_Size return Address; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- Returns the size of a page + + PROT_NONE : constant := 0; + PROT_READ : constant := 1; + PROT_WRITE : constant := 2; + PROT_EXEC : constant := 4; + PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; + PROT_ON : constant := PROT_NONE; + PROT_OFF : constant := PROT_ALL; + + function mprotect (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + -- FSU_THREADS requires pthread_init, which is nonstandard and this should + -- be invoked during the elaboration of s-taprop.adb. + + -- FreeBSD does not require this so we provide an empty Ada body + + procedure pthread_init; + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Import (C, sigwait, "sigwait"); + + function pthread_kill + (thread : pthread_t; + sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + function pthread_sigmask + (how : int; + set : access sigset_t; + oset : access sigset_t) return int; + pragma Import (C, pthread_sigmask, "pthread_sigmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); + + Relative_Timed_Wait : constant Boolean := False; + -- pthread_cond_timedwait requires an absolute delay time + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + PTHREAD_PRIO_NONE : constant := 0; + PTHREAD_PRIO_PROTECT : constant := 2; + PTHREAD_PRIO_INHERIT : constant := 1; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import + (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol"); + + function pthread_mutexattr_getprotocol + (attr : access pthread_mutexattr_t; + protocol : access int) return int; + pragma Import + (C, pthread_mutexattr_getprotocol, "pthread_mutexattr_getprotocol"); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import + (C, pthread_mutexattr_setprioceiling, + "pthread_mutexattr_setprioceiling"); + + function pthread_mutexattr_getprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : access int) return int; + pragma Import + (C, pthread_mutexattr_getprioceiling, + "pthread_mutexattr_getprioceiling"); + + type struct_sched_param is record + sched_priority : int; + end record; + pragma Convention (C, struct_sched_param); + + function pthread_getschedparam + (thread : pthread_t; + policy : access int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_getschedparam, "pthread_getschedparam"); + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_getscope + (attr : access pthread_attr_t; + contentionscope : access int) return int; + pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import + (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched"); + + function pthread_attr_getinheritsched + (attr : access pthread_attr_t; + inheritsched : access int) return int; + pragma Import + (C, pthread_attr_getinheritsched, "pthread_attr_getinheritsched"); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy, + "pthread_attr_setschedpolicy"); + + function pthread_attr_getschedpolicy + (attr : access pthread_attr_t; + policy : access int) return int; + pragma Import (C, pthread_attr_getschedpolicy, + "pthread_attr_getschedpolicy"); + + function pthread_attr_setschedparam + (attr : access pthread_attr_t; + sched_param : int) return int; + pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam"); + + function pthread_attr_getschedparam + (attr : access pthread_attr_t; + sched_param : access int) return int; + pragma Import (C, pthread_attr_getschedparam, "pthread_attr_getschedparam"); + + function sched_yield return int; + pragma Import (C, sched_yield, "pthread_yield"); + + -------------------------- + -- P1003.1c Section 16 -- + -------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import + (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate"); + + function pthread_attr_getdetachstate + (attr : access pthread_attr_t; + detachstate : access int) return int; + pragma Import + (C, pthread_attr_getdetachstate, "pthread_attr_getdetachstate"); + + function pthread_attr_getstacksize + (attr : access pthread_attr_t; + stacksize : access size_t) return int; + pragma Import + (C, pthread_attr_getstacksize, "pthread_attr_getstacksize"); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import + (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "pthread_create"); + + function pthread_detach (thread : pthread_t) return int; + pragma Import (C, pthread_detach, "pthread_detach"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Import (C, pthread_getspecific, "pthread_getspecific"); + + type destructor_pointer is access procedure (arg : System.Address); + pragma Convention (C, destructor_pointer); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + + ------------------------------------ + -- Non-portable Pthread Functions -- + ------------------------------------ + + function pthread_set_name_np + (thread : pthread_t; + name : System.Address) return int; + pragma Import (C, pthread_set_name_np, "pthread_set_name_np"); + +private + + type sigset_t is array (1 .. 4) of unsigned; + + -- In FreeBSD the component sa_handler turns out to + -- be one a union type, and the selector is a macro: + -- #define sa_handler __sigaction_u._handler + -- #define sa_sigaction __sigaction_u._sigaction + + -- Should we add a signal_context type here ??? + -- How could it be done independent of the CPU architecture ??? + -- sigcontext type is opaque, so it is architecturally neutral. + -- It is always passed as an access type, so define it as an empty record + -- since the contents are not used anywhere. + + type struct_sigcontext is null record; + pragma Convention (C, struct_sigcontext); + + type pid_t is new int; + Self_PID : constant pid_t := 0; + + type time_t is new long; + + type timespec is record + ts_sec : time_t; + ts_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 0; + + type pthread_t is new System.Address; + type pthread_attr_t is new System.Address; + type pthread_mutex_t is new System.Address; + type pthread_mutexattr_t is new System.Address; + type pthread_cond_t is new System.Address; + type pthread_condattr_t is new System.Address; + type pthread_key_t is new int; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-hpux-dce.adb b/gcc/ada/s-osinte-hpux-dce.adb new file mode 100644 index 000000000..8844d17e0 --- /dev/null +++ b/gcc/ada/s-osinte-hpux-dce.adb @@ -0,0 +1,500 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2009, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a DCE version of this package. +-- Currently HP-UX and SNI use this file + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +with Interfaces.C; use Interfaces.C; + +package body System.OS_Interface is + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; + end To_Duration; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return timespec'(tv_sec => S, + tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int + is + Result : int; + + begin + Result := sigwait (set); + + if Result = -1 then + sig.all := 0; + return errno; + end if; + + sig.all := Signal (Result); + return 0; + end sigwait; + + -- DCE_THREADS does not have pthread_kill. Instead, we just ignore it + + function pthread_kill (thread : pthread_t; sig : Signal) return int is + pragma Unreferenced (thread, sig); + begin + return 0; + end pthread_kill; + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + -- For all following functions, DCE Threads has a non standard behavior. + -- It sets errno but the standard Posix requires it to be returned. + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int + is + function pthread_mutexattr_create + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_create, "pthread_mutexattr_create"); + + begin + if pthread_mutexattr_create (attr) /= 0 then + return errno; + else + return 0; + end if; + end pthread_mutexattr_init; + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int + is + function pthread_mutexattr_delete + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_delete, "pthread_mutexattr_delete"); + + begin + if pthread_mutexattr_delete (attr) /= 0 then + return errno; + else + return 0; + end if; + end pthread_mutexattr_destroy; + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int + is + function pthread_mutex_init_base + (mutex : access pthread_mutex_t; + attr : pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init_base, "pthread_mutex_init"); + + begin + if pthread_mutex_init_base (mutex, attr.all) /= 0 then + return errno; + else + return 0; + end if; + end pthread_mutex_init; + + function pthread_mutex_destroy + (mutex : access pthread_mutex_t) return int + is + function pthread_mutex_destroy_base + (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy_base, "pthread_mutex_destroy"); + + begin + if pthread_mutex_destroy_base (mutex) /= 0 then + return errno; + else + return 0; + end if; + end pthread_mutex_destroy; + + function pthread_mutex_lock + (mutex : access pthread_mutex_t) return int + is + function pthread_mutex_lock_base + (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock_base, "pthread_mutex_lock"); + + begin + if pthread_mutex_lock_base (mutex) /= 0 then + return errno; + else + return 0; + end if; + end pthread_mutex_lock; + + function pthread_mutex_unlock + (mutex : access pthread_mutex_t) return int + is + function pthread_mutex_unlock_base + (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock_base, "pthread_mutex_unlock"); + + begin + if pthread_mutex_unlock_base (mutex) /= 0 then + return errno; + else + return 0; + end if; + end pthread_mutex_unlock; + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int + is + function pthread_condattr_create + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_create, "pthread_condattr_create"); + + begin + if pthread_condattr_create (attr) /= 0 then + return errno; + else + return 0; + end if; + end pthread_condattr_init; + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int + is + function pthread_condattr_delete + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_delete, "pthread_condattr_delete"); + + begin + if pthread_condattr_delete (attr) /= 0 then + return errno; + else + return 0; + end if; + end pthread_condattr_destroy; + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int + is + function pthread_cond_init_base + (cond : access pthread_cond_t; + attr : pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init_base, "pthread_cond_init"); + + begin + if pthread_cond_init_base (cond, attr.all) /= 0 then + return errno; + else + return 0; + end if; + end pthread_cond_init; + + function pthread_cond_destroy + (cond : access pthread_cond_t) return int + is + function pthread_cond_destroy_base + (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy_base, "pthread_cond_destroy"); + + begin + if pthread_cond_destroy_base (cond) /= 0 then + return errno; + else + return 0; + end if; + end pthread_cond_destroy; + + function pthread_cond_signal + (cond : access pthread_cond_t) return int + is + function pthread_cond_signal_base + (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal_base, "pthread_cond_signal"); + + begin + if pthread_cond_signal_base (cond) /= 0 then + return errno; + else + return 0; + end if; + end pthread_cond_signal; + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int + is + function pthread_cond_wait_base + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait_base, "pthread_cond_wait"); + + begin + if pthread_cond_wait_base (cond, mutex) /= 0 then + return errno; + else + return 0; + end if; + end pthread_cond_wait; + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int + is + function pthread_cond_timedwait_base + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait_base, "pthread_cond_timedwait"); + + begin + if pthread_cond_timedwait_base (cond, mutex, abstime) /= 0 then + return (if errno = EAGAIN then ETIMEDOUT else errno); + else + return 0; + end if; + end pthread_cond_timedwait; + + ---------------------------- + -- POSIX.1c Section 13 -- + ---------------------------- + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int + is + function pthread_setscheduler + (thread : pthread_t; + policy : int; + priority : int) return int; + pragma Import (C, pthread_setscheduler, "pthread_setscheduler"); + + begin + if pthread_setscheduler (thread, policy, param.sched_priority) = -1 then + return errno; + else + return 0; + end if; + end pthread_setschedparam; + + function sched_yield return int is + procedure pthread_yield; + pragma Import (C, pthread_yield, "pthread_yield"); + begin + pthread_yield; + return 0; + end sched_yield; + + ----------------------------- + -- P1003.1c - Section 16 -- + ----------------------------- + + function pthread_attr_init + (attributes : access pthread_attr_t) return int + is + function pthread_attr_create + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_create, "pthread_attr_create"); + + begin + if pthread_attr_create (attributes) /= 0 then + return errno; + else + return 0; + end if; + end pthread_attr_init; + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int + is + function pthread_attr_delete + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_delete, "pthread_attr_delete"); + + begin + if pthread_attr_delete (attributes) /= 0 then + return errno; + else + return 0; + end if; + end pthread_attr_destroy; + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int + is + function pthread_attr_setstacksize_base + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize_base, + "pthread_attr_setstacksize"); + + begin + if pthread_attr_setstacksize_base (attr, stacksize) /= 0 then + return errno; + else + return 0; + end if; + end pthread_attr_setstacksize; + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int + is + function pthread_create_base + (thread : access pthread_t; + attributes : pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create_base, "pthread_create"); + + begin + if pthread_create_base + (thread, attributes.all, start_routine, arg) /= 0 + then + return errno; + else + return 0; + end if; + end pthread_create; + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int + is + function pthread_setspecific_base + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific_base, "pthread_setspecific"); + + begin + if pthread_setspecific_base (key, value) /= 0 then + return errno; + else + return 0; + end if; + end pthread_setspecific; + + function pthread_getspecific (key : pthread_key_t) return System.Address is + function pthread_getspecific_base + (key : pthread_key_t; + value : access System.Address) return int; + pragma Import (C, pthread_getspecific_base, "pthread_getspecific"); + Addr : aliased System.Address; + + begin + if pthread_getspecific_base (key, Addr'Access) /= 0 then + return System.Null_Address; + else + return Addr; + end if; + end pthread_getspecific; + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int + is + function pthread_keycreate + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_keycreate, "pthread_keycreate"); + + begin + if pthread_keycreate (key, destructor) /= 0 then + return errno; + else + return 0; + end if; + end pthread_key_create; + + function Get_Stack_Base (thread : pthread_t) return Address is + pragma Warnings (Off, thread); + begin + return Null_Address; + end Get_Stack_Base; + + procedure pthread_init is + begin + null; + end pthread_init; + + function intr_attach (sig : int; handler : isr_address) return long is + function c_signal (sig : int; handler : isr_address) return long; + pragma Import (C, c_signal, "signal"); + begin + return c_signal (sig, handler); + end intr_attach; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-hpux-dce.ads b/gcc/ada/s-osinte-hpux-dce.ads new file mode 100644 index 000000000..f39cbfdec --- /dev/null +++ b/gcc/ada/s-osinte-hpux-dce.ads @@ -0,0 +1,483 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the HP-UX version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by the tasking run-time (libgnarl). + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Ada.Unchecked_Conversion; + +with Interfaces.C; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-lcma"); + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIME : constant := 52; + ETIMEDOUT : constant := 238; + + FUNC_ERR : constant := -1; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 44; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 16; -- user defined signal 1 + SIGUSR2 : constant := 17; -- user defined signal 2 + SIGCLD : constant := 18; -- alias for SIGCHLD + SIGCHLD : constant := 18; -- child status change + SIGPWR : constant := 19; -- power-fail restart + SIGVTALRM : constant := 20; -- virtual timer alarm + SIGPROF : constant := 21; -- profiling timer alarm + SIGIO : constant := 22; -- asynchronous I/O + SIGPOLL : constant := 22; -- pollable event occurred + SIGWINCH : constant := 23; -- window size change + SIGSTOP : constant := 24; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 25; -- user stop requested from tty + SIGCONT : constant := 26; -- stopped process has been continued + SIGTTIN : constant := 27; -- background tty read attempted + SIGTTOU : constant := 28; -- background tty write attempted + SIGURG : constant := 29; -- urgent condition on IO channel + SIGLOST : constant := 30; -- remote lock lost (NFS) + SIGDIL : constant := 32; -- DIL signal + SIGXCPU : constant := 33; -- CPU time limit exceeded (setrlimit) + SIGXFSZ : constant := 34; -- file size limit exceeded (setrlimit) + + SIGADAABORT : constant := SIGABRT; + -- Note: on other targets, we usually use SIGABRT, but on HP/UX, it + -- appears that SIGABRT can't be used in sigwait(), so we use SIGTERM. + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := + (SIGBUS, SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP); + + Reserved : constant Signal_Set := (SIGKILL, SIGSTOP); + + type sigset_t is private; + + type isr_address is access procedure (sig : int); + pragma Convention (C, isr_address); + + function intr_attach (sig : int; handler : isr_address) return long; + + Intr_Attach_Reset : constant Boolean := True; + -- True if intr_attach is reset after an interrupt handler is called + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type Signal_Handler is access procedure (signo : Signal); + + type struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SA_RESTART : constant := 16#40#; + SA_SIGINFO : constant := 16#10#; + SA_ONSTACK : constant := 16#01#; + + SIG_BLOCK : constant := 0; + SIG_UNBLOCK : constant := 1; + SIG_SETMASK : constant := 2; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + SIG_ERR : constant := -1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + type timespec is private; + + function nanosleep (rqtp, rmtp : access timespec) return int; + pragma Import (C, nanosleep); + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function Clock_Gettime + (Clock_Id : clockid_t; Tp : access timespec) return int; + pragma Import (C, Clock_Gettime); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 0; + SCHED_RR : constant := 1; + SCHED_OTHER : constant := 2; + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + pragma Convention (C, Thread_Body); + + function Thread_Body_Access is new + Ada.Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + ----------- + -- Stack -- + ----------- + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- This is a dummy procedure to share some GNULLI files + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + procedure pthread_init; + pragma Inline (pthread_init); + -- This is a dummy procedure to share some GNULLI files + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait (set : access sigset_t) return int; + pragma Import (C, sigwait, "cma_sigwait"); + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Inline (sigwait); + -- DCE_THREADS has a nonstandard sigwait + + function pthread_kill + (thread : pthread_t; + sig : Signal) return int; + pragma Inline (pthread_kill); + -- DCE_THREADS doesn't have pthread_kill + + function pthread_sigmask + (how : int; + set : access sigset_t; + oset : access sigset_t) return int; + -- DCE THREADS does not have pthread_sigmask. Instead, it uses sigprocmask + -- to do the signal handling when the thread library is sucked in. + pragma Import (C, pthread_sigmask, "sigprocmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + -- DCE_THREADS has a nonstandard pthread_mutexattr_init + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + -- DCE_THREADS has a nonstandard pthread_mutexattr_destroy + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + -- DCE_THREADS has a nonstandard pthread_mutex_init + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + -- DCE_THREADS has a nonstandard pthread_mutex_destroy + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Inline (pthread_mutex_lock); + -- DCE_THREADS has nonstandard pthread_mutex_lock + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Inline (pthread_mutex_unlock); + -- DCE_THREADS has nonstandard pthread_mutex_lock + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + -- DCE_THREADS has nonstandard pthread_condattr_init + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + -- DCE_THREADS has nonstandard pthread_condattr_destroy + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + -- DCE_THREADS has nonstandard pthread_cond_init + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + -- DCE_THREADS has nonstandard pthread_cond_destroy + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Inline (pthread_cond_signal); + -- DCE_THREADS has nonstandard pthread_cond_signal + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Inline (pthread_cond_wait); + -- DCE_THREADS has a nonstandard pthread_cond_wait + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Inline (pthread_cond_timedwait); + -- DCE_THREADS has a nonstandard pthread_cond_timedwait + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + type struct_sched_param is record + sched_priority : int; -- scheduling priority + end record; + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Inline (pthread_setschedparam); + -- DCE_THREADS has a nonstandard pthread_setschedparam + + function sched_yield return int; + pragma Inline (sched_yield); + -- DCE_THREADS has a nonstandard sched_yield + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Inline (pthread_attr_init); + -- DCE_THREADS has a nonstandard pthread_attr_init + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Inline (pthread_attr_destroy); + -- DCE_THREADS has a nonstandard pthread_attr_destroy + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Inline (pthread_attr_setstacksize); + -- DCE_THREADS has a nonstandard pthread_attr_setstacksize + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Inline (pthread_create); + -- DCE_THREADS has a nonstandard pthread_create + + procedure pthread_detach (thread : access pthread_t); + pragma Import (C, pthread_detach); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Inline (pthread_setspecific); + -- DCE_THREADS has a nonstandard pthread_setspecific + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Inline (pthread_getspecific); + -- DCE_THREADS has a nonstandard pthread_getspecific + + type destructor_pointer is access procedure (arg : System.Address); + pragma Convention (C, destructor_pointer); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Inline (pthread_key_create); + -- DCE_THREADS has a nonstandard pthread_key_create + +private + + type array_type_1 is array (Integer range 0 .. 7) of unsigned_long; + type sigset_t is record + X_X_sigbits : array_type_1; + end record; + pragma Convention (C, sigset_t); + + type pid_t is new int; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 1; + + type cma_t_address is new System.Address; + + type cma_t_handle is record + field1 : cma_t_address; + field2 : Short_Integer; + field3 : Short_Integer; + end record; + for cma_t_handle'Size use 64; + + type pthread_attr_t is new cma_t_handle; + pragma Convention (C_Pass_By_Copy, pthread_attr_t); + + type pthread_condattr_t is new cma_t_handle; + pragma Convention (C_Pass_By_Copy, pthread_condattr_t); + + type pthread_mutexattr_t is new cma_t_handle; + pragma Convention (C_Pass_By_Copy, pthread_mutexattr_t); + + type pthread_t is new cma_t_handle; + pragma Convention (C_Pass_By_Copy, pthread_t); + + type pthread_mutex_t is new cma_t_handle; + pragma Convention (C_Pass_By_Copy, pthread_mutex_t); + + type pthread_cond_t is new cma_t_handle; + pragma Convention (C_Pass_By_Copy, pthread_cond_t); + + type pthread_key_t is new int; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-hpux.ads b/gcc/ada/s-osinte-hpux.ads new file mode 100644 index 000000000..ea31697a4 --- /dev/null +++ b/gcc/ada/s-osinte-hpux.ads @@ -0,0 +1,571 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a HPUX 11.0 (Native THREADS) version of this package + +-- This package encapsulates all direct interfaces to OS services that are +-- needed by the tasking run-time (libgnarl). + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Ada.Unchecked_Conversion; + +with Interfaces.C; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-lpthread"); + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIMEDOUT : constant := 238; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 44; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 16; -- user defined signal 1 + SIGUSR2 : constant := 17; -- user defined signal 2 + SIGCLD : constant := 18; -- alias for SIGCHLD + SIGCHLD : constant := 18; -- child status change + SIGPWR : constant := 19; -- power-fail restart + SIGVTALRM : constant := 20; -- virtual timer alarm + SIGPROF : constant := 21; -- profiling timer alarm + SIGIO : constant := 22; -- asynchronous I/O + SIGPOLL : constant := 22; -- pollable event occurred + SIGWINCH : constant := 23; -- window size change + SIGSTOP : constant := 24; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 25; -- user stop requested from tty + SIGCONT : constant := 26; -- stopped process has been continued + SIGTTIN : constant := 27; -- background tty read attempted + SIGTTOU : constant := 28; -- background tty write attempted + SIGURG : constant := 29; -- urgent condition on IO channel + SIGLOST : constant := 30; -- remote lock lost (NFS) + SIGDIL : constant := 32; -- DIL signal + SIGXCPU : constant := 33; -- CPU time limit exceeded (setrlimit) + SIGXFSZ : constant := 34; -- file size limit exceeded (setrlimit) + SIGCANCEL : constant := 35; -- used for pthread cancellation. + SIGGFAULT : constant := 36; -- Graphics framebuffer fault + + SIGADAABORT : constant := SIGABRT; + -- Note: on other targets, we usually use SIGABRT, but on HPUX, it + -- appears that SIGABRT can't be used in sigwait(), so we use SIGTERM. + -- Do we use SIGTERM or SIGABRT??? + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := + (SIGABRT, SIGPIPE, SIGBUS, SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF, + SIGALRM, SIGVTALRM, SIGIO, SIGCHLD); + + Reserved : constant Signal_Set := (SIGKILL, SIGSTOP); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SA_SIGINFO : constant := 16#10#; + SA_ONSTACK : constant := 16#01#; + + SIG_BLOCK : constant := 0; + SIG_UNBLOCK : constant := 1; + SIG_SETMASK : constant := 2; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + Time_Slice_Supported : constant Boolean := True; + -- Indicates whether time slicing is supported + + type timespec is private; + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + function clock_getres + (clock_id : clockid_t; + res : access timespec) return int; + pragma Import (C, clock_getres, "clock_getres"); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timezone is record + tz_minuteswest : int; + tz_dsttime : int; + end record; + pragma Convention (C, struct_timezone); + type struct_timezone_ptr is access all struct_timezone; + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 0; + SCHED_RR : constant := 1; + SCHED_OTHER : constant := 2; + + function To_Target_Priority + (Prio : System.Any_Priority) return Interfaces.C.int; + -- Maps System.Any_Priority to a POSIX priority + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------- + -- LWP -- + --------- + + function lwp_self return System.Address; + pragma Import (C, lwp_self, "_lwp_self"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + pragma Convention (C, Thread_Body); + + function Thread_Body_Access is new + Ada.Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 16#de#; + + PTHREAD_SCOPE_PROCESS : constant := 2; + PTHREAD_SCOPE_SYSTEM : constant := 1; + + ----------- + -- Stack -- + ----------- + + type stack_t is record + ss_sp : System.Address; + ss_flags : int; + ss_size : size_t; + end record; + pragma Convention (C, stack_t); + + function sigaltstack + (ss : not null access stack_t; + oss : access stack_t) return int; + pragma Import (C, sigaltstack, "sigaltstack"); + + Alternate_Stack : aliased System.Address; + pragma Import (C, Alternate_Stack, "__gnat_alternate_stack"); + -- The alternate signal stack for stack overflows + + Alternate_Stack_Size : constant := 16 * 1024; + -- This must be in keeping with init.c:__gnat_alternate_stack + + Stack_Base_Available : constant Boolean := False; + -- Indicates whether the stack base is available on this target + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- Returns the stack base of the specified thread. Only call this function + -- when Stack_Base_Available is True. + + function Get_Page_Size return size_t; + function Get_Page_Size return Address; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- Returns the size of a page + + PROT_NONE : constant := 0; + PROT_READ : constant := 1; + PROT_WRITE : constant := 2; + PROT_EXEC : constant := 4; + PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; + PROT_ON : constant := PROT_READ; + PROT_OFF : constant := PROT_ALL; + + function mprotect (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + procedure pthread_init; + pragma Inline (pthread_init); + -- This is a dummy procedure to share some GNULLI files + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Import (C, sigwait, "sigwait"); + + function pthread_kill + (thread : pthread_t; + sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + function pthread_sigmask + (how : int; + set : access sigset_t; + oset : access sigset_t) return int; + pragma Import (C, pthread_sigmask, "pthread_sigmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); + + Relative_Timed_Wait : constant Boolean := False; + -- pthread_cond_timedwait requires an absolute delay time + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + PTHREAD_PRIO_NONE : constant := 16#100#; + PTHREAD_PRIO_PROTECT : constant := 16#200#; + PTHREAD_PRIO_INHERIT : constant := 16#400#; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import (C, pthread_mutexattr_setprioceiling); + + type Array_7_Int is array (0 .. 6) of int; + type struct_sched_param is record + sched_priority : int; + sched_reserved : Array_7_Int; + end record; + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) + return int; + pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import (C, pthread_attr_setinheritsched); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy); + + function sched_yield return int; + pragma Import (C, sched_yield, "sched_yield"); + + -------------------------- + -- P1003.1c Section 16 -- + -------------------------- + + function pthread_attr_init + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "__pthread_attr_init_system"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import (C, pthread_attr_setdetachstate); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "__pthread_create_system"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Import (C, pthread_getspecific, "pthread_getspecific"); + + type destructor_pointer is access procedure (arg : System.Address); + pragma Convention (C, destructor_pointer); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + +private + + type unsigned_int_array_8 is array (0 .. 7) of unsigned; + type sigset_t is record + sigset : unsigned_int_array_8; + end record; + pragma Convention (C_Pass_By_Copy, sigset_t); + + type pid_t is new int; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 1; + + type pthread_attr_t is new int; + type pthread_condattr_t is new int; + type pthread_mutexattr_t is new int; + type pthread_t is new int; + + type short_array is array (Natural range <>) of short; + type int_array is array (Natural range <>) of int; + + type pthread_mutex_t is record + m_short : short_array (0 .. 1); + m_int : int; + m_int1 : int_array (0 .. 3); + m_pad : int; + + m_ptr : int; + -- actually m_ptr is a void*, and on 32 bit ABI, m_pad is added so that + -- this field takes 64 bits. On 64 bit ABI, m_pad is gone, and m_ptr is + -- a 64 bit void*. Assume int'Size = 32. + + m_int2 : int_array (0 .. 1); + m_int3 : int_array (0 .. 3); + m_short2 : short_array (0 .. 1); + m_int4 : int_array (0 .. 4); + m_int5 : int_array (0 .. 1); + end record; + for pthread_mutex_t'Alignment use System.Address'Alignment; + pragma Convention (C, pthread_mutex_t); + + type pthread_cond_t is record + c_short : short_array (0 .. 1); + c_int : int; + c_int1 : int_array (0 .. 3); + m_pad : int; + m_ptr : int; -- see comment in pthread_mutex_t + c_int2 : int_array (0 .. 1); + c_int3 : int_array (0 .. 1); + c_int4 : int_array (0 .. 1); + end record; + for pthread_cond_t'Alignment use System.Address'Alignment; + pragma Convention (C, pthread_cond_t); + + type pthread_key_t is new int; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-irix.adb b/gcc/ada/s-osinte-irix.adb new file mode 100644 index 000000000..cc3e015f7 --- /dev/null +++ b/gcc/ada/s-osinte-irix.adb @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the IRIX version of this package + +-- This package encapsulates all direct interfaces to OS services that are +-- needed by children of System. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +with Interfaces.C; use Interfaces.C; + +package body System.OS_Interface is + + ------------------ + -- pthread_init -- + ------------------ + + procedure pthread_init is + begin + null; + end pthread_init; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; + end To_Duration; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return timespec'(tv_sec => S, + tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-irix.ads b/gcc/ada/s-osinte-irix.ads new file mode 100644 index 000000000..7231c39e9 --- /dev/null +++ b/gcc/ada/s-osinte-irix.ads @@ -0,0 +1,522 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the SGI Pthreads version of this package + +-- This package encapsulates all direct interfaces to OS services that are +-- needed by the tasking run-time (libgnarl). + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Ada.Unchecked_Conversion; + +with Interfaces.C; + +package System.OS_Interface is + + pragma Preelaborate; + + pragma Linker_Options ("-lpthread"); + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EINTR : constant := 4; -- interrupted system call + EAGAIN : constant := 11; -- No more processes + ENOMEM : constant := 12; -- Not enough core + EINVAL : constant := 22; -- Invalid argument + ETIMEDOUT : constant := 145; -- Connection timed out + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 64; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 16; -- user defined signal 1 + SIGUSR2 : constant := 17; -- user defined signal 2 + SIGCLD : constant := 18; -- alias for SIGCHLD + SIGCHLD : constant := 18; -- child status change + SIGPWR : constant := 19; -- power-fail restart + SIGWINCH : constant := 20; -- window size change + SIGURG : constant := 21; -- urgent condition on IO channel + SIGPOLL : constant := 22; -- pollable event occurred + SIGIO : constant := 22; -- I/O possible (Solaris SIGPOLL alias) + SIGSTOP : constant := 23; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 24; -- user stop requested from tty + SIGCONT : constant := 25; -- stopped process has been continued + SIGTTIN : constant := 26; -- background tty read attempted + SIGTTOU : constant := 27; -- background tty write attempted + SIGVTALRM : constant := 28; -- virtual timer expired + SIGPROF : constant := 29; -- profiling timer expired + SIGXCPU : constant := 30; -- CPU time limit exceeded + SIGXFSZ : constant := 31; -- filesize limit exceeded + SIGK32 : constant := 32; -- reserved for kernel (IRIX) + SIGCKPT : constant := 33; -- Checkpoint warning + SIGRESTART : constant := 34; -- Restart warning + SIGUME : constant := 35; -- Uncorrectable memory error + -- Signals defined for Posix 1003.1c + SIGPTINTR : constant := 47; + SIGPTRESCHED : constant := 48; + -- Posix 1003.1b signals + SIGRTMIN : constant := 49; -- Posix 1003.1b signals + SIGRTMAX : constant := 64; -- Posix 1003.1b signals + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type array_type_2 is array (Integer range 0 .. 1) of int; + type struct_sigaction is record + sa_flags : int; + sa_handler : System.Address; + sa_mask : sigset_t; + sa_resv : array_type_2; + end record; + pragma Convention (C, struct_sigaction); + + type struct_sigaction_ptr is access all struct_sigaction; + + SIG_BLOCK : constant := 1; + SIG_UNBLOCK : constant := 2; + SIG_SETMASK : constant := 3; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr := null) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + type timespec is private; + type timespec_ptr is access all timespec; + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + CLOCK_SGI_FAST : constant clockid_t; + CLOCK_SGI_CYCLE : constant clockid_t; + + SGI_CYCLECNTR_SIZE : constant := 165; + + function syssgi (request : Interfaces.C.int) return Interfaces.C.ptrdiff_t; + pragma Import (C, syssgi, "syssgi"); + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + function clock_getres + (clock_id : clockid_t; + tp : access timespec) return int; + pragma Import (C, clock_getres, "clock_getres"); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 1; + SCHED_RR : constant := 2; + SCHED_TS : constant := 3; + SCHED_OTHER : constant := 3; + SCHED_NP : constant := 4; + + function sched_get_priority_min (Policy : int) return int; + pragma Import (C, sched_get_priority_min, "sched_get_priority_min"); + + function sched_get_priority_max (Policy : int) return int; + pragma Import (C, sched_get_priority_max, "sched_get_priority_max"); + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + pragma Convention (C, Thread_Body); + + function Thread_Body_Access is new + Ada.Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 1; + + ----------- + -- Stack -- + ----------- + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + procedure pthread_init; + pragma Inline (pthread_init); + -- This is a dummy procedure to share some GNULLI files + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Import (C, sigwait, "sigwait"); + + function pthread_kill + (thread : pthread_t; + sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + function pthread_sigmask + (how : int; + set : access sigset_t; + oset : access sigset_t) return int; + pragma Import (C, pthread_sigmask, "pthread_sigmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + PTHREAD_PRIO_NONE : constant := 0; + PTHREAD_PRIO_PROTECT : constant := 2; + PTHREAD_PRIO_INHERIT : constant := 1; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import (C, pthread_mutexattr_setprioceiling); + + type struct_sched_param is record + sched_priority : int; + end record; + pragma Convention (C, struct_sched_param); + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) + return int; + pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import + (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched"); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy); + + function pthread_attr_setschedparam + (attr : access pthread_attr_t; + sched_param : access struct_sched_param) + return int; + pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam"); + + function sched_yield return int; + pragma Import (C, sched_yield, "sched_yield"); + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import (C, pthread_attr_setdetachstate); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "pthread_create"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Import (C, pthread_getspecific, "pthread_getspecific"); + + type destructor_pointer is access procedure (arg : System.Address); + pragma Convention (C, destructor_pointer); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + + ------------------- + -- SGI Additions -- + ------------------- + + -- Non portable SGI 6.5 additions to the pthread interface must be + -- executed from within the context of a system scope task. + + function pthread_setrunon_np (cpu : int) return int; + pragma Import (C, pthread_setrunon_np, "pthread_setrunon_np"); + +private + + type array_type_1 is array (Integer range 0 .. 3) of unsigned; + type sigset_t is record + X_X_sigbits : array_type_1; + end record; + pragma Convention (C, sigset_t); + + type pid_t is new long; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 1; + CLOCK_SGI_CYCLE : constant clockid_t := 2; + CLOCK_SGI_FAST : constant clockid_t := 3; + + type array_type_9 is array (Integer range 0 .. 4) of long; + type pthread_attr_t is record + X_X_D : array_type_9; + end record; + pragma Convention (C, pthread_attr_t); + + type array_type_8 is array (Integer range 0 .. 1) of long; + type pthread_condattr_t is record + X_X_D : array_type_8; + end record; + pragma Convention (C, pthread_condattr_t); + + type array_type_7 is array (Integer range 0 .. 1) of long; + type pthread_mutexattr_t is record + X_X_D : array_type_7; + end record; + pragma Convention (C, pthread_mutexattr_t); + + type pthread_t is new unsigned; + + type array_type_10 is array (Integer range 0 .. 7) of long; + type pthread_mutex_t is record + X_X_D : array_type_10; + end record; + pragma Convention (C, pthread_mutex_t); + + type array_type_11 is array (Integer range 0 .. 7) of long; + type pthread_cond_t is record + X_X_D : array_type_11; + end record; + pragma Convention (C, pthread_cond_t); + + type pthread_key_t is new int; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-kfreebsd-gnu.ads b/gcc/ada/s-osinte-kfreebsd-gnu.ads new file mode 100644 index 000000000..958d4217d --- /dev/null +++ b/gcc/ada/s-osinte-kfreebsd-gnu.ads @@ -0,0 +1,544 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2005,2008 Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the GNU/kFreeBSD (GNU/LinuxThreads) version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package + +with Interfaces.C; +with Unchecked_Conversion; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-lpthread"); + + subtype int is Interfaces.C.int; + subtype char is Interfaces.C.char; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 35; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + EPERM : constant := 1; + ETIMEDOUT : constant := 60; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 128; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGURG : constant := 16; -- urgent condition on IO channel + SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 18; -- user stop requested from tty + SIGCONT : constant := 19; -- stopped process has been continued + SIGCLD : constant := 20; -- alias for SIGCHLD + SIGCHLD : constant := 20; -- child status change + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias) + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 27; -- profiling timer expired + SIGWINCH : constant := 28; -- window size change + SIGINFO : constant := 29; -- information request (NetBSD/FreeBSD) + SIGUSR1 : constant := 30; -- user defined signal 1 + SIGUSR2 : constant := 31; -- user defined signal 2 + SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal + SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal + SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal + + SIGADAABORT : constant := SIGABRT; + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := ( + SIGTRAP, + -- To enable debugging on multithreaded applications, mark SIGTRAP to + -- be kept unmasked. + + SIGBUS, + + SIGTTIN, SIGTTOU, SIGTSTP, + -- Keep these three signals unmasked so that background processes + -- and IO behaves as normal "C" applications + + SIGPROF, + -- To avoid confusing the profiler + + SIGKILL, SIGSTOP, + -- These two signals actually cannot be masked; + -- POSIX simply won't allow it. + + SIGLTHRRES, SIGLTHRCAN, SIGLTHRDBG); + -- These three signals are used by GNU/LinuxThreads starting from + -- glibc 2.1 (future 2.2). + + Reserved : constant Signal_Set := + -- I am not sure why the following signal is reserved. + -- I guess they are not supported by this version of GNU/kFreeBSD. + (0 .. 0 => SIGVTALRM); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + -- sigcontext is architecture dependent, so define it private + type struct_sigcontext is private; + + type struct_sigaction is record + sa_handler : System.Address; + sa_flags : int; + sa_mask : sigset_t; + end record; + pragma Convention (C, struct_sigaction); + + type struct_sigaction_ptr is access all struct_sigaction; + + SIG_BLOCK : constant := 1; + SIG_UNBLOCK : constant := 2; + SIG_SETMASK : constant := 3; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + SA_SIGINFO : constant := 16#0040#; + SA_ONSTACK : constant := 16#0001#; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + type timespec is private; + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + function sysconf (name : int) return long; + pragma Import (C, sysconf); + + SC_CLK_TCK : constant := 2; + SC_NPROCESSORS_ONLN : constant := 84; + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 1; + SCHED_OTHER : constant := 2; + SCHED_RR : constant := 3; + + function To_Target_Priority + (Prio : System.Any_Priority) return Interfaces.C.int; + -- Maps System.Any_Priority to a POSIX priority. + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + pragma Convention (C, Thread_Body); + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is new unsigned_long; + subtype Thread_Id is pthread_t; + + function To_pthread_t is new Unchecked_Conversion + (unsigned_long, pthread_t); + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 1; + + ----------- + -- Stack -- + ----------- + + type stack_t is record + ss_sp : System.Address; + ss_size : size_t; + ss_flags : int; + end record; + pragma Convention (C, stack_t); + + function sigaltstack + (ss : not null access stack_t; + oss : access stack_t) return int; + pragma Import (C, sigaltstack, "sigaltstack"); + + Alternate_Stack : aliased System.Address; + -- This is a dummy definition, never used (Alternate_Stack_Size is null) + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- This is a dummy procedure to share some GNULLI files + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + procedure pthread_init; + pragma Inline (pthread_init); + -- This is a dummy procedure to share some GNULLI files + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait (set : access sigset_t; sig : access Signal) return int; + pragma Import (C, sigwait, "sigwait"); + + function pthread_kill (thread : pthread_t; sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + function pthread_sigmask + (how : int; + set : access sigset_t; + oset : access sigset_t) return int; + pragma Import (C, pthread_sigmask, "pthread_sigmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); + + Relative_Timed_Wait : constant Boolean := False; + -- pthread_cond_timedwait requires an absolute delay time + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + type struct_sched_param is record + sched_priority : int; -- scheduling priority + end record; + pragma Convention (C, struct_sched_param); + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import + (C, pthread_attr_setschedpolicy, "pthread_attr_setschedpolicy"); + + function sched_yield return int; + pragma Import (C, sched_yield, "sched_yield"); + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import + (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate"); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "pthread_create"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Import (C, pthread_getspecific, "pthread_getspecific"); + + type destructor_pointer is access procedure (arg : System.Address); + pragma Convention (C, destructor_pointer); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + + CPU_SETSIZE : constant := 1_024; + + type bit_field is array (1 .. CPU_SETSIZE) of Boolean; + for bit_field'Size use CPU_SETSIZE; + pragma Pack (bit_field); + pragma Convention (C, bit_field); + + type cpu_set_t is record + bits : bit_field; + end record; + pragma Convention (C, cpu_set_t); + + function pthread_setaffinity_np + (thread : pthread_t; + cpusetsize : size_t; + cpuset : access cpu_set_t) return int; + pragma Import (C, pthread_setaffinity_np, "__gnat_pthread_setaffinity_np"); + +private + + type sigset_t is array (1 .. 4) of unsigned; + + -- In FreeBSD the component sa_handler turns out to + -- be one a union type, and the selector is a macro: + -- #define sa_handler __sigaction_u._handler + -- #define sa_sigaction __sigaction_u._sigaction + + -- Should we add a signal_context type here ? + -- How could it be done independent of the CPU architecture ? + -- sigcontext type is opaque, so it is architecturally neutral. + -- It is always passed as an access type, so define it as an empty record + -- since the contents are not used anywhere. + type struct_sigcontext is null record; + pragma Convention (C, struct_sigcontext); + + type pid_t is new int; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type pthread_attr_t is record + detachstate : int; + schedpolicy : int; + schedparam : struct_sched_param; + inheritsched : int; + scope : int; + guardsize : size_t; + stackaddr_set : int; + stackaddr : System.Address; + stacksize : size_t; + end record; + pragma Convention (C, pthread_attr_t); + + type pthread_condattr_t is record + dummy : int; + end record; + pragma Convention (C, pthread_condattr_t); + + type pthread_mutexattr_t is record + mutexkind : int; + end record; + pragma Convention (C, pthread_mutexattr_t); + + type struct_pthread_fast_lock is record + status : long; + spinlock : int; + end record; + pragma Convention (C, struct_pthread_fast_lock); + + type pthread_mutex_t is record + m_reserved : int; + m_count : int; + m_owner : System.Address; + m_kind : int; + m_lock : struct_pthread_fast_lock; + end record; + pragma Convention (C, pthread_mutex_t); + + type pthread_cond_t is array (0 .. 47) of unsigned_char; + pragma Convention (C, pthread_cond_t); + + type pthread_key_t is new unsigned; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-linux.ads b/gcc/ada/s-osinte-linux.ads new file mode 100644 index 000000000..6de1fbd23 --- /dev/null +++ b/gcc/ada/s-osinte-linux.ads @@ -0,0 +1,568 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a GNU/Linux (GNU/LinuxThreads) version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by the tasking run-time (libgnarl). + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Ada.Unchecked_Conversion; +with Interfaces.C; +with System.Linux; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-lpthread"); + + subtype int is Interfaces.C.int; + subtype char is Interfaces.C.char; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := System.Linux.EAGAIN; + EINTR : constant := System.Linux.EINTR; + EINVAL : constant := System.Linux.EINVAL; + ENOMEM : constant := System.Linux.ENOMEM; + EPERM : constant := System.Linux.EPERM; + ETIMEDOUT : constant := System.Linux.ETIMEDOUT; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 63; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := System.Linux.SIGHUP; + SIGINT : constant := System.Linux.SIGINT; + SIGQUIT : constant := System.Linux.SIGQUIT; + SIGILL : constant := System.Linux.SIGILL; + SIGTRAP : constant := System.Linux.SIGTRAP; + SIGIOT : constant := System.Linux.SIGIOT; + SIGABRT : constant := System.Linux.SIGABRT; + SIGFPE : constant := System.Linux.SIGFPE; + SIGKILL : constant := System.Linux.SIGKILL; + SIGBUS : constant := System.Linux.SIGBUS; + SIGSEGV : constant := System.Linux.SIGSEGV; + SIGPIPE : constant := System.Linux.SIGPIPE; + SIGALRM : constant := System.Linux.SIGALRM; + SIGTERM : constant := System.Linux.SIGTERM; + SIGUSR1 : constant := System.Linux.SIGUSR1; + SIGUSR2 : constant := System.Linux.SIGUSR2; + SIGCLD : constant := System.Linux.SIGCLD; + SIGCHLD : constant := System.Linux.SIGCHLD; + SIGPWR : constant := System.Linux.SIGPWR; + SIGWINCH : constant := System.Linux.SIGWINCH; + SIGURG : constant := System.Linux.SIGURG; + SIGPOLL : constant := System.Linux.SIGPOLL; + SIGIO : constant := System.Linux.SIGIO; + SIGLOST : constant := System.Linux.SIGLOST; + SIGSTOP : constant := System.Linux.SIGSTOP; + SIGTSTP : constant := System.Linux.SIGTSTP; + SIGCONT : constant := System.Linux.SIGCONT; + SIGTTIN : constant := System.Linux.SIGTTIN; + SIGTTOU : constant := System.Linux.SIGTTOU; + SIGVTALRM : constant := System.Linux.SIGVTALRM; + SIGPROF : constant := System.Linux.SIGPROF; + SIGXCPU : constant := System.Linux.SIGXCPU; + SIGXFSZ : constant := System.Linux.SIGXFSZ; + SIGUNUSED : constant := System.Linux.SIGUNUSED; + SIGSTKFLT : constant := System.Linux.SIGSTKFLT; + SIGLTHRRES : constant := System.Linux.SIGLTHRRES; + SIGLTHRCAN : constant := System.Linux.SIGLTHRCAN; + SIGLTHRDBG : constant := System.Linux.SIGLTHRDBG; + + SIGADAABORT : constant := SIGABRT; + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := ( + SIGTRAP, + -- To enable debugging on multithreaded applications, mark SIGTRAP to + -- be kept unmasked. + + SIGBUS, + + SIGTTIN, SIGTTOU, SIGTSTP, + -- Keep these three signals unmasked so that background processes + -- and IO behaves as normal "C" applications + + SIGPROF, + -- To avoid confusing the profiler + + SIGKILL, SIGSTOP, + -- These two signals actually cannot be masked; + -- POSIX simply won't allow it. + + SIGLTHRRES, SIGLTHRCAN, SIGLTHRDBG); + -- These three signals are used by GNU/LinuxThreads starting from + -- glibc 2.1 (future 2.2). + + Reserved : constant Signal_Set := + -- I am not sure why the following two signals are reserved. + -- I guess they are not supported by this version of GNU/Linux. + (SIGVTALRM, SIGUNUSED); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type union_type_3 is new String (1 .. 116); + type siginfo_t is record + si_signo : int; + si_code : int; + si_errno : int; + X_data : union_type_3; + end record; + pragma Convention (C, siginfo_t); + + type struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : Interfaces.C.unsigned_long; + sa_restorer : System.Address; + end record; + pragma Convention (C, struct_sigaction); + + type struct_sigaction_ptr is access all struct_sigaction; + + type Machine_State is record + eip : unsigned_long; + ebx : unsigned_long; + esp : unsigned_long; + ebp : unsigned_long; + esi : unsigned_long; + edi : unsigned_long; + end record; + type Machine_State_Ptr is access all Machine_State; + + SA_SIGINFO : constant := System.Linux.SA_SIGINFO; + SA_ONSTACK : constant := System.Linux.SA_ONSTACK; + + SIG_BLOCK : constant := 0; + SIG_UNBLOCK : constant := 1; + SIG_SETMASK : constant := 2; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + type timespec is private; + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + function sysconf (name : int) return long; + pragma Import (C, sysconf); + + SC_CLK_TCK : constant := 2; + SC_NPROCESSORS_ONLN : constant := 84; + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_OTHER : constant := 0; + SCHED_FIFO : constant := 1; + SCHED_RR : constant := 2; + + function To_Target_Priority + (Prio : System.Any_Priority) return Interfaces.C.int; + -- Maps System.Any_Priority to a POSIX priority + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + pragma Convention (C, Thread_Body); + + function Thread_Body_Access is new + Ada.Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is new unsigned_long; + subtype Thread_Id is pthread_t; + + function To_pthread_t is new Ada.Unchecked_Conversion + (unsigned_long, pthread_t); + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 1; + + ----------- + -- Stack -- + ----------- + + type stack_t is record + ss_sp : System.Address; + ss_flags : int; + ss_size : size_t; + end record; + pragma Convention (C, stack_t); + + function sigaltstack + (ss : not null access stack_t; + oss : access stack_t) return int; + pragma Import (C, sigaltstack, "sigaltstack"); + + Alternate_Stack : aliased System.Address; + pragma Import (C, Alternate_Stack, "__gnat_alternate_stack"); + -- The alternate signal stack for stack overflows + + Alternate_Stack_Size : constant := 16 * 1024; + -- This must be in keeping with init.c:__gnat_alternate_stack + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- This is a dummy procedure to share some GNULLI files + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + procedure pthread_init; + pragma Inline (pthread_init); + -- This is a dummy procedure to share some GNULLI files + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait (set : access sigset_t; sig : access Signal) return int; + pragma Import (C, sigwait, "sigwait"); + + function pthread_kill (thread : pthread_t; sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + function pthread_sigmask + (how : int; + set : access sigset_t; + oset : access sigset_t) return int; + pragma Import (C, pthread_sigmask, "pthread_sigmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + type struct_sched_param is record + sched_priority : int; -- scheduling priority + end record; + pragma Convention (C, struct_sched_param); + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import + (C, pthread_attr_setschedpolicy, "pthread_attr_setschedpolicy"); + + function sched_yield return int; + pragma Import (C, sched_yield, "sched_yield"); + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import + (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate"); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "pthread_create"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + function lwp_self return System.Address; + pragma Import (C, lwp_self, "__gnat_lwp_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Import (C, pthread_getspecific, "pthread_getspecific"); + + type destructor_pointer is access procedure (arg : System.Address); + pragma Convention (C, destructor_pointer); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + + CPU_SETSIZE : constant := 1_024; + + type bit_field is array (1 .. CPU_SETSIZE) of Boolean; + for bit_field'Size use CPU_SETSIZE; + pragma Pack (bit_field); + pragma Convention (C, bit_field); + + type cpu_set_t is record + bits : bit_field; + end record; + pragma Convention (C, cpu_set_t); + + function pthread_setaffinity_np + (thread : pthread_t; + cpusetsize : size_t; + cpuset : access cpu_set_t) return int; + pragma Import (C, pthread_setaffinity_np, "pthread_setaffinity_np"); + pragma Weak_External (pthread_setaffinity_np); + -- Use a weak symbol because this function may be available or not, + -- depending on the version of the system. + + function pthread_attr_setaffinity_np + (attr : access pthread_attr_t; + cpusetsize : size_t; + cpuset : access cpu_set_t) return int; + pragma Import (C, pthread_attr_setaffinity_np, + "pthread_attr_setaffinity_np"); + pragma Weak_External (pthread_attr_setaffinity_np); + -- Use a weak symbol because this function may be available or not, + -- depending on the version of the system. + +private + + type sigset_t is array (0 .. 127) of unsigned_char; + pragma Convention (C, sigset_t); + for sigset_t'Alignment use Interfaces.C.unsigned_long'Alignment; + + pragma Warnings (Off); + for struct_sigaction use record + sa_handler at Linux.sa_handler_pos range 0 .. Standard'Address_Size - 1; + sa_mask at Linux.sa_mask_pos range 0 .. 1023; + sa_flags at Linux.sa_flags_pos range 0 .. Standard'Address_Size - 1; + end record; + -- We intentionally leave sa_restorer unspecified and let the compiler + -- append it after the last field, so disable corresponding warning. + pragma Warnings (On); + + type pid_t is new int; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type pthread_attr_t is record + detachstate : int; + schedpolicy : int; + schedparam : struct_sched_param; + inheritsched : int; + scope : int; + guardsize : size_t; + stackaddr_set : int; + stackaddr : System.Address; + stacksize : size_t; + end record; + pragma Convention (C, pthread_attr_t); + + type pthread_condattr_t is record + dummy : int; + end record; + pragma Convention (C, pthread_condattr_t); + + type pthread_mutexattr_t is record + mutexkind : int; + end record; + pragma Convention (C, pthread_mutexattr_t); + + type pthread_mutex_t is new System.Linux.pthread_mutex_t; + + type unsigned_long_long_t is mod 2 ** 64; + -- Interfaces.C.Extensions isn't preelaborated so cannot be with-ed + + type pthread_cond_t is array (0 .. 47) of unsigned_char; + pragma Convention (C, pthread_cond_t); + for pthread_cond_t'Alignment use unsigned_long_long_t'Alignment; + + type pthread_key_t is new unsigned; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-lynxos-3.adb b/gcc/ada/s-osinte-lynxos-3.adb new file mode 100644 index 000000000..0a4a3deb4 --- /dev/null +++ b/gcc/ada/s-osinte-lynxos-3.adb @@ -0,0 +1,575 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a LynxOS (Native) version of this package + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +package body System.OS_Interface is + + use Interfaces.C; + + ------------------- + -- clock_gettime -- + ------------------- + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) + return int + is + function clock_gettime_base + (clock_id : clockid_t; + tp : access timespec) + return int; + pragma Import (C, clock_gettime_base, "clock_gettime"); + + begin + if clock_gettime_base (clock_id, tp) /= 0 then + return errno; + end if; + + return 0; + end clock_gettime; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; + end To_Duration; + + ------------------------ + -- To_Target_Priority -- + ------------------------ + + function To_Target_Priority + (Prio : System.Any_Priority) return Interfaces.C.int + is + begin + return Interfaces.C.int (Prio); + end To_Target_Priority; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return timespec'(tv_sec => S, + tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) + return int + is + function sigwait_base + (set : access sigset_t; + value : System.Address) + return Signal; + pragma Import (C, sigwait_base, "sigwait"); + + begin + sig.all := sigwait_base (set, Null_Address); + + if sig.all = -1 then + return errno; + end if; + + return 0; + end sigwait; + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + -- For all the following functions, LynxOS threads has the POSIX Draft 4 + -- behavior; it sets errno but the standard Posix requires it to be + -- returned. + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) + return int + is + function pthread_mutexattr_create + (attr : access pthread_mutexattr_t) + return int; + pragma Import (C, pthread_mutexattr_create, "pthread_mutexattr_create"); + + begin + if pthread_mutexattr_create (attr) /= 0 then + return errno; + end if; + + return 0; + end pthread_mutexattr_init; + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) + return int + is + function pthread_mutexattr_delete + (attr : access pthread_mutexattr_t) + return int; + pragma Import (C, pthread_mutexattr_delete, "pthread_mutexattr_delete"); + + begin + if pthread_mutexattr_delete (attr) /= 0 then + return errno; + end if; + + return 0; + end pthread_mutexattr_destroy; + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) + return int + is + function pthread_mutex_init_base + (mutex : access pthread_mutex_t; + attr : pthread_mutexattr_t) + return int; + pragma Import (C, pthread_mutex_init_base, "pthread_mutex_init"); + + begin + if pthread_mutex_init_base (mutex, attr.all) /= 0 then + return errno; + end if; + + return 0; + end pthread_mutex_init; + + function pthread_mutex_destroy + (mutex : access pthread_mutex_t) + return int + is + function pthread_mutex_destroy_base + (mutex : access pthread_mutex_t) + return int; + pragma Import (C, pthread_mutex_destroy_base, "pthread_mutex_destroy"); + + begin + if pthread_mutex_destroy_base (mutex) /= 0 then + return errno; + end if; + + return 0; + end pthread_mutex_destroy; + + function pthread_mutex_lock + (mutex : access pthread_mutex_t) + return int + is + function pthread_mutex_lock_base + (mutex : access pthread_mutex_t) + return int; + pragma Import (C, pthread_mutex_lock_base, "pthread_mutex_lock"); + + begin + if pthread_mutex_lock_base (mutex) /= 0 then + return errno; + end if; + + return 0; + end pthread_mutex_lock; + + function pthread_mutex_unlock + (mutex : access pthread_mutex_t) + return int + is + function pthread_mutex_unlock_base + (mutex : access pthread_mutex_t) + return int; + pragma Import (C, pthread_mutex_unlock_base, "pthread_mutex_unlock"); + + begin + if pthread_mutex_unlock_base (mutex) /= 0 then + return errno; + end if; + + return 0; + end pthread_mutex_unlock; + + function pthread_condattr_init + (attr : access pthread_condattr_t) + return int + is + function pthread_condattr_create + (attr : access pthread_condattr_t) + return int; + pragma Import (C, pthread_condattr_create, "pthread_condattr_create"); + + begin + if pthread_condattr_create (attr) /= 0 then + return errno; + end if; + + return 0; + end pthread_condattr_init; + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) + return int + is + function pthread_condattr_delete + (attr : access pthread_condattr_t) + return int; + pragma Import (C, pthread_condattr_delete, "pthread_condattr_delete"); + + begin + if pthread_condattr_delete (attr) /= 0 then + return errno; + end if; + + return 0; + end pthread_condattr_destroy; + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) + return int + is + function pthread_cond_init_base + (cond : access pthread_cond_t; + attr : pthread_condattr_t) + return int; + pragma Import (C, pthread_cond_init_base, "pthread_cond_init"); + + begin + if pthread_cond_init_base (cond, attr.all) /= 0 then + return errno; + end if; + + return 0; + end pthread_cond_init; + + function pthread_cond_destroy + (cond : access pthread_cond_t) + return int + is + function pthread_cond_destroy_base + (cond : access pthread_cond_t) + return int; + pragma Import (C, pthread_cond_destroy_base, "pthread_cond_destroy"); + + begin + if pthread_cond_destroy_base (cond) /= 0 then + return errno; + end if; + + return 0; + end pthread_cond_destroy; + + function pthread_cond_signal + (cond : access pthread_cond_t) + return int + is + function pthread_cond_signal_base + (cond : access pthread_cond_t) + return int; + pragma Import (C, pthread_cond_signal_base, "pthread_cond_signal"); + + begin + if pthread_cond_signal_base (cond) /= 0 then + return errno; + end if; + + return 0; + end pthread_cond_signal; + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) + return int + is + function pthread_cond_wait_base + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) + return int; + pragma Import (C, pthread_cond_wait_base, "pthread_cond_wait"); + + begin + if pthread_cond_wait_base (cond, mutex) /= 0 then + return errno; + end if; + + return 0; + end pthread_cond_wait; + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + reltime : access timespec) return int + is + function pthread_cond_timedwait_base + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + reltime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait_base, "pthread_cond_timedwait"); + + begin + if pthread_cond_timedwait_base (cond, mutex, reltime) /= 0 then + if errno = EAGAIN then + return ETIMEDOUT; + end if; + + return errno; + end if; + + return 0; + end pthread_cond_timedwait; + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) + return int + is + function pthread_setscheduler + (thread : pthread_t; + policy : int; + prio : int) + return int; + pragma Import (C, pthread_setscheduler, "pthread_setscheduler"); + + begin + if pthread_setscheduler (thread, policy, param.sched_priority) = -1 then + return errno; + end if; + + return 0; + end pthread_setschedparam; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) + return int + is + pragma Unreferenced (attr, protocol); + begin + return 0; + end pthread_mutexattr_setprotocol; + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) + return int + is + pragma Unreferenced (attr, prioceiling); + begin + return 0; + end pthread_mutexattr_setprioceiling; + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) + return int + is + pragma Unreferenced (attr, contentionscope); + begin + return 0; + end pthread_attr_setscope; + + function sched_yield return int is + procedure pthread_yield; + pragma Import (C, pthread_yield, "pthread_yield"); + + begin + pthread_yield; + return 0; + end sched_yield; + + ----------------------------- + -- P1003.1c - Section 16 -- + ----------------------------- + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) + return int + is + pragma Unreferenced (attr, detachstate); + begin + return 0; + end pthread_attr_setdetachstate; + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) + return int + is + -- The LynxOS pthread_create doesn't seems to work. + -- Workaround : We're using st_new instead. + -- + -- function pthread_create_base + -- (thread : access pthread_t; + -- attributes : pthread_attr_t; + -- start_routine : Thread_Body; + -- arg : System.Address) + -- return int; + -- pragma Import (C, pthread_create_base, "pthread_create"); + + St : aliased st_t := attributes.st; + + function st_new + (start_routine : Thread_Body; + arg : System.Address; + attributes : access st_t; + thread : access pthread_t) + return int; + pragma Import (C, st_new, "st_new"); + + begin + -- Following code would be used if above commented function worked + + -- if pthread_create_base + -- (thread, attributes.all, start_routine, arg) /= 0 then + + if st_new (start_routine, arg, St'Access, thread) /= 0 then + return errno; + end if; + + return 0; + end pthread_create; + + function pthread_detach (thread : pthread_t) return int is + aliased_thread : aliased pthread_t := thread; + + function pthread_detach_base (thread : access pthread_t) return int; + pragma Import (C, pthread_detach_base, "pthread_detach"); + + begin + if pthread_detach_base (aliased_thread'Access) /= 0 then + return errno; + end if; + + return 0; + end pthread_detach; + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) + return int + is + function pthread_setspecific_base + (key : pthread_key_t; + value : System.Address) + return int; + pragma Import (C, pthread_setspecific_base, "pthread_setspecific"); + + begin + if pthread_setspecific_base (key, value) /= 0 then + return errno; + end if; + + return 0; + end pthread_setspecific; + + function pthread_getspecific (key : pthread_key_t) return System.Address is + procedure pthread_getspecific_base + (key : pthread_key_t; + value : access System.Address); + pragma Import (C, pthread_getspecific_base, "pthread_getspecific"); + + value : aliased System.Address := System.Null_Address; + + begin + pthread_getspecific_base (key, value'Unchecked_Access); + return value; + end pthread_getspecific; + + function Get_Stack_Base (thread : pthread_t) return Address is + pragma Warnings (Off, thread); + + begin + return Null_Address; + end Get_Stack_Base; + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) + return int + is + function pthread_keycreate + (key : access pthread_key_t; + destructor : destructor_pointer) + return int; + pragma Import (C, pthread_keycreate, "pthread_keycreate"); + + begin + if pthread_keycreate (key, destructor) /= 0 then + return errno; + end if; + + return 0; + end pthread_key_create; + + procedure pthread_init is + begin + null; + end pthread_init; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-lynxos-3.ads b/gcc/ada/s-osinte-lynxos-3.ads new file mode 100644 index 000000000..8098a8fbe --- /dev/null +++ b/gcc/ada/s-osinte-lynxos-3.ads @@ -0,0 +1,559 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a LynxOS (Native) version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by the tasking run-time (libgnarl). + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Ada.Unchecked_Conversion; + +with Interfaces.C; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-mthreads"); + + subtype int is Interfaces.C.int; + subtype char is Interfaces.C.char; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIMEDOUT : constant := 60; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 63; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGBRK : constant := 6; -- break + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGCORE : constant := 7; -- kill with core dump + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGURG : constant := 16; -- urgent condition on IO channel + SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 18; -- user stop requested from tty + SIGCONT : constant := 19; -- stopped process has been continued + SIGCLD : constant := 20; -- alias for SIGCHLD + SIGCHLD : constant := 20; -- child status change + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias) + SIGPOLL : constant := 23; -- pollable event occurred + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 27; -- profiling timer expired + SIGWINCH : constant := 28; -- window size change + SIGLOST : constant := 29; -- SUN 4.1 compatibility + SIGUSR1 : constant := 30; -- user defined signal 1 + SIGUSR2 : constant := 31; -- user defined signal 2 + SIGPRIO : constant := 32; -- sent to a process with its priority or + -- group is changed + + SIGADAABORT : constant := SIGABRT; + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := + (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF); + Reserved : constant Signal_Set := (SIGABRT, SIGKILL, SIGSTOP, SIGPRIO); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SA_SIGINFO : constant := 16#80#; + + SIG_BLOCK : constant := 0; + SIG_UNBLOCK : constant := 1; + SIG_SETMASK : constant := 2; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + Time_Slice_Supported : constant Boolean := True; + -- Indicates whether time slicing is supported + + type timespec is private; + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int; + pragma Inline (clock_gettime); + -- LynxOS has non standard clock_gettime + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timezone is record + tz_minuteswest : int; + tz_dsttime : int; + end record; + pragma Convention (C, struct_timezone); + type struct_timezone_ptr is access all struct_timezone; + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 16#00200000#; + SCHED_RR : constant := 16#00100000#; + SCHED_OTHER : constant := 16#00400000#; + + function To_Target_Priority + (Prio : System.Any_Priority) return Interfaces.C.int; + -- Maps System.Any_Priority to a POSIX priority + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------- + -- LWP -- + --------- + + function lwp_self return System.Address; + -- lwp_self does not exist on this thread library, revert to pthread_self + -- which is the closest approximation (with getpid). This function is + -- needed to share 7staprop.adb across POSIX-like targets. + pragma Import (C, lwp_self, "pthread_self"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + pragma Convention (C, Thread_Body); + + function Thread_Body_Access is new + Ada.Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type st_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 0; + + PTHREAD_SCOPE_PROCESS : constant := 0; + PTHREAD_SCOPE_SYSTEM : constant := 1; + + ----------- + -- Stack -- + ----------- + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + + Stack_Base_Available : constant Boolean := False; + -- Indicates whether the stack base is available on this target + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- returns the stack base of the specified thread. + -- Only call this function when Stack_Base_Available is True. + + function Get_Page_Size return size_t; + function Get_Page_Size return Address; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- returns the size of a page, or 0 if this is not relevant on this + -- target + + PROT_NONE : constant := 0; + PROT_READ : constant := 1; + PROT_WRITE : constant := 2; + PROT_EXEC : constant := 4; + PROT_USER : constant := 8; + PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC + PROT_USER; + + PROT_ON : constant := PROT_READ; + PROT_OFF : constant := PROT_ALL; + + function mprotect (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Inline (sigwait); + -- LynxOS has non standard sigwait + + function pthread_kill (thread : pthread_t; sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + function pthread_sigmask + (how : int; + set : access sigset_t; + oset : access sigset_t) return int; + pragma Import (C, pthread_sigmask, "sigprocmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Inline (pthread_mutexattr_init); + -- LynxOS has a nonstandard pthread_mutexattr_init + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Inline (pthread_mutexattr_destroy); + -- Lynxos has a nonstandard pthread_mutexattr_destroy + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Inline (pthread_mutex_init); + -- LynxOS has a nonstandard pthread_mutex_init + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Inline (pthread_mutex_destroy); + -- LynxOS has a nonstandard pthread_mutex_destroy + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Inline (pthread_mutex_lock); + -- LynxOS has a nonstandard pthread_mutex_lock + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Inline (pthread_mutex_unlock); + -- LynxOS has a nonstandard pthread_mutex_unlock + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Inline (pthread_condattr_init); + -- LynxOS has a nonstandard pthread_condattr_init + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Inline (pthread_condattr_destroy); + -- LynxOS has a nonstandard pthread_condattr_destroy + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Inline (pthread_cond_init); + -- LynxOS has a non standard pthread_cond_init + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Inline (pthread_cond_destroy); + -- LynxOS has a nonstandard pthread_cond_destroy + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Inline (pthread_cond_signal); + -- LynxOS has a nonstandard pthread_cond_signal + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Inline (pthread_cond_wait); + -- LynxOS has a nonstandard pthread_cond_wait + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + reltime : access timespec) return int; + pragma Inline (pthread_cond_timedwait); + -- LynxOS has a nonstandard pthread_cond_timedwait + + Relative_Timed_Wait : constant Boolean := True; + -- pthread_cond_timedwait requires a relative delay time + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + PTHREAD_PRIO_NONE : constant := 0; + PTHREAD_PRIO_INHERIT : constant := 0; + PTHREAD_PRIO_PROTECT : constant := 0; + + type struct_sched_param is record + sched_priority : int; -- scheduling priority + end record; + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Inline (pthread_setschedparam); + -- LynxOS doesn't have pthread_setschedparam. + -- Instead, use pthread_setscheduler + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Inline (pthread_mutexattr_setprotocol); + -- LynxOS doesn't have pthread_mutexattr_setprotocol + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Inline (pthread_mutexattr_setprioceiling); + -- LynxOS doesn't have pthread_mutexattr_setprioceiling + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + -- LynxOS doesn't have pthread_attr_setscope: all threads have system scope + pragma Inline (pthread_attr_setscope); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy, "pthread_attr_setsched"); + + function sched_yield return int; + -- pragma Import (C, sched_yield, "sched_yield"); + pragma Inline (sched_yield); + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_create"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_delete"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Inline (pthread_attr_setdetachstate); + -- LynxOS doesn't have pthread_attr_setdetachstate + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Inline (pthread_create); + -- LynxOS has a non standard pthread_create + + function pthread_detach (thread : pthread_t) return int; + pragma Inline (pthread_detach); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Inline (pthread_setspecific); + -- LynxOS has a non standard pthread_setspecific + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Inline (pthread_getspecific); + -- LynxOS has a non standard pthread_getspecific + + type destructor_pointer is access procedure (arg : System.Address); + pragma Convention (C, destructor_pointer); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Inline (pthread_key_create); + -- LynxOS has a non standard pthread_keycreate + + procedure pthread_init; + -- This is a dummy procedure to share some GNULLI files + +private + + type sigbit_array is array (1 .. 2) of long; + type sigset_t is record + sa_sigbits : sigbit_array; + end record; + pragma Convention (C_Pass_By_Copy, sigset_t); + + type pid_t is new long; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new unsigned_char; + CLOCK_REALTIME : constant clockid_t := 0; + + type st_t is record + stksize : int; + prio : int; + inheritsched : int; + state : int; + sched : int; + end record; + pragma Convention (C, st_t); + + type pthread_attr_t is record + st : st_t; + pthread_attr_scope : int; -- ignored + end record; + pragma Convention (C, pthread_attr_t); + + type pthread_condattr_t is new int; + + type pthread_mutexattr_t is new int; + + type tid_t is new short; + type pthread_t is new tid_t; + + type synch_ptr is access all pthread_mutex_t; + type pthread_mutex_t is record + w_count : int; + mut_owner : int; + id : unsigned; + next : synch_ptr; + end record; + pragma Convention (C, pthread_mutex_t); + + type pthread_cond_t is new pthread_mutex_t; + + type pthread_key_t is new int; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-lynxos.adb b/gcc/ada/s-osinte-lynxos.adb new file mode 100644 index 000000000..a0f48c033 --- /dev/null +++ b/gcc/ada/s-osinte-lynxos.adb @@ -0,0 +1,121 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2007, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a LynxOS (POSIX Threads) version of this package + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +package body System.OS_Interface is + + use Interfaces.C; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; + end To_Duration; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return timespec'(tv_sec => S, + tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ------------- + -- sigwait -- + ------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) + return int + is + function sigwaitinfo + (set : access sigset_t; + info : System.Address) return Signal; + pragma Import (C, sigwaitinfo, "sigwaitinfo"); + + begin + sig.all := sigwaitinfo (set, Null_Address); + + if sig.all = -1 then + return errno; + end if; + + return 0; + end sigwait; + + -------------------- + -- Get_Stack_Base -- + -------------------- + + function Get_Stack_Base (thread : pthread_t) return Address is + pragma Warnings (Off, thread); + + begin + return Null_Address; + end Get_Stack_Base; + + ------------------ + -- pthread_init -- + ------------------ + + procedure pthread_init is + begin + null; + end pthread_init; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-lynxos.ads b/gcc/ada/s-osinte-lynxos.ads new file mode 100644 index 000000000..6acb13201 --- /dev/null +++ b/gcc/ada/s-osinte-lynxos.ads @@ -0,0 +1,585 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a LynxOS (POSIX Threads) version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by the tasking run-time (libgnarl). + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Ada.Unchecked_Conversion; + +with Interfaces.C; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-mthreads"); + -- Selects the POSIX 1.c runtime, rather than the non-threading runtime + -- or the deprecated legacy threads library. The -mthreads flag is + -- defined in patch.LynxOS and matches the definition for Lynx's gcc. + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIMEDOUT : constant := 60; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 63; + + -- Max_Interrupt is the number of OS signals, as defined in: + -- + -- /usr/include/sys/signal.h + -- + -- + -- The lowest numbered signal is 1, but 0 is a valid argument to some + -- library functions, e.g. kill(2). However, 0 is not just another + -- signal: For instance 'I in Signal' and similar should be used with + -- caution. + + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGBRK : constant := 6; -- break + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in future + SIGCORE : constant := 7; -- kill with core dump + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGURG : constant := 16; -- urgent condition on IO channel + SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 18; -- user stop requested from tty + SIGCONT : constant := 19; -- stopped process has been continued + SIGCLD : constant := 20; -- alias for SIGCHLD + SIGCHLD : constant := 20; -- child status change + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias) + SIGPOLL : constant := 23; -- pollable event occurred + SIGTHREADKILL : constant := 24; -- Reserved by LynxOS runtime + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 27; -- profiling timer expired + SIGWINCH : constant := 28; -- window size change + SIGLOST : constant := 29; -- SUN 4.1 compatibility + SIGUSR1 : constant := 30; -- user defined signal 1 + SIGUSR2 : constant := 31; -- user defined signal 2 + + SIGPRIO : constant := 32; + -- sent to a process with its priority or group is changed + + SIGADAABORT : constant := SIGABRT; + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := + (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF, SIGTHREADKILL); + Reserved : constant Signal_Set := (SIGABRT, SIGKILL, SIGSTOP, SIGPRIO); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SA_SIGINFO : constant := 16#80#; + + SA_ONSTACK : constant := 16#00#; + -- SA_ONSTACK is not defined on LynxOS, but it is referred to in the POSIX + -- implementation of System.Interrupt_Management. Therefore we define a + -- dummy value of zero here so that setting this flag is a nop. + + SIG_BLOCK : constant := 0; + SIG_UNBLOCK : constant := 1; + SIG_SETMASK : constant := 2; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + Time_Slice_Supported : constant Boolean := True; + -- Indicates whether time slicing is supported + + type timespec is private; + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + function clock_getres + (clock_id : clockid_t; + res : access timespec) return int; + pragma Import (C, clock_getres, "clock_getres"); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timezone is record + tz_minuteswest : int; + tz_dsttime : int; + end record; + pragma Convention (C, struct_timezone); + type struct_timezone_ptr is access all struct_timezone; + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 16#200000#; + SCHED_RR : constant := 16#100000#; + SCHED_OTHER : constant := 16#400000#; + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------- + -- LWP -- + --------- + + function lwp_self return System.Address; + pragma Import (C, lwp_self, "pthread_self"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + pragma Convention (C, Thread_Body); + + function Thread_Body_Access is new + Ada.Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 1; + PTHREAD_CREATE_JOINABLE : constant := 0; + + ----------- + -- Stack -- + ----------- + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + + Stack_Base_Available : constant Boolean := False; + -- Indicates whether the stack base is available on this target + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- Returns the stack base of the specified thread. + -- Only call this function when Stack_Base_Available is True. + + function Get_Page_Size return size_t; + function Get_Page_Size return Address; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- Returns the size of a page, or 0 if this is not relevant on this + -- target + + PROT_NONE : constant := 1; + PROT_READ : constant := 2; + PROT_WRITE : constant := 4; + PROT_EXEC : constant := 8; + PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; + + PROT_ON : constant := PROT_READ; + PROT_OFF : constant := PROT_ALL; + + function mprotect (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + procedure pthread_init; + -- This is a dummy procedure to share some GNULLI files + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Inline (sigwait); + -- LynxOS has non standard sigwait + + function pthread_kill + (thread : pthread_t; + sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + function pthread_sigmask + (how : int; + set : access sigset_t; + oset : access sigset_t) return int; + pragma Import (C, pthread_sigmask, "pthread_sigmask"); + -- The behavior of pthread_sigmask on LynxOS requires + -- further investigation. + + ---------------------------- + -- POSIX.1c Section 11 -- + ---------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); + + Relative_Timed_Wait : constant Boolean := False; + -- pthread_cond_timedwait requires an absolute delay time + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + PTHREAD_PRIO_NONE : constant := 0; + PTHREAD_PRIO_INHERIT : constant := 1; + PTHREAD_PRIO_PROTECT : constant := 2; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import (C, pthread_mutexattr_setprioceiling); + + type struct_sched_param is record + sched_priority : int; + end record; + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import (C, pthread_attr_setinheritsched); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy); + + function sched_yield return int; + pragma Import (C, sched_yield, "sched_yield"); + + -------------------------- + -- P1003.1c Section 16 -- + -------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import (C, pthread_attr_setdetachstate); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "pthread_create"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function st_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, st_setspecific, "st_setspecific"); + + function st_getspecific + (key : pthread_key_t; + retval : System.Address) return int; + pragma Import (C, st_getspecific, "st_getspecific"); + + type destructor_pointer is access procedure (arg : System.Address); + pragma Convention (C, destructor_pointer); + + function st_keycreate + (destructor : destructor_pointer; + key : access pthread_key_t) return int; + pragma Import (C, st_keycreate, "st_keycreate"); + +private + + type sigset_t is record + X1, X2 : long; + end record; + pragma Convention (C, sigset_t); + + type pid_t is new long; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new unsigned_char; + CLOCK_REALTIME : constant clockid_t := 0; + + type st_attr_t is record + stksize : int; + prio : int; + inheritsched : int; + state : int; + sched : int; + detachstate : int; + guardsize : int; + end record; + pragma Convention (C, st_attr_t); + + type pthread_attr_t is record + pthread_attr_magic : unsigned; + st : st_attr_t; + pthread_attr_scope : int; + end record; + pragma Convention (C, pthread_attr_t); + + type pthread_condattr_t is record + cv_magic : unsigned; + cv_pshared : unsigned; + end record; + pragma Convention (C, pthread_condattr_t); + + type pthread_mutexattr_t is record + m_flags : unsigned; + m_prio_c : int; + m_pshared : int; + end record; + pragma Convention (C, pthread_mutexattr_t); + + type tid_t is new short; + type pthread_t is new tid_t; + + type block_obj_t is new System.Address; + -- typedef struct _block_obj_s { + -- struct st_entry *b_head; + -- } block_obj_t; + + type pthread_mutex_t is record + m_flags : unsigned; + m_owner : tid_t; + m_wait : block_obj_t; + m_prio_c : int; + m_oldprio : int; + m_count : int; + m_referenced : int; + end record; + pragma Convention (C, pthread_mutex_t); + type pthread_mutex_t_ptr is access all pthread_mutex_t; + + type pthread_cond_t is record + cv_magic : unsigned; + cv_wait : block_obj_t; + cv_mutex : pthread_mutex_t_ptr; + cv_refcnt : int; + end record; + pragma Convention (C, pthread_cond_t); + + type pthread_key_t is new int; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-mingw.ads b/gcc/ada/s-osinte-mingw.ads new file mode 100644 index 000000000..b3ac024dd --- /dev/null +++ b/gcc/ada/s-osinte-mingw.ads @@ -0,0 +1,363 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a NT (native) version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by the tasking run-time (libgnarl). For non tasking +-- oriented services consider declaring them into system-win32. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Ada.Unchecked_Conversion; + +with Interfaces.C; +with Interfaces.C.Strings; +with System.Win32; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-mthreads"); + + subtype int is Interfaces.C.int; + subtype long is Interfaces.C.long; + + ------------------- + -- General Types -- + ------------------- + + subtype PSZ is Interfaces.C.Strings.chars_ptr; + + Null_Void : constant Win32.PVOID := System.Null_Address; + + ------------------------- + -- Handles for objects -- + ------------------------- + + subtype Thread_Id is Win32.HANDLE; + + ----------- + -- Errno -- + ----------- + + NO_ERROR : constant := 0; + FUNC_ERR : constant := -1; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 31; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGINT : constant := 2; -- interrupt (Ctrl-C) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGFPE : constant := 8; -- floating point exception + SIGSEGV : constant := 11; -- segmentation violation + SIGTERM : constant := 15; -- software termination signal from kill + SIGBREAK : constant := 21; -- break (Ctrl-Break) + SIGABRT : constant := 22; -- used by abort, replace SIGIOT in the future + + type sigset_t is private; + + type isr_address is access procedure (sig : int); + pragma Convention (C, isr_address); + + function intr_attach (sig : int; handler : isr_address) return long; + pragma Import (C, intr_attach, "signal"); + + Intr_Attach_Reset : constant Boolean := True; + -- True if intr_attach is reset after an interrupt handler is called + + procedure kill (sig : Signal); + pragma Import (C, kill, "raise"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + pragma Convention (C, Thread_Body); + + function Thread_Body_Access is new + Ada.Unchecked_Conversion (System.Address, Thread_Body); + + procedure SwitchToThread; + pragma Import (Stdcall, SwitchToThread, "SwitchToThread"); + + function GetThreadTimes + (hThread : Win32.HANDLE; + lpCreationTime : access Long_Long_Integer; + lpExitTime : access Long_Long_Integer; + lpKernelTime : access Long_Long_Integer; + lpUserTime : access Long_Long_Integer) return Win32.BOOL; + pragma Import (Stdcall, GetThreadTimes, "GetThreadTimes"); + + ----------------------- + -- Critical sections -- + ----------------------- + + type CRITICAL_SECTION is private; + + ------------------------------------------------------------- + -- Thread Creation, Activation, Suspension And Termination -- + ------------------------------------------------------------- + + type PTHREAD_START_ROUTINE is access function + (pThreadParameter : Win32.PVOID) return Win32.DWORD; + pragma Convention (Stdcall, PTHREAD_START_ROUTINE); + + function To_PTHREAD_START_ROUTINE is new + Ada.Unchecked_Conversion (System.Address, PTHREAD_START_ROUTINE); + + function CreateThread + (pThreadAttributes : access Win32.SECURITY_ATTRIBUTES; + dwStackSize : Win32.DWORD; + pStartAddress : PTHREAD_START_ROUTINE; + pParameter : Win32.PVOID; + dwCreationFlags : Win32.DWORD; + pThreadId : access Win32.DWORD) return Win32.HANDLE; + pragma Import (Stdcall, CreateThread, "CreateThread"); + + function BeginThreadEx + (pThreadAttributes : access Win32.SECURITY_ATTRIBUTES; + dwStackSize : Win32.DWORD; + pStartAddress : PTHREAD_START_ROUTINE; + pParameter : Win32.PVOID; + dwCreationFlags : Win32.DWORD; + pThreadId : not null access Win32.DWORD) return Win32.HANDLE; + pragma Import (C, BeginThreadEx, "_beginthreadex"); + + Debug_Process : constant := 16#00000001#; + Debug_Only_This_Process : constant := 16#00000002#; + Create_Suspended : constant := 16#00000004#; + Detached_Process : constant := 16#00000008#; + Create_New_Console : constant := 16#00000010#; + + Create_New_Process_Group : constant := 16#00000200#; + + Create_No_window : constant := 16#08000000#; + + Profile_User : constant := 16#10000000#; + Profile_Kernel : constant := 16#20000000#; + Profile_Server : constant := 16#40000000#; + + Stack_Size_Param_Is_A_Reservation : constant := 16#00010000#; + + function GetExitCodeThread + (hThread : Win32.HANDLE; + pExitCode : not null access Win32.DWORD) return Win32.BOOL; + pragma Import (Stdcall, GetExitCodeThread, "GetExitCodeThread"); + + function ResumeThread (hThread : Win32.HANDLE) return Win32.DWORD; + pragma Import (Stdcall, ResumeThread, "ResumeThread"); + + function SuspendThread (hThread : Win32.HANDLE) return Win32.DWORD; + pragma Import (Stdcall, SuspendThread, "SuspendThread"); + + procedure ExitThread (dwExitCode : Win32.DWORD); + pragma Import (Stdcall, ExitThread, "ExitThread"); + + procedure EndThreadEx (dwExitCode : Win32.DWORD); + pragma Import (C, EndThreadEx, "_endthreadex"); + + function TerminateThread + (hThread : Win32.HANDLE; + dwExitCode : Win32.DWORD) return Win32.BOOL; + pragma Import (Stdcall, TerminateThread, "TerminateThread"); + + function GetCurrentThread return Win32.HANDLE; + pragma Import (Stdcall, GetCurrentThread, "GetCurrentThread"); + + function GetCurrentProcess return Win32.HANDLE; + pragma Import (Stdcall, GetCurrentProcess, "GetCurrentProcess"); + + function GetCurrentThreadId return Win32.DWORD; + pragma Import (Stdcall, GetCurrentThreadId, "GetCurrentThreadId"); + + function TlsAlloc return Win32.DWORD; + pragma Import (Stdcall, TlsAlloc, "TlsAlloc"); + + function TlsGetValue (dwTlsIndex : Win32.DWORD) return Win32.PVOID; + pragma Import (Stdcall, TlsGetValue, "TlsGetValue"); + + function TlsSetValue + (dwTlsIndex : Win32.DWORD; pTlsValue : Win32.PVOID) return Win32.BOOL; + pragma Import (Stdcall, TlsSetValue, "TlsSetValue"); + + function TlsFree (dwTlsIndex : Win32.DWORD) return Win32.BOOL; + pragma Import (Stdcall, TlsFree, "TlsFree"); + + TLS_Nothing : constant := Win32.DWORD'Last; + + procedure ExitProcess (uExitCode : Interfaces.C.unsigned); + pragma Import (Stdcall, ExitProcess, "ExitProcess"); + + function WaitForSingleObject + (hHandle : Win32.HANDLE; + dwMilliseconds : Win32.DWORD) return Win32.DWORD; + pragma Import (Stdcall, WaitForSingleObject, "WaitForSingleObject"); + + function WaitForSingleObjectEx + (hHandle : Win32.HANDLE; + dwMilliseconds : Win32.DWORD; + fAlertable : Win32.BOOL) return Win32.DWORD; + pragma Import (Stdcall, WaitForSingleObjectEx, "WaitForSingleObjectEx"); + + Wait_Infinite : constant := Win32.DWORD'Last; + WAIT_TIMEOUT : constant := 16#0000_0102#; + WAIT_FAILED : constant := 16#FFFF_FFFF#; + + ------------------------------------ + -- Semaphores, Events and Mutexes -- + ------------------------------------ + + function CreateSemaphore + (pSemaphoreAttributes : access Win32.SECURITY_ATTRIBUTES; + lInitialCount : Interfaces.C.long; + lMaximumCount : Interfaces.C.long; + pName : PSZ) return Win32.HANDLE; + pragma Import (Stdcall, CreateSemaphore, "CreateSemaphoreA"); + + function OpenSemaphore + (dwDesiredAccess : Win32.DWORD; + bInheritHandle : Win32.BOOL; + pName : PSZ) return Win32.HANDLE; + pragma Import (Stdcall, OpenSemaphore, "OpenSemaphoreA"); + + function ReleaseSemaphore + (hSemaphore : Win32.HANDLE; + lReleaseCount : Interfaces.C.long; + pPreviousCount : access Win32.LONG) return Win32.BOOL; + pragma Import (Stdcall, ReleaseSemaphore, "ReleaseSemaphore"); + + function CreateEvent + (pEventAttributes : access Win32.SECURITY_ATTRIBUTES; + bManualReset : Win32.BOOL; + bInitialState : Win32.BOOL; + pName : PSZ) return Win32.HANDLE; + pragma Import (Stdcall, CreateEvent, "CreateEventA"); + + function OpenEvent + (dwDesiredAccess : Win32.DWORD; + bInheritHandle : Win32.BOOL; + pName : PSZ) return Win32.HANDLE; + pragma Import (Stdcall, OpenEvent, "OpenEventA"); + + function SetEvent (hEvent : Win32.HANDLE) return Win32.BOOL; + pragma Import (Stdcall, SetEvent, "SetEvent"); + + function ResetEvent (hEvent : Win32.HANDLE) return Win32.BOOL; + pragma Import (Stdcall, ResetEvent, "ResetEvent"); + + function PulseEvent (hEvent : Win32.HANDLE) return Win32.BOOL; + pragma Import (Stdcall, PulseEvent, "PulseEvent"); + + function CreateMutex + (pMutexAttributes : access Win32.SECURITY_ATTRIBUTES; + bInitialOwner : Win32.BOOL; + pName : PSZ) return Win32.HANDLE; + pragma Import (Stdcall, CreateMutex, "CreateMutexA"); + + function OpenMutex + (dwDesiredAccess : Win32.DWORD; + bInheritHandle : Win32.BOOL; + pName : PSZ) return Win32.HANDLE; + pragma Import (Stdcall, OpenMutex, "OpenMutexA"); + + function ReleaseMutex (hMutex : Win32.HANDLE) return Win32.BOOL; + pragma Import (Stdcall, ReleaseMutex, "ReleaseMutex"); + + --------------------------------------------------- + -- Accessing properties of Threads and Processes -- + --------------------------------------------------- + + ----------------- + -- Priorities -- + ----------------- + + function SetThreadPriority + (hThread : Win32.HANDLE; + nPriority : Interfaces.C.int) return Win32.BOOL; + pragma Import (Stdcall, SetThreadPriority, "SetThreadPriority"); + + function GetThreadPriority (hThread : Win32.HANDLE) return Interfaces.C.int; + pragma Import (Stdcall, GetThreadPriority, "GetThreadPriority"); + + function SetPriorityClass + (hProcess : Win32.HANDLE; + dwPriorityClass : Win32.DWORD) return Win32.BOOL; + pragma Import (Stdcall, SetPriorityClass, "SetPriorityClass"); + + procedure SetThreadPriorityBoost + (hThread : Win32.HANDLE; + DisablePriorityBoost : Win32.BOOL); + pragma Import (Stdcall, SetThreadPriorityBoost, "SetThreadPriorityBoost"); + + Normal_Priority_Class : constant := 16#00000020#; + Idle_Priority_Class : constant := 16#00000040#; + High_Priority_Class : constant := 16#00000080#; + Realtime_Priority_Class : constant := 16#00000100#; + + Thread_Priority_Idle : constant := -15; + Thread_Priority_Lowest : constant := -2; + Thread_Priority_Below_Normal : constant := -1; + Thread_Priority_Normal : constant := 0; + Thread_Priority_Above_Normal : constant := 1; + Thread_Priority_Highest : constant := 2; + Thread_Priority_Time_Critical : constant := 15; + Thread_Priority_Error_Return : constant := Interfaces.C.long'Last; + +private + + type sigset_t is new Interfaces.C.unsigned_long; + + type CRITICAL_SECTION is record + DebugInfo : System.Address; + + LockCount : Long_Integer; + RecursionCount : Long_Integer; + OwningThread : Win32.HANDLE; + -- The above three fields control entering and exiting the critical + -- section for the resource. + + LockSemaphore : Win32.HANDLE; + SpinCount : Win32.DWORD; + end record; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-posix.adb b/gcc/ada/s-osinte-posix.adb new file mode 100644 index 000000000..310454ad1 --- /dev/null +++ b/gcc/ada/s-osinte-posix.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2006, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a GNU/LinuxThreads, Solaris pthread and HP-UX pthread version +-- of this package. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +with Interfaces.C; use Interfaces.C; +package body System.OS_Interface is + + -------------------- + -- Get_Stack_Base -- + -------------------- + + function Get_Stack_Base (thread : pthread_t) return Address is + pragma Warnings (Off, thread); + + begin + return Null_Address; + end Get_Stack_Base; + + ------------------ + -- pthread_init -- + ------------------ + + procedure pthread_init is + begin + null; + end pthread_init; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; + end To_Duration; + + ------------------------ + -- To_Target_Priority -- + ------------------------ + + function To_Target_Priority + (Prio : System.Any_Priority) return Interfaces.C.int + is + begin + return Interfaces.C.int (Prio); + end To_Target_Priority; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return timespec'(tv_sec => S, + tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-rtems.adb b/gcc/ada/s-osinte-rtems.adb new file mode 100644 index 000000000..d8e57f692 --- /dev/null +++ b/gcc/ada/s-osinte-rtems.adb @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1991-2009 Florida State University -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. It is -- +-- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- +-- State University (http://www.gnat.com). -- +-- -- +-- The GNARL files that were developed for RTEMS are maintained by On-Line -- +-- Applications Research Corporation (http://www.oarcorp.com) in coopera- -- +-- tion with Ada Core Technologies Inc. and Florida State University. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the RTEMS version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with Interfaces.C; use Interfaces.C; +package body System.OS_Interface is + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; + end To_Duration; + + ------------------------ + -- To_Target_Priority -- + ------------------------ + + function To_Target_Priority + (Prio : System.Any_Priority) return Interfaces.C.int + is + begin + return Interfaces.C.int (Prio); + end To_Target_Priority; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to round-up, adjust for positive F value + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + return timespec'(tv_sec => S, + tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ------------------ + -- pthread_init -- + ------------------ + + procedure pthread_init is + begin + null; + end pthread_init; + + -------------------- + -- Get_Stack_Base -- + -------------------- + + function Get_Stack_Base (thread : pthread_t) return Address is + pragma Warnings (Off, thread); + + begin + return Null_Address; + end Get_Stack_Base; + + ----------------- + -- sigaltstack -- + ----------------- + + function sigaltstack + (ss : not null access stack_t; + oss : access stack_t) return int is + pragma Unreferenced (ss); + pragma Unreferenced (oss); + begin + return 0; + end sigaltstack; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-rtems.ads b/gcc/ada/s-osinte-rtems.ads new file mode 100644 index 000000000..eb8b17d5f --- /dev/null +++ b/gcc/ada/s-osinte-rtems.ads @@ -0,0 +1,629 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1997-2009 Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +-- The GNARL files that were developed for RTEMS are maintained by On-Line -- +-- Applications Research Corporation (http://www.oarcorp.com) in coopera- -- +-- tion with Ada Core Technologies Inc. and Florida State University. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the RTEMS version of this package. +-- +-- RTEMS target names are of the form CPU-rtems. +-- This implementation is designed to work on ALL RTEMS targets. +-- The RTEMS implementation is primarily based upon the POSIX threads +-- API but there are also bindings to GNAT/RTEMS support routines +-- to insulate this code from C API specific details and, in some +-- cases, obtain target architecture and BSP specific information +-- that is unavailable at the time this package is built. + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +-- PLEASE DO NOT add any with-clauses to this package +-- or remove the pragma Preelaborate. +-- It is designed to be a bottom-level (leaf) package. + +with Interfaces.C; +package System.OS_Interface is + pragma Preelaborate; + + -- This interface assumes that "unsigned" is a 32-bit entity. This + -- will correspond to RTEMS object ids. + + subtype rtems_id is Interfaces.C.unsigned; + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIMEDOUT : constant := 116; + + ------------- + -- Signals -- + ------------- + + Num_HW_Interrupts : constant := 256; + + Max_HW_Interrupt : constant := Num_HW_Interrupts - 1; + type HW_Interrupt is new int range 0 .. Max_HW_Interrupt; + + Max_Interrupt : constant := Max_HW_Interrupt; + + type Signal is new int range 0 .. Max_Interrupt; + + SIGXCPU : constant := 0; -- XCPU + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 16; -- user defined signal 1 + SIGUSR2 : constant := 17; -- user defined signal 2 + + SIGADAABORT : constant := SIGABRT; + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := (SIGTRAP, SIGALRM, SIGEMT); + Reserved : constant Signal_Set := (1 .. 1 => SIGKILL); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type struct_sigaction is record + sa_flags : int; + sa_mask : sigset_t; + sa_handler : System.Address; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SA_SIGINFO : constant := 16#02#; + + SA_ONSTACK : constant := 16#00#; + -- SA_ONSTACK is not defined on RTEMS, but it is referred to in the POSIX + -- implementation of System.Interrupt_Management. Therefore we define a + -- dummy value of zero here so that setting this flag is a nop. + + SIG_BLOCK : constant := 1; + SIG_UNBLOCK : constant := 2; + SIG_SETMASK : constant := 3; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + Time_Slice_Supported : constant Boolean := True; + -- Indicates whether time slicing is supported (i.e SCHED_RR is supported) + + type timespec is private; + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 1; + SCHED_RR : constant := 2; + SCHED_OTHER : constant := 0; + + function To_Target_Priority + (Prio : System.Any_Priority) return Interfaces.C.int; + -- Maps System.Any_Priority to a POSIX priority + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------- + -- LWP -- + --------- + + function lwp_self return System.Address; + -- lwp_self does not exist on this thread library, revert to pthread_self + -- which is the closest approximation (with getpid). This function is + -- needed to share 7staprop.adb across POSIX-like targets. + pragma Import (C, lwp_self, "pthread_self"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + pragma Convention (C, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + No_Key : constant pthread_key_t; + + PTHREAD_CREATE_DETACHED : constant := 0; + + PTHREAD_SCOPE_PROCESS : constant := 0; + PTHREAD_SCOPE_SYSTEM : constant := 1; + + ----------- + -- Stack -- + ----------- + + type stack_t is record + ss_sp : System.Address; + ss_flags : int; + ss_size : size_t; + end record; + pragma Convention (C, stack_t); + + function sigaltstack + (ss : not null access stack_t; + oss : access stack_t) return int; + + Alternate_Stack : aliased System.Address; + -- This is a dummy definition, never used (Alternate_Stack_Size is null) + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + + Stack_Base_Available : constant Boolean := False; + -- Indicates whether the stack base is available on this target. + -- This allows us to share s-osinte.adb between all the FSU/RTEMS + -- run time. + -- Note that this value can only be true if pthread_t has a complete + -- definition that corresponds exactly to the C header files. + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- returns the stack base of the specified thread. + -- Only call this function when Stack_Base_Available is True. + + -- These two functions are only needed to share s-taprop.adb with + -- FSU threads. + + function Get_Page_Size return size_t; + function Get_Page_Size return Address; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- Returns the size of a page + + PROT_ON : constant := 0; + PROT_OFF : constant := 0; + + function mprotect (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + ----------------------------------------- + -- Nonstandard Thread Initialization -- + ----------------------------------------- + + procedure pthread_init; + -- FSU_THREADS requires pthread_init, which is nonstandard + -- and this should be invoked during the elaboration of s-taprop.adb + -- + -- RTEMS does not require this so we provide an empty Ada body. + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Import (C, sigwait, "sigwait"); + + function pthread_kill + (thread : pthread_t; + sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + function pthread_sigmask + (how : int; + set : access sigset_t; + oset : access sigset_t) return int; + pragma Import (C, pthread_sigmask, "pthread_sigmask"); + + ---------------------------- + -- POSIX.1c Section 11 -- + ---------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); + + Relative_Timed_Wait : constant Boolean := False; + -- pthread_cond_timedwait requires an absolute delay time + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + PTHREAD_PRIO_NONE : constant := 0; + PTHREAD_PRIO_PROTECT : constant := 2; + PTHREAD_PRIO_INHERIT : constant := 1; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import + (C, pthread_mutexattr_setprioceiling, + "pthread_mutexattr_setprioceiling"); + + type struct_sched_param is record + sched_priority : int; + ss_low_priority : int; + ss_replenish_period : timespec; + ss_initial_budget : timespec; + end record; + pragma Convention (C, struct_sched_param); + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import (C, pthread_attr_setinheritsched); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy); + + function pthread_attr_setschedparam + (attr : access pthread_attr_t; + sched_param : int) return int; + pragma Import (C, pthread_attr_setschedparam); + + function sched_yield return int; + pragma Import (C, sched_yield, "sched_yield"); + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import (C, pthread_attr_setdetachstate); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "pthread_create"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Import (C, pthread_getspecific, "pthread_getspecific"); + + type destructor_pointer is access procedure (arg : System.Address); + pragma Convention (C, destructor_pointer); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + + ------------------------------------------------------------ + -- Binary Semaphore Wrapper to Support Interrupt Tasks -- + ------------------------------------------------------------ + + type Binary_Semaphore_Id is new rtems_id; + + function Binary_Semaphore_Create return Binary_Semaphore_Id; + pragma Import ( + C, + Binary_Semaphore_Create, + "__gnat_binary_semaphore_create"); + + function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int; + pragma Import ( + C, + Binary_Semaphore_Delete, + "__gnat_binary_semaphore_delete"); + + function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int; + pragma Import ( + C, + Binary_Semaphore_Obtain, + "__gnat_binary_semaphore_obtain"); + + function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int; + pragma Import ( + C, + Binary_Semaphore_Release, + "__gnat_binary_semaphore_release"); + + function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int; + pragma Import ( + C, + Binary_Semaphore_Flush, + "__gnat_binary_semaphore_flush"); + + ------------------------------------------------------------ + -- Hardware Interrupt Wrappers to Support Interrupt Tasks -- + ------------------------------------------------------------ + + type Interrupt_Handler is access procedure (parameter : System.Address); + pragma Convention (C, Interrupt_Handler); + type Interrupt_Vector is new System.Address; + + function Interrupt_Connect + (vector : Interrupt_Vector; + handler : Interrupt_Handler; + parameter : System.Address := System.Null_Address) return int; + pragma Import (C, Interrupt_Connect, "__gnat_interrupt_connect"); + -- Use this to set up an user handler. The routine installs a + -- a user handler which is invoked after RTEMS has saved enough + -- context for a high-level language routine to be safely invoked. + + function Interrupt_Vector_Get + (Vector : Interrupt_Vector) return Interrupt_Handler; + pragma Import (C, Interrupt_Vector_Get, "__gnat_interrupt_get"); + -- Use this to get the existing handler for later restoral. + + procedure Interrupt_Vector_Set + (Vector : Interrupt_Vector; + Handler : Interrupt_Handler); + pragma Import (C, Interrupt_Vector_Set, "__gnat_interrupt_set"); + -- Use this to restore a handler obtained using Interrupt_Vector_Get. + + function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector; + -- Convert a logical interrupt number to the hardware interrupt vector + -- number used to connect the interrupt. + pragma Import ( + C, + Interrupt_Number_To_Vector, + "__gnat_interrupt_number_to_vector" + ); + +private + + type sigset_t is new int; + + type pid_t is new int; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new rtems_id; + CLOCK_REALTIME : constant clockid_t := 1; + + type pthread_attr_t is record + is_initialized : int; + stackaddr : System.Address; + stacksize : int; + contentionscope : int; + inheritsched : int; + schedpolicy : int; + schedparam : struct_sched_param; + cputime_clocked_allowed : int; + detatchstate : int; + end record; + pragma Convention (C, pthread_attr_t); + + type pthread_condattr_t is record + flags : int; + process_shared : int; + end record; + pragma Convention (C, pthread_condattr_t); + + type pthread_mutexattr_t is record + is_initialized : int; + process_shared : int; + prio_ceiling : int; + protocol : int; + mutex_type : int; + recursive : int; + end record; + pragma Convention (C, pthread_mutexattr_t); + + type pthread_t is new rtems_id; + + type pthread_mutex_t is new rtems_id; + + type pthread_cond_t is new rtems_id; + + type pthread_key_t is new rtems_id; + + No_Key : constant pthread_key_t := 0; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-solaris-posix.ads b/gcc/ada/s-osinte-solaris-posix.ads new file mode 100644 index 000000000..517ed52c1 --- /dev/null +++ b/gcc/ada/s-osinte-solaris-posix.ads @@ -0,0 +1,554 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a Solaris (POSIX Threads) version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by the tasking run-time (libgnarl). + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; + +with Ada.Unchecked_Conversion; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-lposix4"); + pragma Linker_Options ("-lpthread"); + + -- The following is needed to allow --enable-threads=solaris + + pragma Linker_Options ("-lthread"); + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIMEDOUT : constant := 145; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 45; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 16; -- user defined signal 1 + SIGUSR2 : constant := 17; -- user defined signal 2 + SIGCLD : constant := 18; -- alias for SIGCHLD + SIGCHLD : constant := 18; -- child status change + SIGPWR : constant := 19; -- power-fail restart + SIGWINCH : constant := 20; -- window size change + SIGURG : constant := 21; -- urgent condition on IO channel + SIGPOLL : constant := 22; -- pollable event occurred + SIGIO : constant := 22; -- I/O possible (Solaris SIGPOLL alias) + SIGSTOP : constant := 23; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 24; -- user stop requested from tty + SIGCONT : constant := 25; -- stopped process has been continued + SIGTTIN : constant := 26; -- background tty read attempted + SIGTTOU : constant := 27; -- background tty write attempted + SIGVTALRM : constant := 28; -- virtual timer expired + SIGPROF : constant := 29; -- profiling timer expired + SIGXCPU : constant := 30; -- CPU time limit exceeded + SIGXFSZ : constant := 31; -- filesize limit exceeded + SIGWAITING : constant := 32; -- process's lwps blocked (Solaris) + SIGLWP : constant := 33; -- used by thread library (Solaris) + SIGFREEZE : constant := 34; -- used by CPR (Solaris) + SIGTHAW : constant := 35; -- used by CPR (Solaris) + SIGCANCEL : constant := 36; -- thread cancellation signal (libthread) + + SIGADAABORT : constant := SIGABRT; + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := (SIGTRAP, SIGLWP, SIGPROF); + + -- Following signals should not be disturbed. + -- See c-posix-signals.c in FLORIST + + Reserved : constant Signal_Set := + (SIGKILL, SIGSTOP, SIGWAITING, SIGCANCEL); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type struct_sigaction is record + sa_flags : int; + sa_handler : System.Address; + sa_mask : sigset_t; + sa_resv1 : int; + sa_resv2 : int; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SA_SIGINFO : constant := 16#0008#; + SA_ONSTACK : constant := 16#0001#; + + SIG_BLOCK : constant := 1; + SIG_UNBLOCK : constant := 2; + SIG_SETMASK : constant := 3; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + Time_Slice_Supported : constant Boolean := True; + -- Indicates whether time slicing is supported + + type timespec is private; + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 1; + SCHED_RR : constant := 2; + SCHED_OTHER : constant := 0; + + function To_Target_Priority + (Prio : System.Any_Priority) return Interfaces.C.int; + -- Maps System.Any_Priority to a POSIX priority + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------- + -- LWP -- + --------- + + function lwp_self return System.Address; + pragma Import (C, lwp_self, "_lwp_self"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + pragma Convention (C, Thread_Body); + + function Thread_Body_Access is new + Ada.Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 16#40#; + + PTHREAD_SCOPE_PROCESS : constant := 0; + PTHREAD_SCOPE_SYSTEM : constant := 1; + + ----------- + -- Stack -- + ----------- + + type stack_t is record + ss_sp : System.Address; + ss_size : size_t; + ss_flags : int; + end record; + pragma Convention (C, stack_t); + + function sigaltstack + (ss : not null access stack_t; + oss : access stack_t) return int; + pragma Import (C, sigaltstack, "sigaltstack"); + + Alternate_Stack : aliased System.Address; + -- This is a dummy definition, never used (Alternate_Stack_Size is null) + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + + Stack_Base_Available : constant Boolean := False; + -- Indicates whether the stack base is available on this target + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- Returns the stack base of the specified thread. Only call this function + -- when Stack_Base_Available is True. + + function Get_Page_Size return size_t; + function Get_Page_Size return Address; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- Returns the size of a page + + PROT_NONE : constant := 0; + PROT_READ : constant := 1; + PROT_WRITE : constant := 2; + PROT_EXEC : constant := 4; + PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; + PROT_ON : constant := PROT_READ; + PROT_OFF : constant := PROT_ALL; + + function mprotect (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + procedure pthread_init; + -- This is a dummy procedure to share some GNULLI files + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Import (C, sigwait, "__posix_sigwait"); + + function pthread_kill + (thread : pthread_t; + sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + function pthread_sigmask + (how : int; + set : access sigset_t; + oset : access sigset_t) return int; + pragma Import (C, pthread_sigmask, "pthread_sigmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); + + Relative_Timed_Wait : constant Boolean := False; + -- pthread_cond_timedwait requires an absolute delay time + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + PTHREAD_PRIO_NONE : constant := 0; + PTHREAD_PRIO_INHERIT : constant := 16#10#; + PTHREAD_PRIO_PROTECT : constant := 16#20#; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import (C, pthread_mutexattr_setprioceiling); + + type Array_8_Int is array (0 .. 7) of int; + type struct_sched_param is record + sched_priority : int; + sched_pad : Array_8_Int; + end record; + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import (C, pthread_attr_setinheritsched); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy); + + function sched_yield return int; + pragma Import (C, sched_yield, "sched_yield"); + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import (C, pthread_attr_setdetachstate); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "pthread_create"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Import (C, pthread_getspecific, "pthread_getspecific"); + + type destructor_pointer is access procedure (arg : System.Address); + pragma Convention (C, destructor_pointer); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + +private + + type array_type_1 is array (Integer range 0 .. 3) of unsigned_long; + type sigset_t is record + X_X_sigbits : array_type_1; + end record; + pragma Convention (C, sigset_t); + + type pid_t is new long; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 0; + + type pthread_attr_t is record + pthread_attrp : System.Address; + end record; + pragma Convention (C, pthread_attr_t); + + type pthread_condattr_t is record + pthread_condattrp : System.Address; + end record; + pragma Convention (C, pthread_condattr_t); + + type pthread_mutexattr_t is record + pthread_mutexattrp : System.Address; + end record; + pragma Convention (C, pthread_mutexattr_t); + + type pthread_t is new unsigned; + + type uint64_t is mod 2 ** 64; + + type pthread_mutex_t is record + pthread_mutex_flags : uint64_t; + pthread_mutex_owner64 : uint64_t; + pthread_mutex_data : uint64_t; + end record; + pragma Convention (C, pthread_mutex_t); + type pthread_mutex_t_ptr is access pthread_mutex_t; + + type pthread_cond_t is record + pthread_cond_flags : uint64_t; + pthread_cond_data : uint64_t; + end record; + pragma Convention (C, pthread_cond_t); + + type pthread_key_t is new unsigned; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-solaris.adb b/gcc/ada/s-osinte-solaris.adb new file mode 100644 index 000000000..3f40bc677 --- /dev/null +++ b/gcc/ada/s-osinte-solaris.adb @@ -0,0 +1,89 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2007, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a Solaris version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with Interfaces.C; use Interfaces.C; + +package body System.OS_Interface is + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; + end To_Duration; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return timespec'(tv_sec => S, + tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ------------------ + -- pthread_init -- + ------------------ + + procedure pthread_init is + begin + null; + end pthread_init; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-solaris.ads b/gcc/ada/s-osinte-solaris.ads new file mode 100644 index 000000000..0728b18ef --- /dev/null +++ b/gcc/ada/s-osinte-solaris.ads @@ -0,0 +1,544 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a Solaris (native) version of this package + +-- This package includes all direct interfaces to OS services +-- that are needed by the tasking run-time (libgnarl). + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; + +with Ada.Unchecked_Conversion; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-lposix4"); + pragma Linker_Options ("-lthread"); + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIME : constant := 62; + ETIMEDOUT : constant := 145; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 45; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 16; -- user defined signal 1 + SIGUSR2 : constant := 17; -- user defined signal 2 + SIGCLD : constant := 18; -- alias for SIGCHLD + SIGCHLD : constant := 18; -- child status change + SIGPWR : constant := 19; -- power-fail restart + SIGWINCH : constant := 20; -- window size change + SIGURG : constant := 21; -- urgent condition on IO channel + SIGPOLL : constant := 22; -- pollable event occurred + SIGIO : constant := 22; -- I/O possible (Solaris SIGPOLL alias) + SIGSTOP : constant := 23; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 24; -- user stop requested from tty + SIGCONT : constant := 25; -- stopped process has been continued + SIGTTIN : constant := 26; -- background tty read attempted + SIGTTOU : constant := 27; -- background tty write attempted + SIGVTALRM : constant := 28; -- virtual timer expired + SIGPROF : constant := 29; -- profiling timer expired + SIGXCPU : constant := 30; -- CPU time limit exceeded + SIGXFSZ : constant := 31; -- filesize limit exceeded + SIGWAITING : constant := 32; -- process's lwps blocked (Solaris) + SIGLWP : constant := 33; -- used by thread library (Solaris) + SIGFREEZE : constant := 34; -- used by CPR (Solaris) + SIGTHAW : constant := 35; -- used by CPR (Solaris) + SIGCANCEL : constant := 36; -- thread cancellation signal (libthread) + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := (SIGTRAP, SIGLWP, SIGPROF); + + -- Following signals should not be disturbed. + -- See c-posix-signals.c in FLORIST. + + Reserved : constant Signal_Set := + (SIGKILL, SIGSTOP, SIGWAITING, SIGCANCEL, SIGTRAP, SIGSEGV); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type union_type_3 is new String (1 .. 116); + type siginfo_t is record + si_signo : int; + si_code : int; + si_errno : int; + X_data : union_type_3; + end record; + pragma Convention (C, siginfo_t); + + -- The types mcontext_t and gregset_t are part of the ucontext_t + -- information, which is specific to Solaris2.4 for SPARC + -- The ucontext_t info seems to be used by the handler + -- for SIGSEGV to decide whether it is a Storage_Error (stack overflow) or + -- a Constraint_Error (bad pointer). The original code that did this + -- is suspect, so it is not clear whether we really need this part of + -- the signal context information, or perhaps something else. + -- More analysis is needed, after which these declarations may need to + -- be changed. + + type greg_t is new int; + + type gregset_t is array (0 .. 18) of greg_t; + + type union_type_2 is new String (1 .. 128); + type record_type_1 is record + fpu_fr : union_type_2; + fpu_q : System.Address; + fpu_fsr : unsigned; + fpu_qcnt : unsigned_char; + fpu_q_entrysize : unsigned_char; + fpu_en : unsigned_char; + end record; + pragma Convention (C, record_type_1); + + type array_type_7 is array (Integer range 0 .. 20) of long; + type mcontext_t is record + gregs : gregset_t; + gwins : System.Address; + fpregs : record_type_1; + filler : array_type_7; + end record; + pragma Convention (C, mcontext_t); + + type record_type_2 is record + ss_sp : System.Address; + ss_size : int; + ss_flags : int; + end record; + pragma Convention (C, record_type_2); + + type array_type_8 is array (Integer range 0 .. 22) of long; + type ucontext_t is record + uc_flags : unsigned_long; + uc_link : System.Address; + uc_sigmask : sigset_t; + uc_stack : record_type_2; + uc_mcontext : mcontext_t; + uc_filler : array_type_8; + end record; + pragma Convention (C, ucontext_t); + + type Signal_Handler is access procedure + (signo : Signal; + info : access siginfo_t; + context : access ucontext_t); + + type union_type_1 is new plain_char; + type array_type_2 is array (Integer range 0 .. 1) of int; + type struct_sigaction is record + sa_flags : int; + sa_handler : System.Address; + sa_mask : sigset_t; + sa_resv : array_type_2; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SIG_BLOCK : constant := 1; + SIG_UNBLOCK : constant := 2; + SIG_SETMASK : constant := 3; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + type timespec is private; + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; tp : access timespec) return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + function clock_getres + (clock_id : clockid_t; res : access timespec) return int; + pragma Import (C, clock_getres, "clock_getres"); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + pragma Convention (C, Thread_Body); + + function Thread_Body_Access is new + Ada.Unchecked_Conversion (System.Address, Thread_Body); + + THR_DETACHED : constant := 64; + THR_BOUND : constant := 1; + THR_NEW_LWP : constant := 2; + USYNC_THREAD : constant := 0; + + type thread_t is new unsigned; + subtype Thread_Id is thread_t; + -- These types should be commented ??? + + function To_thread_t is new Ada.Unchecked_Conversion (Integer, thread_t); + + type mutex_t is limited private; + + type cond_t is limited private; + + type thread_key_t is private; + + function thr_create + (stack_base : System.Address; + stack_size : size_t; + start_routine : Thread_Body; + arg : System.Address; + flags : int; + new_thread : access thread_t) return int; + pragma Import (C, thr_create, "thr_create"); + + function thr_min_stack return size_t; + pragma Import (C, thr_min_stack, "thr_min_stack"); + + function thr_self return thread_t; + pragma Import (C, thr_self, "thr_self"); + + function mutex_init + (mutex : access mutex_t; + mtype : int; + arg : System.Address) return int; + pragma Import (C, mutex_init, "mutex_init"); + + function mutex_destroy (mutex : access mutex_t) return int; + pragma Import (C, mutex_destroy, "mutex_destroy"); + + function mutex_lock (mutex : access mutex_t) return int; + pragma Import (C, mutex_lock, "mutex_lock"); + + function mutex_unlock (mutex : access mutex_t) return int; + pragma Import (C, mutex_unlock, "mutex_unlock"); + + function cond_init + (cond : access cond_t; + ctype : int; + arg : int) return int; + pragma Import (C, cond_init, "cond_init"); + + function cond_wait + (cond : access cond_t; mutex : access mutex_t) return int; + pragma Import (C, cond_wait, "cond_wait"); + + function cond_timedwait + (cond : access cond_t; + mutex : access mutex_t; + abstime : access timespec) return int; + pragma Import (C, cond_timedwait, "cond_timedwait"); + + function cond_signal (cond : access cond_t) return int; + pragma Import (C, cond_signal, "cond_signal"); + + function cond_destroy (cond : access cond_t) return int; + pragma Import (C, cond_destroy, "cond_destroy"); + + function thr_setspecific + (key : thread_key_t; value : System.Address) return int; + pragma Import (C, thr_setspecific, "thr_setspecific"); + + function thr_getspecific + (key : thread_key_t; + value : access System.Address) return int; + pragma Import (C, thr_getspecific, "thr_getspecific"); + + function thr_keycreate + (key : access thread_key_t; destructor : System.Address) return int; + pragma Import (C, thr_keycreate, "thr_keycreate"); + + function thr_setprio (thread : thread_t; priority : int) return int; + pragma Import (C, thr_setprio, "thr_setprio"); + + procedure thr_exit (status : System.Address); + pragma Import (C, thr_exit, "thr_exit"); + + function thr_setconcurrency (new_level : int) return int; + pragma Import (C, thr_setconcurrency, "thr_setconcurrency"); + + function sigwait (set : access sigset_t; sig : access Signal) return int; + pragma Import (C, sigwait, "__posix_sigwait"); + + function thr_kill (thread : thread_t; sig : Signal) return int; + pragma Import (C, thr_kill, "thr_kill"); + + function thr_sigsetmask + (how : int; + set : access sigset_t; + oset : access sigset_t) return int; + pragma Import (C, thr_sigsetmask, "thr_sigsetmask"); + + function pthread_sigmask + (how : int; + set : access sigset_t; + oset : access sigset_t) return int; + pragma Import (C, pthread_sigmask, "thr_sigsetmask"); + + function thr_suspend (target_thread : thread_t) return int; + pragma Import (C, thr_suspend, "thr_suspend"); + + function thr_continue (target_thread : thread_t) return int; + pragma Import (C, thr_continue, "thr_continue"); + + procedure thr_yield; + pragma Import (C, thr_yield, "thr_yield"); + + --------- + -- LWP -- + --------- + + P_PID : constant := 0; + P_LWPID : constant := 8; + + PC_GETCID : constant := 0; + PC_GETCLINFO : constant := 1; + PC_SETPARMS : constant := 2; + PC_GETPARMS : constant := 3; + PC_ADMIN : constant := 4; + + PC_CLNULL : constant := -1; + + RT_NOCHANGE : constant := -1; + RT_TQINF : constant := -2; + RT_TQDEF : constant := -3; + + PC_CLNMSZ : constant := 16; + + PC_VERSION : constant := 1; + + type lwpid_t is new int; + + type pri_t is new short; + + type id_t is new long; + + P_MYID : constant := -1; + -- The specified LWP or process is the current one + + type struct_pcinfo is record + pc_cid : id_t; + pc_clname : String (1 .. PC_CLNMSZ); + rt_maxpri : short; + end record; + pragma Convention (C, struct_pcinfo); + + type struct_pcparms is record + pc_cid : id_t; + rt_pri : pri_t; + rt_tqsecs : long; + rt_tqnsecs : long; + end record; + pragma Convention (C, struct_pcparms); + + function priocntl + (ver : int; + id_type : int; + id : lwpid_t; + cmd : int; + arg : System.Address) return Interfaces.C.long; + pragma Import (C, priocntl, "__priocntl"); + + function lwp_self return lwpid_t; + pragma Import (C, lwp_self, "_lwp_self"); + + type processorid_t is new int; + type processorid_t_ptr is access all processorid_t; + + -- Constants for function processor_bind + + PBIND_QUERY : constant processorid_t := -2; + -- The processor bindings are not changed + + PBIND_NONE : constant processorid_t := -1; + -- The processor bindings of the specified LWPs are cleared + + -- Flags for function p_online + + PR_OFFLINE : constant int := 1; + -- Processor is offline, as quiet as possible + + PR_ONLINE : constant int := 2; + -- Processor online + + PR_STATUS : constant int := 3; + -- Value passed to p_online to request status + + function p_online (processorid : processorid_t; flag : int) return int; + pragma Import (C, p_online, "p_online"); + + function processor_bind + (id_type : int; + id : id_t; + proc_id : processorid_t; + obind : processorid_t_ptr) return int; + pragma Import (C, processor_bind, "processor_bind"); + + procedure pthread_init; + -- Dummy procedure to share s-intman.adb with other Solaris targets + +private + + type array_type_1 is array (0 .. 3) of unsigned_long; + type sigset_t is record + X_X_sigbits : array_type_1; + end record; + pragma Convention (C, sigset_t); + + type pid_t is new long; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 0; + + type array_type_9 is array (0 .. 3) of unsigned_char; + type record_type_3 is record + flag : array_type_9; + Xtype : unsigned_long; + end record; + pragma Convention (C, record_type_3); + + type mutex_t is record + flags : record_type_3; + lock : String (1 .. 8); + data : String (1 .. 8); + end record; + pragma Convention (C, mutex_t); + + type cond_t is record + flag : array_type_9; + Xtype : unsigned_long; + data : String (1 .. 8); + end record; + pragma Convention (C, cond_t); + + type thread_key_t is new unsigned; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-tru64.adb b/gcc/ada/s-osinte-tru64.adb new file mode 100644 index 000000000..ad391bcb4 --- /dev/null +++ b/gcc/ada/s-osinte-tru64.adb @@ -0,0 +1,142 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the DEC Unix version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with Interfaces.C; use Interfaces.C; +with System.Machine_Code; use System.Machine_Code; + +package body System.OS_Interface is + + -------------------- + -- Get_Stack_Base -- + -------------------- + + function Get_Stack_Base (thread : pthread_t) return Address is + pragma Unreferenced (thread); + begin + return Null_Address; + end Get_Stack_Base; + + ------------------ + -- pthread_init -- + ------------------ + + procedure pthread_init is + begin + null; + end pthread_init; + + ------------------ + -- pthread_self -- + ------------------ + + function pthread_self return pthread_t is + Self : pthread_t; + begin + Asm ("call_pal 0x9e" & ASCII.LF & ASCII.HT & + "bis $31, $0, %0", + Outputs => pthread_t'Asm_Output ("=r", Self), + Clobber => "$0", + Volatile => True); + return Self; + end pthread_self; + + ---------------------- + -- Hide_Yellow_Zone -- + ---------------------- + + procedure Hide_Unhide_Yellow_Zone (Hide : Boolean) is + type Teb_Ptr is access all pthread_teb_t; + Teb : Teb_Ptr; + Res : Interfaces.C.int; + pragma Unreferenced (Res); + + begin + -- Get the Thread Environment Block address + + Asm ("call_pal 0x9e" & ASCII.LF & ASCII.HT & + "bis $31, $0, %0", + Outputs => Teb_Ptr'Asm_Output ("=r", Teb), + Clobber => "$0", + Volatile => True); + + -- Stick a guard page right above the Yellow Zone if it exists + + if Teb.all.stack_yellow /= Teb.all.stack_guard then + Res := + mprotect + (Teb.all.stack_yellow, Get_Page_Size, + prot => (if Hide then PROT_ON else PROT_OFF)); + end if; + end Hide_Unhide_Yellow_Zone; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; + end To_Duration; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return timespec'(tv_sec => S, + tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-tru64.ads b/gcc/ada/s-osinte-tru64.ads new file mode 100644 index 000000000..e893eedb3 --- /dev/null +++ b/gcc/ada/s-osinte-tru64.ads @@ -0,0 +1,592 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Tru64 version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by the tasking run-time (libgnarl). + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; + +with Ada.Unchecked_Conversion; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-lpthread"); + pragma Linker_Options ("-lmach"); + pragma Linker_Options ("-lexc"); + pragma Linker_Options ("-lrt"); + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + subtype char_array is Interfaces.C.char_array; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "_Geterrno"); + + EAGAIN : constant := 35; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIMEDOUT : constant := 60; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 48; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGIOT : constant := 6; -- abort (terminate) process + SIGLOST : constant := 6; -- old BSD signal ?? + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGURG : constant := 16; -- urgent condition on IO channel + SIGIOINT : constant := 16; -- printer to backend error signal + SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 18; -- user stop requested from tty + SIGCONT : constant := 19; -- stopped process has been continued + SIGCHLD : constant := 20; -- child status change + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGPOLL : constant := 23; -- I/O possible, or completed + SIGIO : constant := 23; -- STREAMS version of SIGPOLL + SIGAIO : constant := 23; -- base lan i/o + SIGPTY : constant := 23; -- pty i/o + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 27; -- profiling timer expired + SIGWINCH : constant := 28; -- window size change + SIGINFO : constant := 29; -- information request + SIGPWR : constant := 29; -- Power Fail/Restart -- SVID3/SVR4 + SIGUSR1 : constant := 30; -- user defined signal 1 + SIGUSR2 : constant := 31; -- user defined signal 2 + SIGRESV : constant := 32; -- reserved by Digital for future use + + SIGADAABORT : constant := SIGABRT; + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := (0 .. 0 => SIGTRAP); + Reserved : constant Signal_Set := (SIGALRM, SIGABRT, SIGKILL, SIGSTOP); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset); + + type union_type_3 is new String (1 .. 116); + type siginfo_t is record + si_signo : int; + si_errno : int; + si_code : int; + X_data : union_type_3; + end record; + for siginfo_t'Size use 8 * 128; + pragma Convention (C, siginfo_t); + + type struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; + sa_signo : int; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SIG_BLOCK : constant := 1; + SIG_UNBLOCK : constant := 2; + SIG_SETMASK : constant := 3; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + SA_NODEFER : constant := 8; + SA_SIGINFO : constant := 16#40#; + SA_ONSTACK : constant := 16#01#; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction); + + ---------- + -- Time -- + ---------- + + type timespec is private; + + function nanosleep (rqtp, rmtp : access timespec) return int; + pragma Import (C, nanosleep); + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int; + pragma Import (C, clock_gettime); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timezone is record + tz_minuteswest : int; + tz_dsttime : int; + end record; + pragma Convention (C, struct_timezone); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 1; + SCHED_RR : constant := 2; + SCHED_OTHER : constant := 3; + SCHED_LFI : constant := 5; + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill); + + function getpid return pid_t; + pragma Import (C, getpid); + + BIND_NO_INHERIT : constant := 1; + + function bind_to_cpu + (pid : pid_t; + cpu_mask : unsigned_long; + flag : unsigned_long := BIND_NO_INHERIT) return int; + pragma Import (C, bind_to_cpu); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + pragma Convention (C, Thread_Body); + + function Thread_Body_Access is new + Ada.Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 1; + + PTHREAD_SCOPE_PROCESS : constant := 0; + PTHREAD_SCOPE_SYSTEM : constant := 1; + + PTHREAD_EXPLICIT_SCHED : constant := 1; + + ----------- + -- Stack -- + ----------- + + Stack_Base_Available : constant Boolean := False; + -- Indicates if the stack base is available on this target + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- Returns the stack base of the specified thread. Only call this function + -- when Stack_Base_Available is True. + + function Get_Page_Size return size_t; + function Get_Page_Size return Address; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- Returns the size of a page + + PROT_NONE : constant := 0; + PROT_READ : constant := 1; + PROT_WRITE : constant := 2; + PROT_EXEC : constant := 4; + PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; + + PROT_ON : constant := PROT_READ; + PROT_OFF : constant := PROT_ALL; + + function mprotect (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + procedure Hide_Unhide_Yellow_Zone (Hide : Boolean); + -- Every thread except the initial one features an overflow warning area + -- (called the Yellow Zone) which is just above the overflow guard area + -- on the stack (called the Red Zone). During task execution, we want + -- signals from the Red Zone, so we need to hide the Yellow Zone. This + -- procedure is called at the start of task execution (with Hide set True) + -- to hide the Yellow Zone, and at the end of task execution (with Hide + -- set False) to unhide the Yellow Zone. + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + procedure pthread_init; + pragma Inline (pthread_init); + -- This is a dummy procedure to share some GNULLI files + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Import (C, sigwait, "__sigwaitd10"); + + function pthread_kill + (thread : pthread_t; + sig : Signal) return int; + pragma Import (C, pthread_kill); + + function pthread_sigmask + (how : int; + set : access sigset_t; + oset : access sigset_t) return int; + pragma Import (C, pthread_sigmask); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init (attr : access pthread_mutexattr_t) + return int; + pragma Import (C, pthread_mutexattr_init); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "__pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "__pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "__pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "__pthread_mutex_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "__pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "__pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "__pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "__pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait, "__pthread_cond_timedwait"); + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import (C, pthread_mutexattr_setprioceiling); + + type struct_sched_param is record + sched_priority : int; -- scheduling priority + end record; + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_setschedparam); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import (C, pthread_attr_setinheritsched, + "__pthread_attr_setinheritsched"); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy); + + function pthread_attr_setschedparam + (attr : access pthread_attr_t; + sched_param : access struct_sched_param) return int; + pragma Import (C, pthread_attr_setschedparam); + + function sched_yield return int; + pragma Import (C, sched_yield); + + -------------------------- + -- P1003.1c Section 16 -- + -------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) + return int; + pragma Import (C, pthread_attr_init); + + function pthread_attr_destroy (attributes : access pthread_attr_t) + return int; + pragma Import (C, pthread_attr_destroy); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import (C, pthread_attr_setdetachstate); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize, "__pthread_attr_setstacksize"); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "__pthread_create"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "__pthread_exit"); + + function pthread_self return pthread_t; + pragma Inline (pthread_self); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; value : System.Address) return int; + pragma Import (C, pthread_setspecific, "__pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Import (C, pthread_getspecific, "__pthread_getspecific"); + + type destructor_pointer is access procedure (arg : System.Address); + pragma Convention (C, destructor_pointer); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create); + +private + + type sigset_t is new unsigned_long; + + type pid_t is new int; + + type time_t is new int; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 1; + + type unsigned_long_array is array (Natural range <>) of unsigned_long; + + type pthread_t is new System.Address; + + type pthread_teb_t is record + reserved1 : System.Address; + reserved2 : System.Address; + size : unsigned_short; + version : unsigned_char; + reserved3 : unsigned_char; + external : unsigned_char; + reserved4 : char_array (0 .. 1); + creator : unsigned_char; + sequence : unsigned_long; + reserved5 : unsigned_long_array (0 .. 1); + per_kt_area : System.Address; + stack_base : System.Address; + stack_reserve : System.Address; + stack_yellow : System.Address; + stack_guard : System.Address; + stack_size : unsigned_long; + tsd_values : System.Address; + tsd_count : unsigned_long; + reserved6 : unsigned; + reserved7 : unsigned; + thread_flags : unsigned; + thd_errno : int; + stack_hiwater : System.Address; + home_rad : unsigned_long; + end record; + pragma Convention (C, pthread_teb_t); + + type pthread_cond_t is record + state : unsigned; + valid : unsigned; + name : System.Address; + arg : unsigned; + reserved1 : unsigned; + sequence : unsigned_long; + block : System.Address; + end record; + pragma Convention (C, pthread_cond_t); + + type pthread_attr_t is record + valid : long; + name : System.Address; + arg : unsigned_long; + reserved : unsigned_long_array (0 .. 18); + end record; + pragma Convention (C, pthread_attr_t); + + type pthread_mutex_t is record + lock : unsigned; + valid : unsigned; + name : System.Address; + arg : unsigned; + depth : unsigned; + sequence : unsigned_long; + owner : unsigned_long; + block : System.Address; + end record; + for pthread_mutex_t'Size use 8 * 48; + pragma Convention (C, pthread_mutex_t); + + type pthread_mutexattr_t is record + valid : long; + reserved : unsigned_long_array (0 .. 14); + end record; + pragma Convention (C, pthread_mutexattr_t); + + type pthread_condattr_t is record + valid : long; + reserved : unsigned_long_array (0 .. 12); + end record; + pragma Convention (C, pthread_condattr_t); + + type pthread_key_t is new unsigned; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-vms.adb b/gcc/ada/s-osinte-vms.adb new file mode 100644 index 000000000..a1d04975e --- /dev/null +++ b/gcc/ada/s-osinte-vms.adb @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2009, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a OpenVMS/Alpha version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with Interfaces.C; use Interfaces.C; +with System.Machine_Code; use System.Machine_Code; + +package body System.OS_Interface is + + ------------------ + -- pthread_self -- + ------------------ + + function pthread_self return pthread_t is + use ASCII; + Self : pthread_t; + + begin + Asm ("call_pal 0x9e" & LF & HT & + "bis $31, $0, %0", + Outputs => pthread_t'Asm_Output ("=r", Self), + Clobber => "$0", + Volatile => True); + return Self; + end pthread_self; + + ----------------- + -- sched_yield -- + ----------------- + + function sched_yield return int is + procedure sched_yield_base; + pragma Import (C, sched_yield_base, "PTHREAD_YIELD_NP"); + + begin + sched_yield_base; + return 0; + end sched_yield; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-vms.ads b/gcc/ada/s-osinte-vms.ads new file mode 100644 index 000000000..74f08ea46 --- /dev/null +++ b/gcc/ada/s-osinte-vms.ads @@ -0,0 +1,652 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a OpenVMS/Alpha version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by the tasking run-time (libgnarl). + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; + +with Ada.Unchecked_Conversion; + +with System.Aux_DEC; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("--for-linker=sys$library:pthread$rtl.exe"); + -- Link in the DEC threads library + + -- pragma Linker_Options ("--for-linker=/threads_enable"); + -- Enable upcalls and multiple kernel threads. + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------------------------- + -- Signals (Interrupt IDs) -- + ----------------------------- + + -- Type signal has an arbitrary limit of 31 + + Max_Interrupt : constant := 31; + type Signal is new unsigned range 0 .. Max_Interrupt; + for Signal'Size use unsigned'Size; + + type sigset_t is array (Signal) of Boolean; + pragma Pack (sigset_t); + + -- Interrupt_Number_Type + -- Unsigned long integer denoting the number of an interrupt + + subtype Interrupt_Number_Type is unsigned_long; + + -- OpenVMS system services return values of type Cond_Value_Type + + subtype Cond_Value_Type is unsigned_long; + subtype Short_Cond_Value_Type is unsigned_short; + + type IO_Status_Block_Type is record + Status : Short_Cond_Value_Type; + Count : unsigned_short; + Dev_Info : unsigned_long; + end record; + + type AST_Handler is access procedure (Param : Address); + pragma Convention (C, AST_Handler); + No_AST_Handler : constant AST_Handler := null; + + CMB_M_READONLY : constant := 16#00000001#; + CMB_M_WRITEONLY : constant := 16#00000002#; + AGN_M_READONLY : constant := 16#00000001#; + AGN_M_WRITEONLY : constant := 16#00000002#; + + IO_WRITEVBLK : constant := 48; -- WRITE VIRTUAL BLOCK + IO_READVBLK : constant := 49; -- READ VIRTUAL BLOCK + + ---------------- + -- Sys_Assign -- + ---------------- + -- + -- Assign I/O Channel + -- + -- Status = returned status + -- Devnam = address of device name or logical name string + -- descriptor + -- Chan = address of word to receive channel number assigned + -- Acmode = access mode associated with channel + -- Mbxnam = address of mailbox logical name string descriptor, if + -- mailbox associated with device + -- Flags = optional channel flags longword for specifying options + -- for the $ASSIGN operation + -- + + procedure Sys_Assign + (Status : out Cond_Value_Type; + Devnam : String; + Chan : out unsigned_short; + Acmode : unsigned_short := 0; + Mbxnam : String := String'Null_Parameter; + Flags : unsigned_long := 0); + pragma Interface (External, Sys_Assign); + pragma Import_Valued_Procedure + (Sys_Assign, "SYS$ASSIGN", + (Cond_Value_Type, String, unsigned_short, + unsigned_short, String, unsigned_long), + (Value, Descriptor (s), Reference, + Value, Descriptor (s), Value), + Flags); + + ---------------- + -- Sys_Cantim -- + ---------------- + -- + -- Cancel Timer + -- + -- Status = returned status + -- Reqidt = ID of timer to be cancelled + -- Acmode = Access mode + -- + procedure Sys_Cantim + (Status : out Cond_Value_Type; + Reqidt : Address; + Acmode : unsigned); + pragma Interface (External, Sys_Cantim); + pragma Import_Valued_Procedure + (Sys_Cantim, "SYS$CANTIM", + (Cond_Value_Type, Address, unsigned), + (Value, Value, Value)); + + ---------------- + -- Sys_Crembx -- + ---------------- + -- + -- Create mailbox + -- + -- Status = returned status + -- Prmflg = permanent flag + -- Chan = channel + -- Maxmsg = maximum message + -- Bufquo = buufer quote + -- Promsk = protection mast + -- Acmode = access mode + -- Lognam = logical name + -- Flags = flags + -- + procedure Sys_Crembx + (Status : out Cond_Value_Type; + Prmflg : unsigned_char; + Chan : out unsigned_short; + Maxmsg : unsigned_long := 0; + Bufquo : unsigned_long := 0; + Promsk : unsigned_short := 0; + Acmode : unsigned_short := 0; + Lognam : String; + Flags : unsigned_long := 0); + pragma Interface (External, Sys_Crembx); + pragma Import_Valued_Procedure + (Sys_Crembx, "SYS$CREMBX", + (Cond_Value_Type, unsigned_char, unsigned_short, + unsigned_long, unsigned_long, unsigned_short, + unsigned_short, String, unsigned_long), + (Value, Value, Reference, + Value, Value, Value, + Value, Descriptor (s), Value)); + + ------------- + -- Sys_QIO -- + ------------- + -- + -- Queue I/O + -- + -- Status = Returned status of call + -- EFN = event flag to be set when I/O completes + -- Chan = channel + -- Func = function + -- Iosb = I/O status block + -- Astadr = system trap to be generated when I/O completes + -- Astprm = AST parameter + -- P1-6 = optional parameters + + procedure Sys_QIO + (Status : out Cond_Value_Type; + EFN : unsigned_long := 0; + Chan : unsigned_short; + Func : unsigned_long := 0; + Iosb : out IO_Status_Block_Type; + Astadr : AST_Handler := No_AST_Handler; + Astprm : Address := Null_Address; + P1 : unsigned_long := 0; + P2 : unsigned_long := 0; + P3 : unsigned_long := 0; + P4 : unsigned_long := 0; + P5 : unsigned_long := 0; + P6 : unsigned_long := 0); + + procedure Sys_QIO + (Status : out Cond_Value_Type; + EFN : unsigned_long := 0; + Chan : unsigned_short; + Func : unsigned_long := 0; + Iosb : Address := Null_Address; + Astadr : AST_Handler := No_AST_Handler; + Astprm : Address := Null_Address; + P1 : unsigned_long := 0; + P2 : unsigned_long := 0; + P3 : unsigned_long := 0; + P4 : unsigned_long := 0; + P5 : unsigned_long := 0; + P6 : unsigned_long := 0); + + pragma Interface (External, Sys_QIO); + pragma Import_Valued_Procedure + (Sys_QIO, "SYS$QIO", + (Cond_Value_Type, unsigned_long, unsigned_short, unsigned_long, + IO_Status_Block_Type, AST_Handler, Address, + unsigned_long, unsigned_long, unsigned_long, + unsigned_long, unsigned_long, unsigned_long), + (Value, Value, Value, Value, + Reference, Value, Value, + Value, Value, Value, + Value, Value, Value)); + + pragma Import_Valued_Procedure + (Sys_QIO, "SYS$QIO", + (Cond_Value_Type, unsigned_long, unsigned_short, unsigned_long, + Address, AST_Handler, Address, + unsigned_long, unsigned_long, unsigned_long, + unsigned_long, unsigned_long, unsigned_long), + (Value, Value, Value, Value, + Value, Value, Value, + Value, Value, Value, + Value, Value, Value)); + + ---------------- + -- Sys_Setimr -- + ---------------- + -- + -- Set Timer + -- + -- Status = Returned status of call + -- EFN = event flag to be set when timer expires + -- Tim = expiration time + -- AST = system trap to be generated when timer expires + -- Redidt = returned ID of timer (e.g. to cancel timer) + -- Flags = flags + -- + procedure Sys_Setimr + (Status : out Cond_Value_Type; + EFN : unsigned_long; + Tim : Long_Integer; + AST : AST_Handler; + Reqidt : Address; + Flags : unsigned_long); + pragma Interface (External, Sys_Setimr); + pragma Import_Valued_Procedure + (Sys_Setimr, "SYS$SETIMR", + (Cond_Value_Type, unsigned_long, Long_Integer, + AST_Handler, Address, unsigned_long), + (Value, Value, Reference, + Value, Value, Value)); + + Interrupt_ID_0 : constant := 0; + Interrupt_ID_1 : constant := 1; + Interrupt_ID_2 : constant := 2; + Interrupt_ID_3 : constant := 3; + Interrupt_ID_4 : constant := 4; + Interrupt_ID_5 : constant := 5; + Interrupt_ID_6 : constant := 6; + Interrupt_ID_7 : constant := 7; + Interrupt_ID_8 : constant := 8; + Interrupt_ID_9 : constant := 9; + Interrupt_ID_10 : constant := 10; + Interrupt_ID_11 : constant := 11; + Interrupt_ID_12 : constant := 12; + Interrupt_ID_13 : constant := 13; + Interrupt_ID_14 : constant := 14; + Interrupt_ID_15 : constant := 15; + Interrupt_ID_16 : constant := 16; + Interrupt_ID_17 : constant := 17; + Interrupt_ID_18 : constant := 18; + Interrupt_ID_19 : constant := 19; + Interrupt_ID_20 : constant := 20; + Interrupt_ID_21 : constant := 21; + Interrupt_ID_22 : constant := 22; + Interrupt_ID_23 : constant := 23; + Interrupt_ID_24 : constant := 24; + Interrupt_ID_25 : constant := 25; + Interrupt_ID_26 : constant := 26; + Interrupt_ID_27 : constant := 27; + Interrupt_ID_28 : constant := 28; + Interrupt_ID_29 : constant := 29; + Interrupt_ID_30 : constant := 30; + Interrupt_ID_31 : constant := 31; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EINTR : constant := 4; -- Interrupted system call + EAGAIN : constant := 11; -- No more processes + ENOMEM : constant := 12; -- Not enough core + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 1; + SCHED_RR : constant := 2; + SCHED_OTHER : constant := 3; + SCHED_BG : constant := 4; + SCHED_LFI : constant := 5; + SCHED_LRR : constant := 6; + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill); + + function getpid return pid_t; + pragma Import (C, getpid); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + pragma Convention (C, Thread_Body); + + function Thread_Body_Access is new + Ada.Unchecked_Conversion (System.Aux_DEC.Short_Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_JOINABLE : constant := 0; + PTHREAD_CREATE_DETACHED : constant := 1; + + PTHREAD_CANCEL_DISABLE : constant := 0; + PTHREAD_CANCEL_ENABLE : constant := 1; + + PTHREAD_CANCEL_DEFERRED : constant := 0; + PTHREAD_CANCEL_ASYNCHRONOUS : constant := 1; + + -- Don't use ERRORCHECK mutexes, they don't work when a thread is not + -- the owner. AST's, at least, unlock others threads mutexes. Even + -- if the error is ignored, they don't work. + PTHREAD_MUTEX_NORMAL_NP : constant := 0; + PTHREAD_MUTEX_RECURSIVE_NP : constant := 1; + PTHREAD_MUTEX_ERRORCHECK_NP : constant := 2; + + PTHREAD_INHERIT_SCHED : constant := 0; + PTHREAD_EXPLICIT_SCHED : constant := 1; + + function pthread_cancel (thread : pthread_t) return int; + pragma Import (C, pthread_cancel, "PTHREAD_CANCEL"); + + procedure pthread_testcancel; + pragma Import (C, pthread_testcancel, "PTHREAD_TESTCANCEL"); + + function pthread_setcancelstate + (newstate : int; oldstate : access int) return int; + pragma Import (C, pthread_setcancelstate, "PTHREAD_SETCANCELSTATE"); + + function pthread_setcanceltype + (newtype : int; oldtype : access int) return int; + pragma Import (C, pthread_setcanceltype, "PTHREAD_SETCANCELTYPE"); + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function pthread_lock_global_np return int; + pragma Import (C, pthread_lock_global_np, "PTHREAD_LOCK_GLOBAL_NP"); + + function pthread_unlock_global_np return int; + pragma Import (C, pthread_unlock_global_np, "PTHREAD_UNLOCK_GLOBAL_NP"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "PTHREAD_MUTEXATTR_INIT"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "PTHREAD_MUTEXATTR_DESTROY"); + + function pthread_mutexattr_settype_np + (attr : access pthread_mutexattr_t; + mutextype : int) return int; + pragma Import (C, pthread_mutexattr_settype_np, + "PTHREAD_MUTEXATTR_SETTYPE_NP"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "PTHREAD_MUTEX_INIT"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "PTHREAD_MUTEX_DESTROY"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "PTHREAD_MUTEX_LOCK"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "PTHREAD_MUTEX_UNLOCK"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "PTHREAD_CONDATTR_INIT"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "PTHREAD_CONDATTR_DESTROY"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "PTHREAD_COND_INIT"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "PTHREAD_COND_DESTROY"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "PTHREAD_COND_SIGNAL"); + + function pthread_cond_signal_int_np + (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal_int_np, + "PTHREAD_COND_SIGNAL_INT_NP"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "PTHREAD_COND_WAIT"); + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol, + "PTHREAD_MUTEXATTR_SETPROTOCOL"); + + type struct_sched_param is record + sched_priority : int; -- scheduling priority + end record; + for struct_sched_param'Size use 8*4; + pragma Convention (C, struct_sched_param); + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_setschedparam, "PTHREAD_SETSCHEDPARAM"); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "PTHREAD_ATTR_SETSCOPE"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import (C, pthread_attr_setinheritsched, + "PTHREAD_ATTR_SETINHERITSCHED"); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy, + "PTHREAD_ATTR_SETSCHEDPOLICY"); + + function pthread_attr_setschedparam + (attr : access pthread_attr_t; + sched_param : int) return int; + pragma Import (C, pthread_attr_setschedparam, "PTHREAD_ATTR_SETSCHEDPARAM"); + + function sched_yield return int; + + -------------------------- + -- P1003.1c Section 16 -- + -------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "PTHREAD_ATTR_INIT"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "PTHREAD_ATTR_DESTROY"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import (C, pthread_attr_setdetachstate, + "PTHREAD_ATTR_SETDETACHSTATE"); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize, "PTHREAD_ATTR_SETSTACKSIZE"); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "PTHREAD_CREATE"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "PTHREAD_EXIT"); + + function pthread_self return pthread_t; + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "PTHREAD_SETSPECIFIC"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Import (C, pthread_getspecific, "PTHREAD_GETSPECIFIC"); + + type destructor_pointer is access procedure (arg : System.Address); + pragma Convention (C, destructor_pointer); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "PTHREAD_KEY_CREATE"); + +private + + type pid_t is new int; + + type pthreadLongAddr_p is mod 2 ** Long_Integer'Size; + + type pthreadLongAddr_t is mod 2 ** Long_Integer'Size; + type pthreadLongAddr_t_ptr is mod 2 ** Long_Integer'Size; + + type pthreadLongString_t is mod 2 ** Long_Integer'Size; + + type pthreadLongUint_t is mod 2 ** Long_Integer'Size; + type pthreadLongUint_array is array (Natural range <>) + of pthreadLongUint_t; + + type pthread_t is mod 2 ** Long_Integer'Size; + + type pthread_cond_t is record + state : unsigned; + valid : unsigned; + name : pthreadLongString_t; + arg : unsigned; + sequence : unsigned; + block : pthreadLongAddr_t_ptr; + end record; + for pthread_cond_t'Size use 8*32; + pragma Convention (C, pthread_cond_t); + + type pthread_attr_t is record + valid : long; + name : pthreadLongString_t; + arg : pthreadLongUint_t; + reserved : pthreadLongUint_array (0 .. 18); + end record; + for pthread_attr_t'Size use 8*176; + pragma Convention (C, pthread_attr_t); + + type pthread_mutex_t is record + lock : unsigned; + valid : unsigned; + name : pthreadLongString_t; + arg : unsigned; + sequence : unsigned; + block : pthreadLongAddr_p; + owner : unsigned; + depth : unsigned; + end record; + for pthread_mutex_t'Size use 8*40; + pragma Convention (C, pthread_mutex_t); + + type pthread_mutexattr_t is record + valid : long; + reserved : pthreadLongUint_array (0 .. 14); + end record; + for pthread_mutexattr_t'Size use 8*128; + pragma Convention (C, pthread_mutexattr_t); + + type pthread_condattr_t is record + valid : long; + reserved : pthreadLongUint_array (0 .. 12); + end record; + for pthread_condattr_t'Size use 8*112; + pragma Convention (C, pthread_condattr_t); + + type pthread_key_t is new unsigned; + + pragma Inline (pthread_self); + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-vxworks.adb b/gcc/ada/s-osinte-vxworks.adb new file mode 100644 index 000000000..c3b281447 --- /dev/null +++ b/gcc/ada/s-osinte-vxworks.adb @@ -0,0 +1,252 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2010, 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 VxWorks version + +-- This package encapsulates all direct interfaces to OS services that are +-- needed by children of System. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +package body System.OS_Interface is + + use type Interfaces.C.int; + + Low_Priority : constant := 255; + -- VxWorks native (default) lowest scheduling priority + + ------------- + -- sigwait -- + ------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int + is + Result : int; + + function sigwaitinfo + (set : access sigset_t; sigvalue : System.Address) return int; + pragma Import (C, sigwaitinfo, "sigwaitinfo"); + + begin + Result := sigwaitinfo (set, System.Null_Address); + + if Result /= -1 then + sig.all := Signal (Result); + return OK; + else + sig.all := 0; + return errno; + end if; + end sigwait; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9; + end To_Duration; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F is negative 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'(ts_sec => S, + ts_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ------------------------- + -- To_VxWorks_Priority -- + ------------------------- + + function To_VxWorks_Priority (Priority : int) return int is + begin + return Low_Priority - Priority; + end To_VxWorks_Priority; + + -------------------- + -- To_Clock_Ticks -- + -------------------- + + -- ??? - For now, we'll always get the system clock rate since it is + -- allowed to be changed during run-time in VxWorks. A better method would + -- be to provide an operation to set it that so we can always know its + -- value. + + -- Another thing we should probably allow for is a resultant tick count + -- greater than int'Last. This should probably be a procedure with two + -- output parameters, one in the range 0 .. int'Last, and another + -- representing the overflow count. + + 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 ERROR; + 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; + + ----------------------------- + -- Binary_Semaphore_Create -- + ----------------------------- + + function Binary_Semaphore_Create return Binary_Semaphore_Id is + begin + return Binary_Semaphore_Id (semBCreate (SEM_Q_FIFO, SEM_EMPTY)); + end Binary_Semaphore_Create; + + ----------------------------- + -- Binary_Semaphore_Delete -- + ----------------------------- + + function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int is + begin + return semDelete (SEM_ID (ID)); + end Binary_Semaphore_Delete; + + ----------------------------- + -- Binary_Semaphore_Obtain -- + ----------------------------- + + function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int is + begin + return semTake (SEM_ID (ID), WAIT_FOREVER); + end Binary_Semaphore_Obtain; + + ------------------------------ + -- Binary_Semaphore_Release -- + ------------------------------ + + function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int is + begin + return semGive (SEM_ID (ID)); + end Binary_Semaphore_Release; + + ---------------------------- + -- Binary_Semaphore_Flush -- + ---------------------------- + + function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int is + begin + return semFlush (SEM_ID (ID)); + end Binary_Semaphore_Flush; + + ---------- + -- kill -- + ---------- + + function kill (pid : t_id; sig : Signal) return int is + begin + return System.VxWorks.Ext.kill (pid, int (sig)); + end kill; + + ----------------------- + -- Interrupt_Connect -- + ----------------------- + + function Interrupt_Connect + (Vector : Interrupt_Vector; + Handler : Interrupt_Handler; + Parameter : System.Address := System.Null_Address) return int is + begin + return + System.VxWorks.Ext.Interrupt_Connect + (System.VxWorks.Ext.Interrupt_Vector (Vector), + System.VxWorks.Ext.Interrupt_Handler (Handler), + Parameter); + end Interrupt_Connect; + + ----------------------- + -- Interrupt_Context -- + ----------------------- + + function Interrupt_Context return int is + begin + return System.VxWorks.Ext.Interrupt_Context; + end Interrupt_Context; + + -------------------------------- + -- Interrupt_Number_To_Vector -- + -------------------------------- + + function Interrupt_Number_To_Vector + (intNum : int) return Interrupt_Vector is + begin + return Interrupt_Vector + (System.VxWorks.Ext.Interrupt_Number_To_Vector (intNum)); + end Interrupt_Number_To_Vector; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-vxworks.ads b/gcc/ada/s-osinte-vxworks.ads new file mode 100644 index 000000000..0fc4c13e9 --- /dev/null +++ b/gcc/ada/s-osinte-vxworks.ads @@ -0,0 +1,506 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VxWorks version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by the tasking run-time (libgnarl). + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; +with System.VxWorks; +with System.VxWorks.Ext; + +package System.OS_Interface is + pragma Preelaborate; + + subtype int is Interfaces.C.int; + subtype short is Short_Integer; + type unsigned_int is mod 2 ** int'Size; + type long is new Long_Integer; + type unsigned_long is mod 2 ** long'Size; + type long_long is new Long_Long_Integer; + type unsigned_long_long is mod 2 ** long_long'Size; + type size_t is mod 2 ** Standard'Address_Size; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "errnoGet"); + + EINTR : constant := 4; + EAGAIN : constant := 35; + ENOMEM : constant := 12; + EINVAL : constant := 22; + ETIMEDOUT : constant := 60; + + FUNC_ERR : constant := -1; + + ---------------------------- + -- Signals and interrupts -- + ---------------------------- + + NSIG : constant := 64; + -- Number of signals on the target OS + type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1); + + Max_HW_Interrupt : constant := System.VxWorks.Num_HW_Interrupts - 1; + type HW_Interrupt is new int range 0 .. Max_HW_Interrupt; + + Max_Interrupt : constant := Max_HW_Interrupt; + + -- Signals common to Vxworks 5.x and 6.x + + SIGILL : constant := 4; -- illegal instruction (not reset when caught) + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGFPE : constant := 8; -- floating point exception + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + + -- Signals specific to VxWorks 6.x + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt + SIGQUIT : constant := 3; -- quit + SIGTRAP : constant := 5; -- trace trap (not reset when caught) + SIGEMT : constant := 7; -- EMT instruction + SIGKILL : constant := 9; -- kill + SIGFMT : constant := 12; -- STACK FORMAT ERROR (not posix) + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGCNCL : constant := 16; -- pthreads cancellation signal + SIGSTOP : constant := 17; -- sendable stop signal not from tty + SIGTSTP : constant := 18; -- stop signal from tty + SIGCONT : constant := 19; -- continue a stopped process + SIGCHLD : constant := 20; -- to parent on child stop or exit + SIGTTIN : constant := 21; -- to readers pgrp upon background tty read + SIGTTOU : constant := 22; -- like TTIN for output + + SIGRES1 : constant := 23; -- reserved signal number (Not POSIX) + SIGRES2 : constant := 24; -- reserved signal number (Not POSIX) + SIGRES3 : constant := 25; -- reserved signal number (Not POSIX) + SIGRES4 : constant := 26; -- reserved signal number (Not POSIX) + SIGRES5 : constant := 27; -- reserved signal number (Not POSIX) + SIGRES6 : constant := 28; -- reserved signal number (Not POSIX) + SIGRES7 : constant := 29; -- reserved signal number (Not POSIX) + + SIGUSR1 : constant := 30; -- user defined signal 1 + SIGUSR2 : constant := 31; -- user defined signal 2 + + SIGPOLL : constant := 32; -- pollable event + SIGPROF : constant := 33; -- profiling timer expired + SIGSYS : constant := 34; -- bad system call + SIGURG : constant := 35; -- high bandwidth data is available at socket + SIGVTALRM : constant := 36; -- virtual timer expired + SIGXCPU : constant := 37; -- CPU time limit exceeded + SIGXFSZ : constant := 38; -- file size time limit exceeded + + SIGEVTS : constant := 39; -- signal event thread send + SIGEVTD : constant := 40; -- signal event thread delete + + SIGRTMIN : constant := 48; -- Realtime signal min + SIGRTMAX : constant := 63; -- Realtime signal max + + ----------------------------------- + -- Signal processing definitions -- + ----------------------------------- + + -- The how in sigprocmask() + + SIG_BLOCK : constant := 1; + SIG_UNBLOCK : constant := 2; + SIG_SETMASK : constant := 3; + + -- The sa_flags in struct sigaction + + SA_SIGINFO : constant := 16#0002#; + SA_ONSTACK : constant := 16#0004#; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + type sigset_t is private; + + type struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + type isr_address is access procedure (sig : int); + pragma Convention (C, isr_address); + + function c_signal (sig : Signal; handler : isr_address) return isr_address; + pragma Import (C, c_signal, "signal"); + + function sigwait (set : access sigset_t; sig : access Signal) return int; + pragma Inline (sigwait); + + function pthread_sigmask + (how : int; + set : access sigset_t; + oset : access sigset_t) return int; + pragma Import (C, pthread_sigmask, "sigprocmask"); + + subtype t_id is System.VxWorks.Ext.t_id; + subtype Thread_Id is t_id; + + function kill (pid : t_id; sig : Signal) return int; + pragma Inline (kill); + + function getpid return t_id renames System.VxWorks.Ext.getpid; + + function Task_Stop (tid : t_id) return int + renames System.VxWorks.Ext.Task_Stop; + -- If we are in the kernel space, stop the task whose t_id is + -- given in parameter in such a way that it can be examined by the + -- debugger. This typically maps to taskSuspend on VxWorks 5 and + -- to taskStop on VxWorks 6. + + function Task_Cont (tid : t_id) return int + renames System.VxWorks.Ext.Task_Cont; + -- If we are in the kernel space, continue the task whose t_id is + -- given in parameter if it has been stopped previously to be examined + -- by the debugger (e.g. by taskStop). It typically maps to taskResume + -- on VxWorks 5 and to taskCont on VxWorks 6. + + function Int_Lock return int renames System.VxWorks.Ext.Int_Lock; + -- If we are in the kernel space, lock interrupts. It typically maps to + -- intLock. + + function Int_Unlock return int renames System.VxWorks.Ext.Int_Unlock; + -- If we are in the kernel space, unlock interrupts. It typically maps to + -- intUnlock. + + ---------- + -- Time -- + ---------- + + type time_t is new unsigned_long; + + type timespec is record + ts_sec : time_t; + ts_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; -- System wide realtime clock + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + function To_Clock_Ticks (D : Duration) return int; + -- Convert a duration value (in seconds) into clock ticks + + function clock_gettime + (clock_id : clockid_t; tp : access timespec) return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + ---------------------- + -- Utility Routines -- + ---------------------- + + function To_VxWorks_Priority (Priority : int) return int; + pragma Inline (To_VxWorks_Priority); + -- Convenience routine to convert between VxWorks priority and Ada priority + + -------------------------- + -- VxWorks specific API -- + -------------------------- + + subtype STATUS is int; + -- Equivalent of the C type STATUS + + OK : constant STATUS := 0; + ERROR : constant STATUS := Interfaces.C.int (-1); + + function taskIdVerify (tid : t_id) return STATUS; + pragma Import (C, taskIdVerify, "taskIdVerify"); + + function taskIdSelf return t_id; + pragma Import (C, taskIdSelf, "taskIdSelf"); + + function taskOptionsGet (tid : t_id; pOptions : access int) return int; + pragma Import (C, taskOptionsGet, "taskOptionsGet"); + + function taskSuspend (tid : t_id) return int; + pragma Import (C, taskSuspend, "taskSuspend"); + + function taskResume (tid : t_id) return int; + pragma Import (C, taskResume, "taskResume"); + + function taskIsSuspended (tid : t_id) return int; + pragma Import (C, taskIsSuspended, "taskIsSuspended"); + + function taskDelay (ticks : int) return int; + procedure taskDelay (ticks : int); + pragma Import (C, taskDelay, "taskDelay"); + + function sysClkRateGet return int; + pragma Import (C, sysClkRateGet, "sysClkRateGet"); + + -- VxWorks 5.x specific functions + -- Must not be called from run-time for versions that do not support + -- taskVarLib: eg VxWorks 6 RTPs + + function taskVarAdd + (tid : t_id; pVar : access System.Address) return int; + pragma Import (C, taskVarAdd, "taskVarAdd"); + + function taskVarDelete + (tid : t_id; pVar : access System.Address) return int; + pragma Import (C, taskVarDelete, "taskVarDelete"); + + function taskVarSet + (tid : t_id; + pVar : access System.Address; + value : System.Address) return int; + pragma Import (C, taskVarSet, "taskVarSet"); + + function taskVarGet + (tid : t_id; + pVar : access System.Address) return int; + pragma Import (C, taskVarGet, "taskVarGet"); + + -- VxWorks 6.x specific functions + -- Can only be called from the VxWorks 6 run-time libary that supports + -- tlsLib, and not by the VxWorks 6.6 SMP library + + function tlsKeyCreate return int; + pragma Import (C, tlsKeyCreate, "tlsKeyCreate"); + + function tlsValueGet (key : int) return System.Address; + pragma Import (C, tlsValueGet, "tlsValueGet"); + + function tlsValueSet (key : int; value : System.Address) return STATUS; + pragma Import (C, tlsValueSet, "tlsValueSet"); + + -- Option flags for taskSpawn + + VX_UNBREAKABLE : constant := 16#0002#; + VX_FP_PRIVATE_ENV : constant := 16#0080#; + VX_NO_STACK_FILL : constant := 16#0100#; + + function taskSpawn + (name : System.Address; -- Pointer to task name + priority : int; + options : int; + stacksize : size_t; + start_routine : System.Address; + arg1 : System.Address; + arg2 : int := 0; + arg3 : int := 0; + arg4 : int := 0; + arg5 : int := 0; + arg6 : int := 0; + arg7 : int := 0; + arg8 : int := 0; + arg9 : int := 0; + arg10 : int := 0) return t_id; + pragma Import (C, taskSpawn, "taskSpawn"); + + procedure taskDelete (tid : t_id); + pragma Import (C, taskDelete, "taskDelete"); + + function Set_Time_Slice (ticks : int) return int + renames System.VxWorks.Ext.Set_Time_Slice; + -- Calls kernelTimeSlice under VxWorks 5.x, VxWorks 653, or in VxWorks 6 + -- kernel apps. Returns ERROR for RTPs, VxWorks 5 /CERT + + function taskPriorityGet (tid : t_id; pPriority : access int) return int; + pragma Import (C, taskPriorityGet, "taskPriorityGet"); + + function taskPrioritySet (tid : t_id; newPriority : int) return int; + pragma Import (C, taskPrioritySet, "taskPrioritySet"); + + -- Semaphore creation flags + + SEM_Q_FIFO : constant := 0; + SEM_Q_PRIORITY : constant := 1; + SEM_DELETE_SAFE : constant := 4; -- only valid for binary semaphore + SEM_INVERSION_SAFE : constant := 8; -- only valid for binary semaphore + + -- Semaphore initial state flags + + SEM_EMPTY : constant := 0; + SEM_FULL : constant := 1; + + -- Semaphore take (semTake) time constants + + WAIT_FOREVER : constant := -1; + NO_WAIT : constant := 0; + + -- Error codes (errno). The lower level 16 bits are the error code, with + -- the upper 16 bits representing the module number in which the error + -- occurred. By convention, the module number is 0 for UNIX errors. VxWorks + -- reserves module numbers 1-500, with the remaining module numbers being + -- available for user applications. + + M_objLib : constant := 61 * 2**16; + -- semTake() failure with ticks = NO_WAIT + S_objLib_OBJ_UNAVAILABLE : constant := M_objLib + 2; + -- semTake() timeout with ticks > NO_WAIT + S_objLib_OBJ_TIMEOUT : constant := M_objLib + 4; + + subtype SEM_ID is System.VxWorks.Ext.SEM_ID; + -- typedef struct semaphore *SEM_ID; + + -- We use two different kinds of VxWorks semaphores: mutex and binary + -- semaphores. A null ID is returned when a semaphore cannot be created. + + function semBCreate (options : int; initial_state : int) return SEM_ID; + pragma Import (C, semBCreate, "semBCreate"); + -- Create a binary semaphore. Return ID, or 0 if memory could not + -- be allocated. + + function semMCreate (options : int) return SEM_ID; + pragma Import (C, semMCreate, "semMCreate"); + + function semDelete (Sem : SEM_ID) return int + renames System.VxWorks.Ext.semDelete; + -- Delete a semaphore + + function semGive (Sem : SEM_ID) return int; + pragma Import (C, semGive, "semGive"); + + function semTake (Sem : SEM_ID; timeout : int) return int; + pragma Import (C, semTake, "semTake"); + -- Attempt to take binary semaphore. Error is returned if operation + -- times out + + function semFlush (SemID : SEM_ID) return STATUS; + pragma Import (C, semFlush, "semFlush"); + -- Release all threads blocked on the semaphore + + ------------------------------------------------------------ + -- Binary Semaphore Wrapper to Support interrupt Tasks -- + ------------------------------------------------------------ + + type Binary_Semaphore_Id is new Long_Integer; + + function Binary_Semaphore_Create return Binary_Semaphore_Id; + pragma Inline (Binary_Semaphore_Create); + + function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int; + pragma Inline (Binary_Semaphore_Delete); + + function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int; + pragma Inline (Binary_Semaphore_Obtain); + + function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int; + pragma Inline (Binary_Semaphore_Release); + + function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int; + pragma Inline (Binary_Semaphore_Flush); + + ------------------------------------------------------------ + -- Hardware Interrupt Wrappers to Support Interrupt Tasks -- + ------------------------------------------------------------ + + type Interrupt_Handler is access procedure (parameter : System.Address); + pragma Convention (C, Interrupt_Handler); + + type Interrupt_Vector is new System.Address; + + function Interrupt_Connect + (Vector : Interrupt_Vector; + Handler : Interrupt_Handler; + Parameter : System.Address := System.Null_Address) return int; + pragma Inline (Interrupt_Connect); + -- Use this to set up an user handler. The routine installs a user + -- handler which is invoked after the OS has saved enough context for a + -- high-level language routine to be safely invoked. + + function Interrupt_Context return int; + pragma Inline (Interrupt_Context); + -- Return 1 if executing in an interrupt context; return 0 if executing in + -- a task context. + + function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector; + pragma Inline (Interrupt_Number_To_Vector); + -- Convert a logical interrupt number to the hardware interrupt vector + -- number used to connect the interrupt. + + -------------------------------- + -- Processor Affinity for SMP -- + -------------------------------- + + function taskCpuAffinitySet (tid : t_id; CPU : int) return int + renames System.VxWorks.Ext.taskCpuAffinitySet; + -- For SMP run-times the affinity to CPU. + -- For uniprocessor systems return ERROR status. + +private + type pid_t is new int; + + ERROR_PID : constant pid_t := -1; + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 0; + + type sigset_t is new System.VxWorks.Ext.sigset_t; +end System.OS_Interface; diff --git a/gcc/ada/s-osprim-darwin.adb b/gcc/ada/s-osprim-darwin.adb new file mode 100644 index 000000000..d47c608a7 --- /dev/null +++ b/gcc/ada/s-osprim-darwin.adb @@ -0,0 +1,175 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, 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; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration renames 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 new file mode 100644 index 000000000..6c05b524f --- /dev/null +++ b/gcc/ada/s-osprim-mingw.adb @@ -0,0 +1,342 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the NT version of this package + +with System.Win32.Ext; + +package body System.OS_Primitives is + + use System.Win32; + use System.Win32.Ext; + + ---------------------------------------- + -- Data for the high resolution clock -- + ---------------------------------------- + + -- Declare some pointers to access multi-word data above. This is needed + -- to workaround a limitation in the GNU/Linker auto-import feature used + -- to build the GNAT runtime DLLs. In fact the Clock and Monotonic_Clock + -- routines are inlined and they are using some multi-word variables. + -- GNU/Linker will fail to auto-import those variables when building + -- libgnarl.dll. The indirection level introduced here has no measurable + -- penalties. + + -- Note that access variables below must not be declared as constant + -- otherwise the compiler optimization will remove this indirect access. + + type DA is access all Duration; + -- Use to have indirect access to multi-word variables + + type LIA is access all LARGE_INTEGER; + -- Use to have indirect access to multi-word variables + + type LLIA is access all Long_Long_Integer; + -- Use to have indirect access to multi-word variables + + Tick_Frequency : aliased LARGE_INTEGER; + TFA : constant LIA := Tick_Frequency'Access; + -- Holds frequency of high-performance counter used by Clock + -- Windows NT uses a 1_193_182 Hz counter on PCs. + + Base_Ticks : aliased LARGE_INTEGER; + BTA : constant LIA := Base_Ticks'Access; + -- Holds the Tick count for the base time + + Base_Monotonic_Ticks : aliased LARGE_INTEGER; + BMTA : constant LIA := Base_Monotonic_Ticks'Access; + -- Holds the Tick count for the base monotonic time + + Base_Clock : aliased Duration; + BCA : constant DA := Base_Clock'Access; + -- Holds the current clock for the standard clock's base time + + Base_Monotonic_Clock : aliased Duration; + BMCA : constant DA := Base_Monotonic_Clock'Access; + -- Holds the current clock for monotonic clock's base time + + Base_Time : aliased Long_Long_Integer; + BTiA : constant LLIA := Base_Time'Access; + -- Holds the base time used to check for system time change, used with + -- the standard clock. + + procedure Get_Base_Time; + -- 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; + Current_Ticks : aliased LARGE_INTEGER; + Elap_Secs_Tick : Duration; + Elap_Secs_Sys : Duration; + Now : aliased Long_Long_Integer; + + begin + 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 - BTiA.all)) / + Hundreds_Nano_In_Sec); + + Elap_Secs_Tick := + Duration (Long_Long_Float (Current_Ticks - BTA.all) / + Long_Long_Float (TFA.all)); + + -- If we have a shift of more than Max_Shift seconds we resynchronize + -- the Clock. This is probably due to a manual Clock adjustment, an + -- 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; + + Elap_Secs_Tick := + Duration (Long_Long_Float (Current_Ticks - BTA.all) / + Long_Long_Float (TFA.all)); + end if; + + return BCA.all + Elap_Secs_Tick; + end Clock; + + ------------------- + -- Get_Base_Time -- + ------------------- + + procedure Get_Base_Time 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 + + 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; + + 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 10th times to reach the best synchronisation (below 1 + -- millisecond) otherwise the runtime will use the best value reached + -- during the runs. + + 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 + Base_Time := Loc_Time; + 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; + + Base_Clock := Duration + (Long_Long_Float ((Base_Time - epoch_1970) * system_time_ns) / + Long_Long_Float (Sec_Unit)); + 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 - BMTA.all) / + Long_Long_Float (TFA.all)); + return BMCA.all + 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; + + -- 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 := Base_Clock; + Base_Monotonic_Ticks := Base_Ticks; + end Initialize; + +end System.OS_Primitives; diff --git a/gcc/ada/s-osprim-posix.adb b/gcc/ada/s-osprim-posix.adb new file mode 100644 index 000000000..e03a132c8 --- /dev/null +++ b/gcc/ada/s-osprim-posix.adb @@ -0,0 +1,173 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 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 .. 2) of 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; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration renames 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 new file mode 100644 index 000000000..d629b4b9e --- /dev/null +++ b/gcc/ada/s-osprim-solaris.adb @@ -0,0 +1,132 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 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; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration renames 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 new file mode 100644 index 000000000..973ce0325 --- /dev/null +++ b/gcc/ada/s-osprim-unix.adb @@ -0,0 +1,132 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 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; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration renames 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-vms.adb b/gcc/ada/s-osprim-vms.adb new file mode 100644 index 000000000..c08b4fe89 --- /dev/null +++ b/gcc/ada/s-osprim-vms.adb @@ -0,0 +1,209 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the OpenVMS/Alpha version of this file + +with System.Aux_DEC; + +package body System.OS_Primitives is + + -------------------------------------- + -- Local functions and declarations -- + -------------------------------------- + + function Get_GMToff return Integer; + pragma Import (C, Get_GMToff, "get_gmtoff"); + -- Get the offset from GMT for this timezone + + function VMS_Epoch_Offset return Long_Integer; + pragma Inline (VMS_Epoch_Offset); + -- The offset between the Unix Epoch and the VMS Epoch + + subtype Cond_Value_Type is System.Aux_DEC.Unsigned_Longword; + -- Condition Value return type + + ---------------------- + -- VMS_Epoch_Offset -- + ---------------------- + + function VMS_Epoch_Offset return Long_Integer is + begin + return 10_000_000 * (3_506_716_800 + Long_Integer (Get_GMToff)); + end VMS_Epoch_Offset; + + ---------------- + -- Sys_Schdwk -- + ---------------- + -- + -- Schedule Wakeup + -- + -- status = returned status + -- pidadr = address of process id to be woken up + -- prcnam = name of process to be woken up + -- daytim = time to wake up + -- reptim = repetition interval of wakeup calls + -- + + procedure Sys_Schdwk + ( + Status : out Cond_Value_Type; + Pidadr : Address := Null_Address; + Prcnam : String := String'Null_Parameter; + Daytim : Long_Integer; + Reptim : Long_Integer := Long_Integer'Null_Parameter + ); + + pragma Interface (External, Sys_Schdwk); + -- VMS system call to schedule a wakeup event + pragma Import_Valued_Procedure + (Sys_Schdwk, "SYS$SCHDWK", + (Cond_Value_Type, Address, String, Long_Integer, Long_Integer), + (Value, Value, Descriptor (S), Reference, Reference) + ); + + ---------------- + -- Sys_Gettim -- + ---------------- + -- + -- Get System Time + -- + -- status = returned status + -- tim = current system time + -- + + procedure Sys_Gettim + ( + Status : out Cond_Value_Type; + Tim : out OS_Time + ); + -- VMS system call to get the current system time + pragma Interface (External, Sys_Gettim); + pragma Import_Valued_Procedure + (Sys_Gettim, "SYS$GETTIM", + (Cond_Value_Type, OS_Time), + (Value, Reference) + ); + + --------------- + -- Sys_Hiber -- + --------------- + + -- Hibernate (until woken up) + + -- status = returned status + + procedure Sys_Hiber (Status : out Cond_Value_Type); + -- VMS system call to hibernate the current process + pragma Interface (External, Sys_Hiber); + pragma Import_Valued_Procedure + (Sys_Hiber, "SYS$HIBER", + (Cond_Value_Type), + (Value) + ); + + ----------- + -- Clock -- + ----------- + + function OS_Clock return OS_Time is + Status : Cond_Value_Type; + T : OS_Time; + begin + Sys_Gettim (Status, T); + return (T); + end OS_Clock; + + ----------- + -- Clock -- + ----------- + + function Clock return Duration is + begin + return To_Duration (OS_Clock, Absolute_Calendar); + end Clock; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + null; + end Initialize; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration renames Clock; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Time : Duration; + Mode : Integer) + is + Sleep_Time : OS_Time; + Status : Cond_Value_Type; + pragma Unreferenced (Status); + + begin + Sleep_Time := To_OS_Time (Time, Mode); + Sys_Schdwk (Status => Status, Daytim => Sleep_Time); + Sys_Hiber (Status); + end Timed_Delay; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (T : OS_Time; Mode : Integer) return Duration is + pragma Warnings (Off, Mode); + begin + return Duration'Fixed_Value (T - VMS_Epoch_Offset) * 100; + end To_Duration; + + ---------------- + -- To_OS_Time -- + ---------------- + + function To_OS_Time (D : Duration; Mode : Integer) return OS_Time is + begin + if Mode = Relative then + return -(Long_Integer'Integer_Value (D) / 100); + else + return Long_Integer'Integer_Value (D) / 100 + VMS_Epoch_Offset; + end if; + end To_OS_Time; + +end System.OS_Primitives; diff --git a/gcc/ada/s-osprim-vms.ads b/gcc/ada/s-osprim-vms.ads new file mode 100644 index 000000000..3b4ed328c --- /dev/null +++ b/gcc/ada/s-osprim-vms.ads @@ -0,0 +1,110 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 low level primitives used to implement clock and +-- delays in non tasking applications on Alpha/VMS. + +-- 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; + + subtype OS_Time is Long_Integer; + -- System time on VMS is used for performance reasons. + -- Note that OS_Time is *not* the same as Ada.Calendar.Time, the + -- difference being that relative OS_Time is negative, but relative + -- Calendar.Time is positive. + -- See Ada.Calendar.Delays for more information on VMS Time. + + 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 OS_Clock return OS_Time; + -- Returns "absolute" time, represented as an offset + -- relative to "the Epoch", which is Nov 17, 1858 on VMS. + + 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. + + function Monotonic_Clock return Duration; + pragma Inline (Monotonic_Clock); + -- Returns "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. + + 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. + + function To_Duration (T : OS_Time; Mode : Integer) return Duration; + -- Convert VMS system time to Duration + -- Mode is one of the three values above + + function To_OS_Time (D : Duration; Mode : Integer) return OS_Time; + -- Convert Duration to VMS system time + -- Mode is one of the three values above + +end System.OS_Primitives; diff --git a/gcc/ada/s-osprim-vxworks.adb b/gcc/ada/s-osprim-vxworks.adb new file mode 100644 index 000000000..f75850af0 --- /dev/null +++ b/gcc/ada/s-osprim-vxworks.adb @@ -0,0 +1,165 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 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 Interfaces.C; + +package body System.OS_Primitives is + + use System.OS_Interface; + use type Interfaces.C.int; + + ------------------------ + -- 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 (CLOCK_REALTIME, TS'Unchecked_Access); + pragma Assert (Result = 0); + return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9; + end Clock; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration renames 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.ads b/gcc/ada/s-osprim.ads new file mode 100644 index 000000000..05683b248 --- /dev/null +++ b/gcc/ada/s-osprim.ads @@ -0,0 +1,91 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 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. + + function Monotonic_Clock return Duration; + pragma Inline (Monotonic_Clock); + -- Returns "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. + + 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 new file mode 100644 index 000000000..3d88c8e55 --- /dev/null +++ b/gcc/ada/s-pack03.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 3 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_03 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_03 -- + ------------ + + function Get_03 (Arr : System.Address; N : Natural) return Bits_03 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_03; + + ------------ + -- Set_03 -- + ------------ + + procedure Set_03 (Arr : System.Address; N : Natural; E : Bits_03) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_03; + +end System.Pack_03; diff --git a/gcc/ada/s-pack03.ads b/gcc/ada/s-pack03.ads new file mode 100644 index 000000000..f34428bac --- /dev/null +++ b/gcc/ada/s-pack03.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 3 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handing 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; + + function Get_03 (Arr : System.Address; N : Natural) return Bits_03; + -- 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); + -- 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 new file mode 100644 index 000000000..42af6b130 --- /dev/null +++ b/gcc/ada/s-pack05.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 5 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_05 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_05 -- + ------------ + + function Get_05 (Arr : System.Address; N : Natural) return Bits_05 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_05; + + ------------ + -- Set_05 -- + ------------ + + procedure Set_05 (Arr : System.Address; N : Natural; E : Bits_05) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_05; + +end System.Pack_05; diff --git a/gcc/ada/s-pack05.ads b/gcc/ada/s-pack05.ads new file mode 100644 index 000000000..761ae4fa3 --- /dev/null +++ b/gcc/ada/s-pack05.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 5 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_05 (Arr : System.Address; N : Natural) return Bits_05; + -- 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); + -- 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 new file mode 100644 index 000000000..e2e77b097 --- /dev/null +++ b/gcc/ada/s-pack06.adb @@ -0,0 +1,165 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 6 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_06 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_06 -- + ------------ + + function Get_06 (Arr : System.Address; N : Natural) return Bits_06 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_06; + + ------------- + -- GetU_06 -- + ------------- + + function GetU_06 (Arr : System.Address; N : Natural) return Bits_06 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_06; + + ------------ + -- Set_06 -- + ------------ + + procedure Set_06 (Arr : System.Address; N : Natural; E : Bits_06) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_06; + + ------------- + -- SetU_06 -- + ------------- + + procedure SetU_06 (Arr : System.Address; N : Natural; E : Bits_06) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_06; + +end System.Pack_06; diff --git a/gcc/ada/s-pack06.ads b/gcc/ada/s-pack06.ads new file mode 100644 index 000000000..8d907c1b0 --- /dev/null +++ b/gcc/ada/s-pack06.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 6 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_06 (Arr : System.Address; N : Natural) return Bits_06; + -- 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); + -- 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) return Bits_06; + -- 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); + -- 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 new file mode 100644 index 000000000..0dc35e70d --- /dev/null +++ b/gcc/ada/s-pack07.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 7 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_07 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_07 -- + ------------ + + function Get_07 (Arr : System.Address; N : Natural) return Bits_07 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_07; + + ------------ + -- Set_07 -- + ------------ + + procedure Set_07 (Arr : System.Address; N : Natural; E : Bits_07) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_07; + +end System.Pack_07; diff --git a/gcc/ada/s-pack07.ads b/gcc/ada/s-pack07.ads new file mode 100644 index 000000000..b1b125a15 --- /dev/null +++ b/gcc/ada/s-pack07.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 7 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_07 (Arr : System.Address; N : Natural) return Bits_07; + -- 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); + -- 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 new file mode 100644 index 000000000..26ac89087 --- /dev/null +++ b/gcc/ada/s-pack09.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 9 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_09 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_09 -- + ------------ + + function Get_09 (Arr : System.Address; N : Natural) return Bits_09 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_09; + + ------------ + -- Set_09 -- + ------------ + + procedure Set_09 (Arr : System.Address; N : Natural; E : Bits_09) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_09; + +end System.Pack_09; diff --git a/gcc/ada/s-pack09.ads b/gcc/ada/s-pack09.ads new file mode 100644 index 000000000..be99821f6 --- /dev/null +++ b/gcc/ada/s-pack09.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_09 (Arr : System.Address; N : Natural) return Bits_09; + -- 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); + -- 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 new file mode 100644 index 000000000..933969db3 --- /dev/null +++ b/gcc/ada/s-pack10.adb @@ -0,0 +1,165 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_10 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_10 -- + ------------ + + function Get_10 (Arr : System.Address; N : Natural) return Bits_10 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_10; + + ------------- + -- GetU_10 -- + ------------- + + function GetU_10 (Arr : System.Address; N : Natural) return Bits_10 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_10; + + ------------ + -- Set_10 -- + ------------ + + procedure Set_10 (Arr : System.Address; N : Natural; E : Bits_10) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_10; + + ------------- + -- SetU_10 -- + ------------- + + procedure SetU_10 (Arr : System.Address; N : Natural; E : Bits_10) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_10; + +end System.Pack_10; diff --git a/gcc/ada/s-pack10.ads b/gcc/ada/s-pack10.ads new file mode 100644 index 000000000..fcd1d127d --- /dev/null +++ b/gcc/ada/s-pack10.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_10 (Arr : System.Address; N : Natural) return Bits_10; + -- 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); + -- 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) return Bits_10; + -- 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); + -- 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 new file mode 100644 index 000000000..62737fb83 --- /dev/null +++ b/gcc/ada/s-pack11.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_11 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_11 -- + ------------ + + function Get_11 (Arr : System.Address; N : Natural) return Bits_11 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_11; + + ------------ + -- Set_11 -- + ------------ + + procedure Set_11 (Arr : System.Address; N : Natural; E : Bits_11) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_11; + +end System.Pack_11; diff --git a/gcc/ada/s-pack11.ads b/gcc/ada/s-pack11.ads new file mode 100644 index 000000000..9c880d266 --- /dev/null +++ b/gcc/ada/s-pack11.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_11 (Arr : System.Address; N : Natural) return Bits_11; + -- 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); + -- 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 new file mode 100644 index 000000000..e12cd66ce --- /dev/null +++ b/gcc/ada/s-pack12.adb @@ -0,0 +1,165 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 2 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_12 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_12 -- + ------------ + + function Get_12 (Arr : System.Address; N : Natural) return Bits_12 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_12; + + ------------- + -- GetU_12 -- + ------------- + + function GetU_12 (Arr : System.Address; N : Natural) return Bits_12 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_12; + + ------------ + -- Set_12 -- + ------------ + + procedure Set_12 (Arr : System.Address; N : Natural; E : Bits_12) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_12; + + ------------- + -- SetU_12 -- + ------------- + + procedure SetU_12 (Arr : System.Address; N : Natural; E : Bits_12) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_12; + +end System.Pack_12; diff --git a/gcc/ada/s-pack12.ads b/gcc/ada/s-pack12.ads new file mode 100644 index 000000000..ec8b0732e --- /dev/null +++ b/gcc/ada/s-pack12.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 2 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_12 (Arr : System.Address; N : Natural) return Bits_12; + -- 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); + -- 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) return Bits_12; + -- 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); + -- 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 new file mode 100644 index 000000000..d08b5a184 --- /dev/null +++ b/gcc/ada/s-pack13.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 3 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_13 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_13 -- + ------------ + + function Get_13 (Arr : System.Address; N : Natural) return Bits_13 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_13; + + ------------ + -- Set_13 -- + ------------ + + procedure Set_13 (Arr : System.Address; N : Natural; E : Bits_13) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_13; + +end System.Pack_13; diff --git a/gcc/ada/s-pack13.ads b/gcc/ada/s-pack13.ads new file mode 100644 index 000000000..a5b625812 --- /dev/null +++ b/gcc/ada/s-pack13.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 3 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_13 (Arr : System.Address; N : Natural) return Bits_13; + -- 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); + -- 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 new file mode 100644 index 000000000..0ef322d18 --- /dev/null +++ b/gcc/ada/s-pack14.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 4 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_14 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_14 -- + ------------ + + function Get_14 (Arr : System.Address; N : Natural) return Bits_14 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_14; + + ------------- + -- GetU_14 -- + ------------- + + function GetU_14 (Arr : System.Address; N : Natural) return Bits_14 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_14; + + ------------ + -- Set_14 -- + ------------ + + procedure Set_14 (Arr : System.Address; N : Natural; E : Bits_14) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_14; + + ------------- + -- SetU_14 -- + ------------- + + procedure SetU_14 (Arr : System.Address; N : Natural; E : Bits_14) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_14; + +end System.Pack_14; diff --git a/gcc/ada/s-pack14.ads b/gcc/ada/s-pack14.ads new file mode 100644 index 000000000..326d2e68c --- /dev/null +++ b/gcc/ada/s-pack14.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 4 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handing 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; + + function Get_14 (Arr : System.Address; N : Natural) return Bits_14; + -- 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); + -- 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) return Bits_14; + -- 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); + -- 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 new file mode 100644 index 000000000..7e9c65f07 --- /dev/null +++ b/gcc/ada/s-pack15.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 5 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_15 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_15 -- + ------------ + + function Get_15 (Arr : System.Address; N : Natural) return Bits_15 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_15; + + ------------ + -- Set_15 -- + ------------ + + procedure Set_15 (Arr : System.Address; N : Natural; E : Bits_15) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_15; + +end System.Pack_15; diff --git a/gcc/ada/s-pack15.ads b/gcc/ada/s-pack15.ads new file mode 100644 index 000000000..62dc598e3 --- /dev/null +++ b/gcc/ada/s-pack15.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 5 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_15 (Arr : System.Address; N : Natural) return Bits_15; + -- 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); + -- 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 new file mode 100644 index 000000000..755dd6b4b --- /dev/null +++ b/gcc/ada/s-pack17.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 7 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_17 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_17 -- + ------------ + + function Get_17 (Arr : System.Address; N : Natural) return Bits_17 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_17; + + ------------ + -- Set_17 -- + ------------ + + procedure Set_17 (Arr : System.Address; N : Natural; E : Bits_17) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_17; + +end System.Pack_17; diff --git a/gcc/ada/s-pack17.ads b/gcc/ada/s-pack17.ads new file mode 100644 index 000000000..a81a69620 --- /dev/null +++ b/gcc/ada/s-pack17.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 7 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_17 (Arr : System.Address; N : Natural) return Bits_17; + -- 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); + -- 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 new file mode 100644 index 000000000..feba763cd --- /dev/null +++ b/gcc/ada/s-pack18.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 8 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_18 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_18 -- + ------------ + + function Get_18 (Arr : System.Address; N : Natural) return Bits_18 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_18; + + ------------- + -- GetU_18 -- + ------------- + + function GetU_18 (Arr : System.Address; N : Natural) return Bits_18 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_18; + + ------------ + -- Set_18 -- + ------------ + + procedure Set_18 (Arr : System.Address; N : Natural; E : Bits_18) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_18; + + ------------- + -- SetU_18 -- + ------------- + + procedure SetU_18 (Arr : System.Address; N : Natural; E : Bits_18) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_18; + +end System.Pack_18; diff --git a/gcc/ada/s-pack18.ads b/gcc/ada/s-pack18.ads new file mode 100644 index 000000000..31d6c0b3f --- /dev/null +++ b/gcc/ada/s-pack18.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 8 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_18 (Arr : System.Address; N : Natural) return Bits_18; + -- 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); + -- 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) return Bits_18; + -- 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); + -- 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 new file mode 100644 index 000000000..65d354017 --- /dev/null +++ b/gcc/ada/s-pack19.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 9 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_19 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_19 -- + ------------ + + function Get_19 (Arr : System.Address; N : Natural) return Bits_19 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_19; + + ------------ + -- Set_19 -- + ------------ + + procedure Set_19 (Arr : System.Address; N : Natural; E : Bits_19) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_19; + +end System.Pack_19; diff --git a/gcc/ada/s-pack19.ads b/gcc/ada/s-pack19.ads new file mode 100644 index 000000000..052c216ca --- /dev/null +++ b/gcc/ada/s-pack19.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_19 (Arr : System.Address; N : Natural) return Bits_19; + -- 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); + -- 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 new file mode 100644 index 000000000..6061588ca --- /dev/null +++ b/gcc/ada/s-pack20.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 0 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_20 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_20 -- + ------------ + + function Get_20 (Arr : System.Address; N : Natural) return Bits_20 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_20; + + ------------- + -- GetU_20 -- + ------------- + + function GetU_20 (Arr : System.Address; N : Natural) return Bits_20 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_20; + + ------------ + -- Set_20 -- + ------------ + + procedure Set_20 (Arr : System.Address; N : Natural; E : Bits_20) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_20; + + ------------- + -- SetU_20 -- + ------------- + + procedure SetU_20 (Arr : System.Address; N : Natural; E : Bits_20) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_20; + +end System.Pack_20; diff --git a/gcc/ada/s-pack20.ads b/gcc/ada/s-pack20.ads new file mode 100644 index 000000000..800d677cd --- /dev/null +++ b/gcc/ada/s-pack20.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 0 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_20 (Arr : System.Address; N : Natural) return Bits_20; + -- 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); + -- 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) return Bits_20; + -- 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); + -- 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 new file mode 100644 index 000000000..6b7865093 --- /dev/null +++ b/gcc/ada/s-pack21.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 1 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_21 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_21 -- + ------------ + + function Get_21 (Arr : System.Address; N : Natural) return Bits_21 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_21; + + ------------ + -- Set_21 -- + ------------ + + procedure Set_21 (Arr : System.Address; N : Natural; E : Bits_21) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_21; + +end System.Pack_21; diff --git a/gcc/ada/s-pack21.ads b/gcc/ada/s-pack21.ads new file mode 100644 index 000000000..a0d5939f0 --- /dev/null +++ b/gcc/ada/s-pack21.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_21 (Arr : System.Address; N : Natural) return Bits_21; + -- 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); + -- 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 new file mode 100644 index 000000000..d0e3cdf77 --- /dev/null +++ b/gcc/ada/s-pack22.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 2 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_22 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_22 -- + ------------ + + function Get_22 (Arr : System.Address; N : Natural) return Bits_22 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_22; + + ------------- + -- GetU_22 -- + ------------- + + function GetU_22 (Arr : System.Address; N : Natural) return Bits_22 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_22; + + ------------ + -- Set_22 -- + ------------ + + procedure Set_22 (Arr : System.Address; N : Natural; E : Bits_22) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_22; + + ------------- + -- SetU_22 -- + ------------- + + procedure SetU_22 (Arr : System.Address; N : Natural; E : Bits_22) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_22; + +end System.Pack_22; diff --git a/gcc/ada/s-pack22.ads b/gcc/ada/s-pack22.ads new file mode 100644 index 000000000..d4f1de78d --- /dev/null +++ b/gcc/ada/s-pack22.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 2 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_22 (Arr : System.Address; N : Natural) return Bits_22; + -- 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); + -- 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) return Bits_22; + -- 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); + -- 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 new file mode 100644 index 000000000..ba14b3bfd --- /dev/null +++ b/gcc/ada/s-pack23.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 3 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_23 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_23 -- + ------------ + + function Get_23 (Arr : System.Address; N : Natural) return Bits_23 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_23; + + ------------ + -- Set_23 -- + ------------ + + procedure Set_23 (Arr : System.Address; N : Natural; E : Bits_23) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_23; + +end System.Pack_23; diff --git a/gcc/ada/s-pack23.ads b/gcc/ada/s-pack23.ads new file mode 100644 index 000000000..eaa968ece --- /dev/null +++ b/gcc/ada/s-pack23.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 3 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_23 (Arr : System.Address; N : Natural) return Bits_23; + -- 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); + -- 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 new file mode 100644 index 000000000..49695e623 --- /dev/null +++ b/gcc/ada/s-pack24.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 4 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_24 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_24 -- + ------------ + + function Get_24 (Arr : System.Address; N : Natural) return Bits_24 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_24; + + ------------- + -- GetU_24 -- + ------------- + + function GetU_24 (Arr : System.Address; N : Natural) return Bits_24 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_24; + + ------------ + -- Set_24 -- + ------------ + + procedure Set_24 (Arr : System.Address; N : Natural; E : Bits_24) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_24; + + ------------- + -- SetU_24 -- + ------------- + + procedure SetU_24 (Arr : System.Address; N : Natural; E : Bits_24) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_24; + +end System.Pack_24; diff --git a/gcc/ada/s-pack24.ads b/gcc/ada/s-pack24.ads new file mode 100644 index 000000000..440dc4867 --- /dev/null +++ b/gcc/ada/s-pack24.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 4 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_24 (Arr : System.Address; N : Natural) return Bits_24; + -- 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); + -- 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) return Bits_24; + -- 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); + -- 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 new file mode 100644 index 000000000..015d40305 --- /dev/null +++ b/gcc/ada/s-pack25.adb @@ -0,0 +1,114 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 5 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_25 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_25 -- + ------------ + + function Get_25 (Arr : System.Address; N : Natural) return Bits_25 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_25; + + ------------ + -- Set_25 -- + ------------ + + procedure Set_25 (Arr : System.Address; N : Natural; E : Bits_25) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_25; + +end System.Pack_25; diff --git a/gcc/ada/s-pack25.ads b/gcc/ada/s-pack25.ads new file mode 100644 index 000000000..b7f3ebbf7 --- /dev/null +++ b/gcc/ada/s-pack25.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 5 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_25 (Arr : System.Address; N : Natural) return Bits_25; + -- 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); + -- 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 new file mode 100644 index 000000000..613558f53 --- /dev/null +++ b/gcc/ada/s-pack26.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 6 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_26 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_26 -- + ------------ + + function Get_26 (Arr : System.Address; N : Natural) return Bits_26 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_26; + + ------------- + -- GetU_26 -- + ------------- + + function GetU_26 (Arr : System.Address; N : Natural) return Bits_26 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_26; + + ------------ + -- Set_26 -- + ------------ + + procedure Set_26 (Arr : System.Address; N : Natural; E : Bits_26) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_26; + + ------------- + -- SetU_26 -- + ------------- + + procedure SetU_26 (Arr : System.Address; N : Natural; E : Bits_26) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_26; + +end System.Pack_26; diff --git a/gcc/ada/s-pack26.ads b/gcc/ada/s-pack26.ads new file mode 100644 index 000000000..d0d56ac42 --- /dev/null +++ b/gcc/ada/s-pack26.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 6 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_26 (Arr : System.Address; N : Natural) return Bits_26; + -- 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); + -- 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) return Bits_26; + -- 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); + -- 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 new file mode 100644 index 000000000..7497c098f --- /dev/null +++ b/gcc/ada/s-pack27.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 7 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_27 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_27 -- + ------------ + + function Get_27 (Arr : System.Address; N : Natural) return Bits_27 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_27; + + ------------ + -- Set_27 -- + ------------ + + procedure Set_27 (Arr : System.Address; N : Natural; E : Bits_27) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_27; + +end System.Pack_27; diff --git a/gcc/ada/s-pack27.ads b/gcc/ada/s-pack27.ads new file mode 100644 index 000000000..bfb287e1d --- /dev/null +++ b/gcc/ada/s-pack27.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 7 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_27 (Arr : System.Address; N : Natural) return Bits_27; + -- 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); + -- 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 new file mode 100644 index 000000000..1342885ba --- /dev/null +++ b/gcc/ada/s-pack28.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 8 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_28 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_28 -- + ------------ + + function Get_28 (Arr : System.Address; N : Natural) return Bits_28 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_28; + + ------------- + -- GetU_28 -- + ------------- + + function GetU_28 (Arr : System.Address; N : Natural) return Bits_28 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_28; + + ------------ + -- Set_28 -- + ------------ + + procedure Set_28 (Arr : System.Address; N : Natural; E : Bits_28) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_28; + + ------------- + -- SetU_28 -- + ------------- + + procedure SetU_28 (Arr : System.Address; N : Natural; E : Bits_28) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_28; + +end System.Pack_28; diff --git a/gcc/ada/s-pack28.ads b/gcc/ada/s-pack28.ads new file mode 100644 index 000000000..79c1751a4 --- /dev/null +++ b/gcc/ada/s-pack28.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 8 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_28 (Arr : System.Address; N : Natural) return Bits_28; + -- 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); + -- 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) return Bits_28; + -- 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); + -- 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 new file mode 100644 index 000000000..f0a54c131 --- /dev/null +++ b/gcc/ada/s-pack29.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 9 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_29 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_29 -- + ------------ + + function Get_29 (Arr : System.Address; N : Natural) return Bits_29 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_29; + + ------------ + -- Set_29 -- + ------------ + + procedure Set_29 (Arr : System.Address; N : Natural; E : Bits_29) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_29; + +end System.Pack_29; diff --git a/gcc/ada/s-pack29.ads b/gcc/ada/s-pack29.ads new file mode 100644 index 000000000..ea479574a --- /dev/null +++ b/gcc/ada/s-pack29.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_29 (Arr : System.Address; N : Natural) return Bits_29; + -- 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); + -- 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 new file mode 100644 index 000000000..04eb5b375 --- /dev/null +++ b/gcc/ada/s-pack30.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 0 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_30 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_30 -- + ------------ + + function Get_30 (Arr : System.Address; N : Natural) return Bits_30 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_30; + + ------------- + -- GetU_30 -- + ------------- + + function GetU_30 (Arr : System.Address; N : Natural) return Bits_30 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_30; + + ------------ + -- Set_30 -- + ------------ + + procedure Set_30 (Arr : System.Address; N : Natural; E : Bits_30) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_30; + + ------------- + -- SetU_30 -- + ------------- + + procedure SetU_30 (Arr : System.Address; N : Natural; E : Bits_30) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_30; + +end System.Pack_30; diff --git a/gcc/ada/s-pack30.ads b/gcc/ada/s-pack30.ads new file mode 100644 index 000000000..b09addfeb --- /dev/null +++ b/gcc/ada/s-pack30.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 0 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_30 (Arr : System.Address; N : Natural) return Bits_30; + -- 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); + -- 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) return Bits_30; + -- 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); + -- 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 new file mode 100644 index 000000000..d723601af --- /dev/null +++ b/gcc/ada/s-pack31.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 1 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_31 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_31 -- + ------------ + + function Get_31 (Arr : System.Address; N : Natural) return Bits_31 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_31; + + ------------ + -- Set_31 -- + ------------ + + procedure Set_31 (Arr : System.Address; N : Natural; E : Bits_31) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_31; + +end System.Pack_31; diff --git a/gcc/ada/s-pack31.ads b/gcc/ada/s-pack31.ads new file mode 100644 index 000000000..4cd0daf7a --- /dev/null +++ b/gcc/ada/s-pack31.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_31 (Arr : System.Address; N : Natural) return Bits_31; + -- 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); + -- 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 new file mode 100644 index 000000000..745d8de03 --- /dev/null +++ b/gcc/ada/s-pack33.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 3 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_33 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_33 -- + ------------ + + function Get_33 (Arr : System.Address; N : Natural) return Bits_33 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_33; + + ------------ + -- Set_33 -- + ------------ + + procedure Set_33 (Arr : System.Address; N : Natural; E : Bits_33) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_33; + +end System.Pack_33; diff --git a/gcc/ada/s-pack33.ads b/gcc/ada/s-pack33.ads new file mode 100644 index 000000000..a0dc085d5 --- /dev/null +++ b/gcc/ada/s-pack33.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 3 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_33 (Arr : System.Address; N : Natural) return Bits_33; + -- 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); + -- 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 new file mode 100644 index 000000000..8beafa918 --- /dev/null +++ b/gcc/ada/s-pack34.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 4 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_34 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_34 -- + ------------ + + function Get_34 (Arr : System.Address; N : Natural) return Bits_34 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_34; + + ------------- + -- GetU_34 -- + ------------- + + function GetU_34 (Arr : System.Address; N : Natural) return Bits_34 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_34; + + ------------ + -- Set_34 -- + ------------ + + procedure Set_34 (Arr : System.Address; N : Natural; E : Bits_34) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_34; + + ------------- + -- SetU_34 -- + ------------- + + procedure SetU_34 (Arr : System.Address; N : Natural; E : Bits_34) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_34; + +end System.Pack_34; diff --git a/gcc/ada/s-pack34.ads b/gcc/ada/s-pack34.ads new file mode 100644 index 000000000..26dbc9874 --- /dev/null +++ b/gcc/ada/s-pack34.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 4 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_34 (Arr : System.Address; N : Natural) return Bits_34; + -- 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); + -- 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) return Bits_34; + -- 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); + -- 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 new file mode 100644 index 000000000..009e66707 --- /dev/null +++ b/gcc/ada/s-pack35.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 5 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_35 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_35 -- + ------------ + + function Get_35 (Arr : System.Address; N : Natural) return Bits_35 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_35; + + ------------ + -- Set_35 -- + ------------ + + procedure Set_35 (Arr : System.Address; N : Natural; E : Bits_35) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_35; + +end System.Pack_35; diff --git a/gcc/ada/s-pack35.ads b/gcc/ada/s-pack35.ads new file mode 100644 index 000000000..17283a954 --- /dev/null +++ b/gcc/ada/s-pack35.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 5 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_35 (Arr : System.Address; N : Natural) return Bits_35; + -- 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); + -- 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 new file mode 100644 index 000000000..bfd3e55ef --- /dev/null +++ b/gcc/ada/s-pack36.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 6 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_36 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_36 -- + ------------ + + function Get_36 (Arr : System.Address; N : Natural) return Bits_36 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_36; + + ------------- + -- GetU_36 -- + ------------- + + function GetU_36 (Arr : System.Address; N : Natural) return Bits_36 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_36; + + ------------ + -- Set_36 -- + ------------ + + procedure Set_36 (Arr : System.Address; N : Natural; E : Bits_36) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_36; + + ------------- + -- SetU_36 -- + ------------- + + procedure SetU_36 (Arr : System.Address; N : Natural; E : Bits_36) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_36; + +end System.Pack_36; diff --git a/gcc/ada/s-pack36.ads b/gcc/ada/s-pack36.ads new file mode 100644 index 000000000..17633fad1 --- /dev/null +++ b/gcc/ada/s-pack36.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 6 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_36 (Arr : System.Address; N : Natural) return Bits_36; + -- 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); + -- 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) return Bits_36; + -- 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); + -- 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 new file mode 100644 index 000000000..374ecdefa --- /dev/null +++ b/gcc/ada/s-pack37.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 7 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_37 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_37 -- + ------------ + + function Get_37 (Arr : System.Address; N : Natural) return Bits_37 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_37; + + ------------ + -- Set_37 -- + ------------ + + procedure Set_37 (Arr : System.Address; N : Natural; E : Bits_37) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_37; + +end System.Pack_37; diff --git a/gcc/ada/s-pack37.ads b/gcc/ada/s-pack37.ads new file mode 100644 index 000000000..baa44c6fa --- /dev/null +++ b/gcc/ada/s-pack37.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 7 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_37 (Arr : System.Address; N : Natural) return Bits_37; + -- 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); + -- 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 new file mode 100644 index 000000000..90cf4c430 --- /dev/null +++ b/gcc/ada/s-pack38.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 8 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_38 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_38 -- + ------------ + + function Get_38 (Arr : System.Address; N : Natural) return Bits_38 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_38; + + ------------- + -- GetU_38 -- + ------------- + + function GetU_38 (Arr : System.Address; N : Natural) return Bits_38 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_38; + + ------------ + -- Set_38 -- + ------------ + + procedure Set_38 (Arr : System.Address; N : Natural; E : Bits_38) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_38; + + ------------- + -- SetU_38 -- + ------------- + + procedure SetU_38 (Arr : System.Address; N : Natural; E : Bits_38) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_38; + +end System.Pack_38; diff --git a/gcc/ada/s-pack38.ads b/gcc/ada/s-pack38.ads new file mode 100644 index 000000000..b246eec7a --- /dev/null +++ b/gcc/ada/s-pack38.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 8 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_38 (Arr : System.Address; N : Natural) return Bits_38; + -- 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); + -- 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) return Bits_38; + -- 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); + -- 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 new file mode 100644 index 000000000..258319113 --- /dev/null +++ b/gcc/ada/s-pack39.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 9 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_39 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_39 -- + ------------ + + function Get_39 (Arr : System.Address; N : Natural) return Bits_39 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_39; + + ------------ + -- Set_39 -- + ------------ + + procedure Set_39 (Arr : System.Address; N : Natural; E : Bits_39) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_39; + +end System.Pack_39; diff --git a/gcc/ada/s-pack39.ads b/gcc/ada/s-pack39.ads new file mode 100644 index 000000000..90c4eaaba --- /dev/null +++ b/gcc/ada/s-pack39.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_39 (Arr : System.Address; N : Natural) return Bits_39; + -- 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); + -- 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 new file mode 100644 index 000000000..726763120 --- /dev/null +++ b/gcc/ada/s-pack40.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 0 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_40 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_40 -- + ------------ + + function Get_40 (Arr : System.Address; N : Natural) return Bits_40 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_40; + + ------------- + -- GetU_40 -- + ------------- + + function GetU_40 (Arr : System.Address; N : Natural) return Bits_40 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_40; + + ------------ + -- Set_40 -- + ------------ + + procedure Set_40 (Arr : System.Address; N : Natural; E : Bits_40) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_40; + + ------------- + -- SetU_40 -- + ------------- + + procedure SetU_40 (Arr : System.Address; N : Natural; E : Bits_40) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_40; + +end System.Pack_40; diff --git a/gcc/ada/s-pack40.ads b/gcc/ada/s-pack40.ads new file mode 100644 index 000000000..9fd948ecf --- /dev/null +++ b/gcc/ada/s-pack40.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 0 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_40 (Arr : System.Address; N : Natural) return Bits_40; + -- 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); + -- 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) return Bits_40; + -- 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); + -- 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 new file mode 100644 index 000000000..7ace35884 --- /dev/null +++ b/gcc/ada/s-pack41.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 1 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_41 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_41 -- + ------------ + + function Get_41 (Arr : System.Address; N : Natural) return Bits_41 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_41; + + ------------ + -- Set_41 -- + ------------ + + procedure Set_41 (Arr : System.Address; N : Natural; E : Bits_41) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_41; + +end System.Pack_41; diff --git a/gcc/ada/s-pack41.ads b/gcc/ada/s-pack41.ads new file mode 100644 index 000000000..2ff9f5110 --- /dev/null +++ b/gcc/ada/s-pack41.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_41 (Arr : System.Address; N : Natural) return Bits_41; + -- 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); + -- 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 new file mode 100644 index 000000000..6ba6567b2 --- /dev/null +++ b/gcc/ada/s-pack42.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 2 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_42 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_42 -- + ------------ + + function Get_42 (Arr : System.Address; N : Natural) return Bits_42 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_42; + + ------------- + -- GetU_42 -- + ------------- + + function GetU_42 (Arr : System.Address; N : Natural) return Bits_42 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_42; + + ------------ + -- Set_42 -- + ------------ + + procedure Set_42 (Arr : System.Address; N : Natural; E : Bits_42) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_42; + + ------------- + -- SetU_42 -- + ------------- + + procedure SetU_42 (Arr : System.Address; N : Natural; E : Bits_42) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_42; + +end System.Pack_42; diff --git a/gcc/ada/s-pack42.ads b/gcc/ada/s-pack42.ads new file mode 100644 index 000000000..a0740b265 --- /dev/null +++ b/gcc/ada/s-pack42.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 2 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_42 (Arr : System.Address; N : Natural) return Bits_42; + -- 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); + -- 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) return Bits_42; + -- 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); + -- 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 new file mode 100644 index 000000000..7979fb13a --- /dev/null +++ b/gcc/ada/s-pack43.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 3 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_43 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_43 -- + ------------ + + function Get_43 (Arr : System.Address; N : Natural) return Bits_43 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_43; + + ------------ + -- Set_43 -- + ------------ + + procedure Set_43 (Arr : System.Address; N : Natural; E : Bits_43) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_43; + +end System.Pack_43; diff --git a/gcc/ada/s-pack43.ads b/gcc/ada/s-pack43.ads new file mode 100644 index 000000000..99202f2c8 --- /dev/null +++ b/gcc/ada/s-pack43.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 3 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_43 (Arr : System.Address; N : Natural) return Bits_43; + -- 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); + -- 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 new file mode 100644 index 000000000..a3f7f001b --- /dev/null +++ b/gcc/ada/s-pack44.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 4 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_44 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_44 -- + ------------ + + function Get_44 (Arr : System.Address; N : Natural) return Bits_44 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_44; + + ------------- + -- GetU_44 -- + ------------- + + function GetU_44 (Arr : System.Address; N : Natural) return Bits_44 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_44; + + ------------ + -- Set_44 -- + ------------ + + procedure Set_44 (Arr : System.Address; N : Natural; E : Bits_44) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_44; + + ------------- + -- SetU_44 -- + ------------- + + procedure SetU_44 (Arr : System.Address; N : Natural; E : Bits_44) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_44; + +end System.Pack_44; diff --git a/gcc/ada/s-pack44.ads b/gcc/ada/s-pack44.ads new file mode 100644 index 000000000..d083bf2ac --- /dev/null +++ b/gcc/ada/s-pack44.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 4 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_44 (Arr : System.Address; N : Natural) return Bits_44; + -- 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); + -- 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) return Bits_44; + -- 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); + -- 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 new file mode 100644 index 000000000..4a2ce84af --- /dev/null +++ b/gcc/ada/s-pack45.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 5 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_45 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_45 -- + ------------ + + function Get_45 (Arr : System.Address; N : Natural) return Bits_45 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_45; + + ------------ + -- Set_45 -- + ------------ + + procedure Set_45 (Arr : System.Address; N : Natural; E : Bits_45) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_45; + +end System.Pack_45; diff --git a/gcc/ada/s-pack45.ads b/gcc/ada/s-pack45.ads new file mode 100644 index 000000000..2c9b60b88 --- /dev/null +++ b/gcc/ada/s-pack45.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 5 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_45 (Arr : System.Address; N : Natural) return Bits_45; + -- 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); + -- 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 new file mode 100644 index 000000000..7df5199e6 --- /dev/null +++ b/gcc/ada/s-pack46.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 6 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_46 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_46 -- + ------------ + + function Get_46 (Arr : System.Address; N : Natural) return Bits_46 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_46; + + ------------- + -- GetU_46 -- + ------------- + + function GetU_46 (Arr : System.Address; N : Natural) return Bits_46 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_46; + + ------------ + -- Set_46 -- + ------------ + + procedure Set_46 (Arr : System.Address; N : Natural; E : Bits_46) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_46; + + ------------- + -- SetU_46 -- + ------------- + + procedure SetU_46 (Arr : System.Address; N : Natural; E : Bits_46) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_46; + +end System.Pack_46; diff --git a/gcc/ada/s-pack46.ads b/gcc/ada/s-pack46.ads new file mode 100644 index 000000000..5cdc6a2a2 --- /dev/null +++ b/gcc/ada/s-pack46.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 6 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_46 (Arr : System.Address; N : Natural) return Bits_46; + -- 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); + -- 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) return Bits_46; + -- 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); + -- 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 new file mode 100644 index 000000000..1cd3d7f62 --- /dev/null +++ b/gcc/ada/s-pack47.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 7 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_47 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_47 -- + ------------ + + function Get_47 (Arr : System.Address; N : Natural) return Bits_47 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_47; + + ------------ + -- Set_47 -- + ------------ + + procedure Set_47 (Arr : System.Address; N : Natural; E : Bits_47) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_47; + +end System.Pack_47; diff --git a/gcc/ada/s-pack47.ads b/gcc/ada/s-pack47.ads new file mode 100644 index 000000000..c44a251f6 --- /dev/null +++ b/gcc/ada/s-pack47.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 7 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_47 (Arr : System.Address; N : Natural) return Bits_47; + -- 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); + -- 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 new file mode 100644 index 000000000..615c27014 --- /dev/null +++ b/gcc/ada/s-pack48.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 8 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_48 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_48 -- + ------------ + + function Get_48 (Arr : System.Address; N : Natural) return Bits_48 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_48; + + ------------- + -- GetU_48 -- + ------------- + + function GetU_48 (Arr : System.Address; N : Natural) return Bits_48 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_48; + + ------------ + -- Set_48 -- + ------------ + + procedure Set_48 (Arr : System.Address; N : Natural; E : Bits_48) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_48; + + ------------- + -- SetU_48 -- + ------------- + + procedure SetU_48 (Arr : System.Address; N : Natural; E : Bits_48) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_48; + +end System.Pack_48; diff --git a/gcc/ada/s-pack48.ads b/gcc/ada/s-pack48.ads new file mode 100644 index 000000000..f91b7949f --- /dev/null +++ b/gcc/ada/s-pack48.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 8 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_48 (Arr : System.Address; N : Natural) return Bits_48; + -- 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); + -- 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) return Bits_48; + -- 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); + -- 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 new file mode 100644 index 000000000..9e912035f --- /dev/null +++ b/gcc/ada/s-pack49.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 9 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_49 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_49 -- + ------------ + + function Get_49 (Arr : System.Address; N : Natural) return Bits_49 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_49; + + ------------ + -- Set_49 -- + ------------ + + procedure Set_49 (Arr : System.Address; N : Natural; E : Bits_49) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_49; + +end System.Pack_49; diff --git a/gcc/ada/s-pack49.ads b/gcc/ada/s-pack49.ads new file mode 100644 index 000000000..b0ba1f182 --- /dev/null +++ b/gcc/ada/s-pack49.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_49 (Arr : System.Address; N : Natural) return Bits_49; + -- 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); + -- 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 new file mode 100644 index 000000000..fb2dc15c0 --- /dev/null +++ b/gcc/ada/s-pack50.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 0 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_50 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_50 -- + ------------ + + function Get_50 (Arr : System.Address; N : Natural) return Bits_50 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_50; + + ------------- + -- GetU_50 -- + ------------- + + function GetU_50 (Arr : System.Address; N : Natural) return Bits_50 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_50; + + ------------ + -- Set_50 -- + ------------ + + procedure Set_50 (Arr : System.Address; N : Natural; E : Bits_50) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_50; + + ------------- + -- SetU_50 -- + ------------- + + procedure SetU_50 (Arr : System.Address; N : Natural; E : Bits_50) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_50; + +end System.Pack_50; diff --git a/gcc/ada/s-pack50.ads b/gcc/ada/s-pack50.ads new file mode 100644 index 000000000..1399b66e3 --- /dev/null +++ b/gcc/ada/s-pack50.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 0 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_50 (Arr : System.Address; N : Natural) return Bits_50; + -- 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); + -- 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) return Bits_50; + -- 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); + -- 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 new file mode 100644 index 000000000..f8e4d99a2 --- /dev/null +++ b/gcc/ada/s-pack51.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 1 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_51 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_51 -- + ------------ + + function Get_51 (Arr : System.Address; N : Natural) return Bits_51 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_51; + + ------------ + -- Set_51 -- + ------------ + + procedure Set_51 (Arr : System.Address; N : Natural; E : Bits_51) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_51; + +end System.Pack_51; diff --git a/gcc/ada/s-pack51.ads b/gcc/ada/s-pack51.ads new file mode 100644 index 000000000..8e4316c3d --- /dev/null +++ b/gcc/ada/s-pack51.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_51 (Arr : System.Address; N : Natural) return Bits_51; + -- 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); + -- 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 new file mode 100644 index 000000000..6c4fd4058 --- /dev/null +++ b/gcc/ada/s-pack52.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 2 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_52 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_52 -- + ------------ + + function Get_52 (Arr : System.Address; N : Natural) return Bits_52 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_52; + + ------------- + -- GetU_52 -- + ------------- + + function GetU_52 (Arr : System.Address; N : Natural) return Bits_52 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_52; + + ------------ + -- Set_52 -- + ------------ + + procedure Set_52 (Arr : System.Address; N : Natural; E : Bits_52) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_52; + + ------------- + -- SetU_52 -- + ------------- + + procedure SetU_52 (Arr : System.Address; N : Natural; E : Bits_52) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_52; + +end System.Pack_52; diff --git a/gcc/ada/s-pack52.ads b/gcc/ada/s-pack52.ads new file mode 100644 index 000000000..1342a9260 --- /dev/null +++ b/gcc/ada/s-pack52.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 2 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_52 (Arr : System.Address; N : Natural) return Bits_52; + -- 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); + -- 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) return Bits_52; + -- 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); + -- 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 new file mode 100644 index 000000000..c19512b17 --- /dev/null +++ b/gcc/ada/s-pack53.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 3 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_53 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_53 -- + ------------ + + function Get_53 (Arr : System.Address; N : Natural) return Bits_53 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_53; + + ------------ + -- Set_53 -- + ------------ + + procedure Set_53 (Arr : System.Address; N : Natural; E : Bits_53) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_53; + +end System.Pack_53; diff --git a/gcc/ada/s-pack53.ads b/gcc/ada/s-pack53.ads new file mode 100644 index 000000000..e0e568386 --- /dev/null +++ b/gcc/ada/s-pack53.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 3 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_53 (Arr : System.Address; N : Natural) return Bits_53; + -- 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); + -- 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 new file mode 100644 index 000000000..d21dbc0df --- /dev/null +++ b/gcc/ada/s-pack54.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 4 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_54 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_54 -- + ------------ + + function Get_54 (Arr : System.Address; N : Natural) return Bits_54 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_54; + + ------------- + -- GetU_54 -- + ------------- + + function GetU_54 (Arr : System.Address; N : Natural) return Bits_54 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_54; + + ------------ + -- Set_54 -- + ------------ + + procedure Set_54 (Arr : System.Address; N : Natural; E : Bits_54) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_54; + + ------------- + -- SetU_54 -- + ------------- + + procedure SetU_54 (Arr : System.Address; N : Natural; E : Bits_54) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_54; + +end System.Pack_54; diff --git a/gcc/ada/s-pack54.ads b/gcc/ada/s-pack54.ads new file mode 100644 index 000000000..448f6dbc5 --- /dev/null +++ b/gcc/ada/s-pack54.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 4 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_54 (Arr : System.Address; N : Natural) return Bits_54; + -- 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); + -- 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) return Bits_54; + -- 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); + -- 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 new file mode 100644 index 000000000..378d6f22a --- /dev/null +++ b/gcc/ada/s-pack55.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 5 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_55 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_55 -- + ------------ + + function Get_55 (Arr : System.Address; N : Natural) return Bits_55 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_55; + + ------------ + -- Set_55 -- + ------------ + + procedure Set_55 (Arr : System.Address; N : Natural; E : Bits_55) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_55; + +end System.Pack_55; diff --git a/gcc/ada/s-pack55.ads b/gcc/ada/s-pack55.ads new file mode 100644 index 000000000..00d4d93d9 --- /dev/null +++ b/gcc/ada/s-pack55.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 5 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_55 (Arr : System.Address; N : Natural) return Bits_55; + -- 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); + -- 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 new file mode 100644 index 000000000..b27c408e3 --- /dev/null +++ b/gcc/ada/s-pack56.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 6 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_56 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_56 -- + ------------ + + function Get_56 (Arr : System.Address; N : Natural) return Bits_56 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_56; + + ------------- + -- GetU_56 -- + ------------- + + function GetU_56 (Arr : System.Address; N : Natural) return Bits_56 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_56; + + ------------ + -- Set_56 -- + ------------ + + procedure Set_56 (Arr : System.Address; N : Natural; E : Bits_56) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_56; + + ------------- + -- SetU_56 -- + ------------- + + procedure SetU_56 (Arr : System.Address; N : Natural; E : Bits_56) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_56; + +end System.Pack_56; diff --git a/gcc/ada/s-pack56.ads b/gcc/ada/s-pack56.ads new file mode 100644 index 000000000..27c593c1e --- /dev/null +++ b/gcc/ada/s-pack56.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 6 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_56 (Arr : System.Address; N : Natural) return Bits_56; + -- 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); + -- 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) return Bits_56; + -- 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); + -- 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 new file mode 100644 index 000000000..c510baf2b --- /dev/null +++ b/gcc/ada/s-pack57.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 7 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_57 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_57 -- + ------------ + + function Get_57 (Arr : System.Address; N : Natural) return Bits_57 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_57; + + ------------ + -- Set_57 -- + ------------ + + procedure Set_57 (Arr : System.Address; N : Natural; E : Bits_57) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_57; + +end System.Pack_57; diff --git a/gcc/ada/s-pack57.ads b/gcc/ada/s-pack57.ads new file mode 100644 index 000000000..5203deaaa --- /dev/null +++ b/gcc/ada/s-pack57.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 7 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_57 (Arr : System.Address; N : Natural) return Bits_57; + -- 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); + -- 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 new file mode 100644 index 000000000..067928c64 --- /dev/null +++ b/gcc/ada/s-pack58.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 8 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_58 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_58 -- + ------------ + + function Get_58 (Arr : System.Address; N : Natural) return Bits_58 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_58; + + ------------- + -- GetU_58 -- + ------------- + + function GetU_58 (Arr : System.Address; N : Natural) return Bits_58 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_58; + + ------------ + -- Set_58 -- + ------------ + + procedure Set_58 (Arr : System.Address; N : Natural; E : Bits_58) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_58; + + ------------- + -- SetU_58 -- + ------------- + + procedure SetU_58 (Arr : System.Address; N : Natural; E : Bits_58) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_58; + +end System.Pack_58; diff --git a/gcc/ada/s-pack58.ads b/gcc/ada/s-pack58.ads new file mode 100644 index 000000000..a7e31c7cc --- /dev/null +++ b/gcc/ada/s-pack58.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 8 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_58 (Arr : System.Address; N : Natural) return Bits_58; + -- 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); + -- 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) return Bits_58; + -- 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); + -- 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 new file mode 100644 index 000000000..ea93ebff5 --- /dev/null +++ b/gcc/ada/s-pack59.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 9 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_59 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_59 -- + ------------ + + function Get_59 (Arr : System.Address; N : Natural) return Bits_59 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_59; + + ------------ + -- Set_59 -- + ------------ + + procedure Set_59 (Arr : System.Address; N : Natural; E : Bits_59) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_59; + +end System.Pack_59; diff --git a/gcc/ada/s-pack59.ads b/gcc/ada/s-pack59.ads new file mode 100644 index 000000000..585ecd9c5 --- /dev/null +++ b/gcc/ada/s-pack59.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_59 (Arr : System.Address; N : Natural) return Bits_59; + -- 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); + -- 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 new file mode 100644 index 000000000..5ade77507 --- /dev/null +++ b/gcc/ada/s-pack60.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 0 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_60 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_60 -- + ------------ + + function Get_60 (Arr : System.Address; N : Natural) return Bits_60 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_60; + + ------------- + -- GetU_60 -- + ------------- + + function GetU_60 (Arr : System.Address; N : Natural) return Bits_60 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_60; + + ------------ + -- Set_60 -- + ------------ + + procedure Set_60 (Arr : System.Address; N : Natural; E : Bits_60) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_60; + + ------------- + -- SetU_60 -- + ------------- + + procedure SetU_60 (Arr : System.Address; N : Natural; E : Bits_60) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_60; + +end System.Pack_60; diff --git a/gcc/ada/s-pack60.ads b/gcc/ada/s-pack60.ads new file mode 100644 index 000000000..cee776b78 --- /dev/null +++ b/gcc/ada/s-pack60.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 0 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_60 (Arr : System.Address; N : Natural) return Bits_60; + -- 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); + -- 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) return Bits_60; + -- 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); + -- 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 new file mode 100644 index 000000000..27f72e412 --- /dev/null +++ b/gcc/ada/s-pack61.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 1 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_61 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_61 -- + ------------ + + function Get_61 (Arr : System.Address; N : Natural) return Bits_61 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_61; + + ------------ + -- Set_61 -- + ------------ + + procedure Set_61 (Arr : System.Address; N : Natural; E : Bits_61) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_61; + +end System.Pack_61; diff --git a/gcc/ada/s-pack61.ads b/gcc/ada/s-pack61.ads new file mode 100644 index 000000000..0d63baefd --- /dev/null +++ b/gcc/ada/s-pack61.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_61 (Arr : System.Address; N : Natural) return Bits_61; + -- 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); + -- 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 new file mode 100644 index 000000000..faac2115c --- /dev/null +++ b/gcc/ada/s-pack62.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 2 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_62 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + -- 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_62 -- + ------------ + + function Get_62 (Arr : System.Address; N : Natural) return Bits_62 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_62; + + ------------- + -- GetU_62 -- + ------------- + + function GetU_62 (Arr : System.Address; N : Natural) return Bits_62 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_62; + + ------------ + -- Set_62 -- + ------------ + + procedure Set_62 (Arr : System.Address; N : Natural; E : Bits_62) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_62; + + ------------- + -- SetU_62 -- + ------------- + + procedure SetU_62 (Arr : System.Address; N : Natural; E : Bits_62) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_62; + +end System.Pack_62; diff --git a/gcc/ada/s-pack62.ads b/gcc/ada/s-pack62.ads new file mode 100644 index 000000000..89ad4469a --- /dev/null +++ b/gcc/ada/s-pack62.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 2 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_62 (Arr : System.Address; N : Natural) return Bits_62; + -- 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); + -- 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) return Bits_62; + -- 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); + -- 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 new file mode 100644 index 000000000..c6faee6fb --- /dev/null +++ b/gcc/ada/s-pack63.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 3 -- +-- -- +-- 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.Storage_Elements; +with System.Unsigned_Types; +with Ada.Unchecked_Conversion; + +package body System.Pack_63 is + + 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; + + function To_Ref is new + Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_63 -- + ------------ + + function Get_63 (Arr : System.Address; N : Natural) return Bits_63 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_63; + + ------------ + -- Set_63 -- + ------------ + + procedure Set_63 (Arr : System.Address; N : Natural; E : Bits_63) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_63; + +end System.Pack_63; diff --git a/gcc/ada/s-pack63.ads b/gcc/ada/s-pack63.ads new file mode 100644 index 000000000..b76eed0ef --- /dev/null +++ b/gcc/ada/s-pack63.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 3 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + function Get_63 (Arr : System.Address; N : Natural) return Bits_63; + -- 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); + -- 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-ae653.ads b/gcc/ada/s-parame-ae653.ads new file mode 100644 index 000000000..ceb2405f3 --- /dev/null +++ b/gcc/ada/s-parame-ae653.ads @@ -0,0 +1,204 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the default VxWorks AE 653 version of the package + +-- This package defines some system dependent parameters for GNAT. These +-- are values that are referenced by the runtime library and are therefore +-- relevant to the target machine. + +-- The parameters whose value is defined in the spec are not generally +-- expected to be changed. If they are changed, it will be necessary to +-- recompile the run-time library. + +-- The parameters which are defined by functions can be changed by modifying +-- the body of System.Parameters in file s-parame.adb. A change to this body +-- requires only rebinding and relinking of the application. + +-- Note: do not introduce any pragma Inline statements into this unit, since +-- otherwise the relinking and rebinding capability would be deactivated. + +package System.Parameters is + pragma Pure; + + --------------------------------------- + -- Task And Stack Allocation Control -- + --------------------------------------- + + type Task_Storage_Size is new Integer; + -- Type used in tasking units for task storage size + + type Size_Type is new Task_Storage_Size; + -- Type used to provide task storage size to runtime + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Value used to indicate that no size type is set + + subtype Ratio is Size_Type range -1 .. 100; + Dynamic : constant Size_Type := -1; + -- The secondary stack ratio is a constant between 0 and 100 which + -- determines the percentage of the allocated task stack that is + -- used by the secondary stack (the rest being the primary stack). + -- The special value of minus one indicates that the secondary + -- stack is to be allocated from the heap instead. + + Sec_Stack_Ratio : constant Ratio := 50; + -- This constant defines the handling of the secondary stack + + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; + -- Convenient Boolean for testing for dynamic secondary stack + + function Default_Stack_Size return Size_Type; + -- Default task stack size used if none is specified + + function Minimum_Stack_Size return Size_Type; + -- Minimum task stack size permitted + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type; + -- Given the storage size stored in the TCB, return the Storage_Size + -- value required by the RM for the Storage_Size attribute. The + -- required adjustment is as follows: + -- + -- when Size = Unspecified_Size, return Default_Stack_Size + -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size + -- otherwise return given Size + + Default_Env_Stack_Size : constant Size_Type := 14_336; + -- Assumed size of the environment task, if no other information + -- is available. This value is used when stack checking is + -- enabled and no GNAT_STACK_LIMIT environment variable is set. + -- This value is chosen as the VxWorks default stack size is 20kB, + -- and a little more than 4kB is necessary for the run time. + + Stack_Grows_Down : constant Boolean := True; + -- This constant indicates whether the stack grows up (False) or + -- down (True) in memory as functions are called. It is used for + -- proper implementation of the stack overflow check. + + ---------------------------------------------- + -- Characteristics of types in Interfaces.C -- + ---------------------------------------------- + + long_bits : constant := Long_Integer'Size; + -- Number of bits in type long and unsigned_long. The normal convention + -- is that this is the same as type Long_Integer, but this is not true + -- of all targets. For example, in OpenVMS long /= Long_Integer. + + ---------------------------------------------- + -- Behavior of Pragma Finalize_Storage_Only -- + ---------------------------------------------- + + -- Garbage_Collected is a Boolean constant whose value indicates the + -- effect of the pragma Finalize_Storage_Entry on a controlled type. + + -- Garbage_Collected = False + + -- The system releases all storage on program termination only, + -- but not other garbage collection occurs, so finalization calls + -- are omitted only for outer level objects can be omitted if + -- pragma Finalize_Storage_Only is used. + + -- Garbage_Collected = True + + -- The system provides full garbage collection, so it is never + -- necessary to release storage for controlled objects for which + -- a pragma Finalize_Storage_Only is used. + + Garbage_Collected : constant Boolean := False; + -- The storage mode for this system (release on program exit) + + --------------------- + -- Tasking Profile -- + --------------------- + + -- In the following sections, constant parameters are defined to + -- allow some optimizations and fine tuning within the tasking run time + -- based on restrictions on the tasking features. + + ---------------------- + -- Locking Strategy -- + ---------------------- + + Single_Lock : constant Boolean := False; + -- Indicates whether a single lock should be used within the tasking + -- run-time to protect internal structures. If True, a single lock + -- will be used, meaning less locking/unlocking operations, but also + -- more global contention. In general, Single_Lock should be set to + -- True on single processor machines, and to False to multi-processor + -- systems, but this can vary from application to application and also + -- depends on the scheduling policy. + + ------------------- + -- Task Abortion -- + ------------------- + + No_Abort : constant Boolean := False; + -- This constant indicates whether abort statements and asynchronous + -- transfer of control (ATC) are disallowed. If set to True, it is + -- assumed that neither construct is used, and the run time does not + -- need to defer/undefer abort and check for pending actions at + -- completion points. A value of True for No_Abort corresponds to: + -- pragma Restrictions (No_Abort_Statements); + -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); + + --------------------- + -- Task Attributes -- + --------------------- + + Default_Attribute_Count : constant := 4; + -- Number of pre-allocated Address-sized task attributes stored in the + -- task control block. + + -------------------- + -- Runtime Traces -- + -------------------- + + Runtime_Traces : constant Boolean := False; + -- This constant indicates whether the runtime outputs traces to a + -- predefined output or not (True means that traces are output). + -- See System.Traces for more details. + + ----------------------- + -- Task Image Length -- + ----------------------- + + Max_Task_Image_Length : constant := 32; + -- This constant specifies the maximum length of a task's image + + ------------------------------ + -- Exception Message Length -- + ------------------------------ + + Default_Exception_Msg_Max_Length : constant := 200; + -- This constant specifies the default number of characters to allow + -- in an exception message (200 is minimum required by RM 11.4.1(18)). + +end System.Parameters; diff --git a/gcc/ada/s-parame-hpux.ads b/gcc/ada/s-parame-hpux.ads new file mode 100644 index 000000000..38f8cb510 --- /dev/null +++ b/gcc/ada/s-parame-hpux.ads @@ -0,0 +1,202 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the HP version of this package + +-- This package defines some system dependent parameters for GNAT. These +-- are values that are referenced by the runtime library and are therefore +-- relevant to the target machine. + +-- The parameters whose value is defined in the spec are not generally +-- expected to be changed. If they are changed, it will be necessary to +-- recompile the run-time library. + +-- The parameters which are defined by functions can be changed by modifying +-- the body of System.Parameters in file s-parame.adb. A change to this body +-- requires only rebinding and relinking of the application. + +-- Note: do not introduce any pragma Inline statements into this unit, since +-- otherwise the relinking and rebinding capability would be deactivated. + +package System.Parameters is + pragma Pure; + + --------------------------------------- + -- Task And Stack Allocation Control -- + --------------------------------------- + + type Task_Storage_Size is new Integer; + -- Type used in tasking units for task storage size + + type Size_Type is new Task_Storage_Size; + -- Type used to provide task storage size to runtime + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Value used to indicate that no size type is set + + subtype Ratio is Size_Type range -1 .. 100; + Dynamic : constant Size_Type := -1; + -- The secondary stack ratio is a constant between 0 and 100 which + -- determines the percentage of the allocated task stack that is + -- used by the secondary stack (the rest being the primary stack). + -- The special value of minus one indicates that the secondary + -- stack is to be allocated from the heap instead. + + Sec_Stack_Ratio : constant Ratio := Dynamic; + -- This constant defines the handling of the secondary stack + + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; + -- Convenient Boolean for testing for dynamic secondary stack + + function Default_Stack_Size return Size_Type; + -- Default task stack size used if none is specified + + function Minimum_Stack_Size return Size_Type; + -- Minimum task stack size permitted + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type; + -- Given the storage size stored in the TCB, return the Storage_Size + -- value required by the RM for the Storage_Size attribute. The + -- required adjustment is as follows: + -- + -- when Size = Unspecified_Size, return Default_Stack_Size + -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size + -- otherwise return given Size + + Default_Env_Stack_Size : constant Size_Type := 8_192_000; + -- Assumed size of the environment task, if no other information + -- is available. This value is used when stack checking is + -- enabled and no GNAT_STACK_LIMIT environment variable is set. + + Stack_Grows_Down : constant Boolean := False; + -- This constant indicates whether the stack grows up (False) or + -- down (True) in memory as functions are called. It is used for + -- proper implementation of the stack overflow check. + + ---------------------------------------------- + -- Characteristics of Types in Interfaces.C -- + ---------------------------------------------- + + long_bits : constant := Long_Integer'Size; + -- Number of bits in type long and unsigned_long. The normal convention + -- is that this is the same as type Long_Integer, but this is not true + -- of all targets. For example, in OpenVMS long /= Long_Integer. + + ---------------------------------------------- + -- Behavior of Pragma Finalize_Storage_Only -- + ---------------------------------------------- + + -- Garbage_Collected is a Boolean constant whose value indicates the + -- effect of the pragma Finalize_Storage_Entry on a controlled type. + + -- Garbage_Collected = False + + -- The system releases all storage on program termination only, + -- but not other garbage collection occurs, so finalization calls + -- are omitted only for outer level objects can be omitted if + -- pragma Finalize_Storage_Only is used. + + -- Garbage_Collected = True + + -- The system provides full garbage collection, so it is never + -- necessary to release storage for controlled objects for which + -- a pragma Finalize_Storage_Only is used. + + Garbage_Collected : constant Boolean := False; + -- The storage mode for this system (release on program exit) + + --------------------- + -- Tasking Profile -- + --------------------- + + -- In the following sections, constant parameters are defined to + -- allow some optimizations and fine tuning within the tasking run time + -- based on restrictions on the tasking features. + + ---------------------- + -- Locking Strategy -- + ---------------------- + + Single_Lock : constant Boolean := False; + -- Indicates whether a single lock should be used within the tasking + -- run-time to protect internal structures. If True, a single lock + -- will be used, meaning less locking/unlocking operations, but also + -- more global contention. In general, Single_Lock should be set to + -- True on single processor machines, and to False to multi-processor + -- systems, but this can vary from application to application and also + -- depends on the scheduling policy. + + ------------------- + -- Task Abortion -- + ------------------- + + No_Abort : constant Boolean := False; + -- This constant indicates whether abort statements and asynchronous + -- transfer of control (ATC) are disallowed. If set to True, it is + -- assumed that neither construct is used, and the run time does not + -- need to defer/undefer abort and check for pending actions at + -- completion points. A value of True for No_Abort corresponds to: + -- pragma Restrictions (No_Abort_Statements); + -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); + + --------------------- + -- Task Attributes -- + --------------------- + + Default_Attribute_Count : constant := 4; + -- Number of pre-allocated Address-sized task attributes stored in the + -- task control block. + + -------------------- + -- Runtime Traces -- + -------------------- + + Runtime_Traces : constant Boolean := False; + -- This constant indicates whether the runtime outputs traces to a + -- predefined output or not (True means that traces are output). + -- See System.Traces for more details. + + ----------------------- + -- Task Image Length -- + ----------------------- + + Max_Task_Image_Length : constant := 256; + -- This constant specifies the maximum length of a task's image + + ------------------------------ + -- Exception Message Length -- + ------------------------------ + + Default_Exception_Msg_Max_Length : constant := 200; + -- This constant specifies the default number of characters to allow + -- in an exception message (200 is minimum required by RM 11.4.1(18)). + +end System.Parameters; diff --git a/gcc/ada/s-parame-rtems.adb b/gcc/ada/s-parame-rtems.adb new file mode 100644 index 000000000..aa131147e --- /dev/null +++ b/gcc/ada/s-parame-rtems.adb @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the RTEMS specific version + +with Interfaces.C; + +package body System.Parameters is + + function ada_pthread_minimum_stack_size return Interfaces.C.size_t; + pragma Import (C, ada_pthread_minimum_stack_size, + "_ada_pthread_minimum_stack_size"); + + ------------------------ + -- Default_Stack_Size -- + ------------------------ + + function Default_Stack_Size return Size_Type is + begin + return Size_Type (ada_pthread_minimum_stack_size); + end Default_Stack_Size; + + ------------------------ + -- Minimum_Stack_Size -- + ------------------------ + + function Minimum_Stack_Size return Size_Type is + + begin + return Size_Type (ada_pthread_minimum_stack_size); + end Minimum_Stack_Size; + + ------------------------- + -- Adjust_Storage_Size -- + ------------------------- + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type is + begin + if Size = Unspecified_Size then + return Default_Stack_Size; + + elsif Size < Minimum_Stack_Size then + return Minimum_Stack_Size; + + else + return Size; + end if; + end Adjust_Storage_Size; + +end System.Parameters; diff --git a/gcc/ada/s-parame-vms-alpha.ads b/gcc/ada/s-parame-vms-alpha.ads new file mode 100644 index 000000000..5e1d24e4f --- /dev/null +++ b/gcc/ada/s-parame-vms-alpha.ads @@ -0,0 +1,204 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 OpenVMS Alpha version + +-- This package defines some system dependent parameters for GNAT. These +-- are values that are referenced by the runtime library and are therefore +-- relevant to the target machine. + +-- The parameters whose value is defined in the spec are not generally +-- expected to be changed. If they are changed, it will be necessary to +-- recompile the run-time library. + +-- The parameters which are defined by functions can be changed by modifying +-- the body of System.Parameters in file s-parame.adb. A change to this body +-- requires only rebinding and relinking of the application. + +-- Note: do not introduce any pragma Inline statements into this unit, since +-- otherwise the relinking and rebinding capability would be deactivated. + +package System.Parameters is + pragma Pure; + + --------------------------------------- + -- Task And Stack Allocation Control -- + --------------------------------------- + + type Task_Storage_Size is new Integer; + -- Type used in tasking units for task storage size + + type Size_Type is new Task_Storage_Size; + -- Type used to provide task storage size to runtime + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Value used to indicate that no size type is set + + subtype Ratio is Size_Type range -1 .. 100; + Dynamic : constant Size_Type := -1; + -- The secondary stack ratio is a constant between 0 and 100 which + -- determines the percentage of the allocated task stack that is + -- used by the secondary stack (the rest being the primary stack). + -- The special value of minus one indicates that the secondary + -- stack is to be allocated from the heap instead. + + Sec_Stack_Ratio : constant Ratio := Dynamic; + -- This constant defines the handling of the secondary stack + + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; + -- Convenient Boolean for testing for dynamic secondary stack + + function Default_Stack_Size return Size_Type; + -- Default task stack size used if none is specified + + function Minimum_Stack_Size return Size_Type; + -- Minimum task stack size permitted + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type; + -- Given the storage size stored in the TCB, return the Storage_Size + -- value required by the RM for the Storage_Size attribute. The + -- required adjustment is as follows: + -- + -- when Size = Unspecified_Size, return Default_Stack_Size + -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size + -- otherwise return given Size + + Default_Env_Stack_Size : constant Size_Type := 8_192_000; + -- Assumed size of the environment task, if no other information + -- is available. This value is used when stack checking is + -- enabled and no GNAT_STACK_LIMIT environment variable is set. + + Stack_Grows_Down : constant Boolean := True; + -- This constant indicates whether the stack grows up (False) or + -- down (True) in memory as functions are called. It is used for + -- proper implementation of the stack overflow check. + + ---------------------------------------------- + -- Characteristics of types in Interfaces.C -- + ---------------------------------------------- + + long_bits : constant := 32; + -- Number of bits in type long and unsigned_long. The normal convention + -- is that this is the same as type Long_Integer, but this is not true + -- of all targets. For example, in OpenVMS long /= Long_Integer. + + ---------------------------------------------- + -- Behavior of Pragma Finalize_Storage_Only -- + ---------------------------------------------- + + -- Garbage_Collected is a Boolean constant whose value indicates the + -- effect of the pragma Finalize_Storage_Entry on a controlled type. + + -- Garbage_Collected = False + + -- The system releases all storage on program termination only, + -- but not other garbage collection occurs, so finalization calls + -- are omitted only for outer level objects can be omitted if + -- pragma Finalize_Storage_Only is used. + + -- Garbage_Collected = True + + -- The system provides full garbage collection, so it is never + -- necessary to release storage for controlled objects for which + -- a pragma Finalize_Storage_Only is used. + + Garbage_Collected : constant Boolean := False; + -- The storage mode for this system (release on program exit) + + --------------------- + -- Tasking Profile -- + --------------------- + + -- In the following sections, constant parameters are defined to + -- allow some optimizations and fine tuning within the tasking run time + -- based on restrictions on the tasking features. + + ---------------------- + -- Locking Strategy -- + ---------------------- + + Single_Lock : constant Boolean := True; + -- Indicates whether a single lock should be used within the tasking + -- run-time to protect internal structures. If True, a single lock + -- will be used, meaning less locking/unlocking operations, but also + -- more global contention. In general, Single_Lock should be set to + -- True on single processor machines, and to False to multi-processor + -- systems, but this can vary from application to application and also + -- depends on the scheduling policy. + + ------------------- + -- Task Abortion -- + ------------------- + + No_Abort : constant Boolean := False; + -- This constant indicates whether abort statements and asynchronous + -- transfer of control (ATC) are disallowed. If set to True, it is + -- assumed that neither construct is used, and the run time does not + -- need to defer/undefer abort and check for pending actions at + -- completion points. A value of True for No_Abort corresponds to: + -- pragma Restrictions (No_Abort_Statements); + -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); + + --------------------- + -- Task Attributes -- + --------------------- + + Default_Attribute_Count : constant := 4; + -- Number of pre-allocated Address-sized task attributes stored in the + -- task control block. + + -------------------- + -- Runtime Traces -- + -------------------- + + Runtime_Traces : constant Boolean := False; + -- This constant indicates whether the runtime outputs traces to a + -- predefined output or not (True means that traces are output). + -- See System.Traces for more details. + + ----------------------- + -- Task Image Length -- + ----------------------- + + Max_Task_Image_Length : constant := 256; + -- This constant specifies the maximum length of a task's image + + ------------------------------ + -- Exception Message Length -- + ------------------------------ + + Default_Exception_Msg_Max_Length : constant := 512; + -- This constant specifies the maximum number of characters to allow in an + -- exception message (see RM 11.4.1(18)). The value for VMS exceeds the + -- default minimum of 200 to allow for the length of chained VMS condition + -- handling messages. + +end System.Parameters; diff --git a/gcc/ada/s-parame-vms-ia64.ads b/gcc/ada/s-parame-vms-ia64.ads new file mode 100644 index 000000000..029dfee75 --- /dev/null +++ b/gcc/ada/s-parame-vms-ia64.ads @@ -0,0 +1,204 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 Integrity OpenVMS version + +-- This package defines some system dependent parameters for GNAT. These +-- are values that are referenced by the runtime library and are therefore +-- relevant to the target machine. + +-- The parameters whose value is defined in the spec are not generally +-- expected to be changed. If they are changed, it will be necessary to +-- recompile the run-time library. + +-- The parameters which are defined by functions can be changed by modifying +-- the body of System.Parameters in file s-parame.adb. A change to this body +-- requires only rebinding and relinking of the application. + +-- Note: do not introduce any pragma Inline statements into this unit, since +-- otherwise the relinking and rebinding capability would be deactivated. + +package System.Parameters is + pragma Pure; + + --------------------------------------- + -- Task And Stack Allocation Control -- + --------------------------------------- + + type Task_Storage_Size is new Integer; + -- Type used in tasking units for task storage size + + type Size_Type is new Task_Storage_Size; + -- Type used to provide task storage size to runtime + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Value used to indicate that no size type is set + + subtype Ratio is Size_Type range -1 .. 100; + Dynamic : constant Size_Type := -1; + -- The secondary stack ratio is a constant between 0 and 100 which + -- determines the percentage of the allocated task stack that is + -- used by the secondary stack (the rest being the primary stack). + -- The special value of minus one indicates that the secondary + -- stack is to be allocated from the heap instead. + + Sec_Stack_Ratio : constant Ratio := Dynamic; + -- This constant defines the handling of the secondary stack + + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; + -- Convenient Boolean for testing for dynamic secondary stack + + function Default_Stack_Size return Size_Type; + -- Default task stack size used if none is specified + + function Minimum_Stack_Size return Size_Type; + -- Minimum task stack size permitted + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type; + -- Given the storage size stored in the TCB, return the Storage_Size + -- value required by the RM for the Storage_Size attribute. The + -- required adjustment is as follows: + -- + -- when Size = Unspecified_Size, return Default_Stack_Size + -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size + -- otherwise return given Size + + Default_Env_Stack_Size : constant Size_Type := 8_192_000; + -- Assumed size of the environment task, if no other information + -- is available. This value is used when stack checking is + -- enabled and no GNAT_STACK_LIMIT environment variable is set. + + Stack_Grows_Down : constant Boolean := True; + -- This constant indicates whether the stack grows up (False) or + -- down (True) in memory as functions are called. It is used for + -- proper implementation of the stack overflow check. + + ---------------------------------------------- + -- Characteristics of types in Interfaces.C -- + ---------------------------------------------- + + long_bits : constant := 32; + -- Number of bits in type long and unsigned_long. The normal convention + -- is that this is the same as type Long_Integer, but this is not true + -- of all targets. For example, in OpenVMS long /= Long_Integer. + + ---------------------------------------------- + -- Behavior of Pragma Finalize_Storage_Only -- + ---------------------------------------------- + + -- Garbage_Collected is a Boolean constant whose value indicates the + -- effect of the pragma Finalize_Storage_Entry on a controlled type. + + -- Garbage_Collected = False + + -- The system releases all storage on program termination only, + -- but not other garbage collection occurs, so finalization calls + -- are omitted only for outer level objects can be omitted if + -- pragma Finalize_Storage_Only is used. + + -- Garbage_Collected = True + + -- The system provides full garbage collection, so it is never + -- necessary to release storage for controlled objects for which + -- a pragma Finalize_Storage_Only is used. + + Garbage_Collected : constant Boolean := False; + -- The storage mode for this system (release on program exit) + + --------------------- + -- Tasking Profile -- + --------------------- + + -- In the following sections, constant parameters are defined to + -- allow some optimizations and fine tuning within the tasking run time + -- based on restrictions on the tasking features. + + ---------------------- + -- Locking Strategy -- + ---------------------- + + Single_Lock : constant Boolean := False; + -- Indicates whether a single lock should be used within the tasking + -- run-time to protect internal structures. If True, a single lock + -- will be used, meaning less locking/unlocking operations, but also + -- more global contention. In general, Single_Lock should be set to + -- True on single processor machines, and to False to multi-processor + -- systems, but this can vary from application to application and also + -- depends on the scheduling policy. + + ------------------- + -- Task Abortion -- + ------------------- + + No_Abort : constant Boolean := False; + -- This constant indicates whether abort statements and asynchronous + -- transfer of control (ATC) are disallowed. If set to True, it is + -- assumed that neither construct is used, and the run time does not + -- need to defer/undefer abort and check for pending actions at + -- completion points. A value of True for No_Abort corresponds to: + -- pragma Restrictions (No_Abort_Statements); + -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); + + --------------------- + -- Task Attributes -- + --------------------- + + Default_Attribute_Count : constant := 4; + -- Number of pre-allocated Address-sized task attributes stored in the + -- task control block. + + -------------------- + -- Runtime Traces -- + -------------------- + + Runtime_Traces : constant Boolean := False; + -- This constant indicates whether the runtime outputs traces to a + -- predefined output or not (True means that traces are output). + -- See System.Traces for more details. + + ----------------------- + -- Task Image Length -- + ----------------------- + + Max_Task_Image_Length : constant := 256; + -- This constant specifies the maximum length of a task's image + + ------------------------------ + -- Exception Message Length -- + ------------------------------ + + Default_Exception_Msg_Max_Length : constant := 512; + -- This constant specifies the maximum number of characters to allow in an + -- exception message (see RM 11.4.1(18)). The value for VMS exceeds the + -- default minimum of 200 to allow for the length of chained VMS condition + -- handling messages. + +end System.Parameters; diff --git a/gcc/ada/s-parame-vms-restrict.ads b/gcc/ada/s-parame-vms-restrict.ads new file mode 100644 index 000000000..3456f249f --- /dev/null +++ b/gcc/ada/s-parame-vms-restrict.ads @@ -0,0 +1,204 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 OpenVMS version for restricted tasking + +-- This package defines some system dependent parameters for GNAT. These +-- are values that are referenced by the runtime library and are therefore +-- relevant to the target machine. + +-- The parameters whose value is defined in the spec are not generally +-- expected to be changed. If they are changed, it will be necessary to +-- recompile the run-time library. + +-- The parameters which are defined by functions can be changed by modifying +-- the body of System.Parameters in file s-parame.adb. A change to this body +-- requires only rebinding and relinking of the application. + +-- Note: do not introduce any pragma Inline statements into this unit, since +-- otherwise the relinking and rebinding capability would be deactivated. + +package System.Parameters is + pragma Pure; + + --------------------------------------- + -- Task And Stack Allocation Control -- + --------------------------------------- + + type Task_Storage_Size is new Integer; + -- Type used in tasking units for task storage size + + type Size_Type is new Task_Storage_Size; + -- Type used to provide task storage size to runtime + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Value used to indicate that no size type is set + + subtype Ratio is Size_Type range -1 .. 100; + Dynamic : constant Size_Type := -1; + -- The secondary stack ratio is a constant between 0 and 100 which + -- determines the percentage of the allocated task stack that is + -- used by the secondary stack (the rest being the primary stack). + -- The special value of minus one indicates that the secondary + -- stack is to be allocated from the heap instead. + + Sec_Stack_Ratio : constant Ratio := Dynamic; + -- This constant defines the handling of the secondary stack + + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; + -- Convenient Boolean for testing for dynamic secondary stack + + function Default_Stack_Size return Size_Type; + -- Default task stack size used if none is specified + + function Minimum_Stack_Size return Size_Type; + -- Minimum task stack size permitted + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type; + -- Given the storage size stored in the TCB, return the Storage_Size + -- value required by the RM for the Storage_Size attribute. The + -- required adjustment is as follows: + -- + -- when Size = Unspecified_Size, return Default_Stack_Size + -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size + -- otherwise return given Size + + Default_Env_Stack_Size : constant Size_Type := 8_192_000; + -- Assumed size of the environment task, if no other information + -- is available. This value is used when stack checking is + -- enabled and no GNAT_STACK_LIMIT environment variable is set. + + Stack_Grows_Down : constant Boolean := True; + -- This constant indicates whether the stack grows up (False) or + -- down (True) in memory as functions are called. It is used for + -- proper implementation of the stack overflow check. + + ---------------------------------------------- + -- Characteristics of types in Interfaces.C -- + ---------------------------------------------- + + long_bits : constant := 32; + -- Number of bits in type long and unsigned_long. The normal convention + -- is that this is the same as type Long_Integer, but this is not true + -- of all targets. For example, in OpenVMS long /= Long_Integer. + + ---------------------------------------------- + -- Behavior of Pragma Finalize_Storage_Only -- + ---------------------------------------------- + + -- Garbage_Collected is a Boolean constant whose value indicates the + -- effect of the pragma Finalize_Storage_Entry on a controlled type. + + -- Garbage_Collected = False + + -- The system releases all storage on program termination only, + -- but not other garbage collection occurs, so finalization calls + -- are omitted only for outer level objects can be omitted if + -- pragma Finalize_Storage_Only is used. + + -- Garbage_Collected = True + + -- The system provides full garbage collection, so it is never + -- necessary to release storage for controlled objects for which + -- a pragma Finalize_Storage_Only is used. + + Garbage_Collected : constant Boolean := False; + -- The storage mode for this system (release on program exit) + + --------------------- + -- Tasking Profile -- + --------------------- + + -- In the following sections, constant parameters are defined to + -- allow some optimizations and fine tuning within the tasking run time + -- based on restrictions on the tasking features. + + ---------------------- + -- Locking Strategy -- + ---------------------- + + Single_Lock : constant Boolean := True; + -- Indicates whether a single lock should be used within the tasking + -- run-time to protect internal structures. If True, a single lock + -- will be used, meaning less locking/unlocking operations, but also + -- more global contention. In general, Single_Lock should be set to + -- True on single processor machines, and to False to multi-processor + -- systems, but this can vary from application to application and also + -- depends on the scheduling policy. + + ------------------- + -- Task Abortion -- + ------------------- + + No_Abort : constant Boolean := True; + -- This constant indicates whether abort statements and asynchronous + -- transfer of control (ATC) are disallowed. If set to True, it is + -- assumed that neither construct is used, and the run time does not + -- need to defer/undefer abort and check for pending actions at + -- completion points. A value of True for No_Abort corresponds to: + -- pragma Restrictions (No_Abort_Statements); + -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); + + --------------------- + -- Task Attributes -- + --------------------- + + Default_Attribute_Count : constant := 4; + -- Number of pre-allocated Address-sized task attributes stored in the + -- task control block. + + -------------------- + -- Runtime Traces -- + -------------------- + + Runtime_Traces : constant Boolean := False; + -- This constant indicates whether the runtime outputs traces to a + -- predefined output or not (True means that traces are output). + -- See System.Traces for more details. + + ----------------------- + -- Task Image Length -- + ----------------------- + + Max_Task_Image_Length : constant := 256; + -- This constant specifies the maximum length of a task's image + + ------------------------------ + -- Exception Message Length -- + ------------------------------ + + Default_Exception_Msg_Max_Length : constant := 512; + -- This constant specifies the maximum number of characters to allow in an + -- exception message (see RM 11.4.1(18)). The value for VMS exceeds the + -- default minimum of 200 to allow for the length of chained VMS condition + -- handling messages. + +end System.Parameters; diff --git a/gcc/ada/s-parame-vxworks.adb b/gcc/ada/s-parame-vxworks.adb new file mode 100644 index 000000000..eb9ed6926 --- /dev/null +++ b/gcc/ada/s-parame-vxworks.adb @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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, Nucleus, and RTX RTSS 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 + return 20 * 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 + return 8 * 1024; + end Minimum_Stack_Size; + +end System.Parameters; diff --git a/gcc/ada/s-parame-vxworks.ads b/gcc/ada/s-parame-vxworks.ads new file mode 100644 index 000000000..411d67d84 --- /dev/null +++ b/gcc/ada/s-parame-vxworks.ads @@ -0,0 +1,204 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the default VxWorks version of the package + +-- This package defines some system dependent parameters for GNAT. These +-- are values that are referenced by the runtime library and are therefore +-- relevant to the target machine. + +-- The parameters whose value is defined in the spec are not generally +-- expected to be changed. If they are changed, it will be necessary to +-- recompile the run-time library. + +-- The parameters which are defined by functions can be changed by modifying +-- the body of System.Parameters in file s-parame.adb. A change to this body +-- requires only rebinding and relinking of the application. + +-- Note: do not introduce any pragma Inline statements into this unit, since +-- otherwise the relinking and rebinding capability would be deactivated. + +package System.Parameters is + pragma Pure; + + --------------------------------------- + -- Task And Stack Allocation Control -- + --------------------------------------- + + type Task_Storage_Size is new Integer; + -- Type used in tasking units for task storage size + + type Size_Type is new Task_Storage_Size; + -- Type used to provide task storage size to runtime + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Value used to indicate that no size type is set + + subtype Ratio is Size_Type range -1 .. 100; + Dynamic : constant Size_Type := -1; + -- The secondary stack ratio is a constant between 0 and 100 which + -- determines the percentage of the allocated task stack that is + -- used by the secondary stack (the rest being the primary stack). + -- The special value of minus one indicates that the secondary + -- stack is to be allocated from the heap instead. + + Sec_Stack_Ratio : constant Ratio := Dynamic; + -- This constant defines the handling of the secondary stack + + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; + -- Convenient Boolean for testing for dynamic secondary stack + + function Default_Stack_Size return Size_Type; + -- Default task stack size used if none is specified + + function Minimum_Stack_Size return Size_Type; + -- Minimum task stack size permitted + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type; + -- Given the storage size stored in the TCB, return the Storage_Size + -- value required by the RM for the Storage_Size attribute. The + -- required adjustment is as follows: + -- + -- when Size = Unspecified_Size, return Default_Stack_Size + -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size + -- otherwise return given Size + + Default_Env_Stack_Size : constant Size_Type := 14_336; + -- Assumed size of the environment task, if no other information + -- is available. This value is used when stack checking is + -- enabled and no GNAT_STACK_LIMIT environment variable is set. + -- This value is chosen as the VxWorks default stack size is 20kB, + -- and a little more than 4kB is necessary for the run time. + + Stack_Grows_Down : constant Boolean := True; + -- This constant indicates whether the stack grows up (False) or + -- down (True) in memory as functions are called. It is used for + -- proper implementation of the stack overflow check. + + ---------------------------------------------- + -- Characteristics of types in Interfaces.C -- + ---------------------------------------------- + + long_bits : constant := Long_Integer'Size; + -- Number of bits in type long and unsigned_long. The normal convention + -- is that this is the same as type Long_Integer, but this is not true + -- of all targets. For example, in OpenVMS long /= Long_Integer. + + ---------------------------------------------- + -- Behavior of Pragma Finalize_Storage_Only -- + ---------------------------------------------- + + -- Garbage_Collected is a Boolean constant whose value indicates the + -- effect of the pragma Finalize_Storage_Entry on a controlled type. + + -- Garbage_Collected = False + + -- The system releases all storage on program termination only, + -- but not other garbage collection occurs, so finalization calls + -- are omitted only for outer level objects can be omitted if + -- pragma Finalize_Storage_Only is used. + + -- Garbage_Collected = True + + -- The system provides full garbage collection, so it is never + -- necessary to release storage for controlled objects for which + -- a pragma Finalize_Storage_Only is used. + + Garbage_Collected : constant Boolean := False; + -- The storage mode for this system (release on program exit) + + --------------------- + -- Tasking Profile -- + --------------------- + + -- In the following sections, constant parameters are defined to + -- allow some optimizations and fine tuning within the tasking run time + -- based on restrictions on the tasking features. + + ---------------------- + -- Locking Strategy -- + ---------------------- + + Single_Lock : constant Boolean := False; + -- Indicates whether a single lock should be used within the tasking + -- run-time to protect internal structures. If True, a single lock + -- will be used, meaning less locking/unlocking operations, but also + -- more global contention. In general, Single_Lock should be set to + -- True on single processor machines, and to False to multi-processor + -- systems, but this can vary from application to application and also + -- depends on the scheduling policy. + + ------------------- + -- Task Abortion -- + ------------------- + + No_Abort : constant Boolean := False; + -- This constant indicates whether abort statements and asynchronous + -- transfer of control (ATC) are disallowed. If set to True, it is + -- assumed that neither construct is used, and the run time does not + -- need to defer/undefer abort and check for pending actions at + -- completion points. A value of True for No_Abort corresponds to: + -- pragma Restrictions (No_Abort_Statements); + -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); + + --------------------- + -- Task Attributes -- + --------------------- + + Default_Attribute_Count : constant := 4; + -- Number of pre-allocated Address-sized task attributes stored in the + -- task control block. + + -------------------- + -- Runtime Traces -- + -------------------- + + Runtime_Traces : constant Boolean := False; + -- This constant indicates whether the runtime outputs traces to a + -- predefined output or not (True means that traces are output). + -- See System.Traces for more details. + + ----------------------- + -- Task Image Length -- + ----------------------- + + Max_Task_Image_Length : constant := 32; + -- This constant specifies the maximum length of a task's image + + ------------------------------ + -- Exception Message Length -- + ------------------------------ + + Default_Exception_Msg_Max_Length : constant := 200; + -- This constant specifies the default number of characters to allow + -- in an exception message (200 is minimum required by RM 11.4.1(18)). + +end System.Parameters; diff --git a/gcc/ada/s-parame.adb b/gcc/ada/s-parame.adb new file mode 100644 index 000000000..ff61b7ee5 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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; + +package body System.Parameters is + + ------------------------- + -- Adjust_Storage_Size -- + ------------------------- + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type is + begin + if Size = Unspecified_Size then + return Default_Stack_Size; + elsif Size < Minimum_Stack_Size then + return Minimum_Stack_Size; + else + return Size; + end if; + end Adjust_Storage_Size; + + ------------------------ + -- Default_Stack_Size -- + ------------------------ + + function Default_Stack_Size return Size_Type is + Default_Stack_Size : Integer; + pragma Import (C, Default_Stack_Size, "__gl_default_stack_size"); + begin + if Default_Stack_Size = -1 then + return 2 * 1024 * 1024; + else + return Size_Type (Default_Stack_Size); + end if; + end Default_Stack_Size; + + ------------------------ + -- Minimum_Stack_Size -- + ------------------------ + + function Minimum_Stack_Size return Size_Type is + begin + -- 12K is required for stack-checking to work reliably on most platforms + -- when using the GCC scheme to propagate an exception in the ZCX case. + -- 16K is the value of PTHREAD_STACK_MIN under Linux, so is a reasonable + -- default. + + return 16 * 1024; + end Minimum_Stack_Size; + +end System.Parameters; diff --git a/gcc/ada/s-parame.ads b/gcc/ada/s-parame.ads new file mode 100644 index 000000000..2110034ec --- /dev/null +++ b/gcc/ada/s-parame.ads @@ -0,0 +1,204 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Default version used when no target-specific version is provided + +-- This package defines some system dependent parameters for GNAT. These +-- are values that are referenced by the runtime library and are therefore +-- relevant to the target machine. + +-- The parameters whose value is defined in the spec are not generally +-- expected to be changed. If they are changed, it will be necessary to +-- recompile the run-time library. + +-- The parameters which are defined by functions can be changed by modifying +-- the body of System.Parameters in file s-parame.adb. A change to this body +-- requires only rebinding and relinking of the application. + +-- Note: do not introduce any pragma Inline statements into this unit, since +-- otherwise the relinking and rebinding capability would be deactivated. + +pragma Compiler_Unit; + +package System.Parameters is + pragma Pure; + + --------------------------------------- + -- Task And Stack Allocation Control -- + --------------------------------------- + + type Task_Storage_Size is new Integer; + -- Type used in tasking units for task storage size + + type Size_Type is new Task_Storage_Size; + -- Type used to provide task storage size to runtime + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Value used to indicate that no size type is set + + subtype Ratio is Size_Type range -1 .. 100; + Dynamic : constant Size_Type := -1; + -- The secondary stack ratio is a constant between 0 and 100 which + -- determines the percentage of the allocated task stack that is + -- used by the secondary stack (the rest being the primary stack). + -- The special value of minus one indicates that the secondary + -- stack is to be allocated from the heap instead. + + Sec_Stack_Ratio : constant Ratio := Dynamic; + -- This constant defines the handling of the secondary stack + + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; + -- Convenient Boolean for testing for dynamic secondary stack + + function Default_Stack_Size return Size_Type; + -- Default task stack size used if none is specified + + function Minimum_Stack_Size return Size_Type; + -- Minimum task stack size permitted + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type; + -- Given the storage size stored in the TCB, return the Storage_Size + -- value required by the RM for the Storage_Size attribute. The + -- required adjustment is as follows: + -- + -- when Size = Unspecified_Size, return Default_Stack_Size + -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size + -- otherwise return given Size + + Default_Env_Stack_Size : constant Size_Type := 8_192_000; + -- Assumed size of the environment task, if no other information + -- is available. This value is used when stack checking is + -- enabled and no GNAT_STACK_LIMIT environment variable is set. + + Stack_Grows_Down : constant Boolean := True; + -- This constant indicates whether the stack grows up (False) or + -- down (True) in memory as functions are called. It is used for + -- proper implementation of the stack overflow check. + + ---------------------------------------------- + -- Characteristics of types in Interfaces.C -- + ---------------------------------------------- + + long_bits : constant := Long_Integer'Size; + -- Number of bits in type long and unsigned_long. The normal convention + -- is that this is the same as type Long_Integer, but this is not true + -- of all targets. For example, in OpenVMS long /= Long_Integer. + + ---------------------------------------------- + -- Behavior of Pragma Finalize_Storage_Only -- + ---------------------------------------------- + + -- Garbage_Collected is a Boolean constant whose value indicates the + -- effect of the pragma Finalize_Storage_Entry on a controlled type. + + -- Garbage_Collected = False + + -- The system releases all storage on program termination only, + -- but not other garbage collection occurs, so finalization calls + -- are omitted only for outer level objects can be omitted if + -- pragma Finalize_Storage_Only is used. + + -- Garbage_Collected = True + + -- The system provides full garbage collection, so it is never + -- necessary to release storage for controlled objects for which + -- a pragma Finalize_Storage_Only is used. + + Garbage_Collected : constant Boolean := False; + -- The storage mode for this system (release on program exit) + + --------------------- + -- Tasking Profile -- + --------------------- + + -- In the following sections, constant parameters are defined to + -- allow some optimizations and fine tuning within the tasking run time + -- based on restrictions on the tasking features. + + ---------------------- + -- Locking Strategy -- + ---------------------- + + Single_Lock : constant Boolean := False; + -- Indicates whether a single lock should be used within the tasking + -- run-time to protect internal structures. If True, a single lock + -- will be used, meaning less locking/unlocking operations, but also + -- more global contention. In general, Single_Lock should be set to + -- True on single processor machines, and to False to multi-processor + -- systems, but this can vary from application to application and also + -- depends on the scheduling policy. + + ------------------- + -- Task Abortion -- + ------------------- + + No_Abort : constant Boolean := False; + -- This constant indicates whether abort statements and asynchronous + -- transfer of control (ATC) are disallowed. If set to True, it is + -- assumed that neither construct is used, and the run time does not + -- need to defer/undefer abort and check for pending actions at + -- completion points. A value of True for No_Abort corresponds to: + -- pragma Restrictions (No_Abort_Statements); + -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); + + --------------------- + -- Task Attributes -- + --------------------- + + Default_Attribute_Count : constant := 4; + -- Number of pre-allocated Address-sized task attributes stored in the + -- task control block. + + -------------------- + -- Runtime Traces -- + -------------------- + + Runtime_Traces : constant Boolean := False; + -- This constant indicates whether the runtime outputs traces to a + -- predefined output or not (True means that traces are output). + -- See System.Traces for more details. + + ----------------------- + -- Task Image Length -- + ----------------------- + + Max_Task_Image_Length : constant := 256; + -- This constant specifies the maximum length of a task's image + + ------------------------------ + -- Exception Message Length -- + ------------------------------ + + Default_Exception_Msg_Max_Length : constant := 200; + -- This constant specifies the default number of characters to allow + -- in an exception message (200 is minimum required by RM 11.4.1(18)). + +end System.Parameters; diff --git a/gcc/ada/s-parint.adb b/gcc/ada/s-parint.adb new file mode 100644 index 000000000..53cc49cdb --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..3086d4210 --- /dev/null +++ b/gcc/ada/s-parint.ads @@ -0,0 +1,190 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 Gnatvsn.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 new file mode 100644 index 000000000..35bdf6410 --- /dev/null +++ b/gcc/ada/s-pooglo.adb @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 -- + -------------- + + procedure Allocate + (Pool : in out Unbounded_No_Reclaim_Pool; + Address : out System.Address; + Storage_Size : SSE.Storage_Count; + Alignment : SSE.Storage_Count) + is + pragma Warnings (Off, Pool); + pragma Warnings (Off, Alignment); + + Allocated : System.Address; + + begin + Allocated := Memory.Alloc (Memory.size_t (Storage_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; + else + Address := Allocated; + end if; + end Allocate; + + ---------------- + -- Deallocate -- + ---------------- + + procedure Deallocate + (Pool : in out Unbounded_No_Reclaim_Pool; + Address : System.Address; + Storage_Size : SSE.Storage_Count; + Alignment : SSE.Storage_Count) + is + pragma Warnings (Off, Pool); + pragma Warnings (Off, Storage_Size); + pragma Warnings (Off, Alignment); + + begin + Memory.Free (Address); + end Deallocate; + + ------------------ + -- Storage_Size -- + ------------------ + + 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 new file mode 100644 index 000000000..ae2e1af86 --- /dev/null +++ b/gcc/ada/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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + + 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 : Unbounded_No_Reclaim_Pool; + +end System.Pool_Global; diff --git a/gcc/ada/s-pooloc.adb b/gcc/ada/s-pooloc.adb new file mode 100644 index 000000000..37370e502 --- /dev/null +++ b/gcc/ada/s-pooloc.adb @@ -0,0 +1,160 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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; + Prev (Pool.First).all := Null_Address; + 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 new file mode 100644 index 000000000..34ee93d5b --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..c2dd03bf5 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..974e7b6ec --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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; + + function Storage_Size + (Pool : Stack_Bounded_Pool) return System.Storage_Elements.Storage_Count; + + 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); + + procedure Deallocate + (Pool : in out Stack_Bounded_Pool; + Address : System.Address; + Storage_Size : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count); + + 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 new file mode 100644 index 000000000..ea1820b13 --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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-proinf-irix-athread.adb b/gcc/ada/s-proinf-irix-athread.adb new file mode 100644 index 000000000..31e4dccf8 --- /dev/null +++ b/gcc/ada/s-proinf-irix-athread.adb @@ -0,0 +1,225 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P R O G R A M _ I N F 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an Irix (old pthread library) version of this package + +-- This package contains the parameters used by the run-time system at +-- program startup. These parameters are isolated in this package body to +-- facilitate replacement by the end user. +-- +-- To replace the default values, copy this source file into your build +-- directory, edit the file to reflect your desired behavior, and recompile +-- with the command: +-- +-- % gcc -c -O2 -gnatpg s-proinf.adb +-- +-- then relink your application as usual. + +pragma Warnings (Off); -- why??? +with System.OS_Lib; +pragma Warnings (On); + +package body System.Program_Info is + + Kbytes : constant := 1024; + + Default_Initial_Sproc_Count : constant := 0; + Default_Max_Sproc_Count : constant := 128; + Default_Sproc_Stack_Size : constant := 16#4000#; + Default_Stack_Guard_Pages : constant := 1; + Default_Default_Time_Slice : constant := 0.0; + Default_Default_Task_Stack : constant := 12 * Kbytes; + Default_Pthread_Sched_Signal : constant := 35; + Default_Pthread_Arena_Size : constant := 16#40000#; + Default_Os_Default_Priority : constant := 0; + + ------------------------- + -- Initial_Sproc_Count -- + ------------------------- + + function Initial_Sproc_Count return Integer is + + function sysmp (P1 : Integer) return Integer; + pragma Import (C, sysmp, "sysmp", "sysmp"); + + MP_NPROCS : constant := 1; -- # processor in complex + + Pthread_Sproc_Count : constant System.OS_Lib.String_Access := + System.OS_Lib.Getenv ("PTHREAD_SPROC_COUNT"); + + begin + if Pthread_Sproc_Count.all'Length = 0 then + return Default_Initial_Sproc_Count; + + elsif Pthread_Sproc_Count.all = "AUTO" then + return sysmp (MP_NPROCS); + + else + return Integer'Value (Pthread_Sproc_Count.all); + end if; + + exception + when others => + return Default_Initial_Sproc_Count; + end Initial_Sproc_Count; + + --------------------- + -- Max_Sproc_Count -- + --------------------- + + function Max_Sproc_Count return Integer is + Pthread_Max_Sproc_Count : constant System.OS_Lib.String_Access := + System.OS_Lib.Getenv ("PTHREAD_MAX_SPROC_COUNT"); + + begin + if Pthread_Max_Sproc_Count.all'Length = 0 then + return Default_Max_Sproc_Count; + else + return Integer'Value (Pthread_Max_Sproc_Count.all); + end if; + exception + when others => + return Default_Max_Sproc_Count; + end Max_Sproc_Count; + + ---------------------- + -- Sproc_Stack_Size -- + ---------------------- + + function Sproc_Stack_Size return Integer is + begin + return Default_Sproc_Stack_Size; + end Sproc_Stack_Size; + + ------------------------ + -- Default_Time_Slice -- + ------------------------ + + function Default_Time_Slice return Duration is + Pthread_Time_Slice_Sec : constant System.OS_Lib.String_Access := + System.OS_Lib.Getenv + ("PTHREAD_TIME_SLICE_SEC"); + Pthread_Time_Slice_Usec : constant System.OS_Lib.String_Access := + System.OS_Lib.Getenv + ("PTHREAD_TIME_SLICE_USEC"); + + Val_Sec, Val_Usec : Integer := 0; + + begin + if Pthread_Time_Slice_Sec.all'Length /= 0 or + Pthread_Time_Slice_Usec.all'Length /= 0 + then + if Pthread_Time_Slice_Sec.all'Length /= 0 then + Val_Sec := Integer'Value (Pthread_Time_Slice_Sec.all); + end if; + + if Pthread_Time_Slice_Usec.all'Length /= 0 then + Val_Usec := Integer'Value (Pthread_Time_Slice_Usec.all); + end if; + + return Duration (Val_Sec) + Duration (Val_Usec) / 1000.0; + else + return Default_Default_Time_Slice; + end if; + + exception + when others => + return Default_Default_Time_Slice; + end Default_Time_Slice; + + ------------------------ + -- Default_Task_Stack -- + ------------------------ + + function Default_Task_Stack return Integer is + begin + return Default_Default_Task_Stack; + end Default_Task_Stack; + + ----------------------- + -- Stack_Guard_Pages -- + ----------------------- + + function Stack_Guard_Pages return Integer is + Pthread_Stack_Guard_Pages : constant System.OS_Lib.String_Access := + System.OS_Lib.Getenv + ("PTHREAD_STACK_GUARD_PAGES"); + begin + if Pthread_Stack_Guard_Pages.all'Length /= 0 then + return Integer'Value (Pthread_Stack_Guard_Pages.all); + else + return Default_Stack_Guard_Pages; + end if; + exception + when others => + return Default_Stack_Guard_Pages; + end Stack_Guard_Pages; + + -------------------------- + -- Pthread_Sched_Signal -- + -------------------------- + + function Pthread_Sched_Signal return Integer is + begin + return Default_Pthread_Sched_Signal; + end Pthread_Sched_Signal; + + ------------------------ + -- Pthread_Arena_Size -- + ------------------------ + + function Pthread_Arena_Size return Integer is + Pthread_Arena_Size : constant System.OS_Lib.String_Access := + System.OS_Lib.Getenv + ("PTHREAD_ARENA_SIZE"); + + begin + if Pthread_Arena_Size.all'Length = 0 then + return Default_Pthread_Arena_Size; + else + return Integer'Value (Pthread_Arena_Size.all); + end if; + + exception + when others => + return Default_Pthread_Arena_Size; + end Pthread_Arena_Size; + + ------------------------- + -- Os_Default_Priority -- + ------------------------- + + function Os_Default_Priority return Integer is + begin + return Default_Os_Default_Priority; + end Os_Default_Priority; + +end System.Program_Info; diff --git a/gcc/ada/s-proinf-irix-athread.ads b/gcc/ada/s-proinf-irix-athread.ads new file mode 100644 index 000000000..8c24a5502 --- /dev/null +++ b/gcc/ada/s-proinf-irix-athread.ads @@ -0,0 +1,76 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P R O G R A M _ I N F 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 package contains the definitions and routines used as parameters to +-- the run-time system at program startup for the SGI implementation. + +package System.Program_Info is + pragma Preelaborate; + + function Initial_Sproc_Count return Integer; + -- The number of sproc created at program startup for scheduling threads + + function Max_Sproc_Count return Integer; + -- The maximum number of sprocs that can be created by the program for + -- servicing threads. This limit includes both the pre-created sprocs and + -- those explicitly created under program control. + + function Sproc_Stack_Size return Integer; + -- The size, in bytes, of the sproc's initial stack + + function Default_Time_Slice return Duration; + -- The default time quanta for round-robin scheduling of threads of + -- equal priority. This default value can be overridden on a per-task + -- basis by specifying an alternate value via the implementation-defined + -- Task_Info pragma. See s-tasinf.ads for more information. + + function Default_Task_Stack return Integer; + -- The default stack size for each created thread. This default value can + -- be overridden on a per-task basis by the language-defined Storage_Size + -- pragma. + + function Stack_Guard_Pages return Integer; + -- The number of non-writable, guard pages to append to the bottom of + -- each thread's stack. + + function Pthread_Sched_Signal return Integer; + -- The signal used by the Pthreads library to affect scheduling actions + -- in remote sprocs. + + function Pthread_Arena_Size return Integer; + -- The size of the shared arena from which pthread locks are allocated. + -- See the usinit(3p) man page for more information on shared arenas. + + function Os_Default_Priority return Integer; + -- The default Irix Non-Degrading priority for each sproc created to + -- service threads. + +end System.Program_Info; diff --git a/gcc/ada/s-proinf.adb b/gcc/ada/s-proinf.adb new file mode 100644 index 000000000..308b207b0 --- /dev/null +++ b/gcc/ada/s-proinf.adb @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P R O G R A M _ I N F O -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Program_Info is + + Default_Stack_Size : constant := 10000; + + function Default_Task_Stack return Integer is + begin + return Default_Stack_Size; + end Default_Task_Stack; + +end System.Program_Info; diff --git a/gcc/ada/s-proinf.ads b/gcc/ada/s-proinf.ads new file mode 100644 index 000000000..beff34238 --- /dev/null +++ b/gcc/ada/s-proinf.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P R O G R A M _ I N F O -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the definitions and routines used as parameters +-- to the run-time system at program startup. + +package System.Program_Info is + pragma Preelaborate; + + function Default_Task_Stack return Integer; + -- The default stack size for each created thread. This default value + -- can be overridden on a per-task basis by the language-defined + -- Storage_Size pragma. + +end System.Program_Info; diff --git a/gcc/ada/s-purexc.ads b/gcc/ada/s-purexc.ads new file mode 100644 index 000000000..a327f48bf --- /dev/null +++ b/gcc/ada/s-purexc.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P U R E _ E X C E P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface for raising predefined exceptions with +-- an exception message. It can be used from Pure units. This unit is for +-- internal use only, it is not generally available to applications. + +pragma Compiler_Unit; + +package System.Pure_Exceptions is + pragma Pure; + + type Exception_Type is limited null record; + -- Type used to specify which exception to raise + + -- Really Exception_Type is Exception_Id, but Exception_Id can't be + -- used directly since it is declared in the non-pure unit Ada.Exceptions, + + -- Exception_Id is in fact simply a pointer to the type Exception_Data + -- declared in System.Standard_Library (which is also non-pure). So what + -- we do is to define it here as a by reference type (any by reference + -- type would do), and then Import the definitions from Standard_Library. + -- Since this is a by reference type, these will be passed by reference, + -- which has the same effect as passing a pointer. + + -- This type is not private because keeping it by reference would require + -- defining it in a way (e.g a tagged type) that would drag other run time + -- files, which is unwanted in the case of e.g ravenscar where we want to + -- minimize the number of run time files needed by default. + + CE : constant Exception_Type; -- Constraint_Error + PE : constant Exception_Type; -- Program_Error + SE : constant Exception_Type; -- Storage_Error + TE : constant Exception_Type; -- Tasking_Error + -- One of these constants is used in the call to specify the exception + + procedure Raise_Exception (E : Exception_Type; Message : String); + pragma Import (Ada, Raise_Exception, "__gnat_raise_exception"); + pragma No_Return (Raise_Exception); + -- Raise specified exception with specified message + +private + pragma Import (C, CE, "constraint_error"); + pragma Import (C, PE, "program_error"); + pragma Import (C, SE, "storage_error"); + pragma Import (C, TE, "tasking_error"); + -- References to the exception structures in the standard library + +end System.Pure_Exceptions; diff --git a/gcc/ada/s-rannum.adb b/gcc/ada/s-rannum.adb new file mode 100644 index 000000000..d85dd2efa --- /dev/null +++ b/gcc/ada/s-rannum.adb @@ -0,0 +1,703 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- -- +-- 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.Calendar; use Ada.Calendar; +with Ada.Unchecked_Conversion; + +with Interfaces; use Interfaces; + +use Ada; + +package body System.Random_Numbers is + + Y2K : constant Calendar.Time := + Calendar.Time_Of + (Year => 2000, Month => 1, Day => 1, Seconds => 0.0); + -- First day of Year 2000 (what is this for???) + + 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 non-binary 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"); -- better to use msg string! ??? + 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 + Clock : constant Time := Calendar.Clock; + Duration_Since_Y2K : constant Duration := Clock - Y2K; + + X : constant Unsigned_32 := + Unsigned_32'Mod (Unsigned_64 (Duration_Since_Y2K) * 64); + + begin + Init (Gen, X); + 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 + pragma Warnings (Off, "condition is always *"); + -- 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; + + pragma Warnings (On, "condition is always *"); + 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 new file mode 100644 index 000000000..0d2a7e9de --- /dev/null +++ b/gcc/ada/s-rannum.ads @@ -0,0 +1,153 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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. + +with Interfaces; + +package System.Random_Numbers is + + type Generator is limited private; + 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 .. 1) + + 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-regexp.adb b/gcc/ada/s-regexp.adb new file mode 100755 index 000000000..b347d46ff --- /dev/null +++ b/gcc/ada/s-regexp.adb @@ -0,0 +1,1670 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . R E G E X P -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with System.Case_Util; + +package body System.Regexp is + + Open_Paren : constant Character := '('; + Close_Paren : constant Character := ')'; + Open_Bracket : constant Character := '['; + Close_Bracket : constant Character := ']'; + + type State_Index is new Natural; + type Column_Index is new Natural; + + type Regexp_Array is array + (State_Index range <>, Column_Index range <>) of State_Index; + -- First index is for the state number + -- Second index is for the character type + -- Contents is the new State + + type Regexp_Array_Access is access Regexp_Array; + -- Use this type through the functions Set below, so that it + -- can grow dynamically depending on the needs. + + type Mapping is array (Character'Range) of Column_Index; + -- Mapping between characters and column in the Regexp_Array + + type Boolean_Array is array (State_Index range <>) of Boolean; + + type Regexp_Value + (Alphabet_Size : Column_Index; + Num_States : State_Index) is + record + Map : Mapping; + States : Regexp_Array (1 .. Num_States, 0 .. Alphabet_Size); + Is_Final : Boolean_Array (1 .. Num_States); + Case_Sensitive : Boolean; + end record; + -- Deterministic finite-state machine + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Set + (Table : in out Regexp_Array_Access; + State : State_Index; + Column : Column_Index; + Value : State_Index); + -- Sets a value in the table. If the table is too small, reallocate it + -- dynamically so that (State, Column) is a valid index in it. + + function Get + (Table : Regexp_Array_Access; + State : State_Index; + Column : Column_Index) + return State_Index; + -- Returns the value in the table at (State, Column). + -- If this index does not exist in the table, returns 0 + + procedure Free is new Ada.Unchecked_Deallocation + (Regexp_Array, Regexp_Array_Access); + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (R : in out Regexp) is + Tmp : Regexp_Access; + + begin + Tmp := new Regexp_Value (Alphabet_Size => R.R.Alphabet_Size, + Num_States => R.R.Num_States); + Tmp.all := R.R.all; + R.R := Tmp; + end Adjust; + + ------------- + -- Compile -- + ------------- + + function Compile + (Pattern : String; + Glob : Boolean := False; + Case_Sensitive : Boolean := True) + return Regexp + is + S : String := Pattern; + -- The pattern which is really compiled (when the pattern is case + -- insensitive, we convert this string to lower-cases + + Map : Mapping := (others => 0); + -- Mapping between characters and columns in the tables + + Alphabet_Size : Column_Index := 0; + -- Number of significant characters in the regular expression. + -- This total does not include special operators, such as *, (, ... + + procedure Check_Well_Formed_Pattern; + -- Check that the pattern to compile is well-formed, so that subsequent + -- code can rely on this without performing each time the checks to + -- avoid accessing the pattern outside its bounds. However, not all + -- well-formedness rules are checked. In particular, rules about special + -- characters not being treated as regular characters are not checked. + + procedure Create_Mapping; + -- Creates a mapping between characters in the regexp and columns + -- in the tables representing the regexp. Test that the regexp is + -- well-formed Modifies Alphabet_Size and Map + + procedure Create_Primary_Table + (Table : out Regexp_Array_Access; + Num_States : out State_Index; + Start_State : out State_Index; + End_State : out State_Index); + -- Creates the first version of the regexp (this is a non deterministic + -- finite state machine, which is unadapted for a fast pattern + -- matching algorithm). We use a recursive algorithm to process the + -- parenthesis sub-expressions. + -- + -- Table : at the end of the procedure : Column 0 is for any character + -- ('.') and the last columns are for no character (closure) + -- Num_States is set to the number of states in the table + -- Start_State is the number of the starting state in the regexp + -- End_State is the number of the final state when the regexp matches + + procedure Create_Primary_Table_Glob + (Table : out Regexp_Array_Access; + Num_States : out State_Index; + Start_State : out State_Index; + End_State : out State_Index); + -- Same function as above, but it deals with the second possible + -- grammar for 'globbing pattern', which is a kind of subset of the + -- whole regular expression grammar. + + function Create_Secondary_Table + (First_Table : Regexp_Array_Access; + Num_States : State_Index; + Start_State : State_Index; + End_State : State_Index) + return Regexp; + -- Creates the definitive table representing the regular expression + -- This is actually a transformation of the primary table First_Table, + -- where every state is grouped with the states in its 'no-character' + -- columns. The transitions between the new states are then recalculated + -- and if necessary some new states are created. + -- + -- Note that the resulting finite-state machine is not optimized in + -- terms of the number of states : it would be more time-consuming to + -- add a third pass to reduce the number of states in the machine, with + -- no speed improvement... + + procedure Raise_Exception (M : String; Index : Integer); + pragma No_Return (Raise_Exception); + -- Raise an exception, indicating an error at character Index in S + + ------------------------------- + -- Check_Well_Formed_Pattern -- + ------------------------------- + + procedure Check_Well_Formed_Pattern is + J : Integer; + + Past_Elmt : Boolean := False; + -- Set to True everywhere an elmt has been parsed, if Glob=False, + -- meaning there can be now an occurrence of '*', '+' and '?'. + + Past_Term : Boolean := False; + -- Set to True everywhere a term has been parsed, if Glob=False, + -- meaning there can be now an occurrence of '|'. + + Parenthesis_Level : Integer := 0; + Curly_Level : Integer := 0; + + Last_Open : Integer := S'First - 1; + -- The last occurrence of an opening parenthesis, if Glob=False, + -- or the last occurrence of an opening curly brace, if Glob=True. + + procedure Raise_Exception_If_No_More_Chars (K : Integer := 0); + -- If no more characters are raised, call Raise_Exception + + -------------------------------------- + -- Raise_Exception_If_No_More_Chars -- + -------------------------------------- + + procedure Raise_Exception_If_No_More_Chars (K : Integer := 0) is + begin + if J + K > S'Last then + Raise_Exception ("Ill-formed pattern while parsing", J); + end if; + end Raise_Exception_If_No_More_Chars; + + -- Start of processing for Check_Well_Formed_Pattern + + begin + J := S'First; + while J <= S'Last loop + case S (J) is + when Open_Bracket => + J := J + 1; + Raise_Exception_If_No_More_Chars; + + if not Glob then + if S (J) = '^' then + J := J + 1; + Raise_Exception_If_No_More_Chars; + end if; + end if; + + -- The first character never has a special meaning + + if S (J) = ']' or else S (J) = '-' then + J := J + 1; + Raise_Exception_If_No_More_Chars; + end if; + + -- The set of characters cannot be empty + + if S (J) = ']' then + Raise_Exception + ("Set of characters cannot be empty in regular " + & "expression", J); + end if; + + declare + Possible_Range_Start : Boolean := True; + -- Set True everywhere a range character '-' can occur + + begin + loop + exit when S (J) = Close_Bracket; + + -- The current character should be followed by a + -- closing bracket. + + Raise_Exception_If_No_More_Chars (1); + + if S (J) = '-' + and then S (J + 1) /= Close_Bracket + then + if not Possible_Range_Start then + Raise_Exception + ("No mix of ranges is allowed in " + & "regular expression", J); + end if; + + J := J + 1; + Raise_Exception_If_No_More_Chars; + + -- Range cannot be followed by '-' character, + -- except as last character in the set. + + Possible_Range_Start := False; + + else + Possible_Range_Start := True; + end if; + + if S (J) = '\' then + J := J + 1; + Raise_Exception_If_No_More_Chars; + end if; + + J := J + 1; + end loop; + end; + + -- A closing bracket can end an elmt or term + + Past_Elmt := True; + Past_Term := True; + + when Close_Bracket => + + -- A close bracket must follow a open_bracket, and cannot be + -- found alone on the line. + + Raise_Exception + ("Incorrect character ']' in regular expression", J); + + when '\' => + if J < S'Last then + J := J + 1; + + -- Any character can be an elmt or a term + + Past_Elmt := True; + Past_Term := True; + + else + -- \ not allowed at the end of the regexp + + Raise_Exception + ("Incorrect character '\' in regular expression", J); + end if; + + when Open_Paren => + if not Glob then + Parenthesis_Level := Parenthesis_Level + 1; + Last_Open := J; + + -- An open parenthesis does not end an elmt or term + + Past_Elmt := False; + Past_Term := False; + end if; + + when Close_Paren => + if not Glob then + Parenthesis_Level := Parenthesis_Level - 1; + + if Parenthesis_Level < 0 then + Raise_Exception + ("')' is not associated with '(' in regular " + & "expression", J); + end if; + + if J = Last_Open + 1 then + Raise_Exception + ("Empty parentheses not allowed in regular " + & "expression", J); + end if; + + if not Past_Term then + Raise_Exception + ("Closing parenthesis not allowed here in regular " + & "expression", J); + end if; + + -- A closing parenthesis can end an elmt or term + + Past_Elmt := True; + Past_Term := True; + end if; + + when '{' => + if Glob then + Curly_Level := Curly_Level + 1; + Last_Open := J; + + else + -- Any character can be an elmt or a term + + Past_Elmt := True; + Past_Term := True; + end if; + + -- No need to check for ',' as the code always accepts them + + when '}' => + if Glob then + Curly_Level := Curly_Level - 1; + + if Curly_Level < 0 then + Raise_Exception + ("'}' is not associated with '{' in regular " + & "expression", J); + end if; + + if J = Last_Open + 1 then + Raise_Exception + ("Empty curly braces not allowed in regular " + & "expression", J); + end if; + + else + -- Any character can be an elmt or a term + + Past_Elmt := True; + Past_Term := True; + end if; + + when '*' | '?' | '+' => + if not Glob then + + -- These operators must apply to an elmt sub-expression, + -- and cannot be found if one has not just been parsed. + + if not Past_Elmt then + Raise_Exception + ("'*', '+' and '?' operators must be " + & "applied to an element in regular expression", J); + end if; + + Past_Elmt := False; + Past_Term := True; + end if; + + when '|' => + if not Glob then + + -- This operator must apply to a term sub-expression, + -- and cannot be found if one has not just been parsed. + + if not Past_Term then + Raise_Exception + ("'|' operator must be " + & "applied to a term in regular expression", J); + end if; + + Past_Elmt := False; + Past_Term := False; + end if; + + when others => + if not Glob then + + -- Any character can be an elmt or a term + + Past_Elmt := True; + Past_Term := True; + end if; + end case; + + J := J + 1; + end loop; + + -- A closing parenthesis must follow an open parenthesis + + if Parenthesis_Level /= 0 then + Raise_Exception + ("'(' must always be associated with a ')'", J); + end if; + + -- A closing curly brace must follow an open curly brace + + if Curly_Level /= 0 then + Raise_Exception + ("'{' must always be associated with a '}'", J); + end if; + end Check_Well_Formed_Pattern; + + -------------------- + -- Create_Mapping -- + -------------------- + + procedure Create_Mapping is + + procedure Add_In_Map (C : Character); + -- Add a character in the mapping, if it is not already defined + + ---------------- + -- Add_In_Map -- + ---------------- + + procedure Add_In_Map (C : Character) is + begin + if Map (C) = 0 then + Alphabet_Size := Alphabet_Size + 1; + Map (C) := Alphabet_Size; + end if; + end Add_In_Map; + + J : Integer := S'First; + Parenthesis_Level : Integer := 0; + Curly_Level : Integer := 0; + Last_Open : Integer := S'First - 1; + + -- Start of processing for Create_Mapping + + begin + while J <= S'Last loop + case S (J) is + when Open_Bracket => + J := J + 1; + + if S (J) = '^' then + J := J + 1; + end if; + + if S (J) = ']' or else S (J) = '-' then + J := J + 1; + end if; + + -- The first character never has a special meaning + + loop + if J > S'Last then + Raise_Exception + ("Ran out of characters while parsing ", J); + end if; + + exit when S (J) = Close_Bracket; + + if S (J) = '-' + and then S (J + 1) /= Close_Bracket + then + declare + Start : constant Integer := J - 1; + + begin + J := J + 1; + + if S (J) = '\' then + J := J + 1; + end if; + + for Char in S (Start) .. S (J) loop + Add_In_Map (Char); + end loop; + end; + else + if S (J) = '\' then + J := J + 1; + end if; + + Add_In_Map (S (J)); + end if; + + J := J + 1; + end loop; + + -- A close bracket must follow a open_bracket, + -- and cannot be found alone on the line + + when Close_Bracket => + Raise_Exception + ("Incorrect character ']' in regular expression", J); + + when '\' => + if J < S'Last then + J := J + 1; + Add_In_Map (S (J)); + + else + -- \ not allowed at the end of the regexp + + Raise_Exception + ("Incorrect character '\' in regular expression", J); + end if; + + when Open_Paren => + if not Glob then + Parenthesis_Level := Parenthesis_Level + 1; + Last_Open := J; + else + Add_In_Map (Open_Paren); + end if; + + when Close_Paren => + if not Glob then + Parenthesis_Level := Parenthesis_Level - 1; + + if Parenthesis_Level < 0 then + Raise_Exception + ("')' is not associated with '(' in regular " + & "expression", J); + end if; + + if J = Last_Open + 1 then + Raise_Exception + ("Empty parenthesis not allowed in regular " + & "expression", J); + end if; + + else + Add_In_Map (Close_Paren); + end if; + + when '.' => + if Glob then + Add_In_Map ('.'); + end if; + + when '{' => + if not Glob then + Add_In_Map (S (J)); + else + Curly_Level := Curly_Level + 1; + end if; + + when '}' => + if not Glob then + Add_In_Map (S (J)); + else + Curly_Level := Curly_Level - 1; + end if; + + when '*' | '?' => + if not Glob then + if J = S'First then + Raise_Exception + ("'*', '+', '?' and '|' operators cannot be in " + & "first position in regular expression", J); + end if; + end if; + + when '|' | '+' => + if not Glob then + if J = S'First then + + -- These operators must apply to a sub-expression, + -- and cannot be found at the beginning of the line + + Raise_Exception + ("'*', '+', '?' and '|' operators cannot be in " + & "first position in regular expression", J); + end if; + + else + Add_In_Map (S (J)); + end if; + + when others => + Add_In_Map (S (J)); + end case; + + J := J + 1; + end loop; + + -- A closing parenthesis must follow an open parenthesis + + if Parenthesis_Level /= 0 then + Raise_Exception + ("'(' must always be associated with a ')'", J); + end if; + + if Curly_Level /= 0 then + Raise_Exception + ("'{' must always be associated with a '}'", J); + end if; + end Create_Mapping; + + -------------------------- + -- Create_Primary_Table -- + -------------------------- + + procedure Create_Primary_Table + (Table : out Regexp_Array_Access; + Num_States : out State_Index; + Start_State : out State_Index; + End_State : out State_Index) + is + Empty_Char : constant Column_Index := Alphabet_Size + 1; + + Current_State : State_Index := 0; + -- Index of the last created state + + procedure Add_Empty_Char + (State : State_Index; + To_State : State_Index); + -- Add a empty-character transition from State to To_State + + procedure Create_Repetition + (Repetition : Character; + Start_Prev : State_Index; + End_Prev : State_Index; + New_Start : out State_Index; + New_End : in out State_Index); + -- Create the table in case we have a '*', '+' or '?'. + -- Start_Prev .. End_Prev should indicate respectively the start and + -- end index of the previous expression, to which '*', '+' or '?' is + -- applied. + + procedure Create_Simple + (Start_Index : Integer; + End_Index : Integer; + Start_State : out State_Index; + End_State : out State_Index); + -- Fill the table for the regexp Simple. + -- This is the recursive procedure called to handle () expressions + -- If End_State = 0, then the call to Create_Simple creates an + -- independent regexp, not a concatenation + -- Start_Index .. End_Index is the starting index in the string S. + -- + -- Warning: it may look like we are creating too many empty-string + -- transitions, but they are needed to get the correct regexp. + -- The table is filled as follow ( s means start-state, e means + -- end-state) : + -- + -- regexp state_num | a b * empty_string + -- ------- ------------------------------ + -- a 1 (s) | 2 - - - + -- 2 (e) | - - - - + -- + -- ab 1 (s) | 2 - - - + -- 2 | - - - 3 + -- 3 | - 4 - - + -- 4 (e) | - - - - + -- + -- a|b 1 | 2 - - - + -- 2 | - - - 6 + -- 3 | - 4 - - + -- 4 | - - - 6 + -- 5 (s) | - - - 1,3 + -- 6 (e) | - - - - + -- + -- a* 1 | 2 - - - + -- 2 | - - - 4 + -- 3 (s) | - - - 1,4 + -- 4 (e) | - - - 3 + -- + -- (a) 1 (s) | 2 - - - + -- 2 (e) | - - - - + -- + -- a+ 1 | 2 - - - + -- 2 | - - - 4 + -- 3 (s) | - - - 1 + -- 4 (e) | - - - 3 + -- + -- a? 1 | 2 - - - + -- 2 | - - - 4 + -- 3 (s) | - - - 1,4 + -- 4 (e) | - - - - + -- + -- . 1 (s) | 2 2 2 - + -- 2 (e) | - - - - + + function Next_Sub_Expression + (Start_Index : Integer; + End_Index : Integer) + return Integer; + -- Returns the index of the last character of the next sub-expression + -- in Simple. Index cannot be greater than End_Index. + + -------------------- + -- Add_Empty_Char -- + -------------------- + + procedure Add_Empty_Char + (State : State_Index; + To_State : State_Index) + is + J : Column_Index := Empty_Char; + + begin + while Get (Table, State, J) /= 0 loop + J := J + 1; + end loop; + + Set (Table, State, J, To_State); + end Add_Empty_Char; + + ----------------------- + -- Create_Repetition -- + ----------------------- + + procedure Create_Repetition + (Repetition : Character; + Start_Prev : State_Index; + End_Prev : State_Index; + New_Start : out State_Index; + New_End : in out State_Index) + is + begin + New_Start := Current_State + 1; + + if New_End /= 0 then + Add_Empty_Char (New_End, New_Start); + end if; + + Current_State := Current_State + 2; + New_End := Current_State; + + Add_Empty_Char (End_Prev, New_End); + Add_Empty_Char (New_Start, Start_Prev); + + if Repetition /= '+' then + Add_Empty_Char (New_Start, New_End); + end if; + + if Repetition /= '?' then + Add_Empty_Char (New_End, New_Start); + end if; + end Create_Repetition; + + ------------------- + -- Create_Simple -- + ------------------- + + procedure Create_Simple + (Start_Index : Integer; + End_Index : Integer; + Start_State : out State_Index; + End_State : out State_Index) + is + J : Integer := Start_Index; + Last_Start : State_Index := 0; + + begin + Start_State := 0; + End_State := 0; + while J <= End_Index loop + case S (J) is + when Open_Paren => + declare + J_Start : constant Integer := J + 1; + Next_Start : State_Index; + Next_End : State_Index; + + begin + J := Next_Sub_Expression (J, End_Index); + Create_Simple (J_Start, J - 1, Next_Start, Next_End); + + if J < End_Index + and then (S (J + 1) = '*' or else + S (J + 1) = '+' or else + S (J + 1) = '?') + then + J := J + 1; + Create_Repetition + (S (J), + Next_Start, + Next_End, + Last_Start, + End_State); + + else + Last_Start := Next_Start; + + if End_State /= 0 then + Add_Empty_Char (End_State, Last_Start); + end if; + + End_State := Next_End; + end if; + end; + + when '|' => + declare + Start_Prev : constant State_Index := Start_State; + End_Prev : constant State_Index := End_State; + Start_J : constant Integer := J + 1; + Start_Next : State_Index := 0; + End_Next : State_Index := 0; + + begin + J := Next_Sub_Expression (J, End_Index); + + -- Create a new state for the start of the alternative + + Current_State := Current_State + 1; + Last_Start := Current_State; + Start_State := Last_Start; + + -- Create the tree for the second part of alternative + + Create_Simple (Start_J, J, Start_Next, End_Next); + + -- Create the end state + + Add_Empty_Char (Last_Start, Start_Next); + Add_Empty_Char (Last_Start, Start_Prev); + Current_State := Current_State + 1; + End_State := Current_State; + Add_Empty_Char (End_Prev, End_State); + Add_Empty_Char (End_Next, End_State); + end; + + when Open_Bracket => + Current_State := Current_State + 1; + + declare + Next_State : State_Index := Current_State + 1; + + begin + J := J + 1; + + if S (J) = '^' then + J := J + 1; + + Next_State := 0; + + for Column in 0 .. Alphabet_Size loop + Set (Table, Current_State, Column, + Value => Current_State + 1); + end loop; + end if; + + -- Automatically add the first character + + if S (J) = '-' or else S (J) = ']' then + Set (Table, Current_State, Map (S (J)), + Value => Next_State); + J := J + 1; + end if; + + -- Loop till closing bracket found + + loop + exit when S (J) = Close_Bracket; + + if S (J) = '-' + and then S (J + 1) /= ']' + then + declare + Start : constant Integer := J - 1; + + begin + J := J + 1; + + if S (J) = '\' then + J := J + 1; + end if; + + for Char in S (Start) .. S (J) loop + Set (Table, Current_State, Map (Char), + Value => Next_State); + end loop; + end; + + else + if S (J) = '\' then + J := J + 1; + end if; + + Set (Table, Current_State, Map (S (J)), + Value => Next_State); + end if; + J := J + 1; + end loop; + end; + + Current_State := Current_State + 1; + + -- If the next symbol is a special symbol + + if J < End_Index + and then (S (J + 1) = '*' or else + S (J + 1) = '+' or else + S (J + 1) = '?') + then + J := J + 1; + Create_Repetition + (S (J), + Current_State - 1, + Current_State, + Last_Start, + End_State); + + else + Last_Start := Current_State - 1; + + if End_State /= 0 then + Add_Empty_Char (End_State, Last_Start); + end if; + + End_State := Current_State; + end if; + + when '*' | '+' | '?' | Close_Paren | Close_Bracket => + Raise_Exception + ("Incorrect character in regular expression :", J); + + when others => + Current_State := Current_State + 1; + + -- Create the state for the symbol S (J) + + if S (J) = '.' then + for K in 0 .. Alphabet_Size loop + Set (Table, Current_State, K, + Value => Current_State + 1); + end loop; + + else + if S (J) = '\' then + J := J + 1; + end if; + + Set (Table, Current_State, Map (S (J)), + Value => Current_State + 1); + end if; + + Current_State := Current_State + 1; + + -- If the next symbol is a special symbol + + if J < End_Index + and then (S (J + 1) = '*' or else + S (J + 1) = '+' or else + S (J + 1) = '?') + then + J := J + 1; + Create_Repetition + (S (J), + Current_State - 1, + Current_State, + Last_Start, + End_State); + + else + Last_Start := Current_State - 1; + + if End_State /= 0 then + Add_Empty_Char (End_State, Last_Start); + end if; + + End_State := Current_State; + end if; + + end case; + + if Start_State = 0 then + Start_State := Last_Start; + end if; + + J := J + 1; + end loop; + end Create_Simple; + + ------------------------- + -- Next_Sub_Expression -- + ------------------------- + + function Next_Sub_Expression + (Start_Index : Integer; + End_Index : Integer) + return Integer + is + J : Integer := Start_Index; + Start_On_Alter : Boolean := False; + + begin + if S (J) = '|' then + Start_On_Alter := True; + end if; + + loop + exit when J = End_Index; + J := J + 1; + + case S (J) is + when '\' => + J := J + 1; + + when Open_Bracket => + loop + J := J + 1; + exit when S (J) = Close_Bracket; + + if S (J) = '\' then + J := J + 1; + end if; + end loop; + + when Open_Paren => + J := Next_Sub_Expression (J, End_Index); + + when Close_Paren => + return J; + + when '|' => + if Start_On_Alter then + return J - 1; + end if; + + when others => + null; + end case; + end loop; + + return J; + end Next_Sub_Expression; + + -- Start of Create_Primary_Table + + begin + Table.all := (others => (others => 0)); + Create_Simple (S'First, S'Last, Start_State, End_State); + Num_States := Current_State; + end Create_Primary_Table; + + ------------------------------- + -- Create_Primary_Table_Glob -- + ------------------------------- + + procedure Create_Primary_Table_Glob + (Table : out Regexp_Array_Access; + Num_States : out State_Index; + Start_State : out State_Index; + End_State : out State_Index) + is + Empty_Char : constant Column_Index := Alphabet_Size + 1; + + Current_State : State_Index := 0; + -- Index of the last created state + + procedure Add_Empty_Char + (State : State_Index; + To_State : State_Index); + -- Add a empty-character transition from State to To_State + + procedure Create_Simple + (Start_Index : Integer; + End_Index : Integer; + Start_State : out State_Index; + End_State : out State_Index); + -- Fill the table for the S (Start_Index .. End_Index). + -- This is the recursive procedure called to handle () expressions + + -------------------- + -- Add_Empty_Char -- + -------------------- + + procedure Add_Empty_Char + (State : State_Index; + To_State : State_Index) + is + J : Column_Index := Empty_Char; + + begin + while Get (Table, State, J) /= 0 loop + J := J + 1; + end loop; + + Set (Table, State, J, + Value => To_State); + end Add_Empty_Char; + + ------------------- + -- Create_Simple -- + ------------------- + + procedure Create_Simple + (Start_Index : Integer; + End_Index : Integer; + Start_State : out State_Index; + End_State : out State_Index) + is + J : Integer := Start_Index; + Last_Start : State_Index := 0; + + begin + Start_State := 0; + End_State := 0; + + while J <= End_Index loop + case S (J) is + + when Open_Bracket => + Current_State := Current_State + 1; + + declare + Next_State : State_Index := Current_State + 1; + + begin + J := J + 1; + + if S (J) = '^' then + J := J + 1; + Next_State := 0; + + for Column in 0 .. Alphabet_Size loop + Set (Table, Current_State, Column, + Value => Current_State + 1); + end loop; + end if; + + -- Automatically add the first character + + if S (J) = '-' or else S (J) = ']' then + Set (Table, Current_State, Map (S (J)), + Value => Current_State); + J := J + 1; + end if; + + -- Loop till closing bracket found + + loop + exit when S (J) = Close_Bracket; + + if S (J) = '-' + and then S (J + 1) /= ']' + then + declare + Start : constant Integer := J - 1; + begin + J := J + 1; + + if S (J) = '\' then + J := J + 1; + end if; + + for Char in S (Start) .. S (J) loop + Set (Table, Current_State, Map (Char), + Value => Next_State); + end loop; + end; + + else + if S (J) = '\' then + J := J + 1; + end if; + + Set (Table, Current_State, Map (S (J)), + Value => Next_State); + end if; + J := J + 1; + end loop; + end; + + Last_Start := Current_State; + Current_State := Current_State + 1; + + if End_State /= 0 then + Add_Empty_Char (End_State, Last_Start); + end if; + + End_State := Current_State; + + when '{' => + declare + End_Sub : Integer; + Start_Regexp_Sub : State_Index; + End_Regexp_Sub : State_Index; + Create_Start : State_Index := 0; + + Create_End : State_Index := 0; + -- Initialized to avoid junk warning + + begin + while S (J) /= '}' loop + + -- First step : find sub pattern + + End_Sub := J + 1; + while S (End_Sub) /= ',' + and then S (End_Sub) /= '}' + loop + End_Sub := End_Sub + 1; + end loop; + + -- Second step : create a sub pattern + + Create_Simple + (J + 1, + End_Sub - 1, + Start_Regexp_Sub, + End_Regexp_Sub); + + J := End_Sub; + + -- Third step : create an alternative + + if Create_Start = 0 then + Current_State := Current_State + 1; + Create_Start := Current_State; + Add_Empty_Char (Create_Start, Start_Regexp_Sub); + Current_State := Current_State + 1; + Create_End := Current_State; + Add_Empty_Char (End_Regexp_Sub, Create_End); + + else + Current_State := Current_State + 1; + Add_Empty_Char (Current_State, Create_Start); + Create_Start := Current_State; + Add_Empty_Char (Create_Start, Start_Regexp_Sub); + Add_Empty_Char (End_Regexp_Sub, Create_End); + end if; + end loop; + + if End_State /= 0 then + Add_Empty_Char (End_State, Create_Start); + end if; + + End_State := Create_End; + Last_Start := Create_Start; + end; + + when '*' => + Current_State := Current_State + 1; + + if End_State /= 0 then + Add_Empty_Char (End_State, Current_State); + end if; + + Add_Empty_Char (Current_State, Current_State + 1); + Add_Empty_Char (Current_State, Current_State + 3); + Last_Start := Current_State; + + Current_State := Current_State + 1; + + for K in 0 .. Alphabet_Size loop + Set (Table, Current_State, K, + Value => Current_State + 1); + end loop; + + Current_State := Current_State + 1; + Add_Empty_Char (Current_State, Current_State + 1); + + Current_State := Current_State + 1; + Add_Empty_Char (Current_State, Last_Start); + End_State := Current_State; + + when others => + Current_State := Current_State + 1; + + if S (J) = '?' then + for K in 0 .. Alphabet_Size loop + Set (Table, Current_State, K, + Value => Current_State + 1); + end loop; + + else + if S (J) = '\' then + J := J + 1; + end if; + + -- Create the state for the symbol S (J) + + Set (Table, Current_State, Map (S (J)), + Value => Current_State + 1); + end if; + + Last_Start := Current_State; + Current_State := Current_State + 1; + + if End_State /= 0 then + Add_Empty_Char (End_State, Last_Start); + end if; + + End_State := Current_State; + + end case; + + if Start_State = 0 then + Start_State := Last_Start; + end if; + + J := J + 1; + end loop; + end Create_Simple; + + -- Start of processing for Create_Primary_Table_Glob + + begin + Table.all := (others => (others => 0)); + Create_Simple (S'First, S'Last, Start_State, End_State); + Num_States := Current_State; + end Create_Primary_Table_Glob; + + ---------------------------- + -- Create_Secondary_Table -- + ---------------------------- + + function Create_Secondary_Table + (First_Table : Regexp_Array_Access; + Num_States : State_Index; + Start_State : State_Index; + End_State : State_Index) return Regexp + is + pragma Warnings (Off, Num_States); + + Last_Index : constant State_Index := First_Table'Last (1); + type Meta_State is array (1 .. Last_Index) of Boolean; + + Table : Regexp_Array (1 .. Last_Index, 0 .. Alphabet_Size) := + (others => (others => 0)); + + Meta_States : array (1 .. Last_Index + 1) of Meta_State := + (others => (others => False)); + + Temp_State_Not_Null : Boolean; + + Is_Final : Boolean_Array (1 .. Last_Index) := (others => False); + + Current_State : State_Index := 1; + Nb_State : State_Index := 1; + + procedure Closure + (State : in out Meta_State; + Item : State_Index); + -- Compute the closure of the state (that is every other state which + -- has a empty-character transition) and add it to the state + + ------------- + -- Closure -- + ------------- + + procedure Closure + (State : in out Meta_State; + Item : State_Index) + is + begin + if State (Item) then + return; + end if; + + State (Item) := True; + + for Column in Alphabet_Size + 1 .. First_Table'Last (2) loop + if First_Table (Item, Column) = 0 then + return; + end if; + + Closure (State, First_Table (Item, Column)); + end loop; + end Closure; + + -- Start of processing for Create_Secondary_Table + + begin + -- Create a new state + + Closure (Meta_States (Current_State), Start_State); + + while Current_State <= Nb_State loop + + -- If this new meta-state includes the primary table end state, + -- then this meta-state will be a final state in the regexp + + if Meta_States (Current_State)(End_State) then + Is_Final (Current_State) := True; + end if; + + -- For every character in the regexp, calculate the possible + -- transitions from Current_State + + for Column in 0 .. Alphabet_Size loop + Meta_States (Nb_State + 1) := (others => False); + Temp_State_Not_Null := False; + + for K in Meta_States (Current_State)'Range loop + if Meta_States (Current_State)(K) + and then First_Table (K, Column) /= 0 + then + Closure + (Meta_States (Nb_State + 1), First_Table (K, Column)); + Temp_State_Not_Null := True; + end if; + end loop; + + -- If at least one transition existed + + if Temp_State_Not_Null then + + -- Check if this new state corresponds to an old one + + for K in 1 .. Nb_State loop + if Meta_States (K) = Meta_States (Nb_State + 1) then + Table (Current_State, Column) := K; + exit; + end if; + end loop; + + -- If not, create a new state + + if Table (Current_State, Column) = 0 then + Nb_State := Nb_State + 1; + Table (Current_State, Column) := Nb_State; + end if; + end if; + end loop; + + Current_State := Current_State + 1; + end loop; + + -- Returns the regexp + + declare + R : Regexp_Access; + + begin + R := new Regexp_Value (Alphabet_Size => Alphabet_Size, + Num_States => Nb_State); + R.Map := Map; + R.Is_Final := Is_Final (1 .. Nb_State); + R.Case_Sensitive := Case_Sensitive; + + for State in 1 .. Nb_State loop + for K in 0 .. Alphabet_Size loop + R.States (State, K) := Table (State, K); + end loop; + end loop; + + return (Ada.Finalization.Controlled with R => R); + end; + end Create_Secondary_Table; + + --------------------- + -- Raise_Exception -- + --------------------- + + procedure Raise_Exception (M : String; Index : Integer) is + begin + raise Error_In_Regexp with M & " at offset" & Index'Img; + end Raise_Exception; + + -- Start of processing for Compile + + begin + -- Special case for the empty string: it always matches, and the + -- following processing would fail on it. + if S = "" then + return (Ada.Finalization.Controlled with + R => new Regexp_Value' + (Alphabet_Size => 0, + Num_States => 1, + Map => (others => 0), + States => (others => (others => 1)), + Is_Final => (others => True), + Case_Sensitive => True)); + end if; + + if not Case_Sensitive then + System.Case_Util.To_Lower (S); + end if; + + -- Check the pattern is well-formed before any treatment + + Check_Well_Formed_Pattern; + + Create_Mapping; + + -- Creates the primary table + + declare + Table : Regexp_Array_Access; + Num_States : State_Index; + Start_State : State_Index; + End_State : State_Index; + R : Regexp; + + begin + Table := new Regexp_Array (1 .. 100, + 0 .. Alphabet_Size + 10); + if not Glob then + Create_Primary_Table (Table, Num_States, Start_State, End_State); + else + Create_Primary_Table_Glob + (Table, Num_States, Start_State, End_State); + end if; + + -- Creates the secondary table + + R := Create_Secondary_Table + (Table, Num_States, Start_State, End_State); + Free (Table); + return R; + end; + end Compile; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (R : in out Regexp) is + procedure Free is new + Ada.Unchecked_Deallocation (Regexp_Value, Regexp_Access); + + begin + Free (R.R); + end Finalize; + + --------- + -- Get -- + --------- + + function Get + (Table : Regexp_Array_Access; + State : State_Index; + Column : Column_Index) return State_Index + is + begin + if State <= Table'Last (1) + and then Column <= Table'Last (2) + then + return Table (State, Column); + else + return 0; + end if; + end Get; + + ----------- + -- Match -- + ----------- + + function Match (S : String; R : Regexp) return Boolean is + Current_State : State_Index := 1; + + begin + if R.R = null then + raise Constraint_Error; + end if; + + for Char in S'Range loop + + if R.R.Case_Sensitive then + Current_State := R.R.States (Current_State, R.R.Map (S (Char))); + else + Current_State := + R.R.States (Current_State, + R.R.Map (System.Case_Util.To_Lower (S (Char)))); + end if; + + if Current_State = 0 then + return False; + end if; + + end loop; + + return R.R.Is_Final (Current_State); + end Match; + + --------- + -- Set -- + --------- + + procedure Set + (Table : in out Regexp_Array_Access; + State : State_Index; + Column : Column_Index; + Value : State_Index) + is + New_Lines : State_Index; + New_Columns : Column_Index; + New_Table : Regexp_Array_Access; + + begin + if State <= Table'Last (1) + and then Column <= Table'Last (2) + then + Table (State, Column) := Value; + else + -- Doubles the size of the table until it is big enough that + -- (State, Column) is a valid index + + New_Lines := Table'Last (1) * (State / Table'Last (1) + 1); + New_Columns := Table'Last (2) * (Column / Table'Last (2) + 1); + New_Table := new Regexp_Array (Table'First (1) .. New_Lines, + Table'First (2) .. New_Columns); + New_Table.all := (others => (others => 0)); + + for J in Table'Range (1) loop + for K in Table'Range (2) loop + New_Table (J, K) := Table (J, K); + end loop; + end loop; + + Free (Table); + Table := New_Table; + Table (State, Column) := Value; + end if; + end Set; + +end System.Regexp; diff --git a/gcc/ada/s-regexp.ads b/gcc/ada/s-regexp.ads new file mode 100755 index 000000000..a1f9bf732 --- /dev/null +++ b/gcc/ada/s-regexp.ads @@ -0,0 +1,139 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . R E G E X P -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Simple Regular expression matching + +-- This package provides a simple implementation of a regular expression +-- pattern matching algorithm, using a subset of the syntax of regular +-- expressions copied from familiar Unix style utilities. + +-- Note: this package is in the System hierarchy so that it can be directly +-- be used by other predefined packages. User access to this package is via +-- a renaming of this package in GNAT.Regexp (file g-regexp.ads). + +with Ada.Finalization; + +package System.Regexp is + + -- The regular expression must first be compiled, using the Compile + -- function, which creates a finite state matching table, allowing + -- very fast matching once the expression has been compiled. + + -- The following is the form of a regular expression, expressed in Ada + -- reference manual style BNF is as follows + + -- regexp ::= term + + -- regexp ::= term | term -- alternation (term or term ...) + + -- term ::= item + + -- term ::= item item ... -- concatenation (item then item) + + -- item ::= elmt -- match elmt + -- item ::= elmt * -- zero or more elmt's + -- item ::= elmt + -- one or more elmt's + -- item ::= elmt ? -- matches elmt or nothing + + -- elmt ::= nchr -- matches given character + -- elmt ::= [nchr nchr ...] -- matches any character listed + -- elmt ::= [^ nchr nchr ...] -- matches any character not listed + -- elmt ::= [char - char] -- matches chars in given range + -- elmt ::= . -- matches any single character + -- elmt ::= ( regexp ) -- parens used for grouping + + -- char ::= any character, including special characters + -- nchr ::= any character except \()[].*+?^ or \char to match char + -- ... is used to indication repetition (one or more terms) + + -- See also regexp(1) man page on Unix systems for further details + + -- A second kind of regular expressions is provided. This one is more + -- like the wild card patterns used in file names by the Unix shell (or + -- DOS prompt) command lines. The grammar is the following: + + -- regexp ::= term + + -- term ::= elmt + + -- term ::= elmt elmt ... -- concatenation (elmt then elmt) + -- term ::= * -- any string of 0 or more characters + -- term ::= ? -- matches any character + -- term ::= [char char ...] -- matches any character listed + -- term ::= [char - char] -- matches any character in given range + -- term ::= {elmt, elmt, ...} -- alternation (matches any of elmt) + + -- Important note : This package was mainly intended to match regular + -- expressions against file names. The whole string has to match the + -- regular expression. If only a substring matches, then the function + -- Match will return False. + + type Regexp is private; + -- Private type used to represent a regular expression + + Error_In_Regexp : exception; + -- Exception raised when an error is found in the regular expression + + function Compile + (Pattern : String; + Glob : Boolean := False; + Case_Sensitive : Boolean := True) return Regexp; + -- Compiles a regular expression S. If the syntax of the given + -- expression is invalid (does not match above grammar), Error_In_Regexp + -- is raised. If Glob is True, the pattern is considered as a 'globbing + -- pattern', that is a pattern as given by the second grammar above. + -- As a special case, if Pattern is the empty string it will always + -- match. + + function Match (S : String; R : Regexp) return Boolean; + -- True if S matches R, otherwise False. Raises Constraint_Error if + -- R is an uninitialized regular expression value. + +private + type Regexp_Value; + + type Regexp_Access is access Regexp_Value; + + type Regexp is new Ada.Finalization.Controlled with record + R : Regexp_Access := null; + end record; + + pragma Finalize_Storage_Only (Regexp); + + procedure Finalize (R : in out Regexp); + -- Free the memory occupied by R + + procedure Adjust (R : in out Regexp); + -- Called after an assignment (do a copy of the Regexp_Access.all) + +end System.Regexp; diff --git a/gcc/ada/s-regpat.adb b/gcc/ada/s-regpat.adb new file mode 100755 index 000000000..1c0cf746a --- /dev/null +++ b/gcc/ada/s-regpat.adb @@ -0,0 +1,3715 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an altered Ada 95 version of the original V8 style regular +-- expression library written in C by Henry Spencer. Apart from the +-- translation to Ada, the interface has been considerably changed to +-- use the Ada String type instead of C-style nul-terminated strings. + +-- Beware that some of this code is subtly aware of the way operator +-- precedence is structured in regular expressions. Serious changes in +-- regular-expression syntax might require a total rethink. + +with System.IO; use System.IO; +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Unchecked_Conversion; + +package body System.Regpat is + + Debug : constant Boolean := False; + -- Set to True to activate debug traces. This is normally set to constant + -- False to simply delete all the trace code. It is to be edited to True + -- for internal debugging of the package. + + ---------------------------- + -- Implementation details -- + ---------------------------- + + -- This is essentially a linear encoding of a nondeterministic + -- finite-state machine, also known as syntax charts or + -- "railroad normal form" in parsing technology. + + -- Each node is an opcode plus a "next" pointer, possibly plus an + -- operand. "Next" pointers of all nodes except BRANCH implement + -- concatenation; a "next" pointer with a BRANCH on both ends of it + -- is connecting two alternatives. + + -- The operand of some types of node is a literal string; for others, + -- it is a node leading into a sub-FSM. In particular, the operand of + -- a BRANCH node is the first node of the branch. + -- (NB this is *not* a tree structure: the tail of the branch connects + -- to the thing following the set of BRANCHes). + + -- You can see the exact byte-compiled version by using the Dump + -- subprogram. However, here are a few examples: + + -- (a|b): 1 : BRANCH (next at 9) + -- 4 : EXACT (next at 17) operand=a + -- 9 : BRANCH (next at 17) + -- 12 : EXACT (next at 17) operand=b + -- 17 : EOP (next at 0) + -- + -- (ab)*: 1 : CURLYX (next at 25) { 0, 32767} + -- 8 : OPEN 1 (next at 12) + -- 12 : EXACT (next at 18) operand=ab + -- 18 : CLOSE 1 (next at 22) + -- 22 : WHILEM (next at 0) + -- 25 : NOTHING (next at 28) + -- 28 : EOP (next at 0) + + -- The opcodes are: + + type Opcode is + + -- Name Operand? Meaning + + (EOP, -- no End of program + MINMOD, -- no Next operator is not greedy + + -- Classes of characters + + ANY, -- no Match any one character except newline + SANY, -- no Match any character, including new line + ANYOF, -- class Match any character in this class + EXACT, -- str Match this string exactly + EXACTF, -- str Match this string (case-folding is one) + NOTHING, -- no Match empty string + SPACE, -- no Match any whitespace character + NSPACE, -- no Match any non-whitespace character + DIGIT, -- no Match any numeric character + NDIGIT, -- no Match any non-numeric character + ALNUM, -- no Match any alphanumeric character + NALNUM, -- no Match any non-alphanumeric character + + -- Branches + + BRANCH, -- node Match this alternative, or the next + + -- Simple loops (when the following node is one character in length) + + STAR, -- node Match this simple thing 0 or more times + PLUS, -- node Match this simple thing 1 or more times + CURLY, -- 2num node Match this simple thing between n and m times. + + -- Complex loops + + CURLYX, -- 2num node Match this complex thing {n,m} times + -- The nums are coded on two characters each + + WHILEM, -- no Do curly processing and see if rest matches + + -- Matches after or before a word + + BOL, -- no Match "" at beginning of line + MBOL, -- no Same, assuming multiline (match after \n) + SBOL, -- no Same, assuming single line (don't match at \n) + EOL, -- no Match "" at end of line + MEOL, -- no Same, assuming multiline (match before \n) + SEOL, -- no Same, assuming single line (don't match at \n) + + BOUND, -- no Match "" at any word boundary + NBOUND, -- no Match "" at any word non-boundary + + -- Parenthesis groups handling + + REFF, -- num Match some already matched string, folded + OPEN, -- num Mark this point in input as start of #n + CLOSE); -- num Analogous to OPEN + + for Opcode'Size use 8; + + -- Opcode notes: + + -- BRANCH + -- The set of branches constituting a single choice are hooked + -- together with their "next" pointers, since precedence prevents + -- anything being concatenated to any individual branch. The + -- "next" pointer of the last BRANCH in a choice points to the + -- thing following the whole choice. This is also where the + -- final "next" pointer of each individual branch points; each + -- branch starts with the operand node of a BRANCH node. + + -- STAR,PLUS + -- '?', and complex '*' and '+', are implemented with CURLYX. + -- branches. Simple cases (one character per match) are implemented with + -- STAR and PLUS for speed and to minimize recursive plunges. + + -- OPEN,CLOSE + -- ...are numbered at compile time. + + -- EXACT, EXACTF + -- There are in fact two arguments, the first one is the length (minus + -- one of the string argument), coded on one character, the second + -- argument is the string itself, coded on length + 1 characters. + + -- A node is one char of opcode followed by two chars of "next" pointer. + -- "Next" pointers are stored as two 8-bit pieces, high order first. The + -- value is a positive offset from the opcode of the node containing it. + -- An operand, if any, simply follows the node. (Note that much of the + -- code generation knows about this implicit relationship.) + + -- Using two bytes for the "next" pointer is vast overkill for most + -- things, but allows patterns to get big without disasters. + + Next_Pointer_Bytes : constant := 3; + -- Points after the "next pointer" data. An instruction is therefore: + -- 1 byte: instruction opcode + -- 2 bytes: pointer to next instruction + -- * bytes: optional data for the instruction + + ----------------------- + -- Character classes -- + ----------------------- + -- This is the implementation for character classes ([...]) in the + -- syntax for regular expressions. Each character (0..256) has an + -- entry into the table. This makes for a very fast matching + -- algorithm. + + type Class_Byte is mod 256; + type Character_Class is array (Class_Byte range 0 .. 31) of Class_Byte; + + type Bit_Conversion_Array is array (Class_Byte range 0 .. 7) of Class_Byte; + Bit_Conversion : constant Bit_Conversion_Array := + (1, 2, 4, 8, 16, 32, 64, 128); + + type Std_Class is (ANYOF_NONE, + ANYOF_ALNUM, -- Alphanumeric class [a-zA-Z0-9] + ANYOF_NALNUM, + ANYOF_SPACE, -- Space class [ \t\n\r\f] + ANYOF_NSPACE, + ANYOF_DIGIT, -- Digit class [0-9] + ANYOF_NDIGIT, + ANYOF_ALNUMC, -- Alphanumeric class [a-zA-Z0-9] + ANYOF_NALNUMC, + ANYOF_ALPHA, -- Alpha class [a-zA-Z] + ANYOF_NALPHA, + ANYOF_ASCII, -- Ascii class (7 bits) 0..127 + ANYOF_NASCII, + ANYOF_CNTRL, -- Control class + ANYOF_NCNTRL, + ANYOF_GRAPH, -- Graphic class + ANYOF_NGRAPH, + ANYOF_LOWER, -- Lower case class [a-z] + ANYOF_NLOWER, + ANYOF_PRINT, -- printable class + ANYOF_NPRINT, + ANYOF_PUNCT, -- + ANYOF_NPUNCT, + ANYOF_UPPER, -- Upper case class [A-Z] + ANYOF_NUPPER, + ANYOF_XDIGIT, -- Hexadecimal digit + ANYOF_NXDIGIT + ); + + procedure Set_In_Class + (Bitmap : in out Character_Class; + C : Character); + -- Set the entry to True for C in the class Bitmap + + function Get_From_Class + (Bitmap : Character_Class; + C : Character) return Boolean; + -- Return True if the entry is set for C in the class Bitmap + + procedure Reset_Class (Bitmap : out Character_Class); + -- Clear all the entries in the class Bitmap + + pragma Inline (Set_In_Class); + pragma Inline (Get_From_Class); + pragma Inline (Reset_Class); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function "=" (Left : Character; Right : Opcode) return Boolean; + + function Is_Alnum (C : Character) return Boolean; + -- Return True if C is an alphanum character or an underscore ('_') + + function Is_White_Space (C : Character) return Boolean; + -- Return True if C is a whitespace character + + function Is_Printable (C : Character) return Boolean; + -- Return True if C is a printable character + + function Operand (P : Pointer) return Pointer; + -- Return a pointer to the first operand of the node at P + + function String_Length + (Program : Program_Data; + P : Pointer) return Program_Size; + -- Return the length of the string argument of the node at P + + function String_Operand (P : Pointer) return Pointer; + -- Return a pointer to the string argument of the node at P + + procedure Bitmap_Operand + (Program : Program_Data; + P : Pointer; + Op : out Character_Class); + -- Return a pointer to the string argument of the node at P + + function Get_Next + (Program : Program_Data; + IP : Pointer) return Pointer; + -- Dig the next instruction pointer out of a node + + procedure Optimize (Self : in out Pattern_Matcher); + -- Optimize a Pattern_Matcher by noting certain special cases + + function Read_Natural + (Program : Program_Data; + IP : Pointer) return Natural; + -- Return the 2-byte natural coded at position IP + + -- All of the subprograms above are tiny and should be inlined + + pragma Inline ("="); + pragma Inline (Is_Alnum); + pragma Inline (Is_White_Space); + pragma Inline (Get_Next); + pragma Inline (Operand); + pragma Inline (Read_Natural); + pragma Inline (String_Length); + pragma Inline (String_Operand); + + type Expression_Flags is record + Has_Width, -- Known never to match null string + Simple, -- Simple enough to be STAR/PLUS operand + SP_Start : Boolean; -- Starts with * or + + end record; + + Worst_Expression : constant Expression_Flags := (others => False); + -- Worst case + + procedure Dump_Until + (Program : Program_Data; + Index : in out Pointer; + Till : Pointer; + Indent : Natural; + Do_Print : Boolean := True); + -- Dump the program until the node Till (not included) is met. Every line + -- is indented with Index spaces at the beginning Dumps till the end if + -- Till is 0. + + procedure Dump_Operation + (Program : Program_Data; + Index : Pointer; + Indent : Natural); + -- Same as above, but only dumps a single operation, and compute its + -- indentation from the program. + + --------- + -- "=" -- + --------- + + function "=" (Left : Character; Right : Opcode) return Boolean is + begin + return Character'Pos (Left) = Opcode'Pos (Right); + end "="; + + -------------------- + -- Bitmap_Operand -- + -------------------- + + procedure Bitmap_Operand + (Program : Program_Data; + P : Pointer; + Op : out Character_Class) + is + function Convert is new Ada.Unchecked_Conversion + (Program_Data, Character_Class); + + begin + Op (0 .. 31) := Convert (Program (P + Next_Pointer_Bytes .. P + 34)); + end Bitmap_Operand; + + ------------- + -- Compile -- + ------------- + + procedure Compile + (Matcher : out Pattern_Matcher; + Expression : String; + Final_Code_Size : out Program_Size; + Flags : Regexp_Flags := No_Flags) + is + -- We can't allocate space until we know how big the compiled form + -- will be, but we can't compile it (and thus know how big it is) + -- until we've got a place to put the code. So we cheat: we compile + -- it twice, once with code generation turned off and size counting + -- turned on, and once "for real". + + -- This also means that we don't allocate space until we are sure + -- that the thing really will compile successfully, and we never + -- have to move the code and thus invalidate pointers into it. + + -- Beware that the optimization-preparation code in here knows + -- about some of the structure of the compiled regexp. + + PM : Pattern_Matcher renames Matcher; + Program : Program_Data renames PM.Program; + + Emit_Ptr : Pointer := Program_First; + + Parse_Pos : Natural := Expression'First; -- Input-scan pointer + Parse_End : constant Natural := Expression'Last; + + ---------------------------- + -- Subprograms for Create -- + ---------------------------- + + procedure Emit (B : Character); + -- Output the Character B to the Program. If code-generation is + -- disabled, simply increments the program counter. + + function Emit_Node (Op : Opcode) return Pointer; + -- If code-generation is enabled, Emit_Node outputs the + -- opcode Op and reserves space for a pointer to the next node. + -- Return value is the location of new opcode, i.e. old Emit_Ptr. + + procedure Emit_Natural (IP : Pointer; N : Natural); + -- Split N on two characters at position IP + + procedure Emit_Class (Bitmap : Character_Class); + -- Emits a character class + + procedure Case_Emit (C : Character); + -- Emit C, after converting is to lower-case if the regular + -- expression is case insensitive. + + procedure Parse + (Parenthesized : Boolean; + Flags : out Expression_Flags; + IP : out Pointer); + -- Parse regular expression, i.e. main body or parenthesized thing + -- Caller must absorb opening parenthesis. + + procedure Parse_Branch + (Flags : out Expression_Flags; + First : Boolean; + IP : out Pointer); + -- Implements the concatenation operator and handles '|' + -- First should be true if this is the first item of the alternative. + + procedure Parse_Piece + (Expr_Flags : out Expression_Flags; + IP : out Pointer); + -- Parse something followed by possible [*+?] + + procedure Parse_Atom + (Expr_Flags : out Expression_Flags; + IP : out Pointer); + -- Parse_Atom is the lowest level parse procedure. + -- + -- Optimization: Gobbles an entire sequence of ordinary characters so + -- that it can turn them into a single node, which is smaller to store + -- and faster to run. Backslashed characters are exceptions, each + -- becoming a separate node; the code is simpler that way and it's + -- not worth fixing. + + procedure Insert_Operator + (Op : Opcode; + Operand : Pointer; + Greedy : Boolean := True); + -- Insert_Operator inserts an operator in front of an already-emitted + -- operand and relocates the operand. This applies to PLUS and STAR. + -- If Minmod is True, then the operator is non-greedy. + + function Insert_Operator_Before + (Op : Opcode; + Operand : Pointer; + Greedy : Boolean; + Opsize : Pointer) return Pointer; + -- Insert an operator before Operand (and move the latter forward in the + -- program). Opsize is the size needed to represent the operator. This + -- returns the position at which the operator was inserted, and moves + -- Emit_Ptr after the new position of the operand. + + procedure Insert_Curly_Operator + (Op : Opcode; + Min : Natural; + Max : Natural; + Operand : Pointer; + Greedy : Boolean := True); + -- Insert an operator for CURLY ({Min}, {Min,} or {Min,Max}). + -- If Minmod is True, then the operator is non-greedy. + + procedure Link_Tail (P, Val : Pointer); + -- Link_Tail sets the next-pointer at the end of a node chain + + procedure Link_Operand_Tail (P, Val : Pointer); + -- Link_Tail on operand of first argument; noop if operand-less + + procedure Fail (M : String); + pragma No_Return (Fail); + -- Fail with a diagnostic message, if possible + + function Is_Curly_Operator (IP : Natural) return Boolean; + -- Return True if IP is looking at a '{' that is the beginning + -- of a curly operator, i.e. it matches {\d+,?\d*} + + function Is_Mult (IP : Natural) return Boolean; + -- Return True if C is a regexp multiplier: '+', '*' or '?' + + procedure Get_Curly_Arguments + (IP : Natural; + Min : out Natural; + Max : out Natural; + Greedy : out Boolean); + -- Parse the argument list for a curly operator. + -- It is assumed that IP is indeed pointing at a valid operator. + -- So what is IP and how come IP is not referenced in the body ??? + + procedure Parse_Character_Class (IP : out Pointer); + -- Parse a character class. + -- The calling subprogram should consume the opening '[' before. + + procedure Parse_Literal + (Expr_Flags : out Expression_Flags; + IP : out Pointer); + -- Parse_Literal encodes a string of characters to be matched exactly + + function Parse_Posix_Character_Class return Std_Class; + -- Parse a posix character class, like [:alpha:] or [:^alpha:]. + -- The caller is supposed to absorb the opening [. + + pragma Inline (Is_Mult); + pragma Inline (Emit_Natural); + pragma Inline (Parse_Character_Class); -- since used only once + + --------------- + -- Case_Emit -- + --------------- + + procedure Case_Emit (C : Character) is + begin + if (Flags and Case_Insensitive) /= 0 then + Emit (To_Lower (C)); + + else + -- Dump current character + + Emit (C); + end if; + end Case_Emit; + + ---------- + -- Emit -- + ---------- + + procedure Emit (B : Character) is + begin + if Emit_Ptr <= PM.Size then + Program (Emit_Ptr) := B; + end if; + + Emit_Ptr := Emit_Ptr + 1; + end Emit; + + ---------------- + -- Emit_Class -- + ---------------- + + procedure Emit_Class (Bitmap : Character_Class) is + subtype Program31 is Program_Data (0 .. 31); + + function Convert is new Ada.Unchecked_Conversion + (Character_Class, Program31); + + begin + -- What is the mysterious constant 31 here??? Can't it be expressed + -- symbolically (size of integer - 1 or some such???). In any case + -- it should be declared as a constant (and referenced presumably + -- as this constant + 1 below. + + if Emit_Ptr + 31 <= PM.Size then + Program (Emit_Ptr .. Emit_Ptr + 31) := Convert (Bitmap); + end if; + + Emit_Ptr := Emit_Ptr + 32; + end Emit_Class; + + ------------------ + -- Emit_Natural -- + ------------------ + + procedure Emit_Natural (IP : Pointer; N : Natural) is + begin + if IP + 1 <= PM.Size then + Program (IP + 1) := Character'Val (N / 256); + Program (IP) := Character'Val (N mod 256); + end if; + end Emit_Natural; + + --------------- + -- Emit_Node -- + --------------- + + function Emit_Node (Op : Opcode) return Pointer is + Result : constant Pointer := Emit_Ptr; + + begin + if Emit_Ptr + 2 <= PM.Size then + Program (Emit_Ptr) := Character'Val (Opcode'Pos (Op)); + Program (Emit_Ptr + 1) := ASCII.NUL; + Program (Emit_Ptr + 2) := ASCII.NUL; + end if; + + Emit_Ptr := Emit_Ptr + Next_Pointer_Bytes; + return Result; + end Emit_Node; + + ---------- + -- Fail -- + ---------- + + procedure Fail (M : String) is + begin + raise Expression_Error with M; + end Fail; + + ------------------------- + -- Get_Curly_Arguments -- + ------------------------- + + procedure Get_Curly_Arguments + (IP : Natural; + Min : out Natural; + Max : out Natural; + Greedy : out Boolean) + is + pragma Unreferenced (IP); + + Save_Pos : Natural := Parse_Pos + 1; + + begin + Min := 0; + Max := Max_Curly_Repeat; + + while Expression (Parse_Pos) /= '}' + and then Expression (Parse_Pos) /= ',' + loop + Parse_Pos := Parse_Pos + 1; + end loop; + + Min := Natural'Value (Expression (Save_Pos .. Parse_Pos - 1)); + + if Expression (Parse_Pos) = ',' then + Save_Pos := Parse_Pos + 1; + while Expression (Parse_Pos) /= '}' loop + Parse_Pos := Parse_Pos + 1; + end loop; + + if Save_Pos /= Parse_Pos then + Max := Natural'Value (Expression (Save_Pos .. Parse_Pos - 1)); + end if; + + else + Max := Min; + end if; + + if Parse_Pos < Expression'Last + and then Expression (Parse_Pos + 1) = '?' + then + Greedy := False; + Parse_Pos := Parse_Pos + 1; + + else + Greedy := True; + end if; + end Get_Curly_Arguments; + + --------------------------- + -- Insert_Curly_Operator -- + --------------------------- + + procedure Insert_Curly_Operator + (Op : Opcode; + Min : Natural; + Max : Natural; + Operand : Pointer; + Greedy : Boolean := True) + is + Old : Pointer; + begin + Old := Insert_Operator_Before (Op, Operand, Greedy, Opsize => 7); + Emit_Natural (Old + Next_Pointer_Bytes, Min); + Emit_Natural (Old + Next_Pointer_Bytes + 2, Max); + end Insert_Curly_Operator; + + ---------------------------- + -- Insert_Operator_Before -- + ---------------------------- + + function Insert_Operator_Before + (Op : Opcode; + Operand : Pointer; + Greedy : Boolean; + Opsize : Pointer) return Pointer + is + Dest : constant Pointer := Emit_Ptr; + Old : Pointer; + Size : Pointer := Opsize; + + begin + -- If not greedy, we have to emit another opcode first + + if not Greedy then + Size := Size + Next_Pointer_Bytes; + end if; + + -- Move the operand in the byte-compilation, so that we can insert + -- the operator before it. + + if Emit_Ptr + Size <= PM.Size then + Program (Operand + Size .. Emit_Ptr + Size) := + Program (Operand .. Emit_Ptr); + end if; + + -- Insert the operator at the position previously occupied by the + -- operand. + + Emit_Ptr := Operand; + + if not Greedy then + Old := Emit_Node (MINMOD); + Link_Tail (Old, Old + Next_Pointer_Bytes); + end if; + + Old := Emit_Node (Op); + Emit_Ptr := Dest + Size; + return Old; + end Insert_Operator_Before; + + --------------------- + -- Insert_Operator -- + --------------------- + + procedure Insert_Operator + (Op : Opcode; + Operand : Pointer; + Greedy : Boolean := True) + is + Discard : Pointer; + pragma Warnings (Off, Discard); + begin + Discard := Insert_Operator_Before + (Op, Operand, Greedy, Opsize => Next_Pointer_Bytes); + end Insert_Operator; + + ----------------------- + -- Is_Curly_Operator -- + ----------------------- + + function Is_Curly_Operator (IP : Natural) return Boolean is + Scan : Natural := IP; + + begin + if Expression (Scan) /= '{' + or else Scan + 2 > Expression'Last + or else not Is_Digit (Expression (Scan + 1)) + then + return False; + end if; + + Scan := Scan + 1; + + -- The first digit + + loop + Scan := Scan + 1; + + if Scan > Expression'Last then + return False; + end if; + + exit when not Is_Digit (Expression (Scan)); + end loop; + + if Expression (Scan) = ',' then + loop + Scan := Scan + 1; + + if Scan > Expression'Last then + return False; + end if; + + exit when not Is_Digit (Expression (Scan)); + end loop; + end if; + + return Expression (Scan) = '}'; + end Is_Curly_Operator; + + ------------- + -- Is_Mult -- + ------------- + + function Is_Mult (IP : Natural) return Boolean is + C : constant Character := Expression (IP); + + begin + return C = '*' + or else C = '+' + or else C = '?' + or else (C = '{' and then Is_Curly_Operator (IP)); + end Is_Mult; + + ----------------------- + -- Link_Operand_Tail -- + ----------------------- + + procedure Link_Operand_Tail (P, Val : Pointer) is + begin + if P <= PM.Size and then Program (P) = BRANCH then + Link_Tail (Operand (P), Val); + end if; + end Link_Operand_Tail; + + --------------- + -- Link_Tail -- + --------------- + + procedure Link_Tail (P, Val : Pointer) is + Scan : Pointer; + Temp : Pointer; + Offset : Pointer; + + begin + -- Find last node (the size of the pattern matcher might be too + -- small, so don't try to read past its end). + + Scan := P; + while Scan + Next_Pointer_Bytes <= PM.Size loop + Temp := Get_Next (Program, Scan); + exit when Temp = Scan; + Scan := Temp; + end loop; + + Offset := Val - Scan; + + Emit_Natural (Scan + 1, Natural (Offset)); + end Link_Tail; + + ----------- + -- Parse -- + ----------- + + -- Combining parenthesis handling with the base level of regular + -- expression is a trifle forced, but the need to tie the tails of the + -- the branches to what follows makes it hard to avoid. + + procedure Parse + (Parenthesized : Boolean; + Flags : out Expression_Flags; + IP : out Pointer) + is + E : String renames Expression; + Br, Br2 : Pointer; + Ender : Pointer; + Par_No : Natural; + New_Flags : Expression_Flags; + Have_Branch : Boolean := False; + + begin + Flags := (Has_Width => True, others => False); -- Tentatively + + -- Make an OPEN node, if parenthesized + + if Parenthesized then + if Matcher.Paren_Count > Max_Paren_Count then + Fail ("too many ()"); + end if; + + Par_No := Matcher.Paren_Count + 1; + Matcher.Paren_Count := Matcher.Paren_Count + 1; + IP := Emit_Node (OPEN); + Emit (Character'Val (Par_No)); + + else + IP := 0; + Par_No := 0; + end if; + + -- Pick up the branches, linking them together + + Parse_Branch (New_Flags, True, Br); + + if Br = 0 then + IP := 0; + return; + end if; + + if Parse_Pos <= Parse_End + and then E (Parse_Pos) = '|' + then + Insert_Operator (BRANCH, Br); + Have_Branch := True; + end if; + + if IP /= 0 then + Link_Tail (IP, Br); -- OPEN -> first + else + IP := Br; + end if; + + if not New_Flags.Has_Width then + Flags.Has_Width := False; + end if; + + Flags.SP_Start := Flags.SP_Start or else New_Flags.SP_Start; + + while Parse_Pos <= Parse_End + and then (E (Parse_Pos) = '|') + loop + Parse_Pos := Parse_Pos + 1; + Parse_Branch (New_Flags, False, Br); + + if Br = 0 then + IP := 0; + return; + end if; + + Link_Tail (IP, Br); -- BRANCH -> BRANCH + + if not New_Flags.Has_Width then + Flags.Has_Width := False; + end if; + + Flags.SP_Start := Flags.SP_Start or else New_Flags.SP_Start; + end loop; + + -- Make a closing node, and hook it on the end + + if Parenthesized then + Ender := Emit_Node (CLOSE); + Emit (Character'Val (Par_No)); + else + Ender := Emit_Node (EOP); + end if; + + Link_Tail (IP, Ender); + + if Have_Branch and then Emit_Ptr <= PM.Size then + + -- Hook the tails of the branches to the closing node + + Br := IP; + loop + Link_Operand_Tail (Br, Ender); + Br2 := Get_Next (Program, Br); + exit when Br2 = Br; + Br := Br2; + end loop; + end if; + + -- Check for proper termination + + if Parenthesized then + if Parse_Pos > Parse_End or else E (Parse_Pos) /= ')' then + Fail ("unmatched ()"); + end if; + + Parse_Pos := Parse_Pos + 1; + + elsif Parse_Pos <= Parse_End then + if E (Parse_Pos) = ')' then + Fail ("unmatched ()"); + else + Fail ("junk on end"); -- "Can't happen" + end if; + end if; + end Parse; + + ---------------- + -- Parse_Atom -- + ---------------- + + procedure Parse_Atom + (Expr_Flags : out Expression_Flags; + IP : out Pointer) + is + C : Character; + + begin + -- Tentatively set worst expression case + + Expr_Flags := Worst_Expression; + + C := Expression (Parse_Pos); + Parse_Pos := Parse_Pos + 1; + + case (C) is + when '^' => + IP := + Emit_Node + (if (Flags and Multiple_Lines) /= 0 then MBOL + elsif (Flags and Single_Line) /= 0 then SBOL + else BOL); + + when '$' => + IP := + Emit_Node + (if (Flags and Multiple_Lines) /= 0 then MEOL + elsif (Flags and Single_Line) /= 0 then SEOL + else EOL); + + when '.' => + IP := + Emit_Node + (if (Flags and Single_Line) /= 0 then SANY else ANY); + + Expr_Flags.Has_Width := True; + Expr_Flags.Simple := True; + + when '[' => + Parse_Character_Class (IP); + Expr_Flags.Has_Width := True; + Expr_Flags.Simple := True; + + when '(' => + declare + New_Flags : Expression_Flags; + + begin + Parse (True, New_Flags, IP); + + if IP = 0 then + return; + end if; + + Expr_Flags.Has_Width := + Expr_Flags.Has_Width or else New_Flags.Has_Width; + Expr_Flags.SP_Start := + Expr_Flags.SP_Start or else New_Flags.SP_Start; + end; + + when '|' | ASCII.LF | ')' => + Fail ("internal urp"); -- Supposed to be caught earlier + + when '?' | '+' | '*' => + Fail (C & " follows nothing"); + + when '{' => + if Is_Curly_Operator (Parse_Pos - 1) then + Fail (C & " follows nothing"); + else + Parse_Literal (Expr_Flags, IP); + end if; + + when '\' => + if Parse_Pos > Parse_End then + Fail ("trailing \"); + end if; + + Parse_Pos := Parse_Pos + 1; + + case Expression (Parse_Pos - 1) is + when 'b' => + IP := Emit_Node (BOUND); + + when 'B' => + IP := Emit_Node (NBOUND); + + when 's' => + IP := Emit_Node (SPACE); + Expr_Flags.Simple := True; + Expr_Flags.Has_Width := True; + + when 'S' => + IP := Emit_Node (NSPACE); + Expr_Flags.Simple := True; + Expr_Flags.Has_Width := True; + + when 'd' => + IP := Emit_Node (DIGIT); + Expr_Flags.Simple := True; + Expr_Flags.Has_Width := True; + + when 'D' => + IP := Emit_Node (NDIGIT); + Expr_Flags.Simple := True; + Expr_Flags.Has_Width := True; + + when 'w' => + IP := Emit_Node (ALNUM); + Expr_Flags.Simple := True; + Expr_Flags.Has_Width := True; + + when 'W' => + IP := Emit_Node (NALNUM); + Expr_Flags.Simple := True; + Expr_Flags.Has_Width := True; + + when 'A' => + IP := Emit_Node (SBOL); + + when 'G' => + IP := Emit_Node (SEOL); + + when '0' .. '9' => + IP := Emit_Node (REFF); + + declare + Save : constant Natural := Parse_Pos - 1; + + begin + while Parse_Pos <= Expression'Last + and then Is_Digit (Expression (Parse_Pos)) + loop + Parse_Pos := Parse_Pos + 1; + end loop; + + Emit (Character'Val (Natural'Value + (Expression (Save .. Parse_Pos - 1)))); + end; + + when others => + Parse_Pos := Parse_Pos - 1; + Parse_Literal (Expr_Flags, IP); + end case; + + when others => + Parse_Literal (Expr_Flags, IP); + end case; + end Parse_Atom; + + ------------------ + -- Parse_Branch -- + ------------------ + + procedure Parse_Branch + (Flags : out Expression_Flags; + First : Boolean; + IP : out Pointer) + is + E : String renames Expression; + Chain : Pointer; + Last : Pointer; + New_Flags : Expression_Flags; + + Discard : Pointer; + pragma Warnings (Off, Discard); + + begin + Flags := Worst_Expression; -- Tentatively + IP := (if First then Emit_Ptr else Emit_Node (BRANCH)); + + Chain := 0; + while Parse_Pos <= Parse_End + and then E (Parse_Pos) /= ')' + and then E (Parse_Pos) /= ASCII.LF + and then E (Parse_Pos) /= '|' + loop + Parse_Piece (New_Flags, Last); + + if Last = 0 then + IP := 0; + return; + end if; + + Flags.Has_Width := Flags.Has_Width or else New_Flags.Has_Width; + + if Chain = 0 then -- First piece + Flags.SP_Start := Flags.SP_Start or else New_Flags.SP_Start; + else + Link_Tail (Chain, Last); + end if; + + Chain := Last; + end loop; + + -- Case where loop ran zero CURLY + + if Chain = 0 then + Discard := Emit_Node (NOTHING); + end if; + end Parse_Branch; + + --------------------------- + -- Parse_Character_Class -- + --------------------------- + + procedure Parse_Character_Class (IP : out Pointer) is + Bitmap : Character_Class; + Invert : Boolean := False; + In_Range : Boolean := False; + Named_Class : Std_Class := ANYOF_NONE; + Value : Character; + Last_Value : Character := ASCII.NUL; + + begin + Reset_Class (Bitmap); + + -- Do we have an invert character class ? + + if Parse_Pos <= Parse_End + and then Expression (Parse_Pos) = '^' + then + Invert := True; + Parse_Pos := Parse_Pos + 1; + end if; + + -- First character can be ] or - without closing the class + + if Parse_Pos <= Parse_End + and then (Expression (Parse_Pos) = ']' + or else Expression (Parse_Pos) = '-') + then + Set_In_Class (Bitmap, Expression (Parse_Pos)); + Parse_Pos := Parse_Pos + 1; + end if; + + -- While we don't have the end of the class + + while Parse_Pos <= Parse_End + and then Expression (Parse_Pos) /= ']' + loop + Named_Class := ANYOF_NONE; + Value := Expression (Parse_Pos); + Parse_Pos := Parse_Pos + 1; + + -- Do we have a Posix character class + if Value = '[' then + Named_Class := Parse_Posix_Character_Class; + + elsif Value = '\' then + if Parse_Pos = Parse_End then + Fail ("Trailing \"); + end if; + Value := Expression (Parse_Pos); + Parse_Pos := Parse_Pos + 1; + + case Value is + when 'w' => Named_Class := ANYOF_ALNUM; + when 'W' => Named_Class := ANYOF_NALNUM; + when 's' => Named_Class := ANYOF_SPACE; + when 'S' => Named_Class := ANYOF_NSPACE; + when 'd' => Named_Class := ANYOF_DIGIT; + when 'D' => Named_Class := ANYOF_NDIGIT; + when 'n' => Value := ASCII.LF; + when 'r' => Value := ASCII.CR; + when 't' => Value := ASCII.HT; + when 'f' => Value := ASCII.FF; + when 'e' => Value := ASCII.ESC; + when 'a' => Value := ASCII.BEL; + + -- when 'x' => ??? hexadecimal value + -- when 'c' => ??? control character + -- when '0'..'9' => ??? octal character + + when others => null; + end case; + end if; + + -- Do we have a character class? + + if Named_Class /= ANYOF_NONE then + + -- A range like 'a-\d' or 'a-[:digit:] is not a range + + if In_Range then + Set_In_Class (Bitmap, Last_Value); + Set_In_Class (Bitmap, '-'); + In_Range := False; + end if; + + -- Expand the range + + case Named_Class is + when ANYOF_NONE => null; + + when ANYOF_ALNUM | ANYOF_ALNUMC => + for Value in Class_Byte'Range loop + if Is_Alnum (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NALNUM | ANYOF_NALNUMC => + for Value in Class_Byte'Range loop + if not Is_Alnum (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_SPACE => + for Value in Class_Byte'Range loop + if Is_White_Space (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NSPACE => + for Value in Class_Byte'Range loop + if not Is_White_Space (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_DIGIT => + for Value in Class_Byte'Range loop + if Is_Digit (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NDIGIT => + for Value in Class_Byte'Range loop + if not Is_Digit (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_ALPHA => + for Value in Class_Byte'Range loop + if Is_Letter (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NALPHA => + for Value in Class_Byte'Range loop + if not Is_Letter (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_ASCII => + for Value in 0 .. 127 loop + Set_In_Class (Bitmap, Character'Val (Value)); + end loop; + + when ANYOF_NASCII => + for Value in 128 .. 255 loop + Set_In_Class (Bitmap, Character'Val (Value)); + end loop; + + when ANYOF_CNTRL => + for Value in Class_Byte'Range loop + if Is_Control (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NCNTRL => + for Value in Class_Byte'Range loop + if not Is_Control (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_GRAPH => + for Value in Class_Byte'Range loop + if Is_Graphic (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NGRAPH => + for Value in Class_Byte'Range loop + if not Is_Graphic (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_LOWER => + for Value in Class_Byte'Range loop + if Is_Lower (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NLOWER => + for Value in Class_Byte'Range loop + if not Is_Lower (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_PRINT => + for Value in Class_Byte'Range loop + if Is_Printable (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NPRINT => + for Value in Class_Byte'Range loop + if not Is_Printable (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_PUNCT => + for Value in Class_Byte'Range loop + if Is_Printable (Character'Val (Value)) + and then not Is_White_Space (Character'Val (Value)) + and then not Is_Alnum (Character'Val (Value)) + then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NPUNCT => + for Value in Class_Byte'Range loop + if not Is_Printable (Character'Val (Value)) + or else Is_White_Space (Character'Val (Value)) + or else Is_Alnum (Character'Val (Value)) + then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_UPPER => + for Value in Class_Byte'Range loop + if Is_Upper (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NUPPER => + for Value in Class_Byte'Range loop + if not Is_Upper (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_XDIGIT => + for Value in Class_Byte'Range loop + if Is_Hexadecimal_Digit (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NXDIGIT => + for Value in Class_Byte'Range loop + if not Is_Hexadecimal_Digit + (Character'Val (Value)) + then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + end case; + + -- Not a character range + + elsif not In_Range then + Last_Value := Value; + + if Parse_Pos > Expression'Last then + Fail ("Empty character class []"); + end if; + + if Expression (Parse_Pos) = '-' + and then Parse_Pos < Parse_End + and then Expression (Parse_Pos + 1) /= ']' + then + Parse_Pos := Parse_Pos + 1; + + -- Do we have a range like '\d-a' and '[:space:]-a' + -- which is not a real range + + if Named_Class /= ANYOF_NONE then + Set_In_Class (Bitmap, '-'); + else + In_Range := True; + end if; + + else + Set_In_Class (Bitmap, Value); + + end if; + + -- Else in a character range + + else + if Last_Value > Value then + Fail ("Invalid Range [" & Last_Value'Img + & "-" & Value'Img & "]"); + end if; + + while Last_Value <= Value loop + Set_In_Class (Bitmap, Last_Value); + Last_Value := Character'Succ (Last_Value); + end loop; + + In_Range := False; + + end if; + + end loop; + + -- Optimize case-insensitive ranges (put the upper case or lower + -- case character into the bitmap) + + if (Flags and Case_Insensitive) /= 0 then + for C in Character'Range loop + if Get_From_Class (Bitmap, C) then + Set_In_Class (Bitmap, To_Lower (C)); + Set_In_Class (Bitmap, To_Upper (C)); + end if; + end loop; + end if; + + -- Optimize inverted classes + + if Invert then + for J in Bitmap'Range loop + Bitmap (J) := not Bitmap (J); + end loop; + end if; + + Parse_Pos := Parse_Pos + 1; + + -- Emit the class + + IP := Emit_Node (ANYOF); + Emit_Class (Bitmap); + end Parse_Character_Class; + + ------------------- + -- Parse_Literal -- + ------------------- + + -- This is a bit tricky due to quoted chars and due to + -- the multiplier characters '*', '+', and '?' that + -- take the SINGLE char previous as their operand. + + -- On entry, the character at Parse_Pos - 1 is going to go + -- into the string, no matter what it is. It could be + -- following a \ if Parse_Atom was entered from the '\' case. + + -- Basic idea is to pick up a good char in C and examine + -- the next char. If Is_Mult (C) then twiddle, if it's a \ + -- then frozzle and if it's another magic char then push C and + -- terminate the string. If none of the above, push C on the + -- string and go around again. + + -- Start_Pos is used to remember where "the current character" + -- starts in the string, if due to an Is_Mult we need to back + -- up and put the current char in a separate 1-character string. + -- When Start_Pos is 0, C is the only char in the string; + -- this is used in Is_Mult handling, and in setting the SIMPLE + -- flag at the end. + + procedure Parse_Literal + (Expr_Flags : out Expression_Flags; + IP : out Pointer) + is + Start_Pos : Natural := 0; + C : Character; + Length_Ptr : Pointer; + + Has_Special_Operator : Boolean := False; + + begin + Parse_Pos := Parse_Pos - 1; -- Look at current character + + IP := + Emit_Node + (if (Flags and Case_Insensitive) /= 0 then EXACTF else EXACT); + + Length_Ptr := Emit_Ptr; + Emit_Ptr := String_Operand (IP); + + Parse_Loop : + loop + C := Expression (Parse_Pos); -- Get current character + + case C is + when '.' | '[' | '(' | ')' | '|' | ASCII.LF | '$' | '^' => + + if Start_Pos = 0 then + Start_Pos := Parse_Pos; + Emit (C); -- First character is always emitted + else + exit Parse_Loop; -- Else we are done + end if; + + when '?' | '+' | '*' | '{' => + + if Start_Pos = 0 then + Start_Pos := Parse_Pos; + Emit (C); -- First character is always emitted + + -- Are we looking at an operator, or is this + -- simply a normal character ? + + elsif not Is_Mult (Parse_Pos) then + Start_Pos := Parse_Pos; + Case_Emit (C); + + else + -- We've got something like "abc?d". Mark this as a + -- special case. What we want to emit is a first + -- constant string for "ab", then one for "c" that will + -- ultimately be transformed with a CURLY operator, A + -- special case has to be handled for "a?", since there + -- is no initial string to emit. + + Has_Special_Operator := True; + exit Parse_Loop; + end if; + + when '\' => + Start_Pos := Parse_Pos; + + if Parse_Pos = Parse_End then + Fail ("Trailing \"); + + else + case Expression (Parse_Pos + 1) is + when 'b' | 'B' | 's' | 'S' | 'd' | 'D' + | 'w' | 'W' | '0' .. '9' | 'G' | 'A' + => exit Parse_Loop; + when 'n' => Emit (ASCII.LF); + when 't' => Emit (ASCII.HT); + when 'r' => Emit (ASCII.CR); + when 'f' => Emit (ASCII.FF); + when 'e' => Emit (ASCII.ESC); + when 'a' => Emit (ASCII.BEL); + when others => Emit (Expression (Parse_Pos + 1)); + end case; + + Parse_Pos := Parse_Pos + 1; + end if; + + when others => + Start_Pos := Parse_Pos; + Case_Emit (C); + end case; + + exit Parse_Loop when Emit_Ptr - Length_Ptr = 254; + + Parse_Pos := Parse_Pos + 1; + + exit Parse_Loop when Parse_Pos > Parse_End; + end loop Parse_Loop; + + -- Is the string followed by a '*+?{' operator ? If yes, and if there + -- is an initial string to emit, do it now. + + if Has_Special_Operator + and then Emit_Ptr >= Length_Ptr + Next_Pointer_Bytes + then + Emit_Ptr := Emit_Ptr - 1; + Parse_Pos := Start_Pos; + end if; + + if Length_Ptr <= PM.Size then + Program (Length_Ptr) := Character'Val (Emit_Ptr - Length_Ptr - 2); + end if; + + Expr_Flags.Has_Width := True; + + -- Slight optimization when there is a single character + + if Emit_Ptr = Length_Ptr + 2 then + Expr_Flags.Simple := True; + end if; + end Parse_Literal; + + ----------------- + -- Parse_Piece -- + ----------------- + + -- Note that the branching code sequences used for '?' and the + -- general cases of '*' and + are somewhat optimized: they use + -- the same NOTHING node as both the endmarker for their branch + -- list and the body of the last branch. It might seem that + -- this node could be dispensed with entirely, but the endmarker + -- role is not redundant. + + procedure Parse_Piece + (Expr_Flags : out Expression_Flags; + IP : out Pointer) + is + Op : Character; + New_Flags : Expression_Flags; + Greedy : Boolean := True; + + begin + Parse_Atom (New_Flags, IP); + + if IP = 0 then + return; + end if; + + if Parse_Pos > Parse_End + or else not Is_Mult (Parse_Pos) + then + Expr_Flags := New_Flags; + return; + end if; + + Op := Expression (Parse_Pos); + + Expr_Flags := + (if Op /= '+' + then (SP_Start => True, others => False) + else (Has_Width => True, others => False)); + + -- Detect non greedy operators in the easy cases + + if Op /= '{' + and then Parse_Pos + 1 <= Parse_End + and then Expression (Parse_Pos + 1) = '?' + then + Greedy := False; + Parse_Pos := Parse_Pos + 1; + end if; + + -- Generate the byte code + + case Op is + when '*' => + + if New_Flags.Simple then + Insert_Operator (STAR, IP, Greedy); + else + Link_Tail (IP, Emit_Node (WHILEM)); + Insert_Curly_Operator + (CURLYX, 0, Max_Curly_Repeat, IP, Greedy); + Link_Tail (IP, Emit_Node (NOTHING)); + end if; + + when '+' => + + if New_Flags.Simple then + Insert_Operator (PLUS, IP, Greedy); + else + Link_Tail (IP, Emit_Node (WHILEM)); + Insert_Curly_Operator + (CURLYX, 1, Max_Curly_Repeat, IP, Greedy); + Link_Tail (IP, Emit_Node (NOTHING)); + end if; + + when '?' => + if New_Flags.Simple then + Insert_Curly_Operator (CURLY, 0, 1, IP, Greedy); + else + Link_Tail (IP, Emit_Node (WHILEM)); + Insert_Curly_Operator (CURLYX, 0, 1, IP, Greedy); + Link_Tail (IP, Emit_Node (NOTHING)); + end if; + + when '{' => + declare + Min, Max : Natural; + + begin + Get_Curly_Arguments (Parse_Pos, Min, Max, Greedy); + + if New_Flags.Simple then + Insert_Curly_Operator (CURLY, Min, Max, IP, Greedy); + else + Link_Tail (IP, Emit_Node (WHILEM)); + Insert_Curly_Operator (CURLYX, Min, Max, IP, Greedy); + Link_Tail (IP, Emit_Node (NOTHING)); + end if; + end; + + when others => + null; + end case; + + Parse_Pos := Parse_Pos + 1; + + if Parse_Pos <= Parse_End + and then Is_Mult (Parse_Pos) + then + Fail ("nested *+{"); + end if; + end Parse_Piece; + + --------------------------------- + -- Parse_Posix_Character_Class -- + --------------------------------- + + function Parse_Posix_Character_Class return Std_Class is + Invert : Boolean := False; + Class : Std_Class := ANYOF_NONE; + E : String renames Expression; + + -- Class names. Note that code assumes that the length of all + -- classes starting with the same letter have the same length. + + Alnum : constant String := "alnum:]"; + Alpha : constant String := "alpha:]"; + Ascii_C : constant String := "ascii:]"; + Cntrl : constant String := "cntrl:]"; + Digit : constant String := "digit:]"; + Graph : constant String := "graph:]"; + Lower : constant String := "lower:]"; + Print : constant String := "print:]"; + Punct : constant String := "punct:]"; + Space : constant String := "space:]"; + Upper : constant String := "upper:]"; + Word : constant String := "word:]"; + Xdigit : constant String := "xdigit:]"; + + begin + -- Case of character class specified + + if Parse_Pos <= Parse_End + and then Expression (Parse_Pos) = ':' + then + Parse_Pos := Parse_Pos + 1; + + -- Do we have something like: [[:^alpha:]] + + if Parse_Pos <= Parse_End + and then Expression (Parse_Pos) = '^' + then + Invert := True; + Parse_Pos := Parse_Pos + 1; + end if; + + -- Check for class names based on first letter + + case Expression (Parse_Pos) is + when 'a' => + + -- All 'a' classes have the same length (Alnum'Length) + + if Parse_Pos + Alnum'Length - 1 <= Parse_End then + if + E (Parse_Pos .. Parse_Pos + Alnum'Length - 1) = Alnum + then + Class := + (if Invert then ANYOF_NALNUMC else ANYOF_ALNUMC); + Parse_Pos := Parse_Pos + Alnum'Length; + + elsif + E (Parse_Pos .. Parse_Pos + Alpha'Length - 1) = Alpha + then + Class := + (if Invert then ANYOF_NALPHA else ANYOF_ALPHA); + Parse_Pos := Parse_Pos + Alpha'Length; + + elsif E (Parse_Pos .. Parse_Pos + Ascii_C'Length - 1) = + Ascii_C + then + Class := + (if Invert then ANYOF_NASCII else ANYOF_ASCII); + Parse_Pos := Parse_Pos + Ascii_C'Length; + else + Fail ("Invalid character class: " & E); + end if; + + else + Fail ("Invalid character class: " & E); + end if; + + when 'c' => + if Parse_Pos + Cntrl'Length - 1 <= Parse_End + and then + E (Parse_Pos .. Parse_Pos + Cntrl'Length - 1) = Cntrl + then + Class := (if Invert then ANYOF_NCNTRL else ANYOF_CNTRL); + Parse_Pos := Parse_Pos + Cntrl'Length; + else + Fail ("Invalid character class: " & E); + end if; + + when 'd' => + if Parse_Pos + Digit'Length - 1 <= Parse_End + and then + E (Parse_Pos .. Parse_Pos + Digit'Length - 1) = Digit + then + Class := (if Invert then ANYOF_NDIGIT else ANYOF_DIGIT); + Parse_Pos := Parse_Pos + Digit'Length; + end if; + + when 'g' => + if Parse_Pos + Graph'Length - 1 <= Parse_End + and then + E (Parse_Pos .. Parse_Pos + Graph'Length - 1) = Graph + then + Class := (if Invert then ANYOF_NGRAPH else ANYOF_GRAPH); + Parse_Pos := Parse_Pos + Graph'Length; + else + Fail ("Invalid character class: " & E); + end if; + + when 'l' => + if Parse_Pos + Lower'Length - 1 <= Parse_End + and then + E (Parse_Pos .. Parse_Pos + Lower'Length - 1) = Lower + then + Class := (if Invert then ANYOF_NLOWER else ANYOF_LOWER); + Parse_Pos := Parse_Pos + Lower'Length; + else + Fail ("Invalid character class: " & E); + end if; + + when 'p' => + + -- All 'p' classes have the same length + + if Parse_Pos + Print'Length - 1 <= Parse_End then + if + E (Parse_Pos .. Parse_Pos + Print'Length - 1) = Print + then + Class := + (if Invert then ANYOF_NPRINT else ANYOF_PRINT); + Parse_Pos := Parse_Pos + Print'Length; + + elsif + E (Parse_Pos .. Parse_Pos + Punct'Length - 1) = Punct + then + Class := + (if Invert then ANYOF_NPUNCT else ANYOF_PUNCT); + Parse_Pos := Parse_Pos + Punct'Length; + + else + Fail ("Invalid character class: " & E); + end if; + + else + Fail ("Invalid character class: " & E); + end if; + + when 's' => + if Parse_Pos + Space'Length - 1 <= Parse_End + and then + E (Parse_Pos .. Parse_Pos + Space'Length - 1) = Space + then + Class := (if Invert then ANYOF_NSPACE else ANYOF_SPACE); + Parse_Pos := Parse_Pos + Space'Length; + else + Fail ("Invalid character class: " & E); + end if; + + when 'u' => + if Parse_Pos + Upper'Length - 1 <= Parse_End + and then + E (Parse_Pos .. Parse_Pos + Upper'Length - 1) = Upper + then + Class := (if Invert then ANYOF_NUPPER else ANYOF_UPPER); + Parse_Pos := Parse_Pos + Upper'Length; + else + Fail ("Invalid character class: " & E); + end if; + + when 'w' => + if Parse_Pos + Word'Length - 1 <= Parse_End + and then + E (Parse_Pos .. Parse_Pos + Word'Length - 1) = Word + then + Class := (if Invert then ANYOF_NALNUM else ANYOF_ALNUM); + Parse_Pos := Parse_Pos + Word'Length; + else + Fail ("Invalid character class: " & E); + end if; + + when 'x' => + if Parse_Pos + Xdigit'Length - 1 <= Parse_End + and then + E (Parse_Pos .. Parse_Pos + Xdigit'Length - 1) = Xdigit + then + Class := (if Invert then ANYOF_NXDIGIT else ANYOF_XDIGIT); + Parse_Pos := Parse_Pos + Xdigit'Length; + + else + Fail ("Invalid character class: " & E); + end if; + + when others => + Fail ("Invalid character class: " & E); + end case; + + -- Character class not specified + + else + return ANYOF_NONE; + end if; + + return Class; + end Parse_Posix_Character_Class; + + -- Local Declarations + + Result : Pointer; + + Expr_Flags : Expression_Flags; + pragma Unreferenced (Expr_Flags); + + -- Start of processing for Compile + + begin + Parse (False, Expr_Flags, Result); + + if Result = 0 then + Fail ("Couldn't compile expression"); + end if; + + Final_Code_Size := Emit_Ptr - 1; + + -- Do we want to actually compile the expression, or simply get the + -- code size ??? + + if Emit_Ptr <= PM.Size then + Optimize (PM); + end if; + + PM.Flags := Flags; + end Compile; + + function Compile + (Expression : String; + Flags : Regexp_Flags := No_Flags) return Pattern_Matcher + is + -- Assume the compiled regexp will fit in 1000 chars. If it does not we + -- will have to compile a second time once the correct size is known. If + -- it fits, we save a significant amount of time by avoiding the second + -- compilation. + + Dummy : Pattern_Matcher (1000); + Size : Program_Size; + + begin + Compile (Dummy, Expression, Size, Flags); + + if Size <= Dummy.Size then + return Pattern_Matcher' + (Size => Size, + First => Dummy.First, + Anchored => Dummy.Anchored, + Must_Have => Dummy.Must_Have, + Must_Have_Length => Dummy.Must_Have_Length, + Paren_Count => Dummy.Paren_Count, + Flags => Dummy.Flags, + Program => Dummy.Program + (Dummy.Program'First .. Dummy.Program'First + Size - 1)); + else + -- We have to recompile now that we know the size + -- ??? Can we use Ada05's return construct ? + declare + Result : Pattern_Matcher (Size); + begin + Compile (Result, Expression, Size, Flags); + return Result; + end; + end if; + end Compile; + + procedure Compile + (Matcher : out Pattern_Matcher; + Expression : String; + Flags : Regexp_Flags := No_Flags) + is + Size : Program_Size; + + begin + Compile (Matcher, Expression, Size, Flags); + + if Size > Matcher.Size then + raise Expression_Error with "Pattern_Matcher is too small"; + end if; + end Compile; + + -------------------- + -- Dump_Operation -- + -------------------- + + procedure Dump_Operation + (Program : Program_Data; + Index : Pointer; + Indent : Natural) + is + Current : Pointer := Index; + begin + Dump_Until (Program, Current, Current + 1, Indent); + end Dump_Operation; + + ---------------- + -- Dump_Until -- + ---------------- + + procedure Dump_Until + (Program : Program_Data; + Index : in out Pointer; + Till : Pointer; + Indent : Natural; + Do_Print : Boolean := True) + is + function Image (S : String) return String; + -- Remove leading space + + ----------- + -- Image -- + ----------- + + function Image (S : String) return String is + begin + if S (S'First) = ' ' then + return S (S'First + 1 .. S'Last); + else + return S; + end if; + end Image; + + -- Local variables + + Op : Opcode; + Next : Pointer; + Length : Pointer; + Local_Indent : Natural := Indent; + + -- Start of processing for Dump_Until + + begin + while Index < Till loop + Op := Opcode'Val (Character'Pos ((Program (Index)))); + Next := Get_Next (Program, Index); + + if Do_Print then + declare + Point : constant String := Pointer'Image (Index); + begin + Put ((1 .. 4 - Point'Length => ' ') + & Point & ":" + & (1 .. Local_Indent * 2 => ' ') & Opcode'Image (Op)); + end; + + -- Print the parenthesis number + + if Op = OPEN or else Op = CLOSE or else Op = REFF then + Put (Image (Natural'Image + (Character'Pos + (Program (Index + Next_Pointer_Bytes))))); + end if; + + if Next = Index then + Put (" (-)"); + else + Put (" (" & Image (Pointer'Image (Next)) & ")"); + end if; + end if; + + case Op is + when ANYOF => + declare + Bitmap : Character_Class; + Last : Character := ASCII.NUL; + Current : Natural := 0; + Current_Char : Character; + + begin + Bitmap_Operand (Program, Index, Bitmap); + + if Do_Print then + Put ("["); + + while Current <= 255 loop + Current_Char := Character'Val (Current); + + -- First item in a range + + if Get_From_Class (Bitmap, Current_Char) then + Last := Current_Char; + + -- Search for the last item in the range + + loop + Current := Current + 1; + exit when Current > 255; + Current_Char := Character'Val (Current); + exit when + not Get_From_Class (Bitmap, Current_Char); + end loop; + + if not Is_Graphic (Last) then + Put (Last'Img); + else + Put (Last); + end if; + + if Character'Succ (Last) /= Current_Char then + Put ("\-" & Character'Pred (Current_Char)); + end if; + + else + Current := Current + 1; + end if; + end loop; + + Put_Line ("]"); + end if; + + Index := Index + Next_Pointer_Bytes + Bitmap'Length; + end; + + when EXACT | EXACTF => + Length := String_Length (Program, Index); + if Do_Print then + Put (" (" & Image (Program_Size'Image (Length + 1)) + & " chars) <" + & String (Program (String_Operand (Index) + .. String_Operand (Index) + + Length))); + Put_Line (">"); + end if; + + Index := String_Operand (Index) + Length + 1; + + -- Node operand + + when BRANCH | STAR | PLUS => + if Do_Print then + New_Line; + end if; + + Index := Index + Next_Pointer_Bytes; + Dump_Until (Program, Index, Pointer'Min (Next, Till), + Local_Indent + 1, Do_Print); + + when CURLY | CURLYX => + if Do_Print then + Put_Line + (" {" + & Image (Natural'Image + (Read_Natural (Program, Index + Next_Pointer_Bytes))) + & "," + & Image (Natural'Image (Read_Natural (Program, Index + 5))) + & "}"); + end if; + + Index := Index + 7; + Dump_Until (Program, Index, Pointer'Min (Next, Till), + Local_Indent + 1, Do_Print); + + when OPEN => + if Do_Print then + New_Line; + end if; + + Index := Index + 4; + Local_Indent := Local_Indent + 1; + + when CLOSE | REFF => + if Do_Print then + New_Line; + end if; + + Index := Index + 4; + + if Op = CLOSE then + Local_Indent := Local_Indent - 1; + end if; + + when others => + Index := Index + Next_Pointer_Bytes; + + if Do_Print then + New_Line; + end if; + + exit when Op = EOP; + end case; + end loop; + end Dump_Until; + + ---------- + -- Dump -- + ---------- + + procedure Dump (Self : Pattern_Matcher) is + Program : Program_Data renames Self.Program; + Index : Pointer := Program'First; + + -- Start of processing for Dump + + begin + Put_Line ("Must start with (Self.First) = " + & Character'Image (Self.First)); + + if (Self.Flags and Case_Insensitive) /= 0 then + Put_Line (" Case_Insensitive mode"); + end if; + + if (Self.Flags and Single_Line) /= 0 then + Put_Line (" Single_Line mode"); + end if; + + if (Self.Flags and Multiple_Lines) /= 0 then + Put_Line (" Multiple_Lines mode"); + end if; + + Dump_Until (Program, Index, Self.Program'Last + 1, 0); + end Dump; + + -------------------- + -- Get_From_Class -- + -------------------- + + function Get_From_Class + (Bitmap : Character_Class; + C : Character) return Boolean + is + Value : constant Class_Byte := Character'Pos (C); + begin + return + (Bitmap (Value / 8) and Bit_Conversion (Value mod 8)) /= 0; + end Get_From_Class; + + -------------- + -- Get_Next -- + -------------- + + function Get_Next (Program : Program_Data; IP : Pointer) return Pointer is + begin + return IP + Pointer (Read_Natural (Program, IP + 1)); + end Get_Next; + + -------------- + -- Is_Alnum -- + -------------- + + function Is_Alnum (C : Character) return Boolean is + begin + return Is_Alphanumeric (C) or else C = '_'; + end Is_Alnum; + + ------------------ + -- Is_Printable -- + ------------------ + + function Is_Printable (C : Character) return Boolean is + begin + -- Printable if space or graphic character or other whitespace + -- Other white space includes (HT/LF/VT/FF/CR = codes 9-13) + + return C in Character'Val (32) .. Character'Val (126) + or else C in ASCII.HT .. ASCII.CR; + end Is_Printable; + + -------------------- + -- Is_White_Space -- + -------------------- + + function Is_White_Space (C : Character) return Boolean is + begin + -- Note: HT = 9, LF = 10, VT = 11, FF = 12, CR = 13 + + return C = ' ' or else C in ASCII.HT .. ASCII.CR; + end Is_White_Space; + + ----------- + -- Match -- + ----------- + + procedure Match + (Self : Pattern_Matcher; + Data : String; + Matches : out Match_Array; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last) + is + Program : Program_Data renames Self.Program; -- Shorter notation + + First_In_Data : constant Integer := Integer'Max (Data_First, Data'First); + Last_In_Data : constant Integer := Integer'Min (Data_Last, Data'Last); + + -- Global work variables + + Input_Pos : Natural; -- String-input pointer + BOL_Pos : Natural; -- Beginning of input, for ^ check + Matched : Boolean := False; -- Until proven True + + Matches_Full : Match_Array (0 .. Natural'Max (Self.Paren_Count, + Matches'Last)); + -- Stores the value of all the parenthesis pairs. + -- We do not use directly Matches, so that we can also use back + -- references (REFF) even if Matches is too small. + + type Natural_Array is array (Match_Count range <>) of Natural; + Matches_Tmp : Natural_Array (Matches_Full'Range); + -- Save the opening position of parenthesis + + Last_Paren : Natural := 0; + -- Last parenthesis seen + + Greedy : Boolean := True; + -- True if the next operator should be greedy + + type Current_Curly_Record; + type Current_Curly_Access is access all Current_Curly_Record; + type Current_Curly_Record is record + Paren_Floor : Natural; -- How far back to strip parenthesis data + Cur : Integer; -- How many instances of scan we've matched + Min : Natural; -- Minimal number of scans to match + Max : Natural; -- Maximal number of scans to match + Greedy : Boolean; -- Whether to work our way up or down + Scan : Pointer; -- The thing to match + Next : Pointer; -- What has to match after it + Lastloc : Natural; -- Where we started matching this scan + Old_Cc : Current_Curly_Access; -- Before we started this one + end record; + -- Data used to handle the curly operator and the plus and star + -- operators for complex expressions. + + Current_Curly : Current_Curly_Access := null; + -- The curly currently being processed + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Index (Start : Positive; C : Character) return Natural; + -- Find character C in Data starting at Start and return position + + function Repeat + (IP : Pointer; + Max : Natural := Natural'Last) return Natural; + -- Repeatedly match something simple, report how many + -- It only matches on things of length 1. + -- Starting from Input_Pos, it matches at most Max CURLY. + + function Try (Pos : Positive) return Boolean; + -- Try to match at specific point + + function Match (IP : Pointer) return Boolean; + -- This is the main matching routine. Conceptually the strategy + -- is simple: check to see whether the current node matches, + -- call self recursively to see whether the rest matches, + -- and then act accordingly. + -- + -- In practice Match makes some effort to avoid recursion, in + -- particular by going through "ordinary" nodes (that don't + -- need to know whether the rest of the match failed) by + -- using a loop instead of recursion. + -- Why is the above comment part of the spec rather than body ??? + + function Match_Whilem return Boolean; + -- Return True if a WHILEM matches the Current_Curly + + function Recurse_Match (IP : Pointer; From : Natural) return Boolean; + pragma Inline (Recurse_Match); + -- Calls Match recursively. It saves and restores the parenthesis + -- status and location in the input stream correctly, so that + -- backtracking is possible + + function Match_Simple_Operator + (Op : Opcode; + Scan : Pointer; + Next : Pointer; + Greedy : Boolean) return Boolean; + -- Return True it the simple operator (possibly non-greedy) matches + + Dump_Indent : Integer := -1; + procedure Dump_Current (Scan : Pointer; Prefix : Boolean := True); + procedure Dump_Error (Msg : String); + -- Debug: print the current context + + pragma Inline (Index); + pragma Inline (Repeat); + + -- These are two complex functions, but used only once + + pragma Inline (Match_Whilem); + pragma Inline (Match_Simple_Operator); + + ----------- + -- Index -- + ----------- + + function Index (Start : Positive; C : Character) return Natural is + begin + for J in Start .. Last_In_Data loop + if Data (J) = C then + return J; + end if; + end loop; + + return 0; + end Index; + + ------------------- + -- Recurse_Match -- + ------------------- + + function Recurse_Match (IP : Pointer; From : Natural) return Boolean is + L : constant Natural := Last_Paren; + Tmp_F : constant Match_Array := + Matches_Full (From + 1 .. Matches_Full'Last); + Start : constant Natural_Array := + Matches_Tmp (From + 1 .. Matches_Tmp'Last); + Input : constant Natural := Input_Pos; + + Dump_Indent_Save : constant Integer := Dump_Indent; + + begin + if Match (IP) then + return True; + end if; + + Last_Paren := L; + Matches_Full (Tmp_F'Range) := Tmp_F; + Matches_Tmp (Start'Range) := Start; + Input_Pos := Input; + Dump_Indent := Dump_Indent_Save; + return False; + end Recurse_Match; + + ------------------ + -- Dump_Current -- + ------------------ + + procedure Dump_Current (Scan : Pointer; Prefix : Boolean := True) is + Length : constant := 10; + Pos : constant String := Integer'Image (Input_Pos); + + begin + if Prefix then + Put ((1 .. 5 - Pos'Length => ' ')); + Put (Pos & " <" + & Data (Input_Pos + .. Integer'Min (Last_In_Data, Input_Pos + Length - 1))); + Put ((1 .. Length - 1 - Last_In_Data + Input_Pos => ' ')); + Put ("> |"); + + else + Put (" "); + end if; + + Dump_Operation (Program, Scan, Indent => Dump_Indent); + end Dump_Current; + + ---------------- + -- Dump_Error -- + ---------------- + + procedure Dump_Error (Msg : String) is + begin + Put (" | "); + Put ((1 .. Dump_Indent * 2 => ' ')); + Put_Line (Msg); + end Dump_Error; + + ----------- + -- Match -- + ----------- + + function Match (IP : Pointer) return Boolean is + Scan : Pointer := IP; + Next : Pointer; + Op : Opcode; + Result : Boolean; + + begin + Dump_Indent := Dump_Indent + 1; + + State_Machine : + loop + pragma Assert (Scan /= 0); + + -- Determine current opcode and count its usage in debug mode + + Op := Opcode'Val (Character'Pos (Program (Scan))); + + -- Calculate offset of next instruction. Second character is most + -- significant in Program_Data. + + Next := Get_Next (Program, Scan); + + if Debug then + Dump_Current (Scan); + end if; + + case Op is + when EOP => + Dump_Indent := Dump_Indent - 1; + return True; -- Success ! + + when BRANCH => + if Program (Next) /= BRANCH then + Next := Operand (Scan); -- No choice, avoid recursion + + else + loop + if Recurse_Match (Operand (Scan), 0) then + Dump_Indent := Dump_Indent - 1; + return True; + end if; + + Scan := Get_Next (Program, Scan); + exit when Scan = 0 or else Program (Scan) /= BRANCH; + end loop; + + exit State_Machine; + end if; + + when NOTHING => + null; + + when BOL => + exit State_Machine when Input_Pos /= BOL_Pos + and then ((Self.Flags and Multiple_Lines) = 0 + or else Data (Input_Pos - 1) /= ASCII.LF); + + when MBOL => + exit State_Machine when Input_Pos /= BOL_Pos + and then Data (Input_Pos - 1) /= ASCII.LF; + + when SBOL => + exit State_Machine when Input_Pos /= BOL_Pos; + + when EOL => + exit State_Machine when Input_Pos <= Data'Last + and then ((Self.Flags and Multiple_Lines) = 0 + or else Data (Input_Pos) /= ASCII.LF); + + when MEOL => + exit State_Machine when Input_Pos <= Data'Last + and then Data (Input_Pos) /= ASCII.LF; + + when SEOL => + exit State_Machine when Input_Pos <= Data'Last; + + when BOUND | NBOUND => + + -- Was last char in word ? + + declare + N : Boolean := False; + Ln : Boolean := False; + + begin + if Input_Pos /= First_In_Data then + N := Is_Alnum (Data (Input_Pos - 1)); + end if; + + Ln := + (if Input_Pos > Last_In_Data + then False + else Is_Alnum (Data (Input_Pos))); + + if Op = BOUND then + if N = Ln then + exit State_Machine; + end if; + else + if N /= Ln then + exit State_Machine; + end if; + end if; + end; + + when SPACE => + exit State_Machine when Input_Pos > Last_In_Data + or else not Is_White_Space (Data (Input_Pos)); + Input_Pos := Input_Pos + 1; + + when NSPACE => + exit State_Machine when Input_Pos > Last_In_Data + or else Is_White_Space (Data (Input_Pos)); + Input_Pos := Input_Pos + 1; + + when DIGIT => + exit State_Machine when Input_Pos > Last_In_Data + or else not Is_Digit (Data (Input_Pos)); + Input_Pos := Input_Pos + 1; + + when NDIGIT => + exit State_Machine when Input_Pos > Last_In_Data + or else Is_Digit (Data (Input_Pos)); + Input_Pos := Input_Pos + 1; + + when ALNUM => + exit State_Machine when Input_Pos > Last_In_Data + or else not Is_Alnum (Data (Input_Pos)); + Input_Pos := Input_Pos + 1; + + when NALNUM => + exit State_Machine when Input_Pos > Last_In_Data + or else Is_Alnum (Data (Input_Pos)); + Input_Pos := Input_Pos + 1; + + when ANY => + exit State_Machine when Input_Pos > Last_In_Data + or else Data (Input_Pos) = ASCII.LF; + Input_Pos := Input_Pos + 1; + + when SANY => + exit State_Machine when Input_Pos > Last_In_Data; + Input_Pos := Input_Pos + 1; + + when EXACT => + declare + Opnd : Pointer := String_Operand (Scan); + Current : Positive := Input_Pos; + Last : constant Pointer := + Opnd + String_Length (Program, Scan); + + begin + while Opnd <= Last loop + exit State_Machine when Current > Last_In_Data + or else Program (Opnd) /= Data (Current); + Current := Current + 1; + Opnd := Opnd + 1; + end loop; + + Input_Pos := Current; + end; + + when EXACTF => + declare + Opnd : Pointer := String_Operand (Scan); + Current : Positive := Input_Pos; + + Last : constant Pointer := + Opnd + String_Length (Program, Scan); + + begin + while Opnd <= Last loop + exit State_Machine when Current > Last_In_Data + or else Program (Opnd) /= To_Lower (Data (Current)); + Current := Current + 1; + Opnd := Opnd + 1; + end loop; + + Input_Pos := Current; + end; + + when ANYOF => + declare + Bitmap : Character_Class; + begin + Bitmap_Operand (Program, Scan, Bitmap); + exit State_Machine when Input_Pos > Last_In_Data + or else not Get_From_Class (Bitmap, Data (Input_Pos)); + Input_Pos := Input_Pos + 1; + end; + + when OPEN => + declare + No : constant Natural := + Character'Pos (Program (Operand (Scan))); + begin + Matches_Tmp (No) := Input_Pos; + end; + + when CLOSE => + declare + No : constant Natural := + Character'Pos (Program (Operand (Scan))); + + begin + Matches_Full (No) := (Matches_Tmp (No), Input_Pos - 1); + + if Last_Paren < No then + Last_Paren := No; + end if; + end; + + when REFF => + declare + No : constant Natural := + Character'Pos (Program (Operand (Scan))); + + Data_Pos : Natural; + + begin + -- If we haven't seen that parenthesis yet + + if Last_Paren < No then + Dump_Indent := Dump_Indent - 1; + + if Debug then + Dump_Error ("REFF: No match, backtracking"); + end if; + + return False; + end if; + + Data_Pos := Matches_Full (No).First; + + while Data_Pos <= Matches_Full (No).Last loop + if Input_Pos > Last_In_Data + or else Data (Input_Pos) /= Data (Data_Pos) + then + Dump_Indent := Dump_Indent - 1; + + if Debug then + Dump_Error ("REFF: No match, backtracking"); + end if; + + return False; + end if; + + Input_Pos := Input_Pos + 1; + Data_Pos := Data_Pos + 1; + end loop; + end; + + when MINMOD => + Greedy := False; + + when STAR | PLUS | CURLY => + declare + Greed : constant Boolean := Greedy; + begin + Greedy := True; + Result := Match_Simple_Operator (Op, Scan, Next, Greed); + Dump_Indent := Dump_Indent - 1; + return Result; + end; + + when CURLYX => + + -- Looking at something like: + + -- 1: CURLYX {n,m} (->4) + -- 2: code for complex thing (->3) + -- 3: WHILEM (->0) + -- 4: NOTHING + + declare + Min : constant Natural := + Read_Natural (Program, Scan + Next_Pointer_Bytes); + Max : constant Natural := + Read_Natural + (Program, Scan + Next_Pointer_Bytes + 2); + Cc : aliased Current_Curly_Record; + + Has_Match : Boolean; + + begin + Cc := (Paren_Floor => Last_Paren, + Cur => -1, + Min => Min, + Max => Max, + Greedy => Greedy, + Scan => Scan + 7, + Next => Next, + Lastloc => 0, + Old_Cc => Current_Curly); + Greedy := True; + Current_Curly := Cc'Unchecked_Access; + + Has_Match := Match (Next - Next_Pointer_Bytes); + + -- Start on the WHILEM + + Current_Curly := Cc.Old_Cc; + Dump_Indent := Dump_Indent - 1; + + if not Has_Match then + if Debug then + Dump_Error ("CURLYX failed..."); + end if; + end if; + + return Has_Match; + end; + + when WHILEM => + Result := Match_Whilem; + Dump_Indent := Dump_Indent - 1; + + if Debug and then not Result then + Dump_Error ("WHILEM: no match, backtracking"); + end if; + + return Result; + end case; + + Scan := Next; + end loop State_Machine; + + if Debug then + Dump_Error ("failed..."); + Dump_Indent := Dump_Indent - 1; + end if; + + -- If we get here, there is no match. For successful matches when EOP + -- is the terminating point. + + return False; + end Match; + + --------------------------- + -- Match_Simple_Operator -- + --------------------------- + + function Match_Simple_Operator + (Op : Opcode; + Scan : Pointer; + Next : Pointer; + Greedy : Boolean) return Boolean + is + Next_Char : Character := ASCII.NUL; + Next_Char_Known : Boolean := False; + No : Integer; -- Can be negative + Min : Natural; + Max : Natural := Natural'Last; + Operand_Code : Pointer; + Old : Natural; + Last_Pos : Natural; + Save : constant Natural := Input_Pos; + + begin + -- Lookahead to avoid useless match attempts when we know what + -- character comes next. + + if Program (Next) = EXACT then + Next_Char := Program (String_Operand (Next)); + Next_Char_Known := True; + end if; + + -- Find the minimal and maximal values for the operator + + case Op is + when STAR => + Min := 0; + Operand_Code := Operand (Scan); + + when PLUS => + Min := 1; + Operand_Code := Operand (Scan); + + when others => + Min := Read_Natural (Program, Scan + Next_Pointer_Bytes); + Max := Read_Natural (Program, Scan + Next_Pointer_Bytes + 2); + Operand_Code := Scan + 7; + end case; + + if Debug then + Dump_Current (Operand_Code, Prefix => False); + end if; + + -- Non greedy operators + + if not Greedy then + + -- Test we can repeat at least Min times + + if Min /= 0 then + No := Repeat (Operand_Code, Min); + + if No < Min then + if Debug then + Dump_Error ("failed... matched" & No'Img & " times"); + end if; + + return False; + end if; + end if; + + Old := Input_Pos; + + -- Find the place where 'next' could work + + if Next_Char_Known then + + -- Last position to check + + if Max = Natural'Last then + Last_Pos := Last_In_Data; + else + Last_Pos := Input_Pos + Max; + + if Last_Pos > Last_In_Data then + Last_Pos := Last_In_Data; + end if; + end if; + + -- Look for the first possible opportunity + + if Debug then + Dump_Error ("Next_Char must be " & Next_Char); + end if; + + loop + -- Find the next possible position + + while Input_Pos <= Last_Pos + and then Data (Input_Pos) /= Next_Char + loop + Input_Pos := Input_Pos + 1; + end loop; + + if Input_Pos > Last_Pos then + return False; + end if; + + -- Check that we still match if we stop at the position we + -- just found. + + declare + Num : constant Natural := Input_Pos - Old; + + begin + Input_Pos := Old; + + if Debug then + Dump_Error ("Would we still match at that position?"); + end if; + + if Repeat (Operand_Code, Num) < Num then + return False; + end if; + end; + + -- Input_Pos now points to the new position + + if Match (Get_Next (Program, Scan)) then + return True; + end if; + + Old := Input_Pos; + Input_Pos := Input_Pos + 1; + end loop; + + -- We do not know what the next character is + + else + while Max >= Min loop + if Debug then + Dump_Error ("Non-greedy repeat, N=" & Min'Img); + Dump_Error ("Do we still match Next if we stop here?"); + end if; + + -- If the next character matches + + if Recurse_Match (Next, 1) then + return True; + end if; + + Input_Pos := Save + Min; + + -- Could not or did not match -- move forward + + if Repeat (Operand_Code, 1) /= 0 then + Min := Min + 1; + else + if Debug then + Dump_Error ("Non-greedy repeat failed..."); + end if; + + return False; + end if; + end loop; + end if; + + return False; + + -- Greedy operators + + else + No := Repeat (Operand_Code, Max); + + if Debug and then No < Min then + Dump_Error ("failed... matched" & No'Img & " times"); + end if; + + -- ??? Perl has some special code here in case the next + -- instruction is of type EOL, since $ and \Z can match before + -- *and* after newline at the end. + + -- ??? Perl has some special code here in case (paren) is True + + -- Else, if we don't have any parenthesis + + while No >= Min loop + if not Next_Char_Known + or else (Input_Pos <= Last_In_Data + and then Data (Input_Pos) = Next_Char) + then + if Match (Next) then + return True; + end if; + end if; + + -- Could not or did not work, we back up + + No := No - 1; + Input_Pos := Save + No; + end loop; + + return False; + end if; + end Match_Simple_Operator; + + ------------------ + -- Match_Whilem -- + ------------------ + + -- This is really hard to understand, because after we match what we + -- are trying to match, we must make sure the rest of the REx is going + -- to match for sure, and to do that we have to go back UP the parse + -- tree by recursing ever deeper. And if it fails, we have to reset + -- our parent's current state that we can try again after backing off. + + function Match_Whilem return Boolean is + Cc : constant Current_Curly_Access := Current_Curly; + + N : constant Natural := Cc.Cur + 1; + Ln : Natural := 0; + + Lastloc : constant Natural := Cc.Lastloc; + -- Detection of 0-len + + begin + -- If degenerate scan matches "", assume scan done + + if Input_Pos = Cc.Lastloc + and then N >= Cc.Min + then + -- Temporarily restore the old context, and check that we + -- match was comes after CURLYX. + + Current_Curly := Cc.Old_Cc; + + if Current_Curly /= null then + Ln := Current_Curly.Cur; + end if; + + if Match (Cc.Next) then + return True; + end if; + + if Current_Curly /= null then + Current_Curly.Cur := Ln; + end if; + + Current_Curly := Cc; + return False; + end if; + + -- First, just match a string of min scans + + if N < Cc.Min then + Cc.Cur := N; + Cc.Lastloc := Input_Pos; + + if Debug then + Dump_Error + ("Tests that we match at least" & Cc.Min'Img & " N=" & N'Img); + end if; + + if Match (Cc.Scan) then + return True; + end if; + + Cc.Cur := N - 1; + Cc.Lastloc := Lastloc; + + if Debug then + Dump_Error ("failed..."); + end if; + + return False; + end if; + + -- Prefer next over scan for minimal matching + + if not Cc.Greedy then + Current_Curly := Cc.Old_Cc; + + if Current_Curly /= null then + Ln := Current_Curly.Cur; + end if; + + if Recurse_Match (Cc.Next, Cc.Paren_Floor) then + return True; + end if; + + if Current_Curly /= null then + Current_Curly.Cur := Ln; + end if; + + Current_Curly := Cc; + + -- Maximum greed exceeded ? + + if N >= Cc.Max then + if Debug then + Dump_Error ("failed..."); + end if; + return False; + end if; + + -- Try scanning more and see if it helps + Cc.Cur := N; + Cc.Lastloc := Input_Pos; + + if Debug then + Dump_Error ("Next failed, what about Current?"); + end if; + + if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then + return True; + end if; + + Cc.Cur := N - 1; + Cc.Lastloc := Lastloc; + return False; + end if; + + -- Prefer scan over next for maximal matching + + if N < Cc.Max then -- more greed allowed ? + Cc.Cur := N; + Cc.Lastloc := Input_Pos; + + if Debug then + Dump_Error ("Recurse at current position"); + end if; + + if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then + return True; + end if; + end if; + + -- Failed deeper matches of scan, so see if this one works + + Current_Curly := Cc.Old_Cc; + + if Current_Curly /= null then + Ln := Current_Curly.Cur; + end if; + + if Debug then + Dump_Error ("Failed matching for later positions"); + end if; + + if Match (Cc.Next) then + return True; + end if; + + if Current_Curly /= null then + Current_Curly.Cur := Ln; + end if; + + Current_Curly := Cc; + Cc.Cur := N - 1; + Cc.Lastloc := Lastloc; + + if Debug then + Dump_Error ("failed..."); + end if; + + return False; + end Match_Whilem; + + ------------ + -- Repeat -- + ------------ + + function Repeat + (IP : Pointer; + Max : Natural := Natural'Last) return Natural + is + Scan : Natural := Input_Pos; + Last : Natural; + Op : constant Opcode := Opcode'Val (Character'Pos (Program (IP))); + Count : Natural; + C : Character; + Is_First : Boolean := True; + Bitmap : Character_Class; + + begin + if Max = Natural'Last or else Scan + Max - 1 > Last_In_Data then + Last := Last_In_Data; + else + Last := Scan + Max - 1; + end if; + + case Op is + when ANY => + while Scan <= Last + and then Data (Scan) /= ASCII.LF + loop + Scan := Scan + 1; + end loop; + + when SANY => + Scan := Last + 1; + + when EXACT => + + -- The string has only one character if Repeat was called + + C := Program (String_Operand (IP)); + while Scan <= Last + and then C = Data (Scan) + loop + Scan := Scan + 1; + end loop; + + when EXACTF => + + -- The string has only one character if Repeat was called + + C := Program (String_Operand (IP)); + while Scan <= Last + and then To_Lower (C) = Data (Scan) + loop + Scan := Scan + 1; + end loop; + + when ANYOF => + if Is_First then + Bitmap_Operand (Program, IP, Bitmap); + Is_First := False; + end if; + + while Scan <= Last + and then Get_From_Class (Bitmap, Data (Scan)) + loop + Scan := Scan + 1; + end loop; + + when ALNUM => + while Scan <= Last + and then Is_Alnum (Data (Scan)) + loop + Scan := Scan + 1; + end loop; + + when NALNUM => + while Scan <= Last + and then not Is_Alnum (Data (Scan)) + loop + Scan := Scan + 1; + end loop; + + when SPACE => + while Scan <= Last + and then Is_White_Space (Data (Scan)) + loop + Scan := Scan + 1; + end loop; + + when NSPACE => + while Scan <= Last + and then not Is_White_Space (Data (Scan)) + loop + Scan := Scan + 1; + end loop; + + when DIGIT => + while Scan <= Last + and then Is_Digit (Data (Scan)) + loop + Scan := Scan + 1; + end loop; + + when NDIGIT => + while Scan <= Last + and then not Is_Digit (Data (Scan)) + loop + Scan := Scan + 1; + end loop; + + when others => + raise Program_Error; + end case; + + Count := Scan - Input_Pos; + Input_Pos := Scan; + return Count; + end Repeat; + + --------- + -- Try -- + --------- + + function Try (Pos : Positive) return Boolean is + begin + Input_Pos := Pos; + Last_Paren := 0; + Matches_Full := (others => No_Match); + + if Match (Program_First) then + Matches_Full (0) := (Pos, Input_Pos - 1); + return True; + end if; + + return False; + end Try; + + -- Start of processing for Match + + begin + -- Do we have the regexp Never_Match? + + if Self.Size = 0 then + Matches := (others => No_Match); + return; + end if; + + -- If there is a "must appear" string, look for it + + if Self.Must_Have_Length > 0 then + declare + First : constant Character := Program (Self.Must_Have); + Must_First : constant Pointer := Self.Must_Have; + Must_Last : constant Pointer := + Must_First + Pointer (Self.Must_Have_Length - 1); + Next_Try : Natural := Index (First_In_Data, First); + + begin + while Next_Try /= 0 + and then Data (Next_Try .. Next_Try + Self.Must_Have_Length - 1) + = String (Program (Must_First .. Must_Last)) + loop + Next_Try := Index (Next_Try + 1, First); + end loop; + + if Next_Try = 0 then + Matches := (others => No_Match); + return; -- Not present + end if; + end; + end if; + + -- Mark beginning of line for ^ + + BOL_Pos := Data'First; + + -- Simplest case first: an anchored match need be tried only once + + if Self.Anchored and then (Self.Flags and Multiple_Lines) = 0 then + Matched := Try (First_In_Data); + + elsif Self.Anchored then + declare + Next_Try : Natural := First_In_Data; + begin + -- Test the first position in the buffer + Matched := Try (Next_Try); + + -- Else only test after newlines + + if not Matched then + while Next_Try <= Last_In_Data loop + while Next_Try <= Last_In_Data + and then Data (Next_Try) /= ASCII.LF + loop + Next_Try := Next_Try + 1; + end loop; + + Next_Try := Next_Try + 1; + + if Next_Try <= Last_In_Data then + Matched := Try (Next_Try); + exit when Matched; + end if; + end loop; + end if; + end; + + elsif Self.First /= ASCII.NUL then + -- We know what char it must start with + + declare + Next_Try : Natural := Index (First_In_Data, Self.First); + + begin + while Next_Try /= 0 loop + Matched := Try (Next_Try); + exit when Matched; + Next_Try := Index (Next_Try + 1, Self.First); + end loop; + end; + + else + -- Messy cases: try all locations (including for the empty string) + + Matched := Try (First_In_Data); + + if not Matched then + for S in First_In_Data + 1 .. Last_In_Data loop + Matched := Try (S); + exit when Matched; + end loop; + end if; + end if; + + -- Matched has its value + + for J in Last_Paren + 1 .. Matches'Last loop + Matches_Full (J) := No_Match; + end loop; + + Matches := Matches_Full (Matches'Range); + end Match; + + ----------- + -- Match -- + ----------- + + function Match + (Self : Pattern_Matcher; + Data : String; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last) return Natural + is + Matches : Match_Array (0 .. 0); + + begin + Match (Self, Data, Matches, Data_First, Data_Last); + if Matches (0) = No_Match then + return Data'First - 1; + else + return Matches (0).First; + end if; + end Match; + + function Match + (Self : Pattern_Matcher; + Data : String; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last) return Boolean + is + Matches : Match_Array (0 .. 0); + + begin + Match (Self, Data, Matches, Data_First, Data_Last); + return Matches (0).First >= Data'First; + end Match; + + procedure Match + (Expression : String; + Data : String; + Matches : out Match_Array; + Size : Program_Size := Auto_Size; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last) + is + PM : Pattern_Matcher (Size); + Finalize_Size : Program_Size; + pragma Unreferenced (Finalize_Size); + begin + if Size = 0 then + Match (Compile (Expression), Data, Matches, Data_First, Data_Last); + else + Compile (PM, Expression, Finalize_Size); + Match (PM, Data, Matches, Data_First, Data_Last); + end if; + end Match; + + ----------- + -- Match -- + ----------- + + function Match + (Expression : String; + Data : String; + Size : Program_Size := Auto_Size; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last) return Natural + is + PM : Pattern_Matcher (Size); + Final_Size : Program_Size; + pragma Unreferenced (Final_Size); + begin + if Size = 0 then + return Match (Compile (Expression), Data, Data_First, Data_Last); + else + Compile (PM, Expression, Final_Size); + return Match (PM, Data, Data_First, Data_Last); + end if; + end Match; + + ----------- + -- Match -- + ----------- + + function Match + (Expression : String; + Data : String; + Size : Program_Size := Auto_Size; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last) return Boolean + is + Matches : Match_Array (0 .. 0); + PM : Pattern_Matcher (Size); + Final_Size : Program_Size; + pragma Unreferenced (Final_Size); + begin + if Size = 0 then + Match (Compile (Expression), Data, Matches, Data_First, Data_Last); + else + Compile (PM, Expression, Final_Size); + Match (PM, Data, Matches, Data_First, Data_Last); + end if; + + return Matches (0).First >= Data'First; + end Match; + + ------------- + -- Operand -- + ------------- + + function Operand (P : Pointer) return Pointer is + begin + return P + Next_Pointer_Bytes; + end Operand; + + -------------- + -- Optimize -- + -------------- + + procedure Optimize (Self : in out Pattern_Matcher) is + Scan : Pointer; + Program : Program_Data renames Self.Program; + + begin + -- Start with safe defaults (no optimization): + -- * No known first character of match + -- * Does not necessarily start at beginning of line + -- * No string known that has to appear in data + + Self.First := ASCII.NUL; + Self.Anchored := False; + Self.Must_Have := Program'Last + 1; + Self.Must_Have_Length := 0; + + Scan := Program_First; -- First instruction (can be anything) + + if Program (Scan) = EXACT then + Self.First := Program (String_Operand (Scan)); + + elsif Program (Scan) = BOL + or else Program (Scan) = SBOL + or else Program (Scan) = MBOL + then + Self.Anchored := True; + end if; + end Optimize; + + ----------------- + -- Paren_Count -- + ----------------- + + function Paren_Count (Regexp : Pattern_Matcher) return Match_Count is + begin + return Regexp.Paren_Count; + end Paren_Count; + + ----------- + -- Quote -- + ----------- + + function Quote (Str : String) return String is + S : String (1 .. Str'Length * 2); + Last : Natural := 0; + + begin + for J in Str'Range loop + case Str (J) is + when '^' | '$' | '|' | '*' | '+' | '?' | '{' | + '}' | '[' | ']' | '(' | ')' | '\' | '.' => + + S (Last + 1) := '\'; + S (Last + 2) := Str (J); + Last := Last + 2; + + when others => + S (Last + 1) := Str (J); + Last := Last + 1; + end case; + end loop; + + return S (1 .. Last); + end Quote; + + ------------------ + -- Read_Natural -- + ------------------ + + function Read_Natural + (Program : Program_Data; + IP : Pointer) return Natural + is + begin + return Character'Pos (Program (IP)) + + 256 * Character'Pos (Program (IP + 1)); + end Read_Natural; + + ----------------- + -- Reset_Class -- + ----------------- + + procedure Reset_Class (Bitmap : out Character_Class) is + begin + Bitmap := (others => 0); + end Reset_Class; + + ------------------ + -- Set_In_Class -- + ------------------ + + procedure Set_In_Class + (Bitmap : in out Character_Class; + C : Character) + is + Value : constant Class_Byte := Character'Pos (C); + begin + Bitmap (Value / 8) := Bitmap (Value / 8) + or Bit_Conversion (Value mod 8); + end Set_In_Class; + + ------------------- + -- String_Length -- + ------------------- + + function String_Length + (Program : Program_Data; + P : Pointer) return Program_Size + is + begin + pragma Assert (Program (P) = EXACT or else Program (P) = EXACTF); + return Character'Pos (Program (P + Next_Pointer_Bytes)); + end String_Length; + + -------------------- + -- String_Operand -- + -------------------- + + function String_Operand (P : Pointer) return Pointer is + begin + return P + 4; + end String_Operand; + +end System.Regpat; diff --git a/gcc/ada/s-regpat.ads b/gcc/ada/s-regpat.ads new file mode 100755 index 000000000..0ab027ca9 --- /dev/null +++ b/gcc/ada/s-regpat.ads @@ -0,0 +1,646 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package 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 ) -- parens used for grouping + -- ::= \ num -- reference to num-th 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. + -- + -- 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 "c+" + -- 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 new file mode 100644 index 000000000..7ce6da9cc --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..cd447c1b0 --- /dev/null +++ b/gcc/ada/s-restri.ads @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +with System.Rident; + +package System.Restrictions is + pragma Preelaborate; + + pragma Discard_Names; + package Rident is new System.Rident; + + Run_Time_Restrictions : Rident.Restrictions_Info; + -- Restrictions as set by the user, or detected by the binder. + -- Note that a restriction which is both Set and Violated at run-time means + -- that the violation was detected as part of the Ada run-time and not + -- as part of user code. + + ------------------ + -- Subprograms -- + ----------------- + + function Abort_Allowed return Boolean; + pragma Inline (Abort_Allowed); + -- Tests to see if abort is allowed by the current restrictions settings. + -- For abort to be allowed, either No_Abort_Statements must be False, + -- or Max_Asynchronous_Select_Nesting must be non-zero. + + function Tasking_Allowed return Boolean; + pragma Inline (Tasking_Allowed); + -- Tests to see if tasking operations are allowed by the current + -- restrictions settings. For tasking to be allowed, No_Tasking + -- must be False, and Max_Tasks must not be set to zero. + +end System.Restrictions; diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads new file mode 100644 index 000000000..9423694af --- /dev/null +++ b/gcc/ada/s-rident.ads @@ -0,0 +1,420 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . R I D E N T -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package defines the set of restriction identifiers. It is a generic +-- package that is instantiated by the compiler/binder in package Rident, and +-- is instantiated in package System.Restrictions for use at run-time. + +-- The reason that we make this a generic package is so that in the case of +-- the instantiation in Rident for use at compile time and bind time, we can +-- generate normal image tables for the enumeration types, which are needed +-- for diagnostic and informational messages. At run-time we really do not +-- want to waste the space for these image tables, and they are not needed, +-- so we can do the instantiation under control of Discard_Names to remove +-- the tables. + +generic +package System.Rident is + pragma Preelaborate; + + -- The following enumeration type defines the set of restriction + -- identifiers that are implemented in GNAT. + + -- To add a new restriction identifier, add an entry with the name to be + -- used in the pragma, and add calls to the Restrict.Check_Restriction + -- routine as appropriate. + + type Restriction_Id is + + -- The following cases are checked for consistency in the binder. The + -- binder will check that every unit either has the restriction set, or + -- does not violate the restriction. + + (Simple_Barriers, -- GNAT (Ravenscar) + No_Abort_Statements, -- (RM D.7(5), H.4(3)) + No_Access_Subprograms, -- (RM H.4(17)) + No_Allocators, -- (RM H.4(7)) + No_Allocators_After_Elaboration, -- Ada 2012 (RM D.7(19.1/2)) + No_Anonymous_Allocators, -- Ada 2012 (RM H.4(8/1)) + No_Asynchronous_Control, -- (RM D.7(10)) + No_Calendar, -- GNAT + No_Default_Stream_Attributes, -- Ada 2012 (RM 13.12.1(4/2)) + No_Delay, -- (RM H.4(21)) + No_Direct_Boolean_Operators, -- GNAT + No_Dispatch, -- (RM H.4(19)) + No_Dispatching_Calls, -- GNAT + No_Dynamic_Attachment, -- GNAT + No_Dynamic_Priorities, -- (RM D.9(9)) + No_Enumeration_Maps, -- GNAT + No_Entry_Calls_In_Elaboration_Code, -- GNAT + No_Entry_Queue, -- GNAT (Ravenscar) + No_Exception_Handlers, -- GNAT + No_Exception_Propagation, -- GNAT + No_Exception_Registration, -- GNAT + No_Exceptions, -- (RM H.4(12)) + No_Finalization, -- GNAT + No_Fixed_Point, -- (RM H.4(15)) + No_Floating_Point, -- (RM H.4(14)) + No_IO, -- (RM H.4(20)) + No_Implicit_Conditionals, -- GNAT + No_Implicit_Dynamic_Code, -- GNAT + No_Implicit_Heap_Allocations, -- (RM D.8(8), H.4(3)) + No_Implicit_Loops, -- GNAT + No_Initialize_Scalars, -- GNAT + No_Local_Allocators, -- (RM H.4(8)) + No_Local_Timing_Events, -- (RM D.7(10.2/2)) + No_Local_Protected_Objects, -- GNAT + No_Nested_Finalization, -- (RM D.7(4)) + No_Protected_Type_Allocators, -- GNAT + No_Protected_Types, -- (RM H.4(5)) + No_Recursion, -- (RM H.4(22)) + No_Reentrancy, -- (RM H.4(23)) + No_Relative_Delay, -- GNAT (Ravenscar) + No_Requeue_Statements, -- GNAT + No_Secondary_Stack, -- GNAT + No_Select_Statements, -- GNAT (Ravenscar) + No_Specific_Termination_Handlers, -- (RM D.7(10.7/2)) + No_Standard_Storage_Pools, -- GNAT + No_Stream_Optimizations, -- GNAT + No_Streams, -- GNAT + No_Task_Allocators, -- (RM D.7(7)) + No_Task_Attributes_Package, -- GNAT + No_Task_Hierarchy, -- (RM D.7(3), H.4(3)) + No_Task_Termination, -- GNAT (Ravenscar) + No_Tasking, -- GNAT + No_Terminate_Alternatives, -- (RM D.7(6)) + No_Unchecked_Access, -- (RM H.4(18)) + No_Unchecked_Conversion, -- (RM H.4(16)) + No_Unchecked_Deallocation, -- (RM H.4(9)) + Static_Priorities, -- GNAT + Static_Storage_Size, -- GNAT + + -- The following require consistency checking with special rules. See + -- individual routines in unit Bcheck for details of what is required. + + No_Default_Initialization, -- GNAT + + -- The following cases do not require consistency checking + + Immediate_Reclamation, -- (RM H.4(10)) + No_Implementation_Attributes, -- Ada 2005 AI-257 + No_Implementation_Pragmas, -- Ada 2005 AI-257 + No_Implementation_Restrictions, -- GNAT + No_Elaboration_Code, -- GNAT + No_Obsolescent_Features, -- Ada 2005 AI-368 + No_Wide_Characters, -- GNAT + + -- The following cases require a parameter value + + -- The following entries are fully checked at compile/bind time, which + -- means that the compiler can in general tell the minimum value which + -- could be used with a restrictions pragma. The binder can deduce the + -- appropriate minimum value for the partition by taking the maximum + -- value required by any unit. + + Max_Protected_Entries, -- (RM D.7(14)) + Max_Select_Alternatives, -- (RM D.7(12)) + Max_Task_Entries, -- (RM D.7(13), H.4(3)) + + -- The following entries are also fully checked at compile/bind time, + -- and the compiler can also at least in some cases tell the minimum + -- value which could be used with a restriction pragma. The difference + -- is that the contributions are additive, so the binder deduces this + -- value by adding the unit contributions. + + Max_Tasks, -- (RM D.7(19), H.4(3)) + + -- The following entries are checked at compile time only for zero/ + -- nonzero entries. This means that the compiler can tell at compile + -- time if a restriction value of zero is (would be) violated, but that + -- the compiler cannot distinguish between different non-zero values. + + Max_Asynchronous_Select_Nesting, -- (RM D.7(18), H.4(3)) + Max_Entry_Queue_Length, -- GNAT + + -- The remaining entries are not checked at compile/bind time + + Max_Storage_At_Blocking, -- (RM D.7(17)) + + Not_A_Restriction_Id); + + -- Synonyms permitted for historical purposes of compatibility. + -- Must be coordinated with Restrict.Process_Restriction_Synonym. + + Boolean_Entry_Barriers : Restriction_Id renames Simple_Barriers; + Max_Entry_Queue_Depth : Restriction_Id renames Max_Entry_Queue_Length; + No_Dynamic_Interrupts : Restriction_Id renames No_Dynamic_Attachment; + No_Requeue : Restriction_Id renames No_Requeue_Statements; + No_Task_Attributes : Restriction_Id renames No_Task_Attributes_Package; + + subtype All_Restrictions is Restriction_Id range + Simple_Barriers .. Max_Storage_At_Blocking; + -- All restrictions (excluding only Not_A_Restriction_Id) + + subtype All_Boolean_Restrictions is Restriction_Id range + Simple_Barriers .. No_Wide_Characters; + -- All restrictions which do not take a parameter + + subtype Partition_Boolean_Restrictions is All_Boolean_Restrictions range + Simple_Barriers .. Static_Storage_Size; + -- Boolean restrictions that are checked for partition consistency. + -- Note that all parameter restrictions are checked for partition + -- consistency by default, so this distinction is only needed in the + -- case of Boolean restrictions. + + subtype Cunit_Boolean_Restrictions is All_Boolean_Restrictions range + Immediate_Reclamation .. No_Wide_Characters; + -- Boolean restrictions that are not checked for partition consistency + -- and that thus apply only to the current unit. Note that for these + -- restrictions, the compiler does not apply restrictions found in + -- with'ed units, parent specs etc. to the main unit. + + subtype All_Parameter_Restrictions is + Restriction_Id range + Max_Protected_Entries .. Max_Storage_At_Blocking; + -- All restrictions that take a parameter + + subtype Checked_Parameter_Restrictions is + All_Parameter_Restrictions range + Max_Protected_Entries .. Max_Entry_Queue_Length; + -- These are the parameter restrictions that can be at least partially + -- checked at compile/binder time. Minimally, the compiler can detect + -- violations of a restriction pragma with a value of zero reliably. + + subtype Checked_Max_Parameter_Restrictions is + Checked_Parameter_Restrictions range + Max_Protected_Entries .. Max_Task_Entries; + -- Restrictions with parameters that can be checked in some cases by + -- maximizing among statically detected instances where the compiler + -- can determine the count. + + subtype Checked_Add_Parameter_Restrictions is + Checked_Parameter_Restrictions range + Max_Tasks .. Max_Tasks; + -- Restrictions with parameters that can be checked in some cases by + -- summing the statically detected instances where the compiler can + -- determine the count. + + subtype Checked_Val_Parameter_Restrictions is + Checked_Parameter_Restrictions range + Max_Protected_Entries .. Max_Tasks; + -- Restrictions with parameter where the count is known at least in some + -- cases by the compiler/binder. + + subtype Checked_Zero_Parameter_Restrictions is + Checked_Parameter_Restrictions range + Max_Asynchronous_Select_Nesting .. Max_Entry_Queue_Length; + -- Restrictions with parameters where the compiler can detect the use of + -- the feature, and hence violations of a restriction specifying a value + -- of zero, but cannot detect specific values other than zero/nonzero. + + subtype Unchecked_Parameter_Restrictions is + All_Parameter_Restrictions range + Max_Storage_At_Blocking .. Max_Storage_At_Blocking; + -- Restrictions with parameters where the compiler cannot ever detect + -- corresponding compile time usage, so the binder and compiler never + -- detect violations of any restriction. + + ------------------------------------- + -- Restriction Status Declarations -- + ------------------------------------- + + -- The following declarations are used to record the current status or + -- restrictions (for the current unit, or related units, at compile time, + -- and for all units in a partition at bind time or run time). + + type Restriction_Flags is array (All_Restrictions) of Boolean; + type Restriction_Values is array (All_Parameter_Restrictions) of Natural; + type Parameter_Flags is array (All_Parameter_Restrictions) of Boolean; + + type Restrictions_Info is record + Set : Restriction_Flags; + -- An entry is True in the Set array if a restrictions pragma has been + -- encountered for the given restriction. If the value is True for a + -- parameter restriction, then the corresponding entry in the Value + -- array gives the minimum value encountered for any such restriction. + + Value : Restriction_Values; + -- If the entry for a parameter restriction in Set is True (i.e. a + -- restrictions pragma for the restriction has been encountered), then + -- the corresponding entry in the Value array is the minimum value + -- specified by any such restrictions pragma. Note that a restrictions + -- pragma specifying a value greater than Int'Last is simply ignored. + + Violated : Restriction_Flags; + -- An entry is True in the violations array if the compiler has detected + -- a violation of the restriction. For a parameter restriction, the + -- Count and Unknown arrays have additional information. + + Count : Restriction_Values; + -- If an entry for a parameter restriction is True in Violated, the + -- corresponding entry in the Count array may record additional + -- information. If the actual minimum count is known (by taking + -- maximums, or sums, depending on the restriction), it will be + -- recorded in this array. If not, then the value will remain zero. + -- The value is also zero for a non-violated restriction. + + Unknown : Parameter_Flags; + -- If an entry for a parameter restriction is True in Violated, the + -- corresponding entry in the Unknown array may record additional + -- information. If the actual count is not known by the compiler (but + -- is known to be non-zero), then the entry in Unknown will be True. + -- This indicates that the value in Count is not known to be exact, + -- and the actual violation count may be higher. + + -- Note: If Violated (K) is True, then either Count (K) > 0 or + -- Unknown (K) = True. It is possible for both these to be set. + -- For example, if Count (K) = 3 and Unknown (K) is True, it means + -- that the actual violation count is at least 3 but might be higher. + end record; + + No_Restrictions : constant Restrictions_Info := + (Set => (others => False), + Value => (others => 0), + Violated => (others => False), + Count => (others => 0), + Unknown => (others => False)); + -- Used to initialize Restrictions_Info variables + + ---------------------------------- + -- Profile Definitions and Data -- + ---------------------------------- + + type Profile_Name is (No_Profile, Ravenscar, Restricted); + -- Names of recognized profiles. No_Profile is used to indicate that a + -- restriction came from pragma Restrictions[_Warning], as opposed to + -- pragma Profile[_Warning]. + + subtype Profile_Name_Actual is Profile_Name range Ravenscar .. Restricted; + -- Actual used profile names + + type Profile_Data is record + Set : Restriction_Flags; + -- Set to True if given restriction must be set for the profile, and + -- False if it need not be set (False does not mean that it must not be + -- set, just that it need not be set). If the flag is True for a + -- parameter restriction, then the Value array gives the maximum value + -- permitted by the profile. + + Value : Restriction_Values; + -- An entry in this array is meaningful only if the corresponding flag + -- in Set is True. In that case, the value in this array is the maximum + -- value of the parameter permitted by the profile. + end record; + + Profile_Info : constant array (Profile_Name_Actual) of Profile_Data := + + -- Restricted Profile + + (Restricted => + + -- Restrictions for Restricted profile + + (Set => + (No_Abort_Statements => True, + No_Asynchronous_Control => True, + No_Dynamic_Attachment => True, + No_Dynamic_Priorities => True, + No_Entry_Queue => True, + No_Local_Protected_Objects => True, + No_Protected_Type_Allocators => True, + No_Requeue_Statements => True, + No_Task_Allocators => True, + No_Task_Attributes_Package => True, + No_Task_Hierarchy => True, + No_Terminate_Alternatives => True, + Max_Asynchronous_Select_Nesting => True, + Max_Protected_Entries => True, + Max_Select_Alternatives => True, + Max_Task_Entries => True, + others => False), + + -- Value settings for Restricted profile + + Value => + (Max_Asynchronous_Select_Nesting => 0, + Max_Protected_Entries => 1, + Max_Select_Alternatives => 0, + Max_Task_Entries => 0, + others => 0)), + + -- Ravenscar Profile + + -- Note: the table entries here only represent the + -- required restriction profile for Ravenscar. The + -- full Ravenscar profile also requires: + + -- pragma Dispatching_Policy (FIFO_Within_Priorities); + -- pragma Locking_Policy (Ceiling_Locking); + -- pragma Detect_Blocking + + Ravenscar => + + -- Restrictions for Ravenscar = Restricted profile .. + + (Set => + (No_Abort_Statements => True, + No_Asynchronous_Control => True, + No_Dynamic_Attachment => True, + No_Dynamic_Priorities => True, + No_Entry_Queue => True, + No_Local_Protected_Objects => True, + No_Protected_Type_Allocators => True, + No_Requeue_Statements => True, + No_Task_Allocators => True, + No_Task_Attributes_Package => True, + No_Task_Hierarchy => True, + No_Terminate_Alternatives => True, + Max_Asynchronous_Select_Nesting => True, + Max_Protected_Entries => True, + Max_Select_Alternatives => True, + Max_Task_Entries => True, + + -- plus these additional restrictions: + + No_Calendar => True, + No_Implicit_Heap_Allocations => True, + No_Relative_Delay => True, + No_Select_Statements => True, + No_Task_Termination => True, + Simple_Barriers => True, + others => False), + + -- Value settings for Ravenscar (same as Restricted) + + Value => + (Max_Asynchronous_Select_Nesting => 0, + Max_Protected_Entries => 1, + Max_Select_Alternatives => 0, + Max_Task_Entries => 0, + others => 0))); + +end System.Rident; diff --git a/gcc/ada/s-rpc.adb b/gcc/ada/s-rpc.adb new file mode 100644 index 000000000..1ffb9b984 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..fa883ecbb --- /dev/null +++ b/gcc/ada/s-rpc.ads @@ -0,0 +1,94 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . R P C -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 .. 63; + -- This type must not be modified without checking the code in + -- a-except.adb, since it expects a Partition_ID whose string + -- representation fits on two characters. + + Communication_Error : exception; + + type Params_Stream_Type + (Initial_Size : Ada.Streams.Stream_Element_Count) is new + Ada.Streams.Root_Stream_Type with private; + + procedure Read + (Stream : in out Params_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + + 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 new file mode 100644 index 000000000..632e30e4b --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..9ebbd50bb --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..16e9fa0c9 --- /dev/null +++ b/gcc/ada/s-secsta.adb @@ -0,0 +1,539 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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_Ratio = 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 + + -------------- + -- 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. So 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 - 1) + & " 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 + + 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 new file mode 100644 index 000000000..7e6d11d51 --- /dev/null +++ b/gcc/ada/s-secsta.ads @@ -0,0 +1,119 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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. + + 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_Ratio 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_Ratio 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 new file mode 100644 index 000000000..e47c75fd4 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..5cbe3d92b --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..783fdc4a9 --- /dev/null +++ b/gcc/ada/s-shasto.adb @@ -0,0 +1,585 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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.IO_Exceptions; +with Ada.Streams; +with Ada.Streams.Stream_IO; + +with System.Global_Locks; +with System.Soft_Links; + +with System; +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"); + + procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); + pragma Import (C, Strncpy, "strncpy"); + + Dir_Name : aliased constant String := + "SHARED_MEMORY_DIRECTORY" & ASCII.NUL; + + Env_Value_Ptr : aliased Address; + Env_Value_Length : aliased Integer; + + begin + if Dir = null then + Get_Env_Value_Ptr + (Dir_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address); + + Dir := new String (1 .. Env_Value_Length); + + if Env_Value_Length > 0 then + Strncpy (Dir.all'Address, Env_Value_Ptr, Env_Value_Length); + 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 new file mode 100644 index 000000000..0ef65cc59 --- /dev/null +++ b/gcc/ada/s-shasto.ads @@ -0,0 +1,183 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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. + +-- This unit (and shared passive partitions) are supported on all +-- GNAT implementations except on OpenVMS (where problems arise from +-- trying to share files, and with version numbers of files) + +-- -------------------------- +-- -- 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 new file mode 100644 index 000000000..4ae51f39f --- /dev/null +++ b/gcc/ada/s-soflin.adb @@ -0,0 +1,333 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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_Exc_Stack : array (0 .. 8192) of aliased Character; + for NT_Exc_Stack'Alignment use Standard'Maximum_Alignment; + -- Allocate an exception stack for the main program to use. + -- This is currently only used under VMS. + + NT_TSD : TSD; + -- Note: we rely on the default initialization of NT_TSD + + -------------------- + -- 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 the global list for controlled objects if needed + + Finalize_Global_List.all; + 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 type Parameters.Size_Type; + + SS_Ratio_Dynamic : constant Boolean := + Parameters.Sec_Stack_Ratio = Parameters.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_Exc_Stack_Addr_NT -- + --------------------------- + + function Get_Exc_Stack_Addr_NT return Address is + begin + return NT_Exc_Stack (NT_Exc_Stack'Last)'Address; + end Get_Exc_Stack_Addr_NT; + + ----------------------------- + -- Get_Exc_Stack_Addr_Soft -- + ----------------------------- + + function Get_Exc_Stack_Addr_Soft return Address is + begin + return Get_Exc_Stack_Addr.all; + end Get_Exc_Stack_Addr_Soft; + + ------------------------ + -- 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; + + ------------------------------- + -- Null_Finalize_Global_List -- + ------------------------------- + + procedure Null_Finalize_Global_List is + begin + null; + end Null_Finalize_Global_List; + + --------------------------- + -- 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; + + ------------------------- + -- Update_Exception_NT -- + ------------------------- + + procedure Update_Exception_NT (X : EO := Current_Target_Exception) is + begin + Ada.Exceptions.Save_Occurrence (NT_TSD.Current_Excep, X); + end Update_Exception_NT; + +end System.Soft_Links; diff --git a/gcc/ada/s-soflin.ads b/gcc/ada/s-soflin.ads new file mode 100644 index 000000000..783fd8878 --- /dev/null +++ b/gcc/ada/s-soflin.ads @@ -0,0 +1,397 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +with Ada.Exceptions; +with System.Stack_Checking; + +package System.Soft_Links is + pragma Preelaborate_05; + + 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); + 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, only VMS + -- uses this. + + procedure Update_Exception_NT (X : EO := Current_Target_Exception); + -- Handle exception setting. This routine is provided for targets that + -- have built-in exception handling such as the Java Virtual Machine. + -- Currently, only JGNAT uses this. See 4jexcept.ads for an explanation on + -- how this routine is used. + + 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 Null_Finalize_Global_List; + -- Finalize global list for controlled objects (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) + + Update_Exception : Special_EO_Call := Update_Exception_NT'Access; + -- Handle exception setting and tasking polling when 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_Global_List : No_Param_Proc := Null_Finalize_Global_List'Access; + -- Performs finalization of global list for controlled objects + + 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_Exc_Stack_Addr_NT return Address; + Get_Exc_Stack_Addr : Get_Address_Call := Get_Exc_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 -- + ------------------------------------- + + 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 nullity of this wrapper shall correspond to the nullity 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. + + ------------------------ + -- 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); + + function Get_Exc_Stack_Addr_Soft return Address; + + -- 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-solita.adb b/gcc/ada/s-solita.adb new file mode 100644 index 000000000..aa3c5a8e2 --- /dev/null +++ b/gcc/ada/s-solita.adb @@ -0,0 +1,222 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S O F T _ L I N K S . T A S K I N G -- +-- -- +-- 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 -- +-- . -- +-- -- +-- 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 subprogram alpha ordering check, since we group soft link bodies +-- and dummy soft link bodies together separately in this unit. + +pragma Polling (Off); +-- Turn polling off for this package. We don't need polling during any of the +-- routines in this package, and more to the point, if we try to poll it can +-- cause infinite loops. + +with Ada.Exceptions; +with Ada.Exceptions.Is_Null_Occurrence; + +with System.Task_Primitives.Operations; +with System.Tasking; +with System.Stack_Checking; + +package body System.Soft_Links.Tasking is + + package STPO renames System.Task_Primitives.Operations; + package SSL renames System.Soft_Links; + + use Ada.Exceptions; + + use type System.Tasking.Task_Id; + use type System.Tasking.Termination_Handler; + + ---------------- + -- Local Data -- + ---------------- + + Initialized : Boolean := False; + -- Boolean flag that indicates whether the tasking soft links have + -- already been set. + + ----------------------------------------------------------------- + -- Tasking Versions of Services Needed by Non-Tasking Programs -- + ----------------------------------------------------------------- + + function Get_Jmpbuf_Address return Address; + procedure Set_Jmpbuf_Address (Addr : Address); + -- Get/Set Jmpbuf_Address for current task + + function Get_Sec_Stack_Addr return Address; + procedure Set_Sec_Stack_Addr (Addr : Address); + -- Get/Set location of current task's secondary stack + + procedure Timed_Delay_T (Time : Duration; Mode : Integer); + -- Task-safe version of SSL.Timed_Delay + + procedure Task_Termination_Handler_T (Excep : SSL.EO); + -- Task-safe version of the task termination procedure + + function Get_Stack_Info return Stack_Checking.Stack_Access; + -- Get access to the current task's Stack_Info + + -------------------------- + -- Soft-Link Get Bodies -- + -------------------------- + + function Get_Jmpbuf_Address return Address is + begin + return STPO.Self.Common.Compiler_Data.Jmpbuf_Address; + end Get_Jmpbuf_Address; + + function Get_Sec_Stack_Addr return Address is + begin + return STPO.Self.Common.Compiler_Data.Sec_Stack_Addr; + end Get_Sec_Stack_Addr; + + function Get_Stack_Info return Stack_Checking.Stack_Access is + begin + return STPO.Self.Common.Compiler_Data.Pri_Stack_Info'Access; + end Get_Stack_Info; + + -------------------------- + -- Soft-Link Set Bodies -- + -------------------------- + + procedure Set_Jmpbuf_Address (Addr : Address) is + begin + STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr; + end Set_Jmpbuf_Address; + + procedure Set_Sec_Stack_Addr (Addr : Address) is + begin + STPO.Self.Common.Compiler_Data.Sec_Stack_Addr := Addr; + end Set_Sec_Stack_Addr; + + ------------------- + -- Timed_Delay_T -- + ------------------- + + procedure Timed_Delay_T (Time : Duration; Mode : Integer) is + Self_Id : constant System.Tasking.Task_Id := STPO.Self; + + begin + -- In case pragma Detect_Blocking is active then Program_Error + -- must be raised if this potentially blocking operation + -- is called from a protected operation. + + if System.Tasking.Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with "potentially blocking operation"; + else + Abort_Defer.all; + STPO.Timed_Delay (Self_Id, Time, Mode); + Abort_Undefer.all; + end if; + end Timed_Delay_T; + + -------------------------------- + -- Task_Termination_Handler_T -- + -------------------------------- + + procedure Task_Termination_Handler_T (Excep : SSL.EO) is + Self_Id : constant System.Tasking.Task_Id := STPO.Self; + Cause : System.Tasking.Cause_Of_Termination; + EO : Ada.Exceptions.Exception_Occurrence; + + begin + -- We can only be here because we are terminating the environment task. + -- Task termination for the rest of the tasks is handled in the + -- Task_Wrapper. + + pragma Assert (Self_Id = STPO.Environment_Task); + + -- Normal task termination + + if Is_Null_Occurrence (Excep) then + Cause := System.Tasking.Normal; + Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence); + + -- Abnormal task termination + + elsif Exception_Identity (Excep) = Standard'Abort_Signal'Identity then + Cause := System.Tasking.Abnormal; + Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence); + + -- Termination because of an unhandled exception + + else + Cause := System.Tasking.Unhandled_Exception; + Ada.Exceptions.Save_Occurrence (EO, Excep); + end if; + + -- There is no need for explicit protection against race conditions + -- for this part because it can only be executed by the environment + -- task after all the other tasks have been finalized. + + if Self_Id.Common.Specific_Handler /= null then + Self_Id.Common.Specific_Handler.all (Cause, Self_Id, EO); + elsif Self_Id.Common.Fall_Back_Handler /= null then + Self_Id.Common.Fall_Back_Handler.all (Cause, Self_Id, EO); + end if; + end Task_Termination_Handler_T; + + ----------------------------- + -- Init_Tasking_Soft_Links -- + ----------------------------- + + procedure Init_Tasking_Soft_Links is + begin + -- Set links only if not set already + + if not Initialized then + + -- Mark tasking soft links as initialized + + Initialized := True; + + -- The application being executed uses tasking so that the tasking + -- version of the following soft links need to be used. + + SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access; + SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access; + SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access; + SSL.Get_Stack_Info := Get_Stack_Info'Access; + SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access; + SSL.Timed_Delay := Timed_Delay_T'Access; + SSL.Task_Termination_Handler := Task_Termination_Handler_T'Access; + + -- No need to create a new Secondary Stack, since we will use the + -- default one created in s-secsta.adb + + SSL.Set_Sec_Stack_Addr (SSL.Get_Sec_Stack_Addr_NT); + SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT); + end if; + end Init_Tasking_Soft_Links; + +end System.Soft_Links.Tasking; diff --git a/gcc/ada/s-solita.ads b/gcc/ada/s-solita.ads new file mode 100644 index 000000000..d91568149 --- /dev/null +++ b/gcc/ada/s-solita.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S O F T _ L I N K S . T A S K I N G -- +-- -- +-- 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 contains the tasking versions soft links that are common +-- to the full and the restricted run times. The rest of the required soft +-- links are set by System.Tasking.Initialization and System.Tasking.Stages +-- (full run time) or System.Tasking.Restricted.Stages (restricted run time). + +package System.Soft_Links.Tasking is + + procedure Init_Tasking_Soft_Links; + -- Set the tasking soft links that are common to the full and the + -- restricted run times. + +end System.Soft_Links.Tasking; diff --git a/gcc/ada/s-sopco3.adb b/gcc/ada/s-sopco3.adb new file mode 100644 index 000000000..5e7b6bbcc --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..68b1066c6 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +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 new file mode 100644 index 000000000..4bfbcc31c --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..e198bbae8 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +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 new file mode 100644 index 000000000..8467028c6 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..3491bb9ad --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +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-stache.adb b/gcc/ada/s-stache.adb new file mode 100644 index 000000000..ffad20544 --- /dev/null +++ b/gcc/ada/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-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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit; + +-- 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 new file mode 100644 index 000000000..878b8a527 --- /dev/null +++ b/gcc/ada/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-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 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; + +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 new file mode 100644 index 000000000..ffea8d008 --- /dev/null +++ b/gcc/ada/s-stalib.adb @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +-- 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. + + 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 new file mode 100644 index 000000000..6b3d8645c --- /dev/null +++ b/gcc/ada/s-stalib.ads @@ -0,0 +1,276 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + +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 + pragma Warnings (Off); + pragma Preelaborate_05; + pragma Warnings (On); + + type Big_String_Ptr is access all String (Positive); + for Big_String_Ptr'Storage_Size use 0; + -- A non-fat pointer type for null terminated strings + + function To_Ptr is + new Ada.Unchecked_Conversion (System.Address, Big_String_Ptr); + + --------------------------------------------- + -- Type For Enumeration Image Index Tables -- + --------------------------------------------- + + -- Note: these types are declared at the start of this unit, since + -- they must appear before any enumeration types declared in this + -- unit. Note that the spec of system is already elaborated at + -- this point (since we are a child of system), which means that + -- enumeration types in package System cannot use these types. + + type Image_Index_Table_8 is + array (Integer range <>) of Short_Short_Integer; + type Image_Index_Table_16 is + array (Integer range <>) of Short_Integer; + type Image_Index_Table_32 is + array (Integer range <>) of Integer; + -- These types are used to generate the index vector used for enumeration + -- type image tables. See spec of Exp_Imgv in the main GNAT sources for a + -- full description of the data structures that are used here. + + ------------------------------------- + -- 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 + + type Exception_Code is mod 2 ** Integer'Size; + -- A scalar value bound to some exception data. Typically used for + -- imported or exported exceptions on VMS. Having a separate type for this + -- is useful to enforce consistency throughout the various run-time units + -- handling such codes, and having it unsigned is the most appropriate + -- choice for it's currently single use on VMS. + + -- ??? The construction in Cstand has no way to access the proper type + -- node for Exception_Code, and currently uses Standard_Unsigned as a + -- fallback. The representations shall match, and the size clause below + -- is aimed at ensuring that. + + for Exception_Code'Size use Integer'Size; + + -- 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 "V" for imported VMS 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. + + Import_Code : Exception_Code; + -- Value for imported exceptions. Needed only for the handling of + -- Import/Export_Exception for the VMS case, but present in all + -- implementations (we might well extend this mechanism for other + -- systems in the future). + + 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, + Import_Code => 0, + 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, + Import_Code => 0, + 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, + Import_Code => 0, + 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, + Import_Code => 0, + 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, + Import_Code => 0, + 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, + Import_Code => 0, + 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 every possible raise event, 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. + ); + -- 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 new file mode 100644 index 000000000..e85bc46bf --- /dev/null +++ b/gcc/ada/s-stausa.adb @@ -0,0 +1,677 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2010, 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 | |####| + -- +------------------------------------------------------------------+ + + function Top_Slot_Index_In (Stack : Stack_Slots) return Integer; + -- Index of the stack Top slot in the Slots array, denoting the latest + -- possible slot available to call chain leaves. + + function Bottom_Slot_Index_In (Stack : Stack_Slots) return Integer; + -- Index of the stack Bottom slot in the Slots array, denoting the first + -- possible slot available to call chain entry points. + + function Push_Index_Step_For (Stack : Stack_Slots) return Integer; + -- By how much do we need to update a Slots index to Push a single slot on + -- the stack. + + function Pop_Index_Step_For (Stack : Stack_Slots) return Integer; + -- By how much do we need to update a Slots index to Pop a single slot off + -- the stack. + + pragma Inline_Always (Top_Slot_Index_In); + pragma Inline_Always (Bottom_Slot_Index_In); + pragma Inline_Always (Push_Index_Step_For); + pragma Inline_Always (Pop_Index_Step_For); + + ----------------------- + -- Top_Slot_Index_In -- + ----------------------- + + function Top_Slot_Index_In (Stack : Stack_Slots) return Integer is + begin + if System.Parameters.Stack_Grows_Down then + return Stack'First; + else + return Stack'Last; + end if; + end Top_Slot_Index_In; + + ---------------------------- + -- Bottom_Slot_Index_In -- + ---------------------------- + + function Bottom_Slot_Index_In (Stack : Stack_Slots) return Integer is + begin + if System.Parameters.Stack_Grows_Down then + return Stack'Last; + else + return Stack'First; + end if; + end Bottom_Slot_Index_In; + + ------------------------- + -- Push_Index_Step_For -- + ------------------------- + + function Push_Index_Step_For (Stack : Stack_Slots) return Integer is + pragma Unreferenced (Stack); + begin + if System.Parameters.Stack_Grows_Down then + return -1; + else + return +1; + end if; + end Push_Index_Step_For; + + ------------------------ + -- Pop_Index_Step_For -- + ------------------------ + + function Pop_Index_Step_For (Stack : Stack_Slots) return Integer is + begin + return -Push_Index_Step_For (Stack); + end Pop_Index_Step_For; + + ------------------- + -- 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"; + + function Get_Usage_Range (Result : Task_Result) return String; + -- Return string representing the range of possible result of 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 + Bottom_Of_Stack : aliased Integer; + 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), + Variation => 0, + Value => 0, + Max_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, + My_Stack_Size, + System.Storage_Elements.To_Integer (Bottom_Of_Stack'Address), + 0); + + 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. + + Stack_Used_When_Filling : Integer; + Current_Stack_Level : aliased Integer; + + Guard : constant Integer := 256; + -- Guard space between the Current_Stack_Level'Address and the last + -- allocated byte on the stack. + + begin + -- Easiest and most accurate method: the top of the stack is known. + + if Analyzer.Top_Pattern_Mark /= 0 then + Analyzer.Pattern_Size := + Stack_Size (Analyzer.Top_Pattern_Mark, + To_Stack_Address (Current_Stack_Level'Address)) + - Guard; + + if System.Parameters.Stack_Grows_Down then + Analyzer.Stack_Overlay_Address := + To_Address (Analyzer.Top_Pattern_Mark); + else + Analyzer.Stack_Overlay_Address := + To_Address (Analyzer.Top_Pattern_Mark + - Stack_Address (Analyzer.Pattern_Size)); + end if; + + declare + Pattern : aliased Stack_Slots + (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern); + for Pattern'Address use Analyzer.Stack_Overlay_Address; + + begin + if System.Parameters.Stack_Grows_Down then + for J in reverse Pattern'Range loop + Pattern (J) := Analyzer.Pattern; + end loop; + + Analyzer.Bottom_Pattern_Mark := + To_Stack_Address (Pattern (Pattern'Last)'Address); + + else + for J in Pattern'Range loop + Pattern (J) := Analyzer.Pattern; + end loop; + + Analyzer.Bottom_Pattern_Mark := + To_Stack_Address (Pattern (Pattern'First)'Address); + end if; + end; + + else + -- Readjust the pattern size. When we arrive in this function, there + -- is already a given amount of stack used, that we won't analyze. + + Stack_Used_When_Filling := + Stack_Size (Analyzer.Bottom_Of_Stack, + To_Stack_Address (Current_Stack_Level'Address)); + + if Stack_Used_When_Filling > Analyzer.Pattern_Size then + + -- In this case, the known size of the stack is too small, we've + -- already taken more than expected, so there's no possible + -- computation + + Analyzer.Pattern_Size := 0; + else + Analyzer.Pattern_Size := + Analyzer.Pattern_Size - Stack_Used_When_Filling; + end if; + + declare + Stack : aliased Stack_Slots + (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern); + + begin + Stack := (others => Analyzer.Pattern); + + Analyzer.Stack_Overlay_Address := Stack'Address; + + if Analyzer.Pattern_Size /= 0 then + Analyzer.Bottom_Pattern_Mark := + To_Stack_Address + (Stack (Bottom_Slot_Index_In (Stack))'Address); + Analyzer.Top_Pattern_Mark := + To_Stack_Address + (Stack (Top_Slot_Index_In (Stack))'Address); + else + Analyzer.Bottom_Pattern_Mark := + To_Stack_Address (Stack'Address); + Analyzer.Top_Pattern_Mark := + To_Stack_Address (Stack'Address); + end if; + end; + end if; + end Fill_Stack; + + ------------------------- + -- Initialize_Analyzer -- + ------------------------- + + procedure Initialize_Analyzer + (Analyzer : in out Stack_Analyzer; + Task_Name : String; + My_Stack_Size : Natural; + Max_Pattern_Size : Natural; + Bottom : Stack_Address; + Top : Stack_Address; + Pattern : Unsigned_32 := 16#DEAD_BEEF#) + is + begin + -- Initialize the analyzer fields + + Analyzer.Bottom_Of_Stack := Bottom; + Analyzer.Stack_Size := My_Stack_Size; + Analyzer.Pattern_Size := Max_Pattern_Size; + Analyzer.Pattern := Pattern; + Analyzer.Result_Id := Next_Id; + Analyzer.Task_Name := (others => ' '); + Analyzer.Top_Pattern_Mark := Top; + + -- 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 + 4); + else + return Natural (SP_High - SP_Low + 4); + 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.Stack_Overlay_Address; + + begin + Analyzer.Topmost_Touched_Mark := Analyzer.Bottom_Pattern_Mark; + + 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. + + declare + Top_Index : constant Integer := Top_Slot_Index_In (Stack); + Bottom_Index : constant Integer := Bottom_Slot_Index_In (Stack); + Step : constant Integer := Pop_Index_Step_For (Stack); + J : Integer; + + begin + J := Top_Index; + loop + if Stack (J) /= Analyzer.Pattern then + Analyzer.Topmost_Touched_Mark + := To_Stack_Address (Stack (J)'Address); + exit; + end if; + + exit when J = Bottom_Index; + J := J + Step; + end loop; + end; + end Compute_Result; + + --------------------- + -- Get_Usage_Range -- + --------------------- + + function Get_Usage_Range (Result : Task_Result) return String is + Variation_Used_Str : constant String := + Natural'Image (Result.Variation); + Value_Used_Str : constant String := + Natural'Image (Result.Value); + begin + return Value_Used_Str & " +/- " & Variation_Used_Str; + end Get_Usage_Range; + + --------------------- + -- 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); + My_Stack_Size_Str : constant String := Natural'Image (Result.Max_Size); + Actual_Use_Str : constant String := Get_Usage_Range (Result); + + Result_Id_Blanks : constant + String (1 .. Index_Str'Length - Result_Id_Str'Length) := + (others => ' '); + + Stack_Size_Blanks : constant + String (1 .. Max_Stack_Size_Len - My_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 & My_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_Actual_Use_Result_Id : Natural := Result_Array'First; + 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 > + Result_Array (Max_Actual_Use_Result_Id).Value + then + Max_Actual_Use_Result_Id := J; + end if; + + if Result_Array (J).Max_Size > Max_Stack_Size then + Max_Stack_Size := Result_Array (J).Max_Size; + end if; + end loop; + + Max_Stack_Size_Len := Natural'Image (Max_Stack_Size)'Length; + + Max_Actual_Use_Len := + Get_Usage_Range (Result_Array (Max_Actual_Use_Result_Id))'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, + Max_Size => Analyzer.Stack_Size, + Variation => 0, + Value => 0); + + Overflow_Guard : constant Integer := + Analyzer.Stack_Size + - Stack_Size (Analyzer.Top_Pattern_Mark, Analyzer.Bottom_Of_Stack); + Max, Min : Positive; + + begin + if Analyzer.Pattern_Size = 0 then + + -- If we have that result, it means that we didn't do any computation + -- at all. In other words, we used at least everything (and possibly + -- more). + + Min := Analyzer.Stack_Size - Overflow_Guard; + Max := Analyzer.Stack_Size; + + else + Min := + Stack_Size + (Analyzer.Topmost_Touched_Mark, Analyzer.Bottom_Of_Stack); + Max := Min + Overflow_Guard; + end if; + + Result.Value := (Max + Min) / 2; + Result.Variation := (Max - Min) / 2; + + 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 := + Get_Usage_Range (Result)'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 new file mode 100644 index 000000000..1cd78ea04 --- /dev/null +++ b/gcc/ada/s-stausa.ads @@ -0,0 +1,347 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2010, 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. + + Variation : Natural; + -- Possible variation in the amount of used stack. The real stack usage + -- may vary in the range Value +/- Variation + + Max_Size : Natural; + 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 - A_Guard, + -- 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. + + -- 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 frame | Memory filled with Analyzer.Pattern | + -- | of Fill_Stack | | + -- | (deallocated at | | + -- | the end of the call) | | + -- ^ | ^ + -- Analyzer.Bottom_Of_Stack | Analyzer.Top_Pattern_Mark + -- ^ + -- Analyzer.Bottom_Pattern_Mark + -- + + procedure Initialize_Analyzer + (Analyzer : in out Stack_Analyzer; + Task_Name : String; + My_Stack_Size : Natural; + Max_Pattern_Size : Natural; + Bottom : Stack_Address; + Top : Stack_Address; + 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 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 frame | Array of | used | Memory | + -- | of Compute_Result | Analyzer.Probe | during | filled | + -- | (deallocated at | elements | the | with | + -- | the end of the call) | | execution | pattern | + -- | ^ | | | + -- | Bottom_Pattern_Mark | | | + -- | | | + -- |<----------------------------------------------------> | + -- Stack used ^ + -- Top_Pattern_Mark + + 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_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 + + Bottom_Pattern_Mark : Stack_Address; + -- Bound of the pattern area on the stack closest to the bottom + + Top_Pattern_Mark : Stack_Address; + -- Topmost bound of the pattern area on the stack + + 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. + + Bottom_Of_Stack : Stack_Address; + -- Address of the bottom of the stack, as given by the caller of + -- Initialize_Analyzer. + + Stack_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 new file mode 100644 index 000000000..237c0f9e0 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version of this package is for implementations which use +-- the stack limit approach (the limit of the stack is stored into a per +-- thread variable). + +pragma Restrictions (No_Elaboration_Code); +-- We want to guarantee the absence of elaboration code because the binder +-- does not handle references to this package. + +pragma Polling (Off); +-- Turn off polling, we do not want polling to take place during stack +-- checking operations. It causes infinite loops and other problems. + +package System.Stack_Checking.Operations is + pragma Preelaborate; + + procedure Initialize_Stack_Limit; + pragma Export (C, Initialize_Stack_Limit, + "__gnat_initialize_stack_limit"); + -- This procedure is called before elaboration to setup the stack limit + -- for the environment task and to register the hook to be called at + -- task creation. +end System.Stack_Checking.Operations; diff --git a/gcc/ada/s-stchop-rtems.adb b/gcc/ada/s-stchop-rtems.adb new file mode 100644 index 000000000..ac0cfd0f4 --- /dev/null +++ b/gcc/ada/s-stchop-rtems.adb @@ -0,0 +1,113 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the RTEMS version of this package. +-- This file should be kept synchronized with the general implementation +-- provided by s-stchop.adb. + +pragma Restrictions (No_Elaboration_Code); +-- We want to guarantee the absence of elaboration code because the +-- binder does not handle references to this package. + +with Ada.Exceptions; + +with Interfaces.C; use Interfaces.C; + +package body System.Stack_Checking.Operations is + + ---------------------------- + -- Invalidate_Stack_Cache -- + ---------------------------- + + procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is + pragma Warnings (Off, Any_Stack); + begin + Cache := Null_Stack; + end Invalidate_Stack_Cache; + + ----------------------------- + -- Notify_Stack_Attributes -- + ----------------------------- + + procedure Notify_Stack_Attributes + (Initial_SP : System.Address; + Size : System.Storage_Elements.Storage_Offset) + is + + -- RTEMS keeps all the information we need. + + pragma Unreferenced (Size); + pragma Unreferenced (Initial_SP); + + begin + null; + end Notify_Stack_Attributes; + + ----------------- + -- Stack_Check -- + ----------------- + + function Stack_Check + (Stack_Address : System.Address) return Stack_Access + is + pragma Unreferenced (Stack_Address); + + -- RTEMS has a routine to check if the stack is blown. + -- It returns a C99 bool. + function rtems_stack_checker_is_blown return Interfaces.C.unsigned_char; + pragma Import (C, + rtems_stack_checker_is_blown, "rtems_stack_checker_is_blown"); + + begin + -- RTEMS has a routine to check this. So use it. + + if rtems_stack_checker_is_blown /= 0 then + Ada.Exceptions.Raise_Exception + (E => Storage_Error'Identity, + Message => "stack overflow detected"); + end if; + + return null; + + end Stack_Check; + + ------------------------ + -- Update_Stack_Cache -- + ------------------------ + + procedure Update_Stack_Cache (Stack : Stack_Access) is + begin + if not Multi_Processor then + Cache := Stack; + end if; + end Update_Stack_Cache; + +end System.Stack_Checking.Operations; diff --git a/gcc/ada/s-stchop-vxworks.adb b/gcc/ada/s-stchop-vxworks.adb new file mode 100644 index 000000000..ffdba814a --- /dev/null +++ b/gcc/ada/s-stchop-vxworks.adb @@ -0,0 +1,153 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the verson for VxWorks 5 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 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 := + Boolean'Pos (Stack_Grows_Down) * Address'First + + Boolean'Pos (not Stack_Grows_Down) * Address'Last; + pragma Export (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 + -- For the environment task + + 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; + + function Task_Var_Add (Tid : Interfaces.C.int; Var : Address) + return Interfaces.C.int; + pragma Import (C, Task_Var_Add, "taskVarAdd"); + -- Import from VxWorks + + 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); + + -- In s-stchop.adb, we check for overflow in the following operations, + -- but we have no such check in this vxworks version. Why not ??? + + if Stack_Grows_Down then + Limit := Stack_Info.Base - Storage_Offset (Stack_Info.Size); + else + Limit := Stack_Info.Base + Storage_Offset (Stack_Info.Size); + end if; + + -- Note: taskVarAdd implicitly calls taskVarInit if required + + if Task_Var_Add (0, Stack_Limit'Address) = 0 then + Stack_Limit := Limit; + end if; + 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 new file mode 100644 index 000000000..b757c5653 --- /dev/null +++ b/gcc/ada/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-2010, 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 + -- loosing 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 new file mode 100644 index 000000000..014eddc41 --- /dev/null +++ b/gcc/ada/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-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 new file mode 100644 index 000000000..cd3e22ef9 --- /dev/null +++ b/gcc/ada/s-stoele.adb @@ -0,0 +1,130 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 on VMS + + 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 new file mode 100644 index 000000000..af60beb55 --- /dev/null +++ b/gcc/ada/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-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 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; + +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 new file mode 100644 index 000000000..c66746033 --- /dev/null +++ b/gcc/ada/s-stopoo.adb @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 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 : 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 new file mode 100644 index 000000000..c2d43f7c5 --- /dev/null +++ b/gcc/ada/s-stopoo.ads @@ -0,0 +1,86 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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; +with System.Storage_Elements; + +package System.Storage_Pools is + pragma Preelaborate; + + type Root_Storage_Pool is abstract + new Ada.Finalization.Limited_Controlled with private; + + procedure Allocate + (Pool : in out Root_Storage_Pool; + Storage_Address : out 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 : 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 + -- 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 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 : Address; + Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count); + + type Root_Storage_Pool is abstract + new Ada.Finalization.Limited_Controlled with null record; +end System.Storage_Pools; diff --git a/gcc/ada/s-stratt-xdr.adb b/gcc/ada/s-stratt-xdr.adb new file mode 100644 index 000000000..86e190a98 --- /dev/null +++ b/gcc/ada/s-stratt-xdr.adb @@ -0,0 +1,1891 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2010, 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. + +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 -- + ----------------- + + 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; + + 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 + Positive := False; + Exponent := Long_Unsigned (S (1) - BS); + else + 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 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; + + 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 + Positive := False; + Exponent := Long_Unsigned (S (1) - BS); + else + 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 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; + + 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 + Positive := False; + Exponent := Long_Unsigned (S (1) - BS); + else + 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 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; + 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 + Positive := False; + Exponent := Long_Unsigned (S (1) - BS); + else + 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 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; + 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 + + 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 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; + 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 + + 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 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; + 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 + + 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 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; + 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 + + 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 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 new file mode 100644 index 000000000..796665ff7 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..498700e06 --- /dev/null +++ b/gcc/ada/s-stratt.ads @@ -0,0 +1,210 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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. + -- for + + --------------------- + -- 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. + +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 new file mode 100644 index 000000000..37ccc6138 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..6d1a303c5 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +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 new file mode 100644 index 000000000..0e86cb66b --- /dev/null +++ b/gcc/ada/s-strhas.adb @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- 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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +package body System.String_Hash is + + -- Compute a hash value for a key. The approach here is follows the + -- algorithm used in GNU Awk and the ndbm substitute SDBM by Ozan Yigit. + + ---------- + -- 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 new file mode 100644 index 000000000..c2e72ccbb --- /dev/null +++ b/gcc/ada/s-strhas.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- 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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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. + +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 new file mode 100755 index 000000000..e1799eb45 --- /dev/null +++ b/gcc/ada/s-string.adb @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit; + +package body System.Strings is + + ---------- + -- Free -- + ---------- + + procedure Free (Arg : in out String_List_Access) is + X : String_Access; + + 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 + X := Arg (J); + Free (X); + 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 new file mode 100755 index 000000000..79ec11272 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..44a6a76bf --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..54ac74578 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +package System.String_Ops is + pragma Pure; + + function Str_Concat (X, Y : String) return String; + -- Concatenate two strings and return resulting string + + function Str_Concat_SC (X : String; Y : Character) return String; + -- Concatenate string and character + + function Str_Concat_CS (X : Character; Y : String) return String; + -- Concatenate character and string + + function Str_Concat_CC (X, Y : Character) return String; + -- Concatenate two characters + +end System.String_Ops; diff --git a/gcc/ada/s-ststop.adb b/gcc/ada/s-ststop.adb new file mode 100644 index 000000000..d9f8d0f8e --- /dev/null +++ b/gcc/ada/s-ststop.adb @@ -0,0 +1,685 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G S . S T R E A M _ O P S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2008-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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit; + +with Ada.Streams; use Ada.Streams; +with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; +with Ada.Unchecked_Conversion; + +with System.Stream_Attributes; use System; + +package body System.Strings.Stream_Ops is + + -- The following type describes the low-level IO mechanism used in package + -- Stream_Ops_Internal. + + type IO_Kind is (Byte_IO, Block_IO); + + -- The following package provides an IO framework for strings. Depending + -- on the version of System.Stream_Attributes as well as the size of + -- formal parameter Character_Type, the package will either utilize block + -- IO or character-by-character IO. + + generic + type Character_Type is private; + type String_Type is array (Positive range <>) of Character_Type; + + package Stream_Ops_Internal is + function Input + (Strm : access Root_Stream_Type'Class; + IO : IO_Kind) return String_Type; + + procedure Output + (Strm : access Root_Stream_Type'Class; + Item : String_Type; + IO : IO_Kind); + + procedure Read + (Strm : access Root_Stream_Type'Class; + Item : out String_Type; + IO : IO_Kind); + + procedure Write + (Strm : access Root_Stream_Type'Class; + Item : String_Type; + IO : IO_Kind); + end Stream_Ops_Internal; + + ------------------------- + -- Stream_Ops_Internal -- + ------------------------- + + package body Stream_Ops_Internal is + + -- The following value represents the number of BITS allocated for the + -- default block used in string IO. The sizes of all other types are + -- calculated relative to this value. + + Default_Block_Size : constant := 512 * 8; + + -- Shorthand notation for stream element and character sizes + + C_Size : constant Integer := Character_Type'Size; + SE_Size : constant Integer := Stream_Element'Size; + + -- The following constants describe the number of stream elements or + -- characters that can fit into a default block. + + C_In_Default_Block : constant Integer := Default_Block_Size / C_Size; + SE_In_Default_Block : constant Integer := Default_Block_Size / SE_Size; + + -- Buffer types + + subtype Default_Block is Stream_Element_Array + (1 .. Stream_Element_Offset (SE_In_Default_Block)); + + subtype String_Block is String_Type (1 .. C_In_Default_Block); + + -- Conversions to and from Default_Block + + function To_Default_Block is + new Ada.Unchecked_Conversion (String_Block, Default_Block); + + function To_String_Block is + new Ada.Unchecked_Conversion (Default_Block, String_Block); + + ----------- + -- Input -- + ----------- + + function Input + (Strm : access Root_Stream_Type'Class; + IO : IO_Kind) return String_Type + is + begin + if Strm = null then + raise Constraint_Error; + end if; + + declare + Low : Positive; + High : Positive; + + begin + -- Read the bounds of the string + + Positive'Read (Strm, Low); + Positive'Read (Strm, High); + + declare + Item : String_Type (Low .. High); + + begin + -- Read the character content of the string + + Read (Strm, Item, IO); + + return Item; + end; + end; + end Input; + + ------------ + -- Output -- + ------------ + + procedure Output + (Strm : access Root_Stream_Type'Class; + Item : String_Type; + IO : IO_Kind) + is + begin + if Strm = null then + raise Constraint_Error; + end if; + + -- Write the bounds of the string + + Positive'Write (Strm, Item'First); + Positive'Write (Strm, Item'Last); + + -- Write the character content of the string + + Write (Strm, Item, IO); + end Output; + + ---------- + -- Read -- + ---------- + + procedure Read + (Strm : access Root_Stream_Type'Class; + Item : out String_Type; + IO : IO_Kind) + is + begin + if Strm = null then + raise Constraint_Error; + end if; + + -- Nothing to do if the desired string is empty + + if Item'Length = 0 then + return; + end if; + + -- Block IO + + if IO = Block_IO + and then Stream_Attributes.Block_IO_OK + then + declare + -- Determine the size in BITS of the block necessary to contain + -- the whole string. + + Block_Size : constant Natural := + (Item'Last - Item'First + 1) * C_Size; + + -- Item can be larger than what the default block can store, + -- determine the number of whole reads necessary to read the + -- string. + + Blocks : constant Natural := Block_Size / Default_Block_Size; + + -- The size of Item may not be a multiple of the default block + -- size, determine the size of the remaining chunk in BITS. + + Rem_Size : constant Natural := + Block_Size mod Default_Block_Size; + + -- String indexes + + Low : Positive := Item'First; + High : Positive := Low + C_In_Default_Block - 1; + + -- End of stream error detection + + Last : Stream_Element_Offset := 0; + Sum : Stream_Element_Offset := 0; + + begin + -- Step 1: If the string is too large, read in individual + -- chunks the size of the default block. + + if Blocks > 0 then + declare + Block : Default_Block; + + begin + for Counter in 1 .. Blocks loop + Read (Strm.all, Block, Last); + Item (Low .. High) := To_String_Block (Block); + + Low := High + 1; + High := Low + C_In_Default_Block - 1; + Sum := Sum + Last; + Last := 0; + end loop; + end; + end if; + + -- Step 2: Read in any remaining elements + + if Rem_Size > 0 then + declare + subtype Rem_Block is Stream_Element_Array + (1 .. Stream_Element_Offset (Rem_Size / SE_Size)); + + subtype Rem_String_Block is + String_Type (1 .. Rem_Size / C_Size); + + function To_Rem_String_Block is new + Ada.Unchecked_Conversion (Rem_Block, Rem_String_Block); + + Block : Rem_Block; + + begin + Read (Strm.all, Block, Last); + Item (Low .. Item'Last) := To_Rem_String_Block (Block); + + Sum := Sum + Last; + end; + end if; + + -- Step 3: Potential error detection. The sum of all the + -- chunks is less than we initially wanted to read. In other + -- words, the stream does not contain enough elements to fully + -- populate Item. + + if (Integer (Sum) * SE_Size) / C_Size < Item'Length then + raise End_Error; + end if; + end; + + -- Byte IO + + else + declare + C : Character_Type; + + begin + for Index in Item'First .. Item'Last loop + Character_Type'Read (Strm, C); + Item (Index) := C; + end loop; + end; + end if; + end Read; + + ----------- + -- Write -- + ----------- + + procedure Write + (Strm : access Root_Stream_Type'Class; + Item : String_Type; + IO : IO_Kind) + is + begin + if Strm = null then + raise Constraint_Error; + end if; + + -- Nothing to do if the input string is empty + + if Item'Length = 0 then + return; + end if; + + -- Block IO + + if IO = Block_IO + and then Stream_Attributes.Block_IO_OK + then + declare + -- Determine the size in BITS of the block necessary to contain + -- the whole string. + + Block_Size : constant Natural := Item'Length * C_Size; + + -- Item can be larger than what the default block can store, + -- determine the number of whole writes necessary to output the + -- string. + + Blocks : constant Natural := Block_Size / Default_Block_Size; + + -- The size of Item may not be a multiple of the default block + -- size, determine the size of the remaining chunk. + + Rem_Size : constant Natural := + Block_Size mod Default_Block_Size; + + -- String indexes + + Low : Positive := Item'First; + High : Positive := Low + C_In_Default_Block - 1; + + begin + -- Step 1: If the string is too large, write out individual + -- chunks the size of the default block. + + for Counter in 1 .. Blocks loop + Write (Strm.all, To_Default_Block (Item (Low .. High))); + + Low := High + 1; + High := Low + C_In_Default_Block - 1; + end loop; + + -- Step 2: Write out any remaining elements + + if Rem_Size > 0 then + declare + subtype Rem_Block is Stream_Element_Array + (1 .. Stream_Element_Offset (Rem_Size / SE_Size)); + + subtype Rem_String_Block is + String_Type (1 .. Rem_Size / C_Size); + + function To_Rem_Block is new + Ada.Unchecked_Conversion (Rem_String_Block, Rem_Block); + + begin + Write (Strm.all, To_Rem_Block (Item (Low .. Item'Last))); + end; + end if; + end; + + -- Byte IO + + else + for Index in Item'First .. Item'Last loop + Character_Type'Write (Strm, Item (Index)); + end loop; + end if; + end Write; + end Stream_Ops_Internal; + + -- Specific instantiations for all Ada string types + + package String_Ops is + new Stream_Ops_Internal + (Character_Type => Character, + String_Type => String); + + package Wide_String_Ops is + new Stream_Ops_Internal + (Character_Type => Wide_Character, + String_Type => Wide_String); + + package Wide_Wide_String_Ops is + new Stream_Ops_Internal + (Character_Type => Wide_Wide_Character, + String_Type => Wide_Wide_String); + + ------------------ + -- String_Input -- + ------------------ + + function String_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) return String + is + begin + return String_Ops.Input (Strm, Byte_IO); + end String_Input; + + ------------------------- + -- String_Input_Blk_IO -- + ------------------------- + + function String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) return String + is + begin + return String_Ops.Input (Strm, Block_IO); + end String_Input_Blk_IO; + + ------------------- + -- String_Output -- + ------------------- + + procedure String_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String) + is + begin + String_Ops.Output (Strm, Item, Byte_IO); + end String_Output; + + -------------------------- + -- String_Output_Blk_IO -- + -------------------------- + + procedure String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String) + is + begin + String_Ops.Output (Strm, Item, Block_IO); + end String_Output_Blk_IO; + + ----------------- + -- String_Read -- + ----------------- + + procedure String_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out String) + is + begin + String_Ops.Read (Strm, Item, Byte_IO); + end String_Read; + + ------------------------ + -- String_Read_Blk_IO -- + ------------------------ + + procedure String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out String) + is + begin + String_Ops.Read (Strm, Item, Block_IO); + end String_Read_Blk_IO; + + ------------------ + -- String_Write -- + ------------------ + + procedure String_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String) + is + begin + String_Ops.Write (Strm, Item, Byte_IO); + end String_Write; + + ------------------------- + -- String_Write_Blk_IO -- + ------------------------- + + procedure String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String) + is + begin + String_Ops.Write (Strm, Item, Block_IO); + end String_Write_Blk_IO; + + ----------------------- + -- Wide_String_Input -- + ----------------------- + + function Wide_String_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_String + is + begin + return Wide_String_Ops.Input (Strm, Byte_IO); + end Wide_String_Input; + + ------------------------------ + -- Wide_String_Input_Blk_IO -- + ------------------------------ + + function Wide_String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_String + is + begin + return Wide_String_Ops.Input (Strm, Block_IO); + end Wide_String_Input_Blk_IO; + + ------------------------ + -- Wide_String_Output -- + ------------------------ + + procedure Wide_String_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String) + is + begin + Wide_String_Ops.Output (Strm, Item, Byte_IO); + end Wide_String_Output; + + ------------------------------- + -- Wide_String_Output_Blk_IO -- + ------------------------------- + + procedure Wide_String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String) + is + begin + Wide_String_Ops.Output (Strm, Item, Block_IO); + end Wide_String_Output_Blk_IO; + + ---------------------- + -- Wide_String_Read -- + ---------------------- + + procedure Wide_String_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_String) + is + begin + Wide_String_Ops.Read (Strm, Item, Byte_IO); + end Wide_String_Read; + + ----------------------------- + -- Wide_String_Read_Blk_IO -- + ----------------------------- + + procedure Wide_String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_String) + is + begin + Wide_String_Ops.Read (Strm, Item, Block_IO); + end Wide_String_Read_Blk_IO; + + ----------------------- + -- Wide_String_Write -- + ----------------------- + + procedure Wide_String_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String) + is + begin + Wide_String_Ops.Write (Strm, Item, Byte_IO); + end Wide_String_Write; + + ------------------------------ + -- Wide_String_Write_Blk_IO -- + ------------------------------ + + procedure Wide_String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String) + is + begin + Wide_String_Ops.Write (Strm, Item, Block_IO); + end Wide_String_Write_Blk_IO; + + ---------------------------- + -- Wide_Wide_String_Input -- + ---------------------------- + + function Wide_Wide_String_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_Wide_String + is + begin + return Wide_Wide_String_Ops.Input (Strm, Byte_IO); + end Wide_Wide_String_Input; + + ----------------------------------- + -- Wide_Wide_String_Input_Blk_IO -- + ----------------------------------- + + function Wide_Wide_String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_Wide_String + is + begin + return Wide_Wide_String_Ops.Input (Strm, Block_IO); + end Wide_Wide_String_Input_Blk_IO; + + ----------------------------- + -- Wide_Wide_String_Output -- + ----------------------------- + + procedure Wide_Wide_String_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String) + is + begin + Wide_Wide_String_Ops.Output (Strm, Item, Byte_IO); + end Wide_Wide_String_Output; + + ------------------------------------ + -- Wide_Wide_String_Output_Blk_IO -- + ------------------------------------ + + procedure Wide_Wide_String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String) + is + begin + Wide_Wide_String_Ops.Output (Strm, Item, Block_IO); + end Wide_Wide_String_Output_Blk_IO; + + --------------------------- + -- Wide_Wide_String_Read -- + --------------------------- + + procedure Wide_Wide_String_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_Wide_String) + is + begin + Wide_Wide_String_Ops.Read (Strm, Item, Byte_IO); + end Wide_Wide_String_Read; + + ---------------------------------- + -- Wide_Wide_String_Read_Blk_IO -- + ---------------------------------- + + procedure Wide_Wide_String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_Wide_String) + is + begin + Wide_Wide_String_Ops.Read (Strm, Item, Block_IO); + end Wide_Wide_String_Read_Blk_IO; + + ---------------------------- + -- Wide_Wide_String_Write -- + ---------------------------- + + procedure Wide_Wide_String_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String) + is + begin + Wide_Wide_String_Ops.Write (Strm, Item, Byte_IO); + end Wide_Wide_String_Write; + + ----------------------------------- + -- Wide_Wide_String_Write_Blk_IO -- + ----------------------------------- + + procedure Wide_Wide_String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String) + is + begin + Wide_Wide_String_Ops.Write (Strm, Item, Block_IO); + end Wide_Wide_String_Write_Blk_IO; + +end System.Strings.Stream_Ops; diff --git a/gcc/ada/s-ststop.ads b/gcc/ada/s-ststop.ads new file mode 100644 index 000000000..db7059069 --- /dev/null +++ b/gcc/ada/s-ststop.ads @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G S . S T R E A M _ O P S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides subprogram implementations of stream attributes for +-- the following types: +-- Ada.String +-- Ada.Wide_String +-- Ada.Wide_Wide_String +-- +-- The compiler will generate references to the subprograms in this package +-- when expanding stream attributes for the above mentioned types. Example: +-- +-- String'Output (Some_Stream, Some_String); +-- +-- will be expanded into: +-- +-- String_Output (Some_Stream, Some_String); +-- or +-- String_Output_Blk_IO (Some_Stream, Some_String); + +pragma Compiler_Unit; + +with Ada.Streams; + +package System.Strings.Stream_Ops is + + ------------------------------ + -- String stream operations -- + ------------------------------ + + function String_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return String; + + function String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return String; + + procedure String_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String); + + procedure String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String); + + procedure String_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out String); + + procedure String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out String); + + procedure String_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String); + + procedure String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String); + + ----------------------------------- + -- Wide_String stream operations -- + ----------------------------------- + + function Wide_String_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return Wide_String; + + function Wide_String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return Wide_String; + + procedure Wide_String_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String); + + procedure Wide_String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String); + + procedure Wide_String_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_String); + + procedure Wide_String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_String); + + procedure Wide_String_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String); + + procedure Wide_String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String); + + ---------------------------------------- + -- Wide_Wide_String stream operations -- + ---------------------------------------- + + function Wide_Wide_String_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return Wide_Wide_String; + + function Wide_Wide_String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return Wide_Wide_String; + + procedure Wide_Wide_String_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String); + + procedure Wide_Wide_String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String); + + procedure Wide_Wide_String_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_Wide_String); + + procedure Wide_Wide_String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_Wide_String); + + procedure Wide_Wide_String_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String); + + procedure Wide_Wide_String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String); + +end System.Strings.Stream_Ops; diff --git a/gcc/ada/s-stusta.adb b/gcc/ada/s-stusta.adb new file mode 100644 index 000000000..8078d9bfe --- /dev/null +++ b/gcc/ada/s-stusta.adb @@ -0,0 +1,261 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T A C K _ U S A G E . T A S K I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 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 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Stack_Usage; + +-- This is why this package is part of GNARL: + +with System.Tasking.Debug; +with System.Task_Primitives.Operations; + +with System.IO; + +package body System.Stack_Usage.Tasking is + use System.IO; + + procedure Report_For_Task (Id : System.Tasking.Task_Id); + -- A generic procedure calculating stack usage for a given task + + procedure Compute_All_Tasks; + -- Compute the stack usage for all tasks and saves it in + -- System.Stack_Usage.Result_Array + + procedure Compute_Current_Task; + -- Compute the stack usage for a given task and saves it in the precise + -- slot in System.Stack_Usage.Result_Array; + + procedure Report_Impl (All_Tasks : Boolean; Do_Print : Boolean); + -- Report the stack usage of either all tasks (All_Tasks = True) or of the + -- current task (All_Task = False). If Print is True, then results are + -- printed on stderr + + procedure Convert + (TS : System.Stack_Usage.Task_Result; + Res : out Stack_Usage_Result); + -- Convert an object of type System.Stack_Usage in a Stack_Usage_Result + + -------------- + -- Convert -- + -------------- + + procedure Convert + (TS : System.Stack_Usage.Task_Result; + Res : out Stack_Usage_Result) is + begin + Res := TS; + end Convert; + + ---------------------- + -- Report_For_Task -- + ---------------------- + + procedure Report_For_Task (Id : System.Tasking.Task_Id) is + begin + System.Stack_Usage.Compute_Result (Id.Common.Analyzer); + System.Stack_Usage.Report_Result (Id.Common.Analyzer); + end Report_For_Task; + + ------------------------ + -- Compute_All_Tasks -- + ------------------------ + + procedure Compute_All_Tasks is + Id : System.Tasking.Task_Id; + use type System.Tasking.Task_Id; + begin + if not System.Stack_Usage.Is_Enabled then + Put ("Stack Usage not enabled: bind with -uNNN switch"); + else + + -- Loop over all tasks + + for J in System.Tasking.Debug.Known_Tasks'First + 1 + .. System.Tasking.Debug.Known_Tasks'Last + loop + Id := System.Tasking.Debug.Known_Tasks (J); + exit when Id = null; + + -- Calculate the task usage for a given task + + Report_For_Task (Id); + end loop; + + end if; + end Compute_All_Tasks; + + --------------------------- + -- Compute_Current_Task -- + --------------------------- + + procedure Compute_Current_Task is + begin + if not System.Stack_Usage.Is_Enabled then + Put ("Stack Usage not enabled: bind with -uNNN switch"); + else + + -- The current task + + Report_For_Task (System.Tasking.Self); + + end if; + end Compute_Current_Task; + + ------------------ + -- Report_Impl -- + ------------------ + + procedure Report_Impl (All_Tasks : Boolean; Do_Print : Boolean) is + begin + + -- Lock the runtime + + System.Task_Primitives.Operations.Lock_RTS; + + -- Calculate results + + if All_Tasks then + Compute_All_Tasks; + else + Compute_Current_Task; + end if; + + -- Output results + if Do_Print then + System.Stack_Usage.Output_Results; + end if; + + -- Unlock the runtime + + System.Task_Primitives.Operations.Unlock_RTS; + + end Report_Impl; + + ---------------------- + -- Report_All_Task -- + ---------------------- + + procedure Report_All_Tasks is + begin + Report_Impl (True, True); + end Report_All_Tasks; + + -------------------------- + -- Report_Current_Task -- + -------------------------- + + procedure Report_Current_Task is + Res : Stack_Usage_Result; + begin + Res := Get_Current_Task_Usage; + Print (Res); + end Report_Current_Task; + + -------------------------- + -- Get_All_Tasks_Usage -- + -------------------------- + + function Get_All_Tasks_Usage return Stack_Usage_Result_Array is + Res : Stack_Usage_Result_Array + (1 .. System.Stack_Usage.Result_Array'Length); + begin + Report_Impl (True, False); + + for J in Res'Range loop + Convert (System.Stack_Usage.Result_Array (J), Res (J)); + end loop; + + return Res; + end Get_All_Tasks_Usage; + + ----------------------------- + -- Get_Current_Task_Usage -- + ----------------------------- + + function Get_Current_Task_Usage return Stack_Usage_Result is + Res : Stack_Usage_Result; + Original : System.Stack_Usage.Task_Result; + Found : Boolean := False; + begin + + Report_Impl (False, False); + + -- Look for the task info in System.Stack_Usage.Result_Array; + -- the search is based on task name + + for T in System.Stack_Usage.Result_Array'Range loop + if System.Stack_Usage.Result_Array (T).Task_Name = + System.Tasking.Self.Common.Analyzer.Task_Name + then + Original := System.Stack_Usage.Result_Array (T); + Found := True; + exit; + end if; + end loop; + + -- Be sure a task has been found + + pragma Assert (Found); + + Convert (Original, Res); + return Res; + end Get_Current_Task_Usage; + + ------------ + -- Print -- + ------------ + + procedure Print (Obj : Stack_Usage_Result) is + Pos : Positive; + begin + + -- Simply trim the string containing the task name + + for S in Obj.Task_Name'Range loop + if Obj.Task_Name (S) = ' ' then + Pos := S; + exit; + end if; + end loop; + + declare + T_Name : constant String := Obj.Task_Name + (Obj.Task_Name'First .. Pos); + begin + Put_Line + ("| " & T_Name & " | " & Natural'Image (Obj.Max_Size) & + Natural'Image (Obj.Value) & " +/- " & + Natural'Image (Obj.Variation)); + end; + end Print; + +end System.Stack_Usage.Tasking; diff --git a/gcc/ada/s-stusta.ads b/gcc/ada/s-stusta.ads new file mode 100644 index 000000000..67952b103 --- /dev/null +++ b/gcc/ada/s-stusta.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T A C K _ U S A G E . T A S K I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 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 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides exported subprograms to be called at debug time to +-- measure stack usage at run-time. + +-- Note: this package must be a child package of System.Stack_Usage to have +-- visibility over its private part; it is however part of GNARL because it +-- needs to access tasking features via System.Tasking.Debug and +-- System.Task_Primitives.Operations; + +package System.Stack_Usage.Tasking is + + procedure Report_All_Tasks; + -- Print the current stack usage of all tasks on stderr. Exported to be + -- called also in debug mode. + + pragma Export + (C, + Report_All_Tasks, + "__gnat_tasks_stack_usage_report_all_tasks"); + + procedure Report_Current_Task; + -- Print the stack usage of current task on stderr. Exported to be called + -- also in debug mode. + + pragma Export + (C, + Report_Current_Task, + "__gnat_tasks_stack_usage_report_current_task"); + + subtype Stack_Usage_Result is System.Stack_Usage.Task_Result; + -- This type is a descriptor for task stack usage result + + type Stack_Usage_Result_Array is + array (Positive range <>) of Stack_Usage_Result; + + function Get_Current_Task_Usage return Stack_Usage_Result; + -- Return the current stack usage for the invoking task + + function Get_All_Tasks_Usage return Stack_Usage_Result_Array; + -- Return an array containing the stack usage results for all tasks + + procedure Print (Obj : Stack_Usage_Result); + -- Print Obj on stderr + +end System.Stack_Usage.Tasking; diff --git a/gcc/ada/s-taasde.adb b/gcc/ada/s-taasde.adb new file mode 100644 index 000000000..315d9ba13 --- /dev/null +++ b/gcc/ada/s-taasde.adb @@ -0,0 +1,412 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with Ada.Unchecked_Conversion; +with Ada.Task_Identification; + +with System.Task_Primitives.Operations; +with System.Tasking.Utilities; +with System.Tasking.Initialization; +with System.Tasking.Debug; +with System.OS_Primitives; +with System.Interrupt_Management.Operations; +with System.Parameters; +with System.Traces.Tasking; + +package body System.Tasking.Async_Delays is + + package STPO renames System.Task_Primitives.Operations; + package ST renames System.Tasking; + package STU renames System.Tasking.Utilities; + package STI renames System.Tasking.Initialization; + package OSP renames System.OS_Primitives; + + use Parameters; + use System.Traces; + use System.Traces.Tasking; + + function To_System is new Ada.Unchecked_Conversion + (Ada.Task_Identification.Task_Id, Task_Id); + + Timer_Server_ID : ST.Task_Id; + + Timer_Attention : Boolean := False; + pragma Atomic (Timer_Attention); + + task Timer_Server is + pragma Interrupt_Priority (System.Any_Priority'Last); + end Timer_Server; + + -- The timer queue is a circular doubly linked list, ordered by absolute + -- wakeup time. The first item in the queue is Timer_Queue.Succ. + -- It is given a Resume_Time that is larger than any legitimate wakeup + -- time, so that the ordered insertion will always stop searching when it + -- gets back to the queue header block. + + Timer_Queue : aliased Delay_Block; + + ------------------------ + -- Cancel_Async_Delay -- + ------------------------ + + -- This should (only) be called from the compiler-generated cleanup routine + -- for an async. select statement with delay statement as trigger. The + -- effect should be to remove the delay from the timer queue, and exit one + -- ATC nesting level. + -- The usage and logic are similar to Cancel_Protected_Entry_Call, but + -- simplified because this is not a true entry call. + + procedure Cancel_Async_Delay (D : Delay_Block_Access) is + Dpred : Delay_Block_Access; + Dsucc : Delay_Block_Access; + + begin + -- Note that we mark the delay as being cancelled + -- using a level value that is reserved. + + -- make this operation idempotent + + if D.Level = ATC_Level_Infinity then + return; + end if; + + D.Level := ATC_Level_Infinity; + + -- remove self from timer queue + + STI.Defer_Abort_Nestable (D.Self_Id); + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Timer_Server_ID); + Dpred := D.Pred; + Dsucc := D.Succ; + Dpred.Succ := Dsucc; + Dsucc.Pred := Dpred; + D.Succ := D; + D.Pred := D; + STPO.Unlock (Timer_Server_ID); + + -- Note that the above deletion code is required to be + -- idempotent, since the block may have been dequeued + -- previously by the Timer_Server. + + -- leave the asynchronous select + + STPO.Write_Lock (D.Self_Id); + STU.Exit_One_ATC_Level (D.Self_Id); + STPO.Unlock (D.Self_Id); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + STI.Undefer_Abort_Nestable (D.Self_Id); + end Cancel_Async_Delay; + + --------------------------- + -- Enqueue_Time_Duration -- + --------------------------- + + function Enqueue_Duration + (T : Duration; + D : Delay_Block_Access) return Boolean + is + begin + if T <= 0.0 then + D.Timed_Out := True; + STPO.Yield; + return False; + + else + -- The corresponding call to Undefer_Abort is performed by the + -- expanded code (see exp_ch9). + + STI.Defer_Abort (STPO.Self); + Time_Enqueue + (STPO.Monotonic_Clock + + Duration'Min (T, OSP.Max_Sensible_Delay), D); + return True; + end if; + end Enqueue_Duration; + + ------------------ + -- Time_Enqueue -- + ------------------ + + -- Allocate a queue element for the wakeup time T and put it in the + -- queue in wakeup time order. Assume we are on an asynchronous + -- select statement with delay trigger. Put the calling task to + -- sleep until either the delay expires or is cancelled. + + -- We use one entry call record for this delay, since we have + -- to increment the ATC nesting level, but since it is not a + -- real entry call we do not need to use any of the fields of + -- the call record. The following code implements a subset of + -- the actions for the asynchronous case of Protected_Entry_Call, + -- much simplified since we know this never blocks, and does not + -- have the full semantics of a protected entry call. + + procedure Time_Enqueue + (T : Duration; + D : Delay_Block_Access) + is + Self_Id : constant Task_Id := STPO.Self; + Q : Delay_Block_Access; + + use type ST.Task_Id; + -- for visibility of operator "=" + + begin + pragma Debug (Debug.Trace (Self_Id, "Async_Delay", 'P')); + pragma Assert (Self_Id.Deferral_Level = 1, + "async delay from within abort-deferred region"); + + if Self_Id.ATC_Nesting_Level = ATC_Level'Last then + raise Storage_Error with "not enough ATC nesting levels"; + end if; + + Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; + + pragma Debug + (Debug.Trace (Self_Id, "ASD: entered ATC level: " & + ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + + D.Level := Self_Id.ATC_Nesting_Level; + D.Self_Id := Self_Id; + D.Resume_Time := T; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Timer_Server_ID); + + -- Previously, there was code here to dynamically create + -- the Timer_Server task, if one did not already exist. + -- That code had a timing window that could allow multiple + -- timer servers to be created. Luckily, the need for + -- postponing creation of the timer server should now be + -- gone, since this package will only be linked in if + -- there are calls to enqueue calls on the timer server. + + -- Insert D in the timer queue, at the position determined + -- by the wakeup time T. + + Q := Timer_Queue.Succ; + + while Q.Resume_Time < T loop + Q := Q.Succ; + end loop; + + -- Q is the block that has Resume_Time equal to or greater than + -- T. After the insertion we want Q to be the successor of D. + + D.Succ := Q; + D.Pred := Q.Pred; + D.Pred.Succ := D; + Q.Pred := D; + + -- If the new element became the head of the queue, + -- signal the Timer_Server to wake up. + + if Timer_Queue.Succ = D then + Timer_Attention := True; + STPO.Wakeup (Timer_Server_ID, ST.Timer_Server_Sleep); + end if; + + STPO.Unlock (Timer_Server_ID); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + end Time_Enqueue; + + --------------- + -- Timed_Out -- + --------------- + + function Timed_Out (D : Delay_Block_Access) return Boolean is + begin + return D.Timed_Out; + end Timed_Out; + + ------------------ + -- Timer_Server -- + ------------------ + + task body Timer_Server is + function Get_Next_Wakeup_Time return Duration; + -- Used to initialize Next_Wakeup_Time, but also to ensure that + -- Make_Independent is called during the elaboration of this task. + + -------------------------- + -- Get_Next_Wakeup_Time -- + -------------------------- + + function Get_Next_Wakeup_Time return Duration is + begin + STU.Make_Independent; + return Duration'Last; + end Get_Next_Wakeup_Time; + + -- Local Declarations + + Next_Wakeup_Time : Duration := Get_Next_Wakeup_Time; + Timedout : Boolean; + Yielded : Boolean; + Now : Duration; + Dequeued : Delay_Block_Access; + Dequeued_Task : Task_Id; + + pragma Unreferenced (Timedout, Yielded); + + begin + Timer_Server_ID := STPO.Self; + + -- Since this package may be elaborated before System.Interrupt, + -- we need to call Setup_Interrupt_Mask explicitly to ensure that + -- this task has the proper signal mask. + + Interrupt_Management.Operations.Setup_Interrupt_Mask; + + -- Initialize the timer queue to empty, and make the wakeup time of the + -- header node be larger than any real wakeup time we will ever use. + + loop + STI.Defer_Abort (Timer_Server_ID); + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Timer_Server_ID); + + -- The timer server needs to catch pending aborts after finalization + -- of library packages. If it doesn't poll for it, the server will + -- sometimes hang. + + if not Timer_Attention then + Timer_Server_ID.Common.State := ST.Timer_Server_Sleep; + + if Next_Wakeup_Time = Duration'Last then + Timer_Server_ID.User_State := 1; + Next_Wakeup_Time := + STPO.Monotonic_Clock + OSP.Max_Sensible_Delay; + + else + Timer_Server_ID.User_State := 2; + end if; + + STPO.Timed_Sleep + (Timer_Server_ID, Next_Wakeup_Time, + OSP.Absolute_RT, ST.Timer_Server_Sleep, + Timedout, Yielded); + Timer_Server_ID.Common.State := ST.Runnable; + end if; + + -- Service all of the wakeup requests on the queue whose times have + -- been reached, and update Next_Wakeup_Time to next wakeup time + -- after that (the wakeup time of the head of the queue if any, else + -- a time far in the future). + + Timer_Server_ID.User_State := 3; + Timer_Attention := False; + + Now := STPO.Monotonic_Clock; + while Timer_Queue.Succ.Resume_Time <= Now loop + + -- Dequeue the waiting task from the front of the queue + + pragma Debug (System.Tasking.Debug.Trace + (Timer_Server_ID, "Timer service: waking up waiting task", 'E')); + + Dequeued := Timer_Queue.Succ; + Timer_Queue.Succ := Dequeued.Succ; + Dequeued.Succ.Pred := Dequeued.Pred; + Dequeued.Succ := Dequeued; + Dequeued.Pred := Dequeued; + + -- We want to abort the queued task to the level of the async. + -- select statement with the delay. To do that, we need to lock + -- the ATCB of that task, but to avoid deadlock we need to release + -- the lock of the Timer_Server. This leaves a window in which + -- another task might perform an enqueue or dequeue operation on + -- the timer queue, but that is OK because we always restart the + -- next iteration at the head of the queue. + + if Parameters.Runtime_Traces then + Send_Trace_Info (E_Kill, Dequeued.Self_Id); + end if; + + STPO.Unlock (Timer_Server_ID); + STPO.Write_Lock (Dequeued.Self_Id); + Dequeued_Task := Dequeued.Self_Id; + Dequeued.Timed_Out := True; + STI.Locked_Abort_To_Level + (Timer_Server_ID, Dequeued_Task, Dequeued.Level - 1); + STPO.Unlock (Dequeued_Task); + STPO.Write_Lock (Timer_Server_ID); + end loop; + + Next_Wakeup_Time := Timer_Queue.Succ.Resume_Time; + + -- Service returns the Next_Wakeup_Time. + -- The Next_Wakeup_Time is either an infinity (no delay request) + -- or the wakeup time of the queue head. This value is used for + -- an actual delay in this server. + + STPO.Unlock (Timer_Server_ID); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + STI.Undefer_Abort (Timer_Server_ID); + end loop; + end Timer_Server; + + ------------------------------ + -- Package Body Elaboration -- + ------------------------------ + +begin + Timer_Queue.Succ := Timer_Queue'Access; + Timer_Queue.Pred := Timer_Queue'Access; + Timer_Queue.Resume_Time := Duration'Last; + Timer_Server_ID := To_System (Timer_Server'Identity); +end System.Tasking.Async_Delays; diff --git a/gcc/ada/s-taasde.ads b/gcc/ada/s-taasde.ads new file mode 100644 index 000000000..97a93b9ad --- /dev/null +++ b/gcc/ada/s-taasde.ads @@ -0,0 +1,149 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-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 contains the procedures to implements timeouts (delays) for +-- asynchronous select statements. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +package System.Tasking.Async_Delays is + + -- Suppose the following source code is given: + + -- select delay When; + -- ...continuation for timeout case... + -- then abort + -- ...abortable part... + -- end select; + + -- The compiler should expand this to the following: + + -- declare + -- DB : aliased Delay_Block; + -- begin + -- if System.Tasking.Async_Delays.Enqueue_Duration + -- (When, DB'Unchecked_Access) + -- then + -- begin + -- A101b : declare + -- procedure _clean is + -- begin + -- System.Tasking.Async_Delays.Cancel_Async_Delay + -- (DB'Unchecked_Access); + -- return; + -- end _clean; + -- begin + -- abort_undefer.all; + -- ...abortable part... + -- exception + -- when all others => + -- declare + -- E105b : exception_occurrence; + -- begin + -- save_occurrence (E105b, get_current_excep.all.all); + -- _clean; + -- reraise_occurrence_no_defer (E105b); + -- end; + -- at end + -- _clean; + -- end A101b; + -- exception + -- when _abort_signal => + -- abort_undefer.all; + -- end; + -- end if; + -- + -- if Timed_Out (DB'Unchecked_Access) then + -- ...continuation for timeout case... + -- end if; + -- end; + + ----------------- + -- Delay_Block -- + ----------------- + + type Delay_Block is limited private; + type Delay_Block_Access is access all Delay_Block; + + function Enqueue_Duration + (T : Duration; + D : Delay_Block_Access) return Boolean; + -- Enqueue the specified relative delay. Returns True if the delay has + -- been enqueued, False if it has already expired. If the delay has been + -- enqueued, abort is deferred. + + procedure Cancel_Async_Delay (D : Delay_Block_Access); + -- Cancel the specified asynchronous delay + + function Timed_Out (D : Delay_Block_Access) return Boolean; + pragma Inline (Timed_Out); + -- Return True if the delay specified in D has timed out + + -- There are child units for delays on Ada.Calendar.Time and + -- Ada.Real_Time.Time, so that an application will not need to link in + -- features that is not using. + +private + + type Delay_Block is record + Self_Id : Task_Id; + -- ID of the calling task + + Level : ATC_Level_Base; + -- Normally Level is the ATC nesting level of the + -- async. select statement to which this delay belongs, but + -- after a call has been dequeued we set it to + -- ATC_Level_Infinity so that the Cancel operation can + -- detect repeated calls, and act idempotently. + + Resume_Time : Duration; + -- The absolute wake up time, represented as Duration + + Timed_Out : Boolean := False; + -- Set to true if the delay has timed out + + Succ, Pred : Delay_Block_Access; + -- A double linked list + end record; + + -- The above "overlaying" of Self_ID and Level to hold other + -- data that has a non-overlapping lifetime is an unabashed + -- hack to save memory. + + procedure Time_Enqueue + (T : Duration; + D : Delay_Block_Access); + pragma Inline (Time_Enqueue); + -- Used by the child units to enqueue delays on the timer queue + -- implemented in the body of this package. + +end System.Tasking.Async_Delays; diff --git a/gcc/ada/s-tadeca.adb b/gcc/ada/s-tadeca.adb new file mode 100644 index 000000000..774407281 --- /dev/null +++ b/gcc/ada/s-tadeca.adb @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASKING.ASYNC_DELAYS.ENQUEUE_CALENDAR -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Calendar.Delays; +with System.Task_Primitives.Operations; +with System.Tasking.Initialization; + +function System.Tasking.Async_Delays.Enqueue_Calendar + (T : Ada.Calendar.Time; + D : Delay_Block_Access) + return Boolean +is + use type Ada.Calendar.Time; +begin + if T <= Ada.Calendar.Clock then + D.Timed_Out := True; + System.Task_Primitives.Operations.Yield; + return False; + end if; + + System.Tasking.Initialization.Defer_Abort + (System.Task_Primitives.Operations.Self); + Time_Enqueue (Ada.Calendar.Delays.To_Duration (T), D); + return True; +end System.Tasking.Async_Delays.Enqueue_Calendar; diff --git a/gcc/ada/s-tadeca.ads b/gcc/ada/s-tadeca.ads new file mode 100644 index 000000000..81bd4e18a --- /dev/null +++ b/gcc/ada/s-tadeca.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASKING.ASYNC_DELAYS.ENQUEUE_CALENDAR -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-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. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +-- See comments in package System.Tasking.Async_Delays + +with Ada.Calendar; +function System.Tasking.Async_Delays.Enqueue_Calendar + (T : Ada.Calendar.Time; + D : Delay_Block_Access) + return Boolean; diff --git a/gcc/ada/s-tadert.adb b/gcc/ada/s-tadert.adb new file mode 100644 index 000000000..241523baf --- /dev/null +++ b/gcc/ada/s-tadert.adb @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASKING.ASYNC_DELAYS.ENQUEUE_RT -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Real_Time; +with Ada.Real_Time.Delays; +with System.Task_Primitives.Operations; +with System.Tasking.Initialization; + +function System.Tasking.Async_Delays.Enqueue_RT + (T : Ada.Real_Time.Time; + D : Delay_Block_Access) return Boolean +is + use type Ada.Real_Time.Time; -- for "=" operator +begin + if T <= Ada.Real_Time.Clock then + D.Timed_Out := True; + System.Task_Primitives.Operations.Yield; + return False; + end if; + + System.Tasking.Initialization.Defer_Abort + (System.Task_Primitives.Operations.Self); + Time_Enqueue (Ada.Real_Time.Delays.To_Duration (T), D); + return True; +end System.Tasking.Async_Delays.Enqueue_RT; diff --git a/gcc/ada/s-tadert.ads b/gcc/ada/s-tadert.ads new file mode 100644 index 000000000..da8fafbd8 --- /dev/null +++ b/gcc/ada/s-tadert.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASKING.ASYNC_DELAYS.ENQUEUE_RT -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-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. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +-- See comments in package System.Tasking.Async_Delays + +with Ada.Real_Time; +function System.Tasking.Async_Delays.Enqueue_RT + (T : Ada.Real_Time.Time; + D : Delay_Block_Access) + return Boolean; diff --git a/gcc/ada/s-taenca.adb b/gcc/ada/s-taenca.adb new file mode 100644 index 000000000..14812a446 --- /dev/null +++ b/gcc/ada/s-taenca.adb @@ -0,0 +1,666 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . E N T R Y _ C A L L S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, 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.Task_Primitives.Operations; +with System.Tasking.Initialization; +with System.Tasking.Protected_Objects.Entries; +with System.Tasking.Protected_Objects.Operations; +with System.Tasking.Queuing; +with System.Tasking.Utilities; +with System.Parameters; +with System.Traces; + +package body System.Tasking.Entry_Calls is + + package STPO renames System.Task_Primitives.Operations; + + use Parameters; + use Task_Primitives; + use Protected_Objects.Entries; + use Protected_Objects.Operations; + use System.Traces; + + -- DO NOT use Protected_Objects.Lock or Protected_Objects.Unlock + -- internally. Those operations will raise Program_Error, which + -- we are not prepared to handle inside the RTS. Instead, use + -- System.Task_Primitives lock operations directly on Protection.L. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Lock_Server (Entry_Call : Entry_Call_Link); + + -- This locks the server targeted by Entry_Call + -- + -- This may be a task or a protected object, depending on the target of the + -- original call or any subsequent requeues. + -- + -- This routine is needed because the field specifying the server for this + -- call must be protected by the server's mutex. If it were protected by + -- the caller's mutex, accessing the server's queues would require locking + -- the caller to get the server, locking the server, and then accessing the + -- queues. This involves holding two ATCB locks at once, something which we + -- can guarantee that it will always be done in the same order, or locking + -- a protected object while we hold an ATCB lock, something which is not + -- permitted. Since the server cannot be obtained reliably, it must be + -- obtained unreliably and then checked again once it has been locked. + -- + -- If Single_Lock and server is a PO, release RTS_Lock + -- + -- This should only be called by the Entry_Call.Self. + -- It should be holding no other ATCB locks at the time. + + procedure Unlock_Server (Entry_Call : Entry_Call_Link); + -- STPO.Unlock the server targeted by Entry_Call. The server must + -- be locked before calling this. + -- + -- If Single_Lock and server is a PO, take RTS_Lock on exit. + + procedure Unlock_And_Update_Server + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link); + -- Similar to Unlock_Server, but services entry calls if the + -- server is a protected object. + -- + -- If Single_Lock and server is a PO, take RTS_Lock on exit. + + procedure Check_Pending_Actions_For_Entry_Call + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link); + -- This procedure performs priority change of a queued call and dequeuing + -- of an entry call when the call is cancelled. If the call is dequeued the + -- state should be set to Cancelled. Call only with abort deferred and + -- holding lock of Self_ID. This is a bit of common code for all entry + -- calls. The effect is to do any deferred base priority change operation, + -- in case some other task called STPO.Set_Priority while the current task + -- had abort deferred, and to dequeue the call if the call has been + -- aborted. + + procedure Poll_Base_Priority_Change_At_Entry_Call + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link); + pragma Inline (Poll_Base_Priority_Change_At_Entry_Call); + -- A specialized version of Poll_Base_Priority_Change, that does the + -- optional entry queue reordering. Has to be called with the Self_ID's + -- ATCB write-locked. May temporarily release the lock. + + --------------------- + -- Check_Exception -- + --------------------- + + procedure Check_Exception + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link) + is + pragma Warnings (Off, Self_ID); + + use type Ada.Exceptions.Exception_Id; + + procedure Internal_Raise (X : Ada.Exceptions.Exception_Id); + pragma Import (C, Internal_Raise, "__gnat_raise_with_msg"); + + E : constant Ada.Exceptions.Exception_Id := + Entry_Call.Exception_To_Raise; + begin + -- pragma Assert (Self_ID.Deferral_Level = 0); + + -- The above may be useful for debugging, but the Florist packages + -- contain critical sections that defer abort and then do entry calls, + -- which causes the above Assert to trip. + + if E /= Ada.Exceptions.Null_Id then + Internal_Raise (E); + end if; + end Check_Exception; + + ------------------------------------------ + -- Check_Pending_Actions_For_Entry_Call -- + ------------------------------------------ + + procedure Check_Pending_Actions_For_Entry_Call + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link) + is + begin + pragma Assert (Self_ID = Entry_Call.Self); + + Poll_Base_Priority_Change_At_Entry_Call (Self_ID, Entry_Call); + + if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + and then Entry_Call.State = Now_Abortable + then + STPO.Unlock (Self_ID); + Lock_Server (Entry_Call); + + if Queuing.Onqueue (Entry_Call) + and then Entry_Call.State = Now_Abortable + then + Queuing.Dequeue_Call (Entry_Call); + Entry_Call.State := + (if Entry_Call.Cancellation_Attempted then Cancelled else Done); + Unlock_And_Update_Server (Self_ID, Entry_Call); + + else + Unlock_Server (Entry_Call); + end if; + + STPO.Write_Lock (Self_ID); + end if; + end Check_Pending_Actions_For_Entry_Call; + + ----------------- + -- Lock_Server -- + ----------------- + + procedure Lock_Server (Entry_Call : Entry_Call_Link) is + Test_Task : Task_Id; + Test_PO : Protection_Entries_Access; + Ceiling_Violation : Boolean; + Failures : Integer := 0; + + begin + Test_Task := Entry_Call.Called_Task; + + loop + if Test_Task = null then + + -- Entry_Call was queued on a protected object, or in transition, + -- when we last fetched Test_Task. + + Test_PO := To_Protection (Entry_Call.Called_PO); + + if Test_PO = null then + + -- We had very bad luck, interleaving with TWO different + -- requeue operations. Go around the loop and try again. + + if Single_Lock then + STPO.Unlock_RTS; + STPO.Yield; + STPO.Lock_RTS; + else + STPO.Yield; + end if; + + else + if Single_Lock then + STPO.Unlock_RTS; + end if; + + Lock_Entries (Test_PO, Ceiling_Violation); + + -- ??? + + -- The following code allows Lock_Server to be called when + -- cancelling a call, to allow for the possibility that the + -- priority of the caller has been raised beyond that of the + -- protected entry call by Ada.Dynamic_Priorities.Set_Priority. + + -- If the current task has a higher priority than the ceiling + -- of the protected object, temporarily lower it. It will + -- be reset in Unlock. + + if Ceiling_Violation then + declare + Current_Task : constant Task_Id := STPO.Self; + Old_Base_Priority : System.Any_Priority; + + begin + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Current_Task); + Old_Base_Priority := Current_Task.Common.Base_Priority; + Current_Task.New_Base_Priority := Test_PO.Ceiling; + System.Tasking.Initialization.Change_Base_Priority + (Current_Task); + STPO.Unlock (Current_Task); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + -- Following lock should not fail + + Lock_Entries (Test_PO); + + Test_PO.Old_Base_Priority := Old_Base_Priority; + Test_PO.Pending_Action := True; + end; + end if; + + exit when To_Address (Test_PO) = Entry_Call.Called_PO; + Unlock_Entries (Test_PO); + + if Single_Lock then + STPO.Lock_RTS; + end if; + end if; + + else + STPO.Write_Lock (Test_Task); + exit when Test_Task = Entry_Call.Called_Task; + STPO.Unlock (Test_Task); + end if; + + Test_Task := Entry_Call.Called_Task; + Failures := Failures + 1; + pragma Assert (Failures <= 5); + end loop; + end Lock_Server; + + --------------------------------------------- + -- Poll_Base_Priority_Change_At_Entry_Call -- + --------------------------------------------- + + procedure Poll_Base_Priority_Change_At_Entry_Call + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link) + is + begin + if Self_ID.Pending_Priority_Change then + + -- Check for ceiling violations ??? + + Self_ID.Pending_Priority_Change := False; + + -- Requeue the entry call at the new priority. We need to requeue + -- even if the new priority is the same than the previous (see ACATS + -- test cxd4006). + + STPO.Unlock (Self_ID); + Lock_Server (Entry_Call); + Queuing.Requeue_Call_With_New_Prio + (Entry_Call, STPO.Get_Priority (Self_ID)); + Unlock_And_Update_Server (Self_ID, Entry_Call); + STPO.Write_Lock (Self_ID); + end if; + end Poll_Base_Priority_Change_At_Entry_Call; + + -------------------- + -- Reset_Priority -- + -------------------- + + procedure Reset_Priority + (Acceptor : Task_Id; + Acceptor_Prev_Priority : Rendezvous_Priority) + is + begin + pragma Assert (Acceptor = STPO.Self); + + -- Since we limit this kind of "active" priority change to be done + -- by the task for itself, we don't need to lock Acceptor. + + if Acceptor_Prev_Priority /= Priority_Not_Boosted then + STPO.Set_Priority (Acceptor, Acceptor_Prev_Priority, + Loss_Of_Inheritance => True); + end if; + end Reset_Priority; + + ------------------------------ + -- Try_To_Cancel_Entry_Call -- + ------------------------------ + + procedure Try_To_Cancel_Entry_Call (Succeeded : out Boolean) is + Entry_Call : Entry_Call_Link; + Self_ID : constant Task_Id := STPO.Self; + + use type Ada.Exceptions.Exception_Id; + + begin + Entry_Call := Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access; + + -- Experimentation has shown that abort is sometimes (but not + -- always) already deferred when Cancel_xxx_Entry_Call is called. + -- That may indicate an error. Find out what is going on. ??? + + pragma Assert (Entry_Call.Mode = Asynchronous_Call); + Initialization.Defer_Abort_Nestable (Self_ID); + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Self_ID); + Entry_Call.Cancellation_Attempted := True; + + if Self_ID.Pending_ATC_Level >= Entry_Call.Level then + Self_ID.Pending_ATC_Level := Entry_Call.Level - 1; + end if; + + Entry_Calls.Wait_For_Completion (Entry_Call); + STPO.Unlock (Self_ID); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + Succeeded := Entry_Call.State = Cancelled; + + Initialization.Undefer_Abort_Nestable (Self_ID); + + -- Ideally, abort should no longer be deferred at this point, so we + -- should be able to call Check_Exception. The loop below should be + -- considered temporary, to work around the possibility that abort + -- may be deferred more than one level deep ??? + + if Entry_Call.Exception_To_Raise /= Ada.Exceptions.Null_Id then + while Self_ID.Deferral_Level > 0 loop + System.Tasking.Initialization.Undefer_Abort_Nestable (Self_ID); + end loop; + + Entry_Calls.Check_Exception (Self_ID, Entry_Call); + end if; + end Try_To_Cancel_Entry_Call; + + ------------------------------ + -- Unlock_And_Update_Server -- + ------------------------------ + + procedure Unlock_And_Update_Server + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link) + is + Called_PO : Protection_Entries_Access; + Caller : Task_Id; + + begin + if Entry_Call.Called_Task /= null then + STPO.Unlock (Entry_Call.Called_Task); + else + Called_PO := To_Protection (Entry_Call.Called_PO); + PO_Service_Entries (Self_ID, Called_PO, False); + + if Called_PO.Pending_Action then + Called_PO.Pending_Action := False; + Caller := STPO.Self; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Caller); + Caller.New_Base_Priority := Called_PO.Old_Base_Priority; + Initialization.Change_Base_Priority (Caller); + STPO.Unlock (Caller); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + end if; + + Unlock_Entries (Called_PO); + + if Single_Lock then + STPO.Lock_RTS; + end if; + end if; + end Unlock_And_Update_Server; + + ------------------- + -- Unlock_Server -- + ------------------- + + procedure Unlock_Server (Entry_Call : Entry_Call_Link) is + Caller : Task_Id; + Called_PO : Protection_Entries_Access; + + begin + if Entry_Call.Called_Task /= null then + STPO.Unlock (Entry_Call.Called_Task); + else + Called_PO := To_Protection (Entry_Call.Called_PO); + + if Called_PO.Pending_Action then + Called_PO.Pending_Action := False; + Caller := STPO.Self; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Caller); + Caller.New_Base_Priority := Called_PO.Old_Base_Priority; + Initialization.Change_Base_Priority (Caller); + STPO.Unlock (Caller); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + end if; + + Unlock_Entries (Called_PO); + + if Single_Lock then + STPO.Lock_RTS; + end if; + end if; + end Unlock_Server; + + ------------------------- + -- Wait_For_Completion -- + ------------------------- + + procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is + Self_Id : constant Task_Id := Entry_Call.Self; + + begin + -- If this is a conditional call, it should be cancelled when it + -- becomes abortable. This is checked in the loop below. + + if Parameters.Runtime_Traces then + Send_Trace_Info (W_Completion); + end if; + + Self_Id.Common.State := Entry_Caller_Sleep; + + -- Try to remove calls to Sleep in the loop below by letting the caller + -- a chance of getting ready immediately, using Unlock & Yield. + -- See similar action in Wait_For_Call & Timed_Selective_Wait. + + if Single_Lock then + STPO.Unlock_RTS; + else + STPO.Unlock (Self_Id); + end if; + + if Entry_Call.State < Done then + STPO.Yield; + end if; + + if Single_Lock then + STPO.Lock_RTS; + else + STPO.Write_Lock (Self_Id); + end if; + + loop + Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call); + + exit when Entry_Call.State >= Done; + + STPO.Sleep (Self_Id, Entry_Caller_Sleep); + end loop; + + Self_Id.Common.State := Runnable; + Utilities.Exit_One_ATC_Level (Self_Id); + + if Parameters.Runtime_Traces then + Send_Trace_Info (M_Call_Complete); + end if; + end Wait_For_Completion; + + -------------------------------------- + -- Wait_For_Completion_With_Timeout -- + -------------------------------------- + + procedure Wait_For_Completion_With_Timeout + (Entry_Call : Entry_Call_Link; + Wakeup_Time : Duration; + Mode : Delay_Modes; + Yielded : out Boolean) + is + Self_Id : constant Task_Id := Entry_Call.Self; + Timedout : Boolean := False; + + use type Ada.Exceptions.Exception_Id; + + begin + -- This procedure waits for the entry call to be served, with a timeout. + -- It tries to cancel the call if the timeout expires before the call is + -- served. + + -- If we wake up from the timed sleep operation here, it may be for + -- several possible reasons: + + -- 1) The entry call is done being served. + -- 2) There is an abort or priority change to be served. + -- 3) The timeout has expired (Timedout = True) + -- 4) There has been a spurious wakeup. + + -- Once the timeout has expired we may need to continue to wait if the + -- call is already being serviced. In that case, we want to go back to + -- sleep, but without any timeout. The variable Timedout is used to + -- control this. If the Timedout flag is set, we do not need to + -- STPO.Sleep with a timeout. We just sleep until we get a wakeup for + -- some status change. + + -- The original call may have become abortable after waking up. We want + -- to check Check_Pending_Actions_For_Entry_Call again in any case. + + pragma Assert (Entry_Call.Mode = Timed_Call); + + Yielded := False; + Self_Id.Common.State := Entry_Caller_Sleep; + + -- Looping is necessary in case the task wakes up early from the timed + -- sleep, due to a "spurious wakeup". Spurious wakeups are a weakness of + -- POSIX condition variables. A thread waiting for a condition variable + -- is allowed to wake up at any time, not just when the condition is + -- signaled. See same loop in the ordinary Wait_For_Completion, above. + + if Parameters.Runtime_Traces then + Send_Trace_Info (WT_Completion, Wakeup_Time); + end if; + + loop + Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call); + exit when Entry_Call.State >= Done; + + STPO.Timed_Sleep (Self_Id, Wakeup_Time, Mode, + Entry_Caller_Sleep, Timedout, Yielded); + + if Timedout then + if Parameters.Runtime_Traces then + Send_Trace_Info (E_Timeout); + end if; + + -- Try to cancel the call (see Try_To_Cancel_Entry_Call for + -- corresponding code in the ATC case). + + Entry_Call.Cancellation_Attempted := True; + + -- Reset Entry_Call.State so that the call is marked as cancelled + -- by Check_Pending_Actions_For_Entry_Call below. + + if Entry_Call.State < Was_Abortable then + Entry_Call.State := Now_Abortable; + end if; + + if Self_Id.Pending_ATC_Level >= Entry_Call.Level then + Self_Id.Pending_ATC_Level := Entry_Call.Level - 1; + end if; + + -- The following loop is the same as the loop and exit code + -- from the ordinary Wait_For_Completion. If we get here, we + -- have timed out but we need to keep waiting until the call + -- has actually completed or been cancelled successfully. + + loop + Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call); + exit when Entry_Call.State >= Done; + STPO.Sleep (Self_Id, Entry_Caller_Sleep); + end loop; + + Self_Id.Common.State := Runnable; + Utilities.Exit_One_ATC_Level (Self_Id); + + return; + end if; + end loop; + + -- This last part is the same as ordinary Wait_For_Completion, + -- and is only executed if the call completed without timing out. + + if Parameters.Runtime_Traces then + Send_Trace_Info (M_Call_Complete); + end if; + + Self_Id.Common.State := Runnable; + Utilities.Exit_One_ATC_Level (Self_Id); + end Wait_For_Completion_With_Timeout; + + -------------------------- + -- Wait_Until_Abortable -- + -------------------------- + + procedure Wait_Until_Abortable + (Self_ID : Task_Id; + Call : Entry_Call_Link) + is + begin + pragma Assert (Self_ID.ATC_Nesting_Level > 0); + pragma Assert (Call.Mode = Asynchronous_Call); + + if Parameters.Runtime_Traces then + Send_Trace_Info (W_Completion); + end if; + + STPO.Write_Lock (Self_ID); + Self_ID.Common.State := Entry_Caller_Sleep; + + loop + Check_Pending_Actions_For_Entry_Call (Self_ID, Call); + exit when Call.State >= Was_Abortable; + STPO.Sleep (Self_ID, Async_Select_Sleep); + end loop; + + Self_ID.Common.State := Runnable; + STPO.Unlock (Self_ID); + + if Parameters.Runtime_Traces then + Send_Trace_Info (M_Call_Complete); + end if; + end Wait_Until_Abortable; + +end System.Tasking.Entry_Calls; diff --git a/gcc/ada/s-taenca.ads b/gcc/ada/s-taenca.ads new file mode 100644 index 000000000..6c8d66f57 --- /dev/null +++ b/gcc/ada/s-taenca.ads @@ -0,0 +1,97 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . E N T R Y _ C A L L S -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides internal RTS calls implementing operations +-- that apply to general entry calls, that is, calls to either +-- protected or task entries. + +-- These declarations are not part of the GNARL Interface + +package System.Tasking.Entry_Calls is + + procedure Wait_For_Completion (Entry_Call : Entry_Call_Link); + -- This procedure suspends the calling task until the specified entry + -- call has either been completed or cancelled. It performs other + -- operations required of suspended tasks, such as performing + -- dynamic priority changes. On exit, the call will not be queued. + -- This waits for calls on task or protected entries. + -- Abortion must be deferred when calling this procedure. + -- Call this only when holding Self (= Entry_Call.Self) or global RTS lock. + + procedure Wait_For_Completion_With_Timeout + (Entry_Call : Entry_Call_Link; + Wakeup_Time : Duration; + Mode : Delay_Modes; + Yielded : out Boolean); + -- Same as Wait_For_Completion but wait for a timeout with the value + -- specified in Wakeup_Time as well. + -- On return, Yielded indicates whether the wait has performed a yield. + -- Check_Exception must be called after calling this procedure. + + procedure Wait_Until_Abortable + (Self_ID : Task_Id; + Call : Entry_Call_Link); + -- This procedure suspends the calling task until the specified entry + -- call is queued abortably or completes. + -- Abortion must be deferred when calling this procedure, and the global + -- RTS lock taken when Single_Lock. + + procedure Try_To_Cancel_Entry_Call (Succeeded : out Boolean); + pragma Inline (Try_To_Cancel_Entry_Call); + -- Try to cancel async. entry call. + -- Effect includes Abort_To_Level and Wait_For_Completion. + -- Cancelled = True iff the cancellation was successful, i.e., + -- the call was not Done before this call. + -- On return, the call is off-queue and the ATC level is reduced by one. + + procedure Reset_Priority + (Acceptor : Task_Id; + Acceptor_Prev_Priority : Rendezvous_Priority); + pragma Inline (Reset_Priority); + -- Reset the priority of a task completing an accept statement to + -- the value it had before the call. + -- Acceptor should always be equal to Self. + + procedure Check_Exception + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link); + pragma Inline (Check_Exception); + -- Raise any pending exception from the Entry_Call. + -- This should be called at the end of every compiler interface procedure + -- that implements an entry call. + -- In principle, the caller should not be abort-deferred (unless the + -- application program violates the Ada language rules by doing entry calls + -- from within protected operations -- an erroneous practice apparently + -- followed with success by some adventurous GNAT users). + -- Absolutely, the caller should not be holding any locks, or there + -- will be deadlock. + +end System.Tasking.Entry_Calls; diff --git a/gcc/ada/s-taprob.adb b/gcc/ada/s-taprob.adb new file mode 100644 index 000000000..ee06529d1 --- /dev/null +++ b/gcc/ada/s-taprob.adb @@ -0,0 +1,281 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2008, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with System.Task_Primitives.Operations; +with System.Parameters; +with System.Traces; +with System.Soft_Links.Tasking; + +package body System.Tasking.Protected_Objects is + + use System.Task_Primitives.Operations; + use System.Traces; + + ---------------- + -- Local Data -- + ---------------- + + Locking_Policy : Character; + pragma Import (C, Locking_Policy, "__gl_locking_policy"); + + ------------------------- + -- Finalize_Protection -- + ------------------------- + + procedure Finalize_Protection (Object : in out Protection) is + begin + Finalize_Lock (Object.L'Unrestricted_Access); + end Finalize_Protection; + + --------------------------- + -- Initialize_Protection -- + --------------------------- + + procedure Initialize_Protection + (Object : Protection_Access; + Ceiling_Priority : Integer) + is + Init_Priority : Integer := Ceiling_Priority; + + begin + if Init_Priority = Unspecified_Priority then + Init_Priority := System.Priority'Last; + end if; + + Initialize_Lock (Init_Priority, Object.L'Access); + Object.Ceiling := System.Any_Priority (Init_Priority); + Object.New_Ceiling := System.Any_Priority (Init_Priority); + Object.Owner := Null_Task; + end Initialize_Protection; + + ----------------- + -- Get_Ceiling -- + ----------------- + + function Get_Ceiling + (Object : Protection_Access) return System.Any_Priority is + begin + return Object.New_Ceiling; + end Get_Ceiling; + + ---------- + -- Lock -- + ---------- + + procedure Lock (Object : Protection_Access) is + Ceiling_Violation : Boolean; + + begin + -- The lock is made without deferring abort + + -- Therefore the abort has to be deferred before calling this routine. + -- This means that the compiler has to generate a Defer_Abort call + -- before the call to Lock. + + -- The caller is responsible for undeferring abort, and compiler + -- generated calls must be protected with cleanup handlers to ensure + -- that abort is undeferred in all cases. + + -- If pragma Detect_Blocking is active then, as described in the ARM + -- 9.5.1, par. 15, we must check whether this is an external call on a + -- protected subprogram with the same target object as that of the + -- protected action that is currently in progress (i.e., if the caller + -- is already the protected object's owner). If this is the case hence + -- Program_Error must be raised. + + if Detect_Blocking and then Object.Owner = Self then + raise Program_Error; + end if; + + Write_Lock (Object.L'Access, Ceiling_Violation); + + if Parameters.Runtime_Traces then + Send_Trace_Info (PO_Lock); + end if; + + if Ceiling_Violation then + raise Program_Error; + end if; + + -- We are entering in a protected action, so that we increase the + -- protected object nesting level (if pragma Detect_Blocking is + -- active), and update the protected object's owner. + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := Self; + begin + -- Update the protected object's owner + + Object.Owner := Self_Id; + + -- Increase protected object nesting level + + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting + 1; + end; + end if; + end Lock; + + -------------------- + -- Lock_Read_Only -- + -------------------- + + procedure Lock_Read_Only (Object : Protection_Access) is + Ceiling_Violation : Boolean; + + begin + -- If pragma Detect_Blocking is active then, as described in the ARM + -- 9.5.1, par. 15, we must check whether this is an external call on + -- protected subprogram with the same target object as that of the + -- protected action that is currently in progress (i.e., if the caller + -- is already the protected object's owner). If this is the case hence + -- Program_Error must be raised. + -- + -- Note that in this case (getting read access), several tasks may have + -- read ownership of the protected object, so that this method of + -- storing the (single) protected object's owner does not work reliably + -- for read locks. However, this is the approach taken for two major + -- reasons: first, this function is not currently being used (it is + -- provided for possible future use), and second, it largely simplifies + -- the implementation. + + if Detect_Blocking and then Object.Owner = Self then + raise Program_Error; + end if; + + Read_Lock (Object.L'Access, Ceiling_Violation); + + if Parameters.Runtime_Traces then + Send_Trace_Info (PO_Lock); + end if; + + if Ceiling_Violation then + raise Program_Error; + end if; + + -- We are entering in a protected action, so we increase the protected + -- object nesting level (if pragma Detect_Blocking is active). + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := Self; + begin + -- Update the protected object's owner + + Object.Owner := Self_Id; + + -- Increase protected object nesting level + + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting + 1; + end; + end if; + end Lock_Read_Only; + + ----------------- + -- Set_Ceiling -- + ----------------- + + procedure Set_Ceiling + (Object : Protection_Access; + Prio : System.Any_Priority) is + begin + Object.New_Ceiling := Prio; + end Set_Ceiling; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (Object : Protection_Access) is + begin + -- We are exiting from a protected action, so that we decrease the + -- protected object nesting level (if pragma Detect_Blocking is + -- active), and remove ownership of the protected object. + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := Self; + + begin + -- Calls to this procedure can only take place when being within + -- a protected action and when the caller is the protected + -- object's owner. + + pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0 + and then Object.Owner = Self_Id); + + -- Remove ownership of the protected object + + Object.Owner := Null_Task; + + -- We are exiting from a protected action, so we decrease the + -- protected object nesting level. + + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting - 1; + end; + end if; + + -- Before releasing the mutex we must actually update its ceiling + -- priority if it has been changed. + + if Object.New_Ceiling /= Object.Ceiling then + if Locking_Policy = 'C' then + System.Task_Primitives.Operations.Set_Ceiling + (Object.L'Access, Object.New_Ceiling); + end if; + + Object.Ceiling := Object.New_Ceiling; + end if; + + Unlock (Object.L'Access); + + if Parameters.Runtime_Traces then + Send_Trace_Info (PO_Unlock); + end if; + end Unlock; + +begin + -- Ensure that tasking is initialized, as well as tasking soft links + -- when using protected objects. + + Tasking.Initialize; + System.Soft_Links.Tasking.Init_Tasking_Soft_Links; +end System.Tasking.Protected_Objects; diff --git a/gcc/ada/s-taprob.ads b/gcc/ada/s-taprob.ads new file mode 100644 index 000000000..0342f70e0 --- /dev/null +++ b/gcc/ada/s-taprob.ads @@ -0,0 +1,246 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides necessary definitions to handle simple (i.e without +-- entries) protected objects. + +-- All the routines that handle protected objects with entries have been moved +-- to two children: Entries and Operations. Note that Entries only contains +-- the type declaration and the OO primitives. This is needed to avoid +-- circular dependency. + +-- This package is part of the high level tasking interface used by the +-- compiler to expand Ada 95 tasking constructs into simpler run time calls +-- (aka GNARLI, GNU Ada Run-time Library Interface) + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes +-- in exp_ch9.adb and possibly exp_ch7.adb and exp_attr.adb + +package System.Tasking.Protected_Objects is + pragma Elaborate_Body; + + --------------------------------- + -- Compiler Interface (GNARLI) -- + --------------------------------- + + -- The compiler will expand in the GNAT tree the following construct: + + -- protected PO is + -- procedure P; + -- private + -- open : boolean := false; + -- end PO; + + -- protected body PO is + -- procedure P is + -- ...variable declarations... + -- begin + -- ...B... + -- end P; + -- end PO; + + -- as follows: + + -- protected type poT is + -- procedure p; + -- private + -- open : boolean := false; + -- end poT; + -- type poTV is limited record + -- open : boolean := false; + -- _object : aliased protection; + -- end record; + -- procedure poPT__pN (_object : in out poTV); + -- procedure poPT__pP (_object : in out poTV); + -- freeze poTV [ + -- procedure poTVI (_init : in out poTV) is + -- begin + -- _init.open := false; + -- object-init-proc (_init._object); + -- initialize_protection (_init._object'unchecked_access, + -- unspecified_priority); + -- return; + -- end _init_proc; + -- ] + -- po : poT; + -- poTVI (poTV!(po)); + + -- procedure poPT__pN (_object : in out poTV) is + -- poR : protection renames _object._object; + -- openP : boolean renames _object.open; + -- ...variable declarations... + -- begin + -- ...B... + -- return; + -- end poPT__pN; + + -- procedure poPT__pP (_object : in out poTV) is + -- procedure _clean is + -- begin + -- unlock (_object._object'unchecked_access); + -- return; + -- end _clean; + -- begin + -- lock (_object._object'unchecked_access); + -- B2b : begin + -- poPT__pN (_object); + -- at end + -- _clean; + -- end B2b; + -- return; + -- end poPT__pP; + + Null_Protected_Entry : constant := Null_Entry; + + Max_Protected_Entry : constant := Max_Entry; + + type Protected_Entry_Index is new Entry_Index + range Null_Protected_Entry .. Max_Protected_Entry; + + type Barrier_Function_Pointer is access + function + (O : System.Address; + E : Protected_Entry_Index) + return Boolean; + -- Pointer to a function which evaluates the barrier of a protected + -- entry body. O is a pointer to the compiler-generated record + -- representing the protected object, and E is the index of the + -- entry serviced by the body. + + type Entry_Action_Pointer is access + procedure + (O : System.Address; + P : System.Address; + E : Protected_Entry_Index); + -- Pointer to a procedure which executes the sequence of statements + -- of a protected entry body. O is a pointer to the compiler-generated + -- record representing the protected object, P is a pointer to the + -- record of entry parameters, and E is the index of the + -- entry serviced by the body. + + type Entry_Body is record + Barrier : Barrier_Function_Pointer; + Action : Entry_Action_Pointer; + end record; + -- The compiler-generated code passes objects of this type to the GNARL + -- to allow it to access the executable code of an entry body. + + type Entry_Body_Access is access all Entry_Body; + + type Protection is limited private; + -- This type contains the GNARL state of a protected object. The + -- application-defined portion of the state (i.e. private objects) + -- is maintained by the compiler-generated code. + -- Note that there are now 2 Protection types. One for the simple + -- case (no entries) and one for the general case that needs the whole + -- Finalization mechanism. + -- This split helps in the case of restricted run time where we want to + -- minimize the size of the code. + + type Protection_Access is access all Protection; + + Null_PO : constant Protection_Access := null; + + function Get_Ceiling + (Object : Protection_Access) return System.Any_Priority; + -- Returns the new ceiling priority of the protected object + + procedure Initialize_Protection + (Object : Protection_Access; + Ceiling_Priority : Integer); + -- Initialize the Object parameter so that it can be used by the runtime + -- to keep track of the runtime state of a protected object. + + procedure Lock (Object : Protection_Access); + -- Lock a protected object for write access. Upon return, the caller + -- owns the lock to this object, and no other call to Lock or + -- Lock_Read_Only with the same argument will return until the + -- corresponding call to Unlock has been made by the caller. + + procedure Lock_Read_Only (Object : Protection_Access); + -- Lock a protected object for read access. Upon return, the caller + -- owns the lock for read access, and no other calls to Lock with the + -- same argument will return until the corresponding call to Unlock + -- has been made by the caller. Other calls to Lock_Read_Only may (but + -- need not) return before the call to Unlock, and the corresponding + -- callers will also own the lock for read access. + -- + -- Note: we are not currently using this interface, it is provided + -- for possible future use. At the current time, everyone uses Lock + -- for both read and write locks. + + procedure Set_Ceiling + (Object : Protection_Access; + Prio : System.Any_Priority); + -- Sets the new ceiling priority of the protected object + + procedure Unlock (Object : Protection_Access); + -- Relinquish ownership of the lock for the object represented by + -- the Object parameter. If this ownership was for write access, or + -- if it was for read access where there are no other read access + -- locks outstanding, one (or more, in the case of Lock_Read_Only) + -- of the tasks waiting on this lock (if any) will be given the + -- lock and allowed to return from the Lock or Lock_Read_Only call. + +private + type Protection is record + L : aliased Task_Primitives.Lock; + -- Lock used to ensure mutual exclusive access to the protected object + + Ceiling : System.Any_Priority; + -- Ceiling priority associated to the protected object + + New_Ceiling : System.Any_Priority; + -- New ceiling priority associated to the protected object. In case + -- of assignment of a new ceiling priority to the protected object the + -- frontend generates a call to set_ceiling to save the new value in + -- this field. After such assignment this value can be read by means + -- of the 'Priority attribute, which generates a call to get_ceiling. + -- However, the ceiling of the protected object will not be changed + -- until completion of the protected action in which the assignment + -- has been executed (AARM D.5.2 (10/2)). + + Owner : Task_Id; + -- This field contains the protected object's owner. Null_Task + -- indicates that the protected object is not currently being used. + -- This information is used for detecting the type of potentially + -- blocking operations described in the ARM 9.5.1, par. 15 (external + -- calls on a protected subprogram with the same target object as that + -- of the protected action). + end record; + + procedure Finalize_Protection (Object : in out Protection); + -- Clean up a Protection object (in particular, finalize the associated + -- Lock object). The compiler generates calls automatically to this + -- procedure + +end System.Tasking.Protected_Objects; diff --git a/gcc/ada/s-taprop-dummy.adb b/gcc/ada/s-taprop-dummy.adb new file mode 100644 index 000000000..645e9fd90 --- /dev/null +++ b/gcc/ada/s-taprop-dummy.adb @@ -0,0 +1,519 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a no tasking version of this package + +-- This package contains all the GNULL primitives that interface directly with +-- the underlying OS. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +package body System.Task_Primitives.Operations is + + use System.Tasking; + use System.Parameters; + + pragma Warnings (Off); + -- Turn off warnings since so many unreferenced parameters + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_Id) is + begin + null; + end Abort_Task; + + ---------------- + -- Check_Exit -- + ---------------- + + function Check_Exit (Self_ID : ST.Task_Id) return Boolean is + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is + begin + return True; + end Check_No_Locks; + + ------------------- + -- Continue_Task -- + ------------------- + + function Continue_Task (T : ST.Task_Id) return Boolean is + begin + return False; + end Continue_Task; + + ------------------- + -- Current_State -- + ------------------- + + function Current_State (S : Suspension_Object) return Boolean is + begin + return False; + end Current_State; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_Id is + begin + return null; + end Environment_Task; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_Id; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + begin + Succeeded := False; + end Create_Task; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_Id) is + begin + null; + end Enter_Task; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + null; + end Exit_Task; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (S : in out Suspension_Object) is + begin + null; + end Finalize; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : not null access Lock) is + begin + null; + end Finalize_Lock; + + procedure Finalize_Lock (L : not null access RTS_Lock) is + begin + null; + end Finalize_Lock; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_Id) is + begin + null; + end Finalize_TCB; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_Id) return System.Any_Priority is + begin + return 0; + end Get_Priority; + + -------------------- + -- Get_Thread_Id -- + -------------------- + + function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is + begin + return OSI.Thread_Id (T.Common.LL.Thread); + end Get_Thread_Id; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_Id) is + No_Tasking : Boolean; + begin + raise Program_Error with "tasking not implemented on this configuration"; + end Initialize; + + procedure Initialize (S : in out Suspension_Object) is + begin + null; + end Initialize; + + --------------------- + -- Initialize_Lock -- + --------------------- + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : not null access Lock) + is + begin + null; + end Initialize_Lock; + + procedure Initialize_Lock + (L : not null access RTS_Lock; Level : Lock_Level) is + begin + null; + end Initialize_Lock; + + -------------------- + -- Initialize_TCB -- + -------------------- + + procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is + begin + Succeeded := False; + end Initialize_TCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean is + begin + return False; + end Is_Valid_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + null; + end Lock_RTS; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + begin + return 0.0; + end Monotonic_Clock; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is + begin + Ceiling_Violation := False; + end Read_Lock; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_Id is + begin + return null; + end Register_Foreign_Thread; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_Id; + Thread_Self : OSI.Thread_Id) return Boolean + is + begin + return False; + end Resume_Task; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + return 10#1.0#E-6; + end RT_Resolution; + + ---------- + -- Self -- + ---------- + + function Self return Task_Id is + begin + return Null_Task; + end Self; + + ----------------- + -- Set_Ceiling -- + ----------------- + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + begin + null; + end Set_Ceiling; + + --------------- + -- Set_False -- + --------------- + + procedure Set_False (S : in out Suspension_Object) is + begin + null; + end Set_False; + + ------------------ + -- Set_Priority -- + ------------------ + + procedure Set_Priority + (T : Task_Id; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + begin + null; + end Set_Priority; + + -------------- + -- Set_True -- + -------------- + + procedure Set_True (S : in out Suspension_Object) is + begin + null; + end Set_True; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep (Self_ID : Task_Id; Reason : System.Tasking.Task_States) is + begin + null; + end Sleep; + + ----------------- + -- Stack_Guard -- + ----------------- + + procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is + begin + null; + end Stack_Guard; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_Id; + Thread_Self : OSI.Thread_Id) return Boolean + is + begin + return False; + end Suspend_Task; + + -------------------- + -- Stop_All_Tasks -- + -------------------- + + procedure Stop_All_Tasks is + begin + null; + end Stop_All_Tasks; + + --------------- + -- Stop_Task -- + --------------- + + function Stop_Task (T : ST.Task_Id) return Boolean is + pragma Unreferenced (T); + begin + return False; + end Stop_Task; + + ------------------------ + -- Suspend_Until_True -- + ------------------------ + + procedure Suspend_Until_True (S : in out Suspension_Object) is + begin + null; + end Suspend_Until_True; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes) + is + begin + null; + end Timed_Delay; + + ----------------- + -- Timed_Sleep -- + ----------------- + + procedure Timed_Sleep + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + begin + Timedout := False; + Yielded := False; + end Timed_Sleep; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : not null access Lock) is + begin + null; + end Unlock; + + procedure Unlock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) + is + begin + null; + end Unlock; + + procedure Unlock (T : Task_Id) is + begin + null; + end Unlock; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + null; + end Unlock_RTS; + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is + begin + null; + end Wakeup; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is + begin + Ceiling_Violation := False; + end Write_Lock; + + procedure Write_Lock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) + is + begin + null; + end Write_Lock; + + procedure Write_Lock (T : Task_Id) is + begin + null; + end Write_Lock; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + begin + null; + end Yield; + +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-hpux-dce.adb b/gcc/ada/s-taprop-hpux-dce.adb new file mode 100644 index 000000000..814b48b1a --- /dev/null +++ b/gcc/ada/s-taprop-hpux-dce.adb @@ -0,0 +1,1247 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a HP-UX DCE threads (HPUX 10) version of this package + +-- This package contains all the GNULL primitives that interface directly with +-- the underlying OS. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +with Interfaces.C; + +with System.Tasking.Debug; +with System.Interrupt_Management; +with System.OS_Primitives; +with System.Task_Primitives.Interrupt_Operations; + +pragma Warnings (Off); +with System.Interrupt_Management.Operations; +pragma Elaborate_All (System.Interrupt_Management.Operations); +pragma Warnings (On); + +with System.Soft_Links; +-- We use System.Soft_Links instead of System.Tasking.Initialization +-- because the later is a higher level package that we shouldn't depend on. +-- For example when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Stages. + +package body System.Task_Primitives.Operations is + + package SSL renames System.Soft_Links; + + use System.Tasking.Debug; + use System.Tasking; + use Interfaces.C; + use System.OS_Interface; + use System.Parameters; + use System.OS_Primitives; + + package PIO renames System.Task_Primitives.Interrupt_Operations; + + ---------------- + -- Local Data -- + ---------------- + + -- The followings are logically constants, but need to be initialized + -- at run time. + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + ATCB_Key : aliased pthread_key_t; + -- Key used to find the Ada Task_Id associated with a thread + + Environment_Task_Id : Task_Id; + -- A variable to hold Task_Id for the environment task + + Unblocked_Signal_Mask : aliased sigset_t; + -- The set of signals that should unblocked in all tasks + + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + -- Note: the reason that Locking_Policy is not needed is that this + -- is not implemented for DCE threads. The HPUX 10 port is at this + -- stage considered dead, and no further work is planned on it. + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads) + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + procedure Initialize (Environment_Task : Task_Id); + pragma Inline (Initialize); + -- Initialize various data needed by this package + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does the executing thread have a TCB? + + procedure Set (Self_Id : Task_Id); + pragma Inline (Set); + -- Set the self id for the current task + + function Self return Task_Id; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task + + end Specific; + + package body Specific is separate; + -- The body of this package is target specific + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; + -- Allocate and Initialize a new ATCB for the current Thread + + function Register_Foreign_Thread + (Thread : Thread_Id) return Task_Id is separate; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Abort_Handler (Sig : Signal); + + function To_Address is + new Ada.Unchecked_Conversion (Task_Id, System.Address); + + ------------------- + -- Abort_Handler -- + ------------------- + + procedure Abort_Handler (Sig : Signal) is + pragma Unreferenced (Sig); + + Self_Id : constant Task_Id := Self; + Result : Interfaces.C.int; + Old_Set : aliased sigset_t; + + begin + if Self_Id.Deferral_Level = 0 + and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level + and then not Self_Id.Aborting + then + Self_Id.Aborting := True; + + -- Make sure signals used for RTS internal purpose are unmasked + + Result := + pthread_sigmask + (SIG_UNBLOCK, + Unblocked_Signal_Mask'Access, + Old_Set'Access); + pragma Assert (Result = 0); + + raise Standard'Abort_Signal; + end if; + end Abort_Handler; + + ----------------- + -- Stack_Guard -- + ----------------- + + -- The underlying thread system sets a guard page at the bottom of a thread + -- stack, so nothing is needed. + -- ??? Check the comment above + + procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is + pragma Unreferenced (T, On); + begin + null; + end Stack_Guard; + + ------------------- + -- Get_Thread_Id -- + ------------------- + + function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_Id renames Specific.Self; + + --------------------- + -- Initialize_Lock -- + --------------------- + + -- Note: mutexes and cond_variables needed per-task basis are initialized + -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such + -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any + -- status change of RTS. Therefore raising Storage_Error in the following + -- routines should be able to be handled safely. + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : not null access Lock) + is + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + L.Priority := Prio; + + Result := pthread_mutex_init (L.L'Access, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + procedure Initialize_Lock + (L : not null access RTS_Lock; + Level : Lock_Level) + is + pragma Unreferenced (Level); + + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutex_init (L, Attributes'Access); + + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : not null access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L.L'Access); + pragma Assert (Result = 0); + end Finalize_Lock; + + procedure Finalize_Lock (L : not null access RTS_Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is + Result : Interfaces.C.int; + + begin + L.Owner_Priority := Get_Priority (Self); + + if L.Priority < L.Owner_Priority then + Ceiling_Violation := True; + return; + end if; + + Result := pthread_mutex_lock (L.L'Access); + pragma Assert (Result = 0); + Ceiling_Violation := False; + end Write_Lock; + + procedure Write_Lock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_lock (L); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_Id) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_lock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : not null access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_unlock (L.L'Access); + pragma Assert (Result = 0); + end Unlock; + + procedure Unlock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock (T : Task_Id) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_unlock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + ----------------- + -- Set_Ceiling -- + ----------------- + + -- Dynamic priority ceilings are not supported by the underlying system + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + pragma Unreferenced (L, Prio); + begin + null; + end Set_Ceiling; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : Task_Id; + Reason : System.Tasking.Task_States) + is + pragma Unreferenced (Reason); + + Result : Interfaces.C.int; + + begin + Result := + pthread_cond_wait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access)); + + -- EINTR is not considered a failure + + pragma Assert (Result = 0 or else Result = EINTR); + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + procedure Timed_Sleep + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Unreferenced (Reason); + + Check_Time : constant Duration := Monotonic_Clock; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + Timedout := True; + Yielded := False; + + Abs_Time := + (if Mode = Relative + then Duration'Min (Time, Max_Sensible_Delay) + Check_Time + else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); + + if Abs_Time > Check_Time then + Request := To_Timespec (Abs_Time); + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); + + exit when Abs_Time <= Monotonic_Clock; + + if Result = 0 or Result = EINTR then + + -- Somebody may have called Wakeup for us + + Timedout := False; + exit; + end if; + + pragma Assert (Result = ETIMEDOUT); + end loop; + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes) + is + Check_Time : constant Duration := Monotonic_Clock; + Abs_Time : Duration; + Request : aliased timespec; + + Result : Interfaces.C.int; + pragma Warnings (Off, Result); + + begin + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + Abs_Time := + (if Mode = Relative + then Time + Check_Time + else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); + + if Abs_Time > Check_Time then + Request := To_Timespec (Abs_Time); + Self_ID.Common.State := Delay_Sleep; + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); + + exit when Abs_Time <= Monotonic_Clock; + + pragma Assert (Result = 0 or else + Result = ETIMEDOUT or else + Result = EINTR); + end loop; + + Self_ID.Common.State := Runnable; + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + Result := sched_yield; + end Timed_Delay; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + TS : aliased timespec; + Result : Interfaces.C.int; + begin + Result := Clock_Gettime (CLOCK_REALTIME, TS'Unchecked_Access); + pragma Assert (Result = 0); + return To_Duration (TS); + end Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + return 10#1.0#E-6; + end RT_Resolution; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + begin + Result := pthread_cond_signal (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + Result : Interfaces.C.int; + pragma Unreferenced (Result); + begin + if Do_Yield then + Result := sched_yield; + end if; + end Yield; + + ------------------ + -- Set_Priority -- + ------------------ + + type Prio_Array_Type is array (System.Any_Priority) of Integer; + pragma Atomic_Components (Prio_Array_Type); + + Prio_Array : Prio_Array_Type; + -- Global array containing the id of the currently running task for + -- each priority. + -- + -- Note: assume we are on single processor with run-til-blocked scheduling + + procedure Set_Priority + (T : Task_Id; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + Result : Interfaces.C.int; + Array_Item : Integer; + Param : aliased struct_sched_param; + + function Get_Policy (Prio : System.Any_Priority) return Character; + pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); + -- Get priority specific dispatching policy + + Priority_Specific_Policy : constant Character := Get_Policy (Prio); + -- Upper case first character of the policy name corresponding to the + -- task as set by a Priority_Specific_Dispatching pragma. + + begin + Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio)); + + if Dispatching_Policy = 'R' + or else Priority_Specific_Policy = 'R' + or else Time_Slice_Val > 0 + then + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_RR, Param'Access); + + elsif Dispatching_Policy = 'F' + or else Priority_Specific_Policy = 'F' + or else Time_Slice_Val = 0 + then + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_FIFO, Param'Access); + + else + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_OTHER, Param'Access); + end if; + + pragma Assert (Result = 0); + + if Dispatching_Policy = 'F' or else Priority_Specific_Policy = 'F' then + + -- Annex D requirement [RM D.2.2 par. 9]: + -- If the task drops its priority due to the loss of inherited + -- priority, it is added at the head of the ready queue for its + -- new active priority. + + if Loss_Of_Inheritance + and then Prio < T.Common.Current_Priority + then + Array_Item := Prio_Array (T.Common.Base_Priority) + 1; + Prio_Array (T.Common.Base_Priority) := Array_Item; + + loop + -- Let some processes a chance to arrive + + Yield; + + -- Then wait for our turn to proceed + + exit when Array_Item = Prio_Array (T.Common.Base_Priority) + or else Prio_Array (T.Common.Base_Priority) = 1; + end loop; + + Prio_Array (T.Common.Base_Priority) := + Prio_Array (T.Common.Base_Priority) - 1; + end if; + end if; + + T.Common.Current_Priority := Prio; + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_Id) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_Id) is + begin + Self_ID.Common.LL.Thread := pthread_self; + Specific.Set (Self_ID); + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_Id is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (pthread_self); + end if; + end Register_Foreign_Thread; + + -------------------- + -- Initialize_TCB -- + -------------------- + + procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is + Mutex_Attr : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + Cond_Attr : aliased pthread_condattr_t; + + begin + if not Single_Lock then + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := + pthread_mutex_init + (Self_ID.Common.LL.L'Access, Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := + pthread_cond_init + (Self_ID.Common.LL.CV'Access, + Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result = 0 then + Succeeded := True; + else + if not Single_Lock then + Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Succeeded := False; + end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_Id; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + Attributes : aliased pthread_attr_t; + Result : Interfaces.C.int; + + function Thread_Body_Access is new + Ada.Unchecked_Conversion (System.Address, Thread_Body); + + begin + Result := pthread_attr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := pthread_attr_setstacksize + (Attributes'Access, Interfaces.C.size_t (Stack_Size)); + pragma Assert (Result = 0); + + -- Since the initial signal mask of a thread is inherited from the + -- creator, and the Environment task has all its signals masked, we + -- do not need to manipulate caller's signal mask at this point. + -- All tasks in RTS will have All_Tasks_Mask initially. + + Result := pthread_create + (T.Common.LL.Thread'Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); + pragma Assert (Result = 0 or else Result = EAGAIN); + + Succeeded := Result = 0; + + pthread_detach (T.Common.LL.Thread'Access); + -- Detach the thread using pthread_detach, since DCE threads do not have + -- pthread_attr_set_detachstate. + + Result := pthread_attr_destroy (Attributes'Access); + pragma Assert (Result = 0); + + Set_Priority (T, Priority); + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_Id) is + Result : Interfaces.C.int; + Tmp : Task_Id := T; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + + begin + if not Single_Lock then + Result := pthread_mutex_destroy (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_cond_destroy (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + Free (Tmp); + + if Is_Self then + Specific.Set (null); + end if; + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + Specific.Set (null); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_Id) is + begin + -- Interrupt Server_Tasks may be waiting on an "event" flag (signal) + + if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then + System.Interrupt_Management.Operations.Interrupt_Self_Process + (PIO.Get_Interrupt_ID (T)); + end if; + end Abort_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (S : in out Suspension_Object) is + Mutex_Attr : aliased pthread_mutexattr_t; + Cond_Attr : aliased pthread_condattr_t; + Result : Interfaces.C.int; + begin + -- Initialize internal state (always to False (ARM D.10(6))) + + S.State := False; + S.Waiting := False; + + -- Initialize internal mutex + + Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + -- Initialize internal condition variable + + Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + if Result = ENOMEM then + raise Storage_Error; + end if; + end if; + end Initialize; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + -- Destroy internal mutex + + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + -- Destroy internal condition variable + + Result := pthread_cond_destroy (S.CV'Access); + pragma Assert (Result = 0); + end Finalize; + + ------------------- + -- Current_State -- + ------------------- + + function Current_State (S : Suspension_Object) return Boolean is + begin + -- We do not want to use lock on this read operation. State is marked + -- as Atomic so that we ensure that the value retrieved is correct. + + return S.State; + end Current_State; + + --------------- + -- Set_False -- + --------------- + + procedure Set_False (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + S.State := False; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end Set_False; + + -------------- + -- Set_True -- + -------------- + + procedure Set_True (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + -- If there is already a task waiting on this suspension object then + -- we resume it, leaving the state of the suspension object to False, + -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves + -- the state to True. + + if S.Waiting then + S.Waiting := False; + S.State := False; + + Result := pthread_cond_signal (S.CV'Access); + pragma Assert (Result = 0); + + else + S.State := True; + end if; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end Set_True; + + ------------------------ + -- Suspend_Until_True -- + ------------------------ + + procedure Suspend_Until_True (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + if S.Waiting then + -- Program_Error must be raised upon calling Suspend_Until_True + -- if another task is already waiting on that suspension object + -- (ARM D.10 par. 10). + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + + raise Program_Error; + else + -- Suspend the task if the state is False. Otherwise, the task + -- continues its execution, and the state of the suspension object + -- is set to False (ARM D.10 par. 9). + + if S.State then + S.State := False; + else + S.Waiting := True; + + loop + -- Loop in case pthread_cond_wait returns earlier than expected + -- (e.g. in case of EINTR caused by a signal). + + Result := pthread_cond_wait (S.CV'Access, S.L'Access); + pragma Assert (Result = 0 or else Result = EINTR); + + exit when not S.Waiting; + end loop; + end if; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end if; + end Suspend_Until_True; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy version + + function Check_Exit (Self_ID : ST.Task_Id) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_Id is + begin + return Environment_Task_Id; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + pragma Unreferenced (T); + pragma Unreferenced (Thread_Self); + begin + return False; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + pragma Unreferenced (T); + pragma Unreferenced (Thread_Self); + begin + return False; + end Resume_Task; + + -------------------- + -- Stop_All_Tasks -- + -------------------- + + procedure Stop_All_Tasks is + begin + null; + end Stop_All_Tasks; + + --------------- + -- Stop_Task -- + --------------- + + function Stop_Task (T : ST.Task_Id) return Boolean is + pragma Unreferenced (T); + begin + return False; + end Stop_Task; + + ------------------- + -- Continue_Task -- + ------------------- + + function Continue_Task (T : ST.Task_Id) return Boolean is + pragma Unreferenced (T); + begin + return False; + end Continue_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_Id) is + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + Tmp_Set : aliased sigset_t; + Result : Interfaces.C.int; + + function State + (Int : System.Interrupt_Management.Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state. Defined in a-init.c. The input argument is + -- the interrupt number, and the result is one of the following: + + Default : constant Character := 's'; + -- 'n' this interrupt not set by any Interrupt_State pragma + -- 'u' Interrupt_State pragma set state to User + -- 'r' Interrupt_State pragma set state to Runtime + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + + begin + Environment_Task_Id := Environment_Task; + + Interrupt_Management.Initialize; + + -- Initialize the lock used to synchronize chain of all ATCBs + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + Specific.Initialize (Environment_Task); + + -- Make environment task known here because it doesn't go through + -- Activate_Tasks, which does it for all other tasks. + + Known_Tasks (Known_Tasks'First) := Environment_Task; + Environment_Task.Known_Tasks_Index := Known_Tasks'First; + + Enter_Task (Environment_Task); + + -- Install the abort-signal handler + + if State (System.Interrupt_Management.Abort_Task_Interrupt) + /= Default + then + act.sa_flags := 0; + act.sa_handler := Abort_Handler'Address; + + Result := sigemptyset (Tmp_Set'Access); + pragma Assert (Result = 0); + act.sa_mask := Tmp_Set; + + Result := + sigaction ( + Signal (System.Interrupt_Management.Abort_Task_Interrupt), + act'Unchecked_Access, + old_act'Unchecked_Access); + pragma Assert (Result = 0); + end if; + end Initialize; + + -- NOTE: Unlike other pthread implementations, we do *not* mask all + -- signals here since we handle signals using the process-wide primitive + -- signal, rather than using sigthreadmask and sigwait. The reason of + -- this difference is that sigwait doesn't work when some critical + -- signals (SIGABRT, SIGPIPE) are masked. + +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-irix.adb b/gcc/ada/s-taprop-irix.adb new file mode 100644 index 000000000..e73555fb3 --- /dev/null +++ b/gcc/ada/s-taprop-irix.adb @@ -0,0 +1,1348 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a IRIX (pthread library) version of this package + +-- This package contains all the GNULL primitives that interface directly with +-- the underlying OS. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +with Interfaces.C; + +with System.Task_Info; +with System.Tasking.Debug; +with System.Interrupt_Management; +with System.OS_Primitives; +with System.IO; + +with System.Soft_Links; +-- We use System.Soft_Links instead of System.Tasking.Initialization +-- because the later is a higher level package that we shouldn't depend on. +-- For example when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Stages. + +package body System.Task_Primitives.Operations is + + package SSL renames System.Soft_Links; + + use System.Tasking; + use System.Tasking.Debug; + use Interfaces.C; + use System.OS_Interface; + use System.OS_Primitives; + use System.Parameters; + + ---------------- + -- Local Data -- + ---------------- + + -- The followings are logically constants, but need to be initialized + -- at run time. + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + ATCB_Key : aliased pthread_key_t; + -- Key used to find the Ada Task_Id associated with a thread + + Environment_Task_Id : Task_Id; + -- A variable to hold Task_Id for the environment task + + Locking_Policy : Character; + pragma Import (C, Locking_Policy, "__gl_locking_policy"); + + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + Real_Time_Clock_Id : constant clockid_t := CLOCK_REALTIME; + + Unblocked_Signal_Mask : aliased sigset_t; + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads) + + Abort_Handler_Installed : Boolean := False; + -- True if a handler for the abort signal is installed + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + procedure Initialize (Environment_Task : Task_Id); + pragma Inline (Initialize); + -- Initialize various data needed by this package + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does executing thread have a TCB? + + procedure Set (Self_Id : Task_Id); + pragma Inline (Set); + -- Set the self id for the current task + + function Self return Task_Id; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task + + end Specific; + + package body Specific is separate; + -- The body of this package is target specific + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; + -- Allocate and Initialize a new ATCB for the current Thread + + function Register_Foreign_Thread + (Thread : Thread_Id) return Task_Id is separate; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function To_Address is + new Ada.Unchecked_Conversion (Task_Id, System.Address); + + procedure Abort_Handler (Sig : Signal); + -- Signal handler used to implement asynchronous abort + + ------------------- + -- Abort_Handler -- + ------------------- + + procedure Abort_Handler (Sig : Signal) is + pragma Unreferenced (Sig); + + T : constant Task_Id := Self; + Result : Interfaces.C.int; + Old_Set : aliased sigset_t; + + begin + -- It's not safe to raise an exception when using GCC ZCX mechanism. + -- Note that we still need to install a signal handler, since in some + -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we + -- need to send the Abort signal to a task. + + if ZCX_By_Default and then GCC_ZCX_Support then + return; + end if; + + if T.Deferral_Level = 0 + and then T.Pending_ATC_Level < T.ATC_Nesting_Level + then + -- Make sure signals used for RTS internal purpose are unmasked + + Result := pthread_sigmask + (SIG_UNBLOCK, + Unblocked_Signal_Mask'Access, + Old_Set'Access); + pragma Assert (Result = 0); + + raise Standard'Abort_Signal; + end if; + end Abort_Handler; + + ----------------- + -- Stack_Guard -- + ----------------- + + -- The underlying thread system sets a guard page at the + -- bottom of a thread stack, so nothing is needed. + + procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is + pragma Unreferenced (On); + pragma Unreferenced (T); + begin + null; + end Stack_Guard; + + ------------------- + -- Get_Thread_Id -- + ------------------- + + function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_Id renames Specific.Self; + + --------------------- + -- Initialize_Lock -- + --------------------- + + -- Note: mutexes and cond_variables needed per-task basis are initialized + -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such + -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any + -- status change of RTS. Therefore raising Storage_Error in the following + -- routines should be able to be handled safely. + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : not null access Lock) + is + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + if Locking_Policy = 'C' then + Result := + pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_PROTECT); + pragma Assert (Result = 0); + + Result := + pthread_mutexattr_setprioceiling + (Attributes'Access, Interfaces.C.int (Prio)); + pragma Assert (Result = 0); + end if; + + Result := pthread_mutex_init (L, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Attributes'Access); + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + procedure Initialize_Lock + (L : not null access RTS_Lock; + Level : Lock_Level) + is + pragma Unreferenced (Level); + + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + if Locking_Policy = 'C' then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_PROTECT); + pragma Assert (Result = 0); + + Result := pthread_mutexattr_setprioceiling + (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); + pragma Assert (Result = 0); + end if; + + Result := pthread_mutex_init (L, Attributes'Access); + + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Attributes'Access); + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : not null access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + procedure Finalize_Lock (L : not null access RTS_Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock + (L : not null access Lock; Ceiling_Violation : out Boolean) + is + Result : Interfaces.C.int; + + begin + Result := pthread_mutex_lock (L); + Ceiling_Violation := Result = EINVAL; + + -- Assumes the cause of EINVAL is a priority ceiling violation + + pragma Assert (Result = 0 or else Result = EINVAL); + end Write_Lock; + + procedure Write_Lock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_lock (L); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_Id) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_lock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock + (L : not null access Lock; Ceiling_Violation : out Boolean) is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : not null access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end Unlock; + + procedure Unlock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock (T : Task_Id) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_unlock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + ----------------- + -- Set_Ceiling -- + ----------------- + + -- Dynamic priority ceilings are not supported by the underlying system + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + pragma Unreferenced (L, Prio); + begin + null; + end Set_Ceiling; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : ST.Task_Id; + Reason : System.Tasking.Task_States) + is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + + begin + Result := + pthread_cond_wait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access)); + + -- EINTR is not considered a failure + + pragma Assert (Result = 0 or else Result = EINTR); + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + procedure Timed_Sleep + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Unreferenced (Reason); + + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + Timedout := True; + Yielded := False; + + Abs_Time := + (if Mode = Relative + then Duration'Min (Time, Max_Sensible_Delay) + Check_Time + else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); + + if Abs_Time > Check_Time then + Request := To_Timespec (Abs_Time); + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); + + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + if Result = 0 or else errno = EINTR then + Timedout := False; + exit; + end if; + end loop; + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + -- This is for use in implementing delay statements, so we assume + -- the caller is abort-deferred but is holding no locks. + + procedure Timed_Delay + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes) + is + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + Abs_Time := + (if Mode = Relative + then Time + Check_Time + else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); + + if Abs_Time > Check_Time then + Request := To_Timespec (Abs_Time); + Self_ID.Common.State := Delay_Sleep; + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); + + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + pragma Assert (Result = 0 + or else Result = ETIMEDOUT + or else Result = EINTR); + end loop; + + Self_ID.Common.State := Runnable; + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + Yield; + end Timed_Delay; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + TS : aliased timespec; + Result : Interfaces.C.int; + begin + Result := clock_gettime (Real_Time_Clock_Id, TS'Unchecked_Access); + pragma Assert (Result = 0); + return To_Duration (TS); + end Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + -- The clock_getres (Real_Time_Clock_Id) function appears to return + -- the interrupt resolution of the realtime clock and not the actual + -- resolution of reading the clock. Even though this last value is + -- only guaranteed to be 100 Hz, at least the Origin 200 appears to + -- have a microsecond resolution or better. + + -- ??? We should figure out a method to return the right value on + -- all SGI hardware. + + return 0.000_001; + end RT_Resolution; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : ST.Task_Id; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + begin + Result := pthread_cond_signal (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + Result : Interfaces.C.int; + pragma Unreferenced (Result); + begin + if Do_Yield then + Result := sched_yield; + end if; + end Yield; + + ------------------ + -- Set_Priority -- + ------------------ + + procedure Set_Priority + (T : Task_Id; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + pragma Unreferenced (Loss_Of_Inheritance); + + Result : Interfaces.C.int; + Param : aliased struct_sched_param; + Sched_Policy : Interfaces.C.int; + + use type System.Task_Info.Task_Info_Type; + + function To_Int is new Ada.Unchecked_Conversion + (System.Task_Info.Thread_Scheduling_Policy, Interfaces.C.int); + + function Get_Policy (Prio : System.Any_Priority) return Character; + pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); + -- Get priority specific dispatching policy + + Priority_Specific_Policy : constant Character := Get_Policy (Prio); + -- Upper case first character of the policy name corresponding to the + -- task as set by a Priority_Specific_Dispatching pragma. + + begin + T.Common.Current_Priority := Prio; + Param.sched_priority := Interfaces.C.int (Prio); + + if T.Common.Task_Info /= null then + Sched_Policy := To_Int (T.Common.Task_Info.Policy); + + elsif Dispatching_Policy = 'R' + or else Priority_Specific_Policy = 'R' + or else Time_Slice_Val > 0 + then + Sched_Policy := SCHED_RR; + + else + Sched_Policy := SCHED_FIFO; + end if; + + Result := pthread_setschedparam (T.Common.LL.Thread, Sched_Policy, + Param'Access); + pragma Assert (Result = 0); + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_Id) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_Id) is + Result : Interfaces.C.int; + + function To_Int is new Ada.Unchecked_Conversion + (System.Task_Info.CPU_Number, Interfaces.C.int); + + use System.Task_Info; + + begin + Self_ID.Common.LL.Thread := pthread_self; + Specific.Set (Self_ID); + + if Self_ID.Common.Task_Info /= null + and then Self_ID.Common.Task_Info.Scope = PTHREAD_SCOPE_SYSTEM + and then Self_ID.Common.Task_Info.Runon_CPU /= ANY_CPU + then + Result := pthread_setrunon_np + (To_Int (Self_ID.Common.Task_Info.Runon_CPU)); + pragma Assert (Result = 0); + end if; + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_Id is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (pthread_self); + end if; + end Register_Foreign_Thread; + + -------------------- + -- Initialize_TCB -- + -------------------- + + procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is + Result : Interfaces.C.int; + Cond_Attr : aliased pthread_condattr_t; + + begin + if not Single_Lock then + Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); + end if; + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := + pthread_cond_init (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result = 0 then + Succeeded := True; + else + if not Single_Lock then + Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Succeeded := False; + end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_Id; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + use System.Task_Info; + + Attributes : aliased pthread_attr_t; + Sched_Param : aliased struct_sched_param; + Result : Interfaces.C.int; + + function Thread_Body_Access is new + Ada.Unchecked_Conversion (System.Address, Thread_Body); + function To_Int is new Ada.Unchecked_Conversion + (System.Task_Info.Thread_Scheduling_Scope, Interfaces.C.int); + function To_Int is new Ada.Unchecked_Conversion + (System.Task_Info.Thread_Scheduling_Inheritance, Interfaces.C.int); + function To_Int is new Ada.Unchecked_Conversion + (System.Task_Info.Thread_Scheduling_Policy, Interfaces.C.int); + + begin + Result := pthread_attr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := + pthread_attr_setdetachstate + (Attributes'Access, PTHREAD_CREATE_DETACHED); + pragma Assert (Result = 0); + + Result := + pthread_attr_setstacksize + (Attributes'Access, Interfaces.C.size_t (Stack_Size)); + pragma Assert (Result = 0); + + if T.Common.Task_Info /= null then + Result := + pthread_attr_setscope + (Attributes'Access, To_Int (T.Common.Task_Info.Scope)); + pragma Assert (Result = 0); + + Result := + pthread_attr_setinheritsched + (Attributes'Access, To_Int (T.Common.Task_Info.Inheritance)); + pragma Assert (Result = 0); + + Result := + pthread_attr_setschedpolicy + (Attributes'Access, To_Int (T.Common.Task_Info.Policy)); + pragma Assert (Result = 0); + + Sched_Param.sched_priority := + Interfaces.C.int (T.Common.Task_Info.Priority); + + Result := + pthread_attr_setschedparam + (Attributes'Access, Sched_Param'Access); + pragma Assert (Result = 0); + end if; + + -- Since the initial signal mask of a thread is inherited from the + -- creator, and the Environment task has all its signals masked, we + -- do not need to manipulate caller's signal mask at this point. + -- All tasks in RTS will have All_Tasks_Mask initially. + + Result := + pthread_create + (T.Common.LL.Thread'Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); + + if Result /= 0 + and then T.Common.Task_Info /= null + and then T.Common.Task_Info.Scope = PTHREAD_SCOPE_SYSTEM + then + -- The pthread_create call may have failed because we asked for a + -- system scope pthread and none were available (probably because + -- the program was not executed by the superuser). Let's try for + -- a process scope pthread instead of raising Tasking_Error. + + System.IO.Put_Line + ("Request for PTHREAD_SCOPE_SYSTEM in Task_Info pragma for task"); + System.IO.Put (""""); + System.IO.Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len)); + System.IO.Put_Line (""" could not be honored. "); + System.IO.Put_Line ("Scope changed to PTHREAD_SCOPE_PROCESS"); + + T.Common.Task_Info.Scope := PTHREAD_SCOPE_PROCESS; + Result := + pthread_attr_setscope + (Attributes'Access, To_Int (T.Common.Task_Info.Scope)); + pragma Assert (Result = 0); + + Result := + pthread_create + (T.Common.LL.Thread'Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); + end if; + + pragma Assert (Result = 0 or else Result = EAGAIN); + + Succeeded := Result = 0; + + if Succeeded then + + -- The following needs significant commenting ??? + + if T.Common.Task_Info /= null then + T.Common.Base_Priority := T.Common.Task_Info.Priority; + Set_Priority (T, T.Common.Task_Info.Priority); + else + Set_Priority (T, Priority); + end if; + end if; + + Result := pthread_attr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_Id) is + Result : Interfaces.C.int; + Tmp : Task_Id := T; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + + begin + if not Single_Lock then + Result := pthread_mutex_destroy (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_cond_destroy (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + Free (Tmp); + + if Is_Self then + Specific.Set (null); + end if; + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + Specific.Set (null); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_Id) is + Result : Interfaces.C.int; + begin + if Abort_Handler_Installed then + Result := + pthread_kill + (T.Common.LL.Thread, + Signal (System.Interrupt_Management.Abort_Task_Interrupt)); + pragma Assert (Result = 0); + end if; + end Abort_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (S : in out Suspension_Object) is + Mutex_Attr : aliased pthread_mutexattr_t; + Cond_Attr : aliased pthread_condattr_t; + Result : Interfaces.C.int; + + begin + -- Initialize internal state (always to False (RM D.10(6)) + + S.State := False; + S.Waiting := False; + + -- Initialize internal mutex + + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + + -- Initialize internal condition variable + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + if Result = ENOMEM then + raise Storage_Error; + end if; + end if; + + Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + if Result = ENOMEM then + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + raise Storage_Error; + end if; + end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + end Initialize; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + -- Destroy internal mutex + + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + -- Destroy internal condition variable + + Result := pthread_cond_destroy (S.CV'Access); + pragma Assert (Result = 0); + end Finalize; + + ------------------- + -- Current_State -- + ------------------- + + function Current_State (S : Suspension_Object) return Boolean is + begin + -- We do not want to use lock on this read operation. State is marked + -- as Atomic so that we ensure that the value retrieved is correct. + + return S.State; + end Current_State; + + --------------- + -- Set_False -- + --------------- + + procedure Set_False (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + S.State := False; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end Set_False; + + -------------- + -- Set_True -- + -------------- + + procedure Set_True (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + -- If there is already a task waiting on this suspension object then + -- we resume it, leaving the state of the suspension object to False, + -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves + -- the state to True. + + if S.Waiting then + S.Waiting := False; + S.State := False; + + Result := pthread_cond_signal (S.CV'Access); + pragma Assert (Result = 0); + + else + S.State := True; + end if; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end Set_True; + + ------------------------ + -- Suspend_Until_True -- + ------------------------ + + procedure Suspend_Until_True (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + if S.Waiting then + + -- Program_Error must be raised upon calling Suspend_Until_True + -- if another task is already waiting on that suspension object + -- (RM D.10(10)). + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + + raise Program_Error; + else + -- Suspend the task if the state is False. Otherwise, the task + -- continues its execution, and the state of the suspension object + -- is set to False (ARM D.10 par. 9). + + if S.State then + S.State := False; + else + S.Waiting := True; + + loop + -- Loop in case pthread_cond_wait returns earlier than expected + -- (e.g. in case of EINTR caused by a signal). + + Result := pthread_cond_wait (S.CV'Access, S.L'Access); + pragma Assert (Result = 0 or else Result = EINTR); + + exit when not S.Waiting; + end loop; + end if; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end if; + end Suspend_Until_True; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy version + + function Check_Exit (Self_ID : ST.Task_Id) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_Id is + begin + return Environment_Task_Id; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + pragma Unreferenced (T); + pragma Unreferenced (Thread_Self); + begin + return False; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + pragma Unreferenced (T); + pragma Unreferenced (Thread_Self); + begin + return False; + end Resume_Task; + + -------------------- + -- Stop_All_Tasks -- + -------------------- + + procedure Stop_All_Tasks is + begin + null; + end Stop_All_Tasks; + + --------------- + -- Stop_Task -- + --------------- + + function Stop_Task (T : ST.Task_Id) return Boolean is + pragma Unreferenced (T); + begin + return False; + end Stop_Task; + + ------------------- + -- Continue_Task -- + ------------------- + + function Continue_Task (T : ST.Task_Id) return Boolean is + pragma Unreferenced (T); + begin + return False; + end Continue_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_Id) is + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + Tmp_Set : aliased sigset_t; + Result : Interfaces.C.int; + + function State + (Int : System.Interrupt_Management.Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state. Defined in a-init.c. The input argument is + -- the interrupt number, and the result is one of the following: + + Default : constant Character := 's'; + -- 'n' this interrupt not set by any Interrupt_State pragma + -- 'u' Interrupt_State pragma set state to User + -- 'r' Interrupt_State pragma set state to Runtime + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + + begin + Environment_Task_Id := Environment_Task; + + Interrupt_Management.Initialize; + + -- Initialize the lock used to synchronize chain of all ATCBs + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + Specific.Initialize (Environment_Task); + + -- Make environment task known here because it doesn't go through + -- Activate_Tasks, which does it for all other tasks. + + Known_Tasks (Known_Tasks'First) := Environment_Task; + Environment_Task.Known_Tasks_Index := Known_Tasks'First; + + Enter_Task (Environment_Task); + + -- Prepare the set of signals that should unblocked in all tasks + + Result := sigemptyset (Unblocked_Signal_Mask'Access); + pragma Assert (Result = 0); + + for J in Interrupt_Management.Interrupt_ID loop + if System.Interrupt_Management.Keep_Unmasked (J) then + Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); + pragma Assert (Result = 0); + end if; + end loop; + + if State + (System.Interrupt_Management.Abort_Task_Interrupt) /= Default + then + act.sa_flags := 0; + act.sa_handler := Abort_Handler'Address; + + Result := sigemptyset (Tmp_Set'Access); + pragma Assert (Result = 0); + act.sa_mask := Tmp_Set; + + Result := + sigaction + (Signal (System.Interrupt_Management.Abort_Task_Interrupt), + act'Unchecked_Access, + old_act'Unchecked_Access); + pragma Assert (Result = 0); + Abort_Handler_Installed := True; + end if; + end Initialize; + +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb new file mode 100644 index 000000000..db6ac9ff5 --- /dev/null +++ b/gcc/ada/s-taprop-linux.adb @@ -0,0 +1,1354 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, 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 a GNU/Linux (GNU/LinuxThreads) version of this package + +-- This package contains all the GNULL primitives that interface directly with +-- the underlying OS. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +with Interfaces.C; + +with System.Task_Info; +with System.Tasking.Debug; +with System.Interrupt_Management; +with System.OS_Primitives; +with System.Stack_Checking.Operations; +with System.Multiprocessors; + +with System.Soft_Links; +-- We use System.Soft_Links instead of System.Tasking.Initialization +-- because the later is a higher level package that we shouldn't depend on. +-- For example when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Stages. + +package body System.Task_Primitives.Operations is + + package SSL renames System.Soft_Links; + package SC renames System.Stack_Checking.Operations; + + use System.Tasking.Debug; + use System.Tasking; + use Interfaces.C; + use System.OS_Interface; + use System.Parameters; + use System.OS_Primitives; + use System.Task_Info; + + ---------------- + -- Local Data -- + ---------------- + + -- The followings are logically constants, but need to be initialized + -- at run time. + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + ATCB_Key : aliased pthread_key_t; + -- Key used to find the Ada Task_Id associated with a thread + + Environment_Task_Id : Task_Id; + -- A variable to hold Task_Id for the environment task + + Unblocked_Signal_Mask : aliased sigset_t; + -- The set of signals that should be unblocked in all tasks + + -- The followings are internal configuration constants needed + + Next_Serial_Number : Task_Serial_Number := 100; + -- We start at 100 (reserve some special values for using in error checks) + + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + -- The following are effectively constants, but they need to be initialized + -- by calling a pthread_ function. + + Mutex_Attr : aliased pthread_mutexattr_t; + Cond_Attr : aliased pthread_condattr_t; + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads) + + Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0; + -- Whether to use an alternate signal stack for stack overflows + + Abort_Handler_Installed : Boolean := False; + -- True if a handler for the abort signal is installed + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + procedure Initialize (Environment_Task : Task_Id); + pragma Inline (Initialize); + -- Initialize various data needed by this package + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does executing thread have a TCB? + + procedure Set (Self_Id : Task_Id); + pragma Inline (Set); + -- Set the self id for the current task + + function Self return Task_Id; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task + + end Specific; + + package body Specific is separate; + -- The body of this package is target specific + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; + -- Allocate and Initialize a new ATCB for the current Thread + + function Register_Foreign_Thread + (Thread : Thread_Id) return Task_Id is separate; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + subtype unsigned_long is Interfaces.C.unsigned_long; + + procedure Abort_Handler (signo : Signal); + + function To_pthread_t is new Ada.Unchecked_Conversion + (unsigned_long, System.OS_Interface.pthread_t); + + ------------------- + -- Abort_Handler -- + ------------------- + + procedure Abort_Handler (signo : Signal) is + pragma Unreferenced (signo); + + Self_Id : constant Task_Id := Self; + Result : Interfaces.C.int; + Old_Set : aliased sigset_t; + + begin + -- It's not safe to raise an exception when using GCC ZCX mechanism. + -- Note that we still need to install a signal handler, since in some + -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we + -- need to send the Abort signal to a task. + + if ZCX_By_Default and then GCC_ZCX_Support then + return; + end if; + + if Self_Id.Deferral_Level = 0 + and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level + and then not Self_Id.Aborting + then + Self_Id.Aborting := True; + + -- Make sure signals used for RTS internal purpose are unmasked + + Result := + pthread_sigmask + (SIG_UNBLOCK, + Unblocked_Signal_Mask'Access, + Old_Set'Access); + pragma Assert (Result = 0); + + raise Standard'Abort_Signal; + end if; + end Abort_Handler; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ----------------- + -- Stack_Guard -- + ----------------- + + -- The underlying thread system extends the memory (up to 2MB) when needed + + procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is + pragma Unreferenced (T); + pragma Unreferenced (On); + begin + null; + end Stack_Guard; + + -------------------- + -- Get_Thread_Id -- + -------------------- + + function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_Id renames Specific.Self; + + --------------------- + -- Initialize_Lock -- + --------------------- + + -- Note: mutexes and cond_variables needed per-task basis are initialized + -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such + -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any + -- status change of RTS. Therefore raising Storage_Error in the following + -- routines should be able to be handled safely. + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : not null access Lock) + is + pragma Unreferenced (Prio); + + Result : Interfaces.C.int; + + begin + Result := pthread_mutex_init (L, Mutex_Attr'Access); + + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error with "Failed to allocate a lock"; + end if; + end Initialize_Lock; + + procedure Initialize_Lock + (L : not null access RTS_Lock; + Level : Lock_Level) + is + pragma Unreferenced (Level); + + Result : Interfaces.C.int; + + begin + Result := pthread_mutex_init (L, Mutex_Attr'Access); + + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : not null access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + procedure Finalize_Lock (L : not null access RTS_Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_lock (L); + Ceiling_Violation := Result = EINVAL; + + -- Assume the cause of EINVAL is a priority ceiling violation + + pragma Assert (Result = 0 or else Result = EINVAL); + end Write_Lock; + + procedure Write_Lock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_lock (L); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_Id) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_lock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : not null access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end Unlock; + + procedure Unlock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock (T : Task_Id) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_unlock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + ----------------- + -- Set_Ceiling -- + ----------------- + + -- Dynamic priority ceilings are not supported by the underlying system + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + pragma Unreferenced (L, Prio); + begin + null; + end Set_Ceiling; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : Task_Id; + Reason : System.Tasking.Task_States) + is + pragma Unreferenced (Reason); + + Result : Interfaces.C.int; + + begin + pragma Assert (Self_ID = Self); + + Result := + pthread_cond_wait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access)); + + -- EINTR is not considered a failure + + pragma Assert (Result = 0 or else Result = EINTR); + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + -- This is for use within the run-time system, so abort is + -- assumed to be already deferred, and the caller should be + -- holding its own ATCB lock. + + procedure Timed_Sleep + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Unreferenced (Reason); + + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + Timedout := True; + Yielded := False; + + Abs_Time := + (if Mode = Relative + then Duration'Min (Time, Max_Sensible_Delay) + Check_Time + else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); + + if Abs_Time > Check_Time then + Request := To_Timespec (Abs_Time); + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); + + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + if Result = 0 or else Result = EINTR then + + -- Somebody may have called Wakeup for us + + Timedout := False; + exit; + end if; + + pragma Assert (Result = ETIMEDOUT); + end loop; + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + -- This is for use in implementing delay statements, so we assume the + -- caller is abort-deferred but is holding no locks. + + procedure Timed_Delay + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes) + is + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; + Abs_Time : Duration; + Request : aliased timespec; + + Result : Interfaces.C.int; + pragma Warnings (Off, Result); + + begin + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + Abs_Time := + (if Mode = Relative + then Time + Check_Time + else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); + + if Abs_Time > Check_Time then + Request := To_Timespec (Abs_Time); + Self_ID.Common.State := Delay_Sleep; + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); + + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + pragma Assert (Result = 0 or else + Result = ETIMEDOUT or else + Result = EINTR); + end loop; + + Self_ID.Common.State := Runnable; + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + Result := sched_yield; + end Timed_Delay; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + use Interfaces; + + type timeval is array (1 .. 2) of C.long; + + procedure timeval_to_duration + (T : not null access timeval; + sec : not null access C.long; + usec : not null access C.long); + pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); + + Micro : constant := 10**6; + sec : aliased C.long; + usec : aliased C.long; + TV : aliased timeval; + Result : int; + + function gettimeofday + (Tv : access timeval; + Tz : System.Address := System.Null_Address) return int; + pragma Import (C, gettimeofday, "gettimeofday"); + + begin + Result := gettimeofday (TV'Access, System.Null_Address); + pragma Assert (Result = 0); + timeval_to_duration (TV'Access, sec'Access, usec'Access); + return Duration (sec) + Duration (usec) / Micro; + end Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + return 10#1.0#E-6; + end RT_Resolution; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + begin + Result := pthread_cond_signal (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + Result : Interfaces.C.int; + pragma Unreferenced (Result); + begin + if Do_Yield then + Result := sched_yield; + end if; + end Yield; + + ------------------ + -- Set_Priority -- + ------------------ + + procedure Set_Priority + (T : Task_Id; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + pragma Unreferenced (Loss_Of_Inheritance); + + Result : Interfaces.C.int; + Param : aliased struct_sched_param; + + function Get_Policy (Prio : System.Any_Priority) return Character; + pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); + -- Get priority specific dispatching policy + + Priority_Specific_Policy : constant Character := Get_Policy (Prio); + -- Upper case first character of the policy name corresponding to the + -- task as set by a Priority_Specific_Dispatching pragma. + + begin + T.Common.Current_Priority := Prio; + + -- Priorities are 1 .. 99 on GNU/Linux, so we map 0 .. 98 to 1 .. 99 + + Param.sched_priority := Interfaces.C.int (Prio) + 1; + + if Dispatching_Policy = 'R' + or else Priority_Specific_Policy = 'R' + or else Time_Slice_Val > 0 + then + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_RR, Param'Access); + + elsif Dispatching_Policy = 'F' + or else Priority_Specific_Policy = 'F' + or else Time_Slice_Val = 0 + then + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_FIFO, Param'Access); + + else + Param.sched_priority := 0; + Result := + pthread_setschedparam + (T.Common.LL.Thread, + SCHED_OTHER, Param'Access); + end if; + + pragma Assert (Result = 0 or else Result = EPERM); + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_Id) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_Id) is + begin + if Self_ID.Common.Task_Info /= null + and then Self_ID.Common.Task_Info.CPU_Affinity = No_CPU + then + raise Invalid_CPU_Number; + end if; + + Self_ID.Common.LL.Thread := pthread_self; + Self_ID.Common.LL.LWP := lwp_self; + + Specific.Set (Self_ID); + + if Use_Alternate_Stack + and then Self_ID.Common.Task_Alternate_Stack /= Null_Address + then + declare + Stack : aliased stack_t; + Result : Interfaces.C.int; + begin + Stack.ss_sp := Self_ID.Common.Task_Alternate_Stack; + Stack.ss_size := Alternate_Stack_Size; + Stack.ss_flags := 0; + Result := sigaltstack (Stack'Access, null); + pragma Assert (Result = 0); + end; + end if; + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_Id is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (pthread_self); + end if; + end Register_Foreign_Thread; + + -------------------- + -- Initialize_TCB -- + -------------------- + + procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is + Result : Interfaces.C.int; + + begin + -- Give the task a unique serial number + + Self_ID.Serial_Number := Next_Serial_Number; + Next_Serial_Number := Next_Serial_Number + 1; + pragma Assert (Next_Serial_Number /= 0); + + Self_ID.Common.LL.Thread := To_pthread_t (-1); + + if not Single_Lock then + Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, + Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Succeeded := False; + return; + end if; + end if; + + Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, + Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Succeeded := True; + else + if not Single_Lock then + Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Succeeded := False; + end if; + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_Id; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + Attributes : aliased pthread_attr_t; + Adjusted_Stack_Size : Interfaces.C.size_t; + Result : Interfaces.C.int; + + use type System.Multiprocessors.CPU_Range; + + begin + Adjusted_Stack_Size := + Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size); + + Result := pthread_attr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := + pthread_attr_setstacksize + (Attributes'Access, Adjusted_Stack_Size); + pragma Assert (Result = 0); + + Result := + pthread_attr_setdetachstate + (Attributes'Access, PTHREAD_CREATE_DETACHED); + pragma Assert (Result = 0); + + -- Set the required attributes for the creation of the thread + + -- Note: Previously, we called pthread_setaffinity_np (after thread + -- creation but before thread activation) to set the affinity but it was + -- not behaving as expected. Setting the required attributes for the + -- creation of the thread works correctly and it is more appropriate. + + -- Do nothing if required support not provided by the operating system + + if pthread_attr_setaffinity_np'Address = System.Null_Address then + null; + + -- Support is available + + elsif T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then + declare + CPU_Set : aliased cpu_set_t := (bits => (others => False)); + begin + CPU_Set.bits (Integer (T.Common.Base_CPU)) := True; + Result := + pthread_attr_setaffinity_np + (Attributes'Access, + CPU_SETSIZE / 8, + CPU_Set'Access); + pragma Assert (Result = 0); + end; + + -- Handle Task_Info + + elsif T.Common.Task_Info /= null + and then T.Common.Task_Info.CPU_Affinity /= Task_Info.Any_CPU + then + Result := + pthread_attr_setaffinity_np + (Attributes'Access, + CPU_SETSIZE / 8, + T.Common.Task_Info.CPU_Affinity'Access); + pragma Assert (Result = 0); + end if; + + -- Since the initial signal mask of a thread is inherited from the + -- creator, and the Environment task has all its signals masked, we + -- do not need to manipulate caller's signal mask at this point. + -- All tasks in RTS will have All_Tasks_Mask initially. + + Result := pthread_create + (T.Common.LL.Thread'Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); + pragma Assert + (Result = 0 or else Result = EAGAIN or else Result = ENOMEM); + + if Result /= 0 then + Succeeded := False; + Result := pthread_attr_destroy (Attributes'Access); + pragma Assert (Result = 0); + return; + end if; + + Succeeded := True; + + Result := pthread_attr_destroy (Attributes'Access); + pragma Assert (Result = 0); + + Set_Priority (T, Priority); + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_Id) is + Result : Interfaces.C.int; + Tmp : Task_Id := T; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + + begin + if not Single_Lock then + Result := pthread_mutex_destroy (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_cond_destroy (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + SC.Invalidate_Stack_Cache (T.Common.Compiler_Data.Pri_Stack_Info'Access); + Free (Tmp); + + if Is_Self then + Specific.Set (null); + end if; + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + Specific.Set (null); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_Id) is + Result : Interfaces.C.int; + begin + if Abort_Handler_Installed then + Result := + pthread_kill + (T.Common.LL.Thread, + Signal (System.Interrupt_Management.Abort_Task_Interrupt)); + pragma Assert (Result = 0); + end if; + end Abort_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + -- Initialize internal state (always to False (RM D.10(6))) + + S.State := False; + S.Waiting := False; + + -- Initialize internal mutex + + Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); + + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + -- Initialize internal condition variable + + Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); + + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + if Result = ENOMEM then + raise Storage_Error; + end if; + end if; + end Initialize; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + -- Destroy internal mutex + + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + -- Destroy internal condition variable + + Result := pthread_cond_destroy (S.CV'Access); + pragma Assert (Result = 0); + end Finalize; + + ------------------- + -- Current_State -- + ------------------- + + function Current_State (S : Suspension_Object) return Boolean is + begin + -- We do not want to use lock on this read operation. State is marked + -- as Atomic so that we ensure that the value retrieved is correct. + + return S.State; + end Current_State; + + --------------- + -- Set_False -- + --------------- + + procedure Set_False (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + S.State := False; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end Set_False; + + -------------- + -- Set_True -- + -------------- + + procedure Set_True (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + -- If there is already a task waiting on this suspension object then + -- we resume it, leaving the state of the suspension object to False, + -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves + -- the state to True. + + if S.Waiting then + S.Waiting := False; + S.State := False; + + Result := pthread_cond_signal (S.CV'Access); + pragma Assert (Result = 0); + + else + S.State := True; + end if; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end Set_True; + + ------------------------ + -- Suspend_Until_True -- + ------------------------ + + procedure Suspend_Until_True (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + if S.Waiting then + + -- Program_Error must be raised upon calling Suspend_Until_True + -- if another task is already waiting on that suspension object + -- (RM D.10(10)). + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + + raise Program_Error; + + else + -- Suspend the task if the state is False. Otherwise, the task + -- continues its execution, and the state of the suspension object + -- is set to False (ARM D.10 par. 9). + + if S.State then + S.State := False; + else + S.Waiting := True; + + loop + -- Loop in case pthread_cond_wait returns earlier than expected + -- (e.g. in case of EINTR caused by a signal). This should not + -- happen with the current Linux implementation of pthread, but + -- POSIX does not guarantee it so this may change in future. + + Result := pthread_cond_wait (S.CV'Access, S.L'Access); + pragma Assert (Result = 0 or else Result = EINTR); + + exit when not S.Waiting; + end loop; + end if; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end if; + end Suspend_Until_True; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy version + + function Check_Exit (Self_ID : ST.Task_Id) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_Id is + begin + return Environment_Task_Id; + end Environment_Task; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + begin + if T.Common.LL.Thread /= Thread_Self then + return pthread_kill (T.Common.LL.Thread, SIGSTOP) = 0; + else + return True; + end if; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + begin + if T.Common.LL.Thread /= Thread_Self then + return pthread_kill (T.Common.LL.Thread, SIGCONT) = 0; + else + return True; + end if; + end Resume_Task; + + -------------------- + -- Stop_All_Tasks -- + -------------------- + + procedure Stop_All_Tasks is + begin + null; + end Stop_All_Tasks; + + --------------- + -- Stop_Task -- + --------------- + + function Stop_Task (T : ST.Task_Id) return Boolean is + pragma Unreferenced (T); + begin + return False; + end Stop_Task; + + ------------------- + -- Continue_Task -- + ------------------- + + function Continue_Task (T : ST.Task_Id) return Boolean is + pragma Unreferenced (T); + begin + return False; + end Continue_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_Id) is + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + Tmp_Set : aliased sigset_t; + Result : Interfaces.C.int; + -- Whether to use an alternate signal stack for stack overflows + + function State + (Int : System.Interrupt_Management.Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state. Defined in a-init.c + -- The input argument is the interrupt number, + -- and the result is one of the following: + + Default : constant Character := 's'; + -- 'n' this interrupt not set by any Interrupt_State pragma + -- 'u' Interrupt_State pragma set state to User + -- 'r' Interrupt_State pragma set state to Runtime + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + + use type System.Multiprocessors.CPU_Range; + + begin + Environment_Task_Id := Environment_Task; + + Interrupt_Management.Initialize; + + -- Prepare the set of signals that should be unblocked in all tasks + + Result := sigemptyset (Unblocked_Signal_Mask'Access); + pragma Assert (Result = 0); + + for J in Interrupt_Management.Interrupt_ID loop + if System.Interrupt_Management.Keep_Unmasked (J) then + Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); + pragma Assert (Result = 0); + end if; + end loop; + + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0); + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0); + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + -- Initialize the global RTS lock + + Specific.Initialize (Environment_Task); + + if Use_Alternate_Stack then + Environment_Task.Common.Task_Alternate_Stack := + Alternate_Stack'Address; + end if; + + -- Make environment task known here because it doesn't go through + -- Activate_Tasks, which does it for all other tasks. + + Known_Tasks (Known_Tasks'First) := Environment_Task; + Environment_Task.Known_Tasks_Index := Known_Tasks'First; + + Enter_Task (Environment_Task); + + if State + (System.Interrupt_Management.Abort_Task_Interrupt) /= Default + then + act.sa_flags := 0; + act.sa_handler := Abort_Handler'Address; + + Result := sigemptyset (Tmp_Set'Access); + pragma Assert (Result = 0); + act.sa_mask := Tmp_Set; + + Result := + sigaction + (Signal (Interrupt_Management.Abort_Task_Interrupt), + act'Unchecked_Access, + old_act'Unchecked_Access); + pragma Assert (Result = 0); + Abort_Handler_Installed := True; + end if; + + -- pragma CPU for the environment task + + if pthread_setaffinity_np'Address /= System.Null_Address + and then Environment_Task.Common.Base_CPU /= + System.Multiprocessors.Not_A_Specific_CPU + then + declare + CPU_Set : aliased cpu_set_t := (bits => (others => False)); + begin + CPU_Set.bits (Integer (Environment_Task.Common.Base_CPU)) := True; + Result := + pthread_setaffinity_np + (Environment_Task.Common.LL.Thread, + CPU_SETSIZE / 8, + CPU_Set'Access); + pragma Assert (Result = 0); + end; + end if; + end Initialize; + +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-lynxos.adb b/gcc/ada/s-taprop-lynxos.adb new file mode 100644 index 000000000..d553f1e69 --- /dev/null +++ b/gcc/ada/s-taprop-lynxos.adb @@ -0,0 +1,1423 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a LynxOS version of this file, adapted to make SCHED_FIFO and +-- ceiling locking (Annex D compliance) work properly. + +-- This package contains all the GNULL primitives that interface directly with +-- the underlying OS. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +with Ada.Unchecked_Deallocation; + +with Interfaces.C; + +with System.Tasking.Debug; +with System.Interrupt_Management; +with System.OS_Primitives; +with System.Task_Info; + +with System.Soft_Links; +-- We use System.Soft_Links instead of System.Tasking.Initialization +-- because the later is a higher level package that we shouldn't depend on. +-- For example when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Stages. + +package body System.Task_Primitives.Operations is + + package SSL renames System.Soft_Links; + + use System.Tasking.Debug; + use System.Tasking; + use Interfaces.C; + use System.OS_Interface; + use System.Parameters; + use System.OS_Primitives; + + ---------------- + -- Local Data -- + ---------------- + + -- The followings are logically constants, but need to be initialized + -- at run time. + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + ATCB_Key : aliased pthread_key_t; + -- Key used to find the Ada Task_Id associated with a thread + + Environment_Task_Id : Task_Id; + -- A variable to hold Task_Id for the environment task + + Locking_Policy : Character; + pragma Import (C, Locking_Policy, "__gl_locking_policy"); + -- Value of the pragma Locking_Policy: + -- 'C' for Ceiling_Locking + -- 'I' for Inherit_Locking + -- ' ' for none. + + Unblocked_Signal_Mask : aliased sigset_t; + -- The set of signals that should unblocked in all tasks + + -- The followings are internal configuration constants needed + + Next_Serial_Number : Task_Serial_Number := 100; + -- We start at 100, to reserve some special values for + -- using in error checking. + + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads) + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + procedure Initialize (Environment_Task : Task_Id); + pragma Inline (Initialize); + -- Initialize various data needed by this package + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does the current thread have an ATCB? + + procedure Set (Self_Id : Task_Id); + pragma Inline (Set); + -- Set the self id for the current task + + function Self return Task_Id; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task + + end Specific; + + package body Specific is separate; + -- The body of this package is target specific + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; + -- Allocate and Initialize a new ATCB for the current Thread + + function Register_Foreign_Thread + (Thread : Thread_Id) return Task_Id is separate; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Abort_Handler (Sig : Signal); + -- Signal handler used to implement asynchronous abort + + procedure Set_OS_Priority (T : Task_Id; Prio : System.Any_Priority); + -- This procedure calls the scheduler of the OS to set thread's priority + + ------------------- + -- Abort_Handler -- + ------------------- + + procedure Abort_Handler (Sig : Signal) is + pragma Unreferenced (Sig); + + T : constant Task_Id := Self; + Result : Interfaces.C.int; + Old_Set : aliased sigset_t; + + begin + -- It is not safe to raise an exception when using ZCX and the GCC + -- exception handling mechanism. + + if ZCX_By_Default and then GCC_ZCX_Support then + return; + end if; + + if T.Deferral_Level = 0 + and then T.Pending_ATC_Level < T.ATC_Nesting_Level + and then not T.Aborting + then + T.Aborting := True; + + -- Make sure signals used for RTS internal purpose are unmasked + + Result := + pthread_sigmask + (SIG_UNBLOCK, + Unblocked_Signal_Mask'Access, + Old_Set'Access); + pragma Assert (Result = 0); + + raise Standard'Abort_Signal; + end if; + end Abort_Handler; + + ----------------- + -- Stack_Guard -- + ----------------- + + procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is + Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread); + Guard_Page_Address : Address; + + Res : Interfaces.C.int; + + begin + if Stack_Base_Available then + + -- Compute the guard page address + + Guard_Page_Address := + Stack_Base - (Stack_Base mod Get_Page_Size) + Get_Page_Size; + + if On then + Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_ON); + else + Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_OFF); + end if; + + pragma Assert (Res = 0); + end if; + end Stack_Guard; + + -------------------- + -- Get_Thread_Id -- + -------------------- + + function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_Id renames Specific.Self; + + --------------------- + -- Initialize_Lock -- + --------------------- + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : not null access Lock) + is + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + if Locking_Policy = 'C' then + L.Ceiling := Prio; + end if; + + Result := pthread_mutex_init (L.Mutex'Access, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + procedure Initialize_Lock + (L : not null access RTS_Lock; + Level : Lock_Level) + is + pragma Unreferenced (Level); + + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutex_init (L, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Attributes'Access); + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : not null access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L.Mutex'Access); + pragma Assert (Result = 0); + end Finalize_Lock; + + procedure Finalize_Lock (L : not null access RTS_Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is + Result : Interfaces.C.int; + T : constant Task_Id := Self; + + begin + if Locking_Policy = 'C' then + if T.Common.Current_Priority > L.Ceiling then + Ceiling_Violation := True; + return; + end if; + + L.Saved_Priority := T.Common.Current_Priority; + + if T.Common.Current_Priority < L.Ceiling then + Set_OS_Priority (T, L.Ceiling); + end if; + end if; + + Result := pthread_mutex_lock (L.Mutex'Access); + + -- Assume that the cause of EINVAL is a priority ceiling violation + + Ceiling_Violation := (Result = EINVAL); + pragma Assert (Result = 0 or else Result = EINVAL); + end Write_Lock; + + -- No tricks on RTS_Locks + + procedure Write_Lock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_lock (L); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_Id) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_lock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : not null access Lock) is + Result : Interfaces.C.int; + T : constant Task_Id := Self; + + begin + Result := pthread_mutex_unlock (L.Mutex'Access); + pragma Assert (Result = 0); + + if Locking_Policy = 'C' then + if T.Common.Current_Priority > L.Saved_Priority then + Set_OS_Priority (T, L.Saved_Priority); + end if; + end if; + end Unlock; + + procedure Unlock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock (T : Task_Id) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_unlock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + ----------------- + -- Set_Ceiling -- + ----------------- + + -- Dynamic priority ceilings are not supported by the underlying system + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + pragma Unreferenced (L, Prio); + begin + null; + end Set_Ceiling; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : Task_Id; + Reason : System.Tasking.Task_States) + is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + + begin + if Single_Lock then + Result := + pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + else + Result := + pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + end if; + + -- EINTR is not considered a failure + + pragma Assert (Result = 0 or else Result = EINTR); + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + -- This is for use within the run-time system, so abort is + -- assumed to be already deferred, and the caller should be + -- holding its own ATCB lock. + + procedure Timed_Sleep + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Unreferenced (Reason); + + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; + Rel_Time : Duration; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + Timedout := True; + Yielded := False; + + if Mode = Relative then + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time); + end if; + + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); + end if; + end if; + + if Abs_Time > Check_Time then + if Relative_Timed_Wait then + Request := To_Timespec (Rel_Time); + else + Request := To_Timespec (Abs_Time); + end if; + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + if Single_Lock then + Result := + pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access, + Request'Access); + + else + Result := + pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, + Request'Access); + end if; + + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + if Result = 0 or Result = EINTR then + + -- Somebody may have called Wakeup for us + + Timedout := False; + exit; + end if; + + pragma Assert (Result = ETIMEDOUT); + end loop; + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + -- This is for use in implementing delay statements, so we assume + -- the caller is abort-deferred but is holding no locks. + + procedure Timed_Delay + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes) + is + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; + Abs_Time : Duration; + Rel_Time : Duration; + Request : aliased timespec; + + Result : Interfaces.C.int; + pragma Warnings (Off, Result); + + begin + if Single_Lock then + Lock_RTS; + end if; + + -- Comments needed in code below ??? + + Write_Lock (Self_ID); + + if Mode = Relative then + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time); + end if; + + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); + end if; + end if; + + if Abs_Time > Check_Time then + if Relative_Timed_Wait then + Request := To_Timespec (Rel_Time); + else + Request := To_Timespec (Abs_Time); + end if; + + Self_ID.Common.State := Delay_Sleep; + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + if Single_Lock then + Result := + pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock'Access, + Request'Access); + else + Result := + pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L'Access, + Request'Access); + end if; + + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + pragma Assert (Result = 0 or else + Result = ETIMEDOUT or else + Result = EINTR); + end loop; + + Self_ID.Common.State := Runnable; + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + Result := sched_yield; + end Timed_Delay; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + TS : aliased timespec; + Result : Interfaces.C.int; + begin + Result := + clock_gettime + (clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access); + pragma Assert (Result = 0); + return To_Duration (TS); + end Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + Res : aliased timespec; + Result : Interfaces.C.int; + begin + Result := + clock_getres + (clock_id => CLOCK_REALTIME, res => Res'Unchecked_Access); + pragma Assert (Result = 0); + return To_Duration (Res); + end RT_Resolution; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + begin + Result := pthread_cond_signal (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + Result : Interfaces.C.int; + pragma Unreferenced (Result); + begin + if Do_Yield then + Result := sched_yield; + end if; + end Yield; + + ------------------ + -- Set_Priority -- + ------------------ + + procedure Set_OS_Priority (T : Task_Id; Prio : System.Any_Priority) is + Result : Interfaces.C.int; + Param : aliased struct_sched_param; + + function Get_Policy (Prio : System.Any_Priority) return Character; + pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); + -- Get priority specific dispatching policy + + Priority_Specific_Policy : constant Character := Get_Policy (Prio); + -- Upper case first character of the policy name corresponding to the + -- task as set by a Priority_Specific_Dispatching pragma. + + begin + Param.sched_priority := Interfaces.C.int (Prio); + + if Time_Slice_Supported + and then (Dispatching_Policy = 'R' + or else Priority_Specific_Policy = 'R' + or else Time_Slice_Val > 0) + then + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_RR, Param'Access); + + elsif Dispatching_Policy = 'F' + or else Priority_Specific_Policy = 'F' + or else Time_Slice_Val = 0 + then + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_FIFO, Param'Access); + + else + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_OTHER, Param'Access); + end if; + + pragma Assert (Result = 0); + end Set_OS_Priority; + + type Prio_Array_Type is array (System.Any_Priority) of Integer; + pragma Atomic_Components (Prio_Array_Type); + Prio_Array : Prio_Array_Type; + -- Comments needed for these declarations ??? + + procedure Set_Priority + (T : Task_Id; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + Array_Item : Integer; + + begin + Set_OS_Priority (T, Prio); + + if Locking_Policy = 'C' then + + -- Annex D requirements: loss of inheritance puts task at the start + -- of the queue for that prio; copied from 5ztaprop (VxWorks). + + if Loss_Of_Inheritance + and then Prio < T.Common.Current_Priority then + + Array_Item := Prio_Array (T.Common.Base_Priority) + 1; + Prio_Array (T.Common.Base_Priority) := Array_Item; + + loop + Yield; + exit when Array_Item = Prio_Array (T.Common.Base_Priority) + or else Prio_Array (T.Common.Base_Priority) = 1; + end loop; + + Prio_Array (T.Common.Base_Priority) := + Prio_Array (T.Common.Base_Priority) - 1; + end if; + end if; + + T.Common.Current_Priority := Prio; + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_Id) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_Id) is + begin + Self_ID.Common.LL.Thread := pthread_self; + Self_ID.Common.LL.LWP := lwp_self; + + Specific.Set (Self_ID); + + Lock_RTS; + + for J in Known_Tasks'Range loop + if Known_Tasks (J) = null then + Known_Tasks (J) := Self_ID; + Self_ID.Known_Tasks_Index := J; + exit; + end if; + end loop; + + Unlock_RTS; + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_Id is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (pthread_self); + end if; + end Register_Foreign_Thread; + + -------------------- + -- Initialize_TCB -- + -------------------- + + procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is + Mutex_Attr : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + Cond_Attr : aliased pthread_condattr_t; + + begin + -- Give the task a unique serial number + + Self_ID.Serial_Number := Next_Serial_Number; + Next_Serial_Number := Next_Serial_Number + 1; + pragma Assert (Next_Serial_Number /= 0); + + if not Single_Lock then + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := + pthread_mutex_init + (Self_ID.Common.LL.L'Access, Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := + pthread_cond_init (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result = 0 then + Succeeded := True; + else + if not Single_Lock then + Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Succeeded := False; + end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_Id; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + Attributes : aliased pthread_attr_t; + Adjusted_Stack_Size : Interfaces.C.size_t; + Result : Interfaces.C.int; + + use System.Task_Info; + + begin + Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); + + if Stack_Base_Available then + + -- If Stack Checking is supported then allocate 2 additional pages: + + -- In the worst case, stack is allocated at something like + -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages + -- to be sure the effective stack size is greater than what + -- has been asked. + + Adjusted_Stack_Size := Adjusted_Stack_Size + 2 * Get_Page_Size; + end if; + + Result := pthread_attr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := + pthread_attr_setdetachstate + (Attributes'Access, PTHREAD_CREATE_DETACHED); + pragma Assert (Result = 0); + + Result := + pthread_attr_setstacksize + (Attributes'Access, Adjusted_Stack_Size); + pragma Assert (Result = 0); + + if T.Common.Task_Info /= Default_Scope then + + -- We are assuming that Scope_Type has the same values than the + -- corresponding C macros + + Result := + pthread_attr_setscope + (Attributes'Access, Task_Info_Type'Pos (T.Common.Task_Info)); + pragma Assert (Result = 0); + end if; + + -- Since the initial signal mask of a thread is inherited from the + -- creator, and the Environment task has all its signals masked, we + -- do not need to manipulate caller's signal mask at this point. + -- All tasks in RTS will have All_Tasks_Mask initially. + + Result := + pthread_create + (T.Common.LL.Thread'Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); + pragma Assert (Result = 0 or else Result = EAGAIN); + + Succeeded := Result = 0; + + Result := pthread_attr_destroy (Attributes'Access); + pragma Assert (Result = 0); + + if Succeeded then + Set_Priority (T, Priority); + end if; + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_Id) is + Result : Interfaces.C.int; + Tmp : Task_Id := T; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + + begin + if not Single_Lock then + Result := pthread_mutex_destroy (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_cond_destroy (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + Free (Tmp); + + if Is_Self then + Result := st_setspecific (ATCB_Key, System.Null_Address); + pragma Assert (Result = 0); + end if; + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + Specific.Set (null); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_Id) is + Result : Interfaces.C.int; + begin + Result := + pthread_kill + (T.Common.LL.Thread, + Signal (System.Interrupt_Management.Abort_Task_Interrupt)); + pragma Assert (Result = 0); + end Abort_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (S : in out Suspension_Object) is + Mutex_Attr : aliased pthread_mutexattr_t; + Cond_Attr : aliased pthread_condattr_t; + Result : Interfaces.C.int; + + begin + -- Initialize internal state (always to False (RM D.10(6))) + + S.State := False; + S.Waiting := False; + + -- Initialize internal mutex + + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + + -- Initialize internal condition variable + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + if Result = ENOMEM then + raise Storage_Error; + end if; + end if; + + Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + if Result = ENOMEM then + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + + raise Storage_Error; + end if; + end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + end Initialize; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + -- Destroy internal mutex + + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + -- Destroy internal condition variable + + Result := pthread_cond_destroy (S.CV'Access); + pragma Assert (Result = 0); + end Finalize; + + ------------------- + -- Current_State -- + ------------------- + + function Current_State (S : Suspension_Object) return Boolean is + begin + -- We do not want to use lock on this read operation. State is marked + -- as Atomic so that we ensure that the value retrieved is correct. + + return S.State; + end Current_State; + + --------------- + -- Set_False -- + --------------- + + procedure Set_False (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + S.State := False; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end Set_False; + + -------------- + -- Set_True -- + -------------- + + procedure Set_True (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + -- If there is already a task waiting on this suspension object then + -- we resume it, leaving the state of the suspension object to False, + -- as specified in (RM D.10(9)). Otherwise, just leave state set True. + + if S.Waiting then + S.Waiting := False; + S.State := False; + + Result := pthread_cond_signal (S.CV'Access); + pragma Assert (Result = 0); + + else + S.State := True; + end if; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end Set_True; + + ------------------------ + -- Suspend_Until_True -- + ------------------------ + + procedure Suspend_Until_True (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + if S.Waiting then + + -- Program_Error must be raised upon calling Suspend_Until_True + -- if another task is already waiting on that suspension object + -- (RM D.10 (10)). + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + + raise Program_Error; + + else + -- Suspend the task if the state is False. Otherwise, the task + -- continues its execution, and the state of the suspension object + -- is set to False (RM D.10(9)). + + if S.State then + S.State := False; + else + S.Waiting := True; + Result := pthread_cond_wait (S.CV'Access, S.L'Access); + end if; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end if; + end Suspend_Until_True; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy version + + function Check_Exit (Self_ID : ST.Task_Id) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_Id is + begin + return Environment_Task_Id; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + pragma Unreferenced (T); + pragma Unreferenced (Thread_Self); + begin + return False; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + pragma Unreferenced (T); + pragma Unreferenced (Thread_Self); + begin + return False; + end Resume_Task; + + -------------------- + -- Stop_All_Tasks -- + -------------------- + + procedure Stop_All_Tasks is + begin + null; + end Stop_All_Tasks; + + --------------- + -- Stop_Task -- + --------------- + + function Stop_Task (T : ST.Task_Id) return Boolean is + pragma Unreferenced (T); + begin + return False; + end Stop_Task; + + ------------------- + -- Continue_Task -- + ------------------- + + function Continue_Task (T : ST.Task_Id) return Boolean is + pragma Unreferenced (T); + begin + return False; + end Continue_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_Id) is + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + Tmp_Set : aliased sigset_t; + Result : Interfaces.C.int; + + function State + (Int : System.Interrupt_Management.Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state. Defined in a-init.c + -- The input argument is the interrupt number, + -- and the result is one of the following: + + Default : constant Character := 's'; + -- 'n' this interrupt not set by any Interrupt_State pragma + -- 'u' Interrupt_State pragma set state to User + -- 'r' Interrupt_State pragma set state to Runtime + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + + begin + Environment_Task_Id := Environment_Task; + + Interrupt_Management.Initialize; + + -- Prepare the set of signals that should unblocked in all tasks + + Result := sigemptyset (Unblocked_Signal_Mask'Access); + pragma Assert (Result = 0); + + for J in Interrupt_Management.Interrupt_ID loop + if System.Interrupt_Management.Keep_Unmasked (J) then + Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); + pragma Assert (Result = 0); + end if; + end loop; + + -- Initialize the lock used to synchronize chain of all ATCBs + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + Specific.Initialize (Environment_Task); + + Enter_Task (Environment_Task); + + -- Install the abort-signal handler + + if State + (System.Interrupt_Management.Abort_Task_Interrupt) /= Default + then + act.sa_flags := 0; + act.sa_handler := Abort_Handler'Address; + + Result := sigemptyset (Tmp_Set'Access); + pragma Assert (Result = 0); + act.sa_mask := Tmp_Set; + + Result := + sigaction + (Signal (System.Interrupt_Management.Abort_Task_Interrupt), + act'Unchecked_Access, + old_act'Unchecked_Access); + + pragma Assert (Result = 0); + end if; + end Initialize; + +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb new file mode 100644 index 000000000..20568ce1c --- /dev/null +++ b/gcc/ada/s-taprop-mingw.adb @@ -0,0 +1,1380 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, 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 a NT (native) version of this package + +-- This package contains all the GNULL primitives that interface directly with +-- the underlying OS. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +with Ada.Unchecked_Deallocation; + +with Interfaces.C; +with Interfaces.C.Strings; + +with System.Multiprocessors; +with System.Tasking.Debug; +with System.OS_Primitives; +with System.Task_Info; +with System.Interrupt_Management; +with System.Win32.Ext; + +with System.Soft_Links; +-- We use System.Soft_Links instead of System.Tasking.Initialization because +-- the later is a higher level package that we shouldn't depend on. For +-- example when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Stages. + +package body System.Task_Primitives.Operations is + + package SSL renames System.Soft_Links; + + use System.Tasking.Debug; + use System.Tasking; + use Interfaces.C; + use Interfaces.C.Strings; + use System.OS_Interface; + use System.Parameters; + use System.OS_Primitives; + use System.Task_Info; + use System.Win32; + use System.Win32.Ext; + + pragma Link_With ("-Xlinker --stack=0x200000,0x1000"); + -- Change the default stack size (2 MB) for tasking programs on Windows. + -- This allows about 1000 tasks running at the same time. Note that + -- we set the stack size for non tasking programs on System unit. + -- Also note that under Windows XP, we use a Windows XP extension to + -- specify the stack size on a per task basis, as done under other OSes. + + --------------------- + -- Local Functions -- + --------------------- + + procedure InitializeCriticalSection (pCriticalSection : access RTS_Lock); + procedure InitializeCriticalSection + (pCriticalSection : access CRITICAL_SECTION); + pragma Import + (Stdcall, InitializeCriticalSection, "InitializeCriticalSection"); + + procedure EnterCriticalSection (pCriticalSection : access RTS_Lock); + procedure EnterCriticalSection + (pCriticalSection : access CRITICAL_SECTION); + pragma Import (Stdcall, EnterCriticalSection, "EnterCriticalSection"); + + procedure LeaveCriticalSection (pCriticalSection : access RTS_Lock); + procedure LeaveCriticalSection (pCriticalSection : access CRITICAL_SECTION); + pragma Import (Stdcall, LeaveCriticalSection, "LeaveCriticalSection"); + + procedure DeleteCriticalSection (pCriticalSection : access RTS_Lock); + procedure DeleteCriticalSection + (pCriticalSection : access CRITICAL_SECTION); + pragma Import (Stdcall, DeleteCriticalSection, "DeleteCriticalSection"); + + ---------------- + -- Local Data -- + ---------------- + + Environment_Task_Id : Task_Id; + -- A variable to hold Task_Id for the environment task + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + function Get_Policy (Prio : System.Any_Priority) return Character; + pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); + -- Get priority specific dispatching policy + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads) + + Annex_D : Boolean := False; + -- Set to True if running with Annex-D semantics + + ------------------------------------ + -- The thread local storage index -- + ------------------------------------ + + TlsIndex : DWORD; + pragma Export (Ada, TlsIndex); + -- To ensure that this variable won't be local to this package, since + -- in some cases, inlining forces this variable to be global anyway. + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does executing thread have a TCB? + + procedure Set (Self_Id : Task_Id); + pragma Inline (Set); + -- Set the self id for the current task + + end Specific; + + package body Specific is + + function Is_Valid_Task return Boolean is + begin + return TlsGetValue (TlsIndex) /= System.Null_Address; + end Is_Valid_Task; + + procedure Set (Self_Id : Task_Id) is + Succeeded : BOOL; + begin + Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id)); + pragma Assert (Succeeded = Win32.TRUE); + end Set; + + end Specific; + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; + -- Allocate and Initialize a new ATCB for the current Thread + + function Register_Foreign_Thread + (Thread : Thread_Id) return Task_Id is separate; + + ---------------------------------- + -- Condition Variable Functions -- + ---------------------------------- + + procedure Initialize_Cond (Cond : not null access Condition_Variable); + -- Initialize given condition variable Cond + + procedure Finalize_Cond (Cond : not null access Condition_Variable); + -- Finalize given condition variable Cond + + procedure Cond_Signal (Cond : not null access Condition_Variable); + -- Signal condition variable Cond + + procedure Cond_Wait + (Cond : not null access Condition_Variable; + L : not null access RTS_Lock); + -- Wait on conditional variable Cond, using lock L + + procedure Cond_Timed_Wait + (Cond : not null access Condition_Variable; + L : not null access RTS_Lock; + Rel_Time : Duration; + Timed_Out : out Boolean; + Status : out Integer); + -- Do timed wait on condition variable Cond using lock L. The duration + -- of the timed wait is given by Rel_Time. When the condition is + -- signalled, Timed_Out shows whether or not a time out occurred. + -- Status is only valid if Timed_Out is False, in which case it + -- shows whether Cond_Timed_Wait completed successfully. + + --------------------- + -- Initialize_Cond -- + --------------------- + + procedure Initialize_Cond (Cond : not null access Condition_Variable) is + hEvent : HANDLE; + begin + hEvent := CreateEvent (null, Win32.TRUE, Win32.FALSE, Null_Ptr); + pragma Assert (hEvent /= 0); + Cond.all := Condition_Variable (hEvent); + end Initialize_Cond; + + ------------------- + -- Finalize_Cond -- + ------------------- + + -- No such problem here, DosCloseEventSem has been derived. + -- What does such refer to in above comment??? + + procedure Finalize_Cond (Cond : not null access Condition_Variable) is + Result : BOOL; + begin + Result := CloseHandle (HANDLE (Cond.all)); + pragma Assert (Result = Win32.TRUE); + end Finalize_Cond; + + ----------------- + -- Cond_Signal -- + ----------------- + + procedure Cond_Signal (Cond : not null access Condition_Variable) is + Result : BOOL; + begin + Result := SetEvent (HANDLE (Cond.all)); + pragma Assert (Result = Win32.TRUE); + end Cond_Signal; + + --------------- + -- Cond_Wait -- + --------------- + + -- Pre-condition: Cond is posted + -- L is locked. + + -- Post-condition: Cond is posted + -- L is locked. + + procedure Cond_Wait + (Cond : not null access Condition_Variable; + L : not null access RTS_Lock) + is + Result : DWORD; + Result_Bool : BOOL; + + begin + -- Must reset Cond BEFORE L is unlocked + + Result_Bool := ResetEvent (HANDLE (Cond.all)); + pragma Assert (Result_Bool = Win32.TRUE); + Unlock (L, Global_Lock => True); + + -- No problem if we are interrupted here: if the condition is signaled, + -- WaitForSingleObject will simply not block + + Result := WaitForSingleObject (HANDLE (Cond.all), Wait_Infinite); + pragma Assert (Result = 0); + + Write_Lock (L, Global_Lock => True); + end Cond_Wait; + + --------------------- + -- Cond_Timed_Wait -- + --------------------- + + -- Pre-condition: Cond is posted + -- L is locked. + + -- Post-condition: Cond is posted + -- L is locked. + + procedure Cond_Timed_Wait + (Cond : not null access Condition_Variable; + L : not null access RTS_Lock; + Rel_Time : Duration; + Timed_Out : out Boolean; + Status : out Integer) + is + Time_Out_Max : constant DWORD := 16#FFFF0000#; + -- NT 4 can't handle excessive timeout values (e.g. DWORD'Last - 1) + + Time_Out : DWORD; + Result : BOOL; + Wait_Result : DWORD; + + begin + -- Must reset Cond BEFORE L is unlocked + + Result := ResetEvent (HANDLE (Cond.all)); + pragma Assert (Result = Win32.TRUE); + Unlock (L, Global_Lock => True); + + -- No problem if we are interrupted here: if the condition is signaled, + -- WaitForSingleObject will simply not block. + + if Rel_Time <= 0.0 then + Timed_Out := True; + Wait_Result := 0; + + else + Time_Out := + (if Rel_Time >= Duration (Time_Out_Max) / 1000 + then Time_Out_Max + else DWORD (Rel_Time * 1000)); + + Wait_Result := WaitForSingleObject (HANDLE (Cond.all), Time_Out); + + if Wait_Result = WAIT_TIMEOUT then + Timed_Out := True; + Wait_Result := 0; + else + Timed_Out := False; + end if; + end if; + + Write_Lock (L, Global_Lock => True); + + -- Ensure post-condition + + if Timed_Out then + Result := SetEvent (HANDLE (Cond.all)); + pragma Assert (Result = Win32.TRUE); + end if; + + Status := Integer (Wait_Result); + end Cond_Timed_Wait; + + ------------------ + -- Stack_Guard -- + ------------------ + + -- The underlying thread system sets a guard page at the bottom of a thread + -- stack, so nothing is needed. + -- ??? Check the comment above + + procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is + pragma Unreferenced (T, On); + begin + null; + end Stack_Guard; + + -------------------- + -- Get_Thread_Id -- + -------------------- + + function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_Id is + Self_Id : constant Task_Id := To_Task_Id (TlsGetValue (TlsIndex)); + begin + if Self_Id = null then + return Register_Foreign_Thread (GetCurrentThread); + else + return Self_Id; + end if; + end Self; + + --------------------- + -- Initialize_Lock -- + --------------------- + + -- Note: mutexes and cond_variables needed per-task basis are initialized + -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such + -- as RTS_Lock, Memory_Lock...) used in the RTS is initialized before any + -- status change of RTS. Therefore raising Storage_Error in the following + -- routines should be able to be handled safely. + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : not null access Lock) + is + begin + InitializeCriticalSection (L.Mutex'Access); + L.Owner_Priority := 0; + L.Priority := Prio; + end Initialize_Lock; + + procedure Initialize_Lock + (L : not null access RTS_Lock; Level : Lock_Level) + is + pragma Unreferenced (Level); + begin + InitializeCriticalSection (L); + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : not null access Lock) is + begin + DeleteCriticalSection (L.Mutex'Access); + end Finalize_Lock; + + procedure Finalize_Lock (L : not null access RTS_Lock) is + begin + DeleteCriticalSection (L); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock + (L : not null access Lock; Ceiling_Violation : out Boolean) is + begin + L.Owner_Priority := Get_Priority (Self); + + if L.Priority < L.Owner_Priority then + Ceiling_Violation := True; + return; + end if; + + EnterCriticalSection (L.Mutex'Access); + + Ceiling_Violation := False; + end Write_Lock; + + procedure Write_Lock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) + is + begin + if not Single_Lock or else Global_Lock then + EnterCriticalSection (L); + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_Id) is + begin + if not Single_Lock then + EnterCriticalSection (T.Common.LL.L'Access); + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock + (L : not null access Lock; Ceiling_Violation : out Boolean) is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : not null access Lock) is + begin + LeaveCriticalSection (L.Mutex'Access); + end Unlock; + + procedure Unlock + (L : not null access RTS_Lock; Global_Lock : Boolean := False) is + begin + if not Single_Lock or else Global_Lock then + LeaveCriticalSection (L); + end if; + end Unlock; + + procedure Unlock (T : Task_Id) is + begin + if not Single_Lock then + LeaveCriticalSection (T.Common.LL.L'Access); + end if; + end Unlock; + + ----------------- + -- Set_Ceiling -- + ----------------- + + -- Dynamic priority ceilings are not supported by the underlying system + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + pragma Unreferenced (L, Prio); + begin + null; + end Set_Ceiling; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : Task_Id; + Reason : System.Tasking.Task_States) + is + pragma Unreferenced (Reason); + + begin + pragma Assert (Self_ID = Self); + + if Single_Lock then + Cond_Wait (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + else + Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + end if; + + if Self_ID.Deferral_Level = 0 + and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + then + Unlock (Self_ID); + raise Standard'Abort_Signal; + end if; + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + -- This is for use within the run-time system, so abort is assumed to be + -- already deferred, and the caller should be holding its own ATCB lock. + + procedure Timed_Sleep + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Unreferenced (Reason); + Check_Time : Duration := Monotonic_Clock; + Rel_Time : Duration; + Abs_Time : Duration; + + Result : Integer; + pragma Unreferenced (Result); + + Local_Timedout : Boolean; + + begin + Timedout := True; + Yielded := False; + + if Mode = Relative then + Rel_Time := Time; + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + else + Rel_Time := Time - Check_Time; + Abs_Time := Time; + end if; + + if Rel_Time > 0.0 then + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + if Single_Lock then + Cond_Timed_Wait + (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock'Access, + Rel_Time, Local_Timedout, Result); + else + Cond_Timed_Wait + (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L'Access, + Rel_Time, Local_Timedout, Result); + end if; + + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time; + + if not Local_Timedout then + + -- Somebody may have called Wakeup for us + + Timedout := False; + exit; + end if; + + Rel_Time := Abs_Time - Check_Time; + end loop; + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes) + is + Check_Time : Duration := Monotonic_Clock; + Rel_Time : Duration; + Abs_Time : Duration; + + Timedout : Boolean; + Result : Integer; + pragma Unreferenced (Timedout, Result); + + begin + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + 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 + Self_ID.Common.State := Delay_Sleep; + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + if Single_Lock then + Cond_Timed_Wait + (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock'Access, + Rel_Time, Timedout, Result); + else + Cond_Timed_Wait + (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L'Access, + Rel_Time, Timedout, Result); + end if; + + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time; + + Rel_Time := Abs_Time - Check_Time; + end loop; + + Self_ID.Common.State := Runnable; + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + Yield; + end Timed_Delay; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + begin + Cond_Signal (T.Common.LL.CV'Access); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + begin + if Do_Yield then + SwitchToThread; + + elsif Annex_D then + -- If running with Annex-D semantics we need a delay + -- above 0 milliseconds here otherwise processes give + -- enough time to the other tasks to have a chance to + -- run. + -- + -- This makes cxd8002 ACATS pass on Windows. + + Sleep (1); + end if; + end Yield; + + ------------------ + -- Set_Priority -- + ------------------ + + type Prio_Array_Type is array (System.Any_Priority) of Integer; + pragma Atomic_Components (Prio_Array_Type); + + Prio_Array : Prio_Array_Type; + -- Global array containing the id of the currently running task for + -- each priority. + -- + -- Note: we assume that we are on a single processor with run-til-blocked + -- scheduling. + + procedure Set_Priority + (T : Task_Id; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + Res : BOOL; + Array_Item : Integer; + + begin + Res := SetThreadPriority + (T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio))); + pragma Assert (Res = Win32.TRUE); + + if Dispatching_Policy = 'F' or else Get_Policy (Prio) = 'F' then + + -- Annex D requirement [RM D.2.2 par. 9]: + -- If the task drops its priority due to the loss of inherited + -- priority, it is added at the head of the ready queue for its + -- new active priority. + + if Loss_Of_Inheritance + and then Prio < T.Common.Current_Priority + then + Array_Item := Prio_Array (T.Common.Base_Priority) + 1; + Prio_Array (T.Common.Base_Priority) := Array_Item; + + loop + -- Let some processes a chance to arrive + + Yield; + + -- Then wait for our turn to proceed + + exit when Array_Item = Prio_Array (T.Common.Base_Priority) + or else Prio_Array (T.Common.Base_Priority) = 1; + end loop; + + Prio_Array (T.Common.Base_Priority) := + Prio_Array (T.Common.Base_Priority) - 1; + end if; + end if; + + T.Common.Current_Priority := Prio; + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_Id) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + -- There were two paths were we needed to call Enter_Task : + -- 1) from System.Task_Primitives.Operations.Initialize + -- 2) from System.Tasking.Stages.Task_Wrapper + + -- The thread initialisation has to be done only for the first case + + -- This is because the GetCurrentThread NT call does not return the real + -- thread handler but only a "pseudo" one. It is not possible to release + -- the thread handle and free the system resources from this "pseudo" + -- handle. So we really want to keep the real thread handle set in + -- System.Task_Primitives.Operations.Create_Task during thread creation. + + procedure Enter_Task (Self_ID : Task_Id) is + procedure Init_Float; + pragma Import (C, Init_Float, "__gnat_init_float"); + -- Properly initializes the FPU for x86 systems + + procedure Get_Stack_Bounds (Base : Address; Limit : Address); + pragma Import (C, Get_Stack_Bounds, "__gnat_get_stack_bounds"); + -- Get stack boundaries + begin + Specific.Set (Self_ID); + Init_Float; + + if Self_ID.Common.Task_Info /= null + and then + Self_ID.Common.Task_Info.CPU >= CPU_Number (Number_Of_Processors) + then + raise Invalid_CPU_Number; + end if; + + Self_ID.Common.LL.Thread_Id := GetCurrentThreadId; + + Get_Stack_Bounds + (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Base'Address, + Self_ID.Common.Compiler_Data.Pri_Stack_Info.Limit'Address); + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_Id is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (GetCurrentThread); + end if; + end Register_Foreign_Thread; + + -------------------- + -- Initialize_TCB -- + -------------------- + + procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is + begin + -- Initialize thread ID to 0, this is needed to detect threads that + -- are not yet activated. + + Self_ID.Common.LL.Thread := 0; + + Initialize_Cond (Self_ID.Common.LL.CV'Access); + + if not Single_Lock then + Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); + end if; + + Succeeded := True; + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_Id; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + Initial_Stack_Size : constant := 1024; + -- We set the initial stack size to 1024. On Windows version prior to XP + -- there is no way to fix a task stack size. Only the initial stack size + -- can be set, the operating system will raise the task stack size if + -- needed. + + function Is_Windows_XP return Integer; + pragma Import (C, Is_Windows_XP, "__gnat_is_windows_xp"); + -- Returns 1 if running on Windows XP + + hTask : HANDLE; + TaskId : aliased DWORD; + pTaskParameter : Win32.PVOID; + Result : DWORD; + Entry_Point : PTHREAD_START_ROUTINE; + + use type System.Multiprocessors.CPU_Range; + + begin + pTaskParameter := To_Address (T); + + Entry_Point := To_PTHREAD_START_ROUTINE (Wrapper); + + if Is_Windows_XP = 1 then + hTask := CreateThread + (null, + DWORD (Stack_Size), + Entry_Point, + pTaskParameter, + DWORD (Create_Suspended) or + DWORD (Stack_Size_Param_Is_A_Reservation), + TaskId'Unchecked_Access); + else + hTask := CreateThread + (null, + Initial_Stack_Size, + Entry_Point, + pTaskParameter, + DWORD (Create_Suspended), + TaskId'Unchecked_Access); + end if; + + -- Step 1: Create the thread in blocked mode + + if hTask = 0 then + Succeeded := False; + return; + end if; + + -- Step 2: set its TCB + + T.Common.LL.Thread := hTask; + + -- Note: it would be useful to initialize Thread_Id right away to avoid + -- a race condition in gdb where Thread_ID may not have the right value + -- yet, but GetThreadId is a Vista specific API, not available under XP: + -- T.Common.LL.Thread_Id := GetThreadId (hTask); so instead we set the + -- field to 0 to avoid having a random value. Thread_Id is initialized + -- in Enter_Task anyway. + + T.Common.LL.Thread_Id := 0; + + -- Step 3: set its priority (child has inherited priority from parent) + + Set_Priority (T, Priority); + + if Time_Slice_Val = 0 + or else Dispatching_Policy = 'F' + or else Get_Policy (Priority) = 'F' + then + -- Here we need Annex D semantics so we disable the NT priority + -- boost. A priority boost is temporarily given by the system to + -- a thread when it is taken out of a wait state. + + SetThreadPriorityBoost (hTask, DisablePriorityBoost => Win32.TRUE); + end if; + + -- Step 4: Handle pragma CPU and Task_Info + + if T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then + + -- The CPU numbering in pragma CPU starts at 1 while the subprogram + -- to set the affinity starts at 0, therefore we must subtract 1. + + Result := SetThreadIdealProcessor + (hTask, ProcessorId (T.Common.Base_CPU) - 1); + pragma Assert (Result = 1); + + elsif T.Common.Task_Info /= null then + if T.Common.Task_Info.CPU /= Task_Info.Any_CPU then + Result := SetThreadIdealProcessor (hTask, T.Common.Task_Info.CPU); + pragma Assert (Result = 1); + end if; + end if; + + -- Step 5: Now, start it for good + + Result := ResumeThread (hTask); + pragma Assert (Result = 1); + + Succeeded := Result = 1; + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_Id) is + Self_ID : Task_Id := T; + Result : DWORD; + Succeeded : BOOL; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + + begin + if not Single_Lock then + Finalize_Lock (T.Common.LL.L'Access); + end if; + + Finalize_Cond (T.Common.LL.CV'Access); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + if Self_ID.Common.LL.Thread /= 0 then + + -- This task has been activated. Wait for the thread to terminate + -- then close it. This is needed to release system resources. + + Result := WaitForSingleObject (T.Common.LL.Thread, Wait_Infinite); + pragma Assert (Result /= WAIT_FAILED); + Succeeded := CloseHandle (T.Common.LL.Thread); + pragma Assert (Succeeded = Win32.TRUE); + end if; + + Free (Self_ID); + + if Is_Self then + Specific.Set (null); + end if; + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + Specific.Set (null); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_Id) is + pragma Unreferenced (T); + begin + null; + end Abort_Task; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_Id is + begin + return Environment_Task_Id; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_Id) is + Discard : BOOL; + pragma Unreferenced (Discard); + + Result : DWORD; + + use type System.Multiprocessors.CPU_Range; + + begin + Environment_Task_Id := Environment_Task; + OS_Primitives.Initialize; + Interrupt_Management.Initialize; + + if Time_Slice_Val = 0 or else Dispatching_Policy = 'F' then + -- Here we need Annex D semantics, switch the current process to the + -- Realtime_Priority_Class. + + Discard := OS_Interface.SetPriorityClass + (GetCurrentProcess, Realtime_Priority_Class); + + Annex_D := True; + end if; + + TlsIndex := TlsAlloc; + + -- Initialize the lock used to synchronize chain of all ATCBs + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + Environment_Task.Common.LL.Thread := GetCurrentThread; + + -- Make environment task known here because it doesn't go through + -- Activate_Tasks, which does it for all other tasks. + + Known_Tasks (Known_Tasks'First) := Environment_Task; + Environment_Task.Known_Tasks_Index := Known_Tasks'First; + + Enter_Task (Environment_Task); + + -- pragma CPU for the environment task + + if Environment_Task.Common.Base_CPU /= + System.Multiprocessors.Not_A_Specific_CPU + then + -- The CPU numbering in pragma CPU starts at 1 while the subprogram + -- to set the affinity starts at 0, therefore we must subtract 1. + + Result := + SetThreadIdealProcessor + (Environment_Task.Common.LL.Thread, + ProcessorId (Environment_Task.Common.Base_CPU) - 1); + pragma Assert (Result = 1); + end if; + end Initialize; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration + renames System.OS_Primitives.Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + return 0.000_001; -- 1 micro-second + end RT_Resolution; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (S : in out Suspension_Object) is + begin + -- Initialize internal state. It is always initialized to False (ARM + -- D.10 par. 6). + + S.State := False; + S.Waiting := False; + + -- Initialize internal mutex + + InitializeCriticalSection (S.L'Access); + + -- Initialize internal condition variable + + S.CV := CreateEvent (null, Win32.TRUE, Win32.FALSE, Null_Ptr); + pragma Assert (S.CV /= 0); + end Initialize; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (S : in out Suspension_Object) is + Result : BOOL; + + begin + -- Destroy internal mutex + + DeleteCriticalSection (S.L'Access); + + -- Destroy internal condition variable + + Result := CloseHandle (S.CV); + pragma Assert (Result = Win32.TRUE); + end Finalize; + + ------------------- + -- Current_State -- + ------------------- + + function Current_State (S : Suspension_Object) return Boolean is + begin + -- We do not want to use lock on this read operation. State is marked + -- as Atomic so that we ensure that the value retrieved is correct. + + return S.State; + end Current_State; + + --------------- + -- Set_False -- + --------------- + + procedure Set_False (S : in out Suspension_Object) is + begin + SSL.Abort_Defer.all; + + EnterCriticalSection (S.L'Access); + + S.State := False; + + LeaveCriticalSection (S.L'Access); + + SSL.Abort_Undefer.all; + end Set_False; + + -------------- + -- Set_True -- + -------------- + + procedure Set_True (S : in out Suspension_Object) is + Result : BOOL; + begin + SSL.Abort_Defer.all; + + EnterCriticalSection (S.L'Access); + + -- If there is already a task waiting on this suspension object then + -- we resume it, leaving the state of the suspension object to False, + -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves + -- the state to True. + + if S.Waiting then + S.Waiting := False; + S.State := False; + + Result := SetEvent (S.CV); + pragma Assert (Result = Win32.TRUE); + else + S.State := True; + end if; + + LeaveCriticalSection (S.L'Access); + + SSL.Abort_Undefer.all; + end Set_True; + + ------------------------ + -- Suspend_Until_True -- + ------------------------ + + procedure Suspend_Until_True (S : in out Suspension_Object) is + Result : DWORD; + Result_Bool : BOOL; + + begin + SSL.Abort_Defer.all; + + EnterCriticalSection (S.L'Access); + + if S.Waiting then + -- Program_Error must be raised upon calling Suspend_Until_True + -- if another task is already waiting on that suspension object + -- (ARM D.10 par. 10). + + LeaveCriticalSection (S.L'Access); + + SSL.Abort_Undefer.all; + + raise Program_Error; + else + -- Suspend the task if the state is False. Otherwise, the task + -- continues its execution, and the state of the suspension object + -- is set to False (ARM D.10 par. 9). + + if S.State then + S.State := False; + + LeaveCriticalSection (S.L'Access); + + SSL.Abort_Undefer.all; + else + S.Waiting := True; + + -- Must reset CV BEFORE L is unlocked + + Result_Bool := ResetEvent (S.CV); + pragma Assert (Result_Bool = Win32.TRUE); + + LeaveCriticalSection (S.L'Access); + + SSL.Abort_Undefer.all; + + Result := WaitForSingleObject (S.CV, Wait_Infinite); + pragma Assert (Result = 0); + end if; + end if; + end Suspend_Until_True; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy versions. The only currently working versions is for solaris + -- (native). + + function Check_Exit (Self_ID : ST.Task_Id) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_No_Locks; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + begin + if T.Common.LL.Thread /= Thread_Self then + return SuspendThread (T.Common.LL.Thread) = NO_ERROR; + else + return True; + end if; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + begin + if T.Common.LL.Thread /= Thread_Self then + return ResumeThread (T.Common.LL.Thread) = NO_ERROR; + else + return True; + end if; + end Resume_Task; + + -------------------- + -- Stop_All_Tasks -- + -------------------- + + procedure Stop_All_Tasks is + begin + null; + end Stop_All_Tasks; + + --------------- + -- Stop_Task -- + --------------- + + function Stop_Task (T : ST.Task_Id) return Boolean is + pragma Unreferenced (T); + begin + return False; + end Stop_Task; + + ------------------- + -- Continue_Task -- + ------------------- + + function Continue_Task (T : ST.Task_Id) return Boolean is + pragma Unreferenced (T); + begin + return False; + end Continue_Task; + +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb new file mode 100644 index 000000000..d05bb1cd2 --- /dev/null +++ b/gcc/ada/s-taprop-posix.adb @@ -0,0 +1,1455 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a POSIX-like version of this package + +-- This package contains all the GNULL primitives that interface directly with +-- the underlying OS. + +-- Note: this file can only be used for POSIX compliant systems that implement +-- SCHED_FIFO and Ceiling Locking correctly. + +-- For configurations where SCHED_FIFO and priority ceiling are not a +-- requirement, this file can also be used (e.g AiX threads) + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +with Interfaces.C; + +with System.Tasking.Debug; +with System.Interrupt_Management; +with System.OS_Primitives; +with System.Task_Info; + +with System.Soft_Links; +-- We use System.Soft_Links instead of System.Tasking.Initialization +-- because the later is a higher level package that we shouldn't depend on. +-- For example when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Stages. + +package body System.Task_Primitives.Operations is + + package SSL renames System.Soft_Links; + + use System.Tasking.Debug; + use System.Tasking; + use Interfaces.C; + use System.OS_Interface; + use System.Parameters; + use System.OS_Primitives; + + ---------------- + -- Local Data -- + ---------------- + + -- The followings are logically constants, but need to be initialized + -- at run time. + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + ATCB_Key : aliased pthread_key_t; + -- Key used to find the Ada Task_Id associated with a thread + + Environment_Task_Id : Task_Id; + -- A variable to hold Task_Id for the environment task + + Locking_Policy : Character; + pragma Import (C, Locking_Policy, "__gl_locking_policy"); + -- Value of the pragma Locking_Policy: + -- 'C' for Ceiling_Locking + -- 'I' for Inherit_Locking + -- ' ' for none. + + Unblocked_Signal_Mask : aliased sigset_t; + -- The set of signals that should unblocked in all tasks + + -- The followings are internal configuration constants needed + + Next_Serial_Number : Task_Serial_Number := 100; + -- We start at 100, to reserve some special values for + -- using in error checking. + + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads) + + Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0; + -- Whether to use an alternate signal stack for stack overflows + + Abort_Handler_Installed : Boolean := False; + -- True if a handler for the abort signal is installed + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + procedure Initialize (Environment_Task : Task_Id); + pragma Inline (Initialize); + -- Initialize various data needed by this package + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does executing thread have a TCB? + + procedure Set (Self_Id : Task_Id); + pragma Inline (Set); + -- Set the self id for the current task + + function Self return Task_Id; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task + + end Specific; + + package body Specific is separate; + -- The body of this package is target specific + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; + -- Allocate and Initialize a new ATCB for the current Thread + + function Register_Foreign_Thread + (Thread : Thread_Id) return Task_Id is separate; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Abort_Handler (Sig : Signal); + -- Signal handler used to implement asynchronous abort. + -- See also comment before body, below. + + function To_Address is + new Ada.Unchecked_Conversion (Task_Id, System.Address); + + ------------------- + -- Abort_Handler -- + ------------------- + + -- Target-dependent binding of inter-thread Abort signal to the raising of + -- the Abort_Signal exception. + + -- The technical issues and alternatives here are essentially the + -- same as for raising exceptions in response to other signals + -- (e.g. Storage_Error). See code and comments in the package body + -- System.Interrupt_Management. + + -- Some implementations may not allow an exception to be propagated out of + -- a handler, and others might leave the signal or interrupt that invoked + -- this handler masked after the exceptional return to the application + -- code. + + -- GNAT exceptions are originally implemented using setjmp()/longjmp(). On + -- most UNIX systems, this will allow transfer out of a signal handler, + -- which is usually the only mechanism available for implementing + -- asynchronous handlers of this kind. However, some systems do not + -- restore the signal mask on longjmp(), leaving the abort signal masked. + + procedure Abort_Handler (Sig : Signal) is + pragma Unreferenced (Sig); + + T : constant Task_Id := Self; + Old_Set : aliased sigset_t; + + Result : Interfaces.C.int; + pragma Warnings (Off, Result); + + begin + -- It's not safe to raise an exception when using GCC ZCX mechanism. + -- Note that we still need to install a signal handler, since in some + -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we + -- need to send the Abort signal to a task. + + if ZCX_By_Default and then GCC_ZCX_Support then + return; + end if; + + if T.Deferral_Level = 0 + and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then + not T.Aborting + then + T.Aborting := True; + + -- Make sure signals used for RTS internal purpose are unmasked + + Result := pthread_sigmask (SIG_UNBLOCK, + Unblocked_Signal_Mask'Access, Old_Set'Access); + pragma Assert (Result = 0); + + raise Standard'Abort_Signal; + end if; + end Abort_Handler; + + ----------------- + -- Stack_Guard -- + ----------------- + + procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is + Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread); + Guard_Page_Address : Address; + + Res : Interfaces.C.int; + + begin + if Stack_Base_Available then + + -- Compute the guard page address + + Guard_Page_Address := + Stack_Base - (Stack_Base mod Get_Page_Size) + Get_Page_Size; + + Res := + mprotect (Guard_Page_Address, Get_Page_Size, + prot => (if On then PROT_ON else PROT_OFF)); + pragma Assert (Res = 0); + end if; + end Stack_Guard; + + -------------------- + -- Get_Thread_Id -- + -------------------- + + function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_Id renames Specific.Self; + + --------------------- + -- Initialize_Lock -- + --------------------- + + -- Note: mutexes and cond_variables needed per-task basis are + -- initialized in Initialize_TCB and the Storage_Error is + -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) + -- used in RTS is initialized before any status change of RTS. + -- Therefore raising Storage_Error in the following routines + -- should be able to be handled safely. + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : not null access Lock) + is + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + if Locking_Policy = 'C' then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_PROTECT); + pragma Assert (Result = 0); + + Result := pthread_mutexattr_setprioceiling + (Attributes'Access, Interfaces.C.int (Prio)); + pragma Assert (Result = 0); + + elsif Locking_Policy = 'I' then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_INHERIT); + pragma Assert (Result = 0); + end if; + + Result := pthread_mutex_init (L, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Attributes'Access); + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + procedure Initialize_Lock + (L : not null access RTS_Lock; Level : Lock_Level) + is + pragma Unreferenced (Level); + + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + if Locking_Policy = 'C' then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_PROTECT); + pragma Assert (Result = 0); + + Result := pthread_mutexattr_setprioceiling + (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); + pragma Assert (Result = 0); + + elsif Locking_Policy = 'I' then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_INHERIT); + pragma Assert (Result = 0); + end if; + + Result := pthread_mutex_init (L, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Attributes'Access); + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : not null access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + procedure Finalize_Lock (L : not null access RTS_Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock + (L : not null access Lock; Ceiling_Violation : out Boolean) + is + Result : Interfaces.C.int; + + begin + Result := pthread_mutex_lock (L); + + -- Assume that the cause of EINVAL is a priority ceiling violation + + Ceiling_Violation := (Result = EINVAL); + pragma Assert (Result = 0 or else Result = EINVAL); + end Write_Lock; + + procedure Write_Lock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_lock (L); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_Id) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_lock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock + (L : not null access Lock; Ceiling_Violation : out Boolean) is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : not null access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end Unlock; + + procedure Unlock + (L : not null access RTS_Lock; Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock (T : Task_Id) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_unlock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + ----------------- + -- Set_Ceiling -- + ----------------- + + -- Dynamic priority ceilings are not supported by the underlying system + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + pragma Unreferenced (L, Prio); + begin + null; + end Set_Ceiling; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : Task_Id; + Reason : System.Tasking.Task_States) + is + pragma Unreferenced (Reason); + + Result : Interfaces.C.int; + + begin + Result := + pthread_cond_wait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access)); + + -- EINTR is not considered a failure + + pragma Assert (Result = 0 or else Result = EINTR); + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + -- This is for use within the run-time system, so abort is + -- assumed to be already deferred, and the caller should be + -- holding its own ATCB lock. + + procedure Timed_Sleep + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Unreferenced (Reason); + + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; + Rel_Time : Duration; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + Timedout := True; + Yielded := False; + + if Mode = Relative then + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time); + end if; + + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); + end if; + end if; + + if Abs_Time > Check_Time then + Request := + To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time); + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); + + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + if Result = 0 or Result = EINTR then + + -- Somebody may have called Wakeup for us + + Timedout := False; + exit; + end if; + + pragma Assert (Result = ETIMEDOUT); + end loop; + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + -- This is for use in implementing delay statements, so we assume the + -- caller is abort-deferred but is holding no locks. + + procedure Timed_Delay + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes) + is + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; + Abs_Time : Duration; + Rel_Time : Duration; + Request : aliased timespec; + + Result : Interfaces.C.int; + pragma Warnings (Off, Result); + + begin + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + if Mode = Relative then + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time); + end if; + + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); + end if; + end if; + + if Abs_Time > Check_Time then + Request := + To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time); + Self_ID.Common.State := Delay_Sleep; + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); + + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + pragma Assert (Result = 0 + or else Result = ETIMEDOUT + or else Result = EINTR); + end loop; + + Self_ID.Common.State := Runnable; + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + Result := sched_yield; + end Timed_Delay; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + TS : aliased timespec; + Result : Interfaces.C.int; + begin + Result := clock_gettime + (clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access); + pragma Assert (Result = 0); + return To_Duration (TS); + end Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + return 10#1.0#E-6; + end RT_Resolution; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + begin + Result := pthread_cond_signal (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + Result : Interfaces.C.int; + pragma Unreferenced (Result); + begin + if Do_Yield then + Result := sched_yield; + end if; + end Yield; + + ------------------ + -- Set_Priority -- + ------------------ + + procedure Set_Priority + (T : Task_Id; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + pragma Unreferenced (Loss_Of_Inheritance); + + Result : Interfaces.C.int; + Param : aliased struct_sched_param; + + function Get_Policy (Prio : System.Any_Priority) return Character; + pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); + -- Get priority specific dispatching policy + + Priority_Specific_Policy : constant Character := Get_Policy (Prio); + -- Upper case first character of the policy name corresponding to the + -- task as set by a Priority_Specific_Dispatching pragma. + + begin + T.Common.Current_Priority := Prio; + Param.sched_priority := To_Target_Priority (Prio); + + if Time_Slice_Supported + and then (Dispatching_Policy = 'R' + or else Priority_Specific_Policy = 'R' + or else Time_Slice_Val > 0) + then + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_RR, Param'Access); + + elsif Dispatching_Policy = 'F' + or else Priority_Specific_Policy = 'F' + or else Time_Slice_Val = 0 + then + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_FIFO, Param'Access); + + else + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_OTHER, Param'Access); + end if; + + pragma Assert (Result = 0); + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_Id) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_Id) is + begin + Self_ID.Common.LL.Thread := pthread_self; + Self_ID.Common.LL.LWP := lwp_self; + + Specific.Set (Self_ID); + + if Use_Alternate_Stack then + declare + Stack : aliased stack_t; + Result : Interfaces.C.int; + begin + Stack.ss_sp := Self_ID.Common.Task_Alternate_Stack; + Stack.ss_size := Alternate_Stack_Size; + Stack.ss_flags := 0; + Result := sigaltstack (Stack'Access, null); + pragma Assert (Result = 0); + end; + end if; + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_Id is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (pthread_self); + end if; + end Register_Foreign_Thread; + + -------------------- + -- Initialize_TCB -- + -------------------- + + procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is + Mutex_Attr : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + Cond_Attr : aliased pthread_condattr_t; + + begin + -- Give the task a unique serial number + + Self_ID.Serial_Number := Next_Serial_Number; + Next_Serial_Number := Next_Serial_Number + 1; + pragma Assert (Next_Serial_Number /= 0); + + if not Single_Lock then + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + if Locking_Policy = 'C' then + Result := + pthread_mutexattr_setprotocol + (Mutex_Attr'Access, + PTHREAD_PRIO_PROTECT); + pragma Assert (Result = 0); + + Result := + pthread_mutexattr_setprioceiling + (Mutex_Attr'Access, + Interfaces.C.int (System.Any_Priority'Last)); + pragma Assert (Result = 0); + + elsif Locking_Policy = 'I' then + Result := + pthread_mutexattr_setprotocol + (Mutex_Attr'Access, + PTHREAD_PRIO_INHERIT); + pragma Assert (Result = 0); + end if; + + Result := + pthread_mutex_init + (Self_ID.Common.LL.L'Access, + Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := + pthread_cond_init + (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result = 0 then + Succeeded := True; + else + if not Single_Lock then + Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Succeeded := False; + end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_Id; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + Attributes : aliased pthread_attr_t; + Adjusted_Stack_Size : Interfaces.C.size_t; + Page_Size : constant Interfaces.C.size_t := Get_Page_Size; + Result : Interfaces.C.int; + + function Thread_Body_Access is new + Ada.Unchecked_Conversion (System.Address, Thread_Body); + + use System.Task_Info; + + begin + Adjusted_Stack_Size := + Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size); + + if Stack_Base_Available then + + -- If Stack Checking is supported then allocate 2 additional pages: + + -- In the worst case, stack is allocated at something like + -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages + -- to be sure the effective stack size is greater than what + -- has been asked. + + Adjusted_Stack_Size := Adjusted_Stack_Size + 2 * Page_Size; + end if; + + -- Round stack size as this is required by some OSes (Darwin) + + Adjusted_Stack_Size := Adjusted_Stack_Size + Page_Size - 1; + Adjusted_Stack_Size := + Adjusted_Stack_Size - Adjusted_Stack_Size mod Page_Size; + + Result := pthread_attr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := + pthread_attr_setdetachstate + (Attributes'Access, PTHREAD_CREATE_DETACHED); + pragma Assert (Result = 0); + + Result := + pthread_attr_setstacksize + (Attributes'Access, Adjusted_Stack_Size); + pragma Assert (Result = 0); + + if T.Common.Task_Info /= Default_Scope then + case T.Common.Task_Info is + when System.Task_Info.Process_Scope => + Result := + pthread_attr_setscope + (Attributes'Access, PTHREAD_SCOPE_PROCESS); + + when System.Task_Info.System_Scope => + Result := + pthread_attr_setscope + (Attributes'Access, PTHREAD_SCOPE_SYSTEM); + + when System.Task_Info.Default_Scope => + Result := 0; + end case; + + pragma Assert (Result = 0); + end if; + + -- Since the initial signal mask of a thread is inherited from the + -- creator, and the Environment task has all its signals masked, we + -- do not need to manipulate caller's signal mask at this point. + -- All tasks in RTS will have All_Tasks_Mask initially. + + Result := pthread_create + (T.Common.LL.Thread'Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); + pragma Assert (Result = 0 or else Result = EAGAIN); + + Succeeded := Result = 0; + + Result := pthread_attr_destroy (Attributes'Access); + pragma Assert (Result = 0); + + if Succeeded then + Set_Priority (T, Priority); + end if; + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_Id) is + Result : Interfaces.C.int; + Tmp : Task_Id := T; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + + begin + if not Single_Lock then + Result := pthread_mutex_destroy (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_cond_destroy (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + Free (Tmp); + + if Is_Self then + Specific.Set (null); + end if; + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + -- Mark this task as unknown, so that if Self is called, it won't + -- return a dangling pointer. + + Specific.Set (null); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_Id) is + Result : Interfaces.C.int; + begin + if Abort_Handler_Installed then + Result := + pthread_kill + (T.Common.LL.Thread, + Signal (System.Interrupt_Management.Abort_Task_Interrupt)); + pragma Assert (Result = 0); + end if; + end Abort_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (S : in out Suspension_Object) is + Mutex_Attr : aliased pthread_mutexattr_t; + Cond_Attr : aliased pthread_condattr_t; + Result : Interfaces.C.int; + + begin + -- Initialize internal state (always to False (RM D.10 (6))) + + S.State := False; + S.Waiting := False; + + -- Initialize internal mutex + + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + + -- Initialize internal condition variable + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + if Result = ENOMEM then + raise Storage_Error; + end if; + end if; + + Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + if Result = ENOMEM then + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + raise Storage_Error; + end if; + end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + end Initialize; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + -- Destroy internal mutex + + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + -- Destroy internal condition variable + + Result := pthread_cond_destroy (S.CV'Access); + pragma Assert (Result = 0); + end Finalize; + + ------------------- + -- Current_State -- + ------------------- + + function Current_State (S : Suspension_Object) return Boolean is + begin + -- We do not want to use lock on this read operation. State is marked + -- as Atomic so that we ensure that the value retrieved is correct. + + return S.State; + end Current_State; + + --------------- + -- Set_False -- + --------------- + + procedure Set_False (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + S.State := False; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end Set_False; + + -------------- + -- Set_True -- + -------------- + + procedure Set_True (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + -- If there is already a task waiting on this suspension object then + -- we resume it, leaving the state of the suspension object to False, + -- as it is specified in (RM D.10(9)). Otherwise, it just leaves + -- the state to True. + + if S.Waiting then + S.Waiting := False; + S.State := False; + + Result := pthread_cond_signal (S.CV'Access); + pragma Assert (Result = 0); + + else + S.State := True; + end if; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end Set_True; + + ------------------------ + -- Suspend_Until_True -- + ------------------------ + + procedure Suspend_Until_True (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + if S.Waiting then + + -- Program_Error must be raised upon calling Suspend_Until_True + -- if another task is already waiting on that suspension object + -- (RM D.10(10)). + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + + raise Program_Error; + + else + -- Suspend the task if the state is False. Otherwise, the task + -- continues its execution, and the state of the suspension object + -- is set to False (ARM D.10 par. 9). + + if S.State then + S.State := False; + else + S.Waiting := True; + + loop + -- Loop in case pthread_cond_wait returns earlier than expected + -- (e.g. in case of EINTR caused by a signal). + + Result := pthread_cond_wait (S.CV'Access, S.L'Access); + pragma Assert (Result = 0 or else Result = EINTR); + + exit when not S.Waiting; + end loop; + end if; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end if; + end Suspend_Until_True; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy version + + function Check_Exit (Self_ID : ST.Task_Id) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_Id is + begin + return Environment_Task_Id; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + pragma Unreferenced (T, Thread_Self); + begin + return False; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + pragma Unreferenced (T, Thread_Self); + begin + return False; + end Resume_Task; + + -------------------- + -- Stop_All_Tasks -- + -------------------- + + procedure Stop_All_Tasks is + begin + null; + end Stop_All_Tasks; + + --------------- + -- Stop_Task -- + --------------- + + function Stop_Task (T : ST.Task_Id) return Boolean is + pragma Unreferenced (T); + begin + return False; + end Stop_Task; + + ------------------- + -- Continue_Task -- + ------------------- + + function Continue_Task (T : ST.Task_Id) return Boolean is + pragma Unreferenced (T); + begin + return False; + end Continue_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_Id) is + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + Tmp_Set : aliased sigset_t; + Result : Interfaces.C.int; + + function State + (Int : System.Interrupt_Management.Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state. Defined in a-init.c + -- The input argument is the interrupt number, + -- and the result is one of the following: + + Default : constant Character := 's'; + -- 'n' this interrupt not set by any Interrupt_State pragma + -- 'u' Interrupt_State pragma set state to User + -- 'r' Interrupt_State pragma set state to Runtime + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + + begin + Environment_Task_Id := Environment_Task; + + Interrupt_Management.Initialize; + + -- Prepare the set of signals that should unblocked in all tasks + + Result := sigemptyset (Unblocked_Signal_Mask'Access); + pragma Assert (Result = 0); + + for J in Interrupt_Management.Interrupt_ID loop + if System.Interrupt_Management.Keep_Unmasked (J) then + Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); + pragma Assert (Result = 0); + end if; + end loop; + + -- Initialize the lock used to synchronize chain of all ATCBs + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + Specific.Initialize (Environment_Task); + + if Use_Alternate_Stack then + Environment_Task.Common.Task_Alternate_Stack := + Alternate_Stack'Address; + end if; + + -- Make environment task known here because it doesn't go through + -- Activate_Tasks, which does it for all other tasks. + + Known_Tasks (Known_Tasks'First) := Environment_Task; + Environment_Task.Known_Tasks_Index := Known_Tasks'First; + + Enter_Task (Environment_Task); + + if State + (System.Interrupt_Management.Abort_Task_Interrupt) /= Default + then + act.sa_flags := 0; + act.sa_handler := Abort_Handler'Address; + + Result := sigemptyset (Tmp_Set'Access); + pragma Assert (Result = 0); + act.sa_mask := Tmp_Set; + + Result := + sigaction + (Signal (System.Interrupt_Management.Abort_Task_Interrupt), + act'Unchecked_Access, + old_act'Unchecked_Access); + pragma Assert (Result = 0); + Abort_Handler_Installed := True; + end if; + end Initialize; + +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-solaris.adb b/gcc/ada/s-taprop-solaris.adb new file mode 100644 index 000000000..a48622d03 --- /dev/null +++ b/gcc/ada/s-taprop-solaris.adb @@ -0,0 +1,1990 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, 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 a Solaris (native) version of this package + +-- This package contains all the GNULL primitives that interface directly with +-- the underlying OS. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +with Ada.Unchecked_Deallocation; + +with Interfaces.C; + +with System.Multiprocessors; +with System.Tasking.Debug; +with System.Interrupt_Management; +with System.OS_Primitives; +with System.Task_Info; + +pragma Warnings (Off); +with System.OS_Lib; +pragma Warnings (On); + +with System.Soft_Links; +-- We use System.Soft_Links instead of System.Tasking.Initialization +-- because the later is a higher level package that we shouldn't depend on. +-- For example when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Stages. + +package body System.Task_Primitives.Operations is + + package SSL renames System.Soft_Links; + + use System.Tasking.Debug; + use System.Tasking; + use Interfaces.C; + use System.OS_Interface; + use System.Parameters; + use System.OS_Primitives; + + ---------------- + -- Local Data -- + ---------------- + + -- The following are logically constants, but need to be initialized + -- at run time. + + Environment_Task_Id : Task_Id; + -- A variable to hold Task_Id for the environment task. + -- If we use this variable to get the Task_Id, we need the following + -- ATCB_Key only for non-Ada threads. + + Unblocked_Signal_Mask : aliased sigset_t; + -- The set of signals that should unblocked in all tasks + + ATCB_Key : aliased thread_key_t; + -- Key used to find the Ada Task_Id associated with a thread, + -- at least for C threads unknown to the Ada run-time system. + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + Next_Serial_Number : Task_Serial_Number := 100; + -- We start at 100, to reserve some special values for + -- using in error checking. + -- The following are internal configuration constants needed. + + Abort_Handler_Installed : Boolean := False; + -- True if a handler for the abort signal is installed + + ---------------------- + -- Priority Support -- + ---------------------- + + Priority_Ceiling_Emulation : constant Boolean := True; + -- controls whether we emulate priority ceiling locking + + -- To get a scheduling close to annex D requirements, we use the real-time + -- class provided for LWPs and map each task/thread to a specific and + -- unique LWP (there is 1 thread per LWP, and 1 LWP per thread). + + -- The real time class can only be set when the process has root + -- privileges, so in the other cases, we use the normal thread scheduling + -- and priority handling. + + Using_Real_Time_Class : Boolean := False; + -- indicates whether the real time class is being used (i.e. the process + -- has root privileges). + + Prio_Param : aliased struct_pcparms; + -- Hold priority info (Real_Time) initialized during the package + -- elaboration. + + ----------------------------------- + -- External Configuration Values -- + ----------------------------------- + + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + Locking_Policy : Character; + pragma Import (C, Locking_Policy, "__gl_locking_policy"); + + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads) + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function sysconf (name : System.OS_Interface.int) return processorid_t; + pragma Import (C, sysconf, "sysconf"); + + SC_NPROCESSORS_CONF : constant System.OS_Interface.int := 14; + + function Num_Procs + (name : System.OS_Interface.int := SC_NPROCESSORS_CONF) + return processorid_t renames sysconf; + + procedure Abort_Handler + (Sig : Signal; + Code : not null access siginfo_t; + Context : not null access ucontext_t); + -- Target-dependent binding of inter-thread Abort signal to + -- the raising of the Abort_Signal exception. + -- See also comments in 7staprop.adb + + ------------ + -- Checks -- + ------------ + + function Check_Initialize_Lock + (L : Lock_Ptr; + Level : Lock_Level) return Boolean; + pragma Inline (Check_Initialize_Lock); + + function Check_Lock (L : Lock_Ptr) return Boolean; + pragma Inline (Check_Lock); + + function Record_Lock (L : Lock_Ptr) return Boolean; + pragma Inline (Record_Lock); + + function Check_Sleep (Reason : Task_States) return Boolean; + pragma Inline (Check_Sleep); + + function Record_Wakeup + (L : Lock_Ptr; + Reason : Task_States) return Boolean; + pragma Inline (Record_Wakeup); + + function Check_Wakeup + (T : Task_Id; + Reason : Task_States) return Boolean; + pragma Inline (Check_Wakeup); + + function Check_Unlock (L : Lock_Ptr) return Boolean; + pragma Inline (Check_Unlock); + + function Check_Finalize_Lock (L : Lock_Ptr) return Boolean; + pragma Inline (Check_Finalize_Lock); + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + procedure Initialize (Environment_Task : Task_Id); + pragma Inline (Initialize); + -- Initialize various data needed by this package + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does executing thread have a TCB? + + procedure Set (Self_Id : Task_Id); + pragma Inline (Set); + -- Set the self id for the current task + + function Self return Task_Id; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task + + end Specific; + + package body Specific is separate; + -- The body of this package is target specific + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; + -- Allocate and Initialize a new ATCB for the current Thread + + function Register_Foreign_Thread + (Thread : Thread_Id) return Task_Id is separate; + + ------------ + -- Checks -- + ------------ + + Check_Count : Integer := 0; + Lock_Count : Integer := 0; + Unlock_Count : Integer := 0; + + ------------------- + -- Abort_Handler -- + ------------------- + + procedure Abort_Handler + (Sig : Signal; + Code : not null access siginfo_t; + Context : not null access ucontext_t) + is + pragma Unreferenced (Sig); + pragma Unreferenced (Code); + pragma Unreferenced (Context); + + Self_ID : constant Task_Id := Self; + Old_Set : aliased sigset_t; + + Result : Interfaces.C.int; + pragma Warnings (Off, Result); + + begin + -- It's not safe to raise an exception when using GCC ZCX mechanism. + -- Note that we still need to install a signal handler, since in some + -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we + -- need to send the Abort signal to a task. + + if ZCX_By_Default and then GCC_ZCX_Support then + return; + end if; + + if Self_ID.Deferral_Level = 0 + and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + and then not Self_ID.Aborting + then + Self_ID.Aborting := True; + + -- Make sure signals used for RTS internal purpose are unmasked + + Result := + thr_sigsetmask + (SIG_UNBLOCK, + Unblocked_Signal_Mask'Unchecked_Access, + Old_Set'Unchecked_Access); + pragma Assert (Result = 0); + + raise Standard'Abort_Signal; + end if; + end Abort_Handler; + + ----------------- + -- Stack_Guard -- + ----------------- + + -- The underlying thread system sets a guard page at the + -- bottom of a thread stack, so nothing is needed. + + procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is + pragma Unreferenced (T); + pragma Unreferenced (On); + begin + null; + end Stack_Guard; + + ------------------- + -- Get_Thread_Id -- + ------------------- + + function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : ST.Task_Id) is + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + Tmp_Set : aliased sigset_t; + Result : Interfaces.C.int; + + procedure Configure_Processors; + -- Processors configuration + -- The user can specify a processor which the program should run + -- on to emulate a single-processor system. This can be easily + -- done by setting environment variable GNAT_PROCESSOR to one of + -- the following : + -- + -- -2 : use the default configuration (run the program on all + -- available processors) - this is the same as having + -- GNAT_PROCESSOR unset + -- -1 : let the RTS choose one processor and run the program on + -- that processor + -- 0 .. Last_Proc : run the program on the specified processor + -- + -- Last_Proc is equal to the value of the system variable + -- _SC_NPROCESSORS_CONF, minus one. + + procedure Configure_Processors is + Proc_Acc : constant System.OS_Lib.String_Access := + System.OS_Lib.Getenv ("GNAT_PROCESSOR"); + Proc : aliased processorid_t; -- User processor # + Last_Proc : processorid_t; -- Last processor # + + begin + if Proc_Acc.all'Length /= 0 then + + -- Environment variable is defined + + Last_Proc := Num_Procs - 1; + + if Last_Proc /= -1 then + Proc := processorid_t'Value (Proc_Acc.all); + + if Proc <= -2 or else Proc > Last_Proc then + + -- Use the default configuration + + null; + + elsif Proc = -1 then + + -- Choose a processor + + Result := 0; + while Proc < Last_Proc loop + Proc := Proc + 1; + Result := p_online (Proc, PR_STATUS); + exit when Result = PR_ONLINE; + end loop; + + pragma Assert (Result = PR_ONLINE); + Result := processor_bind (P_PID, P_MYID, Proc, null); + pragma Assert (Result = 0); + + else + -- Use user processor + + Result := processor_bind (P_PID, P_MYID, Proc, null); + pragma Assert (Result = 0); + end if; + end if; + end if; + + exception + when Constraint_Error => + + -- Illegal environment variable GNAT_PROCESSOR - ignored + + null; + end Configure_Processors; + + function State + (Int : System.Interrupt_Management.Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state. Defined in a-init.c + -- The input argument is the interrupt number, + -- and the result is one of the following: + + Default : constant Character := 's'; + -- 'n' this interrupt not set by any Interrupt_State pragma + -- 'u' Interrupt_State pragma set state to User + -- 'r' Interrupt_State pragma set state to Runtime + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + + -- Start of processing for Initialize + + begin + Environment_Task_Id := Environment_Task; + + Interrupt_Management.Initialize; + + -- Prepare the set of signals that should unblocked in all tasks + + Result := sigemptyset (Unblocked_Signal_Mask'Access); + pragma Assert (Result = 0); + + for J in Interrupt_Management.Interrupt_ID loop + if System.Interrupt_Management.Keep_Unmasked (J) then + Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); + pragma Assert (Result = 0); + end if; + end loop; + + if Dispatching_Policy = 'F' then + declare + Result : Interfaces.C.long; + Class_Info : aliased struct_pcinfo; + Secs, Nsecs : Interfaces.C.long; + + begin + -- If a pragma Time_Slice is specified, takes the value in account + + if Time_Slice_Val > 0 then + + -- Convert Time_Slice_Val (microseconds) to seconds/nanosecs + + Secs := Interfaces.C.long (Time_Slice_Val / 1_000_000); + Nsecs := + Interfaces.C.long ((Time_Slice_Val rem 1_000_000) * 1_000); + + -- Otherwise, default to no time slicing (i.e run until blocked) + + else + Secs := RT_TQINF; + Nsecs := RT_TQINF; + end if; + + -- Get the real time class id + + Class_Info.pc_clname (1) := 'R'; + Class_Info.pc_clname (2) := 'T'; + Class_Info.pc_clname (3) := ASCII.NUL; + + Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_GETCID, + Class_Info'Address); + + -- Request the real time class + + Prio_Param.pc_cid := Class_Info.pc_cid; + Prio_Param.rt_pri := pri_t (Class_Info.rt_maxpri); + Prio_Param.rt_tqsecs := Secs; + Prio_Param.rt_tqnsecs := Nsecs; + + Result := + priocntl + (PC_VERSION, P_LWPID, P_MYID, PC_SETPARMS, Prio_Param'Address); + + Using_Real_Time_Class := Result /= -1; + end; + end if; + + Specific.Initialize (Environment_Task); + + -- The following is done in Enter_Task, but this is too late for the + -- Environment Task, since we need to call Self in Check_Locks when + -- the run time is compiled with assertions on. + + Specific.Set (Environment_Task); + + -- Initialize the lock used to synchronize chain of all ATCBs + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + -- Make environment task known here because it doesn't go through + -- Activate_Tasks, which does it for all other tasks. + + Known_Tasks (Known_Tasks'First) := Environment_Task; + Environment_Task.Known_Tasks_Index := Known_Tasks'First; + + Enter_Task (Environment_Task); + + Configure_Processors; + + if State + (System.Interrupt_Management.Abort_Task_Interrupt) /= Default + then + -- Set sa_flags to SA_NODEFER so that during the handler execution + -- we do not change the Signal_Mask to be masked for the Abort_Signal + -- This is a temporary fix to the problem that the Signal_Mask is + -- not restored after the exception (longjmp) from the handler. + -- The right fix should be made in sigsetjmp so that we save + -- the Signal_Set and restore it after a longjmp. + -- In that case, this field should be changed back to 0. ??? + + act.sa_flags := 16; + + act.sa_handler := Abort_Handler'Address; + Result := sigemptyset (Tmp_Set'Access); + pragma Assert (Result = 0); + act.sa_mask := Tmp_Set; + + Result := + sigaction + (Signal (System.Interrupt_Management.Abort_Task_Interrupt), + act'Unchecked_Access, + old_act'Unchecked_Access); + pragma Assert (Result = 0); + Abort_Handler_Installed := True; + end if; + end Initialize; + + --------------------- + -- Initialize_Lock -- + --------------------- + + -- Note: mutexes and cond_variables needed per-task basis are initialized + -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such + -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any + -- status change of RTS. Therefore raising Storage_Error in the following + -- routines should be able to be handled safely. + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : not null access Lock) + is + Result : Interfaces.C.int; + + begin + pragma Assert (Check_Initialize_Lock (Lock_Ptr (L), PO_Level)); + + if Priority_Ceiling_Emulation then + L.Ceiling := Prio; + end if; + + Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error with "Failed to allocate a lock"; + end if; + end Initialize_Lock; + + procedure Initialize_Lock + (L : not null access RTS_Lock; + Level : Lock_Level) + is + Result : Interfaces.C.int; + + begin + pragma Assert + (Check_Initialize_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)), Level)); + Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error with "Failed to allocate a lock"; + end if; + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : not null access Lock) is + Result : Interfaces.C.int; + begin + pragma Assert (Check_Finalize_Lock (Lock_Ptr (L))); + Result := mutex_destroy (L.L'Access); + pragma Assert (Result = 0); + end Finalize_Lock; + + procedure Finalize_Lock (L : not null access RTS_Lock) is + Result : Interfaces.C.int; + begin + pragma Assert (Check_Finalize_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); + Result := mutex_destroy (L.L'Access); + pragma Assert (Result = 0); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is + Result : Interfaces.C.int; + + begin + pragma Assert (Check_Lock (Lock_Ptr (L))); + + if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then + declare + Self_Id : constant Task_Id := Self; + Saved_Priority : System.Any_Priority; + + begin + if Self_Id.Common.LL.Active_Priority > L.Ceiling then + Ceiling_Violation := True; + return; + end if; + + Saved_Priority := Self_Id.Common.LL.Active_Priority; + + if Self_Id.Common.LL.Active_Priority < L.Ceiling then + Set_Priority (Self_Id, L.Ceiling); + end if; + + Result := mutex_lock (L.L'Access); + pragma Assert (Result = 0); + Ceiling_Violation := False; + + L.Saved_Priority := Saved_Priority; + end; + + else + Result := mutex_lock (L.L'Access); + pragma Assert (Result = 0); + Ceiling_Violation := False; + end if; + + pragma Assert (Record_Lock (Lock_Ptr (L))); + end Write_Lock; + + procedure Write_Lock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + pragma Assert (Check_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); + Result := mutex_lock (L.L'Access); + pragma Assert (Result = 0); + pragma Assert (Record_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_Id) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + pragma Assert (Check_Lock (To_Lock_Ptr (T.Common.LL.L'Access))); + Result := mutex_lock (T.Common.LL.L.L'Access); + pragma Assert (Result = 0); + pragma Assert (Record_Lock (To_Lock_Ptr (T.Common.LL.L'Access))); + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock + (L : not null access Lock; + Ceiling_Violation : out Boolean) is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : not null access Lock) is + Result : Interfaces.C.int; + + begin + pragma Assert (Check_Unlock (Lock_Ptr (L))); + + if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then + declare + Self_Id : constant Task_Id := Self; + + begin + Result := mutex_unlock (L.L'Access); + pragma Assert (Result = 0); + + if Self_Id.Common.LL.Active_Priority > L.Saved_Priority then + Set_Priority (Self_Id, L.Saved_Priority); + end if; + end; + else + Result := mutex_unlock (L.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + pragma Assert (Check_Unlock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); + Result := mutex_unlock (L.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock (T : Task_Id) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + pragma Assert (Check_Unlock (To_Lock_Ptr (T.Common.LL.L'Access))); + Result := mutex_unlock (T.Common.LL.L.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + ----------------- + -- Set_Ceiling -- + ----------------- + + -- Dynamic priority ceilings are not supported by the underlying system + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + pragma Unreferenced (L, Prio); + begin + null; + end Set_Ceiling; + + -- For the time delay implementation, we need to make sure we + -- achieve following criteria: + + -- 1) We have to delay at least for the amount requested. + -- 2) We have to give up CPU even though the actual delay does not + -- result in blocking. + -- 3) Except for restricted run-time systems that do not support + -- ATC or task abort, the delay must be interrupted by the + -- abort_task operation. + -- 4) The implementation has to be efficient so that the delay overhead + -- is relatively cheap. + -- (1)-(3) are Ada requirements. Even though (2) is an Annex-D + -- requirement we still want to provide the effect in all cases. + -- The reason is that users may want to use short delays to implement + -- their own scheduling effect in the absence of language provided + -- scheduling policies. + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + TS : aliased timespec; + Result : Interfaces.C.int; + begin + Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); + pragma Assert (Result = 0); + return To_Duration (TS); + end Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + return 10#1.0#E-6; + end RT_Resolution; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + begin + if Do_Yield then + System.OS_Interface.thr_yield; + end if; + end Yield; + + ----------- + -- Self --- + ----------- + + function Self return Task_Id renames Specific.Self; + + ------------------ + -- Set_Priority -- + ------------------ + + procedure Set_Priority + (T : Task_Id; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + pragma Unreferenced (Loss_Of_Inheritance); + + Result : Interfaces.C.int; + pragma Unreferenced (Result); + + Param : aliased struct_pcparms; + + use Task_Info; + + begin + T.Common.Current_Priority := Prio; + + if Priority_Ceiling_Emulation then + T.Common.LL.Active_Priority := Prio; + end if; + + if Using_Real_Time_Class then + Param.pc_cid := Prio_Param.pc_cid; + Param.rt_pri := pri_t (Prio); + Param.rt_tqsecs := Prio_Param.rt_tqsecs; + Param.rt_tqnsecs := Prio_Param.rt_tqnsecs; + + Result := Interfaces.C.int ( + priocntl (PC_VERSION, P_LWPID, T.Common.LL.LWP, PC_SETPARMS, + Param'Address)); + + else + if T.Common.Task_Info /= null + and then not T.Common.Task_Info.Bound_To_LWP + then + -- The task is not bound to a LWP, so use thr_setprio + + Result := + thr_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio)); + + else + -- The task is bound to a LWP, use priocntl + -- ??? TBD + + null; + end if; + end if; + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_Id) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_Id) is + Result : Interfaces.C.int; + Proc : processorid_t; -- User processor # + Last_Proc : processorid_t; -- Last processor # + + use System.Task_Info; + use type System.Multiprocessors.CPU_Range; + + begin + Self_ID.Common.LL.Thread := thr_self; + + Self_ID.Common.LL.LWP := lwp_self; + + -- pragma CPU + + if Self_ID.Common.Base_CPU /= + System.Multiprocessors.Not_A_Specific_CPU + then + -- The CPU numbering in pragma CPU starts at 1 while the subprogram + -- to set the affinity starts at 0, therefore we must subtract 1. + + Result := + processor_bind + (P_LWPID, P_MYID, processorid_t (Self_ID.Common.Base_CPU) - 1, + null); + pragma Assert (Result = 0); + + -- Task_Info + + elsif Self_ID.Common.Task_Info /= null then + if Self_ID.Common.Task_Info.New_LWP + and then Self_ID.Common.Task_Info.CPU /= CPU_UNCHANGED + then + Last_Proc := Num_Procs - 1; + + if Self_ID.Common.Task_Info.CPU = ANY_CPU then + Result := 0; + Proc := 0; + while Proc < Last_Proc loop + Result := p_online (Proc, PR_STATUS); + exit when Result = PR_ONLINE; + Proc := Proc + 1; + end loop; + + Result := processor_bind (P_LWPID, P_MYID, Proc, null); + pragma Assert (Result = 0); + + else + -- Use specified processor + + if Self_ID.Common.Task_Info.CPU < 0 + or else Self_ID.Common.Task_Info.CPU > Last_Proc + then + raise Invalid_CPU_Number; + end if; + + Result := + processor_bind + (P_LWPID, P_MYID, Self_ID.Common.Task_Info.CPU, null); + pragma Assert (Result = 0); + end if; + end if; + end if; + + Specific.Set (Self_ID); + + -- We need the above code even if we do direct fetch of Task_Id in Self + -- for the main task on Sun, x86 Solaris and for gcc 2.7.2. + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_Id is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (thr_self); + end if; + end Register_Foreign_Thread; + + -------------------- + -- Initialize_TCB -- + -------------------- + + procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is + Result : Interfaces.C.int := 0; + + begin + -- Give the task a unique serial number + + Self_ID.Serial_Number := Next_Serial_Number; + Next_Serial_Number := Next_Serial_Number + 1; + pragma Assert (Next_Serial_Number /= 0); + + Self_ID.Common.LL.Thread := To_thread_t (-1); + + if not Single_Lock then + Result := + mutex_init + (Self_ID.Common.LL.L.L'Access, USYNC_THREAD, System.Null_Address); + Self_ID.Common.LL.L.Level := + Private_Task_Serial_Number (Self_ID.Serial_Number); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result = 0 then + Result := cond_init (Self_ID.Common.LL.CV'Access, USYNC_THREAD, 0); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result = 0 then + Succeeded := True; + else + if not Single_Lock then + Result := mutex_destroy (Self_ID.Common.LL.L.L'Access); + pragma Assert (Result = 0); + end if; + + Succeeded := False; + end if; + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_Id; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + pragma Unreferenced (Priority); + + Result : Interfaces.C.int; + Adjusted_Stack_Size : Interfaces.C.size_t; + Opts : Interfaces.C.int := THR_DETACHED; + + Page_Size : constant System.Parameters.Size_Type := 4096; + -- This constant is for reserving extra space at the + -- end of the stack, which can be used by the stack + -- checking as guard page. The idea is that we need + -- to have at least Stack_Size bytes available for + -- actual use. + + use System.Task_Info; + + begin + Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size + Page_Size); + + -- Since the initial signal mask of a thread is inherited from the + -- creator, and the Environment task has all its signals masked, we + -- do not need to manipulate caller's signal mask at this point. + -- All tasks in RTS will have All_Tasks_Mask initially. + + if T.Common.Task_Info /= null then + if T.Common.Task_Info.New_LWP then + Opts := Opts + THR_NEW_LWP; + end if; + + if T.Common.Task_Info.Bound_To_LWP then + Opts := Opts + THR_BOUND; + end if; + + else + Opts := THR_DETACHED + THR_BOUND; + end if; + + Result := + thr_create + (System.Null_Address, + Adjusted_Stack_Size, + Thread_Body_Access (Wrapper), + To_Address (T), + Opts, + T.Common.LL.Thread'Access); + + Succeeded := Result = 0; + pragma Assert + (Result = 0 + or else Result = ENOMEM + or else Result = EAGAIN); + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_Id) is + Result : Interfaces.C.int; + Tmp : Task_Id := T; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + + begin + T.Common.LL.Thread := To_thread_t (0); + + if not Single_Lock then + Result := mutex_destroy (T.Common.LL.L.L'Access); + pragma Assert (Result = 0); + end if; + + Result := cond_destroy (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + Free (Tmp); + + if Is_Self then + Specific.Set (null); + end if; + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + -- This procedure must be called with abort deferred. It can no longer + -- call Self or access the current task's ATCB, since the ATCB has been + -- deallocated. + + procedure Exit_Task is + begin + Specific.Set (null); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_Id) is + Result : Interfaces.C.int; + begin + if Abort_Handler_Installed then + pragma Assert (T /= Self); + Result := + thr_kill + (T.Common.LL.Thread, + Signal (System.Interrupt_Management.Abort_Task_Interrupt)); + pragma Assert (Result = 0); + end if; + end Abort_Task; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : Task_Id; + Reason : Task_States) + is + Result : Interfaces.C.int; + + begin + pragma Assert (Check_Sleep (Reason)); + + if Single_Lock then + Result := + cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock.L'Access); + else + Result := + cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L.L'Access); + end if; + + pragma Assert + (Record_Wakeup (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason)); + pragma Assert (Result = 0 or else Result = EINTR); + end Sleep; + + -- Note that we are relying heavily here on GNAT representing + -- Calendar.Time, System.Real_Time.Time, Duration, + -- System.Real_Time.Time_Span in the same way, i.e., as a 64-bit count of + -- nanoseconds. + + -- This allows us to always pass the timeout value as a Duration + + -- ??? + -- We are taking liberties here with the semantics of the delays. That is, + -- we make no distinction between delays on the Calendar clock and delays + -- on the Real_Time clock. That is technically incorrect, if the Calendar + -- clock happens to be reset or adjusted. To solve this defect will require + -- modification to the compiler interface, so that it can pass through more + -- information, to tell us here which clock to use! + + -- cond_timedwait will return if any of the following happens: + -- 1) some other task did cond_signal on this condition variable + -- In this case, the return value is 0 + -- 2) the call just returned, for no good reason + -- This is called a "spurious wakeup". + -- In this case, the return value may also be 0. + -- 3) the time delay expires + -- In this case, the return value is ETIME + -- 4) this task received a signal, which was handled by some + -- handler procedure, and now the thread is resuming execution + -- UNIX calls this an "interrupted" system call. + -- In this case, the return value is EINTR + + -- If the cond_timedwait returns 0 or EINTR, it is still possible that the + -- time has actually expired, and by chance a signal or cond_signal + -- occurred at around the same time. + + -- We have also observed that on some OS's the value ETIME will be + -- returned, but the clock will show that the full delay has not yet + -- expired. + + -- For these reasons, we need to check the clock after return from + -- cond_timedwait. If the time has expired, we will set Timedout = True. + + -- This check might be omitted for systems on which the cond_timedwait() + -- never returns early or wakes up spuriously. + + -- Annex D requires that completion of a delay cause the task to go to the + -- end of its priority queue, regardless of whether the task actually was + -- suspended by the delay. Since cond_timedwait does not do this on + -- Solaris, we add a call to thr_yield at the end. We might do this at the + -- beginning, instead, but then the round-robin effect would not be the + -- same; the delayed task would be ahead of other tasks of the same + -- priority that awoke while it was sleeping. + + -- For Timed_Sleep, we are expecting possible cond_signals to indicate + -- other events (e.g., completion of a RV or completion of the abortable + -- part of an async. select), we want to always return if interrupted. The + -- caller will be responsible for checking the task state to see whether + -- the wakeup was spurious, and to go back to sleep again in that case. We + -- don't need to check for pending abort or priority change on the way in + -- our out; that is the caller's responsibility. + + -- For Timed_Delay, we are not expecting any cond_signals or other + -- interruptions, except for priority changes and aborts. Therefore, we + -- don't want to return unless the delay has actually expired, or the call + -- has been aborted. In this case, since we want to implement the entire + -- delay statement semantics, we do need to check for pending abort and + -- priority changes. We can quietly handle priority changes inside the + -- procedure, since there is no entry-queue reordering involved. + + ----------------- + -- Timed_Sleep -- + ----------------- + + procedure Timed_Sleep + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + pragma Assert (Check_Sleep (Reason)); + Timedout := True; + Yielded := False; + + Abs_Time := + (if Mode = Relative + then Duration'Min (Time, Max_Sensible_Delay) + Check_Time + else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); + + if Abs_Time > Check_Time then + Request := To_Timespec (Abs_Time); + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + if Single_Lock then + Result := + cond_timedwait + (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock.L'Access, Request'Access); + else + Result := + cond_timedwait + (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L.L'Access, Request'Access); + end if; + + Yielded := True; + + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + if Result = 0 or Result = EINTR then + + -- Somebody may have called Wakeup for us + + Timedout := False; + exit; + end if; + + pragma Assert (Result = ETIME); + end loop; + end if; + + pragma Assert + (Record_Wakeup (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason)); + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes) + is + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + Yielded : Boolean := False; + + begin + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + Abs_Time := + (if Mode = Relative + then Time + Check_Time + else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); + + if Abs_Time > Check_Time then + Request := To_Timespec (Abs_Time); + Self_ID.Common.State := Delay_Sleep; + + pragma Assert (Check_Sleep (Delay_Sleep)); + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + if Single_Lock then + Result := + cond_timedwait + (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock.L'Access, + Request'Access); + else + Result := + cond_timedwait + (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L.L'Access, + Request'Access); + end if; + + Yielded := True; + + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + pragma Assert + (Result = 0 or else + Result = ETIME or else + Result = EINTR); + end loop; + + pragma Assert + (Record_Wakeup + (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Delay_Sleep)); + + Self_ID.Common.State := Runnable; + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + if not Yielded then + thr_yield; + end if; + end Timed_Delay; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup + (T : Task_Id; + Reason : Task_States) + is + Result : Interfaces.C.int; + begin + pragma Assert (Check_Wakeup (T, Reason)); + Result := cond_signal (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Wakeup; + + --------------------------- + -- Check_Initialize_Lock -- + --------------------------- + + -- The following code is intended to check some of the invariant assertions + -- related to lock usage, on which we depend. + + function Check_Initialize_Lock + (L : Lock_Ptr; + Level : Lock_Level) return Boolean + is + Self_ID : constant Task_Id := Self; + + begin + -- Check that caller is abort-deferred + + if Self_ID.Deferral_Level = 0 then + return False; + end if; + + -- Check that the lock is not yet initialized + + if L.Level /= 0 then + return False; + end if; + + L.Level := Lock_Level'Pos (Level) + 1; + return True; + end Check_Initialize_Lock; + + ---------------- + -- Check_Lock -- + ---------------- + + function Check_Lock (L : Lock_Ptr) return Boolean is + Self_ID : constant Task_Id := Self; + P : Lock_Ptr; + + begin + -- Check that the argument is not null + + if L = null then + return False; + end if; + + -- Check that L is not frozen + + if L.Frozen then + return False; + end if; + + -- Check that caller is abort-deferred + + if Self_ID.Deferral_Level = 0 then + return False; + end if; + + -- Check that caller is not holding this lock already + + if L.Owner = To_Owner_ID (To_Address (Self_ID)) then + return False; + end if; + + if Single_Lock then + return True; + end if; + + -- Check that TCB lock order rules are satisfied + + P := Self_ID.Common.LL.Locks; + if P /= null then + if P.Level >= L.Level + and then (P.Level > 2 or else L.Level > 2) + then + return False; + end if; + end if; + + return True; + end Check_Lock; + + ----------------- + -- Record_Lock -- + ----------------- + + function Record_Lock (L : Lock_Ptr) return Boolean is + Self_ID : constant Task_Id := Self; + P : Lock_Ptr; + + begin + Lock_Count := Lock_Count + 1; + + -- There should be no owner for this lock at this point + + if L.Owner /= null then + return False; + end if; + + -- Record new owner + + L.Owner := To_Owner_ID (To_Address (Self_ID)); + + if Single_Lock then + return True; + end if; + + -- Check that TCB lock order rules are satisfied + + P := Self_ID.Common.LL.Locks; + + if P /= null then + L.Next := P; + end if; + + Self_ID.Common.LL.Locking := null; + Self_ID.Common.LL.Locks := L; + return True; + end Record_Lock; + + ----------------- + -- Check_Sleep -- + ----------------- + + function Check_Sleep (Reason : Task_States) return Boolean is + pragma Unreferenced (Reason); + + Self_ID : constant Task_Id := Self; + P : Lock_Ptr; + + begin + -- Check that caller is abort-deferred + + if Self_ID.Deferral_Level = 0 then + return False; + end if; + + if Single_Lock then + return True; + end if; + + -- Check that caller is holding own lock, on top of list + + if Self_ID.Common.LL.Locks /= + To_Lock_Ptr (Self_ID.Common.LL.L'Access) + then + return False; + end if; + + -- Check that TCB lock order rules are satisfied + + if Self_ID.Common.LL.Locks.Next /= null then + return False; + end if; + + Self_ID.Common.LL.L.Owner := null; + P := Self_ID.Common.LL.Locks; + Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next; + P.Next := null; + return True; + end Check_Sleep; + + ------------------- + -- Record_Wakeup -- + ------------------- + + function Record_Wakeup + (L : Lock_Ptr; + Reason : Task_States) return Boolean + is + pragma Unreferenced (Reason); + + Self_ID : constant Task_Id := Self; + P : Lock_Ptr; + + begin + -- Record new owner + + L.Owner := To_Owner_ID (To_Address (Self_ID)); + + if Single_Lock then + return True; + end if; + + -- Check that TCB lock order rules are satisfied + + P := Self_ID.Common.LL.Locks; + + if P /= null then + L.Next := P; + end if; + + Self_ID.Common.LL.Locking := null; + Self_ID.Common.LL.Locks := L; + return True; + end Record_Wakeup; + + ------------------ + -- Check_Wakeup -- + ------------------ + + function Check_Wakeup + (T : Task_Id; + Reason : Task_States) return Boolean + is + Self_ID : constant Task_Id := Self; + + begin + -- Is caller holding T's lock? + + if T.Common.LL.L.Owner /= To_Owner_ID (To_Address (Self_ID)) then + return False; + end if; + + -- Are reasons for wakeup and sleep consistent? + + if T.Common.State /= Reason then + return False; + end if; + + return True; + end Check_Wakeup; + + ------------------ + -- Check_Unlock -- + ------------------ + + function Check_Unlock (L : Lock_Ptr) return Boolean is + Self_ID : constant Task_Id := Self; + P : Lock_Ptr; + + begin + Unlock_Count := Unlock_Count + 1; + + if L = null then + return False; + end if; + + if L.Buddy /= null then + return False; + end if; + + -- Magic constant 4??? + + if L.Level = 4 then + Check_Count := Unlock_Count; + end if; + + -- Magic constant 1000??? + + if Unlock_Count - Check_Count > 1000 then + Check_Count := Unlock_Count; + end if; + + -- Check that caller is abort-deferred + + if Self_ID.Deferral_Level = 0 then + return False; + end if; + + -- Check that caller is holding this lock, on top of list + + if Self_ID.Common.LL.Locks /= L then + return False; + end if; + + -- Record there is no owner now + + L.Owner := null; + P := Self_ID.Common.LL.Locks; + Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next; + P.Next := null; + return True; + end Check_Unlock; + + -------------------- + -- Check_Finalize -- + -------------------- + + function Check_Finalize_Lock (L : Lock_Ptr) return Boolean is + Self_ID : constant Task_Id := Self; + + begin + -- Check that caller is abort-deferred + + if Self_ID.Deferral_Level = 0 then + return False; + end if; + + -- Check that no one is holding this lock + + if L.Owner /= null then + return False; + end if; + + L.Frozen := True; + return True; + end Check_Finalize_Lock; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + -- Initialize internal state (always to zero (RM D.10(6))) + + S.State := False; + S.Waiting := False; + + -- Initialize internal mutex + + Result := mutex_init (S.L'Access, USYNC_THREAD, System.Null_Address); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error with "Failed to allocate a lock"; + end if; + + -- Initialize internal condition variable + + Result := cond_init (S.CV'Access, USYNC_THREAD, 0); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Result := mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + if Result = ENOMEM then + raise Storage_Error; + end if; + end if; + end Initialize; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + -- Destroy internal mutex + + Result := mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + -- Destroy internal condition variable + + Result := cond_destroy (S.CV'Access); + pragma Assert (Result = 0); + end Finalize; + + ------------------- + -- Current_State -- + ------------------- + + function Current_State (S : Suspension_Object) return Boolean is + begin + -- We do not want to use lock on this read operation. State is marked + -- as Atomic so that we ensure that the value retrieved is correct. + + return S.State; + end Current_State; + + --------------- + -- Set_False -- + --------------- + + procedure Set_False (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + S.State := False; + + Result := mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end Set_False; + + -------------- + -- Set_True -- + -------------- + + procedure Set_True (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + -- If there is already a task waiting on this suspension object then + -- we resume it, leaving the state of the suspension object to False, + -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves + -- the state to True. + + if S.Waiting then + S.Waiting := False; + S.State := False; + + Result := cond_signal (S.CV'Access); + pragma Assert (Result = 0); + + else + S.State := True; + end if; + + Result := mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end Set_True; + + ------------------------ + -- Suspend_Until_True -- + ------------------------ + + procedure Suspend_Until_True (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + if S.Waiting then + + -- Program_Error must be raised upon calling Suspend_Until_True + -- if another task is already waiting on that suspension object + -- (RM D.10(10)). + + Result := mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + + raise Program_Error; + + else + -- Suspend the task if the state is False. Otherwise, the task + -- continues its execution, and the state of the suspension object + -- is set to False (ARM D.10 par. 9). + + if S.State then + S.State := False; + else + S.Waiting := True; + + loop + -- Loop in case pthread_cond_wait returns earlier than expected + -- (e.g. in case of EINTR caused by a signal). + + Result := cond_wait (S.CV'Access, S.L'Access); + pragma Assert (Result = 0 or else Result = EINTR); + + exit when not S.Waiting; + end loop; + end if; + + Result := mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end if; + end Suspend_Until_True; + + ---------------- + -- Check_Exit -- + ---------------- + + function Check_Exit (Self_ID : Task_Id) return Boolean is + begin + -- Check that caller is just holding Global_Task_Lock and no other locks + + if Self_ID.Common.LL.Locks = null then + return False; + end if; + + -- 2 = Global_Task_Level + + if Self_ID.Common.LL.Locks.Level /= 2 then + return False; + end if; + + if Self_ID.Common.LL.Locks.Next /= null then + return False; + end if; + + -- Check that caller is abort-deferred + + if Self_ID.Deferral_Level = 0 then + return False; + end if; + + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : Task_Id) return Boolean is + begin + return Self_ID.Common.LL.Locks = null; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_Id is + begin + return Environment_Task_Id; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + begin + if T.Common.LL.Thread /= Thread_Self then + return thr_suspend (T.Common.LL.Thread) = 0; + else + return True; + end if; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + begin + if T.Common.LL.Thread /= Thread_Self then + return thr_continue (T.Common.LL.Thread) = 0; + else + return True; + end if; + end Resume_Task; + + -------------------- + -- Stop_All_Tasks -- + -------------------- + + procedure Stop_All_Tasks is + begin + null; + end Stop_All_Tasks; + + --------------- + -- Stop_Task -- + --------------- + + function Stop_Task (T : ST.Task_Id) return Boolean is + pragma Unreferenced (T); + begin + return False; + end Stop_Task; + + ------------------- + -- Continue_Task -- + ------------------- + + function Continue_Task (T : ST.Task_Id) return Boolean is + pragma Unreferenced (T); + begin + return False; + end Continue_Task; + +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-tru64.adb b/gcc/ada/s-taprop-tru64.adb new file mode 100644 index 000000000..cd23f16d9 --- /dev/null +++ b/gcc/ada/s-taprop-tru64.adb @@ -0,0 +1,1361 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a Tru64 version of this package + +-- This package contains all the GNULL primitives that interface directly with +-- the underlying OS. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +with Ada.Unchecked_Deallocation; + +with Interfaces; +with Interfaces.C; + +with System.Tasking.Debug; +with System.Interrupt_Management; +with System.OS_Primitives; +with System.Task_Info; + +with System.Soft_Links; +-- We use System.Soft_Links instead of System.Tasking.Initialization +-- because the later is a higher level package that we shouldn't depend on. +-- For example when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Stages. + +package body System.Task_Primitives.Operations is + + package SSL renames System.Soft_Links; + + use System.Tasking.Debug; + use System.Tasking; + use Interfaces.C; + use System.OS_Interface; + use System.Parameters; + use System.OS_Primitives; + + ---------------- + -- Local Data -- + ---------------- + + -- The followings are logically constants, but need to be initialized + -- at run time. + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + ATCB_Key : aliased pthread_key_t; + -- Key used to find the Ada Task_Id associated with a thread + + Environment_Task_Id : Task_Id; + -- A variable to hold Task_Id for the environment task + + Unblocked_Signal_Mask : aliased sigset_t; + -- The set of signals that should unblocked in all tasks + + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + Locking_Policy : Character; + pragma Import (C, Locking_Policy, "__gl_locking_policy"); + + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + Curpid : pid_t; + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads) + + Abort_Handler_Installed : Boolean := False; + -- True if a handler for the abort signal is installed + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + procedure Initialize (Environment_Task : Task_Id); + pragma Inline (Initialize); + -- Initialize various data needed by this package + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does executing thread have a TCB? + + procedure Set (Self_Id : Task_Id); + pragma Inline (Set); + -- Set the self id for the current task + + function Self return Task_Id; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task + + end Specific; + + package body Specific is separate; + -- The body of this package is target specific + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; + -- Allocate and initialize a new ATCB for the current Thread + + function Register_Foreign_Thread + (Thread : Thread_Id) return Task_Id is separate; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Abort_Handler (Sig : Signal); + -- Signal handler used to implement asynchronous abort + + function Get_Policy (Prio : System.Any_Priority) return Character; + pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); + -- Get priority specific dispatching policy + + ------------------- + -- Abort_Handler -- + ------------------- + + procedure Abort_Handler (Sig : Signal) is + pragma Unreferenced (Sig); + + T : constant Task_Id := Self; + Old_Set : aliased sigset_t; + + Result : Interfaces.C.int; + pragma Warnings (Off, Result); + + begin + -- It's not safe to raise an exception when using GCC ZCX mechanism. + -- Note that we still need to install a signal handler, since in some + -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we + -- need to send the Abort signal to a task. + + if ZCX_By_Default and then GCC_ZCX_Support then + return; + end if; + + if T.Deferral_Level = 0 + and then T.Pending_ATC_Level < T.ATC_Nesting_Level + and then not T.Aborting + then + T.Aborting := True; + + -- Make sure signals used for RTS internal purpose are unmasked + + Result := + pthread_sigmask + (SIG_UNBLOCK, + Unblocked_Signal_Mask'Access, + Old_Set'Access); + pragma Assert (Result = 0); + + raise Standard'Abort_Signal; + end if; + end Abort_Handler; + + ------------------ + -- Stack_Guard -- + ------------------ + + -- The underlying thread system sets a guard page at the bottom of a thread + -- stack, so nothing is needed. + + procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is + pragma Unreferenced (T); + pragma Unreferenced (On); + begin + null; + end Stack_Guard; + + -------------------- + -- Get_Thread_Id -- + -------------------- + + function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_Id renames Specific.Self; + + --------------------- + -- Initialize_Lock -- + --------------------- + + -- Note: mutexes and cond_variables needed per-task basis are initialized + -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such + -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any + -- status change of RTS. Therefore raising Storage_Error in the following + -- routines should be able to be handled safely. + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : not null access Lock) + is + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + if Locking_Policy = 'C' then + L.Ceiling := Interfaces.C.int (Prio); + end if; + + Result := pthread_mutex_init (L.L'Access, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Attributes'Access); + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + procedure Initialize_Lock + (L : not null access RTS_Lock; + Level : Lock_Level) + is + pragma Unreferenced (Level); + + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutex_init (L, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Attributes'Access); + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : not null access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L.L'Access); + pragma Assert (Result = 0); + end Finalize_Lock; + + procedure Finalize_Lock (L : not null access RTS_Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is + Result : Interfaces.C.int; + Self_ID : Task_Id; + All_Tasks_Link : Task_Id; + Current_Prio : System.Any_Priority; + + begin + -- Perform ceiling checks only when this is the locking policy in use + + if Locking_Policy = 'C' then + Self_ID := Self; + All_Tasks_Link := Self_ID.Common.All_Tasks_Link; + Current_Prio := Get_Priority (Self_ID); + + -- If there is no other task, no need to check priorities + + if All_Tasks_Link /= Null_Task + and then L.Ceiling < Interfaces.C.int (Current_Prio) + then + Ceiling_Violation := True; + return; + end if; + end if; + + Result := pthread_mutex_lock (L.L'Access); + pragma Assert (Result = 0); + + Ceiling_Violation := False; + end Write_Lock; + + procedure Write_Lock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_lock (L); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_Id) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_lock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : not null access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_unlock (L.L'Access); + pragma Assert (Result = 0); + end Unlock; + + procedure Unlock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock (T : Task_Id) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_unlock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + ----------------- + -- Set_Ceiling -- + ----------------- + + -- Dynamic priority ceilings are not supported by the underlying system + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + pragma Unreferenced (L, Prio); + begin + null; + end Set_Ceiling; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : Task_Id; + Reason : System.Tasking.Task_States) + is + pragma Unreferenced (Reason); + + Result : Interfaces.C.int; + + begin + Result := + pthread_cond_wait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access)); + + -- EINTR is not considered a failure + + pragma Assert (Result = 0 or else Result = EINTR); + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + -- This is for use within the run-time system, so abort is assumed to be + -- already deferred, and the caller should be holding its own ATCB lock. + + procedure Timed_Sleep + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Unreferenced (Reason); + + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + Timedout := True; + Yielded := False; + + Abs_Time := + (if Mode = Relative + then Duration'Min (Time, Max_Sensible_Delay) + Check_Time + else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); + + if Abs_Time > Check_Time then + Request := To_Timespec (Abs_Time); + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); + + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + if Result = 0 or Result = EINTR then + + -- Somebody may have called Wakeup for us + + Timedout := False; + exit; + end if; + + pragma Assert (Result = ETIMEDOUT); + end loop; + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + -- This is for use in implementing delay statements, so we assume the + -- caller is abort-deferred but is holding no locks. + + procedure Timed_Delay + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes) + is + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + Abs_Time := + (if Mode = Relative + then Time + Check_Time + else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); + + if Abs_Time > Check_Time then + Request := To_Timespec (Abs_Time); + Self_ID.Common.State := Delay_Sleep; + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); + + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + pragma Assert (Result = 0 or else + Result = ETIMEDOUT or else + Result = EINTR); + end loop; + + Self_ID.Common.State := Runnable; + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + Yield; + end Timed_Delay; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + TS : aliased timespec; + Result : Interfaces.C.int; + begin + Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); + pragma Assert (Result = 0); + return To_Duration (TS); + end Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + -- Returned value must be an integral multiple of Duration'Small (1 ns) + -- The following is the best approximation of 1/1024. The clock on the + -- DEC Alpha ticks at 1024 Hz. + + return 0.000_976_563; + end RT_Resolution; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + begin + Result := pthread_cond_signal (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + Result : Interfaces.C.int; + pragma Unreferenced (Result); + begin + if Do_Yield then + Result := sched_yield; + end if; + end Yield; + + ------------------ + -- Set_Priority -- + ------------------ + + procedure Set_Priority + (T : Task_Id; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + pragma Unreferenced (Loss_Of_Inheritance); + + Result : Interfaces.C.int; + Param : aliased struct_sched_param; + + Priority_Specific_Policy : constant Character := Get_Policy (Prio); + -- Upper case first character of the policy name corresponding to the + -- task as set by a Priority_Specific_Dispatching pragma. + + begin + T.Common.Current_Priority := Prio; + Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio)); + + if Dispatching_Policy = 'R' + or else Priority_Specific_Policy = 'R' + or else Time_Slice_Val > 0 + then + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_RR, Param'Access); + + elsif Dispatching_Policy = 'F' + or else Priority_Specific_Policy = 'F' + or else Time_Slice_Val = 0 + then + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_FIFO, Param'Access); + + else + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_OTHER, Param'Access); + end if; + + pragma Assert (Result = 0); + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_Id) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_Id) is + begin + Hide_Unhide_Yellow_Zone (Hide => True); + Self_ID.Common.LL.Thread := pthread_self; + + Specific.Set (Self_ID); + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_Id is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (pthread_self); + end if; + end Register_Foreign_Thread; + + -------------------- + -- Initialize_TCB -- + -------------------- + + procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is + Mutex_Attr : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + Cond_Attr : aliased pthread_condattr_t; + + begin + if not Single_Lock then + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := + pthread_mutex_init + (Self_ID.Common.LL.L'Access, Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := + pthread_cond_init + (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result = 0 then + Succeeded := True; + else + if not Single_Lock then + Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Succeeded := False; + end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_Id; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + Attributes : aliased pthread_attr_t; + Adjusted_Stack_Size : Interfaces.C.size_t; + Result : Interfaces.C.int; + Param : aliased System.OS_Interface.struct_sched_param; + + Priority_Specific_Policy : constant Character := Get_Policy (Priority); + -- Upper case first character of the policy name corresponding to the + -- task as set by a Priority_Specific_Dispatching pragma. + + use System.Task_Info; + + begin + -- Account for the Yellow Zone (2 pages) and the guard page right above. + -- See Hide_Unhide_Yellow_Zone for the rationale. + + Adjusted_Stack_Size := + Interfaces.C.size_t (Stack_Size) + 3 * Get_Page_Size; + + Result := pthread_attr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := + pthread_attr_setdetachstate + (Attributes'Access, PTHREAD_CREATE_DETACHED); + pragma Assert (Result = 0); + + Result := + pthread_attr_setstacksize + (Attributes'Access, Adjusted_Stack_Size); + pragma Assert (Result = 0); + + Param.sched_priority := + Interfaces.C.int (Underlying_Priorities (Priority)); + Result := + pthread_attr_setschedparam + (Attributes'Access, Param'Access); + pragma Assert (Result = 0); + + if Dispatching_Policy = 'R' + or else Priority_Specific_Policy = 'R' + or else Time_Slice_Val > 0 + then + Result := + pthread_attr_setschedpolicy + (Attributes'Access, System.OS_Interface.SCHED_RR); + + elsif Dispatching_Policy = 'F' + or else Priority_Specific_Policy = 'F' + or else Time_Slice_Val = 0 + then + Result := + pthread_attr_setschedpolicy + (Attributes'Access, System.OS_Interface.SCHED_FIFO); + + else + Result := + pthread_attr_setschedpolicy + (Attributes'Access, System.OS_Interface.SCHED_OTHER); + end if; + + pragma Assert (Result = 0); + + -- Set the scheduling parameters explicitly, since this is the only way + -- to force the OS to take e.g. the sched policy and scope attributes + -- into account. + + Result := + pthread_attr_setinheritsched + (Attributes'Access, PTHREAD_EXPLICIT_SCHED); + pragma Assert (Result = 0); + + T.Common.Current_Priority := Priority; + + if T.Common.Task_Info /= null then + case T.Common.Task_Info.Contention_Scope is + when System.Task_Info.Process_Scope => + Result := + pthread_attr_setscope + (Attributes'Access, PTHREAD_SCOPE_PROCESS); + + when System.Task_Info.System_Scope => + Result := + pthread_attr_setscope + (Attributes'Access, PTHREAD_SCOPE_SYSTEM); + + when System.Task_Info.Default_Scope => + Result := 0; + end case; + + pragma Assert (Result = 0); + end if; + + -- Since the initial signal mask of a thread is inherited from the + -- creator, and the Environment task has all its signals masked, we + -- do not need to manipulate caller's signal mask at this point. + -- All tasks in RTS will have All_Tasks_Mask initially. + + Result := + pthread_create + (T.Common.LL.Thread'Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); + pragma Assert (Result = 0 or else Result = EAGAIN); + + Succeeded := Result = 0; + + Result := pthread_attr_destroy (Attributes'Access); + pragma Assert (Result = 0); + + if Succeeded and then T.Common.Task_Info /= null then + + -- ??? We're using a process-wide function to implement a task + -- specific characteristic. + + if T.Common.Task_Info.Bind_To_Cpu_Number = 0 then + Result := bind_to_cpu (Curpid, 0); + + elsif T.Common.Task_Info.Bind_To_Cpu_Number > 0 then + Result := + bind_to_cpu + (Curpid, + Interfaces.C.unsigned_long ( + Interfaces.Shift_Left + (Interfaces.Unsigned_64'(1), + T.Common.Task_Info.Bind_To_Cpu_Number - 1))); + pragma Assert (Result = 0); + end if; + end if; + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_Id) is + Result : Interfaces.C.int; + Tmp : Task_Id := T; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + + begin + if not Single_Lock then + Result := pthread_mutex_destroy (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_cond_destroy (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + Free (Tmp); + + if Is_Self then + Specific.Set (null); + end if; + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + Specific.Set (null); + Hide_Unhide_Yellow_Zone (Hide => False); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_Id) is + Result : Interfaces.C.int; + begin + if Abort_Handler_Installed then + Result := pthread_kill (T.Common.LL.Thread, + Signal (System.Interrupt_Management.Abort_Task_Interrupt)); + pragma Assert (Result = 0); + end if; + end Abort_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (S : in out Suspension_Object) is + Mutex_Attr : aliased pthread_mutexattr_t; + Cond_Attr : aliased pthread_condattr_t; + Result : Interfaces.C.int; + + begin + -- Initialize internal state (always to False (RM D.10(6))) + + S.State := False; + S.Waiting := False; + + -- Initialize internal mutex + + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + + -- Initialize internal condition variable + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); + + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + if Result = ENOMEM then + raise Storage_Error; + end if; + end if; + end Initialize; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + -- Destroy internal mutex + + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + -- Destroy internal condition variable + + Result := pthread_cond_destroy (S.CV'Access); + pragma Assert (Result = 0); + end Finalize; + + ------------------- + -- Current_State -- + ------------------- + + function Current_State (S : Suspension_Object) return Boolean is + begin + -- We do not want to use lock on this read operation. State is marked + -- as Atomic so that we ensure that the value retrieved is correct. + + return S.State; + end Current_State; + + --------------- + -- Set_False -- + --------------- + + procedure Set_False (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + S.State := False; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end Set_False; + + -------------- + -- Set_True -- + -------------- + + procedure Set_True (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + -- If there is already a task waiting on this suspension object then we + -- resume it, leaving the state of the suspension object to False, as + -- specified in (RM D.10(9)). Otherwise, leave the state set to True. + + if S.Waiting then + S.Waiting := False; + S.State := False; + + Result := pthread_cond_signal (S.CV'Access); + pragma Assert (Result = 0); + + else + S.State := True; + end if; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end Set_True; + + ------------------------ + -- Suspend_Until_True -- + ------------------------ + + procedure Suspend_Until_True (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + if S.Waiting then + + -- Program_Error must be raised upon calling Suspend_Until_True + -- if another task is already waiting on that suspension object + -- (AM D.10(10)). + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + + raise Program_Error; + + else + -- Suspend the task if the state is False. Otherwise, the task + -- continues its execution, and the state of the suspension object + -- is set to False (RM D.10(9)). + + if S.State then + S.State := False; + else + S.Waiting := True; + + loop + -- Loop in case pthread_cond_wait returns earlier than expected + -- (e.g. in case of EINTR caused by a signal). + + Result := pthread_cond_wait (S.CV'Access, S.L'Access); + pragma Assert (Result = 0 or else Result = EINTR); + + exit when not S.Waiting; + end loop; + end if; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end if; + end Suspend_Until_True; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy version + + function Check_Exit (Self_ID : ST.Task_Id) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_Id is + begin + return Environment_Task_Id; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + pragma Unreferenced (T, Thread_Self); + begin + return False; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + pragma Unreferenced (T, Thread_Self); + begin + return False; + end Resume_Task; + + -------------------- + -- Stop_All_Tasks -- + -------------------- + + procedure Stop_All_Tasks is + begin + null; + end Stop_All_Tasks; + + --------------- + -- Stop_Task -- + --------------- + + function Stop_Task (T : ST.Task_Id) return Boolean is + pragma Unreferenced (T); + begin + return False; + end Stop_Task; + + ------------------- + -- Continue_Task -- + ------------------- + + function Continue_Task (T : ST.Task_Id) return Boolean is + pragma Unreferenced (T); + begin + return False; + end Continue_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_Id) is + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + Tmp_Set : aliased sigset_t; + Result : Interfaces.C.int; + + function State + (Int : System.Interrupt_Management.Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state. Defined in a-init.c. The input argument is + -- the interrupt number, and the result is one of the following: + + Default : constant Character := 's'; + -- 'n' this interrupt not set by any Interrupt_State pragma + -- 'u' Interrupt_State pragma set state to User + -- 'r' Interrupt_State pragma set state to Runtime + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + + begin + Environment_Task_Id := Environment_Task; + + Interrupt_Management.Initialize; + + -- Prepare the set of signals that should unblocked in all tasks + + Result := sigemptyset (Unblocked_Signal_Mask'Access); + pragma Assert (Result = 0); + + for J in Interrupt_Management.Interrupt_ID loop + if System.Interrupt_Management.Keep_Unmasked (J) then + Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); + pragma Assert (Result = 0); + end if; + end loop; + + Curpid := getpid; + + -- Initialize the lock used to synchronize chain of all ATCBs + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + Specific.Initialize (Environment_Task); + + -- Make environment task known here because it doesn't go through + -- Activate_Tasks, which does it for all other tasks. + + Known_Tasks (Known_Tasks'First) := Environment_Task; + Environment_Task.Known_Tasks_Index := Known_Tasks'First; + + Enter_Task (Environment_Task); + + if State + (System.Interrupt_Management.Abort_Task_Interrupt) /= Default + then + act.sa_flags := 0; + act.sa_handler := Abort_Handler'Address; + + Result := sigemptyset (Tmp_Set'Access); + pragma Assert (Result = 0); + act.sa_mask := Tmp_Set; + + Result := + sigaction + (Signal (System.Interrupt_Management.Abort_Task_Interrupt), + act'Unchecked_Access, + old_act'Unchecked_Access); + pragma Assert (Result = 0); + Abort_Handler_Installed := True; + end if; + end Initialize; + +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb new file mode 100644 index 000000000..582f88bcb --- /dev/null +++ b/gcc/ada/s-taprop-vms.adb @@ -0,0 +1,1276 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a OpenVMS/Alpha version of this package + +-- This package contains all the GNULL primitives that interface directly with +-- the underlying OS. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +with Interfaces.C; + +with System.Tasking.Debug; +with System.OS_Primitives; +with System.Soft_Links; +with System.Aux_DEC; + +package body System.Task_Primitives.Operations is + + use System.Tasking.Debug; + use System.Tasking; + use Interfaces.C; + use System.OS_Interface; + use System.Parameters; + use System.OS_Primitives; + use type System.OS_Primitives.OS_Time; + + package SSL renames System.Soft_Links; + + ---------------- + -- Local Data -- + ---------------- + + -- The followings are logically constants, but need to be initialized + -- at run time. + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + ATCB_Key : aliased pthread_key_t; + -- Key used to find the Ada Task_Id associated with a thread + + Environment_Task_Id : Task_Id; + -- A variable to hold Task_Id for the environment task + + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads) + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + procedure Initialize (Environment_Task : Task_Id); + pragma Inline (Initialize); + -- Initialize various data needed by this package + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does executing thread have a TCB? + + procedure Set (Self_Id : Task_Id); + pragma Inline (Set); + -- Set the self id for the current task + + function Self return Task_Id; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task + + end Specific; + + package body Specific is separate; + -- The body of this package is target specific + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; + -- Allocate and Initialize a new ATCB for the current Thread + + function Register_Foreign_Thread + (Thread : Thread_Id) return Task_Id is separate; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function To_Task_Id is + new Ada.Unchecked_Conversion + (System.Task_Primitives.Task_Address, Task_Id); + + function To_Address is + new Ada.Unchecked_Conversion + (Task_Id, System.Task_Primitives.Task_Address); + + function Get_Exc_Stack_Addr return Address; + -- Replace System.Soft_Links.Get_Exc_Stack_Addr_NT + + procedure Timer_Sleep_AST (ID : Address); + pragma Convention (C, Timer_Sleep_AST); + -- Signal the condition variable when AST fires + + procedure Timer_Sleep_AST (ID : Address) is + Result : Interfaces.C.int; + pragma Warnings (Off, Result); + Self_ID : constant Task_Id := To_Task_Id (ID); + begin + Self_ID.Common.LL.AST_Pending := False; + Result := pthread_cond_signal_int_np (Self_ID.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Timer_Sleep_AST; + + ----------------- + -- Stack_Guard -- + ----------------- + + -- The underlying thread system sets a guard page at the bottom of a thread + -- stack, so nothing is needed. + -- ??? Check the comment above + + procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is + pragma Unreferenced (T); + pragma Unreferenced (On); + begin + null; + end Stack_Guard; + + -------------------- + -- Get_Thread_Id -- + -------------------- + + function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_Id renames Specific.Self; + + --------------------- + -- Initialize_Lock -- + --------------------- + + -- Note: mutexes and cond_variables needed per-task basis are initialized + -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such + -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any + -- status change of RTS. Therefore raising Storage_Error in the following + -- routines should be able to be handled safely. + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : not null access Lock) + is + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + L.Prio_Save := 0; + L.Prio := Interfaces.C.int (Prio); + + Result := pthread_mutex_init (L.L'Access, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + procedure Initialize_Lock + (L : not null access RTS_Lock; + Level : Lock_Level) + is + pragma Unreferenced (Level); + + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + +-- Don't use, see comment in s-osinte.ads about ERRORCHECK mutexes??? +-- Result := pthread_mutexattr_settype_np +-- (Attributes'Access, PTHREAD_MUTEX_ERRORCHECK_NP); +-- pragma Assert (Result = 0); + +-- Result := pthread_mutexattr_setprotocol +-- (Attributes'Access, PTHREAD_PRIO_PROTECT); +-- pragma Assert (Result = 0); + +-- Result := pthread_mutexattr_setprioceiling +-- (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); +-- pragma Assert (Result = 0); + + Result := pthread_mutex_init (L, Attributes'Access); + + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : not null access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L.L'Access); + pragma Assert (Result = 0); + end Finalize_Lock; + + procedure Finalize_Lock (L : not null access RTS_Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is + Self_ID : constant Task_Id := Self; + All_Tasks_Link : constant Task_Id := Self.Common.All_Tasks_Link; + Current_Prio : System.Any_Priority; + Result : Interfaces.C.int; + + begin + Current_Prio := Get_Priority (Self_ID); + + -- If there is no other tasks, no need to check priorities + + if All_Tasks_Link /= Null_Task + and then L.Prio < Interfaces.C.int (Current_Prio) + then + Ceiling_Violation := True; + return; + end if; + + Result := pthread_mutex_lock (L.L'Access); + pragma Assert (Result = 0); + + Ceiling_Violation := False; +-- Why is this commented out ??? +-- L.Prio_Save := Interfaces.C.int (Current_Prio); +-- Set_Priority (Self_ID, System.Any_Priority (L.Prio)); + end Write_Lock; + + procedure Write_Lock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_lock (L); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_Id) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_lock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : not null access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_unlock (L.L'Access); + pragma Assert (Result = 0); + end Unlock; + + procedure Unlock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock (T : Task_Id) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_unlock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + ----------------- + -- Set_Ceiling -- + ----------------- + + -- Dynamic priority ceilings are not supported by the underlying system + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + pragma Unreferenced (L, Prio); + begin + null; + end Set_Ceiling; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : Task_Id; + Reason : System.Tasking.Task_States) + is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + + begin + Result := + pthread_cond_wait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access)); + + -- EINTR is not considered a failure + + pragma Assert (Result = 0 or else Result = EINTR); + + if Self_ID.Deferral_Level = 0 + and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + then + Unlock (Self_ID); + raise Standard'Abort_Signal; + end if; + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + procedure Timed_Sleep + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Unreferenced (Reason); + + Sleep_Time : OS_Time; + Result : Interfaces.C.int; + Status : Cond_Value_Type; + + -- The body below requires more comments ??? + + begin + Timedout := False; + Yielded := False; + + Sleep_Time := To_OS_Time (Time, Mode); + + if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then + return; + end if; + + Self_ID.Common.LL.AST_Pending := True; + + Sys_Setimr + (Status, 0, Sleep_Time, + Timer_Sleep_AST'Access, To_Address (Self_ID), 0); + + if (Status and 1) /= 1 then + raise Storage_Error; + end if; + + if Single_Lock then + Result := + pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + pragma Assert (Result = 0); + + else + Result := + pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Yielded := True; + + if not Self_ID.Common.LL.AST_Pending then + Timedout := True; + else + Sys_Cantim (Status, To_Address (Self_ID), 0); + pragma Assert ((Status and 1) = 1); + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes) + is + Sleep_Time : OS_Time; + Result : Interfaces.C.int; + Status : Cond_Value_Type; + Yielded : Boolean := False; + + begin + if Single_Lock then + Lock_RTS; + end if; + + -- More comments required in body below ??? + + Write_Lock (Self_ID); + + if Time /= 0.0 or else Mode /= Relative then + Sleep_Time := To_OS_Time (Time, Mode); + + if Mode = Relative or else OS_Clock <= Sleep_Time then + Self_ID.Common.State := Delay_Sleep; + Self_ID.Common.LL.AST_Pending := True; + + Sys_Setimr + (Status, 0, Sleep_Time, + Timer_Sleep_AST'Access, To_Address (Self_ID), 0); + + -- Comment following test + + if (Status and 1) /= 1 then + raise Storage_Error; + end if; + + loop + if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then + Sys_Cantim (Status, To_Address (Self_ID), 0); + pragma Assert ((Status and 1) = 1); + exit; + end if; + + Result := + pthread_cond_wait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access)); + pragma Assert (Result = 0); + + Yielded := True; + + exit when not Self_ID.Common.LL.AST_Pending; + end loop; + + Self_ID.Common.State := Runnable; + end if; + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + if not Yielded then + Result := sched_yield; + pragma Assert (Result = 0); + end if; + end Timed_Delay; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration + renames System.OS_Primitives.Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + -- Document origin of this magic constant ??? + return 10#1.0#E-3; + end RT_Resolution; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + begin + Result := pthread_cond_signal (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + Result : Interfaces.C.int; + pragma Unreferenced (Result); + begin + if Do_Yield then + Result := sched_yield; + end if; + end Yield; + + ------------------ + -- Set_Priority -- + ------------------ + + procedure Set_Priority + (T : Task_Id; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + pragma Unreferenced (Loss_Of_Inheritance); + + Result : Interfaces.C.int; + Param : aliased struct_sched_param; + + function Get_Policy (Prio : System.Any_Priority) return Character; + pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); + -- Get priority specific dispatching policy + + Priority_Specific_Policy : constant Character := Get_Policy (Prio); + -- Upper case first character of the policy name corresponding to the + -- task as set by a Priority_Specific_Dispatching pragma. + + begin + T.Common.Current_Priority := Prio; + Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio)); + + if Dispatching_Policy = 'R' + or else Priority_Specific_Policy = 'R' + or else Time_Slice_Val > 0 + then + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_RR, Param'Access); + + elsif Dispatching_Policy = 'F' + or else Priority_Specific_Policy = 'F' + or else Time_Slice_Val = 0 + then + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_FIFO, Param'Access); + + else + -- SCHED_OTHER priorities are restricted to the range 8 - 15. + -- Since the translation from Underlying priorities results + -- in a range of 16 - 31, dividing by 2 gives the correct result. + + Param.sched_priority := Param.sched_priority / 2; + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_OTHER, Param'Access); + end if; + + pragma Assert (Result = 0); + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_Id) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_Id) is + begin + Self_ID.Common.LL.Thread := pthread_self; + Specific.Set (Self_ID); + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_Id is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (pthread_self); + end if; + end Register_Foreign_Thread; + + -------------------- + -- Initialize_TCB -- + -------------------- + + procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is + Mutex_Attr : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + Cond_Attr : aliased pthread_condattr_t; + + begin + -- More comments required in body below ??? + + if not Single_Lock then + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := + pthread_mutex_init + (Self_ID.Common.LL.L'Access, Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := + pthread_cond_init + (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result = 0 then + Succeeded := True; + Self_ID.Common.LL.Exc_Stack_Ptr := new Exc_Stack_T; + + else + if not Single_Lock then + Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Succeeded := False; + end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + end Initialize_TCB; + + ------------------------ + -- Get_Exc_Stack_Addr -- + ------------------------ + + function Get_Exc_Stack_Addr return Address is + begin + return Self.Common.LL.Exc_Stack_Ptr (Exc_Stack_T'Last)'Address; + end Get_Exc_Stack_Addr; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_Id; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + Attributes : aliased pthread_attr_t; + Result : Interfaces.C.int; + + function Thread_Body_Access is new + Ada.Unchecked_Conversion (System.Aux_DEC.Short_Address, Thread_Body); + + begin + -- Since the initial signal mask of a thread is inherited from the + -- creator, we need to set our local signal mask to mask all signals + -- during the creation operation, to make sure the new thread is + -- not disturbed by signals before it has set its own Task_Id. + + Result := pthread_attr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := pthread_attr_setdetachstate + (Attributes'Access, PTHREAD_CREATE_DETACHED); + pragma Assert (Result = 0); + + Result := pthread_attr_setstacksize + (Attributes'Access, Interfaces.C.size_t (Stack_Size)); + pragma Assert (Result = 0); + + -- This call may be unnecessary, not sure. ??? + + Result := + pthread_attr_setinheritsched + (Attributes'Access, PTHREAD_EXPLICIT_SCHED); + pragma Assert (Result = 0); + + Result := + pthread_create + (T.Common.LL.Thread'Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); + + -- ENOMEM is a valid run-time error -- do not shut down + + pragma Assert (Result = 0 + or else Result = EAGAIN or else Result = ENOMEM); + + Succeeded := Result = 0; + + Result := pthread_attr_destroy (Attributes'Access); + pragma Assert (Result = 0); + + if Succeeded then + Set_Priority (T, Priority); + end if; + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_Id) is + Result : Interfaces.C.int; + Tmp : Task_Id := T; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + + procedure Free is new Ada.Unchecked_Deallocation + (Exc_Stack_T, Exc_Stack_Ptr_T); + + begin + if not Single_Lock then + Result := pthread_mutex_destroy (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_cond_destroy (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + Free (T.Common.LL.Exc_Stack_Ptr); + Free (Tmp); + + if Is_Self then + Specific.Set (null); + end if; + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + null; + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_Id) is + begin + -- Interrupt Server_Tasks may be waiting on an event flag + + if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then + Wakeup (T, Interrupt_Server_Blocked_On_Event_Flag); + end if; + end Abort_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (S : in out Suspension_Object) is + Mutex_Attr : aliased pthread_mutexattr_t; + Cond_Attr : aliased pthread_condattr_t; + Result : Interfaces.C.int; + begin + -- Initialize internal state (always to False (D.10 (6))) + + S.State := False; + S.Waiting := False; + + -- Initialize internal mutex + + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + + -- Initialize internal condition variable + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + if Result = ENOMEM then + raise Storage_Error; + end if; + end if; + + Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + if Result = ENOMEM then + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + + raise Storage_Error; + end if; + end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + end Initialize; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + -- Destroy internal mutex + + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + -- Destroy internal condition variable + + Result := pthread_cond_destroy (S.CV'Access); + pragma Assert (Result = 0); + end Finalize; + + ------------------- + -- Current_State -- + ------------------- + + function Current_State (S : Suspension_Object) return Boolean is + begin + -- We do not want to use lock on this read operation. State is marked + -- as Atomic so that we ensure that the value retrieved is correct. + + return S.State; + end Current_State; + + --------------- + -- Set_False -- + --------------- + + procedure Set_False (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + S.State := False; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end Set_False; + + -------------- + -- Set_True -- + -------------- + + procedure Set_True (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + -- If there is already a task waiting on this suspension object then + -- we resume it, leaving the state of the suspension object to False, + -- as specified in (RM D.10(9)), otherwise leave state set to True. + + if S.Waiting then + S.Waiting := False; + S.State := False; + + Result := pthread_cond_signal (S.CV'Access); + pragma Assert (Result = 0); + + else + S.State := True; + end if; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end Set_True; + + ------------------------ + -- Suspend_Until_True -- + ------------------------ + + procedure Suspend_Until_True (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + if S.Waiting then + + -- Program_Error must be raised upon calling Suspend_Until_True + -- if another task is already waiting on that suspension object + -- (RM D.10(10)). + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + + raise Program_Error; + + else + -- Suspend the task if the state is False. Otherwise, the task + -- continues its execution, and the state of the suspension object + -- is set to False (ARM D.10 par. 9). + + if S.State then + S.State := False; + else + S.Waiting := True; + + loop + -- Loop in case pthread_cond_wait returns earlier than expected + -- (e.g. in case of EINTR caused by a signal). + + Result := pthread_cond_wait (S.CV'Access, S.L'Access); + pragma Assert (Result = 0 or else Result = EINTR); + + exit when not S.Waiting; + end loop; + end if; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end if; + end Suspend_Until_True; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy version + + function Check_Exit (Self_ID : ST.Task_Id) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_Id is + begin + return Environment_Task_Id; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + pragma Unreferenced (T); + pragma Unreferenced (Thread_Self); + begin + return False; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + pragma Unreferenced (T); + pragma Unreferenced (Thread_Self); + begin + return False; + end Resume_Task; + + -------------------- + -- Stop_All_Tasks -- + -------------------- + + procedure Stop_All_Tasks is + begin + null; + end Stop_All_Tasks; + + --------------- + -- Stop_Task -- + --------------- + + function Stop_Task (T : ST.Task_Id) return Boolean is + pragma Unreferenced (T); + begin + return False; + end Stop_Task; + + ------------------- + -- Continue_Task -- + ------------------- + + function Continue_Task (T : ST.Task_Id) return Boolean is + pragma Unreferenced (T); + begin + return False; + end Continue_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_Id) is + + -- The DEC Ada facility code defined in Starlet + Ada_Facility : constant := 49; + + function DBGEXT (Control_Block : System.Address) + return System.Aux_DEC.Unsigned_Word; + -- DBGEXT is imported from s-tasdeb.adb and its parameter re-typed + -- as Address to avoid having a VMS specific s-tasdeb.ads. + pragma Interface (C, DBGEXT); + pragma Import_Function (DBGEXT, "GNAT$DBGEXT"); + + type Facility_Type is range 0 .. 65535; + + procedure Debug_Register + (ADBGEXT : System.Address; + ATCB_Key : pthread_key_t; + Facility : Facility_Type; + Std_Prolog : Integer); + pragma Import (C, Debug_Register, "CMA$DEBUG_REGISTER"); + begin + Environment_Task_Id := Environment_Task; + + SSL.Get_Exc_Stack_Addr := Get_Exc_Stack_Addr'Access; + + -- Initialize the lock used to synchronize chain of all ATCBs + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + Specific.Initialize (Environment_Task); + + -- Pass the context key on to CMA along with the other parameters + Debug_Register + ( + DBGEXT'Address, -- Our DEBUG handling entry point + ATCB_Key, -- CMA context key for our Ada TCB's + Ada_Facility, -- Out facility code + 0 -- False, we don't have the std TCB prolog + ); + + -- Make environment task known here because it doesn't go through + -- Activate_Tasks, which does it for all other tasks. + + Known_Tasks (Known_Tasks'First) := Environment_Task; + Environment_Task.Known_Tasks_Index := Known_Tasks'First; + + Enter_Task (Environment_Task); + end Initialize; + +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb new file mode 100644 index 000000000..3186f6fb9 --- /dev/null +++ b/gcc/ada/s-taprop-vxworks.adb @@ -0,0 +1,1418 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, 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 VxWorks version of this package + +-- This package contains all the GNULL primitives that interface directly with +-- the underlying OS. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +with Interfaces.C; + +with System.Multiprocessors; +with System.Tasking.Debug; +with System.Interrupt_Management; + +with System.Soft_Links; +-- We use System.Soft_Links instead of System.Tasking.Initialization +-- because the later is a higher level package that we shouldn't depend +-- on. For example when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Stages. + +with System.Task_Info; +with System.VxWorks.Ext; + +package body System.Task_Primitives.Operations is + + package SSL renames System.Soft_Links; + + use System.Tasking.Debug; + use System.Tasking; + use System.OS_Interface; + use System.Parameters; + use type System.VxWorks.Ext.t_id; + use type Interfaces.C.int; + + subtype int is System.OS_Interface.int; + + Relative : constant := 0; + + ---------------- + -- Local Data -- + ---------------- + + -- The followings are logically constants, but need to be initialized at + -- run time. + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at a + -- time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + Environment_Task_Id : Task_Id; + -- A variable to hold Task_Id for the environment task + + Unblocked_Signal_Mask : aliased sigset_t; + -- The set of signals that should unblocked in all tasks + + -- The followings are internal configuration constants needed + + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + Locking_Policy : Character; + pragma Import (C, Locking_Policy, "__gl_locking_policy"); + + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + Mutex_Protocol : Priority_Type; + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads) + + 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. + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + procedure Initialize; + pragma Inline (Initialize); + -- Initialize task specific data + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does executing thread have a TCB? + + procedure Set (Self_Id : Task_Id); + pragma Inline (Set); + -- Set the self id for the current task + + procedure Delete; + pragma Inline (Delete); + -- Delete the task specific data associated with the current task + + function Self return Task_Id; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task + + end Specific; + + package body Specific is separate; + -- The body of this package is target specific + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; + -- Allocate and Initialize a new ATCB for the current Thread + + function Register_Foreign_Thread + (Thread : Thread_Id) return Task_Id is separate; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Abort_Handler (signo : Signal); + -- Handler for the abort (SIGABRT) signal to handle asynchronous abort + + procedure Install_Signal_Handlers; + -- Install the default signal handlers for the current task + + function Is_Task_Context return Boolean; + -- This function returns True if the current execution is in the context + -- of a task, and False if it is an interrupt context. + + function To_Address is + new Ada.Unchecked_Conversion (Task_Id, System.Address); + + ------------------- + -- Abort_Handler -- + ------------------- + + procedure Abort_Handler (signo : Signal) is + pragma Unreferenced (signo); + + Self_ID : constant Task_Id := Self; + Old_Set : aliased sigset_t; + + Result : int; + pragma Warnings (Off, Result); + + begin + -- It is not safe to raise an exception when using ZCX and the GCC + -- exception handling mechanism. + + if ZCX_By_Default and then GCC_ZCX_Support then + return; + end if; + + if Self_ID.Deferral_Level = 0 + and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + and then not Self_ID.Aborting + then + Self_ID.Aborting := True; + + -- Make sure signals used for RTS internal purpose are unmasked + + Result := + pthread_sigmask + (SIG_UNBLOCK, + Unblocked_Signal_Mask'Access, + Old_Set'Access); + pragma Assert (Result = 0); + + raise Standard'Abort_Signal; + end if; + end Abort_Handler; + + ----------------- + -- Stack_Guard -- + ----------------- + + procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is + pragma Unreferenced (T); + pragma Unreferenced (On); + + begin + -- Nothing needed (why not???) + + null; + end Stack_Guard; + + ------------------- + -- Get_Thread_Id -- + ------------------- + + function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_Id renames Specific.Self; + + ----------------------------- + -- Install_Signal_Handlers -- + ----------------------------- + + procedure Install_Signal_Handlers is + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + Tmp_Set : aliased sigset_t; + Result : int; + + begin + act.sa_flags := 0; + act.sa_handler := Abort_Handler'Address; + + Result := sigemptyset (Tmp_Set'Access); + pragma Assert (Result = 0); + act.sa_mask := Tmp_Set; + + Result := + sigaction + (Signal (Interrupt_Management.Abort_Task_Interrupt), + act'Unchecked_Access, + old_act'Unchecked_Access); + pragma Assert (Result = 0); + + Interrupt_Management.Initialize_Interrupts; + end Install_Signal_Handlers; + + --------------------- + -- Initialize_Lock -- + --------------------- + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : not null access Lock) + is + begin + L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); + L.Prio_Ceiling := int (Prio); + L.Protocol := Mutex_Protocol; + pragma Assert (L.Mutex /= 0); + end Initialize_Lock; + + procedure Initialize_Lock + (L : not null access RTS_Lock; + Level : Lock_Level) + is + pragma Unreferenced (Level); + begin + L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); + L.Prio_Ceiling := int (System.Any_Priority'Last); + L.Protocol := Mutex_Protocol; + pragma Assert (L.Mutex /= 0); + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : not null access Lock) is + Result : int; + begin + Result := semDelete (L.Mutex); + pragma Assert (Result = 0); + end Finalize_Lock; + + procedure Finalize_Lock (L : not null access RTS_Lock) is + Result : int; + begin + Result := semDelete (L.Mutex); + pragma Assert (Result = 0); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is + Result : int; + + begin + if L.Protocol = Prio_Protect + and then int (Self.Common.Current_Priority) > L.Prio_Ceiling + then + Ceiling_Violation := True; + return; + else + Ceiling_Violation := False; + end if; + + Result := semTake (L.Mutex, WAIT_FOREVER); + pragma Assert (Result = 0); + end Write_Lock; + + procedure Write_Lock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : int; + begin + if not Single_Lock or else Global_Lock then + Result := semTake (L.Mutex, WAIT_FOREVER); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_Id) is + Result : int; + begin + if not Single_Lock then + Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : not null access Lock) is + Result : int; + begin + Result := semGive (L.Mutex); + pragma Assert (Result = 0); + end Unlock; + + procedure Unlock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : int; + begin + if not Single_Lock or else Global_Lock then + Result := semGive (L.Mutex); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock (T : Task_Id) is + Result : int; + begin + if not Single_Lock then + Result := semGive (T.Common.LL.L.Mutex); + pragma Assert (Result = 0); + end if; + end Unlock; + + ----------------- + -- Set_Ceiling -- + ----------------- + + -- Dynamic priority ceilings are not supported by the underlying system + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + pragma Unreferenced (L, Prio); + begin + null; + end Set_Ceiling; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep (Self_ID : Task_Id; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + + Result : int; + + begin + pragma Assert (Self_ID = Self); + + -- Release the mutex before sleeping + + Result := + semGive (if Single_Lock + then Single_RTS_Lock.Mutex + else Self_ID.Common.LL.L.Mutex); + pragma Assert (Result = 0); + + -- Perform a blocking operation to take the CV semaphore. Note that a + -- blocking operation in VxWorks will reenable task scheduling. When we + -- are no longer blocked and control is returned, task scheduling will + -- again be disabled. + + Result := semTake (Self_ID.Common.LL.CV, WAIT_FOREVER); + pragma Assert (Result = 0); + + -- Take the mutex back + + Result := + semTake ((if Single_Lock + then Single_RTS_Lock.Mutex + else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER); + pragma Assert (Result = 0); + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + -- This is for use within the run-time system, so abort is assumed to be + -- already deferred, and the caller should be holding its own ATCB lock. + + procedure Timed_Sleep + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Unreferenced (Reason); + + Orig : constant Duration := Monotonic_Clock; + Absolute : Duration; + Ticks : int; + Result : int; + Wakeup : Boolean := False; + + begin + Timedout := False; + Yielded := True; + + if Mode = Relative then + Absolute := Orig + Time; + + -- Systematically add one since the first tick will delay *at most* + -- 1 / Rate_Duration seconds, so we need to add one to be on the + -- safe side. + + Ticks := To_Clock_Ticks (Time); + + if Ticks > 0 and then Ticks < int'Last then + Ticks := Ticks + 1; + end if; + + else + Absolute := Time; + Ticks := To_Clock_Ticks (Time - Monotonic_Clock); + end if; + + if Ticks > 0 then + loop + -- Release the mutex before sleeping + + Result := + semGive (if Single_Lock + then Single_RTS_Lock.Mutex + else Self_ID.Common.LL.L.Mutex); + pragma Assert (Result = 0); + + -- Perform a blocking operation to take the CV semaphore. Note + -- that a blocking operation in VxWorks will reenable task + -- scheduling. When we are no longer blocked and control is + -- returned, task scheduling will again be disabled. + + Result := semTake (Self_ID.Common.LL.CV, Ticks); + + if Result = 0 then + + -- Somebody may have called Wakeup for us + + Wakeup := True; + + else + if errno /= S_objLib_OBJ_TIMEOUT then + Wakeup := True; + + else + -- If Ticks = int'last, it was most probably truncated so + -- let's make another round after recomputing Ticks from + -- the absolute time. + + if Ticks /= int'Last then + Timedout := True; + + else + Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock); + + if Ticks < 0 then + Timedout := True; + end if; + end if; + end if; + end if; + + -- Take the mutex back + + Result := + semTake ((if Single_Lock + then Single_RTS_Lock.Mutex + else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER); + pragma Assert (Result = 0); + + exit when Timedout or Wakeup; + end loop; + + else + Timedout := True; + + -- Should never hold a lock while yielding + + if Single_Lock then + Result := semGive (Single_RTS_Lock.Mutex); + taskDelay (0); + Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); + + else + Result := semGive (Self_ID.Common.LL.L.Mutex); + taskDelay (0); + Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); + end if; + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + -- This is for use in implementing delay statements, so we assume the + -- caller is holding no locks. + + procedure Timed_Delay + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes) + is + Orig : constant Duration := Monotonic_Clock; + Absolute : Duration; + Ticks : int; + Timedout : Boolean; + Aborted : Boolean := False; + + Result : int; + pragma Warnings (Off, Result); + + begin + if Mode = Relative then + Absolute := Orig + Time; + Ticks := To_Clock_Ticks (Time); + + if Ticks > 0 and then Ticks < int'Last then + + -- 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; + + else + Absolute := Time; + Ticks := To_Clock_Ticks (Time - Orig); + end if; + + if Ticks > 0 then + + -- Modifying State, locking the TCB + + Result := + semTake ((if Single_Lock + then Single_RTS_Lock.Mutex + else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER); + + pragma Assert (Result = 0); + + Self_ID.Common.State := Delay_Sleep; + Timedout := False; + + loop + Aborted := Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + -- Release the TCB before sleeping + + Result := + semGive (if Single_Lock + then Single_RTS_Lock.Mutex + else Self_ID.Common.LL.L.Mutex); + pragma Assert (Result = 0); + + exit when Aborted; + + Result := semTake (Self_ID.Common.LL.CV, Ticks); + + if Result /= 0 then + + -- If Ticks = int'last, it was most probably truncated + -- so let's make another round after recomputing Ticks + -- from the absolute time. + + if errno = S_objLib_OBJ_TIMEOUT and then Ticks /= int'Last then + Timedout := True; + else + Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock); + + if Ticks < 0 then + Timedout := True; + end if; + end if; + end if; + + -- Take back the lock after having slept, to protect further + -- access to Self_ID. + + Result := + semTake + ((if Single_Lock + then Single_RTS_Lock.Mutex + else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER); + + pragma Assert (Result = 0); + + exit when Timedout; + end loop; + + Self_ID.Common.State := Runnable; + + Result := + semGive + (if Single_Lock + then Single_RTS_Lock.Mutex + else Self_ID.Common.LL.L.Mutex); + + else + taskDelay (0); + end if; + end Timed_Delay; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + TS : aliased timespec; + Result : int; + begin + Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); + pragma Assert (Result = 0); + return To_Duration (TS); + end Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + return 1.0 / Duration (sysClkRateGet); + end RT_Resolution; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + Result : int; + begin + Result := semGive (T.Common.LL.CV); + pragma Assert (Result = 0); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + pragma Unreferenced (Do_Yield); + Result : int; + pragma Unreferenced (Result); + begin + Result := taskDelay (0); + end Yield; + + ------------------ + -- Set_Priority -- + ------------------ + + procedure Set_Priority + (T : Task_Id; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + pragma Unreferenced (Loss_Of_Inheritance); + + Result : int; + + begin + Result := + taskPrioritySet + (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio))); + pragma Assert (Result = 0); + + -- Note: in VxWorks 6.6 (or earlier), the task is placed at the end of + -- the priority queue instead of the head. This is not the behavior + -- required by Annex D (RM D.2.3(5/2)), but we consider it an acceptable + -- variation (RM 1.1.3(6)), given this is the built-in behavior of the + -- operating system. VxWorks versions starting from 6.7 implement the + -- required Annex D semantics. + + -- In older versions we attempted to better approximate the Annex D + -- required behavior, but this simulation was not entirely accurate, + -- and it seems better to live with the standard VxWorks semantics. + + T.Common.Current_Priority := Prio; + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_Id) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_Id) is + procedure Init_Float; + pragma Import (C, Init_Float, "__gnat_init_float"); + -- Properly initializes the FPU for PPC/MIPS systems + + begin + -- Store the user-level task id in the Thread field (to be used + -- internally by the run-time system) and the kernel-level task id in + -- the LWP field (to be used by the debugger). + + Self_ID.Common.LL.Thread := taskIdSelf; + Self_ID.Common.LL.LWP := getpid; + + Specific.Set (Self_ID); + + Init_Float; + + -- Install the signal handlers + + -- This is called for each task since there is no signal inheritance + -- between VxWorks tasks. + + Install_Signal_Handlers; + + -- If stack checking is enabled, set the stack limit for this task + + if Set_Stack_Limit_Hook /= null then + Set_Stack_Limit_Hook.all; + end if; + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_Id is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (taskIdSelf); + end if; + end Register_Foreign_Thread; + + -------------------- + -- Initialize_TCB -- + -------------------- + + procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is + begin + Self_ID.Common.LL.CV := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY); + Self_ID.Common.LL.Thread := 0; + + if Self_ID.Common.LL.CV = 0 then + Succeeded := False; + + else + Succeeded := True; + + if not Single_Lock then + Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); + end if; + end if; + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_Id; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + Adjusted_Stack_Size : size_t; + Result : int := 0; + + use System.Task_Info; + use type System.Multiprocessors.CPU_Range; + + begin + -- Ask for four extra bytes of stack space so that the ATCB pointer can + -- be stored below the stack limit, plus extra space for the frame of + -- Task_Wrapper. This is so the user gets the amount of stack requested + -- exclusive of the needs. + + -- We also have to allocate n more bytes for the task name storage and + -- enough space for the Wind Task Control Block which is around 0x778 + -- bytes. VxWorks also seems to carve out additional space, so use 2048 + -- as a nice round number. We might want to increment to the nearest + -- page size in case we ever support VxVMI. + + -- ??? - we should come back and visit this so we can set the task name + -- to something appropriate. + + Adjusted_Stack_Size := size_t (Stack_Size) + 2048; + + -- Since the initial signal mask of a thread is inherited from the + -- creator, and the Environment task has all its signals masked, we do + -- not need to manipulate caller's signal mask at this point. All tasks + -- in RTS will have All_Tasks_Mask initially. + + -- We now compute the VxWorks task name and options, then spawn ... + + declare + Name : aliased String (1 .. T.Common.Task_Image_Len + 1); + Name_Address : System.Address; + -- Task name we are going to hand down to VxWorks + + function Get_Task_Options return int; + pragma Import (C, Get_Task_Options, "__gnat_get_task_options"); + -- Function that returns the options to be set for the task that we + -- are creating. We fetch the options assigned to the current task, + -- so offering some user level control over the options for a task + -- hierarchy, and force VX_FP_TASK because it is almost always + -- required. + + begin + -- If there is no Ada task name handy, let VxWorks choose one. + -- Otherwise, tell VxWorks what the Ada task name is. + + if T.Common.Task_Image_Len = 0 then + Name_Address := System.Null_Address; + else + Name (1 .. Name'Last - 1) := + T.Common.Task_Image (1 .. T.Common.Task_Image_Len); + Name (Name'Last) := ASCII.NUL; + Name_Address := Name'Address; + end if; + + -- Now spawn the VxWorks task for real + + T.Common.LL.Thread := + taskSpawn + (Name_Address, + To_VxWorks_Priority (int (Priority)), + Get_Task_Options, + Adjusted_Stack_Size, + Wrapper, + To_Address (T)); + end; + + -- Set processor affinity + + if T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then + Result := + taskCpuAffinitySet (T.Common.LL.Thread, int (T.Common.Base_CPU)); + + elsif T.Common.Task_Info /= Unspecified_Task_Info then + Result := + taskCpuAffinitySet (T.Common.LL.Thread, T.Common.Task_Info); + end if; + + if Result = -1 then + taskDelete (T.Common.LL.Thread); + T.Common.LL.Thread := -1; + end if; + + if T.Common.LL.Thread = -1 then + Succeeded := False; + else + Succeeded := True; + Task_Creation_Hook (T.Common.LL.Thread); + Set_Priority (T, Priority); + end if; + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_Id) is + Result : int; + Tmp : Task_Id := T; + Is_Self : constant Boolean := (T = Self); + + procedure Free is new + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + + begin + if not Single_Lock then + Result := semDelete (T.Common.LL.L.Mutex); + pragma Assert (Result = 0); + end if; + + T.Common.LL.Thread := 0; + + Result := semDelete (T.Common.LL.CV); + pragma Assert (Result = 0); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + Free (Tmp); + + if Is_Self then + Specific.Delete; + end if; + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + Specific.Set (null); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_Id) is + Result : int; + begin + Result := + kill + (T.Common.LL.Thread, + Signal (Interrupt_Management.Abort_Task_Interrupt)); + pragma Assert (Result = 0); + end Abort_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (S : in out Suspension_Object) is + begin + -- Initialize internal state (always to False (RM D.10(6))) + + S.State := False; + S.Waiting := False; + + -- Initialize internal mutex + + -- Use simpler binary semaphore instead of VxWorks + -- mutual exclusion semaphore, because we don't need + -- the fancier semantics and their overhead. + + S.L := semBCreate (SEM_Q_FIFO, SEM_FULL); + + -- Initialize internal condition variable + + S.CV := semBCreate (SEM_Q_FIFO, SEM_EMPTY); + end Initialize; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (S : in out Suspension_Object) is + pragma Unmodified (S); + -- S may be modified on other targets, but not on VxWorks + + Result : STATUS; + + begin + -- Destroy internal mutex + + Result := semDelete (S.L); + pragma Assert (Result = OK); + + -- Destroy internal condition variable + + Result := semDelete (S.CV); + pragma Assert (Result = OK); + end Finalize; + + ------------------- + -- Current_State -- + ------------------- + + function Current_State (S : Suspension_Object) return Boolean is + begin + -- We do not want to use lock on this read operation. State is marked + -- as Atomic so that we ensure that the value retrieved is correct. + + return S.State; + end Current_State; + + --------------- + -- Set_False -- + --------------- + + procedure Set_False (S : in out Suspension_Object) is + Result : STATUS; + + begin + SSL.Abort_Defer.all; + + Result := semTake (S.L, WAIT_FOREVER); + pragma Assert (Result = OK); + + S.State := False; + + Result := semGive (S.L); + pragma Assert (Result = OK); + + SSL.Abort_Undefer.all; + end Set_False; + + -------------- + -- Set_True -- + -------------- + + procedure Set_True (S : in out Suspension_Object) is + Result : STATUS; + + begin + -- Set_True can be called from an interrupt context, in which case + -- Abort_Defer is undefined. + + if Is_Task_Context then + SSL.Abort_Defer.all; + end if; + + Result := semTake (S.L, WAIT_FOREVER); + pragma Assert (Result = OK); + + -- If there is already a task waiting on this suspension object then + -- we resume it, leaving the state of the suspension object to False, + -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves + -- the state to True. + + if S.Waiting then + S.Waiting := False; + S.State := False; + + Result := semGive (S.CV); + pragma Assert (Result = OK); + else + S.State := True; + end if; + + Result := semGive (S.L); + pragma Assert (Result = OK); + + -- Set_True can be called from an interrupt context, in which case + -- Abort_Undefer is undefined. + + if Is_Task_Context then + SSL.Abort_Undefer.all; + end if; + + end Set_True; + + ------------------------ + -- Suspend_Until_True -- + ------------------------ + + procedure Suspend_Until_True (S : in out Suspension_Object) is + Result : STATUS; + + begin + SSL.Abort_Defer.all; + + Result := semTake (S.L, WAIT_FOREVER); + + if S.Waiting then + + -- Program_Error must be raised upon calling Suspend_Until_True + -- if another task is already waiting on that suspension object + -- (ARM D.10 par. 10). + + Result := semGive (S.L); + pragma Assert (Result = OK); + + SSL.Abort_Undefer.all; + + raise Program_Error; + + else + -- Suspend the task if the state is False. Otherwise, the task + -- continues its execution, and the state of the suspension object + -- is set to False (ARM D.10 par. 9). + + if S.State then + S.State := False; + + Result := semGive (S.L); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + + else + S.Waiting := True; + + -- Release the mutex before sleeping + + Result := semGive (S.L); + pragma Assert (Result = OK); + + SSL.Abort_Undefer.all; + + Result := semTake (S.CV, WAIT_FOREVER); + pragma Assert (Result = 0); + end if; + end if; + end Suspend_Until_True; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy version + + function Check_Exit (Self_ID : ST.Task_Id) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_Id is + begin + return Environment_Task_Id; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + begin + if T.Common.LL.Thread /= 0 + and then T.Common.LL.Thread /= Thread_Self + then + return taskSuspend (T.Common.LL.Thread) = 0; + else + return True; + end if; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + begin + if T.Common.LL.Thread /= 0 + and then T.Common.LL.Thread /= Thread_Self + then + return taskResume (T.Common.LL.Thread) = 0; + else + return True; + end if; + end Resume_Task; + + -------------------- + -- Stop_All_Tasks -- + -------------------- + + procedure Stop_All_Tasks + is + Thread_Self : constant Thread_Id := taskIdSelf; + C : Task_Id; + + Dummy : int; + pragma Unreferenced (Dummy); + + begin + Dummy := Int_Lock; + + C := All_Tasks_List; + while C /= null loop + if C.Common.LL.Thread /= 0 + and then C.Common.LL.Thread /= Thread_Self + then + Dummy := Task_Stop (C.Common.LL.Thread); + end if; + + C := C.Common.All_Tasks_Link; + end loop; + + Dummy := Int_Unlock; + end Stop_All_Tasks; + + --------------- + -- Stop_Task -- + --------------- + + function Stop_Task (T : ST.Task_Id) return Boolean is + begin + if T.Common.LL.Thread /= 0 then + return Task_Stop (T.Common.LL.Thread) = 0; + else + return True; + end if; + end Stop_Task; + + ------------------- + -- Continue_Task -- + ------------------- + + function Continue_Task (T : ST.Task_Id) return Boolean + is + begin + if T.Common.LL.Thread /= 0 then + return Task_Cont (T.Common.LL.Thread) = 0; + else + return True; + end if; + end Continue_Task; + + --------------------- + -- Is_Task_Context -- + --------------------- + + function Is_Task_Context return Boolean is + begin + return System.OS_Interface.Interrupt_Context /= 1; + end Is_Task_Context; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_Id) is + Result : int; + + use type System.Multiprocessors.CPU_Range; + + begin + Environment_Task_Id := Environment_Task; + + Interrupt_Management.Initialize; + Specific.Initialize; + + if Locking_Policy = 'C' then + Mutex_Protocol := Prio_Protect; + elsif Locking_Policy = 'I' then + Mutex_Protocol := Prio_Inherit; + else + Mutex_Protocol := Prio_None; + end if; + + if Time_Slice_Val > 0 then + Result := + Set_Time_Slice + (To_Clock_Ticks + (Duration (Time_Slice_Val) / Duration (1_000_000.0))); + + elsif Dispatching_Policy = 'R' then + Result := Set_Time_Slice (To_Clock_Ticks (0.01)); + + end if; + + Result := sigemptyset (Unblocked_Signal_Mask'Access); + pragma Assert (Result = 0); + + for J in Interrupt_Management.Signal_ID loop + if System.Interrupt_Management.Keep_Unmasked (J) then + Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); + pragma Assert (Result = 0); + end if; + end loop; + + -- Initialize the lock used to synchronize chain of all ATCBs + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + -- Make environment task known here because it doesn't go through + -- Activate_Tasks, which does it for all other tasks. + + Known_Tasks (Known_Tasks'First) := Environment_Task; + Environment_Task.Known_Tasks_Index := Known_Tasks'First; + + Enter_Task (Environment_Task); + + -- Set processor affinity + + if Environment_Task.Common.Base_CPU /= + System.Multiprocessors.Not_A_Specific_CPU + then + Result := + taskCpuAffinitySet + (Environment_Task.Common.LL.Thread, + int (Environment_Task.Common.Base_CPU)); + pragma Assert (Result /= -1); + end if; + end Initialize; + +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop.ads b/gcc/ada/s-taprop.ads new file mode 100644 index 000000000..5c571d41b --- /dev/null +++ b/gcc/ada/s-taprop.ads @@ -0,0 +1,546 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S .O P E R A T I O N S -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains all the GNULL primitives that interface directly with +-- the underlying OS. + +with System.Parameters; +with System.Tasking; +with System.OS_Interface; + +package System.Task_Primitives.Operations is + pragma Preelaborate; + + package ST renames System.Tasking; + package OSI renames System.OS_Interface; + + procedure Initialize (Environment_Task : ST.Task_Id); + -- Perform initialization and set up of the environment task for proper + -- operation of the tasking run-time. This must be called once, before any + -- other subprograms of this package are called. + + procedure Create_Task + (T : ST.Task_Id; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean); + pragma Inline (Create_Task); + -- Create a new low-level task with ST.Task_Id T and place other needed + -- information in the ATCB. + -- + -- A new thread of control is created, with a stack of at least Stack_Size + -- storage units, and the procedure Wrapper is called by this new thread + -- of control. If Stack_Size = Unspecified_Storage_Size, choose a default + -- stack size; this may be effectively "unbounded" on some systems. + -- + -- The newly created low-level task is associated with the ST.Task_Id T + -- such that any subsequent call to Self from within the context of the + -- low-level task returns T. + -- + -- The caller is responsible for ensuring that the storage of the Ada + -- task control block object pointed to by T persists for the lifetime + -- of the new task. + -- + -- Succeeded is set to true unless creation of the task failed, + -- as it may if there are insufficient resources to create another task. + + procedure Enter_Task (Self_ID : ST.Task_Id); + pragma Inline (Enter_Task); + -- Initialize data structures specific to the calling task. Self must be + -- the ID of the calling task. It must be called (once) by the task + -- immediately after creation, while abort is still deferred. The effects + -- of other operations defined below are not defined unless the caller has + -- previously called Initialize_Task. + + procedure Exit_Task; + pragma Inline (Exit_Task); + -- Destroy the thread of control. Self must be the ID of the calling task. + -- The effects of further calls to operations defined below on the task + -- are undefined thereafter. + + function New_ATCB (Entry_Num : ST.Task_Entry_Index) return ST.Task_Id; + pragma Inline (New_ATCB); + -- Allocate a new ATCB with the specified number of entries + + procedure Initialize_TCB (Self_ID : ST.Task_Id; Succeeded : out Boolean); + pragma Inline (Initialize_TCB); + -- Initialize all fields of the TCB + + procedure Finalize_TCB (T : ST.Task_Id); + pragma Inline (Finalize_TCB); + -- Finalizes Private_Data of ATCB, and then deallocates it. This is also + -- responsible for recovering any storage or other resources that were + -- allocated by Create_Task (the one in this package). This should only be + -- called from Free_Task. After it is called there should be no further + -- reference to the ATCB that corresponds to T. + + procedure Abort_Task (T : ST.Task_Id); + pragma Inline (Abort_Task); + -- Abort the task specified by T (the target task). This causes the target + -- task to asynchronously raise Abort_Signal if abort is not deferred, or + -- if it is blocked on an interruptible system call. + -- + -- precondition: + -- the calling task is holding T's lock and has abort deferred + -- + -- postcondition: + -- the calling task is holding T's lock and has abort deferred. + + -- ??? modify GNARL to skip wakeup and always call Abort_Task + + function Self return ST.Task_Id; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task + + type Lock_Level is + (PO_Level, + Global_Task_Level, + RTS_Lock_Level, + ATCB_Level); + -- Type used to describe kind of lock for second form of Initialize_Lock + -- call specified below. See locking rules in System.Tasking (spec) for + -- more details. + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : not null access Lock); + procedure Initialize_Lock + (L : not null access RTS_Lock; + Level : Lock_Level); + pragma Inline (Initialize_Lock); + -- Initialize a lock object + -- + -- For Lock, Prio is the ceiling priority associated with the lock. For + -- RTS_Lock, the ceiling is implicitly Priority'Last. + -- + -- If the underlying system does not support priority ceiling + -- locking, the Prio parameter is ignored. + -- + -- The effect of either initialize operation is undefined unless is a lock + -- object that has not been initialized, or which has been finalized since + -- it was last initialized. + -- + -- The effects of the other operations on lock objects are undefined + -- unless the lock object has been initialized and has not since been + -- finalized. + -- + -- Initialization of the per-task lock is implicit in Create_Task + -- + -- These operations raise Storage_Error if a lack of storage is detected + + procedure Finalize_Lock (L : not null access Lock); + procedure Finalize_Lock (L : not null access RTS_Lock); + pragma Inline (Finalize_Lock); + -- Finalize a lock object, freeing any resources allocated by the + -- corresponding Initialize_Lock operation. + + procedure Write_Lock + (L : not null access Lock; + Ceiling_Violation : out Boolean); + procedure Write_Lock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False); + procedure Write_Lock + (T : ST.Task_Id); + pragma Inline (Write_Lock); + -- Lock a lock object for write access. After this operation returns, + -- the calling task holds write permission for the lock object. No other + -- Write_Lock or Read_Lock operation on the same lock object will return + -- until this task executes an Unlock operation on the same object. The + -- effect is undefined if the calling task already holds read or write + -- permission for the lock object L. + -- + -- For the operation on Lock, Ceiling_Violation is set to true iff the + -- operation failed, which will happen if there is a priority ceiling + -- violation. + -- + -- For the operation on RTS_Lock, Global_Lock should be set to True + -- if L is a global lock (Single_RTS_Lock, Global_Task_Lock). + -- + -- For the operation on ST.Task_Id, the lock is the special lock object + -- associated with that task's ATCB. This lock has effective ceiling + -- priority high enough that it is safe to call by a task with any + -- priority in the range System.Priority. It is implicitly initialized + -- by task creation. The effect is undefined if the calling task already + -- holds T's lock, or has interrupt-level priority. Finalization of the + -- per-task lock is implicit in Exit_Task. + + procedure Read_Lock + (L : not null access Lock; + Ceiling_Violation : out Boolean); + pragma Inline (Read_Lock); + -- Lock a lock object for read access. After this operation returns, + -- the calling task has non-exclusive read permission for the logical + -- resources that are protected by the lock. No other Write_Lock operation + -- on the same object will return until this task and any other tasks with + -- read permission for this lock have executed Unlock operation(s) on the + -- lock object. A Read_Lock for a lock object may return immediately while + -- there are tasks holding read permission, provided there are no tasks + -- holding write permission for the object. The effect is undefined if + -- the calling task already holds read or write permission for L. + -- + -- Alternatively: An implementation may treat Read_Lock identically to + -- Write_Lock. This simplifies the implementation, but reduces the level + -- of concurrency that can be achieved. + -- + -- Note that Read_Lock is not defined for RT_Lock and ST.Task_Id. + -- That is because (1) so far Read_Lock has always been implemented + -- the same as Write_Lock, (2) most lock usage inside the RTS involves + -- potential write access, and (3) implementations of priority ceiling + -- locking that make a reader-writer distinction have higher overhead. + + procedure Unlock + (L : not null access Lock); + procedure Unlock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False); + procedure Unlock + (T : ST.Task_Id); + pragma Inline (Unlock); + -- Unlock a locked lock object + -- + -- The effect is undefined unless the calling task holds read or write + -- permission for the lock L, and L is the lock object most recently + -- locked by the calling task for which the calling task still holds + -- read or write permission. (That is, matching pairs of Lock and Unlock + -- operations on each lock object must be properly nested.) + + -- For the operation on RTS_Lock, Global_Lock should be set to True if L + -- is a global lock (Single_RTS_Lock, Global_Task_Lock). + -- + -- Note that Write_Lock for RTS_Lock does not have an out-parameter. + -- RTS_Locks are used in situations where we have not made provision for + -- recovery from ceiling violations. We do not expect them to occur inside + -- the runtime system, because all RTS locks have ceiling Priority'Last. + + -- There is one way there can be a ceiling violation. That is if the + -- runtime system is called from a task that is executing in the + -- Interrupt_Priority range. + + -- It is not clear what to do about ceiling violations due to RTS calls + -- done at interrupt priority. In general, it is not acceptable to give + -- all RTS locks interrupt priority, since that would give terrible + -- performance on systems where this has the effect of masking hardware + -- interrupts, though we could get away allowing Interrupt_Priority'last + -- where we are layered on an OS that does not allow us to mask interrupts. + -- Ideally, we would like to raise Program_Error back at the original point + -- of the RTS call, but this would require a lot of detailed analysis and + -- recoding, with almost certain performance penalties. + + -- For POSIX systems, we considered just skipping setting priority ceiling + -- on RTS locks. This would mean there is no ceiling violation, but we + -- would end up with priority inversions inside the runtime system, + -- resulting in failure to satisfy the Ada priority rules, and possible + -- missed validation tests. This could be compensated-for by explicit + -- priority-change calls to raise the caller to Priority'Last whenever it + -- first enters the runtime system, but the expected overhead seems high, + -- though it might be lower than using locks with ceilings if the + -- underlying implementation of ceiling locks is an inefficient one. + + -- This issue should be reconsidered whenever we get around to checking + -- for calls to potentially blocking operations from within protected + -- operations. If we check for such calls and catch them on entry to the + -- OS, it may be that we can eliminate the possibility of ceiling + -- violations inside the RTS. For this to work, we would have to forbid + -- explicitly setting the priority of a task to anything in the + -- Interrupt_Priority range, at least. We would also have to check that + -- there are no RTS-lock operations done inside any operations that are + -- not treated as potentially blocking. + + -- The latter approach seems to be the best, i.e. to check on entry to RTS + -- calls that may need to use locks that the priority is not in the + -- interrupt range. If there are RTS operations that NEED to be called + -- from interrupt handlers, those few RTS locks should then be converted + -- to PO-type locks, with ceiling Interrupt_Priority'Last. + + -- For now, we will just shut down the system if there is ceiling violation + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority); + pragma Inline (Set_Ceiling); + -- Change the ceiling priority associated to the lock + -- + -- The effect is undefined unless the calling task holds read or write + -- permission for the lock L, and L is the lock object most recently + -- locked by the calling task for which the calling task still holds + -- read or write permission. (That is, matching pairs of Lock and Unlock + -- operations on each lock object must be properly nested.) + + procedure Yield (Do_Yield : Boolean := True); + pragma Inline (Yield); + -- Yield the processor. Add the calling task to the tail of the ready + -- queue for its active_priority. The Do_Yield argument is only used in + -- some very rare cases very a yield should have an effect on a specific + -- target and not on regular ones. + + procedure Set_Priority + (T : ST.Task_Id; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False); + pragma Inline (Set_Priority); + -- Set the priority of the task specified by T to T.Current_Priority. The + -- priority set is what would correspond to the Ada concept of "base + -- priority" in the terms of the lower layer system, but the operation may + -- be used by the upper layer to implement changes in "active priority" + -- that are not due to lock effects. The effect should be consistent with + -- the Ada Reference Manual. In particular, when a task lowers its + -- priority due to the loss of inherited priority, it goes at the head of + -- the queue for its new priority (RM D.2.2 par 9). Loss_Of_Inheritance + -- helps the underlying implementation to do it right when the OS doesn't. + + function Get_Priority (T : ST.Task_Id) return System.Any_Priority; + pragma Inline (Get_Priority); + -- Returns the priority last set by Set_Priority for this task + + function Monotonic_Clock return Duration; + pragma Inline (Monotonic_Clock); + -- Returns "absolute" time, represented as an offset relative to "the + -- Epoch", which is Jan 1, 1970. This clock implementation is immune to + -- the system's clock changes. + + function RT_Resolution return Duration; + pragma Inline (RT_Resolution); + -- Returns resolution of the underlying clock used to implement RT_Clock + + ---------------- + -- Extensions -- + ---------------- + + -- Whoever calls either of the Sleep routines is responsible for checking + -- for pending aborts before the call. Pending priority changes are handled + -- internally. + + procedure Sleep + (Self_ID : ST.Task_Id; + Reason : System.Tasking.Task_States); + pragma Inline (Sleep); + -- Wait until the current task, T, is signaled to wake up + -- + -- precondition: + -- The calling task is holding its own ATCB lock + -- and has abort deferred + -- + -- postcondition: + -- The calling task is holding its own ATCB lock and has abort deferred. + + -- The effect is to atomically unlock T's lock and wait, so that another + -- task that is able to lock T's lock can be assured that the wait has + -- actually commenced, and that a Wakeup operation will cause the waiting + -- task to become ready for execution once again. When Sleep returns, the + -- waiting task will again hold its own ATCB lock. The waiting task may + -- become ready for execution at any time (that is, spurious wakeups are + -- permitted), but it will definitely become ready for execution when a + -- Wakeup operation is performed for the same task. + + procedure Timed_Sleep + (Self_ID : ST.Task_Id; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean); + -- Combination of Sleep (above) and Timed_Delay + + procedure Timed_Delay + (Self_ID : ST.Task_Id; + Time : Duration; + Mode : ST.Delay_Modes); + -- Implement the semantics of the delay statement. + -- The caller should be abort-deferred and should not hold any locks. + + procedure Wakeup + (T : ST.Task_Id; + Reason : System.Tasking.Task_States); + pragma Inline (Wakeup); + -- Wake up task T if it is waiting on a Sleep call (of ordinary + -- or timed variety), making it ready for execution once again. + -- If the task T is not waiting on a Sleep, the operation has no effect. + + function Environment_Task return ST.Task_Id; + pragma Inline (Environment_Task); + -- Return the task ID of the environment task + -- Consider putting this into a variable visible directly + -- by the rest of the runtime system. ??? + + function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id; + -- Return the thread id of the specified task + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does the calling thread have an ATCB? + + function Register_Foreign_Thread return ST.Task_Id; + -- Allocate and initialize a new ATCB for the current thread + + ----------------------- + -- RTS Entrance/Exit -- + ----------------------- + + -- Following two routines are used for possible operations needed to be + -- setup/cleared upon entrance/exit of RTS while maintaining a single + -- thread of control in the RTS. Since we intend these routines to be used + -- for implementing the Single_Lock RTS, Lock_RTS should follow the first + -- Defer_Abort operation entering RTS. In the same fashion Unlock_RTS + -- should precede the last Undefer_Abort exiting RTS. + -- + -- These routines also replace the functions Lock/Unlock_All_Tasks_List + + procedure Lock_RTS; + -- Take the global RTS lock + + procedure Unlock_RTS; + -- Release the global RTS lock + + -------------------- + -- Stack Checking -- + -------------------- + + -- Stack checking in GNAT is done using the concept of stack probes. A + -- stack probe is an operation that will generate a storage error if + -- an insufficient amount of stack space remains in the current task. + + -- The exact mechanism for a stack probe is target dependent. Typical + -- possibilities are to use a load from a non-existent page, a store to a + -- read-only page, or a comparison with some stack limit constant. Where + -- possible we prefer to use a trap on a bad page access, since this has + -- less overhead. The generation of stack probes is either automatic if + -- the ABI requires it (as on for example DEC Unix), or is controlled by + -- the gcc parameter -fstack-check. + + -- When we are using bad-page accesses, we need a bad page, called guard + -- page, at the end of each task stack. On some systems, this is provided + -- automatically, but on other systems, we need to create the guard page + -- ourselves, and the procedure Stack_Guard is provided for this purpose. + + procedure Stack_Guard (T : ST.Task_Id; On : Boolean); + -- Ensure guard page is set if one is needed and the underlying thread + -- system does not provide it. The procedure is as follows: + -- + -- 1. When we create a task adjust its size so a guard page can + -- safely be set at the bottom of the stack. + -- + -- 2. When the thread is created (and its stack allocated by the + -- underlying thread system), get the stack base (and size, depending + -- how the stack is growing), and create the guard page taking care + -- of page boundaries issues. + -- + -- 3. When the task is destroyed, remove the guard page. + -- + -- If On is true then protect the stack bottom (i.e make it read only) + -- else unprotect it (i.e. On is True for the call when creating a task, + -- and False when a task is destroyed). + -- + -- The call to Stack_Guard has no effect if guard pages are not used on + -- the target, or if guard pages are automatically provided by the system. + + ------------------------ + -- Suspension objects -- + ------------------------ + + -- These subprograms provide the functionality required for synchronizing + -- on a suspension object. Tasks can suspend execution and relinquish the + -- processors until the condition is signaled. + + function Current_State (S : Suspension_Object) return Boolean; + -- Return the state of the suspension object + + procedure Set_False (S : in out Suspension_Object); + -- Set the state of the suspension object to False + + procedure Set_True (S : in out Suspension_Object); + -- Set the state of the suspension object to True. If a task were + -- suspended on the protected object then this task is released (and + -- the state of the suspension object remains set to False). + + procedure Suspend_Until_True (S : in out Suspension_Object); + -- If the state of the suspension object is True then the calling task + -- continues its execution, and the state is set to False. If the state + -- of the object is False then the task is suspended on the suspension + -- object until a Set_True operation is executed. Program_Error is raised + -- if another task is already waiting on that suspension object. + + procedure Initialize (S : in out Suspension_Object); + -- Initialize the suspension object + + procedure Finalize (S : in out Suspension_Object); + -- Finalize the suspension object + + ----------------------------------------- + -- Runtime System Debugging Interfaces -- + ----------------------------------------- + + -- These interfaces have been added to assist in debugging the + -- tasking runtime system. + + function Check_Exit (Self_ID : ST.Task_Id) return Boolean; + pragma Inline (Check_Exit); + -- Check that the current task is holding only Global_Task_Lock + + function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean; + pragma Inline (Check_No_Locks); + -- Check that current task is holding no locks + + function Suspend_Task + (T : ST.Task_Id; + Thread_Self : OSI.Thread_Id) return Boolean; + -- Suspend a specific task when the underlying thread library provides this + -- functionality, unless the thread associated with T is Thread_Self. Such + -- functionality is needed by gdb on some targets (e.g VxWorks) Return True + -- is the operation is successful. On targets where this operation is not + -- available, a dummy body is present which always returns False. + + function Resume_Task + (T : ST.Task_Id; + Thread_Self : OSI.Thread_Id) return Boolean; + -- Resume a specific task when the underlying thread library provides + -- such functionality, unless the thread associated with T is Thread_Self. + -- Such functionality is needed by gdb on some targets (e.g VxWorks) + -- Return True is the operation is successful + + procedure Stop_All_Tasks; + -- Stop all tasks when the underlying thread library provides such + -- functionality. Such functionality is needed by gdb on some targets (e.g + -- VxWorks) This function can be run from an interrupt handler. Return True + -- is the operation is successful + + function Stop_Task (T : ST.Task_Id) return Boolean; + -- Stop a specific task when the underlying thread library provides + -- such functionality. Such functionality is needed by gdb on some targets + -- (e.g VxWorks). Return True is the operation is successful. + + function Continue_Task (T : ST.Task_Id) return Boolean; + -- Continue a specific task when the underlying thread library provides + -- such functionality. Such functionality is needed by gdb on some targets + -- (e.g VxWorks) Return True is the operation is successful + +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-tarest.adb b/gcc/ada/s-tarest.adb new file mode 100644 index 000000000..5c8341243 --- /dev/null +++ b/gcc/ada/s-tarest.adb @@ -0,0 +1,643 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . R E S T R I C T E D . S T A G E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2010, 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 Style_Checks (All_Checks); +-- Turn off subprogram alpha order check, since we group soft link +-- bodies and also separate off subprograms for restricted GNARLI. + +-- This is a simplified version of the System.Tasking.Stages package, +-- intended to be used in a restricted run time. + +-- This package represents the high level tasking interface used by the +-- compiler to expand Ada 95 tasking constructs into simpler run time calls. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with Ada.Exceptions; + +with System.Task_Primitives.Operations; +with System.Soft_Links.Tasking; +with System.Secondary_Stack; +with System.Storage_Elements; + +with System.Soft_Links; +-- Used for the non-tasking routines (*_NT) that refer to global data. They +-- are needed here before the tasking run time has been elaborated. used for +-- Create_TSD This package also provides initialization routines for task +-- specific data. The GNARL must call these to be sure that all non-tasking +-- Ada constructs will work. + +package body System.Tasking.Restricted.Stages is + + package STPO renames System.Task_Primitives.Operations; + package SSL renames System.Soft_Links; + package SSE renames System.Storage_Elements; + package SST renames System.Secondary_Stack; + + use Ada.Exceptions; + + use Parameters; + use Task_Primitives.Operations; + use Task_Info; + + Global_Task_Lock : aliased System.Task_Primitives.RTS_Lock; + -- This is a global lock; it is used to execute in mutual exclusion + -- from all other tasks. It is only used by Task_Lock and Task_Unlock. + + ----------------------------------------------------------------- + -- Tasking versions of services needed by non-tasking programs -- + ----------------------------------------------------------------- + + function Get_Current_Excep return SSL.EOA; + -- Task-safe version of SSL.Get_Current_Excep + + procedure Task_Lock; + -- 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. + + procedure Task_Unlock; + -- Releases lock previously set by call to Task_Lock. In the nested case, + -- all nested locks must be released before other tasks competing for the + -- tasking lock are released. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Task_Wrapper (Self_ID : Task_Id); + -- This is the procedure that is called by the GNULL from the + -- new context when a task is created. It waits for activation + -- and then calls the task body procedure. When the task body + -- procedure completes, it terminates the task. + + procedure Terminate_Task (Self_ID : Task_Id); + -- Terminate the calling task. + -- This should only be called by the Task_Wrapper procedure. + + procedure Init_RTS; + -- This procedure performs the initialization of the GNARL. + -- It consists of initializing the environment task, global locks, and + -- installing tasking versions of certain operations used by the compiler. + -- Init_RTS is called during elaboration. + + ----------------------- + -- Get_Current_Excep -- + ----------------------- + + function Get_Current_Excep return SSL.EOA is + begin + return STPO.Self.Common.Compiler_Data.Current_Excep'Access; + end Get_Current_Excep; + + --------------- + -- Task_Lock -- + --------------- + + procedure Task_Lock is + Self_ID : constant Task_Id := STPO.Self; + + begin + Self_ID.Common.Global_Task_Lock_Nesting := + Self_ID.Common.Global_Task_Lock_Nesting + 1; + + if Self_ID.Common.Global_Task_Lock_Nesting = 1 then + STPO.Write_Lock (Global_Task_Lock'Access, Global_Lock => True); + end if; + end Task_Lock; + + ----------------- + -- Task_Unlock -- + ----------------- + + procedure Task_Unlock is + Self_ID : constant Task_Id := STPO.Self; + + begin + pragma Assert (Self_ID.Common.Global_Task_Lock_Nesting > 0); + Self_ID.Common.Global_Task_Lock_Nesting := + Self_ID.Common.Global_Task_Lock_Nesting - 1; + + if Self_ID.Common.Global_Task_Lock_Nesting = 0 then + STPO.Unlock (Global_Task_Lock'Access, Global_Lock => True); + end if; + end Task_Unlock; + + ------------------ + -- Task_Wrapper -- + ------------------ + + -- The task wrapper is a procedure that is called first for each task + -- task body, and which in turn calls the compiler-generated task body + -- procedure. The wrapper's main job is to do initialization for the task. + + -- The variable ID in the task wrapper is used to implement the Self + -- function on targets where there is a fast way to find the stack base + -- of the current thread, since it should be at a fixed offset from the + -- stack base. + + procedure Task_Wrapper (Self_ID : Task_Id) is + ID : Task_Id := Self_ID; + pragma Volatile (ID); + pragma Warnings (Off, ID); + -- Variable used on some targets to implement a fast self. We turn off + -- warnings because a stand alone volatile constant has to be imported, + -- so we don't want warnings about ID not being referenced, and volatile + -- having no effect. + -- + -- DO NOT delete ID. As noted, it is needed on some targets. + + use type SSE.Storage_Offset; + + Secondary_Stack : aliased SSE.Storage_Array + (1 .. Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size * + SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100); + + pragma Warnings (Off); + Secondary_Stack_Address : System.Address := Secondary_Stack'Address; + pragma Warnings (On); + -- Address of secondary stack. In the fixed secondary stack case, this + -- value is not modified, causing a warning, hence the bracketing with + -- Warnings (Off/On). + + Cause : Cause_Of_Termination := Normal; + -- Indicates the reason why this task terminates. Normal corresponds to + -- a task terminating due to completing the last statement of its body. + -- If the task terminates because of an exception raised by the + -- execution of its task body, then Cause is set to Unhandled_Exception. + -- Aborts are not allowed in the restricted profile to which this file + -- belongs. + + EO : Exception_Occurrence; + -- If the task terminates because of an exception raised by the + -- execution of its task body, then EO will contain the associated + -- exception occurrence. Otherwise, it will contain Null_Occurrence. + + begin + if not Parameters.Sec_Stack_Dynamic then + Self_ID.Common.Compiler_Data.Sec_Stack_Addr := + Secondary_Stack'Address; + SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last)); + end if; + + -- Initialize low-level TCB components, that + -- cannot be initialized by the creator. + + Enter_Task (Self_ID); + + -- Call the task body procedure + + begin + -- We are separating the following portion of the code in order to + -- place the exception handlers in a different block. In this way we + -- do not call Set_Jmpbuf_Address (which needs Self) before we set + -- Self in Enter_Task. + + -- Note that in the case of Ravenscar HI-E where there are no + -- exception handlers, the exception handler is suppressed. + + -- Call the task body procedure + + Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg); + + -- Normal task termination + + Cause := Normal; + Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence); + + exception + when E : others => + + -- Task terminating because of an unhandled exception + + Cause := Unhandled_Exception; + Save_Occurrence (EO, E); + end; + + -- Look for a fall-back handler. It can be either in the task itself + -- or in the environment task. Note that this code is always executed + -- by a task whose master is the environment task. The task termination + -- code for the environment task is executed by + -- SSL.Task_Termination_Handler. + + -- This package is part of the restricted run time which supports + -- neither task hierarchies (No_Task_Hierarchy) nor specific task + -- termination handlers (No_Specific_Termination_Handlers). + + -- There is no need for explicit protection against race conditions + -- for Self_ID.Common.Fall_Back_Handler because this procedure can + -- only be executed by Self, and the Fall_Back_Handler can only be + -- modified by Self. + + if Self_ID.Common.Fall_Back_Handler /= null then + Self_ID.Common.Fall_Back_Handler (Cause, Self_ID, EO); + else + declare + TH : Termination_Handler := null; + + begin + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID.Common.Parent); + + TH := Self_ID.Common.Parent.Common.Fall_Back_Handler; + + Unlock (Self_ID.Common.Parent); + + if Single_Lock then + Unlock_RTS; + end if; + + -- Execute the task termination handler if we found it + + if TH /= null then + TH.all (Cause, Self_ID, EO); + end if; + end; + end if; + + Terminate_Task (Self_ID); + end Task_Wrapper; + + ----------------------- + -- Restricted GNARLI -- + ----------------------- + + ------------------------------- + -- Activate_Restricted_Tasks -- + ------------------------------- + + -- Note that locks of activator and activated task are both locked here. + -- This is necessary because C.State and Self.Wait_Count have to be + -- synchronized. This is safe from deadlock because the activator is always + -- created before the activated task. That satisfies our + -- in-order-of-creation ATCB locking policy. + + procedure Activate_Restricted_Tasks + (Chain_Access : Activation_Chain_Access) + is + Self_ID : constant Task_Id := STPO.Self; + C : Task_Id; + Activate_Prio : System.Any_Priority; + Success : Boolean; + + begin + pragma Assert (Self_ID = Environment_Task); + pragma Assert (Self_ID.Common.Wait_Count = 0); + + if Single_Lock then + Lock_RTS; + end if; + + -- Lock self, to prevent activated tasks from racing ahead before we + -- finish activating the chain. + + Write_Lock (Self_ID); + + -- Activate all the tasks in the chain. Creation of the thread of + -- control was deferred until activation. So create it now. + + C := Chain_Access.T_ID; + + while C /= null loop + if C.Common.State /= Terminated then + pragma Assert (C.Common.State = Unactivated); + + Write_Lock (C); + + Activate_Prio := + (if C.Common.Base_Priority < Get_Priority (Self_ID) + then Get_Priority (Self_ID) + else C.Common.Base_Priority); + + STPO.Create_Task + (C, Task_Wrapper'Address, + Parameters.Size_Type + (C.Common.Compiler_Data.Pri_Stack_Info.Size), + Activate_Prio, Success); + + Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; + + if Success then + C.Common.State := Runnable; + else + raise Program_Error; + end if; + + Unlock (C); + end if; + + C := C.Common.Activation_Link; + end loop; + + Self_ID.Common.State := Activator_Sleep; + + -- Wait for the activated tasks to complete activation. It is unsafe to + -- abort any of these tasks until the count goes to zero. + + loop + exit when Self_ID.Common.Wait_Count = 0; + Sleep (Self_ID, Activator_Sleep); + end loop; + + Self_ID.Common.State := Runnable; + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + -- Remove the tasks from the chain + + Chain_Access.T_ID := null; + end Activate_Restricted_Tasks; + + ------------------------------------ + -- Complete_Restricted_Activation -- + ------------------------------------ + + -- As in several other places, the locks of the activator and activated + -- task are both locked here. This follows our deadlock prevention lock + -- ordering policy, since the activated task must be created after the + -- activator. + + procedure Complete_Restricted_Activation is + Self_ID : constant Task_Id := STPO.Self; + Activator : constant Task_Id := Self_ID.Common.Activator; + + begin + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Activator); + Write_Lock (Self_ID); + + -- Remove dangling reference to Activator, since a task may outlive its + -- activator. + + Self_ID.Common.Activator := null; + + -- Wake up the activator, if it is waiting for a chain of tasks to + -- activate, and we are the last in the chain to complete activation + + if Activator.Common.State = Activator_Sleep then + Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1; + + if Activator.Common.Wait_Count = 0 then + Wakeup (Activator, Activator_Sleep); + end if; + end if; + + Unlock (Self_ID); + Unlock (Activator); + + if Single_Lock then + Unlock_RTS; + end if; + + -- After the activation, active priority should be the same as base + -- priority. We must unlock the Activator first, though, since it should + -- not wait if we have lower priority. + + if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then + Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + end if; + end Complete_Restricted_Activation; + + ------------------------------ + -- Complete_Restricted_Task -- + ------------------------------ + + procedure Complete_Restricted_Task is + begin + STPO.Self.Common.State := Terminated; + end Complete_Restricted_Task; + + ---------------------------- + -- Create_Restricted_Task -- + ---------------------------- + + procedure Create_Restricted_Task + (Priority : Integer; + Stack_Address : System.Address; + Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Chain : in out Activation_Chain; + Task_Image : String; + Created_Task : Task_Id) + is + Self_ID : constant Task_Id := STPO.Self; + Base_Priority : System.Any_Priority; + Base_CPU : System.Multiprocessors.CPU_Range; + Success : Boolean; + Len : Integer; + + begin + -- Stack is not preallocated on this target, so that Stack_Address must + -- be null. + + pragma Assert (Stack_Address = Null_Address); + + Base_Priority := + (if Priority = Unspecified_Priority + then Self_ID.Common.Base_Priority + else System.Any_Priority (Priority)); + + if CPU /= Unspecified_CPU + and then (CPU < Integer (System.Multiprocessors.CPU_Range'First) + or else CPU > Integer (System.Multiprocessors.CPU_Range'Last) + or else CPU > Integer (System.Multiprocessors.Number_Of_CPUs)) + then + raise Tasking_Error with "CPU not in range"; + + -- Normal CPU affinity + else + Base_CPU := + (if CPU = Unspecified_CPU + then Self_ID.Common.Base_CPU + else System.Multiprocessors.CPU_Range (CPU)); + end if; + + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + -- With no task hierarchy, the parent of all non-Environment tasks that + -- are created must be the Environment task + + Initialize_ATCB + (Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority, + Base_CPU, Task_Info, Size, Created_Task, Success); + + -- If we do our job right then there should never be any failures, which + -- was probably said about the Titanic; so just to be safe, let's retain + -- this code for now + + if not Success then + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + raise Program_Error; + end if; + + Created_Task.Entry_Calls (1).Self := Created_Task; + + Len := + Integer'Min (Created_Task.Common.Task_Image'Length, Task_Image'Length); + Created_Task.Common.Task_Image_Len := Len; + Created_Task.Common.Task_Image (1 .. Len) := + Task_Image (Task_Image'First .. Task_Image'First + Len - 1); + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + -- Create TSD as early as possible in the creation of a task, since it + -- may be used by the operation of Ada code within the task. + + SSL.Create_TSD (Created_Task.Common.Compiler_Data); + Created_Task.Common.Activation_Link := Chain.T_ID; + Chain.T_ID := Created_Task; + end Create_Restricted_Task; + + --------------------------- + -- Finalize_Global_Tasks -- + --------------------------- + + -- This is needed to support the compiler interface; it will only be called + -- by the Environment task. Instead, it will cause the Environment to block + -- forever, since none of the dependent tasks are expected to terminate + + procedure Finalize_Global_Tasks is + Self_ID : constant Task_Id := STPO.Self; + + begin + pragma Assert (Self_ID = STPO.Environment_Task); + + if Single_Lock then + Lock_RTS; + end if; + + -- 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. + + -- Note that in the "normal" implementation in s-tassta.adb the task + -- termination procedure for the environment task should be executed + -- after termination of library-level tasks. However, this + -- implementation is to be used when the Ravenscar restrictions are in + -- effect, and AI-394 says that if there is a fall-back handler set for + -- the partition it should be called when the first task (including the + -- environment task) attempts to terminate. + + SSL.Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence); + + Write_Lock (Self_ID); + Sleep (Self_ID, Master_Completion_Sleep); + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + -- Should never return from Master Completion Sleep + + raise Program_Error; + end Finalize_Global_Tasks; + + --------------------------- + -- Restricted_Terminated -- + --------------------------- + + function Restricted_Terminated (T : Task_Id) return Boolean is + begin + return T.Common.State = Terminated; + end Restricted_Terminated; + + -------------------- + -- Terminate_Task -- + -------------------- + + procedure Terminate_Task (Self_ID : Task_Id) is + begin + Self_ID.Common.State := Terminated; + end Terminate_Task; + + -------------- + -- Init_RTS -- + -------------- + + procedure Init_RTS is + begin + Tasking.Initialize; + + -- Initialize lock used to implement mutual exclusion between all tasks + + STPO.Initialize_Lock (Global_Task_Lock'Access, STPO.Global_Task_Level); + + -- Notify that the tasking run time has been elaborated so that + -- the tasking version of the soft links can be used. + + SSL.Lock_Task := Task_Lock'Access; + SSL.Unlock_Task := Task_Unlock'Access; + SSL.Adafinal := Finalize_Global_Tasks'Access; + SSL.Get_Current_Excep := Get_Current_Excep'Access; + + -- Initialize the tasking soft links (if not done yet) that are common + -- to the full and the restricted run times. + + SSL.Tasking.Init_Tasking_Soft_Links; + end Init_RTS; + +begin + Init_RTS; +end System.Tasking.Restricted.Stages; diff --git a/gcc/ada/s-tarest.ads b/gcc/ada/s-tarest.ads new file mode 100644 index 000000000..7b853914b --- /dev/null +++ b/gcc/ada/s-tarest.ads @@ -0,0 +1,225 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . R E S T R I C T E D . S T A G E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2010, 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 a simplified version of the System.Tasking.Stages package, +-- intended to be used in a restricted run time. + +-- This package represents the high level tasking interface used by the +-- compiler to expand Ada 95 tasking constructs into simpler run time calls +-- (aka GNARLI, GNU Ada Run-time Library Interface) + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes +-- in exp_ch9.adb and possibly exp_ch7.adb + +-- The restricted GNARLI is also composed of System.Protected_Objects and +-- System.Protected_Objects.Single_Entry + +with System.Task_Info; +with System.Parameters; + +package System.Tasking.Restricted.Stages is + pragma Elaborate_Body; + + --------------------------------- + -- Compiler Interface (GNARLI) -- + --------------------------------- + + -- The compiler will expand in the GNAT tree the following construct: + + -- task type T (Discr : Integer); + + -- task body T is + -- ...declarations, possibly some controlled... + -- begin + -- ...B...; + -- end T; + + -- T1 : T (1); + + -- as follows: + + -- task type t (discr : integer); + -- tE : aliased boolean := false; + -- tZ : size_type := unspecified_size; + + -- type tV (discr : integer) is limited record + -- _task_id : task_id; + -- _atcb : aliased system__tasking__ada_task_control_block (0); + -- end record; + + -- procedure tB (_task : access tV); + -- freeze tV [ + -- procedure tVIP (_init : in out tV; _master : master_id; + -- _chain : in out activation_chain; _task_name : in string; + -- discr : integer) is + -- begin + -- _init.discr := discr; + -- _init._task_id := null; + -- system__tasking__ada_task_control_blockIP (_init._atcb, 0); + -- _init._task_id := _init._atcb'unchecked_access; + -- create_restricted_task (unspecified_priority, tZ, + -- unspecified_task_info, unspecified_cpu, + -- task_procedure_access!(tB'address), _init'address, + -- tE'unchecked_access, _chain, _task_name, _init._task_id); + -- return; + -- end tVIP; + + -- _chain : aliased activation_chain; + -- activation_chainIP (_chain); + + -- procedure tB (_task : access tV) is + -- discr : integer renames _task.discr; + + -- procedure _clean is + -- begin + -- complete_restricted_task; + -- finalize_list (F14b); + -- return; + -- end _clean; + + -- begin + -- ...declarations... + -- complete_restricted_activation; + -- ...B...; + -- return; + -- at end + -- _clean; + -- end tB; + + -- tE := true; + -- t1 : t (1); + -- t1S : constant String := "t1"; + -- tIP (t1, 3, _chain, t1S, 1); + + -- activate_restricted_tasks (_chain'unchecked_access); + + procedure Create_Restricted_Task + (Priority : Integer; + Stack_Address : System.Address; + Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Chain : in out Activation_Chain; + Task_Image : String; + Created_Task : Task_Id); + -- Compiler interface only. Do not call from within the RTS. + -- This must be called to create a new task. + -- + -- Priority is the task's priority (assumed to be in the + -- System.Any_Priority'Range) + -- + -- Stack_Address is the start address of the stack associated to the task, + -- in case it has been preallocated by the compiler; it is equal to + -- Null_Address when the stack needs to be allocated by the underlying + -- operating system. + -- + -- Size is the stack size of the task to create + -- + -- Task_Info is the task info associated with the created task, or + -- Unspecified_Task_Info if none. + -- + -- CPU is the task affinity. We pass it as an Integer to avoid an explicit + -- dependency from System.Multiprocessors when not needed. Static range + -- checks are performed when analyzing the pragma, and dynamic ones are + -- performed before setting the affinity at run time. + -- + -- State is the compiler generated task's procedure body + -- + -- Discriminants is a pointer to a limited record whose discriminants are + -- those of the task to create. This parameter should be passed as the + -- single argument to State. + -- + -- Elaborated is a pointer to a Boolean that must be set to true on exit + -- if the task could be successfully elaborated. + -- + -- Chain is a linked list of task that needs to be created. On exit, + -- Created_Task.Activation_Link will be Chain.T_ID, and Chain.T_ID will be + -- Created_Task (the created task will be linked at the front of Chain). + -- + -- Task_Image is a string created by the compiler that the run time can + -- store to ease the debugging and the Ada.Task_Identification facility. + -- + -- Created_Task is the resulting task. + -- + -- This procedure can raise Storage_Error if the task creation fails + + procedure Activate_Restricted_Tasks + (Chain_Access : Activation_Chain_Access); + -- Compiler interface only. Do not call from within the RTS. + -- This must be called by the creator of a chain of one or more new tasks, + -- to activate them. The chain is a linked list that up to this point is + -- only known to the task that created them, though the individual tasks + -- are already in the All_Tasks_List. + -- + -- The compiler builds the chain in LIFO order (as a stack). Another + -- version of this procedure had code to reverse the chain, so as to + -- activate the tasks in the order of declaration. This might be nice, but + -- it is not needed if priority-based scheduling is supported, since all + -- the activated tasks synchronize on the activators lock before they start + -- activating and so they should start activating in priority order. + + procedure Complete_Restricted_Activation; + -- Compiler interface only. Do not call from within the RTS. This should be + -- called from the task body at the end of the elaboration code for its + -- declarative part. Decrement the count of tasks to be activated by the + -- activator and wake it up so it can check to see if all tasks have been + -- activated. Except for the environment task, which should never call this + -- procedure, T.Activator should only be null iff T has completed + -- activation. + + procedure Complete_Restricted_Task; + -- Compiler interface only. Do not call from within the RTS. This should be + -- called from an implicit at-end handler associated with the task body, + -- when it completes. From this point, the current task will become not + -- callable. If the current task have not completed activation, this should + -- be done now in order to wake up the activator (the environment task). + + function Restricted_Terminated (T : Task_Id) return Boolean; + -- Compiler interface only. Do not call from within the RTS. This is called + -- by the compiler to implement the 'Terminated attribute. + -- + -- source code: + -- T1'Terminated + -- + -- code expansion: + -- restricted_terminated (t1._task_id) + + procedure Finalize_Global_Tasks; + -- This is needed to support the compiler interface; it will only be called + -- by the Environment task in the binder generated file (by adafinal). + -- Instead, it will cause the Environment to block forever, since none of + -- the dependent tasks are expected to terminate + +end System.Tasking.Restricted.Stages; diff --git a/gcc/ada/s-tasdeb.adb b/gcc/ada/s-tasdeb.adb new file mode 100644 index 000000000..ccc81d9d5 --- /dev/null +++ b/gcc/ada/s-tasdeb.adb @@ -0,0 +1,373 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . D E B U G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-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 encapsulates all direct interfaces to task debugging services +-- that are needed by gdb with gnat mode. + +-- Note : This file *must* be compiled with debugging information + +-- Do not add any dependency to GNARL packages since this package is used +-- in both normal and restricted (ravenscar) environments. + +with System.CRTL; +with System.Task_Primitives; +with System.Task_Primitives.Operations; +with Ada.Unchecked_Conversion; + +package body System.Tasking.Debug is + + package STPO renames System.Task_Primitives.Operations; + + function To_Integer is new + Ada.Unchecked_Conversion (Task_Id, System.Task_Primitives.Task_Address); + + type Trace_Flag_Set is array (Character) of Boolean; + + Trace_On : Trace_Flag_Set := ('A' .. 'Z' => False, others => True); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Write (Fd : Integer; S : String; Count : Integer); + + procedure Put (S : String); + -- Display S on standard output + + procedure Put_Line (S : String := ""); + -- Display S on standard output with an additional line terminator + + ------------------------ + -- Continue_All_Tasks -- + ------------------------ + + procedure Continue_All_Tasks is + C : Task_Id; + + Dummy : Boolean; + pragma Unreferenced (Dummy); + + begin + STPO.Lock_RTS; + + C := All_Tasks_List; + while C /= null loop + Dummy := STPO.Continue_Task (C); + C := C.Common.All_Tasks_Link; + end loop; + + STPO.Unlock_RTS; + end Continue_All_Tasks; + + -------------------- + -- Get_User_State -- + -------------------- + + function Get_User_State return Long_Integer is + begin + return STPO.Self.User_State; + end Get_User_State; + + ---------------- + -- List_Tasks -- + ---------------- + + procedure List_Tasks is + C : Task_Id; + begin + C := All_Tasks_List; + + while C /= null loop + Print_Task_Info (C); + C := C.Common.All_Tasks_Link; + end loop; + end List_Tasks; + + ------------------------ + -- Print_Current_Task -- + ------------------------ + + procedure Print_Current_Task is + begin + Print_Task_Info (STPO.Self); + end Print_Current_Task; + + --------------------- + -- Print_Task_Info -- + --------------------- + + procedure Print_Task_Info (T : Task_Id) is + Entry_Call : Entry_Call_Link; + Parent : Task_Id; + + begin + if T = null then + Put_Line ("null task"); + return; + end if; + + Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len) & ": " & + Task_States'Image (T.Common.State)); + + Parent := T.Common.Parent; + + if Parent = null then + Put (", parent: "); + else + Put (", parent: " & + Parent.Common.Task_Image (1 .. Parent.Common.Task_Image_Len)); + end if; + + Put (", prio:" & T.Common.Current_Priority'Img); + + if not T.Callable then + Put (", not callable"); + end if; + + if T.Aborting then + Put (", aborting"); + end if; + + if T.Deferral_Level /= 0 then + Put (", abort deferred"); + end if; + + if T.Common.Call /= null then + Entry_Call := T.Common.Call; + Put (", serving:"); + + while Entry_Call /= null loop + Put (To_Integer (Entry_Call.Self)'Img); + Entry_Call := Entry_Call.Acceptor_Prev_Call; + end loop; + end if; + + if T.Open_Accepts /= null then + Put (", accepting:"); + + for J in T.Open_Accepts'Range loop + Put (T.Open_Accepts (J).S'Img); + end loop; + + if T.Terminate_Alternative then + Put (" or terminate"); + end if; + end if; + + if T.User_State /= 0 then + Put (", state:" & T.User_State'Img); + end if; + + Put_Line; + end Print_Task_Info; + + --------- + -- Put -- + --------- + + procedure Put (S : String) is + begin + Write (2, S, S'Length); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (S : String := "") is + begin + Write (2, S & ASCII.LF, S'Length + 1); + end Put_Line; + + ---------------------- + -- Resume_All_Tasks -- + ---------------------- + + procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is + C : Task_Id; + Dummy : Boolean; + pragma Unreferenced (Dummy); + + begin + STPO.Lock_RTS; + C := All_Tasks_List; + + while C /= null loop + Dummy := STPO.Resume_Task (C, Thread_Self); + C := C.Common.All_Tasks_Link; + end loop; + + STPO.Unlock_RTS; + end Resume_All_Tasks; + + --------------- + -- Set_Trace -- + --------------- + + procedure Set_Trace (Flag : Character; Value : Boolean := True) is + begin + Trace_On (Flag) := Value; + end Set_Trace; + + -------------------- + -- Set_User_State -- + -------------------- + + procedure Set_User_State (Value : Long_Integer) is + begin + STPO.Self.User_State := Value; + end Set_User_State; + + ------------------------ + -- Signal_Debug_Event -- + ------------------------ + + procedure Signal_Debug_Event + (Event_Kind : Event_Kind_Type; + Task_Value : Task_Id) + is + begin + null; + end Signal_Debug_Event; + + -------------------- + -- Stop_All_Tasks -- + -------------------- + + procedure Stop_All_Tasks is + C : Task_Id; + + Dummy : Boolean; + pragma Unreferenced (Dummy); + + begin + STPO.Lock_RTS; + + C := All_Tasks_List; + while C /= null loop + Dummy := STPO.Stop_Task (C); + C := C.Common.All_Tasks_Link; + end loop; + + STPO.Unlock_RTS; + end Stop_All_Tasks; + + ---------------------------- + -- Stop_All_Tasks_Handler -- + ---------------------------- + + procedure Stop_All_Tasks_Handler is + begin + STPO.Stop_All_Tasks; + end Stop_All_Tasks_Handler; + + ----------------------- + -- Suspend_All_Tasks -- + ----------------------- + + procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is + C : Task_Id; + Dummy : Boolean; + pragma Unreferenced (Dummy); + + begin + STPO.Lock_RTS; + C := All_Tasks_List; + + while C /= null loop + Dummy := STPO.Suspend_Task (C, Thread_Self); + C := C.Common.All_Tasks_Link; + end loop; + + STPO.Unlock_RTS; + end Suspend_All_Tasks; + + ------------------------ + -- Task_Creation_Hook -- + ------------------------ + + procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id) is + pragma Inspection_Point (Thread); + -- gdb needs to access the thread parameter in order to implement + -- the multitask mode under VxWorks. + + begin + null; + end Task_Creation_Hook; + + --------------------------- + -- Task_Termination_Hook -- + --------------------------- + + procedure Task_Termination_Hook is + begin + null; + end Task_Termination_Hook; + + ----------- + -- Trace -- + ----------- + + procedure Trace + (Self_Id : Task_Id; + Msg : String; + Flag : Character; + Other_Id : Task_Id := null) + is + begin + if Trace_On (Flag) then + Put (To_Integer (Self_Id)'Img & + ':' & Flag & ':' & + Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len) & + ':'); + + if Other_Id /= null then + Put (To_Integer (Other_Id)'Img & ':'); + end if; + + Put_Line (Msg); + end if; + end Trace; + + ----------- + -- Write -- + ----------- + + procedure Write (Fd : Integer; S : String; Count : Integer) is + Discard : System.CRTL.ssize_t; + pragma Unreferenced (Discard); + begin + Discard := System.CRTL.write (Fd, S (S'First)'Address, + System.CRTL.size_t (Count)); + -- Is it really right to ignore write errors here ??? + end Write; + +end System.Tasking.Debug; diff --git a/gcc/ada/s-tasdeb.ads b/gcc/ada/s-tasdeb.ads new file mode 100644 index 000000000..806fe0ee7 --- /dev/null +++ b/gcc/ada/s-tasdeb.ads @@ -0,0 +1,148 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . D E B U G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1997-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 encapsulates all direct interfaces to task debugging services +-- that are needed by gdb with gnat mode. + +with System.Tasking; +with System.OS_Interface; + +package System.Tasking.Debug is + pragma Preelaborate; + + ------------------------------------------ + -- Application-level debugging routines -- + ------------------------------------------ + + procedure List_Tasks; + -- Print a list of all the known Ada tasks with abbreviated state + -- information, one-per-line, to the standard error file. + + procedure Print_Current_Task; + -- Write information about current task, in hexadecimal, as one line, to + -- the standard error file. + + procedure Print_Task_Info (T : Task_Id); + -- Similar to Print_Current_Task, for a given task + + procedure Set_User_State (Value : Long_Integer); + -- Set user state value in the current task. This state will be displayed + -- when calling List_Tasks or Print_Current_Task. It is useful for setting + -- task specific state. + + function Get_User_State return Long_Integer; + -- Return the user state for the current task + + ------------------------- + -- General GDB support -- + ------------------------- + + Known_Tasks : array (0 .. 999) of Task_Id := (others => null); + -- Global array of tasks read by gdb, and updated by Create_Task and + -- Finalize_TCB + + Debug_Event_Activating : constant := 1; + Debug_Event_Run : constant := 2; + Debug_Event_Suspended : constant := 3; + Debug_Event_Preempted : constant := 4; + Debug_Event_Terminated : constant := 5; + Debug_Event_Abort_Terminated : constant := 6; + Debug_Event_Exception_Terminated : constant := 7; + Debug_Event_Rendezvous_Exception : constant := 8; + Debug_Event_Handled : constant := 9; + Debug_Event_Dependents_Exception : constant := 10; + Debug_Event_Handled_Others : constant := 11; + + subtype Event_Kind_Type is Positive range 1 .. 11; + -- Event kinds currently defined for debugging, used globally + -- below and on a per taak basis. + + procedure Signal_Debug_Event + (Event_Kind : Event_Kind_Type; + Task_Value : Task_Id); + + ---------------------------------- + -- VxWorks specific GDB support -- + ---------------------------------- + + -- Although the following routines are implemented in a target independent + -- manner, only VxWorks currently uses them. + + procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id); + -- This procedure is used to notify GDB of task's creation. It must be + -- called by the task's creator. + + procedure Task_Termination_Hook; + -- This procedure is used to notify GDB of task's termination + + procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id); + -- Suspend all the tasks except the one whose associated thread is + -- Thread_Self by traversing All_Tasks_Lists and calling + -- System.Task_Primitives.Operations.Suspend_Task. + + procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id); + -- Resume all the tasks except the one whose associated thread is + -- Thread_Self by traversing All_Tasks_Lists and calling + -- System.Task_Primitives.Operations.Continue_Task. + + procedure Stop_All_Tasks_Handler; + -- Stop all the tasks by traversing All_Tasks_Lists and calling + -- System.Task_Primitives.Operations.Stop_All_Task. This function + -- can be used in an interrupt handler. + + procedure Stop_All_Tasks; + -- Stop all the tasks by traversing All_Tasks_Lists and calling + -- System.Task_Primitives.Operations.Stop_Task. + + procedure Continue_All_Tasks; + -- Continue all the tasks by traversing All_Tasks_Lists and calling + -- System.Task_Primitives.Operations.Continue_Task. + + ------------------------------- + -- Run-time tracing routines -- + ------------------------------- + + procedure Trace + (Self_Id : Task_Id; + Msg : String; + Flag : Character; + Other_Id : Task_Id := null); + -- If traces for Flag are enabled, display on Standard_Error a given + -- message for the current task. Other_Id is an optional second task id + -- to display. + + procedure Set_Trace + (Flag : Character; + Value : Boolean := True); + -- Enable or disable tracing for Flag. By default, flags in the range + -- 'A' .. 'Z' are disabled, others are enabled. + +end System.Tasking.Debug; diff --git a/gcc/ada/s-tasinf-irix.ads b/gcc/ada/s-tasinf-irix.ads new file mode 100644 index 000000000..6e9394faf --- /dev/null +++ b/gcc/ada/s-tasinf-irix.ads @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ I N F 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 definitions and routines associated with the +-- implementation and use of the Task_Info pragma. It is specialized +-- appropriately for targets that make use of this pragma. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +-- This unit may be used directly from an application program by providing +-- an appropriate WITH, and the interface can be expected to remain stable. + +-- This is the IRIX (kernel threads) version of this package + +with Interfaces.C; + +package System.Task_Info is + pragma Preelaborate; + pragma Elaborate_Body; + -- To ensure that a body is allowed + + ----------------------------------------- + -- Implementation of Task_Info Feature -- + ----------------------------------------- + + -- Pragma Task_Info allows an application to set the underlying + -- pthread scheduling attributes for a specific task. + + ------------------ + -- Declarations -- + ------------------ + + type Thread_Scheduling_Scope is + (PTHREAD_SCOPE_PROCESS, PTHREAD_SCOPE_SYSTEM); + + for Thread_Scheduling_Scope'Size use Interfaces.C.int'Size; + + type Thread_Scheduling_Inheritance is + (PTHREAD_EXPLICIT_SCHED, PTHREAD_INHERIT_SCHED); + + for Thread_Scheduling_Inheritance'Size use Interfaces.C.int'Size; + + type Thread_Scheduling_Policy is + (SCHED_FIFO, -- The first-in-first-out real-time policy + SCHED_RR, -- The round-robin real-time scheduling policy + SCHED_TS); -- The timeshare earnings based scheduling policy + + for Thread_Scheduling_Policy'Size use Interfaces.C.int'Size; + for Thread_Scheduling_Policy use + (SCHED_FIFO => 1, + SCHED_RR => 2, + SCHED_TS => 3); + + function SCHED_OTHER return Thread_Scheduling_Policy renames SCHED_TS; + + No_Specified_Priority : constant := -1; + + subtype Thread_Scheduling_Priority is Integer range + No_Specified_Priority .. 255; + + subtype FIFO_Priority is Thread_Scheduling_Priority range 0 .. 255; + + subtype RR_Priority is Thread_Scheduling_Priority range 0 .. 255; + + subtype TS_Priority is Thread_Scheduling_Priority range 1 .. 40; + + subtype OTHER_Priority is Thread_Scheduling_Priority range 1 .. 40; + + subtype CPU_Number is Integer range -1 .. Integer'Last; + ANY_CPU : constant CPU_Number := CPU_Number'First; + + type Thread_Attributes is record + Scope : Thread_Scheduling_Scope := PTHREAD_SCOPE_PROCESS; + Inheritance : Thread_Scheduling_Inheritance := PTHREAD_EXPLICIT_SCHED; + Policy : Thread_Scheduling_Policy := SCHED_RR; + Priority : Thread_Scheduling_Priority := No_Specified_Priority; + Runon_CPU : CPU_Number := ANY_CPU; + end record; + + Default_Thread_Attributes : constant Thread_Attributes := + (PTHREAD_SCOPE_PROCESS, PTHREAD_EXPLICIT_SCHED, SCHED_RR, + No_Specified_Priority, ANY_CPU); + + type Task_Info_Type is access all Thread_Attributes; + + Unspecified_Task_Info : constant Task_Info_Type := null; + -- Value passed to task in the absence of a Task_Info pragma + +end System.Task_Info; diff --git a/gcc/ada/s-tasinf-linux.adb b/gcc/ada/s-tasinf-linux.adb new file mode 100644 index 000000000..d194cfb93 --- /dev/null +++ b/gcc/ada/s-tasinf-linux.adb @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ I N F O -- +-- -- +-- 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 is the GNU/Linux version of this module + +package body System.Task_Info is + + N_CPU : Natural := 0; + pragma Atomic (N_CPU); + -- Cache CPU number. Use pragma Atomic to avoid a race condition when + -- setting N_CPU in Number_Of_Processors below. + + -------------------------- + -- Number_Of_Processors -- + -------------------------- + + function Number_Of_Processors return Positive is + begin + if N_CPU = 0 then + N_CPU := Natural + (OS_Interface.sysconf (OS_Interface.SC_NPROCESSORS_ONLN)); + end if; + + return N_CPU; + end Number_Of_Processors; + +end System.Task_Info; diff --git a/gcc/ada/s-tasinf-linux.ads b/gcc/ada/s-tasinf-linux.ads new file mode 100644 index 000000000..db274f89f --- /dev/null +++ b/gcc/ada/s-tasinf-linux.ads @@ -0,0 +1,101 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ I N F O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 definitions and routines associated with the +-- implementation and use of the Task_Info pragma. It is specialized +-- appropriately for targets that make use of this pragma. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +-- This unit may be used directly from an application program by providing +-- an appropriate WITH, and the interface can be expected to remain stable. + +-- This is the GNU/Linux version of this module + +with System.OS_Interface; + +package System.Task_Info is + pragma Preelaborate; + pragma Elaborate_Body; + -- To ensure that a body is allowed + + -- Windows provides a way to define the ideal processor to use for a given + -- thread. The ideal processor is not necessarily the one that will be used + -- by the OS but the OS will always try to schedule this thread to the + -- specified processor if it is available. + + -- The Task_Info pragma: + + -- pragma Task_Info (EXPRESSION); + + -- allows the specification on a task by task basis of a value of type + -- System.Task_Info.Task_Info_Type to be passed to a task when it is + -- created. The specification of this type, and the effect on the task + -- that is created is target dependent. + + -- The Task_Info pragma appears within a task definition (compare the + -- definition and implementation of pragma Priority). If no such pragma + -- appears, then the value Unspecified_Task_Info is passed. If a pragma + -- is present, then it supplies an alternative value. If the argument of + -- the pragma is a discriminant reference, then the value can be set on + -- a task by task basis by supplying the appropriate discriminant value. + + -- Note that this means that the type used for Task_Info_Type must be + -- suitable for use as a discriminant (i.e. a scalar or access type). + + ----------------------- + -- Thread Attributes -- + ----------------------- + + subtype CPU_Set is System.OS_Interface.cpu_set_t; + + Any_CPU : constant CPU_Set := (bits => (others => True)); + No_CPU : constant CPU_Set := (bits => (others => False)); + + Invalid_CPU_Number : exception; + -- Raised when an invalid CPU mask has been specified + -- i.e. An empty CPU set + + type Thread_Attributes is record + CPU_Affinity : aliased CPU_Set := Any_CPU; + end record; + + Default_Thread_Attributes : constant Thread_Attributes := (others => <>); + + type Task_Info_Type is access all Thread_Attributes; + + Unspecified_Task_Info : constant Task_Info_Type := null; + + function Number_Of_Processors return Positive; + -- Returns the number of processors on the running host + +end System.Task_Info; diff --git a/gcc/ada/s-tasinf-mingw.adb b/gcc/ada/s-tasinf-mingw.adb new file mode 100644 index 000000000..14c68dcb8 --- /dev/null +++ b/gcc/ada/s-tasinf-mingw.adb @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ I N F O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 (native) version of this module + +with System.OS_Interface; +pragma Unreferenced (System.OS_Interface); +-- System.OS_Interface is not used today, but the protocol between the +-- run-time and the binder is that any tasking application uses +-- System.OS_Interface, so notify the binder with this "with" clause. + +package body System.Task_Info is + + N_CPU : Natural := 0; + pragma Atomic (N_CPU); + -- Cache CPU number. Use pragma Atomic to avoid a race condition when + -- setting N_CPU in Number_Of_Processors below. + + -------------------------- + -- Number_Of_Processors -- + -------------------------- + + function Number_Of_Processors return Positive is + begin + if N_CPU = 0 then + declare + SI : aliased Win32.SYSTEM_INFO; + begin + Win32.GetSystemInfo (SI'Access); + N_CPU := Positive (SI.dwNumberOfProcessors); + end; + end if; + + return N_CPU; + end Number_Of_Processors; + +end System.Task_Info; diff --git a/gcc/ada/s-tasinf-mingw.ads b/gcc/ada/s-tasinf-mingw.ads new file mode 100644 index 000000000..fb70109ac --- /dev/null +++ b/gcc/ada/s-tasinf-mingw.ads @@ -0,0 +1,102 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ I N F O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 definitions and routines associated with the +-- implementation and use of the Task_Info pragma. It is specialized +-- appropriately for targets that make use of this pragma. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +-- This unit may be used directly from an application program by providing +-- an appropriate WITH, and the interface can be expected to remain stable. + +-- This is the Windows (native) version of this module + +with System.Win32; + +package System.Task_Info is + pragma Preelaborate; + pragma Elaborate_Body; + -- To ensure that a body is allowed + + use type System.Win32.ProcessorId; + + -- Windows provides a way to define the ideal processor to use for a given + -- thread. The ideal processor is not necessarily the one that will be used + -- by the OS but the OS will always try to schedule this thread to the + -- specified processor if it is available. + + -- The Task_Info pragma: + + -- pragma Task_Info (EXPRESSION); + + -- allows the specification on a task by task basis of a value of type + -- System.Task_Info.Task_Info_Type to be passed to a task when it is + -- created. The specification of this type, and the effect on the task + -- that is created is target dependent. + + -- The Task_Info pragma appears within a task definition (compare the + -- definition and implementation of pragma Priority). If no such pragma + -- appears, then the value Unspecified_Task_Info is passed. If a pragma + -- is present, then it supplies an alternative value. If the argument of + -- the pragma is a discriminant reference, then the value can be set on + -- a task by task basis by supplying the appropriate discriminant value. + + -- Note that this means that the type used for Task_Info_Type must be + -- suitable for use as a discriminant (i.e. a scalar or access type). + + ----------------------- + -- Thread Attributes -- + ----------------------- + + subtype CPU_Number is System.Win32.ProcessorId; + + Any_CPU : constant CPU_Number := -1; + + Invalid_CPU_Number : exception; + -- Raised when an invalid CPU number has been specified + -- i.e. CPU > Number_Of_Processors. + + type Thread_Attributes is record + CPU : CPU_Number := Any_CPU; + end record; + + Default_Thread_Attributes : constant Thread_Attributes := (others => <>); + + type Task_Info_Type is access all Thread_Attributes; + + Unspecified_Task_Info : constant Task_Info_Type := null; + + function Number_Of_Processors return Positive; + -- Returns the number of processors on the running host + +end System.Task_Info; diff --git a/gcc/ada/s-tasinf-solaris.adb b/gcc/ada/s-tasinf-solaris.adb new file mode 100644 index 000000000..ac0645dcd --- /dev/null +++ b/gcc/ada/s-tasinf-solaris.adb @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ I N F 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package body contains the routines associated with the implementation +-- of the Task_Info pragma. + +-- This is the Solaris (native) version of this module + +package body System.Task_Info is + + ----------------------------- + -- Bound_Thread_Attributes -- + ----------------------------- + + function Bound_Thread_Attributes return Thread_Attributes is + begin + return (False, True); + end Bound_Thread_Attributes; + + function Bound_Thread_Attributes (CPU : CPU_Number) + return Thread_Attributes is + begin + return (True, True, CPU); + end Bound_Thread_Attributes; + + --------------------------------- + -- New_Bound_Thread_Attributes -- + --------------------------------- + + function New_Bound_Thread_Attributes return Task_Info_Type is + begin + return new Thread_Attributes'(False, True); + end New_Bound_Thread_Attributes; + + function New_Bound_Thread_Attributes (CPU : CPU_Number) + return Task_Info_Type is + begin + return new Thread_Attributes'(True, True, CPU); + end New_Bound_Thread_Attributes; + + ----------------------------------- + -- New_Unbound_Thread_Attributes -- + ----------------------------------- + + function New_Unbound_Thread_Attributes return Task_Info_Type is + begin + return new Thread_Attributes'(False, False); + end New_Unbound_Thread_Attributes; + + ------------------------------- + -- Unbound_Thread_Attributes -- + ------------------------------- + + function Unbound_Thread_Attributes return Thread_Attributes is + begin + return (False, False); + end Unbound_Thread_Attributes; + +end System.Task_Info; diff --git a/gcc/ada/s-tasinf-solaris.ads b/gcc/ada/s-tasinf-solaris.ads new file mode 100644 index 000000000..a7fc7ac19 --- /dev/null +++ b/gcc/ada/s-tasinf-solaris.ads @@ -0,0 +1,141 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ I N F 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 definitions and routines associated with the +-- implementation and use of the Task_Info pragma. It is specialized +-- appropriately for targets that make use of this pragma. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +-- This unit may be used directly from an application program by providing +-- an appropriate WITH, and the interface can be expected to remain stable. + +-- This is the Solaris (native) version of this module + +with System.OS_Interface; + +package System.Task_Info is + pragma Preelaborate; + pragma Elaborate_Body; + -- To ensure that a body is allowed + + ----------------------------------------------------- + -- Binding of Tasks to LWPs and LWPs to processors -- + ----------------------------------------------------- + + -- The Solaris implementation of the GNU Low-Level Interface (GNULLI) + -- implements each Ada task as a Solaris thread. The Solaris thread + -- library distributes threads across one or more LWPs (Light Weight + -- Process) that are members of the same process. Solaris distributes + -- processes and LWPs across the available CPUs on a given machine. The + -- pragma Task_Info provides the mechanism to control the distribution + -- of tasks to LWPs, and LWPs to processors. + + -- Each thread has a number of attributes that dictate it's scheduling. + -- These attributes are: + -- + -- New_LWP: whether a new LWP is created for this thread. + -- + -- Bound_To_LWP: whether the thread is bound to a specific LWP + -- for its entire lifetime. + -- + -- CPU: the CPU number associated to the LWP + -- + + -- The Task_Info pragma: + + -- pragma Task_Info (EXPRESSION); + + -- allows the specification on a task by task basis of a value of type + -- System.Task_Info.Task_Info_Type to be passed to a task when it is + -- created. The specification of this type, and the effect on the task + -- that is created is target dependent. + + -- The Task_Info pragma appears within a task definition (compare the + -- definition and implementation of pragma Priority). If no such pragma + -- appears, then the value Unspecified_Task_Info is passed. If a pragma + -- is present, then it supplies an alternative value. If the argument of + -- the pragma is a discriminant reference, then the value can be set on + -- a task by task basis by supplying the appropriate discriminant value. + + -- Note that this means that the type used for Task_Info_Type must be + -- suitable for use as a discriminant (i.e. a scalar or access type). + + ----------------------- + -- Thread Attributes -- + ----------------------- + + subtype CPU_Number is System.OS_Interface.processorid_t; + + CPU_UNCHANGED : constant CPU_Number := System.OS_Interface.PBIND_QUERY; + -- Do not bind the LWP to a specific processor + + ANY_CPU : constant CPU_Number := System.OS_Interface.PBIND_NONE; + -- Bind the LWP to any processor + + Invalid_CPU_Number : exception; + + type Thread_Attributes (New_LWP : Boolean) is record + Bound_To_LWP : Boolean := True; + case New_LWP is + when False => + null; + when True => + CPU : CPU_Number := CPU_UNCHANGED; + end case; + end record; + + Default_Thread_Attributes : constant Thread_Attributes := (False, True); + + function Unbound_Thread_Attributes + return Thread_Attributes; + + function Bound_Thread_Attributes + return Thread_Attributes; + + function Bound_Thread_Attributes (CPU : CPU_Number) + return Thread_Attributes; + + type Task_Info_Type is access all Thread_Attributes; + + function New_Unbound_Thread_Attributes + return Task_Info_Type; + + function New_Bound_Thread_Attributes + return Task_Info_Type; + + function New_Bound_Thread_Attributes (CPU : CPU_Number) + return Task_Info_Type; + + Unspecified_Task_Info : constant Task_Info_Type := null; + +end System.Task_Info; diff --git a/gcc/ada/s-tasinf-tru64.ads b/gcc/ada/s-tasinf-tru64.ads new file mode 100644 index 000000000..af2832d09 --- /dev/null +++ b/gcc/ada/s-tasinf-tru64.ads @@ -0,0 +1,110 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ I N F O -- +-- -- +-- S p e c -- +-- (Compiler Interface) -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the definitions and routines associated with the +-- implementation and use of the Task_Info pragma. It is specialized +-- appropriately for targets that make use of this pragma. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +-- This unit may be used directly from an application program by providing +-- an appropriate WITH, and the interface can be expected to remain stable. + +-- This is a DEC Unix 4.0d version of this package + +package System.Task_Info is + pragma Preelaborate; + pragma Elaborate_Body; + -- To ensure that a body is allowed + + ----------------------------------------- + -- Implementation of Task_Info Feature -- + ----------------------------------------- + + -- The Task_Info pragma: + + -- pragma Task_Info (EXPRESSION); + + -- allows the specification on a task by task basis of a value of type + -- System.Task_Info.Task_Info_Type to be passed to a task when it is + -- created. The specification of this type, and the effect on the task + -- that is created is target dependent. + + -- The Task_Info pragma appears within a task definition (compare the + -- definition and implementation of pragma Priority). If no such pragma + -- appears, then the value Unspecified_Task_Info is passed. If a pragma + -- is present, then it supplies an alternative value. If the argument of + -- the pragma is a discriminant reference, then the value can be set on + -- a task by task basis by supplying the appropriate discriminant value. + + -- Note that this means that the type used for Task_Info_Type must be + -- suitable for use as a discriminant (i.e. a scalar or access type). + + ------------------ + -- Declarations -- + ------------------ + + type Scope_Type is + (Process_Scope, + -- Contend only with threads in same process + + System_Scope, + -- Contend with all threads on same CPU + + Default_Scope); + + type Thread_Attributes is record + Bind_To_Cpu_Number : Integer; + -- -1: Do nothing + -- 0: Unbind + -- 1-N: Bind all unbound threads to this CPU + + Contention_Scope : Scope_Type; + end record; + + type Task_Info_Type is access all Thread_Attributes; + -- Type used for passing information to task create call, using the + -- Task_Info pragma. This type may be specialized for individual + -- implementations, but it must be a type that can be used as a + -- discriminant (i.e. a scalar or access type). + + Unspecified_Thread_Attribute : aliased Thread_Attributes := + Thread_Attributes'(-1, Default_Scope); + + Unspecified_Task_Info : constant Task_Info_Type := + Unspecified_Thread_Attribute'Access; + -- Value passed to task in the absence of a Task_Info pragma + -- Don't call new here because the tasking run time has not been + -- elaborated yet, so calling Task_Lock is unsafe. + +end System.Task_Info; diff --git a/gcc/ada/s-tasinf-vxworks.ads b/gcc/ada/s-tasinf-vxworks.ads new file mode 100644 index 000000000..18b2ad427 --- /dev/null +++ b/gcc/ada/s-tasinf-vxworks.ads @@ -0,0 +1,90 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ I N F 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 definitions and routines associated with the +-- implementation and use of the Task_Info pragma. It is specialized +-- appropriately for targets that make use of this pragma. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +-- This unit may be used directly from an application program by providing +-- an appropriate WITH, and the interface can be expected to remain stable. + +-- This is the VxWorks version of this package + +with Interfaces.C; + +package System.Task_Info is + pragma Preelaborate; + pragma Elaborate_Body; + -- To ensure that a body is allowed + + ----------------------------------------- + -- Implementation of Task_Info Feature -- + ----------------------------------------- + + -- The Task_Info pragma: + + -- pragma Task_Info (EXPRESSION); + + -- allows the specification on a task by task basis of a value of type + -- System.Task_Info.Task_Info_Type to be passed to a task when it is + -- created. The specification of this type, and the effect on the task + -- that is created is target dependent. + + -- The Task_Info pragma appears within a task definition (compare the + -- definition and implementation of pragma Priority). If no such pragma + -- appears, then the value Unspecified_Task_Info is passed. If a pragma + -- is present, then it supplies an alternative value. If the argument of + -- the pragma is a discriminant reference, then the value can be set on + -- a task by task basis by supplying the appropriate discriminant value. + + -- Note that this means that the type used for Task_Info_Type must be + -- suitable for use as a discriminant (i.e. a scalar or access type). + + ------------------ + -- Declarations -- + ------------------ + + subtype Task_Info_Type is Interfaces.C.int; + -- This is a CPU number (positive) + + Any_CPU : constant Task_Info_Type := 0; + -- Allow task to run on any CPU + + use type Interfaces.C.int; + + Unspecified_Task_Info : constant Task_Info_Type := -1; + -- Value passed to task in the absence of a Task_Info pragma + -- This value means do not try to set the CPU affinity + +end System.Task_Info; diff --git a/gcc/ada/s-tasinf.adb b/gcc/ada/s-tasinf.adb new file mode 100644 index 000000000..905af8605 --- /dev/null +++ b/gcc/ada/s-tasinf.adb @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ I N F O -- +-- -- +-- B o d y -- +-- (Compiler Interface) -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a dummy version of this package that is needed to solve bootstrap +-- problems when compiling a library that doesn't require s-tasinf.adb from +-- a compiler that contains one. + +-- This package contains the definitions and routines associated with the +-- implementation of the Task_Info pragma. + +package body System.Task_Info is +end System.Task_Info; diff --git a/gcc/ada/s-tasinf.ads b/gcc/ada/s-tasinf.ads new file mode 100644 index 000000000..55f949ab1 --- /dev/null +++ b/gcc/ada/s-tasinf.ads @@ -0,0 +1,92 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ I N F 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 definitions and routines associated with the +-- implementation and use of the Task_Info pragma. It is specialized +-- appropriately for targets that make use of this pragma. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +-- This unit may be used directly from an application program by providing +-- an appropriate WITH, and the interface can be expected to remain stable. + +package System.Task_Info is + pragma Preelaborate; + pragma Elaborate_Body; + -- To ensure that a body is allowed + + ----------------------------------------- + -- Implementation of Task_Info Feature -- + ----------------------------------------- + + -- The Task_Info pragma: + + -- pragma Task_Info (EXPRESSION); + + -- allows the specification on a task by task basis of a value of type + -- System.Task_Info.Task_Info_Type to be passed to a task when it is + -- created. The specification of this type, and the effect on the task + -- that is created is target dependent. + + -- The Task_Info pragma appears within a task definition (compare the + -- definition and implementation of pragma Priority). If no such pragma + -- appears, then the value Unspecified_Task_Info is passed. If a pragma + -- is present, then it supplies an alternative value. If the argument of + -- the pragma is a discriminant reference, then the value can be set on + -- a task by task basis by supplying the appropriate discriminant value. + + -- Note that this means that the type used for Task_Info_Type must be + -- suitable for use as a discriminant (i.e. a scalar or access type). + + ------------------ + -- Declarations -- + ------------------ + + type Scope_Type is + (Process_Scope, + -- Contend only with threads in same process + + System_Scope, + -- Contend with all threads on same CPU + + Default_Scope); + + type Task_Info_Type is new Scope_Type; + -- Type used for passing information to task create call, using the + -- Task_Info pragma. This type may be specialized for individual + -- implementations, but it must be a type that can be used as a + -- discriminant (i.e. a scalar or access type). + + Unspecified_Task_Info : constant Task_Info_Type := Default_Scope; + -- Value passed to task in the absence of a Task_Info pragma + +end System.Task_Info; diff --git a/gcc/ada/s-tasini.adb b/gcc/ada/s-tasini.adb new file mode 100644 index 000000000..cacd86c4c --- /dev/null +++ b/gcc/ada/s-tasini.adb @@ -0,0 +1,829 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . I N I T I A L I Z A T I O N -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram alpha ordering check, since we group soft link bodies +-- and dummy soft link bodies together separately in this unit. + +pragma Polling (Off); +-- Turn polling off for this package. We don't need polling during any of the +-- routines in this package, and more to the point, if we try to poll it can +-- cause infinite loops. + +with Ada.Exceptions; + +with System.Task_Primitives; +with System.Task_Primitives.Operations; +with System.Soft_Links; +with System.Soft_Links.Tasking; +with System.Tasking.Debug; +with System.Parameters; + +package body System.Tasking.Initialization is + + package STPO renames System.Task_Primitives.Operations; + package SSL renames System.Soft_Links; + package AE renames Ada.Exceptions; + + use Parameters; + use Task_Primitives.Operations; + + Global_Task_Lock : aliased System.Task_Primitives.RTS_Lock; + -- This is a global lock; it is used to execute in mutual exclusion from + -- all other tasks. It is only used by Task_Lock, Task_Unlock, and + -- Final_Task_Unlock. + + ---------------------------------------------------------------------- + -- Tasking versions of some services needed by non-tasking programs -- + ---------------------------------------------------------------------- + + procedure Abort_Defer; + -- NON-INLINE versions without Self_ID for soft links + + procedure Abort_Undefer; + -- NON-INLINE versions without Self_ID for soft links + + procedure Task_Lock; + -- 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. + + procedure Task_Unlock; + -- Releases lock previously set by call to Task_Lock. In the nested case, + -- all nested locks must be released before other tasks competing for the + -- tasking lock are released. + + function Get_Current_Excep return SSL.EOA; + -- Task-safe version of SSL.Get_Current_Excep + + procedure Update_Exception + (X : AE.Exception_Occurrence := SSL.Current_Target_Exception); + -- Handle exception setting and check for pending actions + + function Task_Name return String; + -- Returns current task's name + + ------------------------ + -- Local Subprograms -- + ------------------------ + + ---------------------------- + -- Tasking Initialization -- + ---------------------------- + + procedure Init_RTS; + -- This procedure completes the initialization of the GNARL. The first part + -- of the initialization is done in the body of System.Tasking. It consists + -- of initializing global locks, and installing tasking versions of certain + -- operations used by the compiler. Init_RTS is called during elaboration. + + -------------------------- + -- Change_Base_Priority -- + -------------------------- + + -- Call only with abort deferred and holding Self_ID locked + + procedure Change_Base_Priority (T : Task_Id) is + begin + if T.Common.Base_Priority /= T.New_Base_Priority then + T.Common.Base_Priority := T.New_Base_Priority; + Set_Priority (T, T.Common.Base_Priority); + end if; + end Change_Base_Priority; + + ------------------------ + -- Check_Abort_Status -- + ------------------------ + + function Check_Abort_Status return Integer is + Self_ID : constant Task_Id := Self; + begin + if Self_ID /= null + and then Self_ID.Deferral_Level = 0 + and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + then + return 1; + else + return 0; + end if; + end Check_Abort_Status; + + ----------------- + -- Defer_Abort -- + ----------------- + + procedure Defer_Abort (Self_ID : Task_Id) is + begin + if No_Abort then + return; + end if; + + pragma Assert (Self_ID.Deferral_Level = 0); + + -- pragma Assert + -- (Self_ID.Pending_ATC_Level >= Self_ID.ATC_Nesting_Level); + + -- The above check has been useful in detecting mismatched defer/undefer + -- pairs. You may uncomment it when testing on systems that support + -- preemptive abort. + + -- If the OS supports preemptive abort (e.g. pthread_kill), it should + -- have happened already. A problem is with systems that do not support + -- preemptive abort, and so rely on polling. On such systems we may get + -- false failures of the assertion, since polling for pending abort does + -- no occur until the abort undefer operation. + + -- Even on systems that only poll for abort, the assertion may be useful + -- for catching missed abort completion polling points. The operations + -- that undefer abort poll for pending aborts. This covers most of the + -- places where the core Ada semantics require abort to be caught, + -- without any special attention. However, this generally happens on + -- exit from runtime system call, which means a pending abort will not + -- be noticed on the way into the runtime system. We considered adding a + -- check for pending aborts at this point, but chose not to, because of + -- the overhead. Instead, we searched for RTS calls where abort + -- completion is required and a task could go farther than Ada allows + -- before undeferring abort; we then modified the code to ensure the + -- abort would be detected. + + Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1; + end Defer_Abort; + + -------------------------- + -- Defer_Abort_Nestable -- + -------------------------- + + procedure Defer_Abort_Nestable (Self_ID : Task_Id) is + begin + if No_Abort then + return; + end if; + + -- The following assertion is by default disabled. See the comment in + -- Defer_Abort on the situations in which it may be useful to uncomment + -- this assertion and enable the test. + + -- pragma Assert + -- (Self_ID.Pending_ATC_Level >= Self_ID.ATC_Nesting_Level or else + -- Self_ID.Deferral_Level > 0); + + Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1; + end Defer_Abort_Nestable; + + ----------------- + -- Abort_Defer -- + ----------------- + + procedure Abort_Defer is + Self_ID : Task_Id; + begin + if No_Abort then + return; + end if; + + Self_ID := STPO.Self; + Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1; + end Abort_Defer; + + ----------------------- + -- Get_Current_Excep -- + ----------------------- + + function Get_Current_Excep return SSL.EOA is + begin + return STPO.Self.Common.Compiler_Data.Current_Excep'Access; + end Get_Current_Excep; + + ----------------------- + -- Do_Pending_Action -- + ----------------------- + + -- Call only when holding no locks + + procedure Do_Pending_Action (Self_ID : Task_Id) is + use type Ada.Exceptions.Exception_Id; + + begin + pragma Assert (Self_ID = Self and then Self_ID.Deferral_Level = 0); + + -- Needs loop to recheck for pending action in case a new one occurred + -- while we had abort deferred below. + + loop + -- Temporarily defer abort so that we can lock Self_ID + + Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1; + + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + Self_ID.Pending_Action := False; + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + -- Restore the original Deferral value + + Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1; + + if not Self_ID.Pending_Action then + if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then + if not Self_ID.Aborting then + Self_ID.Aborting := True; + pragma Debug + (Debug.Trace (Self_ID, "raise Abort_Signal", 'B')); + raise Standard'Abort_Signal; + + pragma Assert (not Self_ID.ATC_Hack); + + elsif Self_ID.ATC_Hack then + + -- The solution really belongs in the Abort_Signal handler + -- for async. entry calls. The present hack is very + -- fragile. It relies that the very next point after + -- Exit_One_ATC_Level at which the task becomes abortable + -- will be the call to Undefer_Abort in the + -- Abort_Signal handler. + + Self_ID.ATC_Hack := False; + + pragma Debug + (Debug.Trace + (Self_ID, "raise Abort_Signal (ATC hack)", 'B')); + raise Standard'Abort_Signal; + end if; + end if; + + return; + end if; + end loop; + end Do_Pending_Action; + + ----------------------- + -- Final_Task_Unlock -- + ----------------------- + + -- This version is only for use in Terminate_Task, when the task is + -- relinquishing further rights to its own ATCB. + + -- There is a very interesting potential race condition there, where the + -- old task may run concurrently with a new task that is allocated the old + -- tasks (now reused) ATCB. The critical thing here is to not make any + -- reference to the ATCB after the lock is released. See also comments on + -- Terminate_Task and Unlock. + + procedure Final_Task_Unlock (Self_ID : Task_Id) is + begin + pragma Assert (Self_ID.Common.Global_Task_Lock_Nesting = 1); + Unlock (Global_Task_Lock'Access, Global_Lock => True); + end Final_Task_Unlock; + + -------------- + -- Init_RTS -- + -------------- + + procedure Init_RTS is + Self_Id : Task_Id; + begin + Tasking.Initialize; + + -- Terminate run time (regular vs restricted) specific initialization + -- of the environment task. + + Self_Id := Environment_Task; + Self_Id.Master_of_Task := Environment_Task_Level; + Self_Id.Master_Within := Self_Id.Master_of_Task + 1; + + for L in Self_Id.Entry_Calls'Range loop + Self_Id.Entry_Calls (L).Self := Self_Id; + Self_Id.Entry_Calls (L).Level := L; + end loop; + + Self_Id.Awake_Count := 1; + Self_Id.Alive_Count := 1; + + -- Normally, a task starts out with internal master nesting level one + -- larger than external master nesting level. It is incremented to one + -- by Enter_Master, which is called in the task body only if the + -- compiler thinks the task may have dependent tasks. There is no + -- corresponding call to Enter_Master for the environment task, so we + -- would need to increment it to 2 here. Instead, we set it to 3. By + -- doing this we reserve the level 2 for server tasks of the runtime + -- system. The environment task does not need to wait for these server + + Self_Id.Master_Within := Library_Task_Level; + + -- Initialize lock used to implement mutual exclusion between all tasks + + Initialize_Lock (Global_Task_Lock'Access, STPO.Global_Task_Level); + + -- Notify that the tasking run time has been elaborated so that + -- the tasking version of the soft links can be used. + + if not No_Abort then + SSL.Abort_Defer := Abort_Defer'Access; + SSL.Abort_Undefer := Abort_Undefer'Access; + end if; + + SSL.Lock_Task := Task_Lock'Access; + SSL.Unlock_Task := Task_Unlock'Access; + SSL.Check_Abort_Status := Check_Abort_Status'Access; + SSL.Task_Name := Task_Name'Access; + SSL.Update_Exception := Update_Exception'Access; + SSL.Get_Current_Excep := Get_Current_Excep'Access; + + -- Initialize the tasking soft links (if not done yet) that are common + -- to the full and the restricted run times. + + SSL.Tasking.Init_Tasking_Soft_Links; + + -- Abort is deferred in a new ATCB, so we need to undefer abort at this + -- stage to make the environment task abortable. + + Undefer_Abort (Environment_Task); + end Init_RTS; + + --------------------------- + -- Locked_Abort_To_Level-- + --------------------------- + + -- Abort a task to the specified ATC nesting level. + -- Call this only with T locked. + + -- An earlier version of this code contained a call to Wakeup. That should + -- not be necessary here, if Abort_Task is implemented correctly, since + -- Abort_Task should include the effect of Wakeup. However, the above call + -- was in earlier versions of this file, and at least for some targets + -- Abort_Task has not been doing Wakeup. It should not hurt to uncomment + -- the above call, until the error is corrected for all targets. + + -- See extended comments in package body System.Tasking.Abort for the + -- overall design of the implementation of task abort. + -- ??? there is no such package ??? + + -- If the task is sleeping it will be in an abort-deferred region, and will + -- not have Abort_Signal raised by Abort_Task. Such an "abort deferral" is + -- just to protect the RTS internals, and not necessarily required to + -- enforce Ada semantics. Abort_Task should wake the task up and let it + -- decide if it wants to complete the aborted construct immediately. + + -- Note that the effect of the low-level Abort_Task is not persistent. + -- If the target task is not blocked, this wakeup will be missed. + + -- We don't bother calling Abort_Task if this task is aborting itself, + -- since we are inside the RTS and have abort deferred. Similarly, We don't + -- bother to call Abort_Task if T is terminated, since there is no need to + -- abort a terminated task, and it could be dangerous to try if the task + -- has stopped executing. + + -- Note that an earlier version of this code had some false reasoning about + -- being able to reliably wake up a task that had suspended on a blocking + -- system call that does not atomically release the task's lock (e.g., UNIX + -- nanosleep, which we once thought could be used to implement delays). + -- That still left the possibility of missed wakeups. + + -- We cannot safely call Vulnerable_Complete_Activation here, since that + -- requires locking Self_ID.Parent. The anti-deadlock lock ordering rules + -- would then require us to release the lock on Self_ID first, which would + -- create a timing window for other tasks to lock Self_ID. This is + -- significant for tasks that may be aborted before their execution can + -- enter the task body, and so they do not get a chance to call + -- Complete_Task. The actual work for this case is done in Terminate_Task. + + procedure Locked_Abort_To_Level + (Self_ID : Task_Id; + T : Task_Id; + L : ATC_Level) + is + begin + if not T.Aborting and then T /= Self_ID then + case T.Common.State is + when Unactivated | Terminated => + pragma Assert (False); + null; + + when Activating | Runnable => + + -- This is needed to cancel an asynchronous protected entry + -- call during a requeue with abort. + + T.Entry_Calls + (T.ATC_Nesting_Level).Cancellation_Attempted := True; + + when Interrupt_Server_Blocked_On_Event_Flag => + null; + + when Delay_Sleep | + Async_Select_Sleep | + Interrupt_Server_Idle_Sleep | + Interrupt_Server_Blocked_Interrupt_Sleep | + Timer_Server_Sleep | + AST_Server_Sleep => + Wakeup (T, T.Common.State); + + when Acceptor_Sleep | Acceptor_Delay_Sleep => + T.Open_Accepts := null; + Wakeup (T, T.Common.State); + + when Entry_Caller_Sleep => + T.Entry_Calls + (T.ATC_Nesting_Level).Cancellation_Attempted := True; + Wakeup (T, T.Common.State); + + when Activator_Sleep | + Master_Completion_Sleep | + Master_Phase_2_Sleep | + Asynchronous_Hold => + null; + end case; + end if; + + if T.Pending_ATC_Level > L then + T.Pending_ATC_Level := L; + T.Pending_Action := True; + + if L = 0 then + T.Callable := False; + end if; + + -- This prevents aborted task from accepting calls + + if T.Aborting then + + -- The test above is just a heuristic, to reduce wasteful + -- calls to Abort_Task. We are holding T locked, and this + -- value will not be set to False except with T also locked, + -- inside Exit_One_ATC_Level, so we should not miss wakeups. + + if T.Common.State = Acceptor_Sleep + or else + T.Common.State = Acceptor_Delay_Sleep + then + T.Open_Accepts := null; + end if; + + elsif T /= Self_ID and then + (T.Common.State = Runnable + or else T.Common.State = Interrupt_Server_Blocked_On_Event_Flag) + + -- The task is blocked on a system call waiting for the + -- completion event. In this case Abort_Task may need to take + -- special action in order to succeed. Example system: VMS. + + then + Abort_Task (T); + end if; + end if; + end Locked_Abort_To_Level; + + -------------------------------- + -- Remove_From_All_Tasks_List -- + -------------------------------- + + procedure Remove_From_All_Tasks_List (T : Task_Id) is + C : Task_Id; + Previous : Task_Id; + + begin + pragma Debug + (Debug.Trace (Self, "Remove_From_All_Tasks_List", 'C')); + + Previous := Null_Task; + C := All_Tasks_List; + while C /= Null_Task loop + if C = T then + if Previous = Null_Task then + All_Tasks_List := All_Tasks_List.Common.All_Tasks_Link; + else + Previous.Common.All_Tasks_Link := C.Common.All_Tasks_Link; + end if; + + return; + end if; + + Previous := C; + C := C.Common.All_Tasks_Link; + end loop; + + pragma Assert (False); + end Remove_From_All_Tasks_List; + + --------------- + -- Task_Lock -- + --------------- + + procedure Task_Lock (Self_ID : Task_Id) is + begin + Self_ID.Common.Global_Task_Lock_Nesting := + Self_ID.Common.Global_Task_Lock_Nesting + 1; + + if Self_ID.Common.Global_Task_Lock_Nesting = 1 then + Defer_Abort_Nestable (Self_ID); + Write_Lock (Global_Task_Lock'Access, Global_Lock => True); + end if; + end Task_Lock; + + procedure Task_Lock is + begin + Task_Lock (STPO.Self); + end Task_Lock; + + --------------- + -- Task_Name -- + --------------- + + function Task_Name return String is + Self_Id : constant Task_Id := STPO.Self; + begin + return Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len); + end Task_Name; + + ----------------- + -- Task_Unlock -- + ----------------- + + procedure Task_Unlock (Self_ID : Task_Id) is + begin + pragma Assert (Self_ID.Common.Global_Task_Lock_Nesting > 0); + Self_ID.Common.Global_Task_Lock_Nesting := + Self_ID.Common.Global_Task_Lock_Nesting - 1; + + if Self_ID.Common.Global_Task_Lock_Nesting = 0 then + Unlock (Global_Task_Lock'Access, Global_Lock => True); + Undefer_Abort_Nestable (Self_ID); + end if; + end Task_Unlock; + + procedure Task_Unlock is + begin + Task_Unlock (STPO.Self); + end Task_Unlock; + + ------------------- + -- Undefer_Abort -- + ------------------- + + -- Precondition : Self does not hold any locks! + + -- Undefer_Abort is called on any abort completion point (aka. + -- synchronization point). It performs the following actions if they + -- are pending: (1) change the base priority, (2) abort the task. + + -- The priority change has to occur before abort. Otherwise, it would + -- take effect no earlier than the next abort completion point. + + procedure Undefer_Abort (Self_ID : Task_Id) is + begin + if No_Abort then + return; + end if; + + pragma Assert (Self_ID.Deferral_Level = 1); + + Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1; + + if Self_ID.Deferral_Level = 0 then + pragma Assert (Check_No_Locks (Self_ID)); + + if Self_ID.Pending_Action then + Do_Pending_Action (Self_ID); + end if; + end if; + end Undefer_Abort; + + ---------------------------- + -- Undefer_Abort_Nestable -- + ---------------------------- + + -- An earlier version would re-defer abort if an abort is in progress. + -- Then, we modified the effect of the raise statement so that it defers + -- abort until control reaches a handler. That was done to prevent + -- "skipping over" a handler if another asynchronous abort occurs during + -- the propagation of the abort to the handler. + + -- There has been talk of reversing that decision, based on a newer + -- implementation of exception propagation. Care must be taken to evaluate + -- how such a change would interact with the above code and all the places + -- where abort-deferral is used to bridge over critical transitions, such + -- as entry to the scope of a region with a finalizer and entry into the + -- body of an accept-procedure. + + procedure Undefer_Abort_Nestable (Self_ID : Task_Id) is + begin + if No_Abort then + return; + end if; + + pragma Assert (Self_ID.Deferral_Level > 0); + + Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1; + + if Self_ID.Deferral_Level = 0 then + + pragma Assert (Check_No_Locks (Self_ID)); + + if Self_ID.Pending_Action then + Do_Pending_Action (Self_ID); + end if; + end if; + end Undefer_Abort_Nestable; + + ------------------- + -- Abort_Undefer -- + ------------------- + + procedure Abort_Undefer is + Self_ID : Task_Id; + begin + if No_Abort then + return; + end if; + + Self_ID := STPO.Self; + + if Self_ID.Deferral_Level = 0 then + + -- In case there are different views on whether Abort is supported + -- between the expander and the run time, we may end up with + -- Self_ID.Deferral_Level being equal to zero, when called from + -- the procedure created by the expander that corresponds to a + -- task body. + + -- In this case, there's nothing to be done + + -- See related code in System.Tasking.Stages.Create_Task resetting + -- Deferral_Level when System.Restrictions.Abort_Allowed is False. + + return; + end if; + + pragma Assert (Self_ID.Deferral_Level > 0); + Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1; + + if Self_ID.Deferral_Level = 0 then + pragma Assert (Check_No_Locks (Self_ID)); + + if Self_ID.Pending_Action then + Do_Pending_Action (Self_ID); + end if; + end if; + end Abort_Undefer; + + ---------------------- + -- Update_Exception -- + ---------------------- + + -- Call only when holding no locks + + procedure Update_Exception + (X : AE.Exception_Occurrence := SSL.Current_Target_Exception) + is + Self_Id : constant Task_Id := Self; + use Ada.Exceptions; + + begin + Save_Occurrence (Self_Id.Common.Compiler_Data.Current_Excep, X); + + if Self_Id.Deferral_Level = 0 then + if Self_Id.Pending_Action then + Self_Id.Pending_Action := False; + Self_Id.Deferral_Level := Self_Id.Deferral_Level + 1; + + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_Id); + Self_Id.Pending_Action := False; + Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Self_Id.Deferral_Level := Self_Id.Deferral_Level - 1; + + if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then + if not Self_Id.Aborting then + Self_Id.Aborting := True; + raise Standard'Abort_Signal; + end if; + end if; + end if; + end if; + end Update_Exception; + + -------------------------- + -- Wakeup_Entry_Caller -- + -------------------------- + + -- This is called at the end of service of an entry call, to abort the + -- caller if he is in an abortable part, and to wake up the caller if it + -- is on Entry_Caller_Sleep. It assumes that the call is already off-queue. + + -- (This enforces the rule that a task must be off-queue if its state is + -- Done or Cancelled.) Call it holding the lock of Entry_Call.Self. + + -- Timed_Call or Simple_Call: + -- The caller is waiting on Entry_Caller_Sleep, in + -- Wait_For_Completion, or Wait_For_Completion_With_Timeout. + + -- Conditional_Call: + -- The caller might be in Wait_For_Completion, + -- waiting for a rendezvous (possibly requeued without abort) + -- to complete. + + -- Asynchronous_Call: + -- The caller may be executing in the abortable part o + -- an async. select, or on a time delay, + -- if Entry_Call.State >= Was_Abortable. + + procedure Wakeup_Entry_Caller + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link; + New_State : Entry_Call_State) + is + Caller : constant Task_Id := Entry_Call.Self; + + begin + pragma Debug (Debug.Trace + (Self_ID, "Wakeup_Entry_Caller", 'E', Caller)); + pragma Assert (New_State = Done or else New_State = Cancelled); + + pragma Assert (Caller.Common.State /= Unactivated); + + Entry_Call.State := New_State; + + if Entry_Call.Mode = Asynchronous_Call then + + -- Abort the caller in his abortable part, but do so only if call has + -- been queued abortably. + + if Entry_Call.State >= Was_Abortable or else New_State = Done then + Locked_Abort_To_Level (Self_ID, Caller, Entry_Call.Level - 1); + end if; + + elsif Caller.Common.State = Entry_Caller_Sleep then + Wakeup (Caller, Entry_Caller_Sleep); + end if; + end Wakeup_Entry_Caller; + + ----------------------- + -- Soft-Link Dummies -- + ----------------------- + + -- These are dummies for subprograms that are only needed by certain + -- optional run-time system packages. If they are needed, the soft links + -- will be redirected to the real subprogram by elaboration of the + -- subprogram body where the real subprogram is declared. + + procedure Finalize_Attributes (T : Task_Id) is + pragma Unreferenced (T); + begin + null; + end Finalize_Attributes; + + procedure Initialize_Attributes (T : Task_Id) is + pragma Unreferenced (T); + begin + null; + end Initialize_Attributes; + +begin + Init_RTS; +end System.Tasking.Initialization; diff --git a/gcc/ada/s-tasini.ads b/gcc/ada/s-tasini.ads new file mode 100644 index 000000000..0b2f45092 --- /dev/null +++ b/gcc/ada/s-tasini.ads @@ -0,0 +1,190 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . I N I T I A L I Z A T I O N -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides overall initialization of the tasking portion of the +-- RTS. This package must be elaborated before any tasking features are used. + +package System.Tasking.Initialization is + + procedure Remove_From_All_Tasks_List (T : Task_Id); + -- Remove T from All_Tasks_List. Call this function with RTS_Lock taken + + --------------------------------- + -- Tasking-Specific Soft Links -- + --------------------------------- + + -- These permit us to leave out certain portions of the tasking + -- run-time system if they are not used. They are only used internally + -- by the tasking run-time system. + + -- So far, the only example is support for Ada.Task_Attributes + + type Proc_T is access procedure (T : Task_Id); + + procedure Finalize_Attributes (T : Task_Id); + procedure Initialize_Attributes (T : Task_Id); + + Finalize_Attributes_Link : Proc_T := Finalize_Attributes'Access; + -- should be called with abort deferred and T.L write-locked + + Initialize_Attributes_Link : Proc_T := Initialize_Attributes'Access; + -- should be called with abort deferred, but holding no locks + + ------------------------- + -- Abort Defer/Undefer -- + ------------------------- + + -- Defer_Abort defers the affects of low-level abort and priority change + -- in the calling task until a matching Undefer_Abort call is executed. + + -- Undefer_Abort DOES MORE than just undo the effects of one call to + -- Defer_Abort. It is the universal "polling point" for deferred + -- processing, including the following: + + -- 1) base priority changes + + -- 2) abort/ATC + + -- Abort deferral MAY be nested (Self_ID.Deferral_Level is a count), but + -- to avoid waste and undetected errors, it generally SHOULD NOT be + -- nested. The symptom of over-deferring abort is that an exception may + -- fail to be raised, or an abort may fail to take place. + + -- Therefore, there are two sets of the inlineable defer/undefer routines, + -- which are the ones to be used inside GNARL. One set allows nesting. The + -- other does not. People who maintain the GNARL should try to avoid using + -- the nested versions, or at least look very critically at the places + -- where they are used. + + -- In general, any GNARL call that is potentially blocking, or whose + -- semantics require that it sometimes raise an exception, or that is + -- required to be an abort completion point, must be made with abort + -- Deferral_Level = 1. + + -- In general, non-blocking GNARL calls, which may be made from inside a + -- protected action, are likely to need to allow nested abort deferral. + + -- With some critical exceptions (which are supposed to be documented), + -- internal calls to the tasking runtime system assume abort is already + -- deferred, and do not modify the deferral level. + + -- There is also a set of non-inlineable defer/undefer routines, for direct + -- call from the compiler. These are not inlineable because they may need + -- to be called via pointers ("soft links"). For the sake of efficiency, + -- the version with Self_ID as parameter should used wherever possible. + -- These are all nestable. + + -- Non-nestable inline versions + + procedure Defer_Abort (Self_ID : Task_Id); + pragma Inline (Defer_Abort); + + procedure Undefer_Abort (Self_ID : Task_Id); + pragma Inline (Undefer_Abort); + + -- Nestable inline versions + + procedure Defer_Abort_Nestable (Self_ID : Task_Id); + pragma Inline (Defer_Abort_Nestable); + + procedure Undefer_Abort_Nestable (Self_ID : Task_Id); + pragma Inline (Undefer_Abort_Nestable); + + procedure Do_Pending_Action (Self_ID : Task_Id); + -- Only call with no locks, and when Self_ID.Pending_Action = True Perform + -- necessary pending actions (e.g. abort, priority change). This procedure + -- is usually called when needed as a result of calling Undefer_Abort, + -- although in the case of e.g. No_Abort restriction, it can be necessary + -- to force execution of pending actions. + + function Check_Abort_Status return Integer; + -- Returns Boolean'Pos (True) iff abort signal should raise + -- Standard.Abort_Signal. Only used by IRIX currently. + + -------------------------- + -- Change Base Priority -- + -------------------------- + + procedure Change_Base_Priority (T : Task_Id); + -- Change the base priority of T. Has to be called with the affected + -- task's ATCB write-locked. May temporarily release the lock. + + ---------------------- + -- Task Lock/Unlock -- + ---------------------- + + procedure Task_Lock (Self_ID : Task_Id); + pragma Inline (Task_Lock); + + procedure Task_Unlock (Self_ID : Task_Id); + pragma Inline (Task_Unlock); + -- These are versions of Lock_Task and Unlock_Task created for use + -- within the GNARL. + + procedure Final_Task_Unlock (Self_ID : Task_Id); + -- This version is only for use in Terminate_Task, when the task is + -- relinquishing further rights to its own ATCB. There is a very + -- interesting potential race condition there, where the old task may run + -- concurrently with a new task that is allocated the old tasks (now + -- reused) ATCB. The critical thing here is to not make any reference to + -- the ATCB after the lock is released. See also comments on + -- Terminate_Task and Unlock. + + procedure Wakeup_Entry_Caller + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link; + New_State : Entry_Call_State); + pragma Inline (Wakeup_Entry_Caller); + -- This is called at the end of service of an entry call, to abort the + -- caller if he is in an abortable part, and to wake up the caller if he + -- is on Entry_Caller_Sleep. Call it holding the lock of Entry_Call.Self. + -- + -- Timed_Call or Simple_Call: + -- The caller is waiting on Entry_Caller_Sleep, in Wait_For_Completion, + -- or Wait_For_Completion_With_Timeout. + -- + -- Conditional_Call: + -- The caller might be in Wait_For_Completion, + -- waiting for a rendezvous (possibly requeued without abort) to + -- complete. + -- + -- Asynchronous_Call: + -- The caller may be executing in the abortable part an async. select, + -- or on a time delay, if Entry_Call.State >= Was_Abortable. + + procedure Locked_Abort_To_Level + (Self_ID : Task_Id; + T : Task_Id; + L : ATC_Level); + pragma Inline (Locked_Abort_To_Level); + -- Abort a task to a specified ATC level. Call this only with T locked + +end System.Tasking.Initialization; diff --git a/gcc/ada/s-taskin.adb b/gcc/ada/s-taskin.adb new file mode 100644 index 000000000..d2d29f924 --- /dev/null +++ b/gcc/ada/s-taskin.adb @@ -0,0 +1,227 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, 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 Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +with Ada.Unchecked_Deallocation; + +with System.Task_Primitives.Operations; +with System.Storage_Elements; + +package body System.Tasking is + + package STPO renames System.Task_Primitives.Operations; + + ---------------------------- + -- Free_Entry_Names_Array -- + ---------------------------- + + procedure Free_Entry_Names_Array (Obj : in out Entry_Names_Array) is + procedure Free_String is new + Ada.Unchecked_Deallocation (String, String_Access); + begin + for Index in Obj'Range loop + Free_String (Obj (Index)); + end loop; + end Free_Entry_Names_Array; + + --------------------- + -- Detect_Blocking -- + --------------------- + + function Detect_Blocking return Boolean is + GL_Detect_Blocking : Integer; + pragma Import (C, GL_Detect_Blocking, "__gl_detect_blocking"); + -- Global variable exported by the binder generated file. A value equal + -- to 1 indicates that pragma Detect_Blocking is active, while 0 is used + -- for the pragma not being present. + + begin + return GL_Detect_Blocking = 1; + end Detect_Blocking; + + ---------- + -- Self -- + ---------- + + function Self return Task_Id renames STPO.Self; + + ------------------ + -- Storage_Size -- + ------------------ + + function Storage_Size (T : Task_Id) return System.Parameters.Size_Type is + begin + return + System.Parameters.Size_Type + (T.Common.Compiler_Data.Pri_Stack_Info.Size); + end Storage_Size; + + --------------------- + -- Initialize_ATCB -- + --------------------- + + procedure Initialize_ATCB + (Self_ID : Task_Id; + Task_Entry_Point : Task_Procedure_Access; + Task_Arg : System.Address; + Parent : Task_Id; + Elaborated : Access_Boolean; + Base_Priority : System.Any_Priority; + Base_CPU : System.Multiprocessors.CPU_Range; + Task_Info : System.Task_Info.Task_Info_Type; + Stack_Size : System.Parameters.Size_Type; + T : Task_Id; + Success : out Boolean) + is + begin + T.Common.State := Unactivated; + + -- Initialize T.Common.LL + + STPO.Initialize_TCB (T, Success); + + if not Success then + return; + end if; + + -- Wouldn't the following be better done using an assignment of an + -- aggregate so that we could be sure no components were forgotten??? + + T.Common.Parent := Parent; + T.Common.Base_Priority := Base_Priority; + T.Common.Base_CPU := Base_CPU; + T.Common.Current_Priority := 0; + T.Common.Protected_Action_Nesting := 0; + T.Common.Call := null; + T.Common.Task_Arg := Task_Arg; + T.Common.Task_Entry_Point := Task_Entry_Point; + T.Common.Activator := Self_ID; + T.Common.Wait_Count := 0; + T.Common.Elaborated := Elaborated; + T.Common.Activation_Failed := False; + T.Common.Task_Info := Task_Info; + T.Common.Global_Task_Lock_Nesting := 0; + T.Common.Fall_Back_Handler := null; + T.Common.Specific_Handler := null; + T.Common.Debug_Events := (others => False); + + if T.Common.Parent = null then + + -- For the environment task, the adjusted stack size is meaningless. + -- For example, an unspecified Stack_Size means that the stack size + -- is determined by the environment, or can grow dynamically. The + -- Stack_Checking algorithm therefore needs to use the requested + -- size, or 0 in case of an unknown size. + + T.Common.Compiler_Data.Pri_Stack_Info.Size := + Storage_Elements.Storage_Offset (Stack_Size); + + else + T.Common.Compiler_Data.Pri_Stack_Info.Size := + Storage_Elements.Storage_Offset + (Parameters.Adjust_Storage_Size (Stack_Size)); + end if; + + -- Link the task into the list of all tasks + + T.Common.All_Tasks_Link := All_Tasks_List; + All_Tasks_List := T; + end Initialize_ATCB; + + ---------------- + -- Initialize -- + ---------------- + + Main_Task_Image : constant String := "main_task"; + -- Image of environment task + + Main_Priority : Integer; + pragma Import (C, Main_Priority, "__gl_main_priority"); + -- Priority for main task. Note that this is of type Integer, not Priority, + -- because we use the value -1 to indicate the default main priority, and + -- that is of course not in Priority'range. + + Main_CPU : Integer; + pragma Import (C, Main_CPU, "__gl_main_cpu"); + -- Affinity for main task. Note that this is of type Integer, not + -- CPU_Range, because we use the value -1 to indicate the unassigned + -- affinity, and that is of course not in CPU_Range'Range. + + Initialized : Boolean := False; + -- Used to prevent multiple calls to Initialize + + procedure Initialize is + T : Task_Id; + Base_Priority : Any_Priority; + Base_CPU : System.Multiprocessors.CPU_Range; + Success : Boolean; + + begin + if Initialized then + return; + end if; + + Initialized := True; + + -- Initialize Environment Task + + Base_Priority := + (if Main_Priority = Unspecified_Priority + then Default_Priority + else Priority (Main_Priority)); + + Base_CPU := + (if Main_CPU = Unspecified_CPU + then System.Multiprocessors.Not_A_Specific_CPU + else System.Multiprocessors.CPU_Range (Main_CPU)); + + T := STPO.New_ATCB (0); + Initialize_ATCB + (null, null, Null_Address, Null_Task, null, Base_Priority, Base_CPU, + Task_Info.Unspecified_Task_Info, 0, T, Success); + pragma Assert (Success); + + STPO.Initialize (T); + STPO.Set_Priority (T, T.Common.Base_Priority); + T.Common.State := Runnable; + T.Common.Task_Image_Len := Main_Task_Image'Length; + T.Common.Task_Image (Main_Task_Image'Range) := Main_Task_Image; + + -- Only initialize the first element since others are not relevant + -- in ravenscar mode. Rest of the initialization is done in Init_RTS. + + T.Entry_Calls (1).Self := T; + end Initialize; + +end System.Tasking; diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads new file mode 100644 index 000000000..4841d0b8b --- /dev/null +++ b/gcc/ada/s-taskin.ads @@ -0,0 +1,1130 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2010, 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 necessary type definitions for compiler interface + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +with Ada.Exceptions; +with Ada.Unchecked_Conversion; + +with System.Parameters; +with System.Task_Info; +with System.Soft_Links; +with System.Task_Primitives; +with System.Stack_Usage; +with System.Multiprocessors; + +package System.Tasking is + pragma Preelaborate; + + ------------------- + -- Locking Rules -- + ------------------- + + -- The following rules must be followed at all times, to prevent + -- deadlock and generally ensure correct operation of locking. + + -- Never lock a lock unless abort is deferred + + -- Never undefer abort while holding a lock + + -- Overlapping critical sections must be properly nested, and locks must + -- be released in LIFO order. E.g., the following is not allowed: + + -- Lock (X); + -- ... + -- Lock (Y); + -- ... + -- Unlock (X); + -- ... + -- Unlock (Y); + + -- Locks with lower (smaller) level number cannot be locked + -- while holding a lock with a higher level number. (The level + + -- 1. System.Tasking.PO_Simple.Protection.L (any PO lock) + -- 2. System.Tasking.Initialization.Global_Task_Lock (in body) + -- 3. System.Task_Primitives.Operations.Single_RTS_Lock + -- 4. System.Tasking.Ada_Task_Control_Block.LL.L (any TCB lock) + + -- Clearly, there can be no circular chain of hold-and-wait + -- relationships involving locks in different ordering levels. + + -- We used to have Global_Task_Lock before Protection.L but this was + -- clearly wrong since there can be calls to "new" inside protected + -- operations. The new ordering prevents these failures. + + -- Sometimes we need to hold two ATCB locks at the same time. To allow us + -- to order the locking, each ATCB is given a unique serial number. If one + -- needs to hold locks on several ATCBs at once, the locks with lower + -- serial numbers must be locked first. + + -- We don't always need to check the serial numbers, since the serial + -- numbers are assigned sequentially, and so: + + -- . The parent of a task always has a lower serial number. + -- . The activator of a task always has a lower serial number. + -- . The environment task has a lower serial number than any other task. + -- . If the activator of a task is different from the task's parent, + -- the parent always has a lower serial number than the activator. + + --------------------------------- + -- Task_Id related definitions -- + --------------------------------- + + type Ada_Task_Control_Block; + + type Task_Id is access all Ada_Task_Control_Block; + for Task_Id'Size use System.Task_Primitives.Task_Address_Size; + + Null_Task : constant Task_Id; + + type Task_List is array (Positive range <>) of Task_Id; + + function Self return Task_Id; + pragma Inline (Self); + -- This is the compiler interface version of this function. Do not call + -- from the run-time system. + + function To_Task_Id is + new Ada.Unchecked_Conversion + (System.Task_Primitives.Task_Address, Task_Id); + function To_Address is + new Ada.Unchecked_Conversion + (Task_Id, System.Task_Primitives.Task_Address); + + ----------------------- + -- Enumeration types -- + ----------------------- + + type Task_States is + (Unactivated, + -- TCB initialized but not task has not been created. + -- It cannot be executing. + +-- Activating, +-- -- ??? Temporarily at end of list for GDB compatibility +-- -- Task has been created and is being made Runnable. + + -- Active states + -- For all states from here down, the task has been activated. + -- For all states from here down, except for Terminated, the task + -- may be executing. + -- Activator = null iff it has not yet completed activating. + + Runnable, + -- Task is not blocked for any reason known to Ada. + -- (It may be waiting for a mutex, though.) + -- It is conceptually "executing" in normal mode. + + Terminated, + -- The task is terminated, in the sense of ARM 9.3 (5). + -- Any dependents that were waiting on terminate + -- alternatives have been awakened and have terminated themselves. + + Activator_Sleep, + -- Task is waiting for created tasks to complete activation + + Acceptor_Sleep, + -- Task is waiting on an accept or select with terminate + +-- Acceptor_Delay_Sleep, +-- -- ??? Temporarily at end of list for GDB compatibility +-- -- Task is waiting on an selective wait statement + + Entry_Caller_Sleep, + -- Task is waiting on an entry call + + Async_Select_Sleep, + -- Task is waiting to start the abortable part of an + -- asynchronous select statement. + + Delay_Sleep, + -- Task is waiting on a select statement with only a delay + -- alternative open. + + Master_Completion_Sleep, + -- Master completion has two phases. + -- In Phase 1 the task is sleeping in Complete_Master + -- having completed a master within itself, + -- and is waiting for the tasks dependent on that master to become + -- terminated or waiting on a terminate Phase. + + Master_Phase_2_Sleep, + -- In Phase 2 the task is sleeping in Complete_Master + -- waiting for tasks on terminate alternatives to finish + -- terminating. + + -- The following are special uses of sleep, for server tasks + -- within the run-time system. + + Interrupt_Server_Idle_Sleep, + Interrupt_Server_Blocked_Interrupt_Sleep, + Timer_Server_Sleep, + AST_Server_Sleep, + + Asynchronous_Hold, + -- The task has been held by Asynchronous_Task_Control.Hold_Task + + Interrupt_Server_Blocked_On_Event_Flag, + -- The task has been blocked on a system call waiting for a + -- completion event/signal to occur. + + Activating, + -- Task has been created and is being made Runnable + + Acceptor_Delay_Sleep + -- Task is waiting on an selective wait statement + ); + + type Call_Modes is + (Simple_Call, Conditional_Call, Asynchronous_Call, Timed_Call); + + type Select_Modes is (Simple_Mode, Else_Mode, Terminate_Mode, Delay_Mode); + + subtype Delay_Modes is Integer; + + ------------------------------- + -- Entry related definitions -- + ------------------------------- + + Null_Entry : constant := 0; + + Max_Entry : constant := Integer'Last; + + Interrupt_Entry : constant := -2; + + Cancelled_Entry : constant := -1; + + type Entry_Index is range Interrupt_Entry .. Max_Entry; + + Null_Task_Entry : constant := Null_Entry; + + Max_Task_Entry : constant := Max_Entry; + + type Task_Entry_Index is new Entry_Index + range Null_Task_Entry .. Max_Task_Entry; + + type Entry_Call_Record; + + type Entry_Call_Link is access all Entry_Call_Record; + + type Entry_Queue is record + Head : Entry_Call_Link; + Tail : Entry_Call_Link; + end record; + + type Task_Entry_Queue_Array is + array (Task_Entry_Index range <>) of Entry_Queue; + + -- A data structure which contains the string names of entries and entry + -- family members. + + type String_Access is access all String; + + type Entry_Names_Array is + array (Entry_Index range <>) of String_Access; + + type Entry_Names_Array_Access is access all Entry_Names_Array; + + procedure Free_Entry_Names_Array (Obj : in out Entry_Names_Array); + -- Deallocate all string names contained in an entry names array + + ---------------------------------- + -- Entry_Call_Record definition -- + ---------------------------------- + + type Entry_Call_State is + (Never_Abortable, + -- the call is not abortable, and never can be + + Not_Yet_Abortable, + -- the call is not abortable, but may become so + + Was_Abortable, + -- the call is not abortable, but once was + + Now_Abortable, + -- the call is abortable + + Done, + -- the call has been completed + + Cancelled + -- the call was asynchronous, and was cancelled + ); + pragma Ordered (Entry_Call_State); + + -- Never_Abortable is used for calls that are made in a abort deferred + -- region (see ARM 9.8(5-11), 9.8 (20)). Such a call is never abortable. + + -- The Was_ vs. Not_Yet_ distinction is needed to decide whether it is OK + -- to advance into the abortable part of an async. select stmt. That is + -- allowed iff the mode is Now_ or Was_. + + -- Done indicates the call has been completed, without cancellation, or no + -- call has been made yet at this ATC nesting level, and so aborting the + -- call is no longer an issue. Completion of the call does not necessarily + -- indicate "success"; the call may be returning an exception if + -- Exception_To_Raise is non-null. + + -- Cancelled indicates the call was cancelled, and so aborting the call is + -- no longer an issue. + + -- The call is on an entry queue unless State >= Done, in which case it may + -- or may not be still Onqueue. + + -- Please do not modify the order of the values, without checking all uses + -- of this type. We rely on partial "monotonicity" of + -- Entry_Call_Record.State to avoid locking when we access this value for + -- certain tests. In particular: + + -- 1) Once State >= Done, we can rely that the call has been + -- completed. If State >= Done, it will not + -- change until the task does another entry call at this level. + + -- 2) Once State >= Was_Abortable, we can rely that the call has + -- been queued abortably at least once, and so the check for + -- whether it is OK to advance to the abortable part of an + -- async. select statement does not need to lock anything. + + type Restricted_Entry_Call_Record is record + Self : Task_Id; + -- ID of the caller + + Mode : Call_Modes; + + State : Entry_Call_State; + pragma Atomic (State); + -- Indicates part of the state of the call. + -- + -- Protection: If the call is not on a queue, it should only be + -- accessed by Self, and Self does not need any lock to modify this + -- field. + -- + -- Once the call is on a queue, the value should be something other + -- than Done unless it is cancelled, and access is controller by the + -- "server" of the queue -- i.e., the lock of Checked_To_Protection + -- (Call_Target) if the call record is on the queue of a PO, or the + -- lock of Called_Target if the call is on the queue of a task. See + -- comments on type declaration for more details. + + Uninterpreted_Data : System.Address; + -- Data passed by the compiler + + Exception_To_Raise : Ada.Exceptions.Exception_Id; + -- The exception to raise once this call has been completed without + -- being aborted. + end record; + pragma Suppress_Initialization (Restricted_Entry_Call_Record); + + ------------------------------------------- + -- Task termination procedure definition -- + ------------------------------------------- + + -- We need to redefine here these types (already defined in + -- Ada.Task_Termination) for avoiding circular dependencies. + + type Cause_Of_Termination is (Normal, Abnormal, Unhandled_Exception); + -- Possible causes for task termination: + -- + -- Normal means that the task terminates due to completing the + -- last sentence of its body, or as a result of waiting on a + -- terminate alternative. + + -- Abnormal means that the task terminates because it is being aborted + + -- handled_Exception means that the task terminates because of exception + -- raised by the execution of its task_body. + + type Termination_Handler is access protected procedure + (Cause : Cause_Of_Termination; + T : Task_Id; + X : Ada.Exceptions.Exception_Occurrence); + -- Used to represent protected procedures to be executed when task + -- terminates. + + ------------------------------------ + -- Task related other definitions -- + ------------------------------------ + + type Activation_Chain is limited private; + -- Linked list of to-be-activated tasks, linked through + -- Activation_Link. The order of tasks on the list is irrelevant, because + -- the priority rules will ensure that they actually start activating in + -- priority order. + + type Activation_Chain_Access is access all Activation_Chain; + + type Task_Procedure_Access is access procedure (Arg : System.Address); + + type Access_Boolean is access all Boolean; + + function Detect_Blocking return Boolean; + pragma Inline (Detect_Blocking); + -- Return whether the Detect_Blocking pragma is enabled + + function Storage_Size (T : Task_Id) return System.Parameters.Size_Type; + -- Retrieve from the TCB of the task the allocated size of its stack, + -- either the system default or the size specified by a pragma. This + -- is in general a non-static value that can depend on discriminants + -- of the task. + + type Bit_Array is array (Integer range <>) of Boolean; + pragma Pack (Bit_Array); + + subtype Debug_Event_Array is Bit_Array (1 .. 16); + + Global_Task_Debug_Event_Set : Boolean := False; + -- Set True when running under debugger control and a task debug + -- event signal has been requested. + + ---------------------------------------------- + -- Ada_Task_Control_Block (ATCB) definition -- + ---------------------------------------------- + + -- Notes on protection (synchronization) of TRTS data structures + + -- Any field of the TCB can be written by the activator of a task when the + -- task is created, since no other task can access the new task's + -- state until creation is complete. + + -- The protection for each field is described in a comment starting with + -- "Protection:". + + -- When a lock is used to protect an ATCB field, this lock is simply named + + -- Some protection is described in terms of tasks related to the + -- ATCB being protected. These are: + + -- Self: The task which is controlled by this ATCB + -- Acceptor: A task accepting a call from Self + -- Caller: A task calling an entry of Self + -- Parent: The task executing the master on which Self depends + -- Dependent: A task dependent on Self + -- Activator: The task that created Self and initiated its activation + -- Created: A task created and activated by Self + + -- Note: The order of the fields is important to implement efficiently + -- tasking support under gdb. + -- Currently gdb relies on the order of the State, Parent, Base_Priority, + -- Task_Image, Task_Image_Len, Call and LL fields. + + ------------------------- + -- Common ATCB section -- + ------------------------- + + -- Section used by all GNARL implementations (regular and restricted) + + type Common_ATCB is record + State : Task_States; + pragma Atomic (State); + -- Encodes some basic information about the state of a task, + -- including whether it has been activated, whether it is sleeping, + -- and whether it is terminated. + -- + -- Protection: Self.L + + Parent : Task_Id; + -- The task on which this task depends. + -- See also Master_Level and Master_Within. + + Base_Priority : System.Any_Priority; + -- Base priority, not changed during entry calls, only changed + -- via dynamic priorities package. + -- + -- Protection: Only written by Self, accessed by anyone + + Base_CPU : System.Multiprocessors.CPU_Range; + -- Base CPU, only changed via dispatching domains package. + -- + -- Protection: Self.L + + Current_Priority : System.Any_Priority; + -- Active priority, except that the effects of protected object + -- priority ceilings are not reflected. This only reflects explicit + -- priority changes and priority inherited through task activation + -- and rendezvous. + -- + -- Ada 95 notes: In Ada 95, this field will be transferred to the + -- Priority field of an Entry_Calls component when an entry call is + -- initiated. The Priority of the Entry_Calls component will not change + -- for the duration of the call. The accepting task can use it to boost + -- its own priority without fear of its changing in the meantime. + -- + -- This can safely be used in the priority ordering of entry queues. + -- Once a call is queued, its priority does not change. + -- + -- Since an entry call cannot be made while executing a protected + -- action, the priority of a task will never reflect a priority ceiling + -- change at the point of an entry call. + -- + -- Protection: Only written by Self, and only accessed when Acceptor + -- accepts an entry or when Created activates, at which points Self is + -- suspended. + + Protected_Action_Nesting : Natural; + pragma Atomic (Protected_Action_Nesting); + -- The dynamic level of protected action nesting for this task. This + -- field is needed for checking whether potentially blocking operations + -- are invoked from protected actions. pragma Atomic is used because it + -- can be read/written from protected interrupt handlers. + + Task_Image : String (1 .. System.Parameters.Max_Task_Image_Length); + -- Hold a string that provides a readable id for task, built from the + -- variable of which it is a value or component. + + Task_Image_Len : Natural; + -- Actual length of Task_Image + + Call : Entry_Call_Link; + -- The entry call that has been accepted by this task. + -- + -- Protection: Self.L. Self will modify this field when Self.Accepting + -- is False, and will not need the mutex to do so. Once a task sets + -- Pending_ATC_Level = 0, no other task can access this field. + + LL : aliased Task_Primitives.Private_Data; + -- Control block used by the underlying low-level tasking service + -- (GNULLI). + -- + -- Protection: This is used only by the GNULLI implementation, which + -- takes care of all of its synchronization. + + Task_Arg : System.Address; + -- The argument to task procedure. Provide a handle for discriminant + -- information. + -- + -- Protection: Part of the synchronization between Self and Activator. + -- Activator writes it, once, before Self starts executing. Thereafter, + -- Self only reads it. + + Task_Alternate_Stack : System.Address; + -- The address of the alternate signal stack for this task, if any + -- + -- Protection: Only accessed by Self + + Task_Entry_Point : Task_Procedure_Access; + -- Information needed to call the procedure containing the code for + -- the body of this task. + -- + -- Protection: Part of the synchronization between Self and Activator. + -- Activator writes it, once, before Self starts executing. Self reads + -- it, once, as part of its execution. + + Compiler_Data : System.Soft_Links.TSD; + -- Task-specific data needed by the compiler to store per-task + -- structures. + -- + -- Protection: Only accessed by Self + + All_Tasks_Link : Task_Id; + -- Used to link this task to the list of all tasks in the system + -- + -- Protection: RTS_Lock + + Activation_Link : Task_Id; + -- Used to link this task to a list of tasks to be activated + -- + -- Protection: Only used by Activator + + Activator : Task_Id; + -- The task that created this task, either by declaring it as a task + -- object or by executing a task allocator. The value is null iff Self + -- has completed activation. + -- + -- Protection: Set by Activator before Self is activated, and only read + -- and modified by Self after that. + + Wait_Count : Integer; + -- This count is used by a task that is waiting for other tasks. At all + -- other times, the value should be zero. It is used differently in + -- several different states. Since a task cannot be in more than one of + -- these states at the same time, a single counter suffices. + -- + -- Protection: Self.L + + -- Activator_Sleep + + -- This is the number of tasks that this task is activating, i.e. the + -- children that have started activation but have not completed it. + -- + -- Protection: Self.L and Created.L. Both mutexes must be locked, since + -- Self.Activation_Count and Created.State must be synchronized. + + -- Master_Completion_Sleep (phase 1) + + -- This is the number dependent tasks of a master being completed by + -- Self that are not activated, not terminated, and not waiting on a + -- terminate alternative. + + -- Master_Completion_2_Sleep (phase 2) + + -- This is the count of tasks dependent on a master being completed by + -- Self which are waiting on a terminate alternative. + + Elaborated : Access_Boolean; + -- Pointer to a flag indicating that this task's body has been + -- elaborated. The flag is created and managed by the + -- compiler-generated code. + -- + -- Protection: The field itself is only accessed by Activator. The flag + -- that it points to is updated by Master and read by Activator; access + -- is assumed to be atomic. + + Activation_Failed : Boolean; + -- Set to True if activation of a chain of tasks fails, + -- so that the activator should raise Tasking_Error. + + Task_Info : System.Task_Info.Task_Info_Type; + -- System-specific attributes of the task as specified by the + -- Task_Info pragma. + + Analyzer : System.Stack_Usage.Stack_Analyzer; + -- For storing informations used to measure the stack usage + + Global_Task_Lock_Nesting : Natural; + -- This is the current nesting level of calls to + -- System.Tasking.Initialization.Lock_Task. This allows a task to call + -- Lock_Task multiple times without deadlocking. A task only locks + -- Global_Task_Lock when its Global_Task_Lock_Nesting goes from 0 to 1, + -- and only unlocked when it goes from 1 to 0. + -- + -- Protection: Only accessed by Self + + Fall_Back_Handler : Termination_Handler; + -- This is the fall-back handler that applies to the dependent tasks of + -- the task. + -- + -- Protection: Self.L + + Specific_Handler : Termination_Handler; + -- This is the specific handler that applies only to this task, and not + -- any of its dependent tasks. + -- + -- Protection: Self.L + + Debug_Events : Debug_Event_Array; + -- Word length array of per task debug events, of which 11 kinds are + -- currently defined in System.Tasking.Debugging package. + end record; + + --------------------------------------- + -- Restricted_Ada_Task_Control_Block -- + --------------------------------------- + + -- This type should only be used by the restricted GNARLI and by restricted + -- GNULL implementations to allocate an ATCB (see System.Task_Primitives. + -- Operations.New_ATCB) that will take significantly less memory. + + -- Note that the restricted GNARLI should only access fields that are + -- present in the Restricted_Ada_Task_Control_Block structure. + + type Restricted_Ada_Task_Control_Block (Entry_Num : Task_Entry_Index) is + record + Common : Common_ATCB; + -- The common part between various tasking implementations + + Entry_Call : aliased Restricted_Entry_Call_Record; + -- Protection: This field is used on entry call "queues" associated + -- with protected objects, and is protected by the protected object + -- lock. + end record; + pragma Suppress_Initialization (Restricted_Ada_Task_Control_Block); + + Interrupt_Manager_ID : Task_Id; + -- This task ID is declared here to break circular dependencies. + -- Also declare Interrupt_Manager_ID after Task_Id is known, to avoid + -- generating unneeded finalization code. + + ----------------------- + -- List of all Tasks -- + ----------------------- + + All_Tasks_List : Task_Id; + -- Global linked list of all tasks + + ------------------------------------------ + -- Regular (non restricted) definitions -- + ------------------------------------------ + + -------------------------------- + -- Master Related Definitions -- + -------------------------------- + + subtype Master_Level is Integer; + subtype Master_ID is Master_Level; + + -- Normally, a task starts out with internal master nesting level one + -- larger than external master nesting level. It is incremented to one by + -- Enter_Master, which is called in the task body only if the compiler + -- thinks the task may have dependent tasks. It is set to 1 for the + -- environment task, the level 2 is reserved for server tasks of the + -- run-time system (the so called "independent tasks"), and the level 3 is + -- for the library level tasks. Foreign threads which are detected by + -- the run-time have a level of 0, allowing these tasks to be easily + -- distinguished if needed. + + Foreign_Task_Level : constant Master_Level := 0; + Environment_Task_Level : constant Master_Level := 1; + Independent_Task_Level : constant Master_Level := 2; + Library_Task_Level : constant Master_Level := 3; + + ------------------- + -- Priority info -- + ------------------- + + Unspecified_Priority : constant Integer := System.Priority'First - 1; + + Priority_Not_Boosted : constant Integer := System.Priority'First - 1; + -- Definition of Priority actually has to come from the RTS configuration + + subtype Rendezvous_Priority is Integer + range Priority_Not_Boosted .. System.Any_Priority'Last; + + ------------------- + -- Affinity info -- + ------------------- + + Unspecified_CPU : constant := -1; + -- No affinity specified + + ------------------------------------ + -- Rendezvous related definitions -- + ------------------------------------ + + No_Rendezvous : constant := 0; + + Max_Select : constant Integer := Integer'Last; + -- RTS-defined + + subtype Select_Index is Integer range No_Rendezvous .. Max_Select; + -- type Select_Index is range No_Rendezvous .. Max_Select; + + subtype Positive_Select_Index is + Select_Index range 1 .. Select_Index'Last; + + type Accept_Alternative is record + Null_Body : Boolean; + S : Task_Entry_Index; + end record; + + type Accept_List is + array (Positive_Select_Index range <>) of Accept_Alternative; + + type Accept_List_Access is access constant Accept_List; + + ----------------------------------- + -- ATC_Level related definitions -- + ----------------------------------- + + Max_ATC_Nesting : constant Natural := 20; + + subtype ATC_Level_Base is Integer range 0 .. Max_ATC_Nesting; + + ATC_Level_Infinity : constant ATC_Level_Base := ATC_Level_Base'Last; + + subtype ATC_Level is ATC_Level_Base range 0 .. ATC_Level_Base'Last - 1; + + subtype ATC_Level_Index is ATC_Level range 1 .. ATC_Level'Last; + + ---------------------------------- + -- Entry_Call_Record definition -- + ---------------------------------- + + type Entry_Call_Record is record + Self : Task_Id; + -- ID of the caller + + Mode : Call_Modes; + + State : Entry_Call_State; + pragma Atomic (State); + -- Indicates part of the state of the call + -- + -- Protection: If the call is not on a queue, it should only be + -- accessed by Self, and Self does not need any lock to modify this + -- field. Once the call is on a queue, the value should be something + -- other than Done unless it is cancelled, and access is controller by + -- the "server" of the queue -- i.e., the lock of Checked_To_Protection + -- (Call_Target) if the call record is on the queue of a PO, or the + -- lock of Called_Target if the call is on the queue of a task. See + -- comments on type declaration for more details. + + Uninterpreted_Data : System.Address; + -- Data passed by the compiler + + Exception_To_Raise : Ada.Exceptions.Exception_Id; + -- The exception to raise once this call has been completed without + -- being aborted. + + Prev : Entry_Call_Link; + + Next : Entry_Call_Link; + + Level : ATC_Level; + -- One of Self and Level are redundant in this implementation, since + -- each Entry_Call_Record is at Self.Entry_Calls (Level). Since we must + -- have access to the entry call record to be reading this, we could + -- get Self from Level, or Level from Self. However, this requires + -- non-portable address arithmetic. + + E : Entry_Index; + + Prio : System.Any_Priority; + + -- The above fields are those that there may be some hope of packing. + -- They are gathered together to allow for compilers that lay records + -- out contiguously, to allow for such packing. + + Called_Task : Task_Id; + pragma Atomic (Called_Task); + -- Use for task entry calls. The value is null if the call record is + -- not in use. Conversely, unless State is Done and Onqueue is false, + -- Called_Task points to an ATCB. + -- + -- Protection: Called_Task.L + + Called_PO : System.Address; + pragma Atomic (Called_PO); + -- Similar to Called_Task but for protected objects + -- + -- Note that the previous implementation tried to merge both + -- Called_Task and Called_PO but this ended up in many unexpected + -- complications (e.g having to add a magic number in the ATCB, which + -- caused gdb lots of confusion) with no real gain since the + -- Lock_Server implementation still need to loop around chasing for + -- pointer changes even with a single pointer. + + Acceptor_Prev_Call : Entry_Call_Link; + -- For task entry calls only + + Acceptor_Prev_Priority : Rendezvous_Priority := Priority_Not_Boosted; + -- For task entry calls only. The priority of the most recent prior + -- call being serviced. For protected entry calls, this function should + -- be performed by GNULLI ceiling locking. + + Cancellation_Attempted : Boolean := False; + pragma Atomic (Cancellation_Attempted); + -- Cancellation of the call has been attempted. + -- Consider merging this into State??? + + With_Abort : Boolean := False; + -- Tell caller whether the call may be aborted + -- ??? consider merging this with Was_Abortable state + + Needs_Requeue : Boolean := False; + -- Temporary to tell acceptor of task entry call that + -- Exceptional_Complete_Rendezvous needs to do requeue. + end record; + + ------------------------------------ + -- Task related other definitions -- + ------------------------------------ + + type Access_Address is access all System.Address; + -- Anonymous pointer used to implement task attributes (see s-tataat.adb + -- and a-tasatt.adb) + + pragma No_Strict_Aliasing (Access_Address); + -- This type is used in contexts where aliasing may be an issue (see + -- for example s-tataat.adb), so we avoid any incorrect aliasing + -- assumptions. + + ---------------------------------------------- + -- Ada_Task_Control_Block (ATCB) definition -- + ---------------------------------------------- + + type Entry_Call_Array is array (ATC_Level_Index) of + aliased Entry_Call_Record; + + type Direct_Index is range 0 .. Parameters.Default_Attribute_Count; + subtype Direct_Index_Range is Direct_Index range 1 .. Direct_Index'Last; + -- Attributes with indexes in this range are stored directly in the task + -- control block. Such attributes must be Address-sized. Other attributes + -- will be held in dynamically allocated records chained off of the task + -- control block. + + type Direct_Attribute_Element is mod Memory_Size; + pragma Atomic (Direct_Attribute_Element); + + type Direct_Attribute_Array is + array (Direct_Index_Range) of aliased Direct_Attribute_Element; + + type Direct_Index_Vector is mod 2 ** Parameters.Default_Attribute_Count; + -- This is a bit-vector type, used to store information about + -- the usage of the direct attribute fields. + + type Task_Serial_Number is mod 2 ** 64; + -- Used to give each task a unique serial number + + type Ada_Task_Control_Block (Entry_Num : Task_Entry_Index) is record + Common : Common_ATCB; + -- The common part between various tasking implementations + + Entry_Calls : Entry_Call_Array; + -- An array of entry calls + -- + -- Protection: The elements of this array are on entry call queues + -- associated with protected objects or task entries, and are protected + -- by the protected object lock or Acceptor.L, respectively. + + Entry_Names : Entry_Names_Array_Access := null; + -- An array of string names which denotes entry [family member] names. + -- The structure is indexed by task entry index and contains Entry_Num + -- components. + + New_Base_Priority : System.Any_Priority; + -- New value for Base_Priority (for dynamic priorities package) + -- + -- Protection: Self.L + + Open_Accepts : Accept_List_Access; + -- This points to the Open_Accepts array of accept alternatives passed + -- to the RTS by the compiler-generated code to Selective_Wait. It is + -- non-null iff this task is ready to accept an entry call. + -- + -- Protection: Self.L + + Chosen_Index : Select_Index; + -- The index in Open_Accepts of the entry call accepted by a selective + -- wait executed by this task. + -- + -- Protection: Written by both Self and Caller. Usually protected by + -- Self.L. However, once the selection is known to have been written it + -- can be accessed without protection. This happens after Self has + -- updated it itself using information from a suspended Caller, or + -- after Caller has updated it and awakened Self. + + Master_of_Task : Master_Level; + -- The task executing the master of this task, and the ID of this task's + -- master (unique only among masters currently active within Parent). + -- + -- Protection: Set by Activator before Self is activated, and read + -- after Self is activated. + + Master_Within : Master_Level; + -- The ID of the master currently executing within this task; that is, + -- the most deeply nested currently active master. + -- + -- Protection: Only written by Self, and only read by Self or by + -- dependents when Self is attempting to exit a master. Since Self will + -- not write this field until the master is complete, the + -- synchronization should be adequate to prevent races. + + Alive_Count : Integer := 0; + -- Number of tasks directly dependent on this task (including itself) + -- that are still "alive", i.e. not terminated. + -- + -- Protection: Self.L + + Awake_Count : Integer := 0; + -- Number of tasks directly dependent on this task (including itself) + -- still "awake", i.e., are not terminated and not waiting on a + -- terminate alternative. + -- + -- Invariant: Awake_Count <= Alive_Count + + -- Protection: Self.L + + -- Beginning of flags + + Aborting : Boolean := False; + pragma Atomic (Aborting); + -- Self is in the process of aborting. While set, prevents multiple + -- abort signals from being sent by different aborter while abort + -- is acted upon. This is essential since an aborter which calls + -- Abort_To_Level could set the Pending_ATC_Level to yet a lower level + -- (than the current level), may be preempted and would send the + -- abort signal when resuming execution. At this point, the abortee + -- may have completed abort to the proper level such that the + -- signal (and resulting abort exception) are not handled any more. + -- In other words, the flag prevents a race between multiple aborters + -- + -- Protection: protected by atomic access. + + ATC_Hack : Boolean := False; + pragma Atomic (ATC_Hack); + -- ????? + -- Temporary fix, to allow Undefer_Abort to reset Aborting in the + -- handler for Abort_Signal that encloses an async. entry call. + -- For the longer term, this should be done via code in the + -- handler itself. + + Callable : Boolean := True; + -- It is OK to call entries of this task + + Dependents_Aborted : Boolean := False; + -- This is set to True by whichever task takes responsibility for + -- aborting the dependents of this task. + -- + -- Protection: Self.L + + Interrupt_Entry : Boolean := False; + -- Indicates if one or more Interrupt Entries are attached to the task. + -- This flag is needed for cleaning up the Interrupt Entry bindings. + + Pending_Action : Boolean := False; + -- Unified flag indicating some action needs to be take when abort + -- next becomes undeferred. Currently set if: + -- . Pending_Priority_Change is set + -- . Pending_ATC_Level is changed + -- . Requeue involving POs + -- (Abortable field may have changed and the Wait_Until_Abortable + -- has to recheck the abortable status of the call.) + -- . Exception_To_Raise is non-null + -- + -- Protection: Self.L + -- + -- This should never be reset back to False outside of the procedure + -- Do_Pending_Action, which is called by Undefer_Abort. It should only + -- be set to True by Set_Priority and Abort_To_Level. + + Pending_Priority_Change : Boolean := False; + -- Flag to indicate pending priority change (for dynamic priorities + -- package). The base priority is updated on the next abort + -- completion point (aka. synchronization point). + -- + -- Protection: Self.L + + Terminate_Alternative : Boolean := False; + -- Task is accepting Select with Terminate Alternative + -- + -- Protection: Self.L + + -- End of flags + + -- Beginning of counts + + ATC_Nesting_Level : ATC_Level := 1; + -- The dynamic level of ATC nesting (currently executing nested + -- asynchronous select statements) in this task. + + -- Protection: Self_ID.L. Only Self reads or updates this field. + -- Decrementing it deallocates an Entry_Calls component, and care must + -- be taken that all references to that component are eliminated before + -- doing the decrement. This in turn will require locking a protected + -- object (for a protected entry call) or the Acceptor's lock (for a + -- task entry call). No other task should attempt to read or modify + -- this value. + + Deferral_Level : Natural := 1; + -- This is the number of times that Defer_Abort has been called by + -- this task without a matching Undefer_Abort call. Abortion is only + -- allowed when this zero. It is initially 1, to protect the task at + -- startup. + + -- Protection: Only updated by Self; access assumed to be atomic + + Pending_ATC_Level : ATC_Level_Base := ATC_Level_Infinity; + -- The ATC level to which this task is currently being aborted. If the + -- value is zero, the entire task has "completed". That may be via + -- abort, exception propagation, or normal exit. If the value is + -- ATC_Level_Infinity, the task is not being aborted to any level. If + -- the value is positive, the task has not completed. This should ONLY + -- be modified by Abort_To_Level and Exit_One_ATC_Level. + -- + -- Protection: Self.L + + Serial_Number : Task_Serial_Number; + -- A growing number to provide some way to check locking rules/ordering + + Known_Tasks_Index : Integer := -1; + -- Index in the System.Tasking.Debug.Known_Tasks array + + User_State : Long_Integer := 0; + -- User-writeable location, for use in debugging tasks; also provides a + -- simple task specific data. + + Direct_Attributes : Direct_Attribute_Array; + -- For task attributes that have same size as Address + + Is_Defined : Direct_Index_Vector := 0; + -- Bit I is 1 iff Direct_Attributes (I) is defined + + Indirect_Attributes : Access_Address; + -- A pointer to chain of records for other attributes that are not + -- address-sized, including all tagged types. + + Entry_Queues : Task_Entry_Queue_Array (1 .. Entry_Num); + -- An array of task entry queues + -- + -- Protection: Self.L. Once a task has set Self.Stage to Completing, it + -- has exclusive access to this field. + end record; + + -------------------- + -- Initialization -- + -------------------- + + procedure Initialize; + -- This procedure constitutes the first part of the initialization of the + -- GNARL. This includes creating data structures to make the initial thread + -- into the environment task. The last part of the initialization is done + -- in System.Tasking.Initialization or System.Tasking.Restricted.Stages. + -- All the initializations used to be in Tasking.Initialization, but this + -- is no longer possible with the run time simplification (including + -- optimized PO and the restricted run time) since one cannot rely on + -- System.Tasking.Initialization being present, as was done before. + + procedure Initialize_ATCB + (Self_ID : Task_Id; + Task_Entry_Point : Task_Procedure_Access; + Task_Arg : System.Address; + Parent : Task_Id; + Elaborated : Access_Boolean; + Base_Priority : System.Any_Priority; + Base_CPU : System.Multiprocessors.CPU_Range; + Task_Info : System.Task_Info.Task_Info_Type; + Stack_Size : System.Parameters.Size_Type; + T : Task_Id; + Success : out Boolean); + -- Initialize fields of a TCB and link into global TCB structures Call + -- this only with abort deferred and holding RTS_Lock. Need more + -- documentation, mention T, and describe Success ??? + +private + + Null_Task : constant Task_Id := null; + + type Activation_Chain is limited record + T_ID : Task_Id; + end record; + + -- Activation_Chain is an in-out parameter of initialization procedures and + -- it must be passed by reference because the init proc may terminate + -- abnormally after creating task components, and these must be properly + -- registered for removal (Expunge_Unactivated_Tasks). The "limited" forces + -- Activation_Chain to be a by-reference type; see RM-6.2(4). + +end System.Tasking; diff --git a/gcc/ada/s-tasloc.adb b/gcc/ada/s-tasloc.adb new file mode 100755 index 000000000..6220c6ba0 --- /dev/null +++ b/gcc/ada/s-tasloc.adb @@ -0,0 +1,56 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +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 new file mode 100755 index 000000000..804eca0a7 --- /dev/null +++ b/gcc/ada/s-tasloc.ads @@ -0,0 +1,100 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2007, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 Elaborate_Body; + + 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-taspri-dummy.ads b/gcc/ada/s-taspri-dummy.ads new file mode 100644 index 000000000..eaf3a6194 --- /dev/null +++ b/gcc/ada/s-taspri-dummy.ads @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a no tasking version of this package + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +package System.Task_Primitives is + pragma Preelaborate; + + type Lock is new Integer; + + type RTS_Lock is new Integer; + + type Suspension_Object is new Integer; + + type Task_Body_Access is access procedure; + + type Private_Data is record + Thread : aliased Integer; + CV : aliased Integer; + L : aliased RTS_Lock; + end record; + + subtype Task_Address is System.Address; + -- In some versions of Task_Primitives, notably for VMS, Task_Address is + -- the short version of address defined in System.Aux_DEC. To avoid + -- dragging Aux_DEC into tasking packages a tasking specific subtype is + -- defined here. + + Task_Address_Size : constant := Standard'Address_Size; + -- The size of Task_Address + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + +end System.Task_Primitives; diff --git a/gcc/ada/s-taspri-hpux-dce.ads b/gcc/ada/s-taspri-hpux-dce.ads new file mode 100644 index 000000000..31d6cec18 --- /dev/null +++ b/gcc/ada/s-taspri-hpux-dce.ads @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a HP-UX version of this package + +-- This package provides low-level support for most tasking features + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +with System.OS_Interface; + +package System.Task_Primitives is + pragma Preelaborate; + + type Lock is limited private; + -- Should be used for implementation of protected objects + + type RTS_Lock is limited private; + -- Should be used inside the runtime system. The difference between Lock + -- and the RTS_Lock is that the later one serves only as a semaphore so + -- that do not check for ceiling violations. + + type Suspension_Object is limited private; + -- Should be used for the implementation of Ada.Synchronous_Task_Control + + type Task_Body_Access is access procedure; + -- Pointer to the task body's entry point (or possibly a wrapper + -- declared local to the GNARL). + + type Private_Data is limited private; + -- Any information that the GNULLI needs maintained on a per-task basis. + -- A component of this type is guaranteed to be included in the + -- Ada_Task_Control_Block. + + subtype Task_Address is System.Address; + -- In some versions of Task_Primitives, notably for VMS, Task_Address is + -- the short version of address defined in System.Aux_DEC. To avoid + -- dragging Aux_DEC into tasking packages a tasking specific subtype is + -- defined here. + + Task_Address_Size : constant := Standard'Address_Size; + -- The size of Task_Address + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + +private + type Lock is record + L : aliased System.OS_Interface.pthread_mutex_t; + Priority : Integer; + Owner_Priority : Integer; + end record; + + type RTS_Lock is new System.OS_Interface.pthread_mutex_t; + + type Suspension_Object is record + State : Boolean; + pragma Atomic (State); + -- Boolean that indicates whether the object is open. This field is + -- marked Atomic to ensure that we can read its value without locking + -- the access to the Suspension_Object. + + Waiting : Boolean; + -- Flag showing if there is a task already suspended on this object + + L : aliased System.OS_Interface.pthread_mutex_t; + -- Protection for ensuring mutual exclusion on the Suspension_Object + + CV : aliased System.OS_Interface.pthread_cond_t; + -- Condition variable used to queue threads until condition is signaled + end record; + + type Private_Data is record + Thread : aliased System.OS_Interface.pthread_t; + pragma Atomic (Thread); + -- Thread field may be updated by two different threads of control. + -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the + -- same value (thr_self value). We do not want to use lock on those + -- operations and the only thing we have to make sure is that they + -- are updated in atomic fashion. + + CV : aliased System.OS_Interface.pthread_cond_t; + + L : aliased RTS_Lock; + -- Protection for all components is lock L + end record; + +end System.Task_Primitives; diff --git a/gcc/ada/s-taspri-lynxos.ads b/gcc/ada/s-taspri-lynxos.ads new file mode 100644 index 000000000..4e08865d8 --- /dev/null +++ b/gcc/ada/s-taspri-lynxos.ads @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2008, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a LynxOS version of this package, derived from s-taspri-posix.ads + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +with System.OS_Interface; + +package System.Task_Primitives is + pragma Preelaborate; + + type Lock is limited private; + -- Should be used for implementation of protected objects + + type RTS_Lock is limited private; + -- Should be used inside the runtime system. The difference between Lock + -- and the RTS_Lock is that the later one serves only as a semaphore so + -- that do not check for ceiling violations. + + type Suspension_Object is limited private; + -- Should be used for the implementation of Ada.Synchronous_Task_Control + + type Task_Body_Access is access procedure; + -- Pointer to the task body's entry point (or possibly a wrapper + -- declared local to the GNARL). + + type Private_Data is limited private; + -- Any information that the GNULLI needs maintained on a per-task basis. + -- A component of this type is guaranteed to be included in the + -- Ada_Task_Control_Block. + + subtype Task_Address is System.Address; + -- In some versions of Task_Primitives, notably for VMS, Task_Address is + -- the short version of address defined in System.Aux_DEC. To avoid + -- dragging Aux_DEC into tasking packages a tasking specific subtype is + -- defined here. + + Task_Address_Size : constant := Standard'Address_Size; + -- The size of Task_Address + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + +private + + type Lock is record + Mutex : aliased System.OS_Interface.pthread_mutex_t; + Ceiling : System.Any_Priority; + Saved_Priority : System.Any_Priority; + end record; + + type RTS_Lock is new System.OS_Interface.pthread_mutex_t; + + type Suspension_Object is record + State : Boolean; + pragma Atomic (State); + -- Boolean that indicates whether the object is open. This field is + -- marked Atomic to ensure that we can read its value without locking + -- the access to the Suspension_Object. + + Waiting : Boolean; + -- Flag showing if there is a task already suspended on this object + + L : aliased System.OS_Interface.pthread_mutex_t; + -- Protection for ensuring mutual exclusion on the Suspension_Object + + CV : aliased System.OS_Interface.pthread_cond_t; + -- Condition variable used to queue threads until condition is signaled + end record; + + type Private_Data is record + Thread : aliased System.OS_Interface.pthread_t; + pragma Atomic (Thread); + -- Thread field may be updated by two different threads of control. + -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the + -- same value (thr_self value). We do not want to use lock on those + -- operations and the only thing we have to make sure is that they + -- are updated in atomic fashion. + + LWP : aliased System.Address; + -- The purpose of this field is to provide a better tasking support on + -- gdb. The order of the two first fields (Thread and LWP) is important. + -- On targets where lwp is not relevant, this is equivalent to Thread. + + CV : aliased System.OS_Interface.pthread_cond_t; + + L : aliased RTS_Lock; + -- Protection for all components is lock L + end record; + +end System.Task_Primitives; diff --git a/gcc/ada/s-taspri-mingw.ads b/gcc/ada/s-taspri-mingw.ads new file mode 100644 index 000000000..fab05aaa2 --- /dev/null +++ b/gcc/ada/s-taspri-mingw.ads @@ -0,0 +1,124 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a NT (native) version of this package + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +with System.OS_Interface; +with System.Win32; + +package System.Task_Primitives is + pragma Preelaborate; + + type Lock is limited private; + -- Should be used for implementation of protected objects + + type RTS_Lock is limited private; + -- Should be used inside the runtime system. The difference between Lock + -- and the RTS_Lock is that the later one serves only as a semaphore so + -- that do not check for ceiling violations. + + type Suspension_Object is limited private; + -- Should be used for the implementation of Ada.Synchronous_Task_Control + + type Task_Body_Access is access procedure; + -- Pointer to the task body's entry point (or possibly a wrapper + -- declared local to the GNARL). + + type Private_Data is limited private; + -- Any information that the GNULLI needs maintained on a per-task basis. + -- A component of this type is guaranteed to be included in the + -- Ada_Task_Control_Block. + + subtype Task_Address is System.Address; + -- In some versions of Task_Primitives, notably for VMS, Task_Address is + -- the short version of address defined in System.Aux_DEC. To avoid + -- dragging Aux_DEC into tasking packages a tasking specific subtype is + -- defined here. + + Task_Address_Size : constant := Standard'Address_Size; + -- The size of Task_Address + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + +private + + type Lock is record + Mutex : aliased System.OS_Interface.CRITICAL_SECTION; + Priority : Integer; + Owner_Priority : Integer; + end record; + + type Condition_Variable is new System.Win32.HANDLE; + + type RTS_Lock is new System.OS_Interface.CRITICAL_SECTION; + + type Suspension_Object is record + State : Boolean; + pragma Atomic (State); + -- Boolean that indicates whether the object is open. This field is + -- marked Atomic to ensure that we can read its value without locking + -- the access to the Suspension_Object. + + Waiting : Boolean; + -- Flag showing if there is a task already suspended on this object + + L : aliased System.OS_Interface.CRITICAL_SECTION; + -- Protection for ensuring mutual exclusion on the Suspension_Object + + CV : aliased Win32.HANDLE; + -- Condition variable used to queue threads until condition is signaled + end record; + + type Private_Data is record + Thread : aliased Win32.HANDLE; + pragma Atomic (Thread); + -- Thread field may be updated by two different threads of control. + -- (See, Enter_Task and Create_Task in s-taprop.adb). + -- They put the same value (thr_self value). We do not want to + -- use lock on those operations and the only thing we have to + -- make sure is that they are updated in atomic fashion. + + Thread_Id : aliased Win32.DWORD; + -- Used to provide a better tasking support in gdb + + CV : aliased Condition_Variable; + -- Condition Variable used to implement Sleep/Wakeup + + L : aliased RTS_Lock; + -- Protection for all components is lock L + end record; + +end System.Task_Primitives; diff --git a/gcc/ada/s-taspri-posix-noaltstack.ads b/gcc/ada/s-taspri-posix-noaltstack.ads new file mode 100644 index 000000000..2fb8655eb --- /dev/null +++ b/gcc/ada/s-taspri-posix-noaltstack.ads @@ -0,0 +1,124 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2008, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a POSIX-like version of this package where no alternate stack +-- is needed for stack checking. + +-- Note: this file can only be used for POSIX compliant systems + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +with System.OS_Interface; + +package System.Task_Primitives is + pragma Preelaborate; + + type Lock is limited private; + -- Should be used for implementation of protected objects + + type RTS_Lock is limited private; + -- Should be used inside the runtime system. The difference between Lock + -- and the RTS_Lock is that the later one serves only as a semaphore so + -- that do not check for ceiling violations. + + type Suspension_Object is limited private; + -- Should be used for the implementation of Ada.Synchronous_Task_Control + + type Task_Body_Access is access procedure; + -- Pointer to the task body's entry point (or possibly a wrapper declared + -- local to the GNARL). + + type Private_Data is limited private; + -- Any information that the GNULLI needs maintained on a per-task basis. + -- A component of this type is guaranteed to be included in the + -- Ada_Task_Control_Block. + + subtype Task_Address is System.Address; + -- In some versions of Task_Primitives, notably for VMS, Task_Address is + -- the short version of address defined in System.Aux_DEC. To avoid + -- dragging Aux_DEC into tasking packages a tasking specific subtype is + -- defined here. + + Task_Address_Size : constant := Standard'Address_Size; + -- The size of Task_Address + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + +private + + type Lock is new System.OS_Interface.pthread_mutex_t; + type RTS_Lock is new System.OS_Interface.pthread_mutex_t; + + type Suspension_Object is record + State : Boolean; + pragma Atomic (State); + -- Boolean that indicates whether the object is open. This field is + -- marked Atomic to ensure that we can read its value without locking + -- the access to the Suspension_Object. + + Waiting : Boolean; + -- Flag showing if there is a task already suspended on this object + + L : aliased System.OS_Interface.pthread_mutex_t; + -- Protection for ensuring mutual exclusion on the Suspension_Object + + CV : aliased System.OS_Interface.pthread_cond_t; + -- Condition variable used to queue threads until condition is signaled + end record; + + type Private_Data is record + Thread : aliased System.OS_Interface.pthread_t; + pragma Atomic (Thread); + -- Thread field may be updated by two different threads of control. + -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same + -- value (thr_self value). We do not want to use lock on those + -- operations and the only thing we have to make sure is that they are + -- updated in atomic fashion. + + LWP : aliased System.Address; + -- The purpose of this field is to provide a better tasking support on + -- gdb. The order of the two first fields (Thread and LWP) is important. + -- On targets where lwp is not relevant, this is equivalent to Thread. + + CV : aliased System.OS_Interface.pthread_cond_t; + -- Should be commented ??? (in all versions of taspri) + + L : aliased RTS_Lock; + -- Protection for all components is lock L + end record; + +end System.Task_Primitives; diff --git a/gcc/ada/s-taspri-posix.ads b/gcc/ada/s-taspri-posix.ads new file mode 100644 index 000000000..23723f829 --- /dev/null +++ b/gcc/ada/s-taspri-posix.ads @@ -0,0 +1,123 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2008, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a POSIX-like version of this package + +-- Note: this file can only be used for POSIX compliant systems + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +with System.OS_Interface; + +package System.Task_Primitives is + pragma Preelaborate; + + type Lock is limited private; + -- Should be used for implementation of protected objects + + type RTS_Lock is limited private; + -- Should be used inside the runtime system. The difference between Lock + -- and the RTS_Lock is that the later one serves only as a semaphore so + -- that do not check for ceiling violations. + + type Suspension_Object is limited private; + -- Should be used for the implementation of Ada.Synchronous_Task_Control + + type Task_Body_Access is access procedure; + -- Pointer to the task body's entry point (or possibly a wrapper declared + -- local to the GNARL). + + type Private_Data is limited private; + -- Any information that the GNULLI needs maintained on a per-task basis. + -- A component of this type is guaranteed to be included in the + -- Ada_Task_Control_Block. + + subtype Task_Address is System.Address; + -- In some versions of Task_Primitives, notably for VMS, Task_Address is + -- the short version of address defined in System.Aux_DEC. To avoid + -- dragging Aux_DEC into tasking packages a tasking specific subtype is + -- defined here. + + Task_Address_Size : constant := Standard'Address_Size; + -- The size of Task_Address + + Alternate_Stack_Size : constant := System.OS_Interface.Alternate_Stack_Size; + -- Import value from System.OS_Interface + +private + + type Lock is new System.OS_Interface.pthread_mutex_t; + type RTS_Lock is new System.OS_Interface.pthread_mutex_t; + + type Suspension_Object is record + State : Boolean; + pragma Atomic (State); + -- Boolean that indicates whether the object is open. This field is + -- marked Atomic to ensure that we can read its value without locking + -- the access to the Suspension_Object. + + Waiting : Boolean; + -- Flag showing if there is a task already suspended on this object + + L : aliased System.OS_Interface.pthread_mutex_t; + -- Protection for ensuring mutual exclusion on the Suspension_Object + + CV : aliased System.OS_Interface.pthread_cond_t; + -- Condition variable used to queue threads until condition is signaled + end record; + + type Private_Data is record + Thread : aliased System.OS_Interface.pthread_t; + pragma Atomic (Thread); + -- Thread field may be updated by two different threads of control. + -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same + -- value (thr_self value). We do not want to use lock on those + -- operations and the only thing we have to make sure is that they are + -- updated in atomic fashion. + + LWP : aliased System.Address; + -- The purpose of this field is to provide a better tasking support on + -- gdb. The order of the two first fields (Thread and LWP) is important. + -- On targets where lwp is not relevant, this is equivalent to Thread. + + CV : aliased System.OS_Interface.pthread_cond_t; + -- Should be commented ??? (in all versions of taspri) + + L : aliased RTS_Lock; + -- Protection for all components is lock L + end record; + +end System.Task_Primitives; diff --git a/gcc/ada/s-taspri-solaris.ads b/gcc/ada/s-taspri-solaris.ads new file mode 100644 index 000000000..ef21e4ed5 --- /dev/null +++ b/gcc/ada/s-taspri-solaris.ads @@ -0,0 +1,156 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a Solaris version of this package + +-- This package provides low-level support for most tasking features + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +with Ada.Unchecked_Conversion; + +with System.OS_Interface; + +package System.Task_Primitives is + pragma Preelaborate; + + type Lock is limited private; + type Lock_Ptr is access all Lock; + -- Should be used for implementation of protected objects + + type RTS_Lock is limited private; + type RTS_Lock_Ptr is access all RTS_Lock; + -- Should be used inside the runtime system. The difference between Lock + -- and the RTS_Lock is that the later one serves only as a semaphore so + -- that do not check for ceiling violations. + + function To_Lock_Ptr is + new Ada.Unchecked_Conversion (RTS_Lock_Ptr, Lock_Ptr); + + type Suspension_Object is limited private; + -- Should be used for the implementation of Ada.Synchronous_Task_Control + + type Task_Body_Access is access procedure; + -- Pointer to the task body's entry point (or possibly a wrapper + -- declared local to the GNARL). + + type Private_Data is limited private; + -- Any information that the GNULLI needs maintained on a per-task basis. + -- A component of this type is guaranteed to be included in the + -- Ada_Task_Control_Block. + + subtype Task_Address is System.Address; + -- In some versions of Task_Primitives, notably for VMS, Task_Address is + -- the short version of address defined in System.Aux_DEC. To avoid + -- dragging Aux_DEC into tasking packages a tasking specific subtype is + -- defined here. + + Task_Address_Size : constant := Standard'Address_Size; + -- The size of Task_Address + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + +private + + type Private_Task_Serial_Number is mod 2 ** 64; + -- Used to give each task a unique serial number + + type Base_Lock is new System.OS_Interface.mutex_t; + + type Owner_Int is new Integer; + for Owner_Int'Alignment use Standard'Maximum_Alignment; + + type Owner_ID is access all Owner_Int; + + function To_Owner_ID is + new Ada.Unchecked_Conversion (System.Address, Owner_ID); + + type Lock is record + L : aliased Base_Lock; + Ceiling : System.Any_Priority := System.Any_Priority'First; + Saved_Priority : System.Any_Priority := System.Any_Priority'First; + Owner : Owner_ID; + Next : Lock_Ptr; + Level : Private_Task_Serial_Number := 0; + Buddy : Owner_ID; + Frozen : Boolean := False; + end record; + + type RTS_Lock is new Lock; + + type Suspension_Object is record + State : Boolean; + pragma Atomic (State); + -- Boolean that indicates whether the object is open. This field is + -- marked Atomic to ensure that we can read its value without locking + -- the access to the Suspension_Object. + + Waiting : Boolean; + -- Flag showing if there is a task already suspended on this object + + L : aliased System.OS_Interface.mutex_t; + -- Protection for ensuring mutual exclusion on the Suspension_Object + + CV : aliased System.OS_Interface.cond_t; + -- Condition variable used to queue threads until condition is signaled + end record; + + -- Note that task support on gdb relies on the fact that the first two + -- fields of Private_Data are Thread and LWP. + + type Private_Data is record + Thread : aliased System.OS_Interface.thread_t; + pragma Atomic (Thread); + -- Thread field may be updated by two different threads of control. + -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same + -- value (thr_self value). We do not want to use lock on those + -- operations and the only thing we have to make sure is that they are + -- updated in atomic fashion. + + LWP : System.OS_Interface.lwpid_t; + -- The LWP id of the thread. Set by self in Enter_Task + + CV : aliased System.OS_Interface.cond_t; + L : aliased RTS_Lock; + -- Protection for all components is lock L + + Active_Priority : System.Any_Priority := System.Any_Priority'First; + -- Simulated active priority, used iff Priority_Ceiling_Support is True + + Locking : Lock_Ptr; + Locks : Lock_Ptr; + Wakeups : Natural := 0; + end record; + +end System.Task_Primitives; diff --git a/gcc/ada/s-taspri-tru64.ads b/gcc/ada/s-taspri-tru64.ads new file mode 100644 index 000000000..da170cb4c --- /dev/null +++ b/gcc/ada/s-taspri-tru64.ads @@ -0,0 +1,119 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the DEC Unix 4.0 version of this package + +-- This package provides low-level support for most tasking features + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +with Interfaces.C; + +with System.OS_Interface; + +package System.Task_Primitives is + pragma Preelaborate; + + type Lock is limited private; + -- Should be used for implementation of protected objects + + type RTS_Lock is limited private; + -- Should be used inside the runtime system. The difference between Lock + -- and the RTS_Lock is that the later one serves only as a semaphore so + -- that do not check for ceiling violations. + + type Suspension_Object is limited private; + -- Should be used for the implementation of Ada.Synchronous_Task_Control + + type Task_Body_Access is access procedure; + -- Pointer to the task body's entry point (or possibly a wrapper + -- declared local to the GNARL). + + type Private_Data is limited private; + -- Any information that the GNULLI needs maintained on a per-task basis. + -- A component of this type is guaranteed to be included + + subtype Task_Address is System.Address; + -- In some versions of Task_Primitives, notably for VMS, Task_Address is + -- the short version of address defined in System.Aux_DEC. To avoid + -- dragging Aux_DEC into tasking packages a tasking specific subtype is + -- defined here. + + Task_Address_Size : constant := Standard'Address_Size; + -- The size of Task_Address + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + +private + + type Lock is record + L : aliased System.OS_Interface.pthread_mutex_t; + Ceiling : Interfaces.C.int; + end record; + + type RTS_Lock is new System.OS_Interface.pthread_mutex_t; + + type Suspension_Object is record + State : Boolean; + pragma Atomic (State); + -- Boolean that indicates whether the object is open. This field is + -- marked Atomic to ensure that we can read its value without locking + -- the access to the Suspension_Object. + + Waiting : Boolean; + -- Flag showing if there is a task already suspended on this object + + L : aliased System.OS_Interface.pthread_mutex_t; + -- Protection for ensuring mutual exclusion on the Suspension_Object + + CV : aliased System.OS_Interface.pthread_cond_t; + -- Condition variable used to queue threads until the is signaled + end record; + + type Private_Data is record + Thread : aliased System.OS_Interface.pthread_t; + pragma Atomic (Thread); + -- Thread field may be updated by two different threads of control. + -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same + -- value (thr_self value). We do not want to use lock on those + -- operations and the only thing we have to make sure is that they are + -- updated in atomic fashion. + + CV : aliased System.OS_Interface.pthread_cond_t; + + L : aliased RTS_Lock; + -- Protection for all components is lock L + end record; + +end System.Task_Primitives; diff --git a/gcc/ada/s-taspri-vms.ads b/gcc/ada/s-taspri-vms.ads new file mode 100644 index 000000000..3d20080e6 --- /dev/null +++ b/gcc/ada/s-taspri-vms.ads @@ -0,0 +1,132 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a OpenVMS/Alpha version of this package + +-- This package provides low-level support for most tasking features + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +with Interfaces.C; + +with System.OS_Interface; +with System.Aux_DEC; + +package System.Task_Primitives is + pragma Preelaborate; + + type Lock is limited private; + -- Should be used for implementation of protected objects + + type RTS_Lock is limited private; + -- Should be used inside the runtime system. The difference between Lock + -- and the RTS_Lock is that the later one serves only as a semaphore so + -- that do not check for ceiling violations. + + type Suspension_Object is limited private; + -- Should be used for the implementation of Ada.Synchronous_Task_Control + + type Task_Body_Access is access procedure; + -- Pointer to the task body's entry point (or possibly a wrapper + -- declared local to the GNARL). + + type Private_Data is limited private; + -- Any information that the GNULLI needs maintained on a per-task basis. + -- A component of this type is guaranteed to be included in the + -- Ada_Task_Control_Block. + + subtype Task_Address is System.Aux_DEC.Short_Address; + -- Task_Address is the short version of address defined in System.Aux_DEC. + -- To avoid dragging Aux_DEC into tasking packages a tasking specific + -- subtype is defined here. + + Task_Address_Size : constant := System.Aux_DEC.Short_Address_Size; + -- The size of Task_Address + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + +private + + type Exc_Stack_T is array (0 .. 8192) of aliased Character; + for Exc_Stack_T'Alignment use Standard'Maximum_Alignment; + type Exc_Stack_Ptr_T is access all Exc_Stack_T; + + type Lock is record + L : aliased System.OS_Interface.pthread_mutex_t; + Prio : Interfaces.C.int; + Prio_Save : Interfaces.C.int; + end record; + + type RTS_Lock is new System.OS_Interface.pthread_mutex_t; + + type Suspension_Object is record + State : Boolean; + pragma Atomic (State); + -- Boolean that indicates whether the object is open. This field is + -- marked Atomic to ensure that we can read its value without locking + -- the access to the Suspension_Object. + + Waiting : Boolean; + -- Flag showing if there is a task already suspended on this object + + L : aliased System.OS_Interface.pthread_mutex_t; + -- Protection for ensuring mutual exclusion on the Suspension_Object + + CV : aliased System.OS_Interface.pthread_cond_t; + -- Condition variable used to queue threads until ondition is signaled + end record; + + type Private_Data is record + Thread : aliased System.OS_Interface.pthread_t; + pragma Atomic (Thread); + -- Thread field may be updated by two different threads of control. + -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the + -- same value (thr_self value). We do not want to use lock on those + -- operations and the only thing we have to make sure is that they + -- are updated in atomic fashion. + + CV : aliased System.OS_Interface.pthread_cond_t; + + L : aliased RTS_Lock; + -- Protection for all components is lock L + + Exc_Stack_Ptr : Exc_Stack_Ptr_T; + -- ??? This needs comments + + AST_Pending : Boolean; + -- Used to detect delay and sleep timeouts + + end record; + +end System.Task_Primitives; diff --git a/gcc/ada/s-taspri-vxworks.ads b/gcc/ada/s-taspri-vxworks.ads new file mode 100644 index 000000000..8662ac6fa --- /dev/null +++ b/gcc/ada/s-taspri-vxworks.ads @@ -0,0 +1,126 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a VxWorks version of this package + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +with System.OS_Interface; + +package System.Task_Primitives is + pragma Preelaborate; + + type Lock is limited private; + -- Should be used for implementation of protected objects + + type RTS_Lock is limited private; + -- Should be used inside the runtime system. The difference between Lock + -- and the RTS_Lock is that the later one serves only as a semaphore so + -- that do not check for ceiling violations. + + type Suspension_Object is limited private; + -- Should be used for the implementation of Ada.Synchronous_Task_Control + + type Task_Body_Access is access procedure; + -- Pointer to the task body's entry point (or possibly a wrapper + -- declared local to the GNARL). + + type Private_Data is limited private; + -- Any information that the GNULLI needs maintained on a per-task basis. + -- A component of this type is guaranteed to be included in the + -- Ada_Task_Control_Block. + + subtype Task_Address is System.Address; + -- In some versions of Task_Primitives, notably for VMS, Task_Address is + -- the short version of address defined in System.Aux_DEC. To avoid + -- dragging Aux_DEC into tasking packages a tasking specific subtype is + -- defined here. + + Task_Address_Size : constant := Standard'Address_Size; + -- The size of Task_Address + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + +private + + type Priority_Type is (Prio_None, Prio_Protect, Prio_Inherit); + + type Lock is record + Mutex : System.OS_Interface.SEM_ID; + Protocol : Priority_Type; + + Prio_Ceiling : System.OS_Interface.int; + -- Priority ceiling of lock + end record; + + type RTS_Lock is new Lock; + + type Suspension_Object is record + State : Boolean; + pragma Atomic (State); + -- Boolean that indicates whether the object is open. This field is + -- marked Atomic to ensure that we can read its value without locking + -- the access to the Suspension_Object. + + Waiting : Boolean; + -- Flag showing if there is a task already suspended on this object + + L : aliased System.OS_Interface.SEM_ID; + -- Protection for ensuring mutual exclusion on the Suspension_Object + + CV : aliased System.OS_Interface.SEM_ID; + -- Condition variable used to queue threads until condition is signaled + end record; + + type Private_Data is record + Thread : aliased System.OS_Interface.t_id := 0; + pragma Atomic (Thread); + -- Thread field may be updated by two different threads of control. + -- (See, Enter_Task and Create_Task in s-taprop.adb). + -- They put the same value (thr_self value). We do not want to + -- use lock on those operations and the only thing we have to + -- make sure is that they are updated in atomic fashion. + + LWP : aliased System.OS_Interface.t_id := 0; + -- The purpose of this field is to provide a better tasking support on + -- gdb. The order of the two first fields (Thread and LWP) is important. + -- On targets where lwp is not relevant, this is equivalent to Thread. + + CV : aliased System.OS_Interface.SEM_ID; + + L : aliased RTS_Lock; + -- Protection for all components is lock L + end record; + +end System.Task_Primitives; diff --git a/gcc/ada/s-tasque.adb b/gcc/ada/s-tasque.adb new file mode 100644 index 000000000..5116c88c0 --- /dev/null +++ b/gcc/ada/s-tasque.adb @@ -0,0 +1,625 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . Q U E U I N G -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This version of the body implements queueing policy according to the policy +-- specified by the pragma Queuing_Policy. When no such pragma is specified +-- FIFO policy is used as default. + +with System.Task_Primitives.Operations; +with System.Tasking.Initialization; +with System.Parameters; + +package body System.Tasking.Queuing is + + use Parameters; + use Task_Primitives.Operations; + use Protected_Objects; + use Protected_Objects.Entries; + + -- Entry Queues implemented as doubly linked list + + Queuing_Policy : Character; + pragma Import (C, Queuing_Policy, "__gl_queuing_policy"); + + Priority_Queuing : constant Boolean := Queuing_Policy = 'P'; + + procedure Send_Program_Error + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link); + -- Raise Program_Error in the caller of the specified entry call + + function Check_Queue (E : Entry_Queue) return Boolean; + -- Check the validity of E. + -- Return True if E is valid, raise Assert_Failure if assertions are + -- enabled and False otherwise. + + ----------------------------- + -- Broadcast_Program_Error -- + ----------------------------- + + procedure Broadcast_Program_Error + (Self_ID : Task_Id; + Object : Protection_Entries_Access; + Pending_Call : Entry_Call_Link; + RTS_Locked : Boolean := False) + is + Entry_Call : Entry_Call_Link; + begin + if Single_Lock and then not RTS_Locked then + Lock_RTS; + end if; + + if Pending_Call /= null then + Send_Program_Error (Self_ID, Pending_Call); + end if; + + for E in Object.Entry_Queues'Range loop + Dequeue_Head (Object.Entry_Queues (E), Entry_Call); + + while Entry_Call /= null loop + pragma Assert (Entry_Call.Mode /= Conditional_Call); + + Send_Program_Error (Self_ID, Entry_Call); + Dequeue_Head (Object.Entry_Queues (E), Entry_Call); + end loop; + end loop; + + if Single_Lock and then not RTS_Locked then + Unlock_RTS; + end if; + end Broadcast_Program_Error; + + ----------------- + -- Check_Queue -- + ----------------- + + function Check_Queue (E : Entry_Queue) return Boolean is + Valid : Boolean := True; + C, Prev : Entry_Call_Link; + + begin + if E.Head = null then + if E.Tail /= null then + Valid := False; + pragma Assert (Valid); + end if; + else + if E.Tail = null + or else E.Tail.Next /= E.Head + then + Valid := False; + pragma Assert (Valid); + + else + C := E.Head; + + loop + Prev := C; + C := C.Next; + + if C = null then + Valid := False; + pragma Assert (Valid); + exit; + end if; + + if Prev /= C.Prev then + Valid := False; + pragma Assert (Valid); + exit; + end if; + + exit when C = E.Head; + end loop; + + if Prev /= E.Tail then + Valid := False; + pragma Assert (Valid); + end if; + end if; + end if; + + return Valid; + end Check_Queue; + + ------------------- + -- Count_Waiting -- + ------------------- + + -- Return number of calls on the waiting queue of E + + function Count_Waiting (E : Entry_Queue) return Natural is + Count : Natural; + Temp : Entry_Call_Link; + + begin + pragma Assert (Check_Queue (E)); + + Count := 0; + + if E.Head /= null then + Temp := E.Head; + + loop + Count := Count + 1; + exit when E.Tail = Temp; + Temp := Temp.Next; + end loop; + end if; + + return Count; + end Count_Waiting; + + ------------- + -- Dequeue -- + ------------- + + -- Dequeue call from entry_queue E + + procedure Dequeue (E : in out Entry_Queue; Call : Entry_Call_Link) is + begin + pragma Assert (Check_Queue (E)); + pragma Assert (Call /= null); + + -- If empty queue, simply return + + if E.Head = null then + return; + end if; + + pragma Assert (Call.Prev /= null); + pragma Assert (Call.Next /= null); + + Call.Prev.Next := Call.Next; + Call.Next.Prev := Call.Prev; + + if E.Head = Call then + + -- Case of one element + + if E.Tail = Call then + E.Head := null; + E.Tail := null; + + -- More than one element + + else + E.Head := Call.Next; + end if; + + elsif E.Tail = Call then + E.Tail := Call.Prev; + end if; + + -- Successfully dequeued + + Call.Prev := null; + Call.Next := null; + pragma Assert (Check_Queue (E)); + end Dequeue; + + ------------------ + -- Dequeue_Call -- + ------------------ + + procedure Dequeue_Call (Entry_Call : Entry_Call_Link) is + Called_PO : Protection_Entries_Access; + + begin + pragma Assert (Entry_Call /= null); + + if Entry_Call.Called_Task /= null then + Dequeue + (Entry_Call.Called_Task.Entry_Queues + (Task_Entry_Index (Entry_Call.E)), + Entry_Call); + + else + Called_PO := To_Protection (Entry_Call.Called_PO); + Dequeue (Called_PO.Entry_Queues + (Protected_Entry_Index (Entry_Call.E)), + Entry_Call); + end if; + end Dequeue_Call; + + ------------------ + -- Dequeue_Head -- + ------------------ + + -- Remove and return the head of entry_queue E + + procedure Dequeue_Head + (E : in out Entry_Queue; + Call : out Entry_Call_Link) + is + Temp : Entry_Call_Link; + + begin + pragma Assert (Check_Queue (E)); + -- If empty queue, return null pointer + + if E.Head = null then + Call := null; + return; + end if; + + Temp := E.Head; + + -- Case of one element + + if E.Head = E.Tail then + E.Head := null; + E.Tail := null; + + -- More than one element + + else + pragma Assert (Temp /= null); + pragma Assert (Temp.Next /= null); + pragma Assert (Temp.Prev /= null); + + E.Head := Temp.Next; + Temp.Prev.Next := Temp.Next; + Temp.Next.Prev := Temp.Prev; + end if; + + -- Successfully dequeued + + Temp.Prev := null; + Temp.Next := null; + Call := Temp; + pragma Assert (Check_Queue (E)); + end Dequeue_Head; + + ------------- + -- Enqueue -- + ------------- + + -- Enqueue call at the end of entry_queue E, for FIFO queuing policy. + -- Enqueue call priority ordered, FIFO at same priority level, for + -- Priority queuing policy. + + procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link) is + Temp : Entry_Call_Link := E.Head; + + begin + pragma Assert (Check_Queue (E)); + pragma Assert (Call /= null); + + -- Priority Queuing + + if Priority_Queuing then + if Temp = null then + Call.Prev := Call; + Call.Next := Call; + E.Head := Call; + E.Tail := Call; + + else + loop + -- Find the entry that the new guy should precede + + exit when Call.Prio > Temp.Prio; + Temp := Temp.Next; + + if Temp = E.Head then + Temp := null; + exit; + end if; + end loop; + + if Temp = null then + -- Insert at tail + + Call.Prev := E.Tail; + Call.Next := E.Head; + E.Tail := Call; + + else + Call.Prev := Temp.Prev; + Call.Next := Temp; + + -- Insert at head + + if Temp = E.Head then + E.Head := Call; + end if; + end if; + + pragma Assert (Call.Prev /= null); + pragma Assert (Call.Next /= null); + + Call.Prev.Next := Call; + Call.Next.Prev := Call; + end if; + + pragma Assert (Check_Queue (E)); + return; + end if; + + -- FIFO Queuing + + if E.Head = null then + E.Head := Call; + else + E.Tail.Next := Call; + Call.Prev := E.Tail; + end if; + + E.Head.Prev := Call; + E.Tail := Call; + Call.Next := E.Head; + pragma Assert (Check_Queue (E)); + end Enqueue; + + ------------------ + -- Enqueue_Call -- + ------------------ + + procedure Enqueue_Call (Entry_Call : Entry_Call_Link) is + Called_PO : Protection_Entries_Access; + + begin + pragma Assert (Entry_Call /= null); + + if Entry_Call.Called_Task /= null then + Enqueue + (Entry_Call.Called_Task.Entry_Queues + (Task_Entry_Index (Entry_Call.E)), + Entry_Call); + + else + Called_PO := To_Protection (Entry_Call.Called_PO); + Enqueue (Called_PO.Entry_Queues + (Protected_Entry_Index (Entry_Call.E)), + Entry_Call); + end if; + end Enqueue_Call; + + ---------- + -- Head -- + ---------- + + -- Return the head of entry_queue E + + function Head (E : Entry_Queue) return Entry_Call_Link is + begin + pragma Assert (Check_Queue (E)); + return E.Head; + end Head; + + ------------- + -- Onqueue -- + ------------- + + -- Return True if Call is on any entry_queue at all + + function Onqueue (Call : Entry_Call_Link) return Boolean is + begin + pragma Assert (Call /= null); + + -- Utilize the fact that every queue is circular, so if Call + -- is on any queue at all, Call.Next must NOT be null. + + return Call.Next /= null; + end Onqueue; + + -------------------------------- + -- Requeue_Call_With_New_Prio -- + -------------------------------- + + procedure Requeue_Call_With_New_Prio + (Entry_Call : Entry_Call_Link; Prio : System.Any_Priority) is + begin + pragma Assert (Entry_Call /= null); + + -- Perform a queue reordering only when the policy being used is the + -- Priority Queuing. + + if Priority_Queuing then + if Onqueue (Entry_Call) then + Dequeue_Call (Entry_Call); + Entry_Call.Prio := Prio; + Enqueue_Call (Entry_Call); + end if; + end if; + end Requeue_Call_With_New_Prio; + + --------------------------------- + -- Select_Protected_Entry_Call -- + --------------------------------- + + -- Select an entry of a protected object. Selection depends on the + -- queuing policy being used. + + procedure Select_Protected_Entry_Call + (Self_ID : Task_Id; + Object : Protection_Entries_Access; + Call : out Entry_Call_Link) + is + Entry_Call : Entry_Call_Link; + Temp_Call : Entry_Call_Link; + Entry_Index : Protected_Entry_Index := Null_Entry; -- stop warning + + begin + Entry_Call := null; + + begin + -- Priority queuing case + + if Priority_Queuing then + for J in Object.Entry_Queues'Range loop + Temp_Call := Head (Object.Entry_Queues (J)); + + if Temp_Call /= null + and then + Object.Entry_Bodies + (Object.Find_Body_Index + (Object.Compiler_Info, J)). + Barrier (Object.Compiler_Info, J) + then + if Entry_Call = null + or else Entry_Call.Prio < Temp_Call.Prio + then + Entry_Call := Temp_Call; + Entry_Index := J; + end if; + end if; + end loop; + + -- FIFO queueing case + + else + for J in Object.Entry_Queues'Range loop + Temp_Call := Head (Object.Entry_Queues (J)); + + if Temp_Call /= null + and then + Object.Entry_Bodies + (Object.Find_Body_Index + (Object.Compiler_Info, J)). + Barrier (Object.Compiler_Info, J) + then + Entry_Call := Temp_Call; + Entry_Index := J; + exit; + end if; + end loop; + end if; + + exception + when others => + Broadcast_Program_Error (Self_ID, Object, null); + end; + + -- If a call was selected, dequeue it and return it for service + + if Entry_Call /= null then + Temp_Call := Entry_Call; + Dequeue_Head (Object.Entry_Queues (Entry_Index), Entry_Call); + pragma Assert (Temp_Call = Entry_Call); + end if; + + Call := Entry_Call; + end Select_Protected_Entry_Call; + + ---------------------------- + -- Select_Task_Entry_Call -- + ---------------------------- + + -- Select an entry for rendezvous. Selection depends on the queuing policy + -- being used. + + procedure Select_Task_Entry_Call + (Acceptor : Task_Id; + Open_Accepts : Accept_List_Access; + Call : out Entry_Call_Link; + Selection : out Select_Index; + Open_Alternative : out Boolean) + is + Entry_Call : Entry_Call_Link; + Temp_Call : Entry_Call_Link; + Entry_Index : Task_Entry_Index := Task_Entry_Index'First; + Temp_Entry : Task_Entry_Index; + + begin + Open_Alternative := False; + Entry_Call := null; + Selection := No_Rendezvous; + + if Priority_Queuing then + -- Priority queueing case + + for J in Open_Accepts'Range loop + Temp_Entry := Open_Accepts (J).S; + + if Temp_Entry /= Null_Task_Entry then + Open_Alternative := True; + Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); + + if Temp_Call /= null + and then (Entry_Call = null + or else Entry_Call.Prio < Temp_Call.Prio) + then + Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); + Entry_Index := Temp_Entry; + Selection := J; + end if; + end if; + end loop; + + else + -- FIFO Queuing case + + for J in Open_Accepts'Range loop + Temp_Entry := Open_Accepts (J).S; + + if Temp_Entry /= Null_Task_Entry then + Open_Alternative := True; + Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); + + if Temp_Call /= null then + Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); + Entry_Index := Temp_Entry; + Selection := J; + exit; + end if; + end if; + end loop; + end if; + + if Entry_Call /= null then + Dequeue_Head (Acceptor.Entry_Queues (Entry_Index), Entry_Call); + + -- Guard is open + end if; + + Call := Entry_Call; + end Select_Task_Entry_Call; + + ------------------------ + -- Send_Program_Error -- + ------------------------ + + procedure Send_Program_Error + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link) + is + Caller : Task_Id; + begin + Caller := Entry_Call.Self; + Entry_Call.Exception_To_Raise := Program_Error'Identity; + Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + Unlock (Caller); + end Send_Program_Error; + +end System.Tasking.Queuing; diff --git a/gcc/ada/s-tasque.ads b/gcc/ada/s-tasque.ads new file mode 100644 index 000000000..e75af73e1 --- /dev/null +++ b/gcc/ada/s-tasque.ads @@ -0,0 +1,99 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . Q U E U I N G -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Tasking.Protected_Objects.Entries; + +package System.Tasking.Queuing is + + package POE renames System.Tasking.Protected_Objects.Entries; + + procedure Broadcast_Program_Error + (Self_ID : Task_Id; + Object : POE.Protection_Entries_Access; + Pending_Call : Entry_Call_Link; + RTS_Locked : Boolean := False); + -- Raise Program_Error in all tasks calling the protected entries of Object + -- The exception will not be raised immediately for the calling task; it + -- will be deferred until it calls Check_Exception. + -- RTS_Locked indicates whether the global RTS lock is taken (only + -- relevant if Single_Lock is True). + + procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link); + -- Enqueue Call at the end of entry_queue E + + procedure Dequeue (E : in out Entry_Queue; Call : Entry_Call_Link); + -- Dequeue Call from entry_queue E + + function Head (E : Entry_Queue) return Entry_Call_Link; + pragma Inline (Head); + -- Return the head of entry_queue E + + procedure Dequeue_Head + (E : in out Entry_Queue; + Call : out Entry_Call_Link); + -- Remove and return the head of entry_queue E + + function Onqueue (Call : Entry_Call_Link) return Boolean; + pragma Inline (Onqueue); + -- Return True if Call is on any entry_queue at all + + function Count_Waiting (E : Entry_Queue) return Natural; + -- Return number of calls on the waiting queue of E + + procedure Select_Task_Entry_Call + (Acceptor : Task_Id; + Open_Accepts : Accept_List_Access; + Call : out Entry_Call_Link; + Selection : out Select_Index; + Open_Alternative : out Boolean); + -- Select an entry for rendezvous. On exit: + -- Call will contain a pointer to the entry call record selected; + -- Selection will contain the index of the alternative selected + -- Open_Alternative will be True if there were any open alternatives + + procedure Select_Protected_Entry_Call + (Self_ID : Task_Id; + Object : POE.Protection_Entries_Access; + Call : out Entry_Call_Link); + -- Select an entry of a protected object + + procedure Enqueue_Call (Entry_Call : Entry_Call_Link); + procedure Dequeue_Call (Entry_Call : Entry_Call_Link); + -- Enqueue (dequeue) the call to (from) whatever server they are + -- calling, whether a task or a protected object. + + procedure Requeue_Call_With_New_Prio + (Entry_Call : Entry_Call_Link; Prio : System.Any_Priority); + -- Change Priority of the call and re insert to the queue when priority + -- queueing is in effect. When FIFO is enforced, this routine + -- should not have any effect. + +end System.Tasking.Queuing; diff --git a/gcc/ada/s-tasren.adb b/gcc/ada/s-tasren.adb new file mode 100644 index 000000000..1ea669947 --- /dev/null +++ b/gcc/ada/s-tasren.adb @@ -0,0 +1,1802 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . R E N D E Z V O U S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, 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.Task_Primitives.Operations; +with System.Tasking.Entry_Calls; +with System.Tasking.Initialization; +with System.Tasking.Queuing; +with System.Tasking.Utilities; +with System.Tasking.Protected_Objects.Operations; +with System.Tasking.Debug; +with System.Restrictions; +with System.Parameters; +with System.Traces.Tasking; + +package body System.Tasking.Rendezvous is + + package STPO renames System.Task_Primitives.Operations; + package POO renames Protected_Objects.Operations; + package POE renames Protected_Objects.Entries; + + use Parameters; + use Task_Primitives.Operations; + use System.Traces; + use System.Traces.Tasking; + + type Select_Treatment is ( + Accept_Alternative_Selected, -- alternative with non-null body + Accept_Alternative_Completed, -- alternative with null body + Else_Selected, + Terminate_Selected, + Accept_Alternative_Open, + No_Alternative_Open); + + ---------------- + -- Local Data -- + ---------------- + + Default_Treatment : constant array (Select_Modes) of Select_Treatment := + (Simple_Mode => No_Alternative_Open, + Else_Mode => Else_Selected, + Terminate_Mode => Terminate_Selected, + Delay_Mode => No_Alternative_Open); + + New_State : constant array (Boolean, Entry_Call_State) + of Entry_Call_State := + (True => + (Never_Abortable => Never_Abortable, + Not_Yet_Abortable => Now_Abortable, + Was_Abortable => Now_Abortable, + Now_Abortable => Now_Abortable, + Done => Done, + Cancelled => Cancelled), + False => + (Never_Abortable => Never_Abortable, + Not_Yet_Abortable => Not_Yet_Abortable, + Was_Abortable => Was_Abortable, + Now_Abortable => Now_Abortable, + Done => Done, + Cancelled => Cancelled) + ); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Local_Defer_Abort (Self_Id : Task_Id) renames + System.Tasking.Initialization.Defer_Abort_Nestable; + + procedure Local_Undefer_Abort (Self_Id : Task_Id) renames + System.Tasking.Initialization.Undefer_Abort_Nestable; + + -- Florist defers abort around critical sections that + -- make entry calls to the Interrupt_Manager task, which + -- violates the general rule about top-level runtime system + -- calls from abort-deferred regions. It is not that this is + -- unsafe, but when it occurs in "normal" programs it usually + -- means either the user is trying to do a potentially blocking + -- operation from within a protected object, or there is a + -- runtime system/compiler error that has failed to undefer + -- an earlier abort deferral. Thus, for debugging it may be + -- wise to modify the above renamings to the non-nestable forms. + + procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id); + pragma Inline (Boost_Priority); + -- Call this only with abort deferred and holding lock of Acceptor + + procedure Call_Synchronous + (Acceptor : Task_Id; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address; + Mode : Call_Modes; + Rendezvous_Successful : out Boolean); + pragma Inline (Call_Synchronous); + -- This call is used to make a simple or conditional entry call. + -- Called from Call_Simple and Task_Entry_Call. + + procedure Setup_For_Rendezvous_With_Body + (Entry_Call : Entry_Call_Link; + Acceptor : Task_Id); + pragma Inline (Setup_For_Rendezvous_With_Body); + -- Call this only with abort deferred and holding lock of Acceptor. + -- When a rendezvous selected (ready for rendezvous) we need to save + -- previous caller and adjust the priority. Also we need to make + -- this call not Abortable (Cancellable) since the rendezvous has + -- already been started. + + procedure Wait_For_Call (Self_Id : Task_Id); + pragma Inline (Wait_For_Call); + -- Call this only with abort deferred and holding lock of Self_Id. + -- An accepting task goes into Sleep by calling this routine + -- waiting for a call from the caller or waiting for an abort. + -- Make sure Self_Id is locked before calling this routine. + + ----------------- + -- Accept_Call -- + ----------------- + + procedure Accept_Call + (E : Task_Entry_Index; + Uninterpreted_Data : out System.Address) + is + Self_Id : constant Task_Id := STPO.Self; + Caller : Task_Id := null; + Open_Accepts : aliased Accept_List (1 .. 1); + Entry_Call : Entry_Call_Link; + + begin + Initialization.Defer_Abort (Self_Id); + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (Self_Id); + + if not Self_Id.Callable then + pragma Assert (Self_Id.Pending_ATC_Level = 0); + + pragma Assert (Self_Id.Pending_Action); + + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + + -- Should never get here ??? + + pragma Assert (False); + raise Standard'Abort_Signal; + end if; + + Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call); + + if Entry_Call /= null then + Caller := Entry_Call.Self; + Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id); + Uninterpreted_Data := Entry_Call.Uninterpreted_Data; + + else + -- Wait for a caller + + Open_Accepts (1).Null_Body := False; + Open_Accepts (1).S := E; + Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access; + + -- Wait for normal call + + if Parameters.Runtime_Traces then + Send_Trace_Info (W_Accept, Self_Id, Integer (Open_Accepts'Length)); + end if; + + pragma Debug + (Debug.Trace (Self_Id, "Accept_Call: wait", 'R')); + Wait_For_Call (Self_Id); + + pragma Assert (Self_Id.Open_Accepts = null); + + if Self_Id.Common.Call /= null then + Caller := Self_Id.Common.Call.Self; + Uninterpreted_Data := + Caller.Entry_Calls (Caller.ATC_Nesting_Level).Uninterpreted_Data; + else + -- Case of an aborted task + + Uninterpreted_Data := System.Null_Address; + end if; + end if; + + -- Self_Id.Common.Call should already be updated by the Caller + -- On return, we will start the rendezvous. + + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + + if Parameters.Runtime_Traces then + Send_Trace_Info (M_Accept_Complete, Caller, Entry_Index (E)); + end if; + end Accept_Call; + + -------------------- + -- Accept_Trivial -- + -------------------- + + procedure Accept_Trivial (E : Task_Entry_Index) is + Self_Id : constant Task_Id := STPO.Self; + Caller : Task_Id := null; + Open_Accepts : aliased Accept_List (1 .. 1); + Entry_Call : Entry_Call_Link; + + begin + Initialization.Defer_Abort_Nestable (Self_Id); + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (Self_Id); + + if not Self_Id.Callable then + pragma Assert (Self_Id.Pending_ATC_Level = 0); + + pragma Assert (Self_Id.Pending_Action); + + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort_Nestable (Self_Id); + + -- Should never get here ??? + + pragma Assert (False); + raise Standard'Abort_Signal; + end if; + + Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call); + + if Entry_Call = null then + -- Need to wait for entry call + + Open_Accepts (1).Null_Body := True; + Open_Accepts (1).S := E; + Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access; + + if Parameters.Runtime_Traces then + Send_Trace_Info (W_Accept, Self_Id, Integer (Open_Accepts'Length)); + end if; + + pragma Debug + (Debug.Trace (Self_Id, "Accept_Trivial: wait", 'R')); + + Wait_For_Call (Self_Id); + + pragma Assert (Self_Id.Open_Accepts = null); + + -- No need to do anything special here for pending abort. + -- Abort_Signal will be raised by Undefer on exit. + + STPO.Unlock (Self_Id); + + else -- found caller already waiting + pragma Assert (Entry_Call.State < Done); + + STPO.Unlock (Self_Id); + Caller := Entry_Call.Self; + + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + end if; + + if Parameters.Runtime_Traces then + Send_Trace_Info (M_Accept_Complete); + + -- Fake one, since there is (???) no way + -- to know that the rendezvous is over + + Send_Trace_Info (M_RDV_Complete); + end if; + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort_Nestable (Self_Id); + end Accept_Trivial; + + -------------------- + -- Boost_Priority -- + -------------------- + + procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id) is + Caller : constant Task_Id := Call.Self; + Caller_Prio : constant System.Any_Priority := Get_Priority (Caller); + Acceptor_Prio : constant System.Any_Priority := Get_Priority (Acceptor); + + begin + if Caller_Prio > Acceptor_Prio then + Call.Acceptor_Prev_Priority := Acceptor_Prio; + Set_Priority (Acceptor, Caller_Prio); + + else + Call.Acceptor_Prev_Priority := Priority_Not_Boosted; + end if; + end Boost_Priority; + + ----------------- + -- Call_Simple -- + ----------------- + + procedure Call_Simple + (Acceptor : Task_Id; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address) + is + Rendezvous_Successful : Boolean; + pragma Unreferenced (Rendezvous_Successful); + + begin + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if System.Tasking.Detect_Blocking + and then STPO.Self.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with "potentially blocking operation"; + end if; + + Call_Synchronous + (Acceptor, E, Uninterpreted_Data, Simple_Call, Rendezvous_Successful); + end Call_Simple; + + ---------------------- + -- Call_Synchronous -- + ---------------------- + + procedure Call_Synchronous + (Acceptor : Task_Id; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address; + Mode : Call_Modes; + Rendezvous_Successful : out Boolean) + is + Self_Id : constant Task_Id := STPO.Self; + Level : ATC_Level; + Entry_Call : Entry_Call_Link; + + begin + pragma Assert (Mode /= Asynchronous_Call); + + Local_Defer_Abort (Self_Id); + Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; + pragma Debug + (Debug.Trace (Self_Id, "CS: entered ATC level: " & + ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + Level := Self_Id.ATC_Nesting_Level; + Entry_Call := Self_Id.Entry_Calls (Level)'Access; + Entry_Call.Next := null; + Entry_Call.Mode := Mode; + Entry_Call.Cancellation_Attempted := False; + + if Parameters.Runtime_Traces then + Send_Trace_Info (W_Call, Acceptor, Entry_Index (E)); + end if; + + -- If this is a call made inside of an abort deferred region, + -- the call should be never abortable. + + Entry_Call.State := + (if Self_Id.Deferral_Level > 1 + then Never_Abortable + else Now_Abortable); + + Entry_Call.E := Entry_Index (E); + Entry_Call.Prio := Get_Priority (Self_Id); + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Called_Task := Acceptor; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + Entry_Call.With_Abort := True; + + -- Note: the caller will undefer abort on return (see WARNING above) + + if Single_Lock then + Lock_RTS; + end if; + + if not Task_Do_Or_Queue (Self_Id, Entry_Call) then + STPO.Write_Lock (Self_Id); + Utilities.Exit_One_ATC_Level (Self_Id); + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + if Parameters.Runtime_Traces then + Send_Trace_Info (E_Missed, Acceptor); + end if; + + Local_Undefer_Abort (Self_Id); + raise Tasking_Error; + end if; + + STPO.Write_Lock (Self_Id); + pragma Debug + (Debug.Trace (Self_Id, "Call_Synchronous: wait", 'R')); + Entry_Calls.Wait_For_Completion (Entry_Call); + pragma Debug + (Debug.Trace (Self_Id, "Call_Synchronous: done waiting", 'R')); + Rendezvous_Successful := Entry_Call.State = Done; + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Local_Undefer_Abort (Self_Id); + Entry_Calls.Check_Exception (Self_Id, Entry_Call); + end Call_Synchronous; + + -------------- + -- Callable -- + -------------- + + function Callable (T : Task_Id) return Boolean is + Result : Boolean; + Self_Id : constant Task_Id := STPO.Self; + + begin + Initialization.Defer_Abort_Nestable (Self_Id); + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (T); + Result := T.Callable; + STPO.Unlock (T); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort_Nestable (Self_Id); + return Result; + end Callable; + + ---------------------------- + -- Cancel_Task_Entry_Call -- + ---------------------------- + + procedure Cancel_Task_Entry_Call (Cancelled : out Boolean) is + begin + Entry_Calls.Try_To_Cancel_Entry_Call (Cancelled); + end Cancel_Task_Entry_Call; + + ------------------------- + -- Complete_Rendezvous -- + ------------------------- + + procedure Complete_Rendezvous is + begin + Exceptional_Complete_Rendezvous (Ada.Exceptions.Null_Id); + end Complete_Rendezvous; + + ------------------------------------- + -- Exceptional_Complete_Rendezvous -- + ------------------------------------- + + procedure Exceptional_Complete_Rendezvous + (Ex : Ada.Exceptions.Exception_Id) + is + Self_Id : constant Task_Id := STPO.Self; + Entry_Call : Entry_Call_Link := Self_Id.Common.Call; + Caller : Task_Id; + Called_PO : STPE.Protection_Entries_Access; + Acceptor_Prev_Priority : Integer; + + Exception_To_Raise : Ada.Exceptions.Exception_Id := Ex; + Ceiling_Violation : Boolean; + + use type Ada.Exceptions.Exception_Id; + procedure Internal_Reraise; + pragma Import (C, Internal_Reraise, "__gnat_reraise"); + + procedure Transfer_Occurrence + (Target : Ada.Exceptions.Exception_Occurrence_Access; + Source : Ada.Exceptions.Exception_Occurrence); + pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence"); + + use type STPE.Protection_Entries_Access; + + begin + -- Consider phasing out Complete_Rendezvous in favor + -- of direct call to this with Ada.Exceptions.Null_ID. + -- See code expansion examples for Accept_Call and Selective_Wait. + -- Also consider putting an explicit re-raise after this call, in + -- the generated code. That way we could eliminate the + -- code here that reraises the exception. + + -- The deferral level is critical here, + -- since we want to raise an exception or allow abort to take + -- place, if there is an exception or abort pending. + + pragma Debug + (Debug.Trace (Self_Id, "Exceptional_Complete_Rendezvous", 'R')); + + if Ex = Ada.Exceptions.Null_Id then + -- The call came from normal end-of-rendezvous, + -- so abort is not yet deferred. + + if Parameters.Runtime_Traces then + Send_Trace_Info (M_RDV_Complete, Entry_Call.Self); + end if; + + Initialization.Defer_Abort_Nestable (Self_Id); + end if; + + -- We need to clean up any accepts which Self may have + -- been serving when it was aborted. + + if Ex = Standard'Abort_Signal'Identity then + if Single_Lock then + Lock_RTS; + end if; + + while Entry_Call /= null loop + Entry_Call.Exception_To_Raise := Tasking_Error'Identity; + + -- All forms of accept make sure that the acceptor is not + -- completed, before accepting further calls, so that we + -- can be sure that no further calls are made after the + -- current calls are purged. + + Caller := Entry_Call.Self; + + -- Take write lock. This follows the lock precedence rule that + -- Caller may be locked while holding lock of Acceptor. + -- Complete the call abnormally, with exception. + + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + Entry_Call := Entry_Call.Acceptor_Prev_Call; + end loop; + + if Single_Lock then + Unlock_RTS; + end if; + + else + Caller := Entry_Call.Self; + + if Entry_Call.Needs_Requeue then + -- We dare not lock Self_Id at the same time as Caller, + -- for fear of deadlock. + + Entry_Call.Needs_Requeue := False; + Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call; + + if Entry_Call.Called_Task /= null then + -- Requeue to another task entry + + if Single_Lock then + Lock_RTS; + end if; + + if not Task_Do_Or_Queue (Self_Id, Entry_Call) then + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + raise Tasking_Error; + end if; + + if Single_Lock then + Unlock_RTS; + end if; + + else + -- Requeue to a protected entry + + Called_PO := POE.To_Protection (Entry_Call.Called_PO); + STPE.Lock_Entries (Called_PO, Ceiling_Violation); + + if Ceiling_Violation then + pragma Assert (Ex = Ada.Exceptions.Null_Id); + + Exception_To_Raise := Program_Error'Identity; + Entry_Call.Exception_To_Raise := Exception_To_Raise; + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller + (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + + if Single_Lock then + Unlock_RTS; + end if; + + else + POO.PO_Do_Or_Queue (Self_Id, Called_PO, Entry_Call); + POO.PO_Service_Entries (Self_Id, Called_PO); + end if; + end if; + + Entry_Calls.Reset_Priority + (Self_Id, Entry_Call.Acceptor_Prev_Priority); + + else + -- The call does not need to be requeued + + Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call; + Entry_Call.Exception_To_Raise := Ex; + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (Caller); + + -- Done with Caller locked to make sure that Wakeup is not lost + + if Ex /= Ada.Exceptions.Null_Id then + Transfer_Occurrence + (Caller.Common.Compiler_Data.Current_Excep'Access, + Self_Id.Common.Compiler_Data.Current_Excep); + end if; + + Acceptor_Prev_Priority := Entry_Call.Acceptor_Prev_Priority; + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + + STPO.Unlock (Caller); + + if Single_Lock then + Unlock_RTS; + end if; + + Entry_Calls.Reset_Priority (Self_Id, Acceptor_Prev_Priority); + end if; + end if; + + Initialization.Undefer_Abort (Self_Id); + + if Exception_To_Raise /= Ada.Exceptions.Null_Id then + Internal_Reraise; + end if; + + -- ??? Do we need to give precedence to Program_Error that might be + -- raised due to failure of finalization, over Tasking_Error from + -- failure of requeue? + end Exceptional_Complete_Rendezvous; + + ------------------------------------- + -- Requeue_Protected_To_Task_Entry -- + ------------------------------------- + + procedure Requeue_Protected_To_Task_Entry + (Object : STPE.Protection_Entries_Access; + Acceptor : Task_Id; + E : Task_Entry_Index; + With_Abort : Boolean) + is + Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress; + begin + pragma Assert (STPO.Self.Deferral_Level > 0); + + Entry_Call.E := Entry_Index (E); + Entry_Call.Called_Task := Acceptor; + Entry_Call.Called_PO := Null_Address; + Entry_Call.With_Abort := With_Abort; + Object.Call_In_Progress := null; + end Requeue_Protected_To_Task_Entry; + + ------------------------ + -- Requeue_Task_Entry -- + ------------------------ + + procedure Requeue_Task_Entry + (Acceptor : Task_Id; + E : Task_Entry_Index; + With_Abort : Boolean) + is + Self_Id : constant Task_Id := STPO.Self; + Entry_Call : constant Entry_Call_Link := Self_Id.Common.Call; + + begin + Initialization.Defer_Abort (Self_Id); + Entry_Call.Needs_Requeue := True; + Entry_Call.With_Abort := With_Abort; + Entry_Call.E := Entry_Index (E); + Entry_Call.Called_Task := Acceptor; + Initialization.Undefer_Abort (Self_Id); + end Requeue_Task_Entry; + + -------------------- + -- Selective_Wait -- + -------------------- + + procedure Selective_Wait + (Open_Accepts : Accept_List_Access; + Select_Mode : Select_Modes; + Uninterpreted_Data : out System.Address; + Index : out Select_Index) + is + Self_Id : constant Task_Id := STPO.Self; + Entry_Call : Entry_Call_Link; + Treatment : Select_Treatment; + Caller : Task_Id; + Selection : Select_Index; + Open_Alternative : Boolean; + + begin + Initialization.Defer_Abort (Self_Id); + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (Self_Id); + + if not Self_Id.Callable then + pragma Assert (Self_Id.Pending_ATC_Level = 0); + + pragma Assert (Self_Id.Pending_Action); + + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + -- ??? In some cases abort is deferred more than once. Need to + -- figure out why this happens. + + if Self_Id.Deferral_Level > 1 then + Self_Id.Deferral_Level := 1; + end if; + + Initialization.Undefer_Abort (Self_Id); + + -- Should never get here ??? + + pragma Assert (False); + raise Standard'Abort_Signal; + end if; + + pragma Assert (Open_Accepts /= null); + + Uninterpreted_Data := Null_Address; + + Queuing.Select_Task_Entry_Call + (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative); + + -- Determine the kind and disposition of the select + + Treatment := Default_Treatment (Select_Mode); + Self_Id.Chosen_Index := No_Rendezvous; + + if Open_Alternative then + if Entry_Call /= null then + if Open_Accepts (Selection).Null_Body then + Treatment := Accept_Alternative_Completed; + else + Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id); + Treatment := Accept_Alternative_Selected; + end if; + + Self_Id.Chosen_Index := Selection; + + elsif Treatment = No_Alternative_Open then + Treatment := Accept_Alternative_Open; + end if; + end if; + + -- Handle the select according to the disposition selected above + + case Treatment is + when Accept_Alternative_Selected => + -- Ready to rendezvous + + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + + -- In this case the accept body is not Null_Body. Defer abort + -- until it gets into the accept body. + + pragma Assert (Self_Id.Deferral_Level = 1); + + Initialization.Defer_Abort_Nestable (Self_Id); + STPO.Unlock (Self_Id); + + when Accept_Alternative_Completed => + + -- Accept body is null, so rendezvous is over immediately + + if Parameters.Runtime_Traces then + Send_Trace_Info (M_RDV_Complete, Entry_Call.Self); + end if; + + STPO.Unlock (Self_Id); + Caller := Entry_Call.Self; + + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + + when Accept_Alternative_Open => + + -- Wait for caller + + Self_Id.Open_Accepts := Open_Accepts; + pragma Debug + (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R')); + + if Parameters.Runtime_Traces then + Send_Trace_Info (W_Select, Self_Id, + Integer (Open_Accepts'Length)); + end if; + + Wait_For_Call (Self_Id); + + pragma Assert (Self_Id.Open_Accepts = null); + + -- Self_Id.Common.Call should already be updated by the Caller if + -- not aborted. It might also be ready to do rendezvous even if + -- this wakes up due to an abort. Therefore, if the call is not + -- empty we need to do the rendezvous if the accept body is not + -- Null_Body. + + -- Aren't the first two conditions below redundant??? + + if Self_Id.Chosen_Index /= No_Rendezvous + and then Self_Id.Common.Call /= null + and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body + then + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + + pragma Assert + (Self_Id.Deferral_Level = 1 + or else + (Self_Id.Deferral_Level = 0 + and then not Restrictions.Abort_Allowed)); + + Initialization.Defer_Abort_Nestable (Self_Id); + + -- Leave abort deferred until the accept body + end if; + + STPO.Unlock (Self_Id); + + when Else_Selected => + pragma Assert (Self_Id.Open_Accepts = null); + + if Parameters.Runtime_Traces then + Send_Trace_Info (M_Select_Else); + end if; + + STPO.Unlock (Self_Id); + + when Terminate_Selected => + -- Terminate alternative is open + + Self_Id.Open_Accepts := Open_Accepts; + Self_Id.Common.State := Acceptor_Sleep; + + -- Notify ancestors that this task is on a terminate alternative + + STPO.Unlock (Self_Id); + Utilities.Make_Passive (Self_Id, Task_Completed => False); + STPO.Write_Lock (Self_Id); + + -- Wait for normal entry call or termination + + Wait_For_Call (Self_Id); + + pragma Assert (Self_Id.Open_Accepts = null); + + if Self_Id.Terminate_Alternative then + -- An entry call should have reset this to False, + -- so we must be aborted. + -- We cannot be in an async. select, since that + -- is not legal, so the abort must be of the entire + -- task. Therefore, we do not need to cancel the + -- terminate alternative. The cleanup will be done + -- in Complete_Master. + + pragma Assert (Self_Id.Pending_ATC_Level = 0); + pragma Assert (Self_Id.Awake_Count = 0); + + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Index := Self_Id.Chosen_Index; + Initialization.Undefer_Abort_Nestable (Self_Id); + + if Self_Id.Pending_Action then + Initialization.Do_Pending_Action (Self_Id); + end if; + + return; + + else + -- Self_Id.Common.Call and Self_Id.Chosen_Index + -- should already be updated by the Caller. + + if Self_Id.Chosen_Index /= No_Rendezvous + and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body + then + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + + pragma Assert (Self_Id.Deferral_Level = 1); + + -- We need an extra defer here, to keep abort + -- deferred until we get into the accept body + + Initialization.Defer_Abort_Nestable (Self_Id); + end if; + end if; + + STPO.Unlock (Self_Id); + + when No_Alternative_Open => + -- In this case, Index will be No_Rendezvous on return, which + -- should cause a Program_Error if it is not a Delay_Mode. + + -- If delay alternative exists (Delay_Mode) we should suspend + -- until the delay expires. + + Self_Id.Open_Accepts := null; + + if Select_Mode = Delay_Mode then + Self_Id.Common.State := Delay_Sleep; + + loop + exit when + Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level; + Sleep (Self_Id, Delay_Sleep); + end loop; + + Self_Id.Common.State := Runnable; + STPO.Unlock (Self_Id); + + else + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + raise Program_Error with "Entry call not a delay mode"; + end if; + end case; + + if Single_Lock then + Unlock_RTS; + end if; + + -- Caller has been chosen. + -- Self_Id.Common.Call should already be updated by the Caller. + -- Self_Id.Chosen_Index should either be updated by the Caller + -- or by Test_Selective_Wait. + -- On return, we sill start rendezvous unless the accept body is + -- null. In the latter case, we will have already completed the RV. + + Index := Self_Id.Chosen_Index; + Initialization.Undefer_Abort_Nestable (Self_Id); + end Selective_Wait; + + ------------------------------------ + -- Setup_For_Rendezvous_With_Body -- + ------------------------------------ + + procedure Setup_For_Rendezvous_With_Body + (Entry_Call : Entry_Call_Link; + Acceptor : Task_Id) is + begin + Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call; + Acceptor.Common.Call := Entry_Call; + + if Entry_Call.State = Now_Abortable then + Entry_Call.State := Was_Abortable; + end if; + + Boost_Priority (Entry_Call, Acceptor); + end Setup_For_Rendezvous_With_Body; + + ---------------- + -- Task_Count -- + ---------------- + + function Task_Count (E : Task_Entry_Index) return Natural is + Self_Id : constant Task_Id := STPO.Self; + Return_Count : Natural; + + begin + Initialization.Defer_Abort (Self_Id); + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (Self_Id); + Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E)); + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + + -- Call Yield to let other tasks get a chance to run as this is a + -- potential dispatching point. + + Yield (Do_Yield => False); + return Return_Count; + end Task_Count; + + ---------------------- + -- Task_Do_Or_Queue -- + ---------------------- + + function Task_Do_Or_Queue + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link) return Boolean + is + E : constant Task_Entry_Index := + Task_Entry_Index (Entry_Call.E); + Old_State : constant Entry_Call_State := Entry_Call.State; + Acceptor : constant Task_Id := Entry_Call.Called_Task; + Parent : constant Task_Id := Acceptor.Common.Parent; + Parent_Locked : Boolean := False; + Null_Body : Boolean; + + begin + -- Find out whether Entry_Call can be accepted immediately + + -- If the Acceptor is not callable, return False. + -- If the rendezvous can start, initiate it. + -- If the accept-body is trivial, also complete the rendezvous. + -- If the acceptor is not ready, enqueue the call. + + -- This should have a special case for Accept_Call and Accept_Trivial, + -- so that we don't have the loop setup overhead, below. + + -- The call state Done is used here and elsewhere to include both the + -- case of normal successful completion, and the case of an exception + -- being raised. The difference is that if an exception is raised no one + -- will pay attention to the fact that State = Done. Instead the + -- exception will be raised in Undefer_Abort, and control will skip past + -- the place where we normally would resume from an entry call. + + pragma Assert (not Queuing.Onqueue (Entry_Call)); + + -- We rely that the call is off-queue for protection, that the caller + -- will not exit the Entry_Caller_Sleep, and so will not reuse the call + -- record for another call. + -- We rely on the Caller's lock for call State mod's. + + -- We can't lock Acceptor.Parent while holding Acceptor, + -- so lock it in advance if we expect to need to lock it. + + if Acceptor.Terminate_Alternative then + STPO.Write_Lock (Parent); + Parent_Locked := True; + end if; + + STPO.Write_Lock (Acceptor); + + -- If the acceptor is not callable, abort the call and return False + + if not Acceptor.Callable then + STPO.Unlock (Acceptor); + + if Parent_Locked then + STPO.Unlock (Parent); + end if; + + pragma Assert (Entry_Call.State < Done); + + -- In case we are not the caller, set up the caller + -- to raise Tasking_Error when it wakes up. + + STPO.Write_Lock (Entry_Call.Self); + Entry_Call.Exception_To_Raise := Tasking_Error'Identity; + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + STPO.Unlock (Entry_Call.Self); + + return False; + end if; + + -- Try to serve the call immediately + + if Acceptor.Open_Accepts /= null then + for J in Acceptor.Open_Accepts'Range loop + if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then + + -- Commit acceptor to rendezvous with us + + Acceptor.Chosen_Index := J; + Null_Body := Acceptor.Open_Accepts (J).Null_Body; + Acceptor.Open_Accepts := null; + + -- Prevent abort while call is being served + + if Entry_Call.State = Now_Abortable then + Entry_Call.State := Was_Abortable; + end if; + + if Acceptor.Terminate_Alternative then + + -- Cancel terminate alternative. See matching code in + -- Selective_Wait and Vulnerable_Complete_Master. + + Acceptor.Terminate_Alternative := False; + Acceptor.Awake_Count := Acceptor.Awake_Count + 1; + + if Acceptor.Awake_Count = 1 then + + -- Notify parent that acceptor is awake + + pragma Assert (Parent.Awake_Count > 0); + + Parent.Awake_Count := Parent.Awake_Count + 1; + + if Parent.Common.State = Master_Completion_Sleep + and then Acceptor.Master_of_Task = Parent.Master_Within + then + Parent.Common.Wait_Count := + Parent.Common.Wait_Count + 1; + end if; + end if; + end if; + + if Null_Body then + + -- Rendezvous is over immediately + + STPO.Wakeup (Acceptor, Acceptor_Sleep); + STPO.Unlock (Acceptor); + + if Parent_Locked then + STPO.Unlock (Parent); + end if; + + STPO.Write_Lock (Entry_Call.Self); + Initialization.Wakeup_Entry_Caller + (Self_ID, Entry_Call, Done); + STPO.Unlock (Entry_Call.Self); + + else + Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor); + + -- For terminate_alternative, acceptor may not be asleep + -- yet, so we skip the wakeup + + if Acceptor.Common.State /= Runnable then + STPO.Wakeup (Acceptor, Acceptor_Sleep); + end if; + + STPO.Unlock (Acceptor); + + if Parent_Locked then + STPO.Unlock (Parent); + end if; + end if; + + return True; + end if; + end loop; + + -- The acceptor is accepting, but not this entry + end if; + + -- If the acceptor was ready to accept this call, + -- we would not have gotten this far, so now we should + -- (re)enqueue the call, if the mode permits that. + + -- If the call is timed, it may have timed out before the requeue, + -- in the unusual case where the current accept has taken longer than + -- the given delay. In that case the requeue is cancelled, and the + -- outer timed call will be aborted. + + if Entry_Call.Mode = Conditional_Call + or else + (Entry_Call.Mode = Timed_Call + and then Entry_Call.With_Abort + and then Entry_Call.Cancellation_Attempted) + then + STPO.Unlock (Acceptor); + + if Parent_Locked then + STPO.Unlock (Parent); + end if; + + STPO.Write_Lock (Entry_Call.Self); + + pragma Assert (Entry_Call.State >= Was_Abortable); + + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled); + STPO.Unlock (Entry_Call.Self); + + else + -- Timed_Call, Simple_Call, or Asynchronous_Call + + Queuing.Enqueue (Acceptor.Entry_Queues (E), Entry_Call); + + -- Update abortability of call + + pragma Assert (Old_State < Done); + + Entry_Call.State := + New_State (Entry_Call.With_Abort, Entry_Call.State); + + STPO.Unlock (Acceptor); + + if Parent_Locked then + STPO.Unlock (Parent); + end if; + + if Old_State /= Entry_Call.State + and then Entry_Call.State = Now_Abortable + and then Entry_Call.Mode /= Simple_Call + and then Entry_Call.Self /= Self_ID + + -- Asynchronous_Call or Conditional_Call + + then + -- Because of ATCB lock ordering rule + + STPO.Write_Lock (Entry_Call.Self); + + if Entry_Call.Self.Common.State = Async_Select_Sleep then + + -- Caller may not yet have reached wait-point + + STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep); + end if; + + STPO.Unlock (Entry_Call.Self); + end if; + end if; + + return True; + end Task_Do_Or_Queue; + + --------------------- + -- Task_Entry_Call -- + --------------------- + + procedure Task_Entry_Call + (Acceptor : Task_Id; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address; + Mode : Call_Modes; + Rendezvous_Successful : out Boolean) + is + Self_Id : constant Task_Id := STPO.Self; + Entry_Call : Entry_Call_Link; + + begin + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if System.Tasking.Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with "potentially blocking operation"; + end if; + + if Parameters.Runtime_Traces then + Send_Trace_Info (W_Call, Acceptor, Entry_Index (E)); + end if; + + if Mode = Simple_Call or else Mode = Conditional_Call then + Call_Synchronous + (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful); + + else + -- This is an asynchronous call + + -- Abort must already be deferred by the compiler-generated code. + -- Without this, an abort that occurs between the time that this + -- call is made and the time that the abortable part's cleanup + -- handler is set up might miss the cleanup handler and leave the + -- call pending. + + Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; + pragma Debug + (Debug.Trace (Self_Id, "TEC: entered ATC level: " & + ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access; + Entry_Call.Next := null; + Entry_Call.Mode := Mode; + Entry_Call.Cancellation_Attempted := False; + Entry_Call.State := Not_Yet_Abortable; + Entry_Call.E := Entry_Index (E); + Entry_Call.Prio := Get_Priority (Self_Id); + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Called_Task := Acceptor; + Entry_Call.Called_PO := Null_Address; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + Entry_Call.With_Abort := True; + + if Single_Lock then + Lock_RTS; + end if; + + if not Task_Do_Or_Queue (Self_Id, Entry_Call) then + STPO.Write_Lock (Self_Id); + Utilities.Exit_One_ATC_Level (Self_Id); + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + + if Parameters.Runtime_Traces then + Send_Trace_Info (E_Missed, Acceptor); + end if; + + raise Tasking_Error; + end if; + + -- The following is special for async. entry calls. + -- If the call was not queued abortably, we need to wait until + -- it is before proceeding with the abortable part. + + -- Wait_Until_Abortable can be called unconditionally here, + -- but it is expensive. + + if Entry_Call.State < Was_Abortable then + Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call); + end if; + + if Single_Lock then + Unlock_RTS; + end if; + + -- Note: following assignment needs to be atomic + + Rendezvous_Successful := Entry_Call.State = Done; + end if; + end Task_Entry_Call; + + ----------------------- + -- Task_Entry_Caller -- + ----------------------- + + function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id is + Self_Id : constant Task_Id := STPO.Self; + Entry_Call : Entry_Call_Link; + + begin + Entry_Call := Self_Id.Common.Call; + + for Depth in 1 .. D loop + Entry_Call := Entry_Call.Acceptor_Prev_Call; + pragma Assert (Entry_Call /= null); + end loop; + + return Entry_Call.Self; + end Task_Entry_Caller; + + -------------------------- + -- Timed_Selective_Wait -- + -------------------------- + + procedure Timed_Selective_Wait + (Open_Accepts : Accept_List_Access; + Select_Mode : Select_Modes; + Uninterpreted_Data : out System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Index : out Select_Index) + is + Self_Id : constant Task_Id := STPO.Self; + Treatment : Select_Treatment; + Entry_Call : Entry_Call_Link; + Caller : Task_Id; + Selection : Select_Index; + Open_Alternative : Boolean; + Timedout : Boolean := False; + Yielded : Boolean := True; + + begin + pragma Assert (Select_Mode = Delay_Mode); + + Initialization.Defer_Abort (Self_Id); + + -- If we are aborted here, the effect will be pending + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (Self_Id); + + if not Self_Id.Callable then + pragma Assert (Self_Id.Pending_ATC_Level = 0); + + pragma Assert (Self_Id.Pending_Action); + + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + + -- Should never get here ??? + + pragma Assert (False); + raise Standard'Abort_Signal; + end if; + + Uninterpreted_Data := Null_Address; + + pragma Assert (Open_Accepts /= null); + + Queuing.Select_Task_Entry_Call + (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative); + + -- Determine the kind and disposition of the select + + Treatment := Default_Treatment (Select_Mode); + Self_Id.Chosen_Index := No_Rendezvous; + + if Open_Alternative then + if Entry_Call /= null then + if Open_Accepts (Selection).Null_Body then + Treatment := Accept_Alternative_Completed; + + else + Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id); + Treatment := Accept_Alternative_Selected; + end if; + + Self_Id.Chosen_Index := Selection; + + elsif Treatment = No_Alternative_Open then + Treatment := Accept_Alternative_Open; + end if; + end if; + + -- Handle the select according to the disposition selected above + + case Treatment is + when Accept_Alternative_Selected => + -- Ready to rendezvous + -- In this case the accept body is not Null_Body. Defer abort + -- until it gets into the accept body. + + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + Initialization.Defer_Abort (Self_Id); + STPO.Unlock (Self_Id); + + when Accept_Alternative_Completed => + -- Rendezvous is over + + if Parameters.Runtime_Traces then + Send_Trace_Info (M_RDV_Complete, Entry_Call.Self); + end if; + + STPO.Unlock (Self_Id); + Caller := Entry_Call.Self; + + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + + when Accept_Alternative_Open => + + -- Wait for caller + + Self_Id.Open_Accepts := Open_Accepts; + + -- Wait for a normal call and a pending action until the + -- Wakeup_Time is reached. + + Self_Id.Common.State := Acceptor_Delay_Sleep; + + -- Try to remove calls to Sleep in the loop below by letting the + -- caller a chance of getting ready immediately, using Unlock + -- Yield. See similar action in Wait_For_Completion/Wait_For_Call. + + if Single_Lock then + Unlock_RTS; + else + Unlock (Self_Id); + end if; + + if Self_Id.Open_Accepts /= null then + Yield; + end if; + + if Single_Lock then + Lock_RTS; + else + Write_Lock (Self_Id); + end if; + + -- Check if this task has been aborted while the lock was released + + if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then + Self_Id.Open_Accepts := null; + end if; + + loop + exit when Self_Id.Open_Accepts = null; + + if Timedout then + Sleep (Self_Id, Acceptor_Delay_Sleep); + else + if Parameters.Runtime_Traces then + Send_Trace_Info (WT_Select, + Self_Id, + Integer (Open_Accepts'Length), + Timeout); + end if; + + STPO.Timed_Sleep (Self_Id, Timeout, Mode, + Acceptor_Delay_Sleep, Timedout, Yielded); + end if; + + if Timedout then + Self_Id.Open_Accepts := null; + + if Parameters.Runtime_Traces then + Send_Trace_Info (E_Timeout); + end if; + end if; + end loop; + + Self_Id.Common.State := Runnable; + + -- Self_Id.Common.Call should already be updated by the Caller if + -- not aborted. It might also be ready to do rendezvous even if + -- this wakes up due to an abort. Therefore, if the call is not + -- empty we need to do the rendezvous if the accept body is not + -- Null_Body. + + if Self_Id.Chosen_Index /= No_Rendezvous + and then Self_Id.Common.Call /= null + and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body + then + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + + pragma Assert (Self_Id.Deferral_Level = 1); + + Initialization.Defer_Abort_Nestable (Self_Id); + + -- Leave abort deferred until the accept body + end if; + + STPO.Unlock (Self_Id); + + when No_Alternative_Open => + -- In this case, Index will be No_Rendezvous on return. We sleep + -- for the time we need to. + -- Wait for a signal or timeout. A wakeup can be made + -- for several reasons: + -- 1) Delay is expired + -- 2) Pending_Action needs to be checked + -- (Abort, Priority change) + -- 3) Spurious wakeup + + Self_Id.Open_Accepts := null; + Self_Id.Common.State := Acceptor_Delay_Sleep; + + STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Delay_Sleep, + Timedout, Yielded); + + Self_Id.Common.State := Runnable; + + STPO.Unlock (Self_Id); + + when others => + -- Should never get here + pragma Assert (False); + null; + end case; + + if Single_Lock then + Unlock_RTS; + end if; + + if not Yielded then + Yield; + end if; + + -- Caller has been chosen + + -- Self_Id.Common.Call should already be updated by the Caller + + -- Self_Id.Chosen_Index should either be updated by the Caller + -- or by Test_Selective_Wait + + Index := Self_Id.Chosen_Index; + Initialization.Undefer_Abort_Nestable (Self_Id); + + -- Start rendezvous, if not already completed + end Timed_Selective_Wait; + + --------------------------- + -- Timed_Task_Entry_Call -- + --------------------------- + + procedure Timed_Task_Entry_Call + (Acceptor : Task_Id; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Rendezvous_Successful : out Boolean) + is + Self_Id : constant Task_Id := STPO.Self; + Level : ATC_Level; + Entry_Call : Entry_Call_Link; + + Yielded : Boolean; + pragma Unreferenced (Yielded); + + begin + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if System.Tasking.Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with "potentially blocking operation"; + end if; + + Initialization.Defer_Abort (Self_Id); + Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; + + pragma Debug + (Debug.Trace (Self_Id, "TTEC: entered ATC level: " & + ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + + if Parameters.Runtime_Traces then + Send_Trace_Info (WT_Call, Acceptor, + Entry_Index (E), Timeout); + end if; + + Level := Self_Id.ATC_Nesting_Level; + Entry_Call := Self_Id.Entry_Calls (Level)'Access; + Entry_Call.Next := null; + Entry_Call.Mode := Timed_Call; + Entry_Call.Cancellation_Attempted := False; + + -- If this is a call made inside of an abort deferred region, + -- the call should be never abortable. + + Entry_Call.State := + (if Self_Id.Deferral_Level > 1 + then Never_Abortable + else Now_Abortable); + + Entry_Call.E := Entry_Index (E); + Entry_Call.Prio := Get_Priority (Self_Id); + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Called_Task := Acceptor; + Entry_Call.Called_PO := Null_Address; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + Entry_Call.With_Abort := True; + + -- Note: the caller will undefer abort on return (see WARNING above) + + if Single_Lock then + Lock_RTS; + end if; + + if not Task_Do_Or_Queue (Self_Id, Entry_Call) then + STPO.Write_Lock (Self_Id); + Utilities.Exit_One_ATC_Level (Self_Id); + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + + if Parameters.Runtime_Traces then + Send_Trace_Info (E_Missed, Acceptor); + end if; + raise Tasking_Error; + end if; + + Write_Lock (Self_Id); + Entry_Calls.Wait_For_Completion_With_Timeout + (Entry_Call, Timeout, Mode, Yielded); + Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + -- ??? Do we need to yield in case Yielded is False + + Rendezvous_Successful := Entry_Call.State = Done; + Initialization.Undefer_Abort (Self_Id); + Entry_Calls.Check_Exception (Self_Id, Entry_Call); + end Timed_Task_Entry_Call; + + ------------------- + -- Wait_For_Call -- + ------------------- + + procedure Wait_For_Call (Self_Id : Task_Id) is + begin + Self_Id.Common.State := Acceptor_Sleep; + + -- Try to remove calls to Sleep in the loop below by letting the caller + -- a chance of getting ready immediately, using Unlock & Yield. + -- See similar action in Wait_For_Completion & Timed_Selective_Wait. + + if Single_Lock then + Unlock_RTS; + else + Unlock (Self_Id); + end if; + + if Self_Id.Open_Accepts /= null then + Yield; + end if; + + if Single_Lock then + Lock_RTS; + else + Write_Lock (Self_Id); + end if; + + -- Check if this task has been aborted while the lock was released + + if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then + Self_Id.Open_Accepts := null; + end if; + + loop + exit when Self_Id.Open_Accepts = null; + Sleep (Self_Id, Acceptor_Sleep); + end loop; + + Self_Id.Common.State := Runnable; + end Wait_For_Call; + +end System.Tasking.Rendezvous; diff --git a/gcc/ada/s-tasren.ads b/gcc/ada/s-tasren.ads new file mode 100644 index 000000000..a9a9a2bbb --- /dev/null +++ b/gcc/ada/s-tasren.ads @@ -0,0 +1,329 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . R E N D E Z V O U S -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +with Ada.Exceptions; + +with System.Tasking.Protected_Objects.Entries; + +package System.Tasking.Rendezvous is + + package STPE renames System.Tasking.Protected_Objects.Entries; + + procedure Task_Entry_Call + (Acceptor : Task_Id; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address; + Mode : Call_Modes; + Rendezvous_Successful : out Boolean); + -- General entry call used to implement ATC or conditional entry calls. + -- Compiler interface only. Do not call from within the RTS. + -- Acceptor is the ID of the acceptor task. + -- E is the entry index requested. + -- Uninterpreted_Data represents the parameters of the entry. It is + -- constructed by the compiler for the caller and the callee; therefore, + -- the run time never needs to decode this data. + -- Mode can be either Asynchronous_Call (ATC) or Conditional_Call. + -- Rendezvous_Successful is set to True on return if the call was serviced. + + procedure Timed_Task_Entry_Call + (Acceptor : Task_Id; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Rendezvous_Successful : out Boolean); + -- Timed entry call without using ATC. + -- Compiler interface only. Do not call from within the RTS. + -- See Task_Entry_Call for details on Acceptor, E and Uninterpreted_Data. + -- Timeout is the value of the time out. + -- Mode determines whether the delay is relative or absolute. + + procedure Call_Simple + (Acceptor : Task_Id; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address); + -- Simple entry call. + -- Compiler interface only. Do not call from within the RTS. + -- + -- source: + -- T.E1 (Params); + -- + -- expansion: + -- declare + -- P : parms := (parm1, parm2, parm3); + -- X : Task_Entry_Index := 1; + -- begin + -- Call_Simple (t._task_id, X, P'Address); + -- parm1 := P.param1; + -- parm2 := P.param2; + -- ... + -- end; + + procedure Cancel_Task_Entry_Call (Cancelled : out Boolean); + -- Cancel pending asynchronous task entry call. + -- Compiler interface only. Do not call from within the RTS. + -- See Exp_Ch9.Expand_N_Asynchronous_Select for code expansion. + + procedure Requeue_Task_Entry + (Acceptor : Task_Id; + E : Task_Entry_Index; + With_Abort : Boolean); + -- Requeue from a task entry to a task entry. + -- Compiler interface only. Do not call from within the RTS. + -- The code generation for task entry requeues is different from that for + -- protected entry requeues. There is a "goto" that skips around the call + -- to Complete_Rendezvous, so that Requeue_Task_Entry must also do the work + -- of Complete_Rendezvous. The difference is that it does not report that + -- the call's State = Done. + -- + -- source: + -- accept e1 do + -- ...A... + -- requeue e2; + -- ...B... + -- end e1; + -- + -- expansion: + -- A62b : address; + -- L61b : label + -- begin + -- accept_call (1, A62b); + -- ...A... + -- requeue_task_entry (tTV!(t)._task_id, 2, false); + -- goto L61b; + -- ...B... + -- complete_rendezvous; + -- <> + -- exception + -- when others => + -- exceptional_complete_rendezvous (current_exception); + -- end; + + procedure Requeue_Protected_To_Task_Entry + (Object : STPE.Protection_Entries_Access; + Acceptor : Task_Id; + E : Task_Entry_Index; + With_Abort : Boolean); + -- Requeue from a protected entry to a task entry. + -- Compiler interface only. Do not call from within the RTS. + -- + -- source: + -- entry e2 when b is + -- begin + -- b := false; + -- ...A... + -- requeue t.e2; + -- end e2; + -- + -- expansion: + -- procedure rPT__E14b (O : address; P : address; E : + -- protected_entry_index) is + -- type rTVP is access rTV; + -- freeze rTVP [] + -- _object : rTVP := rTVP!(O); + -- begin + -- declare + -- rR : protection renames _object._object; + -- vP : integer renames _object.v; + -- bP : boolean renames _object.b; + -- begin + -- b := false; + -- ...A... + -- requeue_protected_to_task_entry (rR'unchecked_access, tTV!(t). + -- _task_id, 2, false); + -- return; + -- end; + -- complete_entry_body (_object._object'unchecked_access, objectF => + -- 0); + -- return; + -- exception + -- when others => + -- abort_undefer.all; + -- exceptional_complete_entry_body (_object._object' + -- unchecked_access, current_exception, objectF => 0); + -- return; + -- end rPT__E14b; + + procedure Selective_Wait + (Open_Accepts : Accept_List_Access; + Select_Mode : Select_Modes; + Uninterpreted_Data : out System.Address; + Index : out Select_Index); + -- Implement select statement. + -- Compiler interface only. Do not call from within the RTS. + -- See comments on Accept_Call. + -- + -- source: + -- select accept e1 do + -- ...A... + -- end e1; + -- ...B... + -- or accept e2; + -- ...C... + -- end select; + -- + -- expansion: + -- A32b : address; + -- declare + -- A37b : T36b; + -- A37b (1) := (null_body => false, s => 1); + -- A37b (2) := (null_body => true, s => 2); + -- S0 : aliased T36b := accept_list'A37b; + -- J1 : select_index := 0; + -- procedure e1A is + -- begin + -- abort_undefer.all; + -- ...A... + -- <> + -- complete_rendezvous; + -- exception + -- when all others => + -- exceptional_complete_rendezvous (get_gnat_exception); + -- end e1A; + -- begin + -- selective_wait (S0'unchecked_access, simple_mode, A32b, J1); + -- case J1 is + -- when 0 => + -- goto L3; + -- when 1 => + -- e1A; + -- goto L1; + -- when 2 => + -- goto L2; + -- when others => + -- goto L3; + -- end case; + -- <> + -- ...B... + -- goto L3; + -- <> + -- ...C... + -- goto L3; + -- <> + -- end; + + procedure Timed_Selective_Wait + (Open_Accepts : Accept_List_Access; + Select_Mode : Select_Modes; + Uninterpreted_Data : out System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Index : out Select_Index); + -- Selective wait with timeout without using ATC. + -- Compiler interface only. Do not call from within the RTS. + + procedure Accept_Call + (E : Task_Entry_Index; + Uninterpreted_Data : out System.Address); + -- Accept an entry call. + -- Compiler interface only. Do not call from within the RTS. + -- + -- source: + -- accept E do ...A... end E; + -- expansion: + -- A27b : address; + -- L26b : label + -- begin + -- accept_call (1, A27b); + -- ...A... + -- complete_rendezvous; + -- <> + -- exception + -- when all others => + -- exceptional_complete_rendezvous (get_gnat_exception); + -- end; + -- + -- The handler for Abort_Signal (*all* others) is to handle the case when + -- the acceptor is aborted between Accept_Call and the corresponding + -- Complete_Rendezvous call. We need to wake up the caller in this case. + -- + -- See also Selective_Wait + + procedure Accept_Trivial (E : Task_Entry_Index); + -- Accept an entry call that has no parameters and no body. + -- Compiler interface only. Do not call from within the RTS. + -- This should only be called when there is no accept body, or the accept + -- body is empty. + -- + -- source: + -- accept E; + -- expansion: + -- accept_trivial (1); + -- + -- The compiler is also able to recognize the following and + -- translate it the same way. + -- + -- accept E do null; end E; + + function Task_Count (E : Task_Entry_Index) return Natural; + -- Return number of tasks waiting on the entry E (of current task) + -- Compiler interface only. Do not call from within the RTS. + + function Callable (T : Task_Id) return Boolean; + -- Return T'Callable + -- Compiler interface. Do not call from within the RTS, except for body of + -- Ada.Task_Identification. + + type Task_Entry_Nesting_Depth is new Task_Entry_Index + range 0 .. Max_Task_Entry; + + function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id; + -- Return E'Caller. This will only work if called from within an + -- accept statement that is handling E, as required by the LRM (C.7.1(14)). + -- Compiler interface only. Do not call from within the RTS. + + procedure Complete_Rendezvous; + -- Called by acceptor to wake up caller + + procedure Exceptional_Complete_Rendezvous + (Ex : Ada.Exceptions.Exception_Id); + -- Called by acceptor to mark the end of the current rendezvous and + -- propagate an exception to the caller. + + -- For internal use only: + + function Task_Do_Or_Queue + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link) return Boolean; + -- Call this only with abort deferred and holding no locks, except + -- the global RTS lock when Single_Lock is True which must be owned. + -- Returns False iff the call cannot be served or queued, as is the + -- case if the caller is not callable; i.e., a False return value + -- indicates that Tasking_Error should be raised. + -- Either initiate the entry call, such that the accepting task is + -- free to execute the rendezvous, queue the call on the acceptor's + -- queue, or cancel the call. Conditional calls that cannot be + -- accepted immediately are cancelled. + +end System.Tasking.Rendezvous; diff --git a/gcc/ada/s-tasres.ads b/gcc/ada/s-tasres.ads new file mode 100644 index 000000000..9445744da --- /dev/null +++ b/gcc/ada/s-tasres.ads @@ -0,0 +1,35 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . R E S T R I C T E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the parent package of the GNAT restricted tasking run time + +package System.Tasking.Restricted is +end System.Tasking.Restricted; diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb new file mode 100644 index 000000000..1663b89c6 --- /dev/null +++ b/gcc/ada/s-tassta.adb @@ -0,0 +1,2026 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . S T A G E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, 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 Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +with Ada.Exceptions; +with Ada.Unchecked_Deallocation; + +with System.Interrupt_Management; +with System.Tasking.Debug; +with System.Address_Image; +with System.Task_Primitives; +with System.Task_Primitives.Operations; +with System.Tasking.Utilities; +with System.Tasking.Queuing; +with System.Tasking.Rendezvous; +with System.OS_Primitives; +with System.Secondary_Stack; +with System.Storage_Elements; +with System.Restrictions; +with System.Standard_Library; +with System.Traces.Tasking; +with System.Stack_Usage; + +with System.Soft_Links; +-- These are procedure pointers to non-tasking routines that use task +-- specific data. In the absence of tasking, these routines refer to global +-- data. In the presence of tasking, they must be replaced with pointers to +-- task-specific versions. Also used for Create_TSD, Destroy_TSD, +-- Get_Current_Excep, Finalize_Global_List, Task_Termination, Handler. + +with System.Tasking.Initialization; +pragma Elaborate_All (System.Tasking.Initialization); +-- This insures that tasking is initialized if any tasks are created + +package body System.Tasking.Stages is + + package STPO renames System.Task_Primitives.Operations; + package SSL renames System.Soft_Links; + package SSE renames System.Storage_Elements; + package SST renames System.Secondary_Stack; + + use Ada.Exceptions; + + use Parameters; + use Task_Primitives; + use Task_Primitives.Operations; + use Task_Info; + + use System.Traces; + use System.Traces.Tasking; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Free is new + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + + procedure Free_Entry_Names (T : Task_Id); + -- Deallocate all string names associated with task entries + + procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id); + -- This procedure outputs the task specific message for exception + -- tracing purposes. + + procedure Task_Wrapper (Self_ID : Task_Id); + pragma Convention (C, Task_Wrapper); + -- This is the procedure that is called by the GNULL from the new context + -- when a task is created. It waits for activation and then calls the task + -- body procedure. When the task body procedure completes, it terminates + -- the task. + -- + -- The Task_Wrapper's address will be provided to the underlying threads + -- library as the task entry point. Convention C is what makes most sense + -- for that purpose (Export C would make the function globally visible, + -- and affect the link name on which GDB depends). This will in addition + -- trigger an automatic stack alignment suitable for GCC's assumptions if + -- need be. + + -- "Vulnerable_..." in the procedure names below means they must be called + -- with abort deferred. + + procedure Vulnerable_Complete_Task (Self_ID : Task_Id); + -- Complete the calling task. This procedure must be called with + -- abort deferred. It should only be called by Complete_Task and + -- Finalize_Global_Tasks (for the environment task). + + procedure Vulnerable_Complete_Master (Self_ID : Task_Id); + -- Complete the current master of the calling task. This procedure + -- must be called with abort deferred. It should only be called by + -- Vulnerable_Complete_Task and Complete_Master. + + procedure Vulnerable_Complete_Activation (Self_ID : Task_Id); + -- Signal to Self_ID's activator that Self_ID has completed activation. + -- This procedure must be called with abort deferred. + + procedure Abort_Dependents (Self_ID : Task_Id); + -- Abort all the direct dependents of Self at its current master nesting + -- level, plus all of their dependents, transitively. RTS_Lock should be + -- locked by the caller. + + procedure Vulnerable_Free_Task (T : Task_Id); + -- Recover all runtime system storage associated with the task T. This + -- should only be called after T has terminated and will no longer be + -- referenced. + -- + -- For tasks created by an allocator that fails, due to an exception, it is + -- called from Expunge_Unactivated_Tasks. + -- + -- Different code is used at master completion, in Terminate_Dependents, + -- due to a need for tighter synchronization with the master. + + ---------------------- + -- Abort_Dependents -- + ---------------------- + + procedure Abort_Dependents (Self_ID : Task_Id) is + C : Task_Id; + P : Task_Id; + + begin + C := All_Tasks_List; + while C /= null loop + P := C.Common.Parent; + while P /= null loop + if P = Self_ID then + + -- ??? C is supposed to take care of its own dependents, so + -- there should be no need to worry about them. Need to double + -- check this. + + if C.Master_of_Task = Self_ID.Master_Within then + Utilities.Abort_One_Task (Self_ID, C); + C.Dependents_Aborted := True; + end if; + + exit; + end if; + + P := P.Common.Parent; + end loop; + + C := C.Common.All_Tasks_Link; + end loop; + + Self_ID.Dependents_Aborted := True; + end Abort_Dependents; + + ----------------- + -- Abort_Tasks -- + ----------------- + + procedure Abort_Tasks (Tasks : Task_List) is + begin + Utilities.Abort_Tasks (Tasks); + end Abort_Tasks; + + -------------------- + -- Activate_Tasks -- + -------------------- + + -- Note that locks of activator and activated task are both locked here. + -- This is necessary because C.Common.State and Self.Common.Wait_Count have + -- to be synchronized. This is safe from deadlock because the activator is + -- always created before the activated task. That satisfies our + -- in-order-of-creation ATCB locking policy. + + -- At one point, we may also lock the parent, if the parent is different + -- from the activator. That is also consistent with the lock ordering + -- policy, since the activator cannot be created before the parent. + + -- Since we are holding both the activator's lock, and Task_Wrapper locks + -- that before it does anything more than initialize the low-level ATCB + -- components, it should be safe to wait to update the counts until we see + -- that the thread creation is successful. + + -- If the thread creation fails, we do need to close the entries of the + -- task. The first phase, of dequeuing calls, only requires locking the + -- acceptor's ATCB, but the waking up of the callers requires locking the + -- caller's ATCB. We cannot safely do this while we are holding other + -- locks. Therefore, the queue-clearing operation is done in a separate + -- pass over the activation chain. + + procedure Activate_Tasks (Chain_Access : Activation_Chain_Access) is + Self_ID : constant Task_Id := STPO.Self; + P : Task_Id; + C : Task_Id; + Next_C, Last_C : Task_Id; + Activate_Prio : System.Any_Priority; + Success : Boolean; + All_Elaborated : Boolean := True; + + begin + -- If pragma Detect_Blocking is active, then we must check whether this + -- potentially blocking operation is called from a protected action. + + if System.Tasking.Detect_Blocking + and then Self_ID.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with "potentially blocking operation"; + end if; + + pragma Debug + (Debug.Trace (Self_ID, "Activate_Tasks", 'C')); + + Initialization.Defer_Abort_Nestable (Self_ID); + + pragma Assert (Self_ID.Common.Wait_Count = 0); + + -- Lock RTS_Lock, to prevent activated tasks from racing ahead before + -- we finish activating the chain. + + Lock_RTS; + + -- Check that all task bodies have been elaborated + + C := Chain_Access.T_ID; + Last_C := null; + while C /= null loop + if C.Common.Elaborated /= null + and then not C.Common.Elaborated.all + then + All_Elaborated := False; + end if; + + -- Reverse the activation chain so that tasks are activated in the + -- same order they're declared. + + Next_C := C.Common.Activation_Link; + C.Common.Activation_Link := Last_C; + Last_C := C; + C := Next_C; + end loop; + + Chain_Access.T_ID := Last_C; + + if not All_Elaborated then + Unlock_RTS; + Initialization.Undefer_Abort_Nestable (Self_ID); + raise Program_Error with "Some tasks have not been elaborated"; + end if; + + -- Activate all the tasks in the chain. Creation of the thread of + -- control was deferred until activation. So create it now. + + C := Chain_Access.T_ID; + while C /= null loop + if C.Common.State /= Terminated then + pragma Assert (C.Common.State = Unactivated); + + P := C.Common.Parent; + Write_Lock (P); + Write_Lock (C); + + Activate_Prio := + (if C.Common.Base_Priority < Get_Priority (Self_ID) + then Get_Priority (Self_ID) + else C.Common.Base_Priority); + + System.Task_Primitives.Operations.Create_Task + (C, Task_Wrapper'Address, + Parameters.Size_Type + (C.Common.Compiler_Data.Pri_Stack_Info.Size), + Activate_Prio, Success); + + -- There would be a race between the created task and the creator + -- to do the following initialization, if we did not have a + -- Lock/Unlock_RTS pair in the task wrapper to prevent it from + -- racing ahead. + + if Success then + C.Common.State := Activating; + C.Awake_Count := 1; + C.Alive_Count := 1; + P.Awake_Count := P.Awake_Count + 1; + P.Alive_Count := P.Alive_Count + 1; + + if P.Common.State = Master_Completion_Sleep and then + C.Master_of_Task = P.Master_Within + then + pragma Assert (Self_ID /= P); + P.Common.Wait_Count := P.Common.Wait_Count + 1; + end if; + + for J in System.Tasking.Debug.Known_Tasks'Range loop + if System.Tasking.Debug.Known_Tasks (J) = null then + System.Tasking.Debug.Known_Tasks (J) := C; + C.Known_Tasks_Index := J; + exit; + end if; + end loop; + + if Global_Task_Debug_Event_Set then + Debug.Signal_Debug_Event + (Debug.Debug_Event_Activating, C); + end if; + + C.Common.State := Runnable; + + Unlock (C); + Unlock (P); + + else + -- No need to set Awake_Count, State, etc. here since the loop + -- below will do that for any Unactivated tasks. + + Unlock (C); + Unlock (P); + Self_ID.Common.Activation_Failed := True; + end if; + end if; + + C := C.Common.Activation_Link; + end loop; + + if not Single_Lock then + Unlock_RTS; + end if; + + -- Close the entries of any tasks that failed thread creation, and count + -- those that have not finished activation. + + Write_Lock (Self_ID); + Self_ID.Common.State := Activator_Sleep; + + C := Chain_Access.T_ID; + while C /= null loop + Write_Lock (C); + + if C.Common.State = Unactivated then + C.Common.Activator := null; + C.Common.State := Terminated; + C.Callable := False; + Utilities.Cancel_Queued_Entry_Calls (C); + + elsif C.Common.Activator /= null then + Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; + end if; + + Unlock (C); + P := C.Common.Activation_Link; + C.Common.Activation_Link := null; + C := P; + end loop; + + -- Wait for the activated tasks to complete activation. It is + -- unsafe to abort any of these tasks until the count goes to zero. + + loop + exit when Self_ID.Common.Wait_Count = 0; + Sleep (Self_ID, Activator_Sleep); + end loop; + + Self_ID.Common.State := Runnable; + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + -- Remove the tasks from the chain + + Chain_Access.T_ID := null; + Initialization.Undefer_Abort_Nestable (Self_ID); + + if Self_ID.Common.Activation_Failed then + Self_ID.Common.Activation_Failed := False; + raise Tasking_Error with "Failure during activation"; + end if; + end Activate_Tasks; + + ------------------------- + -- Complete_Activation -- + ------------------------- + + procedure Complete_Activation is + Self_ID : constant Task_Id := STPO.Self; + + begin + Initialization.Defer_Abort_Nestable (Self_ID); + + if Single_Lock then + Lock_RTS; + end if; + + Vulnerable_Complete_Activation (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort_Nestable (Self_ID); + + -- ??? Why do we need to allow for nested deferral here? + + if Runtime_Traces then + Send_Trace_Info (T_Activate); + end if; + end Complete_Activation; + + --------------------- + -- Complete_Master -- + --------------------- + + procedure Complete_Master is + Self_ID : constant Task_Id := STPO.Self; + begin + pragma Assert + (Self_ID.Deferral_Level > 0 + or else not System.Restrictions.Abort_Allowed); + Vulnerable_Complete_Master (Self_ID); + end Complete_Master; + + ------------------- + -- Complete_Task -- + ------------------- + + -- See comments on Vulnerable_Complete_Task for details + + procedure Complete_Task is + Self_ID : constant Task_Id := STPO.Self; + + begin + pragma Assert + (Self_ID.Deferral_Level > 0 + or else not System.Restrictions.Abort_Allowed); + + Vulnerable_Complete_Task (Self_ID); + + -- All of our dependents have terminated. Never undefer abort again! + + end Complete_Task; + + ----------------- + -- Create_Task -- + ----------------- + + -- Compiler interface only. Do not call from within the RTS. This must be + -- called to create a new task. + + procedure Create_Task + (Priority : Integer; + Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; + Relative_Deadline : Ada.Real_Time.Time_Span; + Num_Entries : Task_Entry_Index; + Master : Master_Level; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Chain : in out Activation_Chain; + Task_Image : String; + Created_Task : out Task_Id; + Build_Entry_Names : Boolean) + is + T, P : Task_Id; + Self_ID : constant Task_Id := STPO.Self; + Success : Boolean; + Base_Priority : System.Any_Priority; + Len : Natural; + Base_CPU : System.Multiprocessors.CPU_Range; + + pragma Unreferenced (Relative_Deadline); + -- EDF scheduling is not supported by any of the target platforms so + -- this parameter is not passed any further. + + begin + -- If Master is greater than the current master, it means that Master + -- has already awaited its dependent tasks. This raises Program_Error, + -- by 4.8(10.3/2). See AI-280. Ignore this check for foreign threads. + + if Self_ID.Master_of_Task /= Foreign_Task_Level + and then Master > Self_ID.Master_Within + then + raise Program_Error with + "create task after awaiting termination"; + end if; + + -- If pragma Detect_Blocking is active must be checked whether this + -- potentially blocking operation is called from a protected action. + + if System.Tasking.Detect_Blocking + and then Self_ID.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with "potentially blocking operation"; + end if; + + pragma Debug (Debug.Trace (Self_ID, "Create_Task", 'C')); + + Base_Priority := + (if Priority = Unspecified_Priority + then Self_ID.Common.Base_Priority + else System.Any_Priority (Priority)); + + if CPU /= Unspecified_CPU + and then (CPU < Integer (System.Multiprocessors.CPU_Range'First) + or else CPU > Integer (System.Multiprocessors.CPU_Range'Last) + or else CPU > Integer (System.Multiprocessors.Number_Of_CPUs)) + then + raise Tasking_Error with "CPU not in range"; + + -- Normal CPU affinity + else + Base_CPU := + (if CPU = Unspecified_CPU + then Self_ID.Common.Base_CPU + else System.Multiprocessors.CPU_Range (CPU)); + end if; + + -- Find parent P of new Task, via master level number + + P := Self_ID; + + if P /= null then + while P.Master_of_Task >= Master loop + P := P.Common.Parent; + exit when P = null; + end loop; + end if; + + Initialization.Defer_Abort_Nestable (Self_ID); + + begin + T := New_ATCB (Num_Entries); + exception + when others => + Initialization.Undefer_Abort_Nestable (Self_ID); + raise Storage_Error with "Cannot allocate task"; + end; + + -- RTS_Lock is used by Abort_Dependents and Abort_Tasks. Up to this + -- point, it is possible that we may be part of a family of tasks that + -- is being aborted. + + Lock_RTS; + Write_Lock (Self_ID); + + -- Now, we must check that we have not been aborted. If so, we should + -- give up on creating this task, and simply return. + + if not Self_ID.Callable then + pragma Assert (Self_ID.Pending_ATC_Level = 0); + pragma Assert (Self_ID.Pending_Action); + pragma Assert + (Chain.T_ID = null or else Chain.T_ID.Common.State = Unactivated); + + Unlock (Self_ID); + Unlock_RTS; + Initialization.Undefer_Abort_Nestable (Self_ID); + + -- ??? Should never get here + + pragma Assert (False); + raise Standard'Abort_Signal; + end if; + + Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated, + Base_Priority, Base_CPU, Task_Info, Size, T, Success); + + if not Success then + Free (T); + Unlock (Self_ID); + Unlock_RTS; + Initialization.Undefer_Abort_Nestable (Self_ID); + raise Storage_Error with "Failed to initialize task"; + end if; + + if Master = Foreign_Task_Level + 2 then + + -- This should not happen, except when a foreign task creates non + -- library-level Ada tasks. In this case, we pretend the master is + -- a regular library level task, otherwise the run-time will get + -- confused when waiting for these tasks to terminate. + + T.Master_of_Task := Library_Task_Level; + + else + T.Master_of_Task := Master; + end if; + + T.Master_Within := T.Master_of_Task + 1; + + for L in T.Entry_Calls'Range loop + T.Entry_Calls (L).Self := T; + T.Entry_Calls (L).Level := L; + end loop; + + if Task_Image'Length = 0 then + T.Common.Task_Image_Len := 0; + else + Len := 1; + T.Common.Task_Image (1) := Task_Image (Task_Image'First); + + -- Remove unwanted blank space generated by 'Image + + for J in Task_Image'First + 1 .. Task_Image'Last loop + if Task_Image (J) /= ' ' + or else Task_Image (J - 1) /= '(' + then + Len := Len + 1; + T.Common.Task_Image (Len) := Task_Image (J); + exit when Len = T.Common.Task_Image'Last; + end if; + end loop; + + T.Common.Task_Image_Len := Len; + end if; + + Unlock (Self_ID); + Unlock_RTS; + + -- Note: we should not call 'new' while holding locks since new + -- may use locks (e.g. RTS_Lock under Windows) itself and cause a + -- deadlock. + + if Build_Entry_Names then + T.Entry_Names := + new Entry_Names_Array (1 .. Entry_Index (Num_Entries)); + end if; + + -- Create TSD as early as possible in the creation of a task, since it + -- may be used by the operation of Ada code within the task. + + SSL.Create_TSD (T.Common.Compiler_Data); + T.Common.Activation_Link := Chain.T_ID; + Chain.T_ID := T; + Initialization.Initialize_Attributes_Link.all (T); + Created_Task := T; + Initialization.Undefer_Abort_Nestable (Self_ID); + + if Runtime_Traces then + Send_Trace_Info (T_Create, T); + end if; + end Create_Task; + + -------------------- + -- Current_Master -- + -------------------- + + function Current_Master return Master_Level is + begin + return STPO.Self.Master_Within; + end Current_Master; + + ------------------ + -- Enter_Master -- + ------------------ + + procedure Enter_Master is + Self_ID : constant Task_Id := STPO.Self; + begin + Self_ID.Master_Within := Self_ID.Master_Within + 1; + end Enter_Master; + + ------------------------------- + -- Expunge_Unactivated_Tasks -- + ------------------------------- + + -- See procedure Close_Entries for the general case + + procedure Expunge_Unactivated_Tasks (Chain : in out Activation_Chain) is + Self_ID : constant Task_Id := STPO.Self; + C : Task_Id; + Call : Entry_Call_Link; + Temp : Task_Id; + + begin + pragma Debug + (Debug.Trace (Self_ID, "Expunge_Unactivated_Tasks", 'C')); + + Initialization.Defer_Abort_Nestable (Self_ID); + + -- ??? + -- Experimentation has shown that abort is sometimes (but not always) + -- already deferred when this is called. + + -- That may indicate an error. Find out what is going on + + C := Chain.T_ID; + while C /= null loop + pragma Assert (C.Common.State = Unactivated); + + Temp := C.Common.Activation_Link; + + if C.Common.State = Unactivated then + Lock_RTS; + Write_Lock (C); + + for J in 1 .. C.Entry_Num loop + Queuing.Dequeue_Head (C.Entry_Queues (J), Call); + pragma Assert (Call = null); + end loop; + + Unlock (C); + + Initialization.Remove_From_All_Tasks_List (C); + Unlock_RTS; + + Vulnerable_Free_Task (C); + C := Temp; + end if; + end loop; + + Chain.T_ID := null; + Initialization.Undefer_Abort_Nestable (Self_ID); + end Expunge_Unactivated_Tasks; + + --------------------------- + -- Finalize_Global_Tasks -- + --------------------------- + + -- ??? + -- We have a potential problem here if finalization of global objects does + -- anything with signals or the timer server, since by that time those + -- servers have terminated. + + -- It is hard to see how that would occur + + -- However, a better solution might be to do all this finalization + -- using the global finalization chain. + + procedure Finalize_Global_Tasks is + Self_ID : constant Task_Id := STPO.Self; + + Ignore : Boolean; + pragma Unreferenced (Ignore); + + function State + (Int : System.Interrupt_Management.Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state for interrupt number Int. Defined in init.c + + Default : constant Character := 's'; + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + + begin + if Self_ID.Deferral_Level = 0 then + -- ??? + -- In principle, we should be able to predict whether abort is + -- already deferred here (and it should not be deferred yet but in + -- practice it seems Finalize_Global_Tasks is being called sometimes, + -- from RTS code for exceptions, with abort already deferred. + + Initialization.Defer_Abort_Nestable (Self_ID); + + -- Never undefer again!!! + end if; + + -- This code is only executed by the environment task + + pragma Assert (Self_ID = Environment_Task); + + -- Set Environment_Task'Callable to false to notify library-level tasks + -- that it is waiting for them. + + Self_ID.Callable := False; + + -- Exit level 2 master, for normal tasks in library-level packages + + Complete_Master; + + -- Force termination of "independent" library-level server tasks + + Lock_RTS; + + Abort_Dependents (Self_ID); + + if not Single_Lock then + Unlock_RTS; + end if; + + -- We need to explicitly wait for the task to be terminated here + -- because on true concurrent system, we may end this procedure before + -- the tasks are really terminated. + + Write_Lock (Self_ID); + + -- If the Abort_Task signal is set to system, it means that we may not + -- have been able to abort all independent tasks (in particular + -- Server_Task may be blocked, waiting for a signal), in which case, + -- do not wait for Independent_Task_Count to go down to 0. + + if State + (System.Interrupt_Management.Abort_Task_Interrupt) /= Default + then + loop + exit when Utilities.Independent_Task_Count = 0; + + -- We used to yield here, but this did not take into account low + -- priority tasks that would cause dead lock in some cases (true + -- FIFO scheduling). + + Timed_Sleep + (Self_ID, 0.01, System.OS_Primitives.Relative, + Self_ID.Common.State, Ignore, Ignore); + end loop; + end if; + + -- ??? On multi-processor environments, it seems that the above loop + -- isn't sufficient, so we need to add an additional delay. + + Timed_Sleep + (Self_ID, 0.01, System.OS_Primitives.Relative, + Self_ID.Common.State, Ignore, Ignore); + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + -- Complete the environment task + + Vulnerable_Complete_Task (Self_ID); + + -- 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. + + SSL.Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence); + + -- Finalize the global list for controlled objects if needed + + SSL.Finalize_Global_List.all; + + -- Reset the soft links to non-tasking + + SSL.Abort_Defer := SSL.Abort_Defer_NT'Access; + SSL.Abort_Undefer := SSL.Abort_Undefer_NT'Access; + SSL.Lock_Task := SSL.Task_Lock_NT'Access; + SSL.Unlock_Task := SSL.Task_Unlock_NT'Access; + SSL.Get_Jmpbuf_Address := SSL.Get_Jmpbuf_Address_NT'Access; + SSL.Set_Jmpbuf_Address := SSL.Set_Jmpbuf_Address_NT'Access; + SSL.Get_Sec_Stack_Addr := SSL.Get_Sec_Stack_Addr_NT'Access; + SSL.Set_Sec_Stack_Addr := SSL.Set_Sec_Stack_Addr_NT'Access; + SSL.Check_Abort_Status := SSL.Check_Abort_Status_NT'Access; + SSL.Get_Stack_Info := SSL.Get_Stack_Info_NT'Access; + + -- Don't bother trying to finalize Initialization.Global_Task_Lock + -- and System.Task_Primitives.RTS_Lock. + + end Finalize_Global_Tasks; + + ---------------------- + -- Free_Entry_Names -- + ---------------------- + + procedure Free_Entry_Names (T : Task_Id) is + Names : Entry_Names_Array_Access := T.Entry_Names; + + procedure Free_Entry_Names_Array_Access is new + Ada.Unchecked_Deallocation + (Entry_Names_Array, Entry_Names_Array_Access); + + begin + if Names = null then + return; + end if; + + Free_Entry_Names_Array (Names.all); + Free_Entry_Names_Array_Access (Names); + end Free_Entry_Names; + + --------------- + -- Free_Task -- + --------------- + + procedure Free_Task (T : Task_Id) is + Self_Id : constant Task_Id := Self; + + begin + if T.Common.State = Terminated then + + -- It is not safe to call Abort_Defer or Write_Lock at this stage + + Initialization.Task_Lock (Self_Id); + + Lock_RTS; + Initialization.Finalize_Attributes_Link.all (T); + Initialization.Remove_From_All_Tasks_List (T); + Unlock_RTS; + + Initialization.Task_Unlock (Self_Id); + + Free_Entry_Names (T); + System.Task_Primitives.Operations.Finalize_TCB (T); + + -- If the task is not terminated, then we simply ignore the call. This + -- happens when a user program attempts an unchecked deallocation on + -- a non-terminated task. + + else + null; + end if; + end Free_Task; + + --------------------------- + -- Move_Activation_Chain -- + --------------------------- + + procedure Move_Activation_Chain + (From, To : Activation_Chain_Access; + New_Master : Master_ID) + is + Self_ID : constant Task_Id := STPO.Self; + C : Task_Id; + + begin + pragma Debug + (Debug.Trace (Self_ID, "Move_Activation_Chain", 'C')); + + -- Nothing to do if From is empty, and we can check that without + -- deferring aborts. + + C := From.all.T_ID; + + if C = null then + return; + end if; + + Initialization.Defer_Abort (Self_ID); + + -- Loop through the From chain, changing their Master_of_Task + -- fields, and to find the end of the chain. + + loop + C.Master_of_Task := New_Master; + exit when C.Common.Activation_Link = null; + C := C.Common.Activation_Link; + end loop; + + -- Hook From in at the start of To + + C.Common.Activation_Link := To.all.T_ID; + To.all.T_ID := From.all.T_ID; + + -- Set From to empty + + From.all.T_ID := null; + + Initialization.Undefer_Abort (Self_ID); + end Move_Activation_Chain; + + -- Compiler interface only. Do not call from within the RTS + + -------------------- + -- Set_Entry_Name -- + -------------------- + + procedure Set_Entry_Name + (T : Task_Id; + Pos : Task_Entry_Index; + Val : String_Access) + is + begin + pragma Assert (T.Entry_Names /= null); + + T.Entry_Names (Entry_Index (Pos)) := Val; + end Set_Entry_Name; + + ------------------ + -- Task_Wrapper -- + ------------------ + + -- The task wrapper is a procedure that is called first for each task body + -- and which in turn calls the compiler-generated task body procedure. + -- The wrapper's main job is to do initialization for the task. It also + -- has some locally declared objects that serve as per-task local data. + -- Task finalization is done by Complete_Task, which is called from an + -- at-end handler that the compiler generates. + + procedure Task_Wrapper (Self_ID : Task_Id) is + use type SSE.Storage_Offset; + use System.Standard_Library; + use System.Stack_Usage; + + Bottom_Of_Stack : aliased Integer; + + Task_Alternate_Stack : + aliased SSE.Storage_Array (1 .. Alternate_Stack_Size); + -- The alternate signal stack for this task, if any + + Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0; + -- Whether to use above alternate signal stack for stack overflows + + Secondary_Stack_Size : + constant SSE.Storage_Offset := + Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size * + SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100; + + Secondary_Stack : aliased SSE.Storage_Array (1 .. Secondary_Stack_Size); + + pragma Warnings (Off); + -- Why are warnings being turned off here??? + + Secondary_Stack_Address : System.Address := Secondary_Stack'Address; + -- Address of secondary stack. In the fixed secondary stack case, this + -- value is not modified, causing a warning, hence the bracketing with + -- Warnings (Off/On). But why is so much *more* bracketed??? + + Small_Overflow_Guard : constant := 12 * 1024; + -- Note: this used to be 4K, but was changed to 12K, since smaller + -- values resulted in segmentation faults from dynamic stack analysis. + + Big_Overflow_Guard : constant := 16 * 1024; + Small_Stack_Limit : constant := 64 * 1024; + -- ??? These three values are experimental, and seems to work on most + -- platforms. They still need to be analyzed further. They also need + -- documentation, what are they??? + + Size : Natural := + Natural (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size); + + Overflow_Guard : Natural; + -- Size of the overflow guard, used by dynamic stack usage analysis + + pragma Warnings (On); + + SEH_Table : aliased SSE.Storage_Array (1 .. 8); + -- Structured Exception Registration table (2 words) + + procedure Install_SEH_Handler (Addr : System.Address); + pragma Import (C, Install_SEH_Handler, "__gnat_install_SEH_handler"); + -- Install the SEH (Structured Exception Handling) handler + + Cause : Cause_Of_Termination := Normal; + -- Indicates the reason why this task terminates. Normal corresponds to + -- a task terminating due to completing the last statement of its body, + -- or as a result of waiting on a terminate alternative. If the task + -- terminates because it is being aborted then Cause will be set to + -- Abnormal. If the task terminates because of an exception raised by + -- the execution of its task body, then Cause is set to + -- Unhandled_Exception. + + EO : Exception_Occurrence; + -- If the task terminates because of an exception raised by the + -- execution of its task body, then EO will contain the associated + -- exception occurrence. Otherwise, it will contain Null_Occurrence. + + TH : Termination_Handler := null; + -- Pointer to the protected procedure to be executed upon task + -- termination. + + procedure Search_Fall_Back_Handler (ID : Task_Id); + -- Procedure that searches recursively a fall-back handler through the + -- master relationship. If the handler is found, its pointer is stored + -- in TH. + + ------------------------------ + -- Search_Fall_Back_Handler -- + ------------------------------ + + procedure Search_Fall_Back_Handler (ID : Task_Id) is + begin + -- If there is a fall back handler, store its pointer for later + -- execution. + + if ID.Common.Fall_Back_Handler /= null then + TH := ID.Common.Fall_Back_Handler; + + -- Otherwise look for a fall back handler in the parent + + elsif ID.Common.Parent /= null then + Search_Fall_Back_Handler (ID.Common.Parent); + + -- Otherwise, do nothing + + else + return; + end if; + end Search_Fall_Back_Handler; + + begin + pragma Assert (Self_ID.Deferral_Level = 1); + + -- Assume a size of the stack taken at this stage + + if not Parameters.Sec_Stack_Dynamic then + Self_ID.Common.Compiler_Data.Sec_Stack_Addr := + Secondary_Stack'Address; + SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last)); + Size := Size - Natural (Secondary_Stack_Size); + end if; + + if Use_Alternate_Stack then + Self_ID.Common.Task_Alternate_Stack := Task_Alternate_Stack'Address; + end if; + + -- Set the guard page at the bottom of the stack. The call to unprotect + -- the page is done in Terminate_Task + + Stack_Guard (Self_ID, True); + + -- Initialize low-level TCB components, that cannot be initialized by + -- the creator. Enter_Task sets Self_ID.LL.Thread + + Enter_Task (Self_ID); + + -- Initialize dynamic stack usage + + if System.Stack_Usage.Is_Enabled then + Overflow_Guard := + (if Size < Small_Stack_Limit + then Small_Overflow_Guard + else Big_Overflow_Guard); + + STPO.Lock_RTS; + Initialize_Analyzer + (Self_ID.Common.Analyzer, + Self_ID.Common.Task_Image + (1 .. Self_ID.Common.Task_Image_Len), + Natural + (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size), + Size - Overflow_Guard, + SSE.To_Integer (Bottom_Of_Stack'Address), + SSE.To_Integer + (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Limit)); + STPO.Unlock_RTS; + Fill_Stack (Self_ID.Common.Analyzer); + end if; + + -- We setup the SEH (Structured Exception Handling) handler if supported + -- on the target. + + Install_SEH_Handler (SEH_Table'Address); + + -- Initialize exception occurrence + + Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence); + + -- We lock RTS_Lock to wait for activator to finish activating the rest + -- of the chain, so that everyone in the chain comes out in priority + -- order. + + -- This also protects the value of + -- Self_ID.Common.Activator.Common.Wait_Count. + + Lock_RTS; + Unlock_RTS; + + if not System.Restrictions.Abort_Allowed then + + -- If Abort is not allowed, reset the deferral level since it will + -- not get changed by the generated code. Keeping a default value + -- of one would prevent some operations (e.g. select or delay) to + -- proceed successfully. + + Self_ID.Deferral_Level := 0; + end if; + + if Global_Task_Debug_Event_Set then + Debug.Signal_Debug_Event + (Debug.Debug_Event_Run, Self_ID); + end if; + + begin + -- We are separating the following portion of the code in order to + -- place the exception handlers in a different block. In this way, + -- we do not call Set_Jmpbuf_Address (which needs Self) before we + -- set Self in Enter_Task + + -- Call the task body procedure + + -- The task body is called with abort still deferred. That + -- eliminates a dangerous window, for which we had to patch-up in + -- Terminate_Task. + + -- During the expansion of the task body, we insert an RTS-call + -- to Abort_Undefer, at the first point where abort should be + -- allowed. + + Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg); + Initialization.Defer_Abort_Nestable (Self_ID); + + exception + -- We can't call Terminate_Task in the exception handlers below, + -- since there may be (e.g. in the case of GCC exception handling) + -- clean ups associated with the exception handler that need to + -- access task specific data. + + -- Defer abort so that this task can't be aborted while exiting + + when Standard'Abort_Signal => + Initialization.Defer_Abort_Nestable (Self_ID); + + -- Update the cause that motivated the task termination so that + -- the appropriate information is passed to the task termination + -- procedure. Task termination as a result of waiting on a + -- terminate alternative is a normal termination, although it is + -- implemented using the abort mechanisms. + + if Self_ID.Terminate_Alternative then + Cause := Normal; + + if Global_Task_Debug_Event_Set then + Debug.Signal_Debug_Event + (Debug.Debug_Event_Terminated, Self_ID); + end if; + else + Cause := Abnormal; + + if Global_Task_Debug_Event_Set then + Debug.Signal_Debug_Event + (Debug.Debug_Event_Abort_Terminated, Self_ID); + end if; + end if; + when others => + -- ??? Using an E : others here causes CD2C11A to fail on Tru64 + + Initialization.Defer_Abort_Nestable (Self_ID); + + -- Perform the task specific exception tracing duty. We handle + -- these outputs here and not in the common notification routine + -- because we need access to tasking related data and we don't + -- want to drag dependencies against tasking related units in the + -- the common notification units. Additionally, no trace is ever + -- triggered from the common routine for the Unhandled_Raise case + -- in tasks, since an exception never appears unhandled in this + -- context because of this handler. + + if Exception_Trace = Unhandled_Raise then + Trace_Unhandled_Exception_In_Task (Self_ID); + end if; + + -- Update the cause that motivated the task termination so that + -- the appropriate information is passed to the task termination + -- procedure, as well as the associated Exception_Occurrence. + + Cause := Unhandled_Exception; + + Save_Occurrence (EO, SSL.Get_Current_Excep.all.all); + + if Global_Task_Debug_Event_Set then + Debug.Signal_Debug_Event + (Debug.Debug_Event_Exception_Terminated, Self_ID); + end if; + end; + + -- Look for a task termination handler. This code is for all tasks but + -- the environment task. The task termination code for the environment + -- task is executed by SSL.Task_Termination_Handler. + + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + if Self_ID.Common.Specific_Handler /= null then + TH := Self_ID.Common.Specific_Handler; + else + -- Look for a fall-back handler following the master relationship + -- for the task. + + Search_Fall_Back_Handler (Self_ID); + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + -- Execute the task termination handler if we found it + + if TH /= null then + TH.all (Cause, Self_ID, EO); + end if; + + if System.Stack_Usage.Is_Enabled then + Compute_Result (Self_ID.Common.Analyzer); + Report_Result (Self_ID.Common.Analyzer); + end if; + + Terminate_Task (Self_ID); + end Task_Wrapper; + + -------------------- + -- Terminate_Task -- + -------------------- + + -- Before we allow the thread to exit, we must clean up. This is a + -- delicate job. We must wake up the task's master, who may immediately try + -- to deallocate the ATCB out from under the current task WHILE IT IS STILL + -- EXECUTING. + + -- To avoid this, the parent task must be blocked up to the latest + -- statement executed. The trouble is that we have another step that we + -- also want to postpone to the very end, i.e., calling SSL.Destroy_TSD. + -- We have to postpone that until the end because compiler-generated code + -- is likely to try to access that data at just about any point. + + -- We can't call Destroy_TSD while we are holding any other locks, because + -- it locks Global_Task_Lock, and our deadlock prevention rules require + -- that to be the outermost lock. Our first "solution" was to just lock + -- Global_Task_Lock in addition to the other locks, and force the parent to + -- also lock this lock between its wakeup and its freeing of the ATCB. See + -- Complete_Task for the parent-side of the code that has the matching + -- calls to Task_Lock and Task_Unlock. That was not really a solution, + -- since the operation Task_Unlock continued to access the ATCB after + -- unlocking, after which the parent was observed to race ahead, deallocate + -- the ATCB, and then reallocate it to another task. The call to + -- Undefer_Abort in Task_Unlock by the "terminated" task was overwriting + -- the data of the new task that reused the ATCB! To solve this problem, we + -- introduced the new operation Final_Task_Unlock. + + procedure Terminate_Task (Self_ID : Task_Id) is + Environment_Task : constant Task_Id := STPO.Environment_Task; + Master_of_Task : Integer; + + begin + Debug.Task_Termination_Hook; + + if Runtime_Traces then + Send_Trace_Info (T_Terminate); + end if; + + -- Since GCC cannot allocate stack chunks efficiently without reordering + -- some of the allocations, we have to handle this unexpected situation + -- here. We should normally never have to call Vulnerable_Complete_Task + -- here. + + if Self_ID.Common.Activator /= null then + Vulnerable_Complete_Task (Self_ID); + end if; + + Initialization.Task_Lock (Self_ID); + + if Single_Lock then + Lock_RTS; + end if; + + Master_of_Task := Self_ID.Master_of_Task; + + -- Check if the current task is an independent task If so, decrement + -- the Independent_Task_Count value. + + if Master_of_Task = Independent_Task_Level then + if Single_Lock then + Utilities.Independent_Task_Count := + Utilities.Independent_Task_Count - 1; + else + Write_Lock (Environment_Task); + Utilities.Independent_Task_Count := + Utilities.Independent_Task_Count - 1; + Unlock (Environment_Task); + end if; + end if; + + -- Unprotect the guard page if needed + + Stack_Guard (Self_ID, False); + + Utilities.Make_Passive (Self_ID, Task_Completed => True); + + if Single_Lock then + Unlock_RTS; + end if; + + pragma Assert (Check_Exit (Self_ID)); + + SSL.Destroy_TSD (Self_ID.Common.Compiler_Data); + Initialization.Final_Task_Unlock (Self_ID); + + -- WARNING: past this point, this thread must assume that the ATCB has + -- been deallocated. It should not be accessed again. + + if Master_of_Task > 0 then + STPO.Exit_Task; + end if; + end Terminate_Task; + + ---------------- + -- Terminated -- + ---------------- + + function Terminated (T : Task_Id) return Boolean is + Self_ID : constant Task_Id := STPO.Self; + Result : Boolean; + + begin + Initialization.Defer_Abort_Nestable (Self_ID); + + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (T); + Result := T.Common.State = Terminated; + Unlock (T); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort_Nestable (Self_ID); + return Result; + end Terminated; + + ---------------------------------------- + -- Trace_Unhandled_Exception_In_Task -- + ---------------------------------------- + + procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id) is + procedure To_Stderr (S : String); + pragma Import (Ada, To_Stderr, "__gnat_to_stderr"); + + use System.Soft_Links; + use System.Standard_Library; + + function To_Address is new + Ada.Unchecked_Conversion + (Task_Id, System.Task_Primitives.Task_Address); + + function Tailored_Exception_Information + (E : Exception_Occurrence) return String; + pragma Import + (Ada, Tailored_Exception_Information, + "__gnat_tailored_exception_information"); + + Excep : constant Exception_Occurrence_Access := + SSL.Get_Current_Excep.all; + + begin + -- This procedure is called by the task outermost handler in + -- Task_Wrapper below, so only once the task stack has been fully + -- unwound. The common notification routine has been called at the + -- raise point already. + + -- Lock to prevent unsynchronized output + + Initialization.Task_Lock (Self_Id); + To_Stderr ("task "); + + if Self_Id.Common.Task_Image_Len /= 0 then + To_Stderr + (Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len)); + To_Stderr ("_"); + end if; + + To_Stderr (System.Address_Image (To_Address (Self_Id))); + To_Stderr (" terminated by unhandled exception"); + To_Stderr ((1 => ASCII.LF)); + To_Stderr (Tailored_Exception_Information (Excep.all)); + Initialization.Task_Unlock (Self_Id); + end Trace_Unhandled_Exception_In_Task; + + ------------------------------------ + -- Vulnerable_Complete_Activation -- + ------------------------------------ + + -- As in several other places, the locks of the activator and activated + -- task are both locked here. This follows our deadlock prevention lock + -- ordering policy, since the activated task must be created after the + -- activator. + + procedure Vulnerable_Complete_Activation (Self_ID : Task_Id) is + Activator : constant Task_Id := Self_ID.Common.Activator; + + begin + pragma Debug (Debug.Trace (Self_ID, "V_Complete_Activation", 'C')); + + Write_Lock (Activator); + Write_Lock (Self_ID); + + pragma Assert (Self_ID.Common.Activator /= null); + + -- Remove dangling reference to Activator, since a task may + -- outlive its activator. + + Self_ID.Common.Activator := null; + + -- Wake up the activator, if it is waiting for a chain of tasks to + -- activate, and we are the last in the chain to complete activation. + + if Activator.Common.State = Activator_Sleep then + Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1; + + if Activator.Common.Wait_Count = 0 then + Wakeup (Activator, Activator_Sleep); + end if; + end if; + + -- The activator raises a Tasking_Error if any task it is activating + -- is completed before the activation is done. However, if the reason + -- for the task completion is an abort, we do not raise an exception. + -- See RM 9.2(5). + + if not Self_ID.Callable and then Self_ID.Pending_ATC_Level /= 0 then + Activator.Common.Activation_Failed := True; + end if; + + Unlock (Self_ID); + Unlock (Activator); + + -- After the activation, active priority should be the same as base + -- priority. We must unlock the Activator first, though, since it + -- should not wait if we have lower priority. + + if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then + Write_Lock (Self_ID); + Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + Unlock (Self_ID); + end if; + end Vulnerable_Complete_Activation; + + -------------------------------- + -- Vulnerable_Complete_Master -- + -------------------------------- + + procedure Vulnerable_Complete_Master (Self_ID : Task_Id) is + C : Task_Id; + P : Task_Id; + CM : constant Master_Level := Self_ID.Master_Within; + T : aliased Task_Id; + + To_Be_Freed : Task_Id; + -- This is a list of ATCBs to be freed, after we have released all RTS + -- locks. This is necessary because of the locking order rules, since + -- the storage manager uses Global_Task_Lock. + + pragma Warnings (Off); + function Check_Unactivated_Tasks return Boolean; + pragma Warnings (On); + -- Temporary error-checking code below. This is part of the checks + -- added in the new run time. Call it only inside a pragma Assert. + + ----------------------------- + -- Check_Unactivated_Tasks -- + ----------------------------- + + function Check_Unactivated_Tasks return Boolean is + begin + if not Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + C := All_Tasks_List; + while C /= null loop + if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then + return False; + end if; + + if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then + Write_Lock (C); + + if C.Common.State = Unactivated then + return False; + end if; + + Unlock (C); + end if; + + C := C.Common.All_Tasks_Link; + end loop; + + Unlock (Self_ID); + + if not Single_Lock then + Unlock_RTS; + end if; + + return True; + end Check_Unactivated_Tasks; + + -- Start of processing for Vulnerable_Complete_Master + + begin + pragma Debug + (Debug.Trace (Self_ID, "V_Complete_Master", 'C')); + + pragma Assert (Self_ID.Common.Wait_Count = 0); + pragma Assert + (Self_ID.Deferral_Level > 0 + or else not System.Restrictions.Abort_Allowed); + + -- Count how many active dependent tasks this master currently has, and + -- record this in Wait_Count. + + -- This count should start at zero, since it is initialized to zero for + -- new tasks, and the task should not exit the sleep-loops that use this + -- count until the count reaches zero. + + -- While we're counting, if we run across any unactivated tasks that + -- belong to this master, we summarily terminate them as required by + -- RM-9.2(6). + + Lock_RTS; + Write_Lock (Self_ID); + + C := All_Tasks_List; + while C /= null loop + + -- Terminate unactivated (never-to-be activated) tasks + + if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then + + pragma Assert (C.Common.State = Unactivated); + -- Usually, C.Common.Activator = Self_ID implies C.Master_of_Task + -- = CM. The only case where C is pending activation by this + -- task, but the master of C is not CM is in Ada 2005, when C is + -- part of a return object of a build-in-place function. + + Write_Lock (C); + C.Common.Activator := null; + C.Common.State := Terminated; + C.Callable := False; + Utilities.Cancel_Queued_Entry_Calls (C); + Unlock (C); + end if; + + -- Count it if dependent on this master + + if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then + Write_Lock (C); + + if C.Awake_Count /= 0 then + Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; + end if; + + Unlock (C); + end if; + + C := C.Common.All_Tasks_Link; + end loop; + + Self_ID.Common.State := Master_Completion_Sleep; + Unlock (Self_ID); + + if not Single_Lock then + Unlock_RTS; + end if; + + -- Wait until dependent tasks are all terminated or ready to terminate. + -- While waiting, the task may be awakened if the task's priority needs + -- changing, or this master is aborted. In the latter case, we abort the + -- dependents, and resume waiting until Wait_Count goes to zero. + + Write_Lock (Self_ID); + + loop + exit when Self_ID.Common.Wait_Count = 0; + + -- Here is a difference as compared to Complete_Master + + if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + and then not Self_ID.Dependents_Aborted + then + if Single_Lock then + Abort_Dependents (Self_ID); + else + Unlock (Self_ID); + Lock_RTS; + Abort_Dependents (Self_ID); + Unlock_RTS; + Write_Lock (Self_ID); + end if; + else + Sleep (Self_ID, Master_Completion_Sleep); + end if; + end loop; + + Self_ID.Common.State := Runnable; + Unlock (Self_ID); + + -- Dependents are all terminated or on terminate alternatives. Now, + -- force those on terminate alternatives to terminate, by aborting them. + + pragma Assert (Check_Unactivated_Tasks); + + if Self_ID.Alive_Count > 1 then + -- ??? + -- Consider finding a way to skip the following extra steps if there + -- are no dependents with terminate alternatives. This could be done + -- by adding another count to the ATCB, similar to Awake_Count, but + -- keeping track of tasks that are on terminate alternatives. + + pragma Assert (Self_ID.Common.Wait_Count = 0); + + -- Force any remaining dependents to terminate by aborting them + + if not Single_Lock then + Lock_RTS; + end if; + + Abort_Dependents (Self_ID); + + -- Above, when we "abort" the dependents we are simply using this + -- operation for convenience. We are not required to support the full + -- abort-statement semantics; in particular, we are not required to + -- immediately cancel any queued or in-service entry calls. That is + -- good, because if we tried to cancel a call we would need to lock + -- the caller, in order to wake the caller up. Our anti-deadlock + -- rules prevent us from doing that without releasing the locks on C + -- and Self_ID. Releasing and retaking those locks would be wasteful + -- at best, and should not be considered further without more + -- detailed analysis of potential concurrent accesses to the ATCBs + -- of C and Self_ID. + + -- Count how many "alive" dependent tasks this master currently has, + -- and record this in Wait_Count. This count should start at zero, + -- since it is initialized to zero for new tasks, and the task should + -- not exit the sleep-loops that use this count until the count + -- reaches zero. + + pragma Assert (Self_ID.Common.Wait_Count = 0); + + Write_Lock (Self_ID); + + C := All_Tasks_List; + while C /= null loop + if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then + Write_Lock (C); + + pragma Assert (C.Awake_Count = 0); + + if C.Alive_Count > 0 then + pragma Assert (C.Terminate_Alternative); + Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; + end if; + + Unlock (C); + end if; + + C := C.Common.All_Tasks_Link; + end loop; + + Self_ID.Common.State := Master_Phase_2_Sleep; + Unlock (Self_ID); + + if not Single_Lock then + Unlock_RTS; + end if; + + -- Wait for all counted tasks to finish terminating themselves + + Write_Lock (Self_ID); + + loop + exit when Self_ID.Common.Wait_Count = 0; + Sleep (Self_ID, Master_Phase_2_Sleep); + end loop; + + Self_ID.Common.State := Runnable; + Unlock (Self_ID); + end if; + + -- We don't wake up for abort here. We are already terminating just as + -- fast as we can, so there is no point. + + -- Remove terminated tasks from the list of Self_ID's dependents, but + -- don't free their ATCBs yet, because of lock order restrictions, which + -- don't allow us to call "free" or "malloc" while holding any other + -- locks. Instead, we put those ATCBs to be freed onto a temporary list, + -- called To_Be_Freed. + + if not Single_Lock then + Lock_RTS; + end if; + + C := All_Tasks_List; + P := null; + while C /= null loop + if C.Common.Parent = Self_ID and then C.Master_of_Task >= CM then + if P /= null then + P.Common.All_Tasks_Link := C.Common.All_Tasks_Link; + else + All_Tasks_List := C.Common.All_Tasks_Link; + end if; + + T := C.Common.All_Tasks_Link; + C.Common.All_Tasks_Link := To_Be_Freed; + To_Be_Freed := C; + C := T; + + else + P := C; + C := C.Common.All_Tasks_Link; + end if; + end loop; + + Unlock_RTS; + + -- Free all the ATCBs on the list To_Be_Freed + + -- The ATCBs in the list are no longer in All_Tasks_List, and after + -- any interrupt entries are detached from them they should no longer + -- be referenced. + + -- Global_Task_Lock (Task_Lock/Unlock) is locked in the loop below to + -- avoid a race between a terminating task and its parent. The parent + -- might try to deallocate the ACTB out from underneath the exiting + -- task. Note that Free will also lock Global_Task_Lock, but that is + -- OK, since this is the *one* lock for which we have a mechanism to + -- support nested locking. See Task_Wrapper and its finalizer for more + -- explanation. + + -- ??? + -- The check "T.Common.Parent /= null ..." below is to prevent dangling + -- references to terminated library-level tasks, which could otherwise + -- occur during finalization of library-level objects. A better solution + -- might be to hook task objects into the finalization chain and + -- deallocate the ATCB when the task object is deallocated. However, + -- this change is not likely to gain anything significant, since all + -- this storage should be recovered en-masse when the process exits. + + while To_Be_Freed /= null loop + T := To_Be_Freed; + To_Be_Freed := T.Common.All_Tasks_Link; + + -- ??? On SGI there is currently no Interrupt_Manager, that's why we + -- need to check if the Interrupt_Manager_ID is null. + + if T.Interrupt_Entry and then Interrupt_Manager_ID /= null then + declare + Detach_Interrupt_Entries_Index : constant Task_Entry_Index := 1; + -- Corresponds to the entry index of System.Interrupts. + -- Interrupt_Manager.Detach_Interrupt_Entries. + -- Be sure to update this value when changing + -- Interrupt_Manager specs. + + type Param_Type is access all Task_Id; + + Param : aliased Param_Type := T'Access; + + begin + System.Tasking.Rendezvous.Call_Simple + (Interrupt_Manager_ID, Detach_Interrupt_Entries_Index, + Param'Address); + end; + end if; + + if (T.Common.Parent /= null + and then T.Common.Parent.Common.Parent /= null) + or else T.Master_of_Task > Library_Task_Level + then + Initialization.Task_Lock (Self_ID); + + -- If Sec_Stack_Addr is not null, it means that Destroy_TSD + -- has not been called yet (case of an unactivated task). + + if T.Common.Compiler_Data.Sec_Stack_Addr /= Null_Address then + SSL.Destroy_TSD (T.Common.Compiler_Data); + end if; + + Vulnerable_Free_Task (T); + Initialization.Task_Unlock (Self_ID); + end if; + end loop; + + -- It might seem nice to let the terminated task deallocate its own + -- ATCB. That would not cover the case of unactivated tasks. It also + -- would force us to keep the underlying thread around past termination, + -- since references to the ATCB are possible past termination. + + -- Currently, we get rid of the thread as soon as the task terminates, + -- and let the parent recover the ATCB later. + + -- Some day, if we want to recover the ATCB earlier, at task + -- termination, we could consider using "fat task IDs", that include the + -- serial number with the ATCB pointer, to catch references to tasks + -- that no longer have ATCBs. It is not clear how much this would gain, + -- since the user-level task object would still be occupying storage. + + -- Make next master level up active. We don't need to lock the ATCB, + -- since the value is only updated by each task for itself. + + Self_ID.Master_Within := CM - 1; + end Vulnerable_Complete_Master; + + ------------------------------ + -- Vulnerable_Complete_Task -- + ------------------------------ + + -- Complete the calling task + + -- This procedure must be called with abort deferred. It should only be + -- called by Complete_Task and Finalize_Global_Tasks (for the environment + -- task). + + -- The effect is similar to that of Complete_Master. Differences include + -- the closing of entries here, and computation of the number of active + -- dependent tasks in Complete_Master. + + -- We don't lock Self_ID before the call to Vulnerable_Complete_Activation, + -- because that does its own locking, and because we do not need the lock + -- to test Self_ID.Common.Activator. That value should only be read and + -- modified by Self. + + procedure Vulnerable_Complete_Task (Self_ID : Task_Id) is + begin + pragma Assert + (Self_ID.Deferral_Level > 0 + or else not System.Restrictions.Abort_Allowed); + pragma Assert (Self_ID = Self); + pragma Assert (Self_ID.Master_Within = Self_ID.Master_of_Task + 1 + or else + Self_ID.Master_Within = Self_ID.Master_of_Task + 2); + pragma Assert (Self_ID.Common.Wait_Count = 0); + pragma Assert (Self_ID.Open_Accepts = null); + pragma Assert (Self_ID.ATC_Nesting_Level = 1); + + pragma Debug (Debug.Trace (Self_ID, "V_Complete_Task", 'C')); + + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + Self_ID.Callable := False; + + -- In theory, Self should have no pending entry calls left on its + -- call-stack. Each async. select statement should clean its own call, + -- and blocking entry calls should defer abort until the calls are + -- cancelled, then clean up. + + Utilities.Cancel_Queued_Entry_Calls (Self_ID); + Unlock (Self_ID); + + if Self_ID.Common.Activator /= null then + Vulnerable_Complete_Activation (Self_ID); + end if; + + if Single_Lock then + Unlock_RTS; + end if; + + -- If Self_ID.Master_Within = Self_ID.Master_of_Task + 2 we may have + -- dependent tasks for which we need to wait. Otherwise we just exit. + + if Self_ID.Master_Within = Self_ID.Master_of_Task + 2 then + Vulnerable_Complete_Master (Self_ID); + end if; + end Vulnerable_Complete_Task; + + -------------------------- + -- Vulnerable_Free_Task -- + -------------------------- + + -- Recover all runtime system storage associated with the task T. This + -- should only be called after T has terminated and will no longer be + -- referenced. + + -- For tasks created by an allocator that fails, due to an exception, it + -- is called from Expunge_Unactivated_Tasks. + + -- For tasks created by elaboration of task object declarations it is + -- called from the finalization code of the Task_Wrapper procedure. It is + -- also called from Ada.Unchecked_Deallocation, for objects that are or + -- contain tasks. + + procedure Vulnerable_Free_Task (T : Task_Id) is + begin + pragma Debug (Debug.Trace (Self, "Vulnerable_Free_Task", 'C', T)); + + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (T); + Initialization.Finalize_Attributes_Link.all (T); + Unlock (T); + + if Single_Lock then + Unlock_RTS; + end if; + + Free_Entry_Names (T); + System.Task_Primitives.Operations.Finalize_TCB (T); + end Vulnerable_Free_Task; + +-- Package elaboration code + +begin + -- Establish the Adafinal oftlink + + -- This is not done inside the central RTS initialization routine + -- to avoid with-ing this package from System.Tasking.Initialization. + + SSL.Adafinal := Finalize_Global_Tasks'Access; + + -- Establish soft links for subprograms that manipulate master_id's. + -- This cannot be done when the RTS is initialized, because of various + -- elaboration constraints. + + SSL.Current_Master := Stages.Current_Master'Access; + SSL.Enter_Master := Stages.Enter_Master'Access; + SSL.Complete_Master := Stages.Complete_Master'Access; +end System.Tasking.Stages; diff --git a/gcc/ada/s-tassta.ads b/gcc/ada/s-tassta.ads new file mode 100644 index 000000000..6b8c7d7df --- /dev/null +++ b/gcc/ada/s-tassta.ads @@ -0,0 +1,310 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . S T A G E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2010, 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 represents the high level tasking interface used by the +-- compiler to expand Ada 95 tasking constructs into simpler run time calls +-- (aka GNARLI, GNU Ada Run-time Library Interface) + +-- Note: Only the compiler is allowed to use this interface, by generating +-- direct calls to it, via Rtsfind. + +-- Any changes to this interface may require corresponding compiler changes +-- in exp_ch9.adb and possibly exp_ch7.adb + +with System.Task_Info; +with System.Parameters; + +with Ada.Real_Time; + +package System.Tasking.Stages is + pragma Elaborate_Body; + + -- The compiler will expand in the GNAT tree the following construct: + + -- task type T (Discr : Integer); + + -- task body T is + -- ...declarations, possibly some controlled... + -- begin + -- ...B...; + -- end T; + + -- T1 : T (1); + + -- as follows: + + -- enter_master.all; + + -- _chain : aliased activation_chain; + -- activation_chainIP (_chain); + + -- task type t (discr : integer); + -- tE : aliased boolean := false; + -- tZ : size_type := unspecified_size; + -- type tV (discr : integer) is limited record + -- _task_id : task_id; + -- end record; + -- procedure tB (_task : access tV); + -- freeze tV [ + -- procedure tVIP (_init : in out tV; _master : master_id; + -- _chain : in out activation_chain; _task_id : in task_image_type; + -- discr : integer) is + -- begin + -- _init.discr := discr; + -- _init._task_id := null; + -- create_task (unspecified_priority, tZ, + -- unspecified_task_info, unspecified_cpu, + -- ada__real_time__time_span_zero, 0, _master, + -- task_procedure_access!(tB'address), _init'address, + -- tE'unchecked_access, _chain, _task_id, _init._task_id); + -- return; + -- end tVIP; + -- ] + + -- procedure tB (_task : access tV) is + -- discr : integer renames _task.discr; + + -- procedure _clean is + -- begin + -- abort_defer.all; + -- complete_task; + -- finalize_list (F14b); + -- abort_undefer.all; + -- return; + -- end _clean; + -- begin + -- abort_undefer.all; + -- ...declarations... + -- complete_activation; + -- ...B...; + -- return; + -- at end + -- _clean; + -- end tB; + + -- tE := true; + -- t1 : t (1); + -- _master : constant master_id := current_master.all; + -- t1S : task_image_type := new string'"t1"; + -- task_image_typeIP (t1, _master, _chain, t1S, 1); + + -- activate_tasks (_chain'unchecked_access); + + procedure Abort_Tasks (Tasks : Task_List); + -- Compiler interface only. Do not call from within the RTS. Initiate + -- abort, however, the actual abort is done by abortee by means of + -- Abort_Handler and Abort_Undefer + -- + -- source code: + -- Abort T1, T2; + -- code expansion: + -- abort_tasks (task_list'(t1._task_id, t2._task_id)); + + procedure Activate_Tasks (Chain_Access : Activation_Chain_Access); + -- Compiler interface only. Do not call from within the RTS. + -- This must be called by the creator of a chain of one or more new tasks, + -- to activate them. The chain is a linked list that up to this point is + -- only known to the task that created them, though the individual tasks + -- are already in the All_Tasks_List. + -- + -- The compiler builds the chain in LIFO order (as a stack). Another + -- version of this procedure had code to reverse the chain, so as to + -- activate the tasks in the order of declaration. This might be nice, but + -- it is not needed if priority-based scheduling is supported, since all + -- the activated tasks synchronize on the activators lock before they + -- start activating and so they should start activating in priority order. + -- ??? Actually, the body of this package DOES reverse the chain, so I + -- don't understand the above comment. + + procedure Complete_Activation; + -- Compiler interface only. Do not call from within the RTS. + -- This should be called from the task body at the end of + -- the elaboration code for its declarative part. + -- Decrement the count of tasks to be activated by the activator and + -- wake it up so it can check to see if all tasks have been activated. + -- Except for the environment task, which should never call this procedure, + -- T.Activator should only be null iff T has completed activation. + + procedure Complete_Master; + -- Compiler interface only. Do not call from within the RTS. This must + -- be called on exit from any master where Enter_Master was called. + -- Assume abort is deferred at this point. + + procedure Complete_Task; + -- Compiler interface only. Do not call from within the RTS. + -- This should be called from an implicit at-end handler + -- associated with the task body, when it completes. + -- From this point, the current task will become not callable. + -- If the current task have not completed activation, this should be done + -- now in order to wake up the activator (the environment task). + + procedure Create_Task + (Priority : Integer; + Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; + Relative_Deadline : Ada.Real_Time.Time_Span; + Num_Entries : Task_Entry_Index; + Master : Master_Level; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Chain : in out Activation_Chain; + Task_Image : String; + Created_Task : out Task_Id; + Build_Entry_Names : Boolean); + -- Compiler interface only. Do not call from within the RTS. + -- This must be called to create a new task. + -- + -- Priority is the task's priority (assumed to be in range of type + -- System.Any_Priority) + -- Size is the stack size of the task to create + -- Task_Info is the task info associated with the created task, or + -- Unspecified_Task_Info if none. + -- CPU is the task affinity. Passed as an Integer because the undefined + -- value is not in the range of CPU_Range. Static range checks are + -- performed when analyzing the pragma, and dynamic ones are performed + -- before setting the affinity at run time. + -- Relative_Deadline is the relative deadline associated with the created + -- task by means of a pragma Relative_Deadline, or 0.0 if none. + -- State is the compiler generated task's procedure body + -- Discriminants is a pointer to a limited record whose discriminants + -- are those of the task to create. This parameter should be passed as + -- the single argument to State. + -- Elaborated is a pointer to a Boolean that must be set to true on exit + -- if the task could be successfully elaborated. + -- Chain is a linked list of task that needs to be created. On exit, + -- Created_Task.Activation_Link will be Chain.T_ID, and Chain.T_ID + -- will be Created_Task (e.g the created task will be linked at the front + -- of Chain). + -- Task_Image is a string created by the compiler that the + -- run time can store to ease the debugging and the + -- Ada.Task_Identification facility. + -- Created_Task is the resulting task. + -- Build_Entry_Names is a flag which controls the allocation of the data + -- structure which stores all entry names. + -- + -- This procedure can raise Storage_Error if the task creation failed. + + function Current_Master return Master_Level; + -- Compiler interface only. + -- This is called to obtain the current master nesting level. + + procedure Enter_Master; + -- Compiler interface only. Do not call from within the RTS. + -- This must be called on entry to any "master" where a task, + -- or access type designating objects containing tasks, may be + -- declared. + + procedure Expunge_Unactivated_Tasks (Chain : in out Activation_Chain); + -- Compiler interface only. Do not call from within the RTS. + -- This must be called by the compiler-generated code for an allocator if + -- the allocated object contains tasks, if the allocator exits without + -- calling Activate_Tasks for a given activation chains, as can happen if + -- an exception occurs during initialization of the object. + -- + -- This should be called ONLY for tasks created via an allocator. Recovery + -- of storage for unactivated local task declarations is done by + -- Complete_Master and Complete_Task. + -- + -- We remove each task from Chain and All_Tasks_List before we free the + -- storage of its ATCB. + -- + -- In other places where we recover the storage of unactivated tasks, we + -- need to clean out the entry queues, but here that should not be + -- necessary, since these tasks should not have been visible to any other + -- tasks, and so no task should be able to queue a call on their entries. + -- + -- Just in case somebody misuses this subprogram, there is a check to + -- verify this condition. + + procedure Finalize_Global_Tasks; + -- This should be called to complete the execution of the environment task + -- and shut down the tasking runtime system. It is the equivalent of + -- Complete_Task, but for the environment task. + -- + -- The environment task must first call Complete_Master, to wait for user + -- tasks that depend on library-level packages to terminate. It then calls + -- Abort_Dependents to abort the "independent" library-level server tasks + -- that are created implicitly by the RTS packages (signal and timer server + -- tasks), and then waits for them to terminate. Then, it calls + -- Vulnerable_Complete_Task. + -- + -- It currently also executes the global finalization list, and then resets + -- the "soft links". + + procedure Free_Task (T : Task_Id); + -- Recover all runtime system storage associated with the task T, but only + -- if T has terminated. Do nothing in the other case. It is called from + -- Unchecked_Deallocation, for objects that are or contain tasks. + + procedure Move_Activation_Chain + (From, To : Activation_Chain_Access; + New_Master : Master_ID); + -- Compiler interface only. Do not call from within the RTS. + -- Move all tasks on From list to To list, and change their Master_of_Task + -- to be New_Master. This is used to implement build-in-place function + -- returns. Tasks that are part of the return object are initially placed + -- on an activation chain local to the return statement, and their master + -- is the return statement, in case the return statement is left + -- prematurely (due to raising an exception, being aborted, or a goto or + -- exit statement). Once the return statement has completed successfully, + -- Move_Activation_Chain is called to move them to the caller's activation + -- chain, and change their master to the one passed in by the caller. If + -- that doesn't happen, they will never be activated, and will become + -- terminated on leaving the return statement. + + procedure Set_Entry_Name + (T : Task_Id; + Pos : Task_Entry_Index; + Val : String_Access); + -- This is called by the compiler to map a string which denotes an entry + -- name to a task entry index. + + function Terminated (T : Task_Id) return Boolean; + -- This is called by the compiler to implement the 'Terminated attribute. + -- Though is not required to be so by the ARM, we choose to synchronize + -- with the task's ATCB, so that this is more useful for polling the state + -- of a task, and so that it becomes an abort completion point for the + -- calling task (via Undefer_Abort). + -- + -- source code: + -- T1'Terminated + -- + -- code expansion: + -- terminated (t1._task_id) + + procedure Terminate_Task (Self_ID : Task_Id); + -- Terminate the calling task. + -- This should only be called by the Task_Wrapper procedure, and to + -- deallocate storage associate with foreign tasks. + +end System.Tasking.Stages; diff --git a/gcc/ada/s-tasuti.adb b/gcc/ada/s-tasuti.adb new file mode 100644 index 000000000..8e818be9c --- /dev/null +++ b/gcc/ada/s-tasuti.adb @@ -0,0 +1,529 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . U T I L I T I E S -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides RTS Internal Declarations + +-- These declarations are not part of the GNARLI + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. + +with System.Tasking.Debug; +with System.Task_Primitives.Operations; +with System.Tasking.Initialization; +with System.Tasking.Queuing; +with System.Parameters; +with System.Traces.Tasking; + +package body System.Tasking.Utilities is + + package STPO renames System.Task_Primitives.Operations; + + use Parameters; + use Tasking.Debug; + use Task_Primitives; + use Task_Primitives.Operations; + + use System.Traces; + use System.Traces.Tasking; + + -------------------- + -- Abort_One_Task -- + -------------------- + + -- Similar to Locked_Abort_To_Level (Self_ID, T, 0), but: + -- (1) caller should be holding no locks except RTS_Lock when Single_Lock + -- (2) may be called for tasks that have not yet been activated + -- (3) always aborts whole task + + procedure Abort_One_Task (Self_ID : Task_Id; T : Task_Id) is + begin + if Parameters.Runtime_Traces then + Send_Trace_Info (T_Abort, Self_ID, T); + end if; + + Write_Lock (T); + + if T.Common.State = Unactivated then + T.Common.Activator := null; + T.Common.State := Terminated; + T.Callable := False; + Cancel_Queued_Entry_Calls (T); + + elsif T.Common.State /= Terminated then + Initialization.Locked_Abort_To_Level (Self_ID, T, 0); + end if; + + Unlock (T); + end Abort_One_Task; + + ----------------- + -- Abort_Tasks -- + ----------------- + + -- This must be called to implement the abort statement. + -- Much of the actual work of the abort is done by the abortee, + -- via the Abort_Handler signal handler, and propagation of the + -- Abort_Signal special exception. + + procedure Abort_Tasks (Tasks : Task_List) is + Self_Id : constant Task_Id := STPO.Self; + C : Task_Id; + P : Task_Id; + + begin + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if System.Tasking.Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with "potentially blocking operation"; + end if; + + Initialization.Defer_Abort_Nestable (Self_Id); + + -- ????? + -- Really should not be nested deferral here. + -- Patch for code generation error that defers abort before + -- evaluating parameters of an entry call (at least, timed entry + -- calls), and so may propagate an exception that causes abort + -- to remain undeferred indefinitely. See C97404B. When all + -- such bugs are fixed, this patch can be removed. + + Lock_RTS; + + for J in Tasks'Range loop + C := Tasks (J); + Abort_One_Task (Self_Id, C); + end loop; + + C := All_Tasks_List; + + while C /= null loop + if C.Pending_ATC_Level > 0 then + P := C.Common.Parent; + + while P /= null loop + if P.Pending_ATC_Level = 0 then + Abort_One_Task (Self_Id, C); + exit; + end if; + + P := P.Common.Parent; + end loop; + end if; + + C := C.Common.All_Tasks_Link; + end loop; + + Unlock_RTS; + Initialization.Undefer_Abort_Nestable (Self_Id); + end Abort_Tasks; + + ------------------------------- + -- Cancel_Queued_Entry_Calls -- + ------------------------------- + + -- This should only be called by T, unless T is a terminated previously + -- unactivated task. + + procedure Cancel_Queued_Entry_Calls (T : Task_Id) is + Next_Entry_Call : Entry_Call_Link; + Entry_Call : Entry_Call_Link; + Self_Id : constant Task_Id := STPO.Self; + + Caller : Task_Id; + pragma Unreferenced (Caller); + -- Should this be removed ??? + + Level : Integer; + pragma Unreferenced (Level); + -- Should this be removed ??? + + begin + pragma Assert (T = Self or else T.Common.State = Terminated); + + for J in 1 .. T.Entry_Num loop + Queuing.Dequeue_Head (T.Entry_Queues (J), Entry_Call); + + while Entry_Call /= null loop + + -- Leave Entry_Call.Done = False, since this is cancelled + + Caller := Entry_Call.Self; + Entry_Call.Exception_To_Raise := Tasking_Error'Identity; + Queuing.Dequeue_Head (T.Entry_Queues (J), Next_Entry_Call); + Level := Entry_Call.Level - 1; + Unlock (T); + Write_Lock (Entry_Call.Self); + Initialization.Wakeup_Entry_Caller + (Self_Id, Entry_Call, Cancelled); + Unlock (Entry_Call.Self); + Write_Lock (T); + Entry_Call.State := Done; + Entry_Call := Next_Entry_Call; + end loop; + end loop; + end Cancel_Queued_Entry_Calls; + + ------------------------ + -- Exit_One_ATC_Level -- + ------------------------ + + -- Call only with abort deferred and holding lock of Self_Id. + -- This is a bit of common code for all entry calls. + -- The effect is to exit one level of ATC nesting. + + -- If we have reached the desired ATC nesting level, reset the + -- requested level to effective infinity, to allow further calls. + -- In any case, reset Self_Id.Aborting, to allow re-raising of + -- Abort_Signal. + + procedure Exit_One_ATC_Level (Self_ID : Task_Id) is + begin + Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level - 1; + + pragma Debug + (Debug.Trace (Self_ID, "EOAL: exited to ATC level: " & + ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A')); + + pragma Assert (Self_ID.ATC_Nesting_Level >= 1); + + if Self_ID.Pending_ATC_Level < ATC_Level_Infinity then + if Self_ID.Pending_ATC_Level = Self_ID.ATC_Nesting_Level then + Self_ID.Pending_ATC_Level := ATC_Level_Infinity; + Self_ID.Aborting := False; + else + -- Force the next Undefer_Abort to re-raise Abort_Signal + + pragma Assert + (Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level); + + if Self_ID.Aborting then + Self_ID.ATC_Hack := True; + Self_ID.Pending_Action := True; + end if; + end if; + end if; + end Exit_One_ATC_Level; + + ---------------------- + -- Make_Independent -- + ---------------------- + + procedure Make_Independent is + Self_Id : constant Task_Id := STPO.Self; + Environment_Task : constant Task_Id := STPO.Environment_Task; + Parent : constant Task_Id := Self_Id.Common.Parent; + Parent_Needs_Updating : Boolean := False; + Master_of_Task : Integer; + + begin + if Self_Id.Known_Tasks_Index /= -1 then + Known_Tasks (Self_Id.Known_Tasks_Index) := null; + end if; + + Initialization.Defer_Abort (Self_Id); + + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Environment_Task); + Write_Lock (Self_Id); + + pragma Assert (Parent = Environment_Task + or else Self_Id.Master_of_Task = Library_Task_Level); + + Master_of_Task := Self_Id.Master_of_Task; + Self_Id.Master_of_Task := Independent_Task_Level; + + -- The run time assumes that the parent of an independent task is the + -- environment task. + + if Parent /= Environment_Task then + + -- We cannot lock three tasks at the same time, so defer the + -- operations on the parent. + + Parent_Needs_Updating := True; + Self_Id.Common.Parent := Environment_Task; + end if; + + -- Update Independent_Task_Count that is needed for the GLADE + -- termination rule. See also pending update in + -- System.Tasking.Stages.Check_Independent + + Independent_Task_Count := Independent_Task_Count + 1; + + Unlock (Self_Id); + + -- Changing the parent after creation is not trivial. Do not forget + -- to update the old parent counts, and the new parent (i.e. the + -- Environment_Task) counts. + + if Parent_Needs_Updating then + Write_Lock (Parent); + Parent.Awake_Count := Parent.Awake_Count - 1; + Parent.Alive_Count := Parent.Alive_Count - 1; + Environment_Task.Awake_Count := Environment_Task.Awake_Count + 1; + Environment_Task.Alive_Count := Environment_Task.Alive_Count + 1; + Unlock (Parent); + end if; + + -- In case the environment task is already waiting for children to + -- complete. + -- ??? There may be a race condition if the environment task was not in + -- master completion sleep when this task was created, but now is + + if Environment_Task.Common.State = Master_Completion_Sleep and then + Master_of_Task = Environment_Task.Master_Within + then + Environment_Task.Common.Wait_Count := + Environment_Task.Common.Wait_Count - 1; + end if; + + Unlock (Environment_Task); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + end Make_Independent; + + ------------------ + -- Make_Passive -- + ------------------ + + procedure Make_Passive (Self_ID : Task_Id; Task_Completed : Boolean) is + C : Task_Id := Self_ID; + P : Task_Id := C.Common.Parent; + + Master_Completion_Phase : Integer; + + begin + if P /= null then + Write_Lock (P); + end if; + + Write_Lock (C); + + if Task_Completed then + Self_ID.Common.State := Terminated; + + if Self_ID.Awake_Count = 0 then + + -- We are completing via a terminate alternative. + -- Our parent should wait in Phase 2 of Complete_Master. + + Master_Completion_Phase := 2; + + pragma Assert (Task_Completed); + pragma Assert (Self_ID.Terminate_Alternative); + pragma Assert (Self_ID.Alive_Count = 1); + + else + -- We are NOT on a terminate alternative. + -- Our parent should wait in Phase 1 of Complete_Master. + + Master_Completion_Phase := 1; + pragma Assert (Self_ID.Awake_Count >= 1); + end if; + + -- We are accepting with a terminate alternative + + else + if Self_ID.Open_Accepts = null then + + -- Somebody started a rendezvous while we had our lock open. + -- Skip the terminate alternative. + + Unlock (C); + + if P /= null then + Unlock (P); + end if; + + return; + end if; + + Self_ID.Terminate_Alternative := True; + Master_Completion_Phase := 0; + + pragma Assert (Self_ID.Terminate_Alternative); + pragma Assert (Self_ID.Awake_Count >= 1); + end if; + + if Master_Completion_Phase = 2 then + + -- Since our Awake_Count is zero but our Alive_Count + -- is nonzero, we have been accepting with a terminate + -- alternative, and we now have been told to terminate + -- by a completed master (in some ancestor task) that + -- is waiting (with zero Awake_Count) in Phase 2 of + -- Complete_Master. + + pragma Debug (Debug.Trace (Self_ID, "Make_Passive: Phase 2", 'M')); + + pragma Assert (P /= null); + + C.Alive_Count := C.Alive_Count - 1; + + if C.Alive_Count > 0 then + Unlock (C); + Unlock (P); + return; + end if; + + -- C's count just went to zero, indicating that + -- all of C's dependents are terminated. + -- C has a parent, P. + + loop + -- C's count just went to zero, indicating that all of C's + -- dependents are terminated. C has a parent, P. Notify P that + -- C and its dependents have all terminated. + + P.Alive_Count := P.Alive_Count - 1; + exit when P.Alive_Count > 0; + Unlock (C); + Unlock (P); + C := P; + P := C.Common.Parent; + + -- Environment task cannot have terminated yet + + pragma Assert (P /= null); + + Write_Lock (P); + Write_Lock (C); + end loop; + + if P.Common.State = Master_Phase_2_Sleep + and then C.Master_of_Task = P.Master_Within + then + pragma Assert (P.Common.Wait_Count > 0); + P.Common.Wait_Count := P.Common.Wait_Count - 1; + + if P.Common.Wait_Count = 0 then + Wakeup (P, Master_Phase_2_Sleep); + end if; + end if; + + Unlock (C); + Unlock (P); + return; + end if; + + -- We are terminating in Phase 1 or Complete_Master, + -- or are accepting on a terminate alternative. + + C.Awake_Count := C.Awake_Count - 1; + + if Task_Completed then + C.Alive_Count := C.Alive_Count - 1; + end if; + + if C.Awake_Count > 0 or else P = null then + Unlock (C); + + if P /= null then + Unlock (P); + end if; + + return; + end if; + + -- C's count just went to zero, indicating that all of C's + -- dependents are terminated or accepting with terminate alt. + -- C has a parent, P. + + loop + -- Notify P that C has gone passive + + if P.Awake_Count > 0 then + P.Awake_Count := P.Awake_Count - 1; + end if; + + if Task_Completed and then C.Alive_Count = 0 then + P.Alive_Count := P.Alive_Count - 1; + end if; + + exit when P.Awake_Count > 0; + Unlock (C); + Unlock (P); + C := P; + P := C.Common.Parent; + + if P = null then + return; + end if; + + Write_Lock (P); + Write_Lock (C); + end loop; + + -- P has non-passive dependents + + if P.Common.State = Master_Completion_Sleep + and then C.Master_of_Task = P.Master_Within + then + pragma Debug + (Debug.Trace + (Self_ID, "Make_Passive: Phase 1, parent waiting", 'M')); + + -- If parent is in Master_Completion_Sleep, it + -- cannot be on a terminate alternative, hence + -- it cannot have Awake_Count of zero. + + pragma Assert (P.Common.Wait_Count > 0); + P.Common.Wait_Count := P.Common.Wait_Count - 1; + + if P.Common.Wait_Count = 0 then + Wakeup (P, Master_Completion_Sleep); + end if; + + else + pragma Debug + (Debug.Trace + (Self_ID, "Make_Passive: Phase 1, parent awake", 'M')); + null; + end if; + + Unlock (C); + Unlock (P); + end Make_Passive; + +end System.Tasking.Utilities; diff --git a/gcc/ada/s-tasuti.ads b/gcc/ada/s-tasuti.ads new file mode 100644 index 000000000..7f9e8bff2 --- /dev/null +++ b/gcc/ada/s-tasuti.ads @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . U T I L I T I E S -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides RTS Internal Declarations. +-- These declarations are not part of the GNARLI + +with Ada.Unchecked_Conversion; +with System.Task_Primitives; + +package System.Tasking.Utilities is + + function ATCB_To_Address is new + Ada.Unchecked_Conversion (Task_Id, System.Task_Primitives.Task_Address); + + --------------------------------- + -- Task_Stage Related routines -- + --------------------------------- + + procedure Make_Independent; + -- Move the current task to the outermost level (level 2) of the master + -- hierarchy of the environment task. That is one level further out + -- than normal tasks defined in library-level packages (level 3). The + -- environment task will wait for level 3 tasks to terminate normally, + -- then it will abort all the level 2 tasks. See Finalize_Global_Tasks + -- procedure for more information. + -- + -- This is a dangerous operation, and should never be used on nested tasks + -- or tasks that depend on any objects that might be finalized earlier than + -- the termination of the environment task. It is for internal use by the + -- GNARL, to prevent such internal server tasks from preventing a partition + -- from terminating. + -- + -- Also note that the run time assumes that the parent of an independent + -- task is the environment task. If this is not the case, Make_Independent + -- will change the task's parent. This assumption is particularly + -- important for master level completion and for the computation of + -- Independent_Task_Count. + + Independent_Task_Count : Natural := 0; + -- Number of independent task. This counter is incremented each time + -- Make_Independent is called. Note that if a server task terminates, + -- this counter will not be decremented. Since Make_Independent locks + -- the environment task (because every independent task depends on it), + -- this counter is protected by the environment task's lock. + + --------------------------------- + -- Task Abort Related Routines -- + --------------------------------- + + procedure Cancel_Queued_Entry_Calls (T : Task_Id); + -- Cancel any entry calls queued on target task. + -- Call this while holding T's lock (or RTS_Lock in Single_Lock mode). + + procedure Exit_One_ATC_Level (Self_ID : Task_Id); + pragma Inline (Exit_One_ATC_Level); + -- Call only with abort deferred and holding lock of Self_ID. + -- This is a bit of common code for all entry calls. + -- The effect is to exit one level of ATC nesting. + + procedure Abort_One_Task (Self_ID : Task_Id; T : Task_Id); + -- Similar to Locked_Abort_To_Level (Self_ID, T, 0), but: + -- (1) caller should be holding no locks + -- (2) may be called for tasks that have not yet been activated + -- (3) always aborts whole task + + procedure Abort_Tasks (Tasks : Task_List); + -- Abort_Tasks is called to initiate abort, however, the actual + -- aborting is done by aborted task by means of Abort_Handler + + procedure Make_Passive (Self_ID : Task_Id; Task_Completed : Boolean); + -- Update counts to indicate current task is either terminated or + -- accepting on a terminate alternative. Call holding no locks except + -- Global_Task_Lock when calling from Terminate_Task, and RTS_Lock when + -- Single_Lock is True. + +end System.Tasking.Utilities; diff --git a/gcc/ada/s-tataat.adb b/gcc/ada/s-tataat.adb new file mode 100644 index 000000000..695f5164e --- /dev/null +++ b/gcc/ada/s-tataat.adb @@ -0,0 +1,217 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . T A S K _ A T T R I B U T E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2008, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +with System.Task_Primitives.Operations; +with System.Tasking.Initialization; + +package body System.Tasking.Task_Attributes is + + use Task_Primitives.Operations; + use Tasking.Initialization; + + function To_Access_Address is new Ada.Unchecked_Conversion + (Access_Node, Access_Address); + -- Store pointer to indirect attribute list + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (X : in out Instance) is + Q, To_Be_Freed : Access_Node; + Self_Id : constant Task_Id := Self; + + begin + -- Defer abort. Note that we use the nestable versions of Defer_Abort + -- and Undefer_Abort, because abort can already deferred when this is + -- called during finalization, which would cause an assert failure + -- in Defer_Abort. + + Defer_Abort_Nestable (Self_Id); + Lock_RTS; + + -- Remove this instantiation from the list of all instantiations + + declare + P : Access_Instance; + Q : Access_Instance := All_Attributes; + + begin + while Q /= null and then Q /= X'Unchecked_Access loop + P := Q; Q := Q.Next; + end loop; + + pragma Assert (Q /= null); + + if P = null then + All_Attributes := Q.Next; + else + P.Next := Q.Next; + end if; + end; + + if X.Index /= 0 then + + -- Free location of this attribute, for reuse + + In_Use := In_Use and not (2**Natural (X.Index)); + + -- There is no need for finalization in this case, since controlled + -- types are too big to fit in the TCB. + + else + -- Remove nodes for this attribute from the lists of all tasks, + -- and deallocate the nodes. Deallocation does finalization, if + -- necessary. + + declare + C : System.Tasking.Task_Id := All_Tasks_List; + P : Access_Node; + + begin + while C /= null loop + Write_Lock (C); + + Q := To_Access_Node (C.Indirect_Attributes); + while Q /= null + and then Q.Instance /= X'Unchecked_Access + loop + P := Q; + Q := Q.Next; + end loop; + + if Q /= null then + if P = null then + C.Indirect_Attributes := To_Access_Address (Q.Next); + else + P.Next := Q.Next; + end if; + + -- Can't Deallocate now since we are holding RTS_Lock + + Q.Next := To_Be_Freed; + To_Be_Freed := Q; + end if; + + Unlock (C); + C := C.Common.All_Tasks_Link; + end loop; + end; + end if; + + Unlock_RTS; + + while To_Be_Freed /= null loop + Q := To_Be_Freed; + To_Be_Freed := To_Be_Freed.Next; + X.Deallocate.all (Q); + end loop; + + Undefer_Abort_Nestable (Self_Id); + + exception + when others => + null; + pragma Assert (False, + "Exception in task attribute instance finalization"); + end Finalize; + + ------------------------- + -- Finalize Attributes -- + ------------------------- + + -- This is to be called just before the ATCB is deallocated. + -- It relies on the caller holding T.L write-lock on entry. + + procedure Finalize_Attributes (T : Task_Id) is + P : Access_Node; + Q : Access_Node := To_Access_Node (T.Indirect_Attributes); + + begin + -- Deallocate all the indirect attributes of this task + + while Q /= null loop + P := Q; + Q := Q.Next; P.Instance.Deallocate.all (P); + end loop; + + T.Indirect_Attributes := null; + + exception + when others => + null; + pragma Assert (False, + "Exception in per-task attributes finalization"); + end Finalize_Attributes; + + --------------------------- + -- Initialize Attributes -- + --------------------------- + + -- This is to be called by System.Tasking.Stages.Create_Task + + procedure Initialize_Attributes (T : Task_Id) is + P : Access_Instance; + Self_Id : constant Task_Id := Self; + + begin + Defer_Abort (Self_Id); + Lock_RTS; + + -- Initialize all the direct-access attributes of this task + + P := All_Attributes; + + while P /= null loop + if P.Index /= 0 then + T.Direct_Attributes (P.Index) := + Direct_Attribute_Element + (System.Storage_Elements.To_Address (P.Initial_Value)); + end if; + + P := P.Next; + end loop; + + Unlock_RTS; + Undefer_Abort (Self_Id); + + exception + when others => + null; + pragma Assert (False); + end Initialize_Attributes; + +end System.Tasking.Task_Attributes; diff --git a/gcc/ada/s-tataat.ads b/gcc/ada/s-tataat.ads new file mode 100644 index 000000000..c2af68c6a --- /dev/null +++ b/gcc/ada/s-tataat.ads @@ -0,0 +1,129 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . T A S K _ A T T R I B U T E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2010, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides support for the body of Ada.Task_Attributes + +with Ada.Finalization; + +with System.Storage_Elements; + +package System.Tasking.Task_Attributes is + + type Attribute is new Integer; + -- A stand-in for the generic formal type of Ada.Task_Attributes + -- in the following declarations. + + type Node; + type Access_Node is access all Node; + -- This needs comments ??? + + function To_Access_Node is new Ada.Unchecked_Conversion + (Access_Address, Access_Node); + -- Used to fetch pointer to indirect attribute list. Declaration is in + -- spec to avoid any problems with aliasing assumptions. + + type Dummy_Wrapper; + type Access_Dummy_Wrapper is access all Dummy_Wrapper; + pragma No_Strict_Aliasing (Access_Dummy_Wrapper); + -- Needed to avoid possible incorrect aliasing situations from + -- instantiation of Unchecked_Conversion in body of Ada.Task_Attributes. + + for Access_Dummy_Wrapper'Storage_Size use 0; + -- Access_Dummy_Wrapper is a stand-in for the generic type Wrapper defined + -- in Ada.Task_Attributes. The real objects allocated are always + -- of type Wrapper, no Dummy_Wrapper objects are ever created. + + type Deallocator is access procedure (P : in out Access_Node); + -- Called to deallocate an Wrapper. P is a pointer to a Node within + + type Instance; + + type Access_Instance is access all Instance; + + type Instance is new Ada.Finalization.Limited_Controlled with record + Deallocate : Deallocator; + Initial_Value : aliased System.Storage_Elements.Integer_Address; + + Index : Direct_Index; + -- The index of the TCB location used by this instantiation, if it is + -- stored in the TCB, otherwise zero. + + Next : Access_Instance; + -- Next instance in All_Attributes list + end record; + + procedure Finalize (X : in out Instance); + + type Node is record + Wrapper : Access_Dummy_Wrapper; + Instance : Access_Instance; + Next : Access_Node; + end record; + + -- The following type is a stand-in for the actual wrapper type, which is + -- different for each instantiation of Ada.Task_Attributes. + + type Dummy_Wrapper is record + Dummy_Node : aliased Node; + + Value : aliased Attribute; + -- The generic formal type, may be controlled + end record; + + for Dummy_Wrapper'Alignment use Standard'Maximum_Alignment; + -- A number of unchecked conversions involving Dummy_Wrapper_Access + -- sources are performed in other units (e.g. Ada.Task_Attributes). + -- Ensure that the designated object is always strictly enough aligned. + + In_Use : Direct_Index_Vector := 0; + -- Set True for direct indexes that are already used (True??? type???) + + All_Attributes : Access_Instance; + -- A linked list of all indirectly access attributes, which includes all + -- those that require finalization. + + procedure Initialize_Attributes (T : Task_Id); + -- Initialize all attributes created via Ada.Task_Attributes for T. This + -- must be called by the creator of the task, inside Create_Task, via + -- soft-link Initialize_Attributes_Link. On entry, abort must be deferred + -- and the caller must hold no locks + + procedure Finalize_Attributes (T : Task_Id); + -- Finalize all attributes created via Ada.Task_Attributes for T. + -- This is to be called by the task after it is marked as terminated + -- (and before it actually dies), inside Vulnerable_Free_Task, via the + -- soft-link Finalize_Attributes_Link. On entry, abort must be deferred + -- and T.L must be write-locked. + +end System.Tasking.Task_Attributes; diff --git a/gcc/ada/s-tfsetr-default.adb b/gcc/ada/s-tfsetr-default.adb new file mode 100644 index 000000000..acddbefef --- /dev/null +++ b/gcc/ada/s-tfsetr-default.adb @@ -0,0 +1,311 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E S . S E N D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is for all targets, provided that System.IO.Put_Line is +-- functional. It prints debug information to Standard Output + +with System.IO; use System.IO; +with System.Regpat; use System.Regpat; + +---------------- +-- Send_Trace -- +---------------- + +-- Prints debug information both in a human readable form +-- and in the form they are sent from upper layers. + +separate (System.Traces.Format) +procedure Send_Trace (Id : Trace_T; Info : String) is + + type Param_Type is + (Name_Param, + Caller_Param, + Entry_Param, + Timeout_Param, + Acceptor_Param, + Parent_Param, + Number_Param); + -- Type of parameter found in the message + + Info_Trace : String_Trace := Format_Trace (Info); + + function Get_Param + (Input : String_Trace; + Param : Param_Type; + How_Many : Integer) + return String; + -- Extract a parameter from the given input string + + --------------- + -- Get_Param -- + --------------- + + function Get_Param + (Input : String_Trace; + Param : Param_Type; + How_Many : Integer) + return String + is + pragma Unreferenced (How_Many); + + Matches : Match_Array (1 .. 2); + begin + -- We need comments here ??? + + case Param is + when Name_Param => + Match ("/N:([\w]+)", Input, Matches); + + when Caller_Param => + Match ("/C:([\w]+)", Input, Matches); + + when Entry_Param => + Match ("/E:([\s]*) +([0-9 ,]+)", Input, Matches); + + when Timeout_Param => + Match ("/T:([\s]*) +([0-9]+.[0-9]+)", Input, Matches); + + when Acceptor_Param => + Match ("/A:([\w]+)", Input, Matches); + + when Parent_Param => + Match ("/P:([\w]+)", Input, Matches); + + when Number_Param => + Match ("/#:([\s]*) +([0-9]+)", Input, Matches); + end case; + + if Matches (1).First < Input'First then + return ""; + end if; + + case Param is + when Timeout_Param | Entry_Param | Number_Param => + return Input (Matches (2).First .. Matches (2).Last); + + when others => + return Input (Matches (1).First .. Matches (1).Last); + end case; + end Get_Param; + +-- Start of processing for Send_Trace + +begin + New_Line; + Put_Line ("- Trace Debug Info ----------------"); + Put ("Caught event Id : "); + + case Id is + when M_Accept_Complete => Put ("M_Accept_Complete"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " completes accept on entry " + & Get_Param (Info_Trace, Entry_Param, 1) & " with " + & Get_Param (Info_Trace, Caller_Param, 1)); + + when M_Select_Else => Put ("M_Select_Else"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " selects else statement"); + + when M_RDV_Complete => Put ("M_RDV_Complete"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " completes rendezvous with " + & Get_Param (Info_Trace, Caller_Param, 1)); + + when M_Call_Complete => Put ("M_Call_Complete"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " completes call"); + + when M_Delay => Put ("M_Delay"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " completes delay " + & Get_Param (Info_Trace, Timeout_Param, 1)); + + when E_Missed => Put ("E_Missed"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " got an invalid acceptor " + & Get_Param (Info_Trace, Acceptor_Param, 1)); + + when E_Timeout => Put ("E_Timeout"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " ends select due to timeout "); + + when E_Kill => Put ("E_Kill"); + New_Line; + Put_Line ("Asynchronous Transfer of Control on task " + & Get_Param (Info_Trace, Name_Param, 1)); + + when W_Delay => Put ("W_Delay"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " sleeping " + & Get_Param (Info_Trace, Timeout_Param, 1) + & " seconds"); + + when WU_Delay => Put ("WU_Delay"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " sleeping until " + & Get_Param (Info_Trace, Timeout_Param, 1)); + + when W_Call => Put ("W_Call"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " calling entry " + & Get_Param (Info_Trace, Entry_Param, 1) + & " of " & Get_Param (Info_Trace, Acceptor_Param, 1)); + + when W_Accept => Put ("W_Accept"); + New_Line; + Put ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " waiting on " + & Get_Param (Info_Trace, Number_Param, 1) + & " accept(s)" + & ", " & Get_Param (Info_Trace, Entry_Param, 1)); + New_Line; + + when W_Select => Put ("W_Select"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " waiting on " + & Get_Param (Info_Trace, Number_Param, 1) + & " select(s)" + & ", " & Get_Param (Info_Trace, Entry_Param, 1)); + New_Line; + + when W_Completion => Put ("W_Completion"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " waiting for completion "); + + when WT_Select => Put ("WT_Select"); + New_Line; + Put ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " waiting " & Get_Param (Info_Trace, Timeout_Param, 1) + & " seconds on " + & Get_Param (Info_Trace, Number_Param, 1) + & " select(s)"); + + if Get_Param (Info_Trace, Number_Param, 1) /= "" then + Put (", " & Get_Param (Info_Trace, Entry_Param, 1)); + end if; + + New_Line; + + when WT_Call => Put ("WT_Call"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " calling entry " + & Get_Param (Info_Trace, Entry_Param, 1) + & " of " & Get_Param (Info_Trace, Acceptor_Param, 1) + & " with timeout " + & Get_Param (Info_Trace, Timeout_Param, 1)); + + when WT_Completion => Put ("WT_Completion"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " waiting " + & Get_Param (Info_Trace, Timeout_Param, 1) + & " for call completion"); + + when PO_Call => Put ("PO_Call"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " calling protected entry " + & Get_Param (Info_Trace, Entry_Param, 1)); + + when POT_Call => Put ("POT_Call"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " calling protected entry " + & Get_Param (Info_Trace, Entry_Param, 1) + & " with timeout " + & Get_Param (Info_Trace, Timeout_Param, 1)); + + when PO_Run => Put ("PO_Run"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " running entry " + & Get_Param (Info_Trace, Entry_Param, 1) + & " for " + & Get_Param (Info_Trace, Caller_Param, 1)); + + when PO_Done => Put ("PO_Done"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " finished call from " + & Get_Param (Info_Trace, Caller_Param, 1)); + + when PO_Lock => Put ("PO_Lock"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " took lock"); + + when PO_Unlock => Put ("PO_Unlock"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " released lock"); + + when T_Create => Put ("T_Create"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " created"); + + when T_Activate => Put ("T_Activate"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " activated"); + + when T_Abort => Put ("T_Abort"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " aborted by " + & Get_Param (Info_Trace, Parent_Param, 1)); + + when T_Terminate => Put ("T_Terminate"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " terminated"); + + when others + => Put ("Invalid Id"); + end case; + + Put_Line (" --> " & Info_Trace); + Put_Line ("-----------------------------------"); + New_Line; +end Send_Trace; diff --git a/gcc/ada/s-tfsetr-vxworks.adb b/gcc/ada/s-tfsetr-vxworks.adb new file mode 100644 index 000000000..ad7bf0362 --- /dev/null +++ b/gcc/ada/s-tfsetr-vxworks.adb @@ -0,0 +1,105 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E S . S E N D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is for VxWorks targets + +-- Trace information is sent to WindView using the wvEvent function + +-- Note that wvEvent is from the VxWorks API + +-- When adding a new event, just give an Id to then event, and then modify +-- the WindView events database. + +-- Refer to WindView User's Guide for more details on how to add new events +-- to the events database. + +---------------- +-- Send_Trace -- +---------------- + +-- This procedure formats the string, maps the event Id to an Id +-- recognized by WindView, and send the event using wvEvent + +separate (System.Traces.Format) +procedure Send_Trace (Id : Trace_T; Info : String) is + + procedure Wv_Event + (Id : Integer; + Buffer : System.Address; + Size : Integer); + pragma Import (C, Wv_Event, "wvEvent"); + + Info_Trace : String_Trace; + Id_Event : Integer; + +begin + Info_Trace := Format_Trace (Info); + + case Id is + when M_Accept_Complete => Id_Event := 30000; + when M_Select_Else => Id_Event := 30001; + when M_RDV_Complete => Id_Event := 30002; + when M_Call_Complete => Id_Event := 30003; + when M_Delay => Id_Event := 30004; + when E_Kill => Id_Event := 30005; + when E_Missed => Id_Event := 30006; + when E_Timeout => Id_Event := 30007; + + when W_Call => Id_Event := 30010; + when W_Accept => Id_Event := 30011; + when W_Select => Id_Event := 30012; + when W_Completion => Id_Event := 30013; + when W_Delay => Id_Event := 30014; + when WT_Select => Id_Event := 30015; + when WT_Call => Id_Event := 30016; + when WT_Completion => Id_Event := 30017; + when WU_Delay => Id_Event := 30018; + + when PO_Call => Id_Event := 30020; + when POT_Call => Id_Event := 30021; + when PO_Run => Id_Event := 30022; + when PO_Lock => Id_Event := 30023; + when PO_Unlock => Id_Event := 30024; + when PO_Done => Id_Event := 30025; + + when T_Create => Id_Event := 30030; + when T_Activate => Id_Event := 30031; + when T_Abort => Id_Event := 30032; + when T_Terminate => Id_Event := 30033; + + -- Unrecognized events are given the special Id_Event value 29999 + + when others => Id_Event := 29999; + + end case; + + Wv_Event (Id_Event, Info_Trace'Address, Max_Size); +end Send_Trace; diff --git a/gcc/ada/s-tpinop.adb b/gcc/ada/s-tpinop.adb new file mode 100644 index 000000000..0ab91ffef --- /dev/null +++ b/gcc/ada/s-tpinop.adb @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.INTERRUPT_OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-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 System.Task_Primitives.Interrupt_Operations is + + -- ??? The VxWorks version of System.Interrupt_Management needs to access + -- this array, but due to elaboration problems, it can't with this + -- package directly, so we export this variable for now. + + Interrupt_ID_Map : array (IM.Interrupt_ID) of ST.Task_Id; + pragma Export (Ada, Interrupt_ID_Map, + "system__task_primitives__interrupt_operations__interrupt_id_map"); + + ---------------------- + -- Get_Interrupt_ID -- + ---------------------- + + function Get_Interrupt_ID (T : ST.Task_Id) return IM.Interrupt_ID is + use type ST.Task_Id; + + begin + for Interrupt in IM.Interrupt_ID loop + if Interrupt_ID_Map (Interrupt) = T then + return Interrupt; + end if; + end loop; + + raise Program_Error; + end Get_Interrupt_ID; + + ----------------- + -- Get_Task_Id -- + ----------------- + + function Get_Task_Id (Interrupt : IM.Interrupt_ID) return ST.Task_Id is + begin + return Interrupt_ID_Map (Interrupt); + end Get_Task_Id; + + ---------------------- + -- Set_Interrupt_ID -- + ---------------------- + + procedure Set_Interrupt_ID (Interrupt : IM.Interrupt_ID; T : ST.Task_Id) is + begin + Interrupt_ID_Map (Interrupt) := T; + end Set_Interrupt_ID; + +end System.Task_Primitives.Interrupt_Operations; diff --git a/gcc/ada/s-tpinop.ads b/gcc/ada/s-tpinop.ads new file mode 100644 index 000000000..57f7c7cb8 --- /dev/null +++ b/gcc/ada/s-tpinop.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.INTERRUPT_OPERATIONS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Interrupt_Management; +with System.Tasking; + +package System.Task_Primitives.Interrupt_Operations is + pragma Preelaborate; + + package IM renames System.Interrupt_Management; + package ST renames System.Tasking; + + procedure Set_Interrupt_ID (Interrupt : IM.Interrupt_ID; T : ST.Task_Id); + -- Associate an Interrupt_ID with a task + + function Get_Interrupt_ID (T : ST.Task_Id) return IM.Interrupt_ID; + -- Return the Interrupt_ID associated with a task + + function Get_Task_Id (Interrupt : IM.Interrupt_ID) return ST.Task_Id; + -- Return the Task_Id associated with an Interrupt + +end System.Task_Primitives.Interrupt_Operations; diff --git a/gcc/ada/s-tpoben.adb b/gcc/ada/s-tpoben.adb new file mode 100644 index 000000000..ba2bf6c26 --- /dev/null +++ b/gcc/ada/s-tpoben.adb @@ -0,0 +1,463 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASKING.PROTECTED_OBJECTS.ENTRIES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2010, 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 contains all the simple primitives related to protected +-- objects with entries (i.e init, lock, unlock). + +-- The handling of protected objects with no entries is done in +-- System.Tasking.Protected_Objects, the complex routines for protected +-- objects with entries in System.Tasking.Protected_Objects.Operations. + +-- The split between Entries and Operations is needed to break circular +-- dependencies inside the run time. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind + +with Ada.Unchecked_Deallocation; + +with System.Task_Primitives.Operations; +with System.Restrictions; +with System.Parameters; + +with System.Tasking.Initialization; +pragma Elaborate_All (System.Tasking.Initialization); +-- To insure that tasking is initialized if any protected objects are created + +package body System.Tasking.Protected_Objects.Entries is + + package STPO renames System.Task_Primitives.Operations; + + use Parameters; + use Task_Primitives.Operations; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Free_Entry_Names (Object : Protection_Entries); + -- Deallocate all string names associated with protected entries + + ---------------- + -- Local Data -- + ---------------- + + Locking_Policy : Character; + pragma Import (C, Locking_Policy, "__gl_locking_policy"); + + -------------- + -- Finalize -- + -------------- + + overriding procedure Finalize (Object : in out Protection_Entries) is + Entry_Call : Entry_Call_Link; + Caller : Task_Id; + Ceiling_Violation : Boolean; + Self_ID : constant Task_Id := STPO.Self; + Old_Base_Priority : System.Any_Priority; + + begin + if Object.Finalized then + return; + end if; + + STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation); + + if Single_Lock then + Lock_RTS; + end if; + + if Ceiling_Violation then + + -- Dip our own priority down to ceiling of lock. See similar code in + -- Tasking.Entry_Calls.Lock_Server. + + STPO.Write_Lock (Self_ID); + Old_Base_Priority := Self_ID.Common.Base_Priority; + Self_ID.New_Base_Priority := Object.Ceiling; + Initialization.Change_Base_Priority (Self_ID); + STPO.Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation); + + if Ceiling_Violation then + raise Program_Error with "Ceiling Violation"; + end if; + + if Single_Lock then + Lock_RTS; + end if; + + Object.Old_Base_Priority := Old_Base_Priority; + Object.Pending_Action := True; + end if; + + -- Send program_error to all tasks still queued on this object + + for E in Object.Entry_Queues'Range loop + Entry_Call := Object.Entry_Queues (E).Head; + + while Entry_Call /= null loop + Caller := Entry_Call.Self; + Entry_Call.Exception_To_Raise := Program_Error'Identity; + + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + STPO.Unlock (Caller); + + exit when Entry_Call = Object.Entry_Queues (E).Tail; + Entry_Call := Entry_Call.Next; + end loop; + end loop; + + Free_Entry_Names (Object); + + Object.Finalized := True; + + if Single_Lock then + Unlock_RTS; + end if; + + STPO.Unlock (Object.L'Unrestricted_Access); + + STPO.Finalize_Lock (Object.L'Unrestricted_Access); + end Finalize; + + ---------------------- + -- Free_Entry_Names -- + ---------------------- + + procedure Free_Entry_Names (Object : Protection_Entries) is + Names : Entry_Names_Array_Access := Object.Entry_Names; + + procedure Free_Entry_Names_Array_Access is new + Ada.Unchecked_Deallocation + (Entry_Names_Array, Entry_Names_Array_Access); + + begin + if Names = null then + return; + end if; + + Free_Entry_Names_Array (Names.all); + Free_Entry_Names_Array_Access (Names); + end Free_Entry_Names; + + ----------------- + -- Get_Ceiling -- + ----------------- + + function Get_Ceiling + (Object : Protection_Entries_Access) return System.Any_Priority is + begin + return Object.New_Ceiling; + end Get_Ceiling; + + ------------------------------------- + -- Has_Interrupt_Or_Attach_Handler -- + ------------------------------------- + + function Has_Interrupt_Or_Attach_Handler + (Object : Protection_Entries_Access) + return Boolean + is + pragma Warnings (Off, Object); + begin + return False; + end Has_Interrupt_Or_Attach_Handler; + + ----------------------------------- + -- Initialize_Protection_Entries -- + ----------------------------------- + + procedure Initialize_Protection_Entries + (Object : Protection_Entries_Access; + Ceiling_Priority : Integer; + Compiler_Info : System.Address; + Entry_Bodies : Protected_Entry_Body_Access; + Find_Body_Index : Find_Body_Index_Access; + Build_Entry_Names : Boolean) + is + Init_Priority : Integer := Ceiling_Priority; + Self_ID : constant Task_Id := STPO.Self; + + begin + if Init_Priority = Unspecified_Priority then + Init_Priority := System.Priority'Last; + end if; + + if Locking_Policy = 'C' + and then Has_Interrupt_Or_Attach_Handler (Object) + and then Init_Priority not in System.Interrupt_Priority + then + -- Required by C.3.1(11) + + raise Program_Error; + end if; + + -- If a PO is created from a controlled operation, abort is already + -- deferred at this point, so we need to use Defer_Abort_Nestable. In + -- some cases, the following assertion can help to spot inconsistencies, + -- outside the above scenario involving controlled types. + + -- pragma Assert (Self_Id.Deferral_Level = 0); + + Initialization.Defer_Abort_Nestable (Self_ID); + Initialize_Lock (Init_Priority, Object.L'Access); + Initialization.Undefer_Abort_Nestable (Self_ID); + + Object.Ceiling := System.Any_Priority (Init_Priority); + Object.New_Ceiling := System.Any_Priority (Init_Priority); + Object.Owner := Null_Task; + Object.Compiler_Info := Compiler_Info; + Object.Pending_Action := False; + Object.Call_In_Progress := null; + Object.Entry_Bodies := Entry_Bodies; + Object.Find_Body_Index := Find_Body_Index; + + for E in Object.Entry_Queues'Range loop + Object.Entry_Queues (E).Head := null; + Object.Entry_Queues (E).Tail := null; + end loop; + + if Build_Entry_Names then + Object.Entry_Names := + new Entry_Names_Array (1 .. Entry_Index (Object.Num_Entries)); + end if; + end Initialize_Protection_Entries; + + ------------------ + -- Lock_Entries -- + ------------------ + + procedure Lock_Entries + (Object : Protection_Entries_Access; + Ceiling_Violation : out Boolean) + is + begin + if Object.Finalized then + raise Program_Error with "Protected Object is finalized"; + end if; + + -- If pragma Detect_Blocking is active then, as described in the ARM + -- 9.5.1, par. 15, we must check whether this is an external call on a + -- protected subprogram with the same target object as that of the + -- protected action that is currently in progress (i.e., if the caller + -- is already the protected object's owner). If this is the case hence + -- Program_Error must be raised. + + if Detect_Blocking and then Object.Owner = Self then + raise Program_Error; + end if; + + -- The lock is made without deferring abort + + -- Therefore the abort has to be deferred before calling this routine. + -- This means that the compiler has to generate a Defer_Abort call + -- before the call to Lock. + + -- The caller is responsible for undeferring abort, and compiler + -- generated calls must be protected with cleanup handlers to ensure + -- that abort is undeferred in all cases. + + pragma Assert + (STPO.Self.Deferral_Level > 0 + or else not Restrictions.Abort_Allowed); + + Write_Lock (Object.L'Access, Ceiling_Violation); + + -- We are entering in a protected action, so that we increase the + -- protected object nesting level (if pragma Detect_Blocking is + -- active), and update the protected object's owner. + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := Self; + + begin + -- Update the protected object's owner + + Object.Owner := Self_Id; + + -- Increase protected object nesting level + + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting + 1; + end; + end if; + + end Lock_Entries; + + procedure Lock_Entries (Object : Protection_Entries_Access) is + Ceiling_Violation : Boolean; + + begin + Lock_Entries (Object, Ceiling_Violation); + + if Ceiling_Violation then + raise Program_Error with "Ceiling Violation"; + end if; + end Lock_Entries; + + ---------------------------- + -- Lock_Read_Only_Entries -- + ---------------------------- + + procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is + Ceiling_Violation : Boolean; + + begin + if Object.Finalized then + raise Program_Error with "Protected Object is finalized"; + end if; + + -- If pragma Detect_Blocking is active then, as described in the ARM + -- 9.5.1, par. 15, we must check whether this is an external call on a + -- protected subprogram with the same target object as that of the + -- protected action that is currently in progress (i.e., if the caller + -- is already the protected object's owner). If this is the case hence + -- Program_Error must be raised. + + -- Note that in this case (getting read access), several tasks may + -- have read ownership of the protected object, so that this method of + -- storing the (single) protected object's owner does not work + -- reliably for read locks. However, this is the approach taken for two + -- major reasons: first, this function is not currently being used (it + -- is provided for possible future use), and second, it largely + -- simplifies the implementation. + + if Detect_Blocking and then Object.Owner = Self then + raise Program_Error; + end if; + + Read_Lock (Object.L'Access, Ceiling_Violation); + + if Ceiling_Violation then + raise Program_Error with "Ceiling Violation"; + end if; + + -- We are entering in a protected action, so that we increase the + -- protected object nesting level (if pragma Detect_Blocking is + -- active), and update the protected object's owner. + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := Self; + + begin + -- Update the protected object's owner + + Object.Owner := Self_Id; + + -- Increase protected object nesting level + + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting + 1; + end; + end if; + end Lock_Read_Only_Entries; + + ----------------- + -- Set_Ceiling -- + ----------------- + + procedure Set_Ceiling + (Object : Protection_Entries_Access; + Prio : System.Any_Priority) is + begin + Object.New_Ceiling := Prio; + end Set_Ceiling; + + -------------------- + -- Set_Entry_Name -- + -------------------- + + procedure Set_Entry_Name + (Object : Protection_Entries'Class; + Pos : Protected_Entry_Index; + Val : String_Access) + is + begin + pragma Assert (Object.Entry_Names /= null); + + Object.Entry_Names (Entry_Index (Pos)) := Val; + end Set_Entry_Name; + + -------------------- + -- Unlock_Entries -- + -------------------- + + procedure Unlock_Entries (Object : Protection_Entries_Access) is + begin + -- We are exiting from a protected action, so that we decrease the + -- protected object nesting level (if pragma Detect_Blocking is + -- active), and remove ownership of the protected object. + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := Self; + + begin + -- Calls to this procedure can only take place when being within + -- a protected action and when the caller is the protected + -- object's owner. + + pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0 + and then Object.Owner = Self_Id); + + -- Remove ownership of the protected object + + Object.Owner := Null_Task; + + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting - 1; + end; + end if; + + -- Before releasing the mutex we must actually update its ceiling + -- priority if it has been changed. + + if Object.New_Ceiling /= Object.Ceiling then + if Locking_Policy = 'C' then + System.Task_Primitives.Operations.Set_Ceiling + (Object.L'Access, Object.New_Ceiling); + end if; + + Object.Ceiling := Object.New_Ceiling; + end if; + + Unlock (Object.L'Access); + end Unlock_Entries; + +end System.Tasking.Protected_Objects.Entries; diff --git a/gcc/ada/s-tpoben.ads b/gcc/ada/s-tpoben.ads new file mode 100644 index 000000000..b0be2526c --- /dev/null +++ b/gcc/ada/s-tpoben.ads @@ -0,0 +1,230 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASKING.PROTECTED_OBJECTS.ENTRIES -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains all simple primitives related to Protected_Objects +-- with entries (i.e init, lock, unlock). + +-- The handling of protected objects with no entries is done in +-- System.Tasking.Protected_Objects, the complex routines for protected +-- objects with entries in System.Tasking.Protected_Objects.Operations. + +-- The split between Entries and Operations is needed to break circular +-- dependencies inside the run time. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +with Ada.Finalization; +with Ada.Unchecked_Conversion; + +package System.Tasking.Protected_Objects.Entries is + pragma Elaborate_Body; + + subtype Positive_Protected_Entry_Index is + Protected_Entry_Index range 1 .. Protected_Entry_Index'Last; + + type Find_Body_Index_Access is access + function + (O : System.Address; + E : Protected_Entry_Index) + return Protected_Entry_Index; + + type Protected_Entry_Body_Array is + array (Positive_Protected_Entry_Index range <>) of Entry_Body; + -- This is an array of the executable code for all entry bodies of + -- a protected type. + + type Protected_Entry_Body_Access is access all Protected_Entry_Body_Array; + + type Protected_Entry_Queue_Array is + array (Protected_Entry_Index range <>) of Entry_Queue; + + -- This type contains the GNARL state of a protected object. The + -- application-defined portion of the state (i.e. private objects) + -- is maintained by the compiler-generated code. + -- note that there is a simplified version of this type declared in + -- System.Tasking.PO_Simple that handle the simple case (no entries). + + type Protection_Entries (Num_Entries : Protected_Entry_Index) is new + Ada.Finalization.Limited_Controlled + with record + L : aliased Task_Primitives.Lock; + -- The underlying lock associated with a Protection_Entries. + -- Note that you should never (un)lock Object.L directly, but instead + -- use Lock_Entries/Unlock_Entries. + + Compiler_Info : System.Address; + -- Pointer to compiler-generated record representing protected object + + Call_In_Progress : Entry_Call_Link; + -- Pointer to the entry call being executed (if any) + + Ceiling : System.Any_Priority; + -- Ceiling priority associated with the protected object + + New_Ceiling : System.Any_Priority; + -- New ceiling priority associated to the protected object. In case + -- of assignment of a new ceiling priority to the protected object the + -- frontend generates a call to set_ceiling to save the new value in + -- this field. After such assignment this value can be read by means + -- of the 'Priority attribute, which generates a call to get_ceiling. + -- However, the ceiling of the protected object will not be changed + -- until completion of the protected action in which the assignment + -- has been executed (AARM D.5.2 (10/2)). + + Owner : Task_Id; + -- This field contains the protected object's owner. Null_Task + -- indicates that the protected object is not currently being used. + -- This information is used for detecting the type of potentially + -- blocking operations described in the ARM 9.5.1, par. 15 (external + -- calls on a protected subprogram with the same target object as that + -- of the protected action). + + Old_Base_Priority : System.Any_Priority; + -- Task's base priority when the protected operation was called + + Pending_Action : Boolean; + -- Flag indicating that priority has been dipped temporarily in order + -- to avoid violating the priority ceiling of the lock associated with + -- this protected object, in Lock_Server. The flag tells Unlock_Server + -- or Unlock_And_Update_Server to restore the old priority to + -- Old_Base_Priority. This is needed because of situations (bad + -- language design?) where one needs to lock a PO but to do so would + -- violate the priority ceiling. For example, this can happen when an + -- entry call has been requeued to a lower-priority object, and the + -- caller then tries to cancel the call while its own priority is + -- higher than the ceiling of the new PO. + + Finalized : Boolean := False; + -- Set to True by Finalize to make this routine idempotent + + Entry_Bodies : Protected_Entry_Body_Access; + -- Pointer to an array containing the executable code for all entry + -- bodies of a protected type. + + Find_Body_Index : Find_Body_Index_Access; + -- A function which maps the entry index in a call (which denotes the + -- queue of the proper entry) into the body of the entry. + + Entry_Queues : Protected_Entry_Queue_Array (1 .. Num_Entries); + + Entry_Names : Entry_Names_Array_Access := null; + -- An array of string names which denotes entry [family member] names. + -- The structure is indexed by protected entry index and contains Num_ + -- Entries components. + end record; + + -- No default initial values for this type, since call records + -- will need to be re-initialized before every use. + + type Protection_Entries_Access is access all Protection_Entries'Class; + -- See comments in s-tassta.adb about the implicit call to Current_Master + -- generated by this declaration. + + function To_Address is + new Ada.Unchecked_Conversion (Protection_Entries_Access, System.Address); + function To_Protection is + new Ada.Unchecked_Conversion (System.Address, Protection_Entries_Access); + + function Get_Ceiling + (Object : Protection_Entries_Access) return System.Any_Priority; + -- Returns the new ceiling priority of the protected object + + function Has_Interrupt_Or_Attach_Handler + (Object : Protection_Entries_Access) return Boolean; + -- Returns True if an Interrupt_Handler or Attach_Handler pragma applies + -- to the protected object. That is to say this primitive returns False for + -- Protection, but is overridden to return True when interrupt handlers are + -- declared so the check required by C.3.1(11) can be implemented in + -- System.Tasking.Protected_Objects.Initialize_Protection. + + procedure Initialize_Protection_Entries + (Object : Protection_Entries_Access; + Ceiling_Priority : Integer; + Compiler_Info : System.Address; + Entry_Bodies : Protected_Entry_Body_Access; + Find_Body_Index : Find_Body_Index_Access; + Build_Entry_Names : Boolean); + -- Initialize the Object parameter so that it can be used by the runtime + -- to keep track of the runtime state of a protected object. + + procedure Lock_Entries (Object : Protection_Entries_Access); + -- Lock a protected object for write access. Upon return, the caller owns + -- the lock to this object, and no other call to Lock or Lock_Read_Only + -- with the same argument will return until the corresponding call to + -- Unlock has been made by the caller. Program_Error is raised in case of + -- ceiling violation. + + procedure Lock_Entries + (Object : Protection_Entries_Access; + Ceiling_Violation : out Boolean); + -- Same as above, but return the ceiling violation status instead of + -- raising Program_Error. + + procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access); + -- Lock a protected object for read access. Upon return, the caller owns + -- the lock for read access, and no other calls to Lock with the same + -- argument will return until the corresponding call to Unlock has been + -- made by the caller. Other calls to Lock_Read_Only may (but need not) + -- return before the call to Unlock, and the corresponding callers will + -- also own the lock for read access. + -- + -- Note: we are not currently using this interface, it is provided for + -- possible future use. At the current time, everyone uses Lock for both + -- read and write locks. + + procedure Set_Ceiling + (Object : Protection_Entries_Access; + Prio : System.Any_Priority); + -- Sets the new ceiling priority of the protected object + + procedure Set_Entry_Name + (Object : Protection_Entries'Class; + Pos : Protected_Entry_Index; + Val : String_Access); + -- This is called by the compiler to map a string which denotes an entry + -- name to a protected entry index. + + procedure Unlock_Entries (Object : Protection_Entries_Access); + -- Relinquish ownership of the lock for the object represented by the + -- Object parameter. If this ownership was for write access, or if it was + -- for read access where there are no other read access locks outstanding, + -- one (or more, in the case of Lock_Read_Only) of the tasks waiting on + -- this lock (if any) will be given the lock and allowed to return from + -- the Lock or Lock_Read_Only call. + +private + + overriding procedure Finalize (Object : in out Protection_Entries); + -- Clean up a Protection object; in particular, finalize the associated + -- Lock object. + +end System.Tasking.Protected_Objects.Entries; diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb new file mode 100644 index 000000000..089018154 --- /dev/null +++ b/gcc/ada/s-tpobop.adb @@ -0,0 +1,1099 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2010, 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 contains all extended primitives related to Protected_Objects +-- with entries. + +-- The handling of protected objects with no entries is done in +-- System.Tasking.Protected_Objects, the simple routines for protected +-- objects with entries in System.Tasking.Protected_Objects.Entries. + +-- The split between Entries and Operations is needed to break circular +-- dependencies inside the run time. + +-- This package contains all primitives related to Protected_Objects. +-- Note: the compiler generates direct calls to this interface, via Rtsfind. + +with System.Task_Primitives.Operations; +with System.Tasking.Entry_Calls; +with System.Tasking.Queuing; +with System.Tasking.Rendezvous; +with System.Tasking.Utilities; +with System.Tasking.Debug; +with System.Parameters; +with System.Traces.Tasking; +with System.Restrictions; + +with System.Tasking.Initialization; +pragma Elaborate_All (System.Tasking.Initialization); +-- Insures that tasking is initialized if any protected objects are created + +package body System.Tasking.Protected_Objects.Operations is + + package STPO renames System.Task_Primitives.Operations; + + use Parameters; + use Task_Primitives; + use Ada.Exceptions; + use Entries; + + use System.Restrictions; + use System.Restrictions.Rident; + use System.Traces; + use System.Traces.Tasking; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Update_For_Queue_To_PO + (Entry_Call : Entry_Call_Link; + With_Abort : Boolean); + pragma Inline (Update_For_Queue_To_PO); + -- Update the state of an existing entry call to reflect the fact that it + -- is being enqueued, based on whether the current queuing action is with + -- or without abort. Call this only while holding the PO's lock. It returns + -- with the PO's lock still held. + + procedure Requeue_Call + (Self_Id : Task_Id; + Object : Protection_Entries_Access; + Entry_Call : Entry_Call_Link); + -- Handle requeue of Entry_Call. + -- In particular, queue the call if needed, or service it immediately + -- if possible. + + --------------------------------- + -- Cancel_Protected_Entry_Call -- + --------------------------------- + + -- Compiler interface only (do not call from within the RTS) + + -- This should have analogous effect to Cancel_Task_Entry_Call, setting + -- the value of Block.Cancelled instead of returning the parameter value + -- Cancelled. + + -- The effect should be idempotent, since the call may already have been + -- dequeued. + + -- Source code: + + -- select r.e; + -- ...A... + -- then abort + -- ...B... + -- end select; + + -- Expanded code: + + -- declare + -- X : protected_entry_index := 1; + -- B80b : communication_block; + -- communication_blockIP (B80b); + + -- begin + -- begin + -- A79b : label + -- A79b : declare + -- procedure _clean is + -- begin + -- if enqueued (B80b) then + -- cancel_protected_entry_call (B80b); + -- end if; + -- return; + -- end _clean; + + -- begin + -- protected_entry_call (rTV!(r)._object'unchecked_access, X, + -- null_address, asynchronous_call, B80b, objectF => 0); + -- if enqueued (B80b) then + -- ...B... + -- end if; + -- at end + -- _clean; + -- end A79b; + + -- exception + -- when _abort_signal => + -- abort_undefer.all; + -- null; + -- end; + + -- if not cancelled (B80b) then + -- x := ...A... + -- end if; + -- end; + + -- If the entry call completes after we get into the abortable part, + -- Abort_Signal should be raised and ATC will take us to the at-end + -- handler, which will call _clean. + + -- If the entry call returns with the call already completed, we can skip + -- this, and use the "if enqueued()" to go past the at-end handler, but we + -- will still call _clean. + + -- If the abortable part completes before the entry call is Done, it will + -- call _clean. + + -- If the entry call or the abortable part raises an exception, + -- we will still call _clean, but the value of Cancelled should not matter. + + -- Whoever calls _clean first gets to decide whether the call + -- has been "cancelled". + + -- Enqueued should be true if there is any chance that the call is still on + -- a queue. It seems to be safe to make it True if the call was Onqueue at + -- some point before return from Protected_Entry_Call. + + -- Cancelled should be true iff the abortable part completed + -- and succeeded in cancelling the entry call before it completed. + + -- ????? + -- The need for Enqueued is less obvious. The "if enqueued ()" tests are + -- not necessary, since Cancel_Protected_Entry_Call/Protected_Entry_Call + -- must do the same test internally, with locking. The one that makes + -- cancellation conditional may be a useful heuristic since at least 1/2 + -- the time the call should be off-queue by that point. The other one seems + -- totally useless, since Protected_Entry_Call must do the same check and + -- then possibly wait for the call to be abortable, internally. + + -- We can check Call.State here without locking the caller's mutex, + -- since the call must be over after returning from Wait_For_Completion. + -- No other task can access the call record at this point. + + procedure Cancel_Protected_Entry_Call + (Block : in out Communication_Block) is + begin + Entry_Calls.Try_To_Cancel_Entry_Call (Block.Cancelled); + end Cancel_Protected_Entry_Call; + + --------------- + -- Cancelled -- + --------------- + + function Cancelled (Block : Communication_Block) return Boolean is + begin + return Block.Cancelled; + end Cancelled; + + ------------------------- + -- Complete_Entry_Body -- + ------------------------- + + procedure Complete_Entry_Body (Object : Protection_Entries_Access) is + begin + Exceptional_Complete_Entry_Body (Object, Ada.Exceptions.Null_Id); + end Complete_Entry_Body; + + -------------- + -- Enqueued -- + -------------- + + function Enqueued (Block : Communication_Block) return Boolean is + begin + return Block.Enqueued; + end Enqueued; + + ------------------------------------- + -- Exceptional_Complete_Entry_Body -- + ------------------------------------- + + procedure Exceptional_Complete_Entry_Body + (Object : Protection_Entries_Access; + Ex : Ada.Exceptions.Exception_Id) + is + procedure Transfer_Occurrence + (Target : Ada.Exceptions.Exception_Occurrence_Access; + Source : Ada.Exceptions.Exception_Occurrence); + pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence"); + + Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress; + Self_Id : Task_Id; + + begin + pragma Debug + (Debug.Trace (STPO.Self, "Exceptional_Complete_Entry_Body", 'P')); + + -- We must have abort deferred, since we are inside a protected + -- operation. + + if Entry_Call /= null then + + -- The call was not requeued + + Entry_Call.Exception_To_Raise := Ex; + + if Ex /= Ada.Exceptions.Null_Id then + + -- An exception was raised and abort was deferred, so adjust + -- before propagating, otherwise the task will stay with deferral + -- enabled for its remaining life. + + Self_Id := STPO.Self; + Initialization.Undefer_Abort_Nestable (Self_Id); + Transfer_Occurrence + (Entry_Call.Self.Common.Compiler_Data.Current_Excep'Access, + Self_Id.Common.Compiler_Data.Current_Excep); + end if; + + -- Wakeup_Entry_Caller will be called from PO_Do_Or_Queue or + -- PO_Service_Entries on return. + + end if; + + if Runtime_Traces then + Send_Trace_Info (PO_Done, Entry_Call.Self); + end if; + end Exceptional_Complete_Entry_Body; + + -------------------- + -- PO_Do_Or_Queue -- + -------------------- + + procedure PO_Do_Or_Queue + (Self_ID : Task_Id; + Object : Protection_Entries_Access; + Entry_Call : Entry_Call_Link) + is + E : constant Protected_Entry_Index := + Protected_Entry_Index (Entry_Call.E); + Barrier_Value : Boolean; + + begin + -- When the Action procedure for an entry body returns, it is either + -- completed (having called [Exceptional_]Complete_Entry_Body) or it + -- is queued, having executed a requeue statement. + + Barrier_Value := + Object.Entry_Bodies ( + Object.Find_Body_Index (Object.Compiler_Info, E)). + Barrier (Object.Compiler_Info, E); + + if Barrier_Value then + + -- Not abortable while service is in progress + + if Entry_Call.State = Now_Abortable then + Entry_Call.State := Was_Abortable; + end if; + + Object.Call_In_Progress := Entry_Call; + + pragma Debug + (Debug.Trace (Self_ID, "PODOQ: start entry body", 'P')); + Object.Entry_Bodies ( + Object.Find_Body_Index (Object.Compiler_Info, E)).Action ( + Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E); + + if Object.Call_In_Progress /= null then + + -- Body of current entry served call to completion + + Object.Call_In_Progress := null; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Entry_Call.Self); + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + STPO.Unlock (Entry_Call.Self); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + else + Requeue_Call (Self_ID, Object, Entry_Call); + end if; + + elsif Entry_Call.Mode /= Conditional_Call + or else not Entry_Call.With_Abort + then + + if Run_Time_Restrictions.Set (Max_Entry_Queue_Length) + and then + Run_Time_Restrictions.Value (Max_Entry_Queue_Length) <= + Queuing.Count_Waiting (Object.Entry_Queues (E)) + then + -- This violates the Max_Entry_Queue_Length restriction, + -- raise Program_Error. + + Entry_Call.Exception_To_Raise := Program_Error'Identity; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Entry_Call.Self); + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + STPO.Unlock (Entry_Call.Self); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + else + Queuing.Enqueue (Object.Entry_Queues (E), Entry_Call); + Update_For_Queue_To_PO (Entry_Call, Entry_Call.With_Abort); + end if; + else + -- Conditional_Call and With_Abort + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Entry_Call.Self); + pragma Assert (Entry_Call.State >= Was_Abortable); + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled); + STPO.Unlock (Entry_Call.Self); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + end if; + + exception + when others => + Queuing.Broadcast_Program_Error (Self_ID, Object, Entry_Call); + end PO_Do_Or_Queue; + + ------------------------ + -- PO_Service_Entries -- + ------------------------ + + procedure PO_Service_Entries + (Self_ID : Task_Id; + Object : Entries.Protection_Entries_Access; + Unlock_Object : Boolean := True) + is + E : Protected_Entry_Index; + Caller : Task_Id; + Entry_Call : Entry_Call_Link; + + begin + loop + Queuing.Select_Protected_Entry_Call (Self_ID, Object, Entry_Call); + + exit when Entry_Call = null; + + E := Protected_Entry_Index (Entry_Call.E); + + -- Not abortable while service is in progress + + if Entry_Call.State = Now_Abortable then + Entry_Call.State := Was_Abortable; + end if; + + Object.Call_In_Progress := Entry_Call; + + begin + if Runtime_Traces then + Send_Trace_Info (PO_Run, Self_ID, + Entry_Call.Self, Entry_Index (E)); + end if; + + pragma Debug + (Debug.Trace (Self_ID, "POSE: start entry body", 'P')); + + Object.Entry_Bodies + (Object.Find_Body_Index (Object.Compiler_Info, E)).Action + (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E); + + exception + when others => + Queuing.Broadcast_Program_Error + (Self_ID, Object, Entry_Call); + end; + + if Object.Call_In_Progress = null then + Requeue_Call (Self_ID, Object, Entry_Call); + exit when Entry_Call.State = Cancelled; + + else + Object.Call_In_Progress := null; + Caller := Entry_Call.Self; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + STPO.Unlock (Caller); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + end if; + end loop; + + if Unlock_Object then + Unlock_Entries (Object); + end if; + end PO_Service_Entries; + + --------------------- + -- Protected_Count -- + --------------------- + + function Protected_Count + (Object : Protection_Entries'Class; + E : Protected_Entry_Index) return Natural + is + begin + return Queuing.Count_Waiting (Object.Entry_Queues (E)); + end Protected_Count; + + -------------------------- + -- Protected_Entry_Call -- + -------------------------- + + -- Compiler interface only (do not call from within the RTS) + + -- select r.e; + -- ...A... + -- else + -- ...B... + -- end select; + + -- declare + -- X : protected_entry_index := 1; + -- B85b : communication_block; + -- communication_blockIP (B85b); + + -- begin + -- protected_entry_call (rTV!(r)._object'unchecked_access, X, + -- null_address, conditional_call, B85b, objectF => 0); + + -- if cancelled (B85b) then + -- ...B... + -- else + -- ...A... + -- end if; + -- end; + + -- See also Cancel_Protected_Entry_Call for code expansion of asynchronous + -- entry call. + + -- The initial part of this procedure does not need to lock the calling + -- task's ATCB, up to the point where the call record first may be queued + -- (PO_Do_Or_Queue), since before that no other task will have access to + -- the record. + + -- If this is a call made inside of an abort deferred region, the call + -- should be never abortable. + + -- If the call was not queued abortably, we need to wait until it is before + -- proceeding with the abortable part. + + -- There are some heuristics here, just to save time for frequently + -- occurring cases. For example, we check Initially_Abortable to try to + -- avoid calling the procedure Wait_Until_Abortable, since the normal case + -- for async. entry calls is to be queued abortably. + + -- Another heuristic uses the Block.Enqueued to try to avoid calling + -- Cancel_Protected_Entry_Call if the call can be served immediately. + + procedure Protected_Entry_Call + (Object : Protection_Entries_Access; + E : Protected_Entry_Index; + Uninterpreted_Data : System.Address; + Mode : Call_Modes; + Block : out Communication_Block) + is + Self_ID : constant Task_Id := STPO.Self; + Entry_Call : Entry_Call_Link; + Initially_Abortable : Boolean; + Ceiling_Violation : Boolean; + + begin + pragma Debug + (Debug.Trace (Self_ID, "Protected_Entry_Call", 'P')); + + if Runtime_Traces then + Send_Trace_Info (PO_Call, Entry_Index (E)); + end if; + + if Self_ID.ATC_Nesting_Level = ATC_Level'Last then + raise Storage_Error with "not enough ATC nesting levels"; + end if; + + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if Detect_Blocking + and then Self_ID.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with "potentially blocking operation"; + end if; + + -- Self_ID.Deferral_Level should be 0, except when called from Finalize, + -- where abort is already deferred. + + Initialization.Defer_Abort_Nestable (Self_ID); + Lock_Entries (Object, Ceiling_Violation); + + if Ceiling_Violation then + + -- Failed ceiling check + + Initialization.Undefer_Abort_Nestable (Self_ID); + raise Program_Error; + end if; + + Block.Self := Self_ID; + Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level + 1; + pragma Debug + (Debug.Trace (Self_ID, "PEC: entered ATC level: " & + ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A')); + Entry_Call := + Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access; + Entry_Call.Next := null; + Entry_Call.Mode := Mode; + Entry_Call.Cancellation_Attempted := False; + + Entry_Call.State := + (if Self_ID.Deferral_Level > 1 + then Never_Abortable else Now_Abortable); + + Entry_Call.E := Entry_Index (E); + Entry_Call.Prio := STPO.Get_Priority (Self_ID); + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Called_PO := To_Address (Object); + Entry_Call.Called_Task := null; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + Entry_Call.With_Abort := True; + + PO_Do_Or_Queue (Self_ID, Object, Entry_Call); + Initially_Abortable := Entry_Call.State = Now_Abortable; + PO_Service_Entries (Self_ID, Object); + + -- Try to prevent waiting later (in Try_To_Cancel_Protected_Entry_Call) + -- for completed or cancelled calls. (This is a heuristic, only.) + + if Entry_Call.State >= Done then + + -- Once State >= Done it will not change any more + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Self_ID); + Utilities.Exit_One_ATC_Level (Self_ID); + STPO.Unlock (Self_ID); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + Block.Enqueued := False; + Block.Cancelled := Entry_Call.State = Cancelled; + Initialization.Undefer_Abort_Nestable (Self_ID); + Entry_Calls.Check_Exception (Self_ID, Entry_Call); + return; + + else + -- In this case we cannot conclude anything, since State can change + -- concurrently. + + null; + end if; + + -- Now for the general case + + if Mode = Asynchronous_Call then + + -- Try to avoid an expensive call + + if not Initially_Abortable then + if Single_Lock then + STPO.Lock_RTS; + Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call); + STPO.Unlock_RTS; + else + Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call); + end if; + end if; + + else + case Mode is + when Simple_Call | Conditional_Call => + if Single_Lock then + STPO.Lock_RTS; + Entry_Calls.Wait_For_Completion (Entry_Call); + STPO.Unlock_RTS; + + else + STPO.Write_Lock (Self_ID); + Entry_Calls.Wait_For_Completion (Entry_Call); + STPO.Unlock (Self_ID); + end if; + + Block.Cancelled := Entry_Call.State = Cancelled; + + when Asynchronous_Call | Timed_Call => + pragma Assert (False); + null; + end case; + end if; + + Initialization.Undefer_Abort_Nestable (Self_ID); + Entry_Calls.Check_Exception (Self_ID, Entry_Call); + end Protected_Entry_Call; + + ------------------ + -- Requeue_Call -- + ------------------ + + procedure Requeue_Call + (Self_Id : Task_Id; + Object : Protection_Entries_Access; + Entry_Call : Entry_Call_Link) + is + New_Object : Protection_Entries_Access; + Ceiling_Violation : Boolean; + Result : Boolean; + E : Protected_Entry_Index; + + begin + New_Object := To_Protection (Entry_Call.Called_PO); + + if New_Object = null then + + -- Call is to be requeued to a task entry + + if Single_Lock then + STPO.Lock_RTS; + end if; + + Result := Rendezvous.Task_Do_Or_Queue (Self_Id, Entry_Call); + + if not Result then + Queuing.Broadcast_Program_Error + (Self_Id, Object, Entry_Call, RTS_Locked => True); + end if; + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + else + -- Call should be requeued to a PO + + if Object /= New_Object then + + -- Requeue is to different PO + + Lock_Entries (New_Object, Ceiling_Violation); + + if Ceiling_Violation then + Object.Call_In_Progress := null; + Queuing.Broadcast_Program_Error (Self_Id, Object, Entry_Call); + + else + PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call); + PO_Service_Entries (Self_Id, New_Object); + end if; + + else + -- Requeue is to same protected object + + -- ??? Try to compensate apparent failure of the scheduler on some + -- OS (e.g VxWorks) to give higher priority tasks a chance to run + -- (see CXD6002). + + STPO.Yield (False); + + if Entry_Call.With_Abort + and then Entry_Call.Cancellation_Attempted + then + -- If this is a requeue with abort and someone tried to cancel + -- this call, cancel it at this point. + + Entry_Call.State := Cancelled; + return; + end if; + + if not Entry_Call.With_Abort + or else Entry_Call.Mode /= Conditional_Call + then + E := Protected_Entry_Index (Entry_Call.E); + + if Run_Time_Restrictions.Set (Max_Entry_Queue_Length) + and then + Run_Time_Restrictions.Value (Max_Entry_Queue_Length) <= + Queuing.Count_Waiting (Object.Entry_Queues (E)) + then + -- This violates the Max_Entry_Queue_Length restriction, + -- raise Program_Error. + + Entry_Call.Exception_To_Raise := Program_Error'Identity; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Entry_Call.Self); + Initialization.Wakeup_Entry_Caller + (Self_Id, Entry_Call, Done); + STPO.Unlock (Entry_Call.Self); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + else + Queuing.Enqueue + (New_Object.Entry_Queues (E), Entry_Call); + Update_For_Queue_To_PO (Entry_Call, Entry_Call.With_Abort); + end if; + + else + PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call); + end if; + end if; + end if; + end Requeue_Call; + + ---------------------------- + -- Protected_Entry_Caller -- + ---------------------------- + + function Protected_Entry_Caller + (Object : Protection_Entries'Class) return Task_Id is + begin + return Object.Call_In_Progress.Self; + end Protected_Entry_Caller; + + ----------------------------- + -- Requeue_Protected_Entry -- + ----------------------------- + + -- Compiler interface only (do not call from within the RTS) + + -- entry e when b is + -- begin + -- b := false; + -- ...A... + -- requeue e2; + -- end e; + + -- procedure rPT__E10b (O : address; P : address; E : + -- protected_entry_index) is + -- type rTVP is access rTV; + -- freeze rTVP [] + -- _object : rTVP := rTVP!(O); + -- begin + -- declare + -- rR : protection renames _object._object; + -- vP : integer renames _object.v; + -- bP : boolean renames _object.b; + -- begin + -- b := false; + -- ...A... + -- requeue_protected_entry (rR'unchecked_access, rR' + -- unchecked_access, 2, false, objectF => 0, new_objectF => + -- 0); + -- return; + -- end; + -- complete_entry_body (_object._object'unchecked_access, objectF => + -- 0); + -- return; + -- exception + -- when others => + -- abort_undefer.all; + -- exceptional_complete_entry_body (_object._object' + -- unchecked_access, current_exception, objectF => 0); + -- return; + -- end rPT__E10b; + + procedure Requeue_Protected_Entry + (Object : Protection_Entries_Access; + New_Object : Protection_Entries_Access; + E : Protected_Entry_Index; + With_Abort : Boolean) + is + Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress; + + begin + pragma Debug + (Debug.Trace (STPO.Self, "Requeue_Protected_Entry", 'P')); + pragma Assert (STPO.Self.Deferral_Level > 0); + + Entry_Call.E := Entry_Index (E); + Entry_Call.Called_PO := To_Address (New_Object); + Entry_Call.Called_Task := null; + Entry_Call.With_Abort := With_Abort; + Object.Call_In_Progress := null; + end Requeue_Protected_Entry; + + ------------------------------------- + -- Requeue_Task_To_Protected_Entry -- + ------------------------------------- + + -- Compiler interface only (do not call from within the RTS) + + -- accept e1 do + -- ...A... + -- requeue r.e2; + -- end e1; + + -- A79b : address; + -- L78b : label + + -- begin + -- accept_call (1, A79b); + -- ...A... + -- requeue_task_to_protected_entry (rTV!(r)._object' + -- unchecked_access, 2, false, new_objectF => 0); + -- goto L78b; + -- <> + -- complete_rendezvous; + + -- exception + -- when all others => + -- exceptional_complete_rendezvous (get_gnat_exception); + -- end; + + procedure Requeue_Task_To_Protected_Entry + (New_Object : Protection_Entries_Access; + E : Protected_Entry_Index; + With_Abort : Boolean) + is + Self_ID : constant Task_Id := STPO.Self; + Entry_Call : constant Entry_Call_Link := Self_ID.Common.Call; + + begin + Initialization.Defer_Abort (Self_ID); + + -- We do not need to lock Self_ID here since the call is not abortable + -- at this point, and therefore, the caller cannot cancel the call. + + Entry_Call.Needs_Requeue := True; + Entry_Call.With_Abort := With_Abort; + Entry_Call.Called_PO := To_Address (New_Object); + Entry_Call.Called_Task := null; + Entry_Call.E := Entry_Index (E); + Initialization.Undefer_Abort (Self_ID); + end Requeue_Task_To_Protected_Entry; + + --------------------- + -- Service_Entries -- + --------------------- + + procedure Service_Entries (Object : Protection_Entries_Access) is + Self_ID : constant Task_Id := STPO.Self; + begin + PO_Service_Entries (Self_ID, Object); + end Service_Entries; + + -------------------------------- + -- Timed_Protected_Entry_Call -- + -------------------------------- + + -- Compiler interface only (do not call from within the RTS) + + procedure Timed_Protected_Entry_Call + (Object : Protection_Entries_Access; + E : Protected_Entry_Index; + Uninterpreted_Data : System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Entry_Call_Successful : out Boolean) + is + Self_Id : constant Task_Id := STPO.Self; + Entry_Call : Entry_Call_Link; + Ceiling_Violation : Boolean; + + Yielded : Boolean; + pragma Unreferenced (Yielded); + + begin + if Self_Id.ATC_Nesting_Level = ATC_Level'Last then + raise Storage_Error with "not enough ATC nesting levels"; + end if; + + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with "potentially blocking operation"; + end if; + + if Runtime_Traces then + Send_Trace_Info (POT_Call, Entry_Index (E), Timeout); + end if; + + Initialization.Defer_Abort_Nestable (Self_Id); + Lock_Entries (Object, Ceiling_Violation); + + if Ceiling_Violation then + Initialization.Undefer_Abort (Self_Id); + raise Program_Error; + end if; + + Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; + pragma Debug + (Debug.Trace (Self_Id, "TPEC: exited to ATC level: " & + ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access; + Entry_Call.Next := null; + Entry_Call.Mode := Timed_Call; + Entry_Call.Cancellation_Attempted := False; + + Entry_Call.State := + (if Self_Id.Deferral_Level > 1 + then Never_Abortable + else Now_Abortable); + + Entry_Call.E := Entry_Index (E); + Entry_Call.Prio := STPO.Get_Priority (Self_Id); + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Called_PO := To_Address (Object); + Entry_Call.Called_Task := null; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + Entry_Call.With_Abort := True; + + PO_Do_Or_Queue (Self_Id, Object, Entry_Call); + PO_Service_Entries (Self_Id, Object); + + if Single_Lock then + STPO.Lock_RTS; + else + STPO.Write_Lock (Self_Id); + end if; + + -- Try to avoid waiting for completed or cancelled calls + + if Entry_Call.State >= Done then + Utilities.Exit_One_ATC_Level (Self_Id); + + if Single_Lock then + STPO.Unlock_RTS; + else + STPO.Unlock (Self_Id); + end if; + + Entry_Call_Successful := Entry_Call.State = Done; + Initialization.Undefer_Abort_Nestable (Self_Id); + Entry_Calls.Check_Exception (Self_Id, Entry_Call); + return; + end if; + + Entry_Calls.Wait_For_Completion_With_Timeout + (Entry_Call, Timeout, Mode, Yielded); + + if Single_Lock then + STPO.Unlock_RTS; + else + STPO.Unlock (Self_Id); + end if; + + -- ??? Do we need to yield in case Yielded is False + + Initialization.Undefer_Abort_Nestable (Self_Id); + Entry_Call_Successful := Entry_Call.State = Done; + Entry_Calls.Check_Exception (Self_Id, Entry_Call); + end Timed_Protected_Entry_Call; + + ---------------------------- + -- Update_For_Queue_To_PO -- + ---------------------------- + + -- Update the state of an existing entry call, based on + -- whether the current queuing action is with or without abort. + -- Call this only while holding the server's lock. + -- It returns with the server's lock released. + + New_State : constant array (Boolean, Entry_Call_State) + of Entry_Call_State := + (True => + (Never_Abortable => Never_Abortable, + Not_Yet_Abortable => Now_Abortable, + Was_Abortable => Now_Abortable, + Now_Abortable => Now_Abortable, + Done => Done, + Cancelled => Cancelled), + False => + (Never_Abortable => Never_Abortable, + Not_Yet_Abortable => Not_Yet_Abortable, + Was_Abortable => Was_Abortable, + Now_Abortable => Now_Abortable, + Done => Done, + Cancelled => Cancelled) + ); + + procedure Update_For_Queue_To_PO + (Entry_Call : Entry_Call_Link; + With_Abort : Boolean) + is + Old : constant Entry_Call_State := Entry_Call.State; + + begin + pragma Assert (Old < Done); + + Entry_Call.State := New_State (With_Abort, Entry_Call.State); + + if Entry_Call.Mode = Asynchronous_Call then + if Old < Was_Abortable and then + Entry_Call.State = Now_Abortable + then + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Entry_Call.Self); + + if Entry_Call.Self.Common.State = Async_Select_Sleep then + STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep); + end if; + + STPO.Unlock (Entry_Call.Self); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + end if; + + elsif Entry_Call.Mode = Conditional_Call then + pragma Assert (Entry_Call.State < Was_Abortable); + null; + end if; + end Update_For_Queue_To_PO; + +end System.Tasking.Protected_Objects.Operations; diff --git a/gcc/ada/s-tpobop.ads b/gcc/ada/s-tpobop.ads new file mode 100644 index 000000000..9b67fbd46 --- /dev/null +++ b/gcc/ada/s-tpobop.ads @@ -0,0 +1,213 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains all the extended primitives related to protected +-- objects with entries. + +-- The handling of protected objects with no entries is done in +-- System.Tasking.Protected_Objects, the simple routines for protected +-- objects with entries in System.Tasking.Protected_Objects.Entries. The +-- split between Entries and Operations is needed to break circular +-- dependencies inside the run time. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +with Ada.Exceptions; + +with System.Tasking.Protected_Objects.Entries; + +package System.Tasking.Protected_Objects.Operations is + pragma Elaborate_Body; + + type Communication_Block is private; + -- Objects of this type are passed between GNARL calls to allow RTS + -- information to be preserved. + + procedure Protected_Entry_Call + (Object : Entries.Protection_Entries_Access; + E : Protected_Entry_Index; + Uninterpreted_Data : System.Address; + Mode : Call_Modes; + Block : out Communication_Block); + -- Make a protected entry call to the specified object. + -- Pend a protected entry call on the protected object represented + -- by Object. A pended call is not queued; it may be executed immediately + -- or queued, depending on the state of the entry barrier. + -- + -- E + -- The index representing the entry to be called. + -- + -- Uninterpreted_Data + -- This will be returned by Next_Entry_Call when this call is serviced. + -- It can be used by the compiler to pass information between the + -- caller and the server, in particular entry parameters. + -- + -- Mode + -- The kind of call to be pended + -- + -- Block + -- Information passed between runtime calls by the compiler + + procedure Timed_Protected_Entry_Call + (Object : Entries.Protection_Entries_Access; + E : Protected_Entry_Index; + Uninterpreted_Data : System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Entry_Call_Successful : out Boolean); + -- Same as the Protected_Entry_Call but with time-out specified. + -- This routines is used when we do not use ATC mechanism to implement + -- timed entry calls. + + procedure Service_Entries (Object : Entries.Protection_Entries_Access); + pragma Inline (Service_Entries); + + procedure PO_Service_Entries + (Self_ID : Task_Id; + Object : Entries.Protection_Entries_Access; + Unlock_Object : Boolean := True); + -- Service all entry queues of the specified object, executing the + -- corresponding bodies of any queued entry calls that are waiting + -- on True barriers. This is used when the state of a protected + -- object may have changed, in particular after the execution of + -- the statement sequence of a protected procedure. + -- + -- Note that servicing an entry may change the value of one or more + -- barriers, so this routine keeps checking barriers until all of + -- them are closed. + -- + -- This must be called with abort deferred and with the corresponding + -- object locked. + -- + -- If Unlock_Object is set True, then Object is unlocked on return, + -- otherwise Object remains locked and the caller is responsible for + -- the required unlock. + + procedure Complete_Entry_Body (Object : Entries.Protection_Entries_Access); + -- Called from within an entry body procedure, indicates that the + -- corresponding entry call has been serviced. + + procedure Exceptional_Complete_Entry_Body + (Object : Entries.Protection_Entries_Access; + Ex : Ada.Exceptions.Exception_Id); + -- Perform all of the functions of Complete_Entry_Body. In addition, + -- report in Ex the exception whose propagation terminated the entry + -- body to the runtime system. + + procedure Cancel_Protected_Entry_Call (Block : in out Communication_Block); + -- Attempt to cancel the most recent protected entry call. If the call is + -- not queued abortably, wait until it is or until it has completed. + -- If the call is actually cancelled, the called object will be + -- locked on return from this call. Get_Cancelled (Block) can be + -- used to determine if the cancellation took place; there + -- may be entries needing service in this case. + -- + -- Block passes information between this and other runtime calls. + + function Enqueued (Block : Communication_Block) return Boolean; + -- Returns True if the Protected_Entry_Call which returned the + -- specified Block object was queued; False otherwise. + + function Cancelled (Block : Communication_Block) return Boolean; + -- Returns True if the Protected_Entry_Call which returned the + -- specified Block object was cancelled, False otherwise. + + procedure Requeue_Protected_Entry + (Object : Entries.Protection_Entries_Access; + New_Object : Entries.Protection_Entries_Access; + E : Protected_Entry_Index; + With_Abort : Boolean); + -- If Object = New_Object, queue the protected entry call on Object + -- currently being serviced on the queue corresponding to the entry + -- represented by E. + -- + -- If Object /= New_Object, transfer the call to New_Object.E, + -- executing or queuing it as appropriate. + -- + -- With_Abort---True if the call is to be queued abortably, false + -- otherwise. + + procedure Requeue_Task_To_Protected_Entry + (New_Object : Entries.Protection_Entries_Access; + E : Protected_Entry_Index; + With_Abort : Boolean); + -- Transfer task entry call currently being serviced to entry E + -- on New_Object. + -- + -- With_Abort---True if the call is to be queued abortably, false + -- otherwise. + + function Protected_Count + (Object : Entries.Protection_Entries'Class; + E : Protected_Entry_Index) + return Natural; + -- Return the number of entry calls to E on Object + + function Protected_Entry_Caller + (Object : Entries.Protection_Entries'Class) return Task_Id; + -- Return value of E'Caller, where E is the protected entry currently + -- being handled. This will only work if called from within an entry + -- body, as required by the LRM (C.7.1(14)). + + -- For internal use only + + procedure PO_Do_Or_Queue + (Self_ID : Task_Id; + Object : Entries.Protection_Entries_Access; + Entry_Call : Entry_Call_Link); + -- This procedure either executes or queues an entry call, depending + -- on the status of the corresponding barrier. It assumes that abort + -- is deferred and that the specified object is locked. + +private + type Communication_Block is record + Self : Task_Id; + Enqueued : Boolean := True; + Cancelled : Boolean := False; + end record; + pragma Volatile (Communication_Block); + + -- When a program contains limited interfaces, the compiler generates the + -- predefined primitives associated with dispatching selects. One of the + -- parameters of these routines is of type Communication_Block. Even if + -- the program lacks implementing concurrent types, the tasking runtime is + -- dragged in unconditionally because of Communication_Block. To avoid this + -- case, the compiler uses type Dummy_Communication_Block which defined in + -- System.Soft_Links. If the structure of Communication_Block is changed, + -- the corresponding dummy type must be changed as well. + + -- The Communication_Block seems to be a relic. At the moment, the + -- compiler seems to be generating unnecessary conditional code based on + -- this block. See the code generated for async. select with task entry + -- call for another way of solving this ??? + +end System.Tasking.Protected_Objects.Operations; diff --git a/gcc/ada/s-tpopde-vms.adb b/gcc/ada/s-tpopde-vms.adb new file mode 100644 index 000000000..4f7cdad61 --- /dev/null +++ b/gcc/ada/s-tpopde-vms.adb @@ -0,0 +1,161 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.DEC -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2000-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 is for OpenVMS/Alpha + +with System.OS_Interface; +with System.Parameters; +with System.Tasking; +with Ada.Unchecked_Conversion; +with System.Soft_Links; + +package body System.Task_Primitives.Operations.DEC is + + use System.OS_Interface; + use System.Parameters; + use System.Tasking; + use System.Aux_DEC; + use type Interfaces.C.int; + + package SSL renames System.Soft_Links; + + -- The FAB_RAB_Type specifies where the context field (the calling + -- task) is stored. Other fields defined for FAB_RAB arent' need and + -- so are ignored. + + type FAB_RAB_Type is record + CTX : Unsigned_Longword; + end record; + + for FAB_RAB_Type use record + CTX at 24 range 0 .. 31; + end record; + + for FAB_RAB_Type'Size use 224; + + type FAB_RAB_Access_Type is access all FAB_RAB_Type; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function To_Unsigned_Longword is new + Ada.Unchecked_Conversion (Task_Id, Unsigned_Longword); + + function To_Task_Id is new + Ada.Unchecked_Conversion (Unsigned_Longword, Task_Id); + + function To_FAB_RAB is new + Ada.Unchecked_Conversion (Address, FAB_RAB_Access_Type); + + --------------------------- + -- Interrupt_AST_Handler -- + --------------------------- + + procedure Interrupt_AST_Handler (ID : Address) is + Result : Interfaces.C.int; + AST_Self_ID : constant Task_Id := To_Task_Id (ID); + begin + Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Interrupt_AST_Handler; + + --------------------- + -- RMS_AST_Handler -- + --------------------- + + procedure RMS_AST_Handler (ID : Address) is + AST_Self_ID : constant Task_Id := To_Task_Id (To_FAB_RAB (ID).CTX); + Result : Interfaces.C.int; + + begin + AST_Self_ID.Common.LL.AST_Pending := False; + Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); + pragma Assert (Result = 0); + end RMS_AST_Handler; + + ---------- + -- Self -- + ---------- + + function Self return Unsigned_Longword is + Self_ID : constant Task_Id := Self; + begin + Self_ID.Common.LL.AST_Pending := True; + return To_Unsigned_Longword (Self); + end Self; + + ------------------------- + -- Starlet_AST_Handler -- + ------------------------- + + procedure Starlet_AST_Handler (ID : Address) is + Result : Interfaces.C.int; + AST_Self_ID : constant Task_Id := To_Task_Id (ID); + begin + AST_Self_ID.Common.LL.AST_Pending := False; + Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Starlet_AST_Handler; + + ---------------- + -- Task_Synch -- + ---------------- + + procedure Task_Synch is + Synch_Self_ID : constant Task_Id := Self; + + begin + if Single_Lock then + Lock_RTS; + else + Write_Lock (Synch_Self_ID); + end if; + + SSL.Abort_Defer.all; + Synch_Self_ID.Common.State := AST_Server_Sleep; + + while Synch_Self_ID.Common.LL.AST_Pending loop + Sleep (Synch_Self_ID, AST_Server_Sleep); + end loop; + + Synch_Self_ID.Common.State := Runnable; + + if Single_Lock then + Unlock_RTS; + else + Unlock (Synch_Self_ID); + end if; + + SSL.Abort_Undefer.all; + end Task_Synch; + +end System.Task_Primitives.Operations.DEC; diff --git a/gcc/ada/s-tpopde-vms.ads b/gcc/ada/s-tpopde-vms.ads new file mode 100644 index 000000000..aadafa649 --- /dev/null +++ b/gcc/ada/s-tpopde-vms.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.DEC -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-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 is for OpenVMS/Alpha. +-- +with System.Aux_DEC; +package System.Task_Primitives.Operations.DEC is + + procedure Interrupt_AST_Handler (ID : Address); + pragma Convention (C, Interrupt_AST_Handler); + -- Handles the AST for Ada95 Interrupts + + procedure RMS_AST_Handler (ID : Address); + -- Handles the AST for RMS_Asynch_Operations + + function Self return System.Aux_DEC.Unsigned_Longword; + -- Returns the task identification for the AST + + procedure Starlet_AST_Handler (ID : Address); + -- Handles the AST for Starlet Tasking_Services + + procedure Task_Synch; + -- Synchronizes the task after the system service completes + +end System.Task_Primitives.Operations.DEC; diff --git a/gcc/ada/s-tpopsp-lynxos.adb b/gcc/ada/s-tpopsp-lynxos.adb new file mode 100644 index 000000000..bc98b11fa --- /dev/null +++ b/gcc/ada/s-tpopsp-lynxos.adb @@ -0,0 +1,111 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a LynxOS version of this package. + +separate (System.Task_Primitives.Operations) +package body Specific is + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_Id) is + pragma Warnings (Off, Environment_Task); + Result : Interfaces.C.int; + + begin + Result := st_keycreate (null, ATCB_Key'Access); + pragma Assert (Result = 0); + end Initialize; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean is + Result : Interfaces.C.int; + Value : aliased System.Address; + begin + Result := st_getspecific (ATCB_Key, Value'Address); + pragma Assert (Result = 0); + return (Value /= System.Null_Address); + end Is_Valid_Task; + + --------- + -- Set -- + --------- + + procedure Set (Self_Id : Task_Id) is + Result : Interfaces.C.int; + + begin + Result := st_setspecific (ATCB_Key, To_Address (Self_Id)); + pragma Assert (Result = 0); + end Set; + + ---------- + -- Self -- + ---------- + + -- To make Ada tasks and C threads interoperate better, we have added some + -- functionality to Self. Suppose a C main program (with threads) calls an + -- Ada procedure and the Ada procedure calls the tasking runtime system. + -- Eventually, a call will be made to self. Since the call is not coming + -- from an Ada task, there will be no corresponding ATCB. + + -- What we do in Self is to catch references that do not come from + -- recognized Ada tasks, and create an ATCB for the calling thread. + + -- The new ATCB will be "detached" from the normal Ada task master + -- hierarchy, much like the existing implicitly created signal-server + -- tasks. + + function Self return Task_Id is + Value : aliased System.Address; + + Result : Interfaces.C.int; + pragma Unreferenced (Result); + + begin + Result := st_getspecific (ATCB_Key, Value'Address); + -- Is it OK not to check this result??? + + -- If the key value is Null, then it is a non-Ada task. + + if Value /= System.Null_Address then + return To_Task_Id (Value); + else + return Register_Foreign_Thread; + end if; + end Self; + +end Specific; diff --git a/gcc/ada/s-tpopsp-posix-foreign.adb b/gcc/ada/s-tpopsp-posix-foreign.adb new file mode 100644 index 000000000..c987f6e27 --- /dev/null +++ b/gcc/ada/s-tpopsp-posix-foreign.adb @@ -0,0 +1,106 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a POSIX version of this package where foreign threads are +-- recognized. + +-- Currently, DEC Unix, SCO UnixWare, Solaris pthread, HPUX pthread and +-- GNU/Linux threads use this version. + +separate (System.Task_Primitives.Operations) +package body Specific is + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_Id) is + pragma Warnings (Off, Environment_Task); + Result : Interfaces.C.int; + + begin + Result := pthread_key_create (ATCB_Key'Access, null); + pragma Assert (Result = 0); + end Initialize; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean is + begin + return pthread_getspecific (ATCB_Key) /= System.Null_Address; + end Is_Valid_Task; + + --------- + -- Set -- + --------- + + procedure Set (Self_Id : Task_Id) is + Result : Interfaces.C.int; + begin + Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id)); + pragma Assert (Result = 0); + end Set; + + ---------- + -- Self -- + ---------- + + -- To make Ada tasks and C threads interoperate better, we have added some + -- functionality to Self. Suppose a C main program (with threads) calls an + -- Ada procedure and the Ada procedure calls the tasking runtime system. + -- Eventually, a call will be made to self. Since the call is not coming + -- from an Ada task, there will be no corresponding ATCB. + + -- What we do in Self is to catch references that do not come from + -- recognized Ada tasks, and create an ATCB for the calling thread. + + -- The new ATCB will be "detached" from the normal Ada task master + -- hierarchy, much like the existing implicitly created signal-server + -- tasks. + + function Self return Task_Id is + Result : System.Address; + + begin + Result := pthread_getspecific (ATCB_Key); + + -- If the key value is Null then it is a non-Ada task + + if Result /= System.Null_Address then + return To_Task_Id (Result); + else + return Register_Foreign_Thread; + end if; + end Self; + +end Specific; diff --git a/gcc/ada/s-tpopsp-posix.adb b/gcc/ada/s-tpopsp-posix.adb new file mode 100644 index 000000000..e7273a586 --- /dev/null +++ b/gcc/ada/s-tpopsp-posix.adb @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a POSIX-like version of this package + +separate (System.Task_Primitives.Operations) +package body Specific is + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_Id) is + pragma Warnings (Off, Environment_Task); + Result : Interfaces.C.int; + begin + Result := pthread_key_create (ATCB_Key'Access, null); + pragma Assert (Result = 0); + end Initialize; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean is + begin + return pthread_getspecific (ATCB_Key) /= System.Null_Address; + end Is_Valid_Task; + + --------- + -- Set -- + --------- + + procedure Set (Self_Id : Task_Id) is + Result : Interfaces.C.int; + begin + Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id)); + pragma Assert (Result = 0); + end Set; + + ---------- + -- Self -- + ---------- + + function Self return Task_Id is + begin + return To_Task_Id (pthread_getspecific (ATCB_Key)); + end Self; + +end Specific; diff --git a/gcc/ada/s-tpopsp-rtems.adb b/gcc/ada/s-tpopsp-rtems.adb new file mode 100644 index 000000000..81afc79cb --- /dev/null +++ b/gcc/ada/s-tpopsp-rtems.adb @@ -0,0 +1,116 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S . -- +-- S P E C I F I C -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.2 $ +-- -- +-- Copyright (C) 1991-2003, Florida State University -- +-- Copyright (C) 2008, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. It is -- +-- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- +-- State University (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This is a RTEMS version of this package which uses a special +-- variable for Ada self which is context switched implicitly by RTEMS. +-- +-- This is the same as the POSIX version except that an RTEMS variable +-- is used instead of a POSIX key. + +separate (System.Task_Primitives.Operations) +package body Specific is + + -- The following gives the Ada run-time direct access to a variable + -- context switched by RTEMS at the lowest level. + + RTEMS_Ada_Self : System.Address; + pragma Import (C, RTEMS_Ada_Self, "rtems_ada_self"); + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_Id) is + pragma Warnings (Off, Environment_Task); + + begin + ATCB_Key := No_Key; + RTEMS_Ada_Self := To_Address (Environment_Task); + end Initialize; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean is + begin + return RTEMS_Ada_Self /= System.Null_Address; + end Is_Valid_Task; + + --------- + -- Set -- + --------- + + procedure Set (Self_Id : Task_Id) is + begin + RTEMS_Ada_Self := To_Address (Self_Id); + end Set; + + ---------- + -- Self -- + ---------- + + -- To make Ada tasks and C threads interoperate better, we have added some + -- functionality to Self. Suppose a C main program (with threads) calls an + -- Ada procedure and the Ada procedure calls the tasking runtime system. + -- Eventually, a call will be made to self. Since the call is not coming + -- from an Ada task, there will be no corresponding ATCB. + + -- What we do in Self is to catch references that do not come from + -- recognized Ada tasks, and create an ATCB for the calling thread. + + -- The new ATCB will be "detached" from the normal Ada task master + -- hierarchy, much like the existing implicitly created signal-server + -- tasks. + + function Self return Task_Id is + Result : System.Address; + + begin + Result := RTEMS_Ada_Self; + + -- If the key value is Null, then it is a non-Ada task. + + if Result /= System.Null_Address then + return To_Task_Id (Result); + else + return Register_Foreign_Thread; + end if; + end Self; + +end Specific; diff --git a/gcc/ada/s-tpopsp-solaris.adb b/gcc/ada/s-tpopsp-solaris.adb new file mode 100644 index 000000000..1d46e714c --- /dev/null +++ b/gcc/ada/s-tpopsp-solaris.adb @@ -0,0 +1,106 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a version for Solaris native threads + +separate (System.Task_Primitives.Operations) +package body Specific is + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_Id) is + pragma Unreferenced (Environment_Task); + Result : Interfaces.C.int; + begin + Result := thr_keycreate (ATCB_Key'Access, System.Null_Address); + pragma Assert (Result = 0); + end Initialize; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean is + Unknown_Task : aliased System.Address; + Result : Interfaces.C.int; + begin + Result := thr_getspecific (ATCB_Key, Unknown_Task'Unchecked_Access); + pragma Assert (Result = 0); + return Unknown_Task /= System.Null_Address; + end Is_Valid_Task; + + --------- + -- Set -- + --------- + + procedure Set (Self_Id : Task_Id) is + Result : Interfaces.C.int; + begin + Result := thr_setspecific (ATCB_Key, To_Address (Self_Id)); + pragma Assert (Result = 0); + end Set; + + ---------- + -- Self -- + ---------- + + -- To make Ada tasks and C threads interoperate better, we have + -- added some functionality to Self. Suppose a C main program + -- (with threads) calls an Ada procedure and the Ada procedure + -- calls the tasking run-time system. Eventually, a call will be + -- made to self. Since the call is not coming from an Ada task, + -- there will be no corresponding ATCB. + + -- What we do in Self is to catch references that do not come + -- from recognized Ada tasks, and create an ATCB for the calling + -- thread. + + -- The new ATCB will be "detached" from the normal Ada task + -- master hierarchy, much like the existing implicitly created + -- signal-server tasks. + + function Self return Task_Id is + Result : Interfaces.C.int; + Self_Id : aliased System.Address; + begin + Result := thr_getspecific (ATCB_Key, Self_Id'Unchecked_Access); + pragma Assert (Result = 0); + + if Self_Id = System.Null_Address then + return Register_Foreign_Thread; + else + return To_Task_Id (Self_Id); + end if; + end Self; + +end Specific; diff --git a/gcc/ada/s-tpopsp-vxworks.adb b/gcc/ada/s-tpopsp-vxworks.adb new file mode 100644 index 000000000..64bf10c4d --- /dev/null +++ b/gcc/ada/s-tpopsp-vxworks.adb @@ -0,0 +1,101 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a VxWorks version of this package where foreign threads are +-- recognized. + +separate (System.Task_Primitives.Operations) +package body Specific is + + ATCB_Key : aliased System.Address := System.Null_Address; + -- Key used to find the Ada Task_Id associated with a thread + + ATCB_Key_Addr : System.Address := ATCB_Key'Address; + pragma Export (Ada, ATCB_Key_Addr, "__gnat_ATCB_key_addr"); + -- Exported to support the temporary AE653 task registration + -- implementation. This mechanism is used to minimize impact on other + -- targets. + + ------------ + -- Delete -- + ------------ + + procedure Delete is + Result : STATUS; + begin + Result := taskVarDelete (taskIdSelf, ATCB_Key'Access); + pragma Assert (Result /= ERROR); + end Delete; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + null; + end Initialize; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean is + begin + return taskVarGet (taskIdSelf, ATCB_Key'Access) /= ERROR; + end Is_Valid_Task; + + --------- + -- Set -- + --------- + + procedure Set (Self_Id : Task_Id) is + Result : STATUS; + + begin + if taskVarGet (0, ATCB_Key'Access) = ERROR then + Result := taskVarAdd (0, ATCB_Key'Access); + pragma Assert (Result = OK); + end if; + + ATCB_Key := To_Address (Self_Id); + end Set; + + ---------- + -- Self -- + ---------- + + function Self return Task_Id is + begin + return To_Task_Id (ATCB_Key); + end Self; + +end Specific; diff --git a/gcc/ada/s-tporft.adb b/gcc/ada/s-tporft.adb new file mode 100644 index 000000000..0158ca284 --- /dev/null +++ b/gcc/ada/s-tporft.adb @@ -0,0 +1,109 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.REGISTER_FOREIGN_THREAD -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2010, 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.Task_Info; +-- Use for Unspecified_Task_Info + +with System.Soft_Links; +-- used to initialize TSD for a C thread, in function Self + +with System.Multiprocessors; + +separate (System.Task_Primitives.Operations) +function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id is + Local_ATCB : aliased Ada_Task_Control_Block (0); + Self_Id : Task_Id; + Succeeded : Boolean; + +begin + -- This section is tricky. We must not call anything that might require + -- an ATCB, until the new ATCB is in place. In order to get an ATCB + -- immediately, we fake one, so that it is then possible to e.g allocate + -- memory (which might require accessing self). + + -- Record this as the Task_Id for the thread + + Local_ATCB.Common.LL.Thread := Thread; + Local_ATCB.Common.Current_Priority := System.Priority'First; + Specific.Set (Local_ATCB'Unchecked_Access); + + -- It is now safe to use an allocator + + Self_Id := new Ada_Task_Control_Block (0); + + -- Finish initialization + + Lock_RTS; + System.Tasking.Initialize_ATCB + (Self_Id, null, Null_Address, Null_Task, + Foreign_Task_Elaborated'Access, + System.Priority'First, System.Multiprocessors.Not_A_Specific_CPU, + Task_Info.Unspecified_Task_Info, 0, Self_Id, Succeeded); + Unlock_RTS; + pragma Assert (Succeeded); + + Self_Id.Master_of_Task := 0; + Self_Id.Master_Within := Self_Id.Master_of_Task + 1; + + for L in Self_Id.Entry_Calls'Range loop + Self_Id.Entry_Calls (L).Self := Self_Id; + Self_Id.Entry_Calls (L).Level := L; + end loop; + + Self_Id.Common.State := Runnable; + Self_Id.Awake_Count := 1; + + Self_Id.Common.Task_Image (1 .. 14) := "foreign thread"; + Self_Id.Common.Task_Image_Len := 14; + + -- Since this is not an ordinary Ada task, we will start out undeferred + + Self_Id.Deferral_Level := 0; + + -- We do not provide an alternate stack for foreign threads + + Self_Id.Common.Task_Alternate_Stack := Null_Address; + + System.Soft_Links.Create_TSD (Self_Id.Common.Compiler_Data); + + -- ??? + -- The following call is commented out to avoid dependence on the + -- System.Tasking.Initialization package. It seems that if we want + -- Ada.Task_Attributes to work correctly for C threads we will need to + -- raise the visibility of this soft link to System.Soft_Links. We are + -- putting that off until this new functionality is otherwise stable. + + -- System.Tasking.Initialization.Initialize_Attributes_Link.all (T); + + Enter_Task (Self_Id); + + return Self_Id; +end Register_Foreign_Thread; diff --git a/gcc/ada/s-tposen.adb b/gcc/ada/s-tposen.adb new file mode 100644 index 000000000..10cfca210 --- /dev/null +++ b/gcc/ada/s-tposen.adb @@ -0,0 +1,638 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram ordering check, since restricted GNARLI subprograms are +-- gathered together at end. + +-- This package provides an optimized version of Protected_Objects.Operations +-- and Protected_Objects.Entries making the following assumptions: + +-- PO has only one entry +-- There is only one caller at a time (No_Entry_Queue) +-- There is no dynamic priority support (No_Dynamic_Priorities) +-- No Abort Statements +-- (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0) +-- PO are at library level +-- No Requeue +-- None of the tasks will terminate (no need for finalization) + +-- This interface is intended to be used in the ravenscar and restricted +-- profiles, the compiler is responsible for ensuring that the conditions +-- mentioned above are respected, except for the No_Entry_Queue restriction +-- that is checked dynamically in this package, since the check cannot be +-- performed at compile time, and is relatively cheap (see PO_Do_Or_Queue, +-- Service_Entry). + +pragma Polling (Off); +-- Turn off polling, we do not want polling to take place during tasking +-- operations. It can cause infinite loops and other problems. + +pragma Suppress (All_Checks); +-- Why is this required ??? + +with Ada.Exceptions; + +with System.Task_Primitives.Operations; +with System.Parameters; + +package body System.Tasking.Protected_Objects.Single_Entry is + + package STPO renames System.Task_Primitives.Operations; + + use Parameters; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Send_Program_Error + (Self_Id : Task_Id; + Entry_Call : Entry_Call_Link); + pragma Inline (Send_Program_Error); + -- Raise Program_Error in the caller of the specified entry call + + -------------------------- + -- Entry Calls Handling -- + -------------------------- + + procedure Wakeup_Entry_Caller + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link; + New_State : Entry_Call_State); + pragma Inline (Wakeup_Entry_Caller); + -- This is called at the end of service of an entry call, + -- to abort the caller if he is in an abortable part, and + -- to wake up the caller if he is on Entry_Caller_Sleep. + -- Call it holding the lock of Entry_Call.Self. + -- + -- Timed_Call or Simple_Call: + -- The caller is waiting on Entry_Caller_Sleep, in + -- Wait_For_Completion, or Wait_For_Completion_With_Timeout. + + procedure Wait_For_Completion (Entry_Call : Entry_Call_Link); + pragma Inline (Wait_For_Completion); + -- This procedure suspends the calling task until the specified entry call + -- has either been completed or cancelled. On exit, the call will not be + -- queued. This waits for calls on protected entries. + -- Call this only when holding Self_ID locked. + + procedure Wait_For_Completion_With_Timeout + (Entry_Call : Entry_Call_Link; + Wakeup_Time : Duration; + Mode : Delay_Modes); + -- Same as Wait_For_Completion but it waits for a timeout with the value + -- specified in Wakeup_Time as well. + + procedure Check_Exception + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link); + pragma Inline (Check_Exception); + -- Raise any pending exception from the Entry_Call. + -- This should be called at the end of every compiler interface procedure + -- that implements an entry call. + -- The caller should not be holding any locks, or there will be deadlock. + + procedure PO_Do_Or_Queue + (Self_Id : Task_Id; + Object : Protection_Entry_Access; + Entry_Call : Entry_Call_Link); + -- This procedure executes or queues an entry call, depending + -- on the status of the corresponding barrier. It assumes that the + -- specified object is locked. + + --------------------- + -- Check_Exception -- + --------------------- + + procedure Check_Exception + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link) + is + pragma Warnings (Off, Self_ID); + + procedure Internal_Raise (X : Ada.Exceptions.Exception_Id); + pragma Import (C, Internal_Raise, "__gnat_raise_with_msg"); + + use type Ada.Exceptions.Exception_Id; + + E : constant Ada.Exceptions.Exception_Id := + Entry_Call.Exception_To_Raise; + + begin + if E /= Ada.Exceptions.Null_Id then + Internal_Raise (E); + end if; + end Check_Exception; + + ------------------------ + -- Send_Program_Error -- + ------------------------ + + procedure Send_Program_Error + (Self_Id : Task_Id; + Entry_Call : Entry_Call_Link) + is + Caller : constant Task_Id := Entry_Call.Self; + begin + Entry_Call.Exception_To_Raise := Program_Error'Identity; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Caller); + Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + end Send_Program_Error; + + ------------------------- + -- Wait_For_Completion -- + ------------------------- + + procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is + Self_Id : constant Task_Id := Entry_Call.Self; + begin + Self_Id.Common.State := Entry_Caller_Sleep; + STPO.Sleep (Self_Id, Entry_Caller_Sleep); + Self_Id.Common.State := Runnable; + end Wait_For_Completion; + + -------------------------------------- + -- Wait_For_Completion_With_Timeout -- + -------------------------------------- + + procedure Wait_For_Completion_With_Timeout + (Entry_Call : Entry_Call_Link; + Wakeup_Time : Duration; + Mode : Delay_Modes) + is + Self_Id : constant Task_Id := Entry_Call.Self; + Timedout : Boolean; + + Yielded : Boolean; + pragma Unreferenced (Yielded); + + use type Ada.Exceptions.Exception_Id; + + begin + -- This procedure waits for the entry call to be served, with a timeout. + -- It tries to cancel the call if the timeout expires before the call is + -- served. + + -- If we wake up from the timed sleep operation here, it may be for the + -- following possible reasons: + + -- 1) The entry call is done being served. + -- 2) The timeout has expired (Timedout = True) + + -- Once the timeout has expired we may need to continue to wait if the + -- call is already being serviced. In that case, we want to go back to + -- sleep, but without any timeout. The variable Timedout is used to + -- control this. If the Timedout flag is set, we do not need to Sleep + -- with a timeout. We just sleep until we get a wakeup for some status + -- change. + + pragma Assert (Entry_Call.Mode = Timed_Call); + Self_Id.Common.State := Entry_Caller_Sleep; + + STPO.Timed_Sleep + (Self_Id, Wakeup_Time, Mode, Entry_Caller_Sleep, Timedout, Yielded); + + Entry_Call.State := (if Timedout then Cancelled else Done); + Self_Id.Common.State := Runnable; + end Wait_For_Completion_With_Timeout; + + ------------------------- + -- Wakeup_Entry_Caller -- + ------------------------- + + -- This is called at the end of service of an entry call, to abort the + -- caller if he is in an abortable part, and to wake up the caller if it + -- is on Entry_Caller_Sleep. It assumes that the call is already off-queue. + + -- (This enforces the rule that a task must be off-queue if its state is + -- Done or Cancelled.) Call it holding the lock of Entry_Call.Self. + + -- Timed_Call or Simple_Call: + -- The caller is waiting on Entry_Caller_Sleep, in + -- Wait_For_Completion, or Wait_For_Completion_With_Timeout. + + -- Conditional_Call: + -- The caller might be in Wait_For_Completion, + -- waiting for a rendezvous (possibly requeued without abort) + -- to complete. + + procedure Wakeup_Entry_Caller + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link; + New_State : Entry_Call_State) + is + pragma Warnings (Off, Self_ID); + + Caller : constant Task_Id := Entry_Call.Self; + + begin + pragma Assert (New_State = Done or else New_State = Cancelled); + pragma Assert + (Caller.Common.State /= Terminated and then + Caller.Common.State /= Unactivated); + + Entry_Call.State := New_State; + STPO.Wakeup (Caller, Entry_Caller_Sleep); + end Wakeup_Entry_Caller; + + ----------------------- + -- Restricted GNARLI -- + ----------------------- + + -------------------------------- + -- Complete_Single_Entry_Body -- + -------------------------------- + + procedure Complete_Single_Entry_Body (Object : Protection_Entry_Access) is + pragma Warnings (Off, Object); + + begin + -- Nothing needs to do (Object.Call_In_Progress.Exception_To_Raise + -- has already been set to Null_Id). + + null; + end Complete_Single_Entry_Body; + + -------------------------------------------- + -- Exceptional_Complete_Single_Entry_Body -- + -------------------------------------------- + + procedure Exceptional_Complete_Single_Entry_Body + (Object : Protection_Entry_Access; + Ex : Ada.Exceptions.Exception_Id) is + begin + Object.Call_In_Progress.Exception_To_Raise := Ex; + end Exceptional_Complete_Single_Entry_Body; + + --------------------------------- + -- Initialize_Protection_Entry -- + --------------------------------- + + procedure Initialize_Protection_Entry + (Object : Protection_Entry_Access; + Ceiling_Priority : Integer; + Compiler_Info : System.Address; + Entry_Body : Entry_Body_Access) + is + begin + Initialize_Protection (Object.Common'Access, Ceiling_Priority); + + Object.Compiler_Info := Compiler_Info; + Object.Call_In_Progress := null; + Object.Entry_Body := Entry_Body; + Object.Entry_Queue := null; + end Initialize_Protection_Entry; + + ---------------- + -- Lock_Entry -- + ---------------- + + -- Compiler interface only. + -- Do not call this procedure from within the run-time system. + + procedure Lock_Entry (Object : Protection_Entry_Access) is + begin + Lock (Object.Common'Access); + end Lock_Entry; + + -------------------------- + -- Lock_Read_Only_Entry -- + -------------------------- + + -- Compiler interface only + + -- Do not call this procedure from within the runtime system + + procedure Lock_Read_Only_Entry (Object : Protection_Entry_Access) is + begin + Lock_Read_Only (Object.Common'Access); + end Lock_Read_Only_Entry; + + -------------------- + -- PO_Do_Or_Queue -- + -------------------- + + procedure PO_Do_Or_Queue + (Self_Id : Task_Id; + Object : Protection_Entry_Access; + Entry_Call : Entry_Call_Link) + is + Barrier_Value : Boolean; + + begin + -- When the Action procedure for an entry body returns, it must be + -- completed (having called [Exceptional_]Complete_Entry_Body). + + Barrier_Value := Object.Entry_Body.Barrier (Object.Compiler_Info, 1); + + if Barrier_Value then + if Object.Call_In_Progress /= null then + + -- This violates the No_Entry_Queue restriction, send + -- Program_Error to the caller. + + Send_Program_Error (Self_Id, Entry_Call); + return; + end if; + + Object.Call_In_Progress := Entry_Call; + Object.Entry_Body.Action + (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1); + Object.Call_In_Progress := null; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Entry_Call.Self); + Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Entry_Call.Self); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + elsif Entry_Call.Mode /= Conditional_Call then + if Object.Entry_Queue /= null then + + -- This violates the No_Entry_Queue restriction, send + -- Program_Error to the caller. + + Send_Program_Error (Self_Id, Entry_Call); + return; + else + Object.Entry_Queue := Entry_Call; + end if; + + else + -- Conditional_Call + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Entry_Call.Self); + Wakeup_Entry_Caller (Self_Id, Entry_Call, Cancelled); + STPO.Unlock (Entry_Call.Self); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + end if; + + exception + when others => + Send_Program_Error + (Self_Id, Entry_Call); + end PO_Do_Or_Queue; + + ---------------------------- + -- Protected_Single_Count -- + ---------------------------- + + function Protected_Count_Entry (Object : Protection_Entry) return Natural is + begin + if Object.Entry_Queue /= null then + return 1; + else + return 0; + end if; + end Protected_Count_Entry; + + --------------------------------- + -- Protected_Single_Entry_Call -- + --------------------------------- + + procedure Protected_Single_Entry_Call + (Object : Protection_Entry_Access; + Uninterpreted_Data : System.Address; + Mode : Call_Modes) + is + Self_Id : constant Task_Id := STPO.Self; + Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1); + begin + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with "potentially blocking operation"; + end if; + + Lock_Entry (Object); + + Entry_Call.Mode := Mode; + Entry_Call.State := Now_Abortable; + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + + PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access); + Unlock_Entry (Object); + + -- The call is either `Done' or not. It cannot be cancelled since there + -- is no ATC construct. + + pragma Assert (Entry_Call.State /= Cancelled); + + if Entry_Call.State /= Done then + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Self_Id); + Wait_For_Completion (Entry_Call'Access); + STPO.Unlock (Self_Id); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + end if; + + Check_Exception (Self_Id, Entry_Call'Access); + end Protected_Single_Entry_Call; + + ----------------------------------- + -- Protected_Single_Entry_Caller -- + ----------------------------------- + + function Protected_Single_Entry_Caller + (Object : Protection_Entry) return Task_Id is + begin + return Object.Call_In_Progress.Self; + end Protected_Single_Entry_Caller; + + ------------------- + -- Service_Entry -- + ------------------- + + procedure Service_Entry (Object : Protection_Entry_Access) is + Self_Id : constant Task_Id := STPO.Self; + Entry_Call : constant Entry_Call_Link := Object.Entry_Queue; + Caller : Task_Id; + + begin + if Entry_Call /= null + and then Object.Entry_Body.Barrier (Object.Compiler_Info, 1) + then + Object.Entry_Queue := null; + + if Object.Call_In_Progress /= null then + + -- Violation of No_Entry_Queue restriction, raise exception + + Send_Program_Error (Self_Id, Entry_Call); + Unlock_Entry (Object); + return; + end if; + + Object.Call_In_Progress := Entry_Call; + Object.Entry_Body.Action + (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1); + Object.Call_In_Progress := null; + Caller := Entry_Call.Self; + Unlock_Entry (Object); + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Caller); + Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + else + -- Just unlock the entry + + Unlock_Entry (Object); + end if; + + exception + when others => + Send_Program_Error (Self_Id, Entry_Call); + Unlock_Entry (Object); + end Service_Entry; + + --------------------------------------- + -- Timed_Protected_Single_Entry_Call -- + --------------------------------------- + + -- Compiler interface only (do not call from within the RTS) + + procedure Timed_Protected_Single_Entry_Call + (Object : Protection_Entry_Access; + Uninterpreted_Data : System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Entry_Call_Successful : out Boolean) + is + Self_Id : constant Task_Id := STPO.Self; + Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1); + + begin + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with "potentially blocking operation"; + end if; + + Lock (Object.Common'Access); + + Entry_Call.Mode := Timed_Call; + Entry_Call.State := Now_Abortable; + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + + PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access); + Unlock_Entry (Object); + + -- Try to avoid waiting for completed calls. + -- The call is either `Done' or not. It cannot be cancelled since there + -- is no ATC construct and the timed wait has not started yet. + + pragma Assert (Entry_Call.State /= Cancelled); + + if Entry_Call.State = Done then + Check_Exception (Self_Id, Entry_Call'Access); + Entry_Call_Successful := True; + return; + end if; + + if Single_Lock then + STPO.Lock_RTS; + else + STPO.Write_Lock (Self_Id); + end if; + + Wait_For_Completion_With_Timeout (Entry_Call'Access, Timeout, Mode); + + if Single_Lock then + STPO.Unlock_RTS; + else + STPO.Unlock (Self_Id); + end if; + + pragma Assert (Entry_Call.State >= Done); + + Check_Exception (Self_Id, Entry_Call'Access); + Entry_Call_Successful := Entry_Call.State = Done; + end Timed_Protected_Single_Entry_Call; + + ------------------ + -- Unlock_Entry -- + ------------------ + + procedure Unlock_Entry (Object : Protection_Entry_Access) is + begin + Unlock (Object.Common'Access); + end Unlock_Entry; + +end System.Tasking.Protected_Objects.Single_Entry; diff --git a/gcc/ada/s-tposen.ads b/gcc/ada/s-tposen.ads new file mode 100644 index 000000000..8c07cfd3a --- /dev/null +++ b/gcc/ada/s-tposen.ads @@ -0,0 +1,295 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an optimized version of Protected_Objects.Operations +-- and Protected_Objects.Entries making the following assumptions: +-- +-- PO have only one entry +-- There is only one caller at a time (No_Entry_Queue) +-- There is no dynamic priority support (No_Dynamic_Priorities) +-- No Abort Statements +-- (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0) +-- PO are at library level +-- None of the tasks will terminate (no need for finalization) +-- +-- This interface is intended to be used in the ravenscar profile, the +-- compiler is responsible for ensuring that the conditions mentioned above +-- are respected, except for the No_Entry_Queue restriction that is checked +-- dynamically in this package, since the check cannot be performed at compile +-- time, and is relatively cheap (see body). +-- +-- This package is part of the high level tasking interface used by the +-- compiler to expand Ada 95 tasking constructs into simpler run time calls +-- (aka GNARLI, GNU Ada Run-time Library Interface) +-- +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes +-- in exp_ch9.adb and possibly exp_ch7.adb + +package System.Tasking.Protected_Objects.Single_Entry is + pragma Elaborate_Body; + + --------------------------------- + -- Compiler Interface (GNARLI) -- + --------------------------------- + + -- The compiler will expand in the GNAT tree the following construct: + + -- protected PO is + -- entry E; + -- procedure P; + -- private + -- Open : Boolean := False; + -- end PO; + + -- protected body PO is + -- entry E when Open is + -- ...variable declarations... + -- begin + -- ...B... + -- end E; + + -- procedure P is + -- ...variable declarations... + -- begin + -- ...C... + -- end P; + -- end PO; + + -- as follows: + + -- protected type poT is + -- entry e; + -- procedure p; + -- private + -- open : boolean := false; + -- end poT; + -- type poTV is limited record + -- open : boolean := false; + -- _object : aliased protection_entry; + -- end record; + -- procedure poPT__E1s (O : address; P : address; E : + -- protected_entry_index); + -- function poPT__B2s (O : address; E : protected_entry_index) return + -- boolean; + -- procedure poPT__pN (_object : in out poTV); + -- procedure poPT__pP (_object : in out poTV); + -- poTA : aliased entry_body := ( + -- barrier => poPT__B2s'unrestricted_access, + -- action => poPT__E1s'unrestricted_access); + -- freeze poTV [ + -- procedure poTVIP (_init : in out poTV) is + -- begin + -- _init.open := false; + -- object-init-proc (_init._object); + -- initialize_protection_entry (_init._object'unchecked_access, + -- unspecified_priority, _init'address, poTA' + -- unrestricted_access); + -- return; + -- end poTVIP; + -- ] + -- po : poT; + -- poTVIP (poTV!(po)); + + -- function poPT__B2s (O : address; E : protected_entry_index) return + -- boolean is + -- type poTVP is access poTV; + -- _object : poTVP := poTVP!(O); + -- poR : protection_entry renames _object._object; + -- openP : boolean renames _object.open; + -- begin + -- return open; + -- end poPT__B2s; + + -- procedure poPT__E1s (O : address; P : address; E : + -- protected_entry_index) is + -- type poTVP is access poTV; + -- _object : poTVP := poTVP!(O); + -- begin + -- B1b : declare + -- poR : protection_entry renames _object._object; + -- openP : boolean renames _object.open; + -- ...variable declarations... + -- begin + -- ...B... + -- end B1b; + -- complete_single_entry_body (_object._object'unchecked_access); + -- return; + -- exception + -- when all others => + -- exceptional_complete_single_entry_body (_object._object' + -- unchecked_access, get_gnat_exception); + -- return; + -- end poPT__E1s; + + -- procedure poPT__pN (_object : in out poTV) is + -- poR : protection_entry renames _object._object; + -- openP : boolean renames _object.open; + -- ...variable declarations... + -- begin + -- ...C... + -- return; + -- end poPT__pN; + + -- procedure poPT__pP (_object : in out poTV) is + -- procedure _clean is + -- begin + -- service_entry (_object._object'unchecked_access); + -- unlock_entry (_object._object'unchecked_access); + -- return; + -- end _clean; + -- begin + -- lock_entry (_object._object'unchecked_access); + -- B5b : begin + -- poPT__pN (_object); + -- at end + -- _clean; + -- end B5b; + -- return; + -- end poPT__pP; + + type Protection_Entry is limited private; + -- This type contains the GNARL state of a protected object. The + -- application-defined portion of the state (i.e. private objects) + -- is maintained by the compiler-generated code. + + type Protection_Entry_Access is access all Protection_Entry; + + procedure Initialize_Protection_Entry + (Object : Protection_Entry_Access; + Ceiling_Priority : Integer; + Compiler_Info : System.Address; + Entry_Body : Entry_Body_Access); + -- Initialize the Object parameter so that it can be used by the run time + -- to keep track of the runtime state of a protected object. + + procedure Lock_Entry (Object : Protection_Entry_Access); + -- Lock a protected object for write access. Upon return, the caller + -- owns the lock to this object, and no other call to Lock or + -- Lock_Read_Only with the same argument will return until the + -- corresponding call to Unlock has been made by the caller. + + procedure Lock_Read_Only_Entry + (Object : Protection_Entry_Access); + -- Lock a protected object for read access. Upon return, the caller + -- owns the lock for read access, and no other calls to Lock + -- with the same argument will return until the corresponding call + -- to Unlock has been made by the caller. Other calls to Lock_Read_Only + -- may (but need not) return before the call to Unlock, and the + -- corresponding callers will also own the lock for read access. + + procedure Unlock_Entry (Object : Protection_Entry_Access); + -- Relinquish ownership of the lock for the object represented by + -- the Object parameter. If this ownership was for write access, or + -- if it was for read access where there are no other read access + -- locks outstanding, one (or more, in the case of Lock_Read_Only) + -- of the tasks waiting on this lock (if any) will be given the + -- lock and allowed to return from the Lock or Lock_Read_Only call. + + procedure Service_Entry (Object : Protection_Entry_Access); + -- Service the entry queue of the specified object, executing the + -- corresponding body of any queued entry call that is waiting on True + -- barrier. This is used when the state of a protected object may have + -- changed, in particular after the execution of the statement sequence of + -- a protected procedure. + -- + -- This must be called with abort deferred and with the corresponding + -- object locked. Object is unlocked on return. + + procedure Protected_Single_Entry_Call + (Object : Protection_Entry_Access; + Uninterpreted_Data : System.Address; + Mode : Call_Modes); + -- Make a protected entry call to the specified object. + -- Pend a protected entry call on the protected object represented + -- by Object. A pended call is not queued; it may be executed immediately + -- or queued, depending on the state of the entry barrier. + -- + -- Uninterpreted_Data + -- This will be returned by Next_Entry_Call when this call is serviced. + -- It can be used by the compiler to pass information between the + -- caller and the server, in particular entry parameters. + -- + -- Mode + -- The kind of call to be pended + + procedure Timed_Protected_Single_Entry_Call + (Object : Protection_Entry_Access; + Uninterpreted_Data : System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Entry_Call_Successful : out Boolean); + -- Same as the Protected_Entry_Call but with time-out specified. + -- This routine is used to implement timed entry calls. + + procedure Complete_Single_Entry_Body + (Object : Protection_Entry_Access); + pragma Inline (Complete_Single_Entry_Body); + -- Called from within an entry body procedure, indicates that the + -- corresponding entry call has been serviced. + + procedure Exceptional_Complete_Single_Entry_Body + (Object : Protection_Entry_Access; + Ex : Ada.Exceptions.Exception_Id); + -- Perform all of the functions of Complete_Entry_Body. In addition, + -- report in Ex the exception whose propagation terminated the entry + -- body to the runtime system. + + function Protected_Count_Entry (Object : Protection_Entry) + return Natural; + -- Return the number of entry calls on Object (0 or 1) + + function Protected_Single_Entry_Caller (Object : Protection_Entry) + return Task_Id; + -- Return value of E'Caller, where E is the protected entry currently + -- being handled. This will only work if called from within an + -- entry body, as required by the LRM (C.7.1(14)). + +private + type Protection_Entry is record + Common : aliased Protection; + -- State of the protected object. This part is common to any protected + -- object, including those without entries. + + Compiler_Info : System.Address; + -- Pointer to compiler-generated record representing protected object + + Call_In_Progress : Entry_Call_Link; + -- Pointer to the entry call being executed (if any) + + Entry_Body : Entry_Body_Access; + -- Pointer to executable code for the entry body of the protected type + + Entry_Queue : Entry_Call_Link; + -- Place to store the waiting entry call (if any) + end record; + +end System.Tasking.Protected_Objects.Single_Entry; diff --git a/gcc/ada/s-traceb-hpux.adb b/gcc/ada/s-traceb-hpux.adb new file mode 100644 index 000000000..d8cf78726 --- /dev/null +++ b/gcc/ada/s-traceb-hpux.adb @@ -0,0 +1,604 @@ +------------------------------------------------------------------------------ +-- -- +-- 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) 1999-2006, AdaCore -- +-- Copyright (C) 2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +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. + + ------------------ + -- 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; + +end System.Traceback; diff --git a/gcc/ada/s-traceb-mastop.adb b/gcc/ada/s-traceb-mastop.adb new file mode 100644 index 000000000..9591b2d2a --- /dev/null +++ b/gcc/ada/s-traceb-mastop.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2005, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version uses System.Machine_State_Operations routines + +with System.Machine_State_Operations; + +package body System.Traceback is + + use System.Machine_State_Operations; + + ---------------- + -- 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; + + ------------------ + -- 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 new file mode 100644 index 000000000..d4de95d7e --- /dev/null +++ b/gcc/ada/s-traceb.adb @@ -0,0 +1,93 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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; + +package body System.Traceback is + + ------------------ + -- 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; + +end System.Traceback; diff --git a/gcc/ada/s-traceb.ads b/gcc/ada/s-traceb.ads new file mode 100644 index 000000000..0119b700a --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we get +-- elaboration circularities with System.Exception_Tables. + +package System.Traceback is + + ---------------- + -- 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); + -- Store up to Max_Len code locations in Traceback, corresponding to + -- the current call chain. + -- + -- Traceback is the address of 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 returned number of addresses stored 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-traces-default.adb b/gcc/ada/s-traces-default.adb new file mode 100644 index 000000000..03145a95b --- /dev/null +++ b/gcc/ada/s-traces-default.adb @@ -0,0 +1,71 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Soft_Links; +with System.Parameters; +with System.Traces.Format; + +package body System.Traces is + + package SSL renames System.Soft_Links; + use System.Traces.Format; + + ---------------------- + -- Send_Trace_Info -- + ---------------------- + + procedure Send_Trace_Info (Id : Trace_T) is + Task_S : constant String := SSL.Task_Name.all; + Trace_S : String (1 .. 3 + Task_S'Length); + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. Trace_S'Last) := Task_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info (Id : Trace_T; Timeout : Duration) is + Task_S : constant String := SSL.Task_Name.all; + Timeout_S : constant String := Duration'Image (Timeout); + Trace_S : String (1 .. 6 + Task_S'Length + Timeout_S'Length); + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + Task_S'Length) := Task_S; + Trace_S (4 + Task_S'Length .. 6 + Task_S'Length) := "/T:"; + Trace_S (7 + Task_S'Length .. Trace_S'Last) := Timeout_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; +end System.Traces; diff --git a/gcc/ada/s-traces.adb b/gcc/ada/s-traces.adb new file mode 100644 index 000000000..e7116f5d1 --- /dev/null +++ b/gcc/ada/s-traces.adb @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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.Traces is + + pragma Warnings (Off); -- kill warnings on unreferenced formals + + --------------------- + -- Send_Trace_Info -- + --------------------- + + procedure Send_Trace_Info (Id : Trace_T) is + begin + null; + end Send_Trace_Info; + + --------------------- + -- Send_Trace_Info -- + --------------------- + + procedure Send_Trace_Info (Id : Trace_T; Timeout : Duration) is + begin + null; + end Send_Trace_Info; + +end System.Traces; diff --git a/gcc/ada/s-traces.ads b/gcc/ada/s-traces.ads new file mode 100644 index 000000000..f1b3f8a6f --- /dev/null +++ b/gcc/ada/s-traces.ads @@ -0,0 +1,114 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package implements functions for traces when tasking is not involved + +-- Warning : NO dependencies to tasking should be created here + +-- This package, and all its children are used to implement debug +-- informations + +-- A new primitive, Send_Trace_Info (Id : Trace_T; 'data') is introduced. +-- Trace_T is an event identifier, 'data' are the informations to pass +-- with the event. This procedure is used from within the Runtime to send +-- debug informations. + +-- This primitive is overloaded in System.Traces.Tasking and this package + +-- Send_Trace_Info calls Send_Trace, in System.Traces.Send, which is target +-- dependent, to send the debug informations to a debugger, stream .. + +-- To add a new event, just add them to the Trace_T type, and write the +-- corresponding Send_Trace_Info procedure. It may be required for some +-- target to modify Send_Trace (e.g. VxWorks). + +-- To add a new target, just adapt System.Traces.Send to your own purposes + +package System.Traces is + pragma Preelaborate; + + type Trace_T is + ( + -- Events handled + + -- Messages + + M_Accept_Complete, + M_Select_Else, + M_RDV_Complete, + M_Call_Complete, + M_Delay, + + -- Errors + + E_Missed, + E_Timeout, + E_Kill, + + -- Waiting events + + W_Call, + W_Accept, + W_Select, + W_Completion, + W_Delay, + WU_Delay, + + WT_Call, + WT_Select, + WT_Completion, + + -- Protected objects events + + PO_Call, + POT_Call, + PO_Run, + PO_Lock, + PO_Unlock, + PO_Done, + + -- Task handling events + + T_Create, + T_Activate, + T_Abort, + T_Terminate); + + -- Send_Trace_Info procedures + + -- They are overloaded, depending on the parameters passed with + -- the event, e.g. Time information, Task name, Accept name ... + + procedure Send_Trace_Info (Id : Trace_T); + + procedure Send_Trace_Info (Id : Trace_T; Timeout : Duration); + +end System.Traces; diff --git a/gcc/ada/s-traent-vms.adb b/gcc/ada/s-traent-vms.adb new file mode 100644 index 000000000..9e130419b --- /dev/null +++ b/gcc/ada/s-traent-vms.adb @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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.Traceback_Entries is + + ------------ + -- PC_For -- + ------------ + + function PC_For (TB_Entry : Traceback_Entry) return System.Address is + begin + return TB_Entry.PC; + end PC_For; + + ------------ + -- PV_For -- + ------------ + + function PV_For (TB_Entry : Traceback_Entry) return System.Address is + begin + return TB_Entry.PV; + end PV_For; + + ------------------ + -- TB_Entry_For -- + ------------------ + + function TB_Entry_For (PC : System.Address) return Traceback_Entry is + begin + return (PC => PC, PV => System.Null_Address); + end TB_Entry_For; + +end System.Traceback_Entries; diff --git a/gcc/ada/s-traent-vms.ads b/gcc/ada/s-traent-vms.ads new file mode 100644 index 000000000..45db3c4d0 --- /dev/null +++ b/gcc/ada/s-traent-vms.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Alpha/OpenVMS version of this package + +package System.Traceback_Entries is + pragma Preelaborate; + + -- Symbolization is performed by a VMS service which requires more + -- than an instruction pointer. + + type Traceback_Entry is record + PC : System.Address; -- Program Counter + PV : System.Address; -- Procedure Value + end record; + + pragma Suppress_Initialization (Traceback_Entry); + + Null_TB_Entry : constant Traceback_Entry := + (PC => System.Null_Address, + PV => System.Null_Address); + + function PC_For (TB_Entry : Traceback_Entry) return System.Address; + function PV_For (TB_Entry : Traceback_Entry) return System.Address; + + function TB_Entry_For (PC : System.Address) return Traceback_Entry; + +end System.Traceback_Entries; diff --git a/gcc/ada/s-traent.adb b/gcc/ada/s-traent.adb new file mode 100644 index 000000000..343d30c89 --- /dev/null +++ b/gcc/ada/s-traent.adb @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..cf24e0db5 --- /dev/null +++ b/gcc/ada/s-traent.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 Compiler_Unit; + +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 + + 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-trafor-default.adb b/gcc/ada/s-trafor-default.adb new file mode 100644 index 000000000..93f0e24c5 --- /dev/null +++ b/gcc/ada/s-trafor-default.adb @@ -0,0 +1,113 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E S . F O R M A T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Parameters; + +package body System.Traces.Format is + + procedure Send_Trace (Id : Trace_T; Info : String) is separate; + + ------------------ + -- Format_Trace -- + ------------------ + + function Format_Trace (Source : String) return String_Trace is + Length : constant Integer := Source'Length; + Result : String_Trace := (others => ' '); + + begin + -- If run-time tracing active, then fill the string + + if Parameters.Runtime_Traces then + if Max_Size - Length > 0 then + Result (1 .. Length) := Source (1 .. Length); + Result (Length + 1 .. Max_Size) := (others => ' '); + Result (Length + 1) := ASCII.NUL; + else + Result (1 .. Max_Size - 1) := + Source (Source'First .. Source'First - 1 + Max_Size - 1); + Result (Max_Size) := ASCII.NUL; + end if; + end if; + + return Result; + end Format_Trace; + + ------------ + -- Append -- + ------------ + + function Append + (Source : String_Trace; + Annex : String) return String_Trace + is + Result : String_Trace := (others => ' '); + Annex_Length : constant Integer := Annex'Length; + Source_Length : Integer; + + begin + if Parameters.Runtime_Traces then + + -- First we determine the size used, without the spaces at the end, + -- if a String_Trace is present. Look at System.Traces.Tasking for + -- examples. + + Source_Length := 1; + while Source (Source_Length) /= ASCII.NUL loop + Source_Length := Source_Length + 1; + end loop; + + -- Then we fill the string + + if Source_Length - 1 + Annex_Length <= Max_Size then + Result (1 .. Source_Length - 1) := + Source (1 .. Source_Length - 1); + + Result (Source_Length .. Source_Length - 1 + Annex_Length) := + Annex (1 .. Annex_Length); + + Result (Source_Length + Annex_Length) := ASCII.NUL; + + Result (Source_Length + Annex_Length + 1 .. Max_Size) := + (others => ' '); + + else + Result (1 .. Source_Length - 1) := Source (1 .. Source_Length - 1); + Result (Source_Length .. Max_Size - 1) := + Annex (1 .. Max_Size - Source_Length); + Result (Max_Size) := ASCII.NUL; + end if; + end if; + + return Result; + end Append; + +end System.Traces.Format; diff --git a/gcc/ada/s-trafor-default.ads b/gcc/ada/s-trafor-default.ads new file mode 100644 index 000000000..82cdf97ba --- /dev/null +++ b/gcc/ada/s-trafor-default.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E S . F O R M A T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package implements functions to format run-time traces + +package System.Traces.Format is + pragma Preelaborate; + + Max_Size : constant Integer := 128; + -- Maximum size if event messages + + subtype String_Trace is String (1 .. Max_Size); + -- Specific type in which trace information is stored. An ASCII.NUL + -- character ends the string so that it is compatible with C strings + -- which is useful on some targets (e.g. VxWorks) + + -- These private functions handles String_Trace formatting + + function Format_Trace (Source : String) return String_Trace; + -- Put a String in a String_Trace, truncates the string if necessary. + -- Similar to Head( .. ) found in Ada.Strings.Bounded + + function Append + (Source : String_Trace; + Annex : String) + return String_Trace; + pragma Inline (Append); + -- Concatenates two string, similar to & operator from Ada.String.Unbounded + + procedure Send_Trace (Id : Trace_T; Info : String); + -- This function (which is a subunit) send messages to external programs + +end System.Traces.Format; diff --git a/gcc/ada/s-tratas-default.adb b/gcc/ada/s-tratas-default.adb new file mode 100644 index 000000000..0c80fe96d --- /dev/null +++ b/gcc/ada/s-tratas-default.adb @@ -0,0 +1,365 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E S . T A S K I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Tasking; use System.Tasking; +with System.Soft_Links; +with System.Parameters; +with System.Traces.Format; use System.Traces.Format; +with System.Traces; use System.Traces; + +package body System.Traces.Tasking is + + use System.Traces; + + package SSL renames System.Soft_Links; + + function Extract_Accepts (Task_Name : Task_Id) return String_Trace; + -- This function is used to extract data joined with + -- W_Select, WT_Select, W_Accept events + + --------------------- + -- Send_Trace_Info -- + --------------------- + + procedure Send_Trace_Info (Id : Trace_T; Task_Name2 : Task_Id) is + Task_S : constant String := SSL.Task_Name.all; + Task2_S : constant String := + Task_Name2.Common.Task_Image + (1 .. Task_Name2.Common.Task_Image_Len); + Trace_S : String (1 .. 6 + Task_S'Length + Task2_S'Length); + + L0 : constant Integer := Task_S'Length; + L1 : constant Integer := Task2_S'Length; + + begin + if Parameters.Runtime_Traces then + case Id is + when M_RDV_Complete | PO_Done => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/C:"; + Trace_S (7 + L0 .. Trace_S'Last) := Task2_S; + Send_Trace (Id, Trace_S); + + when E_Missed => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/A:"; + Trace_S (7 + L0 .. Trace_S'Last) := Task2_S; + Send_Trace (Id, Trace_S); + + when E_Kill => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L1) := Task2_S; + Trace_S (4 + L1 .. Trace_S'Last) := (others => ' '); + Send_Trace (Id, Trace_S); + + when T_Create => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L1) := Task2_S; + Trace_S (4 + L1 .. Trace_S'Last) := (others => ' '); + Send_Trace (Id, Trace_S); + + when others => + null; + -- should raise an exception ??? + end case; + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name2 : Task_Id; + Entry_Number : Entry_Index) + is + Task_S : constant String := SSL.Task_Name.all; + Task2_S : constant String := + Task_Name2.Common.Task_Image + (1 .. Task_Name2.Common.Task_Image_Len); + Entry_S : constant String := Integer'Image (Integer (Entry_Number)); + Trace_S : String (1 .. 9 + Task_S'Length + + Task2_S'Length + Entry_S'Length); + + L0 : constant Integer := Task_S'Length; + L1 : constant Integer := Task_S'Length + Entry_S'Length; + L2 : constant Integer := Task_S'Length + Task2_S'Length; + + begin + if Parameters.Runtime_Traces then + case Id is + when M_Accept_Complete => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/E:"; + Trace_S (7 + L0 .. 6 + L1) := Entry_S; + Trace_S (7 + L1 .. 9 + L1) := "/C:"; + Trace_S (10 + L1 .. Trace_S'Last) := Task2_S; + Send_Trace (Id, Trace_S); + + when W_Call => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/A:"; + Trace_S (7 + L0 .. 6 + L2) := Task2_S; + Trace_S (7 + L2 .. 9 + L2) := "/C:"; + Trace_S (10 + L2 .. Trace_S'Last) := Entry_S; + Send_Trace (Id, Trace_S); + + when others => + null; + -- should raise an exception ??? + end case; + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : Task_Id; + Task_Name2 : Task_Id; + Entry_Number : Entry_Index) + is + Task_S : constant String := + Task_Name.Common.Task_Image + (1 .. Task_Name.Common.Task_Image_Len); + Task2_S : constant String := + Task_Name2.Common.Task_Image + (1 .. Task_Name2.Common.Task_Image_Len); + Entry_S : constant String := Integer'Image (Integer (Entry_Number)); + Trace_S : String (1 .. 9 + Task_S'Length + + Task2_S'Length + Entry_S'Length); + + L0 : constant Integer := Task_S'Length; + L1 : constant Integer := Task_S'Length + Entry_S'Length; + + begin + if Parameters.Runtime_Traces then + case Id is + when PO_Run => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/E:"; + Trace_S (7 + L0 .. 6 + L1) := Entry_S; + Trace_S (7 + L1 .. 9 + L1) := "/C:"; + Trace_S (10 + L1 .. Trace_S'Last) := Task2_S; + Send_Trace (Id, Trace_S); + + when others => + null; + -- should raise an exception ??? + end case; + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info (Id : Trace_T; Entry_Number : Entry_Index) is + Task_S : constant String := SSL.Task_Name.all; + Entry_S : constant String := Integer'Image (Integer (Entry_Number)); + Trace_S : String (1 .. 6 + Task_S'Length + Entry_S'Length); + + L0 : constant Integer := Task_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/E:"; + Trace_S (7 + L0 .. Trace_S'Last) := Entry_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : Task_Id; + Task_Name2 : Task_Id) + is + Task_S : constant String := + Task_Name.Common.Task_Image + (1 .. Task_Name.Common.Task_Image_Len); + Task2_S : constant String := + Task_Name2.Common.Task_Image + (1 .. Task_Name2.Common.Task_Image_Len); + Trace_S : String (1 .. 6 + Task_S'Length + Task2_S'Length); + + L0 : constant Integer := Task2_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task2_S; + Trace_S (4 + L0 .. 6 + L0) := "/P:"; + Trace_S (7 + L0 .. Trace_S'Last) := Task_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Acceptor : Task_Id; + Entry_Number : Entry_Index; + Timeout : Duration) + is + Task_S : constant String := SSL.Task_Name.all; + Acceptor_S : constant String := + Acceptor.Common.Task_Image + (1 .. Acceptor.Common.Task_Image_Len); + Entry_S : constant String := Integer'Image (Integer (Entry_Number)); + Timeout_S : constant String := Duration'Image (Timeout); + Trace_S : String (1 .. 12 + Task_S'Length + Acceptor_S'Length + + Entry_S'Length + Timeout_S'Length); + + L0 : constant Integer := Task_S'Length; + L1 : constant Integer := Task_S'Length + Acceptor_S'Length; + L2 : constant Integer := + Task_S'Length + Acceptor_S'Length + Entry_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/A:"; + Trace_S (7 + L0 .. 6 + L1) := Acceptor_S; + Trace_S (7 + L1 .. 9 + L1) := "/E:"; + Trace_S (10 + L1 .. 9 + L2) := Entry_S; + Trace_S (10 + L2 .. 12 + L2) := "/T:"; + Trace_S (13 + L2 .. Trace_S'Last) := Timeout_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Entry_Number : Entry_Index; + Timeout : Duration) + is + Task_S : constant String := SSL.Task_Name.all; + Entry_S : constant String := Integer'Image (Integer (Entry_Number)); + Timeout_S : constant String := Duration'Image (Timeout); + Trace_S : String (1 .. 9 + Task_S'Length + + Entry_S'Length + Timeout_S'Length); + + L0 : constant Integer := Task_S'Length; + L1 : constant Integer := Task_S'Length + Entry_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/E:"; + Trace_S (7 + L0 .. 6 + L1) := Entry_S; + Trace_S (7 + L1 .. 9 + L1) := "/T:"; + Trace_S (10 + L1 .. Trace_S'Last) := Timeout_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : Task_Id; + Number : Integer) + is + Task_S : constant String := SSL.Task_Name.all; + Number_S : constant String := Integer'Image (Number); + Accepts_S : constant String := Extract_Accepts (Task_Name); + Trace_S : String (1 .. 9 + Task_S'Length + + Number_S'Length + Accepts_S'Length); + + L0 : constant Integer := Task_S'Length; + L1 : constant Integer := Task_S'Length + Number_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/#:"; + Trace_S (7 + L0 .. 6 + L1) := Number_S; + Trace_S (7 + L1 .. 9 + L1) := "/E:"; + Trace_S (10 + L1 .. Trace_S'Last) := Accepts_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : Task_Id; + Number : Integer; + Timeout : Duration) + is + Task_S : constant String := SSL.Task_Name.all; + Timeout_S : constant String := Duration'Image (Timeout); + Number_S : constant String := Integer'Image (Number); + Accepts_S : constant String := Extract_Accepts (Task_Name); + Trace_S : String (1 .. 12 + Task_S'Length + Timeout_S'Length + + Number_S'Length + Accepts_S'Length); + + L0 : constant Integer := Task_S'Length; + L1 : constant Integer := Task_S'Length + Timeout_S'Length; + L2 : constant Integer := + Task_S'Length + Timeout_S'Length + Number_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/T:"; + Trace_S (7 + L0 .. 6 + L1) := Timeout_S; + Trace_S (7 + L1 .. 9 + L1) := "/#:"; + Trace_S (10 + L1 .. 9 + L2) := Number_S; + Trace_S (10 + L2 .. 12 + L2) := "/E:"; + Trace_S (13 + L2 .. Trace_S'Last) := Accepts_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + --------------------- + -- Extract_Accepts -- + --------------------- + + -- This function returns a string in which all opened + -- Accepts or Selects are given, separated by semi-colons. + + function Extract_Accepts (Task_Name : Task_Id) return String_Trace is + Info_Annex : String_Trace := (ASCII.NUL, others => ' '); + + begin + for J in Task_Name.Open_Accepts'First .. + Task_Name.Open_Accepts'Last - 1 + loop + Info_Annex := Append (Info_Annex, Integer'Image + (Integer (Task_Name.Open_Accepts (J).S)) & ","); + end loop; + + Info_Annex := Append (Info_Annex, + Integer'Image (Integer + (Task_Name.Open_Accepts + (Task_Name.Open_Accepts'Last).S))); + return Info_Annex; + end Extract_Accepts; +end System.Traces.Tasking; diff --git a/gcc/ada/s-tratas.adb b/gcc/ada/s-tratas.adb new file mode 100644 index 000000000..a65f70b94 --- /dev/null +++ b/gcc/ada/s-tratas.adb @@ -0,0 +1,119 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E S . T A S K I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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.Traces.Tasking is + + pragma Warnings (Off); -- kill warnings on unreferenced formals + + --------------------- + -- Send_Trace_Info -- + --------------------- + + procedure Send_Trace_Info (Id : Trace_T; Task_Name2 : ST.Task_Id) is + begin + null; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name2 : ST.Task_Id; + Entry_Number : ST.Entry_Index) + is + begin + null; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : ST.Task_Id; + Task_Name2 : ST.Task_Id; + Entry_Number : ST.Entry_Index) + is + begin + null; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : ST.Task_Id; + Task_Name2 : ST.Task_Id) + is + begin + null; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Entry_Number : ST.Entry_Index) + is + begin + null; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Acceptor : ST.Task_Id; + Entry_Number : ST.Entry_Index; + Timeout : Duration) + is + begin + null; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Entry_Number : ST.Entry_Index; + Timeout : Duration) + is + begin + null; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : ST.Task_Id; + Number : Integer) + is + begin + null; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : ST.Task_Id; + Number : Integer; + Timeout : Duration) + is + begin + null; + end Send_Trace_Info; + +end System.Traces.Tasking; diff --git a/gcc/ada/s-tratas.ads b/gcc/ada/s-tratas.ads new file mode 100644 index 000000000..7cb567a1e --- /dev/null +++ b/gcc/ada/s-tratas.ads @@ -0,0 +1,95 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E S . T A S K I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides all procedures used to implement debug traces +-- in the case tasking is involved. + +-- See System.Traces for an overview of the various files involved in Tracing + +-- If tasking is not involved, refer to System.Traces.General + +with System.Tasking; + +package System.Traces.Tasking is + pragma Preelaborate; + + package ST renames System.Tasking; + + -- Send_Trace_Info procedures + + -- They are overloaded, depending on the parameters passed with the event + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name2 : ST.Task_Id); + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name2 : ST.Task_Id; + Entry_Number : ST.Entry_Index); + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : ST.Task_Id; + Task_Name2 : ST.Task_Id; + Entry_Number : ST.Entry_Index); + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : ST.Task_Id; + Task_Name2 : ST.Task_Id); + + procedure Send_Trace_Info + (Id : Trace_T; + Entry_Number : ST.Entry_Index); + + procedure Send_Trace_Info + (Id : Trace_T; + Acceptor : ST.Task_Id; + Entry_Number : ST.Entry_Index; + Timeout : Duration); + + procedure Send_Trace_Info + (Id : Trace_T; + Entry_Number : ST.Entry_Index; + Timeout : Duration); + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : ST.Task_Id; + Number : Integer); + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : ST.Task_Id; + Number : Integer; + Timeout : Duration); +end System.Traces.Tasking; diff --git a/gcc/ada/s-unstyp.ads b/gcc/ada/s-unstyp.ads new file mode 100644 index 000000000..bbd916a2c --- /dev/null +++ b/gcc/ada/s-unstyp.ads @@ -0,0 +1,210 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 Warnings (Off); +pragma Compiler_Unit; +pragma Warnings (On); + +package System.Unsigned_Types is + pragma Pure; + + 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; + for Packed_Byte'Size use 8; + -- Component type for Packed_Bytes array + + type Packed_Bytes1 is array (Natural range <>) of Packed_Byte; + for Packed_Bytes1'Alignment use 1; + for Packed_Bytes1'Component_Size use Packed_Byte'Size; + -- 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); + -- 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); + -- 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 (rather improperly) 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 new file mode 100755 index 000000000..a5af4fbc6 --- /dev/null +++ b/gcc/ada/s-utf_32.adb @@ -0,0 +1,6341 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . U T F _ 3 2 -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit; + +pragma Style_Checks (Off); +-- Allow long lines in this unit + +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) .. + + -- 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 + + -- 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#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 new file mode 100755 index 000000000..c4c04e0ae --- /dev/null +++ b/gcc/ada/s-utf_32.ads @@ -0,0 +1,211 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . U T F _ 3 2 -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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; + +package System.UTF_32 is + + 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 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_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-vaflop-vms-alpha.adb b/gcc/ada/s-vaflop-vms-alpha.adb new file mode 100644 index 000000000..2c1e6842f --- /dev/null +++ b/gcc/ada/s-vaflop-vms-alpha.adb @@ -0,0 +1,776 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A X _ F L O A T _ O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- +-- (Version for Alpha OpenVMS) -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.IO; +with System.Machine_Code; use System.Machine_Code; + +package body System.Vax_Float_Operations is + + -- Ensure this gets compiled with -O to avoid extra (and possibly + -- improper) memory stores. + + pragma Optimize (Time); + + -- Declare the functions that do the conversions between floating-point + -- formats. Call the operands IEEE float so they get passed in + -- FP registers. + + function Cvt_G_T (X : T) return T; + function Cvt_T_G (X : T) return T; + function Cvt_T_F (X : T) return S; + + pragma Import (C, Cvt_G_T, "OTS$CVT_FLOAT_G_T"); + pragma Import (C, Cvt_T_G, "OTS$CVT_FLOAT_T_G"); + pragma Import (C, Cvt_T_F, "OTS$CVT_FLOAT_T_F"); + + -- In each of the conversion routines that are done with OTS calls, + -- we define variables of the corresponding IEEE type so that they are + -- passed and kept in the proper register class. + + Debug_String_Buffer : String (1 .. 32); + -- Buffer used by all Debug_String_x routines for returning result + + ------------ + -- D_To_G -- + ------------ + + function D_To_G (X : D) return G is + A, B : T; + C : G; + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", A), D'Asm_Input ("m", X), + Volatile => True); + Asm ("cvtdg %1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A), + Volatile => True); + Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B), + Volatile => True); + return C; + end D_To_G; + + ------------ + -- F_To_G -- + ------------ + + function F_To_G (X : F) return G is + A : T; + B : G; + begin + Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X), + Volatile => True); + Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A), + Volatile => True); + return B; + end F_To_G; + + ------------ + -- F_To_S -- + ------------ + + function F_To_S (X : F) return S is + A : T; + B : S; + + begin + -- Because converting to a wider FP format is a no-op, we say + -- A is 64-bit even though we are loading 32 bits into it. + + Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X), + Volatile => True); + + B := S (Cvt_G_T (A)); + return B; + end F_To_S; + + ------------ + -- G_To_D -- + ------------ + + function G_To_D (X : G) return D is + A, B : T; + C : D; + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X), + Volatile => True); + Asm ("cvtgd %1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A), + Volatile => True); + Asm ("stg %1,%0", D'Asm_Output ("=m", C), T'Asm_Input ("f", B), + Volatile => True); + return C; + end G_To_D; + + ------------ + -- G_To_F -- + ------------ + + function G_To_F (X : G) return F is + A : T; + B : S; + C : F; + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X), + Volatile => True); + Asm ("cvtgf %1,%0", S'Asm_Output ("=f", B), T'Asm_Input ("f", A), + Volatile => True); + Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B), + Volatile => True); + return C; + end G_To_F; + + ------------ + -- G_To_Q -- + ------------ + + function G_To_Q (X : G) return Q is + A : T; + B : Q; + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X), + Volatile => True); + Asm ("cvtgq %1,%0", Q'Asm_Output ("=f", B), T'Asm_Input ("f", A), + Volatile => True); + return B; + end G_To_Q; + + ------------ + -- G_To_T -- + ------------ + + function G_To_T (X : G) return T is + A, B : T; + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X), + Volatile => True); + B := Cvt_G_T (A); + return B; + end G_To_T; + + ------------ + -- F_To_Q -- + ------------ + + function F_To_Q (X : F) return Q is + begin + return G_To_Q (F_To_G (X)); + end F_To_Q; + + ------------ + -- Q_To_F -- + ------------ + + function Q_To_F (X : Q) return F is + A : S; + B : F; + begin + Asm ("cvtqf %1,%0", S'Asm_Output ("=f", A), Q'Asm_Input ("f", X), + Volatile => True); + Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A), + Volatile => True); + return B; + end Q_To_F; + + ------------ + -- Q_To_G -- + ------------ + + function Q_To_G (X : Q) return G is + A : T; + B : G; + begin + Asm ("cvtqg %1,%0", T'Asm_Output ("=f", A), Q'Asm_Input ("f", X), + Volatile => True); + Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A), + Volatile => True); + return B; + end Q_To_G; + + ------------ + -- S_To_F -- + ------------ + + function S_To_F (X : S) return F is + A : S; + B : F; + begin + A := Cvt_T_F (T (X)); + Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A), + Volatile => True); + return B; + end S_To_F; + + ------------ + -- T_To_D -- + ------------ + + function T_To_D (X : T) return D is + begin + return G_To_D (T_To_G (X)); + end T_To_D; + + ------------ + -- T_To_G -- + ------------ + + function T_To_G (X : T) return G is + A : T; + B : G; + begin + A := Cvt_T_G (X); + Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A), + Volatile => True); + return B; + end T_To_G; + + ----------- + -- Abs_F -- + ----------- + + function Abs_F (X : F) return F is + A, B : S; + C : F; + begin + Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X), + Volatile => True); + Asm ("cpys $f31,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A), + Volatile => True); + Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B), + Volatile => True); + return C; + end Abs_F; + + ----------- + -- Abs_G -- + ----------- + + function Abs_G (X : G) return G is + A, B : T; + C : G; + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); + Asm ("cpys $f31,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A), + Volatile => True); + Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B), + Volatile => True); + return C; + end Abs_G; + + ----------- + -- Add_F -- + ----------- + + function Add_F (X, Y : F) return F is + X1, Y1, R : S; + R1 : F; + begin + Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); + Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y), + Volatile => True); + Asm ("addf %1,%2,%0", S'Asm_Output ("=f", R), + (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)), + Volatile => True); + Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R), + Volatile => True); + return R1; + end Add_F; + + ----------- + -- Add_G -- + ----------- + + function Add_G (X, Y : G) return G is + X1, Y1, R : T; + R1 : G; + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); + Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y), + Volatile => True); + Asm ("addg %1,%2,%0", T'Asm_Output ("=f", R), + (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)), + Volatile => True); + Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R), + Volatile => True); + return R1; + end Add_G; + + -------------------- + -- Debug_Output_D -- + -------------------- + + procedure Debug_Output_D (Arg : D) is + begin + System.IO.Put (D'Image (Arg)); + end Debug_Output_D; + + -------------------- + -- Debug_Output_F -- + -------------------- + + procedure Debug_Output_F (Arg : F) is + begin + System.IO.Put (F'Image (Arg)); + end Debug_Output_F; + + -------------------- + -- Debug_Output_G -- + -------------------- + + procedure Debug_Output_G (Arg : G) is + begin + System.IO.Put (G'Image (Arg)); + end Debug_Output_G; + + -------------------- + -- Debug_String_D -- + -------------------- + + function Debug_String_D (Arg : D) return System.Address is + Image_String : constant String := D'Image (Arg) & ASCII.NUL; + Image_Size : constant Integer := Image_String'Length; + begin + Debug_String_Buffer (1 .. Image_Size) := Image_String; + return Debug_String_Buffer (1)'Address; + end Debug_String_D; + + -------------------- + -- Debug_String_F -- + -------------------- + + function Debug_String_F (Arg : F) return System.Address is + Image_String : constant String := F'Image (Arg) & ASCII.NUL; + Image_Size : constant Integer := Image_String'Length; + begin + Debug_String_Buffer (1 .. Image_Size) := Image_String; + return Debug_String_Buffer (1)'Address; + end Debug_String_F; + + -------------------- + -- Debug_String_G -- + -------------------- + + function Debug_String_G (Arg : G) return System.Address is + Image_String : constant String := G'Image (Arg) & ASCII.NUL; + Image_Size : constant Integer := Image_String'Length; + begin + Debug_String_Buffer (1 .. Image_Size) := Image_String; + return Debug_String_Buffer (1)'Address; + end Debug_String_G; + + ----------- + -- Div_F -- + ----------- + + function Div_F (X, Y : F) return F is + X1, Y1, R : S; + R1 : F; + begin + Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); + Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y), + Volatile => True); + Asm ("divf %1,%2,%0", S'Asm_Output ("=f", R), + (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)), + Volatile => True); + Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R), + Volatile => True); + return R1; + end Div_F; + + ----------- + -- Div_G -- + ----------- + + function Div_G (X, Y : G) return G is + X1, Y1, R : T; + R1 : G; + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); + Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y), + Volatile => True); + Asm ("divg %1,%2,%0", T'Asm_Output ("=f", R), + (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)), + Volatile => True); + Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R), + Volatile => True); + return R1; + end Div_G; + + ---------- + -- Eq_F -- + ---------- + + function Eq_F (X, Y : F) return Boolean is + X1, Y1, R : S; + begin + Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); + Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y), + Volatile => True); + Asm ("cmpgeq %1,%2,%0", S'Asm_Output ("=f", R), + (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)), + Volatile => True); + return R /= 0.0; + end Eq_F; + + ---------- + -- Eq_G -- + ---------- + + function Eq_G (X, Y : G) return Boolean is + X1, Y1, R : T; + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); + Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y), + Volatile => True); + Asm ("cmpgeq %1,%2,%0", T'Asm_Output ("=f", R), + (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)), + Volatile => True); + return R /= 0.0; + end Eq_G; + + ---------- + -- Le_F -- + ---------- + + function Le_F (X, Y : F) return Boolean is + X1, Y1, R : S; + begin + Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); + Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y), + Volatile => True); + Asm ("cmpgle %1,%2,%0", S'Asm_Output ("=f", R), + (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)), + Volatile => True); + return R /= 0.0; + end Le_F; + + ---------- + -- Le_G -- + ---------- + + function Le_G (X, Y : G) return Boolean is + X1, Y1, R : T; + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); + Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y), + Volatile => True); + Asm ("cmpgle %1,%2,%0", T'Asm_Output ("=f", R), + (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)), + Volatile => True); + return R /= 0.0; + end Le_G; + + ---------- + -- Lt_F -- + ---------- + + function Lt_F (X, Y : F) return Boolean is + X1, Y1, R : S; + begin + Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); + Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y), + Volatile => True); + Asm ("cmpglt %1,%2,%0", S'Asm_Output ("=f", R), + (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)), + Volatile => True); + return R /= 0.0; + end Lt_F; + + ---------- + -- Lt_G -- + ---------- + + function Lt_G (X, Y : G) return Boolean is + X1, Y1, R : T; + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); + Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y), + Volatile => True); + Asm ("cmpglt %1,%2,%0", T'Asm_Output ("=f", R), + (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)), + Volatile => True); + return R /= 0.0; + end Lt_G; + + ----------- + -- Mul_F -- + ----------- + + function Mul_F (X, Y : F) return F is + X1, Y1, R : S; + R1 : F; + begin + Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); + Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y), + Volatile => True); + Asm ("mulf %1,%2,%0", S'Asm_Output ("=f", R), + (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)), + Volatile => True); + Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R), + Volatile => True); + return R1; + end Mul_F; + + ----------- + -- Mul_G -- + ----------- + + function Mul_G (X, Y : G) return G is + X1, Y1, R : T; + R1 : G; + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); + Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y), + Volatile => True); + Asm ("mulg %1,%2,%0", T'Asm_Output ("=f", R), + (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)), + Volatile => True); + Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R), + Volatile => True); + return R1; + end Mul_G; + + ---------- + -- Ne_F -- + ---------- + + function Ne_F (X, Y : F) return Boolean is + X1, Y1, R : S; + begin + Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); + Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y), + Volatile => True); + Asm ("cmpgeq %1,%2,%0", S'Asm_Output ("=f", R), + (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)), + Volatile => True); + return R = 0.0; + end Ne_F; + + ---------- + -- Ne_G -- + ---------- + + function Ne_G (X, Y : G) return Boolean is + X1, Y1, R : T; + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); + Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y), + Volatile => True); + Asm ("cmpgeq %1,%2,%0", T'Asm_Output ("=f", R), + (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)), + Volatile => True); + return R = 0.0; + end Ne_G; + + ----------- + -- Neg_F -- + ----------- + + function Neg_F (X : F) return F is + A, B : S; + C : F; + begin + Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X)); + Asm ("cpysn %1,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A), + Volatile => True); + Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B), + Volatile => True); + return C; + end Neg_F; + + ----------- + -- Neg_G -- + ----------- + + function Neg_G (X : G) return G is + A, B : T; + C : G; + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); + Asm ("cpysn %1,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A), + Volatile => True); + Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B), + Volatile => True); + return C; + end Neg_G; + + -------- + -- pd -- + -------- + + procedure pd (Arg : D) is + begin + System.IO.Put_Line (D'Image (Arg)); + end pd; + + -------- + -- pf -- + -------- + + procedure pf (Arg : F) is + begin + System.IO.Put_Line (F'Image (Arg)); + end pf; + + -------- + -- pg -- + -------- + + procedure pg (Arg : G) is + begin + System.IO.Put_Line (G'Image (Arg)); + end pg; + + -------------- + -- Return_D -- + -------------- + + function Return_D (X : D) return D is + R : D; + + begin + -- The return value is already in $f0 so we need to trick the compiler + -- into thinking that we're moving X to $f0. + + Asm ("cvtdg $f0,$f0", Inputs => D'Asm_Input ("g", X), Clobber => "$f0", + Volatile => True); + Asm ("stg $f0,%0", D'Asm_Output ("=m", R), Volatile => True); + return R; + end Return_D; + + -------------- + -- Return_F -- + -------------- + + function Return_F (X : F) return F is + R : F; + + begin + -- The return value is already in $f0 so we need to trick the compiler + -- into thinking that we're moving X to $f0. + + Asm ("stf $f0,%0", F'Asm_Output ("=m", R), F'Asm_Input ("g", X), + Clobber => "$f0", Volatile => True); + return R; + end Return_F; + + -------------- + -- Return_G -- + -------------- + + function Return_G (X : G) return G is + R : G; + + begin + -- The return value is already in $f0 so we need to trick the compiler + -- into thinking that we're moving X to $f0. + + Asm ("stg $f0,%0", G'Asm_Output ("=m", R), G'Asm_Input ("g", X), + Clobber => "$f0", Volatile => True); + return R; + end Return_G; + + ----------- + -- Sub_F -- + ----------- + + function Sub_F (X, Y : F) return F is + X1, Y1, R : S; + R1 : F; + + begin + Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); + Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y), + Volatile => True); + Asm ("subf %1,%2,%0", S'Asm_Output ("=f", R), + (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)), + Volatile => True); + Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R), + Volatile => True); + return R1; + end Sub_F; + + ----------- + -- Sub_G -- + ----------- + + function Sub_G (X, Y : G) return G is + X1, Y1, R : T; + R1 : G; + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); + Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y), + Volatile => True); + Asm ("subg %1,%2,%0", T'Asm_Output ("=f", R), + (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)), + Volatile => True); + Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R), + Volatile => True); + return R1; + end Sub_G; + + ------------- + -- Valid_D -- + ------------- + + -- For now, convert to IEEE and do Valid test on result. This is not quite + -- accurate, but is good enough in practice. + + function Valid_D (Arg : D) return Boolean is + Val : constant T := G_To_T (D_To_G (Arg)); + begin + return Val'Valid; + end Valid_D; + + ------------- + -- Valid_F -- + ------------- + + -- For now, convert to IEEE and do Valid test on result. This is not quite + -- accurate, but is good enough in practice. + + function Valid_F (Arg : F) return Boolean is + Val : constant S := F_To_S (Arg); + begin + return Val'Valid; + end Valid_F; + + ------------- + -- Valid_G -- + ------------- + + -- For now, convert to IEEE and do Valid test on result. This is not quite + -- accurate, but is good enough in practice. + + function Valid_G (Arg : G) return Boolean is + Val : constant T := G_To_T (Arg); + begin + return Val'Valid; + end Valid_G; + +end System.Vax_Float_Operations; diff --git a/gcc/ada/s-vaflop.adb b/gcc/ada/s-vaflop.adb new file mode 100644 index 000000000..dbaa12976 --- /dev/null +++ b/gcc/ada/s-vaflop.adb @@ -0,0 +1,503 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . V A X _ F L O A T _ O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a dummy body for use on non-Alpha systems so that the library +-- can compile. This dummy version uses ordinary conversions and other +-- arithmetic operations. It is used only for testing purposes in the +-- case where the -gnatdm switch is used to force testing of VMS features +-- on non-VMS systems. + +with System.IO; + +package body System.Vax_Float_Operations is + pragma Warnings (Off); + -- Warnings about infinite recursion when the -gnatdm switch is used + + ----------- + -- Abs_F -- + ----------- + + function Abs_F (X : F) return F is + begin + return abs X; + end Abs_F; + + ----------- + -- Abs_G -- + ----------- + + function Abs_G (X : G) return G is + begin + return abs X; + end Abs_G; + + ----------- + -- Add_F -- + ----------- + + function Add_F (X, Y : F) return F is + begin + return X + Y; + end Add_F; + + ----------- + -- Add_G -- + ----------- + + function Add_G (X, Y : G) return G is + begin + return X + Y; + end Add_G; + + ------------ + -- D_To_G -- + ------------ + + function D_To_G (X : D) return G is + begin + return G (X); + end D_To_G; + + -------------------- + -- Debug_Output_D -- + -------------------- + + procedure Debug_Output_D (Arg : D) is + begin + System.IO.Put (D'Image (Arg)); + end Debug_Output_D; + + -------------------- + -- Debug_Output_F -- + -------------------- + + procedure Debug_Output_F (Arg : F) is + begin + System.IO.Put (F'Image (Arg)); + end Debug_Output_F; + + -------------------- + -- Debug_Output_G -- + -------------------- + + procedure Debug_Output_G (Arg : G) is + begin + System.IO.Put (G'Image (Arg)); + end Debug_Output_G; + + -------------------- + -- Debug_String_D -- + -------------------- + + Debug_String_Buffer : String (1 .. 32); + -- Buffer used by all Debug_String_x routines for returning result + + function Debug_String_D (Arg : D) return System.Address is + Image_String : constant String := D'Image (Arg) & ASCII.NUL; + Image_Size : constant Integer := Image_String'Length; + + begin + Debug_String_Buffer (1 .. Image_Size) := Image_String; + return Debug_String_Buffer (1)'Address; + end Debug_String_D; + + -------------------- + -- Debug_String_F -- + -------------------- + + function Debug_String_F (Arg : F) return System.Address is + Image_String : constant String := F'Image (Arg) & ASCII.NUL; + Image_Size : constant Integer := Image_String'Length; + + begin + Debug_String_Buffer (1 .. Image_Size) := Image_String; + return Debug_String_Buffer (1)'Address; + end Debug_String_F; + + -------------------- + -- Debug_String_G -- + -------------------- + + function Debug_String_G (Arg : G) return System.Address is + Image_String : constant String := G'Image (Arg) & ASCII.NUL; + Image_Size : constant Integer := Image_String'Length; + + begin + Debug_String_Buffer (1 .. Image_Size) := Image_String; + return Debug_String_Buffer (1)'Address; + end Debug_String_G; + + ----------- + -- Div_F -- + ----------- + + function Div_F (X, Y : F) return F is + begin + return X / Y; + end Div_F; + + ----------- + -- Div_G -- + ----------- + + function Div_G (X, Y : G) return G is + begin + return X / Y; + end Div_G; + + ---------- + -- Eq_F -- + ---------- + + function Eq_F (X, Y : F) return Boolean is + begin + return X = Y; + end Eq_F; + + ---------- + -- Eq_G -- + ---------- + + function Eq_G (X, Y : G) return Boolean is + begin + return X = Y; + end Eq_G; + + ------------ + -- F_To_G -- + ------------ + + function F_To_G (X : F) return G is + begin + return G (X); + end F_To_G; + + ------------ + -- F_To_Q -- + ------------ + + function F_To_Q (X : F) return Q is + begin + return Q (X); + end F_To_Q; + + ------------ + -- F_To_S -- + ------------ + + function F_To_S (X : F) return S is + begin + return S (X); + end F_To_S; + + ------------ + -- G_To_D -- + ------------ + + function G_To_D (X : G) return D is + begin + return D (X); + end G_To_D; + + ------------ + -- G_To_F -- + ------------ + + function G_To_F (X : G) return F is + begin + return F (X); + end G_To_F; + + ------------ + -- G_To_Q -- + ------------ + + function G_To_Q (X : G) return Q is + begin + return Q (X); + end G_To_Q; + + ------------ + -- G_To_T -- + ------------ + + function G_To_T (X : G) return T is + begin + return T (X); + end G_To_T; + + ---------- + -- Le_F -- + ---------- + + function Le_F (X, Y : F) return Boolean is + begin + return X <= Y; + end Le_F; + + ---------- + -- Le_G -- + ---------- + + function Le_G (X, Y : G) return Boolean is + begin + return X <= Y; + end Le_G; + + ---------- + -- Lt_F -- + ---------- + + function Lt_F (X, Y : F) return Boolean is + begin + return X < Y; + end Lt_F; + + ---------- + -- Lt_G -- + ---------- + + function Lt_G (X, Y : G) return Boolean is + begin + return X < Y; + end Lt_G; + + ----------- + -- Mul_F -- + ----------- + + function Mul_F (X, Y : F) return F is + begin + return X * Y; + end Mul_F; + + ----------- + -- Mul_G -- + ----------- + + function Mul_G (X, Y : G) return G is + begin + return X * Y; + end Mul_G; + + ---------- + -- Ne_F -- + ---------- + + function Ne_F (X, Y : F) return Boolean is + begin + return X /= Y; + end Ne_F; + + ---------- + -- Ne_G -- + ---------- + + function Ne_G (X, Y : G) return Boolean is + begin + return X /= Y; + end Ne_G; + + ----------- + -- Neg_F -- + ----------- + + function Neg_F (X : F) return F is + begin + return -X; + end Neg_F; + + ----------- + -- Neg_G -- + ----------- + + function Neg_G (X : G) return G is + begin + return -X; + end Neg_G; + + -------- + -- pd -- + -------- + + procedure pd (Arg : D) is + begin + System.IO.Put_Line (D'Image (Arg)); + end pd; + + -------- + -- pf -- + -------- + + procedure pf (Arg : F) is + begin + System.IO.Put_Line (F'Image (Arg)); + end pf; + + -------- + -- pg -- + -------- + + procedure pg (Arg : G) is + begin + System.IO.Put_Line (G'Image (Arg)); + end pg; + + ------------ + -- Q_To_F -- + ------------ + + function Q_To_F (X : Q) return F is + begin + return F (X); + end Q_To_F; + + ------------ + -- Q_To_G -- + ------------ + + function Q_To_G (X : Q) return G is + begin + return G (X); + end Q_To_G; + + ------------ + -- S_To_F -- + ------------ + + function S_To_F (X : S) return F is + begin + return F (X); + end S_To_F; + + -------------- + -- Return_D -- + -------------- + + function Return_D (X : D) return D is + begin + return X; + end Return_D; + + -------------- + -- Return_F -- + -------------- + + function Return_F (X : F) return F is + begin + return X; + end Return_F; + + -------------- + -- Return_G -- + -------------- + + function Return_G (X : G) return G is + begin + return X; + end Return_G; + + ----------- + -- Sub_F -- + ----------- + + function Sub_F (X, Y : F) return F is + begin + return X - Y; + end Sub_F; + + ----------- + -- Sub_G -- + ----------- + + function Sub_G (X, Y : G) return G is + begin + return X - Y; + end Sub_G; + + ------------ + -- T_To_D -- + ------------ + + function T_To_D (X : T) return D is + begin + return G_To_D (T_To_G (X)); + end T_To_D; + + ------------ + -- T_To_G -- + ------------ + + function T_To_G (X : T) return G is + begin + return G (X); + end T_To_G; + + ------------- + -- Valid_D -- + ------------- + + -- For now, convert to IEEE and do Valid test on result. This is not quite + -- accurate, but is good enough in practice. + + function Valid_D (Arg : D) return Boolean is + Val : constant T := G_To_T (D_To_G (Arg)); + begin + return Val'Valid; + end Valid_D; + + ------------- + -- Valid_F -- + ------------- + + -- For now, convert to IEEE and do Valid test on result. This is not quite + -- accurate, but is good enough in practice. + + function Valid_F (Arg : F) return Boolean is + Val : constant S := F_To_S (Arg); + begin + return Val'Valid; + end Valid_F; + + ------------- + -- Valid_G -- + ------------- + + -- For now, convert to IEEE and do Valid test on result. This is not quite + -- accurate, but is good enough in practice. + + function Valid_G (Arg : G) return Boolean is + Val : constant T := G_To_T (Arg); + begin + return Val'Valid; + end Valid_G; + +end System.Vax_Float_Operations; diff --git a/gcc/ada/s-vaflop.ads b/gcc/ada/s-vaflop.ads new file mode 100644 index 000000000..49120b74e --- /dev/null +++ b/gcc/ada/s-vaflop.ads @@ -0,0 +1,247 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A X _ F L O A T _ O P E R A T I O N S -- +-- -- +-- 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 package contains runtime routines for handling the non-IEEE +-- floating-point formats used on the Vax and the Alpha. + +package System.Vax_Float_Operations is + + pragma Warnings (Off); + -- Suppress warnings if not on Alpha/VAX + + type D is digits 9; + pragma Float_Representation (VAX_Float, D); + -- D Float type on Vax + + type G is digits 15; + pragma Float_Representation (VAX_Float, G); + -- G Float type on Vax + + type F is digits 6; + pragma Float_Representation (VAX_Float, F); + -- F Float type on Vax + + type S is digits 6; + pragma Float_Representation (IEEE_Float, S); + -- IEEE short + + type T is digits 15; + pragma Float_Representation (IEEE_Float, T); + -- IEEE long + + pragma Warnings (On); + + type Q is range -2 ** 63 .. +(2 ** 63 - 1); + -- 64-bit signed integer + + -------------------------- + -- Conversion Functions -- + -------------------------- + + function D_To_G (X : D) return G; + function G_To_D (X : G) return D; + -- Conversions between D float and G float + + function G_To_F (X : G) return F; + function F_To_G (X : F) return G; + -- Conversions between F float and G float + + function F_To_S (X : F) return S; + function S_To_F (X : S) return F; + -- Conversions between F float and IEEE short + + function G_To_T (X : G) return T; + function T_To_G (X : T) return G; + -- Conversions between G float and IEEE long + + function F_To_Q (X : F) return Q; + function Q_To_F (X : Q) return F; + -- Conversions between F float and 64-bit integer + + function G_To_Q (X : G) return Q; + function Q_To_G (X : Q) return G; + -- Conversions between G float and 64-bit integer + + function T_To_D (X : T) return D; + -- Conversion from IEEE long to D_Float (used for literals) + + -------------------------- + -- Arithmetic Functions -- + -------------------------- + + function Abs_F (X : F) return F; + function Abs_G (X : G) return G; + -- Absolute value of F/G float + + function Add_F (X, Y : F) return F; + function Add_G (X, Y : G) return G; + -- Addition of F/G float + + function Div_F (X, Y : F) return F; + function Div_G (X, Y : G) return G; + -- Division of F/G float + + function Mul_F (X, Y : F) return F; + function Mul_G (X, Y : G) return G; + -- Multiplication of F/G float + + function Neg_F (X : F) return F; + function Neg_G (X : G) return G; + -- Negation of F/G float + + function Sub_F (X, Y : F) return F; + function Sub_G (X, Y : G) return G; + -- Subtraction of F/G float + + -------------------------- + -- Comparison Functions -- + -------------------------- + + function Eq_F (X, Y : F) return Boolean; + function Eq_G (X, Y : G) return Boolean; + -- Compares for X = Y + + function Le_F (X, Y : F) return Boolean; + function Le_G (X, Y : G) return Boolean; + -- Compares for X <= Y + + function Lt_F (X, Y : F) return Boolean; + function Lt_G (X, Y : G) return Boolean; + -- Compares for X < Y + + function Ne_F (X, Y : F) return Boolean; + function Ne_G (X, Y : G) return Boolean; + -- Compares for X /= Y + + ---------------------- + -- Return Functions -- + ---------------------- + + function Return_D (X : D) return D; + function Return_F (X : F) return F; + function Return_G (X : G) return G; + -- Deal with returned value for an imported function where the function + -- result is of VAX Float type. Usually nothing needs to be done, and these + -- functions return their argument unchanged. But for the case of VMS Alpha + -- the return value is already in $f0, so we need to trick the compiler + -- into thinking that we are moving X to $f0. See bodies for this case + -- for the Asm sequence generated to achieve this. + + ---------------------------------- + -- Routines for Valid Attribute -- + ---------------------------------- + + function Valid_D (Arg : D) return Boolean; + function Valid_F (Arg : F) return Boolean; + function Valid_G (Arg : G) return Boolean; + -- Test whether Arg has a valid representation + + ---------------------- + -- Debug Procedures -- + ---------------------- + + procedure Debug_Output_D (Arg : D); + procedure Debug_Output_F (Arg : F); + procedure Debug_Output_G (Arg : G); + pragma Export (Ada, Debug_Output_D); + pragma Export (Ada, Debug_Output_F); + pragma Export (Ada, Debug_Output_G); + -- These routines output their argument in decimal string form, with + -- no terminating line return. They are provided for implicit use by + -- the pre gnat-3.12w GDB, and are retained for backwards compatibility. + + function Debug_String_D (Arg : D) return System.Address; + function Debug_String_F (Arg : F) return System.Address; + function Debug_String_G (Arg : G) return System.Address; + pragma Export (Ada, Debug_String_D); + pragma Export (Ada, Debug_String_F); + pragma Export (Ada, Debug_String_G); + -- These routines return a decimal C string image of their argument. + -- They are provided for implicit use by the debugger, in response to + -- the special encoding used for Vax floating-point types (see Exp_Dbug + -- for details). They supersede the above Debug_Output_D/F/G routines + -- which didn't work properly with GDBTK. + + procedure pd (Arg : D); + procedure pf (Arg : F); + procedure pg (Arg : G); + pragma Export (Ada, pd); + pragma Export (Ada, pf); + pragma Export (Ada, pg); + -- These are like the Debug_Output_D/F/G procedures except that they + -- output a line return after the output. They were originally present + -- for direct use in GDB before GDB recognized Vax floating-point + -- types, and are retained for backwards compatibility. + +private + pragma Inline_Always (D_To_G); + pragma Inline_Always (F_To_G); + pragma Inline_Always (F_To_Q); + pragma Inline_Always (F_To_S); + pragma Inline_Always (G_To_D); + pragma Inline_Always (G_To_F); + pragma Inline_Always (G_To_Q); + pragma Inline_Always (G_To_T); + pragma Inline_Always (Q_To_F); + pragma Inline_Always (Q_To_G); + pragma Inline_Always (S_To_F); + pragma Inline_Always (T_To_G); + + pragma Inline_Always (Abs_F); + pragma Inline_Always (Abs_G); + pragma Inline_Always (Add_F); + pragma Inline_Always (Add_G); + pragma Inline_Always (Div_G); + pragma Inline_Always (Div_F); + pragma Inline_Always (Mul_F); + pragma Inline_Always (Mul_G); + pragma Inline_Always (Neg_G); + pragma Inline_Always (Neg_F); + pragma Inline_Always (Return_D); + pragma Inline_Always (Return_F); + pragma Inline_Always (Return_G); + pragma Inline_Always (Sub_F); + pragma Inline_Always (Sub_G); + + pragma Inline_Always (Eq_F); + pragma Inline_Always (Eq_G); + pragma Inline_Always (Le_F); + pragma Inline_Always (Le_G); + pragma Inline_Always (Lt_F); + pragma Inline_Always (Lt_G); + pragma Inline_Always (Ne_F); + pragma Inline_Always (Ne_G); + + pragma Inline_Always (Valid_D); + pragma Inline_Always (Valid_F); + pragma Inline_Always (Valid_G); + +end System.Vax_Float_Operations; diff --git a/gcc/ada/s-valboo.adb b/gcc/ada/s-valboo.adb new file mode 100644 index 000000000..bea214065 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 + raise Constraint_Error; + end if; + end Value_Boolean; + +end System.Val_Bool; diff --git a/gcc/ada/s-valboo.ads b/gcc/ada/s-valboo.ads new file mode 100644 index 000000000..3b6992402 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 new file mode 100644 index 000000000..8dddcf584 --- /dev/null +++ b/gcc/ada/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-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 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; + + raise Constraint_Error; + end if; + end Value_Character; + +end System.Val_Char; diff --git a/gcc/ada/s-valcha.ads b/gcc/ada/s-valcha.ads new file mode 100644 index 000000000..193f9bdfd --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 new file mode 100644 index 000000000..88b28c9b1 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..cb7a73110 --- /dev/null +++ b/gcc/ada/s-valdec.ads @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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 types 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, otherwise the value returned is the + -- value Integer'Integer_Value (decimal-literal-value), using the given + -- Scale to determine this value. + +end System.Val_Dec; diff --git a/gcc/ada/s-valenu.adb b/gcc/ada/s-valenu.adb new file mode 100644 index 000000000..66a84ec82 --- /dev/null +++ b/gcc/ada/s-valenu.adb @@ -0,0 +1,154 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ 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; +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; + + raise Constraint_Error; + 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; + + raise Constraint_Error; + 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; + + raise Constraint_Error; + end Value_Enumeration_32; + +end System.Val_Enum; diff --git a/gcc/ada/s-valenu.ads b/gcc/ada/s-valenu.ads new file mode 100644 index 000000000..fa5d205d4 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..c37b9dcf0 --- /dev/null +++ b/gcc/ada/s-valint.adb @@ -0,0 +1,100 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ I N 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. -- +-- -- +------------------------------------------------------------------------------ + +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; + raise Constraint_Error; + 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 + raise Constraint_Error; + 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 + V : Integer; + P : aliased Integer := Str'First; + begin + V := Scan_Integer (Str, P'Access, Str'Last); + Scan_Trailing_Blanks (Str, P); + return V; + end Value_Integer; + +end System.Val_Int; diff --git a/gcc/ada/s-valint.ads b/gcc/ada/s-valint.ads new file mode 100644 index 000000000..08b229bb4 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..0fef8a4b2 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..c4d089bfe --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..66f93f7a6 --- /dev/null +++ b/gcc/ada/s-vallli.adb @@ -0,0 +1,102 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ 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. -- +-- -- +------------------------------------------------------------------------------ + +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 (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; + raise Constraint_Error; + 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 + raise Constraint_Error; + 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 + 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 Value_Long_Long_Integer; + +end System.Val_LLI; diff --git a/gcc/ada/s-vallli.ads b/gcc/ada/s-vallli.ads new file mode 100644 index 000000000..c1aceb35d --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..f59bf2fe9 --- /dev/null +++ b/gcc/ada/s-valllu.adb @@ -0,0 +1,304 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ 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; +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 + 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 + + 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; + raise Constraint_Error; + 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 + raise Constraint_Error; + 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 + 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 Value_Long_Long_Unsigned; + +end System.Val_LLU; diff --git a/gcc/ada/s-valllu.ads b/gcc/ada/s-valllu.ads new file mode 100644 index 000000000..72b9d5219 --- /dev/null +++ b/gcc/ada/s-valllu.ads @@ -0,0 +1,86 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ 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 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: 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. + + 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 new file mode 100644 index 000000000..40c5abbca --- /dev/null +++ b/gcc/ada/s-valrea.adb @@ -0,0 +1,403 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ R E 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Powten_Table; use System.Powten_Table; +with System.Val_Util; use System.Val_Util; + +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 + procedure Reset; + pragma Import (C, Reset, "__gnat_init_float"); + -- We import the floating-point processor reset routine so that we can + -- be sure the floating-point processor is properly set for conversion + -- calls (see description of Reset in GNAT.Float_Control (g-flocon.ads). + -- This is notably need on Windows, where calls to the operating system + -- randomly reset the processor into 64-bit mode. + + 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 Bad_Based_Value; + pragma No_Return (Bad_Based_Value); + -- Raise exception for bad based value + + 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. + + --------------------- + -- Bad_Based_Value -- + --------------------- + + procedure Bad_Based_Value is + begin + raise Constraint_Error with + "invalid based literal for 'Value"; + end Bad_Based_Value; + + ----------- + -- 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 + 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 + raise Constraint_Error with + "invalid character in 'Value string"; + end if; + + -- Deal with based case + + 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_Based_Value; + + 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_Based_Value; + 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_Based_Value; + + 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_Based_Value; + 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; + + if Scale > 0 then + Uval := Uval * Powten (Scale); + end if; + + elsif Scale < 0 then + while (-Scale) > Maxpow loop + Uval := Uval / Powten (Maxpow); + Scale := Scale + Maxpow; + end loop; + + if Scale < 0 then + Uval := Uval / Powten (-Scale); + end if; + end if; + + -- Here is where we check for a bad based number + + if Bad_Base then + Bad_Based_Value; + + -- 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 + 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 Value_Real; + +end System.Val_Real; diff --git a/gcc/ada/s-valrea.ads b/gcc/ada/s-valrea.ads new file mode 100644 index 000000000..637e70ae2 --- /dev/null +++ b/gcc/ada/s-valrea.ads @@ -0,0 +1,70 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ 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. -- +-- -- +------------------------------------------------------------------------------ + +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. + + 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 new file mode 100644 index 000000000..d2e0a9144 --- /dev/null +++ b/gcc/ada/s-valuns.adb @@ -0,0 +1,299 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ U N 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.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 + 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 + + 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; + raise Constraint_Error; + 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 + raise Constraint_Error; + 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; + raise Constraint_Error; + end if; + + return Scan_Raw_Unsigned (Str, Ptr, Max); + end Scan_Unsigned; + + -------------------- + -- Value_Unsigned -- + -------------------- + + function Value_Unsigned (Str : String) return Unsigned is + V : Unsigned; + P : aliased Integer := Str'First; + begin + V := Scan_Unsigned (Str, P'Access, Str'Last); + Scan_Trailing_Blanks (Str, P); + return V; + end Value_Unsigned; + +end System.Val_Uns; diff --git a/gcc/ada/s-valuns.ads b/gcc/ada/s-valuns.ads new file mode 100644 index 000000000..fa378bbc7 --- /dev/null +++ b/gcc/ada/s-valuns.ads @@ -0,0 +1,86 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ U N 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 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: 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. + + 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 new file mode 100644 index 000000000..86274e7bf --- /dev/null +++ b/gcc/ada/s-valuti.adb @@ -0,0 +1,326 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ U T I 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.Case_Util; use System.Case_Util; + +package body System.Val_Util is + + ---------------------- + -- 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 + raise Constraint_Error; + 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 + raise Constraint_Error; + end if; + + -- Scan past initial blanks + + while Str (P) = ' ' loop + P := P + 1; + + if P > Max then + Ptr.all := P; + raise Constraint_Error; + 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; + raise Constraint_Error; + 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 + raise Constraint_Error; + end if; + + -- Scan past initial blanks + + while Str (P) = ' ' loop + P := P + 1; + + if P > Max then + Ptr.all := P; + raise Constraint_Error; + 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; + raise Constraint_Error; + end if; + + -- Skip past an initial plus sign + + elsif Str (P) = '+' then + Minus := False; + P := P + 1; + + if P > Max then + Ptr.all := Start; + raise Constraint_Error; + 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 + raise Constraint_Error; + 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; + raise Constraint_Error; + 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; + raise Constraint_Error; + end if; + end Scan_Underscore; + +end System.Val_Util; diff --git a/gcc/ada/s-valuti.ads b/gcc/ada/s-valuti.ads new file mode 100644 index 000000000..0a92352a3 --- /dev/null +++ b/gcc/ada/s-valuti.ads @@ -0,0 +1,113 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ U T I 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 provides some common utilities used by the s-valxxx files + +package System.Val_Util is + pragma Pure; + + 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. + + 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. + + 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. + +end System.Val_Util; diff --git a/gcc/ada/s-valwch.adb b/gcc/ada/s-valwch.adb new file mode 100644 index 000000000..b2db5005a --- /dev/null +++ b/gcc/ada/s-valwch.adb @@ -0,0 +1,176 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ 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.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 + raise Constraint_Error with + "out of range character for Value attribute"; + 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 + raise Constraint_Error; + + -- 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 + raise Constraint_Error; + 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 + raise Constraint_Error; + 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 + raise Constraint_Error; + end if; + end loop; + + if W > 16#7FFF_FFFF# then + raise Constraint_Error; + 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 => + raise Constraint_Error with "invalid string for value attribute"; + end Value_Wide_Wide_Character; + +end System.Val_WChar; diff --git a/gcc/ada/s-valwch.ads b/gcc/ada/s-valwch.ads new file mode 100644 index 000000000..4bf9309bb --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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 new file mode 100644 index 000000000..dea318abb --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..9553dd1d9 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..7205258ab --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..7c2f89f1c --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..4513d9dac --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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-vmexta.adb b/gcc/ada/s-vmexta.adb new file mode 100644 index 000000000..b19e27436 --- /dev/null +++ b/gcc/ada/s-vmexta.adb @@ -0,0 +1,187 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V M S _ E X C E P T I O N _ T A B L E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an Alpha/VMS package + +with System.HTable; +pragma Elaborate_All (System.HTable); + +package body System.VMS_Exception_Table is + + use type SSL.Exception_Code; + + type HTable_Headers is range 1 .. 37; + + type Exception_Code_Data; + type Exception_Code_Data_Ptr is access all Exception_Code_Data; + + -- The following record maps an imported VMS condition to an + -- Ada exception. + + type Exception_Code_Data is record + Code : SSL.Exception_Code; + Except : SSL.Exception_Data_Ptr; + HTable_Ptr : Exception_Code_Data_Ptr; + end record; + + procedure Set_HT_Link + (T : Exception_Code_Data_Ptr; + Next : Exception_Code_Data_Ptr); + + function Get_HT_Link (T : Exception_Code_Data_Ptr) + return Exception_Code_Data_Ptr; + + function Hash (F : SSL.Exception_Code) return HTable_Headers; + function Get_Key (T : Exception_Code_Data_Ptr) return SSL.Exception_Code; + + package Exception_Code_HTable is new System.HTable.Static_HTable ( + Header_Num => HTable_Headers, + Element => Exception_Code_Data, + Elmt_Ptr => Exception_Code_Data_Ptr, + Null_Ptr => null, + Set_Next => Set_HT_Link, + Next => Get_HT_Link, + Key => SSL.Exception_Code, + Get_Key => Get_Key, + Hash => Hash, + Equal => "="); + + ------------------ + -- Base_Code_In -- + ------------------ + + function Base_Code_In + (Code : SSL.Exception_Code) return SSL.Exception_Code + is + begin + return Code and not 2#0111#; + end Base_Code_In; + + --------------------- + -- Coded_Exception -- + --------------------- + + function Coded_Exception + (X : SSL.Exception_Code) return SSL.Exception_Data_Ptr + is + Res : Exception_Code_Data_Ptr; + + begin + Res := Exception_Code_HTable.Get (X); + + if Res /= null then + return Res.Except; + else + return null; + end if; + + end Coded_Exception; + + ----------------- + -- Get_HT_Link -- + ----------------- + + function Get_HT_Link + (T : Exception_Code_Data_Ptr) return Exception_Code_Data_Ptr + is + begin + return T.HTable_Ptr; + end Get_HT_Link; + + ------------- + -- Get_Key -- + ------------- + + function Get_Key (T : Exception_Code_Data_Ptr) + return SSL.Exception_Code + is + begin + return T.Code; + end Get_Key; + + ---------- + -- Hash -- + ---------- + + function Hash + (F : SSL.Exception_Code) return HTable_Headers + is + Headers_Magnitude : constant SSL.Exception_Code := + SSL.Exception_Code (HTable_Headers'Last - HTable_Headers'First + 1); + + begin + return HTable_Headers (F mod Headers_Magnitude + 1); + end Hash; + + ---------------------------- + -- Register_VMS_Exception -- + ---------------------------- + + procedure Register_VMS_Exception + (Code : SSL.Exception_Code; + E : SSL.Exception_Data_Ptr) + is + -- We bind the exception data with the base code found in the + -- input value, that is with the severity bits masked off. + + Excode : constant SSL.Exception_Code := Base_Code_In (Code); + + begin + -- The exception data registered here is mostly filled prior to this + -- call and by __gnat_error_handler when the exception is raised. We + -- still need to fill a couple of components for exceptions that will + -- be used as propagation filters (exception data pointer registered + -- as choices in the unwind tables): in some import/export cases, the + -- exception pointers for the choice and the propagated occurrence may + -- indeed be different for a single import code, and the personality + -- routine attempts to match the import codes in this case. + + E.Lang := 'V'; + E.Import_Code := Excode; + + if Exception_Code_HTable.Get (Excode) = null then + Exception_Code_HTable.Set (new Exception_Code_Data'(Excode, E, null)); + end if; + end Register_VMS_Exception; + + ----------------- + -- Set_HT_Link -- + ----------------- + + procedure Set_HT_Link + (T : Exception_Code_Data_Ptr; + Next : Exception_Code_Data_Ptr) + is + begin + T.HTable_Ptr := Next; + end Set_HT_Link; + +end System.VMS_Exception_Table; diff --git a/gcc/ada/s-vmexta.ads b/gcc/ada/s-vmexta.ads new file mode 100644 index 000000000..e19929e1d --- /dev/null +++ b/gcc/ada/s-vmexta.ads @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V M S _ E X C E P T I O N _ T A B L E -- +-- -- +-- 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 package is usually used only on Alpha/VMS systems in the case +-- where there is at least one Import/Export exception present. + +with System.Standard_Library; + +package System.VMS_Exception_Table is + + package SSL renames System.Standard_Library; + + procedure Register_VMS_Exception + (Code : SSL.Exception_Code; + E : SSL.Exception_Data_Ptr); + -- Register an exception in the hash table mapping with a VMS + -- condition code. + + -- LOTS more comments needed here regarding the entire scheme ??? + +private + + function Base_Code_In (Code : SSL.Exception_Code) return SSL.Exception_Code; + -- Value of Code with the severity bits masked off + + function Coded_Exception (X : SSL.Exception_Code) + return SSL.Exception_Data_Ptr; + -- Given a VMS condition, find and return it's allocated Ada exception + -- (called only from init.c). + +end System.VMS_Exception_Table; diff --git a/gcc/ada/s-vxwext-kernel.adb b/gcc/ada/s-vxwext-kernel.adb new file mode 100644 index 000000000..d43edf154 --- /dev/null +++ b/gcc/ada/s-vxwext-kernel.adb @@ -0,0 +1,89 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . V X W O R K S . E X T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2008-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 -- +-- . -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides vxworks specific support functions needed +-- by System.OS_Interface. + +-- This is the VxWorks <= 6.5 kernel version of this package +-- Also works for 6.6 uniprocessor + +package body System.VxWorks.Ext is + + ERROR : constant := -1; + + -------------- + -- Int_Lock -- + -------------- + + function intLock return int; + pragma Import (C, intLock, "intLock"); + + function Int_Lock return int renames intLock; + + ---------------- + -- Int_Unlock -- + ---------------- + + function intUnlock return int; + pragma Import (C, intUnlock, "intUnlock"); + + function Int_Unlock return int renames intUnlock; + + --------------- + -- semDelete -- + --------------- + + function semDelete (Sem : SEM_ID) return int is + function Os_Sem_Delete (Sem : SEM_ID) return int; + pragma Import (C, Os_Sem_Delete, "semDelete"); + begin + return Os_Sem_Delete (Sem); + end semDelete; + + ------------------------ + -- taskCpuAffinitySet -- + ------------------------ + + function taskCpuAffinitySet (tid : t_id; CPU : int) return int is + pragma Unreferenced (tid, CPU); + begin + return ERROR; + end taskCpuAffinitySet; + + -------------- + -- taskStop -- + -------------- + + function Task_Stop (tid : t_id) return int is + function taskStop (tid : t_id) return int; + pragma Import (C, taskStop, "taskStop"); + begin + return taskStop (tid); + end Task_Stop; + +end System.VxWorks.Ext; diff --git a/gcc/ada/s-vxwext-kernel.ads b/gcc/ada/s-vxwext-kernel.ads new file mode 100644 index 000000000..59dfee03a --- /dev/null +++ b/gcc/ada/s-vxwext-kernel.ads @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . V X W O R K S . E X T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2008-2010, 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 -- +-- . -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides vxworks specific support functions needed +-- by System.OS_Interface. + +-- This is the VxWorks 6 kernel version of this package + +with Interfaces.C; + +package System.VxWorks.Ext is + pragma Preelaborate; + + subtype SEM_ID is Long_Integer; + -- typedef struct semaphore *SEM_ID; + + type sigset_t is mod 2 ** Long_Long_Integer'Size; + + type t_id is new Long_Integer; + subtype int is Interfaces.C.int; + + type Interrupt_Handler is access procedure (parameter : System.Address); + pragma Convention (C, Interrupt_Handler); + + type Interrupt_Vector is new System.Address; + + function Int_Lock return int; + pragma Convention (C, Int_Lock); + + function Int_Unlock return int; + pragma Convention (C, Int_Unlock); + + function Interrupt_Connect + (Vector : Interrupt_Vector; + Handler : Interrupt_Handler; + Parameter : System.Address := System.Null_Address) return int; + pragma Import (C, Interrupt_Connect, "intConnect"); + + function Interrupt_Context return int; + pragma Import (C, Interrupt_Context, "intContext"); + + function Interrupt_Number_To_Vector + (intNum : int) return Interrupt_Vector; + pragma Import (C, Interrupt_Number_To_Vector, "__gnat_inum_to_ivec"); + + function semDelete (Sem : SEM_ID) return int; + pragma Convention (C, semDelete); + + function Task_Cont (tid : t_id) return int; + pragma Import (C, Task_Cont, "taskCont"); + + function Task_Stop (tid : t_id) return int; + pragma Convention (C, Task_Stop); + + function kill (pid : t_id; sig : int) return int; + pragma Import (C, kill, "kill"); + + function getpid return t_id; + pragma Import (C, getpid, "taskIdSelf"); + + function Set_Time_Slice (ticks : int) return int; + pragma Import (C, Set_Time_Slice, "kernelTimeSlice"); + + type UINT64 is mod 2 ** Long_Long_Integer'Size; + + function tickGet return UINT64; + -- Needed for ravenscar-cert + pragma Import (C, tickGet, "tick64Get"); + + -------------------------------- + -- Processor Affinity for SMP -- + -------------------------------- + + function taskCpuAffinitySet (tid : t_id; CPU : int) return int; + pragma Convention (C, taskCpuAffinitySet); + -- For SMP run-times set the CPU affinity. + -- For uniprocessor systems return ERROR status. + +end System.VxWorks.Ext; diff --git a/gcc/ada/s-vxwext-rtp.adb b/gcc/ada/s-vxwext-rtp.adb new file mode 100644 index 000000000..431f41e74 --- /dev/null +++ b/gcc/ada/s-vxwext-rtp.adb @@ -0,0 +1,124 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . V X W O R K S . E X T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2008-2010, 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 -- +-- . -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides VxWorks specific support functions needed +-- by System.OS_Interface. + +-- This is the VxWorks 6 RTP version of this package + +package body System.VxWorks.Ext is + + ERROR : constant := -1; + + -------------- + -- Int_Lock -- + -------------- + + function Int_Lock return int is + begin + return ERROR; + end Int_Lock; + + ---------------- + -- Int_Unlock -- + ---------------- + + function Int_Unlock return int is + begin + return ERROR; + end Int_Unlock; + + ----------------------- + -- Interrupt_Connect -- + ----------------------- + + function Interrupt_Connect + (Vector : Interrupt_Vector; + Handler : Interrupt_Handler; + Parameter : System.Address := System.Null_Address) return int + is + pragma Unreferenced (Vector, Handler, Parameter); + begin + return ERROR; + end Interrupt_Connect; + + ----------------------- + -- Interrupt_Context -- + ----------------------- + + function Interrupt_Context return int is + begin + -- For RTPs, never in an interrupt context + + return 0; + end Interrupt_Context; + + -------------------------------- + -- Interrupt_Number_To_Vector -- + -------------------------------- + + function Interrupt_Number_To_Vector + (intNum : int) return Interrupt_Vector + is + pragma Unreferenced (intNum); + begin + return 0; + end Interrupt_Number_To_Vector; + + --------------- + -- semDelete -- + --------------- + + function semDelete (Sem : SEM_ID) return int is + function OS_semDelete (Sem : SEM_ID) return int; + pragma Import (C, OS_semDelete, "semDelete"); + begin + return OS_semDelete (Sem); + end semDelete; + + -------------------- + -- Set_Time_Slice -- + -------------------- + + function Set_Time_Slice (ticks : int) return int is + pragma Unreferenced (ticks); + begin + return ERROR; + end Set_Time_Slice; + + ------------------------ + -- taskCpuAffinitySet -- + ------------------------ + + function taskCpuAffinitySet (tid : t_id; CPU : int) return int is + pragma Unreferenced (tid, CPU); + begin + return ERROR; + end taskCpuAffinitySet; + +end System.VxWorks.Ext; diff --git a/gcc/ada/s-vxwext-rtp.ads b/gcc/ada/s-vxwext-rtp.ads new file mode 100644 index 000000000..f1783c9c2 --- /dev/null +++ b/gcc/ada/s-vxwext-rtp.ads @@ -0,0 +1,98 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . V X W O R K S . E X T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2008-2010, 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 -- +-- . -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides vxworks specific support functions needed +-- by System.OS_Interface. + +-- This is the VxWorks 6 RTP version of this package + +with Interfaces.C; + +package System.VxWorks.Ext is + pragma Preelaborate; + + subtype SEM_ID is Long_Integer; + -- typedef struct semaphore *SEM_ID; + + type sigset_t is mod 2 ** Long_Long_Integer'Size; + + type t_id is new Long_Integer; + subtype int is Interfaces.C.int; + + type Interrupt_Handler is access procedure (parameter : System.Address); + pragma Convention (C, Interrupt_Handler); + + type Interrupt_Vector is new System.Address; + + function Int_Lock return int; + pragma Inline (Int_Lock); + + function Int_Unlock return int; + pragma Inline (Int_Unlock); + + function Interrupt_Connect + (Vector : Interrupt_Vector; + Handler : Interrupt_Handler; + Parameter : System.Address := System.Null_Address) return int; + pragma Convention (C, Interrupt_Connect); + + function Interrupt_Context return int; + pragma Convention (C, Interrupt_Context); + + function Interrupt_Number_To_Vector + (intNum : int) return Interrupt_Vector; + pragma Convention (C, Interrupt_Number_To_Vector); + + function semDelete (Sem : SEM_ID) return int; + pragma Convention (C, semDelete); + + function Task_Cont (tid : t_id) return int; + pragma Import (C, Task_Cont, "taskResume"); + + function Task_Stop (tid : t_id) return int; + pragma Import (C, Task_Stop, "taskSuspend"); + + function kill (pid : t_id; sig : int) return int; + pragma Import (C, kill, "taskKill"); + + function getpid return t_id; + pragma Import (C, getpid, "getpid"); + + function Set_Time_Slice (ticks : int) return int; + pragma Inline (Set_Time_Slice); + + -------------------------------- + -- Processor Affinity for SMP -- + -------------------------------- + + function taskCpuAffinitySet (tid : t_id; CPU : int) return int; + pragma Convention (C, taskCpuAffinitySet); + -- For SMP run-times set the CPU affinity. + -- For uniprocessor systems return ERROR status. + +end System.VxWorks.Ext; diff --git a/gcc/ada/s-vxwext.adb b/gcc/ada/s-vxwext.adb new file mode 100644 index 000000000..710ff271a --- /dev/null +++ b/gcc/ada/s-vxwext.adb @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . V X W O R K S . E X T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 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 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VxWorks 5 and VxWorks MILS version of this package + +package body System.VxWorks.Ext is + + ERROR : constant := -1; + + ------------------------ + -- taskCpuAffinitySet -- + ------------------------ + + function taskCpuAffinitySet (tid : t_id; CPU : int) return int is + pragma Unreferenced (tid, CPU); + begin + return ERROR; + end taskCpuAffinitySet; + +end System.VxWorks.Ext; diff --git a/gcc/ada/s-vxwext.ads b/gcc/ada/s-vxwext.ads new file mode 100644 index 000000000..f39ccbf3f --- /dev/null +++ b/gcc/ada/s-vxwext.ads @@ -0,0 +1,99 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . V X W O R K S . E X T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2008-2010, 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 -- +-- . -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides vxworks specific support functions needed +-- by System.OS_Interface. + +-- This is the VxWorks 5 and VxWorks MILS version of this package + +with Interfaces.C; + +package System.VxWorks.Ext is + pragma Preelaborate; + + subtype SEM_ID is Long_Integer; + -- typedef struct semaphore *SEM_ID; + + type sigset_t is mod 2 ** Interfaces.C.long'Size; + + type t_id is new Long_Integer; + + subtype int is Interfaces.C.int; + + type Interrupt_Handler is access procedure (parameter : System.Address); + pragma Convention (C, Interrupt_Handler); + + type Interrupt_Vector is new System.Address; + + function Int_Lock return int; + pragma Import (C, Int_Lock, "intLock"); + + function Int_Unlock return int; + pragma Import (C, Int_Unlock, "intUnlock"); + + function Interrupt_Connect + (Vector : Interrupt_Vector; + Handler : Interrupt_Handler; + Parameter : System.Address := System.Null_Address) return int; + pragma Import (C, Interrupt_Connect, "intConnect"); + + function Interrupt_Context return int; + pragma Import (C, Interrupt_Context, "intContext"); + + function Interrupt_Number_To_Vector + (intNum : int) return Interrupt_Vector; + pragma Import (C, Interrupt_Number_To_Vector, "__gnat_inum_to_ivec"); + + function semDelete (Sem : SEM_ID) return int; + pragma Import (C, semDelete, "semDelete"); + + function Task_Cont (tid : t_id) return int; + pragma Import (C, Task_Cont, "taskResume"); + + function Task_Stop (tid : t_id) return int; + pragma Import (C, Task_Stop, "taskSuspend"); + + function kill (pid : t_id; sig : int) return int; + pragma Import (C, kill, "kill"); + + function getpid return t_id; + pragma Import (C, getpid, "taskIdSelf"); + + function Set_Time_Slice (ticks : int) return int; + pragma Import (C, Set_Time_Slice, "kernelTimeSlice"); + + -------------------------------- + -- Processor Affinity for SMP -- + -------------------------------- + + function taskCpuAffinitySet (tid : t_id; CPU : int) return int; + pragma Convention (C, taskCpuAffinitySet); + -- For SMP run-times set the CPU affinity. + -- For uniprocessor systems return ERROR status. + +end System.VxWorks.Ext; diff --git a/gcc/ada/s-vxwork-arm.ads b/gcc/ada/s-vxwork-arm.ads new file mode 100644 index 000000000..1aa6670e1 --- /dev/null +++ b/gcc/ada/s-vxwork-arm.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . V X W O R K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the ARM VxWorks version of this package + +package System.VxWorks is + pragma Preelaborate (System.VxWorks); + + -- Floating point context record. ARM version + + -- The record definition below matches what arch/arm/fppArmLib.h says + + type FP_CONTEXT is record + Dummy : Integer; + end record; + + for FP_CONTEXT'Alignment use 4; + pragma Convention (C, FP_CONTEXT); + + Num_HW_Interrupts : constant := 256; + -- Number of entries in hardware interrupt vector table + +end System.VxWorks; diff --git a/gcc/ada/s-vxwork-m68k.ads b/gcc/ada/s-vxwork-m68k.ads new file mode 100644 index 000000000..678ca5ae7 --- /dev/null +++ b/gcc/ada/s-vxwork-m68k.ads @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . V X W O R K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the M68K VxWorks version of this package + +with Interfaces.C; + +package System.VxWorks is + pragma Preelaborate; + + package IC renames Interfaces.C; + + -- Floating point context record. 68K version + + FP_NUM_DREGS : constant := 8; + FP_STATE_FRAME_SIZE : constant := 216; + + type DOUBLEX is array (1 .. 12) of Interfaces.Unsigned_8; + pragma Pack (DOUBLEX); + for DOUBLEX'Size use 12 * 8; + + type DOUBLEX_Array is array (1 .. FP_NUM_DREGS) of DOUBLEX; + pragma Pack (DOUBLEX_Array); + for DOUBLEX_Array'Size use FP_NUM_DREGS * 12 * 8; + + type FPREG_SET is record + fpcr : IC.int; + fpsr : IC.int; + fpiar : IC.int; + fpx : DOUBLEX_Array; + end record; + + type Fp_State_Frame_Array is array (1 .. FP_STATE_FRAME_SIZE) of IC.char; + pragma Pack (Fp_State_Frame_Array); + for Fp_State_Frame_Array'Size use 8 * FP_STATE_FRAME_SIZE; + + type FP_CONTEXT is record + fpRegSet : FPREG_SET; + stateFrame : Fp_State_Frame_Array; + end record; + pragma Convention (C, FP_CONTEXT); + + Num_HW_Interrupts : constant := 256; + -- Number of entries in the hardware interrupt vector table + +end System.VxWorks; diff --git a/gcc/ada/s-vxwork-mips.ads b/gcc/ada/s-vxwork-mips.ads new file mode 100644 index 000000000..002087132 --- /dev/null +++ b/gcc/ada/s-vxwork-mips.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . V X W O R K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the MIPS VxWorks version of this package + +with Interfaces.C; + +package System.VxWorks is + pragma Preelaborate; + + package IC renames Interfaces.C; + + -- Floating point context record. MIPS version + + FP_NUM_DREGS : constant := 16; + type Fpx_Array is array (1 .. FP_NUM_DREGS) of IC.double; + + type FP_CONTEXT is record + fpx : Fpx_Array; + fpcsr : IC.int; + end record; + pragma Convention (C, FP_CONTEXT); + + Num_HW_Interrupts : constant := 256; + -- Number of entries in hardware interrupt vector table + +end System.VxWorks; diff --git a/gcc/ada/s-vxwork-ppc.ads b/gcc/ada/s-vxwork-ppc.ads new file mode 100644 index 000000000..810e3bfa7 --- /dev/null +++ b/gcc/ada/s-vxwork-ppc.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . V X W O R K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the PPC VxWorks version of this package + +with Interfaces.C; + +package System.VxWorks is + pragma Preelaborate; + + package IC renames Interfaces.C; + + -- Floating point context record. PPC version + + FP_NUM_DREGS : constant := 32; + type Fpr_Array is array (1 .. FP_NUM_DREGS) of IC.double; + + type FP_CONTEXT is record + fpr : Fpr_Array; + fpcsr : IC.int; + pad : IC.int; + end record; + pragma Convention (C, FP_CONTEXT); + + Num_HW_Interrupts : constant := 256; + +end System.VxWorks; diff --git a/gcc/ada/s-vxwork-sparcv9.ads b/gcc/ada/s-vxwork-sparcv9.ads new file mode 100644 index 000000000..a67c2d656 --- /dev/null +++ b/gcc/ada/s-vxwork-sparcv9.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . V X W O R K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Sparc64 VxWorks version of this package + +with Interfaces; + +package System.VxWorks is + pragma Preelaborate; + + -- Floating point context record. SPARCV9 version + + FP_NUM_DREGS : constant := 32; + + type RType is new Interfaces.Unsigned_64; + for RType'Alignment use 8; + + type Fpd_Array is array (1 .. FP_NUM_DREGS) of RType; + for Fpd_Array'Alignment use 8; + + type FP_CONTEXT is record + fpd : Fpd_Array; + fsr : RType; + end record; + + for FP_CONTEXT'Alignment use 8; + pragma Convention (C, FP_CONTEXT); + + Num_HW_Interrupts : constant := 256; + -- Number of entries in hardware interrupt vector table + +end System.VxWorks; diff --git a/gcc/ada/s-vxwork-x86.ads b/gcc/ada/s-vxwork-x86.ads new file mode 100644 index 000000000..566b71b5c --- /dev/null +++ b/gcc/ada/s-vxwork-x86.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . V X W O R K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2009 Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the x86 VxWorks version of this package + +package System.VxWorks is + pragma Preelaborate; + + -- Floating point context record. x86 version + + -- There are two kinds of FP_CONTEXT for this architecture, corresponding + -- to newer and older processors. The type is defined in fppI86lib.h as a + -- union. The form used depends on the versions of the save and restore + -- routines that are selected by the user (these versions are provided in + -- vxwork.ads). Since we do not examine the contents of these objects, it + -- is sufficient to declare the type as of the required size: 512 bytes. + + type FP_CONTEXT is array (1 .. 128) of Integer; + for FP_CONTEXT'Alignment use 4; + for FP_CONTEXT'Size use 512 * Storage_Unit; + pragma Convention (C, FP_CONTEXT); + + Num_HW_Interrupts : constant := 256; + -- Number of entries in hardware interrupt vector table + +end System.VxWorks; diff --git a/gcc/ada/s-wchcnv.adb b/gcc/ada/s-wchcnv.adb new file mode 100644 index 000000000..893232e60 --- /dev/null +++ b/gcc/ada/s-wchcnv.adb @@ -0,0 +1,468 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W C H _ C N V -- +-- -- +-- 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 Compiler_Unit; + +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_Wide + + 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 some 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 new file mode 100644 index 000000000..887e2198c --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +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 new file mode 100755 index 000000000..45585d9f7 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..1a370698c --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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; + +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 new file mode 100644 index 000000000..a005ec68d --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. 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; + +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 new file mode 100644 index 000000000..b91839704 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +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 new file mode 100644 index 000000000..e50f4c2f6 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..7445c59e9 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..4902a7f48 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..56914e64c --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..a6e46633a --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..9aa465b25 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..c8fd29957 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..cfea76416 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..08731427e --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..3cdb532dc --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..4d0aa3a5e --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..bbc3f03e3 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..8f30f80fb --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..7f1fd5dde --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..5d9df7bf7 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..244db8665 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..37a6f3d60 --- /dev/null +++ b/gcc/ada/s-win32.ads @@ -0,0 +1,316 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I N 3 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2008-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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.Win33.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 Operations.Clock) + + 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; + + FALSE : constant := 0; + TRUE : constant := 1; + + 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#; + + 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"); + +end System.Win32; diff --git a/gcc/ada/s-winext.ads b/gcc/ada/s-winext.ads new file mode 100644 index 000000000..22a7ab29b --- /dev/null +++ b/gcc/ada/s-winext.ads @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------ +-- -- +-- 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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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"); + + -------------- + -- 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 new file mode 100644 index 000000000..d7f40e35e --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..04f171dda --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..5006ec516 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, 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 new file mode 100644 index 000000000..c80cc4b11 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 new file mode 100644 index 000000000..001680ef5 --- /dev/null +++ b/gcc/ada/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-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If 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 new file mode 100644 index 000000000..af42232be --- /dev/null +++ b/gcc/ada/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-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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/scans.adb b/gcc/ada/scans.adb new file mode 100644 index 000000000..7f6b808a5 --- /dev/null +++ b/gcc/ada/scans.adb @@ -0,0 +1,187 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S C A N 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 Snames; use Snames; + +package body Scans is + + ----------------------------- + -- Initialize_Ada_Keywords -- + ----------------------------- + + procedure Initialize_Ada_Keywords is + procedure Set_Reserved (N : Name_Id; T : Token_Type); + pragma Inline (Set_Reserved); + -- Set given name as a reserved word (T is the corresponding token) + + ------------------ + -- Set_Reserved -- + ------------------ + + procedure Set_Reserved (N : Name_Id; T : Token_Type) is + begin + -- Set up Token_Type values in Names table entries for reserved + -- words. We use the Pos value of the Token_Type value. Note that + -- Is_Keyword_Name relies on the fact that Token_Type'Val (0) is not + -- a reserved word! + + Set_Name_Table_Byte (N, Token_Type'Pos (T)); + end Set_Reserved; + + -- Start of processing for Initialize_Ada_Keywords + + begin + -- Establish reserved words + + Set_Reserved (Name_Abort, Tok_Abort); + Set_Reserved (Name_Abs, Tok_Abs); + Set_Reserved (Name_Abstract, Tok_Abstract); + Set_Reserved (Name_Accept, Tok_Accept); + Set_Reserved (Name_Access, Tok_Access); + Set_Reserved (Name_And, Tok_And); + Set_Reserved (Name_Aliased, Tok_Aliased); + Set_Reserved (Name_All, Tok_All); + Set_Reserved (Name_Array, Tok_Array); + Set_Reserved (Name_At, Tok_At); + Set_Reserved (Name_Begin, Tok_Begin); + Set_Reserved (Name_Body, Tok_Body); + Set_Reserved (Name_Case, Tok_Case); + Set_Reserved (Name_Constant, Tok_Constant); + Set_Reserved (Name_Declare, Tok_Declare); + Set_Reserved (Name_Delay, Tok_Delay); + Set_Reserved (Name_Delta, Tok_Delta); + Set_Reserved (Name_Digits, Tok_Digits); + Set_Reserved (Name_Do, Tok_Do); + Set_Reserved (Name_Else, Tok_Else); + Set_Reserved (Name_Elsif, Tok_Elsif); + Set_Reserved (Name_End, Tok_End); + Set_Reserved (Name_Entry, Tok_Entry); + Set_Reserved (Name_Exception, Tok_Exception); + Set_Reserved (Name_Exit, Tok_Exit); + Set_Reserved (Name_For, Tok_For); + Set_Reserved (Name_Function, Tok_Function); + Set_Reserved (Name_Generic, Tok_Generic); + Set_Reserved (Name_Goto, Tok_Goto); + Set_Reserved (Name_If, Tok_If); + Set_Reserved (Name_In, Tok_In); + Set_Reserved (Name_Is, Tok_Is); + Set_Reserved (Name_Limited, Tok_Limited); + Set_Reserved (Name_Loop, Tok_Loop); + Set_Reserved (Name_Mod, Tok_Mod); + Set_Reserved (Name_New, Tok_New); + Set_Reserved (Name_Not, Tok_Not); + Set_Reserved (Name_Null, Tok_Null); + Set_Reserved (Name_Of, Tok_Of); + Set_Reserved (Name_Or, Tok_Or); + Set_Reserved (Name_Others, Tok_Others); + Set_Reserved (Name_Out, Tok_Out); + Set_Reserved (Name_Package, Tok_Package); + Set_Reserved (Name_Pragma, Tok_Pragma); + Set_Reserved (Name_Private, Tok_Private); + Set_Reserved (Name_Procedure, Tok_Procedure); + Set_Reserved (Name_Protected, Tok_Protected); + Set_Reserved (Name_Raise, Tok_Raise); + Set_Reserved (Name_Range, Tok_Range); + Set_Reserved (Name_Record, Tok_Record); + Set_Reserved (Name_Rem, Tok_Rem); + Set_Reserved (Name_Renames, Tok_Renames); + Set_Reserved (Name_Requeue, Tok_Requeue); + Set_Reserved (Name_Return, Tok_Return); + Set_Reserved (Name_Reverse, Tok_Reverse); + Set_Reserved (Name_Select, Tok_Select); + Set_Reserved (Name_Separate, Tok_Separate); + + -- We choose to make Some into a non-reserved word, so it is handled + -- like a regular identifier in most contexts. Uncomment the following + -- line if a pedantic Ada2012 mode is required. + + -- Set_Reserved (Name_Some, Tok_Some); + + Set_Reserved (Name_Subtype, Tok_Subtype); + Set_Reserved (Name_Tagged, Tok_Tagged); + Set_Reserved (Name_Task, Tok_Task); + Set_Reserved (Name_Terminate, Tok_Terminate); + Set_Reserved (Name_Then, Tok_Then); + Set_Reserved (Name_Type, Tok_Type); + Set_Reserved (Name_Until, Tok_Until); + Set_Reserved (Name_Use, Tok_Use); + Set_Reserved (Name_When, Tok_When); + Set_Reserved (Name_While, Tok_While); + Set_Reserved (Name_With, Tok_With); + Set_Reserved (Name_Xor, Tok_Xor); + + -- Ada 2005 reserved words + + Set_Reserved (Name_Interface, Tok_Interface); + Set_Reserved (Name_Overriding, Tok_Overriding); + Set_Reserved (Name_Synchronized, Tok_Synchronized); + + end Initialize_Ada_Keywords; + + ------------------------ + -- Restore_Scan_State -- + ------------------------ + + procedure Restore_Scan_State (Saved_State : Saved_Scan_State) is + begin + Scan_Ptr := Saved_State.Save_Scan_Ptr; + Token := Saved_State.Save_Token; + Token_Ptr := Saved_State.Save_Token_Ptr; + Current_Line_Start := Saved_State.Save_Current_Line_Start; + Start_Column := Saved_State.Save_Start_Column; + Checksum := Saved_State.Save_Checksum; + First_Non_Blank_Location := Saved_State.Save_First_Non_Blank_Location; + Token_Node := Saved_State.Save_Token_Node; + Token_Name := Saved_State.Save_Token_Name; + Prev_Token := Saved_State.Save_Prev_Token; + Prev_Token_Ptr := Saved_State.Save_Prev_Token_Ptr; + end Restore_Scan_State; + + --------------------- + -- Save_Scan_State -- + --------------------- + + procedure Save_Scan_State (Saved_State : out Saved_Scan_State) is + begin + Saved_State.Save_Scan_Ptr := Scan_Ptr; + Saved_State.Save_Token := Token; + Saved_State.Save_Token_Ptr := Token_Ptr; + Saved_State.Save_Current_Line_Start := Current_Line_Start; + Saved_State.Save_Start_Column := Start_Column; + Saved_State.Save_Checksum := Checksum; + Saved_State.Save_First_Non_Blank_Location := First_Non_Blank_Location; + Saved_State.Save_Token_Node := Token_Node; + Saved_State.Save_Token_Name := Token_Name; + Saved_State.Save_Prev_Token := Prev_Token; + Saved_State.Save_Prev_Token_Ptr := Prev_Token_Ptr; + end Save_Scan_State; + +end Scans; diff --git a/gcc/ada/scans.ads b/gcc/ada/scans.ads new file mode 100644 index 000000000..fcf474bc8 --- /dev/null +++ b/gcc/ada/scans.ads @@ -0,0 +1,503 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S C A N S -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with Namet; use Namet; +with Types; use Types; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package Scans is + +-- The scanner maintains a current state in the global variables defined +-- in this package. The call to the Scan routine advances this state to +-- the next token. The state is initialized by the call to one of the +-- initialization routines in Sinput. + + -- The following type is used to identify token types returned by Scan. + -- The class column in this table indicates the token classes which + -- apply to the token, as defined by subsequent subtype declarations. + + -- Note: Namet.Is_Keyword_Name depends on the fact that the first entry in + -- this type declaration is *not* for a reserved word. For details on why + -- there is this requirement, see Scans.Initialize_Ada_Keywords. + + type Token_Type is ( + + -- Token name Token type Class(es) + + Tok_Integer_Literal, -- numeric lit Literal, Lit_Or_Name + + Tok_Real_Literal, -- numeric lit Literal, Lit_Or_Name + + Tok_String_Literal, -- string lit Literal. Lit_Or_Name + + Tok_Char_Literal, -- char lit Name, Literal. Lit_Or_Name + + Tok_Operator_Symbol, -- op symbol Name, Literal, Lit_Or_Name, Desig + + Tok_Identifier, -- identifier Name, Lit_Or_Name, Desig + + Tok_Double_Asterisk, -- ** + + Tok_Ampersand, -- & Binary_Addop + Tok_Minus, -- - Binary_Addop, Unary_Addop + Tok_Plus, -- + Binary_Addop, Unary_Addop + + Tok_Asterisk, -- * Mulop + Tok_Mod, -- MOD Mulop + Tok_Rem, -- REM Mulop + Tok_Slash, -- / Mulop + + Tok_New, -- NEW + + Tok_Abs, -- ABS + Tok_Others, -- OTHERS + Tok_Null, -- NULL + + Tok_Dot, -- . Namext + Tok_Apostrophe, -- ' Namext + + Tok_Left_Paren, -- ( Namext, Consk + + Tok_Delta, -- DELTA Atkwd, Sterm, Consk + Tok_Digits, -- DIGITS Atkwd, Sterm, Consk + Tok_Range, -- RANGE Atkwd, Sterm, Consk + + Tok_Right_Paren, -- ) Sterm + Tok_Comma, -- , Sterm + + Tok_And, -- AND Logop, Sterm + Tok_Or, -- OR Logop, Sterm + Tok_Xor, -- XOR Logop, Sterm + + Tok_Less, -- < Relop, Sterm + Tok_Equal, -- = Relop, Sterm + Tok_Greater, -- > Relop, Sterm + Tok_Not_Equal, -- /= Relop, Sterm + Tok_Greater_Equal, -- >= Relop, Sterm + Tok_Less_Equal, -- <= Relop, Sterm + + Tok_In, -- IN Relop, Sterm + Tok_Not, -- NOT Relop, Sterm + + Tok_Box, -- <> Relop, Eterm, Sterm + Tok_Colon_Equal, -- := Eterm, Sterm + Tok_Colon, -- : Eterm, Sterm + Tok_Greater_Greater, -- >> Eterm, Sterm + + Tok_Abstract, -- ABSTRACT Eterm, Sterm + Tok_Access, -- ACCESS Eterm, Sterm + Tok_Aliased, -- ALIASED Eterm, Sterm + Tok_All, -- ALL Eterm, Sterm + Tok_Array, -- ARRAY Eterm, Sterm + Tok_At, -- AT Eterm, Sterm + Tok_Body, -- BODY Eterm, Sterm + Tok_Constant, -- CONSTANT Eterm, Sterm + Tok_Do, -- DO Eterm, Sterm + Tok_Is, -- IS Eterm, Sterm + Tok_Interface, -- INTERFACE Eterm, Sterm + Tok_Limited, -- LIMITED Eterm, Sterm + Tok_Of, -- OF Eterm, Sterm + Tok_Out, -- OUT Eterm, Sterm + Tok_Record, -- RECORD Eterm, Sterm + Tok_Renames, -- RENAMES Eterm, Sterm + Tok_Reverse, -- REVERSE Eterm, Sterm + Tok_Some, -- SOME Eterm, Sterm + Tok_Tagged, -- TAGGED Eterm, Sterm + Tok_Then, -- THEN Eterm, Sterm + + Tok_Less_Less, -- << Eterm, Sterm, After_SM + + Tok_Abort, -- ABORT Eterm, Sterm, After_SM + Tok_Accept, -- ACCEPT Eterm, Sterm, After_SM + Tok_Case, -- CASE Eterm, Sterm, After_SM + Tok_Delay, -- DELAY Eterm, Sterm, After_SM + Tok_Else, -- ELSE Eterm, Sterm, After_SM + Tok_Elsif, -- ELSIF Eterm, Sterm, After_SM + Tok_End, -- END Eterm, Sterm, After_SM + Tok_Exception, -- EXCEPTION Eterm, Sterm, After_SM + Tok_Exit, -- EXIT Eterm, Sterm, After_SM + Tok_Goto, -- GOTO Eterm, Sterm, After_SM + Tok_If, -- IF Eterm, Sterm, After_SM + Tok_Pragma, -- PRAGMA Eterm, Sterm, After_SM + Tok_Raise, -- RAISE Eterm, Sterm, After_SM + Tok_Requeue, -- REQUEUE Eterm, Sterm, After_SM + Tok_Return, -- RETURN Eterm, Sterm, After_SM + Tok_Select, -- SELECT Eterm, Sterm, After_SM + Tok_Terminate, -- TERMINATE Eterm, Sterm, After_SM + Tok_Until, -- UNTIL Eterm, Sterm, After_SM + Tok_When, -- WHEN Eterm, Sterm, After_SM + + Tok_Begin, -- BEGIN Eterm, Sterm, After_SM, Labeled_Stmt + Tok_Declare, -- DECLARE Eterm, Sterm, After_SM, Labeled_Stmt + Tok_For, -- FOR Eterm, Sterm, After_SM, Labeled_Stmt + Tok_Loop, -- LOOP Eterm, Sterm, After_SM, Labeled_Stmt + Tok_While, -- WHILE Eterm, Sterm, After_SM, Labeled_Stmt + + Tok_Entry, -- ENTRY Eterm, Sterm, Declk, Deckn, After_SM + Tok_Protected, -- PROTECTED Eterm, Sterm, Declk, Deckn, After_SM + Tok_Task, -- TASK Eterm, Sterm, Declk, Deckn, After_SM + Tok_Type, -- TYPE Eterm, Sterm, Declk, Deckn, After_SM + Tok_Subtype, -- SUBTYPE Eterm, Sterm, Declk, Deckn, After_SM + Tok_Overriding, -- OVERRIDING Eterm, Sterm, Declk, Declk, After_SM + Tok_Synchronized, -- SYNCHRONIZED Eterm, Sterm, Declk, Deckn, After_SM + Tok_Use, -- USE Eterm, Sterm, Declk, Deckn, After_SM + + Tok_Function, -- FUNCTION Eterm, Sterm, Cunit, Declk, After_SM + Tok_Generic, -- GENERIC Eterm, Sterm, Cunit, Declk, After_SM + Tok_Package, -- PACKAGE Eterm, Sterm, Cunit, Declk, After_SM + Tok_Procedure, -- PROCEDURE Eterm, Sterm, Cunit, Declk, After_SM + + Tok_Private, -- PRIVATE Eterm, Sterm, Cunit, After_SM + Tok_With, -- WITH Eterm, Sterm, Cunit, After_SM + Tok_Separate, -- SEPARATE Eterm, Sterm, Cunit, After_SM + + Tok_EOF, -- End of file Eterm, Sterm, Cterm, After_SM + + Tok_Semicolon, -- ; Eterm, Sterm, Cterm + + Tok_Arrow, -- => Sterm, Cterm, Chtok + + Tok_Vertical_Bar, -- | Cterm, Sterm, Chtok + + Tok_Dot_Dot, -- .. Sterm, Chtok + + Tok_Project, + Tok_Extends, + Tok_External, + Tok_External_As_List, + -- These four entries represent keywords for the project file language + -- and can be returned only in the case of scanning project files. + + Tok_Comment, + -- This entry is used when scanning project files (where it represents + -- an entire comment), and in preprocessing with the -C switch set + -- (where it represents just the "--" of a comment). For the project + -- file case, the text of the comment is stored in + + Tok_End_Of_Line, + -- Represents an end of line. Not used during normal compilation scans + -- where end of line is ignored. Active for preprocessor scanning and + -- also when scanning project files (where it is needed because of ???) + + Tok_Special, + -- Used only in preprocessor scanning (to represent one of the + -- characters '#', '$', '?', '@', '`', '\', '^', '~', or '_'. The + -- character value itself is stored in Scans.Special_Character. + + No_Token); + -- No_Token is used for initializing Token values to indicate that + -- no value has been set yet. + + -- Note: in the RM, operator symbol is a special case of string literal. + -- We distinguish at the lexical level in this compiler, since there are + -- many syntactic situations in which only an operator symbol is allowed. + + -- The following subtype declarations group the token types into classes. + -- These are used for class tests in the parser. + + subtype Token_Class_Numeric_Literal is + Token_Type range Tok_Integer_Literal .. Tok_Real_Literal; + -- Numeric literal + + subtype Token_Class_Literal is + Token_Type range Tok_Integer_Literal .. Tok_Operator_Symbol; + -- Literal + + subtype Token_Class_Lit_Or_Name is + Token_Type range Tok_Integer_Literal .. Tok_Identifier; + + subtype Token_Class_Binary_Addop is + Token_Type range Tok_Ampersand .. Tok_Plus; + -- Binary adding operator (& + -) + + subtype Token_Class_Unary_Addop is + Token_Type range Tok_Minus .. Tok_Plus; + -- Unary adding operator (+ -) + + subtype Token_Class_Mulop is + Token_Type range Tok_Asterisk .. Tok_Slash; + -- Multiplying operator + + subtype Token_Class_Logop is + Token_Type range Tok_And .. Tok_Xor; + -- Logical operator (and, or, xor) + + subtype Token_Class_Relop is + Token_Type range Tok_Less .. Tok_Box; + -- Relational operator (= /= < <= > >= not, in plus <> to catch misuse + -- of Pascal style not equal operator). + + subtype Token_Class_Name is + Token_Type range Tok_Char_Literal .. Tok_Identifier; + -- First token of name (4.1), + -- (identifier, char literal, operator symbol) + + subtype Token_Class_Desig is + Token_Type range Tok_Operator_Symbol .. Tok_Identifier; + -- Token which can be a Designator (identifier, operator symbol) + + subtype Token_Class_Namext is + Token_Type range Tok_Dot .. Tok_Left_Paren; + -- Name extension tokens. These are tokens which can appear immediately + -- after a name to extend it recursively (period, quote, left paren) + + subtype Token_Class_Consk is + Token_Type range Tok_Left_Paren .. Tok_Range; + -- Keywords which can start constraint + -- (left paren, delta, digits, range) + + subtype Token_Class_Eterm is + Token_Type range Tok_Colon_Equal .. Tok_Semicolon; + -- Expression terminators. These tokens can never appear within a simple + -- expression. This is used for error recovery purposes (if we encounter + -- an error in an expression, we simply scan to the next Eterm token). + + subtype Token_Class_Sterm is + Token_Type range Tok_Delta .. Tok_Dot_Dot; + -- Simple_Expression terminators. A Simple_Expression must be followed + -- by a token in this class, or an error message is issued complaining + -- about a missing binary operator. + + subtype Token_Class_Atkwd is + Token_Type range Tok_Delta .. Tok_Range; + -- Attribute keywords. This class includes keywords which can be used + -- as an Attribute_Designator, namely DELTA, DIGITS and RANGE + + subtype Token_Class_Cterm is + Token_Type range Tok_EOF .. Tok_Vertical_Bar; + -- Choice terminators. These tokens terminate a choice. This is used for + -- error recovery purposes (if we encounter an error in a Choice, we + -- simply scan to the next Cterm token). + + subtype Token_Class_Chtok is + Token_Type range Tok_Arrow .. Tok_Dot_Dot; + -- Choice tokens. These tokens signal a choice when used in an Aggregate + + subtype Token_Class_Cunit is + Token_Type range Tok_Function .. Tok_Separate; + -- Tokens which can begin a compilation unit + + subtype Token_Class_Declk is + Token_Type range Tok_Entry .. Tok_Procedure; + -- Keywords which start a declaration + + subtype Token_Class_Deckn is + Token_Type range Tok_Entry .. Tok_Use; + -- Keywords which start a declaration but can't start a compilation unit + + subtype Token_Class_After_SM is + Token_Type range Tok_Less_Less .. Tok_EOF; + -- Tokens which always, or almost always, appear after a semicolon. Used + -- in the Resync_Past_Semicolon routine to avoid gobbling up stuff when + -- a semicolon is missing. Of significance only for error recovery. + + subtype Token_Class_Labeled_Stmt is + Token_Type range Tok_Begin .. Tok_While; + -- Tokens which start labeled statements + + type Token_Flag_Array is array (Token_Type) of Boolean; + Is_Reserved_Keyword : constant Token_Flag_Array := + Token_Flag_Array' + (Tok_Mod .. Tok_Rem => True, + Tok_New .. Tok_Null => True, + Tok_Delta .. Tok_Range => True, + Tok_And .. Tok_Xor => True, + Tok_In .. Tok_Not => True, + Tok_Abstract .. Tok_Then => True, + Tok_Abort .. Tok_Separate => True, + others => False); + -- Flag array used to test for reserved word + + procedure Initialize_Ada_Keywords; + -- Set up Token_Type values in Names table entries for Ada reserved words + + -------------------------- + -- Scan State Variables -- + -------------------------- + + -- Note: these variables can only be referenced during the parsing of a + -- file. Reference to any of them from Sem or the expander is wrong. + + -- These variables are initialized as required by Scn.Initialize_Scanner, + -- and should not be referenced before such a call. However, there are + -- situations in which these variables are saved and restored, and this + -- may happen before the first Initialize_Scanner call, resulting in the + -- assignment of invalid values. To avoid this, and allow building with + -- the -gnatVa switch, we initialize some variables to known valid values. + + Scan_Ptr : Source_Ptr := No_Location; -- init for -gnatVa + -- Current scan pointer location. After a call to Scan, this points + -- just past the end of the token just scanned. + + Token : Token_Type := No_Token; -- init for -gnatVa + -- Type of current token + + Token_Ptr : Source_Ptr := No_Location; -- init for -gnatVa + -- Pointer to first character of current token + + Current_Line_Start : Source_Ptr := No_Location; -- init for -gnatVa + -- Pointer to first character of line containing current token + + Start_Column : Column_Number := No_Column_Number; -- init for -gnatVa + -- Starting column number (zero origin) of the first non-blank character + -- on the line containing the current token. This is used for error + -- recovery circuits which depend on looking at the column line up. + + Type_Token_Location : Source_Ptr := No_Location; -- init for -gnatVa + -- Within a type declaration, gives the location of the TYPE keyword that + -- opened the type declaration. Used in checking the end column of a record + -- declaration, which can line up either with the TYPE keyword, or with the + -- start of the line containing the RECORD keyword. + + Checksum : Word := 0; -- init for -gnatVa + -- Used to accumulate a CRC representing the tokens in the source + -- file being compiled. This CRC includes only program tokens, and + -- excludes comments. + + First_Non_Blank_Location : Source_Ptr := No_Location; -- init for -gnatVa + -- Location of first non-blank character on the line containing the + -- current token (i.e. the location of the character whose column number + -- is stored in Start_Column). + + Token_Node : Node_Id := Empty; + -- Node table Id for the current token. This is set only if the current + -- token is one for which the scanner constructs a node (i.e. it is an + -- identifier, operator symbol, or literal. For other token types, + -- Token_Node is undefined. + + Token_Name : Name_Id := No_Name; + -- For identifiers, this is set to the Name_Id of the identifier scanned. + -- For all other tokens, Token_Name is set to Error_Name. Note that it + -- would be possible for the caller to extract this information from + -- Token_Node. We set Token_Name separately for two reasons. First it + -- allows a quicker test for a specific identifier. Second, it allows + -- a version of the parser to be built that does not build tree nodes, + -- usable as a syntax checker. + + Prev_Token : Token_Type := No_Token; + -- Type of previous token + + Prev_Token_Ptr : Source_Ptr; + -- Pointer to first character of previous token + + Version_To_Be_Found : Boolean; + -- This flag is True if the scanner is still looking for an RCS version + -- number in a comment. Normally it is initialized to False so that this + -- circuit is not activated. If the -dv switch is set, then this flag is + -- initialized to True, and then reset when the version number is found. + -- We do things this way to minimize the impact on comment scanning. + + Character_Code : Char_Code; + -- Valid only when Token is Tok_Char_Literal. Contains the value of the + -- scanned literal. + + Real_Literal_Value : Ureal; + -- Valid only when Token is Tok_Real_Literal, contains the value of the + -- scanned literal. + + Int_Literal_Value : Uint; + -- Valid only when Token = Tok_Integer_Literal, contains the value of the + -- scanned literal. + + Based_Literal_Uses_Colon : Boolean; + -- Valid only when Token = Tok_Integer_Literal or Tok_Real_Literal. Set + -- True only for the case of a based literal using ':' instead of '#'. + + String_Literal_Id : String_Id; + -- Valid only when Token = Tok_String_Literal or Tok_Operator_Symbol. + -- Contains the Id for currently scanned string value. + + Wide_Character_Found : Boolean := False; + -- Valid only when Token = Tok_String_Literal. Set True if wide character + -- found (i.e. a character that does not fit in Character, but fits in + -- Wide_Wide_Character). + + Wide_Wide_Character_Found : Boolean := False; + -- Valid only when Token = Tok_String_Literal. Set True if wide wide + -- character found (i.e. a character that does not fit in Character or + -- Wide_Character). + + Special_Character : Character; + -- Valid only when Token = Tok_Special. Returns one of the characters + -- '#', '$', '?', '@', '`', '\', '^', '~', or '_'. + -- + -- Why only this set? What about wide characters??? + + Comment_Id : Name_Id := No_Name; + -- Valid only when Token = Tok_Comment. Store the string that follows + -- the "--" of a comment when scanning project files. + -- + -- Is it really right for this to be a Name rather than a String, what + -- about the case of Wide_Wide_Characters??? + + Inside_Conditional_Expression : Nat := 0; + -- This is a counter that is set non-zero while scanning out a conditional + -- expression (incremented on entry, decremented on exit). It is used to + -- disconnect format checks that normally apply to keywords THEN, ELSE etc. + + -------------------------------------------------------- + -- Procedures for Saving and Restoring the Scan State -- + -------------------------------------------------------- + + -- The following procedures can be used to save and restore the entire + -- scan state. They are used in cases where it is necessary to backup + -- the scan during the parse. + + type Saved_Scan_State is private; + -- Used for saving and restoring the scan state + + procedure Save_Scan_State (Saved_State : out Saved_Scan_State); + pragma Inline (Save_Scan_State); + -- Saves the current scan state for possible later restoration. Note that + -- there is no harm in saving the state and then never restoring it. + + procedure Restore_Scan_State (Saved_State : Saved_Scan_State); + pragma Inline (Restore_Scan_State); + -- Restores a scan state saved by a call to Save_Scan_State. + -- The saved scan state must refer to the current source file. + +private + type Saved_Scan_State is record + Save_Scan_Ptr : Source_Ptr; + Save_Token : Token_Type; + Save_Token_Ptr : Source_Ptr; + Save_Current_Line_Start : Source_Ptr; + Save_Start_Column : Column_Number; + Save_Checksum : Word; + Save_First_Non_Blank_Location : Source_Ptr; + Save_Token_Node : Node_Id; + Save_Token_Name : Name_Id; + Save_Prev_Token : Token_Type; + Save_Prev_Token_Ptr : Source_Ptr; + end record; + +end Scans; diff --git a/gcc/ada/scil_ll.adb b/gcc/ada/scil_ll.adb new file mode 100644 index 000000000..4591d8ef2 --- /dev/null +++ b/gcc/ada/scil_ll.adb @@ -0,0 +1,144 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S C I L _ L L -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with Alloc; use Alloc; +with Atree; use Atree; +with Opt; use Opt; +with Sinfo; use Sinfo; +with Table; + +package body SCIL_LL is + + procedure Copy_SCIL_Node (Target : Node_Id; Source : Node_Id); + -- Copy the SCIL field from Source to Target (it is used as the argument + -- for a call to Set_Reporting_Proc in package atree). + + function SCIL_Nodes_Table_Size return Pos; + -- Used to initialize the table of SCIL nodes because we do not want + -- to consume memory for this table if it is not required. + + ---------------------------- + -- SCIL_Nodes_Table_Size -- + ---------------------------- + + function SCIL_Nodes_Table_Size return Pos is + begin + if Generate_SCIL then + return Alloc.Orig_Nodes_Initial; + else + return 1; + end if; + end SCIL_Nodes_Table_Size; + + package SCIL_Nodes is new Table.Table ( + Table_Component_Type => Node_Id, + Table_Index_Type => Node_Id'Base, + Table_Low_Bound => First_Node_Id, + Table_Initial => SCIL_Nodes_Table_Size, + Table_Increment => Alloc.Orig_Nodes_Increment, + Table_Name => "SCIL_Nodes"); + -- This table records the value of attribute SCIL_Node of all the + -- tree nodes. + + -------------------- + -- Copy_SCIL_Node -- + -------------------- + + procedure Copy_SCIL_Node (Target : Node_Id; Source : Node_Id) is + begin + Set_SCIL_Node (Target, Get_SCIL_Node (Source)); + end Copy_SCIL_Node; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + SCIL_Nodes.Init; + Set_Reporting_Proc (Copy_SCIL_Node'Access); + end Initialize; + + ------------------- + -- Get_SCIL_Node -- + ------------------- + + function Get_SCIL_Node (N : Node_Id) return Node_Id is + begin + if Generate_SCIL + and then Present (N) + then + return SCIL_Nodes.Table (N); + else + return Empty; + end if; + end Get_SCIL_Node; + + ------------------- + -- Set_SCIL_Node -- + ------------------- + + procedure Set_SCIL_Node (N : Node_Id; Value : Node_Id) is + begin + pragma Assert (Generate_SCIL); + + if Present (Value) then + case Nkind (Value) is + when N_SCIL_Dispatch_Table_Tag_Init => + pragma Assert (Nkind (N) = N_Object_Declaration); + null; + + when N_SCIL_Dispatching_Call => + pragma Assert (Nkind_In (N, N_Function_Call, + N_Procedure_Call_Statement)); + null; + + when N_SCIL_Membership_Test => + pragma Assert (Nkind_In (N, N_Identifier, + N_And_Then, + N_Or_Else, + N_Expression_With_Actions)); + null; + + when others => + pragma Assert (False); + raise Program_Error; + end case; + end if; + + if Atree.Last_Node_Id > SCIL_Nodes.Last then + SCIL_Nodes.Set_Last (Atree.Last_Node_Id); + end if; + + SCIL_Nodes.Set_Item (N, Value); + end Set_SCIL_Node; + +end SCIL_LL; diff --git a/gcc/ada/scil_ll.ads b/gcc/ada/scil_ll.ads new file mode 100644 index 000000000..8265a19df --- /dev/null +++ b/gcc/ada/scil_ll.ads @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S C I L _ L L -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package extends the tree nodes with a field that is used to reference +-- the SCIL node. + +with Types; use Types; + +package SCIL_LL is + + function Get_SCIL_Node (N : Node_Id) return Node_Id; + -- Read the value of attribute SCIL node + + procedure Set_SCIL_Node (N : Node_Id; Value : Node_Id); + -- Set the value of attribute SCIL node + + procedure Initialize; + -- Initialize the table of SCIL nodes + +end SCIL_LL; diff --git a/gcc/ada/scn.adb b/gcc/ada/scn.adb new file mode 100644 index 000000000..2862a0afa --- /dev/null +++ b/gcc/ada/scn.adb @@ -0,0 +1,494 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S C N -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Csets; use Csets; +with Hostparm; use Hostparm; +with Namet; use Namet; +with Opt; use Opt; +with Output; use Output; +with Restrict; use Restrict; +with Rident; use Rident; +with Scans; use Scans; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Uintp; use Uintp; + +with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark; + +with System.WCh_Con; use System.WCh_Con; + +package body Scn is + + use ASCII; + + Used_As_Identifier : array (Token_Type) of Boolean; + -- Flags set True if a given keyword is used as an identifier (used to + -- make sure that we only post an error message for incorrect use of a + -- keyword as an identifier once for a given keyword). + + procedure Check_End_Of_Line; + -- Called when end of line encountered. Checks that line is not too long, + -- and that other style checks for the end of line are met. + + function Determine_License return License_Type; + -- Scan header of file and check that it has an appropriate GNAT-style + -- header with a proper license statement. Returns GPL, Unrestricted, + -- or Modified_GPL depending on header. If none of these, returns Unknown. + + procedure Error_Long_Line; + -- Signal error of excessively long line + + ----------------------- + -- Check_End_Of_Line -- + ----------------------- + + procedure Check_End_Of_Line is + Len : constant Int := Int (Scan_Ptr) - Int (Current_Line_Start); + begin + if Style_Check then + Style.Check_Line_Terminator (Len); + elsif Len > Max_Line_Length then + Error_Long_Line; + end if; + end Check_End_Of_Line; + + ----------------------- + -- Determine_License -- + ----------------------- + + function Determine_License return License_Type is + GPL_Found : Boolean := False; + Result : License_Type; + + function Contains (S : String) return Boolean; + -- See if current comment contains successive non-blank characters + -- matching the contents of S. If so leave Scan_Ptr unchanged and + -- return True, otherwise leave Scan_Ptr unchanged and return False. + + procedure Skip_EOL; + -- Skip to line terminator character + + -------------- + -- Contains -- + -------------- + + function Contains (S : String) return Boolean is + CP : Natural; + SP : Source_Ptr; + SS : Source_Ptr; + + begin + -- Loop to check characters. This loop is terminated by end of + -- line, and also we need to check for the EOF case, to take + -- care of files containing only comments. + + SP := Scan_Ptr; + while Source (SP) /= CR and then + Source (SP) /= LF and then + Source (SP) /= EOF + loop + if Source (SP) = S (S'First) then + SS := SP; + CP := S'First; + + loop + SS := SS + 1; + CP := CP + 1; + + if CP > S'Last then + return True; + end if; + + while Source (SS) = ' ' loop + SS := SS + 1; + end loop; + + exit when Source (SS) /= S (CP); + end loop; + end if; + + SP := SP + 1; + end loop; + + return False; + end Contains; + + -------------- + -- Skip_EOL -- + -------------- + + procedure Skip_EOL is + begin + while Source (Scan_Ptr) /= CR + and then Source (Scan_Ptr) /= LF + and then Source (Scan_Ptr) /= EOF + loop + Scan_Ptr := Scan_Ptr + 1; + end loop; + end Skip_EOL; + + -- Start of processing for Determine_License + + begin + loop + if Source (Scan_Ptr) /= '-' + or else Source (Scan_Ptr + 1) /= '-' + then + if GPL_Found then + Result := GPL; + exit; + else + Result := Unknown; + exit; + end if; + + elsif Contains ("Asaspecialexception") then + if GPL_Found then + Result := Modified_GPL; + exit; + end if; + + elsif Contains ("GNUGeneralPublicLicense") then + GPL_Found := True; + + elsif + Contains + ("ThisspecificationisadaptedfromtheAdaSemanticInterface") + or else + Contains + ("ThisspecificationisderivedfromtheAdaReferenceManual") + then + Result := Unrestricted; + exit; + end if; + + Skip_EOL; + + Check_End_Of_Line; + + if Source (Scan_Ptr) /= EOF then + + -- We have to take into account a degenerate case when the source + -- file contains only comments and no Ada code. + + declare + Physical : Boolean; + + begin + Skip_Line_Terminators (Scan_Ptr, Physical); + + -- If we are at start of physical line, update scan pointers + -- to reflect the start of the new line. + + if Physical then + Current_Line_Start := Scan_Ptr; + Start_Column := Scanner.Set_Start_Column; + First_Non_Blank_Location := Scan_Ptr; + end if; + end; + end if; + end loop; + + return Result; + end Determine_License; + + ---------------------------- + -- Determine_Token_Casing -- + ---------------------------- + + function Determine_Token_Casing return Casing_Type is + begin + return Scanner.Determine_Token_Casing; + end Determine_Token_Casing; + + --------------------- + -- Error_Long_Line -- + --------------------- + + procedure Error_Long_Line is + begin + Error_Msg + ("this line is too long", + Current_Line_Start + Source_Ptr (Max_Line_Length)); + end Error_Long_Line; + + ------------------------ + -- Initialize_Scanner -- + ------------------------ + + procedure Initialize_Scanner + (Unit : Unit_Number_Type; + Index : Source_File_Index) + is + GNAT_Hedr : constant Text_Buffer (1 .. 78) := (others => '-'); + + begin + Scanner.Initialize_Scanner (Index); + + if Index /= Internal_Source_File then + Set_Unit (Index, Unit); + end if; + + Current_Source_Unit := Unit; + + -- Set default for Comes_From_Source (except if we are going to process + -- an artificial string internally created within the compiler and + -- placed into internal source duffer). All nodes built now until we + -- reenter the analyzer will have Comes_From_Source set to True + + if Index /= Internal_Source_File then + Set_Comes_From_Source_Default (True); + end if; + + -- Check license if GNAT type header possibly present + + if Source_Last (Index) - Scan_Ptr > 80 + and then Source (Scan_Ptr .. Scan_Ptr + 77) = GNAT_Hedr + then + Set_License (Current_Source_File, Determine_License); + end if; + + -- Check for BOM + + declare + BOM : BOM_Kind; + Len : Natural; + Tst : String (1 .. 5); + + begin + for J in 1 .. 5 loop + Tst (J) := Source (Scan_Ptr + Source_Ptr (J) - 1); + end loop; + + Read_BOM (Tst, Len, BOM, False); + + case BOM is + when UTF8_All => + Scan_Ptr := Scan_Ptr + Source_Ptr (Len); + Wide_Character_Encoding_Method := WCEM_UTF8; + Upper_Half_Encoding := True; + + when UTF16_LE | UTF16_BE => + Set_Standard_Error; + Write_Line ("UTF-16 encoding format not recognized"); + Set_Standard_Output; + raise Unrecoverable_Error; + + when UTF32_LE | UTF32_BE => + Set_Standard_Error; + Write_Line ("UTF-32 encoding format not recognized"); + Set_Standard_Output; + raise Unrecoverable_Error; + + when Unknown => + null; + + when others => + raise Program_Error; + end case; + end; + + -- Because of the License stuff above, Scng.Initialize_Scanner cannot + -- call Scan. Scan initial token (note this initializes Prev_Token, + -- Prev_Token_Ptr). + + -- There are two reasons not to do the Scan step in case if we + -- initialize the scanner for the internal source buffer: + + -- - The artificial string may not be created by the compiler in this + -- buffer when we call Initialize_Scanner + + -- - For these artificial strings a special way of scanning is used, so + -- the standard step of the scanner may just break the algorithm of + -- processing these strings. + + if Index /= Internal_Source_File then + Scan; + end if; + + -- Clear flags for reserved words used as identifiers + + for J in Token_Type loop + Used_As_Identifier (J) := False; + end loop; + end Initialize_Scanner; + + --------------- + -- Post_Scan -- + --------------- + + procedure Post_Scan is + procedure Check_Obsolescent_Features_Restriction (S : Source_Ptr); + -- This checks for Obsolescent_Features restriction being active, and + -- if so, flags the restriction as occurring at the given scan location. + + procedure Check_Obsolete_Base_Char; + -- Check for numeric literal using ':' instead of '#' for based case + + -------------------------------------------- + -- Check_Obsolescent_Features_Restriction -- + -------------------------------------------- + + procedure Check_Obsolescent_Features_Restriction (S : Source_Ptr) is + begin + -- Normally we have a node handy for posting restrictions. We don't + -- have such a node here, so construct a dummy one with the right + -- scan pointer. This is only used to get the Sloc value anyway. + + Check_Restriction (No_Obsolescent_Features, New_Node (N_Empty, S)); + end Check_Obsolescent_Features_Restriction; + + ------------------------------ + -- Check_Obsolete_Base_Char -- + ------------------------------ + + procedure Check_Obsolete_Base_Char is + S : Source_Ptr; + + begin + if Based_Literal_Uses_Colon then + + -- Find the : for the restriction or warning message + + S := Token_Ptr; + while Source (S) /= ':' loop + S := S + 1; + end loop; + + Check_Obsolescent_Features_Restriction (S); + + if Warn_On_Obsolescent_Feature then + Error_Msg + ("use of "":"" is an obsolescent feature (RM J.2(3))?", S); + Error_Msg + ("\use ""'#"" instead?", S); + end if; + end if; + end Check_Obsolete_Base_Char; + + -- Start of processing for Post_Scan + + begin + case Token is + when Tok_Char_Literal => + Token_Node := New_Node (N_Character_Literal, Token_Ptr); + Set_Char_Literal_Value (Token_Node, UI_From_CC (Character_Code)); + Set_Chars (Token_Node, Token_Name); + + when Tok_Identifier => + Token_Node := New_Node (N_Identifier, Token_Ptr); + Set_Chars (Token_Node, Token_Name); + + when Tok_Real_Literal => + Token_Node := New_Node (N_Real_Literal, Token_Ptr); + Set_Realval (Token_Node, Real_Literal_Value); + Check_Obsolete_Base_Char; + + when Tok_Integer_Literal => + Token_Node := New_Node (N_Integer_Literal, Token_Ptr); + Set_Intval (Token_Node, Int_Literal_Value); + Check_Obsolete_Base_Char; + + when Tok_String_Literal => + Token_Node := New_Node (N_String_Literal, Token_Ptr); + Set_Has_Wide_Character + (Token_Node, Wide_Character_Found); + Set_Has_Wide_Wide_Character + (Token_Node, Wide_Wide_Character_Found); + Set_Strval (Token_Node, String_Literal_Id); + + if Source (Token_Ptr) = '%' then + Check_Obsolescent_Features_Restriction (Token_Ptr); + + if Warn_On_Obsolescent_Feature then + Error_Msg_SC + ("use of ""'%"" is an obsolescent feature (RM J.2(4))?"); + Error_Msg_SC ("\use """""" instead?"); + end if; + end if; + + when Tok_Operator_Symbol => + Token_Node := New_Node (N_Operator_Symbol, Token_Ptr); + Set_Chars (Token_Node, Token_Name); + Set_Strval (Token_Node, String_Literal_Id); + + when Tok_Vertical_Bar => + if Source (Token_Ptr) = '!' then + Check_Obsolescent_Features_Restriction (Token_Ptr); + + if Warn_On_Obsolescent_Feature then + Error_Msg_SC + ("use of ""'!"" is an obsolescent feature (RM J.2(2))?"); + Error_Msg_SC ("\use ""'|"" instead?"); + end if; + end if; + + when others => + null; + end case; + end Post_Scan; + + ------------------------------ + -- Scan_Reserved_Identifier -- + ------------------------------ + + procedure Scan_Reserved_Identifier (Force_Msg : Boolean) is + Token_Chars : constant String := Token_Type'Image (Token); + + begin + -- We have in Token_Chars the image of the Token name, i.e. Tok_xxx. + -- This code extracts the xxx and makes an identifier out of it. + + Name_Len := 0; + + for J in 5 .. Token_Chars'Length loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Fold_Lower (Token_Chars (J)); + end loop; + + Token_Name := Name_Find; + + if not Used_As_Identifier (Token) or else Force_Msg then + + -- If "some" is made into a reserved work in Ada2012, the following + -- check will make it into a regular identifier in earlier versions + -- of the language. + + if Token = Tok_Some and then Ada_Version < Ada_2012 then + null; + else + Error_Msg_Name_1 := Token_Name; + Error_Msg_SC ("reserved word* cannot be used as identifier!"); + Used_As_Identifier (Token) := True; + end if; + end if; + + Token := Tok_Identifier; + Token_Node := New_Node (N_Identifier, Token_Ptr); + Set_Chars (Token_Node, Token_Name); + end Scan_Reserved_Identifier; + +end Scn; diff --git a/gcc/ada/scn.ads b/gcc/ada/scn.ads new file mode 100644 index 000000000..ea7b22be9 --- /dev/null +++ b/gcc/ada/scn.ads @@ -0,0 +1,83 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S C N -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 lexical analyzer routines. This is used by the +-- compiler for scanning Ada source files. + +with Casing; use Casing; +with Errout; use Errout; +with Scng; +with Style; use Style; +with Types; use Types; + +package Scn is + + procedure Initialize_Scanner + (Unit : Unit_Number_Type; + Index : Source_File_Index); + -- Initialize lexical scanner for scanning a new file. The caller has + -- completed the construction of the Units.Table entry for the specified + -- Unit and Index references the corresponding source file. A special + -- case is when Unit = No_Unit_Number, and Index corresponds to the + -- source index for reading the configuration pragma file. + + function Determine_Token_Casing return Casing_Type; + -- Determines the casing style of the current token, which is + -- either a keyword or an identifier. See also package Casing. + + procedure Post_Scan; + -- Create nodes for tokens: Char_Literal, Identifier, Real_Literal, + -- Integer_Literal, String_Literal and Operator_Symbol. + + procedure Scan_Reserved_Identifier (Force_Msg : Boolean); + -- This procedure is called to convert the current token, which the caller + -- has checked is for a reserved word, to an equivalent identifier. This is + -- of course only used in error situations where the parser can detect that + -- a reserved word is being used as an identifier. An appropriate error + -- message, pointing to the token, is also issued if either this is the + -- first occurrence of misuse of this identifier, or if Force_Msg is True. + + ------------- + -- Scanner -- + ------------- + + -- The scanner used by the compiler is an instantiation of the + -- generic package Scng with routines appropriate to the compiler + + package Scanner is new Scng + (Post_Scan => Post_Scan, + Error_Msg => Error_Msg, + Error_Msg_S => Error_Msg_S, + Error_Msg_SC => Error_Msg_SC, + Error_Msg_SP => Error_Msg_SP, + Style => Style.Style_Inst); + + procedure Scan renames Scanner.Scan; + -- Scan scans out the next token, and advances the scan state accordingly + -- (see package Scans for details). If the scan encounters an illegal + -- token, then an error message is issued pointing to the bad character, + -- and Scan returns a reasonable substitute token of some kind. + +end Scn; diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb new file mode 100644 index 000000000..f1386f8fc --- /dev/null +++ b/gcc/ada/scng.adb @@ -0,0 +1,2764 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S C N G -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Csets; use Csets; +with Err_Vars; use Err_Vars; +with Hostparm; use Hostparm; +with Namet; use Namet; +with Opt; use Opt; +with Scans; use Scans; +with Sinput; use Sinput; +with Snames; use Snames; +with Stringt; use Stringt; +with Stylesw; use Stylesw; +with Uintp; use Uintp; +with Urealp; use Urealp; +with Widechar; use Widechar; + +pragma Warnings (Off); +-- This package is used also by gnatcoll +with System.CRC32; +with System.UTF_32; use System.UTF_32; +with System.WCh_Con; use System.WCh_Con; +pragma Warnings (On); + +package body Scng is + + use ASCII; + -- Make control characters visible + + Special_Characters : array (Character) of Boolean := (others => False); + -- For characters that are Special token, the value is True + + Comment_Is_Token : Boolean := False; + -- True if comments are tokens + + End_Of_Line_Is_Token : Boolean := False; + -- True if End_Of_Line is a token + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Accumulate_Token_Checksum; + pragma Inline (Accumulate_Token_Checksum); + -- Called after each numeric literal and identifier/keyword. For keywords, + -- the token used is Tok_Identifier. This allows to detect additional + -- spaces added in sources when using the builder switch -m. + + procedure Accumulate_Token_Checksum_GNAT_6_3; + -- Used in place of Accumulate_Token_Checksum for GNAT versions 5.04 to + -- 6.3, when Tok_Some was not included in Token_Type and the actual + -- Token_Type was used for keywords. This procedure is never used in the + -- compiler or gnatmake, only in gprbuild. + + procedure Accumulate_Token_Checksum_GNAT_5_03; + -- Used in place of Accumulate_Token_Checksum for GNAT version 5.03, when + -- Tok_Interface, Tok_Some, Tok_Synchronized and Tok_Overriding were not + -- included in Token_Type and the actual Token_Type was used for keywords. + -- This procedure is never used in the compiler or gnatmake, only in + -- gprbuild. + + procedure Accumulate_Checksum (C : Character); + pragma Inline (Accumulate_Checksum); + -- This routine accumulates the checksum given character C. During the + -- scanning of a source file, this routine is called with every character + -- in the source, excluding blanks, and all control characters (except + -- that ESC is included in the checksum). Upper case letters not in string + -- literals are folded by the caller. See Sinput spec for the documentation + -- of the checksum algorithm. Note: checksum values are only used if we + -- generate code, so it is not necessary to worry about making the right + -- sequence of calls in any error situation. + + procedure Accumulate_Checksum (C : Char_Code); + pragma Inline (Accumulate_Checksum); + -- This version is identical, except that the argument, C, is a character + -- code value instead of a character. This is used when wide characters + -- are scanned. We use the character code rather than the ASCII characters + -- so that the checksum is independent of wide character encoding method. + + procedure Initialize_Checksum; + pragma Inline (Initialize_Checksum); + -- Initialize checksum value + + ------------------------- + -- Accumulate_Checksum -- + ------------------------- + + procedure Accumulate_Checksum (C : Character) is + begin + System.CRC32.Update (System.CRC32.CRC32 (Checksum), C); + end Accumulate_Checksum; + + procedure Accumulate_Checksum (C : Char_Code) is + begin + if C > 16#FFFF# then + Accumulate_Checksum (Character'Val (C / 2 ** 24)); + Accumulate_Checksum (Character'Val ((C / 2 ** 16) mod 256)); + Accumulate_Checksum (Character'Val ((C / 256) mod 256)); + else + Accumulate_Checksum (Character'Val (C / 256)); + end if; + + Accumulate_Checksum (Character'Val (C mod 256)); + end Accumulate_Checksum; + + ------------------------------- + -- Accumulate_Token_Checksum -- + ------------------------------- + + procedure Accumulate_Token_Checksum is + begin + System.CRC32.Update + (System.CRC32.CRC32 (Checksum), + Character'Val (Token_Type'Pos (Token))); + end Accumulate_Token_Checksum; + + ---------------------------------------- + -- Accumulate_Token_Checksum_GNAT_6_3 -- + ---------------------------------------- + + procedure Accumulate_Token_Checksum_GNAT_6_3 is + begin + -- Individual values of Token_Type are used, instead of subranges, so + -- that additions or suppressions of enumerated values in type + -- Token_Type are detected by the compiler. + + case Token is + when Tok_Integer_Literal | Tok_Real_Literal | Tok_String_Literal | + Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier | + Tok_Double_Asterisk | Tok_Ampersand | Tok_Minus | Tok_Plus | + Tok_Asterisk | Tok_Mod | Tok_Rem | Tok_Slash | Tok_New | + Tok_Abs | Tok_Others | Tok_Null | Tok_Dot | Tok_Apostrophe | + Tok_Left_Paren | Tok_Delta | Tok_Digits | Tok_Range | + Tok_Right_Paren | Tok_Comma | Tok_And | Tok_Or | Tok_Xor | + Tok_Less | Tok_Equal | Tok_Greater | Tok_Not_Equal | + Tok_Greater_Equal | Tok_Less_Equal | Tok_In | Tok_Not | + Tok_Box | Tok_Colon_Equal | Tok_Colon | Tok_Greater_Greater | + Tok_Abstract | Tok_Access | Tok_Aliased | Tok_All | Tok_Array | + Tok_At | Tok_Body | Tok_Constant | Tok_Do | Tok_Is | + Tok_Interface | Tok_Limited | Tok_Of | Tok_Out | Tok_Record | + Tok_Renames | Tok_Reverse => + + System.CRC32.Update + (System.CRC32.CRC32 (Checksum), + Character'Val (Token_Type'Pos (Token))); + + when Tok_Some => + + System.CRC32.Update + (System.CRC32.CRC32 (Checksum), + Character'Val (Token_Type'Pos (Tok_Identifier))); + + when Tok_Tagged | Tok_Then | Tok_Less_Less | Tok_Abort | Tok_Accept | + Tok_Case | Tok_Delay | Tok_Else | Tok_Elsif | Tok_End | + Tok_Exception | Tok_Exit | Tok_Goto | Tok_If | Tok_Pragma | + Tok_Raise | Tok_Requeue | Tok_Return | Tok_Select | + Tok_Terminate | Tok_Until | Tok_When | Tok_Begin | Tok_Declare | + Tok_For | Tok_Loop | Tok_While | Tok_Entry | Tok_Protected | + Tok_Task | Tok_Type | Tok_Subtype | Tok_Overriding | + Tok_Synchronized | Tok_Use | Tok_Function | Tok_Generic | + Tok_Package | Tok_Procedure | Tok_Private | Tok_With | + Tok_Separate | Tok_EOF | Tok_Semicolon | Tok_Arrow | + Tok_Vertical_Bar | Tok_Dot_Dot | Tok_Project | Tok_Extends | + Tok_External | Tok_External_As_List | Tok_Comment | + Tok_End_Of_Line | Tok_Special | No_Token => + + System.CRC32.Update + (System.CRC32.CRC32 (Checksum), + Character'Val (Token_Type'Pos (Token_Type'Pred (Token)))); + end case; + end Accumulate_Token_Checksum_GNAT_6_3; + + ----------------------------------------- + -- Accumulate_Token_Checksum_GNAT_5_03 -- + ----------------------------------------- + + procedure Accumulate_Token_Checksum_GNAT_5_03 is + begin + -- Individual values of Token_Type are used, instead of subranges, so + -- that additions or suppressions of enumerated values in type + -- Token_Type are detected by the compiler. + + case Token is + when Tok_Integer_Literal | Tok_Real_Literal | Tok_String_Literal | + Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier | + Tok_Double_Asterisk | Tok_Ampersand | Tok_Minus | Tok_Plus | + Tok_Asterisk | Tok_Mod | Tok_Rem | Tok_Slash | Tok_New | + Tok_Abs | Tok_Others | Tok_Null | Tok_Dot | Tok_Apostrophe | + Tok_Left_Paren | Tok_Delta | Tok_Digits | Tok_Range | + Tok_Right_Paren | Tok_Comma | Tok_And | Tok_Or | Tok_Xor | + Tok_Less | Tok_Equal | Tok_Greater | Tok_Not_Equal | + Tok_Greater_Equal | Tok_Less_Equal | Tok_In | Tok_Not | + Tok_Box | Tok_Colon_Equal | Tok_Colon | Tok_Greater_Greater | + Tok_Abstract | Tok_Access | Tok_Aliased | Tok_All | Tok_Array | + Tok_At | Tok_Body | Tok_Constant | Tok_Do | Tok_Is => + + System.CRC32.Update + (System.CRC32.CRC32 (Checksum), + Character'Val (Token_Type'Pos (Token))); + + when Tok_Interface | Tok_Some | Tok_Overriding | Tok_Synchronized => + System.CRC32.Update + (System.CRC32.CRC32 (Checksum), + Character'Val (Token_Type'Pos (Tok_Identifier))); + + when Tok_Limited | Tok_Of | Tok_Out | Tok_Record | + Tok_Renames | Tok_Reverse => + + System.CRC32.Update + (System.CRC32.CRC32 (Checksum), + Character'Val (Token_Type'Pos (Token) - 1)); + + when Tok_Tagged | Tok_Then | Tok_Less_Less | Tok_Abort | Tok_Accept | + Tok_Case | Tok_Delay | Tok_Else | Tok_Elsif | Tok_End | + Tok_Exception | Tok_Exit | Tok_Goto | Tok_If | Tok_Pragma | + Tok_Raise | Tok_Requeue | Tok_Return | Tok_Select | + Tok_Terminate | Tok_Until | Tok_When | Tok_Begin | Tok_Declare | + Tok_For | Tok_Loop | Tok_While | Tok_Entry | Tok_Protected | + Tok_Task | Tok_Type | Tok_Subtype => + + System.CRC32.Update + (System.CRC32.CRC32 (Checksum), + Character'Val (Token_Type'Pos (Token) - 2)); + + when Tok_Use | Tok_Function | Tok_Generic | + Tok_Package | Tok_Procedure | Tok_Private | Tok_With | + Tok_Separate | Tok_EOF | Tok_Semicolon | Tok_Arrow | + Tok_Vertical_Bar | Tok_Dot_Dot | Tok_Project | Tok_Extends | + Tok_External | Tok_External_As_List | Tok_Comment | + Tok_End_Of_Line | Tok_Special | No_Token => + + System.CRC32.Update + (System.CRC32.CRC32 (Checksum), + Character'Val (Token_Type'Pos (Token) - 4)); + end case; + end Accumulate_Token_Checksum_GNAT_5_03; + + ---------------------------- + -- Determine_Token_Casing -- + ---------------------------- + + function Determine_Token_Casing return Casing_Type is + begin + return Determine_Casing (Source (Token_Ptr .. Scan_Ptr - 1)); + end Determine_Token_Casing; + + ------------------------- + -- Initialize_Checksum -- + ------------------------- + + procedure Initialize_Checksum is + begin + System.CRC32.Initialize (System.CRC32.CRC32 (Checksum)); + end Initialize_Checksum; + + ------------------------ + -- Initialize_Scanner -- + ------------------------ + + procedure Initialize_Scanner (Index : Source_File_Index) is + begin + -- Establish reserved words + + Scans.Initialize_Ada_Keywords; + + -- Initialize scan control variables + + Current_Source_File := Index; + Source := Source_Text (Current_Source_File); + Scan_Ptr := Source_First (Current_Source_File); + Token := No_Token; + Token_Ptr := Scan_Ptr; + Current_Line_Start := Scan_Ptr; + Token_Node := Empty; + Token_Name := No_Name; + Start_Column := Set_Start_Column; + First_Non_Blank_Location := Scan_Ptr; + + Initialize_Checksum; + Wide_Char_Byte_Count := 0; + + -- Do not call Scan, otherwise the License stuff does not work in Scn + + end Initialize_Scanner; + + ------------------------------ + -- Reset_Special_Characters -- + ------------------------------ + + procedure Reset_Special_Characters is + begin + Special_Characters := (others => False); + end Reset_Special_Characters; + + ---------- + -- Scan -- + ---------- + + procedure Scan is + + Start_Of_Comment : Source_Ptr; + -- Record start of comment position + + Underline_Found : Boolean; + -- During scanning of an identifier, set to True if last character + -- scanned was an underline or other punctuation character. This + -- is used to flag the error of two underlines/punctuations in a + -- row or ending an identifier with a underline/punctuation. Here + -- punctuation means any UTF_32 character in the Unicode category + -- Punctuation,Connector. + + Wptr : Source_Ptr; + -- Used to remember start of last wide character scanned + + procedure Check_End_Of_Line; + -- Called when end of line encountered. Checks that line is not too + -- long, and that other style checks for the end of line are met. + + function Double_Char_Token (C : Character) return Boolean; + -- This function is used for double character tokens like := or <>. It + -- checks if the character following Source (Scan_Ptr) is C, and if so + -- bumps Scan_Ptr past the pair of characters and returns True. A space + -- between the two characters is also recognized with an appropriate + -- error message being issued. If C is not present, False is returned. + -- Note that Double_Char_Token can only be used for tokens defined in + -- the Ada syntax (it's use for error cases like && is not appropriate + -- since we do not want a junk message for a case like &-space-&). + + procedure Error_Illegal_Character; + -- Give illegal character error, Scan_Ptr points to character. On + -- return, Scan_Ptr is bumped past the illegal character. + + procedure Error_Illegal_Wide_Character; + -- Give illegal wide character message. On return, Scan_Ptr is bumped + -- past the illegal character, which may still leave us pointing to + -- junk, not much we can do if the escape sequence is messed up! + + procedure Error_Long_Line; + -- Signal error of excessively long line + + procedure Error_No_Double_Underline; + -- Signal error of two underline or punctuation characters in a row. + -- Called with Scan_Ptr pointing to second underline/punctuation char. + + procedure Nlit; + -- This is the procedure for scanning out numeric literals. On entry, + -- Scan_Ptr points to the digit that starts the numeric literal (the + -- checksum for this character has not been accumulated yet). On return + -- Scan_Ptr points past the last character of the numeric literal, Token + -- and Token_Node are set appropriately, and the checksum is updated. + + procedure Slit; + -- This is the procedure for scanning out string literals. On entry, + -- Scan_Ptr points to the opening string quote (the checksum for this + -- character has not been accumulated yet). On return Scan_Ptr points + -- past the closing quote of the string literal, Token and Token_Node + -- are set appropriately, and the checksum is updated. + + procedure Skip_Other_Format_Characters; + -- Skips past any "other format" category characters at the current + -- cursor location (does not skip past spaces or any other characters). + + function Start_Of_Wide_Character return Boolean; + -- Returns True if the scan pointer is pointing to the start of a wide + -- character sequence, does not modify the scan pointer in any case. + + ----------------------- + -- Check_End_Of_Line -- + ----------------------- + + procedure Check_End_Of_Line is + Len : constant Int := + Int (Scan_Ptr) - + Int (Current_Line_Start) - + Wide_Char_Byte_Count; + + begin + if Style_Check then + Style.Check_Line_Terminator (Len); + end if; + + -- Deal with checking maximum line length + + if Style_Check and Style_Check_Max_Line_Length then + Style.Check_Line_Max_Length (Len); + + -- If style checking is inactive, check maximum line length against + -- standard value. + + elsif Len > Max_Line_Length then + Error_Long_Line; + end if; + + -- Now one more checking circuit. Normally we are only enforcing a + -- limit of physical characters, with tabs counting as one character. + -- But if after tab expansion we would have a total line length that + -- exceeded 32766, that would really cause trouble, because column + -- positions would exceed the maximum we allow for a column count. + -- Note: the limit is 32766 rather than 32767, since we use a value + -- of 32767 for special purposes (see Sinput). Now we really do not + -- want to go messing with tabs in the normal case, so what we do is + -- to check for a line that has more than 4096 physical characters. + -- Any shorter line could not be a problem, even if it was all tabs. + + if Len >= 4096 then + declare + Col : Natural; + Ptr : Source_Ptr; + + begin + Col := 1; + Ptr := Current_Line_Start; + loop + exit when Ptr = Scan_Ptr; + + if Source (Ptr) = ASCII.HT then + Col := (Col - 1 + 8) / 8 * 8 + 1; + else + Col := Col + 1; + end if; + + if Col > 32766 then + Error_Msg + ("this line is longer than 32766 characters", + Current_Line_Start); + raise Unrecoverable_Error; + end if; + + Ptr := Ptr + 1; + end loop; + end; + end if; + + -- Reset wide character byte count for next line + + Wide_Char_Byte_Count := 0; + end Check_End_Of_Line; + + ----------------------- + -- Double_Char_Token -- + ----------------------- + + function Double_Char_Token (C : Character) return Boolean is + begin + if Source (Scan_Ptr + 1) = C then + Accumulate_Checksum (C); + Scan_Ptr := Scan_Ptr + 2; + return True; + + elsif Source (Scan_Ptr + 1) = ' ' + and then Source (Scan_Ptr + 2) = C + then + Scan_Ptr := Scan_Ptr + 1; + Error_Msg_S -- CODEFIX + ("no space allowed here"); + Scan_Ptr := Scan_Ptr + 2; + return True; + + else + return False; + end if; + end Double_Char_Token; + + ----------------------------- + -- Error_Illegal_Character -- + ----------------------------- + + procedure Error_Illegal_Character is + begin + Error_Msg_S ("illegal character"); + Scan_Ptr := Scan_Ptr + 1; + end Error_Illegal_Character; + + ---------------------------------- + -- Error_Illegal_Wide_Character -- + ---------------------------------- + + procedure Error_Illegal_Wide_Character is + begin + Scan_Ptr := Scan_Ptr + 1; + Error_Msg ("illegal wide character", Wptr); + end Error_Illegal_Wide_Character; + + --------------------- + -- Error_Long_Line -- + --------------------- + + procedure Error_Long_Line is + begin + Error_Msg + ("this line is too long", + Current_Line_Start + Source_Ptr (Max_Line_Length)); + end Error_Long_Line; + + ------------------------------- + -- Error_No_Double_Underline -- + ------------------------------- + + procedure Error_No_Double_Underline is + begin + Underline_Found := False; + + -- There are four cases, and we special case the messages + + if Source (Scan_Ptr) = '_' then + if Source (Scan_Ptr - 1) = '_' then + Error_Msg_S -- CODEFIX + ("two consecutive underlines not permitted"); + else + Error_Msg_S ("underline cannot follow punctuation character"); + end if; + + else + if Source (Scan_Ptr - 1) = '_' then + Error_Msg_S ("punctuation character cannot follow underline"); + else + Error_Msg_S + ("two consecutive punctuation characters not permitted"); + end if; + end if; + end Error_No_Double_Underline; + + ---------- + -- Nlit -- + ---------- + + procedure Nlit is + + C : Character; + -- Current source program character + + Base_Char : Character; + -- Either # or : (character at start of based number) + + Base : Int; + -- Value of base + + UI_Base : Uint; + -- Value of base in Uint format + + UI_Int_Value : Uint; + -- Value of integer scanned by Scan_Integer in Uint format + + UI_Num_Value : Uint; + -- Value of integer in numeric value being scanned + + Scale : Int; + -- Scale value for real literal + + UI_Scale : Uint; + -- Scale in Uint format + + Exponent_Is_Negative : Boolean; + -- Set true for negative exponent + + Extended_Digit_Value : Int; + -- Extended digit value + + Point_Scanned : Boolean; + -- Flag for decimal point scanned in numeric literal + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Error_Digit_Expected; + -- Signal error of bad digit, Scan_Ptr points to the location at + -- which the digit was expected on input, and is unchanged on return. + + procedure Scan_Integer; + -- Procedure to scan integer literal. On entry, Scan_Ptr points to a + -- digit, on exit Scan_Ptr points past the last character of the + -- integer. + -- + -- For each digit encountered, UI_Int_Value is multiplied by 10, and + -- the value of the digit added to the result. In addition, the + -- value in Scale is decremented by one for each actual digit + -- scanned. + + -------------------------- + -- Error_Digit_Expected -- + -------------------------- + + procedure Error_Digit_Expected is + begin + Error_Msg_S ("digit expected"); + end Error_Digit_Expected; + + ------------------ + -- Scan_Integer -- + ------------------ + + procedure Scan_Integer is + C : Character; + -- Next character scanned + + begin + C := Source (Scan_Ptr); + + -- Loop through digits (allowing underlines) + + loop + Accumulate_Checksum (C); + UI_Int_Value := + UI_Int_Value * 10 + (Character'Pos (C) - Character'Pos ('0')); + Scan_Ptr := Scan_Ptr + 1; + Scale := Scale - 1; + C := Source (Scan_Ptr); + + -- Case of underline encountered + + if C = '_' then + + -- We do not accumulate the '_' in the checksum, so that + -- 1_234 is equivalent to 1234, and does not trigger + -- compilation for "minimal recompilation" (gnatmake -m). + + loop + Scan_Ptr := Scan_Ptr + 1; + C := Source (Scan_Ptr); + exit when C /= '_'; + Error_No_Double_Underline; + end loop; + + if C not in '0' .. '9' then + Error_Digit_Expected; + exit; + end if; + + else + exit when C not in '0' .. '9'; + end if; + end loop; + end Scan_Integer; + + -- Start of Processing for Nlit + + begin + Base := 10; + UI_Base := Uint_10; + UI_Int_Value := Uint_0; + Based_Literal_Uses_Colon := False; + Scale := 0; + Scan_Integer; + Point_Scanned := False; + UI_Num_Value := UI_Int_Value; + + -- Various possibilities now for continuing the literal are period, + -- E/e (for exponent), or :/# (for based literal). + + Scale := 0; + C := Source (Scan_Ptr); + + if C = '.' then + + -- Scan out point, but do not scan past .. which is a range + -- sequence, and must not be eaten up scanning a numeric literal. + + while C = '.' and then Source (Scan_Ptr + 1) /= '.' loop + Accumulate_Checksum ('.'); + + if Point_Scanned then + Error_Msg_S ("duplicate point ignored"); + end if; + + Point_Scanned := True; + Scan_Ptr := Scan_Ptr + 1; + C := Source (Scan_Ptr); + + if C not in '0' .. '9' then + Error_Msg + ("real literal cannot end with point", Scan_Ptr - 1); + else + Scan_Integer; + UI_Num_Value := UI_Int_Value; + end if; + end loop; + + -- Based literal case. The base is the value we already scanned. + -- In the case of colon, we insist that the following character + -- is indeed an extended digit or a period. This catches a number + -- of common errors, as well as catching the well known tricky + -- bug otherwise arising from "x : integer range 1 .. 10:= 6;" + + elsif C = '#' + or else (C = ':' and then + (Source (Scan_Ptr + 1) = '.' + or else + Source (Scan_Ptr + 1) in '0' .. '9' + or else + Source (Scan_Ptr + 1) in 'A' .. 'Z' + or else + Source (Scan_Ptr + 1) in 'a' .. 'z')) + then + Accumulate_Checksum (C); + Base_Char := C; + UI_Base := UI_Int_Value; + + if Base_Char = ':' then + Based_Literal_Uses_Colon := True; + end if; + + if UI_Base < 2 or else UI_Base > 16 then + Error_Msg_SC ("base not 2-16"); + UI_Base := Uint_16; + end if; + + Base := UI_To_Int (UI_Base); + Scan_Ptr := Scan_Ptr + 1; + + -- Scan out extended integer [. integer] + + C := Source (Scan_Ptr); + UI_Int_Value := Uint_0; + Scale := 0; + + loop + if C in '0' .. '9' then + Accumulate_Checksum (C); + Extended_Digit_Value := + Int'(Character'Pos (C)) - Int'(Character'Pos ('0')); + + elsif C in 'A' .. 'F' then + Accumulate_Checksum (Character'Val (Character'Pos (C) + 32)); + Extended_Digit_Value := + Int'(Character'Pos (C)) - Int'(Character'Pos ('A')) + 10; + + elsif C in 'a' .. 'f' then + Accumulate_Checksum (C); + Extended_Digit_Value := + Int'(Character'Pos (C)) - Int'(Character'Pos ('a')) + 10; + + else + Error_Msg_S ("extended digit expected"); + exit; + end if; + + if Extended_Digit_Value >= Base then + Error_Msg_S ("digit '>= base"); + end if; + + UI_Int_Value := UI_Int_Value * UI_Base + Extended_Digit_Value; + Scale := Scale - 1; + Scan_Ptr := Scan_Ptr + 1; + C := Source (Scan_Ptr); + + if C = '_' then + loop + Accumulate_Checksum ('_'); + Scan_Ptr := Scan_Ptr + 1; + C := Source (Scan_Ptr); + exit when C /= '_'; + Error_No_Double_Underline; + end loop; + + elsif C = '.' then + Accumulate_Checksum ('.'); + + if Point_Scanned then + Error_Msg_S ("duplicate point ignored"); + end if; + + Scan_Ptr := Scan_Ptr + 1; + C := Source (Scan_Ptr); + Point_Scanned := True; + Scale := 0; + + elsif C = Base_Char then + Accumulate_Checksum (C); + Scan_Ptr := Scan_Ptr + 1; + exit; + + elsif C = '#' or else C = ':' then + Error_Msg_S ("based number delimiters must match"); + Scan_Ptr := Scan_Ptr + 1; + exit; + + elsif not Identifier_Char (C) then + if Base_Char = '#' then + Error_Msg_S -- CODEFIX + ("missing '#"); + else + Error_Msg_S -- CODEFIX + ("missing ':"); + end if; + + exit; + end if; + + end loop; + + UI_Num_Value := UI_Int_Value; + end if; + + -- Scan out exponent + + if not Point_Scanned then + Scale := 0; + UI_Scale := Uint_0; + else + UI_Scale := UI_From_Int (Scale); + end if; + + if Source (Scan_Ptr) = 'e' or else Source (Scan_Ptr) = 'E' then + Accumulate_Checksum ('e'); + Scan_Ptr := Scan_Ptr + 1; + Exponent_Is_Negative := False; + + if Source (Scan_Ptr) = '+' then + Accumulate_Checksum ('+'); + Scan_Ptr := Scan_Ptr + 1; + + elsif Source (Scan_Ptr) = '-' then + Accumulate_Checksum ('-'); + + if not Point_Scanned then + Error_Msg_S + ("negative exponent not allowed for integer literal"); + else + Exponent_Is_Negative := True; + end if; + + Scan_Ptr := Scan_Ptr + 1; + end if; + + UI_Int_Value := Uint_0; + + if Source (Scan_Ptr) in '0' .. '9' then + Scan_Integer; + else + Error_Digit_Expected; + end if; + + if Exponent_Is_Negative then + UI_Scale := UI_Scale - UI_Int_Value; + else + UI_Scale := UI_Scale + UI_Int_Value; + end if; + end if; + + -- Case of real literal to be returned + + if Point_Scanned then + Token := Tok_Real_Literal; + Real_Literal_Value := + UR_From_Components ( + Num => UI_Num_Value, + Den => -UI_Scale, + Rbase => Base); + + -- Case of integer literal to be returned + + else + Token := Tok_Integer_Literal; + + if UI_Scale = 0 then + Int_Literal_Value := UI_Num_Value; + + -- Avoid doing possibly expensive calculations in cases like + -- parsing 163E800_000# when semantics will not be done anyway. + -- This is especially useful when parsing garbled input. + + elsif Operating_Mode /= Check_Syntax + and then (Serious_Errors_Detected = 0 or else Try_Semantics) + then + Int_Literal_Value := UI_Num_Value * UI_Base ** UI_Scale; + + else + Int_Literal_Value := No_Uint; + end if; + end if; + + if Checksum_Accumulate_Token_Checksum then + Accumulate_Token_Checksum; + end if; + + return; + end Nlit; + + ---------- + -- Slit -- + ---------- + + procedure Slit is + + Delimiter : Character; + -- Delimiter (first character of string) + + C : Character; + -- Current source program character + + Code : Char_Code; + -- Current character code value + + Err : Boolean; + -- Error flag for Scan_Wide call + + procedure Error_Bad_String_Char; + -- Signal bad character in string/character literal. On entry + -- Scan_Ptr points to the improper character encountered during the + -- scan. Scan_Ptr is not modified, so it still points to the bad + -- character on return. + + procedure Error_Unterminated_String; + -- Procedure called if a line terminator character is encountered + -- during scanning a string, meaning that the string is not properly + -- terminated. + + procedure Set_String; + -- Procedure used to distinguish between string and operator symbol. + -- On entry the string has been scanned out, and its characters start + -- at Token_Ptr and end one character before Scan_Ptr. On exit Token + -- is set to Tok_String_Literal/Tok_Operator_Symbol as appropriate, + -- and Token_Node is appropriately initialized. In addition, in the + -- operator symbol case, Token_Name is appropriately set, and the + -- flags [Wide_]Wide_Character_Found are set appropriately. + + --------------------------- + -- Error_Bad_String_Char -- + --------------------------- + + procedure Error_Bad_String_Char is + C : constant Character := Source (Scan_Ptr); + + begin + if C = HT then + Error_Msg_S ("horizontal tab not allowed in string"); + + elsif C = VT or else C = FF then + Error_Msg_S ("format effector not allowed in string"); + + elsif C in Upper_Half_Character then + Error_Msg_S ("(Ada 83) upper half character not allowed"); + + else + Error_Msg_S ("control character not allowed in string"); + end if; + end Error_Bad_String_Char; + + ------------------------------- + -- Error_Unterminated_String -- + ------------------------------- + + procedure Error_Unterminated_String is + begin + -- An interesting little refinement. Consider the following + -- examples: + + -- A := "this is an unterminated string; + -- A := "this is an unterminated string & + -- P(A, "this is a parameter that didn't get terminated); + + -- We fiddle a little to do slightly better placement in these + -- cases also if there is white space at the end of the line we + -- place the flag at the start of this white space, not at the + -- end. Note that we only have to test for blanks, since tabs + -- aren't allowed in strings in the first place and would have + -- caused an error message. + + -- Two more cases that we treat specially are: + + -- A := "this string uses the wrong terminator' + -- A := "this string uses the wrong terminator' & + + -- In these cases we give a different error message as well + + -- We actually reposition the scan pointer to the point where we + -- place the flag in these cases, since it seems a better bet on + -- the original intention. + + while Source (Scan_Ptr - 1) = ' ' + or else Source (Scan_Ptr - 1) = '&' + loop + Scan_Ptr := Scan_Ptr - 1; + Unstore_String_Char; + end loop; + + -- Check for case of incorrect string terminator, but single quote + -- is not considered incorrect if the opening terminator misused + -- a single quote (error message already given). + + if Delimiter /= ''' + and then Source (Scan_Ptr - 1) = ''' + then + Unstore_String_Char; + Error_Msg + ("incorrect string terminator character", Scan_Ptr - 1); + return; + end if; + + if Source (Scan_Ptr - 1) = ';' then + Scan_Ptr := Scan_Ptr - 1; + Unstore_String_Char; + + if Source (Scan_Ptr - 1) = ')' then + Scan_Ptr := Scan_Ptr - 1; + Unstore_String_Char; + end if; + end if; + + Error_Msg_S -- CODEFIX + ("missing string quote"); + end Error_Unterminated_String; + + ---------------- + -- Set_String -- + ---------------- + + procedure Set_String is + Slen : constant Int := Int (Scan_Ptr - Token_Ptr - 2); + C1 : Character; + C2 : Character; + C3 : Character; + + begin + -- Token_Name is currently set to Error_Name. The following + -- section of code resets Token_Name to the proper Name_Op_xx + -- value if the string is a valid operator symbol, otherwise it is + -- left set to Error_Name. + + if Slen = 1 then + C1 := Source (Token_Ptr + 1); + + case C1 is + when '=' => + Token_Name := Name_Op_Eq; + + when '>' => + Token_Name := Name_Op_Gt; + + when '<' => + Token_Name := Name_Op_Lt; + + when '+' => + Token_Name := Name_Op_Add; + + when '-' => + Token_Name := Name_Op_Subtract; + + when '&' => + Token_Name := Name_Op_Concat; + + when '*' => + Token_Name := Name_Op_Multiply; + + when '/' => + Token_Name := Name_Op_Divide; + + when others => + null; + end case; + + elsif Slen = 2 then + C1 := Source (Token_Ptr + 1); + C2 := Source (Token_Ptr + 2); + + if C1 = '*' and then C2 = '*' then + Token_Name := Name_Op_Expon; + + elsif C2 = '=' then + + if C1 = '/' then + Token_Name := Name_Op_Ne; + elsif C1 = '<' then + Token_Name := Name_Op_Le; + elsif C1 = '>' then + Token_Name := Name_Op_Ge; + end if; + + elsif (C1 = 'O' or else C1 = 'o') and then -- OR + (C2 = 'R' or else C2 = 'r') + then + Token_Name := Name_Op_Or; + end if; + + elsif Slen = 3 then + C1 := Source (Token_Ptr + 1); + C2 := Source (Token_Ptr + 2); + C3 := Source (Token_Ptr + 3); + + if (C1 = 'A' or else C1 = 'a') and then -- AND + (C2 = 'N' or else C2 = 'n') and then + (C3 = 'D' or else C3 = 'd') + then + Token_Name := Name_Op_And; + + elsif (C1 = 'A' or else C1 = 'a') and then -- ABS + (C2 = 'B' or else C2 = 'b') and then + (C3 = 'S' or else C3 = 's') + then + Token_Name := Name_Op_Abs; + + elsif (C1 = 'M' or else C1 = 'm') and then -- MOD + (C2 = 'O' or else C2 = 'o') and then + (C3 = 'D' or else C3 = 'd') + then + Token_Name := Name_Op_Mod; + + elsif (C1 = 'N' or else C1 = 'n') and then -- NOT + (C2 = 'O' or else C2 = 'o') and then + (C3 = 'T' or else C3 = 't') + then + Token_Name := Name_Op_Not; + + elsif (C1 = 'R' or else C1 = 'r') and then -- REM + (C2 = 'E' or else C2 = 'e') and then + (C3 = 'M' or else C3 = 'm') + then + Token_Name := Name_Op_Rem; + + elsif (C1 = 'X' or else C1 = 'x') and then -- XOR + (C2 = 'O' or else C2 = 'o') and then + (C3 = 'R' or else C3 = 'r') + then + Token_Name := Name_Op_Xor; + end if; + + end if; + + -- If it is an operator symbol, then Token_Name is set. If it is + -- some other string value, then Token_Name still contains + -- Error_Name. + + if Token_Name = Error_Name then + Token := Tok_String_Literal; + + else + Token := Tok_Operator_Symbol; + end if; + end Set_String; + + -- Start of processing for Slit + + begin + -- On entry, Scan_Ptr points to the opening character of the string + -- which is either a percent, double quote, or apostrophe (single + -- quote). The latter case is an error detected by the character + -- literal circuit. + + Delimiter := Source (Scan_Ptr); + Accumulate_Checksum (Delimiter); + + Start_String; + Wide_Character_Found := False; + Wide_Wide_Character_Found := False; + Scan_Ptr := Scan_Ptr + 1; + + -- Loop to scan out characters of string literal + + loop + C := Source (Scan_Ptr); + + if C = Delimiter then + Accumulate_Checksum (C); + Scan_Ptr := Scan_Ptr + 1; + exit when Source (Scan_Ptr) /= Delimiter; + Code := Get_Char_Code (C); + Accumulate_Checksum (C); + Scan_Ptr := Scan_Ptr + 1; + + else + if C = '"' and then Delimiter = '%' then + Error_Msg_S + ("quote not allowed in percent delimited string"); + Code := Get_Char_Code (C); + Scan_Ptr := Scan_Ptr + 1; + + elsif Start_Of_Wide_Character then + Wptr := Scan_Ptr; + Scan_Wide (Source, Scan_Ptr, Code, Err); + + if Err then + Error_Illegal_Wide_Character; + Code := Get_Char_Code (' '); + end if; + + Accumulate_Checksum (Code); + + -- In Ada 95 mode we allow any wide characters in a string + -- but in Ada 2005, the set of characters allowed has been + -- restricted to graphic characters. + + if Ada_Version >= Ada_2005 + and then Is_UTF_32_Non_Graphic (UTF_32 (Code)) + then + Error_Msg + ("(Ada 2005) non-graphic character not permitted " & + "in string literal", Wptr); + end if; + + else + Accumulate_Checksum (C); + + if C not in Graphic_Character then + if C in Line_Terminator then + Error_Unterminated_String; + exit; + + elsif C in Upper_Half_Character then + if Ada_Version = Ada_83 then + Error_Bad_String_Char; + end if; + + else + Error_Bad_String_Char; + end if; + end if; + + Code := Get_Char_Code (C); + Scan_Ptr := Scan_Ptr + 1; + end if; + end if; + + Store_String_Char (Code); + + if not In_Character_Range (Code) then + if In_Wide_Character_Range (Code) then + Wide_Character_Found := True; + else + Wide_Wide_Character_Found := True; + end if; + end if; + end loop; + + String_Literal_Id := End_String; + Set_String; + return; + end Slit; + + ---------------------------------- + -- Skip_Other_Format_Characters -- + ---------------------------------- + + procedure Skip_Other_Format_Characters is + P : Source_Ptr; + Code : Char_Code; + Err : Boolean; + + begin + while Start_Of_Wide_Character loop + P := Scan_Ptr; + Scan_Wide (Source, Scan_Ptr, Code, Err); + + if not Is_UTF_32_Other (UTF_32 (Code)) then + Scan_Ptr := P; + return; + end if; + end loop; + end Skip_Other_Format_Characters; + + ----------------------------- + -- Start_Of_Wide_Character -- + ----------------------------- + + function Start_Of_Wide_Character return Boolean is + C : constant Character := Source (Scan_Ptr); + + begin + -- ESC encoding method with ESC present + + if C = ESC + and then Wide_Character_Encoding_Method in WC_ESC_Encoding_Method + then + return True; + + -- Upper half character with upper half encoding + + elsif C in Upper_Half_Character and then Upper_Half_Encoding then + return True; + + -- Brackets encoding + + elsif C = '[' + and then Source (Scan_Ptr + 1) = '"' + and then Identifier_Char (Source (Scan_Ptr + 2)) + then + return True; + + -- Not the start of a wide character + + else + return False; + end if; + end Start_Of_Wide_Character; + + -- Start of processing for Scan + + begin + Prev_Token := Token; + Prev_Token_Ptr := Token_Ptr; + Token_Name := Error_Name; + + -- The following loop runs more than once only if a format effector + -- (tab, vertical tab, form feed, line feed, carriage return) is + -- encountered and skipped, or some error situation, such as an + -- illegal character, is encountered. + + <> + + loop + -- Skip past blanks, loop is opened up for speed + + while Source (Scan_Ptr) = ' ' loop + if Source (Scan_Ptr + 1) /= ' ' then + Scan_Ptr := Scan_Ptr + 1; + exit; + end if; + + if Source (Scan_Ptr + 2) /= ' ' then + Scan_Ptr := Scan_Ptr + 2; + exit; + end if; + + if Source (Scan_Ptr + 3) /= ' ' then + Scan_Ptr := Scan_Ptr + 3; + exit; + end if; + + if Source (Scan_Ptr + 4) /= ' ' then + Scan_Ptr := Scan_Ptr + 4; + exit; + end if; + + if Source (Scan_Ptr + 5) /= ' ' then + Scan_Ptr := Scan_Ptr + 5; + exit; + end if; + + if Source (Scan_Ptr + 6) /= ' ' then + Scan_Ptr := Scan_Ptr + 6; + exit; + end if; + + if Source (Scan_Ptr + 7) /= ' ' then + Scan_Ptr := Scan_Ptr + 7; + exit; + end if; + + Scan_Ptr := Scan_Ptr + 8; + end loop; + + -- We are now at a non-blank character, which is the first character + -- of the token we will scan, and hence the value of Token_Ptr. + + Token_Ptr := Scan_Ptr; + + -- Here begins the main case statement which transfers control on the + -- basis of the non-blank character we have encountered. + + case Source (Scan_Ptr) is + + -- Line terminator characters + + when CR | LF | FF | VT => + goto Scan_Line_Terminator; + + -- Horizontal tab, just skip past it + + when HT => + if Style_Check then + Style.Check_HT; + end if; + + Scan_Ptr := Scan_Ptr + 1; + + -- End of file character, treated as an end of file only if it is + -- the last character in the buffer, otherwise it is ignored. + + when EOF => + if Scan_Ptr = Source_Last (Current_Source_File) then + Check_End_Of_Line; + + if Style_Check then + Style.Check_EOF; + end if; + + Token := Tok_EOF; + return; + else + Scan_Ptr := Scan_Ptr + 1; + end if; + + -- Ampersand + + when '&' => + Accumulate_Checksum ('&'); + + if Source (Scan_Ptr + 1) = '&' then + Error_Msg_S -- CODEFIX + ("'&'& should be `AND THEN`"); + Scan_Ptr := Scan_Ptr + 2; + Token := Tok_And; + return; + + else + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Ampersand; + return; + end if; + + -- Asterisk (can be multiplication operator or double asterisk which + -- is the exponentiation compound delimiter). + + when '*' => + Accumulate_Checksum ('*'); + + if Source (Scan_Ptr + 1) = '*' then + Accumulate_Checksum ('*'); + Scan_Ptr := Scan_Ptr + 2; + Token := Tok_Double_Asterisk; + return; + + else + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Asterisk; + return; + end if; + + -- Colon, which can either be an isolated colon, or part of an + -- assignment compound delimiter. + + when ':' => + Accumulate_Checksum (':'); + + if Double_Char_Token ('=') then + Token := Tok_Colon_Equal; + + if Style_Check then + Style.Check_Colon_Equal; + end if; + + return; + + elsif Source (Scan_Ptr + 1) = '-' + and then Source (Scan_Ptr + 2) /= '-' + then + Token := Tok_Colon_Equal; + Error_Msg -- CODEFIX + (":- should be :=", Scan_Ptr); + Scan_Ptr := Scan_Ptr + 2; + return; + + else + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Colon; + + if Style_Check then + Style.Check_Colon; + end if; + + return; + end if; + + -- Left parenthesis + + when '(' => + Accumulate_Checksum ('('); + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Left_Paren; + + if Style_Check then + Style.Check_Left_Paren; + end if; + + return; + + -- Left bracket + + when '[' => + if Source (Scan_Ptr + 1) = '"' then + goto Scan_Wide_Character; + + else + Error_Msg_S ("illegal character, replaced by ""("""); + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Left_Paren; + return; + end if; + + -- Left brace + + when '{' => + Error_Msg_S ("illegal character, replaced by ""("""); + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Left_Paren; + return; + + -- Comma + + when ',' => + Accumulate_Checksum (','); + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Comma; + + if Style_Check then + Style.Check_Comma; + end if; + + return; + + -- Dot, which is either an isolated period, or part of a double dot + -- compound delimiter sequence. We also check for the case of a + -- digit following the period, to give a better error message. + + when '.' => + Accumulate_Checksum ('.'); + + if Double_Char_Token ('.') then + Token := Tok_Dot_Dot; + + if Style_Check then + Style.Check_Dot_Dot; + end if; + + return; + + elsif Source (Scan_Ptr + 1) in '0' .. '9' then + Error_Msg_S ("numeric literal cannot start with point"); + Scan_Ptr := Scan_Ptr + 1; + + else + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Dot; + return; + end if; + + -- Equal, which can either be an equality operator, or part of the + -- arrow (=>) compound delimiter. + + when '=' => + Accumulate_Checksum ('='); + + if Double_Char_Token ('>') then + Token := Tok_Arrow; + + if Style_Check then + Style.Check_Arrow; + end if; + + return; + + elsif Source (Scan_Ptr + 1) = '=' then + Error_Msg_S -- CODEFIX + ("== should be ="); + Scan_Ptr := Scan_Ptr + 1; + end if; + + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Equal; + return; + + -- Greater than, which can be a greater than operator, greater than + -- or equal operator, or first character of a right label bracket. + + when '>' => + Accumulate_Checksum ('>'); + + if Double_Char_Token ('=') then + Token := Tok_Greater_Equal; + return; + + elsif Double_Char_Token ('>') then + Token := Tok_Greater_Greater; + return; + + else + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Greater; + return; + end if; + + -- Less than, which can be a less than operator, less than or equal + -- operator, or the first character of a left label bracket, or the + -- first character of a box (<>) compound delimiter. + + when '<' => + Accumulate_Checksum ('<'); + + if Double_Char_Token ('=') then + Token := Tok_Less_Equal; + return; + + elsif Double_Char_Token ('>') then + Token := Tok_Box; + + if Style_Check then + Style.Check_Box; + end if; + + return; + + elsif Double_Char_Token ('<') then + Token := Tok_Less_Less; + return; + + else + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Less; + return; + end if; + + -- Minus, which is either a subtraction operator, or the first + -- character of double minus starting a comment + + when '-' => Minus_Case : begin + if Source (Scan_Ptr + 1) = '>' then + Error_Msg_S ("invalid token"); + Scan_Ptr := Scan_Ptr + 2; + Token := Tok_Arrow; + return; + + elsif Source (Scan_Ptr + 1) /= '-' then + Accumulate_Checksum ('-'); + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Minus; + return; + + -- Comment + + else -- Source (Scan_Ptr + 1) = '-' then + if Style_Check then + Style.Check_Comment; + end if; + + Scan_Ptr := Scan_Ptr + 2; + + -- If we are in preprocessor mode with Replace_In_Comments set, + -- then we return the "--" as a token on its own. + + if Replace_In_Comments then + Token := Tok_Comment; + return; + end if; + + -- Otherwise scan out the comment + + Start_Of_Comment := Scan_Ptr; + + -- Loop to scan comment (this loop runs more than once only if + -- a horizontal tab or other non-graphic character is scanned) + + loop + -- Scan to non graphic character (opened up for speed) + + -- Note that we just eat left brackets, which means that + -- bracket notation cannot be used for end of line + -- characters in comments. This seems a reasonable choice, + -- since no one would ever use brackets notation in a real + -- program in this situation, and if we allow brackets + -- notation, we forbid some valid comments which contain a + -- brackets sequence that happens to match an end of line + -- character. + + loop + exit when Source (Scan_Ptr) not in Graphic_Character; + Scan_Ptr := Scan_Ptr + 1; + exit when Source (Scan_Ptr) not in Graphic_Character; + Scan_Ptr := Scan_Ptr + 1; + exit when Source (Scan_Ptr) not in Graphic_Character; + Scan_Ptr := Scan_Ptr + 1; + exit when Source (Scan_Ptr) not in Graphic_Character; + Scan_Ptr := Scan_Ptr + 1; + exit when Source (Scan_Ptr) not in Graphic_Character; + Scan_Ptr := Scan_Ptr + 1; + end loop; + + -- Keep going if horizontal tab + + if Source (Scan_Ptr) = HT then + if Style_Check then + Style.Check_HT; + end if; + + Scan_Ptr := Scan_Ptr + 1; + + -- Terminate scan of comment if line terminator + + elsif Source (Scan_Ptr) in Line_Terminator then + exit; + + -- Terminate scan of comment if end of file encountered + -- (embedded EOF character or real last character in file) + + elsif Source (Scan_Ptr) = EOF then + exit; + + -- If we have a wide character, we have to scan it out, + -- because it might be a legitimate line terminator + + elsif Start_Of_Wide_Character then + declare + Wptr : constant Source_Ptr := Scan_Ptr; + Code : Char_Code; + Err : Boolean; + + begin + Scan_Wide (Source, Scan_Ptr, Code, Err); + + -- If not well formed wide character, then just skip + -- past it and ignore it. + + if Err then + Scan_Ptr := Wptr + 1; + + -- If UTF_32 terminator, terminate comment scan + + elsif Is_UTF_32_Line_Terminator (UTF_32 (Code)) then + Scan_Ptr := Wptr; + exit; + end if; + end; + + -- Keep going if character in 80-FF range, or is ESC. These + -- characters are allowed in comments by RM-2.1(1), 2.7(2). + -- They are allowed even in Ada 83 mode according to the + -- approved AI. ESC was added to the AI in June 93. + + elsif Source (Scan_Ptr) in Upper_Half_Character + or else Source (Scan_Ptr) = ESC + then + Scan_Ptr := Scan_Ptr + 1; + + -- Otherwise we have an illegal comment character + + else + Error_Illegal_Character; + end if; + end loop; + + -- Note that, except when comments are tokens, we do NOT + -- execute a return here, instead we fall through to reexecute + -- the scan loop to look for a token. + + if Comment_Is_Token then + Name_Len := Integer (Scan_Ptr - Start_Of_Comment); + Name_Buffer (1 .. Name_Len) := + String (Source (Start_Of_Comment .. Scan_Ptr - 1)); + Comment_Id := Name_Find; + Token := Tok_Comment; + return; + end if; + end if; + end Minus_Case; + + -- Double quote or percent starting a string literal + + when '"' | '%' => + Slit; + Post_Scan; + return; + + -- Apostrophe. This can either be the start of a character literal, + -- or an isolated apostrophe used in a qualified expression or an + -- attribute. We treat it as a character literal if it does not + -- follow a right parenthesis, identifier, the keyword ALL or + -- a literal. This means that we correctly treat constructs like: + + -- A := CHARACTER'('A'); + + -- Note that RM-2.2(7) does not require a separator between + -- "CHARACTER" and "'" in the above. + + when ''' => Char_Literal_Case : declare + Code : Char_Code; + Err : Boolean; + + begin + Accumulate_Checksum ('''); + Scan_Ptr := Scan_Ptr + 1; + + -- Here is where we make the test to distinguish the cases. Treat + -- as apostrophe if previous token is an identifier, right paren + -- or the reserved word "all" (latter case as in A.all'Address) + -- (or the reserved word "project" in project files). Also treat + -- it as apostrophe after a literal (this catches some legitimate + -- cases, like A."abs"'Address, and also gives better error + -- behavior for impossible cases like 123'xxx). + + if Prev_Token = Tok_Identifier + or else Prev_Token = Tok_Right_Paren + or else Prev_Token = Tok_All + or else Prev_Token = Tok_Project + or else Prev_Token in Token_Class_Literal + then + Token := Tok_Apostrophe; + + if Style_Check then + Style.Check_Apostrophe; + end if; + + return; + + -- Otherwise the apostrophe starts a character literal + + else + -- Case of wide character literal + + if Start_Of_Wide_Character then + Wptr := Scan_Ptr; + Scan_Wide (Source, Scan_Ptr, Code, Err); + Accumulate_Checksum (Code); + + if Err then + Error_Illegal_Wide_Character; + Code := Character'Pos (' '); + + -- In Ada 95 mode we allow any wide character in a character + -- literal, but in Ada 2005, the set of characters allowed + -- is restricted to graphic characters. + + elsif Ada_Version >= Ada_2005 + and then Is_UTF_32_Non_Graphic (UTF_32 (Code)) + then + Error_Msg -- CODEFIX???? + ("(Ada 2005) non-graphic character not permitted " & + "in character literal", Wptr); + end if; + + if Source (Scan_Ptr) /= ''' then + Error_Msg_S ("missing apostrophe"); + else + Scan_Ptr := Scan_Ptr + 1; + end if; + + -- If we do not find a closing quote in the expected place then + -- assume that we have a misguided attempt at a string literal. + + -- However, if previous token is RANGE, then we return an + -- apostrophe instead since this gives better error recovery + + elsif Source (Scan_Ptr + 1) /= ''' then + if Prev_Token = Tok_Range then + Token := Tok_Apostrophe; + return; + + else + Scan_Ptr := Scan_Ptr - 1; + Error_Msg_S + ("strings are delimited by double quote character"); + Slit; + Post_Scan; + return; + end if; + + -- Otherwise we have a (non-wide) character literal + + else + Accumulate_Checksum (Source (Scan_Ptr)); + + if Source (Scan_Ptr) not in Graphic_Character then + if Source (Scan_Ptr) in Upper_Half_Character then + if Ada_Version = Ada_83 then + Error_Illegal_Character; + end if; + + else + Error_Illegal_Character; + end if; + end if; + + Code := Get_Char_Code (Source (Scan_Ptr)); + Scan_Ptr := Scan_Ptr + 2; + end if; + + -- Fall through here with Scan_Ptr updated past the closing + -- quote, and Code set to the Char_Code value for the literal + + Accumulate_Checksum ('''); + Token := Tok_Char_Literal; + Set_Character_Literal_Name (Code); + Token_Name := Name_Find; + Character_Code := Code; + Post_Scan; + return; + end if; + end Char_Literal_Case; + + -- Right parenthesis + + when ')' => + Accumulate_Checksum (')'); + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Right_Paren; + + if Style_Check then + Style.Check_Right_Paren; + end if; + + return; + + -- Right bracket or right brace, treated as right paren + + when ']' | '}' => + Error_Msg_S ("illegal character, replaced by "")"""); + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Right_Paren; + return; + + -- Slash (can be division operator or first character of not equal) + + when '/' => + Accumulate_Checksum ('/'); + + if Double_Char_Token ('=') then + Token := Tok_Not_Equal; + return; + else + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Slash; + return; + end if; + + -- Semicolon + + when ';' => + Accumulate_Checksum (';'); + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Semicolon; + + if Style_Check then + Style.Check_Semicolon; + end if; + + return; + + -- Vertical bar + + when '|' => Vertical_Bar_Case : begin + Accumulate_Checksum ('|'); + + -- Special check for || to give nice message + + if Source (Scan_Ptr + 1) = '|' then + Error_Msg_S -- CODEFIX + ("""'|'|"" should be `OR ELSE`"); + Scan_Ptr := Scan_Ptr + 2; + Token := Tok_Or; + return; + + else + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Vertical_Bar; + + if Style_Check then + Style.Check_Vertical_Bar; + end if; + + Post_Scan; + return; + end if; + end Vertical_Bar_Case; + + -- Exclamation, replacement character for vertical bar + + when '!' => Exclamation_Case : begin + Accumulate_Checksum ('!'); + + if Source (Scan_Ptr + 1) = '=' then + Error_Msg_S -- CODEFIX + ("'!= should be /="); + Scan_Ptr := Scan_Ptr + 2; + Token := Tok_Not_Equal; + return; + + else + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Vertical_Bar; + Post_Scan; + return; + end if; + end Exclamation_Case; + + -- Plus + + when '+' => Plus_Case : begin + Accumulate_Checksum ('+'); + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Plus; + return; + end Plus_Case; + + -- Digits starting a numeric literal + + when '0' .. '9' => + + -- First a bit of a scan ahead to see if we have a case of an + -- identifier starting with a digit (remembering exponent case). + + declare + C : constant Character := Source (Scan_Ptr + 1); + + begin + -- OK literal if digit followed by digit or underscore + + if C in '0' .. '9' or else C = '_' then + null; + + -- OK literal if digit not followed by identifier char + + elsif not Identifier_Char (C) then + null; + + -- OK literal if digit followed by e/E followed by digit/sign. + -- We also allow underscore after the E, which is an error, but + -- better handled by Nlit than deciding this is an identifier. + + elsif (C = 'e' or else C = 'E') + and then (Source (Scan_Ptr + 2) in '0' .. '9' + or else Source (Scan_Ptr + 2) = '+' + or else Source (Scan_Ptr + 2) = '-' + or else Source (Scan_Ptr + 2) = '_') + then + null; + + -- Here we have what really looks like an identifier that + -- starts with a digit, so give error msg. + + else + Error_Msg_S ("identifier may not start with digit"); + Name_Len := 1; + Underline_Found := False; + Name_Buffer (1) := Source (Scan_Ptr); + Accumulate_Checksum (Name_Buffer (1)); + Scan_Ptr := Scan_Ptr + 1; + goto Scan_Identifier; + end if; + end; + + -- Here we have an OK integer literal + + Nlit; + + -- Check for proper delimiter, ignoring other format characters + + Skip_Other_Format_Characters; + + if Identifier_Char (Source (Scan_Ptr)) then + Error_Msg_S + ("delimiter required between literal and identifier"); + end if; + + Post_Scan; + return; + + -- Lower case letters + + when 'a' .. 'z' => + Name_Len := 1; + Underline_Found := False; + Name_Buffer (1) := Source (Scan_Ptr); + Accumulate_Checksum (Name_Buffer (1)); + Scan_Ptr := Scan_Ptr + 1; + goto Scan_Identifier; + + -- Upper case letters + + when 'A' .. 'Z' => + Name_Len := 1; + Underline_Found := False; + Name_Buffer (1) := + Character'Val (Character'Pos (Source (Scan_Ptr)) + 32); + Accumulate_Checksum (Name_Buffer (1)); + Scan_Ptr := Scan_Ptr + 1; + goto Scan_Identifier; + + -- Underline character + + when '_' => + if Special_Characters ('_') then + Token_Ptr := Scan_Ptr; + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Special; + Special_Character := '_'; + return; + end if; + + Error_Msg_S ("identifier cannot start with underline"); + Name_Len := 1; + Name_Buffer (1) := '_'; + Scan_Ptr := Scan_Ptr + 1; + Underline_Found := False; + goto Scan_Identifier; + + -- Space (not possible, because we scanned past blanks) + + when ' ' => + raise Program_Error; + + -- Characters in top half of ASCII 8-bit chart + + when Upper_Half_Character => + + -- Wide character case + + if Upper_Half_Encoding then + goto Scan_Wide_Character; + + -- Otherwise we have OK Latin-1 character + + else + -- Upper half characters may possibly be identifier letters + -- but can never be digits, so Identifier_Char can be used to + -- test for a valid start of identifier character. + + if Identifier_Char (Source (Scan_Ptr)) then + Name_Len := 0; + Underline_Found := False; + goto Scan_Identifier; + else + Error_Illegal_Character; + end if; + end if; + + when ESC => + + -- ESC character, possible start of identifier if wide characters + -- using ESC encoding are allowed in identifiers, which we can + -- tell by looking at the Identifier_Char flag for ESC, which is + -- only true if these conditions are met. In Ada 2005 mode, may + -- also be valid UTF_32 space or line terminator character. + + if Identifier_Char (ESC) then + Name_Len := 0; + goto Scan_Wide_Character; + else + Error_Illegal_Character; + end if; + + -- Invalid control characters + + when NUL | SOH | STX | ETX | EOT | ENQ | ACK | BEL | BS | ASCII.SO | + SI | DLE | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN | + EM | FS | GS | RS | US | DEL + => + Error_Illegal_Character; + + -- Invalid graphic characters + + when '#' | '$' | '?' | '@' | '`' | '\' | '^' | '~' => + + -- If Set_Special_Character has been called for this character, + -- set Scans.Special_Character and return a Special token. + + if Special_Characters (Source (Scan_Ptr)) then + Token_Ptr := Scan_Ptr; + Token := Tok_Special; + Special_Character := Source (Scan_Ptr); + Scan_Ptr := Scan_Ptr + 1; + return; + + -- Otherwise, this is an illegal character + + else + Error_Illegal_Character; + end if; + + -- End switch on non-blank character + + end case; + + -- End loop past format effectors. The exit from this loop is by + -- executing a return statement following completion of token scan + -- (control never falls out of this loop to the code which follows) + + end loop; + + -- Wide_Character scanning routine. On entry we have encountered the + -- initial character of a wide character sequence. + + <> + + declare + Code : Char_Code; + Cat : Category; + Err : Boolean; + + begin + Wptr := Scan_Ptr; + Scan_Wide (Source, Scan_Ptr, Code, Err); + + -- If bad wide character, signal error and continue scan + + if Err then + Error_Illegal_Wide_Character; + goto Scan_Next_Character; + end if; + + Cat := Get_Category (UTF_32 (Code)); + + -- If OK letter, reset scan ptr and go scan identifier + + if Is_UTF_32_Letter (Cat) then + Scan_Ptr := Wptr; + Name_Len := 0; + Underline_Found := False; + goto Scan_Identifier; + + -- If OK wide space, ignore and keep scanning (we do not include + -- any ignored spaces in checksum) + + elsif Is_UTF_32_Space (Cat) then + goto Scan_Next_Character; + + -- If other format character, ignore and keep scanning (again we + -- do not include in the checksum) (this is for AI-0079). + + elsif Is_UTF_32_Other (Cat) then + goto Scan_Next_Character; + + -- If OK wide line terminator, terminate current line + + elsif Is_UTF_32_Line_Terminator (UTF_32 (Code)) then + Scan_Ptr := Wptr; + goto Scan_Line_Terminator; + + -- Punctuation is an error (at start of identifier) + + elsif Is_UTF_32_Punctuation (Cat) then + Error_Msg ("identifier cannot start with punctuation", Wptr); + Scan_Ptr := Wptr; + Name_Len := 0; + Underline_Found := False; + goto Scan_Identifier; + + -- Mark character is an error (at start of identifier) + + elsif Is_UTF_32_Mark (Cat) then + Error_Msg ("identifier cannot start with mark character", Wptr); + Scan_Ptr := Wptr; + Name_Len := 0; + Underline_Found := False; + goto Scan_Identifier; + + -- Extended digit character is an error. Could be bad start of + -- identifier or bad literal. Not worth doing too much to try to + -- distinguish these cases, but we will do a little bit. + + elsif Is_UTF_32_Digit (Cat) then + Error_Msg + ("identifier cannot start with digit character", Wptr); + Scan_Ptr := Wptr; + Name_Len := 0; + Underline_Found := False; + goto Scan_Identifier; + + -- All other wide characters are illegal here + + else + Error_Illegal_Wide_Character; + goto Scan_Next_Character; + end if; + end; + + -- Routine to scan line terminator. On entry Scan_Ptr points to a + -- character which is one of FF,LR,CR,VT, or one of the wide characters + -- that is treated as a line terminator. + + <> + + -- Check line too long + + Check_End_Of_Line; + + -- Set Token_Ptr, if End_Of_Line is a token, for the case when it is + -- a physical line. + + if End_Of_Line_Is_Token then + Token_Ptr := Scan_Ptr; + end if; + + declare + Physical : Boolean; + + begin + Skip_Line_Terminators (Scan_Ptr, Physical); + + -- If we are at start of physical line, update scan pointers to + -- reflect the start of the new line. + + if Physical then + Current_Line_Start := Scan_Ptr; + Start_Column := Set_Start_Column; + First_Non_Blank_Location := Scan_Ptr; + + -- If End_Of_Line is a token, we return it as it is a + -- physical line. + + if End_Of_Line_Is_Token then + Token := Tok_End_Of_Line; + return; + end if; + end if; + end; + + goto Scan_Next_Character; + + -- Identifier scanning routine. On entry, some initial characters of + -- the identifier may have already been stored in Name_Buffer. If so, + -- Name_Len has the number of characters stored, otherwise Name_Len is + -- set to zero on entry. Underline_Found is also set False on entry. + + <> + + -- This loop scans as fast as possible past lower half letters and + -- digits, which we expect to be the most common characters. + + loop + if Source (Scan_Ptr) in 'a' .. 'z' + or else Source (Scan_Ptr) in '0' .. '9' + then + Name_Buffer (Name_Len + 1) := Source (Scan_Ptr); + Accumulate_Checksum (Source (Scan_Ptr)); + + elsif Source (Scan_Ptr) in 'A' .. 'Z' then + Name_Buffer (Name_Len + 1) := + Character'Val (Character'Pos (Source (Scan_Ptr)) + 32); + Accumulate_Checksum (Name_Buffer (Name_Len + 1)); + + else + exit; + end if; + + Underline_Found := False; + Scan_Ptr := Scan_Ptr + 1; + Name_Len := Name_Len + 1; + end loop; + + -- If we fall through, then we have encountered either an underline + -- character, or an extended identifier character (i.e. one from the + -- upper half), or a wide character, or an identifier terminator. The + -- initial test speeds us up in the most common case where we have + -- an identifier terminator. Note that ESC is an identifier character + -- only if a wide character encoding method that uses ESC encoding + -- is active, so if we find an ESC character we know that we have a + -- wide character. + + if Identifier_Char (Source (Scan_Ptr)) + or else (Source (Scan_Ptr) in Upper_Half_Character + and then Upper_Half_Encoding) + then + -- Case of underline + + if Source (Scan_Ptr) = '_' then + Accumulate_Checksum ('_'); + + if Underline_Found then + Error_No_Double_Underline; + else + Underline_Found := True; + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := '_'; + end if; + + Scan_Ptr := Scan_Ptr + 1; + goto Scan_Identifier; + + -- Upper half character + + elsif Source (Scan_Ptr) in Upper_Half_Character + and then not Upper_Half_Encoding + then + Accumulate_Checksum (Source (Scan_Ptr)); + Store_Encoded_Character + (Get_Char_Code (Fold_Lower (Source (Scan_Ptr)))); + Scan_Ptr := Scan_Ptr + 1; + Underline_Found := False; + goto Scan_Identifier; + + -- Left bracket not followed by a quote terminates an identifier. + -- This is an error, but we don't want to give a junk error msg + -- about wide characters in this case! + + elsif Source (Scan_Ptr) = '[' + and then Source (Scan_Ptr + 1) /= '"' + then + null; + + -- We know we have a wide character encoding here (the current + -- character is either ESC, left bracket, or an upper half + -- character depending on the encoding method). + + else + -- Scan out the wide character and insert the appropriate + -- encoding into the name table entry for the identifier. + + declare + Code : Char_Code; + Err : Boolean; + Chr : Character; + Cat : Category; + + begin + Wptr := Scan_Ptr; + Scan_Wide (Source, Scan_Ptr, Code, Err); + + -- If error, signal error + + if Err then + Error_Illegal_Wide_Character; + + -- If the character scanned is a normal identifier + -- character, then we treat it that way. + + elsif In_Character_Range (Code) + and then Identifier_Char (Get_Character (Code)) + then + Chr := Get_Character (Code); + Accumulate_Checksum (Chr); + Store_Encoded_Character + (Get_Char_Code (Fold_Lower (Chr))); + Underline_Found := False; + + -- Here if not a normal identifier character + + else + Cat := Get_Category (UTF_32 (Code)); + + -- Wide character in Unicode category "Other, Format" + -- is not accepted in an identifier. This is because it + -- it is considered a security risk (AI-0091). + + -- However, it is OK for such a character to appear at + -- the end of an identifier. + + if Is_UTF_32_Other (Cat) then + if not Identifier_Char (Source (Scan_Ptr)) then + goto Scan_Identifier_Complete; + else + Error_Msg + ("identifier cannot contain other_format " + & "character", Wptr); + goto Scan_Identifier; + end if; + + -- Wide character in category Separator,Space terminates + + elsif Is_UTF_32_Space (Cat) then + goto Scan_Identifier_Complete; + end if; + + -- Here if wide character is part of the identifier + + -- Make sure we are allowing wide characters in + -- identifiers. Note that we allow wide character + -- notation for an OK identifier character. This in + -- particular allows bracket or other notation to be + -- used for upper half letters. + + -- Wide characters are always allowed in Ada 2005 + + if Identifier_Character_Set /= 'w' + and then Ada_Version < Ada_2005 + then + Error_Msg + ("wide character not allowed in identifier", Wptr); + end if; + + -- If OK letter, store it folding to upper case. Note + -- that we include the folded letter in the checksum. + + if Is_UTF_32_Letter (Cat) then + Code := + Char_Code (UTF_32_To_Upper_Case (UTF_32 (Code))); + Accumulate_Checksum (Code); + Store_Encoded_Character (Code); + Underline_Found := False; + + -- If OK extended digit or mark, then store it + + elsif Is_UTF_32_Digit (Cat) + or else Is_UTF_32_Mark (Cat) + then + Accumulate_Checksum (Code); + Store_Encoded_Character (Code); + Underline_Found := False; + + -- Wide punctuation is also stored, but counts as an + -- underline character for error checking purposes. + + elsif Is_UTF_32_Punctuation (Cat) then + Accumulate_Checksum (Code); + + if Underline_Found then + declare + Cend : constant Source_Ptr := Scan_Ptr; + begin + Scan_Ptr := Wptr; + Error_No_Double_Underline; + Scan_Ptr := Cend; + end; + + else + Store_Encoded_Character (Code); + Underline_Found := True; + end if; + + -- Any other wide character is not acceptable + + else + Error_Msg + ("invalid wide character in identifier", Wptr); + end if; + end if; + + goto Scan_Identifier; + end; + end if; + end if; + + -- Scan of identifier is complete. The identifier is stored in + -- Name_Buffer, and Scan_Ptr points past the last character. + + <> + Token_Name := Name_Find; + + -- Check for identifier ending with underline or punctuation char + + if Underline_Found then + Underline_Found := False; + + if Source (Scan_Ptr - 1) = '_' then + Error_Msg + ("identifier cannot end with underline", Scan_Ptr - 1); + else + Error_Msg + ("identifier cannot end with punctuation character", Wptr); + end if; + end if; + + -- We will assume it is an identifier, not a keyword, so that the + -- checksum is independent of the Ada version. + + Token := Tok_Identifier; + + -- Here is where we check if it was a keyword + + if Is_Keyword_Name (Token_Name) then + if Opt.Checksum_GNAT_6_3 then + Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name)); + + if Checksum_Accumulate_Token_Checksum then + if Checksum_GNAT_5_03 then + Accumulate_Token_Checksum_GNAT_5_03; + else + Accumulate_Token_Checksum_GNAT_6_3; + end if; + end if; + + else + Accumulate_Token_Checksum; + Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name)); + end if; + + -- Keyword style checks + + if Style_Check then + + -- Deal with possible style check for non-lower case keyword, + -- but we don't treat ACCESS, DELTA, DIGITS, RANGE as keywords + -- for this purpose if they appear as attribute designators. + -- Actually we only check the first character for speed. + + -- Ada 2005 (AI-284): Do not apply the style check in case of + -- "pragma Interface" + + -- Ada 2005 (AI-340): Do not apply the style check in case of + -- MOD attribute. + + if Source (Token_Ptr) <= 'Z' + and then (Prev_Token /= Tok_Apostrophe + or else + (Token /= Tok_Access and then + Token /= Tok_Delta and then + Token /= Tok_Digits and then + Token /= Tok_Mod and then + Token /= Tok_Range)) + and then (Token /= Tok_Interface + or else + (Token = Tok_Interface + and then Prev_Token /= Tok_Pragma)) + then + Style.Non_Lower_Case_Keyword; + end if; + + -- Check THEN/ELSE style rules. These do not apply to AND THEN + -- or OR ELSE, and do not apply in conditional expressions. + + if (Token = Tok_Then and then Prev_Token /= Tok_And) + or else + (Token = Tok_Else and then Prev_Token /= Tok_Or) + then + if Inside_Conditional_Expression = 0 then + Style.Check_Separate_Stmt_Lines; + end if; + end if; + end if; + + -- We must reset Token_Name since this is not an identifier and + -- if we leave Token_Name set, the parser gets confused because + -- it thinks it is dealing with an identifier instead of the + -- corresponding keyword. + + Token_Name := No_Name; + return; + + -- It is an identifier after all + + else + if Checksum_Accumulate_Token_Checksum then + Accumulate_Token_Checksum; + end if; + + Post_Scan; + return; + end if; + end Scan; + + -------------------------- + -- Set_Comment_As_Token -- + -------------------------- + + procedure Set_Comment_As_Token (Value : Boolean) is + begin + Comment_Is_Token := Value; + end Set_Comment_As_Token; + + ------------------------------ + -- Set_End_Of_Line_As_Token -- + ------------------------------ + + procedure Set_End_Of_Line_As_Token (Value : Boolean) is + begin + End_Of_Line_Is_Token := Value; + end Set_End_Of_Line_As_Token; + + --------------------------- + -- Set_Special_Character -- + --------------------------- + + procedure Set_Special_Character (C : Character) is + begin + case C is + when '#' | '$' | '_' | '?' | '@' | '`' | '\' | '^' | '~' => + Special_Characters (C) := True; + + when others => + null; + end case; + end Set_Special_Character; + + ---------------------- + -- Set_Start_Column -- + ---------------------- + + -- Note: it seems at first glance a little expensive to compute this value + -- for every source line (since it is certainly not used for all source + -- lines). On the other hand, it doesn't take much more work to skip past + -- the initial white space on the line counting the columns than it would + -- to scan past the white space using the standard scanning circuits. + + function Set_Start_Column return Column_Number is + Start_Column : Column_Number := 0; + + begin + -- Outer loop scans past horizontal tab characters + + Tabs_Loop : loop + + -- Inner loop scans past blanks as fast as possible, bumping Scan_Ptr + -- past the blanks and adjusting Start_Column to account for them. + + Blanks_Loop : loop + if Source (Scan_Ptr) = ' ' then + if Source (Scan_Ptr + 1) = ' ' then + if Source (Scan_Ptr + 2) = ' ' then + if Source (Scan_Ptr + 3) = ' ' then + if Source (Scan_Ptr + 4) = ' ' then + if Source (Scan_Ptr + 5) = ' ' then + if Source (Scan_Ptr + 6) = ' ' then + Scan_Ptr := Scan_Ptr + 7; + Start_Column := Start_Column + 7; + else + Scan_Ptr := Scan_Ptr + 6; + Start_Column := Start_Column + 6; + exit Blanks_Loop; + end if; + else + Scan_Ptr := Scan_Ptr + 5; + Start_Column := Start_Column + 5; + exit Blanks_Loop; + end if; + else + Scan_Ptr := Scan_Ptr + 4; + Start_Column := Start_Column + 4; + exit Blanks_Loop; + end if; + else + Scan_Ptr := Scan_Ptr + 3; + Start_Column := Start_Column + 3; + exit Blanks_Loop; + end if; + else + Scan_Ptr := Scan_Ptr + 2; + Start_Column := Start_Column + 2; + exit Blanks_Loop; + end if; + else + Scan_Ptr := Scan_Ptr + 1; + Start_Column := Start_Column + 1; + exit Blanks_Loop; + end if; + else + exit Blanks_Loop; + end if; + end loop Blanks_Loop; + + -- Outer loop keeps going only if a horizontal tab follows + + if Source (Scan_Ptr) = HT then + if Style_Check then + Style.Check_HT; + end if; + + Scan_Ptr := Scan_Ptr + 1; + Start_Column := (Start_Column / 8) * 8 + 8; + else + exit Tabs_Loop; + end if; + end loop Tabs_Loop; + + return Start_Column; + + -- A constraint error can happen only if we have a compiler with checks on + -- and a line with a ludicrous number of tabs or spaces at the start. In + -- such a case, we really don't care if Start_Column is right or not. + + exception + when Constraint_Error => + return Start_Column; + end Set_Start_Column; + +end Scng; diff --git a/gcc/ada/scng.ads b/gcc/ada/scng.ads new file mode 100644 index 000000000..d9035119f --- /dev/null +++ b/gcc/ada/scng.ads @@ -0,0 +1,100 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S C N G -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 generic lexical analyzer. This is used for scanning +-- Ada source files or text files with an Ada-like syntax, such as project +-- files. It is instantiated in Scn and Prj.Err. + +with Casing; use Casing; +with Styleg; +with Types; use Types; + +generic + with procedure Post_Scan; + -- Procedure called by Scan for the following tokens: Tok_Char_Literal, + -- Tok_Identifier, Tok_Real_Literal, Tok_Real_Literal, Tok_Integer_Literal, + -- Tok_String_Literal, Tok_Operator_Symbol, and Tok_Vertical_Bar. Used to + -- build Token_Node and also check for obsolescent features. + + with procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr); + -- Output a message at specified location + + with procedure Error_Msg_S (Msg : String); + -- Output a message at current scan pointer location + + with procedure Error_Msg_SC (Msg : String); + -- Output a message at the start of the current token + + with procedure Error_Msg_SP (Msg : String); + -- Output a message at the start of the previous token + + with package Style is new Styleg + (Error_Msg, Error_Msg_S, Error_Msg_SC, Error_Msg_SP); + -- Instantiation of Styleg with the same error reporting routines + +package Scng is + + procedure Initialize_Scanner (Index : Source_File_Index); + -- Initialize lexical scanner for scanning a new file referenced by Index. + -- Initialize_Scanner does not call Scan. + + procedure Scan; + -- Scan scans out the next token, and advances the scan state accordingly + -- (see package Scan_State for details). If the scan encounters an illegal + -- token, then an error message is issued pointing to the bad character, + -- and Scan returns a reasonable substitute token of some kind. + -- For tokens Char_Literal, Identifier, Real_Literal, Integer_Literal, + -- String_Literal and Operator_Symbol, Post_Scan is called after scanning. + + function Determine_Token_Casing return Casing_Type; + pragma Inline (Determine_Token_Casing); + -- Determines the casing style of the current token, which is + -- either a keyword or an identifier. See also package Casing. + + procedure Set_Special_Character (C : Character); + -- Indicate that one of the following character '#', '$', '?', '@', '`', + -- '\', '^', '_' or '~', when found is a Special token. + + procedure Reset_Special_Characters; + -- Indicate that there is no characters that are Special tokens., which + -- is the default. + + procedure Set_End_Of_Line_As_Token (Value : Boolean); + -- Indicate if End_Of_Line is a token or not. + -- By default, End_Of_Line is not a token. + + procedure Set_Comment_As_Token (Value : Boolean); + -- Indicate if a comment is a token or not. + -- By default, a comment is not a token. + + function Set_Start_Column return Column_Number; + -- This routine is called with Scan_Ptr pointing to the first character + -- of a line. On exit, Scan_Ptr is advanced to the first non-blank + -- character of this line (or to the terminating format effector if the + -- line contains no non-blank characters), and the returned result is the + -- column number of this non-blank character (zero origin), which is the + -- value to be stored in the Start_Column scan variable. + +end Scng; diff --git a/gcc/ada/scos.adb b/gcc/ada/scos.adb new file mode 100644 index 000000000..c559e6f8d --- /dev/null +++ b/gcc/ada/scos.adb @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S C O S -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body SCOs is + + ------------- + -- Add_SCO -- + ------------- + + procedure Add_SCO + (From : Source_Location := No_Source_Location; + To : Source_Location := No_Source_Location; + C1 : Character := ' '; + C2 : Character := ' '; + Last : Boolean := False) + is + begin + SCO_Table.Append ((From, To, C1, C2, Last)); + end Add_SCO; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + SCO_Table.Init; + SCO_Unit_Table.Init; + + -- Set dummy zeroth entry for sort routine, real entries start at 1 + + SCO_Unit_Table.Increment_Last; + end Initialize; + +end SCOs; diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads new file mode 100644 index 000000000..fbb7e90ee --- /dev/null +++ b/gcc/ada/scos.ads @@ -0,0 +1,472 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S C O S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package defines tables used to store Source Coverage Obligations. It +-- is used by Par_SCO to build the SCO information before writing it out to +-- the ALI file, and by Get_SCO/Put_SCO to read and write the text form that +-- is used in the ALI file. + +with Types; use Types; + +with GNAT.Table; + +package SCOs is + + -- SCO information can exist in one of two forms. In the ALI file, it is + -- represented using a text format that is described in this specification. + -- Internally it is stored using two tables SCO_Table and SCO_Unit_Table, + -- which are also defined in this unit. + + -- Par_SCO is part of the compiler. It scans the parsed source tree and + -- populates the internal tables. + + -- Get_SCO reads the text lines in ALI format and populates the internal + -- tables with corresponding information. + + -- Put_SCO reads the internal tables and generates text lines in the ALI + -- format. + + -------------------- + -- SCO ALI Format -- + -------------------- + + -- Source coverage obligations are generated on a unit-by-unit basis in the + -- ALI file, using lines that start with the identifying character C. These + -- lines are generated if the -gnateS switch is set. + + -- Sloc Ranges + + -- In several places in the SCO lines, Sloc ranges appear. These are used + -- to indicate the first and last Sloc of some construct in the tree and + -- they have the form: + + -- line:col-line:col + + -- Note that SCO's are generated only for generic templates, not for + -- generic instances (since only the first are part of the source). So + -- we don't need generic instantiation stuff in these line:col items. + + -- SCO File headers + + -- The SCO information follows the cross-reference information, so it + -- need not be read by tools like gnatbind, gnatmake etc. The SCO output + -- is divided into sections, one section for each unit for which SCO's + -- are generated. A SCO section has a header of the form: + + -- C dependency-number filename + + -- This header precedes SCO information for the unit identified by + -- dependency number and file name. The dependency number is the + -- index into the generated D lines and is ones origin (i.e. 2 = + -- reference to second generated D line). + + -- Note that the filename here will reflect the original name if + -- a Source_Reference pragma was encountered (since all line number + -- references will be with respect to the original file). + + -- Note: the filename is redundant in that it could be deduced from + -- the corresponding D line, but it is convenient at least for human + -- reading of the SCO information, and means that the SCO information + -- can stand on its own without needing other parts of the ALI file. + + -- Statements + + -- For the purpose of SCO generation, the notion of statement includes + -- simple statements and also the following declaration types: + + -- type_declaration + -- subtype_declaration + -- object_declaration + -- renaming_declaration + -- generic_instantiation + + -- and the following regions of the syntax tree: + + -- the part of a case_statement from CASE up to the expression + -- the part of a FOR loop iteration scheme from FOR up to the + -- loop_parameter_specification + -- the part of a WHILE loop up to the condition + -- the part of an extended_return_statement from RETURN up to the + -- expression (if present) or to the return_subtype_indication (if + -- no expression) + + -- and any pragma that occurs at a place where a statement or declaration + -- is allowed. + + -- Statement lines + + -- These lines correspond to one or more successive statements (in the + -- sense of the above list) which are always executed in sequence (in the + -- absence of exceptions or other external interruptions). + + -- Entry points to such sequences are: + + -- the first declaration of any declarative_part + -- the first statement of any sequence_of_statements that is not in a + -- body or block statement that has a non-empty declarative part + -- the first statement after a compound statement + -- the first statement after an EXIT, RAISE or GOTO statement + -- any statement with a label (the label itself is not part of the + -- entry point that is recorded). + + -- Each entry point must appear as the first entry on a CS line. + -- The idea is that if any simple statement on a CS line is known to have + -- been executed, then all statements that appear before it on the same + -- CS line are certain to also have been executed. + + -- The form of a statement line in the ALI file is: + + -- CS *sloc-range [*sloc-range...] + + -- where each sloc-range corresponds to a single statement, and * is + -- one of: + + -- t type declaration + -- s subtype declaration + -- o object declaration + -- r renaming declaration + -- i generic instantiation + -- C CASE statement (from CASE through end of expression) + -- E EXIT statement + -- F FOR loop statement (from FOR through end of iteration scheme) + -- I IF statement (from IF through end of condition) + -- P PRAGMA + -- R extended RETURN statement + -- W WHILE loop statement (from WHILE through end of condition) + + -- Note: for I and W, condition above is in the RM syntax sense (this + -- condition is a decision in SCO terminology). + + -- and is omitted for all other cases + + -- Note: up to 6 entries can appear on a single CS line. If more than 6 + -- entries appear in one logical statement sequence, continuation lines + -- are marked by Cs and appear immediately after the CS line. + + -- Decisions + + -- Note: in the following description, logical operator includes only the + -- short-circuited forms and NOT (so can be only NOT, AND THEN, OR ELSE). + -- The reason that we can exclude AND/OR/XOR is that we expect SCO's to + -- be generated using the restriction No_Direct_Boolean_Operators if we + -- are interested in decision coverage, which does not permit the use of + -- AND/OR/XOR on boolean operands. These are permitted on modular integer + -- types, but such operations do not count as decisions in any case. If + -- we are generating SCO's only for simple coverage, then we are not + -- interested in decisions in any case. + + -- Note: the reason we include NOT is for informational purposes. The + -- presence of NOT does not generate additional coverage obligations, + -- but if we know where the NOT's are, the coverage tool can generate + -- more accurate diagnostics on uncovered tests. + + -- A top level boolean expression is a boolean expression that is not an + -- operand of a logical operator. + + -- Decisions are either simple or complex. A simple decision is a top + -- level boolean expression that has only one condition and that occurs + -- in the context of a control structure in the source program, including + -- WHILE, IF, EXIT WHEN, or in an Assert, Check, Pre_Condition or + -- Post_Condition pragma. For pragmas, decision SCOs are generated only + -- if the corresponding pragma is enabled. Note that a top level boolean + -- expression with only one condition that occurs in any other context, + -- for example as right hand side of an assignment, is not considered to + -- be a (simple) decision. + + -- A complex decision is a top level boolean expression that has more + -- than one condition. A complex decision may occur in any boolean + -- expression context. + + -- So for example, if we have + + -- A, B, C, D : Boolean; + -- function F (Arg : Boolean) return Boolean); + -- ... + -- A and then (B or else F (C and then D)) + + -- There are two (complex) decisions here: + + -- 1. X and then (Y or else Z) + + -- where X = A, Y = B, and Z = F (C and then D) + + -- 2. C and then D + + -- For each decision, a decision line is generated with the form: + + -- C* sloc expression [chaining] + + -- Here * is one of the following characters: + + -- I decision in IF statement or conditional expression + -- E decision in EXIT WHEN statement + -- P decision in pragma Assert/Check/Pre_Condition/Post_Condition + -- W decision in WHILE iteration scheme + -- X decision appearing in some other expression context + + -- For I, E, P, W, sloc is the source location of the IF, EXIT, PRAGMA or + -- WHILE token. + + -- For X, sloc is omitted + + -- The expression is a prefix polish form indicating the structure of + -- the decision, including logical operators and short-circuit forms. + -- The following is a grammar showing the structure of expression: + + -- expression ::= term (if expr is not logical operator) + -- expression ::= &sloc term term (if expr is AND or AND THEN) + -- expression ::= |sloc term term (if expr is OR or OR ELSE) + -- expression ::= !sloc term (if expr is NOT) + + -- In the last three cases, sloc is the source location of the AND, OR, + -- or NOT token, respectively. + + -- term ::= element + -- term ::= expression + + -- element ::= outcome sloc-range + + -- outcome is one of the following letters: + + -- c condition + -- t true condition + -- f false condition + + -- where t/f are used to mark a condition that has been recognized by + -- the compiler as always being true or false. + + -- & indicates AND THEN connecting two conditions + + -- | indicates OR ELSE connecting two conditions + + -- ! indicates NOT applied to the expression + + -- Note that complex decisions do NOT include non-short-circuited logical + -- operators (AND/XOR/OR). In the context of existing coverage tools the + -- No_Direct_Boolean_Operators restriction is assumed, so these operators + -- cannot appear in the source in any case. + + -- The SCO line for a decision always occurs after the CS line for the + -- enclosing statement. The SCO line for a nested decision always occurs + -- after the line for the enclosing decision. + + -- Note that membership tests are considered to be a single simple + -- condition, and that is true even if the Ada 2005 set membership + -- form is used, e.g. A in (2,7,11.15). + + -- The expression can be followed by chaining indicators of the form + -- Tsloc-range or Fsloc-range. + + -- T* is present when the statement with the given sloc range is executed + -- if, and only if, the decision evaluates to TRUE. + + -- F* is present when the statement with the given sloc range is executed + -- if, and only if, the decision evaluates to FALSE. + + -- For an IF statement or ELSIF part, a T chaining indicator is always + -- present, with the sloc range of the first statement in the + -- corresponding sequence. + + -- For an ELSE part, the last decision in the IF statement (that of the + -- last ELSIF part, if any, or that of the IF statement if there is no + -- ELSIF part) has an F chaining indicator with the sloc range of the + -- first statement in the sequence of the ELSE part. + + -- For a WHILE loop, a T chaining indicator is always present, with the + -- sloc range of the first statement in the loop, but no F chaining + -- indicator is ever present. + + -- For an EXIT WHEN statement, an F chaining indicator is present if + -- there is an immediately following sequence in the same sequence of + -- statements. + + -- In all other cases, chaining indicators are omitted + + -- Case Expressions + + -- For case statements, we rely on statement coverage to make sure that + -- all branches of a case statement are covered, but that does not work + -- for case expressions, since the entire expression is contained in a + -- single statement. However, for complete coverage we really should be + -- able to check that every branch of the case statement is covered, so + -- we generate a SCO of the form: + + -- CC sloc-range sloc-range ... + + -- where sloc-range covers the range of the case expression + + -- Note: up to 6 entries can appear on a single CC line. If more than 6 + -- entries appear in one logical statement sequence, continuation lines + -- are marked by Cc and appear immediately after the CC line. + + --------------------------------------------------------------------- + -- Internal table used to store Source Coverage Obligations (SCOs) -- + --------------------------------------------------------------------- + + type Source_Location is record + Line : Logical_Line_Number; + Col : Column_Number; + end record; + + No_Source_Location : Source_Location := (No_Line_Number, No_Column_Number); + + type SCO_Table_Entry is record + From : Source_Location; + To : Source_Location; + C1 : Character; + C2 : Character; + Last : Boolean; + end record; + + package SCO_Table is new GNAT.Table ( + Table_Component_Type => SCO_Table_Entry, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 500, + Table_Increment => 300); + + -- The SCO_Table_Entry values appear as follows: + + -- Statements + -- C1 = 'S' for entry point, 's' otherwise + -- C2 = statement type code to appear on CS line (or ' ' if none) + -- From = starting source location + -- To = ending source location + -- Last = False for all but the last entry, True for last entry + + -- Note: successive statements (possibly interspersed with entries of + -- other kinds, that are ignored for this purpose), starting with one + -- labeled with C1 = 'S', up to and including the first one labeled with + -- Last = True, indicate the sequence to be output for a sequence of + -- statements on a single CS line (possibly followed by Cs continuation + -- lines). + + -- Decision (IF/EXIT/WHILE) + -- C1 = 'I'/'E'/'W' (for IF/EXIT/WHILE) + -- C2 = ' ' + -- From = IF/EXIT/WHILE token + -- To = No_Source_Location + -- Last = unused + + -- Decision (PRAGMA) + -- C1 = 'P' + -- C2 = 'e'/'d' for enabled/disabled + -- From = PRAGMA token + -- To = No_Source_Location + -- Last = unused + + -- Note: when the parse tree is first scanned, we unconditionally build + -- a pragma decision entry for any decision in a pragma (here as always + -- in SCO contexts, the only pragmas with decisions are Assert, Check, + -- Precondition and Postcondition), and we mark the pragma as disabled. + -- + -- During analysis, if the pragma is enabled, Set_SCO_Pragma_Enabled to + -- mark the SCO decision table entry as enabled (C2 set to 'e'). Then + -- in Put_SCOs, we only output the decision for a pragma if C2 is 'e'. + -- + -- When we read SCOs from an ALI file (in Get_SCOs), we always set C2 + -- to 'e', since clearly the pragma is enabled if it was written out. + + -- Decision (Expression) + -- C1 = 'X' + -- C2 = ' ' + -- From = No_Source_Location + -- To = No_Source_Location + -- Last = unused + + -- Operator + -- C1 = '!', '&', '|' + -- C2 = ' ' + -- From = location of NOT/AND/OR token + -- To = No_Source_Location + -- Last = False + + -- Element (condition) + -- C1 = ' ' + -- C2 = 'c', 't', or 'f' (condition/true/false) + -- From = starting source location + -- To = ending source location + -- Last = False for all but the last entry, True for last entry + + -- Element (chaining indicator) + -- C1 = 'H' (cHain) + -- C2 = 'T' or 'F' (chaining on decision true/false) + -- From = starting source location of chained statement + -- To = ending source location of chained statement + + -- Note: the sequence starting with a decision, and continuing with + -- operators and elements up to and including the first one labeled with + -- Last = True, indicate the sequence to be output on one decision line. + + ---------------- + -- Unit Table -- + ---------------- + + -- This table keeps track of the units and the corresponding starting and + -- ending indexes (From, To) in the SCO table. Note that entry zero is + -- unused, it is for convenience in calling the sort routine. Thus the + -- real lower bound for active entries is 1. + + type SCO_Unit_Index is new Int; + -- Used to index values in this table. Values start at 1 and are assigned + -- sequentially as entries are constructed. + + type SCO_Unit_Table_Entry is record + File_Name : String_Ptr; + -- Pointer to file name in ALI file + + Dep_Num : Nat; + -- Dependency number in ALI file + + From : Nat; + -- Starting index in SCO_Table of SCO information for this unit + + To : Nat; + -- Ending index in SCO_Table of SCO information for this unit + end record; + + package SCO_Unit_Table is new GNAT.Table ( + Table_Component_Type => SCO_Unit_Table_Entry, + Table_Index_Type => SCO_Unit_Index, + Table_Low_Bound => 0, -- see note above on sorting + Table_Initial => 20, + Table_Increment => 200); + + ----------------- + -- Subprograms -- + ----------------- + + procedure Initialize; + -- Reset tables for a new compilation + + procedure Add_SCO + (From : Source_Location := No_Source_Location; + To : Source_Location := No_Source_Location; + C1 : Character := ' '; + C2 : Character := ' '; + Last : Boolean := False); + -- Adds one entry to SCO table with given field values + +end SCOs; diff --git a/gcc/ada/sdefault.ads b/gcc/ada/sdefault.ads new file mode 100644 index 000000000..21745fbb6 --- /dev/null +++ b/gcc/ada/sdefault.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S D E F A U 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 that return the default values for the +-- include and object file directories, target name, default library +-- subdirectory (libsubdir) prefix, and the target OS. The body is generated +-- automatically by the build process. + +with Types; use Types; + +package Sdefault is + function Include_Dir_Default_Name return String_Ptr; + function Object_Dir_Default_Name return String_Ptr; + function Target_Name return String_Ptr; + function Search_Dir_Prefix return String_Ptr; +end Sdefault; diff --git a/gcc/ada/seh_init.c b/gcc/ada/seh_init.c new file mode 100644 index 000000000..012692a7a --- /dev/null +++ b/gcc/ada/seh_init.c @@ -0,0 +1,313 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * S E H - I N I T * + * * + * C Implementation File * + * * + * 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 contains support for SEH (Structured Exception Handling). + Right now the only implementation is for Win32. */ + +#ifdef IN_RTS +#include "tconfig.h" +#include "tsystem.h" + +/* We don't have libiberty, so use malloc. */ +#define xmalloc(S) malloc (S) + +#else +#include "config.h" +#include "system.h" +#endif + +#include "raise.h" + +/* Addresses of exception data blocks for predefined exceptions. */ +extern struct Exception_Data constraint_error; +extern struct Exception_Data numeric_error; +extern struct Exception_Data program_error; +extern struct Exception_Data storage_error; +extern struct Exception_Data tasking_error; +extern struct Exception_Data _abort_signal; + +#define Raise_From_Signal_Handler \ + ada__exceptions__raise_from_signal_handler +extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *); + + +#if defined (_WIN32) + +#include +#include + +extern void _global_unwind2 (void *); + +EXCEPTION_DISPOSITION __gnat_SEH_error_handler +(struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*); + +EXCEPTION_DISPOSITION +__gnat_SEH_error_handler (struct _EXCEPTION_RECORD* ExceptionRecord, + void *EstablisherFrame, + struct _CONTEXT* ContextRecord ATTRIBUTE_UNUSED, + void *DispatcherContext ATTRIBUTE_UNUSED) +{ + struct Exception_Data *exception; + const char *msg; + + switch (ExceptionRecord->ExceptionCode) + { + case EXCEPTION_ACCESS_VIOLATION: + /* If the failing address isn't maximally-aligned or if the page + before the faulting page is not accessible, this is a program error. + */ + if ((ExceptionRecord->ExceptionInformation[1] & 3) != 0 + || IsBadCodePtr + ((void *)(ExceptionRecord->ExceptionInformation[1] + 4096))) + { + exception = &program_error; + msg = "EXCEPTION_ACCESS_VIOLATION"; + } + else + { + /* otherwise it is a stack overflow */ + exception = &storage_error; + msg = "stack overflow (or erroneous memory access)"; + } + break; + + case EXCEPTION_ARRAY_BOUNDS_EXCEEDED: + exception = &constraint_error; + msg = "EXCEPTION_ARRAY_BOUNDS_EXCEEDED"; + break; + + case EXCEPTION_DATATYPE_MISALIGNMENT: + exception = &constraint_error; + msg = "EXCEPTION_DATATYPE_MISALIGNMENT"; + break; + + case EXCEPTION_FLT_DENORMAL_OPERAND: + exception = &constraint_error; + msg = "EXCEPTION_FLT_DENORMAL_OPERAND"; + break; + + case EXCEPTION_FLT_DIVIDE_BY_ZERO: + exception = &constraint_error; + msg = "EXCEPTION_FLT_DENORMAL_OPERAND"; + break; + + case EXCEPTION_FLT_INVALID_OPERATION: + exception = &constraint_error; + msg = "EXCEPTION_FLT_INVALID_OPERATION"; + break; + + case EXCEPTION_FLT_OVERFLOW: + exception = &constraint_error; + msg = "EXCEPTION_FLT_OVERFLOW"; + break; + + case EXCEPTION_FLT_STACK_CHECK: + exception = &program_error; + msg = "EXCEPTION_FLT_STACK_CHECK"; + break; + + case EXCEPTION_FLT_UNDERFLOW: + exception = &constraint_error; + msg = "EXCEPTION_FLT_UNDERFLOW"; + break; + + case EXCEPTION_INT_DIVIDE_BY_ZERO: + exception = &constraint_error; + msg = "EXCEPTION_INT_DIVIDE_BY_ZERO"; + break; + + case EXCEPTION_INT_OVERFLOW: + exception = &constraint_error; + msg = "EXCEPTION_INT_OVERFLOW"; + break; + + case EXCEPTION_INVALID_DISPOSITION: + exception = &program_error; + msg = "EXCEPTION_INVALID_DISPOSITION"; + break; + + case EXCEPTION_NONCONTINUABLE_EXCEPTION: + exception = &program_error; + msg = "EXCEPTION_NONCONTINUABLE_EXCEPTION"; + break; + + case EXCEPTION_PRIV_INSTRUCTION: + exception = &program_error; + msg = "EXCEPTION_PRIV_INSTRUCTION"; + break; + + case EXCEPTION_SINGLE_STEP: + exception = &program_error; + msg = "EXCEPTION_SINGLE_STEP"; + break; + + case EXCEPTION_STACK_OVERFLOW: + exception = &storage_error; + msg = "EXCEPTION_STACK_OVERFLOW"; + break; + + default: + exception = &program_error; + msg = "unhandled signal"; + } + +#if ! defined (_WIN64) + /* This call is important as it avoids locking the second time we catch a + signal. Note that this routine is documented as internal to Windows and + should not be used. */ + + _global_unwind2 (EstablisherFrame); + /* Call equivalent to RtlUnwind (EstablisherFrame, NULL, NULL, 0); */ +#endif + + Raise_From_Signal_Handler (exception, msg); + return 0; /* This is never reached, avoid compiler warning */ +} + +#if defined (_WIN64) +/* On x86_64 windows exception mechanism is no more based on a chained list + of handlers addresses on the stack. Instead unwinding information is used + to retrieve the exception handler (similar to ZCX GCC mechanism). So in + order to register an exception handler we need to put in the final + executable some unwinding information. This information might be present + statically in the image file inside the .pdata section or registered + through RtlAddFunctionTable API. Currently the GCC toolchain does not + generate the .pdata information for each function. As we don't need to + handle SEH exceptions except for signal handling we are registering a + "fake" unwinding data that associate a SEH exception handler to the + complete .text section. As we never return from the handler, the system + does not try to do the final unwinding using the pdata information. The + unwinding is handled by the runtime using either the GNAT SJLJ mechanism + or the ZCX GCC mechanism. + + The current implementation is using the RtlAddFunctionTable. Here is for + information purposes the equivalent using a static .pdata section: + + .section .rdata,"dr" + .align 4 + Lunwind_info: + .byte 9,0,0,0 + .rva ___gnat_SEH_error_handler + .section .pdata,"dr" + .align 4 + .long 0 + .rva etext + .rva Lunwind_info + + Solutions based on SetUnhandledExceptionFilter have been discarded as this + function is mostly disabled on last Windows versions. + Using AddVectoredExceptionHandler should also be discarded as it overrides + all SEH exception handlers that might be present in the program itself and + the loaded DLL (for example it results in unexpected behaviors in the + Win32 subsystem. */ + +typedef struct _UNWIND_INFO { + BYTE VersionAndFlags; + BYTE PrologSize; + BYTE CountOfUnwindCodes; + BYTE FrameRegisterAndOffset; + ULONG AddressOfExceptionHandler; +} UNWIND_INFO,*PUNWIND_INFO; + +static RUNTIME_FUNCTION Table[1]; +static UNWIND_INFO unwind_info[1]; + +#define UNW_VERSION 0x01 +#define UNW_FLAG_EHANDLER 0x08 + +void __gnat_install_SEH_handler (void *eh ATTRIBUTE_UNUSED) +{ + /* Get the end of the text section. */ + extern char etext[] asm("etext"); + /* Get the base of the module. */ + extern char __ImageBase[]; + + /* Current version is always 1 and we are registering an + exception handler. */ + unwind_info[0].VersionAndFlags = UNW_FLAG_EHANDLER | UNW_VERSION; + + /* We don't use the unwinding info so fill the structure with 0 values. */ + unwind_info[0].PrologSize = 0; + unwind_info[0].CountOfUnwindCodes = 0; + unwind_info[0].FrameRegisterAndOffset = 0; + + /* Add the exception handler. */ + unwind_info[0].AddressOfExceptionHandler = + (DWORD)((char *)__gnat_SEH_error_handler - __ImageBase); + + /* Set its scope to the entire program. */ + Table[0].BeginAddress = 0; + Table[0].EndAddress = (DWORD)(etext - __ImageBase); + Table[0].UnwindData = (DWORD)((char *)unwind_info - __ImageBase); + + /* Register the unwind information. */ + RtlAddFunctionTable (Table, 1, (DWORD64)__ImageBase); +} + +#else /* defined (_WIN64) */ +/* Install the Win32 SEH exception handler. Note that the caller must have + allocated 8 bytes on the stack and pass the pointer to this stack + space. This is needed as the SEH exception handler must be on the stack of + the thread. + + int buf[2]; + + __gnat_install_SEH_handler ((void*)buf); + + main(); + + This call must be done before calling the main procedure or the thread + entry. The stack space must exists during all the main run. */ + +void +__gnat_install_SEH_handler (void *ER) +{ + int *ptr; + + /* put current handler in ptr */ + + asm ("mov %%fs:(0),%0" : "=r" (ptr)); + + ((int *)ER)[0] = (int)ptr; /* previous handler */ + ((int *)ER)[1] = (int)__gnat_SEH_error_handler; /* new handler */ + + /* ER is the new handler, set fs:(0) with this value */ + + asm volatile ("mov %0,%%fs:(0)": : "r" (ER)); +} +#endif + +#else /* defined (_WIN32) */ +/* For all non Windows targets we provide a dummy SEH install handler. */ +void __gnat_install_SEH_handler (void *eh ATTRIBUTE_UNUSED) +{ +} +#endif diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb new file mode 100644 index 000000000..4cf2ec740 --- /dev/null +++ b/gcc/ada/sem.adb @@ -0,0 +1,2319 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E 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. -- +-- -- +-- You should have received a copy of the GNU General Public License along -- +-- with this program; see file COPYING3. If not see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Debug; use Debug; +with Debug_A; use Debug_A; +with Elists; use Elists; +with Errout; use Errout; +with Expander; use Expander; +with Fname; use Fname; +with HLO; use HLO; +with Lib; use Lib; +with Lib.Load; use Lib.Load; +with Nlists; use Nlists; +with Output; use Output; +with Sem_Attr; use Sem_Attr; +with Sem_Ch2; use Sem_Ch2; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch4; use Sem_Ch4; +with Sem_Ch5; use Sem_Ch5; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch7; use Sem_Ch7; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch9; use Sem_Ch9; +with Sem_Ch10; use Sem_Ch10; +with Sem_Ch11; use Sem_Ch11; +with Sem_Ch12; use Sem_Ch12; +with Sem_Ch13; use Sem_Ch13; +with Sem_Prag; use Sem_Prag; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Stand; use Stand; +with Uintp; use Uintp; +with Uname; use Uname; + +with Unchecked_Deallocation; + +pragma Warnings (Off, Sem_Util); +-- Suppress warnings of unused with for Sem_Util (used only in asserts) + +package body Sem is + + Debug_Unit_Walk : Boolean renames Debug_Flag_Dot_WW; + -- Controls debugging printouts for Walk_Library_Items + + Outer_Generic_Scope : Entity_Id := Empty; + -- Global reference to the outer scope that is generic. In a non-generic + -- context, it is empty. At the moment, it is only used for avoiding + -- freezing of external references in generics. + + Comp_Unit_List : Elist_Id := No_Elist; + -- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes + -- processed by Semantics, in an appropriate order. Initialized to + -- No_Elist, because it's too early to call New_Elmt_List; we will set it + -- to New_Elmt_List on first use. + + generic + with procedure Action (Withed_Unit : Node_Id); + procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean); + -- Walk all the with clauses of CU, and call Action for the with'ed unit. + -- Ignore limited withs, unless Include_Limited is True. CU must be an + -- N_Compilation_Unit. + + generic + with procedure Action (Withed_Unit : Node_Id); + procedure Walk_Withs (CU : Node_Id; Include_Limited : Boolean); + -- Same as Walk_Withs_Immediate, but also include with clauses on subunits + -- of this unit, since they count as dependences on their parent library + -- item. CU must be an N_Compilation_Unit whose Unit is not an N_Subunit. + + procedure Write_Unit_Info + (Unit_Num : Unit_Number_Type; + Item : Node_Id; + Prefix : String := ""; + Withs : Boolean := False); + -- Print out debugging information about the unit. Prefix precedes the rest + -- of the printout. If Withs is True, we print out units with'ed by this + -- unit (not counting limited withs). + + ------------- + -- Analyze -- + ------------- + + procedure Analyze (N : Node_Id) is + begin + Debug_A_Entry ("analyzing ", N); + + -- Immediate return if already analyzed + + if Analyzed (N) then + Debug_A_Exit ("analyzing ", N, " (done, analyzed already)"); + return; + end if; + + -- Otherwise processing depends on the node kind + + case Nkind (N) is + + when N_Abort_Statement => + Analyze_Abort_Statement (N); + + when N_Abstract_Subprogram_Declaration => + Analyze_Abstract_Subprogram_Declaration (N); + + when N_Accept_Alternative => + Analyze_Accept_Alternative (N); + + when N_Accept_Statement => + Analyze_Accept_Statement (N); + + when N_Aggregate => + Analyze_Aggregate (N); + + when N_Allocator => + Analyze_Allocator (N); + + when N_And_Then => + Analyze_Short_Circuit (N); + + when N_Assignment_Statement => + Analyze_Assignment (N); + + when N_Asynchronous_Select => + Analyze_Asynchronous_Select (N); + + when N_At_Clause => + Analyze_At_Clause (N); + + when N_Attribute_Reference => + Analyze_Attribute (N); + + when N_Attribute_Definition_Clause => + Analyze_Attribute_Definition_Clause (N); + + when N_Block_Statement => + Analyze_Block_Statement (N); + + when N_Case_Expression => + Analyze_Case_Expression (N); + + when N_Case_Statement => + Analyze_Case_Statement (N); + + when N_Character_Literal => + Analyze_Character_Literal (N); + + when N_Code_Statement => + Analyze_Code_Statement (N); + + when N_Compilation_Unit => + Analyze_Compilation_Unit (N); + + when N_Component_Declaration => + Analyze_Component_Declaration (N); + + when N_Conditional_Expression => + Analyze_Conditional_Expression (N); + + when N_Conditional_Entry_Call => + Analyze_Conditional_Entry_Call (N); + + when N_Delay_Alternative => + Analyze_Delay_Alternative (N); + + when N_Delay_Relative_Statement => + Analyze_Delay_Relative (N); + + when N_Delay_Until_Statement => + Analyze_Delay_Until (N); + + when N_Entry_Body => + Analyze_Entry_Body (N); + + when N_Entry_Body_Formal_Part => + Analyze_Entry_Body_Formal_Part (N); + + when N_Entry_Call_Alternative => + Analyze_Entry_Call_Alternative (N); + + when N_Entry_Declaration => + Analyze_Entry_Declaration (N); + + when N_Entry_Index_Specification => + Analyze_Entry_Index_Specification (N); + + when N_Enumeration_Representation_Clause => + Analyze_Enumeration_Representation_Clause (N); + + when N_Exception_Declaration => + Analyze_Exception_Declaration (N); + + when N_Exception_Renaming_Declaration => + Analyze_Exception_Renaming (N); + + when N_Exit_Statement => + Analyze_Exit_Statement (N); + + when N_Expanded_Name => + Analyze_Expanded_Name (N); + + when N_Explicit_Dereference => + Analyze_Explicit_Dereference (N); + + when N_Expression_With_Actions => + Analyze_Expression_With_Actions (N); + + when N_Extended_Return_Statement => + Analyze_Extended_Return_Statement (N); + + when N_Extension_Aggregate => + Analyze_Aggregate (N); + + when N_Formal_Object_Declaration => + Analyze_Formal_Object_Declaration (N); + + when N_Formal_Package_Declaration => + Analyze_Formal_Package_Declaration (N); + + when N_Formal_Subprogram_Declaration => + Analyze_Formal_Subprogram_Declaration (N); + + when N_Formal_Type_Declaration => + Analyze_Formal_Type_Declaration (N); + + when N_Free_Statement => + Analyze_Free_Statement (N); + + when N_Freeze_Entity => + Analyze_Freeze_Entity (N); + + when N_Full_Type_Declaration => + Analyze_Full_Type_Declaration (N); + + when N_Function_Call => + Analyze_Function_Call (N); + + when N_Function_Instantiation => + Analyze_Function_Instantiation (N); + + when N_Generic_Function_Renaming_Declaration => + Analyze_Generic_Function_Renaming (N); + + when N_Generic_Package_Declaration => + Analyze_Generic_Package_Declaration (N); + + when N_Generic_Package_Renaming_Declaration => + Analyze_Generic_Package_Renaming (N); + + when N_Generic_Procedure_Renaming_Declaration => + Analyze_Generic_Procedure_Renaming (N); + + when N_Generic_Subprogram_Declaration => + Analyze_Generic_Subprogram_Declaration (N); + + when N_Goto_Statement => + Analyze_Goto_Statement (N); + + when N_Handled_Sequence_Of_Statements => + Analyze_Handled_Statements (N); + + when N_Identifier => + Analyze_Identifier (N); + + when N_If_Statement => + Analyze_If_Statement (N); + + when N_Implicit_Label_Declaration => + Analyze_Implicit_Label_Declaration (N); + + when N_In => + Analyze_Membership_Op (N); + + when N_Incomplete_Type_Declaration => + Analyze_Incomplete_Type_Decl (N); + + when N_Indexed_Component => + Analyze_Indexed_Component_Form (N); + + when N_Integer_Literal => + Analyze_Integer_Literal (N); + + when N_Iterator_Specification => + Analyze_Iterator_Specification (N); + + when N_Itype_Reference => + Analyze_Itype_Reference (N); + + when N_Label => + Analyze_Label (N); + + when N_Loop_Statement => + Analyze_Loop_Statement (N); + + when N_Not_In => + Analyze_Membership_Op (N); + + when N_Null => + Analyze_Null (N); + + when N_Null_Statement => + Analyze_Null_Statement (N); + + when N_Number_Declaration => + Analyze_Number_Declaration (N); + + when N_Object_Declaration => + Analyze_Object_Declaration (N); + + when N_Object_Renaming_Declaration => + Analyze_Object_Renaming (N); + + when N_Operator_Symbol => + Analyze_Operator_Symbol (N); + + when N_Op_Abs => + Analyze_Unary_Op (N); + + when N_Op_Add => + Analyze_Arithmetic_Op (N); + + when N_Op_And => + Analyze_Logical_Op (N); + + when N_Op_Concat => + Analyze_Concatenation (N); + + when N_Op_Divide => + Analyze_Arithmetic_Op (N); + + when N_Op_Eq => + Analyze_Equality_Op (N); + + when N_Op_Expon => + Analyze_Arithmetic_Op (N); + + when N_Op_Ge => + Analyze_Comparison_Op (N); + + when N_Op_Gt => + Analyze_Comparison_Op (N); + + when N_Op_Le => + Analyze_Comparison_Op (N); + + when N_Op_Lt => + Analyze_Comparison_Op (N); + + when N_Op_Minus => + Analyze_Unary_Op (N); + + when N_Op_Mod => + Analyze_Arithmetic_Op (N); + + when N_Op_Multiply => + Analyze_Arithmetic_Op (N); + + when N_Op_Ne => + Analyze_Equality_Op (N); + + when N_Op_Not => + Analyze_Negation (N); + + when N_Op_Or => + Analyze_Logical_Op (N); + + when N_Op_Plus => + Analyze_Unary_Op (N); + + when N_Op_Rem => + Analyze_Arithmetic_Op (N); + + when N_Op_Rotate_Left => + Analyze_Arithmetic_Op (N); + + when N_Op_Rotate_Right => + Analyze_Arithmetic_Op (N); + + when N_Op_Shift_Left => + Analyze_Arithmetic_Op (N); + + when N_Op_Shift_Right => + Analyze_Arithmetic_Op (N); + + when N_Op_Shift_Right_Arithmetic => + Analyze_Arithmetic_Op (N); + + when N_Op_Subtract => + Analyze_Arithmetic_Op (N); + + when N_Op_Xor => + Analyze_Logical_Op (N); + + when N_Or_Else => + Analyze_Short_Circuit (N); + + when N_Others_Choice => + Analyze_Others_Choice (N); + + when N_Package_Body => + Analyze_Package_Body (N); + + when N_Package_Body_Stub => + Analyze_Package_Body_Stub (N); + + when N_Package_Declaration => + Analyze_Package_Declaration (N); + + when N_Package_Instantiation => + Analyze_Package_Instantiation (N); + + when N_Package_Renaming_Declaration => + Analyze_Package_Renaming (N); + + when N_Package_Specification => + Analyze_Package_Specification (N); + + when N_Parameter_Association => + Analyze_Parameter_Association (N); + + when N_Parameterized_Expression => + Analyze_Parameterized_Expression (N); + + when N_Pragma => + Analyze_Pragma (N); + + when N_Private_Extension_Declaration => + Analyze_Private_Extension_Declaration (N); + + when N_Private_Type_Declaration => + Analyze_Private_Type_Declaration (N); + + when N_Procedure_Call_Statement => + Analyze_Procedure_Call (N); + + when N_Procedure_Instantiation => + Analyze_Procedure_Instantiation (N); + + when N_Protected_Body => + Analyze_Protected_Body (N); + + when N_Protected_Body_Stub => + Analyze_Protected_Body_Stub (N); + + when N_Protected_Definition => + Analyze_Protected_Definition (N); + + when N_Protected_Type_Declaration => + Analyze_Protected_Type_Declaration (N); + + when N_Qualified_Expression => + Analyze_Qualified_Expression (N); + + when N_Quantified_Expression => + Analyze_Quantified_Expression (N); + + when N_Raise_Statement => + Analyze_Raise_Statement (N); + + when N_Raise_xxx_Error => + Analyze_Raise_xxx_Error (N); + + when N_Range => + Analyze_Range (N); + + when N_Range_Constraint => + Analyze_Range (Range_Expression (N)); + + when N_Real_Literal => + Analyze_Real_Literal (N); + + when N_Record_Representation_Clause => + Analyze_Record_Representation_Clause (N); + + when N_Reference => + Analyze_Reference (N); + + when N_Requeue_Statement => + Analyze_Requeue (N); + + when N_Simple_Return_Statement => + Analyze_Simple_Return_Statement (N); + + when N_Selected_Component => + Find_Selected_Component (N); + -- ??? why not Analyze_Selected_Component, needs comments + + when N_Selective_Accept => + Analyze_Selective_Accept (N); + + when N_Single_Protected_Declaration => + Analyze_Single_Protected_Declaration (N); + + when N_Single_Task_Declaration => + Analyze_Single_Task_Declaration (N); + + when N_Slice => + Analyze_Slice (N); + + when N_String_Literal => + Analyze_String_Literal (N); + + when N_Subprogram_Body => + Analyze_Subprogram_Body (N); + + when N_Subprogram_Body_Stub => + Analyze_Subprogram_Body_Stub (N); + + when N_Subprogram_Declaration => + Analyze_Subprogram_Declaration (N); + + when N_Subprogram_Info => + Analyze_Subprogram_Info (N); + + when N_Subprogram_Renaming_Declaration => + Analyze_Subprogram_Renaming (N); + + when N_Subtype_Declaration => + Analyze_Subtype_Declaration (N); + + when N_Subtype_Indication => + Analyze_Subtype_Indication (N); + + when N_Subunit => + Analyze_Subunit (N); + + when N_Task_Body => + Analyze_Task_Body (N); + + when N_Task_Body_Stub => + Analyze_Task_Body_Stub (N); + + when N_Task_Definition => + Analyze_Task_Definition (N); + + when N_Task_Type_Declaration => + Analyze_Task_Type_Declaration (N); + + when N_Terminate_Alternative => + Analyze_Terminate_Alternative (N); + + when N_Timed_Entry_Call => + Analyze_Timed_Entry_Call (N); + + when N_Triggering_Alternative => + Analyze_Triggering_Alternative (N); + + when N_Type_Conversion => + Analyze_Type_Conversion (N); + + when N_Unchecked_Expression => + Analyze_Unchecked_Expression (N); + + when N_Unchecked_Type_Conversion => + Analyze_Unchecked_Type_Conversion (N); + + when N_Use_Package_Clause => + Analyze_Use_Package (N); + + when N_Use_Type_Clause => + Analyze_Use_Type (N); + + when N_Validate_Unchecked_Conversion => + null; + + when N_Variant_Part => + Analyze_Variant_Part (N); + + when N_With_Clause => + Analyze_With_Clause (N); + + -- A call to analyze the Empty node is an error, but most likely it + -- is an error caused by an attempt to analyze a malformed piece of + -- tree caused by some other error, so if there have been any other + -- errors, we just ignore it, otherwise it is a real internal error + -- which we complain about. + + -- We must also consider the case of call to a runtime function that + -- is not available in the configurable runtime. + + when N_Empty => + pragma Assert (Serious_Errors_Detected /= 0 + or else Configurable_Run_Time_Violations /= 0); + null; + + -- A call to analyze the error node is simply ignored, to avoid + -- causing cascaded errors (happens of course only in error cases) + + when N_Error => + null; + + -- Push/Pop nodes normally don't come through an analyze call. An + -- exception is the dummy ones bracketing a subprogram body. In any + -- case there is nothing to be done to analyze such nodes. + + when N_Push_Pop_xxx_Label => + null; + + -- SCIL nodes don't need analysis because they are decorated when + -- they are built. They are added to the tree by Insert_Actions and + -- the call to analyze them is generated when the full list is + -- analyzed. + + when + N_SCIL_Dispatch_Table_Tag_Init | + N_SCIL_Dispatching_Call | + N_SCIL_Membership_Test => + null; + + -- For the remaining node types, we generate compiler abort, because + -- these nodes are always analyzed within the Sem_Chn routines and + -- there should never be a case of making a call to the main Analyze + -- routine for these node kinds. For example, an N_Access_Definition + -- node appears only in the context of a type declaration, and is + -- processed by the analyze routine for type declarations. + + when + N_Abortable_Part | + N_Access_Definition | + N_Access_Function_Definition | + N_Access_Procedure_Definition | + N_Access_To_Object_Definition | + N_Aspect_Specification | + N_Case_Expression_Alternative | + N_Case_Statement_Alternative | + N_Compilation_Unit_Aux | + N_Component_Association | + N_Component_Clause | + N_Component_Definition | + N_Component_List | + N_Constrained_Array_Definition | + N_Decimal_Fixed_Point_Definition | + N_Defining_Character_Literal | + N_Defining_Identifier | + N_Defining_Operator_Symbol | + N_Defining_Program_Unit_Name | + N_Delta_Constraint | + N_Derived_Type_Definition | + N_Designator | + N_Digits_Constraint | + N_Discriminant_Association | + N_Discriminant_Specification | + N_Elsif_Part | + N_Entry_Call_Statement | + N_Enumeration_Type_Definition | + N_Exception_Handler | + N_Floating_Point_Definition | + N_Formal_Decimal_Fixed_Point_Definition | + N_Formal_Derived_Type_Definition | + N_Formal_Discrete_Type_Definition | + N_Formal_Floating_Point_Definition | + N_Formal_Modular_Type_Definition | + N_Formal_Ordinary_Fixed_Point_Definition | + N_Formal_Private_Type_Definition | + N_Formal_Signed_Integer_Type_Definition | + N_Function_Specification | + N_Generic_Association | + N_Index_Or_Discriminant_Constraint | + N_Iteration_Scheme | + N_Loop_Parameter_Specification | + N_Mod_Clause | + N_Modular_Type_Definition | + N_Ordinary_Fixed_Point_Definition | + N_Parameter_Specification | + N_Pragma_Argument_Association | + N_Procedure_Specification | + N_Real_Range_Specification | + N_Record_Definition | + N_Signed_Integer_Type_Definition | + N_Unconstrained_Array_Definition | + N_Unused_At_Start | + N_Unused_At_End | + N_Variant => + + raise Program_Error; + end case; + + Debug_A_Exit ("analyzing ", N, " (done)"); + + -- Now that we have analyzed the node, we call the expander to perform + -- possible expansion. We skip this for subexpressions, because we don't + -- have the type yet, and the expander will need to know the type before + -- it can do its job. For subexpression nodes, the call to the expander + -- happens in Sem_Res.Resolve. A special exception is Raise_xxx_Error, + -- which can appear in a statement context, and needs expanding now in + -- the case (distinguished by Etype, as documented in Sinfo). + + -- The Analyzed flag is also set at this point for non-subexpression + -- nodes (in the case of subexpression nodes, we can't set the flag yet, + -- since resolution and expansion have not yet been completed). Note + -- that for N_Raise_xxx_Error we have to distinguish the expression + -- case from the statement case. + + if Nkind (N) not in N_Subexpr + or else (Nkind (N) in N_Raise_xxx_Error + and then Etype (N) = Standard_Void_Type) + then + Expand (N); + end if; + end Analyze; + + -- Version with check(s) suppressed + + procedure Analyze (N : Node_Id; Suppress : Check_Id) is + begin + if Suppress = All_Checks then + declare + Svg : constant Suppress_Array := Scope_Suppress; + begin + Scope_Suppress := (others => True); + Analyze (N); + Scope_Suppress := Svg; + end; + + else + declare + Svg : constant Boolean := Scope_Suppress (Suppress); + begin + Scope_Suppress (Suppress) := True; + Analyze (N); + Scope_Suppress (Suppress) := Svg; + end; + end if; + end Analyze; + + ------------------ + -- Analyze_List -- + ------------------ + + procedure Analyze_List (L : List_Id) is + Node : Node_Id; + + begin + Node := First (L); + while Present (Node) loop + Analyze (Node); + Next (Node); + end loop; + end Analyze_List; + + -- Version with check(s) suppressed + + procedure Analyze_List (L : List_Id; Suppress : Check_Id) is + begin + if Suppress = All_Checks then + declare + Svg : constant Suppress_Array := Scope_Suppress; + begin + Scope_Suppress := (others => True); + Analyze_List (L); + Scope_Suppress := Svg; + end; + + else + declare + Svg : constant Boolean := Scope_Suppress (Suppress); + begin + Scope_Suppress (Suppress) := True; + Analyze_List (L); + Scope_Suppress (Suppress) := Svg; + end; + end if; + end Analyze_List; + + -------------------------- + -- Copy_Suppress_Status -- + -------------------------- + + procedure Copy_Suppress_Status + (C : Check_Id; + From : Entity_Id; + To : Entity_Id) + is + Found : Boolean; + pragma Warnings (Off, Found); + + procedure Search_Stack + (Top : Suppress_Stack_Entry_Ptr; + Found : out Boolean); + -- Search given suppress stack for matching entry for entity. If found + -- then set Checks_May_Be_Suppressed on To, and push an appropriate + -- entry for To onto the local suppress stack. + + ------------------ + -- Search_Stack -- + ------------------ + + procedure Search_Stack + (Top : Suppress_Stack_Entry_Ptr; + Found : out Boolean) + is + Ptr : Suppress_Stack_Entry_Ptr; + + begin + Ptr := Top; + while Ptr /= null loop + if Ptr.Entity = From + and then (Ptr.Check = All_Checks or else Ptr.Check = C) + then + if Ptr.Suppress then + Set_Checks_May_Be_Suppressed (To, True); + Push_Local_Suppress_Stack_Entry + (Entity => To, + Check => C, + Suppress => True); + Found := True; + return; + end if; + end if; + + Ptr := Ptr.Prev; + end loop; + + Found := False; + return; + end Search_Stack; + + -- Start of processing for Copy_Suppress_Status + + begin + if not Checks_May_Be_Suppressed (From) then + return; + end if; + + -- First search the local entity suppress stack, we search this in + -- reverse order so that we get the innermost entry that applies to + -- this case if there are nested entries. Note that for the purpose + -- of this procedure we are ONLY looking for entries corresponding + -- to a two-argument Suppress, where the second argument matches From. + + Search_Stack (Global_Suppress_Stack_Top, Found); + + if Found then + return; + end if; + + -- Now search the global entity suppress table for a matching entry. + -- We also search this in reverse order so that if there are multiple + -- pragmas for the same entity, the last one applies. + + Search_Stack (Local_Suppress_Stack_Top, Found); + end Copy_Suppress_Status; + + ------------------------- + -- Enter_Generic_Scope -- + ------------------------- + + procedure Enter_Generic_Scope (S : Entity_Id) is + begin + if No (Outer_Generic_Scope) then + Outer_Generic_Scope := S; + end if; + end Enter_Generic_Scope; + + ------------------------ + -- Exit_Generic_Scope -- + ------------------------ + + procedure Exit_Generic_Scope (S : Entity_Id) is + begin + if S = Outer_Generic_Scope then + Outer_Generic_Scope := Empty; + end if; + end Exit_Generic_Scope; + + ----------------------- + -- Explicit_Suppress -- + ----------------------- + + function Explicit_Suppress (E : Entity_Id; C : Check_Id) return Boolean is + Ptr : Suppress_Stack_Entry_Ptr; + + begin + if not Checks_May_Be_Suppressed (E) then + return False; + + else + Ptr := Global_Suppress_Stack_Top; + while Ptr /= null loop + if Ptr.Entity = E + and then (Ptr.Check = All_Checks or else Ptr.Check = C) + then + return Ptr.Suppress; + end if; + + Ptr := Ptr.Prev; + end loop; + end if; + + return False; + end Explicit_Suppress; + + ----------------------------- + -- External_Ref_In_Generic -- + ----------------------------- + + function External_Ref_In_Generic (E : Entity_Id) return Boolean is + Scop : Entity_Id; + + begin + -- Entity is global if defined outside of current outer_generic_scope: + -- Either the entity has a smaller depth that the outer generic, or it + -- is in a different compilation unit, or it is defined within a unit + -- in the same compilation, that is not within the outer_generic. + + if No (Outer_Generic_Scope) then + return False; + + elsif Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope) + or else not In_Same_Source_Unit (E, Outer_Generic_Scope) + then + return True; + + else + Scop := Scope (E); + + while Present (Scop) loop + if Scop = Outer_Generic_Scope then + return False; + elsif Scope_Depth (Scop) < Scope_Depth (Outer_Generic_Scope) then + return True; + else + Scop := Scope (Scop); + end if; + end loop; + + return True; + end if; + end External_Ref_In_Generic; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + Next : Suppress_Stack_Entry_Ptr; + + procedure Free is new Unchecked_Deallocation + (Suppress_Stack_Entry, Suppress_Stack_Entry_Ptr); + + begin + -- Free any global suppress stack entries from a previous invocation + -- of the compiler (in the normal case this loop does nothing). + + while Suppress_Stack_Entries /= null loop + Next := Global_Suppress_Stack_Top.Next; + Free (Suppress_Stack_Entries); + Suppress_Stack_Entries := Next; + end loop; + + Local_Suppress_Stack_Top := null; + Global_Suppress_Stack_Top := null; + + -- Clear scope stack, and reset global variables + + Scope_Stack.Init; + Unloaded_Subunits := False; + end Initialize; + + ------------------------------ + -- Insert_After_And_Analyze -- + ------------------------------ + + procedure Insert_After_And_Analyze (N : Node_Id; M : Node_Id) is + Node : Node_Id; + + begin + if Present (M) then + + -- If we are not at the end of the list, then the easiest + -- coding is simply to insert before our successor + + if Present (Next (N)) then + Insert_Before_And_Analyze (Next (N), M); + + -- Case of inserting at the end of the list + + else + -- Capture the Node_Id of the node to be inserted. This Node_Id + -- will still be the same after the insert operation. + + Node := M; + Insert_After (N, M); + + -- Now just analyze from the inserted node to the end of + -- the new list (note that this properly handles the case + -- where any of the analyze calls result in the insertion of + -- nodes after the analyzed node, expecting analysis). + + while Present (Node) loop + Analyze (Node); + Mark_Rewrite_Insertion (Node); + Next (Node); + end loop; + end if; + end if; + end Insert_After_And_Analyze; + + -- Version with check(s) suppressed + + procedure Insert_After_And_Analyze + (N : Node_Id; + M : Node_Id; + Suppress : Check_Id) + is + begin + if Suppress = All_Checks then + declare + Svg : constant Suppress_Array := Scope_Suppress; + begin + Scope_Suppress := (others => True); + Insert_After_And_Analyze (N, M); + Scope_Suppress := Svg; + end; + + else + declare + Svg : constant Boolean := Scope_Suppress (Suppress); + begin + Scope_Suppress (Suppress) := True; + Insert_After_And_Analyze (N, M); + Scope_Suppress (Suppress) := Svg; + end; + end if; + end Insert_After_And_Analyze; + + ------------------------------- + -- Insert_Before_And_Analyze -- + ------------------------------- + + procedure Insert_Before_And_Analyze (N : Node_Id; M : Node_Id) is + Node : Node_Id; + + begin + if Present (M) then + + -- Capture the Node_Id of the first list node to be inserted. + -- This will still be the first node after the insert operation, + -- since Insert_List_After does not modify the Node_Id values. + + Node := M; + Insert_Before (N, M); + + -- The insertion does not change the Id's of any of the nodes in + -- the list, and they are still linked, so we can simply loop from + -- the original first node until we meet the node before which the + -- insertion is occurring. Note that this properly handles the case + -- where any of the analyzed nodes insert nodes after themselves, + -- expecting them to get analyzed. + + while Node /= N loop + Analyze (Node); + Mark_Rewrite_Insertion (Node); + Next (Node); + end loop; + end if; + end Insert_Before_And_Analyze; + + -- Version with check(s) suppressed + + procedure Insert_Before_And_Analyze + (N : Node_Id; + M : Node_Id; + Suppress : Check_Id) + is + begin + if Suppress = All_Checks then + declare + Svg : constant Suppress_Array := Scope_Suppress; + begin + Scope_Suppress := (others => True); + Insert_Before_And_Analyze (N, M); + Scope_Suppress := Svg; + end; + + else + declare + Svg : constant Boolean := Scope_Suppress (Suppress); + begin + Scope_Suppress (Suppress) := True; + Insert_Before_And_Analyze (N, M); + Scope_Suppress (Suppress) := Svg; + end; + end if; + end Insert_Before_And_Analyze; + + ----------------------------------- + -- Insert_List_After_And_Analyze -- + ----------------------------------- + + procedure Insert_List_After_And_Analyze (N : Node_Id; L : List_Id) is + After : constant Node_Id := Next (N); + Node : Node_Id; + + begin + if Is_Non_Empty_List (L) then + + -- Capture the Node_Id of the first list node to be inserted. + -- This will still be the first node after the insert operation, + -- since Insert_List_After does not modify the Node_Id values. + + Node := First (L); + Insert_List_After (N, L); + + -- Now just analyze from the original first node until we get to the + -- successor of the original insertion point (which may be Empty if + -- the insertion point was at the end of the list). Note that this + -- properly handles the case where any of the analyze calls result in + -- the insertion of nodes after the analyzed node (possibly calling + -- this routine recursively). + + while Node /= After loop + Analyze (Node); + Mark_Rewrite_Insertion (Node); + Next (Node); + end loop; + end if; + end Insert_List_After_And_Analyze; + + -- Version with check(s) suppressed + + procedure Insert_List_After_And_Analyze + (N : Node_Id; L : List_Id; Suppress : Check_Id) + is + begin + if Suppress = All_Checks then + declare + Svg : constant Suppress_Array := Scope_Suppress; + begin + Scope_Suppress := (others => True); + Insert_List_After_And_Analyze (N, L); + Scope_Suppress := Svg; + end; + + else + declare + Svg : constant Boolean := Scope_Suppress (Suppress); + begin + Scope_Suppress (Suppress) := True; + Insert_List_After_And_Analyze (N, L); + Scope_Suppress (Suppress) := Svg; + end; + end if; + end Insert_List_After_And_Analyze; + + ------------------------------------ + -- Insert_List_Before_And_Analyze -- + ------------------------------------ + + procedure Insert_List_Before_And_Analyze (N : Node_Id; L : List_Id) is + Node : Node_Id; + + begin + if Is_Non_Empty_List (L) then + + -- Capture the Node_Id of the first list node to be inserted. This + -- will still be the first node after the insert operation, since + -- Insert_List_After does not modify the Node_Id values. + + Node := First (L); + Insert_List_Before (N, L); + + -- The insertion does not change the Id's of any of the nodes in + -- the list, and they are still linked, so we can simply loop from + -- the original first node until we meet the node before which the + -- insertion is occurring. Note that this properly handles the case + -- where any of the analyzed nodes insert nodes after themselves, + -- expecting them to get analyzed. + + while Node /= N loop + Analyze (Node); + Mark_Rewrite_Insertion (Node); + Next (Node); + end loop; + end if; + end Insert_List_Before_And_Analyze; + + -- Version with check(s) suppressed + + procedure Insert_List_Before_And_Analyze + (N : Node_Id; L : List_Id; Suppress : Check_Id) + is + begin + if Suppress = All_Checks then + declare + Svg : constant Suppress_Array := Scope_Suppress; + begin + Scope_Suppress := (others => True); + Insert_List_Before_And_Analyze (N, L); + Scope_Suppress := Svg; + end; + + else + declare + Svg : constant Boolean := Scope_Suppress (Suppress); + begin + Scope_Suppress (Suppress) := True; + Insert_List_Before_And_Analyze (N, L); + Scope_Suppress (Suppress) := Svg; + end; + end if; + end Insert_List_Before_And_Analyze; + + ------------------------- + -- Is_Check_Suppressed -- + ------------------------- + + function Is_Check_Suppressed (E : Entity_Id; C : Check_Id) return Boolean is + + Ptr : Suppress_Stack_Entry_Ptr; + + begin + -- First search the local entity suppress stack. We search this from the + -- top of the stack down so that we get the innermost entry that applies + -- to this case if there are nested entries. + + Ptr := Local_Suppress_Stack_Top; + while Ptr /= null loop + if (Ptr.Entity = Empty or else Ptr.Entity = E) + and then (Ptr.Check = All_Checks or else Ptr.Check = C) + then + return Ptr.Suppress; + end if; + + Ptr := Ptr.Prev; + end loop; + + -- Now search the global entity suppress table for a matching entry. + -- We also search this from the top down so that if there are multiple + -- pragmas for the same entity, the last one applies (not clear what + -- or whether the RM specifies this handling, but it seems reasonable). + + Ptr := Global_Suppress_Stack_Top; + while Ptr /= null loop + if (Ptr.Entity = Empty or else Ptr.Entity = E) + and then (Ptr.Check = All_Checks or else Ptr.Check = C) + then + return Ptr.Suppress; + end if; + + Ptr := Ptr.Prev; + end loop; + + -- If we did not find a matching entry, then use the normal scope + -- suppress value after all (actually this will be the global setting + -- since it clearly was not overridden at any point). For a predefined + -- check, we test the specific flag. For a user defined check, we check + -- the All_Checks flag. + + if C in Predefined_Check_Id then + return Scope_Suppress (C); + else + return Scope_Suppress (All_Checks); + end if; + end Is_Check_Suppressed; + + ---------- + -- Lock -- + ---------- + + procedure Lock is + begin + Scope_Stack.Locked := True; + Scope_Stack.Release; + end Lock; + + -------------------------------------- + -- Push_Global_Suppress_Stack_Entry -- + -------------------------------------- + + procedure Push_Global_Suppress_Stack_Entry + (Entity : Entity_Id; + Check : Check_Id; + Suppress : Boolean) + is + begin + Global_Suppress_Stack_Top := + new Suppress_Stack_Entry' + (Entity => Entity, + Check => Check, + Suppress => Suppress, + Prev => Global_Suppress_Stack_Top, + Next => Suppress_Stack_Entries); + Suppress_Stack_Entries := Global_Suppress_Stack_Top; + return; + + end Push_Global_Suppress_Stack_Entry; + + ------------------------------------- + -- Push_Local_Suppress_Stack_Entry -- + ------------------------------------- + + procedure Push_Local_Suppress_Stack_Entry + (Entity : Entity_Id; + Check : Check_Id; + Suppress : Boolean) + is + begin + Local_Suppress_Stack_Top := + new Suppress_Stack_Entry' + (Entity => Entity, + Check => Check, + Suppress => Suppress, + Prev => Local_Suppress_Stack_Top, + Next => Suppress_Stack_Entries); + Suppress_Stack_Entries := Local_Suppress_Stack_Top; + + return; + end Push_Local_Suppress_Stack_Entry; + + --------------- + -- Semantics -- + --------------- + + procedure Semantics (Comp_Unit : Node_Id) is + + -- The following locations save the corresponding global flags and + -- variables so that they can be restored on completion. This is needed + -- so that calls to Rtsfind start with the proper default values for + -- these variables, and also that such calls do not disturb the settings + -- for units being analyzed at a higher level. + + S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit; + S_Full_Analysis : constant Boolean := Full_Analysis; + S_GNAT_Mode : constant Boolean := GNAT_Mode; + S_Global_Dis_Names : constant Boolean := Global_Discard_Names; + S_In_Spec_Expr : constant Boolean := In_Spec_Expression; + S_Inside_A_Generic : constant Boolean := Inside_A_Generic; + S_New_Nodes_OK : constant Int := New_Nodes_OK; + S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope; + + Generic_Main : constant Boolean := + Nkind (Unit (Cunit (Main_Unit))) + in N_Generic_Declaration; + -- If the main unit is generic, every compiled unit, including its + -- context, is compiled with expansion disabled. + + Save_Config_Switches : Config_Switches_Type; + -- Variable used to save values of config switches while we analyze the + -- new unit, to be restored on exit for proper recursive behavior. + + procedure Do_Analyze; + -- Procedure to analyze the compilation unit. This is called more than + -- once when the high level optimizer is activated. + + ---------------- + -- Do_Analyze -- + ---------------- + + procedure Do_Analyze is + begin + Save_Scope_Stack; + Push_Scope (Standard_Standard); + Scope_Suppress := Suppress_Options; + Scope_Stack.Table + (Scope_Stack.Last).Component_Alignment_Default := Calign_Default; + Scope_Stack.Table + (Scope_Stack.Last).Is_Active_Stack_Base := True; + Outer_Generic_Scope := Empty; + + -- Now analyze the top level compilation unit node + + Analyze (Comp_Unit); + + -- Check for scope mismatch on exit from compilation + + pragma Assert (Current_Scope = Standard_Standard + or else Comp_Unit = Cunit (Main_Unit)); + + -- Then pop entry for Standard, and pop implicit types + + Pop_Scope; + Restore_Scope_Stack; + end Do_Analyze; + + Already_Analyzed : constant Boolean := Analyzed (Comp_Unit); + + -- Start of processing for Semantics + + begin + if Debug_Unit_Walk then + if Already_Analyzed then + Write_Str ("(done)"); + end if; + + Write_Unit_Info + (Get_Cunit_Unit_Number (Comp_Unit), + Unit (Comp_Unit), + Prefix => "--> "); + Indent; + end if; + + Compiler_State := Analyzing; + Current_Sem_Unit := Get_Cunit_Unit_Number (Comp_Unit); + + -- Compile predefined units with GNAT_Mode set to True, to properly + -- process the categorization stuff. However, do not set GNAT_Mode + -- to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO, + -- Sequential_IO) as this would prevent pragma Extend_System from being + -- taken into account, for example when Text_IO is renaming DEC.Text_IO. + + -- Cleaner might be to do the kludge at the point of excluding the + -- pragma (do not exclude for renamings ???) + + if Is_Predefined_File_Name + (Unit_File_Name (Current_Sem_Unit), Renamings_Included => False) + then + GNAT_Mode := True; + end if; + + if Generic_Main then + Expander_Mode_Save_And_Set (False); + else + Expander_Mode_Save_And_Set + (Operating_Mode = Generate_Code or Debug_Flag_X); + end if; + + Full_Analysis := True; + Inside_A_Generic := False; + In_Spec_Expression := False; + + Set_Comes_From_Source_Default (False); + Save_Opt_Config_Switches (Save_Config_Switches); + Set_Opt_Config_Switches + (Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)), + Current_Sem_Unit = Main_Unit); + + -- Only do analysis of unit that has not already been analyzed + + if not Analyzed (Comp_Unit) then + Initialize_Version (Current_Sem_Unit); + if HLO_Active then + Expander_Mode_Save_And_Set (False); + New_Nodes_OK := 1; + Do_Analyze; + Reset_Analyzed_Flags (Comp_Unit); + Expander_Mode_Restore; + High_Level_Optimize (Comp_Unit); + New_Nodes_OK := 0; + end if; + + -- Do analysis, and then append the compilation unit onto the + -- Comp_Unit_List, if appropriate. This is done after analysis, + -- so if this unit depends on some others, they have already been + -- appended. We ignore bodies, except for the main unit itself, and + -- for subprogram bodies that act as specs. We have also to guard + -- against ill-formed subunits that have an improper context. + + Do_Analyze; + + if Present (Comp_Unit) + and then Nkind (Unit (Comp_Unit)) in N_Proper_Body + and then (Nkind (Unit (Comp_Unit)) /= N_Subprogram_Body + or else not Acts_As_Spec (Comp_Unit)) + and then not In_Extended_Main_Source_Unit (Comp_Unit) + then + null; + + else + -- Initialize if first time + + if No (Comp_Unit_List) then + Comp_Unit_List := New_Elmt_List; + end if; + + Append_Elmt (Comp_Unit, Comp_Unit_List); + + if Debug_Unit_Walk then + Write_Str ("Appending "); + Write_Unit_Info + (Get_Cunit_Unit_Number (Comp_Unit), Unit (Comp_Unit)); + end if; + end if; + end if; + + -- Save indication of dynamic elaboration checks for ALI file + + Set_Dynamic_Elab (Current_Sem_Unit, Dynamic_Elaboration_Checks); + + -- Restore settings of saved switches to entry values + + Current_Sem_Unit := S_Current_Sem_Unit; + Full_Analysis := S_Full_Analysis; + Global_Discard_Names := S_Global_Dis_Names; + GNAT_Mode := S_GNAT_Mode; + In_Spec_Expression := S_In_Spec_Expr; + Inside_A_Generic := S_Inside_A_Generic; + New_Nodes_OK := S_New_Nodes_OK; + Outer_Generic_Scope := S_Outer_Gen_Scope; + + Restore_Opt_Config_Switches (Save_Config_Switches); + Expander_Mode_Restore; + + if Debug_Unit_Walk then + Outdent; + + if Already_Analyzed then + Write_Str ("(done)"); + end if; + + Write_Unit_Info + (Get_Cunit_Unit_Number (Comp_Unit), + Unit (Comp_Unit), + Prefix => "<-- "); + end if; + end Semantics; + + ------------------------ + -- Walk_Library_Items -- + ------------------------ + + procedure Walk_Library_Items is + type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean; + pragma Pack (Unit_Number_Set); + + Main_CU : constant Node_Id := Cunit (Main_Unit); + + Seen, Done : Unit_Number_Set := (others => False); + -- Seen (X) is True after we have seen unit X in the walk. This is used + -- to prevent processing the same unit more than once. Done (X) is True + -- after we have fully processed X, and is used only for debugging + -- printouts and assertions. + + Do_Main : Boolean := False; + -- Flag to delay processing the main body until after all other units. + -- This is needed because the spec of the main unit may appear in the + -- context of some other unit. We do not want this to force processing + -- of the main body before all other units have been processed. + -- + -- Another circularity pattern occurs when the main unit is a child unit + -- and the body of an ancestor has a with-clause of the main unit or on + -- one of its children. In both cases the body in question has a with- + -- clause on the main unit, and must be excluded from the traversal. In + -- some convoluted cases this may lead to a CodePeer error because the + -- spec of a subprogram declared in an instance within the parent will + -- not be seen in the main unit. + + function Depends_On_Main (CU : Node_Id) return Boolean; + -- The body of a unit that is withed by the spec of the main unit may in + -- turn have a with_clause on that spec. In that case do not traverse + -- the body, to prevent loops. It can also happen that the main body has + -- a with_clause on a child, which of course has an implicit with on its + -- parent. It's OK to traverse the child body if the main spec has been + -- processed, otherwise we also have a circularity to avoid. + + procedure Do_Action (CU : Node_Id; Item : Node_Id); + -- Calls Action, with some validity checks + + procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id); + -- Calls Do_Action, first on the units with'ed by this one, then on + -- this unit. If it's an instance body, do the spec first. If it is + -- an instance spec, do the body last. + + procedure Do_Withed_Unit (Withed_Unit : Node_Id); + -- Apply Do_Unit_And_Dependents to a unit in a context clause. + + procedure Process_Bodies_In_Context (Comp : Node_Id); + -- The main unit and its spec may depend on bodies that contain generics + -- that are instantiated in them. Iterate through the corresponding + -- contexts before processing main (spec/body) itself, to process bodies + -- that may be present, together with their context. The spec of main + -- is processed wherever it appears in the list of units, while the body + -- is processed as the last unit in the list. + + --------------------- + -- Depends_On_Main -- + --------------------- + + function Depends_On_Main (CU : Node_Id) return Boolean is + CL : Node_Id; + MCU : constant Node_Id := Unit (Main_CU); + + begin + CL := First (Context_Items (CU)); + + -- Problem does not arise with main subprograms + + if + not Nkind_In (MCU, N_Package_Body, N_Package_Declaration) + then + return False; + end if; + + while Present (CL) loop + if Nkind (CL) = N_With_Clause + and then Library_Unit (CL) = Main_CU + and then not Done (Get_Cunit_Unit_Number (Library_Unit (CL))) + then + return True; + end if; + + Next (CL); + end loop; + + return False; + end Depends_On_Main; + + --------------- + -- Do_Action -- + --------------- + + procedure Do_Action (CU : Node_Id; Item : Node_Id) is + begin + -- This calls Action at the end. All the preceding code is just + -- assertions and debugging output. + + pragma Assert (No (CU) or else Nkind (CU) = N_Compilation_Unit); + + case Nkind (Item) is + when N_Generic_Subprogram_Declaration | + N_Generic_Package_Declaration | + N_Package_Declaration | + N_Subprogram_Declaration | + N_Subprogram_Renaming_Declaration | + N_Package_Renaming_Declaration | + N_Generic_Function_Renaming_Declaration | + N_Generic_Package_Renaming_Declaration | + N_Generic_Procedure_Renaming_Declaration => + + -- Specs are OK + + null; + + when N_Package_Body => + + -- Package bodies are processed separately if the main unit + -- depends on them. + + null; + + when N_Subprogram_Body => + + -- A subprogram body must be the main unit + + pragma Assert (Acts_As_Spec (CU) + or else CU = Cunit (Main_Unit)); + null; + + when N_Function_Instantiation | + N_Procedure_Instantiation | + N_Package_Instantiation => + + -- Can only happen if some generic body (needed for gnat2scil + -- traversal, but not by GNAT) is not available, ignore. + + null; + + -- All other cases cannot happen + + when N_Subunit => + pragma Assert (False, "subunit"); + null; + + when others => + pragma Assert (False); + null; + end case; + + if Present (CU) then + pragma Assert (Item /= Stand.Standard_Package_Node); + pragma Assert (Item = Unit (CU)); + + declare + Unit_Num : constant Unit_Number_Type := + Get_Cunit_Unit_Number (CU); + + procedure Assert_Done (Withed_Unit : Node_Id); + -- Assert Withed_Unit is already Done, unless it's a body. It + -- might seem strange for a with_clause to refer to a body, but + -- this happens in the case of a generic instantiation, which + -- gets transformed into the instance body (and the instance + -- spec is also created). With clauses pointing to the + -- instantiation end up pointing to the instance body. + + ----------------- + -- Assert_Done -- + ----------------- + + procedure Assert_Done (Withed_Unit : Node_Id) is + begin + if not Done (Get_Cunit_Unit_Number (Withed_Unit)) then + if not Nkind_In + (Unit (Withed_Unit), + N_Generic_Package_Declaration, + N_Package_Body, + N_Package_Renaming_Declaration, + N_Subprogram_Body) + then + Write_Unit_Name + (Unit_Name (Get_Cunit_Unit_Number (Withed_Unit))); + Write_Str (" not yet walked!"); + + if Get_Cunit_Unit_Number (Withed_Unit) = Unit_Num then + Write_Str (" (self-ref)"); + end if; + + Write_Eol; + + pragma Assert (False); + end if; + end if; + end Assert_Done; + + procedure Assert_Withed_Units_Done is + new Walk_Withs (Assert_Done); + + begin + if Debug_Unit_Walk then + Write_Unit_Info (Unit_Num, Item, Withs => True); + end if; + + -- Main unit should come last, except in the case where we + -- skipped System_Aux_Id, in which case we missed the things it + -- depends on, and in the case of parent bodies if present. + + pragma Assert + (not Done (Main_Unit) + or else Present (System_Aux_Id) + or else Nkind (Item) = N_Package_Body); + + -- We shouldn't do the same thing twice + + pragma Assert (not Done (Unit_Num)); + + -- Everything we depend upon should already be done + + pragma Debug + (Assert_Withed_Units_Done (CU, Include_Limited => False)); + end; + + else + -- Must be Standard, which has no entry in the units table + + pragma Assert (Item = Stand.Standard_Package_Node); + + if Debug_Unit_Walk then + Write_Line ("Standard"); + end if; + end if; + + Action (Item); + end Do_Action; + + -------------------- + -- Do_Withed_Unit -- + -------------------- + + procedure Do_Withed_Unit (Withed_Unit : Node_Id) is + begin + Do_Unit_And_Dependents (Withed_Unit, Unit (Withed_Unit)); + + -- If the unit in the with_clause is a generic instance, the clause + -- now denotes the instance body. Traverse the corresponding spec + -- because there may be no other dependence that will force the + -- traversal of its own context. + + if Nkind (Unit (Withed_Unit)) = N_Package_Body + and then Is_Generic_Instance + (Defining_Entity (Unit (Library_Unit (Withed_Unit)))) + then + Do_Withed_Unit (Library_Unit (Withed_Unit)); + end if; + end Do_Withed_Unit; + + ---------------------------- + -- Do_Unit_And_Dependents -- + ---------------------------- + + procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id) is + Unit_Num : constant Unit_Number_Type := Get_Cunit_Unit_Number (CU); + Child : Node_Id; + Body_U : Unit_Number_Type; + Parent_CU : Node_Id; + + procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit); + + begin + if not Seen (Unit_Num) then + + -- Process the with clauses + + Do_Withed_Units (CU, Include_Limited => False); + + -- Process the unit if it is a spec or the main unit, if it + -- has no previous spec or we have done all other units. + + if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body) + or else Acts_As_Spec (CU) + then + if CU = Cunit (Main_Unit) + and then not Do_Main + then + Seen (Unit_Num) := False; + + else + Seen (Unit_Num) := True; + + if CU = Library_Unit (Main_CU) then + Process_Bodies_In_Context (CU); + + -- If main is a child unit, examine parent unit contexts + -- to see if they include instantiated units. Also, if + -- the parent itself is an instance, process its body + -- because it may contain subprograms that are called + -- in the main unit. + + if Is_Child_Unit (Cunit_Entity (Main_Unit)) then + Child := Cunit_Entity (Main_Unit); + while Is_Child_Unit (Child) loop + Parent_CU := + Cunit + (Get_Cunit_Entity_Unit_Number (Scope (Child))); + Process_Bodies_In_Context (Parent_CU); + + if Nkind (Unit (Parent_CU)) = N_Package_Body + and then + Nkind (Original_Node (Unit (Parent_CU))) + = N_Package_Instantiation + and then + not Seen (Get_Cunit_Unit_Number (Parent_CU)) + then + Body_U := Get_Cunit_Unit_Number (Parent_CU); + Seen (Body_U) := True; + Do_Action (Parent_CU, Unit (Parent_CU)); + Done (Body_U) := True; + end if; + + Child := Scope (Child); + end loop; + end if; + end if; + + Do_Action (CU, Item); + Done (Unit_Num) := True; + end if; + end if; + end if; + end Do_Unit_And_Dependents; + + ------------------------------- + -- Process_Bodies_In_Context -- + ------------------------------- + + procedure Process_Bodies_In_Context (Comp : Node_Id) is + Body_CU : Node_Id; + Body_U : Unit_Number_Type; + Clause : Node_Id; + Spec : Node_Id; + + procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit); + + -- Start of processing for Process_Bodies_In_Context + + begin + Clause := First (Context_Items (Comp)); + while Present (Clause) loop + if Nkind (Clause) = N_With_Clause then + Spec := Library_Unit (Clause); + Body_CU := Library_Unit (Spec); + + -- If we are processing the spec of the main unit, load bodies + -- only if the with_clause indicates that it forced the loading + -- of the body for a generic instantiation. Note that bodies of + -- parents that are instances have been loaded already. + + if Present (Body_CU) + and then Body_CU /= Cunit (Main_Unit) + and then Nkind (Unit (Body_CU)) /= N_Subprogram_Body + and then (Nkind (Unit (Comp)) /= N_Package_Declaration + or else Present (Withed_Body (Clause))) + then + Body_U := Get_Cunit_Unit_Number (Body_CU); + + if not Seen (Body_U) + and then not Depends_On_Main (Body_CU) + then + Seen (Body_U) := True; + Do_Withed_Units (Body_CU, Include_Limited => False); + Do_Action (Body_CU, Unit (Body_CU)); + Done (Body_U) := True; + end if; + end if; + end if; + + Next (Clause); + end loop; + end Process_Bodies_In_Context; + + -- Local Declarations + + Cur : Elmt_Id; + + -- Start of processing for Walk_Library_Items + + begin + if Debug_Unit_Walk then + Write_Line ("Walk_Library_Items:"); + Indent; + end if; + + -- Do Standard first, then walk the Comp_Unit_List + + Do_Action (Empty, Standard_Package_Node); + + -- First place the context of all instance bodies on the corresponding + -- spec, because it may be needed to analyze the code at the place of + -- the instantiation. + + Cur := First_Elmt (Comp_Unit_List); + while Present (Cur) loop + declare + CU : constant Node_Id := Node (Cur); + N : constant Node_Id := Unit (CU); + + begin + if Nkind (N) = N_Package_Body + and then Is_Generic_Instance (Defining_Entity (N)) + then + Append_List + (Context_Items (CU), Context_Items (Library_Unit (CU))); + end if; + + Next_Elmt (Cur); + end; + end loop; + + -- Now traverse compilation units (specs) in order + + Cur := First_Elmt (Comp_Unit_List); + while Present (Cur) loop + declare + CU : constant Node_Id := Node (Cur); + N : constant Node_Id := Unit (CU); + Par : Entity_Id; + + begin + pragma Assert (Nkind (CU) = N_Compilation_Unit); + + case Nkind (N) is + + -- If it is a subprogram body, process it if it has no + -- separate spec. + + -- If it's a package body, ignore it, unless it is a body + -- created for an instance that is the main unit. In the case + -- of subprograms, the body is the wrapper package. In case of + -- a package, the original file carries the body, and the spec + -- appears as a later entry in the units list. + + -- Otherwise bodies appear in the list only because of inlining + -- or instantiations, and they are processed only if relevant. + -- The flag Withed_Body on a context clause indicates that a + -- unit contains an instantiation that may be needed later, + -- and therefore the body that contains the generic body (and + -- its context) must be traversed immediately after the + -- corresponding spec (see Do_Unit_And_Dependents). + + -- The main unit itself is processed separately after all other + -- specs, and relevant bodies are examined in Process_Main. + + when N_Subprogram_Body => + if Acts_As_Spec (N) then + Do_Unit_And_Dependents (CU, N); + end if; + + when N_Package_Body => + if CU = Main_CU + and then Nkind (Original_Node (Unit (Main_CU))) in + N_Generic_Instantiation + and then Present (Library_Unit (Main_CU)) + then + Do_Unit_And_Dependents + (Library_Unit (Main_CU), + Unit (Library_Unit (Main_CU))); + end if; + + -- It's a spec, process it, and the units it depends on, + -- unless it is a descendent of the main unit. This can + -- happen when the body of a parent depends on some other + -- descendent. + + when others => + Par := Scope (Defining_Entity (Unit (CU))); + + if Is_Child_Unit (Defining_Entity (Unit (CU))) then + while Present (Par) + and then Par /= Standard_Standard + and then Par /= Cunit_Entity (Main_Unit) + loop + Par := Scope (Par); + end loop; + end if; + + if Par /= Cunit_Entity (Main_Unit) then + Do_Unit_And_Dependents (CU, N); + end if; + end case; + end; + + Next_Elmt (Cur); + end loop; + + -- Now process package bodies on which main depends, followed by bodies + -- of parents, if present, and finally main itself. + + if not Done (Main_Unit) then + Do_Main := True; + + Process_Main : declare + Parent_CU : Node_Id; + Body_CU : Node_Id; + Body_U : Unit_Number_Type; + Child : Entity_Id; + + function Is_Subunit_Of_Main (U : Node_Id) return Boolean; + -- If the main unit has subunits, their context may include + -- bodies that are needed in the body of main. We must examine + -- the context of the subunits, which are otherwise not made + -- explicit in the main unit. + + ------------------------ + -- Is_Subunit_Of_Main -- + ------------------------ + + function Is_Subunit_Of_Main (U : Node_Id) return Boolean is + Lib : Node_Id; + begin + if No (U) then + return False; + else + Lib := Library_Unit (U); + return Nkind (Unit (U)) = N_Subunit + and then + (Lib = Cunit (Main_Unit) + or else Is_Subunit_Of_Main (Lib)); + end if; + end Is_Subunit_Of_Main; + + -- Start of processing for Process_Main + + begin + Process_Bodies_In_Context (Main_CU); + + for Unit_Num in Done'Range loop + if Is_Subunit_Of_Main (Cunit (Unit_Num)) then + Process_Bodies_In_Context (Cunit (Unit_Num)); + end if; + end loop; + + -- If the main unit is a child unit, parent bodies may be present + -- because they export instances or inlined subprograms. Check for + -- presence of these, which are not present in context clauses. + -- Note that if the parents are instances, their bodies have been + -- processed before the main spec, because they may be needed + -- therein, so the following loop only affects non-instances. + + if Is_Child_Unit (Cunit_Entity (Main_Unit)) then + Child := Cunit_Entity (Main_Unit); + while Is_Child_Unit (Child) loop + Parent_CU := + Cunit (Get_Cunit_Entity_Unit_Number (Scope (Child))); + Body_CU := Library_Unit (Parent_CU); + + if Present (Body_CU) + and then not Seen (Get_Cunit_Unit_Number (Body_CU)) + and then not Depends_On_Main (Body_CU) + then + Body_U := Get_Cunit_Unit_Number (Body_CU); + Seen (Body_U) := True; + Do_Action (Body_CU, Unit (Body_CU)); + Done (Body_U) := True; + end if; + + Child := Scope (Child); + end loop; + end if; + + Do_Action (Main_CU, Unit (Main_CU)); + Done (Main_Unit) := True; + end Process_Main; + end if; + + if Debug_Unit_Walk then + if Done /= (Done'Range => True) then + Write_Eol; + Write_Line ("Ignored units:"); + + Indent; + + for Unit_Num in Done'Range loop + if not Done (Unit_Num) then + Write_Unit_Info + (Unit_Num, Unit (Cunit (Unit_Num)), Withs => True); + end if; + end loop; + + Outdent; + end if; + end if; + + pragma Assert (Done (Main_Unit)); + + if Debug_Unit_Walk then + Outdent; + Write_Line ("end Walk_Library_Items."); + end if; + end Walk_Library_Items; + + ---------------- + -- Walk_Withs -- + ---------------- + + procedure Walk_Withs (CU : Node_Id; Include_Limited : Boolean) is + pragma Assert (Nkind (CU) = N_Compilation_Unit); + pragma Assert (Nkind (Unit (CU)) /= N_Subunit); + + procedure Walk_Immediate is new Walk_Withs_Immediate (Action); + + begin + -- First walk the withs immediately on the library item + + Walk_Immediate (CU, Include_Limited); + + -- For a body, we must also check for any subunits which belong to it + -- and which have context clauses of their own, since these with'ed + -- units are part of its own dependencies. + + if Nkind (Unit (CU)) in N_Unit_Body then + for S in Main_Unit .. Last_Unit loop + + -- We are only interested in subunits. For preproc. data and def. + -- files, Cunit is Empty, so we need to test that first. + + if Cunit (S) /= Empty + and then Nkind (Unit (Cunit (S))) = N_Subunit + then + declare + Pnode : Node_Id; + + begin + Pnode := Library_Unit (Cunit (S)); + + -- In -gnatc mode, the errors in the subunits will not have + -- been recorded, but the analysis of the subunit may have + -- failed, so just quit. + + if No (Pnode) then + exit; + end if; + + -- Find ultimate parent of the subunit + + while Nkind (Unit (Pnode)) = N_Subunit loop + Pnode := Library_Unit (Pnode); + end loop; + + -- See if it belongs to current unit, and if so, include its + -- with_clauses. Do not process main unit prematurely. + + if Pnode = CU and then CU /= Cunit (Main_Unit) then + Walk_Immediate (Cunit (S), Include_Limited); + end if; + end; + end if; + end loop; + end if; + end Walk_Withs; + + -------------------------- + -- Walk_Withs_Immediate -- + -------------------------- + + procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean) is + pragma Assert (Nkind (CU) = N_Compilation_Unit); + + Context_Item : Node_Id; + Lib_Unit : Node_Id; + Body_CU : Node_Id; + + begin + Context_Item := First (Context_Items (CU)); + while Present (Context_Item) loop + if Nkind (Context_Item) = N_With_Clause + and then (Include_Limited + or else not Limited_Present (Context_Item)) + then + Lib_Unit := Library_Unit (Context_Item); + Action (Lib_Unit); + + -- If the context item indicates that a package body is needed + -- because of an instantiation in CU, traverse the body now, even + -- if CU is not related to the main unit. If the generic itself + -- appears in a package body, the context item is this body, and + -- it already appears in the traversal order, so we only need to + -- examine the case of a context item being a package declaration. + + if Present (Withed_Body (Context_Item)) + and then Nkind (Unit (Lib_Unit)) = N_Package_Declaration + and then Present (Corresponding_Body (Unit (Lib_Unit))) + then + Body_CU := + Parent + (Unit_Declaration_Node + (Corresponding_Body (Unit (Lib_Unit)))); + + -- A body may have an implicit with on its own spec, in which + -- case we must ignore this context item to prevent looping. + + if Unit (CU) /= Unit (Body_CU) then + Action (Body_CU); + end if; + end if; + end if; + + Context_Item := Next (Context_Item); + end loop; + end Walk_Withs_Immediate; + + --------------------- + -- Write_Unit_Info -- + --------------------- + + procedure Write_Unit_Info + (Unit_Num : Unit_Number_Type; + Item : Node_Id; + Prefix : String := ""; + Withs : Boolean := False) + is + begin + Write_Str (Prefix); + Write_Unit_Name (Unit_Name (Unit_Num)); + Write_Str (", unit "); + Write_Int (Int (Unit_Num)); + Write_Str (", "); + Write_Int (Int (Item)); + Write_Str ("="); + Write_Str (Node_Kind'Image (Nkind (Item))); + + if Item /= Original_Node (Item) then + Write_Str (", orig = "); + Write_Int (Int (Original_Node (Item))); + Write_Str ("="); + Write_Str (Node_Kind'Image (Nkind (Original_Node (Item)))); + end if; + + Write_Eol; + + -- Skip the rest if we're not supposed to print the withs + + if not Withs then + return; + end if; + + declare + Context_Item : Node_Id; + + begin + Context_Item := First (Context_Items (Cunit (Unit_Num))); + while Present (Context_Item) + and then (Nkind (Context_Item) /= N_With_Clause + or else Limited_Present (Context_Item)) + loop + Context_Item := Next (Context_Item); + end loop; + + if Present (Context_Item) then + Indent; + Write_Line ("withs:"); + Indent; + + while Present (Context_Item) loop + if Nkind (Context_Item) = N_With_Clause + and then not Limited_Present (Context_Item) + then + pragma Assert (Present (Library_Unit (Context_Item))); + Write_Unit_Name + (Unit_Name + (Get_Cunit_Unit_Number (Library_Unit (Context_Item)))); + + if Implicit_With (Context_Item) then + Write_Str (" -- implicit"); + end if; + + Write_Eol; + end if; + + Context_Item := Next (Context_Item); + end loop; + + Outdent; + Write_Line ("end withs"); + Outdent; + end if; + end; + end Write_Unit_Info; + +end Sem; diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads new file mode 100644 index 000000000..d84ed26f0 --- /dev/null +++ b/gcc/ada/sem.ads @@ -0,0 +1,663 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-------------------------------------- +-- Semantic Analysis: General Model -- +-------------------------------------- + +-- Semantic processing involves 3 phases which are highly intertwined +-- (i.e. mutually recursive): + +-- Analysis implements the bulk of semantic analysis such as +-- name analysis and type resolution for declarations, +-- instructions and expressions. The main routine +-- driving this process is procedure Analyze given below. +-- This analysis phase is really a bottom up pass that is +-- achieved during the recursive traversal performed by the +-- Analyze_... procedures implemented in the sem_* packages. +-- For expressions this phase determines unambiguous types +-- and collects sets of possible types where the +-- interpretation is potentially ambiguous. + +-- Resolution is carried out only for expressions to finish type +-- resolution that was initiated but not necessarily +-- completed during analysis (because of overloading +-- ambiguities). Specifically, after completing the bottom +-- up pass carried out during analysis for expressions, the +-- Resolve routine (see the spec of sem_res for more info) +-- is called to perform a top down resolution with +-- recursive calls to itself to resolve operands. + +-- Expansion if we are not generating code this phase is a no-op. +-- otherwise this phase expands, i.e. transforms, original +-- declaration, expressions or instructions into simpler +-- structures that can be handled by the back-end. This +-- phase is also in charge of generating code which is +-- implicit in the original source (for instance for +-- default initializations, controlled types, etc.) +-- There are two separate instances where expansion is +-- invoked. For declarations and instructions, expansion is +-- invoked just after analysis since no resolution needs +-- to be performed. For expressions, expansion is done just +-- after resolution. In both cases expansion is done from the +-- bottom up just before the end of Analyze for instructions +-- and declarations or the call to Resolve for expressions. +-- The main routine driving expansion is Expand. +-- See the spec of Expander for more details. + +-- To summarize, in normal code generation mode we recursively traverse the +-- abstract syntax tree top-down performing semantic analysis bottom +-- up. For instructions and declarations, before the call to the Analyze +-- routine completes we perform expansion since at that point we have all +-- semantic information needed. For expression nodes, after the call to +-- Analysis terminates we invoke the Resolve routine to transmit top-down +-- the type that was gathered by Analyze which will resolve possible +-- ambiguities in the expression. Just before the call to Resolve +-- terminates, the expression can be expanded since all the semantic +-- information is available at that point. + +-- If we are not generating code then the expansion phase is a no-op + +-- When generating code there are a number of exceptions to the basic +-- Analysis-Resolution-Expansion model for expressions. The most prominent +-- examples are the handling of default expressions and aggregates. + +----------------------------------------------------------------------- +-- Handling of Default and Per-Object Expressions (Spec-Expressions) -- +----------------------------------------------------------------------- + +-- The default expressions in component declarations and in procedure +-- specifications (but not the ones in object declarations) are quite tricky +-- to handle. The problem is that some processing is required at the point +-- where the expression appears: + +-- visibility analysis (including user defined operators) +-- freezing of static expressions + +-- but other processing must be deferred until the enclosing entity (record or +-- procedure specification) is frozen: + +-- freezing of any other types in the expression expansion +-- generation of code + +-- A similar situation occurs with the argument of priority and interrupt +-- priority pragmas that appear in task and protected definition specs and +-- other cases of per-object expressions (see RM 3.8(18)). + +-- Another similar case is the conditions in precondition and postcondition +-- pragmas that appear with subprogram specifications rather than in the body. + +-- Collectively we call these Spec_Expressions. The routine that performs the +-- special analysis is called Analyze_Spec_Expression. + +-- Expansion has to be deferred since you can't generate code for expressions +-- that reference types that have not been frozen yet. As an example, consider +-- the following: + +-- type x is delta 0.5 range -10.0 .. +10.0; +-- ... +-- type q is record +-- xx : x := y * z; +-- end record; + +-- for x'small use 0.25 + +-- The expander is in charge of dealing with fixed-point, and of course the +-- small declaration, which is not too late, since the declaration of type q +-- does *not* freeze type x, definitely affects the expanded code. + +-- Another reason that we cannot expand early is that expansion can generate +-- range checks. These range checks need to be inserted not at the point of +-- definition but at the point of use. The whole point here is that the value +-- of the expression cannot be obtained at the point of declaration, only at +-- the point of use. + +-- Generally our model is to combine analysis resolution and expansion, but +-- this is the one case where this model falls down. Here is how we patch +-- it up without causing too much distortion to our basic model. + +-- A switch (In_Spec_Expression) is set to show that we are in the initial +-- occurrence of a default expression. The analyzer is then called on this +-- expression with the switch set true. Analysis and resolution proceed almost +-- as usual, except that Freeze_Expression will not freeze non-static +-- expressions if this switch is set, and the call to Expand at the end of +-- resolution is skipped. This also skips the code that normally sets the +-- Analyzed flag to True. The result is that when we are done the tree is +-- still marked as unanalyzed, but all types for static expressions are frozen +-- as required, and all entities of variables have been recorded. We then turn +-- off the switch, and later on reanalyze the expression with the switch off. +-- The effect is that this second analysis freezes the rest of the types as +-- required, and generates code but visibility analysis is not repeated since +-- all the entities are marked. + +-- The second analysis (the one that generates code) is in the context +-- where the code is required. For a record field default, this is in the +-- initialization procedure for the record and for a subprogram default +-- parameter, it is at the point the subprogram is frozen. For a priority or +-- storage size pragma it is in the context of the Init_Proc for the task or +-- protected object. For a pre/postcondition pragma it is in the body when +-- code for the pragma is generated. + +------------------ +-- Pre-Analysis -- +------------------ + +-- For certain kind of expressions, such as aggregates, we need to defer +-- expansion of the aggregate and its inner expressions after the whole +-- set of expressions appearing inside the aggregate have been analyzed. +-- Consider, for instance the following example: +-- +-- (1 .. 100 => new Thing (Function_Call)) +-- +-- The normal Analysis-Resolution-Expansion mechanism where expansion of the +-- children is performed before expansion of the parent does not work if the +-- code generated for the children by the expander needs to be evaluated +-- repeatedly (for instance in the above aggregate "new Thing (Function_Call)" +-- needs to be called 100 times.) + +-- The reason why this mechanism does not work is that, the expanded code for +-- the children is typically inserted above the parent and thus when the +-- father gets expanded no re-evaluation takes place. For instance in the case +-- of aggregates if "new Thing (Function_Call)" is expanded before of the +-- aggregate the expanded code will be placed outside of the aggregate and +-- when expanding the aggregate the loop from 1 to 100 will not surround the +-- expanded code for "new Thing (Function_Call)". + +-- To remedy this situation we introduce a new flag which signals whether we +-- want a full analysis (i.e. expansion is enabled) or a pre-analysis which +-- performs Analysis and Resolution but no expansion. + +-- After the complete pre-analysis of an expression has been carried out we +-- can transform the expression and then carry out the full three stage +-- (Analyze-Resolve-Expand) cycle on the transformed expression top-down so +-- that the expansion of inner expressions happens inside the newly generated +-- node for the parent expression. + +-- Note that the difference between processing of default expressions and +-- pre-analysis of other expressions is that we do carry out freezing in +-- the latter but not in the former (except for static scalar expressions). +-- The routine that performs preanalysis and corresponding resolution is +-- called Preanalyze_And_Resolve and is in Sem_Res. + +with Alloc; +with Einfo; use Einfo; +with Opt; use Opt; +with Table; +with Types; use Types; + +package Sem is + + New_Nodes_OK : Int := 1; + -- Temporary flag for use in checking out HLO. Set non-zero if it is + -- OK to generate new nodes. + + ----------------------------- + -- Semantic Analysis Flags -- + ----------------------------- + + Full_Analysis : Boolean := True; + -- Switch to indicate if we are doing a full analysis or a pre-analysis. + -- In normal analysis mode (Analysis-Expansion for instructions or + -- declarations) or (Analysis-Resolution-Expansion for expressions) this + -- flag is set. Note that if we are not generating code the expansion phase + -- merely sets the Analyzed flag to True in this case. If we are in + -- Pre-Analysis mode (see above) this flag is set to False then the + -- expansion phase is skipped. + -- + -- When this flag is False the flag Expander_Active is also False (the + -- Expander_Active flag defined in the spec of package Expander tells you + -- whether expansion is currently enabled). You should really regard this + -- as a read only flag. + + In_Spec_Expression : Boolean := False; + -- Switch to indicate that we are in a spec-expression, as described + -- above. Note that this must be recursively saved on a Semantics call + -- since it is possible for the analysis of an expression to result in a + -- recursive call (e.g. to get the entity for System.Address as part of the + -- processing of an Address attribute reference). When this switch is True + -- then Full_Analysis above must be False. You should really regard this as + -- a read only flag. + + In_Deleted_Code : Boolean := False; + -- If the condition in an if-statement is statically known, the branch + -- that is not taken is analyzed with expansion disabled, and the tree + -- is deleted after analysis. Itypes generated in deleted code must be + -- frozen from start, because the tree on which they depend will not + -- be available at the freeze point. + + In_Inlined_Body : Boolean := False; + -- Switch to indicate that we are analyzing and resolving an inlined body. + -- Type checking is disabled in this context, because types are known to be + -- compatible. This avoids problems with private types whose full view is + -- derived from private types. + + Inside_A_Generic : Boolean := False; + -- This flag is set if we are processing a generic specification, generic + -- definition, or generic body. When this flag is True the Expander_Active + -- flag is False to disable any code expansion (see package Expander). Only + -- the generic processing can modify the status of this flag, any other + -- client should regard it as read-only. + -- Probably should be called Inside_A_Generic_Template ??? + + Inside_Freezing_Actions : Nat := 0; + -- Flag indicating whether we are within a call to Expand_N_Freeze_Actions. + -- Non-zero means we are inside (it is actually a level counter to deal + -- with nested calls). Used to avoid traversing the tree each time a + -- subprogram call is processed to know if we must not clear all constant + -- indications from entities in the current scope. Only the expansion of + -- freezing nodes can modify the status of this flag, any other client + -- should regard it as read-only. + + Unloaded_Subunits : Boolean := False; + -- This flag is set True if we have subunits that are not loaded. This + -- occurs when the main unit is a subunit, and contains lower level + -- subunits that are not loaded. We use this flag to suppress warnings + -- about unused variables, since these warnings are unreliable in this + -- case. We could perhaps do a more accurate job and retain some of the + -- warnings, but it is quite a tricky job. + + ----------------------------------- + -- Handling of Check Suppression -- + ----------------------------------- + + -- There are two kinds of suppress checks: scope based suppress checks, + -- and entity based suppress checks. + + -- Scope based suppress checks for the predefined checks (from initial + -- command line arguments, or from Suppress pragmas not including an entity + -- entity name) are recorded in the Sem.Suppress variable, and all that is + -- necessary is to save the state of this variable on scope entry, and + -- restore it on scope exit. This mechanism allows for fast checking of + -- the scope suppress state without needing complex data structures. + + -- Entity based checks, from Suppress/Unsuppress pragmas giving an + -- Entity_Id and scope based checks for non-predefined checks (introduced + -- using pragma Check_Name), are handled as follows. If a suppress or + -- unsuppress pragma is encountered for a given entity, then the flag + -- Checks_May_Be_Suppressed is set in the entity and an entry is made in + -- either the Local_Entity_Suppress stack (case of pragma that appears in + -- other than a package spec), or in the Global_Entity_Suppress stack (case + -- of pragma that appears in a package spec, which is by the rule of RM + -- 11.5(7) applicable throughout the life of the entity). Similarly, a + -- Suppress/Unsuppress pragma for a non-predefined check which does not + -- specify an entity is also stored in one of these stacks. + + -- If the Checks_May_Be_Suppressed flag is set in an entity then the + -- procedure is to search first the local and then the global suppress + -- stacks (we search these in reverse order, top element first). The only + -- other point is that we have to make sure that we have proper nested + -- interaction between such specific pragmas and locally applied general + -- pragmas applying to all entities. This is achieved by including in the + -- Local_Entity_Suppress table dummy entries with an empty Entity field + -- that are applicable to all entities. A similar search is needed for any + -- non-predefined check even if no specific entity is involved. + + Scope_Suppress : Suppress_Array := Suppress_Options; + -- This array contains the current scope based settings of the suppress + -- switches. It is initialized from the options as shown, and then modified + -- by pragma Suppress. On entry to each scope, the current setting is saved + -- the scope stack, and then restored on exit from the scope. This record + -- may be rapidly checked to determine the current status of a check if + -- no specific entity is involved or if the specific entity involved is + -- one for which no specific Suppress/Unsuppress pragma has been set (as + -- indicated by the Checks_May_Be_Suppressed flag being set). + + -- This scheme is a little complex, but serves the purpose of enabling + -- a very rapid check in the common case where no entity specific pragma + -- applies, and gives the right result when such pragmas are used even + -- in complex cases of nested Suppress and Unsuppress pragmas. + + -- The Local_Entity_Suppress and Global_Entity_Suppress stacks are handled + -- using dynamic allocation and linked lists. We do not often use this + -- approach in the compiler (preferring to use extensible tables instead). + -- The reason we do it here is that scope stack entries save a pointer to + -- the current local stack top, which is also saved and restored on scope + -- exit. Furthermore for processing of generics we save pointers to the + -- top of the stack, so that the local stack is actually a tree of stacks + -- rather than a single stack, a structure that is easy to represent using + -- linked lists, but impossible to represent using a single table. Note + -- that because of the generic issue, we never release entries in these + -- stacks, but that's no big deal, since we are unlikely to have a huge + -- number of Suppress/Unsuppress entries in a single compilation. + + type Suppress_Stack_Entry; + type Suppress_Stack_Entry_Ptr is access all Suppress_Stack_Entry; + + type Suppress_Stack_Entry is record + Entity : Entity_Id; + -- Entity to which the check applies, or Empty for a check that has + -- no entity name (and thus applies to all entities). + + Check : Check_Id; + -- Check which is set (can be All_Checks for the All_Checks case) + + Suppress : Boolean; + -- Set True for Suppress, and False for Unsuppress + + Prev : Suppress_Stack_Entry_Ptr; + -- Pointer to previous entry on stack + + Next : Suppress_Stack_Entry_Ptr; + -- All allocated Suppress_Stack_Entry records are chained together in + -- a linked list whose head is Suppress_Stack_Entries, and the Next + -- field is used as a forward pointer (null ends the list). This is + -- used to free all entries in Sem.Init (which will be important if + -- we ever setup the compiler to be reused). + end record; + + Suppress_Stack_Entries : Suppress_Stack_Entry_Ptr := null; + -- Pointer to linked list of records (see comments for Next above) + + Local_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr; + -- Pointer to top element of local suppress stack. This is the entry that + -- is saved and restored in the scope stack, and also saved for generic + -- body expansion. + + Global_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr; + -- Pointer to top element of global suppress stack + + procedure Push_Local_Suppress_Stack_Entry + (Entity : Entity_Id; + Check : Check_Id; + Suppress : Boolean); + -- Push a new entry on to the top of the local suppress stack, updating + -- the value in Local_Suppress_Stack_Top; + + procedure Push_Global_Suppress_Stack_Entry + (Entity : Entity_Id; + Check : Check_Id; + Suppress : Boolean); + -- Push a new entry on to the top of the global suppress stack, updating + -- the value in Global_Suppress_Stack_Top; + + ----------------- + -- Scope Stack -- + ----------------- + + -- The scope stack indicates the declarative regions that are currently + -- being processed (analyzed and/or expanded). The scope stack is one of + -- the basic visibility structures in the compiler: entities that are + -- declared in a scope that is currently on the scope stack are immediately + -- visible (leaving aside issues of hiding and overloading). + + -- Initially, the scope stack only contains an entry for package Standard. + -- When a compilation unit, subprogram unit, block or declarative region + -- is being processed, the corresponding entity is pushed on the scope + -- stack. It is removed after the processing step is completed. A given + -- entity can be placed several times on the scope stack, for example + -- when processing derived type declarations, freeze nodes, etc. The top + -- of the scope stack is the innermost scope currently being processed. + -- It is obtained through function Current_Scope. After a compilation unit + -- has been processed, the scope stack must contain only Standard. + -- The predicate In_Open_Scopes specifies whether a scope is currently + -- on the scope stack. + + -- This model is complicated by the need to compile units on the fly, in + -- the middle of the compilation of other units. This arises when compiling + -- instantiations, and when compiling run-time packages obtained through + -- rtsfind. Given that the scope stack is a single static and global + -- structure (not originally designed for the recursive processing required + -- by rtsfind for example) additional machinery is needed to indicate what + -- is currently being compiled. As a result, the scope stack holds several + -- contiguous sections that correspond to the compilation of a given + -- compilation unit. These sections are separated by distinct occurrences + -- of package Standard. The currently active section of the scope stack + -- goes from the current scope to the first (innermost) occurrence of + -- Standard, which is additionally marked with the flag + -- Is_Active_Stack_Base. The basic visibility routine (Find_Direct_Name, in + -- Sem_Ch8) uses this contiguous section of the scope stack to determine + -- whether a given entity is or is not visible at a point. In_Open_Scopes + -- only examines the currently active section of the scope stack. + + -- Similar complications arise when processing child instances. These + -- must be compiled in the context of parent instances, and therefore the + -- parents must be pushed on the stack before compiling the child, and + -- removed afterwards. Routines Save_Scope_Stack and Restore_Scope_Stack + -- are used to set/reset the visibility of entities declared in scopes + -- that are currently on the scope stack, and are used when compiling + -- instance bodies on the fly. + + -- It is clear in retrospect that all semantic processing and visibility + -- structures should have been fully recursive. The rtsfind mechanism, + -- and the complexities brought about by subunits and by generic child + -- units and their instantiations, have led to a hybrid model that carries + -- more state than one would wish. + + type Scope_Stack_Entry is record + Entity : Entity_Id; + -- Entity representing the scope + + Last_Subprogram_Name : String_Ptr; + -- Pointer to name of last subprogram body in this scope. Used for + -- testing proper alpha ordering of subprogram bodies in scope. + + Save_Scope_Suppress : Suppress_Array; + -- Save contents of Scope_Suppress on entry + + Save_Local_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr; + -- Save contents of Local_Suppress_Stack on entry to restore on exit + + Save_Check_Policy_List : Node_Id; + -- Save contents of Check_Policy_List on entry to restore on exit + + Save_Default_Storage_Pool : Node_Id; + -- Save contents of Default_Storage_Pool on entry to restore on exit + + Is_Transient : Boolean; + -- Marks transient scopes (see Exp_Ch7 body for details) + + Previous_Visibility : Boolean; + -- Used when installing the parent(s) of the current compilation unit. + -- The parent may already be visible because of an ongoing compilation, + -- and the proper visibility must be restored on exit. The flag is + -- typically needed when the context of a child unit requires + -- compilation of a sibling. In other cases the flag is set to False. + -- See Sem_Ch10 (Install_Parents, Remove_Parents). + + Node_To_Be_Wrapped : Node_Id; + -- Only used in transient scopes. Records the node which will + -- be wrapped by the transient block. + + Actions_To_Be_Wrapped_Before : List_Id; + Actions_To_Be_Wrapped_After : List_Id; + -- Actions that have to be inserted at the start or at the end of a + -- transient block. Used to temporarily hold these actions until the + -- block is created, at which time the actions are moved to the block. + + Pending_Freeze_Actions : List_Id; + -- Used to collect freeze entity nodes and associated actions that are + -- generated in an inner context but need to be analyzed outside, such + -- as records and initialization procedures. On exit from the scope, + -- this list of actions is inserted before the scope construct and + -- analyzed to generate the corresponding freeze processing and + -- elaboration of other associated actions. + + First_Use_Clause : Node_Id; + -- Head of list of Use_Clauses in current scope. The list is built when + -- the declarations in the scope are processed. The list is traversed + -- on scope exit to undo the effect of the use clauses. + + Component_Alignment_Default : Component_Alignment_Kind; + -- Component alignment to be applied to any record or array types that + -- are declared for which a specific component alignment pragma does not + -- set the alignment. + + Is_Active_Stack_Base : Boolean; + -- Set to true only when entering the scope for Standard_Standard from + -- from within procedure Semantics. Indicates the base of the current + -- active set of scopes. Needed by In_Open_Scopes to handle cases where + -- Standard_Standard can be pushed anew on the scope stack to start a + -- new active section (see comment above). + + end record; + + package Scope_Stack is new Table.Table ( + Table_Component_Type => Scope_Stack_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.Scope_Stack_Initial, + Table_Increment => Alloc.Scope_Stack_Increment, + Table_Name => "Sem.Scope_Stack"); + + ----------------- + -- Subprograms -- + ----------------- + + procedure Initialize; + -- Initialize internal tables + + procedure Lock; + -- Lock internal tables before calling back end + + procedure Semantics (Comp_Unit : Node_Id); + -- This procedure is called to perform semantic analysis on the specified + -- node which is the N_Compilation_Unit node for the unit. + + procedure Analyze (N : Node_Id); + procedure Analyze (N : Node_Id; Suppress : Check_Id); + -- This is the recursive procedure that is applied to individual nodes of + -- the tree, starting at the top level node (compilation unit node) and + -- then moving down the tree in a top down traversal. It calls individual + -- routines with names Analyze_xxx to analyze node xxx. Each of these + -- routines is responsible for calling Analyze on the components of the + -- subtree. + -- + -- Note: In the case of expression components (nodes whose Nkind is in + -- N_Subexpr), the call to Analyze does not complete the semantic analysis + -- of the node, since the type resolution cannot be completed until the + -- complete context is analyzed. The completion of the type analysis occurs + -- in the corresponding Resolve routine (see Sem_Res). + -- + -- Note: for integer and real literals, the analyzer sets the flag to + -- indicate that the result is a static expression. If the expander + -- generates a literal that does NOT correspond to a static expression, + -- e.g. by folding an expression whose value is known at compile-time, + -- but is not technically static, then the caller should reset the + -- Is_Static_Expression flag after analyzing but before resolving. + -- + -- If the Suppress argument is present, then the analysis is done + -- with the specified check suppressed (can be All_Checks to suppress + -- all checks). + + procedure Analyze_List (L : List_Id); + procedure Analyze_List (L : List_Id; Suppress : Check_Id); + -- Analyzes each element of a list. If the Suppress argument is present, + -- then the analysis is done with the specified check suppressed (can + -- be All_Checks to suppress all checks). + + procedure Copy_Suppress_Status + (C : Check_Id; + From : Entity_Id; + To : Entity_Id); + -- If From is an entity for which check C is explicitly suppressed + -- then also explicitly suppress the corresponding check in To. + + procedure Insert_List_After_And_Analyze + (N : Node_Id; L : List_Id); + procedure Insert_List_After_And_Analyze + (N : Node_Id; L : List_Id; Suppress : Check_Id); + -- Inserts list L after node N using Nlists.Insert_List_After, and then, + -- after this insertion is complete, analyzes all the nodes in the list, + -- including any additional nodes generated by this analysis. If the list + -- is empty or No_List, the call has no effect. If the Suppress argument is + -- present, then the analysis is done with the specified check suppressed + -- (can be All_Checks to suppress all checks). + + procedure Insert_List_Before_And_Analyze + (N : Node_Id; L : List_Id); + procedure Insert_List_Before_And_Analyze + (N : Node_Id; L : List_Id; Suppress : Check_Id); + -- Inserts list L before node N using Nlists.Insert_List_Before, and then, + -- after this insertion is complete, analyzes all the nodes in the list, + -- including any additional nodes generated by this analysis. If the list + -- is empty or No_List, the call has no effect. If the Suppress argument is + -- present, then the analysis is done with the specified check suppressed + -- (can be All_Checks to suppress all checks). + + procedure Insert_After_And_Analyze + (N : Node_Id; M : Node_Id); + procedure Insert_After_And_Analyze + (N : Node_Id; M : Node_Id; Suppress : Check_Id); + -- Inserts node M after node N and then after the insertion is complete, + -- analyzes the inserted node and all nodes that are generated by + -- this analysis. If the node is empty, the call has no effect. If the + -- Suppress argument is present, then the analysis is done with the + -- specified check suppressed (can be All_Checks to suppress all checks). + + procedure Insert_Before_And_Analyze + (N : Node_Id; M : Node_Id); + procedure Insert_Before_And_Analyze + (N : Node_Id; M : Node_Id; Suppress : Check_Id); + -- Inserts node M before node N and then after the insertion is complete, + -- analyzes the inserted node and all nodes that could be generated by + -- this analysis. If the node is empty, the call has no effect. If the + -- Suppress argument is present, then the analysis is done with the + -- specified check suppressed (can be All_Checks to suppress all checks). + + function External_Ref_In_Generic (E : Entity_Id) return Boolean; + -- Return True if we are in the context of a generic and E is + -- external (more global) to it. + + procedure Enter_Generic_Scope (S : Entity_Id); + -- Shall be called each time a Generic subprogram or package scope is + -- entered. S is the entity of the scope. + -- ??? At the moment, only called for package specs because this mechanism + -- is only used for avoiding freezing of external references in generics + -- and this can only be an issue if the outer generic scope is a package + -- spec (otherwise all external entities are already frozen) + + procedure Exit_Generic_Scope (S : Entity_Id); + -- Shall be called each time a Generic subprogram or package scope is + -- exited. S is the entity of the scope. + -- ??? At the moment, only called for package specs exit. + + function Explicit_Suppress (E : Entity_Id; C : Check_Id) return Boolean; + -- This function returns True if an explicit pragma Suppress for check C + -- is present in the package defining E. + + function Is_Check_Suppressed (E : Entity_Id; C : Check_Id) return Boolean; + -- This function is called if Checks_May_Be_Suppressed (E) is True to + -- determine whether check C is suppressed either on the entity E or + -- as the result of a scope suppress pragma. If Checks_May_Be_Suppressed + -- is False, then the status of the check can be determined simply by + -- examining Scope_Checks (C), so this routine is not called in that case. + + generic + with procedure Action (Item : Node_Id); + procedure Walk_Library_Items; + -- Primarily for use by SofCheck Inspector. Must be called after semantic + -- analysis (and expansion) are complete. Walks each relevant library item, + -- calling Action for each, in an order such that one will not run across + -- forward references. Each Item passed to Action is the declaration or + -- body of a library unit, including generics and renamings. The first item + -- is the N_Package_Declaration node for package Standard. Bodies are not + -- included, except for the main unit itself, which always comes last. + -- + -- Item is never a subunit + -- + -- Item is never an instantiation. Instead, the instance declaration is + -- passed, and (if the instantiation is the main unit), the instance body. + +end Sem; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb new file mode 100644 index 000000000..1d75a3c75 --- /dev/null +++ b/gcc/ada/sem_aggr.adb @@ -0,0 +1,4112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ A G G 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Expander; use Expander; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Itypes; use Itypes; +with Lib; use Lib; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; +with Namet.Sp; use Namet.Sp; +with Nmake; use Nmake; +with Nlists; use Nlists; +with Opt; use Opt; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Cat; use Sem_Cat; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch13; use Sem_Ch13; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sem_Type; use Sem_Type; +with Sem_Warn; use Sem_Warn; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stringt; use Stringt; +with Stand; use Stand; +with Style; use Style; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +package body Sem_Aggr is + + type Case_Bounds is record + Choice_Lo : Node_Id; + Choice_Hi : Node_Id; + Choice_Node : Node_Id; + end record; + + type Case_Table_Type is array (Nat range <>) of Case_Bounds; + -- Table type used by Check_Case_Choices procedure + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Sort_Case_Table (Case_Table : in out Case_Table_Type); + -- Sort the Case Table using the Lower Bound of each Choice as the key. + -- A simple insertion sort is used since the number of choices in a case + -- statement of variant part will usually be small and probably in near + -- sorted order. + + procedure Check_Can_Never_Be_Null (Typ : Entity_Id; Expr : Node_Id); + -- Ada 2005 (AI-231): Check bad usage of null for a component for which + -- null exclusion (NOT NULL) is specified. Typ can be an E_Array_Type for + -- the array case (the component type of the array will be used) or an + -- E_Component/E_Discriminant entity in the record case, in which case the + -- type of the component will be used for the test. If Typ is any other + -- kind of entity, the call is ignored. Expr is the component node in the + -- aggregate which is known to have a null value. A warning message will be + -- issued if the component is null excluding. + -- + -- It would be better to pass the proper type for Typ ??? + + procedure Check_Expr_OK_In_Limited_Aggregate (Expr : Node_Id); + -- Check that Expr is either not limited or else is one of the cases of + -- expressions allowed for a limited component association (namely, an + -- aggregate, function call, or <> notation). Report error for violations. + + ------------------------------------------------------ + -- Subprograms used for RECORD AGGREGATE Processing -- + ------------------------------------------------------ + + procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id); + -- This procedure performs all the semantic checks required for record + -- aggregates. Note that for aggregates analysis and resolution go + -- hand in hand. Aggregate analysis has been delayed up to here and + -- it is done while resolving the aggregate. + -- + -- N is the N_Aggregate node. + -- Typ is the record type for the aggregate resolution + -- + -- While performing the semantic checks, this procedure builds a new + -- Component_Association_List where each record field appears alone in a + -- Component_Choice_List along with its corresponding expression. The + -- record fields in the Component_Association_List appear in the same order + -- in which they appear in the record type Typ. + -- + -- Once this new Component_Association_List is built and all the semantic + -- checks performed, the original aggregate subtree is replaced with the + -- new named record aggregate just built. Note that subtree substitution is + -- performed with Rewrite so as to be able to retrieve the original + -- aggregate. + -- + -- The aggregate subtree manipulation performed by Resolve_Record_Aggregate + -- yields the aggregate format expected by Gigi. Typically, this kind of + -- tree manipulations are done in the expander. However, because the + -- semantic checks that need to be performed on record aggregates really go + -- hand in hand with the record aggregate normalization, the aggregate + -- subtree transformation is performed during resolution rather than + -- expansion. Had we decided otherwise we would have had to duplicate most + -- of the code in the expansion procedure Expand_Record_Aggregate. Note, + -- however, that all the expansion concerning aggregates for tagged records + -- is done in Expand_Record_Aggregate. + -- + -- The algorithm of Resolve_Record_Aggregate proceeds as follows: + -- + -- 1. Make sure that the record type against which the record aggregate + -- has to be resolved is not abstract. Furthermore if the type is a + -- null aggregate make sure the input aggregate N is also null. + -- + -- 2. Verify that the structure of the aggregate is that of a record + -- aggregate. Specifically, look for component associations and ensure + -- that each choice list only has identifiers or the N_Others_Choice + -- node. Also make sure that if present, the N_Others_Choice occurs + -- last and by itself. + -- + -- 3. If Typ contains discriminants, the values for each discriminant is + -- looked for. If the record type Typ has variants, we check that the + -- expressions corresponding to each discriminant ruling the (possibly + -- nested) variant parts of Typ, are static. This allows us to determine + -- the variant parts to which the rest of the aggregate must conform. + -- The names of discriminants with their values are saved in a new + -- association list, New_Assoc_List which is later augmented with the + -- names and values of the remaining components in the record type. + -- + -- During this phase we also make sure that every discriminant is + -- assigned exactly one value. Note that when several values for a given + -- discriminant are found, semantic processing continues looking for + -- further errors. In this case it's the first discriminant value found + -- which we will be recorded. + -- + -- IMPORTANT NOTE: For derived tagged types this procedure expects + -- First_Discriminant and Next_Discriminant to give the correct list + -- of discriminants, in the correct order. + -- + -- 4. After all the discriminant values have been gathered, we can set the + -- Etype of the record aggregate. If Typ contains no discriminants this + -- is straightforward: the Etype of N is just Typ, otherwise a new + -- implicit constrained subtype of Typ is built to be the Etype of N. + -- + -- 5. Gather the remaining record components according to the discriminant + -- values. This involves recursively traversing the record type + -- structure to see what variants are selected by the given discriminant + -- values. This processing is a little more convoluted if Typ is a + -- derived tagged types since we need to retrieve the record structure + -- of all the ancestors of Typ. + -- + -- 6. After gathering the record components we look for their values in the + -- record aggregate and emit appropriate error messages should we not + -- find such values or should they be duplicated. + -- + -- 7. We then make sure no illegal component names appear in the record + -- aggregate and make sure that the type of the record components + -- appearing in a same choice list is the same. Finally we ensure that + -- the others choice, if present, is used to provide the value of at + -- least a record component. + -- + -- 8. The original aggregate node is replaced with the new named aggregate + -- built in steps 3 through 6, as explained earlier. + -- + -- Given the complexity of record aggregate resolution, the primary goal of + -- this routine is clarity and simplicity rather than execution and storage + -- efficiency. If there are only positional components in the aggregate the + -- running time is linear. If there are associations the running time is + -- still linear as long as the order of the associations is not too far off + -- the order of the components in the record type. If this is not the case + -- the running time is at worst quadratic in the size of the association + -- list. + + procedure Check_Misspelled_Component + (Elements : Elist_Id; + Component : Node_Id); + -- Give possible misspelling diagnostic if Component is likely to be a + -- misspelling of one of the components of the Assoc_List. This is called + -- by Resolve_Aggr_Expr after producing an invalid component error message. + + procedure Check_Static_Discriminated_Subtype (T : Entity_Id; V : Node_Id); + -- An optimization: determine whether a discriminated subtype has a static + -- constraint, and contains array components whose length is also static, + -- either because they are constrained by the discriminant, or because the + -- original component bounds are static. + + ----------------------------------------------------- + -- Subprograms used for ARRAY AGGREGATE Processing -- + ----------------------------------------------------- + + function Resolve_Array_Aggregate + (N : Node_Id; + Index : Node_Id; + Index_Constr : Node_Id; + Component_Typ : Entity_Id; + Others_Allowed : Boolean) return Boolean; + -- This procedure performs the semantic checks for an array aggregate. + -- True is returned if the aggregate resolution succeeds. + -- + -- The procedure works by recursively checking each nested aggregate. + -- Specifically, after checking a sub-aggregate nested at the i-th level + -- we recursively check all the subaggregates at the i+1-st level (if any). + -- Note that for aggregates analysis and resolution go hand in hand. + -- Aggregate analysis has been delayed up to here and it is done while + -- resolving the aggregate. + -- + -- N is the current N_Aggregate node to be checked. + -- + -- Index is the index node corresponding to the array sub-aggregate that + -- we are currently checking (RM 4.3.3 (8)). Its Etype is the + -- corresponding index type (or subtype). + -- + -- Index_Constr is the node giving the applicable index constraint if + -- any (RM 4.3.3 (10)). It "is a constraint provided by certain + -- contexts [...] that can be used to determine the bounds of the array + -- value specified by the aggregate". If Others_Allowed below is False + -- there is no applicable index constraint and this node is set to Index. + -- + -- Component_Typ is the array component type. + -- + -- Others_Allowed indicates whether an others choice is allowed + -- in the context where the top-level aggregate appeared. + -- + -- The algorithm of Resolve_Array_Aggregate proceeds as follows: + -- + -- 1. Make sure that the others choice, if present, is by itself and + -- appears last in the sub-aggregate. Check that we do not have + -- positional and named components in the array sub-aggregate (unless + -- the named association is an others choice). Finally if an others + -- choice is present, make sure it is allowed in the aggregate context. + -- + -- 2. If the array sub-aggregate contains discrete_choices: + -- + -- (A) Verify their validity. Specifically verify that: + -- + -- (a) If a null range is present it must be the only possible + -- choice in the array aggregate. + -- + -- (b) Ditto for a non static range. + -- + -- (c) Ditto for a non static expression. + -- + -- In addition this step analyzes and resolves each discrete_choice, + -- making sure that its type is the type of the corresponding Index. + -- If we are not at the lowest array aggregate level (in the case of + -- multi-dimensional aggregates) then invoke Resolve_Array_Aggregate + -- recursively on each component expression. Otherwise, resolve the + -- bottom level component expressions against the expected component + -- type ONLY IF the component corresponds to a single discrete choice + -- which is not an others choice (to see why read the DELAYED + -- COMPONENT RESOLUTION below). + -- + -- (B) Determine the bounds of the sub-aggregate and lowest and + -- highest choice values. + -- + -- 3. For positional aggregates: + -- + -- (A) Loop over the component expressions either recursively invoking + -- Resolve_Array_Aggregate on each of these for multi-dimensional + -- array aggregates or resolving the bottom level component + -- expressions against the expected component type. + -- + -- (B) Determine the bounds of the positional sub-aggregates. + -- + -- 4. Try to determine statically whether the evaluation of the array + -- sub-aggregate raises Constraint_Error. If yes emit proper + -- warnings. The precise checks are the following: + -- + -- (A) Check that the index range defined by aggregate bounds is + -- compatible with corresponding index subtype. + -- We also check against the base type. In fact it could be that + -- Low/High bounds of the base type are static whereas those of + -- the index subtype are not. Thus if we can statically catch + -- a problem with respect to the base type we are guaranteed + -- that the same problem will arise with the index subtype + -- + -- (B) If we are dealing with a named aggregate containing an others + -- choice and at least one discrete choice then make sure the range + -- specified by the discrete choices does not overflow the + -- aggregate bounds. We also check against the index type and base + -- type bounds for the same reasons given in (A). + -- + -- (C) If we are dealing with a positional aggregate with an others + -- choice make sure the number of positional elements specified + -- does not overflow the aggregate bounds. We also check against + -- the index type and base type bounds as mentioned in (A). + -- + -- Finally construct an N_Range node giving the sub-aggregate bounds. + -- Set the Aggregate_Bounds field of the sub-aggregate to be this + -- N_Range. The routine Array_Aggr_Subtype below uses such N_Ranges + -- to build the appropriate aggregate subtype. Aggregate_Bounds + -- information is needed during expansion. + -- + -- DELAYED COMPONENT RESOLUTION: The resolution of bottom level component + -- expressions in an array aggregate may call Duplicate_Subexpr or some + -- other routine that inserts code just outside the outermost aggregate. + -- If the array aggregate contains discrete choices or an others choice, + -- this may be wrong. Consider for instance the following example. + -- + -- type Rec is record + -- V : Integer := 0; + -- end record; + -- + -- type Acc_Rec is access Rec; + -- Arr : array (1..3) of Acc_Rec := (1 .. 3 => new Rec); + -- + -- Then the transformation of "new Rec" that occurs during resolution + -- entails the following code modifications + -- + -- P7b : constant Acc_Rec := new Rec; + -- RecIP (P7b.all); + -- Arr : array (1..3) of Acc_Rec := (1 .. 3 => P7b); + -- + -- This code transformation is clearly wrong, since we need to call + -- "new Rec" for each of the 3 array elements. To avoid this problem we + -- delay resolution of the components of non positional array aggregates + -- to the expansion phase. As an optimization, if the discrete choice + -- specifies a single value we do not delay resolution. + + function Array_Aggr_Subtype (N : Node_Id; Typ : Node_Id) return Entity_Id; + -- This routine returns the type or subtype of an array aggregate. + -- + -- N is the array aggregate node whose type we return. + -- + -- Typ is the context type in which N occurs. + -- + -- This routine creates an implicit array subtype whose bounds are + -- those defined by the aggregate. When this routine is invoked + -- Resolve_Array_Aggregate has already processed aggregate N. Thus the + -- Aggregate_Bounds of each sub-aggregate, is an N_Range node giving the + -- sub-aggregate bounds. When building the aggregate itype, this function + -- traverses the array aggregate N collecting such Aggregate_Bounds and + -- constructs the proper array aggregate itype. + -- + -- Note that in the case of multidimensional aggregates each inner + -- sub-aggregate corresponding to a given array dimension, may provide a + -- different bounds. If it is possible to determine statically that + -- some sub-aggregates corresponding to the same index do not have the + -- same bounds, then a warning is emitted. If such check is not possible + -- statically (because some sub-aggregate bounds are dynamic expressions) + -- then this job is left to the expander. In all cases the particular + -- bounds that this function will chose for a given dimension is the first + -- N_Range node for a sub-aggregate corresponding to that dimension. + -- + -- Note that the Raises_Constraint_Error flag of an array aggregate + -- whose evaluation is determined to raise CE by Resolve_Array_Aggregate, + -- is set in Resolve_Array_Aggregate but the aggregate is not + -- immediately replaced with a raise CE. In fact, Array_Aggr_Subtype must + -- first construct the proper itype for the aggregate (Gigi needs + -- this). After constructing the proper itype we will eventually replace + -- the top-level aggregate with a raise CE (done in Resolve_Aggregate). + -- Of course in cases such as: + -- + -- type Arr is array (integer range <>) of Integer; + -- A : Arr := (positive range -1 .. 2 => 0); + -- + -- The bounds of the aggregate itype are cooked up to look reasonable + -- (in this particular case the bounds will be 1 .. 2). + + procedure Aggregate_Constraint_Checks + (Exp : Node_Id; + Check_Typ : Entity_Id); + -- Checks expression Exp against subtype Check_Typ. If Exp is an + -- aggregate and Check_Typ a constrained record type with discriminants, + -- we generate the appropriate discriminant checks. If Exp is an array + -- aggregate then emit the appropriate length checks. If Exp is a scalar + -- type, or a string literal, Exp is changed into Check_Typ'(Exp) to + -- ensure that range checks are performed at run time. + + procedure Make_String_Into_Aggregate (N : Node_Id); + -- A string literal can appear in a context in which a one dimensional + -- array of characters is expected. This procedure simply rewrites the + -- string as an aggregate, prior to resolution. + + --------------------------------- + -- Aggregate_Constraint_Checks -- + --------------------------------- + + procedure Aggregate_Constraint_Checks + (Exp : Node_Id; + Check_Typ : Entity_Id) + is + Exp_Typ : constant Entity_Id := Etype (Exp); + + begin + if Raises_Constraint_Error (Exp) then + return; + end if; + + -- Ada 2005 (AI-230): Generate a conversion to an anonymous access + -- component's type to force the appropriate accessibility checks. + + -- Ada 2005 (AI-231): Generate conversion to the null-excluding + -- type to force the corresponding run-time check + + if Is_Access_Type (Check_Typ) + and then ((Is_Local_Anonymous_Access (Check_Typ)) + or else (Can_Never_Be_Null (Check_Typ) + and then not Can_Never_Be_Null (Exp_Typ))) + then + Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); + Analyze_And_Resolve (Exp, Check_Typ); + Check_Unset_Reference (Exp); + end if; + + -- This is really expansion activity, so make sure that expansion + -- is on and is allowed. + + if not Expander_Active or else In_Spec_Expression then + return; + end if; + + -- First check if we have to insert discriminant checks + + if Has_Discriminants (Exp_Typ) then + Apply_Discriminant_Check (Exp, Check_Typ); + + -- Next emit length checks for array aggregates + + elsif Is_Array_Type (Exp_Typ) then + Apply_Length_Check (Exp, Check_Typ); + + -- Finally emit scalar and string checks. If we are dealing with a + -- scalar literal we need to check by hand because the Etype of + -- literals is not necessarily correct. + + elsif Is_Scalar_Type (Exp_Typ) + and then Compile_Time_Known_Value (Exp) + then + if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then + Apply_Compile_Time_Constraint_Error + (Exp, "value not in range of}?", CE_Range_Check_Failed, + Ent => Base_Type (Check_Typ), + Typ => Base_Type (Check_Typ)); + + elsif Is_Out_Of_Range (Exp, Check_Typ) then + Apply_Compile_Time_Constraint_Error + (Exp, "value not in range of}?", CE_Range_Check_Failed, + Ent => Check_Typ, + Typ => Check_Typ); + + elsif not Range_Checks_Suppressed (Check_Typ) then + Apply_Scalar_Range_Check (Exp, Check_Typ); + end if; + + -- Verify that target type is also scalar, to prevent view anomalies + -- in instantiations. + + elsif (Is_Scalar_Type (Exp_Typ) + or else Nkind (Exp) = N_String_Literal) + and then Is_Scalar_Type (Check_Typ) + and then Exp_Typ /= Check_Typ + then + if Is_Entity_Name (Exp) + and then Ekind (Entity (Exp)) = E_Constant + then + -- If expression is a constant, it is worthwhile checking whether + -- it is a bound of the type. + + if (Is_Entity_Name (Type_Low_Bound (Check_Typ)) + and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ))) + or else (Is_Entity_Name (Type_High_Bound (Check_Typ)) + and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ))) + then + return; + + else + Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); + Analyze_And_Resolve (Exp, Check_Typ); + Check_Unset_Reference (Exp); + end if; + else + Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); + Analyze_And_Resolve (Exp, Check_Typ); + Check_Unset_Reference (Exp); + end if; + + end if; + end Aggregate_Constraint_Checks; + + ------------------------ + -- Array_Aggr_Subtype -- + ------------------------ + + function Array_Aggr_Subtype + (N : Node_Id; + Typ : Entity_Id) return Entity_Id + is + Aggr_Dimension : constant Pos := Number_Dimensions (Typ); + -- Number of aggregate index dimensions + + Aggr_Range : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty); + -- Constrained N_Range of each index dimension in our aggregate itype + + Aggr_Low : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty); + Aggr_High : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty); + -- Low and High bounds for each index dimension in our aggregate itype + + Is_Fully_Positional : Boolean := True; + + procedure Collect_Aggr_Bounds (N : Node_Id; Dim : Pos); + -- N is an array (sub-)aggregate. Dim is the dimension corresponding + -- to (sub-)aggregate N. This procedure collects and removes the side + -- effects of the constrained N_Range nodes corresponding to each index + -- dimension of our aggregate itype. These N_Range nodes are collected + -- in Aggr_Range above. + -- + -- Likewise collect in Aggr_Low & Aggr_High above the low and high + -- bounds of each index dimension. If, when collecting, two bounds + -- corresponding to the same dimension are static and found to differ, + -- then emit a warning, and mark N as raising Constraint_Error. + + ------------------------- + -- Collect_Aggr_Bounds -- + ------------------------- + + procedure Collect_Aggr_Bounds (N : Node_Id; Dim : Pos) is + This_Range : constant Node_Id := Aggregate_Bounds (N); + -- The aggregate range node of this specific sub-aggregate + + This_Low : constant Node_Id := Low_Bound (Aggregate_Bounds (N)); + This_High : constant Node_Id := High_Bound (Aggregate_Bounds (N)); + -- The aggregate bounds of this specific sub-aggregate + + Assoc : Node_Id; + Expr : Node_Id; + + begin + Remove_Side_Effects (This_Low, Variable_Ref => True); + Remove_Side_Effects (This_High, Variable_Ref => True); + + -- Collect the first N_Range for a given dimension that you find. + -- For a given dimension they must be all equal anyway. + + if No (Aggr_Range (Dim)) then + Aggr_Low (Dim) := This_Low; + Aggr_High (Dim) := This_High; + Aggr_Range (Dim) := This_Range; + + else + if Compile_Time_Known_Value (This_Low) then + if not Compile_Time_Known_Value (Aggr_Low (Dim)) then + Aggr_Low (Dim) := This_Low; + + elsif Expr_Value (This_Low) /= Expr_Value (Aggr_Low (Dim)) then + Set_Raises_Constraint_Error (N); + Error_Msg_N ("sub-aggregate low bound mismatch?", N); + Error_Msg_N + ("\Constraint_Error will be raised at run time?", N); + end if; + end if; + + if Compile_Time_Known_Value (This_High) then + if not Compile_Time_Known_Value (Aggr_High (Dim)) then + Aggr_High (Dim) := This_High; + + elsif + Expr_Value (This_High) /= Expr_Value (Aggr_High (Dim)) + then + Set_Raises_Constraint_Error (N); + Error_Msg_N ("sub-aggregate high bound mismatch?", N); + Error_Msg_N + ("\Constraint_Error will be raised at run time?", N); + end if; + end if; + end if; + + if Dim < Aggr_Dimension then + + -- Process positional components + + if Present (Expressions (N)) then + Expr := First (Expressions (N)); + while Present (Expr) loop + Collect_Aggr_Bounds (Expr, Dim + 1); + Next (Expr); + end loop; + end if; + + -- Process component associations + + if Present (Component_Associations (N)) then + Is_Fully_Positional := False; + + Assoc := First (Component_Associations (N)); + while Present (Assoc) loop + Expr := Expression (Assoc); + Collect_Aggr_Bounds (Expr, Dim + 1); + Next (Assoc); + end loop; + end if; + end if; + end Collect_Aggr_Bounds; + + -- Array_Aggr_Subtype variables + + Itype : Entity_Id; + -- The final itype of the overall aggregate + + Index_Constraints : constant List_Id := New_List; + -- The list of index constraints of the aggregate itype + + -- Start of processing for Array_Aggr_Subtype + + begin + -- Make sure that the list of index constraints is properly attached to + -- the tree, and then collect the aggregate bounds. + + Set_Parent (Index_Constraints, N); + Collect_Aggr_Bounds (N, 1); + + -- Build the list of constrained indexes of our aggregate itype + + for J in 1 .. Aggr_Dimension loop + Create_Index : declare + Index_Base : constant Entity_Id := + Base_Type (Etype (Aggr_Range (J))); + Index_Typ : Entity_Id; + + begin + -- Construct the Index subtype, and associate it with the range + -- construct that generates it. + + Index_Typ := + Create_Itype (Subtype_Kind (Ekind (Index_Base)), Aggr_Range (J)); + + Set_Etype (Index_Typ, Index_Base); + + if Is_Character_Type (Index_Base) then + Set_Is_Character_Type (Index_Typ); + end if; + + Set_Size_Info (Index_Typ, (Index_Base)); + Set_RM_Size (Index_Typ, RM_Size (Index_Base)); + Set_First_Rep_Item (Index_Typ, First_Rep_Item (Index_Base)); + Set_Scalar_Range (Index_Typ, Aggr_Range (J)); + + if Is_Discrete_Or_Fixed_Point_Type (Index_Typ) then + Set_RM_Size (Index_Typ, UI_From_Int (Minimum_Size (Index_Typ))); + end if; + + Set_Etype (Aggr_Range (J), Index_Typ); + + Append (Aggr_Range (J), To => Index_Constraints); + end Create_Index; + end loop; + + -- Now build the Itype + + Itype := Create_Itype (E_Array_Subtype, N); + + Set_First_Rep_Item (Itype, First_Rep_Item (Typ)); + Set_Convention (Itype, Convention (Typ)); + Set_Depends_On_Private (Itype, Has_Private_Component (Typ)); + Set_Etype (Itype, Base_Type (Typ)); + Set_Has_Alignment_Clause (Itype, Has_Alignment_Clause (Typ)); + Set_Is_Aliased (Itype, Is_Aliased (Typ)); + Set_Depends_On_Private (Itype, Depends_On_Private (Typ)); + + Copy_Suppress_Status (Index_Check, Typ, Itype); + Copy_Suppress_Status (Length_Check, Typ, Itype); + + Set_First_Index (Itype, First (Index_Constraints)); + Set_Is_Constrained (Itype, True); + Set_Is_Internal (Itype, True); + + -- A simple optimization: purely positional aggregates of static + -- components should be passed to gigi unexpanded whenever possible, and + -- regardless of the staticness of the bounds themselves. Subsequent + -- checks in exp_aggr verify that type is not packed, etc. + + Set_Size_Known_At_Compile_Time (Itype, + Is_Fully_Positional + and then Comes_From_Source (N) + and then Size_Known_At_Compile_Time (Component_Type (Typ))); + + -- We always need a freeze node for a packed array subtype, so that we + -- can build the Packed_Array_Type corresponding to the subtype. If + -- expansion is disabled, the packed array subtype is not built, and we + -- must not generate a freeze node for the type, or else it will appear + -- incomplete to gigi. + + if Is_Packed (Itype) + and then not In_Spec_Expression + and then Expander_Active + then + Freeze_Itype (Itype, N); + end if; + + return Itype; + end Array_Aggr_Subtype; + + -------------------------------- + -- Check_Misspelled_Component -- + -------------------------------- + + procedure Check_Misspelled_Component + (Elements : Elist_Id; + Component : Node_Id) + is + Max_Suggestions : constant := 2; + + Nr_Of_Suggestions : Natural := 0; + Suggestion_1 : Entity_Id := Empty; + Suggestion_2 : Entity_Id := Empty; + Component_Elmt : Elmt_Id; + + begin + -- All the components of List are matched against Component and a count + -- is maintained of possible misspellings. When at the end of the + -- the analysis there are one or two (not more!) possible misspellings, + -- these misspellings will be suggested as possible correction. + + Component_Elmt := First_Elmt (Elements); + while Nr_Of_Suggestions <= Max_Suggestions + and then Present (Component_Elmt) + loop + if Is_Bad_Spelling_Of + (Chars (Node (Component_Elmt)), + Chars (Component)) + then + Nr_Of_Suggestions := Nr_Of_Suggestions + 1; + + case Nr_Of_Suggestions is + when 1 => Suggestion_1 := Node (Component_Elmt); + when 2 => Suggestion_2 := Node (Component_Elmt); + when others => exit; + end case; + end if; + + Next_Elmt (Component_Elmt); + end loop; + + -- Report at most two suggestions + + if Nr_Of_Suggestions = 1 then + Error_Msg_NE -- CODEFIX + ("\possible misspelling of&", Component, Suggestion_1); + + elsif Nr_Of_Suggestions = 2 then + Error_Msg_Node_2 := Suggestion_2; + Error_Msg_NE -- CODEFIX + ("\possible misspelling of& or&", Component, Suggestion_1); + end if; + end Check_Misspelled_Component; + + ---------------------------------------- + -- Check_Expr_OK_In_Limited_Aggregate -- + ---------------------------------------- + + procedure Check_Expr_OK_In_Limited_Aggregate (Expr : Node_Id) is + begin + if Is_Limited_Type (Etype (Expr)) + and then Comes_From_Source (Expr) + and then not In_Instance_Body + then + if not OK_For_Limited_Init (Etype (Expr), Expr) then + Error_Msg_N ("initialization not allowed for limited types", Expr); + Explain_Limited_Type (Etype (Expr), Expr); + end if; + end if; + end Check_Expr_OK_In_Limited_Aggregate; + + ---------------------------------------- + -- Check_Static_Discriminated_Subtype -- + ---------------------------------------- + + procedure Check_Static_Discriminated_Subtype (T : Entity_Id; V : Node_Id) is + Disc : constant Entity_Id := First_Discriminant (T); + Comp : Entity_Id; + Ind : Entity_Id; + + begin + if Has_Record_Rep_Clause (T) then + return; + + elsif Present (Next_Discriminant (Disc)) then + return; + + elsif Nkind (V) /= N_Integer_Literal then + return; + end if; + + Comp := First_Component (T); + while Present (Comp) loop + if Is_Scalar_Type (Etype (Comp)) then + null; + + elsif Is_Private_Type (Etype (Comp)) + and then Present (Full_View (Etype (Comp))) + and then Is_Scalar_Type (Full_View (Etype (Comp))) + then + null; + + elsif Is_Array_Type (Etype (Comp)) then + if Is_Bit_Packed_Array (Etype (Comp)) then + return; + end if; + + Ind := First_Index (Etype (Comp)); + while Present (Ind) loop + if Nkind (Ind) /= N_Range + or else Nkind (Low_Bound (Ind)) /= N_Integer_Literal + or else Nkind (High_Bound (Ind)) /= N_Integer_Literal + then + return; + end if; + + Next_Index (Ind); + end loop; + + else + return; + end if; + + Next_Component (Comp); + end loop; + + -- On exit, all components have statically known sizes + + Set_Size_Known_At_Compile_Time (T); + end Check_Static_Discriminated_Subtype; + + -------------------------------- + -- Make_String_Into_Aggregate -- + -------------------------------- + + procedure Make_String_Into_Aggregate (N : Node_Id) is + Exprs : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (N); + Str : constant String_Id := Strval (N); + Strlen : constant Nat := String_Length (Str); + C : Char_Code; + C_Node : Node_Id; + New_N : Node_Id; + P : Source_Ptr; + + begin + P := Loc + 1; + for J in 1 .. Strlen loop + C := Get_String_Char (Str, J); + Set_Character_Literal_Name (C); + + C_Node := + Make_Character_Literal (P, + Chars => Name_Find, + Char_Literal_Value => UI_From_CC (C)); + Set_Etype (C_Node, Any_Character); + Append_To (Exprs, C_Node); + + P := P + 1; + -- Something special for wide strings??? + end loop; + + New_N := Make_Aggregate (Loc, Expressions => Exprs); + Set_Analyzed (New_N); + Set_Etype (New_N, Any_Composite); + + Rewrite (N, New_N); + end Make_String_Into_Aggregate; + + ----------------------- + -- Resolve_Aggregate -- + ----------------------- + + procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Pkind : constant Node_Kind := Nkind (Parent (N)); + + Aggr_Subtyp : Entity_Id; + -- The actual aggregate subtype. This is not necessarily the same as Typ + -- which is the subtype of the context in which the aggregate was found. + + begin + -- Ignore junk empty aggregate resulting from parser error + + if No (Expressions (N)) + and then No (Component_Associations (N)) + and then not Null_Record_Present (N) + then + return; + end if; + + -- Check for aggregates not allowed in configurable run-time mode. + -- We allow all cases of aggregates that do not come from source, since + -- these are all assumed to be small (e.g. bounds of a string literal). + -- We also allow aggregates of types we know to be small. + + if not Support_Aggregates_On_Target + and then Comes_From_Source (N) + and then (not Known_Static_Esize (Typ) or else Esize (Typ) > 64) + then + Error_Msg_CRT ("aggregate", N); + end if; + + -- Ada 2005 (AI-287): Limited aggregates allowed + + if Is_Limited_Type (Typ) and then Ada_Version < Ada_2005 then + Error_Msg_N ("aggregate type cannot be limited", N); + Explain_Limited_Type (Typ, N); + + elsif Is_Class_Wide_Type (Typ) then + Error_Msg_N ("type of aggregate cannot be class-wide", N); + + elsif Typ = Any_String + or else Typ = Any_Composite + then + Error_Msg_N ("no unique type for aggregate", N); + Set_Etype (N, Any_Composite); + + elsif Is_Array_Type (Typ) and then Null_Record_Present (N) then + Error_Msg_N ("null record forbidden in array aggregate", N); + + elsif Is_Record_Type (Typ) then + Resolve_Record_Aggregate (N, Typ); + + elsif Is_Array_Type (Typ) then + + -- First a special test, for the case of a positional aggregate + -- of characters which can be replaced by a string literal. + + -- Do not perform this transformation if this was a string literal to + -- start with, whose components needed constraint checks, or if the + -- component type is non-static, because it will require those checks + -- and be transformed back into an aggregate. + + if Number_Dimensions (Typ) = 1 + and then Is_Standard_Character_Type (Component_Type (Typ)) + and then No (Component_Associations (N)) + and then not Is_Limited_Composite (Typ) + and then not Is_Private_Composite (Typ) + and then not Is_Bit_Packed_Array (Typ) + and then Nkind (Original_Node (Parent (N))) /= N_String_Literal + and then Is_Static_Subtype (Component_Type (Typ)) + then + declare + Expr : Node_Id; + + begin + Expr := First (Expressions (N)); + while Present (Expr) loop + exit when Nkind (Expr) /= N_Character_Literal; + Next (Expr); + end loop; + + if No (Expr) then + Start_String; + + Expr := First (Expressions (N)); + while Present (Expr) loop + Store_String_Char (UI_To_CC (Char_Literal_Value (Expr))); + Next (Expr); + end loop; + + Rewrite (N, Make_String_Literal (Loc, End_String)); + + Analyze_And_Resolve (N, Typ); + return; + end if; + end; + end if; + + -- Here if we have a real aggregate to deal with + + Array_Aggregate : declare + Aggr_Resolved : Boolean; + + Aggr_Typ : constant Entity_Id := Etype (Typ); + -- This is the unconstrained array type, which is the type against + -- which the aggregate is to be resolved. Typ itself is the array + -- type of the context which may not be the same subtype as the + -- subtype for the final aggregate. + + begin + -- In the following we determine whether an OTHERS choice is + -- allowed inside the array aggregate. The test checks the context + -- in which the array aggregate occurs. If the context does not + -- permit it, or the aggregate type is unconstrained, an OTHERS + -- choice is not allowed. + + -- If expansion is disabled (generic context, or semantics-only + -- mode) actual subtypes cannot be constructed, and the type of an + -- object may be its unconstrained nominal type. However, if the + -- context is an assignment, we assume that OTHERS is allowed, + -- because the target of the assignment will have a constrained + -- subtype when fully compiled. + + -- Note that there is no node for Explicit_Actual_Parameter. + -- To test for this context we therefore have to test for node + -- N_Parameter_Association which itself appears only if there is a + -- formal parameter. Consequently we also need to test for + -- N_Procedure_Call_Statement or N_Function_Call. + + Set_Etype (N, Aggr_Typ); -- May be overridden later on + + if Is_Constrained (Typ) and then + (Pkind = N_Assignment_Statement or else + Pkind = N_Parameter_Association or else + Pkind = N_Function_Call or else + Pkind = N_Procedure_Call_Statement or else + Pkind = N_Generic_Association or else + Pkind = N_Formal_Object_Declaration or else + Pkind = N_Simple_Return_Statement or else + Pkind = N_Object_Declaration or else + Pkind = N_Component_Declaration or else + Pkind = N_Parameter_Specification or else + Pkind = N_Qualified_Expression or else + Pkind = N_Aggregate or else + Pkind = N_Extension_Aggregate or else + Pkind = N_Component_Association) + then + Aggr_Resolved := + Resolve_Array_Aggregate + (N, + Index => First_Index (Aggr_Typ), + Index_Constr => First_Index (Typ), + Component_Typ => Component_Type (Typ), + Others_Allowed => True); + + elsif not Expander_Active + and then Pkind = N_Assignment_Statement + then + Aggr_Resolved := + Resolve_Array_Aggregate + (N, + Index => First_Index (Aggr_Typ), + Index_Constr => First_Index (Typ), + Component_Typ => Component_Type (Typ), + Others_Allowed => True); + + else + Aggr_Resolved := + Resolve_Array_Aggregate + (N, + Index => First_Index (Aggr_Typ), + Index_Constr => First_Index (Aggr_Typ), + Component_Typ => Component_Type (Typ), + Others_Allowed => False); + end if; + + if not Aggr_Resolved then + Aggr_Subtyp := Any_Composite; + else + Aggr_Subtyp := Array_Aggr_Subtype (N, Typ); + end if; + + Set_Etype (N, Aggr_Subtyp); + end Array_Aggregate; + + elsif Is_Private_Type (Typ) + and then Present (Full_View (Typ)) + and then In_Inlined_Body + and then Is_Composite_Type (Full_View (Typ)) + then + Resolve (N, Full_View (Typ)); + + else + Error_Msg_N ("illegal context for aggregate", N); + end if; + + -- If we can determine statically that the evaluation of the aggregate + -- raises Constraint_Error, then replace the aggregate with an + -- N_Raise_Constraint_Error node, but set the Etype to the right + -- aggregate subtype. Gigi needs this. + + if Raises_Constraint_Error (N) then + Aggr_Subtyp := Etype (N); + Rewrite (N, + Make_Raise_Constraint_Error (Loc, + Reason => CE_Range_Check_Failed)); + Set_Raises_Constraint_Error (N); + Set_Etype (N, Aggr_Subtyp); + Set_Analyzed (N); + end if; + end Resolve_Aggregate; + + ----------------------------- + -- Resolve_Array_Aggregate -- + ----------------------------- + + function Resolve_Array_Aggregate + (N : Node_Id; + Index : Node_Id; + Index_Constr : Node_Id; + Component_Typ : Entity_Id; + Others_Allowed : Boolean) return Boolean + is + Loc : constant Source_Ptr := Sloc (N); + + Failure : constant Boolean := False; + Success : constant Boolean := True; + + Index_Typ : constant Entity_Id := Etype (Index); + Index_Typ_Low : constant Node_Id := Type_Low_Bound (Index_Typ); + Index_Typ_High : constant Node_Id := Type_High_Bound (Index_Typ); + -- The type of the index corresponding to the array sub-aggregate along + -- with its low and upper bounds. + + Index_Base : constant Entity_Id := Base_Type (Index_Typ); + Index_Base_Low : constant Node_Id := Type_Low_Bound (Index_Base); + Index_Base_High : constant Node_Id := Type_High_Bound (Index_Base); + -- Ditto for the base type + + function Add (Val : Uint; To : Node_Id) return Node_Id; + -- Creates a new expression node where Val is added to expression To. + -- Tries to constant fold whenever possible. To must be an already + -- analyzed expression. + + procedure Check_Bound (BH : Node_Id; AH : in out Node_Id); + -- Checks that AH (the upper bound of an array aggregate) is less than + -- or equal to BH (the upper bound of the index base type). If the check + -- fails, a warning is emitted, the Raises_Constraint_Error flag of N is + -- set, and AH is replaced with a duplicate of BH. + + procedure Check_Bounds (L, H : Node_Id; AL, AH : Node_Id); + -- Checks that range AL .. AH is compatible with range L .. H. Emits a + -- warning if not and sets the Raises_Constraint_Error flag in N. + + procedure Check_Length (L, H : Node_Id; Len : Uint); + -- Checks that range L .. H contains at least Len elements. Emits a + -- warning if not and sets the Raises_Constraint_Error flag in N. + + function Dynamic_Or_Null_Range (L, H : Node_Id) return Boolean; + -- Returns True if range L .. H is dynamic or null + + procedure Get (Value : out Uint; From : Node_Id; OK : out Boolean); + -- Given expression node From, this routine sets OK to False if it + -- cannot statically evaluate From. Otherwise it stores this static + -- value into Value. + + function Resolve_Aggr_Expr + (Expr : Node_Id; + Single_Elmt : Boolean) return Boolean; + -- Resolves aggregate expression Expr. Returns False if resolution + -- fails. If Single_Elmt is set to False, the expression Expr may be + -- used to initialize several array aggregate elements (this can happen + -- for discrete choices such as "L .. H => Expr" or the OTHERS choice). + -- In this event we do not resolve Expr unless expansion is disabled. + -- To know why, see the DELAYED COMPONENT RESOLUTION note above. + + --------- + -- Add -- + --------- + + function Add (Val : Uint; To : Node_Id) return Node_Id is + Expr_Pos : Node_Id; + Expr : Node_Id; + To_Pos : Node_Id; + + begin + if Raises_Constraint_Error (To) then + return To; + end if; + + -- First test if we can do constant folding + + if Compile_Time_Known_Value (To) + or else Nkind (To) = N_Integer_Literal + then + Expr_Pos := Make_Integer_Literal (Loc, Expr_Value (To) + Val); + Set_Is_Static_Expression (Expr_Pos); + Set_Etype (Expr_Pos, Etype (To)); + Set_Analyzed (Expr_Pos, Analyzed (To)); + + if not Is_Enumeration_Type (Index_Typ) then + Expr := Expr_Pos; + + -- If we are dealing with enumeration return + -- Index_Typ'Val (Expr_Pos) + + else + Expr := + Make_Attribute_Reference + (Loc, + Prefix => New_Reference_To (Index_Typ, Loc), + Attribute_Name => Name_Val, + Expressions => New_List (Expr_Pos)); + end if; + + return Expr; + end if; + + -- If we are here no constant folding possible + + if not Is_Enumeration_Type (Index_Base) then + Expr := + Make_Op_Add (Loc, + Left_Opnd => Duplicate_Subexpr (To), + Right_Opnd => Make_Integer_Literal (Loc, Val)); + + -- If we are dealing with enumeration return + -- Index_Typ'Val (Index_Typ'Pos (To) + Val) + + else + To_Pos := + Make_Attribute_Reference + (Loc, + Prefix => New_Reference_To (Index_Typ, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List (Duplicate_Subexpr (To))); + + Expr_Pos := + Make_Op_Add (Loc, + Left_Opnd => To_Pos, + Right_Opnd => Make_Integer_Literal (Loc, Val)); + + Expr := + Make_Attribute_Reference + (Loc, + Prefix => New_Reference_To (Index_Typ, Loc), + Attribute_Name => Name_Val, + Expressions => New_List (Expr_Pos)); + + -- If the index type has a non standard representation, the + -- attributes 'Val and 'Pos expand into function calls and the + -- resulting expression is considered non-safe for reevaluation + -- by the backend. Relocate it into a constant temporary in order + -- to make it safe for reevaluation. + + if Has_Non_Standard_Rep (Etype (N)) then + declare + Def_Id : Entity_Id; + + begin + Def_Id := Make_Temporary (Loc, 'R', Expr); + Set_Etype (Def_Id, Index_Typ); + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Def_Id, + Object_Definition => New_Reference_To (Index_Typ, Loc), + Constant_Present => True, + Expression => Relocate_Node (Expr))); + + Expr := New_Reference_To (Def_Id, Loc); + end; + end if; + end if; + + return Expr; + end Add; + + ----------------- + -- Check_Bound -- + ----------------- + + procedure Check_Bound (BH : Node_Id; AH : in out Node_Id) is + Val_BH : Uint; + Val_AH : Uint; + + OK_BH : Boolean; + OK_AH : Boolean; + + begin + Get (Value => Val_BH, From => BH, OK => OK_BH); + Get (Value => Val_AH, From => AH, OK => OK_AH); + + if OK_BH and then OK_AH and then Val_BH < Val_AH then + Set_Raises_Constraint_Error (N); + Error_Msg_N ("upper bound out of range?", AH); + Error_Msg_N ("\Constraint_Error will be raised at run time?", AH); + + -- You need to set AH to BH or else in the case of enumerations + -- indexes we will not be able to resolve the aggregate bounds. + + AH := Duplicate_Subexpr (BH); + end if; + end Check_Bound; + + ------------------ + -- Check_Bounds -- + ------------------ + + procedure Check_Bounds (L, H : Node_Id; AL, AH : Node_Id) is + Val_L : Uint; + Val_H : Uint; + Val_AL : Uint; + Val_AH : Uint; + + OK_L : Boolean; + OK_H : Boolean; + + OK_AL : Boolean; + OK_AH : Boolean; + pragma Warnings (Off, OK_AL); + pragma Warnings (Off, OK_AH); + + begin + if Raises_Constraint_Error (N) + or else Dynamic_Or_Null_Range (AL, AH) + then + return; + end if; + + Get (Value => Val_L, From => L, OK => OK_L); + Get (Value => Val_H, From => H, OK => OK_H); + + Get (Value => Val_AL, From => AL, OK => OK_AL); + Get (Value => Val_AH, From => AH, OK => OK_AH); + + if OK_L and then Val_L > Val_AL then + Set_Raises_Constraint_Error (N); + Error_Msg_N ("lower bound of aggregate out of range?", N); + Error_Msg_N ("\Constraint_Error will be raised at run time?", N); + end if; + + if OK_H and then Val_H < Val_AH then + Set_Raises_Constraint_Error (N); + Error_Msg_N ("upper bound of aggregate out of range?", N); + Error_Msg_N ("\Constraint_Error will be raised at run time?", N); + end if; + end Check_Bounds; + + ------------------ + -- Check_Length -- + ------------------ + + procedure Check_Length (L, H : Node_Id; Len : Uint) is + Val_L : Uint; + Val_H : Uint; + + OK_L : Boolean; + OK_H : Boolean; + + Range_Len : Uint; + + begin + if Raises_Constraint_Error (N) then + return; + end if; + + Get (Value => Val_L, From => L, OK => OK_L); + Get (Value => Val_H, From => H, OK => OK_H); + + if not OK_L or else not OK_H then + return; + end if; + + -- If null range length is zero + + if Val_L > Val_H then + Range_Len := Uint_0; + else + Range_Len := Val_H - Val_L + 1; + end if; + + if Range_Len < Len then + Set_Raises_Constraint_Error (N); + Error_Msg_N ("too many elements?", N); + Error_Msg_N ("\Constraint_Error will be raised at run time?", N); + end if; + end Check_Length; + + --------------------------- + -- Dynamic_Or_Null_Range -- + --------------------------- + + function Dynamic_Or_Null_Range (L, H : Node_Id) return Boolean is + Val_L : Uint; + Val_H : Uint; + + OK_L : Boolean; + OK_H : Boolean; + + begin + Get (Value => Val_L, From => L, OK => OK_L); + Get (Value => Val_H, From => H, OK => OK_H); + + return not OK_L or else not OK_H + or else not Is_OK_Static_Expression (L) + or else not Is_OK_Static_Expression (H) + or else Val_L > Val_H; + end Dynamic_Or_Null_Range; + + --------- + -- Get -- + --------- + + procedure Get (Value : out Uint; From : Node_Id; OK : out Boolean) is + begin + OK := True; + + if Compile_Time_Known_Value (From) then + Value := Expr_Value (From); + + -- If expression From is something like Some_Type'Val (10) then + -- Value = 10 + + elsif Nkind (From) = N_Attribute_Reference + and then Attribute_Name (From) = Name_Val + and then Compile_Time_Known_Value (First (Expressions (From))) + then + Value := Expr_Value (First (Expressions (From))); + + else + Value := Uint_0; + OK := False; + end if; + end Get; + + ----------------------- + -- Resolve_Aggr_Expr -- + ----------------------- + + function Resolve_Aggr_Expr + (Expr : Node_Id; + Single_Elmt : Boolean) return Boolean + is + Nxt_Ind : constant Node_Id := Next_Index (Index); + Nxt_Ind_Constr : constant Node_Id := Next_Index (Index_Constr); + -- Index is the current index corresponding to the expression + + Resolution_OK : Boolean := True; + -- Set to False if resolution of the expression failed + + begin + -- Defend against previous errors + + if Nkind (Expr) = N_Error + or else Error_Posted (Expr) + then + return True; + end if; + + -- If the array type against which we are resolving the aggregate + -- has several dimensions, the expressions nested inside the + -- aggregate must be further aggregates (or strings). + + if Present (Nxt_Ind) then + if Nkind (Expr) /= N_Aggregate then + + -- A string literal can appear where a one-dimensional array + -- of characters is expected. If the literal looks like an + -- operator, it is still an operator symbol, which will be + -- transformed into a string when analyzed. + + if Is_Character_Type (Component_Typ) + and then No (Next_Index (Nxt_Ind)) + and then Nkind_In (Expr, N_String_Literal, N_Operator_Symbol) + then + -- A string literal used in a multidimensional array + -- aggregate in place of the final one-dimensional + -- aggregate must not be enclosed in parentheses. + + if Paren_Count (Expr) /= 0 then + Error_Msg_N ("no parenthesis allowed here", Expr); + end if; + + Make_String_Into_Aggregate (Expr); + + else + Error_Msg_N ("nested array aggregate expected", Expr); + + -- If the expression is parenthesized, this may be + -- a missing component association for a 1-aggregate. + + if Paren_Count (Expr) > 0 then + Error_Msg_N + ("\if single-component aggregate is intended," + & " write e.g. (1 ='> ...)", Expr); + end if; + return Failure; + end if; + end if; + + -- Ada 2005 (AI-231): Propagate the type to the nested aggregate. + -- Required to check the null-exclusion attribute (if present). + -- This value may be overridden later on. + + Set_Etype (Expr, Etype (N)); + + Resolution_OK := Resolve_Array_Aggregate + (Expr, Nxt_Ind, Nxt_Ind_Constr, Component_Typ, Others_Allowed); + + -- Do not resolve the expressions of discrete or others choices + -- unless the expression covers a single component, or the expander + -- is inactive. + + elsif Single_Elmt + or else not Expander_Active + or else In_Spec_Expression + then + Analyze_And_Resolve (Expr, Component_Typ); + Check_Expr_OK_In_Limited_Aggregate (Expr); + Check_Non_Static_Context (Expr); + Aggregate_Constraint_Checks (Expr, Component_Typ); + Check_Unset_Reference (Expr); + end if; + + if Raises_Constraint_Error (Expr) + and then Nkind (Parent (Expr)) /= N_Component_Association + then + Set_Raises_Constraint_Error (N); + end if; + + -- If the expression has been marked as requiring a range check, + -- then generate it here. + + if Do_Range_Check (Expr) then + Set_Do_Range_Check (Expr, False); + Generate_Range_Check (Expr, Component_Typ, CE_Range_Check_Failed); + end if; + + return Resolution_OK; + end Resolve_Aggr_Expr; + + -- Variables local to Resolve_Array_Aggregate + + Assoc : Node_Id; + Choice : Node_Id; + Expr : Node_Id; + + Discard : Node_Id; + pragma Warnings (Off, Discard); + + Aggr_Low : Node_Id := Empty; + Aggr_High : Node_Id := Empty; + -- The actual low and high bounds of this sub-aggregate + + Choices_Low : Node_Id := Empty; + Choices_High : Node_Id := Empty; + -- The lowest and highest discrete choices values for a named aggregate + + Nb_Elements : Uint := Uint_0; + -- The number of elements in a positional aggregate + + Others_Present : Boolean := False; + + Nb_Choices : Nat := 0; + -- Contains the overall number of named choices in this sub-aggregate + + Nb_Discrete_Choices : Nat := 0; + -- The overall number of discrete choices (not counting others choice) + + Case_Table_Size : Nat; + -- Contains the size of the case table needed to sort aggregate choices + + -- Start of processing for Resolve_Array_Aggregate + + begin + -- Ignore junk empty aggregate resulting from parser error + + if No (Expressions (N)) + and then No (Component_Associations (N)) + and then not Null_Record_Present (N) + then + return False; + end if; + + -- STEP 1: make sure the aggregate is correctly formatted + + if Present (Component_Associations (N)) then + Assoc := First (Component_Associations (N)); + while Present (Assoc) loop + Choice := First (Choices (Assoc)); + while Present (Choice) loop + if Nkind (Choice) = N_Others_Choice then + Others_Present := True; + + if Choice /= First (Choices (Assoc)) + or else Present (Next (Choice)) + then + Error_Msg_N + ("OTHERS must appear alone in a choice list", Choice); + return Failure; + end if; + + if Present (Next (Assoc)) then + Error_Msg_N + ("OTHERS must appear last in an aggregate", Choice); + return Failure; + end if; + + if Ada_Version = Ada_83 + and then Assoc /= First (Component_Associations (N)) + and then Nkind_In (Parent (N), N_Assignment_Statement, + N_Object_Declaration) + then + Error_Msg_N + ("(Ada 83) illegal context for OTHERS choice", N); + end if; + end if; + + Nb_Choices := Nb_Choices + 1; + Next (Choice); + end loop; + + Next (Assoc); + end loop; + end if; + + -- At this point we know that the others choice, if present, is by + -- itself and appears last in the aggregate. Check if we have mixed + -- positional and discrete associations (other than the others choice). + + if Present (Expressions (N)) + and then (Nb_Choices > 1 + or else (Nb_Choices = 1 and then not Others_Present)) + then + Error_Msg_N + ("named association cannot follow positional association", + First (Choices (First (Component_Associations (N))))); + return Failure; + end if; + + -- Test for the validity of an others choice if present + + if Others_Present and then not Others_Allowed then + Error_Msg_N + ("OTHERS choice not allowed here", + First (Choices (First (Component_Associations (N))))); + return Failure; + end if; + + -- Protect against cascaded errors + + if Etype (Index_Typ) = Any_Type then + return Failure; + end if; + + -- STEP 2: Process named components + + if No (Expressions (N)) then + if Others_Present then + Case_Table_Size := Nb_Choices - 1; + else + Case_Table_Size := Nb_Choices; + end if; + + Step_2 : declare + Low : Node_Id; + High : Node_Id; + -- Denote the lowest and highest values in an aggregate choice + + Hi_Val : Uint; + Lo_Val : Uint; + -- High end of one range and Low end of the next. Should be + -- contiguous if there is no hole in the list of values. + + Missing_Values : Boolean; + -- Set True if missing index values + + S_Low : Node_Id := Empty; + S_High : Node_Id := Empty; + -- if a choice in an aggregate is a subtype indication these + -- denote the lowest and highest values of the subtype + + Table : Case_Table_Type (1 .. Case_Table_Size); + -- Used to sort all the different choice values + + Single_Choice : Boolean; + -- Set to true every time there is a single discrete choice in a + -- discrete association + + Prev_Nb_Discrete_Choices : Nat; + -- Used to keep track of the number of discrete choices in the + -- current association. + + begin + -- STEP 2 (A): Check discrete choices validity + + Assoc := First (Component_Associations (N)); + while Present (Assoc) loop + Prev_Nb_Discrete_Choices := Nb_Discrete_Choices; + Choice := First (Choices (Assoc)); + loop + Analyze (Choice); + + if Nkind (Choice) = N_Others_Choice then + Single_Choice := False; + exit; + + -- Test for subtype mark without constraint + + elsif Is_Entity_Name (Choice) and then + Is_Type (Entity (Choice)) + then + if Base_Type (Entity (Choice)) /= Index_Base then + Error_Msg_N + ("invalid subtype mark in aggregate choice", + Choice); + return Failure; + end if; + + -- Case of subtype indication + + elsif Nkind (Choice) = N_Subtype_Indication then + Resolve_Discrete_Subtype_Indication (Choice, Index_Base); + + -- Does the subtype indication evaluation raise CE ? + + Get_Index_Bounds (Subtype_Mark (Choice), S_Low, S_High); + Get_Index_Bounds (Choice, Low, High); + Check_Bounds (S_Low, S_High, Low, High); + + -- Case of range or expression + + else + Resolve (Choice, Index_Base); + Check_Unset_Reference (Choice); + Check_Non_Static_Context (Choice); + + -- Do not range check a choice. This check is redundant + -- since this test is already done when we check that the + -- bounds of the array aggregate are within range. + + Set_Do_Range_Check (Choice, False); + end if; + + -- If we could not resolve the discrete choice stop here + + if Etype (Choice) = Any_Type then + return Failure; + + -- If the discrete choice raises CE get its original bounds + + elsif Nkind (Choice) = N_Raise_Constraint_Error then + Set_Raises_Constraint_Error (N); + Get_Index_Bounds (Original_Node (Choice), Low, High); + + -- Otherwise get its bounds as usual + + else + Get_Index_Bounds (Choice, Low, High); + end if; + + if (Dynamic_Or_Null_Range (Low, High) + or else (Nkind (Choice) = N_Subtype_Indication + and then + Dynamic_Or_Null_Range (S_Low, S_High))) + and then Nb_Choices /= 1 + then + Error_Msg_N + ("dynamic or empty choice in aggregate " & + "must be the only choice", Choice); + return Failure; + end if; + + Nb_Discrete_Choices := Nb_Discrete_Choices + 1; + Table (Nb_Discrete_Choices).Choice_Lo := Low; + Table (Nb_Discrete_Choices).Choice_Hi := High; + + Next (Choice); + + if No (Choice) then + + -- Check if we have a single discrete choice and whether + -- this discrete choice specifies a single value. + + Single_Choice := + (Nb_Discrete_Choices = Prev_Nb_Discrete_Choices + 1) + and then (Low = High); + + exit; + end if; + end loop; + + -- Ada 2005 (AI-231) + + if Ada_Version >= Ada_2005 + and then Known_Null (Expression (Assoc)) + then + Check_Can_Never_Be_Null (Etype (N), Expression (Assoc)); + end if; + + -- Ada 2005 (AI-287): In case of default initialized component + -- we delay the resolution to the expansion phase. + + if Box_Present (Assoc) then + + -- Ada 2005 (AI-287): In case of default initialization of a + -- component the expander will generate calls to the + -- corresponding initialization subprogram. + + null; + + elsif not Resolve_Aggr_Expr (Expression (Assoc), + Single_Elmt => Single_Choice) + then + return Failure; + + -- Check incorrect use of dynamically tagged expression + + -- We differentiate here two cases because the expression may + -- not be decorated. For example, the analysis and resolution + -- of the expression associated with the others choice will be + -- done later with the full aggregate. In such case we + -- duplicate the expression tree to analyze the copy and + -- perform the required check. + + elsif not Present (Etype (Expression (Assoc))) then + declare + Save_Analysis : constant Boolean := Full_Analysis; + Expr : constant Node_Id := + New_Copy_Tree (Expression (Assoc)); + + begin + Expander_Mode_Save_And_Set (False); + Full_Analysis := False; + Analyze (Expr); + + -- If the expression is a literal, propagate this info + -- to the expression in the association, to enable some + -- optimizations downstream. + + if Is_Entity_Name (Expr) + and then Present (Entity (Expr)) + and then Ekind (Entity (Expr)) = E_Enumeration_Literal + then + Analyze_And_Resolve + (Expression (Assoc), Component_Typ); + end if; + + Full_Analysis := Save_Analysis; + Expander_Mode_Restore; + + if Is_Tagged_Type (Etype (Expr)) then + Check_Dynamically_Tagged_Expression + (Expr => Expr, + Typ => Component_Type (Etype (N)), + Related_Nod => N); + end if; + end; + + elsif Is_Tagged_Type (Etype (Expression (Assoc))) then + Check_Dynamically_Tagged_Expression + (Expr => Expression (Assoc), + Typ => Component_Type (Etype (N)), + Related_Nod => N); + end if; + + Next (Assoc); + end loop; + + -- If aggregate contains more than one choice then these must be + -- static. Sort them and check that they are contiguous. + + if Nb_Discrete_Choices > 1 then + Sort_Case_Table (Table); + Missing_Values := False; + + Outer : for J in 1 .. Nb_Discrete_Choices - 1 loop + if Expr_Value (Table (J).Choice_Hi) >= + Expr_Value (Table (J + 1).Choice_Lo) + then + Error_Msg_N + ("duplicate choice values in array aggregate", + Table (J).Choice_Hi); + return Failure; + + elsif not Others_Present then + Hi_Val := Expr_Value (Table (J).Choice_Hi); + Lo_Val := Expr_Value (Table (J + 1).Choice_Lo); + + -- If missing values, output error messages + + if Lo_Val - Hi_Val > 1 then + + -- Header message if not first missing value + + if not Missing_Values then + Error_Msg_N + ("missing index value(s) in array aggregate", N); + Missing_Values := True; + end if; + + -- Output values of missing indexes + + Lo_Val := Lo_Val - 1; + Hi_Val := Hi_Val + 1; + + -- Enumeration type case + + if Is_Enumeration_Type (Index_Typ) then + Error_Msg_Name_1 := + Chars + (Get_Enum_Lit_From_Pos + (Index_Typ, Hi_Val, Loc)); + + if Lo_Val = Hi_Val then + Error_Msg_N ("\ %", N); + else + Error_Msg_Name_2 := + Chars + (Get_Enum_Lit_From_Pos + (Index_Typ, Lo_Val, Loc)); + Error_Msg_N ("\ % .. %", N); + end if; + + -- Integer types case + + else + Error_Msg_Uint_1 := Hi_Val; + + if Lo_Val = Hi_Val then + Error_Msg_N ("\ ^", N); + else + Error_Msg_Uint_2 := Lo_Val; + Error_Msg_N ("\ ^ .. ^", N); + end if; + end if; + end if; + end if; + end loop Outer; + + if Missing_Values then + Set_Etype (N, Any_Composite); + return Failure; + end if; + end if; + + -- STEP 2 (B): Compute aggregate bounds and min/max choices values + + if Nb_Discrete_Choices > 0 then + Choices_Low := Table (1).Choice_Lo; + Choices_High := Table (Nb_Discrete_Choices).Choice_Hi; + end if; + + -- If Others is present, then bounds of aggregate come from the + -- index constraint (not the choices in the aggregate itself). + + if Others_Present then + Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High); + + -- No others clause present + + else + -- Special processing if others allowed and not present. This + -- means that the bounds of the aggregate come from the index + -- constraint (and the length must match). + + if Others_Allowed then + Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High); + + -- If others allowed, and no others present, then the array + -- should cover all index values. If it does not, we will + -- get a length check warning, but there is two cases where + -- an additional warning is useful: + + -- If we have no positional components, and the length is + -- wrong (which we can tell by others being allowed with + -- missing components), and the index type is an enumeration + -- type, then issue appropriate warnings about these missing + -- components. They are only warnings, since the aggregate + -- is fine, it's just the wrong length. We skip this check + -- for standard character types (since there are no literals + -- and it is too much trouble to concoct them), and also if + -- any of the bounds have not-known-at-compile-time values. + + -- Another case warranting a warning is when the length is + -- right, but as above we have an index type that is an + -- enumeration, and the bounds do not match. This is a + -- case where dubious sliding is allowed and we generate + -- a warning that the bounds do not match. + + if No (Expressions (N)) + and then Nkind (Index) = N_Range + and then Is_Enumeration_Type (Etype (Index)) + and then not Is_Standard_Character_Type (Etype (Index)) + and then Compile_Time_Known_Value (Aggr_Low) + and then Compile_Time_Known_Value (Aggr_High) + and then Compile_Time_Known_Value (Choices_Low) + and then Compile_Time_Known_Value (Choices_High) + then + -- If the bounds have semantic errors, do not attempt + -- further resolution to prevent cascaded errors. + + if Error_Posted (Choices_Low) + or else Error_Posted (Choices_High) + then + return False; + end if; + + declare + ALo : constant Node_Id := Expr_Value_E (Aggr_Low); + AHi : constant Node_Id := Expr_Value_E (Aggr_High); + CLo : constant Node_Id := Expr_Value_E (Choices_Low); + CHi : constant Node_Id := Expr_Value_E (Choices_High); + + Ent : Entity_Id; + + begin + -- Warning case 1, missing values at start/end. Only + -- do the check if the number of entries is too small. + + if (Enumeration_Pos (CHi) - Enumeration_Pos (CLo)) + < + (Enumeration_Pos (AHi) - Enumeration_Pos (ALo)) + then + Error_Msg_N + ("missing index value(s) in array aggregate?", N); + + -- Output missing value(s) at start + + if Chars (ALo) /= Chars (CLo) then + Ent := Prev (CLo); + + if Chars (ALo) = Chars (Ent) then + Error_Msg_Name_1 := Chars (ALo); + Error_Msg_N ("\ %?", N); + else + Error_Msg_Name_1 := Chars (ALo); + Error_Msg_Name_2 := Chars (Ent); + Error_Msg_N ("\ % .. %?", N); + end if; + end if; + + -- Output missing value(s) at end + + if Chars (AHi) /= Chars (CHi) then + Ent := Next (CHi); + + if Chars (AHi) = Chars (Ent) then + Error_Msg_Name_1 := Chars (Ent); + Error_Msg_N ("\ %?", N); + else + Error_Msg_Name_1 := Chars (Ent); + Error_Msg_Name_2 := Chars (AHi); + Error_Msg_N ("\ % .. %?", N); + end if; + end if; + + -- Warning case 2, dubious sliding. The First_Subtype + -- test distinguishes between a constrained type where + -- sliding is not allowed (so we will get a warning + -- later that Constraint_Error will be raised), and + -- the unconstrained case where sliding is permitted. + + elsif (Enumeration_Pos (CHi) - Enumeration_Pos (CLo)) + = + (Enumeration_Pos (AHi) - Enumeration_Pos (ALo)) + and then Chars (ALo) /= Chars (CLo) + and then + not Is_Constrained (First_Subtype (Etype (N))) + then + Error_Msg_N + ("bounds of aggregate do not match target?", N); + end if; + end; + end if; + end if; + + -- If no others, aggregate bounds come from aggregate + + Aggr_Low := Choices_Low; + Aggr_High := Choices_High; + end if; + end Step_2; + + -- STEP 3: Process positional components + + else + -- STEP 3 (A): Process positional elements + + Expr := First (Expressions (N)); + Nb_Elements := Uint_0; + while Present (Expr) loop + Nb_Elements := Nb_Elements + 1; + + -- Ada 2005 (AI-231) + + if Ada_Version >= Ada_2005 + and then Known_Null (Expr) + then + Check_Can_Never_Be_Null (Etype (N), Expr); + end if; + + if not Resolve_Aggr_Expr (Expr, Single_Elmt => True) then + return Failure; + end if; + + -- Check incorrect use of dynamically tagged expression + + if Is_Tagged_Type (Etype (Expr)) then + Check_Dynamically_Tagged_Expression + (Expr => Expr, + Typ => Component_Type (Etype (N)), + Related_Nod => N); + end if; + + Next (Expr); + end loop; + + if Others_Present then + Assoc := Last (Component_Associations (N)); + + -- Ada 2005 (AI-231) + + if Ada_Version >= Ada_2005 + and then Known_Null (Assoc) + then + Check_Can_Never_Be_Null (Etype (N), Expression (Assoc)); + end if; + + -- Ada 2005 (AI-287): In case of default initialized component, + -- we delay the resolution to the expansion phase. + + if Box_Present (Assoc) then + + -- Ada 2005 (AI-287): In case of default initialization of a + -- component the expander will generate calls to the + -- corresponding initialization subprogram. + + null; + + elsif not Resolve_Aggr_Expr (Expression (Assoc), + Single_Elmt => False) + then + return Failure; + + -- Check incorrect use of dynamically tagged expression. The + -- expression of the others choice has not been resolved yet. + -- In order to diagnose the semantic error we create a duplicate + -- tree to analyze it and perform the check. + + else + declare + Save_Analysis : constant Boolean := Full_Analysis; + Expr : constant Node_Id := + New_Copy_Tree (Expression (Assoc)); + + begin + Expander_Mode_Save_And_Set (False); + Full_Analysis := False; + Analyze (Expr); + Full_Analysis := Save_Analysis; + Expander_Mode_Restore; + + if Is_Tagged_Type (Etype (Expr)) then + Check_Dynamically_Tagged_Expression + (Expr => Expr, + Typ => Component_Type (Etype (N)), + Related_Nod => N); + end if; + end; + end if; + end if; + + -- STEP 3 (B): Compute the aggregate bounds + + if Others_Present then + Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High); + + else + if Others_Allowed then + Get_Index_Bounds (Index_Constr, Aggr_Low, Discard); + else + Aggr_Low := Index_Typ_Low; + end if; + + Aggr_High := Add (Nb_Elements - 1, To => Aggr_Low); + Check_Bound (Index_Base_High, Aggr_High); + end if; + end if; + + -- STEP 4: Perform static aggregate checks and save the bounds + + -- Check (A) + + Check_Bounds (Index_Typ_Low, Index_Typ_High, Aggr_Low, Aggr_High); + Check_Bounds (Index_Base_Low, Index_Base_High, Aggr_Low, Aggr_High); + + -- Check (B) + + if Others_Present and then Nb_Discrete_Choices > 0 then + Check_Bounds (Aggr_Low, Aggr_High, Choices_Low, Choices_High); + Check_Bounds (Index_Typ_Low, Index_Typ_High, + Choices_Low, Choices_High); + Check_Bounds (Index_Base_Low, Index_Base_High, + Choices_Low, Choices_High); + + -- Check (C) + + elsif Others_Present and then Nb_Elements > 0 then + Check_Length (Aggr_Low, Aggr_High, Nb_Elements); + Check_Length (Index_Typ_Low, Index_Typ_High, Nb_Elements); + Check_Length (Index_Base_Low, Index_Base_High, Nb_Elements); + end if; + + if Raises_Constraint_Error (Aggr_Low) + or else Raises_Constraint_Error (Aggr_High) + then + Set_Raises_Constraint_Error (N); + end if; + + Aggr_Low := Duplicate_Subexpr (Aggr_Low); + + -- Do not duplicate Aggr_High if Aggr_High = Aggr_Low + Nb_Elements + -- since the addition node returned by Add is not yet analyzed. Attach + -- to tree and analyze first. Reset analyzed flag to ensure it will get + -- analyzed when it is a literal bound whose type must be properly set. + + if Others_Present or else Nb_Discrete_Choices > 0 then + Aggr_High := Duplicate_Subexpr (Aggr_High); + + if Etype (Aggr_High) = Universal_Integer then + Set_Analyzed (Aggr_High, False); + end if; + end if; + + -- If the aggregate already has bounds attached to it, it means this is + -- a positional aggregate created as an optimization by + -- Exp_Aggr.Convert_To_Positional, so we don't want to change those + -- bounds. + + if Present (Aggregate_Bounds (N)) and then not Others_Allowed then + Aggr_Low := Low_Bound (Aggregate_Bounds (N)); + Aggr_High := High_Bound (Aggregate_Bounds (N)); + end if; + + Set_Aggregate_Bounds + (N, Make_Range (Loc, Low_Bound => Aggr_Low, High_Bound => Aggr_High)); + + -- The bounds may contain expressions that must be inserted upwards. + -- Attach them fully to the tree. After analysis, remove side effects + -- from upper bound, if still needed. + + Set_Parent (Aggregate_Bounds (N), N); + Analyze_And_Resolve (Aggregate_Bounds (N), Index_Typ); + Check_Unset_Reference (Aggregate_Bounds (N)); + + if not Others_Present and then Nb_Discrete_Choices = 0 then + Set_High_Bound (Aggregate_Bounds (N), + Duplicate_Subexpr (High_Bound (Aggregate_Bounds (N)))); + end if; + + return Success; + end Resolve_Array_Aggregate; + + --------------------------------- + -- Resolve_Extension_Aggregate -- + --------------------------------- + + -- There are two cases to consider: + + -- a) If the ancestor part is a type mark, the components needed are the + -- difference between the components of the expected type and the + -- components of the given type mark. + + -- b) If the ancestor part is an expression, it must be unambiguous, and + -- once we have its type we can also compute the needed components as in + -- the previous case. In both cases, if the ancestor type is not the + -- immediate ancestor, we have to build this ancestor recursively. + + -- In both cases discriminants of the ancestor type do not play a role in + -- the resolution of the needed components, because inherited discriminants + -- cannot be used in a type extension. As a result we can compute + -- independently the list of components of the ancestor type and of the + -- expected type. + + procedure Resolve_Extension_Aggregate (N : Node_Id; Typ : Entity_Id) is + A : constant Node_Id := Ancestor_Part (N); + A_Type : Entity_Id; + I : Interp_Index; + It : Interp; + + function Valid_Limited_Ancestor (Anc : Node_Id) return Boolean; + -- If the type is limited, verify that the ancestor part is a legal + -- expression (aggregate or function call, including 'Input)) that does + -- not require a copy, as specified in 7.5(2). + + function Valid_Ancestor_Type return Boolean; + -- Verify that the type of the ancestor part is a non-private ancestor + -- of the expected type, which must be a type extension. + + ---------------------------- + -- Valid_Limited_Ancestor -- + ---------------------------- + + function Valid_Limited_Ancestor (Anc : Node_Id) return Boolean is + begin + if Is_Entity_Name (Anc) + and then Is_Type (Entity (Anc)) + then + return True; + + elsif Nkind_In (Anc, N_Aggregate, N_Function_Call) then + return True; + + elsif Nkind (Anc) = N_Attribute_Reference + and then Attribute_Name (Anc) = Name_Input + then + return True; + + elsif Nkind (Anc) = N_Qualified_Expression then + return Valid_Limited_Ancestor (Expression (Anc)); + + else + return False; + end if; + end Valid_Limited_Ancestor; + + ------------------------- + -- Valid_Ancestor_Type -- + ------------------------- + + function Valid_Ancestor_Type return Boolean is + Imm_Type : Entity_Id; + + begin + Imm_Type := Base_Type (Typ); + while Is_Derived_Type (Imm_Type) loop + if Etype (Imm_Type) = Base_Type (A_Type) then + return True; + + -- The base type of the parent type may appear as a private + -- extension if it is declared as such in a parent unit of the + -- current one. For consistency of the subsequent analysis use + -- the partial view for the ancestor part. + + elsif Is_Private_Type (Etype (Imm_Type)) + and then Present (Full_View (Etype (Imm_Type))) + and then Base_Type (A_Type) = Full_View (Etype (Imm_Type)) + then + A_Type := Etype (Imm_Type); + return True; + + -- The parent type may be a private extension. The aggregate is + -- legal if the type of the aggregate is an extension of it that + -- is not a private extension. + + elsif Is_Private_Type (A_Type) + and then not Is_Private_Type (Imm_Type) + and then Present (Full_View (A_Type)) + and then Base_Type (Full_View (A_Type)) = Etype (Imm_Type) + then + return True; + + else + Imm_Type := Etype (Base_Type (Imm_Type)); + end if; + end loop; + + -- If previous loop did not find a proper ancestor, report error + + Error_Msg_NE ("expect ancestor type of &", A, Typ); + return False; + end Valid_Ancestor_Type; + + -- Start of processing for Resolve_Extension_Aggregate + + begin + -- Analyze the ancestor part and account for the case where it is a + -- parameterless function call. + + Analyze (A); + Check_Parameterless_Call (A); + + if not Is_Tagged_Type (Typ) then + Error_Msg_N ("type of extension aggregate must be tagged", N); + return; + + elsif Is_Limited_Type (Typ) then + + -- Ada 2005 (AI-287): Limited aggregates are allowed + + if Ada_Version < Ada_2005 then + Error_Msg_N ("aggregate type cannot be limited", N); + Explain_Limited_Type (Typ, N); + return; + + elsif Valid_Limited_Ancestor (A) then + null; + + else + Error_Msg_N + ("limited ancestor part must be aggregate or function call", A); + end if; + + elsif Is_Class_Wide_Type (Typ) then + Error_Msg_N ("aggregate cannot be of a class-wide type", N); + return; + end if; + + if Is_Entity_Name (A) + and then Is_Type (Entity (A)) + then + A_Type := Get_Full_View (Entity (A)); + + if Valid_Ancestor_Type then + Set_Entity (A, A_Type); + Set_Etype (A, A_Type); + + Validate_Ancestor_Part (N); + Resolve_Record_Aggregate (N, Typ); + end if; + + elsif Nkind (A) /= N_Aggregate then + if Is_Overloaded (A) then + A_Type := Any_Type; + + Get_First_Interp (A, I, It); + while Present (It.Typ) loop + -- Only consider limited interpretations in the Ada 2005 case + + if Is_Tagged_Type (It.Typ) + and then (Ada_Version >= Ada_2005 + or else not Is_Limited_Type (It.Typ)) + then + if A_Type /= Any_Type then + Error_Msg_N ("cannot resolve expression", A); + return; + else + A_Type := It.Typ; + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + + if A_Type = Any_Type then + if Ada_Version >= Ada_2005 then + Error_Msg_N ("ancestor part must be of a tagged type", A); + else + Error_Msg_N + ("ancestor part must be of a nonlimited tagged type", A); + end if; + + return; + end if; + + else + A_Type := Etype (A); + end if; + + if Valid_Ancestor_Type then + Resolve (A, A_Type); + Check_Unset_Reference (A); + Check_Non_Static_Context (A); + + -- The aggregate is illegal if the ancestor expression is a call + -- to a function with a limited unconstrained result, unless the + -- type of the aggregate is a null extension. This restriction + -- was added in AI05-67 to simplify implementation. + + if Nkind (A) = N_Function_Call + and then Is_Limited_Type (A_Type) + and then not Is_Null_Extension (Typ) + and then not Is_Constrained (A_Type) + then + Error_Msg_N + ("type of limited ancestor part must be constrained", A); + + -- Reject the use of CPP constructors that leave objects partially + -- initialized. For example: + + -- type CPP_Root is tagged limited record ... + -- pragma Import (CPP, CPP_Root); + + -- type CPP_DT is new CPP_Root and Iface ... + -- pragma Import (CPP, CPP_DT); + + -- type Ada_DT is new CPP_DT with ... + + -- Obj : Ada_DT := Ada_DT'(New_CPP_Root with others => <>); + + -- Using the constructor of CPP_Root the slots of the dispatch + -- table of CPP_DT cannot be set, and the secondary tag of + -- CPP_DT is unknown. + + elsif Nkind (A) = N_Function_Call + and then Is_CPP_Constructor_Call (A) + and then Enclosing_CPP_Parent (Typ) /= A_Type + then + Error_Msg_NE + ("?must use 'C'P'P constructor for type &", A, + Enclosing_CPP_Parent (Typ)); + + -- The following call is not needed if the previous warning + -- is promoted to an error. + + Resolve_Record_Aggregate (N, Typ); + + elsif Is_Class_Wide_Type (Etype (A)) + and then Nkind (Original_Node (A)) = N_Function_Call + then + -- If the ancestor part is a dispatching call, it appears + -- statically to be a legal ancestor, but it yields any member + -- of the class, and it is not possible to determine whether + -- it is an ancestor of the extension aggregate (much less + -- which ancestor). It is not possible to determine the + -- components of the extension part. + + -- This check implements AI-306, which in fact was motivated by + -- an AdaCore query to the ARG after this test was added. + + Error_Msg_N ("ancestor part must be statically tagged", A); + else + Resolve_Record_Aggregate (N, Typ); + end if; + end if; + + else + Error_Msg_N ("no unique type for this aggregate", A); + end if; + end Resolve_Extension_Aggregate; + + ------------------------------ + -- Resolve_Record_Aggregate -- + ------------------------------ + + procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is + Assoc : Node_Id; + -- N_Component_Association node belonging to the input aggregate N + + Expr : Node_Id; + Positional_Expr : Node_Id; + Component : Entity_Id; + Component_Elmt : Elmt_Id; + + Components : constant Elist_Id := New_Elmt_List; + -- Components is the list of the record components whose value must be + -- provided in the aggregate. This list does include discriminants. + + New_Assoc_List : constant List_Id := New_List; + New_Assoc : Node_Id; + -- New_Assoc_List is the newly built list of N_Component_Association + -- nodes. New_Assoc is one such N_Component_Association node in it. + -- Note that while Assoc and New_Assoc contain the same kind of nodes, + -- they are used to iterate over two different N_Component_Association + -- lists. + + Others_Etype : Entity_Id := Empty; + -- This variable is used to save the Etype of the last record component + -- that takes its value from the others choice. Its purpose is: + -- + -- (a) make sure the others choice is useful + -- + -- (b) make sure the type of all the components whose value is + -- subsumed by the others choice are the same. + -- + -- This variable is updated as a side effect of function Get_Value. + + Is_Box_Present : Boolean := False; + Others_Box : Boolean := False; + -- Ada 2005 (AI-287): Variables used in case of default initialization + -- to provide a functionality similar to Others_Etype. Box_Present + -- indicates that the component takes its default initialization; + -- Others_Box indicates that at least one component takes its default + -- initialization. Similar to Others_Etype, they are also updated as a + -- side effect of function Get_Value. + + procedure Add_Association + (Component : Entity_Id; + Expr : Node_Id; + Assoc_List : List_Id; + Is_Box_Present : Boolean := False); + -- Builds a new N_Component_Association node which associates Component + -- to expression Expr and adds it to the association list being built, + -- either New_Assoc_List, or the association being built for an inner + -- aggregate. + + function Discr_Present (Discr : Entity_Id) return Boolean; + -- If aggregate N is a regular aggregate this routine will return True. + -- Otherwise, if N is an extension aggregate, Discr is a discriminant + -- whose value may already have been specified by N's ancestor part. + -- This routine checks whether this is indeed the case and if so returns + -- False, signaling that no value for Discr should appear in N's + -- aggregate part. Also, in this case, the routine appends to + -- New_Assoc_List the discriminant value specified in the ancestor part. + -- + -- If the aggregate is in a context with expansion delayed, it will be + -- reanalyzed. The inherited discriminant values must not be reinserted + -- in the component list to prevent spurious errors, but they must be + -- present on first analysis to build the proper subtype indications. + -- The flag Inherited_Discriminant is used to prevent the re-insertion. + + function Get_Value + (Compon : Node_Id; + From : List_Id; + Consider_Others_Choice : Boolean := False) + return Node_Id; + -- Given a record component stored in parameter Compon, this function + -- returns its value as it appears in the list From, which is a list + -- of N_Component_Association nodes. + -- + -- If no component association has a choice for the searched component, + -- the value provided by the others choice is returned, if there is one, + -- and Consider_Others_Choice is set to true. Otherwise Empty is + -- returned. If there is more than one component association giving a + -- value for the searched record component, an error message is emitted + -- and the first found value is returned. + -- + -- If Consider_Others_Choice is set and the returned expression comes + -- from the others choice, then Others_Etype is set as a side effect. + -- An error message is emitted if the components taking their value from + -- the others choice do not have same type. + + procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id); + -- Analyzes and resolves expression Expr against the Etype of the + -- Component. This routine also applies all appropriate checks to Expr. + -- It finally saves a Expr in the newly created association list that + -- will be attached to the final record aggregate. Note that if the + -- Parent pointer of Expr is not set then Expr was produced with a + -- New_Copy_Tree or some such. + + --------------------- + -- Add_Association -- + --------------------- + + procedure Add_Association + (Component : Entity_Id; + Expr : Node_Id; + Assoc_List : List_Id; + Is_Box_Present : Boolean := False) + is + Choice_List : constant List_Id := New_List; + New_Assoc : Node_Id; + + begin + Append (New_Occurrence_Of (Component, Sloc (Expr)), Choice_List); + New_Assoc := + Make_Component_Association (Sloc (Expr), + Choices => Choice_List, + Expression => Expr, + Box_Present => Is_Box_Present); + Append (New_Assoc, Assoc_List); + end Add_Association; + + ------------------- + -- Discr_Present -- + ------------------- + + function Discr_Present (Discr : Entity_Id) return Boolean is + Regular_Aggr : constant Boolean := Nkind (N) /= N_Extension_Aggregate; + + Loc : Source_Ptr; + + Ancestor : Node_Id; + Comp_Assoc : Node_Id; + Discr_Expr : Node_Id; + + Ancestor_Typ : Entity_Id; + Orig_Discr : Entity_Id; + D : Entity_Id; + D_Val : Elmt_Id := No_Elmt; -- stop junk warning + + Ancestor_Is_Subtyp : Boolean; + + begin + if Regular_Aggr then + return True; + end if; + + -- Check whether inherited discriminant values have already been + -- inserted in the aggregate. This will be the case if we are + -- re-analyzing an aggregate whose expansion was delayed. + + if Present (Component_Associations (N)) then + Comp_Assoc := First (Component_Associations (N)); + while Present (Comp_Assoc) loop + if Inherited_Discriminant (Comp_Assoc) then + return True; + end if; + + Next (Comp_Assoc); + end loop; + end if; + + Ancestor := Ancestor_Part (N); + Ancestor_Typ := Etype (Ancestor); + Loc := Sloc (Ancestor); + + -- For a private type with unknown discriminants, use the underlying + -- record view if it is available. + + if Has_Unknown_Discriminants (Ancestor_Typ) + and then Present (Full_View (Ancestor_Typ)) + and then Present (Underlying_Record_View (Full_View (Ancestor_Typ))) + then + Ancestor_Typ := Underlying_Record_View (Full_View (Ancestor_Typ)); + end if; + + Ancestor_Is_Subtyp := + Is_Entity_Name (Ancestor) and then Is_Type (Entity (Ancestor)); + + -- If the ancestor part has no discriminants clearly N's aggregate + -- part must provide a value for Discr. + + if not Has_Discriminants (Ancestor_Typ) then + return True; + + -- If the ancestor part is an unconstrained subtype mark then the + -- Discr must be present in N's aggregate part. + + elsif Ancestor_Is_Subtyp + and then not Is_Constrained (Entity (Ancestor)) + then + return True; + end if; + + -- Now look to see if Discr was specified in the ancestor part + + if Ancestor_Is_Subtyp then + D_Val := First_Elmt (Discriminant_Constraint (Entity (Ancestor))); + end if; + + Orig_Discr := Original_Record_Component (Discr); + + D := First_Discriminant (Ancestor_Typ); + while Present (D) loop + + -- If Ancestor has already specified Disc value then insert its + -- value in the final aggregate. + + if Original_Record_Component (D) = Orig_Discr then + if Ancestor_Is_Subtyp then + Discr_Expr := New_Copy_Tree (Node (D_Val)); + else + Discr_Expr := + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Ancestor), + Selector_Name => New_Occurrence_Of (Discr, Loc)); + end if; + + Resolve_Aggr_Expr (Discr_Expr, Discr); + Set_Inherited_Discriminant (Last (New_Assoc_List)); + return False; + end if; + + Next_Discriminant (D); + + if Ancestor_Is_Subtyp then + Next_Elmt (D_Val); + end if; + end loop; + + return True; + end Discr_Present; + + --------------- + -- Get_Value -- + --------------- + + function Get_Value + (Compon : Node_Id; + From : List_Id; + Consider_Others_Choice : Boolean := False) + return Node_Id + is + Assoc : Node_Id; + Expr : Node_Id := Empty; + Selector_Name : Node_Id; + + begin + Is_Box_Present := False; + + if Present (From) then + Assoc := First (From); + else + return Empty; + end if; + + while Present (Assoc) loop + Selector_Name := First (Choices (Assoc)); + while Present (Selector_Name) loop + if Nkind (Selector_Name) = N_Others_Choice then + if Consider_Others_Choice and then No (Expr) then + + -- We need to duplicate the expression for each + -- successive component covered by the others choice. + -- This is redundant if the others_choice covers only + -- one component (small optimization possible???), but + -- indispensable otherwise, because each one must be + -- expanded individually to preserve side-effects. + + -- Ada 2005 (AI-287): In case of default initialization + -- of components, we duplicate the corresponding default + -- expression (from the record type declaration). The + -- copy must carry the sloc of the association (not the + -- original expression) to prevent spurious elaboration + -- checks when the default includes function calls. + + if Box_Present (Assoc) then + Others_Box := True; + Is_Box_Present := True; + + if Expander_Active then + return + New_Copy_Tree + (Expression (Parent (Compon)), + New_Sloc => Sloc (Assoc)); + else + return Expression (Parent (Compon)); + end if; + + else + if Present (Others_Etype) and then + Base_Type (Others_Etype) /= Base_Type (Etype + (Compon)) + then + Error_Msg_N ("components in OTHERS choice must " & + "have same type", Selector_Name); + end if; + + Others_Etype := Etype (Compon); + + if Expander_Active then + return New_Copy_Tree (Expression (Assoc)); + else + return Expression (Assoc); + end if; + end if; + end if; + + elsif Chars (Compon) = Chars (Selector_Name) then + if No (Expr) then + + -- Ada 2005 (AI-231) + + if Ada_Version >= Ada_2005 + and then Known_Null (Expression (Assoc)) + then + Check_Can_Never_Be_Null (Compon, Expression (Assoc)); + end if; + + -- We need to duplicate the expression when several + -- components are grouped together with a "|" choice. + -- For instance "filed1 | filed2 => Expr" + + -- Ada 2005 (AI-287) + + if Box_Present (Assoc) then + Is_Box_Present := True; + + -- Duplicate the default expression of the component + -- from the record type declaration, so a new copy + -- can be attached to the association. + + -- Note that we always copy the default expression, + -- even when the association has a single choice, in + -- order to create a proper association for the + -- expanded aggregate. + + Expr := New_Copy_Tree (Expression (Parent (Compon))); + + else + if Present (Next (Selector_Name)) then + Expr := New_Copy_Tree (Expression (Assoc)); + else + Expr := Expression (Assoc); + end if; + end if; + + Generate_Reference (Compon, Selector_Name, 'm'); + + else + Error_Msg_NE + ("more than one value supplied for &", + Selector_Name, Compon); + + end if; + end if; + + Next (Selector_Name); + end loop; + + Next (Assoc); + end loop; + + return Expr; + end Get_Value; + + ----------------------- + -- Resolve_Aggr_Expr -- + ----------------------- + + procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id) is + New_C : Entity_Id := Component; + Expr_Type : Entity_Id := Empty; + + function Has_Expansion_Delayed (Expr : Node_Id) return Boolean; + -- If the expression is an aggregate (possibly qualified) then its + -- expansion is delayed until the enclosing aggregate is expanded + -- into assignments. In that case, do not generate checks on the + -- expression, because they will be generated later, and will other- + -- wise force a copy (to remove side-effects) that would leave a + -- dynamic-sized aggregate in the code, something that gigi cannot + -- handle. + + Relocate : Boolean; + -- Set to True if the resolved Expr node needs to be relocated + -- when attached to the newly created association list. This node + -- need not be relocated if its parent pointer is not set. + -- In fact in this case Expr is the output of a New_Copy_Tree call. + -- if Relocate is True then we have analyzed the expression node + -- in the original aggregate and hence it needs to be relocated + -- when moved over the new association list. + + function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is + Kind : constant Node_Kind := Nkind (Expr); + begin + return (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate) + and then Present (Etype (Expr)) + and then Is_Record_Type (Etype (Expr)) + and then Expansion_Delayed (Expr)) + or else (Kind = N_Qualified_Expression + and then Has_Expansion_Delayed (Expression (Expr))); + end Has_Expansion_Delayed; + + -- Start of processing for Resolve_Aggr_Expr + + begin + -- If the type of the component is elementary or the type of the + -- aggregate does not contain discriminants, use the type of the + -- component to resolve Expr. + + if Is_Elementary_Type (Etype (Component)) + or else not Has_Discriminants (Etype (N)) + then + Expr_Type := Etype (Component); + + -- Otherwise we have to pick up the new type of the component from + -- the new constrained subtype of the aggregate. In fact components + -- which are of a composite type might be constrained by a + -- discriminant, and we want to resolve Expr against the subtype were + -- all discriminant occurrences are replaced with their actual value. + + else + New_C := First_Component (Etype (N)); + while Present (New_C) loop + if Chars (New_C) = Chars (Component) then + Expr_Type := Etype (New_C); + exit; + end if; + + Next_Component (New_C); + end loop; + + pragma Assert (Present (Expr_Type)); + + -- For each range in an array type where a discriminant has been + -- replaced with the constraint, check that this range is within + -- the range of the base type. This checks is done in the init + -- proc for regular objects, but has to be done here for + -- aggregates since no init proc is called for them. + + if Is_Array_Type (Expr_Type) then + declare + Index : Node_Id; + -- Range of the current constrained index in the array + + Orig_Index : Node_Id := First_Index (Etype (Component)); + -- Range corresponding to the range Index above in the + -- original unconstrained record type. The bounds of this + -- range may be governed by discriminants. + + Unconstr_Index : Node_Id := First_Index (Etype (Expr_Type)); + -- Range corresponding to the range Index above for the + -- unconstrained array type. This range is needed to apply + -- range checks. + + begin + Index := First_Index (Expr_Type); + while Present (Index) loop + if Depends_On_Discriminant (Orig_Index) then + Apply_Range_Check (Index, Etype (Unconstr_Index)); + end if; + + Next_Index (Index); + Next_Index (Orig_Index); + Next_Index (Unconstr_Index); + end loop; + end; + end if; + end if; + + -- If the Parent pointer of Expr is not set, Expr is an expression + -- duplicated by New_Tree_Copy (this happens for record aggregates + -- that look like (Field1 | Filed2 => Expr) or (others => Expr)). + -- Such a duplicated expression must be attached to the tree + -- before analysis and resolution to enforce the rule that a tree + -- fragment should never be analyzed or resolved unless it is + -- attached to the current compilation unit. + + if No (Parent (Expr)) then + Set_Parent (Expr, N); + Relocate := False; + else + Relocate := True; + end if; + + Analyze_And_Resolve (Expr, Expr_Type); + Check_Expr_OK_In_Limited_Aggregate (Expr); + Check_Non_Static_Context (Expr); + Check_Unset_Reference (Expr); + + -- Check wrong use of class-wide types + + if Is_Class_Wide_Type (Etype (Expr)) then + Error_Msg_N ("dynamically tagged expression not allowed", Expr); + end if; + + if not Has_Expansion_Delayed (Expr) then + Aggregate_Constraint_Checks (Expr, Expr_Type); + end if; + + if Raises_Constraint_Error (Expr) then + Set_Raises_Constraint_Error (N); + end if; + + -- If the expression has been marked as requiring a range check, + -- then generate it here. + + if Do_Range_Check (Expr) then + Set_Do_Range_Check (Expr, False); + Generate_Range_Check (Expr, Expr_Type, CE_Range_Check_Failed); + end if; + + if Relocate then + Add_Association (New_C, Relocate_Node (Expr), New_Assoc_List); + else + Add_Association (New_C, Expr, New_Assoc_List); + end if; + end Resolve_Aggr_Expr; + + -- Start of processing for Resolve_Record_Aggregate + + begin + -- We may end up calling Duplicate_Subexpr on expressions that are + -- attached to New_Assoc_List. For this reason we need to attach it + -- to the tree by setting its parent pointer to N. This parent point + -- will change in STEP 8 below. + + Set_Parent (New_Assoc_List, N); + + -- STEP 1: abstract type and null record verification + + if Is_Abstract_Type (Typ) then + Error_Msg_N ("type of aggregate cannot be abstract", N); + end if; + + if No (First_Entity (Typ)) and then Null_Record_Present (N) then + Set_Etype (N, Typ); + return; + + elsif Present (First_Entity (Typ)) + and then Null_Record_Present (N) + and then not Is_Tagged_Type (Typ) + then + Error_Msg_N ("record aggregate cannot be null", N); + return; + + -- If the type has no components, then the aggregate should either + -- have "null record", or in Ada 2005 it could instead have a single + -- component association given by "others => <>". For Ada 95 we flag + -- an error at this point, but for Ada 2005 we proceed with checking + -- the associations below, which will catch the case where it's not + -- an aggregate with "others => <>". Note that the legality of a <> + -- aggregate for a null record type was established by AI05-016. + + elsif No (First_Entity (Typ)) + and then Ada_Version < Ada_2005 + then + Error_Msg_N ("record aggregate must be null", N); + return; + end if; + + -- STEP 2: Verify aggregate structure + + Step_2 : declare + Selector_Name : Node_Id; + Bad_Aggregate : Boolean := False; + + begin + if Present (Component_Associations (N)) then + Assoc := First (Component_Associations (N)); + else + Assoc := Empty; + end if; + + while Present (Assoc) loop + Selector_Name := First (Choices (Assoc)); + while Present (Selector_Name) loop + if Nkind (Selector_Name) = N_Identifier then + null; + + elsif Nkind (Selector_Name) = N_Others_Choice then + if Selector_Name /= First (Choices (Assoc)) + or else Present (Next (Selector_Name)) + then + Error_Msg_N + ("OTHERS must appear alone in a choice list", + Selector_Name); + return; + + elsif Present (Next (Assoc)) then + Error_Msg_N + ("OTHERS must appear last in an aggregate", + Selector_Name); + return; + + -- (Ada2005): If this is an association with a box, + -- indicate that the association need not represent + -- any component. + + elsif Box_Present (Assoc) then + Others_Box := True; + end if; + + else + Error_Msg_N + ("selector name should be identifier or OTHERS", + Selector_Name); + Bad_Aggregate := True; + end if; + + Next (Selector_Name); + end loop; + + Next (Assoc); + end loop; + + if Bad_Aggregate then + return; + end if; + end Step_2; + + -- STEP 3: Find discriminant Values + + Step_3 : declare + Discrim : Entity_Id; + Missing_Discriminants : Boolean := False; + + begin + if Present (Expressions (N)) then + Positional_Expr := First (Expressions (N)); + else + Positional_Expr := Empty; + end if; + + if Has_Unknown_Discriminants (Typ) + and then Present (Underlying_Record_View (Typ)) + then + Discrim := First_Discriminant (Underlying_Record_View (Typ)); + elsif Has_Discriminants (Typ) then + Discrim := First_Discriminant (Typ); + else + Discrim := Empty; + end if; + + -- First find the discriminant values in the positional components + + while Present (Discrim) and then Present (Positional_Expr) loop + if Discr_Present (Discrim) then + Resolve_Aggr_Expr (Positional_Expr, Discrim); + + -- Ada 2005 (AI-231) + + if Ada_Version >= Ada_2005 + and then Known_Null (Positional_Expr) + then + Check_Can_Never_Be_Null (Discrim, Positional_Expr); + end if; + + Next (Positional_Expr); + end if; + + if Present (Get_Value (Discrim, Component_Associations (N))) then + Error_Msg_NE + ("more than one value supplied for discriminant&", + N, Discrim); + end if; + + Next_Discriminant (Discrim); + end loop; + + -- Find remaining discriminant values, if any, among named components + + while Present (Discrim) loop + Expr := Get_Value (Discrim, Component_Associations (N), True); + + if not Discr_Present (Discrim) then + if Present (Expr) then + Error_Msg_NE + ("more than one value supplied for discriminant&", + N, Discrim); + end if; + + elsif No (Expr) then + Error_Msg_NE + ("no value supplied for discriminant &", N, Discrim); + Missing_Discriminants := True; + + else + Resolve_Aggr_Expr (Expr, Discrim); + end if; + + Next_Discriminant (Discrim); + end loop; + + if Missing_Discriminants then + return; + end if; + + -- At this point and until the beginning of STEP 6, New_Assoc_List + -- contains only the discriminants and their values. + + end Step_3; + + -- STEP 4: Set the Etype of the record aggregate + + -- ??? This code is pretty much a copy of Sem_Ch3.Build_Subtype. That + -- routine should really be exported in sem_util or some such and used + -- in sem_ch3 and here rather than have a copy of the code which is a + -- maintenance nightmare. + + -- ??? Performance WARNING. The current implementation creates a new + -- itype for all aggregates whose base type is discriminated. + -- This means that for record aggregates nested inside an array + -- aggregate we will create a new itype for each record aggregate + -- if the array component type has discriminants. For large aggregates + -- this may be a problem. What should be done in this case is + -- to reuse itypes as much as possible. + + if Has_Discriminants (Typ) + or else (Has_Unknown_Discriminants (Typ) + and then Present (Underlying_Record_View (Typ))) + then + Build_Constrained_Itype : declare + Loc : constant Source_Ptr := Sloc (N); + Indic : Node_Id; + Subtyp_Decl : Node_Id; + Def_Id : Entity_Id; + + C : constant List_Id := New_List; + + begin + New_Assoc := First (New_Assoc_List); + while Present (New_Assoc) loop + Append (Duplicate_Subexpr (Expression (New_Assoc)), To => C); + Next (New_Assoc); + end loop; + + if Has_Unknown_Discriminants (Typ) + and then Present (Underlying_Record_View (Typ)) + then + Indic := + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Underlying_Record_View (Typ), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, C)); + else + Indic := + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Base_Type (Typ), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, C)); + end if; + + Def_Id := Create_Itype (Ekind (Typ), N); + + Subtyp_Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Def_Id, + Subtype_Indication => Indic); + Set_Parent (Subtyp_Decl, Parent (N)); + + -- Itypes must be analyzed with checks off (see itypes.ads) + + Analyze (Subtyp_Decl, Suppress => All_Checks); + + Set_Etype (N, Def_Id); + Check_Static_Discriminated_Subtype + (Def_Id, Expression (First (New_Assoc_List))); + end Build_Constrained_Itype; + + else + Set_Etype (N, Typ); + end if; + + -- STEP 5: Get remaining components according to discriminant values + + Step_5 : declare + Record_Def : Node_Id; + Parent_Typ : Entity_Id; + Root_Typ : Entity_Id; + Parent_Typ_List : Elist_Id; + Parent_Elmt : Elmt_Id; + Errors_Found : Boolean := False; + Dnode : Node_Id; + + begin + if Is_Derived_Type (Typ) and then Is_Tagged_Type (Typ) then + Parent_Typ_List := New_Elmt_List; + + -- If this is an extension aggregate, the component list must + -- include all components that are not in the given ancestor type. + -- Otherwise, the component list must include components of all + -- ancestors, starting with the root. + + if Nkind (N) = N_Extension_Aggregate then + Root_Typ := Base_Type (Etype (Ancestor_Part (N))); + + else + Root_Typ := Root_Type (Typ); + + if Nkind (Parent (Base_Type (Root_Typ))) = + N_Private_Type_Declaration + then + Error_Msg_NE + ("type of aggregate has private ancestor&!", + N, Root_Typ); + Error_Msg_N ("must use extension aggregate!", N); + return; + end if; + + Dnode := Declaration_Node (Base_Type (Root_Typ)); + + -- If we don't get a full declaration, then we have some error + -- which will get signalled later so skip this part. Otherwise + -- gather components of root that apply to the aggregate type. + -- We use the base type in case there is an applicable stored + -- constraint that renames the discriminants of the root. + + if Nkind (Dnode) = N_Full_Type_Declaration then + Record_Def := Type_Definition (Dnode); + Gather_Components (Base_Type (Typ), + Component_List (Record_Def), + Governed_By => New_Assoc_List, + Into => Components, + Report_Errors => Errors_Found); + end if; + end if; + + Parent_Typ := Base_Type (Typ); + while Parent_Typ /= Root_Typ loop + Prepend_Elmt (Parent_Typ, To => Parent_Typ_List); + Parent_Typ := Etype (Parent_Typ); + + if Nkind (Parent (Base_Type (Parent_Typ))) = + N_Private_Type_Declaration + or else Nkind (Parent (Base_Type (Parent_Typ))) = + N_Private_Extension_Declaration + then + if Nkind (N) /= N_Extension_Aggregate then + Error_Msg_NE + ("type of aggregate has private ancestor&!", + N, Parent_Typ); + Error_Msg_N ("must use extension aggregate!", N); + return; + + elsif Parent_Typ /= Root_Typ then + Error_Msg_NE + ("ancestor part of aggregate must be private type&", + Ancestor_Part (N), Parent_Typ); + return; + end if; + + -- The current view of ancestor part may be a private type, + -- while the context type is always non-private. + + elsif Is_Private_Type (Root_Typ) + and then Present (Full_View (Root_Typ)) + and then Nkind (N) = N_Extension_Aggregate + then + exit when Base_Type (Full_View (Root_Typ)) = Parent_Typ; + end if; + end loop; + + -- Now collect components from all other ancestors, beginning + -- with the current type. If the type has unknown discriminants + -- use the component list of the Underlying_Record_View, which + -- needs to be used for the subsequent expansion of the aggregate + -- into assignments. + + Parent_Elmt := First_Elmt (Parent_Typ_List); + while Present (Parent_Elmt) loop + Parent_Typ := Node (Parent_Elmt); + + if Has_Unknown_Discriminants (Parent_Typ) + and then Present (Underlying_Record_View (Typ)) + then + Parent_Typ := Underlying_Record_View (Parent_Typ); + end if; + + Record_Def := Type_Definition (Parent (Base_Type (Parent_Typ))); + Gather_Components (Empty, + Component_List (Record_Extension_Part (Record_Def)), + Governed_By => New_Assoc_List, + Into => Components, + Report_Errors => Errors_Found); + + Next_Elmt (Parent_Elmt); + end loop; + + else + Record_Def := Type_Definition (Parent (Base_Type (Typ))); + + if Null_Present (Record_Def) then + null; + + elsif not Has_Unknown_Discriminants (Typ) then + Gather_Components (Base_Type (Typ), + Component_List (Record_Def), + Governed_By => New_Assoc_List, + Into => Components, + Report_Errors => Errors_Found); + + else + Gather_Components + (Base_Type (Underlying_Record_View (Typ)), + Component_List (Record_Def), + Governed_By => New_Assoc_List, + Into => Components, + Report_Errors => Errors_Found); + end if; + end if; + + if Errors_Found then + return; + end if; + end Step_5; + + -- STEP 6: Find component Values + + Component := Empty; + Component_Elmt := First_Elmt (Components); + + -- First scan the remaining positional associations in the aggregate. + -- Remember that at this point Positional_Expr contains the current + -- positional association if any is left after looking for discriminant + -- values in step 3. + + while Present (Positional_Expr) and then Present (Component_Elmt) loop + Component := Node (Component_Elmt); + Resolve_Aggr_Expr (Positional_Expr, Component); + + -- Ada 2005 (AI-231) + + if Ada_Version >= Ada_2005 + and then Known_Null (Positional_Expr) + then + Check_Can_Never_Be_Null (Component, Positional_Expr); + end if; + + if Present (Get_Value (Component, Component_Associations (N))) then + Error_Msg_NE + ("more than one value supplied for Component &", N, Component); + end if; + + Next (Positional_Expr); + Next_Elmt (Component_Elmt); + end loop; + + if Present (Positional_Expr) then + Error_Msg_N + ("too many components for record aggregate", Positional_Expr); + end if; + + -- Now scan for the named arguments of the aggregate + + while Present (Component_Elmt) loop + Component := Node (Component_Elmt); + Expr := Get_Value (Component, Component_Associations (N), True); + + -- Note: The previous call to Get_Value sets the value of the + -- variable Is_Box_Present. + + -- Ada 2005 (AI-287): Handle components with default initialization. + -- Note: This feature was originally added to Ada 2005 for limited + -- but it was finally allowed with any type. + + if Is_Box_Present then + Check_Box_Component : declare + Ctyp : constant Entity_Id := Etype (Component); + + begin + -- If there is a default expression for the aggregate, copy + -- it into a new association. + + -- If the component has an initialization procedure (IP) we + -- pass the component to the expander, which will generate + -- the call to such IP. + + -- If the component has discriminants, their values must + -- be taken from their subtype. This is indispensable for + -- constraints that are given by the current instance of an + -- enclosing type, to allow the expansion of the aggregate + -- to replace the reference to the current instance by the + -- target object of the aggregate. + + if Present (Parent (Component)) + and then + Nkind (Parent (Component)) = N_Component_Declaration + and then Present (Expression (Parent (Component))) + then + Expr := + New_Copy_Tree (Expression (Parent (Component)), + New_Sloc => Sloc (N)); + + Add_Association + (Component => Component, + Expr => Expr, + Assoc_List => New_Assoc_List); + Set_Has_Self_Reference (N); + + -- A box-defaulted access component gets the value null. Also + -- included are components of private types whose underlying + -- type is an access type. In either case set the type of the + -- literal, for subsequent use in semantic checks. + + elsif Present (Underlying_Type (Ctyp)) + and then Is_Access_Type (Underlying_Type (Ctyp)) + then + if not Is_Private_Type (Ctyp) then + Expr := Make_Null (Sloc (N)); + Set_Etype (Expr, Ctyp); + Add_Association + (Component => Component, + Expr => Expr, + Assoc_List => New_Assoc_List); + + -- If the component's type is private with an access type as + -- its underlying type then we have to create an unchecked + -- conversion to satisfy type checking. + + else + declare + Qual_Null : constant Node_Id := + Make_Qualified_Expression (Sloc (N), + Subtype_Mark => + New_Occurrence_Of + (Underlying_Type (Ctyp), Sloc (N)), + Expression => Make_Null (Sloc (N))); + + Convert_Null : constant Node_Id := + Unchecked_Convert_To + (Ctyp, Qual_Null); + + begin + Analyze_And_Resolve (Convert_Null, Ctyp); + Add_Association + (Component => Component, + Expr => Convert_Null, + Assoc_List => New_Assoc_List); + end; + end if; + + elsif Has_Non_Null_Base_Init_Proc (Ctyp) + or else not Expander_Active + then + if Is_Record_Type (Ctyp) + and then Has_Discriminants (Ctyp) + and then not Is_Private_Type (Ctyp) + then + -- We build a partially initialized aggregate with the + -- values of the discriminants and box initialization + -- for the rest, if other components are present. + -- The type of the aggregate is the known subtype of + -- the component. The capture of discriminants must + -- be recursive because subcomponents may be constrained + -- (transitively) by discriminants of enclosing types. + -- For a private type with discriminants, a call to the + -- initialization procedure will be generated, and no + -- subaggregate is needed. + + Capture_Discriminants : declare + Loc : constant Source_Ptr := Sloc (N); + Expr : Node_Id; + + procedure Add_Discriminant_Values + (New_Aggr : Node_Id; + Assoc_List : List_Id); + -- The constraint to a component may be given by a + -- discriminant of the enclosing type, in which case + -- we have to retrieve its value, which is part of the + -- enclosing aggregate. Assoc_List provides the + -- discriminant associations of the current type or + -- of some enclosing record. + + procedure Propagate_Discriminants + (Aggr : Node_Id; + Assoc_List : List_Id); + -- Nested components may themselves be discriminated + -- types constrained by outer discriminants, whose + -- values must be captured before the aggregate is + -- expanded into assignments. + + ----------------------------- + -- Add_Discriminant_Values -- + ----------------------------- + + procedure Add_Discriminant_Values + (New_Aggr : Node_Id; + Assoc_List : List_Id) + is + Assoc : Node_Id; + Discr : Entity_Id; + Discr_Elmt : Elmt_Id; + Discr_Val : Node_Id; + Val : Entity_Id; + + begin + Discr := First_Discriminant (Etype (New_Aggr)); + Discr_Elmt := + First_Elmt + (Discriminant_Constraint (Etype (New_Aggr))); + while Present (Discr_Elmt) loop + Discr_Val := Node (Discr_Elmt); + + -- If the constraint is given by a discriminant + -- it is a discriminant of an enclosing record, + -- and its value has already been placed in the + -- association list. + + if Is_Entity_Name (Discr_Val) + and then + Ekind (Entity (Discr_Val)) = E_Discriminant + then + Val := Entity (Discr_Val); + + Assoc := First (Assoc_List); + while Present (Assoc) loop + if Present + (Entity (First (Choices (Assoc)))) + and then + Entity (First (Choices (Assoc))) + = Val + then + Discr_Val := Expression (Assoc); + exit; + end if; + Next (Assoc); + end loop; + end if; + + Add_Association + (Discr, New_Copy_Tree (Discr_Val), + Component_Associations (New_Aggr)); + + -- If the discriminant constraint is a current + -- instance, mark the current aggregate so that + -- the self-reference can be expanded later. + + if Nkind (Discr_Val) = N_Attribute_Reference + and then Is_Entity_Name (Prefix (Discr_Val)) + and then Is_Type (Entity (Prefix (Discr_Val))) + and then Etype (N) = + Entity (Prefix (Discr_Val)) + then + Set_Has_Self_Reference (N); + end if; + + Next_Elmt (Discr_Elmt); + Next_Discriminant (Discr); + end loop; + end Add_Discriminant_Values; + + ------------------------------ + -- Propagate_Discriminants -- + ------------------------------ + + procedure Propagate_Discriminants + (Aggr : Node_Id; + Assoc_List : List_Id) + is + Aggr_Type : constant Entity_Id := + Base_Type (Etype (Aggr)); + Def_Node : constant Node_Id := + Type_Definition + (Declaration_Node (Aggr_Type)); + + Comp : Node_Id; + Comp_Elmt : Elmt_Id; + Components : constant Elist_Id := New_Elmt_List; + Needs_Box : Boolean := False; + Errors : Boolean; + + procedure Process_Component (Comp : Entity_Id); + -- Add one component with a box association to the + -- inner aggregate, and recurse if component is + -- itself composite. + + ------------------------ + -- Process_Component -- + ------------------------ + + procedure Process_Component (Comp : Entity_Id) is + T : constant Entity_Id := Etype (Comp); + New_Aggr : Node_Id; + + begin + if Is_Record_Type (T) + and then Has_Discriminants (T) + then + New_Aggr := + Make_Aggregate (Loc, New_List, New_List); + Set_Etype (New_Aggr, T); + Add_Association + (Comp, New_Aggr, + Component_Associations (Aggr)); + + -- Collect discriminant values and recurse + + Add_Discriminant_Values + (New_Aggr, Assoc_List); + Propagate_Discriminants + (New_Aggr, Assoc_List); + + else + Needs_Box := True; + end if; + end Process_Component; + + -- Start of processing for Propagate_Discriminants + + begin + -- The component type may be a variant type, so + -- collect the components that are ruled by the + -- known values of the discriminants. Their values + -- have already been inserted into the component + -- list of the current aggregate. + + if Nkind (Def_Node) = N_Record_Definition + and then + Present (Component_List (Def_Node)) + and then + Present + (Variant_Part (Component_List (Def_Node))) + then + Gather_Components (Aggr_Type, + Component_List (Def_Node), + Governed_By => Component_Associations (Aggr), + Into => Components, + Report_Errors => Errors); + + Comp_Elmt := First_Elmt (Components); + while Present (Comp_Elmt) loop + if + Ekind (Node (Comp_Elmt)) /= E_Discriminant + then + Process_Component (Node (Comp_Elmt)); + end if; + + Next_Elmt (Comp_Elmt); + end loop; + + -- No variant part, iterate over all components + + else + Comp := First_Component (Etype (Aggr)); + while Present (Comp) loop + Process_Component (Comp); + Next_Component (Comp); + end loop; + end if; + + if Needs_Box then + Append + (Make_Component_Association (Loc, + Choices => + New_List (Make_Others_Choice (Loc)), + Expression => Empty, + Box_Present => True), + Component_Associations (Aggr)); + end if; + end Propagate_Discriminants; + + -- Start of processing for Capture_Discriminants + + begin + Expr := Make_Aggregate (Loc, New_List, New_List); + Set_Etype (Expr, Ctyp); + + -- If the enclosing type has discriminants, they have + -- been collected in the aggregate earlier, and they + -- may appear as constraints of subcomponents. + + -- Similarly if this component has discriminants, they + -- might in turn be propagated to their components. + + if Has_Discriminants (Typ) then + Add_Discriminant_Values (Expr, New_Assoc_List); + Propagate_Discriminants (Expr, New_Assoc_List); + + elsif Has_Discriminants (Ctyp) then + Add_Discriminant_Values + (Expr, Component_Associations (Expr)); + Propagate_Discriminants + (Expr, Component_Associations (Expr)); + + else + declare + Comp : Entity_Id; + + begin + -- If the type has additional components, create + -- an OTHERS box association for them. + + Comp := First_Component (Ctyp); + while Present (Comp) loop + if Ekind (Comp) = E_Component then + if not Is_Record_Type (Etype (Comp)) then + Append + (Make_Component_Association (Loc, + Choices => + New_List + (Make_Others_Choice (Loc)), + Expression => Empty, + Box_Present => True), + Component_Associations (Expr)); + end if; + exit; + end if; + + Next_Component (Comp); + end loop; + end; + end if; + + Add_Association + (Component => Component, + Expr => Expr, + Assoc_List => New_Assoc_List); + end Capture_Discriminants; + + else + Add_Association + (Component => Component, + Expr => Empty, + Assoc_List => New_Assoc_List, + Is_Box_Present => True); + end if; + + -- Otherwise we only need to resolve the expression if the + -- component has partially initialized values (required to + -- expand the corresponding assignments and run-time checks). + + elsif Present (Expr) + and then Is_Partially_Initialized_Type (Ctyp) + then + Resolve_Aggr_Expr (Expr, Component); + end if; + end Check_Box_Component; + + elsif No (Expr) then + + -- Ignore hidden components associated with the position of the + -- interface tags: these are initialized dynamically. + + if not Present (Related_Type (Component)) then + Error_Msg_NE + ("no value supplied for component &!", N, Component); + end if; + + else + Resolve_Aggr_Expr (Expr, Component); + end if; + + Next_Elmt (Component_Elmt); + end loop; + + -- STEP 7: check for invalid components + check type in choice list + + Step_7 : declare + Selectr : Node_Id; + -- Selector name + + Typech : Entity_Id; + -- Type of first component in choice list + + begin + if Present (Component_Associations (N)) then + Assoc := First (Component_Associations (N)); + else + Assoc := Empty; + end if; + + Verification : while Present (Assoc) loop + Selectr := First (Choices (Assoc)); + Typech := Empty; + + if Nkind (Selectr) = N_Others_Choice then + + -- Ada 2005 (AI-287): others choice may have expression or box + + if No (Others_Etype) + and then not Others_Box + then + Error_Msg_N + ("OTHERS must represent at least one component", Selectr); + end if; + + exit Verification; + end if; + + while Present (Selectr) loop + New_Assoc := First (New_Assoc_List); + while Present (New_Assoc) loop + Component := First (Choices (New_Assoc)); + + if Chars (Selectr) = Chars (Component) then + if Style_Check then + Check_Identifier (Selectr, Entity (Component)); + end if; + + exit; + end if; + + Next (New_Assoc); + end loop; + + -- If no association, this is not a legal component of + -- of the type in question, except if its association + -- is provided with a box. + + if No (New_Assoc) then + if Box_Present (Parent (Selectr)) then + + -- This may still be a bogus component with a box. Scan + -- list of components to verify that a component with + -- that name exists. + + declare + C : Entity_Id; + + begin + C := First_Component (Typ); + while Present (C) loop + if Chars (C) = Chars (Selectr) then + + -- If the context is an extension aggregate, + -- the component must not be inherited from + -- the ancestor part of the aggregate. + + if Nkind (N) /= N_Extension_Aggregate + or else + Scope (Original_Record_Component (C)) /= + Etype (Ancestor_Part (N)) + then + exit; + end if; + end if; + + Next_Component (C); + end loop; + + if No (C) then + Error_Msg_Node_2 := Typ; + Error_Msg_N ("& is not a component of}", Selectr); + end if; + end; + + elsif Chars (Selectr) /= Name_uTag + and then Chars (Selectr) /= Name_uParent + and then Chars (Selectr) /= Name_uController + then + if not Has_Discriminants (Typ) then + Error_Msg_Node_2 := Typ; + Error_Msg_N ("& is not a component of}", Selectr); + else + Error_Msg_N + ("& is not a component of the aggregate subtype", + Selectr); + end if; + + Check_Misspelled_Component (Components, Selectr); + end if; + + elsif No (Typech) then + Typech := Base_Type (Etype (Component)); + + -- AI05-0199: In Ada 2012, several components of anonymous + -- access types can appear in a choice list, as long as the + -- designated types match. + + elsif Typech /= Base_Type (Etype (Component)) then + if Ada_Version >= Ada_2012 + and then Ekind (Typech) = E_Anonymous_Access_Type + and then + Ekind (Etype (Component)) = E_Anonymous_Access_Type + and then Base_Type (Designated_Type (Typech)) = + Base_Type (Designated_Type (Etype (Component))) + and then + Subtypes_Statically_Match (Typech, (Etype (Component))) + then + null; + + elsif not Box_Present (Parent (Selectr)) then + Error_Msg_N + ("components in choice list must have same type", + Selectr); + end if; + end if; + + Next (Selectr); + end loop; + + Next (Assoc); + end loop Verification; + end Step_7; + + -- STEP 8: replace the original aggregate + + Step_8 : declare + New_Aggregate : constant Node_Id := New_Copy (N); + + begin + Set_Expressions (New_Aggregate, No_List); + Set_Etype (New_Aggregate, Etype (N)); + Set_Component_Associations (New_Aggregate, New_Assoc_List); + + Rewrite (N, New_Aggregate); + end Step_8; + end Resolve_Record_Aggregate; + + ----------------------------- + -- Check_Can_Never_Be_Null -- + ----------------------------- + + procedure Check_Can_Never_Be_Null (Typ : Entity_Id; Expr : Node_Id) is + Comp_Typ : Entity_Id; + + begin + pragma Assert + (Ada_Version >= Ada_2005 + and then Present (Expr) + and then Known_Null (Expr)); + + case Ekind (Typ) is + when E_Array_Type => + Comp_Typ := Component_Type (Typ); + + when E_Component | + E_Discriminant => + Comp_Typ := Etype (Typ); + + when others => + return; + end case; + + if Can_Never_Be_Null (Comp_Typ) then + + -- Here we know we have a constraint error. Note that we do not use + -- Apply_Compile_Time_Constraint_Error here to the Expr, which might + -- seem the more natural approach. That's because in some cases the + -- components are rewritten, and the replacement would be missed. + + Insert_Action + (Compile_Time_Constraint_Error + (Expr, + "(Ada 2005) null not allowed in null-excluding component?"), + Make_Raise_Constraint_Error (Sloc (Expr), + Reason => CE_Access_Check_Failed)); + + -- Set proper type for bogus component (why is this needed???) + + Set_Etype (Expr, Comp_Typ); + Set_Analyzed (Expr); + end if; + end Check_Can_Never_Be_Null; + + --------------------- + -- Sort_Case_Table -- + --------------------- + + procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is + L : constant Int := Case_Table'First; + U : constant Int := Case_Table'Last; + K : Int; + J : Int; + T : Case_Bounds; + + begin + K := L; + while K /= U loop + T := Case_Table (K + 1); + + J := K + 1; + while J /= L + and then Expr_Value (Case_Table (J - 1).Choice_Lo) > + Expr_Value (T.Choice_Lo) + loop + Case_Table (J) := Case_Table (J - 1); + J := J - 1; + end loop; + + Case_Table (J) := T; + K := K + 1; + end loop; + end Sort_Case_Table; + +end Sem_Aggr; diff --git a/gcc/ada/sem_aggr.ads b/gcc/ada/sem_aggr.ads new file mode 100644 index 000000000..86adccafb --- /dev/null +++ b/gcc/ada/sem_aggr.ads @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ A G G R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 resolution code for aggregates. It is logically +-- part of Sem_Res, but is split off since the aggregate code is so complex. + +with Types; use Types; + +package Sem_Aggr is + + procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Extension_Aggregate (N : Node_Id; Typ : Entity_Id); + +end Sem_Aggr; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb new file mode 100644 index 000000000..b7b4f2f63 --- /dev/null +++ b/gcc/ada/sem_attr.adb @@ -0,0 +1,8846 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ A T T 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 Atree; use Atree; +with Casing; use Casing; +with Checks; use Checks; +with Einfo; use Einfo; +with Errout; use Errout; +with Eval_Fat; +with Exp_Dist; use Exp_Dist; +with Exp_Util; use Exp_Util; +with Expander; use Expander; +with Freeze; use Freeze; +with Gnatvsn; use Gnatvsn; +with Itypes; use Itypes; +with Lib; use Lib; +with Lib.Xref; use Lib.Xref; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sdefault; use Sdefault; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Cat; use Sem_Cat; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch10; use Sem_Ch10; +with Sem_Dist; use Sem_Dist; +with Sem_Elim; use Sem_Elim; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Stringt; use Stringt; +with Style; +with Stylesw; use Stylesw; +with Targparm; use Targparm; +with Ttypes; use Ttypes; +with Tbuild; use Tbuild; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package body Sem_Attr is + + True_Value : constant Uint := Uint_1; + False_Value : constant Uint := Uint_0; + -- Synonyms to be used when these constants are used as Boolean values + + Bad_Attribute : exception; + -- Exception raised if an error is detected during attribute processing, + -- used so that we can abandon the processing so we don't run into + -- trouble with cascaded errors. + + -- The following array is the list of attributes defined in the Ada 83 RM + -- that are not included in Ada 95, but still get recognized in GNAT. + + Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'( + Attribute_Address | + Attribute_Aft | + Attribute_Alignment | + Attribute_Base | + Attribute_Callable | + Attribute_Constrained | + Attribute_Count | + Attribute_Delta | + Attribute_Digits | + Attribute_Emax | + Attribute_Epsilon | + Attribute_First | + Attribute_First_Bit | + Attribute_Fore | + Attribute_Image | + Attribute_Large | + Attribute_Last | + Attribute_Last_Bit | + Attribute_Leading_Part | + Attribute_Length | + Attribute_Machine_Emax | + Attribute_Machine_Emin | + Attribute_Machine_Mantissa | + Attribute_Machine_Overflows | + Attribute_Machine_Radix | + Attribute_Machine_Rounds | + Attribute_Mantissa | + Attribute_Pos | + Attribute_Position | + Attribute_Pred | + Attribute_Range | + Attribute_Safe_Emax | + Attribute_Safe_Large | + Attribute_Safe_Small | + Attribute_Size | + Attribute_Small | + Attribute_Storage_Size | + Attribute_Succ | + Attribute_Terminated | + Attribute_Val | + Attribute_Value | + Attribute_Width => True, + others => False); + + -- The following array is the list of attributes defined in the Ada 2005 + -- RM which are not defined in Ada 95. These are recognized in Ada 95 mode, + -- but in Ada 95 they are considered to be implementation defined. + + Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'( + Attribute_Machine_Rounding | + Attribute_Mod | + Attribute_Priority | + Attribute_Stream_Size | + Attribute_Wide_Wide_Width => True, + others => False); + + -- The following array contains all attributes that imply a modification + -- of their prefixes or result in an access value. Such prefixes can be + -- considered as lvalues. + + Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Class_Array := + Attribute_Class_Array'( + Attribute_Access | + Attribute_Address | + Attribute_Input | + Attribute_Read | + Attribute_Unchecked_Access | + Attribute_Unrestricted_Access => True, + others => False); + + ----------------------- + -- Local_Subprograms -- + ----------------------- + + procedure Eval_Attribute (N : Node_Id); + -- Performs compile time evaluation of attributes where possible, leaving + -- the Is_Static_Expression/Raises_Constraint_Error flags appropriately + -- set, and replacing the node with a literal node if the value can be + -- computed at compile time. All static attribute references are folded, + -- as well as a number of cases of non-static attributes that can always + -- be computed at compile time (e.g. floating-point model attributes that + -- are applied to non-static subtypes). Of course in such cases, the + -- Is_Static_Expression flag will not be set on the resulting literal. + -- Note that the only required action of this procedure is to catch the + -- static expression cases as described in the RM. Folding of other cases + -- is done where convenient, but some additional non-static folding is in + -- N_Expand_Attribute_Reference in cases where this is more convenient. + + function Is_Anonymous_Tagged_Base + (Anon : Entity_Id; + Typ : Entity_Id) + return Boolean; + -- For derived tagged types that constrain parent discriminants we build + -- an anonymous unconstrained base type. We need to recognize the relation + -- between the two when analyzing an access attribute for a constrained + -- component, before the full declaration for Typ has been analyzed, and + -- where therefore the prefix of the attribute does not match the enclosing + -- scope. + + ----------------------- + -- Analyze_Attribute -- + ----------------------- + + procedure Analyze_Attribute (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Aname : constant Name_Id := Attribute_Name (N); + P : constant Node_Id := Prefix (N); + Exprs : constant List_Id := Expressions (N); + Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname); + E1 : Node_Id; + E2 : Node_Id; + + P_Type : Entity_Id; + -- Type of prefix after analysis + + P_Base_Type : Entity_Id; + -- Base type of prefix after analysis + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Analyze_Access_Attribute; + -- Used for Access, Unchecked_Access, Unrestricted_Access attributes. + -- Internally, Id distinguishes which of the three cases is involved. + + procedure Bad_Attribute_For_Predicate; + -- Output error message for use of a predicate (First, Last, Range) not + -- allowed with a type that has predicates. If the type is a generic + -- actual, then the message is a warning, and we generate code to raise + -- program error with an appropriate reason. No error message is given + -- for internally generated uses of the attributes. + + procedure Check_Array_Or_Scalar_Type; + -- Common procedure used by First, Last, Range attribute to check + -- that the prefix is a constrained array or scalar type, or a name + -- of an array object, and that an argument appears only if appropriate + -- (i.e. only in the array case). + + procedure Check_Array_Type; + -- Common semantic checks for all array attributes. Checks that the + -- prefix is a constrained array type or the name of an array object. + -- The error message for non-arrays is specialized appropriately. + + procedure Check_Asm_Attribute; + -- Common semantic checks for Asm_Input and Asm_Output attributes + + procedure Check_Component; + -- Common processing for Bit_Position, First_Bit, Last_Bit, and + -- Position. Checks prefix is an appropriate selected component. + + procedure Check_Decimal_Fixed_Point_Type; + -- Check that prefix of attribute N is a decimal fixed-point type + + procedure Check_Dereference; + -- If the prefix of attribute is an object of an access type, then + -- introduce an explicit dereference, and adjust P_Type accordingly. + + procedure Check_Discrete_Type; + -- Verify that prefix of attribute N is a discrete type + + procedure Check_E0; + -- Check that no attribute arguments are present + + procedure Check_Either_E0_Or_E1; + -- Check that there are zero or one attribute arguments present + + procedure Check_E1; + -- Check that exactly one attribute argument is present + + procedure Check_E2; + -- Check that two attribute arguments are present + + procedure Check_Enum_Image; + -- If the prefix type is an enumeration type, set all its literals + -- as referenced, since the image function could possibly end up + -- referencing any of the literals indirectly. Same for Enum_Val. + + procedure Check_Fixed_Point_Type; + -- Verify that prefix of attribute N is a fixed type + + procedure Check_Fixed_Point_Type_0; + -- Verify that prefix of attribute N is a fixed type and that + -- no attribute expressions are present + + procedure Check_Floating_Point_Type; + -- Verify that prefix of attribute N is a float type + + procedure Check_Floating_Point_Type_0; + -- Verify that prefix of attribute N is a float type and that + -- no attribute expressions are present + + procedure Check_Floating_Point_Type_1; + -- Verify that prefix of attribute N is a float type and that + -- exactly one attribute expression is present + + procedure Check_Floating_Point_Type_2; + -- Verify that prefix of attribute N is a float type and that + -- two attribute expressions are present + + procedure Legal_Formal_Attribute; + -- Common processing for attributes Definite and Has_Discriminants. + -- Checks that prefix is generic indefinite formal type. + + procedure Check_Integer_Type; + -- Verify that prefix of attribute N is an integer type + + procedure Check_Library_Unit; + -- Verify that prefix of attribute N is a library unit + + procedure Check_Modular_Integer_Type; + -- Verify that prefix of attribute N is a modular integer type + + procedure Check_Not_CPP_Type; + -- Check that P (the prefix of the attribute) is not an CPP type + -- for which no Ada predefined primitive is available. + + procedure Check_Not_Incomplete_Type; + -- Check that P (the prefix of the attribute) is not an incomplete + -- type or a private type for which no full view has been given. + + procedure Check_Object_Reference (P : Node_Id); + -- Check that P (the prefix of the attribute) is an object reference + + procedure Check_Program_Unit; + -- Verify that prefix of attribute N is a program unit + + procedure Check_Real_Type; + -- Verify that prefix of attribute N is fixed or float type + + procedure Check_Scalar_Type; + -- Verify that prefix of attribute N is a scalar type + + procedure Check_Standard_Prefix; + -- Verify that prefix of attribute N is package Standard + + procedure Check_Stream_Attribute (Nam : TSS_Name_Type); + -- Validity checking for stream attribute. Nam is the TSS name of the + -- corresponding possible defined attribute function (e.g. for the + -- Read attribute, Nam will be TSS_Stream_Read). + + procedure Check_PolyORB_Attribute; + -- Validity checking for PolyORB/DSA attribute + + procedure Check_Task_Prefix; + -- Verify that prefix of attribute N is a task or task type + + procedure Check_Type; + -- Verify that the prefix of attribute N is a type + + procedure Check_Unit_Name (Nod : Node_Id); + -- Check that Nod is of the form of a library unit name, i.e that + -- it is an identifier, or a selected component whose prefix is + -- itself of the form of a library unit name. Note that this is + -- quite different from Check_Program_Unit, since it only checks + -- the syntactic form of the name, not the semantic identity. This + -- is because it is used with attributes (Elab_Body, Elab_Spec, and + -- UET_Address) which can refer to non-visible unit. + + procedure Error_Attr (Msg : String; Error_Node : Node_Id); + pragma No_Return (Error_Attr); + procedure Error_Attr; + pragma No_Return (Error_Attr); + -- Posts error using Error_Msg_N at given node, sets type of attribute + -- node to Any_Type, and then raises Bad_Attribute to avoid any further + -- semantic processing. The message typically contains a % insertion + -- character which is replaced by the attribute name. The call with + -- no arguments is used when the caller has already generated the + -- required error messages. + + procedure Error_Attr_P (Msg : String); + pragma No_Return (Error_Attr); + -- Like Error_Attr, but error is posted at the start of the prefix + + procedure Standard_Attribute (Val : Int); + -- Used to process attributes whose prefix is package Standard which + -- yield values of type Universal_Integer. The attribute reference + -- node is rewritten with an integer literal of the given value. + + procedure Unexpected_Argument (En : Node_Id); + -- Signal unexpected attribute argument (En is the argument) + + procedure Validate_Non_Static_Attribute_Function_Call; + -- Called when processing an attribute that is a function call to a + -- non-static function, i.e. an attribute function that either takes + -- non-scalar arguments or returns a non-scalar result. Verifies that + -- such a call does not appear in a preelaborable context. + + ------------------------------ + -- Analyze_Access_Attribute -- + ------------------------------ + + procedure Analyze_Access_Attribute is + Acc_Type : Entity_Id; + + Scop : Entity_Id; + Typ : Entity_Id; + + function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id; + -- Build an access-to-object type whose designated type is DT, + -- and whose Ekind is appropriate to the attribute type. The + -- type that is constructed is returned as the result. + + procedure Build_Access_Subprogram_Type (P : Node_Id); + -- Build an access to subprogram whose designated type is the type of + -- the prefix. If prefix is overloaded, so is the node itself. The + -- result is stored in Acc_Type. + + function OK_Self_Reference return Boolean; + -- An access reference whose prefix is a type can legally appear + -- within an aggregate, where it is obtained by expansion of + -- a defaulted aggregate. The enclosing aggregate that contains + -- the self-referenced is flagged so that the self-reference can + -- be expanded into a reference to the target object (see exp_aggr). + + ------------------------------ + -- Build_Access_Object_Type -- + ------------------------------ + + function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id is + Typ : constant Entity_Id := + New_Internal_Entity + (E_Access_Attribute_Type, Current_Scope, Loc, 'A'); + begin + Set_Etype (Typ, Typ); + Set_Is_Itype (Typ); + Set_Associated_Node_For_Itype (Typ, N); + Set_Directly_Designated_Type (Typ, DT); + return Typ; + end Build_Access_Object_Type; + + ---------------------------------- + -- Build_Access_Subprogram_Type -- + ---------------------------------- + + procedure Build_Access_Subprogram_Type (P : Node_Id) is + Index : Interp_Index; + It : Interp; + + procedure Check_Local_Access (E : Entity_Id); + -- Deal with possible access to local subprogram. If we have such + -- an access, we set a flag to kill all tracked values on any call + -- because this access value may be passed around, and any called + -- code might use it to access a local procedure which clobbers a + -- tracked value. If the scope is a loop or block, indicate that + -- value tracking is disabled for the enclosing subprogram. + + function Get_Kind (E : Entity_Id) return Entity_Kind; + -- Distinguish between access to regular/protected subprograms + + ------------------------ + -- Check_Local_Access -- + ------------------------ + + procedure Check_Local_Access (E : Entity_Id) is + begin + if not Is_Library_Level_Entity (E) then + Set_Suppress_Value_Tracking_On_Call (Current_Scope); + Set_Suppress_Value_Tracking_On_Call + (Nearest_Dynamic_Scope (Current_Scope)); + end if; + end Check_Local_Access; + + -------------- + -- Get_Kind -- + -------------- + + function Get_Kind (E : Entity_Id) return Entity_Kind is + begin + if Convention (E) = Convention_Protected then + return E_Access_Protected_Subprogram_Type; + else + return E_Access_Subprogram_Type; + end if; + end Get_Kind; + + -- Start of processing for Build_Access_Subprogram_Type + + begin + -- In the case of an access to subprogram, use the name of the + -- subprogram itself as the designated type. Type-checking in + -- this case compares the signatures of the designated types. + + -- Note: This fragment of the tree is temporarily malformed + -- because the correct tree requires an E_Subprogram_Type entity + -- as the designated type. In most cases this designated type is + -- later overridden by the semantics with the type imposed by the + -- context during the resolution phase. In the specific case of + -- the expression Address!(Prim'Unrestricted_Access), used to + -- initialize slots of dispatch tables, this work will be done by + -- the expander (see Exp_Aggr). + + -- The reason to temporarily add this kind of node to the tree + -- instead of a proper E_Subprogram_Type itype, is the following: + -- in case of errors found in the source file we report better + -- error messages. For example, instead of generating the + -- following error: + + -- "expected access to subprogram with profile + -- defined at line X" + + -- we currently generate: + + -- "expected access to function Z defined at line X" + + Set_Etype (N, Any_Type); + + if not Is_Overloaded (P) then + Check_Local_Access (Entity (P)); + + if not Is_Intrinsic_Subprogram (Entity (P)) then + Acc_Type := Create_Itype (Get_Kind (Entity (P)), N); + Set_Is_Public (Acc_Type, False); + Set_Etype (Acc_Type, Acc_Type); + Set_Convention (Acc_Type, Convention (Entity (P))); + Set_Directly_Designated_Type (Acc_Type, Entity (P)); + Set_Etype (N, Acc_Type); + Freeze_Before (N, Acc_Type); + end if; + + else + Get_First_Interp (P, Index, It); + while Present (It.Nam) loop + Check_Local_Access (It.Nam); + + if not Is_Intrinsic_Subprogram (It.Nam) then + Acc_Type := Create_Itype (Get_Kind (It.Nam), N); + Set_Is_Public (Acc_Type, False); + Set_Etype (Acc_Type, Acc_Type); + Set_Convention (Acc_Type, Convention (It.Nam)); + Set_Directly_Designated_Type (Acc_Type, It.Nam); + Add_One_Interp (N, Acc_Type, Acc_Type); + Freeze_Before (N, Acc_Type); + end if; + + Get_Next_Interp (Index, It); + end loop; + end if; + + -- Cannot be applied to intrinsic. Looking at the tests above, + -- the only way Etype (N) can still be set to Any_Type is if + -- Is_Intrinsic_Subprogram was True for some referenced entity. + + if Etype (N) = Any_Type then + Error_Attr_P ("prefix of % attribute cannot be intrinsic"); + end if; + end Build_Access_Subprogram_Type; + + ---------------------- + -- OK_Self_Reference -- + ---------------------- + + function OK_Self_Reference return Boolean is + Par : Node_Id; + + begin + Par := Parent (N); + while Present (Par) + and then + (Nkind (Par) = N_Component_Association + or else Nkind (Par) in N_Subexpr) + loop + if Nkind_In (Par, N_Aggregate, N_Extension_Aggregate) then + if Etype (Par) = Typ then + Set_Has_Self_Reference (Par); + return True; + end if; + end if; + + Par := Parent (Par); + end loop; + + -- No enclosing aggregate, or not a self-reference + + return False; + end OK_Self_Reference; + + -- Start of processing for Analyze_Access_Attribute + + begin + Check_E0; + + if Nkind (P) = N_Character_Literal then + Error_Attr_P + ("prefix of % attribute cannot be enumeration literal"); + end if; + + -- Case of access to subprogram + + if Is_Entity_Name (P) + and then Is_Overloadable (Entity (P)) + then + if Has_Pragma_Inline_Always (Entity (P)) then + Error_Attr_P + ("prefix of % attribute cannot be Inline_Always subprogram"); + end if; + + if Aname = Name_Unchecked_Access then + Error_Attr ("attribute% cannot be applied to a subprogram", P); + end if; + + -- Issue an error if the prefix denotes an eliminated subprogram + + Check_For_Eliminated_Subprogram (P, Entity (P)); + + -- Check for obsolescent subprogram reference + + Check_Obsolescent_2005_Entity (Entity (P), P); + + -- Build the appropriate subprogram type + + Build_Access_Subprogram_Type (P); + + -- For unrestricted access, kill current values, since this + -- attribute allows a reference to a local subprogram that + -- could modify local variables to be passed out of scope + + if Aname = Name_Unrestricted_Access then + + -- Do not kill values on nodes initializing dispatch tables + -- slots. The construct Prim_Ptr!(Prim'Unrestricted_Access) + -- is currently generated by the expander only for this + -- purpose. Done to keep the quality of warnings currently + -- generated by the compiler (otherwise any declaration of + -- a tagged type cleans constant indications from its scope). + + if Nkind (Parent (N)) = N_Unchecked_Type_Conversion + and then (Etype (Parent (N)) = RTE (RE_Prim_Ptr) + or else + Etype (Parent (N)) = RTE (RE_Size_Ptr)) + and then Is_Dispatching_Operation + (Directly_Designated_Type (Etype (N))) + then + null; + else + Kill_Current_Values; + end if; + end if; + + return; + + -- Component is an operation of a protected type + + elsif Nkind (P) = N_Selected_Component + and then Is_Overloadable (Entity (Selector_Name (P))) + then + if Ekind (Entity (Selector_Name (P))) = E_Entry then + Error_Attr_P ("prefix of % attribute must be subprogram"); + end if; + + Build_Access_Subprogram_Type (Selector_Name (P)); + return; + end if; + + -- Deal with incorrect reference to a type, but note that some + -- accesses are allowed: references to the current type instance, + -- or in Ada 2005 self-referential pointer in a default-initialized + -- aggregate. + + if Is_Entity_Name (P) then + Typ := Entity (P); + + -- The reference may appear in an aggregate that has been expanded + -- into a loop. Locate scope of type definition, if any. + + Scop := Current_Scope; + while Ekind (Scop) = E_Loop loop + Scop := Scope (Scop); + end loop; + + if Is_Type (Typ) then + + -- OK if we are within the scope of a limited type + -- let's mark the component as having per object constraint + + if Is_Anonymous_Tagged_Base (Scop, Typ) then + Typ := Scop; + Set_Entity (P, Typ); + Set_Etype (P, Typ); + end if; + + if Typ = Scop then + declare + Q : Node_Id := Parent (N); + + begin + while Present (Q) + and then Nkind (Q) /= N_Component_Declaration + loop + Q := Parent (Q); + end loop; + + if Present (Q) then + Set_Has_Per_Object_Constraint + (Defining_Identifier (Q), True); + end if; + end; + + if Nkind (P) = N_Expanded_Name then + Error_Msg_F + ("current instance prefix must be a direct name", P); + end if; + + -- If a current instance attribute appears in a component + -- constraint it must appear alone; other contexts (spec- + -- expressions, within a task body) are not subject to this + -- restriction. + + if not In_Spec_Expression + and then not Has_Completion (Scop) + and then not + Nkind_In (Parent (N), N_Discriminant_Association, + N_Index_Or_Discriminant_Constraint) + then + Error_Msg_N + ("current instance attribute must appear alone", N); + end if; + + if Is_CPP_Class (Root_Type (Typ)) then + Error_Msg_N + ("?current instance unsupported for derivations of " + & "'C'P'P types", N); + end if; + + -- OK if we are in initialization procedure for the type + -- in question, in which case the reference to the type + -- is rewritten as a reference to the current object. + + elsif Ekind (Scop) = E_Procedure + and then Is_Init_Proc (Scop) + and then Etype (First_Formal (Scop)) = Typ + then + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Attribute_Name => Name_Unrestricted_Access)); + Analyze (N); + return; + + -- OK if a task type, this test needs sharpening up ??? + + elsif Is_Task_Type (Typ) then + null; + + -- OK if self-reference in an aggregate in Ada 2005, and + -- the reference comes from a copied default expression. + + -- Note that we check legality of self-reference even if the + -- expression comes from source, e.g. when a single component + -- association in an aggregate has a box association. + + elsif Ada_Version >= Ada_2005 + and then OK_Self_Reference + then + null; + + -- OK if reference to current instance of a protected object + + elsif Is_Protected_Self_Reference (P) then + null; + + -- Otherwise we have an error case + + else + Error_Attr ("% attribute cannot be applied to type", P); + return; + end if; + end if; + end if; + + -- If we fall through, we have a normal access to object case. + -- Unrestricted_Access is legal wherever an allocator would be + -- legal, so its Etype is set to E_Allocator. The expected type + -- of the other attributes is a general access type, and therefore + -- we label them with E_Access_Attribute_Type. + + if not Is_Overloaded (P) then + Acc_Type := Build_Access_Object_Type (P_Type); + Set_Etype (N, Acc_Type); + else + declare + Index : Interp_Index; + It : Interp; + begin + Set_Etype (N, Any_Type); + Get_First_Interp (P, Index, It); + while Present (It.Typ) loop + Acc_Type := Build_Access_Object_Type (It.Typ); + Add_One_Interp (N, Acc_Type, Acc_Type); + Get_Next_Interp (Index, It); + end loop; + end; + end if; + + -- Special cases when we can find a prefix that is an entity name + + declare + PP : Node_Id; + Ent : Entity_Id; + + begin + PP := P; + loop + if Is_Entity_Name (PP) then + Ent := Entity (PP); + + -- If we have an access to an object, and the attribute + -- comes from source, then set the object as potentially + -- source modified. We do this because the resulting access + -- pointer can be used to modify the variable, and we might + -- not detect this, leading to some junk warnings. + + Set_Never_Set_In_Source (Ent, False); + + -- Mark entity as address taken, and kill current values + + Set_Address_Taken (Ent); + Kill_Current_Values (Ent); + exit; + + elsif Nkind_In (PP, N_Selected_Component, + N_Indexed_Component) + then + PP := Prefix (PP); + + else + exit; + end if; + end loop; + end; + + -- Check for aliased view unless unrestricted case. We allow a + -- nonaliased prefix when within an instance because the prefix may + -- have been a tagged formal object, which is defined to be aliased + -- even when the actual might not be (other instance cases will have + -- been caught in the generic). Similarly, within an inlined body we + -- know that the attribute is legal in the original subprogram, and + -- therefore legal in the expansion. + + if Aname /= Name_Unrestricted_Access + and then not Is_Aliased_View (P) + and then not In_Instance + and then not In_Inlined_Body + then + Error_Attr_P ("prefix of % attribute must be aliased"); + end if; + end Analyze_Access_Attribute; + + --------------------------------- + -- Bad_Attribute_For_Predicate -- + --------------------------------- + + procedure Bad_Attribute_For_Predicate is + begin + if Comes_From_Source (N) then + Error_Msg_Name_1 := Aname; + Bad_Predicated_Subtype_Use + ("type& has predicates, attribute % not allowed", N, P_Type); + end if; + end Bad_Attribute_For_Predicate; + + -------------------------------- + -- Check_Array_Or_Scalar_Type -- + -------------------------------- + + procedure Check_Array_Or_Scalar_Type is + Index : Entity_Id; + + D : Int; + -- Dimension number for array attributes + + begin + -- Case of string literal or string literal subtype. These cases + -- cannot arise from legal Ada code, but the expander is allowed + -- to generate them. They require special handling because string + -- literal subtypes do not have standard bounds (the whole idea + -- of these subtypes is to avoid having to generate the bounds) + + if Ekind (P_Type) = E_String_Literal_Subtype then + Set_Etype (N, Etype (First_Index (P_Base_Type))); + return; + + -- Scalar types + + elsif Is_Scalar_Type (P_Type) then + Check_Type; + + if Present (E1) then + Error_Attr ("invalid argument in % attribute", E1); + else + Set_Etype (N, P_Base_Type); + return; + end if; + + -- The following is a special test to allow 'First to apply to + -- private scalar types if the attribute comes from generated + -- code. This occurs in the case of Normalize_Scalars code. + + elsif Is_Private_Type (P_Type) + and then Present (Full_View (P_Type)) + and then Is_Scalar_Type (Full_View (P_Type)) + and then not Comes_From_Source (N) + then + Set_Etype (N, Implementation_Base_Type (P_Type)); + + -- Array types other than string literal subtypes handled above + + else + Check_Array_Type; + + -- We know prefix is an array type, or the name of an array + -- object, and that the expression, if present, is static + -- and within the range of the dimensions of the type. + + pragma Assert (Is_Array_Type (P_Type)); + Index := First_Index (P_Base_Type); + + if No (E1) then + + -- First dimension assumed + + Set_Etype (N, Base_Type (Etype (Index))); + + else + D := UI_To_Int (Intval (E1)); + + for J in 1 .. D - 1 loop + Next_Index (Index); + end loop; + + Set_Etype (N, Base_Type (Etype (Index))); + Set_Etype (E1, Standard_Integer); + end if; + end if; + end Check_Array_Or_Scalar_Type; + + ---------------------- + -- Check_Array_Type -- + ---------------------- + + procedure Check_Array_Type is + D : Int; + -- Dimension number for array attributes + + begin + -- If the type is a string literal type, then this must be generated + -- internally, and no further check is required on its legality. + + if Ekind (P_Type) = E_String_Literal_Subtype then + return; + + -- If the type is a composite, it is an illegal aggregate, no point + -- in going on. + + elsif P_Type = Any_Composite then + raise Bad_Attribute; + end if; + + -- Normal case of array type or subtype + + Check_Either_E0_Or_E1; + Check_Dereference; + + if Is_Array_Type (P_Type) then + if not Is_Constrained (P_Type) + and then Is_Entity_Name (P) + and then Is_Type (Entity (P)) + then + -- Note: we do not call Error_Attr here, since we prefer to + -- continue, using the relevant index type of the array, + -- even though it is unconstrained. This gives better error + -- recovery behavior. + + Error_Msg_Name_1 := Aname; + Error_Msg_F + ("prefix for % attribute must be constrained array", P); + end if; + + D := Number_Dimensions (P_Type); + + else + if Is_Private_Type (P_Type) then + Error_Attr_P ("prefix for % attribute may not be private type"); + + elsif Is_Access_Type (P_Type) + and then Is_Array_Type (Designated_Type (P_Type)) + and then Is_Entity_Name (P) + and then Is_Type (Entity (P)) + then + Error_Attr_P ("prefix of % attribute cannot be access type"); + + elsif Attr_Id = Attribute_First + or else + Attr_Id = Attribute_Last + then + Error_Attr ("invalid prefix for % attribute", P); + + else + Error_Attr_P ("prefix for % attribute must be array"); + end if; + end if; + + if Present (E1) then + Resolve (E1, Any_Integer); + Set_Etype (E1, Standard_Integer); + + if not Is_Static_Expression (E1) + or else Raises_Constraint_Error (E1) + then + Flag_Non_Static_Expr + ("expression for dimension must be static!", E1); + Error_Attr; + + elsif UI_To_Int (Expr_Value (E1)) > D + or else UI_To_Int (Expr_Value (E1)) < 1 + then + Error_Attr ("invalid dimension number for array type", E1); + end if; + end if; + + if (Style_Check and Style_Check_Array_Attribute_Index) + and then Comes_From_Source (N) + then + Style.Check_Array_Attribute_Index (N, E1, D); + end if; + end Check_Array_Type; + + ------------------------- + -- Check_Asm_Attribute -- + ------------------------- + + procedure Check_Asm_Attribute is + begin + Check_Type; + Check_E2; + + -- Check first argument is static string expression + + Analyze_And_Resolve (E1, Standard_String); + + if Etype (E1) = Any_Type then + return; + + elsif not Is_OK_Static_Expression (E1) then + Flag_Non_Static_Expr + ("constraint argument must be static string expression!", E1); + Error_Attr; + end if; + + -- Check second argument is right type + + Analyze_And_Resolve (E2, Entity (P)); + + -- Note: that is all we need to do, we don't need to check + -- that it appears in a correct context. The Ada type system + -- will do that for us. + + end Check_Asm_Attribute; + + --------------------- + -- Check_Component -- + --------------------- + + procedure Check_Component is + begin + Check_E0; + + if Nkind (P) /= N_Selected_Component + or else + (Ekind (Entity (Selector_Name (P))) /= E_Component + and then + Ekind (Entity (Selector_Name (P))) /= E_Discriminant) + then + Error_Attr_P ("prefix for % attribute must be selected component"); + end if; + end Check_Component; + + ------------------------------------ + -- Check_Decimal_Fixed_Point_Type -- + ------------------------------------ + + procedure Check_Decimal_Fixed_Point_Type is + begin + Check_Type; + + if not Is_Decimal_Fixed_Point_Type (P_Type) then + Error_Attr_P ("prefix of % attribute must be decimal type"); + end if; + end Check_Decimal_Fixed_Point_Type; + + ----------------------- + -- Check_Dereference -- + ----------------------- + + procedure Check_Dereference is + begin + + -- Case of a subtype mark + + if Is_Entity_Name (P) + and then Is_Type (Entity (P)) + then + return; + end if; + + -- Case of an expression + + Resolve (P); + + if Is_Access_Type (P_Type) then + + -- If there is an implicit dereference, then we must freeze + -- the designated type of the access type, since the type of + -- the referenced array is this type (see AI95-00106). + + -- As done elsewhere, freezing must not happen when pre-analyzing + -- a pre- or postcondition or a default value for an object or + -- for a formal parameter. + + if not In_Spec_Expression then + Freeze_Before (N, Designated_Type (P_Type)); + end if; + + Rewrite (P, + Make_Explicit_Dereference (Sloc (P), + Prefix => Relocate_Node (P))); + + Analyze_And_Resolve (P); + P_Type := Etype (P); + + if P_Type = Any_Type then + raise Bad_Attribute; + end if; + + P_Base_Type := Base_Type (P_Type); + end if; + end Check_Dereference; + + ------------------------- + -- Check_Discrete_Type -- + ------------------------- + + procedure Check_Discrete_Type is + begin + Check_Type; + + if not Is_Discrete_Type (P_Type) then + Error_Attr_P ("prefix of % attribute must be discrete type"); + end if; + end Check_Discrete_Type; + + -------------- + -- Check_E0 -- + -------------- + + procedure Check_E0 is + begin + if Present (E1) then + Unexpected_Argument (E1); + end if; + end Check_E0; + + -------------- + -- Check_E1 -- + -------------- + + procedure Check_E1 is + begin + Check_Either_E0_Or_E1; + + if No (E1) then + + -- Special-case attributes that are functions and that appear as + -- the prefix of another attribute. Error is posted on parent. + + if Nkind (Parent (N)) = N_Attribute_Reference + and then (Attribute_Name (Parent (N)) = Name_Address + or else + Attribute_Name (Parent (N)) = Name_Code_Address + or else + Attribute_Name (Parent (N)) = Name_Access) + then + Error_Msg_Name_1 := Attribute_Name (Parent (N)); + Error_Msg_N ("illegal prefix for % attribute", Parent (N)); + Set_Etype (Parent (N), Any_Type); + Set_Entity (Parent (N), Any_Type); + raise Bad_Attribute; + + else + Error_Attr ("missing argument for % attribute", N); + end if; + end if; + end Check_E1; + + -------------- + -- Check_E2 -- + -------------- + + procedure Check_E2 is + begin + if No (E1) then + Error_Attr ("missing arguments for % attribute (2 required)", N); + elsif No (E2) then + Error_Attr ("missing argument for % attribute (2 required)", N); + end if; + end Check_E2; + + --------------------------- + -- Check_Either_E0_Or_E1 -- + --------------------------- + + procedure Check_Either_E0_Or_E1 is + begin + if Present (E2) then + Unexpected_Argument (E2); + end if; + end Check_Either_E0_Or_E1; + + ---------------------- + -- Check_Enum_Image -- + ---------------------- + + procedure Check_Enum_Image is + Lit : Entity_Id; + begin + if Is_Enumeration_Type (P_Base_Type) then + Lit := First_Literal (P_Base_Type); + while Present (Lit) loop + Set_Referenced (Lit); + Next_Literal (Lit); + end loop; + end if; + end Check_Enum_Image; + + ---------------------------- + -- Check_Fixed_Point_Type -- + ---------------------------- + + procedure Check_Fixed_Point_Type is + begin + Check_Type; + + if not Is_Fixed_Point_Type (P_Type) then + Error_Attr_P ("prefix of % attribute must be fixed point type"); + end if; + end Check_Fixed_Point_Type; + + ------------------------------ + -- Check_Fixed_Point_Type_0 -- + ------------------------------ + + procedure Check_Fixed_Point_Type_0 is + begin + Check_Fixed_Point_Type; + Check_E0; + end Check_Fixed_Point_Type_0; + + ------------------------------- + -- Check_Floating_Point_Type -- + ------------------------------- + + procedure Check_Floating_Point_Type is + begin + Check_Type; + + if not Is_Floating_Point_Type (P_Type) then + Error_Attr_P ("prefix of % attribute must be float type"); + end if; + end Check_Floating_Point_Type; + + --------------------------------- + -- Check_Floating_Point_Type_0 -- + --------------------------------- + + procedure Check_Floating_Point_Type_0 is + begin + Check_Floating_Point_Type; + Check_E0; + end Check_Floating_Point_Type_0; + + --------------------------------- + -- Check_Floating_Point_Type_1 -- + --------------------------------- + + procedure Check_Floating_Point_Type_1 is + begin + Check_Floating_Point_Type; + Check_E1; + end Check_Floating_Point_Type_1; + + --------------------------------- + -- Check_Floating_Point_Type_2 -- + --------------------------------- + + procedure Check_Floating_Point_Type_2 is + begin + Check_Floating_Point_Type; + Check_E2; + end Check_Floating_Point_Type_2; + + ------------------------ + -- Check_Integer_Type -- + ------------------------ + + procedure Check_Integer_Type is + begin + Check_Type; + + if not Is_Integer_Type (P_Type) then + Error_Attr_P ("prefix of % attribute must be integer type"); + end if; + end Check_Integer_Type; + + ------------------------ + -- Check_Library_Unit -- + ------------------------ + + procedure Check_Library_Unit is + begin + if not Is_Compilation_Unit (Entity (P)) then + Error_Attr_P ("prefix of % attribute must be library unit"); + end if; + end Check_Library_Unit; + + -------------------------------- + -- Check_Modular_Integer_Type -- + -------------------------------- + + procedure Check_Modular_Integer_Type is + begin + Check_Type; + + if not Is_Modular_Integer_Type (P_Type) then + Error_Attr_P + ("prefix of % attribute must be modular integer type"); + end if; + end Check_Modular_Integer_Type; + + ------------------------ + -- Check_Not_CPP_Type -- + ------------------------ + + procedure Check_Not_CPP_Type is + begin + if Is_Tagged_Type (Etype (P)) + and then Convention (Etype (P)) = Convention_CPP + and then Is_CPP_Class (Root_Type (Etype (P))) + then + Error_Attr_P + ("invalid use of % attribute with 'C'P'P tagged type"); + end if; + end Check_Not_CPP_Type; + + ------------------------------- + -- Check_Not_Incomplete_Type -- + ------------------------------- + + procedure Check_Not_Incomplete_Type is + E : Entity_Id; + Typ : Entity_Id; + + begin + -- Ada 2005 (AI-50217, AI-326): If the prefix is an explicit + -- dereference we have to check wrong uses of incomplete types + -- (other wrong uses are checked at their freezing point). + + -- Example 1: Limited-with + + -- limited with Pkg; + -- package P is + -- type Acc is access Pkg.T; + -- X : Acc; + -- S : Integer := X.all'Size; -- ERROR + -- end P; + + -- Example 2: Tagged incomplete + + -- type T is tagged; + -- type Acc is access all T; + -- X : Acc; + -- S : constant Integer := X.all'Size; -- ERROR + -- procedure Q (Obj : Integer := X.all'Alignment); -- ERROR + + if Ada_Version >= Ada_2005 + and then Nkind (P) = N_Explicit_Dereference + then + E := P; + while Nkind (E) = N_Explicit_Dereference loop + E := Prefix (E); + end loop; + + Typ := Etype (E); + + if From_With_Type (Typ) then + Error_Attr_P + ("prefix of % attribute cannot be an incomplete type"); + + else + if Is_Access_Type (Typ) then + Typ := Directly_Designated_Type (Typ); + end if; + + if Is_Class_Wide_Type (Typ) then + Typ := Root_Type (Typ); + end if; + + -- A legal use of a shadow entity occurs only when the unit + -- where the non-limited view resides is imported via a regular + -- with clause in the current body. Such references to shadow + -- entities may occur in subprogram formals. + + if Is_Incomplete_Type (Typ) + and then From_With_Type (Typ) + and then Present (Non_Limited_View (Typ)) + and then Is_Legal_Shadow_Entity_In_Body (Typ) + then + Typ := Non_Limited_View (Typ); + end if; + + if Ekind (Typ) = E_Incomplete_Type + and then No (Full_View (Typ)) + then + Error_Attr_P + ("prefix of % attribute cannot be an incomplete type"); + end if; + end if; + end if; + + if not Is_Entity_Name (P) + or else not Is_Type (Entity (P)) + or else In_Spec_Expression + then + return; + else + Check_Fully_Declared (P_Type, P); + end if; + end Check_Not_Incomplete_Type; + + ---------------------------- + -- Check_Object_Reference -- + ---------------------------- + + procedure Check_Object_Reference (P : Node_Id) is + Rtyp : Entity_Id; + + begin + -- If we need an object, and we have a prefix that is the name of + -- a function entity, convert it into a function call. + + if Is_Entity_Name (P) + and then Ekind (Entity (P)) = E_Function + then + Rtyp := Etype (Entity (P)); + + Rewrite (P, + Make_Function_Call (Sloc (P), + Name => Relocate_Node (P))); + + Analyze_And_Resolve (P, Rtyp); + + -- Otherwise we must have an object reference + + elsif not Is_Object_Reference (P) then + Error_Attr_P ("prefix of % attribute must be object"); + end if; + end Check_Object_Reference; + + ---------------------------- + -- Check_PolyORB_Attribute -- + ---------------------------- + + procedure Check_PolyORB_Attribute is + begin + Validate_Non_Static_Attribute_Function_Call; + + Check_Type; + Check_Not_CPP_Type; + + if Get_PCS_Name /= Name_PolyORB_DSA then + Error_Attr + ("attribute% requires the 'Poly'O'R'B 'P'C'S", N); + end if; + end Check_PolyORB_Attribute; + + ------------------------ + -- Check_Program_Unit -- + ------------------------ + + procedure Check_Program_Unit is + begin + if Is_Entity_Name (P) then + declare + K : constant Entity_Kind := Ekind (Entity (P)); + T : constant Entity_Id := Etype (Entity (P)); + + begin + if K in Subprogram_Kind + or else K in Task_Kind + or else K in Protected_Kind + or else K = E_Package + or else K in Generic_Unit_Kind + or else (K = E_Variable + and then + (Is_Task_Type (T) + or else + Is_Protected_Type (T))) + then + return; + end if; + end; + end if; + + Error_Attr_P ("prefix of % attribute must be program unit"); + end Check_Program_Unit; + + --------------------- + -- Check_Real_Type -- + --------------------- + + procedure Check_Real_Type is + begin + Check_Type; + + if not Is_Real_Type (P_Type) then + Error_Attr_P ("prefix of % attribute must be real type"); + end if; + end Check_Real_Type; + + ----------------------- + -- Check_Scalar_Type -- + ----------------------- + + procedure Check_Scalar_Type is + begin + Check_Type; + + if not Is_Scalar_Type (P_Type) then + Error_Attr_P ("prefix of % attribute must be scalar type"); + end if; + end Check_Scalar_Type; + + --------------------------- + -- Check_Standard_Prefix -- + --------------------------- + + procedure Check_Standard_Prefix is + begin + Check_E0; + + if Nkind (P) /= N_Identifier + or else Chars (P) /= Name_Standard + then + Error_Attr ("only allowed prefix for % attribute is Standard", P); + end if; + end Check_Standard_Prefix; + + ---------------------------- + -- Check_Stream_Attribute -- + ---------------------------- + + procedure Check_Stream_Attribute (Nam : TSS_Name_Type) is + Etyp : Entity_Id; + Btyp : Entity_Id; + + In_Shared_Var_Procs : Boolean; + -- True when compiling the body of System.Shared_Storage. + -- Shared_Var_Procs. For this runtime package (always compiled in + -- GNAT mode), we allow stream attributes references for limited + -- types for the case where shared passive objects are implemented + -- using stream attributes, which is the default in GNAT's persistent + -- storage implementation. + + begin + Validate_Non_Static_Attribute_Function_Call; + + -- With the exception of 'Input, Stream attributes are procedures, + -- and can only appear at the position of procedure calls. We check + -- for this here, before they are rewritten, to give a more precise + -- diagnostic. + + if Nam = TSS_Stream_Input then + null; + + elsif Is_List_Member (N) + and then not Nkind_In (Parent (N), N_Procedure_Call_Statement, + N_Aggregate) + then + null; + + else + Error_Attr + ("invalid context for attribute%, which is a procedure", N); + end if; + + Check_Type; + Btyp := Implementation_Base_Type (P_Type); + + -- Stream attributes not allowed on limited types unless the + -- attribute reference was generated by the expander (in which + -- case the underlying type will be used, as described in Sinfo), + -- or the attribute was specified explicitly for the type itself + -- or one of its ancestors (taking visibility rules into account if + -- in Ada 2005 mode), or a pragma Stream_Convert applies to Btyp + -- (with no visibility restriction). + + declare + Gen_Body : constant Node_Id := Enclosing_Generic_Body (N); + begin + if Present (Gen_Body) then + In_Shared_Var_Procs := + Is_RTE (Corresponding_Spec (Gen_Body), RE_Shared_Var_Procs); + else + In_Shared_Var_Procs := False; + end if; + end; + + if (Comes_From_Source (N) + and then not (In_Shared_Var_Procs or In_Instance)) + and then not Stream_Attribute_Available (P_Type, Nam) + and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert) + then + Error_Msg_Name_1 := Aname; + + if Is_Limited_Type (P_Type) then + Error_Msg_NE + ("limited type& has no% attribute", P, P_Type); + Explain_Limited_Type (P_Type, P); + else + Error_Msg_NE + ("attribute% for type& is not available", P, P_Type); + end if; + end if; + + -- Check restriction violations + + -- First check the No_Streams restriction, which prohibits the use + -- of explicit stream attributes in the source program. We do not + -- prevent the occurrence of stream attributes in generated code, + -- for instance those generated implicitly for dispatching purposes. + + if Comes_From_Source (N) then + Check_Restriction (No_Streams, P); + end if; + + -- Check special case of Exception_Id and Exception_Occurrence which + -- are not allowed for restriction No_Exception_Registration. + + if Is_RTE (P_Type, RE_Exception_Id) + or else + Is_RTE (P_Type, RE_Exception_Occurrence) + then + Check_Restriction (No_Exception_Registration, P); + end if; + + -- Here we must check that the first argument is an access type + -- that is compatible with Ada.Streams.Root_Stream_Type'Class. + + Analyze_And_Resolve (E1); + Etyp := Etype (E1); + + -- Note: the double call to Root_Type here is needed because the + -- root type of a class-wide type is the corresponding type (e.g. + -- X for X'Class, and we really want to go to the root.) + + if not Is_Access_Type (Etyp) + or else Root_Type (Root_Type (Designated_Type (Etyp))) /= + RTE (RE_Root_Stream_Type) + then + Error_Attr + ("expected access to Ada.Streams.Root_Stream_Type''Class", E1); + end if; + + -- Check that the second argument is of the right type if there is + -- one (the Input attribute has only one argument so this is skipped) + + if Present (E2) then + Analyze (E2); + + if Nam = TSS_Stream_Read + and then not Is_OK_Variable_For_Out_Formal (E2) + then + Error_Attr + ("second argument of % attribute must be a variable", E2); + end if; + + Resolve (E2, P_Type); + end if; + + Check_Not_CPP_Type; + end Check_Stream_Attribute; + + ----------------------- + -- Check_Task_Prefix -- + ----------------------- + + procedure Check_Task_Prefix is + begin + Analyze (P); + + -- Ada 2005 (AI-345): Attribute 'Terminated can be applied to + -- task interface class-wide types. + + if Is_Task_Type (Etype (P)) + or else (Is_Access_Type (Etype (P)) + and then Is_Task_Type (Designated_Type (Etype (P)))) + or else (Ada_Version >= Ada_2005 + and then Ekind (Etype (P)) = E_Class_Wide_Type + and then Is_Interface (Etype (P)) + and then Is_Task_Interface (Etype (P))) + then + Resolve (P); + + else + if Ada_Version >= Ada_2005 then + Error_Attr_P + ("prefix of % attribute must be a task or a task " & + "interface class-wide object"); + + else + Error_Attr_P ("prefix of % attribute must be a task"); + end if; + end if; + end Check_Task_Prefix; + + ---------------- + -- Check_Type -- + ---------------- + + -- The possibilities are an entity name denoting a type, or an + -- attribute reference that denotes a type (Base or Class). If + -- the type is incomplete, replace it with its full view. + + procedure Check_Type is + begin + if not Is_Entity_Name (P) + or else not Is_Type (Entity (P)) + then + Error_Attr_P ("prefix of % attribute must be a type"); + + elsif Is_Protected_Self_Reference (P) then + Error_Attr_P + ("prefix of % attribute denotes current instance " + & "(RM 9.4(21/2))"); + + elsif Ekind (Entity (P)) = E_Incomplete_Type + and then Present (Full_View (Entity (P))) + then + P_Type := Full_View (Entity (P)); + Set_Entity (P, P_Type); + end if; + end Check_Type; + + --------------------- + -- Check_Unit_Name -- + --------------------- + + procedure Check_Unit_Name (Nod : Node_Id) is + begin + if Nkind (Nod) = N_Identifier then + return; + + elsif Nkind (Nod) = N_Selected_Component then + Check_Unit_Name (Prefix (Nod)); + + if Nkind (Selector_Name (Nod)) = N_Identifier then + return; + end if; + end if; + + Error_Attr ("argument for % attribute must be unit name", P); + end Check_Unit_Name; + + ---------------- + -- Error_Attr -- + ---------------- + + procedure Error_Attr is + begin + Set_Etype (N, Any_Type); + Set_Entity (N, Any_Type); + raise Bad_Attribute; + end Error_Attr; + + procedure Error_Attr (Msg : String; Error_Node : Node_Id) is + begin + Error_Msg_Name_1 := Aname; + Error_Msg_N (Msg, Error_Node); + Error_Attr; + end Error_Attr; + + ------------------ + -- Error_Attr_P -- + ------------------ + + procedure Error_Attr_P (Msg : String) is + begin + Error_Msg_Name_1 := Aname; + Error_Msg_F (Msg, P); + Error_Attr; + end Error_Attr_P; + + ---------------------------- + -- Legal_Formal_Attribute -- + ---------------------------- + + procedure Legal_Formal_Attribute is + begin + Check_E0; + + if not Is_Entity_Name (P) + or else not Is_Type (Entity (P)) + then + Error_Attr_P ("prefix of % attribute must be generic type"); + + elsif Is_Generic_Actual_Type (Entity (P)) + or else In_Instance + or else In_Inlined_Body + then + null; + + elsif Is_Generic_Type (Entity (P)) then + if not Is_Indefinite_Subtype (Entity (P)) then + Error_Attr_P + ("prefix of % attribute must be indefinite generic type"); + end if; + + else + Error_Attr_P + ("prefix of % attribute must be indefinite generic type"); + end if; + + Set_Etype (N, Standard_Boolean); + end Legal_Formal_Attribute; + + ------------------------ + -- Standard_Attribute -- + ------------------------ + + procedure Standard_Attribute (Val : Int) is + begin + Check_Standard_Prefix; + Rewrite (N, Make_Integer_Literal (Loc, Val)); + Analyze (N); + end Standard_Attribute; + + ------------------------- + -- Unexpected Argument -- + ------------------------- + + procedure Unexpected_Argument (En : Node_Id) is + begin + Error_Attr ("unexpected argument for % attribute", En); + end Unexpected_Argument; + + ------------------------------------------------- + -- Validate_Non_Static_Attribute_Function_Call -- + ------------------------------------------------- + + -- This function should be moved to Sem_Dist ??? + + procedure Validate_Non_Static_Attribute_Function_Call is + begin + if In_Preelaborated_Unit + and then not In_Subprogram_Or_Concurrent_Unit + then + Flag_Non_Static_Expr + ("non-static function call in preelaborated unit!", N); + end if; + end Validate_Non_Static_Attribute_Function_Call; + + ----------------------------------------------- + -- Start of Processing for Analyze_Attribute -- + ----------------------------------------------- + + begin + -- Immediate return if unrecognized attribute (already diagnosed + -- by parser, so there is nothing more that we need to do) + + if not Is_Attribute_Name (Aname) then + raise Bad_Attribute; + end if; + + -- Deal with Ada 83 issues + + if Comes_From_Source (N) then + if not Attribute_83 (Attr_Id) then + if Ada_Version = Ada_83 and then Comes_From_Source (N) then + Error_Msg_Name_1 := Aname; + Error_Msg_N ("(Ada 83) attribute% is not standard?", N); + end if; + + if Attribute_Impl_Def (Attr_Id) then + Check_Restriction (No_Implementation_Attributes, N); + end if; + end if; + end if; + + -- Deal with Ada 2005 issues + + if Attribute_05 (Attr_Id) and then Ada_Version <= Ada_95 then + Check_Restriction (No_Implementation_Attributes, N); + end if; + + -- Remote access to subprogram type access attribute reference needs + -- unanalyzed copy for tree transformation. The analyzed copy is used + -- for its semantic information (whether prefix is a remote subprogram + -- name), the unanalyzed copy is used to construct new subtree rooted + -- with N_Aggregate which represents a fat pointer aggregate. + + if Aname = Name_Access then + Discard_Node (Copy_Separate_Tree (N)); + end if; + + -- Analyze prefix and exit if error in analysis. If the prefix is an + -- incomplete type, use full view if available. Note that there are + -- some attributes for which we do not analyze the prefix, since the + -- prefix is not a normal name. + + if Aname /= Name_Elab_Body + and then + Aname /= Name_Elab_Spec + and then + Aname /= Name_UET_Address + and then + Aname /= Name_Enabled + then + Analyze (P); + P_Type := Etype (P); + + if Is_Entity_Name (P) + and then Present (Entity (P)) + and then Is_Type (Entity (P)) + then + if Ekind (Entity (P)) = E_Incomplete_Type then + P_Type := Get_Full_View (P_Type); + Set_Entity (P, P_Type); + Set_Etype (P, P_Type); + + elsif Entity (P) = Current_Scope + and then Is_Record_Type (Entity (P)) + then + -- Use of current instance within the type. Verify that if the + -- attribute appears within a constraint, it yields an access + -- type, other uses are illegal. + + declare + Par : Node_Id; + + begin + Par := Parent (N); + while Present (Par) + and then Nkind (Parent (Par)) /= N_Component_Definition + loop + Par := Parent (Par); + end loop; + + if Present (Par) + and then Nkind (Par) = N_Subtype_Indication + then + if Attr_Id /= Attribute_Access + and then Attr_Id /= Attribute_Unchecked_Access + and then Attr_Id /= Attribute_Unrestricted_Access + then + Error_Msg_N + ("in a constraint the current instance can only" + & " be used with an access attribute", N); + end if; + end if; + end; + end if; + end if; + + if P_Type = Any_Type then + raise Bad_Attribute; + end if; + + P_Base_Type := Base_Type (P_Type); + end if; + + -- Analyze expressions that may be present, exiting if an error occurs + + if No (Exprs) then + E1 := Empty; + E2 := Empty; + + else + E1 := First (Exprs); + Analyze (E1); + + -- Check for missing/bad expression (result of previous error) + + if No (E1) or else Etype (E1) = Any_Type then + raise Bad_Attribute; + end if; + + E2 := Next (E1); + + if Present (E2) then + Analyze (E2); + + if Etype (E2) = Any_Type then + raise Bad_Attribute; + end if; + + if Present (Next (E2)) then + Unexpected_Argument (Next (E2)); + end if; + end if; + end if; + + -- Ada 2005 (AI-345): Ensure that the compiler gives exactly the current + -- output compiling in Ada 95 mode for the case of ambiguous prefixes. + + if Ada_Version < Ada_2005 + and then Is_Overloaded (P) + and then Aname /= Name_Access + and then Aname /= Name_Address + and then Aname /= Name_Code_Address + and then Aname /= Name_Count + and then Aname /= Name_Result + and then Aname /= Name_Unchecked_Access + then + Error_Attr ("ambiguous prefix for % attribute", P); + + elsif Ada_Version >= Ada_2005 + and then Is_Overloaded (P) + and then Aname /= Name_Access + and then Aname /= Name_Address + and then Aname /= Name_Code_Address + and then Aname /= Name_Result + and then Aname /= Name_Unchecked_Access + then + -- Ada 2005 (AI-345): Since protected and task types have primitive + -- entry wrappers, the attributes Count, Caller and AST_Entry require + -- a context check + + if Ada_Version >= Ada_2005 + and then (Aname = Name_Count + or else Aname = Name_Caller + or else Aname = Name_AST_Entry) + then + declare + Count : Natural := 0; + I : Interp_Index; + It : Interp; + + begin + Get_First_Interp (P, I, It); + while Present (It.Nam) loop + if Comes_From_Source (It.Nam) then + Count := Count + 1; + else + Remove_Interp (I); + end if; + + Get_Next_Interp (I, It); + end loop; + + if Count > 1 then + Error_Attr ("ambiguous prefix for % attribute", P); + else + Set_Is_Overloaded (P, False); + end if; + end; + + else + Error_Attr ("ambiguous prefix for % attribute", P); + end if; + end if; + + -- Remaining processing depends on attribute + + case Attr_Id is + + ------------------ + -- Abort_Signal -- + ------------------ + + when Attribute_Abort_Signal => + Check_Standard_Prefix; + Rewrite (N, + New_Reference_To (Stand.Abort_Signal, Loc)); + Analyze (N); + + ------------ + -- Access -- + ------------ + + when Attribute_Access => + Analyze_Access_Attribute; + + ------------- + -- Address -- + ------------- + + when Attribute_Address => + Check_E0; + + -- Check for some junk cases, where we have to allow the address + -- attribute but it does not make much sense, so at least for now + -- just replace with Null_Address. + + -- We also do this if the prefix is a reference to the AST_Entry + -- attribute. If expansion is active, the attribute will be + -- replaced by a function call, and address will work fine and + -- get the proper value, but if expansion is not active, then + -- the check here allows proper semantic analysis of the reference. + + -- An Address attribute created by expansion is legal even when it + -- applies to other entity-denoting expressions. + + if Is_Protected_Self_Reference (P) then + + -- Address attribute on a protected object self reference is legal + + null; + + elsif Is_Entity_Name (P) then + declare + Ent : constant Entity_Id := Entity (P); + + begin + if Is_Subprogram (Ent) then + Set_Address_Taken (Ent); + Kill_Current_Values (Ent); + + -- An Address attribute is accepted when generated by the + -- compiler for dispatching operation, and an error is + -- issued once the subprogram is frozen (to avoid confusing + -- errors about implicit uses of Address in the dispatch + -- table initialization). + + if Has_Pragma_Inline_Always (Entity (P)) + and then Comes_From_Source (P) + then + Error_Attr_P + ("prefix of % attribute cannot be Inline_Always" & + " subprogram"); + + -- It is illegal to apply 'Address to an intrinsic + -- subprogram. This is now formalized in AI05-0095. + -- In an instance, an attempt to obtain 'Address of an + -- intrinsic subprogram (e.g the renaming of a predefined + -- operator that is an actual) raises Program_Error. + + elsif Convention (Ent) = Convention_Intrinsic then + if In_Instance then + Rewrite (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Address_Of_Intrinsic)); + + else + Error_Msg_N + ("cannot take Address of intrinsic subprogram", N); + end if; + + -- Issue an error if prefix denotes an eliminated subprogram + + else + Check_For_Eliminated_Subprogram (P, Ent); + end if; + + elsif Is_Object (Ent) + or else Ekind (Ent) = E_Label + then + Set_Address_Taken (Ent); + + -- If we have an address of an object, and the attribute + -- comes from source, then set the object as potentially + -- source modified. We do this because the resulting address + -- can potentially be used to modify the variable and we + -- might not detect this, leading to some junk warnings. + + Set_Never_Set_In_Source (Ent, False); + + elsif (Is_Concurrent_Type (Etype (Ent)) + and then Etype (Ent) = Base_Type (Ent)) + or else Ekind (Ent) = E_Package + or else Is_Generic_Unit (Ent) + then + Rewrite (N, + New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N))); + + else + Error_Attr ("invalid prefix for % attribute", P); + end if; + end; + + elsif Nkind (P) = N_Attribute_Reference + and then Attribute_Name (P) = Name_AST_Entry + then + Rewrite (N, + New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N))); + + elsif Is_Object_Reference (P) then + null; + + elsif Nkind (P) = N_Selected_Component + and then Is_Subprogram (Entity (Selector_Name (P))) + then + null; + + -- What exactly are we allowing here ??? and is this properly + -- documented in the sinfo documentation for this node ??? + + elsif not Comes_From_Source (N) then + null; + + else + Error_Attr ("invalid prefix for % attribute", P); + end if; + + Set_Etype (N, RTE (RE_Address)); + + ------------------ + -- Address_Size -- + ------------------ + + when Attribute_Address_Size => + Standard_Attribute (System_Address_Size); + + -------------- + -- Adjacent -- + -------------- + + when Attribute_Adjacent => + Check_Floating_Point_Type_2; + Set_Etype (N, P_Base_Type); + Resolve (E1, P_Base_Type); + Resolve (E2, P_Base_Type); + + --------- + -- Aft -- + --------- + + when Attribute_Aft => + Check_Fixed_Point_Type_0; + Set_Etype (N, Universal_Integer); + + --------------- + -- Alignment -- + --------------- + + when Attribute_Alignment => + + -- Don't we need more checking here, cf Size ??? + + Check_E0; + Check_Not_Incomplete_Type; + Check_Not_CPP_Type; + Set_Etype (N, Universal_Integer); + + --------------- + -- Asm_Input -- + --------------- + + when Attribute_Asm_Input => + Check_Asm_Attribute; + Set_Etype (N, RTE (RE_Asm_Input_Operand)); + + ---------------- + -- Asm_Output -- + ---------------- + + when Attribute_Asm_Output => + Check_Asm_Attribute; + + if Etype (E2) = Any_Type then + return; + + elsif Aname = Name_Asm_Output then + if not Is_Variable (E2) then + Error_Attr + ("second argument for Asm_Output is not variable", E2); + end if; + end if; + + Note_Possible_Modification (E2, Sure => True); + Set_Etype (N, RTE (RE_Asm_Output_Operand)); + + --------------- + -- AST_Entry -- + --------------- + + when Attribute_AST_Entry => AST_Entry : declare + Ent : Entity_Id; + Pref : Node_Id; + Ptyp : Entity_Id; + + Indexed : Boolean; + -- Indicates if entry family index is present. Note the coding + -- here handles the entry family case, but in fact it cannot be + -- executed currently, because pragma AST_Entry does not permit + -- the specification of an entry family. + + procedure Bad_AST_Entry; + -- Signal a bad AST_Entry pragma + + function OK_Entry (E : Entity_Id) return Boolean; + -- Checks that E is of an appropriate entity kind for an entry + -- (i.e. E_Entry if Index is False, or E_Entry_Family if Index + -- is set True for the entry family case). In the True case, + -- makes sure that Is_AST_Entry is set on the entry. + + ------------------- + -- Bad_AST_Entry -- + ------------------- + + procedure Bad_AST_Entry is + begin + Error_Attr_P ("prefix for % attribute must be task entry"); + end Bad_AST_Entry; + + -------------- + -- OK_Entry -- + -------------- + + function OK_Entry (E : Entity_Id) return Boolean is + Result : Boolean; + + begin + if Indexed then + Result := (Ekind (E) = E_Entry_Family); + else + Result := (Ekind (E) = E_Entry); + end if; + + if Result then + if not Is_AST_Entry (E) then + Error_Msg_Name_2 := Aname; + Error_Attr ("% attribute requires previous % pragma", P); + end if; + end if; + + return Result; + end OK_Entry; + + -- Start of processing for AST_Entry + + begin + Check_VMS (N); + Check_E0; + + -- Deal with entry family case + + if Nkind (P) = N_Indexed_Component then + Pref := Prefix (P); + Indexed := True; + else + Pref := P; + Indexed := False; + end if; + + Ptyp := Etype (Pref); + + if Ptyp = Any_Type or else Error_Posted (Pref) then + return; + end if; + + -- If the prefix is a selected component whose prefix is of an + -- access type, then introduce an explicit dereference. + -- ??? Could we reuse Check_Dereference here? + + if Nkind (Pref) = N_Selected_Component + and then Is_Access_Type (Ptyp) + then + Rewrite (Pref, + Make_Explicit_Dereference (Sloc (Pref), + Relocate_Node (Pref))); + Analyze_And_Resolve (Pref, Designated_Type (Ptyp)); + end if; + + -- Prefix can be of the form a.b, where a is a task object + -- and b is one of the entries of the corresponding task type. + + if Nkind (Pref) = N_Selected_Component + and then OK_Entry (Entity (Selector_Name (Pref))) + and then Is_Object_Reference (Prefix (Pref)) + and then Is_Task_Type (Etype (Prefix (Pref))) + then + null; + + -- Otherwise the prefix must be an entry of a containing task, + -- or of a variable of the enclosing task type. + + else + if Nkind_In (Pref, N_Identifier, N_Expanded_Name) then + Ent := Entity (Pref); + + if not OK_Entry (Ent) + or else not In_Open_Scopes (Scope (Ent)) + then + Bad_AST_Entry; + end if; + + else + Bad_AST_Entry; + end if; + end if; + + Set_Etype (N, RTE (RE_AST_Handler)); + end AST_Entry; + + ---------- + -- Base -- + ---------- + + -- Note: when the base attribute appears in the context of a subtype + -- mark, the analysis is done by Sem_Ch8.Find_Type, rather than by + -- the following circuit. + + when Attribute_Base => Base : declare + Typ : Entity_Id; + + begin + Check_E0; + Find_Type (P); + Typ := Entity (P); + + if Ada_Version >= Ada_95 + and then not Is_Scalar_Type (Typ) + and then not Is_Generic_Type (Typ) + then + Error_Attr_P ("prefix of Base attribute must be scalar type"); + + elsif Sloc (Typ) = Standard_Location + and then Base_Type (Typ) = Typ + and then Warn_On_Redundant_Constructs + then + Error_Msg_NE -- CODEFIX + ("?redundant attribute, & is its own base type", N, Typ); + end if; + + Set_Etype (N, Base_Type (Entity (P))); + Set_Entity (N, Base_Type (Entity (P))); + Rewrite (N, New_Reference_To (Entity (N), Loc)); + Analyze (N); + end Base; + + --------- + -- Bit -- + --------- + + when Attribute_Bit => Bit : + begin + Check_E0; + + if not Is_Object_Reference (P) then + Error_Attr_P ("prefix for % attribute must be object"); + + -- What about the access object cases ??? + + else + null; + end if; + + Set_Etype (N, Universal_Integer); + end Bit; + + --------------- + -- Bit_Order -- + --------------- + + when Attribute_Bit_Order => Bit_Order : + begin + Check_E0; + Check_Type; + + if not Is_Record_Type (P_Type) then + Error_Attr_P ("prefix of % attribute must be record type"); + end if; + + if Bytes_Big_Endian xor Reverse_Bit_Order (P_Type) then + Rewrite (N, + New_Occurrence_Of (RTE (RE_High_Order_First), Loc)); + else + Rewrite (N, + New_Occurrence_Of (RTE (RE_Low_Order_First), Loc)); + end if; + + Set_Etype (N, RTE (RE_Bit_Order)); + Resolve (N); + + -- Reset incorrect indication of staticness + + Set_Is_Static_Expression (N, False); + end Bit_Order; + + ------------------ + -- Bit_Position -- + ------------------ + + -- Note: in generated code, we can have a Bit_Position attribute + -- applied to a (naked) record component (i.e. the prefix is an + -- identifier that references an E_Component or E_Discriminant + -- entity directly, and this is interpreted as expected by Gigi. + -- The following code will not tolerate such usage, but when the + -- expander creates this special case, it marks it as analyzed + -- immediately and sets an appropriate type. + + when Attribute_Bit_Position => + if Comes_From_Source (N) then + Check_Component; + end if; + + Set_Etype (N, Universal_Integer); + + ------------------ + -- Body_Version -- + ------------------ + + when Attribute_Body_Version => + Check_E0; + Check_Program_Unit; + Set_Etype (N, RTE (RE_Version_String)); + + -------------- + -- Callable -- + -------------- + + when Attribute_Callable => + Check_E0; + Set_Etype (N, Standard_Boolean); + Check_Task_Prefix; + + ------------ + -- Caller -- + ------------ + + when Attribute_Caller => Caller : declare + Ent : Entity_Id; + S : Entity_Id; + + begin + Check_E0; + + if Nkind_In (P, N_Identifier, N_Expanded_Name) then + Ent := Entity (P); + + if not Is_Entry (Ent) then + Error_Attr ("invalid entry name", N); + end if; + + else + Error_Attr ("invalid entry name", N); + return; + end if; + + for J in reverse 0 .. Scope_Stack.Last loop + S := Scope_Stack.Table (J).Entity; + + if S = Scope (Ent) then + Error_Attr ("Caller must appear in matching accept or body", N); + elsif S = Ent then + exit; + end if; + end loop; + + Set_Etype (N, RTE (RO_AT_Task_Id)); + end Caller; + + ------------- + -- Ceiling -- + ------------- + + when Attribute_Ceiling => + Check_Floating_Point_Type_1; + Set_Etype (N, P_Base_Type); + Resolve (E1, P_Base_Type); + + ----------- + -- Class -- + ----------- + + when Attribute_Class => + Check_Restriction (No_Dispatch, N); + Check_E0; + Find_Type (N); + + -- Applying Class to untagged incomplete type is obsolescent in Ada + -- 2005. Note that we can't test Is_Tagged_Type here on P_Type, since + -- this flag gets set by Find_Type in this situation. + + if Restriction_Check_Required (No_Obsolescent_Features) + and then Ada_Version >= Ada_2005 + and then Ekind (P_Type) = E_Incomplete_Type + then + declare + DN : constant Node_Id := Declaration_Node (P_Type); + begin + if Nkind (DN) = N_Incomplete_Type_Declaration + and then not Tagged_Present (DN) + then + Check_Restriction (No_Obsolescent_Features, P); + end if; + end; + end if; + + ------------------ + -- Code_Address -- + ------------------ + + when Attribute_Code_Address => + Check_E0; + + if Nkind (P) = N_Attribute_Reference + and then (Attribute_Name (P) = Name_Elab_Body + or else + Attribute_Name (P) = Name_Elab_Spec) + then + null; + + elsif not Is_Entity_Name (P) + or else (Ekind (Entity (P)) /= E_Function + and then + Ekind (Entity (P)) /= E_Procedure) + then + Error_Attr ("invalid prefix for % attribute", P); + Set_Address_Taken (Entity (P)); + + -- Issue an error if the prefix denotes an eliminated subprogram + + else + Check_For_Eliminated_Subprogram (P, Entity (P)); + end if; + + Set_Etype (N, RTE (RE_Address)); + + ---------------------- + -- Compiler_Version -- + ---------------------- + + when Attribute_Compiler_Version => + Check_E0; + Check_Standard_Prefix; + Rewrite (N, Make_String_Literal (Loc, "GNAT " & Gnat_Version_String)); + Analyze_And_Resolve (N, Standard_String); + + -------------------- + -- Component_Size -- + -------------------- + + when Attribute_Component_Size => + Check_E0; + Set_Etype (N, Universal_Integer); + + -- Note: unlike other array attributes, unconstrained arrays are OK + + if Is_Array_Type (P_Type) and then not Is_Constrained (P_Type) then + null; + else + Check_Array_Type; + end if; + + ------------- + -- Compose -- + ------------- + + when Attribute_Compose => + Check_Floating_Point_Type_2; + Set_Etype (N, P_Base_Type); + Resolve (E1, P_Base_Type); + Resolve (E2, Any_Integer); + + ----------------- + -- Constrained -- + ----------------- + + when Attribute_Constrained => + Check_E0; + Set_Etype (N, Standard_Boolean); + + -- Case from RM J.4(2) of constrained applied to private type + + if Is_Entity_Name (P) and then Is_Type (Entity (P)) then + Check_Restriction (No_Obsolescent_Features, P); + + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("constrained for private type is an " & + "obsolescent feature (RM J.4)?", N); + end if; + + -- If we are within an instance, the attribute must be legal + -- because it was valid in the generic unit. Ditto if this is + -- an inlining of a function declared in an instance. + + if In_Instance + or else In_Inlined_Body + then + return; + + -- For sure OK if we have a real private type itself, but must + -- be completed, cannot apply Constrained to incomplete type. + + elsif Is_Private_Type (Entity (P)) then + + -- Note: this is one of the Annex J features that does not + -- generate a warning from -gnatwj, since in fact it seems + -- very useful, and is used in the GNAT runtime. + + Check_Not_Incomplete_Type; + return; + end if; + + -- Normal (non-obsolescent case) of application to object of + -- a discriminated type. + + else + Check_Object_Reference (P); + + -- If N does not come from source, then we allow the + -- the attribute prefix to be of a private type whose + -- full type has discriminants. This occurs in cases + -- involving expanded calls to stream attributes. + + if not Comes_From_Source (N) then + P_Type := Underlying_Type (P_Type); + end if; + + -- Must have discriminants or be an access type designating + -- a type with discriminants. If it is a classwide type is ??? + -- has unknown discriminants. + + if Has_Discriminants (P_Type) + or else Has_Unknown_Discriminants (P_Type) + or else + (Is_Access_Type (P_Type) + and then Has_Discriminants (Designated_Type (P_Type))) + then + return; + + -- Also allow an object of a generic type if extensions allowed + -- and allow this for any type at all. + + elsif (Is_Generic_Type (P_Type) + or else Is_Generic_Actual_Type (P_Type)) + and then Extensions_Allowed + then + return; + end if; + end if; + + -- Fall through if bad prefix + + Error_Attr_P + ("prefix of % attribute must be object of discriminated type"); + + --------------- + -- Copy_Sign -- + --------------- + + when Attribute_Copy_Sign => + Check_Floating_Point_Type_2; + Set_Etype (N, P_Base_Type); + Resolve (E1, P_Base_Type); + Resolve (E2, P_Base_Type); + + ----------- + -- Count -- + ----------- + + when Attribute_Count => Count : + declare + Ent : Entity_Id; + S : Entity_Id; + Tsk : Entity_Id; + + begin + Check_E0; + + if Nkind_In (P, N_Identifier, N_Expanded_Name) then + Ent := Entity (P); + + if Ekind (Ent) /= E_Entry then + Error_Attr ("invalid entry name", N); + end if; + + elsif Nkind (P) = N_Indexed_Component then + if not Is_Entity_Name (Prefix (P)) + or else No (Entity (Prefix (P))) + or else Ekind (Entity (Prefix (P))) /= E_Entry_Family + then + if Nkind (Prefix (P)) = N_Selected_Component + and then Present (Entity (Selector_Name (Prefix (P)))) + and then Ekind (Entity (Selector_Name (Prefix (P)))) = + E_Entry_Family + then + Error_Attr + ("attribute % must apply to entry of current task", P); + + else + Error_Attr ("invalid entry family name", P); + end if; + return; + + else + Ent := Entity (Prefix (P)); + end if; + + elsif Nkind (P) = N_Selected_Component + and then Present (Entity (Selector_Name (P))) + and then Ekind (Entity (Selector_Name (P))) = E_Entry + then + Error_Attr + ("attribute % must apply to entry of current task", P); + + else + Error_Attr ("invalid entry name", N); + return; + end if; + + for J in reverse 0 .. Scope_Stack.Last loop + S := Scope_Stack.Table (J).Entity; + + if S = Scope (Ent) then + if Nkind (P) = N_Expanded_Name then + Tsk := Entity (Prefix (P)); + + -- The prefix denotes either the task type, or else a + -- single task whose task type is being analyzed. + + if (Is_Type (Tsk) + and then Tsk = S) + + or else (not Is_Type (Tsk) + and then Etype (Tsk) = S + and then not (Comes_From_Source (S))) + then + null; + else + Error_Attr + ("Attribute % must apply to entry of current task", N); + end if; + end if; + + exit; + + elsif Ekind (Scope (Ent)) in Task_Kind + and then + not Ekind_In (S, E_Loop, E_Block, E_Entry, E_Entry_Family) + then + Error_Attr ("Attribute % cannot appear in inner unit", N); + + elsif Ekind (Scope (Ent)) = E_Protected_Type + and then not Has_Completion (Scope (Ent)) + then + Error_Attr ("attribute % can only be used inside body", N); + end if; + end loop; + + if Is_Overloaded (P) then + declare + Index : Interp_Index; + It : Interp; + + begin + Get_First_Interp (P, Index, It); + + while Present (It.Nam) loop + if It.Nam = Ent then + null; + + -- Ada 2005 (AI-345): Do not consider primitive entry + -- wrappers generated for task or protected types. + + elsif Ada_Version >= Ada_2005 + and then not Comes_From_Source (It.Nam) + then + null; + + else + Error_Attr ("ambiguous entry name", N); + end if; + + Get_Next_Interp (Index, It); + end loop; + end; + end if; + + Set_Etype (N, Universal_Integer); + end Count; + + ----------------------- + -- Default_Bit_Order -- + ----------------------- + + when Attribute_Default_Bit_Order => Default_Bit_Order : + begin + Check_Standard_Prefix; + + if Bytes_Big_Endian then + Rewrite (N, + Make_Integer_Literal (Loc, False_Value)); + else + Rewrite (N, + Make_Integer_Literal (Loc, True_Value)); + end if; + + Set_Etype (N, Universal_Integer); + Set_Is_Static_Expression (N); + end Default_Bit_Order; + + -------------- + -- Definite -- + -------------- + + when Attribute_Definite => + Legal_Formal_Attribute; + + ----------- + -- Delta -- + ----------- + + when Attribute_Delta => + Check_Fixed_Point_Type_0; + Set_Etype (N, Universal_Real); + + ------------ + -- Denorm -- + ------------ + + when Attribute_Denorm => + Check_Floating_Point_Type_0; + Set_Etype (N, Standard_Boolean); + + ------------ + -- Digits -- + ------------ + + when Attribute_Digits => + Check_E0; + Check_Type; + + if not Is_Floating_Point_Type (P_Type) + and then not Is_Decimal_Fixed_Point_Type (P_Type) + then + Error_Attr_P + ("prefix of % attribute must be float or decimal type"); + end if; + + Set_Etype (N, Universal_Integer); + + --------------- + -- Elab_Body -- + --------------- + + -- Also handles processing for Elab_Spec + + when Attribute_Elab_Body | Attribute_Elab_Spec => + Check_E0; + Check_Unit_Name (P); + Set_Etype (N, Standard_Void_Type); + + -- We have to manually call the expander in this case to get + -- the necessary expansion (normally attributes that return + -- entities are not expanded). + + Expand (N); + + --------------- + -- Elab_Spec -- + --------------- + + -- Shares processing with Elab_Body + + ---------------- + -- Elaborated -- + ---------------- + + when Attribute_Elaborated => + Check_E0; + Check_Library_Unit; + Set_Etype (N, Standard_Boolean); + + ---------- + -- Emax -- + ---------- + + when Attribute_Emax => + Check_Floating_Point_Type_0; + Set_Etype (N, Universal_Integer); + + ------------- + -- Enabled -- + ------------- + + when Attribute_Enabled => + Check_Either_E0_Or_E1; + + if Present (E1) then + if not Is_Entity_Name (E1) or else No (Entity (E1)) then + Error_Msg_N ("entity name expected for Enabled attribute", E1); + E1 := Empty; + end if; + end if; + + if Nkind (P) /= N_Identifier then + Error_Msg_N ("identifier expected (check name)", P); + elsif Get_Check_Id (Chars (P)) = No_Check_Id then + Error_Msg_N ("& is not a recognized check name", P); + end if; + + Set_Etype (N, Standard_Boolean); + + -------------- + -- Enum_Rep -- + -------------- + + when Attribute_Enum_Rep => Enum_Rep : declare + begin + if Present (E1) then + Check_E1; + Check_Discrete_Type; + Resolve (E1, P_Base_Type); + + else + if not Is_Entity_Name (P) + or else (not Is_Object (Entity (P)) + and then + Ekind (Entity (P)) /= E_Enumeration_Literal) + then + Error_Attr_P + ("prefix of % attribute must be " & + "discrete type/object or enum literal"); + end if; + end if; + + Set_Etype (N, Universal_Integer); + end Enum_Rep; + + -------------- + -- Enum_Val -- + -------------- + + when Attribute_Enum_Val => Enum_Val : begin + Check_E1; + Check_Type; + + if not Is_Enumeration_Type (P_Type) then + Error_Attr_P ("prefix of % attribute must be enumeration type"); + end if; + + -- If the enumeration type has a standard representation, the effect + -- is the same as 'Val, so rewrite the attribute as a 'Val. + + if not Has_Non_Standard_Rep (P_Base_Type) then + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Prefix (N)), + Attribute_Name => Name_Val, + Expressions => New_List (Relocate_Node (E1)))); + Analyze_And_Resolve (N, P_Base_Type); + + -- Non-standard representation case (enumeration with holes) + + else + Check_Enum_Image; + Resolve (E1, Any_Integer); + Set_Etype (N, P_Base_Type); + end if; + end Enum_Val; + + ------------- + -- Epsilon -- + ------------- + + when Attribute_Epsilon => + Check_Floating_Point_Type_0; + Set_Etype (N, Universal_Real); + + -------------- + -- Exponent -- + -------------- + + when Attribute_Exponent => + Check_Floating_Point_Type_1; + Set_Etype (N, Universal_Integer); + Resolve (E1, P_Base_Type); + + ------------------ + -- External_Tag -- + ------------------ + + when Attribute_External_Tag => + Check_E0; + Check_Type; + + Set_Etype (N, Standard_String); + + if not Is_Tagged_Type (P_Type) then + Error_Attr_P ("prefix of % attribute must be tagged"); + end if; + + --------------- + -- Fast_Math -- + --------------- + + when Attribute_Fast_Math => + Check_Standard_Prefix; + + if Opt.Fast_Math then + Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); + else + Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); + end if; + + ----------- + -- First -- + ----------- + + when Attribute_First => + Check_Array_Or_Scalar_Type; + Bad_Attribute_For_Predicate; + + --------------- + -- First_Bit -- + --------------- + + when Attribute_First_Bit => + Check_Component; + Set_Etype (N, Universal_Integer); + + ----------------- + -- Fixed_Value -- + ----------------- + + when Attribute_Fixed_Value => + Check_E1; + Check_Fixed_Point_Type; + Resolve (E1, Any_Integer); + Set_Etype (N, P_Base_Type); + + ----------- + -- Floor -- + ----------- + + when Attribute_Floor => + Check_Floating_Point_Type_1; + Set_Etype (N, P_Base_Type); + Resolve (E1, P_Base_Type); + + ---------- + -- Fore -- + ---------- + + when Attribute_Fore => + Check_Fixed_Point_Type_0; + Set_Etype (N, Universal_Integer); + + -------------- + -- Fraction -- + -------------- + + when Attribute_Fraction => + Check_Floating_Point_Type_1; + Set_Etype (N, P_Base_Type); + Resolve (E1, P_Base_Type); + + -------------- + -- From_Any -- + -------------- + + when Attribute_From_Any => + Check_E1; + Check_PolyORB_Attribute; + Set_Etype (N, P_Base_Type); + + ----------------------- + -- Has_Access_Values -- + ----------------------- + + when Attribute_Has_Access_Values => + Check_Type; + Check_E0; + Set_Etype (N, Standard_Boolean); + + ----------------------- + -- Has_Tagged_Values -- + ----------------------- + + when Attribute_Has_Tagged_Values => + Check_Type; + Check_E0; + Set_Etype (N, Standard_Boolean); + + ----------------------- + -- Has_Discriminants -- + ----------------------- + + when Attribute_Has_Discriminants => + Legal_Formal_Attribute; + + -------------- + -- Identity -- + -------------- + + when Attribute_Identity => + Check_E0; + Analyze (P); + + if Etype (P) = Standard_Exception_Type then + Set_Etype (N, RTE (RE_Exception_Id)); + + -- Ada 2005 (AI-345): Attribute 'Identity may be applied to + -- task interface class-wide types. + + elsif Is_Task_Type (Etype (P)) + or else (Is_Access_Type (Etype (P)) + and then Is_Task_Type (Designated_Type (Etype (P)))) + or else (Ada_Version >= Ada_2005 + and then Ekind (Etype (P)) = E_Class_Wide_Type + and then Is_Interface (Etype (P)) + and then Is_Task_Interface (Etype (P))) + then + Resolve (P); + Set_Etype (N, RTE (RO_AT_Task_Id)); + + else + if Ada_Version >= Ada_2005 then + Error_Attr_P + ("prefix of % attribute must be an exception, a " & + "task or a task interface class-wide object"); + else + Error_Attr_P + ("prefix of % attribute must be a task or an exception"); + end if; + end if; + + ----------- + -- Image -- + ----------- + + when Attribute_Image => Image : + begin + Set_Etype (N, Standard_String); + Check_Scalar_Type; + + if Is_Real_Type (P_Type) then + if Ada_Version = Ada_83 and then Comes_From_Source (N) then + Error_Msg_Name_1 := Aname; + Error_Msg_N + ("(Ada 83) % attribute not allowed for real types", N); + end if; + end if; + + if Is_Enumeration_Type (P_Type) then + Check_Restriction (No_Enumeration_Maps, N); + end if; + + Check_E1; + Resolve (E1, P_Base_Type); + Check_Enum_Image; + Validate_Non_Static_Attribute_Function_Call; + end Image; + + --------- + -- Img -- + --------- + + when Attribute_Img => Img : + begin + Check_E0; + Set_Etype (N, Standard_String); + + if not Is_Scalar_Type (P_Type) + or else (Is_Entity_Name (P) and then Is_Type (Entity (P))) + then + Error_Attr_P + ("prefix of % attribute must be scalar object name"); + end if; + + Check_Enum_Image; + end Img; + + ----------- + -- Input -- + ----------- + + when Attribute_Input => + Check_E1; + Check_Stream_Attribute (TSS_Stream_Input); + Set_Etype (N, P_Base_Type); + + ------------------- + -- Integer_Value -- + ------------------- + + when Attribute_Integer_Value => + Check_E1; + Check_Integer_Type; + Resolve (E1, Any_Fixed); + + -- Signal an error if argument type is not a specific fixed-point + -- subtype. An error has been signalled already if the argument + -- was not of a fixed-point type. + + if Etype (E1) = Any_Fixed and then not Error_Posted (E1) then + Error_Attr ("argument of % must be of a fixed-point type", E1); + end if; + + Set_Etype (N, P_Base_Type); + + ------------------- + -- Invalid_Value -- + ------------------- + + when Attribute_Invalid_Value => + Check_E0; + Check_Scalar_Type; + Set_Etype (N, P_Base_Type); + Invalid_Value_Used := True; + + ----------- + -- Large -- + ----------- + + when Attribute_Large => + Check_E0; + Check_Real_Type; + Set_Etype (N, Universal_Real); + + ---------- + -- Last -- + ---------- + + when Attribute_Last => + Check_Array_Or_Scalar_Type; + Bad_Attribute_For_Predicate; + + -------------- + -- Last_Bit -- + -------------- + + when Attribute_Last_Bit => + Check_Component; + Set_Etype (N, Universal_Integer); + + ------------------ + -- Leading_Part -- + ------------------ + + when Attribute_Leading_Part => + Check_Floating_Point_Type_2; + Set_Etype (N, P_Base_Type); + Resolve (E1, P_Base_Type); + Resolve (E2, Any_Integer); + + ------------ + -- Length -- + ------------ + + when Attribute_Length => + Check_Array_Type; + Set_Etype (N, Universal_Integer); + + ------------- + -- Machine -- + ------------- + + when Attribute_Machine => + Check_Floating_Point_Type_1; + Set_Etype (N, P_Base_Type); + Resolve (E1, P_Base_Type); + + ------------------ + -- Machine_Emax -- + ------------------ + + when Attribute_Machine_Emax => + Check_Floating_Point_Type_0; + Set_Etype (N, Universal_Integer); + + ------------------ + -- Machine_Emin -- + ------------------ + + when Attribute_Machine_Emin => + Check_Floating_Point_Type_0; + Set_Etype (N, Universal_Integer); + + ---------------------- + -- Machine_Mantissa -- + ---------------------- + + when Attribute_Machine_Mantissa => + Check_Floating_Point_Type_0; + Set_Etype (N, Universal_Integer); + + ----------------------- + -- Machine_Overflows -- + ----------------------- + + when Attribute_Machine_Overflows => + Check_Real_Type; + Check_E0; + Set_Etype (N, Standard_Boolean); + + ------------------- + -- Machine_Radix -- + ------------------- + + when Attribute_Machine_Radix => + Check_Real_Type; + Check_E0; + Set_Etype (N, Universal_Integer); + + ---------------------- + -- Machine_Rounding -- + ---------------------- + + when Attribute_Machine_Rounding => + Check_Floating_Point_Type_1; + Set_Etype (N, P_Base_Type); + Resolve (E1, P_Base_Type); + + -------------------- + -- Machine_Rounds -- + -------------------- + + when Attribute_Machine_Rounds => + Check_Real_Type; + Check_E0; + Set_Etype (N, Standard_Boolean); + + ------------------ + -- Machine_Size -- + ------------------ + + when Attribute_Machine_Size => + Check_E0; + Check_Type; + Check_Not_Incomplete_Type; + Set_Etype (N, Universal_Integer); + + -------------- + -- Mantissa -- + -------------- + + when Attribute_Mantissa => + Check_E0; + Check_Real_Type; + Set_Etype (N, Universal_Integer); + + --------- + -- Max -- + --------- + + when Attribute_Max => + Check_E2; + Check_Scalar_Type; + Resolve (E1, P_Base_Type); + Resolve (E2, P_Base_Type); + Set_Etype (N, P_Base_Type); + + ---------------------------------- + -- Max_Alignment_For_Allocation -- + -- Max_Size_In_Storage_Elements -- + ---------------------------------- + + when Attribute_Max_Alignment_For_Allocation | + Attribute_Max_Size_In_Storage_Elements => + Check_E0; + Check_Type; + Check_Not_Incomplete_Type; + Set_Etype (N, Universal_Integer); + + ----------------------- + -- Maximum_Alignment -- + ----------------------- + + when Attribute_Maximum_Alignment => + Standard_Attribute (Ttypes.Maximum_Alignment); + + -------------------- + -- Mechanism_Code -- + -------------------- + + when Attribute_Mechanism_Code => + if not Is_Entity_Name (P) + or else not Is_Subprogram (Entity (P)) + then + Error_Attr_P ("prefix of % attribute must be subprogram"); + end if; + + Check_Either_E0_Or_E1; + + if Present (E1) then + Resolve (E1, Any_Integer); + Set_Etype (E1, Standard_Integer); + + if not Is_Static_Expression (E1) then + Flag_Non_Static_Expr + ("expression for parameter number must be static!", E1); + Error_Attr; + + elsif UI_To_Int (Intval (E1)) > Number_Formals (Entity (P)) + or else UI_To_Int (Intval (E1)) < 0 + then + Error_Attr ("invalid parameter number for % attribute", E1); + end if; + end if; + + Set_Etype (N, Universal_Integer); + + --------- + -- Min -- + --------- + + when Attribute_Min => + Check_E2; + Check_Scalar_Type; + Resolve (E1, P_Base_Type); + Resolve (E2, P_Base_Type); + Set_Etype (N, P_Base_Type); + + --------- + -- Mod -- + --------- + + when Attribute_Mod => + + -- Note: this attribute is only allowed in Ada 2005 mode, but + -- we do not need to test that here, since Mod is only recognized + -- as an attribute name in Ada 2005 mode during the parse. + + Check_E1; + Check_Modular_Integer_Type; + Resolve (E1, Any_Integer); + Set_Etype (N, P_Base_Type); + + ----------- + -- Model -- + ----------- + + when Attribute_Model => + Check_Floating_Point_Type_1; + Set_Etype (N, P_Base_Type); + Resolve (E1, P_Base_Type); + + ---------------- + -- Model_Emin -- + ---------------- + + when Attribute_Model_Emin => + Check_Floating_Point_Type_0; + Set_Etype (N, Universal_Integer); + + ------------------- + -- Model_Epsilon -- + ------------------- + + when Attribute_Model_Epsilon => + Check_Floating_Point_Type_0; + Set_Etype (N, Universal_Real); + + -------------------- + -- Model_Mantissa -- + -------------------- + + when Attribute_Model_Mantissa => + Check_Floating_Point_Type_0; + Set_Etype (N, Universal_Integer); + + ----------------- + -- Model_Small -- + ----------------- + + when Attribute_Model_Small => + Check_Floating_Point_Type_0; + Set_Etype (N, Universal_Real); + + ------------- + -- Modulus -- + ------------- + + when Attribute_Modulus => + Check_E0; + Check_Modular_Integer_Type; + Set_Etype (N, Universal_Integer); + + -------------------- + -- Null_Parameter -- + -------------------- + + when Attribute_Null_Parameter => Null_Parameter : declare + Parnt : constant Node_Id := Parent (N); + GParnt : constant Node_Id := Parent (Parnt); + + procedure Bad_Null_Parameter (Msg : String); + -- Used if bad Null parameter attribute node is found. Issues + -- given error message, and also sets the type to Any_Type to + -- avoid blowups later on from dealing with a junk node. + + procedure Must_Be_Imported (Proc_Ent : Entity_Id); + -- Called to check that Proc_Ent is imported subprogram + + ------------------------ + -- Bad_Null_Parameter -- + ------------------------ + + procedure Bad_Null_Parameter (Msg : String) is + begin + Error_Msg_N (Msg, N); + Set_Etype (N, Any_Type); + end Bad_Null_Parameter; + + ---------------------- + -- Must_Be_Imported -- + ---------------------- + + procedure Must_Be_Imported (Proc_Ent : Entity_Id) is + Pent : constant Entity_Id := Ultimate_Alias (Proc_Ent); + + begin + -- Ignore check if procedure not frozen yet (we will get + -- another chance when the default parameter is reanalyzed) + + if not Is_Frozen (Pent) then + return; + + elsif not Is_Imported (Pent) then + Bad_Null_Parameter + ("Null_Parameter can only be used with imported subprogram"); + + else + return; + end if; + end Must_Be_Imported; + + -- Start of processing for Null_Parameter + + begin + Check_Type; + Check_E0; + Set_Etype (N, P_Type); + + -- Case of attribute used as default expression + + if Nkind (Parnt) = N_Parameter_Specification then + Must_Be_Imported (Defining_Entity (GParnt)); + + -- Case of attribute used as actual for subprogram (positional) + + elsif Nkind_In (Parnt, N_Procedure_Call_Statement, + N_Function_Call) + and then Is_Entity_Name (Name (Parnt)) + then + Must_Be_Imported (Entity (Name (Parnt))); + + -- Case of attribute used as actual for subprogram (named) + + elsif Nkind (Parnt) = N_Parameter_Association + and then Nkind_In (GParnt, N_Procedure_Call_Statement, + N_Function_Call) + and then Is_Entity_Name (Name (GParnt)) + then + Must_Be_Imported (Entity (Name (GParnt))); + + -- Not an allowed case + + else + Bad_Null_Parameter + ("Null_Parameter must be actual or default parameter"); + end if; + end Null_Parameter; + + ----------------- + -- Object_Size -- + ----------------- + + when Attribute_Object_Size => + Check_E0; + Check_Type; + Check_Not_Incomplete_Type; + Set_Etype (N, Universal_Integer); + + --------- + -- Old -- + --------- + + when Attribute_Old => + + -- The attribute reference is a primary. If expressions follow, the + -- attribute reference is an indexable object, so rewrite the node + -- accordingly. + + if Present (E1) then + Rewrite (N, + Make_Indexed_Component (Loc, + Prefix => + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Prefix (N)), + Attribute_Name => Name_Old), + Expressions => Expressions (N))); + + Analyze (N); + return; + end if; + + Check_E0; + Set_Etype (N, P_Type); + + if No (Current_Subprogram) then + Error_Attr ("attribute % can only appear within subprogram", N); + end if; + + if Is_Limited_Type (P_Type) then + Error_Attr ("attribute % cannot apply to limited objects", P); + end if; + + if Is_Entity_Name (P) + and then Is_Constant_Object (Entity (P)) + then + Error_Msg_N + ("?attribute Old applied to constant has no effect", P); + end if; + + -- Check that the expression does not refer to local entities + + Check_Local : declare + Subp : Entity_Id := Current_Subprogram; + + function Process (N : Node_Id) return Traverse_Result; + -- Check that N does not contain references to local variables or + -- other local entities of Subp. + + ------------- + -- Process -- + ------------- + + function Process (N : Node_Id) return Traverse_Result is + begin + if Is_Entity_Name (N) + and then Present (Entity (N)) + and then not Is_Formal (Entity (N)) + and then Enclosing_Subprogram (Entity (N)) = Subp + then + Error_Msg_Node_1 := Entity (N); + Error_Attr + ("attribute % cannot refer to local variable&", N); + end if; + + return OK; + end Process; + + procedure Check_No_Local is new Traverse_Proc; + + -- Start of processing for Check_Local + + begin + Check_No_Local (P); + + if In_Parameter_Specification (P) then + + -- We have additional restrictions on using 'Old in parameter + -- specifications. + + if Present (Enclosing_Subprogram (Current_Subprogram)) then + + -- Check that there is no reference to the enclosing + -- subprogram local variables. Otherwise, we might end up + -- being called from the enclosing subprogram and thus using + -- 'Old on a local variable which is not defined at entry + -- time. + + Subp := Enclosing_Subprogram (Current_Subprogram); + Check_No_Local (P); + + else + -- We must prevent default expression of library-level + -- subprogram from using 'Old, as the subprogram may be + -- used in elaboration code for which there is no enclosing + -- subprogram. + + Error_Attr + ("attribute % can only appear within subprogram", N); + end if; + end if; + end Check_Local; + + ------------ + -- Output -- + ------------ + + when Attribute_Output => + Check_E2; + Check_Stream_Attribute (TSS_Stream_Output); + Set_Etype (N, Standard_Void_Type); + Resolve (N, Standard_Void_Type); + + ------------------ + -- Partition_ID -- + ------------------ + + when Attribute_Partition_ID => Partition_Id : + begin + Check_E0; + + if P_Type /= Any_Type then + if not Is_Library_Level_Entity (Entity (P)) then + Error_Attr_P + ("prefix of % attribute must be library-level entity"); + + -- The defining entity of prefix should not be declared inside a + -- Pure unit. RM E.1(8). Is_Pure was set during declaration. + + elsif Is_Entity_Name (P) + and then Is_Pure (Entity (P)) + then + Error_Attr_P ("prefix of% attribute must not be declared pure"); + end if; + end if; + + Set_Etype (N, Universal_Integer); + end Partition_Id; + + ------------------------- + -- Passed_By_Reference -- + ------------------------- + + when Attribute_Passed_By_Reference => + Check_E0; + Check_Type; + Set_Etype (N, Standard_Boolean); + + ------------------ + -- Pool_Address -- + ------------------ + + when Attribute_Pool_Address => + Check_E0; + Set_Etype (N, RTE (RE_Address)); + + --------- + -- Pos -- + --------- + + when Attribute_Pos => + Check_Discrete_Type; + Check_E1; + Resolve (E1, P_Base_Type); + Set_Etype (N, Universal_Integer); + + -------------- + -- Position -- + -------------- + + when Attribute_Position => + Check_Component; + Set_Etype (N, Universal_Integer); + + ---------- + -- Pred -- + ---------- + + when Attribute_Pred => + Check_Scalar_Type; + Check_E1; + Resolve (E1, P_Base_Type); + Set_Etype (N, P_Base_Type); + + -- Nothing to do for real type case + + if Is_Real_Type (P_Type) then + null; + + -- If not modular type, test for overflow check required + + else + if not Is_Modular_Integer_Type (P_Type) + and then not Range_Checks_Suppressed (P_Base_Type) + then + Enable_Range_Check (E1); + end if; + end if; + + -------------- + -- Priority -- + -------------- + + -- Ada 2005 (AI-327): Dynamic ceiling priorities + + when Attribute_Priority => + if Ada_Version < Ada_2005 then + Error_Attr ("% attribute is allowed only in Ada 2005 mode", P); + end if; + + Check_E0; + + -- The prefix must be a protected object (AARM D.5.2 (2/2)) + + Analyze (P); + + if Is_Protected_Type (Etype (P)) + or else (Is_Access_Type (Etype (P)) + and then Is_Protected_Type (Designated_Type (Etype (P)))) + then + Resolve (P, Etype (P)); + else + Error_Attr_P ("prefix of % attribute must be a protected object"); + end if; + + Set_Etype (N, Standard_Integer); + + -- Must be called from within a protected procedure or entry of the + -- protected object. + + declare + S : Entity_Id; + + begin + S := Current_Scope; + while S /= Etype (P) + and then S /= Standard_Standard + loop + S := Scope (S); + end loop; + + if S = Standard_Standard then + Error_Attr ("the attribute % is only allowed inside protected " + & "operations", P); + end if; + end; + + Validate_Non_Static_Attribute_Function_Call; + + ----------- + -- Range -- + ----------- + + when Attribute_Range => + Check_Array_Or_Scalar_Type; + Bad_Attribute_For_Predicate; + + if Ada_Version = Ada_83 + and then Is_Scalar_Type (P_Type) + and then Comes_From_Source (N) + then + Error_Attr + ("(Ada 83) % attribute not allowed for scalar type", P); + end if; + + ------------ + -- Result -- + ------------ + + when Attribute_Result => Result : declare + CS : Entity_Id := Current_Scope; + PS : Entity_Id := Scope (CS); + + begin + -- If the enclosing subprogram is always inlined, the enclosing + -- postcondition will not be propagated to the expanded call. + + if Has_Pragma_Inline_Always (PS) + and then Warn_On_Redundant_Constructs + then + Error_Msg_N + ("postconditions on inlined functions not enforced?", N); + end if; + + -- If we are in the scope of a function and in Spec_Expression mode, + -- this is likely the prescan of the postcondition pragma, and we + -- just set the proper type. If there is an error it will be caught + -- when the real Analyze call is done. + + if Ekind (CS) = E_Function + and then In_Spec_Expression + then + -- Check OK prefix + + if Chars (CS) /= Chars (P) then + Error_Msg_NE + ("incorrect prefix for % attribute, expected &", P, CS); + Error_Attr; + end if; + + Set_Etype (N, Etype (CS)); + + -- If several functions with that name are visible, + -- the intended one is the current scope. + + if Is_Overloaded (P) then + Set_Entity (P, CS); + Set_Is_Overloaded (P, False); + end if; + + -- Body case, where we must be inside a generated _Postcondition + -- procedure, and the prefix must be on the scope stack, or else + -- the attribute use is definitely misplaced. The condition itself + -- may have generated transient scopes, and is not necessarily the + -- current one. + + else + while Present (CS) + and then CS /= Standard_Standard + loop + if Chars (CS) = Name_uPostconditions then + exit; + else + CS := Scope (CS); + end if; + end loop; + + PS := Scope (CS); + + if Chars (CS) = Name_uPostconditions + and then Ekind (PS) = E_Function + then + -- Check OK prefix + + if Nkind_In (P, N_Identifier, N_Operator_Symbol) + and then Chars (P) = Chars (PS) + then + null; + + -- Within an instance, the prefix designates the local renaming + -- of the original generic. + + elsif Is_Entity_Name (P) + and then Ekind (Entity (P)) = E_Function + and then Present (Alias (Entity (P))) + and then Chars (Alias (Entity (P))) = Chars (PS) + then + null; + + else + Error_Msg_NE + ("incorrect prefix for % attribute, expected &", P, PS); + Error_Attr; + end if; + + Rewrite (N, Make_Identifier (Sloc (N), Name_uResult)); + Analyze_And_Resolve (N, Etype (PS)); + + else + Error_Attr + ("% attribute can only appear" & + " in function Postcondition pragma", P); + end if; + end if; + end Result; + + ------------------ + -- Range_Length -- + ------------------ + + when Attribute_Range_Length => + Check_E0; + Check_Discrete_Type; + Set_Etype (N, Universal_Integer); + + ---------- + -- Read -- + ---------- + + when Attribute_Read => + Check_E2; + Check_Stream_Attribute (TSS_Stream_Read); + Set_Etype (N, Standard_Void_Type); + Resolve (N, Standard_Void_Type); + Note_Possible_Modification (E2, Sure => True); + + --------- + -- Ref -- + --------- + + when Attribute_Ref => + Check_E1; + Analyze (P); + + if Nkind (P) /= N_Expanded_Name + or else not Is_RTE (P_Type, RE_Address) + then + Error_Attr_P ("prefix of % attribute must be System.Address"); + end if; + + Analyze_And_Resolve (E1, Any_Integer); + Set_Etype (N, RTE (RE_Address)); + + --------------- + -- Remainder -- + --------------- + + when Attribute_Remainder => + Check_Floating_Point_Type_2; + Set_Etype (N, P_Base_Type); + Resolve (E1, P_Base_Type); + Resolve (E2, P_Base_Type); + + ----------- + -- Round -- + ----------- + + when Attribute_Round => + Check_E1; + Check_Decimal_Fixed_Point_Type; + Set_Etype (N, P_Base_Type); + + -- Because the context is universal_real (3.5.10(12)) it is a legal + -- context for a universal fixed expression. This is the only + -- attribute whose functional description involves U_R. + + if Etype (E1) = Universal_Fixed then + declare + Conv : constant Node_Id := Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Universal_Real, Loc), + Expression => Relocate_Node (E1)); + + begin + Rewrite (E1, Conv); + Analyze (E1); + end; + end if; + + Resolve (E1, Any_Real); + + -------------- + -- Rounding -- + -------------- + + when Attribute_Rounding => + Check_Floating_Point_Type_1; + Set_Etype (N, P_Base_Type); + Resolve (E1, P_Base_Type); + + --------------- + -- Safe_Emax -- + --------------- + + when Attribute_Safe_Emax => + Check_Floating_Point_Type_0; + Set_Etype (N, Universal_Integer); + + ---------------- + -- Safe_First -- + ---------------- + + when Attribute_Safe_First => + Check_Floating_Point_Type_0; + Set_Etype (N, Universal_Real); + + ---------------- + -- Safe_Large -- + ---------------- + + when Attribute_Safe_Large => + Check_E0; + Check_Real_Type; + Set_Etype (N, Universal_Real); + + --------------- + -- Safe_Last -- + --------------- + + when Attribute_Safe_Last => + Check_Floating_Point_Type_0; + Set_Etype (N, Universal_Real); + + ---------------- + -- Safe_Small -- + ---------------- + + when Attribute_Safe_Small => + Check_E0; + Check_Real_Type; + Set_Etype (N, Universal_Real); + + ----------- + -- Scale -- + ----------- + + when Attribute_Scale => + Check_E0; + Check_Decimal_Fixed_Point_Type; + Set_Etype (N, Universal_Integer); + + ------------- + -- Scaling -- + ------------- + + when Attribute_Scaling => + Check_Floating_Point_Type_2; + Set_Etype (N, P_Base_Type); + Resolve (E1, P_Base_Type); + + ------------------ + -- Signed_Zeros -- + ------------------ + + when Attribute_Signed_Zeros => + Check_Floating_Point_Type_0; + Set_Etype (N, Standard_Boolean); + + ---------- + -- Size -- + ---------- + + when Attribute_Size | Attribute_VADS_Size => Size : + begin + Check_E0; + + -- If prefix is parameterless function call, rewrite and resolve + -- as such. + + if Is_Entity_Name (P) + and then Ekind (Entity (P)) = E_Function + then + Resolve (P); + + -- Similar processing for a protected function call + + elsif Nkind (P) = N_Selected_Component + and then Ekind (Entity (Selector_Name (P))) = E_Function + then + Resolve (P); + end if; + + if Is_Object_Reference (P) then + Check_Object_Reference (P); + + elsif Is_Entity_Name (P) + and then (Is_Type (Entity (P)) + or else Ekind (Entity (P)) = E_Enumeration_Literal) + then + null; + + elsif Nkind (P) = N_Type_Conversion + and then not Comes_From_Source (P) + then + null; + + else + Error_Attr_P ("invalid prefix for % attribute"); + end if; + + Check_Not_Incomplete_Type; + Check_Not_CPP_Type; + Set_Etype (N, Universal_Integer); + end Size; + + ----------- + -- Small -- + ----------- + + when Attribute_Small => + Check_E0; + Check_Real_Type; + Set_Etype (N, Universal_Real); + + ------------------ + -- Storage_Pool -- + ------------------ + + when Attribute_Storage_Pool => Storage_Pool : + begin + Check_E0; + + if Is_Access_Type (P_Type) then + if Ekind (P_Type) = E_Access_Subprogram_Type then + Error_Attr_P + ("cannot use % attribute for access-to-subprogram type"); + end if; + + -- Set appropriate entity + + if Present (Associated_Storage_Pool (Root_Type (P_Type))) then + Set_Entity (N, Associated_Storage_Pool (Root_Type (P_Type))); + else + Set_Entity (N, RTE (RE_Global_Pool_Object)); + end if; + + Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool))); + + -- Validate_Remote_Access_To_Class_Wide_Type for attribute + -- Storage_Pool since this attribute is not defined for such + -- types (RM E.2.3(22)). + + Validate_Remote_Access_To_Class_Wide_Type (N); + + else + Error_Attr_P ("prefix of % attribute must be access type"); + end if; + end Storage_Pool; + + ------------------ + -- Storage_Size -- + ------------------ + + when Attribute_Storage_Size => Storage_Size : + begin + Check_E0; + + if Is_Task_Type (P_Type) then + Set_Etype (N, Universal_Integer); + + -- Use with tasks is an obsolescent feature + + Check_Restriction (No_Obsolescent_Features, P); + + elsif Is_Access_Type (P_Type) then + if Ekind (P_Type) = E_Access_Subprogram_Type then + Error_Attr_P + ("cannot use % attribute for access-to-subprogram type"); + end if; + + if Is_Entity_Name (P) + and then Is_Type (Entity (P)) + then + Check_Type; + Set_Etype (N, Universal_Integer); + + -- Validate_Remote_Access_To_Class_Wide_Type for attribute + -- Storage_Size since this attribute is not defined for + -- such types (RM E.2.3(22)). + + Validate_Remote_Access_To_Class_Wide_Type (N); + + -- The prefix is allowed to be an implicit dereference + -- of an access value designating a task. + + else + Check_Task_Prefix; + Set_Etype (N, Universal_Integer); + end if; + + else + Error_Attr_P ("prefix of % attribute must be access or task type"); + end if; + end Storage_Size; + + ------------------ + -- Storage_Unit -- + ------------------ + + when Attribute_Storage_Unit => + Standard_Attribute (Ttypes.System_Storage_Unit); + + ----------------- + -- Stream_Size -- + ----------------- + + when Attribute_Stream_Size => + Check_E0; + Check_Type; + + if Is_Entity_Name (P) + and then Is_Elementary_Type (Entity (P)) + then + Set_Etype (N, Universal_Integer); + else + Error_Attr_P ("invalid prefix for % attribute"); + end if; + + --------------- + -- Stub_Type -- + --------------- + + when Attribute_Stub_Type => + Check_Type; + Check_E0; + + if Is_Remote_Access_To_Class_Wide_Type (P_Type) then + Rewrite (N, + New_Occurrence_Of (Corresponding_Stub_Type (P_Type), Loc)); + else + Error_Attr_P + ("prefix of% attribute must be remote access to classwide"); + end if; + + ---------- + -- Succ -- + ---------- + + when Attribute_Succ => + Check_Scalar_Type; + Check_E1; + Resolve (E1, P_Base_Type); + Set_Etype (N, P_Base_Type); + + -- Nothing to do for real type case + + if Is_Real_Type (P_Type) then + null; + + -- If not modular type, test for overflow check required + + else + if not Is_Modular_Integer_Type (P_Type) + and then not Range_Checks_Suppressed (P_Base_Type) + then + Enable_Range_Check (E1); + end if; + end if; + + --------- + -- Tag -- + --------- + + when Attribute_Tag => Tag : + begin + Check_E0; + Check_Dereference; + + if not Is_Tagged_Type (P_Type) then + Error_Attr_P ("prefix of % attribute must be tagged"); + + -- Next test does not apply to generated code + -- why not, and what does the illegal reference mean??? + + elsif Is_Object_Reference (P) + and then not Is_Class_Wide_Type (P_Type) + and then Comes_From_Source (N) + then + Error_Attr_P + ("% attribute can only be applied to objects " & + "of class - wide type"); + end if; + + -- The prefix cannot be an incomplete type. However, references + -- to 'Tag can be generated when expanding interface conversions, + -- and this is legal. + + if Comes_From_Source (N) then + Check_Not_Incomplete_Type; + end if; + + -- Set appropriate type + + Set_Etype (N, RTE (RE_Tag)); + end Tag; + + ----------------- + -- Target_Name -- + ----------------- + + when Attribute_Target_Name => Target_Name : declare + TN : constant String := Sdefault.Target_Name.all; + TL : Natural; + + begin + Check_Standard_Prefix; + + TL := TN'Last; + + if TN (TL) = '/' or else TN (TL) = '\' then + TL := TL - 1; + end if; + + Rewrite (N, + Make_String_Literal (Loc, + Strval => TN (TN'First .. TL))); + Analyze_And_Resolve (N, Standard_String); + end Target_Name; + + ---------------- + -- Terminated -- + ---------------- + + when Attribute_Terminated => + Check_E0; + Set_Etype (N, Standard_Boolean); + Check_Task_Prefix; + + ---------------- + -- To_Address -- + ---------------- + + when Attribute_To_Address => + Check_E1; + Analyze (P); + + if Nkind (P) /= N_Identifier + or else Chars (P) /= Name_System + then + Error_Attr_P ("prefix of % attribute must be System"); + end if; + + Generate_Reference (RTE (RE_Address), P); + Analyze_And_Resolve (E1, Any_Integer); + Set_Etype (N, RTE (RE_Address)); + + ------------ + -- To_Any -- + ------------ + + when Attribute_To_Any => + Check_E1; + Check_PolyORB_Attribute; + Set_Etype (N, RTE (RE_Any)); + + ---------------- + -- Truncation -- + ---------------- + + when Attribute_Truncation => + Check_Floating_Point_Type_1; + Resolve (E1, P_Base_Type); + Set_Etype (N, P_Base_Type); + + ---------------- + -- Type_Class -- + ---------------- + + when Attribute_Type_Class => + Check_E0; + Check_Type; + Check_Not_Incomplete_Type; + Set_Etype (N, RTE (RE_Type_Class)); + + -------------- + -- TypeCode -- + -------------- + + when Attribute_TypeCode => + Check_E0; + Check_PolyORB_Attribute; + Set_Etype (N, RTE (RE_TypeCode)); + + -------------- + -- Type_Key -- + -------------- + + when Attribute_Type_Key => + Check_E0; + Check_Type; + + -- This processing belongs in Eval_Attribute ??? + + declare + function Type_Key return String_Id; + -- A very preliminary implementation. For now, a signature + -- consists of only the type name. This is clearly incomplete + -- (e.g., adding a new field to a record type should change the + -- type's Type_Key attribute). + + -------------- + -- Type_Key -- + -------------- + + function Type_Key return String_Id is + Full_Name : constant String_Id := + Fully_Qualified_Name_String (Entity (P)); + + begin + -- Copy all characters in Full_Name but the trailing NUL + + Start_String; + for J in 1 .. String_Length (Full_Name) - 1 loop + Store_String_Char (Get_String_Char (Full_Name, Int (J))); + end loop; + + Store_String_Chars ("'Type_Key"); + return End_String; + end Type_Key; + + begin + Rewrite (N, Make_String_Literal (Loc, Type_Key)); + end; + + Analyze_And_Resolve (N, Standard_String); + + ----------------- + -- UET_Address -- + ----------------- + + when Attribute_UET_Address => + Check_E0; + Check_Unit_Name (P); + Set_Etype (N, RTE (RE_Address)); + + ----------------------- + -- Unbiased_Rounding -- + ----------------------- + + when Attribute_Unbiased_Rounding => + Check_Floating_Point_Type_1; + Set_Etype (N, P_Base_Type); + Resolve (E1, P_Base_Type); + + ---------------------- + -- Unchecked_Access -- + ---------------------- + + when Attribute_Unchecked_Access => + if Comes_From_Source (N) then + Check_Restriction (No_Unchecked_Access, N); + end if; + + Analyze_Access_Attribute; + + ------------------------- + -- Unconstrained_Array -- + ------------------------- + + when Attribute_Unconstrained_Array => + Check_E0; + Check_Type; + Check_Not_Incomplete_Type; + Set_Etype (N, Standard_Boolean); + + ------------------------------ + -- Universal_Literal_String -- + ------------------------------ + + -- This is a GNAT specific attribute whose prefix must be a named + -- number where the expression is either a single numeric literal, + -- or a numeric literal immediately preceded by a minus sign. The + -- result is equivalent to a string literal containing the text of + -- the literal as it appeared in the source program with a possible + -- leading minus sign. + + when Attribute_Universal_Literal_String => Universal_Literal_String : + begin + Check_E0; + + if not Is_Entity_Name (P) + or else Ekind (Entity (P)) not in Named_Kind + then + Error_Attr_P ("prefix for % attribute must be named number"); + + else + declare + Expr : Node_Id; + Negative : Boolean; + S : Source_Ptr; + Src : Source_Buffer_Ptr; + + begin + Expr := Original_Node (Expression (Parent (Entity (P)))); + + if Nkind (Expr) = N_Op_Minus then + Negative := True; + Expr := Original_Node (Right_Opnd (Expr)); + else + Negative := False; + end if; + + if not Nkind_In (Expr, N_Integer_Literal, N_Real_Literal) then + Error_Attr + ("named number for % attribute must be simple literal", N); + end if; + + -- Build string literal corresponding to source literal text + + Start_String; + + if Negative then + Store_String_Char (Get_Char_Code ('-')); + end if; + + S := Sloc (Expr); + Src := Source_Text (Get_Source_File_Index (S)); + + while Src (S) /= ';' and then Src (S) /= ' ' loop + Store_String_Char (Get_Char_Code (Src (S))); + S := S + 1; + end loop; + + -- Now we rewrite the attribute with the string literal + + Rewrite (N, + Make_String_Literal (Loc, End_String)); + Analyze (N); + end; + end if; + end Universal_Literal_String; + + ------------------------- + -- Unrestricted_Access -- + ------------------------- + + -- This is a GNAT specific attribute which is like Access except that + -- all scope checks and checks for aliased views are omitted. + + when Attribute_Unrestricted_Access => + if Comes_From_Source (N) then + Check_Restriction (No_Unchecked_Access, N); + end if; + + if Is_Entity_Name (P) then + Set_Address_Taken (Entity (P)); + end if; + + Analyze_Access_Attribute; + + --------- + -- Val -- + --------- + + when Attribute_Val => Val : declare + begin + Check_E1; + Check_Discrete_Type; + Resolve (E1, Any_Integer); + Set_Etype (N, P_Base_Type); + + -- Note, we need a range check in general, but we wait for the + -- Resolve call to do this, since we want to let Eval_Attribute + -- have a chance to find an static illegality first! + end Val; + + ----------- + -- Valid -- + ----------- + + when Attribute_Valid => + Check_E0; + + -- Ignore check for object if we have a 'Valid reference generated + -- by the expanded code, since in some cases valid checks can occur + -- on items that are names, but are not objects (e.g. attributes). + + if Comes_From_Source (N) then + Check_Object_Reference (P); + end if; + + if not Is_Scalar_Type (P_Type) then + Error_Attr_P ("object for % attribute must be of scalar type"); + end if; + + Set_Etype (N, Standard_Boolean); + + ----------- + -- Value -- + ----------- + + when Attribute_Value => Value : + begin + Check_E1; + Check_Scalar_Type; + + -- Case of enumeration type + + if Is_Enumeration_Type (P_Type) then + Check_Restriction (No_Enumeration_Maps, N); + + -- Mark all enumeration literals as referenced, since the use of + -- the Value attribute can implicitly reference any of the + -- literals of the enumeration base type. + + declare + Ent : Entity_Id := First_Literal (P_Base_Type); + begin + while Present (Ent) loop + Set_Referenced (Ent); + Next_Literal (Ent); + end loop; + end; + end if; + + -- Set Etype before resolving expression because expansion of + -- expression may require enclosing type. Note that the type + -- returned by 'Value is the base type of the prefix type. + + Set_Etype (N, P_Base_Type); + Validate_Non_Static_Attribute_Function_Call; + end Value; + + ---------------- + -- Value_Size -- + ---------------- + + when Attribute_Value_Size => + Check_E0; + Check_Type; + Check_Not_Incomplete_Type; + Set_Etype (N, Universal_Integer); + + ------------- + -- Version -- + ------------- + + when Attribute_Version => + Check_E0; + Check_Program_Unit; + Set_Etype (N, RTE (RE_Version_String)); + + ------------------ + -- Wchar_T_Size -- + ------------------ + + when Attribute_Wchar_T_Size => + Standard_Attribute (Interfaces_Wchar_T_Size); + + ---------------- + -- Wide_Image -- + ---------------- + + when Attribute_Wide_Image => Wide_Image : + begin + Check_Scalar_Type; + Set_Etype (N, Standard_Wide_String); + Check_E1; + Resolve (E1, P_Base_Type); + Validate_Non_Static_Attribute_Function_Call; + end Wide_Image; + + --------------------- + -- Wide_Wide_Image -- + --------------------- + + when Attribute_Wide_Wide_Image => Wide_Wide_Image : + begin + Check_Scalar_Type; + Set_Etype (N, Standard_Wide_Wide_String); + Check_E1; + Resolve (E1, P_Base_Type); + Validate_Non_Static_Attribute_Function_Call; + end Wide_Wide_Image; + + ---------------- + -- Wide_Value -- + ---------------- + + when Attribute_Wide_Value => Wide_Value : + begin + Check_E1; + Check_Scalar_Type; + + -- Set Etype before resolving expression because expansion + -- of expression may require enclosing type. + + Set_Etype (N, P_Type); + Validate_Non_Static_Attribute_Function_Call; + end Wide_Value; + + --------------------- + -- Wide_Wide_Value -- + --------------------- + + when Attribute_Wide_Wide_Value => Wide_Wide_Value : + begin + Check_E1; + Check_Scalar_Type; + + -- Set Etype before resolving expression because expansion + -- of expression may require enclosing type. + + Set_Etype (N, P_Type); + Validate_Non_Static_Attribute_Function_Call; + end Wide_Wide_Value; + + --------------------- + -- Wide_Wide_Width -- + --------------------- + + when Attribute_Wide_Wide_Width => + Check_E0; + Check_Scalar_Type; + Set_Etype (N, Universal_Integer); + + ---------------- + -- Wide_Width -- + ---------------- + + when Attribute_Wide_Width => + Check_E0; + Check_Scalar_Type; + Set_Etype (N, Universal_Integer); + + ----------- + -- Width -- + ----------- + + when Attribute_Width => + Check_E0; + Check_Scalar_Type; + Set_Etype (N, Universal_Integer); + + --------------- + -- Word_Size -- + --------------- + + when Attribute_Word_Size => + Standard_Attribute (System_Word_Size); + + ----------- + -- Write -- + ----------- + + when Attribute_Write => + Check_E2; + Check_Stream_Attribute (TSS_Stream_Write); + Set_Etype (N, Standard_Void_Type); + Resolve (N, Standard_Void_Type); + + end case; + + -- All errors raise Bad_Attribute, so that we get out before any further + -- damage occurs when an error is detected (for example, if we check for + -- one attribute expression, and the check succeeds, we want to be able + -- to proceed securely assuming that an expression is in fact present. + + -- Note: we set the attribute analyzed in this case to prevent any + -- attempt at reanalysis which could generate spurious error msgs. + + exception + when Bad_Attribute => + Set_Analyzed (N); + Set_Etype (N, Any_Type); + return; + end Analyze_Attribute; + + -------------------- + -- Eval_Attribute -- + -------------------- + + procedure Eval_Attribute (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Aname : constant Name_Id := Attribute_Name (N); + Id : constant Attribute_Id := Get_Attribute_Id (Aname); + P : constant Node_Id := Prefix (N); + + C_Type : constant Entity_Id := Etype (N); + -- The type imposed by the context + + E1 : Node_Id; + -- First expression, or Empty if none + + E2 : Node_Id; + -- Second expression, or Empty if none + + P_Entity : Entity_Id; + -- Entity denoted by prefix + + P_Type : Entity_Id; + -- The type of the prefix + + P_Base_Type : Entity_Id; + -- The base type of the prefix type + + P_Root_Type : Entity_Id; + -- The root type of the prefix type + + Static : Boolean; + -- True if the result is Static. This is set by the general processing + -- to true if the prefix is static, and all expressions are static. It + -- can be reset as processing continues for particular attributes + + Lo_Bound, Hi_Bound : Node_Id; + -- Expressions for low and high bounds of type or array index referenced + -- by First, Last, or Length attribute for array, set by Set_Bounds. + + CE_Node : Node_Id; + -- Constraint error node used if we have an attribute reference has + -- an argument that raises a constraint error. In this case we replace + -- the attribute with a raise constraint_error node. This is important + -- processing, since otherwise gigi might see an attribute which it is + -- unprepared to deal with. + + procedure Check_Concurrent_Discriminant (Bound : Node_Id); + -- If Bound is a reference to a discriminant of a task or protected type + -- occurring within the object's body, rewrite attribute reference into + -- a reference to the corresponding discriminal. Use for the expansion + -- of checks against bounds of entry family index subtypes. + + procedure Check_Expressions; + -- In case where the attribute is not foldable, the expressions, if + -- any, of the attribute, are in a non-static context. This procedure + -- performs the required additional checks. + + function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean; + -- Determines if the given type has compile time known bounds. Note + -- that we enter the case statement even in cases where the prefix + -- type does NOT have known bounds, so it is important to guard any + -- attempt to evaluate both bounds with a call to this function. + + procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint); + -- This procedure is called when the attribute N has a non-static + -- but compile time known value given by Val. It includes the + -- necessary checks for out of range values. + + function Fore_Value return Nat; + -- Computes the Fore value for the current attribute prefix, which is + -- known to be a static fixed-point type. Used by Fore and Width. + + function Mantissa return Uint; + -- Returns the Mantissa value for the prefix type + + procedure Set_Bounds; + -- Used for First, Last and Length attributes applied to an array or + -- array subtype. Sets the variables Lo_Bound and Hi_Bound to the low + -- and high bound expressions for the index referenced by the attribute + -- designator (i.e. the first index if no expression is present, and + -- the N'th index if the value N is present as an expression). Also + -- used for First and Last of scalar types. Static is reset to False + -- if the type or index type is not statically constrained. + + function Statically_Denotes_Entity (N : Node_Id) return Boolean; + -- Verify that the prefix of a potentially static array attribute + -- satisfies the conditions of 4.9 (14). + + ----------------------------------- + -- Check_Concurrent_Discriminant -- + ----------------------------------- + + procedure Check_Concurrent_Discriminant (Bound : Node_Id) is + Tsk : Entity_Id; + -- The concurrent (task or protected) type + + begin + if Nkind (Bound) = N_Identifier + and then Ekind (Entity (Bound)) = E_Discriminant + and then Is_Concurrent_Record_Type (Scope (Entity (Bound))) + then + Tsk := Corresponding_Concurrent_Type (Scope (Entity (Bound))); + + if In_Open_Scopes (Tsk) and then Has_Completion (Tsk) then + + -- Find discriminant of original concurrent type, and use + -- its current discriminal, which is the renaming within + -- the task/protected body. + + Rewrite (N, + New_Occurrence_Of + (Find_Body_Discriminal (Entity (Bound)), Loc)); + end if; + end if; + end Check_Concurrent_Discriminant; + + ----------------------- + -- Check_Expressions -- + ----------------------- + + procedure Check_Expressions is + E : Node_Id; + begin + E := E1; + while Present (E) loop + Check_Non_Static_Context (E); + Next (E); + end loop; + end Check_Expressions; + + ---------------------------------- + -- Compile_Time_Known_Attribute -- + ---------------------------------- + + procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint) is + T : constant Entity_Id := Etype (N); + + begin + Fold_Uint (N, Val, False); + + -- Check that result is in bounds of the type if it is static + + if Is_In_Range (N, T, Assume_Valid => False) then + null; + + elsif Is_Out_Of_Range (N, T) then + Apply_Compile_Time_Constraint_Error + (N, "value not in range of}?", CE_Range_Check_Failed); + + elsif not Range_Checks_Suppressed (T) then + Enable_Range_Check (N); + + else + Set_Do_Range_Check (N, False); + end if; + end Compile_Time_Known_Attribute; + + ------------------------------- + -- Compile_Time_Known_Bounds -- + ------------------------------- + + function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean is + begin + return + Compile_Time_Known_Value (Type_Low_Bound (Typ)) + and then + Compile_Time_Known_Value (Type_High_Bound (Typ)); + end Compile_Time_Known_Bounds; + + ---------------- + -- Fore_Value -- + ---------------- + + -- Note that the Fore calculation is based on the actual values + -- of the bounds, and does not take into account possible rounding. + + function Fore_Value return Nat is + Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type)); + Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type)); + Small : constant Ureal := Small_Value (P_Type); + Lo_Real : constant Ureal := Lo * Small; + Hi_Real : constant Ureal := Hi * Small; + T : Ureal; + R : Nat; + + begin + -- Bounds are given in terms of small units, so first compute + -- proper values as reals. + + T := UR_Max (abs Lo_Real, abs Hi_Real); + R := 2; + + -- Loop to compute proper value if more than one digit required + + while T >= Ureal_10 loop + R := R + 1; + T := T / Ureal_10; + end loop; + + return R; + end Fore_Value; + + -------------- + -- Mantissa -- + -------------- + + -- Table of mantissa values accessed by function Computed using + -- the relation: + + -- T'Mantissa = integer next above (D * log(10)/log(2)) + 1) + + -- where D is T'Digits (RM83 3.5.7) + + Mantissa_Value : constant array (Nat range 1 .. 40) of Nat := ( + 1 => 5, + 2 => 8, + 3 => 11, + 4 => 15, + 5 => 18, + 6 => 21, + 7 => 25, + 8 => 28, + 9 => 31, + 10 => 35, + 11 => 38, + 12 => 41, + 13 => 45, + 14 => 48, + 15 => 51, + 16 => 55, + 17 => 58, + 18 => 61, + 19 => 65, + 20 => 68, + 21 => 71, + 22 => 75, + 23 => 78, + 24 => 81, + 25 => 85, + 26 => 88, + 27 => 91, + 28 => 95, + 29 => 98, + 30 => 101, + 31 => 104, + 32 => 108, + 33 => 111, + 34 => 114, + 35 => 118, + 36 => 121, + 37 => 124, + 38 => 128, + 39 => 131, + 40 => 134); + + function Mantissa return Uint is + begin + return + UI_From_Int (Mantissa_Value (UI_To_Int (Digits_Value (P_Type)))); + end Mantissa; + + ---------------- + -- Set_Bounds -- + ---------------- + + procedure Set_Bounds is + Ndim : Nat; + Indx : Node_Id; + Ityp : Entity_Id; + + begin + -- For a string literal subtype, we have to construct the bounds. + -- Valid Ada code never applies attributes to string literals, but + -- it is convenient to allow the expander to generate attribute + -- references of this type (e.g. First and Last applied to a string + -- literal). + + -- Note that the whole point of the E_String_Literal_Subtype is to + -- avoid this construction of bounds, but the cases in which we + -- have to materialize them are rare enough that we don't worry! + + -- The low bound is simply the low bound of the base type. The + -- high bound is computed from the length of the string and this + -- low bound. + + if Ekind (P_Type) = E_String_Literal_Subtype then + Ityp := Etype (First_Index (Base_Type (P_Type))); + Lo_Bound := Type_Low_Bound (Ityp); + + Hi_Bound := + Make_Integer_Literal (Sloc (P), + Intval => + Expr_Value (Lo_Bound) + String_Literal_Length (P_Type) - 1); + + Set_Parent (Hi_Bound, P); + Analyze_And_Resolve (Hi_Bound, Etype (Lo_Bound)); + return; + + -- For non-array case, just get bounds of scalar type + + elsif Is_Scalar_Type (P_Type) then + Ityp := P_Type; + + -- For a fixed-point type, we must freeze to get the attributes + -- of the fixed-point type set now so we can reference them. + + if Is_Fixed_Point_Type (P_Type) + and then not Is_Frozen (Base_Type (P_Type)) + and then Compile_Time_Known_Value (Type_Low_Bound (P_Type)) + and then Compile_Time_Known_Value (Type_High_Bound (P_Type)) + then + Freeze_Fixed_Point_Type (Base_Type (P_Type)); + end if; + + -- For array case, get type of proper index + + else + if No (E1) then + Ndim := 1; + else + Ndim := UI_To_Int (Expr_Value (E1)); + end if; + + Indx := First_Index (P_Type); + for J in 1 .. Ndim - 1 loop + Next_Index (Indx); + end loop; + + -- If no index type, get out (some other error occurred, and + -- we don't have enough information to complete the job!) + + if No (Indx) then + Lo_Bound := Error; + Hi_Bound := Error; + return; + end if; + + Ityp := Etype (Indx); + end if; + + -- A discrete range in an index constraint is allowed to be a + -- subtype indication. This is syntactically a pain, but should + -- not propagate to the entity for the corresponding index subtype. + -- After checking that the subtype indication is legal, the range + -- of the subtype indication should be transfered to the entity. + -- The attributes for the bounds should remain the simple retrievals + -- that they are now. + + Lo_Bound := Type_Low_Bound (Ityp); + Hi_Bound := Type_High_Bound (Ityp); + + if not Is_Static_Subtype (Ityp) then + Static := False; + end if; + end Set_Bounds; + + ------------------------------- + -- Statically_Denotes_Entity -- + ------------------------------- + + function Statically_Denotes_Entity (N : Node_Id) return Boolean is + E : Entity_Id; + + begin + if not Is_Entity_Name (N) then + return False; + else + E := Entity (N); + end if; + + return + Nkind (Parent (E)) /= N_Object_Renaming_Declaration + or else Statically_Denotes_Entity (Renamed_Object (E)); + end Statically_Denotes_Entity; + + -- Start of processing for Eval_Attribute + + begin + -- No folding in spec expression that comes from source where the prefix + -- is an unfrozen entity. This avoids premature folding in cases like: + + -- procedure DefExprAnal is + -- type R is new Integer; + -- procedure P (Arg : Integer := R'Size); + -- for R'Size use 64; + -- procedure P (Arg : Integer := R'Size) is + -- begin + -- Put_Line (Arg'Img); + -- end P; + -- begin + -- P; + -- end; + + -- which should print 64 rather than 32. The exclusion of non-source + -- constructs from this test comes from some internal usage in packed + -- arrays, which otherwise fails, could use more analysis perhaps??? + + -- We do however go ahead with generic actual types, otherwise we get + -- some regressions, probably these types should be frozen anyway??? + + if In_Spec_Expression + and then Comes_From_Source (N) + and then not (Is_Entity_Name (P) + and then + (Is_Frozen (Entity (P)) + or else (Is_Type (Entity (P)) + and then + Is_Generic_Actual_Type (Entity (P))))) + then + return; + end if; + + -- Acquire first two expressions (at the moment, no attributes take more + -- than two expressions in any case). + + if Present (Expressions (N)) then + E1 := First (Expressions (N)); + E2 := Next (E1); + else + E1 := Empty; + E2 := Empty; + end if; + + -- Special processing for Enabled attribute. This attribute has a very + -- special prefix, and the easiest way to avoid lots of special checks + -- to protect this special prefix from causing trouble is to deal with + -- this attribute immediately and be done with it. + + if Id = Attribute_Enabled then + + -- We skip evaluation if the expander is not active. This is not just + -- an optimization. It is of key importance that we not rewrite the + -- attribute in a generic template, since we want to pick up the + -- setting of the check in the instance, and testing expander active + -- is as easy way of doing this as any. + + if Expander_Active then + declare + C : constant Check_Id := Get_Check_Id (Chars (P)); + R : Boolean; + + begin + if No (E1) then + if C in Predefined_Check_Id then + R := Scope_Suppress (C); + else + R := Is_Check_Suppressed (Empty, C); + end if; + + else + R := Is_Check_Suppressed (Entity (E1), C); + end if; + + if R then + Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); + else + Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); + end if; + end; + end if; + + return; + end if; + + -- Special processing for cases where the prefix is an object. For + -- this purpose, a string literal counts as an object (attributes + -- of string literals can only appear in generated code). + + if Is_Object_Reference (P) or else Nkind (P) = N_String_Literal then + + -- For Component_Size, the prefix is an array object, and we apply + -- the attribute to the type of the object. This is allowed for + -- both unconstrained and constrained arrays, since the bounds + -- have no influence on the value of this attribute. + + if Id = Attribute_Component_Size then + P_Entity := Etype (P); + + -- For First and Last, the prefix is an array object, and we apply + -- the attribute to the type of the array, but we need a constrained + -- type for this, so we use the actual subtype if available. + + elsif Id = Attribute_First + or else + Id = Attribute_Last + or else + Id = Attribute_Length + then + declare + AS : constant Entity_Id := Get_Actual_Subtype_If_Available (P); + + begin + if Present (AS) and then Is_Constrained (AS) then + P_Entity := AS; + + -- If we have an unconstrained type we cannot fold + + else + Check_Expressions; + return; + end if; + end; + + -- For Size, give size of object if available, otherwise we + -- cannot fold Size. + + elsif Id = Attribute_Size then + if Is_Entity_Name (P) + and then Known_Esize (Entity (P)) + then + Compile_Time_Known_Attribute (N, Esize (Entity (P))); + return; + + else + Check_Expressions; + return; + end if; + + -- For Alignment, give size of object if available, otherwise we + -- cannot fold Alignment. + + elsif Id = Attribute_Alignment then + if Is_Entity_Name (P) + and then Known_Alignment (Entity (P)) + then + Fold_Uint (N, Alignment (Entity (P)), False); + return; + + else + Check_Expressions; + return; + end if; + + -- No other attributes for objects are folded + + else + Check_Expressions; + return; + end if; + + -- Cases where P is not an object. Cannot do anything if P is + -- not the name of an entity. + + elsif not Is_Entity_Name (P) then + Check_Expressions; + return; + + -- Otherwise get prefix entity + + else + P_Entity := Entity (P); + end if; + + -- At this stage P_Entity is the entity to which the attribute + -- is to be applied. This is usually simply the entity of the + -- prefix, except in some cases of attributes for objects, where + -- as described above, we apply the attribute to the object type. + + -- First foldable possibility is a scalar or array type (RM 4.9(7)) + -- that is not generic (generic types are eliminated by RM 4.9(25)). + -- Note we allow non-static non-generic types at this stage as further + -- described below. + + if Is_Type (P_Entity) + and then (Is_Scalar_Type (P_Entity) or Is_Array_Type (P_Entity)) + and then (not Is_Generic_Type (P_Entity)) + then + P_Type := P_Entity; + + -- Second foldable possibility is an array object (RM 4.9(8)) + + elsif (Ekind (P_Entity) = E_Variable + or else + Ekind (P_Entity) = E_Constant) + and then Is_Array_Type (Etype (P_Entity)) + and then (not Is_Generic_Type (Etype (P_Entity))) + then + P_Type := Etype (P_Entity); + + -- If the entity is an array constant with an unconstrained nominal + -- subtype then get the type from the initial value. If the value has + -- been expanded into assignments, there is no expression and the + -- attribute reference remains dynamic. + + -- We could do better here and retrieve the type ??? + + if Ekind (P_Entity) = E_Constant + and then not Is_Constrained (P_Type) + then + if No (Constant_Value (P_Entity)) then + return; + else + P_Type := Etype (Constant_Value (P_Entity)); + end if; + end if; + + -- Definite must be folded if the prefix is not a generic type, + -- that is to say if we are within an instantiation. Same processing + -- applies to the GNAT attributes Has_Discriminants, Type_Class, + -- Has_Tagged_Value, and Unconstrained_Array. + + elsif (Id = Attribute_Definite + or else + Id = Attribute_Has_Access_Values + or else + Id = Attribute_Has_Discriminants + or else + Id = Attribute_Has_Tagged_Values + or else + Id = Attribute_Type_Class + or else + Id = Attribute_Unconstrained_Array + or else + Id = Attribute_Max_Alignment_For_Allocation) + and then not Is_Generic_Type (P_Entity) + then + P_Type := P_Entity; + + -- We can fold 'Size applied to a type if the size is known (as happens + -- for a size from an attribute definition clause). At this stage, this + -- can happen only for types (e.g. record types) for which the size is + -- always non-static. We exclude generic types from consideration (since + -- they have bogus sizes set within templates). + + elsif Id = Attribute_Size + and then Is_Type (P_Entity) + and then (not Is_Generic_Type (P_Entity)) + and then Known_Static_RM_Size (P_Entity) + then + Compile_Time_Known_Attribute (N, RM_Size (P_Entity)); + return; + + -- We can fold 'Alignment applied to a type if the alignment is known + -- (as happens for an alignment from an attribute definition clause). + -- At this stage, this can happen only for types (e.g. record + -- types) for which the size is always non-static. We exclude + -- generic types from consideration (since they have bogus + -- sizes set within templates). + + elsif Id = Attribute_Alignment + and then Is_Type (P_Entity) + and then (not Is_Generic_Type (P_Entity)) + and then Known_Alignment (P_Entity) + then + Compile_Time_Known_Attribute (N, Alignment (P_Entity)); + return; + + -- If this is an access attribute that is known to fail accessibility + -- check, rewrite accordingly. + + elsif Attribute_Name (N) = Name_Access + and then Raises_Constraint_Error (N) + then + Rewrite (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Accessibility_Check_Failed)); + Set_Etype (N, C_Type); + return; + + -- No other cases are foldable (they certainly aren't static, and at + -- the moment we don't try to fold any cases other than these three). + + else + Check_Expressions; + return; + end if; + + -- If either attribute or the prefix is Any_Type, then propagate + -- Any_Type to the result and don't do anything else at all. + + if P_Type = Any_Type + or else (Present (E1) and then Etype (E1) = Any_Type) + or else (Present (E2) and then Etype (E2) = Any_Type) + then + Set_Etype (N, Any_Type); + return; + end if; + + -- Scalar subtype case. We have not yet enforced the static requirement + -- of (RM 4.9(7)) and we don't intend to just yet, since there are cases + -- of non-static attribute references (e.g. S'Digits for a non-static + -- floating-point type, which we can compute at compile time). + + -- Note: this folding of non-static attributes is not simply a case of + -- optimization. For many of the attributes affected, Gigi cannot handle + -- the attribute and depends on the front end having folded them away. + + -- Note: although we don't require staticness at this stage, we do set + -- the Static variable to record the staticness, for easy reference by + -- those attributes where it matters (e.g. Succ and Pred), and also to + -- be used to ensure that non-static folded things are not marked as + -- being static (a check that is done right at the end). + + P_Root_Type := Root_Type (P_Type); + P_Base_Type := Base_Type (P_Type); + + -- If the root type or base type is generic, then we cannot fold. This + -- test is needed because subtypes of generic types are not always + -- marked as being generic themselves (which seems odd???) + + if Is_Generic_Type (P_Root_Type) + or else Is_Generic_Type (P_Base_Type) + then + return; + end if; + + if Is_Scalar_Type (P_Type) then + Static := Is_OK_Static_Subtype (P_Type); + + -- Array case. We enforce the constrained requirement of (RM 4.9(7-8)) + -- since we can't do anything with unconstrained arrays. In addition, + -- only the First, Last and Length attributes are possibly static. + + -- Definite, Has_Access_Values, Has_Discriminants, Has_Tagged_Values, + -- Type_Class, and Unconstrained_Array are again exceptions, because + -- they apply as well to unconstrained types. + + -- In addition Component_Size is an exception since it is possibly + -- foldable, even though it is never static, and it does apply to + -- unconstrained arrays. Furthermore, it is essential to fold this + -- in the packed case, since otherwise the value will be incorrect. + + elsif Id = Attribute_Definite + or else + Id = Attribute_Has_Access_Values + or else + Id = Attribute_Has_Discriminants + or else + Id = Attribute_Has_Tagged_Values + or else + Id = Attribute_Type_Class + or else + Id = Attribute_Unconstrained_Array + or else + Id = Attribute_Component_Size + then + Static := False; + + elsif Id /= Attribute_Max_Alignment_For_Allocation then + if not Is_Constrained (P_Type) + or else (Id /= Attribute_First and then + Id /= Attribute_Last and then + Id /= Attribute_Length) + then + Check_Expressions; + return; + end if; + + -- The rules in (RM 4.9(7,8)) require a static array, but as in the + -- scalar case, we hold off on enforcing staticness, since there are + -- cases which we can fold at compile time even though they are not + -- static (e.g. 'Length applied to a static index, even though other + -- non-static indexes make the array type non-static). This is only + -- an optimization, but it falls out essentially free, so why not. + -- Again we compute the variable Static for easy reference later + -- (note that no array attributes are static in Ada 83). + + -- We also need to set Static properly for subsequent legality checks + -- which might otherwise accept non-static constants in contexts + -- where they are not legal. + + Static := Ada_Version >= Ada_95 + and then Statically_Denotes_Entity (P); + + declare + N : Node_Id; + + begin + N := First_Index (P_Type); + + -- The expression is static if the array type is constrained + -- by given bounds, and not by an initial expression. Constant + -- strings are static in any case. + + if Root_Type (P_Type) /= Standard_String then + Static := + Static and then not Is_Constr_Subt_For_U_Nominal (P_Type); + end if; + + while Present (N) loop + Static := Static and then Is_Static_Subtype (Etype (N)); + + -- If however the index type is generic, or derived from + -- one, attributes cannot be folded. + + if Is_Generic_Type (Root_Type (Etype (N))) + and then Id /= Attribute_Component_Size + then + return; + end if; + + Next_Index (N); + end loop; + end; + end if; + + -- Check any expressions that are present. Note that these expressions, + -- depending on the particular attribute type, are either part of the + -- attribute designator, or they are arguments in a case where the + -- attribute reference returns a function. In the latter case, the + -- rule in (RM 4.9(22)) applies and in particular requires the type + -- of the expressions to be scalar in order for the attribute to be + -- considered to be static. + + declare + E : Node_Id; + + begin + E := E1; + while Present (E) loop + + -- If expression is not static, then the attribute reference + -- result certainly cannot be static. + + if not Is_Static_Expression (E) then + Static := False; + end if; + + -- If the result is not known at compile time, or is not of + -- a scalar type, then the result is definitely not static, + -- so we can quit now. + + if not Compile_Time_Known_Value (E) + or else not Is_Scalar_Type (Etype (E)) + then + -- An odd special case, if this is a Pos attribute, this + -- is where we need to apply a range check since it does + -- not get done anywhere else. + + if Id = Attribute_Pos then + if Is_Integer_Type (Etype (E)) then + Apply_Range_Check (E, Etype (N)); + end if; + end if; + + Check_Expressions; + return; + + -- If the expression raises a constraint error, then so does + -- the attribute reference. We keep going in this case because + -- we are still interested in whether the attribute reference + -- is static even if it is not static. + + elsif Raises_Constraint_Error (E) then + Set_Raises_Constraint_Error (N); + end if; + + Next (E); + end loop; + + if Raises_Constraint_Error (Prefix (N)) then + return; + end if; + end; + + -- Deal with the case of a static attribute reference that raises + -- constraint error. The Raises_Constraint_Error flag will already + -- have been set, and the Static flag shows whether the attribute + -- reference is static. In any case we certainly can't fold such an + -- attribute reference. + + -- Note that the rewriting of the attribute node with the constraint + -- error node is essential in this case, because otherwise Gigi might + -- blow up on one of the attributes it never expects to see. + + -- The constraint_error node must have the type imposed by the context, + -- to avoid spurious errors in the enclosing expression. + + if Raises_Constraint_Error (N) then + CE_Node := + Make_Raise_Constraint_Error (Sloc (N), + Reason => CE_Range_Check_Failed); + Set_Etype (CE_Node, Etype (N)); + Set_Raises_Constraint_Error (CE_Node); + Check_Expressions; + Rewrite (N, Relocate_Node (CE_Node)); + Set_Is_Static_Expression (N, Static); + return; + end if; + + -- At this point we have a potentially foldable attribute reference. + -- If Static is set, then the attribute reference definitely obeys + -- the requirements in (RM 4.9(7,8,22)), and it definitely can be + -- folded. If Static is not set, then the attribute may or may not + -- be foldable, and the individual attribute processing routines + -- test Static as required in cases where it makes a difference. + + -- In the case where Static is not set, we do know that all the + -- expressions present are at least known at compile time (we + -- assumed above that if this was not the case, then there was + -- no hope of static evaluation). However, we did not require + -- that the bounds of the prefix type be compile time known, + -- let alone static). That's because there are many attributes + -- that can be computed at compile time on non-static subtypes, + -- even though such references are not static expressions. + + case Id is + + -------------- + -- Adjacent -- + -------------- + + when Attribute_Adjacent => + Fold_Ureal (N, + Eval_Fat.Adjacent + (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static); + + --------- + -- Aft -- + --------- + + when Attribute_Aft => + Fold_Uint (N, Aft_Value (P_Type), True); + + --------------- + -- Alignment -- + --------------- + + when Attribute_Alignment => Alignment_Block : declare + P_TypeA : constant Entity_Id := Underlying_Type (P_Type); + + begin + -- Fold if alignment is set and not otherwise + + if Known_Alignment (P_TypeA) then + Fold_Uint (N, Alignment (P_TypeA), Is_Discrete_Type (P_TypeA)); + end if; + end Alignment_Block; + + --------------- + -- AST_Entry -- + --------------- + + -- Can only be folded in No_Ast_Handler case + + when Attribute_AST_Entry => + if not Is_AST_Entry (P_Entity) then + Rewrite (N, + New_Occurrence_Of (RTE (RE_No_AST_Handler), Loc)); + else + null; + end if; + + --------- + -- Bit -- + --------- + + -- Bit can never be folded + + when Attribute_Bit => + null; + + ------------------ + -- Body_Version -- + ------------------ + + -- Body_version can never be static + + when Attribute_Body_Version => + null; + + ------------- + -- Ceiling -- + ------------- + + when Attribute_Ceiling => + Fold_Ureal (N, + Eval_Fat.Ceiling (P_Root_Type, Expr_Value_R (E1)), Static); + + -------------------- + -- Component_Size -- + -------------------- + + when Attribute_Component_Size => + if Known_Static_Component_Size (P_Type) then + Fold_Uint (N, Component_Size (P_Type), False); + end if; + + ------------- + -- Compose -- + ------------- + + when Attribute_Compose => + Fold_Ureal (N, + Eval_Fat.Compose + (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)), + Static); + + ----------------- + -- Constrained -- + ----------------- + + -- Constrained is never folded for now, there may be cases that + -- could be handled at compile time. To be looked at later. + + when Attribute_Constrained => + null; + + --------------- + -- Copy_Sign -- + --------------- + + when Attribute_Copy_Sign => + Fold_Ureal (N, + Eval_Fat.Copy_Sign + (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static); + + ----------- + -- Delta -- + ----------- + + when Attribute_Delta => + Fold_Ureal (N, Delta_Value (P_Type), True); + + -------------- + -- Definite -- + -------------- + + when Attribute_Definite => + Rewrite (N, New_Occurrence_Of ( + Boolean_Literals (not Is_Indefinite_Subtype (P_Entity)), Loc)); + Analyze_And_Resolve (N, Standard_Boolean); + + ------------ + -- Denorm -- + ------------ + + when Attribute_Denorm => + Fold_Uint + (N, UI_From_Int (Boolean'Pos (Denorm_On_Target)), True); + + ------------ + -- Digits -- + ------------ + + when Attribute_Digits => + Fold_Uint (N, Digits_Value (P_Type), True); + + ---------- + -- Emax -- + ---------- + + when Attribute_Emax => + + -- Ada 83 attribute is defined as (RM83 3.5.8) + + -- T'Emax = 4 * T'Mantissa + + Fold_Uint (N, 4 * Mantissa, True); + + -------------- + -- Enum_Rep -- + -------------- + + when Attribute_Enum_Rep => + + -- For an enumeration type with a non-standard representation use + -- the Enumeration_Rep field of the proper constant. Note that this + -- will not work for types Character/Wide_[Wide-]Character, since no + -- real entities are created for the enumeration literals, but that + -- does not matter since these two types do not have non-standard + -- representations anyway. + + if Is_Enumeration_Type (P_Type) + and then Has_Non_Standard_Rep (P_Type) + then + Fold_Uint (N, Enumeration_Rep (Expr_Value_E (E1)), Static); + + -- For enumeration types with standard representations and all + -- other cases (i.e. all integer and modular types), Enum_Rep + -- is equivalent to Pos. + + else + Fold_Uint (N, Expr_Value (E1), Static); + end if; + + -------------- + -- Enum_Val -- + -------------- + + when Attribute_Enum_Val => Enum_Val : declare + Lit : Node_Id; + + begin + -- We have something like Enum_Type'Enum_Val (23), so search for a + -- corresponding value in the list of Enum_Rep values for the type. + + Lit := First_Literal (P_Base_Type); + loop + if Enumeration_Rep (Lit) = Expr_Value (E1) then + Fold_Uint (N, Enumeration_Pos (Lit), Static); + exit; + end if; + + Next_Literal (Lit); + + if No (Lit) then + Apply_Compile_Time_Constraint_Error + (N, "no representation value matches", + CE_Range_Check_Failed, + Warn => not Static); + exit; + end if; + end loop; + end Enum_Val; + + ------------- + -- Epsilon -- + ------------- + + when Attribute_Epsilon => + + -- Ada 83 attribute is defined as (RM83 3.5.8) + + -- T'Epsilon = 2.0**(1 - T'Mantissa) + + Fold_Ureal (N, Ureal_2 ** (1 - Mantissa), True); + + -------------- + -- Exponent -- + -------------- + + when Attribute_Exponent => + Fold_Uint (N, + Eval_Fat.Exponent (P_Root_Type, Expr_Value_R (E1)), Static); + + ----------- + -- First -- + ----------- + + when Attribute_First => First_Attr : + begin + Set_Bounds; + + if Compile_Time_Known_Value (Lo_Bound) then + if Is_Real_Type (P_Type) then + Fold_Ureal (N, Expr_Value_R (Lo_Bound), Static); + else + Fold_Uint (N, Expr_Value (Lo_Bound), Static); + end if; + + else + Check_Concurrent_Discriminant (Lo_Bound); + end if; + end First_Attr; + + ----------------- + -- Fixed_Value -- + ----------------- + + when Attribute_Fixed_Value => + null; + + ----------- + -- Floor -- + ----------- + + when Attribute_Floor => + Fold_Ureal (N, + Eval_Fat.Floor (P_Root_Type, Expr_Value_R (E1)), Static); + + ---------- + -- Fore -- + ---------- + + when Attribute_Fore => + if Compile_Time_Known_Bounds (P_Type) then + Fold_Uint (N, UI_From_Int (Fore_Value), Static); + end if; + + -------------- + -- Fraction -- + -------------- + + when Attribute_Fraction => + Fold_Ureal (N, + Eval_Fat.Fraction (P_Root_Type, Expr_Value_R (E1)), Static); + + ----------------------- + -- Has_Access_Values -- + ----------------------- + + when Attribute_Has_Access_Values => + Rewrite (N, New_Occurrence_Of + (Boolean_Literals (Has_Access_Values (P_Root_Type)), Loc)); + Analyze_And_Resolve (N, Standard_Boolean); + + ----------------------- + -- Has_Discriminants -- + ----------------------- + + when Attribute_Has_Discriminants => + Rewrite (N, New_Occurrence_Of ( + Boolean_Literals (Has_Discriminants (P_Entity)), Loc)); + Analyze_And_Resolve (N, Standard_Boolean); + + ----------------------- + -- Has_Tagged_Values -- + ----------------------- + + when Attribute_Has_Tagged_Values => + Rewrite (N, New_Occurrence_Of + (Boolean_Literals (Has_Tagged_Component (P_Root_Type)), Loc)); + Analyze_And_Resolve (N, Standard_Boolean); + + -------------- + -- Identity -- + -------------- + + when Attribute_Identity => + null; + + ----------- + -- Image -- + ----------- + + -- Image is a scalar attribute, but is never static, because it is + -- not a static function (having a non-scalar argument (RM 4.9(22)) + -- However, we can constant-fold the image of an enumeration literal + -- if names are available. + + when Attribute_Image => + if Is_Entity_Name (E1) + and then Ekind (Entity (E1)) = E_Enumeration_Literal + and then not Discard_Names (First_Subtype (Etype (E1))) + and then not Global_Discard_Names + then + declare + Lit : constant Entity_Id := Entity (E1); + Str : String_Id; + begin + Start_String; + Get_Unqualified_Decoded_Name_String (Chars (Lit)); + Set_Casing (All_Upper_Case); + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + Str := End_String; + Rewrite (N, Make_String_Literal (Loc, Strval => Str)); + Analyze_And_Resolve (N, Standard_String); + Set_Is_Static_Expression (N, False); + end; + end if; + + --------- + -- Img -- + --------- + + -- Img is a scalar attribute, but is never static, because it is + -- not a static function (having a non-scalar argument (RM 4.9(22)) + + when Attribute_Img => + null; + + ------------------- + -- Integer_Value -- + ------------------- + + -- We never try to fold Integer_Value (though perhaps we could???) + + when Attribute_Integer_Value => + null; + + ------------------- + -- Invalid_Value -- + ------------------- + + -- Invalid_Value is a scalar attribute that is never static, because + -- the value is by design out of range. + + when Attribute_Invalid_Value => + null; + + ----------- + -- Large -- + ----------- + + when Attribute_Large => + + -- For fixed-point, we use the identity: + + -- T'Large = (2.0**T'Mantissa - 1.0) * T'Small + + if Is_Fixed_Point_Type (P_Type) then + Rewrite (N, + Make_Op_Multiply (Loc, + Left_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Op_Expon (Loc, + Left_Opnd => + Make_Real_Literal (Loc, Ureal_2), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => P, + Attribute_Name => Name_Mantissa)), + Right_Opnd => Make_Real_Literal (Loc, Ureal_1)), + + Right_Opnd => + Make_Real_Literal (Loc, Small_Value (Entity (P))))); + + Analyze_And_Resolve (N, C_Type); + + -- Floating-point (Ada 83 compatibility) + + else + -- Ada 83 attribute is defined as (RM83 3.5.8) + + -- T'Large = 2.0**T'Emax * (1.0 - 2.0**(-T'Mantissa)) + + -- where + + -- T'Emax = 4 * T'Mantissa + + Fold_Ureal (N, + Ureal_2 ** (4 * Mantissa) * (Ureal_1 - Ureal_2 ** (-Mantissa)), + True); + end if; + + ---------- + -- Last -- + ---------- + + when Attribute_Last => Last : + begin + Set_Bounds; + + if Compile_Time_Known_Value (Hi_Bound) then + if Is_Real_Type (P_Type) then + Fold_Ureal (N, Expr_Value_R (Hi_Bound), Static); + else + Fold_Uint (N, Expr_Value (Hi_Bound), Static); + end if; + + else + Check_Concurrent_Discriminant (Hi_Bound); + end if; + end Last; + + ------------------ + -- Leading_Part -- + ------------------ + + when Attribute_Leading_Part => + Fold_Ureal (N, + Eval_Fat.Leading_Part + (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)), Static); + + ------------ + -- Length -- + ------------ + + when Attribute_Length => Length : declare + Ind : Node_Id; + + begin + -- If any index type is a formal type, or derived from one, the + -- bounds are not static. Treating them as static can produce + -- spurious warnings or improper constant folding. + + Ind := First_Index (P_Type); + while Present (Ind) loop + if Is_Generic_Type (Root_Type (Etype (Ind))) then + return; + end if; + + Next_Index (Ind); + end loop; + + Set_Bounds; + + -- For two compile time values, we can compute length + + if Compile_Time_Known_Value (Lo_Bound) + and then Compile_Time_Known_Value (Hi_Bound) + then + Fold_Uint (N, + UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound))), + True); + end if; + + -- One more case is where Hi_Bound and Lo_Bound are compile-time + -- comparable, and we can figure out the difference between them. + + declare + Diff : aliased Uint; + + begin + case + Compile_Time_Compare + (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False) + is + when EQ => + Fold_Uint (N, Uint_1, False); + + when GT => + Fold_Uint (N, Uint_0, False); + + when LT => + if Diff /= No_Uint then + Fold_Uint (N, Diff + 1, False); + end if; + + when others => + null; + end case; + end; + end Length; + + ------------- + -- Machine -- + ------------- + + when Attribute_Machine => + Fold_Ureal (N, + Eval_Fat.Machine + (P_Root_Type, Expr_Value_R (E1), Eval_Fat.Round, N), + Static); + + ------------------ + -- Machine_Emax -- + ------------------ + + when Attribute_Machine_Emax => + Fold_Uint (N, Machine_Emax_Value (P_Type), Static); + + ------------------ + -- Machine_Emin -- + ------------------ + + when Attribute_Machine_Emin => + Fold_Uint (N, Machine_Emin_Value (P_Type), Static); + + ---------------------- + -- Machine_Mantissa -- + ---------------------- + + when Attribute_Machine_Mantissa => + Fold_Uint (N, Machine_Mantissa_Value (P_Type), Static); + + ----------------------- + -- Machine_Overflows -- + ----------------------- + + when Attribute_Machine_Overflows => + + -- Always true for fixed-point + + if Is_Fixed_Point_Type (P_Type) then + Fold_Uint (N, True_Value, True); + + -- Floating point case + + else + Fold_Uint (N, + UI_From_Int (Boolean'Pos (Machine_Overflows_On_Target)), + True); + end if; + + ------------------- + -- Machine_Radix -- + ------------------- + + when Attribute_Machine_Radix => + if Is_Fixed_Point_Type (P_Type) then + if Is_Decimal_Fixed_Point_Type (P_Type) + and then Machine_Radix_10 (P_Type) + then + Fold_Uint (N, Uint_10, True); + else + Fold_Uint (N, Uint_2, True); + end if; + + -- All floating-point type always have radix 2 + + else + Fold_Uint (N, Uint_2, True); + end if; + + ---------------------- + -- Machine_Rounding -- + ---------------------- + + -- Note: for the folding case, it is fine to treat Machine_Rounding + -- exactly the same way as Rounding, since this is one of the allowed + -- behaviors, and performance is not an issue here. It might be a bit + -- better to give the same result as it would give at run time, even + -- though the non-determinism is certainly permitted. + + when Attribute_Machine_Rounding => + Fold_Ureal (N, + Eval_Fat.Rounding (P_Root_Type, Expr_Value_R (E1)), Static); + + -------------------- + -- Machine_Rounds -- + -------------------- + + when Attribute_Machine_Rounds => + + -- Always False for fixed-point + + if Is_Fixed_Point_Type (P_Type) then + Fold_Uint (N, False_Value, True); + + -- Else yield proper floating-point result + + else + Fold_Uint + (N, UI_From_Int (Boolean'Pos (Machine_Rounds_On_Target)), True); + end if; + + ------------------ + -- Machine_Size -- + ------------------ + + -- Note: Machine_Size is identical to Object_Size + + when Attribute_Machine_Size => Machine_Size : declare + P_TypeA : constant Entity_Id := Underlying_Type (P_Type); + + begin + if Known_Esize (P_TypeA) then + Fold_Uint (N, Esize (P_TypeA), True); + end if; + end Machine_Size; + + -------------- + -- Mantissa -- + -------------- + + when Attribute_Mantissa => + + -- Fixed-point mantissa + + if Is_Fixed_Point_Type (P_Type) then + + -- Compile time foldable case + + if Compile_Time_Known_Value (Type_Low_Bound (P_Type)) + and then + Compile_Time_Known_Value (Type_High_Bound (P_Type)) + then + -- The calculation of the obsolete Ada 83 attribute Mantissa + -- is annoying, because of AI00143, quoted here: + + -- !question 84-01-10 + + -- Consider the model numbers for F: + + -- type F is delta 1.0 range -7.0 .. 8.0; + + -- The wording requires that F'MANTISSA be the SMALLEST + -- integer number for which each bound of the specified + -- range is either a model number or lies at most small + -- distant from a model number. This means F'MANTISSA + -- is required to be 3 since the range -7.0 .. 7.0 fits + -- in 3 signed bits, and 8 is "at most" 1.0 from a model + -- number, namely, 7. Is this analysis correct? Note that + -- this implies the upper bound of the range is not + -- represented as a model number. + + -- !response 84-03-17 + + -- The analysis is correct. The upper and lower bounds for + -- a fixed point type can lie outside the range of model + -- numbers. + + declare + Siz : Uint; + LBound : Ureal; + UBound : Ureal; + Bound : Ureal; + Max_Man : Uint; + + begin + LBound := Expr_Value_R (Type_Low_Bound (P_Type)); + UBound := Expr_Value_R (Type_High_Bound (P_Type)); + Bound := UR_Max (UR_Abs (LBound), UR_Abs (UBound)); + Max_Man := UR_Trunc (Bound / Small_Value (P_Type)); + + -- If the Bound is exactly a model number, i.e. a multiple + -- of Small, then we back it off by one to get the integer + -- value that must be representable. + + if Small_Value (P_Type) * Max_Man = Bound then + Max_Man := Max_Man - 1; + end if; + + -- Now find corresponding size = Mantissa value + + Siz := Uint_0; + while 2 ** Siz < Max_Man loop + Siz := Siz + 1; + end loop; + + Fold_Uint (N, Siz, True); + end; + + else + -- The case of dynamic bounds cannot be evaluated at compile + -- time. Instead we use a runtime routine (see Exp_Attr). + + null; + end if; + + -- Floating-point Mantissa + + else + Fold_Uint (N, Mantissa, True); + end if; + + --------- + -- Max -- + --------- + + when Attribute_Max => Max : + begin + if Is_Real_Type (P_Type) then + Fold_Ureal + (N, UR_Max (Expr_Value_R (E1), Expr_Value_R (E2)), Static); + else + Fold_Uint (N, UI_Max (Expr_Value (E1), Expr_Value (E2)), Static); + end if; + end Max; + + ---------------------------------- + -- Max_Alignment_For_Allocation -- + ---------------------------------- + + -- Max_Alignment_For_Allocation is usually the Alignment. However, + -- arrays are allocated with dope, so we need to take into account both + -- the alignment of the array, which comes from the component alignment, + -- and the alignment of the dope. Also, if the alignment is unknown, we + -- use the max (it's OK to be pessimistic). + + when Attribute_Max_Alignment_For_Allocation => + declare + A : Uint := UI_From_Int (Ttypes.Maximum_Alignment); + begin + if Known_Alignment (P_Type) and then + (not Is_Array_Type (P_Type) or else Alignment (P_Type) > A) + then + A := Alignment (P_Type); + end if; + + Fold_Uint (N, A, Static); + end; + + ---------------------------------- + -- Max_Size_In_Storage_Elements -- + ---------------------------------- + + -- Max_Size_In_Storage_Elements is simply the Size rounded up to a + -- Storage_Unit boundary. We can fold any cases for which the size + -- is known by the front end. + + when Attribute_Max_Size_In_Storage_Elements => + if Known_Esize (P_Type) then + Fold_Uint (N, + (Esize (P_Type) + System_Storage_Unit - 1) / + System_Storage_Unit, + Static); + end if; + + -------------------- + -- Mechanism_Code -- + -------------------- + + when Attribute_Mechanism_Code => + declare + Val : Int; + Formal : Entity_Id; + Mech : Mechanism_Type; + + begin + if No (E1) then + Mech := Mechanism (P_Entity); + + else + Val := UI_To_Int (Expr_Value (E1)); + + Formal := First_Formal (P_Entity); + for J in 1 .. Val - 1 loop + Next_Formal (Formal); + end loop; + Mech := Mechanism (Formal); + end if; + + if Mech < 0 then + Fold_Uint (N, UI_From_Int (Int (-Mech)), True); + end if; + end; + + --------- + -- Min -- + --------- + + when Attribute_Min => Min : + begin + if Is_Real_Type (P_Type) then + Fold_Ureal + (N, UR_Min (Expr_Value_R (E1), Expr_Value_R (E2)), Static); + else + Fold_Uint + (N, UI_Min (Expr_Value (E1), Expr_Value (E2)), Static); + end if; + end Min; + + --------- + -- Mod -- + --------- + + when Attribute_Mod => + Fold_Uint + (N, UI_Mod (Expr_Value (E1), Modulus (P_Base_Type)), Static); + + ----------- + -- Model -- + ----------- + + when Attribute_Model => + Fold_Ureal (N, + Eval_Fat.Model (P_Root_Type, Expr_Value_R (E1)), Static); + + ---------------- + -- Model_Emin -- + ---------------- + + when Attribute_Model_Emin => + Fold_Uint (N, Model_Emin_Value (P_Base_Type), Static); + + ------------------- + -- Model_Epsilon -- + ------------------- + + when Attribute_Model_Epsilon => + Fold_Ureal (N, Model_Epsilon_Value (P_Base_Type), Static); + + -------------------- + -- Model_Mantissa -- + -------------------- + + when Attribute_Model_Mantissa => + Fold_Uint (N, Model_Mantissa_Value (P_Base_Type), Static); + + ----------------- + -- Model_Small -- + ----------------- + + when Attribute_Model_Small => + Fold_Ureal (N, Model_Small_Value (P_Base_Type), Static); + + ------------- + -- Modulus -- + ------------- + + when Attribute_Modulus => + Fold_Uint (N, Modulus (P_Type), True); + + -------------------- + -- Null_Parameter -- + -------------------- + + -- Cannot fold, we know the value sort of, but the whole point is + -- that there is no way to talk about this imaginary value except + -- by using the attribute, so we leave it the way it is. + + when Attribute_Null_Parameter => + null; + + ----------------- + -- Object_Size -- + ----------------- + + -- The Object_Size attribute for a type returns the Esize of the + -- type and can be folded if this value is known. + + when Attribute_Object_Size => Object_Size : declare + P_TypeA : constant Entity_Id := Underlying_Type (P_Type); + + begin + if Known_Esize (P_TypeA) then + Fold_Uint (N, Esize (P_TypeA), True); + end if; + end Object_Size; + + ------------------------- + -- Passed_By_Reference -- + ------------------------- + + -- Scalar types are never passed by reference + + when Attribute_Passed_By_Reference => + Fold_Uint (N, False_Value, True); + + --------- + -- Pos -- + --------- + + when Attribute_Pos => + Fold_Uint (N, Expr_Value (E1), True); + + ---------- + -- Pred -- + ---------- + + when Attribute_Pred => Pred : + begin + -- Floating-point case + + if Is_Floating_Point_Type (P_Type) then + Fold_Ureal (N, + Eval_Fat.Pred (P_Root_Type, Expr_Value_R (E1)), Static); + + -- Fixed-point case + + elsif Is_Fixed_Point_Type (P_Type) then + Fold_Ureal (N, + Expr_Value_R (E1) - Small_Value (P_Type), True); + + -- Modular integer case (wraps) + + elsif Is_Modular_Integer_Type (P_Type) then + Fold_Uint (N, (Expr_Value (E1) - 1) mod Modulus (P_Type), Static); + + -- Other scalar cases + + else + pragma Assert (Is_Scalar_Type (P_Type)); + + if Is_Enumeration_Type (P_Type) + and then Expr_Value (E1) = + Expr_Value (Type_Low_Bound (P_Base_Type)) + then + Apply_Compile_Time_Constraint_Error + (N, "Pred of `&''First`", + CE_Overflow_Check_Failed, + Ent => P_Base_Type, + Warn => not Static); + + Check_Expressions; + return; + end if; + + Fold_Uint (N, Expr_Value (E1) - 1, Static); + end if; + end Pred; + + ----------- + -- Range -- + ----------- + + -- No processing required, because by this stage, Range has been + -- replaced by First .. Last, so this branch can never be taken. + + when Attribute_Range => + raise Program_Error; + + ------------------ + -- Range_Length -- + ------------------ + + when Attribute_Range_Length => + Set_Bounds; + + -- Can fold if both bounds are compile time known + + if Compile_Time_Known_Value (Hi_Bound) + and then Compile_Time_Known_Value (Lo_Bound) + then + Fold_Uint (N, + UI_Max + (0, Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound) + 1), + Static); + end if; + + -- One more case is where Hi_Bound and Lo_Bound are compile-time + -- comparable, and we can figure out the difference between them. + + declare + Diff : aliased Uint; + + begin + case + Compile_Time_Compare + (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False) + is + when EQ => + Fold_Uint (N, Uint_1, False); + + when GT => + Fold_Uint (N, Uint_0, False); + + when LT => + if Diff /= No_Uint then + Fold_Uint (N, Diff + 1, False); + end if; + + when others => + null; + end case; + end; + + --------- + -- Ref -- + --------- + + when Attribute_Ref => + Fold_Uint (N, Expr_Value (E1), True); + + --------------- + -- Remainder -- + --------------- + + when Attribute_Remainder => Remainder : declare + X : constant Ureal := Expr_Value_R (E1); + Y : constant Ureal := Expr_Value_R (E2); + + begin + if UR_Is_Zero (Y) then + Apply_Compile_Time_Constraint_Error + (N, "division by zero in Remainder", + CE_Overflow_Check_Failed, + Warn => not Static); + + Check_Expressions; + return; + end if; + + Fold_Ureal (N, Eval_Fat.Remainder (P_Root_Type, X, Y), Static); + end Remainder; + + ----------- + -- Round -- + ----------- + + when Attribute_Round => Round : + declare + Sr : Ureal; + Si : Uint; + + begin + -- First we get the (exact result) in units of small + + Sr := Expr_Value_R (E1) / Small_Value (C_Type); + + -- Now round that exactly to an integer + + Si := UR_To_Uint (Sr); + + -- Finally the result is obtained by converting back to real + + Fold_Ureal (N, Si * Small_Value (C_Type), Static); + end Round; + + -------------- + -- Rounding -- + -------------- + + when Attribute_Rounding => + Fold_Ureal (N, + Eval_Fat.Rounding (P_Root_Type, Expr_Value_R (E1)), Static); + + --------------- + -- Safe_Emax -- + --------------- + + when Attribute_Safe_Emax => + Fold_Uint (N, Safe_Emax_Value (P_Type), Static); + + ---------------- + -- Safe_First -- + ---------------- + + when Attribute_Safe_First => + Fold_Ureal (N, Safe_First_Value (P_Type), Static); + + ---------------- + -- Safe_Large -- + ---------------- + + when Attribute_Safe_Large => + if Is_Fixed_Point_Type (P_Type) then + Fold_Ureal + (N, Expr_Value_R (Type_High_Bound (P_Base_Type)), Static); + else + Fold_Ureal (N, Safe_Last_Value (P_Type), Static); + end if; + + --------------- + -- Safe_Last -- + --------------- + + when Attribute_Safe_Last => + Fold_Ureal (N, Safe_Last_Value (P_Type), Static); + + ---------------- + -- Safe_Small -- + ---------------- + + when Attribute_Safe_Small => + + -- In Ada 95, the old Ada 83 attribute Safe_Small is redundant + -- for fixed-point, since is the same as Small, but we implement + -- it for backwards compatibility. + + if Is_Fixed_Point_Type (P_Type) then + Fold_Ureal (N, Small_Value (P_Type), Static); + + -- Ada 83 Safe_Small for floating-point cases + + else + Fold_Ureal (N, Model_Small_Value (P_Type), Static); + end if; + + ----------- + -- Scale -- + ----------- + + when Attribute_Scale => + Fold_Uint (N, Scale_Value (P_Type), True); + + ------------- + -- Scaling -- + ------------- + + when Attribute_Scaling => + Fold_Ureal (N, + Eval_Fat.Scaling + (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)), Static); + + ------------------ + -- Signed_Zeros -- + ------------------ + + when Attribute_Signed_Zeros => + Fold_Uint + (N, UI_From_Int (Boolean'Pos (Signed_Zeros_On_Target)), Static); + + ---------- + -- Size -- + ---------- + + -- Size attribute returns the RM size. All scalar types can be folded, + -- as well as any types for which the size is known by the front end, + -- including any type for which a size attribute is specified. + + when Attribute_Size | Attribute_VADS_Size => Size : declare + P_TypeA : constant Entity_Id := Underlying_Type (P_Type); + + begin + if RM_Size (P_TypeA) /= Uint_0 then + + -- VADS_Size case + + if Id = Attribute_VADS_Size or else Use_VADS_Size then + declare + S : constant Node_Id := Size_Clause (P_TypeA); + + begin + -- If a size clause applies, then use the size from it. + -- This is one of the rare cases where we can use the + -- Size_Clause field for a subtype when Has_Size_Clause + -- is False. Consider: + + -- type x is range 1 .. 64; + -- for x'size use 12; + -- subtype y is x range 0 .. 3; + + -- Here y has a size clause inherited from x, but normally + -- it does not apply, and y'size is 2. However, y'VADS_Size + -- is indeed 12 and not 2. + + if Present (S) + and then Is_OK_Static_Expression (Expression (S)) + then + Fold_Uint (N, Expr_Value (Expression (S)), True); + + -- If no size is specified, then we simply use the object + -- size in the VADS_Size case (e.g. Natural'Size is equal + -- to Integer'Size, not one less). + + else + Fold_Uint (N, Esize (P_TypeA), True); + end if; + end; + + -- Normal case (Size) in which case we want the RM_Size + + else + Fold_Uint (N, + RM_Size (P_TypeA), + Static and then Is_Discrete_Type (P_TypeA)); + end if; + end if; + end Size; + + ----------- + -- Small -- + ----------- + + when Attribute_Small => + + -- The floating-point case is present only for Ada 83 compatibility. + -- Note that strictly this is an illegal addition, since we are + -- extending an Ada 95 defined attribute, but we anticipate an + -- ARG ruling that will permit this. + + if Is_Floating_Point_Type (P_Type) then + + -- Ada 83 attribute is defined as (RM83 3.5.8) + + -- T'Small = 2.0**(-T'Emax - 1) + + -- where + + -- T'Emax = 4 * T'Mantissa + + Fold_Ureal (N, Ureal_2 ** ((-(4 * Mantissa)) - 1), Static); + + -- Normal Ada 95 fixed-point case + + else + Fold_Ureal (N, Small_Value (P_Type), True); + end if; + + ----------------- + -- Stream_Size -- + ----------------- + + when Attribute_Stream_Size => + null; + + ---------- + -- Succ -- + ---------- + + when Attribute_Succ => Succ : + begin + -- Floating-point case + + if Is_Floating_Point_Type (P_Type) then + Fold_Ureal (N, + Eval_Fat.Succ (P_Root_Type, Expr_Value_R (E1)), Static); + + -- Fixed-point case + + elsif Is_Fixed_Point_Type (P_Type) then + Fold_Ureal (N, + Expr_Value_R (E1) + Small_Value (P_Type), Static); + + -- Modular integer case (wraps) + + elsif Is_Modular_Integer_Type (P_Type) then + Fold_Uint (N, (Expr_Value (E1) + 1) mod Modulus (P_Type), Static); + + -- Other scalar cases + + else + pragma Assert (Is_Scalar_Type (P_Type)); + + if Is_Enumeration_Type (P_Type) + and then Expr_Value (E1) = + Expr_Value (Type_High_Bound (P_Base_Type)) + then + Apply_Compile_Time_Constraint_Error + (N, "Succ of `&''Last`", + CE_Overflow_Check_Failed, + Ent => P_Base_Type, + Warn => not Static); + + Check_Expressions; + return; + else + Fold_Uint (N, Expr_Value (E1) + 1, Static); + end if; + end if; + end Succ; + + ---------------- + -- Truncation -- + ---------------- + + when Attribute_Truncation => + Fold_Ureal (N, + Eval_Fat.Truncation (P_Root_Type, Expr_Value_R (E1)), Static); + + ---------------- + -- Type_Class -- + ---------------- + + when Attribute_Type_Class => Type_Class : declare + Typ : constant Entity_Id := Underlying_Type (P_Base_Type); + Id : RE_Id; + + begin + if Is_Descendent_Of_Address (Typ) then + Id := RE_Type_Class_Address; + + elsif Is_Enumeration_Type (Typ) then + Id := RE_Type_Class_Enumeration; + + elsif Is_Integer_Type (Typ) then + Id := RE_Type_Class_Integer; + + elsif Is_Fixed_Point_Type (Typ) then + Id := RE_Type_Class_Fixed_Point; + + elsif Is_Floating_Point_Type (Typ) then + Id := RE_Type_Class_Floating_Point; + + elsif Is_Array_Type (Typ) then + Id := RE_Type_Class_Array; + + elsif Is_Record_Type (Typ) then + Id := RE_Type_Class_Record; + + elsif Is_Access_Type (Typ) then + Id := RE_Type_Class_Access; + + elsif Is_Enumeration_Type (Typ) then + Id := RE_Type_Class_Enumeration; + + elsif Is_Task_Type (Typ) then + Id := RE_Type_Class_Task; + + -- We treat protected types like task types. It would make more + -- sense to have another enumeration value, but after all the + -- whole point of this feature is to be exactly DEC compatible, + -- and changing the type Type_Class would not meet this requirement. + + elsif Is_Protected_Type (Typ) then + Id := RE_Type_Class_Task; + + -- Not clear if there are any other possibilities, but if there + -- are, then we will treat them as the address case. + + else + Id := RE_Type_Class_Address; + end if; + + Rewrite (N, New_Occurrence_Of (RTE (Id), Loc)); + end Type_Class; + + ----------------------- + -- Unbiased_Rounding -- + ----------------------- + + when Attribute_Unbiased_Rounding => + Fold_Ureal (N, + Eval_Fat.Unbiased_Rounding (P_Root_Type, Expr_Value_R (E1)), + Static); + + ------------------------- + -- Unconstrained_Array -- + ------------------------- + + when Attribute_Unconstrained_Array => Unconstrained_Array : declare + Typ : constant Entity_Id := Underlying_Type (P_Type); + + begin + Rewrite (N, New_Occurrence_Of ( + Boolean_Literals ( + Is_Array_Type (P_Type) + and then not Is_Constrained (Typ)), Loc)); + + -- Analyze and resolve as boolean, note that this attribute is + -- a static attribute in GNAT. + + Analyze_And_Resolve (N, Standard_Boolean); + Static := True; + end Unconstrained_Array; + + --------------- + -- VADS_Size -- + --------------- + + -- Processing is shared with Size + + --------- + -- Val -- + --------- + + when Attribute_Val => Val : + begin + if Expr_Value (E1) < Expr_Value (Type_Low_Bound (P_Base_Type)) + or else + Expr_Value (E1) > Expr_Value (Type_High_Bound (P_Base_Type)) + then + Apply_Compile_Time_Constraint_Error + (N, "Val expression out of range", + CE_Range_Check_Failed, + Warn => not Static); + + Check_Expressions; + return; + + else + Fold_Uint (N, Expr_Value (E1), Static); + end if; + end Val; + + ---------------- + -- Value_Size -- + ---------------- + + -- The Value_Size attribute for a type returns the RM size of the + -- type. This an always be folded for scalar types, and can also + -- be folded for non-scalar types if the size is set. + + when Attribute_Value_Size => Value_Size : declare + P_TypeA : constant Entity_Id := Underlying_Type (P_Type); + begin + if RM_Size (P_TypeA) /= Uint_0 then + Fold_Uint (N, RM_Size (P_TypeA), True); + end if; + end Value_Size; + + ------------- + -- Version -- + ------------- + + -- Version can never be static + + when Attribute_Version => + null; + + ---------------- + -- Wide_Image -- + ---------------- + + -- Wide_Image is a scalar attribute, but is never static, because it + -- is not a static function (having a non-scalar argument (RM 4.9(22)) + + when Attribute_Wide_Image => + null; + + --------------------- + -- Wide_Wide_Image -- + --------------------- + + -- Wide_Wide_Image is a scalar attribute but is never static, because it + -- is not a static function (having a non-scalar argument (RM 4.9(22)). + + when Attribute_Wide_Wide_Image => + null; + + --------------------- + -- Wide_Wide_Width -- + --------------------- + + -- Processing for Wide_Wide_Width is combined with Width + + ---------------- + -- Wide_Width -- + ---------------- + + -- Processing for Wide_Width is combined with Width + + ----------- + -- Width -- + ----------- + + -- This processing also handles the case of Wide_[Wide_]Width + + when Attribute_Width | + Attribute_Wide_Width | + Attribute_Wide_Wide_Width => Width : + begin + if Compile_Time_Known_Bounds (P_Type) then + + -- Floating-point types + + if Is_Floating_Point_Type (P_Type) then + + -- Width is zero for a null range (RM 3.5 (38)) + + if Expr_Value_R (Type_High_Bound (P_Type)) < + Expr_Value_R (Type_Low_Bound (P_Type)) + then + Fold_Uint (N, Uint_0, True); + + else + -- For floating-point, we have +N.dddE+nnn where length + -- of ddd is determined by type'Digits - 1, but is one + -- if Digits is one (RM 3.5 (33)). + + -- nnn is set to 2 for Short_Float and Float (32 bit + -- floats), and 3 for Long_Float and Long_Long_Float. + -- For machines where Long_Long_Float is the IEEE + -- extended precision type, the exponent takes 4 digits. + + declare + Len : Int := + Int'Max (2, UI_To_Int (Digits_Value (P_Type))); + + begin + if Esize (P_Type) <= 32 then + Len := Len + 6; + elsif Esize (P_Type) = 64 then + Len := Len + 7; + else + Len := Len + 8; + end if; + + Fold_Uint (N, UI_From_Int (Len), True); + end; + end if; + + -- Fixed-point types + + elsif Is_Fixed_Point_Type (P_Type) then + + -- Width is zero for a null range (RM 3.5 (38)) + + if Expr_Value (Type_High_Bound (P_Type)) < + Expr_Value (Type_Low_Bound (P_Type)) + then + Fold_Uint (N, Uint_0, True); + + -- The non-null case depends on the specific real type + + else + -- For fixed-point type width is Fore + 1 + Aft (RM 3.5(34)) + + Fold_Uint + (N, UI_From_Int (Fore_Value + 1) + Aft_Value (P_Type), + True); + end if; + + -- Discrete types + + else + declare + R : constant Entity_Id := Root_Type (P_Type); + Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type)); + Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type)); + W : Nat; + Wt : Nat; + T : Uint; + L : Node_Id; + C : Character; + + begin + -- Empty ranges + + if Lo > Hi then + W := 0; + + -- Width for types derived from Standard.Character + -- and Standard.Wide_[Wide_]Character. + + elsif Is_Standard_Character_Type (P_Type) then + W := 0; + + -- Set W larger if needed + + for J in UI_To_Int (Lo) .. UI_To_Int (Hi) loop + + -- All wide characters look like Hex_hhhhhhhh + + if J > 255 then + + -- No need to compute this more than once! + + exit; + + else + C := Character'Val (J); + + -- Test for all cases where Character'Image + -- yields an image that is longer than three + -- characters. First the cases of Reserved_xxx + -- names (length = 12). + + case C is + when Reserved_128 | Reserved_129 | + Reserved_132 | Reserved_153 + => Wt := 12; + + when BS | HT | LF | VT | FF | CR | + SO | SI | EM | FS | GS | RS | + US | RI | MW | ST | PM + => Wt := 2; + + when NUL | SOH | STX | ETX | EOT | + ENQ | ACK | BEL | DLE | DC1 | + DC2 | DC3 | DC4 | NAK | SYN | + ETB | CAN | SUB | ESC | DEL | + BPH | NBH | NEL | SSA | ESA | + HTS | HTJ | VTS | PLD | PLU | + SS2 | SS3 | DCS | PU1 | PU2 | + STS | CCH | SPA | EPA | SOS | + SCI | CSI | OSC | APC + => Wt := 3; + + when Space .. Tilde | + No_Break_Space .. LC_Y_Diaeresis + => + -- Special case of soft hyphen in Ada 2005 + + if C = Character'Val (16#AD#) + and then Ada_Version >= Ada_2005 + then + Wt := 11; + else + Wt := 3; + end if; + end case; + + W := Int'Max (W, Wt); + end if; + end loop; + + -- Width for types derived from Standard.Boolean + + elsif R = Standard_Boolean then + if Lo = 0 then + W := 5; -- FALSE + else + W := 4; -- TRUE + end if; + + -- Width for integer types + + elsif Is_Integer_Type (P_Type) then + T := UI_Max (abs Lo, abs Hi); + + W := 2; + while T >= 10 loop + W := W + 1; + T := T / 10; + end loop; + + -- Only remaining possibility is user declared enum type + + else + pragma Assert (Is_Enumeration_Type (P_Type)); + + W := 0; + L := First_Literal (P_Type); + + while Present (L) loop + + -- Only pay attention to in range characters + + if Lo <= Enumeration_Pos (L) + and then Enumeration_Pos (L) <= Hi + then + -- For Width case, use decoded name + + if Id = Attribute_Width then + Get_Decoded_Name_String (Chars (L)); + Wt := Nat (Name_Len); + + -- For Wide_[Wide_]Width, use encoded name, and + -- then adjust for the encoding. + + else + Get_Name_String (Chars (L)); + + -- Character literals are always of length 3 + + if Name_Buffer (1) = 'Q' then + Wt := 3; + + -- Otherwise loop to adjust for upper/wide chars + + else + Wt := Nat (Name_Len); + + for J in 1 .. Name_Len loop + if Name_Buffer (J) = 'U' then + Wt := Wt - 2; + elsif Name_Buffer (J) = 'W' then + Wt := Wt - 4; + end if; + end loop; + end if; + end if; + + W := Int'Max (W, Wt); + end if; + + Next_Literal (L); + end loop; + end if; + + Fold_Uint (N, UI_From_Int (W), True); + end; + end if; + end if; + end Width; + + -- The following attributes denote functions that cannot be folded + + when Attribute_From_Any | + Attribute_To_Any | + Attribute_TypeCode => + null; + + -- The following attributes can never be folded, and furthermore we + -- should not even have entered the case statement for any of these. + -- Note that in some cases, the values have already been folded as + -- a result of the processing in Analyze_Attribute. + + when Attribute_Abort_Signal | + Attribute_Access | + Attribute_Address | + Attribute_Address_Size | + Attribute_Asm_Input | + Attribute_Asm_Output | + Attribute_Base | + Attribute_Bit_Order | + Attribute_Bit_Position | + Attribute_Callable | + Attribute_Caller | + Attribute_Class | + Attribute_Code_Address | + Attribute_Compiler_Version | + Attribute_Count | + Attribute_Default_Bit_Order | + Attribute_Elaborated | + Attribute_Elab_Body | + Attribute_Elab_Spec | + Attribute_Enabled | + Attribute_External_Tag | + Attribute_Fast_Math | + Attribute_First_Bit | + Attribute_Input | + Attribute_Last_Bit | + Attribute_Maximum_Alignment | + Attribute_Old | + Attribute_Output | + Attribute_Partition_ID | + Attribute_Pool_Address | + Attribute_Position | + Attribute_Priority | + Attribute_Read | + Attribute_Result | + Attribute_Storage_Pool | + Attribute_Storage_Size | + Attribute_Storage_Unit | + Attribute_Stub_Type | + Attribute_Tag | + Attribute_Target_Name | + Attribute_Terminated | + Attribute_To_Address | + Attribute_Type_Key | + Attribute_UET_Address | + Attribute_Unchecked_Access | + Attribute_Universal_Literal_String | + Attribute_Unrestricted_Access | + Attribute_Valid | + Attribute_Value | + Attribute_Wchar_T_Size | + Attribute_Wide_Value | + Attribute_Wide_Wide_Value | + Attribute_Word_Size | + Attribute_Write => + + raise Program_Error; + end case; + + -- At the end of the case, one more check. If we did a static evaluation + -- so that the result is now a literal, then set Is_Static_Expression + -- in the constant only if the prefix type is a static subtype. For + -- non-static subtypes, the folding is still OK, but not static. + + -- An exception is the GNAT attribute Constrained_Array which is + -- defined to be a static attribute in all cases. + + if Nkind_In (N, N_Integer_Literal, + N_Real_Literal, + N_Character_Literal, + N_String_Literal) + or else (Is_Entity_Name (N) + and then Ekind (Entity (N)) = E_Enumeration_Literal) + then + Set_Is_Static_Expression (N, Static); + + -- If this is still an attribute reference, then it has not been folded + -- and that means that its expressions are in a non-static context. + + elsif Nkind (N) = N_Attribute_Reference then + Check_Expressions; + + -- Note: the else case not covered here are odd cases where the + -- processing has transformed the attribute into something other + -- than a constant. Nothing more to do in such cases. + + else + null; + end if; + end Eval_Attribute; + + ------------------------------ + -- Is_Anonymous_Tagged_Base -- + ------------------------------ + + function Is_Anonymous_Tagged_Base + (Anon : Entity_Id; + Typ : Entity_Id) + return Boolean + is + begin + return + Anon = Current_Scope + and then Is_Itype (Anon) + and then Associated_Node_For_Itype (Anon) = Parent (Typ); + end Is_Anonymous_Tagged_Base; + + -------------------------------- + -- Name_Implies_Lvalue_Prefix -- + -------------------------------- + + function Name_Implies_Lvalue_Prefix (Nam : Name_Id) return Boolean is + pragma Assert (Is_Attribute_Name (Nam)); + begin + return Attribute_Name_Implies_Lvalue_Prefix (Get_Attribute_Id (Nam)); + end Name_Implies_Lvalue_Prefix; + + ----------------------- + -- Resolve_Attribute -- + ----------------------- + + procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + P : constant Node_Id := Prefix (N); + Aname : constant Name_Id := Attribute_Name (N); + Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname); + Btyp : constant Entity_Id := Base_Type (Typ); + Des_Btyp : Entity_Id; + Index : Interp_Index; + It : Interp; + Nom_Subt : Entity_Id; + + procedure Accessibility_Message; + -- Error, or warning within an instance, if the static accessibility + -- rules of 3.10.2 are violated. + + --------------------------- + -- Accessibility_Message -- + --------------------------- + + procedure Accessibility_Message is + Indic : Node_Id := Parent (Parent (N)); + + begin + -- In an instance, this is a runtime check, but one we + -- know will fail, so generate an appropriate warning. + + if In_Instance_Body then + Error_Msg_F ("?non-local pointer cannot point to local object", P); + Error_Msg_F + ("\?Program_Error will be raised at run time", P); + Rewrite (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Accessibility_Check_Failed)); + Set_Etype (N, Typ); + return; + + else + Error_Msg_F ("non-local pointer cannot point to local object", P); + + -- Check for case where we have a missing access definition + + if Is_Record_Type (Current_Scope) + and then + Nkind_In (Parent (N), N_Discriminant_Association, + N_Index_Or_Discriminant_Constraint) + then + Indic := Parent (Parent (N)); + while Present (Indic) + and then Nkind (Indic) /= N_Subtype_Indication + loop + Indic := Parent (Indic); + end loop; + + if Present (Indic) then + Error_Msg_NE + ("\use an access definition for" & + " the access discriminant of&", + N, Entity (Subtype_Mark (Indic))); + end if; + end if; + end if; + end Accessibility_Message; + + -- Start of processing for Resolve_Attribute + + begin + -- If error during analysis, no point in continuing, except for array + -- types, where we get better recovery by using unconstrained indexes + -- than nothing at all (see Check_Array_Type). + + if Error_Posted (N) + and then Attr_Id /= Attribute_First + and then Attr_Id /= Attribute_Last + and then Attr_Id /= Attribute_Length + and then Attr_Id /= Attribute_Range + then + return; + end if; + + -- If attribute was universal type, reset to actual type + + if Etype (N) = Universal_Integer + or else Etype (N) = Universal_Real + then + Set_Etype (N, Typ); + end if; + + -- Remaining processing depends on attribute + + case Attr_Id is + + ------------ + -- Access -- + ------------ + + -- For access attributes, if the prefix denotes an entity, it is + -- interpreted as a name, never as a call. It may be overloaded, + -- in which case resolution uses the profile of the context type. + -- Otherwise prefix must be resolved. + + when Attribute_Access + | Attribute_Unchecked_Access + | Attribute_Unrestricted_Access => + + Access_Attribute : + begin + if Is_Variable (P) then + Note_Possible_Modification (P, Sure => False); + end if; + + -- The following comes from a query by Adam Beneschan, concerning + -- improper use of universal_access in equality tests involving + -- anonymous access types. Another good reason for 'Ref, but + -- for now disable the test, which breaks several filed tests. + + if Ekind (Typ) = E_Anonymous_Access_Type + and then Nkind_In (Parent (N), N_Op_Eq, N_Op_Ne) + and then False + then + Error_Msg_N ("need unique type to resolve 'Access", N); + Error_Msg_N ("\qualify attribute with some access type", N); + end if; + + if Is_Entity_Name (P) then + if Is_Overloaded (P) then + Get_First_Interp (P, Index, It); + while Present (It.Nam) loop + if Type_Conformant (Designated_Type (Typ), It.Nam) then + Set_Entity (P, It.Nam); + + -- The prefix is definitely NOT overloaded anymore at + -- this point, so we reset the Is_Overloaded flag to + -- avoid any confusion when reanalyzing the node. + + Set_Is_Overloaded (P, False); + Set_Is_Overloaded (N, False); + Generate_Reference (Entity (P), P); + exit; + end if; + + Get_Next_Interp (Index, It); + end loop; + + -- If Prefix is a subprogram name, it is frozen by this + -- reference: + + -- If it is a type, there is nothing to resolve. + -- If it is an object, complete its resolution. + + elsif Is_Overloadable (Entity (P)) then + + -- Avoid insertion of freeze actions in spec expression mode + + if not In_Spec_Expression then + Freeze_Before (N, Entity (P)); + end if; + + elsif Is_Type (Entity (P)) then + null; + else + Resolve (P); + end if; + + Error_Msg_Name_1 := Aname; + + if not Is_Entity_Name (P) then + null; + + elsif Is_Overloadable (Entity (P)) + and then Is_Abstract_Subprogram (Entity (P)) + then + Error_Msg_F ("prefix of % attribute cannot be abstract", P); + Set_Etype (N, Any_Type); + + elsif Convention (Entity (P)) = Convention_Intrinsic then + if Ekind (Entity (P)) = E_Enumeration_Literal then + Error_Msg_F + ("prefix of % attribute cannot be enumeration literal", + P); + else + Error_Msg_F + ("prefix of % attribute cannot be intrinsic", P); + end if; + + Set_Etype (N, Any_Type); + end if; + + -- Assignments, return statements, components of aggregates, + -- generic instantiations will require convention checks if + -- the type is an access to subprogram. Given that there will + -- also be accessibility checks on those, this is where the + -- checks can eventually be centralized ??? + + if Ekind_In (Btyp, E_Access_Subprogram_Type, + E_Anonymous_Access_Subprogram_Type, + E_Anonymous_Access_Protected_Subprogram_Type) + then + -- Deal with convention mismatch + + if Convention (Btyp) /= Convention (Entity (P)) then + Error_Msg_FE + ("subprogram & has wrong convention", P, Entity (P)); + + Error_Msg_FE + ("\does not match convention of access type &", + P, Btyp); + + if not Has_Convention_Pragma (Btyp) then + Error_Msg_FE + ("\probable missing pragma Convention for &", + P, Btyp); + end if; + + else + Check_Subtype_Conformant + (New_Id => Entity (P), + Old_Id => Designated_Type (Btyp), + Err_Loc => P); + end if; + + if Attr_Id = Attribute_Unchecked_Access then + Error_Msg_Name_1 := Aname; + Error_Msg_F + ("attribute% cannot be applied to a subprogram", P); + + elsif Aname = Name_Unrestricted_Access then + null; -- Nothing to check + + -- Check the static accessibility rule of 3.10.2(32). + -- This rule also applies within the private part of an + -- instantiation. This rule does not apply to anonymous + -- access-to-subprogram types in access parameters. + + elsif Attr_Id = Attribute_Access + and then not In_Instance_Body + and then + (Ekind (Btyp) = E_Access_Subprogram_Type + or else Is_Local_Anonymous_Access (Btyp)) + + and then Subprogram_Access_Level (Entity (P)) > + Type_Access_Level (Btyp) + then + Error_Msg_F + ("subprogram must not be deeper than access type", P); + + -- Check the restriction of 3.10.2(32) that disallows the + -- access attribute within a generic body when the ultimate + -- ancestor of the type of the attribute is declared outside + -- of the generic unit and the subprogram is declared within + -- that generic unit. This includes any such attribute that + -- occurs within the body of a generic unit that is a child + -- of the generic unit where the subprogram is declared. + + -- The rule also prohibits applying the attribute when the + -- access type is a generic formal access type (since the + -- level of the actual type is not known). This restriction + -- does not apply when the attribute type is an anonymous + -- access-to-subprogram type. Note that this check was + -- revised by AI-229, because the originally Ada 95 rule + -- was too lax. The original rule only applied when the + -- subprogram was declared within the body of the generic, + -- which allowed the possibility of dangling references). + -- The rule was also too strict in some case, in that it + -- didn't permit the access to be declared in the generic + -- spec, whereas the revised rule does (as long as it's not + -- a formal type). + + -- There are a couple of subtleties of the test for applying + -- the check that are worth noting. First, we only apply it + -- when the levels of the subprogram and access type are the + -- same (the case where the subprogram is statically deeper + -- was applied above, and the case where the type is deeper + -- is always safe). Second, we want the check to apply + -- within nested generic bodies and generic child unit + -- bodies, but not to apply to an attribute that appears in + -- the generic unit's specification. This is done by testing + -- that the attribute's innermost enclosing generic body is + -- not the same as the innermost generic body enclosing the + -- generic unit where the subprogram is declared (we don't + -- want the check to apply when the access attribute is in + -- the spec and there's some other generic body enclosing + -- generic). Finally, there's no point applying the check + -- when within an instance, because any violations will have + -- been caught by the compilation of the generic unit. + + -- Note that we relax this check in CodePeer mode for + -- compatibility with legacy code, since CodePeer is an + -- Ada source code analyzer, not a strict compiler. + -- ??? Note that a better approach would be to have a + -- separate switch to relax this rule, and enable this + -- switch in CodePeer mode. + + elsif Attr_Id = Attribute_Access + and then not CodePeer_Mode + and then not In_Instance + and then Present (Enclosing_Generic_Unit (Entity (P))) + and then Present (Enclosing_Generic_Body (N)) + and then Enclosing_Generic_Body (N) /= + Enclosing_Generic_Body + (Enclosing_Generic_Unit (Entity (P))) + and then Subprogram_Access_Level (Entity (P)) = + Type_Access_Level (Btyp) + and then Ekind (Btyp) /= + E_Anonymous_Access_Subprogram_Type + and then Ekind (Btyp) /= + E_Anonymous_Access_Protected_Subprogram_Type + then + -- The attribute type's ultimate ancestor must be + -- declared within the same generic unit as the + -- subprogram is declared. The error message is + -- specialized to say "ancestor" for the case where the + -- access type is not its own ancestor, since saying + -- simply "access type" would be very confusing. + + if Enclosing_Generic_Unit (Entity (P)) /= + Enclosing_Generic_Unit (Root_Type (Btyp)) + then + Error_Msg_N + ("''Access attribute not allowed in generic body", + N); + + if Root_Type (Btyp) = Btyp then + Error_Msg_NE + ("\because " & + "access type & is declared outside " & + "generic unit (RM 3.10.2(32))", N, Btyp); + else + Error_Msg_NE + ("\because ancestor of " & + "access type & is declared outside " & + "generic unit (RM 3.10.2(32))", N, Btyp); + end if; + + Error_Msg_NE + ("\move ''Access to private part, or " & + "(Ada 2005) use anonymous access type instead of &", + N, Btyp); + + -- If the ultimate ancestor of the attribute's type is + -- a formal type, then the attribute is illegal because + -- the actual type might be declared at a higher level. + -- The error message is specialized to say "ancestor" + -- for the case where the access type is not its own + -- ancestor, since saying simply "access type" would be + -- very confusing. + + elsif Is_Generic_Type (Root_Type (Btyp)) then + if Root_Type (Btyp) = Btyp then + Error_Msg_N + ("access type must not be a generic formal type", + N); + else + Error_Msg_N + ("ancestor access type must not be a generic " & + "formal type", N); + end if; + end if; + end if; + end if; + + -- If this is a renaming, an inherited operation, or a + -- subprogram instance, use the original entity. This may make + -- the node type-inconsistent, so this transformation can only + -- be done if the node will not be reanalyzed. In particular, + -- if it is within a default expression, the transformation + -- must be delayed until the default subprogram is created for + -- it, when the enclosing subprogram is frozen. + + if Is_Entity_Name (P) + and then Is_Overloadable (Entity (P)) + and then Present (Alias (Entity (P))) + and then Expander_Active + then + Rewrite (P, + New_Occurrence_Of (Alias (Entity (P)), Sloc (P))); + end if; + + elsif Nkind (P) = N_Selected_Component + and then Is_Overloadable (Entity (Selector_Name (P))) + then + -- Protected operation. If operation is overloaded, must + -- disambiguate. Prefix that denotes protected object itself + -- is resolved with its own type. + + if Attr_Id = Attribute_Unchecked_Access then + Error_Msg_Name_1 := Aname; + Error_Msg_F + ("attribute% cannot be applied to protected operation", P); + end if; + + Resolve (Prefix (P)); + Generate_Reference (Entity (Selector_Name (P)), P); + + elsif Is_Overloaded (P) then + + -- Use the designated type of the context to disambiguate + -- Note that this was not strictly conformant to Ada 95, + -- but was the implementation adopted by most Ada 95 compilers. + -- The use of the context type to resolve an Access attribute + -- reference is now mandated in AI-235 for Ada 2005. + + declare + Index : Interp_Index; + It : Interp; + + begin + Get_First_Interp (P, Index, It); + while Present (It.Typ) loop + if Covers (Designated_Type (Typ), It.Typ) then + Resolve (P, It.Typ); + exit; + end if; + + Get_Next_Interp (Index, It); + end loop; + end; + else + Resolve (P); + end if; + + -- X'Access is illegal if X denotes a constant and the access type + -- is access-to-variable. Same for 'Unchecked_Access. The rule + -- does not apply to 'Unrestricted_Access. If the reference is a + -- default-initialized aggregate component for a self-referential + -- type the reference is legal. + + if not (Ekind (Btyp) = E_Access_Subprogram_Type + or else Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type + or else (Is_Record_Type (Btyp) + and then + Present (Corresponding_Remote_Type (Btyp))) + or else Ekind (Btyp) = E_Access_Protected_Subprogram_Type + or else Ekind (Btyp) + = E_Anonymous_Access_Protected_Subprogram_Type + or else Is_Access_Constant (Btyp) + or else Is_Variable (P) + or else Attr_Id = Attribute_Unrestricted_Access) + then + if Is_Entity_Name (P) + and then Is_Type (Entity (P)) + then + -- Legality of a self-reference through an access + -- attribute has been verified in Analyze_Access_Attribute. + + null; + + elsif Comes_From_Source (N) then + Error_Msg_F ("access-to-variable designates constant", P); + end if; + end if; + + Des_Btyp := Designated_Type (Btyp); + + if Ada_Version >= Ada_2005 + and then Is_Incomplete_Type (Des_Btyp) + then + -- Ada 2005 (AI-412): If the (sub)type is a limited view of an + -- imported entity, and the non-limited view is visible, make + -- use of it. If it is an incomplete subtype, use the base type + -- in any case. + + if From_With_Type (Des_Btyp) + and then Present (Non_Limited_View (Des_Btyp)) + then + Des_Btyp := Non_Limited_View (Des_Btyp); + + elsif Ekind (Des_Btyp) = E_Incomplete_Subtype then + Des_Btyp := Etype (Des_Btyp); + end if; + end if; + + if (Attr_Id = Attribute_Access + or else + Attr_Id = Attribute_Unchecked_Access) + and then (Ekind (Btyp) = E_General_Access_Type + or else Ekind (Btyp) = E_Anonymous_Access_Type) + then + -- Ada 2005 (AI-230): Check the accessibility of anonymous + -- access types for stand-alone objects, record and array + -- components, and return objects. For a component definition + -- the level is the same of the enclosing composite type. + + if Ada_Version >= Ada_2005 + and then Is_Local_Anonymous_Access (Btyp) + and then Object_Access_Level (P) > Type_Access_Level (Btyp) + and then Attr_Id = Attribute_Access + then + -- In an instance, this is a runtime check, but one we + -- know will fail, so generate an appropriate warning. + + if In_Instance_Body then + Error_Msg_F + ("?non-local pointer cannot point to local object", P); + Error_Msg_F + ("\?Program_Error will be raised at run time", P); + Rewrite (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Accessibility_Check_Failed)); + Set_Etype (N, Typ); + + else + Error_Msg_F + ("non-local pointer cannot point to local object", P); + end if; + end if; + + if Is_Dependent_Component_Of_Mutable_Object (P) then + Error_Msg_F + ("illegal attribute for discriminant-dependent component", + P); + end if; + + -- Check static matching rule of 3.10.2(27). Nominal subtype + -- of the prefix must statically match the designated type. + + Nom_Subt := Etype (P); + + if Is_Constr_Subt_For_U_Nominal (Nom_Subt) then + Nom_Subt := Base_Type (Nom_Subt); + end if; + + if Is_Tagged_Type (Designated_Type (Typ)) then + + -- If the attribute is in the context of an access + -- parameter, then the prefix is allowed to be of the + -- class-wide type (by AI-127). + + if Ekind (Typ) = E_Anonymous_Access_Type then + if not Covers (Designated_Type (Typ), Nom_Subt) + and then not Covers (Nom_Subt, Designated_Type (Typ)) + then + declare + Desig : Entity_Id; + + begin + Desig := Designated_Type (Typ); + + if Is_Class_Wide_Type (Desig) then + Desig := Etype (Desig); + end if; + + if Is_Anonymous_Tagged_Base (Nom_Subt, Desig) then + null; + + else + Error_Msg_FE + ("type of prefix: & not compatible", + P, Nom_Subt); + Error_Msg_FE + ("\with &, the expected designated type", + P, Designated_Type (Typ)); + end if; + end; + end if; + + elsif not Covers (Designated_Type (Typ), Nom_Subt) + or else + (not Is_Class_Wide_Type (Designated_Type (Typ)) + and then Is_Class_Wide_Type (Nom_Subt)) + then + Error_Msg_FE + ("type of prefix: & is not covered", P, Nom_Subt); + Error_Msg_FE + ("\by &, the expected designated type" & + " (RM 3.10.2 (27))", P, Designated_Type (Typ)); + end if; + + if Is_Class_Wide_Type (Designated_Type (Typ)) + and then Has_Discriminants (Etype (Designated_Type (Typ))) + and then Is_Constrained (Etype (Designated_Type (Typ))) + and then Designated_Type (Typ) /= Nom_Subt + then + Apply_Discriminant_Check + (N, Etype (Designated_Type (Typ))); + end if; + + -- Ada 2005 (AI-363): Require static matching when designated + -- type has discriminants and a constrained partial view, since + -- in general objects of such types are mutable, so we can't + -- allow the access value to designate a constrained object + -- (because access values must be assumed to designate mutable + -- objects when designated type does not impose a constraint). + + elsif Subtypes_Statically_Match (Des_Btyp, Nom_Subt) then + null; + + elsif Has_Discriminants (Designated_Type (Typ)) + and then not Is_Constrained (Des_Btyp) + and then + (Ada_Version < Ada_2005 + or else + not Has_Constrained_Partial_View + (Designated_Type (Base_Type (Typ)))) + then + null; + + else + Error_Msg_F + ("object subtype must statically match " + & "designated subtype", P); + + if Is_Entity_Name (P) + and then Is_Array_Type (Designated_Type (Typ)) + then + declare + D : constant Node_Id := Declaration_Node (Entity (P)); + + begin + Error_Msg_N ("aliased object has explicit bounds?", + D); + Error_Msg_N ("\declare without bounds" + & " (and with explicit initialization)?", D); + Error_Msg_N ("\for use with unconstrained access?", D); + end; + end if; + end if; + + -- Check the static accessibility rule of 3.10.2(28). + -- Note that this check is not performed for the + -- case of an anonymous access type, since the access + -- attribute is always legal in such a context. + + if Attr_Id /= Attribute_Unchecked_Access + and then Object_Access_Level (P) > Type_Access_Level (Btyp) + and then Ekind (Btyp) = E_General_Access_Type + then + Accessibility_Message; + return; + end if; + end if; + + if Ekind_In (Btyp, E_Access_Protected_Subprogram_Type, + E_Anonymous_Access_Protected_Subprogram_Type) + then + if Is_Entity_Name (P) + and then not Is_Protected_Type (Scope (Entity (P))) + then + Error_Msg_F ("context requires a protected subprogram", P); + + -- Check accessibility of protected object against that of the + -- access type, but only on user code, because the expander + -- creates access references for handlers. If the context is an + -- anonymous_access_to_protected, there are no accessibility + -- checks either. Omit check entirely for Unrestricted_Access. + + elsif Object_Access_Level (P) > Type_Access_Level (Btyp) + and then Comes_From_Source (N) + and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type + and then Attr_Id /= Attribute_Unrestricted_Access + then + Accessibility_Message; + return; + end if; + + elsif Ekind_In (Btyp, E_Access_Subprogram_Type, + E_Anonymous_Access_Subprogram_Type) + and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type + then + Error_Msg_F ("context requires a non-protected subprogram", P); + end if; + + -- The context cannot be a pool-specific type, but this is a + -- legality rule, not a resolution rule, so it must be checked + -- separately, after possibly disambiguation (see AI-245). + + if Ekind (Btyp) = E_Access_Type + and then Attr_Id /= Attribute_Unrestricted_Access + then + Wrong_Type (N, Typ); + end if; + + -- The context may be a constrained access type (however ill- + -- advised such subtypes might be) so in order to generate a + -- constraint check when needed set the type of the attribute + -- reference to the base type of the context. + + Set_Etype (N, Btyp); + + -- Check for incorrect atomic/volatile reference (RM C.6(12)) + + if Attr_Id /= Attribute_Unrestricted_Access then + if Is_Atomic_Object (P) + and then not Is_Atomic (Designated_Type (Typ)) + then + Error_Msg_F + ("access to atomic object cannot yield access-to-" & + "non-atomic type", P); + + elsif Is_Volatile_Object (P) + and then not Is_Volatile (Designated_Type (Typ)) + then + Error_Msg_F + ("access to volatile object cannot yield access-to-" & + "non-volatile type", P); + end if; + end if; + + if Is_Entity_Name (P) then + Set_Address_Taken (Entity (P)); + end if; + end Access_Attribute; + + ------------- + -- Address -- + ------------- + + -- Deal with resolving the type for Address attribute, overloading + -- is not permitted here, since there is no context to resolve it. + + when Attribute_Address | Attribute_Code_Address => + Address_Attribute : begin + + -- To be safe, assume that if the address of a variable is taken, + -- it may be modified via this address, so note modification. + + if Is_Variable (P) then + Note_Possible_Modification (P, Sure => False); + end if; + + if Nkind (P) in N_Subexpr + and then Is_Overloaded (P) + then + Get_First_Interp (P, Index, It); + Get_Next_Interp (Index, It); + + if Present (It.Nam) then + Error_Msg_Name_1 := Aname; + Error_Msg_F + ("prefix of % attribute cannot be overloaded", P); + end if; + end if; + + if not Is_Entity_Name (P) + or else not Is_Overloadable (Entity (P)) + then + if not Is_Task_Type (Etype (P)) + or else Nkind (P) = N_Explicit_Dereference + then + Resolve (P); + end if; + end if; + + -- If this is the name of a derived subprogram, or that of a + -- generic actual, the address is that of the original entity. + + if Is_Entity_Name (P) + and then Is_Overloadable (Entity (P)) + and then Present (Alias (Entity (P))) + then + Rewrite (P, + New_Occurrence_Of (Alias (Entity (P)), Sloc (P))); + end if; + + if Is_Entity_Name (P) then + Set_Address_Taken (Entity (P)); + end if; + + if Nkind (P) = N_Slice then + + -- Arr (X .. Y)'address is identical to Arr (X)'address, + -- even if the array is packed and the slice itself is not + -- addressable. Transform the prefix into an indexed component. + + -- Note that the transformation is safe only if we know that + -- the slice is non-null. That is because a null slice can have + -- an out of bounds index value. + + -- Right now, gigi blows up if given 'Address on a slice as a + -- result of some incorrect freeze nodes generated by the front + -- end, and this covers up that bug in one case, but the bug is + -- likely still there in the cases not handled by this code ??? + + -- It's not clear what 'Address *should* return for a null + -- slice with out of bounds indexes, this might be worth an ARG + -- discussion ??? + + -- One approach would be to do a length check unconditionally, + -- and then do the transformation below unconditionally, but + -- analyze with checks off, avoiding the problem of the out of + -- bounds index. This approach would interpret the address of + -- an out of bounds null slice as being the address where the + -- array element would be if there was one, which is probably + -- as reasonable an interpretation as any ??? + + declare + Loc : constant Source_Ptr := Sloc (P); + D : constant Node_Id := Discrete_Range (P); + Lo : Node_Id; + + begin + if Is_Entity_Name (D) + and then + Not_Null_Range + (Type_Low_Bound (Entity (D)), + Type_High_Bound (Entity (D))) + then + Lo := + Make_Attribute_Reference (Loc, + Prefix => (New_Occurrence_Of (Entity (D), Loc)), + Attribute_Name => Name_First); + + elsif Nkind (D) = N_Range + and then Not_Null_Range (Low_Bound (D), High_Bound (D)) + then + Lo := Low_Bound (D); + + else + Lo := Empty; + end if; + + if Present (Lo) then + Rewrite (P, + Make_Indexed_Component (Loc, + Prefix => Relocate_Node (Prefix (P)), + Expressions => New_List (Lo))); + + Analyze_And_Resolve (P); + end if; + end; + end if; + end Address_Attribute; + + --------------- + -- AST_Entry -- + --------------- + + -- Prefix of the AST_Entry attribute is an entry name which must + -- not be resolved, since this is definitely not an entry call. + + when Attribute_AST_Entry => + null; + + ------------------ + -- Body_Version -- + ------------------ + + -- Prefix of Body_Version attribute can be a subprogram name which + -- must not be resolved, since this is not a call. + + when Attribute_Body_Version => + null; + + ------------ + -- Caller -- + ------------ + + -- Prefix of Caller attribute is an entry name which must not + -- be resolved, since this is definitely not an entry call. + + when Attribute_Caller => + null; + + ------------------ + -- Code_Address -- + ------------------ + + -- Shares processing with Address attribute + + ----------- + -- Count -- + ----------- + + -- If the prefix of the Count attribute is an entry name it must not + -- be resolved, since this is definitely not an entry call. However, + -- if it is an element of an entry family, the index itself may + -- have to be resolved because it can be a general expression. + + when Attribute_Count => + if Nkind (P) = N_Indexed_Component + and then Is_Entity_Name (Prefix (P)) + then + declare + Indx : constant Node_Id := First (Expressions (P)); + Fam : constant Entity_Id := Entity (Prefix (P)); + begin + Resolve (Indx, Entry_Index_Type (Fam)); + Apply_Range_Check (Indx, Entry_Index_Type (Fam)); + end; + end if; + + ---------------- + -- Elaborated -- + ---------------- + + -- Prefix of the Elaborated attribute is a subprogram name which + -- must not be resolved, since this is definitely not a call. Note + -- that it is a library unit, so it cannot be overloaded here. + + when Attribute_Elaborated => + null; + + ------------- + -- Enabled -- + ------------- + + -- Prefix of Enabled attribute is a check name, which must be treated + -- specially and not touched by Resolve. + + when Attribute_Enabled => + null; + + -------------------- + -- Mechanism_Code -- + -------------------- + + -- Prefix of the Mechanism_Code attribute is a function name + -- which must not be resolved. Should we check for overloaded ??? + + when Attribute_Mechanism_Code => + null; + + ------------------ + -- Partition_ID -- + ------------------ + + -- Most processing is done in sem_dist, after determining the + -- context type. Node is rewritten as a conversion to a runtime call. + + when Attribute_Partition_ID => + Process_Partition_Id (N); + return; + + ------------------ + -- Pool_Address -- + ------------------ + + when Attribute_Pool_Address => + Resolve (P); + + ----------- + -- Range -- + ----------- + + -- We replace the Range attribute node with a range expression whose + -- bounds are the 'First and 'Last attributes applied to the same + -- prefix. The reason that we do this transformation here instead of + -- in the expander is that it simplifies other parts of the semantic + -- analysis which assume that the Range has been replaced; thus it + -- must be done even when in semantic-only mode (note that the RM + -- specifically mentions this equivalence, we take care that the + -- prefix is only evaluated once). + + when Attribute_Range => Range_Attribute : + declare + LB : Node_Id; + HB : Node_Id; + + begin + if not Is_Entity_Name (P) + or else not Is_Type (Entity (P)) + then + Resolve (P); + end if; + + HB := + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr (P, Name_Req => True), + Attribute_Name => Name_Last, + Expressions => Expressions (N)); + + LB := + Make_Attribute_Reference (Loc, + Prefix => P, + Attribute_Name => Name_First, + Expressions => Expressions (N)); + + -- If the original was marked as Must_Not_Freeze (see code + -- in Sem_Ch3.Make_Index), then make sure the rewriting + -- does not freeze either. + + if Must_Not_Freeze (N) then + Set_Must_Not_Freeze (HB); + Set_Must_Not_Freeze (LB); + Set_Must_Not_Freeze (Prefix (HB)); + Set_Must_Not_Freeze (Prefix (LB)); + end if; + + if Raises_Constraint_Error (Prefix (N)) then + + -- Preserve Sloc of prefix in the new bounds, so that + -- the posted warning can be removed if we are within + -- unreachable code. + + Set_Sloc (LB, Sloc (Prefix (N))); + Set_Sloc (HB, Sloc (Prefix (N))); + end if; + + Rewrite (N, Make_Range (Loc, LB, HB)); + Analyze_And_Resolve (N, Typ); + + -- Ensure that the expanded range does not have side effects + + Force_Evaluation (LB); + Force_Evaluation (HB); + + -- Normally after resolving attribute nodes, Eval_Attribute + -- is called to do any possible static evaluation of the node. + -- However, here since the Range attribute has just been + -- transformed into a range expression it is no longer an + -- attribute node and therefore the call needs to be avoided + -- and is accomplished by simply returning from the procedure. + + return; + end Range_Attribute; + + ------------ + -- Result -- + ------------ + + -- We will only come here during the prescan of a spec expression + -- containing a Result attribute. In that case the proper Etype has + -- already been set, and nothing more needs to be done here. + + when Attribute_Result => + null; + + ----------------- + -- UET_Address -- + ----------------- + + -- Prefix must not be resolved in this case, since it is not a + -- real entity reference. No action of any kind is require! + + when Attribute_UET_Address => + return; + + ---------------------- + -- Unchecked_Access -- + ---------------------- + + -- Processing is shared with Access + + ------------------------- + -- Unrestricted_Access -- + ------------------------- + + -- Processing is shared with Access + + --------- + -- Val -- + --------- + + -- Apply range check. Note that we did not do this during the + -- analysis phase, since we wanted Eval_Attribute to have a + -- chance at finding an illegal out of range value. + + when Attribute_Val => + + -- Note that we do our own Eval_Attribute call here rather than + -- use the common one, because we need to do processing after + -- the call, as per above comment. + + Eval_Attribute (N); + + -- Eval_Attribute may replace the node with a raise CE, or + -- fold it to a constant. Obviously we only apply a scalar + -- range check if this did not happen! + + if Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) = Name_Val + then + Apply_Scalar_Range_Check (First (Expressions (N)), Btyp); + end if; + + return; + + ------------- + -- Version -- + ------------- + + -- Prefix of Version attribute can be a subprogram name which + -- must not be resolved, since this is not a call. + + when Attribute_Version => + null; + + ---------------------- + -- Other Attributes -- + ---------------------- + + -- For other attributes, resolve prefix unless it is a type. If + -- the attribute reference itself is a type name ('Base and 'Class) + -- then this is only legal within a task or protected record. + + when others => + if not Is_Entity_Name (P) + or else not Is_Type (Entity (P)) + then + Resolve (P); + end if; + + -- If the attribute reference itself is a type name ('Base, + -- 'Class) then this is only legal within a task or protected + -- record. What is this all about ??? + + if Is_Entity_Name (N) + and then Is_Type (Entity (N)) + then + if Is_Concurrent_Type (Entity (N)) + and then In_Open_Scopes (Entity (P)) + then + null; + else + Error_Msg_N + ("invalid use of subtype name in expression or call", N); + end if; + end if; + + -- For attributes whose argument may be a string, complete + -- resolution of argument now. This avoids premature expansion + -- (and the creation of transient scopes) before the attribute + -- reference is resolved. + + case Attr_Id is + when Attribute_Value => + Resolve (First (Expressions (N)), Standard_String); + + when Attribute_Wide_Value => + Resolve (First (Expressions (N)), Standard_Wide_String); + + when Attribute_Wide_Wide_Value => + Resolve (First (Expressions (N)), Standard_Wide_Wide_String); + + when others => null; + end case; + + -- If the prefix of the attribute is a class-wide type then it + -- will be expanded into a dispatching call to a predefined + -- primitive. Therefore we must check for potential violation + -- of such restriction. + + if Is_Class_Wide_Type (Etype (P)) then + Check_Restriction (No_Dispatching_Calls, N); + end if; + end case; + + -- Normally the Freezing is done by Resolve but sometimes the Prefix + -- is not resolved, in which case the freezing must be done now. + + Freeze_Expression (P); + + -- Finally perform static evaluation on the attribute reference + + Eval_Attribute (N); + end Resolve_Attribute; + + -------------------------------- + -- Stream_Attribute_Available -- + -------------------------------- + + function Stream_Attribute_Available + (Typ : Entity_Id; + Nam : TSS_Name_Type; + Partial_View : Node_Id := Empty) return Boolean + is + Etyp : Entity_Id := Typ; + + -- Start of processing for Stream_Attribute_Available + + begin + -- We need some comments in this body ??? + + if Has_Stream_Attribute_Definition (Typ, Nam) then + return True; + end if; + + if Is_Class_Wide_Type (Typ) then + return not Is_Limited_Type (Typ) + or else Stream_Attribute_Available (Etype (Typ), Nam); + end if; + + if Nam = TSS_Stream_Input + and then Is_Abstract_Type (Typ) + and then not Is_Class_Wide_Type (Typ) + then + return False; + end if; + + if not (Is_Limited_Type (Typ) + or else (Present (Partial_View) + and then Is_Limited_Type (Partial_View))) + then + return True; + end if; + + -- In Ada 2005, Input can invoke Read, and Output can invoke Write + + if Nam = TSS_Stream_Input + and then Ada_Version >= Ada_2005 + and then Stream_Attribute_Available (Etyp, TSS_Stream_Read) + then + return True; + + elsif Nam = TSS_Stream_Output + and then Ada_Version >= Ada_2005 + and then Stream_Attribute_Available (Etyp, TSS_Stream_Write) + then + return True; + end if; + + -- Case of Read and Write: check for attribute definition clause that + -- applies to an ancestor type. + + while Etype (Etyp) /= Etyp loop + Etyp := Etype (Etyp); + + if Has_Stream_Attribute_Definition (Etyp, Nam) then + return True; + end if; + end loop; + + if Ada_Version < Ada_2005 then + + -- In Ada 95 mode, also consider a non-visible definition + + declare + Btyp : constant Entity_Id := Implementation_Base_Type (Typ); + begin + return Btyp /= Typ + and then Stream_Attribute_Available + (Btyp, Nam, Partial_View => Typ); + end; + end if; + + return False; + end Stream_Attribute_Available; + +end Sem_Attr; diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads new file mode 100644 index 000000000..6db8949be --- /dev/null +++ b/gcc/ada/sem_attr.ads @@ -0,0 +1,607 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ A T T 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. -- +-- -- +-- You should have received a copy of the GNU General Public License along -- +-- with this program; see file COPYING3. If not see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Attribute handling is isolated in a separate package to ease the addition +-- of implementation defined attributes. Logically this processing belongs +-- in chapter 4. See Sem_Ch4 for a description of the relation of the +-- Analyze and Resolve routines for expression components. + +-- This spec also documents all GNAT implementation defined pragmas + +with Exp_Tss; use Exp_Tss; +with Namet; use Namet; +with Snames; use Snames; +with Types; use Types; + +package Sem_Attr is + + ----------------------------------------- + -- Implementation Dependent Attributes -- + ----------------------------------------- + + -- This section describes the implementation dependent attributes + -- provided in GNAT, as well as constructing an array of flags + -- indicating which attributes these are. + + Attribute_Impl_Def : Attribute_Class_Array := Attribute_Class_Array'( + + ------------------ + -- Abort_Signal -- + ------------------ + + Attribute_Abort_Signal => True, + -- Standard'Abort_Signal (Standard is the only allowed prefix) provides + -- the entity for the special exception used to signal task abort or + -- asynchronous transfer of control. Normally this attribute should only + -- be used in the tasking runtime (it is highly peculiar, and completely + -- outside the normal semantics of Ada, for a user program to intercept + -- the abort exception). + + ------------------ + -- Address_Size -- + ------------------ + + Attribute_Address_Size => True, + -- Standard'Address_Size (Standard is the only allowed prefix) is + -- a static constant giving the number of bits in an Address. It + -- is used primarily for constructing the definition of Memory_Size + -- in package Standard, but may be freely used in user programs. + -- This is a static attribute. + + --------------- + -- Asm_Input -- + --------------- + + Attribute_Asm_Input => True, + -- Used only in conjunction with the Asm subprograms in package + -- Machine_Code to construct machine instructions. See documentation + -- in package Machine_Code in file s-maccod.ads. + + ---------------- + -- Asm_Output -- + ---------------- + + Attribute_Asm_Output => True, + -- Used only in conjunction with the Asm subprograms in package + -- Machine_Code to construct machine instructions. See documentation + -- in package Machine_Code in file s-maccod.ads. + + --------------- + -- AST_Entry -- + --------------- + + Attribute_AST_Entry => True, + -- E'Ast_Entry, where E is a task entry, yields a value of the + -- predefined type System.DEC.AST_Handler, that enables the given + -- entry to be called when an AST occurs. If the name to which the + -- attribute applies has not been specified with the pragma AST_Entry, + -- the attribute returns the value No_Ast_Handler, and no AST occurs. + -- If the entry is for a task that is not callable (T'Callable False), + -- the exception program error is raised. If an AST occurs for an + -- entry of a task that is terminated, the program is erroneous. + -- + -- The attribute AST_Entry is supported only in OpenVMS versions + -- of GNAT. It will be rejected as illegal in other GNAT versions. + + --------- + -- Bit -- + --------- + + Attribute_Bit => True, + -- Obj'Bit, where Obj is any object, yields the bit offset within the + -- storage unit (byte) that contains the first bit of storage allocated + -- for the object. The attribute value is of type Universal_Integer, + -- and is always a non-negative number not exceeding the value of + -- System.Storage_Unit. + -- + -- For an object that is a variable or a constant allocated in a + -- register, the value is zero. (The use of this attribute does not + -- force the allocation of a variable to memory). + -- + -- For an object that is a formal parameter, this attribute applies to + -- either the matching actual parameter or to a copy of the matching + -- actual parameter. + -- + -- For an access object the value is zero. Note that Obj.all'Bit is + -- subject to an Access_Check for the designated object. Similarly + -- for a record component X.C'Bit is subject to a discriminant check + -- and X(I).Bit and X(I1..I2)'Bit are subject to index checks. + -- + -- This attribute is designed to be compatible with the DEC Ada + -- definition and implementation of the Bit attribute. + + ------------------ + -- Code_Address -- + ------------------ + + Attribute_Code_Address => True, + -- The reference subp'Code_Address, where subp is a subprogram entity, + -- gives the address of the first generated instruction for the sub- + -- program. This is often, but not always the same as the 'Address + -- value, which is the address to be used in a call. The differences + -- occur in the case of a nested procedure (where Address yields the + -- address of the trampoline code used to load the static link), and on + -- some systems which use procedure descriptors (in which case Address + -- yields the address of the descriptor). + + ----------------------- + -- Default_Bit_Order -- + ----------------------- + + Attribute_Default_Bit_Order => True, + -- Standard'Default_Bit_Order (Standard is the only permissible prefix), + -- provides the value System.Default_Bit_Order as a Pos value (0 for + -- High_Order_First, 1 for Low_Order_First). This is used to construct + -- the definition of Default_Bit_Order in package System. This is a + -- static attribute. + + --------------- + -- Elab_Body -- + --------------- + + Attribute_Elab_Body => True, + -- This attribute can only be applied to a program unit name. It returns + -- the entity for the corresponding elaboration procedure for elabor- + -- ating the body of the referenced unit. This is used in the main + -- generated elaboration procedure by the binder, and is not normally + -- used in any other context, but there may be specialized situations in + -- which it is useful to be able to call this elaboration procedure from + -- Ada code, e.g. if it is necessary to do selective reelaboration to + -- fix some error. + + --------------- + -- Elab_Spec -- + --------------- + + Attribute_Elab_Spec => True, + -- This attribute can only be applied to a program unit name. It + -- returns the entity for the corresponding elaboration procedure + -- for elaborating the spec of the referenced unit. This is used + -- in the main generated elaboration procedure by the binder, and + -- is not normally used in any other context, but there may be + -- specialized situations in which it is useful to be able to + -- call this elaboration procedure from Ada code, e.g. if it + -- is necessary to do selective reelaboration to fix some error. + + ---------------- + -- Elaborated -- + ---------------- + + Attribute_Elaborated => True, + -- Lunit'Elaborated, where Lunit is a library unit, yields a boolean + -- value indicating whether or not the body of the designated library + -- unit has been elaborated yet. + + -------------- + -- Enum_Rep -- + -------------- + + Attribute_Enum_Rep => True, + -- For every enumeration subtype S, S'Enum_Rep denotes a function + -- with the following specification: + -- + -- function S'Enum_Rep (Arg : S'Base) return universal_integer; + -- + -- The function returns the representation value for the given + -- enumeration value. This will be equal to the 'Pos value in the + -- absence of an enumeration representation clause. This is a static + -- attribute (i.e. the result is static if the argument is static). + + -------------- + -- Enum_Val -- + -------------- + + Attribute_Enum_Val => True, + -- For every enumeration subtype S, S'Enum_Val denotes a function + -- with the following specification: + -- + -- function S'Enum_Val (Arg : universal_integer) return S'Base; + -- + -- This function performs the inverse transformation to Enum_Rep. Given + -- a representation value for the type, it returns the corresponding + -- enumeration value. Constraint_Error is raised if no value of the + -- enumeration type corresponds to the given integer value. + + ----------------- + -- Fixed_Value -- + ----------------- + + Attribute_Fixed_Value => True, + -- For every fixed-point type S, S'Fixed_Value denotes a function + -- with the following specification: + -- + -- function S'Fixed_Value (Arg : universal_integer) return S; + -- + -- The value returned is the fixed-point value V such that + -- + -- V = Arg * S'Small + -- + -- The effect is thus equivalent to first converting the argument to + -- the integer type used to represent S, and then doing an unchecked + -- conversion to the fixed-point type. This attribute is primarily + -- intended for use in implementation of the input-output functions for + -- fixed-point values. + + ----------------------- + -- Has_Discriminants -- + ----------------------- + + Attribute_Has_Discriminants => True, + -- Gtyp'Has_Discriminants, where Gtyp is a generic formal type, yields + -- a Boolean value indicating whether or not the actual instantiation + -- type has discriminants. + + --------- + -- Img -- + --------- + + Attribute_Img => True, + -- The 'Img function is defined for any prefix, P, that denotes an + -- object of scalar type T. P'Img is equivalent to T'Image (P). This + -- is convenient for debugging. For example: + -- + -- Put_Line ("X = " & X'Img); + -- + -- has the same meaning as the more verbose: + -- + -- Put_Line ("X = " & Temperature_Type'Image (X)); + -- + -- where Temperature_Type is the subtype of the object X. + + ------------------- + -- Integer_Value -- + ------------------- + + Attribute_Integer_Value => True, + -- For every integer type S, S'Integer_Value denotes a function + -- with the following specification: + -- + -- function S'Integer_Value (Arg : universal_fixed) return S; + -- + -- The value returned is the integer value V, such that + -- + -- Arg = V * fixed-type'Small + -- + -- The effect is thus equivalent to first doing an unchecked convert + -- from the fixed-point type to its corresponding implementation type, + -- and then converting the result to the target integer type. This + -- attribute is primarily intended for use in implementation of the + -- standard input-output functions for fixed-point values. + + Attribute_Invalid_Value => True, + -- For every scalar type, S'Invalid_Value designates an undefined value + -- of the type. If possible this value is an invalid value, and in fact + -- is identical to the value that would be set if Initialize_Scalars + -- mode were in effect (including the behavior of its value on + -- environment variables or binder switches). The intended use is + -- to set a value where initialization is required (e.g. as a result of + -- the coding standards in use), but logically no initialization is + -- needed, and the value should never be accessed. + + ------------------ + -- Machine_Size -- + ------------------ + + Attribute_Machine_Size => True, + -- This attribute is identical to the Object_Size attribute. It is + -- provided for compatibility with the DEC attribute of this name. + + ----------------------- + -- Maximum_Alignment -- + ----------------------- + + Attribute_Maximum_Alignment => True, + -- Standard'Maximum_Alignment (Standard is the only permissible prefix) + -- provides the maximum useful alignment value for the target. This + -- is a static value that can be used to specify the alignment for an + -- object, guaranteeing that it is properly aligned in all cases. The + -- time this is useful is when an external object is imported and its + -- alignment requirements are unknown. This is a static attribute. + + -------------------- + -- Mechanism_Code -- + -------------------- + + Attribute_Mechanism_Code => True, + -- function'Mechanism_Code yields an integer code for the mechanism + -- used for the result of function, and subprogram'Mechanism_Code (n) + -- yields the mechanism used for formal parameter number n (a static + -- integer value, 1 = first parameter). The code returned is: + -- + -- 1 = by copy (value) + -- 2 = by reference + -- 3 = by descriptor (default descriptor type) + -- 4 = by descriptor (UBS unaligned bit string) + -- 5 = by descriptor (UBSB aligned bit string with arbitrary bounds) + -- 6 = by descriptor (UBA unaligned bit array) + -- 7 = by descriptor (S string, also scalar access type parameter) + -- 8 = by descriptor (SB string with arbitrary bounds) + -- 9 = by descriptor (A contiguous array) + -- 10 = by descriptor (NCA non-contiguous array) + + -------------------- + -- Null_Parameter -- + -------------------- + + Attribute_Null_Parameter => True, + -- A reference T'Null_Parameter denotes an (imaginary) object of type or + -- subtype T allocated at (machine) address zero. The attribute is + -- allowed only as the default expression of a formal parameter, or as + -- an actual expression of a subprogram call. In either case, the + -- subprogram must be imported. + -- + -- The identity of the object is represented by the address zero in the + -- argument list, independent of the passing mechanism (explicit or + -- default). + -- + -- The reason that this capability is needed is that for a record or + -- other composite object passed by reference, there is no other way of + -- specifying that a zero address should be passed. + + ----------------- + -- Object_Size -- + ----------------- + + Attribute_Object_Size => True, + -- Type'Object_Size is the same as Type'Size for all types except + -- fixed-point types and discrete types. For fixed-point types and + -- discrete types, this attribute gives the size used for default + -- allocation of objects and components of the size. See section in + -- Einfo ("Handling of type'Size values") for further details. + + ------------------------- + -- Passed_By_Reference -- + ------------------------- + + Attribute_Passed_By_Reference => True, + -- T'Passed_By_Reference for any subtype T returns a boolean value that + -- is true if the type is normally passed by reference and false if the + -- type is normally passed by copy in calls. For scalar types, the + -- result is always False and is static. For non-scalar types, the + -- result is non-static (since it is computed by Gigi). + + ------------------ + -- Range_Length -- + ------------------ + + Attribute_Range_Length => True, + -- T'Range_Length for any discrete type T yields the number of values + -- represented by the subtype (zero for a null range). The result is + -- static for static subtypes. Note that Range_Length applied to the + -- index subtype of a one dimensional array always gives the same result + -- as Range applied to the array itself. The result is of type universal + -- integer. + + --------- + -- Ref -- + --------- + + Attribute_Ref => True, + -- System.Address'Ref (Address is the only permissible prefix) is + -- equivalent to System'To_Address, provided for compatibility with + -- other compilers. + + ------------------ + -- Storage_Unit -- + ------------------ + + Attribute_Storage_Unit => True, + -- Standard'Storage_Unit (Standard is the only permissible prefix) + -- provides the value System.Storage_Unit, and is intended primarily + -- for constructing this definition in package System (see note above + -- in Default_Bit_Order description). The is a static attribute. + + --------------- + -- Stub_Type -- + --------------- + + Attribute_Stub_Type => True, + -- The GNAT implementation of remote access-to-classwide types is + -- organised as described in AARM E.4(20.t): a value of an RACW type + -- (designating a remote object) is represented as a normal access + -- value, pointing to a "stub" object which in turn contains the + -- necessary information to contact the designated remote object. A + -- call on any dispatching operation of such a stub object does the + -- remote call, if necessary, using the information in the stub object + -- to locate the target partition, etc. + -- + -- For a prefix T that denotes a remote access-to-classwide type, + -- T'Stub_Type denotes the type of the corresponding stub objects. + -- + -- By construction, the layout of T'Stub_Type is identical to that of + -- System.Partition_Interface.RACW_Stub_Type (see implementation notes + -- in body of Exp_Dist). + + ----------------- + -- Target_Name -- + ----------------- + + Attribute_Target_Name => True, + -- Standard'Target_Name yields the string identifying the target for the + -- compilation, taken from Sdefault.Target_Name. + + ---------------- + -- To_Address -- + ---------------- + + Attribute_To_Address => True, + -- System'To_Address (System is the only permissible prefix) is a + -- function that takes any integer value, and converts it into an + -- address value. The semantics is to first convert the integer value to + -- type Integer_Address according to normal conversion rules, and then + -- to convert this to an address using the same semantics as the + -- System.Storage_Elements.To_Address function. The important difference + -- is that this is a static attribute so it can be used in + -- initializations in preelaborate packages. + + ---------------- + -- Type_Class -- + ---------------- + + Attribute_Type_Class => True, + -- T'Type_Class for any type or subtype T yields the value of the type + -- class for the full type of T. If T is a generic formal type, then the + -- value is the value for the corresponding actual subtype. The value of + -- this attribute is of type System.Aux_DEC.Type_Class, which has the + -- following definition: + -- + -- 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, + -- Type_Class_Address); + -- + -- Protected types yield the value Type_Class_Task, which thus applies + -- to all concurrent types. This attribute is designed to be compatible + -- with the DEC Ada attribute of the same name. + -- + -- Note: if pragma Extend_System is used to merge the definitions of + -- Aux_DEC into System, then the type Type_Class can be referenced + -- as an entity within System, as can its enumeration literals. + + ----------------- + -- UET_Address -- + ----------------- + + Attribute_UET_Address => True, + -- Unit'UET_Address, where Unit is a program unit, yields the address + -- of the unit exception table for the specified unit. This is only + -- used in the internal implementation of exception handling. See the + -- implementation of unit Ada.Exceptions for details on its use. + + ------------------------------ + -- Universal_Literal_String -- + ------------------------------ + + Attribute_Universal_Literal_String => True, + -- The prefix of 'Universal_Literal_String must be a named number. + -- The static result is the string consisting of the characters of + -- the number as defined in the original source. This allows the + -- user program to access the actual text of named numbers without + -- intermediate conversions and without the need to enclose the + -- strings in quotes (which would preclude their use as numbers). + + ------------------------- + -- Unrestricted_Access -- + ------------------------- + + Attribute_Unrestricted_Access => True, + -- The Unrestricted_Access attribute is similar to Access except that + -- all accessibility and aliased view checks are omitted. This is very + -- much a user-beware attribute. Basically its status is very similar + -- to Address, for which it is a desirable replacement where the value + -- desired is an access type. In other words, its effect is identical + -- to first taking 'Address and then doing an unchecked conversion to + -- a desired access type. Note that in GNAT, but not necessarily in + -- other implementations, the use of static chains for inner level + -- subprograms means that Unrestricted_Access applied to a subprogram + -- yields a value that can be called as long as the subprogram is in + -- scope (normal Ada 95 accessibility rules restrict this usage). + + --------------- + -- VADS_Size -- + --------------- + + Attribute_VADS_Size => True, + -- Typ'VADS_Size yields the Size value typically yielded by some Ada 83 + -- compilers. The differences between VADS_Size and Size is that for + -- scalar types for which no Size has been specified, VADS_Size yields + -- the Object_Size rather than the Value_Size. For example, while + -- Natural'Size is typically 31, the value of Natural'VADS_Size is 32. + -- For all other types, Size and VADS_Size yield the same value. + + ---------------- + -- Value_Size -- + ---------------- + + Attribute_Value_Size => True, + -- Type'Value_Size is the number of bits required to represent value of + -- the given subtype. It is the same as Type'Size, but, unlike Size, may + -- be set for non-first subtypes. See section in Einfo ("Handling of + -- type'Size values") for further details. + + --------------- + -- Word_Size -- + --------------- + + Attribute_Word_Size => True, + -- Standard'Word_Size (Standard is the only permissible prefix) + -- provides the value System.Word_Size, and is intended primarily + -- for constructing this definition in package System (see note above + -- in Default_Bit_Order description). This is a static attribute. + + others => False); + + ----------------- + -- Subprograms -- + ----------------- + + procedure Analyze_Attribute (N : Node_Id); + -- Performs bottom up semantic analysis of an attribute. Note that the + -- parser has already checked that type returning attributes appear only + -- in appropriate contexts (i.e. in subtype marks, or as prefixes for + -- other attributes). + + function Name_Implies_Lvalue_Prefix (Nam : Name_Id) return Boolean; + -- Determine whether the name of an attribute reference categorizes its + -- prefix as an lvalue. The following attributes fall under this bracket + -- by directly or indirectly modifying their prefixes. + -- Access + -- Address + -- Input + -- Read + -- Unchecked_Access + -- Unrestricted_Access + + procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id); + -- Performs type resolution of attribute. If the attribute yields a + -- universal value, mark its type as that of the context. On the other + -- hand, if the context itself is universal (as in T'Val (T'Pos (X)), mark + -- the type as being the largest type of that class that can be used at + -- run-time. This is correct since either the value gets folded (in which + -- case it doesn't matter what type of the class we give if, since the + -- folding uses universal arithmetic anyway) or it doesn't get folded (in + -- which case it is going to be dealt with at runtime, and the largest type + -- is right). + + function Stream_Attribute_Available + (Typ : Entity_Id; + Nam : TSS_Name_Type; + Partial_View : Entity_Id := Empty) return Boolean; + -- For a limited type Typ, return True iff the given attribute is + -- available. For Ada 05, availability is defined by 13.13.2(36/1). For Ada + -- 95, an attribute is considered to be available if it has been specified + -- using an attribute definition clause for the type, or for its full view, + -- or for an ancestor of either. Parameter Partial_View is used only + -- internally, when checking for an attribute definition clause that is not + -- visible (Ada 95 only). + +end Sem_Attr; diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb new file mode 100755 index 000000000..e9a47a3bf --- /dev/null +++ b/gcc/ada/sem_aux.adb @@ -0,0 +1,904 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Namet; use Namet; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; + +package body Sem_Aux is + + ---------------------- + -- Ancestor_Subtype -- + ---------------------- + + function Ancestor_Subtype (Typ : Entity_Id) return Entity_Id is + begin + -- If this is first subtype, or is a base type, then there is no + -- ancestor subtype, so we return Empty to indicate this fact. + + if Is_First_Subtype (Typ) or else Is_Base_Type (Typ) then + return Empty; + end if; + + declare + D : constant Node_Id := Declaration_Node (Typ); + + begin + -- If we have a subtype declaration, get the ancestor subtype + + if Nkind (D) = N_Subtype_Declaration then + if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then + return Entity (Subtype_Mark (Subtype_Indication (D))); + else + return Entity (Subtype_Indication (D)); + end if; + + -- If not, then no subtype indication is available + + else + return Empty; + end if; + end; + end Ancestor_Subtype; + + -------------------- + -- Available_View -- + -------------------- + + function Available_View (Typ : Entity_Id) return Entity_Id is + begin + if Is_Incomplete_Type (Typ) + and then Present (Non_Limited_View (Typ)) + then + -- The non-limited view may itself be an incomplete type, in which + -- case get its full view. + + return Get_Full_View (Non_Limited_View (Typ)); + + elsif Is_Class_Wide_Type (Typ) + and then Is_Incomplete_Type (Etype (Typ)) + and then Present (Non_Limited_View (Etype (Typ))) + then + return Class_Wide_Type (Non_Limited_View (Etype (Typ))); + + else + return Typ; + end if; + end Available_View; + + -------------------- + -- Constant_Value -- + -------------------- + + function Constant_Value (Ent : Entity_Id) return Node_Id is + D : constant Node_Id := Declaration_Node (Ent); + Full_D : Node_Id; + + begin + -- If we have no declaration node, then return no constant value. Not + -- clear how this can happen, but it does sometimes and this is the + -- safest approach. + + if No (D) then + return Empty; + + -- Normal case where a declaration node is present + + elsif Nkind (D) = N_Object_Renaming_Declaration then + return Renamed_Object (Ent); + + -- If this is a component declaration whose entity is a constant, it is + -- a prival within a protected function (and so has no constant value). + + elsif Nkind (D) = N_Component_Declaration then + return Empty; + + -- If there is an expression, return it + + elsif Present (Expression (D)) then + return (Expression (D)); + + -- For a constant, see if we have a full view + + elsif Ekind (Ent) = E_Constant + and then Present (Full_View (Ent)) + then + Full_D := Parent (Full_View (Ent)); + + -- The full view may have been rewritten as an object renaming + + if Nkind (Full_D) = N_Object_Renaming_Declaration then + return Name (Full_D); + else + return Expression (Full_D); + end if; + + -- Otherwise we have no expression to return + + else + return Empty; + end if; + end Constant_Value; + + ----------------------------- + -- Enclosing_Dynamic_Scope -- + ----------------------------- + + function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is + S : Entity_Id; + + begin + -- The following test is an error defense against some syntax errors + -- that can leave scopes very messed up. + + if Ent = Standard_Standard then + return Ent; + end if; + + -- Normal case, search enclosing scopes + + -- Note: the test for Present (S) should not be required, it defends + -- against an ill-formed tree. + + S := Scope (Ent); + loop + -- If we somehow got an empty value for Scope, the tree must be + -- malformed. Rather than blow up we return Standard in this case. + + if No (S) then + return Standard_Standard; + + -- Quit if we get to standard or a dynamic scope + + elsif S = Standard_Standard + or else Is_Dynamic_Scope (S) + then + return S; + + -- Otherwise keep climbing + + else + S := Scope (S); + end if; + end loop; + end Enclosing_Dynamic_Scope; + + ------------------------ + -- First_Discriminant -- + ------------------------ + + function First_Discriminant (Typ : Entity_Id) return Entity_Id is + Ent : Entity_Id; + + begin + pragma Assert + (Has_Discriminants (Typ) or else Has_Unknown_Discriminants (Typ)); + + Ent := First_Entity (Typ); + + -- The discriminants are not necessarily contiguous, because access + -- discriminants will generate itypes. They are not the first entities + -- either, because tag and controller record must be ahead of them. + + if Chars (Ent) = Name_uTag then + Ent := Next_Entity (Ent); + end if; + + if Chars (Ent) = Name_uController then + Ent := Next_Entity (Ent); + end if; + + -- Skip all hidden stored discriminants if any + + while Present (Ent) loop + exit when Ekind (Ent) = E_Discriminant + and then not Is_Completely_Hidden (Ent); + + Ent := Next_Entity (Ent); + end loop; + + pragma Assert (Ekind (Ent) = E_Discriminant); + + return Ent; + end First_Discriminant; + + ------------------------------- + -- First_Stored_Discriminant -- + ------------------------------- + + function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id is + Ent : Entity_Id; + + function Has_Completely_Hidden_Discriminant + (Typ : Entity_Id) return Boolean; + -- Scans the Discriminants to see whether any are Completely_Hidden + -- (the mechanism for describing non-specified stored discriminants) + + ---------------------------------------- + -- Has_Completely_Hidden_Discriminant -- + ---------------------------------------- + + function Has_Completely_Hidden_Discriminant + (Typ : Entity_Id) return Boolean + is + Ent : Entity_Id; + + begin + pragma Assert (Ekind (Typ) = E_Discriminant); + + Ent := Typ; + while Present (Ent) and then Ekind (Ent) = E_Discriminant loop + if Is_Completely_Hidden (Ent) then + return True; + end if; + + Ent := Next_Entity (Ent); + end loop; + + return False; + end Has_Completely_Hidden_Discriminant; + + -- Start of processing for First_Stored_Discriminant + + begin + pragma Assert + (Has_Discriminants (Typ) + or else Has_Unknown_Discriminants (Typ)); + + Ent := First_Entity (Typ); + + if Chars (Ent) = Name_uTag then + Ent := Next_Entity (Ent); + end if; + + if Chars (Ent) = Name_uController then + Ent := Next_Entity (Ent); + end if; + + if Has_Completely_Hidden_Discriminant (Ent) then + + while Present (Ent) loop + exit when Is_Completely_Hidden (Ent); + Ent := Next_Entity (Ent); + end loop; + + end if; + + pragma Assert (Ekind (Ent) = E_Discriminant); + + return Ent; + end First_Stored_Discriminant; + + ------------------- + -- First_Subtype -- + ------------------- + + function First_Subtype (Typ : Entity_Id) return Entity_Id is + B : constant Entity_Id := Base_Type (Typ); + F : constant Node_Id := Freeze_Node (B); + Ent : Entity_Id; + + begin + -- If the base type has no freeze node, it is a type in Standard, and + -- always acts as its own first subtype, except where it is one of the + -- predefined integer types. If the type is formal, it is also a first + -- subtype, and its base type has no freeze node. On the other hand, a + -- subtype of a generic formal is not its own first subtype. Its base + -- type, if anonymous, is attached to the formal type decl. from which + -- the first subtype is obtained. + + if No (F) then + if B = Base_Type (Standard_Integer) then + return Standard_Integer; + + elsif B = Base_Type (Standard_Long_Integer) then + return Standard_Long_Integer; + + elsif B = Base_Type (Standard_Short_Short_Integer) then + return Standard_Short_Short_Integer; + + elsif B = Base_Type (Standard_Short_Integer) then + return Standard_Short_Integer; + + elsif B = Base_Type (Standard_Long_Long_Integer) then + return Standard_Long_Long_Integer; + + elsif Is_Generic_Type (Typ) then + if Present (Parent (B)) then + return Defining_Identifier (Parent (B)); + else + return Defining_Identifier (Associated_Node_For_Itype (B)); + end if; + + else + return B; + end if; + + -- Otherwise we check the freeze node, if it has a First_Subtype_Link + -- then we use that link, otherwise (happens with some Itypes), we use + -- the base type itself. + + else + Ent := First_Subtype_Link (F); + + if Present (Ent) then + return Ent; + else + return B; + end if; + end if; + end First_Subtype; + + ------------------------- + -- First_Tag_Component -- + ------------------------- + + function First_Tag_Component (Typ : Entity_Id) return Entity_Id is + Comp : Entity_Id; + Ctyp : Entity_Id; + + begin + Ctyp := Typ; + pragma Assert (Is_Tagged_Type (Ctyp)); + + if Is_Class_Wide_Type (Ctyp) then + Ctyp := Root_Type (Ctyp); + end if; + + if Is_Private_Type (Ctyp) then + Ctyp := Underlying_Type (Ctyp); + + -- If the underlying type is missing then the source program has + -- errors and there is nothing else to do (the full-type declaration + -- associated with the private type declaration is missing). + + if No (Ctyp) then + return Empty; + end if; + end if; + + Comp := First_Entity (Ctyp); + while Present (Comp) loop + if Is_Tag (Comp) then + return Comp; + end if; + + Comp := Next_Entity (Comp); + end loop; + + -- No tag component found + + return Empty; + end First_Tag_Component; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Obsolescent_Warnings.Init; + end Initialize; + + --------------------- + -- Is_By_Copy_Type -- + --------------------- + + function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is + begin + -- If Id is a private type whose full declaration has not been seen, + -- we assume for now that it is not a By_Copy type. Clearly this + -- attribute should not be used before the type is frozen, but it is + -- needed to build the associated record of a protected type. Another + -- place where some lookahead for a full view is needed ??? + + return + Is_Elementary_Type (Ent) + or else (Is_Private_Type (Ent) + and then Present (Underlying_Type (Ent)) + and then Is_Elementary_Type (Underlying_Type (Ent))); + end Is_By_Copy_Type; + + -------------------------- + -- Is_By_Reference_Type -- + -------------------------- + + function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is + Btype : constant Entity_Id := Base_Type (Ent); + + begin + if Error_Posted (Ent) + or else Error_Posted (Btype) + then + return False; + + elsif Is_Private_Type (Btype) then + declare + Utyp : constant Entity_Id := Underlying_Type (Btype); + begin + if No (Utyp) then + return False; + else + return Is_By_Reference_Type (Utyp); + end if; + end; + + elsif Is_Incomplete_Type (Btype) then + declare + Ftyp : constant Entity_Id := Full_View (Btype); + begin + if No (Ftyp) then + return False; + else + return Is_By_Reference_Type (Ftyp); + end if; + end; + + elsif Is_Concurrent_Type (Btype) then + return True; + + elsif Is_Record_Type (Btype) then + if Is_Limited_Record (Btype) + or else Is_Tagged_Type (Btype) + or else Is_Volatile (Btype) + then + return True; + + else + declare + C : Entity_Id; + + begin + C := First_Component (Btype); + while Present (C) loop + if Is_By_Reference_Type (Etype (C)) + or else Is_Volatile (Etype (C)) + then + return True; + end if; + + C := Next_Component (C); + end loop; + end; + + return False; + end if; + + elsif Is_Array_Type (Btype) then + return + Is_Volatile (Btype) + or else Is_By_Reference_Type (Component_Type (Btype)) + or else Is_Volatile (Component_Type (Btype)) + or else Has_Volatile_Components (Btype); + + else + return False; + end if; + end Is_By_Reference_Type; + + --------------------- + -- Is_Derived_Type -- + --------------------- + + function Is_Derived_Type (Ent : E) return B is + Par : Node_Id; + + begin + if Is_Type (Ent) + and then Base_Type (Ent) /= Root_Type (Ent) + and then not Is_Class_Wide_Type (Ent) + then + if not Is_Numeric_Type (Root_Type (Ent)) then + return True; + + else + Par := Parent (First_Subtype (Ent)); + + return Present (Par) + and then Nkind (Par) = N_Full_Type_Declaration + and then Nkind (Type_Definition (Par)) = + N_Derived_Type_Definition; + end if; + + else + return False; + end if; + end Is_Derived_Type; + + ----------------------- + -- Is_Generic_Formal -- + ----------------------- + + function Is_Generic_Formal (E : Entity_Id) return Boolean is + Kind : Node_Kind; + begin + if No (E) then + return False; + else + Kind := Nkind (Parent (E)); + return + Nkind_In (Kind, N_Formal_Object_Declaration, + N_Formal_Package_Declaration, + N_Formal_Type_Declaration) + or else Is_Formal_Subprogram (E); + end if; + end Is_Generic_Formal; + + --------------------------- + -- Is_Indefinite_Subtype -- + --------------------------- + + function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is + K : constant Entity_Kind := Ekind (Ent); + + begin + if Is_Constrained (Ent) then + return False; + + elsif K in Array_Kind + or else K in Class_Wide_Kind + or else Has_Unknown_Discriminants (Ent) + then + return True; + + -- Known discriminants: indefinite if there are no default values + + elsif K in Record_Kind + or else Is_Incomplete_Or_Private_Type (Ent) + or else Is_Concurrent_Type (Ent) + then + return (Has_Discriminants (Ent) + and then + No (Discriminant_Default_Value (First_Discriminant (Ent)))); + + else + return False; + end if; + end Is_Indefinite_Subtype; + + ------------------------------- + -- Is_Immutably_Limited_Type -- + ------------------------------- + + function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is + Btype : constant Entity_Id := Base_Type (Ent); + + begin + if Is_Limited_Record (Btype) then + return True; + + elsif Ekind (Btype) = E_Limited_Private_Type + and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration + then + return not In_Package_Body (Scope ((Btype))); + end if; + + if Is_Private_Type (Btype) then + + -- AI05-0063: A type derived from a limited private formal type is + -- not immutably limited in a generic body. + + if Is_Derived_Type (Btype) + and then Is_Generic_Type (Etype (Btype)) + then + if not Is_Limited_Type (Etype (Btype)) then + return False; + + -- A descendant of a limited formal type is not immutably limited + -- in the generic body, or in the body of a generic child. + + elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then + return not In_Package_Body (Scope (Btype)); + + else + return False; + end if; + + else + declare + Utyp : constant Entity_Id := Underlying_Type (Btype); + begin + if No (Utyp) then + return False; + else + return Is_Immutably_Limited_Type (Utyp); + end if; + end; + end if; + + elsif Is_Concurrent_Type (Btype) then + return True; + + elsif Is_Record_Type (Btype) then + + -- Note that we return True for all limited interfaces, even though + -- (unsynchronized) limited interfaces can have descendants that are + -- nonlimited, because this is a predicate on the type itself, and + -- things like functions with limited interface results need to be + -- handled as build in place even though they might return objects + -- of a type that is not inherently limited. + + if Is_Class_Wide_Type (Btype) then + return Is_Immutably_Limited_Type (Root_Type (Btype)); + + else + declare + C : Entity_Id; + + begin + C := First_Component (Btype); + while Present (C) loop + + -- Don't consider components with interface types (which can + -- only occur in the case of a _parent component anyway). + -- They don't have any components, plus it would cause this + -- function to return true for nonlimited types derived from + -- limited interfaces. + + if not Is_Interface (Etype (C)) + and then Is_Immutably_Limited_Type (Etype (C)) + then + return True; + end if; + + C := Next_Component (C); + end loop; + end; + + return False; + end if; + + elsif Is_Array_Type (Btype) then + return Is_Immutably_Limited_Type (Component_Type (Btype)); + + else + return False; + end if; + end Is_Immutably_Limited_Type; + + --------------------- + -- Is_Limited_Type -- + --------------------- + + function Is_Limited_Type (Ent : Entity_Id) return Boolean is + Btype : constant E := Base_Type (Ent); + Rtype : constant E := Root_Type (Btype); + + begin + if not Is_Type (Ent) then + return False; + + elsif Ekind (Btype) = E_Limited_Private_Type + or else Is_Limited_Composite (Btype) + then + return True; + + elsif Is_Concurrent_Type (Btype) then + return True; + + -- The Is_Limited_Record flag normally indicates that the type is + -- limited. The exception is that a type does not inherit limitedness + -- from its interface ancestor. So the type may be derived from a + -- limited interface, but is not limited. + + elsif Is_Limited_Record (Ent) + and then not Is_Interface (Ent) + then + return True; + + -- Otherwise we will look around to see if there is some other reason + -- for it to be limited, except that if an error was posted on the + -- entity, then just assume it is non-limited, because it can cause + -- trouble to recurse into a murky erroneous entity! + + elsif Error_Posted (Ent) then + return False; + + elsif Is_Record_Type (Btype) then + + if Is_Limited_Interface (Ent) then + return True; + + -- AI-419: limitedness is not inherited from a limited interface + + elsif Is_Limited_Record (Rtype) then + return not Is_Interface (Rtype) + or else Is_Protected_Interface (Rtype) + or else Is_Synchronized_Interface (Rtype) + or else Is_Task_Interface (Rtype); + + elsif Is_Class_Wide_Type (Btype) then + return Is_Limited_Type (Rtype); + + else + declare + C : E; + + begin + C := First_Component (Btype); + while Present (C) loop + if Is_Limited_Type (Etype (C)) then + return True; + end if; + + C := Next_Component (C); + end loop; + end; + + return False; + end if; + + elsif Is_Array_Type (Btype) then + return Is_Limited_Type (Component_Type (Btype)); + + else + return False; + end if; + end Is_Limited_Type; + + ---------------------- + -- Nearest_Ancestor -- + ---------------------- + + function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is + D : constant Node_Id := Declaration_Node (Typ); + + begin + -- If we have a subtype declaration, get the ancestor subtype + + if Nkind (D) = N_Subtype_Declaration then + if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then + return Entity (Subtype_Mark (Subtype_Indication (D))); + else + return Entity (Subtype_Indication (D)); + end if; + + -- If derived type declaration, find who we are derived from + + elsif Nkind (D) = N_Full_Type_Declaration + and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition + then + declare + DTD : constant Entity_Id := Type_Definition (D); + SI : constant Entity_Id := Subtype_Indication (DTD); + begin + if Is_Entity_Name (SI) then + return Entity (SI); + else + return Entity (Subtype_Mark (SI)); + end if; + end; + + -- Otherwise, nothing useful to return, return Empty + + else + return Empty; + end if; + end Nearest_Ancestor; + + --------------------------- + -- Nearest_Dynamic_Scope -- + --------------------------- + + function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is + begin + if Is_Dynamic_Scope (Ent) then + return Ent; + else + return Enclosing_Dynamic_Scope (Ent); + end if; + end Nearest_Dynamic_Scope; + + ------------------------ + -- Next_Tag_Component -- + ------------------------ + + function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is + Comp : Entity_Id; + + begin + pragma Assert (Is_Tag (Tag)); + + -- Loop to look for next tag component + + Comp := Next_Entity (Tag); + while Present (Comp) loop + if Is_Tag (Comp) then + pragma Assert (Chars (Comp) /= Name_uTag); + return Comp; + end if; + + Comp := Next_Entity (Comp); + end loop; + + -- No tag component found + + return Empty; + end Next_Tag_Component; + + -------------------------- + -- Number_Discriminants -- + -------------------------- + + function Number_Discriminants (Typ : Entity_Id) return Pos is + N : Int; + Discr : Entity_Id; + + begin + N := 0; + Discr := First_Discriminant (Typ); + while Present (Discr) loop + N := N + 1; + Discr := Next_Discriminant (Discr); + end loop; + + return N; + end Number_Discriminants; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + begin + Obsolescent_Warnings.Tree_Read; + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + begin + Obsolescent_Warnings.Tree_Write; + end Tree_Write; + + -------------------- + -- Ultimate_Alias -- + -------------------- + + function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is + E : Entity_Id := Prim; + + begin + while Present (Alias (E)) loop + pragma Assert (Alias (E) /= E); + E := Alias (E); + end loop; + + return E; + end Ultimate_Alias; + +end Sem_Aux; diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads new file mode 100755 index 000000000..e54016c99 --- /dev/null +++ b/gcc/ada/sem_aux.ads @@ -0,0 +1,225 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ A U X -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Package containing utility procedures used throughout the compiler, +-- and also by ASIS so dependencies are limited to ASIS included packages. + +-- Historical note. Many of the routines here were originally in Einfo, but +-- Einfo is supposed to be a relatively low level package dealing with the +-- content of entities in the tree, so this package is used for routines that +-- require more than minimal semantic knowledge. + +with Alloc; use Alloc; +with Table; +with Types; use Types; + +package Sem_Aux is + + -------------------------------- + -- Obsolescent Warnings Table -- + -------------------------------- + + -- This table records entities for which a pragma Obsolescent with a + -- message argument has been processed. + + type OWT_Record is record + Ent : Entity_Id; + -- The entity to which the pragma applies + + Msg : String_Id; + -- The string containing the message + end record; + + package Obsolescent_Warnings is new Table.Table ( + Table_Component_Type => OWT_Record, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.Obsolescent_Warnings_Initial, + Table_Increment => Alloc.Obsolescent_Warnings_Increment, + Table_Name => "Obsolescent_Warnings"); + + procedure Initialize; + -- Called at the start of compilation of each new main source file to + -- initialize the allocation of the Obsolescent_Warnings table. Note that + -- Initialize must not be called if Tree_Read is used. + + procedure Tree_Read; + -- Initializes Obsolescent_Warnings table from current tree file using the + -- relevant Table.Tree_Read routine. + + procedure Tree_Write; + -- Writes out Obsolescent_Warnings table to current tree file using the + -- relevant Table.Tree_Write routine. + + ----------------- + -- Subprograms -- + ----------------- + + function Ancestor_Subtype (Typ : Entity_Id) return Entity_Id; + -- The argument Id is a type or subtype entity. If the argument is a + -- subtype then it returns the subtype or type from which the subtype was + -- obtained, otherwise it returns Empty. + + function Available_View (Typ : Entity_Id) return Entity_Id; + -- Typ is typically a type that has the With_Type flag set. Returns the + -- non-limited view of the type, if available, otherwise the type itself. + -- For class-wide types, there is no direct link in the tree, so we have + -- to retrieve the class-wide type of the non-limited view of the Etype. + -- Returns the argument unchanged if it is not one of these cases. + + function Constant_Value (Ent : Entity_Id) return Node_Id; + -- Id is a variable, constant, named integer, or named real entity. This + -- call obtains the initialization expression for the entity. Will return + -- Empty for for a deferred constant whose full view is not available or + -- in some other cases of internal entities, which cannot be treated as + -- constants from the point of view of constant folding. Empty is also + -- returned for variables with no initialization expression. + + function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id; + -- For any entity, Ent, returns the closest dynamic scope in which the + -- entity is declared or Standard_Standard for library-level entities + + function First_Discriminant (Typ : Entity_Id) return Entity_Id; + -- Typ is a type with discriminants. The discriminants are the first + -- entities declared in the type, so normally this is equivalent to + -- First_Entity. The exception arises for tagged types, where the tag + -- itself is prepended to the front of the entity chain, so the + -- First_Discriminant function steps past the tag if it is present. + + function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id; + -- Typ is a type with discriminants. Gives the first discriminant stored + -- in an object of this type. In many cases, these are the same as the + -- normal visible discriminants for the type, but in the case of renamed + -- discriminants, this is not always the case. + -- + -- For tagged types, and untagged types which are root types or derived + -- types but which do not rename discriminants in their root type, the + -- stored discriminants are the same as the actual discriminants of the + -- type, and hence this function is the same as First_Discriminant. + -- + -- For derived non-tagged types that rename discriminants in the root type + -- this is the first of the discriminants that occur in the root type. To + -- be precise, in this case stored discriminants are entities attached to + -- the entity chain of the derived type which are a copy of the + -- discriminants of the root type. Furthermore their Is_Completely_Hidden + -- flag is set since although they are actually stored in the object, they + -- are not in the set of discriminants that is visible in the type. + -- + -- For derived untagged types, the set of stored discriminants are the real + -- discriminants from Gigi's standpoint, i.e. those that will be stored in + -- actual objects of the type. + + function First_Subtype (Typ : Entity_Id) return Entity_Id; + -- Applies to all types and subtypes. For types, yields the first subtype + -- of the type. For subtypes, yields the first subtype of the base type of + -- the subtype. + + function First_Tag_Component (Typ : Entity_Id) return Entity_Id; + -- Typ must be a tagged record type. This function returns the Entity for + -- the first _Tag field in the record type. + + function Is_By_Copy_Type (Ent : Entity_Id) return Boolean; + -- Ent is any entity. Returns True if Ent is a type entity where the type + -- is required to be passed by copy, as defined in (RM 6.2(3)). + + function Is_By_Reference_Type (Ent : Entity_Id) return Boolean; + -- Ent is any entity. Returns True if Ent is a type entity where the type + -- is required to be passed by reference, as defined in (RM 6.2(4-9)). + + function Is_Derived_Type (Ent : Entity_Id) return Boolean; + -- Determines if the given entity Ent is a derived type. Result is always + -- false if argument is not a type. + + function Is_Generic_Formal (E : Entity_Id) return Boolean; + -- Determine whether E is a generic formal parameter. In particular this is + -- used to set the visibility of generic formals of a generic package + -- declared with a box or with partial parametrization. + + function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean; + -- Ent is any entity. Determines if given entity is an unconstrained array + -- type or subtype, a discriminated record type or subtype with no initial + -- discriminant values or a class wide type or subtype and returns True if + -- so. False for other type entities, or any entities that are not types. + + function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean; + -- Ent is any entity. True for a type that is "inherently" limited (i.e. + -- cannot become nonlimited). From the Ada 2005 RM-7.5(8.1/2), "a type with + -- a part that is of a task, protected, or explicitly limited record type". + -- These are the types that are defined as return-by-reference types in Ada + -- 95 (see RM95-6.5(11-16)). In Ada 2005, these are the types that require + -- build-in-place for function calls. Note that build-in-place is allowed + -- for other types, too. This is also used for identifying pure procedures + -- whose calls should not be eliminated (RM 10.2.1(18/2)). + + function Is_Limited_Type (Ent : Entity_Id) return Boolean; + -- Ent is any entity. Returns true if Ent is a limited type (limited + -- private type, limited interface type, task type, protected type, + -- composite containing a limited component, or a subtype of any of + -- these types). + + function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id; + -- Given a subtype Typ, this function finds out the nearest ancestor from + -- which constraints and predicates are inherited. There is no simple link + -- for doing this, consider: + -- + -- subtype R is Integer range 1 .. 10; + -- type T is new R; + -- + -- In this case the nearest ancestor is R, but the Etype of T'Base will + -- point to R'Base, so we have to go rummaging in the declarations to get + -- this information. It is used for making sure we freeze this before we + -- freeze Typ, and also for retrieving inherited predicate information. + -- For the case of base types or first subtypes, there is no useful entity + -- to return, so Empty is returned. + -- + -- Note: this is similar to Ancestor_Subtype except that it also deals + -- with the case of derived types. + + function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id; + -- This is similar to Enclosing_Dynamic_Scope except that if Ent is itself + -- a dynamic scope, then it is returned. Otherwise the result is the same + -- as that returned by Enclosing_Dynamic_Scope. + + function Next_Tag_Component (Tag : Entity_Id) return Entity_Id; + -- Tag must be an entity representing a _Tag field of a tagged record. + -- The result returned is the next _Tag field in this record, or Empty + -- if this is the last such field. + + function Number_Discriminants (Typ : Entity_Id) return Pos; + -- Typ is a type with discriminants, yields number of discriminants in type + + function Ultimate_Alias (Prim : Entity_Id) return Entity_Id; + pragma Inline (Ultimate_Alias); + -- Return the last entity in the chain of aliased entities of Prim. If Prim + -- has no alias return Prim. + +end Sem_Aux; diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb new file mode 100644 index 000000000..400bc1173 --- /dev/null +++ b/gcc/ada/sem_case.adb @@ -0,0 +1,1052 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C A S E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1996-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Errout; use Errout; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sem_Type; use Sem_Type; +with Snames; use Snames; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +with Ada.Unchecked_Deallocation; + +with GNAT.Heap_Sort_G; + +package body Sem_Case is + + type Choice_Bounds is record + Lo : Node_Id; + Hi : Node_Id; + Node : Node_Id; + end record; + -- Represent one choice bounds entry with Lo and Hi values, Node points + -- to the choice node itself. + + type Choice_Table_Type is array (Nat range <>) of Choice_Bounds; + -- Table type used to sort the choices present in a case statement, array + -- aggregate or record variant. The actual entries are stored in 1 .. Last, + -- but we have a 0 entry for convenience in sorting. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Check_Choices + (Choice_Table : in out Choice_Table_Type; + Bounds_Type : Entity_Id; + Subtyp : Entity_Id; + Others_Present : Boolean; + Case_Node : Node_Id); + -- This is the procedure which verifies that a set of case alternatives + -- or record variant choices has no duplicates, and covers the range + -- specified by Bounds_Type. Choice_Table contains the discrete choices + -- to check. These must start at position 1. + -- + -- Furthermore Choice_Table (0) must exist. This element is used by + -- the sorting algorithm as a temporary. Others_Present is a flag + -- indicating whether or not an Others choice is present. Finally + -- Msg_Sloc gives the source location of the construct containing the + -- choices in the Choice_Table. + -- + -- Bounds_Type is the type whose range must be covered by the alternatives + -- + -- Subtyp is the subtype of the expression. If its bounds are non-static + -- the alternatives must cover its base type. + + function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id; + -- Given a Pos value of enumeration type Ctype, returns the name + -- ID of an appropriate string to be used in error message output. + + procedure Expand_Others_Choice + (Case_Table : Choice_Table_Type; + Others_Choice : Node_Id; + Choice_Type : Entity_Id); + -- The case table is the table generated by a call to Analyze_Choices + -- (with just 1 .. Last_Choice entries present). Others_Choice is a + -- pointer to the N_Others_Choice node (this routine is only called if + -- an others choice is present), and Choice_Type is the discrete type + -- of the bounds. The effect of this call is to analyze the cases and + -- determine the set of values covered by others. This choice list is + -- set in the Others_Discrete_Choices field of the N_Others_Choice node. + + ------------------- + -- Check_Choices -- + ------------------- + + procedure Check_Choices + (Choice_Table : in out Choice_Table_Type; + Bounds_Type : Entity_Id; + Subtyp : Entity_Id; + Others_Present : Boolean; + Case_Node : Node_Id) + is + procedure Explain_Non_Static_Bound; + -- Called when we find a non-static bound, requiring the base type to + -- be covered. Provides where possible a helpful explanation of why the + -- bounds are non-static, since this is not always obvious. + + function Lt_Choice (C1, C2 : Natural) return Boolean; + -- Comparison routine for comparing Choice_Table entries. Use the lower + -- bound of each Choice as the key. + + procedure Move_Choice (From : Natural; To : Natural); + -- Move routine for sorting the Choice_Table + + package Sorting is new GNAT.Heap_Sort_G (Move_Choice, Lt_Choice); + + procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id); + procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint); + procedure Issue_Msg (Value1 : Uint; Value2 : Node_Id); + procedure Issue_Msg (Value1 : Uint; Value2 : Uint); + -- Issue an error message indicating that there are missing choices, + -- followed by the image of the missing choices themselves which lie + -- between Value1 and Value2 inclusive. + + --------------- + -- Issue_Msg -- + --------------- + + procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id) is + begin + Issue_Msg (Expr_Value (Value1), Expr_Value (Value2)); + end Issue_Msg; + + procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint) is + begin + Issue_Msg (Expr_Value (Value1), Value2); + end Issue_Msg; + + procedure Issue_Msg (Value1 : Uint; Value2 : Node_Id) is + begin + Issue_Msg (Value1, Expr_Value (Value2)); + end Issue_Msg; + + procedure Issue_Msg (Value1 : Uint; Value2 : Uint) is + Msg_Sloc : constant Source_Ptr := Sloc (Case_Node); + + begin + -- In some situations, we call this with a null range, and + -- obviously we don't want to complain in this case! + + if Value1 > Value2 then + return; + end if; + + -- Case of only one value that is missing + + if Value1 = Value2 then + if Is_Integer_Type (Bounds_Type) then + Error_Msg_Uint_1 := Value1; + Error_Msg ("missing case value: ^!", Msg_Sloc); + else + Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type); + Error_Msg ("missing case value: %!", Msg_Sloc); + end if; + + -- More than one choice value, so print range of values + + else + if Is_Integer_Type (Bounds_Type) then + Error_Msg_Uint_1 := Value1; + Error_Msg_Uint_2 := Value2; + Error_Msg ("missing case values: ^ .. ^!", Msg_Sloc); + else + Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type); + Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type); + Error_Msg ("missing case values: % .. %!", Msg_Sloc); + end if; + end if; + end Issue_Msg; + + --------------- + -- Lt_Choice -- + --------------- + + function Lt_Choice (C1, C2 : Natural) return Boolean is + begin + return + Expr_Value (Choice_Table (Nat (C1)).Lo) + < + Expr_Value (Choice_Table (Nat (C2)).Lo); + end Lt_Choice; + + ----------------- + -- Move_Choice -- + ----------------- + + procedure Move_Choice (From : Natural; To : Natural) is + begin + Choice_Table (Nat (To)) := Choice_Table (Nat (From)); + end Move_Choice; + + ------------------------------ + -- Explain_Non_Static_Bound -- + ------------------------------ + + procedure Explain_Non_Static_Bound is + Expr : Node_Id; + + begin + if Nkind (Case_Node) = N_Variant_Part then + Expr := Name (Case_Node); + else + Expr := Expression (Case_Node); + end if; + + if Bounds_Type /= Subtyp then + + -- If the case is a variant part, the expression is given by + -- the discriminant itself, and the bounds are the culprits. + + if Nkind (Case_Node) = N_Variant_Part then + Error_Msg_NE + ("bounds of & are not static," & + " alternatives must cover base type", Expr, Expr); + + -- If this is a case statement, the expression may be + -- non-static or else the subtype may be at fault. + + elsif Is_Entity_Name (Expr) then + Error_Msg_NE + ("bounds of & are not static," & + " alternatives must cover base type", Expr, Expr); + + else + Error_Msg_N + ("subtype of expression is not static," + & " alternatives must cover base type!", Expr); + end if; + + -- Otherwise the expression is not static, even if the bounds of the + -- type are, or else there are missing alternatives. If both, the + -- additional information may be redundant but harmless. + + elsif not Is_Entity_Name (Expr) then + Error_Msg_N + ("subtype of expression is not static, " + & "alternatives must cover base type!", Expr); + end if; + end Explain_Non_Static_Bound; + + -- Variables local to Check_Choices + + Choice : Node_Id; + Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type); + Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type); + + Prev_Choice : Node_Id; + + Hi : Uint; + Lo : Uint; + Prev_Hi : Uint; + + -- Start of processing for Check_Choices + + begin + -- Choice_Table must start at 0 which is an unused location used + -- by the sorting algorithm. However the first valid position for + -- a discrete choice is 1. + + pragma Assert (Choice_Table'First = 0); + + if Choice_Table'Last = 0 then + if not Others_Present then + Issue_Msg (Bounds_Lo, Bounds_Hi); + end if; + + return; + end if; + + Sorting.Sort (Positive (Choice_Table'Last)); + + Lo := Expr_Value (Choice_Table (1).Lo); + Hi := Expr_Value (Choice_Table (1).Hi); + Prev_Hi := Hi; + + if not Others_Present and then Expr_Value (Bounds_Lo) < Lo then + Issue_Msg (Bounds_Lo, Lo - 1); + + -- If values are missing outside of the subtype, add explanation. + -- No additional message if only one value is missing. + + if Expr_Value (Bounds_Lo) < Lo - 1 then + Explain_Non_Static_Bound; + end if; + end if; + + for J in 2 .. Choice_Table'Last loop + Lo := Expr_Value (Choice_Table (J).Lo); + Hi := Expr_Value (Choice_Table (J).Hi); + + if Lo <= Prev_Hi then + Choice := Choice_Table (J).Node; + + -- Find first previous choice that overlaps + + for K in 1 .. J - 1 loop + if Lo <= Expr_Value (Choice_Table (K).Hi) then + Prev_Choice := Choice_Table (K).Node; + exit; + end if; + end loop; + + if Sloc (Prev_Choice) <= Sloc (Choice) then + Error_Msg_Sloc := Sloc (Prev_Choice); + Error_Msg_N ("duplication of choice value#", Choice); + else + Error_Msg_Sloc := Sloc (Choice); + Error_Msg_N ("duplication of choice value#", Prev_Choice); + end if; + + elsif not Others_Present and then Lo /= Prev_Hi + 1 then + Issue_Msg (Prev_Hi + 1, Lo - 1); + end if; + + if Hi > Prev_Hi then + Prev_Hi := Hi; + end if; + end loop; + + if not Others_Present and then Expr_Value (Bounds_Hi) > Hi then + Issue_Msg (Hi + 1, Bounds_Hi); + + if Expr_Value (Bounds_Hi) > Hi + 1 then + Explain_Non_Static_Bound; + end if; + end if; + end Check_Choices; + + ------------------ + -- Choice_Image -- + ------------------ + + function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id is + Rtp : constant Entity_Id := Root_Type (Ctype); + Lit : Entity_Id; + C : Int; + + begin + -- For character, or wide [wide] character. If 7-bit ASCII graphic + -- range, then build and return appropriate character literal name + + if Is_Standard_Character_Type (Ctype) then + C := UI_To_Int (Value); + + if C in 16#20# .. 16#7E# then + Set_Character_Literal_Name (Char_Code (UI_To_Int (Value))); + return Name_Find; + end if; + + -- For user defined enumeration type, find enum/char literal + + else + Lit := First_Literal (Rtp); + + for J in 1 .. UI_To_Int (Value) loop + Next_Literal (Lit); + end loop; + + -- If enumeration literal, just return its value + + if Nkind (Lit) = N_Defining_Identifier then + return Chars (Lit); + + -- For character literal, get the name and use it if it is + -- for a 7-bit ASCII graphic character in 16#20#..16#7E#. + + else + Get_Decoded_Name_String (Chars (Lit)); + + if Name_Len = 3 + and then Name_Buffer (2) in + Character'Val (16#20#) .. Character'Val (16#7E#) + then + return Chars (Lit); + end if; + end if; + end if; + + -- If we fall through, we have a character literal which is not in + -- the 7-bit ASCII graphic set. For such cases, we construct the + -- name "type'val(nnn)" where type is the choice type, and nnn is + -- the pos value passed as an argument to Choice_Image. + + Get_Name_String (Chars (First_Subtype (Ctype))); + + Add_Str_To_Name_Buffer ("'val("); + UI_Image (Value); + Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length)); + Add_Char_To_Name_Buffer (')'); + return Name_Find; + end Choice_Image; + + -------------------------- + -- Expand_Others_Choice -- + -------------------------- + + procedure Expand_Others_Choice + (Case_Table : Choice_Table_Type; + Others_Choice : Node_Id; + Choice_Type : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (Others_Choice); + Choice_List : constant List_Id := New_List; + Choice : Node_Id; + Exp_Lo : Node_Id; + Exp_Hi : Node_Id; + Hi : Uint; + Lo : Uint; + Previous_Hi : Uint; + + function Build_Choice (Value1, Value2 : Uint) return Node_Id; + -- Builds a node representing the missing choices given by the + -- Value1 and Value2. A N_Range node is built if there is more than + -- one literal value missing. Otherwise a single N_Integer_Literal, + -- N_Identifier or N_Character_Literal is built depending on what + -- Choice_Type is. + + function Lit_Of (Value : Uint) return Node_Id; + -- Returns the Node_Id for the enumeration literal corresponding to the + -- position given by Value within the enumeration type Choice_Type. + + ------------------ + -- Build_Choice -- + ------------------ + + function Build_Choice (Value1, Value2 : Uint) return Node_Id is + Lit_Node : Node_Id; + Lo, Hi : Node_Id; + + begin + -- If there is only one choice value missing between Value1 and + -- Value2, build an integer or enumeration literal to represent it. + + if (Value2 - Value1) = 0 then + if Is_Integer_Type (Choice_Type) then + Lit_Node := Make_Integer_Literal (Loc, Value1); + Set_Etype (Lit_Node, Choice_Type); + else + Lit_Node := Lit_Of (Value1); + end if; + + -- Otherwise is more that one choice value that is missing between + -- Value1 and Value2, therefore build a N_Range node of either + -- integer or enumeration literals. + + else + if Is_Integer_Type (Choice_Type) then + Lo := Make_Integer_Literal (Loc, Value1); + Set_Etype (Lo, Choice_Type); + Hi := Make_Integer_Literal (Loc, Value2); + Set_Etype (Hi, Choice_Type); + Lit_Node := + Make_Range (Loc, + Low_Bound => Lo, + High_Bound => Hi); + + else + Lit_Node := + Make_Range (Loc, + Low_Bound => Lit_Of (Value1), + High_Bound => Lit_Of (Value2)); + end if; + end if; + + return Lit_Node; + end Build_Choice; + + ------------ + -- Lit_Of -- + ------------ + + function Lit_Of (Value : Uint) return Node_Id is + Lit : Entity_Id; + + begin + -- In the case where the literal is of type Character, there needs + -- to be some special handling since there is no explicit chain + -- of literals to search. Instead, a N_Character_Literal node + -- is created with the appropriate Char_Code and Chars fields. + + if Is_Standard_Character_Type (Choice_Type) then + Set_Character_Literal_Name (Char_Code (UI_To_Int (Value))); + Lit := New_Node (N_Character_Literal, Loc); + Set_Chars (Lit, Name_Find); + Set_Char_Literal_Value (Lit, Value); + Set_Etype (Lit, Choice_Type); + Set_Is_Static_Expression (Lit, True); + return Lit; + + -- Otherwise, iterate through the literals list of Choice_Type + -- "Value" number of times until the desired literal is reached + -- and then return an occurrence of it. + + else + Lit := First_Literal (Choice_Type); + for J in 1 .. UI_To_Int (Value) loop + Next_Literal (Lit); + end loop; + + return New_Occurrence_Of (Lit, Loc); + end if; + end Lit_Of; + + -- Start of processing for Expand_Others_Choice + + begin + if Case_Table'Last = 0 then + + -- Special case: only an others case is present. + -- The others case covers the full range of the type. + + if Is_Static_Subtype (Choice_Type) then + Choice := New_Occurrence_Of (Choice_Type, Loc); + else + Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc); + end if; + + Set_Others_Discrete_Choices (Others_Choice, New_List (Choice)); + return; + end if; + + -- Establish the bound values for the choice depending upon whether + -- the type of the case statement is static or not. + + if Is_OK_Static_Subtype (Choice_Type) then + Exp_Lo := Type_Low_Bound (Choice_Type); + Exp_Hi := Type_High_Bound (Choice_Type); + else + Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type)); + Exp_Hi := Type_High_Bound (Base_Type (Choice_Type)); + end if; + + Lo := Expr_Value (Case_Table (1).Lo); + Hi := Expr_Value (Case_Table (1).Hi); + Previous_Hi := Expr_Value (Case_Table (1).Hi); + + -- Build the node for any missing choices that are smaller than any + -- explicit choices given in the case. + + if Expr_Value (Exp_Lo) < Lo then + Append (Build_Choice (Expr_Value (Exp_Lo), Lo - 1), Choice_List); + end if; + + -- Build the nodes representing any missing choices that lie between + -- the explicit ones given in the case. + + for J in 2 .. Case_Table'Last loop + Lo := Expr_Value (Case_Table (J).Lo); + Hi := Expr_Value (Case_Table (J).Hi); + + if Lo /= (Previous_Hi + 1) then + Append_To (Choice_List, Build_Choice (Previous_Hi + 1, Lo - 1)); + end if; + + Previous_Hi := Hi; + end loop; + + -- Build the node for any missing choices that are greater than any + -- explicit choices given in the case. + + if Expr_Value (Exp_Hi) > Hi then + Append (Build_Choice (Hi + 1, Expr_Value (Exp_Hi)), Choice_List); + end if; + + Set_Others_Discrete_Choices (Others_Choice, Choice_List); + + -- Warn on null others list if warning option set + + if Warn_On_Redundant_Constructs + and then Comes_From_Source (Others_Choice) + and then Is_Empty_List (Choice_List) + then + Error_Msg_N ("?OTHERS choice is redundant", Others_Choice); + Error_Msg_N ("\previous choices cover all values", Others_Choice); + end if; + end Expand_Others_Choice; + + ----------- + -- No_OP -- + ----------- + + procedure No_OP (C : Node_Id) is + pragma Warnings (Off, C); + begin + null; + end No_OP; + + -------------------------------- + -- Generic_Choices_Processing -- + -------------------------------- + + package body Generic_Choices_Processing is + + -- The following type is used to gather the entries for the choice + -- table, so that we can then allocate the right length. + + type Link; + type Link_Ptr is access all Link; + + type Link is record + Val : Choice_Bounds; + Nxt : Link_Ptr; + end record; + + procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr); + + --------------------- + -- Analyze_Choices -- + --------------------- + + procedure Analyze_Choices + (N : Node_Id; + Subtyp : Entity_Id; + Raises_CE : out Boolean; + Others_Present : out Boolean) + is + E : Entity_Id; + + Enode : Node_Id; + -- This is where we post error messages for bounds out of range + + Choice_List : Link_Ptr := null; + -- Gather list of choices + + Num_Choices : Nat := 0; + -- Number of entries in Choice_List + + Choice_Type : constant Entity_Id := Base_Type (Subtyp); + -- The actual type against which the discrete choices are resolved. + -- Note that this type is always the base type not the subtype of the + -- ruling expression, index or discriminant. + + Bounds_Type : Entity_Id; + -- The type from which are derived the bounds of the values covered + -- by the discrete choices (see 3.8.1 (4)). If a discrete choice + -- specifies a value outside of these bounds we have an error. + + Bounds_Lo : Uint; + Bounds_Hi : Uint; + -- The actual bounds of the above type + + Expected_Type : Entity_Id; + -- The expected type of each choice. Equal to Choice_Type, except if + -- the expression is universal, in which case the choices can be of + -- any integer type. + + Alt : Node_Id; + -- A case statement alternative or a variant in a record type + -- declaration. + + Choice : Node_Id; + Kind : Node_Kind; + -- The node kind of the current Choice + + Delete_Choice : Boolean; + -- Set to True to delete the current choice + + Others_Choice : Node_Id := Empty; + -- Remember others choice if it is present (empty otherwise) + + procedure Check (Choice : Node_Id; Lo, Hi : Node_Id); + -- Checks the validity of the bounds of a choice. When the bounds + -- are static and no error occurred the bounds are collected for + -- later entry into the choices table so that they can be sorted + -- later on. + + ----------- + -- Check -- + ----------- + + procedure Check (Choice : Node_Id; Lo, Hi : Node_Id) is + Lo_Val : Uint; + Hi_Val : Uint; + + begin + -- First check if an error was already detected on either bounds + + if Etype (Lo) = Any_Type or else Etype (Hi) = Any_Type then + return; + + -- Do not insert non static choices in the table to be sorted + + elsif not Is_Static_Expression (Lo) + or else not Is_Static_Expression (Hi) + then + Process_Non_Static_Choice (Choice); + return; + + -- Ignore range which raise constraint error + + elsif Raises_Constraint_Error (Lo) + or else Raises_Constraint_Error (Hi) + then + Raises_CE := True; + return; + + -- Otherwise we have an OK static choice + + else + Lo_Val := Expr_Value (Lo); + Hi_Val := Expr_Value (Hi); + + -- Do not insert null ranges in the choices table + + if Lo_Val > Hi_Val then + Process_Empty_Choice (Choice); + return; + end if; + end if; + + -- Check for low bound out of range + + if Lo_Val < Bounds_Lo then + + -- If the choice is an entity name, then it is a type, and we + -- want to post the message on the reference to this entity. + -- Otherwise post it on the lower bound of the range. + + if Is_Entity_Name (Choice) then + Enode := Choice; + else + Enode := Lo; + end if; + + -- Specialize message for integer/enum type + + if Is_Integer_Type (Bounds_Type) then + Error_Msg_Uint_1 := Bounds_Lo; + Error_Msg_N ("minimum allowed choice value is^", Enode); + else + Error_Msg_Name_1 := Choice_Image (Bounds_Lo, Bounds_Type); + Error_Msg_N ("minimum allowed choice value is%", Enode); + end if; + end if; + + -- Check for high bound out of range + + if Hi_Val > Bounds_Hi then + + -- If the choice is an entity name, then it is a type, and we + -- want to post the message on the reference to this entity. + -- Otherwise post it on the upper bound of the range. + + if Is_Entity_Name (Choice) then + Enode := Choice; + else + Enode := Hi; + end if; + + -- Specialize message for integer/enum type + + if Is_Integer_Type (Bounds_Type) then + Error_Msg_Uint_1 := Bounds_Hi; + Error_Msg_N ("maximum allowed choice value is^", Enode); + else + Error_Msg_Name_1 := Choice_Image (Bounds_Hi, Bounds_Type); + Error_Msg_N ("maximum allowed choice value is%", Enode); + end if; + end if; + + -- Collect bounds in the list + + -- Note: we still store the bounds, even if they are out of range, + -- since this may prevent unnecessary cascaded errors for values + -- that are covered by such an excessive range. + + Choice_List := + new Link'(Val => (Lo, Hi, Choice), Nxt => Choice_List); + Num_Choices := Num_Choices + 1; + end Check; + + -- Start of processing for Analyze_Choices + + begin + Raises_CE := False; + Others_Present := False; + + -- If Subtyp is not a static subtype Ada 95 requires then we use the + -- bounds of its base type to determine the values covered by the + -- discrete choices. + + if Is_OK_Static_Subtype (Subtyp) then + Bounds_Type := Subtyp; + else + Bounds_Type := Choice_Type; + end if; + + -- Obtain static bounds of type, unless this is a generic formal + -- discrete type for which all choices will be non-static. + + if not Is_Generic_Type (Root_Type (Bounds_Type)) + or else Ekind (Bounds_Type) /= E_Enumeration_Type + then + Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type)); + Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type)); + end if; + + if Choice_Type = Universal_Integer then + Expected_Type := Any_Integer; + else + Expected_Type := Choice_Type; + end if; + + -- Now loop through the case alternatives or record variants + + Alt := First (Get_Alternatives (N)); + while Present (Alt) loop + + -- If pragma, just analyze it + + if Nkind (Alt) = N_Pragma then + Analyze (Alt); + + -- Otherwise check each choice against its base type + + else + Choice := First (Get_Choices (Alt)); + while Present (Choice) loop + Delete_Choice := False; + Analyze (Choice); + Kind := Nkind (Choice); + + -- Choice is a Range + + if Kind = N_Range + or else (Kind = N_Attribute_Reference + and then Attribute_Name (Choice) = Name_Range) + then + Resolve (Choice, Expected_Type); + Check (Choice, Low_Bound (Choice), High_Bound (Choice)); + + -- Choice is a subtype name + + elsif Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + then + if not Covers (Expected_Type, Etype (Choice)) then + Wrong_Type (Choice, Choice_Type); + + else + E := Entity (Choice); + + -- Case of predicated subtype + + if Has_Predicates (E) then + + -- Use of non-static predicate is an error + + if not Is_Discrete_Type (E) + or else No (Static_Predicate (E)) + then + Bad_Predicated_Subtype_Use + ("cannot use subtype& with non-static " + & "predicate as case alternative", Choice, E); + + -- Static predicate case + + else + declare + Copy : constant List_Id := Empty_List; + P : Node_Id; + C : Node_Id; + + begin + -- Loop through entries in predicate list, + -- converting to choices. Note that if the + -- list is empty, corresponding to a False + -- predicate, then no choices are inserted. + + P := First (Static_Predicate (E)); + while Present (P) loop + C := New_Copy (P); + Set_Sloc (C, Sloc (Choice)); + Append_To (Copy, C); + Next (P); + end loop; + + Insert_List_After (Choice, Copy); + Delete_Choice := True; + end; + end if; + + -- Not predicated subtype case + + elsif not Is_Static_Subtype (E) then + Process_Non_Static_Choice (Choice); + else + Check + (Choice, Type_Low_Bound (E), Type_High_Bound (E)); + end if; + end if; + + -- Choice is a subtype indication + + elsif Kind = N_Subtype_Indication then + Resolve_Discrete_Subtype_Indication + (Choice, Expected_Type); + + -- Here for other than predicated subtype case + + if Etype (Choice) /= Any_Type then + declare + C : constant Node_Id := Constraint (Choice); + R : constant Node_Id := Range_Expression (C); + L : constant Node_Id := Low_Bound (R); + H : constant Node_Id := High_Bound (R); + + begin + E := Entity (Subtype_Mark (Choice)); + + if not Is_Static_Subtype (E) then + Process_Non_Static_Choice (Choice); + + else + if Is_OK_Static_Expression (L) + and then Is_OK_Static_Expression (H) + then + if Expr_Value (L) > Expr_Value (H) then + Process_Empty_Choice (Choice); + else + if Is_Out_Of_Range (L, E) then + Apply_Compile_Time_Constraint_Error + (L, "static value out of range", + CE_Range_Check_Failed); + end if; + + if Is_Out_Of_Range (H, E) then + Apply_Compile_Time_Constraint_Error + (H, "static value out of range", + CE_Range_Check_Failed); + end if; + end if; + end if; + + Check (Choice, L, H); + end if; + end; + end if; + + -- The others choice is only allowed for the last + -- alternative and as its only choice. + + elsif Kind = N_Others_Choice then + if not (Choice = First (Get_Choices (Alt)) + and then Choice = Last (Get_Choices (Alt)) + and then Alt = Last (Get_Alternatives (N))) + then + Error_Msg_N + ("the choice OTHERS must appear alone and last", + Choice); + return; + end if; + + Others_Present := True; + Others_Choice := Choice; + + -- Only other possibility is an expression + + else + Resolve (Choice, Expected_Type); + Check (Choice, Choice, Choice); + end if; + + -- Move to next choice, deleting the current one if the + -- flag requesting this deletion is set True. + + declare + C : constant Node_Id := Choice; + begin + Next (Choice); + + if Delete_Choice then + Remove (C); + end if; + end; + end loop; + + Process_Associated_Node (Alt); + end if; + + Next (Alt); + end loop; + + -- Now we can create the Choice_Table, since we know how long + -- it needs to be so we can allocate exactly the right length. + + declare + Choice_Table : Choice_Table_Type (0 .. Num_Choices); + + begin + -- Now copy the items we collected in the linked list into this + -- newly allocated table (leave entry 0 unused for sorting). + + declare + T : Link_Ptr; + begin + for J in 1 .. Num_Choices loop + T := Choice_List; + Choice_List := T.Nxt; + Choice_Table (J) := T.Val; + Free (T); + end loop; + end; + + Check_Choices + (Choice_Table, + Bounds_Type, + Subtyp, + Others_Present or else (Choice_Type = Universal_Integer), + N); + + -- If no others choice we are all done, otherwise we have one more + -- step, which is to set the Others_Discrete_Choices field of the + -- others choice (to contain all otherwise unspecified choices). + -- Skip this if CE is known to be raised. + + if Others_Present and not Raises_CE then + Expand_Others_Choice + (Case_Table => Choice_Table, + Others_Choice => Others_Choice, + Choice_Type => Bounds_Type); + end if; + end; + end Analyze_Choices; + + end Generic_Choices_Processing; + +end Sem_Case; diff --git a/gcc/ada/sem_case.ads b/gcc/ada/sem_case.ads new file mode 100644 index 000000000..ccee41f02 --- /dev/null +++ b/gcc/ada/sem_case.ads @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C A S E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1996-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Package containing the routines to process a list of discrete choices. +-- Such lists can occur in two different constructs: case statements and +-- record variants. We have factorized what used to be two very similar +-- sets of routines in one place. These are not currently used for the +-- aggregate case, since issues with nested aggregates make that case +-- substantially different. + +with Types; use Types; + +package Sem_Case is + + procedure No_OP (C : Node_Id); + -- The no-operation routine. Does absolutely nothing. Can be used + -- in the following generic for the parameter Process_Empty_Choice. + + generic + with function Get_Alternatives (N : Node_Id) return List_Id; + -- Function needed to get to the actual list of case statement + -- alternatives, or array aggregate component associations or + -- record variants from which we can then access the actual lists + -- of discrete choices. N is the node for the original construct + -- i.e. a case statement, an array aggregate or a record variant. + + with function Get_Choices (A : Node_Id) return List_Id; + -- Given a case statement alternative, array aggregate component + -- association or record variant A we need different access functions + -- to get to the actual list of discrete choices. + + with procedure Process_Empty_Choice (Choice : Node_Id); + -- Processing to carry out for an empty Choice + + with procedure Process_Non_Static_Choice (Choice : Node_Id); + -- Processing to carry out for a non static Choice + + with procedure Process_Associated_Node (A : Node_Id); + -- Associated with each case alternative, aggregate component + -- association or record variant A there is a node or list of nodes + -- that need semantic processing. This routine implements that + -- processing. + + package Generic_Choices_Processing is + + procedure Analyze_Choices + (N : Node_Id; + Subtyp : Entity_Id; + Raises_CE : out Boolean; + Others_Present : out Boolean); + -- From a case expression, case statement, array aggregate or record + -- variant N, this routine analyzes the corresponding list of discrete + -- choices. Subtyp is the subtype of the discrete choices. The type + -- against which the discrete choices must be resolved is its base type. + -- + -- In one of the bounds of a discrete choice raises a constraint + -- error the flag Raise_CE is set. + -- + -- Finally Others_Present is set to True if an Others choice is present + -- in the list of choices, and in this case the call also sets + -- Others_Discrete_Choices in the N_Others_Choice node. + + end Generic_Choices_Processing; + +end Sem_Case; diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb new file mode 100644 index 000000000..9311beb99 --- /dev/null +++ b/gcc/ada/sem_cat.adb @@ -0,0 +1,2252 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C A T -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Disp; use Exp_Disp; +with Fname; use Fname; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Opt; use Opt; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Eval; use Sem_Eval; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; + +package body Sem_Cat is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Check_Categorization_Dependencies + (Unit_Entity : Entity_Id; + Depended_Entity : Entity_Id; + Info_Node : Node_Id; + Is_Subunit : Boolean); + -- This procedure checks that the categorization of a lib unit and that + -- of the depended unit satisfy dependency restrictions. + -- The depended_entity can be the entity in a with_clause item, in which + -- case Info_Node denotes that item. The depended_entity can also be the + -- parent unit of a child unit, in which case Info_Node is the declaration + -- of the child unit. The error message is posted on Info_Node, and is + -- specialized if Is_Subunit is true. + + procedure Check_Non_Static_Default_Expr + (Type_Def : Node_Id; + Obj_Decl : Node_Id); + -- Iterate through the component list of a record definition, check + -- that no component is declared with a nonstatic default value. + -- If a nonstatic default exists, report an error on Obj_Decl. + + -- Iterate through the component list of a record definition, check + -- that no component is declared with a non-static default value. + + function Missing_Read_Write_Attributes (E : Entity_Id) return Boolean; + -- Return True if the entity or one of its subcomponents is of an access + -- type that does not have user-defined Read and Write attributes visible + -- at any place. + + function In_RCI_Declaration (N : Node_Id) return Boolean; + -- Determines if a declaration is within the visible part of a Remote + -- Call Interface compilation unit, for semantic checking purposes only + -- (returns false within an instance and within the package body). + + function In_RT_Declaration return Boolean; + -- Determines if current scope is within the declaration of a Remote Types + -- unit, for semantic checking purposes. + + function Is_Non_Remote_Access_Type (E : Entity_Id) return Boolean; + -- Returns true if the entity is a type whose full view is a non-remote + -- access type, for the purpose of enforcing E.2.2(8) rules. + + function In_Shared_Passive_Unit return Boolean; + -- Determines if current scope is within a Shared Passive compilation unit + + function Static_Discriminant_Expr (L : List_Id) return Boolean; + -- Iterate through the list of discriminants to check if any of them + -- contains non-static default expression, which is a violation in + -- a preelaborated library unit. + + procedure Validate_Remote_Access_Object_Type_Declaration (T : Entity_Id); + -- Check validity of declaration if RCI or RT unit. It should not contain + -- the declaration of an access-to-object type unless it is a general + -- access type that designates a class-wide limited private type. There are + -- also constraints about the primitive subprograms of the class-wide type. + -- RM E.2 (9, 13, 14) + + --------------------------------------- + -- Check_Categorization_Dependencies -- + --------------------------------------- + + procedure Check_Categorization_Dependencies + (Unit_Entity : Entity_Id; + Depended_Entity : Entity_Id; + Info_Node : Node_Id; + Is_Subunit : Boolean) + is + N : constant Node_Id := Info_Node; + Err : Boolean; + + -- Here we define an enumeration type to represent categorization types, + -- ordered so that a unit with a given categorization can only WITH + -- units with lower or equal categorization type. + + type Categorization is + (Pure, + Shared_Passive, + Remote_Types, + Remote_Call_Interface, + Normal); + + function Get_Categorization (E : Entity_Id) return Categorization; + -- Check categorization flags from entity, and return in the form + -- of the lowest value of the Categorization type that applies to E. + + ------------------------ + -- Get_Categorization -- + ------------------------ + + function Get_Categorization (E : Entity_Id) return Categorization is + begin + -- Get the lowest categorization that corresponds to E. Note that + -- nothing prevents several (different) categorization pragmas + -- to apply to the same library unit, in which case the unit has + -- all associated categories, so we need to be careful here to + -- check pragmas in proper Categorization order in order to + -- return the lowest applicable value. + + -- Ignore Pure specification if set by pragma Pure_Function + + if Is_Pure (E) + and then not + (Has_Pragma_Pure_Function (E) and not Has_Pragma_Pure (E)) + then + return Pure; + + elsif Is_Shared_Passive (E) then + return Shared_Passive; + + elsif Is_Remote_Types (E) then + return Remote_Types; + + elsif Is_Remote_Call_Interface (E) then + return Remote_Call_Interface; + + else + return Normal; + end if; + end Get_Categorization; + + Unit_Category : Categorization; + With_Category : Categorization; + + -- Start of processing for Check_Categorization_Dependencies + + begin + -- Intrinsic subprograms are preelaborated, so do not impose any + -- categorization dependencies. + + if Is_Intrinsic_Subprogram (Depended_Entity) then + return; + end if; + + -- First check 10.2.1 (11/1) rules on preelaborate packages + + if Is_Preelaborated (Unit_Entity) + and then not Is_Preelaborated (Depended_Entity) + and then not Is_Pure (Depended_Entity) + then + Err := True; + else + Err := False; + end if; + + -- Check categorization rules of RM E.2(5) + + Unit_Category := Get_Categorization (Unit_Entity); + With_Category := Get_Categorization (Depended_Entity); + + if With_Category > Unit_Category then + + -- Special case: Remote_Types and Remote_Call_Interface are allowed + -- to WITH anything in the package body, per (RM E.2(5)). + + if (Unit_Category = Remote_Types + or else Unit_Category = Remote_Call_Interface) + and then In_Package_Body (Unit_Entity) + then + null; + + -- Special case: Remote_Types can depend on Preelaborated per + -- Ada 2005 AI 0206. + + elsif Unit_Category = Remote_Types + and then Is_Preelaborated (Depended_Entity) + then + null; + + -- All other cases, we do have an error + + else + Err := True; + end if; + end if; + + -- Here if we have an error + + if Err then + + -- These messages are warnings in GNAT mode or if the -gnateP switch + -- was set. Otherwise these are real errors for real illegalities. + + -- The reason we suppress these errors in GNAT mode is that the run- + -- time has several instances of violations of the categorization + -- errors (e.g. Pure units withing Preelaborate units. All these + -- violations are harmless in the cases where we intend them, and + -- we suppress the warnings with Warnings (Off). In cases where we + -- do not intend the violation, warnings are errors in GNAT mode + -- anyway, so we will still get an error. + + Error_Msg_Warn := + Treat_Categorization_Errors_As_Warnings or GNAT_Mode; + + -- Don't give error if main unit is not an internal unit, and the + -- unit generating the message is an internal unit. This is the + -- situation in which such messages would be ignored in any case, + -- so it is convenient not to generate them (since it causes + -- annoying interference with debugging). + + if Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)) + and then not Is_Internal_File_Name (Unit_File_Name (Main_Unit)) + then + return; + + -- Subunit case + + elsif Is_Subunit then + Error_Msg_NE + (" + exit when Nam = TSS_Stream_Read; + + when Name_Write => + exit when Nam = TSS_Stream_Write; + + when Name_Input => + exit when Nam = TSS_Stream_Input; + + when Name_Output => + exit when Nam = TSS_Stream_Output; + + when others => + null; + + end case; + end if; + + Next_Rep_Item (Rep_Item); + end loop; + + -- If At_Any_Place is true, return True if the attribute is available + -- at any place; if it is false, return True only if the attribute is + -- currently visible. + + return Present (Rep_Item) + and then (Ada_Version < Ada_2005 + or else At_Any_Place + or else not Is_Hidden (Entity (Rep_Item))); + end Has_Stream_Attribute_Definition; + + --------------------------- + -- In_Preelaborated_Unit -- + --------------------------- + + function In_Preelaborated_Unit return Boolean is + Unit_Entity : constant Entity_Id := Current_Scope; + Unit_Kind : constant Node_Kind := + Nkind (Unit (Cunit (Current_Sem_Unit))); + + begin + -- There are no constraints on body of remote_call_interface or + -- remote_types packages. + + return (Unit_Entity /= Standard_Standard) + and then (Is_Preelaborated (Unit_Entity) + or else Is_Pure (Unit_Entity) + or else Is_Shared_Passive (Unit_Entity) + or else + ((Is_Remote_Types (Unit_Entity) + or else Is_Remote_Call_Interface (Unit_Entity)) + and then Ekind (Unit_Entity) = E_Package + and then Unit_Kind /= N_Package_Body + and then not In_Package_Body (Unit_Entity) + and then not In_Instance)); + end In_Preelaborated_Unit; + + ------------------ + -- In_Pure_Unit -- + ------------------ + + function In_Pure_Unit return Boolean is + begin + return Is_Pure (Current_Scope); + end In_Pure_Unit; + + ------------------------ + -- In_RCI_Declaration -- + ------------------------ + + function In_RCI_Declaration (N : Node_Id) return Boolean is + Unit_Entity : constant Entity_Id := Current_Scope; + Unit_Kind : constant Node_Kind := + Nkind (Unit (Cunit (Current_Sem_Unit))); + + begin + -- There are no restrictions on the private part or body + -- of an RCI unit. + + return Is_Remote_Call_Interface (Unit_Entity) + and then Is_Package_Or_Generic_Package (Unit_Entity) + and then Unit_Kind /= N_Package_Body + and then List_Containing (N) = + Visible_Declarations + (Specification (Unit_Declaration_Node (Unit_Entity))) + and then not In_Package_Body (Unit_Entity) + and then not In_Instance; + + -- What about the case of a nested package in the visible part??? + -- This case is missed by the List_Containing check above??? + end In_RCI_Declaration; + + ----------------------- + -- In_RT_Declaration -- + ----------------------- + + function In_RT_Declaration return Boolean is + Unit_Entity : constant Entity_Id := Current_Scope; + Unit_Kind : constant Node_Kind := + Nkind (Unit (Cunit (Current_Sem_Unit))); + + begin + -- There are no restrictions on the body of a Remote Types unit + + return Is_Remote_Types (Unit_Entity) + and then Is_Package_Or_Generic_Package (Unit_Entity) + and then Unit_Kind /= N_Package_Body + and then not In_Package_Body (Unit_Entity) + and then not In_Instance; + end In_RT_Declaration; + + ---------------------------- + -- In_Shared_Passive_Unit -- + ---------------------------- + + function In_Shared_Passive_Unit return Boolean is + Unit_Entity : constant Entity_Id := Current_Scope; + + begin + return Is_Shared_Passive (Unit_Entity); + end In_Shared_Passive_Unit; + + --------------------------------------- + -- In_Subprogram_Task_Protected_Unit -- + --------------------------------------- + + function In_Subprogram_Task_Protected_Unit return Boolean is + E : Entity_Id; + + begin + -- The following is to verify that a declaration is inside + -- subprogram, generic subprogram, task unit, protected unit. + -- Used to validate if a lib. unit is Pure. RM 10.2.1(16). + + -- Use scope chain to check successively outer scopes + + E := Current_Scope; + loop + if Is_Subprogram (E) + or else + Is_Generic_Subprogram (E) + or else + Is_Concurrent_Type (E) + then + return True; + + elsif E = Standard_Standard then + return False; + end if; + + E := Scope (E); + end loop; + end In_Subprogram_Task_Protected_Unit; + + ------------------------------- + -- Is_Non_Remote_Access_Type -- + ------------------------------- + + function Is_Non_Remote_Access_Type (E : Entity_Id) return Boolean is + U_E : constant Entity_Id := Underlying_Type (E); + begin + if No (U_E) then + + -- This case arises for the case of a generic formal type, in which + -- case E.2.2(8) rules will be enforced at instantiation time. + + return False; + end if; + + return Is_Access_Type (U_E) + and then not Is_Remote_Access_To_Class_Wide_Type (U_E) + and then not Is_Remote_Access_To_Subprogram_Type (U_E); + end Is_Non_Remote_Access_Type; + + ---------------------------------- + -- Missing_Read_Write_Attribute -- + ---------------------------------- + + function Missing_Read_Write_Attributes (E : Entity_Id) return Boolean is + Component : Entity_Id; + Component_Type : Entity_Id; + U_E : constant Entity_Id := Underlying_Type (E); + + function Has_Read_Write_Attributes (E : Entity_Id) return Boolean; + -- Return True if entity has attribute definition clauses for Read and + -- Write attributes that are visible at some place. + + ------------------------------- + -- Has_Read_Write_Attributes -- + ------------------------------- + + function Has_Read_Write_Attributes (E : Entity_Id) return Boolean is + begin + return True + and then Has_Stream_Attribute_Definition (E, + TSS_Stream_Read, At_Any_Place => True) + and then Has_Stream_Attribute_Definition (E, + TSS_Stream_Write, At_Any_Place => True); + end Has_Read_Write_Attributes; + + -- Start of processing for Missing_Read_Write_Attributes + + begin + if No (U_E) then + return False; + + elsif Has_Read_Write_Attributes (E) + or else Has_Read_Write_Attributes (U_E) + then + return False; + + elsif Is_Non_Remote_Access_Type (U_E) then + return True; + end if; + + if Is_Record_Type (U_E) then + Component := First_Entity (U_E); + while Present (Component) loop + if not Is_Tag (Component) then + Component_Type := Etype (Component); + + if Missing_Read_Write_Attributes (Component_Type) then + return True; + end if; + end if; + + Next_Entity (Component); + end loop; + end if; + + return False; + end Missing_Read_Write_Attributes; + + ------------------------------------- + -- Set_Categorization_From_Pragmas -- + ------------------------------------- + + procedure Set_Categorization_From_Pragmas (N : Node_Id) is + P : constant Node_Id := Parent (N); + S : constant Entity_Id := Current_Scope; + + procedure Set_Parents (Visibility : Boolean); + -- If this is a child instance, the parents are not immediately + -- visible during analysis. Make them momentarily visible so that + -- the argument of the pragma can be resolved properly, and reset + -- afterwards. + + ----------------- + -- Set_Parents -- + ----------------- + + procedure Set_Parents (Visibility : Boolean) is + Par : Entity_Id; + begin + Par := Scope (S); + while Present (Par) and then Par /= Standard_Standard loop + Set_Is_Immediately_Visible (Par, Visibility); + Par := Scope (Par); + end loop; + end Set_Parents; + + -- Start of processing for Set_Categorization_From_Pragmas + + begin + -- Deal with categorization pragmas in Pragmas of Compilation_Unit. + -- The purpose is to set categorization flags before analyzing the + -- unit itself, so as to diagnose violations of categorization as + -- we process each declaration, even though the pragma appears after + -- the unit. + + if Nkind (P) /= N_Compilation_Unit then + return; + end if; + + declare + PN : Node_Id; + + begin + if Is_Child_Unit (S) + and then Is_Generic_Instance (S) + then + Set_Parents (True); + end if; + + PN := First (Pragmas_After (Aux_Decls_Node (P))); + while Present (PN) loop + + -- Skip implicit types that may have been introduced by + -- previous analysis. + + if Nkind (PN) = N_Pragma then + case Get_Pragma_Id (PN) is + when Pragma_All_Calls_Remote | + Pragma_Preelaborate | + Pragma_Pure | + Pragma_Remote_Call_Interface | + Pragma_Remote_Types | + Pragma_Shared_Passive => Analyze (PN); + when others => null; + end case; + end if; + + Next (PN); + end loop; + + if Is_Child_Unit (S) + and then Is_Generic_Instance (S) + then + Set_Parents (False); + end if; + end; + end Set_Categorization_From_Pragmas; + + ----------------------------------- + -- Set_Categorization_From_Scope -- + ----------------------------------- + + procedure Set_Categorization_From_Scope (E : Entity_Id; Scop : Entity_Id) is + Declaration : Node_Id := Empty; + Specification : Node_Id := Empty; + + begin + Set_Is_Pure (E, + Is_Pure (Scop) and then Is_Library_Level_Entity (E)); + + if not Is_Remote_Call_Interface (E) then + if Ekind (E) in Subprogram_Kind then + Declaration := Unit_Declaration_Node (E); + + if Nkind (Declaration) = N_Subprogram_Body + or else + Nkind (Declaration) = N_Subprogram_Renaming_Declaration + then + Specification := Corresponding_Spec (Declaration); + end if; + end if; + + -- A subprogram body or renaming-as-body is a remote call + -- interface if it serves as the completion of a subprogram + -- declaration that is a remote call interface. + + if Nkind (Specification) in N_Entity then + Set_Is_Remote_Call_Interface + (E, Is_Remote_Call_Interface (Specification)); + + -- A subprogram declaration is a remote call interface when it is + -- declared within the visible part of, or declared by, a library + -- unit declaration that is a remote call interface. + + else + Set_Is_Remote_Call_Interface + (E, Is_Remote_Call_Interface (Scop) + and then not (In_Private_Part (Scop) + or else In_Package_Body (Scop))); + end if; + end if; + + Set_Is_Remote_Types + (E, Is_Remote_Types (Scop) + and then not (In_Private_Part (Scop) + or else In_Package_Body (Scop))); + end Set_Categorization_From_Scope; + + ------------------------------ + -- Static_Discriminant_Expr -- + ------------------------------ + + -- We need to accommodate a Why_Not_Static call somehow here ??? + + function Static_Discriminant_Expr (L : List_Id) return Boolean is + Discriminant_Spec : Node_Id; + + begin + Discriminant_Spec := First (L); + while Present (Discriminant_Spec) loop + if Present (Expression (Discriminant_Spec)) + and then not Is_Static_Expression (Expression (Discriminant_Spec)) + then + return False; + end if; + + Next (Discriminant_Spec); + end loop; + + return True; + end Static_Discriminant_Expr; + + -------------------------------------- + -- Validate_Access_Type_Declaration -- + -------------------------------------- + + procedure Validate_Access_Type_Declaration (T : Entity_Id; N : Node_Id) is + Def : constant Node_Id := Type_Definition (N); + + begin + case Nkind (Def) is + + -- Access to subprogram case + + when N_Access_To_Subprogram_Definition => + + -- A pure library_item must not contain the declaration of a + -- named access type, except within a subprogram, generic + -- subprogram, task unit, or protected unit (RM 10.2.1(16)). + + -- This test is skipped in Ada 2005 (see AI-366) + + if Ada_Version < Ada_2005 + and then Comes_From_Source (T) + and then In_Pure_Unit + and then not In_Subprogram_Task_Protected_Unit + then + Error_Msg_N ("named access type not allowed in pure unit", T); + end if; + + -- Access to object case + + when N_Access_To_Object_Definition => + if Comes_From_Source (T) + and then In_Pure_Unit + and then not In_Subprogram_Task_Protected_Unit + then + -- We can't give the message yet, since the type is not frozen + -- and in Ada 2005 mode, access types are allowed in pure units + -- if the type has no storage pool (see AI-366). So we set a + -- flag which will be checked at freeze time. + + Set_Is_Pure_Unit_Access_Type (T); + end if; + + -- Check for RCI or RT unit type declaration: declaration of an + -- access-to-object type is illegal unless it is a general access + -- type that designates a class-wide limited private type. + -- Note that constraints on the primitive subprograms of the + -- designated tagged type are not enforced here but in + -- Validate_RACW_Primitives, which is done separately because the + -- designated type might not be frozen (and therefore its + -- primitive operations might not be completely known) at the + -- point of the RACW declaration. + + Validate_Remote_Access_Object_Type_Declaration (T); + + -- Check for shared passive unit type declaration. It should + -- not contain the declaration of access to class wide type, + -- access to task type and access to protected type with entry. + + Validate_SP_Access_Object_Type_Decl (T); + + when others => + null; + end case; + + -- Set categorization flag from package on entity as well, to allow + -- easy checks later on for required validations of RCI or RT units. + -- This is only done for entities that are in the original source. + + if Comes_From_Source (T) + and then not (In_Package_Body (Scope (T)) + or else In_Private_Part (Scope (T))) + then + Set_Is_Remote_Call_Interface + (T, Is_Remote_Call_Interface (Scope (T))); + Set_Is_Remote_Types + (T, Is_Remote_Types (Scope (T))); + end if; + end Validate_Access_Type_Declaration; + + ---------------------------- + -- Validate_Ancestor_Part -- + ---------------------------- + + procedure Validate_Ancestor_Part (N : Node_Id) is + A : constant Node_Id := Ancestor_Part (N); + T : constant Entity_Id := Entity (A); + + begin + if In_Preelaborated_Unit + and then not In_Subprogram_Or_Concurrent_Unit + and then (not Inside_A_Generic + or else Present (Enclosing_Generic_Body (N))) + then + -- If the type is private, it must have the Ada 2005 pragma + -- Has_Preelaborable_Initialization. + -- The check is omitted within predefined units. This is probably + -- obsolete code to fix the Ada95 weakness in this area ??? + + if Is_Private_Type (T) + and then not Has_Pragma_Preelab_Init (T) + and then not Is_Internal_File_Name + (Unit_File_Name (Get_Source_Unit (N))) + then + Error_Msg_N + ("private ancestor type not allowed in preelaborated unit", A); + + elsif Is_Record_Type (T) then + if Nkind (Parent (T)) = N_Full_Type_Declaration then + Check_Non_Static_Default_Expr + (Type_Definition (Parent (T)), A); + end if; + end if; + end if; + end Validate_Ancestor_Part; + + ---------------------------------------- + -- Validate_Categorization_Dependency -- + ---------------------------------------- + + procedure Validate_Categorization_Dependency + (N : Node_Id; + E : Entity_Id) + is + K : constant Node_Kind := Nkind (N); + P : Node_Id := Parent (N); + U : Entity_Id := E; + Is_Subunit : constant Boolean := Nkind (P) = N_Subunit; + + begin + -- Only validate library units and subunits. For subunits, checks + -- concerning withed units apply to the parent compilation unit. + + if Is_Subunit then + P := Parent (P); + U := Scope (E); + + while Present (U) + and then not Is_Compilation_Unit (U) + and then not Is_Child_Unit (U) + loop + U := Scope (U); + end loop; + end if; + + if Nkind (P) /= N_Compilation_Unit then + return; + end if; + + -- Body of RCI unit does not need validation + + if Is_Remote_Call_Interface (E) + and then (Nkind (N) = N_Package_Body + or else Nkind (N) = N_Subprogram_Body) + then + return; + end if; + + -- Ada 2005 (AI-50217): Process explicit non-limited with_clauses + + declare + Item : Node_Id; + Entity_Of_Withed : Entity_Id; + + begin + Item := First (Context_Items (P)); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then not (Implicit_With (Item) + or else Limited_Present (Item)) + then + Entity_Of_Withed := Entity (Name (Item)); + Check_Categorization_Dependencies + (U, Entity_Of_Withed, Item, Is_Subunit); + end if; + + Next (Item); + end loop; + end; + + -- Child depends on parent; therefore parent should also be categorized + -- and satisfy the dependency hierarchy. + + -- Check if N is a child spec + + if (K in N_Generic_Declaration or else + K in N_Generic_Instantiation or else + K in N_Generic_Renaming_Declaration or else + K = N_Package_Declaration or else + K = N_Package_Renaming_Declaration or else + K = N_Subprogram_Declaration or else + K = N_Subprogram_Renaming_Declaration) + and then Present (Parent_Spec (N)) + then + Check_Categorization_Dependencies (E, Scope (E), N, False); + + -- Verify that public child of an RCI library unit must also be an + -- RCI library unit (RM E.2.3(15)). + + if Is_Remote_Call_Interface (Scope (E)) + and then not Private_Present (P) + and then not Is_Remote_Call_Interface (E) + then + Error_Msg_N ("public child of rci unit must also be rci unit", N); + end if; + end if; + end Validate_Categorization_Dependency; + + -------------------------------- + -- Validate_Controlled_Object -- + -------------------------------- + + procedure Validate_Controlled_Object (E : Entity_Id) is + begin + -- Don't need this check in Ada 2005 mode, where this is all taken + -- care of by the mechanism for Preelaborable Initialization. + + if Ada_Version >= Ada_2005 then + return; + end if; + + -- For now, never apply this check for internal GNAT units, since we + -- have a number of cases in the library where we are stuck with objects + -- of this type, and the RM requires Preelaborate. + + -- For similar reasons, we only do this check for source entities, since + -- we generate entities of this type in some situations. + + -- Note that the 10.2.1(9) restrictions are not relevant to us anyway. + -- We have to enforce them for RM compatibility, but we have no trouble + -- accepting these objects and doing the right thing. Note that there is + -- no requirement that Preelaborate not actually generate any code! + + if In_Preelaborated_Unit + and then not Debug_Flag_PP + and then Comes_From_Source (E) + and then not + Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (E))) + and then (not Inside_A_Generic + or else Present (Enclosing_Generic_Body (E))) + and then not Is_Protected_Type (Etype (E)) + then + Error_Msg_N + ("library level controlled object not allowed in " & + "preelaborated unit", E); + end if; + end Validate_Controlled_Object; + + -------------------------------------- + -- Validate_Null_Statement_Sequence -- + -------------------------------------- + + procedure Validate_Null_Statement_Sequence (N : Node_Id) is + Item : Node_Id; + + begin + if In_Preelaborated_Unit then + Item := First (Statements (Handled_Statement_Sequence (N))); + while Present (Item) loop + if Nkind (Item) /= N_Label + and then Nkind (Item) /= N_Null_Statement + then + -- In GNAT mode, this is a warning, allowing the run-time + -- to judiciously bypass this error condition. + + Error_Msg_Warn := GNAT_Mode; + Error_Msg_N + ("= Ada_2005 then + Error_Msg_NE + ("\would be legal if pragma Preelaborable_" & + "Initialization given for & #", N, Ent); + else + Error_Msg_NE + ("\would be legal in Ada 2005 if pragma " & + "Preelaborable_Initialization given for & #", + N, Ent); + end if; + end if; + end if; + end if; + + -- Access to Task or Protected type + + elsif Is_Entity_Name (Odf) + and then Present (Etype (Odf)) + and then Is_Access_Type (Etype (Odf)) + then + Ent := Designated_Type (Etype (Odf)); + + elsif Is_Entity_Name (Odf) then + Ent := Entity (Odf); + + elsif Nkind (Odf) = N_Subtype_Indication then + Ent := Etype (Subtype_Mark (Odf)); + + elsif Nkind (Odf) = N_Constrained_Array_Definition then + Ent := Component_Type (T); + end if; + + if Is_Task_Type (Ent) + or else (Is_Protected_Type (Ent) and then Has_Entries (Ent)) + then + Error_Msg_N + ("concurrent object not allowed in preelaborated unit", + N); + return; + end if; + end; + end if; + + -- Non-static discriminants not allowed in preelaborated unit. + -- Objects of a controlled type with a user-defined Initialize + -- are forbidden as well. + + if Is_Record_Type (Etype (Id)) then + declare + ET : constant Entity_Id := Etype (Id); + EE : constant Entity_Id := Etype (Etype (Id)); + PEE : Node_Id; + + begin + if Has_Discriminants (ET) + and then Present (EE) + then + PEE := Parent (EE); + + if Nkind (PEE) = N_Full_Type_Declaration + and then not Static_Discriminant_Expr + (Discriminant_Specifications (PEE)) + then + Error_Msg_N + ("non-static discriminant in preelaborated unit", + PEE); + end if; + end if; + + if Has_Overriding_Initialize (ET) then + Error_Msg_NE + ("controlled type& does not have" + & " preelaborable initialization", N, ET); + end if; + end; + + end if; + end if; + + -- A pure library_item must not contain the declaration of any variable + -- except within a subprogram, generic subprogram, task unit, or + -- protected unit (RM 10.2.1(16)). + + if In_Pure_Unit and then not In_Subprogram_Task_Protected_Unit then + Error_Msg_N ("declaration of variable not allowed in pure unit", N); + + -- The visible part of an RCI library unit must not contain the + -- declaration of a variable (RM E.1.3(9)) + + elsif In_RCI_Declaration (N) then + Error_Msg_N ("visible variable not allowed in 'R'C'I unit", N); + + -- The visible part of a Shared Passive library unit must not contain + -- the declaration of a variable (RM E.2.2(7)) + + elsif In_RT_Declaration and then not In_Private_Part (Id) then + Error_Msg_N + ("visible variable not allowed in remote types unit", N); + end if; + + end Validate_Object_Declaration; + + ------------------------------ + -- Validate_RACW_Primitives -- + ------------------------------ + + procedure Validate_RACW_Primitives (T : Entity_Id) is + Desig_Type : Entity_Id; + Primitive_Subprograms : Elist_Id; + Subprogram_Elmt : Elmt_Id; + Subprogram : Entity_Id; + Param_Spec : Node_Id; + Param : Entity_Id; + Param_Type : Entity_Id; + Rtyp : Node_Id; + + procedure Illegal_RACW (Msg : String; N : Node_Id); + -- Diagnose that T is illegal because of the given reason, associated + -- with the location of node N. + + Illegal_RACW_Message_Issued : Boolean := False; + -- Set True once Illegal_RACW has been called + + ------------------ + -- Illegal_RACW -- + ------------------ + + procedure Illegal_RACW (Msg : String; N : Node_Id) is + begin + if not Illegal_RACW_Message_Issued then + Error_Msg_N + ("illegal remote access to class-wide type&", T); + Illegal_RACW_Message_Issued := True; + end if; + + Error_Msg_Sloc := Sloc (N); + Error_Msg_N ("\\" & Msg & " in primitive#", T); + end Illegal_RACW; + + -- Start of processing for Validate_RACW_Primitives + + begin + Desig_Type := Etype (Designated_Type (T)); + + -- No action needed for concurrent types + + if Is_Concurrent_Type (Desig_Type) then + return; + end if; + + Primitive_Subprograms := Primitive_Operations (Desig_Type); + + Subprogram_Elmt := First_Elmt (Primitive_Subprograms); + while Subprogram_Elmt /= No_Elmt loop + Subprogram := Node (Subprogram_Elmt); + + if Is_Predefined_Dispatching_Operation (Subprogram) + or else Is_Hidden (Subprogram) + then + goto Next_Subprogram; + end if; + + -- Check return type + + if Ekind (Subprogram) = E_Function then + Rtyp := Etype (Subprogram); + + if Has_Controlling_Result (Subprogram) then + null; + + elsif Ekind (Rtyp) = E_Anonymous_Access_Type then + Illegal_RACW ("anonymous access result", Rtyp); + + elsif Is_Limited_Type (Rtyp) then + if No (TSS (Rtyp, TSS_Stream_Read)) + or else + No (TSS (Rtyp, TSS_Stream_Write)) + then + Illegal_RACW + ("limited return type must have Read and Write attributes", + Parent (Subprogram)); + Explain_Limited_Type (Rtyp, Parent (Subprogram)); + + -- Check that the return type supports external streaming. + -- Note that the language of the standard (E.2.2(14)) does not + -- explicitly mention that case, but it really does not make + -- sense to return a value containing a local access type. + + elsif Missing_Read_Write_Attributes (Rtyp) + and then not Error_Posted (Rtyp) + then + Illegal_RACW ("return type containing non-remote access " + & "must have Read and Write attributes", + Parent (Subprogram)); + end if; + + end if; + end if; + + Param := First_Formal (Subprogram); + while Present (Param) loop + + -- Now find out if this parameter is a controlling parameter + + Param_Spec := Parent (Param); + Param_Type := Etype (Param); + + if Is_Controlling_Formal (Param) then + + -- It is a controlling parameter, so specific checks below + -- do not apply. + + null; + + elsif Ekind_In (Param_Type, E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) + then + -- From RM E.2.2(14), no anonymous access parameter other than + -- controlling ones may be used (because an anonymous access + -- type never supports external streaming). + + Illegal_RACW ("non-controlling access parameter", Param_Spec); + + elsif Is_Limited_Type (Param_Type) then + + -- Not a controlling parameter, so type must have Read and + -- Write attributes. + + if No (TSS (Param_Type, TSS_Stream_Read)) + or else + No (TSS (Param_Type, TSS_Stream_Write)) + then + Illegal_RACW + ("limited formal must have Read and Write attributes", + Param_Spec); + Explain_Limited_Type (Param_Type, Param_Spec); + end if; + + elsif Missing_Read_Write_Attributes (Param_Type) + and then not Error_Posted (Param_Type) + then + Illegal_RACW ("parameter containing non-remote access " + & "must have Read and Write attributes", Param_Spec); + end if; + + -- Check next parameter in this subprogram + + Next_Formal (Param); + end loop; + + <> + Next_Elmt (Subprogram_Elmt); + end loop; + end Validate_RACW_Primitives; + + ------------------------------- + -- Validate_RCI_Declarations -- + ------------------------------- + + procedure Validate_RCI_Declarations (P : Entity_Id) is + E : Entity_Id; + + begin + E := First_Entity (P); + while Present (E) loop + if Comes_From_Source (E) then + if Is_Limited_Type (E) then + Error_Msg_N + ("limited type not allowed in rci unit", Parent (E)); + Explain_Limited_Type (E, Parent (E)); + + elsif Ekind_In (E, E_Generic_Function, + E_Generic_Package, + E_Generic_Procedure) + then + Error_Msg_N ("generic declaration not allowed in rci unit", + Parent (E)); + + elsif (Ekind (E) = E_Function + or else Ekind (E) = E_Procedure) + and then Has_Pragma_Inline (E) + then + Error_Msg_N + ("inlined subprogram not allowed in rci unit", Parent (E)); + + -- Inner packages that are renamings need not be checked. Generic + -- RCI packages are subject to the checks, but entities that come + -- from formal packages are not part of the visible declarations + -- of the package and are not checked. + + elsif Ekind (E) = E_Package then + if Present (Renamed_Entity (E)) then + null; + + elsif Ekind (P) /= E_Generic_Package + or else List_Containing (Unit_Declaration_Node (E)) /= + Generic_Formal_Declarations + (Unit_Declaration_Node (P)) + then + Validate_RCI_Declarations (E); + end if; + end if; + end if; + + Next_Entity (E); + end loop; + end Validate_RCI_Declarations; + + ----------------------------------------- + -- Validate_RCI_Subprogram_Declaration -- + ----------------------------------------- + + procedure Validate_RCI_Subprogram_Declaration (N : Node_Id) is + K : constant Node_Kind := Nkind (N); + Profile : List_Id; + Id : Node_Id; + Param_Spec : Node_Id; + Param_Type : Entity_Id; + Base_Param_Type : Entity_Id; + Base_Under_Type : Entity_Id; + Type_Decl : Node_Id; + Error_Node : Node_Id := N; + + begin + -- This procedure enforces rules on subprogram and access to subprogram + -- declarations in RCI units. These rules do not apply to expander + -- generated routines, which are not remote subprograms. It is called: + + -- 1. from Analyze_Subprogram_Declaration. + -- 2. from Validate_Object_Declaration (access to subprogram). + + if not (Comes_From_Source (N) and then In_RCI_Declaration (N)) then + return; + end if; + + if K = N_Subprogram_Declaration then + Profile := Parameter_Specifications (Specification (N)); + + else pragma Assert (K = N_Object_Declaration); + + -- The above assertion is dubious, the visible declarations of an + -- RCI unit never contain an object declaration, this should be an + -- ACCESS-to-object declaration??? + + Id := Defining_Identifier (N); + + if Nkind (Id) = N_Defining_Identifier + and then Nkind (Parent (Etype (Id))) = N_Full_Type_Declaration + and then Ekind (Etype (Id)) = E_Access_Subprogram_Type + then + Profile := + Parameter_Specifications (Type_Definition (Parent (Etype (Id)))); + else + return; + end if; + end if; + + -- Iterate through the parameter specification list, checking that + -- no access parameter and no limited type parameter in the list. + -- RM E.2.3(14). + + if Present (Profile) then + Param_Spec := First (Profile); + while Present (Param_Spec) loop + Param_Type := Etype (Defining_Identifier (Param_Spec)); + Type_Decl := Parent (Param_Type); + + if Ekind (Param_Type) = E_Anonymous_Access_Type then + if K = N_Subprogram_Declaration then + Error_Node := Param_Spec; + end if; + + -- Report error only if declaration is in source program + + if Comes_From_Source + (Defining_Entity (Specification (N))) + then + Error_Msg_N + ("subprogram in 'R'C'I unit cannot have access parameter", + Error_Node); + end if; + + -- For a limited private type parameter, we check only the private + -- declaration and ignore full type declaration, unless this is + -- the only declaration for the type, e.g., as a limited record. + + elsif Is_Limited_Type (Param_Type) + and then (Nkind (Type_Decl) = N_Private_Type_Declaration + or else + (Nkind (Type_Decl) = N_Full_Type_Declaration + and then not (Has_Private_Declaration (Param_Type)) + and then Comes_From_Source (N))) + then + -- A limited parameter is legal only if user-specified Read and + -- Write attributes exist for it. Second part of RM E.2.3 (14). + + if No (Full_View (Param_Type)) + and then Ekind (Param_Type) /= E_Record_Type + then + -- Type does not have completion yet, so if declared in + -- the current RCI scope it is illegal, and will be flagged + -- subsequently. + + return; + end if; + + -- In Ada 95 the rules permit using a limited type that has + -- user-specified Read and Write attributes that are specified + -- in the private part of the package, whereas Ada 2005 + -- (AI-240) revises this to require the attributes to be + -- "available" (implying that the attribute clauses must be + -- visible to the RCI client). The Ada 95 rules violate the + -- contract model for privacy, but we support both semantics + -- for now for compatibility (note that ACATS test BXE2009 + -- checks a case that conforms to the Ada 95 rules but is + -- illegal in Ada 2005). In the Ada 2005 case we check for the + -- possibilities of visible TSS stream subprograms or explicit + -- stream attribute definitions because the TSS subprograms + -- can be hidden in the private part while the attribute + -- definitions are still be available from the visible part. + + Base_Param_Type := Base_Type (Param_Type); + Base_Under_Type := Base_Type (Underlying_Type + (Base_Param_Type)); + + if (Ada_Version < Ada_2005 + and then + (No (TSS (Base_Param_Type, TSS_Stream_Read)) + or else + No (TSS (Base_Param_Type, TSS_Stream_Write))) + and then + (No (TSS (Base_Under_Type, TSS_Stream_Read)) + or else + No (TSS (Base_Under_Type, TSS_Stream_Write)))) + or else + (Ada_Version >= Ada_2005 + and then + (No (TSS (Base_Param_Type, TSS_Stream_Read)) + or else + No (TSS (Base_Param_Type, TSS_Stream_Write)) + or else + Is_Hidden (TSS (Base_Param_Type, TSS_Stream_Read)) + or else + Is_Hidden (TSS (Base_Param_Type, TSS_Stream_Write))) + and then + (not Has_Stream_Attribute_Definition + (Base_Param_Type, TSS_Stream_Read) + or else + not Has_Stream_Attribute_Definition + (Base_Param_Type, TSS_Stream_Write))) + then + if K = N_Subprogram_Declaration then + Error_Node := Param_Spec; + end if; + + if Ada_Version >= Ada_2005 then + Error_Msg_N + ("limited parameter in 'R'C'I unit " + & "must have visible read/write attributes ", + Error_Node); + else + Error_Msg_N + ("limited parameter in 'R'C'I unit " + & "must have read/write attributes ", + Error_Node); + end if; + Explain_Limited_Type (Param_Type, Error_Node); + end if; + + -- In Ada 95, any non-remote access type (or any type with a + -- component of a non-remote access type) that is visible in an + -- RCI unit comes from a Remote_Types or Remote_Call_Interface + -- unit, and thus is already guaranteed to support external + -- streaming. However in Ada 2005 we have to account for the case + -- of named access types from declared pure units as well, which + -- may or may not support external streaming, and so we need to + -- perform a specific check for E.2.3(14/2) here. + + -- Note that if the declaration of the type itself is illegal, we + -- do not perform this check since it might be a cascaded error. + + else + if K = N_Subprogram_Declaration then + Error_Node := Param_Spec; + end if; + + if Missing_Read_Write_Attributes (Param_Type) + and then not Error_Posted (Param_Type) + then + Error_Msg_N + ("parameter containing non-remote access in 'R'C'I " + & "subprogram must have visible " + & "Read and Write attributes", Error_Node); + end if; + end if; + Next (Param_Spec); + end loop; + + -- No check on return type??? + end if; + end Validate_RCI_Subprogram_Declaration; + + ---------------------------------------------------- + -- Validate_Remote_Access_Object_Type_Declaration -- + ---------------------------------------------------- + + procedure Validate_Remote_Access_Object_Type_Declaration (T : Entity_Id) is + + function Is_Valid_Remote_Object_Type (E : Entity_Id) return Boolean; + -- True if tagged type E is a valid candidate as the root type of the + -- designated type for a RACW, i.e. a tagged limited private type, or a + -- limited interface type, or a private extension of such a type. + + --------------------------------- + -- Is_Valid_Remote_Object_Type -- + --------------------------------- + + function Is_Valid_Remote_Object_Type (E : Entity_Id) return Boolean is + P : constant Node_Id := Parent (E); + + begin + pragma Assert (Is_Tagged_Type (E)); + + -- Simple case: a limited private type + + if Nkind (P) = N_Private_Type_Declaration + and then Is_Limited_Record (E) + then + return True; + + -- A limited interface is not currently a legal ancestor for the + -- designated type of an RACW type, because a type that implements + -- such an interface need not be limited. However, the ARG seems to + -- incline towards allowing an access to classwide limited interface + -- type as a remote access type, as resolved in AI05-060. But note + -- that the expansion circuitry for RACWs that designate classwide + -- interfaces is not complete yet. + + elsif Is_Limited_Record (E) and then Is_Limited_Interface (E) then + return True; + + -- A generic tagged limited type is a valid candidate. Limitedness + -- will be checked again on the actual at instantiation point. + + elsif Nkind (P) = N_Formal_Type_Declaration + and then Ekind (E) = E_Record_Type_With_Private + and then Is_Generic_Type (E) + and then Is_Limited_Record (E) + then + return True; + + -- A private extension declaration is a valid candidate if its parent + -- type is. + + elsif Nkind (P) = N_Private_Extension_Declaration then + return Is_Valid_Remote_Object_Type (Etype (E)); + + else + return False; + end if; + end Is_Valid_Remote_Object_Type; + + -- Local variables + + Direct_Designated_Type : Entity_Id; + Desig_Type : Entity_Id; + + -- Start of processing for Validate_Remote_Access_Object_Type_Declaration + + begin + -- We are called from Analyze_Full_Type_Declaration, and the Nkind of + -- the given node is N_Access_To_Object_Definition. + + if not Comes_From_Source (T) + or else (not In_RCI_Declaration (Parent (T)) + and then not In_RT_Declaration) + then + return; + end if; + + -- An access definition in the private part of a Remote Types package + -- may be legal if it has user-defined Read and Write attributes. This + -- will be checked at the end of the package spec processing. + + if In_RT_Declaration and then In_Private_Part (Scope (T)) then + return; + end if; + + -- Check RCI or RT unit type declaration. It may not contain the + -- declaration of an access-to-object type unless it is a general access + -- type that designates a class-wide limited private type or subtype. + -- There are also constraints on the primitive subprograms of the + -- class-wide type (RM E.2.2(14), see Validate_RACW_Primitives). + + if Ekind (T) /= E_General_Access_Type + or else not Is_Class_Wide_Type (Designated_Type (T)) + then + if In_RCI_Declaration (Parent (T)) then + Error_Msg_N + ("error in access type in Remote_Call_Interface unit", T); + else + Error_Msg_N + ("error in access type in Remote_Types unit", T); + end if; + + Error_Msg_N ("\must be general access to class-wide type", T); + return; + end if; + + Direct_Designated_Type := Designated_Type (T); + Desig_Type := Etype (Direct_Designated_Type); + + -- Why is the check below not in + -- Validate_Remote_Access_To_Class_Wide_Type??? + + if not Is_Valid_Remote_Object_Type (Desig_Type) then + Error_Msg_N + ("error in designated type of remote access to class-wide type", T); + Error_Msg_N + ("\must be tagged limited private or private extension", T); + return; + end if; + end Validate_Remote_Access_Object_Type_Declaration; + + ----------------------------------------------- + -- Validate_Remote_Access_To_Class_Wide_Type -- + ----------------------------------------------- + + procedure Validate_Remote_Access_To_Class_Wide_Type (N : Node_Id) is + K : constant Node_Kind := Nkind (N); + PK : constant Node_Kind := Nkind (Parent (N)); + E : Entity_Id; + + begin + -- This subprogram enforces the checks in (RM E.2.2(8)) for certain uses + -- of class-wide limited private types. + + -- Storage_Pool and Storage_Size are not defined for such types + -- + -- The expected type of allocator must not be such a type. + + -- The actual parameter of generic instantiation must not be such a + -- type if the formal parameter is of an access type. + + -- On entry, there are five cases + + -- 1. called from sem_attr Analyze_Attribute where attribute name is + -- either Storage_Pool or Storage_Size. + + -- 2. called from exp_ch4 Expand_N_Allocator + + -- 3. called from sem_ch12 Analyze_Associations + + -- 4. called from sem_ch4 Analyze_Explicit_Dereference + + -- 5. called from sem_res Resolve_Actuals + + if K = N_Attribute_Reference then + E := Etype (Prefix (N)); + + if Is_Remote_Access_To_Class_Wide_Type (E) then + Error_Msg_N ("incorrect attribute of remote operand", N); + return; + end if; + + elsif K = N_Allocator then + E := Etype (N); + + if Is_Remote_Access_To_Class_Wide_Type (E) then + Error_Msg_N ("incorrect expected remote type of allocator", N); + return; + end if; + + elsif K in N_Has_Entity then + E := Entity (N); + + if Is_Remote_Access_To_Class_Wide_Type (E) then + Error_Msg_N ("incorrect remote type generic actual", N); + return; + end if; + + -- This subprogram also enforces the checks in E.2.2(13). A value of + -- such type must not be dereferenced unless as controlling operand of + -- a dispatching call. Explicit dereferences not coming from source are + -- exempted from this checking because the expander produces them in + -- some cases (such as for tag checks on dispatching calls with multiple + -- controlling operands). However we do check in the case of an implicit + -- dereference that is expanded to an explicit dereference (hence the + -- test of whether Original_Node (N) comes from source). + + elsif K = N_Explicit_Dereference + and then Comes_From_Source (Original_Node (N)) + then + E := Etype (Prefix (N)); + + -- If the class-wide type is not a remote one, the restrictions + -- do not apply. + + if not Is_Remote_Access_To_Class_Wide_Type (E) then + return; + end if; + + -- If we have a true dereference that comes from source and that + -- is a controlling argument for a dispatching call, accept it. + + if Is_Actual_Parameter (N) + and then Is_Controlling_Actual (N) + then + return; + end if; + + -- If we are just within a procedure or function call and the + -- dereference has not been analyzed, return because this procedure + -- will be called again from sem_res Resolve_Actuals. The same can + -- apply in the case of dereference that is the prefix of a selected + -- component, which can be a call given in prefixed form. + + if (Is_Actual_Parameter (N) + or else PK = N_Selected_Component) + and then not Analyzed (N) + then + return; + end if; + + -- We must allow expanded code to generate a reference to the tag of + -- the designated object (may be either the actual tag, or the stub + -- tag in the case of a remote object). + + if PK = N_Selected_Component + and then Is_Tag (Entity (Selector_Name (Parent (N)))) + then + return; + end if; + + Error_Msg_N + ("invalid dereference of a remote access-to-class-wide value", N); + end if; + end Validate_Remote_Access_To_Class_Wide_Type; + + ------------------------------------------ + -- Validate_Remote_Type_Type_Conversion -- + ------------------------------------------ + + procedure Validate_Remote_Type_Type_Conversion (N : Node_Id) is + S : constant Entity_Id := Etype (N); + E : constant Entity_Id := Etype (Expression (N)); + + begin + -- This test is required in the case where a conversion appears inside a + -- normal package, it does not necessarily have to be inside an RCI, + -- Remote_Types unit (RM E.2.2(9,12)). + + if Is_Remote_Access_To_Subprogram_Type (E) + and then not Is_Remote_Access_To_Subprogram_Type (S) + then + Error_Msg_N + ("incorrect conversion of remote operand to local type", N); + return; + + elsif not Is_Remote_Access_To_Subprogram_Type (E) + and then Is_Remote_Access_To_Subprogram_Type (S) + then + Error_Msg_N + ("incorrect conversion of local operand to remote type", N); + return; + + elsif Is_Remote_Access_To_Class_Wide_Type (E) + and then not Is_Remote_Access_To_Class_Wide_Type (S) + then + Error_Msg_N + ("incorrect conversion of remote operand to local type", N); + return; + end if; + + -- If a local access type is converted into a RACW type, then the + -- current unit has a pointer that may now be exported to another + -- partition. + + if Is_Remote_Access_To_Class_Wide_Type (S) + and then not Is_Remote_Access_To_Class_Wide_Type (E) + then + Set_Has_RACW (Current_Sem_Unit); + end if; + end Validate_Remote_Type_Type_Conversion; + + ------------------------------- + -- Validate_RT_RAT_Component -- + ------------------------------- + + procedure Validate_RT_RAT_Component (N : Node_Id) is + Spec : constant Node_Id := Specification (N); + Name_U : constant Entity_Id := Defining_Entity (Spec); + Typ : Entity_Id; + U_Typ : Entity_Id; + First_Priv_Ent : constant Entity_Id := First_Private_Entity (Name_U); + + begin + if not Is_Remote_Types (Name_U) then + return; + end if; + + Typ := First_Entity (Name_U); + while Present (Typ) and then Typ /= First_Priv_Ent loop + U_Typ := Underlying_Type (Typ); + + if No (U_Typ) then + U_Typ := Typ; + end if; + + if Comes_From_Source (Typ) and then Is_Type (Typ) then + if Missing_Read_Write_Attributes (Typ) then + if Is_Non_Remote_Access_Type (Typ) then + Error_Msg_N ("error in non-remote access type", U_Typ); + else + Error_Msg_N + ("error in record type containing a component of a " & + "non-remote access type", U_Typ); + end if; + + if Ada_Version >= Ada_2005 then + Error_Msg_N + ("\must have visible Read and Write attribute " & + "definition clauses (RM E.2.2(8))", U_Typ); + else + Error_Msg_N + ("\must have Read and Write attribute " & + "definition clauses (RM E.2.2(8))", U_Typ); + end if; + end if; + end if; + + Next_Entity (Typ); + end loop; + end Validate_RT_RAT_Component; + + ----------------------------------------- + -- Validate_SP_Access_Object_Type_Decl -- + ----------------------------------------- + + procedure Validate_SP_Access_Object_Type_Decl (T : Entity_Id) is + Direct_Designated_Type : Entity_Id; + + function Has_Entry_Declarations (E : Entity_Id) return Boolean; + -- Return true if the protected type designated by T has + -- entry declarations. + + ---------------------------- + -- Has_Entry_Declarations -- + ---------------------------- + + function Has_Entry_Declarations (E : Entity_Id) return Boolean is + Ety : Entity_Id; + + begin + if Nkind (Parent (E)) = N_Protected_Type_Declaration then + Ety := First_Entity (E); + while Present (Ety) loop + if Ekind (Ety) = E_Entry then + return True; + end if; + + Next_Entity (Ety); + end loop; + end if; + + return False; + end Has_Entry_Declarations; + + -- Start of processing for Validate_SP_Access_Object_Type_Decl + + begin + -- We are called from Sem_Ch3.Analyze_Full_Type_Declaration, and the + -- Nkind of the given entity is N_Access_To_Object_Definition. + + if not Comes_From_Source (T) + or else not In_Shared_Passive_Unit + or else In_Subprogram_Task_Protected_Unit + then + return; + end if; + + -- Check Shared Passive unit. It should not contain the declaration + -- of an access-to-object type whose designated type is a class-wide + -- type, task type or protected type with entry (RM E.2.1(7)). + + Direct_Designated_Type := Designated_Type (T); + + if Ekind (Direct_Designated_Type) = E_Class_Wide_Type then + Error_Msg_N + ("invalid access-to-class-wide type in shared passive unit", T); + return; + + elsif Ekind (Direct_Designated_Type) in Task_Kind then + Error_Msg_N + ("invalid access-to-task type in shared passive unit", T); + return; + + elsif Ekind (Direct_Designated_Type) in Protected_Kind + and then Has_Entry_Declarations (Direct_Designated_Type) + then + Error_Msg_N + ("invalid access-to-protected type in shared passive unit", T); + return; + end if; + end Validate_SP_Access_Object_Type_Decl; + + --------------------------------- + -- Validate_Static_Object_Name -- + --------------------------------- + + procedure Validate_Static_Object_Name (N : Node_Id) is + E : Entity_Id; + + function Is_Primary (N : Node_Id) return Boolean; + -- Determine whether node is syntactically a primary in an expression + -- This function should probably be somewhere else ??? + -- Also it does not do what it says, e.g if N is a binary operator + -- whose parent is a binary operator, Is_Primary returns True ??? + + ---------------- + -- Is_Primary -- + ---------------- + + function Is_Primary (N : Node_Id) return Boolean is + K : constant Node_Kind := Nkind (Parent (N)); + + begin + case K is + when N_Op | N_Membership_Test => + return True; + + when N_Aggregate + | N_Component_Association + | N_Index_Or_Discriminant_Constraint => + return True; + + when N_Attribute_Reference => + return Attribute_Name (Parent (N)) /= Name_Address + and then Attribute_Name (Parent (N)) /= Name_Access + and then Attribute_Name (Parent (N)) /= Name_Unchecked_Access + and then + Attribute_Name (Parent (N)) /= Name_Unrestricted_Access; + + when N_Indexed_Component => + return (N /= Prefix (Parent (N)) + or else Is_Primary (Parent (N))); + + when N_Qualified_Expression | N_Type_Conversion => + return Is_Primary (Parent (N)); + + when N_Assignment_Statement | N_Object_Declaration => + return (N = Expression (Parent (N))); + + when N_Selected_Component => + return Is_Primary (Parent (N)); + + when others => + return False; + end case; + end Is_Primary; + + -- Start of processing for Validate_Static_Object_Name + + begin + if not In_Preelaborated_Unit + or else not Comes_From_Source (N) + or else In_Subprogram_Or_Concurrent_Unit + or else Ekind (Current_Scope) = E_Block + then + return; + + -- Filter out cases where primary is default in a component declaration, + -- discriminant specification, or actual in a record type initialization + -- call. + + -- Initialization call of internal types + + elsif Nkind (Parent (N)) = N_Procedure_Call_Statement then + + if Present (Parent (Parent (N))) + and then Nkind (Parent (Parent (N))) = N_Freeze_Entity + then + return; + end if; + + if Nkind (Name (Parent (N))) = N_Identifier + and then not Comes_From_Source (Entity (Name (Parent (N)))) + then + return; + end if; + end if; + + -- Error if the name is a primary in an expression. The parent must not + -- be an operator, or a selected component or an indexed component that + -- is itself a primary. Entities that are actuals do not need to be + -- checked, because the call itself will be diagnosed. + + if Is_Primary (N) + and then (not Inside_A_Generic + or else Present (Enclosing_Generic_Body (N))) + then + if Ekind (Entity (N)) = E_Variable + or else Ekind (Entity (N)) in Formal_Object_Kind + then + Flag_Non_Static_Expr + ("non-static object name in preelaborated unit", N); + + -- Give an error for a reference to a nonstatic constant, unless the + -- constant is in another GNAT library unit that is preelaborable. + + elsif Ekind (Entity (N)) = E_Constant + and then not Is_Static_Expression (N) + then + E := Entity (N); + + if Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N))) + and then + Enclosing_Lib_Unit_Node (N) /= Enclosing_Lib_Unit_Node (E) + and then (Is_Preelaborated (Scope (E)) + or else Is_Pure (Scope (E)) + or else (Present (Renamed_Object (E)) + and then + Is_Entity_Name (Renamed_Object (E)) + and then + (Is_Preelaborated + (Scope (Renamed_Object (E))) + or else + Is_Pure (Scope + (Renamed_Object (E)))))) + then + null; + + -- This is the error case + + else + -- In GNAT mode, this is just a warning, to allow it to be + -- judiciously turned off. Otherwise it is a real error. + + if GNAT_Mode then + Error_Msg_N + ("?non-static constant in preelaborated unit", N); + else + Flag_Non_Static_Expr + ("non-static constant in preelaborated unit", N); + end if; + end if; + end if; + end if; + end Validate_Static_Object_Name; + +end Sem_Cat; diff --git a/gcc/ada/sem_cat.ads b/gcc/ada/sem_cat.ads new file mode 100644 index 000000000..1c7f5722e --- /dev/null +++ b/gcc/ada/sem_cat.ads @@ -0,0 +1,159 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C A T -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit contains the routines used for checking for conformance with +-- the semantic restrictions required for the categorization pragmas: +-- +-- Preelaborate +-- Pure, +-- Remote_Call_Interface +-- Remote_Types +-- Shared_Passive +-- +-- Note that we treat Preelaborate as a categorization pragma, even though +-- strictly, according to RM E.2(2,3), the term does not apply in this case. + +with Exp_Tss; use Exp_Tss; +with Types; use Types; + +package Sem_Cat is + + function Has_Stream_Attribute_Definition + (Typ : Entity_Id; + Nam : TSS_Name_Type; + At_Any_Place : Boolean := False) return Boolean; + -- True when there is a attribute definition clause specifying attribute + -- Nam for Typ. In Ada 2005 mode, returns True only when the attribute + -- definition clause is visible, unless At_Any_Place is True (in which case + -- no visibility test is made, and True is returned as long as an attribute + -- is visible at any place). Note that attribute definition clauses + -- inherited from parent types are taken into account by this predicate + -- (to test for presence of an attribute definition clause for one + -- specific type, excluding inherited definitions, the flags + -- Has_Specified_Stream_* can be used instead). + + function In_Preelaborated_Unit return Boolean; + -- Determines if the current scope is within a preelaborated compilation + -- unit, that is one to which one of the pragmas Preelaborate, Pure, + -- Shared_Passive, Remote_Types, or inside a unit other than a package + -- body with pragma Remote_Call_Interface. + + function In_Pure_Unit return Boolean; + pragma Inline (In_Pure_Unit); + -- Determines if the current scope is within pure compilation unit, + -- that is, one to which the pragmas Pure is applied. + + function In_Subprogram_Task_Protected_Unit return Boolean; + -- Determines if the current scope is within a subprogram, task + -- or protected unit. Used to validate if the library unit is Pure + -- (RM 10.2.1(16)). + + procedure Set_Categorization_From_Pragmas (N : Node_Id); + -- Since validation of categorization dependency is done during Analyze, + -- categorization flags from following pragmas should be set before + -- validation begin. N is the N_Compilation_Unit node. + + procedure Set_Categorization_From_Scope (E : Entity_Id; Scop : Entity_Id); + -- Set categorization flags Pure, Remote_Call_Interface and Remote_Types + -- on entity E according to those of Scop. + + procedure Validate_Access_Type_Declaration (T : Entity_Id; N : Node_Id); + -- Validate all constraints against declaration of access types in + -- categorized library units. Usually this is a violation in Pure unit, + -- Shared_Passive unit. N is the declaration node. + + procedure Validate_Ancestor_Part (N : Node_Id); + -- Checks that a type given as the ancestor in an extension aggregate + -- satisfies the restriction of 10.2.1(9). + + procedure Validate_Categorization_Dependency (N : Node_Id; E : Entity_Id); + -- There are restrictions on lib unit that semantically depends on other + -- units (RM E.2(5), 10.2.1(11). This procedure checks the restrictions + -- on categorizations. N is the current unit node, and E is the current + -- library unit entity. + + procedure Validate_Controlled_Object (E : Entity_Id); + -- Given an entity for a library level controlled object, check that it is + -- not in a preelaborated unit (prohibited by RM 10.2.1(9)). + + procedure Validate_Null_Statement_Sequence (N : Node_Id); + -- Given N, a package body node, check that a handled statement sequence + -- in a preelaborable body contains no statements other than labels or + -- null statements, as required by RM 10.2.1(6). + + procedure Validate_Object_Declaration (N : Node_Id); + -- Given N, an object declaration node, validates all the constraints in + -- a preelaborable library unit, including creation of task objects etc. + -- Note that this is called when the corresponding object is frozen since + -- the checks cannot be made before knowing if the object is imported. + + procedure Validate_RCI_Declarations (P : Entity_Id); + -- Apply semantic checks given in E2.3(10-14) + + procedure Validate_RCI_Subprogram_Declaration (N : Node_Id); + -- Check RCI subprogram declarations for illegal inlining and formals not + -- supporting external streaming. + + procedure Validate_Remote_Access_To_Class_Wide_Type (N : Node_Id); + -- Checks that Storage_Pool and Storage_Size attribute references are + -- not applied to remote access-to-class-wide types. And the expected + -- type for an allocator shall not be a remote access-to-class-wide + -- type. And a remote access-to-class-wide type shall not be an actual + -- parameter for a generic formal access type. RM E.2.3(22). + + procedure Validate_RT_RAT_Component (N : Node_Id); + -- Given N, the package library unit declaration node, we should check + -- against RM:9.95 E.2.2(8): the full view of a type declared in the + -- visible part of a Remote Types unit has a part that is of a non-remote + -- access type which has no read/write. + + procedure Validate_Remote_Type_Type_Conversion (N : Node_Id); + -- Check for remote-type type conversion constraints. First, a value of + -- a remote access-to-subprogram type can be converted only to another + -- type conformant remote access-to-subprogram type. Secondly, a value + -- of a remote access-to-class-wide type can be converted only to another + -- remote access-to-class-wide type (RM E.2.3(17,20)). + + procedure Validate_SP_Access_Object_Type_Decl (T : Entity_Id); + -- Check validity of declaration if shared passive unit. It should not + -- contain the declaration of an access-to-object type whose designated + -- type is a class-wide type ,task type or protected type. E.2.1(7). + -- T is the entity of the declared type. + + procedure Validate_Static_Object_Name (N : Node_Id); + -- In the elaboration code of a preelaborated library unit, check that we + -- do not have the evaluation of a primary that is a name of an object, + -- unless the name is a static expression (RM 10.2.1(8)). Non-static + -- constant and variable are the targets, generic parameters are not + -- are not included because the generic declaration and body are + -- preelaborable. + + procedure Validate_RACW_Primitives (T : Entity_Id); + -- Enforce constraints on primitive operations of the designated type of + -- an RACW. Note that since the complete set of primitive operations of the + -- designated type needs to be known, we must defer these checks until the + -- designated type is frozen. + +end Sem_Cat; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb new file mode 100644 index 000000000..6c4e2442d --- /dev/null +++ b/gcc/ada/sem_ch10.adb @@ -0,0 +1,6163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 1 0 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Debug; use Debug; +with Einfo; use Einfo; +with Errout; use Errout; +with Exp_Util; use Exp_Util; +with Elists; use Elists; +with Fname; use Fname; +with Fname.UF; use Fname.UF; +with Freeze; use Freeze; +with Impunit; use Impunit; +with Inline; use Inline; +with Lib; use Lib; +with Lib.Load; use Lib.Load; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Output; use Output; +with Par_SCO; use Par_SCO; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch7; use Sem_Ch7; +with Sem_Ch8; use Sem_Ch8; +with Sem_Dist; use Sem_Dist; +with Sem_Prag; use Sem_Prag; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Sinfo.CN; use Sinfo.CN; +with Sinput; use Sinput; +with Snames; use Snames; +with Style; use Style; +with Stylesw; use Stylesw; +with Tbuild; use Tbuild; +with Uname; use Uname; + +package body Sem_Ch10 is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Analyze_Context (N : Node_Id); + -- Analyzes items in the context clause of compilation unit + + procedure Build_Limited_Views (N : Node_Id); + -- Build and decorate the list of shadow entities for a package mentioned + -- in a limited_with clause. If the package was not previously analyzed + -- then it also performs a basic decoration of the real entities. This is + -- required to do not pass non-decorated entities to the back-end. + -- Implements Ada 2005 (AI-50217). + + procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id); + -- Check whether the source for the body of a compilation unit must be + -- included in a standalone library. + + procedure Check_Private_Child_Unit (N : Node_Id); + -- If a with_clause mentions a private child unit, the compilation unit + -- must be a member of the same family, as described in 10.1.2. + + procedure Check_Stub_Level (N : Node_Id); + -- Verify that a stub is declared immediately within a compilation unit, + -- and not in an inner frame. + + procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id); + -- When a child unit appears in a context clause, the implicit withs on + -- parents are made explicit, and with clauses are inserted in the context + -- clause before the one for the child. If a parent in the with_clause + -- is a renaming, the implicit with_clause is on the renaming whose name + -- is mentioned in the with_clause, and not on the package it renames. + -- N is the compilation unit whose list of context items receives the + -- implicit with_clauses. + + function Get_Parent_Entity (Unit : Node_Id) return Entity_Id; + -- Get defining entity of parent unit of a child unit. In most cases this + -- is the defining entity of the unit, but for a child instance whose + -- parent needs a body for inlining, the instantiation node of the parent + -- has not yet been rewritten as a package declaration, and the entity has + -- to be retrieved from the Instance_Spec of the unit. + + function Has_With_Clause + (C_Unit : Node_Id; + Pack : Entity_Id; + Is_Limited : Boolean := False) return Boolean; + -- Determine whether compilation unit C_Unit contains a [limited] with + -- clause for package Pack. Use the flag Is_Limited to designate desired + -- clause kind. + + procedure Implicit_With_On_Parent (Child_Unit : Node_Id; N : Node_Id); + -- If the main unit is a child unit, implicit withs are also added for + -- all its ancestors. + + function In_Chain (E : Entity_Id) return Boolean; + -- Check that the shadow entity is not already in the homonym chain, for + -- example through a limited_with clause in a parent unit. + + procedure Install_Context_Clauses (N : Node_Id); + -- Subsidiary to Install_Context and Install_Parents. Process all with + -- and use clauses for current unit and its library unit if any. + + procedure Install_Limited_Context_Clauses (N : Node_Id); + -- Subsidiary to Install_Context. Process only limited with_clauses for + -- current unit. Implements Ada 2005 (AI-50217). + + procedure Install_Limited_Withed_Unit (N : Node_Id); + -- Place shadow entities for a limited_with package in the visibility + -- structures for the current compilation. Implements Ada 2005 (AI-50217). + + procedure Install_Withed_Unit + (With_Clause : Node_Id; + Private_With_OK : Boolean := False); + -- If the unit is not a child unit, make unit immediately visible. The + -- caller ensures that the unit is not already currently installed. The + -- flag Private_With_OK is set true in Install_Private_With_Clauses, which + -- is called when compiling the private part of a package, or installing + -- the private declarations of a parent unit. + + procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean); + -- This procedure establishes the context for the compilation of a child + -- unit. If Lib_Unit is a child library spec then the context of the parent + -- is installed, and the parent itself made immediately visible, so that + -- the child unit is processed in the declarative region of the parent. + -- Install_Parents makes a recursive call to itself to ensure that all + -- parents are loaded in the nested case. If Lib_Unit is a library body, + -- the only effect of Install_Parents is to install the private decls of + -- the parents, because the visible parent declarations will have been + -- installed as part of the context of the corresponding spec. + + procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id); + -- In the compilation of a child unit, a child of any of the ancestor + -- units is directly visible if it is visible, because the parent is in + -- an enclosing scope. Iterate over context to find child units of U_Name + -- or of some ancestor of it. + + function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean; + -- Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec + -- returns True if Lib_Unit is a library spec which is a child spec, i.e. + -- a library spec that has a parent. If the call to Is_Child_Spec returns + -- True, then Parent_Spec (Lib_Unit) is non-Empty and points to the + -- compilation unit for the parent spec. + -- + -- Lib_Unit can also be a subprogram body that acts as its own spec. If the + -- Parent_Spec is non-empty, this is also a child unit. + + procedure Remove_Context_Clauses (N : Node_Id); + -- Subsidiary of previous one. Remove use_ and with_clauses + + procedure Remove_Limited_With_Clause (N : Node_Id); + -- Remove from visibility the shadow entities introduced for a package + -- mentioned in a limited_with clause. Implements Ada 2005 (AI-50217). + + procedure Remove_Parents (Lib_Unit : Node_Id); + -- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent + -- contexts established by the corresponding call to Install_Parents are + -- removed. Remove_Parents contains a recursive call to itself to ensure + -- that all parents are removed in the nested case. + + procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id); + -- Reset all visibility flags on unit after compiling it, either as a main + -- unit or as a unit in the context. + + procedure Unchain (E : Entity_Id); + -- Remove single entity from visibility list + + procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id); + -- Common processing for all stubs (subprograms, tasks, packages, and + -- protected cases). N is the stub to be analyzed. Once the subunit name + -- is established, load and analyze. Nam is the non-overloadable entity + -- for which the proper body provides a completion. Subprogram stubs are + -- handled differently because they can be declarations. + + procedure sm; + -- A dummy procedure, for debugging use, called just before analyzing the + -- main unit (after dealing with any context clauses). + + -------------------------- + -- Limited_With_Clauses -- + -------------------------- + + -- Limited_With clauses are the mechanism chosen for Ada05 to support + -- mutually recursive types declared in different units. A limited_with + -- clause that names package P in the context of unit U makes the types + -- declared in the visible part of P available within U, but with the + -- restriction that these types can only be used as incomplete types. + -- The limited_with clause does not impose a semantic dependence on P, + -- and it is possible for two packages to have limited_with_clauses on + -- each other without creating an elaboration circularity. + + -- To support this feature, the analysis of a limited_with clause must + -- create an abbreviated view of the package, without performing any + -- semantic analysis on it. This "package abstract" contains shadow types + -- that are in one-one correspondence with the real types in the package, + -- and that have the properties of incomplete types. + + -- The implementation creates two element lists: one to chain the shadow + -- entities, and one to chain the corresponding type entities in the tree + -- of the package. Links between corresponding entities in both chains + -- allow the compiler to select the proper view of a given type, depending + -- on the context. Note that in contrast with the handling of private + -- types, the limited view and the non-limited view of a type are treated + -- as separate entities, and no entity exchange needs to take place, which + -- makes the implementation must simpler than could be feared. + + ------------------------------ + -- Analyze_Compilation_Unit -- + ------------------------------ + + procedure Analyze_Compilation_Unit (N : Node_Id) is + Unit_Node : constant Node_Id := Unit (N); + Lib_Unit : Node_Id := Library_Unit (N); + Spec_Id : Entity_Id; + Main_Cunit : constant Node_Id := Cunit (Main_Unit); + Par_Spec_Name : Unit_Name_Type; + Unum : Unit_Number_Type; + + procedure Check_Redundant_Withs + (Context_Items : List_Id; + Spec_Context_Items : List_Id := No_List); + -- Determine whether the context list of a compilation unit contains + -- redundant with clauses. When checking body clauses against spec + -- clauses, set Context_Items to the context list of the body and + -- Spec_Context_Items to that of the spec. Parent packages are not + -- examined for documentation purposes. + + procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id); + -- Generate cross-reference information for the parents of child units. + -- N is a defining_program_unit_name, and P_Id is the immediate parent. + + --------------------------- + -- Check_Redundant_Withs -- + --------------------------- + + procedure Check_Redundant_Withs + (Context_Items : List_Id; + Spec_Context_Items : List_Id := No_List) + is + Clause : Node_Id; + + procedure Process_Body_Clauses + (Context_List : List_Id; + Clause : Node_Id; + Used : in out Boolean; + Used_Type_Or_Elab : in out Boolean); + -- Examine the context clauses of a package body, trying to match the + -- name entity of Clause with any list element. If the match occurs + -- on a use package clause set Used to True, for a use type clause or + -- pragma Elaborate[_All], set Used_Type_Or_Elab to True. + + procedure Process_Spec_Clauses + (Context_List : List_Id; + Clause : Node_Id; + Used : in out Boolean; + Withed : in out Boolean; + Exit_On_Self : Boolean := False); + -- Examine the context clauses of a package spec, trying to match + -- the name entity of Clause with any list element. If the match + -- occurs on a use package clause, set Used to True, for a with + -- package clause other than Clause, set Withed to True. Limited + -- with clauses, implicitly generated with clauses and withs + -- having pragmas Elaborate or Elaborate_All applied to them are + -- skipped. Exit_On_Self is used to control the search loop and + -- force an exit whenever Clause sees itself in the search. + + -------------------------- + -- Process_Body_Clauses -- + -------------------------- + + procedure Process_Body_Clauses + (Context_List : List_Id; + Clause : Node_Id; + Used : in out Boolean; + Used_Type_Or_Elab : in out Boolean) + is + Nam_Ent : constant Entity_Id := Entity (Name (Clause)); + Cont_Item : Node_Id; + Prag_Unit : Node_Id; + Subt_Mark : Node_Id; + Use_Item : Node_Id; + + function Same_Unit (N : Node_Id; P : Entity_Id) return Boolean; + -- In an expanded name in a use clause, if the prefix is a renamed + -- package, the entity is set to the original package as a result, + -- when checking whether the package appears in a previous with + -- clause, the renaming has to be taken into account, to prevent + -- spurious/incorrect warnings. A common case is use of Text_IO. + + --------------- + -- Same_Unit -- + --------------- + + function Same_Unit (N : Node_Id; P : Entity_Id) return Boolean is + begin + return Entity (N) = P + or else + (Present (Renamed_Object (P)) + and then Entity (N) = Renamed_Object (P)); + end Same_Unit; + + -- Start of processing for Process_Body_Clauses + + begin + Used := False; + Used_Type_Or_Elab := False; + + Cont_Item := First (Context_List); + while Present (Cont_Item) loop + + -- Package use clause + + if Nkind (Cont_Item) = N_Use_Package_Clause + and then not Used + then + -- Search through use clauses + + Use_Item := First (Names (Cont_Item)); + while Present (Use_Item) and then not Used loop + + -- Case of a direct use of the one we are looking for + + if Entity (Use_Item) = Nam_Ent then + Used := True; + + -- Handle nested case, as in "with P; use P.Q.R" + + else + declare + UE : Node_Id; + + begin + -- Loop through prefixes looking for match + + UE := Use_Item; + while Nkind (UE) = N_Expanded_Name loop + if Same_Unit (Prefix (UE), Nam_Ent) then + Used := True; + exit; + end if; + + UE := Prefix (UE); + end loop; + end; + end if; + + Next (Use_Item); + end loop; + + -- USE TYPE clause + + elsif Nkind (Cont_Item) = N_Use_Type_Clause + and then not Used_Type_Or_Elab + then + Subt_Mark := First (Subtype_Marks (Cont_Item)); + while Present (Subt_Mark) + and then not Used_Type_Or_Elab + loop + if Same_Unit (Prefix (Subt_Mark), Nam_Ent) then + Used_Type_Or_Elab := True; + end if; + + Next (Subt_Mark); + end loop; + + -- Pragma Elaborate or Elaborate_All + + elsif Nkind (Cont_Item) = N_Pragma + and then + (Pragma_Name (Cont_Item) = Name_Elaborate + or else + Pragma_Name (Cont_Item) = Name_Elaborate_All) + and then not Used_Type_Or_Elab + then + Prag_Unit := + First (Pragma_Argument_Associations (Cont_Item)); + while Present (Prag_Unit) + and then not Used_Type_Or_Elab + loop + if Entity (Expression (Prag_Unit)) = Nam_Ent then + Used_Type_Or_Elab := True; + end if; + + Next (Prag_Unit); + end loop; + end if; + + Next (Cont_Item); + end loop; + end Process_Body_Clauses; + + -------------------------- + -- Process_Spec_Clauses -- + -------------------------- + + procedure Process_Spec_Clauses + (Context_List : List_Id; + Clause : Node_Id; + Used : in out Boolean; + Withed : in out Boolean; + Exit_On_Self : Boolean := False) + is + Nam_Ent : constant Entity_Id := Entity (Name (Clause)); + Cont_Item : Node_Id; + Use_Item : Node_Id; + + begin + Used := False; + Withed := False; + + Cont_Item := First (Context_List); + while Present (Cont_Item) loop + + -- Stop the search since the context items after Cont_Item have + -- already been examined in a previous iteration of the reverse + -- loop in Check_Redundant_Withs. + + if Exit_On_Self + and Cont_Item = Clause + then + exit; + end if; + + -- Package use clause + + if Nkind (Cont_Item) = N_Use_Package_Clause + and then not Used + then + Use_Item := First (Names (Cont_Item)); + while Present (Use_Item) and then not Used loop + if Entity (Use_Item) = Nam_Ent then + Used := True; + end if; + + Next (Use_Item); + end loop; + + -- Package with clause. Avoid processing self, implicitly + -- generated with clauses or limited with clauses. Note that + -- we examine with clauses having pragmas Elaborate or + -- Elaborate_All applied to them due to cases such as: + -- + + -- with Pack; + -- with Pack; + -- pragma Elaborate (Pack); + -- + -- In this case, the second with clause is redundant since + -- the pragma applies only to the first "with Pack;". + + elsif Nkind (Cont_Item) = N_With_Clause + and then not Implicit_With (Cont_Item) + and then not Limited_Present (Cont_Item) + and then Cont_Item /= Clause + and then Entity (Name (Cont_Item)) = Nam_Ent + then + Withed := True; + end if; + + Next (Cont_Item); + end loop; + end Process_Spec_Clauses; + + -- Start of processing for Check_Redundant_Withs + + begin + Clause := Last (Context_Items); + while Present (Clause) loop + + -- Avoid checking implicitly generated with clauses, limited with + -- clauses or withs that have pragma Elaborate or Elaborate_All. + + if Nkind (Clause) = N_With_Clause + and then not Implicit_With (Clause) + and then not Limited_Present (Clause) + and then not Elaborate_Present (Clause) + then + -- Package body-to-spec check + + if Present (Spec_Context_Items) then + declare + Used_In_Body : Boolean := False; + Used_In_Spec : Boolean := False; + Used_Type_Or_Elab : Boolean := False; + Withed_In_Spec : Boolean := False; + + begin + Process_Spec_Clauses + (Context_List => Spec_Context_Items, + Clause => Clause, + Used => Used_In_Spec, + Withed => Withed_In_Spec); + + Process_Body_Clauses + (Context_List => Context_Items, + Clause => Clause, + Used => Used_In_Body, + Used_Type_Or_Elab => Used_Type_Or_Elab); + + -- "Type Elab" refers to the presence of either a use + -- type clause, pragmas Elaborate or Elaborate_All. + + -- +---------------+---------------------------+------+ + -- | Spec | Body | Warn | + -- +--------+------+--------+------+-----------+------+ + -- | Withed | Used | Withed | Used | Type Elab | | + -- | X | | X | | | X | + -- | X | | X | X | | | + -- | X | | X | | X | | + -- | X | | X | X | X | | + -- | X | X | X | | | X | + -- | X | X | X | | X | | + -- | X | X | X | X | | X | + -- | X | X | X | X | X | | + -- +--------+------+--------+------+-----------+------+ + + if (Withed_In_Spec + and then not Used_Type_Or_Elab) + and then + ((not Used_In_Spec + and then not Used_In_Body) + or else + Used_In_Spec) + then + Error_Msg_N -- CODEFIX + ("?redundant with clause in body", Clause); + end if; + + Used_In_Body := False; + Used_In_Spec := False; + Used_Type_Or_Elab := False; + Withed_In_Spec := False; + end; + + -- Standalone package spec or body check + + else + declare + Dont_Care : Boolean := False; + Withed : Boolean := False; + + begin + -- The mechanism for examining the context clauses of a + -- package spec can be applied to package body clauses. + + Process_Spec_Clauses + (Context_List => Context_Items, + Clause => Clause, + Used => Dont_Care, + Withed => Withed, + Exit_On_Self => True); + + if Withed then + Error_Msg_N -- CODEFIX + ("?redundant with clause", Clause); + end if; + end; + end if; + end if; + + Prev (Clause); + end loop; + end Check_Redundant_Withs; + + -------------------------------- + -- Generate_Parent_References -- + -------------------------------- + + procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id) is + Pref : Node_Id; + P_Name : Entity_Id := P_Id; + + begin + Pref := Name (Parent (Defining_Entity (N))); + + if Nkind (Pref) = N_Expanded_Name then + + -- Done already, if the unit has been compiled indirectly as + -- part of the closure of its context because of inlining. + + return; + end if; + + while Nkind (Pref) = N_Selected_Component loop + Change_Selected_Component_To_Expanded_Name (Pref); + Set_Entity (Pref, P_Name); + Set_Etype (Pref, Etype (P_Name)); + Generate_Reference (P_Name, Pref, 'r'); + Pref := Prefix (Pref); + P_Name := Scope (P_Name); + end loop; + + -- The guard here on P_Name is to handle the error condition where + -- the parent unit is missing because the file was not found. + + if Present (P_Name) then + Set_Entity (Pref, P_Name); + Set_Etype (Pref, Etype (P_Name)); + Generate_Reference (P_Name, Pref, 'r'); + Style.Check_Identifier (Pref, P_Name); + end if; + end Generate_Parent_References; + + -- Start of processing for Analyze_Compilation_Unit + + begin + Process_Compilation_Unit_Pragmas (N); + + -- If the unit is a subunit whose parent has not been analyzed (which + -- indicates that the main unit is a subunit, either the current one or + -- one of its descendents) then the subunit is compiled as part of the + -- analysis of the parent, which we proceed to do. Basically this gets + -- handled from the top down and we don't want to do anything at this + -- level (i.e. this subunit will be handled on the way down from the + -- parent), so at this level we immediately return. If the subunit ends + -- up not analyzed, it means that the parent did not contain a stub for + -- it, or that there errors were detected in some ancestor. + + if Nkind (Unit_Node) = N_Subunit + and then not Analyzed (Lib_Unit) + then + Semantics (Lib_Unit); + + if not Analyzed (Proper_Body (Unit_Node)) then + if Serious_Errors_Detected > 0 then + Error_Msg_N ("subunit not analyzed (errors in parent unit)", N); + else + Error_Msg_N ("missing stub for subunit", N); + end if; + end if; + + return; + end if; + + -- Analyze context (this will call Sem recursively for with'ed units) To + -- detect circularities among with-clauses that are not caught during + -- loading, we set the Context_Pending flag on the current unit. If the + -- flag is already set there is a potential circularity. We exclude + -- predefined units from this check because they are known to be safe. + -- We also exclude package bodies that are present because circularities + -- between bodies are harmless (and necessary). + + if Context_Pending (N) then + declare + Circularity : Boolean := True; + + begin + if Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Unit (N)))) + then + Circularity := False; + + else + for U in Main_Unit + 1 .. Last_Unit loop + if Nkind (Unit (Cunit (U))) = N_Package_Body + and then not Analyzed (Cunit (U)) + then + Circularity := False; + exit; + end if; + end loop; + end if; + + if Circularity then + Error_Msg_N ("circular dependency caused by with_clauses", N); + Error_Msg_N + ("\possibly missing limited_with clause" + & " in one of the following", N); + + for U in Main_Unit .. Last_Unit loop + if Context_Pending (Cunit (U)) then + Error_Msg_Unit_1 := Get_Unit_Name (Unit (Cunit (U))); + Error_Msg_N ("\unit$", N); + end if; + end loop; + + raise Unrecoverable_Error; + end if; + end; + else + Set_Context_Pending (N); + end if; + + Analyze_Context (N); + + Set_Context_Pending (N, False); + + -- If the unit is a package body, the spec is already loaded and must be + -- analyzed first, before we analyze the body. + + if Nkind (Unit_Node) = N_Package_Body then + + -- If no Lib_Unit, then there was a serious previous error, so just + -- ignore the entire analysis effort + + if No (Lib_Unit) then + return; + + else + Semantics (Lib_Unit); + Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit)); + + -- Verify that the library unit is a package declaration + + if not Nkind_In (Unit (Lib_Unit), N_Package_Declaration, + N_Generic_Package_Declaration) + then + Error_Msg_N + ("no legal package declaration for package body", N); + return; + + -- Otherwise, the entity in the declaration is visible. Update the + -- version to reflect dependence of this body on the spec. + + else + Spec_Id := Defining_Entity (Unit (Lib_Unit)); + Set_Is_Immediately_Visible (Spec_Id, True); + Version_Update (N, Lib_Unit); + + if Nkind (Defining_Unit_Name (Unit_Node)) = + N_Defining_Program_Unit_Name + then + Generate_Parent_References (Unit_Node, Scope (Spec_Id)); + end if; + end if; + end if; + + -- If the unit is a subprogram body, then we similarly need to analyze + -- its spec. However, things are a little simpler in this case, because + -- here, this analysis is done only for error checking and consistency + -- purposes, so there's nothing else to be done. + + elsif Nkind (Unit_Node) = N_Subprogram_Body then + if Acts_As_Spec (N) then + + -- If the subprogram body is a child unit, we must create a + -- declaration for it, in order to properly load the parent(s). + -- After this, the original unit does not acts as a spec, because + -- there is an explicit one. If this unit appears in a context + -- clause, then an implicit with on the parent will be added when + -- installing the context. If this is the main unit, there is no + -- Unit_Table entry for the declaration (it has the unit number + -- of the main unit) and code generation is unaffected. + + Unum := Get_Cunit_Unit_Number (N); + Par_Spec_Name := Get_Parent_Spec_Name (Unit_Name (Unum)); + + if Par_Spec_Name /= No_Unit_Name then + Unum := + Load_Unit + (Load_Name => Par_Spec_Name, + Required => True, + Subunit => False, + Error_Node => N); + + if Unum /= No_Unit then + + -- Build subprogram declaration and attach parent unit to it + -- This subprogram declaration does not come from source, + -- Nevertheless the backend must generate debugging info for + -- it, and this must be indicated explicitly. We also mark + -- the body entity as a child unit now, to prevent a + -- cascaded error if the spec entity cannot be entered + -- in its scope. Finally we create a Units table entry for + -- the subprogram declaration, to maintain a one-to-one + -- correspondence with compilation unit nodes. This is + -- critical for the tree traversals performed by CodePeer. + + declare + Loc : constant Source_Ptr := Sloc (N); + SCS : constant Boolean := + Get_Comes_From_Source_Default; + + begin + Set_Comes_From_Source_Default (False); + Lib_Unit := + Make_Compilation_Unit (Loc, + Context_Items => New_Copy_List (Context_Items (N)), + Unit => + Make_Subprogram_Declaration (Sloc (N), + Specification => + Copy_Separate_Tree + (Specification (Unit_Node))), + Aux_Decls_Node => + Make_Compilation_Unit_Aux (Loc)); + + Set_Library_Unit (N, Lib_Unit); + Set_Parent_Spec (Unit (Lib_Unit), Cunit (Unum)); + Make_Child_Decl_Unit (N); + Semantics (Lib_Unit); + + -- Now that a separate declaration exists, the body + -- of the child unit does not act as spec any longer. + + Set_Acts_As_Spec (N, False); + Set_Is_Child_Unit (Defining_Entity (Unit_Node)); + Set_Debug_Info_Needed (Defining_Entity (Unit (Lib_Unit))); + Set_Comes_From_Source_Default (SCS); + end; + end if; + end if; + + -- Here for subprogram with separate declaration + + else + Semantics (Lib_Unit); + Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit)); + Version_Update (N, Lib_Unit); + end if; + + -- If this is a child unit, generate references to the parents + + if Nkind (Defining_Unit_Name (Specification (Unit_Node))) = + N_Defining_Program_Unit_Name + then + Generate_Parent_References ( + Specification (Unit_Node), + Scope (Defining_Entity (Unit (Lib_Unit)))); + end if; + end if; + + -- If it is a child unit, the parent must be elaborated first and we + -- update version, since we are dependent on our parent. + + if Is_Child_Spec (Unit_Node) then + + -- The analysis of the parent is done with style checks off + + declare + Save_Style_Check : constant Boolean := Style_Check; + Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions := + Cunit_Boolean_Restrictions_Save; + + begin + if not GNAT_Mode then + Style_Check := False; + end if; + + Semantics (Parent_Spec (Unit_Node)); + Version_Update (N, Parent_Spec (Unit_Node)); + Style_Check := Save_Style_Check; + Cunit_Boolean_Restrictions_Restore (Save_C_Restrict); + end; + end if; + + -- With the analysis done, install the context. Note that we can't + -- install the context from the with clauses as we analyze them, because + -- each with clause must be analyzed in a clean visibility context, so + -- we have to wait and install them all at once. + + Install_Context (N); + + if Is_Child_Spec (Unit_Node) then + + -- Set the entities of all parents in the program_unit_name + + Generate_Parent_References ( + Unit_Node, Get_Parent_Entity (Unit (Parent_Spec (Unit_Node)))); + end if; + + -- All components of the context: with-clauses, library unit, ancestors + -- if any, (and their context) are analyzed and installed. + + -- Call special debug routine sm if this is the main unit + + if Current_Sem_Unit = Main_Unit then + sm; + end if; + + -- Now analyze the unit (package, subprogram spec, body) itself + + Analyze (Unit_Node); + + if Warn_On_Redundant_Constructs then + Check_Redundant_Withs (Context_Items (N)); + + if Nkind (Unit_Node) = N_Package_Body then + Check_Redundant_Withs + (Context_Items => Context_Items (N), + Spec_Context_Items => Context_Items (Lib_Unit)); + end if; + end if; + + -- The above call might have made Unit_Node an N_Subprogram_Body from + -- something else, so propagate any Acts_As_Spec flag. + + if Nkind (Unit_Node) = N_Subprogram_Body + and then Acts_As_Spec (Unit_Node) + then + Set_Acts_As_Spec (N); + end if; + + -- Register predefined units in Rtsfind + + declare + Unum : constant Unit_Number_Type := Get_Source_Unit (Sloc (N)); + begin + if Is_Predefined_File_Name (Unit_File_Name (Unum)) then + Set_RTU_Loaded (Unit_Node); + end if; + end; + + -- Treat compilation unit pragmas that appear after the library unit + + if Present (Pragmas_After (Aux_Decls_Node (N))) then + declare + Prag_Node : Node_Id := First (Pragmas_After (Aux_Decls_Node (N))); + begin + while Present (Prag_Node) loop + Analyze (Prag_Node); + Next (Prag_Node); + end loop; + end; + end if; + + -- Generate distribution stubs if requested and no error + + if N = Main_Cunit + and then (Distribution_Stub_Mode = Generate_Receiver_Stub_Body + or else + Distribution_Stub_Mode = Generate_Caller_Stub_Body) + and then not Fatal_Error (Main_Unit) + then + if Is_RCI_Pkg_Spec_Or_Body (N) then + + -- Regular RCI package + + Add_Stub_Constructs (N); + + elsif (Nkind (Unit_Node) = N_Package_Declaration + and then Is_Shared_Passive (Defining_Entity + (Specification (Unit_Node)))) + or else (Nkind (Unit_Node) = N_Package_Body + and then + Is_Shared_Passive (Corresponding_Spec (Unit_Node))) + then + -- Shared passive package + + Add_Stub_Constructs (N); + + elsif Nkind (Unit_Node) = N_Package_Instantiation + and then + Is_Remote_Call_Interface + (Defining_Entity (Specification (Instance_Spec (Unit_Node)))) + then + -- Instantiation of a RCI generic package + + Add_Stub_Constructs (N); + end if; + end if; + + -- Remove unit from visibility, so that environment is clean for the + -- next compilation, which is either the main unit or some other unit + -- in the context. + + if Nkind_In (Unit_Node, N_Package_Declaration, + N_Package_Renaming_Declaration, + N_Subprogram_Declaration) + or else Nkind (Unit_Node) in N_Generic_Declaration + or else + (Nkind (Unit_Node) = N_Subprogram_Body + and then Acts_As_Spec (Unit_Node)) + then + Remove_Unit_From_Visibility (Defining_Entity (Unit_Node)); + + -- If the unit is an instantiation whose body will be elaborated for + -- inlining purposes, use the proper entity of the instance. The entity + -- may be missing if the instantiation was illegal. + + elsif Nkind (Unit_Node) = N_Package_Instantiation + and then not Error_Posted (Unit_Node) + and then Present (Instance_Spec (Unit_Node)) + then + Remove_Unit_From_Visibility + (Defining_Entity (Instance_Spec (Unit_Node))); + + elsif Nkind (Unit_Node) = N_Package_Body + or else (Nkind (Unit_Node) = N_Subprogram_Body + and then not Acts_As_Spec (Unit_Node)) + then + -- Bodies that are not the main unit are compiled if they are generic + -- or contain generic or inlined units. Their analysis brings in the + -- context of the corresponding spec (unit declaration) which must be + -- removed as well, to return the compilation environment to its + -- proper state. + + Remove_Context (Lib_Unit); + Set_Is_Immediately_Visible (Defining_Entity (Unit (Lib_Unit)), False); + end if; + + -- Last step is to deinstall the context we just installed as well as + -- the unit just compiled. + + Remove_Context (N); + + -- If this is the main unit and we are generating code, we must check + -- that all generic units in the context have a body if they need it, + -- even if they have not been instantiated. In the absence of .ali files + -- for generic units, we must force the load of the body, just to + -- produce the proper error if the body is absent. We skip this + -- verification if the main unit itself is generic. + + if Get_Cunit_Unit_Number (N) = Main_Unit + and then Operating_Mode = Generate_Code + and then Expander_Active + then + -- Check whether the source for the body of the unit must be included + -- in a standalone library. + + Check_Body_Needed_For_SAL (Cunit_Entity (Main_Unit)); + + -- Indicate that the main unit is now analyzed, to catch possible + -- circularities between it and generic bodies. Remove main unit from + -- visibility. This might seem superfluous, but the main unit must + -- not be visible in the generic body expansions that follow. + + Set_Analyzed (N, True); + Set_Is_Immediately_Visible (Cunit_Entity (Main_Unit), False); + + declare + Item : Node_Id; + Nam : Entity_Id; + Un : Unit_Number_Type; + + Save_Style_Check : constant Boolean := Style_Check; + Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions := + Cunit_Boolean_Restrictions_Save; + + begin + Item := First (Context_Items (N)); + while Present (Item) loop + + -- Check for explicit with clause + + if Nkind (Item) = N_With_Clause + and then not Implicit_With (Item) + + -- Ada 2005 (AI-50217): Ignore limited-withed units + + and then not Limited_Present (Item) + then + Nam := Entity (Name (Item)); + + -- Compile generic subprogram, unless it is intrinsic or + -- imported so no body is required, or generic package body + -- if the package spec requires a body. + + if (Is_Generic_Subprogram (Nam) + and then not Is_Intrinsic_Subprogram (Nam) + and then not Is_Imported (Nam)) + or else (Ekind (Nam) = E_Generic_Package + and then Unit_Requires_Body (Nam)) + then + Style_Check := False; + + if Present (Renamed_Object (Nam)) then + Un := + Load_Unit + (Load_Name => Get_Body_Name + (Get_Unit_Name + (Unit_Declaration_Node + (Renamed_Object (Nam)))), + Required => False, + Subunit => False, + Error_Node => N, + Renamings => True); + else + Un := + Load_Unit + (Load_Name => Get_Body_Name + (Get_Unit_Name (Item)), + Required => False, + Subunit => False, + Error_Node => N, + Renamings => True); + end if; + + if Un = No_Unit then + Error_Msg_NE + ("body of generic unit& not found", Item, Nam); + exit; + + elsif not Analyzed (Cunit (Un)) + and then Un /= Main_Unit + and then not Fatal_Error (Un) + then + Style_Check := False; + Semantics (Cunit (Un)); + end if; + end if; + end if; + + Next (Item); + end loop; + + Style_Check := Save_Style_Check; + Cunit_Boolean_Restrictions_Restore (Save_C_Restrict); + end; + end if; + + -- Deal with creating elaboration Boolean if needed. We create an + -- elaboration boolean only for units that come from source since + -- units manufactured by the compiler never need elab checks. + + if Comes_From_Source (N) + and then Nkind_In (Unit_Node, N_Package_Declaration, + N_Generic_Package_Declaration, + N_Subprogram_Declaration, + N_Generic_Subprogram_Declaration) + then + declare + Loc : constant Source_Ptr := Sloc (N); + Unum : constant Unit_Number_Type := Get_Source_Unit (Loc); + + begin + Spec_Id := Defining_Entity (Unit_Node); + Generate_Definition (Spec_Id); + + -- See if an elaboration entity is required for possible access + -- before elaboration checking. Note that we must allow for this + -- even if -gnatE is not set, since a client may be compiled in + -- -gnatE mode and reference the entity. + + -- These entities are also used by the binder to prevent multiple + -- attempts to execute the elaboration code for the library case + -- where the elaboration routine might otherwise be called more + -- than once. + + -- Case of units which do not require elaboration checks + + if + -- Pure units do not need checks + + Is_Pure (Spec_Id) + + -- Preelaborated units do not need checks + + or else Is_Preelaborated (Spec_Id) + + -- No checks needed if pragma Elaborate_Body present + + or else Has_Pragma_Elaborate_Body (Spec_Id) + + -- No checks needed if unit does not require a body + + or else not Unit_Requires_Body (Spec_Id) + + -- No checks needed for predefined files + + or else Is_Predefined_File_Name (Unit_File_Name (Unum)) + + -- No checks required if no separate spec + + or else Acts_As_Spec (N) + then + -- This is a case where we only need the entity for + -- checking to prevent multiple elaboration checks. + + Set_Elaboration_Entity_Required (Spec_Id, False); + + -- Case of elaboration entity is required for access before + -- elaboration checking (so certainly we must build it!) + + else + Set_Elaboration_Entity_Required (Spec_Id, True); + end if; + + Build_Elaboration_Entity (N, Spec_Id); + end; + end if; + + -- Freeze the compilation unit entity. This for sure is needed because + -- of some warnings that can be output (see Freeze_Subprogram), but may + -- in general be required. If freezing actions result, place them in the + -- compilation unit actions list, and analyze them. + + declare + L : constant List_Id := + Freeze_Entity (Cunit_Entity (Current_Sem_Unit), N); + begin + while Is_Non_Empty_List (L) loop + Insert_Library_Level_Action (Remove_Head (L)); + end loop; + end; + + Set_Analyzed (N); + + if Nkind (Unit_Node) = N_Package_Declaration + and then Get_Cunit_Unit_Number (N) /= Main_Unit + and then Expander_Active + then + declare + Save_Style_Check : constant Boolean := Style_Check; + Save_Warning : constant Warning_Mode_Type := Warning_Mode; + Options : Style_Check_Options; + + begin + Save_Style_Check_Options (Options); + Reset_Style_Check_Options; + Opt.Warning_Mode := Suppress; + Check_Body_For_Inlining (N, Defining_Entity (Unit_Node)); + + Reset_Style_Check_Options; + Set_Style_Check_Options (Options); + Style_Check := Save_Style_Check; + Warning_Mode := Save_Warning; + end; + end if; + + -- If we are generating obsolescent warnings, then here is where we + -- generate them for the with'ed items. The reason for this special + -- processing is that the normal mechanism of generating the warnings + -- for referenced entities does not work for context clause references. + -- That's because when we first analyze the context, it is too early to + -- know if the with'ing unit is itself obsolescent (which suppresses + -- the warnings). + + if not GNAT_Mode and then Warn_On_Obsolescent_Feature then + + -- Push current compilation unit as scope, so that the test for + -- being within an obsolescent unit will work correctly. + + Push_Scope (Defining_Entity (Unit_Node)); + + -- Loop through context items to deal with with clauses + + declare + Item : Node_Id; + Nam : Node_Id; + Ent : Entity_Id; + + begin + Item := First (Context_Items (N)); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + + -- Suppress this check in limited-withed units. Further work + -- needed here if we decide to incorporate this check on + -- limited-withed units. + + and then not Limited_Present (Item) + then + Nam := Name (Item); + Ent := Entity (Nam); + + if Is_Obsolescent (Ent) then + Output_Obsolescent_Entity_Warnings (Nam, Ent); + end if; + end if; + + Next (Item); + end loop; + end; + + -- Remove temporary install of current unit as scope + + Pop_Scope; + end if; + end Analyze_Compilation_Unit; + + --------------------- + -- Analyze_Context -- + --------------------- + + procedure Analyze_Context (N : Node_Id) is + Ukind : constant Node_Kind := Nkind (Unit (N)); + Item : Node_Id; + + begin + -- First process all configuration pragmas at the start of the context + -- items. Strictly these are not part of the context clause, but that + -- is where the parser puts them. In any case for sure we must analyze + -- these before analyzing the actual context items, since they can have + -- an effect on that analysis (e.g. pragma Ada_2005 may allow a unit to + -- be with'ed as a result of changing categorizations in Ada 2005). + + Item := First (Context_Items (N)); + while Present (Item) + and then Nkind (Item) = N_Pragma + and then Pragma_Name (Item) in Configuration_Pragma_Names + loop + Analyze (Item); + Next (Item); + end loop; + + -- This is the point at which we capture the configuration settings + -- for the unit. At the moment only the Optimize_Alignment setting + -- needs to be captured. Probably more later ??? + + if Optimize_Alignment_Local then + Set_OA_Setting (Current_Sem_Unit, 'L'); + else + Set_OA_Setting (Current_Sem_Unit, Optimize_Alignment); + end if; + + -- Loop through actual context items. This is done in two passes: + + -- a) The first pass analyzes non-limited with-clauses and also any + -- configuration pragmas (we need to get the latter analyzed right + -- away, since they can affect processing of subsequent items. + + -- b) The second pass analyzes limited_with clauses (Ada 2005: AI-50217) + + while Present (Item) loop + + -- For with clause, analyze the with clause, and then update the + -- version, since we are dependent on a unit that we with. + + if Nkind (Item) = N_With_Clause + and then not Limited_Present (Item) + then + -- Skip analyzing with clause if no unit, nothing to do (this + -- happens for a with that references a non-existent unit). Skip + -- as well if this is a with_clause for the main unit, which + -- happens if a subunit has a useless with_clause on its parent. + + if Present (Library_Unit (Item)) then + if Library_Unit (Item) /= Cunit (Current_Sem_Unit) then + Analyze (Item); + + else + Set_Entity (Name (Item), Cunit_Entity (Current_Sem_Unit)); + end if; + end if; + + if not Implicit_With (Item) then + Version_Update (N, Library_Unit (Item)); + end if; + + -- Skip pragmas. Configuration pragmas at the start were handled in + -- the loop above, and remaining pragmas are not processed until we + -- actually install the context (see Install_Context). We delay the + -- analysis of these pragmas to make sure that we have installed all + -- the implicit with's on parent units. + + -- Skip use clauses at this stage, since we don't want to do any + -- installing of potentially use-visible entities until we + -- actually install the complete context (in Install_Context). + -- Otherwise things can get installed in the wrong context. + + else + null; + end if; + + Next (Item); + end loop; + + -- Second pass: examine all limited_with clauses. All other context + -- items are ignored in this pass. + + Item := First (Context_Items (N)); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then Limited_Present (Item) + then + -- No need to check errors on implicitly generated limited-with + -- clauses. + + if not Implicit_With (Item) then + + -- Verify that the illegal contexts given in 10.1.2 (18/2) are + -- properly rejected, including renaming declarations. + + if not Nkind_In (Ukind, N_Package_Declaration, + N_Subprogram_Declaration) + and then Ukind not in N_Generic_Declaration + and then Ukind not in N_Generic_Instantiation + then + Error_Msg_N ("limited with_clause not allowed here", Item); + + -- Check wrong use of a limited with clause applied to the + -- compilation unit containing the limited-with clause. + + -- limited with P.Q; + -- package P.Q is ... + + elsif Unit (Library_Unit (Item)) = Unit (N) then + Error_Msg_N ("wrong use of limited-with clause", Item); + + -- Check wrong use of limited-with clause applied to some + -- immediate ancestor. + + elsif Is_Child_Spec (Unit (N)) then + declare + Lib_U : constant Entity_Id := Unit (Library_Unit (Item)); + P : Node_Id; + + begin + P := Parent_Spec (Unit (N)); + loop + if Unit (P) = Lib_U then + Error_Msg_N ("limited with_clause cannot " + & "name ancestor", Item); + exit; + end if; + + exit when not Is_Child_Spec (Unit (P)); + P := Parent_Spec (Unit (P)); + end loop; + end; + end if; + + -- Check if the limited-withed unit is already visible through + -- some context clause of the current compilation unit or some + -- ancestor of the current compilation unit. + + declare + Lim_Unit_Name : constant Node_Id := Name (Item); + Comp_Unit : Node_Id; + It : Node_Id; + Unit_Name : Node_Id; + + begin + Comp_Unit := N; + loop + It := First (Context_Items (Comp_Unit)); + while Present (It) loop + if Item /= It + and then Nkind (It) = N_With_Clause + and then not Limited_Present (It) + and then + Nkind_In (Unit (Library_Unit (It)), + N_Package_Declaration, + N_Package_Renaming_Declaration) + then + if Nkind (Unit (Library_Unit (It))) = + N_Package_Declaration + then + Unit_Name := Name (It); + else + Unit_Name := Name (Unit (Library_Unit (It))); + end if; + + -- Check if the named package (or some ancestor) + -- leaves visible the full-view of the unit given + -- in the limited-with clause + + loop + if Designate_Same_Unit (Lim_Unit_Name, + Unit_Name) + then + Error_Msg_Sloc := Sloc (It); + Error_Msg_N + ("simultaneous visibility of limited " + & "and unlimited views not allowed", + Item); + Error_Msg_NE + ("\unlimited view visible through " + & "context clause #", + Item, It); + exit; + + elsif Nkind (Unit_Name) = N_Identifier then + exit; + end if; + + Unit_Name := Prefix (Unit_Name); + end loop; + end if; + + Next (It); + end loop; + + exit when not Is_Child_Spec (Unit (Comp_Unit)); + + Comp_Unit := Parent_Spec (Unit (Comp_Unit)); + end loop; + end; + end if; + + -- Skip analyzing with clause if no unit, see above + + if Present (Library_Unit (Item)) then + Analyze (Item); + end if; + + -- A limited_with does not impose an elaboration order, but + -- there is a semantic dependency for recompilation purposes. + + if not Implicit_With (Item) then + Version_Update (N, Library_Unit (Item)); + end if; + + -- Pragmas and use clauses and with clauses other than limited + -- with's are ignored in this pass through the context items. + + else + null; + end if; + + Next (Item); + end loop; + end Analyze_Context; + + ------------------------------- + -- Analyze_Package_Body_Stub -- + ------------------------------- + + procedure Analyze_Package_Body_Stub (N : Node_Id) is + Id : constant Entity_Id := Defining_Identifier (N); + Nam : Entity_Id; + + begin + -- The package declaration must be in the current declarative part + + Check_Stub_Level (N); + Nam := Current_Entity_In_Scope (Id); + + if No (Nam) or else not Is_Package_Or_Generic_Package (Nam) then + Error_Msg_N ("missing specification for package stub", N); + + elsif Has_Completion (Nam) + and then Present (Corresponding_Body (Unit_Declaration_Node (Nam))) + then + Error_Msg_N ("duplicate or redundant stub for package", N); + + else + -- Indicate that the body of the package exists. If we are doing + -- only semantic analysis, the stub stands for the body. If we are + -- generating code, the existence of the body will be confirmed + -- when we load the proper body. + + Set_Has_Completion (Nam); + Set_Scope (Defining_Entity (N), Current_Scope); + Generate_Reference (Nam, Id, 'b'); + Analyze_Proper_Body (N, Nam); + end if; + end Analyze_Package_Body_Stub; + + ------------------------- + -- Analyze_Proper_Body -- + ------------------------- + + procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id) is + Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N); + Unum : Unit_Number_Type; + + procedure Optional_Subunit; + -- This procedure is called when the main unit is a stub, or when we + -- are not generating code. In such a case, we analyze the subunit if + -- present, which is user-friendly and in fact required for ASIS, but + -- we don't complain if the subunit is missing. + + ---------------------- + -- Optional_Subunit -- + ---------------------- + + procedure Optional_Subunit is + Comp_Unit : Node_Id; + + begin + -- Try to load subunit, but ignore any errors that occur during the + -- loading of the subunit, by using the special feature in Errout to + -- ignore all errors. Note that Fatal_Error will still be set, so we + -- will be able to check for this case below. + + if not ASIS_Mode then + Ignore_Errors_Enable := Ignore_Errors_Enable + 1; + end if; + + Unum := + Load_Unit + (Load_Name => Subunit_Name, + Required => False, + Subunit => True, + Error_Node => N); + + if not ASIS_Mode then + Ignore_Errors_Enable := Ignore_Errors_Enable - 1; + end if; + + -- All done if we successfully loaded the subunit + + if Unum /= No_Unit + and then (not Fatal_Error (Unum) or else Try_Semantics) + then + Comp_Unit := Cunit (Unum); + + -- If the file was empty or seriously mangled, the unit itself may + -- be missing. + + if No (Unit (Comp_Unit)) then + Error_Msg_N + ("subunit does not contain expected proper body", N); + + elsif Nkind (Unit (Comp_Unit)) /= N_Subunit then + Error_Msg_N + ("expected SEPARATE subunit, found child unit", + Cunit_Entity (Unum)); + else + Set_Corresponding_Stub (Unit (Comp_Unit), N); + Analyze_Subunit (Comp_Unit); + Set_Library_Unit (N, Comp_Unit); + end if; + + elsif Unum = No_Unit + and then Present (Nam) + then + if Is_Protected_Type (Nam) then + Set_Corresponding_Body (Parent (Nam), Defining_Identifier (N)); + else + Set_Corresponding_Body ( + Unit_Declaration_Node (Nam), Defining_Identifier (N)); + end if; + end if; + end Optional_Subunit; + + -- Start of processing for Analyze_Proper_Body + + begin + -- If the subunit is already loaded, it means that the main unit is a + -- subunit, and that the current unit is one of its parents which was + -- being analyzed to provide the needed context for the analysis of the + -- subunit. In this case we analyze the subunit and continue with the + -- parent, without looking a subsequent subunits. + + if Is_Loaded (Subunit_Name) then + + -- If the proper body is already linked to the stub node, the stub is + -- in a generic unit and just needs analyzing. + + if Present (Library_Unit (N)) then + Set_Corresponding_Stub (Unit (Library_Unit (N)), N); + Analyze_Subunit (Library_Unit (N)); + + -- Otherwise we must load the subunit and link to it + + else + -- Load the subunit, this must work, since we originally loaded + -- the subunit earlier on. So this will not really load it, just + -- give access to it. + + Unum := + Load_Unit + (Load_Name => Subunit_Name, + Required => True, + Subunit => False, + Error_Node => N); + + -- And analyze the subunit in the parent context (note that we + -- do not call Semantics, since that would remove the parent + -- context). Because of this, we have to manually reset the + -- compiler state to Analyzing since it got destroyed by Load. + + if Unum /= No_Unit then + Compiler_State := Analyzing; + + -- Check that the proper body is a subunit and not a child + -- unit. If the unit was previously loaded, the error will + -- have been emitted when copying the generic node, so we + -- just return to avoid cascaded errors. + + if Nkind (Unit (Cunit (Unum))) /= N_Subunit then + return; + end if; + + Set_Corresponding_Stub (Unit (Cunit (Unum)), N); + Analyze_Subunit (Cunit (Unum)); + Set_Library_Unit (N, Cunit (Unum)); + end if; + end if; + + -- If the main unit is a subunit, then we are just performing semantic + -- analysis on that subunit, and any other subunits of any parent unit + -- should be ignored, except that if we are building trees for ASIS + -- usage we want to annotate the stub properly. + + elsif Nkind (Unit (Cunit (Main_Unit))) = N_Subunit + and then Subunit_Name /= Unit_Name (Main_Unit) + then + if ASIS_Mode then + Optional_Subunit; + end if; + + -- But before we return, set the flag for unloaded subunits. This + -- will suppress junk warnings of variables in the same declarative + -- part (or a higher level one) that are in danger of looking unused + -- when in fact there might be a declaration in the subunit that we + -- do not intend to load. + + Unloaded_Subunits := True; + return; + + -- If the subunit is not already loaded, and we are generating code, + -- then this is the case where compilation started from the parent, and + -- we are generating code for an entire subunit tree. In that case we + -- definitely need to load the subunit. + + -- In order to continue the analysis with the rest of the parent, + -- and other subunits, we load the unit without requiring its + -- presence, and emit a warning if not found, rather than terminating + -- the compilation abruptly, as for other missing file problems. + + elsif Original_Operating_Mode = Generate_Code then + + -- If the proper body is already linked to the stub node, the stub is + -- in a generic unit and just needs analyzing. + + -- We update the version. Although we are not strictly technically + -- semantically dependent on the subunit, given our approach of macro + -- substitution of subunits, it makes sense to include it in the + -- version identification. + + if Present (Library_Unit (N)) then + Set_Corresponding_Stub (Unit (Library_Unit (N)), N); + Analyze_Subunit (Library_Unit (N)); + Version_Update (Cunit (Main_Unit), Library_Unit (N)); + + -- Otherwise we must load the subunit and link to it + + else + -- Make sure that, if the subunit is preprocessed and -gnateG is + -- specified, the preprocessed file will be written. + + Lib.Analysing_Subunit_Of_Main := True; + Unum := + Load_Unit + (Load_Name => Subunit_Name, + Required => False, + Subunit => True, + Error_Node => N); + Lib.Analysing_Subunit_Of_Main := False; + + -- Give message if we did not get the unit Emit warning even if + -- missing subunit is not within main unit, to simplify debugging. + + if Original_Operating_Mode = Generate_Code + and then Unum = No_Unit + then + Error_Msg_Unit_1 := Subunit_Name; + Error_Msg_File_1 := + Get_File_Name (Subunit_Name, Subunit => True); + Error_Msg_N + ("subunit$$ in file{ not found?!!", N); + Subunits_Missing := True; + end if; + + -- Load_Unit may reset Compiler_State, since it may have been + -- necessary to parse an additional units, so we make sure that + -- we reset it to the Analyzing state. + + Compiler_State := Analyzing; + + if Unum /= No_Unit then + if Debug_Flag_L then + Write_Str ("*** Loaded subunit from stub. Analyze"); + Write_Eol; + end if; + + declare + Comp_Unit : constant Node_Id := Cunit (Unum); + + begin + -- Check for child unit instead of subunit + + if Nkind (Unit (Comp_Unit)) /= N_Subunit then + Error_Msg_N + ("expected SEPARATE subunit, found child unit", + Cunit_Entity (Unum)); + + -- OK, we have a subunit + + else + -- Set corresponding stub (even if errors) + + Set_Corresponding_Stub (Unit (Comp_Unit), N); + + -- Collect SCO information for loaded subunit if we are + -- in the main unit). + + if Generate_SCO + and then + In_Extended_Main_Source_Unit + (Cunit_Entity (Current_Sem_Unit)) + then + SCO_Record (Unum); + end if; + + -- Analyze the unit if semantics active + + if not Fatal_Error (Unum) or else Try_Semantics then + Analyze_Subunit (Comp_Unit); + end if; + + -- Set the library unit pointer in any case + + Set_Library_Unit (N, Comp_Unit); + + -- We update the version. Although we are not technically + -- semantically dependent on the subunit, given our + -- approach of macro substitution of subunits, it makes + -- sense to include it in the version identification. + + Version_Update (Cunit (Main_Unit), Comp_Unit); + end if; + end; + end if; + end if; + + -- The remaining case is when the subunit is not already loaded and we + -- are not generating code. In this case we are just performing semantic + -- analysis on the parent, and we are not interested in the subunit. For + -- subprograms, analyze the stub as a body. For other entities the stub + -- has already been marked as completed. + + else + Optional_Subunit; + end if; + end Analyze_Proper_Body; + + ---------------------------------- + -- Analyze_Protected_Body_Stub -- + ---------------------------------- + + procedure Analyze_Protected_Body_Stub (N : Node_Id) is + Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N)); + + begin + Check_Stub_Level (N); + + -- First occurrence of name may have been as an incomplete type + + if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then + Nam := Full_View (Nam); + end if; + + if No (Nam) + or else not Is_Protected_Type (Etype (Nam)) + then + Error_Msg_N ("missing specification for Protected body", N); + else + Set_Scope (Defining_Entity (N), Current_Scope); + Set_Has_Completion (Etype (Nam)); + Generate_Reference (Nam, Defining_Identifier (N), 'b'); + Analyze_Proper_Body (N, Etype (Nam)); + end if; + end Analyze_Protected_Body_Stub; + + ---------------------------------- + -- Analyze_Subprogram_Body_Stub -- + ---------------------------------- + + -- A subprogram body stub can appear with or without a previous spec. If + -- there is one, then the analysis of the body will find it and verify + -- conformance. The formals appearing in the specification of the stub play + -- no role, except for requiring an additional conformance check. If there + -- is no previous subprogram declaration, the stub acts as a spec, and + -- provides the defining entity for the subprogram. + + procedure Analyze_Subprogram_Body_Stub (N : Node_Id) is + Decl : Node_Id; + + begin + Check_Stub_Level (N); + + -- Verify that the identifier for the stub is unique within this + -- declarative part. + + if Nkind_In (Parent (N), N_Block_Statement, + N_Package_Body, + N_Subprogram_Body) + then + Decl := First (Declarations (Parent (N))); + while Present (Decl) + and then Decl /= N + loop + if Nkind (Decl) = N_Subprogram_Body_Stub + and then (Chars (Defining_Unit_Name (Specification (Decl))) = + Chars (Defining_Unit_Name (Specification (N)))) + then + Error_Msg_N ("identifier for stub is not unique", N); + end if; + + Next (Decl); + end loop; + end if; + + -- Treat stub as a body, which checks conformance if there is a previous + -- declaration, or else introduces entity and its signature. + + Analyze_Subprogram_Body (N); + Analyze_Proper_Body (N, Empty); + end Analyze_Subprogram_Body_Stub; + + --------------------- + -- Analyze_Subunit -- + --------------------- + + -- A subunit is compiled either by itself (for semantic checking) or as + -- part of compiling the parent (for code generation). In either case, by + -- the time we actually process the subunit, the parent has already been + -- installed and analyzed. The node N is a compilation unit, whose context + -- needs to be treated here, because we come directly here from the parent + -- without calling Analyze_Compilation_Unit. + + -- The compilation context includes the explicit context of the subunit, + -- and the context of the parent, together with the parent itself. In order + -- to compile the current context, we remove the one inherited from the + -- parent, in order to have a clean visibility table. We restore the parent + -- context before analyzing the proper body itself. On exit, we remove only + -- the explicit context of the subunit. + + procedure Analyze_Subunit (N : Node_Id) is + Lib_Unit : constant Node_Id := Library_Unit (N); + Par_Unit : constant Entity_Id := Current_Scope; + + Lib_Spec : Node_Id := Library_Unit (Lib_Unit); + Num_Scopes : Int := 0; + Use_Clauses : array (1 .. Scope_Stack.Last) of Node_Id; + Enclosing_Child : Entity_Id := Empty; + Svg : constant Suppress_Array := Scope_Suppress; + + procedure Analyze_Subunit_Context; + -- Capture names in use clauses of the subunit. This must be done before + -- re-installing parent declarations, because items in the context must + -- not be hidden by declarations local to the parent. + + procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id); + -- Recursive procedure to restore scope of all ancestors of subunit, + -- from outermost in. If parent is not a subunit, the call to install + -- context installs context of spec and (if parent is a child unit) the + -- context of its parents as well. It is confusing that parents should + -- be treated differently in both cases, but the semantics are just not + -- identical. + + procedure Re_Install_Use_Clauses; + -- As part of the removal of the parent scope, the use clauses are + -- removed, to be reinstalled when the context of the subunit has been + -- analyzed. Use clauses may also have been affected by the analysis of + -- the context of the subunit, so they have to be applied again, to + -- insure that the compilation environment of the rest of the parent + -- unit is identical. + + procedure Remove_Scope; + -- Remove current scope from scope stack, and preserve the list of use + -- clauses in it, to be reinstalled after context is analyzed. + + ----------------------------- + -- Analyze_Subunit_Context -- + ----------------------------- + + procedure Analyze_Subunit_Context is + Item : Node_Id; + Nam : Node_Id; + Unit_Name : Entity_Id; + + begin + Analyze_Context (N); + + -- Make withed units immediately visible. If child unit, make the + -- ultimate parent immediately visible. + + Item := First (Context_Items (N)); + while Present (Item) loop + if Nkind (Item) = N_With_Clause then + + -- Protect frontend against previous errors in context clauses + + if Nkind (Name (Item)) /= N_Selected_Component then + if Error_Posted (Item) then + null; + + else + Unit_Name := Entity (Name (Item)); + while Is_Child_Unit (Unit_Name) loop + Set_Is_Visible_Child_Unit (Unit_Name); + Unit_Name := Scope (Unit_Name); + end loop; + + if not Is_Immediately_Visible (Unit_Name) then + Set_Is_Immediately_Visible (Unit_Name); + Set_Context_Installed (Item); + end if; + end if; + end if; + + elsif Nkind (Item) = N_Use_Package_Clause then + Nam := First (Names (Item)); + while Present (Nam) loop + Analyze (Nam); + Next (Nam); + end loop; + + elsif Nkind (Item) = N_Use_Type_Clause then + Nam := First (Subtype_Marks (Item)); + while Present (Nam) loop + Analyze (Nam); + Next (Nam); + end loop; + end if; + + Next (Item); + end loop; + + -- Reset visibility of withed units. They will be made visible again + -- when we install the subunit context. + + Item := First (Context_Items (N)); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + + -- Protect frontend against previous errors in context clauses + + and then Nkind (Name (Item)) /= N_Selected_Component + and then not Error_Posted (Item) + then + Unit_Name := Entity (Name (Item)); + while Is_Child_Unit (Unit_Name) loop + Set_Is_Visible_Child_Unit (Unit_Name, False); + Unit_Name := Scope (Unit_Name); + end loop; + + if Context_Installed (Item) then + Set_Is_Immediately_Visible (Unit_Name, False); + Set_Context_Installed (Item, False); + end if; + end if; + + Next (Item); + end loop; + end Analyze_Subunit_Context; + + ------------------------ + -- Re_Install_Parents -- + ------------------------ + + procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id) is + E : Entity_Id; + + begin + if Nkind (Unit (L)) = N_Subunit then + Re_Install_Parents (Library_Unit (L), Scope (Scop)); + end if; + + Install_Context (L); + + -- If the subunit occurs within a child unit, we must restore the + -- immediate visibility of any siblings that may occur in context. + + if Present (Enclosing_Child) then + Install_Siblings (Enclosing_Child, L); + end if; + + Push_Scope (Scop); + + if Scop /= Par_Unit then + Set_Is_Immediately_Visible (Scop); + end if; + + -- Make entities in scope visible again. For child units, restore + -- visibility only if they are actually in context. + + E := First_Entity (Current_Scope); + while Present (E) loop + if not Is_Child_Unit (E) + or else Is_Visible_Child_Unit (E) + then + Set_Is_Immediately_Visible (E); + end if; + + Next_Entity (E); + end loop; + + -- A subunit appears within a body, and for a nested subunits all the + -- parents are bodies. Restore full visibility of their private + -- entities. + + if Is_Package_Or_Generic_Package (Scop) then + Set_In_Package_Body (Scop); + Install_Private_Declarations (Scop); + end if; + end Re_Install_Parents; + + ---------------------------- + -- Re_Install_Use_Clauses -- + ---------------------------- + + procedure Re_Install_Use_Clauses is + U : Node_Id; + begin + for J in reverse 1 .. Num_Scopes loop + U := Use_Clauses (J); + Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := U; + Install_Use_Clauses (U, Force_Installation => True); + end loop; + end Re_Install_Use_Clauses; + + ------------------ + -- Remove_Scope -- + ------------------ + + procedure Remove_Scope is + E : Entity_Id; + + begin + Num_Scopes := Num_Scopes + 1; + Use_Clauses (Num_Scopes) := + Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause; + + E := First_Entity (Current_Scope); + while Present (E) loop + Set_Is_Immediately_Visible (E, False); + Next_Entity (E); + end loop; + + if Is_Child_Unit (Current_Scope) then + Enclosing_Child := Current_Scope; + end if; + + Pop_Scope; + end Remove_Scope; + + -- Start of processing for Analyze_Subunit + + begin + if Style_Check then + declare + Nam : Node_Id := Name (Unit (N)); + + begin + if Nkind (Nam) = N_Selected_Component then + Nam := Selector_Name (Nam); + end if; + + Check_Identifier (Nam, Par_Unit); + end; + end if; + + if not Is_Empty_List (Context_Items (N)) then + + -- Save current use clauses + + Remove_Scope; + Remove_Context (Lib_Unit); + + -- Now remove parents and their context, including enclosing subunits + -- and the outer parent body which is not a subunit. + + if Present (Lib_Spec) then + Remove_Context (Lib_Spec); + + while Nkind (Unit (Lib_Spec)) = N_Subunit loop + Lib_Spec := Library_Unit (Lib_Spec); + Remove_Scope; + Remove_Context (Lib_Spec); + end loop; + + if Nkind (Unit (Lib_Unit)) = N_Subunit then + Remove_Scope; + end if; + + if Nkind (Unit (Lib_Spec)) = N_Package_Body then + Remove_Context (Library_Unit (Lib_Spec)); + end if; + end if; + + Set_Is_Immediately_Visible (Par_Unit, False); + + Analyze_Subunit_Context; + + Re_Install_Parents (Lib_Unit, Par_Unit); + Set_Is_Immediately_Visible (Par_Unit); + + -- If the context includes a child unit of the parent of the subunit, + -- the parent will have been removed from visibility, after compiling + -- that cousin in the context. The visibility of the parent must be + -- restored now. This also applies if the context includes another + -- subunit of the same parent which in turn includes a child unit in + -- its context. + + if Is_Package_Or_Generic_Package (Par_Unit) then + if not Is_Immediately_Visible (Par_Unit) + or else (Present (First_Entity (Par_Unit)) + and then not Is_Immediately_Visible + (First_Entity (Par_Unit))) + then + Set_Is_Immediately_Visible (Par_Unit); + Install_Visible_Declarations (Par_Unit); + Install_Private_Declarations (Par_Unit); + end if; + end if; + + Re_Install_Use_Clauses; + Install_Context (N); + + -- Restore state of suppress flags for current body + + Scope_Suppress := Svg; + + -- If the subunit is within a child unit, then siblings of any parent + -- unit that appear in the context clause of the subunit must also be + -- made immediately visible. + + if Present (Enclosing_Child) then + Install_Siblings (Enclosing_Child, N); + end if; + end if; + + Analyze (Proper_Body (Unit (N))); + Remove_Context (N); + + -- The subunit may contain a with_clause on a sibling of some ancestor. + -- Removing the context will remove from visibility those ancestor child + -- units, which must be restored to the visibility they have in the + -- enclosing body. + + if Present (Enclosing_Child) then + declare + C : Entity_Id; + begin + C := Current_Scope; + while Present (C) + and then Is_Child_Unit (C) + loop + Set_Is_Immediately_Visible (C); + Set_Is_Visible_Child_Unit (C); + C := Scope (C); + end loop; + end; + end if; + end Analyze_Subunit; + + ---------------------------- + -- Analyze_Task_Body_Stub -- + ---------------------------- + + procedure Analyze_Task_Body_Stub (N : Node_Id) is + Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N)); + Loc : constant Source_Ptr := Sloc (N); + + begin + Check_Stub_Level (N); + + -- First occurrence of name may have been as an incomplete type + + if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then + Nam := Full_View (Nam); + end if; + + if No (Nam) or else not Is_Task_Type (Etype (Nam)) then + Error_Msg_N ("missing specification for task body", N); + else + Set_Scope (Defining_Entity (N), Current_Scope); + Generate_Reference (Nam, Defining_Identifier (N), 'b'); + + -- Check for duplicate stub, if so give message and terminate + + if Has_Completion (Etype (Nam)) then + Error_Msg_N ("duplicate stub for task", N); + return; + else + Set_Has_Completion (Etype (Nam)); + end if; + + Analyze_Proper_Body (N, Etype (Nam)); + + -- Set elaboration flag to indicate that entity is callable. This + -- cannot be done in the expansion of the body itself, because the + -- proper body is not in a declarative part. This is only done if + -- expansion is active, because the context may be generic and the + -- flag not defined yet. + + if Expander_Active then + Insert_After (N, + Make_Assignment_Statement (Loc, + Name => + Make_Identifier (Loc, + Chars => New_External_Name (Chars (Etype (Nam)), 'E')), + Expression => New_Reference_To (Standard_True, Loc))); + end if; + end if; + end Analyze_Task_Body_Stub; + + ------------------------- + -- Analyze_With_Clause -- + ------------------------- + + -- Analyze the declaration of a unit in a with clause. At end, label the + -- with clause with the defining entity for the unit. + + procedure Analyze_With_Clause (N : Node_Id) is + + -- Retrieve the original kind of the unit node, before analysis. If it + -- is a subprogram instantiation, its analysis below will rewrite the + -- node as the declaration of the wrapper package. If the same + -- instantiation appears indirectly elsewhere in the context, it will + -- have been analyzed already. + + Unit_Kind : constant Node_Kind := + Nkind (Original_Node (Unit (Library_Unit (N)))); + Nam : constant Node_Id := Name (N); + E_Name : Entity_Id; + Par_Name : Entity_Id; + Pref : Node_Id; + U : Node_Id; + + Intunit : Boolean; + -- Set True if the unit currently being compiled is an internal unit + + Save_Style_Check : constant Boolean := Opt.Style_Check; + Save_C_Restrict : Save_Cunit_Boolean_Restrictions; + + begin + U := Unit (Library_Unit (N)); + + -- If this is an internal unit which is a renaming, then this is a + -- violation of No_Obsolescent_Features. + + -- Note: this is not quite right if the user defines one of these units + -- himself, but that's a marginal case, and fixing it is hard ??? + + if Restriction_Check_Required (No_Obsolescent_Features) then + declare + F : constant File_Name_Type := + Unit_File_Name (Get_Source_Unit (U)); + begin + if Is_Predefined_File_Name (F, Renamings_Included => True) + and then not + Is_Predefined_File_Name (F, Renamings_Included => False) + then + Check_Restriction (No_Obsolescent_Features, N); + end if; + end; + end if; + + -- Save current restriction set, does not apply to with'ed unit + + Save_C_Restrict := Cunit_Boolean_Restrictions_Save; + + -- Several actions are skipped for dummy packages (those supplied for + -- with's where no matching file could be found). Such packages are + -- identified by the Sloc value being set to No_Location. + + if Limited_Present (N) then + + -- Ada 2005 (AI-50217): Build visibility structures but do not + -- analyze the unit. + + if Sloc (U) /= No_Location then + Build_Limited_Views (N); + end if; + + return; + end if; + + -- We reset ordinary style checking during the analysis of a with'ed + -- unit, but we do NOT reset GNAT special analysis mode (the latter + -- definitely *does* apply to with'ed units). + + if not GNAT_Mode then + Style_Check := False; + end if; + + -- If the library unit is a predefined unit, and we are in high + -- integrity mode, then temporarily reset Configurable_Run_Time_Mode + -- for the analysis of the with'ed unit. This mode does not prevent + -- explicit with'ing of run-time units. + + if Configurable_Run_Time_Mode + and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (U))) + then + Configurable_Run_Time_Mode := False; + Semantics (Library_Unit (N)); + Configurable_Run_Time_Mode := True; + + else + Semantics (Library_Unit (N)); + end if; + + Intunit := Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)); + + if Sloc (U) /= No_Location then + + -- Check restrictions, except that we skip the check if this is an + -- internal unit unless we are compiling the internal unit as the + -- main unit. We also skip this for dummy packages. + + Check_Restriction_No_Dependence (Nam, N); + + if not Intunit or else Current_Sem_Unit = Main_Unit then + Check_Restricted_Unit (Unit_Name (Get_Source_Unit (U)), N); + end if; + + -- Deal with special case of GNAT.Current_Exceptions which interacts + -- with the optimization of local raise statements into gotos. + + if Nkind (Nam) = N_Selected_Component + and then Nkind (Prefix (Nam)) = N_Identifier + and then Chars (Prefix (Nam)) = Name_Gnat + and then (Chars (Selector_Name (Nam)) = Name_Most_Recent_Exception + or else + Chars (Selector_Name (Nam)) = Name_Exception_Traces) + then + Check_Restriction (No_Exception_Propagation, N); + Special_Exception_Package_Used := True; + end if; + + -- Check for inappropriate with of internal implementation unit if we + -- are not compiling an internal unit. We do not issue this message + -- for implicit with's generated by the compiler itself. + + if Implementation_Unit_Warnings + and then not Intunit + and then not Implicit_With (N) + then + declare + U_Kind : constant Kind_Of_Unit := + Get_Kind_Of_Unit (Get_Source_Unit (U)); + + begin + if U_Kind = Implementation_Unit then + Error_Msg_F ("& is an internal 'G'N'A'T unit?", Name (N)); + + -- Add alternative name if available, otherwise issue a + -- general warning message. + + if Error_Msg_Strlen /= 0 then + Error_Msg_F ("\use ""~"" instead", Name (N)); + else + Error_Msg_F + ("\use of this unit is non-portable " & + "and version-dependent?", Name (N)); + end if; + + elsif U_Kind = Ada_2005_Unit + and then Ada_Version < Ada_2005 + and then Warn_On_Ada_2005_Compatibility + then + Error_Msg_N ("& is an Ada 2005 unit?", Name (N)); + + elsif U_Kind = Ada_2012_Unit + and then Ada_Version < Ada_2012 + and then Warn_On_Ada_2012_Compatibility + then + Error_Msg_N ("& is an Ada 2012 unit?", Name (N)); + end if; + end; + end if; + end if; + + -- Semantic analysis of a generic unit is performed on a copy of + -- the original tree. Retrieve the entity on which semantic info + -- actually appears. + + if Unit_Kind in N_Generic_Declaration then + E_Name := Defining_Entity (U); + + -- Note: in the following test, Unit_Kind is the original Nkind, but in + -- the case of an instantiation, semantic analysis above will have + -- replaced the unit by its instantiated version. If the instance body + -- has been generated, the instance now denotes the body entity. For + -- visibility purposes we need the entity of its spec. + + elsif (Unit_Kind = N_Package_Instantiation + or else Nkind (Original_Node (Unit (Library_Unit (N)))) = + N_Package_Instantiation) + and then Nkind (U) = N_Package_Body + then + E_Name := Corresponding_Spec (U); + + elsif Unit_Kind = N_Package_Instantiation + and then Nkind (U) = N_Package_Instantiation + and then Present (Instance_Spec (U)) + then + -- If the instance has not been rewritten as a package declaration, + -- then it appeared already in a previous with clause. Retrieve + -- the entity from the previous instance. + + E_Name := Defining_Entity (Specification (Instance_Spec (U))); + + elsif Unit_Kind in N_Subprogram_Instantiation then + + -- The visible subprogram is created during instantiation, and is + -- an attribute of the wrapper package. We retrieve the wrapper + -- package directly from the instantiation node. If the instance + -- is inlined the unit is still an instantiation. Otherwise it has + -- been rewritten as the declaration of the wrapper itself. + + if Nkind (U) in N_Subprogram_Instantiation then + E_Name := + Related_Instance + (Defining_Entity (Specification (Instance_Spec (U)))); + else + E_Name := Related_Instance (Defining_Entity (U)); + end if; + + elsif Unit_Kind = N_Package_Renaming_Declaration + or else Unit_Kind in N_Generic_Renaming_Declaration + then + E_Name := Defining_Entity (U); + + elsif Unit_Kind = N_Subprogram_Body + and then Nkind (Name (N)) = N_Selected_Component + and then not Acts_As_Spec (Library_Unit (N)) + then + -- For a child unit that has no spec, one has been created and + -- analyzed. The entity required is that of the spec. + + E_Name := Corresponding_Spec (U); + + else + E_Name := Defining_Entity (U); + end if; + + if Nkind (Name (N)) = N_Selected_Component then + + -- Child unit in a with clause + + Change_Selected_Component_To_Expanded_Name (Name (N)); + end if; + + -- Restore style checks and restrictions + + Style_Check := Save_Style_Check; + Cunit_Boolean_Restrictions_Restore (Save_C_Restrict); + + -- Record the reference, but do NOT set the unit as referenced, we want + -- to consider the unit as unreferenced if this is the only reference + -- that occurs. + + Set_Entity_With_Style_Check (Name (N), E_Name); + Generate_Reference (E_Name, Name (N), 'w', Set_Ref => False); + + -- Generate references and check No_Dependence restriction for parents + + if Is_Child_Unit (E_Name) then + Pref := Prefix (Name (N)); + Par_Name := Scope (E_Name); + while Nkind (Pref) = N_Selected_Component loop + Change_Selected_Component_To_Expanded_Name (Pref); + + if Present (Entity (Selector_Name (Pref))) + and then + Present (Renamed_Entity (Entity (Selector_Name (Pref)))) + and then Entity (Selector_Name (Pref)) /= Par_Name + then + -- The prefix is a child unit that denotes a renaming declaration. + -- Replace the prefix directly with the renamed unit, because the + -- rest of the prefix is irrelevant to the visibility of the real + -- unit. + + Rewrite (Pref, New_Occurrence_Of (Par_Name, Sloc (Pref))); + exit; + end if; + + Set_Entity_With_Style_Check (Pref, Par_Name); + + Generate_Reference (Par_Name, Pref); + Check_Restriction_No_Dependence (Pref, N); + Pref := Prefix (Pref); + + -- If E_Name is the dummy entity for a nonexistent unit, its scope + -- is set to Standard_Standard, and no attempt should be made to + -- further unwind scopes. + + if Par_Name /= Standard_Standard then + Par_Name := Scope (Par_Name); + end if; + end loop; + + if Present (Entity (Pref)) + and then not Analyzed (Parent (Parent (Entity (Pref)))) + then + -- If the entity is set without its unit being compiled, the + -- original parent is a renaming, and Par_Name is the renamed + -- entity. For visibility purposes, we need the original entity, + -- which must be analyzed now because Load_Unit directly retrieves + -- the renamed unit, and the renaming declaration itself has not + -- been analyzed. + + Analyze (Parent (Parent (Entity (Pref)))); + pragma Assert (Renamed_Object (Entity (Pref)) = Par_Name); + Par_Name := Entity (Pref); + end if; + + Set_Entity_With_Style_Check (Pref, Par_Name); + Generate_Reference (Par_Name, Pref); + end if; + + -- If the withed unit is System, and a system extension pragma is + -- present, compile the extension now, rather than waiting for a + -- visibility check on a specific entity. + + if Chars (E_Name) = Name_System + and then Scope (E_Name) = Standard_Standard + and then Present (System_Extend_Unit) + and then Present_System_Aux (N) + then + -- If the extension is not present, an error will have been emitted + + null; + end if; + + -- Ada 2005 (AI-262): Remove from visibility the entity corresponding + -- to private_with units; they will be made visible later (just before + -- the private part is analyzed) + + if Private_Present (N) then + Set_Is_Immediately_Visible (E_Name, False); + end if; + end Analyze_With_Clause; + + ------------------------------ + -- Check_Private_Child_Unit -- + ------------------------------ + + procedure Check_Private_Child_Unit (N : Node_Id) is + Lib_Unit : constant Node_Id := Unit (N); + Item : Node_Id; + Curr_Unit : Entity_Id; + Sub_Parent : Node_Id; + Priv_Child : Entity_Id; + Par_Lib : Entity_Id; + Par_Spec : Node_Id; + + function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean; + -- Returns true if and only if the library unit is declared with + -- an explicit designation of private. + + ----------------------------- + -- Is_Private_Library_Unit -- + ----------------------------- + + function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean is + Comp_Unit : constant Node_Id := Parent (Unit_Declaration_Node (Unit)); + + begin + return Private_Present (Comp_Unit); + end Is_Private_Library_Unit; + + -- Start of processing for Check_Private_Child_Unit + + begin + if Nkind_In (Lib_Unit, N_Package_Body, N_Subprogram_Body) then + Curr_Unit := Defining_Entity (Unit (Library_Unit (N))); + Par_Lib := Curr_Unit; + + elsif Nkind (Lib_Unit) = N_Subunit then + + -- The parent is itself a body. The parent entity is to be found in + -- the corresponding spec. + + Sub_Parent := Library_Unit (N); + Curr_Unit := Defining_Entity (Unit (Library_Unit (Sub_Parent))); + + -- If the parent itself is a subunit, Curr_Unit is the entity of the + -- enclosing body, retrieve the spec entity which is the proper + -- ancestor we need for the following tests. + + if Ekind (Curr_Unit) = E_Package_Body then + Curr_Unit := Spec_Entity (Curr_Unit); + end if; + + Par_Lib := Curr_Unit; + + else + Curr_Unit := Defining_Entity (Lib_Unit); + + Par_Lib := Curr_Unit; + Par_Spec := Parent_Spec (Lib_Unit); + + if No (Par_Spec) then + Par_Lib := Empty; + else + Par_Lib := Defining_Entity (Unit (Par_Spec)); + end if; + end if; + + -- Loop through context items + + Item := First (Context_Items (N)); + while Present (Item) loop + + -- Ada 2005 (AI-262): Allow private_with of a private child package + -- in public siblings + + if Nkind (Item) = N_With_Clause + and then not Implicit_With (Item) + and then not Limited_Present (Item) + and then Is_Private_Descendant (Entity (Name (Item))) + then + Priv_Child := Entity (Name (Item)); + + declare + Curr_Parent : Entity_Id := Par_Lib; + Child_Parent : Entity_Id := Scope (Priv_Child); + Prv_Ancestor : Entity_Id := Child_Parent; + Curr_Private : Boolean := Is_Private_Library_Unit (Curr_Unit); + + begin + -- If the child unit is a public child then locate the nearest + -- private ancestor. Child_Parent will then be set to the + -- parent of that ancestor. + + if not Is_Private_Library_Unit (Priv_Child) then + while Present (Prv_Ancestor) + and then not Is_Private_Library_Unit (Prv_Ancestor) + loop + Prv_Ancestor := Scope (Prv_Ancestor); + end loop; + + if Present (Prv_Ancestor) then + Child_Parent := Scope (Prv_Ancestor); + end if; + end if; + + while Present (Curr_Parent) + and then Curr_Parent /= Standard_Standard + and then Curr_Parent /= Child_Parent + loop + Curr_Private := + Curr_Private or else Is_Private_Library_Unit (Curr_Parent); + Curr_Parent := Scope (Curr_Parent); + end loop; + + if No (Curr_Parent) then + Curr_Parent := Standard_Standard; + end if; + + if Curr_Parent /= Child_Parent then + if Ekind (Priv_Child) = E_Generic_Package + and then Chars (Priv_Child) in Text_IO_Package_Name + and then Chars (Scope (Scope (Priv_Child))) = Name_Ada + then + Error_Msg_NE + ("& is a nested package, not a compilation unit", + Name (Item), Priv_Child); + + else + Error_Msg_N + ("unit in with clause is private child unit!", Item); + Error_Msg_NE + ("\current unit must also have parent&!", + Item, Child_Parent); + end if; + + elsif Curr_Private + or else Private_Present (Item) + or else Nkind_In (Lib_Unit, N_Package_Body, N_Subunit) + or else (Nkind (Lib_Unit) = N_Subprogram_Body + and then not Acts_As_Spec (Parent (Lib_Unit))) + then + null; + + else + Error_Msg_NE + ("current unit must also be private descendant of&", + Item, Child_Parent); + end if; + end; + end if; + + Next (Item); + end loop; + + end Check_Private_Child_Unit; + + ---------------------- + -- Check_Stub_Level -- + ---------------------- + + procedure Check_Stub_Level (N : Node_Id) is + Par : constant Node_Id := Parent (N); + Kind : constant Node_Kind := Nkind (Par); + + begin + if Nkind_In (Kind, N_Package_Body, + N_Subprogram_Body, + N_Task_Body, + N_Protected_Body) + and then Nkind_In (Parent (Par), N_Compilation_Unit, N_Subunit) + then + null; + + -- In an instance, a missing stub appears at any level. A warning + -- message will have been emitted already for the missing file. + + elsif not In_Instance then + Error_Msg_N ("stub cannot appear in an inner scope", N); + + elsif Expander_Active then + Error_Msg_N ("missing proper body", N); + end if; + end Check_Stub_Level; + + ------------------------ + -- Expand_With_Clause -- + ------------------------ + + procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id) is + Loc : constant Source_Ptr := Sloc (Nam); + Ent : constant Entity_Id := Entity (Nam); + Withn : Node_Id; + P : Node_Id; + + function Build_Unit_Name (Nam : Node_Id) return Node_Id; + -- Build name to be used in implicit with_clause. In most cases this + -- is the source name, but if renamings are present we must make the + -- original unit visible, not the one it renames. The entity in the + -- with clause is the renamed unit, but the identifier is the one from + -- the source, which allows us to recover the unit renaming. + + --------------------- + -- Build_Unit_Name -- + --------------------- + + function Build_Unit_Name (Nam : Node_Id) return Node_Id is + Ent : Entity_Id; + Renaming : Entity_Id; + Result : Node_Id; + + begin + if Nkind (Nam) = N_Identifier then + + -- If the parent unit P in the name of the with_clause for P.Q is + -- a renaming of package R, then the entity of the parent is set + -- to R, but the identifier retains Chars (P) to be consistent + -- with the source (see details in lib-load). However the implicit + -- with_clause for the parent must make the entity for P visible, + -- because P.Q may be used as a prefix within the current unit. + -- The entity for P is the current_entity with that name, because + -- the package renaming declaration for it has just been analyzed. + -- Note that this case can only happen if P.Q has already appeared + -- in a previous with_clause in a related unit, such as the + -- library body of the current unit. + + if Chars (Nam) /= Chars (Entity (Nam)) then + Renaming := Current_Entity (Nam); + pragma Assert (Renamed_Entity (Renaming) = Entity (Nam)); + return New_Occurrence_Of (Renaming, Loc); + + else + return New_Occurrence_Of (Entity (Nam), Loc); + end if; + + else + Ent := Entity (Nam); + + if Present (Entity (Selector_Name (Nam))) + and then Chars (Entity (Selector_Name (Nam))) /= Chars (Ent) + and then + Nkind (Unit_Declaration_Node (Entity (Selector_Name (Nam)))) + = N_Package_Renaming_Declaration + then + -- The name in the with_clause is of the form A.B.C, and B is + -- given by a renaming declaration. In that case we may not + -- have analyzed the unit for B, but replaced it directly in + -- lib-load with the unit it renames. We have to make A.B + -- visible, so analyze the declaration for B now, in case it + -- has not been done yet. + + Ent := Entity (Selector_Name (Nam)); + Analyze + (Parent + (Unit_Declaration_Node (Entity (Selector_Name (Nam))))); + end if; + + Result := + Make_Expanded_Name (Loc, + Chars => Chars (Entity (Nam)), + Prefix => Build_Unit_Name (Prefix (Nam)), + Selector_Name => New_Occurrence_Of (Ent, Loc)); + Set_Entity (Result, Ent); + return Result; + end if; + end Build_Unit_Name; + + -- Start of processing for Expand_With_Clause + + begin + New_Nodes_OK := New_Nodes_OK + 1; + Withn := + Make_With_Clause (Loc, + Name => Build_Unit_Name (Nam)); + + P := Parent (Unit_Declaration_Node (Ent)); + Set_Library_Unit (Withn, P); + Set_Corresponding_Spec (Withn, Ent); + Set_First_Name (Withn, True); + Set_Implicit_With (Withn, True); + + -- If the unit is a package declaration, a private_with_clause on a + -- child unit implies the implicit with on the parent is also private. + + if Nkind (Unit (N)) = N_Package_Declaration then + Set_Private_Present (Withn, Private_Present (Item)); + end if; + + Prepend (Withn, Context_Items (N)); + Mark_Rewrite_Insertion (Withn); + Install_Withed_Unit (Withn); + + if Nkind (Nam) = N_Expanded_Name then + Expand_With_Clause (Item, Prefix (Nam), N); + end if; + + New_Nodes_OK := New_Nodes_OK - 1; + end Expand_With_Clause; + + ----------------------- + -- Get_Parent_Entity -- + ----------------------- + + function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is + begin + if Nkind (Unit) = N_Package_Body + and then Nkind (Original_Node (Unit)) = N_Package_Instantiation + then + return Defining_Entity + (Specification (Instance_Spec (Original_Node (Unit)))); + elsif Nkind (Unit) = N_Package_Instantiation then + return Defining_Entity (Specification (Instance_Spec (Unit))); + else + return Defining_Entity (Unit); + end if; + end Get_Parent_Entity; + + --------------------- + -- Has_With_Clause -- + --------------------- + + function Has_With_Clause + (C_Unit : Node_Id; + Pack : Entity_Id; + Is_Limited : Boolean := False) return Boolean + is + Item : Node_Id; + + function Named_Unit (Clause : Node_Id) return Entity_Id; + -- Return the entity for the unit named in a [limited] with clause + + ---------------- + -- Named_Unit -- + ---------------- + + function Named_Unit (Clause : Node_Id) return Entity_Id is + begin + if Nkind (Name (Clause)) = N_Selected_Component then + return Entity (Selector_Name (Name (Clause))); + else + return Entity (Name (Clause)); + end if; + end Named_Unit; + + -- Start of processing for Has_With_Clause + + begin + if Present (Context_Items (C_Unit)) then + Item := First (Context_Items (C_Unit)); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then Limited_Present (Item) = Is_Limited + and then Named_Unit (Item) = Pack + then + return True; + end if; + + Next (Item); + end loop; + end if; + + return False; + end Has_With_Clause; + + ----------------------------- + -- Implicit_With_On_Parent -- + ----------------------------- + + procedure Implicit_With_On_Parent + (Child_Unit : Node_Id; + N : Node_Id) + is + Loc : constant Source_Ptr := Sloc (N); + P : constant Node_Id := Parent_Spec (Child_Unit); + P_Unit : Node_Id := Unit (P); + P_Name : constant Entity_Id := Get_Parent_Entity (P_Unit); + Withn : Node_Id; + + function Build_Ancestor_Name (P : Node_Id) return Node_Id; + -- Build prefix of child unit name. Recurse if needed + + function Build_Unit_Name return Node_Id; + -- If the unit is a child unit, build qualified name with all ancestors + + ------------------------- + -- Build_Ancestor_Name -- + ------------------------- + + function Build_Ancestor_Name (P : Node_Id) return Node_Id is + P_Ref : constant Node_Id := + New_Reference_To (Defining_Entity (P), Loc); + P_Spec : Node_Id := P; + + begin + -- Ancestor may have been rewritten as a package body. Retrieve + -- the original spec to trace earlier ancestors. + + if Nkind (P) = N_Package_Body + and then Nkind (Original_Node (P)) = N_Package_Instantiation + then + P_Spec := Original_Node (P); + end if; + + if No (Parent_Spec (P_Spec)) then + return P_Ref; + else + return + Make_Selected_Component (Loc, + Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P_Spec))), + Selector_Name => P_Ref); + end if; + end Build_Ancestor_Name; + + --------------------- + -- Build_Unit_Name -- + --------------------- + + function Build_Unit_Name return Node_Id is + Result : Node_Id; + + begin + if No (Parent_Spec (P_Unit)) then + return New_Reference_To (P_Name, Loc); + + else + Result := + Make_Expanded_Name (Loc, + Chars => Chars (P_Name), + Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P_Unit))), + Selector_Name => New_Reference_To (P_Name, Loc)); + Set_Entity (Result, P_Name); + return Result; + end if; + end Build_Unit_Name; + + -- Start of processing for Implicit_With_On_Parent + + begin + -- The unit of the current compilation may be a package body that + -- replaces an instance node. In this case we need the original instance + -- node to construct the proper parent name. + + if Nkind (P_Unit) = N_Package_Body + and then Nkind (Original_Node (P_Unit)) = N_Package_Instantiation + then + P_Unit := Original_Node (P_Unit); + end if; + + -- We add the implicit with if the child unit is the current unit being + -- compiled. If the current unit is a body, we do not want to add an + -- implicit_with a second time to the corresponding spec. + + if Nkind (Child_Unit) = N_Package_Declaration + and then Child_Unit /= Unit (Cunit (Current_Sem_Unit)) + then + return; + end if; + + New_Nodes_OK := New_Nodes_OK + 1; + Withn := Make_With_Clause (Loc, Name => Build_Unit_Name); + + Set_Library_Unit (Withn, P); + Set_Corresponding_Spec (Withn, P_Name); + Set_First_Name (Withn, True); + Set_Implicit_With (Withn, True); + + -- Node is placed at the beginning of the context items, so that + -- subsequent use clauses on the parent can be validated. + + Prepend (Withn, Context_Items (N)); + Mark_Rewrite_Insertion (Withn); + Install_Withed_Unit (Withn); + + if Is_Child_Spec (P_Unit) then + Implicit_With_On_Parent (P_Unit, N); + end if; + + New_Nodes_OK := New_Nodes_OK - 1; + end Implicit_With_On_Parent; + + -------------- + -- In_Chain -- + -------------- + + function In_Chain (E : Entity_Id) return Boolean is + H : Entity_Id; + + begin + H := Current_Entity (E); + while Present (H) loop + if H = E then + return True; + else + H := Homonym (H); + end if; + end loop; + + return False; + end In_Chain; + + --------------------- + -- Install_Context -- + --------------------- + + procedure Install_Context (N : Node_Id) is + Lib_Unit : constant Node_Id := Unit (N); + + begin + Install_Context_Clauses (N); + + if Is_Child_Spec (Lib_Unit) then + Install_Parents (Lib_Unit, Private_Present (Parent (Lib_Unit))); + end if; + + Install_Limited_Context_Clauses (N); + end Install_Context; + + ----------------------------- + -- Install_Context_Clauses -- + ----------------------------- + + procedure Install_Context_Clauses (N : Node_Id) is + Lib_Unit : constant Node_Id := Unit (N); + Item : Node_Id; + Uname_Node : Entity_Id; + Check_Private : Boolean := False; + Decl_Node : Node_Id; + Lib_Parent : Entity_Id; + + begin + -- First skip configuration pragmas at the start of the context. They + -- are not technically part of the context clause, but that's where the + -- parser puts them. Note they were analyzed in Analyze_Context. + + Item := First (Context_Items (N)); + while Present (Item) + and then Nkind (Item) = N_Pragma + and then Pragma_Name (Item) in Configuration_Pragma_Names + loop + Next (Item); + end loop; + + -- Loop through the actual context clause items. We process everything + -- except Limited_With clauses in this routine. Limited_With clauses + -- are separately installed (see Install_Limited_Context_Clauses). + + while Present (Item) loop + + -- Case of explicit WITH clause + + if Nkind (Item) = N_With_Clause + and then not Implicit_With (Item) + then + if Limited_Present (Item) then + + -- Limited withed units will be installed later + + goto Continue; + + -- If Name (Item) is not an entity name, something is wrong, and + -- this will be detected in due course, for now ignore the item + + elsif not Is_Entity_Name (Name (Item)) then + goto Continue; + + elsif No (Entity (Name (Item))) then + Set_Entity (Name (Item), Any_Id); + goto Continue; + end if; + + Uname_Node := Entity (Name (Item)); + + if Is_Private_Descendant (Uname_Node) then + Check_Private := True; + end if; + + Install_Withed_Unit (Item); + + Decl_Node := Unit_Declaration_Node (Uname_Node); + + -- If the unit is a subprogram instance, it appears nested within + -- a package that carries the parent information. + + if Is_Generic_Instance (Uname_Node) + and then Ekind (Uname_Node) /= E_Package + then + Decl_Node := Parent (Parent (Decl_Node)); + end if; + + if Is_Child_Spec (Decl_Node) then + if Nkind (Name (Item)) = N_Expanded_Name then + Expand_With_Clause (Item, Prefix (Name (Item)), N); + else + -- If not an expanded name, the child unit must be a + -- renaming, nothing to do. + + null; + end if; + + elsif Nkind (Decl_Node) = N_Subprogram_Body + and then not Acts_As_Spec (Parent (Decl_Node)) + and then Is_Child_Spec (Unit (Library_Unit (Parent (Decl_Node)))) + then + Implicit_With_On_Parent + (Unit (Library_Unit (Parent (Decl_Node))), N); + end if; + + -- Check license conditions unless this is a dummy unit + + if Sloc (Library_Unit (Item)) /= No_Location then + License_Check : declare + Withu : constant Unit_Number_Type := + Get_Source_Unit (Library_Unit (Item)); + Withl : constant License_Type := + License (Source_Index (Withu)); + Unitl : constant License_Type := + License (Source_Index (Current_Sem_Unit)); + + procedure License_Error; + -- Signal error of bad license + + ------------------- + -- License_Error -- + ------------------- + + procedure License_Error is + begin + Error_Msg_N + ("?license of with'ed unit & may be inconsistent", + Name (Item)); + end License_Error; + + -- Start of processing for License_Check + + begin + -- Exclude license check if withed unit is an internal unit. + -- This situation arises e.g. with the GPL version of GNAT. + + if Is_Internal_File_Name (Unit_File_Name (Withu)) then + null; + + -- Otherwise check various cases + else + case Unitl is + when Unknown => + null; + + when Restricted => + if Withl = GPL then + License_Error; + end if; + + when GPL => + if Withl = Restricted then + License_Error; + end if; + + when Modified_GPL => + if Withl = Restricted or else Withl = GPL then + License_Error; + end if; + + when Unrestricted => + null; + end case; + end if; + end License_Check; + end if; + + -- Case of USE PACKAGE clause + + elsif Nkind (Item) = N_Use_Package_Clause then + Analyze_Use_Package (Item); + + -- Case of USE TYPE clause + + elsif Nkind (Item) = N_Use_Type_Clause then + Analyze_Use_Type (Item); + + -- case of PRAGMA + + elsif Nkind (Item) = N_Pragma then + Analyze (Item); + end if; + + <> + Next (Item); + end loop; + + if Is_Child_Spec (Lib_Unit) then + + -- The unit also has implicit with_clauses on its own parents + + if No (Context_Items (N)) then + Set_Context_Items (N, New_List); + end if; + + Implicit_With_On_Parent (Lib_Unit, N); + end if; + + -- If the unit is a body, the context of the specification must also + -- be installed. That includes private with_clauses in that context. + + if Nkind (Lib_Unit) = N_Package_Body + or else (Nkind (Lib_Unit) = N_Subprogram_Body + and then not Acts_As_Spec (N)) + then + Install_Context (Library_Unit (N)); + + -- Only install private with-clauses of a spec that comes from + -- source, excluding specs created for a subprogram body that is + -- a child unit. + + if Comes_From_Source (Library_Unit (N)) then + Install_Private_With_Clauses + (Defining_Entity (Unit (Library_Unit (N)))); + end if; + + if Is_Child_Spec (Unit (Library_Unit (N))) then + + -- If the unit is the body of a public child unit, the private + -- declarations of the parent must be made visible. If the child + -- unit is private, the private declarations have been installed + -- already in the call to Install_Parents for the spec. Installing + -- private declarations must be done for all ancestors of public + -- child units. In addition, sibling units mentioned in the + -- context clause of the body are directly visible. + + declare + Lib_Spec : Node_Id; + P : Node_Id; + P_Name : Entity_Id; + + begin + Lib_Spec := Unit (Library_Unit (N)); + while Is_Child_Spec (Lib_Spec) loop + P := Unit (Parent_Spec (Lib_Spec)); + P_Name := Defining_Entity (P); + + if not (Private_Present (Parent (Lib_Spec))) + and then not In_Private_Part (P_Name) + then + Install_Private_Declarations (P_Name); + Install_Private_With_Clauses (P_Name); + Set_Use (Private_Declarations (Specification (P))); + end if; + + Lib_Spec := P; + end loop; + end; + end if; + + -- For a package body, children in context are immediately visible + + Install_Siblings (Defining_Entity (Unit (Library_Unit (N))), N); + end if; + + if Nkind_In (Lib_Unit, N_Generic_Package_Declaration, + N_Generic_Subprogram_Declaration, + N_Package_Declaration, + N_Subprogram_Declaration) + then + if Is_Child_Spec (Lib_Unit) then + Lib_Parent := Defining_Entity (Unit (Parent_Spec (Lib_Unit))); + Set_Is_Private_Descendant + (Defining_Entity (Lib_Unit), + Is_Private_Descendant (Lib_Parent) + or else Private_Present (Parent (Lib_Unit))); + + else + Set_Is_Private_Descendant + (Defining_Entity (Lib_Unit), + Private_Present (Parent (Lib_Unit))); + end if; + end if; + + if Check_Private then + Check_Private_Child_Unit (N); + end if; + end Install_Context_Clauses; + + ------------------------------------- + -- Install_Limited_Context_Clauses -- + ------------------------------------- + + procedure Install_Limited_Context_Clauses (N : Node_Id) is + Item : Node_Id; + + procedure Check_Renamings (P : Node_Id; W : Node_Id); + -- Check that the unlimited view of a given compilation_unit is not + -- already visible through "use + renamings". + + procedure Check_Private_Limited_Withed_Unit (Item : Node_Id); + -- Check that if a limited_with clause of a given compilation_unit + -- mentions a descendant of a private child of some library unit, then + -- the given compilation_unit shall be the declaration of a private + -- descendant of that library unit, or a public descendant of such. The + -- code is analogous to that of Check_Private_Child_Unit but we cannot + -- use entities on the limited with_clauses because their units have not + -- been analyzed, so we have to climb the tree of ancestors looking for + -- private keywords. + + procedure Expand_Limited_With_Clause + (Comp_Unit : Node_Id; + Nam : Node_Id; + N : Node_Id); + -- If a child unit appears in a limited_with clause, there are implicit + -- limited_with clauses on all parents that are not already visible + -- through a regular with clause. This procedure creates the implicit + -- limited with_clauses for the parents and loads the corresponding + -- units. The shadow entities are created when the inserted clause is + -- analyzed. Implements Ada 2005 (AI-50217). + + function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean; + -- When compiling a unit Q descended from some parent unit P, a limited + -- with_clause in the context of P that names some other ancestor of Q + -- must not be installed because the ancestor is immediately visible. + + --------------------- + -- Check_Renamings -- + --------------------- + + procedure Check_Renamings (P : Node_Id; W : Node_Id) is + Item : Node_Id; + Spec : Node_Id; + WEnt : Entity_Id; + Nam : Node_Id; + E : Entity_Id; + E2 : Entity_Id; + + begin + pragma Assert (Nkind (W) = N_With_Clause); + + -- Protect the frontend against previous critical errors + + case Nkind (Unit (Library_Unit (W))) is + when N_Subprogram_Declaration | + N_Package_Declaration | + N_Generic_Subprogram_Declaration | + N_Generic_Package_Declaration => + null; + + when others => + return; + end case; + + -- Check "use + renamings" + + WEnt := Defining_Unit_Name (Specification (Unit (Library_Unit (W)))); + Spec := Specification (Unit (P)); + + Item := First (Visible_Declarations (Spec)); + while Present (Item) loop + + -- Look only at use package clauses + + if Nkind (Item) = N_Use_Package_Clause then + + -- Traverse the list of packages + + Nam := First (Names (Item)); + while Present (Nam) loop + E := Entity (Nam); + + pragma Assert (Present (Parent (E))); + + if Nkind (Parent (E)) = N_Package_Renaming_Declaration + and then Renamed_Entity (E) = WEnt + then + -- The unlimited view is visible through use clause and + -- renamings. There is no need to generate the error + -- message here because Is_Visible_Through_Renamings + -- takes care of generating the precise error message. + + return; + + elsif Nkind (Parent (E)) = N_Package_Specification then + + -- The use clause may refer to a local package. + -- Check all the enclosing scopes. + + E2 := E; + while E2 /= Standard_Standard + and then E2 /= WEnt + loop + E2 := Scope (E2); + end loop; + + if E2 = WEnt then + Error_Msg_N + ("unlimited view visible through use clause ", W); + return; + end if; + end if; + + Next (Nam); + end loop; + end if; + + Next (Item); + end loop; + + -- Recursive call to check all the ancestors + + if Is_Child_Spec (Unit (P)) then + Check_Renamings (P => Parent_Spec (Unit (P)), W => W); + end if; + end Check_Renamings; + + --------------------------------------- + -- Check_Private_Limited_Withed_Unit -- + --------------------------------------- + + procedure Check_Private_Limited_Withed_Unit (Item : Node_Id) is + Curr_Parent : Node_Id; + Child_Parent : Node_Id; + Curr_Private : Boolean; + + begin + -- Compilation unit of the parent of the withed library unit + + Child_Parent := Library_Unit (Item); + + -- If the child unit is a public child, then locate its nearest + -- private ancestor, if any, then Child_Parent will then be set to + -- the parent of that ancestor. + + if not Private_Present (Library_Unit (Item)) then + while Present (Child_Parent) + and then not Private_Present (Child_Parent) + loop + Child_Parent := Parent_Spec (Unit (Child_Parent)); + end loop; + + if No (Child_Parent) then + return; + end if; + end if; + + Child_Parent := Parent_Spec (Unit (Child_Parent)); + + -- Traverse all the ancestors of the current compilation unit to + -- check if it is a descendant of named library unit. + + Curr_Parent := Parent (Item); + Curr_Private := Private_Present (Curr_Parent); + + while Present (Parent_Spec (Unit (Curr_Parent))) + and then Curr_Parent /= Child_Parent + loop + Curr_Parent := Parent_Spec (Unit (Curr_Parent)); + Curr_Private := Curr_Private or else Private_Present (Curr_Parent); + end loop; + + if Curr_Parent /= Child_Parent then + Error_Msg_N + ("unit in with clause is private child unit!", Item); + Error_Msg_NE + ("\current unit must also have parent&!", + Item, Defining_Unit_Name (Specification (Unit (Child_Parent)))); + + elsif Private_Present (Parent (Item)) + or else Curr_Private + or else Private_Present (Item) + or else Nkind_In (Unit (Parent (Item)), N_Package_Body, + N_Subprogram_Body, + N_Subunit) + then + -- Current unit is private, of descendant of a private unit + + null; + + else + Error_Msg_NE + ("current unit must also be private descendant of&", + Item, Defining_Unit_Name (Specification (Unit (Child_Parent)))); + end if; + end Check_Private_Limited_Withed_Unit; + + -------------------------------- + -- Expand_Limited_With_Clause -- + -------------------------------- + + procedure Expand_Limited_With_Clause + (Comp_Unit : Node_Id; + Nam : Node_Id; + N : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Nam); + Unum : Unit_Number_Type; + Withn : Node_Id; + + function Previous_Withed_Unit (W : Node_Id) return Boolean; + -- Returns true if the context already includes a with_clause for + -- this unit. If the with_clause is non-limited, the unit is fully + -- visible and an implicit limited_with should not be created. If + -- there is already a limited_with clause for W, a second one is + -- simply redundant. + + -------------------------- + -- Previous_Withed_Unit -- + -------------------------- + + function Previous_Withed_Unit (W : Node_Id) return Boolean is + Item : Node_Id; + + begin + -- A limited with_clause cannot appear in the same context_clause + -- as a nonlimited with_clause which mentions the same library. + + Item := First (Context_Items (Comp_Unit)); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then Library_Unit (Item) = Library_Unit (W) + then + return True; + end if; + + Next (Item); + end loop; + + return False; + end Previous_Withed_Unit; + + -- Start of processing for Expand_Limited_With_Clause + + begin + New_Nodes_OK := New_Nodes_OK + 1; + + if Nkind (Nam) = N_Identifier then + + -- Create node for name of withed unit + + Withn := + Make_With_Clause (Loc, + Name => New_Copy (Nam)); + + else pragma Assert (Nkind (Nam) = N_Selected_Component); + Withn := + Make_With_Clause (Loc, + Name => Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Prefix (Nam)), + Selector_Name => New_Copy (Selector_Name (Nam)))); + Set_Parent (Withn, Parent (N)); + end if; + + Set_Limited_Present (Withn); + Set_First_Name (Withn); + Set_Implicit_With (Withn); + + Unum := + Load_Unit + (Load_Name => Get_Spec_Name (Get_Unit_Name (Nam)), + Required => True, + Subunit => False, + Error_Node => Nam); + + -- Do not generate a limited_with_clause on the current unit. This + -- path is taken when a unit has a limited_with clause on one of its + -- child units. + + if Unum = Current_Sem_Unit then + return; + end if; + + Set_Library_Unit (Withn, Cunit (Unum)); + Set_Corresponding_Spec + (Withn, Specification (Unit (Cunit (Unum)))); + + if not Previous_Withed_Unit (Withn) then + Prepend (Withn, Context_Items (Parent (N))); + Mark_Rewrite_Insertion (Withn); + + -- Add implicit limited_with_clauses for parents of child units + -- mentioned in limited_with clauses. + + if Nkind (Nam) = N_Selected_Component then + Expand_Limited_With_Clause (Comp_Unit, Prefix (Nam), N); + end if; + + Analyze (Withn); + + if not Limited_View_Installed (Withn) then + Install_Limited_Withed_Unit (Withn); + end if; + end if; + + New_Nodes_OK := New_Nodes_OK - 1; + end Expand_Limited_With_Clause; + + ---------------------- + -- Is_Ancestor_Unit -- + ---------------------- + + function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean is + E1 : constant Entity_Id := Defining_Entity (Unit (U1)); + E2 : Entity_Id; + begin + if Nkind_In (Unit (U2), N_Package_Body, N_Subprogram_Body) then + E2 := Defining_Entity (Unit (Library_Unit (U2))); + return Is_Ancestor_Package (E1, E2); + else + return False; + end if; + end Is_Ancestor_Unit; + + -- Start of processing for Install_Limited_Context_Clauses + + begin + Item := First (Context_Items (N)); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then Limited_Present (Item) + and then not Error_Posted (Item) + then + if Nkind (Name (Item)) = N_Selected_Component then + Expand_Limited_With_Clause + (Comp_Unit => N, Nam => Prefix (Name (Item)), N => Item); + end if; + + Check_Private_Limited_Withed_Unit (Item); + + if not Implicit_With (Item) + and then Is_Child_Spec (Unit (N)) + then + Check_Renamings (Parent_Spec (Unit (N)), Item); + end if; + + -- A unit may have a limited with on itself if it has a limited + -- with_clause on one of its child units. In that case it is + -- already being compiled and it makes no sense to install its + -- limited view. + + -- If the item is a limited_private_with_clause, install it if the + -- current unit is a body or if it is a private child. Otherwise + -- the private clause is installed before analyzing the private + -- part of the current unit. + + if Library_Unit (Item) /= Cunit (Current_Sem_Unit) + and then not Limited_View_Installed (Item) + and then + not Is_Ancestor_Unit + (Library_Unit (Item), Cunit (Current_Sem_Unit)) + then + if not Private_Present (Item) + or else Private_Present (N) + or else Nkind_In (Unit (N), N_Package_Body, + N_Subprogram_Body, + N_Subunit) + then + Install_Limited_Withed_Unit (Item); + end if; + end if; + end if; + + Next (Item); + end loop; + + -- Ada 2005 (AI-412): Examine visible declarations of a package spec, + -- looking for incomplete subtype declarations of incomplete types + -- visible through a limited with clause. + + if Ada_Version >= Ada_2005 + and then Analyzed (N) + and then Nkind (Unit (N)) = N_Package_Declaration + then + declare + Decl : Node_Id; + Def_Id : Entity_Id; + Non_Lim_View : Entity_Id; + + begin + Decl := First (Visible_Declarations (Specification (Unit (N)))); + while Present (Decl) loop + if Nkind (Decl) = N_Subtype_Declaration + and then + Ekind (Defining_Identifier (Decl)) = E_Incomplete_Subtype + and then + From_With_Type (Defining_Identifier (Decl)) + then + Def_Id := Defining_Identifier (Decl); + Non_Lim_View := Non_Limited_View (Def_Id); + + if not Is_Incomplete_Type (Non_Lim_View) then + + -- Convert an incomplete subtype declaration into a + -- corresponding non-limited view subtype declaration. + -- This is usually the case when analyzing a body that + -- has regular with clauses, when the spec has limited + -- ones. + + -- If the non-limited view is still incomplete, it is + -- the dummy entry already created, and the declaration + -- cannot be reanalyzed. This is the case when installing + -- a parent unit that has limited with-clauses. + + Set_Subtype_Indication (Decl, + New_Reference_To (Non_Lim_View, Sloc (Def_Id))); + Set_Etype (Def_Id, Non_Lim_View); + Set_Ekind (Def_Id, Subtype_Kind (Ekind (Non_Lim_View))); + Set_Analyzed (Decl, False); + + -- Reanalyze the declaration, suppressing the call to + -- Enter_Name to avoid duplicate names. + + Analyze_Subtype_Declaration + (N => Decl, + Skip => True); + end if; + end if; + + Next (Decl); + end loop; + end; + end if; + end Install_Limited_Context_Clauses; + + --------------------- + -- Install_Parents -- + --------------------- + + procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean) is + P : Node_Id; + E_Name : Entity_Id; + P_Name : Entity_Id; + P_Spec : Node_Id; + + begin + P := Unit (Parent_Spec (Lib_Unit)); + P_Name := Get_Parent_Entity (P); + + if Etype (P_Name) = Any_Type then + return; + end if; + + if Ekind (P_Name) = E_Generic_Package + and then not Nkind_In (Lib_Unit, N_Generic_Subprogram_Declaration, + N_Generic_Package_Declaration) + and then Nkind (Lib_Unit) not in N_Generic_Renaming_Declaration + then + Error_Msg_N + ("child of a generic package must be a generic unit", Lib_Unit); + + elsif not Is_Package_Or_Generic_Package (P_Name) then + Error_Msg_N + ("parent unit must be package or generic package", Lib_Unit); + raise Unrecoverable_Error; + + elsif Present (Renamed_Object (P_Name)) then + Error_Msg_N ("parent unit cannot be a renaming", Lib_Unit); + raise Unrecoverable_Error; + + -- Verify that a child of an instance is itself an instance, or the + -- renaming of one. Given that an instance that is a unit is replaced + -- with a package declaration, check against the original node. The + -- parent may be currently being instantiated, in which case it appears + -- as a declaration, but the generic_parent is already established + -- indicating that we deal with an instance. + + elsif Nkind (Original_Node (P)) = N_Package_Instantiation then + if Nkind (Lib_Unit) in N_Renaming_Declaration + or else Nkind (Original_Node (Lib_Unit)) in N_Generic_Instantiation + or else + (Nkind (Lib_Unit) = N_Package_Declaration + and then Present (Generic_Parent (Specification (Lib_Unit)))) + then + null; + else + Error_Msg_N + ("child of an instance must be an instance or renaming", + Lib_Unit); + end if; + end if; + + -- This is the recursive call that ensures all parents are loaded + + if Is_Child_Spec (P) then + Install_Parents (P, + Is_Private or else Private_Present (Parent (Lib_Unit))); + end if; + + -- Now we can install the context for this parent + + Install_Context_Clauses (Parent_Spec (Lib_Unit)); + Install_Limited_Context_Clauses (Parent_Spec (Lib_Unit)); + Install_Siblings (P_Name, Parent (Lib_Unit)); + + -- The child unit is in the declarative region of the parent. The parent + -- must therefore appear in the scope stack and be visible, as when + -- compiling the corresponding body. If the child unit is private or it + -- is a package body, private declarations must be accessible as well. + -- Use declarations in the parent must also be installed. Finally, other + -- child units of the same parent that are in the context are + -- immediately visible. + + -- Find entity for compilation unit, and set its private descendant + -- status as needed. Indicate that it is a compilation unit, which is + -- redundant in general, but needed if this is a generated child spec + -- for a child body without previous spec. + + E_Name := Defining_Entity (Lib_Unit); + + Set_Is_Child_Unit (E_Name); + Set_Is_Compilation_Unit (E_Name); + + Set_Is_Private_Descendant (E_Name, + Is_Private_Descendant (P_Name) + or else Private_Present (Parent (Lib_Unit))); + + P_Spec := Specification (Unit_Declaration_Node (P_Name)); + Push_Scope (P_Name); + + -- Save current visibility of unit + + Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility := + Is_Immediately_Visible (P_Name); + Set_Is_Immediately_Visible (P_Name); + Install_Visible_Declarations (P_Name); + Set_Use (Visible_Declarations (P_Spec)); + + -- If the parent is a generic unit, its formal part may contain formal + -- packages and use clauses for them. + + if Ekind (P_Name) = E_Generic_Package then + Set_Use (Generic_Formal_Declarations (Parent (P_Spec))); + end if; + + if Is_Private + or else Private_Present (Parent (Lib_Unit)) + then + Install_Private_Declarations (P_Name); + Install_Private_With_Clauses (P_Name); + Set_Use (Private_Declarations (P_Spec)); + end if; + end Install_Parents; + + ---------------------------------- + -- Install_Private_With_Clauses -- + ---------------------------------- + + procedure Install_Private_With_Clauses (P : Entity_Id) is + Decl : constant Node_Id := Unit_Declaration_Node (P); + Item : Node_Id; + + begin + if Debug_Flag_I then + Write_Str ("install private with clauses of "); + Write_Name (Chars (P)); + Write_Eol; + end if; + + if Nkind (Parent (Decl)) = N_Compilation_Unit then + Item := First (Context_Items (Parent (Decl))); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then Private_Present (Item) + then + if Limited_Present (Item) then + if not Limited_View_Installed (Item) then + Install_Limited_Withed_Unit (Item); + end if; + else + Install_Withed_Unit (Item, Private_With_OK => True); + end if; + end if; + + Next (Item); + end loop; + end if; + end Install_Private_With_Clauses; + + ---------------------- + -- Install_Siblings -- + ---------------------- + + procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id) is + Item : Node_Id; + Id : Entity_Id; + Prev : Entity_Id; + + begin + -- Iterate over explicit with clauses, and check whether the scope of + -- each entity is an ancestor of the current unit, in which case it is + -- immediately visible. + + Item := First (Context_Items (N)); + while Present (Item) loop + + -- Do not install private_with_clauses declaration, unless unit + -- is itself a private child unit, or is a body. Note that for a + -- subprogram body the private_with_clause does not take effect until + -- after the specification. + + if Nkind (Item) /= N_With_Clause + or else Implicit_With (Item) + or else Limited_Present (Item) + then + null; + + elsif not Private_Present (Item) + or else Private_Present (N) + or else Nkind (Unit (N)) = N_Package_Body + then + Id := Entity (Name (Item)); + + if Is_Child_Unit (Id) + and then Is_Ancestor_Package (Scope (Id), U_Name) + then + Set_Is_Immediately_Visible (Id); + + -- Check for the presence of another unit in the context that + -- may be inadvertently hidden by the child. + + Prev := Current_Entity (Id); + + if Present (Prev) + and then Is_Immediately_Visible (Prev) + and then not Is_Child_Unit (Prev) + then + declare + Clause : Node_Id; + + begin + Clause := First (Context_Items (N)); + while Present (Clause) loop + if Nkind (Clause) = N_With_Clause + and then Entity (Name (Clause)) = Prev + then + Error_Msg_NE + ("child unit& hides compilation unit " & + "with the same name?", + Name (Item), Id); + exit; + end if; + + Next (Clause); + end loop; + end; + end if; + + -- The With_Clause may be on a grand-child or one of its further + -- descendants, which makes a child immediately visible. Examine + -- ancestry to determine whether such a child exists. For example, + -- if current unit is A.C, and with_clause is on A.X.Y.Z, then X + -- is immediately visible. + + elsif Is_Child_Unit (Id) then + declare + Par : Entity_Id; + + begin + Par := Scope (Id); + while Is_Child_Unit (Par) loop + if Is_Ancestor_Package (Scope (Par), U_Name) then + Set_Is_Immediately_Visible (Par); + exit; + end if; + + Par := Scope (Par); + end loop; + end; + end if; + + -- If the item is a private with-clause on a child unit, the parent + -- may have been installed already, but the child unit must remain + -- invisible until installed in a private part or body, unless there + -- is already a regular with_clause for it in the current unit. + + elsif Private_Present (Item) then + Id := Entity (Name (Item)); + + if Is_Child_Unit (Id) then + declare + Clause : Node_Id; + + function In_Context return Boolean; + -- Scan context of current unit, to check whether there is + -- a with_clause on the same unit as a private with-clause + -- on a parent, in which case child unit is visible. If the + -- unit is a grand-child, the same applies to its parent. + + ---------------- + -- In_Context -- + ---------------- + + function In_Context return Boolean is + begin + Clause := + First (Context_Items (Cunit (Current_Sem_Unit))); + while Present (Clause) loop + if Nkind (Clause) = N_With_Clause + and then Comes_From_Source (Clause) + and then Is_Entity_Name (Name (Clause)) + and then not Private_Present (Clause) + then + if Entity (Name (Clause)) = Id + or else + (Nkind (Name (Clause)) = N_Expanded_Name + and then Entity (Prefix (Name (Clause))) = Id) + then + return True; + end if; + end if; + + Next (Clause); + end loop; + + return False; + end In_Context; + + begin + Set_Is_Visible_Child_Unit (Id, In_Context); + end; + end if; + end if; + + Next (Item); + end loop; + end Install_Siblings; + + --------------------------------- + -- Install_Limited_Withed_Unit -- + --------------------------------- + + procedure Install_Limited_Withed_Unit (N : Node_Id) is + P_Unit : constant Entity_Id := Unit (Library_Unit (N)); + E : Entity_Id; + P : Entity_Id; + Is_Child_Package : Boolean := False; + Lim_Header : Entity_Id; + Lim_Typ : Entity_Id; + + procedure Check_Body_Required; + -- A unit mentioned in a limited with_clause may not be mentioned in + -- a regular with_clause, but must still be included in the current + -- partition. We need to determine whether the unit needs a body, so + -- that the binder can determine the name of the file to be compiled. + -- Checking whether a unit needs a body can be done without semantic + -- analysis, by examining the nature of the declarations in the package. + + function Has_Limited_With_Clause + (C_Unit : Entity_Id; + Pack : Entity_Id) return Boolean; + -- Determine whether any package in the ancestor chain starting with + -- C_Unit has a limited with clause for package Pack. + + function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean; + -- Check if some package installed though normal with-clauses has a + -- renaming declaration of package P. AARM 10.1.2(21/2). + + ------------------------- + -- Check_Body_Required -- + ------------------------- + + procedure Check_Body_Required is + PA : constant List_Id := + Pragmas_After (Aux_Decls_Node (Parent (P_Unit))); + + procedure Check_Declarations (Spec : Node_Id); + -- Recursive procedure that does the work and checks nested packages + + ------------------------ + -- Check_Declarations -- + ------------------------ + + procedure Check_Declarations (Spec : Node_Id) is + Decl : Node_Id; + Incomplete_Decls : constant Elist_Id := New_Elmt_List; + + Subp_List : constant Elist_Id := New_Elmt_List; + + procedure Check_Pragma_Import (P : Node_Id); + -- If a pragma import applies to a previous subprogram, the + -- enclosing unit may not need a body. The processing is syntactic + -- and does not require a declaration to be analyzed. The code + -- below also handles pragma Import when applied to a subprogram + -- that renames another. In this case the pragma applies to the + -- renamed entity. + -- + -- Chains of multiple renames are not handled by the code below. + -- It is probably impossible to handle all cases without proper + -- name resolution. In such cases the algorithm is conservative + -- and will indicate that a body is needed??? + + ------------------------- + -- Check_Pragma_Import -- + ------------------------- + + procedure Check_Pragma_Import (P : Node_Id) is + Arg : Node_Id; + Prev_Id : Elmt_Id; + Subp_Id : Elmt_Id; + Imported : Node_Id; + + procedure Remove_Homonyms (E : Node_Id); + -- Make one pass over list of subprograms. Called again if + -- subprogram is a renaming. E is known to be an identifier. + + --------------------- + -- Remove_Homonyms -- + --------------------- + + procedure Remove_Homonyms (E : Node_Id) is + R : Entity_Id := Empty; + -- Name of renamed entity, if any + + begin + Subp_Id := First_Elmt (Subp_List); + while Present (Subp_Id) loop + if Chars (Node (Subp_Id)) = Chars (E) then + if Nkind (Parent (Parent (Node (Subp_Id)))) + /= N_Subprogram_Renaming_Declaration + then + Prev_Id := Subp_Id; + Next_Elmt (Subp_Id); + Remove_Elmt (Subp_List, Prev_Id); + else + R := Name (Parent (Parent (Node (Subp_Id)))); + exit; + end if; + else + Next_Elmt (Subp_Id); + end if; + end loop; + + if Present (R) then + if Nkind (R) = N_Identifier then + Remove_Homonyms (R); + + elsif Nkind (R) = N_Selected_Component then + Remove_Homonyms (Selector_Name (R)); + + -- Renaming of attribute + + else + null; + end if; + end if; + end Remove_Homonyms; + + -- Start of processing for Check_Pragma_Import + + begin + -- Find name of entity in Import pragma. We have not analyzed + -- the construct, so we must guard against syntax errors. + + Arg := Next (First (Pragma_Argument_Associations (P))); + + if No (Arg) + or else Nkind (Expression (Arg)) /= N_Identifier + then + return; + else + Imported := Expression (Arg); + end if; + + Remove_Homonyms (Imported); + end Check_Pragma_Import; + + -- Start of processing for Check_Declarations + + begin + -- Search for Elaborate Body pragma + + Decl := First (Visible_Declarations (Spec)); + while Present (Decl) + and then Nkind (Decl) = N_Pragma + loop + if Get_Pragma_Id (Decl) = Pragma_Elaborate_Body then + Set_Body_Required (Library_Unit (N)); + return; + end if; + + Next (Decl); + end loop; + + -- Look for declarations that require the presence of a body. We + -- have already skipped pragmas at the start of the list. + + while Present (Decl) loop + + -- Subprogram that comes from source means body may be needed. + -- Save for subsequent examination of import pragmas. + + if Comes_From_Source (Decl) + and then (Nkind_In (Decl, N_Subprogram_Declaration, + N_Subprogram_Renaming_Declaration, + N_Generic_Subprogram_Declaration)) + then + Append_Elmt (Defining_Entity (Decl), Subp_List); + + -- Package declaration of generic package declaration. We need + -- to recursively examine nested declarations. + + elsif Nkind_In (Decl, N_Package_Declaration, + N_Generic_Package_Declaration) + then + Check_Declarations (Specification (Decl)); + + elsif Nkind (Decl) = N_Pragma + and then Pragma_Name (Decl) = Name_Import + then + Check_Pragma_Import (Decl); + end if; + + Next (Decl); + end loop; + + -- Same set of tests for private part. In addition to subprograms + -- detect the presence of Taft Amendment types (incomplete types + -- completed in the body). + + Decl := First (Private_Declarations (Spec)); + while Present (Decl) loop + if Comes_From_Source (Decl) + and then (Nkind_In (Decl, N_Subprogram_Declaration, + N_Subprogram_Renaming_Declaration, + N_Generic_Subprogram_Declaration)) + then + Append_Elmt (Defining_Entity (Decl), Subp_List); + + elsif Nkind_In (Decl, N_Package_Declaration, + N_Generic_Package_Declaration) + then + Check_Declarations (Specification (Decl)); + + -- Collect incomplete type declarations for separate pass + + elsif Nkind (Decl) = N_Incomplete_Type_Declaration then + Append_Elmt (Decl, Incomplete_Decls); + + elsif Nkind (Decl) = N_Pragma + and then Pragma_Name (Decl) = Name_Import + then + Check_Pragma_Import (Decl); + end if; + + Next (Decl); + end loop; + + -- Now check incomplete declarations to locate Taft amendment + -- types. This can be done by examining the defining identifiers + -- of type declarations without real semantic analysis. + + declare + Inc : Elmt_Id; + + begin + Inc := First_Elmt (Incomplete_Decls); + while Present (Inc) loop + Decl := Next (Node (Inc)); + while Present (Decl) loop + if Nkind (Decl) = N_Full_Type_Declaration + and then Chars (Defining_Identifier (Decl)) = + Chars (Defining_Identifier (Node (Inc))) + then + exit; + end if; + + Next (Decl); + end loop; + + -- If no completion, this is a TAT, and a body is needed + + if No (Decl) then + Set_Body_Required (Library_Unit (N)); + return; + end if; + + Next_Elmt (Inc); + end loop; + end; + + -- Finally, check whether there are subprograms that still require + -- a body, i.e. are not renamings or null. + + if not Is_Empty_Elmt_List (Subp_List) then + declare + Subp_Id : Elmt_Id; + Spec : Node_Id; + + begin + Subp_Id := First_Elmt (Subp_List); + Spec := Parent (Node (Subp_Id)); + + while Present (Subp_Id) loop + if Nkind (Parent (Spec)) + = N_Subprogram_Renaming_Declaration + then + null; + + elsif Nkind (Spec) = N_Procedure_Specification + and then Null_Present (Spec) + then + null; + + else + Set_Body_Required (Library_Unit (N)); + return; + end if; + + Next_Elmt (Subp_Id); + end loop; + end; + end if; + end Check_Declarations; + + -- Start of processing for Check_Body_Required + + begin + -- If this is an imported package (Java and CIL usage) no body is + -- needed. Scan list of pragmas that may follow a compilation unit + -- to look for a relevant pragma Import. + + if Present (PA) then + declare + Prag : Node_Id; + + begin + Prag := First (PA); + while Present (Prag) loop + if Nkind (Prag) = N_Pragma + and then Get_Pragma_Id (Prag) = Pragma_Import + then + return; + end if; + + Next (Prag); + end loop; + end; + end if; + + Check_Declarations (Specification (P_Unit)); + end Check_Body_Required; + + ----------------------------- + -- Has_Limited_With_Clause -- + ----------------------------- + + function Has_Limited_With_Clause + (C_Unit : Entity_Id; + Pack : Entity_Id) return Boolean + is + Par : Entity_Id; + Par_Unit : Node_Id; + + begin + Par := C_Unit; + while Present (Par) loop + if Ekind (Par) /= E_Package then + exit; + end if; + + -- Retrieve the Compilation_Unit node for Par and determine if + -- its context clauses contain a limited with for Pack. + + Par_Unit := Parent (Parent (Parent (Par))); + + if Nkind (Par_Unit) = N_Package_Declaration then + Par_Unit := Parent (Par_Unit); + end if; + + if Has_With_Clause (Par_Unit, Pack, True) then + return True; + end if; + + -- If there are more ancestors, climb up the tree, otherwise we + -- are done. + + if Is_Child_Unit (Par) then + Par := Scope (Par); + else + exit; + end if; + end loop; + + return False; + end Has_Limited_With_Clause; + + ---------------------------------- + -- Is_Visible_Through_Renamings -- + ---------------------------------- + + function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean is + Kind : constant Node_Kind := + Nkind (Unit (Cunit (Current_Sem_Unit))); + Aux_Unit : Node_Id; + Item : Node_Id; + Decl : Entity_Id; + + begin + -- Example of the error detected by this subprogram: + + -- package P is + -- type T is ... + -- end P; + + -- with P; + -- package Q is + -- package Ren_P renames P; + -- end Q; + + -- with Q; + -- package R is ... + + -- limited with P; -- ERROR + -- package R.C is ... + + Aux_Unit := Cunit (Current_Sem_Unit); + + loop + Item := First (Context_Items (Aux_Unit)); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then not Limited_Present (Item) + and then Nkind (Unit (Library_Unit (Item))) = + N_Package_Declaration + then + Decl := + First (Visible_Declarations + (Specification (Unit (Library_Unit (Item))))); + while Present (Decl) loop + if Nkind (Decl) = N_Package_Renaming_Declaration + and then Entity (Name (Decl)) = P + then + -- Generate the error message only if the current unit + -- is a package declaration; in case of subprogram + -- bodies and package bodies we just return True to + -- indicate that the limited view must not be + -- installed. + + if Kind = N_Package_Declaration then + Error_Msg_N + ("simultaneous visibility of the limited and " & + "unlimited views not allowed", N); + Error_Msg_Sloc := Sloc (Item); + Error_Msg_NE + ("\\ unlimited view of & visible through the " & + "context clause #", N, P); + Error_Msg_Sloc := Sloc (Decl); + Error_Msg_NE ("\\ and the renaming #", N, P); + end if; + + return True; + end if; + + Next (Decl); + end loop; + end if; + + Next (Item); + end loop; + + -- If it is a body not acting as spec, follow pointer to the + -- corresponding spec, otherwise follow pointer to parent spec. + + if Present (Library_Unit (Aux_Unit)) + and then Nkind_In (Unit (Aux_Unit), + N_Package_Body, N_Subprogram_Body) + then + if Aux_Unit = Library_Unit (Aux_Unit) then + + -- Aux_Unit is a body that acts as a spec. Clause has + -- already been flagged as illegal. + + return False; + + else + Aux_Unit := Library_Unit (Aux_Unit); + end if; + + else + Aux_Unit := Parent_Spec (Unit (Aux_Unit)); + end if; + + exit when No (Aux_Unit); + end loop; + + return False; + end Is_Visible_Through_Renamings; + + -- Start of processing for Install_Limited_Withed_Unit + + begin + pragma Assert (not Limited_View_Installed (N)); + + -- In case of limited with_clause on subprograms, generics, instances, + -- or renamings, the corresponding error was previously posted and we + -- have nothing to do here. If the file is missing altogether, it has + -- no source location. + + if Nkind (P_Unit) /= N_Package_Declaration + or else Sloc (P_Unit) = No_Location + then + return; + end if; + + P := Defining_Unit_Name (Specification (P_Unit)); + + -- Handle child packages + + if Nkind (P) = N_Defining_Program_Unit_Name then + Is_Child_Package := True; + P := Defining_Identifier (P); + end if; + + -- Do not install the limited-view if the context of the unit is already + -- available through a regular with clause. + + if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body + and then Has_With_Clause (Cunit (Current_Sem_Unit), P) + then + return; + end if; + + -- Do not install the limited-view if the full-view is already visible + -- through renaming declarations. + + if Is_Visible_Through_Renamings (P) then + return; + end if; + + -- Do not install the limited view if this is the unit being analyzed. + -- This unusual case will happen when a unit has a limited_with clause + -- on one of its children. The compilation of the child forces the load + -- of the parent which tries to install the limited view of the child + -- again. Installing the limited view must also be disabled when + -- compiling the body of the child unit. + + if P = Cunit_Entity (Current_Sem_Unit) + or else + (Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body + and then P = Main_Unit_Entity) + then + return; + end if; + + -- This scenario is similar to the one above, the difference is that the + -- compilation of sibling Par.Sib forces the load of parent Par which + -- tries to install the limited view of Lim_Pack [1]. However Par.Sib + -- has a with clause for Lim_Pack [2] in its body, and thus needs the + -- non-limited views of all entities from Lim_Pack. + + -- limited with Lim_Pack; -- [1] + -- package Par is ... package Lim_Pack is ... + + -- with Lim_Pack; -- [2] + -- package Par.Sib is ... package body Par.Sib is ... + + -- In this case Main_Unit_Entity is the spec of Par.Sib and Current_ + -- Sem_Unit is the body of Par.Sib. + + if Ekind (P) = E_Package + and then Ekind (Main_Unit_Entity) = E_Package + and then Is_Child_Unit (Main_Unit_Entity) + + -- The body has a regular with clause + + and then Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body + and then Has_With_Clause (Cunit (Current_Sem_Unit), P) + + -- One of the ancestors has a limited with clause + + and then Nkind (Parent (Parent (Main_Unit_Entity))) = + N_Package_Specification + and then Has_Limited_With_Clause (Scope (Main_Unit_Entity), P) + then + return; + end if; + + -- A common use of the limited-with is to have a limited-with in the + -- package spec, and a normal with in its package body. For example: + + -- limited with X; -- [1] + -- package A is ... + + -- with X; -- [2] + -- package body A is ... + + -- The compilation of A's body installs the context clauses found at [2] + -- and then the context clauses of its specification (found at [1]). As + -- a consequence, at [1] the specification of X has been analyzed and it + -- is immediately visible. According to the semantics of limited-with + -- context clauses we don't install the limited view because the full + -- view of X supersedes its limited view. + + if Analyzed (P_Unit) + and then + (Is_Immediately_Visible (P) + or else (Is_Child_Package and then Is_Visible_Child_Unit (P))) + then + + -- The presence of both the limited and the analyzed nonlimited view + -- may also be an error, such as an illegal context for a limited + -- with_clause. In that case, do not process the context item at all. + + if Error_Posted (N) then + return; + end if; + + if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then + declare + Item : Node_Id; + begin + Item := First (Context_Items (Cunit (Current_Sem_Unit))); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then Comes_From_Source (Item) + and then Entity (Name (Item)) = P + then + return; + end if; + + Next (Item); + end loop; + end; + + -- If this is a child body, assume that the nonlimited with_clause + -- appears in an ancestor. Could be refined ??? + + if Is_Child_Unit + (Defining_Entity + (Unit (Library_Unit (Cunit (Current_Sem_Unit))))) + then + return; + end if; + + else + + -- If in package declaration, nonlimited view brought in from + -- parent unit or some error condition. + + return; + end if; + end if; + + if Debug_Flag_I then + Write_Str ("install limited view of "); + Write_Name (Chars (P)); + Write_Eol; + end if; + + -- If the unit has not been analyzed and the limited view has not been + -- already installed then we install it. + + if not Analyzed (P_Unit) then + if not In_Chain (P) then + + -- Minimum decoration + + Set_Ekind (P, E_Package); + Set_Etype (P, Standard_Void_Type); + Set_Scope (P, Standard_Standard); + + if Is_Child_Package then + Set_Is_Child_Unit (P); + Set_Is_Visible_Child_Unit (P); + Set_Scope (P, Defining_Entity (Unit (Parent_Spec (P_Unit)))); + end if; + + -- Place entity on visibility structure + + Set_Homonym (P, Current_Entity (P)); + Set_Current_Entity (P); + + if Debug_Flag_I then + Write_Str (" (homonym) chain "); + Write_Name (Chars (P)); + Write_Eol; + end if; + + -- Install the incomplete view. The first element of the limited + -- view is a header (an E_Package entity) used to reference the + -- first shadow entity in the private part of the package. + + Lim_Header := Limited_View (P); + Lim_Typ := First_Entity (Lim_Header); + + while Present (Lim_Typ) + and then Lim_Typ /= First_Private_Entity (Lim_Header) + loop + Set_Homonym (Lim_Typ, Current_Entity (Lim_Typ)); + Set_Current_Entity (Lim_Typ); + + if Debug_Flag_I then + Write_Str (" (homonym) chain "); + Write_Name (Chars (Lim_Typ)); + Write_Eol; + end if; + + Next_Entity (Lim_Typ); + end loop; + end if; + + -- If the unit appears in a previous regular with_clause, the regular + -- entities of the public part of the withed package must be replaced + -- by the shadow ones. + + -- This code must be kept synchronized with the code that replaces the + -- shadow entities by the real entities (see body of Remove_Limited + -- With_Clause); otherwise the contents of the homonym chains are not + -- consistent. + + else + -- Hide all the type entities of the public part of the package to + -- avoid its usage. This is needed to cover all the subtype decla- + -- rations because we do not remove them from the homonym chain. + + E := First_Entity (P); + while Present (E) and then E /= First_Private_Entity (P) loop + if Is_Type (E) then + Set_Was_Hidden (E, Is_Hidden (E)); + Set_Is_Hidden (E); + end if; + + Next_Entity (E); + end loop; + + -- Replace the real entities by the shadow entities of the limited + -- view. The first element of the limited view is a header that is + -- used to reference the first shadow entity in the private part + -- of the package. Successive elements are the limited views of the + -- type (including regular incomplete types) declared in the package. + + Lim_Header := Limited_View (P); + + Lim_Typ := First_Entity (Lim_Header); + while Present (Lim_Typ) + and then Lim_Typ /= First_Private_Entity (Lim_Header) + loop + pragma Assert (not In_Chain (Lim_Typ)); + + -- Do not unchain nested packages and child units + + if Ekind (Lim_Typ) /= E_Package + and then not Is_Child_Unit (Lim_Typ) + then + declare + Prev : Entity_Id; + + begin + Prev := Current_Entity (Lim_Typ); + E := Prev; + + -- Replace E in the homonyms list, so that the limited view + -- becomes available. + + if E = Non_Limited_View (Lim_Typ) then + Set_Homonym (Lim_Typ, Homonym (Prev)); + Set_Current_Entity (Lim_Typ); + + else + loop + E := Homonym (Prev); + + -- E may have been removed when installing a previous + -- limited_with_clause. + + exit when No (E); + + exit when E = Non_Limited_View (Lim_Typ); + + Prev := Homonym (Prev); + end loop; + + if Present (E) then + Set_Homonym (Lim_Typ, Homonym (Homonym (Prev))); + Set_Homonym (Prev, Lim_Typ); + end if; + end if; + end; + + if Debug_Flag_I then + Write_Str (" (homonym) chain "); + Write_Name (Chars (Lim_Typ)); + Write_Eol; + end if; + end if; + + Next_Entity (Lim_Typ); + end loop; + end if; + + -- The package must be visible while the limited-with clause is active + -- because references to the type P.T must resolve in the usual way. + -- In addition, we remember that the limited-view has been installed to + -- uninstall it at the point of context removal. + + Set_Is_Immediately_Visible (P); + Set_Limited_View_Installed (N); + + -- If unit has not been analyzed in some previous context, check + -- (imperfectly ???) whether it might need a body. + + if not Analyzed (P_Unit) then + Check_Body_Required; + end if; + + -- If the package in the limited_with clause is a child unit, the clause + -- is unanalyzed and appears as a selected component. Recast it as an + -- expanded name so that the entity can be properly set. Use entity of + -- parent, if available, for higher ancestors in the name. + + if Nkind (Name (N)) = N_Selected_Component then + declare + Nam : Node_Id; + Ent : Entity_Id; + + begin + Nam := Name (N); + Ent := P; + while Nkind (Nam) = N_Selected_Component + and then Present (Ent) + loop + Change_Selected_Component_To_Expanded_Name (Nam); + + -- Set entity of parent identifiers if the unit is a child + -- unit. This ensures that the tree is properly formed from + -- semantic point of view (e.g. for ASIS queries). + + Set_Entity (Nam, Ent); + + Nam := Prefix (Nam); + Ent := Scope (Ent); + + -- Set entity of last ancestor + + if Nkind (Nam) = N_Identifier then + Set_Entity (Nam, Ent); + end if; + end loop; + end; + end if; + + Set_Entity (Name (N), P); + Set_From_With_Type (P); + end Install_Limited_Withed_Unit; + + ------------------------- + -- Install_Withed_Unit -- + ------------------------- + + procedure Install_Withed_Unit + (With_Clause : Node_Id; + Private_With_OK : Boolean := False) + is + Uname : constant Entity_Id := Entity (Name (With_Clause)); + P : constant Entity_Id := Scope (Uname); + + begin + -- Ada 2005 (AI-262): Do not install the private withed unit if we are + -- compiling a package declaration and the Private_With_OK flag was not + -- set by the caller. These declarations will be installed later (before + -- analyzing the private part of the package). + + if Private_Present (With_Clause) + and then Nkind (Unit (Parent (With_Clause))) = N_Package_Declaration + and then not (Private_With_OK) + then + return; + end if; + + if Debug_Flag_I then + if Private_Present (With_Clause) then + Write_Str ("install private withed unit "); + else + Write_Str ("install withed unit "); + end if; + + Write_Name (Chars (Uname)); + Write_Eol; + end if; + + -- We do not apply the restrictions to an internal unit unless we are + -- compiling the internal unit as a main unit. This check is also + -- skipped for dummy units (for missing packages). + + if Sloc (Uname) /= No_Location + and then (not Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)) + or else Current_Sem_Unit = Main_Unit) + then + Check_Restricted_Unit + (Unit_Name (Get_Source_Unit (Uname)), With_Clause); + end if; + + if P /= Standard_Standard then + + -- If the unit is not analyzed after analysis of the with clause and + -- it is an instantiation then it awaits a body and is the main unit. + -- Its appearance in the context of some other unit indicates a + -- circular dependency (DEC suite perversity). + + if not Analyzed (Uname) + and then Nkind (Parent (Uname)) = N_Package_Instantiation + then + Error_Msg_N + ("instantiation depends on itself", Name (With_Clause)); + + elsif not Is_Visible_Child_Unit (Uname) then + Set_Is_Visible_Child_Unit (Uname); + + -- If the child unit appears in the context of its parent, it is + -- immediately visible. + + if In_Open_Scopes (Scope (Uname)) then + Set_Is_Immediately_Visible (Uname); + end if; + + if Is_Generic_Instance (Uname) + and then Ekind (Uname) in Subprogram_Kind + then + -- Set flag as well on the visible entity that denotes the + -- instance, which renames the current one. + + Set_Is_Visible_Child_Unit + (Related_Instance + (Defining_Entity (Unit (Library_Unit (With_Clause))))); + end if; + + -- The parent unit may have been installed already, and may have + -- appeared in a use clause. + + if In_Use (Scope (Uname)) then + Set_Is_Potentially_Use_Visible (Uname); + end if; + + Set_Context_Installed (With_Clause); + end if; + + elsif not Is_Immediately_Visible (Uname) then + if not Private_Present (With_Clause) + or else Private_With_OK + then + Set_Is_Immediately_Visible (Uname); + end if; + + Set_Context_Installed (With_Clause); + end if; + + -- A with-clause overrides a with-type clause: there are no restric- + -- tions on the use of package entities. + + if Ekind (Uname) = E_Package then + Set_From_With_Type (Uname, False); + end if; + + -- Ada 2005 (AI-377): it is illegal for a with_clause to name a child + -- unit if there is a visible homograph for it declared in the same + -- declarative region. This pathological case can only arise when an + -- instance I1 of a generic unit G1 has an explicit child unit I1.G2, + -- G1 has a generic child also named G2, and the context includes with_ + -- clauses for both I1.G2 and for G1.G2, making an implicit declaration + -- of I1.G2 visible as well. If the child unit is named Standard, do + -- not apply the check to the Standard package itself. + + if Is_Child_Unit (Uname) + and then Is_Visible_Child_Unit (Uname) + and then Ada_Version >= Ada_2005 + then + declare + Decl1 : constant Node_Id := Unit_Declaration_Node (P); + Decl2 : Node_Id; + P2 : Entity_Id; + U2 : Entity_Id; + + begin + U2 := Homonym (Uname); + while Present (U2) + and then U2 /= Standard_Standard + loop + P2 := Scope (U2); + Decl2 := Unit_Declaration_Node (P2); + + if Is_Child_Unit (U2) + and then Is_Visible_Child_Unit (U2) + then + if Is_Generic_Instance (P) + and then Nkind (Decl1) = N_Package_Declaration + and then Generic_Parent (Specification (Decl1)) = P2 + then + Error_Msg_N ("illegal with_clause", With_Clause); + Error_Msg_N + ("\child unit has visible homograph" & + " (RM 8.3(26), 10.1.1(19))", + With_Clause); + exit; + + elsif Is_Generic_Instance (P2) + and then Nkind (Decl2) = N_Package_Declaration + and then Generic_Parent (Specification (Decl2)) = P + then + -- With_clause for child unit of instance appears before + -- in the context. We want to place the error message on + -- it, not on the generic child unit itself. + + declare + Prev_Clause : Node_Id; + + begin + Prev_Clause := First (List_Containing (With_Clause)); + while Entity (Name (Prev_Clause)) /= U2 loop + Next (Prev_Clause); + end loop; + + pragma Assert (Present (Prev_Clause)); + Error_Msg_N ("illegal with_clause", Prev_Clause); + Error_Msg_N + ("\child unit has visible homograph" & + " (RM 8.3(26), 10.1.1(19))", + Prev_Clause); + exit; + end; + end if; + end if; + + U2 := Homonym (U2); + end loop; + end; + end if; + end Install_Withed_Unit; + + ------------------- + -- Is_Child_Spec -- + ------------------- + + function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean is + K : constant Node_Kind := Nkind (Lib_Unit); + + begin + return (K in N_Generic_Declaration or else + K in N_Generic_Instantiation or else + K in N_Generic_Renaming_Declaration or else + K = N_Package_Declaration or else + K = N_Package_Renaming_Declaration or else + K = N_Subprogram_Declaration or else + K = N_Subprogram_Renaming_Declaration) + and then Present (Parent_Spec (Lib_Unit)); + end Is_Child_Spec; + + ------------------------------------ + -- Is_Legal_Shadow_Entity_In_Body -- + ------------------------------------ + + function Is_Legal_Shadow_Entity_In_Body (T : Entity_Id) return Boolean is + C_Unit : constant Node_Id := Cunit (Current_Sem_Unit); + begin + return Nkind (Unit (C_Unit)) = N_Package_Body + and then + Has_With_Clause + (C_Unit, Cunit_Entity (Get_Source_Unit (Non_Limited_View (T)))); + end Is_Legal_Shadow_Entity_In_Body; + + ----------------------- + -- Load_Needed_Body -- + ----------------------- + + -- N is a generic unit named in a with clause, or else it is a unit that + -- contains a generic unit or an inlined function. In order to perform an + -- instantiation, the body of the unit must be present. If the unit itself + -- is generic, we assume that an instantiation follows, and load & analyze + -- the body unconditionally. This forces analysis of the spec as well. + + -- If the unit is not generic, but contains a generic unit, it is loaded on + -- demand, at the point of instantiation (see ch12). + + procedure Load_Needed_Body + (N : Node_Id; + OK : out Boolean; + Do_Analyze : Boolean := True) + is + Body_Name : Unit_Name_Type; + Unum : Unit_Number_Type; + + Save_Style_Check : constant Boolean := Opt.Style_Check; + -- The loading and analysis is done with style checks off + + begin + if not GNAT_Mode then + Style_Check := False; + end if; + + Body_Name := Get_Body_Name (Get_Unit_Name (Unit (N))); + Unum := + Load_Unit + (Load_Name => Body_Name, + Required => False, + Subunit => False, + Error_Node => N, + Renamings => True); + + if Unum = No_Unit then + OK := False; + + else + Compiler_State := Analyzing; -- reset after load + + if not Fatal_Error (Unum) or else Try_Semantics then + if Debug_Flag_L then + Write_Str ("*** Loaded generic body"); + Write_Eol; + end if; + + if Do_Analyze then + Semantics (Cunit (Unum)); + end if; + end if; + + OK := True; + end if; + + Style_Check := Save_Style_Check; + end Load_Needed_Body; + + ------------------------- + -- Build_Limited_Views -- + ------------------------- + + procedure Build_Limited_Views (N : Node_Id) is + Unum : constant Unit_Number_Type := Get_Source_Unit (Library_Unit (N)); + P : constant Entity_Id := Cunit_Entity (Unum); + + Spec : Node_Id; -- To denote a package specification + Lim_Typ : Entity_Id; -- To denote shadow entities + Comp_Typ : Entity_Id; -- To denote real entities + + Lim_Header : Entity_Id; -- Package entity + Last_Lim_E : Entity_Id := Empty; -- Last limited entity built + Last_Pub_Lim_E : Entity_Id; -- To set the first private entity + + procedure Decorate_Incomplete_Type (E : Entity_Id; Scop : Entity_Id); + -- Add attributes of an incomplete type to a shadow entity. The same + -- attributes are placed on the real entity, so that gigi receives + -- a consistent view. + + procedure Decorate_Package_Specification (P : Entity_Id); + -- Add attributes of a package entity to the entity in a package + -- declaration + + procedure Decorate_Tagged_Type + (Loc : Source_Ptr; + T : Entity_Id; + Scop : Entity_Id); + -- Set basic attributes of tagged type T, including its class_wide type. + -- The parameters Loc, Scope are used to decorate the class_wide type. + + procedure Build_Chain (Scope : Entity_Id; First_Decl : Node_Id); + -- Construct list of shadow entities and attach it to entity of + -- package that is mentioned in a limited_with clause. + + function New_Internal_Shadow_Entity + (Kind : Entity_Kind; + Sloc_Value : Source_Ptr; + Id_Char : Character) return Entity_Id; + -- Build a new internal entity and append it to the list of shadow + -- entities available through the limited-header + + ----------------- + -- Build_Chain -- + ----------------- + + procedure Build_Chain (Scope : Entity_Id; First_Decl : Node_Id) is + Analyzed_Unit : constant Boolean := Analyzed (Cunit (Unum)); + Is_Tagged : Boolean; + Decl : Node_Id; + + begin + Decl := First_Decl; + while Present (Decl) loop + + -- For each library_package_declaration in the environment, there + -- is an implicit declaration of a *limited view* of that library + -- package. The limited view of a package contains: + + -- * For each nested package_declaration, a declaration of the + -- limited view of that package, with the same defining- + -- program-unit name. + + -- * For each type_declaration in the visible part, an incomplete + -- type-declaration with the same defining_identifier, whose + -- completion is the type_declaration. If the type_declaration + -- is tagged, then the incomplete_type_declaration is tagged + -- incomplete. + + -- The partial view is tagged if the declaration has the + -- explicit keyword, or else if it is a type extension, both + -- of which can be ascertained syntactically. + + if Nkind (Decl) = N_Full_Type_Declaration then + Is_Tagged := + (Nkind (Type_Definition (Decl)) = N_Record_Definition + and then Tagged_Present (Type_Definition (Decl))) + or else + (Nkind (Type_Definition (Decl)) = N_Derived_Type_Definition + and then + Present + (Record_Extension_Part (Type_Definition (Decl)))); + + Comp_Typ := Defining_Identifier (Decl); + + if not Analyzed_Unit then + if Is_Tagged then + Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope); + else + Decorate_Incomplete_Type (Comp_Typ, Scope); + end if; + end if; + + -- Create shadow entity for type + + Lim_Typ := + New_Internal_Shadow_Entity + (Kind => Ekind (Comp_Typ), + Sloc_Value => Sloc (Comp_Typ), + Id_Char => 'Z'); + + Set_Chars (Lim_Typ, Chars (Comp_Typ)); + Set_Parent (Lim_Typ, Parent (Comp_Typ)); + Set_From_With_Type (Lim_Typ); + + if Is_Tagged then + Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope); + else + Decorate_Incomplete_Type (Lim_Typ, Scope); + end if; + + Set_Non_Limited_View (Lim_Typ, Comp_Typ); + + elsif Nkind_In (Decl, N_Private_Type_Declaration, + N_Incomplete_Type_Declaration, + N_Task_Type_Declaration, + N_Protected_Type_Declaration) + then + Comp_Typ := Defining_Identifier (Decl); + + Is_Tagged := + Nkind_In (Decl, N_Private_Type_Declaration, + N_Incomplete_Type_Declaration) + and then Tagged_Present (Decl); + + if not Analyzed_Unit then + if Is_Tagged then + Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope); + else + Decorate_Incomplete_Type (Comp_Typ, Scope); + end if; + end if; + + Lim_Typ := + New_Internal_Shadow_Entity + (Kind => Ekind (Comp_Typ), + Sloc_Value => Sloc (Comp_Typ), + Id_Char => 'Z'); + + Set_Chars (Lim_Typ, Chars (Comp_Typ)); + Set_Parent (Lim_Typ, Parent (Comp_Typ)); + Set_From_With_Type (Lim_Typ); + + if Is_Tagged then + Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope); + else + Decorate_Incomplete_Type (Lim_Typ, Scope); + end if; + + Set_Non_Limited_View (Lim_Typ, Comp_Typ); + + elsif Nkind (Decl) = N_Private_Extension_Declaration then + Comp_Typ := Defining_Identifier (Decl); + + if not Analyzed_Unit then + Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope); + end if; + + -- Create shadow entity for type + + Lim_Typ := + New_Internal_Shadow_Entity + (Kind => Ekind (Comp_Typ), + Sloc_Value => Sloc (Comp_Typ), + Id_Char => 'Z'); + + Set_Chars (Lim_Typ, Chars (Comp_Typ)); + Set_Parent (Lim_Typ, Parent (Comp_Typ)); + Set_From_With_Type (Lim_Typ); + + Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope); + Set_Non_Limited_View (Lim_Typ, Comp_Typ); + + elsif Nkind (Decl) = N_Package_Declaration then + + -- Local package + + declare + Spec : constant Node_Id := Specification (Decl); + + begin + Comp_Typ := Defining_Unit_Name (Spec); + + if not Analyzed (Cunit (Unum)) then + Decorate_Package_Specification (Comp_Typ); + Set_Scope (Comp_Typ, Scope); + end if; + + Lim_Typ := + New_Internal_Shadow_Entity + (Kind => Ekind (Comp_Typ), + Sloc_Value => Sloc (Comp_Typ), + Id_Char => 'Z'); + + Decorate_Package_Specification (Lim_Typ); + Set_Scope (Lim_Typ, Scope); + + Set_Chars (Lim_Typ, Chars (Comp_Typ)); + Set_Parent (Lim_Typ, Parent (Comp_Typ)); + Set_From_With_Type (Lim_Typ); + + -- Note: The non_limited_view attribute is not used + -- for local packages. + + Build_Chain + (Scope => Lim_Typ, + First_Decl => First (Visible_Declarations (Spec))); + end; + end if; + + Next (Decl); + end loop; + end Build_Chain; + + ------------------------------ + -- Decorate_Incomplete_Type -- + ------------------------------ + + procedure Decorate_Incomplete_Type (E : Entity_Id; Scop : Entity_Id) is + begin + Set_Ekind (E, E_Incomplete_Type); + Set_Scope (E, Scop); + Set_Etype (E, E); + Set_Is_First_Subtype (E, True); + Set_Stored_Constraint (E, No_Elist); + Set_Full_View (E, Empty); + Init_Size_Align (E); + end Decorate_Incomplete_Type; + + -------------------------- + -- Decorate_Tagged_Type -- + -------------------------- + + procedure Decorate_Tagged_Type + (Loc : Source_Ptr; + T : Entity_Id; + Scop : Entity_Id) + is + CW : Entity_Id; + + begin + Decorate_Incomplete_Type (T, Scop); + Set_Is_Tagged_Type (T); + + -- Build corresponding class_wide type, if not previously done + + -- Note: The class-wide entity is shared by the limited-view + -- and the full-view. + + if No (Class_Wide_Type (T)) then + CW := Make_Temporary (Loc, 'S'); + + -- Set parent to be the same as the parent of the tagged type. + -- We need a parent field set, and it is supposed to point to + -- the declaration of the type. The tagged type declaration + -- essentially declares two separate types, the tagged type + -- itself and the corresponding class-wide type, so it is + -- reasonable for the parent fields to point to the declaration + -- in both cases. + + Set_Parent (CW, Parent (T)); + + -- Set remaining fields of classwide type + + Set_Ekind (CW, E_Class_Wide_Type); + Set_Etype (CW, T); + Set_Scope (CW, Scop); + Set_Is_Tagged_Type (CW); + Set_Is_First_Subtype (CW, True); + Init_Size_Align (CW); + Set_Has_Unknown_Discriminants (CW, True); + Set_Class_Wide_Type (CW, CW); + Set_Equivalent_Type (CW, Empty); + Set_From_With_Type (CW, From_With_Type (T)); + + -- Link type to its class-wide type + + Set_Class_Wide_Type (T, CW); + end if; + end Decorate_Tagged_Type; + + ------------------------------------ + -- Decorate_Package_Specification -- + ------------------------------------ + + procedure Decorate_Package_Specification (P : Entity_Id) is + begin + -- Place only the most basic attributes + + Set_Ekind (P, E_Package); + Set_Etype (P, Standard_Void_Type); + end Decorate_Package_Specification; + + -------------------------------- + -- New_Internal_Shadow_Entity -- + -------------------------------- + + function New_Internal_Shadow_Entity + (Kind : Entity_Kind; + Sloc_Value : Source_Ptr; + Id_Char : Character) return Entity_Id + is + E : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char); + + begin + Set_Ekind (E, Kind); + Set_Is_Internal (E, True); + + if Kind in Type_Kind then + Init_Size_Align (E); + end if; + + Append_Entity (E, Lim_Header); + Last_Lim_E := E; + return E; + end New_Internal_Shadow_Entity; + + -- Start of processing for Build_Limited_Views + + begin + pragma Assert (Limited_Present (N)); + + -- A library_item mentioned in a limited_with_clause is a package + -- declaration, not a subprogram declaration, generic declaration, + -- generic instantiation, or package renaming declaration. + + case Nkind (Unit (Library_Unit (N))) is + when N_Package_Declaration => + null; + + when N_Subprogram_Declaration => + Error_Msg_N ("subprograms not allowed in " + & "limited with_clauses", N); + return; + + when N_Generic_Package_Declaration | + N_Generic_Subprogram_Declaration => + Error_Msg_N ("generics not allowed in " + & "limited with_clauses", N); + return; + + when N_Generic_Instantiation => + Error_Msg_N ("generic instantiations not allowed in " + & "limited with_clauses", N); + return; + + when N_Generic_Renaming_Declaration => + Error_Msg_N ("generic renamings not allowed in " + & "limited with_clauses", N); + return; + + when N_Subprogram_Renaming_Declaration => + Error_Msg_N ("renamed subprograms not allowed in " + & "limited with_clauses", N); + return; + + when N_Package_Renaming_Declaration => + Error_Msg_N ("renamed packages not allowed in " + & "limited with_clauses", N); + return; + + when others => + raise Program_Error; + end case; + + -- Check if the chain is already built + + Spec := Specification (Unit (Library_Unit (N))); + + if Limited_View_Installed (Spec) then + return; + end if; + + Set_Ekind (P, E_Package); + + -- Build the header of the limited_view + + Lim_Header := Make_Temporary (Sloc (N), 'Z'); + Set_Ekind (Lim_Header, E_Package); + Set_Is_Internal (Lim_Header); + Set_Limited_View (P, Lim_Header); + + -- Create the auxiliary chain. All the shadow entities are appended to + -- the list of entities of the limited-view header + + Build_Chain + (Scope => P, + First_Decl => First (Visible_Declarations (Spec))); + + -- Save the last built shadow entity. It is needed later to set the + -- reference to the first shadow entity in the private part + + Last_Pub_Lim_E := Last_Lim_E; + + -- Ada 2005 (AI-262): Add the limited view of the private declarations + -- Required to give support to limited-private-with clauses + + Build_Chain (Scope => P, + First_Decl => First (Private_Declarations (Spec))); + + if Last_Pub_Lim_E /= Empty then + Set_First_Private_Entity + (Lim_Header, Next_Entity (Last_Pub_Lim_E)); + else + Set_First_Private_Entity + (Lim_Header, First_Entity (P)); + end if; + + Set_Limited_View_Installed (Spec); + end Build_Limited_Views; + + ------------------------------- + -- Check_Body_Needed_For_SAL -- + ------------------------------- + + procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id) is + + function Entity_Needs_Body (E : Entity_Id) return Boolean; + -- Determine whether use of entity E might require the presence of its + -- body. For a package this requires a recursive traversal of all nested + -- declarations. + + --------------------------- + -- Entity_Needed_For_SAL -- + --------------------------- + + function Entity_Needs_Body (E : Entity_Id) return Boolean is + Ent : Entity_Id; + + begin + if Is_Subprogram (E) + and then Has_Pragma_Inline (E) + then + return True; + + elsif Ekind_In (E, E_Generic_Function, E_Generic_Procedure) then + return True; + + elsif Ekind (E) = E_Generic_Package + and then + Nkind (Unit_Declaration_Node (E)) = N_Generic_Package_Declaration + and then Present (Corresponding_Body (Unit_Declaration_Node (E))) + then + return True; + + elsif Ekind (E) = E_Package + and then Nkind (Unit_Declaration_Node (E)) = N_Package_Declaration + and then Present (Corresponding_Body (Unit_Declaration_Node (E))) + then + Ent := First_Entity (E); + while Present (Ent) loop + if Entity_Needs_Body (Ent) then + return True; + end if; + + Next_Entity (Ent); + end loop; + + return False; + + else + return False; + end if; + end Entity_Needs_Body; + + -- Start of processing for Check_Body_Needed_For_SAL + + begin + if Ekind (Unit_Name) = E_Generic_Package + and then Nkind (Unit_Declaration_Node (Unit_Name)) = + N_Generic_Package_Declaration + and then + Present (Corresponding_Body (Unit_Declaration_Node (Unit_Name))) + then + Set_Body_Needed_For_SAL (Unit_Name); + + elsif Ekind_In (Unit_Name, E_Generic_Procedure, E_Generic_Function) then + Set_Body_Needed_For_SAL (Unit_Name); + + elsif Is_Subprogram (Unit_Name) + and then Nkind (Unit_Declaration_Node (Unit_Name)) = + N_Subprogram_Declaration + and then Has_Pragma_Inline (Unit_Name) + then + Set_Body_Needed_For_SAL (Unit_Name); + + elsif Ekind (Unit_Name) = E_Subprogram_Body then + Check_Body_Needed_For_SAL + (Corresponding_Spec (Unit_Declaration_Node (Unit_Name))); + + elsif Ekind (Unit_Name) = E_Package + and then Entity_Needs_Body (Unit_Name) + then + Set_Body_Needed_For_SAL (Unit_Name); + + elsif Ekind (Unit_Name) = E_Package_Body + and then Nkind (Unit_Declaration_Node (Unit_Name)) = N_Package_Body + then + Check_Body_Needed_For_SAL + (Corresponding_Spec (Unit_Declaration_Node (Unit_Name))); + end if; + end Check_Body_Needed_For_SAL; + + -------------------- + -- Remove_Context -- + -------------------- + + procedure Remove_Context (N : Node_Id) is + Lib_Unit : constant Node_Id := Unit (N); + + begin + -- If this is a child unit, first remove the parent units + + if Is_Child_Spec (Lib_Unit) then + Remove_Parents (Lib_Unit); + end if; + + Remove_Context_Clauses (N); + end Remove_Context; + + ---------------------------- + -- Remove_Context_Clauses -- + ---------------------------- + + procedure Remove_Context_Clauses (N : Node_Id) is + Item : Node_Id; + Unit_Name : Entity_Id; + + begin + -- Ada 2005 (AI-50217): We remove the context clauses in two phases: + -- limited-views first and regular-views later (to maintain the + -- stack model). + + -- First Phase: Remove limited_with context clauses + + Item := First (Context_Items (N)); + while Present (Item) loop + + -- We are interested only in with clauses which got installed + -- on entry. + + if Nkind (Item) = N_With_Clause + and then Limited_Present (Item) + and then Limited_View_Installed (Item) + then + Remove_Limited_With_Clause (Item); + end if; + + Next (Item); + end loop; + + -- Second Phase: Loop through context items and undo regular + -- with_clauses and use_clauses. + + Item := First (Context_Items (N)); + while Present (Item) loop + + -- We are interested only in with clauses which got installed on + -- entry, as indicated by their Context_Installed flag set + + if Nkind (Item) = N_With_Clause + and then Limited_Present (Item) + and then Limited_View_Installed (Item) + then + null; + + elsif Nkind (Item) = N_With_Clause + and then Context_Installed (Item) + then + -- Remove items from one with'ed unit + + Unit_Name := Entity (Name (Item)); + Remove_Unit_From_Visibility (Unit_Name); + Set_Context_Installed (Item, False); + + elsif Nkind (Item) = N_Use_Package_Clause then + End_Use_Package (Item); + + elsif Nkind (Item) = N_Use_Type_Clause then + End_Use_Type (Item); + end if; + + Next (Item); + end loop; + end Remove_Context_Clauses; + + -------------------------------- + -- Remove_Limited_With_Clause -- + -------------------------------- + + procedure Remove_Limited_With_Clause (N : Node_Id) is + P_Unit : constant Entity_Id := Unit (Library_Unit (N)); + E : Entity_Id; + P : Entity_Id; + Lim_Header : Entity_Id; + Lim_Typ : Entity_Id; + Prev : Entity_Id; + + begin + pragma Assert (Limited_View_Installed (N)); + + -- In case of limited with_clause on subprograms, generics, instances, + -- or renamings, the corresponding error was previously posted and we + -- have nothing to do here. + + if Nkind (P_Unit) /= N_Package_Declaration then + return; + end if; + + P := Defining_Unit_Name (Specification (P_Unit)); + + -- Handle child packages + + if Nkind (P) = N_Defining_Program_Unit_Name then + P := Defining_Identifier (P); + end if; + + if Debug_Flag_I then + Write_Str ("remove limited view of "); + Write_Name (Chars (P)); + Write_Str (" from visibility"); + Write_Eol; + end if; + + -- Prepare the removal of the shadow entities from visibility. The first + -- element of the limited view is a header (an E_Package entity) that is + -- used to reference the first shadow entity in the private part of the + -- package + + Lim_Header := Limited_View (P); + Lim_Typ := First_Entity (Lim_Header); + + -- Remove package and shadow entities from visibility if it has not + -- been analyzed + + if not Analyzed (P_Unit) then + Unchain (P); + Set_Is_Immediately_Visible (P, False); + + while Present (Lim_Typ) loop + Unchain (Lim_Typ); + Next_Entity (Lim_Typ); + end loop; + + -- Otherwise this package has already appeared in the closure and its + -- shadow entities must be replaced by its real entities. This code + -- must be kept synchronized with the complementary code in Install + -- Limited_Withed_Unit. + + else + -- Real entities that are type or subtype declarations were hidden + -- from visibility at the point of installation of the limited-view. + -- Now we recover the previous value of the hidden attribute. + + E := First_Entity (P); + while Present (E) and then E /= First_Private_Entity (P) loop + if Is_Type (E) then + Set_Is_Hidden (E, Was_Hidden (E)); + end if; + + Next_Entity (E); + end loop; + + while Present (Lim_Typ) + and then Lim_Typ /= First_Private_Entity (Lim_Header) + loop + -- Nested packages and child units were not unchained + + if Ekind (Lim_Typ) /= E_Package + and then not Is_Child_Unit (Non_Limited_View (Lim_Typ)) + then + -- If the package has incomplete types, the limited view of the + -- incomplete type is in fact never visible (AI05-129) but we + -- have created a shadow entity E1 for it, that points to E2, + -- a non-limited incomplete type. This in turn has a full view + -- E3 that is the full declaration. There is a corresponding + -- shadow entity E4. When reinstalling the non-limited view, + -- E2 must become the current entity and E3 must be ignored. + + E := Non_Limited_View (Lim_Typ); + + if Present (Current_Entity (E)) + and then Ekind (Current_Entity (E)) = E_Incomplete_Type + and then Full_View (Current_Entity (E)) = E + then + + -- Lim_Typ is the limited view of a full type declaration + -- that has a previous incomplete declaration, i.e. E3 from + -- the previous description. Nothing to insert. + + null; + + else + pragma Assert (not In_Chain (E)); + + Prev := Current_Entity (Lim_Typ); + + if Prev = Lim_Typ then + Set_Current_Entity (E); + + else + while Present (Prev) + and then Homonym (Prev) /= Lim_Typ + loop + Prev := Homonym (Prev); + end loop; + + if Present (Prev) then + Set_Homonym (Prev, E); + end if; + end if; + + -- Preserve structure of homonym chain + + Set_Homonym (E, Homonym (Lim_Typ)); + end if; + end if; + + Next_Entity (Lim_Typ); + end loop; + end if; + + -- Indicate that the limited view of the package is not installed + + Set_From_With_Type (P, False); + Set_Limited_View_Installed (N, False); + end Remove_Limited_With_Clause; + + -------------------- + -- Remove_Parents -- + -------------------- + + procedure Remove_Parents (Lib_Unit : Node_Id) is + P : Node_Id; + P_Name : Entity_Id; + P_Spec : Node_Id := Empty; + E : Entity_Id; + Vis : constant Boolean := + Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility; + + begin + if Is_Child_Spec (Lib_Unit) then + P_Spec := Parent_Spec (Lib_Unit); + + elsif Nkind (Lib_Unit) = N_Package_Body + and then Nkind (Original_Node (Lib_Unit)) = N_Package_Instantiation + then + P_Spec := Parent_Spec (Original_Node (Lib_Unit)); + end if; + + if Present (P_Spec) then + P := Unit (P_Spec); + P_Name := Get_Parent_Entity (P); + Remove_Context_Clauses (P_Spec); + End_Package_Scope (P_Name); + Set_Is_Immediately_Visible (P_Name, Vis); + + -- Remove from visibility the siblings as well, which are directly + -- visible while the parent is in scope. + + E := First_Entity (P_Name); + while Present (E) loop + if Is_Child_Unit (E) then + Set_Is_Immediately_Visible (E, False); + end if; + + Next_Entity (E); + end loop; + + Set_In_Package_Body (P_Name, False); + + -- This is the recursive call to remove the context of any higher + -- level parent. This recursion ensures that all parents are removed + -- in the reverse order of their installation. + + Remove_Parents (P); + end if; + end Remove_Parents; + + --------------------------------- + -- Remove_Private_With_Clauses -- + --------------------------------- + + procedure Remove_Private_With_Clauses (Comp_Unit : Node_Id) is + Item : Node_Id; + + function In_Regular_With_Clause (E : Entity_Id) return Boolean; + -- Check whether a given unit appears in a regular with_clause. Used to + -- determine whether a private_with_clause, implicit or explicit, should + -- be ignored. + + ---------------------------- + -- In_Regular_With_Clause -- + ---------------------------- + + function In_Regular_With_Clause (E : Entity_Id) return Boolean + is + Item : Node_Id; + + begin + Item := First (Context_Items (Comp_Unit)); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then Entity (Name (Item)) = E + and then not Private_Present (Item) + then + return True; + end if; + Next (Item); + end loop; + + return False; + end In_Regular_With_Clause; + + -- Start of processing for Remove_Private_With_Clauses + + begin + Item := First (Context_Items (Comp_Unit)); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then Private_Present (Item) + then + -- If private_with_clause is redundant, remove it from context, + -- as a small optimization to subsequent handling of private_with + -- clauses in other nested packages. + + if In_Regular_With_Clause (Entity (Name (Item))) then + declare + Nxt : constant Node_Id := Next (Item); + begin + Remove (Item); + Item := Nxt; + end; + + elsif Limited_Present (Item) then + if not Limited_View_Installed (Item) then + Remove_Limited_With_Clause (Item); + end if; + + Next (Item); + + else + Remove_Unit_From_Visibility (Entity (Name (Item))); + Set_Context_Installed (Item, False); + Next (Item); + end if; + + else + Next (Item); + end if; + end loop; + end Remove_Private_With_Clauses; + + --------------------------------- + -- Remove_Unit_From_Visibility -- + --------------------------------- + + procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id) is + P : constant Entity_Id := Scope (Unit_Name); + + begin + if Debug_Flag_I then + Write_Str ("remove unit "); + Write_Name (Chars (Unit_Name)); + Write_Str (" from visibility"); + Write_Eol; + end if; + + if P /= Standard_Standard then + Set_Is_Visible_Child_Unit (Unit_Name, False); + end if; + + Set_Is_Potentially_Use_Visible (Unit_Name, False); + Set_Is_Immediately_Visible (Unit_Name, False); + end Remove_Unit_From_Visibility; + + -------- + -- sm -- + -------- + + procedure sm is + begin + null; + end sm; + + ------------- + -- Unchain -- + ------------- + + procedure Unchain (E : Entity_Id) is + Prev : Entity_Id; + + begin + Prev := Current_Entity (E); + + if No (Prev) then + return; + + elsif Prev = E then + Set_Name_Entity_Id (Chars (E), Homonym (E)); + + else + while Present (Prev) + and then Homonym (Prev) /= E + loop + Prev := Homonym (Prev); + end loop; + + if Present (Prev) then + Set_Homonym (Prev, Homonym (E)); + end if; + end if; + + if Debug_Flag_I then + Write_Str (" (homonym) unchain "); + Write_Name (Chars (E)); + Write_Eol; + end if; + end Unchain; + +end Sem_Ch10; diff --git a/gcc/ada/sem_ch10.ads b/gcc/ada/sem_ch10.ads new file mode 100644 index 000000000..6eb7fab5c --- /dev/null +++ b/gcc/ada/sem_ch10.ads @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 1 0 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Types; use Types; +package Sem_Ch10 is + procedure Analyze_Compilation_Unit (N : Node_Id); + procedure Analyze_With_Clause (N : Node_Id); + procedure Analyze_Subprogram_Body_Stub (N : Node_Id); + procedure Analyze_Package_Body_Stub (N : Node_Id); + procedure Analyze_Task_Body_Stub (N : Node_Id); + procedure Analyze_Protected_Body_Stub (N : Node_Id); + procedure Analyze_Subunit (N : Node_Id); + + procedure Install_Context (N : Node_Id); + -- Installs the entities from the context clause of the given compilation + -- unit into the visibility chains. This is done before analyzing a unit. + -- For a child unit, install context of parents as well. + + procedure Install_Private_With_Clauses (P : Entity_Id); + -- Install the private with_clauses of a compilation unit, when compiling + -- its private part, compiling a private child unit, or compiling the + -- private declarations of a public child unit. + + function Is_Legal_Shadow_Entity_In_Body (T : Entity_Id) return Boolean; + -- Assuming that type T is an incomplete type coming from a limited with + -- view, determine whether the package where T resides is imported through + -- a regular with clause in the current package body. + + procedure Remove_Context (N : Node_Id); + -- Removes the entities from the context clause of the given compilation + -- unit from the visibility chains. This is done on exit from a unit as + -- part of cleaning up the visibility chains for the caller. A special + -- case is that the call from the Main_Unit can be ignored, since at the + -- end of the main unit the visibility table won't be needed in any case. + -- For a child unit, remove parents and their context as well. + + procedure Remove_Private_With_Clauses (Comp_Unit : Node_Id); + -- The private_with_clauses of a compilation unit are visible in the + -- private part of a nested package, even if this package appears in + -- the visible part of the enclosing compilation unit. This Ada 2005 + -- rule imposes extra steps in order to install/remove the private_with + -- clauses of an enclosing unit. + + procedure Load_Needed_Body + (N : Node_Id; + OK : out Boolean; + Do_Analyze : Boolean := True); + -- Load and analyze the body of a context unit that is generic, or that + -- contains generic units or inlined units. The body becomes part of the + -- semantic dependency set of the unit that needs it. The returned result + -- in OK is True if the load is successful, and False if the requested file + -- cannot be found. If the flag Do_Analyze is false, the unit is loaded and + -- parsed only. This allows a selective analysis in some inlining cases + -- where a full analysis would lead so circularities in the back-end. + +end Sem_Ch10; diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb new file mode 100644 index 000000000..da7e05e32 --- /dev/null +++ b/gcc/ada/sem_ch11.adb @@ -0,0 +1,653 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 1 1 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Aspects; use Aspects; +with Atree; use Atree; +with Checks; use Checks; +with Einfo; use Einfo; +with Errout; use Errout; +with Lib; use Lib; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Ch5; use Sem_Ch5; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch13; use Sem_Ch13; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Sinfo; use Sinfo; +with Stand; use Stand; +with Uintp; use Uintp; + +package body Sem_Ch11 is + + ----------------------------------- + -- Analyze_Exception_Declaration -- + ----------------------------------- + + procedure Analyze_Exception_Declaration (N : Node_Id) is + Id : constant Entity_Id := Defining_Identifier (N); + PF : constant Boolean := Is_Pure (Current_Scope); + begin + Generate_Definition (Id); + Enter_Name (Id); + Set_Ekind (Id, E_Exception); + Set_Exception_Code (Id, Uint_0); + Set_Etype (Id, Standard_Exception_Type); + Set_Is_Statically_Allocated (Id); + Set_Is_Pure (Id, PF); + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); + end Analyze_Exception_Declaration; + + -------------------------------- + -- Analyze_Exception_Handlers -- + -------------------------------- + + procedure Analyze_Exception_Handlers (L : List_Id) is + Handler : Node_Id; + Choice : Entity_Id; + Id : Node_Id; + H_Scope : Entity_Id := Empty; + + procedure Check_Duplication (Id : Node_Id); + -- Iterate through the identifiers in each handler to find duplicates + + function Others_Present return Boolean; + -- Returns True if others handler is present + + ----------------------- + -- Check_Duplication -- + ----------------------- + + procedure Check_Duplication (Id : Node_Id) is + Handler : Node_Id; + Id1 : Node_Id; + Id_Entity : Entity_Id := Entity (Id); + + begin + if Present (Renamed_Entity (Id_Entity)) then + Id_Entity := Renamed_Entity (Id_Entity); + end if; + + Handler := First_Non_Pragma (L); + while Present (Handler) loop + Id1 := First (Exception_Choices (Handler)); + while Present (Id1) loop + + -- Only check against the exception choices which precede + -- Id in the handler, since the ones that follow Id have not + -- been analyzed yet and will be checked in a subsequent call. + + if Id = Id1 then + return; + + elsif Nkind (Id1) /= N_Others_Choice + and then + (Id_Entity = Entity (Id1) + or else (Id_Entity = Renamed_Entity (Entity (Id1)))) + then + if Handler /= Parent (Id) then + Error_Msg_Sloc := Sloc (Id1); + Error_Msg_NE + ("exception choice duplicates &#", Id, Id1); + + else + if Ada_Version = Ada_83 + and then Comes_From_Source (Id) + then + Error_Msg_N + ("(Ada 83): duplicate exception choice&", Id); + end if; + end if; + end if; + + Next_Non_Pragma (Id1); + end loop; + + Next (Handler); + end loop; + end Check_Duplication; + + -------------------- + -- Others_Present -- + -------------------- + + function Others_Present return Boolean is + H : Node_Id; + + begin + H := First (L); + while Present (H) loop + if Nkind (H) /= N_Pragma + and then Nkind (First (Exception_Choices (H))) = N_Others_Choice + then + return True; + end if; + + Next (H); + end loop; + + return False; + end Others_Present; + + -- Start of processing for Analyze_Exception_Handlers + + begin + Handler := First (L); + Check_Restriction (No_Exceptions, Handler); + Check_Restriction (No_Exception_Handlers, Handler); + + -- Kill current remembered values, since we don't know where we were + -- when the exception was raised. + + Kill_Current_Values; + + -- Loop through handlers (which can include pragmas) + + while Present (Handler) loop + + -- If pragma just analyze it + + if Nkind (Handler) = N_Pragma then + Analyze (Handler); + + -- Otherwise we have a real exception handler + + else + -- Deal with choice parameter. The exception handler is a + -- declarative part for the choice parameter, so it constitutes a + -- scope for visibility purposes. We create an entity to denote + -- the whole exception part, and use it as the scope of all the + -- choices, which may even have the same name without conflict. + -- This scope plays no other role in expansion or code generation. + + Choice := Choice_Parameter (Handler); + + if Present (Choice) then + Set_Local_Raise_Not_OK (Handler); + + if Comes_From_Source (Choice) then + Check_Restriction (No_Exception_Propagation, Choice); + end if; + + if No (H_Scope) then + H_Scope := + New_Internal_Entity + (E_Block, Current_Scope, Sloc (Choice), 'E'); + end if; + + Push_Scope (H_Scope); + Set_Etype (H_Scope, Standard_Void_Type); + + -- Set the Finalization Chain entity to Error means that it + -- should not be used at that level but the parent one should + -- be used instead. + + -- ??? this usage needs documenting in Einfo/Exp_Ch7 ??? + -- ??? using Error for this non-error condition is nasty ??? + + Set_Finalization_Chain_Entity (H_Scope, Error); + + Enter_Name (Choice); + Set_Ekind (Choice, E_Variable); + + if RTE_Available (RE_Exception_Occurrence) then + Set_Etype (Choice, RTE (RE_Exception_Occurrence)); + end if; + + Generate_Definition (Choice); + + -- Indicate that choice has an initial value, since in effect + -- this field is assigned an initial value by the exception. + -- We also consider that it is modified in the source. + + Set_Has_Initial_Value (Choice, True); + Set_Never_Set_In_Source (Choice, False); + end if; + + Id := First (Exception_Choices (Handler)); + while Present (Id) loop + if Nkind (Id) = N_Others_Choice then + if Present (Next (Id)) + or else Present (Next (Handler)) + or else Present (Prev (Id)) + then + Error_Msg_N ("OTHERS must appear alone and last", Id); + end if; + + else + Analyze (Id); + + -- In most cases the choice has already been analyzed in + -- Analyze_Handled_Statement_Sequence, in order to expand + -- local handlers. This advance analysis does not take into + -- account the case in which a choice has the same name as + -- the choice parameter of the handler, which may hide an + -- outer exception. This pathological case appears in ACATS + -- B80001_3.adb, and requires an explicit check to verify + -- that the id is not hidden. + + if not Is_Entity_Name (Id) + or else Ekind (Entity (Id)) /= E_Exception + or else + (Nkind (Id) = N_Identifier + and then Chars (Id) = Chars (Choice)) + then + Error_Msg_N ("exception name expected", Id); + + else + -- Emit a warning at the declaration level when a local + -- exception is never raised explicitly. + + if Warn_On_Redundant_Constructs + and then not Is_Raised (Entity (Id)) + and then Scope (Entity (Id)) = Current_Scope + then + Error_Msg_NE + ("?exception & is never raised", Entity (Id), Id); + end if; + + if Present (Renamed_Entity (Entity (Id))) then + if Entity (Id) = Standard_Numeric_Error then + Check_Restriction (No_Obsolescent_Features, Id); + + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("Numeric_Error is an " & + "obsolescent feature (RM J.6(1))?", Id); + Error_Msg_N + ("\use Constraint_Error instead?", Id); + end if; + end if; + end if; + + Check_Duplication (Id); + + -- Check for exception declared within generic formal + -- package (which is illegal, see RM 11.2(8)) + + declare + Ent : Entity_Id := Entity (Id); + Scop : Entity_Id; + + begin + if Present (Renamed_Entity (Ent)) then + Ent := Renamed_Entity (Ent); + end if; + + Scop := Scope (Ent); + while Scop /= Standard_Standard + and then Ekind (Scop) = E_Package + loop + if Nkind (Declaration_Node (Scop)) = + N_Package_Specification + and then + Nkind (Original_Node (Parent + (Declaration_Node (Scop)))) = + N_Formal_Package_Declaration + then + Error_Msg_NE + ("exception& is declared in " & + "generic formal package", Id, Ent); + Error_Msg_N + ("\and therefore cannot appear in " & + "handler (RM 11.2(8))", Id); + exit; + + -- If the exception is declared in an inner + -- instance, nothing else to check. + + elsif Is_Generic_Instance (Scop) then + exit; + end if; + + Scop := Scope (Scop); + end loop; + end; + end if; + end if; + + Next (Id); + end loop; + + -- Check for redundant handler (has only raise statement) and is + -- either an others handler, or is a specific handler when no + -- others handler is present. + + if Warn_On_Redundant_Constructs + and then List_Length (Statements (Handler)) = 1 + and then Nkind (First (Statements (Handler))) = N_Raise_Statement + and then No (Name (First (Statements (Handler)))) + and then (not Others_Present + or else Nkind (First (Exception_Choices (Handler))) = + N_Others_Choice) + then + Error_Msg_N + ("useless handler contains only a reraise statement?", + Handler); + end if; + + -- Now analyze the statements of this handler + + Analyze_Statements (Statements (Handler)); + + -- If a choice was present, we created a special scope for it, + -- so this is where we pop that special scope to get rid of it. + + if Present (Choice) then + End_Scope; + end if; + end if; + + Next (Handler); + end loop; + end Analyze_Exception_Handlers; + + -------------------------------- + -- Analyze_Handled_Statements -- + -------------------------------- + + procedure Analyze_Handled_Statements (N : Node_Id) is + Handlers : constant List_Id := Exception_Handlers (N); + Handler : Node_Id; + Choice : Node_Id; + + begin + if Present (Handlers) then + Kill_All_Checks; + end if; + + -- We are now going to analyze the statements and then the exception + -- handlers. We certainly need to do things in this order to get the + -- proper sequential semantics for various warnings. + + -- However, there is a glitch. When we process raise statements, an + -- optimization is to look for local handlers and specialize the code + -- in this case. + + -- In order to detect if a handler is matching, we must have at least + -- analyzed the choices in the proper scope so that proper visibility + -- analysis is performed. Hence we analyze just the choices first, + -- before we analyze the statement sequence. + + Handler := First_Non_Pragma (Handlers); + while Present (Handler) loop + Choice := First_Non_Pragma (Exception_Choices (Handler)); + while Present (Choice) loop + Analyze (Choice); + Next_Non_Pragma (Choice); + end loop; + + Next_Non_Pragma (Handler); + end loop; + + -- Analyze statements in sequence + + Analyze_Statements (Statements (N)); + + -- If the current scope is a subprogram, then this is the right place to + -- check for hanging useless assignments from the statement sequence of + -- the subprogram body. + + if Is_Subprogram (Current_Scope) then + Warn_On_Useless_Assignments (Current_Scope); + end if; + + -- Deal with handlers or AT END proc + + if Present (Handlers) then + Analyze_Exception_Handlers (Handlers); + elsif Present (At_End_Proc (N)) then + Analyze (At_End_Proc (N)); + end if; + end Analyze_Handled_Statements; + + ----------------------------- + -- Analyze_Raise_Statement -- + ----------------------------- + + procedure Analyze_Raise_Statement (N : Node_Id) is + Exception_Id : constant Node_Id := Name (N); + Exception_Name : Entity_Id := Empty; + P : Node_Id; + + begin + Check_Unreachable_Code (N); + + -- Check exception restrictions on the original source + + if Comes_From_Source (N) then + Check_Restriction (No_Exceptions, N); + end if; + + -- Check for useless assignment to OUT or IN OUT scalar immediately + -- preceding the raise. Right now we only look at assignment statements, + -- we could do more. + + if Is_List_Member (N) then + declare + P : Node_Id; + L : Node_Id; + + begin + P := Prev (N); + + if Present (P) + and then Nkind (P) = N_Assignment_Statement + then + L := Name (P); + + if Is_Scalar_Type (Etype (L)) + and then Is_Entity_Name (L) + and then Is_Formal (Entity (L)) + then + Error_Msg_N + ("?assignment to pass-by-copy formal may have no effect", + P); + Error_Msg_N + ("\?RAISE statement may result in abnormal return" & + " (RM 6.4.1(17))", P); + end if; + end if; + end; + end if; + + -- Reraise statement + + if No (Exception_Id) then + P := Parent (N); + while not Nkind_In (P, N_Exception_Handler, + N_Subprogram_Body, + N_Package_Body, + N_Task_Body, + N_Entry_Body) + loop + P := Parent (P); + end loop; + + if Nkind (P) /= N_Exception_Handler then + Error_Msg_N + ("reraise statement must appear directly in a handler", N); + + -- If a handler has a reraise, it cannot be the target of a local + -- raise (goto optimization is impossible), and if the no exception + -- propagation restriction is set, this is a violation. + + else + Set_Local_Raise_Not_OK (P); + + -- Do not check the restriction if the reraise statement is part + -- of the code generated for an AT-END handler. That's because + -- if the restriction is actually active, we never generate this + -- raise anyway, so the apparent violation is bogus. + + if not From_At_End (N) then + Check_Restriction (No_Exception_Propagation, N); + end if; + end if; + + -- Normal case with exception id present + + else + Analyze (Exception_Id); + + if Is_Entity_Name (Exception_Id) then + Exception_Name := Entity (Exception_Id); + end if; + + if No (Exception_Name) + or else Ekind (Exception_Name) /= E_Exception + then + Error_Msg_N + ("exception name expected in raise statement", Exception_Id); + else + Set_Is_Raised (Exception_Name); + end if; + + -- Deal with RAISE WITH case + + if Present (Expression (N)) then + Check_Compiler_Unit (Expression (N)); + Analyze_And_Resolve (Expression (N), Standard_String); + end if; + end if; + + -- Check obsolescent use of Numeric_Error + + if Exception_Name = Standard_Numeric_Error then + Check_Restriction (No_Obsolescent_Features, Exception_Id); + end if; + + -- Kill last assignment indication + + Kill_Current_Values (Last_Assignment_Only => True); + end Analyze_Raise_Statement; + + ----------------------------- + -- Analyze_Raise_xxx_Error -- + ----------------------------- + + -- Normally, the Etype is already set (when this node is used within + -- an expression, since it is copied from the node which it rewrites). + -- If this node is used in a statement context, then we set the type + -- Standard_Void_Type. This is used both by Gigi and by the front end + -- to distinguish the statement use and the subexpression use. + + -- The only other required processing is to take care of the Condition + -- field if one is present. + + procedure Analyze_Raise_xxx_Error (N : Node_Id) is + + function Same_Expression (C1, C2 : Node_Id) return Boolean; + -- It often occurs that two identical raise statements are generated in + -- succession (for example when dynamic elaboration checks take place on + -- separate expressions in a call). If the two statements are identical + -- according to the simple criterion that follows, the raise is + -- converted into a null statement. + + --------------------- + -- Same_Expression -- + --------------------- + + function Same_Expression (C1, C2 : Node_Id) return Boolean is + begin + if No (C1) and then No (C2) then + return True; + + elsif Is_Entity_Name (C1) and then Is_Entity_Name (C2) then + return Entity (C1) = Entity (C2); + + elsif Nkind (C1) /= Nkind (C2) then + return False; + + elsif Nkind (C1) in N_Unary_Op then + return Same_Expression (Right_Opnd (C1), Right_Opnd (C2)); + + elsif Nkind (C1) in N_Binary_Op then + return Same_Expression (Left_Opnd (C1), Left_Opnd (C2)) + and then Same_Expression (Right_Opnd (C1), Right_Opnd (C2)); + + elsif Nkind (C1) = N_Null then + return True; + + else + return False; + end if; + end Same_Expression; + + -- Start of processing for Analyze_Raise_xxx_Error + + begin + if No (Etype (N)) then + Set_Etype (N, Standard_Void_Type); + end if; + + if Present (Condition (N)) then + Analyze_And_Resolve (Condition (N), Standard_Boolean); + end if; + + -- Deal with static cases in obvious manner + + if Nkind (Condition (N)) = N_Identifier then + if Entity (Condition (N)) = Standard_True then + Set_Condition (N, Empty); + + elsif Entity (Condition (N)) = Standard_False then + Rewrite (N, Make_Null_Statement (Sloc (N))); + end if; + end if; + + -- Remove duplicate raise statements. Note that the previous one may + -- already have been removed as well. + + if not Comes_From_Source (N) + and then Nkind (N) /= N_Null_Statement + and then Is_List_Member (N) + and then Present (Prev (N)) + and then Nkind (N) = Nkind (Original_Node (Prev (N))) + and then Same_Expression + (Condition (N), Condition (Original_Node (Prev (N)))) + then + Rewrite (N, Make_Null_Statement (Sloc (N))); + end if; + end Analyze_Raise_xxx_Error; + + ----------------------------- + -- Analyze_Subprogram_Info -- + ----------------------------- + + procedure Analyze_Subprogram_Info (N : Node_Id) is + begin + Set_Etype (N, RTE (RE_Code_Loc)); + end Analyze_Subprogram_Info; + +end Sem_Ch11; diff --git a/gcc/ada/sem_ch11.ads b/gcc/ada/sem_ch11.ads new file mode 100644 index 000000000..63544bd0e --- /dev/null +++ b/gcc/ada/sem_ch11.ads @@ -0,0 +1,37 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 1 1 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Types; use Types; +package Sem_Ch11 is + procedure Analyze_Exception_Declaration (N : Node_Id); + procedure Analyze_Handled_Statements (N : Node_Id); + procedure Analyze_Raise_Statement (N : Node_Id); + procedure Analyze_Raise_xxx_Error (N : Node_Id); + procedure Analyze_Subprogram_Info (N : Node_Id); + + procedure Analyze_Exception_Handlers (L : List_Id); + -- Analyze list of exception handlers of a handled statement sequence + +end Sem_Ch11; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb new file mode 100644 index 000000000..80eacf660 --- /dev/null +++ b/gcc/ada/sem_ch12.adb @@ -0,0 +1,12533 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 1 2 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Aspects; use Aspects; +with Atree; use Atree; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Expander; use Expander; +with Fname; use Fname; +with Fname.UF; use Fname.UF; +with Freeze; use Freeze; +with Hostparm; +with Itypes; use Itypes; +with Lib; use Lib; +with Lib.Load; use Lib.Load; +with Lib.Xref; use Lib.Xref; +with Nlists; use Nlists; +with Namet; use Namet; +with Nmake; use Nmake; +with Opt; use Opt; +with Rident; use Rident; +with Restrict; use Restrict; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Cat; use Sem_Cat; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch7; use Sem_Ch7; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch10; use Sem_Ch10; +with Sem_Ch13; use Sem_Ch13; +with Sem_Disp; use Sem_Disp; +with Sem_Elab; use Sem_Elab; +with Sem_Elim; use Sem_Elim; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Sinfo.CN; use Sinfo.CN; +with Sinput; use Sinput; +with Sinput.L; use Sinput.L; +with Snames; use Snames; +with Stringt; use Stringt; +with Uname; use Uname; +with Table; +with Tbuild; use Tbuild; +with Uintp; use Uintp; +with Urealp; use Urealp; + +with GNAT.HTable; + +package body Sem_Ch12 is + + ---------------------------------------------------------- + -- Implementation of Generic Analysis and Instantiation -- + ---------------------------------------------------------- + + -- GNAT implements generics by macro expansion. No attempt is made to share + -- generic instantiations (for now). Analysis of a generic definition does + -- not perform any expansion action, but the expander must be called on the + -- tree for each instantiation, because the expansion may of course depend + -- on the generic actuals. All of this is best achieved as follows: + -- + -- a) Semantic analysis of a generic unit is performed on a copy of the + -- tree for the generic unit. All tree modifications that follow analysis + -- do not affect the original tree. Links are kept between the original + -- tree and the copy, in order to recognize non-local references within + -- the generic, and propagate them to each instance (recall that name + -- resolution is done on the generic declaration: generics are not really + -- macros!). This is summarized in the following diagram: + + -- .-----------. .----------. + -- | semantic |<--------------| generic | + -- | copy | | unit | + -- | |==============>| | + -- |___________| global |__________| + -- references | | | + -- | | | + -- .-----|--|. + -- | .-----|---. + -- | | .----------. + -- | | | generic | + -- |__| | | + -- |__| instance | + -- |__________| + + -- b) Each instantiation copies the original tree, and inserts into it a + -- series of declarations that describe the mapping between generic formals + -- and actuals. For example, a generic In OUT parameter is an object + -- renaming of the corresponding actual, etc. Generic IN parameters are + -- constant declarations. + + -- c) In order to give the right visibility for these renamings, we use + -- a different scheme for package and subprogram instantiations. For + -- packages, the list of renamings is inserted into the package + -- specification, before the visible declarations of the package. The + -- renamings are analyzed before any of the text of the instance, and are + -- thus visible at the right place. Furthermore, outside of the instance, + -- the generic parameters are visible and denote their corresponding + -- actuals. + + -- For subprograms, we create a container package to hold the renamings + -- and the subprogram instance itself. Analysis of the package makes the + -- renaming declarations visible to the subprogram. After analyzing the + -- package, the defining entity for the subprogram is touched-up so that + -- it appears declared in the current scope, and not inside the container + -- package. + + -- If the instantiation is a compilation unit, the container package is + -- given the same name as the subprogram instance. This ensures that + -- the elaboration procedure called by the binder, using the compilation + -- unit name, calls in fact the elaboration procedure for the package. + + -- Not surprisingly, private types complicate this approach. By saving in + -- the original generic object the non-local references, we guarantee that + -- the proper entities are referenced at the point of instantiation. + -- However, for private types, this by itself does not insure that the + -- proper VIEW of the entity is used (the full type may be visible at the + -- point of generic definition, but not at instantiation, or vice-versa). + -- In order to reference the proper view, we special-case any reference + -- to private types in the generic object, by saving both views, one in + -- the generic and one in the semantic copy. At time of instantiation, we + -- check whether the two views are consistent, and exchange declarations if + -- necessary, in order to restore the correct visibility. Similarly, if + -- the instance view is private when the generic view was not, we perform + -- the exchange. After completing the instantiation, we restore the + -- current visibility. The flag Has_Private_View marks identifiers in the + -- the generic unit that require checking. + + -- Visibility within nested generic units requires special handling. + -- Consider the following scheme: + + -- type Global is ... -- outside of generic unit. + -- generic ... + -- package Outer is + -- ... + -- type Semi_Global is ... -- global to inner. + + -- generic ... -- 1 + -- procedure inner (X1 : Global; X2 : Semi_Global); + + -- procedure in2 is new inner (...); -- 4 + -- end Outer; + + -- package New_Outer is new Outer (...); -- 2 + -- procedure New_Inner is new New_Outer.Inner (...); -- 3 + + -- The semantic analysis of Outer captures all occurrences of Global. + -- The semantic analysis of Inner (at 1) captures both occurrences of + -- Global and Semi_Global. + + -- At point 2 (instantiation of Outer), we also produce a generic copy + -- of Inner, even though Inner is, at that point, not being instantiated. + -- (This is just part of the semantic analysis of New_Outer). + + -- Critically, references to Global within Inner must be preserved, while + -- references to Semi_Global should not preserved, because they must now + -- resolve to an entity within New_Outer. To distinguish between these, we + -- use a global variable, Current_Instantiated_Parent, which is set when + -- performing a generic copy during instantiation (at 2). This variable is + -- used when performing a generic copy that is not an instantiation, but + -- that is nested within one, as the occurrence of 1 within 2. The analysis + -- of a nested generic only preserves references that are global to the + -- enclosing Current_Instantiated_Parent. We use the Scope_Depth value to + -- determine whether a reference is external to the given parent. + + -- The instantiation at point 3 requires no special treatment. The method + -- works as well for further nestings of generic units, but of course the + -- variable Current_Instantiated_Parent must be stacked because nested + -- instantiations can occur, e.g. the occurrence of 4 within 2. + + -- The instantiation of package and subprogram bodies is handled in a + -- similar manner, except that it is delayed until after semantic + -- analysis is complete. In this fashion complex cross-dependencies + -- between several package declarations and bodies containing generics + -- can be compiled which otherwise would diagnose spurious circularities. + + -- For example, it is possible to compile two packages A and B that + -- have the following structure: + + -- package A is package B is + -- generic ... generic ... + -- package G_A is package G_B is + + -- with B; with A; + -- package body A is package body B is + -- package N_B is new G_B (..) package N_A is new G_A (..) + + -- The table Pending_Instantiations in package Inline is used to keep + -- track of body instantiations that are delayed in this manner. Inline + -- handles the actual calls to do the body instantiations. This activity + -- is part of Inline, since the processing occurs at the same point, and + -- for essentially the same reason, as the handling of inlined routines. + + ---------------------------------------------- + -- Detection of Instantiation Circularities -- + ---------------------------------------------- + + -- If we have a chain of instantiations that is circular, this is static + -- error which must be detected at compile time. The detection of these + -- circularities is carried out at the point that we insert a generic + -- instance spec or body. If there is a circularity, then the analysis of + -- the offending spec or body will eventually result in trying to load the + -- same unit again, and we detect this problem as we analyze the package + -- instantiation for the second time. + + -- At least in some cases after we have detected the circularity, we get + -- into trouble if we try to keep going. The following flag is set if a + -- circularity is detected, and used to abandon compilation after the + -- messages have been posted. + + Circularity_Detected : Boolean := False; + -- This should really be reset on encountering a new main unit, but in + -- practice we are not using multiple main units so it is not critical. + + ------------------------------------------------- + -- Formal packages and partial parametrization -- + ------------------------------------------------- + + -- When compiling a generic, a formal package is a local instantiation. If + -- declared with a box, its generic formals are visible in the enclosing + -- generic. If declared with a partial list of actuals, those actuals that + -- are defaulted (covered by an Others clause, or given an explicit box + -- initialization) are also visible in the enclosing generic, while those + -- that have a corresponding actual are not. + + -- In our source model of instantiation, the same visibility must be + -- present in the spec and body of an instance: the names of the formals + -- that are defaulted must be made visible within the instance, and made + -- invisible (hidden) after the instantiation is complete, so that they + -- are not accessible outside of the instance. + + -- In a generic, a formal package is treated like a special instantiation. + -- Our Ada95 compiler handled formals with and without box in different + -- ways. With partial parametrization, we use a single model for both. + -- We create a package declaration that consists of the specification of + -- the generic package, and a set of declarations that map the actuals + -- into local renamings, just as we do for bona fide instantiations. For + -- defaulted parameters and formals with a box, we copy directly the + -- declarations of the formal into this local package. The result is a + -- a package whose visible declarations may include generic formals. This + -- package is only used for type checking and visibility analysis, and + -- never reaches the back-end, so it can freely violate the placement + -- rules for generic formal declarations. + + -- The list of declarations (renamings and copies of formals) is built + -- by Analyze_Associations, just as for regular instantiations. + + -- At the point of instantiation, conformance checking must be applied only + -- to those parameters that were specified in the formal. We perform this + -- checking by creating another internal instantiation, this one including + -- only the renamings and the formals (the rest of the package spec is not + -- relevant to conformance checking). We can then traverse two lists: the + -- list of actuals in the instance that corresponds to the formal package, + -- and the list of actuals produced for this bogus instantiation. We apply + -- the conformance rules to those actuals that are not defaulted (i.e. + -- which still appear as generic formals. + + -- When we compile an instance body we must make the right parameters + -- visible again. The predicate Is_Generic_Formal indicates which of the + -- formals should have its Is_Hidden flag reset. + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Abandon_Instantiation (N : Node_Id); + pragma No_Return (Abandon_Instantiation); + -- Posts an error message "instantiation abandoned" at the indicated node + -- and then raises the exception Instantiation_Error to do it. + + procedure Analyze_Formal_Array_Type + (T : in out Entity_Id; + Def : Node_Id); + -- A formal array type is treated like an array type declaration, and + -- invokes Array_Type_Declaration (sem_ch3) whose first parameter is + -- in-out, because in the case of an anonymous type the entity is + -- actually created in the procedure. + + -- The following procedures treat other kinds of formal parameters + + procedure Analyze_Formal_Derived_Interface_Type + (N : Node_Id; + T : Entity_Id; + Def : Node_Id); + + procedure Analyze_Formal_Derived_Type + (N : Node_Id; + T : Entity_Id; + Def : Node_Id); + + procedure Analyze_Formal_Interface_Type + (N : Node_Id; + T : Entity_Id; + Def : Node_Id); + + -- The following subprograms create abbreviated declarations for formal + -- scalar types. We introduce an anonymous base of the proper class for + -- each of them, and define the formals as constrained first subtypes of + -- their bases. The bounds are expressions that are non-static in the + -- generic. + + procedure Analyze_Formal_Decimal_Fixed_Point_Type + (T : Entity_Id; Def : Node_Id); + procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id); + procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id); + procedure Analyze_Formal_Signed_Integer_Type (T : Entity_Id; Def : Node_Id); + procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id); + procedure Analyze_Formal_Ordinary_Fixed_Point_Type + (T : Entity_Id; Def : Node_Id); + + procedure Analyze_Formal_Private_Type + (N : Node_Id; + T : Entity_Id; + Def : Node_Id); + -- Creates a new private type, which does not require completion + + procedure Analyze_Generic_Formal_Part (N : Node_Id); + + procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id); + -- Create a new access type with the given designated type + + function Analyze_Associations + (I_Node : Node_Id; + Formals : List_Id; + F_Copy : List_Id) return List_Id; + -- At instantiation time, build the list of associations between formals + -- and actuals. Each association becomes a renaming declaration for the + -- formal entity. F_Copy is the analyzed list of formals in the generic + -- copy. It is used to apply legality checks to the actuals. I_Node is the + -- instantiation node itself. + + procedure Analyze_Subprogram_Instantiation + (N : Node_Id; + K : Entity_Kind); + + procedure Build_Instance_Compilation_Unit_Nodes + (N : Node_Id; + Act_Body : Node_Id; + Act_Decl : Node_Id); + -- This procedure is used in the case where the generic instance of a + -- subprogram body or package body is a library unit. In this case, the + -- original library unit node for the generic instantiation must be + -- replaced by the resulting generic body, and a link made to a new + -- compilation unit node for the generic declaration. The argument N is + -- the original generic instantiation. Act_Body and Act_Decl are the body + -- and declaration of the instance (either package body and declaration + -- nodes or subprogram body and declaration nodes depending on the case). + -- On return, the node N has been rewritten with the actual body. + + procedure Check_Access_Definition (N : Node_Id); + -- Subsidiary routine to null exclusion processing. Perform an assertion + -- check on Ada version and the presence of an access definition in N. + + procedure Check_Formal_Packages (P_Id : Entity_Id); + -- Apply the following to all formal packages in generic associations + + procedure Check_Formal_Package_Instance + (Formal_Pack : Entity_Id; + Actual_Pack : Entity_Id); + -- Verify that the actuals of the actual instance match the actuals of + -- the template for a formal package that is not declared with a box. + + procedure Check_Forward_Instantiation (Decl : Node_Id); + -- If the generic is a local entity and the corresponding body has not + -- been seen yet, flag enclosing packages to indicate that it will be + -- elaborated after the generic body. Subprograms declared in the same + -- package cannot be inlined by the front-end because front-end inlining + -- requires a strict linear order of elaboration. + + procedure Check_Hidden_Child_Unit + (N : Node_Id; + Gen_Unit : Entity_Id; + Act_Decl_Id : Entity_Id); + -- If the generic unit is an implicit child instance within a parent + -- instance, we need to make an explicit test that it is not hidden by + -- a child instance of the same name and parent. + + procedure Check_Generic_Actuals + (Instance : Entity_Id; + Is_Formal_Box : Boolean); + -- Similar to previous one. Check the actuals in the instantiation, + -- whose views can change between the point of instantiation and the point + -- of instantiation of the body. In addition, mark the generic renamings + -- as generic actuals, so that they are not compatible with other actuals. + -- Recurse on an actual that is a formal package whose declaration has + -- a box. + + function Contains_Instance_Of + (Inner : Entity_Id; + Outer : Entity_Id; + N : Node_Id) return Boolean; + -- Inner is instantiated within the generic Outer. Check whether Inner + -- directly or indirectly contains an instance of Outer or of one of its + -- parents, in the case of a subunit. Each generic unit holds a list of + -- the entities instantiated within (at any depth). This procedure + -- determines whether the set of such lists contains a cycle, i.e. an + -- illegal circular instantiation. + + function Denotes_Formal_Package + (Pack : Entity_Id; + On_Exit : Boolean := False; + Instance : Entity_Id := Empty) return Boolean; + -- Returns True if E is a formal package of an enclosing generic, or + -- the actual for such a formal in an enclosing instantiation. If such + -- a package is used as a formal in an nested generic, or as an actual + -- in a nested instantiation, the visibility of ITS formals should not + -- be modified. When called from within Restore_Private_Views, the flag + -- On_Exit is true, to indicate that the search for a possible enclosing + -- instance should ignore the current one. In that case Instance denotes + -- the declaration for which this is an actual. This declaration may be + -- an instantiation in the source, or the internal instantiation that + -- corresponds to the actual for a formal package. + + function Find_Actual_Type + (Typ : Entity_Id; + Gen_Type : Entity_Id) return Entity_Id; + -- When validating the actual types of a child instance, check whether + -- the formal is a formal type of the parent unit, and retrieve the current + -- actual for it. Typ is the entity in the analyzed formal type declaration + -- (component or index type of an array type, or designated type of an + -- access formal) and Gen_Type is the enclosing analyzed formal array + -- or access type. The desired actual may be a formal of a parent, or may + -- be declared in a formal package of a parent. In both cases it is a + -- generic actual type because it appears within a visible instance. + -- Finally, it may be declared in a parent unit without being a formal + -- of that unit, in which case it must be retrieved by visibility. + -- Ambiguities may still arise if two homonyms are declared in two formal + -- packages, and the prefix of the formal type may be needed to resolve + -- the ambiguity in the instance ??? + + function In_Same_Declarative_Part + (F_Node : Node_Id; + Inst : Node_Id) return Boolean; + -- True if the instantiation Inst and the given freeze_node F_Node appear + -- within the same declarative part, ignoring subunits, but with no inter- + -- vening subprograms or concurrent units. If true, the freeze node + -- of the instance can be placed after the freeze node of the parent, + -- which it itself an instance. + + function In_Main_Context (E : Entity_Id) return Boolean; + -- Check whether an instantiation is in the context of the main unit. + -- Used to determine whether its body should be elaborated to allow + -- front-end inlining. + + procedure Set_Instance_Env + (Gen_Unit : Entity_Id; + Act_Unit : Entity_Id); + -- Save current instance on saved environment, to be used to determine + -- the global status of entities in nested instances. Part of Save_Env. + -- called after verifying that the generic unit is legal for the instance, + -- The procedure also examines whether the generic unit is a predefined + -- unit, in order to set configuration switches accordingly. As a result + -- the procedure must be called after analyzing and freezing the actuals. + + procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id); + -- Associate analyzed generic parameter with corresponding + -- instance. Used for semantic checks at instantiation time. + + function Has_Been_Exchanged (E : Entity_Id) return Boolean; + -- Traverse the Exchanged_Views list to see if a type was private + -- and has already been flipped during this phase of instantiation. + + procedure Hide_Current_Scope; + -- When instantiating a generic child unit, the parent context must be + -- present, but the instance and all entities that may be generated + -- must be inserted in the current scope. We leave the current scope + -- on the stack, but make its entities invisible to avoid visibility + -- problems. This is reversed at the end of the instantiation. This is + -- not done for the instantiation of the bodies, which only require the + -- instances of the generic parents to be in scope. + + procedure Install_Body + (Act_Body : Node_Id; + N : Node_Id; + Gen_Body : Node_Id; + Gen_Decl : Node_Id); + -- If the instantiation happens textually before the body of the generic, + -- the instantiation of the body must be analyzed after the generic body, + -- and not at the point of instantiation. Such early instantiations can + -- happen if the generic and the instance appear in a package declaration + -- because the generic body can only appear in the corresponding package + -- body. Early instantiations can also appear if generic, instance and + -- body are all in the declarative part of a subprogram or entry. Entities + -- of packages that are early instantiations are delayed, and their freeze + -- node appears after the generic body. + + procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id); + -- Insert freeze node at the end of the declarative part that includes the + -- instance node N. If N is in the visible part of an enclosing package + -- declaration, the freeze node has to be inserted at the end of the + -- private declarations, if any. + + procedure Freeze_Subprogram_Body + (Inst_Node : Node_Id; + Gen_Body : Node_Id; + Pack_Id : Entity_Id); + -- The generic body may appear textually after the instance, including + -- in the proper body of a stub, or within a different package instance. + -- Given that the instance can only be elaborated after the generic, we + -- place freeze_nodes for the instance and/or for packages that may enclose + -- the instance and the generic, so that the back-end can establish the + -- proper order of elaboration. + + procedure Init_Env; + -- Establish environment for subsequent instantiation. Separated from + -- Save_Env because data-structures for visibility handling must be + -- initialized before call to Check_Generic_Child_Unit. + + procedure Install_Formal_Packages (Par : Entity_Id); + -- Install the visible part of any formal of the parent that is a formal + -- package. Note that for the case of a formal package with a box, this + -- includes the formal part of the formal package (12.7(10/2)). + + procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False); + -- When compiling an instance of a child unit the parent (which is + -- itself an instance) is an enclosing scope that must be made + -- immediately visible. This procedure is also used to install the non- + -- generic parent of a generic child unit when compiling its body, so + -- that full views of types in the parent are made visible. + + procedure Remove_Parent (In_Body : Boolean := False); + -- Reverse effect after instantiation of child is complete + + procedure Inline_Instance_Body + (N : Node_Id; + Gen_Unit : Entity_Id; + Act_Decl : Node_Id); + -- If front-end inlining is requested, instantiate the package body, + -- and preserve the visibility of its compilation unit, to insure + -- that successive instantiations succeed. + + -- The functions Instantiate_XXX perform various legality checks and build + -- the declarations for instantiated generic parameters. In all of these + -- Formal is the entity in the generic unit, Actual is the entity of + -- expression in the generic associations, and Analyzed_Formal is the + -- formal in the generic copy, which contains the semantic information to + -- be used to validate the actual. + + function Instantiate_Object + (Formal : Node_Id; + Actual : Node_Id; + Analyzed_Formal : Node_Id) return List_Id; + + function Instantiate_Type + (Formal : Node_Id; + Actual : Node_Id; + Analyzed_Formal : Node_Id; + Actual_Decls : List_Id) return List_Id; + + function Instantiate_Formal_Subprogram + (Formal : Node_Id; + Actual : Node_Id; + Analyzed_Formal : Node_Id) return Node_Id; + + function Instantiate_Formal_Package + (Formal : Node_Id; + Actual : Node_Id; + Analyzed_Formal : Node_Id) return List_Id; + -- If the formal package is declared with a box, special visibility rules + -- apply to its formals: they are in the visible part of the package. This + -- is true in the declarative region of the formal package, that is to say + -- in the enclosing generic or instantiation. For an instantiation, the + -- parameters of the formal package are made visible in an explicit step. + -- Furthermore, if the actual has a visible USE clause, these formals must + -- be made potentially use-visible as well. On exit from the enclosing + -- instantiation, the reverse must be done. + + -- For a formal package declared without a box, there are conformance rules + -- that apply to the actuals in the generic declaration and the actuals of + -- the actual package in the enclosing instantiation. The simplest way to + -- apply these rules is to repeat the instantiation of the formal package + -- in the context of the enclosing instance, and compare the generic + -- associations of this instantiation with those of the actual package. + -- This internal instantiation only needs to contain the renamings of the + -- formals: the visible and private declarations themselves need not be + -- created. + + -- In Ada 2005, the formal package may be only partially parameterized. + -- In that case the visibility step must make visible those actuals whose + -- corresponding formals were given with a box. A final complication + -- involves inherited operations from formal derived types, which must + -- be visible if the type is. + + function Is_In_Main_Unit (N : Node_Id) return Boolean; + -- Test if given node is in the main unit + + procedure Load_Parent_Of_Generic + (N : Node_Id; + Spec : Node_Id; + Body_Optional : Boolean := False); + -- If the generic appears in a separate non-generic library unit, load the + -- corresponding body to retrieve the body of the generic. N is the node + -- for the generic instantiation, Spec is the generic package declaration. + -- + -- Body_Optional is a flag that indicates that the body is being loaded to + -- ensure that temporaries are generated consistently when there are other + -- instances in the current declarative part that precede the one being + -- loaded. In that case a missing body is acceptable. + + procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id); + -- Add the context clause of the unit containing a generic unit to a + -- compilation unit that is, or contains, an instantiation. + + function Get_Associated_Node (N : Node_Id) return Node_Id; + -- In order to propagate semantic information back from the analyzed copy + -- to the original generic, we maintain links between selected nodes in the + -- generic and their corresponding copies. At the end of generic analysis, + -- the routine Save_Global_References traverses the generic tree, examines + -- the semantic information, and preserves the links to those nodes that + -- contain global information. At instantiation, the information from the + -- associated node is placed on the new copy, so that name resolution is + -- not repeated. + -- + -- Three kinds of source nodes have associated nodes: + -- + -- a) those that can reference (denote) entities, that is identifiers, + -- character literals, expanded_names, operator symbols, operators, + -- and attribute reference nodes. These nodes have an Entity field + -- and are the set of nodes that are in N_Has_Entity. + -- + -- b) aggregates (N_Aggregate and N_Extension_Aggregate) + -- + -- c) selected components (N_Selected_Component) + -- + -- For the first class, the associated node preserves the entity if it is + -- global. If the generic contains nested instantiations, the associated + -- node itself has been recopied, and a chain of them must be followed. + -- + -- For aggregates, the associated node allows retrieval of the type, which + -- may otherwise not appear in the generic. The view of this type may be + -- different between generic and instantiation, and the full view can be + -- installed before the instantiation is analyzed. For aggregates of type + -- extensions, the same view exchange may have to be performed for some of + -- the ancestor types, if their view is private at the point of + -- instantiation. + -- + -- Nodes that are selected components in the parse tree may be rewritten + -- as expanded names after resolution, and must be treated as potential + -- entity holders, which is why they also have an Associated_Node. + -- + -- Nodes that do not come from source, such as freeze nodes, do not appear + -- in the generic tree, and need not have an associated node. + -- + -- The associated node is stored in the Associated_Node field. Note that + -- this field overlaps Entity, which is fine, because the whole point is + -- that we don't need or want the normal Entity field in this situation. + + procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id); + -- Within the generic part, entities in the formal package are + -- visible. To validate subsequent type declarations, indicate + -- the correspondence between the entities in the analyzed formal, + -- and the entities in the actual package. There are three packages + -- involved in the instantiation of a formal package: the parent + -- generic P1 which appears in the generic declaration, the fake + -- instantiation P2 which appears in the analyzed generic, and whose + -- visible entities may be used in subsequent formals, and the actual + -- P3 in the instance. To validate subsequent formals, me indicate + -- that the entities in P2 are mapped into those of P3. The mapping of + -- entities has to be done recursively for nested packages. + + procedure Move_Freeze_Nodes + (Out_Of : Entity_Id; + After : Node_Id; + L : List_Id); + -- Freeze nodes can be generated in the analysis of a generic unit, but + -- will not be seen by the back-end. It is necessary to move those nodes + -- to the enclosing scope if they freeze an outer entity. We place them + -- at the end of the enclosing generic package, which is semantically + -- neutral. + + procedure Preanalyze_Actuals (N : Node_Id); + -- Analyze actuals to perform name resolution. Full resolution is done + -- later, when the expected types are known, but names have to be captured + -- before installing parents of generics, that are not visible for the + -- actuals themselves. + + procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id); + -- Verify that an attribute that appears as the default for a formal + -- subprogram is a function or procedure with the correct profile. + + ------------------------------------------- + -- Data Structures for Generic Renamings -- + ------------------------------------------- + + -- The map Generic_Renamings associates generic entities with their + -- corresponding actuals. Currently used to validate type instances. It + -- will eventually be used for all generic parameters to eliminate the + -- need for overload resolution in the instance. + + type Assoc_Ptr is new Int; + + Assoc_Null : constant Assoc_Ptr := -1; + + type Assoc is record + Gen_Id : Entity_Id; + Act_Id : Entity_Id; + Next_In_HTable : Assoc_Ptr; + end record; + + package Generic_Renamings is new Table.Table + (Table_Component_Type => Assoc, + Table_Index_Type => Assoc_Ptr, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Generic_Renamings"); + + -- Variable to hold enclosing instantiation. When the environment is + -- saved for a subprogram inlining, the corresponding Act_Id is empty. + + Current_Instantiated_Parent : Assoc := (Empty, Empty, Assoc_Null); + + -- Hash table for associations + + HTable_Size : constant := 37; + type HTable_Range is range 0 .. HTable_Size - 1; + + procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr); + function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr; + function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id; + function Hash (F : Entity_Id) return HTable_Range; + + package Generic_Renamings_HTable is new GNAT.HTable.Static_HTable ( + Header_Num => HTable_Range, + Element => Assoc, + Elmt_Ptr => Assoc_Ptr, + Null_Ptr => Assoc_Null, + Set_Next => Set_Next_Assoc, + Next => Next_Assoc, + Key => Entity_Id, + Get_Key => Get_Gen_Id, + Hash => Hash, + Equal => "="); + + Exchanged_Views : Elist_Id; + -- This list holds the private views that have been exchanged during + -- instantiation to restore the visibility of the generic declaration. + -- (see comments above). After instantiation, the current visibility is + -- reestablished by means of a traversal of this list. + + Hidden_Entities : Elist_Id; + -- This list holds the entities of the current scope that are removed + -- from immediate visibility when instantiating a child unit. Their + -- visibility is restored in Remove_Parent. + + -- Because instantiations can be recursive, the following must be saved + -- on entry and restored on exit from an instantiation (spec or body). + -- This is done by the two procedures Save_Env and Restore_Env. For + -- package and subprogram instantiations (but not for the body instances) + -- the action of Save_Env is done in two steps: Init_Env is called before + -- Check_Generic_Child_Unit, because setting the parent instances requires + -- that the visibility data structures be properly initialized. Once the + -- generic is unit is validated, Set_Instance_Env completes Save_Env. + + Parent_Unit_Visible : Boolean := False; + -- Parent_Unit_Visible is used when the generic is a child unit, and + -- indicates whether the ultimate parent of the generic is visible in the + -- instantiation environment. It is used to reset the visibility of the + -- parent at the end of the instantiation (see Remove_Parent). + + Instance_Parent_Unit : Entity_Id := Empty; + -- This records the ultimate parent unit of an instance of a generic + -- child unit and is used in conjunction with Parent_Unit_Visible to + -- indicate the unit to which the Parent_Unit_Visible flag corresponds. + + type Instance_Env is record + Instantiated_Parent : Assoc; + Exchanged_Views : Elist_Id; + Hidden_Entities : Elist_Id; + Current_Sem_Unit : Unit_Number_Type; + Parent_Unit_Visible : Boolean := False; + Instance_Parent_Unit : Entity_Id := Empty; + Switches : Config_Switches_Type; + end record; + + package Instance_Envs is new Table.Table ( + Table_Component_Type => Instance_Env, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 32, + Table_Increment => 100, + Table_Name => "Instance_Envs"); + + procedure Restore_Private_Views + (Pack_Id : Entity_Id; + Is_Package : Boolean := True); + -- Restore the private views of external types, and unmark the generic + -- renamings of actuals, so that they become compatible subtypes again. + -- For subprograms, Pack_Id is the package constructed to hold the + -- renamings. + + procedure Switch_View (T : Entity_Id); + -- Switch the partial and full views of a type and its private + -- dependents (i.e. its subtypes and derived types). + + ------------------------------------ + -- Structures for Error Reporting -- + ------------------------------------ + + Instantiation_Node : Node_Id; + -- Used by subprograms that validate instantiation of formal parameters + -- where there might be no actual on which to place the error message. + -- Also used to locate the instantiation node for generic subunits. + + Instantiation_Error : exception; + -- When there is a semantic error in the generic parameter matching, + -- there is no point in continuing the instantiation, because the + -- number of cascaded errors is unpredictable. This exception aborts + -- the instantiation process altogether. + + S_Adjustment : Sloc_Adjustment; + -- Offset created for each node in an instantiation, in order to keep + -- track of the source position of the instantiation in each of its nodes. + -- A subsequent semantic error or warning on a construct of the instance + -- points to both places: the original generic node, and the point of + -- instantiation. See Sinput and Sinput.L for additional details. + + ------------------------------------------------------------ + -- Data structure for keeping track when inside a Generic -- + ------------------------------------------------------------ + + -- The following table is used to save values of the Inside_A_Generic + -- flag (see spec of Sem) when they are saved by Start_Generic. + + package Generic_Flags is new Table.Table ( + Table_Component_Type => Boolean, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 32, + Table_Increment => 200, + Table_Name => "Generic_Flags"); + + --------------------------- + -- Abandon_Instantiation -- + --------------------------- + + procedure Abandon_Instantiation (N : Node_Id) is + begin + Error_Msg_N ("\instantiation abandoned!", N); + raise Instantiation_Error; + end Abandon_Instantiation; + + -------------------------- + -- Analyze_Associations -- + -------------------------- + + function Analyze_Associations + (I_Node : Node_Id; + Formals : List_Id; + F_Copy : List_Id) return List_Id + is + + Actual_Types : constant Elist_Id := New_Elmt_List; + Assoc : constant List_Id := New_List; + Default_Actuals : constant Elist_Id := New_Elmt_List; + Gen_Unit : constant Entity_Id := + Defining_Entity (Parent (F_Copy)); + + Actuals : List_Id; + Actual : Node_Id; + Formal : Node_Id; + Next_Formal : Node_Id; + Temp_Formal : Node_Id; + Analyzed_Formal : Node_Id; + Match : Node_Id; + Named : Node_Id; + First_Named : Node_Id := Empty; + + Default_Formals : constant List_Id := New_List; + -- If an Others_Choice is present, some of the formals may be defaulted. + -- To simplify the treatment of visibility in an instance, we introduce + -- individual defaults for each such formal. These defaults are + -- appended to the list of associations and replace the Others_Choice. + + Found_Assoc : Node_Id; + -- Association for the current formal being match. Empty if there are + -- no remaining actuals, or if there is no named association with the + -- name of the formal. + + Is_Named_Assoc : Boolean; + Num_Matched : Int := 0; + Num_Actuals : Int := 0; + + Others_Present : Boolean := False; + -- In Ada 2005, indicates partial parametrization of a formal + -- package. As usual an other association must be last in the list. + + function Matching_Actual + (F : Entity_Id; + A_F : Entity_Id) return Node_Id; + -- Find actual that corresponds to a given a formal parameter. If the + -- actuals are positional, return the next one, if any. If the actuals + -- are named, scan the parameter associations to find the right one. + -- A_F is the corresponding entity in the analyzed generic,which is + -- placed on the selector name for ASIS use. + + -- In Ada 2005, a named association may be given with a box, in which + -- case Matching_Actual sets Found_Assoc to the generic association, + -- but return Empty for the actual itself. In this case the code below + -- creates a corresponding declaration for the formal. + + function Partial_Parametrization return Boolean; + -- Ada 2005: if no match is found for a given formal, check if the + -- association for it includes a box, or whether the associations + -- include an Others clause. + + procedure Process_Default (F : Entity_Id); + -- Add a copy of the declaration of generic formal F to the list of + -- associations, and add an explicit box association for F if there + -- is none yet, and the default comes from an Others_Choice. + + procedure Set_Analyzed_Formal; + -- Find the node in the generic copy that corresponds to a given formal. + -- The semantic information on this node is used to perform legality + -- checks on the actuals. Because semantic analysis can introduce some + -- anonymous entities or modify the declaration node itself, the + -- correspondence between the two lists is not one-one. In addition to + -- anonymous types, the presence a formal equality will introduce an + -- implicit declaration for the corresponding inequality. + + --------------------- + -- Matching_Actual -- + --------------------- + + function Matching_Actual + (F : Entity_Id; + A_F : Entity_Id) return Node_Id + is + Prev : Node_Id; + Act : Node_Id; + + begin + Is_Named_Assoc := False; + + -- End of list of purely positional parameters + + if No (Actual) or else Nkind (Actual) = N_Others_Choice then + Found_Assoc := Empty; + Act := Empty; + + -- Case of positional parameter corresponding to current formal + + elsif No (Selector_Name (Actual)) then + Found_Assoc := Actual; + Act := Explicit_Generic_Actual_Parameter (Actual); + Num_Matched := Num_Matched + 1; + Next (Actual); + + -- Otherwise scan list of named actuals to find the one with the + -- desired name. All remaining actuals have explicit names. + + else + Is_Named_Assoc := True; + Found_Assoc := Empty; + Act := Empty; + Prev := Empty; + + while Present (Actual) loop + if Chars (Selector_Name (Actual)) = Chars (F) then + Set_Entity (Selector_Name (Actual), A_F); + Set_Etype (Selector_Name (Actual), Etype (A_F)); + Generate_Reference (A_F, Selector_Name (Actual)); + Found_Assoc := Actual; + Act := Explicit_Generic_Actual_Parameter (Actual); + Num_Matched := Num_Matched + 1; + exit; + end if; + + Prev := Actual; + Next (Actual); + end loop; + + -- Reset for subsequent searches. In most cases the named + -- associations are in order. If they are not, we reorder them + -- to avoid scanning twice the same actual. This is not just a + -- question of efficiency: there may be multiple defaults with + -- boxes that have the same name. In a nested instantiation we + -- insert actuals for those defaults, and cannot rely on their + -- names to disambiguate them. + + if Actual = First_Named then + Next (First_Named); + + elsif Present (Actual) then + Insert_Before (First_Named, Remove_Next (Prev)); + end if; + + Actual := First_Named; + end if; + + if Is_Entity_Name (Act) and then Present (Entity (Act)) then + Set_Used_As_Generic_Actual (Entity (Act)); + end if; + + return Act; + end Matching_Actual; + + ----------------------------- + -- Partial_Parametrization -- + ----------------------------- + + function Partial_Parametrization return Boolean is + begin + return Others_Present + or else (Present (Found_Assoc) and then Box_Present (Found_Assoc)); + end Partial_Parametrization; + + --------------------- + -- Process_Default -- + --------------------- + + procedure Process_Default (F : Entity_Id) is + Loc : constant Source_Ptr := Sloc (I_Node); + F_Id : constant Entity_Id := Defining_Entity (F); + Decl : Node_Id; + Default : Node_Id; + Id : Entity_Id; + + begin + -- Append copy of formal declaration to associations, and create new + -- defining identifier for it. + + Decl := New_Copy_Tree (F); + Id := Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id)); + + if Nkind (F) in N_Formal_Subprogram_Declaration then + Set_Defining_Unit_Name (Specification (Decl), Id); + + else + Set_Defining_Identifier (Decl, Id); + end if; + + Append (Decl, Assoc); + + if No (Found_Assoc) then + Default := + Make_Generic_Association (Loc, + Selector_Name => New_Occurrence_Of (Id, Loc), + Explicit_Generic_Actual_Parameter => Empty); + Set_Box_Present (Default); + Append (Default, Default_Formals); + end if; + end Process_Default; + + ------------------------- + -- Set_Analyzed_Formal -- + ------------------------- + + procedure Set_Analyzed_Formal is + Kind : Node_Kind; + + begin + while Present (Analyzed_Formal) loop + Kind := Nkind (Analyzed_Formal); + + case Nkind (Formal) is + + when N_Formal_Subprogram_Declaration => + exit when Kind in N_Formal_Subprogram_Declaration + and then + Chars + (Defining_Unit_Name (Specification (Formal))) = + Chars + (Defining_Unit_Name (Specification (Analyzed_Formal))); + + when N_Formal_Package_Declaration => + exit when Nkind_In (Kind, N_Formal_Package_Declaration, + N_Generic_Package_Declaration, + N_Package_Declaration); + + when N_Use_Package_Clause | N_Use_Type_Clause => exit; + + when others => + + -- Skip freeze nodes, and nodes inserted to replace + -- unrecognized pragmas. + + exit when + Kind not in N_Formal_Subprogram_Declaration + and then not Nkind_In (Kind, N_Subprogram_Declaration, + N_Freeze_Entity, + N_Null_Statement, + N_Itype_Reference) + and then Chars (Defining_Identifier (Formal)) = + Chars (Defining_Identifier (Analyzed_Formal)); + end case; + + Next (Analyzed_Formal); + end loop; + end Set_Analyzed_Formal; + + -- Start of processing for Analyze_Associations + + begin + Actuals := Generic_Associations (I_Node); + + if Present (Actuals) then + + -- Check for an Others choice, indicating a partial parametrization + -- for a formal package. + + Actual := First (Actuals); + while Present (Actual) loop + if Nkind (Actual) = N_Others_Choice then + Others_Present := True; + + if Present (Next (Actual)) then + Error_Msg_N ("others must be last association", Actual); + end if; + + -- This subprogram is used both for formal packages and for + -- instantiations. For the latter, associations must all be + -- explicit. + + if Nkind (I_Node) /= N_Formal_Package_Declaration + and then Comes_From_Source (I_Node) + then + Error_Msg_N + ("others association not allowed in an instance", + Actual); + end if; + + -- In any case, nothing to do after the others association + + exit; + + elsif Box_Present (Actual) + and then Comes_From_Source (I_Node) + and then Nkind (I_Node) /= N_Formal_Package_Declaration + then + Error_Msg_N + ("box association not allowed in an instance", Actual); + end if; + + Next (Actual); + end loop; + + -- If named associations are present, save first named association + -- (it may of course be Empty) to facilitate subsequent name search. + + First_Named := First (Actuals); + while Present (First_Named) + and then Nkind (First_Named) /= N_Others_Choice + and then No (Selector_Name (First_Named)) + loop + Num_Actuals := Num_Actuals + 1; + Next (First_Named); + end loop; + end if; + + Named := First_Named; + while Present (Named) loop + if Nkind (Named) /= N_Others_Choice + and then No (Selector_Name (Named)) + then + Error_Msg_N ("invalid positional actual after named one", Named); + Abandon_Instantiation (Named); + end if; + + -- A named association may lack an actual parameter, if it was + -- introduced for a default subprogram that turns out to be local + -- to the outer instantiation. + + if Nkind (Named) /= N_Others_Choice + and then Present (Explicit_Generic_Actual_Parameter (Named)) + then + Num_Actuals := Num_Actuals + 1; + end if; + + Next (Named); + end loop; + + if Present (Formals) then + Formal := First_Non_Pragma (Formals); + Analyzed_Formal := First_Non_Pragma (F_Copy); + + if Present (Actuals) then + Actual := First (Actuals); + + -- All formals should have default values + + else + Actual := Empty; + end if; + + while Present (Formal) loop + Set_Analyzed_Formal; + Next_Formal := Next_Non_Pragma (Formal); + + case Nkind (Formal) is + when N_Formal_Object_Declaration => + Match := + Matching_Actual ( + Defining_Identifier (Formal), + Defining_Identifier (Analyzed_Formal)); + + if No (Match) and then Partial_Parametrization then + Process_Default (Formal); + else + Append_List + (Instantiate_Object (Formal, Match, Analyzed_Formal), + Assoc); + end if; + + when N_Formal_Type_Declaration => + Match := + Matching_Actual ( + Defining_Identifier (Formal), + Defining_Identifier (Analyzed_Formal)); + + if No (Match) then + if Partial_Parametrization then + Process_Default (Formal); + + else + Error_Msg_Sloc := Sloc (Gen_Unit); + Error_Msg_NE + ("missing actual&", + Instantiation_Node, + Defining_Identifier (Formal)); + Error_Msg_NE ("\in instantiation of & declared#", + Instantiation_Node, Gen_Unit); + Abandon_Instantiation (Instantiation_Node); + end if; + + else + Analyze (Match); + Append_List + (Instantiate_Type + (Formal, Match, Analyzed_Formal, Assoc), + Assoc); + + -- An instantiation is a freeze point for the actuals, + -- unless this is a rewritten formal package. + + if Nkind (I_Node) /= N_Formal_Package_Declaration then + Append_Elmt (Entity (Match), Actual_Types); + end if; + end if; + + -- A remote access-to-class-wide type must not be an + -- actual parameter for a generic formal of an access + -- type (E.2.2 (17)). + + if Nkind (Analyzed_Formal) = N_Formal_Type_Declaration + and then + Nkind (Formal_Type_Definition (Analyzed_Formal)) = + N_Access_To_Object_Definition + then + Validate_Remote_Access_To_Class_Wide_Type (Match); + end if; + + when N_Formal_Subprogram_Declaration => + Match := + Matching_Actual ( + Defining_Unit_Name (Specification (Formal)), + Defining_Unit_Name (Specification (Analyzed_Formal))); + + -- If the formal subprogram has the same name as another + -- formal subprogram of the generic, then a named + -- association is illegal (12.3(9)). Exclude named + -- associations that are generated for a nested instance. + + if Present (Match) + and then Is_Named_Assoc + and then Comes_From_Source (Found_Assoc) + then + Temp_Formal := First (Formals); + while Present (Temp_Formal) loop + if Nkind (Temp_Formal) in + N_Formal_Subprogram_Declaration + and then Temp_Formal /= Formal + and then + Chars (Selector_Name (Found_Assoc)) = + Chars (Defining_Unit_Name + (Specification (Temp_Formal))) + then + Error_Msg_N + ("name not allowed for overloaded formal", + Found_Assoc); + Abandon_Instantiation (Instantiation_Node); + end if; + + Next (Temp_Formal); + end loop; + end if; + + -- If there is no corresponding actual, this may be case of + -- partial parametrization, or else the formal has a default + -- or a box. + + if No (Match) + and then Partial_Parametrization + then + Process_Default (Formal); + else + Append_To (Assoc, + Instantiate_Formal_Subprogram + (Formal, Match, Analyzed_Formal)); + end if; + + -- If this is a nested generic, preserve default for later + -- instantiations. + + if No (Match) + and then Box_Present (Formal) + then + Append_Elmt + (Defining_Unit_Name (Specification (Last (Assoc))), + Default_Actuals); + end if; + + when N_Formal_Package_Declaration => + Match := + Matching_Actual ( + Defining_Identifier (Formal), + Defining_Identifier (Original_Node (Analyzed_Formal))); + + if No (Match) then + if Partial_Parametrization then + Process_Default (Formal); + + else + Error_Msg_Sloc := Sloc (Gen_Unit); + Error_Msg_NE + ("missing actual&", + Instantiation_Node, Defining_Identifier (Formal)); + Error_Msg_NE ("\in instantiation of & declared#", + Instantiation_Node, Gen_Unit); + + Abandon_Instantiation (Instantiation_Node); + end if; + + else + Analyze (Match); + Append_List + (Instantiate_Formal_Package + (Formal, Match, Analyzed_Formal), + Assoc); + end if; + + -- For use type and use package appearing in the generic part, + -- we have already copied them, so we can just move them where + -- they belong (we mustn't recopy them since this would mess up + -- the Sloc values). + + when N_Use_Package_Clause | + N_Use_Type_Clause => + if Nkind (Original_Node (I_Node)) = + N_Formal_Package_Declaration + then + Append (New_Copy_Tree (Formal), Assoc); + else + Remove (Formal); + Append (Formal, Assoc); + end if; + + when others => + raise Program_Error; + + end case; + + Formal := Next_Formal; + Next_Non_Pragma (Analyzed_Formal); + end loop; + + if Num_Actuals > Num_Matched then + Error_Msg_Sloc := Sloc (Gen_Unit); + + if Present (Selector_Name (Actual)) then + Error_Msg_NE + ("unmatched actual&", + Actual, Selector_Name (Actual)); + Error_Msg_NE ("\in instantiation of& declared#", + Actual, Gen_Unit); + else + Error_Msg_NE + ("unmatched actual in instantiation of& declared#", + Actual, Gen_Unit); + end if; + end if; + + elsif Present (Actuals) then + Error_Msg_N + ("too many actuals in generic instantiation", Instantiation_Node); + end if; + + declare + Elmt : Elmt_Id := First_Elmt (Actual_Types); + begin + while Present (Elmt) loop + Freeze_Before (I_Node, Node (Elmt)); + Next_Elmt (Elmt); + end loop; + end; + + -- If there are default subprograms, normalize the tree by adding + -- explicit associations for them. This is required if the instance + -- appears within a generic. + + declare + Elmt : Elmt_Id; + Subp : Entity_Id; + New_D : Node_Id; + + begin + Elmt := First_Elmt (Default_Actuals); + while Present (Elmt) loop + if No (Actuals) then + Actuals := New_List; + Set_Generic_Associations (I_Node, Actuals); + end if; + + Subp := Node (Elmt); + New_D := + Make_Generic_Association (Sloc (Subp), + Selector_Name => New_Occurrence_Of (Subp, Sloc (Subp)), + Explicit_Generic_Actual_Parameter => + New_Occurrence_Of (Subp, Sloc (Subp))); + Mark_Rewrite_Insertion (New_D); + Append_To (Actuals, New_D); + Next_Elmt (Elmt); + end loop; + end; + + -- If this is a formal package, normalize the parameter list by adding + -- explicit box associations for the formals that are covered by an + -- Others_Choice. + + if not Is_Empty_List (Default_Formals) then + Append_List (Default_Formals, Formals); + end if; + + return Assoc; + end Analyze_Associations; + + ------------------------------- + -- Analyze_Formal_Array_Type -- + ------------------------------- + + procedure Analyze_Formal_Array_Type + (T : in out Entity_Id; + Def : Node_Id) + is + DSS : Node_Id; + + begin + -- Treated like a non-generic array declaration, with additional + -- semantic checks. + + Enter_Name (T); + + if Nkind (Def) = N_Constrained_Array_Definition then + DSS := First (Discrete_Subtype_Definitions (Def)); + while Present (DSS) loop + if Nkind_In (DSS, N_Subtype_Indication, + N_Range, + N_Attribute_Reference) + then + Error_Msg_N ("only a subtype mark is allowed in a formal", DSS); + end if; + + Next (DSS); + end loop; + end if; + + Array_Type_Declaration (T, Def); + Set_Is_Generic_Type (Base_Type (T)); + + if Ekind (Component_Type (T)) = E_Incomplete_Type + and then No (Full_View (Component_Type (T))) + then + Error_Msg_N ("premature usage of incomplete type", Def); + + -- Check that range constraint is not allowed on the component type + -- of a generic formal array type (AARM 12.5.3(3)) + + elsif Is_Internal (Component_Type (T)) + and then Present (Subtype_Indication (Component_Definition (Def))) + and then Nkind (Original_Node + (Subtype_Indication (Component_Definition (Def)))) = + N_Subtype_Indication + then + Error_Msg_N + ("in a formal, a subtype indication can only be " + & "a subtype mark (RM 12.5.3(3))", + Subtype_Indication (Component_Definition (Def))); + end if; + + end Analyze_Formal_Array_Type; + + --------------------------------------------- + -- Analyze_Formal_Decimal_Fixed_Point_Type -- + --------------------------------------------- + + -- As for other generic types, we create a valid type representation with + -- legal but arbitrary attributes, whose values are never considered + -- static. For all scalar types we introduce an anonymous base type, with + -- the same attributes. We choose the corresponding integer type to be + -- Standard_Integer. + + procedure Analyze_Formal_Decimal_Fixed_Point_Type + (T : Entity_Id; + Def : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Def); + Base : constant Entity_Id := + New_Internal_Entity + (E_Decimal_Fixed_Point_Type, + Current_Scope, Sloc (Def), 'G'); + Int_Base : constant Entity_Id := Standard_Integer; + Delta_Val : constant Ureal := Ureal_1; + Digs_Val : constant Uint := Uint_6; + + begin + Enter_Name (T); + + Set_Etype (Base, Base); + Set_Size_Info (Base, Int_Base); + Set_RM_Size (Base, RM_Size (Int_Base)); + Set_First_Rep_Item (Base, First_Rep_Item (Int_Base)); + Set_Digits_Value (Base, Digs_Val); + Set_Delta_Value (Base, Delta_Val); + Set_Small_Value (Base, Delta_Val); + Set_Scalar_Range (Base, + Make_Range (Loc, + Low_Bound => Make_Real_Literal (Loc, Ureal_1), + High_Bound => Make_Real_Literal (Loc, Ureal_1))); + + Set_Is_Generic_Type (Base); + Set_Parent (Base, Parent (Def)); + + Set_Ekind (T, E_Decimal_Fixed_Point_Subtype); + Set_Etype (T, Base); + Set_Size_Info (T, Int_Base); + Set_RM_Size (T, RM_Size (Int_Base)); + Set_First_Rep_Item (T, First_Rep_Item (Int_Base)); + Set_Digits_Value (T, Digs_Val); + Set_Delta_Value (T, Delta_Val); + Set_Small_Value (T, Delta_Val); + Set_Scalar_Range (T, Scalar_Range (Base)); + Set_Is_Constrained (T); + + Check_Restriction (No_Fixed_Point, Def); + end Analyze_Formal_Decimal_Fixed_Point_Type; + + ------------------------------------------- + -- Analyze_Formal_Derived_Interface_Type -- + ------------------------------------------- + + procedure Analyze_Formal_Derived_Interface_Type + (N : Node_Id; + T : Entity_Id; + Def : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Def); + + begin + -- Rewrite as a type declaration of a derived type. This ensures that + -- the interface list and primitive operations are properly captured. + + Rewrite (N, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => T, + Type_Definition => Def)); + Analyze (N); + Set_Is_Generic_Type (T); + end Analyze_Formal_Derived_Interface_Type; + + --------------------------------- + -- Analyze_Formal_Derived_Type -- + --------------------------------- + + procedure Analyze_Formal_Derived_Type + (N : Node_Id; + T : Entity_Id; + Def : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Def); + Unk_Disc : constant Boolean := Unknown_Discriminants_Present (N); + New_N : Node_Id; + + begin + Set_Is_Generic_Type (T); + + if Private_Present (Def) then + New_N := + Make_Private_Extension_Declaration (Loc, + Defining_Identifier => T, + Discriminant_Specifications => Discriminant_Specifications (N), + Unknown_Discriminants_Present => Unk_Disc, + Subtype_Indication => Subtype_Mark (Def), + Interface_List => Interface_List (Def)); + + Set_Abstract_Present (New_N, Abstract_Present (Def)); + Set_Limited_Present (New_N, Limited_Present (Def)); + Set_Synchronized_Present (New_N, Synchronized_Present (Def)); + + else + New_N := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => T, + Discriminant_Specifications => + Discriminant_Specifications (Parent (T)), + Type_Definition => + Make_Derived_Type_Definition (Loc, + Subtype_Indication => Subtype_Mark (Def))); + + Set_Abstract_Present + (Type_Definition (New_N), Abstract_Present (Def)); + Set_Limited_Present + (Type_Definition (New_N), Limited_Present (Def)); + end if; + + Rewrite (N, New_N); + Analyze (N); + + if Unk_Disc then + if not Is_Composite_Type (T) then + Error_Msg_N + ("unknown discriminants not allowed for elementary types", N); + else + Set_Has_Unknown_Discriminants (T); + Set_Is_Constrained (T, False); + end if; + end if; + + -- If the parent type has a known size, so does the formal, which makes + -- legal representation clauses that involve the formal. + + Set_Size_Known_At_Compile_Time + (T, Size_Known_At_Compile_Time (Entity (Subtype_Mark (Def)))); + end Analyze_Formal_Derived_Type; + + ---------------------------------- + -- Analyze_Formal_Discrete_Type -- + ---------------------------------- + + -- The operations defined for a discrete types are those of an enumeration + -- type. The size is set to an arbitrary value, for use in analyzing the + -- generic unit. + + procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id) is + Loc : constant Source_Ptr := Sloc (Def); + Lo : Node_Id; + Hi : Node_Id; + + Base : constant Entity_Id := + New_Internal_Entity + (E_Floating_Point_Type, Current_Scope, Sloc (Def), 'G'); + begin + Enter_Name (T); + Set_Ekind (T, E_Enumeration_Subtype); + Set_Etype (T, Base); + Init_Size (T, 8); + Init_Alignment (T); + Set_Is_Generic_Type (T); + Set_Is_Constrained (T); + + -- For semantic analysis, the bounds of the type must be set to some + -- non-static value. The simplest is to create attribute nodes for those + -- bounds, that refer to the type itself. These bounds are never + -- analyzed but serve as place-holders. + + Lo := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_First, + Prefix => New_Reference_To (T, Loc)); + Set_Etype (Lo, T); + + Hi := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Last, + Prefix => New_Reference_To (T, Loc)); + Set_Etype (Hi, T); + + Set_Scalar_Range (T, + Make_Range (Loc, + Low_Bound => Lo, + High_Bound => Hi)); + + Set_Ekind (Base, E_Enumeration_Type); + Set_Etype (Base, Base); + Init_Size (Base, 8); + Init_Alignment (Base); + Set_Is_Generic_Type (Base); + Set_Scalar_Range (Base, Scalar_Range (T)); + Set_Parent (Base, Parent (Def)); + end Analyze_Formal_Discrete_Type; + + ---------------------------------- + -- Analyze_Formal_Floating_Type -- + --------------------------------- + + procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id) is + Base : constant Entity_Id := + New_Internal_Entity + (E_Floating_Point_Type, Current_Scope, Sloc (Def), 'G'); + + begin + -- The various semantic attributes are taken from the predefined type + -- Float, just so that all of them are initialized. Their values are + -- never used because no constant folding or expansion takes place in + -- the generic itself. + + Enter_Name (T); + Set_Ekind (T, E_Floating_Point_Subtype); + Set_Etype (T, Base); + Set_Size_Info (T, (Standard_Float)); + Set_RM_Size (T, RM_Size (Standard_Float)); + Set_Digits_Value (T, Digits_Value (Standard_Float)); + Set_Scalar_Range (T, Scalar_Range (Standard_Float)); + Set_Is_Constrained (T); + + Set_Is_Generic_Type (Base); + Set_Etype (Base, Base); + Set_Size_Info (Base, (Standard_Float)); + Set_RM_Size (Base, RM_Size (Standard_Float)); + Set_Digits_Value (Base, Digits_Value (Standard_Float)); + Set_Scalar_Range (Base, Scalar_Range (Standard_Float)); + Set_Parent (Base, Parent (Def)); + + Check_Restriction (No_Floating_Point, Def); + end Analyze_Formal_Floating_Type; + + ----------------------------------- + -- Analyze_Formal_Interface_Type;-- + ----------------------------------- + + procedure Analyze_Formal_Interface_Type + (N : Node_Id; + T : Entity_Id; + Def : Node_Id) + is + Loc : constant Source_Ptr := Sloc (N); + New_N : Node_Id; + + begin + New_N := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => T, + Type_Definition => Def); + + Rewrite (N, New_N); + Analyze (N); + Set_Is_Generic_Type (T); + end Analyze_Formal_Interface_Type; + + --------------------------------- + -- Analyze_Formal_Modular_Type -- + --------------------------------- + + procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id) is + begin + -- Apart from their entity kind, generic modular types are treated like + -- signed integer types, and have the same attributes. + + Analyze_Formal_Signed_Integer_Type (T, Def); + Set_Ekind (T, E_Modular_Integer_Subtype); + Set_Ekind (Etype (T), E_Modular_Integer_Type); + + end Analyze_Formal_Modular_Type; + + --------------------------------------- + -- Analyze_Formal_Object_Declaration -- + --------------------------------------- + + procedure Analyze_Formal_Object_Declaration (N : Node_Id) is + E : constant Node_Id := Default_Expression (N); + Id : constant Node_Id := Defining_Identifier (N); + K : Entity_Kind; + T : Node_Id; + + begin + Enter_Name (Id); + + -- Determine the mode of the formal object + + if Out_Present (N) then + K := E_Generic_In_Out_Parameter; + + if not In_Present (N) then + Error_Msg_N ("formal generic objects cannot have mode OUT", N); + end if; + + else + K := E_Generic_In_Parameter; + end if; + + if Present (Subtype_Mark (N)) then + Find_Type (Subtype_Mark (N)); + T := Entity (Subtype_Mark (N)); + + -- Verify that there is no redundant null exclusion + + if Null_Exclusion_Present (N) then + if not Is_Access_Type (T) then + Error_Msg_N + ("null exclusion can only apply to an access type", N); + + elsif Can_Never_Be_Null (T) then + Error_Msg_NE + ("`NOT NULL` not allowed (& already excludes null)", + N, T); + end if; + end if; + + -- Ada 2005 (AI-423): Formal object with an access definition + + else + Check_Access_Definition (N); + T := Access_Definition + (Related_Nod => N, + N => Access_Definition (N)); + end if; + + if Ekind (T) = E_Incomplete_Type then + declare + Error_Node : Node_Id; + + begin + if Present (Subtype_Mark (N)) then + Error_Node := Subtype_Mark (N); + else + Check_Access_Definition (N); + Error_Node := Access_Definition (N); + end if; + + Error_Msg_N ("premature usage of incomplete type", Error_Node); + end; + end if; + + if K = E_Generic_In_Parameter then + + -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals + + if Ada_Version < Ada_2005 and then Is_Limited_Type (T) then + Error_Msg_N + ("generic formal of mode IN must not be of limited type", N); + Explain_Limited_Type (T, N); + end if; + + if Is_Abstract_Type (T) then + Error_Msg_N + ("generic formal of mode IN must not be of abstract type", N); + end if; + + if Present (E) then + Preanalyze_Spec_Expression (E, T); + + if Is_Limited_Type (T) and then not OK_For_Limited_Init (T, E) then + Error_Msg_N + ("initialization not allowed for limited types", E); + Explain_Limited_Type (T, E); + end if; + end if; + + Set_Ekind (Id, K); + Set_Etype (Id, T); + + -- Case of generic IN OUT parameter + + else + -- If the formal has an unconstrained type, construct its actual + -- subtype, as is done for subprogram formals. In this fashion, all + -- its uses can refer to specific bounds. + + Set_Ekind (Id, K); + Set_Etype (Id, T); + + if (Is_Array_Type (T) + and then not Is_Constrained (T)) + or else + (Ekind (T) = E_Record_Type + and then Has_Discriminants (T)) + then + declare + Non_Freezing_Ref : constant Node_Id := + New_Reference_To (Id, Sloc (Id)); + Decl : Node_Id; + + begin + -- Make sure the actual subtype doesn't generate bogus freezing + + Set_Must_Not_Freeze (Non_Freezing_Ref); + Decl := Build_Actual_Subtype (T, Non_Freezing_Ref); + Insert_Before_And_Analyze (N, Decl); + Set_Actual_Subtype (Id, Defining_Identifier (Decl)); + end; + else + Set_Actual_Subtype (Id, T); + end if; + + if Present (E) then + Error_Msg_N + ("initialization not allowed for `IN OUT` formals", N); + end if; + end if; + + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); + end Analyze_Formal_Object_Declaration; + + ---------------------------------------------- + -- Analyze_Formal_Ordinary_Fixed_Point_Type -- + ---------------------------------------------- + + procedure Analyze_Formal_Ordinary_Fixed_Point_Type + (T : Entity_Id; + Def : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Def); + Base : constant Entity_Id := + New_Internal_Entity + (E_Ordinary_Fixed_Point_Type, Current_Scope, Sloc (Def), 'G'); + begin + -- The semantic attributes are set for completeness only, their values + -- will never be used, since all properties of the type are non-static. + + Enter_Name (T); + Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype); + Set_Etype (T, Base); + Set_Size_Info (T, Standard_Integer); + Set_RM_Size (T, RM_Size (Standard_Integer)); + Set_Small_Value (T, Ureal_1); + Set_Delta_Value (T, Ureal_1); + Set_Scalar_Range (T, + Make_Range (Loc, + Low_Bound => Make_Real_Literal (Loc, Ureal_1), + High_Bound => Make_Real_Literal (Loc, Ureal_1))); + Set_Is_Constrained (T); + + Set_Is_Generic_Type (Base); + Set_Etype (Base, Base); + Set_Size_Info (Base, Standard_Integer); + Set_RM_Size (Base, RM_Size (Standard_Integer)); + Set_Small_Value (Base, Ureal_1); + Set_Delta_Value (Base, Ureal_1); + Set_Scalar_Range (Base, Scalar_Range (T)); + Set_Parent (Base, Parent (Def)); + + Check_Restriction (No_Fixed_Point, Def); + end Analyze_Formal_Ordinary_Fixed_Point_Type; + + ---------------------------------------- + -- Analyze_Formal_Package_Declaration -- + ---------------------------------------- + + procedure Analyze_Formal_Package_Declaration (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Pack_Id : constant Entity_Id := Defining_Identifier (N); + Formal : Entity_Id; + Gen_Id : constant Node_Id := Name (N); + Gen_Decl : Node_Id; + Gen_Unit : Entity_Id; + New_N : Node_Id; + Parent_Installed : Boolean := False; + Renaming : Node_Id; + Parent_Instance : Entity_Id; + Renaming_In_Par : Entity_Id; + No_Associations : Boolean := False; + + function Build_Local_Package return Node_Id; + -- The formal package is rewritten so that its parameters are replaced + -- with corresponding declarations. For parameters with bona fide + -- associations these declarations are created by Analyze_Associations + -- as for a regular instantiation. For boxed parameters, we preserve + -- the formal declarations and analyze them, in order to introduce + -- entities of the right kind in the environment of the formal. + + ------------------------- + -- Build_Local_Package -- + ------------------------- + + function Build_Local_Package return Node_Id is + Decls : List_Id; + Pack_Decl : Node_Id; + + begin + -- Within the formal, the name of the generic package is a renaming + -- of the formal (as for a regular instantiation). + + Pack_Decl := + Make_Package_Declaration (Loc, + Specification => + Copy_Generic_Node + (Specification (Original_Node (Gen_Decl)), + Empty, Instantiating => True)); + + Renaming := Make_Package_Renaming_Declaration (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Chars (Gen_Unit)), + Name => New_Occurrence_Of (Formal, Loc)); + + if Nkind (Gen_Id) = N_Identifier + and then Chars (Gen_Id) = Chars (Pack_Id) + then + Error_Msg_NE + ("& is hidden within declaration of instance", Gen_Id, Gen_Unit); + end if; + + -- If the formal is declared with a box, or with an others choice, + -- create corresponding declarations for all entities in the formal + -- part, so that names with the proper types are available in the + -- specification of the formal package. + + -- On the other hand, if there are no associations, then all the + -- formals must have defaults, and this will be checked by the + -- call to Analyze_Associations. + + if Box_Present (N) + or else Nkind (First (Generic_Associations (N))) = N_Others_Choice + then + declare + Formal_Decl : Node_Id; + + begin + -- TBA : for a formal package, need to recurse ??? + + Decls := New_List; + Formal_Decl := + First + (Generic_Formal_Declarations (Original_Node (Gen_Decl))); + while Present (Formal_Decl) loop + Append_To + (Decls, Copy_Generic_Node (Formal_Decl, Empty, True)); + Next (Formal_Decl); + end loop; + end; + + -- If generic associations are present, use Analyze_Associations to + -- create the proper renaming declarations. + + else + declare + Act_Tree : constant Node_Id := + Copy_Generic_Node + (Original_Node (Gen_Decl), Empty, + Instantiating => True); + + begin + Generic_Renamings.Set_Last (0); + Generic_Renamings_HTable.Reset; + Instantiation_Node := N; + + Decls := + Analyze_Associations + (Original_Node (N), + Generic_Formal_Declarations (Act_Tree), + Generic_Formal_Declarations (Gen_Decl)); + end; + end if; + + Append (Renaming, To => Decls); + + -- Add generated declarations ahead of local declarations in + -- the package. + + if No (Visible_Declarations (Specification (Pack_Decl))) then + Set_Visible_Declarations (Specification (Pack_Decl), Decls); + else + Insert_List_Before + (First (Visible_Declarations (Specification (Pack_Decl))), + Decls); + end if; + + return Pack_Decl; + end Build_Local_Package; + + -- Start of processing for Analyze_Formal_Package + + begin + Text_IO_Kludge (Gen_Id); + + Init_Env; + Check_Generic_Child_Unit (Gen_Id, Parent_Installed); + Gen_Unit := Entity (Gen_Id); + + -- Check for a formal package that is a package renaming + + if Present (Renamed_Object (Gen_Unit)) then + + -- Indicate that unit is used, before replacing it with renamed + -- entity for use below. + + if In_Extended_Main_Source_Unit (N) then + Set_Is_Instantiated (Gen_Unit); + Generate_Reference (Gen_Unit, N); + end if; + + Gen_Unit := Renamed_Object (Gen_Unit); + end if; + + if Ekind (Gen_Unit) /= E_Generic_Package then + Error_Msg_N ("expect generic package name", Gen_Id); + Restore_Env; + goto Leave; + + elsif Gen_Unit = Current_Scope then + Error_Msg_N + ("generic package cannot be used as a formal package of itself", + Gen_Id); + Restore_Env; + goto Leave; + + elsif In_Open_Scopes (Gen_Unit) then + if Is_Compilation_Unit (Gen_Unit) + and then Is_Child_Unit (Current_Scope) + then + -- Special-case the error when the formal is a parent, and + -- continue analysis to minimize cascaded errors. + + Error_Msg_N + ("generic parent cannot be used as formal package " + & "of a child unit", + Gen_Id); + + else + Error_Msg_N + ("generic package cannot be used as a formal package " + & "within itself", + Gen_Id); + Restore_Env; + goto Leave; + end if; + end if; + + if Box_Present (N) + or else No (Generic_Associations (N)) + or else Nkind (First (Generic_Associations (N))) = N_Others_Choice + then + No_Associations := True; + end if; + + -- If there are no generic associations, the generic parameters appear + -- as local entities and are instantiated like them. We copy the generic + -- package declaration as if it were an instantiation, and analyze it + -- like a regular package, except that we treat the formals as + -- additional visible components. + + Gen_Decl := Unit_Declaration_Node (Gen_Unit); + + if In_Extended_Main_Source_Unit (N) then + Set_Is_Instantiated (Gen_Unit); + Generate_Reference (Gen_Unit, N); + end if; + + Formal := New_Copy (Pack_Id); + Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment); + + begin + -- Make local generic without formals. The formals will be replaced + -- with internal declarations. + + New_N := Build_Local_Package; + + -- If there are errors in the parameter list, Analyze_Associations + -- raises Instantiation_Error. Patch the declaration to prevent + -- further exception propagation. + + exception + when Instantiation_Error => + + Enter_Name (Formal); + Set_Ekind (Formal, E_Variable); + Set_Etype (Formal, Any_Type); + + if Parent_Installed then + Remove_Parent; + end if; + + goto Leave; + end; + + Rewrite (N, New_N); + Set_Defining_Unit_Name (Specification (New_N), Formal); + Set_Generic_Parent (Specification (N), Gen_Unit); + Set_Instance_Env (Gen_Unit, Formal); + Set_Is_Generic_Instance (Formal); + + Enter_Name (Formal); + Set_Ekind (Formal, E_Package); + Set_Etype (Formal, Standard_Void_Type); + Set_Inner_Instances (Formal, New_Elmt_List); + Push_Scope (Formal); + + if Is_Child_Unit (Gen_Unit) + and then Parent_Installed + then + -- Similarly, we have to make the name of the formal visible in the + -- parent instance, to resolve properly fully qualified names that + -- may appear in the generic unit. The parent instance has been + -- placed on the scope stack ahead of the current scope. + + Parent_Instance := Scope_Stack.Table (Scope_Stack.Last - 1).Entity; + + Renaming_In_Par := + Make_Defining_Identifier (Loc, Chars (Gen_Unit)); + Set_Ekind (Renaming_In_Par, E_Package); + Set_Etype (Renaming_In_Par, Standard_Void_Type); + Set_Scope (Renaming_In_Par, Parent_Instance); + Set_Parent (Renaming_In_Par, Parent (Formal)); + Set_Renamed_Object (Renaming_In_Par, Formal); + Append_Entity (Renaming_In_Par, Parent_Instance); + end if; + + Analyze (Specification (N)); + + -- The formals for which associations are provided are not visible + -- outside of the formal package. The others are still declared by a + -- formal parameter declaration. + + if not No_Associations then + declare + E : Entity_Id; + + begin + E := First_Entity (Formal); + while Present (E) loop + exit when Ekind (E) = E_Package + and then Renamed_Entity (E) = Formal; + + if not Is_Generic_Formal (E) then + Set_Is_Hidden (E); + end if; + + Next_Entity (E); + end loop; + end; + end if; + + End_Package_Scope (Formal); + + if Parent_Installed then + Remove_Parent; + end if; + + Restore_Env; + + -- Inside the generic unit, the formal package is a regular package, but + -- no body is needed for it. Note that after instantiation, the defining + -- unit name we need is in the new tree and not in the original (see + -- Package_Instantiation). A generic formal package is an instance, and + -- can be used as an actual for an inner instance. + + Set_Has_Completion (Formal, True); + + -- Add semantic information to the original defining identifier. + -- for ASIS use. + + Set_Ekind (Pack_Id, E_Package); + Set_Etype (Pack_Id, Standard_Void_Type); + Set_Scope (Pack_Id, Scope (Formal)); + Set_Has_Completion (Pack_Id, True); + + <> + Analyze_Aspect_Specifications (N, Pack_Id, Aspect_Specifications (N)); + end Analyze_Formal_Package_Declaration; + + --------------------------------- + -- Analyze_Formal_Private_Type -- + --------------------------------- + + procedure Analyze_Formal_Private_Type + (N : Node_Id; + T : Entity_Id; + Def : Node_Id) + is + begin + New_Private_Type (N, T, Def); + + -- Set the size to an arbitrary but legal value + + Set_Size_Info (T, Standard_Integer); + Set_RM_Size (T, RM_Size (Standard_Integer)); + end Analyze_Formal_Private_Type; + + ---------------------------------------- + -- Analyze_Formal_Signed_Integer_Type -- + ---------------------------------------- + + procedure Analyze_Formal_Signed_Integer_Type + (T : Entity_Id; + Def : Node_Id) + is + Base : constant Entity_Id := + New_Internal_Entity + (E_Signed_Integer_Type, Current_Scope, Sloc (Def), 'G'); + + begin + Enter_Name (T); + + Set_Ekind (T, E_Signed_Integer_Subtype); + Set_Etype (T, Base); + Set_Size_Info (T, Standard_Integer); + Set_RM_Size (T, RM_Size (Standard_Integer)); + Set_Scalar_Range (T, Scalar_Range (Standard_Integer)); + Set_Is_Constrained (T); + + Set_Is_Generic_Type (Base); + Set_Size_Info (Base, Standard_Integer); + Set_RM_Size (Base, RM_Size (Standard_Integer)); + Set_Etype (Base, Base); + Set_Scalar_Range (Base, Scalar_Range (Standard_Integer)); + Set_Parent (Base, Parent (Def)); + end Analyze_Formal_Signed_Integer_Type; + + ------------------------------------------- + -- Analyze_Formal_Subprogram_Declaration -- + ------------------------------------------- + + procedure Analyze_Formal_Subprogram_Declaration (N : Node_Id) is + Spec : constant Node_Id := Specification (N); + Def : constant Node_Id := Default_Name (N); + Nam : constant Entity_Id := Defining_Unit_Name (Spec); + Subp : Entity_Id; + + begin + if Nam = Error then + return; + end if; + + if Nkind (Nam) = N_Defining_Program_Unit_Name then + Error_Msg_N ("name of formal subprogram must be a direct name", Nam); + goto Leave; + end if; + + Analyze_Subprogram_Declaration (N); + Set_Is_Formal_Subprogram (Nam); + Set_Has_Completion (Nam); + + if Nkind (N) = N_Formal_Abstract_Subprogram_Declaration then + Set_Is_Abstract_Subprogram (Nam); + Set_Is_Dispatching_Operation (Nam); + + declare + Ctrl_Type : constant Entity_Id := Find_Dispatching_Type (Nam); + begin + if No (Ctrl_Type) then + Error_Msg_N + ("abstract formal subprogram must have a controlling type", + N); + else + Check_Controlling_Formals (Ctrl_Type, Nam); + end if; + end; + end if; + + -- Default name is resolved at the point of instantiation + + if Box_Present (N) then + null; + + -- Else default is bound at the point of generic declaration + + elsif Present (Def) then + if Nkind (Def) = N_Operator_Symbol then + Find_Direct_Name (Def); + + elsif Nkind (Def) /= N_Attribute_Reference then + Analyze (Def); + + else + -- For an attribute reference, analyze the prefix and verify + -- that it has the proper profile for the subprogram. + + Analyze (Prefix (Def)); + Valid_Default_Attribute (Nam, Def); + goto Leave; + end if; + + -- Default name may be overloaded, in which case the interpretation + -- with the correct profile must be selected, as for a renaming. + -- If the definition is an indexed component, it must denote a + -- member of an entry family. If it is a selected component, it + -- can be a protected operation. + + if Etype (Def) = Any_Type then + goto Leave; + + elsif Nkind (Def) = N_Selected_Component then + if not Is_Overloadable (Entity (Selector_Name (Def))) then + Error_Msg_N ("expect valid subprogram name as default", Def); + end if; + + elsif Nkind (Def) = N_Indexed_Component then + if Is_Entity_Name (Prefix (Def)) then + if Ekind (Entity (Prefix (Def))) /= E_Entry_Family then + Error_Msg_N ("expect valid subprogram name as default", Def); + end if; + + elsif Nkind (Prefix (Def)) = N_Selected_Component then + if Ekind (Entity (Selector_Name (Prefix (Def)))) /= + E_Entry_Family + then + Error_Msg_N ("expect valid subprogram name as default", Def); + end if; + + else + Error_Msg_N ("expect valid subprogram name as default", Def); + goto Leave; + end if; + + elsif Nkind (Def) = N_Character_Literal then + + -- Needs some type checks: subprogram should be parameterless??? + + Resolve (Def, (Etype (Nam))); + + elsif not Is_Entity_Name (Def) + or else not Is_Overloadable (Entity (Def)) + then + Error_Msg_N ("expect valid subprogram name as default", Def); + goto Leave; + + elsif not Is_Overloaded (Def) then + Subp := Entity (Def); + + if Subp = Nam then + Error_Msg_N ("premature usage of formal subprogram", Def); + + elsif not Entity_Matches_Spec (Subp, Nam) then + Error_Msg_N ("no visible entity matches specification", Def); + end if; + + -- More than one interpretation, so disambiguate as for a renaming + + else + declare + I : Interp_Index; + I1 : Interp_Index := 0; + It : Interp; + It1 : Interp; + + begin + Subp := Any_Id; + Get_First_Interp (Def, I, It); + while Present (It.Nam) loop + if Entity_Matches_Spec (It.Nam, Nam) then + if Subp /= Any_Id then + It1 := Disambiguate (Def, I1, I, Etype (Subp)); + + if It1 = No_Interp then + Error_Msg_N ("ambiguous default subprogram", Def); + else + Subp := It1.Nam; + end if; + + exit; + + else + I1 := I; + Subp := It.Nam; + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + end; + + if Subp /= Any_Id then + Set_Entity (Def, Subp); + + if Subp = Nam then + Error_Msg_N ("premature usage of formal subprogram", Def); + + elsif Ekind (Subp) /= E_Operator then + Check_Mode_Conformant (Subp, Nam); + end if; + + else + Error_Msg_N ("no visible subprogram matches specification", N); + end if; + end if; + end if; + + <> + Analyze_Aspect_Specifications (N, Nam, Aspect_Specifications (N)); + end Analyze_Formal_Subprogram_Declaration; + + ------------------------------------- + -- Analyze_Formal_Type_Declaration -- + ------------------------------------- + + procedure Analyze_Formal_Type_Declaration (N : Node_Id) is + Def : constant Node_Id := Formal_Type_Definition (N); + T : Entity_Id; + + begin + T := Defining_Identifier (N); + + if Present (Discriminant_Specifications (N)) + and then Nkind (Def) /= N_Formal_Private_Type_Definition + then + Error_Msg_N + ("discriminants not allowed for this formal type", T); + end if; + + -- Enter the new name, and branch to specific routine + + case Nkind (Def) is + when N_Formal_Private_Type_Definition => + Analyze_Formal_Private_Type (N, T, Def); + + when N_Formal_Derived_Type_Definition => + Analyze_Formal_Derived_Type (N, T, Def); + + when N_Formal_Discrete_Type_Definition => + Analyze_Formal_Discrete_Type (T, Def); + + when N_Formal_Signed_Integer_Type_Definition => + Analyze_Formal_Signed_Integer_Type (T, Def); + + when N_Formal_Modular_Type_Definition => + Analyze_Formal_Modular_Type (T, Def); + + when N_Formal_Floating_Point_Definition => + Analyze_Formal_Floating_Type (T, Def); + + when N_Formal_Ordinary_Fixed_Point_Definition => + Analyze_Formal_Ordinary_Fixed_Point_Type (T, Def); + + when N_Formal_Decimal_Fixed_Point_Definition => + Analyze_Formal_Decimal_Fixed_Point_Type (T, Def); + + when N_Array_Type_Definition => + Analyze_Formal_Array_Type (T, Def); + + when N_Access_To_Object_Definition | + N_Access_Function_Definition | + N_Access_Procedure_Definition => + Analyze_Generic_Access_Type (T, Def); + + -- Ada 2005: a interface declaration is encoded as an abstract + -- record declaration or a abstract type derivation. + + when N_Record_Definition => + Analyze_Formal_Interface_Type (N, T, Def); + + when N_Derived_Type_Definition => + Analyze_Formal_Derived_Interface_Type (N, T, Def); + + when N_Error => + null; + + when others => + raise Program_Error; + + end case; + + Set_Is_Generic_Type (T); + Analyze_Aspect_Specifications (N, T, Aspect_Specifications (N)); + end Analyze_Formal_Type_Declaration; + + ------------------------------------ + -- Analyze_Function_Instantiation -- + ------------------------------------ + + procedure Analyze_Function_Instantiation (N : Node_Id) is + begin + Analyze_Subprogram_Instantiation (N, E_Function); + end Analyze_Function_Instantiation; + + --------------------------------- + -- Analyze_Generic_Access_Type -- + --------------------------------- + + procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id) is + begin + Enter_Name (T); + + if Nkind (Def) = N_Access_To_Object_Definition then + Access_Type_Declaration (T, Def); + + if Is_Incomplete_Or_Private_Type (Designated_Type (T)) + and then No (Full_View (Designated_Type (T))) + and then not Is_Generic_Type (Designated_Type (T)) + then + Error_Msg_N ("premature usage of incomplete type", Def); + + elsif not Is_Entity_Name (Subtype_Indication (Def)) then + Error_Msg_N + ("only a subtype mark is allowed in a formal", Def); + end if; + + else + Access_Subprogram_Declaration (T, Def); + end if; + end Analyze_Generic_Access_Type; + + --------------------------------- + -- Analyze_Generic_Formal_Part -- + --------------------------------- + + procedure Analyze_Generic_Formal_Part (N : Node_Id) is + Gen_Parm_Decl : Node_Id; + + begin + -- The generic formals are processed in the scope of the generic unit, + -- where they are immediately visible. The scope is installed by the + -- caller. + + Gen_Parm_Decl := First (Generic_Formal_Declarations (N)); + + while Present (Gen_Parm_Decl) loop + Analyze (Gen_Parm_Decl); + Next (Gen_Parm_Decl); + end loop; + + Generate_Reference_To_Generic_Formals (Current_Scope); + end Analyze_Generic_Formal_Part; + + ------------------------------------------ + -- Analyze_Generic_Package_Declaration -- + ------------------------------------------ + + procedure Analyze_Generic_Package_Declaration (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Id : Entity_Id; + New_N : Node_Id; + Save_Parent : Node_Id; + Renaming : Node_Id; + Decls : constant List_Id := + Visible_Declarations (Specification (N)); + Decl : Node_Id; + + begin + -- We introduce a renaming of the enclosing package, to have a usable + -- entity as the prefix of an expanded name for a local entity of the + -- form Par.P.Q, where P is the generic package. This is because a local + -- entity named P may hide it, so that the usual visibility rules in + -- the instance will not resolve properly. + + Renaming := + Make_Package_Renaming_Declaration (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Defining_Entity (N)), "GH")), + Name => Make_Identifier (Loc, Chars (Defining_Entity (N)))); + + if Present (Decls) then + Decl := First (Decls); + while Present (Decl) + and then Nkind (Decl) = N_Pragma + loop + Next (Decl); + end loop; + + if Present (Decl) then + Insert_Before (Decl, Renaming); + else + Append (Renaming, Visible_Declarations (Specification (N))); + end if; + + else + Set_Visible_Declarations (Specification (N), New_List (Renaming)); + end if; + + -- Create copy of generic unit, and save for instantiation. If the unit + -- is a child unit, do not copy the specifications for the parent, which + -- are not part of the generic tree. + + Save_Parent := Parent_Spec (N); + Set_Parent_Spec (N, Empty); + + New_N := Copy_Generic_Node (N, Empty, Instantiating => False); + Set_Parent_Spec (New_N, Save_Parent); + Rewrite (N, New_N); + Id := Defining_Entity (N); + Generate_Definition (Id); + + -- Expansion is not applied to generic units + + Start_Generic; + + Enter_Name (Id); + Set_Ekind (Id, E_Generic_Package); + Set_Etype (Id, Standard_Void_Type); + Push_Scope (Id); + Enter_Generic_Scope (Id); + Set_Inner_Instances (Id, New_Elmt_List); + + Set_Categorization_From_Pragmas (N); + Set_Is_Pure (Id, Is_Pure (Current_Scope)); + + -- Link the declaration of the generic homonym in the generic copy to + -- the package it renames, so that it is always resolved properly. + + Set_Generic_Homonym (Id, Defining_Unit_Name (Renaming)); + Set_Entity (Associated_Node (Name (Renaming)), Id); + + -- For a library unit, we have reconstructed the entity for the unit, + -- and must reset it in the library tables. + + if Nkind (Parent (N)) = N_Compilation_Unit then + Set_Cunit_Entity (Current_Sem_Unit, Id); + end if; + + Analyze_Generic_Formal_Part (N); + + -- After processing the generic formals, analysis proceeds as for a + -- non-generic package. + + Analyze (Specification (N)); + + Validate_Categorization_Dependency (N, Id); + + End_Generic; + + End_Package_Scope (Id); + Exit_Generic_Scope (Id); + + if Nkind (Parent (N)) /= N_Compilation_Unit then + Move_Freeze_Nodes (Id, N, Visible_Declarations (Specification (N))); + Move_Freeze_Nodes (Id, N, Private_Declarations (Specification (N))); + Move_Freeze_Nodes (Id, N, Generic_Formal_Declarations (N)); + + else + Set_Body_Required (Parent (N), Unit_Requires_Body (Id)); + Validate_RT_RAT_Component (N); + + -- If this is a spec without a body, check that generic parameters + -- are referenced. + + if not Body_Required (Parent (N)) then + Check_References (Id); + end if; + end if; + + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); + end Analyze_Generic_Package_Declaration; + + -------------------------------------------- + -- Analyze_Generic_Subprogram_Declaration -- + -------------------------------------------- + + procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id) is + Spec : Node_Id; + Id : Entity_Id; + Formals : List_Id; + New_N : Node_Id; + Result_Type : Entity_Id; + Save_Parent : Node_Id; + Typ : Entity_Id; + + begin + -- Create copy of generic unit, and save for instantiation. If the unit + -- is a child unit, do not copy the specifications for the parent, which + -- are not part of the generic tree. + + Save_Parent := Parent_Spec (N); + Set_Parent_Spec (N, Empty); + + New_N := Copy_Generic_Node (N, Empty, Instantiating => False); + Set_Parent_Spec (New_N, Save_Parent); + Rewrite (N, New_N); + + Spec := Specification (N); + Id := Defining_Entity (Spec); + Generate_Definition (Id); + + if Nkind (Id) = N_Defining_Operator_Symbol then + Error_Msg_N + ("operator symbol not allowed for generic subprogram", Id); + end if; + + Start_Generic; + + Enter_Name (Id); + + Set_Scope_Depth_Value (Id, Scope_Depth (Current_Scope) + 1); + Push_Scope (Id); + Enter_Generic_Scope (Id); + Set_Inner_Instances (Id, New_Elmt_List); + Set_Is_Pure (Id, Is_Pure (Current_Scope)); + + Analyze_Generic_Formal_Part (N); + + Formals := Parameter_Specifications (Spec); + + if Present (Formals) then + Process_Formals (Formals, Spec); + end if; + + if Nkind (Spec) = N_Function_Specification then + Set_Ekind (Id, E_Generic_Function); + + if Nkind (Result_Definition (Spec)) = N_Access_Definition then + Result_Type := Access_Definition (Spec, Result_Definition (Spec)); + Set_Etype (Id, Result_Type); + + -- Check restriction imposed by AI05-073: a generic function + -- cannot return an abstract type or an access to such. + + -- This is a binding interpretation should it apply to earlier + -- versions of Ada as well as Ada 2012??? + + if Is_Abstract_Type (Designated_Type (Result_Type)) + and then Ada_Version >= Ada_2012 + then + Error_Msg_N ("generic function cannot have an access result" + & " that designates an abstract type", Spec); + end if; + + else + Find_Type (Result_Definition (Spec)); + Typ := Entity (Result_Definition (Spec)); + + if Is_Abstract_Type (Typ) + and then Ada_Version >= Ada_2012 + then + Error_Msg_N + ("generic function cannot have abstract result type", Spec); + end if; + + -- If a null exclusion is imposed on the result type, then create + -- a null-excluding itype (an access subtype) and use it as the + -- function's Etype. + + if Is_Access_Type (Typ) + and then Null_Exclusion_Present (Spec) + then + Set_Etype (Id, + Create_Null_Excluding_Itype + (T => Typ, + Related_Nod => Spec, + Scope_Id => Defining_Unit_Name (Spec))); + else + Set_Etype (Id, Typ); + end if; + end if; + + else + Set_Ekind (Id, E_Generic_Procedure); + Set_Etype (Id, Standard_Void_Type); + end if; + + -- For a library unit, we have reconstructed the entity for the unit, + -- and must reset it in the library tables. We also make sure that + -- Body_Required is set properly in the original compilation unit node. + + if Nkind (Parent (N)) = N_Compilation_Unit then + Set_Cunit_Entity (Current_Sem_Unit, Id); + Set_Body_Required (Parent (N), Unit_Requires_Body (Id)); + end if; + + Set_Categorization_From_Pragmas (N); + Validate_Categorization_Dependency (N, Id); + + Save_Global_References (Original_Node (N)); + + End_Generic; + End_Scope; + Exit_Generic_Scope (Id); + Generate_Reference_To_Formals (Id); + + List_Inherited_Pre_Post_Aspects (Id); + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); + end Analyze_Generic_Subprogram_Declaration; + + ----------------------------------- + -- Analyze_Package_Instantiation -- + ----------------------------------- + + procedure Analyze_Package_Instantiation (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Gen_Id : constant Node_Id := Name (N); + + Act_Decl : Node_Id; + Act_Decl_Name : Node_Id; + Act_Decl_Id : Entity_Id; + Act_Spec : Node_Id; + Act_Tree : Node_Id; + + Gen_Decl : Node_Id; + Gen_Unit : Entity_Id; + + Is_Actual_Pack : constant Boolean := + Is_Internal (Defining_Entity (N)); + + Env_Installed : Boolean := False; + Parent_Installed : Boolean := False; + Renaming_List : List_Id; + Unit_Renaming : Node_Id; + Needs_Body : Boolean; + Inline_Now : Boolean := False; + + procedure Delay_Descriptors (E : Entity_Id); + -- Delay generation of subprogram descriptors for given entity + + function Might_Inline_Subp return Boolean; + -- If inlining is active and the generic contains inlined subprograms, + -- we instantiate the body. This may cause superfluous instantiations, + -- but it is simpler than detecting the need for the body at the point + -- of inlining, when the context of the instance is not available. + + ----------------------- + -- Delay_Descriptors -- + ----------------------- + + procedure Delay_Descriptors (E : Entity_Id) is + begin + if not Delay_Subprogram_Descriptors (E) then + Set_Delay_Subprogram_Descriptors (E); + Pending_Descriptor.Append (E); + end if; + end Delay_Descriptors; + + ----------------------- + -- Might_Inline_Subp -- + ----------------------- + + function Might_Inline_Subp return Boolean is + E : Entity_Id; + + begin + if not Inline_Processing_Required then + return False; + + else + E := First_Entity (Gen_Unit); + while Present (E) loop + if Is_Subprogram (E) + and then Is_Inlined (E) + then + return True; + end if; + + Next_Entity (E); + end loop; + end if; + + return False; + end Might_Inline_Subp; + + -- Start of processing for Analyze_Package_Instantiation + + begin + -- Very first thing: apply the special kludge for Text_IO processing + -- in case we are instantiating one of the children of [Wide_]Text_IO. + + Text_IO_Kludge (Name (N)); + + -- Make node global for error reporting + + Instantiation_Node := N; + + -- Case of instantiation of a generic package + + if Nkind (N) = N_Package_Instantiation then + Act_Decl_Id := New_Copy (Defining_Entity (N)); + Set_Comes_From_Source (Act_Decl_Id, True); + + if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then + Act_Decl_Name := + Make_Defining_Program_Unit_Name (Loc, + Name => New_Copy_Tree (Name (Defining_Unit_Name (N))), + Defining_Identifier => Act_Decl_Id); + else + Act_Decl_Name := Act_Decl_Id; + end if; + + -- Case of instantiation of a formal package + + else + Act_Decl_Id := Defining_Identifier (N); + Act_Decl_Name := Act_Decl_Id; + end if; + + Generate_Definition (Act_Decl_Id); + Preanalyze_Actuals (N); + + Init_Env; + Env_Installed := True; + + -- Reset renaming map for formal types. The mapping is established + -- when analyzing the generic associations, but some mappings are + -- inherited from formal packages of parent units, and these are + -- constructed when the parents are installed. + + Generic_Renamings.Set_Last (0); + Generic_Renamings_HTable.Reset; + + Check_Generic_Child_Unit (Gen_Id, Parent_Installed); + Gen_Unit := Entity (Gen_Id); + + -- Verify that it is the name of a generic package + + -- A visibility glitch: if the instance is a child unit and the generic + -- is the generic unit of a parent instance (i.e. both the parent and + -- the child units are instances of the same package) the name now + -- denotes the renaming within the parent, not the intended generic + -- unit. See if there is a homonym that is the desired generic. The + -- renaming declaration must be visible inside the instance of the + -- child, but not when analyzing the name in the instantiation itself. + + if Ekind (Gen_Unit) = E_Package + and then Present (Renamed_Entity (Gen_Unit)) + and then In_Open_Scopes (Renamed_Entity (Gen_Unit)) + and then Is_Generic_Instance (Renamed_Entity (Gen_Unit)) + and then Present (Homonym (Gen_Unit)) + then + Gen_Unit := Homonym (Gen_Unit); + end if; + + if Etype (Gen_Unit) = Any_Type then + Restore_Env; + goto Leave; + + elsif Ekind (Gen_Unit) /= E_Generic_Package then + + -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause + + if From_With_Type (Gen_Unit) then + Error_Msg_N + ("cannot instantiate a limited withed package", Gen_Id); + else + Error_Msg_N + ("expect name of generic package in instantiation", Gen_Id); + end if; + + Restore_Env; + goto Leave; + end if; + + if In_Extended_Main_Source_Unit (N) then + Set_Is_Instantiated (Gen_Unit); + Generate_Reference (Gen_Unit, N); + + if Present (Renamed_Object (Gen_Unit)) then + Set_Is_Instantiated (Renamed_Object (Gen_Unit)); + Generate_Reference (Renamed_Object (Gen_Unit), N); + end if; + end if; + + if Nkind (Gen_Id) = N_Identifier + and then Chars (Gen_Unit) = Chars (Defining_Entity (N)) + then + Error_Msg_NE + ("& is hidden within declaration of instance", Gen_Id, Gen_Unit); + + elsif Nkind (Gen_Id) = N_Expanded_Name + and then Is_Child_Unit (Gen_Unit) + and then Nkind (Prefix (Gen_Id)) = N_Identifier + and then Chars (Act_Decl_Id) = Chars (Prefix (Gen_Id)) + then + Error_Msg_N + ("& is hidden within declaration of instance ", Prefix (Gen_Id)); + end if; + + Set_Entity (Gen_Id, Gen_Unit); + + -- If generic is a renaming, get original generic unit + + if Present (Renamed_Object (Gen_Unit)) + and then Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Package + then + Gen_Unit := Renamed_Object (Gen_Unit); + end if; + + -- Verify that there are no circular instantiations + + if In_Open_Scopes (Gen_Unit) then + Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit); + Restore_Env; + goto Leave; + + elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then + Error_Msg_Node_2 := Current_Scope; + Error_Msg_NE + ("circular Instantiation: & instantiated in &!", N, Gen_Unit); + Circularity_Detected := True; + Restore_Env; + goto Leave; + + else + Gen_Decl := Unit_Declaration_Node (Gen_Unit); + + -- Initialize renamings map, for error checking, and the list that + -- holds private entities whose views have changed between generic + -- definition and instantiation. If this is the instance created to + -- validate an actual package, the instantiation environment is that + -- of the enclosing instance. + + Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment); + + -- Copy original generic tree, to produce text for instantiation + + Act_Tree := + Copy_Generic_Node + (Original_Node (Gen_Decl), Empty, Instantiating => True); + + Act_Spec := Specification (Act_Tree); + + -- If this is the instance created to validate an actual package, + -- only the formals matter, do not examine the package spec itself. + + if Is_Actual_Pack then + Set_Visible_Declarations (Act_Spec, New_List); + Set_Private_Declarations (Act_Spec, New_List); + end if; + + Renaming_List := + Analyze_Associations + (N, + Generic_Formal_Declarations (Act_Tree), + Generic_Formal_Declarations (Gen_Decl)); + + Set_Instance_Env (Gen_Unit, Act_Decl_Id); + Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name); + Set_Is_Generic_Instance (Act_Decl_Id); + + Set_Generic_Parent (Act_Spec, Gen_Unit); + + -- References to the generic in its own declaration or its body are + -- references to the instance. Add a renaming declaration for the + -- generic unit itself. This declaration, as well as the renaming + -- declarations for the generic formals, must remain private to the + -- unit: the formals, because this is the language semantics, and + -- the unit because its use is an artifact of the implementation. + + Unit_Renaming := + Make_Package_Renaming_Declaration (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Chars (Gen_Unit)), + Name => New_Reference_To (Act_Decl_Id, Loc)); + + Append (Unit_Renaming, Renaming_List); + + -- The renaming declarations are the first local declarations of + -- the new unit. + + if Is_Non_Empty_List (Visible_Declarations (Act_Spec)) then + Insert_List_Before + (First (Visible_Declarations (Act_Spec)), Renaming_List); + else + Set_Visible_Declarations (Act_Spec, Renaming_List); + end if; + + Act_Decl := + Make_Package_Declaration (Loc, + Specification => Act_Spec); + + -- Save the instantiation node, for subsequent instantiation of the + -- body, if there is one and we are generating code for the current + -- unit. Mark the unit as having a body, to avoid a premature error + -- message. + + -- We instantiate the body if we are generating code, if we are + -- generating cross-reference information, or if we are building + -- trees for ASIS use. + + declare + Enclosing_Body_Present : Boolean := False; + -- If the generic unit is not a compilation unit, then a body may + -- be present in its parent even if none is required. We create a + -- tentative pending instantiation for the body, which will be + -- discarded if none is actually present. + + Scop : Entity_Id; + + begin + if Scope (Gen_Unit) /= Standard_Standard + and then not Is_Child_Unit (Gen_Unit) + then + Scop := Scope (Gen_Unit); + + while Present (Scop) + and then Scop /= Standard_Standard + loop + if Unit_Requires_Body (Scop) then + Enclosing_Body_Present := True; + exit; + + elsif In_Open_Scopes (Scop) + and then In_Package_Body (Scop) + then + Enclosing_Body_Present := True; + exit; + end if; + + exit when Is_Compilation_Unit (Scop); + Scop := Scope (Scop); + end loop; + end if; + + -- If front-end inlining is enabled, and this is a unit for which + -- code will be generated, we instantiate the body at once. + + -- This is done if the instance is not the main unit, and if the + -- generic is not a child unit of another generic, to avoid scope + -- problems and the reinstallation of parent instances. + + if Expander_Active + and then (not Is_Child_Unit (Gen_Unit) + or else not Is_Generic_Unit (Scope (Gen_Unit))) + and then Might_Inline_Subp + and then not Is_Actual_Pack + then + if Front_End_Inlining + and then (Is_In_Main_Unit (N) + or else In_Main_Context (Current_Scope)) + and then Nkind (Parent (N)) /= N_Compilation_Unit + then + Inline_Now := True; + + -- In configurable_run_time mode we force the inlining of + -- predefined subprograms marked Inline_Always, to minimize + -- the use of the run-time library. + + elsif Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Gen_Decl))) + and then Configurable_Run_Time_Mode + and then Nkind (Parent (N)) /= N_Compilation_Unit + then + Inline_Now := True; + end if; + + -- If the current scope is itself an instance within a child + -- unit, there will be duplications in the scope stack, and the + -- unstacking mechanism in Inline_Instance_Body will fail. + -- This loses some rare cases of optimization, and might be + -- improved some day, if we can find a proper abstraction for + -- "the complete compilation context" that can be saved and + -- restored. ??? + + if Is_Generic_Instance (Current_Scope) then + declare + Curr_Unit : constant Entity_Id := + Cunit_Entity (Current_Sem_Unit); + begin + if Curr_Unit /= Current_Scope + and then Is_Child_Unit (Curr_Unit) + then + Inline_Now := False; + end if; + end; + end if; + end if; + + Needs_Body := + (Unit_Requires_Body (Gen_Unit) + or else Enclosing_Body_Present + or else Present (Corresponding_Body (Gen_Decl))) + and then (Is_In_Main_Unit (N) + or else Might_Inline_Subp) + and then not Is_Actual_Pack + and then not Inline_Now + and then (Operating_Mode = Generate_Code + or else (Operating_Mode = Check_Semantics + and then ASIS_Mode)); + + -- If front_end_inlining is enabled, do not instantiate body if + -- within a generic context. + + if (Front_End_Inlining + and then not Expander_Active) + or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) + then + Needs_Body := False; + end if; + + -- If the current context is generic, and the package being + -- instantiated is declared within a formal package, there is no + -- body to instantiate until the enclosing generic is instantiated + -- and there is an actual for the formal package. If the formal + -- package has parameters, we build a regular package instance for + -- it, that precedes the original formal package declaration. + + if In_Open_Scopes (Scope (Scope (Gen_Unit))) then + declare + Decl : constant Node_Id := + Original_Node + (Unit_Declaration_Node (Scope (Gen_Unit))); + begin + if Nkind (Decl) = N_Formal_Package_Declaration + or else (Nkind (Decl) = N_Package_Declaration + and then Is_List_Member (Decl) + and then Present (Next (Decl)) + and then + Nkind (Next (Decl)) = + N_Formal_Package_Declaration) + then + Needs_Body := False; + end if; + end; + end if; + end; + + -- If we are generating calling stubs, we never need a body for an + -- instantiation from source. However normal processing occurs for + -- any generic instantiation appearing in generated code, since we + -- do not generate stubs in that case. + + if Distribution_Stub_Mode = Generate_Caller_Stub_Body + and then Comes_From_Source (N) + then + Needs_Body := False; + end if; + + if Needs_Body then + + -- Here is a defence against a ludicrous number of instantiations + -- caused by a circular set of instantiation attempts. + + if Pending_Instantiations.Last > + Hostparm.Max_Instantiations + then + Error_Msg_N ("too many instantiations", N); + raise Unrecoverable_Error; + end if; + + -- Indicate that the enclosing scopes contain an instantiation, + -- and that cleanup actions should be delayed until after the + -- instance body is expanded. + + Check_Forward_Instantiation (Gen_Decl); + if Nkind (N) = N_Package_Instantiation then + declare + Enclosing_Master : Entity_Id; + + begin + -- Loop to search enclosing masters + + Enclosing_Master := Current_Scope; + Scope_Loop : while Enclosing_Master /= Standard_Standard loop + if Ekind (Enclosing_Master) = E_Package then + if Is_Compilation_Unit (Enclosing_Master) then + if In_Package_Body (Enclosing_Master) then + Delay_Descriptors + (Body_Entity (Enclosing_Master)); + else + Delay_Descriptors + (Enclosing_Master); + end if; + + exit Scope_Loop; + + else + Enclosing_Master := Scope (Enclosing_Master); + end if; + + elsif Ekind (Enclosing_Master) = E_Generic_Package then + Enclosing_Master := Scope (Enclosing_Master); + + elsif Is_Generic_Subprogram (Enclosing_Master) + or else Ekind (Enclosing_Master) = E_Void + then + -- Cleanup actions will eventually be performed on the + -- enclosing instance, if any. Enclosing scope is void + -- in the formal part of a generic subprogram. + + exit Scope_Loop; + + else + if Ekind (Enclosing_Master) = E_Entry + and then + Ekind (Scope (Enclosing_Master)) = E_Protected_Type + then + if not Expander_Active then + exit Scope_Loop; + else + Enclosing_Master := + Protected_Body_Subprogram (Enclosing_Master); + end if; + end if; + + Set_Delay_Cleanups (Enclosing_Master); + + while Ekind (Enclosing_Master) = E_Block loop + Enclosing_Master := Scope (Enclosing_Master); + end loop; + + if Is_Subprogram (Enclosing_Master) then + Delay_Descriptors (Enclosing_Master); + + elsif Is_Task_Type (Enclosing_Master) then + declare + TBP : constant Node_Id := + Get_Task_Body_Procedure + (Enclosing_Master); + begin + if Present (TBP) then + Delay_Descriptors (TBP); + Set_Delay_Cleanups (TBP); + end if; + end; + end if; + + exit Scope_Loop; + end if; + end loop Scope_Loop; + end; + + -- Make entry in table + + Pending_Instantiations.Append + ((Inst_Node => N, + Act_Decl => Act_Decl, + Expander_Status => Expander_Active, + Current_Sem_Unit => Current_Sem_Unit, + Scope_Suppress => Scope_Suppress, + Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, + Version => Ada_Version)); + end if; + end if; + + Set_Categorization_From_Pragmas (Act_Decl); + + if Parent_Installed then + Hide_Current_Scope; + end if; + + Set_Instance_Spec (N, Act_Decl); + + -- If not a compilation unit, insert the package declaration before + -- the original instantiation node. + + if Nkind (Parent (N)) /= N_Compilation_Unit then + Mark_Rewrite_Insertion (Act_Decl); + Insert_Before (N, Act_Decl); + Analyze (Act_Decl); + + -- For an instantiation that is a compilation unit, place declaration + -- on current node so context is complete for analysis (including + -- nested instantiations). If this is the main unit, the declaration + -- eventually replaces the instantiation node. If the instance body + -- is created later, it replaces the instance node, and the + -- declaration is attached to it (see + -- Build_Instance_Compilation_Unit_Nodes). + + else + if Cunit_Entity (Current_Sem_Unit) = Defining_Entity (N) then + + -- The entity for the current unit is the newly created one, + -- and all semantic information is attached to it. + + Set_Cunit_Entity (Current_Sem_Unit, Act_Decl_Id); + + -- If this is the main unit, replace the main entity as well + + if Current_Sem_Unit = Main_Unit then + Main_Unit_Entity := Act_Decl_Id; + end if; + end if; + + Set_Unit (Parent (N), Act_Decl); + Set_Parent_Spec (Act_Decl, Parent_Spec (N)); + Set_Package_Instantiation (Act_Decl_Id, N); + Analyze (Act_Decl); + Set_Unit (Parent (N), N); + Set_Body_Required (Parent (N), False); + + -- We never need elaboration checks on instantiations, since by + -- definition, the body instantiation is elaborated at the same + -- time as the spec instantiation. + + Set_Suppress_Elaboration_Warnings (Act_Decl_Id); + Set_Kill_Elaboration_Checks (Act_Decl_Id); + end if; + + Check_Elab_Instantiation (N); + + if ABE_Is_Certain (N) and then Needs_Body then + Pending_Instantiations.Decrement_Last; + end if; + + Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id); + + Set_First_Private_Entity (Defining_Unit_Name (Unit_Renaming), + First_Private_Entity (Act_Decl_Id)); + + -- If the instantiation will receive a body, the unit will be + -- transformed into a package body, and receive its own elaboration + -- entity. Otherwise, the nature of the unit is now a package + -- declaration. + + if Nkind (Parent (N)) = N_Compilation_Unit + and then not Needs_Body + then + Rewrite (N, Act_Decl); + end if; + + if Present (Corresponding_Body (Gen_Decl)) + or else Unit_Requires_Body (Gen_Unit) + then + Set_Has_Completion (Act_Decl_Id); + end if; + + Check_Formal_Packages (Act_Decl_Id); + + Restore_Private_Views (Act_Decl_Id); + + Inherit_Context (Gen_Decl, N); + + if Parent_Installed then + Remove_Parent; + end if; + + Restore_Env; + Env_Installed := False; + end if; + + Validate_Categorization_Dependency (N, Act_Decl_Id); + + -- There used to be a check here to prevent instantiations in local + -- contexts if the No_Local_Allocators restriction was active. This + -- check was removed by a binding interpretation in AI-95-00130/07, + -- but we retain the code for documentation purposes. + + -- if Ekind (Act_Decl_Id) /= E_Void + -- and then not Is_Library_Level_Entity (Act_Decl_Id) + -- then + -- Check_Restriction (No_Local_Allocators, N); + -- end if; + + if Inline_Now then + Inline_Instance_Body (N, Gen_Unit, Act_Decl); + end if; + + -- The following is a tree patch for ASIS: ASIS needs separate nodes to + -- be used as defining identifiers for a formal package and for the + -- corresponding expanded package. + + if Nkind (N) = N_Formal_Package_Declaration then + Act_Decl_Id := New_Copy (Defining_Entity (N)); + Set_Comes_From_Source (Act_Decl_Id, True); + Set_Is_Generic_Instance (Act_Decl_Id, False); + Set_Defining_Identifier (N, Act_Decl_Id); + end if; + + <> + Analyze_Aspect_Specifications + (N, Act_Decl_Id, Aspect_Specifications (N)); + + exception + when Instantiation_Error => + if Parent_Installed then + Remove_Parent; + end if; + + if Env_Installed then + Restore_Env; + end if; + end Analyze_Package_Instantiation; + + -------------------------- + -- Inline_Instance_Body -- + -------------------------- + + procedure Inline_Instance_Body + (N : Node_Id; + Gen_Unit : Entity_Id; + Act_Decl : Node_Id) + is + Vis : Boolean; + Gen_Comp : constant Entity_Id := + Cunit_Entity (Get_Source_Unit (Gen_Unit)); + Curr_Comp : constant Node_Id := Cunit (Current_Sem_Unit); + Curr_Scope : Entity_Id := Empty; + Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); + Removed : Boolean := False; + Num_Scopes : Int := 0; + + Scope_Stack_Depth : constant Int := + Scope_Stack.Last - Scope_Stack.First + 1; + + Use_Clauses : array (1 .. Scope_Stack_Depth) of Node_Id; + Instances : array (1 .. Scope_Stack_Depth) of Entity_Id; + Inner_Scopes : array (1 .. Scope_Stack_Depth) of Entity_Id; + Num_Inner : Int := 0; + N_Instances : Int := 0; + S : Entity_Id; + + begin + -- Case of generic unit defined in another unit. We must remove the + -- complete context of the current unit to install that of the generic. + + if Gen_Comp /= Cunit_Entity (Current_Sem_Unit) then + + -- Add some comments for the following two loops ??? + + S := Current_Scope; + while Present (S) and then S /= Standard_Standard loop + loop + Num_Scopes := Num_Scopes + 1; + + Use_Clauses (Num_Scopes) := + (Scope_Stack.Table + (Scope_Stack.Last - Num_Scopes + 1). + First_Use_Clause); + End_Use_Clauses (Use_Clauses (Num_Scopes)); + + exit when Scope_Stack.Last - Num_Scopes + 1 = Scope_Stack.First + or else Scope_Stack.Table + (Scope_Stack.Last - Num_Scopes).Entity + = Scope (S); + end loop; + + exit when Is_Generic_Instance (S) + and then (In_Package_Body (S) + or else Ekind (S) = E_Procedure + or else Ekind (S) = E_Function); + S := Scope (S); + end loop; + + Vis := Is_Immediately_Visible (Gen_Comp); + + -- Find and save all enclosing instances + + S := Current_Scope; + + while Present (S) + and then S /= Standard_Standard + loop + if Is_Generic_Instance (S) then + N_Instances := N_Instances + 1; + Instances (N_Instances) := S; + + exit when In_Package_Body (S); + end if; + + S := Scope (S); + end loop; + + -- Remove context of current compilation unit, unless we are within a + -- nested package instantiation, in which case the context has been + -- removed previously. + + -- If current scope is the body of a child unit, remove context of + -- spec as well. If an enclosing scope is an instance body, the + -- context has already been removed, but the entities in the body + -- must be made invisible as well. + + S := Current_Scope; + + while Present (S) + and then S /= Standard_Standard + loop + if Is_Generic_Instance (S) + and then (In_Package_Body (S) + or else Ekind (S) = E_Procedure + or else Ekind (S) = E_Function) + then + -- We still have to remove the entities of the enclosing + -- instance from direct visibility. + + declare + E : Entity_Id; + begin + E := First_Entity (S); + while Present (E) loop + Set_Is_Immediately_Visible (E, False); + Next_Entity (E); + end loop; + end; + + exit; + end if; + + if S = Curr_Unit + or else (Ekind (Curr_Unit) = E_Package_Body + and then S = Spec_Entity (Curr_Unit)) + or else (Ekind (Curr_Unit) = E_Subprogram_Body + and then S = + Corresponding_Spec + (Unit_Declaration_Node (Curr_Unit))) + then + Removed := True; + + -- Remove entities in current scopes from visibility, so that + -- instance body is compiled in a clean environment. + + Save_Scope_Stack (Handle_Use => False); + + if Is_Child_Unit (S) then + + -- Remove child unit from stack, as well as inner scopes. + -- Removing the context of a child unit removes parent units + -- as well. + + while Current_Scope /= S loop + Num_Inner := Num_Inner + 1; + Inner_Scopes (Num_Inner) := Current_Scope; + Pop_Scope; + end loop; + + Pop_Scope; + Remove_Context (Curr_Comp); + Curr_Scope := S; + + else + Remove_Context (Curr_Comp); + end if; + + if Ekind (Curr_Unit) = E_Package_Body then + Remove_Context (Library_Unit (Curr_Comp)); + end if; + end if; + + S := Scope (S); + end loop; + pragma Assert (Num_Inner < Num_Scopes); + + Push_Scope (Standard_Standard); + Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base := True; + Instantiate_Package_Body + (Body_Info => + ((Inst_Node => N, + Act_Decl => Act_Decl, + Expander_Status => Expander_Active, + Current_Sem_Unit => Current_Sem_Unit, + Scope_Suppress => Scope_Suppress, + Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, + Version => Ada_Version)), + Inlined_Body => True); + + Pop_Scope; + + -- Restore context + + Set_Is_Immediately_Visible (Gen_Comp, Vis); + + -- Reset Generic_Instance flag so that use clauses can be installed + -- in the proper order. (See Use_One_Package for effect of enclosing + -- instances on processing of use clauses). + + for J in 1 .. N_Instances loop + Set_Is_Generic_Instance (Instances (J), False); + end loop; + + if Removed then + Install_Context (Curr_Comp); + + if Present (Curr_Scope) + and then Is_Child_Unit (Curr_Scope) + then + Push_Scope (Curr_Scope); + Set_Is_Immediately_Visible (Curr_Scope); + + -- Finally, restore inner scopes as well + + for J in reverse 1 .. Num_Inner loop + Push_Scope (Inner_Scopes (J)); + end loop; + end if; + + Restore_Scope_Stack (Handle_Use => False); + + if Present (Curr_Scope) + and then + (In_Private_Part (Curr_Scope) + or else In_Package_Body (Curr_Scope)) + then + -- Install private declaration of ancestor units, which are + -- currently available. Restore_Scope_Stack and Install_Context + -- only install the visible part of parents. + + declare + Par : Entity_Id; + begin + Par := Scope (Curr_Scope); + while (Present (Par)) + and then Par /= Standard_Standard + loop + Install_Private_Declarations (Par); + Par := Scope (Par); + end loop; + end; + end if; + end if; + + -- Restore use clauses. For a child unit, use clauses in the parents + -- are restored when installing the context, so only those in inner + -- scopes (and those local to the child unit itself) need to be + -- installed explicitly. + + if Is_Child_Unit (Curr_Unit) + and then Removed + then + for J in reverse 1 .. Num_Inner + 1 loop + Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := + Use_Clauses (J); + Install_Use_Clauses (Use_Clauses (J)); + end loop; + + else + for J in reverse 1 .. Num_Scopes loop + Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := + Use_Clauses (J); + Install_Use_Clauses (Use_Clauses (J)); + end loop; + end if; + + -- Restore status of instances. If one of them is a body, make + -- its local entities visible again. + + declare + E : Entity_Id; + Inst : Entity_Id; + + begin + for J in 1 .. N_Instances loop + Inst := Instances (J); + Set_Is_Generic_Instance (Inst, True); + + if In_Package_Body (Inst) + or else Ekind (S) = E_Procedure + or else Ekind (S) = E_Function + then + E := First_Entity (Instances (J)); + while Present (E) loop + Set_Is_Immediately_Visible (E); + Next_Entity (E); + end loop; + end if; + end loop; + end; + + -- If generic unit is in current unit, current context is correct + + else + Instantiate_Package_Body + (Body_Info => + ((Inst_Node => N, + Act_Decl => Act_Decl, + Expander_Status => Expander_Active, + Current_Sem_Unit => Current_Sem_Unit, + Scope_Suppress => Scope_Suppress, + Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, + Version => Ada_Version)), + Inlined_Body => True); + end if; + end Inline_Instance_Body; + + ------------------------------------- + -- Analyze_Procedure_Instantiation -- + ------------------------------------- + + procedure Analyze_Procedure_Instantiation (N : Node_Id) is + begin + Analyze_Subprogram_Instantiation (N, E_Procedure); + end Analyze_Procedure_Instantiation; + + ----------------------------------- + -- Need_Subprogram_Instance_Body -- + ----------------------------------- + + function Need_Subprogram_Instance_Body + (N : Node_Id; + Subp : Entity_Id) return Boolean + is + begin + if (Is_In_Main_Unit (N) + or else Is_Inlined (Subp) + or else Is_Inlined (Alias (Subp))) + and then (Operating_Mode = Generate_Code + or else (Operating_Mode = Check_Semantics + and then ASIS_Mode)) + and then (Expander_Active or else ASIS_Mode) + and then not ABE_Is_Certain (N) + and then not Is_Eliminated (Subp) + then + Pending_Instantiations.Append + ((Inst_Node => N, + Act_Decl => Unit_Declaration_Node (Subp), + Expander_Status => Expander_Active, + Current_Sem_Unit => Current_Sem_Unit, + Scope_Suppress => Scope_Suppress, + Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, + Version => Ada_Version)); + return True; + else + return False; + end if; + end Need_Subprogram_Instance_Body; + + -------------------------------------- + -- Analyze_Subprogram_Instantiation -- + -------------------------------------- + + procedure Analyze_Subprogram_Instantiation + (N : Node_Id; + K : Entity_Kind) + is + Loc : constant Source_Ptr := Sloc (N); + Gen_Id : constant Node_Id := Name (N); + + Anon_Id : constant Entity_Id := + Make_Defining_Identifier (Sloc (Defining_Entity (N)), + Chars => New_External_Name + (Chars (Defining_Entity (N)), 'R')); + + Act_Decl_Id : Entity_Id; + Act_Decl : Node_Id; + Act_Spec : Node_Id; + Act_Tree : Node_Id; + + Env_Installed : Boolean := False; + Gen_Unit : Entity_Id; + Gen_Decl : Node_Id; + Pack_Id : Entity_Id; + Parent_Installed : Boolean := False; + Renaming_List : List_Id; + + procedure Analyze_Instance_And_Renamings; + -- The instance must be analyzed in a context that includes the mappings + -- of generic parameters into actuals. We create a package declaration + -- for this purpose, and a subprogram with an internal name within the + -- package. The subprogram instance is simply an alias for the internal + -- subprogram, declared in the current scope. + + ------------------------------------ + -- Analyze_Instance_And_Renamings -- + ------------------------------------ + + procedure Analyze_Instance_And_Renamings is + Def_Ent : constant Entity_Id := Defining_Entity (N); + Pack_Decl : Node_Id; + + begin + if Nkind (Parent (N)) = N_Compilation_Unit then + + -- For the case of a compilation unit, the container package has + -- the same name as the instantiation, to insure that the binder + -- calls the elaboration procedure with the right name. Copy the + -- entity of the instance, which may have compilation level flags + -- (e.g. Is_Child_Unit) set. + + Pack_Id := New_Copy (Def_Ent); + + else + -- Otherwise we use the name of the instantiation concatenated + -- with its source position to ensure uniqueness if there are + -- several instantiations with the same name. + + Pack_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name + (Related_Id => Chars (Def_Ent), + Suffix => "GP", + Suffix_Index => Source_Offset (Sloc (Def_Ent)))); + end if; + + Pack_Decl := Make_Package_Declaration (Loc, + Specification => Make_Package_Specification (Loc, + Defining_Unit_Name => Pack_Id, + Visible_Declarations => Renaming_List, + End_Label => Empty)); + + Set_Instance_Spec (N, Pack_Decl); + Set_Is_Generic_Instance (Pack_Id); + Set_Debug_Info_Needed (Pack_Id); + + -- Case of not a compilation unit + + if Nkind (Parent (N)) /= N_Compilation_Unit then + Mark_Rewrite_Insertion (Pack_Decl); + Insert_Before (N, Pack_Decl); + Set_Has_Completion (Pack_Id); + + -- Case of an instantiation that is a compilation unit + + -- Place declaration on current node so context is complete for + -- analysis (including nested instantiations), and for use in a + -- context_clause (see Analyze_With_Clause). + + else + Set_Unit (Parent (N), Pack_Decl); + Set_Parent_Spec (Pack_Decl, Parent_Spec (N)); + end if; + + Analyze (Pack_Decl); + Check_Formal_Packages (Pack_Id); + Set_Is_Generic_Instance (Pack_Id, False); + + -- Why do we clear Is_Generic_Instance??? We set it 20 lines + -- above??? + + -- Body of the enclosing package is supplied when instantiating the + -- subprogram body, after semantic analysis is completed. + + if Nkind (Parent (N)) = N_Compilation_Unit then + + -- Remove package itself from visibility, so it does not + -- conflict with subprogram. + + Set_Name_Entity_Id (Chars (Pack_Id), Homonym (Pack_Id)); + + -- Set name and scope of internal subprogram so that the proper + -- external name will be generated. The proper scope is the scope + -- of the wrapper package. We need to generate debugging info for + -- the internal subprogram, so set flag accordingly. + + Set_Chars (Anon_Id, Chars (Defining_Entity (N))); + Set_Scope (Anon_Id, Scope (Pack_Id)); + + -- Mark wrapper package as referenced, to avoid spurious warnings + -- if the instantiation appears in various with_ clauses of + -- subunits of the main unit. + + Set_Referenced (Pack_Id); + end if; + + Set_Is_Generic_Instance (Anon_Id); + Set_Debug_Info_Needed (Anon_Id); + Act_Decl_Id := New_Copy (Anon_Id); + + Set_Parent (Act_Decl_Id, Parent (Anon_Id)); + Set_Chars (Act_Decl_Id, Chars (Defining_Entity (N))); + Set_Sloc (Act_Decl_Id, Sloc (Defining_Entity (N))); + Set_Comes_From_Source (Act_Decl_Id, True); + + -- The signature may involve types that are not frozen yet, but the + -- subprogram will be frozen at the point the wrapper package is + -- frozen, so it does not need its own freeze node. In fact, if one + -- is created, it might conflict with the freezing actions from the + -- wrapper package. + + Set_Has_Delayed_Freeze (Anon_Id, False); + + -- If the instance is a child unit, mark the Id accordingly. Mark + -- the anonymous entity as well, which is the real subprogram and + -- which is used when the instance appears in a context clause. + -- Similarly, propagate the Is_Eliminated flag to handle properly + -- nested eliminated subprograms. + + Set_Is_Child_Unit (Act_Decl_Id, Is_Child_Unit (Defining_Entity (N))); + Set_Is_Child_Unit (Anon_Id, Is_Child_Unit (Defining_Entity (N))); + New_Overloaded_Entity (Act_Decl_Id); + Check_Eliminated (Act_Decl_Id); + Set_Is_Eliminated (Anon_Id, Is_Eliminated (Act_Decl_Id)); + + -- In compilation unit case, kill elaboration checks on the + -- instantiation, since they are never needed -- the body is + -- instantiated at the same point as the spec. + + if Nkind (Parent (N)) = N_Compilation_Unit then + Set_Suppress_Elaboration_Warnings (Act_Decl_Id); + Set_Kill_Elaboration_Checks (Act_Decl_Id); + Set_Is_Compilation_Unit (Anon_Id); + + Set_Cunit_Entity (Current_Sem_Unit, Pack_Id); + end if; + + -- The instance is not a freezing point for the new subprogram + + Set_Is_Frozen (Act_Decl_Id, False); + + if Nkind (Defining_Entity (N)) = N_Defining_Operator_Symbol then + Valid_Operator_Definition (Act_Decl_Id); + end if; + + Set_Alias (Act_Decl_Id, Anon_Id); + Set_Parent (Act_Decl_Id, Parent (Anon_Id)); + Set_Has_Completion (Act_Decl_Id); + Set_Related_Instance (Pack_Id, Act_Decl_Id); + + if Nkind (Parent (N)) = N_Compilation_Unit then + Set_Body_Required (Parent (N), False); + end if; + end Analyze_Instance_And_Renamings; + + -- Start of processing for Analyze_Subprogram_Instantiation + + begin + -- Very first thing: apply the special kludge for Text_IO processing + -- in case we are instantiating one of the children of [Wide_]Text_IO. + -- Of course such an instantiation is bogus (these are packages, not + -- subprograms), but we get a better error message if we do this. + + Text_IO_Kludge (Gen_Id); + + -- Make node global for error reporting + + Instantiation_Node := N; + Preanalyze_Actuals (N); + + Init_Env; + Env_Installed := True; + Check_Generic_Child_Unit (Gen_Id, Parent_Installed); + Gen_Unit := Entity (Gen_Id); + + Generate_Reference (Gen_Unit, Gen_Id); + + if Nkind (Gen_Id) = N_Identifier + and then Chars (Gen_Unit) = Chars (Defining_Entity (N)) + then + Error_Msg_NE + ("& is hidden within declaration of instance", Gen_Id, Gen_Unit); + end if; + + if Etype (Gen_Unit) = Any_Type then + Restore_Env; + return; + end if; + + -- Verify that it is a generic subprogram of the right kind, and that + -- it does not lead to a circular instantiation. + + if not Ekind_In (Gen_Unit, E_Generic_Procedure, E_Generic_Function) then + Error_Msg_N ("expect generic subprogram in instantiation", Gen_Id); + + elsif In_Open_Scopes (Gen_Unit) then + Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit); + + elsif K = E_Procedure + and then Ekind (Gen_Unit) /= E_Generic_Procedure + then + if Ekind (Gen_Unit) = E_Generic_Function then + Error_Msg_N + ("cannot instantiate generic function as procedure", Gen_Id); + else + Error_Msg_N + ("expect name of generic procedure in instantiation", Gen_Id); + end if; + + elsif K = E_Function + and then Ekind (Gen_Unit) /= E_Generic_Function + then + if Ekind (Gen_Unit) = E_Generic_Procedure then + Error_Msg_N + ("cannot instantiate generic procedure as function", Gen_Id); + else + Error_Msg_N + ("expect name of generic function in instantiation", Gen_Id); + end if; + + else + Set_Entity (Gen_Id, Gen_Unit); + Set_Is_Instantiated (Gen_Unit); + + if In_Extended_Main_Source_Unit (N) then + Generate_Reference (Gen_Unit, N); + end if; + + -- If renaming, get original unit + + if Present (Renamed_Object (Gen_Unit)) + and then (Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Procedure + or else + Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Function) + then + Gen_Unit := Renamed_Object (Gen_Unit); + Set_Is_Instantiated (Gen_Unit); + Generate_Reference (Gen_Unit, N); + end if; + + if Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then + Error_Msg_Node_2 := Current_Scope; + Error_Msg_NE + ("circular Instantiation: & instantiated in &!", N, Gen_Unit); + Circularity_Detected := True; + goto Leave; + end if; + + Gen_Decl := Unit_Declaration_Node (Gen_Unit); + + -- Initialize renamings map, for error checking + + Generic_Renamings.Set_Last (0); + Generic_Renamings_HTable.Reset; + + Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment); + + -- Copy original generic tree, to produce text for instantiation + + Act_Tree := + Copy_Generic_Node + (Original_Node (Gen_Decl), Empty, Instantiating => True); + + -- Inherit overriding indicator from instance node + + Act_Spec := Specification (Act_Tree); + Set_Must_Override (Act_Spec, Must_Override (N)); + Set_Must_Not_Override (Act_Spec, Must_Not_Override (N)); + + Renaming_List := + Analyze_Associations + (N, + Generic_Formal_Declarations (Act_Tree), + Generic_Formal_Declarations (Gen_Decl)); + + -- The subprogram itself cannot contain a nested instance, so the + -- current parent is left empty. + + Set_Instance_Env (Gen_Unit, Empty); + + -- Build the subprogram declaration, which does not appear in the + -- generic template, and give it a sloc consistent with that of the + -- template. + + Set_Defining_Unit_Name (Act_Spec, Anon_Id); + Set_Generic_Parent (Act_Spec, Gen_Unit); + Act_Decl := + Make_Subprogram_Declaration (Sloc (Act_Spec), + Specification => Act_Spec); + + Set_Categorization_From_Pragmas (Act_Decl); + + if Parent_Installed then + Hide_Current_Scope; + end if; + + Append (Act_Decl, Renaming_List); + Analyze_Instance_And_Renamings; + + -- If the generic is marked Import (Intrinsic), then so is the + -- instance. This indicates that there is no body to instantiate. If + -- generic is marked inline, so it the instance, and the anonymous + -- subprogram it renames. If inlined, or else if inlining is enabled + -- for the compilation, we generate the instance body even if it is + -- not within the main unit. + + -- Any other pragmas might also be inherited ??? + + if Is_Intrinsic_Subprogram (Gen_Unit) then + Set_Is_Intrinsic_Subprogram (Anon_Id); + Set_Is_Intrinsic_Subprogram (Act_Decl_Id); + + if Chars (Gen_Unit) = Name_Unchecked_Conversion then + Validate_Unchecked_Conversion (N, Act_Decl_Id); + end if; + end if; + + Generate_Definition (Act_Decl_Id); + + Set_Is_Inlined (Act_Decl_Id, Is_Inlined (Gen_Unit)); + Set_Is_Inlined (Anon_Id, Is_Inlined (Gen_Unit)); + + if not Is_Intrinsic_Subprogram (Gen_Unit) then + Check_Elab_Instantiation (N); + end if; + + if Is_Dispatching_Operation (Act_Decl_Id) + and then Ada_Version >= Ada_2005 + then + declare + Formal : Entity_Id; + + begin + Formal := First_Formal (Act_Decl_Id); + while Present (Formal) loop + if Ekind (Etype (Formal)) = E_Anonymous_Access_Type + and then Is_Controlling_Formal (Formal) + and then not Can_Never_Be_Null (Formal) + then + Error_Msg_NE ("access parameter& is controlling,", + N, Formal); + Error_Msg_NE + ("\corresponding parameter of & must be" + & " explicitly null-excluding", N, Gen_Id); + end if; + + Next_Formal (Formal); + end loop; + end; + end if; + + Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id); + + -- Subject to change, pending on if other pragmas are inherited ??? + + Validate_Categorization_Dependency (N, Act_Decl_Id); + + if not Is_Intrinsic_Subprogram (Act_Decl_Id) then + Inherit_Context (Gen_Decl, N); + + Restore_Private_Views (Pack_Id, False); + + -- If the context requires a full instantiation, mark node for + -- subsequent construction of the body. + + if Need_Subprogram_Instance_Body (N, Act_Decl_Id) then + + Check_Forward_Instantiation (Gen_Decl); + + -- The wrapper package is always delayed, because it does not + -- constitute a freeze point, but to insure that the freeze + -- node is placed properly, it is created directly when + -- instantiating the body (otherwise the freeze node might + -- appear to early for nested instantiations). + + elsif Nkind (Parent (N)) = N_Compilation_Unit then + + -- For ASIS purposes, indicate that the wrapper package has + -- replaced the instantiation node. + + Rewrite (N, Unit (Parent (N))); + Set_Unit (Parent (N), N); + end if; + + elsif Nkind (Parent (N)) = N_Compilation_Unit then + + -- Replace instance node for library-level instantiations of + -- intrinsic subprograms, for ASIS use. + + Rewrite (N, Unit (Parent (N))); + Set_Unit (Parent (N), N); + end if; + + if Parent_Installed then + Remove_Parent; + end if; + + Restore_Env; + Env_Installed := False; + Generic_Renamings.Set_Last (0); + Generic_Renamings_HTable.Reset; + end if; + + <> + Analyze_Aspect_Specifications + (N, Act_Decl_Id, Aspect_Specifications (N)); + + exception + when Instantiation_Error => + if Parent_Installed then + Remove_Parent; + end if; + + if Env_Installed then + Restore_Env; + end if; + end Analyze_Subprogram_Instantiation; + + ------------------------- + -- Get_Associated_Node -- + ------------------------- + + function Get_Associated_Node (N : Node_Id) return Node_Id is + Assoc : Node_Id; + + begin + Assoc := Associated_Node (N); + + if Nkind (Assoc) /= Nkind (N) then + return Assoc; + + elsif Nkind_In (Assoc, N_Aggregate, N_Extension_Aggregate) then + return Assoc; + + else + -- If the node is part of an inner generic, it may itself have been + -- remapped into a further generic copy. Associated_Node is otherwise + -- used for the entity of the node, and will be of a different node + -- kind, or else N has been rewritten as a literal or function call. + + while Present (Associated_Node (Assoc)) + and then Nkind (Associated_Node (Assoc)) = Nkind (Assoc) + loop + Assoc := Associated_Node (Assoc); + end loop; + + -- Follow and additional link in case the final node was rewritten. + -- This can only happen with nested generic units. + + if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op) + and then Present (Associated_Node (Assoc)) + and then (Nkind_In (Associated_Node (Assoc), N_Function_Call, + N_Explicit_Dereference, + N_Integer_Literal, + N_Real_Literal, + N_String_Literal)) + then + Assoc := Associated_Node (Assoc); + end if; + + return Assoc; + end if; + end Get_Associated_Node; + + ------------------------------------------- + -- Build_Instance_Compilation_Unit_Nodes -- + ------------------------------------------- + + procedure Build_Instance_Compilation_Unit_Nodes + (N : Node_Id; + Act_Body : Node_Id; + Act_Decl : Node_Id) + is + Decl_Cunit : Node_Id; + Body_Cunit : Node_Id; + Citem : Node_Id; + New_Main : constant Entity_Id := Defining_Entity (Act_Decl); + Old_Main : constant Entity_Id := Cunit_Entity (Main_Unit); + + begin + -- A new compilation unit node is built for the instance declaration + + Decl_Cunit := + Make_Compilation_Unit (Sloc (N), + Context_Items => Empty_List, + Unit => Act_Decl, + Aux_Decls_Node => + Make_Compilation_Unit_Aux (Sloc (N))); + + Set_Parent_Spec (Act_Decl, Parent_Spec (N)); + + -- The new compilation unit is linked to its body, but both share the + -- same file, so we do not set Body_Required on the new unit so as not + -- to create a spurious dependency on a non-existent body in the ali. + -- This simplifies CodePeer unit traversal. + + -- We use the original instantiation compilation unit as the resulting + -- compilation unit of the instance, since this is the main unit. + + Rewrite (N, Act_Body); + Body_Cunit := Parent (N); + + -- The two compilation unit nodes are linked by the Library_Unit field + + Set_Library_Unit (Decl_Cunit, Body_Cunit); + Set_Library_Unit (Body_Cunit, Decl_Cunit); + + -- Preserve the private nature of the package if needed + + Set_Private_Present (Decl_Cunit, Private_Present (Body_Cunit)); + + -- If the instance is not the main unit, its context, categorization + -- and elaboration entity are not relevant to the compilation. + + if Body_Cunit /= Cunit (Main_Unit) then + Make_Instance_Unit (Body_Cunit, In_Main => False); + return; + end if; + + -- The context clause items on the instantiation, which are now attached + -- to the body compilation unit (since the body overwrote the original + -- instantiation node), semantically belong on the spec, so copy them + -- there. It's harmless to leave them on the body as well. In fact one + -- could argue that they belong in both places. + + Citem := First (Context_Items (Body_Cunit)); + while Present (Citem) loop + Append (New_Copy (Citem), Context_Items (Decl_Cunit)); + Next (Citem); + end loop; + + -- Propagate categorization flags on packages, so that they appear in + -- the ali file for the spec of the unit. + + if Ekind (New_Main) = E_Package then + Set_Is_Pure (Old_Main, Is_Pure (New_Main)); + Set_Is_Preelaborated (Old_Main, Is_Preelaborated (New_Main)); + Set_Is_Remote_Types (Old_Main, Is_Remote_Types (New_Main)); + Set_Is_Shared_Passive (Old_Main, Is_Shared_Passive (New_Main)); + Set_Is_Remote_Call_Interface + (Old_Main, Is_Remote_Call_Interface (New_Main)); + end if; + + -- Make entry in Units table, so that binder can generate call to + -- elaboration procedure for body, if any. + + Make_Instance_Unit (Body_Cunit, In_Main => True); + Main_Unit_Entity := New_Main; + Set_Cunit_Entity (Main_Unit, Main_Unit_Entity); + + -- Build elaboration entity, since the instance may certainly generate + -- elaboration code requiring a flag for protection. + + Build_Elaboration_Entity (Decl_Cunit, New_Main); + end Build_Instance_Compilation_Unit_Nodes; + + ----------------------------- + -- Check_Access_Definition -- + ----------------------------- + + procedure Check_Access_Definition (N : Node_Id) is + begin + pragma Assert + (Ada_Version >= Ada_2005 + and then Present (Access_Definition (N))); + null; + end Check_Access_Definition; + + ----------------------------------- + -- Check_Formal_Package_Instance -- + ----------------------------------- + + -- If the formal has specific parameters, they must match those of the + -- actual. Both of them are instances, and the renaming declarations for + -- their formal parameters appear in the same order in both. The analyzed + -- formal has been analyzed in the context of the current instance. + + procedure Check_Formal_Package_Instance + (Formal_Pack : Entity_Id; + Actual_Pack : Entity_Id) + is + E1 : Entity_Id := First_Entity (Actual_Pack); + E2 : Entity_Id := First_Entity (Formal_Pack); + + Expr1 : Node_Id; + Expr2 : Node_Id; + + procedure Check_Mismatch (B : Boolean); + -- Common error routine for mismatch between the parameters of the + -- actual instance and those of the formal package. + + function Same_Instantiated_Constant (E1, E2 : Entity_Id) return Boolean; + -- The formal may come from a nested formal package, and the actual may + -- have been constant-folded. To determine whether the two denote the + -- same entity we may have to traverse several definitions to recover + -- the ultimate entity that they refer to. + + function Same_Instantiated_Variable (E1, E2 : Entity_Id) return Boolean; + -- Similarly, if the formal comes from a nested formal package, the + -- actual may designate the formal through multiple renamings, which + -- have to be followed to determine the original variable in question. + + -------------------- + -- Check_Mismatch -- + -------------------- + + procedure Check_Mismatch (B : Boolean) is + Kind : constant Node_Kind := Nkind (Parent (E2)); + + begin + if Kind = N_Formal_Type_Declaration then + return; + + elsif Nkind_In (Kind, N_Formal_Object_Declaration, + N_Formal_Package_Declaration) + or else Kind in N_Formal_Subprogram_Declaration + then + null; + + elsif B then + Error_Msg_NE + ("actual for & in actual instance does not match formal", + Parent (Actual_Pack), E1); + end if; + end Check_Mismatch; + + -------------------------------- + -- Same_Instantiated_Constant -- + -------------------------------- + + function Same_Instantiated_Constant + (E1, E2 : Entity_Id) return Boolean + is + Ent : Entity_Id; + + begin + Ent := E2; + while Present (Ent) loop + if E1 = Ent then + return True; + + elsif Ekind (Ent) /= E_Constant then + return False; + + elsif Is_Entity_Name (Constant_Value (Ent)) then + if Entity (Constant_Value (Ent)) = E1 then + return True; + else + Ent := Entity (Constant_Value (Ent)); + end if; + + -- The actual may be a constant that has been folded. Recover + -- original name. + + elsif Is_Entity_Name (Original_Node (Constant_Value (Ent))) then + Ent := Entity (Original_Node (Constant_Value (Ent))); + else + return False; + end if; + end loop; + + return False; + end Same_Instantiated_Constant; + + -------------------------------- + -- Same_Instantiated_Variable -- + -------------------------------- + + function Same_Instantiated_Variable + (E1, E2 : Entity_Id) return Boolean + is + function Original_Entity (E : Entity_Id) return Entity_Id; + -- Follow chain of renamings to the ultimate ancestor + + --------------------- + -- Original_Entity -- + --------------------- + + function Original_Entity (E : Entity_Id) return Entity_Id is + Orig : Entity_Id; + + begin + Orig := E; + while Nkind (Parent (Orig)) = N_Object_Renaming_Declaration + and then Present (Renamed_Object (Orig)) + and then Is_Entity_Name (Renamed_Object (Orig)) + loop + Orig := Entity (Renamed_Object (Orig)); + end loop; + + return Orig; + end Original_Entity; + + -- Start of processing for Same_Instantiated_Variable + + begin + return Ekind (E1) = Ekind (E2) + and then Original_Entity (E1) = Original_Entity (E2); + end Same_Instantiated_Variable; + + -- Start of processing for Check_Formal_Package_Instance + + begin + while Present (E1) + and then Present (E2) + loop + exit when Ekind (E1) = E_Package + and then Renamed_Entity (E1) = Renamed_Entity (Actual_Pack); + + -- If the formal is the renaming of the formal package, this + -- is the end of its formal part, which may occur before the + -- end of the formal part in the actual in the presence of + -- defaulted parameters in the formal package. + + exit when Nkind (Parent (E2)) = N_Package_Renaming_Declaration + and then Renamed_Entity (E2) = Scope (E2); + + -- The analysis of the actual may generate additional internal + -- entities. If the formal is defaulted, there is no corresponding + -- analysis and the internal entities must be skipped, until we + -- find corresponding entities again. + + if Comes_From_Source (E2) + and then not Comes_From_Source (E1) + and then Chars (E1) /= Chars (E2) + then + while Present (E1) + and then Chars (E1) /= Chars (E2) + loop + Next_Entity (E1); + end loop; + end if; + + if No (E1) then + return; + + -- If the formal entity comes from a formal declaration, it was + -- defaulted in the formal package, and no check is needed on it. + + elsif Nkind (Parent (E2)) = N_Formal_Object_Declaration then + goto Next_E; + + elsif Is_Type (E1) then + + -- Subtypes must statically match. E1, E2 are the local entities + -- that are subtypes of the actuals. Itypes generated for other + -- parameters need not be checked, the check will be performed + -- on the parameters themselves. + + -- If E2 is a formal type declaration, it is a defaulted parameter + -- and needs no checking. + + if not Is_Itype (E1) + and then not Is_Itype (E2) + then + Check_Mismatch + (not Is_Type (E2) + or else Etype (E1) /= Etype (E2) + or else not Subtypes_Statically_Match (E1, E2)); + end if; + + elsif Ekind (E1) = E_Constant then + + -- IN parameters must denote the same static value, or the same + -- constant, or the literal null. + + Expr1 := Expression (Parent (E1)); + + if Ekind (E2) /= E_Constant then + Check_Mismatch (True); + goto Next_E; + else + Expr2 := Expression (Parent (E2)); + end if; + + if Is_Static_Expression (Expr1) then + + if not Is_Static_Expression (Expr2) then + Check_Mismatch (True); + + elsif Is_Discrete_Type (Etype (E1)) then + declare + V1 : constant Uint := Expr_Value (Expr1); + V2 : constant Uint := Expr_Value (Expr2); + begin + Check_Mismatch (V1 /= V2); + end; + + elsif Is_Real_Type (Etype (E1)) then + declare + V1 : constant Ureal := Expr_Value_R (Expr1); + V2 : constant Ureal := Expr_Value_R (Expr2); + begin + Check_Mismatch (V1 /= V2); + end; + + elsif Is_String_Type (Etype (E1)) + and then Nkind (Expr1) = N_String_Literal + then + if Nkind (Expr2) /= N_String_Literal then + Check_Mismatch (True); + else + Check_Mismatch + (not String_Equal (Strval (Expr1), Strval (Expr2))); + end if; + end if; + + elsif Is_Entity_Name (Expr1) then + if Is_Entity_Name (Expr2) then + if Entity (Expr1) = Entity (Expr2) then + null; + else + Check_Mismatch + (not Same_Instantiated_Constant + (Entity (Expr1), Entity (Expr2))); + end if; + else + Check_Mismatch (True); + end if; + + elsif Is_Entity_Name (Original_Node (Expr1)) + and then Is_Entity_Name (Expr2) + and then + Same_Instantiated_Constant + (Entity (Original_Node (Expr1)), Entity (Expr2)) + then + null; + + elsif Nkind (Expr1) = N_Null then + Check_Mismatch (Nkind (Expr1) /= N_Null); + + else + Check_Mismatch (True); + end if; + + elsif Ekind (E1) = E_Variable then + Check_Mismatch (not Same_Instantiated_Variable (E1, E2)); + + elsif Ekind (E1) = E_Package then + Check_Mismatch + (Ekind (E1) /= Ekind (E2) + or else Renamed_Object (E1) /= Renamed_Object (E2)); + + elsif Is_Overloadable (E1) then + + -- Verify that the actual subprograms match. Note that actuals + -- that are attributes are rewritten as subprograms. If the + -- subprogram in the formal package is defaulted, no check is + -- needed. Note that this can only happen in Ada 2005 when the + -- formal package can be partially parameterized. + + if Nkind (Unit_Declaration_Node (E1)) = + N_Subprogram_Renaming_Declaration + and then From_Default (Unit_Declaration_Node (E1)) + then + null; + + else + Check_Mismatch + (Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2)); + end if; + + else + raise Program_Error; + end if; + + <> + Next_Entity (E1); + Next_Entity (E2); + end loop; + end Check_Formal_Package_Instance; + + --------------------------- + -- Check_Formal_Packages -- + --------------------------- + + procedure Check_Formal_Packages (P_Id : Entity_Id) is + E : Entity_Id; + Formal_P : Entity_Id; + + begin + -- Iterate through the declarations in the instance, looking for package + -- renaming declarations that denote instances of formal packages. Stop + -- when we find the renaming of the current package itself. The + -- declaration for a formal package without a box is followed by an + -- internal entity that repeats the instantiation. + + E := First_Entity (P_Id); + while Present (E) loop + if Ekind (E) = E_Package then + if Renamed_Object (E) = P_Id then + exit; + + elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then + null; + + elsif not Box_Present (Parent (Associated_Formal_Package (E))) then + Formal_P := Next_Entity (E); + Check_Formal_Package_Instance (Formal_P, E); + + -- After checking, remove the internal validating package. It + -- is only needed for semantic checks, and as it may contain + -- generic formal declarations it should not reach gigi. + + Remove (Unit_Declaration_Node (Formal_P)); + end if; + end if; + + Next_Entity (E); + end loop; + end Check_Formal_Packages; + + --------------------------------- + -- Check_Forward_Instantiation -- + --------------------------------- + + procedure Check_Forward_Instantiation (Decl : Node_Id) is + S : Entity_Id; + Gen_Comp : Entity_Id := Cunit_Entity (Get_Source_Unit (Decl)); + + begin + -- The instantiation appears before the generic body if we are in the + -- scope of the unit containing the generic, either in its spec or in + -- the package body, and before the generic body. + + if Ekind (Gen_Comp) = E_Package_Body then + Gen_Comp := Spec_Entity (Gen_Comp); + end if; + + if In_Open_Scopes (Gen_Comp) + and then No (Corresponding_Body (Decl)) + then + S := Current_Scope; + + while Present (S) + and then not Is_Compilation_Unit (S) + and then not Is_Child_Unit (S) + loop + if Ekind (S) = E_Package then + Set_Has_Forward_Instantiation (S); + end if; + + S := Scope (S); + end loop; + end if; + end Check_Forward_Instantiation; + + --------------------------- + -- Check_Generic_Actuals -- + --------------------------- + + -- The visibility of the actuals may be different between the point of + -- generic instantiation and the instantiation of the body. + + procedure Check_Generic_Actuals + (Instance : Entity_Id; + Is_Formal_Box : Boolean) + is + E : Entity_Id; + Astype : Entity_Id; + + function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean; + -- For a formal that is an array type, the component type is often a + -- previous formal in the same unit. The privacy status of the component + -- type will have been examined earlier in the traversal of the + -- corresponding actuals, and this status should not be modified for the + -- array type itself. + -- + -- To detect this case we have to rescan the list of formals, which + -- is usually short enough to ignore the resulting inefficiency. + + ----------------------------- + -- Denotes_Previous_Actual -- + ----------------------------- + + function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean is + Prev : Entity_Id; + + begin + Prev := First_Entity (Instance); + while Present (Prev) loop + if Is_Type (Prev) + and then Nkind (Parent (Prev)) = N_Subtype_Declaration + and then Is_Entity_Name (Subtype_Indication (Parent (Prev))) + and then Entity (Subtype_Indication (Parent (Prev))) = Typ + then + return True; + + elsif Prev = E then + return False; + + else + Next_Entity (Prev); + end if; + end loop; + + return False; + end Denotes_Previous_Actual; + + -- Start of processing for Check_Generic_Actuals + + begin + E := First_Entity (Instance); + while Present (E) loop + if Is_Type (E) + and then Nkind (Parent (E)) = N_Subtype_Declaration + and then Scope (Etype (E)) /= Instance + and then Is_Entity_Name (Subtype_Indication (Parent (E))) + then + if Is_Array_Type (E) + and then Denotes_Previous_Actual (Component_Type (E)) + then + null; + else + Check_Private_View (Subtype_Indication (Parent (E))); + end if; + Set_Is_Generic_Actual_Type (E, True); + Set_Is_Hidden (E, False); + Set_Is_Potentially_Use_Visible (E, + In_Use (Instance)); + + -- We constructed the generic actual type as a subtype of the + -- supplied type. This means that it normally would not inherit + -- subtype specific attributes of the actual, which is wrong for + -- the generic case. + + Astype := Ancestor_Subtype (E); + + if No (Astype) then + + -- This can happen when E is an itype that is the full view of + -- a private type completed, e.g. with a constrained array. In + -- that case, use the first subtype, which will carry size + -- information. The base type itself is unconstrained and will + -- not carry it. + + Astype := First_Subtype (E); + end if; + + Set_Size_Info (E, (Astype)); + Set_RM_Size (E, RM_Size (Astype)); + Set_First_Rep_Item (E, First_Rep_Item (Astype)); + + if Is_Discrete_Or_Fixed_Point_Type (E) then + Set_RM_Size (E, RM_Size (Astype)); + + -- In nested instances, the base type of an access actual + -- may itself be private, and need to be exchanged. + + elsif Is_Access_Type (E) + and then Is_Private_Type (Etype (E)) + then + Check_Private_View + (New_Occurrence_Of (Etype (E), Sloc (Instance))); + end if; + + elsif Ekind (E) = E_Package then + + -- If this is the renaming for the current instance, we're done. + -- Otherwise it is a formal package. If the corresponding formal + -- was declared with a box, the (instantiations of the) generic + -- formal part are also visible. Otherwise, ignore the entity + -- created to validate the actuals. + + if Renamed_Object (E) = Instance then + exit; + + elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then + null; + + -- The visibility of a formal of an enclosing generic is already + -- correct. + + elsif Denotes_Formal_Package (E) then + null; + + elsif Present (Associated_Formal_Package (E)) + and then not Is_Generic_Formal (E) + then + if Box_Present (Parent (Associated_Formal_Package (E))) then + Check_Generic_Actuals (Renamed_Object (E), True); + + else + Check_Generic_Actuals (Renamed_Object (E), False); + end if; + + Set_Is_Hidden (E, False); + end if; + + -- If this is a subprogram instance (in a wrapper package) the + -- actual is fully visible. + + elsif Is_Wrapper_Package (Instance) then + Set_Is_Hidden (E, False); + + -- If the formal package is declared with a box, or if the formal + -- parameter is defaulted, it is visible in the body. + + elsif Is_Formal_Box + or else Is_Visible_Formal (E) + then + Set_Is_Hidden (E, False); + end if; + + Next_Entity (E); + end loop; + end Check_Generic_Actuals; + + ------------------------------ + -- Check_Generic_Child_Unit -- + ------------------------------ + + procedure Check_Generic_Child_Unit + (Gen_Id : Node_Id; + Parent_Installed : in out Boolean) + is + Loc : constant Source_Ptr := Sloc (Gen_Id); + Gen_Par : Entity_Id := Empty; + E : Entity_Id; + Inst_Par : Entity_Id; + S : Node_Id; + + function Find_Generic_Child + (Scop : Entity_Id; + Id : Node_Id) return Entity_Id; + -- Search generic parent for possible child unit with the given name + + function In_Enclosing_Instance return Boolean; + -- Within an instance of the parent, the child unit may be denoted + -- by a simple name, or an abbreviated expanded name. Examine enclosing + -- scopes to locate a possible parent instantiation. + + ------------------------ + -- Find_Generic_Child -- + ------------------------ + + function Find_Generic_Child + (Scop : Entity_Id; + Id : Node_Id) return Entity_Id + is + E : Entity_Id; + + begin + -- If entity of name is already set, instance has already been + -- resolved, e.g. in an enclosing instantiation. + + if Present (Entity (Id)) then + if Scope (Entity (Id)) = Scop then + return Entity (Id); + else + return Empty; + end if; + + else + E := First_Entity (Scop); + while Present (E) loop + if Chars (E) = Chars (Id) + and then Is_Child_Unit (E) + then + if Is_Child_Unit (E) + and then not Is_Visible_Child_Unit (E) + then + Error_Msg_NE + ("generic child unit& is not visible", Gen_Id, E); + end if; + + Set_Entity (Id, E); + return E; + end if; + + Next_Entity (E); + end loop; + + return Empty; + end if; + end Find_Generic_Child; + + --------------------------- + -- In_Enclosing_Instance -- + --------------------------- + + function In_Enclosing_Instance return Boolean is + Enclosing_Instance : Node_Id; + Instance_Decl : Node_Id; + + begin + -- We do not inline any call that contains instantiations, except + -- for instantiations of Unchecked_Conversion, so if we are within + -- an inlined body the current instance does not require parents. + + if In_Inlined_Body then + pragma Assert (Chars (Gen_Id) = Name_Unchecked_Conversion); + return False; + end if; + + -- Loop to check enclosing scopes + + Enclosing_Instance := Current_Scope; + while Present (Enclosing_Instance) loop + Instance_Decl := Unit_Declaration_Node (Enclosing_Instance); + + if Ekind (Enclosing_Instance) = E_Package + and then Is_Generic_Instance (Enclosing_Instance) + and then Present + (Generic_Parent (Specification (Instance_Decl))) + then + -- Check whether the generic we are looking for is a child of + -- this instance. + + E := Find_Generic_Child + (Generic_Parent (Specification (Instance_Decl)), Gen_Id); + exit when Present (E); + + else + E := Empty; + end if; + + Enclosing_Instance := Scope (Enclosing_Instance); + end loop; + + if No (E) then + + -- Not a child unit + + Analyze (Gen_Id); + return False; + + else + Rewrite (Gen_Id, + Make_Expanded_Name (Loc, + Chars => Chars (E), + Prefix => New_Occurrence_Of (Enclosing_Instance, Loc), + Selector_Name => New_Occurrence_Of (E, Loc))); + + Set_Entity (Gen_Id, E); + Set_Etype (Gen_Id, Etype (E)); + Parent_Installed := False; -- Already in scope. + return True; + end if; + end In_Enclosing_Instance; + + -- Start of processing for Check_Generic_Child_Unit + + begin + -- If the name of the generic is given by a selected component, it may + -- be the name of a generic child unit, and the prefix is the name of an + -- instance of the parent, in which case the child unit must be visible. + -- If this instance is not in scope, it must be placed there and removed + -- after instantiation, because what is being instantiated is not the + -- original child, but the corresponding child present in the instance + -- of the parent. + + -- If the child is instantiated within the parent, it can be given by + -- a simple name. In this case the instance is already in scope, but + -- the child generic must be recovered from the generic parent as well. + + if Nkind (Gen_Id) = N_Selected_Component then + S := Selector_Name (Gen_Id); + Analyze (Prefix (Gen_Id)); + Inst_Par := Entity (Prefix (Gen_Id)); + + if Ekind (Inst_Par) = E_Package + and then Present (Renamed_Object (Inst_Par)) + then + Inst_Par := Renamed_Object (Inst_Par); + end if; + + if Ekind (Inst_Par) = E_Package then + if Nkind (Parent (Inst_Par)) = N_Package_Specification then + Gen_Par := Generic_Parent (Parent (Inst_Par)); + + elsif Nkind (Parent (Inst_Par)) = N_Defining_Program_Unit_Name + and then + Nkind (Parent (Parent (Inst_Par))) = N_Package_Specification + then + Gen_Par := Generic_Parent (Parent (Parent (Inst_Par))); + end if; + + elsif Ekind (Inst_Par) = E_Generic_Package + and then Nkind (Parent (Gen_Id)) = N_Formal_Package_Declaration + then + -- A formal package may be a real child package, and not the + -- implicit instance within a parent. In this case the child is + -- not visible and has to be retrieved explicitly as well. + + Gen_Par := Inst_Par; + end if; + + if Present (Gen_Par) then + + -- The prefix denotes an instantiation. The entity itself may be a + -- nested generic, or a child unit. + + E := Find_Generic_Child (Gen_Par, S); + + if Present (E) then + Change_Selected_Component_To_Expanded_Name (Gen_Id); + Set_Entity (Gen_Id, E); + Set_Etype (Gen_Id, Etype (E)); + Set_Entity (S, E); + Set_Etype (S, Etype (E)); + + -- Indicate that this is a reference to the parent + + if In_Extended_Main_Source_Unit (Gen_Id) then + Set_Is_Instantiated (Inst_Par); + end if; + + -- A common mistake is to replicate the naming scheme of a + -- hierarchy by instantiating a generic child directly, rather + -- than the implicit child in a parent instance: + + -- generic .. package Gpar is .. + -- generic .. package Gpar.Child is .. + -- package Par is new Gpar (); + + -- with Gpar.Child; + -- package Par.Child is new Gpar.Child (); + -- rather than Par.Child + + -- In this case the instantiation is within Par, which is an + -- instance, but Gpar does not denote Par because we are not IN + -- the instance of Gpar, so this is illegal. The test below + -- recognizes this particular case. + + if Is_Child_Unit (E) + and then not Comes_From_Source (Entity (Prefix (Gen_Id))) + and then (not In_Instance + or else Nkind (Parent (Parent (Gen_Id))) = + N_Compilation_Unit) + then + Error_Msg_N + ("prefix of generic child unit must be instance of parent", + Gen_Id); + end if; + + if not In_Open_Scopes (Inst_Par) + and then Nkind (Parent (Gen_Id)) not in + N_Generic_Renaming_Declaration + then + Install_Parent (Inst_Par); + Parent_Installed := True; + + elsif In_Open_Scopes (Inst_Par) then + + -- If the parent is already installed, install the actuals + -- for its formal packages. This is necessary when the + -- child instance is a child of the parent instance: + -- in this case, the parent is placed on the scope stack + -- but the formal packages are not made visible. + + Install_Formal_Packages (Inst_Par); + end if; + + else + -- If the generic parent does not contain an entity that + -- corresponds to the selector, the instance doesn't either. + -- Analyzing the node will yield the appropriate error message. + -- If the entity is not a child unit, then it is an inner + -- generic in the parent. + + Analyze (Gen_Id); + end if; + + else + Analyze (Gen_Id); + + if Is_Child_Unit (Entity (Gen_Id)) + and then + Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration + and then not In_Open_Scopes (Inst_Par) + then + Install_Parent (Inst_Par); + Parent_Installed := True; + + -- The generic unit may be the renaming of the implicit child + -- present in an instance. In that case the parent instance is + -- obtained from the name of the renamed entity. + + elsif Ekind (Entity (Gen_Id)) = E_Generic_Package + and then Present (Renamed_Entity (Entity (Gen_Id))) + and then Is_Child_Unit (Renamed_Entity (Entity (Gen_Id))) + then + declare + Renamed_Package : constant Node_Id := + Name (Parent (Entity (Gen_Id))); + begin + if Nkind (Renamed_Package) = N_Expanded_Name then + Inst_Par := Entity (Prefix (Renamed_Package)); + Install_Parent (Inst_Par); + Parent_Installed := True; + end if; + end; + end if; + end if; + + elsif Nkind (Gen_Id) = N_Expanded_Name then + + -- Entity already present, analyze prefix, whose meaning may be + -- an instance in the current context. If it is an instance of + -- a relative within another, the proper parent may still have + -- to be installed, if they are not of the same generation. + + Analyze (Prefix (Gen_Id)); + + -- In the unlikely case that a local declaration hides the name + -- of the parent package, locate it on the homonym chain. If the + -- context is an instance of the parent, the renaming entity is + -- flagged as such. + + Inst_Par := Entity (Prefix (Gen_Id)); + while Present (Inst_Par) + and then not Is_Package_Or_Generic_Package (Inst_Par) + loop + Inst_Par := Homonym (Inst_Par); + end loop; + + pragma Assert (Present (Inst_Par)); + Set_Entity (Prefix (Gen_Id), Inst_Par); + + if In_Enclosing_Instance then + null; + + elsif Present (Entity (Gen_Id)) + and then Is_Child_Unit (Entity (Gen_Id)) + and then not In_Open_Scopes (Inst_Par) + then + Install_Parent (Inst_Par); + Parent_Installed := True; + end if; + + elsif In_Enclosing_Instance then + + -- The child unit is found in some enclosing scope + + null; + + else + Analyze (Gen_Id); + + -- If this is the renaming of the implicit child in a parent + -- instance, recover the parent name and install it. + + if Is_Entity_Name (Gen_Id) then + E := Entity (Gen_Id); + + if Is_Generic_Unit (E) + and then Nkind (Parent (E)) in N_Generic_Renaming_Declaration + and then Is_Child_Unit (Renamed_Object (E)) + and then Is_Generic_Unit (Scope (Renamed_Object (E))) + and then Nkind (Name (Parent (E))) = N_Expanded_Name + then + Rewrite (Gen_Id, + New_Copy_Tree (Name (Parent (E)))); + Inst_Par := Entity (Prefix (Gen_Id)); + + if not In_Open_Scopes (Inst_Par) then + Install_Parent (Inst_Par); + Parent_Installed := True; + end if; + + -- If it is a child unit of a non-generic parent, it may be + -- use-visible and given by a direct name. Install parent as + -- for other cases. + + elsif Is_Generic_Unit (E) + and then Is_Child_Unit (E) + and then + Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration + and then not Is_Generic_Unit (Scope (E)) + then + if not In_Open_Scopes (Scope (E)) then + Install_Parent (Scope (E)); + Parent_Installed := True; + end if; + end if; + end if; + end if; + end Check_Generic_Child_Unit; + + ----------------------------- + -- Check_Hidden_Child_Unit -- + ----------------------------- + + procedure Check_Hidden_Child_Unit + (N : Node_Id; + Gen_Unit : Entity_Id; + Act_Decl_Id : Entity_Id) + is + Gen_Id : constant Node_Id := Name (N); + + begin + if Is_Child_Unit (Gen_Unit) + and then Is_Child_Unit (Act_Decl_Id) + and then Nkind (Gen_Id) = N_Expanded_Name + and then Entity (Prefix (Gen_Id)) = Scope (Act_Decl_Id) + and then Chars (Gen_Unit) = Chars (Act_Decl_Id) + then + Error_Msg_Node_2 := Scope (Act_Decl_Id); + Error_Msg_NE + ("generic unit & is implicitly declared in &", + Defining_Unit_Name (N), Gen_Unit); + Error_Msg_N ("\instance must have different name", + Defining_Unit_Name (N)); + end if; + end Check_Hidden_Child_Unit; + + ------------------------ + -- Check_Private_View -- + ------------------------ + + procedure Check_Private_View (N : Node_Id) is + T : constant Entity_Id := Etype (N); + BT : Entity_Id; + + begin + -- Exchange views if the type was not private in the generic but is + -- private at the point of instantiation. Do not exchange views if + -- the scope of the type is in scope. This can happen if both generic + -- and instance are sibling units, or if type is defined in a parent. + -- In this case the visibility of the type will be correct for all + -- semantic checks. + + if Present (T) then + BT := Base_Type (T); + + if Is_Private_Type (T) + and then not Has_Private_View (N) + and then Present (Full_View (T)) + and then not In_Open_Scopes (Scope (T)) + then + -- In the generic, the full type was visible. Save the private + -- entity, for subsequent exchange. + + Switch_View (T); + + elsif Has_Private_View (N) + and then not Is_Private_Type (T) + and then not Has_Been_Exchanged (T) + and then Etype (Get_Associated_Node (N)) /= T + then + -- Only the private declaration was visible in the generic. If + -- the type appears in a subtype declaration, the subtype in the + -- instance must have a view compatible with that of its parent, + -- which must be exchanged (see corresponding code in Restore_ + -- Private_Views). Otherwise, if the type is defined in a parent + -- unit, leave full visibility within instance, which is safe. + + if In_Open_Scopes (Scope (Base_Type (T))) + and then not Is_Private_Type (Base_Type (T)) + and then Comes_From_Source (Base_Type (T)) + then + null; + + elsif Nkind (Parent (N)) = N_Subtype_Declaration + or else not In_Private_Part (Scope (Base_Type (T))) + then + Prepend_Elmt (T, Exchanged_Views); + Exchange_Declarations (Etype (Get_Associated_Node (N))); + end if; + + -- For composite types with inconsistent representation exchange + -- component types accordingly. + + elsif Is_Access_Type (T) + and then Is_Private_Type (Designated_Type (T)) + and then not Has_Private_View (N) + and then Present (Full_View (Designated_Type (T))) + and then Used_As_Generic_Actual (T) + then + Switch_View (Designated_Type (T)); + + elsif Is_Array_Type (T) then + if Is_Private_Type (Component_Type (T)) + and then not Has_Private_View (N) + and then Present (Full_View (Component_Type (T))) + then + Switch_View (Component_Type (T)); + end if; + + -- The normal exchange mechanism relies on the setting of a + -- flag on the reference in the generic. However, an additional + -- mechanism is needed for types that are not explicitly mentioned + -- in the generic, but may be needed in expanded code in the + -- instance. This includes component types of arrays and + -- designated types of access types. This processing must also + -- include the index types of arrays which we take care of here. + + declare + Indx : Node_Id; + Typ : Entity_Id; + + begin + Indx := First_Index (T); + Typ := Base_Type (Etype (Indx)); + while Present (Indx) loop + if Is_Private_Type (Typ) + and then Present (Full_View (Typ)) + then + Switch_View (Typ); + end if; + + Next_Index (Indx); + end loop; + end; + + elsif Is_Private_Type (T) + and then Present (Full_View (T)) + and then Is_Array_Type (Full_View (T)) + and then Is_Private_Type (Component_Type (Full_View (T))) + then + Switch_View (T); + + -- Finally, a non-private subtype may have a private base type, which + -- must be exchanged for consistency. This can happen when a package + -- body is instantiated, when the scope stack is empty but in fact + -- the subtype and the base type are declared in an enclosing scope. + + -- Note that in this case we introduce an inconsistency in the view + -- set, because we switch the base type BT, but there could be some + -- private dependent subtypes of BT which remain unswitched. Such + -- subtypes might need to be switched at a later point (see specific + -- provision for that case in Switch_View). + + elsif not Is_Private_Type (T) + and then not Has_Private_View (N) + and then Is_Private_Type (BT) + and then Present (Full_View (BT)) + and then not Is_Generic_Type (BT) + and then not In_Open_Scopes (BT) + then + Prepend_Elmt (Full_View (BT), Exchanged_Views); + Exchange_Declarations (BT); + end if; + end if; + end Check_Private_View; + + -------------------------- + -- Contains_Instance_Of -- + -------------------------- + + function Contains_Instance_Of + (Inner : Entity_Id; + Outer : Entity_Id; + N : Node_Id) return Boolean + is + Elmt : Elmt_Id; + Scop : Entity_Id; + + begin + Scop := Outer; + + -- Verify that there are no circular instantiations. We check whether + -- the unit contains an instance of the current scope or some enclosing + -- scope (in case one of the instances appears in a subunit). Longer + -- circularities involving subunits might seem too pathological to + -- consider, but they were not too pathological for the authors of + -- DEC bc30vsq, so we loop over all enclosing scopes, and mark all + -- enclosing generic scopes as containing an instance. + + loop + -- Within a generic subprogram body, the scope is not generic, to + -- allow for recursive subprograms. Use the declaration to determine + -- whether this is a generic unit. + + if Ekind (Scop) = E_Generic_Package + or else (Is_Subprogram (Scop) + and then Nkind (Unit_Declaration_Node (Scop)) = + N_Generic_Subprogram_Declaration) + then + Elmt := First_Elmt (Inner_Instances (Inner)); + + while Present (Elmt) loop + if Node (Elmt) = Scop then + Error_Msg_Node_2 := Inner; + Error_Msg_NE + ("circular Instantiation: & instantiated within &!", + N, Scop); + return True; + + elsif Node (Elmt) = Inner then + return True; + + elsif Contains_Instance_Of (Node (Elmt), Scop, N) then + Error_Msg_Node_2 := Inner; + Error_Msg_NE + ("circular Instantiation: & instantiated within &!", + N, Node (Elmt)); + return True; + end if; + + Next_Elmt (Elmt); + end loop; + + -- Indicate that Inner is being instantiated within Scop + + Append_Elmt (Inner, Inner_Instances (Scop)); + end if; + + if Scop = Standard_Standard then + exit; + else + Scop := Scope (Scop); + end if; + end loop; + + return False; + end Contains_Instance_Of; + + ----------------------- + -- Copy_Generic_Node -- + ----------------------- + + function Copy_Generic_Node + (N : Node_Id; + Parent_Id : Node_Id; + Instantiating : Boolean) return Node_Id + is + Ent : Entity_Id; + New_N : Node_Id; + + function Copy_Generic_Descendant (D : Union_Id) return Union_Id; + -- Check the given value of one of the Fields referenced by the + -- current node to determine whether to copy it recursively. The + -- field may hold a Node_Id, a List_Id, or an Elist_Id, or a plain + -- value (Sloc, Uint, Char) in which case it need not be copied. + + procedure Copy_Descendants; + -- Common utility for various nodes + + function Copy_Generic_Elist (E : Elist_Id) return Elist_Id; + -- Make copy of element list + + function Copy_Generic_List + (L : List_Id; + Parent_Id : Node_Id) return List_Id; + -- Apply Copy_Node recursively to the members of a node list + + function In_Defining_Unit_Name (Nam : Node_Id) return Boolean; + -- True if an identifier is part of the defining program unit name + -- of a child unit. The entity of such an identifier must be kept + -- (for ASIS use) even though as the name of an enclosing generic + -- it would otherwise not be preserved in the generic tree. + + ---------------------- + -- Copy_Descendants -- + ---------------------- + + procedure Copy_Descendants is + + use Atree.Unchecked_Access; + -- This code section is part of the implementation of an untyped + -- tree traversal, so it needs direct access to node fields. + + begin + Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N))); + Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N))); + Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N))); + Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N))); + Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N))); + end Copy_Descendants; + + ----------------------------- + -- Copy_Generic_Descendant -- + ----------------------------- + + function Copy_Generic_Descendant (D : Union_Id) return Union_Id is + begin + if D = Union_Id (Empty) then + return D; + + elsif D in Node_Range then + return Union_Id + (Copy_Generic_Node (Node_Id (D), New_N, Instantiating)); + + elsif D in List_Range then + return Union_Id (Copy_Generic_List (List_Id (D), New_N)); + + elsif D in Elist_Range then + return Union_Id (Copy_Generic_Elist (Elist_Id (D))); + + -- Nothing else is copyable (e.g. Uint values), return as is + + else + return D; + end if; + end Copy_Generic_Descendant; + + ------------------------ + -- Copy_Generic_Elist -- + ------------------------ + + function Copy_Generic_Elist (E : Elist_Id) return Elist_Id is + M : Elmt_Id; + L : Elist_Id; + + begin + if Present (E) then + L := New_Elmt_List; + M := First_Elmt (E); + while Present (M) loop + Append_Elmt + (Copy_Generic_Node (Node (M), Empty, Instantiating), L); + Next_Elmt (M); + end loop; + + return L; + + else + return No_Elist; + end if; + end Copy_Generic_Elist; + + ----------------------- + -- Copy_Generic_List -- + ----------------------- + + function Copy_Generic_List + (L : List_Id; + Parent_Id : Node_Id) return List_Id + is + N : Node_Id; + New_L : List_Id; + + begin + if Present (L) then + New_L := New_List; + Set_Parent (New_L, Parent_Id); + + N := First (L); + while Present (N) loop + Append (Copy_Generic_Node (N, Empty, Instantiating), New_L); + Next (N); + end loop; + + return New_L; + + else + return No_List; + end if; + end Copy_Generic_List; + + --------------------------- + -- In_Defining_Unit_Name -- + --------------------------- + + function In_Defining_Unit_Name (Nam : Node_Id) return Boolean is + begin + return Present (Parent (Nam)) + and then (Nkind (Parent (Nam)) = N_Defining_Program_Unit_Name + or else + (Nkind (Parent (Nam)) = N_Expanded_Name + and then In_Defining_Unit_Name (Parent (Nam)))); + end In_Defining_Unit_Name; + + -- Start of processing for Copy_Generic_Node + + begin + if N = Empty then + return N; + end if; + + New_N := New_Copy (N); + + -- Copy aspects if present + + if Has_Aspects (N) then + Set_Has_Aspects (New_N, False); + Set_Aspect_Specifications + (New_N, Copy_Generic_List (Aspect_Specifications (N), Parent_Id)); + end if; + + if Instantiating then + Adjust_Instantiation_Sloc (New_N, S_Adjustment); + end if; + + if not Is_List_Member (N) then + Set_Parent (New_N, Parent_Id); + end if; + + -- If defining identifier, then all fields have been copied already + + if Nkind (New_N) in N_Entity then + null; + + -- Special casing for identifiers and other entity names and operators + + elsif Nkind_In (New_N, N_Identifier, + N_Character_Literal, + N_Expanded_Name, + N_Operator_Symbol) + or else Nkind (New_N) in N_Op + then + if not Instantiating then + + -- Link both nodes in order to assign subsequently the entity of + -- the copy to the original node, in case this is a global + -- reference. + + Set_Associated_Node (N, New_N); + + -- If we are within an instantiation, this is a nested generic + -- that has already been analyzed at the point of definition. We + -- must preserve references that were global to the enclosing + -- parent at that point. Other occurrences, whether global or + -- local to the current generic, must be resolved anew, so we + -- reset the entity in the generic copy. A global reference has a + -- smaller depth than the parent, or else the same depth in case + -- both are distinct compilation units. + -- A child unit is implicitly declared within the enclosing parent + -- but is in fact global to it, and must be preserved. + + -- It is also possible for Current_Instantiated_Parent to be + -- defined, and for this not to be a nested generic, namely if the + -- unit is loaded through Rtsfind. In that case, the entity of + -- New_N is only a link to the associated node, and not a defining + -- occurrence. + + -- The entities for parent units in the defining_program_unit of a + -- generic child unit are established when the context of the unit + -- is first analyzed, before the generic copy is made. They are + -- preserved in the copy for use in ASIS queries. + + Ent := Entity (New_N); + + if No (Current_Instantiated_Parent.Gen_Id) then + if No (Ent) + or else Nkind (Ent) /= N_Defining_Identifier + or else not In_Defining_Unit_Name (N) + then + Set_Associated_Node (New_N, Empty); + end if; + + elsif No (Ent) + or else + not Nkind_In (Ent, N_Defining_Identifier, + N_Defining_Character_Literal, + N_Defining_Operator_Symbol) + or else No (Scope (Ent)) + or else + (Scope (Ent) = Current_Instantiated_Parent.Gen_Id + and then not Is_Child_Unit (Ent)) + or else + (Scope_Depth (Scope (Ent)) > + Scope_Depth (Current_Instantiated_Parent.Gen_Id) + and then + Get_Source_Unit (Ent) = + Get_Source_Unit (Current_Instantiated_Parent.Gen_Id)) + then + Set_Associated_Node (New_N, Empty); + end if; + + -- Case of instantiating identifier or some other name or operator + + else + -- If the associated node is still defined, the entity in it is + -- global, and must be copied to the instance. If this copy is + -- being made for a body to inline, it is applied to an + -- instantiated tree, and the entity is already present and must + -- be also preserved. + + declare + Assoc : constant Node_Id := Get_Associated_Node (N); + + begin + if Present (Assoc) then + if Nkind (Assoc) = Nkind (N) then + Set_Entity (New_N, Entity (Assoc)); + Check_Private_View (N); + + elsif Nkind (Assoc) = N_Function_Call then + Set_Entity (New_N, Entity (Name (Assoc))); + + elsif Nkind_In (Assoc, N_Defining_Identifier, + N_Defining_Character_Literal, + N_Defining_Operator_Symbol) + and then Expander_Active + then + -- Inlining case: we are copying a tree that contains + -- global entities, which are preserved in the copy to be + -- used for subsequent inlining. + + null; + + else + Set_Entity (New_N, Empty); + end if; + end if; + end; + end if; + + -- For expanded name, we must copy the Prefix and Selector_Name + + if Nkind (N) = N_Expanded_Name then + Set_Prefix + (New_N, Copy_Generic_Node (Prefix (N), New_N, Instantiating)); + + Set_Selector_Name (New_N, + Copy_Generic_Node (Selector_Name (N), New_N, Instantiating)); + + -- For operators, we must copy the right operand + + elsif Nkind (N) in N_Op then + Set_Right_Opnd (New_N, + Copy_Generic_Node (Right_Opnd (N), New_N, Instantiating)); + + -- And for binary operators, the left operand as well + + if Nkind (N) in N_Binary_Op then + Set_Left_Opnd (New_N, + Copy_Generic_Node (Left_Opnd (N), New_N, Instantiating)); + end if; + end if; + + -- Special casing for stubs + + elsif Nkind (N) in N_Body_Stub then + + -- In any case, we must copy the specification or defining + -- identifier as appropriate. + + if Nkind (N) = N_Subprogram_Body_Stub then + Set_Specification (New_N, + Copy_Generic_Node (Specification (N), New_N, Instantiating)); + + else + Set_Defining_Identifier (New_N, + Copy_Generic_Node + (Defining_Identifier (N), New_N, Instantiating)); + end if; + + -- If we are not instantiating, then this is where we load and + -- analyze subunits, i.e. at the point where the stub occurs. A + -- more permissive system might defer this analysis to the point + -- of instantiation, but this seems to complicated for now. + + if not Instantiating then + declare + Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N); + Subunit : Node_Id; + Unum : Unit_Number_Type; + New_Body : Node_Id; + + begin + -- Make sure that, if it is a subunit of the main unit that is + -- preprocessed and if -gnateG is specified, the preprocessed + -- file will be written. + + Lib.Analysing_Subunit_Of_Main := + Lib.In_Extended_Main_Source_Unit (N); + Unum := + Load_Unit + (Load_Name => Subunit_Name, + Required => False, + Subunit => True, + Error_Node => N); + Lib.Analysing_Subunit_Of_Main := False; + + -- If the proper body is not found, a warning message will be + -- emitted when analyzing the stub, or later at the point + -- of instantiation. Here we just leave the stub as is. + + if Unum = No_Unit then + Subunits_Missing := True; + goto Subunit_Not_Found; + end if; + + Subunit := Cunit (Unum); + + if Nkind (Unit (Subunit)) /= N_Subunit then + Error_Msg_N + ("found child unit instead of expected SEPARATE subunit", + Subunit); + Error_Msg_Sloc := Sloc (N); + Error_Msg_N ("\to complete stub #", Subunit); + goto Subunit_Not_Found; + end if; + + -- We must create a generic copy of the subunit, in order to + -- perform semantic analysis on it, and we must replace the + -- stub in the original generic unit with the subunit, in order + -- to preserve non-local references within. + + -- Only the proper body needs to be copied. Library_Unit and + -- context clause are simply inherited by the generic copy. + -- Note that the copy (which may be recursive if there are + -- nested subunits) must be done first, before attaching it to + -- the enclosing generic. + + New_Body := + Copy_Generic_Node + (Proper_Body (Unit (Subunit)), + Empty, Instantiating => False); + + -- Now place the original proper body in the original generic + -- unit. This is a body, not a compilation unit. + + Rewrite (N, Proper_Body (Unit (Subunit))); + Set_Is_Compilation_Unit (Defining_Entity (N), False); + Set_Was_Originally_Stub (N); + + -- Finally replace the body of the subunit with its copy, and + -- make this new subunit into the library unit of the generic + -- copy, which does not have stubs any longer. + + Set_Proper_Body (Unit (Subunit), New_Body); + Set_Library_Unit (New_N, Subunit); + Inherit_Context (Unit (Subunit), N); + end; + + -- If we are instantiating, this must be an error case, since + -- otherwise we would have replaced the stub node by the proper body + -- that corresponds. So just ignore it in the copy (i.e. we have + -- copied it, and that is good enough). + + else + null; + end if; + + <> null; + + -- If the node is a compilation unit, it is the subunit of a stub, which + -- has been loaded already (see code below). In this case, the library + -- unit field of N points to the parent unit (which is a compilation + -- unit) and need not (and cannot!) be copied. + + -- When the proper body of the stub is analyzed, the library_unit link + -- is used to establish the proper context (see sem_ch10). + + -- The other fields of a compilation unit are copied as usual + + elsif Nkind (N) = N_Compilation_Unit then + + -- This code can only be executed when not instantiating, because in + -- the copy made for an instantiation, the compilation unit node has + -- disappeared at the point that a stub is replaced by its proper + -- body. + + pragma Assert (not Instantiating); + + Set_Context_Items (New_N, + Copy_Generic_List (Context_Items (N), New_N)); + + Set_Unit (New_N, + Copy_Generic_Node (Unit (N), New_N, False)); + + Set_First_Inlined_Subprogram (New_N, + Copy_Generic_Node + (First_Inlined_Subprogram (N), New_N, False)); + + Set_Aux_Decls_Node (New_N, + Copy_Generic_Node (Aux_Decls_Node (N), New_N, False)); + + -- For an assignment node, the assignment is known to be semantically + -- legal if we are instantiating the template. This avoids incorrect + -- diagnostics in generated code. + + elsif Nkind (N) = N_Assignment_Statement then + + -- Copy name and expression fields in usual manner + + Set_Name (New_N, + Copy_Generic_Node (Name (N), New_N, Instantiating)); + + Set_Expression (New_N, + Copy_Generic_Node (Expression (N), New_N, Instantiating)); + + if Instantiating then + Set_Assignment_OK (Name (New_N), True); + end if; + + elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then + if not Instantiating then + Set_Associated_Node (N, New_N); + + else + if Present (Get_Associated_Node (N)) + and then Nkind (Get_Associated_Node (N)) = Nkind (N) + then + -- In the generic the aggregate has some composite type. If at + -- the point of instantiation the type has a private view, + -- install the full view (and that of its ancestors, if any). + + declare + T : Entity_Id := (Etype (Get_Associated_Node (New_N))); + Rt : Entity_Id; + + begin + if Present (T) + and then Is_Private_Type (T) + then + Switch_View (T); + end if; + + if Present (T) + and then Is_Tagged_Type (T) + and then Is_Derived_Type (T) + then + Rt := Root_Type (T); + + loop + T := Etype (T); + + if Is_Private_Type (T) then + Switch_View (T); + end if; + + exit when T = Rt; + end loop; + end if; + end; + end if; + end if; + + -- Do not copy the associated node, which points to + -- the generic copy of the aggregate. + + declare + use Atree.Unchecked_Access; + -- This code section is part of the implementation of an untyped + -- tree traversal, so it needs direct access to node fields. + + begin + Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N))); + Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N))); + Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N))); + Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N))); + end; + + -- Allocators do not have an identifier denoting the access type, + -- so we must locate it through the expression to check whether + -- the views are consistent. + + elsif Nkind (N) = N_Allocator + and then Nkind (Expression (N)) = N_Qualified_Expression + and then Is_Entity_Name (Subtype_Mark (Expression (N))) + and then Instantiating + then + declare + T : constant Node_Id := + Get_Associated_Node (Subtype_Mark (Expression (N))); + Acc_T : Entity_Id; + + begin + if Present (T) then + + -- Retrieve the allocator node in the generic copy + + Acc_T := Etype (Parent (Parent (T))); + if Present (Acc_T) + and then Is_Private_Type (Acc_T) + then + Switch_View (Acc_T); + end if; + end if; + + Copy_Descendants; + end; + + -- For a proper body, we must catch the case of a proper body that + -- replaces a stub. This represents the point at which a separate + -- compilation unit, and hence template file, may be referenced, so we + -- must make a new source instantiation entry for the template of the + -- subunit, and ensure that all nodes in the subunit are adjusted using + -- this new source instantiation entry. + + elsif Nkind (N) in N_Proper_Body then + declare + Save_Adjustment : constant Sloc_Adjustment := S_Adjustment; + + begin + if Instantiating and then Was_Originally_Stub (N) then + Create_Instantiation_Source + (Instantiation_Node, + Defining_Entity (N), + False, + S_Adjustment); + end if; + + -- Now copy the fields of the proper body, using the new + -- adjustment factor if one was needed as per test above. + + Copy_Descendants; + + -- Restore the original adjustment factor in case changed + + S_Adjustment := Save_Adjustment; + end; + + -- Don't copy Ident or Comment pragmas, since the comment belongs to the + -- generic unit, not to the instantiating unit. + + elsif Nkind (N) = N_Pragma + and then Instantiating + then + declare + Prag_Id : constant Pragma_Id := Get_Pragma_Id (N); + begin + if Prag_Id = Pragma_Ident + or else Prag_Id = Pragma_Comment + then + New_N := Make_Null_Statement (Sloc (N)); + else + Copy_Descendants; + end if; + end; + + elsif Nkind_In (N, N_Integer_Literal, N_Real_Literal) then + + -- No descendant fields need traversing + + null; + + elsif Nkind (N) = N_String_Literal + and then Present (Etype (N)) + and then Instantiating + then + -- If the string is declared in an outer scope, the string_literal + -- subtype created for it may have the wrong scope. We force the + -- reanalysis of the constant to generate a new itype in the proper + -- context. + + Set_Etype (New_N, Empty); + Set_Analyzed (New_N, False); + + -- For the remaining nodes, copy their descendants recursively + + else + Copy_Descendants; + + if Instantiating + and then Nkind (N) = N_Subprogram_Body + then + Set_Generic_Parent (Specification (New_N), N); + end if; + end if; + + return New_N; + end Copy_Generic_Node; + + ---------------------------- + -- Denotes_Formal_Package -- + ---------------------------- + + function Denotes_Formal_Package + (Pack : Entity_Id; + On_Exit : Boolean := False; + Instance : Entity_Id := Empty) return Boolean + is + Par : Entity_Id; + Scop : constant Entity_Id := Scope (Pack); + E : Entity_Id; + + function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean; + -- The package in question may be an actual for a previous formal + -- package P of the current instance, so examine its actuals as well. + -- This must be recursive over other formal packages. + + ---------------------------------- + -- Is_Actual_Of_Previous_Formal -- + ---------------------------------- + + function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean is + E1 : Entity_Id; + + begin + E1 := First_Entity (P); + while Present (E1) and then E1 /= Instance loop + if Ekind (E1) = E_Package + and then Nkind (Parent (E1)) = N_Package_Renaming_Declaration + then + if Renamed_Object (E1) = Pack then + return True; + + elsif E1 = P + or else Renamed_Object (E1) = P + then + return False; + + elsif Is_Actual_Of_Previous_Formal (E1) then + return True; + end if; + end if; + + Next_Entity (E1); + end loop; + + return False; + end Is_Actual_Of_Previous_Formal; + + -- Start of processing for Denotes_Formal_Package + + begin + if On_Exit then + Par := + Instance_Envs.Table + (Instance_Envs.Last).Instantiated_Parent.Act_Id; + else + Par := Current_Instantiated_Parent.Act_Id; + end if; + + if Ekind (Scop) = E_Generic_Package + or else Nkind (Unit_Declaration_Node (Scop)) = + N_Generic_Subprogram_Declaration + then + return True; + + elsif Nkind (Original_Node (Unit_Declaration_Node (Pack))) = + N_Formal_Package_Declaration + then + return True; + + elsif No (Par) then + return False; + + else + -- Check whether this package is associated with a formal package of + -- the enclosing instantiation. Iterate over the list of renamings. + + E := First_Entity (Par); + while Present (E) loop + if Ekind (E) /= E_Package + or else Nkind (Parent (E)) /= N_Package_Renaming_Declaration + then + null; + + elsif Renamed_Object (E) = Par then + return False; + + elsif Renamed_Object (E) = Pack then + return True; + + elsif Is_Actual_Of_Previous_Formal (E) then + return True; + + end if; + + Next_Entity (E); + end loop; + + return False; + end if; + end Denotes_Formal_Package; + + ----------------- + -- End_Generic -- + ----------------- + + procedure End_Generic is + begin + -- ??? More things could be factored out in this routine. Should + -- probably be done at a later stage. + + Inside_A_Generic := Generic_Flags.Table (Generic_Flags.Last); + Generic_Flags.Decrement_Last; + + Expander_Mode_Restore; + end End_Generic; + + ---------------------- + -- Find_Actual_Type -- + ---------------------- + + function Find_Actual_Type + (Typ : Entity_Id; + Gen_Type : Entity_Id) return Entity_Id + is + Gen_Scope : constant Entity_Id := Scope (Gen_Type); + T : Entity_Id; + + begin + -- Special processing only applies to child units + + if not Is_Child_Unit (Gen_Scope) then + return Get_Instance_Of (Typ); + + -- If designated or component type is itself a formal of the child unit, + -- its instance is available. + + elsif Scope (Typ) = Gen_Scope then + return Get_Instance_Of (Typ); + + -- If the array or access type is not declared in the parent unit, + -- no special processing needed. + + elsif not Is_Generic_Type (Typ) + and then Scope (Gen_Scope) /= Scope (Typ) + then + return Get_Instance_Of (Typ); + + -- Otherwise, retrieve designated or component type by visibility + + else + T := Current_Entity (Typ); + while Present (T) loop + if In_Open_Scopes (Scope (T)) then + return T; + + elsif Is_Generic_Actual_Type (T) then + return T; + end if; + + T := Homonym (T); + end loop; + + return Typ; + end if; + end Find_Actual_Type; + + ---------------------------- + -- Freeze_Subprogram_Body -- + ---------------------------- + + procedure Freeze_Subprogram_Body + (Inst_Node : Node_Id; + Gen_Body : Node_Id; + Pack_Id : Entity_Id) + is + F_Node : Node_Id; + Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); + Par : constant Entity_Id := Scope (Gen_Unit); + Enc_G : Entity_Id; + Enc_I : Node_Id; + E_G_Id : Entity_Id; + + function Earlier (N1, N2 : Node_Id) return Boolean; + -- Yields True if N1 and N2 appear in the same compilation unit, + -- ignoring subunits, and if N1 is to the left of N2 in a left-to-right + -- traversal of the tree for the unit. + + function Enclosing_Body (N : Node_Id) return Node_Id; + -- Find innermost package body that encloses the given node, and which + -- is not a compilation unit. Freeze nodes for the instance, or for its + -- enclosing body, may be inserted after the enclosing_body of the + -- generic unit. + + function Package_Freeze_Node (B : Node_Id) return Node_Id; + -- Find entity for given package body, and locate or create a freeze + -- node for it. + + function True_Parent (N : Node_Id) return Node_Id; + -- For a subunit, return parent of corresponding stub + + ------------- + -- Earlier -- + ------------- + + function Earlier (N1, N2 : Node_Id) return Boolean is + D1 : Integer := 0; + D2 : Integer := 0; + P1 : Node_Id := N1; + P2 : Node_Id := N2; + + procedure Find_Depth (P : in out Node_Id; D : in out Integer); + -- Find distance from given node to enclosing compilation unit + + ---------------- + -- Find_Depth -- + ---------------- + + procedure Find_Depth (P : in out Node_Id; D : in out Integer) is + begin + while Present (P) + and then Nkind (P) /= N_Compilation_Unit + loop + P := True_Parent (P); + D := D + 1; + end loop; + end Find_Depth; + + -- Start of processing for Earlier + + begin + Find_Depth (P1, D1); + Find_Depth (P2, D2); + + if P1 /= P2 then + return False; + else + P1 := N1; + P2 := N2; + end if; + + while D1 > D2 loop + P1 := True_Parent (P1); + D1 := D1 - 1; + end loop; + + while D2 > D1 loop + P2 := True_Parent (P2); + D2 := D2 - 1; + end loop; + + -- At this point P1 and P2 are at the same distance from the root. + -- We examine their parents until we find a common declarative + -- list, at which point we can establish their relative placement + -- by comparing their ultimate slocs. If we reach the root, + -- N1 and N2 do not descend from the same declarative list (e.g. + -- one is nested in the declarative part and the other is in a block + -- in the statement part) and the earlier one is already frozen. + + while not Is_List_Member (P1) + or else not Is_List_Member (P2) + or else List_Containing (P1) /= List_Containing (P2) + loop + P1 := True_Parent (P1); + P2 := True_Parent (P2); + + if Nkind (Parent (P1)) = N_Subunit then + P1 := Corresponding_Stub (Parent (P1)); + end if; + + if Nkind (Parent (P2)) = N_Subunit then + P2 := Corresponding_Stub (Parent (P2)); + end if; + + if P1 = P2 then + return False; + end if; + end loop; + + return + Top_Level_Location (Sloc (P1)) < Top_Level_Location (Sloc (P2)); + end Earlier; + + -------------------- + -- Enclosing_Body -- + -------------------- + + function Enclosing_Body (N : Node_Id) return Node_Id is + P : Node_Id := Parent (N); + + begin + while Present (P) + and then Nkind (Parent (P)) /= N_Compilation_Unit + loop + if Nkind (P) = N_Package_Body then + + if Nkind (Parent (P)) = N_Subunit then + return Corresponding_Stub (Parent (P)); + else + return P; + end if; + end if; + + P := True_Parent (P); + end loop; + + return Empty; + end Enclosing_Body; + + ------------------------- + -- Package_Freeze_Node -- + ------------------------- + + function Package_Freeze_Node (B : Node_Id) return Node_Id is + Id : Entity_Id; + + begin + if Nkind (B) = N_Package_Body then + Id := Corresponding_Spec (B); + + else pragma Assert (Nkind (B) = N_Package_Body_Stub); + Id := Corresponding_Spec (Proper_Body (Unit (Library_Unit (B)))); + end if; + + Ensure_Freeze_Node (Id); + return Freeze_Node (Id); + end Package_Freeze_Node; + + ----------------- + -- True_Parent -- + ----------------- + + function True_Parent (N : Node_Id) return Node_Id is + begin + if Nkind (Parent (N)) = N_Subunit then + return Parent (Corresponding_Stub (Parent (N))); + else + return Parent (N); + end if; + end True_Parent; + + -- Start of processing of Freeze_Subprogram_Body + + begin + -- If the instance and the generic body appear within the same unit, and + -- the instance precedes the generic, the freeze node for the instance + -- must appear after that of the generic. If the generic is nested + -- within another instance I2, then current instance must be frozen + -- after I2. In both cases, the freeze nodes are those of enclosing + -- packages. Otherwise, the freeze node is placed at the end of the + -- current declarative part. + + Enc_G := Enclosing_Body (Gen_Body); + Enc_I := Enclosing_Body (Inst_Node); + Ensure_Freeze_Node (Pack_Id); + F_Node := Freeze_Node (Pack_Id); + + if Is_Generic_Instance (Par) + and then Present (Freeze_Node (Par)) + and then + In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node) + then + if ABE_Is_Certain (Get_Package_Instantiation_Node (Par)) then + + -- The parent was a premature instantiation. Insert freeze node at + -- the end the current declarative part. + + Insert_After_Last_Decl (Inst_Node, F_Node); + + else + Insert_After (Freeze_Node (Par), F_Node); + end if; + + -- The body enclosing the instance should be frozen after the body that + -- includes the generic, because the body of the instance may make + -- references to entities therein. If the two are not in the same + -- declarative part, or if the one enclosing the instance is frozen + -- already, freeze the instance at the end of the current declarative + -- part. + + elsif Is_Generic_Instance (Par) + and then Present (Freeze_Node (Par)) + and then Present (Enc_I) + then + if In_Same_Declarative_Part (Freeze_Node (Par), Enc_I) + or else + (Nkind (Enc_I) = N_Package_Body + and then + In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I))) + then + -- The enclosing package may contain several instances. Rather + -- than computing the earliest point at which to insert its + -- freeze node, we place it at the end of the declarative part + -- of the parent of the generic. + + Insert_After_Last_Decl + (Freeze_Node (Par), Package_Freeze_Node (Enc_I)); + end if; + + Insert_After_Last_Decl (Inst_Node, F_Node); + + elsif Present (Enc_G) + and then Present (Enc_I) + and then Enc_G /= Enc_I + and then Earlier (Inst_Node, Gen_Body) + then + if Nkind (Enc_G) = N_Package_Body then + E_G_Id := Corresponding_Spec (Enc_G); + else pragma Assert (Nkind (Enc_G) = N_Package_Body_Stub); + E_G_Id := + Corresponding_Spec (Proper_Body (Unit (Library_Unit (Enc_G)))); + end if; + + -- Freeze package that encloses instance, and place node after + -- package that encloses generic. If enclosing package is already + -- frozen we have to assume it is at the proper place. This may be + -- a potential ABE that requires dynamic checking. Do not add a + -- freeze node if the package that encloses the generic is inside + -- the body that encloses the instance, because the freeze node + -- would be in the wrong scope. Additional contortions needed if + -- the bodies are within a subunit. + + declare + Enclosing_Body : Node_Id; + + begin + if Nkind (Enc_I) = N_Package_Body_Stub then + Enclosing_Body := Proper_Body (Unit (Library_Unit (Enc_I))); + else + Enclosing_Body := Enc_I; + end if; + + if Parent (List_Containing (Enc_G)) /= Enclosing_Body then + Insert_After_Last_Decl (Enc_G, Package_Freeze_Node (Enc_I)); + end if; + end; + + -- Freeze enclosing subunit before instance + + Ensure_Freeze_Node (E_G_Id); + + if not Is_List_Member (Freeze_Node (E_G_Id)) then + Insert_After (Enc_G, Freeze_Node (E_G_Id)); + end if; + + Insert_After_Last_Decl (Inst_Node, F_Node); + + else + -- If none of the above, insert freeze node at the end of the current + -- declarative part. + + Insert_After_Last_Decl (Inst_Node, F_Node); + end if; + end Freeze_Subprogram_Body; + + ---------------- + -- Get_Gen_Id -- + ---------------- + + function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id is + begin + return Generic_Renamings.Table (E).Gen_Id; + end Get_Gen_Id; + + --------------------- + -- Get_Instance_Of -- + --------------------- + + function Get_Instance_Of (A : Entity_Id) return Entity_Id is + Res : constant Assoc_Ptr := Generic_Renamings_HTable.Get (A); + + begin + if Res /= Assoc_Null then + return Generic_Renamings.Table (Res).Act_Id; + else + -- On exit, entity is not instantiated: not a generic parameter, or + -- else parameter of an inner generic unit. + + return A; + end if; + end Get_Instance_Of; + + ------------------------------------ + -- Get_Package_Instantiation_Node -- + ------------------------------------ + + function Get_Package_Instantiation_Node (A : Entity_Id) return Node_Id is + Decl : Node_Id := Unit_Declaration_Node (A); + Inst : Node_Id; + + begin + -- If the Package_Instantiation attribute has been set on the package + -- entity, then use it directly when it (or its Original_Node) refers + -- to an N_Package_Instantiation node. In principle it should be + -- possible to have this field set in all cases, which should be + -- investigated, and would allow this function to be significantly + -- simplified. ??? + + if Present (Package_Instantiation (A)) then + if Nkind (Package_Instantiation (A)) = N_Package_Instantiation then + return Package_Instantiation (A); + + elsif Nkind (Original_Node (Package_Instantiation (A))) = + N_Package_Instantiation + then + return Original_Node (Package_Instantiation (A)); + end if; + end if; + + -- If the instantiation is a compilation unit that does not need body + -- then the instantiation node has been rewritten as a package + -- declaration for the instance, and we return the original node. + + -- If it is a compilation unit and the instance node has not been + -- rewritten, then it is still the unit of the compilation. Finally, if + -- a body is present, this is a parent of the main unit whose body has + -- been compiled for inlining purposes, and the instantiation node has + -- been rewritten with the instance body. + + -- Otherwise the instantiation node appears after the declaration. If + -- the entity is a formal package, the declaration may have been + -- rewritten as a generic declaration (in the case of a formal with box) + -- or left as a formal package declaration if it has actuals, and is + -- found with a forward search. + + if Nkind (Parent (Decl)) = N_Compilation_Unit then + if Nkind (Decl) = N_Package_Declaration + and then Present (Corresponding_Body (Decl)) + then + Decl := Unit_Declaration_Node (Corresponding_Body (Decl)); + end if; + + if Nkind (Original_Node (Decl)) = N_Package_Instantiation then + return Original_Node (Decl); + else + return Unit (Parent (Decl)); + end if; + + elsif Nkind (Decl) = N_Package_Declaration + and then Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration + then + return Original_Node (Decl); + + else + Inst := Next (Decl); + while not Nkind_In (Inst, N_Package_Instantiation, + N_Formal_Package_Declaration) + loop + Next (Inst); + end loop; + + return Inst; + end if; + end Get_Package_Instantiation_Node; + + ------------------------ + -- Has_Been_Exchanged -- + ------------------------ + + function Has_Been_Exchanged (E : Entity_Id) return Boolean is + Next : Elmt_Id; + + begin + Next := First_Elmt (Exchanged_Views); + while Present (Next) loop + if Full_View (Node (Next)) = E then + return True; + end if; + + Next_Elmt (Next); + end loop; + + return False; + end Has_Been_Exchanged; + + ---------- + -- Hash -- + ---------- + + function Hash (F : Entity_Id) return HTable_Range is + begin + return HTable_Range (F mod HTable_Size); + end Hash; + + ------------------------ + -- Hide_Current_Scope -- + ------------------------ + + procedure Hide_Current_Scope is + C : constant Entity_Id := Current_Scope; + E : Entity_Id; + + begin + Set_Is_Hidden_Open_Scope (C); + + E := First_Entity (C); + while Present (E) loop + if Is_Immediately_Visible (E) then + Set_Is_Immediately_Visible (E, False); + Append_Elmt (E, Hidden_Entities); + end if; + + Next_Entity (E); + end loop; + + -- Make the scope name invisible as well. This is necessary, but might + -- conflict with calls to Rtsfind later on, in case the scope is a + -- predefined one. There is no clean solution to this problem, so for + -- now we depend on the user not redefining Standard itself in one of + -- the parent units. + + if Is_Immediately_Visible (C) + and then C /= Standard_Standard + then + Set_Is_Immediately_Visible (C, False); + Append_Elmt (C, Hidden_Entities); + end if; + + end Hide_Current_Scope; + + -------------- + -- Init_Env -- + -------------- + + procedure Init_Env is + Saved : Instance_Env; + + begin + Saved.Instantiated_Parent := Current_Instantiated_Parent; + Saved.Exchanged_Views := Exchanged_Views; + Saved.Hidden_Entities := Hidden_Entities; + Saved.Current_Sem_Unit := Current_Sem_Unit; + Saved.Parent_Unit_Visible := Parent_Unit_Visible; + Saved.Instance_Parent_Unit := Instance_Parent_Unit; + + -- Save configuration switches. These may be reset if the unit is a + -- predefined unit, and the current mode is not Ada 2005. + + Save_Opt_Config_Switches (Saved.Switches); + + Instance_Envs.Append (Saved); + + Exchanged_Views := New_Elmt_List; + Hidden_Entities := New_Elmt_List; + + -- Make dummy entry for Instantiated parent. If generic unit is legal, + -- this is set properly in Set_Instance_Env. + + Current_Instantiated_Parent := + (Current_Scope, Current_Scope, Assoc_Null); + end Init_Env; + + ------------------------------ + -- In_Same_Declarative_Part -- + ------------------------------ + + function In_Same_Declarative_Part + (F_Node : Node_Id; + Inst : Node_Id) return Boolean + is + Decls : constant Node_Id := Parent (F_Node); + Nod : Node_Id := Parent (Inst); + + begin + while Present (Nod) loop + if Nod = Decls then + return True; + + elsif Nkind_In (Nod, N_Subprogram_Body, + N_Package_Body, + N_Task_Body, + N_Protected_Body, + N_Block_Statement) + then + return False; + + elsif Nkind (Nod) = N_Subunit then + Nod := Corresponding_Stub (Nod); + + elsif Nkind (Nod) = N_Compilation_Unit then + return False; + + else + Nod := Parent (Nod); + end if; + end loop; + + return False; + end In_Same_Declarative_Part; + + --------------------- + -- In_Main_Context -- + --------------------- + + function In_Main_Context (E : Entity_Id) return Boolean is + Context : List_Id; + Clause : Node_Id; + Nam : Node_Id; + + begin + if not Is_Compilation_Unit (E) + or else Ekind (E) /= E_Package + or else In_Private_Part (E) + then + return False; + end if; + + Context := Context_Items (Cunit (Main_Unit)); + + Clause := First (Context); + while Present (Clause) loop + if Nkind (Clause) = N_With_Clause then + Nam := Name (Clause); + + -- If the current scope is part of the context of the main unit, + -- analysis of the corresponding with_clause is not complete, and + -- the entity is not set. We use the Chars field directly, which + -- might produce false positives in rare cases, but guarantees + -- that we produce all the instance bodies we will need. + + if (Is_Entity_Name (Nam) + and then Chars (Nam) = Chars (E)) + or else (Nkind (Nam) = N_Selected_Component + and then Chars (Selector_Name (Nam)) = Chars (E)) + then + return True; + end if; + end if; + + Next (Clause); + end loop; + + return False; + end In_Main_Context; + + --------------------- + -- Inherit_Context -- + --------------------- + + procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id) is + Current_Context : List_Id; + Current_Unit : Node_Id; + Item : Node_Id; + New_I : Node_Id; + + begin + if Nkind (Parent (Gen_Decl)) = N_Compilation_Unit then + + -- The inherited context is attached to the enclosing compilation + -- unit. This is either the main unit, or the declaration for the + -- main unit (in case the instantiation appears within the package + -- declaration and the main unit is its body). + + Current_Unit := Parent (Inst); + while Present (Current_Unit) + and then Nkind (Current_Unit) /= N_Compilation_Unit + loop + Current_Unit := Parent (Current_Unit); + end loop; + + Current_Context := Context_Items (Current_Unit); + + Item := First (Context_Items (Parent (Gen_Decl))); + while Present (Item) loop + if Nkind (Item) = N_With_Clause then + + -- Take care to prevent direct cyclic with's, which can happen + -- if the generic body with's the current unit. Such a case + -- would result in binder errors (or run-time errors if the + -- -gnatE switch is in effect), but we want to prevent it here, + -- because Sem.Walk_Library_Items doesn't like cycles. Note + -- that we don't bother to detect indirect cycles. + + if Library_Unit (Item) /= Current_Unit then + New_I := New_Copy (Item); + Set_Implicit_With (New_I, True); + Append (New_I, Current_Context); + end if; + end if; + + Next (Item); + end loop; + end if; + end Inherit_Context; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Generic_Renamings.Init; + Instance_Envs.Init; + Generic_Flags.Init; + Generic_Renamings_HTable.Reset; + Circularity_Detected := False; + Exchanged_Views := No_Elist; + Hidden_Entities := No_Elist; + end Initialize; + + ---------------------------- + -- Insert_After_Last_Decl -- + ---------------------------- + + procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id) is + L : List_Id := List_Containing (N); + P : constant Node_Id := Parent (L); + + begin + if not Is_List_Member (F_Node) then + if Nkind (P) = N_Package_Specification + and then L = Visible_Declarations (P) + and then Present (Private_Declarations (P)) + and then not Is_Empty_List (Private_Declarations (P)) + then + L := Private_Declarations (P); + end if; + + Insert_After (Last (L), F_Node); + end if; + end Insert_After_Last_Decl; + + ------------------ + -- Install_Body -- + ------------------ + + procedure Install_Body + (Act_Body : Node_Id; + N : Node_Id; + Gen_Body : Node_Id; + Gen_Decl : Node_Id) + is + Act_Id : constant Entity_Id := Corresponding_Spec (Act_Body); + Act_Unit : constant Node_Id := Unit (Cunit (Get_Source_Unit (N))); + Gen_Id : constant Entity_Id := Corresponding_Spec (Gen_Body); + Par : constant Entity_Id := Scope (Gen_Id); + Gen_Unit : constant Node_Id := + Unit (Cunit (Get_Source_Unit (Gen_Decl))); + Orig_Body : Node_Id := Gen_Body; + F_Node : Node_Id; + Body_Unit : Node_Id; + + Must_Delay : Boolean; + + function Enclosing_Subp (Id : Entity_Id) return Entity_Id; + -- Find subprogram (if any) that encloses instance and/or generic body + + function True_Sloc (N : Node_Id) return Source_Ptr; + -- If the instance is nested inside a generic unit, the Sloc of the + -- instance indicates the place of the original definition, not the + -- point of the current enclosing instance. Pending a better usage of + -- Slocs to indicate instantiation places, we determine the place of + -- origin of a node by finding the maximum sloc of any ancestor node. + -- Why is this not equivalent to Top_Level_Location ??? + + -------------------- + -- Enclosing_Subp -- + -------------------- + + function Enclosing_Subp (Id : Entity_Id) return Entity_Id is + Scop : Entity_Id := Scope (Id); + + begin + while Scop /= Standard_Standard + and then not Is_Overloadable (Scop) + loop + Scop := Scope (Scop); + end loop; + + return Scop; + end Enclosing_Subp; + + --------------- + -- True_Sloc -- + --------------- + + function True_Sloc (N : Node_Id) return Source_Ptr is + Res : Source_Ptr; + N1 : Node_Id; + + begin + Res := Sloc (N); + N1 := N; + while Present (N1) and then N1 /= Act_Unit loop + if Sloc (N1) > Res then + Res := Sloc (N1); + end if; + + N1 := Parent (N1); + end loop; + + return Res; + end True_Sloc; + + -- Start of processing for Install_Body + + begin + + -- If the body is a subunit, the freeze point is the corresponding + -- stub in the current compilation, not the subunit itself. + + if Nkind (Parent (Gen_Body)) = N_Subunit then + Orig_Body := Corresponding_Stub (Parent (Gen_Body)); + else + Orig_Body := Gen_Body; + end if; + + Body_Unit := Unit (Cunit (Get_Source_Unit (Orig_Body))); + + -- If the instantiation and the generic definition appear in the same + -- package declaration, this is an early instantiation. If they appear + -- in the same declarative part, it is an early instantiation only if + -- the generic body appears textually later, and the generic body is + -- also in the main unit. + + -- If instance is nested within a subprogram, and the generic body is + -- not, the instance is delayed because the enclosing body is. If + -- instance and body are within the same scope, or the same sub- + -- program body, indicate explicitly that the instance is delayed. + + Must_Delay := + (Gen_Unit = Act_Unit + and then (Nkind_In (Gen_Unit, N_Package_Declaration, + N_Generic_Package_Declaration) + or else (Gen_Unit = Body_Unit + and then True_Sloc (N) < Sloc (Orig_Body))) + and then Is_In_Main_Unit (Gen_Unit) + and then (Scope (Act_Id) = Scope (Gen_Id) + or else + Enclosing_Subp (Act_Id) = Enclosing_Subp (Gen_Id))); + + -- If this is an early instantiation, the freeze node is placed after + -- the generic body. Otherwise, if the generic appears in an instance, + -- we cannot freeze the current instance until the outer one is frozen. + -- This is only relevant if the current instance is nested within some + -- inner scope not itself within the outer instance. If this scope is + -- a package body in the same declarative part as the outer instance, + -- then that body needs to be frozen after the outer instance. Finally, + -- if no delay is needed, we place the freeze node at the end of the + -- current declarative part. + + if Expander_Active then + Ensure_Freeze_Node (Act_Id); + F_Node := Freeze_Node (Act_Id); + + if Must_Delay then + Insert_After (Orig_Body, F_Node); + + elsif Is_Generic_Instance (Par) + and then Present (Freeze_Node (Par)) + and then Scope (Act_Id) /= Par + then + -- Freeze instance of inner generic after instance of enclosing + -- generic. + + if In_Same_Declarative_Part (Freeze_Node (Par), N) then + Insert_After (Freeze_Node (Par), F_Node); + + -- Freeze package enclosing instance of inner generic after + -- instance of enclosing generic. + + elsif Nkind (Parent (N)) = N_Package_Body + and then In_Same_Declarative_Part (Freeze_Node (Par), Parent (N)) + then + + declare + Enclosing : constant Entity_Id := + Corresponding_Spec (Parent (N)); + + begin + Insert_After_Last_Decl (N, F_Node); + Ensure_Freeze_Node (Enclosing); + + if not Is_List_Member (Freeze_Node (Enclosing)) then + Insert_After (Freeze_Node (Par), Freeze_Node (Enclosing)); + end if; + end; + + else + Insert_After_Last_Decl (N, F_Node); + end if; + + else + Insert_After_Last_Decl (N, F_Node); + end if; + end if; + + Set_Is_Frozen (Act_Id); + Insert_Before (N, Act_Body); + Mark_Rewrite_Insertion (Act_Body); + end Install_Body; + + ----------------------------- + -- Install_Formal_Packages -- + ----------------------------- + + procedure Install_Formal_Packages (Par : Entity_Id) is + E : Entity_Id; + Gen : Entity_Id; + Gen_E : Entity_Id := Empty; + + begin + E := First_Entity (Par); + + -- In we are installing an instance parent, locate the formal packages + -- of its generic parent. + + if Is_Generic_Instance (Par) then + Gen := Generic_Parent (Specification (Unit_Declaration_Node (Par))); + Gen_E := First_Entity (Gen); + end if; + + while Present (E) loop + if Ekind (E) = E_Package + and then Nkind (Parent (E)) = N_Package_Renaming_Declaration + then + -- If this is the renaming for the parent instance, done + + if Renamed_Object (E) = Par then + exit; + + -- The visibility of a formal of an enclosing generic is already + -- correct. + + elsif Denotes_Formal_Package (E) then + null; + + elsif Present (Associated_Formal_Package (E)) then + Check_Generic_Actuals (Renamed_Object (E), True); + Set_Is_Hidden (E, False); + + -- Find formal package in generic unit that corresponds to + -- (instance of) formal package in instance. + + while Present (Gen_E) and then Chars (Gen_E) /= Chars (E) loop + Next_Entity (Gen_E); + end loop; + + if Present (Gen_E) then + Map_Formal_Package_Entities (Gen_E, E); + end if; + end if; + end if; + + Next_Entity (E); + if Present (Gen_E) then + Next_Entity (Gen_E); + end if; + end loop; + end Install_Formal_Packages; + + -------------------- + -- Install_Parent -- + -------------------- + + procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False) is + Ancestors : constant Elist_Id := New_Elmt_List; + S : constant Entity_Id := Current_Scope; + Inst_Par : Entity_Id; + First_Par : Entity_Id; + Inst_Node : Node_Id; + Gen_Par : Entity_Id; + First_Gen : Entity_Id; + Elmt : Elmt_Id; + + procedure Install_Noninstance_Specs (Par : Entity_Id); + -- Install the scopes of noninstance parent units ending with Par + + procedure Install_Spec (Par : Entity_Id); + -- The child unit is within the declarative part of the parent, so + -- the declarations within the parent are immediately visible. + + ------------------------------- + -- Install_Noninstance_Specs -- + ------------------------------- + + procedure Install_Noninstance_Specs (Par : Entity_Id) is + begin + if Present (Par) + and then Par /= Standard_Standard + and then not In_Open_Scopes (Par) + then + Install_Noninstance_Specs (Scope (Par)); + Install_Spec (Par); + end if; + end Install_Noninstance_Specs; + + ------------------ + -- Install_Spec -- + ------------------ + + procedure Install_Spec (Par : Entity_Id) is + Spec : constant Node_Id := + Specification (Unit_Declaration_Node (Par)); + + begin + -- If this parent of the child instance is a top-level unit, + -- then record the unit and its visibility for later resetting + -- in Remove_Parent. We exclude units that are generic instances, + -- as we only want to record this information for the ultimate + -- top-level noninstance parent (is that always correct???). + + if Scope (Par) = Standard_Standard + and then not Is_Generic_Instance (Par) + then + Parent_Unit_Visible := Is_Immediately_Visible (Par); + Instance_Parent_Unit := Par; + end if; + + -- Open the parent scope and make it and its declarations visible. + -- If this point is not within a body, then only the visible + -- declarations should be made visible, and installation of the + -- private declarations is deferred until the appropriate point + -- within analysis of the spec being instantiated (see the handling + -- of parent visibility in Analyze_Package_Specification). This is + -- relaxed in the case where the parent unit is Ada.Tags, to avoid + -- private view problems that occur when compiling instantiations of + -- a generic child of that package (Generic_Dispatching_Constructor). + -- If the instance freezes a tagged type, inlinings of operations + -- from Ada.Tags may need the full view of type Tag. If inlining took + -- proper account of establishing visibility of inlined subprograms' + -- parents then it should be possible to remove this + -- special check. ??? + + Push_Scope (Par); + Set_Is_Immediately_Visible (Par); + Install_Visible_Declarations (Par); + Set_Use (Visible_Declarations (Spec)); + + if In_Body or else Is_RTU (Par, Ada_Tags) then + Install_Private_Declarations (Par); + Set_Use (Private_Declarations (Spec)); + end if; + end Install_Spec; + + -- Start of processing for Install_Parent + + begin + -- We need to install the parent instance to compile the instantiation + -- of the child, but the child instance must appear in the current + -- scope. Given that we cannot place the parent above the current scope + -- in the scope stack, we duplicate the current scope and unstack both + -- after the instantiation is complete. + + -- If the parent is itself the instantiation of a child unit, we must + -- also stack the instantiation of its parent, and so on. Each such + -- ancestor is the prefix of the name in a prior instantiation. + + -- If this is a nested instance, the parent unit itself resolves to + -- a renaming of the parent instance, whose declaration we need. + + -- Finally, the parent may be a generic (not an instance) when the + -- child unit appears as a formal package. + + Inst_Par := P; + + if Present (Renamed_Entity (Inst_Par)) then + Inst_Par := Renamed_Entity (Inst_Par); + end if; + + First_Par := Inst_Par; + + Gen_Par := + Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par))); + + First_Gen := Gen_Par; + + while Present (Gen_Par) + and then Is_Child_Unit (Gen_Par) + loop + -- Load grandparent instance as well + + Inst_Node := Get_Package_Instantiation_Node (Inst_Par); + + if Nkind (Name (Inst_Node)) = N_Expanded_Name then + Inst_Par := Entity (Prefix (Name (Inst_Node))); + + if Present (Renamed_Entity (Inst_Par)) then + Inst_Par := Renamed_Entity (Inst_Par); + end if; + + Gen_Par := + Generic_Parent + (Specification (Unit_Declaration_Node (Inst_Par))); + + if Present (Gen_Par) then + Prepend_Elmt (Inst_Par, Ancestors); + + else + -- Parent is not the name of an instantiation + + Install_Noninstance_Specs (Inst_Par); + + exit; + end if; + + else + -- Previous error + + exit; + end if; + end loop; + + if Present (First_Gen) then + Append_Elmt (First_Par, Ancestors); + + else + Install_Noninstance_Specs (First_Par); + end if; + + if not Is_Empty_Elmt_List (Ancestors) then + Elmt := First_Elmt (Ancestors); + + while Present (Elmt) loop + Install_Spec (Node (Elmt)); + Install_Formal_Packages (Node (Elmt)); + + Next_Elmt (Elmt); + end loop; + end if; + + if not In_Body then + Push_Scope (S); + end if; + end Install_Parent; + + -------------------------------- + -- Instantiate_Formal_Package -- + -------------------------------- + + function Instantiate_Formal_Package + (Formal : Node_Id; + Actual : Node_Id; + Analyzed_Formal : Node_Id) return List_Id + is + Loc : constant Source_Ptr := Sloc (Actual); + Actual_Pack : Entity_Id; + Formal_Pack : Entity_Id; + Gen_Parent : Entity_Id; + Decls : List_Id; + Nod : Node_Id; + Parent_Spec : Node_Id; + + procedure Find_Matching_Actual + (F : Node_Id; + Act : in out Entity_Id); + -- We need to associate each formal entity in the formal package + -- with the corresponding entity in the actual package. The actual + -- package has been analyzed and possibly expanded, and as a result + -- there is no one-to-one correspondence between the two lists (for + -- example, the actual may include subtypes, itypes, and inherited + -- primitive operations, interspersed among the renaming declarations + -- for the actuals) . We retrieve the corresponding actual by name + -- because each actual has the same name as the formal, and they do + -- appear in the same order. + + function Get_Formal_Entity (N : Node_Id) return Entity_Id; + -- Retrieve entity of defining entity of generic formal parameter. + -- Only the declarations of formals need to be considered when + -- linking them to actuals, but the declarative list may include + -- internal entities generated during analysis, and those are ignored. + + procedure Match_Formal_Entity + (Formal_Node : Node_Id; + Formal_Ent : Entity_Id; + Actual_Ent : Entity_Id); + -- Associates the formal entity with the actual. In the case + -- where Formal_Ent is a formal package, this procedure iterates + -- through all of its formals and enters associations between the + -- actuals occurring in the formal package's corresponding actual + -- package (given by Actual_Ent) and the formal package's formal + -- parameters. This procedure recurses if any of the parameters is + -- itself a package. + + function Is_Instance_Of + (Act_Spec : Entity_Id; + Gen_Anc : Entity_Id) return Boolean; + -- The actual can be an instantiation of a generic within another + -- instance, in which case there is no direct link from it to the + -- original generic ancestor. In that case, we recognize that the + -- ultimate ancestor is the same by examining names and scopes. + + procedure Process_Nested_Formal (Formal : Entity_Id); + -- If the current formal is declared with a box, its own formals are + -- visible in the instance, as they were in the generic, and their + -- Hidden flag must be reset. If some of these formals are themselves + -- packages declared with a box, the processing must be recursive. + + -------------------------- + -- Find_Matching_Actual -- + -------------------------- + + procedure Find_Matching_Actual + (F : Node_Id; + Act : in out Entity_Id) + is + Formal_Ent : Entity_Id; + + begin + case Nkind (Original_Node (F)) is + when N_Formal_Object_Declaration | + N_Formal_Type_Declaration => + Formal_Ent := Defining_Identifier (F); + + while Chars (Act) /= Chars (Formal_Ent) loop + Next_Entity (Act); + end loop; + + when N_Formal_Subprogram_Declaration | + N_Formal_Package_Declaration | + N_Package_Declaration | + N_Generic_Package_Declaration => + Formal_Ent := Defining_Entity (F); + + while Chars (Act) /= Chars (Formal_Ent) loop + Next_Entity (Act); + end loop; + + when others => + raise Program_Error; + end case; + end Find_Matching_Actual; + + ------------------------- + -- Match_Formal_Entity -- + ------------------------- + + procedure Match_Formal_Entity + (Formal_Node : Node_Id; + Formal_Ent : Entity_Id; + Actual_Ent : Entity_Id) + is + Act_Pkg : Entity_Id; + + begin + Set_Instance_Of (Formal_Ent, Actual_Ent); + + if Ekind (Actual_Ent) = E_Package then + + -- Record associations for each parameter + + Act_Pkg := Actual_Ent; + + declare + A_Ent : Entity_Id := First_Entity (Act_Pkg); + F_Ent : Entity_Id; + F_Node : Node_Id; + + Gen_Decl : Node_Id; + Formals : List_Id; + Actual : Entity_Id; + + begin + -- Retrieve the actual given in the formal package declaration + + Actual := Entity (Name (Original_Node (Formal_Node))); + + -- The actual in the formal package declaration may be a + -- renamed generic package, in which case we want to retrieve + -- the original generic in order to traverse its formal part. + + if Present (Renamed_Entity (Actual)) then + Gen_Decl := Unit_Declaration_Node (Renamed_Entity (Actual)); + else + Gen_Decl := Unit_Declaration_Node (Actual); + end if; + + Formals := Generic_Formal_Declarations (Gen_Decl); + + if Present (Formals) then + F_Node := First_Non_Pragma (Formals); + else + F_Node := Empty; + end if; + + while Present (A_Ent) + and then Present (F_Node) + and then A_Ent /= First_Private_Entity (Act_Pkg) + loop + F_Ent := Get_Formal_Entity (F_Node); + + if Present (F_Ent) then + + -- This is a formal of the original package. Record + -- association and recurse. + + Find_Matching_Actual (F_Node, A_Ent); + Match_Formal_Entity (F_Node, F_Ent, A_Ent); + Next_Entity (A_Ent); + end if; + + Next_Non_Pragma (F_Node); + end loop; + end; + end if; + end Match_Formal_Entity; + + ----------------------- + -- Get_Formal_Entity -- + ----------------------- + + function Get_Formal_Entity (N : Node_Id) return Entity_Id is + Kind : constant Node_Kind := Nkind (Original_Node (N)); + begin + case Kind is + when N_Formal_Object_Declaration => + return Defining_Identifier (N); + + when N_Formal_Type_Declaration => + return Defining_Identifier (N); + + when N_Formal_Subprogram_Declaration => + return Defining_Unit_Name (Specification (N)); + + when N_Formal_Package_Declaration => + return Defining_Identifier (Original_Node (N)); + + when N_Generic_Package_Declaration => + return Defining_Identifier (Original_Node (N)); + + -- All other declarations are introduced by semantic analysis and + -- have no match in the actual. + + when others => + return Empty; + end case; + end Get_Formal_Entity; + + -------------------- + -- Is_Instance_Of -- + -------------------- + + function Is_Instance_Of + (Act_Spec : Entity_Id; + Gen_Anc : Entity_Id) return Boolean + is + Gen_Par : constant Entity_Id := Generic_Parent (Act_Spec); + + begin + if No (Gen_Par) then + return False; + + -- Simplest case: the generic parent of the actual is the formal + + elsif Gen_Par = Gen_Anc then + return True; + + elsif Chars (Gen_Par) /= Chars (Gen_Anc) then + return False; + + -- The actual may be obtained through several instantiations. Its + -- scope must itself be an instance of a generic declared in the + -- same scope as the formal. Any other case is detected above. + + elsif not Is_Generic_Instance (Scope (Gen_Par)) then + return False; + + else + return Generic_Parent (Parent (Scope (Gen_Par))) = Scope (Gen_Anc); + end if; + end Is_Instance_Of; + + --------------------------- + -- Process_Nested_Formal -- + --------------------------- + + procedure Process_Nested_Formal (Formal : Entity_Id) is + Ent : Entity_Id; + + begin + if Present (Associated_Formal_Package (Formal)) + and then Box_Present (Parent (Associated_Formal_Package (Formal))) + then + Ent := First_Entity (Formal); + while Present (Ent) loop + Set_Is_Hidden (Ent, False); + Set_Is_Visible_Formal (Ent); + Set_Is_Potentially_Use_Visible + (Ent, Is_Potentially_Use_Visible (Formal)); + + if Ekind (Ent) = E_Package then + exit when Renamed_Entity (Ent) = Renamed_Entity (Formal); + Process_Nested_Formal (Ent); + end if; + + Next_Entity (Ent); + end loop; + end if; + end Process_Nested_Formal; + + -- Start of processing for Instantiate_Formal_Package + + begin + Analyze (Actual); + + if not Is_Entity_Name (Actual) + or else Ekind (Entity (Actual)) /= E_Package + then + Error_Msg_N + ("expect package instance to instantiate formal", Actual); + Abandon_Instantiation (Actual); + raise Program_Error; + + else + Actual_Pack := Entity (Actual); + Set_Is_Instantiated (Actual_Pack); + + -- The actual may be a renamed package, or an outer generic formal + -- package whose instantiation is converted into a renaming. + + if Present (Renamed_Object (Actual_Pack)) then + Actual_Pack := Renamed_Object (Actual_Pack); + end if; + + if Nkind (Analyzed_Formal) = N_Formal_Package_Declaration then + Gen_Parent := Get_Instance_Of (Entity (Name (Analyzed_Formal))); + Formal_Pack := Defining_Identifier (Analyzed_Formal); + else + Gen_Parent := + Generic_Parent (Specification (Analyzed_Formal)); + Formal_Pack := + Defining_Unit_Name (Specification (Analyzed_Formal)); + end if; + + if Nkind (Parent (Actual_Pack)) = N_Defining_Program_Unit_Name then + Parent_Spec := Specification (Unit_Declaration_Node (Actual_Pack)); + else + Parent_Spec := Parent (Actual_Pack); + end if; + + if Gen_Parent = Any_Id then + Error_Msg_N + ("previous error in declaration of formal package", Actual); + Abandon_Instantiation (Actual); + + elsif + Is_Instance_Of (Parent_Spec, Get_Instance_Of (Gen_Parent)) + then + null; + + else + Error_Msg_NE + ("actual parameter must be instance of&", Actual, Gen_Parent); + Abandon_Instantiation (Actual); + end if; + + Set_Instance_Of (Defining_Identifier (Formal), Actual_Pack); + Map_Formal_Package_Entities (Formal_Pack, Actual_Pack); + + Nod := + Make_Package_Renaming_Declaration (Loc, + Defining_Unit_Name => New_Copy (Defining_Identifier (Formal)), + Name => New_Reference_To (Actual_Pack, Loc)); + + Set_Associated_Formal_Package (Defining_Unit_Name (Nod), + Defining_Identifier (Formal)); + Decls := New_List (Nod); + + -- If the formal F has a box, then the generic declarations are + -- visible in the generic G. In an instance of G, the corresponding + -- entities in the actual for F (which are the actuals for the + -- instantiation of the generic that F denotes) must also be made + -- visible for analysis of the current instance. On exit from the + -- current instance, those entities are made private again. If the + -- actual is currently in use, these entities are also use-visible. + + -- The loop through the actual entities also steps through the formal + -- entities and enters associations from formals to actuals into the + -- renaming map. This is necessary to properly handle checking of + -- actual parameter associations for later formals that depend on + -- actuals declared in the formal package. + + -- In Ada 2005, partial parametrization requires that we make visible + -- the actuals corresponding to formals that were defaulted in the + -- formal package. There formals are identified because they remain + -- formal generics within the formal package, rather than being + -- renamings of the actuals supplied. + + declare + Gen_Decl : constant Node_Id := + Unit_Declaration_Node (Gen_Parent); + Formals : constant List_Id := + Generic_Formal_Declarations (Gen_Decl); + + Actual_Ent : Entity_Id; + Actual_Of_Formal : Node_Id; + Formal_Node : Node_Id; + Formal_Ent : Entity_Id; + + begin + if Present (Formals) then + Formal_Node := First_Non_Pragma (Formals); + else + Formal_Node := Empty; + end if; + + Actual_Ent := First_Entity (Actual_Pack); + Actual_Of_Formal := + First (Visible_Declarations (Specification (Analyzed_Formal))); + while Present (Actual_Ent) + and then Actual_Ent /= First_Private_Entity (Actual_Pack) + loop + if Present (Formal_Node) then + Formal_Ent := Get_Formal_Entity (Formal_Node); + + if Present (Formal_Ent) then + Find_Matching_Actual (Formal_Node, Actual_Ent); + Match_Formal_Entity + (Formal_Node, Formal_Ent, Actual_Ent); + + -- We iterate at the same time over the actuals of the + -- local package created for the formal, to determine + -- which one of the formals of the original generic were + -- defaulted in the formal. The corresponding actual + -- entities are visible in the enclosing instance. + + if Box_Present (Formal) + or else + (Present (Actual_Of_Formal) + and then + Is_Generic_Formal + (Get_Formal_Entity (Actual_Of_Formal))) + then + Set_Is_Hidden (Actual_Ent, False); + Set_Is_Visible_Formal (Actual_Ent); + Set_Is_Potentially_Use_Visible + (Actual_Ent, In_Use (Actual_Pack)); + + if Ekind (Actual_Ent) = E_Package then + Process_Nested_Formal (Actual_Ent); + end if; + + else + Set_Is_Hidden (Actual_Ent); + Set_Is_Potentially_Use_Visible (Actual_Ent, False); + end if; + end if; + + Next_Non_Pragma (Formal_Node); + Next (Actual_Of_Formal); + + else + -- No further formals to match, but the generic part may + -- contain inherited operation that are not hidden in the + -- enclosing instance. + + Next_Entity (Actual_Ent); + end if; + end loop; + + -- Inherited subprograms generated by formal derived types are + -- also visible if the types are. + + Actual_Ent := First_Entity (Actual_Pack); + while Present (Actual_Ent) + and then Actual_Ent /= First_Private_Entity (Actual_Pack) + loop + if Is_Overloadable (Actual_Ent) + and then + Nkind (Parent (Actual_Ent)) = N_Subtype_Declaration + and then + not Is_Hidden (Defining_Identifier (Parent (Actual_Ent))) + then + Set_Is_Hidden (Actual_Ent, False); + Set_Is_Potentially_Use_Visible + (Actual_Ent, In_Use (Actual_Pack)); + end if; + + Next_Entity (Actual_Ent); + end loop; + end; + + -- If the formal is not declared with a box, reanalyze it as an + -- abbreviated instantiation, to verify the matching rules of 12.7. + -- The actual checks are performed after the generic associations + -- have been analyzed, to guarantee the same visibility for this + -- instantiation and for the actuals. + + -- In Ada 2005, the generic associations for the formal can include + -- defaulted parameters. These are ignored during check. This + -- internal instantiation is removed from the tree after conformance + -- checking, because it contains formal declarations for those + -- defaulted parameters, and those should not reach the back-end. + + if not Box_Present (Formal) then + declare + I_Pack : constant Entity_Id := + Make_Temporary (Sloc (Actual), 'P'); + + begin + Set_Is_Internal (I_Pack); + + Append_To (Decls, + Make_Package_Instantiation (Sloc (Actual), + Defining_Unit_Name => I_Pack, + Name => + New_Occurrence_Of + (Get_Instance_Of (Gen_Parent), Sloc (Actual)), + Generic_Associations => + Generic_Associations (Formal))); + end; + end if; + + return Decls; + end if; + end Instantiate_Formal_Package; + + ----------------------------------- + -- Instantiate_Formal_Subprogram -- + ----------------------------------- + + function Instantiate_Formal_Subprogram + (Formal : Node_Id; + Actual : Node_Id; + Analyzed_Formal : Node_Id) return Node_Id + is + Loc : Source_Ptr; + Formal_Sub : constant Entity_Id := + Defining_Unit_Name (Specification (Formal)); + Analyzed_S : constant Entity_Id := + Defining_Unit_Name (Specification (Analyzed_Formal)); + Decl_Node : Node_Id; + Nam : Node_Id; + New_Spec : Node_Id; + + function From_Parent_Scope (Subp : Entity_Id) return Boolean; + -- If the generic is a child unit, the parent has been installed on the + -- scope stack, but a default subprogram cannot resolve to something on + -- the parent because that parent is not really part of the visible + -- context (it is there to resolve explicit local entities). If the + -- default has resolved in this way, we remove the entity from + -- immediate visibility and analyze the node again to emit an error + -- message or find another visible candidate. + + procedure Valid_Actual_Subprogram (Act : Node_Id); + -- Perform legality check and raise exception on failure + + ----------------------- + -- From_Parent_Scope -- + ----------------------- + + function From_Parent_Scope (Subp : Entity_Id) return Boolean is + Gen_Scope : Node_Id; + + begin + Gen_Scope := Scope (Analyzed_S); + while Present (Gen_Scope) + and then Is_Child_Unit (Gen_Scope) + loop + if Scope (Subp) = Scope (Gen_Scope) then + return True; + end if; + + Gen_Scope := Scope (Gen_Scope); + end loop; + + return False; + end From_Parent_Scope; + + ----------------------------- + -- Valid_Actual_Subprogram -- + ----------------------------- + + procedure Valid_Actual_Subprogram (Act : Node_Id) is + Act_E : Entity_Id; + + begin + if Is_Entity_Name (Act) then + Act_E := Entity (Act); + + elsif Nkind (Act) = N_Selected_Component + and then Is_Entity_Name (Selector_Name (Act)) + then + Act_E := Entity (Selector_Name (Act)); + + else + Act_E := Empty; + end if; + + if (Present (Act_E) and then Is_Overloadable (Act_E)) + or else Nkind_In (Act, N_Attribute_Reference, + N_Indexed_Component, + N_Character_Literal, + N_Explicit_Dereference) + then + return; + end if; + + Error_Msg_NE + ("expect subprogram or entry name in instantiation of&", + Instantiation_Node, Formal_Sub); + Abandon_Instantiation (Instantiation_Node); + + end Valid_Actual_Subprogram; + + -- Start of processing for Instantiate_Formal_Subprogram + + begin + New_Spec := New_Copy_Tree (Specification (Formal)); + + -- The tree copy has created the proper instantiation sloc for the + -- new specification. Use this location for all other constructed + -- declarations. + + Loc := Sloc (Defining_Unit_Name (New_Spec)); + + -- Create new entity for the actual (New_Copy_Tree does not) + + Set_Defining_Unit_Name + (New_Spec, Make_Defining_Identifier (Loc, Chars (Formal_Sub))); + + -- Create new entities for the each of the formals in the + -- specification of the renaming declaration built for the actual. + + if Present (Parameter_Specifications (New_Spec)) then + declare + F : Node_Id; + begin + F := First (Parameter_Specifications (New_Spec)); + while Present (F) loop + Set_Defining_Identifier (F, + Make_Defining_Identifier (Sloc (F), + Chars => Chars (Defining_Identifier (F)))); + Next (F); + end loop; + end; + end if; + + -- Find entity of actual. If the actual is an attribute reference, it + -- cannot be resolved here (its formal is missing) but is handled + -- instead in Attribute_Renaming. If the actual is overloaded, it is + -- fully resolved subsequently, when the renaming declaration for the + -- formal is analyzed. If it is an explicit dereference, resolve the + -- prefix but not the actual itself, to prevent interpretation as call. + + if Present (Actual) then + Loc := Sloc (Actual); + Set_Sloc (New_Spec, Loc); + + if Nkind (Actual) = N_Operator_Symbol then + Find_Direct_Name (Actual); + + elsif Nkind (Actual) = N_Explicit_Dereference then + Analyze (Prefix (Actual)); + + elsif Nkind (Actual) /= N_Attribute_Reference then + Analyze (Actual); + end if; + + Valid_Actual_Subprogram (Actual); + Nam := Actual; + + elsif Present (Default_Name (Formal)) then + if not Nkind_In (Default_Name (Formal), N_Attribute_Reference, + N_Selected_Component, + N_Indexed_Component, + N_Character_Literal) + and then Present (Entity (Default_Name (Formal))) + then + Nam := New_Occurrence_Of (Entity (Default_Name (Formal)), Loc); + else + Nam := New_Copy (Default_Name (Formal)); + Set_Sloc (Nam, Loc); + end if; + + elsif Box_Present (Formal) then + + -- Actual is resolved at the point of instantiation. Create an + -- identifier or operator with the same name as the formal. + + if Nkind (Formal_Sub) = N_Defining_Operator_Symbol then + Nam := Make_Operator_Symbol (Loc, + Chars => Chars (Formal_Sub), + Strval => No_String); + else + Nam := Make_Identifier (Loc, Chars (Formal_Sub)); + end if; + + elsif Nkind (Specification (Formal)) = N_Procedure_Specification + and then Null_Present (Specification (Formal)) + then + -- Generate null body for procedure, for use in the instance + + Decl_Node := + Make_Subprogram_Body (Loc, + Specification => New_Spec, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Make_Null_Statement (Loc)))); + + Set_Is_Intrinsic_Subprogram (Defining_Unit_Name (New_Spec)); + return Decl_Node; + + else + Error_Msg_Sloc := Sloc (Scope (Analyzed_S)); + Error_Msg_NE + ("missing actual&", Instantiation_Node, Formal_Sub); + Error_Msg_NE + ("\in instantiation of & declared#", + Instantiation_Node, Scope (Analyzed_S)); + Abandon_Instantiation (Instantiation_Node); + end if; + + Decl_Node := + Make_Subprogram_Renaming_Declaration (Loc, + Specification => New_Spec, + Name => Nam); + + -- If we do not have an actual and the formal specified <> then set to + -- get proper default. + + if No (Actual) and then Box_Present (Formal) then + Set_From_Default (Decl_Node); + end if; + + -- Gather possible interpretations for the actual before analyzing the + -- instance. If overloaded, it will be resolved when analyzing the + -- renaming declaration. + + if Box_Present (Formal) + and then No (Actual) + then + Analyze (Nam); + + if Is_Child_Unit (Scope (Analyzed_S)) + and then Present (Entity (Nam)) + then + if not Is_Overloaded (Nam) then + + if From_Parent_Scope (Entity (Nam)) then + Set_Is_Immediately_Visible (Entity (Nam), False); + Set_Entity (Nam, Empty); + Set_Etype (Nam, Empty); + + Analyze (Nam); + + Set_Is_Immediately_Visible (Entity (Nam)); + end if; + + else + declare + I : Interp_Index; + It : Interp; + + begin + Get_First_Interp (Nam, I, It); + + while Present (It.Nam) loop + if From_Parent_Scope (It.Nam) then + Remove_Interp (I); + end if; + + Get_Next_Interp (I, It); + end loop; + end; + end if; + end if; + end if; + + -- The generic instantiation freezes the actual. This can only be done + -- once the actual is resolved, in the analysis of the renaming + -- declaration. To make the formal subprogram entity available, we set + -- Corresponding_Formal_Spec to point to the formal subprogram entity. + -- This is also needed in Analyze_Subprogram_Renaming for the processing + -- of formal abstract subprograms. + + Set_Corresponding_Formal_Spec (Decl_Node, Analyzed_S); + + -- We cannot analyze the renaming declaration, and thus find the actual, + -- until all the actuals are assembled in the instance. For subsequent + -- checks of other actuals, indicate the node that will hold the + -- instance of this formal. + + Set_Instance_Of (Analyzed_S, Nam); + + if Nkind (Actual) = N_Selected_Component + and then Is_Task_Type (Etype (Prefix (Actual))) + and then not Is_Frozen (Etype (Prefix (Actual))) + then + -- The renaming declaration will create a body, which must appear + -- outside of the instantiation, We move the renaming declaration + -- out of the instance, and create an additional renaming inside, + -- to prevent freezing anomalies. + + declare + Anon_Id : constant Entity_Id := Make_Temporary (Loc, 'E'); + + begin + Set_Defining_Unit_Name (New_Spec, Anon_Id); + Insert_Before (Instantiation_Node, Decl_Node); + Analyze (Decl_Node); + + -- Now create renaming within the instance + + Decl_Node := + Make_Subprogram_Renaming_Declaration (Loc, + Specification => New_Copy_Tree (New_Spec), + Name => New_Occurrence_Of (Anon_Id, Loc)); + + Set_Defining_Unit_Name (Specification (Decl_Node), + Make_Defining_Identifier (Loc, Chars (Formal_Sub))); + end; + end if; + + return Decl_Node; + end Instantiate_Formal_Subprogram; + + ------------------------ + -- Instantiate_Object -- + ------------------------ + + function Instantiate_Object + (Formal : Node_Id; + Actual : Node_Id; + Analyzed_Formal : Node_Id) return List_Id + is + Gen_Obj : constant Entity_Id := Defining_Identifier (Formal); + A_Gen_Obj : constant Entity_Id := + Defining_Identifier (Analyzed_Formal); + Acc_Def : Node_Id := Empty; + Act_Assoc : constant Node_Id := Parent (Actual); + Actual_Decl : Node_Id := Empty; + Decl_Node : Node_Id; + Def : Node_Id; + Ftyp : Entity_Id; + List : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Actual); + Orig_Ftyp : constant Entity_Id := Etype (A_Gen_Obj); + Subt_Decl : Node_Id := Empty; + Subt_Mark : Node_Id := Empty; + + begin + if Present (Subtype_Mark (Formal)) then + Subt_Mark := Subtype_Mark (Formal); + else + Check_Access_Definition (Formal); + Acc_Def := Access_Definition (Formal); + end if; + + -- Sloc for error message on missing actual + + Error_Msg_Sloc := Sloc (Scope (A_Gen_Obj)); + + if Get_Instance_Of (Gen_Obj) /= Gen_Obj then + Error_Msg_N ("duplicate instantiation of generic parameter", Actual); + end if; + + Set_Parent (List, Parent (Actual)); + + -- OUT present + + if Out_Present (Formal) then + + -- An IN OUT generic actual must be a name. The instantiation is a + -- renaming declaration. The actual is the name being renamed. We + -- use the actual directly, rather than a copy, because it is not + -- used further in the list of actuals, and because a copy or a use + -- of relocate_node is incorrect if the instance is nested within a + -- generic. In order to simplify ASIS searches, the Generic_Parent + -- field links the declaration to the generic association. + + if No (Actual) then + Error_Msg_NE + ("missing actual&", + Instantiation_Node, Gen_Obj); + Error_Msg_NE + ("\in instantiation of & declared#", + Instantiation_Node, Scope (A_Gen_Obj)); + Abandon_Instantiation (Instantiation_Node); + end if; + + if Present (Subt_Mark) then + Decl_Node := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => New_Copy (Gen_Obj), + Subtype_Mark => New_Copy_Tree (Subt_Mark), + Name => Actual); + + else pragma Assert (Present (Acc_Def)); + Decl_Node := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => New_Copy (Gen_Obj), + Access_Definition => New_Copy_Tree (Acc_Def), + Name => Actual); + end if; + + Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc); + + -- The analysis of the actual may produce insert_action nodes, so + -- the declaration must have a context in which to attach them. + + Append (Decl_Node, List); + Analyze (Actual); + + -- Return if the analysis of the actual reported some error + + if Etype (Actual) = Any_Type then + return List; + end if; + + -- This check is performed here because Analyze_Object_Renaming will + -- not check it when Comes_From_Source is False. Note though that the + -- check for the actual being the name of an object will be performed + -- in Analyze_Object_Renaming. + + if Is_Object_Reference (Actual) + and then Is_Dependent_Component_Of_Mutable_Object (Actual) + then + Error_Msg_N + ("illegal discriminant-dependent component for in out parameter", + Actual); + end if; + + -- The actual has to be resolved in order to check that it is a + -- variable (due to cases such as F (1), where F returns access to an + -- array, and for overloaded prefixes). + + Ftyp := Get_Instance_Of (Etype (A_Gen_Obj)); + + -- If the type of the formal is not itself a formal, and the + -- current unit is a child unit, the formal type must be declared + -- in a parent, and must be retrieved by visibility. + + if Ftyp = Orig_Ftyp + and then Is_Generic_Unit (Scope (Ftyp)) + and then Is_Child_Unit (Scope (A_Gen_Obj)) + then + declare + Temp : constant Node_Id := + New_Copy_Tree (Subtype_Mark (Analyzed_Formal)); + begin + Set_Entity (Temp, Empty); + Find_Type (Temp); + Ftyp := Entity (Temp); + end; + end if; + + if Is_Private_Type (Ftyp) + and then not Is_Private_Type (Etype (Actual)) + and then (Base_Type (Full_View (Ftyp)) = Base_Type (Etype (Actual)) + or else Base_Type (Etype (Actual)) = Ftyp) + then + -- If the actual has the type of the full view of the formal, or + -- else a non-private subtype of the formal, then the visibility + -- of the formal type has changed. Add to the actuals a subtype + -- declaration that will force the exchange of views in the body + -- of the instance as well. + + Subt_Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'P'), + Subtype_Indication => New_Occurrence_Of (Ftyp, Loc)); + + Prepend (Subt_Decl, List); + + Prepend_Elmt (Full_View (Ftyp), Exchanged_Views); + Exchange_Declarations (Ftyp); + end if; + + Resolve (Actual, Ftyp); + + if not Denotes_Variable (Actual) then + Error_Msg_NE + ("actual for& must be a variable", Actual, Gen_Obj); + + elsif Base_Type (Ftyp) /= Base_Type (Etype (Actual)) then + + -- Ada 2005 (AI-423): For a generic formal object of mode in out, + -- the type of the actual shall resolve to a specific anonymous + -- access type. + + if Ada_Version < Ada_2005 + or else + Ekind (Base_Type (Ftyp)) /= + E_Anonymous_Access_Type + or else + Ekind (Base_Type (Etype (Actual))) /= + E_Anonymous_Access_Type + then + Error_Msg_NE ("type of actual does not match type of&", + Actual, Gen_Obj); + end if; + end if; + + Note_Possible_Modification (Actual, Sure => True); + + -- Check for instantiation of atomic/volatile actual for + -- non-atomic/volatile formal (RM C.6 (12)). + + if Is_Atomic_Object (Actual) + and then not Is_Atomic (Orig_Ftyp) + then + Error_Msg_N + ("cannot instantiate non-atomic formal object " & + "with atomic actual", Actual); + + elsif Is_Volatile_Object (Actual) + and then not Is_Volatile (Orig_Ftyp) + then + Error_Msg_N + ("cannot instantiate non-volatile formal object " & + "with volatile actual", Actual); + end if; + + -- Formal in-parameter + + else + -- The instantiation of a generic formal in-parameter is constant + -- declaration. The actual is the expression for that declaration. + + if Present (Actual) then + if Present (Subt_Mark) then + Def := Subt_Mark; + else pragma Assert (Present (Acc_Def)); + Def := Acc_Def; + end if; + + Decl_Node := + Make_Object_Declaration (Loc, + Defining_Identifier => New_Copy (Gen_Obj), + Constant_Present => True, + Null_Exclusion_Present => Null_Exclusion_Present (Formal), + Object_Definition => New_Copy_Tree (Def), + Expression => Actual); + + Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc); + + -- A generic formal object of a tagged type is defined to be + -- aliased so the new constant must also be treated as aliased. + + if Is_Tagged_Type (Etype (A_Gen_Obj)) then + Set_Aliased_Present (Decl_Node); + end if; + + Append (Decl_Node, List); + + -- No need to repeat (pre-)analysis of some expression nodes + -- already handled in Preanalyze_Actuals. + + if Nkind (Actual) /= N_Allocator then + Analyze (Actual); + + -- Return if the analysis of the actual reported some error + + if Etype (Actual) = Any_Type then + return List; + end if; + end if; + + declare + Formal_Type : constant Entity_Id := Etype (A_Gen_Obj); + Typ : Entity_Id; + + begin + Typ := Get_Instance_Of (Formal_Type); + + Freeze_Before (Instantiation_Node, Typ); + + -- If the actual is an aggregate, perform name resolution on + -- its components (the analysis of an aggregate does not do it) + -- to capture local names that may be hidden if the generic is + -- a child unit. + + if Nkind (Actual) = N_Aggregate then + Preanalyze_And_Resolve (Actual, Typ); + end if; + + if Is_Limited_Type (Typ) + and then not OK_For_Limited_Init (Typ, Actual) + then + Error_Msg_N + ("initialization not allowed for limited types", Actual); + Explain_Limited_Type (Typ, Actual); + end if; + end; + + elsif Present (Default_Expression (Formal)) then + + -- Use default to construct declaration + + if Present (Subt_Mark) then + Def := Subt_Mark; + else pragma Assert (Present (Acc_Def)); + Def := Acc_Def; + end if; + + Decl_Node := + Make_Object_Declaration (Sloc (Formal), + Defining_Identifier => New_Copy (Gen_Obj), + Constant_Present => True, + Null_Exclusion_Present => Null_Exclusion_Present (Formal), + Object_Definition => New_Copy (Def), + Expression => New_Copy_Tree + (Default_Expression (Formal))); + + Append (Decl_Node, List); + Set_Analyzed (Expression (Decl_Node), False); + + else + Error_Msg_NE + ("missing actual&", + Instantiation_Node, Gen_Obj); + Error_Msg_NE ("\in instantiation of & declared#", + Instantiation_Node, Scope (A_Gen_Obj)); + + if Is_Scalar_Type (Etype (A_Gen_Obj)) then + + -- Create dummy constant declaration so that instance can be + -- analyzed, to minimize cascaded visibility errors. + + if Present (Subt_Mark) then + Def := Subt_Mark; + else pragma Assert (Present (Acc_Def)); + Def := Acc_Def; + end if; + + Decl_Node := + Make_Object_Declaration (Loc, + Defining_Identifier => New_Copy (Gen_Obj), + Constant_Present => True, + Null_Exclusion_Present => Null_Exclusion_Present (Formal), + Object_Definition => New_Copy (Def), + Expression => + Make_Attribute_Reference (Sloc (Gen_Obj), + Attribute_Name => Name_First, + Prefix => New_Copy (Def))); + + Append (Decl_Node, List); + + else + Abandon_Instantiation (Instantiation_Node); + end if; + end if; + end if; + + if Nkind (Actual) in N_Has_Entity then + Actual_Decl := Parent (Entity (Actual)); + end if; + + -- Ada 2005 (AI-423): For a formal object declaration with a null + -- exclusion or an access definition that has a null exclusion: If the + -- actual matching the formal object declaration denotes a generic + -- formal object of another generic unit G, and the instantiation + -- containing the actual occurs within the body of G or within the body + -- of a generic unit declared within the declarative region of G, then + -- the declaration of the formal object of G must have a null exclusion. + -- Otherwise, the subtype of the actual matching the formal object + -- declaration shall exclude null. + + if Ada_Version >= Ada_2005 + and then Present (Actual_Decl) + and then + Nkind_In (Actual_Decl, N_Formal_Object_Declaration, + N_Object_Declaration) + and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration + and then not Has_Null_Exclusion (Actual_Decl) + and then Has_Null_Exclusion (Analyzed_Formal) + then + Error_Msg_Sloc := Sloc (Analyzed_Formal); + Error_Msg_N + ("actual must exclude null to match generic formal#", Actual); + end if; + + return List; + end Instantiate_Object; + + ------------------------------ + -- Instantiate_Package_Body -- + ------------------------------ + + procedure Instantiate_Package_Body + (Body_Info : Pending_Body_Info; + Inlined_Body : Boolean := False; + Body_Optional : Boolean := False) + is + Act_Decl : constant Node_Id := Body_Info.Act_Decl; + Inst_Node : constant Node_Id := Body_Info.Inst_Node; + Loc : constant Source_Ptr := Sloc (Inst_Node); + + Gen_Id : constant Node_Id := Name (Inst_Node); + Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); + Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit); + Act_Spec : constant Node_Id := Specification (Act_Decl); + Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Spec); + + Act_Body_Name : Node_Id; + Gen_Body : Node_Id; + Gen_Body_Id : Node_Id; + Act_Body : Node_Id; + Act_Body_Id : Entity_Id; + + Parent_Installed : Boolean := False; + Save_Style_Check : constant Boolean := Style_Check; + + Par_Ent : Entity_Id := Empty; + Par_Vis : Boolean := False; + + begin + Gen_Body_Id := Corresponding_Body (Gen_Decl); + + -- The instance body may already have been processed, as the parent of + -- another instance that is inlined (Load_Parent_Of_Generic). + + if Present (Corresponding_Body (Instance_Spec (Inst_Node))) then + return; + end if; + + Expander_Mode_Save_And_Set (Body_Info.Expander_Status); + + -- Re-establish the state of information on which checks are suppressed. + -- This information was set in Body_Info at the point of instantiation, + -- and now we restore it so that the instance is compiled using the + -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01). + + Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; + Scope_Suppress := Body_Info.Scope_Suppress; + Opt.Ada_Version := Body_Info.Version; + + if No (Gen_Body_Id) then + Load_Parent_Of_Generic + (Inst_Node, Specification (Gen_Decl), Body_Optional); + Gen_Body_Id := Corresponding_Body (Gen_Decl); + end if; + + -- Establish global variable for sloc adjustment and for error recovery + + Instantiation_Node := Inst_Node; + + if Present (Gen_Body_Id) then + Save_Env (Gen_Unit, Act_Decl_Id); + Style_Check := False; + Current_Sem_Unit := Body_Info.Current_Sem_Unit; + + Gen_Body := Unit_Declaration_Node (Gen_Body_Id); + + Create_Instantiation_Source + (Inst_Node, Gen_Body_Id, False, S_Adjustment); + + Act_Body := + Copy_Generic_Node + (Original_Node (Gen_Body), Empty, Instantiating => True); + + -- Build new name (possibly qualified) for body declaration + + Act_Body_Id := New_Copy (Act_Decl_Id); + + -- Some attributes of spec entity are not inherited by body entity + + Set_Handler_Records (Act_Body_Id, No_List); + + if Nkind (Defining_Unit_Name (Act_Spec)) = + N_Defining_Program_Unit_Name + then + Act_Body_Name := + Make_Defining_Program_Unit_Name (Loc, + Name => New_Copy_Tree (Name (Defining_Unit_Name (Act_Spec))), + Defining_Identifier => Act_Body_Id); + else + Act_Body_Name := Act_Body_Id; + end if; + + Set_Defining_Unit_Name (Act_Body, Act_Body_Name); + + Set_Corresponding_Spec (Act_Body, Act_Decl_Id); + Check_Generic_Actuals (Act_Decl_Id, False); + + -- If it is a child unit, make the parent instance (which is an + -- instance of the parent of the generic) visible. The parent + -- instance is the prefix of the name of the generic unit. + + if Ekind (Scope (Gen_Unit)) = E_Generic_Package + and then Nkind (Gen_Id) = N_Expanded_Name + then + Par_Ent := Entity (Prefix (Gen_Id)); + Par_Vis := Is_Immediately_Visible (Par_Ent); + Install_Parent (Par_Ent, In_Body => True); + Parent_Installed := True; + + elsif Is_Child_Unit (Gen_Unit) then + Par_Ent := Scope (Gen_Unit); + Par_Vis := Is_Immediately_Visible (Par_Ent); + Install_Parent (Par_Ent, In_Body => True); + Parent_Installed := True; + end if; + + -- If the instantiation is a library unit, and this is the main unit, + -- then build the resulting compilation unit nodes for the instance. + -- If this is a compilation unit but it is not the main unit, then it + -- is the body of a unit in the context, that is being compiled + -- because it is encloses some inlined unit or another generic unit + -- being instantiated. In that case, this body is not part of the + -- current compilation, and is not attached to the tree, but its + -- parent must be set for analysis. + + if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then + + -- Replace instance node with body of instance, and create new + -- node for corresponding instance declaration. + + Build_Instance_Compilation_Unit_Nodes + (Inst_Node, Act_Body, Act_Decl); + Analyze (Inst_Node); + + if Parent (Inst_Node) = Cunit (Main_Unit) then + + -- If the instance is a child unit itself, then set the scope + -- of the expanded body to be the parent of the instantiation + -- (ensuring that the fully qualified name will be generated + -- for the elaboration subprogram). + + if Nkind (Defining_Unit_Name (Act_Spec)) = + N_Defining_Program_Unit_Name + then + Set_Scope + (Defining_Entity (Inst_Node), Scope (Act_Decl_Id)); + end if; + end if; + + -- Case where instantiation is not a library unit + + else + -- If this is an early instantiation, i.e. appears textually + -- before the corresponding body and must be elaborated first, + -- indicate that the body instance is to be delayed. + + Install_Body (Act_Body, Inst_Node, Gen_Body, Gen_Decl); + + -- Now analyze the body. We turn off all checks if this is an + -- internal unit, since there is no reason to have checks on for + -- any predefined run-time library code. All such code is designed + -- to be compiled with checks off. + + -- Note that we do NOT apply this criterion to children of GNAT + -- (or on VMS, children of DEC). The latter units must suppress + -- checks explicitly if this is needed. + + if Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Gen_Decl))) + then + Analyze (Act_Body, Suppress => All_Checks); + else + Analyze (Act_Body); + end if; + end if; + + Inherit_Context (Gen_Body, Inst_Node); + + -- Remove the parent instances if they have been placed on the scope + -- stack to compile the body. + + if Parent_Installed then + Remove_Parent (In_Body => True); + + -- Restore the previous visibility of the parent + + Set_Is_Immediately_Visible (Par_Ent, Par_Vis); + end if; + + Restore_Private_Views (Act_Decl_Id); + + -- Remove the current unit from visibility if this is an instance + -- that is not elaborated on the fly for inlining purposes. + + if not Inlined_Body then + Set_Is_Immediately_Visible (Act_Decl_Id, False); + end if; + + Restore_Env; + Style_Check := Save_Style_Check; + + -- If we have no body, and the unit requires a body, then complain. This + -- complaint is suppressed if we have detected other errors (since a + -- common reason for missing the body is that it had errors). + -- In CodePeer mode, a warning has been emitted already, no need for + -- further messages. + + elsif Unit_Requires_Body (Gen_Unit) + and then not Body_Optional + then + if CodePeer_Mode then + null; + + elsif Serious_Errors_Detected = 0 then + Error_Msg_NE + ("cannot find body of generic package &", Inst_Node, Gen_Unit); + + -- Don't attempt to perform any cleanup actions if some other error + -- was already detected, since this can cause blowups. + + else + return; + end if; + + -- Case of package that does not need a body + + else + -- If the instantiation of the declaration is a library unit, rewrite + -- the original package instantiation as a package declaration in the + -- compilation unit node. + + if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then + Set_Parent_Spec (Act_Decl, Parent_Spec (Inst_Node)); + Rewrite (Inst_Node, Act_Decl); + + -- Generate elaboration entity, in case spec has elaboration code. + -- This cannot be done when the instance is analyzed, because it + -- is not known yet whether the body exists. + + Set_Elaboration_Entity_Required (Act_Decl_Id, False); + Build_Elaboration_Entity (Parent (Inst_Node), Act_Decl_Id); + + -- If the instantiation is not a library unit, then append the + -- declaration to the list of implicitly generated entities, unless + -- it is already a list member which means that it was already + -- processed + + elsif not Is_List_Member (Act_Decl) then + Mark_Rewrite_Insertion (Act_Decl); + Insert_Before (Inst_Node, Act_Decl); + end if; + end if; + + Expander_Mode_Restore; + end Instantiate_Package_Body; + + --------------------------------- + -- Instantiate_Subprogram_Body -- + --------------------------------- + + procedure Instantiate_Subprogram_Body + (Body_Info : Pending_Body_Info; + Body_Optional : Boolean := False) + is + Act_Decl : constant Node_Id := Body_Info.Act_Decl; + Inst_Node : constant Node_Id := Body_Info.Inst_Node; + Loc : constant Source_Ptr := Sloc (Inst_Node); + Gen_Id : constant Node_Id := Name (Inst_Node); + Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); + Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit); + Anon_Id : constant Entity_Id := + Defining_Unit_Name (Specification (Act_Decl)); + Pack_Id : constant Entity_Id := + Defining_Unit_Name (Parent (Act_Decl)); + Decls : List_Id; + Gen_Body : Node_Id; + Gen_Body_Id : Node_Id; + Act_Body : Node_Id; + Pack_Body : Node_Id; + Prev_Formal : Entity_Id; + Ret_Expr : Node_Id; + Unit_Renaming : Node_Id; + + Parent_Installed : Boolean := False; + Save_Style_Check : constant Boolean := Style_Check; + + Par_Ent : Entity_Id := Empty; + Par_Vis : Boolean := False; + + begin + Gen_Body_Id := Corresponding_Body (Gen_Decl); + + -- Subprogram body may have been created already because of an inline + -- pragma, or because of multiple elaborations of the enclosing package + -- when several instances of the subprogram appear in the main unit. + + if Present (Corresponding_Body (Act_Decl)) then + return; + end if; + + Expander_Mode_Save_And_Set (Body_Info.Expander_Status); + + -- Re-establish the state of information on which checks are suppressed. + -- This information was set in Body_Info at the point of instantiation, + -- and now we restore it so that the instance is compiled using the + -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01). + + Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; + Scope_Suppress := Body_Info.Scope_Suppress; + Opt.Ada_Version := Body_Info.Version; + + if No (Gen_Body_Id) then + + -- For imported generic subprogram, no body to compile, complete + -- the spec entity appropriately. + + if Is_Imported (Gen_Unit) then + Set_Is_Imported (Anon_Id); + Set_First_Rep_Item (Anon_Id, First_Rep_Item (Gen_Unit)); + Set_Interface_Name (Anon_Id, Interface_Name (Gen_Unit)); + Set_Convention (Anon_Id, Convention (Gen_Unit)); + Set_Has_Completion (Anon_Id); + return; + + -- For other cases, compile the body + + else + Load_Parent_Of_Generic + (Inst_Node, Specification (Gen_Decl), Body_Optional); + Gen_Body_Id := Corresponding_Body (Gen_Decl); + end if; + end if; + + Instantiation_Node := Inst_Node; + + if Present (Gen_Body_Id) then + Gen_Body := Unit_Declaration_Node (Gen_Body_Id); + + if Nkind (Gen_Body) = N_Subprogram_Body_Stub then + + -- Either body is not present, or context is non-expanding, as + -- when compiling a subunit. Mark the instance as completed, and + -- diagnose a missing body when needed. + + if Expander_Active + and then Operating_Mode = Generate_Code + then + Error_Msg_N + ("missing proper body for instantiation", Gen_Body); + end if; + + Set_Has_Completion (Anon_Id); + return; + end if; + + Save_Env (Gen_Unit, Anon_Id); + Style_Check := False; + Current_Sem_Unit := Body_Info.Current_Sem_Unit; + Create_Instantiation_Source + (Inst_Node, + Gen_Body_Id, + False, + S_Adjustment); + + Act_Body := + Copy_Generic_Node + (Original_Node (Gen_Body), Empty, Instantiating => True); + + -- Create proper defining name for the body, to correspond to + -- the one in the spec. + + Set_Defining_Unit_Name (Specification (Act_Body), + Make_Defining_Identifier + (Sloc (Defining_Entity (Inst_Node)), Chars (Anon_Id))); + Set_Corresponding_Spec (Act_Body, Anon_Id); + Set_Has_Completion (Anon_Id); + Check_Generic_Actuals (Pack_Id, False); + + -- Generate a reference to link the visible subprogram instance to + -- the generic body, which for navigation purposes is the only + -- available source for the instance. + + Generate_Reference + (Related_Instance (Pack_Id), + Gen_Body_Id, 'b', Set_Ref => False, Force => True); + + -- If it is a child unit, make the parent instance (which is an + -- instance of the parent of the generic) visible. The parent + -- instance is the prefix of the name of the generic unit. + + if Ekind (Scope (Gen_Unit)) = E_Generic_Package + and then Nkind (Gen_Id) = N_Expanded_Name + then + Par_Ent := Entity (Prefix (Gen_Id)); + Par_Vis := Is_Immediately_Visible (Par_Ent); + Install_Parent (Par_Ent, In_Body => True); + Parent_Installed := True; + + elsif Is_Child_Unit (Gen_Unit) then + Par_Ent := Scope (Gen_Unit); + Par_Vis := Is_Immediately_Visible (Par_Ent); + Install_Parent (Par_Ent, In_Body => True); + Parent_Installed := True; + end if; + + -- Inside its body, a reference to the generic unit is a reference + -- to the instance. The corresponding renaming is the first + -- declaration in the body. + + Unit_Renaming := + Make_Subprogram_Renaming_Declaration (Loc, + Specification => + Copy_Generic_Node ( + Specification (Original_Node (Gen_Body)), + Empty, + Instantiating => True), + Name => New_Occurrence_Of (Anon_Id, Loc)); + + -- If there is a formal subprogram with the same name as the unit + -- itself, do not add this renaming declaration. This is a temporary + -- fix for one ACVC test. ??? + + Prev_Formal := First_Entity (Pack_Id); + while Present (Prev_Formal) loop + if Chars (Prev_Formal) = Chars (Gen_Unit) + and then Is_Overloadable (Prev_Formal) + then + exit; + end if; + + Next_Entity (Prev_Formal); + end loop; + + if Present (Prev_Formal) then + Decls := New_List (Act_Body); + else + Decls := New_List (Unit_Renaming, Act_Body); + end if; + + -- The subprogram body is placed in the body of a dummy package body, + -- whose spec contains the subprogram declaration as well as the + -- renaming declarations for the generic parameters. + + Pack_Body := Make_Package_Body (Loc, + Defining_Unit_Name => New_Copy (Pack_Id), + Declarations => Decls); + + Set_Corresponding_Spec (Pack_Body, Pack_Id); + + -- If the instantiation is a library unit, then build resulting + -- compilation unit nodes for the instance. The declaration of + -- the enclosing package is the grandparent of the subprogram + -- declaration. First replace the instantiation node as the unit + -- of the corresponding compilation. + + if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then + if Parent (Inst_Node) = Cunit (Main_Unit) then + Set_Unit (Parent (Inst_Node), Inst_Node); + Build_Instance_Compilation_Unit_Nodes + (Inst_Node, Pack_Body, Parent (Parent (Act_Decl))); + Analyze (Inst_Node); + else + Set_Parent (Pack_Body, Parent (Inst_Node)); + Analyze (Pack_Body); + end if; + + else + Insert_Before (Inst_Node, Pack_Body); + Mark_Rewrite_Insertion (Pack_Body); + Analyze (Pack_Body); + + if Expander_Active then + Freeze_Subprogram_Body (Inst_Node, Gen_Body, Pack_Id); + end if; + end if; + + Inherit_Context (Gen_Body, Inst_Node); + + Restore_Private_Views (Pack_Id, False); + + if Parent_Installed then + Remove_Parent (In_Body => True); + + -- Restore the previous visibility of the parent + + Set_Is_Immediately_Visible (Par_Ent, Par_Vis); + end if; + + Restore_Env; + Style_Check := Save_Style_Check; + + -- Body not found. Error was emitted already. If there were no previous + -- errors, this may be an instance whose scope is a premature instance. + -- In that case we must insure that the (legal) program does raise + -- program error if executed. We generate a subprogram body for this + -- purpose. See DEC ac30vso. + + -- Should not reference proprietary DEC tests in comments ??? + + elsif Serious_Errors_Detected = 0 + and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit + then + if Body_Optional then + return; + + elsif Ekind (Anon_Id) = E_Procedure then + Act_Body := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Chars (Anon_Id)), + Parameter_Specifications => + New_Copy_List + (Parameter_Specifications (Parent (Anon_Id)))), + + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => + New_List ( + Make_Raise_Program_Error (Loc, + Reason => + PE_Access_Before_Elaboration)))); + + else + Ret_Expr := + Make_Raise_Program_Error (Loc, + Reason => PE_Access_Before_Elaboration); + + Set_Etype (Ret_Expr, (Etype (Anon_Id))); + Set_Analyzed (Ret_Expr); + + Act_Body := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Chars (Anon_Id)), + Parameter_Specifications => + New_Copy_List + (Parameter_Specifications (Parent (Anon_Id))), + Result_Definition => + New_Occurrence_Of (Etype (Anon_Id), Loc)), + + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => + New_List + (Make_Simple_Return_Statement (Loc, Ret_Expr)))); + end if; + + Pack_Body := Make_Package_Body (Loc, + Defining_Unit_Name => New_Copy (Pack_Id), + Declarations => New_List (Act_Body)); + + Insert_After (Inst_Node, Pack_Body); + Set_Corresponding_Spec (Pack_Body, Pack_Id); + Analyze (Pack_Body); + end if; + + Expander_Mode_Restore; + end Instantiate_Subprogram_Body; + + ---------------------- + -- Instantiate_Type -- + ---------------------- + + function Instantiate_Type + (Formal : Node_Id; + Actual : Node_Id; + Analyzed_Formal : Node_Id; + Actual_Decls : List_Id) return List_Id + is + Gen_T : constant Entity_Id := Defining_Identifier (Formal); + A_Gen_T : constant Entity_Id := + Defining_Identifier (Analyzed_Formal); + Ancestor : Entity_Id := Empty; + Def : constant Node_Id := Formal_Type_Definition (Formal); + Act_T : Entity_Id; + Decl_Node : Node_Id; + Decl_Nodes : List_Id; + Loc : Source_Ptr; + Subt : Entity_Id; + + procedure Validate_Array_Type_Instance; + procedure Validate_Access_Subprogram_Instance; + procedure Validate_Access_Type_Instance; + procedure Validate_Derived_Type_Instance; + procedure Validate_Derived_Interface_Type_Instance; + procedure Validate_Interface_Type_Instance; + procedure Validate_Private_Type_Instance; + -- These procedures perform validation tests for the named case + + function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean; + -- Check that base types are the same and that the subtypes match + -- statically. Used in several of the above. + + -------------------- + -- Subtypes_Match -- + -------------------- + + function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean is + T : constant Entity_Id := Get_Instance_Of (Gen_T); + + begin + return (Base_Type (T) = Base_Type (Act_T) + and then Subtypes_Statically_Match (T, Act_T)) + + or else (Is_Class_Wide_Type (Gen_T) + and then Is_Class_Wide_Type (Act_T) + and then + Subtypes_Match + (Get_Instance_Of (Root_Type (Gen_T)), + Root_Type (Act_T))) + + or else + ((Ekind (Gen_T) = E_Anonymous_Access_Subprogram_Type + or else Ekind (Gen_T) = E_Anonymous_Access_Type) + and then Ekind (Act_T) = Ekind (Gen_T) + and then + Subtypes_Statically_Match + (Designated_Type (Gen_T), Designated_Type (Act_T))); + end Subtypes_Match; + + ----------------------------------------- + -- Validate_Access_Subprogram_Instance -- + ----------------------------------------- + + procedure Validate_Access_Subprogram_Instance is + begin + if not Is_Access_Type (Act_T) + or else Ekind (Designated_Type (Act_T)) /= E_Subprogram_Type + then + Error_Msg_NE + ("expect access type in instantiation of &", Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; + + Check_Mode_Conformant + (Designated_Type (Act_T), + Designated_Type (A_Gen_T), + Actual, + Get_Inst => True); + + if Ekind (Base_Type (Act_T)) = E_Access_Protected_Subprogram_Type then + if Ekind (A_Gen_T) = E_Access_Subprogram_Type then + Error_Msg_NE + ("protected access type not allowed for formal &", + Actual, Gen_T); + end if; + + elsif Ekind (A_Gen_T) = E_Access_Protected_Subprogram_Type then + Error_Msg_NE + ("expect protected access type for formal &", + Actual, Gen_T); + end if; + end Validate_Access_Subprogram_Instance; + + ----------------------------------- + -- Validate_Access_Type_Instance -- + ----------------------------------- + + procedure Validate_Access_Type_Instance is + Desig_Type : constant Entity_Id := + Find_Actual_Type (Designated_Type (A_Gen_T), A_Gen_T); + Desig_Act : Entity_Id; + + begin + if not Is_Access_Type (Act_T) then + Error_Msg_NE + ("expect access type in instantiation of &", Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; + + if Is_Access_Constant (A_Gen_T) then + if not Is_Access_Constant (Act_T) then + Error_Msg_N + ("actual type must be access-to-constant type", Actual); + Abandon_Instantiation (Actual); + end if; + else + if Is_Access_Constant (Act_T) then + Error_Msg_N + ("actual type must be access-to-variable type", Actual); + Abandon_Instantiation (Actual); + + elsif Ekind (A_Gen_T) = E_General_Access_Type + and then Ekind (Base_Type (Act_T)) /= E_General_Access_Type + then + Error_Msg_N -- CODEFIX + ("actual must be general access type!", Actual); + Error_Msg_NE -- CODEFIX + ("add ALL to }!", Actual, Act_T); + Abandon_Instantiation (Actual); + end if; + end if; + + -- The designated subtypes, that is to say the subtypes introduced + -- by an access type declaration (and not by a subtype declaration) + -- must match. + + Desig_Act := Designated_Type (Base_Type (Act_T)); + + -- The designated type may have been introduced through a limited_ + -- with clause, in which case retrieve the non-limited view. This + -- applies to incomplete types as well as to class-wide types. + + if From_With_Type (Desig_Act) then + Desig_Act := Available_View (Desig_Act); + end if; + + if not Subtypes_Match + (Desig_Type, Desig_Act) then + Error_Msg_NE + ("designated type of actual does not match that of formal &", + Actual, Gen_T); + Abandon_Instantiation (Actual); + + elsif Is_Access_Type (Designated_Type (Act_T)) + and then Is_Constrained (Designated_Type (Designated_Type (Act_T))) + /= + Is_Constrained (Designated_Type (Desig_Type)) + then + Error_Msg_NE + ("designated type of actual does not match that of formal &", + Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; + + -- Ada 2005: null-exclusion indicators of the two types must agree + + if Can_Never_Be_Null (A_Gen_T) /= Can_Never_Be_Null (Act_T) then + Error_Msg_NE + ("non null exclusion of actual and formal & do not match", + Actual, Gen_T); + end if; + end Validate_Access_Type_Instance; + + ---------------------------------- + -- Validate_Array_Type_Instance -- + ---------------------------------- + + procedure Validate_Array_Type_Instance is + I1 : Node_Id; + I2 : Node_Id; + T2 : Entity_Id; + + function Formal_Dimensions return Int; + -- Count number of dimensions in array type formal + + ----------------------- + -- Formal_Dimensions -- + ----------------------- + + function Formal_Dimensions return Int is + Num : Int := 0; + Index : Node_Id; + + begin + if Nkind (Def) = N_Constrained_Array_Definition then + Index := First (Discrete_Subtype_Definitions (Def)); + else + Index := First (Subtype_Marks (Def)); + end if; + + while Present (Index) loop + Num := Num + 1; + Next_Index (Index); + end loop; + + return Num; + end Formal_Dimensions; + + -- Start of processing for Validate_Array_Type_Instance + + begin + if not Is_Array_Type (Act_T) then + Error_Msg_NE + ("expect array type in instantiation of &", Actual, Gen_T); + Abandon_Instantiation (Actual); + + elsif Nkind (Def) = N_Constrained_Array_Definition then + if not (Is_Constrained (Act_T)) then + Error_Msg_NE + ("expect constrained array in instantiation of &", + Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; + + else + if Is_Constrained (Act_T) then + Error_Msg_NE + ("expect unconstrained array in instantiation of &", + Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; + end if; + + if Formal_Dimensions /= Number_Dimensions (Act_T) then + Error_Msg_NE + ("dimensions of actual do not match formal &", Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; + + I1 := First_Index (A_Gen_T); + I2 := First_Index (Act_T); + for J in 1 .. Formal_Dimensions loop + + -- If the indexes of the actual were given by a subtype_mark, + -- the index was transformed into a range attribute. Retrieve + -- the original type mark for checking. + + if Is_Entity_Name (Original_Node (I2)) then + T2 := Entity (Original_Node (I2)); + else + T2 := Etype (I2); + end if; + + if not Subtypes_Match + (Find_Actual_Type (Etype (I1), A_Gen_T), T2) + then + Error_Msg_NE + ("index types of actual do not match those of formal &", + Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; + + Next_Index (I1); + Next_Index (I2); + end loop; + + -- Check matching subtypes. Note that there are complex visibility + -- issues when the generic is a child unit and some aspect of the + -- generic type is declared in a parent unit of the generic. We do + -- the test to handle this special case only after a direct check + -- for static matching has failed. + + if Subtypes_Match + (Component_Type (A_Gen_T), Component_Type (Act_T)) + or else Subtypes_Match + (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T), + Component_Type (Act_T)) + then + null; + else + Error_Msg_NE + ("component subtype of actual does not match that of formal &", + Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; + + if Has_Aliased_Components (A_Gen_T) + and then not Has_Aliased_Components (Act_T) + then + Error_Msg_NE + ("actual must have aliased components to match formal type &", + Actual, Gen_T); + end if; + end Validate_Array_Type_Instance; + + ----------------------------------------------- + -- Validate_Derived_Interface_Type_Instance -- + ----------------------------------------------- + + procedure Validate_Derived_Interface_Type_Instance is + Par : constant Entity_Id := Entity (Subtype_Indication (Def)); + Elmt : Elmt_Id; + + begin + -- First apply interface instance checks + + Validate_Interface_Type_Instance; + + -- Verify that immediate parent interface is an ancestor of + -- the actual. + + if Present (Par) + and then not Interface_Present_In_Ancestor (Act_T, Par) + then + Error_Msg_NE + ("interface actual must include progenitor&", Actual, Par); + end if; + + -- Now verify that the actual includes all other ancestors of + -- the formal. + + Elmt := First_Elmt (Interfaces (A_Gen_T)); + while Present (Elmt) loop + if not Interface_Present_In_Ancestor + (Act_T, Get_Instance_Of (Node (Elmt))) + then + Error_Msg_NE + ("interface actual must include progenitor&", + Actual, Node (Elmt)); + end if; + + Next_Elmt (Elmt); + end loop; + end Validate_Derived_Interface_Type_Instance; + + ------------------------------------ + -- Validate_Derived_Type_Instance -- + ------------------------------------ + + procedure Validate_Derived_Type_Instance is + Actual_Discr : Entity_Id; + Ancestor_Discr : Entity_Id; + + begin + -- If the parent type in the generic declaration is itself a previous + -- formal type, then it is local to the generic and absent from the + -- analyzed generic definition. In that case the ancestor is the + -- instance of the formal (which must have been instantiated + -- previously), unless the ancestor is itself a formal derived type. + -- In this latter case (which is the subject of Corrigendum 8652/0038 + -- (AI-202) the ancestor of the formals is the ancestor of its + -- parent. Otherwise, the analyzed generic carries the parent type. + -- If the parent type is defined in a previous formal package, then + -- the scope of that formal package is that of the generic type + -- itself, and it has already been mapped into the corresponding type + -- in the actual package. + + -- Common case: parent type defined outside of the generic + + if Is_Entity_Name (Subtype_Mark (Def)) + and then Present (Entity (Subtype_Mark (Def))) + then + Ancestor := Get_Instance_Of (Entity (Subtype_Mark (Def))); + + -- Check whether parent is defined in a previous formal package + + elsif + Scope (Scope (Base_Type (Etype (A_Gen_T)))) = Scope (A_Gen_T) + then + Ancestor := + Get_Instance_Of (Base_Type (Etype (A_Gen_T))); + + -- The type may be a local derivation, or a type extension of a + -- previous formal, or of a formal of a parent package. + + elsif Is_Derived_Type (Get_Instance_Of (A_Gen_T)) + or else + Ekind (Get_Instance_Of (A_Gen_T)) = E_Record_Type_With_Private + then + -- Check whether the parent is another derived formal type in the + -- same generic unit. + + if Etype (A_Gen_T) /= A_Gen_T + and then Is_Generic_Type (Etype (A_Gen_T)) + and then Scope (Etype (A_Gen_T)) = Scope (A_Gen_T) + and then Etype (Etype (A_Gen_T)) /= Etype (A_Gen_T) + then + -- Locate ancestor of parent from the subtype declaration + -- created for the actual. + + declare + Decl : Node_Id; + + begin + Decl := First (Actual_Decls); + while Present (Decl) loop + if Nkind (Decl) = N_Subtype_Declaration + and then Chars (Defining_Identifier (Decl)) = + Chars (Etype (A_Gen_T)) + then + Ancestor := Generic_Parent_Type (Decl); + exit; + else + Next (Decl); + end if; + end loop; + end; + + pragma Assert (Present (Ancestor)); + + else + Ancestor := + Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T))); + end if; + + else + Ancestor := Get_Instance_Of (Etype (Base_Type (A_Gen_T))); + end if; + + -- If the formal derived type has pragma Preelaborable_Initialization + -- then the actual type must have preelaborable initialization. + + if Known_To_Have_Preelab_Init (A_Gen_T) + and then not Has_Preelaborable_Initialization (Act_T) + then + Error_Msg_NE + ("actual for & must have preelaborable initialization", + Actual, Gen_T); + end if; + + -- Ada 2005 (AI-251) + + if Ada_Version >= Ada_2005 + and then Is_Interface (Ancestor) + then + if not Interface_Present_In_Ancestor (Act_T, Ancestor) then + Error_Msg_NE + ("(Ada 2005) expected type implementing & in instantiation", + Actual, Ancestor); + end if; + + elsif not Is_Ancestor (Base_Type (Ancestor), Act_T) then + Error_Msg_NE + ("expect type derived from & in instantiation", + Actual, First_Subtype (Ancestor)); + Abandon_Instantiation (Actual); + end if; + + -- Ada 2005 (AI-443): Synchronized formal derived type checks. Note + -- that the formal type declaration has been rewritten as a private + -- extension. + + if Ada_Version >= Ada_2005 + and then Nkind (Parent (A_Gen_T)) = N_Private_Extension_Declaration + and then Synchronized_Present (Parent (A_Gen_T)) + then + -- The actual must be a synchronized tagged type + + if not Is_Tagged_Type (Act_T) then + Error_Msg_N + ("actual of synchronized type must be tagged", Actual); + Abandon_Instantiation (Actual); + + elsif Nkind (Parent (Act_T)) = N_Full_Type_Declaration + and then Nkind (Type_Definition (Parent (Act_T))) = + N_Derived_Type_Definition + and then not Synchronized_Present (Type_Definition + (Parent (Act_T))) + then + Error_Msg_N + ("actual of synchronized type must be synchronized", Actual); + Abandon_Instantiation (Actual); + end if; + end if; + + -- Perform atomic/volatile checks (RM C.6(12)) + + if Is_Atomic (Act_T) and then not Is_Atomic (Ancestor) then + Error_Msg_N + ("cannot have atomic actual type for non-atomic formal type", + Actual); + + elsif Is_Volatile (Act_T) + and then not Is_Volatile (Ancestor) + and then Is_By_Reference_Type (Ancestor) + then + Error_Msg_N + ("cannot have volatile actual type for non-volatile formal type", + Actual); + end if; + + -- It should not be necessary to check for unknown discriminants on + -- Formal, but for some reason Has_Unknown_Discriminants is false for + -- A_Gen_T, so Is_Indefinite_Subtype incorrectly returns False. This + -- needs fixing. ??? + + if not Is_Indefinite_Subtype (A_Gen_T) + and then not Unknown_Discriminants_Present (Formal) + and then Is_Indefinite_Subtype (Act_T) + then + Error_Msg_N + ("actual subtype must be constrained", Actual); + Abandon_Instantiation (Actual); + end if; + + if not Unknown_Discriminants_Present (Formal) then + if Is_Constrained (Ancestor) then + if not Is_Constrained (Act_T) then + Error_Msg_N + ("actual subtype must be constrained", Actual); + Abandon_Instantiation (Actual); + end if; + + -- Ancestor is unconstrained, Check if generic formal and actual + -- agree on constrainedness. The check only applies to array types + -- and discriminated types. + + elsif Is_Constrained (Act_T) then + if Ekind (Ancestor) = E_Access_Type + or else + (not Is_Constrained (A_Gen_T) + and then Is_Composite_Type (A_Gen_T)) + then + Error_Msg_N + ("actual subtype must be unconstrained", Actual); + Abandon_Instantiation (Actual); + end if; + + -- A class-wide type is only allowed if the formal has unknown + -- discriminants. + + elsif Is_Class_Wide_Type (Act_T) + and then not Has_Unknown_Discriminants (Ancestor) + then + Error_Msg_NE + ("actual for & cannot be a class-wide type", Actual, Gen_T); + Abandon_Instantiation (Actual); + + -- Otherwise, the formal and actual shall have the same number + -- of discriminants and each discriminant of the actual must + -- correspond to a discriminant of the formal. + + elsif Has_Discriminants (Act_T) + and then not Has_Unknown_Discriminants (Act_T) + and then Has_Discriminants (Ancestor) + then + Actual_Discr := First_Discriminant (Act_T); + Ancestor_Discr := First_Discriminant (Ancestor); + while Present (Actual_Discr) + and then Present (Ancestor_Discr) + loop + if Base_Type (Act_T) /= Base_Type (Ancestor) and then + No (Corresponding_Discriminant (Actual_Discr)) + then + Error_Msg_NE + ("discriminant & does not correspond " & + "to ancestor discriminant", Actual, Actual_Discr); + Abandon_Instantiation (Actual); + end if; + + Next_Discriminant (Actual_Discr); + Next_Discriminant (Ancestor_Discr); + end loop; + + if Present (Actual_Discr) or else Present (Ancestor_Discr) then + Error_Msg_NE + ("actual for & must have same number of discriminants", + Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; + + -- This case should be caught by the earlier check for + -- constrainedness, but the check here is added for completeness. + + elsif Has_Discriminants (Act_T) + and then not Has_Unknown_Discriminants (Act_T) + then + Error_Msg_NE + ("actual for & must not have discriminants", Actual, Gen_T); + Abandon_Instantiation (Actual); + + elsif Has_Discriminants (Ancestor) then + Error_Msg_NE + ("actual for & must have known discriminants", Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; + + if not Subtypes_Statically_Compatible (Act_T, Ancestor) then + Error_Msg_N + ("constraint on actual is incompatible with formal", Actual); + Abandon_Instantiation (Actual); + end if; + end if; + + -- If the formal and actual types are abstract, check that there + -- are no abstract primitives of the actual type that correspond to + -- nonabstract primitives of the formal type (second sentence of + -- RM95-3.9.3(9)). + + if Is_Abstract_Type (A_Gen_T) and then Is_Abstract_Type (Act_T) then + Check_Abstract_Primitives : declare + Gen_Prims : constant Elist_Id := + Primitive_Operations (A_Gen_T); + Gen_Elmt : Elmt_Id; + Gen_Subp : Entity_Id; + Anc_Subp : Entity_Id; + Anc_Formal : Entity_Id; + Anc_F_Type : Entity_Id; + + Act_Prims : constant Elist_Id := Primitive_Operations (Act_T); + Act_Elmt : Elmt_Id; + Act_Subp : Entity_Id; + Act_Formal : Entity_Id; + Act_F_Type : Entity_Id; + + Subprograms_Correspond : Boolean; + + function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean; + -- Returns true if T2 is derived directly or indirectly from + -- T1, including derivations from interfaces. T1 and T2 are + -- required to be specific tagged base types. + + ------------------------ + -- Is_Tagged_Ancestor -- + ------------------------ + + function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean + is + Intfc_Elmt : Elmt_Id; + + begin + -- The predicate is satisfied if the types are the same + + if T1 = T2 then + return True; + + -- If we've reached the top of the derivation chain then + -- we know that T1 is not an ancestor of T2. + + elsif Etype (T2) = T2 then + return False; + + -- Proceed to check T2's immediate parent + + elsif Is_Ancestor (T1, Base_Type (Etype (T2))) then + return True; + + -- Finally, check to see if T1 is an ancestor of any of T2's + -- progenitors. + + else + Intfc_Elmt := First_Elmt (Interfaces (T2)); + while Present (Intfc_Elmt) loop + if Is_Ancestor (T1, Node (Intfc_Elmt)) then + return True; + end if; + + Next_Elmt (Intfc_Elmt); + end loop; + end if; + + return False; + end Is_Tagged_Ancestor; + + -- Start of processing for Check_Abstract_Primitives + + begin + -- Loop over all of the formal derived type's primitives + + Gen_Elmt := First_Elmt (Gen_Prims); + while Present (Gen_Elmt) loop + Gen_Subp := Node (Gen_Elmt); + + -- If the primitive of the formal is not abstract, then + -- determine whether there is a corresponding primitive of + -- the actual type that's abstract. + + if not Is_Abstract_Subprogram (Gen_Subp) then + Act_Elmt := First_Elmt (Act_Prims); + while Present (Act_Elmt) loop + Act_Subp := Node (Act_Elmt); + + -- If we find an abstract primitive of the actual, + -- then we need to test whether it corresponds to the + -- subprogram from which the generic formal primitive + -- is inherited. + + if Is_Abstract_Subprogram (Act_Subp) then + Anc_Subp := Alias (Gen_Subp); + + -- Test whether we have a corresponding primitive + -- by comparing names, kinds, formal types, and + -- result types. + + if Chars (Anc_Subp) = Chars (Act_Subp) + and then Ekind (Anc_Subp) = Ekind (Act_Subp) + then + Anc_Formal := First_Formal (Anc_Subp); + Act_Formal := First_Formal (Act_Subp); + while Present (Anc_Formal) + and then Present (Act_Formal) + loop + Anc_F_Type := Etype (Anc_Formal); + Act_F_Type := Etype (Act_Formal); + + if Ekind (Anc_F_Type) + = E_Anonymous_Access_Type + then + Anc_F_Type := Designated_Type (Anc_F_Type); + + if Ekind (Act_F_Type) + = E_Anonymous_Access_Type + then + Act_F_Type := + Designated_Type (Act_F_Type); + else + exit; + end if; + + elsif + Ekind (Act_F_Type) = E_Anonymous_Access_Type + then + exit; + end if; + + Anc_F_Type := Base_Type (Anc_F_Type); + Act_F_Type := Base_Type (Act_F_Type); + + -- If the formal is controlling, then the + -- the type of the actual primitive's formal + -- must be derived directly or indirectly + -- from the type of the ancestor primitive's + -- formal. + + if Is_Controlling_Formal (Anc_Formal) then + if not Is_Tagged_Ancestor + (Anc_F_Type, Act_F_Type) + then + exit; + end if; + + -- Otherwise the types of the formals must + -- be the same. + + elsif Anc_F_Type /= Act_F_Type then + exit; + end if; + + Next_Entity (Anc_Formal); + Next_Entity (Act_Formal); + end loop; + + -- If we traversed through all of the formals + -- then so far the subprograms correspond, so + -- now check that any result types correspond. + + if No (Anc_Formal) and then No (Act_Formal) then + Subprograms_Correspond := True; + + if Ekind (Act_Subp) = E_Function then + Anc_F_Type := Etype (Anc_Subp); + Act_F_Type := Etype (Act_Subp); + + if Ekind (Anc_F_Type) + = E_Anonymous_Access_Type + then + Anc_F_Type := + Designated_Type (Anc_F_Type); + + if Ekind (Act_F_Type) + = E_Anonymous_Access_Type + then + Act_F_Type := + Designated_Type (Act_F_Type); + else + Subprograms_Correspond := False; + end if; + + elsif + Ekind (Act_F_Type) + = E_Anonymous_Access_Type + then + Subprograms_Correspond := False; + end if; + + Anc_F_Type := Base_Type (Anc_F_Type); + Act_F_Type := Base_Type (Act_F_Type); + + -- Now either the result types must be + -- the same or, if the result type is + -- controlling, the result type of the + -- actual primitive must descend from the + -- result type of the ancestor primitive. + + if Subprograms_Correspond + and then Anc_F_Type /= Act_F_Type + and then + Has_Controlling_Result (Anc_Subp) + and then + not Is_Tagged_Ancestor + (Anc_F_Type, Act_F_Type) + then + Subprograms_Correspond := False; + end if; + end if; + + -- Found a matching subprogram belonging to + -- formal ancestor type, so actual subprogram + -- corresponds and this violates 3.9.3(9). + + if Subprograms_Correspond then + Error_Msg_NE + ("abstract subprogram & overrides " & + "nonabstract subprogram of ancestor", + Actual, + Act_Subp); + end if; + end if; + end if; + end if; + + Next_Elmt (Act_Elmt); + end loop; + end if; + + Next_Elmt (Gen_Elmt); + end loop; + end Check_Abstract_Primitives; + end if; + + -- Verify that limitedness matches. If parent is a limited + -- interface then the generic formal is not unless declared + -- explicitly so. If not declared limited, the actual cannot be + -- limited (see AI05-0087). + + -- Even though this AI is a binding interpretation, we enable the + -- check only in Ada 2012 mode, because this improper construct + -- shows up in user code and in existing B-tests. + + if Is_Limited_Type (Act_T) + and then not Is_Limited_Type (A_Gen_T) + and then Ada_Version >= Ada_2012 + then + Error_Msg_NE + ("actual for non-limited & cannot be a limited type", Actual, + Gen_T); + Explain_Limited_Type (Act_T, Actual); + Abandon_Instantiation (Actual); + end if; + end Validate_Derived_Type_Instance; + + -------------------------------------- + -- Validate_Interface_Type_Instance -- + -------------------------------------- + + procedure Validate_Interface_Type_Instance is + begin + if not Is_Interface (Act_T) then + Error_Msg_NE + ("actual for formal interface type must be an interface", + Actual, Gen_T); + + elsif Is_Limited_Type (Act_T) /= Is_Limited_Type (A_Gen_T) + or else + Is_Task_Interface (A_Gen_T) /= Is_Task_Interface (Act_T) + or else + Is_Protected_Interface (A_Gen_T) /= + Is_Protected_Interface (Act_T) + or else + Is_Synchronized_Interface (A_Gen_T) /= + Is_Synchronized_Interface (Act_T) + then + Error_Msg_NE + ("actual for interface& does not match (RM 12.5.5(4))", + Actual, Gen_T); + end if; + end Validate_Interface_Type_Instance; + + ------------------------------------ + -- Validate_Private_Type_Instance -- + ------------------------------------ + + procedure Validate_Private_Type_Instance is + Formal_Discr : Entity_Id; + Actual_Discr : Entity_Id; + Formal_Subt : Entity_Id; + + begin + if Is_Limited_Type (Act_T) + and then not Is_Limited_Type (A_Gen_T) + then + Error_Msg_NE + ("actual for non-limited & cannot be a limited type", Actual, + Gen_T); + Explain_Limited_Type (Act_T, Actual); + Abandon_Instantiation (Actual); + + elsif Known_To_Have_Preelab_Init (A_Gen_T) + and then not Has_Preelaborable_Initialization (Act_T) + then + Error_Msg_NE + ("actual for & must have preelaborable initialization", Actual, + Gen_T); + + elsif Is_Indefinite_Subtype (Act_T) + and then not Is_Indefinite_Subtype (A_Gen_T) + and then Ada_Version >= Ada_95 + then + Error_Msg_NE + ("actual for & must be a definite subtype", Actual, Gen_T); + + elsif not Is_Tagged_Type (Act_T) + and then Is_Tagged_Type (A_Gen_T) + then + Error_Msg_NE + ("actual for & must be a tagged type", Actual, Gen_T); + + elsif Has_Discriminants (A_Gen_T) then + if not Has_Discriminants (Act_T) then + Error_Msg_NE + ("actual for & must have discriminants", Actual, Gen_T); + Abandon_Instantiation (Actual); + + elsif Is_Constrained (Act_T) then + Error_Msg_NE + ("actual for & must be unconstrained", Actual, Gen_T); + Abandon_Instantiation (Actual); + + else + Formal_Discr := First_Discriminant (A_Gen_T); + Actual_Discr := First_Discriminant (Act_T); + while Formal_Discr /= Empty loop + if Actual_Discr = Empty then + Error_Msg_NE + ("discriminants on actual do not match formal", + Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; + + Formal_Subt := Get_Instance_Of (Etype (Formal_Discr)); + + -- Access discriminants match if designated types do + + if Ekind (Base_Type (Formal_Subt)) = E_Anonymous_Access_Type + and then (Ekind (Base_Type (Etype (Actual_Discr)))) = + E_Anonymous_Access_Type + and then + Get_Instance_Of + (Designated_Type (Base_Type (Formal_Subt))) = + Designated_Type (Base_Type (Etype (Actual_Discr))) + then + null; + + elsif Base_Type (Formal_Subt) /= + Base_Type (Etype (Actual_Discr)) + then + Error_Msg_NE + ("types of actual discriminants must match formal", + Actual, Gen_T); + Abandon_Instantiation (Actual); + + elsif not Subtypes_Statically_Match + (Formal_Subt, Etype (Actual_Discr)) + and then Ada_Version >= Ada_95 + then + Error_Msg_NE + ("subtypes of actual discriminants must match formal", + Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; + + Next_Discriminant (Formal_Discr); + Next_Discriminant (Actual_Discr); + end loop; + + if Actual_Discr /= Empty then + Error_Msg_NE + ("discriminants on actual do not match formal", + Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; + end if; + + end if; + + Ancestor := Gen_T; + end Validate_Private_Type_Instance; + + -- Start of processing for Instantiate_Type + + begin + if Get_Instance_Of (A_Gen_T) /= A_Gen_T then + Error_Msg_N ("duplicate instantiation of generic type", Actual); + return New_List (Error); + + elsif not Is_Entity_Name (Actual) + or else not Is_Type (Entity (Actual)) + then + Error_Msg_NE + ("expect valid subtype mark to instantiate &", Actual, Gen_T); + Abandon_Instantiation (Actual); + + else + Act_T := Entity (Actual); + + -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed + -- as a generic actual parameter if the corresponding formal type + -- does not have a known_discriminant_part, or is a formal derived + -- type that is an Unchecked_Union type. + + if Is_Unchecked_Union (Base_Type (Act_T)) then + if not Has_Discriminants (A_Gen_T) + or else + (Is_Derived_Type (A_Gen_T) + and then + Is_Unchecked_Union (A_Gen_T)) + then + null; + else + Error_Msg_N ("Unchecked_Union cannot be the actual for a" & + " discriminated formal type", Act_T); + + end if; + end if; + + -- Deal with fixed/floating restrictions + + if Is_Floating_Point_Type (Act_T) then + Check_Restriction (No_Floating_Point, Actual); + elsif Is_Fixed_Point_Type (Act_T) then + Check_Restriction (No_Fixed_Point, Actual); + end if; + + -- Deal with error of using incomplete type as generic actual. + -- This includes limited views of a type, even if the non-limited + -- view may be available. + + if Ekind (Act_T) = E_Incomplete_Type + or else (Is_Class_Wide_Type (Act_T) + and then + Ekind (Root_Type (Act_T)) = E_Incomplete_Type) + then + if Is_Class_Wide_Type (Act_T) + or else No (Full_View (Act_T)) + then + Error_Msg_N ("premature use of incomplete type", Actual); + Abandon_Instantiation (Actual); + else + Act_T := Full_View (Act_T); + Set_Entity (Actual, Act_T); + + if Has_Private_Component (Act_T) then + Error_Msg_N + ("premature use of type with private component", Actual); + end if; + end if; + + -- Deal with error of premature use of private type as generic actual + + elsif Is_Private_Type (Act_T) + and then Is_Private_Type (Base_Type (Act_T)) + and then not Is_Generic_Type (Act_T) + and then not Is_Derived_Type (Act_T) + and then No (Full_View (Root_Type (Act_T))) + then + Error_Msg_N ("premature use of private type", Actual); + + elsif Has_Private_Component (Act_T) then + Error_Msg_N + ("premature use of type with private component", Actual); + end if; + + Set_Instance_Of (A_Gen_T, Act_T); + + -- If the type is generic, the class-wide type may also be used + + if Is_Tagged_Type (A_Gen_T) + and then Is_Tagged_Type (Act_T) + and then not Is_Class_Wide_Type (A_Gen_T) + then + Set_Instance_Of (Class_Wide_Type (A_Gen_T), + Class_Wide_Type (Act_T)); + end if; + + if not Is_Abstract_Type (A_Gen_T) + and then Is_Abstract_Type (Act_T) + then + Error_Msg_N + ("actual of non-abstract formal cannot be abstract", Actual); + end if; + + -- A generic scalar type is a first subtype for which we generate + -- an anonymous base type. Indicate that the instance of this base + -- is the base type of the actual. + + if Is_Scalar_Type (A_Gen_T) then + Set_Instance_Of (Etype (A_Gen_T), Etype (Act_T)); + end if; + end if; + + if Error_Posted (Act_T) then + null; + else + case Nkind (Def) is + when N_Formal_Private_Type_Definition => + Validate_Private_Type_Instance; + + when N_Formal_Derived_Type_Definition => + Validate_Derived_Type_Instance; + + when N_Formal_Discrete_Type_Definition => + if not Is_Discrete_Type (Act_T) then + Error_Msg_NE + ("expect discrete type in instantiation of&", + Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; + + when N_Formal_Signed_Integer_Type_Definition => + if not Is_Signed_Integer_Type (Act_T) then + Error_Msg_NE + ("expect signed integer type in instantiation of&", + Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; + + when N_Formal_Modular_Type_Definition => + if not Is_Modular_Integer_Type (Act_T) then + Error_Msg_NE + ("expect modular type in instantiation of &", + Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; + + when N_Formal_Floating_Point_Definition => + if not Is_Floating_Point_Type (Act_T) then + Error_Msg_NE + ("expect float type in instantiation of &", Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; + + when N_Formal_Ordinary_Fixed_Point_Definition => + if not Is_Ordinary_Fixed_Point_Type (Act_T) then + Error_Msg_NE + ("expect ordinary fixed point type in instantiation of &", + Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; + + when N_Formal_Decimal_Fixed_Point_Definition => + if not Is_Decimal_Fixed_Point_Type (Act_T) then + Error_Msg_NE + ("expect decimal type in instantiation of &", + Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; + + when N_Array_Type_Definition => + Validate_Array_Type_Instance; + + when N_Access_To_Object_Definition => + Validate_Access_Type_Instance; + + when N_Access_Function_Definition | + N_Access_Procedure_Definition => + Validate_Access_Subprogram_Instance; + + when N_Record_Definition => + Validate_Interface_Type_Instance; + + when N_Derived_Type_Definition => + Validate_Derived_Interface_Type_Instance; + + when others => + raise Program_Error; + + end case; + end if; + + Subt := New_Copy (Gen_T); + + -- Use adjusted sloc of subtype name as the location for other nodes in + -- the subtype declaration. + + Loc := Sloc (Subt); + + Decl_Node := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Subt, + Subtype_Indication => New_Reference_To (Act_T, Loc)); + + if Is_Private_Type (Act_T) then + Set_Has_Private_View (Subtype_Indication (Decl_Node)); + + elsif Is_Access_Type (Act_T) + and then Is_Private_Type (Designated_Type (Act_T)) + then + Set_Has_Private_View (Subtype_Indication (Decl_Node)); + end if; + + Decl_Nodes := New_List (Decl_Node); + + -- Flag actual derived types so their elaboration produces the + -- appropriate renamings for the primitive operations of the ancestor. + -- Flag actual for formal private types as well, to determine whether + -- operations in the private part may override inherited operations. + -- If the formal has an interface list, the ancestor is not the + -- parent, but the analyzed formal that includes the interface + -- operations of all its progenitors. + + -- Same treatment for formal private types, so we can check whether the + -- type is tagged limited when validating derivations in the private + -- part. (See AI05-096). + + if Nkind (Def) = N_Formal_Derived_Type_Definition then + if Present (Interface_List (Def)) then + Set_Generic_Parent_Type (Decl_Node, A_Gen_T); + else + Set_Generic_Parent_Type (Decl_Node, Ancestor); + end if; + + elsif Nkind (Def) = N_Formal_Private_Type_Definition then + Set_Generic_Parent_Type (Decl_Node, A_Gen_T); + end if; + + -- If the actual is a synchronized type that implements an interface, + -- the primitive operations are attached to the corresponding record, + -- and we have to treat it as an additional generic actual, so that its + -- primitive operations become visible in the instance. The task or + -- protected type itself does not carry primitive operations. + + if Is_Concurrent_Type (Act_T) + and then Is_Tagged_Type (Act_T) + and then Present (Corresponding_Record_Type (Act_T)) + and then Present (Ancestor) + and then Is_Interface (Ancestor) + then + declare + Corr_Rec : constant Entity_Id := + Corresponding_Record_Type (Act_T); + New_Corr : Entity_Id; + Corr_Decl : Node_Id; + + begin + New_Corr := Make_Temporary (Loc, 'S'); + Corr_Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => New_Corr, + Subtype_Indication => + New_Reference_To (Corr_Rec, Loc)); + Append_To (Decl_Nodes, Corr_Decl); + + if Ekind (Act_T) = E_Task_Type then + Set_Ekind (Subt, E_Task_Subtype); + else + Set_Ekind (Subt, E_Protected_Subtype); + end if; + + Set_Corresponding_Record_Type (Subt, Corr_Rec); + Set_Generic_Parent_Type (Corr_Decl, Ancestor); + Set_Generic_Parent_Type (Decl_Node, Empty); + end; + end if; + + return Decl_Nodes; + end Instantiate_Type; + + --------------------- + -- Is_In_Main_Unit -- + --------------------- + + function Is_In_Main_Unit (N : Node_Id) return Boolean is + Unum : constant Unit_Number_Type := Get_Source_Unit (N); + Current_Unit : Node_Id; + + begin + if Unum = Main_Unit then + return True; + + -- If the current unit is a subunit then it is either the main unit or + -- is being compiled as part of the main unit. + + elsif Nkind (N) = N_Compilation_Unit then + return Nkind (Unit (N)) = N_Subunit; + end if; + + Current_Unit := Parent (N); + while Present (Current_Unit) + and then Nkind (Current_Unit) /= N_Compilation_Unit + loop + Current_Unit := Parent (Current_Unit); + end loop; + + -- The instantiation node is in the main unit, or else the current node + -- (perhaps as the result of nested instantiations) is in the main unit, + -- or in the declaration of the main unit, which in this last case must + -- be a body. + + return Unum = Main_Unit + or else Current_Unit = Cunit (Main_Unit) + or else Current_Unit = Library_Unit (Cunit (Main_Unit)) + or else (Present (Library_Unit (Current_Unit)) + and then Is_In_Main_Unit (Library_Unit (Current_Unit))); + end Is_In_Main_Unit; + + ---------------------------- + -- Load_Parent_Of_Generic -- + ---------------------------- + + procedure Load_Parent_Of_Generic + (N : Node_Id; + Spec : Node_Id; + Body_Optional : Boolean := False) + is + Comp_Unit : constant Node_Id := Cunit (Get_Source_Unit (Spec)); + Save_Style_Check : constant Boolean := Style_Check; + True_Parent : Node_Id; + Inst_Node : Node_Id; + OK : Boolean; + Previous_Instances : constant Elist_Id := New_Elmt_List; + + procedure Collect_Previous_Instances (Decls : List_Id); + -- Collect all instantiations in the given list of declarations, that + -- precede the generic that we need to load. If the bodies of these + -- instantiations are available, we must analyze them, to ensure that + -- the public symbols generated are the same when the unit is compiled + -- to generate code, and when it is compiled in the context of a unit + -- that needs a particular nested instance. This process is applied to + -- both package and subprogram instances. + + -------------------------------- + -- Collect_Previous_Instances -- + -------------------------------- + + procedure Collect_Previous_Instances (Decls : List_Id) is + Decl : Node_Id; + + begin + Decl := First (Decls); + while Present (Decl) loop + if Sloc (Decl) >= Sloc (Inst_Node) then + return; + + -- If Decl is an instantiation, then record it as requiring + -- instantiation of the corresponding body, except if it is an + -- abbreviated instantiation generated internally for conformance + -- checking purposes only for the case of a formal package + -- declared without a box (see Instantiate_Formal_Package). Such + -- an instantiation does not generate any code (the actual code + -- comes from actual) and thus does not need to be analyzed here. + -- If the instantiation appears with a generic package body it is + -- not analyzed here either. + + elsif Nkind (Decl) = N_Package_Instantiation + and then not Is_Internal (Defining_Entity (Decl)) + then + Append_Elmt (Decl, Previous_Instances); + + -- For a subprogram instantiation, omit instantiations intrinsic + -- operations (Unchecked_Conversions, etc.) that have no bodies. + + elsif Nkind_In (Decl, N_Function_Instantiation, + N_Procedure_Instantiation) + and then not Is_Intrinsic_Subprogram (Entity (Name (Decl))) + then + Append_Elmt (Decl, Previous_Instances); + + elsif Nkind (Decl) = N_Package_Declaration then + Collect_Previous_Instances + (Visible_Declarations (Specification (Decl))); + Collect_Previous_Instances + (Private_Declarations (Specification (Decl))); + + -- Previous non-generic bodies may contain instances as well + + elsif Nkind (Decl) = N_Package_Body + and then Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package + then + Collect_Previous_Instances (Declarations (Decl)); + + elsif Nkind (Decl) = N_Subprogram_Body + and then not Acts_As_Spec (Decl) + and then not Is_Generic_Subprogram (Corresponding_Spec (Decl)) + then + Collect_Previous_Instances (Declarations (Decl)); + end if; + + Next (Decl); + end loop; + end Collect_Previous_Instances; + + -- Start of processing for Load_Parent_Of_Generic + + begin + if not In_Same_Source_Unit (N, Spec) + or else Nkind (Unit (Comp_Unit)) = N_Package_Declaration + or else (Nkind (Unit (Comp_Unit)) = N_Package_Body + and then not Is_In_Main_Unit (Spec)) + then + -- Find body of parent of spec, and analyze it. A special case arises + -- when the parent is an instantiation, that is to say when we are + -- currently instantiating a nested generic. In that case, there is + -- no separate file for the body of the enclosing instance. Instead, + -- the enclosing body must be instantiated as if it were a pending + -- instantiation, in order to produce the body for the nested generic + -- we require now. Note that in that case the generic may be defined + -- in a package body, the instance defined in the same package body, + -- and the original enclosing body may not be in the main unit. + + Inst_Node := Empty; + + True_Parent := Parent (Spec); + while Present (True_Parent) + and then Nkind (True_Parent) /= N_Compilation_Unit + loop + if Nkind (True_Parent) = N_Package_Declaration + and then + Nkind (Original_Node (True_Parent)) = N_Package_Instantiation + then + -- Parent is a compilation unit that is an instantiation. + -- Instantiation node has been replaced with package decl. + + Inst_Node := Original_Node (True_Parent); + exit; + + elsif Nkind (True_Parent) = N_Package_Declaration + and then Present (Generic_Parent (Specification (True_Parent))) + and then Nkind (Parent (True_Parent)) /= N_Compilation_Unit + then + -- Parent is an instantiation within another specification. + -- Declaration for instance has been inserted before original + -- instantiation node. A direct link would be preferable? + + Inst_Node := Next (True_Parent); + while Present (Inst_Node) + and then Nkind (Inst_Node) /= N_Package_Instantiation + loop + Next (Inst_Node); + end loop; + + -- If the instance appears within a generic, and the generic + -- unit is defined within a formal package of the enclosing + -- generic, there is no generic body available, and none + -- needed. A more precise test should be used ??? + + if No (Inst_Node) then + return; + end if; + + exit; + + else + True_Parent := Parent (True_Parent); + end if; + end loop; + + -- Case where we are currently instantiating a nested generic + + if Present (Inst_Node) then + if Nkind (Parent (True_Parent)) = N_Compilation_Unit then + + -- Instantiation node and declaration of instantiated package + -- were exchanged when only the declaration was needed. + -- Restore instantiation node before proceeding with body. + + Set_Unit (Parent (True_Parent), Inst_Node); + end if; + + -- Now complete instantiation of enclosing body, if it appears in + -- some other unit. If it appears in the current unit, the body + -- will have been instantiated already. + + if No (Corresponding_Body (Instance_Spec (Inst_Node))) then + + -- We need to determine the expander mode to instantiate the + -- enclosing body. Because the generic body we need may use + -- global entities declared in the enclosing package (including + -- aggregates) it is in general necessary to compile this body + -- with expansion enabled, except if we are within a generic + -- package, in which case the usual generic rule applies. + + declare + Exp_Status : Boolean := True; + Scop : Entity_Id; + + begin + -- Loop through scopes looking for generic package + + Scop := Scope (Defining_Entity (Instance_Spec (Inst_Node))); + while Present (Scop) + and then Scop /= Standard_Standard + loop + if Ekind (Scop) = E_Generic_Package then + Exp_Status := False; + exit; + end if; + + Scop := Scope (Scop); + end loop; + + -- Collect previous instantiations in the unit that contains + -- the desired generic. + + if Nkind (Parent (True_Parent)) /= N_Compilation_Unit + and then not Body_Optional + then + declare + Decl : Elmt_Id; + Info : Pending_Body_Info; + Par : Node_Id; + + begin + Par := Parent (Inst_Node); + while Present (Par) loop + exit when Nkind (Parent (Par)) = N_Compilation_Unit; + Par := Parent (Par); + end loop; + + pragma Assert (Present (Par)); + + if Nkind (Par) = N_Package_Body then + Collect_Previous_Instances (Declarations (Par)); + + elsif Nkind (Par) = N_Package_Declaration then + Collect_Previous_Instances + (Visible_Declarations (Specification (Par))); + Collect_Previous_Instances + (Private_Declarations (Specification (Par))); + + else + -- Enclosing unit is a subprogram body. In this + -- case all instance bodies are processed in order + -- and there is no need to collect them separately. + + null; + end if; + + Decl := First_Elmt (Previous_Instances); + while Present (Decl) loop + Info := + (Inst_Node => Node (Decl), + Act_Decl => + Instance_Spec (Node (Decl)), + Expander_Status => Exp_Status, + Current_Sem_Unit => + Get_Code_Unit (Sloc (Node (Decl))), + Scope_Suppress => Scope_Suppress, + Local_Suppress_Stack_Top => + Local_Suppress_Stack_Top, + Version => Ada_Version); + + -- Package instance + + if + Nkind (Node (Decl)) = N_Package_Instantiation + then + Instantiate_Package_Body + (Info, Body_Optional => True); + + -- Subprogram instance + + else + -- The instance_spec is the wrapper package, + -- and the subprogram declaration is the last + -- declaration in the wrapper. + + Info.Act_Decl := + Last + (Visible_Declarations + (Specification (Info.Act_Decl))); + + Instantiate_Subprogram_Body + (Info, Body_Optional => True); + end if; + + Next_Elmt (Decl); + end loop; + end; + end if; + + Instantiate_Package_Body + (Body_Info => + ((Inst_Node => Inst_Node, + Act_Decl => True_Parent, + Expander_Status => Exp_Status, + Current_Sem_Unit => + Get_Code_Unit (Sloc (Inst_Node)), + Scope_Suppress => Scope_Suppress, + Local_Suppress_Stack_Top => + Local_Suppress_Stack_Top, + Version => Ada_Version)), + Body_Optional => Body_Optional); + end; + end if; + + -- Case where we are not instantiating a nested generic + + else + Opt.Style_Check := False; + Expander_Mode_Save_And_Set (True); + Load_Needed_Body (Comp_Unit, OK); + Opt.Style_Check := Save_Style_Check; + Expander_Mode_Restore; + + if not OK + and then Unit_Requires_Body (Defining_Entity (Spec)) + and then not Body_Optional + then + declare + Bname : constant Unit_Name_Type := + Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit))); + + begin + -- In CodePeer mode, the missing body may make the analysis + -- incomplete, but we do not treat it as fatal. + + if CodePeer_Mode then + return; + + else + Error_Msg_Unit_1 := Bname; + Error_Msg_N ("this instantiation requires$!", N); + Error_Msg_File_1 := + Get_File_Name (Bname, Subunit => False); + Error_Msg_N ("\but file{ was not found!", N); + raise Unrecoverable_Error; + end if; + end; + end if; + end if; + end if; + + -- If loading parent of the generic caused an instantiation circularity, + -- we abandon compilation at this point, because otherwise in some cases + -- we get into trouble with infinite recursions after this point. + + if Circularity_Detected then + raise Unrecoverable_Error; + end if; + end Load_Parent_Of_Generic; + + --------------------------------- + -- Map_Formal_Package_Entities -- + --------------------------------- + + procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id) is + E1 : Entity_Id; + E2 : Entity_Id; + + begin + Set_Instance_Of (Form, Act); + + -- Traverse formal and actual package to map the corresponding entities. + -- We skip over internal entities that may be generated during semantic + -- analysis, and find the matching entities by name, given that they + -- must appear in the same order. + + E1 := First_Entity (Form); + E2 := First_Entity (Act); + while Present (E1) and then E1 /= First_Private_Entity (Form) loop + -- Could this test be a single condition??? + -- Seems like it could, and isn't FPE (Form) a constant anyway??? + + if not Is_Internal (E1) + and then Present (Parent (E1)) + and then not Is_Class_Wide_Type (E1) + and then not Is_Internal_Name (Chars (E1)) + then + while Present (E2) and then Chars (E2) /= Chars (E1) loop + Next_Entity (E2); + end loop; + + if No (E2) then + exit; + else + Set_Instance_Of (E1, E2); + + if Is_Type (E1) and then Is_Tagged_Type (E2) then + Set_Instance_Of (Class_Wide_Type (E1), Class_Wide_Type (E2)); + end if; + + if Is_Constrained (E1) then + Set_Instance_Of (Base_Type (E1), Base_Type (E2)); + end if; + + if Ekind (E1) = E_Package and then No (Renamed_Object (E1)) then + Map_Formal_Package_Entities (E1, E2); + end if; + end if; + end if; + + Next_Entity (E1); + end loop; + end Map_Formal_Package_Entities; + + ----------------------- + -- Move_Freeze_Nodes -- + ----------------------- + + procedure Move_Freeze_Nodes + (Out_Of : Entity_Id; + After : Node_Id; + L : List_Id) + is + Decl : Node_Id; + Next_Decl : Node_Id; + Next_Node : Node_Id := After; + Spec : Node_Id; + + function Is_Outer_Type (T : Entity_Id) return Boolean; + -- Check whether entity is declared in a scope external to that of the + -- generic unit. + + ------------------- + -- Is_Outer_Type -- + ------------------- + + function Is_Outer_Type (T : Entity_Id) return Boolean is + Scop : Entity_Id := Scope (T); + + begin + if Scope_Depth (Scop) < Scope_Depth (Out_Of) then + return True; + + else + while Scop /= Standard_Standard loop + if Scop = Out_Of then + return False; + else + Scop := Scope (Scop); + end if; + end loop; + + return True; + end if; + end Is_Outer_Type; + + -- Start of processing for Move_Freeze_Nodes + + begin + if No (L) then + return; + end if; + + -- First remove the freeze nodes that may appear before all other + -- declarations. + + Decl := First (L); + while Present (Decl) + and then Nkind (Decl) = N_Freeze_Entity + and then Is_Outer_Type (Entity (Decl)) + loop + Decl := Remove_Head (L); + Insert_After (Next_Node, Decl); + Set_Analyzed (Decl, False); + Next_Node := Decl; + Decl := First (L); + end loop; + + -- Next scan the list of declarations and remove each freeze node that + -- appears ahead of the current node. + + while Present (Decl) loop + while Present (Next (Decl)) + and then Nkind (Next (Decl)) = N_Freeze_Entity + and then Is_Outer_Type (Entity (Next (Decl))) + loop + Next_Decl := Remove_Next (Decl); + Insert_After (Next_Node, Next_Decl); + Set_Analyzed (Next_Decl, False); + Next_Node := Next_Decl; + end loop; + + -- If the declaration is a nested package or concurrent type, then + -- recurse. Nested generic packages will have been processed from the + -- inside out. + + case Nkind (Decl) is + when N_Package_Declaration => + Spec := Specification (Decl); + + when N_Task_Type_Declaration => + Spec := Task_Definition (Decl); + + when N_Protected_Type_Declaration => + Spec := Protected_Definition (Decl); + + when others => + Spec := Empty; + end case; + + if Present (Spec) then + Move_Freeze_Nodes (Out_Of, Next_Node, Visible_Declarations (Spec)); + Move_Freeze_Nodes (Out_Of, Next_Node, Private_Declarations (Spec)); + end if; + + Next (Decl); + end loop; + end Move_Freeze_Nodes; + + ---------------- + -- Next_Assoc -- + ---------------- + + function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr is + begin + return Generic_Renamings.Table (E).Next_In_HTable; + end Next_Assoc; + + ------------------------ + -- Preanalyze_Actuals -- + ------------------------ + + procedure Preanalyze_Actuals (N : Node_Id) is + Assoc : Node_Id; + Act : Node_Id; + Errs : constant Int := Serious_Errors_Detected; + + Cur : Entity_Id := Empty; + -- Current homograph of the instance name + + Vis : Boolean; + -- Saved visibility status of the current homograph + + begin + Assoc := First (Generic_Associations (N)); + + -- If the instance is a child unit, its name may hide an outer homonym, + -- so make it invisible to perform name resolution on the actuals. + + if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name + and then Present + (Current_Entity (Defining_Identifier (Defining_Unit_Name (N)))) + then + Cur := Current_Entity (Defining_Identifier (Defining_Unit_Name (N))); + + if Is_Compilation_Unit (Cur) then + Vis := Is_Immediately_Visible (Cur); + Set_Is_Immediately_Visible (Cur, False); + else + Cur := Empty; + end if; + end if; + + while Present (Assoc) loop + if Nkind (Assoc) /= N_Others_Choice then + Act := Explicit_Generic_Actual_Parameter (Assoc); + + -- Within a nested instantiation, a defaulted actual is an empty + -- association, so nothing to analyze. If the subprogram actual + -- is an attribute, analyze prefix only, because actual is not a + -- complete attribute reference. + + -- If actual is an allocator, analyze expression only. The full + -- analysis can generate code, and if instance is a compilation + -- unit we have to wait until the package instance is installed + -- to have a proper place to insert this code. + + -- String literals may be operators, but at this point we do not + -- know whether the actual is a formal subprogram or a string. + + if No (Act) then + null; + + elsif Nkind (Act) = N_Attribute_Reference then + Analyze (Prefix (Act)); + + elsif Nkind (Act) = N_Explicit_Dereference then + Analyze (Prefix (Act)); + + elsif Nkind (Act) = N_Allocator then + declare + Expr : constant Node_Id := Expression (Act); + + begin + if Nkind (Expr) = N_Subtype_Indication then + Analyze (Subtype_Mark (Expr)); + + -- Analyze separately each discriminant constraint, when + -- given with a named association. + + declare + Constr : Node_Id; + + begin + Constr := First (Constraints (Constraint (Expr))); + while Present (Constr) loop + if Nkind (Constr) = N_Discriminant_Association then + Analyze (Expression (Constr)); + else + Analyze (Constr); + end if; + + Next (Constr); + end loop; + end; + + else + Analyze (Expr); + end if; + end; + + elsif Nkind (Act) /= N_Operator_Symbol then + Analyze (Act); + end if; + + if Errs /= Serious_Errors_Detected then + + -- Do a minimal analysis of the generic, to prevent spurious + -- warnings complaining about the generic being unreferenced, + -- before abandoning the instantiation. + + Analyze (Name (N)); + + if Is_Entity_Name (Name (N)) + and then Etype (Name (N)) /= Any_Type + then + Generate_Reference (Entity (Name (N)), Name (N)); + Set_Is_Instantiated (Entity (Name (N))); + end if; + + if Present (Cur) then + + -- For the case of a child instance hiding an outer homonym, + -- provide additional warning which might explain the error. + + Set_Is_Immediately_Visible (Cur, Vis); + Error_Msg_NE ("& hides outer unit with the same name?", + N, Defining_Unit_Name (N)); + end if; + + Abandon_Instantiation (Act); + end if; + end if; + + Next (Assoc); + end loop; + + if Present (Cur) then + Set_Is_Immediately_Visible (Cur, Vis); + end if; + end Preanalyze_Actuals; + + ------------------- + -- Remove_Parent -- + ------------------- + + procedure Remove_Parent (In_Body : Boolean := False) is + S : Entity_Id := Current_Scope; + -- S is the scope containing the instantiation just completed. The scope + -- stack contains the parent instances of the instantiation, followed by + -- the original S. + + Cur_P : Entity_Id; + E : Entity_Id; + P : Entity_Id; + Hidden : Elmt_Id; + + begin + -- After child instantiation is complete, remove from scope stack the + -- extra copy of the current scope, and then remove parent instances. + + if not In_Body then + Pop_Scope; + + while Current_Scope /= S loop + P := Current_Scope; + End_Package_Scope (Current_Scope); + + if In_Open_Scopes (P) then + E := First_Entity (P); + while Present (E) loop + Set_Is_Immediately_Visible (E, True); + Next_Entity (E); + end loop; + + -- If instantiation is declared in a block, it is the enclosing + -- scope that might be a parent instance. Note that only one + -- block can be involved, because the parent instances have + -- been installed within it. + + if Ekind (P) = E_Block then + Cur_P := Scope (P); + else + Cur_P := P; + end if; + + if Is_Generic_Instance (Cur_P) and then P /= Current_Scope then + -- We are within an instance of some sibling. Retain + -- visibility of parent, for proper subsequent cleanup, and + -- reinstall private declarations as well. + + Set_In_Private_Part (P); + Install_Private_Declarations (P); + end if; + + -- If the ultimate parent is a top-level unit recorded in + -- Instance_Parent_Unit, then reset its visibility to what it was + -- before instantiation. (It's not clear what the purpose is of + -- testing whether Scope (P) is In_Open_Scopes, but that test was + -- present before the ultimate parent test was added.???) + + elsif not In_Open_Scopes (Scope (P)) + or else (P = Instance_Parent_Unit + and then not Parent_Unit_Visible) + then + Set_Is_Immediately_Visible (P, False); + + -- If the current scope is itself an instantiation of a generic + -- nested within P, and we are in the private part of body of this + -- instantiation, restore the full views of P, that were removed + -- in End_Package_Scope above. This obscure case can occur when a + -- subunit of a generic contains an instance of a child unit of + -- its generic parent unit. + + elsif S = Current_Scope and then Is_Generic_Instance (S) then + declare + Par : constant Entity_Id := + Generic_Parent + (Specification (Unit_Declaration_Node (S))); + begin + if Present (Par) + and then P = Scope (Par) + and then (In_Package_Body (S) or else In_Private_Part (S)) + then + Set_In_Private_Part (P); + Install_Private_Declarations (P); + end if; + end; + end if; + end loop; + + -- Reset visibility of entities in the enclosing scope + + Set_Is_Hidden_Open_Scope (Current_Scope, False); + + Hidden := First_Elmt (Hidden_Entities); + while Present (Hidden) loop + Set_Is_Immediately_Visible (Node (Hidden), True); + Next_Elmt (Hidden); + end loop; + + else + -- Each body is analyzed separately, and there is no context that + -- needs preserving from one body instance to the next, so remove all + -- parent scopes that have been installed. + + while Present (S) loop + End_Package_Scope (S); + Set_Is_Immediately_Visible (S, False); + S := Current_Scope; + exit when S = Standard_Standard; + end loop; + end if; + end Remove_Parent; + + ----------------- + -- Restore_Env -- + ----------------- + + procedure Restore_Env is + Saved : Instance_Env renames Instance_Envs.Table (Instance_Envs.Last); + + begin + if No (Current_Instantiated_Parent.Act_Id) then + -- Restore environment after subprogram inlining + + Restore_Private_Views (Empty); + end if; + + Current_Instantiated_Parent := Saved.Instantiated_Parent; + Exchanged_Views := Saved.Exchanged_Views; + Hidden_Entities := Saved.Hidden_Entities; + Current_Sem_Unit := Saved.Current_Sem_Unit; + Parent_Unit_Visible := Saved.Parent_Unit_Visible; + Instance_Parent_Unit := Saved.Instance_Parent_Unit; + + Restore_Opt_Config_Switches (Saved.Switches); + + Instance_Envs.Decrement_Last; + end Restore_Env; + + --------------------------- + -- Restore_Private_Views -- + --------------------------- + + procedure Restore_Private_Views + (Pack_Id : Entity_Id; + Is_Package : Boolean := True) + is + M : Elmt_Id; + E : Entity_Id; + Typ : Entity_Id; + Dep_Elmt : Elmt_Id; + Dep_Typ : Node_Id; + + procedure Restore_Nested_Formal (Formal : Entity_Id); + -- Hide the generic formals of formal packages declared with box which + -- were reachable in the current instantiation. + + --------------------------- + -- Restore_Nested_Formal -- + --------------------------- + + procedure Restore_Nested_Formal (Formal : Entity_Id) is + Ent : Entity_Id; + + begin + if Present (Renamed_Object (Formal)) + and then Denotes_Formal_Package (Renamed_Object (Formal), True) + then + return; + + elsif Present (Associated_Formal_Package (Formal)) then + Ent := First_Entity (Formal); + while Present (Ent) loop + exit when Ekind (Ent) = E_Package + and then Renamed_Entity (Ent) = Renamed_Entity (Formal); + + Set_Is_Hidden (Ent); + Set_Is_Potentially_Use_Visible (Ent, False); + + -- If package, then recurse + + if Ekind (Ent) = E_Package then + Restore_Nested_Formal (Ent); + end if; + + Next_Entity (Ent); + end loop; + end if; + end Restore_Nested_Formal; + + -- Start of processing for Restore_Private_Views + + begin + M := First_Elmt (Exchanged_Views); + while Present (M) loop + Typ := Node (M); + + -- Subtypes of types whose views have been exchanged, and that are + -- defined within the instance, were not on the Private_Dependents + -- list on entry to the instance, so they have to be exchanged + -- explicitly now, in order to remain consistent with the view of the + -- parent type. + + if Ekind_In (Typ, E_Private_Type, + E_Limited_Private_Type, + E_Record_Type_With_Private) + then + Dep_Elmt := First_Elmt (Private_Dependents (Typ)); + while Present (Dep_Elmt) loop + Dep_Typ := Node (Dep_Elmt); + + if Scope (Dep_Typ) = Pack_Id + and then Present (Full_View (Dep_Typ)) + then + Replace_Elmt (Dep_Elmt, Full_View (Dep_Typ)); + Exchange_Declarations (Dep_Typ); + end if; + + Next_Elmt (Dep_Elmt); + end loop; + end if; + + Exchange_Declarations (Node (M)); + Next_Elmt (M); + end loop; + + if No (Pack_Id) then + return; + end if; + + -- Make the generic formal parameters private, and make the formal types + -- into subtypes of the actuals again. + + E := First_Entity (Pack_Id); + while Present (E) loop + Set_Is_Hidden (E, True); + + if Is_Type (E) + and then Nkind (Parent (E)) = N_Subtype_Declaration + then + Set_Is_Generic_Actual_Type (E, False); + + -- An unusual case of aliasing: the actual may also be directly + -- visible in the generic, and be private there, while it is fully + -- visible in the context of the instance. The internal subtype + -- is private in the instance but has full visibility like its + -- parent in the enclosing scope. This enforces the invariant that + -- the privacy status of all private dependents of a type coincide + -- with that of the parent type. This can only happen when a + -- generic child unit is instantiated within a sibling. + + if Is_Private_Type (E) + and then not Is_Private_Type (Etype (E)) + then + Exchange_Declarations (E); + end if; + + elsif Ekind (E) = E_Package then + + -- The end of the renaming list is the renaming of the generic + -- package itself. If the instance is a subprogram, all entities + -- in the corresponding package are renamings. If this entity is + -- a formal package, make its own formals private as well. The + -- actual in this case is itself the renaming of an instantiation. + -- If the entity is not a package renaming, it is the entity + -- created to validate formal package actuals: ignore it. + + -- If the actual is itself a formal package for the enclosing + -- generic, or the actual for such a formal package, it remains + -- visible on exit from the instance, and therefore nothing needs + -- to be done either, except to keep it accessible. + + if Is_Package and then Renamed_Object (E) = Pack_Id then + exit; + + elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then + null; + + elsif + Denotes_Formal_Package (Renamed_Object (E), True, Pack_Id) + then + Set_Is_Hidden (E, False); + + else + declare + Act_P : constant Entity_Id := Renamed_Object (E); + Id : Entity_Id; + + begin + Id := First_Entity (Act_P); + while Present (Id) + and then Id /= First_Private_Entity (Act_P) + loop + exit when Ekind (Id) = E_Package + and then Renamed_Object (Id) = Act_P; + + Set_Is_Hidden (Id, True); + Set_Is_Potentially_Use_Visible (Id, In_Use (Act_P)); + + if Ekind (Id) = E_Package then + Restore_Nested_Formal (Id); + end if; + + Next_Entity (Id); + end loop; + end; + end if; + end if; + + Next_Entity (E); + end loop; + end Restore_Private_Views; + + -------------- + -- Save_Env -- + -------------- + + procedure Save_Env + (Gen_Unit : Entity_Id; + Act_Unit : Entity_Id) + is + begin + Init_Env; + Set_Instance_Env (Gen_Unit, Act_Unit); + end Save_Env; + + ---------------------------- + -- Save_Global_References -- + ---------------------------- + + procedure Save_Global_References (N : Node_Id) is + Gen_Scope : Entity_Id; + E : Entity_Id; + N2 : Node_Id; + + function Is_Global (E : Entity_Id) return Boolean; + -- Check whether entity is defined outside of generic unit. Examine the + -- scope of an entity, and the scope of the scope, etc, until we find + -- either Standard, in which case the entity is global, or the generic + -- unit itself, which indicates that the entity is local. If the entity + -- is the generic unit itself, as in the case of a recursive call, or + -- the enclosing generic unit, if different from the current scope, then + -- it is local as well, because it will be replaced at the point of + -- instantiation. On the other hand, if it is a reference to a child + -- unit of a common ancestor, which appears in an instantiation, it is + -- global because it is used to denote a specific compilation unit at + -- the time the instantiations will be analyzed. + + procedure Reset_Entity (N : Node_Id); + -- Save semantic information on global entity so that it is not resolved + -- again at instantiation time. + + procedure Save_Entity_Descendants (N : Node_Id); + -- Apply Save_Global_References to the two syntactic descendants of + -- non-terminal nodes that carry an Associated_Node and are processed + -- through Reset_Entity. Once the global entity (if any) has been + -- captured together with its type, only two syntactic descendants need + -- to be traversed to complete the processing of the tree rooted at N. + -- This applies to Selected_Components, Expanded_Names, and to Operator + -- nodes. N can also be a character literal, identifier, or operator + -- symbol node, but the call has no effect in these cases. + + procedure Save_Global_Defaults (N1, N2 : Node_Id); + -- Default actuals in nested instances must be handled specially + -- because there is no link to them from the original tree. When an + -- actual subprogram is given by a default, we add an explicit generic + -- association for it in the instantiation node. When we save the + -- global references on the name of the instance, we recover the list + -- of generic associations, and add an explicit one to the original + -- generic tree, through which a global actual can be preserved. + -- Similarly, if a child unit is instantiated within a sibling, in the + -- context of the parent, we must preserve the identifier of the parent + -- so that it can be properly resolved in a subsequent instantiation. + + procedure Save_Global_Descendant (D : Union_Id); + -- Apply Save_Global_References recursively to the descendents of the + -- current node. + + procedure Save_References (N : Node_Id); + -- This is the recursive procedure that does the work, once the + -- enclosing generic scope has been established. + + --------------- + -- Is_Global -- + --------------- + + function Is_Global (E : Entity_Id) return Boolean is + Se : Entity_Id; + + function Is_Instance_Node (Decl : Node_Id) return Boolean; + -- Determine whether the parent node of a reference to a child unit + -- denotes an instantiation or a formal package, in which case the + -- reference to the child unit is global, even if it appears within + -- the current scope (e.g. when the instance appears within the body + -- of an ancestor). + + ---------------------- + -- Is_Instance_Node -- + ---------------------- + + function Is_Instance_Node (Decl : Node_Id) return Boolean is + begin + return Nkind (Decl) in N_Generic_Instantiation + or else + Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration; + end Is_Instance_Node; + + -- Start of processing for Is_Global + + begin + if E = Gen_Scope then + return False; + + elsif E = Standard_Standard then + return True; + + elsif Is_Child_Unit (E) + and then (Is_Instance_Node (Parent (N2)) + or else (Nkind (Parent (N2)) = N_Expanded_Name + and then N2 = Selector_Name (Parent (N2)) + and then + Is_Instance_Node (Parent (Parent (N2))))) + then + return True; + + else + Se := Scope (E); + while Se /= Gen_Scope loop + if Se = Standard_Standard then + return True; + else + Se := Scope (Se); + end if; + end loop; + + return False; + end if; + end Is_Global; + + ------------------ + -- Reset_Entity -- + ------------------ + + procedure Reset_Entity (N : Node_Id) is + + procedure Set_Global_Type (N : Node_Id; N2 : Node_Id); + -- If the type of N2 is global to the generic unit. Save the type in + -- the generic node. + -- What does this comment mean??? + + function Top_Ancestor (E : Entity_Id) return Entity_Id; + -- Find the ultimate ancestor of the current unit. If it is not a + -- generic unit, then the name of the current unit in the prefix of + -- an expanded name must be replaced with its generic homonym to + -- ensure that it will be properly resolved in an instance. + + --------------------- + -- Set_Global_Type -- + --------------------- + + procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is + Typ : constant Entity_Id := Etype (N2); + + begin + Set_Etype (N, Typ); + + if Entity (N) /= N2 + and then Has_Private_View (Entity (N)) + then + -- If the entity of N is not the associated node, this is a + -- nested generic and it has an associated node as well, whose + -- type is already the full view (see below). Indicate that the + -- original node has a private view. + + Set_Has_Private_View (N); + end if; + + -- If not a private type, nothing else to do + + if not Is_Private_Type (Typ) then + if Is_Array_Type (Typ) + and then Is_Private_Type (Component_Type (Typ)) + then + Set_Has_Private_View (N); + end if; + + -- If it is a derivation of a private type in a context where no + -- full view is needed, nothing to do either. + + elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then + null; + + -- Otherwise mark the type for flipping and use the full view when + -- available. + + else + Set_Has_Private_View (N); + + if Present (Full_View (Typ)) then + Set_Etype (N2, Full_View (Typ)); + end if; + end if; + end Set_Global_Type; + + ------------------ + -- Top_Ancestor -- + ------------------ + + function Top_Ancestor (E : Entity_Id) return Entity_Id is + Par : Entity_Id; + + begin + Par := E; + while Is_Child_Unit (Par) loop + Par := Scope (Par); + end loop; + + return Par; + end Top_Ancestor; + + -- Start of processing for Reset_Entity + + begin + N2 := Get_Associated_Node (N); + E := Entity (N2); + + -- If the entity is an itype created as a subtype of an access type + -- with a null exclusion restore source entity for proper visibility. + -- The itype will be created anew in the instance. + + if Present (E) then + if Is_Itype (E) + and then Ekind (E) = E_Access_Subtype + and then Is_Entity_Name (N) + and then Chars (Etype (E)) = Chars (N) + then + E := Etype (E); + Set_Entity (N2, E); + Set_Etype (N2, E); + end if; + + if Is_Global (E) then + Set_Global_Type (N, N2); + + elsif Nkind (N) = N_Op_Concat + and then Is_Generic_Type (Etype (N2)) + and then (Base_Type (Etype (Right_Opnd (N2))) = Etype (N2) + or else + Base_Type (Etype (Left_Opnd (N2))) = Etype (N2)) + and then Is_Intrinsic_Subprogram (E) + then + null; + + else + -- Entity is local. Mark generic node as unresolved. + -- Note that now it does not have an entity. + + Set_Associated_Node (N, Empty); + Set_Etype (N, Empty); + end if; + + if Nkind (Parent (N)) in N_Generic_Instantiation + and then N = Name (Parent (N)) + then + Save_Global_Defaults (Parent (N), Parent (N2)); + end if; + + elsif Nkind (Parent (N)) = N_Selected_Component + and then Nkind (Parent (N2)) = N_Expanded_Name + then + if Is_Global (Entity (Parent (N2))) then + Change_Selected_Component_To_Expanded_Name (Parent (N)); + Set_Associated_Node (Parent (N), Parent (N2)); + Set_Global_Type (Parent (N), Parent (N2)); + Save_Entity_Descendants (N); + + -- If this is a reference to the current generic entity, replace + -- by the name of the generic homonym of the current package. This + -- is because in an instantiation Par.P.Q will not resolve to the + -- name of the instance, whose enclosing scope is not necessarily + -- Par. We use the generic homonym rather that the name of the + -- generic itself because it may be hidden by a local declaration. + + elsif In_Open_Scopes (Entity (Parent (N2))) + and then not + Is_Generic_Unit (Top_Ancestor (Entity (Prefix (Parent (N2))))) + then + if Ekind (Entity (Parent (N2))) = E_Generic_Package then + Rewrite (Parent (N), + Make_Identifier (Sloc (N), + Chars => + Chars (Generic_Homonym (Entity (Parent (N2)))))); + else + Rewrite (Parent (N), + Make_Identifier (Sloc (N), + Chars => Chars (Selector_Name (Parent (N2))))); + end if; + end if; + + if Nkind (Parent (Parent (N))) in N_Generic_Instantiation + and then Parent (N) = Name (Parent (Parent (N))) + then + Save_Global_Defaults + (Parent (Parent (N)), Parent (Parent ((N2)))); + end if; + + -- A selected component may denote a static constant that has been + -- folded. If the static constant is global to the generic, capture + -- its value. Otherwise the folding will happen in any instantiation. + + elsif Nkind (Parent (N)) = N_Selected_Component + and then Nkind_In (Parent (N2), N_Integer_Literal, N_Real_Literal) + then + if Present (Entity (Original_Node (Parent (N2)))) + and then Is_Global (Entity (Original_Node (Parent (N2)))) + then + Rewrite (Parent (N), New_Copy (Parent (N2))); + Set_Analyzed (Parent (N), False); + + else + null; + end if; + + -- A selected component may be transformed into a parameterless + -- function call. If the called entity is global, rewrite the node + -- appropriately, i.e. as an extended name for the global entity. + + elsif Nkind (Parent (N)) = N_Selected_Component + and then Nkind (Parent (N2)) = N_Function_Call + and then N = Selector_Name (Parent (N)) + then + if No (Parameter_Associations (Parent (N2))) then + if Is_Global (Entity (Name (Parent (N2)))) then + Change_Selected_Component_To_Expanded_Name (Parent (N)); + Set_Associated_Node (Parent (N), Name (Parent (N2))); + Set_Global_Type (Parent (N), Name (Parent (N2))); + Save_Entity_Descendants (N); + + else + Set_Associated_Node (N, Empty); + Set_Etype (N, Empty); + end if; + + -- In Ada 2005, X.F may be a call to a primitive operation, + -- rewritten as F (X). This rewriting will be done again in an + -- instance, so keep the original node. Global entities will be + -- captured as for other constructs. + + else + null; + end if; + + -- Entity is local. Reset in generic unit, so that node is resolved + -- anew at the point of instantiation. + + else + Set_Associated_Node (N, Empty); + Set_Etype (N, Empty); + end if; + end Reset_Entity; + + ----------------------------- + -- Save_Entity_Descendants -- + ----------------------------- + + procedure Save_Entity_Descendants (N : Node_Id) is + begin + case Nkind (N) is + when N_Binary_Op => + Save_Global_Descendant (Union_Id (Left_Opnd (N))); + Save_Global_Descendant (Union_Id (Right_Opnd (N))); + + when N_Unary_Op => + Save_Global_Descendant (Union_Id (Right_Opnd (N))); + + when N_Expanded_Name | N_Selected_Component => + Save_Global_Descendant (Union_Id (Prefix (N))); + Save_Global_Descendant (Union_Id (Selector_Name (N))); + + when N_Identifier | N_Character_Literal | N_Operator_Symbol => + null; + + when others => + raise Program_Error; + end case; + end Save_Entity_Descendants; + + -------------------------- + -- Save_Global_Defaults -- + -------------------------- + + procedure Save_Global_Defaults (N1, N2 : Node_Id) is + Loc : constant Source_Ptr := Sloc (N1); + Assoc2 : constant List_Id := Generic_Associations (N2); + Gen_Id : constant Entity_Id := Get_Generic_Entity (N2); + Assoc1 : List_Id; + Act1 : Node_Id; + Act2 : Node_Id; + Def : Node_Id; + Ndec : Node_Id; + Subp : Entity_Id; + Actual : Entity_Id; + + begin + Assoc1 := Generic_Associations (N1); + + if Present (Assoc1) then + Act1 := First (Assoc1); + else + Act1 := Empty; + Set_Generic_Associations (N1, New_List); + Assoc1 := Generic_Associations (N1); + end if; + + if Present (Assoc2) then + Act2 := First (Assoc2); + else + return; + end if; + + while Present (Act1) and then Present (Act2) loop + Next (Act1); + Next (Act2); + end loop; + + -- Find the associations added for default subprograms + + if Present (Act2) then + while Nkind (Act2) /= N_Generic_Association + or else No (Entity (Selector_Name (Act2))) + or else not Is_Overloadable (Entity (Selector_Name (Act2))) + loop + Next (Act2); + end loop; + + -- Add a similar association if the default is global. The + -- renaming declaration for the actual has been analyzed, and + -- its alias is the program it renames. Link the actual in the + -- original generic tree with the node in the analyzed tree. + + while Present (Act2) loop + Subp := Entity (Selector_Name (Act2)); + Def := Explicit_Generic_Actual_Parameter (Act2); + + -- Following test is defence against rubbish errors + + if No (Alias (Subp)) then + return; + end if; + + -- Retrieve the resolved actual from the renaming declaration + -- created for the instantiated formal. + + Actual := Entity (Name (Parent (Parent (Subp)))); + Set_Entity (Def, Actual); + Set_Etype (Def, Etype (Actual)); + + if Is_Global (Actual) then + Ndec := + Make_Generic_Association (Loc, + Selector_Name => New_Occurrence_Of (Subp, Loc), + Explicit_Generic_Actual_Parameter => + New_Occurrence_Of (Actual, Loc)); + + Set_Associated_Node + (Explicit_Generic_Actual_Parameter (Ndec), Def); + + Append (Ndec, Assoc1); + + -- If there are other defaults, add a dummy association in case + -- there are other defaulted formals with the same name. + + elsif Present (Next (Act2)) then + Ndec := + Make_Generic_Association (Loc, + Selector_Name => New_Occurrence_Of (Subp, Loc), + Explicit_Generic_Actual_Parameter => Empty); + + Append (Ndec, Assoc1); + end if; + + Next (Act2); + end loop; + end if; + + if Nkind (Name (N1)) = N_Identifier + and then Is_Child_Unit (Gen_Id) + and then Is_Global (Gen_Id) + and then Is_Generic_Unit (Scope (Gen_Id)) + and then In_Open_Scopes (Scope (Gen_Id)) + then + -- This is an instantiation of a child unit within a sibling, so + -- that the generic parent is in scope. An eventual instance must + -- occur within the scope of an instance of the parent. Make name + -- in instance into an expanded name, to preserve the identifier + -- of the parent, so it can be resolved subsequently. + + Rewrite (Name (N2), + Make_Expanded_Name (Loc, + Chars => Chars (Gen_Id), + Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc), + Selector_Name => New_Occurrence_Of (Gen_Id, Loc))); + Set_Entity (Name (N2), Gen_Id); + + Rewrite (Name (N1), + Make_Expanded_Name (Loc, + Chars => Chars (Gen_Id), + Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc), + Selector_Name => New_Occurrence_Of (Gen_Id, Loc))); + + Set_Associated_Node (Name (N1), Name (N2)); + Set_Associated_Node (Prefix (Name (N1)), Empty); + Set_Associated_Node + (Selector_Name (Name (N1)), Selector_Name (Name (N2))); + Set_Etype (Name (N1), Etype (Gen_Id)); + end if; + + end Save_Global_Defaults; + + ---------------------------- + -- Save_Global_Descendant -- + ---------------------------- + + procedure Save_Global_Descendant (D : Union_Id) is + N1 : Node_Id; + + begin + if D in Node_Range then + if D = Union_Id (Empty) then + null; + + elsif Nkind (Node_Id (D)) /= N_Compilation_Unit then + Save_References (Node_Id (D)); + end if; + + elsif D in List_Range then + if D = Union_Id (No_List) + or else Is_Empty_List (List_Id (D)) + then + null; + + else + N1 := First (List_Id (D)); + while Present (N1) loop + Save_References (N1); + Next (N1); + end loop; + end if; + + -- Element list or other non-node field, nothing to do + + else + null; + end if; + end Save_Global_Descendant; + + --------------------- + -- Save_References -- + --------------------- + + -- This is the recursive procedure that does the work once the enclosing + -- generic scope has been established. We have to treat specially a + -- number of node rewritings that are required by semantic processing + -- and which change the kind of nodes in the generic copy: typically + -- constant-folding, replacing an operator node by a string literal, or + -- a selected component by an expanded name. In each of those cases, the + -- transformation is propagated to the generic unit. + + procedure Save_References (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + begin + if N = Empty then + null; + + elsif Nkind_In (N, N_Character_Literal, N_Operator_Symbol) then + if Nkind (N) = Nkind (Get_Associated_Node (N)) then + Reset_Entity (N); + + elsif Nkind (N) = N_Operator_Symbol + and then Nkind (Get_Associated_Node (N)) = N_String_Literal + then + Change_Operator_Symbol_To_String_Literal (N); + end if; + + elsif Nkind (N) in N_Op then + if Nkind (N) = Nkind (Get_Associated_Node (N)) then + if Nkind (N) = N_Op_Concat then + Set_Is_Component_Left_Opnd (N, + Is_Component_Left_Opnd (Get_Associated_Node (N))); + + Set_Is_Component_Right_Opnd (N, + Is_Component_Right_Opnd (Get_Associated_Node (N))); + end if; + + Reset_Entity (N); + + else + -- Node may be transformed into call to a user-defined operator + + N2 := Get_Associated_Node (N); + + if Nkind (N2) = N_Function_Call then + E := Entity (Name (N2)); + + if Present (E) + and then Is_Global (E) + then + Set_Etype (N, Etype (N2)); + else + Set_Associated_Node (N, Empty); + Set_Etype (N, Empty); + end if; + + elsif Nkind_In (N2, N_Integer_Literal, + N_Real_Literal, + N_String_Literal) + then + if Present (Original_Node (N2)) + and then Nkind (Original_Node (N2)) = Nkind (N) + then + + -- Operation was constant-folded. Whenever possible, + -- recover semantic information from unfolded node, + -- for ASIS use. + + Set_Associated_Node (N, Original_Node (N2)); + + if Nkind (N) = N_Op_Concat then + Set_Is_Component_Left_Opnd (N, + Is_Component_Left_Opnd (Get_Associated_Node (N))); + Set_Is_Component_Right_Opnd (N, + Is_Component_Right_Opnd (Get_Associated_Node (N))); + end if; + + Reset_Entity (N); + + else + -- If original node is already modified, propagate + -- constant-folding to template. + + Rewrite (N, New_Copy (N2)); + Set_Analyzed (N, False); + end if; + + elsif Nkind (N2) = N_Identifier + and then Ekind (Entity (N2)) = E_Enumeration_Literal + then + -- Same if call was folded into a literal, but in this case + -- retain the entity to avoid spurious ambiguities if it is + -- overloaded at the point of instantiation or inlining. + + Rewrite (N, New_Copy (N2)); + Set_Analyzed (N, False); + end if; + end if; + + -- Complete operands check if node has not been constant-folded + + if Nkind (N) in N_Op then + Save_Entity_Descendants (N); + end if; + + elsif Nkind (N) = N_Identifier then + if Nkind (N) = Nkind (Get_Associated_Node (N)) then + + -- If this is a discriminant reference, always save it. It is + -- used in the instance to find the corresponding discriminant + -- positionally rather than by name. + + Set_Original_Discriminant + (N, Original_Discriminant (Get_Associated_Node (N))); + Reset_Entity (N); + + else + N2 := Get_Associated_Node (N); + + if Nkind (N2) = N_Function_Call then + E := Entity (Name (N2)); + + -- Name resolves to a call to parameterless function. If + -- original entity is global, mark node as resolved. + + if Present (E) + and then Is_Global (E) + then + Set_Etype (N, Etype (N2)); + else + Set_Associated_Node (N, Empty); + Set_Etype (N, Empty); + end if; + + elsif Nkind_In (N2, N_Integer_Literal, N_Real_Literal) + and then Is_Entity_Name (Original_Node (N2)) + then + -- Name resolves to named number that is constant-folded, + -- We must preserve the original name for ASIS use, and + -- undo the constant-folding, which will be repeated in + -- each instance. + + Set_Associated_Node (N, Original_Node (N2)); + Reset_Entity (N); + + elsif Nkind (N2) = N_String_Literal then + + -- Name resolves to string literal. Perform the same + -- replacement in generic. + + Rewrite (N, New_Copy (N2)); + + elsif Nkind (N2) = N_Explicit_Dereference then + + -- An identifier is rewritten as a dereference if it is the + -- prefix in an implicit dereference (call or attribute). + -- The analysis of an instantiation will expand the node + -- again, so we preserve the original tree but link it to + -- the resolved entity in case it is global. + + if Is_Entity_Name (Prefix (N2)) + and then Present (Entity (Prefix (N2))) + and then Is_Global (Entity (Prefix (N2))) + then + Set_Associated_Node (N, Prefix (N2)); + + elsif Nkind (Prefix (N2)) = N_Function_Call + and then Is_Global (Entity (Name (Prefix (N2)))) + then + Rewrite (N, + Make_Explicit_Dereference (Loc, + Prefix => Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Entity (Name (Prefix (N2))), + Loc)))); + + else + Set_Associated_Node (N, Empty); + Set_Etype (N, Empty); + end if; + + -- The subtype mark of a nominally unconstrained object is + -- rewritten as a subtype indication using the bounds of the + -- expression. Recover the original subtype mark. + + elsif Nkind (N2) = N_Subtype_Indication + and then Is_Entity_Name (Original_Node (N2)) + then + Set_Associated_Node (N, Original_Node (N2)); + Reset_Entity (N); + + else + null; + end if; + end if; + + elsif Nkind (N) in N_Entity then + null; + + else + declare + Qual : Node_Id := Empty; + Typ : Entity_Id := Empty; + Nam : Node_Id; + + use Atree.Unchecked_Access; + -- This code section is part of implementing an untyped tree + -- traversal, so it needs direct access to node fields. + + begin + if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then + N2 := Get_Associated_Node (N); + + if No (N2) then + Typ := Empty; + else + Typ := Etype (N2); + + -- In an instance within a generic, use the name of the + -- actual and not the original generic parameter. If the + -- actual is global in the current generic it must be + -- preserved for its instantiation. + + if Nkind (Parent (Typ)) = N_Subtype_Declaration + and then + Present (Generic_Parent_Type (Parent (Typ))) + then + Typ := Base_Type (Typ); + Set_Etype (N2, Typ); + end if; + end if; + + if No (N2) + or else No (Typ) + or else not Is_Global (Typ) + then + Set_Associated_Node (N, Empty); + + -- If the aggregate is an actual in a call, it has been + -- resolved in the current context, to some local type. + -- The enclosing call may have been disambiguated by the + -- aggregate, and this disambiguation might fail at + -- instantiation time because the type to which the + -- aggregate did resolve is not preserved. In order to + -- preserve some of this information, we wrap the + -- aggregate in a qualified expression, using the id of + -- its type. For further disambiguation we qualify the + -- type name with its scope (if visible) because both + -- id's will have corresponding entities in an instance. + -- This resolves most of the problems with missing type + -- information on aggregates in instances. + + if Nkind (N2) = Nkind (N) + and then + Nkind_In (Parent (N2), N_Procedure_Call_Statement, + N_Function_Call) + and then Comes_From_Source (Typ) + then + if Is_Immediately_Visible (Scope (Typ)) then + Nam := Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Chars (Scope (Typ))), + Selector_Name => + Make_Identifier (Loc, Chars (Typ))); + else + Nam := Make_Identifier (Loc, Chars (Typ)); + end if; + + Qual := + Make_Qualified_Expression (Loc, + Subtype_Mark => Nam, + Expression => Relocate_Node (N)); + end if; + end if; + + Save_Global_Descendant (Field1 (N)); + Save_Global_Descendant (Field2 (N)); + Save_Global_Descendant (Field3 (N)); + Save_Global_Descendant (Field5 (N)); + + if Present (Qual) then + Rewrite (N, Qual); + end if; + + -- All other cases than aggregates + + else + -- For pragmas, we propagate the Enabled status for the + -- relevant pragmas to the original generic tree. This was + -- originally needed for SCO generation. It is no longer + -- needed there (since we use the Sloc value in calls to + -- Set_SCO_Pragma_Enabled), but it seems a generally good + -- idea to have this flag set properly. + + if Nkind (N) = N_Pragma + and then + (Pragma_Name (N) = Name_Assert or else + Pragma_Name (N) = Name_Check or else + Pragma_Name (N) = Name_Precondition or else + Pragma_Name (N) = Name_Postcondition) + and then Present (Associated_Node (Pragma_Identifier (N))) + then + Set_Pragma_Enabled (N, + Pragma_Enabled + (Parent (Associated_Node (Pragma_Identifier (N))))); + end if; + + Save_Global_Descendant (Field1 (N)); + Save_Global_Descendant (Field2 (N)); + Save_Global_Descendant (Field3 (N)); + Save_Global_Descendant (Field4 (N)); + Save_Global_Descendant (Field5 (N)); + end if; + end; + end if; + end Save_References; + + -- Start of processing for Save_Global_References + + begin + Gen_Scope := Current_Scope; + + -- If the generic unit is a child unit, references to entities in the + -- parent are treated as local, because they will be resolved anew in + -- the context of the instance of the parent. + + while Is_Child_Unit (Gen_Scope) + and then Ekind (Scope (Gen_Scope)) = E_Generic_Package + loop + Gen_Scope := Scope (Gen_Scope); + end loop; + + Save_References (N); + end Save_Global_References; + + -------------------------------------- + -- Set_Copied_Sloc_For_Inlined_Body -- + -------------------------------------- + + procedure Set_Copied_Sloc_For_Inlined_Body (N : Node_Id; E : Entity_Id) is + begin + Create_Instantiation_Source (N, E, True, S_Adjustment); + end Set_Copied_Sloc_For_Inlined_Body; + + --------------------- + -- Set_Instance_Of -- + --------------------- + + procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id) is + begin + Generic_Renamings.Table (Generic_Renamings.Last) := (A, B, Assoc_Null); + Generic_Renamings_HTable.Set (Generic_Renamings.Last); + Generic_Renamings.Increment_Last; + end Set_Instance_Of; + + -------------------- + -- Set_Next_Assoc -- + -------------------- + + procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr) is + begin + Generic_Renamings.Table (E).Next_In_HTable := Next; + end Set_Next_Assoc; + + ------------------- + -- Start_Generic -- + ------------------- + + procedure Start_Generic is + begin + -- ??? More things could be factored out in this routine. + -- Should probably be done at a later stage. + + Generic_Flags.Append (Inside_A_Generic); + Inside_A_Generic := True; + + Expander_Mode_Save_And_Set (False); + end Start_Generic; + + ---------------------- + -- Set_Instance_Env -- + ---------------------- + + procedure Set_Instance_Env + (Gen_Unit : Entity_Id; + Act_Unit : Entity_Id) + is + begin + -- Regardless of the current mode, predefined units are analyzed in the + -- most current Ada mode, and earlier version Ada checks do not apply + -- to predefined units. Nothing needs to be done for non-internal units. + -- These are always analyzed in the current mode. + + if Is_Internal_File_Name + (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)), + Renamings_Included => True) + then + Set_Opt_Config_Switches (True, Current_Sem_Unit = Main_Unit); + end if; + + Current_Instantiated_Parent := + (Gen_Id => Gen_Unit, + Act_Id => Act_Unit, + Next_In_HTable => Assoc_Null); + end Set_Instance_Env; + + ----------------- + -- Switch_View -- + ----------------- + + procedure Switch_View (T : Entity_Id) is + BT : constant Entity_Id := Base_Type (T); + Priv_Elmt : Elmt_Id := No_Elmt; + Priv_Sub : Entity_Id; + + begin + -- T may be private but its base type may have been exchanged through + -- some other occurrence, in which case there is nothing to switch + -- besides T itself. Note that a private dependent subtype of a private + -- type might not have been switched even if the base type has been, + -- because of the last branch of Check_Private_View (see comment there). + + if not Is_Private_Type (BT) then + Prepend_Elmt (Full_View (T), Exchanged_Views); + Exchange_Declarations (T); + return; + end if; + + Priv_Elmt := First_Elmt (Private_Dependents (BT)); + + if Present (Full_View (BT)) then + Prepend_Elmt (Full_View (BT), Exchanged_Views); + Exchange_Declarations (BT); + end if; + + while Present (Priv_Elmt) loop + Priv_Sub := (Node (Priv_Elmt)); + + -- We avoid flipping the subtype if the Etype of its full view is + -- private because this would result in a malformed subtype. This + -- occurs when the Etype of the subtype full view is the full view of + -- the base type (and since the base types were just switched, the + -- subtype is pointing to the wrong view). This is currently the case + -- for tagged record types, access types (maybe more?) and needs to + -- be resolved. ??? + + if Present (Full_View (Priv_Sub)) + and then not Is_Private_Type (Etype (Full_View (Priv_Sub))) + then + Prepend_Elmt (Full_View (Priv_Sub), Exchanged_Views); + Exchange_Declarations (Priv_Sub); + end if; + + Next_Elmt (Priv_Elmt); + end loop; + end Switch_View; + + ----------------------------- + -- Valid_Default_Attribute -- + ----------------------------- + + procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id) is + Attr_Id : constant Attribute_Id := + Get_Attribute_Id (Attribute_Name (Def)); + T : constant Entity_Id := Entity (Prefix (Def)); + Is_Fun : constant Boolean := (Ekind (Nam) = E_Function); + F : Entity_Id; + Num_F : Int; + OK : Boolean; + + begin + if No (T) + or else T = Any_Id + then + return; + end if; + + Num_F := 0; + F := First_Formal (Nam); + while Present (F) loop + Num_F := Num_F + 1; + Next_Formal (F); + end loop; + + case Attr_Id is + when Attribute_Adjacent | Attribute_Ceiling | Attribute_Copy_Sign | + Attribute_Floor | Attribute_Fraction | Attribute_Machine | + Attribute_Model | Attribute_Remainder | Attribute_Rounding | + Attribute_Unbiased_Rounding => + OK := Is_Fun + and then Num_F = 1 + and then Is_Floating_Point_Type (T); + + when Attribute_Image | Attribute_Pred | Attribute_Succ | + Attribute_Value | Attribute_Wide_Image | + Attribute_Wide_Value => + OK := (Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T)); + + when Attribute_Max | Attribute_Min => + OK := (Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T)); + + when Attribute_Input => + OK := (Is_Fun and then Num_F = 1); + + when Attribute_Output | Attribute_Read | Attribute_Write => + OK := (not Is_Fun and then Num_F = 2); + + when others => + OK := False; + end case; + + if not OK then + Error_Msg_N ("attribute reference has wrong profile for subprogram", + Def); + end if; + end Valid_Default_Attribute; + +end Sem_Ch12; diff --git a/gcc/ada/sem_ch12.ads b/gcc/ada/sem_ch12.ads new file mode 100644 index 000000000..676be37e3 --- /dev/null +++ b/gcc/ada/sem_ch12.ads @@ -0,0 +1,176 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 1 2 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Inline; use Inline; +with Types; use Types; + +package Sem_Ch12 is + procedure Analyze_Generic_Package_Declaration (N : Node_Id); + procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id); + procedure Analyze_Package_Instantiation (N : Node_Id); + procedure Analyze_Procedure_Instantiation (N : Node_Id); + procedure Analyze_Function_Instantiation (N : Node_Id); + procedure Analyze_Formal_Object_Declaration (N : Node_Id); + procedure Analyze_Formal_Type_Declaration (N : Node_Id); + procedure Analyze_Formal_Subprogram_Declaration (N : Node_Id); + procedure Analyze_Formal_Package_Declaration (N : Node_Id); + + procedure Start_Generic; + -- Must be invoked before starting to process a generic spec or body + + procedure End_Generic; + -- Must be invoked just at the end of the end of the processing of a + -- generic spec or body. + + procedure Check_Generic_Child_Unit + (Gen_Id : Node_Id; + Parent_Installed : in out Boolean); + -- If the name of the generic unit in an instantiation or a renaming is a + -- selected component, then the prefix may be an instance and the selector + -- may designate a child unit. Retrieve the parent generic and search for + -- the child unit that must be declared within. Similarly, if this is the + -- name of a generic child unit within an instantiation of its own parent, + -- retrieve the parent generic. If the parent is installed as a result of + -- this call, then Parent_Installed is set True, otherwise Parent_Installed + -- is unchanged by the call. + + function Copy_Generic_Node + (N : Node_Id; + Parent_Id : Node_Id; + Instantiating : Boolean) return Node_Id; + -- Copy the tree for a generic unit or its body. The unit is copied + -- repeatedly: once to produce a copy on which semantic analysis of + -- the generic is performed, and once for each instantiation. The tree + -- being copied is not semantically analyzed, except that references to + -- global entities are marked on terminal nodes. Note that this function + -- copies any aspect specifications from the input node N to the returned + -- node, as well as the setting of the Has_Aspects flag. + + function Get_Instance_Of (A : Entity_Id) return Entity_Id; + -- Retrieve actual associated with given generic parameter. + -- If A is uninstantiated or not a generic parameter, return A. + + function Get_Package_Instantiation_Node (A : Entity_Id) return Node_Id; + -- Given the entity of a unit that is an instantiation, retrieve the + -- original instance node. This is used when loading the instantiations + -- of the ancestors of a child generic that is being instantiated. + + procedure Instantiate_Package_Body + (Body_Info : Pending_Body_Info; + Inlined_Body : Boolean := False; + Body_Optional : Boolean := False); + -- Called after semantic analysis, to complete the instantiation of + -- package instances. The flag Inlined_Body is set if the body is + -- being instantiated on the fly for inlined purposes. + -- + -- The flag Body_Optional indicates that the call is for an instance + -- that precedes the current instance in the same declarative part. + -- This call is needed when instantiating a nested generic whose body + -- is to be found in the body of an instance. Normally we instantiate + -- package bodies only when they appear in the main unit, or when their + -- contents are needed for a nested generic G. If unit U contains several + -- instances I1, I2, etc. and I2 contains a nested generic, then when U + -- appears in the context of some other unit P that contains an instance + -- of G, we compile the body of I2, but not that of I1. However, when we + -- compile U as the main unit, we compile both bodies. This will lead to + -- lead to link-time errors if the compilation of I1 generates public + -- symbols, because those in I2 will receive different names in both + -- cases. This forces us to analyze the body of I1 even when U is not the + -- main unit. We don't want this additional mechanism to generate an error + -- when the body of the generic for I1 is not present, and this is the + -- reason for the presence of the flag Body_Optional, which is exchanged + -- between the current procedure and Load_Parent_Of_Generic. + + procedure Instantiate_Subprogram_Body + (Body_Info : Pending_Body_Info; + Body_Optional : Boolean := False); + -- Called after semantic analysis, to complete the instantiation of + -- function and procedure instances. The flag Body_Optional has the + -- same purpose as described for Instantiate_Package_Body. + + function Need_Subprogram_Instance_Body + (N : Node_Id; + Subp : Entity_Id) return Boolean; + + -- If a subprogram instance is inlined, indicate that the body of it + -- must be created, to be used in inlined calls by the back-end. The + -- subprogram may be inlined because the generic itself carries the + -- pragma, or because a pragma appears for the instance in the scope. + -- of the instance. + + procedure Save_Global_References (N : Node_Id); + -- Traverse the original generic unit, and capture all references to + -- entities that are defined outside of the generic in the analyzed + -- tree for the template. These references are copied into the original + -- tree, so that they appear automatically in every instantiation. + -- A critical invariant in this approach is that if an id in the generic + -- resolves to a local entity, the corresponding id in the instance + -- will resolve to the homologous entity in the instance, even though + -- the enclosing context for resolution is different, as long as the + -- global references have been captured as described here. + + -- Because instantiations can be nested, the environment of the instance, + -- involving the actuals and other data-structures, must be saved and + -- restored in stack-like fashion. Front-end inlining also uses these + -- structures for the management of private/full views. + + procedure Set_Copied_Sloc_For_Inlined_Body (N : Node_Id; E : Entity_Id); + -- This procedure is used when a subprogram body is inlined. This process + -- shares the same circuitry as the creation of an instantiated copy of + -- a generic template. The call to this procedure establishes a new source + -- file entry representing the inlined body as an instantiation, marked as + -- an inlined body (so that errout can distinguish cases for generating + -- error messages, otherwise the treatment is identical). In this call + -- N is the subprogram body and E is the defining identifier of the + -- subprogram in question. The resulting Sloc adjustment factor is + -- saved as part of the internal state of the Sem_Ch12 package for use + -- in subsequent calls to copy nodes. + + procedure Save_Env + (Gen_Unit : Entity_Id; + Act_Unit : Entity_Id); + -- ??? comment needed + + procedure Restore_Env; + -- ??? comment needed + + procedure Initialize; + -- Initializes internal data structures + + procedure Check_Private_View (N : Node_Id); + -- Check whether the type of a generic entity has a different view between + -- the point of generic analysis and the point of instantiation. If the + -- view has changed, then at the point of instantiation we restore the + -- correct view to perform semantic analysis of the instance, and reset + -- the current view after instantiation. The processing is driven by the + -- current private status of the type of the node, and Has_Private_View, + -- a flag that is set at the point of generic compilation. If view and + -- flag are inconsistent then the type is updated appropriately. + -- + -- This subprogram is used in Check_Generic_Actuals and Copy_Generic_Node, + -- and is exported here for the purpose of front-end inlining (see Exp_Ch6. + -- Expand_Inlined_Call.Process_Formals). + +end Sem_Ch12; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb new file mode 100644 index 000000000..128b398bf --- /dev/null +++ b/gcc/ada/sem_ch13.adb @@ -0,0 +1,7788 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 1 3 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Aspects; use Aspects; +with Atree; use Atree; +with Checks; use Checks; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Disp; use Exp_Disp; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Lib; use Lib; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Sinput; use Sinput; +with Snames; use Snames; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Stringt; use Stringt; +with Targparm; use Targparm; +with Ttypes; use Ttypes; +with Tbuild; use Tbuild; +with Urealp; use Urealp; + +with GNAT.Heap_Sort_G; + +package body Sem_Ch13 is + + SSU : constant Pos := System_Storage_Unit; + -- Convenient short hand for commonly used constant + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id); + -- This routine is called after setting the Esize of type entity Typ. + -- The purpose is to deal with the situation where an alignment has been + -- inherited from a derived type that is no longer appropriate for the + -- new Esize value. In this case, we reset the Alignment to unknown. + + procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id); + -- If Typ has predicates (indicated by Has_Predicates being set for Typ, + -- then either there are pragma Invariant entries on the rep chain for the + -- type (note that Predicate aspects are converted to pragma Predicate), or + -- there are inherited aspects from a parent type, or ancestor subtypes. + -- This procedure builds the spec and body for the Predicate function that + -- tests these predicates. N is the freeze node for the type. The spec of + -- the function is inserted before the freeze node, and the body of the + -- function is inserted after the freeze node. + + procedure Build_Static_Predicate + (Typ : Entity_Id; + Expr : Node_Id; + Nam : Name_Id); + -- Given a predicated type Typ, where Typ is a discrete static subtype, + -- whose predicate expression is Expr, tests if Expr is a static predicate, + -- and if so, builds the predicate range list. Nam is the name of the one + -- argument to the predicate function. Occurrences of the type name in the + -- predicate expression have been replaced by identifier references to this + -- name, which is unique, so any identifier with Chars matching Nam must be + -- a reference to the type. If the predicate is non-static, this procedure + -- returns doing nothing. If the predicate is static, then the predicate + -- list is stored in Static_Predicate (Typ), and the Expr is rewritten as + -- a canonicalized membership operation. + + function Get_Alignment_Value (Expr : Node_Id) return Uint; + -- Given the expression for an alignment value, returns the corresponding + -- Uint value. If the value is inappropriate, then error messages are + -- posted as required, and a value of No_Uint is returned. + + function Is_Operational_Item (N : Node_Id) return Boolean; + -- A specification for a stream attribute is allowed before the full type + -- is declared, as explained in AI-00137 and the corrigendum. Attributes + -- that do not specify a representation characteristic are operational + -- attributes. + + procedure New_Stream_Subprogram + (N : Node_Id; + Ent : Entity_Id; + Subp : Entity_Id; + Nam : TSS_Name_Type); + -- Create a subprogram renaming of a given stream attribute to the + -- designated subprogram and then in the tagged case, provide this as a + -- primitive operation, or in the non-tagged case make an appropriate TSS + -- entry. This is more properly an expansion activity than just semantics, + -- but the presence of user-defined stream functions for limited types is a + -- legality check, which is why this takes place here rather than in + -- exp_ch13, where it was previously. Nam indicates the name of the TSS + -- function to be generated. + -- + -- To avoid elaboration anomalies with freeze nodes, for untagged types + -- we generate both a subprogram declaration and a subprogram renaming + -- declaration, so that the attribute specification is handled as a + -- renaming_as_body. For tagged types, the specification is one of the + -- primitive specs. + + generic + with procedure Replace_Type_Reference (N : Node_Id); + procedure Replace_Type_References_Generic (N : Node_Id; TName : Name_Id); + -- This is used to scan an expression for a predicate or invariant aspect + -- replacing occurrences of the name TName (the name of the subtype to + -- which the aspect applies) with appropriate references to the parameter + -- of the predicate function or invariant procedure. The procedure passed + -- as a generic parameter does the actual replacement of node N, which is + -- either a simple direct reference to TName, or a selected component that + -- represents an appropriately qualified occurrence of TName. + + procedure Set_Biased + (E : Entity_Id; + N : Node_Id; + Msg : String; + Biased : Boolean := True); + -- If Biased is True, sets Has_Biased_Representation flag for E, and + -- outputs a warning message at node N if Warn_On_Biased_Representation is + -- is True. This warning inserts the string Msg to describe the construct + -- causing biasing. + + ---------------------------------------------- + -- Table for Validate_Unchecked_Conversions -- + ---------------------------------------------- + + -- The following table collects unchecked conversions for validation. + -- Entries are made by Validate_Unchecked_Conversion and then the + -- call to Validate_Unchecked_Conversions does the actual error + -- checking and posting of warnings. The reason for this delayed + -- processing is to take advantage of back-annotations of size and + -- alignment values performed by the back end. + + -- Note: the reason we store a Source_Ptr value instead of a Node_Id + -- is that by the time Validate_Unchecked_Conversions is called, Sprint + -- will already have modified all Sloc values if the -gnatD option is set. + + type UC_Entry is record + Eloc : Source_Ptr; -- node used for posting warnings + Source : Entity_Id; -- source type for unchecked conversion + Target : Entity_Id; -- target type for unchecked conversion + end record; + + package Unchecked_Conversions is new Table.Table ( + Table_Component_Type => UC_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 200, + Table_Name => "Unchecked_Conversions"); + + ---------------------------------------- + -- Table for Validate_Address_Clauses -- + ---------------------------------------- + + -- If an address clause has the form + + -- for X'Address use Expr + + -- where Expr is of the form Y'Address or recursively is a reference + -- to a constant of either of these forms, and X and Y are entities of + -- objects, then if Y has a smaller alignment than X, that merits a + -- warning about possible bad alignment. The following table collects + -- address clauses of this kind. We put these in a table so that they + -- can be checked after the back end has completed annotation of the + -- alignments of objects, since we can catch more cases that way. + + type Address_Clause_Check_Record is record + N : Node_Id; + -- The address clause + + X : Entity_Id; + -- The entity of the object overlaying Y + + Y : Entity_Id; + -- The entity of the object being overlaid + + Off : Boolean; + -- Whether the address is offset within Y + end record; + + package Address_Clause_Checks is new Table.Table ( + Table_Component_Type => Address_Clause_Check_Record, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 200, + Table_Name => "Address_Clause_Checks"); + + ----------------------------------------- + -- Adjust_Record_For_Reverse_Bit_Order -- + ----------------------------------------- + + procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is + Comp : Node_Id; + CC : Node_Id; + + begin + -- Processing depends on version of Ada + + -- For Ada 95, we just renumber bits within a storage unit. We do the + -- same for Ada 83 mode, since we recognize pragma Bit_Order in Ada 83, + -- and are free to add this extension. + + if Ada_Version < Ada_2005 then + Comp := First_Component_Or_Discriminant (R); + while Present (Comp) loop + CC := Component_Clause (Comp); + + -- If component clause is present, then deal with the non-default + -- bit order case for Ada 95 mode. + + -- We only do this processing for the base type, and in fact that + -- is important, since otherwise if there are record subtypes, we + -- could reverse the bits once for each subtype, which is wrong. + + if Present (CC) + and then Ekind (R) = E_Record_Type + then + declare + CFB : constant Uint := Component_Bit_Offset (Comp); + CSZ : constant Uint := Esize (Comp); + CLC : constant Node_Id := Component_Clause (Comp); + Pos : constant Node_Id := Position (CLC); + FB : constant Node_Id := First_Bit (CLC); + + Storage_Unit_Offset : constant Uint := + CFB / System_Storage_Unit; + + Start_Bit : constant Uint := + CFB mod System_Storage_Unit; + + begin + -- Cases where field goes over storage unit boundary + + if Start_Bit + CSZ > System_Storage_Unit then + + -- Allow multi-byte field but generate warning + + if Start_Bit mod System_Storage_Unit = 0 + and then CSZ mod System_Storage_Unit = 0 + then + Error_Msg_N + ("multi-byte field specified with non-standard" + & " Bit_Order?", CLC); + + if Bytes_Big_Endian then + Error_Msg_N + ("bytes are not reversed " + & "(component is big-endian)?", CLC); + else + Error_Msg_N + ("bytes are not reversed " + & "(component is little-endian)?", CLC); + end if; + + -- Do not allow non-contiguous field + + else + Error_Msg_N + ("attempt to specify non-contiguous field " + & "not permitted", CLC); + Error_Msg_N + ("\caused by non-standard Bit_Order " + & "specified", CLC); + Error_Msg_N + ("\consider possibility of using " + & "Ada 2005 mode here", CLC); + end if; + + -- Case where field fits in one storage unit + + else + -- Give warning if suspicious component clause + + if Intval (FB) >= System_Storage_Unit + and then Warn_On_Reverse_Bit_Order + then + Error_Msg_N + ("?Bit_Order clause does not affect " & + "byte ordering", Pos); + Error_Msg_Uint_1 := + Intval (Pos) + Intval (FB) / + System_Storage_Unit; + Error_Msg_N + ("?position normalized to ^ before bit " & + "order interpreted", Pos); + end if; + + -- Here is where we fix up the Component_Bit_Offset value + -- to account for the reverse bit order. Some examples of + -- what needs to be done are: + + -- First_Bit .. Last_Bit Component_Bit_Offset + -- old new old new + + -- 0 .. 0 7 .. 7 0 7 + -- 0 .. 1 6 .. 7 0 6 + -- 0 .. 2 5 .. 7 0 5 + -- 0 .. 7 0 .. 7 0 4 + + -- 1 .. 1 6 .. 6 1 6 + -- 1 .. 4 3 .. 6 1 3 + -- 4 .. 7 0 .. 3 4 0 + + -- The rule is that the first bit is is obtained by + -- subtracting the old ending bit from storage_unit - 1. + + Set_Component_Bit_Offset + (Comp, + (Storage_Unit_Offset * System_Storage_Unit) + + (System_Storage_Unit - 1) - + (Start_Bit + CSZ - 1)); + + Set_Normalized_First_Bit + (Comp, + Component_Bit_Offset (Comp) mod + System_Storage_Unit); + end if; + end; + end if; + + Next_Component_Or_Discriminant (Comp); + end loop; + + -- For Ada 2005, we do machine scalar processing, as fully described In + -- AI-133. This involves gathering all components which start at the + -- same byte offset and processing them together. Same approach is still + -- valid in later versions including Ada 2012. + + else + declare + Max_Machine_Scalar_Size : constant Uint := + UI_From_Int + (Standard_Long_Long_Integer_Size); + -- We use this as the maximum machine scalar size + + Num_CC : Natural; + SSU : constant Uint := UI_From_Int (System_Storage_Unit); + + begin + -- This first loop through components does two things. First it + -- deals with the case of components with component clauses whose + -- length is greater than the maximum machine scalar size (either + -- accepting them or rejecting as needed). Second, it counts the + -- number of components with component clauses whose length does + -- not exceed this maximum for later processing. + + Num_CC := 0; + Comp := First_Component_Or_Discriminant (R); + while Present (Comp) loop + CC := Component_Clause (Comp); + + if Present (CC) then + declare + Fbit : constant Uint := + Static_Integer (First_Bit (CC)); + Lbit : constant Uint := + Static_Integer (Last_Bit (CC)); + + begin + -- Case of component with last bit >= max machine scalar + + if Lbit >= Max_Machine_Scalar_Size then + + -- This is allowed only if first bit is zero, and + -- last bit + 1 is a multiple of storage unit size. + + if Fbit = 0 and then (Lbit + 1) mod SSU = 0 then + + -- This is the case to give a warning if enabled + + if Warn_On_Reverse_Bit_Order then + Error_Msg_N + ("multi-byte field specified with " + & " non-standard Bit_Order?", CC); + + if Bytes_Big_Endian then + Error_Msg_N + ("\bytes are not reversed " + & "(component is big-endian)?", CC); + else + Error_Msg_N + ("\bytes are not reversed " + & "(component is little-endian)?", CC); + end if; + end if; + + -- Give error message for RM 13.4.1(10) violation + + else + Error_Msg_FE + ("machine scalar rules not followed for&", + First_Bit (CC), Comp); + + Error_Msg_Uint_1 := Lbit; + Error_Msg_Uint_2 := Max_Machine_Scalar_Size; + Error_Msg_F + ("\last bit (^) exceeds maximum machine " + & "scalar size (^)", + First_Bit (CC)); + + if (Lbit + 1) mod SSU /= 0 then + Error_Msg_Uint_1 := SSU; + Error_Msg_F + ("\and is not a multiple of Storage_Unit (^) " + & "('R'M 13.4.1(10))", + First_Bit (CC)); + + else + Error_Msg_Uint_1 := Fbit; + Error_Msg_F + ("\and first bit (^) is non-zero " + & "('R'M 13.4.1(10))", + First_Bit (CC)); + end if; + end if; + + -- OK case of machine scalar related component clause, + -- For now, just count them. + + else + Num_CC := Num_CC + 1; + end if; + end; + end if; + + Next_Component_Or_Discriminant (Comp); + end loop; + + -- We need to sort the component clauses on the basis of the + -- Position values in the clause, so we can group clauses with + -- the same Position. together to determine the relevant machine + -- scalar size. + + Sort_CC : declare + Comps : array (0 .. Num_CC) of Entity_Id; + -- Array to collect component and discriminant entities. The + -- data starts at index 1, the 0'th entry is for the sort + -- routine. + + function CP_Lt (Op1, Op2 : Natural) return Boolean; + -- Compare routine for Sort + + procedure CP_Move (From : Natural; To : Natural); + -- Move routine for Sort + + package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt); + + Start : Natural; + Stop : Natural; + -- Start and stop positions in the component list of the set of + -- components with the same starting position (that constitute + -- components in a single machine scalar). + + MaxL : Uint; + -- Maximum last bit value of any component in this set + + MSS : Uint; + -- Corresponding machine scalar size + + ----------- + -- CP_Lt -- + ----------- + + function CP_Lt (Op1, Op2 : Natural) return Boolean is + begin + return Position (Component_Clause (Comps (Op1))) < + Position (Component_Clause (Comps (Op2))); + end CP_Lt; + + ------------- + -- CP_Move -- + ------------- + + procedure CP_Move (From : Natural; To : Natural) is + begin + Comps (To) := Comps (From); + end CP_Move; + + -- Start of processing for Sort_CC + + begin + -- Collect the machine scalar relevant component clauses + + Num_CC := 0; + Comp := First_Component_Or_Discriminant (R); + while Present (Comp) loop + declare + CC : constant Node_Id := Component_Clause (Comp); + + begin + -- Collect only component clauses whose last bit is less + -- than machine scalar size. Any component clause whose + -- last bit exceeds this value does not take part in + -- machine scalar layout considerations. The test for + -- Error_Posted makes sure we exclude component clauses + -- for which we already posted an error. + + if Present (CC) + and then not Error_Posted (Last_Bit (CC)) + and then Static_Integer (Last_Bit (CC)) < + Max_Machine_Scalar_Size + then + Num_CC := Num_CC + 1; + Comps (Num_CC) := Comp; + end if; + end; + + Next_Component_Or_Discriminant (Comp); + end loop; + + -- Sort by ascending position number + + Sorting.Sort (Num_CC); + + -- We now have all the components whose size does not exceed + -- the max machine scalar value, sorted by starting position. + -- In this loop we gather groups of clauses starting at the + -- same position, to process them in accordance with AI-133. + + Stop := 0; + while Stop < Num_CC loop + Start := Stop + 1; + Stop := Start; + MaxL := + Static_Integer + (Last_Bit (Component_Clause (Comps (Start)))); + while Stop < Num_CC loop + if Static_Integer + (Position (Component_Clause (Comps (Stop + 1)))) = + Static_Integer + (Position (Component_Clause (Comps (Stop)))) + then + Stop := Stop + 1; + MaxL := + UI_Max + (MaxL, + Static_Integer + (Last_Bit + (Component_Clause (Comps (Stop))))); + else + exit; + end if; + end loop; + + -- Now we have a group of component clauses from Start to + -- Stop whose positions are identical, and MaxL is the + -- maximum last bit value of any of these components. + + -- We need to determine the corresponding machine scalar + -- size. This loop assumes that machine scalar sizes are + -- even, and that each possible machine scalar has twice + -- as many bits as the next smaller one. + + MSS := Max_Machine_Scalar_Size; + while MSS mod 2 = 0 + and then (MSS / 2) >= SSU + and then (MSS / 2) > MaxL + loop + MSS := MSS / 2; + end loop; + + -- Here is where we fix up the Component_Bit_Offset value + -- to account for the reverse bit order. Some examples of + -- what needs to be done for the case of a machine scalar + -- size of 8 are: + + -- First_Bit .. Last_Bit Component_Bit_Offset + -- old new old new + + -- 0 .. 0 7 .. 7 0 7 + -- 0 .. 1 6 .. 7 0 6 + -- 0 .. 2 5 .. 7 0 5 + -- 0 .. 7 0 .. 7 0 4 + + -- 1 .. 1 6 .. 6 1 6 + -- 1 .. 4 3 .. 6 1 3 + -- 4 .. 7 0 .. 3 4 0 + + -- The rule is that the first bit is obtained by subtracting + -- the old ending bit from machine scalar size - 1. + + for C in Start .. Stop loop + declare + Comp : constant Entity_Id := Comps (C); + CC : constant Node_Id := + Component_Clause (Comp); + LB : constant Uint := + Static_Integer (Last_Bit (CC)); + NFB : constant Uint := MSS - Uint_1 - LB; + NLB : constant Uint := NFB + Esize (Comp) - 1; + Pos : constant Uint := + Static_Integer (Position (CC)); + + begin + if Warn_On_Reverse_Bit_Order then + Error_Msg_Uint_1 := MSS; + Error_Msg_N + ("info: reverse bit order in machine " & + "scalar of length^?", First_Bit (CC)); + Error_Msg_Uint_1 := NFB; + Error_Msg_Uint_2 := NLB; + + if Bytes_Big_Endian then + Error_Msg_NE + ("?\info: big-endian range for " + & "component & is ^ .. ^", + First_Bit (CC), Comp); + else + Error_Msg_NE + ("?\info: little-endian range " + & "for component & is ^ .. ^", + First_Bit (CC), Comp); + end if; + end if; + + Set_Component_Bit_Offset (Comp, Pos * SSU + NFB); + Set_Normalized_First_Bit (Comp, NFB mod SSU); + end; + end loop; + end loop; + end Sort_CC; + end; + end if; + end Adjust_Record_For_Reverse_Bit_Order; + + -------------------------------------- + -- Alignment_Check_For_Esize_Change -- + -------------------------------------- + + procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id) is + begin + -- If the alignment is known, and not set by a rep clause, and is + -- inconsistent with the size being set, then reset it to unknown, + -- we assume in this case that the size overrides the inherited + -- alignment, and that the alignment must be recomputed. + + if Known_Alignment (Typ) + and then not Has_Alignment_Clause (Typ) + and then Esize (Typ) mod (Alignment (Typ) * SSU) /= 0 + then + Init_Alignment (Typ); + end if; + end Alignment_Check_For_Esize_Change; + + ----------------------------------- + -- Analyze_Aspect_Specifications -- + ----------------------------------- + + procedure Analyze_Aspect_Specifications + (N : Node_Id; + E : Entity_Id; + L : List_Id) + is + Aspect : Node_Id; + Aitem : Node_Id; + Ent : Node_Id; + + Ins_Node : Node_Id := N; + -- Insert pragmas (except Pre/Post/Invariant/Predicate) after this node + + -- The general processing involves building an attribute definition + -- clause or a pragma node that corresponds to the access type. Then + -- one of two things happens: + + -- If we are required to delay the evaluation of this aspect to the + -- freeze point, we preanalyze the relevant argument, and then attach + -- the corresponding pragma/attribute definition clause to the aspect + -- specification node, which is then placed in the Rep Item chain. + -- In this case we mark the entity with the Has_Delayed_Aspects flag, + -- and we evaluate the rep item at the freeze point. + + -- If no delay is required, we just insert the pragma or attribute + -- after the declaration, and it will get processed by the normal + -- circuit. The From_Aspect_Specification flag is set on the pragma + -- or attribute definition node in either case to activate special + -- processing (e.g. not traversing the list of homonyms for inline). + + Delay_Required : Boolean; + -- Set True if delay is required + + begin + -- Return if no aspects + + if L = No_List then + return; + end if; + + -- Return if already analyzed (avoids duplicate calls in some cases + -- where type declarations get rewritten and processed twice). + + if Analyzed (N) then + return; + end if; + + -- Loop through aspects + + Aspect := First (L); + while Present (Aspect) loop + declare + Loc : constant Source_Ptr := Sloc (Aspect); + Id : constant Node_Id := Identifier (Aspect); + Expr : constant Node_Id := Expression (Aspect); + Nam : constant Name_Id := Chars (Id); + A_Id : constant Aspect_Id := Get_Aspect_Id (Nam); + Anod : Node_Id; + T : Entity_Id; + + Eloc : Source_Ptr := Sloc (Expr); + -- Source location of expression, modified when we split PPC's + + begin + Set_Entity (Aspect, E); + Ent := New_Occurrence_Of (E, Sloc (Id)); + + -- Check for duplicate aspect. Note that the Comes_From_Source + -- test allows duplicate Pre/Post's that we generate internally + -- to escape being flagged here. + + Anod := First (L); + while Anod /= Aspect loop + if Nam = Chars (Identifier (Anod)) + and then Comes_From_Source (Aspect) + then + Error_Msg_Name_1 := Nam; + Error_Msg_Sloc := Sloc (Anod); + + -- Case of same aspect specified twice + + if Class_Present (Anod) = Class_Present (Aspect) then + if not Class_Present (Anod) then + Error_Msg_NE + ("aspect% for & previously given#", + Id, E); + else + Error_Msg_NE + ("aspect `%''Class` for & previously given#", + Id, E); + end if; + + -- Case of Pre and Pre'Class both specified + + elsif Nam = Name_Pre then + if Class_Present (Aspect) then + Error_Msg_NE + ("aspect `Pre''Class` for & is not allowed here", + Id, E); + Error_Msg_NE + ("\since aspect `Pre` previously given#", + Id, E); + + else + Error_Msg_NE + ("aspect `Pre` for & is not allowed here", + Id, E); + Error_Msg_NE + ("\since aspect `Pre''Class` previously given#", + Id, E); + end if; + end if; + + goto Continue; + end if; + + Next (Anod); + end loop; + + -- Processing based on specific aspect + + case A_Id is + + -- No_Aspect should be impossible + + when No_Aspect => + raise Program_Error; + + -- Aspects taking an optional boolean argument. For all of + -- these we just create a matching pragma and insert it, + -- setting flag Cancel_Aspect if the expression is False. + + when Aspect_Ada_2005 | + Aspect_Ada_2012 | + Aspect_Atomic | + Aspect_Atomic_Components | + Aspect_Discard_Names | + Aspect_Favor_Top_Level | + Aspect_Inline | + Aspect_Inline_Always | + Aspect_No_Return | + Aspect_Pack | + Aspect_Persistent_BSS | + Aspect_Preelaborable_Initialization | + Aspect_Pure_Function | + Aspect_Shared | + Aspect_Suppress_Debug_Info | + Aspect_Unchecked_Union | + Aspect_Universal_Aliasing | + Aspect_Unmodified | + Aspect_Unreferenced | + Aspect_Unreferenced_Objects | + Aspect_Volatile | + Aspect_Volatile_Components => + + -- Build corresponding pragma node + + Aitem := + Make_Pragma (Loc, + Pragma_Argument_Associations => New_List (Ent), + Pragma_Identifier => + Make_Identifier (Sloc (Id), Chars (Id))); + + -- Deal with missing expression case, delay never needed + + if No (Expr) then + Delay_Required := False; + + -- Expression is present + + else + Preanalyze_Spec_Expression (Expr, Standard_Boolean); + + -- If preanalysis gives a static expression, we don't + -- need to delay (this will happen often in practice). + + if Is_OK_Static_Expression (Expr) then + Delay_Required := False; + + if Is_False (Expr_Value (Expr)) then + Set_Aspect_Cancel (Aitem); + end if; + + -- If we don't get a static expression, then delay, the + -- expression may turn out static by freeze time. + + else + Delay_Required := True; + end if; + end if; + + -- Aspects corresponding to attribute definition clauses + + when Aspect_Address | + Aspect_Alignment | + Aspect_Bit_Order | + Aspect_Component_Size | + Aspect_External_Tag | + Aspect_Machine_Radix | + Aspect_Object_Size | + Aspect_Size | + Aspect_Storage_Pool | + Aspect_Storage_Size | + Aspect_Stream_Size | + Aspect_Value_Size => + + -- Preanalyze the expression with the appropriate type + + case A_Id is + when Aspect_Address => + T := RTE (RE_Address); + when Aspect_Bit_Order => + T := RTE (RE_Bit_Order); + when Aspect_External_Tag => + T := Standard_String; + when Aspect_Storage_Pool => + T := Class_Wide_Type (RTE (RE_Root_Storage_Pool)); + when others => + T := Any_Integer; + end case; + + Preanalyze_Spec_Expression (Expr, T); + + -- Construct the attribute definition clause + + Aitem := + Make_Attribute_Definition_Clause (Loc, + Name => Ent, + Chars => Chars (Id), + Expression => Relocate_Node (Expr)); + + -- We do not need a delay if we have a static expression + + if Is_OK_Static_Expression (Expression (Aitem)) then + Delay_Required := False; + + -- Here a delay is required + + else + Delay_Required := True; + end if; + + -- Aspects corresponding to pragmas with two arguments, where + -- the first argument is a local name referring to the entity, + -- and the second argument is the aspect definition expression. + + when Aspect_Suppress | + Aspect_Unsuppress => + + -- Construct the pragma + + Aitem := + Make_Pragma (Loc, + Pragma_Argument_Associations => New_List ( + New_Occurrence_Of (E, Eloc), + Relocate_Node (Expr)), + Pragma_Identifier => + Make_Identifier (Sloc (Id), Chars (Id))); + + -- We don't have to play the delay game here, since the only + -- values are check names which don't get analyzed anyway. + + Delay_Required := False; + + -- Aspects corresponding to stream routines + + when Aspect_Input | + Aspect_Output | + Aspect_Read | + Aspect_Write => + + -- Construct the attribute definition clause + + Aitem := + Make_Attribute_Definition_Clause (Loc, + Name => Ent, + Chars => Chars (Id), + Expression => Relocate_Node (Expr)); + + -- These are always delayed (typically the subprogram that + -- is referenced cannot have been declared yet, since it has + -- a reference to the type for which this aspect is defined. + + Delay_Required := True; + + -- Aspects corresponding to pragmas with two arguments, where + -- the second argument is a local name referring to the entity, + -- and the first argument is the aspect definition expression. + + when Aspect_Warnings => + + -- Construct the pragma + + Aitem := + Make_Pragma (Loc, + Pragma_Argument_Associations => New_List ( + Relocate_Node (Expr), + New_Occurrence_Of (E, Eloc)), + Pragma_Identifier => + Make_Identifier (Sloc (Id), Chars (Id)), + Class_Present => Class_Present (Aspect)); + + -- We don't have to play the delay game here, since the only + -- values are check names which don't get analyzed anyway. + + Delay_Required := False; + + -- Aspects Pre/Post generate Precondition/Postcondition pragmas + -- with a first argument that is the expression, and a second + -- argument that is an informative message if the test fails. + -- This is inserted right after the declaration, to get the + -- required pragma placement. The processing for the pragmas + -- takes care of the required delay. + + when Aspect_Pre | Aspect_Post => declare + Pname : Name_Id; + + begin + if A_Id = Aspect_Pre then + Pname := Name_Precondition; + else + Pname := Name_Postcondition; + end if; + + -- If the expressions is of the form A and then B, then + -- we generate separate Pre/Post aspects for the separate + -- clauses. Since we allow multiple pragmas, there is no + -- problem in allowing multiple Pre/Post aspects internally. + + -- We do not do this for Pre'Class, since we have to put + -- these conditions together in a complex OR expression + + if Pname = Name_Postcondition + or else not Class_Present (Aspect) + then + while Nkind (Expr) = N_And_Then loop + Insert_After (Aspect, + Make_Aspect_Specification (Sloc (Right_Opnd (Expr)), + Identifier => Identifier (Aspect), + Expression => Relocate_Node (Right_Opnd (Expr)), + Class_Present => Class_Present (Aspect), + Split_PPC => True)); + Rewrite (Expr, Relocate_Node (Left_Opnd (Expr))); + Eloc := Sloc (Expr); + end loop; + end if; + + -- Build the precondition/postcondition pragma + + Aitem := + Make_Pragma (Loc, + Pragma_Identifier => + Make_Identifier (Sloc (Id), Pname), + Class_Present => Class_Present (Aspect), + Split_PPC => Split_PPC (Aspect), + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Eloc, + Chars => Name_Check, + Expression => Relocate_Node (Expr)))); + + -- Add message unless exception messages are suppressed + + if not Opt.Exception_Locations_Suppressed then + Append_To (Pragma_Argument_Associations (Aitem), + Make_Pragma_Argument_Association (Eloc, + Chars => Name_Message, + Expression => + Make_String_Literal (Eloc, + Strval => "failed " + & Get_Name_String (Pname) + & " from " + & Build_Location_String (Eloc)))); + end if; + + Set_From_Aspect_Specification (Aitem, True); + + -- For Pre/Post cases, insert immediately after the entity + -- declaration, since that is the required pragma placement. + -- Note that for these aspects, we do not have to worry + -- about delay issues, since the pragmas themselves deal + -- with delay of visibility for the expression analysis. + + -- If the entity is a library-level subprogram, the pre/ + -- postconditions must be treated as late pragmas. + + if Nkind (Parent (N)) = N_Compilation_Unit then + Add_Global_Declaration (Aitem); + else + Insert_After (N, Aitem); + end if; + + goto Continue; + end; + + -- Invariant aspects generate a corresponding pragma with a + -- first argument that is the entity, a second argument that is + -- the expression and a third argument that is an appropriate + -- message. This is inserted right after the declaration, to + -- get the required pragma placement. The pragma processing + -- takes care of the required delay. + + when Aspect_Invariant => + + -- Construct the pragma + + Aitem := + Make_Pragma (Loc, + Pragma_Argument_Associations => + New_List (Ent, Relocate_Node (Expr)), + Class_Present => Class_Present (Aspect), + Pragma_Identifier => + Make_Identifier (Sloc (Id), Name_Invariant)); + + -- Add message unless exception messages are suppressed + + if not Opt.Exception_Locations_Suppressed then + Append_To (Pragma_Argument_Associations (Aitem), + Make_Pragma_Argument_Association (Eloc, + Chars => Name_Message, + Expression => + Make_String_Literal (Eloc, + Strval => "failed invariant from " + & Build_Location_String (Eloc)))); + end if; + + Set_From_Aspect_Specification (Aitem, True); + + -- For Invariant case, insert immediately after the entity + -- declaration. We do not have to worry about delay issues + -- since the pragma processing takes care of this. + + Insert_After (N, Aitem); + goto Continue; + + -- Predicate aspects generate a corresponding pragma with a + -- first argument that is the entity, and the second argument + -- is the expression. This is inserted immediately after the + -- declaration, to get the required pragma placement. The + -- pragma processing takes care of the required delay. + + when Aspect_Predicate => + + -- Construct the pragma + + Aitem := + Make_Pragma (Loc, + Pragma_Argument_Associations => + New_List (Ent, Relocate_Node (Expr)), + Class_Present => Class_Present (Aspect), + Pragma_Identifier => + Make_Identifier (Sloc (Id), Name_Predicate)); + + Set_From_Aspect_Specification (Aitem, True); + + -- Make sure we have a freeze node (it might otherwise be + -- missing in cases like subtype X is Y, and we would not + -- have a place to build the predicate function). + + Ensure_Freeze_Node (E); + + -- For Predicate case, insert immediately after the entity + -- declaration. We do not have to worry about delay issues + -- since the pragma processing takes care of this. + + Insert_After (N, Aitem); + goto Continue; + end case; + + Set_From_Aspect_Specification (Aitem, True); + + -- If a delay is required, we delay the freeze (not much point in + -- delaying the aspect if we don't delay the freeze!). The pragma + -- or clause is then attached to the aspect specification which + -- is placed in the rep item list. + + if Delay_Required then + Ensure_Freeze_Node (E); + Set_Is_Delayed_Aspect (Aitem); + Set_Has_Delayed_Aspects (E); + Set_Aspect_Rep_Item (Aspect, Aitem); + Record_Rep_Item (E, Aspect); + + -- If no delay required, insert the pragma/clause in the tree + + else + -- For Pre/Post cases, insert immediately after the entity + -- declaration, since that is the required pragma placement. + + if A_Id = Aspect_Pre or else A_Id = Aspect_Post then + Insert_After (N, Aitem); + + -- For all other cases, insert in sequence + + else + Insert_After (Ins_Node, Aitem); + Ins_Node := Aitem; + end if; + end if; + end; + + <> + Next (Aspect); + end loop; + end Analyze_Aspect_Specifications; + + ----------------------- + -- Analyze_At_Clause -- + ----------------------- + + -- An at clause is replaced by the corresponding Address attribute + -- definition clause that is the preferred approach in Ada 95. + + procedure Analyze_At_Clause (N : Node_Id) is + CS : constant Boolean := Comes_From_Source (N); + + begin + -- This is an obsolescent feature + + Check_Restriction (No_Obsolescent_Features, N); + + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("at clause is an obsolescent feature (RM J.7(2))?", N); + Error_Msg_N + ("\use address attribute definition clause instead?", N); + end if; + + -- Rewrite as address clause + + Rewrite (N, + Make_Attribute_Definition_Clause (Sloc (N), + Name => Identifier (N), + Chars => Name_Address, + Expression => Expression (N))); + + -- We preserve Comes_From_Source, since logically the clause still + -- comes from the source program even though it is changed in form. + + Set_Comes_From_Source (N, CS); + + -- Analyze rewritten clause + + Analyze_Attribute_Definition_Clause (N); + end Analyze_At_Clause; + + ----------------------------------------- + -- Analyze_Attribute_Definition_Clause -- + ----------------------------------------- + + procedure Analyze_Attribute_Definition_Clause (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Nam : constant Node_Id := Name (N); + Attr : constant Name_Id := Chars (N); + Expr : constant Node_Id := Expression (N); + Id : constant Attribute_Id := Get_Attribute_Id (Attr); + Ent : Entity_Id; + U_Ent : Entity_Id; + + FOnly : Boolean := False; + -- Reset to True for subtype specific attribute (Alignment, Size) + -- and for stream attributes, i.e. those cases where in the call + -- to Rep_Item_Too_Late, FOnly is set True so that only the freezing + -- rules are checked. Note that the case of stream attributes is not + -- clear from the RM, but see AI95-00137. Also, the RM seems to + -- disallow Storage_Size for derived task types, but that is also + -- clearly unintentional. + + procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type); + -- Common processing for 'Read, 'Write, 'Input and 'Output attribute + -- definition clauses. + + function Duplicate_Clause return Boolean; + -- This routine checks if the aspect for U_Ent being given by attribute + -- definition clause N is for an aspect that has already been specified, + -- and if so gives an error message. If there is a duplicate, True is + -- returned, otherwise if there is no error, False is returned. + + ----------------------------------- + -- Analyze_Stream_TSS_Definition -- + ----------------------------------- + + procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type) is + Subp : Entity_Id := Empty; + I : Interp_Index; + It : Interp; + Pnam : Entity_Id; + + Is_Read : constant Boolean := (TSS_Nam = TSS_Stream_Read); + + function Has_Good_Profile (Subp : Entity_Id) return Boolean; + -- Return true if the entity is a subprogram with an appropriate + -- profile for the attribute being defined. + + ---------------------- + -- Has_Good_Profile -- + ---------------------- + + function Has_Good_Profile (Subp : Entity_Id) return Boolean is + F : Entity_Id; + Is_Function : constant Boolean := (TSS_Nam = TSS_Stream_Input); + Expected_Ekind : constant array (Boolean) of Entity_Kind := + (False => E_Procedure, True => E_Function); + Typ : Entity_Id; + + begin + if Ekind (Subp) /= Expected_Ekind (Is_Function) then + return False; + end if; + + F := First_Formal (Subp); + + if No (F) + or else Ekind (Etype (F)) /= E_Anonymous_Access_Type + or else Designated_Type (Etype (F)) /= + Class_Wide_Type (RTE (RE_Root_Stream_Type)) + then + return False; + end if; + + if not Is_Function then + Next_Formal (F); + + declare + Expected_Mode : constant array (Boolean) of Entity_Kind := + (False => E_In_Parameter, + True => E_Out_Parameter); + begin + if Parameter_Mode (F) /= Expected_Mode (Is_Read) then + return False; + end if; + end; + + Typ := Etype (F); + + else + Typ := Etype (Subp); + end if; + + return Base_Type (Typ) = Base_Type (Ent) + and then No (Next_Formal (F)); + end Has_Good_Profile; + + -- Start of processing for Analyze_Stream_TSS_Definition + + begin + FOnly := True; + + if not Is_Type (U_Ent) then + Error_Msg_N ("local name must be a subtype", Nam); + return; + end if; + + Pnam := TSS (Base_Type (U_Ent), TSS_Nam); + + -- If Pnam is present, it can be either inherited from an ancestor + -- type (in which case it is legal to redefine it for this type), or + -- be a previous definition of the attribute for the same type (in + -- which case it is illegal). + + -- In the first case, it will have been analyzed already, and we + -- can check that its profile does not match the expected profile + -- for a stream attribute of U_Ent. In the second case, either Pnam + -- has been analyzed (and has the expected profile), or it has not + -- been analyzed yet (case of a type that has not been frozen yet + -- and for which the stream attribute has been set using Set_TSS). + + if Present (Pnam) + and then (No (First_Entity (Pnam)) or else Has_Good_Profile (Pnam)) + then + Error_Msg_Sloc := Sloc (Pnam); + Error_Msg_Name_1 := Attr; + Error_Msg_N ("% attribute already defined #", Nam); + return; + end if; + + Analyze (Expr); + + if Is_Entity_Name (Expr) then + if not Is_Overloaded (Expr) then + if Has_Good_Profile (Entity (Expr)) then + Subp := Entity (Expr); + end if; + + else + Get_First_Interp (Expr, I, It); + while Present (It.Nam) loop + if Has_Good_Profile (It.Nam) then + Subp := It.Nam; + exit; + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + end if; + + if Present (Subp) then + if Is_Abstract_Subprogram (Subp) then + Error_Msg_N ("stream subprogram must not be abstract", Expr); + return; + end if; + + Set_Entity (Expr, Subp); + Set_Etype (Expr, Etype (Subp)); + + New_Stream_Subprogram (N, U_Ent, Subp, TSS_Nam); + + else + Error_Msg_Name_1 := Attr; + Error_Msg_N ("incorrect expression for% attribute", Expr); + end if; + end Analyze_Stream_TSS_Definition; + + ---------------------- + -- Duplicate_Clause -- + ---------------------- + + function Duplicate_Clause return Boolean is + A : Node_Id; + + begin + -- Nothing to do if this attribute definition clause comes from + -- an aspect specification, since we could not be duplicating an + -- explicit clause, and we dealt with the case of duplicated aspects + -- in Analyze_Aspect_Specifications. + + if From_Aspect_Specification (N) then + return False; + end if; + + -- Otherwise current clause may duplicate previous clause or a + -- previously given aspect specification for the same aspect. + + A := Get_Rep_Item_For_Entity (U_Ent, Chars (N)); + + if Present (A) then + if Entity (A) = U_Ent then + Error_Msg_Name_1 := Chars (N); + Error_Msg_Sloc := Sloc (A); + Error_Msg_NE ("aspect% for & previously given#", N, U_Ent); + return True; + end if; + end if; + + return False; + end Duplicate_Clause; + + -- Start of processing for Analyze_Attribute_Definition_Clause + + begin + -- Process Ignore_Rep_Clauses option + + if Ignore_Rep_Clauses then + case Id is + + -- The following should be ignored. They do not affect legality + -- and may be target dependent. The basic idea of -gnatI is to + -- ignore any rep clauses that may be target dependent but do not + -- affect legality (except possibly to be rejected because they + -- are incompatible with the compilation target). + + when Attribute_Alignment | + Attribute_Bit_Order | + Attribute_Component_Size | + Attribute_Machine_Radix | + Attribute_Object_Size | + Attribute_Size | + Attribute_Small | + Attribute_Stream_Size | + Attribute_Value_Size => + + Rewrite (N, Make_Null_Statement (Sloc (N))); + return; + + -- The following should not be ignored, because in the first place + -- they are reasonably portable, and should not cause problems in + -- compiling code from another target, and also they do affect + -- legality, e.g. failing to provide a stream attribute for a + -- type may make a program illegal. + + when Attribute_External_Tag | + Attribute_Input | + Attribute_Output | + Attribute_Read | + Attribute_Storage_Pool | + Attribute_Storage_Size | + Attribute_Write => + null; + + -- Other cases are errors ("attribute& cannot be set with + -- definition clause"), which will be caught below. + + when others => + null; + end case; + end if; + + Analyze (Nam); + Ent := Entity (Nam); + + if Rep_Item_Too_Early (Ent, N) then + return; + end if; + + -- Rep clause applies to full view of incomplete type or private type if + -- we have one (if not, this is a premature use of the type). However, + -- certain semantic checks need to be done on the specified entity (i.e. + -- the private view), so we save it in Ent. + + if Is_Private_Type (Ent) + and then Is_Derived_Type (Ent) + and then not Is_Tagged_Type (Ent) + and then No (Full_View (Ent)) + then + -- If this is a private type whose completion is a derivation from + -- another private type, there is no full view, and the attribute + -- belongs to the type itself, not its underlying parent. + + U_Ent := Ent; + + elsif Ekind (Ent) = E_Incomplete_Type then + + -- The attribute applies to the full view, set the entity of the + -- attribute definition accordingly. + + Ent := Underlying_Type (Ent); + U_Ent := Ent; + Set_Entity (Nam, Ent); + + else + U_Ent := Underlying_Type (Ent); + end if; + + -- Complete other routine error checks + + if Etype (Nam) = Any_Type then + return; + + elsif Scope (Ent) /= Current_Scope then + Error_Msg_N ("entity must be declared in this scope", Nam); + return; + + elsif No (U_Ent) then + U_Ent := Ent; + + elsif Is_Type (U_Ent) + and then not Is_First_Subtype (U_Ent) + and then Id /= Attribute_Object_Size + and then Id /= Attribute_Value_Size + and then not From_At_Mod (N) + then + Error_Msg_N ("cannot specify attribute for subtype", Nam); + return; + end if; + + Set_Entity (N, U_Ent); + + -- Switch on particular attribute + + case Id is + + ------------- + -- Address -- + ------------- + + -- Address attribute definition clause + + when Attribute_Address => Address : begin + + -- A little error check, catch for X'Address use X'Address; + + if Nkind (Nam) = N_Identifier + and then Nkind (Expr) = N_Attribute_Reference + and then Attribute_Name (Expr) = Name_Address + and then Nkind (Prefix (Expr)) = N_Identifier + and then Chars (Nam) = Chars (Prefix (Expr)) + then + Error_Msg_NE + ("address for & is self-referencing", Prefix (Expr), Ent); + return; + end if; + + -- Not that special case, carry on with analysis of expression + + Analyze_And_Resolve (Expr, RTE (RE_Address)); + + -- Even when ignoring rep clauses we need to indicate that the + -- entity has an address clause and thus it is legal to declare + -- it imported. + + if Ignore_Rep_Clauses then + if Ekind_In (U_Ent, E_Variable, E_Constant) then + Record_Rep_Item (U_Ent, N); + end if; + + return; + end if; + + if Duplicate_Clause then + null; + + -- Case of address clause for subprogram + + elsif Is_Subprogram (U_Ent) then + if Has_Homonym (U_Ent) then + Error_Msg_N + ("address clause cannot be given " & + "for overloaded subprogram", + Nam); + return; + end if; + + -- For subprograms, all address clauses are permitted, and we + -- mark the subprogram as having a deferred freeze so that Gigi + -- will not elaborate it too soon. + + -- Above needs more comments, what is too soon about??? + + Set_Has_Delayed_Freeze (U_Ent); + + -- Case of address clause for entry + + elsif Ekind (U_Ent) = E_Entry then + if Nkind (Parent (N)) = N_Task_Body then + Error_Msg_N + ("entry address must be specified in task spec", Nam); + return; + end if; + + -- For entries, we require a constant address + + Check_Constant_Address_Clause (Expr, U_Ent); + + -- Special checks for task types + + if Is_Task_Type (Scope (U_Ent)) + and then Comes_From_Source (Scope (U_Ent)) + then + Error_Msg_N + ("?entry address declared for entry in task type", N); + Error_Msg_N + ("\?only one task can be declared of this type", N); + end if; + + -- Entry address clauses are obsolescent + + Check_Restriction (No_Obsolescent_Features, N); + + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("attaching interrupt to task entry is an " & + "obsolescent feature (RM J.7.1)?", N); + Error_Msg_N + ("\use interrupt procedure instead?", N); + end if; + + -- Case of an address clause for a controlled object which we + -- consider to be erroneous. + + elsif Is_Controlled (Etype (U_Ent)) + or else Has_Controlled_Component (Etype (U_Ent)) + then + Error_Msg_NE + ("?controlled object& must not be overlaid", Nam, U_Ent); + Error_Msg_N + ("\?Program_Error will be raised at run time", Nam); + Insert_Action (Declaration_Node (U_Ent), + Make_Raise_Program_Error (Loc, + Reason => PE_Overlaid_Controlled_Object)); + return; + + -- Case of address clause for a (non-controlled) object + + elsif + Ekind (U_Ent) = E_Variable + or else + Ekind (U_Ent) = E_Constant + then + declare + Expr : constant Node_Id := Expression (N); + O_Ent : Entity_Id; + Off : Boolean; + + begin + -- Exported variables cannot have an address clause, because + -- this cancels the effect of the pragma Export. + + if Is_Exported (U_Ent) then + Error_Msg_N + ("cannot export object with address clause", Nam); + return; + end if; + + Find_Overlaid_Entity (N, O_Ent, Off); + + -- Overlaying controlled objects is erroneous + + if Present (O_Ent) + and then (Has_Controlled_Component (Etype (O_Ent)) + or else Is_Controlled (Etype (O_Ent))) + then + Error_Msg_N + ("?cannot overlay with controlled object", Expr); + Error_Msg_N + ("\?Program_Error will be raised at run time", Expr); + Insert_Action (Declaration_Node (U_Ent), + Make_Raise_Program_Error (Loc, + Reason => PE_Overlaid_Controlled_Object)); + return; + + elsif Present (O_Ent) + and then Ekind (U_Ent) = E_Constant + and then not Is_Constant_Object (O_Ent) + then + Error_Msg_N ("constant overlays a variable?", Expr); + + elsif Present (Renamed_Object (U_Ent)) then + Error_Msg_N + ("address clause not allowed" + & " for a renaming declaration (RM 13.1(6))", Nam); + return; + + -- Imported variables can have an address clause, but then + -- the import is pretty meaningless except to suppress + -- initializations, so we do not need such variables to + -- be statically allocated (and in fact it causes trouble + -- if the address clause is a local value). + + elsif Is_Imported (U_Ent) then + Set_Is_Statically_Allocated (U_Ent, False); + end if; + + -- We mark a possible modification of a variable with an + -- address clause, since it is likely aliasing is occurring. + + Note_Possible_Modification (Nam, Sure => False); + + -- Here we are checking for explicit overlap of one variable + -- by another, and if we find this then mark the overlapped + -- variable as also being volatile to prevent unwanted + -- optimizations. This is a significant pessimization so + -- avoid it when there is an offset, i.e. when the object + -- is composite; they cannot be optimized easily anyway. + + if Present (O_Ent) + and then Is_Object (O_Ent) + and then not Off + then + Set_Treat_As_Volatile (O_Ent); + end if; + + -- Legality checks on the address clause for initialized + -- objects is deferred until the freeze point, because + -- a subsequent pragma might indicate that the object is + -- imported and thus not initialized. + + Set_Has_Delayed_Freeze (U_Ent); + + -- If an initialization call has been generated for this + -- object, it needs to be deferred to after the freeze node + -- we have just now added, otherwise GIGI will see a + -- reference to the variable (as actual to the IP call) + -- before its definition. + + declare + Init_Call : constant Node_Id := Find_Init_Call (U_Ent, N); + begin + if Present (Init_Call) then + Remove (Init_Call); + Append_Freeze_Action (U_Ent, Init_Call); + end if; + end; + + if Is_Exported (U_Ent) then + Error_Msg_N + ("& cannot be exported if an address clause is given", + Nam); + Error_Msg_N + ("\define and export a variable " & + "that holds its address instead", + Nam); + end if; + + -- Entity has delayed freeze, so we will generate an + -- alignment check at the freeze point unless suppressed. + + if not Range_Checks_Suppressed (U_Ent) + and then not Alignment_Checks_Suppressed (U_Ent) + then + Set_Check_Address_Alignment (N); + end if; + + -- Kill the size check code, since we are not allocating + -- the variable, it is somewhere else. + + Kill_Size_Check_Code (U_Ent); + + -- If the address clause is of the form: + + -- for Y'Address use X'Address + + -- or + + -- Const : constant Address := X'Address; + -- ... + -- for Y'Address use Const; + + -- then we make an entry in the table for checking the size + -- and alignment of the overlaying variable. We defer this + -- check till after code generation to take full advantage + -- of the annotation done by the back end. This entry is + -- only made if the address clause comes from source. + -- If the entity has a generic type, the check will be + -- performed in the instance if the actual type justifies + -- it, and we do not insert the clause in the table to + -- prevent spurious warnings. + + if Address_Clause_Overlay_Warnings + and then Comes_From_Source (N) + and then Present (O_Ent) + and then Is_Object (O_Ent) + then + if not Is_Generic_Type (Etype (U_Ent)) then + Address_Clause_Checks.Append ((N, U_Ent, O_Ent, Off)); + end if; + + -- If variable overlays a constant view, and we are + -- warning on overlays, then mark the variable as + -- overlaying a constant (we will give warnings later + -- if this variable is assigned). + + if Is_Constant_Object (O_Ent) + and then Ekind (U_Ent) = E_Variable + then + Set_Overlays_Constant (U_Ent); + end if; + end if; + end; + + -- Not a valid entity for an address clause + + else + Error_Msg_N ("address cannot be given for &", Nam); + end if; + end Address; + + --------------- + -- Alignment -- + --------------- + + -- Alignment attribute definition clause + + when Attribute_Alignment => Alignment : declare + Align : constant Uint := Get_Alignment_Value (Expr); + + begin + FOnly := True; + + if not Is_Type (U_Ent) + and then Ekind (U_Ent) /= E_Variable + and then Ekind (U_Ent) /= E_Constant + then + Error_Msg_N ("alignment cannot be given for &", Nam); + + elsif Duplicate_Clause then + null; + + elsif Align /= No_Uint then + Set_Has_Alignment_Clause (U_Ent); + Set_Alignment (U_Ent, Align); + + -- For an array type, U_Ent is the first subtype. In that case, + -- also set the alignment of the anonymous base type so that + -- other subtypes (such as the itypes for aggregates of the + -- type) also receive the expected alignment. + + if Is_Array_Type (U_Ent) then + Set_Alignment (Base_Type (U_Ent), Align); + end if; + end if; + end Alignment; + + --------------- + -- Bit_Order -- + --------------- + + -- Bit_Order attribute definition clause + + when Attribute_Bit_Order => Bit_Order : declare + begin + if not Is_Record_Type (U_Ent) then + Error_Msg_N + ("Bit_Order can only be defined for record type", Nam); + + elsif Duplicate_Clause then + null; + + else + Analyze_And_Resolve (Expr, RTE (RE_Bit_Order)); + + if Etype (Expr) = Any_Type then + return; + + elsif not Is_Static_Expression (Expr) then + Flag_Non_Static_Expr + ("Bit_Order requires static expression!", Expr); + + else + if (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then + Set_Reverse_Bit_Order (U_Ent, True); + end if; + end if; + end if; + end Bit_Order; + + -------------------- + -- Component_Size -- + -------------------- + + -- Component_Size attribute definition clause + + when Attribute_Component_Size => Component_Size_Case : declare + Csize : constant Uint := Static_Integer (Expr); + Ctyp : Entity_Id; + Btype : Entity_Id; + Biased : Boolean; + New_Ctyp : Entity_Id; + Decl : Node_Id; + + begin + if not Is_Array_Type (U_Ent) then + Error_Msg_N ("component size requires array type", Nam); + return; + end if; + + Btype := Base_Type (U_Ent); + Ctyp := Component_Type (Btype); + + if Duplicate_Clause then + null; + + elsif Rep_Item_Too_Early (Btype, N) then + null; + + elsif Csize /= No_Uint then + Check_Size (Expr, Ctyp, Csize, Biased); + + -- For the biased case, build a declaration for a subtype that + -- will be used to represent the biased subtype that reflects + -- the biased representation of components. We need the subtype + -- to get proper conversions on referencing elements of the + -- array. Note: component size clauses are ignored in VM mode. + + if VM_Target = No_VM then + if Biased then + New_Ctyp := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Chars (U_Ent), 'C', 0, 'T')); + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => New_Ctyp, + Subtype_Indication => + New_Occurrence_Of (Component_Type (Btype), Loc)); + + Set_Parent (Decl, N); + Analyze (Decl, Suppress => All_Checks); + + Set_Has_Delayed_Freeze (New_Ctyp, False); + Set_Esize (New_Ctyp, Csize); + Set_RM_Size (New_Ctyp, Csize); + Init_Alignment (New_Ctyp); + Set_Is_Itype (New_Ctyp, True); + Set_Associated_Node_For_Itype (New_Ctyp, U_Ent); + + Set_Component_Type (Btype, New_Ctyp); + Set_Biased (New_Ctyp, N, "component size clause"); + end if; + + Set_Component_Size (Btype, Csize); + + -- For VM case, we ignore component size clauses + + else + -- Give a warning unless we are in GNAT mode, in which case + -- the warning is suppressed since it is not useful. + + if not GNAT_Mode then + Error_Msg_N + ("?component size ignored in this configuration", N); + end if; + end if; + + -- Deal with warning on overridden size + + if Warn_On_Overridden_Size + and then Has_Size_Clause (Ctyp) + and then RM_Size (Ctyp) /= Csize + then + Error_Msg_NE + ("?component size overrides size clause for&", + N, Ctyp); + end if; + + Set_Has_Component_Size_Clause (Btype, True); + Set_Has_Non_Standard_Rep (Btype, True); + end if; + end Component_Size_Case; + + ------------------ + -- External_Tag -- + ------------------ + + when Attribute_External_Tag => External_Tag : + begin + if not Is_Tagged_Type (U_Ent) then + Error_Msg_N ("should be a tagged type", Nam); + end if; + + if Duplicate_Clause then + null; + + else + Analyze_And_Resolve (Expr, Standard_String); + + if not Is_Static_Expression (Expr) then + Flag_Non_Static_Expr + ("static string required for tag name!", Nam); + end if; + + if VM_Target = No_VM then + Set_Has_External_Tag_Rep_Clause (U_Ent); + else + Error_Msg_Name_1 := Attr; + Error_Msg_N + ("% attribute unsupported in this configuration", Nam); + end if; + + if not Is_Library_Level_Entity (U_Ent) then + Error_Msg_NE + ("?non-unique external tag supplied for &", N, U_Ent); + Error_Msg_N + ("?\same external tag applies to all subprogram calls", N); + Error_Msg_N + ("?\corresponding internal tag cannot be obtained", N); + end if; + end if; + end External_Tag; + + ----------- + -- Input -- + ----------- + + when Attribute_Input => + Analyze_Stream_TSS_Definition (TSS_Stream_Input); + Set_Has_Specified_Stream_Input (Ent); + + ------------------- + -- Machine_Radix -- + ------------------- + + -- Machine radix attribute definition clause + + when Attribute_Machine_Radix => Machine_Radix : declare + Radix : constant Uint := Static_Integer (Expr); + + begin + if not Is_Decimal_Fixed_Point_Type (U_Ent) then + Error_Msg_N ("decimal fixed-point type expected for &", Nam); + + elsif Duplicate_Clause then + null; + + elsif Radix /= No_Uint then + Set_Has_Machine_Radix_Clause (U_Ent); + Set_Has_Non_Standard_Rep (Base_Type (U_Ent)); + + if Radix = 2 then + null; + elsif Radix = 10 then + Set_Machine_Radix_10 (U_Ent); + else + Error_Msg_N ("machine radix value must be 2 or 10", Expr); + end if; + end if; + end Machine_Radix; + + ----------------- + -- Object_Size -- + ----------------- + + -- Object_Size attribute definition clause + + when Attribute_Object_Size => Object_Size : declare + Size : constant Uint := Static_Integer (Expr); + + Biased : Boolean; + pragma Warnings (Off, Biased); + + begin + if not Is_Type (U_Ent) then + Error_Msg_N ("Object_Size cannot be given for &", Nam); + + elsif Duplicate_Clause then + null; + + else + Check_Size (Expr, U_Ent, Size, Biased); + + if Size /= 8 + and then + Size /= 16 + and then + Size /= 32 + and then + UI_Mod (Size, 64) /= 0 + then + Error_Msg_N + ("Object_Size must be 8, 16, 32, or multiple of 64", + Expr); + end if; + + Set_Esize (U_Ent, Size); + Set_Has_Object_Size_Clause (U_Ent); + Alignment_Check_For_Esize_Change (U_Ent); + end if; + end Object_Size; + + ------------ + -- Output -- + ------------ + + when Attribute_Output => + Analyze_Stream_TSS_Definition (TSS_Stream_Output); + Set_Has_Specified_Stream_Output (Ent); + + ---------- + -- Read -- + ---------- + + when Attribute_Read => + Analyze_Stream_TSS_Definition (TSS_Stream_Read); + Set_Has_Specified_Stream_Read (Ent); + + ---------- + -- Size -- + ---------- + + -- Size attribute definition clause + + when Attribute_Size => Size : declare + Size : constant Uint := Static_Integer (Expr); + Etyp : Entity_Id; + Biased : Boolean; + + begin + FOnly := True; + + if Duplicate_Clause then + null; + + elsif not Is_Type (U_Ent) + and then Ekind (U_Ent) /= E_Variable + and then Ekind (U_Ent) /= E_Constant + then + Error_Msg_N ("size cannot be given for &", Nam); + + elsif Is_Array_Type (U_Ent) + and then not Is_Constrained (U_Ent) + then + Error_Msg_N + ("size cannot be given for unconstrained array", Nam); + + elsif Size /= No_Uint then + + if VM_Target /= No_VM and then not GNAT_Mode then + + -- Size clause is not handled properly on VM targets. + -- Display a warning unless we are in GNAT mode, in which + -- case this is useless. + + Error_Msg_N + ("?size clauses are ignored in this configuration", N); + end if; + + if Is_Type (U_Ent) then + Etyp := U_Ent; + else + Etyp := Etype (U_Ent); + end if; + + -- Check size, note that Gigi is in charge of checking that the + -- size of an array or record type is OK. Also we do not check + -- the size in the ordinary fixed-point case, since it is too + -- early to do so (there may be subsequent small clause that + -- affects the size). We can check the size if a small clause + -- has already been given. + + if not Is_Ordinary_Fixed_Point_Type (U_Ent) + or else Has_Small_Clause (U_Ent) + then + Check_Size (Expr, Etyp, Size, Biased); + Set_Biased (U_Ent, N, "size clause", Biased); + end if; + + -- For types set RM_Size and Esize if possible + + if Is_Type (U_Ent) then + Set_RM_Size (U_Ent, Size); + + -- For scalar types, increase Object_Size to power of 2, but + -- not less than a storage unit in any case (i.e., normally + -- this means it will be byte addressable). + + if Is_Scalar_Type (U_Ent) then + if Size <= System_Storage_Unit then + Init_Esize (U_Ent, System_Storage_Unit); + elsif Size <= 16 then + Init_Esize (U_Ent, 16); + elsif Size <= 32 then + Init_Esize (U_Ent, 32); + else + Set_Esize (U_Ent, (Size + 63) / 64 * 64); + end if; + + -- For all other types, object size = value size. The + -- backend will adjust as needed. + + else + Set_Esize (U_Ent, Size); + end if; + + Alignment_Check_For_Esize_Change (U_Ent); + + -- For objects, set Esize only + + else + if Is_Elementary_Type (Etyp) then + if Size /= System_Storage_Unit + and then + Size /= System_Storage_Unit * 2 + and then + Size /= System_Storage_Unit * 4 + and then + Size /= System_Storage_Unit * 8 + then + Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit); + Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8; + Error_Msg_N + ("size for primitive object must be a power of 2" + & " in the range ^-^", N); + end if; + end if; + + Set_Esize (U_Ent, Size); + end if; + + Set_Has_Size_Clause (U_Ent); + end if; + end Size; + + ----------- + -- Small -- + ----------- + + -- Small attribute definition clause + + when Attribute_Small => Small : declare + Implicit_Base : constant Entity_Id := Base_Type (U_Ent); + Small : Ureal; + + begin + Analyze_And_Resolve (Expr, Any_Real); + + if Etype (Expr) = Any_Type then + return; + + elsif not Is_Static_Expression (Expr) then + Flag_Non_Static_Expr + ("small requires static expression!", Expr); + return; + + else + Small := Expr_Value_R (Expr); + + if Small <= Ureal_0 then + Error_Msg_N ("small value must be greater than zero", Expr); + return; + end if; + + end if; + + if not Is_Ordinary_Fixed_Point_Type (U_Ent) then + Error_Msg_N + ("small requires an ordinary fixed point type", Nam); + + elsif Has_Small_Clause (U_Ent) then + Error_Msg_N ("small already given for &", Nam); + + elsif Small > Delta_Value (U_Ent) then + Error_Msg_N + ("small value must not be greater then delta value", Nam); + + else + Set_Small_Value (U_Ent, Small); + Set_Small_Value (Implicit_Base, Small); + Set_Has_Small_Clause (U_Ent); + Set_Has_Small_Clause (Implicit_Base); + Set_Has_Non_Standard_Rep (Implicit_Base); + end if; + end Small; + + ------------------ + -- Storage_Pool -- + ------------------ + + -- Storage_Pool attribute definition clause + + when Attribute_Storage_Pool => Storage_Pool : declare + Pool : Entity_Id; + T : Entity_Id; + + begin + if Ekind (U_Ent) = E_Access_Subprogram_Type then + Error_Msg_N + ("storage pool cannot be given for access-to-subprogram type", + Nam); + return; + + elsif not + Ekind_In (U_Ent, E_Access_Type, E_General_Access_Type) + then + Error_Msg_N + ("storage pool can only be given for access types", Nam); + return; + + elsif Is_Derived_Type (U_Ent) then + Error_Msg_N + ("storage pool cannot be given for a derived access type", + Nam); + + elsif Duplicate_Clause then + return; + + elsif Present (Associated_Storage_Pool (U_Ent)) then + Error_Msg_N ("storage pool already given for &", Nam); + return; + end if; + + Analyze_And_Resolve + (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool))); + + if not Denotes_Variable (Expr) then + Error_Msg_N ("storage pool must be a variable", Expr); + return; + end if; + + if Nkind (Expr) = N_Type_Conversion then + T := Etype (Expression (Expr)); + else + T := Etype (Expr); + end if; + + -- The Stack_Bounded_Pool is used internally for implementing + -- access types with a Storage_Size. Since it only work + -- properly when used on one specific type, we need to check + -- that it is not hijacked improperly: + -- type T is access Integer; + -- for T'Storage_Size use n; + -- type Q is access Float; + -- for Q'Storage_Size use T'Storage_Size; -- incorrect + + if RTE_Available (RE_Stack_Bounded_Pool) + and then Base_Type (T) = RTE (RE_Stack_Bounded_Pool) + then + Error_Msg_N ("non-shareable internal Pool", Expr); + return; + end if; + + -- If the argument is a name that is not an entity name, then + -- we construct a renaming operation to define an entity of + -- type storage pool. + + if not Is_Entity_Name (Expr) + and then Is_Object_Reference (Expr) + then + Pool := Make_Temporary (Loc, 'P', Expr); + + declare + Rnode : constant Node_Id := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Pool, + Subtype_Mark => + New_Occurrence_Of (Etype (Expr), Loc), + Name => Expr); + + begin + Insert_Before (N, Rnode); + Analyze (Rnode); + Set_Associated_Storage_Pool (U_Ent, Pool); + end; + + elsif Is_Entity_Name (Expr) then + Pool := Entity (Expr); + + -- If pool is a renamed object, get original one. This can + -- happen with an explicit renaming, and within instances. + + while Present (Renamed_Object (Pool)) + and then Is_Entity_Name (Renamed_Object (Pool)) + loop + Pool := Entity (Renamed_Object (Pool)); + end loop; + + if Present (Renamed_Object (Pool)) + and then Nkind (Renamed_Object (Pool)) = N_Type_Conversion + and then Is_Entity_Name (Expression (Renamed_Object (Pool))) + then + Pool := Entity (Expression (Renamed_Object (Pool))); + end if; + + Set_Associated_Storage_Pool (U_Ent, Pool); + + elsif Nkind (Expr) = N_Type_Conversion + and then Is_Entity_Name (Expression (Expr)) + and then Nkind (Original_Node (Expr)) = N_Attribute_Reference + then + Pool := Entity (Expression (Expr)); + Set_Associated_Storage_Pool (U_Ent, Pool); + + else + Error_Msg_N ("incorrect reference to a Storage Pool", Expr); + return; + end if; + end Storage_Pool; + + ------------------ + -- Storage_Size -- + ------------------ + + -- Storage_Size attribute definition clause + + when Attribute_Storage_Size => Storage_Size : declare + Btype : constant Entity_Id := Base_Type (U_Ent); + Sprag : Node_Id; + + begin + if Is_Task_Type (U_Ent) then + Check_Restriction (No_Obsolescent_Features, N); + + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("storage size clause for task is an " & + "obsolescent feature (RM J.9)?", N); + Error_Msg_N ("\use Storage_Size pragma instead?", N); + end if; + + FOnly := True; + end if; + + if not Is_Access_Type (U_Ent) + and then Ekind (U_Ent) /= E_Task_Type + then + Error_Msg_N ("storage size cannot be given for &", Nam); + + elsif Is_Access_Type (U_Ent) and Is_Derived_Type (U_Ent) then + Error_Msg_N + ("storage size cannot be given for a derived access type", + Nam); + + elsif Duplicate_Clause then + null; + + else + Analyze_And_Resolve (Expr, Any_Integer); + + if Is_Access_Type (U_Ent) then + if Present (Associated_Storage_Pool (U_Ent)) then + Error_Msg_N ("storage pool already given for &", Nam); + return; + end if; + + if Is_OK_Static_Expression (Expr) + and then Expr_Value (Expr) = 0 + then + Set_No_Pool_Assigned (Btype); + end if; + + else -- Is_Task_Type (U_Ent) + Sprag := Get_Rep_Pragma (Btype, Name_Storage_Size); + + if Present (Sprag) then + Error_Msg_Sloc := Sloc (Sprag); + Error_Msg_N + ("Storage_Size already specified#", Nam); + return; + end if; + end if; + + Set_Has_Storage_Size_Clause (Btype); + end if; + end Storage_Size; + + ----------------- + -- Stream_Size -- + ----------------- + + when Attribute_Stream_Size => Stream_Size : declare + Size : constant Uint := Static_Integer (Expr); + + begin + if Ada_Version <= Ada_95 then + Check_Restriction (No_Implementation_Attributes, N); + end if; + + if Duplicate_Clause then + null; + + elsif Is_Elementary_Type (U_Ent) then + if Size /= System_Storage_Unit + and then + Size /= System_Storage_Unit * 2 + and then + Size /= System_Storage_Unit * 4 + and then + Size /= System_Storage_Unit * 8 + then + Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit); + Error_Msg_N + ("stream size for elementary type must be a" + & " power of 2 and at least ^", N); + + elsif RM_Size (U_Ent) > Size then + Error_Msg_Uint_1 := RM_Size (U_Ent); + Error_Msg_N + ("stream size for elementary type must be a" + & " power of 2 and at least ^", N); + end if; + + Set_Has_Stream_Size_Clause (U_Ent); + + else + Error_Msg_N ("Stream_Size cannot be given for &", Nam); + end if; + end Stream_Size; + + ---------------- + -- Value_Size -- + ---------------- + + -- Value_Size attribute definition clause + + when Attribute_Value_Size => Value_Size : declare + Size : constant Uint := Static_Integer (Expr); + Biased : Boolean; + + begin + if not Is_Type (U_Ent) then + Error_Msg_N ("Value_Size cannot be given for &", Nam); + + elsif Duplicate_Clause then + null; + + elsif Is_Array_Type (U_Ent) + and then not Is_Constrained (U_Ent) + then + Error_Msg_N + ("Value_Size cannot be given for unconstrained array", Nam); + + else + if Is_Elementary_Type (U_Ent) then + Check_Size (Expr, U_Ent, Size, Biased); + Set_Biased (U_Ent, N, "value size clause", Biased); + end if; + + Set_RM_Size (U_Ent, Size); + end if; + end Value_Size; + + ----------- + -- Write -- + ----------- + + when Attribute_Write => + Analyze_Stream_TSS_Definition (TSS_Stream_Write); + Set_Has_Specified_Stream_Write (Ent); + + -- All other attributes cannot be set + + when others => + Error_Msg_N + ("attribute& cannot be set with definition clause", N); + end case; + + -- The test for the type being frozen must be performed after + -- any expression the clause has been analyzed since the expression + -- itself might cause freezing that makes the clause illegal. + + if Rep_Item_Too_Late (U_Ent, N, FOnly) then + return; + end if; + end Analyze_Attribute_Definition_Clause; + + ---------------------------- + -- Analyze_Code_Statement -- + ---------------------------- + + procedure Analyze_Code_Statement (N : Node_Id) is + HSS : constant Node_Id := Parent (N); + SBody : constant Node_Id := Parent (HSS); + Subp : constant Entity_Id := Current_Scope; + Stmt : Node_Id; + Decl : Node_Id; + StmtO : Node_Id; + DeclO : Node_Id; + + begin + -- Analyze and check we get right type, note that this implements the + -- requirement (RM 13.8(1)) that Machine_Code be with'ed, since that + -- is the only way that Asm_Insn could possibly be visible. + + Analyze_And_Resolve (Expression (N)); + + if Etype (Expression (N)) = Any_Type then + return; + elsif Etype (Expression (N)) /= RTE (RE_Asm_Insn) then + Error_Msg_N ("incorrect type for code statement", N); + return; + end if; + + Check_Code_Statement (N); + + -- Make sure we appear in the handled statement sequence of a + -- subprogram (RM 13.8(3)). + + if Nkind (HSS) /= N_Handled_Sequence_Of_Statements + or else Nkind (SBody) /= N_Subprogram_Body + then + Error_Msg_N + ("code statement can only appear in body of subprogram", N); + return; + end if; + + -- Do remaining checks (RM 13.8(3)) if not already done + + if not Is_Machine_Code_Subprogram (Subp) then + Set_Is_Machine_Code_Subprogram (Subp); + + -- No exception handlers allowed + + if Present (Exception_Handlers (HSS)) then + Error_Msg_N + ("exception handlers not permitted in machine code subprogram", + First (Exception_Handlers (HSS))); + end if; + + -- No declarations other than use clauses and pragmas (we allow + -- certain internally generated declarations as well). + + Decl := First (Declarations (SBody)); + while Present (Decl) loop + DeclO := Original_Node (Decl); + if Comes_From_Source (DeclO) + and not Nkind_In (DeclO, N_Pragma, + N_Use_Package_Clause, + N_Use_Type_Clause, + N_Implicit_Label_Declaration) + then + Error_Msg_N + ("this declaration not allowed in machine code subprogram", + DeclO); + end if; + + Next (Decl); + end loop; + + -- No statements other than code statements, pragmas, and labels. + -- Again we allow certain internally generated statements. + + Stmt := First (Statements (HSS)); + while Present (Stmt) loop + StmtO := Original_Node (Stmt); + if Comes_From_Source (StmtO) + and then not Nkind_In (StmtO, N_Pragma, + N_Label, + N_Code_Statement) + then + Error_Msg_N + ("this statement is not allowed in machine code subprogram", + StmtO); + end if; + + Next (Stmt); + end loop; + end if; + end Analyze_Code_Statement; + + ----------------------------------------------- + -- Analyze_Enumeration_Representation_Clause -- + ----------------------------------------------- + + procedure Analyze_Enumeration_Representation_Clause (N : Node_Id) is + Ident : constant Node_Id := Identifier (N); + Aggr : constant Node_Id := Array_Aggregate (N); + Enumtype : Entity_Id; + Elit : Entity_Id; + Expr : Node_Id; + Assoc : Node_Id; + Choice : Node_Id; + Val : Uint; + Err : Boolean := False; + + Lo : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer)); + Hi : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer)); + -- Allowed range of universal integer (= allowed range of enum lit vals) + + Min : Uint; + Max : Uint; + -- Minimum and maximum values of entries + + Max_Node : Node_Id; + -- Pointer to node for literal providing max value + + begin + if Ignore_Rep_Clauses then + return; + end if; + + -- First some basic error checks + + Find_Type (Ident); + Enumtype := Entity (Ident); + + if Enumtype = Any_Type + or else Rep_Item_Too_Early (Enumtype, N) + then + return; + else + Enumtype := Underlying_Type (Enumtype); + end if; + + if not Is_Enumeration_Type (Enumtype) then + Error_Msg_NE + ("enumeration type required, found}", + Ident, First_Subtype (Enumtype)); + return; + end if; + + -- Ignore rep clause on generic actual type. This will already have + -- been flagged on the template as an error, and this is the safest + -- way to ensure we don't get a junk cascaded message in the instance. + + if Is_Generic_Actual_Type (Enumtype) then + return; + + -- Type must be in current scope + + elsif Scope (Enumtype) /= Current_Scope then + Error_Msg_N ("type must be declared in this scope", Ident); + return; + + -- Type must be a first subtype + + elsif not Is_First_Subtype (Enumtype) then + Error_Msg_N ("cannot give enumeration rep clause for subtype", N); + return; + + -- Ignore duplicate rep clause + + elsif Has_Enumeration_Rep_Clause (Enumtype) then + Error_Msg_N ("duplicate enumeration rep clause ignored", N); + return; + + -- Don't allow rep clause for standard [wide_[wide_]]character + + elsif Is_Standard_Character_Type (Enumtype) then + Error_Msg_N ("enumeration rep clause not allowed for this type", N); + return; + + -- Check that the expression is a proper aggregate (no parentheses) + + elsif Paren_Count (Aggr) /= 0 then + Error_Msg + ("extra parentheses surrounding aggregate not allowed", + First_Sloc (Aggr)); + return; + + -- All tests passed, so set rep clause in place + + else + Set_Has_Enumeration_Rep_Clause (Enumtype); + Set_Has_Enumeration_Rep_Clause (Base_Type (Enumtype)); + end if; + + -- Now we process the aggregate. Note that we don't use the normal + -- aggregate code for this purpose, because we don't want any of the + -- normal expansion activities, and a number of special semantic + -- rules apply (including the component type being any integer type) + + Elit := First_Literal (Enumtype); + + -- First the positional entries if any + + if Present (Expressions (Aggr)) then + Expr := First (Expressions (Aggr)); + while Present (Expr) loop + if No (Elit) then + Error_Msg_N ("too many entries in aggregate", Expr); + return; + end if; + + Val := Static_Integer (Expr); + + -- Err signals that we found some incorrect entries processing + -- the list. The final checks for completeness and ordering are + -- skipped in this case. + + if Val = No_Uint then + Err := True; + elsif Val < Lo or else Hi < Val then + Error_Msg_N ("value outside permitted range", Expr); + Err := True; + end if; + + Set_Enumeration_Rep (Elit, Val); + Set_Enumeration_Rep_Expr (Elit, Expr); + Next (Expr); + Next (Elit); + end loop; + end if; + + -- Now process the named entries if present + + if Present (Component_Associations (Aggr)) then + Assoc := First (Component_Associations (Aggr)); + while Present (Assoc) loop + Choice := First (Choices (Assoc)); + + if Present (Next (Choice)) then + Error_Msg_N + ("multiple choice not allowed here", Next (Choice)); + Err := True; + end if; + + if Nkind (Choice) = N_Others_Choice then + Error_Msg_N ("others choice not allowed here", Choice); + Err := True; + + elsif Nkind (Choice) = N_Range then + -- ??? should allow zero/one element range here + Error_Msg_N ("range not allowed here", Choice); + Err := True; + + else + Analyze_And_Resolve (Choice, Enumtype); + + if Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + then + Error_Msg_N ("subtype name not allowed here", Choice); + Err := True; + -- ??? should allow static subtype with zero/one entry + + elsif Etype (Choice) = Base_Type (Enumtype) then + if not Is_Static_Expression (Choice) then + Flag_Non_Static_Expr + ("non-static expression used for choice!", Choice); + Err := True; + + else + Elit := Expr_Value_E (Choice); + + if Present (Enumeration_Rep_Expr (Elit)) then + Error_Msg_Sloc := Sloc (Enumeration_Rep_Expr (Elit)); + Error_Msg_NE + ("representation for& previously given#", + Choice, Elit); + Err := True; + end if; + + Set_Enumeration_Rep_Expr (Elit, Expression (Assoc)); + + Expr := Expression (Assoc); + Val := Static_Integer (Expr); + + if Val = No_Uint then + Err := True; + + elsif Val < Lo or else Hi < Val then + Error_Msg_N ("value outside permitted range", Expr); + Err := True; + end if; + + Set_Enumeration_Rep (Elit, Val); + end if; + end if; + end if; + + Next (Assoc); + end loop; + end if; + + -- Aggregate is fully processed. Now we check that a full set of + -- representations was given, and that they are in range and in order. + -- These checks are only done if no other errors occurred. + + if not Err then + Min := No_Uint; + Max := No_Uint; + + Elit := First_Literal (Enumtype); + while Present (Elit) loop + if No (Enumeration_Rep_Expr (Elit)) then + Error_Msg_NE ("missing representation for&!", N, Elit); + + else + Val := Enumeration_Rep (Elit); + + if Min = No_Uint then + Min := Val; + end if; + + if Val /= No_Uint then + if Max /= No_Uint and then Val <= Max then + Error_Msg_NE + ("enumeration value for& not ordered!", + Enumeration_Rep_Expr (Elit), Elit); + end if; + + Max_Node := Enumeration_Rep_Expr (Elit); + Max := Val; + end if; + + -- If there is at least one literal whose representation is not + -- equal to the Pos value, then note that this enumeration type + -- has a non-standard representation. + + if Val /= Enumeration_Pos (Elit) then + Set_Has_Non_Standard_Rep (Base_Type (Enumtype)); + end if; + end if; + + Next (Elit); + end loop; + + -- Now set proper size information + + declare + Minsize : Uint := UI_From_Int (Minimum_Size (Enumtype)); + + begin + if Has_Size_Clause (Enumtype) then + + -- All OK, if size is OK now + + if RM_Size (Enumtype) >= Minsize then + null; + + else + -- Try if we can get by with biasing + + Minsize := + UI_From_Int (Minimum_Size (Enumtype, Biased => True)); + + -- Error message if even biasing does not work + + if RM_Size (Enumtype) < Minsize then + Error_Msg_Uint_1 := RM_Size (Enumtype); + Error_Msg_Uint_2 := Max; + Error_Msg_N + ("previously given size (^) is too small " + & "for this value (^)", Max_Node); + + -- If biasing worked, indicate that we now have biased rep + + else + Set_Biased + (Enumtype, Size_Clause (Enumtype), "size clause"); + end if; + end if; + + else + Set_RM_Size (Enumtype, Minsize); + Set_Enum_Esize (Enumtype); + end if; + + Set_RM_Size (Base_Type (Enumtype), RM_Size (Enumtype)); + Set_Esize (Base_Type (Enumtype), Esize (Enumtype)); + Set_Alignment (Base_Type (Enumtype), Alignment (Enumtype)); + end; + end if; + + -- We repeat the too late test in case it froze itself! + + if Rep_Item_Too_Late (Enumtype, N) then + null; + end if; + end Analyze_Enumeration_Representation_Clause; + + ---------------------------- + -- Analyze_Free_Statement -- + ---------------------------- + + procedure Analyze_Free_Statement (N : Node_Id) is + begin + Analyze (Expression (N)); + end Analyze_Free_Statement; + + --------------------------- + -- Analyze_Freeze_Entity -- + --------------------------- + + procedure Analyze_Freeze_Entity (N : Node_Id) is + E : constant Entity_Id := Entity (N); + + begin + -- Remember that we are processing a freezing entity. Required to + -- ensure correct decoration of internal entities associated with + -- interfaces (see New_Overloaded_Entity). + + Inside_Freezing_Actions := Inside_Freezing_Actions + 1; + + -- For tagged types covering interfaces add internal entities that link + -- the primitives of the interfaces with the primitives that cover them. + -- Note: These entities were originally generated only when generating + -- code because their main purpose was to provide support to initialize + -- the secondary dispatch tables. They are now generated also when + -- compiling with no code generation to provide ASIS the relationship + -- between interface primitives and tagged type primitives. They are + -- also used to locate primitives covering interfaces when processing + -- generics (see Derive_Subprograms). + + if Ada_Version >= Ada_2005 + and then Ekind (E) = E_Record_Type + and then Is_Tagged_Type (E) + and then not Is_Interface (E) + and then Has_Interfaces (E) + then + -- This would be a good common place to call the routine that checks + -- overriding of interface primitives (and thus factorize calls to + -- Check_Abstract_Overriding located at different contexts in the + -- compiler). However, this is not possible because it causes + -- spurious errors in case of late overriding. + + Add_Internal_Interface_Entities (E); + end if; + + -- Check CPP types + + if Ekind (E) = E_Record_Type + and then Is_CPP_Class (E) + and then Is_Tagged_Type (E) + and then Tagged_Type_Expansion + and then Expander_Active + then + if CPP_Num_Prims (E) = 0 then + + -- If the CPP type has user defined components then it must import + -- primitives from C++. This is required because if the C++ class + -- has no primitives then the C++ compiler does not added the _tag + -- component to the type. + + pragma Assert (Chars (First_Entity (E)) = Name_uTag); + + if First_Entity (E) /= Last_Entity (E) then + Error_Msg_N + ("?'C'P'P type must import at least one primitive from C++", + E); + end if; + end if; + + -- Check that all its primitives are abstract or imported from C++. + -- Check also availability of the C++ constructor. + + declare + Has_Constructors : constant Boolean := Has_CPP_Constructors (E); + Elmt : Elmt_Id; + Error_Reported : Boolean := False; + Prim : Node_Id; + + begin + Elmt := First_Elmt (Primitive_Operations (E)); + while Present (Elmt) loop + Prim := Node (Elmt); + + if Comes_From_Source (Prim) then + if Is_Abstract_Subprogram (Prim) then + null; + + elsif not Is_Imported (Prim) + or else Convention (Prim) /= Convention_CPP + then + Error_Msg_N + ("?primitives of 'C'P'P types must be imported from C++" + & " or abstract", Prim); + + elsif not Has_Constructors + and then not Error_Reported + then + Error_Msg_Name_1 := Chars (E); + Error_Msg_N + ("?'C'P'P constructor required for type %", Prim); + Error_Reported := True; + end if; + end if; + + Next_Elmt (Elmt); + end loop; + end; + end if; + + Inside_Freezing_Actions := Inside_Freezing_Actions - 1; + + -- If we have a type with predicates, build predicate function + + if Is_Type (E) and then Has_Predicates (E) then + Build_Predicate_Function (E, N); + end if; + end Analyze_Freeze_Entity; + + ------------------------------------------ + -- Analyze_Record_Representation_Clause -- + ------------------------------------------ + + -- Note: we check as much as we can here, but we can't do any checks + -- based on the position values (e.g. overlap checks) until freeze time + -- because especially in Ada 2005 (machine scalar mode), the processing + -- for non-standard bit order can substantially change the positions. + -- See procedure Check_Record_Representation_Clause (called from Freeze) + -- for the remainder of this processing. + + procedure Analyze_Record_Representation_Clause (N : Node_Id) is + Ident : constant Node_Id := Identifier (N); + Biased : Boolean; + CC : Node_Id; + Comp : Entity_Id; + Fbit : Uint; + Hbit : Uint := Uint_0; + Lbit : Uint; + Ocomp : Entity_Id; + Posit : Uint; + Rectype : Entity_Id; + + CR_Pragma : Node_Id := Empty; + -- Points to N_Pragma node if Complete_Representation pragma present + + begin + if Ignore_Rep_Clauses then + return; + end if; + + Find_Type (Ident); + Rectype := Entity (Ident); + + if Rectype = Any_Type + or else Rep_Item_Too_Early (Rectype, N) + then + return; + else + Rectype := Underlying_Type (Rectype); + end if; + + -- First some basic error checks + + if not Is_Record_Type (Rectype) then + Error_Msg_NE + ("record type required, found}", Ident, First_Subtype (Rectype)); + return; + + elsif Scope (Rectype) /= Current_Scope then + Error_Msg_N ("type must be declared in this scope", N); + return; + + elsif not Is_First_Subtype (Rectype) then + Error_Msg_N ("cannot give record rep clause for subtype", N); + return; + + elsif Has_Record_Rep_Clause (Rectype) then + Error_Msg_N ("duplicate record rep clause ignored", N); + return; + + elsif Rep_Item_Too_Late (Rectype, N) then + return; + end if; + + if Present (Mod_Clause (N)) then + declare + Loc : constant Source_Ptr := Sloc (N); + M : constant Node_Id := Mod_Clause (N); + P : constant List_Id := Pragmas_Before (M); + AtM_Nod : Node_Id; + + Mod_Val : Uint; + pragma Warnings (Off, Mod_Val); + + begin + Check_Restriction (No_Obsolescent_Features, Mod_Clause (N)); + + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("mod clause is an obsolescent feature (RM J.8)?", N); + Error_Msg_N + ("\use alignment attribute definition clause instead?", N); + end if; + + if Present (P) then + Analyze_List (P); + end if; + + -- In ASIS_Mode mode, expansion is disabled, but we must convert + -- the Mod clause into an alignment clause anyway, so that the + -- back-end can compute and back-annotate properly the size and + -- alignment of types that may include this record. + + -- This seems dubious, this destroys the source tree in a manner + -- not detectable by ASIS ??? + + if Operating_Mode = Check_Semantics + and then ASIS_Mode + then + AtM_Nod := + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (Base_Type (Rectype), Loc), + Chars => Name_Alignment, + Expression => Relocate_Node (Expression (M))); + + Set_From_At_Mod (AtM_Nod); + Insert_After (N, AtM_Nod); + Mod_Val := Get_Alignment_Value (Expression (AtM_Nod)); + Set_Mod_Clause (N, Empty); + + else + -- Get the alignment value to perform error checking + + Mod_Val := Get_Alignment_Value (Expression (M)); + end if; + end; + end if; + + -- For untagged types, clear any existing component clauses for the + -- type. If the type is derived, this is what allows us to override + -- a rep clause for the parent. For type extensions, the representation + -- of the inherited components is inherited, so we want to keep previous + -- component clauses for completeness. + + if not Is_Tagged_Type (Rectype) then + Comp := First_Component_Or_Discriminant (Rectype); + while Present (Comp) loop + Set_Component_Clause (Comp, Empty); + Next_Component_Or_Discriminant (Comp); + end loop; + end if; + + -- All done if no component clauses + + CC := First (Component_Clauses (N)); + + if No (CC) then + return; + end if; + + -- A representation like this applies to the base type + + Set_Has_Record_Rep_Clause (Base_Type (Rectype)); + Set_Has_Non_Standard_Rep (Base_Type (Rectype)); + Set_Has_Specified_Layout (Base_Type (Rectype)); + + -- Process the component clauses + + while Present (CC) loop + + -- Pragma + + if Nkind (CC) = N_Pragma then + Analyze (CC); + + -- The only pragma of interest is Complete_Representation + + if Pragma_Name (CC) = Name_Complete_Representation then + CR_Pragma := CC; + end if; + + -- Processing for real component clause + + else + Posit := Static_Integer (Position (CC)); + Fbit := Static_Integer (First_Bit (CC)); + Lbit := Static_Integer (Last_Bit (CC)); + + if Posit /= No_Uint + and then Fbit /= No_Uint + and then Lbit /= No_Uint + then + if Posit < 0 then + Error_Msg_N + ("position cannot be negative", Position (CC)); + + elsif Fbit < 0 then + Error_Msg_N + ("first bit cannot be negative", First_Bit (CC)); + + -- The Last_Bit specified in a component clause must not be + -- less than the First_Bit minus one (RM-13.5.1(10)). + + elsif Lbit < Fbit - 1 then + Error_Msg_N + ("last bit cannot be less than first bit minus one", + Last_Bit (CC)); + + -- Values look OK, so find the corresponding record component + -- Even though the syntax allows an attribute reference for + -- implementation-defined components, GNAT does not allow the + -- tag to get an explicit position. + + elsif Nkind (Component_Name (CC)) = N_Attribute_Reference then + if Attribute_Name (Component_Name (CC)) = Name_Tag then + Error_Msg_N ("position of tag cannot be specified", CC); + else + Error_Msg_N ("illegal component name", CC); + end if; + + else + Comp := First_Entity (Rectype); + while Present (Comp) loop + exit when Chars (Comp) = Chars (Component_Name (CC)); + Next_Entity (Comp); + end loop; + + if No (Comp) then + + -- Maybe component of base type that is absent from + -- statically constrained first subtype. + + Comp := First_Entity (Base_Type (Rectype)); + while Present (Comp) loop + exit when Chars (Comp) = Chars (Component_Name (CC)); + Next_Entity (Comp); + end loop; + end if; + + if No (Comp) then + Error_Msg_N + ("component clause is for non-existent field", CC); + + -- Ada 2012 (AI05-0026): Any name that denotes a + -- discriminant of an object of an unchecked union type + -- shall not occur within a record_representation_clause. + + -- The general restriction of using record rep clauses on + -- Unchecked_Union types has now been lifted. Since it is + -- possible to introduce a record rep clause which mentions + -- the discriminant of an Unchecked_Union in non-Ada 2012 + -- code, this check is applied to all versions of the + -- language. + + elsif Ekind (Comp) = E_Discriminant + and then Is_Unchecked_Union (Rectype) + then + Error_Msg_N + ("cannot reference discriminant of Unchecked_Union", + Component_Name (CC)); + + elsif Present (Component_Clause (Comp)) then + + -- Diagnose duplicate rep clause, or check consistency + -- if this is an inherited component. In a double fault, + -- there may be a duplicate inconsistent clause for an + -- inherited component. + + if Scope (Original_Record_Component (Comp)) = Rectype + or else Parent (Component_Clause (Comp)) = N + then + Error_Msg_Sloc := Sloc (Component_Clause (Comp)); + Error_Msg_N ("component clause previously given#", CC); + + else + declare + Rep1 : constant Node_Id := Component_Clause (Comp); + begin + if Intval (Position (Rep1)) /= + Intval (Position (CC)) + or else Intval (First_Bit (Rep1)) /= + Intval (First_Bit (CC)) + or else Intval (Last_Bit (Rep1)) /= + Intval (Last_Bit (CC)) + then + Error_Msg_N ("component clause inconsistent " + & "with representation of ancestor", CC); + elsif Warn_On_Redundant_Constructs then + Error_Msg_N ("?redundant component clause " + & "for inherited component!", CC); + end if; + end; + end if; + + -- Normal case where this is the first component clause we + -- have seen for this entity, so set it up properly. + + else + -- Make reference for field in record rep clause and set + -- appropriate entity field in the field identifier. + + Generate_Reference + (Comp, Component_Name (CC), Set_Ref => False); + Set_Entity (Component_Name (CC), Comp); + + -- Update Fbit and Lbit to the actual bit number + + Fbit := Fbit + UI_From_Int (SSU) * Posit; + Lbit := Lbit + UI_From_Int (SSU) * Posit; + + if Has_Size_Clause (Rectype) + and then Esize (Rectype) <= Lbit + then + Error_Msg_N + ("bit number out of range of specified size", + Last_Bit (CC)); + else + Set_Component_Clause (Comp, CC); + Set_Component_Bit_Offset (Comp, Fbit); + Set_Esize (Comp, 1 + (Lbit - Fbit)); + Set_Normalized_First_Bit (Comp, Fbit mod SSU); + Set_Normalized_Position (Comp, Fbit / SSU); + + if Warn_On_Overridden_Size + and then Has_Size_Clause (Etype (Comp)) + and then RM_Size (Etype (Comp)) /= Esize (Comp) + then + Error_Msg_NE + ("?component size overrides size clause for&", + Component_Name (CC), Etype (Comp)); + end if; + + -- This information is also set in the corresponding + -- component of the base type, found by accessing the + -- Original_Record_Component link if it is present. + + Ocomp := Original_Record_Component (Comp); + + if Hbit < Lbit then + Hbit := Lbit; + end if; + + Check_Size + (Component_Name (CC), + Etype (Comp), + Esize (Comp), + Biased); + + Set_Biased + (Comp, First_Node (CC), "component clause", Biased); + + if Present (Ocomp) then + Set_Component_Clause (Ocomp, CC); + Set_Component_Bit_Offset (Ocomp, Fbit); + Set_Normalized_First_Bit (Ocomp, Fbit mod SSU); + Set_Normalized_Position (Ocomp, Fbit / SSU); + Set_Esize (Ocomp, 1 + (Lbit - Fbit)); + + Set_Normalized_Position_Max + (Ocomp, Normalized_Position (Ocomp)); + + -- Note: we don't use Set_Biased here, because we + -- already gave a warning above if needed, and we + -- would get a duplicate for the same name here. + + Set_Has_Biased_Representation + (Ocomp, Has_Biased_Representation (Comp)); + end if; + + if Esize (Comp) < 0 then + Error_Msg_N ("component size is negative", CC); + end if; + end if; + end if; + end if; + end if; + end if; + + Next (CC); + end loop; + + -- Check missing components if Complete_Representation pragma appeared + + if Present (CR_Pragma) then + Comp := First_Component_Or_Discriminant (Rectype); + while Present (Comp) loop + if No (Component_Clause (Comp)) then + Error_Msg_NE + ("missing component clause for &", CR_Pragma, Comp); + end if; + + Next_Component_Or_Discriminant (Comp); + end loop; + + -- If no Complete_Representation pragma, warn if missing components + + elsif Warn_On_Unrepped_Components then + declare + Num_Repped_Components : Nat := 0; + Num_Unrepped_Components : Nat := 0; + + begin + -- First count number of repped and unrepped components + + Comp := First_Component_Or_Discriminant (Rectype); + while Present (Comp) loop + if Present (Component_Clause (Comp)) then + Num_Repped_Components := Num_Repped_Components + 1; + else + Num_Unrepped_Components := Num_Unrepped_Components + 1; + end if; + + Next_Component_Or_Discriminant (Comp); + end loop; + + -- We are only interested in the case where there is at least one + -- unrepped component, and at least half the components have rep + -- clauses. We figure that if less than half have them, then the + -- partial rep clause is really intentional. If the component + -- type has no underlying type set at this point (as for a generic + -- formal type), we don't know enough to give a warning on the + -- component. + + if Num_Unrepped_Components > 0 + and then Num_Unrepped_Components < Num_Repped_Components + then + Comp := First_Component_Or_Discriminant (Rectype); + while Present (Comp) loop + if No (Component_Clause (Comp)) + and then Comes_From_Source (Comp) + and then Present (Underlying_Type (Etype (Comp))) + and then (Is_Scalar_Type (Underlying_Type (Etype (Comp))) + or else Size_Known_At_Compile_Time + (Underlying_Type (Etype (Comp)))) + and then not Has_Warnings_Off (Rectype) + then + Error_Msg_Sloc := Sloc (Comp); + Error_Msg_NE + ("?no component clause given for & declared #", + N, Comp); + end if; + + Next_Component_Or_Discriminant (Comp); + end loop; + end if; + end; + end if; + end Analyze_Record_Representation_Clause; + + ------------------------------- + -- Build_Invariant_Procedure -- + ------------------------------- + + -- The procedure that is constructed here has the form + + -- procedure typInvariant (Ixxx : typ) is + -- begin + -- pragma Check (Invariant, exp, "failed invariant from xxx"); + -- pragma Check (Invariant, exp, "failed invariant from xxx"); + -- ... + -- pragma Check (Invariant, exp, "failed inherited invariant from xxx"); + -- ... + -- end typInvariant; + + procedure Build_Invariant_Procedure (Typ : Entity_Id; N : Node_Id) is + Loc : constant Source_Ptr := Sloc (Typ); + Stmts : List_Id; + Spec : Node_Id; + SId : Entity_Id; + PDecl : Node_Id; + PBody : Node_Id; + + Visible_Decls : constant List_Id := Visible_Declarations (N); + Private_Decls : constant List_Id := Private_Declarations (N); + + procedure Add_Invariants (T : Entity_Id; Inherit : Boolean); + -- Appends statements to Stmts for any invariants in the rep item chain + -- of the given type. If Inherit is False, then we only process entries + -- on the chain for the type Typ. If Inherit is True, then we ignore any + -- Invariant aspects, but we process all Invariant'Class aspects, adding + -- "inherited" to the exception message and generating an informational + -- message about the inheritance of an invariant. + + Object_Name : constant Name_Id := New_Internal_Name ('I'); + -- Name for argument of invariant procedure + + Object_Entity : constant Node_Id := + Make_Defining_Identifier (Loc, Object_Name); + -- The procedure declaration entity for the argument + + -------------------- + -- Add_Invariants -- + -------------------- + + procedure Add_Invariants (T : Entity_Id; Inherit : Boolean) is + Ritem : Node_Id; + Arg1 : Node_Id; + Arg2 : Node_Id; + Arg3 : Node_Id; + Exp : Node_Id; + Loc : Source_Ptr; + Assoc : List_Id; + Str : String_Id; + + procedure Replace_Type_Reference (N : Node_Id); + -- Replace a single occurrence N of the subtype name with a reference + -- to the formal of the predicate function. N can be an identifier + -- referencing the subtype, or a selected component, representing an + -- appropriately qualified occurrence of the subtype name. + + procedure Replace_Type_References is + new Replace_Type_References_Generic (Replace_Type_Reference); + -- Traverse an expression replacing all occurrences of the subtype + -- name with appropriate references to the object that is the formal + -- parameter of the predicate function. Note that we must ensure + -- that the type and entity information is properly set in the + -- replacement node, since we will do a Preanalyze call of this + -- expression without proper visibility of the procedure argument. + + ---------------------------- + -- Replace_Type_Reference -- + ---------------------------- + + procedure Replace_Type_Reference (N : Node_Id) is + begin + -- Invariant'Class, replace with T'Class (obj) + + if Class_Present (Ritem) then + Rewrite (N, + Make_Type_Conversion (Loc, + Subtype_Mark => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (T, Loc), + Attribute_Name => Name_Class), + Expression => Make_Identifier (Loc, Object_Name))); + + Set_Entity (Expression (N), Object_Entity); + Set_Etype (Expression (N), Typ); + + -- Invariant, replace with obj + + else + Rewrite (N, Make_Identifier (Loc, Object_Name)); + Set_Entity (N, Object_Entity); + Set_Etype (N, Typ); + end if; + end Replace_Type_Reference; + + -- Start of processing for Add_Invariants + + begin + Ritem := First_Rep_Item (T); + while Present (Ritem) loop + if Nkind (Ritem) = N_Pragma + and then Pragma_Name (Ritem) = Name_Invariant + then + Arg1 := First (Pragma_Argument_Associations (Ritem)); + Arg2 := Next (Arg1); + Arg3 := Next (Arg2); + + Arg1 := Get_Pragma_Arg (Arg1); + Arg2 := Get_Pragma_Arg (Arg2); + + -- For Inherit case, ignore Invariant, process only Class case + + if Inherit then + if not Class_Present (Ritem) then + goto Continue; + end if; + + -- For Inherit false, process only item for right type + + else + if Entity (Arg1) /= Typ then + goto Continue; + end if; + end if; + + if No (Stmts) then + Stmts := Empty_List; + end if; + + Exp := New_Copy_Tree (Arg2); + Loc := Sloc (Exp); + + -- We need to replace any occurrences of the name of the type + -- with references to the object, converted to type'Class in + -- the case of Invariant'Class aspects. + + Replace_Type_References (Exp, Chars (T)); + + -- Now we need to preanalyze the expression to properly capture + -- the visibility in the visible part. The expression will not + -- be analyzed for real until the body is analyzed, but that is + -- at the end of the private part and has the wrong visibility. + + Set_Parent (Exp, N); + Preanalyze_Spec_Expression (Exp, Standard_Boolean); + + -- Build first two arguments for Check pragma + + Assoc := New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_Invariant)), + Make_Pragma_Argument_Association (Loc, Expression => Exp)); + + -- Add message if present in Invariant pragma + + if Present (Arg3) then + Str := Strval (Get_Pragma_Arg (Arg3)); + + -- If inherited case, and message starts "failed invariant", + -- change it to be "failed inherited invariant". + + if Inherit then + String_To_Name_Buffer (Str); + + if Name_Buffer (1 .. 16) = "failed invariant" then + Insert_Str_In_Name_Buffer ("inherited ", 8); + Str := String_From_Name_Buffer; + end if; + end if; + + Append_To (Assoc, + Make_Pragma_Argument_Association (Loc, + Expression => Make_String_Literal (Loc, Str))); + end if; + + -- Add Check pragma to list of statements + + Append_To (Stmts, + Make_Pragma (Loc, + Pragma_Identifier => + Make_Identifier (Loc, Name_Check), + Pragma_Argument_Associations => Assoc)); + + -- If Inherited case and option enabled, output info msg. Note + -- that we know this is a case of Invariant'Class. + + if Inherit and Opt.List_Inherited_Aspects then + Error_Msg_Sloc := Sloc (Ritem); + Error_Msg_N + ("?info: & inherits `Invariant''Class` aspect from #", + Typ); + end if; + end if; + + <> + Next_Rep_Item (Ritem); + end loop; + end Add_Invariants; + + -- Start of processing for Build_Invariant_Procedure + + begin + Stmts := No_List; + PDecl := Empty; + PBody := Empty; + Set_Etype (Object_Entity, Typ); + + -- Add invariants for the current type + + Add_Invariants (Typ, Inherit => False); + + -- Add invariants for parent types + + declare + Current_Typ : Entity_Id; + Parent_Typ : Entity_Id; + + begin + Current_Typ := Typ; + loop + Parent_Typ := Etype (Current_Typ); + + if Is_Private_Type (Parent_Typ) + and then Present (Full_View (Base_Type (Parent_Typ))) + then + Parent_Typ := Full_View (Base_Type (Parent_Typ)); + end if; + + exit when Parent_Typ = Current_Typ; + + Current_Typ := Parent_Typ; + Add_Invariants (Current_Typ, Inherit => True); + end loop; + end; + + -- Build the procedure if we generated at least one Check pragma + + if Stmts /= No_List then + + -- Build procedure declaration + + SId := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Invariant")); + Set_Has_Invariants (SId); + Set_Invariant_Procedure (Typ, SId); + + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => SId, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Object_Entity, + Parameter_Type => New_Occurrence_Of (Typ, Loc)))); + + PDecl := Make_Subprogram_Declaration (Loc, Specification => Spec); + + -- Build procedure body + + SId := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Invariant")); + + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => SId, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Object_Name), + Parameter_Type => New_Occurrence_Of (Typ, Loc)))); + + PBody := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + + -- Insert procedure declaration and spec at the appropriate points. + -- Skip this if there are no private declarations (that's an error + -- that will be diagnosed elsewhere, and there is no point in having + -- an invariant procedure set if the full declaration is missing). + + if Present (Private_Decls) then + + -- The spec goes at the end of visible declarations, but they have + -- already been analyzed, so we need to explicitly do the analyze. + + Append_To (Visible_Decls, PDecl); + Analyze (PDecl); + + -- The body goes at the end of the private declarations, which we + -- have not analyzed yet, so we do not need to perform an explicit + -- analyze call. We skip this if there are no private declarations + -- (this is an error that will be caught elsewhere); + + Append_To (Private_Decls, PBody); + end if; + end if; + end Build_Invariant_Procedure; + + ------------------------------ + -- Build_Predicate_Function -- + ------------------------------ + + -- The procedure that is constructed here has the form + + -- function typPredicate (Ixxx : typ) return Boolean is + -- begin + -- return + -- exp1 and then exp2 and then ... + -- and then typ1Predicate (typ1 (Ixxx)) + -- and then typ2Predicate (typ2 (Ixxx)) + -- and then ...; + -- end typPredicate; + + -- Here exp1, and exp2 are expressions from Predicate pragmas. Note that + -- this is the point at which these expressions get analyzed, providing the + -- required delay, and typ1, typ2, are entities from which predicates are + -- inherited. Note that we do NOT generate Check pragmas, that's because we + -- use this function even if checks are off, e.g. for membership tests. + + procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id) is + Loc : constant Source_Ptr := Sloc (Typ); + Spec : Node_Id; + SId : Entity_Id; + FDecl : Node_Id; + FBody : Node_Id; + + Expr : Node_Id; + -- This is the expression for the return statement in the function. It + -- is build by connecting the component predicates with AND THEN. + + procedure Add_Call (T : Entity_Id); + -- Includes a call to the predicate function for type T in Expr if T + -- has predicates and Predicate_Function (T) is non-empty. + + procedure Add_Predicates; + -- Appends expressions for any Predicate pragmas in the rep item chain + -- Typ to Expr. Note that we look only at items for this exact entity. + -- Inheritance of predicates for the parent type is done by calling the + -- Predicate_Function of the parent type, using Add_Call above. + + Object_Name : constant Name_Id := New_Internal_Name ('I'); + -- Name for argument of Predicate procedure + + -------------- + -- Add_Call -- + -------------- + + procedure Add_Call (T : Entity_Id) is + Exp : Node_Id; + + begin + if Present (T) and then Present (Predicate_Function (T)) then + Set_Has_Predicates (Typ); + + -- Build the call to the predicate function of T + + Exp := + Make_Predicate_Call + (T, Convert_To (T, Make_Identifier (Loc, Object_Name))); + + -- Add call to evolving expression, using AND THEN if needed + + if No (Expr) then + Expr := Exp; + else + Expr := + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (Expr), + Right_Opnd => Exp); + end if; + + -- Output info message on inheritance if required. Note we do not + -- give this information for generic actual types, since it is + -- unwelcome noise in that case in instantiations. We also + -- generally suppress the message in instantiations, and also + -- if it involves internal names. + + if Opt.List_Inherited_Aspects + and then not Is_Generic_Actual_Type (Typ) + and then Instantiation_Depth (Sloc (Typ)) = 0 + and then not Is_Internal_Name (Chars (T)) + and then not Is_Internal_Name (Chars (Typ)) + then + Error_Msg_Sloc := Sloc (Predicate_Function (T)); + Error_Msg_Node_2 := T; + Error_Msg_N ("?info: & inherits predicate from & #", Typ); + end if; + end if; + end Add_Call; + + -------------------- + -- Add_Predicates -- + -------------------- + + procedure Add_Predicates is + Ritem : Node_Id; + Arg1 : Node_Id; + Arg2 : Node_Id; + + procedure Replace_Type_Reference (N : Node_Id); + -- Replace a single occurrence N of the subtype name with a reference + -- to the formal of the predicate function. N can be an identifier + -- referencing the subtype, or a selected component, representing an + -- appropriately qualified occurrence of the subtype name. + + procedure Replace_Type_References is + new Replace_Type_References_Generic (Replace_Type_Reference); + -- Traverse an expression changing every occurrence of an identifier + -- whose name matches the name of the subtype with a reference to + -- the formal parameter of the predicate function. + + ---------------------------- + -- Replace_Type_Reference -- + ---------------------------- + + procedure Replace_Type_Reference (N : Node_Id) is + begin + Rewrite (N, Make_Identifier (Loc, Object_Name)); + end Replace_Type_Reference; + + -- Start of processing for Add_Predicates + + begin + Ritem := First_Rep_Item (Typ); + while Present (Ritem) loop + if Nkind (Ritem) = N_Pragma + and then Pragma_Name (Ritem) = Name_Predicate + then + Arg1 := First (Pragma_Argument_Associations (Ritem)); + Arg2 := Next (Arg1); + + Arg1 := Get_Pragma_Arg (Arg1); + Arg2 := Get_Pragma_Arg (Arg2); + + -- See if this predicate pragma is for the current type + + if Entity (Arg1) = Typ then + + -- We have a match, this entry is for our subtype + + -- First We need to replace any occurrences of the name of + -- the type with references to the object. + + Replace_Type_References (Arg2, Chars (Typ)); + + -- OK, replacement complete, now we can add the expression + + if No (Expr) then + Expr := Relocate_Node (Arg2); + + -- There already was a predicate, so add to it + + else + Expr := + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (Expr), + Right_Opnd => Relocate_Node (Arg2)); + end if; + end if; + end if; + + Next_Rep_Item (Ritem); + end loop; + end Add_Predicates; + + -- Start of processing for Build_Predicate_Function + + begin + -- Initialize for construction of statement list + + Expr := Empty; + + -- Return if already built or if type does not have predicates + + if not Has_Predicates (Typ) + or else Present (Predicate_Function (Typ)) + then + return; + end if; + + -- Add Predicates for the current type + + Add_Predicates; + + -- Add predicates for ancestor if present + + declare + Atyp : constant Entity_Id := Nearest_Ancestor (Typ); + begin + if Present (Atyp) then + Add_Call (Atyp); + end if; + end; + + -- If we have predicates, build the function + + if Present (Expr) then + + -- Build function declaration + + pragma Assert (Has_Predicates (Typ)); + SId := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Predicate")); + Set_Has_Predicates (SId); + Set_Predicate_Function (Typ, SId); + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SId, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Object_Name), + Parameter_Type => New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + + FDecl := Make_Subprogram_Declaration (Loc, Specification => Spec); + + -- Build function body + + SId := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Predicate")); + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SId, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Object_Name), + Parameter_Type => + New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + + FBody := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => Expr)))); + + -- Insert declaration before freeze node and body after + + Insert_Before_And_Analyze (N, FDecl); + Insert_After_And_Analyze (N, FBody); + + -- Deal with static predicate case + + if Ekind_In (Typ, E_Enumeration_Subtype, + E_Modular_Integer_Subtype, + E_Signed_Integer_Subtype) + and then Is_Static_Subtype (Typ) + then + Build_Static_Predicate (Typ, Expr, Object_Name); + end if; + end if; + end Build_Predicate_Function; + + ---------------------------- + -- Build_Static_Predicate -- + ---------------------------- + + procedure Build_Static_Predicate + (Typ : Entity_Id; + Expr : Node_Id; + Nam : Name_Id) + is + Loc : constant Source_Ptr := Sloc (Expr); + + Non_Static : exception; + -- Raised if something non-static is found + + Btyp : constant Entity_Id := Base_Type (Typ); + + BLo : constant Uint := Expr_Value (Type_Low_Bound (Btyp)); + BHi : constant Uint := Expr_Value (Type_High_Bound (Btyp)); + -- Low bound and high bound value of base type of Typ + + TLo : constant Uint := Expr_Value (Type_Low_Bound (Typ)); + THi : constant Uint := Expr_Value (Type_High_Bound (Typ)); + -- Low bound and high bound values of static subtype Typ + + type REnt is record + Lo, Hi : Uint; + end record; + -- One entry in a Rlist value, a single REnt (range entry) value + -- denotes one range from Lo to Hi. To represent a single value + -- range Lo = Hi = value. + + type RList is array (Nat range <>) of REnt; + -- A list of ranges. The ranges are sorted in increasing order, + -- and are disjoint (there is a gap of at least one value between + -- each range in the table). A value is in the set of ranges in + -- Rlist if it lies within one of these ranges + + False_Range : constant RList := + RList'(1 .. 0 => REnt'(No_Uint, No_Uint)); + -- An empty set of ranges represents a range list that can never be + -- satisfied, since there are no ranges in which the value could lie, + -- so it does not lie in any of them. False_Range is a canonical value + -- for this empty set, but general processing should test for an Rlist + -- with length zero (see Is_False predicate), since other null ranges + -- may appear which must be treated as False. + + True_Range : constant RList := RList'(1 => REnt'(BLo, BHi)); + -- Range representing True, value must be in the base range + + function "and" (Left, Right : RList) return RList; + -- And's together two range lists, returning a range list. This is + -- a set intersection operation. + + function "or" (Left, Right : RList) return RList; + -- Or's together two range lists, returning a range list. This is a + -- set union operation. + + function "not" (Right : RList) return RList; + -- Returns complement of a given range list, i.e. a range list + -- representing all the values in TLo .. THi that are not in the + -- input operand Right. + + function Build_Val (V : Uint) return Node_Id; + -- Return an analyzed N_Identifier node referencing this value, suitable + -- for use as an entry in the Static_Predicate list. This node is typed + -- with the base type. + + function Build_Range (Lo, Hi : Uint) return Node_Id; + -- Return an analyzed N_Range node referencing this range, suitable + -- for use as an entry in the Static_Predicate list. This node is typed + -- with the base type. + + function Get_RList (Exp : Node_Id) return RList; + -- This is a recursive routine that converts the given expression into + -- a list of ranges, suitable for use in building the static predicate. + + function Is_False (R : RList) return Boolean; + pragma Inline (Is_False); + -- Returns True if the given range list is empty, and thus represents + -- a False list of ranges that can never be satisfied. + + function Is_True (R : RList) return Boolean; + -- Returns True if R trivially represents the True predicate by having + -- a single range from BLo to BHi. + + function Is_Type_Ref (N : Node_Id) return Boolean; + pragma Inline (Is_Type_Ref); + -- Returns if True if N is a reference to the type for the predicate in + -- the expression (i.e. if it is an identifier whose Chars field matches + -- the Nam given in the call). + + function Lo_Val (N : Node_Id) return Uint; + -- Given static expression or static range from a Static_Predicate list, + -- gets expression value or low bound of range. + + function Hi_Val (N : Node_Id) return Uint; + -- Given static expression or static range from a Static_Predicate list, + -- gets expression value of high bound of range. + + function Membership_Entry (N : Node_Id) return RList; + -- Given a single membership entry (range, value, or subtype), returns + -- the corresponding range list. Raises Static_Error if not static. + + function Membership_Entries (N : Node_Id) return RList; + -- Given an element on an alternatives list of a membership operation, + -- returns the range list corresponding to this entry and all following + -- entries (i.e. returns the "or" of this list of values). + + function Stat_Pred (Typ : Entity_Id) return RList; + -- Given a type, if it has a static predicate, then return the predicate + -- as a range list, otherwise raise Non_Static. + + ----------- + -- "and" -- + ----------- + + function "and" (Left, Right : RList) return RList is + FEnt : REnt; + -- First range of result + + SLeft : Nat := Left'First; + -- Start of rest of left entries + + SRight : Nat := Right'First; + -- Start of rest of right entries + + begin + -- If either range is True, return the other + + if Is_True (Left) then + return Right; + elsif Is_True (Right) then + return Left; + end if; + + -- If either range is False, return False + + if Is_False (Left) or else Is_False (Right) then + return False_Range; + end if; + + -- Loop to remove entries at start that are disjoint, and thus + -- just get discarded from the result entirely. + + loop + -- If no operands left in either operand, result is false + + if SLeft > Left'Last or else SRight > Right'Last then + return False_Range; + + -- Discard first left operand entry if disjoint with right + + elsif Left (SLeft).Hi < Right (SRight).Lo then + SLeft := SLeft + 1; + + -- Discard first right operand entry if disjoint with left + + elsif Right (SRight).Hi < Left (SLeft).Lo then + SRight := SRight + 1; + + -- Otherwise we have an overlapping entry + + else + exit; + end if; + end loop; + + -- Now we have two non-null operands, and first entries overlap. + -- The first entry in the result will be the overlapping part of + -- these two entries. + + FEnt := REnt'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo), + Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi)); + + -- Now we can remove the entry that ended at a lower value, since + -- its contribution is entirely contained in Fent. + + if Left (SLeft).Hi <= Right (SRight).Hi then + SLeft := SLeft + 1; + else + SRight := SRight + 1; + end if; + + -- Compute result by concatenating this first entry with the "and" + -- of the remaining parts of the left and right operands. Note that + -- if either of these is empty, "and" will yield empty, so that we + -- will end up with just Fent, which is what we want in that case. + + return + FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last)); + end "and"; + + ----------- + -- "not" -- + ----------- + + function "not" (Right : RList) return RList is + begin + -- Return True if False range + + if Is_False (Right) then + return True_Range; + end if; + + -- Return False if True range + + if Is_True (Right) then + return False_Range; + end if; + + -- Here if not trivial case + + declare + Result : RList (1 .. Right'Length + 1); + -- May need one more entry for gap at beginning and end + + Count : Nat := 0; + -- Number of entries stored in Result + + begin + -- Gap at start + + if Right (Right'First).Lo > TLo then + Count := Count + 1; + Result (Count) := REnt'(TLo, Right (Right'First).Lo - 1); + end if; + + -- Gaps between ranges + + for J in Right'First .. Right'Last - 1 loop + Count := Count + 1; + Result (Count) := + REnt'(Right (J).Hi + 1, Right (J + 1).Lo - 1); + end loop; + + -- Gap at end + + if Right (Right'Last).Hi < THi then + Count := Count + 1; + Result (Count) := REnt'(Right (Right'Last).Hi + 1, THi); + end if; + + return Result (1 .. Count); + end; + end "not"; + + ---------- + -- "or" -- + ---------- + + function "or" (Left, Right : RList) return RList is + FEnt : REnt; + -- First range of result + + SLeft : Nat := Left'First; + -- Start of rest of left entries + + SRight : Nat := Right'First; + -- Start of rest of right entries + + begin + -- If either range is True, return True + + if Is_True (Left) or else Is_True (Right) then + return True_Range; + end if; + + -- If either range is False (empty), return the other + + if Is_False (Left) then + return Right; + elsif Is_False (Right) then + return Left; + end if; + + -- Initialize result first entry from left or right operand + -- depending on which starts with the lower range. + + if Left (SLeft).Lo < Right (SRight).Lo then + FEnt := Left (SLeft); + SLeft := SLeft + 1; + else + FEnt := Right (SRight); + SRight := SRight + 1; + end if; + + -- This loop eats ranges from left and right operands that + -- are contiguous with the first range we are gathering. + + loop + -- Eat first entry in left operand if contiguous or + -- overlapped by gathered first operand of result. + + if SLeft <= Left'Last + and then Left (SLeft).Lo <= FEnt.Hi + 1 + then + FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi); + SLeft := SLeft + 1; + + -- Eat first entry in right operand if contiguous or + -- overlapped by gathered right operand of result. + + elsif SRight <= Right'Last + and then Right (SRight).Lo <= FEnt.Hi + 1 + then + FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi); + SRight := SRight + 1; + + -- All done if no more entries to eat! + + else + exit; + end if; + end loop; + + -- Obtain result as the first entry we just computed, concatenated + -- to the "or" of the remaining results (if one operand is empty, + -- this will just concatenate with the other + + return + FEnt & (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last)); + end "or"; + + ----------------- + -- Build_Range -- + ----------------- + + function Build_Range (Lo, Hi : Uint) return Node_Id is + Result : Node_Id; + begin + if Lo = Hi then + return Build_Val (Hi); + else + Result := + Make_Range (Loc, + Low_Bound => Build_Val (Lo), + High_Bound => Build_Val (Hi)); + Set_Etype (Result, Btyp); + Set_Analyzed (Result); + return Result; + end if; + end Build_Range; + + --------------- + -- Build_Val -- + --------------- + + function Build_Val (V : Uint) return Node_Id is + Result : Node_Id; + + begin + if Is_Enumeration_Type (Typ) then + Result := Get_Enum_Lit_From_Pos (Typ, V, Loc); + else + Result := Make_Integer_Literal (Loc, V); + end if; + + Set_Etype (Result, Btyp); + Set_Is_Static_Expression (Result); + Set_Analyzed (Result); + return Result; + end Build_Val; + + --------------- + -- Get_RList -- + --------------- + + function Get_RList (Exp : Node_Id) return RList is + Op : Node_Kind; + Val : Uint; + + begin + -- Static expression can only be true or false + + if Is_OK_Static_Expression (Exp) then + + -- For False + + if Expr_Value (Exp) = 0 then + return False_Range; + else + return True_Range; + end if; + end if; + + -- Otherwise test node type + + Op := Nkind (Exp); + + case Op is + + -- And + + when N_Op_And | N_And_Then => + return Get_RList (Left_Opnd (Exp)) + and + Get_RList (Right_Opnd (Exp)); + + -- Or + + when N_Op_Or | N_Or_Else => + return Get_RList (Left_Opnd (Exp)) + or + Get_RList (Right_Opnd (Exp)); + + -- Not + + when N_Op_Not => + return not Get_RList (Right_Opnd (Exp)); + + -- Comparisons of type with static value + + when N_Op_Compare => + -- Type is left operand + + if Is_Type_Ref (Left_Opnd (Exp)) + and then Is_OK_Static_Expression (Right_Opnd (Exp)) + then + Val := Expr_Value (Right_Opnd (Exp)); + + -- Typ is right operand + + elsif Is_Type_Ref (Right_Opnd (Exp)) + and then Is_OK_Static_Expression (Left_Opnd (Exp)) + then + Val := Expr_Value (Left_Opnd (Exp)); + + -- Invert sense of comparison + + case Op is + when N_Op_Gt => Op := N_Op_Lt; + when N_Op_Lt => Op := N_Op_Gt; + when N_Op_Ge => Op := N_Op_Le; + when N_Op_Le => Op := N_Op_Ge; + when others => null; + end case; + + -- Other cases are non-static + + else + raise Non_Static; + end if; + + -- Construct range according to comparison operation + + case Op is + when N_Op_Eq => + return RList'(1 => REnt'(Val, Val)); + + when N_Op_Ge => + return RList'(1 => REnt'(Val, BHi)); + + when N_Op_Gt => + return RList'(1 => REnt'(Val + 1, BHi)); + + when N_Op_Le => + return RList'(1 => REnt'(BLo, Val)); + + when N_Op_Lt => + return RList'(1 => REnt'(BLo, Val - 1)); + + when N_Op_Ne => + return RList'(REnt'(BLo, Val - 1), + REnt'(Val + 1, BHi)); + + when others => + raise Program_Error; + end case; + + -- Membership (IN) + + when N_In => + if not Is_Type_Ref (Left_Opnd (Exp)) then + raise Non_Static; + end if; + + if Present (Right_Opnd (Exp)) then + return Membership_Entry (Right_Opnd (Exp)); + else + return Membership_Entries (First (Alternatives (Exp))); + end if; + + -- Negative membership (NOT IN) + + when N_Not_In => + if not Is_Type_Ref (Left_Opnd (Exp)) then + raise Non_Static; + end if; + + if Present (Right_Opnd (Exp)) then + return not Membership_Entry (Right_Opnd (Exp)); + else + return not Membership_Entries (First (Alternatives (Exp))); + end if; + + -- Function call, may be call to static predicate + + when N_Function_Call => + if Is_Entity_Name (Name (Exp)) then + declare + Ent : constant Entity_Id := Entity (Name (Exp)); + begin + if Has_Predicates (Ent) then + return Stat_Pred (Etype (First_Formal (Ent))); + end if; + end; + end if; + + -- Other function call cases are non-static + + raise Non_Static; + + -- Qualified expression, dig out the expression + + when N_Qualified_Expression => + return Get_RList (Expression (Exp)); + + -- Xor operator + + when N_Op_Xor => + return (Get_RList (Left_Opnd (Exp)) + and not Get_RList (Right_Opnd (Exp))) + or (Get_RList (Right_Opnd (Exp)) + and not Get_RList (Left_Opnd (Exp))); + + -- Any other node type is non-static + + when others => + raise Non_Static; + end case; + end Get_RList; + + ------------ + -- Hi_Val -- + ------------ + + function Hi_Val (N : Node_Id) return Uint is + begin + if Is_Static_Expression (N) then + return Expr_Value (N); + else + pragma Assert (Nkind (N) = N_Range); + return Expr_Value (High_Bound (N)); + end if; + end Hi_Val; + + -------------- + -- Is_False -- + -------------- + + function Is_False (R : RList) return Boolean is + begin + return R'Length = 0; + end Is_False; + + ------------- + -- Is_True -- + ------------- + + function Is_True (R : RList) return Boolean is + begin + return R'Length = 1 + and then R (R'First).Lo = BLo + and then R (R'First).Hi = BHi; + end Is_True; + + ----------------- + -- Is_Type_Ref -- + ----------------- + + function Is_Type_Ref (N : Node_Id) return Boolean is + begin + return Nkind (N) = N_Identifier and then Chars (N) = Nam; + end Is_Type_Ref; + + ------------ + -- Lo_Val -- + ------------ + + function Lo_Val (N : Node_Id) return Uint is + begin + if Is_Static_Expression (N) then + return Expr_Value (N); + else + pragma Assert (Nkind (N) = N_Range); + return Expr_Value (Low_Bound (N)); + end if; + end Lo_Val; + + ------------------------ + -- Membership_Entries -- + ------------------------ + + function Membership_Entries (N : Node_Id) return RList is + begin + if No (Next (N)) then + return Membership_Entry (N); + else + return Membership_Entry (N) or Membership_Entries (Next (N)); + end if; + end Membership_Entries; + + ---------------------- + -- Membership_Entry -- + ---------------------- + + function Membership_Entry (N : Node_Id) return RList is + Val : Uint; + SLo : Uint; + SHi : Uint; + + begin + -- Range case + + if Nkind (N) = N_Range then + if not Is_Static_Expression (Low_Bound (N)) + or else + not Is_Static_Expression (High_Bound (N)) + then + raise Non_Static; + else + SLo := Expr_Value (Low_Bound (N)); + SHi := Expr_Value (High_Bound (N)); + return RList'(1 => REnt'(SLo, SHi)); + end if; + + -- Static expression case + + elsif Is_Static_Expression (N) then + Val := Expr_Value (N); + return RList'(1 => REnt'(Val, Val)); + + -- Identifier (other than static expression) case + + else pragma Assert (Nkind (N) = N_Identifier); + + -- Type case + + if Is_Type (Entity (N)) then + + -- If type has predicates, process them + + if Has_Predicates (Entity (N)) then + return Stat_Pred (Entity (N)); + + -- For static subtype without predicates, get range + + elsif Is_Static_Subtype (Entity (N)) then + SLo := Expr_Value (Type_Low_Bound (Entity (N))); + SHi := Expr_Value (Type_High_Bound (Entity (N))); + return RList'(1 => REnt'(SLo, SHi)); + + -- Any other type makes us non-static + + else + raise Non_Static; + end if; + + -- Any other kind of identifier in predicate (e.g. a non-static + -- expression value) means this is not a static predicate. + + else + raise Non_Static; + end if; + end if; + end Membership_Entry; + + --------------- + -- Stat_Pred -- + --------------- + + function Stat_Pred (Typ : Entity_Id) return RList is + begin + -- Not static if type does not have static predicates + + if not Has_Predicates (Typ) + or else No (Static_Predicate (Typ)) + then + raise Non_Static; + end if; + + -- Otherwise we convert the predicate list to a range list + + declare + Result : RList (1 .. List_Length (Static_Predicate (Typ))); + P : Node_Id; + + begin + P := First (Static_Predicate (Typ)); + for J in Result'Range loop + Result (J) := REnt'(Lo_Val (P), Hi_Val (P)); + Next (P); + end loop; + + return Result; + end; + end Stat_Pred; + + -- Start of processing for Build_Static_Predicate + + begin + -- Now analyze the expression to see if it is a static predicate + + declare + Ranges : constant RList := Get_RList (Expr); + -- Range list from expression if it is static + + Plist : List_Id; + + begin + -- Convert range list into a form for the static predicate. In the + -- Ranges array, we just have raw ranges, these must be converted + -- to properly typed and analyzed static expressions or range nodes. + + -- Note: here we limit ranges to the ranges of the subtype, so that + -- a predicate is always false for values outside the subtype. That + -- seems fine, such values are invalid anyway, and considering them + -- to fail the predicate seems allowed and friendly, and furthermore + -- simplifies processing for case statements and loops. + + Plist := New_List; + + for J in Ranges'Range loop + declare + Lo : Uint := Ranges (J).Lo; + Hi : Uint := Ranges (J).Hi; + + begin + -- Ignore completely out of range entry + + if Hi < TLo or else Lo > THi then + null; + + -- Otherwise process entry + + else + -- Adjust out of range value to subtype range + + if Lo < TLo then + Lo := TLo; + end if; + + if Hi > THi then + Hi := THi; + end if; + + -- Convert range into required form + + if Lo = Hi then + Append_To (Plist, Build_Val (Lo)); + else + Append_To (Plist, Build_Range (Lo, Hi)); + end if; + end if; + end; + end loop; + + -- Processing was successful and all entries were static, so now we + -- can store the result as the predicate list. + + Set_Static_Predicate (Typ, Plist); + + -- The processing for static predicates put the expression into + -- canonical form as a series of ranges. It also eliminated + -- duplicates and collapsed and combined ranges. We might as well + -- replace the alternatives list of the right operand of the + -- membership test with the static predicate list, which will + -- usually be more efficient. + + declare + New_Alts : constant List_Id := New_List; + Old_Node : Node_Id; + New_Node : Node_Id; + + begin + Old_Node := First (Plist); + while Present (Old_Node) loop + New_Node := New_Copy (Old_Node); + + if Nkind (New_Node) = N_Range then + Set_Low_Bound (New_Node, New_Copy (Low_Bound (Old_Node))); + Set_High_Bound (New_Node, New_Copy (High_Bound (Old_Node))); + end if; + + Append_To (New_Alts, New_Node); + Next (Old_Node); + end loop; + + -- If empty list, replace by False + + if Is_Empty_List (New_Alts) then + Rewrite (Expr, New_Occurrence_Of (Standard_False, Loc)); + + -- Else replace by set membership test + + else + Rewrite (Expr, + Make_In (Loc, + Left_Opnd => Make_Identifier (Loc, Nam), + Right_Opnd => Empty, + Alternatives => New_Alts)); + + -- Resolve new expression in function context + + Install_Formals (Predicate_Function (Typ)); + Push_Scope (Predicate_Function (Typ)); + Analyze_And_Resolve (Expr, Standard_Boolean); + Pop_Scope; + end if; + end; + end; + + -- If non-static, return doing nothing + + exception + when Non_Static => + return; + end Build_Static_Predicate; + + ----------------------------------- + -- Check_Constant_Address_Clause -- + ----------------------------------- + + procedure Check_Constant_Address_Clause + (Expr : Node_Id; + U_Ent : Entity_Id) + is + procedure Check_At_Constant_Address (Nod : Node_Id); + -- Checks that the given node N represents a name whose 'Address is + -- constant (in the same sense as OK_Constant_Address_Clause, i.e. the + -- address value is the same at the point of declaration of U_Ent and at + -- the time of elaboration of the address clause. + + procedure Check_Expr_Constants (Nod : Node_Id); + -- Checks that Nod meets the requirements for a constant address clause + -- in the sense of the enclosing procedure. + + procedure Check_List_Constants (Lst : List_Id); + -- Check that all elements of list Lst meet the requirements for a + -- constant address clause in the sense of the enclosing procedure. + + ------------------------------- + -- Check_At_Constant_Address -- + ------------------------------- + + procedure Check_At_Constant_Address (Nod : Node_Id) is + begin + if Is_Entity_Name (Nod) then + if Present (Address_Clause (Entity ((Nod)))) then + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + Error_Msg_NE + ("address for& cannot" & + " depend on another address clause! (RM 13.1(22))!", + Nod, U_Ent); + + elsif In_Same_Source_Unit (Entity (Nod), U_Ent) + and then Sloc (U_Ent) < Sloc (Entity (Nod)) + then + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + Error_Msg_Node_2 := U_Ent; + Error_Msg_NE + ("\& must be defined before & (RM 13.1(22))!", + Nod, Entity (Nod)); + end if; + + elsif Nkind (Nod) = N_Selected_Component then + declare + T : constant Entity_Id := Etype (Prefix (Nod)); + + begin + if (Is_Record_Type (T) + and then Has_Discriminants (T)) + or else + (Is_Access_Type (T) + and then Is_Record_Type (Designated_Type (T)) + and then Has_Discriminants (Designated_Type (T))) + then + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + Error_Msg_N + ("\address cannot depend on component" & + " of discriminated record (RM 13.1(22))!", + Nod); + else + Check_At_Constant_Address (Prefix (Nod)); + end if; + end; + + elsif Nkind (Nod) = N_Indexed_Component then + Check_At_Constant_Address (Prefix (Nod)); + Check_List_Constants (Expressions (Nod)); + + else + Check_Expr_Constants (Nod); + end if; + end Check_At_Constant_Address; + + -------------------------- + -- Check_Expr_Constants -- + -------------------------- + + procedure Check_Expr_Constants (Nod : Node_Id) is + Loc_U_Ent : constant Source_Ptr := Sloc (U_Ent); + Ent : Entity_Id := Empty; + + begin + if Nkind (Nod) in N_Has_Etype + and then Etype (Nod) = Any_Type + then + return; + end if; + + case Nkind (Nod) is + when N_Empty | N_Error => + return; + + when N_Identifier | N_Expanded_Name => + Ent := Entity (Nod); + + -- We need to look at the original node if it is different + -- from the node, since we may have rewritten things and + -- substituted an identifier representing the rewrite. + + if Original_Node (Nod) /= Nod then + Check_Expr_Constants (Original_Node (Nod)); + + -- If the node is an object declaration without initial + -- value, some code has been expanded, and the expression + -- is not constant, even if the constituents might be + -- acceptable, as in A'Address + offset. + + if Ekind (Ent) = E_Variable + and then + Nkind (Declaration_Node (Ent)) = N_Object_Declaration + and then + No (Expression (Declaration_Node (Ent))) + then + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + + -- If entity is constant, it may be the result of expanding + -- a check. We must verify that its declaration appears + -- before the object in question, else we also reject the + -- address clause. + + elsif Ekind (Ent) = E_Constant + and then In_Same_Source_Unit (Ent, U_Ent) + and then Sloc (Ent) > Loc_U_Ent + then + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + end if; + + return; + end if; + + -- Otherwise look at the identifier and see if it is OK + + if Ekind_In (Ent, E_Named_Integer, E_Named_Real) + or else Is_Type (Ent) + then + return; + + elsif + Ekind (Ent) = E_Constant + or else + Ekind (Ent) = E_In_Parameter + then + -- This is the case where we must have Ent defined before + -- U_Ent. Clearly if they are in different units this + -- requirement is met since the unit containing Ent is + -- already processed. + + if not In_Same_Source_Unit (Ent, U_Ent) then + return; + + -- Otherwise location of Ent must be before the location + -- of U_Ent, that's what prior defined means. + + elsif Sloc (Ent) < Loc_U_Ent then + return; + + else + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + Error_Msg_Node_2 := U_Ent; + Error_Msg_NE + ("\& must be defined before & (RM 13.1(22))!", + Nod, Ent); + end if; + + elsif Nkind (Original_Node (Nod)) = N_Function_Call then + Check_Expr_Constants (Original_Node (Nod)); + + else + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + + if Comes_From_Source (Ent) then + Error_Msg_NE + ("\reference to variable& not allowed" + & " (RM 13.1(22))!", Nod, Ent); + else + Error_Msg_N + ("non-static expression not allowed" + & " (RM 13.1(22))!", Nod); + end if; + end if; + + when N_Integer_Literal => + + -- If this is a rewritten unchecked conversion, in a system + -- where Address is an integer type, always use the base type + -- for a literal value. This is user-friendly and prevents + -- order-of-elaboration issues with instances of unchecked + -- conversion. + + if Nkind (Original_Node (Nod)) = N_Function_Call then + Set_Etype (Nod, Base_Type (Etype (Nod))); + end if; + + when N_Real_Literal | + N_String_Literal | + N_Character_Literal => + return; + + when N_Range => + Check_Expr_Constants (Low_Bound (Nod)); + Check_Expr_Constants (High_Bound (Nod)); + + when N_Explicit_Dereference => + Check_Expr_Constants (Prefix (Nod)); + + when N_Indexed_Component => + Check_Expr_Constants (Prefix (Nod)); + Check_List_Constants (Expressions (Nod)); + + when N_Slice => + Check_Expr_Constants (Prefix (Nod)); + Check_Expr_Constants (Discrete_Range (Nod)); + + when N_Selected_Component => + Check_Expr_Constants (Prefix (Nod)); + + when N_Attribute_Reference => + if Attribute_Name (Nod) = Name_Address + or else + Attribute_Name (Nod) = Name_Access + or else + Attribute_Name (Nod) = Name_Unchecked_Access + or else + Attribute_Name (Nod) = Name_Unrestricted_Access + then + Check_At_Constant_Address (Prefix (Nod)); + + else + Check_Expr_Constants (Prefix (Nod)); + Check_List_Constants (Expressions (Nod)); + end if; + + when N_Aggregate => + Check_List_Constants (Component_Associations (Nod)); + Check_List_Constants (Expressions (Nod)); + + when N_Component_Association => + Check_Expr_Constants (Expression (Nod)); + + when N_Extension_Aggregate => + Check_Expr_Constants (Ancestor_Part (Nod)); + Check_List_Constants (Component_Associations (Nod)); + Check_List_Constants (Expressions (Nod)); + + when N_Null => + return; + + when N_Binary_Op | N_Short_Circuit | N_Membership_Test => + Check_Expr_Constants (Left_Opnd (Nod)); + Check_Expr_Constants (Right_Opnd (Nod)); + + when N_Unary_Op => + Check_Expr_Constants (Right_Opnd (Nod)); + + when N_Type_Conversion | + N_Qualified_Expression | + N_Allocator => + Check_Expr_Constants (Expression (Nod)); + + when N_Unchecked_Type_Conversion => + Check_Expr_Constants (Expression (Nod)); + + -- If this is a rewritten unchecked conversion, subtypes in + -- this node are those created within the instance. To avoid + -- order of elaboration issues, replace them with their base + -- types. Note that address clauses can cause order of + -- elaboration problems because they are elaborated by the + -- back-end at the point of definition, and may mention + -- entities declared in between (as long as everything is + -- static). It is user-friendly to allow unchecked conversions + -- in this context. + + if Nkind (Original_Node (Nod)) = N_Function_Call then + Set_Etype (Expression (Nod), + Base_Type (Etype (Expression (Nod)))); + Set_Etype (Nod, Base_Type (Etype (Nod))); + end if; + + when N_Function_Call => + if not Is_Pure (Entity (Name (Nod))) then + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + + Error_Msg_NE + ("\function & is not pure (RM 13.1(22))!", + Nod, Entity (Name (Nod))); + + else + Check_List_Constants (Parameter_Associations (Nod)); + end if; + + when N_Parameter_Association => + Check_Expr_Constants (Explicit_Actual_Parameter (Nod)); + + when others => + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + Error_Msg_NE + ("\must be constant defined before& (RM 13.1(22))!", + Nod, U_Ent); + end case; + end Check_Expr_Constants; + + -------------------------- + -- Check_List_Constants -- + -------------------------- + + procedure Check_List_Constants (Lst : List_Id) is + Nod1 : Node_Id; + + begin + if Present (Lst) then + Nod1 := First (Lst); + while Present (Nod1) loop + Check_Expr_Constants (Nod1); + Next (Nod1); + end loop; + end if; + end Check_List_Constants; + + -- Start of processing for Check_Constant_Address_Clause + + begin + -- If rep_clauses are to be ignored, no need for legality checks. In + -- particular, no need to pester user about rep clauses that violate + -- the rule on constant addresses, given that these clauses will be + -- removed by Freeze before they reach the back end. + + if not Ignore_Rep_Clauses then + Check_Expr_Constants (Expr); + end if; + end Check_Constant_Address_Clause; + + ---------------------------------------- + -- Check_Record_Representation_Clause -- + ---------------------------------------- + + procedure Check_Record_Representation_Clause (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ident : constant Node_Id := Identifier (N); + Rectype : Entity_Id; + Fent : Entity_Id; + CC : Node_Id; + Fbit : Uint; + Lbit : Uint; + Hbit : Uint := Uint_0; + Comp : Entity_Id; + Pcomp : Entity_Id; + + Max_Bit_So_Far : Uint; + -- Records the maximum bit position so far. If all field positions + -- are monotonically increasing, then we can skip the circuit for + -- checking for overlap, since no overlap is possible. + + Tagged_Parent : Entity_Id := Empty; + -- This is set in the case of a derived tagged type for which we have + -- Is_Fully_Repped_Tagged_Type True (indicating that all components are + -- positioned by record representation clauses). In this case we must + -- check for overlap between components of this tagged type, and the + -- components of its parent. Tagged_Parent will point to this parent + -- type. For all other cases Tagged_Parent is left set to Empty. + + Parent_Last_Bit : Uint; + -- Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the + -- last bit position for any field in the parent type. We only need to + -- check overlap for fields starting below this point. + + Overlap_Check_Required : Boolean; + -- Used to keep track of whether or not an overlap check is required + + Overlap_Detected : Boolean := False; + -- Set True if an overlap is detected + + Ccount : Natural := 0; + -- Number of component clauses in record rep clause + + procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id); + -- Given two entities for record components or discriminants, checks + -- if they have overlapping component clauses and issues errors if so. + + procedure Find_Component; + -- Finds component entity corresponding to current component clause (in + -- CC), and sets Comp to the entity, and Fbit/Lbit to the zero origin + -- start/stop bits for the field. If there is no matching component or + -- if the matching component does not have a component clause, then + -- that's an error and Comp is set to Empty, but no error message is + -- issued, since the message was already given. Comp is also set to + -- Empty if the current "component clause" is in fact a pragma. + + ----------------------------- + -- Check_Component_Overlap -- + ----------------------------- + + procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is + CC1 : constant Node_Id := Component_Clause (C1_Ent); + CC2 : constant Node_Id := Component_Clause (C2_Ent); + + begin + if Present (CC1) and then Present (CC2) then + + -- Exclude odd case where we have two tag fields in the same + -- record, both at location zero. This seems a bit strange, but + -- it seems to happen in some circumstances, perhaps on an error. + + if Chars (C1_Ent) = Name_uTag + and then + Chars (C2_Ent) = Name_uTag + then + return; + end if; + + -- Here we check if the two fields overlap + + declare + S1 : constant Uint := Component_Bit_Offset (C1_Ent); + S2 : constant Uint := Component_Bit_Offset (C2_Ent); + E1 : constant Uint := S1 + Esize (C1_Ent); + E2 : constant Uint := S2 + Esize (C2_Ent); + + begin + if E2 <= S1 or else E1 <= S2 then + null; + else + Error_Msg_Node_2 := Component_Name (CC2); + Error_Msg_Sloc := Sloc (Error_Msg_Node_2); + Error_Msg_Node_1 := Component_Name (CC1); + Error_Msg_N + ("component& overlaps & #", Component_Name (CC1)); + Overlap_Detected := True; + end if; + end; + end if; + end Check_Component_Overlap; + + -------------------- + -- Find_Component -- + -------------------- + + procedure Find_Component is + + procedure Search_Component (R : Entity_Id); + -- Search components of R for a match. If found, Comp is set. + + ---------------------- + -- Search_Component -- + ---------------------- + + procedure Search_Component (R : Entity_Id) is + begin + Comp := First_Component_Or_Discriminant (R); + while Present (Comp) loop + + -- Ignore error of attribute name for component name (we + -- already gave an error message for this, so no need to + -- complain here) + + if Nkind (Component_Name (CC)) = N_Attribute_Reference then + null; + else + exit when Chars (Comp) = Chars (Component_Name (CC)); + end if; + + Next_Component_Or_Discriminant (Comp); + end loop; + end Search_Component; + + -- Start of processing for Find_Component + + begin + -- Return with Comp set to Empty if we have a pragma + + if Nkind (CC) = N_Pragma then + Comp := Empty; + return; + end if; + + -- Search current record for matching component + + Search_Component (Rectype); + + -- If not found, maybe component of base type that is absent from + -- statically constrained first subtype. + + if No (Comp) then + Search_Component (Base_Type (Rectype)); + end if; + + -- If no component, or the component does not reference the component + -- clause in question, then there was some previous error for which + -- we already gave a message, so just return with Comp Empty. + + if No (Comp) + or else Component_Clause (Comp) /= CC + then + Comp := Empty; + + -- Normal case where we have a component clause + + else + Fbit := Component_Bit_Offset (Comp); + Lbit := Fbit + Esize (Comp) - 1; + end if; + end Find_Component; + + -- Start of processing for Check_Record_Representation_Clause + + begin + Find_Type (Ident); + Rectype := Entity (Ident); + + if Rectype = Any_Type then + return; + else + Rectype := Underlying_Type (Rectype); + end if; + + -- See if we have a fully repped derived tagged type + + declare + PS : constant Entity_Id := Parent_Subtype (Rectype); + + begin + if Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then + Tagged_Parent := PS; + + -- Find maximum bit of any component of the parent type + + Parent_Last_Bit := UI_From_Int (System_Address_Size - 1); + Pcomp := First_Entity (Tagged_Parent); + while Present (Pcomp) loop + if Ekind_In (Pcomp, E_Discriminant, E_Component) then + if Component_Bit_Offset (Pcomp) /= No_Uint + and then Known_Static_Esize (Pcomp) + then + Parent_Last_Bit := + UI_Max + (Parent_Last_Bit, + Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1); + end if; + + Next_Entity (Pcomp); + end if; + end loop; + end if; + end; + + -- All done if no component clauses + + CC := First (Component_Clauses (N)); + + if No (CC) then + return; + end if; + + -- If a tag is present, then create a component clause that places it + -- at the start of the record (otherwise gigi may place it after other + -- fields that have rep clauses). + + Fent := First_Entity (Rectype); + + if Nkind (Fent) = N_Defining_Identifier + and then Chars (Fent) = Name_uTag + then + Set_Component_Bit_Offset (Fent, Uint_0); + Set_Normalized_Position (Fent, Uint_0); + Set_Normalized_First_Bit (Fent, Uint_0); + Set_Normalized_Position_Max (Fent, Uint_0); + Init_Esize (Fent, System_Address_Size); + + Set_Component_Clause (Fent, + Make_Component_Clause (Loc, + Component_Name => Make_Identifier (Loc, Name_uTag), + + Position => Make_Integer_Literal (Loc, Uint_0), + First_Bit => Make_Integer_Literal (Loc, Uint_0), + Last_Bit => + Make_Integer_Literal (Loc, + UI_From_Int (System_Address_Size)))); + + Ccount := Ccount + 1; + end if; + + Max_Bit_So_Far := Uint_Minus_1; + Overlap_Check_Required := False; + + -- Process the component clauses + + while Present (CC) loop + Find_Component; + + if Present (Comp) then + Ccount := Ccount + 1; + + -- We need a full overlap check if record positions non-monotonic + + if Fbit <= Max_Bit_So_Far then + Overlap_Check_Required := True; + end if; + + Max_Bit_So_Far := Lbit; + + -- Check bit position out of range of specified size + + if Has_Size_Clause (Rectype) + and then Esize (Rectype) <= Lbit + then + Error_Msg_N + ("bit number out of range of specified size", + Last_Bit (CC)); + + -- Check for overlap with tag field + + else + if Is_Tagged_Type (Rectype) + and then Fbit < System_Address_Size + then + Error_Msg_NE + ("component overlaps tag field of&", + Component_Name (CC), Rectype); + Overlap_Detected := True; + end if; + + if Hbit < Lbit then + Hbit := Lbit; + end if; + end if; + + -- Check parent overlap if component might overlap parent field + + if Present (Tagged_Parent) + and then Fbit <= Parent_Last_Bit + then + Pcomp := First_Component_Or_Discriminant (Tagged_Parent); + while Present (Pcomp) loop + if not Is_Tag (Pcomp) + and then Chars (Pcomp) /= Name_uParent + then + Check_Component_Overlap (Comp, Pcomp); + end if; + + Next_Component_Or_Discriminant (Pcomp); + end loop; + end if; + end if; + + Next (CC); + end loop; + + -- Now that we have processed all the component clauses, check for + -- overlap. We have to leave this till last, since the components can + -- appear in any arbitrary order in the representation clause. + + -- We do not need this check if all specified ranges were monotonic, + -- as recorded by Overlap_Check_Required being False at this stage. + + -- This first section checks if there are any overlapping entries at + -- all. It does this by sorting all entries and then seeing if there are + -- any overlaps. If there are none, then that is decisive, but if there + -- are overlaps, they may still be OK (they may result from fields in + -- different variants). + + if Overlap_Check_Required then + Overlap_Check1 : declare + + OC_Fbit : array (0 .. Ccount) of Uint; + -- First-bit values for component clauses, the value is the offset + -- of the first bit of the field from start of record. The zero + -- entry is for use in sorting. + + OC_Lbit : array (0 .. Ccount) of Uint; + -- Last-bit values for component clauses, the value is the offset + -- of the last bit of the field from start of record. The zero + -- entry is for use in sorting. + + OC_Count : Natural := 0; + -- Count of entries in OC_Fbit and OC_Lbit + + function OC_Lt (Op1, Op2 : Natural) return Boolean; + -- Compare routine for Sort + + procedure OC_Move (From : Natural; To : Natural); + -- Move routine for Sort + + package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt); + + ----------- + -- OC_Lt -- + ----------- + + function OC_Lt (Op1, Op2 : Natural) return Boolean is + begin + return OC_Fbit (Op1) < OC_Fbit (Op2); + end OC_Lt; + + ------------- + -- OC_Move -- + ------------- + + procedure OC_Move (From : Natural; To : Natural) is + begin + OC_Fbit (To) := OC_Fbit (From); + OC_Lbit (To) := OC_Lbit (From); + end OC_Move; + + -- Start of processing for Overlap_Check + + begin + CC := First (Component_Clauses (N)); + while Present (CC) loop + + -- Exclude component clause already marked in error + + if not Error_Posted (CC) then + Find_Component; + + if Present (Comp) then + OC_Count := OC_Count + 1; + OC_Fbit (OC_Count) := Fbit; + OC_Lbit (OC_Count) := Lbit; + end if; + end if; + + Next (CC); + end loop; + + Sorting.Sort (OC_Count); + + Overlap_Check_Required := False; + for J in 1 .. OC_Count - 1 loop + if OC_Lbit (J) >= OC_Fbit (J + 1) then + Overlap_Check_Required := True; + exit; + end if; + end loop; + end Overlap_Check1; + end if; + + -- If Overlap_Check_Required is still True, then we have to do the full + -- scale overlap check, since we have at least two fields that do + -- overlap, and we need to know if that is OK since they are in + -- different variant, or whether we have a definite problem. + + if Overlap_Check_Required then + Overlap_Check2 : declare + C1_Ent, C2_Ent : Entity_Id; + -- Entities of components being checked for overlap + + Clist : Node_Id; + -- Component_List node whose Component_Items are being checked + + Citem : Node_Id; + -- Component declaration for component being checked + + begin + C1_Ent := First_Entity (Base_Type (Rectype)); + + -- Loop through all components in record. For each component check + -- for overlap with any of the preceding elements on the component + -- list containing the component and also, if the component is in + -- a variant, check against components outside the case structure. + -- This latter test is repeated recursively up the variant tree. + + Main_Component_Loop : while Present (C1_Ent) loop + if not Ekind_In (C1_Ent, E_Component, E_Discriminant) then + goto Continue_Main_Component_Loop; + end if; + + -- Skip overlap check if entity has no declaration node. This + -- happens with discriminants in constrained derived types. + -- Possibly we are missing some checks as a result, but that + -- does not seem terribly serious. + + if No (Declaration_Node (C1_Ent)) then + goto Continue_Main_Component_Loop; + end if; + + Clist := Parent (List_Containing (Declaration_Node (C1_Ent))); + + -- Loop through component lists that need checking. Check the + -- current component list and all lists in variants above us. + + Component_List_Loop : loop + + -- If derived type definition, go to full declaration + -- If at outer level, check discriminants if there are any. + + if Nkind (Clist) = N_Derived_Type_Definition then + Clist := Parent (Clist); + end if; + + -- Outer level of record definition, check discriminants + + if Nkind_In (Clist, N_Full_Type_Declaration, + N_Private_Type_Declaration) + then + if Has_Discriminants (Defining_Identifier (Clist)) then + C2_Ent := + First_Discriminant (Defining_Identifier (Clist)); + while Present (C2_Ent) loop + exit when C1_Ent = C2_Ent; + Check_Component_Overlap (C1_Ent, C2_Ent); + Next_Discriminant (C2_Ent); + end loop; + end if; + + -- Record extension case + + elsif Nkind (Clist) = N_Derived_Type_Definition then + Clist := Empty; + + -- Otherwise check one component list + + else + Citem := First (Component_Items (Clist)); + while Present (Citem) loop + if Nkind (Citem) = N_Component_Declaration then + C2_Ent := Defining_Identifier (Citem); + exit when C1_Ent = C2_Ent; + Check_Component_Overlap (C1_Ent, C2_Ent); + end if; + + Next (Citem); + end loop; + end if; + + -- Check for variants above us (the parent of the Clist can + -- be a variant, in which case its parent is a variant part, + -- and the parent of the variant part is a component list + -- whose components must all be checked against the current + -- component for overlap). + + if Nkind (Parent (Clist)) = N_Variant then + Clist := Parent (Parent (Parent (Clist))); + + -- Check for possible discriminant part in record, this + -- is treated essentially as another level in the + -- recursion. For this case the parent of the component + -- list is the record definition, and its parent is the + -- full type declaration containing the discriminant + -- specifications. + + elsif Nkind (Parent (Clist)) = N_Record_Definition then + Clist := Parent (Parent ((Clist))); + + -- If neither of these two cases, we are at the top of + -- the tree. + + else + exit Component_List_Loop; + end if; + end loop Component_List_Loop; + + <> + Next_Entity (C1_Ent); + + end loop Main_Component_Loop; + end Overlap_Check2; + end if; + + -- The following circuit deals with warning on record holes (gaps). We + -- skip this check if overlap was detected, since it makes sense for the + -- programmer to fix this illegality before worrying about warnings. + + if not Overlap_Detected and Warn_On_Record_Holes then + Record_Hole_Check : declare + Decl : constant Node_Id := Declaration_Node (Base_Type (Rectype)); + -- Full declaration of record type + + procedure Check_Component_List + (CL : Node_Id; + Sbit : Uint; + DS : List_Id); + -- Check component list CL for holes. The starting bit should be + -- Sbit. which is zero for the main record component list and set + -- appropriately for recursive calls for variants. DS is set to + -- a list of discriminant specifications to be included in the + -- consideration of components. It is No_List if none to consider. + + -------------------------- + -- Check_Component_List -- + -------------------------- + + procedure Check_Component_List + (CL : Node_Id; + Sbit : Uint; + DS : List_Id) + is + Compl : Integer; + + begin + Compl := Integer (List_Length (Component_Items (CL))); + + if DS /= No_List then + Compl := Compl + Integer (List_Length (DS)); + end if; + + declare + Comps : array (Natural range 0 .. Compl) of Entity_Id; + -- Gather components (zero entry is for sort routine) + + Ncomps : Natural := 0; + -- Number of entries stored in Comps (starting at Comps (1)) + + Citem : Node_Id; + -- One component item or discriminant specification + + Nbit : Uint; + -- Starting bit for next component + + CEnt : Entity_Id; + -- Component entity + + Variant : Node_Id; + -- One variant + + function Lt (Op1, Op2 : Natural) return Boolean; + -- Compare routine for Sort + + procedure Move (From : Natural; To : Natural); + -- Move routine for Sort + + package Sorting is new GNAT.Heap_Sort_G (Move, Lt); + + -------- + -- Lt -- + -------- + + function Lt (Op1, Op2 : Natural) return Boolean is + begin + return Component_Bit_Offset (Comps (Op1)) + < + Component_Bit_Offset (Comps (Op2)); + end Lt; + + ---------- + -- Move -- + ---------- + + procedure Move (From : Natural; To : Natural) is + begin + Comps (To) := Comps (From); + end Move; + + begin + -- Gather discriminants into Comp + + if DS /= No_List then + Citem := First (DS); + while Present (Citem) loop + if Nkind (Citem) = N_Discriminant_Specification then + declare + Ent : constant Entity_Id := + Defining_Identifier (Citem); + begin + if Ekind (Ent) = E_Discriminant then + Ncomps := Ncomps + 1; + Comps (Ncomps) := Ent; + end if; + end; + end if; + + Next (Citem); + end loop; + end if; + + -- Gather component entities into Comp + + Citem := First (Component_Items (CL)); + while Present (Citem) loop + if Nkind (Citem) = N_Component_Declaration then + Ncomps := Ncomps + 1; + Comps (Ncomps) := Defining_Identifier (Citem); + end if; + + Next (Citem); + end loop; + + -- Now sort the component entities based on the first bit. + -- Note we already know there are no overlapping components. + + Sorting.Sort (Ncomps); + + -- Loop through entries checking for holes + + Nbit := Sbit; + for J in 1 .. Ncomps loop + CEnt := Comps (J); + Error_Msg_Uint_1 := Component_Bit_Offset (CEnt) - Nbit; + + if Error_Msg_Uint_1 > 0 then + Error_Msg_NE + ("?^-bit gap before component&", + Component_Name (Component_Clause (CEnt)), CEnt); + end if; + + Nbit := Component_Bit_Offset (CEnt) + Esize (CEnt); + end loop; + + -- Process variant parts recursively if present + + if Present (Variant_Part (CL)) then + Variant := First (Variants (Variant_Part (CL))); + while Present (Variant) loop + Check_Component_List + (Component_List (Variant), Nbit, No_List); + Next (Variant); + end loop; + end if; + end; + end Check_Component_List; + + -- Start of processing for Record_Hole_Check + + begin + declare + Sbit : Uint; + + begin + if Is_Tagged_Type (Rectype) then + Sbit := UI_From_Int (System_Address_Size); + else + Sbit := Uint_0; + end if; + + if Nkind (Decl) = N_Full_Type_Declaration + and then Nkind (Type_Definition (Decl)) = N_Record_Definition + then + Check_Component_List + (Component_List (Type_Definition (Decl)), + Sbit, + Discriminant_Specifications (Decl)); + end if; + end; + end Record_Hole_Check; + end if; + + -- For records that have component clauses for all components, and whose + -- size is less than or equal to 32, we need to know the size in the + -- front end to activate possible packed array processing where the + -- component type is a record. + + -- At this stage Hbit + 1 represents the first unused bit from all the + -- component clauses processed, so if the component clauses are + -- complete, then this is the length of the record. + + -- For records longer than System.Storage_Unit, and for those where not + -- all components have component clauses, the back end determines the + -- length (it may for example be appropriate to round up the size + -- to some convenient boundary, based on alignment considerations, etc). + + if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then + + -- Nothing to do if at least one component has no component clause + + Comp := First_Component_Or_Discriminant (Rectype); + while Present (Comp) loop + exit when No (Component_Clause (Comp)); + Next_Component_Or_Discriminant (Comp); + end loop; + + -- If we fall out of loop, all components have component clauses + -- and so we can set the size to the maximum value. + + if No (Comp) then + Set_RM_Size (Rectype, Hbit + 1); + end if; + end if; + end Check_Record_Representation_Clause; + + ---------------- + -- Check_Size -- + ---------------- + + procedure Check_Size + (N : Node_Id; + T : Entity_Id; + Siz : Uint; + Biased : out Boolean) + is + UT : constant Entity_Id := Underlying_Type (T); + M : Uint; + + begin + Biased := False; + + -- Dismiss cases for generic types or types with previous errors + + if No (UT) + or else UT = Any_Type + or else Is_Generic_Type (UT) + or else Is_Generic_Type (Root_Type (UT)) + then + return; + + -- Check case of bit packed array + + elsif Is_Array_Type (UT) + and then Known_Static_Component_Size (UT) + and then Is_Bit_Packed_Array (UT) + then + declare + Asiz : Uint; + Indx : Node_Id; + Ityp : Entity_Id; + + begin + Asiz := Component_Size (UT); + Indx := First_Index (UT); + loop + Ityp := Etype (Indx); + + -- If non-static bound, then we are not in the business of + -- trying to check the length, and indeed an error will be + -- issued elsewhere, since sizes of non-static array types + -- cannot be set implicitly or explicitly. + + if not Is_Static_Subtype (Ityp) then + return; + end if; + + -- Otherwise accumulate next dimension + + Asiz := Asiz * (Expr_Value (Type_High_Bound (Ityp)) - + Expr_Value (Type_Low_Bound (Ityp)) + + Uint_1); + + Next_Index (Indx); + exit when No (Indx); + end loop; + + if Asiz <= Siz then + return; + else + Error_Msg_Uint_1 := Asiz; + Error_Msg_NE + ("size for& too small, minimum allowed is ^", N, T); + Set_Esize (T, Asiz); + Set_RM_Size (T, Asiz); + end if; + end; + + -- All other composite types are ignored + + elsif Is_Composite_Type (UT) then + return; + + -- For fixed-point types, don't check minimum if type is not frozen, + -- since we don't know all the characteristics of the type that can + -- affect the size (e.g. a specified small) till freeze time. + + elsif Is_Fixed_Point_Type (UT) + and then not Is_Frozen (UT) + then + null; + + -- Cases for which a minimum check is required + + else + -- Ignore if specified size is correct for the type + + if Known_Esize (UT) and then Siz = Esize (UT) then + return; + end if; + + -- Otherwise get minimum size + + M := UI_From_Int (Minimum_Size (UT)); + + if Siz < M then + + -- Size is less than minimum size, but one possibility remains + -- that we can manage with the new size if we bias the type. + + M := UI_From_Int (Minimum_Size (UT, Biased => True)); + + if Siz < M then + Error_Msg_Uint_1 := M; + Error_Msg_NE + ("size for& too small, minimum allowed is ^", N, T); + Set_Esize (T, M); + Set_RM_Size (T, M); + else + Biased := True; + end if; + end if; + end if; + end Check_Size; + + ------------------------- + -- Get_Alignment_Value -- + ------------------------- + + function Get_Alignment_Value (Expr : Node_Id) return Uint is + Align : constant Uint := Static_Integer (Expr); + + begin + if Align = No_Uint then + return No_Uint; + + elsif Align <= 0 then + Error_Msg_N ("alignment value must be positive", Expr); + return No_Uint; + + else + for J in Int range 0 .. 64 loop + declare + M : constant Uint := Uint_2 ** J; + + begin + exit when M = Align; + + if M > Align then + Error_Msg_N + ("alignment value must be power of 2", Expr); + return No_Uint; + end if; + end; + end loop; + + return Align; + end if; + end Get_Alignment_Value; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Address_Clause_Checks.Init; + Independence_Checks.Init; + Unchecked_Conversions.Init; + end Initialize; + + ------------------------- + -- Is_Operational_Item -- + ------------------------- + + function Is_Operational_Item (N : Node_Id) return Boolean is + begin + if Nkind (N) /= N_Attribute_Definition_Clause then + return False; + else + declare + Id : constant Attribute_Id := Get_Attribute_Id (Chars (N)); + begin + return Id = Attribute_Input + or else Id = Attribute_Output + or else Id = Attribute_Read + or else Id = Attribute_Write + or else Id = Attribute_External_Tag; + end; + end if; + end Is_Operational_Item; + + ------------------ + -- Minimum_Size -- + ------------------ + + function Minimum_Size + (T : Entity_Id; + Biased : Boolean := False) return Nat + is + Lo : Uint := No_Uint; + Hi : Uint := No_Uint; + LoR : Ureal := No_Ureal; + HiR : Ureal := No_Ureal; + LoSet : Boolean := False; + HiSet : Boolean := False; + B : Uint; + S : Nat; + Ancest : Entity_Id; + R_Typ : constant Entity_Id := Root_Type (T); + + begin + -- If bad type, return 0 + + if T = Any_Type then + return 0; + + -- For generic types, just return zero. There cannot be any legitimate + -- need to know such a size, but this routine may be called with a + -- generic type as part of normal processing. + + elsif Is_Generic_Type (R_Typ) + or else R_Typ = Any_Type + then + return 0; + + -- Access types. Normally an access type cannot have a size smaller + -- than the size of System.Address. The exception is on VMS, where + -- we have short and long addresses, and it is possible for an access + -- type to have a short address size (and thus be less than the size + -- of System.Address itself). We simply skip the check for VMS, and + -- leave it to the back end to do the check. + + elsif Is_Access_Type (T) then + if OpenVMS_On_Target then + return 0; + else + return System_Address_Size; + end if; + + -- Floating-point types + + elsif Is_Floating_Point_Type (T) then + return UI_To_Int (Esize (R_Typ)); + + -- Discrete types + + elsif Is_Discrete_Type (T) then + + -- The following loop is looking for the nearest compile time known + -- bounds following the ancestor subtype chain. The idea is to find + -- the most restrictive known bounds information. + + Ancest := T; + loop + if Ancest = Any_Type or else Etype (Ancest) = Any_Type then + return 0; + end if; + + if not LoSet then + if Compile_Time_Known_Value (Type_Low_Bound (Ancest)) then + Lo := Expr_Rep_Value (Type_Low_Bound (Ancest)); + LoSet := True; + exit when HiSet; + end if; + end if; + + if not HiSet then + if Compile_Time_Known_Value (Type_High_Bound (Ancest)) then + Hi := Expr_Rep_Value (Type_High_Bound (Ancest)); + HiSet := True; + exit when LoSet; + end if; + end if; + + Ancest := Ancestor_Subtype (Ancest); + + if No (Ancest) then + Ancest := Base_Type (T); + + if Is_Generic_Type (Ancest) then + return 0; + end if; + end if; + end loop; + + -- Fixed-point types. We can't simply use Expr_Value to get the + -- Corresponding_Integer_Value values of the bounds, since these do not + -- get set till the type is frozen, and this routine can be called + -- before the type is frozen. Similarly the test for bounds being static + -- needs to include the case where we have unanalyzed real literals for + -- the same reason. + + elsif Is_Fixed_Point_Type (T) then + + -- The following loop is looking for the nearest compile time known + -- bounds following the ancestor subtype chain. The idea is to find + -- the most restrictive known bounds information. + + Ancest := T; + loop + if Ancest = Any_Type or else Etype (Ancest) = Any_Type then + return 0; + end if; + + -- Note: In the following two tests for LoSet and HiSet, it may + -- seem redundant to test for N_Real_Literal here since normally + -- one would assume that the test for the value being known at + -- compile time includes this case. However, there is a glitch. + -- If the real literal comes from folding a non-static expression, + -- then we don't consider any non- static expression to be known + -- at compile time if we are in configurable run time mode (needed + -- in some cases to give a clearer definition of what is and what + -- is not accepted). So the test is indeed needed. Without it, we + -- would set neither Lo_Set nor Hi_Set and get an infinite loop. + + if not LoSet then + if Nkind (Type_Low_Bound (Ancest)) = N_Real_Literal + or else Compile_Time_Known_Value (Type_Low_Bound (Ancest)) + then + LoR := Expr_Value_R (Type_Low_Bound (Ancest)); + LoSet := True; + exit when HiSet; + end if; + end if; + + if not HiSet then + if Nkind (Type_High_Bound (Ancest)) = N_Real_Literal + or else Compile_Time_Known_Value (Type_High_Bound (Ancest)) + then + HiR := Expr_Value_R (Type_High_Bound (Ancest)); + HiSet := True; + exit when LoSet; + end if; + end if; + + Ancest := Ancestor_Subtype (Ancest); + + if No (Ancest) then + Ancest := Base_Type (T); + + if Is_Generic_Type (Ancest) then + return 0; + end if; + end if; + end loop; + + Lo := UR_To_Uint (LoR / Small_Value (T)); + Hi := UR_To_Uint (HiR / Small_Value (T)); + + -- No other types allowed + + else + raise Program_Error; + end if; + + -- Fall through with Hi and Lo set. Deal with biased case + + if (Biased + and then not Is_Fixed_Point_Type (T) + and then not (Is_Enumeration_Type (T) + and then Has_Non_Standard_Rep (T))) + or else Has_Biased_Representation (T) + then + Hi := Hi - Lo; + Lo := Uint_0; + end if; + + -- Signed case. Note that we consider types like range 1 .. -1 to be + -- signed for the purpose of computing the size, since the bounds have + -- to be accommodated in the base type. + + if Lo < 0 or else Hi < 0 then + S := 1; + B := Uint_1; + + -- S = size, B = 2 ** (size - 1) (can accommodate -B .. +(B - 1)) + -- Note that we accommodate the case where the bounds cross. This + -- can happen either because of the way the bounds are declared + -- or because of the algorithm in Freeze_Fixed_Point_Type. + + while Lo < -B + or else Hi < -B + or else Lo >= B + or else Hi >= B + loop + B := Uint_2 ** S; + S := S + 1; + end loop; + + -- Unsigned case + + else + -- If both bounds are positive, make sure that both are represen- + -- table in the case where the bounds are crossed. This can happen + -- either because of the way the bounds are declared, or because of + -- the algorithm in Freeze_Fixed_Point_Type. + + if Lo > Hi then + Hi := Lo; + end if; + + -- S = size, (can accommodate 0 .. (2**size - 1)) + + S := 0; + while Hi >= Uint_2 ** S loop + S := S + 1; + end loop; + end if; + + return S; + end Minimum_Size; + + --------------------------- + -- New_Stream_Subprogram -- + --------------------------- + + procedure New_Stream_Subprogram + (N : Node_Id; + Ent : Entity_Id; + Subp : Entity_Id; + Nam : TSS_Name_Type) + is + Loc : constant Source_Ptr := Sloc (N); + Sname : constant Name_Id := Make_TSS_Name (Base_Type (Ent), Nam); + Subp_Id : Entity_Id; + Subp_Decl : Node_Id; + F : Entity_Id; + Etyp : Entity_Id; + + Defer_Declaration : constant Boolean := + Is_Tagged_Type (Ent) or else Is_Private_Type (Ent); + -- For a tagged type, there is a declaration for each stream attribute + -- at the freeze point, and we must generate only a completion of this + -- declaration. We do the same for private types, because the full view + -- might be tagged. Otherwise we generate a declaration at the point of + -- the attribute definition clause. + + function Build_Spec return Node_Id; + -- Used for declaration and renaming declaration, so that this is + -- treated as a renaming_as_body. + + ---------------- + -- Build_Spec -- + ---------------- + + function Build_Spec return Node_Id is + Out_P : constant Boolean := (Nam = TSS_Stream_Read); + Formals : List_Id; + Spec : Node_Id; + T_Ref : constant Node_Id := New_Reference_To (Etyp, Loc); + + begin + Subp_Id := Make_Defining_Identifier (Loc, Sname); + + -- S : access Root_Stream_Type'Class + + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_S), + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Reference_To ( + Designated_Type (Etype (F)), Loc)))); + + if Nam = TSS_Stream_Input then + Spec := Make_Function_Specification (Loc, + Defining_Unit_Name => Subp_Id, + Parameter_Specifications => Formals, + Result_Definition => T_Ref); + else + -- V : [out] T + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Out_Present => Out_P, + Parameter_Type => T_Ref)); + + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Subp_Id, + Parameter_Specifications => Formals); + end if; + + return Spec; + end Build_Spec; + + -- Start of processing for New_Stream_Subprogram + + begin + F := First_Formal (Subp); + + if Ekind (Subp) = E_Procedure then + Etyp := Etype (Next_Formal (F)); + else + Etyp := Etype (Subp); + end if; + + -- Prepare subprogram declaration and insert it as an action on the + -- clause node. The visibility for this entity is used to test for + -- visibility of the attribute definition clause (in the sense of + -- 8.3(23) as amended by AI-195). + + if not Defer_Declaration then + Subp_Decl := + Make_Subprogram_Declaration (Loc, + Specification => Build_Spec); + + -- For a tagged type, there is always a visible declaration for each + -- stream TSS (it is a predefined primitive operation), and the + -- completion of this declaration occurs at the freeze point, which is + -- not always visible at places where the attribute definition clause is + -- visible. So, we create a dummy entity here for the purpose of + -- tracking the visibility of the attribute definition clause itself. + + else + Subp_Id := + Make_Defining_Identifier (Loc, New_External_Name (Sname, 'V')); + Subp_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Id, + Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc)); + end if; + + Insert_Action (N, Subp_Decl); + Set_Entity (N, Subp_Id); + + Subp_Decl := + Make_Subprogram_Renaming_Declaration (Loc, + Specification => Build_Spec, + Name => New_Reference_To (Subp, Loc)); + + if Defer_Declaration then + Set_TSS (Base_Type (Ent), Subp_Id); + else + Insert_Action (N, Subp_Decl); + Copy_TSS (Subp_Id, Base_Type (Ent)); + end if; + end New_Stream_Subprogram; + + ------------------------ + -- Rep_Item_Too_Early -- + ------------------------ + + function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean is + begin + -- Cannot apply non-operational rep items to generic types + + if Is_Operational_Item (N) then + return False; + + elsif Is_Type (T) + and then Is_Generic_Type (Root_Type (T)) + then + Error_Msg_N ("representation item not allowed for generic type", N); + return True; + end if; + + -- Otherwise check for incomplete type + + if Is_Incomplete_Or_Private_Type (T) + and then No (Underlying_Type (T)) + then + Error_Msg_N + ("representation item must be after full type declaration", N); + return True; + + -- If the type has incomplete components, a representation clause is + -- illegal but stream attributes and Convention pragmas are correct. + + elsif Has_Private_Component (T) then + if Nkind (N) = N_Pragma then + return False; + else + Error_Msg_N + ("representation item must appear after type is fully defined", + N); + return True; + end if; + else + return False; + end if; + end Rep_Item_Too_Early; + + ----------------------- + -- Rep_Item_Too_Late -- + ----------------------- + + function Rep_Item_Too_Late + (T : Entity_Id; + N : Node_Id; + FOnly : Boolean := False) return Boolean + is + S : Entity_Id; + Parent_Type : Entity_Id; + + procedure Too_Late; + -- Output the too late message. Note that this is not considered a + -- serious error, since the effect is simply that we ignore the + -- representation clause in this case. + + -------------- + -- Too_Late -- + -------------- + + procedure Too_Late is + begin + Error_Msg_N ("|representation item appears too late!", N); + end Too_Late; + + -- Start of processing for Rep_Item_Too_Late + + begin + -- First make sure entity is not frozen (RM 13.1(9)). Exclude imported + -- types, which may be frozen if they appear in a representation clause + -- for a local type. + + if Is_Frozen (T) + and then not From_With_Type (T) + then + Too_Late; + S := First_Subtype (T); + + if Present (Freeze_Node (S)) then + Error_Msg_NE + ("?no more representation items for }", Freeze_Node (S), S); + end if; + + return True; + + -- Check for case of non-tagged derived type whose parent either has + -- primitive operations, or is a by reference type (RM 13.1(10)). + + elsif Is_Type (T) + and then not FOnly + and then Is_Derived_Type (T) + and then not Is_Tagged_Type (T) + then + Parent_Type := Etype (Base_Type (T)); + + if Has_Primitive_Operations (Parent_Type) then + Too_Late; + Error_Msg_NE + ("primitive operations already defined for&!", N, Parent_Type); + return True; + + elsif Is_By_Reference_Type (Parent_Type) then + Too_Late; + Error_Msg_NE + ("parent type & is a by reference type!", N, Parent_Type); + return True; + end if; + end if; + + -- No error, link item into head of chain of rep items for the entity, + -- but avoid chaining if we have an overloadable entity, and the pragma + -- is one that can apply to multiple overloaded entities. + + if Is_Overloadable (T) + and then Nkind (N) = N_Pragma + then + declare + Pname : constant Name_Id := Pragma_Name (N); + begin + if Pname = Name_Convention or else + Pname = Name_Import or else + Pname = Name_Export or else + Pname = Name_External or else + Pname = Name_Interface + then + return False; + end if; + end; + end if; + + Record_Rep_Item (T, N); + return False; + end Rep_Item_Too_Late; + + ------------------------------------- + -- Replace_Type_References_Generic -- + ------------------------------------- + + procedure Replace_Type_References_Generic (N : Node_Id; TName : Name_Id) is + + function Replace_Node (N : Node_Id) return Traverse_Result; + -- Processes a single node in the traversal procedure below, checking + -- if node N should be replaced, and if so, doing the replacement. + + procedure Replace_Type_Refs is new Traverse_Proc (Replace_Node); + -- This instantiation provides the body of Replace_Type_References + + ------------------ + -- Replace_Node -- + ------------------ + + function Replace_Node (N : Node_Id) return Traverse_Result is + S : Entity_Id; + P : Node_Id; + + begin + -- Case of identifier + + if Nkind (N) = N_Identifier then + + -- If not the type name, all done with this node + + if Chars (N) /= TName then + return Skip; + + -- Otherwise do the replacement and we are done with this node + + else + Replace_Type_Reference (N); + return Skip; + end if; + + -- Case of selected component (which is what a qualification + -- looks like in the unanalyzed tree, which is what we have. + + elsif Nkind (N) = N_Selected_Component then + + -- If selector name is not our type, keeping going (we might + -- still have an occurrence of the type in the prefix). + + if Nkind (Selector_Name (N)) /= N_Identifier + or else Chars (Selector_Name (N)) /= TName + then + return OK; + + -- Selector name is our type, check qualification + + else + -- Loop through scopes and prefixes, doing comparison + + S := Current_Scope; + P := Prefix (N); + loop + -- Continue if no more scopes or scope with no name + + if No (S) or else Nkind (S) not in N_Has_Chars then + return OK; + end if; + + -- Do replace if prefix is an identifier matching the + -- scope that we are currently looking at. + + if Nkind (P) = N_Identifier + and then Chars (P) = Chars (S) + then + Replace_Type_Reference (N); + return Skip; + end if; + + -- Go check scope above us if prefix is itself of the + -- form of a selected component, whose selector matches + -- the scope we are currently looking at. + + if Nkind (P) = N_Selected_Component + and then Nkind (Selector_Name (P)) = N_Identifier + and then Chars (Selector_Name (P)) = Chars (S) + then + S := Scope (S); + P := Prefix (P); + + -- For anything else, we don't have a match, so keep on + -- going, there are still some weird cases where we may + -- still have a replacement within the prefix. + + else + return OK; + end if; + end loop; + end if; + + -- Continue for any other node kind + + else + return OK; + end if; + end Replace_Node; + + begin + Replace_Type_Refs (N); + end Replace_Type_References_Generic; + + ------------------------- + -- Same_Representation -- + ------------------------- + + function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean is + T1 : constant Entity_Id := Underlying_Type (Typ1); + T2 : constant Entity_Id := Underlying_Type (Typ2); + + begin + -- A quick check, if base types are the same, then we definitely have + -- the same representation, because the subtype specific representation + -- attributes (Size and Alignment) do not affect representation from + -- the point of view of this test. + + if Base_Type (T1) = Base_Type (T2) then + return True; + + elsif Is_Private_Type (Base_Type (T2)) + and then Base_Type (T1) = Full_View (Base_Type (T2)) + then + return True; + end if; + + -- Tagged types never have differing representations + + if Is_Tagged_Type (T1) then + return True; + end if; + + -- Representations are definitely different if conventions differ + + if Convention (T1) /= Convention (T2) then + return False; + end if; + + -- Representations are different if component alignments differ + + if (Is_Record_Type (T1) or else Is_Array_Type (T1)) + and then + (Is_Record_Type (T2) or else Is_Array_Type (T2)) + and then Component_Alignment (T1) /= Component_Alignment (T2) + then + return False; + end if; + + -- For arrays, the only real issue is component size. If we know the + -- component size for both arrays, and it is the same, then that's + -- good enough to know we don't have a change of representation. + + if Is_Array_Type (T1) then + if Known_Component_Size (T1) + and then Known_Component_Size (T2) + and then Component_Size (T1) = Component_Size (T2) + then + return True; + end if; + end if; + + -- Types definitely have same representation if neither has non-standard + -- representation since default representations are always consistent. + -- If only one has non-standard representation, and the other does not, + -- then we consider that they do not have the same representation. They + -- might, but there is no way of telling early enough. + + if Has_Non_Standard_Rep (T1) then + if not Has_Non_Standard_Rep (T2) then + return False; + end if; + else + return not Has_Non_Standard_Rep (T2); + end if; + + -- Here the two types both have non-standard representation, and we need + -- to determine if they have the same non-standard representation. + + -- For arrays, we simply need to test if the component sizes are the + -- same. Pragma Pack is reflected in modified component sizes, so this + -- check also deals with pragma Pack. + + if Is_Array_Type (T1) then + return Component_Size (T1) = Component_Size (T2); + + -- Tagged types always have the same representation, because it is not + -- possible to specify different representations for common fields. + + elsif Is_Tagged_Type (T1) then + return True; + + -- Case of record types + + elsif Is_Record_Type (T1) then + + -- Packed status must conform + + if Is_Packed (T1) /= Is_Packed (T2) then + return False; + + -- Otherwise we must check components. Typ2 maybe a constrained + -- subtype with fewer components, so we compare the components + -- of the base types. + + else + Record_Case : declare + CD1, CD2 : Entity_Id; + + function Same_Rep return Boolean; + -- CD1 and CD2 are either components or discriminants. This + -- function tests whether the two have the same representation + + -------------- + -- Same_Rep -- + -------------- + + function Same_Rep return Boolean is + begin + if No (Component_Clause (CD1)) then + return No (Component_Clause (CD2)); + + else + return + Present (Component_Clause (CD2)) + and then + Component_Bit_Offset (CD1) = Component_Bit_Offset (CD2) + and then + Esize (CD1) = Esize (CD2); + end if; + end Same_Rep; + + -- Start of processing for Record_Case + + begin + if Has_Discriminants (T1) then + CD1 := First_Discriminant (T1); + CD2 := First_Discriminant (T2); + + -- The number of discriminants may be different if the + -- derived type has fewer (constrained by values). The + -- invisible discriminants retain the representation of + -- the original, so the discrepancy does not per se + -- indicate a different representation. + + while Present (CD1) + and then Present (CD2) + loop + if not Same_Rep then + return False; + else + Next_Discriminant (CD1); + Next_Discriminant (CD2); + end if; + end loop; + end if; + + CD1 := First_Component (Underlying_Type (Base_Type (T1))); + CD2 := First_Component (Underlying_Type (Base_Type (T2))); + + while Present (CD1) loop + if not Same_Rep then + return False; + else + Next_Component (CD1); + Next_Component (CD2); + end if; + end loop; + + return True; + end Record_Case; + end if; + + -- For enumeration types, we must check each literal to see if the + -- representation is the same. Note that we do not permit enumeration + -- representation clauses for Character and Wide_Character, so these + -- cases were already dealt with. + + elsif Is_Enumeration_Type (T1) then + Enumeration_Case : declare + L1, L2 : Entity_Id; + + begin + L1 := First_Literal (T1); + L2 := First_Literal (T2); + + while Present (L1) loop + if Enumeration_Rep (L1) /= Enumeration_Rep (L2) then + return False; + else + Next_Literal (L1); + Next_Literal (L2); + end if; + end loop; + + return True; + + end Enumeration_Case; + + -- Any other types have the same representation for these purposes + + else + return True; + end if; + end Same_Representation; + + ---------------- + -- Set_Biased -- + ---------------- + + procedure Set_Biased + (E : Entity_Id; + N : Node_Id; + Msg : String; + Biased : Boolean := True) + is + begin + if Biased then + Set_Has_Biased_Representation (E); + + if Warn_On_Biased_Representation then + Error_Msg_NE + ("?" & Msg & " forces biased representation for&", N, E); + end if; + end if; + end Set_Biased; + + -------------------- + -- Set_Enum_Esize -- + -------------------- + + procedure Set_Enum_Esize (T : Entity_Id) is + Lo : Uint; + Hi : Uint; + Sz : Nat; + + begin + Init_Alignment (T); + + -- Find the minimum standard size (8,16,32,64) that fits + + Lo := Enumeration_Rep (Entity (Type_Low_Bound (T))); + Hi := Enumeration_Rep (Entity (Type_High_Bound (T))); + + if Lo < 0 then + if Lo >= -Uint_2**07 and then Hi < Uint_2**07 then + Sz := Standard_Character_Size; -- May be > 8 on some targets + + elsif Lo >= -Uint_2**15 and then Hi < Uint_2**15 then + Sz := 16; + + elsif Lo >= -Uint_2**31 and then Hi < Uint_2**31 then + Sz := 32; + + else pragma Assert (Lo >= -Uint_2**63 and then Hi < Uint_2**63); + Sz := 64; + end if; + + else + if Hi < Uint_2**08 then + Sz := Standard_Character_Size; -- May be > 8 on some targets + + elsif Hi < Uint_2**16 then + Sz := 16; + + elsif Hi < Uint_2**32 then + Sz := 32; + + else pragma Assert (Hi < Uint_2**63); + Sz := 64; + end if; + end if; + + -- That minimum is the proper size unless we have a foreign convention + -- and the size required is 32 or less, in which case we bump the size + -- up to 32. This is required for C and C++ and seems reasonable for + -- all other foreign conventions. + + if Has_Foreign_Convention (T) + and then Esize (T) < Standard_Integer_Size + then + Init_Esize (T, Standard_Integer_Size); + else + Init_Esize (T, Sz); + end if; + end Set_Enum_Esize; + + ------------------------------ + -- Validate_Address_Clauses -- + ------------------------------ + + procedure Validate_Address_Clauses is + begin + for J in Address_Clause_Checks.First .. Address_Clause_Checks.Last loop + declare + ACCR : Address_Clause_Check_Record + renames Address_Clause_Checks.Table (J); + + Expr : Node_Id; + + X_Alignment : Uint; + Y_Alignment : Uint; + + X_Size : Uint; + Y_Size : Uint; + + begin + -- Skip processing of this entry if warning already posted + + if not Address_Warning_Posted (ACCR.N) then + + Expr := Original_Node (Expression (ACCR.N)); + + -- Get alignments + + X_Alignment := Alignment (ACCR.X); + Y_Alignment := Alignment (ACCR.Y); + + -- Similarly obtain sizes + + X_Size := Esize (ACCR.X); + Y_Size := Esize (ACCR.Y); + + -- Check for large object overlaying smaller one + + if Y_Size > Uint_0 + and then X_Size > Uint_0 + and then X_Size > Y_Size + then + Error_Msg_NE + ("?& overlays smaller object", ACCR.N, ACCR.X); + Error_Msg_N + ("\?program execution may be erroneous", ACCR.N); + Error_Msg_Uint_1 := X_Size; + Error_Msg_NE + ("\?size of & is ^", ACCR.N, ACCR.X); + Error_Msg_Uint_1 := Y_Size; + Error_Msg_NE + ("\?size of & is ^", ACCR.N, ACCR.Y); + + -- Check for inadequate alignment, both of the base object + -- and of the offset, if any. + + -- Note: we do not check the alignment if we gave a size + -- warning, since it would likely be redundant. + + elsif Y_Alignment /= Uint_0 + and then (Y_Alignment < X_Alignment + or else (ACCR.Off + and then + Nkind (Expr) = N_Attribute_Reference + and then + Attribute_Name (Expr) = Name_Address + and then + Has_Compatible_Alignment + (ACCR.X, Prefix (Expr)) + /= Known_Compatible)) + then + Error_Msg_NE + ("?specified address for& may be inconsistent " + & "with alignment", + ACCR.N, ACCR.X); + Error_Msg_N + ("\?program execution may be erroneous (RM 13.3(27))", + ACCR.N); + Error_Msg_Uint_1 := X_Alignment; + Error_Msg_NE + ("\?alignment of & is ^", + ACCR.N, ACCR.X); + Error_Msg_Uint_1 := Y_Alignment; + Error_Msg_NE + ("\?alignment of & is ^", + ACCR.N, ACCR.Y); + if Y_Alignment >= X_Alignment then + Error_Msg_N + ("\?but offset is not multiple of alignment", + ACCR.N); + end if; + end if; + end if; + end; + end loop; + end Validate_Address_Clauses; + + --------------------------- + -- Validate_Independence -- + --------------------------- + + procedure Validate_Independence is + SU : constant Uint := UI_From_Int (System_Storage_Unit); + N : Node_Id; + E : Entity_Id; + IC : Boolean; + Comp : Entity_Id; + Addr : Node_Id; + P : Node_Id; + + procedure Check_Array_Type (Atyp : Entity_Id); + -- Checks if the array type Atyp has independent components, and + -- if not, outputs an appropriate set of error messages. + + procedure No_Independence; + -- Output message that independence cannot be guaranteed + + function OK_Component (C : Entity_Id) return Boolean; + -- Checks one component to see if it is independently accessible, and + -- if so yields True, otherwise yields False if independent access + -- cannot be guaranteed. This is a conservative routine, it only + -- returns True if it knows for sure, it returns False if it knows + -- there is a problem, or it cannot be sure there is no problem. + + procedure Reason_Bad_Component (C : Entity_Id); + -- Outputs continuation message if a reason can be determined for + -- the component C being bad. + + ---------------------- + -- Check_Array_Type -- + ---------------------- + + procedure Check_Array_Type (Atyp : Entity_Id) is + Ctyp : constant Entity_Id := Component_Type (Atyp); + + begin + -- OK if no alignment clause, no pack, and no component size + + if not Has_Component_Size_Clause (Atyp) + and then not Has_Alignment_Clause (Atyp) + and then not Is_Packed (Atyp) + then + return; + end if; + + -- Check actual component size + + if not Known_Component_Size (Atyp) + or else not (Addressable (Component_Size (Atyp)) + and then Component_Size (Atyp) < 64) + or else Component_Size (Atyp) mod Esize (Ctyp) /= 0 + then + No_Independence; + + -- Bad component size, check reason + + if Has_Component_Size_Clause (Atyp) then + P := + Get_Attribute_Definition_Clause + (Atyp, Attribute_Component_Size); + + if Present (P) then + Error_Msg_Sloc := Sloc (P); + Error_Msg_N ("\because of Component_Size clause#", N); + return; + end if; + end if; + + if Is_Packed (Atyp) then + P := Get_Rep_Pragma (Atyp, Name_Pack); + + if Present (P) then + Error_Msg_Sloc := Sloc (P); + Error_Msg_N ("\because of pragma Pack#", N); + return; + end if; + end if; + + -- No reason found, just return + + return; + end if; + + -- Array type is OK independence-wise + + return; + end Check_Array_Type; + + --------------------- + -- No_Independence -- + --------------------- + + procedure No_Independence is + begin + if Pragma_Name (N) = Name_Independent then + Error_Msg_NE + ("independence cannot be guaranteed for&", N, E); + else + Error_Msg_NE + ("independent components cannot be guaranteed for&", N, E); + end if; + end No_Independence; + + ------------------ + -- OK_Component -- + ------------------ + + function OK_Component (C : Entity_Id) return Boolean is + Rec : constant Entity_Id := Scope (C); + Ctyp : constant Entity_Id := Etype (C); + + begin + -- OK if no component clause, no Pack, and no alignment clause + + if No (Component_Clause (C)) + and then not Is_Packed (Rec) + and then not Has_Alignment_Clause (Rec) + then + return True; + end if; + + -- Here we look at the actual component layout. A component is + -- addressable if its size is a multiple of the Esize of the + -- component type, and its starting position in the record has + -- appropriate alignment, and the record itself has appropriate + -- alignment to guarantee the component alignment. + + -- Make sure sizes are static, always assume the worst for any + -- cases where we cannot check static values. + + if not (Known_Static_Esize (C) + and then Known_Static_Esize (Ctyp)) + then + return False; + end if; + + -- Size of component must be addressable or greater than 64 bits + -- and a multiple of bytes. + + if not Addressable (Esize (C)) + and then Esize (C) < Uint_64 + then + return False; + end if; + + -- Check size is proper multiple + + if Esize (C) mod Esize (Ctyp) /= 0 then + return False; + end if; + + -- Check alignment of component is OK + + if not Known_Component_Bit_Offset (C) + or else Component_Bit_Offset (C) < Uint_0 + or else Component_Bit_Offset (C) mod Esize (Ctyp) /= 0 + then + return False; + end if; + + -- Check alignment of record type is OK + + if not Known_Alignment (Rec) + or else (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0 + then + return False; + end if; + + -- All tests passed, component is addressable + + return True; + end OK_Component; + + -------------------------- + -- Reason_Bad_Component -- + -------------------------- + + procedure Reason_Bad_Component (C : Entity_Id) is + Rec : constant Entity_Id := Scope (C); + Ctyp : constant Entity_Id := Etype (C); + + begin + -- If component clause present assume that's the problem + + if Present (Component_Clause (C)) then + Error_Msg_Sloc := Sloc (Component_Clause (C)); + Error_Msg_N ("\because of Component_Clause#", N); + return; + end if; + + -- If pragma Pack clause present, assume that's the problem + + if Is_Packed (Rec) then + P := Get_Rep_Pragma (Rec, Name_Pack); + + if Present (P) then + Error_Msg_Sloc := Sloc (P); + Error_Msg_N ("\because of pragma Pack#", N); + return; + end if; + end if; + + -- See if record has bad alignment clause + + if Has_Alignment_Clause (Rec) + and then Known_Alignment (Rec) + and then (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0 + then + P := Get_Attribute_Definition_Clause (Rec, Attribute_Alignment); + + if Present (P) then + Error_Msg_Sloc := Sloc (P); + Error_Msg_N ("\because of Alignment clause#", N); + end if; + end if; + + -- Couldn't find a reason, so return without a message + + return; + end Reason_Bad_Component; + + -- Start of processing for Validate_Independence + + begin + for J in Independence_Checks.First .. Independence_Checks.Last loop + N := Independence_Checks.Table (J).N; + E := Independence_Checks.Table (J).E; + IC := Pragma_Name (N) = Name_Independent_Components; + + -- Deal with component case + + if Ekind (E) = E_Discriminant or else Ekind (E) = E_Component then + if not OK_Component (E) then + No_Independence; + Reason_Bad_Component (E); + goto Continue; + end if; + end if; + + -- Deal with record with Independent_Components + + if IC and then Is_Record_Type (E) then + Comp := First_Component_Or_Discriminant (E); + while Present (Comp) loop + if not OK_Component (Comp) then + No_Independence; + Reason_Bad_Component (Comp); + goto Continue; + end if; + + Next_Component_Or_Discriminant (Comp); + end loop; + end if; + + -- Deal with address clause case + + if Is_Object (E) then + Addr := Address_Clause (E); + + if Present (Addr) then + No_Independence; + Error_Msg_Sloc := Sloc (Addr); + Error_Msg_N ("\because of Address clause#", N); + goto Continue; + end if; + end if; + + -- Deal with independent components for array type + + if IC and then Is_Array_Type (E) then + Check_Array_Type (E); + end if; + + -- Deal with independent components for array object + + if IC and then Is_Object (E) and then Is_Array_Type (Etype (E)) then + Check_Array_Type (Etype (E)); + end if; + + <> null; + end loop; + end Validate_Independence; + + ----------------------------------- + -- Validate_Unchecked_Conversion -- + ----------------------------------- + + procedure Validate_Unchecked_Conversion + (N : Node_Id; + Act_Unit : Entity_Id) + is + Source : Entity_Id; + Target : Entity_Id; + Vnode : Node_Id; + + begin + -- Obtain source and target types. Note that we call Ancestor_Subtype + -- here because the processing for generic instantiation always makes + -- subtypes, and we want the original frozen actual types. + + -- If we are dealing with private types, then do the check on their + -- fully declared counterparts if the full declarations have been + -- encountered (they don't have to be visible, but they must exist!) + + Source := Ancestor_Subtype (Etype (First_Formal (Act_Unit))); + + if Is_Private_Type (Source) + and then Present (Underlying_Type (Source)) + then + Source := Underlying_Type (Source); + end if; + + Target := Ancestor_Subtype (Etype (Act_Unit)); + + -- If either type is generic, the instantiation happens within a generic + -- unit, and there is nothing to check. The proper check + -- will happen when the enclosing generic is instantiated. + + if Is_Generic_Type (Source) or else Is_Generic_Type (Target) then + return; + end if; + + if Is_Private_Type (Target) + and then Present (Underlying_Type (Target)) + then + Target := Underlying_Type (Target); + end if; + + -- Source may be unconstrained array, but not target + + if Is_Array_Type (Target) + and then not Is_Constrained (Target) + then + Error_Msg_N + ("unchecked conversion to unconstrained array not allowed", N); + return; + end if; + + -- Warn if conversion between two different convention pointers + + if Is_Access_Type (Target) + and then Is_Access_Type (Source) + and then Convention (Target) /= Convention (Source) + and then Warn_On_Unchecked_Conversion + then + -- Give warnings for subprogram pointers only on most targets. The + -- exception is VMS, where data pointers can have different lengths + -- depending on the pointer convention. + + if Is_Access_Subprogram_Type (Target) + or else Is_Access_Subprogram_Type (Source) + or else OpenVMS_On_Target + then + Error_Msg_N + ("?conversion between pointers with different conventions!", N); + end if; + end if; + + -- Warn if one of the operands is Ada.Calendar.Time. Do not emit a + -- warning when compiling GNAT-related sources. + + if Warn_On_Unchecked_Conversion + and then not In_Predefined_Unit (N) + and then RTU_Loaded (Ada_Calendar) + and then + (Chars (Source) = Name_Time + or else + Chars (Target) = Name_Time) + then + -- If Ada.Calendar is loaded and the name of one of the operands is + -- Time, there is a good chance that this is Ada.Calendar.Time. + + declare + Calendar_Time : constant Entity_Id := + Full_View (RTE (RO_CA_Time)); + begin + pragma Assert (Present (Calendar_Time)); + + if Source = Calendar_Time + or else Target = Calendar_Time + then + Error_Msg_N + ("?representation of 'Time values may change between " & + "'G'N'A'T versions", N); + end if; + end; + end if; + + -- Make entry in unchecked conversion table for later processing by + -- Validate_Unchecked_Conversions, which will check sizes and alignments + -- (using values set by the back-end where possible). This is only done + -- if the appropriate warning is active. + + if Warn_On_Unchecked_Conversion then + Unchecked_Conversions.Append + (New_Val => UC_Entry' + (Eloc => Sloc (N), + Source => Source, + Target => Target)); + + -- If both sizes are known statically now, then back end annotation + -- is not required to do a proper check but if either size is not + -- known statically, then we need the annotation. + + if Known_Static_RM_Size (Source) + and then Known_Static_RM_Size (Target) + then + null; + else + Back_Annotate_Rep_Info := True; + end if; + end if; + + -- If unchecked conversion to access type, and access type is declared + -- in the same unit as the unchecked conversion, then set the + -- No_Strict_Aliasing flag (no strict aliasing is implicit in this + -- situation). + + if Is_Access_Type (Target) and then + In_Same_Source_Unit (Target, N) + then + Set_No_Strict_Aliasing (Implementation_Base_Type (Target)); + end if; + + -- Generate N_Validate_Unchecked_Conversion node for back end in + -- case the back end needs to perform special validation checks. + + -- Shouldn't this be in Exp_Ch13, since the check only gets done + -- if we have full expansion and the back end is called ??? + + Vnode := + Make_Validate_Unchecked_Conversion (Sloc (N)); + Set_Source_Type (Vnode, Source); + Set_Target_Type (Vnode, Target); + + -- If the unchecked conversion node is in a list, just insert before it. + -- If not we have some strange case, not worth bothering about. + + if Is_List_Member (N) then + Insert_After (N, Vnode); + end if; + end Validate_Unchecked_Conversion; + + ------------------------------------ + -- Validate_Unchecked_Conversions -- + ------------------------------------ + + procedure Validate_Unchecked_Conversions is + begin + for N in Unchecked_Conversions.First .. Unchecked_Conversions.Last loop + declare + T : UC_Entry renames Unchecked_Conversions.Table (N); + + Eloc : constant Source_Ptr := T.Eloc; + Source : constant Entity_Id := T.Source; + Target : constant Entity_Id := T.Target; + + Source_Siz : Uint; + Target_Siz : Uint; + + begin + -- This validation check, which warns if we have unequal sizes for + -- unchecked conversion, and thus potentially implementation + -- dependent semantics, is one of the few occasions on which we + -- use the official RM size instead of Esize. See description in + -- Einfo "Handling of Type'Size Values" for details. + + if Serious_Errors_Detected = 0 + and then Known_Static_RM_Size (Source) + and then Known_Static_RM_Size (Target) + + -- Don't do the check if warnings off for either type, note the + -- deliberate use of OR here instead of OR ELSE to get the flag + -- Warnings_Off_Used set for both types if appropriate. + + and then not (Has_Warnings_Off (Source) + or + Has_Warnings_Off (Target)) + then + Source_Siz := RM_Size (Source); + Target_Siz := RM_Size (Target); + + if Source_Siz /= Target_Siz then + Error_Msg + ("?types for unchecked conversion have different sizes!", + Eloc); + + if All_Errors_Mode then + Error_Msg_Name_1 := Chars (Source); + Error_Msg_Uint_1 := Source_Siz; + Error_Msg_Name_2 := Chars (Target); + Error_Msg_Uint_2 := Target_Siz; + Error_Msg ("\size of % is ^, size of % is ^?", Eloc); + + Error_Msg_Uint_1 := UI_Abs (Source_Siz - Target_Siz); + + if Is_Discrete_Type (Source) + and then Is_Discrete_Type (Target) + then + if Source_Siz > Target_Siz then + Error_Msg + ("\?^ high order bits of source will be ignored!", + Eloc); + + elsif Is_Unsigned_Type (Source) then + Error_Msg + ("\?source will be extended with ^ high order " & + "zero bits?!", Eloc); + + else + Error_Msg + ("\?source will be extended with ^ high order " & + "sign bits!", + Eloc); + end if; + + elsif Source_Siz < Target_Siz then + if Is_Discrete_Type (Target) then + if Bytes_Big_Endian then + Error_Msg + ("\?target value will include ^ undefined " & + "low order bits!", + Eloc); + else + Error_Msg + ("\?target value will include ^ undefined " & + "high order bits!", + Eloc); + end if; + + else + Error_Msg + ("\?^ trailing bits of target value will be " & + "undefined!", Eloc); + end if; + + else pragma Assert (Source_Siz > Target_Siz); + Error_Msg + ("\?^ trailing bits of source will be ignored!", + Eloc); + end if; + end if; + end if; + end if; + + -- If both types are access types, we need to check the alignment. + -- If the alignment of both is specified, we can do it here. + + if Serious_Errors_Detected = 0 + and then Ekind (Source) in Access_Kind + and then Ekind (Target) in Access_Kind + and then Target_Strict_Alignment + and then Present (Designated_Type (Source)) + and then Present (Designated_Type (Target)) + then + declare + D_Source : constant Entity_Id := Designated_Type (Source); + D_Target : constant Entity_Id := Designated_Type (Target); + + begin + if Known_Alignment (D_Source) + and then Known_Alignment (D_Target) + then + declare + Source_Align : constant Uint := Alignment (D_Source); + Target_Align : constant Uint := Alignment (D_Target); + + begin + if Source_Align < Target_Align + and then not Is_Tagged_Type (D_Source) + + -- Suppress warning if warnings suppressed on either + -- type or either designated type. Note the use of + -- OR here instead of OR ELSE. That is intentional, + -- we would like to set flag Warnings_Off_Used in + -- all types for which warnings are suppressed. + + and then not (Has_Warnings_Off (D_Source) + or + Has_Warnings_Off (D_Target) + or + Has_Warnings_Off (Source) + or + Has_Warnings_Off (Target)) + then + Error_Msg_Uint_1 := Target_Align; + Error_Msg_Uint_2 := Source_Align; + Error_Msg_Node_1 := D_Target; + Error_Msg_Node_2 := D_Source; + Error_Msg + ("?alignment of & (^) is stricter than " & + "alignment of & (^)!", Eloc); + Error_Msg + ("\?resulting access value may have invalid " & + "alignment!", Eloc); + end if; + end; + end if; + end; + end if; + end; + end loop; + end Validate_Unchecked_Conversions; + +end Sem_Ch13; diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads new file mode 100644 index 000000000..95263ec84 --- /dev/null +++ b/gcc/ada/sem_ch13.ads @@ -0,0 +1,239 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 1 3 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Table; +with Types; use Types; +with Uintp; use Uintp; + +package Sem_Ch13 is + procedure Analyze_At_Clause (N : Node_Id); + procedure Analyze_Attribute_Definition_Clause (N : Node_Id); + procedure Analyze_Enumeration_Representation_Clause (N : Node_Id); + procedure Analyze_Free_Statement (N : Node_Id); + procedure Analyze_Freeze_Entity (N : Node_Id); + procedure Analyze_Record_Representation_Clause (N : Node_Id); + procedure Analyze_Code_Statement (N : Node_Id); + + procedure Analyze_Aspect_Specifications + (N : Node_Id; + E : Entity_Id; + L : List_Id); + -- This procedure is called to analyze aspect specifications for node N. E + -- is the corresponding entity declared by the declaration node N, and L is + -- the list of aspect specifications for this node. If L is No_List, the + -- call is ignored. Note that we can't use a simpler interface of just + -- passing the node N, since the analysis of the node may cause it to be + -- rewritten to a node not permitting aspect specifications. + + procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id); + -- Called from Freeze where R is a record entity for which reverse bit + -- order is specified and there is at least one component clause. Adjusts + -- component positions according to either Ada 95 or Ada 2005 (AI-133). + + procedure Build_Invariant_Procedure (Typ : Entity_Id; N : Node_Id); + -- Typ is a private type with invariants (indicated by Has_Invariants being + -- set for Typ, indicating the presence of pragma Invariant entries on the + -- rep chain, note that Invariant aspects have already been converted to + -- pragma Invariant), then this procedure builds the spec and body for the + -- corresponding Invariant procedure, inserting them at appropriate points + -- in the package specification N. Invariant_Procedure is set for Typ. Note + -- that this procedure is called at the end of processing the declarations + -- in the visible part (i.e. the right point for visibility analysis of + -- the invariant expression). + + procedure Check_Record_Representation_Clause (N : Node_Id); + -- This procedure completes the analysis of a record representation clause + -- N. It is called at freeze time after adjustment of component clause bit + -- positions for possible non-standard bit order. In the case of Ada 2005 + -- (machine scalar) mode, this adjustment can make substantial changes, so + -- some checks, in particular for component overlaps cannot be done at the + -- time the record representation clause is first seen, but must be delayed + -- till freeze time, and in particular is called after calling the above + -- procedure for adjusting record bit positions for reverse bit order. + + procedure Initialize; + -- Initialize internal tables for new compilation + + procedure Set_Enum_Esize (T : Entity_Id); + -- This routine sets the Esize field for an enumeration type T, based + -- on the current representation information available for T. Note that + -- the setting of the RM_Size field is not affected. This routine also + -- initializes the alignment field to zero. + + function Minimum_Size + (T : Entity_Id; + Biased : Boolean := False) return Nat; + -- Given an elementary type, determines the minimum number of bits required + -- to represent all values of the type. This function may not be called + -- with any other types. If the flag Biased is set True, then the minimum + -- size calculation that biased representation is used in the case of a + -- discrete type, e.g. the range 7..8 gives a minimum size of 4 with + -- Biased set to False, and 1 with Biased set to True. Note that the + -- biased parameter only has an effect if the type is not biased, it + -- causes Minimum_Size to indicate the minimum size of an object with + -- the given type, of the size the type would have if it were biased. If + -- the type is already biased, then Minimum_Size returns the biased size, + -- regardless of the setting of Biased. Also, fixed-point types are never + -- biased in the current implementation. If the size is not known at + -- compile time, this function returns 0. + + procedure Check_Constant_Address_Clause (Expr : Node_Id; U_Ent : Entity_Id); + -- Expr is an expression for an address clause. This procedure checks + -- that the expression is constant, in the limited sense that it is safe + -- to evaluate it at the point the object U_Ent is declared, rather than + -- at the point of the address clause. The condition for this to be true + -- is that the expression has no variables, no constants declared after + -- U_Ent, and no calls to non-pure functions. If this condition is not + -- met, then an appropriate error message is posted. This check is applied + -- at the point an object with an address clause is frozen, as well as for + -- address clauses for tasks and entries. + + procedure Check_Size + (N : Node_Id; + T : Entity_Id; + Siz : Uint; + Biased : out Boolean); + -- Called when size Siz is specified for subtype T. This subprogram checks + -- that the size is appropriate, posting errors on node N as required. + -- This check is effective for elementary types and bit-packed arrays. + -- For other non-elementary types, a check is only made if an explicit + -- size has been given for the type (and the specified size must match). + -- The parameter Biased is set False if the size specified did not require + -- the use of biased representation, and True if biased representation + -- was required to meet the size requirement. Note that Biased is only + -- set if the type is not currently biased, but biasing it is the only + -- way to meet the requirement. If the type is currently biased, then + -- this biased size is used in the initial check, and Biased is False. + -- If the size is too small, and an error message is given, then both + -- Esize and RM_Size are reset to the allowed minimum value in T. + + function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean; + -- Called at the start of processing a representation clause or a + -- representation pragma. Used to check that the representation item + -- is not being applied to an incomplete type or to a generic formal + -- type or a type derived from a generic formal type. Returns False if + -- no such error occurs. If this error does occur, appropriate error + -- messages are posted on node N, and True is returned. + + function Rep_Item_Too_Late + (T : Entity_Id; + N : Node_Id; + FOnly : Boolean := False) return Boolean; + -- Called at the start of processing a representation clause or a + -- representation pragma. Used to check that a representation item + -- for entity T does not appear too late (according to the rules in + -- RM 13.1(9) and RM 13.1(10)). N is the associated node, which in + -- the pragma case is the pragma or representation clause itself, used + -- for placing error messages if the item is too late. + -- + -- Fonly is a flag that causes only the freezing rule (para 9) to be + -- applied, and the tests of para 10 are skipped. This is appropriate + -- for both subtype related attributes (Alignment and Size) and for + -- stream attributes, which, although certainly not subtype related + -- attributes, clearly should not be subject to the para 10 restrictions + -- (see AI95-00137). Similarly, we also skip the para 10 restrictions for + -- the Storage_Size case where they also clearly do not apply, and for + -- Stream_Convert which is in the same category as the stream attributes. + -- + -- If the rep item is too late, an appropriate message is output and + -- True is returned, which is a signal that the caller should abandon + -- processing for the item. If the item is not too late, then False + -- is returned, and the caller can continue processing the item. + -- + -- If no error is detected, this call also as a side effect links the + -- representation item onto the head of the representation item chain + -- (referenced by the First_Rep_Item field of the entity). + -- + -- Note: Rep_Item_Too_Late must be called with the underlying type in + -- the case of a private or incomplete type. The protocol is to first + -- check for Rep_Item_Too_Early using the initial entity, then take the + -- underlying type, then call Rep_Item_Too_Late on the result. + -- + -- Note: Calls to Rep_Item_Too_Late are ignored for the case of attribute + -- definition clauses which have From_Aspect_Specification set. This is + -- because such clauses are linked on to the Rep_Item chain in procedure + -- Sem_Ch13.Analyze_Aspect_Specifications. See that procedure for details. + + function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean; + -- Given two types, where the two types are related by possible derivation, + -- determines if the two types have the same representation, or different + -- representations, requiring the special processing for representation + -- change. A False result is possible only for array, enumeration or + -- record types. + + procedure Validate_Unchecked_Conversion + (N : Node_Id; + Act_Unit : Entity_Id); + -- Validate a call to unchecked conversion. N is the node for the actual + -- instantiation, which is used only for error messages. Act_Unit is the + -- entity for the instantiation, from which the actual types etc. for this + -- instantiation can be determined. This procedure makes an entry in a + -- table and/or generates an N_Validate_Unchecked_Conversion node. The + -- actual checking is done in Validate_Unchecked_Conversions or in the + -- back end as required. + + procedure Validate_Unchecked_Conversions; + -- This routine is called after calling the backend to validate unchecked + -- conversions for size and alignment appropriateness. The reason it is + -- called that late is to take advantage of any back-annotation of size + -- and alignment performed by the backend. + + procedure Validate_Address_Clauses; + -- This is called after the back end has been called (and thus after the + -- alignments of objects have been back annotated). It goes through the + -- table of saved address clauses checking for suspicious alignments and + -- if necessary issuing warnings. + + procedure Validate_Independence; + -- This is called after the back end has been called (and thus after the + -- layout of components has been back annotated). It goes through the + -- table of saved pragma Independent[_Component] entries, checking that + -- independence can be achieved, and if necessary issuing error messages. + + ------------------------------------- + -- Table for Validate_Independence -- + ------------------------------------- + + -- If a legal pragma Independent or Independent_Components is given for + -- an entity, then an entry is made in this table, to be checked by a + -- call to Validate_Independence after back annotation of layout is done. + + type Independence_Check_Record is record + N : Node_Id; + -- The pragma Independent or Independent_Components + + E : Entity_Id; + -- The entity to which it applies + end record; + + package Independence_Checks is new Table.Table ( + Table_Component_Type => Independence_Check_Record, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 200, + Table_Name => "Independence_Checks"); + +end Sem_Ch13; diff --git a/gcc/ada/sem_ch2.adb b/gcc/ada/sem_ch2.adb new file mode 100644 index 000000000..3a3bbf9d2 --- /dev/null +++ b/gcc/ada/sem_ch2.adb @@ -0,0 +1,126 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 2 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Errout; use Errout; +with Namet; use Namet; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Sem_Ch8; use Sem_Ch8; +with Sinfo; use Sinfo; +with Stand; use Stand; +with Uintp; use Uintp; + +package body Sem_Ch2 is + + ------------------------------- + -- Analyze_Character_Literal -- + ------------------------------- + + procedure Analyze_Character_Literal (N : Node_Id) is + begin + -- The type is eventually inherited from the context. If expansion + -- has already established the proper type, do not modify it. + + if No (Etype (N)) then + Set_Etype (N, Any_Character); + end if; + + Set_Is_Static_Expression (N); + + if Comes_From_Source (N) + and then not In_Character_Range (UI_To_CC (Char_Literal_Value (N))) + then + Check_Restriction (No_Wide_Characters, N); + end if; + end Analyze_Character_Literal; + + ------------------------ + -- Analyze_Identifier -- + ------------------------ + + procedure Analyze_Identifier (N : Node_Id) is + begin + -- Ignore call if prior errors, and identifier has no name, since + -- this is the result of some kind of previous error generating a + -- junk identifier. + + if Chars (N) in Error_Name_Or_No_Name + and then Total_Errors_Detected /= 0 + then + return; + else + Find_Direct_Name (N); + end if; + end Analyze_Identifier; + + ----------------------------- + -- Analyze_Integer_Literal -- + ----------------------------- + + procedure Analyze_Integer_Literal (N : Node_Id) is + begin + Set_Etype (N, Universal_Integer); + Set_Is_Static_Expression (N); + end Analyze_Integer_Literal; + + -------------------------- + -- Analyze_Real_Literal -- + -------------------------- + + procedure Analyze_Real_Literal (N : Node_Id) is + begin + Set_Etype (N, Universal_Real); + Set_Is_Static_Expression (N); + end Analyze_Real_Literal; + + ---------------------------- + -- Analyze_String_Literal -- + ---------------------------- + + procedure Analyze_String_Literal (N : Node_Id) is + begin + -- The type is eventually inherited from the context. If expansion + -- has already established the proper type, do not modify it. + + if No (Etype (N)) then + Set_Etype (N, Any_String); + end if; + + -- String literals are static in Ada 95. Note that if the subtype + -- turns out to be non-static, then the Is_Static_Expression flag + -- will be reset in Eval_String_Literal. + + if Ada_Version >= Ada_95 then + Set_Is_Static_Expression (N); + end if; + + if Comes_From_Source (N) and then Has_Wide_Character (N) then + Check_Restriction (No_Wide_Characters, N); + end if; + end Analyze_String_Literal; + +end Sem_Ch2; diff --git a/gcc/ada/sem_ch2.ads b/gcc/ada/sem_ch2.ads new file mode 100644 index 000000000..3e6a7b4e5 --- /dev/null +++ b/gcc/ada/sem_ch2.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Types; use Types; + +package Sem_Ch2 is + + procedure Analyze_Character_Literal (N : Node_Id); + procedure Analyze_Identifier (N : Node_Id); + procedure Analyze_Integer_Literal (N : Node_Id); + procedure Analyze_Real_Literal (N : Node_Id); + procedure Analyze_String_Literal (N : Node_Id); + +private + pragma Inline (Analyze_Character_Literal); + pragma Inline (Analyze_Identifier); + pragma Inline (Analyze_Integer_Literal); + pragma Inline (Analyze_Real_Literal); + pragma Inline (Analyze_String_Literal); + +end Sem_Ch2; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb new file mode 100644 index 000000000..0587b9a36 --- /dev/null +++ b/gcc/ada/sem_ch3.adb @@ -0,0 +1,19171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 3 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Aspects; use Aspects; +with Atree; use Atree; +with Checks; use Checks; +with Debug; use Debug; +with Elists; use Elists; +with Einfo; use Einfo; +with Errout; use Errout; +with Eval_Fat; use Eval_Fat; +with Exp_Ch3; use Exp_Ch3; +with Exp_Ch9; use Exp_Ch9; +with Exp_Disp; use Exp_Disp; +with Exp_Dist; use Exp_Dist; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Fname; use Fname; +with Freeze; use Freeze; +with Itypes; use Itypes; +with Layout; use Layout; +with Lib; use Lib; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Case; use Sem_Case; +with Sem_Cat; use Sem_Cat; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch7; use Sem_Ch7; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch13; use Sem_Ch13; +with Sem_Disp; use Sem_Disp; +with Sem_Dist; use Sem_Dist; +with Sem_Elim; use Sem_Elim; +with Sem_Eval; use Sem_Eval; +with Sem_Mech; use Sem_Mech; +with Sem_Prag; use Sem_Prag; +with Sem_Res; use Sem_Res; +with Sem_Smem; use Sem_Smem; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package body Sem_Ch3 is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id); + -- Ada 2005 (AI-251): Add the tag components corresponding to all the + -- abstract interface types implemented by a record type or a derived + -- record type. + + procedure Build_Derived_Type + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id; + Is_Completion : Boolean; + Derive_Subps : Boolean := True); + -- Create and decorate a Derived_Type given the Parent_Type entity. N is + -- the N_Full_Type_Declaration node containing the derived type definition. + -- Parent_Type is the entity for the parent type in the derived type + -- definition and Derived_Type the actual derived type. Is_Completion must + -- be set to False if Derived_Type is the N_Defining_Identifier node in N + -- (i.e. Derived_Type = Defining_Identifier (N)). In this case N is not the + -- completion of a private type declaration. If Is_Completion is set to + -- True, N is the completion of a private type declaration and Derived_Type + -- is different from the defining identifier inside N (i.e. Derived_Type /= + -- Defining_Identifier (N)). Derive_Subps indicates whether the parent + -- subprograms should be derived. The only case where this parameter is + -- False is when Build_Derived_Type is recursively called to process an + -- implicit derived full type for a type derived from a private type (in + -- that case the subprograms must only be derived for the private view of + -- the type). + -- + -- ??? These flags need a bit of re-examination and re-documentation: + -- ??? are they both necessary (both seem related to the recursion)? + + procedure Build_Derived_Access_Type + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id); + -- Subsidiary procedure to Build_Derived_Type. For a derived access type, + -- create an implicit base if the parent type is constrained or if the + -- subtype indication has a constraint. + + procedure Build_Derived_Array_Type + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id); + -- Subsidiary procedure to Build_Derived_Type. For a derived array type, + -- create an implicit base if the parent type is constrained or if the + -- subtype indication has a constraint. + + procedure Build_Derived_Concurrent_Type + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id); + -- Subsidiary procedure to Build_Derived_Type. For a derived task or + -- protected type, inherit entries and protected subprograms, check + -- legality of discriminant constraints if any. + + procedure Build_Derived_Enumeration_Type + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id); + -- Subsidiary procedure to Build_Derived_Type. For a derived enumeration + -- type, we must create a new list of literals. Types derived from + -- Character and [Wide_]Wide_Character are special-cased. + + procedure Build_Derived_Numeric_Type + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id); + -- Subsidiary procedure to Build_Derived_Type. For numeric types, create + -- an anonymous base type, and propagate constraint to subtype if needed. + + procedure Build_Derived_Private_Type + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id; + Is_Completion : Boolean; + Derive_Subps : Boolean := True); + -- Subsidiary procedure to Build_Derived_Type. This procedure is complex + -- because the parent may or may not have a completion, and the derivation + -- may itself be a completion. + + procedure Build_Derived_Record_Type + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id; + Derive_Subps : Boolean := True); + -- Subsidiary procedure for Build_Derived_Type and + -- Analyze_Private_Extension_Declaration used for tagged and untagged + -- record types. All parameters are as in Build_Derived_Type except that + -- N, in addition to being an N_Full_Type_Declaration node, can also be an + -- N_Private_Extension_Declaration node. See the definition of this routine + -- for much more info. Derive_Subps indicates whether subprograms should + -- be derived from the parent type. The only case where Derive_Subps is + -- False is for an implicit derived full type for a type derived from a + -- private type (see Build_Derived_Type). + + procedure Build_Discriminal (Discrim : Entity_Id); + -- Create the discriminal corresponding to discriminant Discrim, that is + -- the parameter corresponding to Discrim to be used in initialization + -- procedures for the type where Discrim is a discriminant. Discriminals + -- are not used during semantic analysis, and are not fully defined + -- entities until expansion. Thus they are not given a scope until + -- initialization procedures are built. + + function Build_Discriminant_Constraints + (T : Entity_Id; + Def : Node_Id; + Derived_Def : Boolean := False) return Elist_Id; + -- Validate discriminant constraints and return the list of the constraints + -- in order of discriminant declarations, where T is the discriminated + -- unconstrained type. Def is the N_Subtype_Indication node where the + -- discriminants constraints for T are specified. Derived_Def is True + -- when building the discriminant constraints in a derived type definition + -- of the form "type D (...) is new T (xxx)". In this case T is the parent + -- type and Def is the constraint "(xxx)" on T and this routine sets the + -- Corresponding_Discriminant field of the discriminants in the derived + -- type D to point to the corresponding discriminants in the parent type T. + + procedure Build_Discriminated_Subtype + (T : Entity_Id; + Def_Id : Entity_Id; + Elist : Elist_Id; + Related_Nod : Node_Id; + For_Access : Boolean := False); + -- Subsidiary procedure to Constrain_Discriminated_Type and to + -- Process_Incomplete_Dependents. Given + -- + -- T (a possibly discriminated base type) + -- Def_Id (a very partially built subtype for T), + -- + -- the call completes Def_Id to be the appropriate E_*_Subtype. + -- + -- The Elist is the list of discriminant constraints if any (it is set + -- to No_Elist if T is not a discriminated type, and to an empty list if + -- T has discriminants but there are no discriminant constraints). The + -- Related_Nod is the same as Decl_Node in Create_Constrained_Components. + -- The For_Access says whether or not this subtype is really constraining + -- an access type. That is its sole purpose is the designated type of an + -- access type -- in which case a Private_Subtype Is_For_Access_Subtype + -- is built to avoid freezing T when the access subtype is frozen. + + function Build_Scalar_Bound + (Bound : Node_Id; + Par_T : Entity_Id; + Der_T : Entity_Id) return Node_Id; + -- The bounds of a derived scalar type are conversions of the bounds of + -- the parent type. Optimize the representation if the bounds are literals. + -- Needs a more complete spec--what are the parameters exactly, and what + -- exactly is the returned value, and how is Bound affected??? + + procedure Build_Underlying_Full_View + (N : Node_Id; + Typ : Entity_Id; + Par : Entity_Id); + -- If the completion of a private type is itself derived from a private + -- type, or if the full view of a private subtype is itself private, the + -- back-end has no way to compute the actual size of this type. We build + -- an internal subtype declaration of the proper parent type to convey + -- this information. This extra mechanism is needed because a full + -- view cannot itself have a full view (it would get clobbered during + -- view exchanges). + + procedure Check_Access_Discriminant_Requires_Limited + (D : Node_Id; + Loc : Node_Id); + -- Check the restriction that the type to which an access discriminant + -- belongs must be a concurrent type or a descendant of a type with + -- the reserved word 'limited' in its declaration. + + procedure Check_Anonymous_Access_Components + (Typ_Decl : Node_Id; + Typ : Entity_Id; + Prev : Entity_Id; + Comp_List : Node_Id); + -- Ada 2005 AI-382: an access component in a record definition can refer to + -- the enclosing record, in which case it denotes the type itself, and not + -- the current instance of the type. We create an anonymous access type for + -- the component, and flag it as an access to a component, so accessibility + -- checks are properly performed on it. The declaration of the access type + -- is placed ahead of that of the record to prevent order-of-elaboration + -- circularity issues in Gigi. We create an incomplete type for the record + -- declaration, which is the designated type of the anonymous access. + + procedure Check_Delta_Expression (E : Node_Id); + -- Check that the expression represented by E is suitable for use as a + -- delta expression, i.e. it is of real type and is static. + + procedure Check_Digits_Expression (E : Node_Id); + -- Check that the expression represented by E is suitable for use as a + -- digits expression, i.e. it is of integer type, positive and static. + + procedure Check_Initialization (T : Entity_Id; Exp : Node_Id); + -- Validate the initialization of an object declaration. T is the required + -- type, and Exp is the initialization expression. + + procedure Check_Interfaces (N : Node_Id; Def : Node_Id); + -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) + + procedure Check_Or_Process_Discriminants + (N : Node_Id; + T : Entity_Id; + Prev : Entity_Id := Empty); + -- If N is the full declaration of the completion T of an incomplete or + -- private type, check its discriminants (which are already known to be + -- conformant with those of the partial view, see Find_Type_Name), + -- otherwise process them. Prev is the entity of the partial declaration, + -- if any. + + procedure Check_Real_Bound (Bound : Node_Id); + -- Check given bound for being of real type and static. If not, post an + -- appropriate message, and rewrite the bound with the real literal zero. + + procedure Constant_Redeclaration + (Id : Entity_Id; + N : Node_Id; + T : out Entity_Id); + -- Various checks on legality of full declaration of deferred constant. + -- Id is the entity for the redeclaration, N is the N_Object_Declaration, + -- node. The caller has not yet set any attributes of this entity. + + function Contain_Interface + (Iface : Entity_Id; + Ifaces : Elist_Id) return Boolean; + -- Ada 2005: Determine whether Iface is present in the list Ifaces + + procedure Convert_Scalar_Bounds + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id; + Loc : Source_Ptr); + -- For derived scalar types, convert the bounds in the type definition to + -- the derived type, and complete their analysis. Given a constraint of the + -- form ".. new T range Lo .. Hi", Lo and Hi are analyzed and resolved with + -- T'Base, the parent_type. The bounds of the derived type (the anonymous + -- base) are copies of Lo and Hi. Finally, the bounds of the derived + -- subtype are conversions of those bounds to the derived_type, so that + -- their typing is consistent. + + procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id); + -- Copies attributes from array base type T2 to array base type T1. Copies + -- only attributes that apply to base types, but not subtypes. + + procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id); + -- Copies attributes from array subtype T2 to array subtype T1. Copies + -- attributes that apply to both subtypes and base types. + + procedure Create_Constrained_Components + (Subt : Entity_Id; + Decl_Node : Node_Id; + Typ : Entity_Id; + Constraints : Elist_Id); + -- Build the list of entities for a constrained discriminated record + -- subtype. If a component depends on a discriminant, replace its subtype + -- using the discriminant values in the discriminant constraint. Subt + -- is the defining identifier for the subtype whose list of constrained + -- entities we will create. Decl_Node is the type declaration node where + -- we will attach all the itypes created. Typ is the base discriminated + -- type for the subtype Subt. Constraints is the list of discriminant + -- constraints for Typ. + + function Constrain_Component_Type + (Comp : Entity_Id; + Constrained_Typ : Entity_Id; + Related_Node : Node_Id; + Typ : Entity_Id; + Constraints : Elist_Id) return Entity_Id; + -- Given a discriminated base type Typ, a list of discriminant constraint + -- Constraints for Typ and a component of Typ, with type Compon_Type, + -- create and return the type corresponding to Compon_type where all + -- discriminant references are replaced with the corresponding constraint. + -- If no discriminant references occur in Compon_Typ then return it as is. + -- Constrained_Typ is the final constrained subtype to which the + -- constrained Compon_Type belongs. Related_Node is the node where we will + -- attach all the itypes created. + -- + -- Above description is confused, what is Compon_Type??? + + procedure Constrain_Access + (Def_Id : in out Entity_Id; + S : Node_Id; + Related_Nod : Node_Id); + -- Apply a list of constraints to an access type. If Def_Id is empty, it is + -- an anonymous type created for a subtype indication. In that case it is + -- created in the procedure and attached to Related_Nod. + + procedure Constrain_Array + (Def_Id : in out Entity_Id; + SI : Node_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id; + Suffix : Character); + -- Apply a list of index constraints to an unconstrained array type. The + -- first parameter is the entity for the resulting subtype. A value of + -- Empty for Def_Id indicates that an implicit type must be created, but + -- creation is delayed (and must be done by this procedure) because other + -- subsidiary implicit types must be created first (which is why Def_Id + -- is an in/out parameter). The second parameter is a subtype indication + -- node for the constrained array to be created (e.g. something of the + -- form string (1 .. 10)). Related_Nod gives the place where this type + -- has to be inserted in the tree. The Related_Id and Suffix parameters + -- are used to build the associated Implicit type name. + + procedure Constrain_Concurrent + (Def_Id : in out Entity_Id; + SI : Node_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id; + Suffix : Character); + -- Apply list of discriminant constraints to an unconstrained concurrent + -- type. + -- + -- SI is the N_Subtype_Indication node containing the constraint and + -- the unconstrained type to constrain. + -- + -- Def_Id is the entity for the resulting constrained subtype. A value + -- of Empty for Def_Id indicates that an implicit type must be created, + -- but creation is delayed (and must be done by this procedure) because + -- other subsidiary implicit types must be created first (which is why + -- Def_Id is an in/out parameter). + -- + -- Related_Nod gives the place where this type has to be inserted + -- in the tree + -- + -- The last two arguments are used to create its external name if needed. + + function Constrain_Corresponding_Record + (Prot_Subt : Entity_Id; + Corr_Rec : Entity_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id) return Entity_Id; + -- When constraining a protected type or task type with discriminants, + -- constrain the corresponding record with the same discriminant values. + + procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id); + -- Constrain a decimal fixed point type with a digits constraint and/or a + -- range constraint, and build E_Decimal_Fixed_Point_Subtype entity. + + procedure Constrain_Discriminated_Type + (Def_Id : Entity_Id; + S : Node_Id; + Related_Nod : Node_Id; + For_Access : Boolean := False); + -- Process discriminant constraints of composite type. Verify that values + -- have been provided for all discriminants, that the original type is + -- unconstrained, and that the types of the supplied expressions match + -- the discriminant types. The first three parameters are like in routine + -- Constrain_Concurrent. See Build_Discriminated_Subtype for an explanation + -- of For_Access. + + procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id); + -- Constrain an enumeration type with a range constraint. This is identical + -- to Constrain_Integer, but for the Ekind of the resulting subtype. + + procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id); + -- Constrain a floating point type with either a digits constraint + -- and/or a range constraint, building a E_Floating_Point_Subtype. + + procedure Constrain_Index + (Index : Node_Id; + S : Node_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id; + Suffix : Character; + Suffix_Index : Nat); + -- Process an index constraint S in a constrained array declaration. The + -- constraint can be a subtype name, or a range with or without an explicit + -- subtype mark. The index is the corresponding index of the unconstrained + -- array. The Related_Id and Suffix parameters are used to build the + -- associated Implicit type name. + + procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id); + -- Build subtype of a signed or modular integer type + + procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id); + -- Constrain an ordinary fixed point type with a range constraint, and + -- build an E_Ordinary_Fixed_Point_Subtype entity. + + procedure Copy_And_Swap (Priv, Full : Entity_Id); + -- Copy the Priv entity into the entity of its full declaration then swap + -- the two entities in such a manner that the former private type is now + -- seen as a full type. + + procedure Decimal_Fixed_Point_Type_Declaration + (T : Entity_Id; + Def : Node_Id); + -- Create a new decimal fixed point type, and apply the constraint to + -- obtain a subtype of this new type. + + procedure Complete_Private_Subtype + (Priv : Entity_Id; + Full : Entity_Id; + Full_Base : Entity_Id; + Related_Nod : Node_Id); + -- Complete the implicit full view of a private subtype by setting the + -- appropriate semantic fields. If the full view of the parent is a record + -- type, build constrained components of subtype. + + procedure Derive_Progenitor_Subprograms + (Parent_Type : Entity_Id; + Tagged_Type : Entity_Id); + -- Ada 2005 (AI-251): To complete type derivation, collect the primitive + -- operations of progenitors of Tagged_Type, and replace the subsidiary + -- subtypes with Tagged_Type, to build the specs of the inherited interface + -- primitives. The derived primitives are aliased to those of the + -- interface. This routine takes care also of transferring to the full view + -- subprograms associated with the partial view of Tagged_Type that cover + -- interface primitives. + + procedure Derived_Standard_Character + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id); + -- Subsidiary procedure to Build_Derived_Enumeration_Type which handles + -- derivations from types Standard.Character and Standard.Wide_Character. + + procedure Derived_Type_Declaration + (T : Entity_Id; + N : Node_Id; + Is_Completion : Boolean); + -- Process a derived type declaration. Build_Derived_Type is invoked + -- to process the actual derived type definition. Parameters N and + -- Is_Completion have the same meaning as in Build_Derived_Type. + -- T is the N_Defining_Identifier for the entity defined in the + -- N_Full_Type_Declaration node N, that is T is the derived type. + + procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id); + -- Insert each literal in symbol table, as an overloadable identifier. Each + -- enumeration type is mapped into a sequence of integers, and each literal + -- is defined as a constant with integer value. If any of the literals are + -- character literals, the type is a character type, which means that + -- strings are legal aggregates for arrays of components of the type. + + function Expand_To_Stored_Constraint + (Typ : Entity_Id; + Constraint : Elist_Id) return Elist_Id; + -- Given a constraint (i.e. a list of expressions) on the discriminants of + -- Typ, expand it into a constraint on the stored discriminants and return + -- the new list of expressions constraining the stored discriminants. + + function Find_Type_Of_Object + (Obj_Def : Node_Id; + Related_Nod : Node_Id) return Entity_Id; + -- Get type entity for object referenced by Obj_Def, attaching the + -- implicit types generated to Related_Nod + + procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id); + -- Create a new float and apply the constraint to obtain subtype of it + + function Has_Range_Constraint (N : Node_Id) return Boolean; + -- Given an N_Subtype_Indication node N, return True if a range constraint + -- is present, either directly, or as part of a digits or delta constraint. + -- In addition, a digits constraint in the decimal case returns True, since + -- it establishes a default range if no explicit range is present. + + function Inherit_Components + (N : Node_Id; + Parent_Base : Entity_Id; + Derived_Base : Entity_Id; + Is_Tagged : Boolean; + Inherit_Discr : Boolean; + Discs : Elist_Id) return Elist_Id; + -- Called from Build_Derived_Record_Type to inherit the components of + -- Parent_Base (a base type) into the Derived_Base (the derived base type). + -- For more information on derived types and component inheritance please + -- consult the comment above the body of Build_Derived_Record_Type. + -- + -- N is the original derived type declaration + -- + -- Is_Tagged is set if we are dealing with tagged types + -- + -- If Inherit_Discr is set, Derived_Base inherits its discriminants from + -- Parent_Base, otherwise no discriminants are inherited. + -- + -- Discs gives the list of constraints that apply to Parent_Base in the + -- derived type declaration. If Discs is set to No_Elist, then we have + -- the following situation: + -- + -- type Parent (D1..Dn : ..) is [tagged] record ...; + -- type Derived is new Parent [with ...]; + -- + -- which gets treated as + -- + -- type Derived (D1..Dn : ..) is new Parent (D1,..,Dn) [with ...]; + -- + -- For untagged types the returned value is an association list. The list + -- starts from the association (Parent_Base => Derived_Base), and then it + -- contains a sequence of the associations of the form + -- + -- (Old_Component => New_Component), + -- + -- where Old_Component is the Entity_Id of a component in Parent_Base and + -- New_Component is the Entity_Id of the corresponding component in + -- Derived_Base. For untagged records, this association list is needed when + -- copying the record declaration for the derived base. In the tagged case + -- the value returned is irrelevant. + + function Is_Valid_Constraint_Kind + (T_Kind : Type_Kind; + Constraint_Kind : Node_Kind) return Boolean; + -- Returns True if it is legal to apply the given kind of constraint to the + -- given kind of type (index constraint to an array type, for example). + + procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id); + -- Create new modular type. Verify that modulus is in bounds and is + -- a power of two (implementation restriction). + + procedure New_Concatenation_Op (Typ : Entity_Id); + -- Create an abbreviated declaration for an operator in order to + -- materialize concatenation on array types. + + procedure Ordinary_Fixed_Point_Type_Declaration + (T : Entity_Id; + Def : Node_Id); + -- Create a new ordinary fixed point type, and apply the constraint to + -- obtain subtype of it. + + procedure Prepare_Private_Subtype_Completion + (Id : Entity_Id; + Related_Nod : Node_Id); + -- Id is a subtype of some private type. Creates the full declaration + -- associated with Id whenever possible, i.e. when the full declaration + -- of the base type is already known. Records each subtype into + -- Private_Dependents of the base type. + + procedure Process_Incomplete_Dependents + (N : Node_Id; + Full_T : Entity_Id; + Inc_T : Entity_Id); + -- Process all entities that depend on an incomplete type. There include + -- subtypes, subprogram types that mention the incomplete type in their + -- profiles, and subprogram with access parameters that designate the + -- incomplete type. + + -- Inc_T is the defining identifier of an incomplete type declaration, its + -- Ekind is E_Incomplete_Type. + -- + -- N is the corresponding N_Full_Type_Declaration for Inc_T. + -- + -- Full_T is N's defining identifier. + -- + -- Subtypes of incomplete types with discriminants are completed when the + -- parent type is. This is simpler than private subtypes, because they can + -- only appear in the same scope, and there is no need to exchange views. + -- Similarly, access_to_subprogram types may have a parameter or a return + -- type that is an incomplete type, and that must be replaced with the + -- full type. + -- + -- If the full type is tagged, subprogram with access parameters that + -- designated the incomplete may be primitive operations of the full type, + -- and have to be processed accordingly. + + procedure Process_Real_Range_Specification (Def : Node_Id); + -- Given the type definition for a real type, this procedure processes and + -- checks the real range specification of this type definition if one is + -- present. If errors are found, error messages are posted, and the + -- Real_Range_Specification of Def is reset to Empty. + + procedure Record_Type_Declaration + (T : Entity_Id; + N : Node_Id; + Prev : Entity_Id); + -- Process a record type declaration (for both untagged and tagged + -- records). Parameters T and N are exactly like in procedure + -- Derived_Type_Declaration, except that no flag Is_Completion is needed + -- for this routine. If this is the completion of an incomplete type + -- declaration, Prev is the entity of the incomplete declaration, used for + -- cross-referencing. Otherwise Prev = T. + + procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id); + -- This routine is used to process the actual record type definition (both + -- for untagged and tagged records). Def is a record type definition node. + -- This procedure analyzes the components in this record type definition. + -- Prev_T is the entity for the enclosing record type. It is provided so + -- that its Has_Task flag can be set if any of the component have Has_Task + -- set. If the declaration is the completion of an incomplete type + -- declaration, Prev_T is the original incomplete type, whose full view is + -- the record type. + + procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id); + -- Subsidiary to Build_Derived_Record_Type. For untagged records, we + -- build a copy of the declaration tree of the parent, and we create + -- independently the list of components for the derived type. Semantic + -- information uses the component entities, but record representation + -- clauses are validated on the declaration tree. This procedure replaces + -- discriminants and components in the declaration with those that have + -- been created by Inherit_Components. + + procedure Set_Fixed_Range + (E : Entity_Id; + Loc : Source_Ptr; + Lo : Ureal; + Hi : Ureal); + -- Build a range node with the given bounds and set it as the Scalar_Range + -- of the given fixed-point type entity. Loc is the source location used + -- for the constructed range. See body for further details. + + procedure Set_Scalar_Range_For_Subtype + (Def_Id : Entity_Id; + R : Node_Id; + Subt : Entity_Id); + -- This routine is used to set the scalar range field for a subtype given + -- Def_Id, the entity for the subtype, and R, the range expression for the + -- scalar range. Subt provides the parent subtype to be used to analyze, + -- resolve, and check the given range. + + procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id); + -- Create a new signed integer entity, and apply the constraint to obtain + -- the required first named subtype of this type. + + procedure Set_Stored_Constraint_From_Discriminant_Constraint + (E : Entity_Id); + -- E is some record type. This routine computes E's Stored_Constraint + -- from its Discriminant_Constraint. + + procedure Diagnose_Interface (N : Node_Id; E : Entity_Id); + -- Check that an entity in a list of progenitors is an interface, + -- emit error otherwise. + + ----------------------- + -- Access_Definition -- + ----------------------- + + function Access_Definition + (Related_Nod : Node_Id; + N : Node_Id) return Entity_Id + is + Loc : constant Source_Ptr := Sloc (Related_Nod); + Anon_Type : Entity_Id; + Anon_Scope : Entity_Id; + Desig_Type : Entity_Id; + Decl : Entity_Id; + Enclosing_Prot_Type : Entity_Id := Empty; + + begin + if Is_Entry (Current_Scope) + and then Is_Task_Type (Etype (Scope (Current_Scope))) + then + Error_Msg_N ("task entries cannot have access parameters", N); + return Empty; + end if; + + -- Ada 2005: for an object declaration the corresponding anonymous + -- type is declared in the current scope. + + -- If the access definition is the return type of another access to + -- function, scope is the current one, because it is the one of the + -- current type declaration. + + if Nkind_In (Related_Nod, N_Object_Declaration, + N_Access_Function_Definition) + then + Anon_Scope := Current_Scope; + + -- For the anonymous function result case, retrieve the scope of the + -- function specification's associated entity rather than using the + -- current scope. The current scope will be the function itself if the + -- formal part is currently being analyzed, but will be the parent scope + -- in the case of a parameterless function, and we always want to use + -- the function's parent scope. Finally, if the function is a child + -- unit, we must traverse the tree to retrieve the proper entity. + + elsif Nkind (Related_Nod) = N_Function_Specification + and then Nkind (Parent (N)) /= N_Parameter_Specification + then + -- If the current scope is a protected type, the anonymous access + -- is associated with one of the protected operations, and must + -- be available in the scope that encloses the protected declaration. + -- Otherwise the type is in the scope enclosing the subprogram. + + -- If the function has formals, The return type of a subprogram + -- declaration is analyzed in the scope of the subprogram (see + -- Process_Formals) and thus the protected type, if present, is + -- the scope of the current function scope. + + if Ekind (Current_Scope) = E_Protected_Type then + Enclosing_Prot_Type := Current_Scope; + + elsif Ekind (Current_Scope) = E_Function + and then Ekind (Scope (Current_Scope)) = E_Protected_Type + then + Enclosing_Prot_Type := Scope (Current_Scope); + end if; + + if Present (Enclosing_Prot_Type) then + Anon_Scope := Scope (Enclosing_Prot_Type); + + else + Anon_Scope := Scope (Defining_Entity (Related_Nod)); + end if; + + else + -- For access formals, access components, and access discriminants, + -- the scope is that of the enclosing declaration, + + Anon_Scope := Scope (Current_Scope); + end if; + + Anon_Type := + Create_Itype + (E_Anonymous_Access_Type, Related_Nod, Scope_Id => Anon_Scope); + + if All_Present (N) + and then Ada_Version >= Ada_2005 + then + Error_Msg_N ("ALL is not permitted for anonymous access types", N); + end if; + + -- Ada 2005 (AI-254): In case of anonymous access to subprograms call + -- the corresponding semantic routine + + if Present (Access_To_Subprogram_Definition (N)) then + Access_Subprogram_Declaration + (T_Name => Anon_Type, + T_Def => Access_To_Subprogram_Definition (N)); + + if Ekind (Anon_Type) = E_Access_Protected_Subprogram_Type then + Set_Ekind + (Anon_Type, E_Anonymous_Access_Protected_Subprogram_Type); + else + Set_Ekind + (Anon_Type, E_Anonymous_Access_Subprogram_Type); + end if; + + Set_Can_Use_Internal_Rep + (Anon_Type, not Always_Compatible_Rep_On_Target); + + -- If the anonymous access is associated with a protected operation + -- create a reference to it after the enclosing protected definition + -- because the itype will be used in the subsequent bodies. + + if Ekind (Current_Scope) = E_Protected_Type then + Build_Itype_Reference (Anon_Type, Parent (Current_Scope)); + end if; + + return Anon_Type; + end if; + + Find_Type (Subtype_Mark (N)); + Desig_Type := Entity (Subtype_Mark (N)); + + Set_Directly_Designated_Type (Anon_Type, Desig_Type); + Set_Etype (Anon_Type, Anon_Type); + + -- Make sure the anonymous access type has size and alignment fields + -- set, as required by gigi. This is necessary in the case of the + -- Task_Body_Procedure. + + if not Has_Private_Component (Desig_Type) then + Layout_Type (Anon_Type); + end if; + + -- Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs + -- from Ada 95 semantics. In Ada 2005, anonymous access must specify if + -- the null value is allowed. In Ada 95 the null value is never allowed. + + if Ada_Version >= Ada_2005 then + Set_Can_Never_Be_Null (Anon_Type, Null_Exclusion_Present (N)); + else + Set_Can_Never_Be_Null (Anon_Type, True); + end if; + + -- The anonymous access type is as public as the discriminated type or + -- subprogram that defines it. It is imported (for back-end purposes) + -- if the designated type is. + + Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type))); + + -- Ada 2005 (AI-231): Propagate the access-constant attribute + + Set_Is_Access_Constant (Anon_Type, Constant_Present (N)); + + -- The context is either a subprogram declaration, object declaration, + -- or an access discriminant, in a private or a full type declaration. + -- In the case of a subprogram, if the designated type is incomplete, + -- the operation will be a primitive operation of the full type, to be + -- updated subsequently. If the type is imported through a limited_with + -- clause, the subprogram is not a primitive operation of the type + -- (which is declared elsewhere in some other scope). + + if Ekind (Desig_Type) = E_Incomplete_Type + and then not From_With_Type (Desig_Type) + and then Is_Overloadable (Current_Scope) + then + Append_Elmt (Current_Scope, Private_Dependents (Desig_Type)); + Set_Has_Delayed_Freeze (Current_Scope); + end if; + + -- Ada 2005: if the designated type is an interface that may contain + -- tasks, create a Master entity for the declaration. This must be done + -- before expansion of the full declaration, because the declaration may + -- include an expression that is an allocator, whose expansion needs the + -- proper Master for the created tasks. + + if Nkind (Related_Nod) = N_Object_Declaration + and then Expander_Active + then + if Is_Interface (Desig_Type) + and then Is_Limited_Record (Desig_Type) + then + Build_Class_Wide_Master (Anon_Type); + + -- Similarly, if the type is an anonymous access that designates + -- tasks, create a master entity for it in the current context. + + elsif Has_Task (Desig_Type) + and then Comes_From_Source (Related_Nod) + and then not Restriction_Active (No_Task_Hierarchy) + then + if not Has_Master_Entity (Current_Scope) then + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uMaster), + Constant_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Master_Id), Loc), + Expression => + Make_Explicit_Dereference (Loc, + New_Reference_To (RTE (RE_Current_Master), Loc))); + + Insert_Before (Related_Nod, Decl); + Analyze (Decl); + + Set_Master_Id (Anon_Type, Defining_Identifier (Decl)); + Set_Has_Master_Entity (Current_Scope); + else + Build_Master_Renaming (Related_Nod, Anon_Type); + end if; + end if; + end if; + + -- For a private component of a protected type, it is imperative that + -- the back-end elaborate the type immediately after the protected + -- declaration, because this type will be used in the declarations + -- created for the component within each protected body, so we must + -- create an itype reference for it now. + + if Nkind (Parent (Related_Nod)) = N_Protected_Definition then + Build_Itype_Reference (Anon_Type, Parent (Parent (Related_Nod))); + + -- Similarly, if the access definition is the return result of a + -- function, create an itype reference for it because it will be used + -- within the function body. For a regular function that is not a + -- compilation unit, insert reference after the declaration. For a + -- protected operation, insert it after the enclosing protected type + -- declaration. In either case, do not create a reference for a type + -- obtained through a limited_with clause, because this would introduce + -- semantic dependencies. + + -- Similarly, do not create a reference if the designated type is a + -- generic formal, because no use of it will reach the backend. + + elsif Nkind (Related_Nod) = N_Function_Specification + and then not From_With_Type (Desig_Type) + and then not Is_Generic_Type (Desig_Type) + then + if Present (Enclosing_Prot_Type) then + Build_Itype_Reference (Anon_Type, Parent (Enclosing_Prot_Type)); + + elsif Is_List_Member (Parent (Related_Nod)) + and then Nkind (Parent (N)) /= N_Parameter_Specification + then + Build_Itype_Reference (Anon_Type, Parent (Related_Nod)); + end if; + + -- Finally, create an itype reference for an object declaration of an + -- anonymous access type. This is strictly necessary only for deferred + -- constants, but in any case will avoid out-of-scope problems in the + -- back-end. + + elsif Nkind (Related_Nod) = N_Object_Declaration then + Build_Itype_Reference (Anon_Type, Related_Nod); + end if; + + return Anon_Type; + end Access_Definition; + + ----------------------------------- + -- Access_Subprogram_Declaration -- + ----------------------------------- + + procedure Access_Subprogram_Declaration + (T_Name : Entity_Id; + T_Def : Node_Id) + is + + procedure Check_For_Premature_Usage (Def : Node_Id); + -- Check that type T_Name is not used, directly or recursively, as a + -- parameter or a return type in Def. Def is either a subtype, an + -- access_definition, or an access_to_subprogram_definition. + + ------------------------------- + -- Check_For_Premature_Usage -- + ------------------------------- + + procedure Check_For_Premature_Usage (Def : Node_Id) is + Param : Node_Id; + + begin + -- Check for a subtype mark + + if Nkind (Def) in N_Has_Etype then + if Etype (Def) = T_Name then + Error_Msg_N + ("type& cannot be used before end of its declaration", Def); + end if; + + -- If this is not a subtype, then this is an access_definition + + elsif Nkind (Def) = N_Access_Definition then + if Present (Access_To_Subprogram_Definition (Def)) then + Check_For_Premature_Usage + (Access_To_Subprogram_Definition (Def)); + else + Check_For_Premature_Usage (Subtype_Mark (Def)); + end if; + + -- The only cases left are N_Access_Function_Definition and + -- N_Access_Procedure_Definition. + + else + if Present (Parameter_Specifications (Def)) then + Param := First (Parameter_Specifications (Def)); + while Present (Param) loop + Check_For_Premature_Usage (Parameter_Type (Param)); + Param := Next (Param); + end loop; + end if; + + if Nkind (Def) = N_Access_Function_Definition then + Check_For_Premature_Usage (Result_Definition (Def)); + end if; + end if; + end Check_For_Premature_Usage; + + -- Local variables + + Formals : constant List_Id := Parameter_Specifications (T_Def); + Formal : Entity_Id; + D_Ityp : Node_Id; + Desig_Type : constant Entity_Id := + Create_Itype (E_Subprogram_Type, Parent (T_Def)); + + -- Start of processing for Access_Subprogram_Declaration + + begin + -- Associate the Itype node with the inner full-type declaration or + -- subprogram spec or entry body. This is required to handle nested + -- anonymous declarations. For example: + + -- procedure P + -- (X : access procedure + -- (Y : access procedure + -- (Z : access T))) + + D_Ityp := Associated_Node_For_Itype (Desig_Type); + while not (Nkind_In (D_Ityp, N_Full_Type_Declaration, + N_Private_Type_Declaration, + N_Private_Extension_Declaration, + N_Procedure_Specification, + N_Function_Specification, + N_Entry_Body) + + or else + Nkind_In (D_Ityp, N_Object_Declaration, + N_Object_Renaming_Declaration, + N_Formal_Object_Declaration, + N_Formal_Type_Declaration, + N_Task_Type_Declaration, + N_Protected_Type_Declaration)) + loop + D_Ityp := Parent (D_Ityp); + pragma Assert (D_Ityp /= Empty); + end loop; + + Set_Associated_Node_For_Itype (Desig_Type, D_Ityp); + + if Nkind_In (D_Ityp, N_Procedure_Specification, + N_Function_Specification) + then + Set_Scope (Desig_Type, Scope (Defining_Entity (D_Ityp))); + + elsif Nkind_In (D_Ityp, N_Full_Type_Declaration, + N_Object_Declaration, + N_Object_Renaming_Declaration, + N_Formal_Type_Declaration) + then + Set_Scope (Desig_Type, Scope (Defining_Identifier (D_Ityp))); + end if; + + if Nkind (T_Def) = N_Access_Function_Definition then + if Nkind (Result_Definition (T_Def)) = N_Access_Definition then + declare + Acc : constant Node_Id := Result_Definition (T_Def); + + begin + if Present (Access_To_Subprogram_Definition (Acc)) + and then + Protected_Present (Access_To_Subprogram_Definition (Acc)) + then + Set_Etype + (Desig_Type, + Replace_Anonymous_Access_To_Protected_Subprogram + (T_Def)); + + else + Set_Etype + (Desig_Type, + Access_Definition (T_Def, Result_Definition (T_Def))); + end if; + end; + + else + Analyze (Result_Definition (T_Def)); + + declare + Typ : constant Entity_Id := Entity (Result_Definition (T_Def)); + + begin + -- If a null exclusion is imposed on the result type, then + -- create a null-excluding itype (an access subtype) and use + -- it as the function's Etype. + + if Is_Access_Type (Typ) + and then Null_Exclusion_In_Return_Present (T_Def) + then + Set_Etype (Desig_Type, + Create_Null_Excluding_Itype + (T => Typ, + Related_Nod => T_Def, + Scope_Id => Current_Scope)); + + else + if From_With_Type (Typ) then + + -- AI05-151: Incomplete types are allowed in all basic + -- declarations, including access to subprograms. + + if Ada_Version >= Ada_2012 then + null; + + else + Error_Msg_NE + ("illegal use of incomplete type&", + Result_Definition (T_Def), Typ); + end if; + + elsif Ekind (Current_Scope) = E_Package + and then In_Private_Part (Current_Scope) + then + if Ekind (Typ) = E_Incomplete_Type then + Append_Elmt (Desig_Type, Private_Dependents (Typ)); + + elsif Is_Class_Wide_Type (Typ) + and then Ekind (Etype (Typ)) = E_Incomplete_Type + then + Append_Elmt + (Desig_Type, Private_Dependents (Etype (Typ))); + end if; + end if; + + Set_Etype (Desig_Type, Typ); + end if; + end; + end if; + + if not (Is_Type (Etype (Desig_Type))) then + Error_Msg_N + ("expect type in function specification", + Result_Definition (T_Def)); + end if; + + else + Set_Etype (Desig_Type, Standard_Void_Type); + end if; + + if Present (Formals) then + Push_Scope (Desig_Type); + + -- A bit of a kludge here. These kludges will be removed when Itypes + -- have proper parent pointers to their declarations??? + + -- Kludge 1) Link defining_identifier of formals. Required by + -- First_Formal to provide its functionality. + + declare + F : Node_Id; + + begin + F := First (Formals); + while Present (F) loop + if No (Parent (Defining_Identifier (F))) then + Set_Parent (Defining_Identifier (F), F); + end if; + + Next (F); + end loop; + end; + + Process_Formals (Formals, Parent (T_Def)); + + -- Kludge 2) End_Scope requires that the parent pointer be set to + -- something reasonable, but Itypes don't have parent pointers. So + -- we set it and then unset it ??? + + Set_Parent (Desig_Type, T_Name); + End_Scope; + Set_Parent (Desig_Type, Empty); + end if; + + -- Check for premature usage of the type being defined + + Check_For_Premature_Usage (T_Def); + + -- The return type and/or any parameter type may be incomplete. Mark + -- the subprogram_type as depending on the incomplete type, so that + -- it can be updated when the full type declaration is seen. This + -- only applies to incomplete types declared in some enclosing scope, + -- not to limited views from other packages. + + if Present (Formals) then + Formal := First_Formal (Desig_Type); + while Present (Formal) loop + if Ekind (Formal) /= E_In_Parameter + and then Nkind (T_Def) = N_Access_Function_Definition + then + Error_Msg_N ("functions can only have IN parameters", Formal); + end if; + + if Ekind (Etype (Formal)) = E_Incomplete_Type + and then In_Open_Scopes (Scope (Etype (Formal))) + then + Append_Elmt (Desig_Type, Private_Dependents (Etype (Formal))); + Set_Has_Delayed_Freeze (Desig_Type); + end if; + + Next_Formal (Formal); + end loop; + end if; + + -- If the return type is incomplete, this is legal as long as the + -- type is declared in the current scope and will be completed in + -- it (rather than being part of limited view). + + if Ekind (Etype (Desig_Type)) = E_Incomplete_Type + and then not Has_Delayed_Freeze (Desig_Type) + and then In_Open_Scopes (Scope (Etype (Desig_Type))) + then + Append_Elmt (Desig_Type, Private_Dependents (Etype (Desig_Type))); + Set_Has_Delayed_Freeze (Desig_Type); + end if; + + Check_Delayed_Subprogram (Desig_Type); + + if Protected_Present (T_Def) then + Set_Ekind (T_Name, E_Access_Protected_Subprogram_Type); + Set_Convention (Desig_Type, Convention_Protected); + else + Set_Ekind (T_Name, E_Access_Subprogram_Type); + end if; + + Set_Can_Use_Internal_Rep (T_Name, not Always_Compatible_Rep_On_Target); + + Set_Etype (T_Name, T_Name); + Init_Size_Align (T_Name); + Set_Directly_Designated_Type (T_Name, Desig_Type); + + -- Ada 2005 (AI-231): Propagate the null-excluding attribute + + Set_Can_Never_Be_Null (T_Name, Null_Exclusion_Present (T_Def)); + + Check_Restriction (No_Access_Subprograms, T_Def); + end Access_Subprogram_Declaration; + + ---------------------------- + -- Access_Type_Declaration -- + ---------------------------- + + procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id) is + S : constant Node_Id := Subtype_Indication (Def); + P : constant Node_Id := Parent (Def); + begin + -- Check for permissible use of incomplete type + + if Nkind (S) /= N_Subtype_Indication then + Analyze (S); + + if Ekind (Root_Type (Entity (S))) = E_Incomplete_Type then + Set_Directly_Designated_Type (T, Entity (S)); + else + Set_Directly_Designated_Type (T, + Process_Subtype (S, P, T, 'P')); + end if; + + else + Set_Directly_Designated_Type (T, + Process_Subtype (S, P, T, 'P')); + end if; + + if All_Present (Def) or Constant_Present (Def) then + Set_Ekind (T, E_General_Access_Type); + else + Set_Ekind (T, E_Access_Type); + end if; + + if Base_Type (Designated_Type (T)) = T then + Error_Msg_N ("access type cannot designate itself", S); + + -- In Ada 2005, the type may have a limited view through some unit + -- in its own context, allowing the following circularity that cannot + -- be detected earlier + + elsif Is_Class_Wide_Type (Designated_Type (T)) + and then Etype (Designated_Type (T)) = T + then + Error_Msg_N + ("access type cannot designate its own classwide type", S); + + -- Clean up indication of tagged status to prevent cascaded errors + + Set_Is_Tagged_Type (T, False); + end if; + + Set_Etype (T, T); + + -- If the type has appeared already in a with_type clause, it is + -- frozen and the pointer size is already set. Else, initialize. + + if not From_With_Type (T) then + Init_Size_Align (T); + end if; + + -- Note that Has_Task is always false, since the access type itself + -- is not a task type. See Einfo for more description on this point. + -- Exactly the same consideration applies to Has_Controlled_Component. + + Set_Has_Task (T, False); + Set_Has_Controlled_Component (T, False); + + -- Initialize Associated_Final_Chain explicitly to Empty, to avoid + -- problems where an incomplete view of this entity has been previously + -- established by a limited with and an overlaid version of this field + -- (Stored_Constraint) was initialized for the incomplete view. + + Set_Associated_Final_Chain (T, Empty); + + -- Ada 2005 (AI-231): Propagate the null-excluding and access-constant + -- attributes + + Set_Can_Never_Be_Null (T, Null_Exclusion_Present (Def)); + Set_Is_Access_Constant (T, Constant_Present (Def)); + end Access_Type_Declaration; + + ---------------------------------- + -- Add_Interface_Tag_Components -- + ---------------------------------- + + procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + L : List_Id; + Last_Tag : Node_Id; + + procedure Add_Tag (Iface : Entity_Id); + -- Add tag for one of the progenitor interfaces + + ------------- + -- Add_Tag -- + ------------- + + procedure Add_Tag (Iface : Entity_Id) is + Decl : Node_Id; + Def : Node_Id; + Tag : Entity_Id; + Offset : Entity_Id; + + begin + pragma Assert (Is_Tagged_Type (Iface) + and then Is_Interface (Iface)); + + -- This is a reasonable place to propagate predicates + + if Has_Predicates (Iface) then + Set_Has_Predicates (Typ); + end if; + + Def := + Make_Component_Definition (Loc, + Aliased_Present => True, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Interface_Tag), Loc)); + + Tag := Make_Temporary (Loc, 'V'); + + Decl := + Make_Component_Declaration (Loc, + Defining_Identifier => Tag, + Component_Definition => Def); + + Analyze_Component_Declaration (Decl); + + Set_Analyzed (Decl); + Set_Ekind (Tag, E_Component); + Set_Is_Tag (Tag); + Set_Is_Aliased (Tag); + Set_Related_Type (Tag, Iface); + Init_Component_Location (Tag); + + pragma Assert (Is_Frozen (Iface)); + + Set_DT_Entry_Count (Tag, + DT_Entry_Count (First_Entity (Iface))); + + if No (Last_Tag) then + Prepend (Decl, L); + else + Insert_After (Last_Tag, Decl); + end if; + + Last_Tag := Decl; + + -- If the ancestor has discriminants we need to give special support + -- to store the offset_to_top value of the secondary dispatch tables. + -- For this purpose we add a supplementary component just after the + -- field that contains the tag associated with each secondary DT. + + if Typ /= Etype (Typ) + and then Has_Discriminants (Etype (Typ)) + then + Def := + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Storage_Offset), Loc)); + + Offset := Make_Temporary (Loc, 'V'); + + Decl := + Make_Component_Declaration (Loc, + Defining_Identifier => Offset, + Component_Definition => Def); + + Analyze_Component_Declaration (Decl); + + Set_Analyzed (Decl); + Set_Ekind (Offset, E_Component); + Set_Is_Aliased (Offset); + Set_Related_Type (Offset, Iface); + Init_Component_Location (Offset); + Insert_After (Last_Tag, Decl); + Last_Tag := Decl; + end if; + end Add_Tag; + + -- Local variables + + Elmt : Elmt_Id; + Ext : Node_Id; + Comp : Node_Id; + + -- Start of processing for Add_Interface_Tag_Components + + begin + if not RTE_Available (RE_Interface_Tag) then + Error_Msg + ("(Ada 2005) interface types not supported by this run-time!", + Sloc (N)); + return; + end if; + + if Ekind (Typ) /= E_Record_Type + or else (Is_Concurrent_Record_Type (Typ) + and then Is_Empty_List (Abstract_Interface_List (Typ))) + or else (not Is_Concurrent_Record_Type (Typ) + and then No (Interfaces (Typ)) + and then Is_Empty_Elmt_List (Interfaces (Typ))) + then + return; + end if; + + -- Find the current last tag + + if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then + Ext := Record_Extension_Part (Type_Definition (N)); + else + pragma Assert (Nkind (Type_Definition (N)) = N_Record_Definition); + Ext := Type_Definition (N); + end if; + + Last_Tag := Empty; + + if not (Present (Component_List (Ext))) then + Set_Null_Present (Ext, False); + L := New_List; + Set_Component_List (Ext, + Make_Component_List (Loc, + Component_Items => L, + Null_Present => False)); + else + if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then + L := Component_Items + (Component_List + (Record_Extension_Part + (Type_Definition (N)))); + else + L := Component_Items + (Component_List + (Type_Definition (N))); + end if; + + -- Find the last tag component + + Comp := First (L); + while Present (Comp) loop + if Nkind (Comp) = N_Component_Declaration + and then Is_Tag (Defining_Identifier (Comp)) + then + Last_Tag := Comp; + end if; + + Next (Comp); + end loop; + end if; + + -- At this point L references the list of components and Last_Tag + -- references the current last tag (if any). Now we add the tag + -- corresponding with all the interfaces that are not implemented + -- by the parent. + + if Present (Interfaces (Typ)) then + Elmt := First_Elmt (Interfaces (Typ)); + while Present (Elmt) loop + Add_Tag (Node (Elmt)); + Next_Elmt (Elmt); + end loop; + end if; + end Add_Interface_Tag_Components; + + ------------------------------------- + -- Add_Internal_Interface_Entities -- + ------------------------------------- + + procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is + Elmt : Elmt_Id; + Iface : Entity_Id; + Iface_Elmt : Elmt_Id; + Iface_Prim : Entity_Id; + Ifaces_List : Elist_Id; + New_Subp : Entity_Id := Empty; + Prim : Entity_Id; + Restore_Scope : Boolean := False; + + begin + pragma Assert (Ada_Version >= Ada_2005 + and then Is_Record_Type (Tagged_Type) + and then Is_Tagged_Type (Tagged_Type) + and then Has_Interfaces (Tagged_Type) + and then not Is_Interface (Tagged_Type)); + + -- Ensure that the internal entities are added to the scope of the type + + if Scope (Tagged_Type) /= Current_Scope then + Push_Scope (Scope (Tagged_Type)); + Restore_Scope := True; + end if; + + Collect_Interfaces (Tagged_Type, Ifaces_List); + + Iface_Elmt := First_Elmt (Ifaces_List); + while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); + + -- Originally we excluded here from this processing interfaces that + -- are parents of Tagged_Type because their primitives are located + -- in the primary dispatch table (and hence no auxiliary internal + -- entities are required to handle secondary dispatch tables in such + -- case). However, these auxiliary entities are also required to + -- handle derivations of interfaces in formals of generics (see + -- Derive_Subprograms). + + Elmt := First_Elmt (Primitive_Operations (Iface)); + while Present (Elmt) loop + Iface_Prim := Node (Elmt); + + if not Is_Predefined_Dispatching_Operation (Iface_Prim) then + Prim := + Find_Primitive_Covering_Interface + (Tagged_Type => Tagged_Type, + Iface_Prim => Iface_Prim); + + pragma Assert (Present (Prim)); + + -- Ada 2012 (AI05-0197): If the name of the covering primitive + -- differs from the name of the interface primitive then it is + -- a private primitive inherited from a parent type. In such + -- case, given that Tagged_Type covers the interface, the + -- inherited private primitive becomes visible. For such + -- purpose we add a new entity that renames the inherited + -- private primitive. + + if Chars (Prim) /= Chars (Iface_Prim) then + pragma Assert (Has_Suffix (Prim, 'P')); + Derive_Subprogram + (New_Subp => New_Subp, + Parent_Subp => Iface_Prim, + Derived_Type => Tagged_Type, + Parent_Type => Iface); + Set_Alias (New_Subp, Prim); + Set_Is_Abstract_Subprogram + (New_Subp, Is_Abstract_Subprogram (Prim)); + end if; + + Derive_Subprogram + (New_Subp => New_Subp, + Parent_Subp => Iface_Prim, + Derived_Type => Tagged_Type, + Parent_Type => Iface); + + -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp + -- associated with interface types. These entities are + -- only registered in the list of primitives of its + -- corresponding tagged type because they are only used + -- to fill the contents of the secondary dispatch tables. + -- Therefore they are removed from the homonym chains. + + Set_Is_Hidden (New_Subp); + Set_Is_Internal (New_Subp); + Set_Alias (New_Subp, Prim); + Set_Is_Abstract_Subprogram + (New_Subp, Is_Abstract_Subprogram (Prim)); + Set_Interface_Alias (New_Subp, Iface_Prim); + + -- Internal entities associated with interface types are + -- only registered in the list of primitives of the tagged + -- type. They are only used to fill the contents of the + -- secondary dispatch tables. Therefore they are not needed + -- in the homonym chains. + + Remove_Homonym (New_Subp); + + -- Hidden entities associated with interfaces must have set + -- the Has_Delay_Freeze attribute to ensure that, in case of + -- locally defined tagged types (or compiling with static + -- dispatch tables generation disabled) the corresponding + -- entry of the secondary dispatch table is filled when + -- such an entity is frozen. + + Set_Has_Delayed_Freeze (New_Subp); + end if; + + Next_Elmt (Elmt); + end loop; + + Next_Elmt (Iface_Elmt); + end loop; + + if Restore_Scope then + Pop_Scope; + end if; + end Add_Internal_Interface_Entities; + + ----------------------------------- + -- Analyze_Component_Declaration -- + ----------------------------------- + + procedure Analyze_Component_Declaration (N : Node_Id) is + Id : constant Entity_Id := Defining_Identifier (N); + E : constant Node_Id := Expression (N); + T : Entity_Id; + P : Entity_Id; + + function Contains_POC (Constr : Node_Id) return Boolean; + -- Determines whether a constraint uses the discriminant of a record + -- type thus becoming a per-object constraint (POC). + + function Is_Known_Limited (Typ : Entity_Id) return Boolean; + -- Typ is the type of the current component, check whether this type is + -- a limited type. Used to validate declaration against that of + -- enclosing record. + + ------------------ + -- Contains_POC -- + ------------------ + + function Contains_POC (Constr : Node_Id) return Boolean is + begin + -- Prevent cascaded errors + + if Error_Posted (Constr) then + return False; + end if; + + case Nkind (Constr) is + when N_Attribute_Reference => + return + Attribute_Name (Constr) = Name_Access + and then Prefix (Constr) = Scope (Entity (Prefix (Constr))); + + when N_Discriminant_Association => + return Denotes_Discriminant (Expression (Constr)); + + when N_Identifier => + return Denotes_Discriminant (Constr); + + when N_Index_Or_Discriminant_Constraint => + declare + IDC : Node_Id; + + begin + IDC := First (Constraints (Constr)); + while Present (IDC) loop + + -- One per-object constraint is sufficient + + if Contains_POC (IDC) then + return True; + end if; + + Next (IDC); + end loop; + + return False; + end; + + when N_Range => + return Denotes_Discriminant (Low_Bound (Constr)) + or else + Denotes_Discriminant (High_Bound (Constr)); + + when N_Range_Constraint => + return Denotes_Discriminant (Range_Expression (Constr)); + + when others => + return False; + + end case; + end Contains_POC; + + ---------------------- + -- Is_Known_Limited -- + ---------------------- + + function Is_Known_Limited (Typ : Entity_Id) return Boolean is + P : constant Entity_Id := Etype (Typ); + R : constant Entity_Id := Root_Type (Typ); + + begin + if Is_Limited_Record (Typ) then + return True; + + -- If the root type is limited (and not a limited interface) + -- so is the current type + + elsif Is_Limited_Record (R) + and then + (not Is_Interface (R) + or else not Is_Limited_Interface (R)) + then + return True; + + -- Else the type may have a limited interface progenitor, but a + -- limited record parent. + + elsif R /= P + and then Is_Limited_Record (P) + then + return True; + + else + return False; + end if; + end Is_Known_Limited; + + -- Start of processing for Analyze_Component_Declaration + + begin + Generate_Definition (Id); + Enter_Name (Id); + + if Present (Subtype_Indication (Component_Definition (N))) then + T := Find_Type_Of_Object + (Subtype_Indication (Component_Definition (N)), N); + + -- Ada 2005 (AI-230): Access Definition case + + else + pragma Assert (Present + (Access_Definition (Component_Definition (N)))); + + T := Access_Definition + (Related_Nod => N, + N => Access_Definition (Component_Definition (N))); + Set_Is_Local_Anonymous_Access (T); + + -- Ada 2005 (AI-254) + + if Present (Access_To_Subprogram_Definition + (Access_Definition (Component_Definition (N)))) + and then Protected_Present (Access_To_Subprogram_Definition + (Access_Definition + (Component_Definition (N)))) + then + T := Replace_Anonymous_Access_To_Protected_Subprogram (N); + end if; + end if; + + -- If the subtype is a constrained subtype of the enclosing record, + -- (which must have a partial view) the back-end does not properly + -- handle the recursion. Rewrite the component declaration with an + -- explicit subtype indication, which is acceptable to Gigi. We can copy + -- the tree directly because side effects have already been removed from + -- discriminant constraints. + + if Ekind (T) = E_Access_Subtype + and then Is_Entity_Name (Subtype_Indication (Component_Definition (N))) + and then Comes_From_Source (T) + and then Nkind (Parent (T)) = N_Subtype_Declaration + and then Etype (Directly_Designated_Type (T)) = Current_Scope + then + Rewrite + (Subtype_Indication (Component_Definition (N)), + New_Copy_Tree (Subtype_Indication (Parent (T)))); + T := Find_Type_Of_Object + (Subtype_Indication (Component_Definition (N)), N); + end if; + + -- If the component declaration includes a default expression, then we + -- check that the component is not of a limited type (RM 3.7(5)), + -- and do the special preanalysis of the expression (see section on + -- "Handling of Default and Per-Object Expressions" in the spec of + -- package Sem). + + if Present (E) then + Preanalyze_Spec_Expression (E, T); + Check_Initialization (T, E); + + if Ada_Version >= Ada_2005 + and then Ekind (T) = E_Anonymous_Access_Type + and then Etype (E) /= Any_Type + then + -- Check RM 3.9.2(9): "if the expected type for an expression is + -- an anonymous access-to-specific tagged type, then the object + -- designated by the expression shall not be dynamically tagged + -- unless it is a controlling operand in a call on a dispatching + -- operation" + + if Is_Tagged_Type (Directly_Designated_Type (T)) + and then + Ekind (Directly_Designated_Type (T)) /= E_Class_Wide_Type + and then + Ekind (Directly_Designated_Type (Etype (E))) = + E_Class_Wide_Type + then + Error_Msg_N + ("access to specific tagged type required (RM 3.9.2(9))", E); + end if; + + -- (Ada 2005: AI-230): Accessibility check for anonymous + -- components + + if Type_Access_Level (Etype (E)) > Type_Access_Level (T) then + Error_Msg_N + ("expression has deeper access level than component " & + "(RM 3.10.2 (12.2))", E); + end if; + + -- The initialization expression is a reference to an access + -- discriminant. The type of the discriminant is always deeper + -- than any access type. + + if Ekind (Etype (E)) = E_Anonymous_Access_Type + and then Is_Entity_Name (E) + and then Ekind (Entity (E)) = E_In_Parameter + and then Present (Discriminal_Link (Entity (E))) + then + Error_Msg_N + ("discriminant has deeper accessibility level than target", + E); + end if; + end if; + end if; + + -- The parent type may be a private view with unknown discriminants, + -- and thus unconstrained. Regular components must be constrained. + + if Is_Indefinite_Subtype (T) and then Chars (Id) /= Name_uParent then + if Is_Class_Wide_Type (T) then + Error_Msg_N + ("class-wide subtype with unknown discriminants" & + " in component declaration", + Subtype_Indication (Component_Definition (N))); + else + Error_Msg_N + ("unconstrained subtype in component declaration", + Subtype_Indication (Component_Definition (N))); + end if; + + -- Components cannot be abstract, except for the special case of + -- the _Parent field (case of extending an abstract tagged type) + + elsif Is_Abstract_Type (T) and then Chars (Id) /= Name_uParent then + Error_Msg_N ("type of a component cannot be abstract", N); + end if; + + Set_Etype (Id, T); + Set_Is_Aliased (Id, Aliased_Present (Component_Definition (N))); + + -- The component declaration may have a per-object constraint, set + -- the appropriate flag in the defining identifier of the subtype. + + if Present (Subtype_Indication (Component_Definition (N))) then + declare + Sindic : constant Node_Id := + Subtype_Indication (Component_Definition (N)); + begin + if Nkind (Sindic) = N_Subtype_Indication + and then Present (Constraint (Sindic)) + and then Contains_POC (Constraint (Sindic)) + then + Set_Has_Per_Object_Constraint (Id); + end if; + end; + end if; + + -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry + -- out some static checks. + + if Ada_Version >= Ada_2005 + and then Can_Never_Be_Null (T) + then + Null_Exclusion_Static_Checks (N); + end if; + + -- If this component is private (or depends on a private type), flag the + -- record type to indicate that some operations are not available. + + P := Private_Component (T); + + if Present (P) then + + -- Check for circular definitions + + if P = Any_Type then + Set_Etype (Id, Any_Type); + + -- There is a gap in the visibility of operations only if the + -- component type is not defined in the scope of the record type. + + elsif Scope (P) = Scope (Current_Scope) then + null; + + elsif Is_Limited_Type (P) then + Set_Is_Limited_Composite (Current_Scope); + + else + Set_Is_Private_Composite (Current_Scope); + end if; + end if; + + if P /= Any_Type + and then Is_Limited_Type (T) + and then Chars (Id) /= Name_uParent + and then Is_Tagged_Type (Current_Scope) + then + if Is_Derived_Type (Current_Scope) + and then not Is_Known_Limited (Current_Scope) + then + Error_Msg_N + ("extension of nonlimited type cannot have limited components", + N); + + if Is_Interface (Root_Type (Current_Scope)) then + Error_Msg_N + ("\limitedness is not inherited from limited interface", N); + Error_Msg_N ("\add LIMITED to type indication", N); + end if; + + Explain_Limited_Type (T, N); + Set_Etype (Id, Any_Type); + Set_Is_Limited_Composite (Current_Scope, False); + + elsif not Is_Derived_Type (Current_Scope) + and then not Is_Limited_Record (Current_Scope) + and then not Is_Concurrent_Type (Current_Scope) + then + Error_Msg_N + ("nonlimited tagged type cannot have limited components", N); + Explain_Limited_Type (T, N); + Set_Etype (Id, Any_Type); + Set_Is_Limited_Composite (Current_Scope, False); + end if; + end if; + + Set_Original_Record_Component (Id, Id); + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); + end Analyze_Component_Declaration; + + -------------------------- + -- Analyze_Declarations -- + -------------------------- + + procedure Analyze_Declarations (L : List_Id) is + D : Node_Id; + Freeze_From : Entity_Id := Empty; + Next_Node : Node_Id; + + procedure Adjust_D; + -- Adjust D not to include implicit label declarations, since these + -- have strange Sloc values that result in elaboration check problems. + -- (They have the sloc of the label as found in the source, and that + -- is ahead of the current declarative part). + + -------------- + -- Adjust_D -- + -------------- + + procedure Adjust_D is + begin + while Present (Prev (D)) + and then Nkind (D) = N_Implicit_Label_Declaration + loop + Prev (D); + end loop; + end Adjust_D; + + -- Start of processing for Analyze_Declarations + + begin + D := First (L); + while Present (D) loop + + -- Complete analysis of declaration + + Analyze (D); + Next_Node := Next (D); + + if No (Freeze_From) then + Freeze_From := First_Entity (Current_Scope); + end if; + + -- At the end of a declarative part, freeze remaining entities + -- declared in it. The end of the visible declarations of package + -- specification is not the end of a declarative part if private + -- declarations are present. The end of a package declaration is a + -- freezing point only if it a library package. A task definition or + -- protected type definition is not a freeze point either. Finally, + -- we do not freeze entities in generic scopes, because there is no + -- code generated for them and freeze nodes will be generated for + -- the instance. + + -- The end of a package instantiation is not a freeze point, but + -- for now we make it one, because the generic body is inserted + -- (currently) immediately after. Generic instantiations will not + -- be a freeze point once delayed freezing of bodies is implemented. + -- (This is needed in any case for early instantiations ???). + + if No (Next_Node) then + if Nkind_In (Parent (L), N_Component_List, + N_Task_Definition, + N_Protected_Definition) + then + null; + + elsif Nkind (Parent (L)) /= N_Package_Specification then + if Nkind (Parent (L)) = N_Package_Body then + Freeze_From := First_Entity (Current_Scope); + end if; + + Adjust_D; + Freeze_All (Freeze_From, D); + Freeze_From := Last_Entity (Current_Scope); + + elsif Scope (Current_Scope) /= Standard_Standard + and then not Is_Child_Unit (Current_Scope) + and then No (Generic_Parent (Parent (L))) + then + null; + + elsif L /= Visible_Declarations (Parent (L)) + or else No (Private_Declarations (Parent (L))) + or else Is_Empty_List (Private_Declarations (Parent (L))) + then + Adjust_D; + Freeze_All (Freeze_From, D); + Freeze_From := Last_Entity (Current_Scope); + end if; + + -- If next node is a body then freeze all types before the body. + -- An exception occurs for some expander-generated bodies. If these + -- are generated at places where in general language rules would not + -- allow a freeze point, then we assume that the expander has + -- explicitly checked that all required types are properly frozen, + -- and we do not cause general freezing here. This special circuit + -- is used when the encountered body is marked as having already + -- been analyzed. + + -- In all other cases (bodies that come from source, and expander + -- generated bodies that have not been analyzed yet), freeze all + -- types now. Note that in the latter case, the expander must take + -- care to attach the bodies at a proper place in the tree so as to + -- not cause unwanted freezing at that point. + + elsif not Analyzed (Next_Node) + and then (Nkind_In (Next_Node, N_Subprogram_Body, + N_Entry_Body, + N_Package_Body, + N_Protected_Body, + N_Task_Body) + or else + Nkind (Next_Node) in N_Body_Stub) + then + Adjust_D; + Freeze_All (Freeze_From, D); + Freeze_From := Last_Entity (Current_Scope); + end if; + + D := Next_Node; + end loop; + + -- One more thing to do, we need to scan the declarations to check + -- for any precondition/postcondition pragmas (Pre/Post aspects have + -- by this stage been converted into corresponding pragmas). It is + -- at this point that we analyze the expressions in such pragmas, + -- to implement the delayed visibility requirement. + + declare + Decl : Node_Id; + Spec : Node_Id; + Sent : Entity_Id; + Prag : Node_Id; + + begin + Decl := First (L); + while Present (Decl) loop + if Nkind (Original_Node (Decl)) = N_Subprogram_Declaration then + Spec := Specification (Original_Node (Decl)); + Sent := Defining_Unit_Name (Spec); + Prag := Spec_PPC_List (Sent); + while Present (Prag) loop + Analyze_PPC_In_Decl_Part (Prag, Sent); + Prag := Next_Pragma (Prag); + end loop; + end if; + + Next (Decl); + end loop; + end; + end Analyze_Declarations; + + ----------------------------------- + -- Analyze_Full_Type_Declaration -- + ----------------------------------- + + procedure Analyze_Full_Type_Declaration (N : Node_Id) is + Def : constant Node_Id := Type_Definition (N); + Def_Id : constant Entity_Id := Defining_Identifier (N); + T : Entity_Id; + Prev : Entity_Id; + + Is_Remote : constant Boolean := + (Is_Remote_Types (Current_Scope) + or else Is_Remote_Call_Interface (Current_Scope)) + and then not (In_Private_Part (Current_Scope) + or else In_Package_Body (Current_Scope)); + + procedure Check_Ops_From_Incomplete_Type; + -- If there is a tagged incomplete partial view of the type, transfer + -- its operations to the full view, and indicate that the type of the + -- controlling parameter (s) is this full view. + + ------------------------------------ + -- Check_Ops_From_Incomplete_Type -- + ------------------------------------ + + procedure Check_Ops_From_Incomplete_Type is + Elmt : Elmt_Id; + Formal : Entity_Id; + Op : Entity_Id; + + begin + if Prev /= T + and then Ekind (Prev) = E_Incomplete_Type + and then Is_Tagged_Type (Prev) + and then Is_Tagged_Type (T) + then + Elmt := First_Elmt (Primitive_Operations (Prev)); + while Present (Elmt) loop + Op := Node (Elmt); + Prepend_Elmt (Op, Primitive_Operations (T)); + + Formal := First_Formal (Op); + while Present (Formal) loop + if Etype (Formal) = Prev then + Set_Etype (Formal, T); + end if; + + Next_Formal (Formal); + end loop; + + if Etype (Op) = Prev then + Set_Etype (Op, T); + end if; + + Next_Elmt (Elmt); + end loop; + end if; + end Check_Ops_From_Incomplete_Type; + + -- Start of processing for Analyze_Full_Type_Declaration + + begin + Prev := Find_Type_Name (N); + + -- The full view, if present, now points to the current type + + -- Ada 2005 (AI-50217): If the type was previously decorated when + -- imported through a LIMITED WITH clause, it appears as incomplete + -- but has no full view. + + if Ekind (Prev) = E_Incomplete_Type + and then Present (Full_View (Prev)) + then + T := Full_View (Prev); + else + T := Prev; + end if; + + Set_Is_Pure (T, Is_Pure (Current_Scope)); + + -- We set the flag Is_First_Subtype here. It is needed to set the + -- corresponding flag for the Implicit class-wide-type created + -- during tagged types processing. + + Set_Is_First_Subtype (T, True); + + -- Only composite types other than array types are allowed to have + -- discriminants. + + case Nkind (Def) is + + -- For derived types, the rule will be checked once we've figured + -- out the parent type. + + when N_Derived_Type_Definition => + null; + + -- For record types, discriminants are allowed + + when N_Record_Definition => + null; + + when others => + if Present (Discriminant_Specifications (N)) then + Error_Msg_N + ("elementary or array type cannot have discriminants", + Defining_Identifier + (First (Discriminant_Specifications (N)))); + end if; + end case; + + -- Elaborate the type definition according to kind, and generate + -- subsidiary (implicit) subtypes where needed. We skip this if it was + -- already done (this happens during the reanalysis that follows a call + -- to the high level optimizer). + + if not Analyzed (T) then + Set_Analyzed (T); + + case Nkind (Def) is + + when N_Access_To_Subprogram_Definition => + Access_Subprogram_Declaration (T, Def); + + -- If this is a remote access to subprogram, we must create the + -- equivalent fat pointer type, and related subprograms. + + if Is_Remote then + Process_Remote_AST_Declaration (N); + end if; + + -- Validate categorization rule against access type declaration + -- usually a violation in Pure unit, Shared_Passive unit. + + Validate_Access_Type_Declaration (T, N); + + when N_Access_To_Object_Definition => + Access_Type_Declaration (T, Def); + + -- Validate categorization rule against access type declaration + -- usually a violation in Pure unit, Shared_Passive unit. + + Validate_Access_Type_Declaration (T, N); + + -- If we are in a Remote_Call_Interface package and define a + -- RACW, then calling stubs and specific stream attributes + -- must be added. + + if Is_Remote + and then Is_Remote_Access_To_Class_Wide_Type (Def_Id) + then + Add_RACW_Features (Def_Id); + end if; + + -- Set no strict aliasing flag if config pragma seen + + if Opt.No_Strict_Aliasing then + Set_No_Strict_Aliasing (Base_Type (Def_Id)); + end if; + + when N_Array_Type_Definition => + Array_Type_Declaration (T, Def); + + when N_Derived_Type_Definition => + Derived_Type_Declaration (T, N, T /= Def_Id); + + when N_Enumeration_Type_Definition => + Enumeration_Type_Declaration (T, Def); + + when N_Floating_Point_Definition => + Floating_Point_Type_Declaration (T, Def); + + when N_Decimal_Fixed_Point_Definition => + Decimal_Fixed_Point_Type_Declaration (T, Def); + + when N_Ordinary_Fixed_Point_Definition => + Ordinary_Fixed_Point_Type_Declaration (T, Def); + + when N_Signed_Integer_Type_Definition => + Signed_Integer_Type_Declaration (T, Def); + + when N_Modular_Type_Definition => + Modular_Type_Declaration (T, Def); + + when N_Record_Definition => + Record_Type_Declaration (T, N, Prev); + + -- If declaration has a parse error, nothing to elaborate. + + when N_Error => + null; + + when others => + raise Program_Error; + + end case; + end if; + + if Etype (T) = Any_Type then + return; + end if; + + -- Some common processing for all types + + Set_Depends_On_Private (T, Has_Private_Component (T)); + Check_Ops_From_Incomplete_Type; + + -- Both the declared entity, and its anonymous base type if one + -- was created, need freeze nodes allocated. + + declare + B : constant Entity_Id := Base_Type (T); + + begin + -- In the case where the base type differs from the first subtype, we + -- pre-allocate a freeze node, and set the proper link to the first + -- subtype. Freeze_Entity will use this preallocated freeze node when + -- it freezes the entity. + + -- This does not apply if the base type is a generic type, whose + -- declaration is independent of the current derived definition. + + if B /= T and then not Is_Generic_Type (B) then + Ensure_Freeze_Node (B); + Set_First_Subtype_Link (Freeze_Node (B), T); + end if; + + -- A type that is imported through a limited_with clause cannot + -- generate any code, and thus need not be frozen. However, an access + -- type with an imported designated type needs a finalization list, + -- which may be referenced in some other package that has non-limited + -- visibility on the designated type. Thus we must create the + -- finalization list at the point the access type is frozen, to + -- prevent unsatisfied references at link time. + + if not From_With_Type (T) or else Is_Access_Type (T) then + Set_Has_Delayed_Freeze (T); + end if; + end; + + -- Case where T is the full declaration of some private type which has + -- been swapped in Defining_Identifier (N). + + if T /= Def_Id and then Is_Private_Type (Def_Id) then + Process_Full_View (N, T, Def_Id); + + -- Record the reference. The form of this is a little strange, since + -- the full declaration has been swapped in. So the first parameter + -- here represents the entity to which a reference is made which is + -- the "real" entity, i.e. the one swapped in, and the second + -- parameter provides the reference location. + + -- Also, we want to kill Has_Pragma_Unreferenced temporarily here + -- since we don't want a complaint about the full type being an + -- unwanted reference to the private type + + declare + B : constant Boolean := Has_Pragma_Unreferenced (T); + begin + Set_Has_Pragma_Unreferenced (T, False); + Generate_Reference (T, T, 'c'); + Set_Has_Pragma_Unreferenced (T, B); + end; + + Set_Completion_Referenced (Def_Id); + + -- For completion of incomplete type, process incomplete dependents + -- and always mark the full type as referenced (it is the incomplete + -- type that we get for any real reference). + + elsif Ekind (Prev) = E_Incomplete_Type then + Process_Incomplete_Dependents (N, T, Prev); + Generate_Reference (Prev, Def_Id, 'c'); + Set_Completion_Referenced (Def_Id); + + -- If not private type or incomplete type completion, this is a real + -- definition of a new entity, so record it. + + else + Generate_Definition (Def_Id); + end if; + + if Chars (Scope (Def_Id)) = Name_System + and then Chars (Def_Id) = Name_Address + and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (N))) + then + Set_Is_Descendent_Of_Address (Def_Id); + Set_Is_Descendent_Of_Address (Base_Type (Def_Id)); + Set_Is_Descendent_Of_Address (Prev); + end if; + + Set_Optimize_Alignment_Flags (Def_Id); + Check_Eliminated (Def_Id); + + Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N)); + end Analyze_Full_Type_Declaration; + + ---------------------------------- + -- Analyze_Incomplete_Type_Decl -- + ---------------------------------- + + procedure Analyze_Incomplete_Type_Decl (N : Node_Id) is + F : constant Boolean := Is_Pure (Current_Scope); + T : Entity_Id; + + begin + Generate_Definition (Defining_Identifier (N)); + + -- Process an incomplete declaration. The identifier must not have been + -- declared already in the scope. However, an incomplete declaration may + -- appear in the private part of a package, for a private type that has + -- already been declared. + + -- In this case, the discriminants (if any) must match + + T := Find_Type_Name (N); + + Set_Ekind (T, E_Incomplete_Type); + Init_Size_Align (T); + Set_Is_First_Subtype (T, True); + Set_Etype (T, T); + + -- Ada 2005 (AI-326): Minimum decoration to give support to tagged + -- incomplete types. + + if Tagged_Present (N) then + Set_Is_Tagged_Type (T); + Make_Class_Wide_Type (T); + Set_Direct_Primitive_Operations (T, New_Elmt_List); + end if; + + Push_Scope (T); + + Set_Stored_Constraint (T, No_Elist); + + if Present (Discriminant_Specifications (N)) then + Process_Discriminants (N); + end if; + + End_Scope; + + -- If the type has discriminants, non-trivial subtypes may be + -- declared before the full view of the type. The full views of those + -- subtypes will be built after the full view of the type. + + Set_Private_Dependents (T, New_Elmt_List); + Set_Is_Pure (T, F); + end Analyze_Incomplete_Type_Decl; + + ----------------------------------- + -- Analyze_Interface_Declaration -- + ----------------------------------- + + procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id) is + CW : constant Entity_Id := Class_Wide_Type (T); + + begin + Set_Is_Tagged_Type (T); + + Set_Is_Limited_Record (T, Limited_Present (Def) + or else Task_Present (Def) + or else Protected_Present (Def) + or else Synchronized_Present (Def)); + + -- Type is abstract if full declaration carries keyword, or if previous + -- partial view did. + + Set_Is_Abstract_Type (T); + Set_Is_Interface (T); + + -- Type is a limited interface if it includes the keyword limited, task, + -- protected, or synchronized. + + Set_Is_Limited_Interface + (T, Limited_Present (Def) + or else Protected_Present (Def) + or else Synchronized_Present (Def) + or else Task_Present (Def)); + + Set_Interfaces (T, New_Elmt_List); + Set_Direct_Primitive_Operations (T, New_Elmt_List); + + -- Complete the decoration of the class-wide entity if it was already + -- built (i.e. during the creation of the limited view) + + if Present (CW) then + Set_Is_Interface (CW); + Set_Is_Limited_Interface (CW, Is_Limited_Interface (T)); + end if; + + -- Check runtime support for synchronized interfaces + + if VM_Target = No_VM + and then (Is_Task_Interface (T) + or else Is_Protected_Interface (T) + or else Is_Synchronized_Interface (T)) + and then not RTE_Available (RE_Select_Specific_Data) + then + Error_Msg_CRT ("synchronized interfaces", T); + end if; + end Analyze_Interface_Declaration; + + ----------------------------- + -- Analyze_Itype_Reference -- + ----------------------------- + + -- Nothing to do. This node is placed in the tree only for the benefit of + -- back end processing, and has no effect on the semantic processing. + + procedure Analyze_Itype_Reference (N : Node_Id) is + begin + pragma Assert (Is_Itype (Itype (N))); + null; + end Analyze_Itype_Reference; + + -------------------------------- + -- Analyze_Number_Declaration -- + -------------------------------- + + procedure Analyze_Number_Declaration (N : Node_Id) is + Id : constant Entity_Id := Defining_Identifier (N); + E : constant Node_Id := Expression (N); + T : Entity_Id; + Index : Interp_Index; + It : Interp; + + begin + Generate_Definition (Id); + Enter_Name (Id); + + -- This is an optimization of a common case of an integer literal + + if Nkind (E) = N_Integer_Literal then + Set_Is_Static_Expression (E, True); + Set_Etype (E, Universal_Integer); + + Set_Etype (Id, Universal_Integer); + Set_Ekind (Id, E_Named_Integer); + Set_Is_Frozen (Id, True); + return; + end if; + + Set_Is_Pure (Id, Is_Pure (Current_Scope)); + + -- Process expression, replacing error by integer zero, to avoid + -- cascaded errors or aborts further along in the processing + + -- Replace Error by integer zero, which seems least likely to + -- cause cascaded errors. + + if E = Error then + Rewrite (E, Make_Integer_Literal (Sloc (E), Uint_0)); + Set_Error_Posted (E); + end if; + + Analyze (E); + + -- Verify that the expression is static and numeric. If + -- the expression is overloaded, we apply the preference + -- rule that favors root numeric types. + + if not Is_Overloaded (E) then + T := Etype (E); + + else + T := Any_Type; + + Get_First_Interp (E, Index, It); + while Present (It.Typ) loop + if (Is_Integer_Type (It.Typ) + or else Is_Real_Type (It.Typ)) + and then (Scope (Base_Type (It.Typ))) = Standard_Standard + then + if T = Any_Type then + T := It.Typ; + + elsif It.Typ = Universal_Real + or else It.Typ = Universal_Integer + then + -- Choose universal interpretation over any other + + T := It.Typ; + exit; + end if; + end if; + + Get_Next_Interp (Index, It); + end loop; + end if; + + if Is_Integer_Type (T) then + Resolve (E, T); + Set_Etype (Id, Universal_Integer); + Set_Ekind (Id, E_Named_Integer); + + elsif Is_Real_Type (T) then + + -- Because the real value is converted to universal_real, this is a + -- legal context for a universal fixed expression. + + if T = Universal_Fixed then + declare + Loc : constant Source_Ptr := Sloc (N); + Conv : constant Node_Id := Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Universal_Real, Loc), + Expression => Relocate_Node (E)); + + begin + Rewrite (E, Conv); + Analyze (E); + end; + + elsif T = Any_Fixed then + Error_Msg_N ("illegal context for mixed mode operation", E); + + -- Expression is of the form : universal_fixed * integer. Try to + -- resolve as universal_real. + + T := Universal_Real; + Set_Etype (E, T); + end if; + + Resolve (E, T); + Set_Etype (Id, Universal_Real); + Set_Ekind (Id, E_Named_Real); + + else + Wrong_Type (E, Any_Numeric); + Resolve (E, T); + + Set_Etype (Id, T); + Set_Ekind (Id, E_Constant); + Set_Never_Set_In_Source (Id, True); + Set_Is_True_Constant (Id, True); + return; + end if; + + if Nkind_In (E, N_Integer_Literal, N_Real_Literal) then + Set_Etype (E, Etype (Id)); + end if; + + if not Is_OK_Static_Expression (E) then + Flag_Non_Static_Expr + ("non-static expression used in number declaration!", E); + Rewrite (E, Make_Integer_Literal (Sloc (N), 1)); + Set_Etype (E, Any_Type); + end if; + end Analyze_Number_Declaration; + + -------------------------------- + -- Analyze_Object_Declaration -- + -------------------------------- + + procedure Analyze_Object_Declaration (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Id : constant Entity_Id := Defining_Identifier (N); + T : Entity_Id; + Act_T : Entity_Id; + + E : Node_Id := Expression (N); + -- E is set to Expression (N) throughout this routine. When + -- Expression (N) is modified, E is changed accordingly. + + Prev_Entity : Entity_Id := Empty; + + function Count_Tasks (T : Entity_Id) return Uint; + -- This function is called when a non-generic library level object of a + -- task type is declared. Its function is to count the static number of + -- tasks declared within the type (it is only called if Has_Tasks is set + -- for T). As a side effect, if an array of tasks with non-static bounds + -- or a variant record type is encountered, Check_Restrictions is called + -- indicating the count is unknown. + + ----------------- + -- Count_Tasks -- + ----------------- + + function Count_Tasks (T : Entity_Id) return Uint is + C : Entity_Id; + X : Node_Id; + V : Uint; + + begin + if Is_Task_Type (T) then + return Uint_1; + + elsif Is_Record_Type (T) then + if Has_Discriminants (T) then + Check_Restriction (Max_Tasks, N); + return Uint_0; + + else + V := Uint_0; + C := First_Component (T); + while Present (C) loop + V := V + Count_Tasks (Etype (C)); + Next_Component (C); + end loop; + + return V; + end if; + + elsif Is_Array_Type (T) then + X := First_Index (T); + V := Count_Tasks (Component_Type (T)); + while Present (X) loop + C := Etype (X); + + if not Is_Static_Subtype (C) then + Check_Restriction (Max_Tasks, N); + return Uint_0; + else + V := V * (UI_Max (Uint_0, + Expr_Value (Type_High_Bound (C)) - + Expr_Value (Type_Low_Bound (C)) + Uint_1)); + end if; + + Next_Index (X); + end loop; + + return V; + + else + return Uint_0; + end if; + end Count_Tasks; + + -- Start of processing for Analyze_Object_Declaration + + begin + -- There are three kinds of implicit types generated by an + -- object declaration: + + -- 1. Those for generated by the original Object Definition + + -- 2. Those generated by the Expression + + -- 3. Those used to constrained the Object Definition with the + -- expression constraints when it is unconstrained + + -- They must be generated in this order to avoid order of elaboration + -- issues. Thus the first step (after entering the name) is to analyze + -- the object definition. + + if Constant_Present (N) then + Prev_Entity := Current_Entity_In_Scope (Id); + + if Present (Prev_Entity) + and then + -- If the homograph is an implicit subprogram, it is overridden + -- by the current declaration. + + ((Is_Overloadable (Prev_Entity) + and then Is_Inherited_Operation (Prev_Entity)) + + -- The current object is a discriminal generated for an entry + -- family index. Even though the index is a constant, in this + -- particular context there is no true constant redeclaration. + -- Enter_Name will handle the visibility. + + or else + (Is_Discriminal (Id) + and then Ekind (Discriminal_Link (Id)) = + E_Entry_Index_Parameter) + + -- The current object is the renaming for a generic declared + -- within the instance. + + or else + (Ekind (Prev_Entity) = E_Package + and then Nkind (Parent (Prev_Entity)) = + N_Package_Renaming_Declaration + and then not Comes_From_Source (Prev_Entity) + and then Is_Generic_Instance (Renamed_Entity (Prev_Entity)))) + then + Prev_Entity := Empty; + end if; + end if; + + if Present (Prev_Entity) then + Constant_Redeclaration (Id, N, T); + + Generate_Reference (Prev_Entity, Id, 'c'); + Set_Completion_Referenced (Id); + + if Error_Posted (N) then + + -- Type mismatch or illegal redeclaration, Do not analyze + -- expression to avoid cascaded errors. + + T := Find_Type_Of_Object (Object_Definition (N), N); + Set_Etype (Id, T); + Set_Ekind (Id, E_Variable); + goto Leave; + end if; + + -- In the normal case, enter identifier at the start to catch premature + -- usage in the initialization expression. + + else + Generate_Definition (Id); + Enter_Name (Id); + + Mark_Coextensions (N, Object_Definition (N)); + + T := Find_Type_Of_Object (Object_Definition (N), N); + + if Nkind (Object_Definition (N)) = N_Access_Definition + and then Present + (Access_To_Subprogram_Definition (Object_Definition (N))) + and then Protected_Present + (Access_To_Subprogram_Definition (Object_Definition (N))) + then + T := Replace_Anonymous_Access_To_Protected_Subprogram (N); + end if; + + if Error_Posted (Id) then + Set_Etype (Id, T); + Set_Ekind (Id, E_Variable); + goto Leave; + end if; + end if; + + -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry + -- out some static checks + + if Ada_Version >= Ada_2005 + and then Can_Never_Be_Null (T) + then + -- In case of aggregates we must also take care of the correct + -- initialization of nested aggregates bug this is done at the + -- point of the analysis of the aggregate (see sem_aggr.adb) + + if Present (Expression (N)) + and then Nkind (Expression (N)) = N_Aggregate + then + null; + + else + declare + Save_Typ : constant Entity_Id := Etype (Id); + begin + Set_Etype (Id, T); -- Temp. decoration for static checks + Null_Exclusion_Static_Checks (N); + Set_Etype (Id, Save_Typ); + end; + end if; + end if; + + Set_Is_Pure (Id, Is_Pure (Current_Scope)); + + -- If deferred constant, make sure context is appropriate. We detect + -- a deferred constant as a constant declaration with no expression. + -- A deferred constant can appear in a package body if its completion + -- is by means of an interface pragma. + + if Constant_Present (N) + and then No (E) + then + -- A deferred constant may appear in the declarative part of the + -- following constructs: + + -- blocks + -- entry bodies + -- extended return statements + -- package specs + -- package bodies + -- subprogram bodies + -- task bodies + + -- When declared inside a package spec, a deferred constant must be + -- completed by a full constant declaration or pragma Import. In all + -- other cases, the only proper completion is pragma Import. Extended + -- return statements are flagged as invalid contexts because they do + -- not have a declarative part and so cannot accommodate the pragma. + + if Ekind (Current_Scope) = E_Return_Statement then + Error_Msg_N + ("invalid context for deferred constant declaration (RM 7.4)", + N); + Error_Msg_N + ("\declaration requires an initialization expression", + N); + Set_Constant_Present (N, False); + + -- In Ada 83, deferred constant must be of private type + + elsif not Is_Private_Type (T) then + if Ada_Version = Ada_83 and then Comes_From_Source (N) then + Error_Msg_N + ("(Ada 83) deferred constant must be private type", N); + end if; + end if; + + -- If not a deferred constant, then object declaration freezes its type + + else + Check_Fully_Declared (T, N); + Freeze_Before (N, T); + end if; + + -- If the object was created by a constrained array definition, then + -- set the link in both the anonymous base type and anonymous subtype + -- that are built to represent the array type to point to the object. + + if Nkind (Object_Definition (Declaration_Node (Id))) = + N_Constrained_Array_Definition + then + Set_Related_Array_Object (T, Id); + Set_Related_Array_Object (Base_Type (T), Id); + end if; + + -- Special checks for protected objects not at library level + + if Is_Protected_Type (T) + and then not Is_Library_Level_Entity (Id) + then + Check_Restriction (No_Local_Protected_Objects, Id); + + -- Protected objects with interrupt handlers must be at library level + + -- Ada 2005: this test is not needed (and the corresponding clause + -- in the RM is removed) because accessibility checks are sufficient + -- to make handlers not at the library level illegal. + + if Has_Interrupt_Handler (T) + and then Ada_Version < Ada_2005 + then + Error_Msg_N + ("interrupt object can only be declared at library level", Id); + end if; + end if; + + -- The actual subtype of the object is the nominal subtype, unless + -- the nominal one is unconstrained and obtained from the expression. + + Act_T := T; + + -- Process initialization expression if present and not in error + + if Present (E) and then E /= Error then + + -- Generate an error in case of CPP class-wide object initialization. + -- Required because otherwise the expansion of the class-wide + -- assignment would try to use 'size to initialize the object + -- (primitive that is not available in CPP tagged types). + + if Is_Class_Wide_Type (Act_T) + and then + (Is_CPP_Class (Root_Type (Etype (Act_T))) + or else + (Present (Full_View (Root_Type (Etype (Act_T)))) + and then + Is_CPP_Class (Full_View (Root_Type (Etype (Act_T)))))) + then + Error_Msg_N + ("predefined assignment not available for 'C'P'P tagged types", + E); + end if; + + Mark_Coextensions (N, E); + Analyze (E); + + -- In case of errors detected in the analysis of the expression, + -- decorate it with the expected type to avoid cascaded errors + + if No (Etype (E)) then + Set_Etype (E, T); + end if; + + -- If an initialization expression is present, then we set the + -- Is_True_Constant flag. It will be reset if this is a variable + -- and it is indeed modified. + + Set_Is_True_Constant (Id, True); + + -- If we are analyzing a constant declaration, set its completion + -- flag after analyzing and resolving the expression. + + if Constant_Present (N) then + Set_Has_Completion (Id); + end if; + + -- Set type and resolve (type may be overridden later on) + + Set_Etype (Id, T); + Resolve (E, T); + + -- If E is null and has been replaced by an N_Raise_Constraint_Error + -- node (which was marked already-analyzed), we need to set the type + -- to something other than Any_Access in order to keep gigi happy. + + if Etype (E) = Any_Access then + Set_Etype (E, T); + end if; + + -- If the object is an access to variable, the initialization + -- expression cannot be an access to constant. + + if Is_Access_Type (T) + and then not Is_Access_Constant (T) + and then Is_Access_Type (Etype (E)) + and then Is_Access_Constant (Etype (E)) + then + Error_Msg_N + ("access to variable cannot be initialized " + & "with an access-to-constant expression", E); + end if; + + if not Assignment_OK (N) then + Check_Initialization (T, E); + end if; + + Check_Unset_Reference (E); + + -- If this is a variable, then set current value. If this is a + -- declared constant of a scalar type with a static expression, + -- indicate that it is always valid. + + if not Constant_Present (N) then + if Compile_Time_Known_Value (E) then + Set_Current_Value (Id, E); + end if; + + elsif Is_Scalar_Type (T) + and then Is_OK_Static_Expression (E) + then + Set_Is_Known_Valid (Id); + end if; + + -- Deal with setting of null flags + + if Is_Access_Type (T) then + if Known_Non_Null (E) then + Set_Is_Known_Non_Null (Id, True); + elsif Known_Null (E) + and then not Can_Never_Be_Null (Id) + then + Set_Is_Known_Null (Id, True); + end if; + end if; + + -- Check incorrect use of dynamically tagged expressions. + + if Is_Tagged_Type (T) then + Check_Dynamically_Tagged_Expression + (Expr => E, + Typ => T, + Related_Nod => N); + end if; + + Apply_Scalar_Range_Check (E, T); + Apply_Static_Length_Check (E, T); + end if; + + -- If the No_Streams restriction is set, check that the type of the + -- object is not, and does not contain, any subtype derived from + -- Ada.Streams.Root_Stream_Type. Note that we guard the call to + -- Has_Stream just for efficiency reasons. There is no point in + -- spending time on a Has_Stream check if the restriction is not set. + + if Restriction_Check_Required (No_Streams) then + if Has_Stream (T) then + Check_Restriction (No_Streams, N); + end if; + end if; + + -- Deal with predicate check before we start to do major rewriting. + -- it is OK to initialize and then check the initialized value, since + -- the object goes out of scope if we get a predicate failure. Note + -- that we do this in the analyzer and not the expander because the + -- analyzer does some substantial rewriting in some cases. + + -- We need a predicate check if the type has predicates, and if either + -- there is an initializing expression, or for default initialization + -- when we have at least one case of an explicit default initial value. + + if not Suppress_Assignment_Checks (N) + and then Present (Predicate_Function (T)) + and then + (Present (E) + or else + Is_Partially_Initialized_Type (T, Include_Implicit => False)) + then + Insert_After (N, + Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc))); + end if; + + -- Case of unconstrained type + + if Is_Indefinite_Subtype (T) then + + -- Nothing to do in deferred constant case + + if Constant_Present (N) and then No (E) then + null; + + -- Case of no initialization present + + elsif No (E) then + if No_Initialization (N) then + null; + + elsif Is_Class_Wide_Type (T) then + Error_Msg_N + ("initialization required in class-wide declaration ", N); + + else + Error_Msg_N + ("unconstrained subtype not allowed (need initialization)", + Object_Definition (N)); + + if Is_Record_Type (T) and then Has_Discriminants (T) then + Error_Msg_N + ("\provide initial value or explicit discriminant values", + Object_Definition (N)); + + Error_Msg_NE + ("\or give default discriminant values for type&", + Object_Definition (N), T); + + elsif Is_Array_Type (T) then + Error_Msg_N + ("\provide initial value or explicit array bounds", + Object_Definition (N)); + end if; + end if; + + -- Case of initialization present but in error. Set initial + -- expression as absent (but do not make above complaints) + + elsif E = Error then + Set_Expression (N, Empty); + E := Empty; + + -- Case of initialization present + + else + -- Not allowed in Ada 83 + + if not Constant_Present (N) then + if Ada_Version = Ada_83 + and then Comes_From_Source (Object_Definition (N)) + then + Error_Msg_N + ("(Ada 83) unconstrained variable not allowed", + Object_Definition (N)); + end if; + end if; + + -- Now we constrain the variable from the initializing expression + + -- If the expression is an aggregate, it has been expanded into + -- individual assignments. Retrieve the actual type from the + -- expanded construct. + + if Is_Array_Type (T) + and then No_Initialization (N) + and then Nkind (Original_Node (E)) = N_Aggregate + then + Act_T := Etype (E); + + -- In case of class-wide interface object declarations we delay + -- the generation of the equivalent record type declarations until + -- its expansion because there are cases in they are not required. + + elsif Is_Interface (T) then + null; + + else + Expand_Subtype_From_Expr (N, T, Object_Definition (N), E); + Act_T := Find_Type_Of_Object (Object_Definition (N), N); + end if; + + Set_Is_Constr_Subt_For_U_Nominal (Act_T); + + if Aliased_Present (N) then + Set_Is_Constr_Subt_For_UN_Aliased (Act_T); + end if; + + Freeze_Before (N, Act_T); + Freeze_Before (N, T); + end if; + + elsif Is_Array_Type (T) + and then No_Initialization (N) + and then Nkind (Original_Node (E)) = N_Aggregate + then + if not Is_Entity_Name (Object_Definition (N)) then + Act_T := Etype (E); + Check_Compile_Time_Size (Act_T); + + if Aliased_Present (N) then + Set_Is_Constr_Subt_For_UN_Aliased (Act_T); + end if; + end if; + + -- When the given object definition and the aggregate are specified + -- independently, and their lengths might differ do a length check. + -- This cannot happen if the aggregate is of the form (others =>...) + + if not Is_Constrained (T) then + null; + + elsif Nkind (E) = N_Raise_Constraint_Error then + + -- Aggregate is statically illegal. Place back in declaration + + Set_Expression (N, E); + Set_No_Initialization (N, False); + + elsif T = Etype (E) then + null; + + elsif Nkind (E) = N_Aggregate + and then Present (Component_Associations (E)) + and then Present (Choices (First (Component_Associations (E)))) + and then Nkind (First + (Choices (First (Component_Associations (E))))) = N_Others_Choice + then + null; + + else + Apply_Length_Check (E, T); + end if; + + -- If the type is limited unconstrained with defaulted discriminants and + -- there is no expression, then the object is constrained by the + -- defaults, so it is worthwhile building the corresponding subtype. + + elsif (Is_Limited_Record (T) or else Is_Concurrent_Type (T)) + and then not Is_Constrained (T) + and then Has_Discriminants (T) + then + if No (E) then + Act_T := Build_Default_Subtype (T, N); + else + -- Ada 2005: a limited object may be initialized by means of an + -- aggregate. If the type has default discriminants it has an + -- unconstrained nominal type, Its actual subtype will be obtained + -- from the aggregate, and not from the default discriminants. + + Act_T := Etype (E); + end if; + + Rewrite (Object_Definition (N), New_Occurrence_Of (Act_T, Loc)); + + elsif Present (Underlying_Type (T)) + and then not Is_Constrained (Underlying_Type (T)) + and then Has_Discriminants (Underlying_Type (T)) + and then Nkind (E) = N_Function_Call + and then Constant_Present (N) + then + -- The back-end has problems with constants of a discriminated type + -- with defaults, if the initial value is a function call. We + -- generate an intermediate temporary for the result of the call. + -- It is unclear why this should make it acceptable to gcc. ??? + + Remove_Side_Effects (E); + end if; + + -- Check No_Wide_Characters restriction + + Check_Wide_Character_Restriction (T, Object_Definition (N)); + + -- Indicate this is not set in source. Certainly true for constants, + -- and true for variables so far (will be reset for a variable if and + -- when we encounter a modification in the source). + + Set_Never_Set_In_Source (Id, True); + + -- Now establish the proper kind and type of the object + + if Constant_Present (N) then + Set_Ekind (Id, E_Constant); + Set_Is_True_Constant (Id, True); + + else + Set_Ekind (Id, E_Variable); + + -- A variable is set as shared passive if it appears in a shared + -- passive package, and is at the outer level. This is not done + -- for entities generated during expansion, because those are + -- always manipulated locally. + + if Is_Shared_Passive (Current_Scope) + and then Is_Library_Level_Entity (Id) + and then Comes_From_Source (Id) + then + Set_Is_Shared_Passive (Id); + Check_Shared_Var (Id, T, N); + end if; + + -- Set Has_Initial_Value if initializing expression present. Note + -- that if there is no initializing expression, we leave the state + -- of this flag unchanged (usually it will be False, but notably in + -- the case of exception choice variables, it will already be true). + + if Present (E) then + Set_Has_Initial_Value (Id, True); + end if; + end if; + + -- Initialize alignment and size and capture alignment setting + + Init_Alignment (Id); + Init_Esize (Id); + Set_Optimize_Alignment_Flags (Id); + + -- Deal with aliased case + + if Aliased_Present (N) then + Set_Is_Aliased (Id); + + -- If the object is aliased and the type is unconstrained with + -- defaulted discriminants and there is no expression, then the + -- object is constrained by the defaults, so it is worthwhile + -- building the corresponding subtype. + + -- Ada 2005 (AI-363): If the aliased object is discriminated and + -- unconstrained, then only establish an actual subtype if the + -- nominal subtype is indefinite. In definite cases the object is + -- unconstrained in Ada 2005. + + if No (E) + and then Is_Record_Type (T) + and then not Is_Constrained (T) + and then Has_Discriminants (T) + and then (Ada_Version < Ada_2005 or else Is_Indefinite_Subtype (T)) + then + Set_Actual_Subtype (Id, Build_Default_Subtype (T, N)); + end if; + end if; + + -- Now we can set the type of the object + + Set_Etype (Id, Act_T); + + -- Deal with controlled types + + if Has_Controlled_Component (Etype (Id)) + or else Is_Controlled (Etype (Id)) + then + if not Is_Library_Level_Entity (Id) then + Check_Restriction (No_Nested_Finalization, N); + else + Validate_Controlled_Object (Id); + end if; + + -- Generate a warning when an initialization causes an obvious ABE + -- violation. If the init expression is a simple aggregate there + -- shouldn't be any initialize/adjust call generated. This will be + -- true as soon as aggregates are built in place when possible. + + -- ??? at the moment we do not generate warnings for temporaries + -- created for those aggregates although Program_Error might be + -- generated if compiled with -gnato. + + if Is_Controlled (Etype (Id)) + and then Comes_From_Source (Id) + then + declare + BT : constant Entity_Id := Base_Type (Etype (Id)); + + Implicit_Call : Entity_Id; + pragma Warnings (Off, Implicit_Call); + -- ??? what is this for (never referenced!) + + function Is_Aggr (N : Node_Id) return Boolean; + -- Check that N is an aggregate + + ------------- + -- Is_Aggr -- + ------------- + + function Is_Aggr (N : Node_Id) return Boolean is + begin + case Nkind (Original_Node (N)) is + when N_Aggregate | N_Extension_Aggregate => + return True; + + when N_Qualified_Expression | + N_Type_Conversion | + N_Unchecked_Type_Conversion => + return Is_Aggr (Expression (Original_Node (N))); + + when others => + return False; + end case; + end Is_Aggr; + + begin + -- If no underlying type, we already are in an error situation. + -- Do not try to add a warning since we do not have access to + -- prim-op list. + + if No (Underlying_Type (BT)) then + Implicit_Call := Empty; + + -- A generic type does not have usable primitive operators. + -- Initialization calls are built for instances. + + elsif Is_Generic_Type (BT) then + Implicit_Call := Empty; + + -- If the init expression is not an aggregate, an adjust call + -- will be generated + + elsif Present (E) and then not Is_Aggr (E) then + Implicit_Call := Find_Prim_Op (BT, Name_Adjust); + + -- If no init expression and we are not in the deferred + -- constant case, an Initialize call will be generated + + elsif No (E) and then not Constant_Present (N) then + Implicit_Call := Find_Prim_Op (BT, Name_Initialize); + + else + Implicit_Call := Empty; + end if; + end; + end if; + end if; + + if Has_Task (Etype (Id)) then + Check_Restriction (No_Tasking, N); + + -- Deal with counting max tasks + + -- Nothing to do if inside a generic + + if Inside_A_Generic then + null; + + -- If library level entity, then count tasks + + elsif Is_Library_Level_Entity (Id) then + Check_Restriction (Max_Tasks, N, Count_Tasks (Etype (Id))); + + -- If not library level entity, then indicate we don't know max + -- tasks and also check task hierarchy restriction and blocking + -- operation (since starting a task is definitely blocking!) + + else + Check_Restriction (Max_Tasks, N); + Check_Restriction (No_Task_Hierarchy, N); + Check_Potentially_Blocking_Operation (N); + end if; + + -- A rather specialized test. If we see two tasks being declared + -- of the same type in the same object declaration, and the task + -- has an entry with an address clause, we know that program error + -- will be raised at run time since we can't have two tasks with + -- entries at the same address. + + if Is_Task_Type (Etype (Id)) and then More_Ids (N) then + declare + E : Entity_Id; + + begin + E := First_Entity (Etype (Id)); + while Present (E) loop + if Ekind (E) = E_Entry + and then Present (Get_Attribute_Definition_Clause + (E, Attribute_Address)) + then + Error_Msg_N + ("?more than one task with same entry address", N); + Error_Msg_N + ("\?Program_Error will be raised at run time", N); + Insert_Action (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Duplicated_Entry_Address)); + exit; + end if; + + Next_Entity (E); + end loop; + end; + end if; + end if; + + -- Some simple constant-propagation: if the expression is a constant + -- string initialized with a literal, share the literal. This avoids + -- a run-time copy. + + if Present (E) + and then Is_Entity_Name (E) + and then Ekind (Entity (E)) = E_Constant + and then Base_Type (Etype (E)) = Standard_String + then + declare + Val : constant Node_Id := Constant_Value (Entity (E)); + begin + if Present (Val) + and then Nkind (Val) = N_String_Literal + then + Rewrite (E, New_Copy (Val)); + end if; + end; + end if; + + -- Another optimization: if the nominal subtype is unconstrained and + -- the expression is a function call that returns an unconstrained + -- type, rewrite the declaration as a renaming of the result of the + -- call. The exceptions below are cases where the copy is expected, + -- either by the back end (Aliased case) or by the semantics, as for + -- initializing controlled types or copying tags for classwide types. + + if Present (E) + and then Nkind (E) = N_Explicit_Dereference + and then Nkind (Original_Node (E)) = N_Function_Call + and then not Is_Library_Level_Entity (Id) + and then not Is_Constrained (Underlying_Type (T)) + and then not Is_Aliased (Id) + and then not Is_Class_Wide_Type (T) + and then not Is_Controlled (T) + and then not Has_Controlled_Component (Base_Type (T)) + and then Expander_Active + then + Rewrite (N, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Id, + Access_Definition => Empty, + Subtype_Mark => New_Occurrence_Of + (Base_Type (Etype (Id)), Loc), + Name => E)); + + Set_Renamed_Object (Id, E); + + -- Force generation of debugging information for the constant and for + -- the renamed function call. + + Set_Debug_Info_Needed (Id); + Set_Debug_Info_Needed (Entity (Prefix (E))); + end if; + + if Present (Prev_Entity) + and then Is_Frozen (Prev_Entity) + and then not Error_Posted (Id) + then + Error_Msg_N ("full constant declaration appears too late", N); + end if; + + Check_Eliminated (Id); + + -- Deal with setting In_Private_Part flag if in private part + + if Ekind (Scope (Id)) = E_Package + and then In_Private_Part (Scope (Id)) + then + Set_In_Private_Part (Id); + end if; + + -- Check for violation of No_Local_Timing_Events + + if Is_RTE (Etype (Id), RE_Timing_Event) + and then not Is_Library_Level_Entity (Id) + then + Check_Restriction (No_Local_Timing_Events, N); + end if; + + <> + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); + end Analyze_Object_Declaration; + + --------------------------- + -- Analyze_Others_Choice -- + --------------------------- + + -- Nothing to do for the others choice node itself, the semantic analysis + -- of the others choice will occur as part of the processing of the parent + + procedure Analyze_Others_Choice (N : Node_Id) is + pragma Warnings (Off, N); + begin + null; + end Analyze_Others_Choice; + + ------------------------------------------- + -- Analyze_Private_Extension_Declaration -- + ------------------------------------------- + + procedure Analyze_Private_Extension_Declaration (N : Node_Id) is + T : constant Entity_Id := Defining_Identifier (N); + Indic : constant Node_Id := Subtype_Indication (N); + Parent_Type : Entity_Id; + Parent_Base : Entity_Id; + + begin + -- Ada 2005 (AI-251): Decorate all names in list of ancestor interfaces + + if Is_Non_Empty_List (Interface_List (N)) then + declare + Intf : Node_Id; + T : Entity_Id; + + begin + Intf := First (Interface_List (N)); + while Present (Intf) loop + T := Find_Type_Of_Subtype_Indic (Intf); + + Diagnose_Interface (Intf, T); + Next (Intf); + end loop; + end; + end if; + + Generate_Definition (T); + + -- For other than Ada 2012, just enter the name in the current scope + + if Ada_Version < Ada_2012 then + Enter_Name (T); + + -- Ada 2012 (AI05-0162): Enter the name in the current scope handling + -- case of private type that completes an incomplete type. + + else + declare + Prev : Entity_Id; + + begin + Prev := Find_Type_Name (N); + + pragma Assert (Prev = T + or else (Ekind (Prev) = E_Incomplete_Type + and then Present (Full_View (Prev)) + and then Full_View (Prev) = T)); + end; + end if; + + Parent_Type := Find_Type_Of_Subtype_Indic (Indic); + Parent_Base := Base_Type (Parent_Type); + + if Parent_Type = Any_Type + or else Etype (Parent_Type) = Any_Type + then + Set_Ekind (T, Ekind (Parent_Type)); + Set_Etype (T, Any_Type); + goto Leave; + + elsif not Is_Tagged_Type (Parent_Type) then + Error_Msg_N + ("parent of type extension must be a tagged type ", Indic); + goto Leave; + + elsif Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then + Error_Msg_N ("premature derivation of incomplete type", Indic); + goto Leave; + + elsif Is_Concurrent_Type (Parent_Type) then + Error_Msg_N + ("parent type of a private extension cannot be " + & "a synchronized tagged type (RM 3.9.1 (3/1))", N); + + Set_Etype (T, Any_Type); + Set_Ekind (T, E_Limited_Private_Type); + Set_Private_Dependents (T, New_Elmt_List); + Set_Error_Posted (T); + goto Leave; + end if; + + -- Perhaps the parent type should be changed to the class-wide type's + -- specific type in this case to prevent cascading errors ??? + + if Is_Class_Wide_Type (Parent_Type) then + Error_Msg_N + ("parent of type extension must not be a class-wide type", Indic); + goto Leave; + end if; + + if (not Is_Package_Or_Generic_Package (Current_Scope) + and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration) + or else In_Private_Part (Current_Scope) + + then + Error_Msg_N ("invalid context for private extension", N); + end if; + + -- Set common attributes + + Set_Is_Pure (T, Is_Pure (Current_Scope)); + Set_Scope (T, Current_Scope); + Set_Ekind (T, E_Record_Type_With_Private); + Init_Size_Align (T); + + Set_Etype (T, Parent_Base); + Set_Has_Task (T, Has_Task (Parent_Base)); + + Set_Convention (T, Convention (Parent_Type)); + Set_First_Rep_Item (T, First_Rep_Item (Parent_Type)); + Set_Is_First_Subtype (T); + Make_Class_Wide_Type (T); + + if Unknown_Discriminants_Present (N) then + Set_Discriminant_Constraint (T, No_Elist); + end if; + + Build_Derived_Record_Type (N, Parent_Type, T); + + -- Propagate inherited invariant information. The new type has + -- invariants, if the parent type has inheritable invariants, + -- and these invariants can in turn be inherited. + + if Has_Inheritable_Invariants (Parent_Type) then + Set_Has_Inheritable_Invariants (T); + Set_Has_Invariants (T); + end if; + + -- Ada 2005 (AI-443): Synchronized private extension or a rewritten + -- synchronized formal derived type. + + if Ada_Version >= Ada_2005 + and then Synchronized_Present (N) + then + Set_Is_Limited_Record (T); + + -- Formal derived type case + + if Is_Generic_Type (T) then + + -- The parent must be a tagged limited type or a synchronized + -- interface. + + if (not Is_Tagged_Type (Parent_Type) + or else not Is_Limited_Type (Parent_Type)) + and then + (not Is_Interface (Parent_Type) + or else not Is_Synchronized_Interface (Parent_Type)) + then + Error_Msg_NE ("parent type of & must be tagged limited " & + "or synchronized", N, T); + end if; + + -- The progenitors (if any) must be limited or synchronized + -- interfaces. + + if Present (Interfaces (T)) then + declare + Iface : Entity_Id; + Iface_Elmt : Elmt_Id; + + begin + Iface_Elmt := First_Elmt (Interfaces (T)); + while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); + + if not Is_Limited_Interface (Iface) + and then not Is_Synchronized_Interface (Iface) + then + Error_Msg_NE ("progenitor & must be limited " & + "or synchronized", N, Iface); + end if; + + Next_Elmt (Iface_Elmt); + end loop; + end; + end if; + + -- Regular derived extension, the parent must be a limited or + -- synchronized interface. + + else + if not Is_Interface (Parent_Type) + or else (not Is_Limited_Interface (Parent_Type) + and then + not Is_Synchronized_Interface (Parent_Type)) + then + Error_Msg_NE + ("parent type of & must be limited interface", N, T); + end if; + end if; + + -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private + -- extension with a synchronized parent must be explicitly declared + -- synchronized, because the full view will be a synchronized type. + -- This must be checked before the check for limited types below, + -- to ensure that types declared limited are not allowed to extend + -- synchronized interfaces. + + elsif Is_Interface (Parent_Type) + and then Is_Synchronized_Interface (Parent_Type) + and then not Synchronized_Present (N) + then + Error_Msg_NE + ("private extension of& must be explicitly synchronized", + N, Parent_Type); + + elsif Limited_Present (N) then + Set_Is_Limited_Record (T); + + if not Is_Limited_Type (Parent_Type) + and then + (not Is_Interface (Parent_Type) + or else not Is_Limited_Interface (Parent_Type)) + then + Error_Msg_NE ("parent type& of limited extension must be limited", + N, Parent_Type); + end if; + end if; + + <> + Analyze_Aspect_Specifications (N, T, Aspect_Specifications (N)); + end Analyze_Private_Extension_Declaration; + + --------------------------------- + -- Analyze_Subtype_Declaration -- + --------------------------------- + + procedure Analyze_Subtype_Declaration + (N : Node_Id; + Skip : Boolean := False) + is + Id : constant Entity_Id := Defining_Identifier (N); + T : Entity_Id; + R_Checks : Check_Result; + + begin + Generate_Definition (Id); + Set_Is_Pure (Id, Is_Pure (Current_Scope)); + Init_Size_Align (Id); + + -- The following guard condition on Enter_Name is to handle cases where + -- the defining identifier has already been entered into the scope but + -- the declaration as a whole needs to be analyzed. + + -- This case in particular happens for derived enumeration types. The + -- derived enumeration type is processed as an inserted enumeration type + -- declaration followed by a rewritten subtype declaration. The defining + -- identifier, however, is entered into the name scope very early in the + -- processing of the original type declaration and therefore needs to be + -- avoided here, when the created subtype declaration is analyzed. (See + -- Build_Derived_Types) + + -- This also happens when the full view of a private type is derived + -- type with constraints. In this case the entity has been introduced + -- in the private declaration. + + if Skip + or else (Present (Etype (Id)) + and then (Is_Private_Type (Etype (Id)) + or else Is_Task_Type (Etype (Id)) + or else Is_Rewrite_Substitution (N))) + then + null; + + else + Enter_Name (Id); + end if; + + T := Process_Subtype (Subtype_Indication (N), N, Id, 'P'); + + -- Inherit common attributes + + Set_Is_Generic_Type (Id, Is_Generic_Type (Base_Type (T))); + Set_Is_Volatile (Id, Is_Volatile (T)); + Set_Treat_As_Volatile (Id, Treat_As_Volatile (T)); + Set_Is_Atomic (Id, Is_Atomic (T)); + Set_Is_Ada_2005_Only (Id, Is_Ada_2005_Only (T)); + Set_Is_Ada_2012_Only (Id, Is_Ada_2012_Only (T)); + Set_Convention (Id, Convention (T)); + + -- If ancestor has predicates then so does the subtype, and in addition + -- we must delay the freeze to properly arrange predicate inheritance. + + -- The Ancestor_Type test is a big kludge, there seem to be cases in + -- which T = ID, so the above tests and assignments do nothing??? + + if Has_Predicates (T) + or else (Present (Ancestor_Subtype (T)) + and then Has_Predicates (Ancestor_Subtype (T))) + then + Set_Has_Predicates (Id); + Set_Has_Delayed_Freeze (Id); + end if; + + -- In the case where there is no constraint given in the subtype + -- indication, Process_Subtype just returns the Subtype_Mark, so its + -- semantic attributes must be established here. + + if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then + Set_Etype (Id, Base_Type (T)); + + case Ekind (T) is + when Array_Kind => + Set_Ekind (Id, E_Array_Subtype); + Copy_Array_Subtype_Attributes (Id, T); + + when Decimal_Fixed_Point_Kind => + Set_Ekind (Id, E_Decimal_Fixed_Point_Subtype); + Set_Digits_Value (Id, Digits_Value (T)); + Set_Delta_Value (Id, Delta_Value (T)); + Set_Scale_Value (Id, Scale_Value (T)); + Set_Small_Value (Id, Small_Value (T)); + Set_Scalar_Range (Id, Scalar_Range (T)); + Set_Machine_Radix_10 (Id, Machine_Radix_10 (T)); + Set_Is_Constrained (Id, Is_Constrained (T)); + Set_Is_Known_Valid (Id, Is_Known_Valid (T)); + Set_RM_Size (Id, RM_Size (T)); + + when Enumeration_Kind => + Set_Ekind (Id, E_Enumeration_Subtype); + Set_First_Literal (Id, First_Literal (Base_Type (T))); + Set_Scalar_Range (Id, Scalar_Range (T)); + Set_Is_Character_Type (Id, Is_Character_Type (T)); + Set_Is_Constrained (Id, Is_Constrained (T)); + Set_Is_Known_Valid (Id, Is_Known_Valid (T)); + Set_RM_Size (Id, RM_Size (T)); + + when Ordinary_Fixed_Point_Kind => + Set_Ekind (Id, E_Ordinary_Fixed_Point_Subtype); + Set_Scalar_Range (Id, Scalar_Range (T)); + Set_Small_Value (Id, Small_Value (T)); + Set_Delta_Value (Id, Delta_Value (T)); + Set_Is_Constrained (Id, Is_Constrained (T)); + Set_Is_Known_Valid (Id, Is_Known_Valid (T)); + Set_RM_Size (Id, RM_Size (T)); + + when Float_Kind => + Set_Ekind (Id, E_Floating_Point_Subtype); + Set_Scalar_Range (Id, Scalar_Range (T)); + Set_Digits_Value (Id, Digits_Value (T)); + Set_Is_Constrained (Id, Is_Constrained (T)); + + when Signed_Integer_Kind => + Set_Ekind (Id, E_Signed_Integer_Subtype); + Set_Scalar_Range (Id, Scalar_Range (T)); + Set_Is_Constrained (Id, Is_Constrained (T)); + Set_Is_Known_Valid (Id, Is_Known_Valid (T)); + Set_RM_Size (Id, RM_Size (T)); + + when Modular_Integer_Kind => + Set_Ekind (Id, E_Modular_Integer_Subtype); + Set_Scalar_Range (Id, Scalar_Range (T)); + Set_Is_Constrained (Id, Is_Constrained (T)); + Set_Is_Known_Valid (Id, Is_Known_Valid (T)); + Set_RM_Size (Id, RM_Size (T)); + + when Class_Wide_Kind => + Set_Ekind (Id, E_Class_Wide_Subtype); + Set_First_Entity (Id, First_Entity (T)); + Set_Last_Entity (Id, Last_Entity (T)); + Set_Class_Wide_Type (Id, Class_Wide_Type (T)); + Set_Cloned_Subtype (Id, T); + Set_Is_Tagged_Type (Id, True); + Set_Has_Unknown_Discriminants + (Id, True); + + if Ekind (T) = E_Class_Wide_Subtype then + Set_Equivalent_Type (Id, Equivalent_Type (T)); + end if; + + when E_Record_Type | E_Record_Subtype => + Set_Ekind (Id, E_Record_Subtype); + + if Ekind (T) = E_Record_Subtype + and then Present (Cloned_Subtype (T)) + then + Set_Cloned_Subtype (Id, Cloned_Subtype (T)); + else + Set_Cloned_Subtype (Id, T); + end if; + + Set_First_Entity (Id, First_Entity (T)); + Set_Last_Entity (Id, Last_Entity (T)); + Set_Has_Discriminants (Id, Has_Discriminants (T)); + Set_Is_Constrained (Id, Is_Constrained (T)); + Set_Is_Limited_Record (Id, Is_Limited_Record (T)); + Set_Has_Unknown_Discriminants + (Id, Has_Unknown_Discriminants (T)); + + if Has_Discriminants (T) then + Set_Discriminant_Constraint + (Id, Discriminant_Constraint (T)); + Set_Stored_Constraint_From_Discriminant_Constraint (Id); + + elsif Has_Unknown_Discriminants (Id) then + Set_Discriminant_Constraint (Id, No_Elist); + end if; + + if Is_Tagged_Type (T) then + Set_Is_Tagged_Type (Id); + Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); + Set_Direct_Primitive_Operations + (Id, Direct_Primitive_Operations (T)); + Set_Class_Wide_Type (Id, Class_Wide_Type (T)); + + if Is_Interface (T) then + Set_Is_Interface (Id); + Set_Is_Limited_Interface (Id, Is_Limited_Interface (T)); + end if; + end if; + + when Private_Kind => + Set_Ekind (Id, Subtype_Kind (Ekind (T))); + Set_Has_Discriminants (Id, Has_Discriminants (T)); + Set_Is_Constrained (Id, Is_Constrained (T)); + Set_First_Entity (Id, First_Entity (T)); + Set_Last_Entity (Id, Last_Entity (T)); + Set_Private_Dependents (Id, New_Elmt_List); + Set_Is_Limited_Record (Id, Is_Limited_Record (T)); + Set_Has_Unknown_Discriminants + (Id, Has_Unknown_Discriminants (T)); + Set_Known_To_Have_Preelab_Init + (Id, Known_To_Have_Preelab_Init (T)); + + if Is_Tagged_Type (T) then + Set_Is_Tagged_Type (Id); + Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); + Set_Class_Wide_Type (Id, Class_Wide_Type (T)); + Set_Direct_Primitive_Operations (Id, + Direct_Primitive_Operations (T)); + end if; + + -- In general the attributes of the subtype of a private type + -- are the attributes of the partial view of parent. However, + -- the full view may be a discriminated type, and the subtype + -- must share the discriminant constraint to generate correct + -- calls to initialization procedures. + + if Has_Discriminants (T) then + Set_Discriminant_Constraint + (Id, Discriminant_Constraint (T)); + Set_Stored_Constraint_From_Discriminant_Constraint (Id); + + elsif Present (Full_View (T)) + and then Has_Discriminants (Full_View (T)) + then + Set_Discriminant_Constraint + (Id, Discriminant_Constraint (Full_View (T))); + Set_Stored_Constraint_From_Discriminant_Constraint (Id); + + -- This would seem semantically correct, but apparently + -- confuses the back-end. To be explained and checked with + -- current version ??? + + -- Set_Has_Discriminants (Id); + end if; + + Prepare_Private_Subtype_Completion (Id, N); + + when Access_Kind => + Set_Ekind (Id, E_Access_Subtype); + Set_Is_Constrained (Id, Is_Constrained (T)); + Set_Is_Access_Constant + (Id, Is_Access_Constant (T)); + Set_Directly_Designated_Type + (Id, Designated_Type (T)); + Set_Can_Never_Be_Null (Id, Can_Never_Be_Null (T)); + + -- A Pure library_item must not contain the declaration of a + -- named access type, except within a subprogram, generic + -- subprogram, task unit, or protected unit, or if it has + -- a specified Storage_Size of zero (RM05-10.2.1(15.4-15.5)). + + if Comes_From_Source (Id) + and then In_Pure_Unit + and then not In_Subprogram_Task_Protected_Unit + and then not No_Pool_Assigned (Id) + then + Error_Msg_N + ("named access types not allowed in pure unit", N); + end if; + + when Concurrent_Kind => + Set_Ekind (Id, Subtype_Kind (Ekind (T))); + Set_Corresponding_Record_Type (Id, + Corresponding_Record_Type (T)); + Set_First_Entity (Id, First_Entity (T)); + Set_First_Private_Entity (Id, First_Private_Entity (T)); + Set_Has_Discriminants (Id, Has_Discriminants (T)); + Set_Is_Constrained (Id, Is_Constrained (T)); + Set_Is_Tagged_Type (Id, Is_Tagged_Type (T)); + Set_Last_Entity (Id, Last_Entity (T)); + + if Has_Discriminants (T) then + Set_Discriminant_Constraint (Id, + Discriminant_Constraint (T)); + Set_Stored_Constraint_From_Discriminant_Constraint (Id); + end if; + + when E_Incomplete_Type => + if Ada_Version >= Ada_2005 then + Set_Ekind (Id, E_Incomplete_Subtype); + + -- Ada 2005 (AI-412): Decorate an incomplete subtype + -- of an incomplete type visible through a limited + -- with clause. + + if From_With_Type (T) + and then Present (Non_Limited_View (T)) + then + Set_From_With_Type (Id); + Set_Non_Limited_View (Id, Non_Limited_View (T)); + + -- Ada 2005 (AI-412): Add the regular incomplete subtype + -- to the private dependents of the original incomplete + -- type for future transformation. + + else + Append_Elmt (Id, Private_Dependents (T)); + end if; + + -- If the subtype name denotes an incomplete type an error + -- was already reported by Process_Subtype. + + else + Set_Etype (Id, Any_Type); + end if; + + when others => + raise Program_Error; + end case; + end if; + + if Etype (Id) = Any_Type then + goto Leave; + end if; + + -- Some common processing on all types + + Set_Size_Info (Id, T); + Set_First_Rep_Item (Id, First_Rep_Item (T)); + + T := Etype (Id); + + Set_Is_Immediately_Visible (Id, True); + Set_Depends_On_Private (Id, Has_Private_Component (T)); + Set_Is_Descendent_Of_Address (Id, Is_Descendent_Of_Address (T)); + + if Is_Interface (T) then + Set_Is_Interface (Id); + end if; + + if Present (Generic_Parent_Type (N)) + and then + (Nkind + (Parent (Generic_Parent_Type (N))) /= N_Formal_Type_Declaration + or else Nkind + (Formal_Type_Definition (Parent (Generic_Parent_Type (N)))) + /= N_Formal_Private_Type_Definition) + then + if Is_Tagged_Type (Id) then + + -- If this is a generic actual subtype for a synchronized type, + -- the primitive operations are those of the corresponding record + -- for which there is a separate subtype declaration. + + if Is_Concurrent_Type (Id) then + null; + elsif Is_Class_Wide_Type (Id) then + Derive_Subprograms (Generic_Parent_Type (N), Id, Etype (T)); + else + Derive_Subprograms (Generic_Parent_Type (N), Id, T); + end if; + + elsif Scope (Etype (Id)) /= Standard_Standard then + Derive_Subprograms (Generic_Parent_Type (N), Id); + end if; + end if; + + if Is_Private_Type (T) + and then Present (Full_View (T)) + then + Conditional_Delay (Id, Full_View (T)); + + -- The subtypes of components or subcomponents of protected types + -- do not need freeze nodes, which would otherwise appear in the + -- wrong scope (before the freeze node for the protected type). The + -- proper subtypes are those of the subcomponents of the corresponding + -- record. + + elsif Ekind (Scope (Id)) /= E_Protected_Type + and then Present (Scope (Scope (Id))) -- error defense! + and then Ekind (Scope (Scope (Id))) /= E_Protected_Type + then + Conditional_Delay (Id, T); + end if; + + -- Check that constraint_error is raised for a scalar subtype + -- indication when the lower or upper bound of a non-null range + -- lies outside the range of the type mark. + + if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then + if Is_Scalar_Type (Etype (Id)) + and then Scalar_Range (Id) /= + Scalar_Range (Etype (Subtype_Mark + (Subtype_Indication (N)))) + then + Apply_Range_Check + (Scalar_Range (Id), + Etype (Subtype_Mark (Subtype_Indication (N)))); + + elsif Is_Array_Type (Etype (Id)) + and then Present (First_Index (Id)) + then + -- This really should be a subprogram that finds the indications + -- to check??? + + if ((Nkind (First_Index (Id)) = N_Identifier + and then Ekind (Entity (First_Index (Id))) in Scalar_Kind) + or else Nkind (First_Index (Id)) = N_Subtype_Indication) + and then + Nkind (Scalar_Range (Etype (First_Index (Id)))) = N_Range + then + declare + Target_Typ : constant Entity_Id := + Etype + (First_Index (Etype + (Subtype_Mark (Subtype_Indication (N))))); + begin + R_Checks := + Get_Range_Checks + (Scalar_Range (Etype (First_Index (Id))), + Target_Typ, + Etype (First_Index (Id)), + Defining_Identifier (N)); + + Insert_Range_Checks + (R_Checks, + N, + Target_Typ, + Sloc (Defining_Identifier (N))); + end; + end if; + end if; + end if; + + -- Make sure that generic actual types are properly frozen. The subtype + -- is marked as a generic actual type when the enclosing instance is + -- analyzed, so here we identify the subtype from the tree structure. + + if Expander_Active + and then Is_Generic_Actual_Type (Id) + and then In_Instance + and then not Comes_From_Source (N) + and then Nkind (Subtype_Indication (N)) /= N_Subtype_Indication + and then Is_Frozen (T) + then + Freeze_Before (N, Id); + end if; + + Set_Optimize_Alignment_Flags (Id); + Check_Eliminated (Id); + + <> + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); + end Analyze_Subtype_Declaration; + + -------------------------------- + -- Analyze_Subtype_Indication -- + -------------------------------- + + procedure Analyze_Subtype_Indication (N : Node_Id) is + T : constant Entity_Id := Subtype_Mark (N); + R : constant Node_Id := Range_Expression (Constraint (N)); + + begin + Analyze (T); + + if R /= Error then + Analyze (R); + Set_Etype (N, Etype (R)); + Resolve (R, Entity (T)); + else + Set_Error_Posted (R); + Set_Error_Posted (T); + end if; + end Analyze_Subtype_Indication; + + -------------------------- + -- Analyze_Variant_Part -- + -------------------------- + + procedure Analyze_Variant_Part (N : Node_Id) is + + procedure Non_Static_Choice_Error (Choice : Node_Id); + -- Error routine invoked by the generic instantiation below when the + -- variant part has a non static choice. + + procedure Process_Declarations (Variant : Node_Id); + -- Analyzes all the declarations associated with a Variant. Needed by + -- the generic instantiation below. + + package Variant_Choices_Processing is new + Generic_Choices_Processing + (Get_Alternatives => Variants, + Get_Choices => Discrete_Choices, + Process_Empty_Choice => No_OP, + Process_Non_Static_Choice => Non_Static_Choice_Error, + Process_Associated_Node => Process_Declarations); + use Variant_Choices_Processing; + -- Instantiation of the generic choice processing package + + ----------------------------- + -- Non_Static_Choice_Error -- + ----------------------------- + + procedure Non_Static_Choice_Error (Choice : Node_Id) is + begin + Flag_Non_Static_Expr + ("choice given in variant part is not static!", Choice); + end Non_Static_Choice_Error; + + -------------------------- + -- Process_Declarations -- + -------------------------- + + procedure Process_Declarations (Variant : Node_Id) is + begin + if not Null_Present (Component_List (Variant)) then + Analyze_Declarations (Component_Items (Component_List (Variant))); + + if Present (Variant_Part (Component_List (Variant))) then + Analyze (Variant_Part (Component_List (Variant))); + end if; + end if; + end Process_Declarations; + + -- Local Variables + + Discr_Name : Node_Id; + Discr_Type : Entity_Id; + + Dont_Care : Boolean; + Others_Present : Boolean := False; + + pragma Warnings (Off, Dont_Care); + pragma Warnings (Off, Others_Present); + -- We don't care about the assigned values of any of these + + -- Start of processing for Analyze_Variant_Part + + begin + Discr_Name := Name (N); + Analyze (Discr_Name); + + -- If Discr_Name bad, get out (prevent cascaded errors) + + if Etype (Discr_Name) = Any_Type then + return; + end if; + + -- Check invalid discriminant in variant part + + if Ekind (Entity (Discr_Name)) /= E_Discriminant then + Error_Msg_N ("invalid discriminant name in variant part", Discr_Name); + end if; + + Discr_Type := Etype (Entity (Discr_Name)); + + if not Is_Discrete_Type (Discr_Type) then + Error_Msg_N + ("discriminant in a variant part must be of a discrete type", + Name (N)); + return; + end if; + + -- Call the instantiated Analyze_Choices which does the rest of the work + + Analyze_Choices (N, Discr_Type, Dont_Care, Others_Present); + end Analyze_Variant_Part; + + ---------------------------- + -- Array_Type_Declaration -- + ---------------------------- + + procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id) is + Component_Def : constant Node_Id := Component_Definition (Def); + Element_Type : Entity_Id; + Implicit_Base : Entity_Id; + Index : Node_Id; + Related_Id : Entity_Id := Empty; + Nb_Index : Nat; + P : constant Node_Id := Parent (Def); + Priv : Entity_Id; + + begin + if Nkind (Def) = N_Constrained_Array_Definition then + Index := First (Discrete_Subtype_Definitions (Def)); + else + Index := First (Subtype_Marks (Def)); + end if; + + -- Find proper names for the implicit types which may be public. In case + -- of anonymous arrays we use the name of the first object of that type + -- as prefix. + + if No (T) then + Related_Id := Defining_Identifier (P); + else + Related_Id := T; + end if; + + Nb_Index := 1; + while Present (Index) loop + Analyze (Index); + + -- Add a subtype declaration for each index of private array type + -- declaration whose etype is also private. For example: + + -- package Pkg is + -- type Index is private; + -- private + -- type Table is array (Index) of ... + -- end; + + -- This is currently required by the expander for the internally + -- generated equality subprogram of records with variant parts in + -- which the etype of some component is such private type. + + if Ekind (Current_Scope) = E_Package + and then In_Private_Part (Current_Scope) + and then Has_Private_Declaration (Etype (Index)) + then + declare + Loc : constant Source_Ptr := Sloc (Def); + New_E : Entity_Id; + Decl : Entity_Id; + + begin + New_E := Make_Temporary (Loc, 'T'); + Set_Is_Internal (New_E); + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => New_E, + Subtype_Indication => + New_Occurrence_Of (Etype (Index), Loc)); + + Insert_Before (Parent (Def), Decl); + Analyze (Decl); + Set_Etype (Index, New_E); + + -- If the index is a range the Entity attribute is not + -- available. Example: + + -- package Pkg is + -- type T is private; + -- private + -- type T is new Natural; + -- Table : array (T(1) .. T(10)) of Boolean; + -- end Pkg; + + if Nkind (Index) /= N_Range then + Set_Entity (Index, New_E); + end if; + end; + end if; + + Make_Index (Index, P, Related_Id, Nb_Index); + + -- Check error of subtype with predicate for index type + + Bad_Predicated_Subtype_Use + ("subtype& has predicate, not allowed as index subtype", + Index, Etype (Index)); + + -- Move to next index + + Next_Index (Index); + Nb_Index := Nb_Index + 1; + end loop; + + -- Process subtype indication if one is present + + if Present (Subtype_Indication (Component_Def)) then + Element_Type := + Process_Subtype + (Subtype_Indication (Component_Def), P, Related_Id, 'C'); + + -- Ada 2005 (AI-230): Access Definition case + + else pragma Assert (Present (Access_Definition (Component_Def))); + + -- Indicate that the anonymous access type is created by the + -- array type declaration. + + Element_Type := Access_Definition + (Related_Nod => P, + N => Access_Definition (Component_Def)); + Set_Is_Local_Anonymous_Access (Element_Type); + + -- Propagate the parent. This field is needed if we have to generate + -- the master_id associated with an anonymous access to task type + -- component (see Expand_N_Full_Type_Declaration.Build_Master) + + Set_Parent (Element_Type, Parent (T)); + + -- Ada 2005 (AI-230): In case of components that are anonymous access + -- types the level of accessibility depends on the enclosing type + -- declaration + + Set_Scope (Element_Type, Current_Scope); -- Ada 2005 (AI-230) + + -- Ada 2005 (AI-254) + + declare + CD : constant Node_Id := + Access_To_Subprogram_Definition + (Access_Definition (Component_Def)); + begin + if Present (CD) and then Protected_Present (CD) then + Element_Type := + Replace_Anonymous_Access_To_Protected_Subprogram (Def); + end if; + end; + end if; + + -- Constrained array case + + if No (T) then + T := Create_Itype (E_Void, P, Related_Id, 'T'); + end if; + + if Nkind (Def) = N_Constrained_Array_Definition then + + -- Establish Implicit_Base as unconstrained base type + + Implicit_Base := Create_Itype (E_Array_Type, P, Related_Id, 'B'); + + Set_Etype (Implicit_Base, Implicit_Base); + Set_Scope (Implicit_Base, Current_Scope); + Set_Has_Delayed_Freeze (Implicit_Base); + + -- The constrained array type is a subtype of the unconstrained one + + Set_Ekind (T, E_Array_Subtype); + Init_Size_Align (T); + Set_Etype (T, Implicit_Base); + Set_Scope (T, Current_Scope); + Set_Is_Constrained (T, True); + Set_First_Index (T, First (Discrete_Subtype_Definitions (Def))); + Set_Has_Delayed_Freeze (T); + + -- Complete setup of implicit base type + + Set_First_Index (Implicit_Base, First_Index (T)); + Set_Component_Type (Implicit_Base, Element_Type); + Set_Has_Task (Implicit_Base, Has_Task (Element_Type)); + Set_Component_Size (Implicit_Base, Uint_0); + Set_Packed_Array_Type (Implicit_Base, Empty); + Set_Has_Controlled_Component + (Implicit_Base, Has_Controlled_Component + (Element_Type) + or else Is_Controlled + (Element_Type)); + Set_Finalize_Storage_Only + (Implicit_Base, Finalize_Storage_Only + (Element_Type)); + + -- Unconstrained array case + + else + Set_Ekind (T, E_Array_Type); + Init_Size_Align (T); + Set_Etype (T, T); + Set_Scope (T, Current_Scope); + Set_Component_Size (T, Uint_0); + Set_Is_Constrained (T, False); + Set_First_Index (T, First (Subtype_Marks (Def))); + Set_Has_Delayed_Freeze (T, True); + Set_Has_Task (T, Has_Task (Element_Type)); + Set_Has_Controlled_Component (T, Has_Controlled_Component + (Element_Type) + or else + Is_Controlled (Element_Type)); + Set_Finalize_Storage_Only (T, Finalize_Storage_Only + (Element_Type)); + end if; + + -- Common attributes for both cases + + Set_Component_Type (Base_Type (T), Element_Type); + Set_Packed_Array_Type (T, Empty); + + if Aliased_Present (Component_Definition (Def)) then + Set_Has_Aliased_Components (Etype (T)); + end if; + + -- Ada 2005 (AI-231): Propagate the null-excluding attribute to the + -- array type to ensure that objects of this type are initialized. + + if Ada_Version >= Ada_2005 + and then Can_Never_Be_Null (Element_Type) + then + Set_Can_Never_Be_Null (T); + + if Null_Exclusion_Present (Component_Definition (Def)) + + -- No need to check itypes because in their case this check was + -- done at their point of creation + + and then not Is_Itype (Element_Type) + then + Error_Msg_N + ("`NOT NULL` not allowed (null already excluded)", + Subtype_Indication (Component_Definition (Def))); + end if; + end if; + + Priv := Private_Component (Element_Type); + + if Present (Priv) then + + -- Check for circular definitions + + if Priv = Any_Type then + Set_Component_Type (Etype (T), Any_Type); + + -- There is a gap in the visibility of operations on the composite + -- type only if the component type is defined in a different scope. + + elsif Scope (Priv) = Current_Scope then + null; + + elsif Is_Limited_Type (Priv) then + Set_Is_Limited_Composite (Etype (T)); + Set_Is_Limited_Composite (T); + else + Set_Is_Private_Composite (Etype (T)); + Set_Is_Private_Composite (T); + end if; + end if; + + -- A syntax error in the declaration itself may lead to an empty index + -- list, in which case do a minimal patch. + + if No (First_Index (T)) then + Error_Msg_N ("missing index definition in array type declaration", T); + + declare + Indexes : constant List_Id := + New_List (New_Occurrence_Of (Any_Id, Sloc (T))); + begin + Set_Discrete_Subtype_Definitions (Def, Indexes); + Set_First_Index (T, First (Indexes)); + return; + end; + end if; + + -- Create a concatenation operator for the new type. Internal array + -- types created for packed entities do not need such, they are + -- compatible with the user-defined type. + + if Number_Dimensions (T) = 1 + and then not Is_Packed_Array_Type (T) + then + New_Concatenation_Op (T); + end if; + + -- In the case of an unconstrained array the parser has already verified + -- that all the indexes are unconstrained but we still need to make sure + -- that the element type is constrained. + + if Is_Indefinite_Subtype (Element_Type) then + Error_Msg_N + ("unconstrained element type in array declaration", + Subtype_Indication (Component_Def)); + + elsif Is_Abstract_Type (Element_Type) then + Error_Msg_N + ("the type of a component cannot be abstract", + Subtype_Indication (Component_Def)); + end if; + end Array_Type_Declaration; + + ------------------------------------------------------ + -- Replace_Anonymous_Access_To_Protected_Subprogram -- + ------------------------------------------------------ + + function Replace_Anonymous_Access_To_Protected_Subprogram + (N : Node_Id) return Entity_Id + is + Loc : constant Source_Ptr := Sloc (N); + + Curr_Scope : constant Scope_Stack_Entry := + Scope_Stack.Table (Scope_Stack.Last); + + Anon : constant Entity_Id := Make_Temporary (Loc, 'S'); + Acc : Node_Id; + Comp : Node_Id; + Decl : Node_Id; + P : Node_Id; + + begin + Set_Is_Internal (Anon); + + case Nkind (N) is + when N_Component_Declaration | + N_Unconstrained_Array_Definition | + N_Constrained_Array_Definition => + Comp := Component_Definition (N); + Acc := Access_Definition (Comp); + + when N_Discriminant_Specification => + Comp := Discriminant_Type (N); + Acc := Comp; + + when N_Parameter_Specification => + Comp := Parameter_Type (N); + Acc := Comp; + + when N_Access_Function_Definition => + Comp := Result_Definition (N); + Acc := Comp; + + when N_Object_Declaration => + Comp := Object_Definition (N); + Acc := Comp; + + when N_Function_Specification => + Comp := Result_Definition (N); + Acc := Comp; + + when others => + raise Program_Error; + end case; + + Decl := Make_Full_Type_Declaration (Loc, + Defining_Identifier => Anon, + Type_Definition => + Copy_Separate_Tree (Access_To_Subprogram_Definition (Acc))); + + Mark_Rewrite_Insertion (Decl); + + -- Insert the new declaration in the nearest enclosing scope. If the + -- node is a body and N is its return type, the declaration belongs in + -- the enclosing scope. + + P := Parent (N); + + if Nkind (P) = N_Subprogram_Body + and then Nkind (N) = N_Function_Specification + then + P := Parent (P); + end if; + + while Present (P) and then not Has_Declarations (P) loop + P := Parent (P); + end loop; + + pragma Assert (Present (P)); + + if Nkind (P) = N_Package_Specification then + Prepend (Decl, Visible_Declarations (P)); + else + Prepend (Decl, Declarations (P)); + end if; + + -- Replace the anonymous type with an occurrence of the new declaration. + -- In all cases the rewritten node does not have the null-exclusion + -- attribute because (if present) it was already inherited by the + -- anonymous entity (Anon). Thus, in case of components we do not + -- inherit this attribute. + + if Nkind (N) = N_Parameter_Specification then + Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); + Set_Etype (Defining_Identifier (N), Anon); + Set_Null_Exclusion_Present (N, False); + + elsif Nkind (N) = N_Object_Declaration then + Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); + Set_Etype (Defining_Identifier (N), Anon); + + elsif Nkind (N) = N_Access_Function_Definition then + Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); + + elsif Nkind (N) = N_Function_Specification then + Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); + Set_Etype (Defining_Unit_Name (N), Anon); + + else + Rewrite (Comp, + Make_Component_Definition (Loc, + Subtype_Indication => New_Occurrence_Of (Anon, Loc))); + end if; + + Mark_Rewrite_Insertion (Comp); + + if Nkind_In (N, N_Object_Declaration, N_Access_Function_Definition) then + Analyze (Decl); + + else + -- Temporarily remove the current scope (record or subprogram) from + -- the stack to add the new declarations to the enclosing scope. + + Scope_Stack.Decrement_Last; + Analyze (Decl); + Set_Is_Itype (Anon); + Scope_Stack.Append (Curr_Scope); + end if; + + Set_Ekind (Anon, E_Anonymous_Access_Protected_Subprogram_Type); + Set_Can_Use_Internal_Rep (Anon, not Always_Compatible_Rep_On_Target); + return Anon; + end Replace_Anonymous_Access_To_Protected_Subprogram; + + ------------------------------- + -- Build_Derived_Access_Type -- + ------------------------------- + + procedure Build_Derived_Access_Type + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id) + is + S : constant Node_Id := Subtype_Indication (Type_Definition (N)); + + Desig_Type : Entity_Id; + Discr : Entity_Id; + Discr_Con_Elist : Elist_Id; + Discr_Con_El : Elmt_Id; + Subt : Entity_Id; + + begin + -- Set the designated type so it is available in case this is an access + -- to a self-referential type, e.g. a standard list type with a next + -- pointer. Will be reset after subtype is built. + + Set_Directly_Designated_Type + (Derived_Type, Designated_Type (Parent_Type)); + + Subt := Process_Subtype (S, N); + + if Nkind (S) /= N_Subtype_Indication + and then Subt /= Base_Type (Subt) + then + Set_Ekind (Derived_Type, E_Access_Subtype); + end if; + + if Ekind (Derived_Type) = E_Access_Subtype then + declare + Pbase : constant Entity_Id := Base_Type (Parent_Type); + Ibase : constant Entity_Id := + Create_Itype (Ekind (Pbase), N, Derived_Type, 'B'); + Svg_Chars : constant Name_Id := Chars (Ibase); + Svg_Next_E : constant Entity_Id := Next_Entity (Ibase); + + begin + Copy_Node (Pbase, Ibase); + + Set_Chars (Ibase, Svg_Chars); + Set_Next_Entity (Ibase, Svg_Next_E); + Set_Sloc (Ibase, Sloc (Derived_Type)); + Set_Scope (Ibase, Scope (Derived_Type)); + Set_Freeze_Node (Ibase, Empty); + Set_Is_Frozen (Ibase, False); + Set_Comes_From_Source (Ibase, False); + Set_Is_First_Subtype (Ibase, False); + + Set_Etype (Ibase, Pbase); + Set_Etype (Derived_Type, Ibase); + end; + end if; + + Set_Directly_Designated_Type + (Derived_Type, Designated_Type (Subt)); + + Set_Is_Constrained (Derived_Type, Is_Constrained (Subt)); + Set_Is_Access_Constant (Derived_Type, Is_Access_Constant (Parent_Type)); + Set_Size_Info (Derived_Type, Parent_Type); + Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); + Set_Depends_On_Private (Derived_Type, + Has_Private_Component (Derived_Type)); + Conditional_Delay (Derived_Type, Subt); + + -- Ada 2005 (AI-231): Set the null-exclusion attribute, and verify + -- that it is not redundant. + + if Null_Exclusion_Present (Type_Definition (N)) then + Set_Can_Never_Be_Null (Derived_Type); + + if Can_Never_Be_Null (Parent_Type) + and then False + then + Error_Msg_NE + ("`NOT NULL` not allowed (& already excludes null)", + N, Parent_Type); + end if; + + elsif Can_Never_Be_Null (Parent_Type) then + Set_Can_Never_Be_Null (Derived_Type); + end if; + + -- Note: we do not copy the Storage_Size_Variable, since we always go to + -- the root type for this information. + + -- Apply range checks to discriminants for derived record case + -- ??? THIS CODE SHOULD NOT BE HERE REALLY. + + Desig_Type := Designated_Type (Derived_Type); + if Is_Composite_Type (Desig_Type) + and then (not Is_Array_Type (Desig_Type)) + and then Has_Discriminants (Desig_Type) + and then Base_Type (Desig_Type) /= Desig_Type + then + Discr_Con_Elist := Discriminant_Constraint (Desig_Type); + Discr_Con_El := First_Elmt (Discr_Con_Elist); + + Discr := First_Discriminant (Base_Type (Desig_Type)); + while Present (Discr_Con_El) loop + Apply_Range_Check (Node (Discr_Con_El), Etype (Discr)); + Next_Elmt (Discr_Con_El); + Next_Discriminant (Discr); + end loop; + end if; + end Build_Derived_Access_Type; + + ------------------------------ + -- Build_Derived_Array_Type -- + ------------------------------ + + procedure Build_Derived_Array_Type + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Tdef : constant Node_Id := Type_Definition (N); + Indic : constant Node_Id := Subtype_Indication (Tdef); + Parent_Base : constant Entity_Id := Base_Type (Parent_Type); + Implicit_Base : Entity_Id; + New_Indic : Node_Id; + + procedure Make_Implicit_Base; + -- If the parent subtype is constrained, the derived type is a subtype + -- of an implicit base type derived from the parent base. + + ------------------------ + -- Make_Implicit_Base -- + ------------------------ + + procedure Make_Implicit_Base is + begin + Implicit_Base := + Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B'); + + Set_Ekind (Implicit_Base, Ekind (Parent_Base)); + Set_Etype (Implicit_Base, Parent_Base); + + Copy_Array_Subtype_Attributes (Implicit_Base, Parent_Base); + Copy_Array_Base_Type_Attributes (Implicit_Base, Parent_Base); + + Set_Has_Delayed_Freeze (Implicit_Base, True); + end Make_Implicit_Base; + + -- Start of processing for Build_Derived_Array_Type + + begin + if not Is_Constrained (Parent_Type) then + if Nkind (Indic) /= N_Subtype_Indication then + Set_Ekind (Derived_Type, E_Array_Type); + + Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type); + Copy_Array_Base_Type_Attributes (Derived_Type, Parent_Type); + + Set_Has_Delayed_Freeze (Derived_Type, True); + + else + Make_Implicit_Base; + Set_Etype (Derived_Type, Implicit_Base); + + New_Indic := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Derived_Type, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (Implicit_Base, Loc), + Constraint => Constraint (Indic))); + + Rewrite (N, New_Indic); + Analyze (N); + end if; + + else + if Nkind (Indic) /= N_Subtype_Indication then + Make_Implicit_Base; + + Set_Ekind (Derived_Type, Ekind (Parent_Type)); + Set_Etype (Derived_Type, Implicit_Base); + Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type); + + else + Error_Msg_N ("illegal constraint on constrained type", Indic); + end if; + end if; + + -- If parent type is not a derived type itself, and is declared in + -- closed scope (e.g. a subprogram), then we must explicitly introduce + -- the new type's concatenation operator since Derive_Subprograms + -- will not inherit the parent's operator. If the parent type is + -- unconstrained, the operator is of the unconstrained base type. + + if Number_Dimensions (Parent_Type) = 1 + and then not Is_Limited_Type (Parent_Type) + and then not Is_Derived_Type (Parent_Type) + and then not Is_Package_Or_Generic_Package + (Scope (Base_Type (Parent_Type))) + then + if not Is_Constrained (Parent_Type) + and then Is_Constrained (Derived_Type) + then + New_Concatenation_Op (Implicit_Base); + else + New_Concatenation_Op (Derived_Type); + end if; + end if; + end Build_Derived_Array_Type; + + ----------------------------------- + -- Build_Derived_Concurrent_Type -- + ----------------------------------- + + procedure Build_Derived_Concurrent_Type + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + + Corr_Record : constant Entity_Id := Make_Temporary (Loc, 'C'); + Corr_Decl : Node_Id; + Corr_Decl_Needed : Boolean; + -- If the derived type has fewer discriminants than its parent, the + -- corresponding record is also a derived type, in order to account for + -- the bound discriminants. We create a full type declaration for it in + -- this case. + + Constraint_Present : constant Boolean := + Nkind (Subtype_Indication (Type_Definition (N))) = + N_Subtype_Indication; + + D_Constraint : Node_Id; + New_Constraint : Elist_Id; + Old_Disc : Entity_Id; + New_Disc : Entity_Id; + New_N : Node_Id; + + begin + Set_Stored_Constraint (Derived_Type, No_Elist); + Corr_Decl_Needed := False; + Old_Disc := Empty; + + if Present (Discriminant_Specifications (N)) + and then Constraint_Present + then + Old_Disc := First_Discriminant (Parent_Type); + New_Disc := First (Discriminant_Specifications (N)); + while Present (New_Disc) and then Present (Old_Disc) loop + Next_Discriminant (Old_Disc); + Next (New_Disc); + end loop; + end if; + + if Present (Old_Disc) and then Expander_Active then + + -- The new type has fewer discriminants, so we need to create a new + -- corresponding record, which is derived from the corresponding + -- record of the parent, and has a stored constraint that captures + -- the values of the discriminant constraints. The corresponding + -- record is needed only if expander is active and code generation is + -- enabled. + + -- The type declaration for the derived corresponding record has the + -- same discriminant part and constraints as the current declaration. + -- Copy the unanalyzed tree to build declaration. + + Corr_Decl_Needed := True; + New_N := Copy_Separate_Tree (N); + + Corr_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Corr_Record, + Discriminant_Specifications => + Discriminant_Specifications (New_N), + Type_Definition => + Make_Derived_Type_Definition (Loc, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of + (Corresponding_Record_Type (Parent_Type), Loc), + Constraint => + Constraint + (Subtype_Indication (Type_Definition (New_N)))))); + end if; + + -- Copy Storage_Size and Relative_Deadline variables if task case + + if Is_Task_Type (Parent_Type) then + Set_Storage_Size_Variable (Derived_Type, + Storage_Size_Variable (Parent_Type)); + Set_Relative_Deadline_Variable (Derived_Type, + Relative_Deadline_Variable (Parent_Type)); + end if; + + if Present (Discriminant_Specifications (N)) then + Push_Scope (Derived_Type); + Check_Or_Process_Discriminants (N, Derived_Type); + + if Constraint_Present then + New_Constraint := + Expand_To_Stored_Constraint + (Parent_Type, + Build_Discriminant_Constraints + (Parent_Type, + Subtype_Indication (Type_Definition (N)), True)); + end if; + + End_Scope; + + elsif Constraint_Present then + + -- Build constrained subtype and derive from it + + declare + Loc : constant Source_Ptr := Sloc (N); + Anon : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Derived_Type), 'T')); + Decl : Node_Id; + + begin + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Anon, + Subtype_Indication => + Subtype_Indication (Type_Definition (N))); + Insert_Before (N, Decl); + Analyze (Decl); + + Rewrite (Subtype_Indication (Type_Definition (N)), + New_Occurrence_Of (Anon, Loc)); + Set_Analyzed (Derived_Type, False); + Analyze (N); + return; + end; + end if; + + -- By default, operations and private data are inherited from parent. + -- However, in the presence of bound discriminants, a new corresponding + -- record will be created, see below. + + Set_Has_Discriminants + (Derived_Type, Has_Discriminants (Parent_Type)); + Set_Corresponding_Record_Type + (Derived_Type, Corresponding_Record_Type (Parent_Type)); + + -- Is_Constrained is set according the parent subtype, but is set to + -- False if the derived type is declared with new discriminants. + + Set_Is_Constrained + (Derived_Type, + (Is_Constrained (Parent_Type) or else Constraint_Present) + and then not Present (Discriminant_Specifications (N))); + + if Constraint_Present then + if not Has_Discriminants (Parent_Type) then + Error_Msg_N ("untagged parent must have discriminants", N); + + elsif Present (Discriminant_Specifications (N)) then + + -- Verify that new discriminants are used to constrain old ones + + D_Constraint := + First + (Constraints + (Constraint (Subtype_Indication (Type_Definition (N))))); + + Old_Disc := First_Discriminant (Parent_Type); + + while Present (D_Constraint) loop + if Nkind (D_Constraint) /= N_Discriminant_Association then + + -- Positional constraint. If it is a reference to a new + -- discriminant, it constrains the corresponding old one. + + if Nkind (D_Constraint) = N_Identifier then + New_Disc := First_Discriminant (Derived_Type); + while Present (New_Disc) loop + exit when Chars (New_Disc) = Chars (D_Constraint); + Next_Discriminant (New_Disc); + end loop; + + if Present (New_Disc) then + Set_Corresponding_Discriminant (New_Disc, Old_Disc); + end if; + end if; + + Next_Discriminant (Old_Disc); + + -- if this is a named constraint, search by name for the old + -- discriminants constrained by the new one. + + elsif Nkind (Expression (D_Constraint)) = N_Identifier then + + -- Find new discriminant with that name + + New_Disc := First_Discriminant (Derived_Type); + while Present (New_Disc) loop + exit when + Chars (New_Disc) = Chars (Expression (D_Constraint)); + Next_Discriminant (New_Disc); + end loop; + + if Present (New_Disc) then + + -- Verify that new discriminant renames some discriminant + -- of the parent type, and associate the new discriminant + -- with one or more old ones that it renames. + + declare + Selector : Node_Id; + + begin + Selector := First (Selector_Names (D_Constraint)); + while Present (Selector) loop + Old_Disc := First_Discriminant (Parent_Type); + while Present (Old_Disc) loop + exit when Chars (Old_Disc) = Chars (Selector); + Next_Discriminant (Old_Disc); + end loop; + + if Present (Old_Disc) then + Set_Corresponding_Discriminant + (New_Disc, Old_Disc); + end if; + + Next (Selector); + end loop; + end; + end if; + end if; + + Next (D_Constraint); + end loop; + + New_Disc := First_Discriminant (Derived_Type); + while Present (New_Disc) loop + if No (Corresponding_Discriminant (New_Disc)) then + Error_Msg_NE + ("new discriminant& must constrain old one", N, New_Disc); + + elsif not + Subtypes_Statically_Compatible + (Etype (New_Disc), + Etype (Corresponding_Discriminant (New_Disc))) + then + Error_Msg_NE + ("& not statically compatible with parent discriminant", + N, New_Disc); + end if; + + Next_Discriminant (New_Disc); + end loop; + end if; + + elsif Present (Discriminant_Specifications (N)) then + Error_Msg_N + ("missing discriminant constraint in untagged derivation", N); + end if; + + -- The entity chain of the derived type includes the new discriminants + -- but shares operations with the parent. + + if Present (Discriminant_Specifications (N)) then + Old_Disc := First_Discriminant (Parent_Type); + while Present (Old_Disc) loop + if No (Next_Entity (Old_Disc)) + or else Ekind (Next_Entity (Old_Disc)) /= E_Discriminant + then + Set_Next_Entity + (Last_Entity (Derived_Type), Next_Entity (Old_Disc)); + exit; + end if; + + Next_Discriminant (Old_Disc); + end loop; + + else + Set_First_Entity (Derived_Type, First_Entity (Parent_Type)); + if Has_Discriminants (Parent_Type) then + Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); + Set_Discriminant_Constraint ( + Derived_Type, Discriminant_Constraint (Parent_Type)); + end if; + end if; + + Set_Last_Entity (Derived_Type, Last_Entity (Parent_Type)); + + Set_Has_Completion (Derived_Type); + + if Corr_Decl_Needed then + Set_Stored_Constraint (Derived_Type, New_Constraint); + Insert_After (N, Corr_Decl); + Analyze (Corr_Decl); + Set_Corresponding_Record_Type (Derived_Type, Corr_Record); + end if; + end Build_Derived_Concurrent_Type; + + ------------------------------------ + -- Build_Derived_Enumeration_Type -- + ------------------------------------ + + procedure Build_Derived_Enumeration_Type + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Def : constant Node_Id := Type_Definition (N); + Indic : constant Node_Id := Subtype_Indication (Def); + Implicit_Base : Entity_Id; + Literal : Entity_Id; + New_Lit : Entity_Id; + Literals_List : List_Id; + Type_Decl : Node_Id; + Hi, Lo : Node_Id; + Rang_Expr : Node_Id; + + begin + -- Since types Standard.Character and Standard.[Wide_]Wide_Character do + -- not have explicit literals lists we need to process types derived + -- from them specially. This is handled by Derived_Standard_Character. + -- If the parent type is a generic type, there are no literals either, + -- and we construct the same skeletal representation as for the generic + -- parent type. + + if Is_Standard_Character_Type (Parent_Type) then + Derived_Standard_Character (N, Parent_Type, Derived_Type); + + elsif Is_Generic_Type (Root_Type (Parent_Type)) then + declare + Lo : Node_Id; + Hi : Node_Id; + + begin + if Nkind (Indic) /= N_Subtype_Indication then + Lo := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_First, + Prefix => New_Reference_To (Derived_Type, Loc)); + Set_Etype (Lo, Derived_Type); + + Hi := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Last, + Prefix => New_Reference_To (Derived_Type, Loc)); + Set_Etype (Hi, Derived_Type); + + Set_Scalar_Range (Derived_Type, + Make_Range (Loc, + Low_Bound => Lo, + High_Bound => Hi)); + else + + -- Analyze subtype indication and verify compatibility + -- with parent type. + + if Base_Type (Process_Subtype (Indic, N)) /= + Base_Type (Parent_Type) + then + Error_Msg_N + ("illegal constraint for formal discrete type", N); + end if; + end if; + end; + + else + -- If a constraint is present, analyze the bounds to catch + -- premature usage of the derived literals. + + if Nkind (Indic) = N_Subtype_Indication + and then Nkind (Range_Expression (Constraint (Indic))) = N_Range + then + Analyze (Low_Bound (Range_Expression (Constraint (Indic)))); + Analyze (High_Bound (Range_Expression (Constraint (Indic)))); + end if; + + -- Introduce an implicit base type for the derived type even if there + -- is no constraint attached to it, since this seems closer to the + -- Ada semantics. Build a full type declaration tree for the derived + -- type using the implicit base type as the defining identifier. The + -- build a subtype declaration tree which applies the constraint (if + -- any) have it replace the derived type declaration. + + Literal := First_Literal (Parent_Type); + Literals_List := New_List; + while Present (Literal) + and then Ekind (Literal) = E_Enumeration_Literal + loop + -- Literals of the derived type have the same representation as + -- those of the parent type, but this representation can be + -- overridden by an explicit representation clause. Indicate + -- that there is no explicit representation given yet. These + -- derived literals are implicit operations of the new type, + -- and can be overridden by explicit ones. + + if Nkind (Literal) = N_Defining_Character_Literal then + New_Lit := + Make_Defining_Character_Literal (Loc, Chars (Literal)); + else + New_Lit := Make_Defining_Identifier (Loc, Chars (Literal)); + end if; + + Set_Ekind (New_Lit, E_Enumeration_Literal); + Set_Enumeration_Pos (New_Lit, Enumeration_Pos (Literal)); + Set_Enumeration_Rep (New_Lit, Enumeration_Rep (Literal)); + Set_Enumeration_Rep_Expr (New_Lit, Empty); + Set_Alias (New_Lit, Literal); + Set_Is_Known_Valid (New_Lit, True); + + Append (New_Lit, Literals_List); + Next_Literal (Literal); + end loop; + + Implicit_Base := + Make_Defining_Identifier (Sloc (Derived_Type), + Chars => New_External_Name (Chars (Derived_Type), 'B')); + + -- Indicate the proper nature of the derived type. This must be done + -- before analysis of the literals, to recognize cases when a literal + -- may be hidden by a previous explicit function definition (cf. + -- c83031a). + + Set_Ekind (Derived_Type, E_Enumeration_Subtype); + Set_Etype (Derived_Type, Implicit_Base); + + Type_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Implicit_Base, + Discriminant_Specifications => No_List, + Type_Definition => + Make_Enumeration_Type_Definition (Loc, Literals_List)); + + Mark_Rewrite_Insertion (Type_Decl); + Insert_Before (N, Type_Decl); + Analyze (Type_Decl); + + -- After the implicit base is analyzed its Etype needs to be changed + -- to reflect the fact that it is derived from the parent type which + -- was ignored during analysis. We also set the size at this point. + + Set_Etype (Implicit_Base, Parent_Type); + + Set_Size_Info (Implicit_Base, Parent_Type); + Set_RM_Size (Implicit_Base, RM_Size (Parent_Type)); + Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Type)); + + -- Copy other flags from parent type + + Set_Has_Non_Standard_Rep + (Implicit_Base, Has_Non_Standard_Rep + (Parent_Type)); + Set_Has_Pragma_Ordered + (Implicit_Base, Has_Pragma_Ordered + (Parent_Type)); + Set_Has_Delayed_Freeze (Implicit_Base); + + -- Process the subtype indication including a validation check on the + -- constraint, if any. If a constraint is given, its bounds must be + -- implicitly converted to the new type. + + if Nkind (Indic) = N_Subtype_Indication then + declare + R : constant Node_Id := + Range_Expression (Constraint (Indic)); + + begin + if Nkind (R) = N_Range then + Hi := Build_Scalar_Bound + (High_Bound (R), Parent_Type, Implicit_Base); + Lo := Build_Scalar_Bound + (Low_Bound (R), Parent_Type, Implicit_Base); + + else + -- Constraint is a Range attribute. Replace with explicit + -- mention of the bounds of the prefix, which must be a + -- subtype. + + Analyze (Prefix (R)); + Hi := + Convert_To (Implicit_Base, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Last, + Prefix => + New_Occurrence_Of (Entity (Prefix (R)), Loc))); + + Lo := + Convert_To (Implicit_Base, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_First, + Prefix => + New_Occurrence_Of (Entity (Prefix (R)), Loc))); + end if; + end; + + else + Hi := + Build_Scalar_Bound + (Type_High_Bound (Parent_Type), + Parent_Type, Implicit_Base); + Lo := + Build_Scalar_Bound + (Type_Low_Bound (Parent_Type), + Parent_Type, Implicit_Base); + end if; + + Rang_Expr := + Make_Range (Loc, + Low_Bound => Lo, + High_Bound => Hi); + + -- If we constructed a default range for the case where no range + -- was given, then the expressions in the range must not freeze + -- since they do not correspond to expressions in the source. + + if Nkind (Indic) /= N_Subtype_Indication then + Set_Must_Not_Freeze (Lo); + Set_Must_Not_Freeze (Hi); + Set_Must_Not_Freeze (Rang_Expr); + end if; + + Rewrite (N, + Make_Subtype_Declaration (Loc, + Defining_Identifier => Derived_Type, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Implicit_Base, Loc), + Constraint => + Make_Range_Constraint (Loc, + Range_Expression => Rang_Expr)))); + + Analyze (N); + + -- If pragma Discard_Names applies on the first subtype of the parent + -- type, then it must be applied on this subtype as well. + + if Einfo.Discard_Names (First_Subtype (Parent_Type)) then + Set_Discard_Names (Derived_Type); + end if; + + -- Apply a range check. Since this range expression doesn't have an + -- Etype, we have to specifically pass the Source_Typ parameter. Is + -- this right??? + + if Nkind (Indic) = N_Subtype_Indication then + Apply_Range_Check (Range_Expression (Constraint (Indic)), + Parent_Type, + Source_Typ => Entity (Subtype_Mark (Indic))); + end if; + end if; + end Build_Derived_Enumeration_Type; + + -------------------------------- + -- Build_Derived_Numeric_Type -- + -------------------------------- + + procedure Build_Derived_Numeric_Type + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Tdef : constant Node_Id := Type_Definition (N); + Indic : constant Node_Id := Subtype_Indication (Tdef); + Parent_Base : constant Entity_Id := Base_Type (Parent_Type); + No_Constraint : constant Boolean := Nkind (Indic) /= + N_Subtype_Indication; + Implicit_Base : Entity_Id; + + Lo : Node_Id; + Hi : Node_Id; + + begin + -- Process the subtype indication including a validation check on + -- the constraint if any. + + Discard_Node (Process_Subtype (Indic, N)); + + -- Introduce an implicit base type for the derived type even if there + -- is no constraint attached to it, since this seems closer to the Ada + -- semantics. + + Implicit_Base := + Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B'); + + Set_Etype (Implicit_Base, Parent_Base); + Set_Ekind (Implicit_Base, Ekind (Parent_Base)); + Set_Size_Info (Implicit_Base, Parent_Base); + Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Base)); + Set_Parent (Implicit_Base, Parent (Derived_Type)); + Set_Is_Known_Valid (Implicit_Base, Is_Known_Valid (Parent_Base)); + + -- Set RM Size for discrete type or decimal fixed-point type + -- Ordinary fixed-point is excluded, why??? + + if Is_Discrete_Type (Parent_Base) + or else Is_Decimal_Fixed_Point_Type (Parent_Base) + then + Set_RM_Size (Implicit_Base, RM_Size (Parent_Base)); + end if; + + Set_Has_Delayed_Freeze (Implicit_Base); + + Lo := New_Copy_Tree (Type_Low_Bound (Parent_Base)); + Hi := New_Copy_Tree (Type_High_Bound (Parent_Base)); + + Set_Scalar_Range (Implicit_Base, + Make_Range (Loc, + Low_Bound => Lo, + High_Bound => Hi)); + + if Has_Infinities (Parent_Base) then + Set_Includes_Infinities (Scalar_Range (Implicit_Base)); + end if; + + -- The Derived_Type, which is the entity of the declaration, is a + -- subtype of the implicit base. Its Ekind is a subtype, even in the + -- absence of an explicit constraint. + + Set_Etype (Derived_Type, Implicit_Base); + + -- If we did not have a constraint, then the Ekind is set from the + -- parent type (otherwise Process_Subtype has set the bounds) + + if No_Constraint then + Set_Ekind (Derived_Type, Subtype_Kind (Ekind (Parent_Type))); + end if; + + -- If we did not have a range constraint, then set the range from the + -- parent type. Otherwise, the Process_Subtype call has set the bounds. + + if No_Constraint + or else not Has_Range_Constraint (Indic) + then + Set_Scalar_Range (Derived_Type, + Make_Range (Loc, + Low_Bound => New_Copy_Tree (Type_Low_Bound (Parent_Type)), + High_Bound => New_Copy_Tree (Type_High_Bound (Parent_Type)))); + Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); + + if Has_Infinities (Parent_Type) then + Set_Includes_Infinities (Scalar_Range (Derived_Type)); + end if; + + Set_Is_Known_Valid (Derived_Type, Is_Known_Valid (Parent_Type)); + end if; + + Set_Is_Descendent_Of_Address (Derived_Type, + Is_Descendent_Of_Address (Parent_Type)); + Set_Is_Descendent_Of_Address (Implicit_Base, + Is_Descendent_Of_Address (Parent_Type)); + + -- Set remaining type-specific fields, depending on numeric type + + if Is_Modular_Integer_Type (Parent_Type) then + Set_Modulus (Implicit_Base, Modulus (Parent_Base)); + + Set_Non_Binary_Modulus + (Implicit_Base, Non_Binary_Modulus (Parent_Base)); + + Set_Is_Known_Valid + (Implicit_Base, Is_Known_Valid (Parent_Base)); + + elsif Is_Floating_Point_Type (Parent_Type) then + + -- Digits of base type is always copied from the digits value of + -- the parent base type, but the digits of the derived type will + -- already have been set if there was a constraint present. + + Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base)); + Set_Float_Rep (Implicit_Base, Float_Rep (Parent_Base)); + + if No_Constraint then + Set_Digits_Value (Derived_Type, Digits_Value (Parent_Type)); + end if; + + elsif Is_Fixed_Point_Type (Parent_Type) then + + -- Small of base type and derived type are always copied from the + -- parent base type, since smalls never change. The delta of the + -- base type is also copied from the parent base type. However the + -- delta of the derived type will have been set already if a + -- constraint was present. + + Set_Small_Value (Derived_Type, Small_Value (Parent_Base)); + Set_Small_Value (Implicit_Base, Small_Value (Parent_Base)); + Set_Delta_Value (Implicit_Base, Delta_Value (Parent_Base)); + + if No_Constraint then + Set_Delta_Value (Derived_Type, Delta_Value (Parent_Type)); + end if; + + -- The scale and machine radix in the decimal case are always + -- copied from the parent base type. + + if Is_Decimal_Fixed_Point_Type (Parent_Type) then + Set_Scale_Value (Derived_Type, Scale_Value (Parent_Base)); + Set_Scale_Value (Implicit_Base, Scale_Value (Parent_Base)); + + Set_Machine_Radix_10 + (Derived_Type, Machine_Radix_10 (Parent_Base)); + Set_Machine_Radix_10 + (Implicit_Base, Machine_Radix_10 (Parent_Base)); + + Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base)); + + if No_Constraint then + Set_Digits_Value (Derived_Type, Digits_Value (Parent_Base)); + + else + -- the analysis of the subtype_indication sets the + -- digits value of the derived type. + + null; + end if; + end if; + end if; + + -- The type of the bounds is that of the parent type, and they + -- must be converted to the derived type. + + Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc); + + -- The implicit_base should be frozen when the derived type is frozen, + -- but note that it is used in the conversions of the bounds. For fixed + -- types we delay the determination of the bounds until the proper + -- freezing point. For other numeric types this is rejected by GCC, for + -- reasons that are currently unclear (???), so we choose to freeze the + -- implicit base now. In the case of integers and floating point types + -- this is harmless because subsequent representation clauses cannot + -- affect anything, but it is still baffling that we cannot use the + -- same mechanism for all derived numeric types. + + -- There is a further complication: actually *some* representation + -- clauses can affect the implicit base type. Namely, attribute + -- definition clauses for stream-oriented attributes need to set the + -- corresponding TSS entries on the base type, and this normally cannot + -- be done after the base type is frozen, so the circuitry in + -- Sem_Ch13.New_Stream_Subprogram must account for this possibility and + -- not use Set_TSS in this case. + + if Is_Fixed_Point_Type (Parent_Type) then + Conditional_Delay (Implicit_Base, Parent_Type); + else + Freeze_Before (N, Implicit_Base); + end if; + end Build_Derived_Numeric_Type; + + -------------------------------- + -- Build_Derived_Private_Type -- + -------------------------------- + + procedure Build_Derived_Private_Type + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id; + Is_Completion : Boolean; + Derive_Subps : Boolean := True) + is + Loc : constant Source_Ptr := Sloc (N); + Der_Base : Entity_Id; + Discr : Entity_Id; + Full_Decl : Node_Id := Empty; + Full_Der : Entity_Id; + Full_P : Entity_Id; + Last_Discr : Entity_Id; + Par_Scope : constant Entity_Id := Scope (Base_Type (Parent_Type)); + Swapped : Boolean := False; + + procedure Copy_And_Build; + -- Copy derived type declaration, replace parent with its full view, + -- and analyze new declaration. + + -------------------- + -- Copy_And_Build -- + -------------------- + + procedure Copy_And_Build is + Full_N : Node_Id; + + begin + if Ekind (Parent_Type) in Record_Kind + or else + (Ekind (Parent_Type) in Enumeration_Kind + and then not Is_Standard_Character_Type (Parent_Type) + and then not Is_Generic_Type (Root_Type (Parent_Type))) + then + Full_N := New_Copy_Tree (N); + Insert_After (N, Full_N); + Build_Derived_Type ( + Full_N, Parent_Type, Full_Der, True, Derive_Subps => False); + + else + Build_Derived_Type ( + N, Parent_Type, Full_Der, True, Derive_Subps => False); + end if; + end Copy_And_Build; + + -- Start of processing for Build_Derived_Private_Type + + begin + if Is_Tagged_Type (Parent_Type) then + Full_P := Full_View (Parent_Type); + + -- A type extension of a type with unknown discriminants is an + -- indefinite type that the back-end cannot handle directly. + -- We treat it as a private type, and build a completion that is + -- derived from the full view of the parent, and hopefully has + -- known discriminants. + + -- If the full view of the parent type has an underlying record view, + -- use it to generate the underlying record view of this derived type + -- (required for chains of derivations with unknown discriminants). + + -- Minor optimization: we avoid the generation of useless underlying + -- record view entities if the private type declaration has unknown + -- discriminants but its corresponding full view has no + -- discriminants. + + if Has_Unknown_Discriminants (Parent_Type) + and then Present (Full_P) + and then (Has_Discriminants (Full_P) + or else Present (Underlying_Record_View (Full_P))) + and then not In_Open_Scopes (Par_Scope) + and then Expander_Active + then + declare + Full_Der : constant Entity_Id := Make_Temporary (Loc, 'T'); + New_Ext : constant Node_Id := + Copy_Separate_Tree + (Record_Extension_Part (Type_Definition (N))); + Decl : Node_Id; + + begin + Build_Derived_Record_Type + (N, Parent_Type, Derived_Type, Derive_Subps); + + -- Build anonymous completion, as a derivation from the full + -- view of the parent. This is not a completion in the usual + -- sense, because the current type is not private. + + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Full_Der, + Type_Definition => + Make_Derived_Type_Definition (Loc, + Subtype_Indication => + New_Copy_Tree + (Subtype_Indication (Type_Definition (N))), + Record_Extension_Part => New_Ext)); + + -- If the parent type has an underlying record view, use it + -- here to build the new underlying record view. + + if Present (Underlying_Record_View (Full_P)) then + pragma Assert + (Nkind (Subtype_Indication (Type_Definition (Decl))) + = N_Identifier); + Set_Entity (Subtype_Indication (Type_Definition (Decl)), + Underlying_Record_View (Full_P)); + end if; + + Install_Private_Declarations (Par_Scope); + Install_Visible_Declarations (Par_Scope); + Insert_Before (N, Decl); + + -- Mark entity as an underlying record view before analysis, + -- to avoid generating the list of its primitive operations + -- (which is not really required for this entity) and thus + -- prevent spurious errors associated with missing overriding + -- of abstract primitives (overridden only for Derived_Type). + + Set_Ekind (Full_Der, E_Record_Type); + Set_Is_Underlying_Record_View (Full_Der); + + Analyze (Decl); + + pragma Assert (Has_Discriminants (Full_Der) + and then not Has_Unknown_Discriminants (Full_Der)); + + Uninstall_Declarations (Par_Scope); + + -- Freeze the underlying record view, to prevent generation of + -- useless dispatching information, which is simply shared with + -- the real derived type. + + Set_Is_Frozen (Full_Der); + + -- Set up links between real entity and underlying record view + + Set_Underlying_Record_View (Derived_Type, Base_Type (Full_Der)); + Set_Underlying_Record_View (Base_Type (Full_Der), Derived_Type); + end; + + -- If discriminants are known, build derived record + + else + Build_Derived_Record_Type + (N, Parent_Type, Derived_Type, Derive_Subps); + end if; + + return; + + elsif Has_Discriminants (Parent_Type) then + if Present (Full_View (Parent_Type)) then + if not Is_Completion then + + -- Copy declaration for subsequent analysis, to provide a + -- completion for what is a private declaration. Indicate that + -- the full type is internally generated. + + Full_Decl := New_Copy_Tree (N); + Full_Der := New_Copy (Derived_Type); + Set_Comes_From_Source (Full_Decl, False); + Set_Comes_From_Source (Full_Der, False); + Set_Parent (Full_Der, Full_Decl); + + Insert_After (N, Full_Decl); + + else + -- If this is a completion, the full view being built is itself + -- private. We build a subtype of the parent with the same + -- constraints as this full view, to convey to the back end the + -- constrained components and the size of this subtype. If the + -- parent is constrained, its full view can serve as the + -- underlying full view of the derived type. + + if No (Discriminant_Specifications (N)) then + if Nkind (Subtype_Indication (Type_Definition (N))) = + N_Subtype_Indication + then + Build_Underlying_Full_View (N, Derived_Type, Parent_Type); + + elsif Is_Constrained (Full_View (Parent_Type)) then + Set_Underlying_Full_View + (Derived_Type, Full_View (Parent_Type)); + end if; + + else + -- If there are new discriminants, the parent subtype is + -- constrained by them, but it is not clear how to build + -- the Underlying_Full_View in this case??? + + null; + end if; + end if; + end if; + + -- Build partial view of derived type from partial view of parent + + Build_Derived_Record_Type + (N, Parent_Type, Derived_Type, Derive_Subps); + + if Present (Full_View (Parent_Type)) and then not Is_Completion then + if not In_Open_Scopes (Par_Scope) + or else not In_Same_Source_Unit (N, Parent_Type) + then + -- Swap partial and full views temporarily + + Install_Private_Declarations (Par_Scope); + Install_Visible_Declarations (Par_Scope); + Swapped := True; + end if; + + -- Build full view of derived type from full view of parent which + -- is now installed. Subprograms have been derived on the partial + -- view, the completion does not derive them anew. + + if not Is_Tagged_Type (Parent_Type) then + + -- If the parent is itself derived from another private type, + -- installing the private declarations has not affected its + -- privacy status, so use its own full view explicitly. + + if Is_Private_Type (Parent_Type) then + Build_Derived_Record_Type + (Full_Decl, Full_View (Parent_Type), Full_Der, False); + else + Build_Derived_Record_Type + (Full_Decl, Parent_Type, Full_Der, False); + end if; + + else + -- If full view of parent is tagged, the completion inherits + -- the proper primitive operations. + + Set_Defining_Identifier (Full_Decl, Full_Der); + Build_Derived_Record_Type + (Full_Decl, Parent_Type, Full_Der, Derive_Subps); + end if; + + -- The full declaration has been introduced into the tree and + -- processed in the step above. It should not be analyzed again + -- (when encountered later in the current list of declarations) + -- to prevent spurious name conflicts. The full entity remains + -- invisible. + + Set_Analyzed (Full_Decl); + + if Swapped then + Uninstall_Declarations (Par_Scope); + + if In_Open_Scopes (Par_Scope) then + Install_Visible_Declarations (Par_Scope); + end if; + end if; + + Der_Base := Base_Type (Derived_Type); + Set_Full_View (Derived_Type, Full_Der); + Set_Full_View (Der_Base, Base_Type (Full_Der)); + + -- Copy the discriminant list from full view to the partial views + -- (base type and its subtype). Gigi requires that the partial and + -- full views have the same discriminants. + + -- Note that since the partial view is pointing to discriminants + -- in the full view, their scope will be that of the full view. + -- This might cause some front end problems and need adjustment??? + + Discr := First_Discriminant (Base_Type (Full_Der)); + Set_First_Entity (Der_Base, Discr); + + loop + Last_Discr := Discr; + Next_Discriminant (Discr); + exit when No (Discr); + end loop; + + Set_Last_Entity (Der_Base, Last_Discr); + + Set_First_Entity (Derived_Type, First_Entity (Der_Base)); + Set_Last_Entity (Derived_Type, Last_Entity (Der_Base)); + Set_Stored_Constraint (Full_Der, Stored_Constraint (Derived_Type)); + + else + -- If this is a completion, the derived type stays private and + -- there is no need to create a further full view, except in the + -- unusual case when the derivation is nested within a child unit, + -- see below. + + null; + end if; + + elsif Present (Full_View (Parent_Type)) + and then Has_Discriminants (Full_View (Parent_Type)) + then + if Has_Unknown_Discriminants (Parent_Type) + and then Nkind (Subtype_Indication (Type_Definition (N))) = + N_Subtype_Indication + then + Error_Msg_N + ("cannot constrain type with unknown discriminants", + Subtype_Indication (Type_Definition (N))); + return; + end if; + + -- If full view of parent is a record type, build full view as a + -- derivation from the parent's full view. Partial view remains + -- private. For code generation and linking, the full view must have + -- the same public status as the partial one. This full view is only + -- needed if the parent type is in an enclosing scope, so that the + -- full view may actually become visible, e.g. in a child unit. This + -- is both more efficient, and avoids order of freezing problems with + -- the added entities. + + if not Is_Private_Type (Full_View (Parent_Type)) + and then (In_Open_Scopes (Scope (Parent_Type))) + then + Full_Der := + Make_Defining_Identifier + (Sloc (Derived_Type), Chars (Derived_Type)); + Set_Is_Itype (Full_Der); + Set_Has_Private_Declaration (Full_Der); + Set_Has_Private_Declaration (Derived_Type); + Set_Associated_Node_For_Itype (Full_Der, N); + Set_Parent (Full_Der, Parent (Derived_Type)); + Set_Full_View (Derived_Type, Full_Der); + Set_Is_Public (Full_Der, Is_Public (Derived_Type)); + Full_P := Full_View (Parent_Type); + Exchange_Declarations (Parent_Type); + Copy_And_Build; + Exchange_Declarations (Full_P); + + else + Build_Derived_Record_Type + (N, Full_View (Parent_Type), Derived_Type, + Derive_Subps => False); + end if; + + -- In any case, the primitive operations are inherited from the + -- parent type, not from the internal full view. + + Set_Etype (Base_Type (Derived_Type), Base_Type (Parent_Type)); + + if Derive_Subps then + Derive_Subprograms (Parent_Type, Derived_Type); + end if; + + else + -- Untagged type, No discriminants on either view + + if Nkind (Subtype_Indication (Type_Definition (N))) = + N_Subtype_Indication + then + Error_Msg_N + ("illegal constraint on type without discriminants", N); + end if; + + if Present (Discriminant_Specifications (N)) + and then Present (Full_View (Parent_Type)) + and then not Is_Tagged_Type (Full_View (Parent_Type)) + then + Error_Msg_N ("cannot add discriminants to untagged type", N); + end if; + + Set_Stored_Constraint (Derived_Type, No_Elist); + Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); + Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type)); + Set_Has_Controlled_Component + (Derived_Type, Has_Controlled_Component + (Parent_Type)); + + -- Direct controlled types do not inherit Finalize_Storage_Only flag + + if not Is_Controlled (Parent_Type) then + Set_Finalize_Storage_Only + (Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type)); + end if; + + -- Construct the implicit full view by deriving from full view of the + -- parent type. In order to get proper visibility, we install the + -- parent scope and its declarations. + + -- ??? If the parent is untagged private and its completion is + -- tagged, this mechanism will not work because we cannot derive from + -- the tagged full view unless we have an extension. + + if Present (Full_View (Parent_Type)) + and then not Is_Tagged_Type (Full_View (Parent_Type)) + and then not Is_Completion + then + Full_Der := + Make_Defining_Identifier + (Sloc (Derived_Type), Chars (Derived_Type)); + Set_Is_Itype (Full_Der); + Set_Has_Private_Declaration (Full_Der); + Set_Has_Private_Declaration (Derived_Type); + Set_Associated_Node_For_Itype (Full_Der, N); + Set_Parent (Full_Der, Parent (Derived_Type)); + Set_Full_View (Derived_Type, Full_Der); + + if not In_Open_Scopes (Par_Scope) then + Install_Private_Declarations (Par_Scope); + Install_Visible_Declarations (Par_Scope); + Copy_And_Build; + Uninstall_Declarations (Par_Scope); + + -- If parent scope is open and in another unit, and parent has a + -- completion, then the derivation is taking place in the visible + -- part of a child unit. In that case retrieve the full view of + -- the parent momentarily. + + elsif not In_Same_Source_Unit (N, Parent_Type) then + Full_P := Full_View (Parent_Type); + Exchange_Declarations (Parent_Type); + Copy_And_Build; + Exchange_Declarations (Full_P); + + -- Otherwise it is a local derivation + + else + Copy_And_Build; + end if; + + Set_Scope (Full_Der, Current_Scope); + Set_Is_First_Subtype (Full_Der, + Is_First_Subtype (Derived_Type)); + Set_Has_Size_Clause (Full_Der, False); + Set_Has_Alignment_Clause (Full_Der, False); + Set_Next_Entity (Full_Der, Empty); + Set_Has_Delayed_Freeze (Full_Der); + Set_Is_Frozen (Full_Der, False); + Set_Freeze_Node (Full_Der, Empty); + Set_Depends_On_Private (Full_Der, + Has_Private_Component (Full_Der)); + Set_Public_Status (Full_Der); + end if; + end if; + + Set_Has_Unknown_Discriminants (Derived_Type, + Has_Unknown_Discriminants (Parent_Type)); + + if Is_Private_Type (Derived_Type) then + Set_Private_Dependents (Derived_Type, New_Elmt_List); + end if; + + if Is_Private_Type (Parent_Type) + and then Base_Type (Parent_Type) = Parent_Type + and then In_Open_Scopes (Scope (Parent_Type)) + then + Append_Elmt (Derived_Type, Private_Dependents (Parent_Type)); + + if Is_Child_Unit (Scope (Current_Scope)) + and then Is_Completion + and then In_Private_Part (Current_Scope) + and then Scope (Parent_Type) /= Current_Scope + then + -- This is the unusual case where a type completed by a private + -- derivation occurs within a package nested in a child unit, and + -- the parent is declared in an ancestor. In this case, the full + -- view of the parent type will become visible in the body of + -- the enclosing child, and only then will the current type be + -- possibly non-private. We build a underlying full view that + -- will be installed when the enclosing child body is compiled. + + Full_Der := + Make_Defining_Identifier + (Sloc (Derived_Type), Chars (Derived_Type)); + Set_Is_Itype (Full_Der); + Build_Itype_Reference (Full_Der, N); + + -- The full view will be used to swap entities on entry/exit to + -- the body, and must appear in the entity list for the package. + + Append_Entity (Full_Der, Scope (Derived_Type)); + Set_Has_Private_Declaration (Full_Der); + Set_Has_Private_Declaration (Derived_Type); + Set_Associated_Node_For_Itype (Full_Der, N); + Set_Parent (Full_Der, Parent (Derived_Type)); + Full_P := Full_View (Parent_Type); + Exchange_Declarations (Parent_Type); + Copy_And_Build; + Exchange_Declarations (Full_P); + Set_Underlying_Full_View (Derived_Type, Full_Der); + end if; + end if; + end Build_Derived_Private_Type; + + ------------------------------- + -- Build_Derived_Record_Type -- + ------------------------------- + + -- 1. INTRODUCTION + + -- Ideally we would like to use the same model of type derivation for + -- tagged and untagged record types. Unfortunately this is not quite + -- possible because the semantics of representation clauses is different + -- for tagged and untagged records under inheritance. Consider the + -- following: + + -- type R (...) is [tagged] record ... end record; + -- type T (...) is new R (...) [with ...]; + + -- The representation clauses for T can specify a completely different + -- record layout from R's. Hence the same component can be placed in two + -- very different positions in objects of type T and R. If R and T are + -- tagged types, representation clauses for T can only specify the layout + -- of non inherited components, thus components that are common in R and T + -- have the same position in objects of type R and T. + + -- This has two implications. The first is that the entire tree for R's + -- declaration needs to be copied for T in the untagged case, so that T + -- can be viewed as a record type of its own with its own representation + -- clauses. The second implication is the way we handle discriminants. + -- Specifically, in the untagged case we need a way to communicate to Gigi + -- what are the real discriminants in the record, while for the semantics + -- we need to consider those introduced by the user to rename the + -- discriminants in the parent type. This is handled by introducing the + -- notion of stored discriminants. See below for more. + + -- Fortunately the way regular components are inherited can be handled in + -- the same way in tagged and untagged types. + + -- To complicate things a bit more the private view of a private extension + -- cannot be handled in the same way as the full view (for one thing the + -- semantic rules are somewhat different). We will explain what differs + -- below. + + -- 2. DISCRIMINANTS UNDER INHERITANCE + + -- The semantic rules governing the discriminants of derived types are + -- quite subtle. + + -- type Derived_Type_Name [KNOWN_DISCRIMINANT_PART] is new + -- [abstract] Parent_Type_Name [CONSTRAINT] [RECORD_EXTENSION_PART] + + -- If parent type has discriminants, then the discriminants that are + -- declared in the derived type are [3.4 (11)]: + + -- o The discriminants specified by a new KNOWN_DISCRIMINANT_PART, if + -- there is one; + + -- o Otherwise, each discriminant of the parent type (implicitly declared + -- in the same order with the same specifications). In this case, the + -- discriminants are said to be "inherited", or if unknown in the parent + -- are also unknown in the derived type. + + -- Furthermore if a KNOWN_DISCRIMINANT_PART is provided, then [3.7(13-18)]: + + -- o The parent subtype shall be constrained; + + -- o If the parent type is not a tagged type, then each discriminant of + -- the derived type shall be used in the constraint defining a parent + -- subtype. [Implementation note: This ensures that the new discriminant + -- can share storage with an existing discriminant.] + + -- For the derived type each discriminant of the parent type is either + -- inherited, constrained to equal some new discriminant of the derived + -- type, or constrained to the value of an expression. + + -- When inherited or constrained to equal some new discriminant, the + -- parent discriminant and the discriminant of the derived type are said + -- to "correspond". + + -- If a discriminant of the parent type is constrained to a specific value + -- in the derived type definition, then the discriminant is said to be + -- "specified" by that derived type definition. + + -- 3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES + + -- We have spoken about stored discriminants in point 1 (introduction) + -- above. There are two sort of stored discriminants: implicit and + -- explicit. As long as the derived type inherits the same discriminants as + -- the root record type, stored discriminants are the same as regular + -- discriminants, and are said to be implicit. However, if any discriminant + -- in the root type was renamed in the derived type, then the derived + -- type will contain explicit stored discriminants. Explicit stored + -- discriminants are discriminants in addition to the semantically visible + -- discriminants defined for the derived type. Stored discriminants are + -- used by Gigi to figure out what are the physical discriminants in + -- objects of the derived type (see precise definition in einfo.ads). + -- As an example, consider the following: + + -- type R (D1, D2, D3 : Int) is record ... end record; + -- type T1 is new R; + -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1); + -- type T3 is new T2; + -- type T4 (Y : Int) is new T3 (Y, 99); + + -- The following table summarizes the discriminants and stored + -- discriminants in R and T1 through T4. + + -- Type Discrim Stored Discrim Comment + -- R (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in R + -- T1 (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in T1 + -- T2 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T2 + -- T3 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T3 + -- T4 (Y) (D1, D2, D3) Girder discrims EXPLICIT in T4 + + -- Field Corresponding_Discriminant (abbreviated CD below) allows us to + -- find the corresponding discriminant in the parent type, while + -- Original_Record_Component (abbreviated ORC below), the actual physical + -- component that is renamed. Finally the field Is_Completely_Hidden + -- (abbreviated ICH below) is set for all explicit stored discriminants + -- (see einfo.ads for more info). For the above example this gives: + + -- Discrim CD ORC ICH + -- ^^^^^^^ ^^ ^^^ ^^^ + -- D1 in R empty itself no + -- D2 in R empty itself no + -- D3 in R empty itself no + + -- D1 in T1 D1 in R itself no + -- D2 in T1 D2 in R itself no + -- D3 in T1 D3 in R itself no + + -- X1 in T2 D3 in T1 D3 in T2 no + -- X2 in T2 D1 in T1 D1 in T2 no + -- D1 in T2 empty itself yes + -- D2 in T2 empty itself yes + -- D3 in T2 empty itself yes + + -- X1 in T3 X1 in T2 D3 in T3 no + -- X2 in T3 X2 in T2 D1 in T3 no + -- D1 in T3 empty itself yes + -- D2 in T3 empty itself yes + -- D3 in T3 empty itself yes + + -- Y in T4 X1 in T3 D3 in T3 no + -- D1 in T3 empty itself yes + -- D2 in T3 empty itself yes + -- D3 in T3 empty itself yes + + -- 4. DISCRIMINANTS IN DERIVED TAGGED RECORD TYPES + + -- Type derivation for tagged types is fairly straightforward. If no + -- discriminants are specified by the derived type, these are inherited + -- from the parent. No explicit stored discriminants are ever necessary. + -- The only manipulation that is done to the tree is that of adding a + -- _parent field with parent type and constrained to the same constraint + -- specified for the parent in the derived type definition. For instance: + + -- type R (D1, D2, D3 : Int) is tagged record ... end record; + -- type T1 is new R with null record; + -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with null record; + + -- are changed into: + + -- type T1 (D1, D2, D3 : Int) is new R (D1, D2, D3) with record + -- _parent : R (D1, D2, D3); + -- end record; + + -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with record + -- _parent : T1 (X2, 88, X1); + -- end record; + + -- The discriminants actually present in R, T1 and T2 as well as their CD, + -- ORC and ICH fields are: + + -- Discrim CD ORC ICH + -- ^^^^^^^ ^^ ^^^ ^^^ + -- D1 in R empty itself no + -- D2 in R empty itself no + -- D3 in R empty itself no + + -- D1 in T1 D1 in R D1 in R no + -- D2 in T1 D2 in R D2 in R no + -- D3 in T1 D3 in R D3 in R no + + -- X1 in T2 D3 in T1 D3 in R no + -- X2 in T2 D1 in T1 D1 in R no + + -- 5. FIRST TRANSFORMATION FOR DERIVED RECORDS + -- + -- Regardless of whether we dealing with a tagged or untagged type + -- we will transform all derived type declarations of the form + -- + -- type T is new R (...) [with ...]; + -- or + -- subtype S is R (...); + -- type T is new S [with ...]; + -- into + -- type BT is new R [with ...]; + -- subtype T is BT (...); + -- + -- That is, the base derived type is constrained only if it has no + -- discriminants. The reason for doing this is that GNAT's semantic model + -- assumes that a base type with discriminants is unconstrained. + -- + -- Note that, strictly speaking, the above transformation is not always + -- correct. Consider for instance the following excerpt from ACVC b34011a: + -- + -- procedure B34011A is + -- type REC (D : integer := 0) is record + -- I : Integer; + -- end record; + + -- package P is + -- type T6 is new Rec; + -- function F return T6; + -- end P; + + -- use P; + -- package Q6 is + -- type U is new T6 (Q6.F.I); -- ERROR: Q6.F. + -- end Q6; + -- + -- The definition of Q6.U is illegal. However transforming Q6.U into + + -- type BaseU is new T6; + -- subtype U is BaseU (Q6.F.I) + + -- turns U into a legal subtype, which is incorrect. To avoid this problem + -- we always analyze the constraint (in this case (Q6.F.I)) before applying + -- the transformation described above. + + -- There is another instance where the above transformation is incorrect. + -- Consider: + + -- package Pack is + -- type Base (D : Integer) is tagged null record; + -- procedure P (X : Base); + + -- type Der is new Base (2) with null record; + -- procedure P (X : Der); + -- end Pack; + + -- Then the above transformation turns this into + + -- type Der_Base is new Base with null record; + -- -- procedure P (X : Base) is implicitly inherited here + -- -- as procedure P (X : Der_Base). + + -- subtype Der is Der_Base (2); + -- procedure P (X : Der); + -- -- The overriding of P (X : Der_Base) is illegal since we + -- -- have a parameter conformance problem. + + -- To get around this problem, after having semantically processed Der_Base + -- and the rewritten subtype declaration for Der, we copy Der_Base field + -- Discriminant_Constraint from Der so that when parameter conformance is + -- checked when P is overridden, no semantic errors are flagged. + + -- 6. SECOND TRANSFORMATION FOR DERIVED RECORDS + + -- Regardless of whether we are dealing with a tagged or untagged type + -- we will transform all derived type declarations of the form + + -- type R (D1, .., Dn : ...) is [tagged] record ...; + -- type T is new R [with ...]; + -- into + -- type T (D1, .., Dn : ...) is new R (D1, .., Dn) [with ...]; + + -- The reason for such transformation is that it allows us to implement a + -- very clean form of component inheritance as explained below. + + -- Note that this transformation is not achieved by direct tree rewriting + -- and manipulation, but rather by redoing the semantic actions that the + -- above transformation will entail. This is done directly in routine + -- Inherit_Components. + + -- 7. TYPE DERIVATION AND COMPONENT INHERITANCE + + -- In both tagged and untagged derived types, regular non discriminant + -- components are inherited in the derived type from the parent type. In + -- the absence of discriminants component, inheritance is straightforward + -- as components can simply be copied from the parent. + + -- If the parent has discriminants, inheriting components constrained with + -- these discriminants requires caution. Consider the following example: + + -- type R (D1, D2 : Positive) is [tagged] record + -- S : String (D1 .. D2); + -- end record; + + -- type T1 is new R [with null record]; + -- type T2 (X : positive) is new R (1, X) [with null record]; + + -- As explained in 6. above, T1 is rewritten as + -- type T1 (D1, D2 : Positive) is new R (D1, D2) [with null record]; + -- which makes the treatment for T1 and T2 identical. + + -- What we want when inheriting S, is that references to D1 and D2 in R are + -- replaced with references to their correct constraints, i.e. D1 and D2 in + -- T1 and 1 and X in T2. So all R's discriminant references are replaced + -- with either discriminant references in the derived type or expressions. + -- This replacement is achieved as follows: before inheriting R's + -- components, a subtype R (D1, D2) for T1 (resp. R (1, X) for T2) is + -- created in the scope of T1 (resp. scope of T2) so that discriminants D1 + -- and D2 of T1 are visible (resp. discriminant X of T2 is visible). + -- For T2, for instance, this has the effect of replacing String (D1 .. D2) + -- by String (1 .. X). + + -- 8. TYPE DERIVATION IN PRIVATE TYPE EXTENSIONS + + -- We explain here the rules governing private type extensions relevant to + -- type derivation. These rules are explained on the following example: + + -- type D [(...)] is new A [(...)] with private; <-- partial view + -- type D [(...)] is new P [(...)] with null record; <-- full view + + -- Type A is called the ancestor subtype of the private extension. + -- Type P is the parent type of the full view of the private extension. It + -- must be A or a type derived from A. + + -- The rules concerning the discriminants of private type extensions are + -- [7.3(10-13)]: + + -- o If a private extension inherits known discriminants from the ancestor + -- subtype, then the full view shall also inherit its discriminants from + -- the ancestor subtype and the parent subtype of the full view shall be + -- constrained if and only if the ancestor subtype is constrained. + + -- o If a partial view has unknown discriminants, then the full view may + -- define a definite or an indefinite subtype, with or without + -- discriminants. + + -- o If a partial view has neither known nor unknown discriminants, then + -- the full view shall define a definite subtype. + + -- o If the ancestor subtype of a private extension has constrained + -- discriminants, then the parent subtype of the full view shall impose a + -- statically matching constraint on those discriminants. + + -- This means that only the following forms of private extensions are + -- allowed: + + -- type D is new A with private; <-- partial view + -- type D is new P with null record; <-- full view + + -- If A has no discriminants than P has no discriminants, otherwise P must + -- inherit A's discriminants. + + -- type D is new A (...) with private; <-- partial view + -- type D is new P (:::) with null record; <-- full view + + -- P must inherit A's discriminants and (...) and (:::) must statically + -- match. + + -- subtype A is R (...); + -- type D is new A with private; <-- partial view + -- type D is new P with null record; <-- full view + + -- P must have inherited R's discriminants and must be derived from A or + -- any of its subtypes. + + -- type D (..) is new A with private; <-- partial view + -- type D (..) is new P [(:::)] with null record; <-- full view + + -- No specific constraints on P's discriminants or constraint (:::). + -- Note that A can be unconstrained, but the parent subtype P must either + -- be constrained or (:::) must be present. + + -- type D (..) is new A [(...)] with private; <-- partial view + -- type D (..) is new P [(:::)] with null record; <-- full view + + -- P's constraints on A's discriminants must statically match those + -- imposed by (...). + + -- 9. IMPLEMENTATION OF TYPE DERIVATION FOR PRIVATE EXTENSIONS + + -- The full view of a private extension is handled exactly as described + -- above. The model chose for the private view of a private extension is + -- the same for what concerns discriminants (i.e. they receive the same + -- treatment as in the tagged case). However, the private view of the + -- private extension always inherits the components of the parent base, + -- without replacing any discriminant reference. Strictly speaking this is + -- incorrect. However, Gigi never uses this view to generate code so this + -- is a purely semantic issue. In theory, a set of transformations similar + -- to those given in 5. and 6. above could be applied to private views of + -- private extensions to have the same model of component inheritance as + -- for non private extensions. However, this is not done because it would + -- further complicate private type processing. Semantically speaking, this + -- leaves us in an uncomfortable situation. As an example consider: + + -- package Pack is + -- type R (D : integer) is tagged record + -- S : String (1 .. D); + -- end record; + -- procedure P (X : R); + -- type T is new R (1) with private; + -- private + -- type T is new R (1) with null record; + -- end; + + -- This is transformed into: + + -- package Pack is + -- type R (D : integer) is tagged record + -- S : String (1 .. D); + -- end record; + -- procedure P (X : R); + -- type T is new R (1) with private; + -- private + -- type BaseT is new R with null record; + -- subtype T is BaseT (1); + -- end; + + -- (strictly speaking the above is incorrect Ada) + + -- From the semantic standpoint the private view of private extension T + -- should be flagged as constrained since one can clearly have + -- + -- Obj : T; + -- + -- in a unit withing Pack. However, when deriving subprograms for the + -- private view of private extension T, T must be seen as unconstrained + -- since T has discriminants (this is a constraint of the current + -- subprogram derivation model). Thus, when processing the private view of + -- a private extension such as T, we first mark T as unconstrained, we + -- process it, we perform program derivation and just before returning from + -- Build_Derived_Record_Type we mark T as constrained. + + -- ??? Are there are other uncomfortable cases that we will have to + -- deal with. + + -- 10. RECORD_TYPE_WITH_PRIVATE complications + + -- Types that are derived from a visible record type and have a private + -- extension present other peculiarities. They behave mostly like private + -- types, but if they have primitive operations defined, these will not + -- have the proper signatures for further inheritance, because other + -- primitive operations will use the implicit base that we define for + -- private derivations below. This affect subprogram inheritance (see + -- Derive_Subprograms for details). We also derive the implicit base from + -- the base type of the full view, so that the implicit base is a record + -- type and not another private type, This avoids infinite loops. + + procedure Build_Derived_Record_Type + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id; + Derive_Subps : Boolean := True) + is + Loc : constant Source_Ptr := Sloc (N); + Parent_Base : Entity_Id; + Type_Def : Node_Id; + Indic : Node_Id; + Discrim : Entity_Id; + Last_Discrim : Entity_Id; + Constrs : Elist_Id; + + Discs : Elist_Id := New_Elmt_List; + -- An empty Discs list means that there were no constraints in the + -- subtype indication or that there was an error processing it. + + Assoc_List : Elist_Id; + New_Discrs : Elist_Id; + New_Base : Entity_Id; + New_Decl : Node_Id; + New_Indic : Node_Id; + + Is_Tagged : constant Boolean := Is_Tagged_Type (Parent_Type); + Discriminant_Specs : constant Boolean := + Present (Discriminant_Specifications (N)); + Private_Extension : constant Boolean := + Nkind (N) = N_Private_Extension_Declaration; + + Constraint_Present : Boolean; + Inherit_Discrims : Boolean := False; + Save_Etype : Entity_Id; + Save_Discr_Constr : Elist_Id; + Save_Next_Entity : Entity_Id; + + begin + if Ekind (Parent_Type) = E_Record_Type_With_Private + and then Present (Full_View (Parent_Type)) + and then Has_Discriminants (Parent_Type) + then + Parent_Base := Base_Type (Full_View (Parent_Type)); + else + Parent_Base := Base_Type (Parent_Type); + end if; + + -- Before we start the previously documented transformations, here is + -- little fix for size and alignment of tagged types. Normally when we + -- derive type D from type P, we copy the size and alignment of P as the + -- default for D, and in the absence of explicit representation clauses + -- for D, the size and alignment are indeed the same as the parent. + + -- But this is wrong for tagged types, since fields may be added, and + -- the default size may need to be larger, and the default alignment may + -- need to be larger. + + -- We therefore reset the size and alignment fields in the tagged case. + -- Note that the size and alignment will in any case be at least as + -- large as the parent type (since the derived type has a copy of the + -- parent type in the _parent field) + + -- The type is also marked as being tagged here, which is needed when + -- processing components with a self-referential anonymous access type + -- in the call to Check_Anonymous_Access_Components below. Note that + -- this flag is also set later on for completeness. + + if Is_Tagged then + Set_Is_Tagged_Type (Derived_Type); + Init_Size_Align (Derived_Type); + end if; + + -- STEP 0a: figure out what kind of derived type declaration we have + + if Private_Extension then + Type_Def := N; + Set_Ekind (Derived_Type, E_Record_Type_With_Private); + + else + Type_Def := Type_Definition (N); + + -- Ekind (Parent_Base) is not necessarily E_Record_Type since + -- Parent_Base can be a private type or private extension. However, + -- for tagged types with an extension the newly added fields are + -- visible and hence the Derived_Type is always an E_Record_Type. + -- (except that the parent may have its own private fields). + -- For untagged types we preserve the Ekind of the Parent_Base. + + if Present (Record_Extension_Part (Type_Def)) then + Set_Ekind (Derived_Type, E_Record_Type); + + -- Create internal access types for components with anonymous + -- access types. + + if Ada_Version >= Ada_2005 then + Check_Anonymous_Access_Components + (N, Derived_Type, Derived_Type, + Component_List (Record_Extension_Part (Type_Def))); + end if; + + else + Set_Ekind (Derived_Type, Ekind (Parent_Base)); + end if; + end if; + + -- Indic can either be an N_Identifier if the subtype indication + -- contains no constraint or an N_Subtype_Indication if the subtype + -- indication has a constraint. + + Indic := Subtype_Indication (Type_Def); + Constraint_Present := (Nkind (Indic) = N_Subtype_Indication); + + -- Check that the type has visible discriminants. The type may be + -- a private type with unknown discriminants whose full view has + -- discriminants which are invisible. + + if Constraint_Present then + if not Has_Discriminants (Parent_Base) + or else + (Has_Unknown_Discriminants (Parent_Base) + and then Is_Private_Type (Parent_Base)) + then + Error_Msg_N + ("invalid constraint: type has no discriminant", + Constraint (Indic)); + + Constraint_Present := False; + Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic))); + + elsif Is_Constrained (Parent_Type) then + Error_Msg_N + ("invalid constraint: parent type is already constrained", + Constraint (Indic)); + + Constraint_Present := False; + Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic))); + end if; + end if; + + -- STEP 0b: If needed, apply transformation given in point 5. above + + if not Private_Extension + and then Has_Discriminants (Parent_Type) + and then not Discriminant_Specs + and then (Is_Constrained (Parent_Type) or else Constraint_Present) + then + -- First, we must analyze the constraint (see comment in point 5.) + + if Constraint_Present then + New_Discrs := Build_Discriminant_Constraints (Parent_Type, Indic); + + if Has_Discriminants (Derived_Type) + and then Has_Private_Declaration (Derived_Type) + and then Present (Discriminant_Constraint (Derived_Type)) + then + -- Verify that constraints of the full view statically match + -- those given in the partial view. + + declare + C1, C2 : Elmt_Id; + + begin + C1 := First_Elmt (New_Discrs); + C2 := First_Elmt (Discriminant_Constraint (Derived_Type)); + while Present (C1) and then Present (C2) loop + if Fully_Conformant_Expressions (Node (C1), Node (C2)) + or else + (Is_OK_Static_Expression (Node (C1)) + and then + Is_OK_Static_Expression (Node (C2)) + and then + Expr_Value (Node (C1)) = Expr_Value (Node (C2))) + then + null; + + else + Error_Msg_N ( + "constraint not conformant to previous declaration", + Node (C1)); + end if; + + Next_Elmt (C1); + Next_Elmt (C2); + end loop; + end; + end if; + end if; + + -- Insert and analyze the declaration for the unconstrained base type + + New_Base := Create_Itype (Ekind (Derived_Type), N, Derived_Type, 'B'); + + New_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => New_Base, + Type_Definition => + Make_Derived_Type_Definition (Loc, + Abstract_Present => Abstract_Present (Type_Def), + Limited_Present => Limited_Present (Type_Def), + Subtype_Indication => + New_Occurrence_Of (Parent_Base, Loc), + Record_Extension_Part => + Relocate_Node (Record_Extension_Part (Type_Def)), + Interface_List => Interface_List (Type_Def))); + + Set_Parent (New_Decl, Parent (N)); + Mark_Rewrite_Insertion (New_Decl); + Insert_Before (N, New_Decl); + + -- In the extension case, make sure ancestor is frozen appropriately + -- (see also non-discriminated case below). + + if Present (Record_Extension_Part (Type_Def)) + or else Is_Interface (Parent_Base) + then + Freeze_Before (New_Decl, Parent_Type); + end if; + + -- Note that this call passes False for the Derive_Subps parameter + -- because subprogram derivation is deferred until after creating + -- the subtype (see below). + + Build_Derived_Type + (New_Decl, Parent_Base, New_Base, + Is_Completion => True, Derive_Subps => False); + + -- ??? This needs re-examination to determine whether the + -- above call can simply be replaced by a call to Analyze. + + Set_Analyzed (New_Decl); + + -- Insert and analyze the declaration for the constrained subtype + + if Constraint_Present then + New_Indic := + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (New_Base, Loc), + Constraint => Relocate_Node (Constraint (Indic))); + + else + declare + Constr_List : constant List_Id := New_List; + C : Elmt_Id; + Expr : Node_Id; + + begin + C := First_Elmt (Discriminant_Constraint (Parent_Type)); + while Present (C) loop + Expr := Node (C); + + -- It is safe here to call New_Copy_Tree since + -- Force_Evaluation was called on each constraint in + -- Build_Discriminant_Constraints. + + Append (New_Copy_Tree (Expr), To => Constr_List); + + Next_Elmt (C); + end loop; + + New_Indic := + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (New_Base, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, Constr_List)); + end; + end if; + + Rewrite (N, + Make_Subtype_Declaration (Loc, + Defining_Identifier => Derived_Type, + Subtype_Indication => New_Indic)); + + Analyze (N); + + -- Derivation of subprograms must be delayed until the full subtype + -- has been established to ensure proper overriding of subprograms + -- inherited by full types. If the derivations occurred as part of + -- the call to Build_Derived_Type above, then the check for type + -- conformance would fail because earlier primitive subprograms + -- could still refer to the full type prior the change to the new + -- subtype and hence would not match the new base type created here. + + Derive_Subprograms (Parent_Type, Derived_Type); + + -- For tagged types the Discriminant_Constraint of the new base itype + -- is inherited from the first subtype so that no subtype conformance + -- problem arise when the first subtype overrides primitive + -- operations inherited by the implicit base type. + + if Is_Tagged then + Set_Discriminant_Constraint + (New_Base, Discriminant_Constraint (Derived_Type)); + end if; + + return; + end if; + + -- If we get here Derived_Type will have no discriminants or it will be + -- a discriminated unconstrained base type. + + -- STEP 1a: perform preliminary actions/checks for derived tagged types + + if Is_Tagged then + + -- The parent type is frozen for non-private extensions (RM 13.14(7)) + -- The declaration of a specific descendant of an interface type + -- freezes the interface type (RM 13.14). + + if not Private_Extension or else Is_Interface (Parent_Base) then + Freeze_Before (N, Parent_Type); + end if; + + -- In Ada 2005 (AI-344), the restriction that a derived tagged type + -- cannot be declared at a deeper level than its parent type is + -- removed. The check on derivation within a generic body is also + -- relaxed, but there's a restriction that a derived tagged type + -- cannot be declared in a generic body if it's derived directly + -- or indirectly from a formal type of that generic. + + if Ada_Version >= Ada_2005 then + if Present (Enclosing_Generic_Body (Derived_Type)) then + declare + Ancestor_Type : Entity_Id; + + begin + -- Check to see if any ancestor of the derived type is a + -- formal type. + + Ancestor_Type := Parent_Type; + while not Is_Generic_Type (Ancestor_Type) + and then Etype (Ancestor_Type) /= Ancestor_Type + loop + Ancestor_Type := Etype (Ancestor_Type); + end loop; + + -- If the derived type does have a formal type as an + -- ancestor, then it's an error if the derived type is + -- declared within the body of the generic unit that + -- declares the formal type in its generic formal part. It's + -- sufficient to check whether the ancestor type is declared + -- inside the same generic body as the derived type (such as + -- within a nested generic spec), in which case the + -- derivation is legal. If the formal type is declared + -- outside of that generic body, then it's guaranteed that + -- the derived type is declared within the generic body of + -- the generic unit declaring the formal type. + + if Is_Generic_Type (Ancestor_Type) + and then Enclosing_Generic_Body (Ancestor_Type) /= + Enclosing_Generic_Body (Derived_Type) + then + Error_Msg_NE + ("parent type of& must not be descendant of formal type" + & " of an enclosing generic body", + Indic, Derived_Type); + end if; + end; + end if; + + elsif Type_Access_Level (Derived_Type) /= + Type_Access_Level (Parent_Type) + and then not Is_Generic_Type (Derived_Type) + then + if Is_Controlled (Parent_Type) then + Error_Msg_N + ("controlled type must be declared at the library level", + Indic); + else + Error_Msg_N + ("type extension at deeper accessibility level than parent", + Indic); + end if; + + else + declare + GB : constant Node_Id := Enclosing_Generic_Body (Derived_Type); + + begin + if Present (GB) + and then GB /= Enclosing_Generic_Body (Parent_Base) + then + Error_Msg_NE + ("parent type of& must not be outside generic body" + & " (RM 3.9.1(4))", + Indic, Derived_Type); + end if; + end; + end if; + end if; + + -- Ada 2005 (AI-251) + + if Ada_Version >= Ada_2005 and then Is_Tagged then + + -- "The declaration of a specific descendant of an interface type + -- freezes the interface type" (RM 13.14). + + declare + Iface : Node_Id; + begin + if Is_Non_Empty_List (Interface_List (Type_Def)) then + Iface := First (Interface_List (Type_Def)); + while Present (Iface) loop + Freeze_Before (N, Etype (Iface)); + Next (Iface); + end loop; + end if; + end; + end if; + + -- STEP 1b : preliminary cleanup of the full view of private types + + -- If the type is already marked as having discriminants, then it's the + -- completion of a private type or private extension and we need to + -- retain the discriminants from the partial view if the current + -- declaration has Discriminant_Specifications so that we can verify + -- conformance. However, we must remove any existing components that + -- were inherited from the parent (and attached in Copy_And_Swap) + -- because the full type inherits all appropriate components anyway, and + -- we do not want the partial view's components interfering. + + if Has_Discriminants (Derived_Type) and then Discriminant_Specs then + Discrim := First_Discriminant (Derived_Type); + loop + Last_Discrim := Discrim; + Next_Discriminant (Discrim); + exit when No (Discrim); + end loop; + + Set_Last_Entity (Derived_Type, Last_Discrim); + + -- In all other cases wipe out the list of inherited components (even + -- inherited discriminants), it will be properly rebuilt here. + + else + Set_First_Entity (Derived_Type, Empty); + Set_Last_Entity (Derived_Type, Empty); + end if; + + -- STEP 1c: Initialize some flags for the Derived_Type + + -- The following flags must be initialized here so that + -- Process_Discriminants can check that discriminants of tagged types do + -- not have a default initial value and that access discriminants are + -- only specified for limited records. For completeness, these flags are + -- also initialized along with all the other flags below. + + -- AI-419: Limitedness is not inherited from an interface parent, so to + -- be limited in that case the type must be explicitly declared as + -- limited. However, task and protected interfaces are always limited. + + if Limited_Present (Type_Def) then + Set_Is_Limited_Record (Derived_Type); + + elsif Is_Limited_Record (Parent_Type) + or else (Present (Full_View (Parent_Type)) + and then Is_Limited_Record (Full_View (Parent_Type))) + then + if not Is_Interface (Parent_Type) + or else Is_Synchronized_Interface (Parent_Type) + or else Is_Protected_Interface (Parent_Type) + or else Is_Task_Interface (Parent_Type) + then + Set_Is_Limited_Record (Derived_Type); + end if; + end if; + + -- STEP 2a: process discriminants of derived type if any + + Push_Scope (Derived_Type); + + if Discriminant_Specs then + Set_Has_Unknown_Discriminants (Derived_Type, False); + + -- The following call initializes fields Has_Discriminants and + -- Discriminant_Constraint, unless we are processing the completion + -- of a private type declaration. + + Check_Or_Process_Discriminants (N, Derived_Type); + + -- For untagged types, the constraint on the Parent_Type must be + -- present and is used to rename the discriminants. + + if not Is_Tagged and then not Has_Discriminants (Parent_Type) then + Error_Msg_N ("untagged parent must have discriminants", Indic); + + elsif not Is_Tagged and then not Constraint_Present then + Error_Msg_N + ("discriminant constraint needed for derived untagged records", + Indic); + + -- Otherwise the parent subtype must be constrained unless we have a + -- private extension. + + elsif not Constraint_Present + and then not Private_Extension + and then not Is_Constrained (Parent_Type) + then + Error_Msg_N + ("unconstrained type not allowed in this context", Indic); + + elsif Constraint_Present then + -- The following call sets the field Corresponding_Discriminant + -- for the discriminants in the Derived_Type. + + Discs := Build_Discriminant_Constraints (Parent_Type, Indic, True); + + -- For untagged types all new discriminants must rename + -- discriminants in the parent. For private extensions new + -- discriminants cannot rename old ones (implied by [7.3(13)]). + + Discrim := First_Discriminant (Derived_Type); + while Present (Discrim) loop + if not Is_Tagged + and then No (Corresponding_Discriminant (Discrim)) + then + Error_Msg_N + ("new discriminants must constrain old ones", Discrim); + + elsif Private_Extension + and then Present (Corresponding_Discriminant (Discrim)) + then + Error_Msg_N + ("only static constraints allowed for parent" + & " discriminants in the partial view", Indic); + exit; + end if; + + -- If a new discriminant is used in the constraint, then its + -- subtype must be statically compatible with the parent + -- discriminant's subtype (3.7(15)). + + if Present (Corresponding_Discriminant (Discrim)) + and then + not Subtypes_Statically_Compatible + (Etype (Discrim), + Etype (Corresponding_Discriminant (Discrim))) + then + Error_Msg_N + ("subtype must be compatible with parent discriminant", + Discrim); + end if; + + Next_Discriminant (Discrim); + end loop; + + -- Check whether the constraints of the full view statically + -- match those imposed by the parent subtype [7.3(13)]. + + if Present (Stored_Constraint (Derived_Type)) then + declare + C1, C2 : Elmt_Id; + + begin + C1 := First_Elmt (Discs); + C2 := First_Elmt (Stored_Constraint (Derived_Type)); + while Present (C1) and then Present (C2) loop + if not + Fully_Conformant_Expressions (Node (C1), Node (C2)) + then + Error_Msg_N + ("not conformant with previous declaration", + Node (C1)); + end if; + + Next_Elmt (C1); + Next_Elmt (C2); + end loop; + end; + end if; + end if; + + -- STEP 2b: No new discriminants, inherit discriminants if any + + else + if Private_Extension then + Set_Has_Unknown_Discriminants + (Derived_Type, + Has_Unknown_Discriminants (Parent_Type) + or else Unknown_Discriminants_Present (N)); + + -- The partial view of the parent may have unknown discriminants, + -- but if the full view has discriminants and the parent type is + -- in scope they must be inherited. + + elsif Has_Unknown_Discriminants (Parent_Type) + and then + (not Has_Discriminants (Parent_Type) + or else not In_Open_Scopes (Scope (Parent_Type))) + then + Set_Has_Unknown_Discriminants (Derived_Type); + end if; + + if not Has_Unknown_Discriminants (Derived_Type) + and then not Has_Unknown_Discriminants (Parent_Base) + and then Has_Discriminants (Parent_Type) + then + Inherit_Discrims := True; + Set_Has_Discriminants + (Derived_Type, True); + Set_Discriminant_Constraint + (Derived_Type, Discriminant_Constraint (Parent_Base)); + end if; + + -- The following test is true for private types (remember + -- transformation 5. is not applied to those) and in an error + -- situation. + + if Constraint_Present then + Discs := Build_Discriminant_Constraints (Parent_Type, Indic); + end if; + + -- For now mark a new derived type as constrained only if it has no + -- discriminants. At the end of Build_Derived_Record_Type we properly + -- set this flag in the case of private extensions. See comments in + -- point 9. just before body of Build_Derived_Record_Type. + + Set_Is_Constrained + (Derived_Type, + not (Inherit_Discrims + or else Has_Unknown_Discriminants (Derived_Type))); + end if; + + -- STEP 3: initialize fields of derived type + + Set_Is_Tagged_Type (Derived_Type, Is_Tagged); + Set_Stored_Constraint (Derived_Type, No_Elist); + + -- Ada 2005 (AI-251): Private type-declarations can implement interfaces + -- but cannot be interfaces + + if not Private_Extension + and then Ekind (Derived_Type) /= E_Private_Type + and then Ekind (Derived_Type) /= E_Limited_Private_Type + then + if Interface_Present (Type_Def) then + Analyze_Interface_Declaration (Derived_Type, Type_Def); + end if; + + Set_Interfaces (Derived_Type, No_Elist); + end if; + + -- Fields inherited from the Parent_Type + + Set_Discard_Names + (Derived_Type, Einfo.Discard_Names (Parent_Type)); + Set_Has_Specified_Layout + (Derived_Type, Has_Specified_Layout (Parent_Type)); + Set_Is_Limited_Composite + (Derived_Type, Is_Limited_Composite (Parent_Type)); + Set_Is_Private_Composite + (Derived_Type, Is_Private_Composite (Parent_Type)); + + -- Fields inherited from the Parent_Base + + Set_Has_Controlled_Component + (Derived_Type, Has_Controlled_Component (Parent_Base)); + Set_Has_Non_Standard_Rep + (Derived_Type, Has_Non_Standard_Rep (Parent_Base)); + Set_Has_Primitive_Operations + (Derived_Type, Has_Primitive_Operations (Parent_Base)); + + -- Fields inherited from the Parent_Base in the non-private case + + if Ekind (Derived_Type) = E_Record_Type then + Set_Has_Complex_Representation + (Derived_Type, Has_Complex_Representation (Parent_Base)); + end if; + + -- Fields inherited from the Parent_Base for record types + + if Is_Record_Type (Derived_Type) then + + -- Ekind (Parent_Base) is not necessarily E_Record_Type since + -- Parent_Base can be a private type or private extension. + + if Present (Full_View (Parent_Base)) then + Set_OK_To_Reorder_Components + (Derived_Type, + OK_To_Reorder_Components (Full_View (Parent_Base))); + Set_Reverse_Bit_Order + (Derived_Type, Reverse_Bit_Order (Full_View (Parent_Base))); + else + Set_OK_To_Reorder_Components + (Derived_Type, OK_To_Reorder_Components (Parent_Base)); + Set_Reverse_Bit_Order + (Derived_Type, Reverse_Bit_Order (Parent_Base)); + end if; + end if; + + -- Direct controlled types do not inherit Finalize_Storage_Only flag + + if not Is_Controlled (Parent_Type) then + Set_Finalize_Storage_Only + (Derived_Type, Finalize_Storage_Only (Parent_Type)); + end if; + + -- Set fields for private derived types + + if Is_Private_Type (Derived_Type) then + Set_Depends_On_Private (Derived_Type, True); + Set_Private_Dependents (Derived_Type, New_Elmt_List); + + -- Inherit fields from non private record types. If this is the + -- completion of a derivation from a private type, the parent itself + -- is private, and the attributes come from its full view, which must + -- be present. + + else + if Is_Private_Type (Parent_Base) + and then not Is_Record_Type (Parent_Base) + then + Set_Component_Alignment + (Derived_Type, Component_Alignment (Full_View (Parent_Base))); + Set_C_Pass_By_Copy + (Derived_Type, C_Pass_By_Copy (Full_View (Parent_Base))); + else + Set_Component_Alignment + (Derived_Type, Component_Alignment (Parent_Base)); + Set_C_Pass_By_Copy + (Derived_Type, C_Pass_By_Copy (Parent_Base)); + end if; + end if; + + -- Set fields for tagged types + + if Is_Tagged then + Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List); + + -- All tagged types defined in Ada.Finalization are controlled + + if Chars (Scope (Derived_Type)) = Name_Finalization + and then Chars (Scope (Scope (Derived_Type))) = Name_Ada + and then Scope (Scope (Scope (Derived_Type))) = Standard_Standard + then + Set_Is_Controlled (Derived_Type); + else + Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Base)); + end if; + + -- Minor optimization: there is no need to generate the class-wide + -- entity associated with an underlying record view. + + if not Is_Underlying_Record_View (Derived_Type) then + Make_Class_Wide_Type (Derived_Type); + end if; + + Set_Is_Abstract_Type (Derived_Type, Abstract_Present (Type_Def)); + + if Has_Discriminants (Derived_Type) + and then Constraint_Present + then + Set_Stored_Constraint + (Derived_Type, Expand_To_Stored_Constraint (Parent_Base, Discs)); + end if; + + if Ada_Version >= Ada_2005 then + declare + Ifaces_List : Elist_Id; + + begin + -- Checks rules 3.9.4 (13/2 and 14/2) + + if Comes_From_Source (Derived_Type) + and then not Is_Private_Type (Derived_Type) + and then Is_Interface (Parent_Type) + and then not Is_Interface (Derived_Type) + then + if Is_Task_Interface (Parent_Type) then + Error_Msg_N + ("(Ada 2005) task type required (RM 3.9.4 (13.2))", + Derived_Type); + + elsif Is_Protected_Interface (Parent_Type) then + Error_Msg_N + ("(Ada 2005) protected type required (RM 3.9.4 (14.2))", + Derived_Type); + end if; + end if; + + -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) + + Check_Interfaces (N, Type_Def); + + -- Ada 2005 (AI-251): Collect the list of progenitors that are + -- not already in the parents. + + Collect_Interfaces + (T => Derived_Type, + Ifaces_List => Ifaces_List, + Exclude_Parents => True); + + Set_Interfaces (Derived_Type, Ifaces_List); + + -- If the derived type is the anonymous type created for + -- a declaration whose parent has a constraint, propagate + -- the interface list to the source type. This must be done + -- prior to the completion of the analysis of the source type + -- because the components in the extension may contain current + -- instances whose legality depends on some ancestor. + + if Is_Itype (Derived_Type) then + declare + Def : constant Node_Id := + Associated_Node_For_Itype (Derived_Type); + begin + if Present (Def) + and then Nkind (Def) = N_Full_Type_Declaration + then + Set_Interfaces + (Defining_Identifier (Def), Ifaces_List); + end if; + end; + end if; + end; + end if; + + else + Set_Is_Packed (Derived_Type, Is_Packed (Parent_Base)); + Set_Has_Non_Standard_Rep + (Derived_Type, Has_Non_Standard_Rep (Parent_Base)); + end if; + + -- STEP 4: Inherit components from the parent base and constrain them. + -- Apply the second transformation described in point 6. above. + + if (not Is_Empty_Elmt_List (Discs) or else Inherit_Discrims) + or else not Has_Discriminants (Parent_Type) + or else not Is_Constrained (Parent_Type) + then + Constrs := Discs; + else + Constrs := Discriminant_Constraint (Parent_Type); + end if; + + Assoc_List := + Inherit_Components + (N, Parent_Base, Derived_Type, Is_Tagged, Inherit_Discrims, Constrs); + + -- STEP 5a: Copy the parent record declaration for untagged types + + if not Is_Tagged then + + -- Discriminant_Constraint (Derived_Type) has been properly + -- constructed. Save it and temporarily set it to Empty because we + -- do not want the call to New_Copy_Tree below to mess this list. + + if Has_Discriminants (Derived_Type) then + Save_Discr_Constr := Discriminant_Constraint (Derived_Type); + Set_Discriminant_Constraint (Derived_Type, No_Elist); + else + Save_Discr_Constr := No_Elist; + end if; + + -- Save the Etype field of Derived_Type. It is correctly set now, + -- but the call to New_Copy tree may remap it to point to itself, + -- which is not what we want. Ditto for the Next_Entity field. + + Save_Etype := Etype (Derived_Type); + Save_Next_Entity := Next_Entity (Derived_Type); + + -- Assoc_List maps all stored discriminants in the Parent_Base to + -- stored discriminants in the Derived_Type. It is fundamental that + -- no types or itypes with discriminants other than the stored + -- discriminants appear in the entities declared inside + -- Derived_Type, since the back end cannot deal with it. + + New_Decl := + New_Copy_Tree + (Parent (Parent_Base), Map => Assoc_List, New_Sloc => Loc); + + -- Restore the fields saved prior to the New_Copy_Tree call + -- and compute the stored constraint. + + Set_Etype (Derived_Type, Save_Etype); + Set_Next_Entity (Derived_Type, Save_Next_Entity); + + if Has_Discriminants (Derived_Type) then + Set_Discriminant_Constraint + (Derived_Type, Save_Discr_Constr); + Set_Stored_Constraint + (Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs)); + Replace_Components (Derived_Type, New_Decl); + end if; + + -- Insert the new derived type declaration + + Rewrite (N, New_Decl); + + -- STEP 5b: Complete the processing for record extensions in generics + + -- There is no completion for record extensions declared in the + -- parameter part of a generic, so we need to complete processing for + -- these generic record extensions here. The Record_Type_Definition call + -- will change the Ekind of the components from E_Void to E_Component. + + elsif Private_Extension and then Is_Generic_Type (Derived_Type) then + Record_Type_Definition (Empty, Derived_Type); + + -- STEP 5c: Process the record extension for non private tagged types + + elsif not Private_Extension then + + -- Add the _parent field in the derived type + + Expand_Record_Extension (Derived_Type, Type_Def); + + -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the + -- implemented interfaces if we are in expansion mode + + if Expander_Active + and then Has_Interfaces (Derived_Type) + then + Add_Interface_Tag_Components (N, Derived_Type); + end if; + + -- Analyze the record extension + + Record_Type_Definition + (Record_Extension_Part (Type_Def), Derived_Type); + end if; + + End_Scope; + + -- Nothing else to do if there is an error in the derivation. + -- An unusual case: the full view may be derived from a type in an + -- instance, when the partial view was used illegally as an actual + -- in that instance, leading to a circular definition. + + if Etype (Derived_Type) = Any_Type + or else Etype (Parent_Type) = Derived_Type + then + return; + end if; + + -- Set delayed freeze and then derive subprograms, we need to do + -- this in this order so that derived subprograms inherit the + -- derived freeze if necessary. + + Set_Has_Delayed_Freeze (Derived_Type); + + if Derive_Subps then + Derive_Subprograms (Parent_Type, Derived_Type); + end if; + + -- If we have a private extension which defines a constrained derived + -- type mark as constrained here after we have derived subprograms. See + -- comment on point 9. just above the body of Build_Derived_Record_Type. + + if Private_Extension and then Inherit_Discrims then + if Constraint_Present and then not Is_Empty_Elmt_List (Discs) then + Set_Is_Constrained (Derived_Type, True); + Set_Discriminant_Constraint (Derived_Type, Discs); + + elsif Is_Constrained (Parent_Type) then + Set_Is_Constrained + (Derived_Type, True); + Set_Discriminant_Constraint + (Derived_Type, Discriminant_Constraint (Parent_Type)); + end if; + end if; + + -- Update the class-wide type, which shares the now-completed entity + -- list with its specific type. In case of underlying record views, + -- we do not generate the corresponding class wide entity. + + if Is_Tagged + and then not Is_Underlying_Record_View (Derived_Type) + then + Set_First_Entity + (Class_Wide_Type (Derived_Type), First_Entity (Derived_Type)); + Set_Last_Entity + (Class_Wide_Type (Derived_Type), Last_Entity (Derived_Type)); + end if; + + -- Update the scope of anonymous access types of discriminants and other + -- components, to prevent scope anomalies in gigi, when the derivation + -- appears in a scope nested within that of the parent. + + declare + D : Entity_Id; + + begin + D := First_Entity (Derived_Type); + while Present (D) loop + if Ekind_In (D, E_Discriminant, E_Component) then + if Is_Itype (Etype (D)) + and then Ekind (Etype (D)) = E_Anonymous_Access_Type + then + Set_Scope (Etype (D), Current_Scope); + end if; + end if; + + Next_Entity (D); + end loop; + end; + end Build_Derived_Record_Type; + + ------------------------ + -- Build_Derived_Type -- + ------------------------ + + procedure Build_Derived_Type + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id; + Is_Completion : Boolean; + Derive_Subps : Boolean := True) + is + Parent_Base : constant Entity_Id := Base_Type (Parent_Type); + + begin + -- Set common attributes + + Set_Scope (Derived_Type, Current_Scope); + + Set_Ekind (Derived_Type, Ekind (Parent_Base)); + Set_Etype (Derived_Type, Parent_Base); + Set_Has_Task (Derived_Type, Has_Task (Parent_Base)); + + Set_Size_Info (Derived_Type, Parent_Type); + Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); + Set_Convention (Derived_Type, Convention (Parent_Type)); + Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type)); + Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type)); + + -- Propagate invariant information. The new type has invariants if + -- they are inherited from the parent type, and these invariants can + -- be further inherited, so both flags are set. + + if Has_Inheritable_Invariants (Parent_Type) then + Set_Has_Inheritable_Invariants (Derived_Type); + Set_Has_Invariants (Derived_Type); + end if; + + -- We similarly inherit predicates + + if Has_Predicates (Parent_Type) then + Set_Has_Predicates (Derived_Type); + end if; + + -- The derived type inherits the representation clauses of the parent. + -- However, for a private type that is completed by a derivation, there + -- may be operation attributes that have been specified already (stream + -- attributes and External_Tag) and those must be provided. Finally, + -- if the partial view is a private extension, the representation items + -- of the parent have been inherited already, and should not be chained + -- twice to the derived type. + + if Is_Tagged_Type (Parent_Type) + and then Present (First_Rep_Item (Derived_Type)) + then + -- The existing items are either operational items or items inherited + -- from a private extension declaration. + + declare + Rep : Node_Id; + -- Used to iterate over representation items of the derived type + + Last_Rep : Node_Id; + -- Last representation item of the (non-empty) representation + -- item list of the derived type. + + Found : Boolean := False; + + begin + Rep := First_Rep_Item (Derived_Type); + Last_Rep := Rep; + while Present (Rep) loop + if Rep = First_Rep_Item (Parent_Type) then + Found := True; + exit; + + else + Rep := Next_Rep_Item (Rep); + + if Present (Rep) then + Last_Rep := Rep; + end if; + end if; + end loop; + + -- Here if we either encountered the parent type's first rep + -- item on the derived type's rep item list (in which case + -- Found is True, and we have nothing else to do), or if we + -- reached the last rep item of the derived type, which is + -- Last_Rep, in which case we further chain the parent type's + -- rep items to those of the derived type. + + if not Found then + Set_Next_Rep_Item (Last_Rep, First_Rep_Item (Parent_Type)); + end if; + end; + + else + Set_First_Rep_Item (Derived_Type, First_Rep_Item (Parent_Type)); + end if; + + case Ekind (Parent_Type) is + when Numeric_Kind => + Build_Derived_Numeric_Type (N, Parent_Type, Derived_Type); + + when Array_Kind => + Build_Derived_Array_Type (N, Parent_Type, Derived_Type); + + when E_Record_Type + | E_Record_Subtype + | Class_Wide_Kind => + Build_Derived_Record_Type + (N, Parent_Type, Derived_Type, Derive_Subps); + return; + + when Enumeration_Kind => + Build_Derived_Enumeration_Type (N, Parent_Type, Derived_Type); + + when Access_Kind => + Build_Derived_Access_Type (N, Parent_Type, Derived_Type); + + when Incomplete_Or_Private_Kind => + Build_Derived_Private_Type + (N, Parent_Type, Derived_Type, Is_Completion, Derive_Subps); + + -- For discriminated types, the derivation includes deriving + -- primitive operations. For others it is done below. + + if Is_Tagged_Type (Parent_Type) + or else Has_Discriminants (Parent_Type) + or else (Present (Full_View (Parent_Type)) + and then Has_Discriminants (Full_View (Parent_Type))) + then + return; + end if; + + when Concurrent_Kind => + Build_Derived_Concurrent_Type (N, Parent_Type, Derived_Type); + + when others => + raise Program_Error; + end case; + + if Etype (Derived_Type) = Any_Type then + return; + end if; + + -- Set delayed freeze and then derive subprograms, we need to do this + -- in this order so that derived subprograms inherit the derived freeze + -- if necessary. + + Set_Has_Delayed_Freeze (Derived_Type); + if Derive_Subps then + Derive_Subprograms (Parent_Type, Derived_Type); + end if; + + Set_Has_Primitive_Operations + (Base_Type (Derived_Type), Has_Primitive_Operations (Parent_Type)); + end Build_Derived_Type; + + ----------------------- + -- Build_Discriminal -- + ----------------------- + + procedure Build_Discriminal (Discrim : Entity_Id) is + D_Minal : Entity_Id; + CR_Disc : Entity_Id; + + begin + -- A discriminal has the same name as the discriminant + + D_Minal := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim)); + + Set_Ekind (D_Minal, E_In_Parameter); + Set_Mechanism (D_Minal, Default_Mechanism); + Set_Etype (D_Minal, Etype (Discrim)); + Set_Scope (D_Minal, Current_Scope); + + Set_Discriminal (Discrim, D_Minal); + Set_Discriminal_Link (D_Minal, Discrim); + + -- For task types, build at once the discriminants of the corresponding + -- record, which are needed if discriminants are used in entry defaults + -- and in family bounds. + + if Is_Concurrent_Type (Current_Scope) + or else Is_Limited_Type (Current_Scope) + then + CR_Disc := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim)); + + Set_Ekind (CR_Disc, E_In_Parameter); + Set_Mechanism (CR_Disc, Default_Mechanism); + Set_Etype (CR_Disc, Etype (Discrim)); + Set_Scope (CR_Disc, Current_Scope); + Set_Discriminal_Link (CR_Disc, Discrim); + Set_CR_Discriminant (Discrim, CR_Disc); + end if; + end Build_Discriminal; + + ------------------------------------ + -- Build_Discriminant_Constraints -- + ------------------------------------ + + function Build_Discriminant_Constraints + (T : Entity_Id; + Def : Node_Id; + Derived_Def : Boolean := False) return Elist_Id + is + C : constant Node_Id := Constraint (Def); + Nb_Discr : constant Nat := Number_Discriminants (T); + + Discr_Expr : array (1 .. Nb_Discr) of Node_Id := (others => Empty); + -- Saves the expression corresponding to a given discriminant in T + + function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat; + -- Return the Position number within array Discr_Expr of a discriminant + -- D within the discriminant list of the discriminated type T. + + ------------------ + -- Pos_Of_Discr -- + ------------------ + + function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat is + Disc : Entity_Id; + + begin + Disc := First_Discriminant (T); + for J in Discr_Expr'Range loop + if Disc = D then + return J; + end if; + + Next_Discriminant (Disc); + end loop; + + -- Note: Since this function is called on discriminants that are + -- known to belong to the discriminated type, falling through the + -- loop with no match signals an internal compiler error. + + raise Program_Error; + end Pos_Of_Discr; + + -- Declarations local to Build_Discriminant_Constraints + + Discr : Entity_Id; + E : Entity_Id; + Elist : constant Elist_Id := New_Elmt_List; + + Constr : Node_Id; + Expr : Node_Id; + Id : Node_Id; + Position : Nat; + Found : Boolean; + + Discrim_Present : Boolean := False; + + -- Start of processing for Build_Discriminant_Constraints + + begin + -- The following loop will process positional associations only. + -- For a positional association, the (single) discriminant is + -- implicitly specified by position, in textual order (RM 3.7.2). + + Discr := First_Discriminant (T); + Constr := First (Constraints (C)); + for D in Discr_Expr'Range loop + exit when Nkind (Constr) = N_Discriminant_Association; + + if No (Constr) then + Error_Msg_N ("too few discriminants given in constraint", C); + return New_Elmt_List; + + elsif Nkind (Constr) = N_Range + or else (Nkind (Constr) = N_Attribute_Reference + and then + Attribute_Name (Constr) = Name_Range) + then + Error_Msg_N + ("a range is not a valid discriminant constraint", Constr); + Discr_Expr (D) := Error; + + else + Analyze_And_Resolve (Constr, Base_Type (Etype (Discr))); + Discr_Expr (D) := Constr; + end if; + + Next_Discriminant (Discr); + Next (Constr); + end loop; + + if No (Discr) and then Present (Constr) then + Error_Msg_N ("too many discriminants given in constraint", Constr); + return New_Elmt_List; + end if; + + -- Named associations can be given in any order, but if both positional + -- and named associations are used in the same discriminant constraint, + -- then positional associations must occur first, at their normal + -- position. Hence once a named association is used, the rest of the + -- discriminant constraint must use only named associations. + + while Present (Constr) loop + + -- Positional association forbidden after a named association + + if Nkind (Constr) /= N_Discriminant_Association then + Error_Msg_N ("positional association follows named one", Constr); + return New_Elmt_List; + + -- Otherwise it is a named association + + else + -- E records the type of the discriminants in the named + -- association. All the discriminants specified in the same name + -- association must have the same type. + + E := Empty; + + -- Search the list of discriminants in T to see if the simple name + -- given in the constraint matches any of them. + + Id := First (Selector_Names (Constr)); + while Present (Id) loop + Found := False; + + -- If Original_Discriminant is present, we are processing a + -- generic instantiation and this is an instance node. We need + -- to find the name of the corresponding discriminant in the + -- actual record type T and not the name of the discriminant in + -- the generic formal. Example: + + -- generic + -- type G (D : int) is private; + -- package P is + -- subtype W is G (D => 1); + -- end package; + -- type Rec (X : int) is record ... end record; + -- package Q is new P (G => Rec); + + -- At the point of the instantiation, formal type G is Rec + -- and therefore when reanalyzing "subtype W is G (D => 1);" + -- which really looks like "subtype W is Rec (D => 1);" at + -- the point of instantiation, we want to find the discriminant + -- that corresponds to D in Rec, i.e. X. + + if Present (Original_Discriminant (Id)) then + Discr := Find_Corresponding_Discriminant (Id, T); + Found := True; + + else + Discr := First_Discriminant (T); + while Present (Discr) loop + if Chars (Discr) = Chars (Id) then + Found := True; + exit; + end if; + + Next_Discriminant (Discr); + end loop; + + if not Found then + Error_Msg_N ("& does not match any discriminant", Id); + return New_Elmt_List; + + -- The following is only useful for the benefit of generic + -- instances but it does not interfere with other + -- processing for the non-generic case so we do it in all + -- cases (for generics this statement is executed when + -- processing the generic definition, see comment at the + -- beginning of this if statement). + + else + Set_Original_Discriminant (Id, Discr); + end if; + end if; + + Position := Pos_Of_Discr (T, Discr); + + if Present (Discr_Expr (Position)) then + Error_Msg_N ("duplicate constraint for discriminant&", Id); + + else + -- Each discriminant specified in the same named association + -- must be associated with a separate copy of the + -- corresponding expression. + + if Present (Next (Id)) then + Expr := New_Copy_Tree (Expression (Constr)); + Set_Parent (Expr, Parent (Expression (Constr))); + else + Expr := Expression (Constr); + end if; + + Discr_Expr (Position) := Expr; + Analyze_And_Resolve (Expr, Base_Type (Etype (Discr))); + end if; + + -- A discriminant association with more than one discriminant + -- name is only allowed if the named discriminants are all of + -- the same type (RM 3.7.1(8)). + + if E = Empty then + E := Base_Type (Etype (Discr)); + + elsif Base_Type (Etype (Discr)) /= E then + Error_Msg_N + ("all discriminants in an association " & + "must have the same type", Id); + end if; + + Next (Id); + end loop; + end if; + + Next (Constr); + end loop; + + -- A discriminant constraint must provide exactly one value for each + -- discriminant of the type (RM 3.7.1(8)). + + for J in Discr_Expr'Range loop + if No (Discr_Expr (J)) then + Error_Msg_N ("too few discriminants given in constraint", C); + return New_Elmt_List; + end if; + end loop; + + -- Determine if there are discriminant expressions in the constraint + + for J in Discr_Expr'Range loop + if Denotes_Discriminant + (Discr_Expr (J), Check_Concurrent => True) + then + Discrim_Present := True; + end if; + end loop; + + -- Build an element list consisting of the expressions given in the + -- discriminant constraint and apply the appropriate checks. The list + -- is constructed after resolving any named discriminant associations + -- and therefore the expressions appear in the textual order of the + -- discriminants. + + Discr := First_Discriminant (T); + for J in Discr_Expr'Range loop + if Discr_Expr (J) /= Error then + Append_Elmt (Discr_Expr (J), Elist); + + -- If any of the discriminant constraints is given by a + -- discriminant and we are in a derived type declaration we + -- have a discriminant renaming. Establish link between new + -- and old discriminant. + + if Denotes_Discriminant (Discr_Expr (J)) then + if Derived_Def then + Set_Corresponding_Discriminant + (Entity (Discr_Expr (J)), Discr); + end if; + + -- Force the evaluation of non-discriminant expressions. + -- If we have found a discriminant in the constraint 3.4(26) + -- and 3.8(18) demand that no range checks are performed are + -- after evaluation. If the constraint is for a component + -- definition that has a per-object constraint, expressions are + -- evaluated but not checked either. In all other cases perform + -- a range check. + + else + if Discrim_Present then + null; + + elsif Nkind (Parent (Parent (Def))) = N_Component_Declaration + and then + Has_Per_Object_Constraint + (Defining_Identifier (Parent (Parent (Def)))) + then + null; + + elsif Is_Access_Type (Etype (Discr)) then + Apply_Constraint_Check (Discr_Expr (J), Etype (Discr)); + + else + Apply_Range_Check (Discr_Expr (J), Etype (Discr)); + end if; + + Force_Evaluation (Discr_Expr (J)); + end if; + + -- Check that the designated type of an access discriminant's + -- expression is not a class-wide type unless the discriminant's + -- designated type is also class-wide. + + if Ekind (Etype (Discr)) = E_Anonymous_Access_Type + and then not Is_Class_Wide_Type + (Designated_Type (Etype (Discr))) + and then Etype (Discr_Expr (J)) /= Any_Type + and then Is_Class_Wide_Type + (Designated_Type (Etype (Discr_Expr (J)))) + then + Wrong_Type (Discr_Expr (J), Etype (Discr)); + + elsif Is_Access_Type (Etype (Discr)) + and then not Is_Access_Constant (Etype (Discr)) + and then Is_Access_Type (Etype (Discr_Expr (J))) + and then Is_Access_Constant (Etype (Discr_Expr (J))) + then + Error_Msg_NE + ("constraint for discriminant& must be access to variable", + Def, Discr); + end if; + end if; + + Next_Discriminant (Discr); + end loop; + + return Elist; + end Build_Discriminant_Constraints; + + --------------------------------- + -- Build_Discriminated_Subtype -- + --------------------------------- + + procedure Build_Discriminated_Subtype + (T : Entity_Id; + Def_Id : Entity_Id; + Elist : Elist_Id; + Related_Nod : Node_Id; + For_Access : Boolean := False) + is + Has_Discrs : constant Boolean := Has_Discriminants (T); + Constrained : constant Boolean := + (Has_Discrs + and then not Is_Empty_Elmt_List (Elist) + and then not Is_Class_Wide_Type (T)) + or else Is_Constrained (T); + + begin + if Ekind (T) = E_Record_Type then + if For_Access then + Set_Ekind (Def_Id, E_Private_Subtype); + Set_Is_For_Access_Subtype (Def_Id, True); + else + Set_Ekind (Def_Id, E_Record_Subtype); + end if; + + -- Inherit preelaboration flag from base, for types for which it + -- may have been set: records, private types, protected types. + + Set_Known_To_Have_Preelab_Init + (Def_Id, Known_To_Have_Preelab_Init (T)); + + elsif Ekind (T) = E_Task_Type then + Set_Ekind (Def_Id, E_Task_Subtype); + + elsif Ekind (T) = E_Protected_Type then + Set_Ekind (Def_Id, E_Protected_Subtype); + Set_Known_To_Have_Preelab_Init + (Def_Id, Known_To_Have_Preelab_Init (T)); + + elsif Is_Private_Type (T) then + Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); + Set_Known_To_Have_Preelab_Init + (Def_Id, Known_To_Have_Preelab_Init (T)); + + elsif Is_Class_Wide_Type (T) then + Set_Ekind (Def_Id, E_Class_Wide_Subtype); + + else + -- Incomplete type. Attach subtype to list of dependents, to be + -- completed with full view of parent type, unless is it the + -- designated subtype of a record component within an init_proc. + -- This last case arises for a component of an access type whose + -- designated type is incomplete (e.g. a Taft Amendment type). + -- The designated subtype is within an inner scope, and needs no + -- elaboration, because only the access type is needed in the + -- initialization procedure. + + Set_Ekind (Def_Id, Ekind (T)); + + if For_Access and then Within_Init_Proc then + null; + else + Append_Elmt (Def_Id, Private_Dependents (T)); + end if; + end if; + + Set_Etype (Def_Id, T); + Init_Size_Align (Def_Id); + Set_Has_Discriminants (Def_Id, Has_Discrs); + Set_Is_Constrained (Def_Id, Constrained); + + Set_First_Entity (Def_Id, First_Entity (T)); + Set_Last_Entity (Def_Id, Last_Entity (T)); + + -- If the subtype is the completion of a private declaration, there may + -- have been representation clauses for the partial view, and they must + -- be preserved. Build_Derived_Type chains the inherited clauses with + -- the ones appearing on the extension. If this comes from a subtype + -- declaration, all clauses are inherited. + + if No (First_Rep_Item (Def_Id)) then + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + end if; + + if Is_Tagged_Type (T) then + Set_Is_Tagged_Type (Def_Id); + Make_Class_Wide_Type (Def_Id); + end if; + + Set_Stored_Constraint (Def_Id, No_Elist); + + if Has_Discrs then + Set_Discriminant_Constraint (Def_Id, Elist); + Set_Stored_Constraint_From_Discriminant_Constraint (Def_Id); + end if; + + if Is_Tagged_Type (T) then + + -- Ada 2005 (AI-251): In case of concurrent types we inherit the + -- concurrent record type (which has the list of primitive + -- operations). + + if Ada_Version >= Ada_2005 + and then Is_Concurrent_Type (T) + then + Set_Corresponding_Record_Type (Def_Id, + Corresponding_Record_Type (T)); + else + Set_Direct_Primitive_Operations (Def_Id, + Direct_Primitive_Operations (T)); + end if; + + Set_Is_Abstract_Type (Def_Id, Is_Abstract_Type (T)); + end if; + + -- Subtypes introduced by component declarations do not need to be + -- marked as delayed, and do not get freeze nodes, because the semantics + -- verifies that the parents of the subtypes are frozen before the + -- enclosing record is frozen. + + if not Is_Type (Scope (Def_Id)) then + Set_Depends_On_Private (Def_Id, Depends_On_Private (T)); + + if Is_Private_Type (T) + and then Present (Full_View (T)) + then + Conditional_Delay (Def_Id, Full_View (T)); + else + Conditional_Delay (Def_Id, T); + end if; + end if; + + if Is_Record_Type (T) then + Set_Is_Limited_Record (Def_Id, Is_Limited_Record (T)); + + if Has_Discrs + and then not Is_Empty_Elmt_List (Elist) + and then not For_Access + then + Create_Constrained_Components (Def_Id, Related_Nod, T, Elist); + elsif not For_Access then + Set_Cloned_Subtype (Def_Id, T); + end if; + end if; + end Build_Discriminated_Subtype; + + --------------------------- + -- Build_Itype_Reference -- + --------------------------- + + procedure Build_Itype_Reference + (Ityp : Entity_Id; + Nod : Node_Id) + is + IR : constant Node_Id := Make_Itype_Reference (Sloc (Nod)); + begin + Set_Itype (IR, Ityp); + Insert_After (Nod, IR); + end Build_Itype_Reference; + + ------------------------ + -- Build_Scalar_Bound -- + ------------------------ + + function Build_Scalar_Bound + (Bound : Node_Id; + Par_T : Entity_Id; + Der_T : Entity_Id) return Node_Id + is + New_Bound : Entity_Id; + + begin + -- Note: not clear why this is needed, how can the original bound + -- be unanalyzed at this point? and if it is, what business do we + -- have messing around with it? and why is the base type of the + -- parent type the right type for the resolution. It probably is + -- not! It is OK for the new bound we are creating, but not for + -- the old one??? Still if it never happens, no problem! + + Analyze_And_Resolve (Bound, Base_Type (Par_T)); + + if Nkind_In (Bound, N_Integer_Literal, N_Real_Literal) then + New_Bound := New_Copy (Bound); + Set_Etype (New_Bound, Der_T); + Set_Analyzed (New_Bound); + + elsif Is_Entity_Name (Bound) then + New_Bound := OK_Convert_To (Der_T, New_Copy (Bound)); + + -- The following is almost certainly wrong. What business do we have + -- relocating a node (Bound) that is presumably still attached to + -- the tree elsewhere??? + + else + New_Bound := OK_Convert_To (Der_T, Relocate_Node (Bound)); + end if; + + Set_Etype (New_Bound, Der_T); + return New_Bound; + end Build_Scalar_Bound; + + -------------------------------- + -- Build_Underlying_Full_View -- + -------------------------------- + + procedure Build_Underlying_Full_View + (N : Node_Id; + Typ : Entity_Id; + Par : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Subt : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_External_Name (Chars (Typ), 'S')); + + Constr : Node_Id; + Indic : Node_Id; + C : Node_Id; + Id : Node_Id; + + procedure Set_Discriminant_Name (Id : Node_Id); + -- If the derived type has discriminants, they may rename discriminants + -- of the parent. When building the full view of the parent, we need to + -- recover the names of the original discriminants if the constraint is + -- given by named associations. + + --------------------------- + -- Set_Discriminant_Name -- + --------------------------- + + procedure Set_Discriminant_Name (Id : Node_Id) is + Disc : Entity_Id; + + begin + Set_Original_Discriminant (Id, Empty); + + if Has_Discriminants (Typ) then + Disc := First_Discriminant (Typ); + while Present (Disc) loop + if Chars (Disc) = Chars (Id) + and then Present (Corresponding_Discriminant (Disc)) + then + Set_Chars (Id, Chars (Corresponding_Discriminant (Disc))); + end if; + Next_Discriminant (Disc); + end loop; + end if; + end Set_Discriminant_Name; + + -- Start of processing for Build_Underlying_Full_View + + begin + if Nkind (N) = N_Full_Type_Declaration then + Constr := Constraint (Subtype_Indication (Type_Definition (N))); + + elsif Nkind (N) = N_Subtype_Declaration then + Constr := New_Copy_Tree (Constraint (Subtype_Indication (N))); + + elsif Nkind (N) = N_Component_Declaration then + Constr := + New_Copy_Tree + (Constraint (Subtype_Indication (Component_Definition (N)))); + + else + raise Program_Error; + end if; + + C := First (Constraints (Constr)); + while Present (C) loop + if Nkind (C) = N_Discriminant_Association then + Id := First (Selector_Names (C)); + while Present (Id) loop + Set_Discriminant_Name (Id); + Next (Id); + end loop; + end if; + + Next (C); + end loop; + + Indic := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Subt, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (Par, Loc), + Constraint => New_Copy_Tree (Constr))); + + -- If this is a component subtype for an outer itype, it is not + -- a list member, so simply set the parent link for analysis: if + -- the enclosing type does not need to be in a declarative list, + -- neither do the components. + + if Is_List_Member (N) + and then Nkind (N) /= N_Component_Declaration + then + Insert_Before (N, Indic); + else + Set_Parent (Indic, Parent (N)); + end if; + + Analyze (Indic); + Set_Underlying_Full_View (Typ, Full_View (Subt)); + end Build_Underlying_Full_View; + + ------------------------------- + -- Check_Abstract_Overriding -- + ------------------------------- + + procedure Check_Abstract_Overriding (T : Entity_Id) is + Alias_Subp : Entity_Id; + Elmt : Elmt_Id; + Op_List : Elist_Id; + Subp : Entity_Id; + Type_Def : Node_Id; + + procedure Check_Pragma_Implemented (Subp : Entity_Id); + -- Ada 2012 (AI05-0030): Subprogram Subp overrides an interface routine + -- which has pragma Implemented already set. Check whether Subp's entity + -- kind conforms to the implementation kind of the overridden routine. + + procedure Check_Pragma_Implemented + (Subp : Entity_Id; + Iface_Subp : Entity_Id); + -- Ada 2012 (AI05-0030): Subprogram Subp overrides interface routine + -- Iface_Subp and both entities have pragma Implemented already set on + -- them. Check whether the two implementation kinds are conforming. + + procedure Inherit_Pragma_Implemented + (Subp : Entity_Id; + Iface_Subp : Entity_Id); + -- Ada 2012 (AI05-0030): Interface primitive Subp overrides interface + -- subprogram Iface_Subp which has been marked by pragma Implemented. + -- Propagate the implementation kind of Iface_Subp to Subp. + + ------------------------------ + -- Check_Pragma_Implemented -- + ------------------------------ + + procedure Check_Pragma_Implemented (Subp : Entity_Id) is + Iface_Alias : constant Entity_Id := Interface_Alias (Subp); + Impl_Kind : constant Name_Id := Implementation_Kind (Iface_Alias); + Contr_Typ : Entity_Id; + + begin + -- Subp must have an alias since it is a hidden entity used to link + -- an interface subprogram to its overriding counterpart. + + pragma Assert (Present (Alias (Subp))); + + -- Extract the type of the controlling formal + + Contr_Typ := Etype (First_Formal (Alias (Subp))); + + if Is_Concurrent_Record_Type (Contr_Typ) then + Contr_Typ := Corresponding_Concurrent_Type (Contr_Typ); + end if; + + -- An interface subprogram whose implementation kind is By_Entry must + -- be implemented by an entry. + + if Impl_Kind = Name_By_Entry + and then Ekind (Wrapped_Entity (Alias (Subp))) /= E_Entry + then + Error_Msg_Node_2 := Iface_Alias; + Error_Msg_NE + ("type & must implement abstract subprogram & with an entry", + Alias (Subp), Contr_Typ); + + elsif Impl_Kind = Name_By_Protected_Procedure then + + -- An interface subprogram whose implementation kind is By_ + -- Protected_Procedure cannot be implemented by a primitive + -- procedure of a task type. + + if Ekind (Contr_Typ) /= E_Protected_Type then + Error_Msg_Node_2 := Contr_Typ; + Error_Msg_NE + ("interface subprogram & cannot be implemented by a " & + "primitive procedure of task type &", Alias (Subp), + Iface_Alias); + + -- An interface subprogram whose implementation kind is By_ + -- Protected_Procedure must be implemented by a procedure. + + elsif Is_Primitive_Wrapper (Alias (Subp)) + and then Ekind (Wrapped_Entity (Alias (Subp))) /= E_Procedure + then + Error_Msg_Node_2 := Iface_Alias; + Error_Msg_NE + ("type & must implement abstract subprogram & with a " & + "procedure", Alias (Subp), Contr_Typ); + end if; + end if; + end Check_Pragma_Implemented; + + ------------------------------ + -- Check_Pragma_Implemented -- + ------------------------------ + + procedure Check_Pragma_Implemented + (Subp : Entity_Id; + Iface_Subp : Entity_Id) + is + Iface_Kind : constant Name_Id := Implementation_Kind (Iface_Subp); + Subp_Kind : constant Name_Id := Implementation_Kind (Subp); + + begin + -- Ada 2012 (AI05-0030): The implementation kinds of an overridden + -- and overriding subprogram are different. In general this is an + -- error except when the implementation kind of the overridden + -- subprograms is By_Any. + + if Iface_Kind /= Subp_Kind + and then Iface_Kind /= Name_By_Any + then + if Iface_Kind = Name_By_Entry then + Error_Msg_N + ("incompatible implementation kind, overridden subprogram " & + "is marked By_Entry", Subp); + else + Error_Msg_N + ("incompatible implementation kind, overridden subprogram " & + "is marked By_Protected_Procedure", Subp); + end if; + end if; + end Check_Pragma_Implemented; + + -------------------------------- + -- Inherit_Pragma_Implemented -- + -------------------------------- + + procedure Inherit_Pragma_Implemented + (Subp : Entity_Id; + Iface_Subp : Entity_Id) + is + Iface_Kind : constant Name_Id := Implementation_Kind (Iface_Subp); + Loc : constant Source_Ptr := Sloc (Subp); + Impl_Prag : Node_Id; + + begin + -- Since the implementation kind is stored as a representation item + -- rather than a flag, create a pragma node. + + Impl_Prag := + Make_Pragma (Loc, + Chars => Name_Implemented, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => + New_Reference_To (Subp, Loc)), + + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Iface_Kind)))); + + -- The pragma doesn't need to be analyzed because it is internally + -- build. It is safe to directly register it as a rep item since we + -- are only interested in the characters of the implementation kind. + + Record_Rep_Item (Subp, Impl_Prag); + end Inherit_Pragma_Implemented; + + -- Start of processing for Check_Abstract_Overriding + + begin + Op_List := Primitive_Operations (T); + + -- Loop to check primitive operations + + Elmt := First_Elmt (Op_List); + while Present (Elmt) loop + Subp := Node (Elmt); + Alias_Subp := Alias (Subp); + + -- Inherited subprograms are identified by the fact that they do not + -- come from source, and the associated source location is the + -- location of the first subtype of the derived type. + + -- Ada 2005 (AI-228): Apply the rules of RM-3.9.3(6/2) for + -- subprograms that "require overriding". + + -- Special exception, do not complain about failure to override the + -- stream routines _Input and _Output, as well as the primitive + -- operations used in dispatching selects since we always provide + -- automatic overridings for these subprograms. + + -- Also ignore this rule for convention CIL since .NET libraries + -- do bizarre things with interfaces??? + + -- The partial view of T may have been a private extension, for + -- which inherited functions dispatching on result are abstract. + -- If the full view is a null extension, there is no need for + -- overriding in Ada2005, but wrappers need to be built for them + -- (see exp_ch3, Build_Controlling_Function_Wrappers). + + if Is_Null_Extension (T) + and then Has_Controlling_Result (Subp) + and then Ada_Version >= Ada_2005 + and then Present (Alias_Subp) + and then not Comes_From_Source (Subp) + and then not Is_Abstract_Subprogram (Alias_Subp) + and then not Is_Access_Type (Etype (Subp)) + then + null; + + -- Ada 2005 (AI-251): Internal entities of interfaces need no + -- processing because this check is done with the aliased + -- entity + + elsif Present (Interface_Alias (Subp)) then + null; + + elsif (Is_Abstract_Subprogram (Subp) + or else Requires_Overriding (Subp) + or else + (Has_Controlling_Result (Subp) + and then Present (Alias_Subp) + and then not Comes_From_Source (Subp) + and then Sloc (Subp) = Sloc (First_Subtype (T)))) + and then not Is_TSS (Subp, TSS_Stream_Input) + and then not Is_TSS (Subp, TSS_Stream_Output) + and then not Is_Abstract_Type (T) + and then Convention (T) /= Convention_CIL + and then not Is_Predefined_Interface_Primitive (Subp) + + -- Ada 2005 (AI-251): Do not consider hidden entities associated + -- with abstract interface types because the check will be done + -- with the aliased entity (otherwise we generate a duplicated + -- error message). + + and then not Present (Interface_Alias (Subp)) + then + if Present (Alias_Subp) then + + -- Only perform the check for a derived subprogram when the + -- type has an explicit record extension. This avoids incorrect + -- flagging of abstract subprograms for the case of a type + -- without an extension that is derived from a formal type + -- with a tagged actual (can occur within a private part). + + -- Ada 2005 (AI-391): In the case of an inherited function with + -- a controlling result of the type, the rule does not apply if + -- the type is a null extension (unless the parent function + -- itself is abstract, in which case the function must still be + -- be overridden). The expander will generate an overriding + -- wrapper function calling the parent subprogram (see + -- Exp_Ch3.Make_Controlling_Wrapper_Functions). + + Type_Def := Type_Definition (Parent (T)); + + if Nkind (Type_Def) = N_Derived_Type_Definition + and then Present (Record_Extension_Part (Type_Def)) + and then + (Ada_Version < Ada_2005 + or else not Is_Null_Extension (T) + or else Ekind (Subp) = E_Procedure + or else not Has_Controlling_Result (Subp) + or else Is_Abstract_Subprogram (Alias_Subp) + or else Requires_Overriding (Subp) + or else Is_Access_Type (Etype (Subp))) + then + -- Avoid reporting error in case of abstract predefined + -- primitive inherited from interface type because the + -- body of internally generated predefined primitives + -- of tagged types are generated later by Freeze_Type + + if Is_Interface (Root_Type (T)) + and then Is_Abstract_Subprogram (Subp) + and then Is_Predefined_Dispatching_Operation (Subp) + and then not Comes_From_Source (Ultimate_Alias (Subp)) + then + null; + + else + Error_Msg_NE + ("type must be declared abstract or & overridden", + T, Subp); + + -- Traverse the whole chain of aliased subprograms to + -- complete the error notification. This is especially + -- useful for traceability of the chain of entities when + -- the subprogram corresponds with an interface + -- subprogram (which may be defined in another package). + + if Present (Alias_Subp) then + declare + E : Entity_Id; + + begin + E := Subp; + while Present (Alias (E)) loop + Error_Msg_Sloc := Sloc (E); + Error_Msg_NE + ("\& has been inherited #", T, Subp); + E := Alias (E); + end loop; + + Error_Msg_Sloc := Sloc (E); + Error_Msg_NE + ("\& has been inherited from subprogram #", + T, Subp); + end; + end if; + end if; + + -- Ada 2005 (AI-345): Protected or task type implementing + -- abstract interfaces. + + elsif Is_Concurrent_Record_Type (T) + and then Present (Interfaces (T)) + then + -- The controlling formal of Subp must be of mode "out", + -- "in out" or an access-to-variable to be overridden. + + -- Error message below needs rewording (remember comma + -- in -gnatj mode) ??? + + if Ekind (First_Formal (Subp)) = E_In_Parameter + and then Ekind (Subp) /= E_Function + then + if not Is_Predefined_Dispatching_Operation (Subp) then + Error_Msg_NE + ("first formal of & must be of mode `OUT`, " & + "`IN OUT` or access-to-variable", T, Subp); + Error_Msg_N + ("\to be overridden by protected procedure or " & + "entry (RM 9.4(11.9/2))", T); + end if; + + -- Some other kind of overriding failure + + else + Error_Msg_NE + ("interface subprogram & must be overridden", + T, Subp); + + -- Examine primitive operations of synchronized type, + -- to find homonyms that have the wrong profile. + + declare + Prim : Entity_Id; + + begin + Prim := + First_Entity (Corresponding_Concurrent_Type (T)); + while Present (Prim) loop + if Chars (Prim) = Chars (Subp) then + Error_Msg_NE + ("profile is not type conformant with " + & "prefixed view profile of " + & "inherited operation&", Prim, Subp); + end if; + + Next_Entity (Prim); + end loop; + end; + end if; + end if; + + else + Error_Msg_Node_2 := T; + Error_Msg_N + ("abstract subprogram& not allowed for type&", Subp); + + -- Also post unconditional warning on the type (unconditional + -- so that if there are more than one of these cases, we get + -- them all, and not just the first one). + + Error_Msg_Node_2 := Subp; + Error_Msg_N ("nonabstract type& has abstract subprogram&!", T); + end if; + end if; + + -- Ada 2012 (AI05-0030): Perform some checks related to pragma + -- Implemented + + -- Subp is an expander-generated procedure which maps an interface + -- alias to a protected wrapper. The interface alias is flagged by + -- pragma Implemented. Ensure that Subp is a procedure when the + -- implementation kind is By_Protected_Procedure or an entry when + -- By_Entry. + + if Ada_Version >= Ada_2012 + and then Is_Hidden (Subp) + and then Present (Interface_Alias (Subp)) + and then Has_Rep_Pragma (Interface_Alias (Subp), Name_Implemented) + then + Check_Pragma_Implemented (Subp); + end if; + + -- Subp is an interface primitive which overrides another interface + -- primitive marked with pragma Implemented. + + if Ada_Version >= Ada_2012 + and then Present (Overridden_Operation (Subp)) + and then Has_Rep_Pragma + (Overridden_Operation (Subp), Name_Implemented) + then + -- If the overriding routine is also marked by Implemented, check + -- that the two implementation kinds are conforming. + + if Has_Rep_Pragma (Subp, Name_Implemented) then + Check_Pragma_Implemented + (Subp => Subp, + Iface_Subp => Overridden_Operation (Subp)); + + -- Otherwise the overriding routine inherits the implementation + -- kind from the overridden subprogram. + + else + Inherit_Pragma_Implemented + (Subp => Subp, + Iface_Subp => Overridden_Operation (Subp)); + end if; + end if; + + Next_Elmt (Elmt); + end loop; + end Check_Abstract_Overriding; + + ------------------------------------------------ + -- Check_Access_Discriminant_Requires_Limited -- + ------------------------------------------------ + + procedure Check_Access_Discriminant_Requires_Limited + (D : Node_Id; + Loc : Node_Id) + is + begin + -- A discriminant_specification for an access discriminant shall appear + -- only in the declaration for a task or protected type, or for a type + -- with the reserved word 'limited' in its definition or in one of its + -- ancestors (RM 3.7(10)). + + -- AI-0063: The proper condition is that type must be immutably limited, + -- or else be a partial view. + + if Nkind (Discriminant_Type (D)) = N_Access_Definition then + if Is_Immutably_Limited_Type (Current_Scope) + or else + (Nkind (Parent (Current_Scope)) = N_Private_Type_Declaration + and then Limited_Present (Parent (Current_Scope))) + then + null; + + else + Error_Msg_N + ("access discriminants allowed only for limited types", Loc); + end if; + end if; + end Check_Access_Discriminant_Requires_Limited; + + ----------------------------------- + -- Check_Aliased_Component_Types -- + ----------------------------------- + + procedure Check_Aliased_Component_Types (T : Entity_Id) is + C : Entity_Id; + + begin + -- ??? Also need to check components of record extensions, but not + -- components of protected types (which are always limited). + + -- Ada 2005: AI-363 relaxes this rule, to allow heap objects of such + -- types to be unconstrained. This is safe because it is illegal to + -- create access subtypes to such types with explicit discriminant + -- constraints. + + if not Is_Limited_Type (T) then + if Ekind (T) = E_Record_Type then + C := First_Component (T); + while Present (C) loop + if Is_Aliased (C) + and then Has_Discriminants (Etype (C)) + and then not Is_Constrained (Etype (C)) + and then not In_Instance_Body + and then Ada_Version < Ada_2005 + then + Error_Msg_N + ("aliased component must be constrained (RM 3.6(11))", + C); + end if; + + Next_Component (C); + end loop; + + elsif Ekind (T) = E_Array_Type then + if Has_Aliased_Components (T) + and then Has_Discriminants (Component_Type (T)) + and then not Is_Constrained (Component_Type (T)) + and then not In_Instance_Body + and then Ada_Version < Ada_2005 + then + Error_Msg_N + ("aliased component type must be constrained (RM 3.6(11))", + T); + end if; + end if; + end if; + end Check_Aliased_Component_Types; + + ---------------------- + -- Check_Completion -- + ---------------------- + + procedure Check_Completion (Body_Id : Node_Id := Empty) is + E : Entity_Id; + + procedure Post_Error; + -- Post error message for lack of completion for entity E + + ---------------- + -- Post_Error -- + ---------------- + + procedure Post_Error is + + procedure Missing_Body; + -- Output missing body message + + ------------------ + -- Missing_Body -- + ------------------ + + procedure Missing_Body is + begin + -- Spec is in same unit, so we can post on spec + + if In_Same_Source_Unit (Body_Id, E) then + Error_Msg_N ("missing body for &", E); + + -- Spec is in a separate unit, so we have to post on the body + + else + Error_Msg_NE ("missing body for & declared#!", Body_Id, E); + end if; + end Missing_Body; + + -- Start of processing for Post_Error + + begin + if not Comes_From_Source (E) then + + if Ekind_In (E, E_Task_Type, E_Protected_Type) then + -- It may be an anonymous protected type created for a + -- single variable. Post error on variable, if present. + + declare + Var : Entity_Id; + + begin + Var := First_Entity (Current_Scope); + while Present (Var) loop + exit when Etype (Var) = E + and then Comes_From_Source (Var); + + Next_Entity (Var); + end loop; + + if Present (Var) then + E := Var; + end if; + end; + end if; + end if; + + -- If a generated entity has no completion, then either previous + -- semantic errors have disabled the expansion phase, or else we had + -- missing subunits, or else we are compiling without expansion, + -- or else something is very wrong. + + if not Comes_From_Source (E) then + pragma Assert + (Serious_Errors_Detected > 0 + or else Configurable_Run_Time_Violations > 0 + or else Subunits_Missing + or else not Expander_Active); + return; + + -- Here for source entity + + else + -- Here if no body to post the error message, so we post the error + -- on the declaration that has no completion. This is not really + -- the right place to post it, think about this later ??? + + if No (Body_Id) then + if Is_Type (E) then + Error_Msg_NE + ("missing full declaration for }", Parent (E), E); + else + Error_Msg_NE ("missing body for &", Parent (E), E); + end if; + + -- Package body has no completion for a declaration that appears + -- in the corresponding spec. Post error on the body, with a + -- reference to the non-completed declaration. + + else + Error_Msg_Sloc := Sloc (E); + + if Is_Type (E) then + Error_Msg_NE ("missing full declaration for }!", Body_Id, E); + + elsif Is_Overloadable (E) + and then Current_Entity_In_Scope (E) /= E + then + -- It may be that the completion is mistyped and appears as + -- a distinct overloading of the entity. + + declare + Candidate : constant Entity_Id := + Current_Entity_In_Scope (E); + Decl : constant Node_Id := + Unit_Declaration_Node (Candidate); + + begin + if Is_Overloadable (Candidate) + and then Ekind (Candidate) = Ekind (E) + and then Nkind (Decl) = N_Subprogram_Body + and then Acts_As_Spec (Decl) + then + Check_Type_Conformant (Candidate, E); + + else + Missing_Body; + end if; + end; + + else + Missing_Body; + end if; + end if; + end if; + end Post_Error; + + -- Start of processing for Check_Completion + + begin + E := First_Entity (Current_Scope); + while Present (E) loop + if Is_Intrinsic_Subprogram (E) then + null; + + -- The following situation requires special handling: a child unit + -- that appears in the context clause of the body of its parent: + + -- procedure Parent.Child (...); + + -- with Parent.Child; + -- package body Parent is + + -- Here Parent.Child appears as a local entity, but should not be + -- flagged as requiring completion, because it is a compilation + -- unit. + + -- Ignore missing completion for a subprogram that does not come from + -- source (including the _Call primitive operation of RAS types, + -- which has to have the flag Comes_From_Source for other purposes): + -- we assume that the expander will provide the missing completion. + -- In case of previous errors, other expansion actions that provide + -- bodies for null procedures with not be invoked, so inhibit message + -- in those cases. + -- Note that E_Operator is not in the list that follows, because + -- this kind is reserved for predefined operators, that are + -- intrinsic and do not need completion. + + elsif Ekind (E) = E_Function + or else Ekind (E) = E_Procedure + or else Ekind (E) = E_Generic_Function + or else Ekind (E) = E_Generic_Procedure + then + if Has_Completion (E) then + null; + + elsif Is_Subprogram (E) and then Is_Abstract_Subprogram (E) then + null; + + elsif Is_Subprogram (E) + and then (not Comes_From_Source (E) + or else Chars (E) = Name_uCall) + then + null; + + elsif + Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit + then + null; + + elsif Nkind (Parent (E)) = N_Procedure_Specification + and then Null_Present (Parent (E)) + and then Serious_Errors_Detected > 0 + then + null; + + else + Post_Error; + end if; + + elsif Is_Entry (E) then + if not Has_Completion (E) and then + (Ekind (Scope (E)) = E_Protected_Object + or else Ekind (Scope (E)) = E_Protected_Type) + then + Post_Error; + end if; + + elsif Is_Package_Or_Generic_Package (E) then + if Unit_Requires_Body (E) then + if not Has_Completion (E) + and then Nkind (Parent (Unit_Declaration_Node (E))) /= + N_Compilation_Unit + then + Post_Error; + end if; + + elsif not Is_Child_Unit (E) then + May_Need_Implicit_Body (E); + end if; + + elsif Ekind (E) = E_Incomplete_Type + and then No (Underlying_Type (E)) + then + Post_Error; + + elsif (Ekind (E) = E_Task_Type or else + Ekind (E) = E_Protected_Type) + and then not Has_Completion (E) + then + Post_Error; + + -- A single task declared in the current scope is a constant, verify + -- that the body of its anonymous type is in the same scope. If the + -- task is defined elsewhere, this may be a renaming declaration for + -- which no completion is needed. + + elsif Ekind (E) = E_Constant + and then Ekind (Etype (E)) = E_Task_Type + and then not Has_Completion (Etype (E)) + and then Scope (Etype (E)) = Current_Scope + then + Post_Error; + + elsif Ekind (E) = E_Protected_Object + and then not Has_Completion (Etype (E)) + then + Post_Error; + + elsif Ekind (E) = E_Record_Type then + if Is_Tagged_Type (E) then + Check_Abstract_Overriding (E); + Check_Conventions (E); + end if; + + Check_Aliased_Component_Types (E); + + elsif Ekind (E) = E_Array_Type then + Check_Aliased_Component_Types (E); + + end if; + + Next_Entity (E); + end loop; + end Check_Completion; + + ---------------------------- + -- Check_Delta_Expression -- + ---------------------------- + + procedure Check_Delta_Expression (E : Node_Id) is + begin + if not (Is_Real_Type (Etype (E))) then + Wrong_Type (E, Any_Real); + + elsif not Is_OK_Static_Expression (E) then + Flag_Non_Static_Expr + ("non-static expression used for delta value!", E); + + elsif not UR_Is_Positive (Expr_Value_R (E)) then + Error_Msg_N ("delta expression must be positive", E); + + else + return; + end if; + + -- If any of above errors occurred, then replace the incorrect + -- expression by the real 0.1, which should prevent further errors. + + Rewrite (E, + Make_Real_Literal (Sloc (E), Ureal_Tenth)); + Analyze_And_Resolve (E, Standard_Float); + end Check_Delta_Expression; + + ----------------------------- + -- Check_Digits_Expression -- + ----------------------------- + + procedure Check_Digits_Expression (E : Node_Id) is + begin + if not (Is_Integer_Type (Etype (E))) then + Wrong_Type (E, Any_Integer); + + elsif not Is_OK_Static_Expression (E) then + Flag_Non_Static_Expr + ("non-static expression used for digits value!", E); + + elsif Expr_Value (E) <= 0 then + Error_Msg_N ("digits value must be greater than zero", E); + + else + return; + end if; + + -- If any of above errors occurred, then replace the incorrect + -- expression by the integer 1, which should prevent further errors. + + Rewrite (E, Make_Integer_Literal (Sloc (E), 1)); + Analyze_And_Resolve (E, Standard_Integer); + + end Check_Digits_Expression; + + -------------------------- + -- Check_Initialization -- + -------------------------- + + procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is + begin + if Is_Limited_Type (T) + and then not In_Instance + and then not In_Inlined_Body + then + if not OK_For_Limited_Init (T, Exp) then + + -- In GNAT mode, this is just a warning, to allow it to be evilly + -- turned off. Otherwise it is a real error. + + if GNAT_Mode then + Error_Msg_N + ("?cannot initialize entities of limited type!", Exp); + + elsif Ada_Version < Ada_2005 then + Error_Msg_N + ("cannot initialize entities of limited type", Exp); + Explain_Limited_Type (T, Exp); + + else + -- Specialize error message according to kind of illegal + -- initial expression. + + if Nkind (Exp) = N_Type_Conversion + and then Nkind (Expression (Exp)) = N_Function_Call + then + Error_Msg_N + ("illegal context for call" + & " to function with limited result", Exp); + + else + Error_Msg_N + ("initialization of limited object requires aggregate " + & "or function call", Exp); + end if; + end if; + end if; + end if; + end Check_Initialization; + + ---------------------- + -- Check_Interfaces -- + ---------------------- + + procedure Check_Interfaces (N : Node_Id; Def : Node_Id) is + Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N)); + + Iface : Node_Id; + Iface_Def : Node_Id; + Iface_Typ : Entity_Id; + Parent_Node : Node_Id; + + Is_Task : Boolean := False; + -- Set True if parent type or any progenitor is a task interface + + Is_Protected : Boolean := False; + -- Set True if parent type or any progenitor is a protected interface + + procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id); + -- Check that a progenitor is compatible with declaration. + -- Error is posted on Error_Node. + + ------------------ + -- Check_Ifaces -- + ------------------ + + procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is + Iface_Id : constant Entity_Id := + Defining_Identifier (Parent (Iface_Def)); + Type_Def : Node_Id; + + begin + if Nkind (N) = N_Private_Extension_Declaration then + Type_Def := N; + else + Type_Def := Type_Definition (N); + end if; + + if Is_Task_Interface (Iface_Id) then + Is_Task := True; + + elsif Is_Protected_Interface (Iface_Id) then + Is_Protected := True; + end if; + + if Is_Synchronized_Interface (Iface_Id) then + + -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private + -- extension derived from a synchronized interface must explicitly + -- be declared synchronized, because the full view will be a + -- synchronized type. + + if Nkind (N) = N_Private_Extension_Declaration then + if not Synchronized_Present (N) then + Error_Msg_NE + ("private extension of& must be explicitly synchronized", + N, Iface_Id); + end if; + + -- However, by 3.9.4(16/2), a full type that is a record extension + -- is never allowed to derive from a synchronized interface (note + -- that interfaces must be excluded from this check, because those + -- are represented by derived type definitions in some cases). + + elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition + and then not Interface_Present (Type_Definition (N)) + then + Error_Msg_N ("record extension cannot derive from synchronized" + & " interface", Error_Node); + end if; + end if; + + -- Check that the characteristics of the progenitor are compatible + -- with the explicit qualifier in the declaration. + -- The check only applies to qualifiers that come from source. + -- Limited_Present also appears in the declaration of corresponding + -- records, and the check does not apply to them. + + if Limited_Present (Type_Def) + and then not + Is_Concurrent_Record_Type (Defining_Identifier (N)) + then + if Is_Limited_Interface (Parent_Type) + and then not Is_Limited_Interface (Iface_Id) + then + Error_Msg_NE + ("progenitor& must be limited interface", + Error_Node, Iface_Id); + + elsif + (Task_Present (Iface_Def) + or else Protected_Present (Iface_Def) + or else Synchronized_Present (Iface_Def)) + and then Nkind (N) /= N_Private_Extension_Declaration + and then not Error_Posted (N) + then + Error_Msg_NE + ("progenitor& must be limited interface", + Error_Node, Iface_Id); + end if; + + -- Protected interfaces can only inherit from limited, synchronized + -- or protected interfaces. + + elsif Nkind (N) = N_Full_Type_Declaration + and then Protected_Present (Type_Def) + then + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + or else Protected_Present (Iface_Def) + then + null; + + elsif Task_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) protected interface cannot inherit" + & " from task interface", Error_Node); + + else + Error_Msg_N ("(Ada 2005) protected interface cannot inherit" + & " from non-limited interface", Error_Node); + end if; + + -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from + -- limited and synchronized. + + elsif Synchronized_Present (Type_Def) then + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + then + null; + + elsif Protected_Present (Iface_Def) + and then Nkind (N) /= N_Private_Extension_Declaration + then + Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" + & " from protected interface", Error_Node); + + elsif Task_Present (Iface_Def) + and then Nkind (N) /= N_Private_Extension_Declaration + then + Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" + & " from task interface", Error_Node); + + elsif not Is_Limited_Interface (Iface_Id) then + Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" + & " from non-limited interface", Error_Node); + end if; + + -- Ada 2005 (AI-345): Task interfaces can only inherit from limited, + -- synchronized or task interfaces. + + elsif Nkind (N) = N_Full_Type_Declaration + and then Task_Present (Type_Def) + then + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + or else Task_Present (Iface_Def) + then + null; + + elsif Protected_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) task interface cannot inherit from" + & " protected interface", Error_Node); + + else + Error_Msg_N ("(Ada 2005) task interface cannot inherit from" + & " non-limited interface", Error_Node); + end if; + end if; + end Check_Ifaces; + + -- Start of processing for Check_Interfaces + + begin + if Is_Interface (Parent_Type) then + if Is_Task_Interface (Parent_Type) then + Is_Task := True; + + elsif Is_Protected_Interface (Parent_Type) then + Is_Protected := True; + end if; + end if; + + if Nkind (N) = N_Private_Extension_Declaration then + + -- Check that progenitors are compatible with declaration + + Iface := First (Interface_List (Def)); + while Present (Iface) loop + Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); + + Parent_Node := Parent (Base_Type (Iface_Typ)); + Iface_Def := Type_Definition (Parent_Node); + + if not Is_Interface (Iface_Typ) then + Diagnose_Interface (Iface, Iface_Typ); + + else + Check_Ifaces (Iface_Def, Iface); + end if; + + Next (Iface); + end loop; + + if Is_Task and Is_Protected then + Error_Msg_N + ("type cannot derive from task and protected interface", N); + end if; + + return; + end if; + + -- Full type declaration of derived type. + -- Check compatibility with parent if it is interface type + + if Nkind (Type_Definition (N)) = N_Derived_Type_Definition + and then Is_Interface (Parent_Type) + then + Parent_Node := Parent (Parent_Type); + + -- More detailed checks for interface varieties + + Check_Ifaces + (Iface_Def => Type_Definition (Parent_Node), + Error_Node => Subtype_Indication (Type_Definition (N))); + end if; + + Iface := First (Interface_List (Def)); + while Present (Iface) loop + Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); + + Parent_Node := Parent (Base_Type (Iface_Typ)); + Iface_Def := Type_Definition (Parent_Node); + + if not Is_Interface (Iface_Typ) then + Diagnose_Interface (Iface, Iface_Typ); + + else + -- "The declaration of a specific descendant of an interface + -- type freezes the interface type" RM 13.14 + + Freeze_Before (N, Iface_Typ); + Check_Ifaces (Iface_Def, Error_Node => Iface); + end if; + + Next (Iface); + end loop; + + if Is_Task and Is_Protected then + Error_Msg_N + ("type cannot derive from task and protected interface", N); + end if; + end Check_Interfaces; + + ------------------------------------ + -- Check_Or_Process_Discriminants -- + ------------------------------------ + + -- If an incomplete or private type declaration was already given for the + -- type, the discriminants may have already been processed if they were + -- present on the incomplete declaration. In this case a full conformance + -- check has been performed in Find_Type_Name, and we then recheck here + -- some properties that can't be checked on the partial view alone. + -- Otherwise we call Process_Discriminants. + + procedure Check_Or_Process_Discriminants + (N : Node_Id; + T : Entity_Id; + Prev : Entity_Id := Empty) + is + begin + if Has_Discriminants (T) then + + -- Discriminants are already set on T if they were already present + -- on the partial view. Make them visible to component declarations. + + declare + D : Entity_Id; + -- Discriminant on T (full view) referencing expr on partial view + + Prev_D : Entity_Id; + -- Entity of corresponding discriminant on partial view + + New_D : Node_Id; + -- Discriminant specification for full view, expression is the + -- syntactic copy on full view (which has been checked for + -- conformance with partial view), only used here to post error + -- message. + + begin + D := First_Discriminant (T); + New_D := First (Discriminant_Specifications (N)); + while Present (D) loop + Prev_D := Current_Entity (D); + Set_Current_Entity (D); + Set_Is_Immediately_Visible (D); + Set_Homonym (D, Prev_D); + + -- Handle the case where there is an untagged partial view and + -- the full view is tagged: must disallow discriminants with + -- defaults, unless compiling for Ada 2012, which allows a + -- limited tagged type to have defaulted discriminants (see + -- AI05-0214). However, suppress the error here if it was + -- already reported on the default expression of the partial + -- view. + + if Is_Tagged_Type (T) + and then Present (Expression (Parent (D))) + and then (not Is_Limited_Type (Current_Scope) + or else Ada_Version < Ada_2012) + and then not Error_Posted (Expression (Parent (D))) + then + if Ada_Version >= Ada_2012 then + Error_Msg_N + ("discriminants of nonlimited tagged type cannot have" + & " defaults", + Expression (New_D)); + else + Error_Msg_N + ("discriminants of tagged type cannot have defaults", + Expression (New_D)); + end if; + end if; + + -- Ada 2005 (AI-230): Access discriminant allowed in + -- non-limited record types. + + if Ada_Version < Ada_2005 then + + -- This restriction gets applied to the full type here. It + -- has already been applied earlier to the partial view. + + Check_Access_Discriminant_Requires_Limited (Parent (D), N); + end if; + + Next_Discriminant (D); + Next (New_D); + end loop; + end; + + elsif Present (Discriminant_Specifications (N)) then + Process_Discriminants (N, Prev); + end if; + end Check_Or_Process_Discriminants; + + ---------------------- + -- Check_Real_Bound -- + ---------------------- + + procedure Check_Real_Bound (Bound : Node_Id) is + begin + if not Is_Real_Type (Etype (Bound)) then + Error_Msg_N + ("bound in real type definition must be of real type", Bound); + + elsif not Is_OK_Static_Expression (Bound) then + Flag_Non_Static_Expr + ("non-static expression used for real type bound!", Bound); + + else + return; + end if; + + Rewrite + (Bound, Make_Real_Literal (Sloc (Bound), Ureal_0)); + Analyze (Bound); + Resolve (Bound, Standard_Float); + end Check_Real_Bound; + + ------------------------------ + -- Complete_Private_Subtype -- + ------------------------------ + + procedure Complete_Private_Subtype + (Priv : Entity_Id; + Full : Entity_Id; + Full_Base : Entity_Id; + Related_Nod : Node_Id) + is + Save_Next_Entity : Entity_Id; + Save_Homonym : Entity_Id; + + begin + -- Set semantic attributes for (implicit) private subtype completion. + -- If the full type has no discriminants, then it is a copy of the full + -- view of the base. Otherwise, it is a subtype of the base with a + -- possible discriminant constraint. Save and restore the original + -- Next_Entity field of full to ensure that the calls to Copy_Node + -- do not corrupt the entity chain. + + -- Note that the type of the full view is the same entity as the type of + -- the partial view. In this fashion, the subtype has access to the + -- correct view of the parent. + + Save_Next_Entity := Next_Entity (Full); + Save_Homonym := Homonym (Priv); + + case Ekind (Full_Base) is + when E_Record_Type | + E_Record_Subtype | + Class_Wide_Kind | + Private_Kind | + Task_Kind | + Protected_Kind => + Copy_Node (Priv, Full); + + Set_Has_Discriminants (Full, Has_Discriminants (Full_Base)); + Set_First_Entity (Full, First_Entity (Full_Base)); + Set_Last_Entity (Full, Last_Entity (Full_Base)); + + when others => + Copy_Node (Full_Base, Full); + Set_Chars (Full, Chars (Priv)); + Conditional_Delay (Full, Priv); + Set_Sloc (Full, Sloc (Priv)); + end case; + + Set_Next_Entity (Full, Save_Next_Entity); + Set_Homonym (Full, Save_Homonym); + Set_Associated_Node_For_Itype (Full, Related_Nod); + + -- Set common attributes for all subtypes + + Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base))); + + -- The Etype of the full view is inconsistent. Gigi needs to see the + -- structural full view, which is what the current scheme gives: + -- the Etype of the full view is the etype of the full base. However, + -- if the full base is a derived type, the full view then looks like + -- a subtype of the parent, not a subtype of the full base. If instead + -- we write: + + -- Set_Etype (Full, Full_Base); + + -- then we get inconsistencies in the front-end (confusion between + -- views). Several outstanding bugs are related to this ??? + + Set_Is_First_Subtype (Full, False); + Set_Scope (Full, Scope (Priv)); + Set_Size_Info (Full, Full_Base); + Set_RM_Size (Full, RM_Size (Full_Base)); + Set_Is_Itype (Full); + + -- A subtype of a private-type-without-discriminants, whose full-view + -- has discriminants with default expressions, is not constrained! + + if not Has_Discriminants (Priv) then + Set_Is_Constrained (Full, Is_Constrained (Full_Base)); + + if Has_Discriminants (Full_Base) then + Set_Discriminant_Constraint + (Full, Discriminant_Constraint (Full_Base)); + + -- The partial view may have been indefinite, the full view + -- might not be. + + Set_Has_Unknown_Discriminants + (Full, Has_Unknown_Discriminants (Full_Base)); + end if; + end if; + + Set_First_Rep_Item (Full, First_Rep_Item (Full_Base)); + Set_Depends_On_Private (Full, Has_Private_Component (Full)); + + -- Freeze the private subtype entity if its parent is delayed, and not + -- already frozen. We skip this processing if the type is an anonymous + -- subtype of a record component, or is the corresponding record of a + -- protected type, since ??? + + if not Is_Type (Scope (Full)) then + Set_Has_Delayed_Freeze (Full, + Has_Delayed_Freeze (Full_Base) + and then (not Is_Frozen (Full_Base))); + end if; + + Set_Freeze_Node (Full, Empty); + Set_Is_Frozen (Full, False); + Set_Full_View (Priv, Full); + + if Has_Discriminants (Full) then + Set_Stored_Constraint_From_Discriminant_Constraint (Full); + Set_Stored_Constraint (Priv, Stored_Constraint (Full)); + + if Has_Unknown_Discriminants (Full) then + Set_Discriminant_Constraint (Full, No_Elist); + end if; + end if; + + if Ekind (Full_Base) = E_Record_Type + and then Has_Discriminants (Full_Base) + and then Has_Discriminants (Priv) -- might not, if errors + and then not Has_Unknown_Discriminants (Priv) + and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv)) + then + Create_Constrained_Components + (Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv)); + + -- If the full base is itself derived from private, build a congruent + -- subtype of its underlying type, for use by the back end. For a + -- constrained record component, the declaration cannot be placed on + -- the component list, but it must nevertheless be built an analyzed, to + -- supply enough information for Gigi to compute the size of component. + + elsif Ekind (Full_Base) in Private_Kind + and then Is_Derived_Type (Full_Base) + and then Has_Discriminants (Full_Base) + and then (Ekind (Current_Scope) /= E_Record_Subtype) + then + if not Is_Itype (Priv) + and then + Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication + then + Build_Underlying_Full_View + (Parent (Priv), Full, Etype (Full_Base)); + + elsif Nkind (Related_Nod) = N_Component_Declaration then + Build_Underlying_Full_View (Related_Nod, Full, Etype (Full_Base)); + end if; + + elsif Is_Record_Type (Full_Base) then + + -- Show Full is simply a renaming of Full_Base + + Set_Cloned_Subtype (Full, Full_Base); + end if; + + -- It is unsafe to share to bounds of a scalar type, because the Itype + -- is elaborated on demand, and if a bound is non-static then different + -- orders of elaboration in different units will lead to different + -- external symbols. + + if Is_Scalar_Type (Full_Base) then + Set_Scalar_Range (Full, + Make_Range (Sloc (Related_Nod), + Low_Bound => + Duplicate_Subexpr_No_Checks (Type_Low_Bound (Full_Base)), + High_Bound => + Duplicate_Subexpr_No_Checks (Type_High_Bound (Full_Base)))); + + -- This completion inherits the bounds of the full parent, but if + -- the parent is an unconstrained floating point type, so is the + -- completion. + + if Is_Floating_Point_Type (Full_Base) then + Set_Includes_Infinities + (Scalar_Range (Full), Has_Infinities (Full_Base)); + end if; + end if; + + -- ??? It seems that a lot of fields are missing that should be copied + -- from Full_Base to Full. Here are some that are introduced in a + -- non-disruptive way but a cleanup is necessary. + + if Is_Tagged_Type (Full_Base) then + Set_Is_Tagged_Type (Full); + Set_Direct_Primitive_Operations (Full, + Direct_Primitive_Operations (Full_Base)); + + -- Inherit class_wide type of full_base in case the partial view was + -- not tagged. Otherwise it has already been created when the private + -- subtype was analyzed. + + if No (Class_Wide_Type (Full)) then + Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base)); + end if; + + -- If this is a subtype of a protected or task type, constrain its + -- corresponding record, unless this is a subtype without constraints, + -- i.e. a simple renaming as with an actual subtype in an instance. + + elsif Is_Concurrent_Type (Full_Base) then + if Has_Discriminants (Full) + and then Present (Corresponding_Record_Type (Full_Base)) + and then + not Is_Empty_Elmt_List (Discriminant_Constraint (Full)) + then + Set_Corresponding_Record_Type (Full, + Constrain_Corresponding_Record + (Full, Corresponding_Record_Type (Full_Base), + Related_Nod, Full_Base)); + + else + Set_Corresponding_Record_Type (Full, + Corresponding_Record_Type (Full_Base)); + end if; + end if; + + -- Link rep item chain, and also setting of Has_Predicates from private + -- subtype to full subtype, since we will need these on the full subtype + -- to create the predicate function. Note that the full subtype may + -- already have rep items, inherited from the full view of the base + -- type, so we must be sure not to overwrite these entries. + + declare + Item : Node_Id; + Next_Item : Node_Id; + + begin + Item := First_Rep_Item (Full); + + -- If no existing rep items on full type, we can just link directly + -- to the list of items on the private type. + + if No (Item) then + Set_First_Rep_Item (Full, First_Rep_Item (Priv)); + + -- Else search to end of items currently linked to the full subtype + + else + loop + Next_Item := Next_Rep_Item (Item); + exit when No (Next_Item); + Item := Next_Item; + end loop; + + -- And link the private type items at the end of the chain + + Set_Next_Rep_Item (Item, First_Rep_Item (Priv)); + end if; + end; + + -- Make sure Has_Predicates is set on full type if it is set on the + -- private type. Note that it may already be set on the full type and + -- if so, we don't want to unset it. + + if Has_Predicates (Priv) then + Set_Has_Predicates (Full); + end if; + end Complete_Private_Subtype; + + ---------------------------- + -- Constant_Redeclaration -- + ---------------------------- + + procedure Constant_Redeclaration + (Id : Entity_Id; + N : Node_Id; + T : out Entity_Id) + is + Prev : constant Entity_Id := Current_Entity_In_Scope (Id); + Obj_Def : constant Node_Id := Object_Definition (N); + New_T : Entity_Id; + + procedure Check_Possible_Deferred_Completion + (Prev_Id : Entity_Id; + Prev_Obj_Def : Node_Id; + Curr_Obj_Def : Node_Id); + -- Determine whether the two object definitions describe the partial + -- and the full view of a constrained deferred constant. Generate + -- a subtype for the full view and verify that it statically matches + -- the subtype of the partial view. + + procedure Check_Recursive_Declaration (Typ : Entity_Id); + -- If deferred constant is an access type initialized with an allocator, + -- check whether there is an illegal recursion in the definition, + -- through a default value of some record subcomponent. This is normally + -- detected when generating init procs, but requires this additional + -- mechanism when expansion is disabled. + + ---------------------------------------- + -- Check_Possible_Deferred_Completion -- + ---------------------------------------- + + procedure Check_Possible_Deferred_Completion + (Prev_Id : Entity_Id; + Prev_Obj_Def : Node_Id; + Curr_Obj_Def : Node_Id) + is + begin + if Nkind (Prev_Obj_Def) = N_Subtype_Indication + and then Present (Constraint (Prev_Obj_Def)) + and then Nkind (Curr_Obj_Def) = N_Subtype_Indication + and then Present (Constraint (Curr_Obj_Def)) + then + declare + Loc : constant Source_Ptr := Sloc (N); + Def_Id : constant Entity_Id := Make_Temporary (Loc, 'S'); + Decl : constant Node_Id := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Def_Id, + Subtype_Indication => + Relocate_Node (Curr_Obj_Def)); + + begin + Insert_Before_And_Analyze (N, Decl); + Set_Etype (Id, Def_Id); + + if not Subtypes_Statically_Match (Etype (Prev_Id), Def_Id) then + Error_Msg_Sloc := Sloc (Prev_Id); + Error_Msg_N ("subtype does not statically match deferred " & + "declaration#", N); + end if; + end; + end if; + end Check_Possible_Deferred_Completion; + + --------------------------------- + -- Check_Recursive_Declaration -- + --------------------------------- + + procedure Check_Recursive_Declaration (Typ : Entity_Id) is + Comp : Entity_Id; + + begin + if Is_Record_Type (Typ) then + Comp := First_Component (Typ); + while Present (Comp) loop + if Comes_From_Source (Comp) then + if Present (Expression (Parent (Comp))) + and then Is_Entity_Name (Expression (Parent (Comp))) + and then Entity (Expression (Parent (Comp))) = Prev + then + Error_Msg_Sloc := Sloc (Parent (Comp)); + Error_Msg_NE + ("illegal circularity with declaration for&#", + N, Comp); + return; + + elsif Is_Record_Type (Etype (Comp)) then + Check_Recursive_Declaration (Etype (Comp)); + end if; + end if; + + Next_Component (Comp); + end loop; + end if; + end Check_Recursive_Declaration; + + -- Start of processing for Constant_Redeclaration + + begin + if Nkind (Parent (Prev)) = N_Object_Declaration then + if Nkind (Object_Definition + (Parent (Prev))) = N_Subtype_Indication + then + -- Find type of new declaration. The constraints of the two + -- views must match statically, but there is no point in + -- creating an itype for the full view. + + if Nkind (Obj_Def) = N_Subtype_Indication then + Find_Type (Subtype_Mark (Obj_Def)); + New_T := Entity (Subtype_Mark (Obj_Def)); + + else + Find_Type (Obj_Def); + New_T := Entity (Obj_Def); + end if; + + T := Etype (Prev); + + else + -- The full view may impose a constraint, even if the partial + -- view does not, so construct the subtype. + + New_T := Find_Type_Of_Object (Obj_Def, N); + T := New_T; + end if; + + else + -- Current declaration is illegal, diagnosed below in Enter_Name + + T := Empty; + New_T := Any_Type; + end if; + + -- If previous full declaration or a renaming declaration exists, or if + -- a homograph is present, let Enter_Name handle it, either with an + -- error or with the removal of an overridden implicit subprogram. + + if Ekind (Prev) /= E_Constant + or else Nkind (Parent (Prev)) = N_Object_Renaming_Declaration + or else Present (Expression (Parent (Prev))) + or else Present (Full_View (Prev)) + then + Enter_Name (Id); + + -- Verify that types of both declarations match, or else that both types + -- are anonymous access types whose designated subtypes statically match + -- (as allowed in Ada 2005 by AI-385). + + elsif Base_Type (Etype (Prev)) /= Base_Type (New_T) + and then + (Ekind (Etype (Prev)) /= E_Anonymous_Access_Type + or else Ekind (Etype (New_T)) /= E_Anonymous_Access_Type + or else Is_Access_Constant (Etype (New_T)) /= + Is_Access_Constant (Etype (Prev)) + or else Can_Never_Be_Null (Etype (New_T)) /= + Can_Never_Be_Null (Etype (Prev)) + or else Null_Exclusion_Present (Parent (Prev)) /= + Null_Exclusion_Present (Parent (Id)) + or else not Subtypes_Statically_Match + (Designated_Type (Etype (Prev)), + Designated_Type (Etype (New_T)))) + then + Error_Msg_Sloc := Sloc (Prev); + Error_Msg_N ("type does not match declaration#", N); + Set_Full_View (Prev, Id); + Set_Etype (Id, Any_Type); + + elsif + Null_Exclusion_Present (Parent (Prev)) + and then not Null_Exclusion_Present (N) + then + Error_Msg_Sloc := Sloc (Prev); + Error_Msg_N ("null-exclusion does not match declaration#", N); + Set_Full_View (Prev, Id); + Set_Etype (Id, Any_Type); + + -- If so, process the full constant declaration + + else + -- RM 7.4 (6): If the subtype defined by the subtype_indication in + -- the deferred declaration is constrained, then the subtype defined + -- by the subtype_indication in the full declaration shall match it + -- statically. + + Check_Possible_Deferred_Completion + (Prev_Id => Prev, + Prev_Obj_Def => Object_Definition (Parent (Prev)), + Curr_Obj_Def => Obj_Def); + + Set_Full_View (Prev, Id); + Set_Is_Public (Id, Is_Public (Prev)); + Set_Is_Internal (Id); + Append_Entity (Id, Current_Scope); + + -- Check ALIASED present if present before (RM 7.4(7)) + + if Is_Aliased (Prev) + and then not Aliased_Present (N) + then + Error_Msg_Sloc := Sloc (Prev); + Error_Msg_N ("ALIASED required (see declaration#)", N); + end if; + + -- Check that placement is in private part and that the incomplete + -- declaration appeared in the visible part. + + if Ekind (Current_Scope) = E_Package + and then not In_Private_Part (Current_Scope) + then + Error_Msg_Sloc := Sloc (Prev); + Error_Msg_N + ("full constant for declaration#" + & " must be in private part", N); + + elsif Ekind (Current_Scope) = E_Package + and then + List_Containing (Parent (Prev)) /= + Visible_Declarations + (Specification (Unit_Declaration_Node (Current_Scope))) + then + Error_Msg_N + ("deferred constant must be declared in visible part", + Parent (Prev)); + end if; + + if Is_Access_Type (T) + and then Nkind (Expression (N)) = N_Allocator + then + Check_Recursive_Declaration (Designated_Type (T)); + end if; + end if; + end Constant_Redeclaration; + + ---------------------- + -- Constrain_Access -- + ---------------------- + + procedure Constrain_Access + (Def_Id : in out Entity_Id; + S : Node_Id; + Related_Nod : Node_Id) + is + T : constant Entity_Id := Entity (Subtype_Mark (S)); + Desig_Type : constant Entity_Id := Designated_Type (T); + Desig_Subtype : Entity_Id := Create_Itype (E_Void, Related_Nod); + Constraint_OK : Boolean := True; + + function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean; + -- Simple predicate to test for defaulted discriminants + -- Shouldn't this be in sem_util??? + + --------------------------------- + -- Has_Defaulted_Discriminants -- + --------------------------------- + + function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is + begin + return Has_Discriminants (Typ) + and then Present (First_Discriminant (Typ)) + and then Present + (Discriminant_Default_Value (First_Discriminant (Typ))); + end Has_Defaulted_Discriminants; + + -- Start of processing for Constrain_Access + + begin + if Is_Array_Type (Desig_Type) then + Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P'); + + elsif (Is_Record_Type (Desig_Type) + or else Is_Incomplete_Or_Private_Type (Desig_Type)) + and then not Is_Constrained (Desig_Type) + then + -- ??? The following code is a temporary kludge to ignore a + -- discriminant constraint on access type if it is constraining + -- the current record. Avoid creating the implicit subtype of the + -- record we are currently compiling since right now, we cannot + -- handle these. For now, just return the access type itself. + + if Desig_Type = Current_Scope + and then No (Def_Id) + then + Set_Ekind (Desig_Subtype, E_Record_Subtype); + Def_Id := Entity (Subtype_Mark (S)); + + -- This call added to ensure that the constraint is analyzed + -- (needed for a B test). Note that we still return early from + -- this procedure to avoid recursive processing. ??? + + Constrain_Discriminated_Type + (Desig_Subtype, S, Related_Nod, For_Access => True); + return; + end if; + + if (Ekind (T) = E_General_Access_Type + or else Ada_Version >= Ada_2005) + and then Has_Private_Declaration (Desig_Type) + and then In_Open_Scopes (Scope (Desig_Type)) + and then Has_Discriminants (Desig_Type) + then + -- Enforce rule that the constraint is illegal if there is + -- an unconstrained view of the designated type. This means + -- that the partial view (either a private type declaration or + -- a derivation from a private type) has no discriminants. + -- (Defect Report 8652/0008, Technical Corrigendum 1, checked + -- by ACATS B371001). + + -- Rule updated for Ada 2005: the private type is said to have + -- a constrained partial view, given that objects of the type + -- can be declared. Furthermore, the rule applies to all access + -- types, unlike the rule concerning default discriminants. + + declare + Pack : constant Node_Id := + Unit_Declaration_Node (Scope (Desig_Type)); + Decls : List_Id; + Decl : Node_Id; + + begin + if Nkind (Pack) = N_Package_Declaration then + Decls := Visible_Declarations (Specification (Pack)); + Decl := First (Decls); + while Present (Decl) loop + if (Nkind (Decl) = N_Private_Type_Declaration + and then + Chars (Defining_Identifier (Decl)) = + Chars (Desig_Type)) + + or else + (Nkind (Decl) = N_Full_Type_Declaration + and then + Chars (Defining_Identifier (Decl)) = + Chars (Desig_Type) + and then Is_Derived_Type (Desig_Type) + and then + Has_Private_Declaration (Etype (Desig_Type))) + then + if No (Discriminant_Specifications (Decl)) then + Error_Msg_N + ("cannot constrain general access type if " & + "designated type has constrained partial view", + S); + end if; + + exit; + end if; + + Next (Decl); + end loop; + end if; + end; + end if; + + Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod, + For_Access => True); + + elsif (Is_Task_Type (Desig_Type) + or else Is_Protected_Type (Desig_Type)) + and then not Is_Constrained (Desig_Type) + then + Constrain_Concurrent + (Desig_Subtype, S, Related_Nod, Desig_Type, ' '); + + else + Error_Msg_N ("invalid constraint on access type", S); + Desig_Subtype := Desig_Type; -- Ignore invalid constraint. + Constraint_OK := False; + end if; + + if No (Def_Id) then + Def_Id := Create_Itype (E_Access_Subtype, Related_Nod); + else + Set_Ekind (Def_Id, E_Access_Subtype); + end if; + + if Constraint_OK then + Set_Etype (Def_Id, Base_Type (T)); + + if Is_Private_Type (Desig_Type) then + Prepare_Private_Subtype_Completion (Desig_Subtype, Related_Nod); + end if; + else + Set_Etype (Def_Id, Any_Type); + end if; + + Set_Size_Info (Def_Id, T); + Set_Is_Constrained (Def_Id, Constraint_OK); + Set_Directly_Designated_Type (Def_Id, Desig_Subtype); + Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); + Set_Is_Access_Constant (Def_Id, Is_Access_Constant (T)); + + Conditional_Delay (Def_Id, T); + + -- AI-363 : Subtypes of general access types whose designated types have + -- default discriminants are disallowed. In instances, the rule has to + -- be checked against the actual, of which T is the subtype. In a + -- generic body, the rule is checked assuming that the actual type has + -- defaulted discriminants. + + if Ada_Version >= Ada_2005 or else Warn_On_Ada_2005_Compatibility then + if Ekind (Base_Type (T)) = E_General_Access_Type + and then Has_Defaulted_Discriminants (Desig_Type) + then + if Ada_Version < Ada_2005 then + Error_Msg_N + ("access subtype of general access type would not " & + "be allowed in Ada 2005?", S); + else + Error_Msg_N + ("access subtype of general access type not allowed", S); + end if; + + Error_Msg_N ("\discriminants have defaults", S); + + elsif Is_Access_Type (T) + and then Is_Generic_Type (Desig_Type) + and then Has_Discriminants (Desig_Type) + and then In_Package_Body (Current_Scope) + then + if Ada_Version < Ada_2005 then + Error_Msg_N + ("access subtype would not be allowed in generic body " & + "in Ada 2005?", S); + else + Error_Msg_N + ("access subtype not allowed in generic body", S); + end if; + + Error_Msg_N + ("\designated type is a discriminated formal", S); + end if; + end if; + end Constrain_Access; + + --------------------- + -- Constrain_Array -- + --------------------- + + procedure Constrain_Array + (Def_Id : in out Entity_Id; + SI : Node_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id; + Suffix : Character) + is + C : constant Node_Id := Constraint (SI); + Number_Of_Constraints : Nat := 0; + Index : Node_Id; + S, T : Entity_Id; + Constraint_OK : Boolean := True; + + begin + T := Entity (Subtype_Mark (SI)); + + if Ekind (T) in Access_Kind then + T := Designated_Type (T); + end if; + + -- If an index constraint follows a subtype mark in a subtype indication + -- then the type or subtype denoted by the subtype mark must not already + -- impose an index constraint. The subtype mark must denote either an + -- unconstrained array type or an access type whose designated type + -- is such an array type... (RM 3.6.1) + + if Is_Constrained (T) then + Error_Msg_N ("array type is already constrained", Subtype_Mark (SI)); + Constraint_OK := False; + + else + S := First (Constraints (C)); + while Present (S) loop + Number_Of_Constraints := Number_Of_Constraints + 1; + Next (S); + end loop; + + -- In either case, the index constraint must provide a discrete + -- range for each index of the array type and the type of each + -- discrete range must be the same as that of the corresponding + -- index. (RM 3.6.1) + + if Number_Of_Constraints /= Number_Dimensions (T) then + Error_Msg_NE ("incorrect number of index constraints for }", C, T); + Constraint_OK := False; + + else + S := First (Constraints (C)); + Index := First_Index (T); + Analyze (Index); + + -- Apply constraints to each index type + + for J in 1 .. Number_Of_Constraints loop + Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J); + Next (Index); + Next (S); + end loop; + + end if; + end if; + + if No (Def_Id) then + Def_Id := + Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix); + Set_Parent (Def_Id, Related_Nod); + + else + Set_Ekind (Def_Id, E_Array_Subtype); + end if; + + Set_Size_Info (Def_Id, (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + Set_Etype (Def_Id, Base_Type (T)); + + if Constraint_OK then + Set_First_Index (Def_Id, First (Constraints (C))); + else + Set_First_Index (Def_Id, First_Index (T)); + end if; + + Set_Is_Constrained (Def_Id, True); + Set_Is_Aliased (Def_Id, Is_Aliased (T)); + Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); + + Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T)); + Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T)); + + -- A subtype does not inherit the packed_array_type of is parent. We + -- need to initialize the attribute because if Def_Id is previously + -- analyzed through a limited_with clause, it will have the attributes + -- of an incomplete type, one of which is an Elist that overlaps the + -- Packed_Array_Type field. + + Set_Packed_Array_Type (Def_Id, Empty); + + -- Build a freeze node if parent still needs one. Also make sure that + -- the Depends_On_Private status is set because the subtype will need + -- reprocessing at the time the base type does, and also we must set a + -- conditional delay. + + Set_Depends_On_Private (Def_Id, Depends_On_Private (T)); + Conditional_Delay (Def_Id, T); + end Constrain_Array; + + ------------------------------ + -- Constrain_Component_Type -- + ------------------------------ + + function Constrain_Component_Type + (Comp : Entity_Id; + Constrained_Typ : Entity_Id; + Related_Node : Node_Id; + Typ : Entity_Id; + Constraints : Elist_Id) return Entity_Id + is + Loc : constant Source_Ptr := Sloc (Constrained_Typ); + Compon_Type : constant Entity_Id := Etype (Comp); + + function Build_Constrained_Array_Type + (Old_Type : Entity_Id) return Entity_Id; + -- If Old_Type is an array type, one of whose indexes is constrained + -- by a discriminant, build an Itype whose constraint replaces the + -- discriminant with its value in the constraint. + + function Build_Constrained_Discriminated_Type + (Old_Type : Entity_Id) return Entity_Id; + -- Ditto for record components + + function Build_Constrained_Access_Type + (Old_Type : Entity_Id) return Entity_Id; + -- Ditto for access types. Makes use of previous two functions, to + -- constrain designated type. + + function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id; + -- T is an array or discriminated type, C is a list of constraints + -- that apply to T. This routine builds the constrained subtype. + + function Is_Discriminant (Expr : Node_Id) return Boolean; + -- Returns True if Expr is a discriminant + + function Get_Discr_Value (Discrim : Entity_Id) return Node_Id; + -- Find the value of discriminant Discrim in Constraint + + ----------------------------------- + -- Build_Constrained_Access_Type -- + ----------------------------------- + + function Build_Constrained_Access_Type + (Old_Type : Entity_Id) return Entity_Id + is + Desig_Type : constant Entity_Id := Designated_Type (Old_Type); + Itype : Entity_Id; + Desig_Subtype : Entity_Id; + Scop : Entity_Id; + + begin + -- if the original access type was not embedded in the enclosing + -- type definition, there is no need to produce a new access + -- subtype. In fact every access type with an explicit constraint + -- generates an itype whose scope is the enclosing record. + + if not Is_Type (Scope (Old_Type)) then + return Old_Type; + + elsif Is_Array_Type (Desig_Type) then + Desig_Subtype := Build_Constrained_Array_Type (Desig_Type); + + elsif Has_Discriminants (Desig_Type) then + + -- This may be an access type to an enclosing record type for + -- which we are constructing the constrained components. Return + -- the enclosing record subtype. This is not always correct, + -- but avoids infinite recursion. ??? + + Desig_Subtype := Any_Type; + + for J in reverse 0 .. Scope_Stack.Last loop + Scop := Scope_Stack.Table (J).Entity; + + if Is_Type (Scop) + and then Base_Type (Scop) = Base_Type (Desig_Type) + then + Desig_Subtype := Scop; + end if; + + exit when not Is_Type (Scop); + end loop; + + if Desig_Subtype = Any_Type then + Desig_Subtype := + Build_Constrained_Discriminated_Type (Desig_Type); + end if; + + else + return Old_Type; + end if; + + if Desig_Subtype /= Desig_Type then + + -- The Related_Node better be here or else we won't be able + -- to attach new itypes to a node in the tree. + + pragma Assert (Present (Related_Node)); + + Itype := Create_Itype (E_Access_Subtype, Related_Node); + + Set_Etype (Itype, Base_Type (Old_Type)); + Set_Size_Info (Itype, (Old_Type)); + Set_Directly_Designated_Type (Itype, Desig_Subtype); + Set_Depends_On_Private (Itype, Has_Private_Component + (Old_Type)); + Set_Is_Access_Constant (Itype, Is_Access_Constant + (Old_Type)); + + -- The new itype needs freezing when it depends on a not frozen + -- type and the enclosing subtype needs freezing. + + if Has_Delayed_Freeze (Constrained_Typ) + and then not Is_Frozen (Constrained_Typ) + then + Conditional_Delay (Itype, Base_Type (Old_Type)); + end if; + + return Itype; + + else + return Old_Type; + end if; + end Build_Constrained_Access_Type; + + ---------------------------------- + -- Build_Constrained_Array_Type -- + ---------------------------------- + + function Build_Constrained_Array_Type + (Old_Type : Entity_Id) return Entity_Id + is + Lo_Expr : Node_Id; + Hi_Expr : Node_Id; + Old_Index : Node_Id; + Range_Node : Node_Id; + Constr_List : List_Id; + + Need_To_Create_Itype : Boolean := False; + + begin + Old_Index := First_Index (Old_Type); + while Present (Old_Index) loop + Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr); + + if Is_Discriminant (Lo_Expr) + or else Is_Discriminant (Hi_Expr) + then + Need_To_Create_Itype := True; + end if; + + Next_Index (Old_Index); + end loop; + + if Need_To_Create_Itype then + Constr_List := New_List; + + Old_Index := First_Index (Old_Type); + while Present (Old_Index) loop + Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr); + + if Is_Discriminant (Lo_Expr) then + Lo_Expr := Get_Discr_Value (Lo_Expr); + end if; + + if Is_Discriminant (Hi_Expr) then + Hi_Expr := Get_Discr_Value (Hi_Expr); + end if; + + Range_Node := + Make_Range + (Loc, New_Copy_Tree (Lo_Expr), New_Copy_Tree (Hi_Expr)); + + Append (Range_Node, To => Constr_List); + + Next_Index (Old_Index); + end loop; + + return Build_Subtype (Old_Type, Constr_List); + + else + return Old_Type; + end if; + end Build_Constrained_Array_Type; + + ------------------------------------------ + -- Build_Constrained_Discriminated_Type -- + ------------------------------------------ + + function Build_Constrained_Discriminated_Type + (Old_Type : Entity_Id) return Entity_Id + is + Expr : Node_Id; + Constr_List : List_Id; + Old_Constraint : Elmt_Id; + + Need_To_Create_Itype : Boolean := False; + + begin + Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type)); + while Present (Old_Constraint) loop + Expr := Node (Old_Constraint); + + if Is_Discriminant (Expr) then + Need_To_Create_Itype := True; + end if; + + Next_Elmt (Old_Constraint); + end loop; + + if Need_To_Create_Itype then + Constr_List := New_List; + + Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type)); + while Present (Old_Constraint) loop + Expr := Node (Old_Constraint); + + if Is_Discriminant (Expr) then + Expr := Get_Discr_Value (Expr); + end if; + + Append (New_Copy_Tree (Expr), To => Constr_List); + + Next_Elmt (Old_Constraint); + end loop; + + return Build_Subtype (Old_Type, Constr_List); + + else + return Old_Type; + end if; + end Build_Constrained_Discriminated_Type; + + ------------------- + -- Build_Subtype -- + ------------------- + + function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id is + Indic : Node_Id; + Subtyp_Decl : Node_Id; + Def_Id : Entity_Id; + Btyp : Entity_Id := Base_Type (T); + + begin + -- The Related_Node better be here or else we won't be able to + -- attach new itypes to a node in the tree. + + pragma Assert (Present (Related_Node)); + + -- If the view of the component's type is incomplete or private + -- with unknown discriminants, then the constraint must be applied + -- to the full type. + + if Has_Unknown_Discriminants (Btyp) + and then Present (Underlying_Type (Btyp)) + then + Btyp := Underlying_Type (Btyp); + end if; + + Indic := + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Btyp, Loc), + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C)); + + Def_Id := Create_Itype (Ekind (T), Related_Node); + + Subtyp_Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Def_Id, + Subtype_Indication => Indic); + + Set_Parent (Subtyp_Decl, Parent (Related_Node)); + + -- Itypes must be analyzed with checks off (see package Itypes) + + Analyze (Subtyp_Decl, Suppress => All_Checks); + + return Def_Id; + end Build_Subtype; + + --------------------- + -- Get_Discr_Value -- + --------------------- + + function Get_Discr_Value (Discrim : Entity_Id) return Node_Id is + D : Entity_Id; + E : Elmt_Id; + + begin + -- The discriminant may be declared for the type, in which case we + -- find it by iterating over the list of discriminants. If the + -- discriminant is inherited from a parent type, it appears as the + -- corresponding discriminant of the current type. This will be the + -- case when constraining an inherited component whose constraint is + -- given by a discriminant of the parent. + + D := First_Discriminant (Typ); + E := First_Elmt (Constraints); + + while Present (D) loop + if D = Entity (Discrim) + or else D = CR_Discriminant (Entity (Discrim)) + or else Corresponding_Discriminant (D) = Entity (Discrim) + then + return Node (E); + end if; + + Next_Discriminant (D); + Next_Elmt (E); + end loop; + + -- The Corresponding_Discriminant mechanism is incomplete, because + -- the correspondence between new and old discriminants is not one + -- to one: one new discriminant can constrain several old ones. In + -- that case, scan sequentially the stored_constraint, the list of + -- discriminants of the parents, and the constraints. + -- Previous code checked for the present of the Stored_Constraint + -- list for the derived type, but did not use it at all. Should it + -- be present when the component is a discriminated task type? + + if Is_Derived_Type (Typ) + and then Scope (Entity (Discrim)) = Etype (Typ) + then + D := First_Discriminant (Etype (Typ)); + E := First_Elmt (Constraints); + while Present (D) loop + if D = Entity (Discrim) then + return Node (E); + end if; + + Next_Discriminant (D); + Next_Elmt (E); + end loop; + end if; + + -- Something is wrong if we did not find the value + + raise Program_Error; + end Get_Discr_Value; + + --------------------- + -- Is_Discriminant -- + --------------------- + + function Is_Discriminant (Expr : Node_Id) return Boolean is + Discrim_Scope : Entity_Id; + + begin + if Denotes_Discriminant (Expr) then + Discrim_Scope := Scope (Entity (Expr)); + + -- Either we have a reference to one of Typ's discriminants, + + pragma Assert (Discrim_Scope = Typ + + -- or to the discriminants of the parent type, in the case + -- of a derivation of a tagged type with variants. + + or else Discrim_Scope = Etype (Typ) + or else Full_View (Discrim_Scope) = Etype (Typ) + + -- or same as above for the case where the discriminants + -- were declared in Typ's private view. + + or else (Is_Private_Type (Discrim_Scope) + and then Chars (Discrim_Scope) = Chars (Typ)) + + -- or else we are deriving from the full view and the + -- discriminant is declared in the private entity. + + or else (Is_Private_Type (Typ) + and then Chars (Discrim_Scope) = Chars (Typ)) + + -- Or we are constrained the corresponding record of a + -- synchronized type that completes a private declaration. + + or else (Is_Concurrent_Record_Type (Typ) + and then + Corresponding_Concurrent_Type (Typ) = Discrim_Scope) + + -- or we have a class-wide type, in which case make sure the + -- discriminant found belongs to the root type. + + or else (Is_Class_Wide_Type (Typ) + and then Etype (Typ) = Discrim_Scope)); + + return True; + end if; + + -- In all other cases we have something wrong + + return False; + end Is_Discriminant; + + -- Start of processing for Constrain_Component_Type + + begin + if Nkind (Parent (Comp)) = N_Component_Declaration + and then Comes_From_Source (Parent (Comp)) + and then Comes_From_Source + (Subtype_Indication (Component_Definition (Parent (Comp)))) + and then + Is_Entity_Name + (Subtype_Indication (Component_Definition (Parent (Comp)))) + then + return Compon_Type; + + elsif Is_Array_Type (Compon_Type) then + return Build_Constrained_Array_Type (Compon_Type); + + elsif Has_Discriminants (Compon_Type) then + return Build_Constrained_Discriminated_Type (Compon_Type); + + elsif Is_Access_Type (Compon_Type) then + return Build_Constrained_Access_Type (Compon_Type); + + else + return Compon_Type; + end if; + end Constrain_Component_Type; + + -------------------------- + -- Constrain_Concurrent -- + -------------------------- + + -- For concurrent types, the associated record value type carries the same + -- discriminants, so when we constrain a concurrent type, we must constrain + -- the corresponding record type as well. + + procedure Constrain_Concurrent + (Def_Id : in out Entity_Id; + SI : Node_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id; + Suffix : Character) + is + T_Ent : Entity_Id := Entity (Subtype_Mark (SI)); + T_Val : Entity_Id; + + begin + if Ekind (T_Ent) in Access_Kind then + T_Ent := Designated_Type (T_Ent); + end if; + + T_Val := Corresponding_Record_Type (T_Ent); + + if Present (T_Val) then + + if No (Def_Id) then + Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); + end if; + + Constrain_Discriminated_Type (Def_Id, SI, Related_Nod); + + Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); + Set_Corresponding_Record_Type (Def_Id, + Constrain_Corresponding_Record + (Def_Id, T_Val, Related_Nod, Related_Id)); + + else + -- If there is no associated record, expansion is disabled and this + -- is a generic context. Create a subtype in any case, so that + -- semantic analysis can proceed. + + if No (Def_Id) then + Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); + end if; + + Constrain_Discriminated_Type (Def_Id, SI, Related_Nod); + end if; + end Constrain_Concurrent; + + ------------------------------------ + -- Constrain_Corresponding_Record -- + ------------------------------------ + + function Constrain_Corresponding_Record + (Prot_Subt : Entity_Id; + Corr_Rec : Entity_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id) return Entity_Id + is + T_Sub : constant Entity_Id := + Create_Itype (E_Record_Subtype, Related_Nod, Related_Id, 'V'); + + begin + Set_Etype (T_Sub, Corr_Rec); + Set_Has_Discriminants (T_Sub, Has_Discriminants (Prot_Subt)); + Set_Is_Constrained (T_Sub, True); + Set_First_Entity (T_Sub, First_Entity (Corr_Rec)); + Set_Last_Entity (T_Sub, Last_Entity (Corr_Rec)); + + -- As elsewhere, we do not want to create a freeze node for this itype + -- if it is created for a constrained component of an enclosing record + -- because references to outer discriminants will appear out of scope. + + if Ekind (Scope (Prot_Subt)) /= E_Record_Type then + Conditional_Delay (T_Sub, Corr_Rec); + else + Set_Is_Frozen (T_Sub); + end if; + + if Has_Discriminants (Prot_Subt) then -- False only if errors. + Set_Discriminant_Constraint + (T_Sub, Discriminant_Constraint (Prot_Subt)); + Set_Stored_Constraint_From_Discriminant_Constraint (T_Sub); + Create_Constrained_Components + (T_Sub, Related_Nod, Corr_Rec, Discriminant_Constraint (T_Sub)); + end if; + + Set_Depends_On_Private (T_Sub, Has_Private_Component (T_Sub)); + + return T_Sub; + end Constrain_Corresponding_Record; + + ----------------------- + -- Constrain_Decimal -- + ----------------------- + + procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id) is + T : constant Entity_Id := Entity (Subtype_Mark (S)); + C : constant Node_Id := Constraint (S); + Loc : constant Source_Ptr := Sloc (C); + Range_Expr : Node_Id; + Digits_Expr : Node_Id; + Digits_Val : Uint; + Bound_Val : Ureal; + + begin + Set_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype); + + if Nkind (C) = N_Range_Constraint then + Range_Expr := Range_Expression (C); + Digits_Val := Digits_Value (T); + + else + pragma Assert (Nkind (C) = N_Digits_Constraint); + Digits_Expr := Digits_Expression (C); + Analyze_And_Resolve (Digits_Expr, Any_Integer); + + Check_Digits_Expression (Digits_Expr); + Digits_Val := Expr_Value (Digits_Expr); + + if Digits_Val > Digits_Value (T) then + Error_Msg_N + ("digits expression is incompatible with subtype", C); + Digits_Val := Digits_Value (T); + end if; + + if Present (Range_Constraint (C)) then + Range_Expr := Range_Expression (Range_Constraint (C)); + else + Range_Expr := Empty; + end if; + end if; + + Set_Etype (Def_Id, Base_Type (T)); + Set_Size_Info (Def_Id, (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + Set_Delta_Value (Def_Id, Delta_Value (T)); + Set_Scale_Value (Def_Id, Scale_Value (T)); + Set_Small_Value (Def_Id, Small_Value (T)); + Set_Machine_Radix_10 (Def_Id, Machine_Radix_10 (T)); + Set_Digits_Value (Def_Id, Digits_Val); + + -- Manufacture range from given digits value if no range present + + if No (Range_Expr) then + Bound_Val := (Ureal_10 ** Digits_Val - Ureal_1) * Small_Value (T); + Range_Expr := + Make_Range (Loc, + Low_Bound => + Convert_To (T, Make_Real_Literal (Loc, (-Bound_Val))), + High_Bound => + Convert_To (T, Make_Real_Literal (Loc, Bound_Val))); + end if; + + Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T); + Set_Discrete_RM_Size (Def_Id); + + -- Unconditionally delay the freeze, since we cannot set size + -- information in all cases correctly until the freeze point. + + Set_Has_Delayed_Freeze (Def_Id); + end Constrain_Decimal; + + ---------------------------------- + -- Constrain_Discriminated_Type -- + ---------------------------------- + + procedure Constrain_Discriminated_Type + (Def_Id : Entity_Id; + S : Node_Id; + Related_Nod : Node_Id; + For_Access : Boolean := False) + is + E : constant Entity_Id := Entity (Subtype_Mark (S)); + T : Entity_Id; + C : Node_Id; + Elist : Elist_Id := New_Elmt_List; + + procedure Fixup_Bad_Constraint; + -- This is called after finding a bad constraint, and after having + -- posted an appropriate error message. The mission is to leave the + -- entity T in as reasonable state as possible! + + -------------------------- + -- Fixup_Bad_Constraint -- + -------------------------- + + procedure Fixup_Bad_Constraint is + begin + -- Set a reasonable Ekind for the entity. For an incomplete type, + -- we can't do much, but for other types, we can set the proper + -- corresponding subtype kind. + + if Ekind (T) = E_Incomplete_Type then + Set_Ekind (Def_Id, Ekind (T)); + else + Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); + end if; + + -- Set Etype to the known type, to reduce chances of cascaded errors + + Set_Etype (Def_Id, E); + Set_Error_Posted (Def_Id); + end Fixup_Bad_Constraint; + + -- Start of processing for Constrain_Discriminated_Type + + begin + C := Constraint (S); + + -- A discriminant constraint is only allowed in a subtype indication, + -- after a subtype mark. This subtype mark must denote either a type + -- with discriminants, or an access type whose designated type is a + -- type with discriminants. A discriminant constraint specifies the + -- values of these discriminants (RM 3.7.2(5)). + + T := Base_Type (Entity (Subtype_Mark (S))); + + if Ekind (T) in Access_Kind then + T := Designated_Type (T); + end if; + + -- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal. + -- Avoid generating an error for access-to-incomplete subtypes. + + if Ada_Version >= Ada_2005 + and then Ekind (T) = E_Incomplete_Type + and then Nkind (Parent (S)) = N_Subtype_Declaration + and then not Is_Itype (Def_Id) + then + -- A little sanity check, emit an error message if the type + -- has discriminants to begin with. Type T may be a regular + -- incomplete type or imported via a limited with clause. + + if Has_Discriminants (T) + or else + (From_With_Type (T) + and then Present (Non_Limited_View (T)) + and then Nkind (Parent (Non_Limited_View (T))) = + N_Full_Type_Declaration + and then Present (Discriminant_Specifications + (Parent (Non_Limited_View (T))))) + then + Error_Msg_N + ("(Ada 2005) incomplete subtype may not be constrained", C); + else + Error_Msg_N ("invalid constraint: type has no discriminant", C); + end if; + + Fixup_Bad_Constraint; + return; + + -- Check that the type has visible discriminants. The type may be + -- a private type with unknown discriminants whose full view has + -- discriminants which are invisible. + + elsif not Has_Discriminants (T) + or else + (Has_Unknown_Discriminants (T) + and then Is_Private_Type (T)) + then + Error_Msg_N ("invalid constraint: type has no discriminant", C); + Fixup_Bad_Constraint; + return; + + elsif Is_Constrained (E) + or else (Ekind (E) = E_Class_Wide_Subtype + and then Present (Discriminant_Constraint (E))) + then + Error_Msg_N ("type is already constrained", Subtype_Mark (S)); + Fixup_Bad_Constraint; + return; + end if; + + -- T may be an unconstrained subtype (e.g. a generic actual). + -- Constraint applies to the base type. + + T := Base_Type (T); + + Elist := Build_Discriminant_Constraints (T, S); + + -- If the list returned was empty we had an error in building the + -- discriminant constraint. We have also already signalled an error + -- in the incomplete type case + + if Is_Empty_Elmt_List (Elist) then + Fixup_Bad_Constraint; + return; + end if; + + Build_Discriminated_Subtype (T, Def_Id, Elist, Related_Nod, For_Access); + end Constrain_Discriminated_Type; + + --------------------------- + -- Constrain_Enumeration -- + --------------------------- + + procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id) is + T : constant Entity_Id := Entity (Subtype_Mark (S)); + C : constant Node_Id := Constraint (S); + + begin + Set_Ekind (Def_Id, E_Enumeration_Subtype); + + Set_First_Literal (Def_Id, First_Literal (Base_Type (T))); + + Set_Etype (Def_Id, Base_Type (T)); + Set_Size_Info (Def_Id, (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); + + Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); + + Set_Discrete_RM_Size (Def_Id); + end Constrain_Enumeration; + + ---------------------- + -- Constrain_Float -- + ---------------------- + + procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id) is + T : constant Entity_Id := Entity (Subtype_Mark (S)); + C : Node_Id; + D : Node_Id; + Rais : Node_Id; + + begin + Set_Ekind (Def_Id, E_Floating_Point_Subtype); + + Set_Etype (Def_Id, Base_Type (T)); + Set_Size_Info (Def_Id, (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + + -- Process the constraint + + C := Constraint (S); + + -- Digits constraint present + + if Nkind (C) = N_Digits_Constraint then + Check_Restriction (No_Obsolescent_Features, C); + + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("subtype digits constraint is an " & + "obsolescent feature (RM J.3(8))?", C); + end if; + + D := Digits_Expression (C); + Analyze_And_Resolve (D, Any_Integer); + Check_Digits_Expression (D); + Set_Digits_Value (Def_Id, Expr_Value (D)); + + -- Check that digits value is in range. Obviously we can do this + -- at compile time, but it is strictly a runtime check, and of + -- course there is an ACVC test that checks this! + + if Digits_Value (Def_Id) > Digits_Value (T) then + Error_Msg_Uint_1 := Digits_Value (T); + Error_Msg_N ("?digits value is too large, maximum is ^", D); + Rais := + Make_Raise_Constraint_Error (Sloc (D), + Reason => CE_Range_Check_Failed); + Insert_Action (Declaration_Node (Def_Id), Rais); + end if; + + C := Range_Constraint (C); + + -- No digits constraint present + + else + Set_Digits_Value (Def_Id, Digits_Value (T)); + end if; + + -- Range constraint present + + if Nkind (C) = N_Range_Constraint then + Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); + + -- No range constraint present + + else + pragma Assert (No (C)); + Set_Scalar_Range (Def_Id, Scalar_Range (T)); + end if; + + Set_Is_Constrained (Def_Id); + end Constrain_Float; + + --------------------- + -- Constrain_Index -- + --------------------- + + procedure Constrain_Index + (Index : Node_Id; + S : Node_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id; + Suffix : Character; + Suffix_Index : Nat) + is + Def_Id : Entity_Id; + R : Node_Id := Empty; + T : constant Entity_Id := Etype (Index); + + begin + if Nkind (S) = N_Range + or else + (Nkind (S) = N_Attribute_Reference + and then Attribute_Name (S) = Name_Range) + then + -- A Range attribute will transformed into N_Range by Resolve + + Analyze (S); + Set_Etype (S, T); + R := S; + + Process_Range_Expr_In_Decl (R, T, Empty_List); + + if not Error_Posted (S) + and then + (Nkind (S) /= N_Range + or else not Covers (T, (Etype (Low_Bound (S)))) + or else not Covers (T, (Etype (High_Bound (S))))) + then + if Base_Type (T) /= Any_Type + and then Etype (Low_Bound (S)) /= Any_Type + and then Etype (High_Bound (S)) /= Any_Type + then + Error_Msg_N ("range expected", S); + end if; + end if; + + elsif Nkind (S) = N_Subtype_Indication then + + -- The parser has verified that this is a discrete indication + + Resolve_Discrete_Subtype_Indication (S, T); + R := Range_Expression (Constraint (S)); + + elsif Nkind (S) = N_Discriminant_Association then + + -- Syntactically valid in subtype indication + + Error_Msg_N ("invalid index constraint", S); + Rewrite (S, New_Occurrence_Of (T, Sloc (S))); + return; + + -- Subtype_Mark case, no anonymous subtypes to construct + + else + Analyze (S); + + if Is_Entity_Name (S) then + if not Is_Type (Entity (S)) then + Error_Msg_N ("expect subtype mark for index constraint", S); + + elsif Base_Type (Entity (S)) /= Base_Type (T) then + Wrong_Type (S, Base_Type (T)); + + -- Check error of subtype with predicate in index constraint + + else + Bad_Predicated_Subtype_Use + ("subtype& has predicate, not allowed in index constraint", + S, Entity (S)); + end if; + + return; + + else + Error_Msg_N ("invalid index constraint", S); + Rewrite (S, New_Occurrence_Of (T, Sloc (S))); + return; + end if; + end if; + + Def_Id := + Create_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index); + + Set_Etype (Def_Id, Base_Type (T)); + + if Is_Modular_Integer_Type (T) then + Set_Ekind (Def_Id, E_Modular_Integer_Subtype); + + elsif Is_Integer_Type (T) then + Set_Ekind (Def_Id, E_Signed_Integer_Subtype); + + else + Set_Ekind (Def_Id, E_Enumeration_Subtype); + Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); + Set_First_Literal (Def_Id, First_Literal (T)); + end if; + + Set_Size_Info (Def_Id, (T)); + Set_RM_Size (Def_Id, RM_Size (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + + Set_Scalar_Range (Def_Id, R); + + Set_Etype (S, Def_Id); + Set_Discrete_RM_Size (Def_Id); + end Constrain_Index; + + ----------------------- + -- Constrain_Integer -- + ----------------------- + + procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id) is + T : constant Entity_Id := Entity (Subtype_Mark (S)); + C : constant Node_Id := Constraint (S); + + begin + Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); + + if Is_Modular_Integer_Type (T) then + Set_Ekind (Def_Id, E_Modular_Integer_Subtype); + else + Set_Ekind (Def_Id, E_Signed_Integer_Subtype); + end if; + + Set_Etype (Def_Id, Base_Type (T)); + Set_Size_Info (Def_Id, (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + Set_Discrete_RM_Size (Def_Id); + end Constrain_Integer; + + ------------------------------ + -- Constrain_Ordinary_Fixed -- + ------------------------------ + + procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id) is + T : constant Entity_Id := Entity (Subtype_Mark (S)); + C : Node_Id; + D : Node_Id; + Rais : Node_Id; + + begin + Set_Ekind (Def_Id, E_Ordinary_Fixed_Point_Subtype); + Set_Etype (Def_Id, Base_Type (T)); + Set_Size_Info (Def_Id, (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + Set_Small_Value (Def_Id, Small_Value (T)); + + -- Process the constraint + + C := Constraint (S); + + -- Delta constraint present + + if Nkind (C) = N_Delta_Constraint then + Check_Restriction (No_Obsolescent_Features, C); + + if Warn_On_Obsolescent_Feature then + Error_Msg_S + ("subtype delta constraint is an " & + "obsolescent feature (RM J.3(7))?"); + end if; + + D := Delta_Expression (C); + Analyze_And_Resolve (D, Any_Real); + Check_Delta_Expression (D); + Set_Delta_Value (Def_Id, Expr_Value_R (D)); + + -- Check that delta value is in range. Obviously we can do this + -- at compile time, but it is strictly a runtime check, and of + -- course there is an ACVC test that checks this! + + if Delta_Value (Def_Id) < Delta_Value (T) then + Error_Msg_N ("?delta value is too small", D); + Rais := + Make_Raise_Constraint_Error (Sloc (D), + Reason => CE_Range_Check_Failed); + Insert_Action (Declaration_Node (Def_Id), Rais); + end if; + + C := Range_Constraint (C); + + -- No delta constraint present + + else + Set_Delta_Value (Def_Id, Delta_Value (T)); + end if; + + -- Range constraint present + + if Nkind (C) = N_Range_Constraint then + Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); + + -- No range constraint present + + else + pragma Assert (No (C)); + Set_Scalar_Range (Def_Id, Scalar_Range (T)); + + end if; + + Set_Discrete_RM_Size (Def_Id); + + -- Unconditionally delay the freeze, since we cannot set size + -- information in all cases correctly until the freeze point. + + Set_Has_Delayed_Freeze (Def_Id); + end Constrain_Ordinary_Fixed; + + ----------------------- + -- Contain_Interface -- + ----------------------- + + function Contain_Interface + (Iface : Entity_Id; + Ifaces : Elist_Id) return Boolean + is + Iface_Elmt : Elmt_Id; + + begin + if Present (Ifaces) then + Iface_Elmt := First_Elmt (Ifaces); + while Present (Iface_Elmt) loop + if Node (Iface_Elmt) = Iface then + return True; + end if; + + Next_Elmt (Iface_Elmt); + end loop; + end if; + + return False; + end Contain_Interface; + + --------------------------- + -- Convert_Scalar_Bounds -- + --------------------------- + + procedure Convert_Scalar_Bounds + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id; + Loc : Source_Ptr) + is + Implicit_Base : constant Entity_Id := Base_Type (Derived_Type); + + Lo : Node_Id; + Hi : Node_Id; + Rng : Node_Id; + + begin + -- Defend against previous errors + + if No (Scalar_Range (Derived_Type)) then + return; + end if; + + Lo := Build_Scalar_Bound + (Type_Low_Bound (Derived_Type), + Parent_Type, Implicit_Base); + + Hi := Build_Scalar_Bound + (Type_High_Bound (Derived_Type), + Parent_Type, Implicit_Base); + + Rng := + Make_Range (Loc, + Low_Bound => Lo, + High_Bound => Hi); + + Set_Includes_Infinities (Rng, Has_Infinities (Derived_Type)); + + Set_Parent (Rng, N); + Set_Scalar_Range (Derived_Type, Rng); + + -- Analyze the bounds + + Analyze_And_Resolve (Lo, Implicit_Base); + Analyze_And_Resolve (Hi, Implicit_Base); + + -- Analyze the range itself, except that we do not analyze it if + -- the bounds are real literals, and we have a fixed-point type. + -- The reason for this is that we delay setting the bounds in this + -- case till we know the final Small and Size values (see circuit + -- in Freeze.Freeze_Fixed_Point_Type for further details). + + if Is_Fixed_Point_Type (Parent_Type) + and then Nkind (Lo) = N_Real_Literal + and then Nkind (Hi) = N_Real_Literal + then + return; + + -- Here we do the analysis of the range + + -- Note: we do this manually, since if we do a normal Analyze and + -- Resolve call, there are problems with the conversions used for + -- the derived type range. + + else + Set_Etype (Rng, Implicit_Base); + Set_Analyzed (Rng, True); + end if; + end Convert_Scalar_Bounds; + + ------------------- + -- Copy_And_Swap -- + ------------------- + + procedure Copy_And_Swap (Priv, Full : Entity_Id) is + begin + -- Initialize new full declaration entity by copying the pertinent + -- fields of the corresponding private declaration entity. + + -- We temporarily set Ekind to a value appropriate for a type to + -- avoid assert failures in Einfo from checking for setting type + -- attributes on something that is not a type. Ekind (Priv) is an + -- appropriate choice, since it allowed the attributes to be set + -- in the first place. This Ekind value will be modified later. + + Set_Ekind (Full, Ekind (Priv)); + + -- Also set Etype temporarily to Any_Type, again, in the absence + -- of errors, it will be properly reset, and if there are errors, + -- then we want a value of Any_Type to remain. + + Set_Etype (Full, Any_Type); + + -- Now start copying attributes + + Set_Has_Discriminants (Full, Has_Discriminants (Priv)); + + if Has_Discriminants (Full) then + Set_Discriminant_Constraint (Full, Discriminant_Constraint (Priv)); + Set_Stored_Constraint (Full, Stored_Constraint (Priv)); + end if; + + Set_First_Rep_Item (Full, First_Rep_Item (Priv)); + Set_Homonym (Full, Homonym (Priv)); + Set_Is_Immediately_Visible (Full, Is_Immediately_Visible (Priv)); + Set_Is_Public (Full, Is_Public (Priv)); + Set_Is_Pure (Full, Is_Pure (Priv)); + Set_Is_Tagged_Type (Full, Is_Tagged_Type (Priv)); + Set_Has_Pragma_Unmodified (Full, Has_Pragma_Unmodified (Priv)); + Set_Has_Pragma_Unreferenced (Full, Has_Pragma_Unreferenced (Priv)); + Set_Has_Pragma_Unreferenced_Objects + (Full, Has_Pragma_Unreferenced_Objects + (Priv)); + + Conditional_Delay (Full, Priv); + + if Is_Tagged_Type (Full) then + Set_Direct_Primitive_Operations (Full, + Direct_Primitive_Operations (Priv)); + + if Is_Base_Type (Priv) then + Set_Class_Wide_Type (Full, Class_Wide_Type (Priv)); + end if; + end if; + + Set_Is_Volatile (Full, Is_Volatile (Priv)); + Set_Treat_As_Volatile (Full, Treat_As_Volatile (Priv)); + Set_Scope (Full, Scope (Priv)); + Set_Next_Entity (Full, Next_Entity (Priv)); + Set_First_Entity (Full, First_Entity (Priv)); + Set_Last_Entity (Full, Last_Entity (Priv)); + + -- If access types have been recorded for later handling, keep them in + -- the full view so that they get handled when the full view freeze + -- node is expanded. + + if Present (Freeze_Node (Priv)) + and then Present (Access_Types_To_Process (Freeze_Node (Priv))) + then + Ensure_Freeze_Node (Full); + Set_Access_Types_To_Process + (Freeze_Node (Full), + Access_Types_To_Process (Freeze_Node (Priv))); + end if; + + -- Swap the two entities. Now Private is the full type entity and Full + -- is the private one. They will be swapped back at the end of the + -- private part. This swapping ensures that the entity that is visible + -- in the private part is the full declaration. + + Exchange_Entities (Priv, Full); + Append_Entity (Full, Scope (Full)); + end Copy_And_Swap; + + ------------------------------------- + -- Copy_Array_Base_Type_Attributes -- + ------------------------------------- + + procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id) is + begin + Set_Component_Alignment (T1, Component_Alignment (T2)); + Set_Component_Type (T1, Component_Type (T2)); + Set_Component_Size (T1, Component_Size (T2)); + Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2)); + Set_Finalize_Storage_Only (T1, Finalize_Storage_Only (T2)); + Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2)); + Set_Has_Task (T1, Has_Task (T2)); + Set_Is_Packed (T1, Is_Packed (T2)); + Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2)); + Set_Has_Atomic_Components (T1, Has_Atomic_Components (T2)); + Set_Has_Volatile_Components (T1, Has_Volatile_Components (T2)); + end Copy_Array_Base_Type_Attributes; + + ----------------------------------- + -- Copy_Array_Subtype_Attributes -- + ----------------------------------- + + procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id) is + begin + Set_Size_Info (T1, T2); + + Set_First_Index (T1, First_Index (T2)); + Set_Is_Aliased (T1, Is_Aliased (T2)); + Set_Is_Atomic (T1, Is_Atomic (T2)); + Set_Is_Volatile (T1, Is_Volatile (T2)); + Set_Treat_As_Volatile (T1, Treat_As_Volatile (T2)); + Set_Is_Constrained (T1, Is_Constrained (T2)); + Set_Depends_On_Private (T1, Has_Private_Component (T2)); + Set_First_Rep_Item (T1, First_Rep_Item (T2)); + Set_Convention (T1, Convention (T2)); + Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2)); + Set_Is_Private_Composite (T1, Is_Private_Composite (T2)); + Set_Packed_Array_Type (T1, Packed_Array_Type (T2)); + end Copy_Array_Subtype_Attributes; + + ----------------------------------- + -- Create_Constrained_Components -- + ----------------------------------- + + procedure Create_Constrained_Components + (Subt : Entity_Id; + Decl_Node : Node_Id; + Typ : Entity_Id; + Constraints : Elist_Id) + is + Loc : constant Source_Ptr := Sloc (Subt); + Comp_List : constant Elist_Id := New_Elmt_List; + Parent_Type : constant Entity_Id := Etype (Typ); + Assoc_List : constant List_Id := New_List; + Discr_Val : Elmt_Id; + Errors : Boolean; + New_C : Entity_Id; + Old_C : Entity_Id; + Is_Static : Boolean := True; + + procedure Collect_Fixed_Components (Typ : Entity_Id); + -- Collect parent type components that do not appear in a variant part + + procedure Create_All_Components; + -- Iterate over Comp_List to create the components of the subtype + + function Create_Component (Old_Compon : Entity_Id) return Entity_Id; + -- Creates a new component from Old_Compon, copying all the fields from + -- it, including its Etype, inserts the new component in the Subt entity + -- chain and returns the new component. + + function Is_Variant_Record (T : Entity_Id) return Boolean; + -- If true, and discriminants are static, collect only components from + -- variants selected by discriminant values. + + ------------------------------ + -- Collect_Fixed_Components -- + ------------------------------ + + procedure Collect_Fixed_Components (Typ : Entity_Id) is + begin + -- Build association list for discriminants, and find components of the + -- variant part selected by the values of the discriminants. + + Old_C := First_Discriminant (Typ); + Discr_Val := First_Elmt (Constraints); + while Present (Old_C) loop + Append_To (Assoc_List, + Make_Component_Association (Loc, + Choices => New_List (New_Occurrence_Of (Old_C, Loc)), + Expression => New_Copy (Node (Discr_Val)))); + + Next_Elmt (Discr_Val); + Next_Discriminant (Old_C); + end loop; + + -- The tag, and the possible parent and controller components + -- are unconditionally in the subtype. + + if Is_Tagged_Type (Typ) + or else Has_Controlled_Component (Typ) + then + Old_C := First_Component (Typ); + while Present (Old_C) loop + if Chars ((Old_C)) = Name_uTag + or else Chars ((Old_C)) = Name_uParent + or else Chars ((Old_C)) = Name_uController + then + Append_Elmt (Old_C, Comp_List); + end if; + + Next_Component (Old_C); + end loop; + end if; + end Collect_Fixed_Components; + + --------------------------- + -- Create_All_Components -- + --------------------------- + + procedure Create_All_Components is + Comp : Elmt_Id; + + begin + Comp := First_Elmt (Comp_List); + while Present (Comp) loop + Old_C := Node (Comp); + New_C := Create_Component (Old_C); + + Set_Etype + (New_C, + Constrain_Component_Type + (Old_C, Subt, Decl_Node, Typ, Constraints)); + Set_Is_Public (New_C, Is_Public (Subt)); + + Next_Elmt (Comp); + end loop; + end Create_All_Components; + + ---------------------- + -- Create_Component -- + ---------------------- + + function Create_Component (Old_Compon : Entity_Id) return Entity_Id is + New_Compon : constant Entity_Id := New_Copy (Old_Compon); + + begin + if Ekind (Old_Compon) = E_Discriminant + and then Is_Completely_Hidden (Old_Compon) + then + -- This is a shadow discriminant created for a discriminant of + -- the parent type, which needs to be present in the subtype. + -- Give the shadow discriminant an internal name that cannot + -- conflict with that of visible components. + + Set_Chars (New_Compon, New_Internal_Name ('C')); + end if; + + -- Set the parent so we have a proper link for freezing etc. This is + -- not a real parent pointer, since of course our parent does not own + -- up to us and reference us, we are an illegitimate child of the + -- original parent! + + Set_Parent (New_Compon, Parent (Old_Compon)); + + -- If the old component's Esize was already determined and is a + -- static value, then the new component simply inherits it. Otherwise + -- the old component's size may require run-time determination, but + -- the new component's size still might be statically determinable + -- (if, for example it has a static constraint). In that case we want + -- Layout_Type to recompute the component's size, so we reset its + -- size and positional fields. + + if Frontend_Layout_On_Target + and then not Known_Static_Esize (Old_Compon) + then + Set_Esize (New_Compon, Uint_0); + Init_Normalized_First_Bit (New_Compon); + Init_Normalized_Position (New_Compon); + Init_Normalized_Position_Max (New_Compon); + end if; + + -- We do not want this node marked as Comes_From_Source, since + -- otherwise it would get first class status and a separate cross- + -- reference line would be generated. Illegitimate children do not + -- rate such recognition. + + Set_Comes_From_Source (New_Compon, False); + + -- But it is a real entity, and a birth certificate must be properly + -- registered by entering it into the entity list. + + Enter_Name (New_Compon); + + return New_Compon; + end Create_Component; + + ----------------------- + -- Is_Variant_Record -- + ----------------------- + + function Is_Variant_Record (T : Entity_Id) return Boolean is + begin + return Nkind (Parent (T)) = N_Full_Type_Declaration + and then Nkind (Type_Definition (Parent (T))) = N_Record_Definition + and then Present (Component_List (Type_Definition (Parent (T)))) + and then + Present + (Variant_Part (Component_List (Type_Definition (Parent (T))))); + end Is_Variant_Record; + + -- Start of processing for Create_Constrained_Components + + begin + pragma Assert (Subt /= Base_Type (Subt)); + pragma Assert (Typ = Base_Type (Typ)); + + Set_First_Entity (Subt, Empty); + Set_Last_Entity (Subt, Empty); + + -- Check whether constraint is fully static, in which case we can + -- optimize the list of components. + + Discr_Val := First_Elmt (Constraints); + while Present (Discr_Val) loop + if not Is_OK_Static_Expression (Node (Discr_Val)) then + Is_Static := False; + exit; + end if; + + Next_Elmt (Discr_Val); + end loop; + + Set_Has_Static_Discriminants (Subt, Is_Static); + + Push_Scope (Subt); + + -- Inherit the discriminants of the parent type + + Add_Discriminants : declare + Num_Disc : Int; + Num_Gird : Int; + + begin + Num_Disc := 0; + Old_C := First_Discriminant (Typ); + + while Present (Old_C) loop + Num_Disc := Num_Disc + 1; + New_C := Create_Component (Old_C); + Set_Is_Public (New_C, Is_Public (Subt)); + Next_Discriminant (Old_C); + end loop; + + -- For an untagged derived subtype, the number of discriminants may + -- be smaller than the number of inherited discriminants, because + -- several of them may be renamed by a single new discriminant or + -- constrained. In this case, add the hidden discriminants back into + -- the subtype, because they need to be present if the optimizer of + -- the GCC 4.x back-end decides to break apart assignments between + -- objects using the parent view into member-wise assignments. + + Num_Gird := 0; + + if Is_Derived_Type (Typ) + and then not Is_Tagged_Type (Typ) + then + Old_C := First_Stored_Discriminant (Typ); + + while Present (Old_C) loop + Num_Gird := Num_Gird + 1; + Next_Stored_Discriminant (Old_C); + end loop; + end if; + + if Num_Gird > Num_Disc then + + -- Find out multiple uses of new discriminants, and add hidden + -- components for the extra renamed discriminants. We recognize + -- multiple uses through the Corresponding_Discriminant of a + -- new discriminant: if it constrains several old discriminants, + -- this field points to the last one in the parent type. The + -- stored discriminants of the derived type have the same name + -- as those of the parent. + + declare + Constr : Elmt_Id; + New_Discr : Entity_Id; + Old_Discr : Entity_Id; + + begin + Constr := First_Elmt (Stored_Constraint (Typ)); + Old_Discr := First_Stored_Discriminant (Typ); + while Present (Constr) loop + if Is_Entity_Name (Node (Constr)) + and then Ekind (Entity (Node (Constr))) = E_Discriminant + then + New_Discr := Entity (Node (Constr)); + + if Chars (Corresponding_Discriminant (New_Discr)) /= + Chars (Old_Discr) + then + -- The new discriminant has been used to rename a + -- subsequent old discriminant. Introduce a shadow + -- component for the current old discriminant. + + New_C := Create_Component (Old_Discr); + Set_Original_Record_Component (New_C, Old_Discr); + end if; + + else + -- The constraint has eliminated the old discriminant. + -- Introduce a shadow component. + + New_C := Create_Component (Old_Discr); + Set_Original_Record_Component (New_C, Old_Discr); + end if; + + Next_Elmt (Constr); + Next_Stored_Discriminant (Old_Discr); + end loop; + end; + end if; + end Add_Discriminants; + + if Is_Static + and then Is_Variant_Record (Typ) + then + Collect_Fixed_Components (Typ); + + Gather_Components ( + Typ, + Component_List (Type_Definition (Parent (Typ))), + Governed_By => Assoc_List, + Into => Comp_List, + Report_Errors => Errors); + pragma Assert (not Errors); + + Create_All_Components; + + -- If the subtype declaration is created for a tagged type derivation + -- with constraints, we retrieve the record definition of the parent + -- type to select the components of the proper variant. + + elsif Is_Static + and then Is_Tagged_Type (Typ) + and then Nkind (Parent (Typ)) = N_Full_Type_Declaration + and then + Nkind (Type_Definition (Parent (Typ))) = N_Derived_Type_Definition + and then Is_Variant_Record (Parent_Type) + then + Collect_Fixed_Components (Typ); + + Gather_Components ( + Typ, + Component_List (Type_Definition (Parent (Parent_Type))), + Governed_By => Assoc_List, + Into => Comp_List, + Report_Errors => Errors); + pragma Assert (not Errors); + + -- If the tagged derivation has a type extension, collect all the + -- new components therein. + + if Present + (Record_Extension_Part (Type_Definition (Parent (Typ)))) + then + Old_C := First_Component (Typ); + while Present (Old_C) loop + if Original_Record_Component (Old_C) = Old_C + and then Chars (Old_C) /= Name_uTag + and then Chars (Old_C) /= Name_uParent + and then Chars (Old_C) /= Name_uController + then + Append_Elmt (Old_C, Comp_List); + end if; + + Next_Component (Old_C); + end loop; + end if; + + Create_All_Components; + + else + -- If discriminants are not static, or if this is a multi-level type + -- extension, we have to include all components of the parent type. + + Old_C := First_Component (Typ); + while Present (Old_C) loop + New_C := Create_Component (Old_C); + + Set_Etype + (New_C, + Constrain_Component_Type + (Old_C, Subt, Decl_Node, Typ, Constraints)); + Set_Is_Public (New_C, Is_Public (Subt)); + + Next_Component (Old_C); + end loop; + end if; + + End_Scope; + end Create_Constrained_Components; + + ------------------------------------------ + -- Decimal_Fixed_Point_Type_Declaration -- + ------------------------------------------ + + procedure Decimal_Fixed_Point_Type_Declaration + (T : Entity_Id; + Def : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Def); + Digs_Expr : constant Node_Id := Digits_Expression (Def); + Delta_Expr : constant Node_Id := Delta_Expression (Def); + Implicit_Base : Entity_Id; + Digs_Val : Uint; + Delta_Val : Ureal; + Scale_Val : Uint; + Bound_Val : Ureal; + + begin + Check_Restriction (No_Fixed_Point, Def); + + -- Create implicit base type + + Implicit_Base := + Create_Itype (E_Decimal_Fixed_Point_Type, Parent (Def), T, 'B'); + Set_Etype (Implicit_Base, Implicit_Base); + + -- Analyze and process delta expression + + Analyze_And_Resolve (Delta_Expr, Universal_Real); + + Check_Delta_Expression (Delta_Expr); + Delta_Val := Expr_Value_R (Delta_Expr); + + -- Check delta is power of 10, and determine scale value from it + + declare + Val : Ureal; + + begin + Scale_Val := Uint_0; + Val := Delta_Val; + + if Val < Ureal_1 then + while Val < Ureal_1 loop + Val := Val * Ureal_10; + Scale_Val := Scale_Val + 1; + end loop; + + if Scale_Val > 18 then + Error_Msg_N ("scale exceeds maximum value of 18", Def); + Scale_Val := UI_From_Int (+18); + end if; + + else + while Val > Ureal_1 loop + Val := Val / Ureal_10; + Scale_Val := Scale_Val - 1; + end loop; + + if Scale_Val < -18 then + Error_Msg_N ("scale is less than minimum value of -18", Def); + Scale_Val := UI_From_Int (-18); + end if; + end if; + + if Val /= Ureal_1 then + Error_Msg_N ("delta expression must be a power of 10", Def); + Delta_Val := Ureal_10 ** (-Scale_Val); + end if; + end; + + -- Set delta, scale and small (small = delta for decimal type) + + Set_Delta_Value (Implicit_Base, Delta_Val); + Set_Scale_Value (Implicit_Base, Scale_Val); + Set_Small_Value (Implicit_Base, Delta_Val); + + -- Analyze and process digits expression + + Analyze_And_Resolve (Digs_Expr, Any_Integer); + Check_Digits_Expression (Digs_Expr); + Digs_Val := Expr_Value (Digs_Expr); + + if Digs_Val > 18 then + Digs_Val := UI_From_Int (+18); + Error_Msg_N ("digits value out of range, maximum is 18", Digs_Expr); + end if; + + Set_Digits_Value (Implicit_Base, Digs_Val); + Bound_Val := UR_From_Uint (10 ** Digs_Val - 1) * Delta_Val; + + -- Set range of base type from digits value for now. This will be + -- expanded to represent the true underlying base range by Freeze. + + Set_Fixed_Range (Implicit_Base, Loc, -Bound_Val, Bound_Val); + + -- Note: We leave size as zero for now, size will be set at freeze + -- time. We have to do this for ordinary fixed-point, because the size + -- depends on the specified small, and we might as well do the same for + -- decimal fixed-point. + + pragma Assert (Esize (Implicit_Base) = Uint_0); + + -- If there are bounds given in the declaration use them as the + -- bounds of the first named subtype. + + if Present (Real_Range_Specification (Def)) then + declare + RRS : constant Node_Id := Real_Range_Specification (Def); + Low : constant Node_Id := Low_Bound (RRS); + High : constant Node_Id := High_Bound (RRS); + Low_Val : Ureal; + High_Val : Ureal; + + begin + Analyze_And_Resolve (Low, Any_Real); + Analyze_And_Resolve (High, Any_Real); + Check_Real_Bound (Low); + Check_Real_Bound (High); + Low_Val := Expr_Value_R (Low); + High_Val := Expr_Value_R (High); + + if Low_Val < (-Bound_Val) then + Error_Msg_N + ("range low bound too small for digits value", Low); + Low_Val := -Bound_Val; + end if; + + if High_Val > Bound_Val then + Error_Msg_N + ("range high bound too large for digits value", High); + High_Val := Bound_Val; + end if; + + Set_Fixed_Range (T, Loc, Low_Val, High_Val); + end; + + -- If no explicit range, use range that corresponds to given + -- digits value. This will end up as the final range for the + -- first subtype. + + else + Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val); + end if; + + -- Complete entity for first subtype + + Set_Ekind (T, E_Decimal_Fixed_Point_Subtype); + Set_Etype (T, Implicit_Base); + Set_Size_Info (T, Implicit_Base); + Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); + Set_Digits_Value (T, Digs_Val); + Set_Delta_Value (T, Delta_Val); + Set_Small_Value (T, Delta_Val); + Set_Scale_Value (T, Scale_Val); + Set_Is_Constrained (T); + end Decimal_Fixed_Point_Type_Declaration; + + ----------------------------------- + -- Derive_Progenitor_Subprograms -- + ----------------------------------- + + procedure Derive_Progenitor_Subprograms + (Parent_Type : Entity_Id; + Tagged_Type : Entity_Id) + is + E : Entity_Id; + Elmt : Elmt_Id; + Iface : Entity_Id; + Iface_Elmt : Elmt_Id; + Iface_Subp : Entity_Id; + New_Subp : Entity_Id := Empty; + Prim_Elmt : Elmt_Id; + Subp : Entity_Id; + Typ : Entity_Id; + + begin + pragma Assert (Ada_Version >= Ada_2005 + and then Is_Record_Type (Tagged_Type) + and then Is_Tagged_Type (Tagged_Type) + and then Has_Interfaces (Tagged_Type)); + + -- Step 1: Transfer to the full-view primitives associated with the + -- partial-view that cover interface primitives. Conceptually this + -- work should be done later by Process_Full_View; done here to + -- simplify its implementation at later stages. It can be safely + -- done here because interfaces must be visible in the partial and + -- private view (RM 7.3(7.3/2)). + + -- Small optimization: This work is only required if the parent is + -- abstract. If the tagged type is not abstract, it cannot have + -- abstract primitives (the only entities in the list of primitives of + -- non-abstract tagged types that can reference abstract primitives + -- through its Alias attribute are the internal entities that have + -- attribute Interface_Alias, and these entities are generated later + -- by Add_Internal_Interface_Entities). + + if In_Private_Part (Current_Scope) + and then Is_Abstract_Type (Parent_Type) + then + Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); + while Present (Elmt) loop + Subp := Node (Elmt); + + -- At this stage it is not possible to have entities in the list + -- of primitives that have attribute Interface_Alias + + pragma Assert (No (Interface_Alias (Subp))); + + Typ := Find_Dispatching_Type (Ultimate_Alias (Subp)); + + if Is_Interface (Typ) then + E := Find_Primitive_Covering_Interface + (Tagged_Type => Tagged_Type, + Iface_Prim => Subp); + + if Present (E) + and then Find_Dispatching_Type (Ultimate_Alias (E)) /= Typ + then + Replace_Elmt (Elmt, E); + Remove_Homonym (Subp); + end if; + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + -- Step 2: Add primitives of progenitors that are not implemented by + -- parents of Tagged_Type + + if Present (Interfaces (Base_Type (Tagged_Type))) then + Iface_Elmt := First_Elmt (Interfaces (Base_Type (Tagged_Type))); + while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); + + Prim_Elmt := First_Elmt (Primitive_Operations (Iface)); + while Present (Prim_Elmt) loop + Iface_Subp := Node (Prim_Elmt); + + -- Exclude derivation of predefined primitives except those + -- that come from source. Required to catch declarations of + -- equality operators of interfaces. For example: + + -- type Iface is interface; + -- function "=" (Left, Right : Iface) return Boolean; + + if not Is_Predefined_Dispatching_Operation (Iface_Subp) + or else Comes_From_Source (Iface_Subp) + then + E := Find_Primitive_Covering_Interface + (Tagged_Type => Tagged_Type, + Iface_Prim => Iface_Subp); + + -- If not found we derive a new primitive leaving its alias + -- attribute referencing the interface primitive + + if No (E) then + Derive_Subprogram + (New_Subp, Iface_Subp, Tagged_Type, Iface); + + -- Ada 2012 (AI05-0197): If the covering primitive's name + -- differs from the name of the interface primitive then it + -- is a private primitive inherited from a parent type. In + -- such case, given that Tagged_Type covers the interface, + -- the inherited private primitive becomes visible. For such + -- purpose we add a new entity that renames the inherited + -- private primitive. + + elsif Chars (E) /= Chars (Iface_Subp) then + pragma Assert (Has_Suffix (E, 'P')); + Derive_Subprogram + (New_Subp, Iface_Subp, Tagged_Type, Iface); + Set_Alias (New_Subp, E); + Set_Is_Abstract_Subprogram (New_Subp, + Is_Abstract_Subprogram (E)); + + -- Propagate to the full view interface entities associated + -- with the partial view + + elsif In_Private_Part (Current_Scope) + and then Present (Alias (E)) + and then Alias (E) = Iface_Subp + and then + List_Containing (Parent (E)) /= + Private_Declarations + (Specification + (Unit_Declaration_Node (Current_Scope))) + then + Append_Elmt (E, Primitive_Operations (Tagged_Type)); + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + Next_Elmt (Iface_Elmt); + end loop; + end if; + end Derive_Progenitor_Subprograms; + + ----------------------- + -- Derive_Subprogram -- + ----------------------- + + procedure Derive_Subprogram + (New_Subp : in out Entity_Id; + Parent_Subp : Entity_Id; + Derived_Type : Entity_Id; + Parent_Type : Entity_Id; + Actual_Subp : Entity_Id := Empty) + is + Formal : Entity_Id; + -- Formal parameter of parent primitive operation + + Formal_Of_Actual : Entity_Id; + -- Formal parameter of actual operation, when the derivation is to + -- create a renaming for a primitive operation of an actual in an + -- instantiation. + + New_Formal : Entity_Id; + -- Formal of inherited operation + + Visible_Subp : Entity_Id := Parent_Subp; + + function Is_Private_Overriding return Boolean; + -- If Subp is a private overriding of a visible operation, the inherited + -- operation derives from the overridden op (even though its body is the + -- overriding one) and the inherited operation is visible now. See + -- sem_disp to see the full details of the handling of the overridden + -- subprogram, which is removed from the list of primitive operations of + -- the type. The overridden subprogram is saved locally in Visible_Subp, + -- and used to diagnose abstract operations that need overriding in the + -- derived type. + + procedure Replace_Type (Id, New_Id : Entity_Id); + -- When the type is an anonymous access type, create a new access type + -- designating the derived type. + + procedure Set_Derived_Name; + -- This procedure sets the appropriate Chars name for New_Subp. This + -- is normally just a copy of the parent name. An exception arises for + -- type support subprograms, where the name is changed to reflect the + -- name of the derived type, e.g. if type foo is derived from type bar, + -- then a procedure barDA is derived with a name fooDA. + + --------------------------- + -- Is_Private_Overriding -- + --------------------------- + + function Is_Private_Overriding return Boolean is + Prev : Entity_Id; + + begin + -- If the parent is not a dispatching operation there is no + -- need to investigate overridings + + if not Is_Dispatching_Operation (Parent_Subp) then + return False; + end if; + + -- The visible operation that is overridden is a homonym of the + -- parent subprogram. We scan the homonym chain to find the one + -- whose alias is the subprogram we are deriving. + + Prev := Current_Entity (Parent_Subp); + while Present (Prev) loop + if Ekind (Prev) = Ekind (Parent_Subp) + and then Alias (Prev) = Parent_Subp + and then Scope (Parent_Subp) = Scope (Prev) + and then not Is_Hidden (Prev) + then + Visible_Subp := Prev; + return True; + end if; + + Prev := Homonym (Prev); + end loop; + + return False; + end Is_Private_Overriding; + + ------------------ + -- Replace_Type -- + ------------------ + + procedure Replace_Type (Id, New_Id : Entity_Id) is + Acc_Type : Entity_Id; + Par : constant Node_Id := Parent (Derived_Type); + + begin + -- When the type is an anonymous access type, create a new access + -- type designating the derived type. This itype must be elaborated + -- at the point of the derivation, not on subsequent calls that may + -- be out of the proper scope for Gigi, so we insert a reference to + -- it after the derivation. + + if Ekind (Etype (Id)) = E_Anonymous_Access_Type then + declare + Desig_Typ : Entity_Id := Designated_Type (Etype (Id)); + + begin + if Ekind (Desig_Typ) = E_Record_Type_With_Private + and then Present (Full_View (Desig_Typ)) + and then not Is_Private_Type (Parent_Type) + then + Desig_Typ := Full_View (Desig_Typ); + end if; + + if Base_Type (Desig_Typ) = Base_Type (Parent_Type) + + -- Ada 2005 (AI-251): Handle also derivations of abstract + -- interface primitives. + + or else (Is_Interface (Desig_Typ) + and then not Is_Class_Wide_Type (Desig_Typ)) + then + Acc_Type := New_Copy (Etype (Id)); + Set_Etype (Acc_Type, Acc_Type); + Set_Scope (Acc_Type, New_Subp); + + -- Compute size of anonymous access type + + if Is_Array_Type (Desig_Typ) + and then not Is_Constrained (Desig_Typ) + then + Init_Size (Acc_Type, 2 * System_Address_Size); + else + Init_Size (Acc_Type, System_Address_Size); + end if; + + Init_Alignment (Acc_Type); + Set_Directly_Designated_Type (Acc_Type, Derived_Type); + + Set_Etype (New_Id, Acc_Type); + Set_Scope (New_Id, New_Subp); + + -- Create a reference to it + Build_Itype_Reference (Acc_Type, Parent (Derived_Type)); + + else + Set_Etype (New_Id, Etype (Id)); + end if; + end; + + elsif Base_Type (Etype (Id)) = Base_Type (Parent_Type) + or else + (Ekind (Etype (Id)) = E_Record_Type_With_Private + and then Present (Full_View (Etype (Id))) + and then + Base_Type (Full_View (Etype (Id))) = Base_Type (Parent_Type)) + then + -- Constraint checks on formals are generated during expansion, + -- based on the signature of the original subprogram. The bounds + -- of the derived type are not relevant, and thus we can use + -- the base type for the formals. However, the return type may be + -- used in a context that requires that the proper static bounds + -- be used (a case statement, for example) and for those cases + -- we must use the derived type (first subtype), not its base. + + -- If the derived_type_definition has no constraints, we know that + -- the derived type has the same constraints as the first subtype + -- of the parent, and we can also use it rather than its base, + -- which can lead to more efficient code. + + if Etype (Id) = Parent_Type then + if Is_Scalar_Type (Parent_Type) + and then + Subtypes_Statically_Compatible (Parent_Type, Derived_Type) + then + Set_Etype (New_Id, Derived_Type); + + elsif Nkind (Par) = N_Full_Type_Declaration + and then + Nkind (Type_Definition (Par)) = N_Derived_Type_Definition + and then + Is_Entity_Name + (Subtype_Indication (Type_Definition (Par))) + then + Set_Etype (New_Id, Derived_Type); + + else + Set_Etype (New_Id, Base_Type (Derived_Type)); + end if; + + else + Set_Etype (New_Id, Base_Type (Derived_Type)); + end if; + + else + Set_Etype (New_Id, Etype (Id)); + end if; + end Replace_Type; + + ---------------------- + -- Set_Derived_Name -- + ---------------------- + + procedure Set_Derived_Name is + Nm : constant TSS_Name_Type := Get_TSS_Name (Parent_Subp); + begin + if Nm = TSS_Null then + Set_Chars (New_Subp, Chars (Parent_Subp)); + else + Set_Chars (New_Subp, Make_TSS_Name (Base_Type (Derived_Type), Nm)); + end if; + end Set_Derived_Name; + + -- Start of processing for Derive_Subprogram + + begin + New_Subp := + New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type)); + Set_Ekind (New_Subp, Ekind (Parent_Subp)); + + -- Check whether the inherited subprogram is a private operation that + -- should be inherited but not yet made visible. Such subprograms can + -- become visible at a later point (e.g., the private part of a public + -- child unit) via Declare_Inherited_Private_Subprograms. If the + -- following predicate is true, then this is not such a private + -- operation and the subprogram simply inherits the name of the parent + -- subprogram. Note the special check for the names of controlled + -- operations, which are currently exempted from being inherited with + -- a hidden name because they must be findable for generation of + -- implicit run-time calls. + + if not Is_Hidden (Parent_Subp) + or else Is_Internal (Parent_Subp) + or else Is_Private_Overriding + or else Is_Internal_Name (Chars (Parent_Subp)) + or else Chars (Parent_Subp) = Name_Initialize + or else Chars (Parent_Subp) = Name_Adjust + or else Chars (Parent_Subp) = Name_Finalize + then + Set_Derived_Name; + + -- An inherited dispatching equality will be overridden by an internally + -- generated one, or by an explicit one, so preserve its name and thus + -- its entry in the dispatch table. Otherwise, if Parent_Subp is a + -- private operation it may become invisible if the full view has + -- progenitors, and the dispatch table will be malformed. + -- We check that the type is limited to handle the anomalous declaration + -- of Limited_Controlled, which is derived from a non-limited type, and + -- which is handled specially elsewhere as well. + + elsif Chars (Parent_Subp) = Name_Op_Eq + and then Is_Dispatching_Operation (Parent_Subp) + and then Etype (Parent_Subp) = Standard_Boolean + and then not Is_Limited_Type (Etype (First_Formal (Parent_Subp))) + and then + Etype (First_Formal (Parent_Subp)) = + Etype (Next_Formal (First_Formal (Parent_Subp))) + then + Set_Derived_Name; + + -- If parent is hidden, this can be a regular derivation if the + -- parent is immediately visible in a non-instantiating context, + -- or if we are in the private part of an instance. This test + -- should still be refined ??? + + -- The test for In_Instance_Not_Visible avoids inheriting the derived + -- operation as a non-visible operation in cases where the parent + -- subprogram might not be visible now, but was visible within the + -- original generic, so it would be wrong to make the inherited + -- subprogram non-visible now. (Not clear if this test is fully + -- correct; are there any cases where we should declare the inherited + -- operation as not visible to avoid it being overridden, e.g., when + -- the parent type is a generic actual with private primitives ???) + + -- (they should be treated the same as other private inherited + -- subprograms, but it's not clear how to do this cleanly). ??? + + elsif (In_Open_Scopes (Scope (Base_Type (Parent_Type))) + and then Is_Immediately_Visible (Parent_Subp) + and then not In_Instance) + or else In_Instance_Not_Visible + then + Set_Derived_Name; + + -- Ada 2005 (AI-251): Regular derivation if the parent subprogram + -- overrides an interface primitive because interface primitives + -- must be visible in the partial view of the parent (RM 7.3 (7.3/2)) + + elsif Ada_Version >= Ada_2005 + and then Is_Dispatching_Operation (Parent_Subp) + and then Covers_Some_Interface (Parent_Subp) + then + Set_Derived_Name; + + -- Otherwise, the type is inheriting a private operation, so enter + -- it with a special name so it can't be overridden. + + else + Set_Chars (New_Subp, New_External_Name (Chars (Parent_Subp), 'P')); + end if; + + Set_Parent (New_Subp, Parent (Derived_Type)); + + if Present (Actual_Subp) then + Replace_Type (Actual_Subp, New_Subp); + else + Replace_Type (Parent_Subp, New_Subp); + end if; + + Conditional_Delay (New_Subp, Parent_Subp); + + -- If we are creating a renaming for a primitive operation of an + -- actual of a generic derived type, we must examine the signature + -- of the actual primitive, not that of the generic formal, which for + -- example may be an interface. However the name and initial value + -- of the inherited operation are those of the formal primitive. + + Formal := First_Formal (Parent_Subp); + + if Present (Actual_Subp) then + Formal_Of_Actual := First_Formal (Actual_Subp); + else + Formal_Of_Actual := Empty; + end if; + + while Present (Formal) loop + New_Formal := New_Copy (Formal); + + -- Normally we do not go copying parents, but in the case of + -- formals, we need to link up to the declaration (which is the + -- parameter specification), and it is fine to link up to the + -- original formal's parameter specification in this case. + + Set_Parent (New_Formal, Parent (Formal)); + Append_Entity (New_Formal, New_Subp); + + if Present (Formal_Of_Actual) then + Replace_Type (Formal_Of_Actual, New_Formal); + Next_Formal (Formal_Of_Actual); + else + Replace_Type (Formal, New_Formal); + end if; + + Next_Formal (Formal); + end loop; + + -- If this derivation corresponds to a tagged generic actual, then + -- primitive operations rename those of the actual. Otherwise the + -- primitive operations rename those of the parent type, If the parent + -- renames an intrinsic operator, so does the new subprogram. We except + -- concatenation, which is always properly typed, and does not get + -- expanded as other intrinsic operations. + + if No (Actual_Subp) then + if Is_Intrinsic_Subprogram (Parent_Subp) then + Set_Is_Intrinsic_Subprogram (New_Subp); + + if Present (Alias (Parent_Subp)) + and then Chars (Parent_Subp) /= Name_Op_Concat + then + Set_Alias (New_Subp, Alias (Parent_Subp)); + else + Set_Alias (New_Subp, Parent_Subp); + end if; + + else + Set_Alias (New_Subp, Parent_Subp); + end if; + + else + Set_Alias (New_Subp, Actual_Subp); + end if; + + -- Derived subprograms of a tagged type must inherit the convention + -- of the parent subprogram (a requirement of AI-117). Derived + -- subprograms of untagged types simply get convention Ada by default. + + if Is_Tagged_Type (Derived_Type) then + Set_Convention (New_Subp, Convention (Parent_Subp)); + end if; + + -- Predefined controlled operations retain their name even if the parent + -- is hidden (see above), but they are not primitive operations if the + -- ancestor is not visible, for example if the parent is a private + -- extension completed with a controlled extension. Note that a full + -- type that is controlled can break privacy: the flag Is_Controlled is + -- set on both views of the type. + + if Is_Controlled (Parent_Type) + and then + (Chars (Parent_Subp) = Name_Initialize + or else Chars (Parent_Subp) = Name_Adjust + or else Chars (Parent_Subp) = Name_Finalize) + and then Is_Hidden (Parent_Subp) + and then not Is_Visibly_Controlled (Parent_Type) + then + Set_Is_Hidden (New_Subp); + end if; + + Set_Is_Imported (New_Subp, Is_Imported (Parent_Subp)); + Set_Is_Exported (New_Subp, Is_Exported (Parent_Subp)); + + if Ekind (Parent_Subp) = E_Procedure then + Set_Is_Valued_Procedure + (New_Subp, Is_Valued_Procedure (Parent_Subp)); + else + Set_Has_Controlling_Result + (New_Subp, Has_Controlling_Result (Parent_Subp)); + end if; + + -- No_Return must be inherited properly. If this is overridden in the + -- case of a dispatching operation, then a check is made in Sem_Disp + -- that the overriding operation is also No_Return (no such check is + -- required for the case of non-dispatching operation. + + Set_No_Return (New_Subp, No_Return (Parent_Subp)); + + -- A derived function with a controlling result is abstract. If the + -- Derived_Type is a nonabstract formal generic derived type, then + -- inherited operations are not abstract: the required check is done at + -- instantiation time. If the derivation is for a generic actual, the + -- function is not abstract unless the actual is. + + if Is_Generic_Type (Derived_Type) + and then not Is_Abstract_Type (Derived_Type) + then + null; + + -- Ada 2005 (AI-228): Calculate the "require overriding" and "abstract" + -- properties of the subprogram, as defined in RM-3.9.3(4/2-6/2). + + elsif Ada_Version >= Ada_2005 + and then (Is_Abstract_Subprogram (Alias (New_Subp)) + or else (Is_Tagged_Type (Derived_Type) + and then Etype (New_Subp) = Derived_Type + and then not Is_Null_Extension (Derived_Type)) + or else (Is_Tagged_Type (Derived_Type) + and then Ekind (Etype (New_Subp)) = + E_Anonymous_Access_Type + and then Designated_Type (Etype (New_Subp)) = + Derived_Type + and then not Is_Null_Extension (Derived_Type))) + and then No (Actual_Subp) + then + if not Is_Tagged_Type (Derived_Type) + or else Is_Abstract_Type (Derived_Type) + or else Is_Abstract_Subprogram (Alias (New_Subp)) + then + Set_Is_Abstract_Subprogram (New_Subp); + else + Set_Requires_Overriding (New_Subp); + end if; + + elsif Ada_Version < Ada_2005 + and then (Is_Abstract_Subprogram (Alias (New_Subp)) + or else (Is_Tagged_Type (Derived_Type) + and then Etype (New_Subp) = Derived_Type + and then No (Actual_Subp))) + then + Set_Is_Abstract_Subprogram (New_Subp); + + -- AI05-0097 : an inherited operation that dispatches on result is + -- abstract if the derived type is abstract, even if the parent type + -- is concrete and the derived type is a null extension. + + elsif Has_Controlling_Result (Alias (New_Subp)) + and then Is_Abstract_Type (Etype (New_Subp)) + then + Set_Is_Abstract_Subprogram (New_Subp); + + -- Finally, if the parent type is abstract we must verify that all + -- inherited operations are either non-abstract or overridden, or that + -- the derived type itself is abstract (this check is performed at the + -- end of a package declaration, in Check_Abstract_Overriding). A + -- private overriding in the parent type will not be visible in the + -- derivation if we are not in an inner package or in a child unit of + -- the parent type, in which case the abstractness of the inherited + -- operation is carried to the new subprogram. + + elsif Is_Abstract_Type (Parent_Type) + and then not In_Open_Scopes (Scope (Parent_Type)) + and then Is_Private_Overriding + and then Is_Abstract_Subprogram (Visible_Subp) + then + if No (Actual_Subp) then + Set_Alias (New_Subp, Visible_Subp); + Set_Is_Abstract_Subprogram (New_Subp, True); + + else + -- If this is a derivation for an instance of a formal derived + -- type, abstractness comes from the primitive operation of the + -- actual, not from the operation inherited from the ancestor. + + Set_Is_Abstract_Subprogram + (New_Subp, Is_Abstract_Subprogram (Actual_Subp)); + end if; + end if; + + New_Overloaded_Entity (New_Subp, Derived_Type); + + -- Check for case of a derived subprogram for the instantiation of a + -- formal derived tagged type, if so mark the subprogram as dispatching + -- and inherit the dispatching attributes of the parent subprogram. The + -- derived subprogram is effectively renaming of the actual subprogram, + -- so it needs to have the same attributes as the actual. + + if Present (Actual_Subp) + and then Is_Dispatching_Operation (Parent_Subp) + then + Set_Is_Dispatching_Operation (New_Subp); + + if Present (DTC_Entity (Parent_Subp)) then + Set_DTC_Entity (New_Subp, DTC_Entity (Parent_Subp)); + Set_DT_Position (New_Subp, DT_Position (Parent_Subp)); + end if; + end if; + + -- Indicate that a derived subprogram does not require a body and that + -- it does not require processing of default expressions. + + Set_Has_Completion (New_Subp); + Set_Default_Expressions_Processed (New_Subp); + + if Ekind (New_Subp) = E_Function then + Set_Mechanism (New_Subp, Mechanism (Parent_Subp)); + end if; + end Derive_Subprogram; + + ------------------------ + -- Derive_Subprograms -- + ------------------------ + + procedure Derive_Subprograms + (Parent_Type : Entity_Id; + Derived_Type : Entity_Id; + Generic_Actual : Entity_Id := Empty) + is + Op_List : constant Elist_Id := + Collect_Primitive_Operations (Parent_Type); + + function Check_Derived_Type return Boolean; + -- Check that all the entities derived from Parent_Type are found in + -- the list of primitives of Derived_Type exactly in the same order. + + procedure Derive_Interface_Subprogram + (New_Subp : in out Entity_Id; + Subp : Entity_Id; + Actual_Subp : Entity_Id); + -- Derive New_Subp from the ultimate alias of the parent subprogram Subp + -- (which is an interface primitive). If Generic_Actual is present then + -- Actual_Subp is the actual subprogram corresponding with the generic + -- subprogram Subp. + + function Check_Derived_Type return Boolean is + E : Entity_Id; + Elmt : Elmt_Id; + List : Elist_Id; + New_Subp : Entity_Id; + Op_Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + -- Traverse list of entities in the current scope searching for + -- an incomplete type whose full-view is derived type + + E := First_Entity (Scope (Derived_Type)); + while Present (E) + and then E /= Derived_Type + loop + if Ekind (E) = E_Incomplete_Type + and then Present (Full_View (E)) + and then Full_View (E) = Derived_Type + then + -- Disable this test if Derived_Type completes an incomplete + -- type because in such case more primitives can be added + -- later to the list of primitives of Derived_Type by routine + -- Process_Incomplete_Dependents + + return True; + end if; + + E := Next_Entity (E); + end loop; + + List := Collect_Primitive_Operations (Derived_Type); + Elmt := First_Elmt (List); + + Op_Elmt := First_Elmt (Op_List); + while Present (Op_Elmt) loop + Subp := Node (Op_Elmt); + New_Subp := Node (Elmt); + + -- At this early stage Derived_Type has no entities with attribute + -- Interface_Alias. In addition, such primitives are always + -- located at the end of the list of primitives of Parent_Type. + -- Therefore, if found we can safely stop processing pending + -- entities. + + exit when Present (Interface_Alias (Subp)); + + -- Handle hidden entities + + if not Is_Predefined_Dispatching_Operation (Subp) + and then Is_Hidden (Subp) + then + if Present (New_Subp) + and then Primitive_Names_Match (Subp, New_Subp) + then + Next_Elmt (Elmt); + end if; + + else + if not Present (New_Subp) + or else Ekind (Subp) /= Ekind (New_Subp) + or else not Primitive_Names_Match (Subp, New_Subp) + then + return False; + end if; + + Next_Elmt (Elmt); + end if; + + Next_Elmt (Op_Elmt); + end loop; + + return True; + end Check_Derived_Type; + + --------------------------------- + -- Derive_Interface_Subprogram -- + --------------------------------- + + procedure Derive_Interface_Subprogram + (New_Subp : in out Entity_Id; + Subp : Entity_Id; + Actual_Subp : Entity_Id) + is + Iface_Subp : constant Entity_Id := Ultimate_Alias (Subp); + Iface_Type : constant Entity_Id := Find_Dispatching_Type (Iface_Subp); + + begin + pragma Assert (Is_Interface (Iface_Type)); + + Derive_Subprogram + (New_Subp => New_Subp, + Parent_Subp => Iface_Subp, + Derived_Type => Derived_Type, + Parent_Type => Iface_Type, + Actual_Subp => Actual_Subp); + + -- Given that this new interface entity corresponds with a primitive + -- of the parent that was not overridden we must leave it associated + -- with its parent primitive to ensure that it will share the same + -- dispatch table slot when overridden. + + if No (Actual_Subp) then + Set_Alias (New_Subp, Subp); + + -- For instantiations this is not needed since the previous call to + -- Derive_Subprogram leaves the entity well decorated. + + else + pragma Assert (Alias (New_Subp) = Actual_Subp); + null; + end if; + end Derive_Interface_Subprogram; + + -- Local variables + + Alias_Subp : Entity_Id; + Act_List : Elist_Id; + Act_Elmt : Elmt_Id := No_Elmt; + Act_Subp : Entity_Id := Empty; + Elmt : Elmt_Id; + Need_Search : Boolean := False; + New_Subp : Entity_Id := Empty; + Parent_Base : Entity_Id; + Subp : Entity_Id; + + -- Start of processing for Derive_Subprograms + + begin + if Ekind (Parent_Type) = E_Record_Type_With_Private + and then Has_Discriminants (Parent_Type) + and then Present (Full_View (Parent_Type)) + then + Parent_Base := Full_View (Parent_Type); + else + Parent_Base := Parent_Type; + end if; + + if Present (Generic_Actual) then + Act_List := Collect_Primitive_Operations (Generic_Actual); + Act_Elmt := First_Elmt (Act_List); + end if; + + -- Derive primitives inherited from the parent. Note that if the generic + -- actual is present, this is not really a type derivation, it is a + -- completion within an instance. + + -- Case 1: Derived_Type does not implement interfaces + + if not Is_Tagged_Type (Derived_Type) + or else (not Has_Interfaces (Derived_Type) + and then not (Present (Generic_Actual) + and then + Has_Interfaces (Generic_Actual))) + then + Elmt := First_Elmt (Op_List); + while Present (Elmt) loop + Subp := Node (Elmt); + + -- Literals are derived earlier in the process of building the + -- derived type, and are skipped here. + + if Ekind (Subp) = E_Enumeration_Literal then + null; + + -- The actual is a direct descendant and the common primitive + -- operations appear in the same order. + + -- If the generic parent type is present, the derived type is an + -- instance of a formal derived type, and within the instance its + -- operations are those of the actual. We derive from the formal + -- type but make the inherited operations aliases of the + -- corresponding operations of the actual. + + else + pragma Assert (No (Node (Act_Elmt)) + or else (Primitive_Names_Match (Subp, Node (Act_Elmt)) + and then + Type_Conformant (Subp, Node (Act_Elmt), + Skip_Controlling_Formals => True))); + + Derive_Subprogram + (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt)); + + if Present (Act_Elmt) then + Next_Elmt (Act_Elmt); + end if; + end if; + + Next_Elmt (Elmt); + end loop; + + -- Case 2: Derived_Type implements interfaces + + else + -- If the parent type has no predefined primitives we remove + -- predefined primitives from the list of primitives of generic + -- actual to simplify the complexity of this algorithm. + + if Present (Generic_Actual) then + declare + Has_Predefined_Primitives : Boolean := False; + + begin + -- Check if the parent type has predefined primitives + + Elmt := First_Elmt (Op_List); + while Present (Elmt) loop + Subp := Node (Elmt); + + if Is_Predefined_Dispatching_Operation (Subp) + and then not Comes_From_Source (Ultimate_Alias (Subp)) + then + Has_Predefined_Primitives := True; + exit; + end if; + + Next_Elmt (Elmt); + end loop; + + -- Remove predefined primitives of Generic_Actual. We must use + -- an auxiliary list because in case of tagged types the value + -- returned by Collect_Primitive_Operations is the value stored + -- in its Primitive_Operations attribute (and we don't want to + -- modify its current contents). + + if not Has_Predefined_Primitives then + declare + Aux_List : constant Elist_Id := New_Elmt_List; + + begin + Elmt := First_Elmt (Act_List); + while Present (Elmt) loop + Subp := Node (Elmt); + + if not Is_Predefined_Dispatching_Operation (Subp) + or else Comes_From_Source (Subp) + then + Append_Elmt (Subp, Aux_List); + end if; + + Next_Elmt (Elmt); + end loop; + + Act_List := Aux_List; + end; + end if; + + Act_Elmt := First_Elmt (Act_List); + Act_Subp := Node (Act_Elmt); + end; + end if; + + -- Stage 1: If the generic actual is not present we derive the + -- primitives inherited from the parent type. If the generic parent + -- type is present, the derived type is an instance of a formal + -- derived type, and within the instance its operations are those of + -- the actual. We derive from the formal type but make the inherited + -- operations aliases of the corresponding operations of the actual. + + Elmt := First_Elmt (Op_List); + while Present (Elmt) loop + Subp := Node (Elmt); + Alias_Subp := Ultimate_Alias (Subp); + + -- Do not derive internal entities of the parent that link + -- interface primitives with their covering primitive. These + -- entities will be added to this type when frozen. + + if Present (Interface_Alias (Subp)) then + goto Continue; + end if; + + -- If the generic actual is present find the corresponding + -- operation in the generic actual. If the parent type is a + -- direct ancestor of the derived type then, even if it is an + -- interface, the operations are inherited from the primary + -- dispatch table and are in the proper order. If we detect here + -- that primitives are not in the same order we traverse the list + -- of primitive operations of the actual to find the one that + -- implements the interface primitive. + + if Need_Search + or else + (Present (Generic_Actual) + and then Present (Act_Subp) + and then not + (Primitive_Names_Match (Subp, Act_Subp) + and then + Type_Conformant (Subp, Act_Subp, + Skip_Controlling_Formals => True))) + then + pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual)); + + -- Remember that we need searching for all pending primitives + + Need_Search := True; + + -- Handle entities associated with interface primitives + + if Present (Alias_Subp) + and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) + and then not Is_Predefined_Dispatching_Operation (Subp) + then + -- Search for the primitive in the homonym chain + + Act_Subp := + Find_Primitive_Covering_Interface + (Tagged_Type => Generic_Actual, + Iface_Prim => Alias_Subp); + + -- Previous search may not locate primitives covering + -- interfaces defined in generics units or instantiations. + -- (it fails if the covering primitive has formals whose + -- type is also defined in generics or instantiations). + -- In such case we search in the list of primitives of the + -- generic actual for the internal entity that links the + -- interface primitive and the covering primitive. + + if No (Act_Subp) + and then Is_Generic_Type (Parent_Type) + then + -- This code has been designed to handle only generic + -- formals that implement interfaces that are defined + -- in a generic unit or instantiation. If this code is + -- needed for other cases we must review it because + -- (given that it relies on Original_Location to locate + -- the primitive of Generic_Actual that covers the + -- interface) it could leave linked through attribute + -- Alias entities of unrelated instantiations). + + pragma Assert + (Is_Generic_Unit + (Scope (Find_Dispatching_Type (Alias_Subp))) + or else + Instantiation_Depth + (Sloc (Find_Dispatching_Type (Alias_Subp))) > 0); + + declare + Iface_Prim_Loc : constant Source_Ptr := + Original_Location (Sloc (Alias_Subp)); + Elmt : Elmt_Id; + Prim : Entity_Id; + begin + Elmt := + First_Elmt (Primitive_Operations (Generic_Actual)); + + Search : while Present (Elmt) loop + Prim := Node (Elmt); + + if Present (Interface_Alias (Prim)) + and then Original_Location + (Sloc (Interface_Alias (Prim))) + = Iface_Prim_Loc + then + Act_Subp := Alias (Prim); + exit Search; + end if; + + Next_Elmt (Elmt); + end loop Search; + end; + end if; + + pragma Assert (Present (Act_Subp) + or else Is_Abstract_Type (Generic_Actual) + or else Serious_Errors_Detected > 0); + + -- Handle predefined primitives plus the rest of user-defined + -- primitives + + else + Act_Elmt := First_Elmt (Act_List); + while Present (Act_Elmt) loop + Act_Subp := Node (Act_Elmt); + + exit when Primitive_Names_Match (Subp, Act_Subp) + and then Type_Conformant + (Subp, Act_Subp, + Skip_Controlling_Formals => True) + and then No (Interface_Alias (Act_Subp)); + + Next_Elmt (Act_Elmt); + end loop; + + if No (Act_Elmt) then + Act_Subp := Empty; + end if; + end if; + end if; + + -- Case 1: If the parent is a limited interface then it has the + -- predefined primitives of synchronized interfaces. However, the + -- actual type may be a non-limited type and hence it does not + -- have such primitives. + + if Present (Generic_Actual) + and then not Present (Act_Subp) + and then Is_Limited_Interface (Parent_Base) + and then Is_Predefined_Interface_Primitive (Subp) + then + null; + + -- Case 2: Inherit entities associated with interfaces that were + -- not covered by the parent type. We exclude here null interface + -- primitives because they do not need special management. + + -- We also exclude interface operations that are renamings. If the + -- subprogram is an explicit renaming of an interface primitive, + -- it is a regular primitive operation, and the presence of its + -- alias is not relevant: it has to be derived like any other + -- primitive. + + elsif Present (Alias (Subp)) + and then Nkind (Unit_Declaration_Node (Subp)) /= + N_Subprogram_Renaming_Declaration + and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) + and then not + (Nkind (Parent (Alias_Subp)) = N_Procedure_Specification + and then Null_Present (Parent (Alias_Subp))) + then + -- If this is an abstract private type then we transfer the + -- derivation of the interface primitive from the partial view + -- to the full view. This is safe because all the interfaces + -- must be visible in the partial view. Done to avoid adding + -- a new interface derivation to the private part of the + -- enclosing package; otherwise this new derivation would be + -- decorated as hidden when the analysis of the enclosing + -- package completes. + + if Is_Abstract_Type (Derived_Type) + and then In_Private_Part (Current_Scope) + and then Has_Private_Declaration (Derived_Type) + then + declare + Partial_View : Entity_Id; + Elmt : Elmt_Id; + Ent : Entity_Id; + + begin + Partial_View := First_Entity (Current_Scope); + loop + exit when No (Partial_View) + or else (Has_Private_Declaration (Partial_View) + and then + Full_View (Partial_View) = Derived_Type); + + Next_Entity (Partial_View); + end loop; + + -- If the partial view was not found then the source code + -- has errors and the derivation is not needed. + + if Present (Partial_View) then + Elmt := + First_Elmt (Primitive_Operations (Partial_View)); + while Present (Elmt) loop + Ent := Node (Elmt); + + if Present (Alias (Ent)) + and then Ultimate_Alias (Ent) = Alias (Subp) + then + Append_Elmt + (Ent, Primitive_Operations (Derived_Type)); + exit; + end if; + + Next_Elmt (Elmt); + end loop; + + -- If the interface primitive was not found in the + -- partial view then this interface primitive was + -- overridden. We add a derivation to activate in + -- Derive_Progenitor_Subprograms the machinery to + -- search for it. + + if No (Elmt) then + Derive_Interface_Subprogram + (New_Subp => New_Subp, + Subp => Subp, + Actual_Subp => Act_Subp); + end if; + end if; + end; + else + Derive_Interface_Subprogram + (New_Subp => New_Subp, + Subp => Subp, + Actual_Subp => Act_Subp); + end if; + + -- Case 3: Common derivation + + else + Derive_Subprogram + (New_Subp => New_Subp, + Parent_Subp => Subp, + Derived_Type => Derived_Type, + Parent_Type => Parent_Base, + Actual_Subp => Act_Subp); + end if; + + -- No need to update Act_Elm if we must search for the + -- corresponding operation in the generic actual + + if not Need_Search + and then Present (Act_Elmt) + then + Next_Elmt (Act_Elmt); + Act_Subp := Node (Act_Elmt); + end if; + + <> + Next_Elmt (Elmt); + end loop; + + -- Inherit additional operations from progenitors. If the derived + -- type is a generic actual, there are not new primitive operations + -- for the type because it has those of the actual, and therefore + -- nothing needs to be done. The renamings generated above are not + -- primitive operations, and their purpose is simply to make the + -- proper operations visible within an instantiation. + + if No (Generic_Actual) then + Derive_Progenitor_Subprograms (Parent_Base, Derived_Type); + end if; + end if; + + -- Final check: Direct descendants must have their primitives in the + -- same order. We exclude from this test untagged types and instances + -- of formal derived types. We skip this test if we have already + -- reported serious errors in the sources. + + pragma Assert (not Is_Tagged_Type (Derived_Type) + or else Present (Generic_Actual) + or else Serious_Errors_Detected > 0 + or else Check_Derived_Type); + end Derive_Subprograms; + + -------------------------------- + -- Derived_Standard_Character -- + -------------------------------- + + procedure Derived_Standard_Character + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Def : constant Node_Id := Type_Definition (N); + Indic : constant Node_Id := Subtype_Indication (Def); + Parent_Base : constant Entity_Id := Base_Type (Parent_Type); + Implicit_Base : constant Entity_Id := + Create_Itype + (E_Enumeration_Type, N, Derived_Type, 'B'); + + Lo : Node_Id; + Hi : Node_Id; + + begin + Discard_Node (Process_Subtype (Indic, N)); + + Set_Etype (Implicit_Base, Parent_Base); + Set_Size_Info (Implicit_Base, Root_Type (Parent_Type)); + Set_RM_Size (Implicit_Base, RM_Size (Root_Type (Parent_Type))); + + Set_Is_Character_Type (Implicit_Base, True); + Set_Has_Delayed_Freeze (Implicit_Base); + + -- The bounds of the implicit base are the bounds of the parent base. + -- Note that their type is the parent base. + + Lo := New_Copy_Tree (Type_Low_Bound (Parent_Base)); + Hi := New_Copy_Tree (Type_High_Bound (Parent_Base)); + + Set_Scalar_Range (Implicit_Base, + Make_Range (Loc, + Low_Bound => Lo, + High_Bound => Hi)); + + Conditional_Delay (Derived_Type, Parent_Type); + + Set_Ekind (Derived_Type, E_Enumeration_Subtype); + Set_Etype (Derived_Type, Implicit_Base); + Set_Size_Info (Derived_Type, Parent_Type); + + if Unknown_RM_Size (Derived_Type) then + Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); + end if; + + Set_Is_Character_Type (Derived_Type, True); + + if Nkind (Indic) /= N_Subtype_Indication then + + -- If no explicit constraint, the bounds are those + -- of the parent type. + + Lo := New_Copy_Tree (Type_Low_Bound (Parent_Type)); + Hi := New_Copy_Tree (Type_High_Bound (Parent_Type)); + Set_Scalar_Range (Derived_Type, Make_Range (Loc, Lo, Hi)); + end if; + + Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc); + + -- Because the implicit base is used in the conversion of the bounds, we + -- have to freeze it now. This is similar to what is done for numeric + -- types, and it equally suspicious, but otherwise a non-static bound + -- will have a reference to an unfrozen type, which is rejected by Gigi + -- (???). This requires specific care for definition of stream + -- attributes. For details, see comments at the end of + -- Build_Derived_Numeric_Type. + + Freeze_Before (N, Implicit_Base); + end Derived_Standard_Character; + + ------------------------------ + -- Derived_Type_Declaration -- + ------------------------------ + + procedure Derived_Type_Declaration + (T : Entity_Id; + N : Node_Id; + Is_Completion : Boolean) + is + Parent_Type : Entity_Id; + + function Comes_From_Generic (Typ : Entity_Id) return Boolean; + -- Check whether the parent type is a generic formal, or derives + -- directly or indirectly from one. + + ------------------------ + -- Comes_From_Generic -- + ------------------------ + + function Comes_From_Generic (Typ : Entity_Id) return Boolean is + begin + if Is_Generic_Type (Typ) then + return True; + + elsif Is_Generic_Type (Root_Type (Parent_Type)) then + return True; + + elsif Is_Private_Type (Typ) + and then Present (Full_View (Typ)) + and then Is_Generic_Type (Root_Type (Full_View (Typ))) + then + return True; + + elsif Is_Generic_Actual_Type (Typ) then + return True; + + else + return False; + end if; + end Comes_From_Generic; + + -- Local variables + + Def : constant Node_Id := Type_Definition (N); + Iface_Def : Node_Id; + Indic : constant Node_Id := Subtype_Indication (Def); + Extension : constant Node_Id := Record_Extension_Part (Def); + Parent_Node : Node_Id; + Parent_Scope : Entity_Id; + Taggd : Boolean; + + -- Start of processing for Derived_Type_Declaration + + begin + Parent_Type := Find_Type_Of_Subtype_Indic (Indic); + + -- Ada 2005 (AI-251): In case of interface derivation check that the + -- parent is also an interface. + + if Interface_Present (Def) then + if not Is_Interface (Parent_Type) then + Diagnose_Interface (Indic, Parent_Type); + + else + Parent_Node := Parent (Base_Type (Parent_Type)); + Iface_Def := Type_Definition (Parent_Node); + + -- Ada 2005 (AI-251): Limited interfaces can only inherit from + -- other limited interfaces. + + if Limited_Present (Def) then + if Limited_Present (Iface_Def) then + null; + + elsif Protected_Present (Iface_Def) then + Error_Msg_NE + ("descendant of& must be declared" + & " as a protected interface", + N, Parent_Type); + + elsif Synchronized_Present (Iface_Def) then + Error_Msg_NE + ("descendant of& must be declared" + & " as a synchronized interface", + N, Parent_Type); + + elsif Task_Present (Iface_Def) then + Error_Msg_NE + ("descendant of& must be declared as a task interface", + N, Parent_Type); + + else + Error_Msg_N + ("(Ada 2005) limited interface cannot " + & "inherit from non-limited interface", Indic); + end if; + + -- Ada 2005 (AI-345): Non-limited interfaces can only inherit + -- from non-limited or limited interfaces. + + elsif not Protected_Present (Def) + and then not Synchronized_Present (Def) + and then not Task_Present (Def) + then + if Limited_Present (Iface_Def) then + null; + + elsif Protected_Present (Iface_Def) then + Error_Msg_NE + ("descendant of& must be declared" + & " as a protected interface", + N, Parent_Type); + + elsif Synchronized_Present (Iface_Def) then + Error_Msg_NE + ("descendant of& must be declared" + & " as a synchronized interface", + N, Parent_Type); + + elsif Task_Present (Iface_Def) then + Error_Msg_NE + ("descendant of& must be declared as a task interface", + N, Parent_Type); + else + null; + end if; + end if; + end if; + end if; + + if Is_Tagged_Type (Parent_Type) + and then Is_Concurrent_Type (Parent_Type) + and then not Is_Interface (Parent_Type) + then + Error_Msg_N + ("parent type of a record extension cannot be " + & "a synchronized tagged type (RM 3.9.1 (3/1))", N); + Set_Etype (T, Any_Type); + return; + end if; + + -- Ada 2005 (AI-251): Decorate all the names in the list of ancestor + -- interfaces + + if Is_Tagged_Type (Parent_Type) + and then Is_Non_Empty_List (Interface_List (Def)) + then + declare + Intf : Node_Id; + T : Entity_Id; + + begin + Intf := First (Interface_List (Def)); + while Present (Intf) loop + T := Find_Type_Of_Subtype_Indic (Intf); + + if not Is_Interface (T) then + Diagnose_Interface (Intf, T); + + -- Check the rules of 3.9.4(12/2) and 7.5(2/2) that disallow + -- a limited type from having a nonlimited progenitor. + + elsif (Limited_Present (Def) + or else (not Is_Interface (Parent_Type) + and then Is_Limited_Type (Parent_Type))) + and then not Is_Limited_Interface (T) + then + Error_Msg_NE + ("progenitor interface& of limited type must be limited", + N, T); + end if; + + Next (Intf); + end loop; + end; + end if; + + if Parent_Type = Any_Type + or else Etype (Parent_Type) = Any_Type + or else (Is_Class_Wide_Type (Parent_Type) + and then Etype (Parent_Type) = T) + then + -- If Parent_Type is undefined or illegal, make new type into a + -- subtype of Any_Type, and set a few attributes to prevent cascaded + -- errors. If this is a self-definition, emit error now. + + if T = Parent_Type + or else T = Etype (Parent_Type) + then + Error_Msg_N ("type cannot be used in its own definition", Indic); + end if; + + Set_Ekind (T, Ekind (Parent_Type)); + Set_Etype (T, Any_Type); + Set_Scalar_Range (T, Scalar_Range (Any_Type)); + + if Is_Tagged_Type (T) + and then Is_Record_Type (T) + then + Set_Direct_Primitive_Operations (T, New_Elmt_List); + end if; + + return; + end if; + + -- Ada 2005 (AI-251): The case in which the parent of the full-view is + -- an interface is special because the list of interfaces in the full + -- view can be given in any order. For example: + + -- type A is interface; + -- type B is interface and A; + -- type D is new B with private; + -- private + -- type D is new A and B with null record; -- 1 -- + + -- In this case we perform the following transformation of -1-: + + -- type D is new B and A with null record; + + -- If the parent of the full-view covers the parent of the partial-view + -- we have two possible cases: + + -- 1) They have the same parent + -- 2) The parent of the full-view implements some further interfaces + + -- In both cases we do not need to perform the transformation. In the + -- first case the source program is correct and the transformation is + -- not needed; in the second case the source program does not fulfill + -- the no-hidden interfaces rule (AI-396) and the error will be reported + -- later. + + -- This transformation not only simplifies the rest of the analysis of + -- this type declaration but also simplifies the correct generation of + -- the object layout to the expander. + + if In_Private_Part (Current_Scope) + and then Is_Interface (Parent_Type) + then + declare + Iface : Node_Id; + Partial_View : Entity_Id; + Partial_View_Parent : Entity_Id; + New_Iface : Node_Id; + + begin + -- Look for the associated private type declaration + + Partial_View := First_Entity (Current_Scope); + loop + exit when No (Partial_View) + or else (Has_Private_Declaration (Partial_View) + and then Full_View (Partial_View) = T); + + Next_Entity (Partial_View); + end loop; + + -- If the partial view was not found then the source code has + -- errors and the transformation is not needed. + + if Present (Partial_View) then + Partial_View_Parent := Etype (Partial_View); + + -- If the parent of the full-view covers the parent of the + -- partial-view we have nothing else to do. + + if Interface_Present_In_Ancestor + (Parent_Type, Partial_View_Parent) + then + null; + + -- Traverse the list of interfaces of the full-view to look + -- for the parent of the partial-view and perform the tree + -- transformation. + + else + Iface := First (Interface_List (Def)); + while Present (Iface) loop + if Etype (Iface) = Etype (Partial_View) then + Rewrite (Subtype_Indication (Def), + New_Copy (Subtype_Indication + (Parent (Partial_View)))); + + New_Iface := + Make_Identifier (Sloc (N), Chars (Parent_Type)); + Append (New_Iface, Interface_List (Def)); + + -- Analyze the transformed code + + Derived_Type_Declaration (T, N, Is_Completion); + return; + end if; + + Next (Iface); + end loop; + end if; + end if; + end; + end if; + + -- Only composite types other than array types are allowed to have + -- discriminants. + + if Present (Discriminant_Specifications (N)) + and then (Is_Elementary_Type (Parent_Type) + or else Is_Array_Type (Parent_Type)) + and then not Error_Posted (N) + then + Error_Msg_N + ("elementary or array type cannot have discriminants", + Defining_Identifier (First (Discriminant_Specifications (N)))); + Set_Has_Discriminants (T, False); + end if; + + -- In Ada 83, a derived type defined in a package specification cannot + -- be used for further derivation until the end of its visible part. + -- Note that derivation in the private part of the package is allowed. + + if Ada_Version = Ada_83 + and then Is_Derived_Type (Parent_Type) + and then In_Visible_Part (Scope (Parent_Type)) + then + if Ada_Version = Ada_83 and then Comes_From_Source (Indic) then + Error_Msg_N + ("(Ada 83): premature use of type for derivation", Indic); + end if; + end if; + + -- Check for early use of incomplete or private type + + if Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then + Error_Msg_N ("premature derivation of incomplete type", Indic); + return; + + elsif (Is_Incomplete_Or_Private_Type (Parent_Type) + and then not Comes_From_Generic (Parent_Type)) + or else Has_Private_Component (Parent_Type) + then + -- The ancestor type of a formal type can be incomplete, in which + -- case only the operations of the partial view are available in + -- the generic. Subsequent checks may be required when the full + -- view is analyzed, to verify that derivation from a tagged type + -- has an extension. + + if Nkind (Original_Node (N)) = N_Formal_Type_Declaration then + null; + + elsif No (Underlying_Type (Parent_Type)) + or else Has_Private_Component (Parent_Type) + then + Error_Msg_N + ("premature derivation of derived or private type", Indic); + + -- Flag the type itself as being in error, this prevents some + -- nasty problems with subsequent uses of the malformed type. + + Set_Error_Posted (T); + + -- Check that within the immediate scope of an untagged partial + -- view it's illegal to derive from the partial view if the + -- full view is tagged. (7.3(7)) + + -- We verify that the Parent_Type is a partial view by checking + -- that it is not a Full_Type_Declaration (i.e. a private type or + -- private extension declaration), to distinguish a partial view + -- from a derivation from a private type which also appears as + -- E_Private_Type. + + elsif Present (Full_View (Parent_Type)) + and then Nkind (Parent (Parent_Type)) /= N_Full_Type_Declaration + and then not Is_Tagged_Type (Parent_Type) + and then Is_Tagged_Type (Full_View (Parent_Type)) + then + Parent_Scope := Scope (T); + while Present (Parent_Scope) + and then Parent_Scope /= Standard_Standard + loop + if Parent_Scope = Scope (Parent_Type) then + Error_Msg_N + ("premature derivation from type with tagged full view", + Indic); + end if; + + Parent_Scope := Scope (Parent_Scope); + end loop; + end if; + end if; + + -- Check that form of derivation is appropriate + + Taggd := Is_Tagged_Type (Parent_Type); + + -- Perhaps the parent type should be changed to the class-wide type's + -- specific type in this case to prevent cascading errors ??? + + if Present (Extension) and then Is_Class_Wide_Type (Parent_Type) then + Error_Msg_N ("parent type must not be a class-wide type", Indic); + return; + end if; + + if Present (Extension) and then not Taggd then + Error_Msg_N + ("type derived from untagged type cannot have extension", Indic); + + elsif No (Extension) and then Taggd then + + -- If this declaration is within a private part (or body) of a + -- generic instantiation then the derivation is allowed (the parent + -- type can only appear tagged in this case if it's a generic actual + -- type, since it would otherwise have been rejected in the analysis + -- of the generic template). + + if not Is_Generic_Actual_Type (Parent_Type) + or else In_Visible_Part (Scope (Parent_Type)) + then + if Is_Class_Wide_Type (Parent_Type) then + Error_Msg_N + ("parent type must not be a class-wide type", Indic); + + -- Use specific type to prevent cascaded errors. + + Parent_Type := Etype (Parent_Type); + + else + Error_Msg_N + ("type derived from tagged type must have extension", Indic); + end if; + end if; + end if; + + -- AI-443: Synchronized formal derived types require a private + -- extension. There is no point in checking the ancestor type or + -- the progenitors since the construct is wrong to begin with. + + if Ada_Version >= Ada_2005 + and then Is_Generic_Type (T) + and then Present (Original_Node (N)) + then + declare + Decl : constant Node_Id := Original_Node (N); + + begin + if Nkind (Decl) = N_Formal_Type_Declaration + and then Nkind (Formal_Type_Definition (Decl)) = + N_Formal_Derived_Type_Definition + and then Synchronized_Present (Formal_Type_Definition (Decl)) + and then No (Extension) + + -- Avoid emitting a duplicate error message + + and then not Error_Posted (Indic) + then + Error_Msg_N + ("synchronized derived type must have extension", N); + end if; + end; + end if; + + if Null_Exclusion_Present (Def) + and then not Is_Access_Type (Parent_Type) + then + Error_Msg_N ("null exclusion can only apply to an access type", N); + end if; + + -- Avoid deriving parent primitives of underlying record views + + Build_Derived_Type (N, Parent_Type, T, Is_Completion, + Derive_Subps => not Is_Underlying_Record_View (T)); + + -- AI-419: The parent type of an explicitly limited derived type must + -- be a limited type or a limited interface. + + if Limited_Present (Def) then + Set_Is_Limited_Record (T); + + if Is_Interface (T) then + Set_Is_Limited_Interface (T); + end if; + + if not Is_Limited_Type (Parent_Type) + and then + (not Is_Interface (Parent_Type) + or else not Is_Limited_Interface (Parent_Type)) + then + -- AI05-0096: a derivation in the private part of an instance is + -- legal if the generic formal is untagged limited, and the actual + -- is non-limited. + + if Is_Generic_Actual_Type (Parent_Type) + and then In_Private_Part (Current_Scope) + and then + not Is_Tagged_Type + (Generic_Parent_Type (Parent (Parent_Type))) + then + null; + + else + Error_Msg_NE + ("parent type& of limited type must be limited", + N, Parent_Type); + end if; + end if; + end if; + end Derived_Type_Declaration; + + ------------------------ + -- Diagnose_Interface -- + ------------------------ + + procedure Diagnose_Interface (N : Node_Id; E : Entity_Id) is + begin + if not Is_Interface (E) + and then E /= Any_Type + then + Error_Msg_NE ("(Ada 2005) & must be an interface", N, E); + end if; + end Diagnose_Interface; + + ---------------------------------- + -- Enumeration_Type_Declaration -- + ---------------------------------- + + procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id) is + Ev : Uint; + L : Node_Id; + R_Node : Node_Id; + B_Node : Node_Id; + + begin + -- Create identifier node representing lower bound + + B_Node := New_Node (N_Identifier, Sloc (Def)); + L := First (Literals (Def)); + Set_Chars (B_Node, Chars (L)); + Set_Entity (B_Node, L); + Set_Etype (B_Node, T); + Set_Is_Static_Expression (B_Node, True); + + R_Node := New_Node (N_Range, Sloc (Def)); + Set_Low_Bound (R_Node, B_Node); + + Set_Ekind (T, E_Enumeration_Type); + Set_First_Literal (T, L); + Set_Etype (T, T); + Set_Is_Constrained (T); + + Ev := Uint_0; + + -- Loop through literals of enumeration type setting pos and rep values + -- except that if the Ekind is already set, then it means the literal + -- was already constructed (case of a derived type declaration and we + -- should not disturb the Pos and Rep values. + + while Present (L) loop + if Ekind (L) /= E_Enumeration_Literal then + Set_Ekind (L, E_Enumeration_Literal); + Set_Enumeration_Pos (L, Ev); + Set_Enumeration_Rep (L, Ev); + Set_Is_Known_Valid (L, True); + end if; + + Set_Etype (L, T); + New_Overloaded_Entity (L); + Generate_Definition (L); + Set_Convention (L, Convention_Intrinsic); + + -- Case of character literal + + if Nkind (L) = N_Defining_Character_Literal then + Set_Is_Character_Type (T, True); + + -- Check violation of No_Wide_Characters + + if Restriction_Check_Required (No_Wide_Characters) then + Get_Name_String (Chars (L)); + + if Name_Len >= 3 and then Name_Buffer (1 .. 2) = "QW" then + Check_Restriction (No_Wide_Characters, L); + end if; + end if; + end if; + + Ev := Ev + 1; + Next (L); + end loop; + + -- Now create a node representing upper bound + + B_Node := New_Node (N_Identifier, Sloc (Def)); + Set_Chars (B_Node, Chars (Last (Literals (Def)))); + Set_Entity (B_Node, Last (Literals (Def))); + Set_Etype (B_Node, T); + Set_Is_Static_Expression (B_Node, True); + + Set_High_Bound (R_Node, B_Node); + + -- Initialize various fields of the type. Some of this information + -- may be overwritten later through rep.clauses. + + Set_Scalar_Range (T, R_Node); + Set_RM_Size (T, UI_From_Int (Minimum_Size (T))); + Set_Enum_Esize (T); + Set_Enum_Pos_To_Rep (T, Empty); + + -- Set Discard_Names if configuration pragma set, or if there is + -- a parameterless pragma in the current declarative region + + if Global_Discard_Names + or else Discard_Names (Scope (T)) + then + Set_Discard_Names (T); + end if; + + -- Process end label if there is one + + if Present (Def) then + Process_End_Label (Def, 'e', T); + end if; + end Enumeration_Type_Declaration; + + --------------------------------- + -- Expand_To_Stored_Constraint -- + --------------------------------- + + function Expand_To_Stored_Constraint + (Typ : Entity_Id; + Constraint : Elist_Id) return Elist_Id + is + Explicitly_Discriminated_Type : Entity_Id; + Expansion : Elist_Id; + Discriminant : Entity_Id; + + function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id; + -- Find the nearest type that actually specifies discriminants + + --------------------------------- + -- Type_With_Explicit_Discrims -- + --------------------------------- + + function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id is + Typ : constant E := Base_Type (Id); + + begin + if Ekind (Typ) in Incomplete_Or_Private_Kind then + if Present (Full_View (Typ)) then + return Type_With_Explicit_Discrims (Full_View (Typ)); + end if; + + else + if Has_Discriminants (Typ) then + return Typ; + end if; + end if; + + if Etype (Typ) = Typ then + return Empty; + elsif Has_Discriminants (Typ) then + return Typ; + else + return Type_With_Explicit_Discrims (Etype (Typ)); + end if; + + end Type_With_Explicit_Discrims; + + -- Start of processing for Expand_To_Stored_Constraint + + begin + if No (Constraint) + or else Is_Empty_Elmt_List (Constraint) + then + return No_Elist; + end if; + + Explicitly_Discriminated_Type := Type_With_Explicit_Discrims (Typ); + + if No (Explicitly_Discriminated_Type) then + return No_Elist; + end if; + + Expansion := New_Elmt_List; + + Discriminant := + First_Stored_Discriminant (Explicitly_Discriminated_Type); + while Present (Discriminant) loop + Append_Elmt ( + Get_Discriminant_Value ( + Discriminant, Explicitly_Discriminated_Type, Constraint), + Expansion); + Next_Stored_Discriminant (Discriminant); + end loop; + + return Expansion; + end Expand_To_Stored_Constraint; + + --------------------------- + -- Find_Hidden_Interface -- + --------------------------- + + function Find_Hidden_Interface + (Src : Elist_Id; + Dest : Elist_Id) return Entity_Id + is + Iface : Entity_Id; + Iface_Elmt : Elmt_Id; + + begin + if Present (Src) and then Present (Dest) then + Iface_Elmt := First_Elmt (Src); + while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); + + if Is_Interface (Iface) + and then not Contain_Interface (Iface, Dest) + then + return Iface; + end if; + + Next_Elmt (Iface_Elmt); + end loop; + end if; + + return Empty; + end Find_Hidden_Interface; + + -------------------- + -- Find_Type_Name -- + -------------------- + + function Find_Type_Name (N : Node_Id) return Entity_Id is + Id : constant Entity_Id := Defining_Identifier (N); + Prev : Entity_Id; + New_Id : Entity_Id; + Prev_Par : Node_Id; + + procedure Tag_Mismatch; + -- Diagnose a tagged partial view whose full view is untagged. + -- We post the message on the full view, with a reference to + -- the previous partial view. The partial view can be private + -- or incomplete, and these are handled in a different manner, + -- so we determine the position of the error message from the + -- respective slocs of both. + + ------------------ + -- Tag_Mismatch -- + ------------------ + + procedure Tag_Mismatch is + begin + if Sloc (Prev) < Sloc (Id) then + if Ada_Version >= Ada_2012 + and then Nkind (N) = N_Private_Type_Declaration + then + Error_Msg_NE + ("declaration of private } must be a tagged type ", Id, Prev); + else + Error_Msg_NE + ("full declaration of } must be a tagged type ", Id, Prev); + end if; + else + if Ada_Version >= Ada_2012 + and then Nkind (N) = N_Private_Type_Declaration + then + Error_Msg_NE + ("declaration of private } must be a tagged type ", Prev, Id); + else + Error_Msg_NE + ("full declaration of } must be a tagged type ", Prev, Id); + end if; + end if; + end Tag_Mismatch; + + -- Start of processing for Find_Type_Name + + begin + -- Find incomplete declaration, if one was given + + Prev := Current_Entity_In_Scope (Id); + + -- New type declaration + + if No (Prev) then + Enter_Name (Id); + return Id; + + -- Previous declaration exists + + else + Prev_Par := Parent (Prev); + + -- Error if not incomplete/private case except if previous + -- declaration is implicit, etc. Enter_Name will emit error if + -- appropriate. + + if not Is_Incomplete_Or_Private_Type (Prev) then + Enter_Name (Id); + New_Id := Id; + + -- Check invalid completion of private or incomplete type + + elsif not Nkind_In (N, N_Full_Type_Declaration, + N_Task_Type_Declaration, + N_Protected_Type_Declaration) + and then + (Ada_Version < Ada_2012 + or else not Is_Incomplete_Type (Prev) + or else not Nkind_In (N, N_Private_Type_Declaration, + N_Private_Extension_Declaration)) + then + -- Completion must be a full type declarations (RM 7.3(4)) + + Error_Msg_Sloc := Sloc (Prev); + Error_Msg_NE ("invalid completion of }", Id, Prev); + + -- Set scope of Id to avoid cascaded errors. Entity is never + -- examined again, except when saving globals in generics. + + Set_Scope (Id, Current_Scope); + New_Id := Id; + + -- If this is a repeated incomplete declaration, no further + -- checks are possible. + + if Nkind (N) = N_Incomplete_Type_Declaration then + return Prev; + end if; + + -- Case of full declaration of incomplete type + + elsif Ekind (Prev) = E_Incomplete_Type + and then (Ada_Version < Ada_2012 + or else No (Full_View (Prev)) + or else not Is_Private_Type (Full_View (Prev))) + then + + -- Indicate that the incomplete declaration has a matching full + -- declaration. The defining occurrence of the incomplete + -- declaration remains the visible one, and the procedure + -- Get_Full_View dereferences it whenever the type is used. + + if Present (Full_View (Prev)) then + Error_Msg_NE ("invalid redeclaration of }", Id, Prev); + end if; + + Set_Full_View (Prev, Id); + Append_Entity (Id, Current_Scope); + Set_Is_Public (Id, Is_Public (Prev)); + Set_Is_Internal (Id); + New_Id := Prev; + + -- If the incomplete view is tagged, a class_wide type has been + -- created already. Use it for the private type as well, in order + -- to prevent multiple incompatible class-wide types that may be + -- created for self-referential anonymous access components. + + if Is_Tagged_Type (Prev) + and then Present (Class_Wide_Type (Prev)) + then + Set_Ekind (Id, Ekind (Prev)); -- will be reset later + Set_Class_Wide_Type (Id, Class_Wide_Type (Prev)); + Set_Etype (Class_Wide_Type (Id), Id); + end if; + + -- Case of full declaration of private type + + else + -- If the private type was a completion of an incomplete type then + -- update Prev to reference the private type + + if Ada_Version >= Ada_2012 + and then Ekind (Prev) = E_Incomplete_Type + and then Present (Full_View (Prev)) + and then Is_Private_Type (Full_View (Prev)) + then + Prev := Full_View (Prev); + Prev_Par := Parent (Prev); + end if; + + if Nkind (Parent (Prev)) /= N_Private_Extension_Declaration then + if Etype (Prev) /= Prev then + + -- Prev is a private subtype or a derived type, and needs + -- no completion. + + Error_Msg_NE ("invalid redeclaration of }", Id, Prev); + New_Id := Id; + + elsif Ekind (Prev) = E_Private_Type + and then Nkind_In (N, N_Task_Type_Declaration, + N_Protected_Type_Declaration) + then + Error_Msg_N + ("completion of nonlimited type cannot be limited", N); + + elsif Ekind (Prev) = E_Record_Type_With_Private + and then Nkind_In (N, N_Task_Type_Declaration, + N_Protected_Type_Declaration) + then + if not Is_Limited_Record (Prev) then + Error_Msg_N + ("completion of nonlimited type cannot be limited", N); + + elsif No (Interface_List (N)) then + Error_Msg_N + ("completion of tagged private type must be tagged", + N); + end if; + + elsif Nkind (N) = N_Full_Type_Declaration + and then + Nkind (Type_Definition (N)) = N_Record_Definition + and then Interface_Present (Type_Definition (N)) + then + Error_Msg_N + ("completion of private type cannot be an interface", N); + end if; + + -- Ada 2005 (AI-251): Private extension declaration of a task + -- type or a protected type. This case arises when covering + -- interface types. + + elsif Nkind_In (N, N_Task_Type_Declaration, + N_Protected_Type_Declaration) + then + null; + + elsif Nkind (N) /= N_Full_Type_Declaration + or else Nkind (Type_Definition (N)) /= N_Derived_Type_Definition + then + Error_Msg_N + ("full view of private extension must be an extension", N); + + elsif not (Abstract_Present (Parent (Prev))) + and then Abstract_Present (Type_Definition (N)) + then + Error_Msg_N + ("full view of non-abstract extension cannot be abstract", N); + end if; + + if not In_Private_Part (Current_Scope) then + Error_Msg_N + ("declaration of full view must appear in private part", N); + end if; + + Copy_And_Swap (Prev, Id); + Set_Has_Private_Declaration (Prev); + Set_Has_Private_Declaration (Id); + + -- If no error, propagate freeze_node from private to full view. + -- It may have been generated for an early operational item. + + if Present (Freeze_Node (Id)) + and then Serious_Errors_Detected = 0 + and then No (Full_View (Id)) + then + Set_Freeze_Node (Prev, Freeze_Node (Id)); + Set_Freeze_Node (Id, Empty); + Set_First_Rep_Item (Prev, First_Rep_Item (Id)); + end if; + + Set_Full_View (Id, Prev); + New_Id := Prev; + end if; + + -- Verify that full declaration conforms to partial one + + if Is_Incomplete_Or_Private_Type (Prev) + and then Present (Discriminant_Specifications (Prev_Par)) + then + if Present (Discriminant_Specifications (N)) then + if Ekind (Prev) = E_Incomplete_Type then + Check_Discriminant_Conformance (N, Prev, Prev); + else + Check_Discriminant_Conformance (N, Prev, Id); + end if; + + else + Error_Msg_N + ("missing discriminants in full type declaration", N); + + -- To avoid cascaded errors on subsequent use, share the + -- discriminants of the partial view. + + Set_Discriminant_Specifications (N, + Discriminant_Specifications (Prev_Par)); + end if; + end if; + + -- A prior untagged partial view can have an associated class-wide + -- type due to use of the class attribute, and in this case the full + -- type must also be tagged. This Ada 95 usage is deprecated in favor + -- of incomplete tagged declarations, but we check for it. + + if Is_Type (Prev) + and then (Is_Tagged_Type (Prev) + or else Present (Class_Wide_Type (Prev))) + then + -- Ada 2012 (AI05-0162): A private type may be the completion of + -- an incomplete type + + if Ada_Version >= Ada_2012 + and then Is_Incomplete_Type (Prev) + and then Nkind_In (N, N_Private_Type_Declaration, + N_Private_Extension_Declaration) + then + -- No need to check private extensions since they are tagged + + if Nkind (N) = N_Private_Type_Declaration + and then not Tagged_Present (N) + then + Tag_Mismatch; + end if; + + -- The full declaration is either a tagged type (including + -- a synchronized type that implements interfaces) or a + -- type extension, otherwise this is an error. + + elsif Nkind_In (N, N_Task_Type_Declaration, + N_Protected_Type_Declaration) + then + if No (Interface_List (N)) + and then not Error_Posted (N) + then + Tag_Mismatch; + end if; + + elsif Nkind (Type_Definition (N)) = N_Record_Definition then + + -- Indicate that the previous declaration (tagged incomplete + -- or private declaration) requires the same on the full one. + + if not Tagged_Present (Type_Definition (N)) then + Tag_Mismatch; + Set_Is_Tagged_Type (Id); + end if; + + elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then + if No (Record_Extension_Part (Type_Definition (N))) then + Error_Msg_NE + ("full declaration of } must be a record extension", + Prev, Id); + + -- Set some attributes to produce a usable full view + + Set_Is_Tagged_Type (Id); + end if; + + else + Tag_Mismatch; + end if; + end if; + + return New_Id; + end if; + end Find_Type_Name; + + ------------------------- + -- Find_Type_Of_Object -- + ------------------------- + + function Find_Type_Of_Object + (Obj_Def : Node_Id; + Related_Nod : Node_Id) return Entity_Id + is + Def_Kind : constant Node_Kind := Nkind (Obj_Def); + P : Node_Id := Parent (Obj_Def); + T : Entity_Id; + Nam : Name_Id; + + begin + -- If the parent is a component_definition node we climb to the + -- component_declaration node + + if Nkind (P) = N_Component_Definition then + P := Parent (P); + end if; + + -- Case of an anonymous array subtype + + if Nkind_In (Def_Kind, N_Constrained_Array_Definition, + N_Unconstrained_Array_Definition) + then + T := Empty; + Array_Type_Declaration (T, Obj_Def); + + -- Create an explicit subtype whenever possible + + elsif Nkind (P) /= N_Component_Declaration + and then Def_Kind = N_Subtype_Indication + then + -- Base name of subtype on object name, which will be unique in + -- the current scope. + + -- If this is a duplicate declaration, return base type, to avoid + -- generating duplicate anonymous types. + + if Error_Posted (P) then + Analyze (Subtype_Mark (Obj_Def)); + return Entity (Subtype_Mark (Obj_Def)); + end if; + + Nam := + New_External_Name + (Chars (Defining_Identifier (Related_Nod)), 'S', 0, 'T'); + + T := Make_Defining_Identifier (Sloc (P), Nam); + + Insert_Action (Obj_Def, + Make_Subtype_Declaration (Sloc (P), + Defining_Identifier => T, + Subtype_Indication => Relocate_Node (Obj_Def))); + + -- This subtype may need freezing, and this will not be done + -- automatically if the object declaration is not in declarative + -- part. Since this is an object declaration, the type cannot always + -- be frozen here. Deferred constants do not freeze their type + -- (which often enough will be private). + + if Nkind (P) = N_Object_Declaration + and then Constant_Present (P) + and then No (Expression (P)) + then + null; + else + Insert_Actions (Obj_Def, Freeze_Entity (T, P)); + end if; + + -- Ada 2005 AI-406: the object definition in an object declaration + -- can be an access definition. + + elsif Def_Kind = N_Access_Definition then + T := Access_Definition (Related_Nod, Obj_Def); + Set_Is_Local_Anonymous_Access (T); + + -- Otherwise, the object definition is just a subtype_mark + + else + T := Process_Subtype (Obj_Def, Related_Nod); + end if; + + return T; + end Find_Type_Of_Object; + + -------------------------------- + -- Find_Type_Of_Subtype_Indic -- + -------------------------------- + + function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id is + Typ : Entity_Id; + + begin + -- Case of subtype mark with a constraint + + if Nkind (S) = N_Subtype_Indication then + Find_Type (Subtype_Mark (S)); + Typ := Entity (Subtype_Mark (S)); + + if not + Is_Valid_Constraint_Kind (Ekind (Typ), Nkind (Constraint (S))) + then + Error_Msg_N + ("incorrect constraint for this kind of type", Constraint (S)); + Rewrite (S, New_Copy_Tree (Subtype_Mark (S))); + end if; + + -- Otherwise we have a subtype mark without a constraint + + elsif Error_Posted (S) then + Rewrite (S, New_Occurrence_Of (Any_Id, Sloc (S))); + return Any_Type; + + else + Find_Type (S); + Typ := Entity (S); + end if; + + -- Check No_Wide_Characters restriction + + Check_Wide_Character_Restriction (Typ, S); + + return Typ; + end Find_Type_Of_Subtype_Indic; + + ------------------------------------- + -- Floating_Point_Type_Declaration -- + ------------------------------------- + + procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id) is + Digs : constant Node_Id := Digits_Expression (Def); + Digs_Val : Uint; + Base_Typ : Entity_Id; + Implicit_Base : Entity_Id; + Bound : Node_Id; + + function Can_Derive_From (E : Entity_Id) return Boolean; + -- Find if given digits value allows derivation from specified type + + --------------------- + -- Can_Derive_From -- + --------------------- + + function Can_Derive_From (E : Entity_Id) return Boolean is + Spec : constant Entity_Id := Real_Range_Specification (Def); + + begin + if Digs_Val > Digits_Value (E) then + return False; + end if; + + if Present (Spec) then + if Expr_Value_R (Type_Low_Bound (E)) > + Expr_Value_R (Low_Bound (Spec)) + then + return False; + end if; + + if Expr_Value_R (Type_High_Bound (E)) < + Expr_Value_R (High_Bound (Spec)) + then + return False; + end if; + end if; + + return True; + end Can_Derive_From; + + -- Start of processing for Floating_Point_Type_Declaration + + begin + Check_Restriction (No_Floating_Point, Def); + + -- Create an implicit base type + + Implicit_Base := + Create_Itype (E_Floating_Point_Type, Parent (Def), T, 'B'); + + -- Analyze and verify digits value + + Analyze_And_Resolve (Digs, Any_Integer); + Check_Digits_Expression (Digs); + Digs_Val := Expr_Value (Digs); + + -- Process possible range spec and find correct type to derive from + + Process_Real_Range_Specification (Def); + + if Can_Derive_From (Standard_Short_Float) then + Base_Typ := Standard_Short_Float; + elsif Can_Derive_From (Standard_Float) then + Base_Typ := Standard_Float; + elsif Can_Derive_From (Standard_Long_Float) then + Base_Typ := Standard_Long_Float; + elsif Can_Derive_From (Standard_Long_Long_Float) then + Base_Typ := Standard_Long_Long_Float; + + -- If we can't derive from any existing type, use long_long_float + -- and give appropriate message explaining the problem. + + else + Base_Typ := Standard_Long_Long_Float; + + if Digs_Val >= Digits_Value (Standard_Long_Long_Float) then + Error_Msg_Uint_1 := Digits_Value (Standard_Long_Long_Float); + Error_Msg_N ("digits value out of range, maximum is ^", Digs); + + else + Error_Msg_N + ("range too large for any predefined type", + Real_Range_Specification (Def)); + end if; + end if; + + -- If there are bounds given in the declaration use them as the bounds + -- of the type, otherwise use the bounds of the predefined base type + -- that was chosen based on the Digits value. + + if Present (Real_Range_Specification (Def)) then + Set_Scalar_Range (T, Real_Range_Specification (Def)); + Set_Is_Constrained (T); + + -- The bounds of this range must be converted to machine numbers + -- in accordance with RM 4.9(38). + + Bound := Type_Low_Bound (T); + + if Nkind (Bound) = N_Real_Literal then + Set_Realval + (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound)); + Set_Is_Machine_Number (Bound); + end if; + + Bound := Type_High_Bound (T); + + if Nkind (Bound) = N_Real_Literal then + Set_Realval + (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound)); + Set_Is_Machine_Number (Bound); + end if; + + else + Set_Scalar_Range (T, Scalar_Range (Base_Typ)); + end if; + + -- Complete definition of implicit base and declared first subtype + + Set_Etype (Implicit_Base, Base_Typ); + + Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ)); + Set_Size_Info (Implicit_Base, (Base_Typ)); + Set_RM_Size (Implicit_Base, RM_Size (Base_Typ)); + Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ)); + Set_Digits_Value (Implicit_Base, Digits_Value (Base_Typ)); + Set_Float_Rep (Implicit_Base, Float_Rep (Base_Typ)); + + Set_Ekind (T, E_Floating_Point_Subtype); + Set_Etype (T, Implicit_Base); + + Set_Size_Info (T, (Implicit_Base)); + Set_RM_Size (T, RM_Size (Implicit_Base)); + Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); + Set_Digits_Value (T, Digs_Val); + end Floating_Point_Type_Declaration; + + ---------------------------- + -- Get_Discriminant_Value -- + ---------------------------- + + -- This is the situation: + + -- There is a non-derived type + + -- type T0 (Dx, Dy, Dz...) + + -- There are zero or more levels of derivation, with each derivation + -- either purely inheriting the discriminants, or defining its own. + + -- type Ti is new Ti-1 + -- or + -- type Ti (Dw) is new Ti-1(Dw, 1, X+Y) + -- or + -- subtype Ti is ... + + -- The subtype issue is avoided by the use of Original_Record_Component, + -- and the fact that derived subtypes also derive the constraints. + + -- This chain leads back from + + -- Typ_For_Constraint + + -- Typ_For_Constraint has discriminants, and the value for each + -- discriminant is given by its corresponding Elmt of Constraints. + + -- Discriminant is some discriminant in this hierarchy + + -- We need to return its value + + -- We do this by recursively searching each level, and looking for + -- Discriminant. Once we get to the bottom, we start backing up + -- returning the value for it which may in turn be a discriminant + -- further up, so on the backup we continue the substitution. + + function Get_Discriminant_Value + (Discriminant : Entity_Id; + Typ_For_Constraint : Entity_Id; + Constraint : Elist_Id) return Node_Id + is + function Search_Derivation_Levels + (Ti : Entity_Id; + Discrim_Values : Elist_Id; + Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id; + -- This is the routine that performs the recursive search of levels + -- as described above. + + ------------------------------ + -- Search_Derivation_Levels -- + ------------------------------ + + function Search_Derivation_Levels + (Ti : Entity_Id; + Discrim_Values : Elist_Id; + Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id + is + Assoc : Elmt_Id; + Disc : Entity_Id; + Result : Node_Or_Entity_Id; + Result_Entity : Node_Id; + + begin + -- If inappropriate type, return Error, this happens only in + -- cascaded error situations, and we want to avoid a blow up. + + if not Is_Composite_Type (Ti) or else Is_Array_Type (Ti) then + return Error; + end if; + + -- Look deeper if possible. Use Stored_Constraints only for + -- untagged types. For tagged types use the given constraint. + -- This asymmetry needs explanation??? + + if not Stored_Discrim_Values + and then Present (Stored_Constraint (Ti)) + and then not Is_Tagged_Type (Ti) + then + Result := + Search_Derivation_Levels (Ti, Stored_Constraint (Ti), True); + else + declare + Td : constant Entity_Id := Etype (Ti); + + begin + if Td = Ti then + Result := Discriminant; + + else + if Present (Stored_Constraint (Ti)) then + Result := + Search_Derivation_Levels + (Td, Stored_Constraint (Ti), True); + else + Result := + Search_Derivation_Levels + (Td, Discrim_Values, Stored_Discrim_Values); + end if; + end if; + end; + end if; + + -- Extra underlying places to search, if not found above. For + -- concurrent types, the relevant discriminant appears in the + -- corresponding record. For a type derived from a private type + -- without discriminant, the full view inherits the discriminants + -- of the full view of the parent. + + if Result = Discriminant then + if Is_Concurrent_Type (Ti) + and then Present (Corresponding_Record_Type (Ti)) + then + Result := + Search_Derivation_Levels ( + Corresponding_Record_Type (Ti), + Discrim_Values, + Stored_Discrim_Values); + + elsif Is_Private_Type (Ti) + and then not Has_Discriminants (Ti) + and then Present (Full_View (Ti)) + and then Etype (Full_View (Ti)) /= Ti + then + Result := + Search_Derivation_Levels ( + Full_View (Ti), + Discrim_Values, + Stored_Discrim_Values); + end if; + end if; + + -- If Result is not a (reference to a) discriminant, return it, + -- otherwise set Result_Entity to the discriminant. + + if Nkind (Result) = N_Defining_Identifier then + pragma Assert (Result = Discriminant); + Result_Entity := Result; + + else + if not Denotes_Discriminant (Result) then + return Result; + end if; + + Result_Entity := Entity (Result); + end if; + + -- See if this level of derivation actually has discriminants + -- because tagged derivations can add them, hence the lower + -- levels need not have any. + + if not Has_Discriminants (Ti) then + return Result; + end if; + + -- Scan Ti's discriminants for Result_Entity, + -- and return its corresponding value, if any. + + Result_Entity := Original_Record_Component (Result_Entity); + + Assoc := First_Elmt (Discrim_Values); + + if Stored_Discrim_Values then + Disc := First_Stored_Discriminant (Ti); + else + Disc := First_Discriminant (Ti); + end if; + + while Present (Disc) loop + pragma Assert (Present (Assoc)); + + if Original_Record_Component (Disc) = Result_Entity then + return Node (Assoc); + end if; + + Next_Elmt (Assoc); + + if Stored_Discrim_Values then + Next_Stored_Discriminant (Disc); + else + Next_Discriminant (Disc); + end if; + end loop; + + -- Could not find it + -- + return Result; + end Search_Derivation_Levels; + + -- Local Variables + + Result : Node_Or_Entity_Id; + + -- Start of processing for Get_Discriminant_Value + + begin + -- ??? This routine is a gigantic mess and will be deleted. For the + -- time being just test for the trivial case before calling recurse. + + if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then + declare + D : Entity_Id; + E : Elmt_Id; + + begin + D := First_Discriminant (Typ_For_Constraint); + E := First_Elmt (Constraint); + while Present (D) loop + if Chars (D) = Chars (Discriminant) then + return Node (E); + end if; + + Next_Discriminant (D); + Next_Elmt (E); + end loop; + end; + end if; + + Result := Search_Derivation_Levels + (Typ_For_Constraint, Constraint, False); + + -- ??? hack to disappear when this routine is gone + + if Nkind (Result) = N_Defining_Identifier then + declare + D : Entity_Id; + E : Elmt_Id; + + begin + D := First_Discriminant (Typ_For_Constraint); + E := First_Elmt (Constraint); + while Present (D) loop + if Corresponding_Discriminant (D) = Discriminant then + return Node (E); + end if; + + Next_Discriminant (D); + Next_Elmt (E); + end loop; + end; + end if; + + pragma Assert (Nkind (Result) /= N_Defining_Identifier); + return Result; + end Get_Discriminant_Value; + + -------------------------- + -- Has_Range_Constraint -- + -------------------------- + + function Has_Range_Constraint (N : Node_Id) return Boolean is + C : constant Node_Id := Constraint (N); + + begin + if Nkind (C) = N_Range_Constraint then + return True; + + elsif Nkind (C) = N_Digits_Constraint then + return + Is_Decimal_Fixed_Point_Type (Entity (Subtype_Mark (N))) + or else + Present (Range_Constraint (C)); + + elsif Nkind (C) = N_Delta_Constraint then + return Present (Range_Constraint (C)); + + else + return False; + end if; + end Has_Range_Constraint; + + ------------------------ + -- Inherit_Components -- + ------------------------ + + function Inherit_Components + (N : Node_Id; + Parent_Base : Entity_Id; + Derived_Base : Entity_Id; + Is_Tagged : Boolean; + Inherit_Discr : Boolean; + Discs : Elist_Id) return Elist_Id + is + Assoc_List : constant Elist_Id := New_Elmt_List; + + procedure Inherit_Component + (Old_C : Entity_Id; + Plain_Discrim : Boolean := False; + Stored_Discrim : Boolean := False); + -- Inherits component Old_C from Parent_Base to the Derived_Base. If + -- Plain_Discrim is True, Old_C is a discriminant. If Stored_Discrim is + -- True, Old_C is a stored discriminant. If they are both false then + -- Old_C is a regular component. + + ----------------------- + -- Inherit_Component -- + ----------------------- + + procedure Inherit_Component + (Old_C : Entity_Id; + Plain_Discrim : Boolean := False; + Stored_Discrim : Boolean := False) + is + New_C : constant Entity_Id := New_Copy (Old_C); + + Discrim : Entity_Id; + Corr_Discrim : Entity_Id; + + begin + pragma Assert (not Is_Tagged or else not Stored_Discrim); + + Set_Parent (New_C, Parent (Old_C)); + + -- Regular discriminants and components must be inserted in the scope + -- of the Derived_Base. Do it here. + + if not Stored_Discrim then + Enter_Name (New_C); + end if; + + -- For tagged types the Original_Record_Component must point to + -- whatever this field was pointing to in the parent type. This has + -- already been achieved by the call to New_Copy above. + + if not Is_Tagged then + Set_Original_Record_Component (New_C, New_C); + end if; + + -- If we have inherited a component then see if its Etype contains + -- references to Parent_Base discriminants. In this case, replace + -- these references with the constraints given in Discs. We do not + -- do this for the partial view of private types because this is + -- not needed (only the components of the full view will be used + -- for code generation) and cause problem. We also avoid this + -- transformation in some error situations. + + if Ekind (New_C) = E_Component then + if (Is_Private_Type (Derived_Base) + and then not Is_Generic_Type (Derived_Base)) + or else (Is_Empty_Elmt_List (Discs) + and then not Expander_Active) + then + Set_Etype (New_C, Etype (Old_C)); + + else + -- The current component introduces a circularity of the + -- following kind: + + -- limited with Pack_2; + -- package Pack_1 is + -- type T_1 is tagged record + -- Comp : access Pack_2.T_2; + -- ... + -- end record; + -- end Pack_1; + + -- with Pack_1; + -- package Pack_2 is + -- type T_2 is new Pack_1.T_1 with ...; + -- end Pack_2; + + Set_Etype + (New_C, + Constrain_Component_Type + (Old_C, Derived_Base, N, Parent_Base, Discs)); + end if; + end if; + + -- In derived tagged types it is illegal to reference a non + -- discriminant component in the parent type. To catch this, mark + -- these components with an Ekind of E_Void. This will be reset in + -- Record_Type_Definition after processing the record extension of + -- the derived type. + + -- If the declaration is a private extension, there is no further + -- record extension to process, and the components retain their + -- current kind, because they are visible at this point. + + if Is_Tagged and then Ekind (New_C) = E_Component + and then Nkind (N) /= N_Private_Extension_Declaration + then + Set_Ekind (New_C, E_Void); + end if; + + if Plain_Discrim then + Set_Corresponding_Discriminant (New_C, Old_C); + Build_Discriminal (New_C); + + -- If we are explicitly inheriting a stored discriminant it will be + -- completely hidden. + + elsif Stored_Discrim then + Set_Corresponding_Discriminant (New_C, Empty); + Set_Discriminal (New_C, Empty); + Set_Is_Completely_Hidden (New_C); + + -- Set the Original_Record_Component of each discriminant in the + -- derived base to point to the corresponding stored that we just + -- created. + + Discrim := First_Discriminant (Derived_Base); + while Present (Discrim) loop + Corr_Discrim := Corresponding_Discriminant (Discrim); + + -- Corr_Discrim could be missing in an error situation + + if Present (Corr_Discrim) + and then Original_Record_Component (Corr_Discrim) = Old_C + then + Set_Original_Record_Component (Discrim, New_C); + end if; + + Next_Discriminant (Discrim); + end loop; + + Append_Entity (New_C, Derived_Base); + end if; + + if not Is_Tagged then + Append_Elmt (Old_C, Assoc_List); + Append_Elmt (New_C, Assoc_List); + end if; + end Inherit_Component; + + -- Variables local to Inherit_Component + + Loc : constant Source_Ptr := Sloc (N); + + Parent_Discrim : Entity_Id; + Stored_Discrim : Entity_Id; + D : Entity_Id; + Component : Entity_Id; + + -- Start of processing for Inherit_Components + + begin + if not Is_Tagged then + Append_Elmt (Parent_Base, Assoc_List); + Append_Elmt (Derived_Base, Assoc_List); + end if; + + -- Inherit parent discriminants if needed + + if Inherit_Discr then + Parent_Discrim := First_Discriminant (Parent_Base); + while Present (Parent_Discrim) loop + Inherit_Component (Parent_Discrim, Plain_Discrim => True); + Next_Discriminant (Parent_Discrim); + end loop; + end if; + + -- Create explicit stored discrims for untagged types when necessary + + if not Has_Unknown_Discriminants (Derived_Base) + and then Has_Discriminants (Parent_Base) + and then not Is_Tagged + and then + (not Inherit_Discr + or else First_Discriminant (Parent_Base) /= + First_Stored_Discriminant (Parent_Base)) + then + Stored_Discrim := First_Stored_Discriminant (Parent_Base); + while Present (Stored_Discrim) loop + Inherit_Component (Stored_Discrim, Stored_Discrim => True); + Next_Stored_Discriminant (Stored_Discrim); + end loop; + end if; + + -- See if we can apply the second transformation for derived types, as + -- explained in point 6. in the comments above Build_Derived_Record_Type + -- This is achieved by appending Derived_Base discriminants into Discs, + -- which has the side effect of returning a non empty Discs list to the + -- caller of Inherit_Components, which is what we want. This must be + -- done for private derived types if there are explicit stored + -- discriminants, to ensure that we can retrieve the values of the + -- constraints provided in the ancestors. + + if Inherit_Discr + and then Is_Empty_Elmt_List (Discs) + and then Present (First_Discriminant (Derived_Base)) + and then + (not Is_Private_Type (Derived_Base) + or else Is_Completely_Hidden + (First_Stored_Discriminant (Derived_Base)) + or else Is_Generic_Type (Derived_Base)) + then + D := First_Discriminant (Derived_Base); + while Present (D) loop + Append_Elmt (New_Reference_To (D, Loc), Discs); + Next_Discriminant (D); + end loop; + end if; + + -- Finally, inherit non-discriminant components unless they are not + -- visible because defined or inherited from the full view of the + -- parent. Don't inherit the _parent field of the parent type. + + Component := First_Entity (Parent_Base); + while Present (Component) loop + + -- Ada 2005 (AI-251): Do not inherit components associated with + -- secondary tags of the parent. + + if Ekind (Component) = E_Component + and then Present (Related_Type (Component)) + then + null; + + elsif Ekind (Component) /= E_Component + or else Chars (Component) = Name_uParent + then + null; + + -- If the derived type is within the parent type's declarative + -- region, then the components can still be inherited even though + -- they aren't visible at this point. This can occur for cases + -- such as within public child units where the components must + -- become visible upon entering the child unit's private part. + + elsif not Is_Visible_Component (Component) + and then not In_Open_Scopes (Scope (Parent_Base)) + then + null; + + elsif Ekind_In (Derived_Base, E_Private_Type, + E_Limited_Private_Type) + then + null; + + else + Inherit_Component (Component); + end if; + + Next_Entity (Component); + end loop; + + -- For tagged derived types, inherited discriminants cannot be used in + -- component declarations of the record extension part. To achieve this + -- we mark the inherited discriminants as not visible. + + if Is_Tagged and then Inherit_Discr then + D := First_Discriminant (Derived_Base); + while Present (D) loop + Set_Is_Immediately_Visible (D, False); + Next_Discriminant (D); + end loop; + end if; + + return Assoc_List; + end Inherit_Components; + + ----------------------- + -- Is_Null_Extension -- + ----------------------- + + function Is_Null_Extension (T : Entity_Id) return Boolean is + Type_Decl : constant Node_Id := Parent (Base_Type (T)); + Comp_List : Node_Id; + Comp : Node_Id; + + begin + if Nkind (Type_Decl) /= N_Full_Type_Declaration + or else not Is_Tagged_Type (T) + or else Nkind (Type_Definition (Type_Decl)) /= + N_Derived_Type_Definition + or else No (Record_Extension_Part (Type_Definition (Type_Decl))) + then + return False; + end if; + + Comp_List := + Component_List (Record_Extension_Part (Type_Definition (Type_Decl))); + + if Present (Discriminant_Specifications (Type_Decl)) then + return False; + + elsif Present (Comp_List) + and then Is_Non_Empty_List (Component_Items (Comp_List)) + then + Comp := First (Component_Items (Comp_List)); + + -- Only user-defined components are relevant. The component list + -- may also contain a parent component and internal components + -- corresponding to secondary tags, but these do not determine + -- whether this is a null extension. + + while Present (Comp) loop + if Comes_From_Source (Comp) then + return False; + end if; + + Next (Comp); + end loop; + + return True; + else + return True; + end if; + end Is_Null_Extension; + + ------------------------------ + -- Is_Valid_Constraint_Kind -- + ------------------------------ + + function Is_Valid_Constraint_Kind + (T_Kind : Type_Kind; + Constraint_Kind : Node_Kind) return Boolean + is + begin + case T_Kind is + when Enumeration_Kind | + Integer_Kind => + return Constraint_Kind = N_Range_Constraint; + + when Decimal_Fixed_Point_Kind => + return Nkind_In (Constraint_Kind, N_Digits_Constraint, + N_Range_Constraint); + + when Ordinary_Fixed_Point_Kind => + return Nkind_In (Constraint_Kind, N_Delta_Constraint, + N_Range_Constraint); + + when Float_Kind => + return Nkind_In (Constraint_Kind, N_Digits_Constraint, + N_Range_Constraint); + + when Access_Kind | + Array_Kind | + E_Record_Type | + E_Record_Subtype | + Class_Wide_Kind | + E_Incomplete_Type | + Private_Kind | + Concurrent_Kind => + return Constraint_Kind = N_Index_Or_Discriminant_Constraint; + + when others => + return True; -- Error will be detected later + end case; + end Is_Valid_Constraint_Kind; + + -------------------------- + -- Is_Visible_Component -- + -------------------------- + + function Is_Visible_Component (C : Entity_Id) return Boolean is + Original_Comp : Entity_Id := Empty; + Original_Scope : Entity_Id; + Type_Scope : Entity_Id; + + function Is_Local_Type (Typ : Entity_Id) return Boolean; + -- Check whether parent type of inherited component is declared locally, + -- possibly within a nested package or instance. The current scope is + -- the derived record itself. + + ------------------- + -- Is_Local_Type -- + ------------------- + + function Is_Local_Type (Typ : Entity_Id) return Boolean is + Scop : Entity_Id; + + begin + Scop := Scope (Typ); + while Present (Scop) + and then Scop /= Standard_Standard + loop + if Scop = Scope (Current_Scope) then + return True; + end if; + + Scop := Scope (Scop); + end loop; + + return False; + end Is_Local_Type; + + -- Start of processing for Is_Visible_Component + + begin + if Ekind_In (C, E_Component, E_Discriminant) then + Original_Comp := Original_Record_Component (C); + end if; + + if No (Original_Comp) then + + -- Premature usage, or previous error + + return False; + + else + Original_Scope := Scope (Original_Comp); + Type_Scope := Scope (Base_Type (Scope (C))); + end if; + + -- This test only concerns tagged types + + if not Is_Tagged_Type (Original_Scope) then + return True; + + -- If it is _Parent or _Tag, there is no visibility issue + + elsif not Comes_From_Source (Original_Comp) then + return True; + + -- If we are in the body of an instantiation, the component is visible + -- even when the parent type (possibly defined in an enclosing unit or + -- in a parent unit) might not. + + elsif In_Instance_Body then + return True; + + -- Discriminants are always visible + + elsif Ekind (Original_Comp) = E_Discriminant + and then not Has_Unknown_Discriminants (Original_Scope) + then + return True; + + -- If the component has been declared in an ancestor which is currently + -- a private type, then it is not visible. The same applies if the + -- component's containing type is not in an open scope and the original + -- component's enclosing type is a visible full view of a private type + -- (which can occur in cases where an attempt is being made to reference + -- a component in a sibling package that is inherited from a visible + -- component of a type in an ancestor package; the component in the + -- sibling package should not be visible even though the component it + -- inherited from is visible). This does not apply however in the case + -- where the scope of the type is a private child unit, or when the + -- parent comes from a local package in which the ancestor is currently + -- visible. The latter suppression of visibility is needed for cases + -- that are tested in B730006. + + elsif Is_Private_Type (Original_Scope) + or else + (not Is_Private_Descendant (Type_Scope) + and then not In_Open_Scopes (Type_Scope) + and then Has_Private_Declaration (Original_Scope)) + then + -- If the type derives from an entity in a formal package, there + -- are no additional visible components. + + if Nkind (Original_Node (Unit_Declaration_Node (Type_Scope))) = + N_Formal_Package_Declaration + then + return False; + + -- if we are not in the private part of the current package, there + -- are no additional visible components. + + elsif Ekind (Scope (Current_Scope)) = E_Package + and then not In_Private_Part (Scope (Current_Scope)) + then + return False; + else + return + Is_Child_Unit (Cunit_Entity (Current_Sem_Unit)) + and then In_Open_Scopes (Scope (Original_Scope)) + and then Is_Local_Type (Type_Scope); + end if; + + -- There is another weird way in which a component may be invisible + -- when the private and the full view are not derived from the same + -- ancestor. Here is an example : + + -- type A1 is tagged record F1 : integer; end record; + -- type A2 is new A1 with record F2 : integer; end record; + -- type T is new A1 with private; + -- private + -- type T is new A2 with null record; + + -- In this case, the full view of T inherits F1 and F2 but the private + -- view inherits only F1 + + else + declare + Ancestor : Entity_Id := Scope (C); + + begin + loop + if Ancestor = Original_Scope then + return True; + elsif Ancestor = Etype (Ancestor) then + return False; + end if; + + Ancestor := Etype (Ancestor); + end loop; + end; + end if; + end Is_Visible_Component; + + -------------------------- + -- Make_Class_Wide_Type -- + -------------------------- + + procedure Make_Class_Wide_Type (T : Entity_Id) is + CW_Type : Entity_Id; + CW_Name : Name_Id; + Next_E : Entity_Id; + + begin + -- The class wide type can have been defined by the partial view, in + -- which case everything is already done. + + if Present (Class_Wide_Type (T)) then + return; + end if; + + CW_Type := + New_External_Entity (E_Void, Scope (T), Sloc (T), T, 'C', 0, 'T'); + + -- Inherit root type characteristics + + CW_Name := Chars (CW_Type); + Next_E := Next_Entity (CW_Type); + Copy_Node (T, CW_Type); + Set_Comes_From_Source (CW_Type, False); + Set_Chars (CW_Type, CW_Name); + Set_Parent (CW_Type, Parent (T)); + Set_Next_Entity (CW_Type, Next_E); + + -- Ensure we have a new freeze node for the class-wide type. The partial + -- view may have freeze action of its own, requiring a proper freeze + -- node, and the same freeze node cannot be shared between the two + -- types. + + Set_Has_Delayed_Freeze (CW_Type); + Set_Freeze_Node (CW_Type, Empty); + + -- Customize the class-wide type: It has no prim. op., it cannot be + -- abstract and its Etype points back to the specific root type. + + Set_Ekind (CW_Type, E_Class_Wide_Type); + Set_Is_Tagged_Type (CW_Type, True); + Set_Direct_Primitive_Operations (CW_Type, New_Elmt_List); + Set_Is_Abstract_Type (CW_Type, False); + Set_Is_Constrained (CW_Type, False); + Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T)); + + if Ekind (T) = E_Class_Wide_Subtype then + Set_Etype (CW_Type, Etype (Base_Type (T))); + else + Set_Etype (CW_Type, T); + end if; + + -- If this is the class_wide type of a constrained subtype, it does + -- not have discriminants. + + Set_Has_Discriminants (CW_Type, + Has_Discriminants (T) and then not Is_Constrained (T)); + + Set_Has_Unknown_Discriminants (CW_Type, True); + Set_Class_Wide_Type (T, CW_Type); + Set_Equivalent_Type (CW_Type, Empty); + + -- The class-wide type of a class-wide type is itself (RM 3.9(14)) + + Set_Class_Wide_Type (CW_Type, CW_Type); + end Make_Class_Wide_Type; + + ---------------- + -- Make_Index -- + ---------------- + + procedure Make_Index + (I : Node_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id := Empty; + Suffix_Index : Nat := 1) + is + R : Node_Id; + T : Entity_Id; + Def_Id : Entity_Id := Empty; + Found : Boolean := False; + + begin + -- For a discrete range used in a constrained array definition and + -- defined by a range, an implicit conversion to the predefined type + -- INTEGER is assumed if each bound is either a numeric literal, a named + -- number, or an attribute, and the type of both bounds (prior to the + -- implicit conversion) is the type universal_integer. Otherwise, both + -- bounds must be of the same discrete type, other than universal + -- integer; this type must be determinable independently of the + -- context, but using the fact that the type must be discrete and that + -- both bounds must have the same type. + + -- Character literals also have a universal type in the absence of + -- of additional context, and are resolved to Standard_Character. + + if Nkind (I) = N_Range then + + -- The index is given by a range constraint. The bounds are known + -- to be of a consistent type. + + if not Is_Overloaded (I) then + T := Etype (I); + + -- For universal bounds, choose the specific predefined type + + if T = Universal_Integer then + T := Standard_Integer; + + elsif T = Any_Character then + Ambiguous_Character (Low_Bound (I)); + + T := Standard_Character; + end if; + + -- The node may be overloaded because some user-defined operators + -- are available, but if a universal interpretation exists it is + -- also the selected one. + + elsif Universal_Interpretation (I) = Universal_Integer then + T := Standard_Integer; + + else + T := Any_Type; + + declare + Ind : Interp_Index; + It : Interp; + + begin + Get_First_Interp (I, Ind, It); + while Present (It.Typ) loop + if Is_Discrete_Type (It.Typ) then + + if Found + and then not Covers (It.Typ, T) + and then not Covers (T, It.Typ) + then + Error_Msg_N ("ambiguous bounds in discrete range", I); + exit; + else + T := It.Typ; + Found := True; + end if; + end if; + + Get_Next_Interp (Ind, It); + end loop; + + if T = Any_Type then + Error_Msg_N ("discrete type required for range", I); + Set_Etype (I, Any_Type); + return; + + elsif T = Universal_Integer then + T := Standard_Integer; + end if; + end; + end if; + + if not Is_Discrete_Type (T) then + Error_Msg_N ("discrete type required for range", I); + Set_Etype (I, Any_Type); + return; + end if; + + if Nkind (Low_Bound (I)) = N_Attribute_Reference + and then Attribute_Name (Low_Bound (I)) = Name_First + and then Is_Entity_Name (Prefix (Low_Bound (I))) + and then Is_Type (Entity (Prefix (Low_Bound (I)))) + and then Is_Discrete_Type (Entity (Prefix (Low_Bound (I)))) + then + -- The type of the index will be the type of the prefix, as long + -- as the upper bound is 'Last of the same type. + + Def_Id := Entity (Prefix (Low_Bound (I))); + + if Nkind (High_Bound (I)) /= N_Attribute_Reference + or else Attribute_Name (High_Bound (I)) /= Name_Last + or else not Is_Entity_Name (Prefix (High_Bound (I))) + or else Entity (Prefix (High_Bound (I))) /= Def_Id + then + Def_Id := Empty; + end if; + end if; + + R := I; + Process_Range_Expr_In_Decl (R, T); + + elsif Nkind (I) = N_Subtype_Indication then + + -- The index is given by a subtype with a range constraint + + T := Base_Type (Entity (Subtype_Mark (I))); + + if not Is_Discrete_Type (T) then + Error_Msg_N ("discrete type required for range", I); + Set_Etype (I, Any_Type); + return; + end if; + + R := Range_Expression (Constraint (I)); + + Resolve (R, T); + Process_Range_Expr_In_Decl (R, Entity (Subtype_Mark (I))); + + elsif Nkind (I) = N_Attribute_Reference then + + -- The parser guarantees that the attribute is a RANGE attribute + + -- If the node denotes the range of a type mark, that is also the + -- resulting type, and we do no need to create an Itype for it. + + if Is_Entity_Name (Prefix (I)) + and then Comes_From_Source (I) + and then Is_Type (Entity (Prefix (I))) + and then Is_Discrete_Type (Entity (Prefix (I))) + then + Def_Id := Entity (Prefix (I)); + end if; + + Analyze_And_Resolve (I); + T := Etype (I); + R := I; + + -- If none of the above, must be a subtype. We convert this to a + -- range attribute reference because in the case of declared first + -- named subtypes, the types in the range reference can be different + -- from the type of the entity. A range attribute normalizes the + -- reference and obtains the correct types for the bounds. + + -- This transformation is in the nature of an expansion, is only + -- done if expansion is active. In particular, it is not done on + -- formal generic types, because we need to retain the name of the + -- original index for instantiation purposes. + + else + if not Is_Entity_Name (I) or else not Is_Type (Entity (I)) then + Error_Msg_N ("invalid subtype mark in discrete range ", I); + Set_Etype (I, Any_Integer); + return; + + else + -- The type mark may be that of an incomplete type. It is only + -- now that we can get the full view, previous analysis does + -- not look specifically for a type mark. + + Set_Entity (I, Get_Full_View (Entity (I))); + Set_Etype (I, Entity (I)); + Def_Id := Entity (I); + + if not Is_Discrete_Type (Def_Id) then + Error_Msg_N ("discrete type required for index", I); + Set_Etype (I, Any_Type); + return; + end if; + end if; + + if Expander_Active then + Rewrite (I, + Make_Attribute_Reference (Sloc (I), + Attribute_Name => Name_Range, + Prefix => Relocate_Node (I))); + + -- The original was a subtype mark that does not freeze. This + -- means that the rewritten version must not freeze either. + + Set_Must_Not_Freeze (I); + Set_Must_Not_Freeze (Prefix (I)); + + -- Is order critical??? if so, document why, if not + -- use Analyze_And_Resolve + + Analyze_And_Resolve (I); + T := Etype (I); + R := I; + + -- If expander is inactive, type is legal, nothing else to construct + + else + return; + end if; + end if; + + if not Is_Discrete_Type (T) then + Error_Msg_N ("discrete type required for range", I); + Set_Etype (I, Any_Type); + return; + + elsif T = Any_Type then + Set_Etype (I, Any_Type); + return; + end if; + + -- We will now create the appropriate Itype to describe the range, but + -- first a check. If we originally had a subtype, then we just label + -- the range with this subtype. Not only is there no need to construct + -- a new subtype, but it is wrong to do so for two reasons: + + -- 1. A legality concern, if we have a subtype, it must not freeze, + -- and the Itype would cause freezing incorrectly + + -- 2. An efficiency concern, if we created an Itype, it would not be + -- recognized as the same type for the purposes of eliminating + -- checks in some circumstances. + + -- We signal this case by setting the subtype entity in Def_Id + + if No (Def_Id) then + Def_Id := + Create_Itype (E_Void, Related_Nod, Related_Id, 'D', Suffix_Index); + Set_Etype (Def_Id, Base_Type (T)); + + if Is_Signed_Integer_Type (T) then + Set_Ekind (Def_Id, E_Signed_Integer_Subtype); + + elsif Is_Modular_Integer_Type (T) then + Set_Ekind (Def_Id, E_Modular_Integer_Subtype); + + else + Set_Ekind (Def_Id, E_Enumeration_Subtype); + Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); + Set_First_Literal (Def_Id, First_Literal (T)); + end if; + + Set_Size_Info (Def_Id, (T)); + Set_RM_Size (Def_Id, RM_Size (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + + Set_Scalar_Range (Def_Id, R); + Conditional_Delay (Def_Id, T); + + -- In the subtype indication case, if the immediate parent of the + -- new subtype is non-static, then the subtype we create is non- + -- static, even if its bounds are static. + + if Nkind (I) = N_Subtype_Indication + and then not Is_Static_Subtype (Entity (Subtype_Mark (I))) + then + Set_Is_Non_Static_Subtype (Def_Id); + end if; + end if; + + -- Final step is to label the index with this constructed type + + Set_Etype (I, Def_Id); + end Make_Index; + + ------------------------------ + -- Modular_Type_Declaration -- + ------------------------------ + + procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id) is + Mod_Expr : constant Node_Id := Expression (Def); + M_Val : Uint; + + procedure Set_Modular_Size (Bits : Int); + -- Sets RM_Size to Bits, and Esize to normal word size above this + + ---------------------- + -- Set_Modular_Size -- + ---------------------- + + procedure Set_Modular_Size (Bits : Int) is + begin + Set_RM_Size (T, UI_From_Int (Bits)); + + if Bits <= 8 then + Init_Esize (T, 8); + + elsif Bits <= 16 then + Init_Esize (T, 16); + + elsif Bits <= 32 then + Init_Esize (T, 32); + + else + Init_Esize (T, System_Max_Binary_Modulus_Power); + end if; + + if not Non_Binary_Modulus (T) + and then Esize (T) = RM_Size (T) + then + Set_Is_Known_Valid (T); + end if; + end Set_Modular_Size; + + -- Start of processing for Modular_Type_Declaration + + begin + Analyze_And_Resolve (Mod_Expr, Any_Integer); + Set_Etype (T, T); + Set_Ekind (T, E_Modular_Integer_Type); + Init_Alignment (T); + Set_Is_Constrained (T); + + if not Is_OK_Static_Expression (Mod_Expr) then + Flag_Non_Static_Expr + ("non-static expression used for modular type bound!", Mod_Expr); + M_Val := 2 ** System_Max_Binary_Modulus_Power; + else + M_Val := Expr_Value (Mod_Expr); + end if; + + if M_Val < 1 then + Error_Msg_N ("modulus value must be positive", Mod_Expr); + M_Val := 2 ** System_Max_Binary_Modulus_Power; + end if; + + Set_Modulus (T, M_Val); + + -- Create bounds for the modular type based on the modulus given in + -- the type declaration and then analyze and resolve those bounds. + + Set_Scalar_Range (T, + Make_Range (Sloc (Mod_Expr), + Low_Bound => Make_Integer_Literal (Sloc (Mod_Expr), 0), + High_Bound => Make_Integer_Literal (Sloc (Mod_Expr), M_Val - 1))); + + -- Properly analyze the literals for the range. We do this manually + -- because we can't go calling Resolve, since we are resolving these + -- bounds with the type, and this type is certainly not complete yet! + + Set_Etype (Low_Bound (Scalar_Range (T)), T); + Set_Etype (High_Bound (Scalar_Range (T)), T); + Set_Is_Static_Expression (Low_Bound (Scalar_Range (T))); + Set_Is_Static_Expression (High_Bound (Scalar_Range (T))); + + -- Loop through powers of two to find number of bits required + + for Bits in Int range 0 .. System_Max_Binary_Modulus_Power loop + + -- Binary case + + if M_Val = 2 ** Bits then + Set_Modular_Size (Bits); + return; + + -- Non-binary case + + elsif M_Val < 2 ** Bits then + Set_Non_Binary_Modulus (T); + + if Bits > System_Max_Nonbinary_Modulus_Power then + Error_Msg_Uint_1 := + UI_From_Int (System_Max_Nonbinary_Modulus_Power); + Error_Msg_F + ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr); + Set_Modular_Size (System_Max_Binary_Modulus_Power); + return; + + else + -- In the non-binary case, set size as per RM 13.3(55) + + Set_Modular_Size (Bits); + return; + end if; + end if; + + end loop; + + -- If we fall through, then the size exceed System.Max_Binary_Modulus + -- so we just signal an error and set the maximum size. + + Error_Msg_Uint_1 := UI_From_Int (System_Max_Binary_Modulus_Power); + Error_Msg_F ("modulus exceeds limit (2 '*'*^)", Mod_Expr); + + Set_Modular_Size (System_Max_Binary_Modulus_Power); + Init_Alignment (T); + + end Modular_Type_Declaration; + + -------------------------- + -- New_Concatenation_Op -- + -------------------------- + + procedure New_Concatenation_Op (Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); + Op : Entity_Id; + + function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id; + -- Create abbreviated declaration for the formal of a predefined + -- Operator 'Op' of type 'Typ' + + -------------------- + -- Make_Op_Formal -- + -------------------- + + function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id is + Formal : Entity_Id; + begin + Formal := New_Internal_Entity (E_In_Parameter, Op, Loc, 'P'); + Set_Etype (Formal, Typ); + Set_Mechanism (Formal, Default_Mechanism); + return Formal; + end Make_Op_Formal; + + -- Start of processing for New_Concatenation_Op + + begin + Op := Make_Defining_Operator_Symbol (Loc, Name_Op_Concat); + + Set_Ekind (Op, E_Operator); + Set_Scope (Op, Current_Scope); + Set_Etype (Op, Typ); + Set_Homonym (Op, Get_Name_Entity_Id (Name_Op_Concat)); + Set_Is_Immediately_Visible (Op); + Set_Is_Intrinsic_Subprogram (Op); + Set_Has_Completion (Op); + Append_Entity (Op, Current_Scope); + + Set_Name_Entity_Id (Name_Op_Concat, Op); + + Append_Entity (Make_Op_Formal (Typ, Op), Op); + Append_Entity (Make_Op_Formal (Typ, Op), Op); + end New_Concatenation_Op; + + ------------------------- + -- OK_For_Limited_Init -- + ------------------------- + + -- ???Check all calls of this, and compare the conditions under which it's + -- called. + + function OK_For_Limited_Init + (Typ : Entity_Id; + Exp : Node_Id) return Boolean + is + begin + return Is_CPP_Constructor_Call (Exp) + or else (Ada_Version >= Ada_2005 + and then not Debug_Flag_Dot_L + and then OK_For_Limited_Init_In_05 (Typ, Exp)); + end OK_For_Limited_Init; + + ------------------------------- + -- OK_For_Limited_Init_In_05 -- + ------------------------------- + + function OK_For_Limited_Init_In_05 + (Typ : Entity_Id; + Exp : Node_Id) return Boolean + is + begin + -- An object of a limited interface type can be initialized with any + -- expression of a nonlimited descendant type. + + if Is_Class_Wide_Type (Typ) + and then Is_Limited_Interface (Typ) + and then not Is_Limited_Type (Etype (Exp)) + then + return True; + end if; + + -- Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in + -- case of limited aggregates (including extension aggregates), and + -- function calls. The function call may have been given in prefixed + -- notation, in which case the original node is an indexed component. + -- If the function is parameterless, the original node was an explicit + -- dereference. + + case Nkind (Original_Node (Exp)) is + when N_Aggregate | N_Extension_Aggregate | N_Function_Call | N_Op => + return True; + + when N_Qualified_Expression => + return + OK_For_Limited_Init_In_05 + (Typ, Expression (Original_Node (Exp))); + + -- Ada 2005 (AI-251): If a class-wide interface object is initialized + -- with a function call, the expander has rewritten the call into an + -- N_Type_Conversion node to force displacement of the pointer to + -- reference the component containing the secondary dispatch table. + -- Otherwise a type conversion is not a legal context. + -- A return statement for a build-in-place function returning a + -- synchronized type also introduces an unchecked conversion. + + when N_Type_Conversion | + N_Unchecked_Type_Conversion => + return not Comes_From_Source (Exp) + and then + OK_For_Limited_Init_In_05 + (Typ, Expression (Original_Node (Exp))); + + when N_Indexed_Component | + N_Selected_Component | + N_Explicit_Dereference => + return Nkind (Exp) = N_Function_Call; + + -- A use of 'Input is a function call, hence allowed. Normally the + -- attribute will be changed to a call, but the attribute by itself + -- can occur with -gnatc. + + when N_Attribute_Reference => + return Attribute_Name (Original_Node (Exp)) = Name_Input; + + when others => + return False; + end case; + end OK_For_Limited_Init_In_05; + + ------------------------------------------- + -- Ordinary_Fixed_Point_Type_Declaration -- + ------------------------------------------- + + procedure Ordinary_Fixed_Point_Type_Declaration + (T : Entity_Id; + Def : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Def); + Delta_Expr : constant Node_Id := Delta_Expression (Def); + RRS : constant Node_Id := Real_Range_Specification (Def); + Implicit_Base : Entity_Id; + Delta_Val : Ureal; + Small_Val : Ureal; + Low_Val : Ureal; + High_Val : Ureal; + + begin + Check_Restriction (No_Fixed_Point, Def); + + -- Create implicit base type + + Implicit_Base := + Create_Itype (E_Ordinary_Fixed_Point_Type, Parent (Def), T, 'B'); + Set_Etype (Implicit_Base, Implicit_Base); + + -- Analyze and process delta expression + + Analyze_And_Resolve (Delta_Expr, Any_Real); + + Check_Delta_Expression (Delta_Expr); + Delta_Val := Expr_Value_R (Delta_Expr); + + Set_Delta_Value (Implicit_Base, Delta_Val); + + -- Compute default small from given delta, which is the largest power + -- of two that does not exceed the given delta value. + + declare + Tmp : Ureal; + Scale : Int; + + begin + Tmp := Ureal_1; + Scale := 0; + + if Delta_Val < Ureal_1 then + while Delta_Val < Tmp loop + Tmp := Tmp / Ureal_2; + Scale := Scale + 1; + end loop; + + else + loop + Tmp := Tmp * Ureal_2; + exit when Tmp > Delta_Val; + Scale := Scale - 1; + end loop; + end if; + + Small_Val := UR_From_Components (Uint_1, UI_From_Int (Scale), 2); + end; + + Set_Small_Value (Implicit_Base, Small_Val); + + -- If no range was given, set a dummy range + + if RRS <= Empty_Or_Error then + Low_Val := -Small_Val; + High_Val := Small_Val; + + -- Otherwise analyze and process given range + + else + declare + Low : constant Node_Id := Low_Bound (RRS); + High : constant Node_Id := High_Bound (RRS); + + begin + Analyze_And_Resolve (Low, Any_Real); + Analyze_And_Resolve (High, Any_Real); + Check_Real_Bound (Low); + Check_Real_Bound (High); + + -- Obtain and set the range + + Low_Val := Expr_Value_R (Low); + High_Val := Expr_Value_R (High); + + if Low_Val > High_Val then + Error_Msg_NE ("?fixed point type& has null range", Def, T); + end if; + end; + end if; + + -- The range for both the implicit base and the declared first subtype + -- cannot be set yet, so we use the special routine Set_Fixed_Range to + -- set a temporary range in place. Note that the bounds of the base + -- type will be widened to be symmetrical and to fill the available + -- bits when the type is frozen. + + -- We could do this with all discrete types, and probably should, but + -- we absolutely have to do it for fixed-point, since the end-points + -- of the range and the size are determined by the small value, which + -- could be reset before the freeze point. + + Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val); + Set_Fixed_Range (T, Loc, Low_Val, High_Val); + + -- Complete definition of first subtype + + Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype); + Set_Etype (T, Implicit_Base); + Init_Size_Align (T); + Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); + Set_Small_Value (T, Small_Val); + Set_Delta_Value (T, Delta_Val); + Set_Is_Constrained (T); + + end Ordinary_Fixed_Point_Type_Declaration; + + ---------------------------------------- + -- Prepare_Private_Subtype_Completion -- + ---------------------------------------- + + procedure Prepare_Private_Subtype_Completion + (Id : Entity_Id; + Related_Nod : Node_Id) + is + Id_B : constant Entity_Id := Base_Type (Id); + Full_B : constant Entity_Id := Full_View (Id_B); + Full : Entity_Id; + + begin + if Present (Full_B) then + + -- The Base_Type is already completed, we can complete the subtype + -- now. We have to create a new entity with the same name, Thus we + -- can't use Create_Itype. + + -- This is messy, should be fixed ??? + + Full := Make_Defining_Identifier (Sloc (Id), Chars (Id)); + Set_Is_Itype (Full); + Set_Associated_Node_For_Itype (Full, Related_Nod); + Complete_Private_Subtype (Id, Full, Full_B, Related_Nod); + end if; + + -- The parent subtype may be private, but the base might not, in some + -- nested instances. In that case, the subtype does not need to be + -- exchanged. It would still be nice to make private subtypes and their + -- bases consistent at all times ??? + + if Is_Private_Type (Id_B) then + Append_Elmt (Id, Private_Dependents (Id_B)); + end if; + + end Prepare_Private_Subtype_Completion; + + --------------------------- + -- Process_Discriminants -- + --------------------------- + + procedure Process_Discriminants + (N : Node_Id; + Prev : Entity_Id := Empty) + is + Elist : constant Elist_Id := New_Elmt_List; + Id : Node_Id; + Discr : Node_Id; + Discr_Number : Uint; + Discr_Type : Entity_Id; + Default_Present : Boolean := False; + Default_Not_Present : Boolean := False; + + begin + -- A composite type other than an array type can have discriminants. + -- On entry, the current scope is the composite type. + + -- The discriminants are initially entered into the scope of the type + -- via Enter_Name with the default Ekind of E_Void to prevent premature + -- use, as explained at the end of this procedure. + + Discr := First (Discriminant_Specifications (N)); + while Present (Discr) loop + Enter_Name (Defining_Identifier (Discr)); + + -- For navigation purposes we add a reference to the discriminant + -- in the entity for the type. If the current declaration is a + -- completion, place references on the partial view. Otherwise the + -- type is the current scope. + + if Present (Prev) then + + -- The references go on the partial view, if present. If the + -- partial view has discriminants, the references have been + -- generated already. + + if not Has_Discriminants (Prev) then + Generate_Reference (Prev, Defining_Identifier (Discr), 'd'); + end if; + else + Generate_Reference + (Current_Scope, Defining_Identifier (Discr), 'd'); + end if; + + if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then + Discr_Type := Access_Definition (Discr, Discriminant_Type (Discr)); + + -- Ada 2005 (AI-254) + + if Present (Access_To_Subprogram_Definition + (Discriminant_Type (Discr))) + and then Protected_Present (Access_To_Subprogram_Definition + (Discriminant_Type (Discr))) + then + Discr_Type := + Replace_Anonymous_Access_To_Protected_Subprogram (Discr); + end if; + + else + Find_Type (Discriminant_Type (Discr)); + Discr_Type := Etype (Discriminant_Type (Discr)); + + if Error_Posted (Discriminant_Type (Discr)) then + Discr_Type := Any_Type; + end if; + end if; + + if Is_Access_Type (Discr_Type) then + + -- Ada 2005 (AI-230): Access discriminant allowed in non-limited + -- record types + + if Ada_Version < Ada_2005 then + Check_Access_Discriminant_Requires_Limited + (Discr, Discriminant_Type (Discr)); + end if; + + if Ada_Version = Ada_83 and then Comes_From_Source (Discr) then + Error_Msg_N + ("(Ada 83) access discriminant not allowed", Discr); + end if; + + elsif not Is_Discrete_Type (Discr_Type) then + Error_Msg_N ("discriminants must have a discrete or access type", + Discriminant_Type (Discr)); + end if; + + Set_Etype (Defining_Identifier (Discr), Discr_Type); + + -- If a discriminant specification includes the assignment compound + -- delimiter followed by an expression, the expression is the default + -- expression of the discriminant; the default expression must be of + -- the type of the discriminant. (RM 3.7.1) Since this expression is + -- a default expression, we do the special preanalysis, since this + -- expression does not freeze (see "Handling of Default and Per- + -- Object Expressions" in spec of package Sem). + + if Present (Expression (Discr)) then + Preanalyze_Spec_Expression (Expression (Discr), Discr_Type); + + if Nkind (N) = N_Formal_Type_Declaration then + Error_Msg_N + ("discriminant defaults not allowed for formal type", + Expression (Discr)); + + -- Flag an error for a tagged type with defaulted discriminants, + -- excluding limited tagged types when compiling for Ada 2012 + -- (see AI05-0214). + + elsif Is_Tagged_Type (Current_Scope) + and then (not Is_Limited_Type (Current_Scope) + or else Ada_Version < Ada_2012) + and then Comes_From_Source (N) + then + -- Note: see similar test in Check_Or_Process_Discriminants, to + -- handle the (illegal) case of the completion of an untagged + -- view with discriminants with defaults by a tagged full view. + -- We skip the check if Discr does not come from source, to + -- account for the case of an untagged derived type providing + -- defaults for a renamed discriminant from a private untagged + -- ancestor with a tagged full view (ACATS B460006). + + if Ada_Version >= Ada_2012 then + Error_Msg_N + ("discriminants of nonlimited tagged type cannot have" + & " defaults", + Expression (Discr)); + else + Error_Msg_N + ("discriminants of tagged type cannot have defaults", + Expression (Discr)); + end if; + + else + Default_Present := True; + Append_Elmt (Expression (Discr), Elist); + + -- Tag the defining identifiers for the discriminants with + -- their corresponding default expressions from the tree. + + Set_Discriminant_Default_Value + (Defining_Identifier (Discr), Expression (Discr)); + end if; + + else + Default_Not_Present := True; + end if; + + -- Ada 2005 (AI-231): Create an Itype that is a duplicate of + -- Discr_Type but with the null-exclusion attribute + + if Ada_Version >= Ada_2005 then + + -- Ada 2005 (AI-231): Static checks + + if Can_Never_Be_Null (Discr_Type) then + Null_Exclusion_Static_Checks (Discr); + + elsif Is_Access_Type (Discr_Type) + and then Null_Exclusion_Present (Discr) + + -- No need to check itypes because in their case this check + -- was done at their point of creation + + and then not Is_Itype (Discr_Type) + then + if Can_Never_Be_Null (Discr_Type) then + Error_Msg_NE + ("`NOT NULL` not allowed (& already excludes null)", + Discr, + Discr_Type); + end if; + + Set_Etype (Defining_Identifier (Discr), + Create_Null_Excluding_Itype + (T => Discr_Type, + Related_Nod => Discr)); + + -- Check for improper null exclusion if the type is otherwise + -- legal for a discriminant. + + elsif Null_Exclusion_Present (Discr) + and then Is_Discrete_Type (Discr_Type) + then + Error_Msg_N + ("null exclusion can only apply to an access type", Discr); + end if; + + -- Ada 2005 (AI-402): access discriminants of nonlimited types + -- can't have defaults. Synchronized types, or types that are + -- explicitly limited are fine, but special tests apply to derived + -- types in generics: in a generic body we have to assume the + -- worst, and therefore defaults are not allowed if the parent is + -- a generic formal private type (see ACATS B370001). + + if Is_Access_Type (Discr_Type) then + if Ekind (Discr_Type) /= E_Anonymous_Access_Type + or else not Default_Present + or else Is_Limited_Record (Current_Scope) + or else Is_Concurrent_Type (Current_Scope) + or else Is_Concurrent_Record_Type (Current_Scope) + or else Ekind (Current_Scope) = E_Limited_Private_Type + then + if not Is_Derived_Type (Current_Scope) + or else not Is_Generic_Type (Etype (Current_Scope)) + or else not In_Package_Body (Scope (Etype (Current_Scope))) + or else Limited_Present + (Type_Definition (Parent (Current_Scope))) + then + null; + + else + Error_Msg_N ("access discriminants of nonlimited types", + Expression (Discr)); + Error_Msg_N ("\cannot have defaults", Expression (Discr)); + end if; + + elsif Present (Expression (Discr)) then + Error_Msg_N + ("(Ada 2005) access discriminants of nonlimited types", + Expression (Discr)); + Error_Msg_N ("\cannot have defaults", Expression (Discr)); + end if; + end if; + end if; + + Next (Discr); + end loop; + + -- An element list consisting of the default expressions of the + -- discriminants is constructed in the above loop and used to set + -- the Discriminant_Constraint attribute for the type. If an object + -- is declared of this (record or task) type without any explicit + -- discriminant constraint given, this element list will form the + -- actual parameters for the corresponding initialization procedure + -- for the type. + + Set_Discriminant_Constraint (Current_Scope, Elist); + Set_Stored_Constraint (Current_Scope, No_Elist); + + -- Default expressions must be provided either for all or for none + -- of the discriminants of a discriminant part. (RM 3.7.1) + + if Default_Present and then Default_Not_Present then + Error_Msg_N + ("incomplete specification of defaults for discriminants", N); + end if; + + -- The use of the name of a discriminant is not allowed in default + -- expressions of a discriminant part if the specification of the + -- discriminant is itself given in the discriminant part. (RM 3.7.1) + + -- To detect this, the discriminant names are entered initially with an + -- Ekind of E_Void (which is the default Ekind given by Enter_Name). Any + -- attempt to use a void entity (for example in an expression that is + -- type-checked) produces the error message: premature usage. Now after + -- completing the semantic analysis of the discriminant part, we can set + -- the Ekind of all the discriminants appropriately. + + Discr := First (Discriminant_Specifications (N)); + Discr_Number := Uint_1; + while Present (Discr) loop + Id := Defining_Identifier (Discr); + Set_Ekind (Id, E_Discriminant); + Init_Component_Location (Id); + Init_Esize (Id); + Set_Discriminant_Number (Id, Discr_Number); + + -- Make sure this is always set, even in illegal programs + + Set_Corresponding_Discriminant (Id, Empty); + + -- Initialize the Original_Record_Component to the entity itself. + -- Inherit_Components will propagate the right value to + -- discriminants in derived record types. + + Set_Original_Record_Component (Id, Id); + + -- Create the discriminal for the discriminant + + Build_Discriminal (Id); + + Next (Discr); + Discr_Number := Discr_Number + 1; + end loop; + + Set_Has_Discriminants (Current_Scope); + end Process_Discriminants; + + ----------------------- + -- Process_Full_View -- + ----------------------- + + procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id) is + Priv_Parent : Entity_Id; + Full_Parent : Entity_Id; + Full_Indic : Node_Id; + + procedure Collect_Implemented_Interfaces + (Typ : Entity_Id; + Ifaces : Elist_Id); + -- Ada 2005: Gather all the interfaces that Typ directly or + -- inherently implements. Duplicate entries are not added to + -- the list Ifaces. + + ------------------------------------ + -- Collect_Implemented_Interfaces -- + ------------------------------------ + + procedure Collect_Implemented_Interfaces + (Typ : Entity_Id; + Ifaces : Elist_Id) + is + Iface : Entity_Id; + Iface_Elmt : Elmt_Id; + + begin + -- Abstract interfaces are only associated with tagged record types + + if not Is_Tagged_Type (Typ) + or else not Is_Record_Type (Typ) + then + return; + end if; + + -- Recursively climb to the ancestors + + if Etype (Typ) /= Typ + + -- Protect the frontend against wrong cyclic declarations like: + + -- type B is new A with private; + -- type C is new A with private; + -- private + -- type B is new C with null record; + -- type C is new B with null record; + + and then Etype (Typ) /= Priv_T + and then Etype (Typ) /= Full_T + then + -- Keep separate the management of private type declarations + + if Ekind (Typ) = E_Record_Type_With_Private then + + -- Handle the following erroneous case: + -- type Private_Type is tagged private; + -- private + -- type Private_Type is new Type_Implementing_Iface; + + if Present (Full_View (Typ)) + and then Etype (Typ) /= Full_View (Typ) + then + if Is_Interface (Etype (Typ)) then + Append_Unique_Elmt (Etype (Typ), Ifaces); + end if; + + Collect_Implemented_Interfaces (Etype (Typ), Ifaces); + end if; + + -- Non-private types + + else + if Is_Interface (Etype (Typ)) then + Append_Unique_Elmt (Etype (Typ), Ifaces); + end if; + + Collect_Implemented_Interfaces (Etype (Typ), Ifaces); + end if; + end if; + + -- Handle entities in the list of abstract interfaces + + if Present (Interfaces (Typ)) then + Iface_Elmt := First_Elmt (Interfaces (Typ)); + while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); + + pragma Assert (Is_Interface (Iface)); + + if not Contain_Interface (Iface, Ifaces) then + Append_Elmt (Iface, Ifaces); + Collect_Implemented_Interfaces (Iface, Ifaces); + end if; + + Next_Elmt (Iface_Elmt); + end loop; + end if; + end Collect_Implemented_Interfaces; + + -- Start of processing for Process_Full_View + + begin + -- First some sanity checks that must be done after semantic + -- decoration of the full view and thus cannot be placed with other + -- similar checks in Find_Type_Name + + if not Is_Limited_Type (Priv_T) + and then (Is_Limited_Type (Full_T) + or else Is_Limited_Composite (Full_T)) + then + Error_Msg_N + ("completion of nonlimited type cannot be limited", Full_T); + Explain_Limited_Type (Full_T, Full_T); + + elsif Is_Abstract_Type (Full_T) + and then not Is_Abstract_Type (Priv_T) + then + Error_Msg_N + ("completion of nonabstract type cannot be abstract", Full_T); + + elsif Is_Tagged_Type (Priv_T) + and then Is_Limited_Type (Priv_T) + and then not Is_Limited_Type (Full_T) + then + -- If pragma CPP_Class was applied to the private declaration + -- propagate the limitedness to the full-view + + if Is_CPP_Class (Priv_T) then + Set_Is_Limited_Record (Full_T); + + -- GNAT allow its own definition of Limited_Controlled to disobey + -- this rule in order in ease the implementation. The next test is + -- safe because Root_Controlled is defined in a private system child + + elsif Etype (Full_T) = Full_View (RTE (RE_Root_Controlled)) then + Set_Is_Limited_Composite (Full_T); + else + Error_Msg_N + ("completion of limited tagged type must be limited", Full_T); + end if; + + elsif Is_Generic_Type (Priv_T) then + Error_Msg_N ("generic type cannot have a completion", Full_T); + end if; + + -- Check that ancestor interfaces of private and full views are + -- consistent. We omit this check for synchronized types because + -- they are performed on the corresponding record type when frozen. + + if Ada_Version >= Ada_2005 + and then Is_Tagged_Type (Priv_T) + and then Is_Tagged_Type (Full_T) + and then not Is_Concurrent_Type (Full_T) + then + declare + Iface : Entity_Id; + Priv_T_Ifaces : constant Elist_Id := New_Elmt_List; + Full_T_Ifaces : constant Elist_Id := New_Elmt_List; + + begin + Collect_Implemented_Interfaces (Priv_T, Priv_T_Ifaces); + Collect_Implemented_Interfaces (Full_T, Full_T_Ifaces); + + -- Ada 2005 (AI-251): The partial view shall be a descendant of + -- an interface type if and only if the full type is descendant + -- of the interface type (AARM 7.3 (7.3/2). + + Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); + + if Present (Iface) then + Error_Msg_NE + ("interface & not implemented by full type " & + "(RM-2005 7.3 (7.3/2))", Priv_T, Iface); + end if; + + Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); + + if Present (Iface) then + Error_Msg_NE + ("interface & not implemented by partial view " & + "(RM-2005 7.3 (7.3/2))", Full_T, Iface); + end if; + end; + end if; + + if Is_Tagged_Type (Priv_T) + and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration + and then Is_Derived_Type (Full_T) + then + Priv_Parent := Etype (Priv_T); + + -- The full view of a private extension may have been transformed + -- into an unconstrained derived type declaration and a subtype + -- declaration (see build_derived_record_type for details). + + if Nkind (N) = N_Subtype_Declaration then + Full_Indic := Subtype_Indication (N); + Full_Parent := Etype (Base_Type (Full_T)); + else + Full_Indic := Subtype_Indication (Type_Definition (N)); + Full_Parent := Etype (Full_T); + end if; + + -- Check that the parent type of the full type is a descendant of + -- the ancestor subtype given in the private extension. If either + -- entity has an Etype equal to Any_Type then we had some previous + -- error situation [7.3(8)]. + + if Priv_Parent = Any_Type or else Full_Parent = Any_Type then + return; + + -- Ada 2005 (AI-251): Interfaces in the full-typ can be given in + -- any order. Therefore we don't have to check that its parent must + -- be a descendant of the parent of the private type declaration. + + elsif Is_Interface (Priv_Parent) + and then Is_Interface (Full_Parent) + then + null; + + -- Ada 2005 (AI-251): If the parent of the private type declaration + -- is an interface there is no need to check that it is an ancestor + -- of the associated full type declaration. The required tests for + -- this case are performed by Build_Derived_Record_Type. + + elsif not Is_Interface (Base_Type (Priv_Parent)) + and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) + then + Error_Msg_N + ("parent of full type must descend from parent" + & " of private extension", Full_Indic); + + -- Check the rules of 7.3(10): if the private extension inherits + -- known discriminants, then the full type must also inherit those + -- discriminants from the same (ancestor) type, and the parent + -- subtype of the full type must be constrained if and only if + -- the ancestor subtype of the private extension is constrained. + + elsif No (Discriminant_Specifications (Parent (Priv_T))) + and then not Has_Unknown_Discriminants (Priv_T) + and then Has_Discriminants (Base_Type (Priv_Parent)) + then + declare + Priv_Indic : constant Node_Id := + Subtype_Indication (Parent (Priv_T)); + + Priv_Constr : constant Boolean := + Is_Constrained (Priv_Parent) + or else + Nkind (Priv_Indic) = N_Subtype_Indication + or else Is_Constrained (Entity (Priv_Indic)); + + Full_Constr : constant Boolean := + Is_Constrained (Full_Parent) + or else + Nkind (Full_Indic) = N_Subtype_Indication + or else Is_Constrained (Entity (Full_Indic)); + + Priv_Discr : Entity_Id; + Full_Discr : Entity_Id; + + begin + Priv_Discr := First_Discriminant (Priv_Parent); + Full_Discr := First_Discriminant (Full_Parent); + while Present (Priv_Discr) and then Present (Full_Discr) loop + if Original_Record_Component (Priv_Discr) = + Original_Record_Component (Full_Discr) + or else + Corresponding_Discriminant (Priv_Discr) = + Corresponding_Discriminant (Full_Discr) + then + null; + else + exit; + end if; + + Next_Discriminant (Priv_Discr); + Next_Discriminant (Full_Discr); + end loop; + + if Present (Priv_Discr) or else Present (Full_Discr) then + Error_Msg_N + ("full view must inherit discriminants of the parent type" + & " used in the private extension", Full_Indic); + + elsif Priv_Constr and then not Full_Constr then + Error_Msg_N + ("parent subtype of full type must be constrained", + Full_Indic); + + elsif Full_Constr and then not Priv_Constr then + Error_Msg_N + ("parent subtype of full type must be unconstrained", + Full_Indic); + end if; + end; + + -- Check the rules of 7.3(12): if a partial view has neither known + -- or unknown discriminants, then the full type declaration shall + -- define a definite subtype. + + elsif not Has_Unknown_Discriminants (Priv_T) + and then not Has_Discriminants (Priv_T) + and then not Is_Constrained (Full_T) + then + Error_Msg_N + ("full view must define a constrained type if partial view" + & " has no discriminants", Full_T); + end if; + + -- ??????? Do we implement the following properly ????? + -- If the ancestor subtype of a private extension has constrained + -- discriminants, then the parent subtype of the full view shall + -- impose a statically matching constraint on those discriminants + -- [7.3(13)]. + + else + -- For untagged types, verify that a type without discriminants + -- is not completed with an unconstrained type. + + if not Is_Indefinite_Subtype (Priv_T) + and then Is_Indefinite_Subtype (Full_T) + then + Error_Msg_N ("full view of type must be definite subtype", Full_T); + end if; + end if; + + -- AI-419: verify that the use of "limited" is consistent + + declare + Orig_Decl : constant Node_Id := Original_Node (N); + + begin + if Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration + and then not Limited_Present (Parent (Priv_T)) + and then not Synchronized_Present (Parent (Priv_T)) + and then Nkind (Orig_Decl) = N_Full_Type_Declaration + and then Nkind + (Type_Definition (Orig_Decl)) = N_Derived_Type_Definition + and then Limited_Present (Type_Definition (Orig_Decl)) + then + Error_Msg_N + ("full view of non-limited extension cannot be limited", N); + end if; + end; + + -- Ada 2005 (AI-443): A synchronized private extension must be + -- completed by a task or protected type. + + if Ada_Version >= Ada_2005 + and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration + and then Synchronized_Present (Parent (Priv_T)) + and then not Is_Concurrent_Type (Full_T) + then + Error_Msg_N ("full view of synchronized extension must " & + "be synchronized type", N); + end if; + + -- Ada 2005 AI-363: if the full view has discriminants with + -- defaults, it is illegal to declare constrained access subtypes + -- whose designated type is the current type. This allows objects + -- of the type that are declared in the heap to be unconstrained. + + if not Has_Unknown_Discriminants (Priv_T) + and then not Has_Discriminants (Priv_T) + and then Has_Discriminants (Full_T) + and then + Present (Discriminant_Default_Value (First_Discriminant (Full_T))) + then + Set_Has_Constrained_Partial_View (Full_T); + Set_Has_Constrained_Partial_View (Priv_T); + end if; + + -- Create a full declaration for all its subtypes recorded in + -- Private_Dependents and swap them similarly to the base type. These + -- are subtypes that have been define before the full declaration of + -- the private type. We also swap the entry in Private_Dependents list + -- so we can properly restore the private view on exit from the scope. + + declare + Priv_Elmt : Elmt_Id; + Priv : Entity_Id; + Full : Entity_Id; + + begin + Priv_Elmt := First_Elmt (Private_Dependents (Priv_T)); + while Present (Priv_Elmt) loop + Priv := Node (Priv_Elmt); + + if Ekind_In (Priv, E_Private_Subtype, + E_Limited_Private_Subtype, + E_Record_Subtype_With_Private) + then + Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv)); + Set_Is_Itype (Full); + Set_Parent (Full, Parent (Priv)); + Set_Associated_Node_For_Itype (Full, N); + + -- Now we need to complete the private subtype, but since the + -- base type has already been swapped, we must also swap the + -- subtypes (and thus, reverse the arguments in the call to + -- Complete_Private_Subtype). + + Copy_And_Swap (Priv, Full); + Complete_Private_Subtype (Full, Priv, Full_T, N); + Replace_Elmt (Priv_Elmt, Full); + end if; + + Next_Elmt (Priv_Elmt); + end loop; + end; + + -- If the private view was tagged, copy the new primitive operations + -- from the private view to the full view. + + if Is_Tagged_Type (Full_T) then + declare + Disp_Typ : Entity_Id; + Full_List : Elist_Id; + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + Priv_List : Elist_Id; + + function Contains + (E : Entity_Id; + L : Elist_Id) return Boolean; + -- Determine whether list L contains element E + + -------------- + -- Contains -- + -------------- + + function Contains + (E : Entity_Id; + L : Elist_Id) return Boolean + is + List_Elmt : Elmt_Id; + + begin + List_Elmt := First_Elmt (L); + while Present (List_Elmt) loop + if Node (List_Elmt) = E then + return True; + end if; + + Next_Elmt (List_Elmt); + end loop; + + return False; + end Contains; + + -- Start of processing + + begin + if Is_Tagged_Type (Priv_T) then + Priv_List := Primitive_Operations (Priv_T); + Prim_Elmt := First_Elmt (Priv_List); + + -- In the case of a concurrent type completing a private tagged + -- type, primitives may have been declared in between the two + -- views. These subprograms need to be wrapped the same way + -- entries and protected procedures are handled because they + -- cannot be directly shared by the two views. + + if Is_Concurrent_Type (Full_T) then + declare + Conc_Typ : constant Entity_Id := + Corresponding_Record_Type (Full_T); + Curr_Nod : Node_Id := Parent (Conc_Typ); + Wrap_Spec : Node_Id; + + begin + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if Comes_From_Source (Prim) + and then not Is_Abstract_Subprogram (Prim) + then + Wrap_Spec := + Make_Subprogram_Declaration (Sloc (Prim), + Specification => + Build_Wrapper_Spec + (Subp_Id => Prim, + Obj_Typ => Conc_Typ, + Formals => + Parameter_Specifications ( + Parent (Prim)))); + + Insert_After (Curr_Nod, Wrap_Spec); + Curr_Nod := Wrap_Spec; + + Analyze (Wrap_Spec); + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + return; + end; + + -- For non-concurrent types, transfer explicit primitives, but + -- omit those inherited from the parent of the private view + -- since they will be re-inherited later on. + + else + Full_List := Primitive_Operations (Full_T); + + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if Comes_From_Source (Prim) + and then not Contains (Prim, Full_List) + then + Append_Elmt (Prim, Full_List); + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end if; + + -- Untagged private view + + else + Full_List := Primitive_Operations (Full_T); + + -- In this case the partial view is untagged, so here we locate + -- all of the earlier primitives that need to be treated as + -- dispatching (those that appear between the two views). Note + -- that these additional operations must all be new operations + -- (any earlier operations that override inherited operations + -- of the full view will already have been inserted in the + -- primitives list, marked by Check_Operation_From_Private_View + -- as dispatching. Note that implicit "/=" operators are + -- excluded from being added to the primitives list since they + -- shouldn't be treated as dispatching (tagged "/=" is handled + -- specially). + + Prim := Next_Entity (Full_T); + while Present (Prim) and then Prim /= Priv_T loop + if Ekind_In (Prim, E_Procedure, E_Function) then + Disp_Typ := Find_Dispatching_Type (Prim); + + if Disp_Typ = Full_T + and then (Chars (Prim) /= Name_Op_Ne + or else Comes_From_Source (Prim)) + then + Check_Controlling_Formals (Full_T, Prim); + + if not Is_Dispatching_Operation (Prim) then + Append_Elmt (Prim, Full_List); + Set_Is_Dispatching_Operation (Prim, True); + Set_DT_Position (Prim, No_Uint); + end if; + + elsif Is_Dispatching_Operation (Prim) + and then Disp_Typ /= Full_T + then + + -- Verify that it is not otherwise controlled by a + -- formal or a return value of type T. + + Check_Controlling_Formals (Disp_Typ, Prim); + end if; + end if; + + Next_Entity (Prim); + end loop; + end if; + + -- For the tagged case, the two views can share the same primitive + -- operations list and the same class-wide type. Update attributes + -- of the class-wide type which depend on the full declaration. + + if Is_Tagged_Type (Priv_T) then + Set_Direct_Primitive_Operations (Priv_T, Full_List); + Set_Class_Wide_Type + (Base_Type (Full_T), Class_Wide_Type (Priv_T)); + + Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T)); + end if; + end; + end if; + + -- Ada 2005 AI 161: Check preelaboratable initialization consistency + + if Known_To_Have_Preelab_Init (Priv_T) then + + -- Case where there is a pragma Preelaborable_Initialization. We + -- always allow this in predefined units, which is a bit of a kludge, + -- but it means we don't have to struggle to meet the requirements in + -- the RM for having Preelaborable Initialization. Otherwise we + -- require that the type meets the RM rules. But we can't check that + -- yet, because of the rule about overriding Initialize, so we simply + -- set a flag that will be checked at freeze time. + + if not In_Predefined_Unit (Full_T) then + Set_Must_Have_Preelab_Init (Full_T); + end if; + end if; + + -- If pragma CPP_Class was applied to the private type declaration, + -- propagate it now to the full type declaration. + + if Is_CPP_Class (Priv_T) then + Set_Is_CPP_Class (Full_T); + Set_Convention (Full_T, Convention_CPP); + end if; + + -- If the private view has user specified stream attributes, then so has + -- the full view. + + -- Why the test, how could these flags be already set in Full_T ??? + + if Has_Specified_Stream_Read (Priv_T) then + Set_Has_Specified_Stream_Read (Full_T); + end if; + + if Has_Specified_Stream_Write (Priv_T) then + Set_Has_Specified_Stream_Write (Full_T); + end if; + + if Has_Specified_Stream_Input (Priv_T) then + Set_Has_Specified_Stream_Input (Full_T); + end if; + + if Has_Specified_Stream_Output (Priv_T) then + Set_Has_Specified_Stream_Output (Full_T); + end if; + + -- Propagate invariants to full type + + if Has_Invariants (Priv_T) then + Set_Has_Invariants (Full_T); + Set_Invariant_Procedure (Full_T, Invariant_Procedure (Priv_T)); + end if; + + if Has_Inheritable_Invariants (Priv_T) then + Set_Has_Inheritable_Invariants (Full_T); + end if; + + -- Propagate predicates to full type + + if Has_Predicates (Priv_T) then + Set_Predicate_Function (Priv_T, Predicate_Function (Full_T)); + Set_Has_Predicates (Priv_T); + end if; + end Process_Full_View; + + ----------------------------------- + -- Process_Incomplete_Dependents -- + ----------------------------------- + + procedure Process_Incomplete_Dependents + (N : Node_Id; + Full_T : Entity_Id; + Inc_T : Entity_Id) + is + Inc_Elmt : Elmt_Id; + Priv_Dep : Entity_Id; + New_Subt : Entity_Id; + + Disc_Constraint : Elist_Id; + + begin + if No (Private_Dependents (Inc_T)) then + return; + end if; + + -- Itypes that may be generated by the completion of an incomplete + -- subtype are not used by the back-end and not attached to the tree. + -- They are created only for constraint-checking purposes. + + Inc_Elmt := First_Elmt (Private_Dependents (Inc_T)); + while Present (Inc_Elmt) loop + Priv_Dep := Node (Inc_Elmt); + + if Ekind (Priv_Dep) = E_Subprogram_Type then + + -- An Access_To_Subprogram type may have a return type or a + -- parameter type that is incomplete. Replace with the full view. + + if Etype (Priv_Dep) = Inc_T then + Set_Etype (Priv_Dep, Full_T); + end if; + + declare + Formal : Entity_Id; + + begin + Formal := First_Formal (Priv_Dep); + while Present (Formal) loop + if Etype (Formal) = Inc_T then + Set_Etype (Formal, Full_T); + end if; + + Next_Formal (Formal); + end loop; + end; + + elsif Is_Overloadable (Priv_Dep) then + + -- A protected operation is never dispatching: only its + -- wrapper operation (which has convention Ada) is. + + if Is_Tagged_Type (Full_T) + and then Convention (Priv_Dep) /= Convention_Protected + then + + -- Subprogram has an access parameter whose designated type + -- was incomplete. Reexamine declaration now, because it may + -- be a primitive operation of the full type. + + Check_Operation_From_Incomplete_Type (Priv_Dep, Inc_T); + Set_Is_Dispatching_Operation (Priv_Dep); + Check_Controlling_Formals (Full_T, Priv_Dep); + end if; + + elsif Ekind (Priv_Dep) = E_Subprogram_Body then + + -- Can happen during processing of a body before the completion + -- of a TA type. Ignore, because spec is also on dependent list. + + return; + + -- Ada 2005 (AI-412): Transform a regular incomplete subtype into a + -- corresponding subtype of the full view. + + elsif Ekind (Priv_Dep) = E_Incomplete_Subtype then + Set_Subtype_Indication + (Parent (Priv_Dep), New_Reference_To (Full_T, Sloc (Priv_Dep))); + Set_Etype (Priv_Dep, Full_T); + Set_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T))); + Set_Analyzed (Parent (Priv_Dep), False); + + -- Reanalyze the declaration, suppressing the call to + -- Enter_Name to avoid duplicate names. + + Analyze_Subtype_Declaration + (N => Parent (Priv_Dep), + Skip => True); + + -- Dependent is a subtype + + else + -- We build a new subtype indication using the full view of the + -- incomplete parent. The discriminant constraints have been + -- elaborated already at the point of the subtype declaration. + + New_Subt := Create_Itype (E_Void, N); + + if Has_Discriminants (Full_T) then + Disc_Constraint := Discriminant_Constraint (Priv_Dep); + else + Disc_Constraint := No_Elist; + end if; + + Build_Discriminated_Subtype (Full_T, New_Subt, Disc_Constraint, N); + Set_Full_View (Priv_Dep, New_Subt); + end if; + + Next_Elmt (Inc_Elmt); + end loop; + end Process_Incomplete_Dependents; + + -------------------------------- + -- Process_Range_Expr_In_Decl -- + -------------------------------- + + procedure Process_Range_Expr_In_Decl + (R : Node_Id; + T : Entity_Id; + Check_List : List_Id := Empty_List; + R_Check_Off : Boolean := False) + is + Lo, Hi : Node_Id; + R_Checks : Check_Result; + Insert_Node : Node_Id; + Def_Id : Entity_Id; + + begin + Analyze_And_Resolve (R, Base_Type (T)); + + if Nkind (R) = N_Range then + Lo := Low_Bound (R); + Hi := High_Bound (R); + + -- We need to ensure validity of the bounds here, because if we + -- go ahead and do the expansion, then the expanded code will get + -- analyzed with range checks suppressed and we miss the check. + + Validity_Check_Range (R); + + -- If there were errors in the declaration, try and patch up some + -- common mistakes in the bounds. The cases handled are literals + -- which are Integer where the expected type is Real and vice versa. + -- These corrections allow the compilation process to proceed further + -- along since some basic assumptions of the format of the bounds + -- are guaranteed. + + if Etype (R) = Any_Type then + + if Nkind (Lo) = N_Integer_Literal and then Is_Real_Type (T) then + Rewrite (Lo, + Make_Real_Literal (Sloc (Lo), UR_From_Uint (Intval (Lo)))); + + elsif Nkind (Hi) = N_Integer_Literal and then Is_Real_Type (T) then + Rewrite (Hi, + Make_Real_Literal (Sloc (Hi), UR_From_Uint (Intval (Hi)))); + + elsif Nkind (Lo) = N_Real_Literal and then Is_Integer_Type (T) then + Rewrite (Lo, + Make_Integer_Literal (Sloc (Lo), UR_To_Uint (Realval (Lo)))); + + elsif Nkind (Hi) = N_Real_Literal and then Is_Integer_Type (T) then + Rewrite (Hi, + Make_Integer_Literal (Sloc (Hi), UR_To_Uint (Realval (Hi)))); + end if; + + Set_Etype (Lo, T); + Set_Etype (Hi, T); + end if; + + -- If the bounds of the range have been mistakenly given as string + -- literals (perhaps in place of character literals), then an error + -- has already been reported, but we rewrite the string literal as a + -- bound of the range's type to avoid blowups in later processing + -- that looks at static values. + + if Nkind (Lo) = N_String_Literal then + Rewrite (Lo, + Make_Attribute_Reference (Sloc (Lo), + Attribute_Name => Name_First, + Prefix => New_Reference_To (T, Sloc (Lo)))); + Analyze_And_Resolve (Lo); + end if; + + if Nkind (Hi) = N_String_Literal then + Rewrite (Hi, + Make_Attribute_Reference (Sloc (Hi), + Attribute_Name => Name_First, + Prefix => New_Reference_To (T, Sloc (Hi)))); + Analyze_And_Resolve (Hi); + end if; + + -- If bounds aren't scalar at this point then exit, avoiding + -- problems with further processing of the range in this procedure. + + if not Is_Scalar_Type (Etype (Lo)) then + return; + end if; + + -- Resolve (actually Sem_Eval) has checked that the bounds are in + -- then range of the base type. Here we check whether the bounds + -- are in the range of the subtype itself. Note that if the bounds + -- represent the null range the Constraint_Error exception should + -- not be raised. + + -- ??? The following code should be cleaned up as follows + + -- 1. The Is_Null_Range (Lo, Hi) test should disappear since it + -- is done in the call to Range_Check (R, T); below + + -- 2. The use of R_Check_Off should be investigated and possibly + -- removed, this would clean up things a bit. + + if Is_Null_Range (Lo, Hi) then + null; + + else + -- Capture values of bounds and generate temporaries for them + -- if needed, before applying checks, since checks may cause + -- duplication of the expression without forcing evaluation. + + if Expander_Active then + Force_Evaluation (Lo); + Force_Evaluation (Hi); + end if; + + -- We use a flag here instead of suppressing checks on the + -- type because the type we check against isn't necessarily + -- the place where we put the check. + + if not R_Check_Off then + R_Checks := Get_Range_Checks (R, T); + + -- Look up tree to find an appropriate insertion point. We + -- can't just use insert_actions because later processing + -- depends on the insertion node. Prior to Ada2012 the + -- insertion point could only be a declaration or a loop, but + -- quantified expressions can appear within any context in an + -- expression, and the insertion point can be any statement, + -- pragma, or declaration. + + Insert_Node := Parent (R); + while Present (Insert_Node) loop + exit when + Nkind (Insert_Node) in N_Declaration + and then + not Nkind_In + (Insert_Node, N_Component_Declaration, + N_Loop_Parameter_Specification, + N_Function_Specification, + N_Procedure_Specification); + + exit when Nkind (Insert_Node) in N_Later_Decl_Item + or else Nkind (Insert_Node) in + N_Statement_Other_Than_Procedure_Call + or else Nkind_In (Insert_Node, N_Procedure_Call_Statement, + N_Pragma); + + Insert_Node := Parent (Insert_Node); + end loop; + + -- Why would Type_Decl not be present??? Without this test, + -- short regression tests fail. + + if Present (Insert_Node) then + + -- Case of loop statement. Verify that the range is part + -- of the subtype indication of the iteration scheme. + + if Nkind (Insert_Node) = N_Loop_Statement then + declare + Indic : Node_Id; + + begin + Indic := Parent (R); + while Present (Indic) + and then Nkind (Indic) /= N_Subtype_Indication + loop + Indic := Parent (Indic); + end loop; + + if Present (Indic) then + Def_Id := Etype (Subtype_Mark (Indic)); + + Insert_Range_Checks + (R_Checks, + Insert_Node, + Def_Id, + Sloc (Insert_Node), + R, + Do_Before => True); + end if; + end; + + -- Insertion before a declaration. If the declaration + -- includes discriminants, the list of applicable checks + -- is given by the caller. + + elsif Nkind (Insert_Node) in N_Declaration then + Def_Id := Defining_Identifier (Insert_Node); + + if (Ekind (Def_Id) = E_Record_Type + and then Depends_On_Discriminant (R)) + or else + (Ekind (Def_Id) = E_Protected_Type + and then Has_Discriminants (Def_Id)) + then + Append_Range_Checks + (R_Checks, + Check_List, Def_Id, Sloc (Insert_Node), R); + + else + Insert_Range_Checks + (R_Checks, + Insert_Node, Def_Id, Sloc (Insert_Node), R); + + end if; + + -- Insertion before a statement. Range appears in the + -- context of a quantified expression. Insertion will + -- take place when expression is expanded. + + else + null; + end if; + end if; + end if; + end if; + + -- Case of other than an explicit N_Range node + + elsif Expander_Active then + Get_Index_Bounds (R, Lo, Hi); + Force_Evaluation (Lo); + Force_Evaluation (Hi); + end if; + end Process_Range_Expr_In_Decl; + + -------------------------------------- + -- Process_Real_Range_Specification -- + -------------------------------------- + + procedure Process_Real_Range_Specification (Def : Node_Id) is + Spec : constant Node_Id := Real_Range_Specification (Def); + Lo : Node_Id; + Hi : Node_Id; + Err : Boolean := False; + + procedure Analyze_Bound (N : Node_Id); + -- Analyze and check one bound + + ------------------- + -- Analyze_Bound -- + ------------------- + + procedure Analyze_Bound (N : Node_Id) is + begin + Analyze_And_Resolve (N, Any_Real); + + if not Is_OK_Static_Expression (N) then + Flag_Non_Static_Expr + ("bound in real type definition is not static!", N); + Err := True; + end if; + end Analyze_Bound; + + -- Start of processing for Process_Real_Range_Specification + + begin + if Present (Spec) then + Lo := Low_Bound (Spec); + Hi := High_Bound (Spec); + Analyze_Bound (Lo); + Analyze_Bound (Hi); + + -- If error, clear away junk range specification + + if Err then + Set_Real_Range_Specification (Def, Empty); + end if; + end if; + end Process_Real_Range_Specification; + + --------------------- + -- Process_Subtype -- + --------------------- + + function Process_Subtype + (S : Node_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id := Empty; + Suffix : Character := ' ') return Entity_Id + is + P : Node_Id; + Def_Id : Entity_Id; + Error_Node : Node_Id; + Full_View_Id : Entity_Id; + Subtype_Mark_Id : Entity_Id; + + May_Have_Null_Exclusion : Boolean; + + procedure Check_Incomplete (T : Entity_Id); + -- Called to verify that an incomplete type is not used prematurely + + ---------------------- + -- Check_Incomplete -- + ---------------------- + + procedure Check_Incomplete (T : Entity_Id) is + begin + -- Ada 2005 (AI-412): Incomplete subtypes are legal + + if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type + and then + not (Ada_Version >= Ada_2005 + and then + (Nkind (Parent (T)) = N_Subtype_Declaration + or else + (Nkind (Parent (T)) = N_Subtype_Indication + and then Nkind (Parent (Parent (T))) = + N_Subtype_Declaration))) + then + Error_Msg_N ("invalid use of type before its full declaration", T); + end if; + end Check_Incomplete; + + -- Start of processing for Process_Subtype + + begin + -- Case of no constraints present + + if Nkind (S) /= N_Subtype_Indication then + Find_Type (S); + Check_Incomplete (S); + P := Parent (S); + + -- Ada 2005 (AI-231): Static check + + if Ada_Version >= Ada_2005 + and then Present (P) + and then Null_Exclusion_Present (P) + and then Nkind (P) /= N_Access_To_Object_Definition + and then not Is_Access_Type (Entity (S)) + then + Error_Msg_N ("`NOT NULL` only allowed for an access type", S); + end if; + + -- The following is ugly, can't we have a range or even a flag??? + + May_Have_Null_Exclusion := + Nkind_In (P, N_Access_Definition, + N_Access_Function_Definition, + N_Access_Procedure_Definition, + N_Access_To_Object_Definition, + N_Allocator, + N_Component_Definition) + or else + Nkind_In (P, N_Derived_Type_Definition, + N_Discriminant_Specification, + N_Formal_Object_Declaration, + N_Object_Declaration, + N_Object_Renaming_Declaration, + N_Parameter_Specification, + N_Subtype_Declaration); + + -- Create an Itype that is a duplicate of Entity (S) but with the + -- null-exclusion attribute. + + if May_Have_Null_Exclusion + and then Is_Access_Type (Entity (S)) + and then Null_Exclusion_Present (P) + + -- No need to check the case of an access to object definition. + -- It is correct to define double not-null pointers. + + -- Example: + -- type Not_Null_Int_Ptr is not null access Integer; + -- type Acc is not null access Not_Null_Int_Ptr; + + and then Nkind (P) /= N_Access_To_Object_Definition + then + if Can_Never_Be_Null (Entity (S)) then + case Nkind (Related_Nod) is + when N_Full_Type_Declaration => + if Nkind (Type_Definition (Related_Nod)) + in N_Array_Type_Definition + then + Error_Node := + Subtype_Indication + (Component_Definition + (Type_Definition (Related_Nod))); + else + Error_Node := + Subtype_Indication (Type_Definition (Related_Nod)); + end if; + + when N_Subtype_Declaration => + Error_Node := Subtype_Indication (Related_Nod); + + when N_Object_Declaration => + Error_Node := Object_Definition (Related_Nod); + + when N_Component_Declaration => + Error_Node := + Subtype_Indication (Component_Definition (Related_Nod)); + + when N_Allocator => + Error_Node := Expression (Related_Nod); + + when others => + pragma Assert (False); + Error_Node := Related_Nod; + end case; + + Error_Msg_NE + ("`NOT NULL` not allowed (& already excludes null)", + Error_Node, + Entity (S)); + end if; + + Set_Etype (S, + Create_Null_Excluding_Itype + (T => Entity (S), + Related_Nod => P)); + Set_Entity (S, Etype (S)); + end if; + + return Entity (S); + + -- Case of constraint present, so that we have an N_Subtype_Indication + -- node (this node is created only if constraints are present). + + else + Find_Type (Subtype_Mark (S)); + + if Nkind (Parent (S)) /= N_Access_To_Object_Definition + and then not + (Nkind (Parent (S)) = N_Subtype_Declaration + and then Is_Itype (Defining_Identifier (Parent (S)))) + then + Check_Incomplete (Subtype_Mark (S)); + end if; + + P := Parent (S); + Subtype_Mark_Id := Entity (Subtype_Mark (S)); + + -- Explicit subtype declaration case + + if Nkind (P) = N_Subtype_Declaration then + Def_Id := Defining_Identifier (P); + + -- Explicit derived type definition case + + elsif Nkind (P) = N_Derived_Type_Definition then + Def_Id := Defining_Identifier (Parent (P)); + + -- Implicit case, the Def_Id must be created as an implicit type. + -- The one exception arises in the case of concurrent types, array + -- and access types, where other subsidiary implicit types may be + -- created and must appear before the main implicit type. In these + -- cases we leave Def_Id set to Empty as a signal that Create_Itype + -- has not yet been called to create Def_Id. + + else + if Is_Array_Type (Subtype_Mark_Id) + or else Is_Concurrent_Type (Subtype_Mark_Id) + or else Is_Access_Type (Subtype_Mark_Id) + then + Def_Id := Empty; + + -- For the other cases, we create a new unattached Itype, + -- and set the indication to ensure it gets attached later. + + else + Def_Id := + Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); + end if; + end if; + + -- If the kind of constraint is invalid for this kind of type, + -- then give an error, and then pretend no constraint was given. + + if not Is_Valid_Constraint_Kind + (Ekind (Subtype_Mark_Id), Nkind (Constraint (S))) + then + Error_Msg_N + ("incorrect constraint for this kind of type", Constraint (S)); + + Rewrite (S, New_Copy_Tree (Subtype_Mark (S))); + + -- Set Ekind of orphan itype, to prevent cascaded errors + + if Present (Def_Id) then + Set_Ekind (Def_Id, Ekind (Any_Type)); + end if; + + -- Make recursive call, having got rid of the bogus constraint + + return Process_Subtype (S, Related_Nod, Related_Id, Suffix); + end if; + + -- Remaining processing depends on type + + case Ekind (Subtype_Mark_Id) is + when Access_Kind => + Constrain_Access (Def_Id, S, Related_Nod); + + if Expander_Active + and then Is_Itype (Designated_Type (Def_Id)) + and then Nkind (Related_Nod) = N_Subtype_Declaration + and then not Is_Incomplete_Type (Designated_Type (Def_Id)) + then + Build_Itype_Reference + (Designated_Type (Def_Id), Related_Nod); + end if; + + when Array_Kind => + Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix); + + when Decimal_Fixed_Point_Kind => + Constrain_Decimal (Def_Id, S); + + when Enumeration_Kind => + Constrain_Enumeration (Def_Id, S); + + when Ordinary_Fixed_Point_Kind => + Constrain_Ordinary_Fixed (Def_Id, S); + + when Float_Kind => + Constrain_Float (Def_Id, S); + + when Integer_Kind => + Constrain_Integer (Def_Id, S); + + when E_Record_Type | + E_Record_Subtype | + Class_Wide_Kind | + E_Incomplete_Type => + Constrain_Discriminated_Type (Def_Id, S, Related_Nod); + + if Ekind (Def_Id) = E_Incomplete_Type then + Set_Private_Dependents (Def_Id, New_Elmt_List); + end if; + + when Private_Kind => + Constrain_Discriminated_Type (Def_Id, S, Related_Nod); + Set_Private_Dependents (Def_Id, New_Elmt_List); + + -- In case of an invalid constraint prevent further processing + -- since the type constructed is missing expected fields. + + if Etype (Def_Id) = Any_Type then + return Def_Id; + end if; + + -- If the full view is that of a task with discriminants, + -- we must constrain both the concurrent type and its + -- corresponding record type. Otherwise we will just propagate + -- the constraint to the full view, if available. + + if Present (Full_View (Subtype_Mark_Id)) + and then Has_Discriminants (Subtype_Mark_Id) + and then Is_Concurrent_Type (Full_View (Subtype_Mark_Id)) + then + Full_View_Id := + Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); + + Set_Entity (Subtype_Mark (S), Full_View (Subtype_Mark_Id)); + Constrain_Concurrent (Full_View_Id, S, + Related_Nod, Related_Id, Suffix); + Set_Entity (Subtype_Mark (S), Subtype_Mark_Id); + Set_Full_View (Def_Id, Full_View_Id); + + -- Introduce an explicit reference to the private subtype, + -- to prevent scope anomalies in gigi if first use appears + -- in a nested context, e.g. a later function body. + -- Should this be generated in other contexts than a full + -- type declaration? + + if Is_Itype (Def_Id) + and then + Nkind (Parent (P)) = N_Full_Type_Declaration + then + Build_Itype_Reference (Def_Id, Parent (P)); + end if; + + else + Prepare_Private_Subtype_Completion (Def_Id, Related_Nod); + end if; + + when Concurrent_Kind => + Constrain_Concurrent (Def_Id, S, + Related_Nod, Related_Id, Suffix); + + when others => + Error_Msg_N ("invalid subtype mark in subtype indication", S); + end case; + + -- Size and Convention are always inherited from the base type + + Set_Size_Info (Def_Id, (Subtype_Mark_Id)); + Set_Convention (Def_Id, Convention (Subtype_Mark_Id)); + + return Def_Id; + end if; + end Process_Subtype; + + --------------------------------------- + -- Check_Anonymous_Access_Components -- + --------------------------------------- + + procedure Check_Anonymous_Access_Components + (Typ_Decl : Node_Id; + Typ : Entity_Id; + Prev : Entity_Id; + Comp_List : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Typ_Decl); + Anon_Access : Entity_Id; + Acc_Def : Node_Id; + Comp : Node_Id; + Comp_Def : Node_Id; + Decl : Node_Id; + Type_Def : Node_Id; + + procedure Build_Incomplete_Type_Declaration; + -- If the record type contains components that include an access to the + -- current record, then create an incomplete type declaration for the + -- record, to be used as the designated type of the anonymous access. + -- This is done only once, and only if there is no previous partial + -- view of the type. + + function Designates_T (Subt : Node_Id) return Boolean; + -- Check whether a node designates the enclosing record type, or 'Class + -- of that type + + function Mentions_T (Acc_Def : Node_Id) return Boolean; + -- Check whether an access definition includes a reference to + -- the enclosing record type. The reference can be a subtype mark + -- in the access definition itself, a 'Class attribute reference, or + -- recursively a reference appearing in a parameter specification + -- or result definition of an access_to_subprogram definition. + + -------------------------------------- + -- Build_Incomplete_Type_Declaration -- + -------------------------------------- + + procedure Build_Incomplete_Type_Declaration is + Decl : Node_Id; + Inc_T : Entity_Id; + H : Entity_Id; + + -- Is_Tagged indicates whether the type is tagged. It is tagged if + -- it's "is new ... with record" or else "is tagged record ...". + + Is_Tagged : constant Boolean := + (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition + and then + Present + (Record_Extension_Part (Type_Definition (Typ_Decl)))) + or else + (Nkind (Type_Definition (Typ_Decl)) = N_Record_Definition + and then Tagged_Present (Type_Definition (Typ_Decl))); + + begin + -- If there is a previous partial view, no need to create a new one + -- If the partial view, given by Prev, is incomplete, If Prev is + -- a private declaration, full declaration is flagged accordingly. + + if Prev /= Typ then + if Is_Tagged then + Make_Class_Wide_Type (Prev); + Set_Class_Wide_Type (Typ, Class_Wide_Type (Prev)); + Set_Etype (Class_Wide_Type (Typ), Typ); + end if; + + return; + + elsif Has_Private_Declaration (Typ) then + + -- If we refer to T'Class inside T, and T is the completion of a + -- private type, then we need to make sure the class-wide type + -- exists. + + if Is_Tagged then + Make_Class_Wide_Type (Typ); + end if; + + return; + + -- If there was a previous anonymous access type, the incomplete + -- type declaration will have been created already. + + elsif Present (Current_Entity (Typ)) + and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type + and then Full_View (Current_Entity (Typ)) = Typ + then + if Is_Tagged + and then Comes_From_Source (Current_Entity (Typ)) + and then not Is_Tagged_Type (Current_Entity (Typ)) + then + Make_Class_Wide_Type (Typ); + Error_Msg_N + ("incomplete view of tagged type should be declared tagged?", + Parent (Current_Entity (Typ))); + end if; + return; + + else + Inc_T := Make_Defining_Identifier (Loc, Chars (Typ)); + Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T); + + -- Type has already been inserted into the current scope. Remove + -- it, and add incomplete declaration for type, so that subsequent + -- anonymous access types can use it. The entity is unchained from + -- the homonym list and from immediate visibility. After analysis, + -- the entity in the incomplete declaration becomes immediately + -- visible in the record declaration that follows. + + H := Current_Entity (Typ); + + if H = Typ then + Set_Name_Entity_Id (Chars (Typ), Homonym (Typ)); + else + while Present (H) + and then Homonym (H) /= Typ + loop + H := Homonym (Typ); + end loop; + + Set_Homonym (H, Homonym (Typ)); + end if; + + Insert_Before (Typ_Decl, Decl); + Analyze (Decl); + Set_Full_View (Inc_T, Typ); + + if Is_Tagged then + + -- Create a common class-wide type for both views, and set the + -- Etype of the class-wide type to the full view. + + Make_Class_Wide_Type (Inc_T); + Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T)); + Set_Etype (Class_Wide_Type (Typ), Typ); + end if; + end if; + end Build_Incomplete_Type_Declaration; + + ------------------ + -- Designates_T -- + ------------------ + + function Designates_T (Subt : Node_Id) return Boolean is + Type_Id : constant Name_Id := Chars (Typ); + + function Names_T (Nam : Node_Id) return Boolean; + -- The record type has not been introduced in the current scope + -- yet, so we must examine the name of the type itself, either + -- an identifier T, or an expanded name of the form P.T, where + -- P denotes the current scope. + + ------------- + -- Names_T -- + ------------- + + function Names_T (Nam : Node_Id) return Boolean is + begin + if Nkind (Nam) = N_Identifier then + return Chars (Nam) = Type_Id; + + elsif Nkind (Nam) = N_Selected_Component then + if Chars (Selector_Name (Nam)) = Type_Id then + if Nkind (Prefix (Nam)) = N_Identifier then + return Chars (Prefix (Nam)) = Chars (Current_Scope); + + elsif Nkind (Prefix (Nam)) = N_Selected_Component then + return Chars (Selector_Name (Prefix (Nam))) = + Chars (Current_Scope); + else + return False; + end if; + + else + return False; + end if; + + else + return False; + end if; + end Names_T; + + -- Start of processing for Designates_T + + begin + if Nkind (Subt) = N_Identifier then + return Chars (Subt) = Type_Id; + + -- Reference can be through an expanded name which has not been + -- analyzed yet, and which designates enclosing scopes. + + elsif Nkind (Subt) = N_Selected_Component then + if Names_T (Subt) then + return True; + + -- Otherwise it must denote an entity that is already visible. + -- The access definition may name a subtype of the enclosing + -- type, if there is a previous incomplete declaration for it. + + else + Find_Selected_Component (Subt); + return + Is_Entity_Name (Subt) + and then Scope (Entity (Subt)) = Current_Scope + and then + (Chars (Base_Type (Entity (Subt))) = Type_Id + or else + (Is_Class_Wide_Type (Entity (Subt)) + and then + Chars (Etype (Base_Type (Entity (Subt)))) = + Type_Id)); + end if; + + -- A reference to the current type may appear as the prefix of + -- a 'Class attribute. + + elsif Nkind (Subt) = N_Attribute_Reference + and then Attribute_Name (Subt) = Name_Class + then + return Names_T (Prefix (Subt)); + + else + return False; + end if; + end Designates_T; + + ---------------- + -- Mentions_T -- + ---------------- + + function Mentions_T (Acc_Def : Node_Id) return Boolean is + Param_Spec : Node_Id; + + Acc_Subprg : constant Node_Id := + Access_To_Subprogram_Definition (Acc_Def); + + begin + if No (Acc_Subprg) then + return Designates_T (Subtype_Mark (Acc_Def)); + end if; + + -- Component is an access_to_subprogram: examine its formals, + -- and result definition in the case of an access_to_function. + + Param_Spec := First (Parameter_Specifications (Acc_Subprg)); + while Present (Param_Spec) loop + if Nkind (Parameter_Type (Param_Spec)) = N_Access_Definition + and then Mentions_T (Parameter_Type (Param_Spec)) + then + return True; + + elsif Designates_T (Parameter_Type (Param_Spec)) then + return True; + end if; + + Next (Param_Spec); + end loop; + + if Nkind (Acc_Subprg) = N_Access_Function_Definition then + if Nkind (Result_Definition (Acc_Subprg)) = + N_Access_Definition + then + return Mentions_T (Result_Definition (Acc_Subprg)); + else + return Designates_T (Result_Definition (Acc_Subprg)); + end if; + end if; + + return False; + end Mentions_T; + + -- Start of processing for Check_Anonymous_Access_Components + + begin + if No (Comp_List) then + return; + end if; + + Comp := First (Component_Items (Comp_List)); + while Present (Comp) loop + if Nkind (Comp) = N_Component_Declaration + and then Present + (Access_Definition (Component_Definition (Comp))) + and then + Mentions_T (Access_Definition (Component_Definition (Comp))) + then + Comp_Def := Component_Definition (Comp); + Acc_Def := + Access_To_Subprogram_Definition + (Access_Definition (Comp_Def)); + + Build_Incomplete_Type_Declaration; + Anon_Access := Make_Temporary (Loc, 'S'); + + -- Create a declaration for the anonymous access type: either + -- an access_to_object or an access_to_subprogram. + + if Present (Acc_Def) then + if Nkind (Acc_Def) = N_Access_Function_Definition then + Type_Def := + Make_Access_Function_Definition (Loc, + Parameter_Specifications => + Parameter_Specifications (Acc_Def), + Result_Definition => Result_Definition (Acc_Def)); + else + Type_Def := + Make_Access_Procedure_Definition (Loc, + Parameter_Specifications => + Parameter_Specifications (Acc_Def)); + end if; + + else + Type_Def := + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + Relocate_Node + (Subtype_Mark + (Access_Definition (Comp_Def)))); + + Set_Constant_Present + (Type_Def, Constant_Present (Access_Definition (Comp_Def))); + Set_All_Present + (Type_Def, All_Present (Access_Definition (Comp_Def))); + end if; + + Set_Null_Exclusion_Present + (Type_Def, + Null_Exclusion_Present (Access_Definition (Comp_Def))); + + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Anon_Access, + Type_Definition => Type_Def); + + Insert_Before (Typ_Decl, Decl); + Analyze (Decl); + + -- If an access to object, Preserve entity of designated type, + -- for ASIS use, before rewriting the component definition. + + if No (Acc_Def) then + declare + Desig : Entity_Id; + + begin + Desig := Entity (Subtype_Indication (Type_Def)); + + -- If the access definition is to the current record, + -- the visible entity at this point is an incomplete + -- type. Retrieve the full view to simplify ASIS queries + + if Ekind (Desig) = E_Incomplete_Type then + Desig := Full_View (Desig); + end if; + + Set_Entity + (Subtype_Mark (Access_Definition (Comp_Def)), Desig); + end; + end if; + + Rewrite (Comp_Def, + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (Anon_Access, Loc))); + + if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then + Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type); + else + Set_Ekind (Anon_Access, E_Anonymous_Access_Type); + end if; + + Set_Is_Local_Anonymous_Access (Anon_Access); + end if; + + Next (Comp); + end loop; + + if Present (Variant_Part (Comp_List)) then + declare + V : Node_Id; + begin + V := First_Non_Pragma (Variants (Variant_Part (Comp_List))); + while Present (V) loop + Check_Anonymous_Access_Components + (Typ_Decl, Typ, Prev, Component_List (V)); + Next_Non_Pragma (V); + end loop; + end; + end if; + end Check_Anonymous_Access_Components; + + -------------------------------- + -- Preanalyze_Spec_Expression -- + -------------------------------- + + procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id) is + Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; + begin + In_Spec_Expression := True; + Preanalyze_And_Resolve (N, T); + In_Spec_Expression := Save_In_Spec_Expression; + end Preanalyze_Spec_Expression; + + ----------------------------- + -- Record_Type_Declaration -- + ----------------------------- + + procedure Record_Type_Declaration + (T : Entity_Id; + N : Node_Id; + Prev : Entity_Id) + is + Def : constant Node_Id := Type_Definition (N); + Is_Tagged : Boolean; + Tag_Comp : Entity_Id; + + begin + -- These flags must be initialized before calling Process_Discriminants + -- because this routine makes use of them. + + Set_Ekind (T, E_Record_Type); + Set_Etype (T, T); + Init_Size_Align (T); + Set_Interfaces (T, No_Elist); + Set_Stored_Constraint (T, No_Elist); + + -- Normal case + + if Ada_Version < Ada_2005 + or else not Interface_Present (Def) + then + -- The flag Is_Tagged_Type might have already been set by + -- Find_Type_Name if it detected an error for declaration T. This + -- arises in the case of private tagged types where the full view + -- omits the word tagged. + + Is_Tagged := + Tagged_Present (Def) + or else (Serious_Errors_Detected > 0 and then Is_Tagged_Type (T)); + + Set_Is_Tagged_Type (T, Is_Tagged); + Set_Is_Limited_Record (T, Limited_Present (Def)); + + -- Type is abstract if full declaration carries keyword, or if + -- previous partial view did. + + Set_Is_Abstract_Type (T, Is_Abstract_Type (T) + or else Abstract_Present (Def)); + + else + Is_Tagged := True; + Analyze_Interface_Declaration (T, Def); + + if Present (Discriminant_Specifications (N)) then + Error_Msg_N + ("interface types cannot have discriminants", + Defining_Identifier + (First (Discriminant_Specifications (N)))); + end if; + end if; + + -- First pass: if there are self-referential access components, + -- create the required anonymous access type declarations, and if + -- need be an incomplete type declaration for T itself. + + Check_Anonymous_Access_Components (N, T, Prev, Component_List (Def)); + + if Ada_Version >= Ada_2005 + and then Present (Interface_List (Def)) + then + Check_Interfaces (N, Def); + + declare + Ifaces_List : Elist_Id; + + begin + -- Ada 2005 (AI-251): Collect the list of progenitors that are not + -- already in the parents. + + Collect_Interfaces + (T => T, + Ifaces_List => Ifaces_List, + Exclude_Parents => True); + + Set_Interfaces (T, Ifaces_List); + end; + end if; + + -- Records constitute a scope for the component declarations within. + -- The scope is created prior to the processing of these declarations. + -- Discriminants are processed first, so that they are visible when + -- processing the other components. The Ekind of the record type itself + -- is set to E_Record_Type (subtypes appear as E_Record_Subtype). + + -- Enter record scope + + Push_Scope (T); + + -- If an incomplete or private type declaration was already given for + -- the type, then this scope already exists, and the discriminants have + -- been declared within. We must verify that the full declaration + -- matches the incomplete one. + + Check_Or_Process_Discriminants (N, T, Prev); + + Set_Is_Constrained (T, not Has_Discriminants (T)); + Set_Has_Delayed_Freeze (T, True); + + -- For tagged types add a manually analyzed component corresponding + -- to the component _tag, the corresponding piece of tree will be + -- expanded as part of the freezing actions if it is not a CPP_Class. + + if Is_Tagged then + + -- Do not add the tag unless we are in expansion mode + + if Expander_Active then + Tag_Comp := Make_Defining_Identifier (Sloc (Def), Name_uTag); + Enter_Name (Tag_Comp); + + Set_Ekind (Tag_Comp, E_Component); + Set_Is_Tag (Tag_Comp); + Set_Is_Aliased (Tag_Comp); + Set_Etype (Tag_Comp, RTE (RE_Tag)); + Set_DT_Entry_Count (Tag_Comp, No_Uint); + Set_Original_Record_Component (Tag_Comp, Tag_Comp); + Init_Component_Location (Tag_Comp); + + -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the + -- implemented interfaces. + + if Has_Interfaces (T) then + Add_Interface_Tag_Components (N, T); + end if; + end if; + + Make_Class_Wide_Type (T); + Set_Direct_Primitive_Operations (T, New_Elmt_List); + end if; + + -- We must suppress range checks when processing record components in + -- the presence of discriminants, since we don't want spurious checks to + -- be generated during their analysis, but Suppress_Range_Checks flags + -- must be reset the after processing the record definition. + + -- Note: this is the only use of Kill_Range_Checks, and is a bit odd, + -- couldn't we just use the normal range check suppression method here. + -- That would seem cleaner ??? + + if Has_Discriminants (T) and then not Range_Checks_Suppressed (T) then + Set_Kill_Range_Checks (T, True); + Record_Type_Definition (Def, Prev); + Set_Kill_Range_Checks (T, False); + else + Record_Type_Definition (Def, Prev); + end if; + + -- Exit from record scope + + End_Scope; + + -- Ada 2005 (AI-251 and AI-345): Derive the interface subprograms of all + -- the implemented interfaces and associate them an aliased entity. + + if Is_Tagged + and then not Is_Empty_List (Interface_List (Def)) + then + Derive_Progenitor_Subprograms (T, T); + end if; + end Record_Type_Declaration; + + ---------------------------- + -- Record_Type_Definition -- + ---------------------------- + + procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id) is + Component : Entity_Id; + Ctrl_Components : Boolean := False; + Final_Storage_Only : Boolean; + T : Entity_Id; + + begin + if Ekind (Prev_T) = E_Incomplete_Type then + T := Full_View (Prev_T); + else + T := Prev_T; + end if; + + Final_Storage_Only := not Is_Controlled (T); + + -- Ada 2005: check whether an explicit Limited is present in a derived + -- type declaration. + + if Nkind (Parent (Def)) = N_Derived_Type_Definition + and then Limited_Present (Parent (Def)) + then + Set_Is_Limited_Record (T); + end if; + + -- If the component list of a record type is defined by the reserved + -- word null and there is no discriminant part, then the record type has + -- no components and all records of the type are null records (RM 3.7) + -- This procedure is also called to process the extension part of a + -- record extension, in which case the current scope may have inherited + -- components. + + if No (Def) + or else No (Component_List (Def)) + or else Null_Present (Component_List (Def)) + then + null; + + else + Analyze_Declarations (Component_Items (Component_List (Def))); + + if Present (Variant_Part (Component_List (Def))) then + Analyze (Variant_Part (Component_List (Def))); + end if; + end if; + + -- After completing the semantic analysis of the record definition, + -- record components, both new and inherited, are accessible. Set their + -- kind accordingly. Exclude malformed itypes from illegal declarations, + -- whose Ekind may be void. + + Component := First_Entity (Current_Scope); + while Present (Component) loop + if Ekind (Component) = E_Void + and then not Is_Itype (Component) + then + Set_Ekind (Component, E_Component); + Init_Component_Location (Component); + end if; + + if Has_Task (Etype (Component)) then + Set_Has_Task (T); + end if; + + if Ekind (Component) /= E_Component then + null; + + -- Do not set Has_Controlled_Component on a class-wide equivalent + -- type. See Make_CW_Equivalent_Type. + + elsif not Is_Class_Wide_Equivalent_Type (T) + and then (Has_Controlled_Component (Etype (Component)) + or else (Chars (Component) /= Name_uParent + and then Is_Controlled (Etype (Component)))) + then + Set_Has_Controlled_Component (T, True); + Final_Storage_Only := + Final_Storage_Only + and then Finalize_Storage_Only (Etype (Component)); + Ctrl_Components := True; + end if; + + Next_Entity (Component); + end loop; + + -- A Type is Finalize_Storage_Only only if all its controlled components + -- are also. + + if Ctrl_Components then + Set_Finalize_Storage_Only (T, Final_Storage_Only); + end if; + + -- Place reference to end record on the proper entity, which may + -- be a partial view. + + if Present (Def) then + Process_End_Label (Def, 'e', Prev_T); + end if; + end Record_Type_Definition; + + ------------------------ + -- Replace_Components -- + ------------------------ + + procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id) is + function Process (N : Node_Id) return Traverse_Result; + + ------------- + -- Process -- + ------------- + + function Process (N : Node_Id) return Traverse_Result is + Comp : Entity_Id; + + begin + if Nkind (N) = N_Discriminant_Specification then + Comp := First_Discriminant (Typ); + while Present (Comp) loop + if Chars (Comp) = Chars (Defining_Identifier (N)) then + Set_Defining_Identifier (N, Comp); + exit; + end if; + + Next_Discriminant (Comp); + end loop; + + elsif Nkind (N) = N_Component_Declaration then + Comp := First_Component (Typ); + while Present (Comp) loop + if Chars (Comp) = Chars (Defining_Identifier (N)) then + Set_Defining_Identifier (N, Comp); + exit; + end if; + + Next_Component (Comp); + end loop; + end if; + + return OK; + end Process; + + procedure Replace is new Traverse_Proc (Process); + + -- Start of processing for Replace_Components + + begin + Replace (Decl); + end Replace_Components; + + ------------------------------- + -- Set_Completion_Referenced -- + ------------------------------- + + procedure Set_Completion_Referenced (E : Entity_Id) is + begin + -- If in main unit, mark entity that is a completion as referenced, + -- warnings go on the partial view when needed. + + if In_Extended_Main_Source_Unit (E) then + Set_Referenced (E); + end if; + end Set_Completion_Referenced; + + --------------------- + -- Set_Fixed_Range -- + --------------------- + + -- The range for fixed-point types is complicated by the fact that we + -- do not know the exact end points at the time of the declaration. This + -- is true for three reasons: + + -- A size clause may affect the fudging of the end-points + -- A small clause may affect the values of the end-points + -- We try to include the end-points if it does not affect the size + + -- This means that the actual end-points must be established at the point + -- when the type is frozen. Meanwhile, we first narrow the range as + -- permitted (so that it will fit if necessary in a small specified size), + -- and then build a range subtree with these narrowed bounds. + + -- Set_Fixed_Range constructs the range from real literal values, and sets + -- the range as the Scalar_Range of the given fixed-point type entity. + + -- The parent of this range is set to point to the entity so that it is + -- properly hooked into the tree (unlike normal Scalar_Range entries for + -- other scalar types, which are just pointers to the range in the + -- original tree, this would otherwise be an orphan). + + -- The tree is left unanalyzed. When the type is frozen, the processing + -- in Freeze.Freeze_Fixed_Point_Type notices that the range is not + -- analyzed, and uses this as an indication that it should complete + -- work on the range (it will know the final small and size values). + + procedure Set_Fixed_Range + (E : Entity_Id; + Loc : Source_Ptr; + Lo : Ureal; + Hi : Ureal) + is + S : constant Node_Id := + Make_Range (Loc, + Low_Bound => Make_Real_Literal (Loc, Lo), + High_Bound => Make_Real_Literal (Loc, Hi)); + begin + Set_Scalar_Range (E, S); + Set_Parent (S, E); + end Set_Fixed_Range; + + ---------------------------------- + -- Set_Scalar_Range_For_Subtype -- + ---------------------------------- + + procedure Set_Scalar_Range_For_Subtype + (Def_Id : Entity_Id; + R : Node_Id; + Subt : Entity_Id) + is + Kind : constant Entity_Kind := Ekind (Def_Id); + + begin + -- Defend against previous error + + if Nkind (R) = N_Error then + return; + end if; + + Set_Scalar_Range (Def_Id, R); + + -- We need to link the range into the tree before resolving it so + -- that types that are referenced, including importantly the subtype + -- itself, are properly frozen (Freeze_Expression requires that the + -- expression be properly linked into the tree). Of course if it is + -- already linked in, then we do not disturb the current link. + + if No (Parent (R)) then + Set_Parent (R, Def_Id); + end if; + + -- Reset the kind of the subtype during analysis of the range, to + -- catch possible premature use in the bounds themselves. + + Set_Ekind (Def_Id, E_Void); + Process_Range_Expr_In_Decl (R, Subt); + Set_Ekind (Def_Id, Kind); + end Set_Scalar_Range_For_Subtype; + + -------------------------------------------------------- + -- Set_Stored_Constraint_From_Discriminant_Constraint -- + -------------------------------------------------------- + + procedure Set_Stored_Constraint_From_Discriminant_Constraint + (E : Entity_Id) + is + begin + -- Make sure set if encountered during Expand_To_Stored_Constraint + + Set_Stored_Constraint (E, No_Elist); + + -- Give it the right value + + if Is_Constrained (E) and then Has_Discriminants (E) then + Set_Stored_Constraint (E, + Expand_To_Stored_Constraint (E, Discriminant_Constraint (E))); + end if; + end Set_Stored_Constraint_From_Discriminant_Constraint; + + ------------------------------------- + -- Signed_Integer_Type_Declaration -- + ------------------------------------- + + procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id) is + Implicit_Base : Entity_Id; + Base_Typ : Entity_Id; + Lo_Val : Uint; + Hi_Val : Uint; + Errs : Boolean := False; + Lo : Node_Id; + Hi : Node_Id; + + function Can_Derive_From (E : Entity_Id) return Boolean; + -- Determine whether given bounds allow derivation from specified type + + procedure Check_Bound (Expr : Node_Id); + -- Check bound to make sure it is integral and static. If not, post + -- appropriate error message and set Errs flag + + --------------------- + -- Can_Derive_From -- + --------------------- + + -- Note we check both bounds against both end values, to deal with + -- strange types like ones with a range of 0 .. -12341234. + + function Can_Derive_From (E : Entity_Id) return Boolean is + Lo : constant Uint := Expr_Value (Type_Low_Bound (E)); + Hi : constant Uint := Expr_Value (Type_High_Bound (E)); + begin + return Lo <= Lo_Val and then Lo_Val <= Hi + and then + Lo <= Hi_Val and then Hi_Val <= Hi; + end Can_Derive_From; + + ----------------- + -- Check_Bound -- + ----------------- + + procedure Check_Bound (Expr : Node_Id) is + begin + -- If a range constraint is used as an integer type definition, each + -- bound of the range must be defined by a static expression of some + -- integer type, but the two bounds need not have the same integer + -- type (Negative bounds are allowed.) (RM 3.5.4) + + if not Is_Integer_Type (Etype (Expr)) then + Error_Msg_N + ("integer type definition bounds must be of integer type", Expr); + Errs := True; + + elsif not Is_OK_Static_Expression (Expr) then + Flag_Non_Static_Expr + ("non-static expression used for integer type bound!", Expr); + Errs := True; + + -- The bounds are folded into literals, and we set their type to be + -- universal, to avoid typing difficulties: we cannot set the type + -- of the literal to the new type, because this would be a forward + -- reference for the back end, and if the original type is user- + -- defined this can lead to spurious semantic errors (e.g. 2928-003). + + else + if Is_Entity_Name (Expr) then + Fold_Uint (Expr, Expr_Value (Expr), True); + end if; + + Set_Etype (Expr, Universal_Integer); + end if; + end Check_Bound; + + -- Start of processing for Signed_Integer_Type_Declaration + + begin + -- Create an anonymous base type + + Implicit_Base := + Create_Itype (E_Signed_Integer_Type, Parent (Def), T, 'B'); + + -- Analyze and check the bounds, they can be of any integer type + + Lo := Low_Bound (Def); + Hi := High_Bound (Def); + + -- Arbitrarily use Integer as the type if either bound had an error + + if Hi = Error or else Lo = Error then + Base_Typ := Any_Integer; + Set_Error_Posted (T, True); + + -- Here both bounds are OK expressions + + else + Analyze_And_Resolve (Lo, Any_Integer); + Analyze_And_Resolve (Hi, Any_Integer); + + Check_Bound (Lo); + Check_Bound (Hi); + + if Errs then + Hi := Type_High_Bound (Standard_Long_Long_Integer); + Lo := Type_Low_Bound (Standard_Long_Long_Integer); + end if; + + -- Find type to derive from + + Lo_Val := Expr_Value (Lo); + Hi_Val := Expr_Value (Hi); + + if Can_Derive_From (Standard_Short_Short_Integer) then + Base_Typ := Base_Type (Standard_Short_Short_Integer); + + elsif Can_Derive_From (Standard_Short_Integer) then + Base_Typ := Base_Type (Standard_Short_Integer); + + elsif Can_Derive_From (Standard_Integer) then + Base_Typ := Base_Type (Standard_Integer); + + elsif Can_Derive_From (Standard_Long_Integer) then + Base_Typ := Base_Type (Standard_Long_Integer); + + elsif Can_Derive_From (Standard_Long_Long_Integer) then + Base_Typ := Base_Type (Standard_Long_Long_Integer); + + else + Base_Typ := Base_Type (Standard_Long_Long_Integer); + Error_Msg_N ("integer type definition bounds out of range", Def); + Hi := Type_High_Bound (Standard_Long_Long_Integer); + Lo := Type_Low_Bound (Standard_Long_Long_Integer); + end if; + end if; + + -- Complete both implicit base and declared first subtype entities + + Set_Etype (Implicit_Base, Base_Typ); + Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ)); + Set_Size_Info (Implicit_Base, (Base_Typ)); + Set_RM_Size (Implicit_Base, RM_Size (Base_Typ)); + Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ)); + + Set_Ekind (T, E_Signed_Integer_Subtype); + Set_Etype (T, Implicit_Base); + + Set_Size_Info (T, (Implicit_Base)); + Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); + Set_Scalar_Range (T, Def); + Set_RM_Size (T, UI_From_Int (Minimum_Size (T))); + Set_Is_Constrained (T); + end Signed_Integer_Type_Declaration; + +end Sem_Ch3; diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads new file mode 100644 index 000000000..46605b371 --- /dev/null +++ b/gcc/ada/sem_ch3.ads @@ -0,0 +1,299 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 3 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Nlists; use Nlists; +with Types; use Types; + +package Sem_Ch3 is + procedure Analyze_Component_Declaration (N : Node_Id); + procedure Analyze_Full_Type_Declaration (N : Node_Id); + procedure Analyze_Incomplete_Type_Decl (N : Node_Id); + procedure Analyze_Itype_Reference (N : Node_Id); + procedure Analyze_Number_Declaration (N : Node_Id); + procedure Analyze_Object_Declaration (N : Node_Id); + procedure Analyze_Others_Choice (N : Node_Id); + procedure Analyze_Private_Extension_Declaration (N : Node_Id); + procedure Analyze_Subtype_Indication (N : Node_Id); + procedure Analyze_Variant_Part (N : Node_Id); + + procedure Analyze_Subtype_Declaration + (N : Node_Id; + Skip : Boolean := False); + -- Called to analyze a subtype declaration. The parameter Skip is used for + -- Ada 2005 (AI-412). We set to True in order to avoid reentering the + -- defining identifier of N when analyzing a rewritten incomplete subtype + -- declaration. + + function Access_Definition + (Related_Nod : Node_Id; + N : Node_Id) return Entity_Id; + -- An access definition defines a general access type for a formal + -- parameter. The procedure is called when processing formals, when + -- the current scope is the subprogram. The Implicit type is attached + -- to the Related_Nod put into the enclosing scope, so that the only + -- entities defined in the spec are the formals themselves. + + procedure Access_Subprogram_Declaration + (T_Name : Entity_Id; + T_Def : Node_Id); + -- The subprogram specification yields the signature of an implicit + -- type, whose Ekind is Access_Subprogram_Type. This implicit type is + -- the designated type of the declared access type. In subprogram calls, + -- the signature of the implicit type works like the profile of a regular + -- subprogram. + + procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id); + -- Add to the list of primitives of Tagged_Type the internal entities + -- associated with covered interface primitives. These entities link the + -- interface primitives with the tagged type primitives that cover them. + + procedure Analyze_Declarations (L : List_Id); + -- Called to analyze a list of declarations (in what context ???). Also + -- performs necessary freezing actions (more description needed ???) + + procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id); + -- Analyze an interface declaration or a formal interface declaration + + procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id); + -- Process an array type declaration. If the array is constrained, we + -- create an implicit parent array type, with the same index types and + -- component type. + + procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id); + -- Process an access type declaration + + procedure Build_Itype_Reference (Ityp : Entity_Id; Nod : Node_Id); + -- Create a reference to an internal type, for use by Gigi. The back-end + -- elaborates itypes on demand, i.e. when their first use is seen. This can + -- lead to scope anomalies if the first use is within a scope that is + -- nested within the scope that contains the point of definition of the + -- itype. The Itype_Reference node forces the elaboration of the itype + -- in the proper scope. The node is inserted after Nod, which is the + -- enclosing declaration that generated Ityp. + -- + -- A related mechanism is used during expansion, for itypes created in + -- branches of conditionals. See Ensure_Defined in exp_util. + -- Could both mechanisms be merged ??? + + procedure Check_Abstract_Overriding (T : Entity_Id); + -- Check that all abstract subprograms inherited from T's parent type have + -- been overridden as required, and that nonabstract subprograms have not + -- been incorrectly overridden with an abstract subprogram. + + procedure Check_Aliased_Component_Types (T : Entity_Id); + -- Given an array type or record type T, check that if the type is + -- nonlimited, then the nominal subtype of any components of T that + -- have discriminants must be constrained. + + procedure Check_Completion (Body_Id : Node_Id := Empty); + -- At the end of a declarative part, verify that all entities that require + -- completion have received one. If Body_Id is absent, the error indicating + -- a missing completion is placed on the declaration that needs completion. + -- If Body_Id is present, it is the defining identifier of a package body, + -- and errors are posted on that node, rather than on the declarations that + -- require completion in the package declaration. + + procedure Derive_Subprogram + (New_Subp : in out Entity_Id; + Parent_Subp : Entity_Id; + Derived_Type : Entity_Id; + Parent_Type : Entity_Id; + Actual_Subp : Entity_Id := Empty); + -- Derive the subprogram Parent_Subp from Parent_Type, and replace the + -- subsidiary subtypes with the derived type to build the specification + -- of the inherited subprogram (returned in New_Subp). For tagged types, + -- the derived subprogram is aliased to that of the actual (in the + -- case where Actual_Subp is nonempty) rather than to the corresponding + -- subprogram of the parent type. + + procedure Derive_Subprograms + (Parent_Type : Entity_Id; + Derived_Type : Entity_Id; + Generic_Actual : Entity_Id := Empty); + -- To complete type derivation, collect/retrieve the primitive operations + -- of the parent type, and replace the subsidiary subtypes with the derived + -- type, to build the specs of the inherited ops. For generic actuals, the + -- mapping of the primitive operations to those of the parent type is also + -- done by rederiving the operations within the instance. For tagged types, + -- the derived subprograms are aliased to those of the actual, not those of + -- the ancestor. + -- + -- Note: one might expect this to be private to the package body, but there + -- is one rather unusual usage in package Exp_Dist. + + function Find_Hidden_Interface + (Src : Elist_Id; + Dest : Elist_Id) return Entity_Id; + -- Ada 2005: Determine whether the interfaces in list Src are all present + -- in the list Dest. Return the first differing interface, or Empty + -- otherwise. + + function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id; + -- Given a subtype indication S (which is really an N_Subtype_Indication + -- node or a plain N_Identifier), find the type of the subtype mark. + + function Find_Type_Name (N : Node_Id) return Entity_Id; + -- Enter the identifier in a type definition, or find the entity already + -- declared, in the case of the full declaration of an incomplete or + -- private type. If the previous declaration is tagged then the class-wide + -- entity is propagated to the identifier to prevent multiple incompatible + -- class-wide types that may be created for self-referential anonymous + -- access components. + + function Get_Discriminant_Value + (Discriminant : Entity_Id; + Typ_For_Constraint : Entity_Id; + Constraint : Elist_Id) return Node_Id; + -- ??? MORE DOCUMENTATION + -- Given a discriminant somewhere in the Typ_For_Constraint tree and a + -- Constraint, return the value of that discriminant. + + function Is_Null_Extension (T : Entity_Id) return Boolean; + -- Returns True if the tagged type T has an N_Full_Type_Declaration that + -- is a null extension, meaning that it has an extension part without any + -- components and does not have a known discriminant part. + + function Is_Visible_Component (C : Entity_Id) return Boolean; + -- Determines if a record component C is visible in the present context. + -- Note that even though component C could appear in the entity chain + -- of a record type, C may not be visible in the current context. For + -- instance, C may be a component inherited in the full view of a private + -- extension which is not visible in the current context. + + procedure Make_Index + (I : Node_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id := Empty; + Suffix_Index : Nat := 1); + -- Process an index that is given in an array declaration, an entry + -- family declaration or a loop iteration. The index is given by an + -- index declaration (a 'box'), or by a discrete range. The later can + -- be the name of a discrete type, or a subtype indication. + -- + -- Related_Nod is the node where the potential generated implicit types + -- will be inserted. The 2 last parameters are used for creating the name. + + procedure Make_Class_Wide_Type (T : Entity_Id); + -- A Class_Wide_Type is created for each tagged type definition. The + -- attributes of a class-wide type are inherited from those of the type T. + -- If T is introduced by a private declaration, the corresponding class + -- wide type is created at the same time, and therefore there is a private + -- and a full declaration for the class-wide type as well. + + function OK_For_Limited_Init_In_05 + (Typ : Entity_Id; + Exp : Node_Id) return Boolean; + -- Presuming Exp is an expression of an inherently limited type Typ, + -- returns True if the expression is allowed in an initialization context + -- by the rules of Ada 2005. We use the rule in RM-7.5(2.1/2), "...it is an + -- aggregate, a function_call, or a parenthesized expression or qualified + -- expression whose operand is permitted...". Note that in Ada 95 mode, + -- we sometimes wish to give warnings based on whether the program _would_ + -- be legal in Ada 2005. Note that Exp must already have been resolved, + -- so we can know whether it's a function call (as opposed to an indexed + -- component, for example). In the case where Typ is a limited interface's + -- class-wide type, then the expression is allowed to be of any kind if its + -- type is a nonlimited descendant of the interface. + + function OK_For_Limited_Init + (Typ : Entity_Id; + Exp : Node_Id) return Boolean; + -- Always False in Ada 95 mode. Equivalent to OK_For_Limited_Init_In_05 in + -- Ada 2005 mode. + + procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id); + -- Default and per object expressions do not freeze their components, and + -- must be analyzed and resolved accordingly. The analysis is done by + -- calling the Preanalyze_And_Resolve routine and setting the global + -- In_Default_Expression flag. See the documentation section entitled + -- "Handling of Default and Per-Object Expressions" in sem.ads for full + -- details. N is the expression to be analyzed, T is the expected type. + -- This mechanism is also used for aspect specifications that have an + -- expression parameter that needs similar preanalysis. + + procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id); + -- Process some semantic actions when the full view of a private type is + -- encountered and analyzed. The first action is to create the full views + -- of the dependant private subtypes. The second action is to recopy the + -- primitive operations of the private view (in the tagged case). + -- N is the N_Full_Type_Declaration node. + -- + -- Full_T is the full view of the type whose full declaration is in N. + -- + -- Priv_T is the private view of the type whose full declaration is in N. + + procedure Process_Range_Expr_In_Decl + (R : Node_Id; + T : Entity_Id; + Check_List : List_Id := Empty_List; + R_Check_Off : Boolean := False); + -- Process a range expression that appears in a declaration context. The + -- range is analyzed and resolved with the base type of the given type, and + -- an appropriate check for expressions in non-static contexts made on the + -- bounds. R is analyzed and resolved using T, so the caller should if + -- necessary link R into the tree before the call, and in particular in the + -- case of a subtype declaration, it is appropriate to set the parent + -- pointer of R so that the types get properly frozen. Check_List is used + -- when the subprogram is called from Build_Record_Init_Proc and is used to + -- return a set of constraint checking statements generated by the Checks + -- package. R_Check_Off is set to True when the call to Range_Check is to + -- be skipped. + + function Process_Subtype + (S : Node_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id := Empty; + Suffix : Character := ' ') return Entity_Id; + -- Process a subtype indication S and return corresponding entity. + -- Related_Nod is the node where the potential generated implicit types + -- will be inserted. The Related_Id and Suffix parameters are used to + -- build the associated Implicit type name. + + procedure Process_Discriminants + (N : Node_Id; + Prev : Entity_Id := Empty); + -- Process the discriminants contained in an N_Full_Type_Declaration or + -- N_Incomplete_Type_Decl node N. If the declaration is a completion, + -- Prev is entity on the partial view, on which references are posted. + -- However, note that Process_Discriminants is called for a completion only + -- if partial view had no discriminants (else we just check conformance + -- between the two views and do not call Process_Discriminants again for + -- the completion). + + function Replace_Anonymous_Access_To_Protected_Subprogram + (N : Node_Id) return Entity_Id; + -- Ada 2005 (AI-254): Create and decorate an internal full type declaration + -- for an anonymous access to protected subprogram. For a record component + -- declaration, the type is created in the enclosing scope, for an array + -- type declaration or an object declaration it is simply placed ahead of + -- this declaration. + + procedure Set_Completion_Referenced (E : Entity_Id); + -- If E is the completion of a private or incomplete type declaration, + -- or the completion of a deferred constant declaration, mark the entity + -- as referenced. Warnings on unused entities, if needed, go on the + -- partial view. + +end Sem_Ch3; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb new file mode 100644 index 000000000..c94196ab0 --- /dev/null +++ b/gcc/ada/sem_ch4.adb @@ -0,0 +1,7394 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 4 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Util; use Exp_Util; +with Fname; use Fname; +with Itypes; use Itypes; +with Lib; use Lib; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; +with Namet.Sp; use Namet.Sp; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Output; use Output; +with Restrict; use Restrict; +with Rident; use Rident; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Case; use Sem_Case; +with Sem_Cat; use Sem_Cat; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch5; use Sem_Ch5; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Disp; use Sem_Disp; +with Sem_Dist; use Sem_Dist; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Tbuild; use Tbuild; + +package body Sem_Ch4 is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Analyze_Concatenation_Rest (N : Node_Id); + -- Does the "rest" of the work of Analyze_Concatenation, after the left + -- operand has been analyzed. See Analyze_Concatenation for details. + + procedure Analyze_Expression (N : Node_Id); + -- For expressions that are not names, this is just a call to analyze. + -- If the expression is a name, it may be a call to a parameterless + -- function, and if so must be converted into an explicit call node + -- and analyzed as such. This deproceduring must be done during the first + -- pass of overload resolution, because otherwise a procedure call with + -- overloaded actuals may fail to resolve. + + procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id); + -- Analyze a call of the form "+"(x, y), etc. The prefix of the call + -- is an operator name or an expanded name whose selector is an operator + -- name, and one possible interpretation is as a predefined operator. + + procedure Analyze_Overloaded_Selected_Component (N : Node_Id); + -- If the prefix of a selected_component is overloaded, the proper + -- interpretation that yields a record type with the proper selector + -- name must be selected. + + procedure Analyze_User_Defined_Binary_Op (N : Node_Id; Op_Id : Entity_Id); + -- Procedure to analyze a user defined binary operator, which is resolved + -- like a function, but instead of a list of actuals it is presented + -- with the left and right operands of an operator node. + + procedure Analyze_User_Defined_Unary_Op (N : Node_Id; Op_Id : Entity_Id); + -- Procedure to analyze a user defined unary operator, which is resolved + -- like a function, but instead of a list of actuals, it is presented with + -- the operand of the operator node. + + procedure Ambiguous_Operands (N : Node_Id); + -- For equality, membership, and comparison operators with overloaded + -- arguments, list possible interpretations. + + procedure Analyze_One_Call + (N : Node_Id; + Nam : Entity_Id; + Report : Boolean; + Success : out Boolean; + Skip_First : Boolean := False); + -- Check one interpretation of an overloaded subprogram name for + -- compatibility with the types of the actuals in a call. If there is a + -- single interpretation which does not match, post error if Report is + -- set to True. + -- + -- Nam is the entity that provides the formals against which the actuals + -- are checked. Nam is either the name of a subprogram, or the internal + -- subprogram type constructed for an access_to_subprogram. If the actuals + -- are compatible with Nam, then Nam is added to the list of candidate + -- interpretations for N, and Success is set to True. + -- + -- The flag Skip_First is used when analyzing a call that was rewritten + -- from object notation. In this case the first actual may have to receive + -- an explicit dereference, depending on the first formal of the operation + -- being called. The caller will have verified that the object is legal + -- for the call. If the remaining parameters match, the first parameter + -- will rewritten as a dereference if needed, prior to completing analysis. + + procedure Check_Misspelled_Selector + (Prefix : Entity_Id; + Sel : Node_Id); + -- Give possible misspelling diagnostic if Sel is likely to be a mis- + -- spelling of one of the selectors of the Prefix. This is called by + -- Analyze_Selected_Component after producing an invalid selector error + -- message. + + function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean; + -- Verify that type T is declared in scope S. Used to find interpretations + -- for operators given by expanded names. This is abstracted as a separate + -- function to handle extensions to System, where S is System, but T is + -- declared in the extension. + + procedure Find_Arithmetic_Types + (L, R : Node_Id; + Op_Id : Entity_Id; + N : Node_Id); + -- L and R are the operands of an arithmetic operator. Find + -- consistent pairs of interpretations for L and R that have a + -- numeric type consistent with the semantics of the operator. + + procedure Find_Comparison_Types + (L, R : Node_Id; + Op_Id : Entity_Id; + N : Node_Id); + -- L and R are operands of a comparison operator. Find consistent + -- pairs of interpretations for L and R. + + procedure Find_Concatenation_Types + (L, R : Node_Id; + Op_Id : Entity_Id; + N : Node_Id); + -- For the four varieties of concatenation + + procedure Find_Equality_Types + (L, R : Node_Id; + Op_Id : Entity_Id; + N : Node_Id); + -- Ditto for equality operators + + procedure Find_Boolean_Types + (L, R : Node_Id; + Op_Id : Entity_Id; + N : Node_Id); + -- Ditto for binary logical operations + + procedure Find_Negation_Types + (R : Node_Id; + Op_Id : Entity_Id; + N : Node_Id); + -- Find consistent interpretation for operand of negation operator + + procedure Find_Non_Universal_Interpretations + (N : Node_Id; + R : Node_Id; + Op_Id : Entity_Id; + T1 : Entity_Id); + -- For equality and comparison operators, the result is always boolean, + -- and the legality of the operation is determined from the visibility + -- of the operand types. If one of the operands has a universal interpre- + -- tation, the legality check uses some compatible non-universal + -- interpretation of the other operand. N can be an operator node, or + -- a function call whose name is an operator designator. + + function Find_Primitive_Operation (N : Node_Id) return Boolean; + -- Find candidate interpretations for the name Obj.Proc when it appears + -- in a subprogram renaming declaration. + + procedure Find_Unary_Types + (R : Node_Id; + Op_Id : Entity_Id; + N : Node_Id); + -- Unary arithmetic types: plus, minus, abs + + procedure Check_Arithmetic_Pair + (T1, T2 : Entity_Id; + Op_Id : Entity_Id; + N : Node_Id); + -- Subsidiary procedure to Find_Arithmetic_Types. T1 and T2 are valid + -- types for left and right operand. Determine whether they constitute + -- a valid pair for the given operator, and record the corresponding + -- interpretation of the operator node. The node N may be an operator + -- node (the usual case) or a function call whose prefix is an operator + -- designator. In both cases Op_Id is the operator name itself. + + procedure Diagnose_Call (N : Node_Id; Nam : Node_Id); + -- Give detailed information on overloaded call where none of the + -- interpretations match. N is the call node, Nam the designator for + -- the overloaded entity being called. + + function Junk_Operand (N : Node_Id) return Boolean; + -- Test for an operand that is an inappropriate entity (e.g. a package + -- name or a label). If so, issue an error message and return True. If + -- the operand is not an inappropriate entity kind, return False. + + procedure Operator_Check (N : Node_Id); + -- Verify that an operator has received some valid interpretation. If none + -- was found, determine whether a use clause would make the operation + -- legal. The variable Candidate_Type (defined in Sem_Type) is set for + -- every type compatible with the operator, even if the operator for the + -- type is not directly visible. The routine uses this type to emit a more + -- informative message. + + function Process_Implicit_Dereference_Prefix + (E : Entity_Id; + P : Node_Id) return Entity_Id; + -- Called when P is the prefix of an implicit dereference, denoting an + -- object E. The function returns the designated type of the prefix, taking + -- into account that the designated type of an anonymous access type may be + -- a limited view, when the non-limited view is visible. + -- If in semantics only mode (-gnatc or generic), the function also records + -- that the prefix is a reference to E, if any. Normally, such a reference + -- is generated only when the implicit dereference is expanded into an + -- explicit one, but for consistency we must generate the reference when + -- expansion is disabled as well. + + procedure Remove_Abstract_Operations (N : Node_Id); + -- Ada 2005: implementation of AI-310. An abstract non-dispatching + -- operation is not a candidate interpretation. + + function Try_Indexed_Call + (N : Node_Id; + Nam : Entity_Id; + Typ : Entity_Id; + Skip_First : Boolean) return Boolean; + -- If a function has defaults for all its actuals, a call to it may in fact + -- be an indexing on the result of the call. Try_Indexed_Call attempts the + -- interpretation as an indexing, prior to analysis as a call. If both are + -- possible, the node is overloaded with both interpretations (same symbol + -- but two different types). If the call is written in prefix form, the + -- prefix becomes the first parameter in the call, and only the remaining + -- actuals must be checked for the presence of defaults. + + function Try_Indirect_Call + (N : Node_Id; + Nam : Entity_Id; + Typ : Entity_Id) return Boolean; + -- Similarly, a function F that needs no actuals can return an access to a + -- subprogram, and the call F (X) interpreted as F.all (X). In this case + -- the call may be overloaded with both interpretations. + + function Try_Object_Operation (N : Node_Id) return Boolean; + -- Ada 2005 (AI-252): Support the object.operation notation. If node N + -- is a call in this notation, it is transformed into a normal subprogram + -- call where the prefix is a parameter, and True is returned. If node + -- N is not of this form, it is unchanged, and False is returned. + + procedure wpo (T : Entity_Id); + pragma Warnings (Off, wpo); + -- Used for debugging: obtain list of primitive operations even if + -- type is not frozen and dispatch table is not built yet. + + ------------------------ + -- Ambiguous_Operands -- + ------------------------ + + procedure Ambiguous_Operands (N : Node_Id) is + procedure List_Operand_Interps (Opnd : Node_Id); + + -------------------------- + -- List_Operand_Interps -- + -------------------------- + + procedure List_Operand_Interps (Opnd : Node_Id) is + Nam : Node_Id; + Err : Node_Id := N; + + begin + if Is_Overloaded (Opnd) then + if Nkind (Opnd) in N_Op then + Nam := Opnd; + elsif Nkind (Opnd) = N_Function_Call then + Nam := Name (Opnd); + else + return; + end if; + + else + return; + end if; + + if Opnd = Left_Opnd (N) then + Error_Msg_N ("\left operand has the following interpretations", N); + else + Error_Msg_N + ("\right operand has the following interpretations", N); + Err := Opnd; + end if; + + List_Interps (Nam, Err); + end List_Operand_Interps; + + -- Start of processing for Ambiguous_Operands + + begin + if Nkind (N) in N_Membership_Test then + Error_Msg_N ("ambiguous operands for membership", N); + + elsif Nkind_In (N, N_Op_Eq, N_Op_Ne) then + Error_Msg_N ("ambiguous operands for equality", N); + + else + Error_Msg_N ("ambiguous operands for comparison", N); + end if; + + if All_Errors_Mode then + List_Operand_Interps (Left_Opnd (N)); + List_Operand_Interps (Right_Opnd (N)); + else + Error_Msg_N ("\use -gnatf switch for details", N); + end if; + end Ambiguous_Operands; + + ----------------------- + -- Analyze_Aggregate -- + ----------------------- + + -- Most of the analysis of Aggregates requires that the type be known, + -- and is therefore put off until resolution. + + procedure Analyze_Aggregate (N : Node_Id) is + begin + if No (Etype (N)) then + Set_Etype (N, Any_Composite); + end if; + end Analyze_Aggregate; + + ----------------------- + -- Analyze_Allocator -- + ----------------------- + + procedure Analyze_Allocator (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Sav_Errs : constant Nat := Serious_Errors_Detected; + E : Node_Id := Expression (N); + Acc_Type : Entity_Id; + Type_Id : Entity_Id; + P : Node_Id; + C : Node_Id; + + begin + -- Deal with allocator restrictions + + -- In accordance with H.4(7), the No_Allocators restriction only applies + -- to user-written allocators. The same consideration applies to the + -- No_Allocators_Before_Elaboration restriction. + + if Comes_From_Source (N) then + Check_Restriction (No_Allocators, N); + + -- Processing for No_Allocators_After_Elaboration, loop to look at + -- enclosing context, checking task case and main subprogram case. + + C := N; + P := Parent (C); + while Present (P) loop + + -- In both cases we need a handled sequence of statements, where + -- the occurrence of the allocator is within the statements. + + if Nkind (P) = N_Handled_Sequence_Of_Statements + and then Is_List_Member (C) + and then List_Containing (C) = Statements (P) + then + -- Check for allocator within task body, this is a definite + -- violation of No_Allocators_After_Elaboration we can detect. + + if Nkind (Original_Node (Parent (P))) = N_Task_Body then + Check_Restriction (No_Allocators_After_Elaboration, N); + exit; + end if; + + -- The other case is appearance in a subprogram body. This may + -- be a violation if this is a library level subprogram, and it + -- turns out to be used as the main program, but only the + -- binder knows that, so just record the occurrence. + + if Nkind (Original_Node (Parent (P))) = N_Subprogram_Body + and then Nkind (Parent (Parent (P))) = N_Compilation_Unit + then + Set_Has_Allocator (Current_Sem_Unit); + end if; + end if; + + C := P; + P := Parent (C); + end loop; + end if; + + -- Analyze the allocator + + if Nkind (E) = N_Qualified_Expression then + Acc_Type := Create_Itype (E_Allocator_Type, N); + Set_Etype (Acc_Type, Acc_Type); + Find_Type (Subtype_Mark (E)); + + -- Analyze the qualified expression, and apply the name resolution + -- rule given in 4.7 (3). + + Analyze (E); + Type_Id := Etype (E); + Set_Directly_Designated_Type (Acc_Type, Type_Id); + + Resolve (Expression (E), Type_Id); + + if Is_Limited_Type (Type_Id) + and then Comes_From_Source (N) + and then not In_Instance_Body + then + if not OK_For_Limited_Init (Type_Id, Expression (E)) then + Error_Msg_N ("initialization not allowed for limited types", N); + Explain_Limited_Type (Type_Id, N); + end if; + end if; + + -- A qualified expression requires an exact match of the type, + -- class-wide matching is not allowed. + + -- if Is_Class_Wide_Type (Type_Id) + -- and then Base_Type + -- (Etype (Expression (E))) /= Base_Type (Type_Id) + -- then + -- Wrong_Type (Expression (E), Type_Id); + -- end if; + + Check_Non_Static_Context (Expression (E)); + + -- We don't analyze the qualified expression itself because it's + -- part of the allocator + + Set_Etype (E, Type_Id); + + -- Case where allocator has a subtype indication + + else + declare + Def_Id : Entity_Id; + Base_Typ : Entity_Id; + + begin + -- If the allocator includes a N_Subtype_Indication then a + -- constraint is present, otherwise the node is a subtype mark. + -- Introduce an explicit subtype declaration into the tree + -- defining some anonymous subtype and rewrite the allocator to + -- use this subtype rather than the subtype indication. + + -- It is important to introduce the explicit subtype declaration + -- so that the bounds of the subtype indication are attached to + -- the tree in case the allocator is inside a generic unit. + + if Nkind (E) = N_Subtype_Indication then + + -- A constraint is only allowed for a composite type in Ada + -- 95. In Ada 83, a constraint is also allowed for an + -- access-to-composite type, but the constraint is ignored. + + Find_Type (Subtype_Mark (E)); + Base_Typ := Entity (Subtype_Mark (E)); + + if Is_Elementary_Type (Base_Typ) then + if not (Ada_Version = Ada_83 + and then Is_Access_Type (Base_Typ)) + then + Error_Msg_N ("constraint not allowed here", E); + + if Nkind (Constraint (E)) = + N_Index_Or_Discriminant_Constraint + then + Error_Msg_N -- CODEFIX + ("\if qualified expression was meant, " & + "use apostrophe", Constraint (E)); + end if; + end if; + + -- Get rid of the bogus constraint: + + Rewrite (E, New_Copy_Tree (Subtype_Mark (E))); + Analyze_Allocator (N); + return; + + -- Ada 2005, AI-363: if the designated type has a constrained + -- partial view, it cannot receive a discriminant constraint, + -- and the allocated object is unconstrained. + + elsif Ada_Version >= Ada_2005 + and then Has_Constrained_Partial_View (Base_Typ) + then + Error_Msg_N + ("constraint no allowed when type " & + "has a constrained partial view", Constraint (E)); + end if; + + if Expander_Active then + Def_Id := Make_Temporary (Loc, 'S'); + + Insert_Action (E, + Make_Subtype_Declaration (Loc, + Defining_Identifier => Def_Id, + Subtype_Indication => Relocate_Node (E))); + + if Sav_Errs /= Serious_Errors_Detected + and then Nkind (Constraint (E)) = + N_Index_Or_Discriminant_Constraint + then + Error_Msg_N -- CODEFIX + ("if qualified expression was meant, " & + "use apostrophe!", Constraint (E)); + end if; + + E := New_Occurrence_Of (Def_Id, Loc); + Rewrite (Expression (N), E); + end if; + end if; + + Type_Id := Process_Subtype (E, N); + Acc_Type := Create_Itype (E_Allocator_Type, N); + Set_Etype (Acc_Type, Acc_Type); + Set_Directly_Designated_Type (Acc_Type, Type_Id); + Check_Fully_Declared (Type_Id, N); + + -- Ada 2005 (AI-231): If the designated type is itself an access + -- type that excludes null, its default initialization will + -- be a null object, and we can insert an unconditional raise + -- before the allocator. + + -- Ada 2012 (AI-104): A not null indication here is altogether + -- illegal. + + if Can_Never_Be_Null (Type_Id) then + declare + Not_Null_Check : constant Node_Id := + Make_Raise_Constraint_Error (Sloc (E), + Reason => CE_Null_Not_Allowed); + + begin + if Ada_Version >= Ada_2012 then + Error_Msg_N + ("an uninitialized allocator cannot have" + & " a null exclusion", N); + + elsif Expander_Active then + Insert_Action (N, Not_Null_Check); + Analyze (Not_Null_Check); + + else + Error_Msg_N ("null value not allowed here?", E); + end if; + end; + end if; + + -- Check restriction against dynamically allocated protected + -- objects. Note that when limited aggregates are supported, + -- a similar test should be applied to an allocator with a + -- qualified expression ??? + + if Is_Protected_Type (Type_Id) then + Check_Restriction (No_Protected_Type_Allocators, N); + end if; + + -- Check for missing initialization. Skip this check if we already + -- had errors on analyzing the allocator, since in that case these + -- are probably cascaded errors. + + if Is_Indefinite_Subtype (Type_Id) + and then Serious_Errors_Detected = Sav_Errs + then + if Is_Class_Wide_Type (Type_Id) then + Error_Msg_N + ("initialization required in class-wide allocation", N); + else + if Ada_Version < Ada_2005 + and then Is_Limited_Type (Type_Id) + then + Error_Msg_N ("unconstrained allocation not allowed", N); + + if Is_Array_Type (Type_Id) then + Error_Msg_N + ("\constraint with array bounds required", N); + + elsif Has_Unknown_Discriminants (Type_Id) then + null; + + else pragma Assert (Has_Discriminants (Type_Id)); + Error_Msg_N + ("\constraint with discriminant values required", N); + end if; + + -- Limited Ada 2005 and general non-limited case + + else + Error_Msg_N + ("uninitialized unconstrained allocation not allowed", + N); + + if Is_Array_Type (Type_Id) then + Error_Msg_N + ("\qualified expression or constraint with " & + "array bounds required", N); + + elsif Has_Unknown_Discriminants (Type_Id) then + Error_Msg_N ("\qualified expression required", N); + + else pragma Assert (Has_Discriminants (Type_Id)); + Error_Msg_N + ("\qualified expression or constraint with " & + "discriminant values required", N); + end if; + end if; + end if; + end if; + end; + end if; + + if Is_Abstract_Type (Type_Id) then + Error_Msg_N ("cannot allocate abstract object", E); + end if; + + if Has_Task (Designated_Type (Acc_Type)) then + Check_Restriction (No_Tasking, N); + Check_Restriction (Max_Tasks, N); + Check_Restriction (No_Task_Allocators, N); + + -- Check that an allocator with task parts isn't for a nested access + -- type when restriction No_Task_Hierarchy applies. + + if not Is_Library_Level_Entity (Acc_Type) then + Check_Restriction (No_Task_Hierarchy, N); + end if; + end if; + + -- Check that an allocator of a nested access type doesn't create a + -- protected object when restriction No_Local_Protected_Objects applies. + -- We don't have an equivalent to Has_Task for protected types, so only + -- cases where the designated type itself is a protected type are + -- currently checked. ??? + + if Is_Protected_Type (Designated_Type (Acc_Type)) + and then not Is_Library_Level_Entity (Acc_Type) + then + Check_Restriction (No_Local_Protected_Objects, N); + end if; + + -- If the No_Streams restriction is set, check that the type of the + -- object is not, and does not contain, any subtype derived from + -- Ada.Streams.Root_Stream_Type. Note that we guard the call to + -- Has_Stream just for efficiency reasons. There is no point in + -- spending time on a Has_Stream check if the restriction is not set. + + if Restriction_Check_Required (No_Streams) then + if Has_Stream (Designated_Type (Acc_Type)) then + Check_Restriction (No_Streams, N); + end if; + end if; + + Set_Etype (N, Acc_Type); + + if not Is_Library_Level_Entity (Acc_Type) then + Check_Restriction (No_Local_Allocators, N); + end if; + + if Serious_Errors_Detected > Sav_Errs then + Set_Error_Posted (N); + Set_Etype (N, Any_Type); + end if; + end Analyze_Allocator; + + --------------------------- + -- Analyze_Arithmetic_Op -- + --------------------------- + + procedure Analyze_Arithmetic_Op (N : Node_Id) is + L : constant Node_Id := Left_Opnd (N); + R : constant Node_Id := Right_Opnd (N); + Op_Id : Entity_Id; + + begin + Candidate_Type := Empty; + Analyze_Expression (L); + Analyze_Expression (R); + + -- If the entity is already set, the node is the instantiation of a + -- generic node with a non-local reference, or was manufactured by a + -- call to Make_Op_xxx. In either case the entity is known to be valid, + -- and we do not need to collect interpretations, instead we just get + -- the single possible interpretation. + + Op_Id := Entity (N); + + if Present (Op_Id) then + if Ekind (Op_Id) = E_Operator then + + if Nkind_In (N, N_Op_Divide, N_Op_Mod, N_Op_Multiply, N_Op_Rem) + and then Treat_Fixed_As_Integer (N) + then + null; + else + Set_Etype (N, Any_Type); + Find_Arithmetic_Types (L, R, Op_Id, N); + end if; + + else + Set_Etype (N, Any_Type); + Add_One_Interp (N, Op_Id, Etype (Op_Id)); + end if; + + -- Entity is not already set, so we do need to collect interpretations + + else + Op_Id := Get_Name_Entity_Id (Chars (N)); + Set_Etype (N, Any_Type); + + while Present (Op_Id) loop + if Ekind (Op_Id) = E_Operator + and then Present (Next_Entity (First_Entity (Op_Id))) + then + Find_Arithmetic_Types (L, R, Op_Id, N); + + -- The following may seem superfluous, because an operator cannot + -- be generic, but this ignores the cleverness of the author of + -- ACVC bc1013a. + + elsif Is_Overloadable (Op_Id) then + Analyze_User_Defined_Binary_Op (N, Op_Id); + end if; + + Op_Id := Homonym (Op_Id); + end loop; + end if; + + Operator_Check (N); + end Analyze_Arithmetic_Op; + + ------------------ + -- Analyze_Call -- + ------------------ + + -- Function, procedure, and entry calls are checked here. The Name in + -- the call may be overloaded. The actuals have been analyzed and may + -- themselves be overloaded. On exit from this procedure, the node N + -- may have zero, one or more interpretations. In the first case an + -- error message is produced. In the last case, the node is flagged + -- as overloaded and the interpretations are collected in All_Interp. + + -- If the name is an Access_To_Subprogram, it cannot be overloaded, but + -- the type-checking is similar to that of other calls. + + procedure Analyze_Call (N : Node_Id) is + Actuals : constant List_Id := Parameter_Associations (N); + Nam : Node_Id; + X : Interp_Index; + It : Interp; + Nam_Ent : Entity_Id; + Success : Boolean := False; + + Deref : Boolean := False; + -- Flag indicates whether an interpretation of the prefix is a + -- parameterless call that returns an access_to_subprogram. + + function Name_Denotes_Function return Boolean; + -- If the type of the name is an access to subprogram, this may be the + -- type of a name, or the return type of the function being called. If + -- the name is not an entity then it can denote a protected function. + -- Until we distinguish Etype from Return_Type, we must use this routine + -- to resolve the meaning of the name in the call. + + procedure No_Interpretation; + -- Output error message when no valid interpretation exists + + --------------------------- + -- Name_Denotes_Function -- + --------------------------- + + function Name_Denotes_Function return Boolean is + begin + if Is_Entity_Name (Nam) then + return Ekind (Entity (Nam)) = E_Function; + + elsif Nkind (Nam) = N_Selected_Component then + return Ekind (Entity (Selector_Name (Nam))) = E_Function; + + else + return False; + end if; + end Name_Denotes_Function; + + ----------------------- + -- No_Interpretation -- + ----------------------- + + procedure No_Interpretation is + L : constant Boolean := Is_List_Member (N); + K : constant Node_Kind := Nkind (Parent (N)); + + begin + -- If the node is in a list whose parent is not an expression then it + -- must be an attempted procedure call. + + if L and then K not in N_Subexpr then + if Ekind (Entity (Nam)) = E_Generic_Procedure then + Error_Msg_NE + ("must instantiate generic procedure& before call", + Nam, Entity (Nam)); + else + Error_Msg_N + ("procedure or entry name expected", Nam); + end if; + + -- Check for tasking cases where only an entry call will do + + elsif not L + and then Nkind_In (K, N_Entry_Call_Alternative, + N_Triggering_Alternative) + then + Error_Msg_N ("entry name expected", Nam); + + -- Otherwise give general error message + + else + Error_Msg_N ("invalid prefix in call", Nam); + end if; + end No_Interpretation; + + -- Start of processing for Analyze_Call + + begin + -- Initialize the type of the result of the call to the error type, + -- which will be reset if the type is successfully resolved. + + Set_Etype (N, Any_Type); + + Nam := Name (N); + + if not Is_Overloaded (Nam) then + + -- Only one interpretation to check + + if Ekind (Etype (Nam)) = E_Subprogram_Type then + Nam_Ent := Etype (Nam); + + -- If the prefix is an access_to_subprogram, this may be an indirect + -- call. This is the case if the name in the call is not an entity + -- name, or if it is a function name in the context of a procedure + -- call. In this latter case, we have a call to a parameterless + -- function that returns a pointer_to_procedure which is the entity + -- being called. Finally, F (X) may be a call to a parameterless + -- function that returns a pointer to a function with parameters. + + elsif Is_Access_Type (Etype (Nam)) + and then Ekind (Designated_Type (Etype (Nam))) = E_Subprogram_Type + and then + (not Name_Denotes_Function + or else Nkind (N) = N_Procedure_Call_Statement + or else + (Nkind (Parent (N)) /= N_Explicit_Dereference + and then Is_Entity_Name (Nam) + and then No (First_Formal (Entity (Nam))) + and then Present (Actuals))) + then + Nam_Ent := Designated_Type (Etype (Nam)); + Insert_Explicit_Dereference (Nam); + + -- Selected component case. Simple entry or protected operation, + -- where the entry name is given by the selector name. + + elsif Nkind (Nam) = N_Selected_Component then + Nam_Ent := Entity (Selector_Name (Nam)); + + if not Ekind_In (Nam_Ent, E_Entry, + E_Entry_Family, + E_Function, + E_Procedure) + then + Error_Msg_N ("name in call is not a callable entity", Nam); + Set_Etype (N, Any_Type); + return; + end if; + + -- If the name is an Indexed component, it can be a call to a member + -- of an entry family. The prefix must be a selected component whose + -- selector is the entry. Analyze_Procedure_Call normalizes several + -- kinds of call into this form. + + elsif Nkind (Nam) = N_Indexed_Component then + if Nkind (Prefix (Nam)) = N_Selected_Component then + Nam_Ent := Entity (Selector_Name (Prefix (Nam))); + else + Error_Msg_N ("name in call is not a callable entity", Nam); + Set_Etype (N, Any_Type); + return; + end if; + + elsif not Is_Entity_Name (Nam) then + Error_Msg_N ("name in call is not a callable entity", Nam); + Set_Etype (N, Any_Type); + return; + + else + Nam_Ent := Entity (Nam); + + -- If no interpretations, give error message + + if not Is_Overloadable (Nam_Ent) then + No_Interpretation; + return; + end if; + end if; + + -- Operations generated for RACW stub types are called only through + -- dispatching, and can never be the static interpretation of a call. + + if Is_RACW_Stub_Type_Operation (Nam_Ent) then + No_Interpretation; + return; + end if; + + Analyze_One_Call (N, Nam_Ent, True, Success); + + -- If this is an indirect call, the return type of the access_to + -- subprogram may be an incomplete type. At the point of the call, + -- use the full type if available, and at the same time update the + -- return type of the access_to_subprogram. + + if Success + and then Nkind (Nam) = N_Explicit_Dereference + and then Ekind (Etype (N)) = E_Incomplete_Type + and then Present (Full_View (Etype (N))) + then + Set_Etype (N, Full_View (Etype (N))); + Set_Etype (Nam_Ent, Etype (N)); + end if; + + else + -- An overloaded selected component must denote overloaded operations + -- of a concurrent type. The interpretations are attached to the + -- simple name of those operations. + + if Nkind (Nam) = N_Selected_Component then + Nam := Selector_Name (Nam); + end if; + + Get_First_Interp (Nam, X, It); + + while Present (It.Nam) loop + Nam_Ent := It.Nam; + Deref := False; + + -- Name may be call that returns an access to subprogram, or more + -- generally an overloaded expression one of whose interpretations + -- yields an access to subprogram. If the name is an entity, we do + -- not dereference, because the node is a call that returns the + -- access type: note difference between f(x), where the call may + -- return an access subprogram type, and f(x)(y), where the type + -- returned by the call to f is implicitly dereferenced to analyze + -- the outer call. + + if Is_Access_Type (Nam_Ent) then + Nam_Ent := Designated_Type (Nam_Ent); + + elsif Is_Access_Type (Etype (Nam_Ent)) + and then + (not Is_Entity_Name (Nam) + or else Nkind (N) = N_Procedure_Call_Statement) + and then Ekind (Designated_Type (Etype (Nam_Ent))) + = E_Subprogram_Type + then + Nam_Ent := Designated_Type (Etype (Nam_Ent)); + + if Is_Entity_Name (Nam) then + Deref := True; + end if; + end if; + + -- If the call has been rewritten from a prefixed call, the first + -- parameter has been analyzed, but may need a subsequent + -- dereference, so skip its analysis now. + + if N /= Original_Node (N) + and then Nkind (Original_Node (N)) = Nkind (N) + and then Nkind (Name (N)) /= Nkind (Name (Original_Node (N))) + and then Present (Parameter_Associations (N)) + and then Present (Etype (First (Parameter_Associations (N)))) + then + Analyze_One_Call + (N, Nam_Ent, False, Success, Skip_First => True); + else + Analyze_One_Call (N, Nam_Ent, False, Success); + end if; + + -- If the interpretation succeeds, mark the proper type of the + -- prefix (any valid candidate will do). If not, remove the + -- candidate interpretation. This only needs to be done for + -- overloaded protected operations, for other entities disambi- + -- guation is done directly in Resolve. + + if Success then + if Deref + and then Nkind (Parent (N)) /= N_Explicit_Dereference + then + Set_Entity (Nam, It.Nam); + Insert_Explicit_Dereference (Nam); + Set_Etype (Nam, Nam_Ent); + + else + Set_Etype (Nam, It.Typ); + end if; + + elsif Nkind_In (Name (N), N_Selected_Component, + N_Function_Call) + then + Remove_Interp (X); + end if; + + Get_Next_Interp (X, It); + end loop; + + -- If the name is the result of a function call, it can only + -- be a call to a function returning an access to subprogram. + -- Insert explicit dereference. + + if Nkind (Nam) = N_Function_Call then + Insert_Explicit_Dereference (Nam); + end if; + + if Etype (N) = Any_Type then + + -- None of the interpretations is compatible with the actuals + + Diagnose_Call (N, Nam); + + -- Special checks for uninstantiated put routines + + if Nkind (N) = N_Procedure_Call_Statement + and then Is_Entity_Name (Nam) + and then Chars (Nam) = Name_Put + and then List_Length (Actuals) = 1 + then + declare + Arg : constant Node_Id := First (Actuals); + Typ : Entity_Id; + + begin + if Nkind (Arg) = N_Parameter_Association then + Typ := Etype (Explicit_Actual_Parameter (Arg)); + else + Typ := Etype (Arg); + end if; + + if Is_Signed_Integer_Type (Typ) then + Error_Msg_N + ("possible missing instantiation of " & + "'Text_'I'O.'Integer_'I'O!", Nam); + + elsif Is_Modular_Integer_Type (Typ) then + Error_Msg_N + ("possible missing instantiation of " & + "'Text_'I'O.'Modular_'I'O!", Nam); + + elsif Is_Floating_Point_Type (Typ) then + Error_Msg_N + ("possible missing instantiation of " & + "'Text_'I'O.'Float_'I'O!", Nam); + + elsif Is_Ordinary_Fixed_Point_Type (Typ) then + Error_Msg_N + ("possible missing instantiation of " & + "'Text_'I'O.'Fixed_'I'O!", Nam); + + elsif Is_Decimal_Fixed_Point_Type (Typ) then + Error_Msg_N + ("possible missing instantiation of " & + "'Text_'I'O.'Decimal_'I'O!", Nam); + + elsif Is_Enumeration_Type (Typ) then + Error_Msg_N + ("possible missing instantiation of " & + "'Text_'I'O.'Enumeration_'I'O!", Nam); + end if; + end; + end if; + + elsif not Is_Overloaded (N) + and then Is_Entity_Name (Nam) + then + -- Resolution yields a single interpretation. Verify that the + -- reference has capitalization consistent with the declaration. + + Set_Entity_With_Style_Check (Nam, Entity (Nam)); + Generate_Reference (Entity (Nam), Nam); + + Set_Etype (Nam, Etype (Entity (Nam))); + else + Remove_Abstract_Operations (N); + end if; + + End_Interp_List; + end if; + end Analyze_Call; + + ----------------------------- + -- Analyze_Case_Expression -- + ----------------------------- + + procedure Analyze_Case_Expression (N : Node_Id) is + Expr : constant Node_Id := Expression (N); + FirstX : constant Node_Id := Expression (First (Alternatives (N))); + Alt : Node_Id; + Exp_Type : Entity_Id; + Exp_Btype : Entity_Id; + + Dont_Care : Boolean; + Others_Present : Boolean; + + procedure Non_Static_Choice_Error (Choice : Node_Id); + -- Error routine invoked by the generic instantiation below when + -- the case expression has a non static choice. + + package Case_Choices_Processing is new + Generic_Choices_Processing + (Get_Alternatives => Alternatives, + Get_Choices => Discrete_Choices, + Process_Empty_Choice => No_OP, + Process_Non_Static_Choice => Non_Static_Choice_Error, + Process_Associated_Node => No_OP); + use Case_Choices_Processing; + + ----------------------------- + -- Non_Static_Choice_Error -- + ----------------------------- + + procedure Non_Static_Choice_Error (Choice : Node_Id) is + begin + Flag_Non_Static_Expr + ("choice given in case expression is not static!", Choice); + end Non_Static_Choice_Error; + + -- Start of processing for Analyze_Case_Expression + + begin + if Comes_From_Source (N) then + Check_Compiler_Unit (N); + end if; + + Analyze_And_Resolve (Expr, Any_Discrete); + Check_Unset_Reference (Expr); + Exp_Type := Etype (Expr); + Exp_Btype := Base_Type (Exp_Type); + + Alt := First (Alternatives (N)); + while Present (Alt) loop + Analyze (Expression (Alt)); + Next (Alt); + end loop; + + if not Is_Overloaded (FirstX) then + Set_Etype (N, Etype (FirstX)); + + else + declare + I : Interp_Index; + It : Interp; + + begin + Set_Etype (N, Any_Type); + + Get_First_Interp (FirstX, I, It); + while Present (It.Nam) loop + + -- For each interpretation of the first expression, we only + -- add the interpretation if every other expression in the + -- case expression alternatives has a compatible type. + + Alt := Next (First (Alternatives (N))); + while Present (Alt) loop + exit when not Has_Compatible_Type (Expression (Alt), It.Typ); + Next (Alt); + end loop; + + if No (Alt) then + Add_One_Interp (N, It.Typ, It.Typ); + end if; + + Get_Next_Interp (I, It); + end loop; + end; + end if; + + Exp_Btype := Base_Type (Exp_Type); + + -- The expression must be of a discrete type which must be determinable + -- independently of the context in which the expression occurs, but + -- using the fact that the expression must be of a discrete type. + -- Moreover, the type this expression must not be a character literal + -- (which is always ambiguous). + + -- If error already reported by Resolve, nothing more to do + + if Exp_Btype = Any_Discrete + or else Exp_Btype = Any_Type + then + return; + + elsif Exp_Btype = Any_Character then + Error_Msg_N + ("character literal as case expression is ambiguous", Expr); + return; + end if; + + -- If the case expression is a formal object of mode in out, then + -- treat it as having a nonstatic subtype by forcing use of the base + -- type (which has to get passed to Check_Case_Choices below). Also + -- use base type when the case expression is parenthesized. + + if Paren_Count (Expr) > 0 + or else (Is_Entity_Name (Expr) + and then Ekind (Entity (Expr)) = E_Generic_In_Out_Parameter) + then + Exp_Type := Exp_Btype; + end if; + + -- Call instantiated Analyze_Choices which does the rest of the work + + Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present); + + if Exp_Type = Universal_Integer and then not Others_Present then + Error_Msg_N + ("case on universal integer requires OTHERS choice", Expr); + end if; + end Analyze_Case_Expression; + + --------------------------- + -- Analyze_Comparison_Op -- + --------------------------- + + procedure Analyze_Comparison_Op (N : Node_Id) is + L : constant Node_Id := Left_Opnd (N); + R : constant Node_Id := Right_Opnd (N); + Op_Id : Entity_Id := Entity (N); + + begin + Set_Etype (N, Any_Type); + Candidate_Type := Empty; + + Analyze_Expression (L); + Analyze_Expression (R); + + if Present (Op_Id) then + if Ekind (Op_Id) = E_Operator then + Find_Comparison_Types (L, R, Op_Id, N); + else + Add_One_Interp (N, Op_Id, Etype (Op_Id)); + end if; + + if Is_Overloaded (L) then + Set_Etype (L, Intersect_Types (L, R)); + end if; + + else + Op_Id := Get_Name_Entity_Id (Chars (N)); + while Present (Op_Id) loop + if Ekind (Op_Id) = E_Operator then + Find_Comparison_Types (L, R, Op_Id, N); + else + Analyze_User_Defined_Binary_Op (N, Op_Id); + end if; + + Op_Id := Homonym (Op_Id); + end loop; + end if; + + Operator_Check (N); + end Analyze_Comparison_Op; + + --------------------------- + -- Analyze_Concatenation -- + --------------------------- + + procedure Analyze_Concatenation (N : Node_Id) is + + -- We wish to avoid deep recursion, because concatenations are often + -- deeply nested, as in A&B&...&Z. Therefore, we walk down the left + -- operands nonrecursively until we find something that is not a + -- concatenation (A in this case), or has already been analyzed. We + -- analyze that, and then walk back up the tree following Parent + -- pointers, calling Analyze_Concatenation_Rest to do the rest of the + -- work at each level. The Parent pointers allow us to avoid recursion, + -- and thus avoid running out of memory. + + NN : Node_Id := N; + L : Node_Id; + + begin + Candidate_Type := Empty; + + -- The following code is equivalent to: + + -- Set_Etype (N, Any_Type); + -- Analyze_Expression (Left_Opnd (N)); + -- Analyze_Concatenation_Rest (N); + + -- where the Analyze_Expression call recurses back here if the left + -- operand is a concatenation. + + -- Walk down left operands + + loop + Set_Etype (NN, Any_Type); + L := Left_Opnd (NN); + exit when Nkind (L) /= N_Op_Concat or else Analyzed (L); + NN := L; + end loop; + + -- Now (given the above example) NN is A&B and L is A + + -- First analyze L ... + + Analyze_Expression (L); + + -- ... then walk NN back up until we reach N (where we started), calling + -- Analyze_Concatenation_Rest along the way. + + loop + Analyze_Concatenation_Rest (NN); + exit when NN = N; + NN := Parent (NN); + end loop; + end Analyze_Concatenation; + + -------------------------------- + -- Analyze_Concatenation_Rest -- + -------------------------------- + + -- If the only one-dimensional array type in scope is String, + -- this is the resulting type of the operation. Otherwise there + -- will be a concatenation operation defined for each user-defined + -- one-dimensional array. + + procedure Analyze_Concatenation_Rest (N : Node_Id) is + L : constant Node_Id := Left_Opnd (N); + R : constant Node_Id := Right_Opnd (N); + Op_Id : Entity_Id := Entity (N); + LT : Entity_Id; + RT : Entity_Id; + + begin + Analyze_Expression (R); + + -- If the entity is present, the node appears in an instance, and + -- denotes a predefined concatenation operation. The resulting type is + -- obtained from the arguments when possible. If the arguments are + -- aggregates, the array type and the concatenation type must be + -- visible. + + if Present (Op_Id) then + if Ekind (Op_Id) = E_Operator then + LT := Base_Type (Etype (L)); + RT := Base_Type (Etype (R)); + + if Is_Array_Type (LT) + and then (RT = LT or else RT = Base_Type (Component_Type (LT))) + then + Add_One_Interp (N, Op_Id, LT); + + elsif Is_Array_Type (RT) + and then LT = Base_Type (Component_Type (RT)) + then + Add_One_Interp (N, Op_Id, RT); + + -- If one operand is a string type or a user-defined array type, + -- and the other is a literal, result is of the specific type. + + elsif + (Root_Type (LT) = Standard_String + or else Scope (LT) /= Standard_Standard) + and then Etype (R) = Any_String + then + Add_One_Interp (N, Op_Id, LT); + + elsif + (Root_Type (RT) = Standard_String + or else Scope (RT) /= Standard_Standard) + and then Etype (L) = Any_String + then + Add_One_Interp (N, Op_Id, RT); + + elsif not Is_Generic_Type (Etype (Op_Id)) then + Add_One_Interp (N, Op_Id, Etype (Op_Id)); + + else + -- Type and its operations must be visible + + Set_Entity (N, Empty); + Analyze_Concatenation (N); + end if; + + else + Add_One_Interp (N, Op_Id, Etype (Op_Id)); + end if; + + else + Op_Id := Get_Name_Entity_Id (Name_Op_Concat); + while Present (Op_Id) loop + if Ekind (Op_Id) = E_Operator then + + -- Do not consider operators declared in dead code, they can + -- not be part of the resolution. + + if Is_Eliminated (Op_Id) then + null; + else + Find_Concatenation_Types (L, R, Op_Id, N); + end if; + + else + Analyze_User_Defined_Binary_Op (N, Op_Id); + end if; + + Op_Id := Homonym (Op_Id); + end loop; + end if; + + Operator_Check (N); + end Analyze_Concatenation_Rest; + + ------------------------------------ + -- Analyze_Conditional_Expression -- + ------------------------------------ + + procedure Analyze_Conditional_Expression (N : Node_Id) is + Condition : constant Node_Id := First (Expressions (N)); + Then_Expr : constant Node_Id := Next (Condition); + Else_Expr : Node_Id; + + begin + -- Defend against error of missing expressions from previous error + + if No (Then_Expr) then + return; + end if; + + Else_Expr := Next (Then_Expr); + + if Comes_From_Source (N) then + Check_Compiler_Unit (N); + end if; + + Analyze_Expression (Condition); + Analyze_Expression (Then_Expr); + + if Present (Else_Expr) then + Analyze_Expression (Else_Expr); + end if; + + -- If then expression not overloaded, then that decides the type + + if not Is_Overloaded (Then_Expr) then + Set_Etype (N, Etype (Then_Expr)); + + -- Case where then expression is overloaded + + else + declare + I : Interp_Index; + It : Interp; + + begin + Set_Etype (N, Any_Type); + Get_First_Interp (Then_Expr, I, It); + while Present (It.Nam) loop + + -- For each possible interpretation of the Then Expression, + -- add it only if the else expression has a compatible type. + + -- Is this right if Else_Expr is empty? + + if Has_Compatible_Type (Else_Expr, It.Typ) then + Add_One_Interp (N, It.Typ, It.Typ); + end if; + + Get_Next_Interp (I, It); + end loop; + end; + end if; + end Analyze_Conditional_Expression; + + ------------------------- + -- Analyze_Equality_Op -- + ------------------------- + + procedure Analyze_Equality_Op (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + L : constant Node_Id := Left_Opnd (N); + R : constant Node_Id := Right_Opnd (N); + Op_Id : Entity_Id; + + begin + Set_Etype (N, Any_Type); + Candidate_Type := Empty; + + Analyze_Expression (L); + Analyze_Expression (R); + + -- If the entity is set, the node is a generic instance with a non-local + -- reference to the predefined operator or to a user-defined function. + -- It can also be an inequality that is expanded into the negation of a + -- call to a user-defined equality operator. + + -- For the predefined case, the result is Boolean, regardless of the + -- type of the operands. The operands may even be limited, if they are + -- generic actuals. If they are overloaded, label the left argument with + -- the common type that must be present, or with the type of the formal + -- of the user-defined function. + + if Present (Entity (N)) then + Op_Id := Entity (N); + + if Ekind (Op_Id) = E_Operator then + Add_One_Interp (N, Op_Id, Standard_Boolean); + else + Add_One_Interp (N, Op_Id, Etype (Op_Id)); + end if; + + if Is_Overloaded (L) then + if Ekind (Op_Id) = E_Operator then + Set_Etype (L, Intersect_Types (L, R)); + else + Set_Etype (L, Etype (First_Formal (Op_Id))); + end if; + end if; + + else + Op_Id := Get_Name_Entity_Id (Chars (N)); + while Present (Op_Id) loop + if Ekind (Op_Id) = E_Operator then + Find_Equality_Types (L, R, Op_Id, N); + else + Analyze_User_Defined_Binary_Op (N, Op_Id); + end if; + + Op_Id := Homonym (Op_Id); + end loop; + end if; + + -- If there was no match, and the operator is inequality, this may + -- be a case where inequality has not been made explicit, as for + -- tagged types. Analyze the node as the negation of an equality + -- operation. This cannot be done earlier, because before analysis + -- we cannot rule out the presence of an explicit inequality. + + if Etype (N) = Any_Type + and then Nkind (N) = N_Op_Ne + then + Op_Id := Get_Name_Entity_Id (Name_Op_Eq); + while Present (Op_Id) loop + if Ekind (Op_Id) = E_Operator then + Find_Equality_Types (L, R, Op_Id, N); + else + Analyze_User_Defined_Binary_Op (N, Op_Id); + end if; + + Op_Id := Homonym (Op_Id); + end loop; + + if Etype (N) /= Any_Type then + Op_Id := Entity (N); + + Rewrite (N, + Make_Op_Not (Loc, + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => Left_Opnd (N), + Right_Opnd => Right_Opnd (N)))); + + Set_Entity (Right_Opnd (N), Op_Id); + Analyze (N); + end if; + end if; + + Operator_Check (N); + end Analyze_Equality_Op; + + ---------------------------------- + -- Analyze_Explicit_Dereference -- + ---------------------------------- + + procedure Analyze_Explicit_Dereference (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + P : constant Node_Id := Prefix (N); + T : Entity_Id; + I : Interp_Index; + It : Interp; + New_N : Node_Id; + + function Is_Function_Type return Boolean; + -- Check whether node may be interpreted as an implicit function call + + ---------------------- + -- Is_Function_Type -- + ---------------------- + + function Is_Function_Type return Boolean is + I : Interp_Index; + It : Interp; + + begin + if not Is_Overloaded (N) then + return Ekind (Base_Type (Etype (N))) = E_Subprogram_Type + and then Etype (Base_Type (Etype (N))) /= Standard_Void_Type; + + else + Get_First_Interp (N, I, It); + while Present (It.Nam) loop + if Ekind (Base_Type (It.Typ)) /= E_Subprogram_Type + or else Etype (Base_Type (It.Typ)) = Standard_Void_Type + then + return False; + end if; + + Get_Next_Interp (I, It); + end loop; + + return True; + end if; + end Is_Function_Type; + + -- Start of processing for Analyze_Explicit_Dereference + + begin + Analyze (P); + Set_Etype (N, Any_Type); + + -- Test for remote access to subprogram type, and if so return + -- after rewriting the original tree. + + if Remote_AST_E_Dereference (P) then + return; + end if; + + -- Normal processing for other than remote access to subprogram type + + if not Is_Overloaded (P) then + if Is_Access_Type (Etype (P)) then + + -- Set the Etype. We need to go through Is_For_Access_Subtypes to + -- avoid other problems caused by the Private_Subtype and it is + -- safe to go to the Base_Type because this is the same as + -- converting the access value to its Base_Type. + + declare + DT : Entity_Id := Designated_Type (Etype (P)); + + begin + if Ekind (DT) = E_Private_Subtype + and then Is_For_Access_Subtype (DT) + then + DT := Base_Type (DT); + end if; + + -- An explicit dereference is a legal occurrence of an + -- incomplete type imported through a limited_with clause, + -- if the full view is visible. + + if From_With_Type (DT) + and then not From_With_Type (Scope (DT)) + and then + (Is_Immediately_Visible (Scope (DT)) + or else + (Is_Child_Unit (Scope (DT)) + and then Is_Visible_Child_Unit (Scope (DT)))) + then + Set_Etype (N, Available_View (DT)); + + else + Set_Etype (N, DT); + end if; + end; + + elsif Etype (P) /= Any_Type then + Error_Msg_N ("prefix of dereference must be an access type", N); + return; + end if; + + else + Get_First_Interp (P, I, It); + while Present (It.Nam) loop + T := It.Typ; + + if Is_Access_Type (T) then + Add_One_Interp (N, Designated_Type (T), Designated_Type (T)); + end if; + + Get_Next_Interp (I, It); + end loop; + + -- Error if no interpretation of the prefix has an access type + + if Etype (N) = Any_Type then + Error_Msg_N + ("access type required in prefix of explicit dereference", P); + Set_Etype (N, Any_Type); + return; + end if; + end if; + + if Is_Function_Type + and then Nkind (Parent (N)) /= N_Indexed_Component + + and then (Nkind (Parent (N)) /= N_Function_Call + or else N /= Name (Parent (N))) + + and then (Nkind (Parent (N)) /= N_Procedure_Call_Statement + or else N /= Name (Parent (N))) + + and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration + and then (Nkind (Parent (N)) /= N_Attribute_Reference + or else + (Attribute_Name (Parent (N)) /= Name_Address + and then + Attribute_Name (Parent (N)) /= Name_Access)) + then + -- Name is a function call with no actuals, in a context that + -- requires deproceduring (including as an actual in an enclosing + -- function or procedure call). There are some pathological cases + -- where the prefix might include functions that return access to + -- subprograms and others that return a regular type. Disambiguation + -- of those has to take place in Resolve. + + New_N := + Make_Function_Call (Loc, + Name => Make_Explicit_Dereference (Loc, P), + Parameter_Associations => New_List); + + -- If the prefix is overloaded, remove operations that have formals, + -- we know that this is a parameterless call. + + if Is_Overloaded (P) then + Get_First_Interp (P, I, It); + while Present (It.Nam) loop + T := It.Typ; + + if No (First_Formal (Base_Type (Designated_Type (T)))) then + Set_Etype (P, T); + else + Remove_Interp (I); + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + + Rewrite (N, New_N); + Analyze (N); + + elsif not Is_Function_Type + and then Is_Overloaded (N) + then + -- The prefix may include access to subprograms and other access + -- types. If the context selects the interpretation that is a + -- function call (not a procedure call) we cannot rewrite the node + -- yet, but we include the result of the call interpretation. + + Get_First_Interp (N, I, It); + while Present (It.Nam) loop + if Ekind (Base_Type (It.Typ)) = E_Subprogram_Type + and then Etype (Base_Type (It.Typ)) /= Standard_Void_Type + and then Nkind (Parent (N)) /= N_Procedure_Call_Statement + then + Add_One_Interp (N, Etype (It.Typ), Etype (It.Typ)); + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + + -- A value of remote access-to-class-wide must not be dereferenced + -- (RM E.2.2(16)). + + Validate_Remote_Access_To_Class_Wide_Type (N); + end Analyze_Explicit_Dereference; + + ------------------------ + -- Analyze_Expression -- + ------------------------ + + procedure Analyze_Expression (N : Node_Id) is + begin + Analyze (N); + Check_Parameterless_Call (N); + end Analyze_Expression; + + ------------------------------------- + -- Analyze_Expression_With_Actions -- + ------------------------------------- + + procedure Analyze_Expression_With_Actions (N : Node_Id) is + A : Node_Id; + + begin + A := First (Actions (N)); + loop + Analyze (A); + Next (A); + exit when No (A); + end loop; + + Analyze_Expression (Expression (N)); + Set_Etype (N, Etype (Expression (N))); + end Analyze_Expression_With_Actions; + + ------------------------------------ + -- Analyze_Indexed_Component_Form -- + ------------------------------------ + + procedure Analyze_Indexed_Component_Form (N : Node_Id) is + P : constant Node_Id := Prefix (N); + Exprs : constant List_Id := Expressions (N); + Exp : Node_Id; + P_T : Entity_Id; + E : Node_Id; + U_N : Entity_Id; + + procedure Process_Function_Call; + -- Prefix in indexed component form is an overloadable entity, + -- so the node is a function call. Reformat it as such. + + procedure Process_Indexed_Component; + -- Prefix in indexed component form is actually an indexed component. + -- This routine processes it, knowing that the prefix is already + -- resolved. + + procedure Process_Indexed_Component_Or_Slice; + -- An indexed component with a single index may designate a slice if + -- the index is a subtype mark. This routine disambiguates these two + -- cases by resolving the prefix to see if it is a subtype mark. + + procedure Process_Overloaded_Indexed_Component; + -- If the prefix of an indexed component is overloaded, the proper + -- interpretation is selected by the index types and the context. + + --------------------------- + -- Process_Function_Call -- + --------------------------- + + procedure Process_Function_Call is + Actual : Node_Id; + + begin + Change_Node (N, N_Function_Call); + Set_Name (N, P); + Set_Parameter_Associations (N, Exprs); + + -- Analyze actuals prior to analyzing the call itself + + Actual := First (Parameter_Associations (N)); + while Present (Actual) loop + Analyze (Actual); + Check_Parameterless_Call (Actual); + + -- Move to next actual. Note that we use Next, not Next_Actual + -- here. The reason for this is a bit subtle. If a function call + -- includes named associations, the parser recognizes the node as + -- a call, and it is analyzed as such. If all associations are + -- positional, the parser builds an indexed_component node, and + -- it is only after analysis of the prefix that the construct + -- is recognized as a call, in which case Process_Function_Call + -- rewrites the node and analyzes the actuals. If the list of + -- actuals is malformed, the parser may leave the node as an + -- indexed component (despite the presence of named associations). + -- The iterator Next_Actual is equivalent to Next if the list is + -- positional, but follows the normalized chain of actuals when + -- named associations are present. In this case normalization has + -- not taken place, and actuals remain unanalyzed, which leads to + -- subsequent crashes or loops if there is an attempt to continue + -- analysis of the program. + + Next (Actual); + end loop; + + Analyze_Call (N); + end Process_Function_Call; + + ------------------------------- + -- Process_Indexed_Component -- + ------------------------------- + + procedure Process_Indexed_Component is + Exp : Node_Id; + Array_Type : Entity_Id; + Index : Node_Id; + Pent : Entity_Id := Empty; + + begin + Exp := First (Exprs); + + if Is_Overloaded (P) then + Process_Overloaded_Indexed_Component; + + else + Array_Type := Etype (P); + + if Is_Entity_Name (P) then + Pent := Entity (P); + elsif Nkind (P) = N_Selected_Component + and then Is_Entity_Name (Selector_Name (P)) + then + Pent := Entity (Selector_Name (P)); + end if; + + -- Prefix must be appropriate for an array type, taking into + -- account a possible implicit dereference. + + if Is_Access_Type (Array_Type) then + Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N); + Array_Type := Process_Implicit_Dereference_Prefix (Pent, P); + end if; + + if Is_Array_Type (Array_Type) then + null; + + elsif Present (Pent) and then Ekind (Pent) = E_Entry_Family then + Analyze (Exp); + Set_Etype (N, Any_Type); + + if not Has_Compatible_Type + (Exp, Entry_Index_Type (Pent)) + then + Error_Msg_N ("invalid index type in entry name", N); + + elsif Present (Next (Exp)) then + Error_Msg_N ("too many subscripts in entry reference", N); + + else + Set_Etype (N, Etype (P)); + end if; + + return; + + elsif Is_Record_Type (Array_Type) + and then Remote_AST_I_Dereference (P) + then + return; + + elsif Array_Type = Any_Type then + Set_Etype (N, Any_Type); + + -- In most cases the analysis of the prefix will have emitted + -- an error already, but if the prefix may be interpreted as a + -- call in prefixed notation, the report is left to the caller. + -- To prevent cascaded errors, report only if no previous ones. + + if Serious_Errors_Detected = 0 then + Error_Msg_N ("invalid prefix in indexed component", P); + + if Nkind (P) = N_Expanded_Name then + Error_Msg_NE ("\& is not visible", P, Selector_Name (P)); + end if; + end if; + + return; + + -- Here we definitely have a bad indexing + + else + if Nkind (Parent (N)) = N_Requeue_Statement + and then Present (Pent) and then Ekind (Pent) = E_Entry + then + Error_Msg_N + ("REQUEUE does not permit parameters", First (Exprs)); + + elsif Is_Entity_Name (P) + and then Etype (P) = Standard_Void_Type + then + Error_Msg_NE ("incorrect use of&", P, Entity (P)); + + else + Error_Msg_N ("array type required in indexed component", P); + end if; + + Set_Etype (N, Any_Type); + return; + end if; + + Index := First_Index (Array_Type); + while Present (Index) and then Present (Exp) loop + if not Has_Compatible_Type (Exp, Etype (Index)) then + Wrong_Type (Exp, Etype (Index)); + Set_Etype (N, Any_Type); + return; + end if; + + Next_Index (Index); + Next (Exp); + end loop; + + Set_Etype (N, Component_Type (Array_Type)); + + if Present (Index) then + Error_Msg_N + ("too few subscripts in array reference", First (Exprs)); + + elsif Present (Exp) then + Error_Msg_N ("too many subscripts in array reference", Exp); + end if; + end if; + end Process_Indexed_Component; + + ---------------------------------------- + -- Process_Indexed_Component_Or_Slice -- + ---------------------------------------- + + procedure Process_Indexed_Component_Or_Slice is + begin + Exp := First (Exprs); + while Present (Exp) loop + Analyze_Expression (Exp); + Next (Exp); + end loop; + + Exp := First (Exprs); + + -- If one index is present, and it is a subtype name, then the + -- node denotes a slice (note that the case of an explicit range + -- for a slice was already built as an N_Slice node in the first + -- place, so that case is not handled here). + + -- We use a replace rather than a rewrite here because this is one + -- of the cases in which the tree built by the parser is plain wrong. + + if No (Next (Exp)) + and then Is_Entity_Name (Exp) + and then Is_Type (Entity (Exp)) + then + Replace (N, + Make_Slice (Sloc (N), + Prefix => P, + Discrete_Range => New_Copy (Exp))); + Analyze (N); + + -- Otherwise (more than one index present, or single index is not + -- a subtype name), then we have the indexed component case. + + else + Process_Indexed_Component; + end if; + end Process_Indexed_Component_Or_Slice; + + ------------------------------------------ + -- Process_Overloaded_Indexed_Component -- + ------------------------------------------ + + procedure Process_Overloaded_Indexed_Component is + Exp : Node_Id; + I : Interp_Index; + It : Interp; + Typ : Entity_Id; + Index : Node_Id; + Found : Boolean; + + begin + Set_Etype (N, Any_Type); + + Get_First_Interp (P, I, It); + while Present (It.Nam) loop + Typ := It.Typ; + + if Is_Access_Type (Typ) then + Typ := Designated_Type (Typ); + Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N); + end if; + + if Is_Array_Type (Typ) then + + -- Got a candidate: verify that index types are compatible + + Index := First_Index (Typ); + Found := True; + Exp := First (Exprs); + while Present (Index) and then Present (Exp) loop + if Has_Compatible_Type (Exp, Etype (Index)) then + null; + else + Found := False; + Remove_Interp (I); + exit; + end if; + + Next_Index (Index); + Next (Exp); + end loop; + + if Found and then No (Index) and then No (Exp) then + Add_One_Interp (N, + Etype (Component_Type (Typ)), + Etype (Component_Type (Typ))); + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + + if Etype (N) = Any_Type then + Error_Msg_N ("no legal interpretation for indexed component", N); + Set_Is_Overloaded (N, False); + end if; + + End_Interp_List; + end Process_Overloaded_Indexed_Component; + + -- Start of processing for Analyze_Indexed_Component_Form + + begin + -- Get name of array, function or type + + Analyze (P); + + if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) then + + -- If P is an explicit dereference whose prefix is of a + -- remote access-to-subprogram type, then N has already + -- been rewritten as a subprogram call and analyzed. + + return; + end if; + + pragma Assert (Nkind (N) = N_Indexed_Component); + + P_T := Base_Type (Etype (P)); + + if Is_Entity_Name (P) and then Present (Entity (P)) then + U_N := Entity (P); + + if Is_Type (U_N) then + + -- Reformat node as a type conversion + + E := Remove_Head (Exprs); + + if Present (First (Exprs)) then + Error_Msg_N + ("argument of type conversion must be single expression", N); + end if; + + Change_Node (N, N_Type_Conversion); + Set_Subtype_Mark (N, P); + Set_Etype (N, U_N); + Set_Expression (N, E); + + -- After changing the node, call for the specific Analysis + -- routine directly, to avoid a double call to the expander. + + Analyze_Type_Conversion (N); + return; + end if; + + if Is_Overloadable (U_N) then + Process_Function_Call; + + elsif Ekind (Etype (P)) = E_Subprogram_Type + or else (Is_Access_Type (Etype (P)) + and then + Ekind (Designated_Type (Etype (P))) = + E_Subprogram_Type) + then + -- Call to access_to-subprogram with possible implicit dereference + + Process_Function_Call; + + elsif Is_Generic_Subprogram (U_N) then + + -- A common beginner's (or C++ templates fan) error + + Error_Msg_N ("generic subprogram cannot be called", N); + Set_Etype (N, Any_Type); + return; + + else + Process_Indexed_Component_Or_Slice; + end if; + + -- If not an entity name, prefix is an expression that may denote + -- an array or an access-to-subprogram. + + else + if Ekind (P_T) = E_Subprogram_Type + or else (Is_Access_Type (P_T) + and then + Ekind (Designated_Type (P_T)) = E_Subprogram_Type) + then + Process_Function_Call; + + elsif Nkind (P) = N_Selected_Component + and then Is_Overloadable (Entity (Selector_Name (P))) + then + Process_Function_Call; + + else + -- Indexed component, slice, or a call to a member of a family + -- entry, which will be converted to an entry call later. + + Process_Indexed_Component_Or_Slice; + end if; + end if; + end Analyze_Indexed_Component_Form; + + ------------------------ + -- Analyze_Logical_Op -- + ------------------------ + + procedure Analyze_Logical_Op (N : Node_Id) is + L : constant Node_Id := Left_Opnd (N); + R : constant Node_Id := Right_Opnd (N); + Op_Id : Entity_Id := Entity (N); + + begin + Set_Etype (N, Any_Type); + Candidate_Type := Empty; + + Analyze_Expression (L); + Analyze_Expression (R); + + if Present (Op_Id) then + + if Ekind (Op_Id) = E_Operator then + Find_Boolean_Types (L, R, Op_Id, N); + else + Add_One_Interp (N, Op_Id, Etype (Op_Id)); + end if; + + else + Op_Id := Get_Name_Entity_Id (Chars (N)); + while Present (Op_Id) loop + if Ekind (Op_Id) = E_Operator then + Find_Boolean_Types (L, R, Op_Id, N); + else + Analyze_User_Defined_Binary_Op (N, Op_Id); + end if; + + Op_Id := Homonym (Op_Id); + end loop; + end if; + + Operator_Check (N); + end Analyze_Logical_Op; + + --------------------------- + -- Analyze_Membership_Op -- + --------------------------- + + procedure Analyze_Membership_Op (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + L : constant Node_Id := Left_Opnd (N); + R : constant Node_Id := Right_Opnd (N); + + Index : Interp_Index; + It : Interp; + Found : Boolean := False; + I_F : Interp_Index; + T_F : Entity_Id; + + procedure Try_One_Interp (T1 : Entity_Id); + -- Routine to try one proposed interpretation. Note that the context + -- of the operation plays no role in resolving the arguments, so that + -- if there is more than one interpretation of the operands that is + -- compatible with a membership test, the operation is ambiguous. + + -------------------- + -- Try_One_Interp -- + -------------------- + + procedure Try_One_Interp (T1 : Entity_Id) is + begin + if Has_Compatible_Type (R, T1) then + if Found + and then Base_Type (T1) /= Base_Type (T_F) + then + It := Disambiguate (L, I_F, Index, Any_Type); + + if It = No_Interp then + Ambiguous_Operands (N); + Set_Etype (L, Any_Type); + return; + + else + T_F := It.Typ; + end if; + + else + Found := True; + T_F := T1; + I_F := Index; + end if; + + Set_Etype (L, T_F); + end if; + end Try_One_Interp; + + procedure Analyze_Set_Membership; + -- If a set of alternatives is present, analyze each and find the + -- common type to which they must all resolve. + + ---------------------------- + -- Analyze_Set_Membership -- + ---------------------------- + + procedure Analyze_Set_Membership is + Alt : Node_Id; + Index : Interp_Index; + It : Interp; + Candidate_Interps : Node_Id; + Common_Type : Entity_Id := Empty; + + begin + Analyze (L); + Candidate_Interps := L; + + if not Is_Overloaded (L) then + Common_Type := Etype (L); + + Alt := First (Alternatives (N)); + while Present (Alt) loop + Analyze (Alt); + + if not Has_Compatible_Type (Alt, Common_Type) then + Wrong_Type (Alt, Common_Type); + end if; + + Next (Alt); + end loop; + + else + Alt := First (Alternatives (N)); + while Present (Alt) loop + Analyze (Alt); + if not Is_Overloaded (Alt) then + Common_Type := Etype (Alt); + + else + Get_First_Interp (Alt, Index, It); + while Present (It.Typ) loop + if not + Has_Compatible_Type (Candidate_Interps, It.Typ) + then + Remove_Interp (Index); + end if; + + Get_Next_Interp (Index, It); + end loop; + + Get_First_Interp (Alt, Index, It); + + if No (It.Typ) then + Error_Msg_N ("alternative has no legal type", Alt); + return; + end if; + + -- If alternative is not overloaded, we have a unique type + -- for all of them. + + Set_Etype (Alt, It.Typ); + Get_Next_Interp (Index, It); + + if No (It.Typ) then + Set_Is_Overloaded (Alt, False); + Common_Type := Etype (Alt); + end if; + + Candidate_Interps := Alt; + end if; + + Next (Alt); + end loop; + end if; + + Set_Etype (N, Standard_Boolean); + + if Present (Common_Type) then + Set_Etype (L, Common_Type); + Set_Is_Overloaded (L, False); + + else + Error_Msg_N ("cannot resolve membership operation", N); + end if; + end Analyze_Set_Membership; + + -- Start of processing for Analyze_Membership_Op + + begin + Analyze_Expression (L); + + if No (R) + and then Ada_Version >= Ada_2012 + then + Analyze_Set_Membership; + return; + end if; + + if Nkind (R) = N_Range + or else (Nkind (R) = N_Attribute_Reference + and then Attribute_Name (R) = Name_Range) + then + Analyze (R); + + if not Is_Overloaded (L) then + Try_One_Interp (Etype (L)); + + else + Get_First_Interp (L, Index, It); + while Present (It.Typ) loop + Try_One_Interp (It.Typ); + Get_Next_Interp (Index, It); + end loop; + end if; + + -- If not a range, it can be a subtype mark, or else it is a degenerate + -- membership test with a singleton value, i.e. a test for equality. + + else + Analyze (R); + if Is_Entity_Name (R) + and then Is_Type (Entity (R)) + then + Find_Type (R); + Check_Fully_Declared (Entity (R), R); + + elsif Ada_Version >= Ada_2012 then + if Nkind (N) = N_In then + Rewrite (N, + Make_Op_Eq (Loc, + Left_Opnd => L, + Right_Opnd => R)); + else + Rewrite (N, + Make_Op_Ne (Loc, + Left_Opnd => L, + Right_Opnd => R)); + end if; + + Analyze (N); + return; + + else + -- In previous version of the language this is an error that will + -- be diagnosed below. + + Find_Type (R); + end if; + end if; + + -- Compatibility between expression and subtype mark or range is + -- checked during resolution. The result of the operation is Boolean + -- in any case. + + Set_Etype (N, Standard_Boolean); + + if Comes_From_Source (N) + and then Present (Right_Opnd (N)) + and then Is_CPP_Class (Etype (Etype (Right_Opnd (N)))) + then + Error_Msg_N ("membership test not applicable to cpp-class types", N); + end if; + end Analyze_Membership_Op; + + ---------------------- + -- Analyze_Negation -- + ---------------------- + + procedure Analyze_Negation (N : Node_Id) is + R : constant Node_Id := Right_Opnd (N); + Op_Id : Entity_Id := Entity (N); + + begin + Set_Etype (N, Any_Type); + Candidate_Type := Empty; + + Analyze_Expression (R); + + if Present (Op_Id) then + if Ekind (Op_Id) = E_Operator then + Find_Negation_Types (R, Op_Id, N); + else + Add_One_Interp (N, Op_Id, Etype (Op_Id)); + end if; + + else + Op_Id := Get_Name_Entity_Id (Chars (N)); + while Present (Op_Id) loop + if Ekind (Op_Id) = E_Operator then + Find_Negation_Types (R, Op_Id, N); + else + Analyze_User_Defined_Unary_Op (N, Op_Id); + end if; + + Op_Id := Homonym (Op_Id); + end loop; + end if; + + Operator_Check (N); + end Analyze_Negation; + + ------------------ + -- Analyze_Null -- + ------------------ + + procedure Analyze_Null (N : Node_Id) is + begin + Set_Etype (N, Any_Access); + end Analyze_Null; + + ---------------------- + -- Analyze_One_Call -- + ---------------------- + + procedure Analyze_One_Call + (N : Node_Id; + Nam : Entity_Id; + Report : Boolean; + Success : out Boolean; + Skip_First : Boolean := False) + is + Actuals : constant List_Id := Parameter_Associations (N); + Prev_T : constant Entity_Id := Etype (N); + + Must_Skip : constant Boolean := Skip_First + or else Nkind (Original_Node (N)) = N_Selected_Component + or else + (Nkind (Original_Node (N)) = N_Indexed_Component + and then Nkind (Prefix (Original_Node (N))) + = N_Selected_Component); + -- The first formal must be omitted from the match when trying to find + -- a primitive operation that is a possible interpretation, and also + -- after the call has been rewritten, because the corresponding actual + -- is already known to be compatible, and because this may be an + -- indexing of a call with default parameters. + + Formal : Entity_Id; + Actual : Node_Id; + Is_Indexed : Boolean := False; + Is_Indirect : Boolean := False; + Subp_Type : constant Entity_Id := Etype (Nam); + Norm_OK : Boolean; + + function Operator_Hidden_By (Fun : Entity_Id) return Boolean; + -- There may be a user-defined operator that hides the current + -- interpretation. We must check for this independently of the + -- analysis of the call with the user-defined operation, because + -- the parameter names may be wrong and yet the hiding takes place. + -- This fixes a problem with ACATS test B34014O. + -- + -- When the type Address is a visible integer type, and the DEC + -- system extension is visible, the predefined operator may be + -- hidden as well, by one of the address operations in auxdec. + -- Finally, The abstract operations on address do not hide the + -- predefined operator (this is the purpose of making them abstract). + + procedure Indicate_Name_And_Type; + -- If candidate interpretation matches, indicate name and type of + -- result on call node. + + ---------------------------- + -- Indicate_Name_And_Type -- + ---------------------------- + + procedure Indicate_Name_And_Type is + begin + Add_One_Interp (N, Nam, Etype (Nam)); + Success := True; + + -- If the prefix of the call is a name, indicate the entity + -- being called. If it is not a name, it is an expression that + -- denotes an access to subprogram or else an entry or family. In + -- the latter case, the name is a selected component, and the entity + -- being called is noted on the selector. + + if not Is_Type (Nam) then + if Is_Entity_Name (Name (N)) then + Set_Entity (Name (N), Nam); + + elsif Nkind (Name (N)) = N_Selected_Component then + Set_Entity (Selector_Name (Name (N)), Nam); + end if; + end if; + + if Debug_Flag_E and not Report then + Write_Str (" Overloaded call "); + Write_Int (Int (N)); + Write_Str (" compatible with "); + Write_Int (Int (Nam)); + Write_Eol; + end if; + end Indicate_Name_And_Type; + + ------------------------ + -- Operator_Hidden_By -- + ------------------------ + + function Operator_Hidden_By (Fun : Entity_Id) return Boolean is + Act1 : constant Node_Id := First_Actual (N); + Act2 : constant Node_Id := Next_Actual (Act1); + Form1 : constant Entity_Id := First_Formal (Fun); + Form2 : constant Entity_Id := Next_Formal (Form1); + + begin + if Ekind (Fun) /= E_Function + or else Is_Abstract_Subprogram (Fun) + then + return False; + + elsif not Has_Compatible_Type (Act1, Etype (Form1)) then + return False; + + elsif Present (Form2) then + if + No (Act2) or else not Has_Compatible_Type (Act2, Etype (Form2)) + then + return False; + end if; + + elsif Present (Act2) then + return False; + end if; + + -- Now we know that the arity of the operator matches the function, + -- and the function call is a valid interpretation. The function + -- hides the operator if it has the right signature, or if one of + -- its operands is a non-abstract operation on Address when this is + -- a visible integer type. + + return Hides_Op (Fun, Nam) + or else Is_Descendent_Of_Address (Etype (Form1)) + or else + (Present (Form2) + and then Is_Descendent_Of_Address (Etype (Form2))); + end Operator_Hidden_By; + + -- Start of processing for Analyze_One_Call + + begin + Success := False; + + -- If the subprogram has no formals or if all the formals have defaults, + -- and the return type is an array type, the node may denote an indexing + -- of the result of a parameterless call. In Ada 2005, the subprogram + -- may have one non-defaulted formal, and the call may have been written + -- in prefix notation, so that the rebuilt parameter list has more than + -- one actual. + + if not Is_Overloadable (Nam) + and then Ekind (Nam) /= E_Subprogram_Type + and then Ekind (Nam) /= E_Entry_Family + then + return; + end if; + + -- An indexing requires at least one actual + + if not Is_Empty_List (Actuals) + and then + (Needs_No_Actuals (Nam) + or else + (Needs_One_Actual (Nam) + and then Present (Next_Actual (First (Actuals))))) + then + if Is_Array_Type (Subp_Type) then + Is_Indexed := Try_Indexed_Call (N, Nam, Subp_Type, Must_Skip); + + elsif Is_Access_Type (Subp_Type) + and then Is_Array_Type (Designated_Type (Subp_Type)) + then + Is_Indexed := + Try_Indexed_Call + (N, Nam, Designated_Type (Subp_Type), Must_Skip); + + -- The prefix can also be a parameterless function that returns an + -- access to subprogram, in which case this is an indirect call. + -- If this succeeds, an explicit dereference is added later on, + -- in Analyze_Call or Resolve_Call. + + elsif Is_Access_Type (Subp_Type) + and then Ekind (Designated_Type (Subp_Type)) = E_Subprogram_Type + then + Is_Indirect := Try_Indirect_Call (N, Nam, Subp_Type); + end if; + + end if; + + -- If the call has been transformed into a slice, it is of the form + -- F (Subtype) where F is parameterless. The node has been rewritten in + -- Try_Indexed_Call and there is nothing else to do. + + if Is_Indexed + and then Nkind (N) = N_Slice + then + return; + end if; + + Normalize_Actuals + (N, Nam, (Report and not Is_Indexed and not Is_Indirect), Norm_OK); + + if not Norm_OK then + + -- If an indirect call is a possible interpretation, indicate + -- success to the caller. + + if Is_Indirect then + Success := True; + return; + + -- Mismatch in number or names of parameters + + elsif Debug_Flag_E then + Write_Str (" normalization fails in call "); + Write_Int (Int (N)); + Write_Str (" with subprogram "); + Write_Int (Int (Nam)); + Write_Eol; + end if; + + -- If the context expects a function call, discard any interpretation + -- that is a procedure. If the node is not overloaded, leave as is for + -- better error reporting when type mismatch is found. + + elsif Nkind (N) = N_Function_Call + and then Is_Overloaded (Name (N)) + and then Ekind (Nam) = E_Procedure + then + return; + + -- Ditto for function calls in a procedure context + + elsif Nkind (N) = N_Procedure_Call_Statement + and then Is_Overloaded (Name (N)) + and then Etype (Nam) /= Standard_Void_Type + then + return; + + elsif No (Actuals) then + + -- If Normalize succeeds, then there are default parameters for + -- all formals. + + Indicate_Name_And_Type; + + elsif Ekind (Nam) = E_Operator then + if Nkind (N) = N_Procedure_Call_Statement then + return; + end if; + + -- This can occur when the prefix of the call is an operator + -- name or an expanded name whose selector is an operator name. + + Analyze_Operator_Call (N, Nam); + + if Etype (N) /= Prev_T then + + -- Check that operator is not hidden by a function interpretation + + if Is_Overloaded (Name (N)) then + declare + I : Interp_Index; + It : Interp; + + begin + Get_First_Interp (Name (N), I, It); + while Present (It.Nam) loop + if Operator_Hidden_By (It.Nam) then + Set_Etype (N, Prev_T); + return; + end if; + + Get_Next_Interp (I, It); + end loop; + end; + end if; + + -- If operator matches formals, record its name on the call. + -- If the operator is overloaded, Resolve will select the + -- correct one from the list of interpretations. The call + -- node itself carries the first candidate. + + Set_Entity (Name (N), Nam); + Success := True; + + elsif Report and then Etype (N) = Any_Type then + Error_Msg_N ("incompatible arguments for operator", N); + end if; + + else + -- Normalize_Actuals has chained the named associations in the + -- correct order of the formals. + + Actual := First_Actual (N); + Formal := First_Formal (Nam); + + -- If we are analyzing a call rewritten from object notation, + -- skip first actual, which may be rewritten later as an + -- explicit dereference. + + if Must_Skip then + Next_Actual (Actual); + Next_Formal (Formal); + end if; + + while Present (Actual) and then Present (Formal) loop + if Nkind (Parent (Actual)) /= N_Parameter_Association + or else Chars (Selector_Name (Parent (Actual))) = Chars (Formal) + then + -- The actual can be compatible with the formal, but we must + -- also check that the context is not an address type that is + -- visibly an integer type, as is the case in VMS_64. In this + -- case the use of literals is illegal, except in the body of + -- descendents of system, where arithmetic operations on + -- address are of course used. + + if Has_Compatible_Type (Actual, Etype (Formal)) + and then + (Etype (Actual) /= Universal_Integer + or else not Is_Descendent_Of_Address (Etype (Formal)) + or else + Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (N)))) + then + Next_Actual (Actual); + Next_Formal (Formal); + + else + if Debug_Flag_E then + Write_Str (" type checking fails in call "); + Write_Int (Int (N)); + Write_Str (" with formal "); + Write_Int (Int (Formal)); + Write_Str (" in subprogram "); + Write_Int (Int (Nam)); + Write_Eol; + end if; + + if Report and not Is_Indexed and not Is_Indirect then + + -- Ada 2005 (AI-251): Complete the error notification + -- to help new Ada 2005 users. + + if Is_Class_Wide_Type (Etype (Formal)) + and then Is_Interface (Etype (Etype (Formal))) + and then not Interface_Present_In_Ancestor + (Typ => Etype (Actual), + Iface => Etype (Etype (Formal))) + then + Error_Msg_NE + ("(Ada 2005) does not implement interface }", + Actual, Etype (Etype (Formal))); + end if; + + Wrong_Type (Actual, Etype (Formal)); + + if Nkind (Actual) = N_Op_Eq + and then Nkind (Left_Opnd (Actual)) = N_Identifier + then + Formal := First_Formal (Nam); + while Present (Formal) loop + if Chars (Left_Opnd (Actual)) = Chars (Formal) then + Error_Msg_N -- CODEFIX + ("possible misspelling of `='>`!", Actual); + exit; + end if; + + Next_Formal (Formal); + end loop; + end if; + + if All_Errors_Mode then + Error_Msg_Sloc := Sloc (Nam); + + if Etype (Formal) = Any_Type then + Error_Msg_N + ("there is no legal actual parameter", Actual); + end if; + + if Is_Overloadable (Nam) + and then Present (Alias (Nam)) + and then not Comes_From_Source (Nam) + then + Error_Msg_NE + ("\\ =='> in call to inherited operation & #!", + Actual, Nam); + + elsif Ekind (Nam) = E_Subprogram_Type then + declare + Access_To_Subprogram_Typ : + constant Entity_Id := + Defining_Identifier + (Associated_Node_For_Itype (Nam)); + begin + Error_Msg_NE ( + "\\ =='> in call to dereference of &#!", + Actual, Access_To_Subprogram_Typ); + end; + + else + Error_Msg_NE + ("\\ =='> in call to &#!", Actual, Nam); + + end if; + end if; + end if; + + return; + end if; + + else + -- Normalize_Actuals has verified that a default value exists + -- for this formal. Current actual names a subsequent formal. + + Next_Formal (Formal); + end if; + end loop; + + -- On exit, all actuals match + + Indicate_Name_And_Type; + end if; + end Analyze_One_Call; + + --------------------------- + -- Analyze_Operator_Call -- + --------------------------- + + procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id) is + Op_Name : constant Name_Id := Chars (Op_Id); + Act1 : constant Node_Id := First_Actual (N); + Act2 : constant Node_Id := Next_Actual (Act1); + + begin + -- Binary operator case + + if Present (Act2) then + + -- If more than two operands, then not binary operator after all + + if Present (Next_Actual (Act2)) then + return; + + elsif Op_Name = Name_Op_Add + or else Op_Name = Name_Op_Subtract + or else Op_Name = Name_Op_Multiply + or else Op_Name = Name_Op_Divide + or else Op_Name = Name_Op_Mod + or else Op_Name = Name_Op_Rem + or else Op_Name = Name_Op_Expon + then + Find_Arithmetic_Types (Act1, Act2, Op_Id, N); + + elsif Op_Name = Name_Op_And + or else Op_Name = Name_Op_Or + or else Op_Name = Name_Op_Xor + then + Find_Boolean_Types (Act1, Act2, Op_Id, N); + + elsif Op_Name = Name_Op_Lt + or else Op_Name = Name_Op_Le + or else Op_Name = Name_Op_Gt + or else Op_Name = Name_Op_Ge + then + Find_Comparison_Types (Act1, Act2, Op_Id, N); + + elsif Op_Name = Name_Op_Eq + or else Op_Name = Name_Op_Ne + then + Find_Equality_Types (Act1, Act2, Op_Id, N); + + elsif Op_Name = Name_Op_Concat then + Find_Concatenation_Types (Act1, Act2, Op_Id, N); + + -- Is this else null correct, or should it be an abort??? + + else + null; + end if; + + -- Unary operator case + + else + if Op_Name = Name_Op_Subtract or else + Op_Name = Name_Op_Add or else + Op_Name = Name_Op_Abs + then + Find_Unary_Types (Act1, Op_Id, N); + + elsif + Op_Name = Name_Op_Not + then + Find_Negation_Types (Act1, Op_Id, N); + + -- Is this else null correct, or should it be an abort??? + + else + null; + end if; + end if; + end Analyze_Operator_Call; + + ------------------------------------------- + -- Analyze_Overloaded_Selected_Component -- + ------------------------------------------- + + procedure Analyze_Overloaded_Selected_Component (N : Node_Id) is + Nam : constant Node_Id := Prefix (N); + Sel : constant Node_Id := Selector_Name (N); + Comp : Entity_Id; + I : Interp_Index; + It : Interp; + T : Entity_Id; + + begin + Set_Etype (Sel, Any_Type); + + Get_First_Interp (Nam, I, It); + while Present (It.Typ) loop + if Is_Access_Type (It.Typ) then + T := Designated_Type (It.Typ); + Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N); + else + T := It.Typ; + end if; + + if Is_Record_Type (T) then + + -- If the prefix is a class-wide type, the visible components are + -- those of the base type. + + if Is_Class_Wide_Type (T) then + T := Etype (T); + end if; + + Comp := First_Entity (T); + while Present (Comp) loop + if Chars (Comp) = Chars (Sel) + and then Is_Visible_Component (Comp) + then + + -- AI05-105: if the context is an object renaming with + -- an anonymous access type, the expected type of the + -- object must be anonymous. This is a name resolution rule. + + if Nkind (Parent (N)) /= N_Object_Renaming_Declaration + or else No (Access_Definition (Parent (N))) + or else Ekind (Etype (Comp)) = E_Anonymous_Access_Type + or else + Ekind (Etype (Comp)) = E_Anonymous_Access_Subprogram_Type + then + Set_Entity (Sel, Comp); + Set_Etype (Sel, Etype (Comp)); + Add_One_Interp (N, Etype (Comp), Etype (Comp)); + + -- This also specifies a candidate to resolve the name. + -- Further overloading will be resolved from context. + -- The selector name itself does not carry overloading + -- information. + + Set_Etype (Nam, It.Typ); + + else + -- Named access type in the context of a renaming + -- declaration with an access definition. Remove + -- inapplicable candidate. + + Remove_Interp (I); + end if; + end if; + + Next_Entity (Comp); + end loop; + + elsif Is_Concurrent_Type (T) then + Comp := First_Entity (T); + while Present (Comp) + and then Comp /= First_Private_Entity (T) + loop + if Chars (Comp) = Chars (Sel) then + if Is_Overloadable (Comp) then + Add_One_Interp (Sel, Comp, Etype (Comp)); + else + Set_Entity_With_Style_Check (Sel, Comp); + Generate_Reference (Comp, Sel); + end if; + + Set_Etype (Sel, Etype (Comp)); + Set_Etype (N, Etype (Comp)); + Set_Etype (Nam, It.Typ); + + -- For access type case, introduce explicit dereference for + -- more uniform treatment of entry calls. Do this only once + -- if several interpretations yield an access type. + + if Is_Access_Type (Etype (Nam)) + and then Nkind (Nam) /= N_Explicit_Dereference + then + Insert_Explicit_Dereference (Nam); + Error_Msg_NW + (Warn_On_Dereference, "?implicit dereference", N); + end if; + end if; + + Next_Entity (Comp); + end loop; + + Set_Is_Overloaded (N, Is_Overloaded (Sel)); + end if; + + Get_Next_Interp (I, It); + end loop; + + if Etype (N) = Any_Type + and then not Try_Object_Operation (N) + then + Error_Msg_NE ("undefined selector& for overloaded prefix", N, Sel); + Set_Entity (Sel, Any_Id); + Set_Etype (Sel, Any_Type); + end if; + end Analyze_Overloaded_Selected_Component; + + ---------------------------------- + -- Analyze_Qualified_Expression -- + ---------------------------------- + + procedure Analyze_Qualified_Expression (N : Node_Id) is + Mark : constant Entity_Id := Subtype_Mark (N); + Expr : constant Node_Id := Expression (N); + I : Interp_Index; + It : Interp; + T : Entity_Id; + + begin + Analyze_Expression (Expr); + + Set_Etype (N, Any_Type); + Find_Type (Mark); + T := Entity (Mark); + Set_Etype (N, T); + + if T = Any_Type then + return; + end if; + + Check_Fully_Declared (T, N); + + -- If expected type is class-wide, check for exact match before + -- expansion, because if the expression is a dispatching call it + -- may be rewritten as explicit dereference with class-wide result. + -- If expression is overloaded, retain only interpretations that + -- will yield exact matches. + + if Is_Class_Wide_Type (T) then + if not Is_Overloaded (Expr) then + if Base_Type (Etype (Expr)) /= Base_Type (T) then + if Nkind (Expr) = N_Aggregate then + Error_Msg_N ("type of aggregate cannot be class-wide", Expr); + else + Wrong_Type (Expr, T); + end if; + end if; + + else + Get_First_Interp (Expr, I, It); + + while Present (It.Nam) loop + if Base_Type (It.Typ) /= Base_Type (T) then + Remove_Interp (I); + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + end if; + + Set_Etype (N, T); + end Analyze_Qualified_Expression; + + ----------------------------------- + -- Analyze_Quantified_Expression -- + ----------------------------------- + + procedure Analyze_Quantified_Expression (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ent : constant Entity_Id := + New_Internal_Entity + (E_Loop, Current_Scope, Sloc (N), 'L'); + + Iterator : Node_Id; + + begin + Set_Etype (Ent, Standard_Void_Type); + Set_Parent (Ent, N); + + if Present (Loop_Parameter_Specification (N)) then + Iterator := + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Loop_Parameter_Specification (N)); + else + Iterator := + Make_Iteration_Scheme (Loc, + Iterator_Specification => + Iterator_Specification (N)); + end if; + + Push_Scope (Ent); + Set_Parent (Iterator, N); + Analyze_Iteration_Scheme (Iterator); + + -- The loop specification may have been converted into an + -- iterator specification during its analysis. Update the + -- quantified node accordingly. + + if Present (Iterator_Specification (Iterator)) then + Set_Iterator_Specification + (N, Iterator_Specification (Iterator)); + Set_Loop_Parameter_Specification (N, Empty); + end if; + + Analyze (Condition (N)); + End_Scope; + + Set_Etype (N, Standard_Boolean); + end Analyze_Quantified_Expression; + + ------------------- + -- Analyze_Range -- + ------------------- + + procedure Analyze_Range (N : Node_Id) is + L : constant Node_Id := Low_Bound (N); + H : constant Node_Id := High_Bound (N); + I1, I2 : Interp_Index; + It1, It2 : Interp; + + procedure Check_Common_Type (T1, T2 : Entity_Id); + -- Verify the compatibility of two types, and choose the + -- non universal one if the other is universal. + + procedure Check_High_Bound (T : Entity_Id); + -- Test one interpretation of the low bound against all those + -- of the high bound. + + procedure Check_Universal_Expression (N : Node_Id); + -- In Ada83, reject bounds of a universal range that are not + -- literals or entity names. + + ----------------------- + -- Check_Common_Type -- + ----------------------- + + procedure Check_Common_Type (T1, T2 : Entity_Id) is + begin + if Covers (T1 => T1, T2 => T2) + or else + Covers (T1 => T2, T2 => T1) + then + if T1 = Universal_Integer + or else T1 = Universal_Real + or else T1 = Any_Character + then + Add_One_Interp (N, Base_Type (T2), Base_Type (T2)); + + elsif T1 = T2 then + Add_One_Interp (N, T1, T1); + + else + Add_One_Interp (N, Base_Type (T1), Base_Type (T1)); + end if; + end if; + end Check_Common_Type; + + ---------------------- + -- Check_High_Bound -- + ---------------------- + + procedure Check_High_Bound (T : Entity_Id) is + begin + if not Is_Overloaded (H) then + Check_Common_Type (T, Etype (H)); + else + Get_First_Interp (H, I2, It2); + while Present (It2.Typ) loop + Check_Common_Type (T, It2.Typ); + Get_Next_Interp (I2, It2); + end loop; + end if; + end Check_High_Bound; + + ----------------------------- + -- Is_Universal_Expression -- + ----------------------------- + + procedure Check_Universal_Expression (N : Node_Id) is + begin + if Etype (N) = Universal_Integer + and then Nkind (N) /= N_Integer_Literal + and then not Is_Entity_Name (N) + and then Nkind (N) /= N_Attribute_Reference + then + Error_Msg_N ("illegal bound in discrete range", N); + end if; + end Check_Universal_Expression; + + -- Start of processing for Analyze_Range + + begin + Set_Etype (N, Any_Type); + Analyze_Expression (L); + Analyze_Expression (H); + + if Etype (L) = Any_Type or else Etype (H) = Any_Type then + return; + + else + if not Is_Overloaded (L) then + Check_High_Bound (Etype (L)); + else + Get_First_Interp (L, I1, It1); + while Present (It1.Typ) loop + Check_High_Bound (It1.Typ); + Get_Next_Interp (I1, It1); + end loop; + end if; + + -- If result is Any_Type, then we did not find a compatible pair + + if Etype (N) = Any_Type then + Error_Msg_N ("incompatible types in range ", N); + end if; + end if; + + if Ada_Version = Ada_83 + and then + (Nkind (Parent (N)) = N_Loop_Parameter_Specification + or else Nkind (Parent (N)) = N_Constrained_Array_Definition) + then + Check_Universal_Expression (L); + Check_Universal_Expression (H); + end if; + end Analyze_Range; + + ----------------------- + -- Analyze_Reference -- + ----------------------- + + procedure Analyze_Reference (N : Node_Id) is + P : constant Node_Id := Prefix (N); + E : Entity_Id; + T : Entity_Id; + Acc_Type : Entity_Id; + + begin + Analyze (P); + + -- An interesting error check, if we take the 'Reference of an object + -- for which a pragma Atomic or Volatile has been given, and the type + -- of the object is not Atomic or Volatile, then we are in trouble. The + -- problem is that no trace of the atomic/volatile status will remain + -- for the backend to respect when it deals with the resulting pointer, + -- since the pointer type will not be marked atomic (it is a pointer to + -- the base type of the object). + + -- It is not clear if that can ever occur, but in case it does, we will + -- generate an error message. Not clear if this message can ever be + -- generated, and pretty clear that it represents a bug if it is, still + -- seems worth checking, except in CodePeer mode where we do not really + -- care and don't want to bother the user. + + T := Etype (P); + + if Is_Entity_Name (P) + and then Is_Object_Reference (P) + and then not CodePeer_Mode + then + E := Entity (P); + T := Etype (P); + + if (Has_Atomic_Components (E) + and then not Has_Atomic_Components (T)) + or else + (Has_Volatile_Components (E) + and then not Has_Volatile_Components (T)) + or else (Is_Atomic (E) and then not Is_Atomic (T)) + or else (Is_Volatile (E) and then not Is_Volatile (T)) + then + Error_Msg_N ("cannot take reference to Atomic/Volatile object", N); + end if; + end if; + + -- Carry on with normal processing + + Acc_Type := Create_Itype (E_Allocator_Type, N); + Set_Etype (Acc_Type, Acc_Type); + Set_Directly_Designated_Type (Acc_Type, Etype (P)); + Set_Etype (N, Acc_Type); + end Analyze_Reference; + + -------------------------------- + -- Analyze_Selected_Component -- + -------------------------------- + + -- Prefix is a record type or a task or protected type. In the latter case, + -- the selector must denote a visible entry. + + procedure Analyze_Selected_Component (N : Node_Id) is + Name : constant Node_Id := Prefix (N); + Sel : constant Node_Id := Selector_Name (N); + Act_Decl : Node_Id; + Comp : Entity_Id; + Has_Candidate : Boolean := False; + In_Scope : Boolean; + Parent_N : Node_Id; + Pent : Entity_Id := Empty; + Prefix_Type : Entity_Id; + + Type_To_Use : Entity_Id; + -- In most cases this is the Prefix_Type, but if the Prefix_Type is + -- a class-wide type, we use its root type, whose components are + -- present in the class-wide type. + + Is_Single_Concurrent_Object : Boolean; + -- Set True if the prefix is a single task or a single protected object + + procedure Find_Component_In_Instance (Rec : Entity_Id); + -- In an instance, a component of a private extension may not be visible + -- while it was visible in the generic. Search candidate scope for a + -- component with the proper identifier. This is only done if all other + -- searches have failed. When the match is found (it always will be), + -- the Etype of both N and Sel are set from this component, and the + -- entity of Sel is set to reference this component. + + function Has_Mode_Conformant_Spec (Comp : Entity_Id) return Boolean; + -- It is known that the parent of N denotes a subprogram call. Comp + -- is an overloadable component of the concurrent type of the prefix. + -- Determine whether all formals of the parent of N and Comp are mode + -- conformant. If the parent node is not analyzed yet it may be an + -- indexed component rather than a function call. + + -------------------------------- + -- Find_Component_In_Instance -- + -------------------------------- + + procedure Find_Component_In_Instance (Rec : Entity_Id) is + Comp : Entity_Id; + + begin + Comp := First_Component (Rec); + while Present (Comp) loop + if Chars (Comp) = Chars (Sel) then + Set_Entity_With_Style_Check (Sel, Comp); + Set_Etype (Sel, Etype (Comp)); + Set_Etype (N, Etype (Comp)); + return; + end if; + + Next_Component (Comp); + end loop; + + -- This must succeed because code was legal in the generic + + raise Program_Error; + end Find_Component_In_Instance; + + ------------------------------ + -- Has_Mode_Conformant_Spec -- + ------------------------------ + + function Has_Mode_Conformant_Spec (Comp : Entity_Id) return Boolean is + Comp_Param : Entity_Id; + Param : Node_Id; + Param_Typ : Entity_Id; + + begin + Comp_Param := First_Formal (Comp); + + if Nkind (Parent (N)) = N_Indexed_Component then + Param := First (Expressions (Parent (N))); + else + Param := First (Parameter_Associations (Parent (N))); + end if; + + while Present (Comp_Param) + and then Present (Param) + loop + Param_Typ := Find_Parameter_Type (Param); + + if Present (Param_Typ) + and then + not Conforming_Types + (Etype (Comp_Param), Param_Typ, Mode_Conformant) + then + return False; + end if; + + Next_Formal (Comp_Param); + Next (Param); + end loop; + + -- One of the specs has additional formals + + if Present (Comp_Param) or else Present (Param) then + return False; + end if; + + return True; + end Has_Mode_Conformant_Spec; + + -- Start of processing for Analyze_Selected_Component + + begin + Set_Etype (N, Any_Type); + + if Is_Overloaded (Name) then + Analyze_Overloaded_Selected_Component (N); + return; + + elsif Etype (Name) = Any_Type then + Set_Entity (Sel, Any_Id); + Set_Etype (Sel, Any_Type); + return; + + else + Prefix_Type := Etype (Name); + end if; + + if Is_Access_Type (Prefix_Type) then + + -- A RACW object can never be used as prefix of a selected component + -- since that means it is dereferenced without being a controlling + -- operand of a dispatching operation (RM E.2.2(16/1)). Before + -- reporting an error, we must check whether this is actually a + -- dispatching call in prefix form. + + if Is_Remote_Access_To_Class_Wide_Type (Prefix_Type) + and then Comes_From_Source (N) + then + if Try_Object_Operation (N) then + return; + else + Error_Msg_N + ("invalid dereference of a remote access-to-class-wide value", + N); + end if; + + -- Normal case of selected component applied to access type + + else + Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N); + + if Is_Entity_Name (Name) then + Pent := Entity (Name); + elsif Nkind (Name) = N_Selected_Component + and then Is_Entity_Name (Selector_Name (Name)) + then + Pent := Entity (Selector_Name (Name)); + end if; + + Prefix_Type := Process_Implicit_Dereference_Prefix (Pent, Name); + end if; + + -- If we have an explicit dereference of a remote access-to-class-wide + -- value, then issue an error (see RM-E.2.2(16/1)). However we first + -- have to check for the case of a prefix that is a controlling operand + -- of a prefixed dispatching call, as the dereference is legal in that + -- case. Normally this condition is checked in Validate_Remote_Access_ + -- To_Class_Wide_Type, but we have to defer the checking for selected + -- component prefixes because of the prefixed dispatching call case. + -- Note that implicit dereferences are checked for this just above. + + elsif Nkind (Name) = N_Explicit_Dereference + and then Is_Remote_Access_To_Class_Wide_Type (Etype (Prefix (Name))) + and then Comes_From_Source (N) + then + if Try_Object_Operation (N) then + return; + else + Error_Msg_N + ("invalid dereference of a remote access-to-class-wide value", + N); + end if; + end if; + + -- (Ada 2005): if the prefix is the limited view of a type, and + -- the context already includes the full view, use the full view + -- in what follows, either to retrieve a component of to find + -- a primitive operation. If the prefix is an explicit dereference, + -- set the type of the prefix to reflect this transformation. + -- If the non-limited view is itself an incomplete type, get the + -- full view if available. + + if Is_Incomplete_Type (Prefix_Type) + and then From_With_Type (Prefix_Type) + and then Present (Non_Limited_View (Prefix_Type)) + then + Prefix_Type := Get_Full_View (Non_Limited_View (Prefix_Type)); + + if Nkind (N) = N_Explicit_Dereference then + Set_Etype (Prefix (N), Prefix_Type); + end if; + + elsif Ekind (Prefix_Type) = E_Class_Wide_Type + and then From_With_Type (Prefix_Type) + and then Present (Non_Limited_View (Etype (Prefix_Type))) + then + Prefix_Type := + Class_Wide_Type (Non_Limited_View (Etype (Prefix_Type))); + + if Nkind (N) = N_Explicit_Dereference then + Set_Etype (Prefix (N), Prefix_Type); + end if; + end if; + + if Ekind (Prefix_Type) = E_Private_Subtype then + Prefix_Type := Base_Type (Prefix_Type); + end if; + + Type_To_Use := Prefix_Type; + + -- For class-wide types, use the entity list of the root type. This + -- indirection is specially important for private extensions because + -- only the root type get switched (not the class-wide type). + + if Is_Class_Wide_Type (Prefix_Type) then + Type_To_Use := Root_Type (Prefix_Type); + end if; + + -- If the prefix is a single concurrent object, use its name in error + -- messages, rather than that of its anonymous type. + + Is_Single_Concurrent_Object := + Is_Concurrent_Type (Prefix_Type) + and then Is_Internal_Name (Chars (Prefix_Type)) + and then not Is_Derived_Type (Prefix_Type) + and then Is_Entity_Name (Name); + + Comp := First_Entity (Type_To_Use); + + -- If the selector has an original discriminant, the node appears in + -- an instance. Replace the discriminant with the corresponding one + -- in the current discriminated type. For nested generics, this must + -- be done transitively, so note the new original discriminant. + + if Nkind (Sel) = N_Identifier + and then Present (Original_Discriminant (Sel)) + then + Comp := Find_Corresponding_Discriminant (Sel, Prefix_Type); + + -- Mark entity before rewriting, for completeness and because + -- subsequent semantic checks might examine the original node. + + Set_Entity (Sel, Comp); + Rewrite (Selector_Name (N), + New_Occurrence_Of (Comp, Sloc (N))); + Set_Original_Discriminant (Selector_Name (N), Comp); + Set_Etype (N, Etype (Comp)); + + if Is_Access_Type (Etype (Name)) then + Insert_Explicit_Dereference (Name); + Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N); + end if; + + elsif Is_Record_Type (Prefix_Type) then + + -- Find component with given name + + while Present (Comp) loop + if Chars (Comp) = Chars (Sel) + and then Is_Visible_Component (Comp) + then + Set_Entity_With_Style_Check (Sel, Comp); + Set_Etype (Sel, Etype (Comp)); + + if Ekind (Comp) = E_Discriminant then + if Is_Unchecked_Union (Base_Type (Prefix_Type)) then + Error_Msg_N + ("cannot reference discriminant of Unchecked_Union", + Sel); + end if; + + if Is_Generic_Type (Prefix_Type) + or else + Is_Generic_Type (Root_Type (Prefix_Type)) + then + Set_Original_Discriminant (Sel, Comp); + end if; + end if; + + -- Resolve the prefix early otherwise it is not possible to + -- build the actual subtype of the component: it may need + -- to duplicate this prefix and duplication is only allowed + -- on fully resolved expressions. + + Resolve (Name); + + -- Ada 2005 (AI-50217): Check wrong use of incomplete types or + -- subtypes in a package specification. + -- Example: + + -- limited with Pkg; + -- package Pkg is + -- type Acc_Inc is access Pkg.T; + -- X : Acc_Inc; + -- N : Natural := X.all.Comp; -- ERROR, limited view + -- end Pkg; -- Comp is not visible + + if Nkind (Name) = N_Explicit_Dereference + and then From_With_Type (Etype (Prefix (Name))) + and then not Is_Potentially_Use_Visible (Etype (Name)) + and then Nkind (Parent (Cunit_Entity (Current_Sem_Unit))) = + N_Package_Specification + then + Error_Msg_NE + ("premature usage of incomplete}", Prefix (Name), + Etype (Prefix (Name))); + end if; + + -- We never need an actual subtype for the case of a selection + -- for a indexed component of a non-packed array, since in + -- this case gigi generates all the checks and can find the + -- necessary bounds information. + + -- We also do not need an actual subtype for the case of a + -- first, last, length, or range attribute applied to a + -- non-packed array, since gigi can again get the bounds in + -- these cases (gigi cannot handle the packed case, since it + -- has the bounds of the packed array type, not the original + -- bounds of the type). However, if the prefix is itself a + -- selected component, as in a.b.c (i), gigi may regard a.b.c + -- as a dynamic-sized temporary, so we do generate an actual + -- subtype for this case. + + Parent_N := Parent (N); + + if not Is_Packed (Etype (Comp)) + and then + ((Nkind (Parent_N) = N_Indexed_Component + and then Nkind (Name) /= N_Selected_Component) + or else + (Nkind (Parent_N) = N_Attribute_Reference + and then (Attribute_Name (Parent_N) = Name_First + or else + Attribute_Name (Parent_N) = Name_Last + or else + Attribute_Name (Parent_N) = Name_Length + or else + Attribute_Name (Parent_N) = Name_Range))) + then + Set_Etype (N, Etype (Comp)); + + -- If full analysis is not enabled, we do not generate an + -- actual subtype, because in the absence of expansion + -- reference to a formal of a protected type, for example, + -- will not be properly transformed, and will lead to + -- out-of-scope references in gigi. + + -- In all other cases, we currently build an actual subtype. + -- It seems likely that many of these cases can be avoided, + -- but right now, the front end makes direct references to the + -- bounds (e.g. in generating a length check), and if we do + -- not make an actual subtype, we end up getting a direct + -- reference to a discriminant, which will not do. + + elsif Full_Analysis then + Act_Decl := + Build_Actual_Subtype_Of_Component (Etype (Comp), N); + Insert_Action (N, Act_Decl); + + if No (Act_Decl) then + Set_Etype (N, Etype (Comp)); + + else + -- Component type depends on discriminants. Enter the + -- main attributes of the subtype. + + declare + Subt : constant Entity_Id := + Defining_Identifier (Act_Decl); + + begin + Set_Etype (Subt, Base_Type (Etype (Comp))); + Set_Ekind (Subt, Ekind (Etype (Comp))); + Set_Etype (N, Subt); + end; + end if; + + -- If Full_Analysis not enabled, just set the Etype + + else + Set_Etype (N, Etype (Comp)); + end if; + + return; + end if; + + -- If the prefix is a private extension, check only the visible + -- components of the partial view. This must include the tag, + -- which can appear in expanded code in a tag check. + + if Ekind (Type_To_Use) = E_Record_Type_With_Private + and then Chars (Selector_Name (N)) /= Name_uTag + then + exit when Comp = Last_Entity (Type_To_Use); + end if; + + Next_Entity (Comp); + end loop; + + -- Ada 2005 (AI-252): The selected component can be interpreted as + -- a prefixed view of a subprogram. Depending on the context, this is + -- either a name that can appear in a renaming declaration, or part + -- of an enclosing call given in prefix form. + + -- Ada 2005 (AI05-0030): In the case of dispatching requeue, the + -- selected component should resolve to a name. + + if Ada_Version >= Ada_2005 + and then Is_Tagged_Type (Prefix_Type) + and then not Is_Concurrent_Type (Prefix_Type) + then + if Nkind (Parent (N)) = N_Generic_Association + or else Nkind (Parent (N)) = N_Requeue_Statement + or else Nkind (Parent (N)) = N_Subprogram_Renaming_Declaration + then + if Find_Primitive_Operation (N) then + return; + end if; + + elsif Try_Object_Operation (N) then + return; + end if; + + -- If the transformation fails, it will be necessary to redo the + -- analysis with all errors enabled, to indicate candidate + -- interpretations and reasons for each failure ??? + + end if; + + elsif Is_Private_Type (Prefix_Type) then + + -- Allow access only to discriminants of the type. If the type has + -- no full view, gigi uses the parent type for the components, so we + -- do the same here. + + if No (Full_View (Prefix_Type)) then + Type_To_Use := Root_Type (Base_Type (Prefix_Type)); + Comp := First_Entity (Type_To_Use); + end if; + + while Present (Comp) loop + if Chars (Comp) = Chars (Sel) then + if Ekind (Comp) = E_Discriminant then + Set_Entity_With_Style_Check (Sel, Comp); + Generate_Reference (Comp, Sel); + + Set_Etype (Sel, Etype (Comp)); + Set_Etype (N, Etype (Comp)); + + if Is_Generic_Type (Prefix_Type) + or else Is_Generic_Type (Root_Type (Prefix_Type)) + then + Set_Original_Discriminant (Sel, Comp); + end if; + + -- Before declaring an error, check whether this is tagged + -- private type and a call to a primitive operation. + + elsif Ada_Version >= Ada_2005 + and then Is_Tagged_Type (Prefix_Type) + and then Try_Object_Operation (N) + then + return; + + else + Error_Msg_Node_2 := First_Subtype (Prefix_Type); + Error_Msg_NE ("invisible selector& for }", N, Sel); + Set_Entity (Sel, Any_Id); + Set_Etype (N, Any_Type); + end if; + + return; + end if; + + Next_Entity (Comp); + end loop; + + elsif Is_Concurrent_Type (Prefix_Type) then + + -- Find visible operation with given name. For a protected type, + -- the possible candidates are discriminants, entries or protected + -- procedures. For a task type, the set can only include entries or + -- discriminants if the task type is not an enclosing scope. If it + -- is an enclosing scope (e.g. in an inner task) then all entities + -- are visible, but the prefix must denote the enclosing scope, i.e. + -- can only be a direct name or an expanded name. + + Set_Etype (Sel, Any_Type); + In_Scope := In_Open_Scopes (Prefix_Type); + + while Present (Comp) loop + if Chars (Comp) = Chars (Sel) then + if Is_Overloadable (Comp) then + Add_One_Interp (Sel, Comp, Etype (Comp)); + + -- If the prefix is tagged, the correct interpretation may + -- lie in the primitive or class-wide operations of the + -- type. Perform a simple conformance check to determine + -- whether Try_Object_Operation should be invoked even if + -- a visible entity is found. + + if Is_Tagged_Type (Prefix_Type) + and then + Nkind_In (Parent (N), N_Procedure_Call_Statement, + N_Function_Call, + N_Indexed_Component) + and then Has_Mode_Conformant_Spec (Comp) + then + Has_Candidate := True; + end if; + + -- Note: a selected component may not denote a component of a + -- protected type (4.1.3(7)). + + elsif Ekind_In (Comp, E_Discriminant, E_Entry_Family) + or else (In_Scope + and then not Is_Protected_Type (Prefix_Type) + and then Is_Entity_Name (Name)) + then + Set_Entity_With_Style_Check (Sel, Comp); + Generate_Reference (Comp, Sel); + + else + goto Next_Comp; + end if; + + Set_Etype (Sel, Etype (Comp)); + Set_Etype (N, Etype (Comp)); + + if Ekind (Comp) = E_Discriminant then + Set_Original_Discriminant (Sel, Comp); + end if; + + -- For access type case, introduce explicit dereference for + -- more uniform treatment of entry calls. + + if Is_Access_Type (Etype (Name)) then + Insert_Explicit_Dereference (Name); + Error_Msg_NW + (Warn_On_Dereference, "?implicit dereference", N); + end if; + end if; + + <> + Next_Entity (Comp); + exit when not In_Scope + and then + Comp = First_Private_Entity (Base_Type (Prefix_Type)); + end loop; + + -- If there is no visible entity with the given name or none of the + -- visible entities are plausible interpretations, check whether + -- there is some other primitive operation with that name. + + if Ada_Version >= Ada_2005 + and then Is_Tagged_Type (Prefix_Type) + then + if (Etype (N) = Any_Type + or else not Has_Candidate) + and then Try_Object_Operation (N) + then + return; + + -- If the context is not syntactically a procedure call, it + -- may be a call to a primitive function declared outside of + -- the synchronized type. + + -- If the context is a procedure call, there might still be + -- an overloading between an entry and a primitive procedure + -- declared outside of the synchronized type, called in prefix + -- notation. This is harder to disambiguate because in one case + -- the controlling formal is implicit ??? + + elsif Nkind (Parent (N)) /= N_Procedure_Call_Statement + and then Nkind (Parent (N)) /= N_Indexed_Component + and then Try_Object_Operation (N) + then + return; + end if; + end if; + + if Etype (N) = Any_Type and then Is_Protected_Type (Prefix_Type) then + -- Case of a prefix of a protected type: selector might denote + -- an invisible private component. + + Comp := First_Private_Entity (Base_Type (Prefix_Type)); + while Present (Comp) and then Chars (Comp) /= Chars (Sel) loop + Next_Entity (Comp); + end loop; + + if Present (Comp) then + if Is_Single_Concurrent_Object then + Error_Msg_Node_2 := Entity (Name); + Error_Msg_NE ("invisible selector& for &", N, Sel); + + else + Error_Msg_Node_2 := First_Subtype (Prefix_Type); + Error_Msg_NE ("invisible selector& for }", N, Sel); + end if; + return; + end if; + end if; + + Set_Is_Overloaded (N, Is_Overloaded (Sel)); + + else + -- Invalid prefix + + Error_Msg_NE ("invalid prefix in selected component&", N, Sel); + end if; + + -- If N still has no type, the component is not defined in the prefix + + if Etype (N) = Any_Type then + + if Is_Single_Concurrent_Object then + Error_Msg_Node_2 := Entity (Name); + Error_Msg_NE ("no selector& for&", N, Sel); + + Check_Misspelled_Selector (Type_To_Use, Sel); + + elsif Is_Generic_Type (Prefix_Type) + and then Ekind (Prefix_Type) = E_Record_Type_With_Private + and then Prefix_Type /= Etype (Prefix_Type) + and then Is_Record_Type (Etype (Prefix_Type)) + then + -- If this is a derived formal type, the parent may have + -- different visibility at this point. Try for an inherited + -- component before reporting an error. + + Set_Etype (Prefix (N), Etype (Prefix_Type)); + Analyze_Selected_Component (N); + return; + + -- Similarly, if this is the actual for a formal derived type, the + -- component inherited from the generic parent may not be visible + -- in the actual, but the selected component is legal. + + elsif Ekind (Prefix_Type) = E_Record_Subtype_With_Private + and then Is_Generic_Actual_Type (Prefix_Type) + and then Present (Full_View (Prefix_Type)) + then + + Find_Component_In_Instance + (Generic_Parent_Type (Parent (Prefix_Type))); + return; + + -- Finally, the formal and the actual may be private extensions, + -- but the generic is declared in a child unit of the parent, and + -- an additional step is needed to retrieve the proper scope. + + elsif In_Instance + and then Present (Parent_Subtype (Etype (Base_Type (Prefix_Type)))) + then + Find_Component_In_Instance + (Parent_Subtype (Etype (Base_Type (Prefix_Type)))); + return; + + -- Component not found, specialize error message when appropriate + + else + if Ekind (Prefix_Type) = E_Record_Subtype then + + -- Check whether this is a component of the base type which + -- is absent from a statically constrained subtype. This will + -- raise constraint error at run time, but is not a compile- + -- time error. When the selector is illegal for base type as + -- well fall through and generate a compilation error anyway. + + Comp := First_Component (Base_Type (Prefix_Type)); + while Present (Comp) loop + if Chars (Comp) = Chars (Sel) + and then Is_Visible_Component (Comp) + then + Set_Entity_With_Style_Check (Sel, Comp); + Generate_Reference (Comp, Sel); + Set_Etype (Sel, Etype (Comp)); + Set_Etype (N, Etype (Comp)); + + -- Emit appropriate message. Gigi will replace the + -- node subsequently with the appropriate Raise. + + Apply_Compile_Time_Constraint_Error + (N, "component not present in }?", + CE_Discriminant_Check_Failed, + Ent => Prefix_Type, Rep => False); + Set_Raises_Constraint_Error (N); + return; + end if; + + Next_Component (Comp); + end loop; + + end if; + + Error_Msg_Node_2 := First_Subtype (Prefix_Type); + Error_Msg_NE ("no selector& for}", N, Sel); + + Check_Misspelled_Selector (Type_To_Use, Sel); + end if; + + Set_Entity (Sel, Any_Id); + Set_Etype (Sel, Any_Type); + end if; + end Analyze_Selected_Component; + + --------------------------- + -- Analyze_Short_Circuit -- + --------------------------- + + procedure Analyze_Short_Circuit (N : Node_Id) is + L : constant Node_Id := Left_Opnd (N); + R : constant Node_Id := Right_Opnd (N); + Ind : Interp_Index; + It : Interp; + + begin + Analyze_Expression (L); + Analyze_Expression (R); + Set_Etype (N, Any_Type); + + if not Is_Overloaded (L) then + if Root_Type (Etype (L)) = Standard_Boolean + and then Has_Compatible_Type (R, Etype (L)) + then + Add_One_Interp (N, Etype (L), Etype (L)); + end if; + + else + Get_First_Interp (L, Ind, It); + while Present (It.Typ) loop + if Root_Type (It.Typ) = Standard_Boolean + and then Has_Compatible_Type (R, It.Typ) + then + Add_One_Interp (N, It.Typ, It.Typ); + end if; + + Get_Next_Interp (Ind, It); + end loop; + end if; + + -- Here we have failed to find an interpretation. Clearly we know that + -- it is not the case that both operands can have an interpretation of + -- Boolean, but this is by far the most likely intended interpretation. + -- So we simply resolve both operands as Booleans, and at least one of + -- these resolutions will generate an error message, and we do not need + -- to give another error message on the short circuit operation itself. + + if Etype (N) = Any_Type then + Resolve (L, Standard_Boolean); + Resolve (R, Standard_Boolean); + Set_Etype (N, Standard_Boolean); + end if; + end Analyze_Short_Circuit; + + ------------------- + -- Analyze_Slice -- + ------------------- + + procedure Analyze_Slice (N : Node_Id) is + P : constant Node_Id := Prefix (N); + D : constant Node_Id := Discrete_Range (N); + Array_Type : Entity_Id; + + procedure Analyze_Overloaded_Slice; + -- If the prefix is overloaded, select those interpretations that + -- yield a one-dimensional array type. + + ------------------------------ + -- Analyze_Overloaded_Slice -- + ------------------------------ + + procedure Analyze_Overloaded_Slice is + I : Interp_Index; + It : Interp; + Typ : Entity_Id; + + begin + Set_Etype (N, Any_Type); + + Get_First_Interp (P, I, It); + while Present (It.Nam) loop + Typ := It.Typ; + + if Is_Access_Type (Typ) then + Typ := Designated_Type (Typ); + Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N); + end if; + + if Is_Array_Type (Typ) + and then Number_Dimensions (Typ) = 1 + and then Has_Compatible_Type (D, Etype (First_Index (Typ))) + then + Add_One_Interp (N, Typ, Typ); + end if; + + Get_Next_Interp (I, It); + end loop; + + if Etype (N) = Any_Type then + Error_Msg_N ("expect array type in prefix of slice", N); + end if; + end Analyze_Overloaded_Slice; + + -- Start of processing for Analyze_Slice + + begin + Analyze (P); + Analyze (D); + + if Is_Overloaded (P) then + Analyze_Overloaded_Slice; + + else + Array_Type := Etype (P); + Set_Etype (N, Any_Type); + + if Is_Access_Type (Array_Type) then + Array_Type := Designated_Type (Array_Type); + Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N); + end if; + + if not Is_Array_Type (Array_Type) then + Wrong_Type (P, Any_Array); + + elsif Number_Dimensions (Array_Type) > 1 then + Error_Msg_N + ("type is not one-dimensional array in slice prefix", N); + + elsif not + Has_Compatible_Type (D, Etype (First_Index (Array_Type))) + then + Wrong_Type (D, Etype (First_Index (Array_Type))); + + else + Set_Etype (N, Array_Type); + end if; + end if; + end Analyze_Slice; + + ----------------------------- + -- Analyze_Type_Conversion -- + ----------------------------- + + procedure Analyze_Type_Conversion (N : Node_Id) is + Expr : constant Node_Id := Expression (N); + T : Entity_Id; + + begin + -- If Conversion_OK is set, then the Etype is already set, and the + -- only processing required is to analyze the expression. This is + -- used to construct certain "illegal" conversions which are not + -- allowed by Ada semantics, but can be handled OK by Gigi, see + -- Sinfo for further details. + + if Conversion_OK (N) then + Analyze (Expr); + return; + end if; + + -- Otherwise full type analysis is required, as well as some semantic + -- checks to make sure the argument of the conversion is appropriate. + + Find_Type (Subtype_Mark (N)); + T := Entity (Subtype_Mark (N)); + Set_Etype (N, T); + Check_Fully_Declared (T, N); + Analyze_Expression (Expr); + Validate_Remote_Type_Type_Conversion (N); + + -- Only remaining step is validity checks on the argument. These + -- are skipped if the conversion does not come from the source. + + if not Comes_From_Source (N) then + return; + + -- If there was an error in a generic unit, no need to replicate the + -- error message. Conversely, constant-folding in the generic may + -- transform the argument of a conversion into a string literal, which + -- is legal. Therefore the following tests are not performed in an + -- instance. + + elsif In_Instance then + return; + + elsif Nkind (Expr) = N_Null then + Error_Msg_N ("argument of conversion cannot be null", N); + Error_Msg_N ("\use qualified expression instead", N); + Set_Etype (N, Any_Type); + + elsif Nkind (Expr) = N_Aggregate then + Error_Msg_N ("argument of conversion cannot be aggregate", N); + Error_Msg_N ("\use qualified expression instead", N); + + elsif Nkind (Expr) = N_Allocator then + Error_Msg_N ("argument of conversion cannot be an allocator", N); + Error_Msg_N ("\use qualified expression instead", N); + + elsif Nkind (Expr) = N_String_Literal then + Error_Msg_N ("argument of conversion cannot be string literal", N); + Error_Msg_N ("\use qualified expression instead", N); + + elsif Nkind (Expr) = N_Character_Literal then + if Ada_Version = Ada_83 then + Resolve (Expr, T); + else + Error_Msg_N ("argument of conversion cannot be character literal", + N); + Error_Msg_N ("\use qualified expression instead", N); + end if; + + elsif Nkind (Expr) = N_Attribute_Reference + and then + (Attribute_Name (Expr) = Name_Access or else + Attribute_Name (Expr) = Name_Unchecked_Access or else + Attribute_Name (Expr) = Name_Unrestricted_Access) + then + Error_Msg_N ("argument of conversion cannot be access", N); + Error_Msg_N ("\use qualified expression instead", N); + end if; + end Analyze_Type_Conversion; + + ---------------------- + -- Analyze_Unary_Op -- + ---------------------- + + procedure Analyze_Unary_Op (N : Node_Id) is + R : constant Node_Id := Right_Opnd (N); + Op_Id : Entity_Id := Entity (N); + + begin + Set_Etype (N, Any_Type); + Candidate_Type := Empty; + + Analyze_Expression (R); + + if Present (Op_Id) then + if Ekind (Op_Id) = E_Operator then + Find_Unary_Types (R, Op_Id, N); + else + Add_One_Interp (N, Op_Id, Etype (Op_Id)); + end if; + + else + Op_Id := Get_Name_Entity_Id (Chars (N)); + while Present (Op_Id) loop + if Ekind (Op_Id) = E_Operator then + if No (Next_Entity (First_Entity (Op_Id))) then + Find_Unary_Types (R, Op_Id, N); + end if; + + elsif Is_Overloadable (Op_Id) then + Analyze_User_Defined_Unary_Op (N, Op_Id); + end if; + + Op_Id := Homonym (Op_Id); + end loop; + end if; + + Operator_Check (N); + end Analyze_Unary_Op; + + ---------------------------------- + -- Analyze_Unchecked_Expression -- + ---------------------------------- + + procedure Analyze_Unchecked_Expression (N : Node_Id) is + begin + Analyze (Expression (N), Suppress => All_Checks); + Set_Etype (N, Etype (Expression (N))); + Save_Interps (Expression (N), N); + end Analyze_Unchecked_Expression; + + --------------------------------------- + -- Analyze_Unchecked_Type_Conversion -- + --------------------------------------- + + procedure Analyze_Unchecked_Type_Conversion (N : Node_Id) is + begin + Find_Type (Subtype_Mark (N)); + Analyze_Expression (Expression (N)); + Set_Etype (N, Entity (Subtype_Mark (N))); + end Analyze_Unchecked_Type_Conversion; + + ------------------------------------ + -- Analyze_User_Defined_Binary_Op -- + ------------------------------------ + + procedure Analyze_User_Defined_Binary_Op + (N : Node_Id; + Op_Id : Entity_Id) + is + begin + -- Only do analysis if the operator Comes_From_Source, since otherwise + -- the operator was generated by the expander, and all such operators + -- always refer to the operators in package Standard. + + if Comes_From_Source (N) then + declare + F1 : constant Entity_Id := First_Formal (Op_Id); + F2 : constant Entity_Id := Next_Formal (F1); + + begin + -- Verify that Op_Id is a visible binary function. Note that since + -- we know Op_Id is overloaded, potentially use visible means use + -- visible for sure (RM 9.4(11)). + + if Ekind (Op_Id) = E_Function + and then Present (F2) + and then (Is_Immediately_Visible (Op_Id) + or else Is_Potentially_Use_Visible (Op_Id)) + and then Has_Compatible_Type (Left_Opnd (N), Etype (F1)) + and then Has_Compatible_Type (Right_Opnd (N), Etype (F2)) + then + Add_One_Interp (N, Op_Id, Etype (Op_Id)); + + -- If the left operand is overloaded, indicate that the + -- current type is a viable candidate. This is redundant + -- in most cases, but for equality and comparison operators + -- where the context does not impose a type on the operands, + -- setting the proper type is necessary to avoid subsequent + -- ambiguities during resolution, when both user-defined and + -- predefined operators may be candidates. + + if Is_Overloaded (Left_Opnd (N)) then + Set_Etype (Left_Opnd (N), Etype (F1)); + end if; + + if Debug_Flag_E then + Write_Str ("user defined operator "); + Write_Name (Chars (Op_Id)); + Write_Str (" on node "); + Write_Int (Int (N)); + Write_Eol; + end if; + end if; + end; + end if; + end Analyze_User_Defined_Binary_Op; + + ----------------------------------- + -- Analyze_User_Defined_Unary_Op -- + ----------------------------------- + + procedure Analyze_User_Defined_Unary_Op + (N : Node_Id; + Op_Id : Entity_Id) + is + begin + -- Only do analysis if the operator Comes_From_Source, since otherwise + -- the operator was generated by the expander, and all such operators + -- always refer to the operators in package Standard. + + if Comes_From_Source (N) then + declare + F : constant Entity_Id := First_Formal (Op_Id); + + begin + -- Verify that Op_Id is a visible unary function. Note that since + -- we know Op_Id is overloaded, potentially use visible means use + -- visible for sure (RM 9.4(11)). + + if Ekind (Op_Id) = E_Function + and then No (Next_Formal (F)) + and then (Is_Immediately_Visible (Op_Id) + or else Is_Potentially_Use_Visible (Op_Id)) + and then Has_Compatible_Type (Right_Opnd (N), Etype (F)) + then + Add_One_Interp (N, Op_Id, Etype (Op_Id)); + end if; + end; + end if; + end Analyze_User_Defined_Unary_Op; + + --------------------------- + -- Check_Arithmetic_Pair -- + --------------------------- + + procedure Check_Arithmetic_Pair + (T1, T2 : Entity_Id; + Op_Id : Entity_Id; + N : Node_Id) + is + Op_Name : constant Name_Id := Chars (Op_Id); + + function Has_Fixed_Op (Typ : Entity_Id; Op : Entity_Id) return Boolean; + -- Check whether the fixed-point type Typ has a user-defined operator + -- (multiplication or division) that should hide the corresponding + -- predefined operator. Used to implement Ada 2005 AI-264, to make + -- such operators more visible and therefore useful. + + -- If the name of the operation is an expanded name with prefix + -- Standard, the predefined universal fixed operator is available, + -- as specified by AI-420 (RM 4.5.5 (19.1/2)). + + function Specific_Type (T1, T2 : Entity_Id) return Entity_Id; + -- Get specific type (i.e. non-universal type if there is one) + + ------------------ + -- Has_Fixed_Op -- + ------------------ + + function Has_Fixed_Op (Typ : Entity_Id; Op : Entity_Id) return Boolean is + Bas : constant Entity_Id := Base_Type (Typ); + Ent : Entity_Id; + F1 : Entity_Id; + F2 : Entity_Id; + + begin + -- If the universal_fixed operation is given explicitly the rule + -- concerning primitive operations of the type do not apply. + + if Nkind (N) = N_Function_Call + and then Nkind (Name (N)) = N_Expanded_Name + and then Entity (Prefix (Name (N))) = Standard_Standard + then + return False; + end if; + + -- The operation is treated as primitive if it is declared in the + -- same scope as the type, and therefore on the same entity chain. + + Ent := Next_Entity (Typ); + while Present (Ent) loop + if Chars (Ent) = Chars (Op) then + F1 := First_Formal (Ent); + F2 := Next_Formal (F1); + + -- The operation counts as primitive if either operand or + -- result are of the given base type, and both operands are + -- fixed point types. + + if (Base_Type (Etype (F1)) = Bas + and then Is_Fixed_Point_Type (Etype (F2))) + + or else + (Base_Type (Etype (F2)) = Bas + and then Is_Fixed_Point_Type (Etype (F1))) + + or else + (Base_Type (Etype (Ent)) = Bas + and then Is_Fixed_Point_Type (Etype (F1)) + and then Is_Fixed_Point_Type (Etype (F2))) + then + return True; + end if; + end if; + + Next_Entity (Ent); + end loop; + + return False; + end Has_Fixed_Op; + + ------------------- + -- Specific_Type -- + ------------------- + + function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is + begin + if T1 = Universal_Integer or else T1 = Universal_Real then + return Base_Type (T2); + else + return Base_Type (T1); + end if; + end Specific_Type; + + -- Start of processing for Check_Arithmetic_Pair + + begin + if Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then + + if Is_Numeric_Type (T1) + and then Is_Numeric_Type (T2) + and then (Covers (T1 => T1, T2 => T2) + or else + Covers (T1 => T2, T2 => T1)) + then + Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); + end if; + + elsif Op_Name = Name_Op_Multiply or else Op_Name = Name_Op_Divide then + + if Is_Fixed_Point_Type (T1) + and then (Is_Fixed_Point_Type (T2) + or else T2 = Universal_Real) + then + -- If Treat_Fixed_As_Integer is set then the Etype is already set + -- and no further processing is required (this is the case of an + -- operator constructed by Exp_Fixd for a fixed point operation) + -- Otherwise add one interpretation with universal fixed result + -- If the operator is given in functional notation, it comes + -- from source and Fixed_As_Integer cannot apply. + + if (Nkind (N) not in N_Op + or else not Treat_Fixed_As_Integer (N)) + and then + (not Has_Fixed_Op (T1, Op_Id) + or else Nkind (Parent (N)) = N_Type_Conversion) + then + Add_One_Interp (N, Op_Id, Universal_Fixed); + end if; + + elsif Is_Fixed_Point_Type (T2) + and then (Nkind (N) not in N_Op + or else not Treat_Fixed_As_Integer (N)) + and then T1 = Universal_Real + and then + (not Has_Fixed_Op (T1, Op_Id) + or else Nkind (Parent (N)) = N_Type_Conversion) + then + Add_One_Interp (N, Op_Id, Universal_Fixed); + + elsif Is_Numeric_Type (T1) + and then Is_Numeric_Type (T2) + and then (Covers (T1 => T1, T2 => T2) + or else + Covers (T1 => T2, T2 => T1)) + then + Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); + + elsif Is_Fixed_Point_Type (T1) + and then (Base_Type (T2) = Base_Type (Standard_Integer) + or else T2 = Universal_Integer) + then + Add_One_Interp (N, Op_Id, T1); + + elsif T2 = Universal_Real + and then Base_Type (T1) = Base_Type (Standard_Integer) + and then Op_Name = Name_Op_Multiply + then + Add_One_Interp (N, Op_Id, Any_Fixed); + + elsif T1 = Universal_Real + and then Base_Type (T2) = Base_Type (Standard_Integer) + then + Add_One_Interp (N, Op_Id, Any_Fixed); + + elsif Is_Fixed_Point_Type (T2) + and then (Base_Type (T1) = Base_Type (Standard_Integer) + or else T1 = Universal_Integer) + and then Op_Name = Name_Op_Multiply + then + Add_One_Interp (N, Op_Id, T2); + + elsif T1 = Universal_Real and then T2 = Universal_Integer then + Add_One_Interp (N, Op_Id, T1); + + elsif T2 = Universal_Real + and then T1 = Universal_Integer + and then Op_Name = Name_Op_Multiply + then + Add_One_Interp (N, Op_Id, T2); + end if; + + elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then + + -- Note: The fixed-point operands case with Treat_Fixed_As_Integer + -- set does not require any special processing, since the Etype is + -- already set (case of operation constructed by Exp_Fixed). + + if Is_Integer_Type (T1) + and then (Covers (T1 => T1, T2 => T2) + or else + Covers (T1 => T2, T2 => T1)) + then + Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); + end if; + + elsif Op_Name = Name_Op_Expon then + if Is_Numeric_Type (T1) + and then not Is_Fixed_Point_Type (T1) + and then (Base_Type (T2) = Base_Type (Standard_Integer) + or else T2 = Universal_Integer) + then + Add_One_Interp (N, Op_Id, Base_Type (T1)); + end if; + + else pragma Assert (Nkind (N) in N_Op_Shift); + + -- If not one of the predefined operators, the node may be one + -- of the intrinsic functions. Its kind is always specific, and + -- we can use it directly, rather than the name of the operation. + + if Is_Integer_Type (T1) + and then (Base_Type (T2) = Base_Type (Standard_Integer) + or else T2 = Universal_Integer) + then + Add_One_Interp (N, Op_Id, Base_Type (T1)); + end if; + end if; + end Check_Arithmetic_Pair; + + ------------------------------- + -- Check_Misspelled_Selector -- + ------------------------------- + + procedure Check_Misspelled_Selector + (Prefix : Entity_Id; + Sel : Node_Id) + is + Max_Suggestions : constant := 2; + Nr_Of_Suggestions : Natural := 0; + + Suggestion_1 : Entity_Id := Empty; + Suggestion_2 : Entity_Id := Empty; + + Comp : Entity_Id; + + begin + -- All the components of the prefix of selector Sel are matched + -- against Sel and a count is maintained of possible misspellings. + -- When at the end of the analysis there are one or two (not more!) + -- possible misspellings, these misspellings will be suggested as + -- possible correction. + + if not (Is_Private_Type (Prefix) or else Is_Record_Type (Prefix)) then + + -- Concurrent types should be handled as well ??? + + return; + end if; + + Comp := First_Entity (Prefix); + while Nr_Of_Suggestions <= Max_Suggestions and then Present (Comp) loop + if Is_Visible_Component (Comp) then + if Is_Bad_Spelling_Of (Chars (Comp), Chars (Sel)) then + Nr_Of_Suggestions := Nr_Of_Suggestions + 1; + + case Nr_Of_Suggestions is + when 1 => Suggestion_1 := Comp; + when 2 => Suggestion_2 := Comp; + when others => exit; + end case; + end if; + end if; + + Comp := Next_Entity (Comp); + end loop; + + -- Report at most two suggestions + + if Nr_Of_Suggestions = 1 then + Error_Msg_NE -- CODEFIX + ("\possible misspelling of&", Sel, Suggestion_1); + + elsif Nr_Of_Suggestions = 2 then + Error_Msg_Node_2 := Suggestion_2; + Error_Msg_NE -- CODEFIX + ("\possible misspelling of& or&", Sel, Suggestion_1); + end if; + end Check_Misspelled_Selector; + + ---------------------- + -- Defined_In_Scope -- + ---------------------- + + function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean + is + S1 : constant Entity_Id := Scope (Base_Type (T)); + begin + return S1 = S + or else (S1 = System_Aux_Id and then S = Scope (S1)); + end Defined_In_Scope; + + ------------------- + -- Diagnose_Call -- + ------------------- + + procedure Diagnose_Call (N : Node_Id; Nam : Node_Id) is + Actual : Node_Id; + X : Interp_Index; + It : Interp; + Err_Mode : Boolean; + New_Nam : Node_Id; + Void_Interp_Seen : Boolean := False; + + Success : Boolean; + pragma Warnings (Off, Boolean); + + begin + if Ada_Version >= Ada_2005 then + Actual := First_Actual (N); + while Present (Actual) loop + + -- Ada 2005 (AI-50217): Post an error in case of premature + -- usage of an entity from the limited view. + + if not Analyzed (Etype (Actual)) + and then From_With_Type (Etype (Actual)) + then + Error_Msg_Qual_Level := 1; + Error_Msg_NE + ("missing with_clause for scope of imported type&", + Actual, Etype (Actual)); + Error_Msg_Qual_Level := 0; + end if; + + Next_Actual (Actual); + end loop; + end if; + + -- Analyze each candidate call again, with full error reporting + -- for each. + + Error_Msg_N + ("no candidate interpretations match the actuals:!", Nam); + Err_Mode := All_Errors_Mode; + All_Errors_Mode := True; + + -- If this is a call to an operation of a concurrent type, + -- the failed interpretations have been removed from the + -- name. Recover them to provide full diagnostics. + + if Nkind (Parent (Nam)) = N_Selected_Component then + Set_Entity (Nam, Empty); + New_Nam := New_Copy_Tree (Parent (Nam)); + Set_Is_Overloaded (New_Nam, False); + Set_Is_Overloaded (Selector_Name (New_Nam), False); + Set_Parent (New_Nam, Parent (Parent (Nam))); + Analyze_Selected_Component (New_Nam); + Get_First_Interp (Selector_Name (New_Nam), X, It); + else + Get_First_Interp (Nam, X, It); + end if; + + while Present (It.Nam) loop + if Etype (It.Nam) = Standard_Void_Type then + Void_Interp_Seen := True; + end if; + + Analyze_One_Call (N, It.Nam, True, Success); + Get_Next_Interp (X, It); + end loop; + + if Nkind (N) = N_Function_Call then + Get_First_Interp (Nam, X, It); + while Present (It.Nam) loop + if Ekind_In (It.Nam, E_Function, E_Operator) then + return; + else + Get_Next_Interp (X, It); + end if; + end loop; + + -- If all interpretations are procedures, this deserves a + -- more precise message. Ditto if this appears as the prefix + -- of a selected component, which may be a lexical error. + + Error_Msg_N + ("\context requires function call, found procedure name", Nam); + + if Nkind (Parent (N)) = N_Selected_Component + and then N = Prefix (Parent (N)) + then + Error_Msg_N -- CODEFIX + ("\period should probably be semicolon", Parent (N)); + end if; + + elsif Nkind (N) = N_Procedure_Call_Statement + and then not Void_Interp_Seen + then + Error_Msg_N ( + "\function name found in procedure call", Nam); + end if; + + All_Errors_Mode := Err_Mode; + end Diagnose_Call; + + --------------------------- + -- Find_Arithmetic_Types -- + --------------------------- + + procedure Find_Arithmetic_Types + (L, R : Node_Id; + Op_Id : Entity_Id; + N : Node_Id) + is + Index1 : Interp_Index; + Index2 : Interp_Index; + It1 : Interp; + It2 : Interp; + + procedure Check_Right_Argument (T : Entity_Id); + -- Check right operand of operator + + -------------------------- + -- Check_Right_Argument -- + -------------------------- + + procedure Check_Right_Argument (T : Entity_Id) is + begin + if not Is_Overloaded (R) then + Check_Arithmetic_Pair (T, Etype (R), Op_Id, N); + else + Get_First_Interp (R, Index2, It2); + while Present (It2.Typ) loop + Check_Arithmetic_Pair (T, It2.Typ, Op_Id, N); + Get_Next_Interp (Index2, It2); + end loop; + end if; + end Check_Right_Argument; + + -- Start of processing for Find_Arithmetic_Types + + begin + if not Is_Overloaded (L) then + Check_Right_Argument (Etype (L)); + + else + Get_First_Interp (L, Index1, It1); + while Present (It1.Typ) loop + Check_Right_Argument (It1.Typ); + Get_Next_Interp (Index1, It1); + end loop; + end if; + + end Find_Arithmetic_Types; + + ------------------------ + -- Find_Boolean_Types -- + ------------------------ + + procedure Find_Boolean_Types + (L, R : Node_Id; + Op_Id : Entity_Id; + N : Node_Id) + is + Index : Interp_Index; + It : Interp; + + procedure Check_Numeric_Argument (T : Entity_Id); + -- Special case for logical operations one of whose operands is an + -- integer literal. If both are literal the result is any modular type. + + ---------------------------- + -- Check_Numeric_Argument -- + ---------------------------- + + procedure Check_Numeric_Argument (T : Entity_Id) is + begin + if T = Universal_Integer then + Add_One_Interp (N, Op_Id, Any_Modular); + + elsif Is_Modular_Integer_Type (T) then + Add_One_Interp (N, Op_Id, T); + end if; + end Check_Numeric_Argument; + + -- Start of processing for Find_Boolean_Types + + begin + if not Is_Overloaded (L) then + if Etype (L) = Universal_Integer + or else Etype (L) = Any_Modular + then + if not Is_Overloaded (R) then + Check_Numeric_Argument (Etype (R)); + + else + Get_First_Interp (R, Index, It); + while Present (It.Typ) loop + Check_Numeric_Argument (It.Typ); + Get_Next_Interp (Index, It); + end loop; + end if; + + -- If operands are aggregates, we must assume that they may be + -- boolean arrays, and leave disambiguation for the second pass. + -- If only one is an aggregate, verify that the other one has an + -- interpretation as a boolean array + + elsif Nkind (L) = N_Aggregate then + if Nkind (R) = N_Aggregate then + Add_One_Interp (N, Op_Id, Etype (L)); + + elsif not Is_Overloaded (R) then + if Valid_Boolean_Arg (Etype (R)) then + Add_One_Interp (N, Op_Id, Etype (R)); + end if; + + else + Get_First_Interp (R, Index, It); + while Present (It.Typ) loop + if Valid_Boolean_Arg (It.Typ) then + Add_One_Interp (N, Op_Id, It.Typ); + end if; + + Get_Next_Interp (Index, It); + end loop; + end if; + + elsif Valid_Boolean_Arg (Etype (L)) + and then Has_Compatible_Type (R, Etype (L)) + then + Add_One_Interp (N, Op_Id, Etype (L)); + end if; + + else + Get_First_Interp (L, Index, It); + while Present (It.Typ) loop + if Valid_Boolean_Arg (It.Typ) + and then Has_Compatible_Type (R, It.Typ) + then + Add_One_Interp (N, Op_Id, It.Typ); + end if; + + Get_Next_Interp (Index, It); + end loop; + end if; + end Find_Boolean_Types; + + --------------------------- + -- Find_Comparison_Types -- + --------------------------- + + procedure Find_Comparison_Types + (L, R : Node_Id; + Op_Id : Entity_Id; + N : Node_Id) + is + Index : Interp_Index; + It : Interp; + Found : Boolean := False; + I_F : Interp_Index; + T_F : Entity_Id; + Scop : Entity_Id := Empty; + + procedure Try_One_Interp (T1 : Entity_Id); + -- Routine to try one proposed interpretation. Note that the context + -- of the operator plays no role in resolving the arguments, so that + -- if there is more than one interpretation of the operands that is + -- compatible with comparison, the operation is ambiguous. + + -------------------- + -- Try_One_Interp -- + -------------------- + + procedure Try_One_Interp (T1 : Entity_Id) is + begin + + -- If the operator is an expanded name, then the type of the operand + -- must be defined in the corresponding scope. If the type is + -- universal, the context will impose the correct type. + + if Present (Scop) + and then not Defined_In_Scope (T1, Scop) + and then T1 /= Universal_Integer + and then T1 /= Universal_Real + and then T1 /= Any_String + and then T1 /= Any_Composite + then + return; + end if; + + if Valid_Comparison_Arg (T1) + and then Has_Compatible_Type (R, T1) + then + if Found + and then Base_Type (T1) /= Base_Type (T_F) + then + It := Disambiguate (L, I_F, Index, Any_Type); + + if It = No_Interp then + Ambiguous_Operands (N); + Set_Etype (L, Any_Type); + return; + + else + T_F := It.Typ; + end if; + + else + Found := True; + T_F := T1; + I_F := Index; + end if; + + Set_Etype (L, T_F); + Find_Non_Universal_Interpretations (N, R, Op_Id, T1); + + end if; + end Try_One_Interp; + + -- Start of processing for Find_Comparison_Types + + begin + -- If left operand is aggregate, the right operand has to + -- provide a usable type for it. + + if Nkind (L) = N_Aggregate + and then Nkind (R) /= N_Aggregate + then + Find_Comparison_Types (L => R, R => L, Op_Id => Op_Id, N => N); + return; + end if; + + if Nkind (N) = N_Function_Call + and then Nkind (Name (N)) = N_Expanded_Name + then + Scop := Entity (Prefix (Name (N))); + + -- The prefix may be a package renaming, and the subsequent test + -- requires the original package. + + if Ekind (Scop) = E_Package + and then Present (Renamed_Entity (Scop)) + then + Scop := Renamed_Entity (Scop); + Set_Entity (Prefix (Name (N)), Scop); + end if; + end if; + + if not Is_Overloaded (L) then + Try_One_Interp (Etype (L)); + + else + Get_First_Interp (L, Index, It); + while Present (It.Typ) loop + Try_One_Interp (It.Typ); + Get_Next_Interp (Index, It); + end loop; + end if; + end Find_Comparison_Types; + + ---------------------------------------- + -- Find_Non_Universal_Interpretations -- + ---------------------------------------- + + procedure Find_Non_Universal_Interpretations + (N : Node_Id; + R : Node_Id; + Op_Id : Entity_Id; + T1 : Entity_Id) + is + Index : Interp_Index; + It : Interp; + + begin + if T1 = Universal_Integer + or else T1 = Universal_Real + then + if not Is_Overloaded (R) then + Add_One_Interp + (N, Op_Id, Standard_Boolean, Base_Type (Etype (R))); + else + Get_First_Interp (R, Index, It); + while Present (It.Typ) loop + if Covers (It.Typ, T1) then + Add_One_Interp + (N, Op_Id, Standard_Boolean, Base_Type (It.Typ)); + end if; + + Get_Next_Interp (Index, It); + end loop; + end if; + else + Add_One_Interp (N, Op_Id, Standard_Boolean, Base_Type (T1)); + end if; + end Find_Non_Universal_Interpretations; + + ------------------------------ + -- Find_Concatenation_Types -- + ------------------------------ + + procedure Find_Concatenation_Types + (L, R : Node_Id; + Op_Id : Entity_Id; + N : Node_Id) + is + Op_Type : constant Entity_Id := Etype (Op_Id); + + begin + if Is_Array_Type (Op_Type) + and then not Is_Limited_Type (Op_Type) + + and then (Has_Compatible_Type (L, Op_Type) + or else + Has_Compatible_Type (L, Component_Type (Op_Type))) + + and then (Has_Compatible_Type (R, Op_Type) + or else + Has_Compatible_Type (R, Component_Type (Op_Type))) + then + Add_One_Interp (N, Op_Id, Op_Type); + end if; + end Find_Concatenation_Types; + + ------------------------- + -- Find_Equality_Types -- + ------------------------- + + procedure Find_Equality_Types + (L, R : Node_Id; + Op_Id : Entity_Id; + N : Node_Id) + is + Index : Interp_Index; + It : Interp; + Found : Boolean := False; + I_F : Interp_Index; + T_F : Entity_Id; + Scop : Entity_Id := Empty; + + procedure Try_One_Interp (T1 : Entity_Id); + -- The context of the equality operator plays no role in resolving the + -- arguments, so that if there is more than one interpretation of the + -- operands that is compatible with equality, the construct is ambiguous + -- and an error can be emitted now, after trying to disambiguate, i.e. + -- applying preference rules. + + -------------------- + -- Try_One_Interp -- + -------------------- + + procedure Try_One_Interp (T1 : Entity_Id) is + Bas : constant Entity_Id := Base_Type (T1); + + begin + -- If the operator is an expanded name, then the type of the operand + -- must be defined in the corresponding scope. If the type is + -- universal, the context will impose the correct type. An anonymous + -- type for a 'Access reference is also universal in this sense, as + -- the actual type is obtained from context. + -- In Ada 2005, the equality operator for anonymous access types + -- is declared in Standard, and preference rules apply to it. + + if Present (Scop) then + if Defined_In_Scope (T1, Scop) + or else T1 = Universal_Integer + or else T1 = Universal_Real + or else T1 = Any_Access + or else T1 = Any_String + or else T1 = Any_Composite + or else (Ekind (T1) = E_Access_Subprogram_Type + and then not Comes_From_Source (T1)) + then + null; + + elsif Ekind (T1) = E_Anonymous_Access_Type + and then Scop = Standard_Standard + then + null; + + else + -- The scope does not contain an operator for the type + + return; + end if; + + -- If we have infix notation, the operator must be usable. + -- Within an instance, if the type is already established we + -- know it is correct. + -- In Ada 2005, the equality on anonymous access types is declared + -- in Standard, and is always visible. + + elsif In_Open_Scopes (Scope (Bas)) + or else Is_Potentially_Use_Visible (Bas) + or else In_Use (Bas) + or else (In_Use (Scope (Bas)) + and then not Is_Hidden (Bas)) + or else (In_Instance + and then First_Subtype (T1) = First_Subtype (Etype (R))) + or else Ekind (T1) = E_Anonymous_Access_Type + then + null; + + else + -- Save candidate type for subsequent error message, if any + + if not Is_Limited_Type (T1) then + Candidate_Type := T1; + end if; + + return; + end if; + + -- Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95: + -- Do not allow anonymous access types in equality operators. + + if Ada_Version < Ada_2005 + and then Ekind (T1) = E_Anonymous_Access_Type + then + return; + end if; + + if T1 /= Standard_Void_Type + and then not Is_Limited_Type (T1) + and then not Is_Limited_Composite (T1) + and then Has_Compatible_Type (R, T1) + then + if Found + and then Base_Type (T1) /= Base_Type (T_F) + then + It := Disambiguate (L, I_F, Index, Any_Type); + + if It = No_Interp then + Ambiguous_Operands (N); + Set_Etype (L, Any_Type); + return; + + else + T_F := It.Typ; + end if; + + else + Found := True; + T_F := T1; + I_F := Index; + end if; + + if not Analyzed (L) then + Set_Etype (L, T_F); + end if; + + Find_Non_Universal_Interpretations (N, R, Op_Id, T1); + + -- Case of operator was not visible, Etype still set to Any_Type + + if Etype (N) = Any_Type then + Found := False; + end if; + + elsif Scop = Standard_Standard + and then Ekind (T1) = E_Anonymous_Access_Type + then + Found := True; + end if; + end Try_One_Interp; + + -- Start of processing for Find_Equality_Types + + begin + -- If left operand is aggregate, the right operand has to + -- provide a usable type for it. + + if Nkind (L) = N_Aggregate + and then Nkind (R) /= N_Aggregate + then + Find_Equality_Types (L => R, R => L, Op_Id => Op_Id, N => N); + return; + end if; + + if Nkind (N) = N_Function_Call + and then Nkind (Name (N)) = N_Expanded_Name + then + Scop := Entity (Prefix (Name (N))); + + -- The prefix may be a package renaming, and the subsequent test + -- requires the original package. + + if Ekind (Scop) = E_Package + and then Present (Renamed_Entity (Scop)) + then + Scop := Renamed_Entity (Scop); + Set_Entity (Prefix (Name (N)), Scop); + end if; + end if; + + if not Is_Overloaded (L) then + Try_One_Interp (Etype (L)); + + else + Get_First_Interp (L, Index, It); + while Present (It.Typ) loop + Try_One_Interp (It.Typ); + Get_Next_Interp (Index, It); + end loop; + end if; + end Find_Equality_Types; + + ------------------------- + -- Find_Negation_Types -- + ------------------------- + + procedure Find_Negation_Types + (R : Node_Id; + Op_Id : Entity_Id; + N : Node_Id) + is + Index : Interp_Index; + It : Interp; + + begin + if not Is_Overloaded (R) then + if Etype (R) = Universal_Integer then + Add_One_Interp (N, Op_Id, Any_Modular); + elsif Valid_Boolean_Arg (Etype (R)) then + Add_One_Interp (N, Op_Id, Etype (R)); + end if; + + else + Get_First_Interp (R, Index, It); + while Present (It.Typ) loop + if Valid_Boolean_Arg (It.Typ) then + Add_One_Interp (N, Op_Id, It.Typ); + end if; + + Get_Next_Interp (Index, It); + end loop; + end if; + end Find_Negation_Types; + + ------------------------------ + -- Find_Primitive_Operation -- + ------------------------------ + + function Find_Primitive_Operation (N : Node_Id) return Boolean is + Obj : constant Node_Id := Prefix (N); + Op : constant Node_Id := Selector_Name (N); + + Prim : Elmt_Id; + Prims : Elist_Id; + Typ : Entity_Id; + + begin + Set_Etype (Op, Any_Type); + + if Is_Access_Type (Etype (Obj)) then + Typ := Designated_Type (Etype (Obj)); + else + Typ := Etype (Obj); + end if; + + if Is_Class_Wide_Type (Typ) then + Typ := Root_Type (Typ); + end if; + + Prims := Primitive_Operations (Typ); + + Prim := First_Elmt (Prims); + while Present (Prim) loop + if Chars (Node (Prim)) = Chars (Op) then + Add_One_Interp (Op, Node (Prim), Etype (Node (Prim))); + Set_Etype (N, Etype (Node (Prim))); + end if; + + Next_Elmt (Prim); + end loop; + + -- Now look for class-wide operations of the type or any of its + -- ancestors by iterating over the homonyms of the selector. + + declare + Cls_Type : constant Entity_Id := Class_Wide_Type (Typ); + Hom : Entity_Id; + + begin + Hom := Current_Entity (Op); + while Present (Hom) loop + if (Ekind (Hom) = E_Procedure + or else + Ekind (Hom) = E_Function) + and then Scope (Hom) = Scope (Typ) + and then Present (First_Formal (Hom)) + and then + (Base_Type (Etype (First_Formal (Hom))) = Cls_Type + or else + (Is_Access_Type (Etype (First_Formal (Hom))) + and then + Ekind (Etype (First_Formal (Hom))) = + E_Anonymous_Access_Type + and then + Base_Type + (Designated_Type (Etype (First_Formal (Hom)))) = + Cls_Type)) + then + Add_One_Interp (Op, Hom, Etype (Hom)); + Set_Etype (N, Etype (Hom)); + end if; + + Hom := Homonym (Hom); + end loop; + end; + + return Etype (Op) /= Any_Type; + end Find_Primitive_Operation; + + ---------------------- + -- Find_Unary_Types -- + ---------------------- + + procedure Find_Unary_Types + (R : Node_Id; + Op_Id : Entity_Id; + N : Node_Id) + is + Index : Interp_Index; + It : Interp; + + begin + if not Is_Overloaded (R) then + if Is_Numeric_Type (Etype (R)) then + Add_One_Interp (N, Op_Id, Base_Type (Etype (R))); + end if; + + else + Get_First_Interp (R, Index, It); + while Present (It.Typ) loop + if Is_Numeric_Type (It.Typ) then + Add_One_Interp (N, Op_Id, Base_Type (It.Typ)); + end if; + + Get_Next_Interp (Index, It); + end loop; + end if; + end Find_Unary_Types; + + ------------------ + -- Junk_Operand -- + ------------------ + + function Junk_Operand (N : Node_Id) return Boolean is + Enode : Node_Id; + + begin + if Error_Posted (N) then + return False; + end if; + + -- Get entity to be tested + + if Is_Entity_Name (N) + and then Present (Entity (N)) + then + Enode := N; + + -- An odd case, a procedure name gets converted to a very peculiar + -- function call, and here is where we detect this happening. + + elsif Nkind (N) = N_Function_Call + and then Is_Entity_Name (Name (N)) + and then Present (Entity (Name (N))) + then + Enode := Name (N); + + -- Another odd case, there are at least some cases of selected + -- components where the selected component is not marked as having + -- an entity, even though the selector does have an entity + + elsif Nkind (N) = N_Selected_Component + and then Present (Entity (Selector_Name (N))) + then + Enode := Selector_Name (N); + + else + return False; + end if; + + -- Now test the entity we got to see if it is a bad case + + case Ekind (Entity (Enode)) is + + when E_Package => + Error_Msg_N + ("package name cannot be used as operand", Enode); + + when Generic_Unit_Kind => + Error_Msg_N + ("generic unit name cannot be used as operand", Enode); + + when Type_Kind => + Error_Msg_N + ("subtype name cannot be used as operand", Enode); + + when Entry_Kind => + Error_Msg_N + ("entry name cannot be used as operand", Enode); + + when E_Procedure => + Error_Msg_N + ("procedure name cannot be used as operand", Enode); + + when E_Exception => + Error_Msg_N + ("exception name cannot be used as operand", Enode); + + when E_Block | E_Label | E_Loop => + Error_Msg_N + ("label name cannot be used as operand", Enode); + + when others => + return False; + + end case; + + return True; + end Junk_Operand; + + -------------------- + -- Operator_Check -- + -------------------- + + procedure Operator_Check (N : Node_Id) is + begin + Remove_Abstract_Operations (N); + + -- Test for case of no interpretation found for operator + + if Etype (N) = Any_Type then + declare + L : Node_Id; + R : Node_Id; + Op_Id : Entity_Id := Empty; + + begin + R := Right_Opnd (N); + + if Nkind (N) in N_Binary_Op then + L := Left_Opnd (N); + else + L := Empty; + end if; + + -- If either operand has no type, then don't complain further, + -- since this simply means that we have a propagated error. + + if R = Error + or else Etype (R) = Any_Type + or else (Nkind (N) in N_Binary_Op and then Etype (L) = Any_Type) + then + return; + + -- We explicitly check for the case of concatenation of component + -- with component to avoid reporting spurious matching array types + -- that might happen to be lurking in distant packages (such as + -- run-time packages). This also prevents inconsistencies in the + -- messages for certain ACVC B tests, which can vary depending on + -- types declared in run-time interfaces. Another improvement when + -- aggregates are present is to look for a well-typed operand. + + elsif Present (Candidate_Type) + and then (Nkind (N) /= N_Op_Concat + or else Is_Array_Type (Etype (L)) + or else Is_Array_Type (Etype (R))) + then + if Nkind (N) = N_Op_Concat then + if Etype (L) /= Any_Composite + and then Is_Array_Type (Etype (L)) + then + Candidate_Type := Etype (L); + + elsif Etype (R) /= Any_Composite + and then Is_Array_Type (Etype (R)) + then + Candidate_Type := Etype (R); + end if; + end if; + + Error_Msg_NE -- CODEFIX + ("operator for} is not directly visible!", + N, First_Subtype (Candidate_Type)); + Error_Msg_N -- CODEFIX + ("use clause would make operation legal!", N); + return; + + -- If either operand is a junk operand (e.g. package name), then + -- post appropriate error messages, but do not complain further. + + -- Note that the use of OR in this test instead of OR ELSE is + -- quite deliberate, we may as well check both operands in the + -- binary operator case. + + elsif Junk_Operand (R) + or (Nkind (N) in N_Binary_Op and then Junk_Operand (L)) + then + return; + + -- If we have a logical operator, one of whose operands is + -- Boolean, then we know that the other operand cannot resolve to + -- Boolean (since we got no interpretations), but in that case we + -- pretty much know that the other operand should be Boolean, so + -- resolve it that way (generating an error) + + elsif Nkind_In (N, N_Op_And, N_Op_Or, N_Op_Xor) then + if Etype (L) = Standard_Boolean then + Resolve (R, Standard_Boolean); + return; + elsif Etype (R) = Standard_Boolean then + Resolve (L, Standard_Boolean); + return; + end if; + + -- For an arithmetic operator or comparison operator, if one + -- of the operands is numeric, then we know the other operand + -- is not the same numeric type. If it is a non-numeric type, + -- then probably it is intended to match the other operand. + + elsif Nkind_In (N, N_Op_Add, + N_Op_Divide, + N_Op_Ge, + N_Op_Gt, + N_Op_Le) + or else + Nkind_In (N, N_Op_Lt, + N_Op_Mod, + N_Op_Multiply, + N_Op_Rem, + N_Op_Subtract) + then + if Is_Numeric_Type (Etype (L)) + and then not Is_Numeric_Type (Etype (R)) + then + Resolve (R, Etype (L)); + return; + + elsif Is_Numeric_Type (Etype (R)) + and then not Is_Numeric_Type (Etype (L)) + then + Resolve (L, Etype (R)); + return; + end if; + + -- Comparisons on A'Access are common enough to deserve a + -- special message. + + elsif Nkind_In (N, N_Op_Eq, N_Op_Ne) + and then Ekind (Etype (L)) = E_Access_Attribute_Type + and then Ekind (Etype (R)) = E_Access_Attribute_Type + then + Error_Msg_N + ("two access attributes cannot be compared directly", N); + Error_Msg_N + ("\use qualified expression for one of the operands", + N); + return; + + -- Another one for C programmers + + elsif Nkind (N) = N_Op_Concat + and then Valid_Boolean_Arg (Etype (L)) + and then Valid_Boolean_Arg (Etype (R)) + then + Error_Msg_N ("invalid operands for concatenation", N); + Error_Msg_N -- CODEFIX + ("\maybe AND was meant", N); + return; + + -- A special case for comparison of access parameter with null + + elsif Nkind (N) = N_Op_Eq + and then Is_Entity_Name (L) + and then Nkind (Parent (Entity (L))) = N_Parameter_Specification + and then Nkind (Parameter_Type (Parent (Entity (L)))) = + N_Access_Definition + and then Nkind (R) = N_Null + then + Error_Msg_N ("access parameter is not allowed to be null", L); + Error_Msg_N ("\(call would raise Constraint_Error)", L); + return; + + -- Another special case for exponentiation, where the right + -- operand must be Natural, independently of the base. + + elsif Nkind (N) = N_Op_Expon + and then Is_Numeric_Type (Etype (L)) + and then not Is_Overloaded (R) + and then + First_Subtype (Base_Type (Etype (R))) /= Standard_Integer + and then Base_Type (Etype (R)) /= Universal_Integer + then + Error_Msg_NE + ("exponent must be of type Natural, found}", R, Etype (R)); + return; + end if; + + -- If we fall through then just give general message. Note that in + -- the following messages, if the operand is overloaded we choose + -- an arbitrary type to complain about, but that is probably more + -- useful than not giving a type at all. + + if Nkind (N) in N_Unary_Op then + Error_Msg_Node_2 := Etype (R); + Error_Msg_N ("operator& not defined for}", N); + return; + + else + if Nkind (N) in N_Binary_Op then + if not Is_Overloaded (L) + and then not Is_Overloaded (R) + and then Base_Type (Etype (L)) = Base_Type (Etype (R)) + then + Error_Msg_Node_2 := First_Subtype (Etype (R)); + Error_Msg_N ("there is no applicable operator& for}", N); + + else + -- Another attempt to find a fix: one of the candidate + -- interpretations may not be use-visible. This has + -- already been checked for predefined operators, so + -- we examine only user-defined functions. + + Op_Id := Get_Name_Entity_Id (Chars (N)); + + while Present (Op_Id) loop + if Ekind (Op_Id) /= E_Operator + and then Is_Overloadable (Op_Id) + then + if not Is_Immediately_Visible (Op_Id) + and then not In_Use (Scope (Op_Id)) + and then not Is_Abstract_Subprogram (Op_Id) + and then not Is_Hidden (Op_Id) + and then Ekind (Scope (Op_Id)) = E_Package + and then + Has_Compatible_Type + (L, Etype (First_Formal (Op_Id))) + and then Present + (Next_Formal (First_Formal (Op_Id))) + and then + Has_Compatible_Type + (R, + Etype (Next_Formal (First_Formal (Op_Id)))) + then + Error_Msg_N + ("No legal interpretation for operator&", N); + Error_Msg_NE + ("\use clause on& would make operation legal", + N, Scope (Op_Id)); + exit; + end if; + end if; + + Op_Id := Homonym (Op_Id); + end loop; + + if No (Op_Id) then + Error_Msg_N ("invalid operand types for operator&", N); + + if Nkind (N) /= N_Op_Concat then + Error_Msg_NE ("\left operand has}!", N, Etype (L)); + Error_Msg_NE ("\right operand has}!", N, Etype (R)); + end if; + end if; + end if; + end if; + end if; + end; + end if; + end Operator_Check; + + ----------------------------------------- + -- Process_Implicit_Dereference_Prefix -- + ----------------------------------------- + + function Process_Implicit_Dereference_Prefix + (E : Entity_Id; + P : Entity_Id) return Entity_Id + is + Ref : Node_Id; + Typ : constant Entity_Id := Designated_Type (Etype (P)); + + begin + if Present (E) + and then (Operating_Mode = Check_Semantics or else not Expander_Active) + then + -- We create a dummy reference to E to ensure that the reference + -- is not considered as part of an assignment (an implicit + -- dereference can never assign to its prefix). The Comes_From_Source + -- attribute needs to be propagated for accurate warnings. + + Ref := New_Reference_To (E, Sloc (P)); + Set_Comes_From_Source (Ref, Comes_From_Source (P)); + Generate_Reference (E, Ref); + end if; + + -- An implicit dereference is a legal occurrence of an + -- incomplete type imported through a limited_with clause, + -- if the full view is visible. + + if From_With_Type (Typ) + and then not From_With_Type (Scope (Typ)) + and then + (Is_Immediately_Visible (Scope (Typ)) + or else + (Is_Child_Unit (Scope (Typ)) + and then Is_Visible_Child_Unit (Scope (Typ)))) + then + return Available_View (Typ); + else + return Typ; + end if; + + end Process_Implicit_Dereference_Prefix; + + -------------------------------- + -- Remove_Abstract_Operations -- + -------------------------------- + + procedure Remove_Abstract_Operations (N : Node_Id) is + Abstract_Op : Entity_Id := Empty; + Address_Kludge : Boolean := False; + I : Interp_Index; + It : Interp; + + -- AI-310: If overloaded, remove abstract non-dispatching operations. We + -- activate this if either extensions are enabled, or if the abstract + -- operation in question comes from a predefined file. This latter test + -- allows us to use abstract to make operations invisible to users. In + -- particular, if type Address is non-private and abstract subprograms + -- are used to hide its operators, they will be truly hidden. + + type Operand_Position is (First_Op, Second_Op); + Univ_Type : constant Entity_Id := Universal_Interpretation (N); + + procedure Remove_Address_Interpretations (Op : Operand_Position); + -- Ambiguities may arise when the operands are literal and the address + -- operations in s-auxdec are visible. In that case, remove the + -- interpretation of a literal as Address, to retain the semantics of + -- Address as a private type. + + ------------------------------------ + -- Remove_Address_Interpretations -- + ------------------------------------ + + procedure Remove_Address_Interpretations (Op : Operand_Position) is + Formal : Entity_Id; + + begin + if Is_Overloaded (N) then + Get_First_Interp (N, I, It); + while Present (It.Nam) loop + Formal := First_Entity (It.Nam); + + if Op = Second_Op then + Formal := Next_Entity (Formal); + end if; + + if Is_Descendent_Of_Address (Etype (Formal)) then + Address_Kludge := True; + Remove_Interp (I); + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + end Remove_Address_Interpretations; + + -- Start of processing for Remove_Abstract_Operations + + begin + if Is_Overloaded (N) then + Get_First_Interp (N, I, It); + + while Present (It.Nam) loop + if Is_Overloadable (It.Nam) + and then Is_Abstract_Subprogram (It.Nam) + and then not Is_Dispatching_Operation (It.Nam) + then + Abstract_Op := It.Nam; + + if Is_Descendent_Of_Address (It.Typ) then + Address_Kludge := True; + Remove_Interp (I); + exit; + + -- In Ada 2005, this operation does not participate in Overload + -- resolution. If the operation is defined in a predefined + -- unit, it is one of the operations declared abstract in some + -- variants of System, and it must be removed as well. + + elsif Ada_Version >= Ada_2005 + or else Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (It.Nam))) + then + Remove_Interp (I); + exit; + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + + if No (Abstract_Op) then + + -- If some interpretation yields an integer type, it is still + -- possible that there are address interpretations. Remove them + -- if one operand is a literal, to avoid spurious ambiguities + -- on systems where Address is a visible integer type. + + if Is_Overloaded (N) + and then Nkind (N) in N_Op + and then Is_Integer_Type (Etype (N)) + then + if Nkind (N) in N_Binary_Op then + if Nkind (Right_Opnd (N)) = N_Integer_Literal then + Remove_Address_Interpretations (Second_Op); + + elsif Nkind (Right_Opnd (N)) = N_Integer_Literal then + Remove_Address_Interpretations (First_Op); + end if; + end if; + end if; + + elsif Nkind (N) in N_Op then + + -- Remove interpretations that treat literals as addresses. This + -- is never appropriate, even when Address is defined as a visible + -- Integer type. The reason is that we would really prefer Address + -- to behave as a private type, even in this case, which is there + -- only to accommodate oddities of VMS address sizes. If Address + -- is a visible integer type, we get lots of overload ambiguities. + + if Nkind (N) in N_Binary_Op then + declare + U1 : constant Boolean := + Present (Universal_Interpretation (Right_Opnd (N))); + U2 : constant Boolean := + Present (Universal_Interpretation (Left_Opnd (N))); + + begin + if U1 then + Remove_Address_Interpretations (Second_Op); + end if; + + if U2 then + Remove_Address_Interpretations (First_Op); + end if; + + if not (U1 and U2) then + + -- Remove corresponding predefined operator, which is + -- always added to the overload set. + + Get_First_Interp (N, I, It); + while Present (It.Nam) loop + if Scope (It.Nam) = Standard_Standard + and then Base_Type (It.Typ) = + Base_Type (Etype (Abstract_Op)) + then + Remove_Interp (I); + end if; + + Get_Next_Interp (I, It); + end loop; + + elsif Is_Overloaded (N) + and then Present (Univ_Type) + then + -- If both operands have a universal interpretation, + -- it is still necessary to remove interpretations that + -- yield Address. Any remaining ambiguities will be + -- removed in Disambiguate. + + Get_First_Interp (N, I, It); + while Present (It.Nam) loop + if Is_Descendent_Of_Address (It.Typ) then + Remove_Interp (I); + + elsif not Is_Type (It.Nam) then + Set_Entity (N, It.Nam); + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + end; + end if; + + elsif Nkind (N) = N_Function_Call + and then + (Nkind (Name (N)) = N_Operator_Symbol + or else + (Nkind (Name (N)) = N_Expanded_Name + and then + Nkind (Selector_Name (Name (N))) = N_Operator_Symbol)) + then + + declare + Arg1 : constant Node_Id := First (Parameter_Associations (N)); + U1 : constant Boolean := + Present (Universal_Interpretation (Arg1)); + U2 : constant Boolean := + Present (Next (Arg1)) and then + Present (Universal_Interpretation (Next (Arg1))); + + begin + if U1 then + Remove_Address_Interpretations (First_Op); + end if; + + if U2 then + Remove_Address_Interpretations (Second_Op); + end if; + + if not (U1 and U2) then + Get_First_Interp (N, I, It); + while Present (It.Nam) loop + if Scope (It.Nam) = Standard_Standard + and then It.Typ = Base_Type (Etype (Abstract_Op)) + then + Remove_Interp (I); + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + end; + end if; + + -- If the removal has left no valid interpretations, emit an error + -- message now and label node as illegal. + + if Present (Abstract_Op) then + Get_First_Interp (N, I, It); + + if No (It.Nam) then + + -- Removal of abstract operation left no viable candidate + + Set_Etype (N, Any_Type); + Error_Msg_Sloc := Sloc (Abstract_Op); + Error_Msg_NE + ("cannot call abstract operation& declared#", N, Abstract_Op); + + -- In Ada 2005, an abstract operation may disable predefined + -- operators. Since the context is not yet known, we mark the + -- predefined operators as potentially hidden. Do not include + -- predefined operators when addresses are involved since this + -- case is handled separately. + + elsif Ada_Version >= Ada_2005 + and then not Address_Kludge + then + while Present (It.Nam) loop + if Is_Numeric_Type (It.Typ) + and then Scope (It.Typ) = Standard_Standard + then + Set_Abstract_Op (I, Abstract_Op); + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + end if; + end if; + end Remove_Abstract_Operations; + + ----------------------- + -- Try_Indirect_Call -- + ----------------------- + + function Try_Indirect_Call + (N : Node_Id; + Nam : Entity_Id; + Typ : Entity_Id) return Boolean + is + Actual : Node_Id; + Formal : Entity_Id; + + Call_OK : Boolean; + pragma Warnings (Off, Call_OK); + + begin + Normalize_Actuals (N, Designated_Type (Typ), False, Call_OK); + + Actual := First_Actual (N); + Formal := First_Formal (Designated_Type (Typ)); + while Present (Actual) and then Present (Formal) loop + if not Has_Compatible_Type (Actual, Etype (Formal)) then + return False; + end if; + + Next (Actual); + Next_Formal (Formal); + end loop; + + if No (Actual) and then No (Formal) then + Add_One_Interp (N, Nam, Etype (Designated_Type (Typ))); + + -- Nam is a candidate interpretation for the name in the call, + -- if it is not an indirect call. + + if not Is_Type (Nam) + and then Is_Entity_Name (Name (N)) + then + Set_Entity (Name (N), Nam); + end if; + + return True; + else + return False; + end if; + end Try_Indirect_Call; + + ---------------------- + -- Try_Indexed_Call -- + ---------------------- + + function Try_Indexed_Call + (N : Node_Id; + Nam : Entity_Id; + Typ : Entity_Id; + Skip_First : Boolean) return Boolean + is + Loc : constant Source_Ptr := Sloc (N); + Actuals : constant List_Id := Parameter_Associations (N); + Actual : Node_Id; + Index : Entity_Id; + + begin + Actual := First (Actuals); + + -- If the call was originally written in prefix form, skip the first + -- actual, which is obviously not defaulted. + + if Skip_First then + Next (Actual); + end if; + + Index := First_Index (Typ); + while Present (Actual) and then Present (Index) loop + + -- If the parameter list has a named association, the expression + -- is definitely a call and not an indexed component. + + if Nkind (Actual) = N_Parameter_Association then + return False; + end if; + + if Is_Entity_Name (Actual) + and then Is_Type (Entity (Actual)) + and then No (Next (Actual)) + then + -- A single actual that is a type name indicates a slice if the + -- type is discrete, and an error otherwise. + + if Is_Discrete_Type (Entity (Actual)) then + Rewrite (N, + Make_Slice (Loc, + Prefix => + Make_Function_Call (Loc, + Name => Relocate_Node (Name (N))), + Discrete_Range => + New_Occurrence_Of (Entity (Actual), Sloc (Actual)))); + + Analyze (N); + + else + Error_Msg_N ("invalid use of type in expression", Actual); + Set_Etype (N, Any_Type); + end if; + + return True; + + elsif not Has_Compatible_Type (Actual, Etype (Index)) then + return False; + end if; + + Next (Actual); + Next_Index (Index); + end loop; + + if No (Actual) and then No (Index) then + Add_One_Interp (N, Nam, Component_Type (Typ)); + + -- Nam is a candidate interpretation for the name in the call, + -- if it is not an indirect call. + + if not Is_Type (Nam) + and then Is_Entity_Name (Name (N)) + then + Set_Entity (Name (N), Nam); + end if; + + return True; + else + return False; + end if; + end Try_Indexed_Call; + + -------------------------- + -- Try_Object_Operation -- + -------------------------- + + function Try_Object_Operation (N : Node_Id) return Boolean is + K : constant Node_Kind := Nkind (Parent (N)); + Is_Subprg_Call : constant Boolean := Nkind_In + (K, N_Procedure_Call_Statement, + N_Function_Call); + Loc : constant Source_Ptr := Sloc (N); + Obj : constant Node_Id := Prefix (N); + + Subprog : constant Node_Id := + Make_Identifier (Sloc (Selector_Name (N)), + Chars => Chars (Selector_Name (N))); + -- Identifier on which possible interpretations will be collected + + Report_Error : Boolean := False; + -- If no candidate interpretation matches the context, redo the + -- analysis with error enabled to provide additional information. + + Actual : Node_Id; + Candidate : Entity_Id := Empty; + New_Call_Node : Node_Id := Empty; + Node_To_Replace : Node_Id; + Obj_Type : Entity_Id := Etype (Obj); + Success : Boolean := False; + + function Valid_Candidate + (Success : Boolean; + Call : Node_Id; + Subp : Entity_Id) return Entity_Id; + -- If the subprogram is a valid interpretation, record it, and add + -- to the list of interpretations of Subprog. + + procedure Complete_Object_Operation + (Call_Node : Node_Id; + Node_To_Replace : Node_Id); + -- Make Subprog the name of Call_Node, replace Node_To_Replace with + -- Call_Node, insert the object (or its dereference) as the first actual + -- in the call, and complete the analysis of the call. + + procedure Report_Ambiguity (Op : Entity_Id); + -- If a prefixed procedure call is ambiguous, indicate whether the + -- call includes an implicit dereference or an implicit 'Access. + + procedure Transform_Object_Operation + (Call_Node : out Node_Id; + Node_To_Replace : out Node_Id); + -- Transform Obj.Operation (X, Y,,) into Operation (Obj, X, Y ..) + -- Call_Node is the resulting subprogram call, Node_To_Replace is + -- either N or the parent of N, and Subprog is a reference to the + -- subprogram we are trying to match. + + function Try_Class_Wide_Operation + (Call_Node : Node_Id; + Node_To_Replace : Node_Id) return Boolean; + -- Traverse all ancestor types looking for a class-wide subprogram + -- for which the current operation is a valid non-dispatching call. + + procedure Try_One_Prefix_Interpretation (T : Entity_Id); + -- If prefix is overloaded, its interpretation may include different + -- tagged types, and we must examine the primitive operations and + -- the class-wide operations of each in order to find candidate + -- interpretations for the call as a whole. + + function Try_Primitive_Operation + (Call_Node : Node_Id; + Node_To_Replace : Node_Id) return Boolean; + -- Traverse the list of primitive subprograms looking for a dispatching + -- operation for which the current node is a valid call . + + --------------------- + -- Valid_Candidate -- + --------------------- + + function Valid_Candidate + (Success : Boolean; + Call : Node_Id; + Subp : Entity_Id) return Entity_Id + is + Arr_Type : Entity_Id; + Comp_Type : Entity_Id; + + begin + -- If the subprogram is a valid interpretation, record it in global + -- variable Subprog, to collect all possible overloadings. + + if Success then + if Subp /= Entity (Subprog) then + Add_One_Interp (Subprog, Subp, Etype (Subp)); + end if; + end if; + + -- If the call may be an indexed call, retrieve component type of + -- resulting expression, and add possible interpretation. + + Arr_Type := Empty; + Comp_Type := Empty; + + if Nkind (Call) = N_Function_Call + and then Nkind (Parent (N)) = N_Indexed_Component + and then Needs_One_Actual (Subp) + then + if Is_Array_Type (Etype (Subp)) then + Arr_Type := Etype (Subp); + + elsif Is_Access_Type (Etype (Subp)) + and then Is_Array_Type (Designated_Type (Etype (Subp))) + then + Arr_Type := Designated_Type (Etype (Subp)); + end if; + end if; + + if Present (Arr_Type) then + + -- Verify that the actuals (excluding the object) match the types + -- of the indexes. + + declare + Actual : Node_Id; + Index : Node_Id; + + begin + Actual := Next (First_Actual (Call)); + Index := First_Index (Arr_Type); + while Present (Actual) and then Present (Index) loop + if not Has_Compatible_Type (Actual, Etype (Index)) then + Arr_Type := Empty; + exit; + end if; + + Next_Actual (Actual); + Next_Index (Index); + end loop; + + if No (Actual) + and then No (Index) + and then Present (Arr_Type) + then + Comp_Type := Component_Type (Arr_Type); + end if; + end; + + if Present (Comp_Type) + and then Etype (Subprog) /= Comp_Type + then + Add_One_Interp (Subprog, Subp, Comp_Type); + end if; + end if; + + if Etype (Call) /= Any_Type then + return Subp; + else + return Empty; + end if; + end Valid_Candidate; + + ------------------------------- + -- Complete_Object_Operation -- + ------------------------------- + + procedure Complete_Object_Operation + (Call_Node : Node_Id; + Node_To_Replace : Node_Id) + is + Control : constant Entity_Id := First_Formal (Entity (Subprog)); + Formal_Type : constant Entity_Id := Etype (Control); + First_Actual : Node_Id; + + begin + -- Place the name of the operation, with its interpretations, + -- on the rewritten call. + + Set_Name (Call_Node, Subprog); + + First_Actual := First (Parameter_Associations (Call_Node)); + + -- For cross-reference purposes, treat the new node as being in + -- the source if the original one is. + + Set_Comes_From_Source (Subprog, Comes_From_Source (N)); + Set_Comes_From_Source (Call_Node, Comes_From_Source (N)); + + if Nkind (N) = N_Selected_Component + and then not Inside_A_Generic + then + Set_Entity (Selector_Name (N), Entity (Subprog)); + end if; + + -- If need be, rewrite first actual as an explicit dereference + -- If the call is overloaded, the rewriting can only be done + -- once the primitive operation is identified. + + if Is_Overloaded (Subprog) then + + -- The prefix itself may be overloaded, and its interpretations + -- must be propagated to the new actual in the call. + + if Is_Overloaded (Obj) then + Save_Interps (Obj, First_Actual); + end if; + + Rewrite (First_Actual, Obj); + + elsif not Is_Access_Type (Formal_Type) + and then Is_Access_Type (Etype (Obj)) + then + Rewrite (First_Actual, + Make_Explicit_Dereference (Sloc (Obj), Obj)); + Analyze (First_Actual); + + -- If we need to introduce an explicit dereference, verify that + -- the resulting actual is compatible with the mode of the formal. + + if Ekind (First_Formal (Entity (Subprog))) /= E_In_Parameter + and then Is_Access_Constant (Etype (Obj)) + then + Error_Msg_NE + ("expect variable in call to&", Prefix (N), Entity (Subprog)); + end if; + + -- Conversely, if the formal is an access parameter and the object + -- is not, replace the actual with a 'Access reference. Its analysis + -- will check that the object is aliased. + + elsif Is_Access_Type (Formal_Type) + and then not Is_Access_Type (Etype (Obj)) + then + -- A special case: A.all'access is illegal if A is an access to a + -- constant and the context requires an access to a variable. + + if not Is_Access_Constant (Formal_Type) then + if (Nkind (Obj) = N_Explicit_Dereference + and then Is_Access_Constant (Etype (Prefix (Obj)))) + or else not Is_Variable (Obj) + then + Error_Msg_NE + ("actual for& must be a variable", Obj, Control); + end if; + end if; + + Rewrite (First_Actual, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Access, + Prefix => Relocate_Node (Obj))); + + if not Is_Aliased_View (Obj) then + Error_Msg_NE + ("object in prefixed call to& must be aliased" + & " (RM-2005 4.3.1 (13))", + Prefix (First_Actual), Subprog); + end if; + + Analyze (First_Actual); + + else + if Is_Overloaded (Obj) then + Save_Interps (Obj, First_Actual); + end if; + + Rewrite (First_Actual, Obj); + end if; + + Rewrite (Node_To_Replace, Call_Node); + + -- Propagate the interpretations collected in subprog to the new + -- function call node, to be resolved from context. + + if Is_Overloaded (Subprog) then + Save_Interps (Subprog, Node_To_Replace); + + else + Analyze (Node_To_Replace); + + -- If the operation has been rewritten into a call, which may get + -- subsequently an explicit dereference, preserve the type on the + -- original node (selected component or indexed component) for + -- subsequent legality tests, e.g. Is_Variable. which examines + -- the original node. + + if Nkind (Node_To_Replace) = N_Function_Call then + Set_Etype + (Original_Node (Node_To_Replace), Etype (Node_To_Replace)); + end if; + end if; + end Complete_Object_Operation; + + ---------------------- + -- Report_Ambiguity -- + ---------------------- + + procedure Report_Ambiguity (Op : Entity_Id) is + Access_Formal : constant Boolean := + Is_Access_Type (Etype (First_Formal (Op))); + Access_Actual : constant Boolean := + Is_Access_Type (Etype (Prefix (N))); + + begin + Error_Msg_Sloc := Sloc (Op); + + if Access_Formal and then not Access_Actual then + if Nkind (Parent (Op)) = N_Full_Type_Declaration then + Error_Msg_N + ("\possible interpretation" + & " (inherited, with implicit 'Access) #", N); + else + Error_Msg_N + ("\possible interpretation (with implicit 'Access) #", N); + end if; + + elsif not Access_Formal and then Access_Actual then + if Nkind (Parent (Op)) = N_Full_Type_Declaration then + Error_Msg_N + ("\possible interpretation" + & " ( inherited, with implicit dereference) #", N); + else + Error_Msg_N + ("\possible interpretation (with implicit dereference) #", N); + end if; + + else + if Nkind (Parent (Op)) = N_Full_Type_Declaration then + Error_Msg_N ("\possible interpretation (inherited)#", N); + else + Error_Msg_N -- CODEFIX + ("\possible interpretation#", N); + end if; + end if; + end Report_Ambiguity; + + -------------------------------- + -- Transform_Object_Operation -- + -------------------------------- + + procedure Transform_Object_Operation + (Call_Node : out Node_Id; + Node_To_Replace : out Node_Id) + is + Dummy : constant Node_Id := New_Copy (Obj); + -- Placeholder used as a first parameter in the call, replaced + -- eventually by the proper object. + + Parent_Node : constant Node_Id := Parent (N); + + Actual : Node_Id; + Actuals : List_Id; + + begin + -- Common case covering 1) Call to a procedure and 2) Call to a + -- function that has some additional actuals. + + if Nkind_In (Parent_Node, N_Function_Call, + N_Procedure_Call_Statement) + + -- N is a selected component node containing the name of the + -- subprogram. If N is not the name of the parent node we must + -- not replace the parent node by the new construct. This case + -- occurs when N is a parameterless call to a subprogram that + -- is an actual parameter of a call to another subprogram. For + -- example: + -- Some_Subprogram (..., Obj.Operation, ...) + + and then Name (Parent_Node) = N + then + Node_To_Replace := Parent_Node; + + Actuals := Parameter_Associations (Parent_Node); + + if Present (Actuals) then + Prepend (Dummy, Actuals); + else + Actuals := New_List (Dummy); + end if; + + if Nkind (Parent_Node) = N_Procedure_Call_Statement then + Call_Node := + Make_Procedure_Call_Statement (Loc, + Name => New_Copy (Subprog), + Parameter_Associations => Actuals); + + else + Call_Node := + Make_Function_Call (Loc, + Name => New_Copy (Subprog), + Parameter_Associations => Actuals); + + end if; + + -- Before analysis, a function call appears as an indexed component + -- if there are no named associations. + + elsif Nkind (Parent_Node) = N_Indexed_Component + and then N = Prefix (Parent_Node) + then + Node_To_Replace := Parent_Node; + Actuals := Expressions (Parent_Node); + + Actual := First (Actuals); + while Present (Actual) loop + Analyze (Actual); + Next (Actual); + end loop; + + Prepend (Dummy, Actuals); + + Call_Node := + Make_Function_Call (Loc, + Name => New_Copy (Subprog), + Parameter_Associations => Actuals); + + -- Parameterless call: Obj.F is rewritten as F (Obj) + + else + Node_To_Replace := N; + + Call_Node := + Make_Function_Call (Loc, + Name => New_Copy (Subprog), + Parameter_Associations => New_List (Dummy)); + end if; + end Transform_Object_Operation; + + ------------------------------ + -- Try_Class_Wide_Operation -- + ------------------------------ + + function Try_Class_Wide_Operation + (Call_Node : Node_Id; + Node_To_Replace : Node_Id) return Boolean + is + Anc_Type : Entity_Id; + Matching_Op : Entity_Id := Empty; + Error : Boolean; + + procedure Traverse_Homonyms + (Anc_Type : Entity_Id; + Error : out Boolean); + -- Traverse the homonym chain of the subprogram searching for those + -- homonyms whose first formal has the Anc_Type's class-wide type, + -- or an anonymous access type designating the class-wide type. If + -- an ambiguity is detected, then Error is set to True. + + procedure Traverse_Interfaces + (Anc_Type : Entity_Id; + Error : out Boolean); + -- Traverse the list of interfaces, if any, associated with Anc_Type + -- and search for acceptable class-wide homonyms associated with each + -- interface. If an ambiguity is detected, then Error is set to True. + + ----------------------- + -- Traverse_Homonyms -- + ----------------------- + + procedure Traverse_Homonyms + (Anc_Type : Entity_Id; + Error : out Boolean) + is + Cls_Type : Entity_Id; + Hom : Entity_Id; + Hom_Ref : Node_Id; + Success : Boolean; + + begin + Error := False; + + Cls_Type := Class_Wide_Type (Anc_Type); + + Hom := Current_Entity (Subprog); + + -- Find operation whose first parameter is of the class-wide + -- type, a subtype thereof, or an anonymous access to same. + + while Present (Hom) loop + if (Ekind (Hom) = E_Procedure + or else + Ekind (Hom) = E_Function) + and then Scope (Hom) = Scope (Anc_Type) + and then Present (First_Formal (Hom)) + and then + (Base_Type (Etype (First_Formal (Hom))) = Cls_Type + or else + (Is_Access_Type (Etype (First_Formal (Hom))) + and then + Ekind (Etype (First_Formal (Hom))) = + E_Anonymous_Access_Type + and then + Base_Type + (Designated_Type (Etype (First_Formal (Hom)))) = + Cls_Type)) + then + Set_Etype (Call_Node, Any_Type); + Set_Is_Overloaded (Call_Node, False); + Success := False; + + if No (Matching_Op) then + Hom_Ref := New_Reference_To (Hom, Sloc (Subprog)); + Set_Etype (Call_Node, Any_Type); + Set_Parent (Call_Node, Parent (Node_To_Replace)); + + Set_Name (Call_Node, Hom_Ref); + + Analyze_One_Call + (N => Call_Node, + Nam => Hom, + Report => Report_Error, + Success => Success, + Skip_First => True); + + Matching_Op := + Valid_Candidate (Success, Call_Node, Hom); + + else + Analyze_One_Call + (N => Call_Node, + Nam => Hom, + Report => Report_Error, + Success => Success, + Skip_First => True); + + if Present (Valid_Candidate (Success, Call_Node, Hom)) + and then Nkind (Call_Node) /= N_Function_Call + then + Error_Msg_NE ("ambiguous call to&", N, Hom); + Report_Ambiguity (Matching_Op); + Report_Ambiguity (Hom); + Error := True; + return; + end if; + end if; + end if; + + Hom := Homonym (Hom); + end loop; + end Traverse_Homonyms; + + ------------------------- + -- Traverse_Interfaces -- + ------------------------- + + procedure Traverse_Interfaces + (Anc_Type : Entity_Id; + Error : out Boolean) + is + Intface_List : constant List_Id := + Abstract_Interface_List (Anc_Type); + Intface : Node_Id; + + begin + Error := False; + + if Is_Non_Empty_List (Intface_List) then + Intface := First (Intface_List); + while Present (Intface) loop + + -- Look for acceptable class-wide homonyms associated with + -- the interface. + + Traverse_Homonyms (Etype (Intface), Error); + + if Error then + return; + end if; + + -- Continue the search by looking at each of the interface's + -- associated interface ancestors. + + Traverse_Interfaces (Etype (Intface), Error); + + if Error then + return; + end if; + + Next (Intface); + end loop; + end if; + end Traverse_Interfaces; + + -- Start of processing for Try_Class_Wide_Operation + + begin + -- Loop through ancestor types (including interfaces), traversing + -- the homonym chain of the subprogram, trying out those homonyms + -- whose first formal has the class-wide type of the ancestor, or + -- an anonymous access type designating the class-wide type. + + Anc_Type := Obj_Type; + loop + -- Look for a match among homonyms associated with the ancestor + + Traverse_Homonyms (Anc_Type, Error); + + if Error then + return True; + end if; + + -- Continue the search for matches among homonyms associated with + -- any interfaces implemented by the ancestor. + + Traverse_Interfaces (Anc_Type, Error); + + if Error then + return True; + end if; + + exit when Etype (Anc_Type) = Anc_Type; + Anc_Type := Etype (Anc_Type); + end loop; + + if Present (Matching_Op) then + Set_Etype (Call_Node, Etype (Matching_Op)); + end if; + + return Present (Matching_Op); + end Try_Class_Wide_Operation; + + ----------------------------------- + -- Try_One_Prefix_Interpretation -- + ----------------------------------- + + procedure Try_One_Prefix_Interpretation (T : Entity_Id) is + begin + Obj_Type := T; + + if Is_Access_Type (Obj_Type) then + Obj_Type := Designated_Type (Obj_Type); + end if; + + if Ekind (Obj_Type) = E_Private_Subtype then + Obj_Type := Base_Type (Obj_Type); + end if; + + if Is_Class_Wide_Type (Obj_Type) then + Obj_Type := Etype (Class_Wide_Type (Obj_Type)); + end if; + + -- The type may have be obtained through a limited_with clause, + -- in which case the primitive operations are available on its + -- non-limited view. If still incomplete, retrieve full view. + + if Ekind (Obj_Type) = E_Incomplete_Type + and then From_With_Type (Obj_Type) + then + Obj_Type := Get_Full_View (Non_Limited_View (Obj_Type)); + end if; + + -- If the object is not tagged, or the type is still an incomplete + -- type, this is not a prefixed call. + + if not Is_Tagged_Type (Obj_Type) + or else Is_Incomplete_Type (Obj_Type) + then + return; + end if; + + if Try_Primitive_Operation + (Call_Node => New_Call_Node, + Node_To_Replace => Node_To_Replace) + or else + Try_Class_Wide_Operation + (Call_Node => New_Call_Node, + Node_To_Replace => Node_To_Replace) + then + null; + end if; + end Try_One_Prefix_Interpretation; + + ----------------------------- + -- Try_Primitive_Operation -- + ----------------------------- + + function Try_Primitive_Operation + (Call_Node : Node_Id; + Node_To_Replace : Node_Id) return Boolean + is + Elmt : Elmt_Id; + Prim_Op : Entity_Id; + Matching_Op : Entity_Id := Empty; + Prim_Op_Ref : Node_Id := Empty; + + Corr_Type : Entity_Id := Empty; + -- If the prefix is a synchronized type, the controlling type of + -- the primitive operation is the corresponding record type, else + -- this is the object type itself. + + Success : Boolean := False; + + function Collect_Generic_Type_Ops (T : Entity_Id) return Elist_Id; + -- For tagged types the candidate interpretations are found in + -- the list of primitive operations of the type and its ancestors. + -- For formal tagged types we have to find the operations declared + -- in the same scope as the type (including in the generic formal + -- part) because the type itself carries no primitive operations, + -- except for formal derived types that inherit the operations of + -- the parent and progenitors. + -- If the context is a generic subprogram body, the generic formals + -- are visible by name, but are not in the entity list of the + -- subprogram because that list starts with the subprogram formals. + -- We retrieve the candidate operations from the generic declaration. + + function Is_Private_Overriding (Op : Entity_Id) return Boolean; + -- An operation that overrides an inherited operation in the private + -- part of its package may be hidden, but if the inherited operation + -- is visible a direct call to it will dispatch to the private one, + -- which is therefore a valid candidate. + + function Valid_First_Argument_Of (Op : Entity_Id) return Boolean; + -- Verify that the prefix, dereferenced if need be, is a valid + -- controlling argument in a call to Op. The remaining actuals + -- are checked in the subsequent call to Analyze_One_Call. + + ------------------------------ + -- Collect_Generic_Type_Ops -- + ------------------------------ + + function Collect_Generic_Type_Ops (T : Entity_Id) return Elist_Id is + Bas : constant Entity_Id := Base_Type (T); + Candidates : constant Elist_Id := New_Elmt_List; + Subp : Entity_Id; + Formal : Entity_Id; + + procedure Check_Candidate; + -- The operation is a candidate if its first parameter is a + -- controlling operand of the desired type. + + ----------------------- + -- Check_Candidate; -- + ----------------------- + + procedure Check_Candidate is + begin + Formal := First_Formal (Subp); + + if Present (Formal) + and then Is_Controlling_Formal (Formal) + and then + (Base_Type (Etype (Formal)) = Bas + or else + (Is_Access_Type (Etype (Formal)) + and then Designated_Type (Etype (Formal)) = Bas)) + then + Append_Elmt (Subp, Candidates); + end if; + end Check_Candidate; + + -- Start of processing for Collect_Generic_Type_Ops + + begin + if Is_Derived_Type (T) then + return Primitive_Operations (T); + + elsif Ekind_In (Scope (T), E_Procedure, E_Function) then + + -- Scan the list of generic formals to find subprograms + -- that may have a first controlling formal of the type. + + if Nkind (Unit_Declaration_Node (Scope (T))) + = N_Generic_Subprogram_Declaration + then + declare + Decl : Node_Id; + + begin + Decl := + First (Generic_Formal_Declarations + (Unit_Declaration_Node (Scope (T)))); + while Present (Decl) loop + if Nkind (Decl) in N_Formal_Subprogram_Declaration then + Subp := Defining_Entity (Decl); + Check_Candidate; + end if; + + Next (Decl); + end loop; + end; + end if; + return Candidates; + + else + -- Scan the list of entities declared in the same scope as + -- the type. In general this will be an open scope, given that + -- the call we are analyzing can only appear within a generic + -- declaration or body (either the one that declares T, or a + -- child unit). + + -- For a subtype representing a generic actual type, go to the + -- base type. + + if Is_Generic_Actual_Type (T) then + Subp := First_Entity (Scope (Base_Type (T))); + else + Subp := First_Entity (Scope (T)); + end if; + + while Present (Subp) loop + if Is_Overloadable (Subp) then + Check_Candidate; + end if; + + Next_Entity (Subp); + end loop; + + return Candidates; + end if; + end Collect_Generic_Type_Ops; + + --------------------------- + -- Is_Private_Overriding -- + --------------------------- + + function Is_Private_Overriding (Op : Entity_Id) return Boolean is + Visible_Op : constant Entity_Id := Homonym (Op); + + begin + return Present (Visible_Op) + and then Scope (Op) = Scope (Visible_Op) + and then not Comes_From_Source (Visible_Op) + and then Alias (Visible_Op) = Op + and then not Is_Hidden (Visible_Op); + end Is_Private_Overriding; + + ----------------------------- + -- Valid_First_Argument_Of -- + ----------------------------- + + function Valid_First_Argument_Of (Op : Entity_Id) return Boolean is + Typ : Entity_Id := Etype (First_Formal (Op)); + + begin + if Is_Concurrent_Type (Typ) + and then Present (Corresponding_Record_Type (Typ)) + then + Typ := Corresponding_Record_Type (Typ); + end if; + + -- Simple case. Object may be a subtype of the tagged type or + -- may be the corresponding record of a synchronized type. + + return Obj_Type = Typ + or else Base_Type (Obj_Type) = Typ + or else Corr_Type = Typ + + -- Prefix can be dereferenced + + or else + (Is_Access_Type (Corr_Type) + and then Designated_Type (Corr_Type) = Typ) + + -- Formal is an access parameter, for which the object + -- can provide an access. + + or else + (Ekind (Typ) = E_Anonymous_Access_Type + and then Designated_Type (Typ) = Base_Type (Corr_Type)); + end Valid_First_Argument_Of; + + -- Start of processing for Try_Primitive_Operation + + begin + -- Look for subprograms in the list of primitive operations. The name + -- must be identical, and the kind of call indicates the expected + -- kind of operation (function or procedure). If the type is a + -- (tagged) synchronized type, the primitive ops are attached to the + -- corresponding record (base) type. + + if Is_Concurrent_Type (Obj_Type) then + if Present (Corresponding_Record_Type (Obj_Type)) then + Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type)); + Elmt := First_Elmt (Primitive_Operations (Corr_Type)); + else + Corr_Type := Obj_Type; + Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type)); + end if; + + elsif not Is_Generic_Type (Obj_Type) then + Corr_Type := Obj_Type; + Elmt := First_Elmt (Primitive_Operations (Obj_Type)); + + else + Corr_Type := Obj_Type; + Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type)); + end if; + + while Present (Elmt) loop + Prim_Op := Node (Elmt); + + if Chars (Prim_Op) = Chars (Subprog) + and then Present (First_Formal (Prim_Op)) + and then Valid_First_Argument_Of (Prim_Op) + and then + (Nkind (Call_Node) = N_Function_Call) + = (Ekind (Prim_Op) = E_Function) + then + -- Ada 2005 (AI-251): If this primitive operation corresponds + -- with an immediate ancestor interface there is no need to add + -- it to the list of interpretations; the corresponding aliased + -- primitive is also in this list of primitive operations and + -- will be used instead. + + if (Present (Interface_Alias (Prim_Op)) + and then Is_Ancestor (Find_Dispatching_Type + (Alias (Prim_Op)), Corr_Type)) + + -- Do not consider hidden primitives unless the type is in an + -- open scope or we are within an instance, where visibility + -- is known to be correct, or else if this is an overriding + -- operation in the private part for an inherited operation. + + or else (Is_Hidden (Prim_Op) + and then not Is_Immediately_Visible (Obj_Type) + and then not In_Instance + and then not Is_Private_Overriding (Prim_Op)) + then + goto Continue; + end if; + + Set_Etype (Call_Node, Any_Type); + Set_Is_Overloaded (Call_Node, False); + + if No (Matching_Op) then + Prim_Op_Ref := New_Reference_To (Prim_Op, Sloc (Subprog)); + Candidate := Prim_Op; + + Set_Parent (Call_Node, Parent (Node_To_Replace)); + + Set_Name (Call_Node, Prim_Op_Ref); + Success := False; + + Analyze_One_Call + (N => Call_Node, + Nam => Prim_Op, + Report => Report_Error, + Success => Success, + Skip_First => True); + + Matching_Op := Valid_Candidate (Success, Call_Node, Prim_Op); + + -- More than one interpretation, collect for subsequent + -- disambiguation. If this is a procedure call and there + -- is another match, report ambiguity now. + + else + Analyze_One_Call + (N => Call_Node, + Nam => Prim_Op, + Report => Report_Error, + Success => Success, + Skip_First => True); + + if Present (Valid_Candidate (Success, Call_Node, Prim_Op)) + and then Nkind (Call_Node) /= N_Function_Call + then + Error_Msg_NE ("ambiguous call to&", N, Prim_Op); + Report_Ambiguity (Matching_Op); + Report_Ambiguity (Prim_Op); + return True; + end if; + end if; + end if; + + <> + Next_Elmt (Elmt); + end loop; + + if Present (Matching_Op) then + Set_Etype (Call_Node, Etype (Matching_Op)); + end if; + + return Present (Matching_Op); + end Try_Primitive_Operation; + + -- Start of processing for Try_Object_Operation + + begin + Analyze_Expression (Obj); + + -- Analyze the actuals if node is known to be a subprogram call + + if Is_Subprg_Call and then N = Name (Parent (N)) then + Actual := First (Parameter_Associations (Parent (N))); + while Present (Actual) loop + Analyze_Expression (Actual); + Next (Actual); + end loop; + end if; + + -- Build a subprogram call node, using a copy of Obj as its first + -- actual. This is a placeholder, to be replaced by an explicit + -- dereference when needed. + + Transform_Object_Operation + (Call_Node => New_Call_Node, + Node_To_Replace => Node_To_Replace); + + Set_Etype (New_Call_Node, Any_Type); + Set_Etype (Subprog, Any_Type); + Set_Parent (New_Call_Node, Parent (Node_To_Replace)); + + if not Is_Overloaded (Obj) then + Try_One_Prefix_Interpretation (Obj_Type); + + else + declare + I : Interp_Index; + It : Interp; + begin + Get_First_Interp (Obj, I, It); + while Present (It.Nam) loop + Try_One_Prefix_Interpretation (It.Typ); + Get_Next_Interp (I, It); + end loop; + end; + end if; + + if Etype (New_Call_Node) /= Any_Type then + Complete_Object_Operation + (Call_Node => New_Call_Node, + Node_To_Replace => Node_To_Replace); + return True; + + elsif Present (Candidate) then + + -- The argument list is not type correct. Re-analyze with error + -- reporting enabled, and use one of the possible candidates. + -- In All_Errors_Mode, re-analyze all failed interpretations. + + if All_Errors_Mode then + Report_Error := True; + if Try_Primitive_Operation + (Call_Node => New_Call_Node, + Node_To_Replace => Node_To_Replace) + + or else + Try_Class_Wide_Operation + (Call_Node => New_Call_Node, + Node_To_Replace => Node_To_Replace) + then + null; + end if; + + else + Analyze_One_Call + (N => New_Call_Node, + Nam => Candidate, + Report => True, + Success => Success, + Skip_First => True); + end if; + + -- No need for further errors + + return True; + + else + -- There was no candidate operation, so report it as an error + -- in the caller: Analyze_Selected_Component. + + return False; + end if; + end Try_Object_Operation; + + --------- + -- wpo -- + --------- + + procedure wpo (T : Entity_Id) is + Op : Entity_Id; + E : Elmt_Id; + + begin + if not Is_Tagged_Type (T) then + return; + end if; + + E := First_Elmt (Primitive_Operations (Base_Type (T))); + while Present (E) loop + Op := Node (E); + Write_Int (Int (Op)); + Write_Str (" === "); + Write_Name (Chars (Op)); + Write_Str (" in "); + Write_Name (Chars (Scope (Op))); + Next_Elmt (E); + Write_Eol; + end loop; + end wpo; + +end Sem_Ch4; diff --git a/gcc/ada/sem_ch4.ads b/gcc/ada/sem_ch4.ads new file mode 100644 index 000000000..4f9554589 --- /dev/null +++ b/gcc/ada/sem_ch4.ads @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 4 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Types; use Types; + +package Sem_Ch4 is + procedure Analyze_Aggregate (N : Node_Id); + procedure Analyze_Allocator (N : Node_Id); + procedure Analyze_Arithmetic_Op (N : Node_Id); + procedure Analyze_Call (N : Node_Id); + procedure Analyze_Case_Expression (N : Node_Id); + procedure Analyze_Comparison_Op (N : Node_Id); + procedure Analyze_Concatenation (N : Node_Id); + procedure Analyze_Conditional_Expression (N : Node_Id); + procedure Analyze_Equality_Op (N : Node_Id); + procedure Analyze_Explicit_Dereference (N : Node_Id); + procedure Analyze_Expression_With_Actions (N : Node_Id); + procedure Analyze_Logical_Op (N : Node_Id); + procedure Analyze_Membership_Op (N : Node_Id); + procedure Analyze_Negation (N : Node_Id); + procedure Analyze_Null (N : Node_Id); + procedure Analyze_Qualified_Expression (N : Node_Id); + procedure Analyze_Quantified_Expression (N : Node_Id); + procedure Analyze_Range (N : Node_Id); + procedure Analyze_Reference (N : Node_Id); + procedure Analyze_Selected_Component (N : Node_Id); + procedure Analyze_Short_Circuit (N : Node_Id); + procedure Analyze_Slice (N : Node_Id); + procedure Analyze_Type_Conversion (N : Node_Id); + procedure Analyze_Unary_Op (N : Node_Id); + procedure Analyze_Unchecked_Expression (N : Node_Id); + procedure Analyze_Unchecked_Type_Conversion (N : Node_Id); + + procedure Analyze_Indexed_Component_Form (N : Node_Id); + -- Prior to semantic analysis, an indexed component node can denote any + -- of the following syntactic constructs: + -- a) An indexed component of an array + -- b) A function call + -- c) A conversion + -- d) A slice + -- The resolution of the construct requires some semantic information + -- on the prefix and the indexes. + +end Sem_Ch4; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb new file mode 100644 index 000000000..68305d6e8 --- /dev/null +++ b/gcc/ada/sem_ch5.adb @@ -0,0 +1,2402 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 5 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Einfo; use Einfo; +with Errout; use Errout; +with Expander; use Expander; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Lib; use Lib; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Case; use Sem_Case; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch8; use Sem_Ch8; +with Sem_Disp; use Sem_Disp; +with Sem_Elab; use Sem_Elab; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Snames; use Snames; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +package body Sem_Ch5 is + + Unblocked_Exit_Count : Nat := 0; + -- This variable is used when processing if statements, case statements, + -- and block statements. It counts the number of exit points that are not + -- blocked by unconditional transfer instructions: for IF and CASE, these + -- are the branches of the conditional; for a block, they are the statement + -- sequence of the block, and the statement sequences of any exception + -- handlers that are part of the block. When processing is complete, if + -- this count is zero, it means that control cannot fall through the IF, + -- CASE or block statement. This is used for the generation of warning + -- messages. This variable is recursively saved on entry to processing the + -- construct, and restored on exit. + + ------------------------ + -- Analyze_Assignment -- + ------------------------ + + procedure Analyze_Assignment (N : Node_Id) is + Lhs : constant Node_Id := Name (N); + Rhs : constant Node_Id := Expression (N); + T1 : Entity_Id; + T2 : Entity_Id; + Decl : Node_Id; + + procedure Diagnose_Non_Variable_Lhs (N : Node_Id); + -- N is the node for the left hand side of an assignment, and it is not + -- a variable. This routine issues an appropriate diagnostic. + + procedure Kill_Lhs; + -- This is called to kill current value settings of a simple variable + -- on the left hand side. We call it if we find any error in analyzing + -- the assignment, and at the end of processing before setting any new + -- current values in place. + + procedure Set_Assignment_Type + (Opnd : Node_Id; + Opnd_Type : in out Entity_Id); + -- Opnd is either the Lhs or Rhs of the assignment, and Opnd_Type + -- is the nominal subtype. This procedure is used to deal with cases + -- where the nominal subtype must be replaced by the actual subtype. + + ------------------------------- + -- Diagnose_Non_Variable_Lhs -- + ------------------------------- + + procedure Diagnose_Non_Variable_Lhs (N : Node_Id) is + begin + -- Not worth posting another error if left hand side already + -- flagged as being illegal in some respect. + + if Error_Posted (N) then + return; + + -- Some special bad cases of entity names + + elsif Is_Entity_Name (N) then + declare + Ent : constant Entity_Id := Entity (N); + + begin + if Ekind (Ent) = E_In_Parameter then + Error_Msg_N + ("assignment to IN mode parameter not allowed", N); + + -- Renamings of protected private components are turned into + -- constants when compiling a protected function. In the case + -- of single protected types, the private component appears + -- directly. + + elsif (Is_Prival (Ent) + and then + (Ekind (Current_Scope) = E_Function + or else Ekind (Enclosing_Dynamic_Scope ( + Current_Scope)) = E_Function)) + or else + (Ekind (Ent) = E_Component + and then Is_Protected_Type (Scope (Ent))) + then + Error_Msg_N + ("protected function cannot modify protected object", N); + + elsif Ekind (Ent) = E_Loop_Parameter then + Error_Msg_N + ("assignment to loop parameter not allowed", N); + + else + Error_Msg_N + ("left hand side of assignment must be a variable", N); + end if; + end; + + -- For indexed components or selected components, test prefix + + elsif Nkind (N) = N_Indexed_Component then + Diagnose_Non_Variable_Lhs (Prefix (N)); + + -- Another special case for assignment to discriminant + + elsif Nkind (N) = N_Selected_Component then + if Present (Entity (Selector_Name (N))) + and then Ekind (Entity (Selector_Name (N))) = E_Discriminant + then + Error_Msg_N + ("assignment to discriminant not allowed", N); + else + Diagnose_Non_Variable_Lhs (Prefix (N)); + end if; + + else + -- If we fall through, we have no special message to issue! + + Error_Msg_N ("left hand side of assignment must be a variable", N); + end if; + end Diagnose_Non_Variable_Lhs; + + -------------- + -- Kill_LHS -- + -------------- + + procedure Kill_Lhs is + begin + if Is_Entity_Name (Lhs) then + declare + Ent : constant Entity_Id := Entity (Lhs); + begin + if Present (Ent) then + Kill_Current_Values (Ent); + end if; + end; + end if; + end Kill_Lhs; + + ------------------------- + -- Set_Assignment_Type -- + ------------------------- + + procedure Set_Assignment_Type + (Opnd : Node_Id; + Opnd_Type : in out Entity_Id) + is + begin + Require_Entity (Opnd); + + -- If the assignment operand is an in-out or out parameter, then we + -- get the actual subtype (needed for the unconstrained case). + -- If the operand is the actual in an entry declaration, then within + -- the accept statement it is replaced with a local renaming, which + -- may also have an actual subtype. + + if Is_Entity_Name (Opnd) + and then (Ekind (Entity (Opnd)) = E_Out_Parameter + or else Ekind (Entity (Opnd)) = + E_In_Out_Parameter + or else Ekind (Entity (Opnd)) = + E_Generic_In_Out_Parameter + or else + (Ekind (Entity (Opnd)) = E_Variable + and then Nkind (Parent (Entity (Opnd))) = + N_Object_Renaming_Declaration + and then Nkind (Parent (Parent (Entity (Opnd)))) = + N_Accept_Statement)) + then + Opnd_Type := Get_Actual_Subtype (Opnd); + + -- If assignment operand is a component reference, then we get the + -- actual subtype of the component for the unconstrained case. + + elsif Nkind_In (Opnd, N_Selected_Component, N_Explicit_Dereference) + and then not Is_Unchecked_Union (Opnd_Type) + then + Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd); + + if Present (Decl) then + Insert_Action (N, Decl); + Mark_Rewrite_Insertion (Decl); + Analyze (Decl); + Opnd_Type := Defining_Identifier (Decl); + Set_Etype (Opnd, Opnd_Type); + Freeze_Itype (Opnd_Type, N); + + elsif Is_Constrained (Etype (Opnd)) then + Opnd_Type := Etype (Opnd); + end if; + + -- For slice, use the constrained subtype created for the slice + + elsif Nkind (Opnd) = N_Slice then + Opnd_Type := Etype (Opnd); + end if; + end Set_Assignment_Type; + + -- Start of processing for Analyze_Assignment + + begin + Mark_Coextensions (N, Rhs); + + Analyze (Rhs); + Analyze (Lhs); + + -- Start type analysis for assignment + + T1 := Etype (Lhs); + + -- In the most general case, both Lhs and Rhs can be overloaded, and we + -- must compute the intersection of the possible types on each side. + + if Is_Overloaded (Lhs) then + declare + I : Interp_Index; + It : Interp; + + begin + T1 := Any_Type; + Get_First_Interp (Lhs, I, It); + + while Present (It.Typ) loop + if Has_Compatible_Type (Rhs, It.Typ) then + if T1 /= Any_Type then + + -- An explicit dereference is overloaded if the prefix + -- is. Try to remove the ambiguity on the prefix, the + -- error will be posted there if the ambiguity is real. + + if Nkind (Lhs) = N_Explicit_Dereference then + declare + PI : Interp_Index; + PI1 : Interp_Index := 0; + PIt : Interp; + Found : Boolean; + + begin + Found := False; + Get_First_Interp (Prefix (Lhs), PI, PIt); + + while Present (PIt.Typ) loop + if Is_Access_Type (PIt.Typ) + and then Has_Compatible_Type + (Rhs, Designated_Type (PIt.Typ)) + then + if Found then + PIt := + Disambiguate (Prefix (Lhs), + PI1, PI, Any_Type); + + if PIt = No_Interp then + Error_Msg_N + ("ambiguous left-hand side" + & " in assignment", Lhs); + exit; + else + Resolve (Prefix (Lhs), PIt.Typ); + end if; + + exit; + else + Found := True; + PI1 := PI; + end if; + end if; + + Get_Next_Interp (PI, PIt); + end loop; + end; + + else + Error_Msg_N + ("ambiguous left-hand side in assignment", Lhs); + exit; + end if; + else + T1 := It.Typ; + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + end; + + if T1 = Any_Type then + Error_Msg_N + ("no valid types for left-hand side for assignment", Lhs); + Kill_Lhs; + return; + end if; + end if; + + -- The resulting assignment type is T1, so now we will resolve the + -- left hand side of the assignment using this determined type. + + Resolve (Lhs, T1); + + -- Cases where Lhs is not a variable + + if not Is_Variable (Lhs) then + + -- Ada 2005 (AI-327): Check assignment to the attribute Priority of + -- a protected object. + + declare + Ent : Entity_Id; + S : Entity_Id; + + begin + if Ada_Version >= Ada_2005 then + + -- Handle chains of renamings + + Ent := Lhs; + while Nkind (Ent) in N_Has_Entity + and then Present (Entity (Ent)) + and then Present (Renamed_Object (Entity (Ent))) + loop + Ent := Renamed_Object (Entity (Ent)); + end loop; + + if (Nkind (Ent) = N_Attribute_Reference + and then Attribute_Name (Ent) = Name_Priority) + + -- Renamings of the attribute Priority applied to protected + -- objects have been previously expanded into calls to the + -- Get_Ceiling run-time subprogram. + + or else + (Nkind (Ent) = N_Function_Call + and then (Entity (Name (Ent)) = RTE (RE_Get_Ceiling) + or else + Entity (Name (Ent)) = RTE (RO_PE_Get_Ceiling))) + then + -- The enclosing subprogram cannot be a protected function + + S := Current_Scope; + while not (Is_Subprogram (S) + and then Convention (S) = Convention_Protected) + and then S /= Standard_Standard + loop + S := Scope (S); + end loop; + + if Ekind (S) = E_Function + and then Convention (S) = Convention_Protected + then + Error_Msg_N + ("protected function cannot modify protected object", + Lhs); + end if; + + -- Changes of the ceiling priority of the protected object + -- are only effective if the Ceiling_Locking policy is in + -- effect (AARM D.5.2 (5/2)). + + if Locking_Policy /= 'C' then + Error_Msg_N ("assignment to the attribute PRIORITY has " & + "no effect?", Lhs); + Error_Msg_N ("\since no Locking_Policy has been " & + "specified", Lhs); + end if; + + return; + end if; + end if; + end; + + Diagnose_Non_Variable_Lhs (Lhs); + return; + + -- Error of assigning to limited type. We do however allow this in + -- certain cases where the front end generates the assignments. + + elsif Is_Limited_Type (T1) + and then not Assignment_OK (Lhs) + and then not Assignment_OK (Original_Node (Lhs)) + and then not Is_Value_Type (T1) + then + -- CPP constructors can only be called in declarations + + if Is_CPP_Constructor_Call (Rhs) then + Error_Msg_N ("invalid use of 'C'P'P constructor", Rhs); + else + Error_Msg_N + ("left hand of assignment must not be limited type", Lhs); + Explain_Limited_Type (T1, Lhs); + end if; + return; + + -- Enforce RM 3.9.3 (8): the target of an assignment operation cannot be + -- abstract. This is only checked when the assignment Comes_From_Source, + -- because in some cases the expander generates such assignments (such + -- in the _assign operation for an abstract type). + + elsif Is_Abstract_Type (T1) and then Comes_From_Source (N) then + Error_Msg_N + ("target of assignment operation must not be abstract", Lhs); + end if; + + -- Resolution may have updated the subtype, in case the left-hand + -- side is a private protected component. Use the correct subtype + -- to avoid scoping issues in the back-end. + + T1 := Etype (Lhs); + + -- Ada 2005 (AI-50217, AI-326): Check wrong dereference of incomplete + -- type. For example: + + -- limited with P; + -- package Pkg is + -- type Acc is access P.T; + -- end Pkg; + + -- with Pkg; use Acc; + -- procedure Example is + -- A, B : Acc; + -- begin + -- A.all := B.all; -- ERROR + -- end Example; + + if Nkind (Lhs) = N_Explicit_Dereference + and then Ekind (T1) = E_Incomplete_Type + then + Error_Msg_N ("invalid use of incomplete type", Lhs); + Kill_Lhs; + return; + end if; + + -- Now we can complete the resolution of the right hand side + + Set_Assignment_Type (Lhs, T1); + Resolve (Rhs, T1); + + -- This is the point at which we check for an unset reference + + Check_Unset_Reference (Rhs); + Check_Unprotected_Access (Lhs, Rhs); + + -- Remaining steps are skipped if Rhs was syntactically in error + + if Rhs = Error then + Kill_Lhs; + return; + end if; + + T2 := Etype (Rhs); + + if not Covers (T1, T2) then + Wrong_Type (Rhs, Etype (Lhs)); + Kill_Lhs; + return; + end if; + + -- Ada 2005 (AI-326): In case of explicit dereference of incomplete + -- types, use the non-limited view if available + + if Nkind (Rhs) = N_Explicit_Dereference + and then Ekind (T2) = E_Incomplete_Type + and then Is_Tagged_Type (T2) + and then Present (Non_Limited_View (T2)) + then + T2 := Non_Limited_View (T2); + end if; + + Set_Assignment_Type (Rhs, T2); + + if Total_Errors_Detected /= 0 then + if No (T1) then + T1 := Any_Type; + end if; + + if No (T2) then + T2 := Any_Type; + end if; + end if; + + if T1 = Any_Type or else T2 = Any_Type then + Kill_Lhs; + return; + end if; + + -- If the rhs is class-wide or dynamically tagged, then require the lhs + -- to be class-wide. The case where the rhs is a dynamically tagged call + -- to a dispatching operation with a controlling access result is + -- excluded from this check, since the target has an access type (and + -- no tag propagation occurs in that case). + + if (Is_Class_Wide_Type (T2) + or else (Is_Dynamically_Tagged (Rhs) + and then not Is_Access_Type (T1))) + and then not Is_Class_Wide_Type (T1) + then + Error_Msg_N ("dynamically tagged expression not allowed!", Rhs); + + elsif Is_Class_Wide_Type (T1) + and then not Is_Class_Wide_Type (T2) + and then not Is_Tag_Indeterminate (Rhs) + and then not Is_Dynamically_Tagged (Rhs) + then + Error_Msg_N ("dynamically tagged expression required!", Rhs); + end if; + + -- Propagate the tag from a class-wide target to the rhs when the rhs + -- is a tag-indeterminate call. + + if Is_Tag_Indeterminate (Rhs) then + if Is_Class_Wide_Type (T1) then + Propagate_Tag (Lhs, Rhs); + + elsif Nkind (Rhs) = N_Function_Call + and then Is_Entity_Name (Name (Rhs)) + and then Is_Abstract_Subprogram (Entity (Name (Rhs))) + then + Error_Msg_N + ("call to abstract function must be dispatching", Name (Rhs)); + + elsif Nkind (Rhs) = N_Qualified_Expression + and then Nkind (Expression (Rhs)) = N_Function_Call + and then Is_Entity_Name (Name (Expression (Rhs))) + and then + Is_Abstract_Subprogram (Entity (Name (Expression (Rhs)))) + then + Error_Msg_N + ("call to abstract function must be dispatching", + Name (Expression (Rhs))); + end if; + end if; + + -- Ada 2005 (AI-385): When the lhs type is an anonymous access type, + -- apply an implicit conversion of the rhs to that type to force + -- appropriate static and run-time accessibility checks. This applies + -- as well to anonymous access-to-subprogram types that are component + -- subtypes or formal parameters. + + if Ada_Version >= Ada_2005 + and then Is_Access_Type (T1) + then + if Is_Local_Anonymous_Access (T1) + or else Ekind (T2) = E_Anonymous_Access_Subprogram_Type + then + Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs))); + Analyze_And_Resolve (Rhs, T1); + end if; + end if; + + -- Ada 2005 (AI-231): Assignment to not null variable + + if Ada_Version >= Ada_2005 + and then Can_Never_Be_Null (T1) + and then not Assignment_OK (Lhs) + then + -- Case where we know the right hand side is null + + if Known_Null (Rhs) then + Apply_Compile_Time_Constraint_Error + (N => Rhs, + Msg => "(Ada 2005) null not allowed in null-excluding objects?", + Reason => CE_Null_Not_Allowed); + + -- We still mark this as a possible modification, that's necessary + -- to reset Is_True_Constant, and desirable for xref purposes. + + Note_Possible_Modification (Lhs, Sure => True); + return; + + -- If we know the right hand side is non-null, then we convert to the + -- target type, since we don't need a run time check in that case. + + elsif not Can_Never_Be_Null (T2) then + Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs))); + Analyze_And_Resolve (Rhs, T1); + end if; + end if; + + if Is_Scalar_Type (T1) then + Apply_Scalar_Range_Check (Rhs, Etype (Lhs)); + + -- For array types, verify that lengths match. If the right hand side + -- if a function call that has been inlined, the assignment has been + -- rewritten as a block, and the constraint check will be applied to the + -- assignment within the block. + + elsif Is_Array_Type (T1) + and then + (Nkind (Rhs) /= N_Type_Conversion + or else Is_Constrained (Etype (Rhs))) + and then + (Nkind (Rhs) /= N_Function_Call + or else Nkind (N) /= N_Block_Statement) + then + -- Assignment verifies that the length of the Lsh and Rhs are equal, + -- but of course the indexes do not have to match. If the right-hand + -- side is a type conversion to an unconstrained type, a length check + -- is performed on the expression itself during expansion. In rare + -- cases, the redundant length check is computed on an index type + -- with a different representation, triggering incorrect code in + -- the back end. + + Apply_Length_Check (Rhs, Etype (Lhs)); + + else + -- Discriminant checks are applied in the course of expansion + + null; + end if; + + -- Note: modifications of the Lhs may only be recorded after + -- checks have been applied. + + Note_Possible_Modification (Lhs, Sure => True); + Check_Order_Dependence; + + -- ??? a real accessibility check is needed when ??? + + -- Post warning for redundant assignment or variable to itself + + if Warn_On_Redundant_Constructs + + -- We only warn for source constructs + + and then Comes_From_Source (N) + + -- Where the object is the same on both sides + + and then Same_Object (Lhs, Original_Node (Rhs)) + + -- But exclude the case where the right side was an operation + -- that got rewritten (e.g. JUNK + K, where K was known to be + -- zero). We don't want to warn in such a case, since it is + -- reasonable to write such expressions especially when K is + -- defined symbolically in some other package. + + and then Nkind (Original_Node (Rhs)) not in N_Op + then + if Nkind (Lhs) in N_Has_Entity then + Error_Msg_NE -- CODEFIX + ("?useless assignment of & to itself!", N, Entity (Lhs)); + else + Error_Msg_N -- CODEFIX + ("?useless assignment of object to itself!", N); + end if; + end if; + + -- Check for non-allowed composite assignment + + if not Support_Composite_Assign_On_Target + and then (Is_Array_Type (T1) or else Is_Record_Type (T1)) + and then (not Has_Size_Clause (T1) or else Esize (T1) > 64) + then + Error_Msg_CRT ("composite assignment", N); + end if; + + -- Check elaboration warning for left side if not in elab code + + if not In_Subprogram_Or_Concurrent_Unit then + Check_Elab_Assign (Lhs); + end if; + + -- Set Referenced_As_LHS if appropriate. We only set this flag if the + -- assignment is a source assignment in the extended main source unit. + -- We are not interested in any reference information outside this + -- context, or in compiler generated assignment statements. + + if Comes_From_Source (N) + and then In_Extended_Main_Source_Unit (Lhs) + then + Set_Referenced_Modified (Lhs, Out_Param => False); + end if; + + -- Final step. If left side is an entity, then we may be able to + -- reset the current tracked values to new safe values. We only have + -- something to do if the left side is an entity name, and expansion + -- has not modified the node into something other than an assignment, + -- and of course we only capture values if it is safe to do so. + + if Is_Entity_Name (Lhs) + and then Nkind (N) = N_Assignment_Statement + then + declare + Ent : constant Entity_Id := Entity (Lhs); + + begin + if Safe_To_Capture_Value (N, Ent) then + + -- If simple variable on left side, warn if this assignment + -- blots out another one (rendering it useless) and note + -- location of assignment in case no one references value. + -- We only do this for source assignments, otherwise we can + -- generate bogus warnings when an assignment is rewritten as + -- another assignment, and gets tied up with itself. + + -- Note: we don't use Record_Last_Assignment here, because we + -- have lots of other stuff to do under control of this test. + + if Warn_On_Modified_Unread + and then Is_Assignable (Ent) + and then Comes_From_Source (N) + and then In_Extended_Main_Source_Unit (Ent) + then + Warn_On_Useless_Assignment (Ent, N); + Set_Last_Assignment (Ent, Lhs); + end if; + + -- If we are assigning an access type and the left side is an + -- entity, then make sure that the Is_Known_[Non_]Null flags + -- properly reflect the state of the entity after assignment. + + if Is_Access_Type (T1) then + if Known_Non_Null (Rhs) then + Set_Is_Known_Non_Null (Ent, True); + + elsif Known_Null (Rhs) + and then not Can_Never_Be_Null (Ent) + then + Set_Is_Known_Null (Ent, True); + + else + Set_Is_Known_Null (Ent, False); + + if not Can_Never_Be_Null (Ent) then + Set_Is_Known_Non_Null (Ent, False); + end if; + end if; + + -- For discrete types, we may be able to set the current value + -- if the value is known at compile time. + + elsif Is_Discrete_Type (T1) + and then Compile_Time_Known_Value (Rhs) + then + Set_Current_Value (Ent, Rhs); + else + Set_Current_Value (Ent, Empty); + end if; + + -- If not safe to capture values, kill them + + else + Kill_Lhs; + end if; + end; + end if; + end Analyze_Assignment; + + ----------------------------- + -- Analyze_Block_Statement -- + ----------------------------- + + procedure Analyze_Block_Statement (N : Node_Id) is + Decls : constant List_Id := Declarations (N); + Id : constant Node_Id := Identifier (N); + HSS : constant Node_Id := Handled_Statement_Sequence (N); + + begin + -- If no handled statement sequence is present, things are really + -- messed up, and we just return immediately (this is a defence + -- against previous errors). + + if No (HSS) then + return; + end if; + + -- Normal processing with HSS present + + declare + EH : constant List_Id := Exception_Handlers (HSS); + Ent : Entity_Id := Empty; + S : Entity_Id; + + Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count; + -- Recursively save value of this global, will be restored on exit + + begin + -- Initialize unblocked exit count for statements of begin block + -- plus one for each exception handler that is present. + + Unblocked_Exit_Count := 1; + + if Present (EH) then + Unblocked_Exit_Count := Unblocked_Exit_Count + List_Length (EH); + end if; + + -- If a label is present analyze it and mark it as referenced + + if Present (Id) then + Analyze (Id); + Ent := Entity (Id); + + -- An error defense. If we have an identifier, but no entity, + -- then something is wrong. If we have previous errors, then + -- just remove the identifier and continue, otherwise raise + -- an exception. + + if No (Ent) then + if Total_Errors_Detected /= 0 then + Set_Identifier (N, Empty); + else + raise Program_Error; + end if; + + else + Set_Ekind (Ent, E_Block); + Generate_Reference (Ent, N, ' '); + Generate_Definition (Ent); + + if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then + Set_Label_Construct (Parent (Ent), N); + end if; + end if; + end if; + + -- If no entity set, create a label entity + + if No (Ent) then + Ent := New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B'); + Set_Identifier (N, New_Occurrence_Of (Ent, Sloc (N))); + Set_Parent (Ent, N); + end if; + + Set_Etype (Ent, Standard_Void_Type); + Set_Block_Node (Ent, Identifier (N)); + Push_Scope (Ent); + + if Present (Decls) then + Analyze_Declarations (Decls); + Check_Completion; + Inspect_Deferred_Constant_Completion (Decls); + end if; + + Analyze (HSS); + Process_End_Label (HSS, 'e', Ent); + + -- If exception handlers are present, then we indicate that + -- enclosing scopes contain a block with handlers. We only + -- need to mark non-generic scopes. + + if Present (EH) then + S := Scope (Ent); + loop + Set_Has_Nested_Block_With_Handler (S); + exit when Is_Overloadable (S) + or else Ekind (S) = E_Package + or else Is_Generic_Unit (S); + S := Scope (S); + end loop; + end if; + + Check_References (Ent); + Warn_On_Useless_Assignments (Ent); + End_Scope; + + if Unblocked_Exit_Count = 0 then + Unblocked_Exit_Count := Save_Unblocked_Exit_Count; + Check_Unreachable_Code (N); + else + Unblocked_Exit_Count := Save_Unblocked_Exit_Count; + end if; + end; + end Analyze_Block_Statement; + + ---------------------------- + -- Analyze_Case_Statement -- + ---------------------------- + + procedure Analyze_Case_Statement (N : Node_Id) is + Exp : Node_Id; + Exp_Type : Entity_Id; + Exp_Btype : Entity_Id; + Last_Choice : Nat; + Dont_Care : Boolean; + Others_Present : Boolean; + + pragma Warnings (Off, Last_Choice); + pragma Warnings (Off, Dont_Care); + -- Don't care about assigned values + + Statements_Analyzed : Boolean := False; + -- Set True if at least some statement sequences get analyzed. + -- If False on exit, means we had a serious error that prevented + -- full analysis of the case statement, and as a result it is not + -- a good idea to output warning messages about unreachable code. + + Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count; + -- Recursively save value of this global, will be restored on exit + + procedure Non_Static_Choice_Error (Choice : Node_Id); + -- Error routine invoked by the generic instantiation below when + -- the case statement has a non static choice. + + procedure Process_Statements (Alternative : Node_Id); + -- Analyzes all the statements associated with a case alternative. + -- Needed by the generic instantiation below. + + package Case_Choices_Processing is new + Generic_Choices_Processing + (Get_Alternatives => Alternatives, + Get_Choices => Discrete_Choices, + Process_Empty_Choice => No_OP, + Process_Non_Static_Choice => Non_Static_Choice_Error, + Process_Associated_Node => Process_Statements); + use Case_Choices_Processing; + -- Instantiation of the generic choice processing package + + ----------------------------- + -- Non_Static_Choice_Error -- + ----------------------------- + + procedure Non_Static_Choice_Error (Choice : Node_Id) is + begin + Flag_Non_Static_Expr + ("choice given in case statement is not static!", Choice); + end Non_Static_Choice_Error; + + ------------------------ + -- Process_Statements -- + ------------------------ + + procedure Process_Statements (Alternative : Node_Id) is + Choices : constant List_Id := Discrete_Choices (Alternative); + Ent : Entity_Id; + + begin + Unblocked_Exit_Count := Unblocked_Exit_Count + 1; + Statements_Analyzed := True; + + -- An interesting optimization. If the case statement expression + -- is a simple entity, then we can set the current value within + -- an alternative if the alternative has one possible value. + + -- case N is + -- when 1 => alpha + -- when 2 | 3 => beta + -- when others => gamma + + -- Here we know that N is initially 1 within alpha, but for beta + -- and gamma, we do not know anything more about the initial value. + + if Is_Entity_Name (Exp) then + Ent := Entity (Exp); + + if Ekind_In (Ent, E_Variable, + E_In_Out_Parameter, + E_Out_Parameter) + then + if List_Length (Choices) = 1 + and then Nkind (First (Choices)) in N_Subexpr + and then Compile_Time_Known_Value (First (Choices)) + then + Set_Current_Value (Entity (Exp), First (Choices)); + end if; + + Analyze_Statements (Statements (Alternative)); + + -- After analyzing the case, set the current value to empty + -- since we won't know what it is for the next alternative + -- (unless reset by this same circuit), or after the case. + + Set_Current_Value (Entity (Exp), Empty); + return; + end if; + end if; + + -- Case where expression is not an entity name of a variable + + Analyze_Statements (Statements (Alternative)); + end Process_Statements; + + -- Start of processing for Analyze_Case_Statement + + begin + Unblocked_Exit_Count := 0; + Exp := Expression (N); + Analyze (Exp); + + -- The expression must be of any discrete type. In rare cases, the + -- expander constructs a case statement whose expression has a private + -- type whose full view is discrete. This can happen when generating + -- a stream operation for a variant type after the type is frozen, + -- when the partial of view of the type of the discriminant is private. + -- In that case, use the full view to analyze case alternatives. + + if not Is_Overloaded (Exp) + and then not Comes_From_Source (N) + and then Is_Private_Type (Etype (Exp)) + and then Present (Full_View (Etype (Exp))) + and then Is_Discrete_Type (Full_View (Etype (Exp))) + then + Resolve (Exp, Etype (Exp)); + Exp_Type := Full_View (Etype (Exp)); + + else + Analyze_And_Resolve (Exp, Any_Discrete); + Exp_Type := Etype (Exp); + end if; + + Check_Unset_Reference (Exp); + Exp_Btype := Base_Type (Exp_Type); + + -- The expression must be of a discrete type which must be determinable + -- independently of the context in which the expression occurs, but + -- using the fact that the expression must be of a discrete type. + -- Moreover, the type this expression must not be a character literal + -- (which is always ambiguous) or, for Ada-83, a generic formal type. + + -- If error already reported by Resolve, nothing more to do + + if Exp_Btype = Any_Discrete + or else Exp_Btype = Any_Type + then + return; + + elsif Exp_Btype = Any_Character then + Error_Msg_N + ("character literal as case expression is ambiguous", Exp); + return; + + elsif Ada_Version = Ada_83 + and then (Is_Generic_Type (Exp_Btype) + or else Is_Generic_Type (Root_Type (Exp_Btype))) + then + Error_Msg_N + ("(Ada 83) case expression cannot be of a generic type", Exp); + return; + end if; + + -- If the case expression is a formal object of mode in out, then + -- treat it as having a nonstatic subtype by forcing use of the base + -- type (which has to get passed to Check_Case_Choices below). Also + -- use base type when the case expression is parenthesized. + + if Paren_Count (Exp) > 0 + or else (Is_Entity_Name (Exp) + and then Ekind (Entity (Exp)) = E_Generic_In_Out_Parameter) + then + Exp_Type := Exp_Btype; + end if; + + -- Call instantiated Analyze_Choices which does the rest of the work + + Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present); + + if Exp_Type = Universal_Integer and then not Others_Present then + Error_Msg_N ("case on universal integer requires OTHERS choice", Exp); + end if; + + -- If all our exits were blocked by unconditional transfers of control, + -- then the entire CASE statement acts as an unconditional transfer of + -- control, so treat it like one, and check unreachable code. Skip this + -- test if we had serious errors preventing any statement analysis. + + if Unblocked_Exit_Count = 0 and then Statements_Analyzed then + Unblocked_Exit_Count := Save_Unblocked_Exit_Count; + Check_Unreachable_Code (N); + else + Unblocked_Exit_Count := Save_Unblocked_Exit_Count; + end if; + + if not Expander_Active + and then Compile_Time_Known_Value (Expression (N)) + and then Serious_Errors_Detected = 0 + then + declare + Chosen : constant Node_Id := Find_Static_Alternative (N); + Alt : Node_Id; + + begin + Alt := First (Alternatives (N)); + while Present (Alt) loop + if Alt /= Chosen then + Remove_Warning_Messages (Statements (Alt)); + end if; + + Next (Alt); + end loop; + end; + end if; + end Analyze_Case_Statement; + + ---------------------------- + -- Analyze_Exit_Statement -- + ---------------------------- + + -- If the exit includes a name, it must be the name of a currently open + -- loop. Otherwise there must be an innermost open loop on the stack, + -- to which the statement implicitly refers. + + procedure Analyze_Exit_Statement (N : Node_Id) is + Target : constant Node_Id := Name (N); + Cond : constant Node_Id := Condition (N); + Scope_Id : Entity_Id; + U_Name : Entity_Id; + Kind : Entity_Kind; + + begin + if No (Cond) then + Check_Unreachable_Code (N); + end if; + + if Present (Target) then + Analyze (Target); + U_Name := Entity (Target); + + if not In_Open_Scopes (U_Name) or else Ekind (U_Name) /= E_Loop then + Error_Msg_N ("invalid loop name in exit statement", N); + return; + else + Set_Has_Exit (U_Name); + end if; + + else + U_Name := Empty; + end if; + + for J in reverse 0 .. Scope_Stack.Last loop + Scope_Id := Scope_Stack.Table (J).Entity; + Kind := Ekind (Scope_Id); + + if Kind = E_Loop + and then (No (Target) or else Scope_Id = U_Name) then + Set_Has_Exit (Scope_Id); + exit; + + elsif Kind = E_Block + or else Kind = E_Loop + or else Kind = E_Return_Statement + then + null; + + else + Error_Msg_N + ("cannot exit from program unit or accept statement", N); + return; + end if; + end loop; + + -- Verify that if present the condition is a Boolean expression + + if Present (Cond) then + Analyze_And_Resolve (Cond, Any_Boolean); + Check_Unset_Reference (Cond); + end if; + + -- Chain exit statement to associated loop entity + + Set_Next_Exit_Statement (N, First_Exit_Statement (Scope_Id)); + Set_First_Exit_Statement (Scope_Id, N); + + -- Since the exit may take us out of a loop, any previous assignment + -- statement is not useless, so clear last assignment indications. It + -- is OK to keep other current values, since if the exit statement + -- does not exit, then the current values are still valid. + + Kill_Current_Values (Last_Assignment_Only => True); + end Analyze_Exit_Statement; + + ---------------------------- + -- Analyze_Goto_Statement -- + ---------------------------- + + procedure Analyze_Goto_Statement (N : Node_Id) is + Label : constant Node_Id := Name (N); + Scope_Id : Entity_Id; + Label_Scope : Entity_Id; + Label_Ent : Entity_Id; + + begin + Check_Unreachable_Code (N); + Kill_Current_Values (Last_Assignment_Only => True); + + Analyze (Label); + Label_Ent := Entity (Label); + + -- Ignore previous error + + if Label_Ent = Any_Id then + return; + + -- We just have a label as the target of a goto + + elsif Ekind (Label_Ent) /= E_Label then + Error_Msg_N ("target of goto statement must be a label", Label); + return; + + -- Check that the target of the goto is reachable according to Ada + -- scoping rules. Note: the special gotos we generate for optimizing + -- local handling of exceptions would violate these rules, but we mark + -- such gotos as analyzed when built, so this code is never entered. + + elsif not Reachable (Label_Ent) then + Error_Msg_N ("target of goto statement is not reachable", Label); + return; + end if; + + -- Here if goto passes initial validity checks + + Label_Scope := Enclosing_Scope (Label_Ent); + + for J in reverse 0 .. Scope_Stack.Last loop + Scope_Id := Scope_Stack.Table (J).Entity; + + if Label_Scope = Scope_Id + or else (Ekind (Scope_Id) /= E_Block + and then Ekind (Scope_Id) /= E_Loop + and then Ekind (Scope_Id) /= E_Return_Statement) + then + if Scope_Id /= Label_Scope then + Error_Msg_N + ("cannot exit from program unit or accept statement", N); + end if; + + return; + end if; + end loop; + + raise Program_Error; + end Analyze_Goto_Statement; + + -------------------------- + -- Analyze_If_Statement -- + -------------------------- + + -- A special complication arises in the analysis of if statements + + -- The expander has circuitry to completely delete code that it + -- can tell will not be executed (as a result of compile time known + -- conditions). In the analyzer, we ensure that code that will be + -- deleted in this manner is analyzed but not expanded. This is + -- obviously more efficient, but more significantly, difficulties + -- arise if code is expanded and then eliminated (e.g. exception + -- table entries disappear). Similarly, itypes generated in deleted + -- code must be frozen from start, because the nodes on which they + -- depend will not be available at the freeze point. + + procedure Analyze_If_Statement (N : Node_Id) is + E : Node_Id; + + Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count; + -- Recursively save value of this global, will be restored on exit + + Save_In_Deleted_Code : Boolean; + + Del : Boolean := False; + -- This flag gets set True if a True condition has been found, + -- which means that remaining ELSE/ELSIF parts are deleted. + + procedure Analyze_Cond_Then (Cnode : Node_Id); + -- This is applied to either the N_If_Statement node itself or + -- to an N_Elsif_Part node. It deals with analyzing the condition + -- and the THEN statements associated with it. + + ----------------------- + -- Analyze_Cond_Then -- + ----------------------- + + procedure Analyze_Cond_Then (Cnode : Node_Id) is + Cond : constant Node_Id := Condition (Cnode); + Tstm : constant List_Id := Then_Statements (Cnode); + + begin + Unblocked_Exit_Count := Unblocked_Exit_Count + 1; + Analyze_And_Resolve (Cond, Any_Boolean); + Check_Unset_Reference (Cond); + Set_Current_Value_Condition (Cnode); + + -- If already deleting, then just analyze then statements + + if Del then + Analyze_Statements (Tstm); + + -- Compile time known value, not deleting yet + + elsif Compile_Time_Known_Value (Cond) then + Save_In_Deleted_Code := In_Deleted_Code; + + -- If condition is True, then analyze the THEN statements + -- and set no expansion for ELSE and ELSIF parts. + + if Is_True (Expr_Value (Cond)) then + Analyze_Statements (Tstm); + Del := True; + Expander_Mode_Save_And_Set (False); + In_Deleted_Code := True; + + -- If condition is False, analyze THEN with expansion off + + else -- Is_False (Expr_Value (Cond)) + Expander_Mode_Save_And_Set (False); + In_Deleted_Code := True; + Analyze_Statements (Tstm); + Expander_Mode_Restore; + In_Deleted_Code := Save_In_Deleted_Code; + end if; + + -- Not known at compile time, not deleting, normal analysis + + else + Analyze_Statements (Tstm); + end if; + end Analyze_Cond_Then; + + -- Start of Analyze_If_Statement + + begin + -- Initialize exit count for else statements. If there is no else + -- part, this count will stay non-zero reflecting the fact that the + -- uncovered else case is an unblocked exit. + + Unblocked_Exit_Count := 1; + Analyze_Cond_Then (N); + + -- Now to analyze the elsif parts if any are present + + if Present (Elsif_Parts (N)) then + E := First (Elsif_Parts (N)); + while Present (E) loop + Analyze_Cond_Then (E); + Next (E); + end loop; + end if; + + if Present (Else_Statements (N)) then + Analyze_Statements (Else_Statements (N)); + end if; + + -- If all our exits were blocked by unconditional transfers of control, + -- then the entire IF statement acts as an unconditional transfer of + -- control, so treat it like one, and check unreachable code. + + if Unblocked_Exit_Count = 0 then + Unblocked_Exit_Count := Save_Unblocked_Exit_Count; + Check_Unreachable_Code (N); + else + Unblocked_Exit_Count := Save_Unblocked_Exit_Count; + end if; + + if Del then + Expander_Mode_Restore; + In_Deleted_Code := Save_In_Deleted_Code; + end if; + + if not Expander_Active + and then Compile_Time_Known_Value (Condition (N)) + and then Serious_Errors_Detected = 0 + then + if Is_True (Expr_Value (Condition (N))) then + Remove_Warning_Messages (Else_Statements (N)); + + if Present (Elsif_Parts (N)) then + E := First (Elsif_Parts (N)); + while Present (E) loop + Remove_Warning_Messages (Then_Statements (E)); + Next (E); + end loop; + end if; + + else + Remove_Warning_Messages (Then_Statements (N)); + end if; + end if; + end Analyze_If_Statement; + + ---------------------------------------- + -- Analyze_Implicit_Label_Declaration -- + ---------------------------------------- + + -- An implicit label declaration is generated in the innermost + -- enclosing declarative part. This is done for labels as well as + -- block and loop names. + + -- Note: any changes in this routine may need to be reflected in + -- Analyze_Label_Entity. + + procedure Analyze_Implicit_Label_Declaration (N : Node_Id) is + Id : constant Node_Id := Defining_Identifier (N); + begin + Enter_Name (Id); + Set_Ekind (Id, E_Label); + Set_Etype (Id, Standard_Void_Type); + Set_Enclosing_Scope (Id, Current_Scope); + end Analyze_Implicit_Label_Declaration; + + ------------------------------ + -- Analyze_Iteration_Scheme -- + ------------------------------ + + procedure Analyze_Iteration_Scheme (N : Node_Id) is + + procedure Process_Bounds (R : Node_Id); + -- If the iteration is given by a range, create temporaries and + -- assignment statements block to capture the bounds and perform + -- required finalization actions in case a bound includes a function + -- call that uses the temporary stack. We first pre-analyze a copy of + -- the range in order to determine the expected type, and analyze and + -- resolve the original bounds. + + procedure Check_Controlled_Array_Attribute (DS : Node_Id); + -- If the bounds are given by a 'Range reference on a function call + -- that returns a controlled array, introduce an explicit declaration + -- to capture the bounds, so that the function result can be finalized + -- in timely fashion. + + -------------------- + -- Process_Bounds -- + -------------------- + + procedure Process_Bounds (R : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + R_Copy : constant Node_Id := New_Copy_Tree (R); + Lo : constant Node_Id := Low_Bound (R); + Hi : constant Node_Id := High_Bound (R); + New_Lo_Bound : Node_Id; + New_Hi_Bound : Node_Id; + Typ : Entity_Id; + Save_Analysis : Boolean; + + function One_Bound + (Original_Bound : Node_Id; + Analyzed_Bound : Node_Id) return Node_Id; + -- Capture value of bound and return captured value + + --------------- + -- One_Bound -- + --------------- + + function One_Bound + (Original_Bound : Node_Id; + Analyzed_Bound : Node_Id) return Node_Id + is + Assign : Node_Id; + Id : Entity_Id; + Decl : Node_Id; + + begin + -- If the bound is a constant or an object, no need for a separate + -- declaration. If the bound is the result of previous expansion + -- it is already analyzed and should not be modified. Note that + -- the Bound will be resolved later, if needed, as part of the + -- call to Make_Index (literal bounds may need to be resolved to + -- type Integer). + + if Analyzed (Original_Bound) then + return Original_Bound; + + elsif Nkind_In (Analyzed_Bound, N_Integer_Literal, + N_Character_Literal) + or else Is_Entity_Name (Analyzed_Bound) + then + Analyze_And_Resolve (Original_Bound, Typ); + return Original_Bound; + end if; + + -- Here we need to capture the value + + Analyze_And_Resolve (Original_Bound, Typ); + + Id := Make_Temporary (Loc, 'S', Original_Bound); + + -- Normally, the best approach is simply to generate a constant + -- declaration that captures the bound. However, there is a nasty + -- case where this is wrong. If the bound is complex, and has a + -- possible use of the secondary stack, we need to generate a + -- separate assignment statement to ensure the creation of a block + -- which will release the secondary stack. + + -- We prefer the constant declaration, since it leaves us with a + -- proper trace of the value, useful in optimizations that get rid + -- of junk range checks. + + -- Probably we want something like the Side_Effect_Free routine + -- in Exp_Util, but for now, we just optimize the cases of 'Last + -- and 'First applied to an entity, since these are the important + -- cases for range check optimizations. + + if Nkind (Original_Bound) = N_Attribute_Reference + and then (Attribute_Name (Original_Bound) = Name_First + or else + Attribute_Name (Original_Bound) = Name_Last) + and then Is_Entity_Name (Prefix (Original_Bound)) + then + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Id, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (Original_Bound)); + + -- Insert declaration at proper place. If loop comes from an + -- enclosing quantified expression, the insertion point is + -- arbitrarily far up in the tree. + + Insert_Action (Parent (N), Decl); + Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc)); + return Expression (Decl); + end if; + + -- Here we make a declaration with a separate assignment + -- statement, and insert before loop header. + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Id, + Object_Definition => New_Occurrence_Of (Typ, Loc)); + + Assign := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Id, Loc), + Expression => Relocate_Node (Original_Bound)); + + Insert_Actions (Parent (N), New_List (Decl, Assign)); + + Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc)); + + if Nkind (Assign) = N_Assignment_Statement then + return Expression (Assign); + else + return Original_Bound; + end if; + end One_Bound; + + -- Start of processing for Process_Bounds + + begin + -- Determine expected type of range by analyzing separate copy + -- Do the analysis and resolution of the copy of the bounds with + -- expansion disabled, to prevent the generation of finalization + -- actions on each bound. This prevents memory leaks when the + -- bounds contain calls to functions returning controlled arrays. + + Set_Parent (R_Copy, Parent (R)); + Save_Analysis := Full_Analysis; + Full_Analysis := False; + Expander_Mode_Save_And_Set (False); + + Analyze (R_Copy); + + if Is_Overloaded (R_Copy) then + + -- Apply preference rules for range of predefined integer types, + -- or diagnose true ambiguity. + + declare + I : Interp_Index; + It : Interp; + Found : Entity_Id := Empty; + + begin + Get_First_Interp (R_Copy, I, It); + while Present (It.Typ) loop + if Is_Discrete_Type (It.Typ) then + if No (Found) then + Found := It.Typ; + else + if Scope (Found) = Standard_Standard then + null; + + elsif Scope (It.Typ) = Standard_Standard then + Found := It.Typ; + + else + -- Both of them are user-defined + + Error_Msg_N + ("ambiguous bounds in range of iteration", + R_Copy); + Error_Msg_N ("\possible interpretations:", R_Copy); + Error_Msg_NE ("\\} ", R_Copy, Found); + Error_Msg_NE ("\\} ", R_Copy, It.Typ); + exit; + end if; + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + end; + end if; + + Resolve (R_Copy); + Expander_Mode_Restore; + Full_Analysis := Save_Analysis; + + Typ := Etype (R_Copy); + + -- If the type of the discrete range is Universal_Integer, then + -- the bound's type must be resolved to Integer, and any object + -- used to hold the bound must also have type Integer, unless the + -- literal bounds are constant-folded expressions that carry a user- + -- defined type. + + if Typ = Universal_Integer then + if Nkind (Lo) = N_Integer_Literal + and then Present (Etype (Lo)) + and then Scope (Etype (Lo)) /= Standard_Standard + then + Typ := Etype (Lo); + + elsif Nkind (Hi) = N_Integer_Literal + and then Present (Etype (Hi)) + and then Scope (Etype (Hi)) /= Standard_Standard + then + Typ := Etype (Hi); + + else + Typ := Standard_Integer; + end if; + end if; + + Set_Etype (R, Typ); + + New_Lo_Bound := One_Bound (Lo, Low_Bound (R_Copy)); + New_Hi_Bound := One_Bound (Hi, High_Bound (R_Copy)); + + -- Propagate staticness to loop range itself, in case the + -- corresponding subtype is static. + + if New_Lo_Bound /= Lo + and then Is_Static_Expression (New_Lo_Bound) + then + Rewrite (Low_Bound (R), New_Copy (New_Lo_Bound)); + end if; + + if New_Hi_Bound /= Hi + and then Is_Static_Expression (New_Hi_Bound) + then + Rewrite (High_Bound (R), New_Copy (New_Hi_Bound)); + end if; + end Process_Bounds; + + -------------------------------------- + -- Check_Controlled_Array_Attribute -- + -------------------------------------- + + procedure Check_Controlled_Array_Attribute (DS : Node_Id) is + begin + if Nkind (DS) = N_Attribute_Reference + and then Is_Entity_Name (Prefix (DS)) + and then Ekind (Entity (Prefix (DS))) = E_Function + and then Is_Array_Type (Etype (Entity (Prefix (DS)))) + and then + Is_Controlled ( + Component_Type (Etype (Entity (Prefix (DS))))) + and then Expander_Active + then + declare + Loc : constant Source_Ptr := Sloc (N); + Arr : constant Entity_Id := Etype (Entity (Prefix (DS))); + Indx : constant Entity_Id := + Base_Type (Etype (First_Index (Arr))); + Subt : constant Entity_Id := Make_Temporary (Loc, 'S'); + Decl : Node_Id; + + begin + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Subt, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (Indx, Loc), + Constraint => + Make_Range_Constraint (Loc, + Relocate_Node (DS)))); + Insert_Before (Parent (N), Decl); + Analyze (Decl); + + Rewrite (DS, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Subt, Loc), + Attribute_Name => Attribute_Name (DS))); + Analyze (DS); + end; + end if; + end Check_Controlled_Array_Attribute; + + -- Start of processing for Analyze_Iteration_Scheme + + begin + -- If this is a rewritten quantified expression, the iteration + -- scheme has been analyzed already. Do no repeat analysis because + -- the loop variable is already declared. + + if Analyzed (N) then + return; + end if; + + -- For an infinite loop, there is no iteration scheme + + if No (N) then + return; + end if; + + -- Iteration scheme is present + + declare + Cond : constant Node_Id := Condition (N); + + begin + -- For WHILE loop, verify that the condition is a Boolean + -- expression and resolve and check it. + + if Present (Cond) then + Analyze_And_Resolve (Cond, Any_Boolean); + Check_Unset_Reference (Cond); + Set_Current_Value_Condition (N); + return; + + elsif Present (Iterator_Specification (N)) then + Analyze_Iterator_Specification (Iterator_Specification (N)); + + -- Else we have a FOR loop + + else + declare + LP : constant Node_Id := Loop_Parameter_Specification (N); + Id : constant Entity_Id := Defining_Identifier (LP); + DS : constant Node_Id := Discrete_Subtype_Definition (LP); + + begin + Enter_Name (Id); + + -- We always consider the loop variable to be referenced, + -- since the loop may be used just for counting purposes. + + Generate_Reference (Id, N, ' '); + + -- Check for the case of loop variable hiding a local variable + -- (used later on to give a nice warning if the hidden variable + -- is never assigned). + + declare + H : constant Entity_Id := Homonym (Id); + begin + if Present (H) + and then Enclosing_Dynamic_Scope (H) = + Enclosing_Dynamic_Scope (Id) + and then Ekind (H) = E_Variable + and then Is_Discrete_Type (Etype (H)) + then + Set_Hiding_Loop_Variable (H, Id); + end if; + end; + + -- Now analyze the subtype definition. If it is a range, create + -- temporaries for bounds. + + if Nkind (DS) = N_Range + and then Expander_Active + then + Process_Bounds (DS); + + -- Not a range or expander not active (is that right???) + + else + Analyze (DS); + + if Nkind (DS) = N_Function_Call + or else + (Is_Entity_Name (DS) + and then not Is_Type (Entity (DS))) + then + -- This is an iterator specification. Rewrite as such + -- and analyze. + + declare + I_Spec : constant Node_Id := + Make_Iterator_Specification (Sloc (LP), + Defining_Identifier => + Relocate_Node (Id), + Name => + Relocate_Node (DS), + Subtype_Indication => + Empty, + Reverse_Present => + Reverse_Present (LP)); + begin + Set_Iterator_Specification (N, I_Spec); + Set_Loop_Parameter_Specification (N, Empty); + Analyze_Iterator_Specification (I_Spec); + return; + end; + end if; + end if; + + if DS = Error then + return; + end if; + + -- Some additional checks if we are iterating through a type + + if Is_Entity_Name (DS) + and then Present (Entity (DS)) + and then Is_Type (Entity (DS)) + then + -- The subtype indication may denote the completion of an + -- incomplete type declaration. + + if Ekind (Entity (DS)) = E_Incomplete_Type then + Set_Entity (DS, Get_Full_View (Entity (DS))); + Set_Etype (DS, Entity (DS)); + end if; + + -- Attempt to iterate through non-static predicate + + if Is_Discrete_Type (Entity (DS)) + and then Present (Predicate_Function (Entity (DS))) + and then No (Static_Predicate (Entity (DS))) + then + Bad_Predicated_Subtype_Use + ("cannot use subtype& with non-static " + & "predicate for loop iteration", DS, Entity (DS)); + end if; + end if; + + -- Error if not discrete type + + if not Is_Discrete_Type (Etype (DS)) then + Wrong_Type (DS, Any_Discrete); + Set_Etype (DS, Any_Type); + end if; + + Check_Controlled_Array_Attribute (DS); + + Make_Index (DS, LP); + + Set_Ekind (Id, E_Loop_Parameter); + Set_Etype (Id, Etype (DS)); + + -- Treat a range as an implicit reference to the type, to + -- inhibit spurious warnings. + + Generate_Reference (Base_Type (Etype (DS)), N, ' '); + Set_Is_Known_Valid (Id, True); + + -- The loop is not a declarative part, so the only entity + -- declared "within" must be frozen explicitly. + + declare + Flist : constant List_Id := Freeze_Entity (Id, N); + begin + if Is_Non_Empty_List (Flist) then + Insert_Actions (N, Flist); + end if; + end; + + -- Check for null or possibly null range and issue warning. We + -- suppress such messages in generic templates and instances, + -- because in practice they tend to be dubious in these cases. + + if Nkind (DS) = N_Range and then Comes_From_Source (N) then + declare + L : constant Node_Id := Low_Bound (DS); + H : constant Node_Id := High_Bound (DS); + + begin + -- If range of loop is null, issue warning + + if Compile_Time_Compare + (L, H, Assume_Valid => True) = GT + then + -- Suppress the warning if inside a generic template + -- or instance, since in practice they tend to be + -- dubious in these cases since they can result from + -- intended parametrization. + + if not Inside_A_Generic + and then not In_Instance + then + -- Specialize msg if invalid values could make + -- the loop non-null after all. + + if Compile_Time_Compare + (L, H, Assume_Valid => False) = GT + then + Error_Msg_N + ("?loop range is null, loop will not execute", + DS); + + -- Since we know the range of the loop is + -- null, set the appropriate flag to remove + -- the loop entirely during expansion. + + Set_Is_Null_Loop (Parent (N)); + + -- Here is where the loop could execute because + -- of invalid values, so issue appropriate + -- message and in this case we do not set the + -- Is_Null_Loop flag since the loop may execute. + + else + Error_Msg_N + ("?loop range may be null, " + & "loop may not execute", + DS); + Error_Msg_N + ("?can only execute if invalid values " + & "are present", + DS); + end if; + end if; + + -- In either case, suppress warnings in the body of + -- the loop, since it is likely that these warnings + -- will be inappropriate if the loop never actually + -- executes, which is likely. + + Set_Suppress_Loop_Warnings (Parent (N)); + + -- The other case for a warning is a reverse loop + -- where the upper bound is the integer literal zero + -- or one, and the lower bound can be positive. + + -- For example, we have + + -- for J in reverse N .. 1 loop + + -- In practice, this is very likely to be a case of + -- reversing the bounds incorrectly in the range. + + elsif Reverse_Present (LP) + and then Nkind (Original_Node (H)) = + N_Integer_Literal + and then (Intval (Original_Node (H)) = Uint_0 + or else + Intval (Original_Node (H)) = Uint_1) + then + Error_Msg_N ("?loop range may be null", DS); + Error_Msg_N ("\?bounds may be wrong way round", DS); + end if; + end; + end if; + end; + end if; + end; + end Analyze_Iteration_Scheme; + + ------------------------------------- + -- Analyze_Iterator_Specification -- + ------------------------------------- + + procedure Analyze_Iterator_Specification (N : Node_Id) is + Def_Id : constant Node_Id := Defining_Identifier (N); + Subt : constant Node_Id := Subtype_Indication (N); + Container : constant Node_Id := Name (N); + + Ent : Entity_Id; + Typ : Entity_Id; + + begin + Enter_Name (Def_Id); + Set_Ekind (Def_Id, E_Variable); + + if Present (Subt) then + Analyze (Subt); + end if; + + Analyze_And_Resolve (Container); + Typ := Etype (Container); + + if Is_Array_Type (Typ) then + if Of_Present (N) then + Set_Etype (Def_Id, Component_Type (Typ)); + else + Error_Msg_N + ("to iterate over the elements of an array, use OF", N); + Set_Etype (Def_Id, Etype (First_Index (Typ))); + end if; + + -- Iteration over a container + + else + Set_Ekind (Def_Id, E_Loop_Parameter); + + if Of_Present (N) then + + -- Find the Element_Type in the package instance that defines the + -- container type. + + Ent := First_Entity (Scope (Typ)); + while Present (Ent) loop + if Chars (Ent) = Name_Element_Type then + Set_Etype (Def_Id, Ent); + exit; + end if; + + Next_Entity (Ent); + end loop; + + else + -- Find the Cursor type in similar fashion + + Ent := First_Entity (Scope (Typ)); + while Present (Ent) loop + if Chars (Ent) = Name_Cursor then + Set_Etype (Def_Id, Ent); + exit; + end if; + + Next_Entity (Ent); + end loop; + end if; + end if; + end Analyze_Iterator_Specification; + + ------------------- + -- Analyze_Label -- + ------------------- + + -- Note: the semantic work required for analyzing labels (setting them as + -- reachable) was done in a prepass through the statements in the block, + -- so that forward gotos would be properly handled. See Analyze_Statements + -- for further details. The only processing required here is to deal with + -- optimizations that depend on an assumption of sequential control flow, + -- since of course the occurrence of a label breaks this assumption. + + procedure Analyze_Label (N : Node_Id) is + pragma Warnings (Off, N); + begin + Kill_Current_Values; + end Analyze_Label; + + -------------------------- + -- Analyze_Label_Entity -- + -------------------------- + + procedure Analyze_Label_Entity (E : Entity_Id) is + begin + Set_Ekind (E, E_Label); + Set_Etype (E, Standard_Void_Type); + Set_Enclosing_Scope (E, Current_Scope); + Set_Reachable (E, True); + end Analyze_Label_Entity; + + ---------------------------- + -- Analyze_Loop_Statement -- + ---------------------------- + + procedure Analyze_Loop_Statement (N : Node_Id) is + Loop_Statement : constant Node_Id := N; + + Id : constant Node_Id := Identifier (Loop_Statement); + Iter : constant Node_Id := Iteration_Scheme (Loop_Statement); + Ent : Entity_Id; + + begin + if Present (Id) then + + -- Make name visible, e.g. for use in exit statements. Loop + -- labels are always considered to be referenced. + + Analyze (Id); + Ent := Entity (Id); + + -- Guard against serious error (typically, a scope mismatch when + -- semantic analysis is requested) by creating loop entity to + -- continue analysis. + + if No (Ent) then + if Total_Errors_Detected /= 0 then + Ent := + New_Internal_Entity + (E_Loop, Current_Scope, Sloc (Loop_Statement), 'L'); + else + raise Program_Error; + end if; + + else + Generate_Reference (Ent, Loop_Statement, ' '); + Generate_Definition (Ent); + + -- If we found a label, mark its type. If not, ignore it, since it + -- means we have a conflicting declaration, which would already + -- have been diagnosed at declaration time. Set Label_Construct + -- of the implicit label declaration, which is not created by the + -- parser for generic units. + + if Ekind (Ent) = E_Label then + Set_Ekind (Ent, E_Loop); + + if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then + Set_Label_Construct (Parent (Ent), Loop_Statement); + end if; + end if; + end if; + + -- Case of no identifier present + + else + Ent := + New_Internal_Entity + (E_Loop, Current_Scope, Sloc (Loop_Statement), 'L'); + Set_Etype (Ent, Standard_Void_Type); + Set_Parent (Ent, Loop_Statement); + end if; + + -- Kill current values on entry to loop, since statements in body of + -- loop may have been executed before the loop is entered. Similarly we + -- kill values after the loop, since we do not know that the body of the + -- loop was executed. + + Kill_Current_Values; + Push_Scope (Ent); + Analyze_Iteration_Scheme (Iter); + Analyze_Statements (Statements (Loop_Statement)); + Process_End_Label (Loop_Statement, 'e', Ent); + End_Scope; + Kill_Current_Values; + + -- Check for infinite loop. Skip check for generated code, since it + -- justs waste time and makes debugging the routine called harder. + + -- Note that we have to wait till the body of the loop is fully analyzed + -- before making this call, since Check_Infinite_Loop_Warning relies on + -- being able to use semantic visibility information to find references. + + if Comes_From_Source (N) then + Check_Infinite_Loop_Warning (N); + end if; + + -- Code after loop is unreachable if the loop has no WHILE or FOR + -- and contains no EXIT statements within the body of the loop. + + if No (Iter) and then not Has_Exit (Ent) then + Check_Unreachable_Code (N); + end if; + end Analyze_Loop_Statement; + + ---------------------------- + -- Analyze_Null_Statement -- + ---------------------------- + + -- Note: the semantics of the null statement is implemented by a single + -- null statement, too bad everything isn't as simple as this! + + procedure Analyze_Null_Statement (N : Node_Id) is + pragma Warnings (Off, N); + begin + null; + end Analyze_Null_Statement; + + ------------------------ + -- Analyze_Statements -- + ------------------------ + + procedure Analyze_Statements (L : List_Id) is + S : Node_Id; + Lab : Entity_Id; + + begin + -- The labels declared in the statement list are reachable from + -- statements in the list. We do this as a prepass so that any + -- goto statement will be properly flagged if its target is not + -- reachable. This is not required, but is nice behavior! + + S := First (L); + while Present (S) loop + if Nkind (S) = N_Label then + Analyze (Identifier (S)); + Lab := Entity (Identifier (S)); + + -- If we found a label mark it as reachable + + if Ekind (Lab) = E_Label then + Generate_Definition (Lab); + Set_Reachable (Lab); + + if Nkind (Parent (Lab)) = N_Implicit_Label_Declaration then + Set_Label_Construct (Parent (Lab), S); + end if; + + -- If we failed to find a label, it means the implicit declaration + -- of the label was hidden. A for-loop parameter can do this to + -- a label with the same name inside the loop, since the implicit + -- label declaration is in the innermost enclosing body or block + -- statement. + + else + Error_Msg_Sloc := Sloc (Lab); + Error_Msg_N + ("implicit label declaration for & is hidden#", + Identifier (S)); + end if; + end if; + + Next (S); + end loop; + + -- Perform semantic analysis on all statements + + Conditional_Statements_Begin; + + S := First (L); + while Present (S) loop + Analyze (S); + Next (S); + end loop; + + Conditional_Statements_End; + + -- Make labels unreachable. Visibility is not sufficient, because + -- labels in one if-branch for example are not reachable from the + -- other branch, even though their declarations are in the enclosing + -- declarative part. + + S := First (L); + while Present (S) loop + if Nkind (S) = N_Label then + Set_Reachable (Entity (Identifier (S)), False); + end if; + + Next (S); + end loop; + end Analyze_Statements; + + ---------------------------- + -- Check_Unreachable_Code -- + ---------------------------- + + procedure Check_Unreachable_Code (N : Node_Id) is + Error_Loc : Source_Ptr; + P : Node_Id; + + begin + if Is_List_Member (N) + and then Comes_From_Source (N) + then + declare + Nxt : Node_Id; + + begin + Nxt := Original_Node (Next (N)); + + -- If a label follows us, then we never have dead code, since + -- someone could branch to the label, so we just ignore it. + + if Nkind (Nxt) = N_Label then + return; + + -- Otherwise see if we have a real statement following us + + elsif Present (Nxt) + and then Comes_From_Source (Nxt) + and then Is_Statement (Nxt) + then + -- Special very annoying exception. If we have a return that + -- follows a raise, then we allow it without a warning, since + -- the Ada RM annoyingly requires a useless return here! + + if Nkind (Original_Node (N)) /= N_Raise_Statement + or else Nkind (Nxt) /= N_Simple_Return_Statement + then + -- The rather strange shenanigans with the warning message + -- here reflects the fact that Kill_Dead_Code is very good + -- at removing warnings in deleted code, and this is one + -- warning we would prefer NOT to have removed. + + Error_Loc := Sloc (Nxt); + + -- If we have unreachable code, analyze and remove the + -- unreachable code, since it is useless and we don't + -- want to generate junk warnings. + + -- We skip this step if we are not in code generation mode. + -- This is the one case where we remove dead code in the + -- semantics as opposed to the expander, and we do not want + -- to remove code if we are not in code generation mode, + -- since this messes up the ASIS trees. + + -- Note that one might react by moving the whole circuit to + -- exp_ch5, but then we lose the warning in -gnatc mode. + + if Operating_Mode = Generate_Code then + loop + Nxt := Next (N); + + -- Quit deleting when we have nothing more to delete + -- or if we hit a label (since someone could transfer + -- control to a label, so we should not delete it). + + exit when No (Nxt) or else Nkind (Nxt) = N_Label; + + -- Statement/declaration is to be deleted + + Analyze (Nxt); + Remove (Nxt); + Kill_Dead_Code (Nxt); + end loop; + end if; + + -- Now issue the warning + + Error_Msg ("?unreachable code!", Error_Loc); + end if; + + -- If the unconditional transfer of control instruction is + -- the last statement of a sequence, then see if our parent + -- is one of the constructs for which we count unblocked exits, + -- and if so, adjust the count. + + else + P := Parent (N); + + -- Statements in THEN part or ELSE part of IF statement + + if Nkind (P) = N_If_Statement then + null; + + -- Statements in ELSIF part of an IF statement + + elsif Nkind (P) = N_Elsif_Part then + P := Parent (P); + pragma Assert (Nkind (P) = N_If_Statement); + + -- Statements in CASE statement alternative + + elsif Nkind (P) = N_Case_Statement_Alternative then + P := Parent (P); + pragma Assert (Nkind (P) = N_Case_Statement); + + -- Statements in body of block + + elsif Nkind (P) = N_Handled_Sequence_Of_Statements + and then Nkind (Parent (P)) = N_Block_Statement + then + null; + + -- Statements in exception handler in a block + + elsif Nkind (P) = N_Exception_Handler + and then Nkind (Parent (P)) = N_Handled_Sequence_Of_Statements + and then Nkind (Parent (Parent (P))) = N_Block_Statement + then + null; + + -- None of these cases, so return + + else + return; + end if; + + -- This was one of the cases we are looking for (i.e. the + -- parent construct was IF, CASE or block) so decrement count. + + Unblocked_Exit_Count := Unblocked_Exit_Count - 1; + end if; + end; + end if; + end Check_Unreachable_Code; + +end Sem_Ch5; diff --git a/gcc/ada/sem_ch5.ads b/gcc/ada/sem_ch5.ads new file mode 100644 index 000000000..fdf09db32 --- /dev/null +++ b/gcc/ada/sem_ch5.ads @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 5 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Types; use Types; + +package Sem_Ch5 is + + procedure Analyze_Assignment (N : Node_Id); + procedure Analyze_Block_Statement (N : Node_Id); + procedure Analyze_Case_Statement (N : Node_Id); + procedure Analyze_Exit_Statement (N : Node_Id); + procedure Analyze_Goto_Statement (N : Node_Id); + procedure Analyze_If_Statement (N : Node_Id); + procedure Analyze_Implicit_Label_Declaration (N : Node_Id); + procedure Analyze_Iterator_Specification (N : Node_Id); + procedure Analyze_Iteration_Scheme (N : Node_Id); + procedure Analyze_Label (N : Node_Id); + procedure Analyze_Loop_Statement (N : Node_Id); + procedure Analyze_Null_Statement (N : Node_Id); + procedure Analyze_Statements (L : List_Id); + + procedure Analyze_Label_Entity (E : Entity_Id); + -- This procedure performs direct analysis of the label entity E. It + -- is used when a label is created by the expander without bothering + -- to insert an N_Implicit_Label_Declaration in the tree. It also takes + -- care of setting Reachable, since labels defined by the expander can + -- be assumed to be reachable. + + procedure Check_Unreachable_Code (N : Node_Id); + -- This procedure is called with N being the node for a statement that is + -- an unconditional transfer of control or an apparent infinite loop. It + -- checks to see if the statement is followed by some other statement, and + -- if so generates an appropriate warning for unreachable code. + +end Sem_Ch5; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb new file mode 100644 index 000000000..ab3f26b7a --- /dev/null +++ b/gcc/ada/sem_ch6.adb @@ -0,0 +1,9612 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 6 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Aspects; use Aspects; +with Atree; use Atree; +with Checks; use Checks; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Expander; use Expander; +with Exp_Ch6; use Exp_Ch6; +with Exp_Ch7; use Exp_Ch7; +with Exp_Ch9; use Exp_Ch9; +with Exp_Disp; use Exp_Disp; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Fname; use Fname; +with Freeze; use Freeze; +with Itypes; use Itypes; +with Lib.Xref; use Lib.Xref; +with Layout; use Layout; +with Namet; use Namet; +with Lib; use Lib; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Output; use Output; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Cat; use Sem_Cat; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch4; use Sem_Ch4; +with Sem_Ch5; use Sem_Ch5; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch10; use Sem_Ch10; +with Sem_Ch12; use Sem_Ch12; +with Sem_Ch13; use Sem_Ch13; +with Sem_Disp; use Sem_Disp; +with Sem_Dist; use Sem_Dist; +with Sem_Elim; use Sem_Elim; +with Sem_Eval; use Sem_Eval; +with Sem_Mech; use Sem_Mech; +with Sem_Prag; use Sem_Prag; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sem_Type; use Sem_Type; +with Sem_Warn; use Sem_Warn; +with Sinput; use Sinput; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Sinfo.CN; use Sinfo.CN; +with Snames; use Snames; +with Stringt; use Stringt; +with Style; +with Stylesw; use Stylesw; +with Tbuild; use Tbuild; +with Uintp; use Uintp; +with Urealp; use Urealp; +with Validsw; use Validsw; + +package body Sem_Ch6 is + + May_Hide_Profile : Boolean := False; + -- This flag is used to indicate that two formals in two subprograms being + -- checked for conformance differ only in that one is an access parameter + -- while the other is of a general access type with the same designated + -- type. In this case, if the rest of the signatures match, a call to + -- either subprogram may be ambiguous, which is worth a warning. The flag + -- is set in Compatible_Types, and the warning emitted in + -- New_Overloaded_Entity. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Analyze_Return_Statement (N : Node_Id); + -- Common processing for simple and extended return statements + + procedure Analyze_Function_Return (N : Node_Id); + -- Subsidiary to Analyze_Return_Statement. Called when the return statement + -- applies to a [generic] function. + + procedure Analyze_Return_Type (N : Node_Id); + -- Subsidiary to Process_Formals: analyze subtype mark in function + -- specification in a context where the formals are visible and hide + -- outer homographs. + + procedure Analyze_Subprogram_Body_Helper (N : Node_Id); + -- Does all the real work of Analyze_Subprogram_Body. This is split out so + -- that we can use RETURN but not skip the debug output at the end. + + procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id); + -- Analyze a generic subprogram body. N is the body to be analyzed, and + -- Gen_Id is the defining entity Id for the corresponding spec. + + procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id); + -- If a subprogram has pragma Inline and inlining is active, use generic + -- machinery to build an unexpanded body for the subprogram. This body is + -- subsequently used for inline expansions at call sites. If subprogram can + -- be inlined (depending on size and nature of local declarations) this + -- function returns true. Otherwise subprogram body is treated normally. + -- If proper warnings are enabled and the subprogram contains a construct + -- that cannot be inlined, the offending construct is flagged accordingly. + + procedure Check_Conformance + (New_Id : Entity_Id; + Old_Id : Entity_Id; + Ctype : Conformance_Type; + Errmsg : Boolean; + Conforms : out Boolean; + Err_Loc : Node_Id := Empty; + Get_Inst : Boolean := False; + Skip_Controlling_Formals : Boolean := False); + -- Given two entities, this procedure checks that the profiles associated + -- with these entities meet the conformance criterion given by the third + -- parameter. If they conform, Conforms is set True and control returns + -- to the caller. If they do not conform, Conforms is set to False, and + -- in addition, if Errmsg is True on the call, proper messages are output + -- to complain about the conformance failure. If Err_Loc is non_Empty + -- the error messages are placed on Err_Loc, if Err_Loc is empty, then + -- error messages are placed on the appropriate part of the construct + -- denoted by New_Id. If Get_Inst is true, then this is a mode conformance + -- against a formal access-to-subprogram type so Get_Instance_Of must + -- be called. + + procedure Check_Subprogram_Order (N : Node_Id); + -- N is the N_Subprogram_Body node for a subprogram. This routine applies + -- the alpha ordering rule for N if this ordering requirement applicable. + + procedure Check_Returns + (HSS : Node_Id; + Mode : Character; + Err : out Boolean; + Proc : Entity_Id := Empty); + -- Called to check for missing return statements in a function body, or for + -- returns present in a procedure body which has No_Return set. HSS is the + -- handled statement sequence for the subprogram body. This procedure + -- checks all flow paths to make sure they either have return (Mode = 'F', + -- used for functions) or do not have a return (Mode = 'P', used for + -- No_Return procedures). The flag Err is set if there are any control + -- paths not explicitly terminated by a return in the function case, and is + -- True otherwise. Proc is the entity for the procedure case and is used + -- in posting the warning message. + + procedure Check_Untagged_Equality (Eq_Op : Entity_Id); + -- In Ada 2012, a primitive equality operator on an untagged record type + -- must appear before the type is frozen, and have the same visibility as + -- that of the type. This procedure checks that this rule is met, and + -- otherwise emits an error on the subprogram declaration and a warning + -- on the earlier freeze point if it is easy to locate. + + procedure Enter_Overloaded_Entity (S : Entity_Id); + -- This procedure makes S, a new overloaded entity, into the first visible + -- entity with that name. + + procedure Install_Entity (E : Entity_Id); + -- Make single entity visible (used for generic formals as well) + + function Is_Non_Overriding_Operation + (Prev_E : Entity_Id; + New_E : Entity_Id) return Boolean; + -- Enforce the rule given in 12.3(18): a private operation in an instance + -- overrides an inherited operation only if the corresponding operation + -- was overriding in the generic. This can happen for primitive operations + -- of types derived (in the generic unit) from formal private or formal + -- derived types. + + procedure Make_Inequality_Operator (S : Entity_Id); + -- Create the declaration for an inequality operator that is implicitly + -- created by a user-defined equality operator that yields a boolean. + + procedure May_Need_Actuals (Fun : Entity_Id); + -- Flag functions that can be called without parameters, i.e. those that + -- have no parameters, or those for which defaults exist for all parameters + + procedure Process_PPCs + (N : Node_Id; + Spec_Id : Entity_Id; + Body_Id : Entity_Id); + -- Called from Analyze[_Generic]_Subprogram_Body to deal with scanning post + -- conditions for the body and assembling and inserting the _postconditions + -- procedure. N is the node for the subprogram body and Body_Id/Spec_Id are + -- the entities for the body and separate spec (if there is no separate + -- spec, Spec_Id is Empty). Note that invariants and predicates may also + -- provide postconditions, and are also handled in this procedure. + + procedure Set_Formal_Validity (Formal_Id : Entity_Id); + -- Formal_Id is an formal parameter entity. This procedure deals with + -- setting the proper validity status for this entity, which depends on + -- the kind of parameter and the validity checking mode. + + ------------------------------ + -- Analyze_Return_Statement -- + ------------------------------ + + procedure Analyze_Return_Statement (N : Node_Id) is + + pragma Assert (Nkind_In (N, N_Simple_Return_Statement, + N_Extended_Return_Statement)); + + Returns_Object : constant Boolean := + Nkind (N) = N_Extended_Return_Statement + or else + (Nkind (N) = N_Simple_Return_Statement + and then Present (Expression (N))); + -- True if we're returning something; that is, "return ;" + -- or "return Result : T [:= ...]". False for "return;". Used for error + -- checking: If Returns_Object is True, N should apply to a function + -- body; otherwise N should apply to a procedure body, entry body, + -- accept statement, or extended return statement. + + function Find_What_It_Applies_To return Entity_Id; + -- Find the entity representing the innermost enclosing body, accept + -- statement, or extended return statement. If the result is a callable + -- construct or extended return statement, then this will be the value + -- of the Return_Applies_To attribute. Otherwise, the program is + -- illegal. See RM-6.5(4/2). + + ----------------------------- + -- Find_What_It_Applies_To -- + ----------------------------- + + function Find_What_It_Applies_To return Entity_Id is + Result : Entity_Id := Empty; + + begin + -- Loop outward through the Scope_Stack, skipping blocks and loops + + for J in reverse 0 .. Scope_Stack.Last loop + Result := Scope_Stack.Table (J).Entity; + exit when Ekind (Result) /= E_Block and then + Ekind (Result) /= E_Loop; + end loop; + + pragma Assert (Present (Result)); + return Result; + end Find_What_It_Applies_To; + + -- Local declarations + + Scope_Id : constant Entity_Id := Find_What_It_Applies_To; + Kind : constant Entity_Kind := Ekind (Scope_Id); + Loc : constant Source_Ptr := Sloc (N); + Stm_Entity : constant Entity_Id := + New_Internal_Entity + (E_Return_Statement, Current_Scope, Loc, 'R'); + + -- Start of processing for Analyze_Return_Statement + + begin + Set_Return_Statement_Entity (N, Stm_Entity); + + Set_Etype (Stm_Entity, Standard_Void_Type); + Set_Return_Applies_To (Stm_Entity, Scope_Id); + + -- Place Return entity on scope stack, to simplify enforcement of 6.5 + -- (4/2): an inner return statement will apply to this extended return. + + if Nkind (N) = N_Extended_Return_Statement then + Push_Scope (Stm_Entity); + end if; + + -- Check that pragma No_Return is obeyed. Don't complain about the + -- implicitly-generated return that is placed at the end. + + if No_Return (Scope_Id) and then Comes_From_Source (N) then + Error_Msg_N ("RETURN statement not allowed (No_Return)", N); + end if; + + -- Warn on any unassigned OUT parameters if in procedure + + if Ekind (Scope_Id) = E_Procedure then + Warn_On_Unassigned_Out_Parameter (N, Scope_Id); + end if; + + -- Check that functions return objects, and other things do not + + if Kind = E_Function or else Kind = E_Generic_Function then + if not Returns_Object then + Error_Msg_N ("missing expression in return from function", N); + end if; + + elsif Kind = E_Procedure or else Kind = E_Generic_Procedure then + if Returns_Object then + Error_Msg_N ("procedure cannot return value (use function)", N); + end if; + + elsif Kind = E_Entry or else Kind = E_Entry_Family then + if Returns_Object then + if Is_Protected_Type (Scope (Scope_Id)) then + Error_Msg_N ("entry body cannot return value", N); + else + Error_Msg_N ("accept statement cannot return value", N); + end if; + end if; + + elsif Kind = E_Return_Statement then + + -- We are nested within another return statement, which must be an + -- extended_return_statement. + + if Returns_Object then + Error_Msg_N + ("extended_return_statement cannot return value; " & + "use `""RETURN;""`", N); + end if; + + else + Error_Msg_N ("illegal context for return statement", N); + end if; + + if Kind = E_Function or else Kind = E_Generic_Function then + Analyze_Function_Return (N); + end if; + + if Nkind (N) = N_Extended_Return_Statement then + End_Scope; + end if; + + Kill_Current_Values (Last_Assignment_Only => True); + Check_Unreachable_Code (N); + end Analyze_Return_Statement; + + --------------------------------------------- + -- Analyze_Abstract_Subprogram_Declaration -- + --------------------------------------------- + + procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id) is + Designator : constant Entity_Id := + Analyze_Subprogram_Specification (Specification (N)); + Scop : constant Entity_Id := Current_Scope; + + begin + Generate_Definition (Designator); + Set_Is_Abstract_Subprogram (Designator); + New_Overloaded_Entity (Designator); + Check_Delayed_Subprogram (Designator); + + Set_Categorization_From_Scope (Designator, Scop); + + if Ekind (Scope (Designator)) = E_Protected_Type then + Error_Msg_N + ("abstract subprogram not allowed in protected type", N); + + -- Issue a warning if the abstract subprogram is neither a dispatching + -- operation nor an operation that overrides an inherited subprogram or + -- predefined operator, since this most likely indicates a mistake. + + elsif Warn_On_Redundant_Constructs + and then not Is_Dispatching_Operation (Designator) + and then not Present (Overridden_Operation (Designator)) + and then (not Is_Operator_Symbol_Name (Chars (Designator)) + or else Scop /= Scope (Etype (First_Formal (Designator)))) + then + Error_Msg_N + ("?abstract subprogram is not dispatching or overriding", N); + end if; + + Generate_Reference_To_Formals (Designator); + Check_Eliminated (Designator); + Analyze_Aspect_Specifications (N, Designator, Aspect_Specifications (N)); + end Analyze_Abstract_Subprogram_Declaration; + + ---------------------------------------- + -- Analyze_Extended_Return_Statement -- + ---------------------------------------- + + procedure Analyze_Extended_Return_Statement (N : Node_Id) is + begin + Analyze_Return_Statement (N); + end Analyze_Extended_Return_Statement; + + ---------------------------- + -- Analyze_Function_Call -- + ---------------------------- + + procedure Analyze_Function_Call (N : Node_Id) is + P : constant Node_Id := Name (N); + L : constant List_Id := Parameter_Associations (N); + Actual : Node_Id; + + begin + Analyze (P); + + -- A call of the form A.B (X) may be an Ada05 call, which is rewritten + -- as B (A, X). If the rewriting is successful, the call has been + -- analyzed and we just return. + + if Nkind (P) = N_Selected_Component + and then Name (N) /= P + and then Is_Rewrite_Substitution (N) + and then Present (Etype (N)) + then + return; + end if; + + -- If error analyzing name, then set Any_Type as result type and return + + if Etype (P) = Any_Type then + Set_Etype (N, Any_Type); + return; + end if; + + -- Otherwise analyze the parameters + + if Present (L) then + Actual := First (L); + while Present (Actual) loop + Analyze (Actual); + Check_Parameterless_Call (Actual); + Next (Actual); + end loop; + end if; + + Analyze_Call (N); + end Analyze_Function_Call; + + ----------------------------- + -- Analyze_Function_Return -- + ----------------------------- + + procedure Analyze_Function_Return (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Stm_Entity : constant Entity_Id := Return_Statement_Entity (N); + Scope_Id : constant Entity_Id := Return_Applies_To (Stm_Entity); + + R_Type : constant Entity_Id := Etype (Scope_Id); + -- Function result subtype + + procedure Check_Limited_Return (Expr : Node_Id); + -- Check the appropriate (Ada 95 or Ada 2005) rules for returning + -- limited types. Used only for simple return statements. + -- Expr is the expression returned. + + procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id); + -- Check that the return_subtype_indication properly matches the result + -- subtype of the function, as required by RM-6.5(5.1/2-5.3/2). + + -------------------------- + -- Check_Limited_Return -- + -------------------------- + + procedure Check_Limited_Return (Expr : Node_Id) is + begin + -- Ada 2005 (AI-318-02): Return-by-reference types have been + -- removed and replaced by anonymous access results. This is an + -- incompatibility with Ada 95. Not clear whether this should be + -- enforced yet or perhaps controllable with special switch. ??? + + if Is_Limited_Type (R_Type) + and then Comes_From_Source (N) + and then not In_Instance_Body + and then not OK_For_Limited_Init_In_05 (R_Type, Expr) + then + -- Error in Ada 2005 + + if Ada_Version >= Ada_2005 + and then not Debug_Flag_Dot_L + and then not GNAT_Mode + then + Error_Msg_N + ("(Ada 2005) cannot copy object of a limited type " & + "(RM-2005 6.5(5.5/2))", Expr); + + if Is_Immutably_Limited_Type (R_Type) then + Error_Msg_N + ("\return by reference not permitted in Ada 2005", Expr); + end if; + + -- Warn in Ada 95 mode, to give folks a heads up about this + -- incompatibility. + + -- In GNAT mode, this is just a warning, to allow it to be + -- evilly turned off. Otherwise it is a real error. + + -- In a generic context, simplify the warning because it makes + -- no sense to discuss pass-by-reference or copy. + + elsif Warn_On_Ada_2005_Compatibility or GNAT_Mode then + if Inside_A_Generic then + Error_Msg_N + ("return of limited object not permitted in Ada2005 " + & "(RM-2005 6.5(5.5/2))?", Expr); + + elsif Is_Immutably_Limited_Type (R_Type) then + Error_Msg_N + ("return by reference not permitted in Ada 2005 " + & "(RM-2005 6.5(5.5/2))?", Expr); + else + Error_Msg_N + ("cannot copy object of a limited type in Ada 2005 " + & "(RM-2005 6.5(5.5/2))?", Expr); + end if; + + -- Ada 95 mode, compatibility warnings disabled + + else + return; -- skip continuation messages below + end if; + + if not Inside_A_Generic then + Error_Msg_N + ("\consider switching to return of access type", Expr); + Explain_Limited_Type (R_Type, Expr); + end if; + end if; + end Check_Limited_Return; + + ------------------------------------- + -- Check_Return_Subtype_Indication -- + ------------------------------------- + + procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id) is + Return_Obj : constant Node_Id := Defining_Identifier (Obj_Decl); + + R_Stm_Type : constant Entity_Id := Etype (Return_Obj); + -- Subtype given in the extended return statement (must match R_Type) + + Subtype_Ind : constant Node_Id := + Object_Definition (Original_Node (Obj_Decl)); + + R_Type_Is_Anon_Access : + constant Boolean := + Ekind (R_Type) = E_Anonymous_Access_Subprogram_Type + or else + Ekind (R_Type) = E_Anonymous_Access_Protected_Subprogram_Type + or else + Ekind (R_Type) = E_Anonymous_Access_Type; + -- True if return type of the function is an anonymous access type + -- Can't we make Is_Anonymous_Access_Type in einfo ??? + + R_Stm_Type_Is_Anon_Access : + constant Boolean := + Ekind (R_Stm_Type) = E_Anonymous_Access_Subprogram_Type + or else + Ekind (R_Stm_Type) = E_Anonymous_Access_Protected_Subprogram_Type + or else + Ekind (R_Stm_Type) = E_Anonymous_Access_Type; + -- True if type of the return object is an anonymous access type + + begin + -- First, avoid cascaded errors + + if Error_Posted (Obj_Decl) or else Error_Posted (Subtype_Ind) then + return; + end if; + + -- "return access T" case; check that the return statement also has + -- "access T", and that the subtypes statically match: + -- if this is an access to subprogram the signatures must match. + + if R_Type_Is_Anon_Access then + if R_Stm_Type_Is_Anon_Access then + if + Ekind (Designated_Type (R_Stm_Type)) /= E_Subprogram_Type + then + if Base_Type (Designated_Type (R_Stm_Type)) /= + Base_Type (Designated_Type (R_Type)) + or else not Subtypes_Statically_Match (R_Stm_Type, R_Type) + then + Error_Msg_N + ("subtype must statically match function result subtype", + Subtype_Mark (Subtype_Ind)); + end if; + + else + -- For two anonymous access to subprogram types, the + -- types themselves must be type conformant. + + if not Conforming_Types + (R_Stm_Type, R_Type, Fully_Conformant) + then + Error_Msg_N + ("subtype must statically match function result subtype", + Subtype_Ind); + end if; + end if; + + else + Error_Msg_N ("must use anonymous access type", Subtype_Ind); + end if; + + -- Subtype indication case: check that the return object's type is + -- covered by the result type, and that the subtypes statically match + -- when the result subtype is constrained. Also handle record types + -- with unknown discriminants for which we have built the underlying + -- record view. Coverage is needed to allow specific-type return + -- objects when the result type is class-wide (see AI05-32). + + elsif Covers (Base_Type (R_Type), Base_Type (R_Stm_Type)) + or else (Is_Underlying_Record_View (Base_Type (R_Stm_Type)) + and then + Covers + (Base_Type (R_Type), + Underlying_Record_View (Base_Type (R_Stm_Type)))) + then + -- A null exclusion may be present on the return type, on the + -- function specification, on the object declaration or on the + -- subtype itself. + + if Is_Access_Type (R_Type) + and then + (Can_Never_Be_Null (R_Type) + or else Null_Exclusion_Present (Parent (Scope_Id))) /= + Can_Never_Be_Null (R_Stm_Type) + then + Error_Msg_N + ("subtype must statically match function result subtype", + Subtype_Ind); + end if; + + -- AI05-103: for elementary types, subtypes must statically match + + if Is_Constrained (R_Type) + or else Is_Access_Type (R_Type) + then + if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then + Error_Msg_N + ("subtype must statically match function result subtype", + Subtype_Ind); + end if; + end if; + + elsif Etype (Base_Type (R_Type)) = R_Stm_Type + and then Is_Null_Extension (Base_Type (R_Type)) + then + null; + + else + Error_Msg_N + ("wrong type for return_subtype_indication", Subtype_Ind); + end if; + end Check_Return_Subtype_Indication; + + --------------------- + -- Local Variables -- + --------------------- + + Expr : Node_Id; + + -- Start of processing for Analyze_Function_Return + + begin + Set_Return_Present (Scope_Id); + + if Nkind (N) = N_Simple_Return_Statement then + Expr := Expression (N); + Analyze_And_Resolve (Expr, R_Type); + Check_Limited_Return (Expr); + + else + -- Analyze parts specific to extended_return_statement: + + declare + Obj_Decl : constant Node_Id := + Last (Return_Object_Declarations (N)); + + HSS : constant Node_Id := Handled_Statement_Sequence (N); + + begin + Expr := Expression (Obj_Decl); + + -- Note: The check for OK_For_Limited_Init will happen in + -- Analyze_Object_Declaration; we treat it as a normal + -- object declaration. + + Set_Is_Return_Object (Defining_Identifier (Obj_Decl)); + Analyze (Obj_Decl); + + Check_Return_Subtype_Indication (Obj_Decl); + + if Present (HSS) then + Analyze (HSS); + + if Present (Exception_Handlers (HSS)) then + + -- ???Has_Nested_Block_With_Handler needs to be set. + -- Probably by creating an actual N_Block_Statement. + -- Probably in Expand. + + null; + end if; + end if; + + -- Mark the return object as referenced, since the return is an + -- implicit reference of the object. + + Set_Referenced (Defining_Identifier (Obj_Decl)); + + Check_References (Stm_Entity); + end; + end if; + + -- Case of Expr present + + if Present (Expr) + + -- Defend against previous errors + + and then Nkind (Expr) /= N_Empty + and then Present (Etype (Expr)) + then + -- Apply constraint check. Note that this is done before the implicit + -- conversion of the expression done for anonymous access types to + -- ensure correct generation of the null-excluding check associated + -- with null-excluding expressions found in return statements. + + Apply_Constraint_Check (Expr, R_Type); + + -- Ada 2005 (AI-318-02): When the result type is an anonymous access + -- type, apply an implicit conversion of the expression to that type + -- to force appropriate static and run-time accessibility checks. + + if Ada_Version >= Ada_2005 + and then Ekind (R_Type) = E_Anonymous_Access_Type + then + Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr))); + Analyze_And_Resolve (Expr, R_Type); + end if; + + -- If the result type is class-wide, then check that the return + -- expression's type is not declared at a deeper level than the + -- function (RM05-6.5(5.6/2)). + + if Ada_Version >= Ada_2005 + and then Is_Class_Wide_Type (R_Type) + then + if Type_Access_Level (Etype (Expr)) > + Subprogram_Access_Level (Scope_Id) + then + Error_Msg_N + ("level of return expression type is deeper than " & + "class-wide function!", Expr); + end if; + end if; + + -- Check incorrect use of dynamically tagged expression + + if Is_Tagged_Type (R_Type) then + Check_Dynamically_Tagged_Expression + (Expr => Expr, + Typ => R_Type, + Related_Nod => N); + end if; + + -- ??? A real run-time accessibility check is needed in cases + -- involving dereferences of access parameters. For now we just + -- check the static cases. + + if (Ada_Version < Ada_2005 or else Debug_Flag_Dot_L) + and then Is_Immutably_Limited_Type (Etype (Scope_Id)) + and then Object_Access_Level (Expr) > + Subprogram_Access_Level (Scope_Id) + then + + -- Suppress the message in a generic, where the rewriting + -- is irrelevant. + + if Inside_A_Generic then + null; + + else + Rewrite (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Accessibility_Check_Failed)); + Analyze (N); + + Error_Msg_N + ("cannot return a local value by reference?", N); + Error_Msg_NE + ("\& will be raised at run time?", + N, Standard_Program_Error); + end if; + end if; + + if Known_Null (Expr) + and then Nkind (Parent (Scope_Id)) = N_Function_Specification + and then Null_Exclusion_Present (Parent (Scope_Id)) + then + Apply_Compile_Time_Constraint_Error + (N => Expr, + Msg => "(Ada 2005) null not allowed for " + & "null-excluding return?", + Reason => CE_Null_Not_Allowed); + end if; + + -- Apply checks suggested by AI05-0144 (dangerous order dependence) + + Check_Order_Dependence; + end if; + end Analyze_Function_Return; + + ------------------------------------- + -- Analyze_Generic_Subprogram_Body -- + ------------------------------------- + + procedure Analyze_Generic_Subprogram_Body + (N : Node_Id; + Gen_Id : Entity_Id) + is + Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Id); + Kind : constant Entity_Kind := Ekind (Gen_Id); + Body_Id : Entity_Id; + New_N : Node_Id; + Spec : Node_Id; + + begin + -- Copy body and disable expansion while analyzing the generic For a + -- stub, do not copy the stub (which would load the proper body), this + -- will be done when the proper body is analyzed. + + if Nkind (N) /= N_Subprogram_Body_Stub then + New_N := Copy_Generic_Node (N, Empty, Instantiating => False); + Rewrite (N, New_N); + Start_Generic; + end if; + + Spec := Specification (N); + + -- Within the body of the generic, the subprogram is callable, and + -- behaves like the corresponding non-generic unit. + + Body_Id := Defining_Entity (Spec); + + if Kind = E_Generic_Procedure + and then Nkind (Spec) /= N_Procedure_Specification + then + Error_Msg_N ("invalid body for generic procedure ", Body_Id); + return; + + elsif Kind = E_Generic_Function + and then Nkind (Spec) /= N_Function_Specification + then + Error_Msg_N ("invalid body for generic function ", Body_Id); + return; + end if; + + Set_Corresponding_Body (Gen_Decl, Body_Id); + + if Has_Completion (Gen_Id) + and then Nkind (Parent (N)) /= N_Subunit + then + Error_Msg_N ("duplicate generic body", N); + return; + else + Set_Has_Completion (Gen_Id); + end if; + + if Nkind (N) = N_Subprogram_Body_Stub then + Set_Ekind (Defining_Entity (Specification (N)), Kind); + else + Set_Corresponding_Spec (N, Gen_Id); + end if; + + if Nkind (Parent (N)) = N_Compilation_Unit then + Set_Cunit_Entity (Current_Sem_Unit, Defining_Entity (N)); + end if; + + -- Make generic parameters immediately visible in the body. They are + -- needed to process the formals declarations. Then make the formals + -- visible in a separate step. + + Push_Scope (Gen_Id); + + declare + E : Entity_Id; + First_Ent : Entity_Id; + + begin + First_Ent := First_Entity (Gen_Id); + + E := First_Ent; + while Present (E) and then not Is_Formal (E) loop + Install_Entity (E); + Next_Entity (E); + end loop; + + Set_Use (Generic_Formal_Declarations (Gen_Decl)); + + -- Now generic formals are visible, and the specification can be + -- analyzed, for subsequent conformance check. + + Body_Id := Analyze_Subprogram_Specification (Spec); + + -- Make formal parameters visible + + if Present (E) then + + -- E is the first formal parameter, we loop through the formals + -- installing them so that they will be visible. + + Set_First_Entity (Gen_Id, E); + while Present (E) loop + Install_Entity (E); + Next_Formal (E); + end loop; + end if; + + -- Visible generic entity is callable within its own body + + Set_Ekind (Gen_Id, Ekind (Body_Id)); + Set_Ekind (Body_Id, E_Subprogram_Body); + Set_Convention (Body_Id, Convention (Gen_Id)); + Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Gen_Id)); + Set_Scope (Body_Id, Scope (Gen_Id)); + Check_Fully_Conformant (Body_Id, Gen_Id, Body_Id); + + if Nkind (N) = N_Subprogram_Body_Stub then + + -- No body to analyze, so restore state of generic unit + + Set_Ekind (Gen_Id, Kind); + Set_Ekind (Body_Id, Kind); + + if Present (First_Ent) then + Set_First_Entity (Gen_Id, First_Ent); + end if; + + End_Scope; + return; + end if; + + -- If this is a compilation unit, it must be made visible explicitly, + -- because the compilation of the declaration, unlike other library + -- unit declarations, does not. If it is not a unit, the following + -- is redundant but harmless. + + Set_Is_Immediately_Visible (Gen_Id); + Reference_Body_Formals (Gen_Id, Body_Id); + + if Is_Child_Unit (Gen_Id) then + Generate_Reference (Gen_Id, Scope (Gen_Id), 'k', False); + end if; + + Set_Actual_Subtypes (N, Current_Scope); + Process_PPCs (N, Gen_Id, Body_Id); + + -- If the generic unit carries pre- or post-conditions, copy them + -- to the original generic tree, so that they are properly added + -- to any instantiation. + + declare + Orig : constant Node_Id := Original_Node (N); + Cond : Node_Id; + + begin + Cond := First (Declarations (N)); + while Present (Cond) loop + if Nkind (Cond) = N_Pragma + and then Pragma_Name (Cond) = Name_Check + then + Prepend (New_Copy_Tree (Cond), Declarations (Orig)); + + elsif Nkind (Cond) = N_Pragma + and then Pragma_Name (Cond) = Name_Postcondition + then + Set_Ekind (Defining_Entity (Orig), Ekind (Gen_Id)); + Prepend (New_Copy_Tree (Cond), Declarations (Orig)); + else + exit; + end if; + + Next (Cond); + end loop; + end; + + Analyze_Declarations (Declarations (N)); + Check_Completion; + Analyze (Handled_Statement_Sequence (N)); + + Save_Global_References (Original_Node (N)); + + -- Prior to exiting the scope, include generic formals again (if any + -- are present) in the set of local entities. + + if Present (First_Ent) then + Set_First_Entity (Gen_Id, First_Ent); + end if; + + Check_References (Gen_Id); + end; + + Process_End_Label (Handled_Statement_Sequence (N), 't', Current_Scope); + End_Scope; + Check_Subprogram_Order (N); + + -- Outside of its body, unit is generic again + + Set_Ekind (Gen_Id, Kind); + Generate_Reference (Gen_Id, Body_Id, 'b', Set_Ref => False); + + if Style_Check then + Style.Check_Identifier (Body_Id, Gen_Id); + end if; + + End_Generic; + end Analyze_Generic_Subprogram_Body; + + ----------------------------- + -- Analyze_Operator_Symbol -- + ----------------------------- + + -- An operator symbol such as "+" or "and" may appear in context where the + -- literal denotes an entity name, such as "+"(x, y) or in context when it + -- is just a string, as in (conjunction = "or"). In these cases the parser + -- generates this node, and the semantics does the disambiguation. Other + -- such case are actuals in an instantiation, the generic unit in an + -- instantiation, and pragma arguments. + + procedure Analyze_Operator_Symbol (N : Node_Id) is + Par : constant Node_Id := Parent (N); + + begin + if (Nkind (Par) = N_Function_Call + and then N = Name (Par)) + or else Nkind (Par) = N_Function_Instantiation + or else (Nkind (Par) = N_Indexed_Component + and then N = Prefix (Par)) + or else (Nkind (Par) = N_Pragma_Argument_Association + and then not Is_Pragma_String_Literal (Par)) + or else Nkind (Par) = N_Subprogram_Renaming_Declaration + or else (Nkind (Par) = N_Attribute_Reference + and then Attribute_Name (Par) /= Name_Value) + then + Find_Direct_Name (N); + + else + Change_Operator_Symbol_To_String_Literal (N); + Analyze (N); + end if; + end Analyze_Operator_Symbol; + + ----------------------------------- + -- Analyze_Parameter_Association -- + ----------------------------------- + + procedure Analyze_Parameter_Association (N : Node_Id) is + begin + Analyze (Explicit_Actual_Parameter (N)); + end Analyze_Parameter_Association; + + -------------------------------------- + -- Analyze_Parameterized_Expression -- + -------------------------------------- + + procedure Analyze_Parameterized_Expression (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + LocX : constant Source_Ptr := Sloc (Expression (N)); + + begin + -- This is one of the occasions on which we write things during semantic + -- analysis. Transform the parameterized expression into an equivalent + -- subprogram body, and then analyze that. + + Rewrite (N, + Make_Subprogram_Body (Loc, + Specification => Specification (N), + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (LocX, + Statements => New_List ( + Make_Simple_Return_Statement (LocX, + Expression => Expression (N)))))); + Analyze (N); + end Analyze_Parameterized_Expression; + + ---------------------------- + -- Analyze_Procedure_Call -- + ---------------------------- + + procedure Analyze_Procedure_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + P : constant Node_Id := Name (N); + Actuals : constant List_Id := Parameter_Associations (N); + Actual : Node_Id; + New_N : Node_Id; + + procedure Analyze_Call_And_Resolve; + -- Do Analyze and Resolve calls for procedure call + -- At end, check illegal order dependence. + + ------------------------------ + -- Analyze_Call_And_Resolve -- + ------------------------------ + + procedure Analyze_Call_And_Resolve is + begin + if Nkind (N) = N_Procedure_Call_Statement then + Analyze_Call (N); + Resolve (N, Standard_Void_Type); + + -- Apply checks suggested by AI05-0144 + + Check_Order_Dependence; + + else + Analyze (N); + end if; + end Analyze_Call_And_Resolve; + + -- Start of processing for Analyze_Procedure_Call + + begin + -- The syntactic construct: PREFIX ACTUAL_PARAMETER_PART can denote + -- a procedure call or an entry call. The prefix may denote an access + -- to subprogram type, in which case an implicit dereference applies. + -- If the prefix is an indexed component (without implicit dereference) + -- then the construct denotes a call to a member of an entire family. + -- If the prefix is a simple name, it may still denote a call to a + -- parameterless member of an entry family. Resolution of these various + -- interpretations is delicate. + + Analyze (P); + + -- If this is a call of the form Obj.Op, the call may have been + -- analyzed and possibly rewritten into a block, in which case + -- we are done. + + if Analyzed (N) then + return; + end if; + + -- If there is an error analyzing the name (which may have been + -- rewritten if the original call was in prefix notation) then error + -- has been emitted already, mark node and return. + + if Error_Posted (N) + or else Etype (Name (N)) = Any_Type + then + Set_Etype (N, Any_Type); + return; + end if; + + -- Otherwise analyze the parameters + + if Present (Actuals) then + Actual := First (Actuals); + + while Present (Actual) loop + Analyze (Actual); + Check_Parameterless_Call (Actual); + Next (Actual); + end loop; + end if; + + -- Special processing for Elab_Spec and Elab_Body calls + + if Nkind (P) = N_Attribute_Reference + and then (Attribute_Name (P) = Name_Elab_Spec + or else Attribute_Name (P) = Name_Elab_Body) + then + if Present (Actuals) then + Error_Msg_N + ("no parameters allowed for this call", First (Actuals)); + return; + end if; + + Set_Etype (N, Standard_Void_Type); + Set_Analyzed (N); + + elsif Is_Entity_Name (P) + and then Is_Record_Type (Etype (Entity (P))) + and then Remote_AST_I_Dereference (P) + then + return; + + elsif Is_Entity_Name (P) + and then Ekind (Entity (P)) /= E_Entry_Family + then + if Is_Access_Type (Etype (P)) + and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type + and then No (Actuals) + and then Comes_From_Source (N) + then + Error_Msg_N ("missing explicit dereference in call", N); + end if; + + Analyze_Call_And_Resolve; + + -- If the prefix is the simple name of an entry family, this is + -- a parameterless call from within the task body itself. + + elsif Is_Entity_Name (P) + and then Nkind (P) = N_Identifier + and then Ekind (Entity (P)) = E_Entry_Family + and then Present (Actuals) + and then No (Next (First (Actuals))) + then + -- Can be call to parameterless entry family. What appears to be the + -- sole argument is in fact the entry index. Rewrite prefix of node + -- accordingly. Source representation is unchanged by this + -- transformation. + + New_N := + Make_Indexed_Component (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Scope (Entity (P)), Loc), + Selector_Name => New_Occurrence_Of (Entity (P), Loc)), + Expressions => Actuals); + Set_Name (N, New_N); + Set_Etype (New_N, Standard_Void_Type); + Set_Parameter_Associations (N, No_List); + Analyze_Call_And_Resolve; + + elsif Nkind (P) = N_Explicit_Dereference then + if Ekind (Etype (P)) = E_Subprogram_Type then + Analyze_Call_And_Resolve; + else + Error_Msg_N ("expect access to procedure in call", P); + end if; + + -- The name can be a selected component or an indexed component that + -- yields an access to subprogram. Such a prefix is legal if the call + -- has parameter associations. + + elsif Is_Access_Type (Etype (P)) + and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type + then + if Present (Actuals) then + Analyze_Call_And_Resolve; + else + Error_Msg_N ("missing explicit dereference in call ", N); + end if; + + -- If not an access to subprogram, then the prefix must resolve to the + -- name of an entry, entry family, or protected operation. + + -- For the case of a simple entry call, P is a selected component where + -- the prefix is the task and the selector name is the entry. A call to + -- a protected procedure will have the same syntax. If the protected + -- object contains overloaded operations, the entity may appear as a + -- function, the context will select the operation whose type is Void. + + elsif Nkind (P) = N_Selected_Component + and then (Ekind (Entity (Selector_Name (P))) = E_Entry + or else + Ekind (Entity (Selector_Name (P))) = E_Procedure + or else + Ekind (Entity (Selector_Name (P))) = E_Function) + then + Analyze_Call_And_Resolve; + + elsif Nkind (P) = N_Selected_Component + and then Ekind (Entity (Selector_Name (P))) = E_Entry_Family + and then Present (Actuals) + and then No (Next (First (Actuals))) + then + -- Can be call to parameterless entry family. What appears to be the + -- sole argument is in fact the entry index. Rewrite prefix of node + -- accordingly. Source representation is unchanged by this + -- transformation. + + New_N := + Make_Indexed_Component (Loc, + Prefix => New_Copy (P), + Expressions => Actuals); + Set_Name (N, New_N); + Set_Etype (New_N, Standard_Void_Type); + Set_Parameter_Associations (N, No_List); + Analyze_Call_And_Resolve; + + -- For the case of a reference to an element of an entry family, P is + -- an indexed component whose prefix is a selected component (task and + -- entry family), and whose index is the entry family index. + + elsif Nkind (P) = N_Indexed_Component + and then Nkind (Prefix (P)) = N_Selected_Component + and then Ekind (Entity (Selector_Name (Prefix (P)))) = E_Entry_Family + then + Analyze_Call_And_Resolve; + + -- If the prefix is the name of an entry family, it is a call from + -- within the task body itself. + + elsif Nkind (P) = N_Indexed_Component + and then Nkind (Prefix (P)) = N_Identifier + and then Ekind (Entity (Prefix (P))) = E_Entry_Family + then + New_N := + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Scope (Entity (Prefix (P))), Loc), + Selector_Name => New_Occurrence_Of (Entity (Prefix (P)), Loc)); + Rewrite (Prefix (P), New_N); + Analyze (P); + Analyze_Call_And_Resolve; + + -- Anything else is an error + + else + Error_Msg_N ("invalid procedure or entry call", N); + end if; + end Analyze_Procedure_Call; + + ------------------------------------- + -- Analyze_Simple_Return_Statement -- + ------------------------------------- + + procedure Analyze_Simple_Return_Statement (N : Node_Id) is + begin + if Present (Expression (N)) then + Mark_Coextensions (N, Expression (N)); + end if; + + Analyze_Return_Statement (N); + end Analyze_Simple_Return_Statement; + + ------------------------- + -- Analyze_Return_Type -- + ------------------------- + + procedure Analyze_Return_Type (N : Node_Id) is + Designator : constant Entity_Id := Defining_Entity (N); + Typ : Entity_Id := Empty; + + begin + -- Normal case where result definition does not indicate an error + + if Result_Definition (N) /= Error then + if Nkind (Result_Definition (N)) = N_Access_Definition then + + -- Ada 2005 (AI-254): Handle anonymous access to subprograms + + declare + AD : constant Node_Id := + Access_To_Subprogram_Definition (Result_Definition (N)); + begin + if Present (AD) and then Protected_Present (AD) then + Typ := Replace_Anonymous_Access_To_Protected_Subprogram (N); + else + Typ := Access_Definition (N, Result_Definition (N)); + end if; + end; + + Set_Parent (Typ, Result_Definition (N)); + Set_Is_Local_Anonymous_Access (Typ); + Set_Etype (Designator, Typ); + + -- Ada 2005 (AI-231): Ensure proper usage of null exclusion + + Null_Exclusion_Static_Checks (N); + + -- Subtype_Mark case + + else + Find_Type (Result_Definition (N)); + Typ := Entity (Result_Definition (N)); + Set_Etype (Designator, Typ); + + -- Ada 2005 (AI-231): Ensure proper usage of null exclusion + + Null_Exclusion_Static_Checks (N); + + -- If a null exclusion is imposed on the result type, then create + -- a null-excluding itype (an access subtype) and use it as the + -- function's Etype. Note that the null exclusion checks are done + -- right before this, because they don't get applied to types that + -- do not come from source. + + if Is_Access_Type (Typ) + and then Null_Exclusion_Present (N) + then + Set_Etype (Designator, + Create_Null_Excluding_Itype + (T => Typ, + Related_Nod => N, + Scope_Id => Scope (Current_Scope))); + + -- The new subtype must be elaborated before use because + -- it is visible outside of the function. However its base + -- type may not be frozen yet, so the reference that will + -- force elaboration must be attached to the freezing of + -- the base type. + + -- If the return specification appears on a proper body, + -- the subtype will have been created already on the spec. + + if Is_Frozen (Typ) then + if Nkind (Parent (N)) = N_Subprogram_Body + and then Nkind (Parent (Parent (N))) = N_Subunit + then + null; + else + Build_Itype_Reference (Etype (Designator), Parent (N)); + end if; + + else + Ensure_Freeze_Node (Typ); + + declare + IR : constant Node_Id := Make_Itype_Reference (Sloc (N)); + begin + Set_Itype (IR, Etype (Designator)); + Append_Freeze_Actions (Typ, New_List (IR)); + end; + end if; + + else + Set_Etype (Designator, Typ); + end if; + + if Ekind (Typ) = E_Incomplete_Type + and then Is_Value_Type (Typ) + then + null; + + elsif Ekind (Typ) = E_Incomplete_Type + or else (Is_Class_Wide_Type (Typ) + and then + Ekind (Root_Type (Typ)) = E_Incomplete_Type) + then + -- AI05-0151: Tagged incomplete types are allowed in all formal + -- parts. Untagged incomplete types are not allowed in bodies. + + if Ada_Version >= Ada_2012 then + if Is_Tagged_Type (Typ) then + null; + + elsif Nkind_In (Parent (Parent (N)), + N_Accept_Statement, + N_Entry_Body, + N_Subprogram_Body) + then + Error_Msg_NE + ("invalid use of untagged incomplete type&", + Designator, Typ); + end if; + + else + Error_Msg_NE + ("invalid use of incomplete type&", Designator, Typ); + end if; + end if; + end if; + + -- Case where result definition does indicate an error + + else + Set_Etype (Designator, Any_Type); + end if; + end Analyze_Return_Type; + + ----------------------------- + -- Analyze_Subprogram_Body -- + ----------------------------- + + procedure Analyze_Subprogram_Body (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Body_Spec : constant Node_Id := Specification (N); + Body_Id : constant Entity_Id := Defining_Entity (Body_Spec); + + begin + if Debug_Flag_C then + Write_Str ("==> subprogram body "); + Write_Name (Chars (Body_Id)); + Write_Str (" from "); + Write_Location (Loc); + Write_Eol; + Indent; + end if; + + Trace_Scope (N, Body_Id, " Analyze subprogram: "); + + -- The real work is split out into the helper, so it can do "return;" + -- without skipping the debug output: + + Analyze_Subprogram_Body_Helper (N); + + if Debug_Flag_C then + Outdent; + Write_Str ("<== subprogram body "); + Write_Name (Chars (Body_Id)); + Write_Str (" from "); + Write_Location (Loc); + Write_Eol; + end if; + end Analyze_Subprogram_Body; + + ------------------------------------ + -- Analyze_Subprogram_Body_Helper -- + ------------------------------------ + + -- This procedure is called for regular subprogram bodies, generic bodies, + -- and for subprogram stubs of both kinds. In the case of stubs, only the + -- specification matters, and is used to create a proper declaration for + -- the subprogram, or to perform conformance checks. + + procedure Analyze_Subprogram_Body_Helper (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Body_Deleted : constant Boolean := False; + Body_Spec : constant Node_Id := Specification (N); + Body_Id : Entity_Id := Defining_Entity (Body_Spec); + Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id); + Conformant : Boolean; + HSS : Node_Id; + P_Ent : Entity_Id; + Prot_Typ : Entity_Id := Empty; + Spec_Id : Entity_Id; + Spec_Decl : Node_Id := Empty; + + Last_Real_Spec_Entity : Entity_Id := Empty; + -- When we analyze a separate spec, the entity chain ends up containing + -- the formals, as well as any itypes generated during analysis of the + -- default expressions for parameters, or the arguments of associated + -- precondition/postcondition pragmas (which are analyzed in the context + -- of the spec since they have visibility on formals). + -- + -- These entities belong with the spec and not the body. However we do + -- the analysis of the body in the context of the spec (again to obtain + -- visibility to the formals), and all the entities generated during + -- this analysis end up also chained to the entity chain of the spec. + -- But they really belong to the body, and there is circuitry to move + -- them from the spec to the body. + -- + -- However, when we do this move, we don't want to move the real spec + -- entities (first para above) to the body. The Last_Real_Spec_Entity + -- variable points to the last real spec entity, so we only move those + -- chained beyond that point. It is initialized to Empty to deal with + -- the case where there is no separate spec. + + procedure Check_Anonymous_Return; + -- Ada 2005: if a function returns an access type that denotes a task, + -- or a type that contains tasks, we must create a master entity for + -- the anonymous type, which typically will be used in an allocator + -- in the body of the function. + + procedure Check_Inline_Pragma (Spec : in out Node_Id); + -- Look ahead to recognize a pragma that may appear after the body. + -- If there is a previous spec, check that it appears in the same + -- declarative part. If the pragma is Inline_Always, perform inlining + -- unconditionally, otherwise only if Front_End_Inlining is requested. + -- If the body acts as a spec, and inlining is required, we create a + -- subprogram declaration for it, in order to attach the body to inline. + -- If pragma does not appear after the body, check whether there is + -- an inline pragma before any local declarations. + + procedure Check_Missing_Return; + -- Checks for a function with a no return statements, and also performs + -- the warning checks implemented by Check_Returns. + + function Disambiguate_Spec return Entity_Id; + -- When a primitive is declared between the private view and the full + -- view of a concurrent type which implements an interface, a special + -- mechanism is used to find the corresponding spec of the primitive + -- body. + + function Is_Private_Concurrent_Primitive + (Subp_Id : Entity_Id) return Boolean; + -- Determine whether subprogram Subp_Id is a primitive of a concurrent + -- type that implements an interface and has a private view. + + procedure Set_Trivial_Subprogram (N : Node_Id); + -- Sets the Is_Trivial_Subprogram flag in both spec and body of the + -- subprogram whose body is being analyzed. N is the statement node + -- causing the flag to be set, if the following statement is a return + -- of an entity, we mark the entity as set in source to suppress any + -- warning on the stylized use of function stubs with a dummy return. + + procedure Verify_Overriding_Indicator; + -- If there was a previous spec, the entity has been entered in the + -- current scope previously. If the body itself carries an overriding + -- indicator, check that it is consistent with the known status of the + -- entity. + + ---------------------------- + -- Check_Anonymous_Return -- + ---------------------------- + + procedure Check_Anonymous_Return is + Decl : Node_Id; + Par : Node_Id; + Scop : Entity_Id; + + begin + if Present (Spec_Id) then + Scop := Spec_Id; + else + Scop := Body_Id; + end if; + + if Ekind (Scop) = E_Function + and then Ekind (Etype (Scop)) = E_Anonymous_Access_Type + and then not Is_Thunk (Scop) + and then (Has_Task (Designated_Type (Etype (Scop))) + or else + (Is_Class_Wide_Type (Designated_Type (Etype (Scop))) + and then + Is_Limited_Record (Designated_Type (Etype (Scop))))) + and then Expander_Active + + -- Avoid cases with no tasking support + + and then RTE_Available (RE_Current_Master) + and then not Restriction_Active (No_Task_Hierarchy) + then + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uMaster), + Constant_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Master_Id), Loc), + Expression => + Make_Explicit_Dereference (Loc, + New_Reference_To (RTE (RE_Current_Master), Loc))); + + if Present (Declarations (N)) then + Prepend (Decl, Declarations (N)); + else + Set_Declarations (N, New_List (Decl)); + end if; + + Set_Master_Id (Etype (Scop), Defining_Identifier (Decl)); + Set_Has_Master_Entity (Scop); + + -- Now mark the containing scope as a task master + + Par := N; + while Nkind (Par) /= N_Compilation_Unit loop + Par := Parent (Par); + pragma Assert (Present (Par)); + + -- If we fall off the top, we are at the outer level, and + -- the environment task is our effective master, so nothing + -- to mark. + + if Nkind_In + (Par, N_Task_Body, N_Block_Statement, N_Subprogram_Body) + then + Set_Is_Task_Master (Par, True); + exit; + end if; + end loop; + end if; + end Check_Anonymous_Return; + + ------------------------- + -- Check_Inline_Pragma -- + ------------------------- + + procedure Check_Inline_Pragma (Spec : in out Node_Id) is + Prag : Node_Id; + Plist : List_Id; + + function Is_Inline_Pragma (N : Node_Id) return Boolean; + -- True when N is a pragma Inline or Inline_Always that applies + -- to this subprogram. + + ----------------------- + -- Is_Inline_Pragma -- + ----------------------- + + function Is_Inline_Pragma (N : Node_Id) return Boolean is + begin + return + Nkind (N) = N_Pragma + and then + (Pragma_Name (N) = Name_Inline_Always + or else + (Front_End_Inlining + and then Pragma_Name (N) = Name_Inline)) + and then + Chars + (Expression (First (Pragma_Argument_Associations (N)))) + = Chars (Body_Id); + end Is_Inline_Pragma; + + -- Start of processing for Check_Inline_Pragma + + begin + if not Expander_Active then + return; + end if; + + if Is_List_Member (N) + and then Present (Next (N)) + and then Is_Inline_Pragma (Next (N)) + then + Prag := Next (N); + + elsif Nkind (N) /= N_Subprogram_Body_Stub + and then Present (Declarations (N)) + and then Is_Inline_Pragma (First (Declarations (N))) + then + Prag := First (Declarations (N)); + + else + Prag := Empty; + end if; + + if Present (Prag) then + if Present (Spec_Id) then + if In_Same_List (N, Unit_Declaration_Node (Spec_Id)) then + Analyze (Prag); + end if; + + else + -- Create a subprogram declaration, to make treatment uniform + + declare + Subp : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars (Body_Id)); + Decl : constant Node_Id := + Make_Subprogram_Declaration (Loc, + Specification => + New_Copy_Tree (Specification (N))); + + begin + Set_Defining_Unit_Name (Specification (Decl), Subp); + + if Present (First_Formal (Body_Id)) then + Plist := Copy_Parameter_List (Body_Id); + Set_Parameter_Specifications + (Specification (Decl), Plist); + end if; + + Insert_Before (N, Decl); + Analyze (Decl); + Analyze (Prag); + Set_Has_Pragma_Inline (Subp); + + if Pragma_Name (Prag) = Name_Inline_Always then + Set_Is_Inlined (Subp); + Set_Has_Pragma_Inline_Always (Subp); + end if; + + Spec := Subp; + end; + end if; + end if; + end Check_Inline_Pragma; + + -------------------------- + -- Check_Missing_Return -- + -------------------------- + + procedure Check_Missing_Return is + Id : Entity_Id; + Missing_Ret : Boolean; + + begin + if Nkind (Body_Spec) = N_Function_Specification then + if Present (Spec_Id) then + Id := Spec_Id; + else + Id := Body_Id; + end if; + + if Return_Present (Id) then + Check_Returns (HSS, 'F', Missing_Ret); + + if Missing_Ret then + Set_Has_Missing_Return (Id); + end if; + + elsif (Is_Generic_Subprogram (Id) + or else not Is_Machine_Code_Subprogram (Id)) + and then not Body_Deleted + then + Error_Msg_N ("missing RETURN statement in function body", N); + end if; + + -- If procedure with No_Return, check returns + + elsif Nkind (Body_Spec) = N_Procedure_Specification + and then Present (Spec_Id) + and then No_Return (Spec_Id) + then + Check_Returns (HSS, 'P', Missing_Ret, Spec_Id); + end if; + end Check_Missing_Return; + + ----------------------- + -- Disambiguate_Spec -- + ----------------------- + + function Disambiguate_Spec return Entity_Id is + Priv_Spec : Entity_Id; + Spec_N : Entity_Id; + + procedure Replace_Types (To_Corresponding : Boolean); + -- Depending on the flag, replace the type of formal parameters of + -- Body_Id if it is a concurrent type implementing interfaces with + -- the corresponding record type or the other way around. + + procedure Replace_Types (To_Corresponding : Boolean) is + Formal : Entity_Id; + Formal_Typ : Entity_Id; + + begin + Formal := First_Formal (Body_Id); + while Present (Formal) loop + Formal_Typ := Etype (Formal); + + -- From concurrent type to corresponding record + + if To_Corresponding then + if Is_Concurrent_Type (Formal_Typ) + and then Present (Corresponding_Record_Type (Formal_Typ)) + and then Present (Interfaces ( + Corresponding_Record_Type (Formal_Typ))) + then + Set_Etype (Formal, + Corresponding_Record_Type (Formal_Typ)); + end if; + + -- From corresponding record to concurrent type + + else + if Is_Concurrent_Record_Type (Formal_Typ) + and then Present (Interfaces (Formal_Typ)) + then + Set_Etype (Formal, + Corresponding_Concurrent_Type (Formal_Typ)); + end if; + end if; + + Next_Formal (Formal); + end loop; + end Replace_Types; + + -- Start of processing for Disambiguate_Spec + + begin + -- Try to retrieve the specification of the body as is. All error + -- messages are suppressed because the body may not have a spec in + -- its current state. + + Spec_N := Find_Corresponding_Spec (N, False); + + -- It is possible that this is the body of a primitive declared + -- between a private and a full view of a concurrent type. The + -- controlling parameter of the spec carries the concurrent type, + -- not the corresponding record type as transformed by Analyze_ + -- Subprogram_Specification. In such cases, we undo the change + -- made by the analysis of the specification and try to find the + -- spec again. + + -- Note that wrappers already have their corresponding specs and + -- bodies set during their creation, so if the candidate spec is + -- a wrapper, then we definitely need to swap all types to their + -- original concurrent status. + + if No (Spec_N) + or else Is_Primitive_Wrapper (Spec_N) + then + -- Restore all references of corresponding record types to the + -- original concurrent types. + + Replace_Types (To_Corresponding => False); + Priv_Spec := Find_Corresponding_Spec (N, False); + + -- The current body truly belongs to a primitive declared between + -- a private and a full view. We leave the modified body as is, + -- and return the true spec. + + if Present (Priv_Spec) + and then Is_Private_Primitive (Priv_Spec) + then + return Priv_Spec; + end if; + + -- In case that this is some sort of error, restore the original + -- state of the body. + + Replace_Types (To_Corresponding => True); + end if; + + return Spec_N; + end Disambiguate_Spec; + + ------------------------------------- + -- Is_Private_Concurrent_Primitive -- + ------------------------------------- + + function Is_Private_Concurrent_Primitive + (Subp_Id : Entity_Id) return Boolean + is + Formal_Typ : Entity_Id; + + begin + if Present (First_Formal (Subp_Id)) then + Formal_Typ := Etype (First_Formal (Subp_Id)); + + if Is_Concurrent_Record_Type (Formal_Typ) then + Formal_Typ := Corresponding_Concurrent_Type (Formal_Typ); + end if; + + -- The type of the first formal is a concurrent tagged type with + -- a private view. + + return + Is_Concurrent_Type (Formal_Typ) + and then Is_Tagged_Type (Formal_Typ) + and then Has_Private_Declaration (Formal_Typ); + end if; + + return False; + end Is_Private_Concurrent_Primitive; + + ---------------------------- + -- Set_Trivial_Subprogram -- + ---------------------------- + + procedure Set_Trivial_Subprogram (N : Node_Id) is + Nxt : constant Node_Id := Next (N); + + begin + Set_Is_Trivial_Subprogram (Body_Id); + + if Present (Spec_Id) then + Set_Is_Trivial_Subprogram (Spec_Id); + end if; + + if Present (Nxt) + and then Nkind (Nxt) = N_Simple_Return_Statement + and then No (Next (Nxt)) + and then Present (Expression (Nxt)) + and then Is_Entity_Name (Expression (Nxt)) + then + Set_Never_Set_In_Source (Entity (Expression (Nxt)), False); + end if; + end Set_Trivial_Subprogram; + + --------------------------------- + -- Verify_Overriding_Indicator -- + --------------------------------- + + procedure Verify_Overriding_Indicator is + begin + if Must_Override (Body_Spec) then + if Nkind (Spec_Id) = N_Defining_Operator_Symbol + and then Operator_Matches_Spec (Spec_Id, Spec_Id) + then + null; + + elsif not Present (Overridden_Operation (Spec_Id)) then + Error_Msg_NE + ("subprogram& is not overriding", Body_Spec, Spec_Id); + end if; + + elsif Must_Not_Override (Body_Spec) then + if Present (Overridden_Operation (Spec_Id)) then + Error_Msg_NE + ("subprogram& overrides inherited operation", + Body_Spec, Spec_Id); + + elsif Nkind (Spec_Id) = N_Defining_Operator_Symbol + and then Operator_Matches_Spec (Spec_Id, Spec_Id) + then + Error_Msg_NE + ("subprogram & overrides predefined operator ", + Body_Spec, Spec_Id); + + -- If this is not a primitive operation or protected subprogram, + -- then the overriding indicator is altogether illegal. + + elsif not Is_Primitive (Spec_Id) + and then Ekind (Scope (Spec_Id)) /= E_Protected_Type + then + Error_Msg_N + ("overriding indicator only allowed " & + "if subprogram is primitive", + Body_Spec); + end if; + + elsif Style_Check -- ??? incorrect use of Style_Check! + and then Present (Overridden_Operation (Spec_Id)) + then + pragma Assert (Unit_Declaration_Node (Body_Id) = N); + Style.Missing_Overriding (N, Body_Id); + end if; + end Verify_Overriding_Indicator; + + -- Start of processing for Analyze_Subprogram_Body_Helper + + begin + -- Generic subprograms are handled separately. They always have a + -- generic specification. Determine whether current scope has a + -- previous declaration. + + -- If the subprogram body is defined within an instance of the same + -- name, the instance appears as a package renaming, and will be hidden + -- within the subprogram. + + if Present (Prev_Id) + and then not Is_Overloadable (Prev_Id) + and then (Nkind (Parent (Prev_Id)) /= N_Package_Renaming_Declaration + or else Comes_From_Source (Prev_Id)) + then + if Is_Generic_Subprogram (Prev_Id) then + Spec_Id := Prev_Id; + Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id)); + Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id)); + + Analyze_Generic_Subprogram_Body (N, Spec_Id); + + if Nkind (N) = N_Subprogram_Body then + HSS := Handled_Statement_Sequence (N); + Check_Missing_Return; + end if; + + return; + + else + -- Previous entity conflicts with subprogram name. Attempting to + -- enter name will post error. + + Enter_Name (Body_Id); + return; + end if; + + -- Non-generic case, find the subprogram declaration, if one was seen, + -- or enter new overloaded entity in the current scope. If the + -- Current_Entity is the Body_Id itself, the unit is being analyzed as + -- part of the context of one of its subunits. No need to redo the + -- analysis. + + elsif Prev_Id = Body_Id + and then Has_Completion (Body_Id) + then + return; + + else + Body_Id := Analyze_Subprogram_Specification (Body_Spec); + + if Nkind (N) = N_Subprogram_Body_Stub + or else No (Corresponding_Spec (N)) + then + if Is_Private_Concurrent_Primitive (Body_Id) then + Spec_Id := Disambiguate_Spec; + else + Spec_Id := Find_Corresponding_Spec (N); + end if; + + -- If this is a duplicate body, no point in analyzing it + + if Error_Posted (N) then + return; + end if; + + -- A subprogram body should cause freezing of its own declaration, + -- but if there was no previous explicit declaration, then the + -- subprogram will get frozen too late (there may be code within + -- the body that depends on the subprogram having been frozen, + -- such as uses of extra formals), so we force it to be frozen + -- here. Same holds if the body and spec are compilation units. + -- Finally, if the return type is an anonymous access to protected + -- subprogram, it must be frozen before the body because its + -- expansion has generated an equivalent type that is used when + -- elaborating the body. + + if No (Spec_Id) then + Freeze_Before (N, Body_Id); + + elsif Nkind (Parent (N)) = N_Compilation_Unit then + Freeze_Before (N, Spec_Id); + + elsif Is_Access_Subprogram_Type (Etype (Body_Id)) then + Freeze_Before (N, Etype (Body_Id)); + end if; + + else + Spec_Id := Corresponding_Spec (N); + end if; + end if; + + -- Do not inline any subprogram that contains nested subprograms, since + -- the backend inlining circuit seems to generate uninitialized + -- references in this case. We know this happens in the case of front + -- end ZCX support, but it also appears it can happen in other cases as + -- well. The backend often rejects attempts to inline in the case of + -- nested procedures anyway, so little if anything is lost by this. + -- Note that this is test is for the benefit of the back-end. There is + -- a separate test for front-end inlining that also rejects nested + -- subprograms. + + -- Do not do this test if errors have been detected, because in some + -- error cases, this code blows up, and we don't need it anyway if + -- there have been errors, since we won't get to the linker anyway. + + if Comes_From_Source (Body_Id) + and then Serious_Errors_Detected = 0 + then + P_Ent := Body_Id; + loop + P_Ent := Scope (P_Ent); + exit when No (P_Ent) or else P_Ent = Standard_Standard; + + if Is_Subprogram (P_Ent) then + Set_Is_Inlined (P_Ent, False); + + if Comes_From_Source (P_Ent) + and then Has_Pragma_Inline (P_Ent) + then + Cannot_Inline + ("cannot inline& (nested subprogram)?", + N, P_Ent); + end if; + end if; + end loop; + end if; + + Check_Inline_Pragma (Spec_Id); + + -- Deal with special case of a fully private operation in the body of + -- the protected type. We must create a declaration for the subprogram, + -- in order to attach the protected subprogram that will be used in + -- internal calls. We exclude compiler generated bodies from the + -- expander since the issue does not arise for those cases. + + if No (Spec_Id) + and then Comes_From_Source (N) + and then Is_Protected_Type (Current_Scope) + then + Spec_Id := Build_Private_Protected_Declaration (N); + end if; + + -- If a separate spec is present, then deal with freezing issues + + if Present (Spec_Id) then + Spec_Decl := Unit_Declaration_Node (Spec_Id); + Verify_Overriding_Indicator; + + -- In general, the spec will be frozen when we start analyzing the + -- body. However, for internally generated operations, such as + -- wrapper functions for inherited operations with controlling + -- results, the spec may not have been frozen by the time we + -- expand the freeze actions that include the bodies. In particular, + -- extra formals for accessibility or for return-in-place may need + -- to be generated. Freeze nodes, if any, are inserted before the + -- current body. + + if not Is_Frozen (Spec_Id) + and then Expander_Active + then + -- Force the generation of its freezing node to ensure proper + -- management of access types in the backend. + + -- This is definitely needed for some cases, but it is not clear + -- why, to be investigated further??? + + Set_Has_Delayed_Freeze (Spec_Id); + Freeze_Before (N, Spec_Id); + end if; + end if; + + -- Mark presence of postcondition procedure in current scope and mark + -- the procedure itself as needing debug info. The latter is important + -- when analyzing decision coverage (for example, for MC/DC coverage). + + if Chars (Body_Id) = Name_uPostconditions then + Set_Has_Postconditions (Current_Scope); + Set_Debug_Info_Needed (Body_Id); + end if; + + -- Place subprogram on scope stack, and make formals visible. If there + -- is a spec, the visible entity remains that of the spec. + + if Present (Spec_Id) then + Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False); + + if Is_Child_Unit (Spec_Id) then + Generate_Reference (Spec_Id, Scope (Spec_Id), 'k', False); + end if; + + if Style_Check then + Style.Check_Identifier (Body_Id, Spec_Id); + end if; + + Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id)); + Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id)); + + if Is_Abstract_Subprogram (Spec_Id) then + Error_Msg_N ("an abstract subprogram cannot have a body", N); + return; + + else + Set_Convention (Body_Id, Convention (Spec_Id)); + Set_Has_Completion (Spec_Id); + + if Is_Protected_Type (Scope (Spec_Id)) then + Prot_Typ := Scope (Spec_Id); + end if; + + -- If this is a body generated for a renaming, do not check for + -- full conformance. The check is redundant, because the spec of + -- the body is a copy of the spec in the renaming declaration, + -- and the test can lead to spurious errors on nested defaults. + + if Present (Spec_Decl) + and then not Comes_From_Source (N) + and then + (Nkind (Original_Node (Spec_Decl)) = + N_Subprogram_Renaming_Declaration + or else (Present (Corresponding_Body (Spec_Decl)) + and then + Nkind (Unit_Declaration_Node + (Corresponding_Body (Spec_Decl))) = + N_Subprogram_Renaming_Declaration)) + then + Conformant := True; + + -- Conversely, the spec may have been generated for specless body + -- with an inline pragma. + + elsif Comes_From_Source (N) + and then not Comes_From_Source (Spec_Id) + and then Has_Pragma_Inline (Spec_Id) + then + Conformant := True; + + else + Check_Conformance + (Body_Id, Spec_Id, + Fully_Conformant, True, Conformant, Body_Id); + end if; + + -- If the body is not fully conformant, we have to decide if we + -- should analyze it or not. If it has a really messed up profile + -- then we probably should not analyze it, since we will get too + -- many bogus messages. + + -- Our decision is to go ahead in the non-fully conformant case + -- only if it is at least mode conformant with the spec. Note + -- that the call to Check_Fully_Conformant has issued the proper + -- error messages to complain about the lack of conformance. + + if not Conformant + and then not Mode_Conformant (Body_Id, Spec_Id) + then + return; + end if; + end if; + + if Spec_Id /= Body_Id then + Reference_Body_Formals (Spec_Id, Body_Id); + end if; + + if Nkind (N) /= N_Subprogram_Body_Stub then + Set_Corresponding_Spec (N, Spec_Id); + + -- Ada 2005 (AI-345): If the operation is a primitive operation + -- of a concurrent type, the type of the first parameter has been + -- replaced with the corresponding record, which is the proper + -- run-time structure to use. However, within the body there may + -- be uses of the formals that depend on primitive operations + -- of the type (in particular calls in prefixed form) for which + -- we need the original concurrent type. The operation may have + -- several controlling formals, so the replacement must be done + -- for all of them. + + if Comes_From_Source (Spec_Id) + and then Present (First_Entity (Spec_Id)) + and then Ekind (Etype (First_Entity (Spec_Id))) = E_Record_Type + and then Is_Tagged_Type (Etype (First_Entity (Spec_Id))) + and then + Present (Interfaces (Etype (First_Entity (Spec_Id)))) + and then + Present + (Corresponding_Concurrent_Type + (Etype (First_Entity (Spec_Id)))) + then + declare + Typ : constant Entity_Id := Etype (First_Entity (Spec_Id)); + Form : Entity_Id; + + begin + Form := First_Formal (Spec_Id); + while Present (Form) loop + if Etype (Form) = Typ then + Set_Etype (Form, Corresponding_Concurrent_Type (Typ)); + end if; + + Next_Formal (Form); + end loop; + end; + end if; + + -- Make the formals visible, and place subprogram on scope stack. + -- This is also the point at which we set Last_Real_Spec_Entity + -- to mark the entities which will not be moved to the body. + + Install_Formals (Spec_Id); + Last_Real_Spec_Entity := Last_Entity (Spec_Id); + Push_Scope (Spec_Id); + + -- Make sure that the subprogram is immediately visible. For + -- child units that have no separate spec this is indispensable. + -- Otherwise it is safe albeit redundant. + + Set_Is_Immediately_Visible (Spec_Id); + end if; + + Set_Corresponding_Body (Unit_Declaration_Node (Spec_Id), Body_Id); + Set_Ekind (Body_Id, E_Subprogram_Body); + Set_Scope (Body_Id, Scope (Spec_Id)); + Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Spec_Id)); + + -- Case of subprogram body with no previous spec + + else + -- Check for style warning required + + if Style_Check + + -- Only apply check for source level subprograms for which checks + -- have not been suppressed. + + and then Comes_From_Source (Body_Id) + and then not Suppress_Style_Checks (Body_Id) + + -- No warnings within an instance + + and then not In_Instance + + -- No warnings for parameterized expressions + + and then Nkind (Original_Node (N)) /= N_Parameterized_Expression + then + Style.Body_With_No_Spec (N); + end if; + + New_Overloaded_Entity (Body_Id); + + if Nkind (N) /= N_Subprogram_Body_Stub then + Set_Acts_As_Spec (N); + Generate_Definition (Body_Id); + Generate_Reference + (Body_Id, Body_Id, 'b', Set_Ref => False, Force => True); + Generate_Reference_To_Formals (Body_Id); + Install_Formals (Body_Id); + Push_Scope (Body_Id); + end if; + end if; + + -- If the return type is an anonymous access type whose designated type + -- is the limited view of a class-wide type and the non-limited view is + -- available, update the return type accordingly. + + if Ada_Version >= Ada_2005 + and then Comes_From_Source (N) + then + declare + Etyp : Entity_Id; + Rtyp : Entity_Id; + + begin + Rtyp := Etype (Current_Scope); + + if Ekind (Rtyp) = E_Anonymous_Access_Type then + Etyp := Directly_Designated_Type (Rtyp); + + if Is_Class_Wide_Type (Etyp) + and then From_With_Type (Etyp) + then + Set_Directly_Designated_Type + (Etype (Current_Scope), Available_View (Etyp)); + end if; + end if; + end; + end if; + + -- If this is the proper body of a stub, we must verify that the stub + -- conforms to the body, and to the previous spec if one was present. + -- we know already that the body conforms to that spec. This test is + -- only required for subprograms that come from source. + + if Nkind (Parent (N)) = N_Subunit + and then Comes_From_Source (N) + and then not Error_Posted (Body_Id) + and then Nkind (Corresponding_Stub (Parent (N))) = + N_Subprogram_Body_Stub + then + declare + Old_Id : constant Entity_Id := + Defining_Entity + (Specification (Corresponding_Stub (Parent (N)))); + + Conformant : Boolean := False; + + begin + if No (Spec_Id) then + Check_Fully_Conformant (Body_Id, Old_Id); + + else + Check_Conformance + (Body_Id, Old_Id, Fully_Conformant, False, Conformant); + + if not Conformant then + + -- The stub was taken to be a new declaration. Indicate + -- that it lacks a body. + + Set_Has_Completion (Old_Id, False); + end if; + end if; + end; + end if; + + Set_Has_Completion (Body_Id); + Check_Eliminated (Body_Id); + + if Nkind (N) = N_Subprogram_Body_Stub then + return; + + elsif Present (Spec_Id) + and then Expander_Active + and then + (Has_Pragma_Inline_Always (Spec_Id) + or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining)) + then + Build_Body_To_Inline (N, Spec_Id); + end if; + + -- Ada 2005 (AI-262): In library subprogram bodies, after the analysis + -- if its specification we have to install the private withed units. + -- This holds for child units as well. + + if Is_Compilation_Unit (Body_Id) + or else Nkind (Parent (N)) = N_Compilation_Unit + then + Install_Private_With_Clauses (Body_Id); + end if; + + Check_Anonymous_Return; + + -- Set the Protected_Formal field of each extra formal of the protected + -- subprogram to reference the corresponding extra formal of the + -- subprogram that implements it. For regular formals this occurs when + -- the protected subprogram's declaration is expanded, but the extra + -- formals don't get created until the subprogram is frozen. We need to + -- do this before analyzing the protected subprogram's body so that any + -- references to the original subprogram's extra formals will be changed + -- refer to the implementing subprogram's formals (see Expand_Formal). + + if Present (Spec_Id) + and then Is_Protected_Type (Scope (Spec_Id)) + and then Present (Protected_Body_Subprogram (Spec_Id)) + then + declare + Impl_Subp : constant Entity_Id := + Protected_Body_Subprogram (Spec_Id); + Prot_Ext_Formal : Entity_Id := Extra_Formals (Spec_Id); + Impl_Ext_Formal : Entity_Id := Extra_Formals (Impl_Subp); + begin + while Present (Prot_Ext_Formal) loop + pragma Assert (Present (Impl_Ext_Formal)); + Set_Protected_Formal (Prot_Ext_Formal, Impl_Ext_Formal); + Next_Formal_With_Extras (Prot_Ext_Formal); + Next_Formal_With_Extras (Impl_Ext_Formal); + end loop; + end; + end if; + + -- Now we can go on to analyze the body + + HSS := Handled_Statement_Sequence (N); + Set_Actual_Subtypes (N, Current_Scope); + + -- Deal with preconditions and postconditions + + Process_PPCs (N, Spec_Id, Body_Id); + + -- Add a declaration for the Protection object, renaming declarations + -- for discriminals and privals and finally a declaration for the entry + -- family index (if applicable). This form of early expansion is done + -- when the Expander is active because Install_Private_Data_Declarations + -- references entities which were created during regular expansion. + + if Expander_Active + and then Comes_From_Source (N) + and then Present (Prot_Typ) + and then Present (Spec_Id) + and then not Is_Eliminated (Spec_Id) + then + Install_Private_Data_Declarations + (Sloc (N), Spec_Id, Prot_Typ, N, Declarations (N)); + end if; + + -- Analyze the declarations (this call will analyze the precondition + -- Check pragmas we prepended to the list, as well as the declaration + -- of the _Postconditions procedure). + + Analyze_Declarations (Declarations (N)); + + -- Check completion, and analyze the statements + + Check_Completion; + Inspect_Deferred_Constant_Completion (Declarations (N)); + Analyze (HSS); + + -- Deal with end of scope processing for the body + + Process_End_Label (HSS, 't', Current_Scope); + End_Scope; + Check_Subprogram_Order (N); + Set_Analyzed (Body_Id); + + -- If we have a separate spec, then the analysis of the declarations + -- caused the entities in the body to be chained to the spec id, but + -- we want them chained to the body id. Only the formal parameters + -- end up chained to the spec id in this case. + + if Present (Spec_Id) then + + -- We must conform to the categorization of our spec + + Validate_Categorization_Dependency (N, Spec_Id); + + -- And if this is a child unit, the parent units must conform + + if Is_Child_Unit (Spec_Id) then + Validate_Categorization_Dependency + (Unit_Declaration_Node (Spec_Id), Spec_Id); + end if; + + -- Here is where we move entities from the spec to the body + + -- Case where there are entities that stay with the spec + + if Present (Last_Real_Spec_Entity) then + + -- No body entities (happens when the only real spec entities + -- come from precondition and postcondition pragmas) + + if No (Last_Entity (Body_Id)) then + Set_First_Entity + (Body_Id, Next_Entity (Last_Real_Spec_Entity)); + + -- Body entities present (formals), so chain stuff past them + + else + Set_Next_Entity + (Last_Entity (Body_Id), Next_Entity (Last_Real_Spec_Entity)); + end if; + + Set_Next_Entity (Last_Real_Spec_Entity, Empty); + Set_Last_Entity (Body_Id, Last_Entity (Spec_Id)); + Set_Last_Entity (Spec_Id, Last_Real_Spec_Entity); + + -- Case where there are no spec entities, in this case there can + -- be no body entities either, so just move everything. + + else + pragma Assert (No (Last_Entity (Body_Id))); + Set_First_Entity (Body_Id, First_Entity (Spec_Id)); + Set_Last_Entity (Body_Id, Last_Entity (Spec_Id)); + Set_First_Entity (Spec_Id, Empty); + Set_Last_Entity (Spec_Id, Empty); + end if; + end if; + + Check_Missing_Return; + + -- Now we are going to check for variables that are never modified in + -- the body of the procedure. But first we deal with a special case + -- where we want to modify this check. If the body of the subprogram + -- starts with a raise statement or its equivalent, or if the body + -- consists entirely of a null statement, then it is pretty obvious + -- that it is OK to not reference the parameters. For example, this + -- might be the following common idiom for a stubbed function: + -- statement of the procedure raises an exception. In particular this + -- deals with the common idiom of a stubbed function, which might + -- appear as something like + + -- function F (A : Integer) return Some_Type; + -- X : Some_Type; + -- begin + -- raise Program_Error; + -- return X; + -- end F; + + -- Here the purpose of X is simply to satisfy the annoying requirement + -- in Ada that there be at least one return, and we certainly do not + -- want to go posting warnings on X that it is not initialized! On + -- the other hand, if X is entirely unreferenced that should still + -- get a warning. + + -- What we do is to detect these cases, and if we find them, flag the + -- subprogram as being Is_Trivial_Subprogram and then use that flag to + -- suppress unwanted warnings. For the case of the function stub above + -- we have a special test to set X as apparently assigned to suppress + -- the warning. + + declare + Stm : Node_Id; + + begin + -- Skip initial labels (for one thing this occurs when we are in + -- front end ZCX mode, but in any case it is irrelevant), and also + -- initial Push_xxx_Error_Label nodes, which are also irrelevant. + + Stm := First (Statements (HSS)); + while Nkind (Stm) = N_Label + or else Nkind (Stm) in N_Push_xxx_Label + loop + Next (Stm); + end loop; + + -- Do the test on the original statement before expansion + + declare + Ostm : constant Node_Id := Original_Node (Stm); + + begin + -- If explicit raise statement, turn on flag + + if Nkind (Ostm) = N_Raise_Statement then + Set_Trivial_Subprogram (Stm); + + -- If null statement, and no following statements, turn on flag + + elsif Nkind (Stm) = N_Null_Statement + and then Comes_From_Source (Stm) + and then No (Next (Stm)) + then + Set_Trivial_Subprogram (Stm); + + -- Check for explicit call cases which likely raise an exception + + elsif Nkind (Ostm) = N_Procedure_Call_Statement then + if Is_Entity_Name (Name (Ostm)) then + declare + Ent : constant Entity_Id := Entity (Name (Ostm)); + + begin + -- If the procedure is marked No_Return, then likely it + -- raises an exception, but in any case it is not coming + -- back here, so turn on the flag. + + if Ekind (Ent) = E_Procedure + and then No_Return (Ent) + then + Set_Trivial_Subprogram (Stm); + end if; + end; + end if; + end if; + end; + end; + + -- Check for variables that are never modified + + declare + E1, E2 : Entity_Id; + + begin + -- If there is a separate spec, then transfer Never_Set_In_Source + -- flags from out parameters to the corresponding entities in the + -- body. The reason we do that is we want to post error flags on + -- the body entities, not the spec entities. + + if Present (Spec_Id) then + E1 := First_Entity (Spec_Id); + while Present (E1) loop + if Ekind (E1) = E_Out_Parameter then + E2 := First_Entity (Body_Id); + while Present (E2) loop + exit when Chars (E1) = Chars (E2); + Next_Entity (E2); + end loop; + + if Present (E2) then + Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1)); + end if; + end if; + + Next_Entity (E1); + end loop; + end if; + + -- Check references in body unless it was deleted. Note that the + -- check of Body_Deleted here is not just for efficiency, it is + -- necessary to avoid junk warnings on formal parameters. + + if not Body_Deleted then + Check_References (Body_Id); + end if; + end; + end Analyze_Subprogram_Body_Helper; + + ------------------------------------ + -- Analyze_Subprogram_Declaration -- + ------------------------------------ + + procedure Analyze_Subprogram_Declaration (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Scop : constant Entity_Id := Current_Scope; + Designator : Entity_Id; + Form : Node_Id; + Null_Body : Node_Id := Empty; + + -- Start of processing for Analyze_Subprogram_Declaration + + begin + -- For a null procedure, capture the profile before analysis, for + -- expansion at the freeze point and at each point of call. The body + -- will only be used if the procedure has preconditions. In that case + -- the body is analyzed at the freeze point. + + if Nkind (Specification (N)) = N_Procedure_Specification + and then Null_Present (Specification (N)) + and then Expander_Active + then + Null_Body := + Make_Subprogram_Body (Loc, + Specification => + New_Copy_Tree (Specification (N)), + Declarations => + New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Make_Null_Statement (Loc)))); + + -- Create new entities for body and formals + + Set_Defining_Unit_Name (Specification (Null_Body), + Make_Defining_Identifier (Loc, Chars (Defining_Entity (N)))); + Set_Corresponding_Body (N, Defining_Entity (Null_Body)); + + Form := First (Parameter_Specifications (Specification (Null_Body))); + while Present (Form) loop + Set_Defining_Identifier (Form, + Make_Defining_Identifier (Loc, + Chars (Defining_Identifier (Form)))); + + -- Resolve the types of the formals now, because the freeze point + -- may appear in a different context, e.g. an instantiation. + + if Nkind (Parameter_Type (Form)) /= N_Access_Definition then + Find_Type (Parameter_Type (Form)); + + elsif + No (Access_To_Subprogram_Definition (Parameter_Type (Form))) + then + Find_Type (Subtype_Mark (Parameter_Type (Form))); + + else + + -- the case of a null procedure with a formal that is an + -- access_to_subprogram type, and that is used as an actual + -- in an instantiation is left to the enthusiastic reader. + + null; + end if; + + Next (Form); + end loop; + + if Is_Protected_Type (Current_Scope) then + Error_Msg_N ("protected operation cannot be a null procedure", N); + end if; + end if; + + Designator := Analyze_Subprogram_Specification (Specification (N)); + Generate_Definition (Designator); + + if Debug_Flag_C then + Write_Str ("==> subprogram spec "); + Write_Name (Chars (Designator)); + Write_Str (" from "); + Write_Location (Sloc (N)); + Write_Eol; + Indent; + end if; + + if Nkind (Specification (N)) = N_Procedure_Specification + and then Null_Present (Specification (N)) + then + Set_Has_Completion (Designator); + + if Present (Null_Body) then + Set_Corresponding_Body (N, Defining_Entity (Null_Body)); + Set_Body_To_Inline (N, Null_Body); + Set_Is_Inlined (Designator); + end if; + end if; + + Validate_RCI_Subprogram_Declaration (N); + New_Overloaded_Entity (Designator); + Check_Delayed_Subprogram (Designator); + + -- If the type of the first formal of the current subprogram is a + -- nongeneric tagged private type, mark the subprogram as being a + -- private primitive. Ditto if this is a function with controlling + -- result, and the return type is currently private. In both cases, + -- the type of the controlling argument or result must be in the + -- current scope for the operation to be primitive. + + if Has_Controlling_Result (Designator) + and then Is_Private_Type (Etype (Designator)) + and then Scope (Etype (Designator)) = Current_Scope + and then not Is_Generic_Actual_Type (Etype (Designator)) + then + Set_Is_Private_Primitive (Designator); + + elsif Present (First_Formal (Designator)) then + declare + Formal_Typ : constant Entity_Id := + Etype (First_Formal (Designator)); + begin + Set_Is_Private_Primitive (Designator, + Is_Tagged_Type (Formal_Typ) + and then Scope (Formal_Typ) = Current_Scope + and then Is_Private_Type (Formal_Typ) + and then not Is_Generic_Actual_Type (Formal_Typ)); + end; + end if; + + -- Ada 2005 (AI-251): Abstract interface primitives must be abstract + -- or null. + + if Ada_Version >= Ada_2005 + and then Comes_From_Source (N) + and then Is_Dispatching_Operation (Designator) + then + declare + E : Entity_Id; + Etyp : Entity_Id; + + begin + if Has_Controlling_Result (Designator) then + Etyp := Etype (Designator); + + else + E := First_Entity (Designator); + while Present (E) + and then Is_Formal (E) + and then not Is_Controlling_Formal (E) + loop + Next_Entity (E); + end loop; + + Etyp := Etype (E); + end if; + + if Is_Access_Type (Etyp) then + Etyp := Directly_Designated_Type (Etyp); + end if; + + if Is_Interface (Etyp) + and then not Is_Abstract_Subprogram (Designator) + and then not (Ekind (Designator) = E_Procedure + and then Null_Present (Specification (N))) + then + Error_Msg_Name_1 := Chars (Defining_Entity (N)); + Error_Msg_N + ("(Ada 2005) interface subprogram % must be abstract or null", + N); + end if; + end; + end if; + + -- What is the following code for, it used to be + + -- ??? Set_Suppress_Elaboration_Checks + -- ??? (Designator, Elaboration_Checks_Suppressed (Designator)); + + -- The following seems equivalent, but a bit dubious + + if Elaboration_Checks_Suppressed (Designator) then + Set_Kill_Elaboration_Checks (Designator); + end if; + + if Scop /= Standard_Standard + and then not Is_Child_Unit (Designator) + then + Set_Categorization_From_Scope (Designator, Scop); + else + -- For a compilation unit, check for library-unit pragmas + + Push_Scope (Designator); + Set_Categorization_From_Pragmas (N); + Validate_Categorization_Dependency (N, Designator); + Pop_Scope; + end if; + + -- For a compilation unit, set body required. This flag will only be + -- reset if a valid Import or Interface pragma is processed later on. + + if Nkind (Parent (N)) = N_Compilation_Unit then + Set_Body_Required (Parent (N), True); + + if Ada_Version >= Ada_2005 + and then Nkind (Specification (N)) = N_Procedure_Specification + and then Null_Present (Specification (N)) + then + Error_Msg_N + ("null procedure cannot be declared at library level", N); + end if; + end if; + + Generate_Reference_To_Formals (Designator); + Check_Eliminated (Designator); + + if Debug_Flag_C then + Outdent; + Write_Str ("<== subprogram spec "); + Write_Name (Chars (Designator)); + Write_Str (" from "); + Write_Location (Sloc (N)); + Write_Eol; + end if; + + List_Inherited_Pre_Post_Aspects (Designator); + Analyze_Aspect_Specifications (N, Designator, Aspect_Specifications (N)); + end Analyze_Subprogram_Declaration; + + -------------------------------------- + -- Analyze_Subprogram_Specification -- + -------------------------------------- + + -- Reminder: N here really is a subprogram specification (not a subprogram + -- declaration). This procedure is called to analyze the specification in + -- both subprogram bodies and subprogram declarations (specs). + + function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is + Designator : constant Entity_Id := Defining_Entity (N); + Formals : constant List_Id := Parameter_Specifications (N); + + -- Start of processing for Analyze_Subprogram_Specification + + begin + Generate_Definition (Designator); + + if Nkind (N) = N_Function_Specification then + Set_Ekind (Designator, E_Function); + Set_Mechanism (Designator, Default_Mechanism); + else + Set_Ekind (Designator, E_Procedure); + Set_Etype (Designator, Standard_Void_Type); + end if; + + -- Introduce new scope for analysis of the formals and the return type + + Set_Scope (Designator, Current_Scope); + + if Present (Formals) then + Push_Scope (Designator); + Process_Formals (Formals, N); + + -- Ada 2005 (AI-345): If this is an overriding operation of an + -- inherited interface operation, and the controlling type is + -- a synchronized type, replace the type with its corresponding + -- record, to match the proper signature of an overriding operation. + -- Same processing for an access parameter whose designated type is + -- derived from a synchronized interface. + + if Ada_Version >= Ada_2005 then + declare + Formal : Entity_Id; + Formal_Typ : Entity_Id; + Rec_Typ : Entity_Id; + Desig_Typ : Entity_Id; + + begin + Formal := First_Formal (Designator); + while Present (Formal) loop + Formal_Typ := Etype (Formal); + + if Is_Concurrent_Type (Formal_Typ) + and then Present (Corresponding_Record_Type (Formal_Typ)) + then + Rec_Typ := Corresponding_Record_Type (Formal_Typ); + + if Present (Interfaces (Rec_Typ)) then + Set_Etype (Formal, Rec_Typ); + end if; + + elsif Ekind (Formal_Typ) = E_Anonymous_Access_Type then + Desig_Typ := Designated_Type (Formal_Typ); + + if Is_Concurrent_Type (Desig_Typ) + and then Present (Corresponding_Record_Type (Desig_Typ)) + then + Rec_Typ := Corresponding_Record_Type (Desig_Typ); + + if Present (Interfaces (Rec_Typ)) then + Set_Directly_Designated_Type (Formal_Typ, Rec_Typ); + end if; + end if; + end if; + + Next_Formal (Formal); + end loop; + end; + end if; + + End_Scope; + + -- The subprogram scope is pushed and popped around the processing of + -- the return type for consistency with call above to Process_Formals + -- (which itself can call Analyze_Return_Type), and to ensure that any + -- itype created for the return type will be associated with the proper + -- scope. + + elsif Nkind (N) = N_Function_Specification then + Push_Scope (Designator); + Analyze_Return_Type (N); + End_Scope; + end if; + + -- Function case + + if Nkind (N) = N_Function_Specification then + + -- Deal with operator symbol case + + if Nkind (Designator) = N_Defining_Operator_Symbol then + Valid_Operator_Definition (Designator); + end if; + + May_Need_Actuals (Designator); + + -- Ada 2005 (AI-251): If the return type is abstract, verify that + -- the subprogram is abstract also. This does not apply to renaming + -- declarations, where abstractness is inherited. + + -- In case of primitives associated with abstract interface types + -- the check is applied later (see Analyze_Subprogram_Declaration). + + if not Nkind_In (Parent (N), N_Subprogram_Renaming_Declaration, + N_Abstract_Subprogram_Declaration, + N_Formal_Abstract_Subprogram_Declaration) + then + if Is_Abstract_Type (Etype (Designator)) + and then not Is_Interface (Etype (Designator)) + then + Error_Msg_N + ("function that returns abstract type must be abstract", N); + + -- Ada 2012 (AI-0073): Extend this test to subprograms with an + -- access result whose designated type is abstract. + + elsif Nkind (Result_Definition (N)) = N_Access_Definition + and then + not Is_Class_Wide_Type (Designated_Type (Etype (Designator))) + and then Is_Abstract_Type (Designated_Type (Etype (Designator))) + and then Ada_Version >= Ada_2012 + then + Error_Msg_N ("function whose access result designates " + & "abstract type must be abstract", N); + end if; + end if; + end if; + + return Designator; + end Analyze_Subprogram_Specification; + + -------------------------- + -- Build_Body_To_Inline -- + -------------------------- + + procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id) is + Decl : constant Node_Id := Unit_Declaration_Node (Subp); + Original_Body : Node_Id; + Body_To_Analyze : Node_Id; + Max_Size : constant := 10; + Stat_Count : Integer := 0; + + function Has_Excluded_Declaration (Decls : List_Id) return Boolean; + -- Check for declarations that make inlining not worthwhile + + function Has_Excluded_Statement (Stats : List_Id) return Boolean; + -- Check for statements that make inlining not worthwhile: any tasking + -- statement, nested at any level. Keep track of total number of + -- elementary statements, as a measure of acceptable size. + + function Has_Pending_Instantiation return Boolean; + -- If some enclosing body contains instantiations that appear before the + -- corresponding generic body, the enclosing body has a freeze node so + -- that it can be elaborated after the generic itself. This might + -- conflict with subsequent inlinings, so that it is unsafe to try to + -- inline in such a case. + + function Has_Single_Return return Boolean; + -- In general we cannot inline functions that return unconstrained type. + -- However, we can handle such functions if all return statements return + -- a local variable that is the only declaration in the body of the + -- function. In that case the call can be replaced by that local + -- variable as is done for other inlined calls. + + procedure Remove_Pragmas; + -- A pragma Unreferenced or pragma Unmodified that mentions a formal + -- parameter has no meaning when the body is inlined and the formals + -- are rewritten. Remove it from body to inline. The analysis of the + -- non-inlined body will handle the pragma properly. + + function Uses_Secondary_Stack (Bod : Node_Id) return Boolean; + -- If the body of the subprogram includes a call that returns an + -- unconstrained type, the secondary stack is involved, and it + -- is not worth inlining. + + ------------------------------ + -- Has_Excluded_Declaration -- + ------------------------------ + + function Has_Excluded_Declaration (Decls : List_Id) return Boolean is + D : Node_Id; + + function Is_Unchecked_Conversion (D : Node_Id) return Boolean; + -- Nested subprograms make a given body ineligible for inlining, but + -- we make an exception for instantiations of unchecked conversion. + -- The body has not been analyzed yet, so check the name, and verify + -- that the visible entity with that name is the predefined unit. + + ----------------------------- + -- Is_Unchecked_Conversion -- + ----------------------------- + + function Is_Unchecked_Conversion (D : Node_Id) return Boolean is + Id : constant Node_Id := Name (D); + Conv : Entity_Id; + + begin + if Nkind (Id) = N_Identifier + and then Chars (Id) = Name_Unchecked_Conversion + then + Conv := Current_Entity (Id); + + elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name) + and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion + then + Conv := Current_Entity (Selector_Name (Id)); + else + return False; + end if; + + return Present (Conv) + and then Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Conv))) + and then Is_Intrinsic_Subprogram (Conv); + end Is_Unchecked_Conversion; + + -- Start of processing for Has_Excluded_Declaration + + begin + D := First (Decls); + while Present (D) loop + if (Nkind (D) = N_Function_Instantiation + and then not Is_Unchecked_Conversion (D)) + or else Nkind_In (D, N_Protected_Type_Declaration, + N_Package_Declaration, + N_Package_Instantiation, + N_Subprogram_Body, + N_Procedure_Instantiation, + N_Task_Type_Declaration) + then + Cannot_Inline + ("cannot inline & (non-allowed declaration)?", D, Subp); + return True; + end if; + + Next (D); + end loop; + + return False; + end Has_Excluded_Declaration; + + ---------------------------- + -- Has_Excluded_Statement -- + ---------------------------- + + function Has_Excluded_Statement (Stats : List_Id) return Boolean is + S : Node_Id; + E : Node_Id; + + begin + S := First (Stats); + while Present (S) loop + Stat_Count := Stat_Count + 1; + + if Nkind_In (S, N_Abort_Statement, + N_Asynchronous_Select, + N_Conditional_Entry_Call, + N_Delay_Relative_Statement, + N_Delay_Until_Statement, + N_Selective_Accept, + N_Timed_Entry_Call) + then + Cannot_Inline + ("cannot inline & (non-allowed statement)?", S, Subp); + return True; + + elsif Nkind (S) = N_Block_Statement then + if Present (Declarations (S)) + and then Has_Excluded_Declaration (Declarations (S)) + then + return True; + + elsif Present (Handled_Statement_Sequence (S)) + and then + (Present + (Exception_Handlers (Handled_Statement_Sequence (S))) + or else + Has_Excluded_Statement + (Statements (Handled_Statement_Sequence (S)))) + then + return True; + end if; + + elsif Nkind (S) = N_Case_Statement then + E := First (Alternatives (S)); + while Present (E) loop + if Has_Excluded_Statement (Statements (E)) then + return True; + end if; + + Next (E); + end loop; + + elsif Nkind (S) = N_If_Statement then + if Has_Excluded_Statement (Then_Statements (S)) then + return True; + end if; + + if Present (Elsif_Parts (S)) then + E := First (Elsif_Parts (S)); + while Present (E) loop + if Has_Excluded_Statement (Then_Statements (E)) then + return True; + end if; + Next (E); + end loop; + end if; + + if Present (Else_Statements (S)) + and then Has_Excluded_Statement (Else_Statements (S)) + then + return True; + end if; + + elsif Nkind (S) = N_Loop_Statement + and then Has_Excluded_Statement (Statements (S)) + then + return True; + + elsif Nkind (S) = N_Extended_Return_Statement then + if Has_Excluded_Statement + (Statements (Handled_Statement_Sequence (S))) + or else Present + (Exception_Handlers (Handled_Statement_Sequence (S))) + then + return True; + end if; + end if; + + Next (S); + end loop; + + return False; + end Has_Excluded_Statement; + + ------------------------------- + -- Has_Pending_Instantiation -- + ------------------------------- + + function Has_Pending_Instantiation return Boolean is + S : Entity_Id; + + begin + S := Current_Scope; + while Present (S) loop + if Is_Compilation_Unit (S) + or else Is_Child_Unit (S) + then + return False; + + elsif Ekind (S) = E_Package + and then Has_Forward_Instantiation (S) + then + return True; + end if; + + S := Scope (S); + end loop; + + return False; + end Has_Pending_Instantiation; + + ------------------------ + -- Has_Single_Return -- + ------------------------ + + function Has_Single_Return return Boolean is + Return_Statement : Node_Id := Empty; + + function Check_Return (N : Node_Id) return Traverse_Result; + + ------------------ + -- Check_Return -- + ------------------ + + function Check_Return (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Simple_Return_Statement then + if Present (Expression (N)) + and then Is_Entity_Name (Expression (N)) + then + if No (Return_Statement) then + Return_Statement := N; + return OK; + + elsif Chars (Expression (N)) = + Chars (Expression (Return_Statement)) + then + return OK; + + else + return Abandon; + end if; + + -- A return statement within an extended return is a noop + -- after inlining. + + elsif No (Expression (N)) + and then Nkind (Parent (Parent (N))) = + N_Extended_Return_Statement + then + return OK; + + else + -- Expression has wrong form + + return Abandon; + end if; + + -- We can only inline a build-in-place function if + -- it has a single extended return. + + elsif Nkind (N) = N_Extended_Return_Statement then + if No (Return_Statement) then + Return_Statement := N; + return OK; + + else + return Abandon; + end if; + + else + return OK; + end if; + end Check_Return; + + function Check_All_Returns is new Traverse_Func (Check_Return); + + -- Start of processing for Has_Single_Return + + begin + if Check_All_Returns (N) /= OK then + return False; + + elsif Nkind (Return_Statement) = N_Extended_Return_Statement then + return True; + + else + return Present (Declarations (N)) + and then Present (First (Declarations (N))) + and then Chars (Expression (Return_Statement)) = + Chars (Defining_Identifier (First (Declarations (N)))); + end if; + end Has_Single_Return; + + -------------------- + -- Remove_Pragmas -- + -------------------- + + procedure Remove_Pragmas is + Decl : Node_Id; + Nxt : Node_Id; + + begin + Decl := First (Declarations (Body_To_Analyze)); + while Present (Decl) loop + Nxt := Next (Decl); + + if Nkind (Decl) = N_Pragma + and then (Pragma_Name (Decl) = Name_Unreferenced + or else + Pragma_Name (Decl) = Name_Unmodified) + then + Remove (Decl); + end if; + + Decl := Nxt; + end loop; + end Remove_Pragmas; + + -------------------------- + -- Uses_Secondary_Stack -- + -------------------------- + + function Uses_Secondary_Stack (Bod : Node_Id) return Boolean is + function Check_Call (N : Node_Id) return Traverse_Result; + -- Look for function calls that return an unconstrained type + + ---------------- + -- Check_Call -- + ---------------- + + function Check_Call (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Function_Call + and then Is_Entity_Name (Name (N)) + and then Is_Composite_Type (Etype (Entity (Name (N)))) + and then not Is_Constrained (Etype (Entity (Name (N)))) + then + Cannot_Inline + ("cannot inline & (call returns unconstrained type)?", + N, Subp); + return Abandon; + else + return OK; + end if; + end Check_Call; + + function Check_Calls is new Traverse_Func (Check_Call); + + begin + return Check_Calls (Bod) = Abandon; + end Uses_Secondary_Stack; + + -- Start of processing for Build_Body_To_Inline + + begin + -- Return immediately if done already + + if Nkind (Decl) = N_Subprogram_Declaration + and then Present (Body_To_Inline (Decl)) + then + return; + + -- Functions that return unconstrained composite types require + -- secondary stack handling, and cannot currently be inlined, unless + -- all return statements return a local variable that is the first + -- local declaration in the body. + + elsif Ekind (Subp) = E_Function + and then not Is_Scalar_Type (Etype (Subp)) + and then not Is_Access_Type (Etype (Subp)) + and then not Is_Constrained (Etype (Subp)) + then + if not Has_Single_Return then + Cannot_Inline + ("cannot inline & (unconstrained return type)?", N, Subp); + return; + end if; + + -- Ditto for functions that return controlled types, where controlled + -- actions interfere in complex ways with inlining. + + elsif Ekind (Subp) = E_Function + and then Needs_Finalization (Etype (Subp)) + then + Cannot_Inline + ("cannot inline & (controlled return type)?", N, Subp); + return; + end if; + + if Present (Declarations (N)) + and then Has_Excluded_Declaration (Declarations (N)) + then + return; + end if; + + if Present (Handled_Statement_Sequence (N)) then + if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then + Cannot_Inline + ("cannot inline& (exception handler)?", + First (Exception_Handlers (Handled_Statement_Sequence (N))), + Subp); + return; + elsif + Has_Excluded_Statement + (Statements (Handled_Statement_Sequence (N))) + then + return; + end if; + end if; + + -- We do not inline a subprogram that is too large, unless it is + -- marked Inline_Always. This pragma does not suppress the other + -- checks on inlining (forbidden declarations, handlers, etc). + + if Stat_Count > Max_Size + and then not Has_Pragma_Inline_Always (Subp) + then + Cannot_Inline ("cannot inline& (body too large)?", N, Subp); + return; + end if; + + if Has_Pending_Instantiation then + Cannot_Inline + ("cannot inline& (forward instance within enclosing body)?", + N, Subp); + return; + end if; + + -- Within an instance, the body to inline must be treated as a nested + -- generic, so that the proper global references are preserved. + + -- Note that we do not do this at the library level, because it is not + -- needed, and furthermore this causes trouble if front end inlining + -- is activated (-gnatN). + + if In_Instance and then Scope (Current_Scope) /= Standard_Standard then + Save_Env (Scope (Current_Scope), Scope (Current_Scope)); + Original_Body := Copy_Generic_Node (N, Empty, True); + else + Original_Body := Copy_Separate_Tree (N); + end if; + + -- We need to capture references to the formals in order to substitute + -- the actuals at the point of inlining, i.e. instantiation. To treat + -- the formals as globals to the body to inline, we nest it within + -- a dummy parameterless subprogram, declared within the real one. + -- To avoid generating an internal name (which is never public, and + -- which affects serial numbers of other generated names), we use + -- an internal symbol that cannot conflict with user declarations. + + Set_Parameter_Specifications (Specification (Original_Body), No_List); + Set_Defining_Unit_Name + (Specification (Original_Body), + Make_Defining_Identifier (Sloc (N), Name_uParent)); + Set_Corresponding_Spec (Original_Body, Empty); + + Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False); + + -- Set return type of function, which is also global and does not need + -- to be resolved. + + if Ekind (Subp) = E_Function then + Set_Result_Definition (Specification (Body_To_Analyze), + New_Occurrence_Of (Etype (Subp), Sloc (N))); + end if; + + if No (Declarations (N)) then + Set_Declarations (N, New_List (Body_To_Analyze)); + else + Append (Body_To_Analyze, Declarations (N)); + end if; + + Expander_Mode_Save_And_Set (False); + Remove_Pragmas; + + Analyze (Body_To_Analyze); + Push_Scope (Defining_Entity (Body_To_Analyze)); + Save_Global_References (Original_Body); + End_Scope; + Remove (Body_To_Analyze); + + Expander_Mode_Restore; + + -- Restore environment if previously saved + + if In_Instance and then Scope (Current_Scope) /= Standard_Standard then + Restore_Env; + end if; + + -- If secondary stk used there is no point in inlining. We have + -- already issued the warning in this case, so nothing to do. + + if Uses_Secondary_Stack (Body_To_Analyze) then + return; + end if; + + Set_Body_To_Inline (Decl, Original_Body); + Set_Ekind (Defining_Entity (Original_Body), Ekind (Subp)); + Set_Is_Inlined (Subp); + end Build_Body_To_Inline; + + ------------------- + -- Cannot_Inline -- + ------------------- + + procedure Cannot_Inline (Msg : String; N : Node_Id; Subp : Entity_Id) is + begin + -- Do not emit warning if this is a predefined unit which is not the + -- main unit. With validity checks enabled, some predefined subprograms + -- may contain nested subprograms and become ineligible for inlining. + + if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp))) + and then not In_Extended_Main_Source_Unit (Subp) + then + null; + + elsif Has_Pragma_Inline_Always (Subp) then + + -- Remove last character (question mark) to make this into an error, + -- because the Inline_Always pragma cannot be obeyed. + + Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp); + + elsif Ineffective_Inline_Warnings then + Error_Msg_NE (Msg, N, Subp); + end if; + end Cannot_Inline; + + ----------------------- + -- Check_Conformance -- + ----------------------- + + procedure Check_Conformance + (New_Id : Entity_Id; + Old_Id : Entity_Id; + Ctype : Conformance_Type; + Errmsg : Boolean; + Conforms : out Boolean; + Err_Loc : Node_Id := Empty; + Get_Inst : Boolean := False; + Skip_Controlling_Formals : Boolean := False) + is + procedure Conformance_Error (Msg : String; N : Node_Id := New_Id); + -- Sets Conforms to False. If Errmsg is False, then that's all it does. + -- If Errmsg is True, then processing continues to post an error message + -- for conformance error on given node. Two messages are output. The + -- first message points to the previous declaration with a general "no + -- conformance" message. The second is the detailed reason, supplied as + -- Msg. The parameter N provide information for a possible & insertion + -- in the message, and also provides the location for posting the + -- message in the absence of a specified Err_Loc location. + + ----------------------- + -- Conformance_Error -- + ----------------------- + + procedure Conformance_Error (Msg : String; N : Node_Id := New_Id) is + Enode : Node_Id; + + begin + Conforms := False; + + if Errmsg then + if No (Err_Loc) then + Enode := N; + else + Enode := Err_Loc; + end if; + + Error_Msg_Sloc := Sloc (Old_Id); + + case Ctype is + when Type_Conformant => + Error_Msg_N -- CODEFIX + ("not type conformant with declaration#!", Enode); + + when Mode_Conformant => + if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then + Error_Msg_N + ("not mode conformant with operation inherited#!", + Enode); + else + Error_Msg_N + ("not mode conformant with declaration#!", Enode); + end if; + + when Subtype_Conformant => + if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then + Error_Msg_N + ("not subtype conformant with operation inherited#!", + Enode); + else + Error_Msg_N + ("not subtype conformant with declaration#!", Enode); + end if; + + when Fully_Conformant => + if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then + Error_Msg_N -- CODEFIX + ("not fully conformant with operation inherited#!", + Enode); + else + Error_Msg_N -- CODEFIX + ("not fully conformant with declaration#!", Enode); + end if; + end case; + + Error_Msg_NE (Msg, Enode, N); + end if; + end Conformance_Error; + + -- Local Variables + + Old_Type : constant Entity_Id := Etype (Old_Id); + New_Type : constant Entity_Id := Etype (New_Id); + Old_Formal : Entity_Id; + New_Formal : Entity_Id; + Access_Types_Match : Boolean; + Old_Formal_Base : Entity_Id; + New_Formal_Base : Entity_Id; + + -- Start of processing for Check_Conformance + + begin + Conforms := True; + + -- We need a special case for operators, since they don't appear + -- explicitly. + + if Ctype = Type_Conformant then + if Ekind (New_Id) = E_Operator + and then Operator_Matches_Spec (New_Id, Old_Id) + then + return; + end if; + end if; + + -- If both are functions/operators, check return types conform + + if Old_Type /= Standard_Void_Type + and then New_Type /= Standard_Void_Type + then + + -- If we are checking interface conformance we omit controlling + -- arguments and result, because we are only checking the conformance + -- of the remaining parameters. + + if Has_Controlling_Result (Old_Id) + and then Has_Controlling_Result (New_Id) + and then Skip_Controlling_Formals + then + null; + + elsif not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then + Conformance_Error ("\return type does not match!", New_Id); + return; + end if; + + -- Ada 2005 (AI-231): In case of anonymous access types check the + -- null-exclusion and access-to-constant attributes match. + + if Ada_Version >= Ada_2005 + and then Ekind (Etype (Old_Type)) = E_Anonymous_Access_Type + and then + (Can_Never_Be_Null (Old_Type) + /= Can_Never_Be_Null (New_Type) + or else Is_Access_Constant (Etype (Old_Type)) + /= Is_Access_Constant (Etype (New_Type))) + then + Conformance_Error ("\return type does not match!", New_Id); + return; + end if; + + -- If either is a function/operator and the other isn't, error + + elsif Old_Type /= Standard_Void_Type + or else New_Type /= Standard_Void_Type + then + Conformance_Error ("\functions can only match functions!", New_Id); + return; + end if; + + -- In subtype conformant case, conventions must match (RM 6.3.1(16)). + -- If this is a renaming as body, refine error message to indicate that + -- the conflict is with the original declaration. If the entity is not + -- frozen, the conventions don't have to match, the one of the renamed + -- entity is inherited. + + if Ctype >= Subtype_Conformant then + if Convention (Old_Id) /= Convention (New_Id) then + + if not Is_Frozen (New_Id) then + null; + + elsif Present (Err_Loc) + and then Nkind (Err_Loc) = N_Subprogram_Renaming_Declaration + and then Present (Corresponding_Spec (Err_Loc)) + then + Error_Msg_Name_1 := Chars (New_Id); + Error_Msg_Name_2 := + Name_Ada + Convention_Id'Pos (Convention (New_Id)); + Conformance_Error ("\prior declaration for% has convention %!"); + + else + Conformance_Error ("\calling conventions do not match!"); + end if; + + return; + + elsif Is_Formal_Subprogram (Old_Id) + or else Is_Formal_Subprogram (New_Id) + then + Conformance_Error ("\formal subprograms not allowed!"); + return; + end if; + end if; + + -- Deal with parameters + + -- Note: we use the entity information, rather than going directly + -- to the specification in the tree. This is not only simpler, but + -- absolutely necessary for some cases of conformance tests between + -- operators, where the declaration tree simply does not exist! + + Old_Formal := First_Formal (Old_Id); + New_Formal := First_Formal (New_Id); + while Present (Old_Formal) and then Present (New_Formal) loop + if Is_Controlling_Formal (Old_Formal) + and then Is_Controlling_Formal (New_Formal) + and then Skip_Controlling_Formals + then + -- The controlling formals will have different types when + -- comparing an interface operation with its match, but both + -- or neither must be access parameters. + + if Is_Access_Type (Etype (Old_Formal)) + = + Is_Access_Type (Etype (New_Formal)) + then + goto Skip_Controlling_Formal; + else + Conformance_Error + ("\access parameter does not match!", New_Formal); + end if; + end if; + + if Ctype = Fully_Conformant then + + -- Names must match. Error message is more accurate if we do + -- this before checking that the types of the formals match. + + if Chars (Old_Formal) /= Chars (New_Formal) then + Conformance_Error ("\name & does not match!", New_Formal); + + -- Set error posted flag on new formal as well to stop + -- junk cascaded messages in some cases. + + Set_Error_Posted (New_Formal); + return; + end if; + + -- Null exclusion must match + + if Null_Exclusion_Present (Parent (Old_Formal)) + /= + Null_Exclusion_Present (Parent (New_Formal)) + then + -- Only give error if both come from source. This should be + -- investigated some time, since it should not be needed ??? + + if Comes_From_Source (Old_Formal) + and then + Comes_From_Source (New_Formal) + then + Conformance_Error + ("\null exclusion for & does not match", New_Formal); + + -- Mark error posted on the new formal to avoid duplicated + -- complaint about types not matching. + + Set_Error_Posted (New_Formal); + end if; + end if; + end if; + + -- Ada 2005 (AI-423): Possible access [sub]type and itype match. This + -- case occurs whenever a subprogram is being renamed and one of its + -- parameters imposes a null exclusion. For example: + + -- type T is null record; + -- type Acc_T is access T; + -- subtype Acc_T_Sub is Acc_T; + + -- procedure P (Obj : not null Acc_T_Sub); -- itype + -- procedure Ren_P (Obj : Acc_T_Sub) -- subtype + -- renames P; + + Old_Formal_Base := Etype (Old_Formal); + New_Formal_Base := Etype (New_Formal); + + if Get_Inst then + Old_Formal_Base := Get_Instance_Of (Old_Formal_Base); + New_Formal_Base := Get_Instance_Of (New_Formal_Base); + end if; + + Access_Types_Match := Ada_Version >= Ada_2005 + + -- Ensure that this rule is only applied when New_Id is a + -- renaming of Old_Id. + + and then Nkind (Parent (Parent (New_Id))) = + N_Subprogram_Renaming_Declaration + and then Nkind (Name (Parent (Parent (New_Id)))) in N_Has_Entity + and then Present (Entity (Name (Parent (Parent (New_Id))))) + and then Entity (Name (Parent (Parent (New_Id)))) = Old_Id + + -- Now handle the allowed access-type case + + and then Is_Access_Type (Old_Formal_Base) + and then Is_Access_Type (New_Formal_Base) + + -- The type kinds must match. The only exception occurs with + -- multiple generics of the form: + + -- generic generic + -- type F is private; type A is private; + -- type F_Ptr is access F; type A_Ptr is access A; + -- with proc F_P (X : F_Ptr); with proc A_P (X : A_Ptr); + -- package F_Pack is ... package A_Pack is + -- package F_Inst is + -- new F_Pack (A, A_Ptr, A_P); + + -- When checking for conformance between the parameters of A_P + -- and F_P, the type kinds of F_Ptr and A_Ptr will not match + -- because the compiler has transformed A_Ptr into a subtype of + -- F_Ptr. We catch this case in the code below. + + and then (Ekind (Old_Formal_Base) = Ekind (New_Formal_Base) + or else + (Is_Generic_Type (Old_Formal_Base) + and then Is_Generic_Type (New_Formal_Base) + and then Is_Internal (New_Formal_Base) + and then Etype (Etype (New_Formal_Base)) = + Old_Formal_Base)) + and then Directly_Designated_Type (Old_Formal_Base) = + Directly_Designated_Type (New_Formal_Base) + and then ((Is_Itype (Old_Formal_Base) + and then Can_Never_Be_Null (Old_Formal_Base)) + or else + (Is_Itype (New_Formal_Base) + and then Can_Never_Be_Null (New_Formal_Base))); + + -- Types must always match. In the visible part of an instance, + -- usual overloading rules for dispatching operations apply, and + -- we check base types (not the actual subtypes). + + if In_Instance_Visible_Part + and then Is_Dispatching_Operation (New_Id) + then + if not Conforming_Types + (T1 => Base_Type (Etype (Old_Formal)), + T2 => Base_Type (Etype (New_Formal)), + Ctype => Ctype, + Get_Inst => Get_Inst) + and then not Access_Types_Match + then + Conformance_Error ("\type of & does not match!", New_Formal); + return; + end if; + + elsif not Conforming_Types + (T1 => Old_Formal_Base, + T2 => New_Formal_Base, + Ctype => Ctype, + Get_Inst => Get_Inst) + and then not Access_Types_Match + then + -- Don't give error message if old type is Any_Type. This test + -- avoids some cascaded errors, e.g. in case of a bad spec. + + if Errmsg and then Old_Formal_Base = Any_Type then + Conforms := False; + else + Conformance_Error ("\type of & does not match!", New_Formal); + end if; + + return; + end if; + + -- For mode conformance, mode must match + + if Ctype >= Mode_Conformant then + if Parameter_Mode (Old_Formal) /= Parameter_Mode (New_Formal) then + Conformance_Error ("\mode of & does not match!", New_Formal); + return; + + -- Part of mode conformance for access types is having the same + -- constant modifier. + + elsif Access_Types_Match + and then Is_Access_Constant (Old_Formal_Base) /= + Is_Access_Constant (New_Formal_Base) + then + Conformance_Error + ("\constant modifier does not match!", New_Formal); + return; + end if; + end if; + + if Ctype >= Subtype_Conformant then + + -- Ada 2005 (AI-231): In case of anonymous access types check + -- the null-exclusion and access-to-constant attributes must + -- match. + + if Ada_Version >= Ada_2005 + and then Ekind (Etype (Old_Formal)) = E_Anonymous_Access_Type + and then Ekind (Etype (New_Formal)) = E_Anonymous_Access_Type + and then + (Can_Never_Be_Null (Old_Formal) /= + Can_Never_Be_Null (New_Formal) + or else + Is_Access_Constant (Etype (Old_Formal)) /= + Is_Access_Constant (Etype (New_Formal))) + + -- Do not complain if error already posted on New_Formal. This + -- avoids some redundant error messages. + + and then not Error_Posted (New_Formal) + then + -- It is allowed to omit the null-exclusion in case of stream + -- attribute subprograms. We recognize stream subprograms + -- through their TSS-generated suffix. + + declare + TSS_Name : constant TSS_Name_Type := Get_TSS_Name (New_Id); + begin + if TSS_Name /= TSS_Stream_Read + and then TSS_Name /= TSS_Stream_Write + and then TSS_Name /= TSS_Stream_Input + and then TSS_Name /= TSS_Stream_Output + then + Conformance_Error + ("\type of & does not match!", New_Formal); + return; + end if; + end; + end if; + end if; + + -- Full conformance checks + + if Ctype = Fully_Conformant then + + -- We have checked already that names match + + if Parameter_Mode (Old_Formal) = E_In_Parameter then + + -- Check default expressions for in parameters + + declare + NewD : constant Boolean := + Present (Default_Value (New_Formal)); + OldD : constant Boolean := + Present (Default_Value (Old_Formal)); + begin + if NewD or OldD then + + -- The old default value has been analyzed because the + -- current full declaration will have frozen everything + -- before. The new default value has not been analyzed, + -- so analyze it now before we check for conformance. + + if NewD then + Push_Scope (New_Id); + Preanalyze_Spec_Expression + (Default_Value (New_Formal), Etype (New_Formal)); + End_Scope; + end if; + + if not (NewD and OldD) + or else not Fully_Conformant_Expressions + (Default_Value (Old_Formal), + Default_Value (New_Formal)) + then + Conformance_Error + ("\default expression for & does not match!", + New_Formal); + return; + end if; + end if; + end; + end if; + end if; + + -- A couple of special checks for Ada 83 mode. These checks are + -- skipped if either entity is an operator in package Standard, + -- or if either old or new instance is not from the source program. + + if Ada_Version = Ada_83 + and then Sloc (Old_Id) > Standard_Location + and then Sloc (New_Id) > Standard_Location + and then Comes_From_Source (Old_Id) + and then Comes_From_Source (New_Id) + then + declare + Old_Param : constant Node_Id := Declaration_Node (Old_Formal); + New_Param : constant Node_Id := Declaration_Node (New_Formal); + + begin + -- Explicit IN must be present or absent in both cases. This + -- test is required only in the full conformance case. + + if In_Present (Old_Param) /= In_Present (New_Param) + and then Ctype = Fully_Conformant + then + Conformance_Error + ("\(Ada 83) IN must appear in both declarations", + New_Formal); + return; + end if; + + -- Grouping (use of comma in param lists) must be the same + -- This is where we catch a misconformance like: + + -- A, B : Integer + -- A : Integer; B : Integer + + -- which are represented identically in the tree except + -- for the setting of the flags More_Ids and Prev_Ids. + + if More_Ids (Old_Param) /= More_Ids (New_Param) + or else Prev_Ids (Old_Param) /= Prev_Ids (New_Param) + then + Conformance_Error + ("\grouping of & does not match!", New_Formal); + return; + end if; + end; + end if; + + -- This label is required when skipping controlling formals + + <> + + Next_Formal (Old_Formal); + Next_Formal (New_Formal); + end loop; + + if Present (Old_Formal) then + Conformance_Error ("\too few parameters!"); + return; + + elsif Present (New_Formal) then + Conformance_Error ("\too many parameters!", New_Formal); + return; + end if; + end Check_Conformance; + + ----------------------- + -- Check_Conventions -- + ----------------------- + + procedure Check_Conventions (Typ : Entity_Id) is + Ifaces_List : Elist_Id; + + procedure Check_Convention (Op : Entity_Id); + -- Verify that the convention of inherited dispatching operation Op is + -- consistent among all subprograms it overrides. In order to minimize + -- the search, Search_From is utilized to designate a specific point in + -- the list rather than iterating over the whole list once more. + + ---------------------- + -- Check_Convention -- + ---------------------- + + procedure Check_Convention (Op : Entity_Id) is + Iface_Elmt : Elmt_Id; + Iface_Prim_Elmt : Elmt_Id; + Iface_Prim : Entity_Id; + + begin + Iface_Elmt := First_Elmt (Ifaces_List); + while Present (Iface_Elmt) loop + Iface_Prim_Elmt := + First_Elmt (Primitive_Operations (Node (Iface_Elmt))); + while Present (Iface_Prim_Elmt) loop + Iface_Prim := Node (Iface_Prim_Elmt); + + if Is_Interface_Conformant (Typ, Iface_Prim, Op) + and then Convention (Iface_Prim) /= Convention (Op) + then + Error_Msg_N + ("inconsistent conventions in primitive operations", Typ); + + Error_Msg_Name_1 := Chars (Op); + Error_Msg_Name_2 := Get_Convention_Name (Convention (Op)); + Error_Msg_Sloc := Sloc (Op); + + if Comes_From_Source (Op) or else No (Alias (Op)) then + if not Present (Overridden_Operation (Op)) then + Error_Msg_N ("\\primitive % defined #", Typ); + else + Error_Msg_N + ("\\overriding operation % with " & + "convention % defined #", Typ); + end if; + + else pragma Assert (Present (Alias (Op))); + Error_Msg_Sloc := Sloc (Alias (Op)); + Error_Msg_N + ("\\inherited operation % with " & + "convention % defined #", Typ); + end if; + + Error_Msg_Name_1 := Chars (Op); + Error_Msg_Name_2 := + Get_Convention_Name (Convention (Iface_Prim)); + Error_Msg_Sloc := Sloc (Iface_Prim); + Error_Msg_N + ("\\overridden operation % with " & + "convention % defined #", Typ); + + -- Avoid cascading errors + + return; + end if; + + Next_Elmt (Iface_Prim_Elmt); + end loop; + + Next_Elmt (Iface_Elmt); + end loop; + end Check_Convention; + + -- Local variables + + Prim_Op : Entity_Id; + Prim_Op_Elmt : Elmt_Id; + + -- Start of processing for Check_Conventions + + begin + if not Has_Interfaces (Typ) then + return; + end if; + + Collect_Interfaces (Typ, Ifaces_List); + + -- The algorithm checks every overriding dispatching operation against + -- all the corresponding overridden dispatching operations, detecting + -- differences in conventions. + + Prim_Op_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Op_Elmt) loop + Prim_Op := Node (Prim_Op_Elmt); + + -- A small optimization: skip the predefined dispatching operations + -- since they always have the same convention. + + if not Is_Predefined_Dispatching_Operation (Prim_Op) then + Check_Convention (Prim_Op); + end if; + + Next_Elmt (Prim_Op_Elmt); + end loop; + end Check_Conventions; + + ------------------------------ + -- Check_Delayed_Subprogram -- + ------------------------------ + + procedure Check_Delayed_Subprogram (Designator : Entity_Id) is + F : Entity_Id; + + procedure Possible_Freeze (T : Entity_Id); + -- T is the type of either a formal parameter or of the return type. + -- If T is not yet frozen and needs a delayed freeze, then the + -- subprogram itself must be delayed. If T is the limited view of an + -- incomplete type the subprogram must be frozen as well, because + -- T may depend on local types that have not been frozen yet. + + --------------------- + -- Possible_Freeze -- + --------------------- + + procedure Possible_Freeze (T : Entity_Id) is + begin + if Has_Delayed_Freeze (T) and then not Is_Frozen (T) then + Set_Has_Delayed_Freeze (Designator); + + elsif Is_Access_Type (T) + and then Has_Delayed_Freeze (Designated_Type (T)) + and then not Is_Frozen (Designated_Type (T)) + then + Set_Has_Delayed_Freeze (Designator); + + elsif Ekind (T) = E_Incomplete_Type and then From_With_Type (T) then + Set_Has_Delayed_Freeze (Designator); + end if; + + end Possible_Freeze; + + -- Start of processing for Check_Delayed_Subprogram + + begin + -- All subprograms, including abstract subprograms, may need a freeze + -- node if some formal type or the return type needs one. + + Possible_Freeze (Etype (Designator)); + Possible_Freeze (Base_Type (Etype (Designator))); -- needed ??? + + -- Need delayed freeze if any of the formal types themselves need + -- a delayed freeze and are not yet frozen. + + F := First_Formal (Designator); + while Present (F) loop + Possible_Freeze (Etype (F)); + Possible_Freeze (Base_Type (Etype (F))); -- needed ??? + Next_Formal (F); + end loop; + + -- Mark functions that return by reference. Note that it cannot be + -- done for delayed_freeze subprograms because the underlying + -- returned type may not be known yet (for private types) + + if not Has_Delayed_Freeze (Designator) + and then Expander_Active + then + declare + Typ : constant Entity_Id := Etype (Designator); + Utyp : constant Entity_Id := Underlying_Type (Typ); + + begin + if Is_Immutably_Limited_Type (Typ) then + Set_Returns_By_Ref (Designator); + + elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then + Set_Returns_By_Ref (Designator); + end if; + end; + end if; + end Check_Delayed_Subprogram; + + ------------------------------------ + -- Check_Discriminant_Conformance -- + ------------------------------------ + + procedure Check_Discriminant_Conformance + (N : Node_Id; + Prev : Entity_Id; + Prev_Loc : Node_Id) + is + Old_Discr : Entity_Id := First_Discriminant (Prev); + New_Discr : Node_Id := First (Discriminant_Specifications (N)); + New_Discr_Id : Entity_Id; + New_Discr_Type : Entity_Id; + + procedure Conformance_Error (Msg : String; N : Node_Id); + -- Post error message for conformance error on given node. Two messages + -- are output. The first points to the previous declaration with a + -- general "no conformance" message. The second is the detailed reason, + -- supplied as Msg. The parameter N provide information for a possible + -- & insertion in the message. + + ----------------------- + -- Conformance_Error -- + ----------------------- + + procedure Conformance_Error (Msg : String; N : Node_Id) is + begin + Error_Msg_Sloc := Sloc (Prev_Loc); + Error_Msg_N -- CODEFIX + ("not fully conformant with declaration#!", N); + Error_Msg_NE (Msg, N, N); + end Conformance_Error; + + -- Start of processing for Check_Discriminant_Conformance + + begin + while Present (Old_Discr) and then Present (New_Discr) loop + + New_Discr_Id := Defining_Identifier (New_Discr); + + -- The subtype mark of the discriminant on the full type has not + -- been analyzed so we do it here. For an access discriminant a new + -- type is created. + + if Nkind (Discriminant_Type (New_Discr)) = N_Access_Definition then + New_Discr_Type := + Access_Definition (N, Discriminant_Type (New_Discr)); + + else + Analyze (Discriminant_Type (New_Discr)); + New_Discr_Type := Etype (Discriminant_Type (New_Discr)); + + -- Ada 2005: if the discriminant definition carries a null + -- exclusion, create an itype to check properly for consistency + -- with partial declaration. + + if Is_Access_Type (New_Discr_Type) + and then Null_Exclusion_Present (New_Discr) + then + New_Discr_Type := + Create_Null_Excluding_Itype + (T => New_Discr_Type, + Related_Nod => New_Discr, + Scope_Id => Current_Scope); + end if; + end if; + + if not Conforming_Types + (Etype (Old_Discr), New_Discr_Type, Fully_Conformant) + then + Conformance_Error ("type of & does not match!", New_Discr_Id); + return; + else + -- Treat the new discriminant as an occurrence of the old one, + -- for navigation purposes, and fill in some semantic + -- information, for completeness. + + Generate_Reference (Old_Discr, New_Discr_Id, 'r'); + Set_Etype (New_Discr_Id, Etype (Old_Discr)); + Set_Scope (New_Discr_Id, Scope (Old_Discr)); + end if; + + -- Names must match + + if Chars (Old_Discr) /= Chars (Defining_Identifier (New_Discr)) then + Conformance_Error ("name & does not match!", New_Discr_Id); + return; + end if; + + -- Default expressions must match + + declare + NewD : constant Boolean := + Present (Expression (New_Discr)); + OldD : constant Boolean := + Present (Expression (Parent (Old_Discr))); + + begin + if NewD or OldD then + + -- The old default value has been analyzed and expanded, + -- because the current full declaration will have frozen + -- everything before. The new default values have not been + -- expanded, so expand now to check conformance. + + if NewD then + Preanalyze_Spec_Expression + (Expression (New_Discr), New_Discr_Type); + end if; + + if not (NewD and OldD) + or else not Fully_Conformant_Expressions + (Expression (Parent (Old_Discr)), + Expression (New_Discr)) + + then + Conformance_Error + ("default expression for & does not match!", + New_Discr_Id); + return; + end if; + end if; + end; + + -- In Ada 83 case, grouping must match: (A,B : X) /= (A : X; B : X) + + if Ada_Version = Ada_83 then + declare + Old_Disc : constant Node_Id := Declaration_Node (Old_Discr); + + begin + -- Grouping (use of comma in param lists) must be the same + -- This is where we catch a misconformance like: + + -- A,B : Integer + -- A : Integer; B : Integer + + -- which are represented identically in the tree except + -- for the setting of the flags More_Ids and Prev_Ids. + + if More_Ids (Old_Disc) /= More_Ids (New_Discr) + or else Prev_Ids (Old_Disc) /= Prev_Ids (New_Discr) + then + Conformance_Error + ("grouping of & does not match!", New_Discr_Id); + return; + end if; + end; + end if; + + Next_Discriminant (Old_Discr); + Next (New_Discr); + end loop; + + if Present (Old_Discr) then + Conformance_Error ("too few discriminants!", Defining_Identifier (N)); + return; + + elsif Present (New_Discr) then + Conformance_Error + ("too many discriminants!", Defining_Identifier (New_Discr)); + return; + end if; + end Check_Discriminant_Conformance; + + ---------------------------- + -- Check_Fully_Conformant -- + ---------------------------- + + procedure Check_Fully_Conformant + (New_Id : Entity_Id; + Old_Id : Entity_Id; + Err_Loc : Node_Id := Empty) + is + Result : Boolean; + pragma Warnings (Off, Result); + begin + Check_Conformance + (New_Id, Old_Id, Fully_Conformant, True, Result, Err_Loc); + end Check_Fully_Conformant; + + --------------------------- + -- Check_Mode_Conformant -- + --------------------------- + + procedure Check_Mode_Conformant + (New_Id : Entity_Id; + Old_Id : Entity_Id; + Err_Loc : Node_Id := Empty; + Get_Inst : Boolean := False) + is + Result : Boolean; + pragma Warnings (Off, Result); + begin + Check_Conformance + (New_Id, Old_Id, Mode_Conformant, True, Result, Err_Loc, Get_Inst); + end Check_Mode_Conformant; + + -------------------------------- + -- Check_Overriding_Indicator -- + -------------------------------- + + procedure Check_Overriding_Indicator + (Subp : Entity_Id; + Overridden_Subp : Entity_Id; + Is_Primitive : Boolean) + is + Decl : Node_Id; + Spec : Node_Id; + + begin + -- No overriding indicator for literals + + if Ekind (Subp) = E_Enumeration_Literal then + return; + + elsif Ekind (Subp) = E_Entry then + Decl := Parent (Subp); + + -- No point in analyzing a malformed operator + + elsif Nkind (Subp) = N_Defining_Operator_Symbol + and then Error_Posted (Subp) + then + return; + + else + Decl := Unit_Declaration_Node (Subp); + end if; + + if Nkind_In (Decl, N_Subprogram_Body, + N_Subprogram_Body_Stub, + N_Subprogram_Declaration, + N_Abstract_Subprogram_Declaration, + N_Subprogram_Renaming_Declaration) + then + Spec := Specification (Decl); + + elsif Nkind (Decl) = N_Entry_Declaration then + Spec := Decl; + + else + return; + end if; + + -- The overriding operation is type conformant with the overridden one, + -- but the names of the formals are not required to match. If the names + -- appear permuted in the overriding operation, this is a possible + -- source of confusion that is worth diagnosing. Controlling formals + -- often carry names that reflect the type, and it is not worthwhile + -- requiring that their names match. + + if Present (Overridden_Subp) + and then Nkind (Subp) /= N_Defining_Operator_Symbol + then + declare + Form1 : Entity_Id; + Form2 : Entity_Id; + + begin + Form1 := First_Formal (Subp); + Form2 := First_Formal (Overridden_Subp); + + -- If the overriding operation is a synchronized operation, skip + -- the first parameter of the overridden operation, which is + -- implicit in the new one. If the operation is declared in the + -- body it is not primitive and all formals must match. + + if Is_Concurrent_Type (Scope (Subp)) + and then Is_Tagged_Type (Scope (Subp)) + and then not Has_Completion (Scope (Subp)) + then + Form2 := Next_Formal (Form2); + end if; + + if Present (Form1) then + Form1 := Next_Formal (Form1); + Form2 := Next_Formal (Form2); + end if; + + while Present (Form1) loop + if not Is_Controlling_Formal (Form1) + and then Present (Next_Formal (Form2)) + and then Chars (Form1) = Chars (Next_Formal (Form2)) + then + Error_Msg_Node_2 := Alias (Overridden_Subp); + Error_Msg_Sloc := Sloc (Error_Msg_Node_2); + Error_Msg_NE + ("& does not match corresponding formal of&#", + Form1, Form1); + exit; + end if; + + Next_Formal (Form1); + Next_Formal (Form2); + end loop; + end; + end if; + + -- If there is an overridden subprogram, then check that there is no + -- "not overriding" indicator, and mark the subprogram as overriding. + -- This is not done if the overridden subprogram is marked as hidden, + -- which can occur for the case of inherited controlled operations + -- (see Derive_Subprogram), unless the inherited subprogram's parent + -- subprogram is not itself hidden. (Note: This condition could probably + -- be simplified, leaving out the testing for the specific controlled + -- cases, but it seems safer and clearer this way, and echoes similar + -- special-case tests of this kind in other places.) + + if Present (Overridden_Subp) + and then (not Is_Hidden (Overridden_Subp) + or else + ((Chars (Overridden_Subp) = Name_Initialize + or else + Chars (Overridden_Subp) = Name_Adjust + or else + Chars (Overridden_Subp) = Name_Finalize) + and then Present (Alias (Overridden_Subp)) + and then not Is_Hidden (Alias (Overridden_Subp)))) + then + if Must_Not_Override (Spec) then + Error_Msg_Sloc := Sloc (Overridden_Subp); + + if Ekind (Subp) = E_Entry then + Error_Msg_NE + ("entry & overrides inherited operation #", Spec, Subp); + else + Error_Msg_NE + ("subprogram & overrides inherited operation #", Spec, Subp); + end if; + + elsif Is_Subprogram (Subp) then + if No (Overridden_Operation (Subp)) then + + -- For entities generated by Derive_Subprograms the overridden + -- operation is the inherited primitive (which is available + -- through the attribute alias) + + if (Is_Dispatching_Operation (Subp) + or else Is_Dispatching_Operation (Overridden_Subp)) + and then not Comes_From_Source (Overridden_Subp) + and then Find_Dispatching_Type (Overridden_Subp) = + Find_Dispatching_Type (Subp) + and then Present (Alias (Overridden_Subp)) + and then Comes_From_Source (Alias (Overridden_Subp)) + then + Set_Overridden_Operation (Subp, Alias (Overridden_Subp)); + else + Set_Overridden_Operation (Subp, Overridden_Subp); + end if; + end if; + end if; + + -- If primitive flag is set or this is a protected operation, then + -- the operation is overriding at the point of its declaration, so + -- warn if necessary. Otherwise it may have been declared before the + -- operation it overrides and no check is required. + + if Style_Check + and then not Must_Override (Spec) + and then (Is_Primitive + or else Ekind (Scope (Subp)) = E_Protected_Type) + then + Style.Missing_Overriding (Decl, Subp); + end if; + + -- If Subp is an operator, it may override a predefined operation, if + -- it is defined in the same scope as the type to which it applies. + -- In that case Overridden_Subp is empty because of our implicit + -- representation for predefined operators. We have to check whether the + -- signature of Subp matches that of a predefined operator. Note that + -- first argument provides the name of the operator, and the second + -- argument the signature that may match that of a standard operation. + -- If the indicator is overriding, then the operator must match a + -- predefined signature, because we know already that there is no + -- explicit overridden operation. + + elsif Nkind (Subp) = N_Defining_Operator_Symbol then + declare + Typ : constant Entity_Id := + Base_Type (Etype (First_Formal (Subp))); + + Can_Override : constant Boolean := + Operator_Matches_Spec (Subp, Subp) + and then Scope (Subp) = Scope (Typ) + and then not Is_Class_Wide_Type (Typ); + + begin + if Must_Not_Override (Spec) then + + -- If this is not a primitive or a protected subprogram, then + -- "not overriding" is illegal. + + if not Is_Primitive + and then Ekind (Scope (Subp)) /= E_Protected_Type + then + Error_Msg_N + ("overriding indicator only allowed " + & "if subprogram is primitive", Subp); + + elsif Can_Override then + Error_Msg_NE + ("subprogram& overrides predefined operator ", Spec, Subp); + end if; + + elsif Must_Override (Spec) then + if No (Overridden_Operation (Subp)) + and then not Can_Override + then + Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); + end if; + + elsif not Error_Posted (Subp) + and then Style_Check + and then Can_Override + and then + not Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Subp))) + then + -- If style checks are enabled, indicate that the indicator is + -- missing. However, at the point of declaration, the type of + -- which this is a primitive operation may be private, in which + -- case the indicator would be premature. + + if Has_Private_Declaration (Etype (Subp)) + or else Has_Private_Declaration (Etype (First_Formal (Subp))) + then + null; + else + Style.Missing_Overriding (Decl, Subp); + end if; + end if; + end; + + elsif Must_Override (Spec) then + if Ekind (Subp) = E_Entry then + Error_Msg_NE ("entry & is not overriding", Spec, Subp); + else + Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); + end if; + + -- If the operation is marked "not overriding" and it's not primitive + -- then an error is issued, unless this is an operation of a task or + -- protected type (RM05-8.3.1(3/2-4/2)). Error cases where "overriding" + -- has been specified have already been checked above. + + elsif Must_Not_Override (Spec) + and then not Is_Primitive + and then Ekind (Subp) /= E_Entry + and then Ekind (Scope (Subp)) /= E_Protected_Type + then + Error_Msg_N + ("overriding indicator only allowed if subprogram is primitive", + Subp); + return; + end if; + end Check_Overriding_Indicator; + + ------------------- + -- Check_Returns -- + ------------------- + + -- Note: this procedure needs to know far too much about how the expander + -- messes with exceptions. The use of the flag Exception_Junk and the + -- incorporation of knowledge of Exp_Ch11.Expand_Local_Exception_Handlers + -- works, but is not very clean. It would be better if the expansion + -- routines would leave Original_Node working nicely, and we could use + -- Original_Node here to ignore all the peculiar expander messing ??? + + procedure Check_Returns + (HSS : Node_Id; + Mode : Character; + Err : out Boolean; + Proc : Entity_Id := Empty) + is + Handler : Node_Id; + + procedure Check_Statement_Sequence (L : List_Id); + -- Internal recursive procedure to check a list of statements for proper + -- termination by a return statement (or a transfer of control or a + -- compound statement that is itself internally properly terminated). + + ------------------------------ + -- Check_Statement_Sequence -- + ------------------------------ + + procedure Check_Statement_Sequence (L : List_Id) is + Last_Stm : Node_Id; + Stm : Node_Id; + Kind : Node_Kind; + + Raise_Exception_Call : Boolean; + -- Set True if statement sequence terminated by Raise_Exception call + -- or a Reraise_Occurrence call. + + begin + Raise_Exception_Call := False; + + -- Get last real statement + + Last_Stm := Last (L); + + -- Deal with digging out exception handler statement sequences that + -- have been transformed by the local raise to goto optimization. + -- See Exp_Ch11.Expand_Local_Exception_Handlers for details. If this + -- optimization has occurred, we are looking at something like: + + -- begin + -- original stmts in block + + -- exception \ + -- when excep1 => | + -- goto L1; | omitted if No_Exception_Propagation + -- when excep2 => | + -- goto L2; / + -- end; + + -- goto L3; -- skip handler when exception not raised + + -- <> -- target label for local exception + -- begin + -- estmts1 + -- end; + + -- goto L3; + + -- <> + -- begin + -- estmts2 + -- end; + + -- <> + + -- and what we have to do is to dig out the estmts1 and estmts2 + -- sequences (which were the original sequences of statements in + -- the exception handlers) and check them. + + if Nkind (Last_Stm) = N_Label + and then Exception_Junk (Last_Stm) + then + Stm := Last_Stm; + loop + Prev (Stm); + exit when No (Stm); + exit when Nkind (Stm) /= N_Block_Statement; + exit when not Exception_Junk (Stm); + Prev (Stm); + exit when No (Stm); + exit when Nkind (Stm) /= N_Label; + exit when not Exception_Junk (Stm); + Check_Statement_Sequence + (Statements (Handled_Statement_Sequence (Next (Stm)))); + + Prev (Stm); + Last_Stm := Stm; + exit when No (Stm); + exit when Nkind (Stm) /= N_Goto_Statement; + exit when not Exception_Junk (Stm); + end loop; + end if; + + -- Don't count pragmas + + while Nkind (Last_Stm) = N_Pragma + + -- Don't count call to SS_Release (can happen after Raise_Exception) + + or else + (Nkind (Last_Stm) = N_Procedure_Call_Statement + and then + Nkind (Name (Last_Stm)) = N_Identifier + and then + Is_RTE (Entity (Name (Last_Stm)), RE_SS_Release)) + + -- Don't count exception junk + + or else + (Nkind_In (Last_Stm, N_Goto_Statement, + N_Label, + N_Object_Declaration) + and then Exception_Junk (Last_Stm)) + or else Nkind (Last_Stm) in N_Push_xxx_Label + or else Nkind (Last_Stm) in N_Pop_xxx_Label + loop + Prev (Last_Stm); + end loop; + + -- Here we have the "real" last statement + + Kind := Nkind (Last_Stm); + + -- Transfer of control, OK. Note that in the No_Return procedure + -- case, we already diagnosed any explicit return statements, so + -- we can treat them as OK in this context. + + if Is_Transfer (Last_Stm) then + return; + + -- Check cases of explicit non-indirect procedure calls + + elsif Kind = N_Procedure_Call_Statement + and then Is_Entity_Name (Name (Last_Stm)) + then + -- Check call to Raise_Exception procedure which is treated + -- specially, as is a call to Reraise_Occurrence. + + -- We suppress the warning in these cases since it is likely that + -- the programmer really does not expect to deal with the case + -- of Null_Occurrence, and thus would find a warning about a + -- missing return curious, and raising Program_Error does not + -- seem such a bad behavior if this does occur. + + -- Note that in the Ada 2005 case for Raise_Exception, the actual + -- behavior will be to raise Constraint_Error (see AI-329). + + if Is_RTE (Entity (Name (Last_Stm)), RE_Raise_Exception) + or else + Is_RTE (Entity (Name (Last_Stm)), RE_Reraise_Occurrence) + then + Raise_Exception_Call := True; + + -- For Raise_Exception call, test first argument, if it is + -- an attribute reference for a 'Identity call, then we know + -- that the call cannot possibly return. + + declare + Arg : constant Node_Id := + Original_Node (First_Actual (Last_Stm)); + begin + if Nkind (Arg) = N_Attribute_Reference + and then Attribute_Name (Arg) = Name_Identity + then + return; + end if; + end; + end if; + + -- If statement, need to look inside if there is an else and check + -- each constituent statement sequence for proper termination. + + elsif Kind = N_If_Statement + and then Present (Else_Statements (Last_Stm)) + then + Check_Statement_Sequence (Then_Statements (Last_Stm)); + Check_Statement_Sequence (Else_Statements (Last_Stm)); + + if Present (Elsif_Parts (Last_Stm)) then + declare + Elsif_Part : Node_Id := First (Elsif_Parts (Last_Stm)); + + begin + while Present (Elsif_Part) loop + Check_Statement_Sequence (Then_Statements (Elsif_Part)); + Next (Elsif_Part); + end loop; + end; + end if; + + return; + + -- Case statement, check each case for proper termination + + elsif Kind = N_Case_Statement then + declare + Case_Alt : Node_Id; + begin + Case_Alt := First_Non_Pragma (Alternatives (Last_Stm)); + while Present (Case_Alt) loop + Check_Statement_Sequence (Statements (Case_Alt)); + Next_Non_Pragma (Case_Alt); + end loop; + end; + + return; + + -- Block statement, check its handled sequence of statements + + elsif Kind = N_Block_Statement then + declare + Err1 : Boolean; + + begin + Check_Returns + (Handled_Statement_Sequence (Last_Stm), Mode, Err1); + + if Err1 then + Err := True; + end if; + + return; + end; + + -- Loop statement. If there is an iteration scheme, we can definitely + -- fall out of the loop. Similarly if there is an exit statement, we + -- can fall out. In either case we need a following return. + + elsif Kind = N_Loop_Statement then + if Present (Iteration_Scheme (Last_Stm)) + or else Has_Exit (Entity (Identifier (Last_Stm))) + then + null; + + -- A loop with no exit statement or iteration scheme is either + -- an infinite loop, or it has some other exit (raise/return). + -- In either case, no warning is required. + + else + return; + end if; + + -- Timed entry call, check entry call and delay alternatives + + -- Note: in expanded code, the timed entry call has been converted + -- to a set of expanded statements on which the check will work + -- correctly in any case. + + elsif Kind = N_Timed_Entry_Call then + declare + ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm); + DCA : constant Node_Id := Delay_Alternative (Last_Stm); + + begin + -- If statement sequence of entry call alternative is missing, + -- then we can definitely fall through, and we post the error + -- message on the entry call alternative itself. + + if No (Statements (ECA)) then + Last_Stm := ECA; + + -- If statement sequence of delay alternative is missing, then + -- we can definitely fall through, and we post the error + -- message on the delay alternative itself. + + -- Note: if both ECA and DCA are missing the return, then we + -- post only one message, should be enough to fix the bugs. + -- If not we will get a message next time on the DCA when the + -- ECA is fixed! + + elsif No (Statements (DCA)) then + Last_Stm := DCA; + + -- Else check both statement sequences + + else + Check_Statement_Sequence (Statements (ECA)); + Check_Statement_Sequence (Statements (DCA)); + return; + end if; + end; + + -- Conditional entry call, check entry call and else part + + -- Note: in expanded code, the conditional entry call has been + -- converted to a set of expanded statements on which the check + -- will work correctly in any case. + + elsif Kind = N_Conditional_Entry_Call then + declare + ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm); + + begin + -- If statement sequence of entry call alternative is missing, + -- then we can definitely fall through, and we post the error + -- message on the entry call alternative itself. + + if No (Statements (ECA)) then + Last_Stm := ECA; + + -- Else check statement sequence and else part + + else + Check_Statement_Sequence (Statements (ECA)); + Check_Statement_Sequence (Else_Statements (Last_Stm)); + return; + end if; + end; + end if; + + -- If we fall through, issue appropriate message + + if Mode = 'F' then + if not Raise_Exception_Call then + Error_Msg_N + ("?RETURN statement missing following this statement!", + Last_Stm); + Error_Msg_N + ("\?Program_Error may be raised at run time!", + Last_Stm); + end if; + + -- Note: we set Err even though we have not issued a warning + -- because we still have a case of a missing return. This is + -- an extremely marginal case, probably will never be noticed + -- but we might as well get it right. + + Err := True; + + -- Otherwise we have the case of a procedure marked No_Return + + else + if not Raise_Exception_Call then + Error_Msg_N + ("?implied return after this statement " & + "will raise Program_Error", + Last_Stm); + Error_Msg_NE + ("\?procedure & is marked as No_Return!", + Last_Stm, Proc); + end if; + + declare + RE : constant Node_Id := + Make_Raise_Program_Error (Sloc (Last_Stm), + Reason => PE_Implicit_Return); + begin + Insert_After (Last_Stm, RE); + Analyze (RE); + end; + end if; + end Check_Statement_Sequence; + + -- Start of processing for Check_Returns + + begin + Err := False; + Check_Statement_Sequence (Statements (HSS)); + + if Present (Exception_Handlers (HSS)) then + Handler := First_Non_Pragma (Exception_Handlers (HSS)); + while Present (Handler) loop + Check_Statement_Sequence (Statements (Handler)); + Next_Non_Pragma (Handler); + end loop; + end if; + end Check_Returns; + + ---------------------------- + -- Check_Subprogram_Order -- + ---------------------------- + + procedure Check_Subprogram_Order (N : Node_Id) is + + function Subprogram_Name_Greater (S1, S2 : String) return Boolean; + -- This is used to check if S1 > S2 in the sense required by this + -- test, for example nameab < namec, but name2 < name10. + + ----------------------------- + -- Subprogram_Name_Greater -- + ----------------------------- + + function Subprogram_Name_Greater (S1, S2 : String) return Boolean is + L1, L2 : Positive; + N1, N2 : Natural; + + begin + -- Remove trailing numeric parts + + L1 := S1'Last; + while S1 (L1) in '0' .. '9' loop + L1 := L1 - 1; + end loop; + + L2 := S2'Last; + while S2 (L2) in '0' .. '9' loop + L2 := L2 - 1; + end loop; + + -- If non-numeric parts non-equal, that's decisive + + if S1 (S1'First .. L1) < S2 (S2'First .. L2) then + return False; + + elsif S1 (S1'First .. L1) > S2 (S2'First .. L2) then + return True; + + -- If non-numeric parts equal, compare suffixed numeric parts. Note + -- that a missing suffix is treated as numeric zero in this test. + + else + N1 := 0; + while L1 < S1'Last loop + L1 := L1 + 1; + N1 := N1 * 10 + Character'Pos (S1 (L1)) - Character'Pos ('0'); + end loop; + + N2 := 0; + while L2 < S2'Last loop + L2 := L2 + 1; + N2 := N2 * 10 + Character'Pos (S2 (L2)) - Character'Pos ('0'); + end loop; + + return N1 > N2; + end if; + end Subprogram_Name_Greater; + + -- Start of processing for Check_Subprogram_Order + + begin + -- Check body in alpha order if this is option + + if Style_Check + and then Style_Check_Order_Subprograms + and then Nkind (N) = N_Subprogram_Body + and then Comes_From_Source (N) + and then In_Extended_Main_Source_Unit (N) + then + declare + LSN : String_Ptr + renames Scope_Stack.Table + (Scope_Stack.Last).Last_Subprogram_Name; + + Body_Id : constant Entity_Id := + Defining_Entity (Specification (N)); + + begin + Get_Decoded_Name_String (Chars (Body_Id)); + + if LSN /= null then + if Subprogram_Name_Greater + (LSN.all, Name_Buffer (1 .. Name_Len)) + then + Style.Subprogram_Not_In_Alpha_Order (Body_Id); + end if; + + Free (LSN); + end if; + + LSN := new String'(Name_Buffer (1 .. Name_Len)); + end; + end if; + end Check_Subprogram_Order; + + ------------------------------ + -- Check_Subtype_Conformant -- + ------------------------------ + + procedure Check_Subtype_Conformant + (New_Id : Entity_Id; + Old_Id : Entity_Id; + Err_Loc : Node_Id := Empty; + Skip_Controlling_Formals : Boolean := False) + is + Result : Boolean; + pragma Warnings (Off, Result); + begin + Check_Conformance + (New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc, + Skip_Controlling_Formals => Skip_Controlling_Formals); + end Check_Subtype_Conformant; + + --------------------------- + -- Check_Type_Conformant -- + --------------------------- + + procedure Check_Type_Conformant + (New_Id : Entity_Id; + Old_Id : Entity_Id; + Err_Loc : Node_Id := Empty) + is + Result : Boolean; + pragma Warnings (Off, Result); + begin + Check_Conformance + (New_Id, Old_Id, Type_Conformant, True, Result, Err_Loc); + end Check_Type_Conformant; + + ---------------------- + -- Conforming_Types -- + ---------------------- + + function Conforming_Types + (T1 : Entity_Id; + T2 : Entity_Id; + Ctype : Conformance_Type; + Get_Inst : Boolean := False) return Boolean + is + Type_1 : Entity_Id := T1; + Type_2 : Entity_Id := T2; + Are_Anonymous_Access_To_Subprogram_Types : Boolean := False; + + function Base_Types_Match (T1, T2 : Entity_Id) return Boolean; + -- If neither T1 nor T2 are generic actual types, or if they are in + -- different scopes (e.g. parent and child instances), then verify that + -- the base types are equal. Otherwise T1 and T2 must be on the same + -- subtype chain. The whole purpose of this procedure is to prevent + -- spurious ambiguities in an instantiation that may arise if two + -- distinct generic types are instantiated with the same actual. + + function Find_Designated_Type (T : Entity_Id) return Entity_Id; + -- An access parameter can designate an incomplete type. If the + -- incomplete type is the limited view of a type from a limited_ + -- with_clause, check whether the non-limited view is available. If + -- it is a (non-limited) incomplete type, get the full view. + + function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean; + -- Returns True if and only if either T1 denotes a limited view of T2 + -- or T2 denotes a limited view of T1. This can arise when the limited + -- with view of a type is used in a subprogram declaration and the + -- subprogram body is in the scope of a regular with clause for the + -- same unit. In such a case, the two type entities can be considered + -- identical for purposes of conformance checking. + + ---------------------- + -- Base_Types_Match -- + ---------------------- + + function Base_Types_Match (T1, T2 : Entity_Id) return Boolean is + begin + if T1 = T2 then + return True; + + elsif Base_Type (T1) = Base_Type (T2) then + + -- The following is too permissive. A more precise test should + -- check that the generic actual is an ancestor subtype of the + -- other ???. + + return not Is_Generic_Actual_Type (T1) + or else not Is_Generic_Actual_Type (T2) + or else Scope (T1) /= Scope (T2); + + else + return False; + end if; + end Base_Types_Match; + + -------------------------- + -- Find_Designated_Type -- + -------------------------- + + function Find_Designated_Type (T : Entity_Id) return Entity_Id is + Desig : Entity_Id; + + begin + Desig := Directly_Designated_Type (T); + + if Ekind (Desig) = E_Incomplete_Type then + + -- If regular incomplete type, get full view if available + + if Present (Full_View (Desig)) then + Desig := Full_View (Desig); + + -- If limited view of a type, get non-limited view if available, + -- and check again for a regular incomplete type. + + elsif Present (Non_Limited_View (Desig)) then + Desig := Get_Full_View (Non_Limited_View (Desig)); + end if; + end if; + + return Desig; + end Find_Designated_Type; + + ------------------------------- + -- Matches_Limited_With_View -- + ------------------------------- + + function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean is + begin + -- In some cases a type imported through a limited_with clause, and + -- its nonlimited view are both visible, for example in an anonymous + -- access-to-class-wide type in a formal. Both entities designate the + -- same type. + + if From_With_Type (T1) + and then T2 = Available_View (T1) + then + return True; + + elsif From_With_Type (T2) + and then T1 = Available_View (T2) + then + return True; + + else + return False; + end if; + end Matches_Limited_With_View; + + -- Start of processing for Conforming_Types + + begin + -- The context is an instance association for a formal + -- access-to-subprogram type; the formal parameter types require + -- mapping because they may denote other formal parameters of the + -- generic unit. + + if Get_Inst then + Type_1 := Get_Instance_Of (T1); + Type_2 := Get_Instance_Of (T2); + end if; + + -- If one of the types is a view of the other introduced by a limited + -- with clause, treat these as conforming for all purposes. + + if Matches_Limited_With_View (T1, T2) then + return True; + + elsif Base_Types_Match (Type_1, Type_2) then + return Ctype <= Mode_Conformant + or else Subtypes_Statically_Match (Type_1, Type_2); + + elsif Is_Incomplete_Or_Private_Type (Type_1) + and then Present (Full_View (Type_1)) + and then Base_Types_Match (Full_View (Type_1), Type_2) + then + return Ctype <= Mode_Conformant + or else Subtypes_Statically_Match (Full_View (Type_1), Type_2); + + elsif Ekind (Type_2) = E_Incomplete_Type + and then Present (Full_View (Type_2)) + and then Base_Types_Match (Type_1, Full_View (Type_2)) + then + return Ctype <= Mode_Conformant + or else Subtypes_Statically_Match (Type_1, Full_View (Type_2)); + + elsif Is_Private_Type (Type_2) + and then In_Instance + and then Present (Full_View (Type_2)) + and then Base_Types_Match (Type_1, Full_View (Type_2)) + then + return Ctype <= Mode_Conformant + or else Subtypes_Statically_Match (Type_1, Full_View (Type_2)); + end if; + + -- Ada 2005 (AI-254): Anonymous access-to-subprogram types must be + -- treated recursively because they carry a signature. + + Are_Anonymous_Access_To_Subprogram_Types := + Ekind (Type_1) = Ekind (Type_2) + and then + (Ekind (Type_1) = E_Anonymous_Access_Subprogram_Type + or else + Ekind (Type_1) = E_Anonymous_Access_Protected_Subprogram_Type); + + -- Test anonymous access type case. For this case, static subtype + -- matching is required for mode conformance (RM 6.3.1(15)). We check + -- the base types because we may have built internal subtype entities + -- to handle null-excluding types (see Process_Formals). + + if (Ekind (Base_Type (Type_1)) = E_Anonymous_Access_Type + and then + Ekind (Base_Type (Type_2)) = E_Anonymous_Access_Type) + or else Are_Anonymous_Access_To_Subprogram_Types -- Ada 2005 (AI-254) + then + declare + Desig_1 : Entity_Id; + Desig_2 : Entity_Id; + + begin + -- In Ada2005, access constant indicators must match for + -- subtype conformance. + + if Ada_Version >= Ada_2005 + and then Ctype >= Subtype_Conformant + and then + Is_Access_Constant (Type_1) /= Is_Access_Constant (Type_2) + then + return False; + end if; + + Desig_1 := Find_Designated_Type (Type_1); + Desig_2 := Find_Designated_Type (Type_2); + + -- If the context is an instance association for a formal + -- access-to-subprogram type; formal access parameter designated + -- types require mapping because they may denote other formal + -- parameters of the generic unit. + + if Get_Inst then + Desig_1 := Get_Instance_Of (Desig_1); + Desig_2 := Get_Instance_Of (Desig_2); + end if; + + -- It is possible for a Class_Wide_Type to be introduced for an + -- incomplete type, in which case there is a separate class_ wide + -- type for the full view. The types conform if their Etypes + -- conform, i.e. one may be the full view of the other. This can + -- only happen in the context of an access parameter, other uses + -- of an incomplete Class_Wide_Type are illegal. + + if Is_Class_Wide_Type (Desig_1) + and then + Is_Class_Wide_Type (Desig_2) + then + return + Conforming_Types + (Etype (Base_Type (Desig_1)), + Etype (Base_Type (Desig_2)), Ctype); + + elsif Are_Anonymous_Access_To_Subprogram_Types then + if Ada_Version < Ada_2005 then + return Ctype = Type_Conformant + or else + Subtypes_Statically_Match (Desig_1, Desig_2); + + -- We must check the conformance of the signatures themselves + + else + declare + Conformant : Boolean; + begin + Check_Conformance + (Desig_1, Desig_2, Ctype, False, Conformant); + return Conformant; + end; + end if; + + else + return Base_Type (Desig_1) = Base_Type (Desig_2) + and then (Ctype = Type_Conformant + or else + Subtypes_Statically_Match (Desig_1, Desig_2)); + end if; + end; + + -- Otherwise definitely no match + + else + if ((Ekind (Type_1) = E_Anonymous_Access_Type + and then Is_Access_Type (Type_2)) + or else (Ekind (Type_2) = E_Anonymous_Access_Type + and then Is_Access_Type (Type_1))) + and then + Conforming_Types + (Designated_Type (Type_1), Designated_Type (Type_2), Ctype) + then + May_Hide_Profile := True; + end if; + + return False; + end if; + end Conforming_Types; + + -------------------------- + -- Create_Extra_Formals -- + -------------------------- + + procedure Create_Extra_Formals (E : Entity_Id) is + Formal : Entity_Id; + First_Extra : Entity_Id := Empty; + Last_Extra : Entity_Id; + Formal_Type : Entity_Id; + P_Formal : Entity_Id := Empty; + + function Add_Extra_Formal + (Assoc_Entity : Entity_Id; + Typ : Entity_Id; + Scope : Entity_Id; + Suffix : String) return Entity_Id; + -- Add an extra formal to the current list of formals and extra formals. + -- The extra formal is added to the end of the list of extra formals, + -- and also returned as the result. These formals are always of mode IN. + -- The new formal has the type Typ, is declared in Scope, and its name + -- is given by a concatenation of the name of Assoc_Entity and Suffix. + -- The following suffixes are currently used. They should not be changed + -- without coordinating with CodePeer, which makes use of these to + -- provide better messages. + + -- O denotes the Constrained bit. + -- L denotes the accessibility level. + -- BIP_xxx denotes an extra formal for a build-in-place function. See + -- the full list in exp_ch6.BIP_Formal_Kind. + + ---------------------- + -- Add_Extra_Formal -- + ---------------------- + + function Add_Extra_Formal + (Assoc_Entity : Entity_Id; + Typ : Entity_Id; + Scope : Entity_Id; + Suffix : String) return Entity_Id + is + EF : constant Entity_Id := + Make_Defining_Identifier (Sloc (Assoc_Entity), + Chars => New_External_Name (Chars (Assoc_Entity), + Suffix => Suffix)); + + begin + -- A little optimization. Never generate an extra formal for the + -- _init operand of an initialization procedure, since it could + -- never be used. + + if Chars (Formal) = Name_uInit then + return Empty; + end if; + + Set_Ekind (EF, E_In_Parameter); + Set_Actual_Subtype (EF, Typ); + Set_Etype (EF, Typ); + Set_Scope (EF, Scope); + Set_Mechanism (EF, Default_Mechanism); + Set_Formal_Validity (EF); + + if No (First_Extra) then + First_Extra := EF; + Set_Extra_Formals (Scope, First_Extra); + end if; + + if Present (Last_Extra) then + Set_Extra_Formal (Last_Extra, EF); + end if; + + Last_Extra := EF; + + return EF; + end Add_Extra_Formal; + + -- Start of processing for Create_Extra_Formals + + begin + -- We never generate extra formals if expansion is not active + -- because we don't need them unless we are generating code. + + if not Expander_Active then + return; + end if; + + -- If this is a derived subprogram then the subtypes of the parent + -- subprogram's formal parameters will be used to determine the need + -- for extra formals. + + if Is_Overloadable (E) and then Present (Alias (E)) then + P_Formal := First_Formal (Alias (E)); + end if; + + Last_Extra := Empty; + Formal := First_Formal (E); + while Present (Formal) loop + Last_Extra := Formal; + Next_Formal (Formal); + end loop; + + -- If Extra_formals were already created, don't do it again. This + -- situation may arise for subprogram types created as part of + -- dispatching calls (see Expand_Dispatching_Call) + + if Present (Last_Extra) and then + Present (Extra_Formal (Last_Extra)) + then + return; + end if; + + -- If the subprogram is a predefined dispatching subprogram then don't + -- generate any extra constrained or accessibility level formals. In + -- general we suppress these for internal subprograms (by not calling + -- Freeze_Subprogram and Create_Extra_Formals at all), but internally + -- generated stream attributes do get passed through because extra + -- build-in-place formals are needed in some cases (limited 'Input). + + if Is_Predefined_Internal_Operation (E) then + goto Test_For_BIP_Extras; + end if; + + Formal := First_Formal (E); + while Present (Formal) loop + + -- Create extra formal for supporting the attribute 'Constrained. + -- The case of a private type view without discriminants also + -- requires the extra formal if the underlying type has defaulted + -- discriminants. + + if Ekind (Formal) /= E_In_Parameter then + if Present (P_Formal) then + Formal_Type := Etype (P_Formal); + else + Formal_Type := Etype (Formal); + end if; + + -- Do not produce extra formals for Unchecked_Union parameters. + -- Jump directly to the end of the loop. + + if Is_Unchecked_Union (Base_Type (Formal_Type)) then + goto Skip_Extra_Formal_Generation; + end if; + + if not Has_Discriminants (Formal_Type) + and then Ekind (Formal_Type) in Private_Kind + and then Present (Underlying_Type (Formal_Type)) + then + Formal_Type := Underlying_Type (Formal_Type); + end if; + + -- Suppress the extra formal if formal's subtype is constrained or + -- indefinite, or we're compiling for Ada 2012 and the underlying + -- type is tagged and limited. In Ada 2012, a limited tagged type + -- can have defaulted discriminants, but 'Constrained is required + -- to return True, so the formal is never needed (see AI05-0214). + -- Note that this ensures consistency of calling sequences for + -- dispatching operations when some types in a class have defaults + -- on discriminants and others do not (and requiring the extra + -- formal would introduce distributed overhead). + + if Has_Discriminants (Formal_Type) + and then not Is_Constrained (Formal_Type) + and then not Is_Indefinite_Subtype (Formal_Type) + and then (Ada_Version < Ada_2012 + or else + not (Is_Tagged_Type (Underlying_Type (Formal_Type)) + and then Is_Limited_Type (Formal_Type))) + then + Set_Extra_Constrained + (Formal, Add_Extra_Formal (Formal, Standard_Boolean, E, "O")); + end if; + end if; + + -- Create extra formal for supporting accessibility checking. This + -- is done for both anonymous access formals and formals of named + -- access types that are marked as controlling formals. The latter + -- case can occur when Expand_Dispatching_Call creates a subprogram + -- type and substitutes the types of access-to-class-wide actuals + -- for the anonymous access-to-specific-type of controlling formals. + -- Base_Type is applied because in cases where there is a null + -- exclusion the formal may have an access subtype. + + -- This is suppressed if we specifically suppress accessibility + -- checks at the package level for either the subprogram, or the + -- package in which it resides. However, we do not suppress it + -- simply if the scope has accessibility checks suppressed, since + -- this could cause trouble when clients are compiled with a + -- different suppression setting. The explicit checks at the + -- package level are safe from this point of view. + + if (Ekind (Base_Type (Etype (Formal))) = E_Anonymous_Access_Type + or else (Is_Controlling_Formal (Formal) + and then Is_Access_Type (Base_Type (Etype (Formal))))) + and then not + (Explicit_Suppress (E, Accessibility_Check) + or else + Explicit_Suppress (Scope (E), Accessibility_Check)) + and then + (No (P_Formal) + or else Present (Extra_Accessibility (P_Formal))) + then + Set_Extra_Accessibility + (Formal, Add_Extra_Formal (Formal, Standard_Natural, E, "L")); + end if; + + -- This label is required when skipping extra formal generation for + -- Unchecked_Union parameters. + + <> + + if Present (P_Formal) then + Next_Formal (P_Formal); + end if; + + Next_Formal (Formal); + end loop; + + <> + + -- Ada 2005 (AI-318-02): In the case of build-in-place functions, add + -- appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind. + + if Ada_Version >= Ada_2005 and then Is_Build_In_Place_Function (E) then + declare + Result_Subt : constant Entity_Id := Etype (E); + + Discard : Entity_Id; + pragma Warnings (Off, Discard); + + begin + -- In the case of functions with unconstrained result subtypes, + -- add a 4-state formal indicating whether the return object is + -- allocated by the caller (1), or should be allocated by the + -- callee on the secondary stack (2), in the global heap (3), or + -- in a user-defined storage pool (4). For the moment we just use + -- Natural for the type of this formal. Note that this formal + -- isn't usually needed in the case where the result subtype is + -- constrained, but it is needed when the function has a tagged + -- result, because generally such functions can be called in a + -- dispatching context and such calls must be handled like calls + -- to a class-wide function. + + if not Is_Constrained (Underlying_Type (Result_Subt)) + or else Is_Tagged_Type (Underlying_Type (Result_Subt)) + then + Discard := + Add_Extra_Formal + (E, Standard_Natural, + E, BIP_Formal_Suffix (BIP_Alloc_Form)); + end if; + + -- For functions whose result type has controlled parts, we have + -- an extra formal of type System.Finalization_Implementation. + -- Finalizable_Ptr_Ptr. That is, we are passing a pointer to a + -- finalization list (which is itself a pointer). This extra + -- formal is then passed along to Move_Final_List in case of + -- successful completion of a return statement. We cannot pass an + -- 'in out' parameter, because we need to update the finalization + -- list during an abort-deferred region, rather than using + -- copy-back after the function returns. This is true even if we + -- are able to get away with having 'in out' parameters, which are + -- normally illegal for functions. This formal is also needed when + -- the function has a tagged result. + + if Needs_BIP_Final_List (E) then + Discard := + Add_Extra_Formal + (E, RTE (RE_Finalizable_Ptr_Ptr), + E, BIP_Formal_Suffix (BIP_Final_List)); + end if; + + -- If the result type contains tasks, we have two extra formals: + -- the master of the tasks to be created, and the caller's + -- activation chain. + + if Has_Task (Result_Subt) then + Discard := + Add_Extra_Formal + (E, RTE (RE_Master_Id), + E, BIP_Formal_Suffix (BIP_Master)); + Discard := + Add_Extra_Formal + (E, RTE (RE_Activation_Chain_Access), + E, BIP_Formal_Suffix (BIP_Activation_Chain)); + end if; + + -- All build-in-place functions get an extra formal that will be + -- passed the address of the return object within the caller. + + declare + Formal_Type : constant Entity_Id := + Create_Itype + (E_Anonymous_Access_Type, E, + Scope_Id => Scope (E)); + begin + Set_Directly_Designated_Type (Formal_Type, Result_Subt); + Set_Etype (Formal_Type, Formal_Type); + Set_Depends_On_Private + (Formal_Type, Has_Private_Component (Formal_Type)); + Set_Is_Public (Formal_Type, Is_Public (Scope (Formal_Type))); + Set_Is_Access_Constant (Formal_Type, False); + + -- Ada 2005 (AI-50217): Propagate the attribute that indicates + -- the designated type comes from the limited view (for + -- back-end purposes). + + Set_From_With_Type (Formal_Type, From_With_Type (Result_Subt)); + + Layout_Type (Formal_Type); + + Discard := + Add_Extra_Formal + (E, Formal_Type, E, BIP_Formal_Suffix (BIP_Object_Access)); + end; + end; + end if; + end Create_Extra_Formals; + + ----------------------------- + -- Enter_Overloaded_Entity -- + ----------------------------- + + procedure Enter_Overloaded_Entity (S : Entity_Id) is + E : Entity_Id := Current_Entity_In_Scope (S); + C_E : Entity_Id := Current_Entity (S); + + begin + if Present (E) then + Set_Has_Homonym (E); + Set_Has_Homonym (S); + end if; + + Set_Is_Immediately_Visible (S); + Set_Scope (S, Current_Scope); + + -- Chain new entity if front of homonym in current scope, so that + -- homonyms are contiguous. + + if Present (E) + and then E /= C_E + then + while Homonym (C_E) /= E loop + C_E := Homonym (C_E); + end loop; + + Set_Homonym (C_E, S); + + else + E := C_E; + Set_Current_Entity (S); + end if; + + Set_Homonym (S, E); + + Append_Entity (S, Current_Scope); + Set_Public_Status (S); + + if Debug_Flag_E then + Write_Str ("New overloaded entity chain: "); + Write_Name (Chars (S)); + + E := S; + while Present (E) loop + Write_Str (" "); Write_Int (Int (E)); + E := Homonym (E); + end loop; + + Write_Eol; + end if; + + -- Generate warning for hiding + + if Warn_On_Hiding + and then Comes_From_Source (S) + and then In_Extended_Main_Source_Unit (S) + then + E := S; + loop + E := Homonym (E); + exit when No (E); + + -- Warn unless genuine overloading. Do not emit warning on + -- hiding predefined operators in Standard (these are either an + -- (artifact of our implicit declarations, or simple noise) but + -- keep warning on a operator defined on a local subtype, because + -- of the real danger that different operators may be applied in + -- various parts of the program. + + if (not Is_Overloadable (E) or else Subtype_Conformant (E, S)) + and then (Is_Immediately_Visible (E) + or else + Is_Potentially_Use_Visible (S)) + then + if Scope (E) /= Standard_Standard then + Error_Msg_Sloc := Sloc (E); + Error_Msg_N ("declaration of & hides one#?", S); + + elsif Nkind (S) = N_Defining_Operator_Symbol + and then + Scope ( + Base_Type (Etype (First_Formal (S)))) /= Scope (S) + then + Error_Msg_N + ("declaration of & hides predefined operator?", S); + end if; + end if; + end loop; + end if; + end Enter_Overloaded_Entity; + + ----------------------------- + -- Check_Untagged_Equality -- + ----------------------------- + + procedure Check_Untagged_Equality (Eq_Op : Entity_Id) is + Typ : constant Entity_Id := Etype (First_Formal (Eq_Op)); + Decl : constant Node_Id := Unit_Declaration_Node (Eq_Op); + Obj_Decl : Node_Id; + + begin + if Nkind (Decl) = N_Subprogram_Declaration + and then Is_Record_Type (Typ) + and then not Is_Tagged_Type (Typ) + then + -- If the type is not declared in a package, or if we are in the + -- body of the package or in some other scope, the new operation is + -- not primitive, and therefore legal, though suspicious. If the + -- type is a generic actual (sub)type, the operation is not primitive + -- either because the base type is declared elsewhere. + + if Is_Frozen (Typ) then + if Ekind (Scope (Typ)) /= E_Package + or else Scope (Typ) /= Current_Scope + then + null; + + elsif Is_Generic_Actual_Type (Typ) then + null; + + elsif In_Package_Body (Scope (Typ)) then + Error_Msg_NE + ("equality operator must be declared " + & "before type& is frozen", Eq_Op, Typ); + Error_Msg_N + ("\move declaration to package spec", Eq_Op); + + else + Error_Msg_NE + ("equality operator must be declared " + & "before type& is frozen", Eq_Op, Typ); + + Obj_Decl := Next (Parent (Typ)); + while Present (Obj_Decl) + and then Obj_Decl /= Decl + loop + if Nkind (Obj_Decl) = N_Object_Declaration + and then Etype (Defining_Identifier (Obj_Decl)) = Typ + then + Error_Msg_NE ("type& is frozen by declaration?", + Obj_Decl, Typ); + Error_Msg_N + ("\an equality operator cannot be declared after this " + & "point ('R'M 4.5.2 (9.8)) (Ada 2012))?", Obj_Decl); + exit; + end if; + + Next (Obj_Decl); + end loop; + end if; + + elsif not In_Same_List (Parent (Typ), Decl) + and then not Is_Limited_Type (Typ) + then + + -- This makes it illegal to have a primitive equality declared in + -- the private part if the type is visible. + + Error_Msg_N ("equality operator appears too late", Eq_Op); + end if; + end if; + end Check_Untagged_Equality; + + ----------------------------- + -- Find_Corresponding_Spec -- + ----------------------------- + + function Find_Corresponding_Spec + (N : Node_Id; + Post_Error : Boolean := True) return Entity_Id + is + Spec : constant Node_Id := Specification (N); + Designator : constant Entity_Id := Defining_Entity (Spec); + + E : Entity_Id; + + begin + E := Current_Entity (Designator); + while Present (E) loop + + -- We are looking for a matching spec. It must have the same scope, + -- and the same name, and either be type conformant, or be the case + -- of a library procedure spec and its body (which belong to one + -- another regardless of whether they are type conformant or not). + + if Scope (E) = Current_Scope then + if Current_Scope = Standard_Standard + or else (Ekind (E) = Ekind (Designator) + and then Type_Conformant (E, Designator)) + then + -- Within an instantiation, we know that spec and body are + -- subtype conformant, because they were subtype conformant + -- in the generic. We choose the subtype-conformant entity + -- here as well, to resolve spurious ambiguities in the + -- instance that were not present in the generic (i.e. when + -- two different types are given the same actual). If we are + -- looking for a spec to match a body, full conformance is + -- expected. + + if In_Instance then + Set_Convention (Designator, Convention (E)); + + if Nkind (N) = N_Subprogram_Body + and then Present (Homonym (E)) + and then not Fully_Conformant (E, Designator) + then + goto Next_Entity; + + elsif not Subtype_Conformant (E, Designator) then + goto Next_Entity; + end if; + end if; + + if not Has_Completion (E) then + if Nkind (N) /= N_Subprogram_Body_Stub then + Set_Corresponding_Spec (N, E); + end if; + + Set_Has_Completion (E); + return E; + + elsif Nkind (Parent (N)) = N_Subunit then + + -- If this is the proper body of a subunit, the completion + -- flag is set when analyzing the stub. + + return E; + + -- If E is an internal function with a controlling result + -- that was created for an operation inherited by a null + -- extension, it may be overridden by a body without a previous + -- spec (one more reason why these should be shunned). In that + -- case remove the generated body if present, because the + -- current one is the explicit overriding. + + elsif Ekind (E) = E_Function + and then Ada_Version >= Ada_2005 + and then not Comes_From_Source (E) + and then Has_Controlling_Result (E) + and then Is_Null_Extension (Etype (E)) + and then Comes_From_Source (Spec) + then + Set_Has_Completion (E, False); + + if Expander_Active + and then Nkind (Parent (E)) = N_Function_Specification + then + Remove + (Unit_Declaration_Node + (Corresponding_Body (Unit_Declaration_Node (E)))); + + return E; + + -- If expansion is disabled, or if the wrapper function has + -- not been generated yet, this a late body overriding an + -- inherited operation, or it is an overriding by some other + -- declaration before the controlling result is frozen. In + -- either case this is a declaration of a new entity. + + else + return Empty; + end if; + + -- If the body already exists, then this is an error unless + -- the previous declaration is the implicit declaration of a + -- derived subprogram, or this is a spurious overloading in an + -- instance. + + elsif No (Alias (E)) + and then not Is_Intrinsic_Subprogram (E) + and then not In_Instance + and then Post_Error + then + Error_Msg_Sloc := Sloc (E); + + if Is_Imported (E) then + Error_Msg_NE + ("body not allowed for imported subprogram & declared#", + N, E); + else + Error_Msg_NE ("duplicate body for & declared#", N, E); + end if; + end if; + + -- Child units cannot be overloaded, so a conformance mismatch + -- between body and a previous spec is an error. + + elsif Is_Child_Unit (E) + and then + Nkind (Unit_Declaration_Node (Designator)) = N_Subprogram_Body + and then + Nkind (Parent (Unit_Declaration_Node (Designator))) = + N_Compilation_Unit + and then Post_Error + then + Error_Msg_N + ("body of child unit does not match previous declaration", N); + end if; + end if; + + <> + E := Homonym (E); + end loop; + + -- On exit, we know that no previous declaration of subprogram exists + + return Empty; + end Find_Corresponding_Spec; + + ---------------------- + -- Fully_Conformant -- + ---------------------- + + function Fully_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is + Result : Boolean; + begin + Check_Conformance (New_Id, Old_Id, Fully_Conformant, False, Result); + return Result; + end Fully_Conformant; + + ---------------------------------- + -- Fully_Conformant_Expressions -- + ---------------------------------- + + function Fully_Conformant_Expressions + (Given_E1 : Node_Id; + Given_E2 : Node_Id) return Boolean + is + E1 : constant Node_Id := Original_Node (Given_E1); + E2 : constant Node_Id := Original_Node (Given_E2); + -- We always test conformance on original nodes, since it is possible + -- for analysis and/or expansion to make things look as though they + -- conform when they do not, e.g. by converting 1+2 into 3. + + function FCE (Given_E1, Given_E2 : Node_Id) return Boolean + renames Fully_Conformant_Expressions; + + function FCL (L1, L2 : List_Id) return Boolean; + -- Compare elements of two lists for conformance. Elements have to + -- be conformant, and actuals inserted as default parameters do not + -- match explicit actuals with the same value. + + function FCO (Op_Node, Call_Node : Node_Id) return Boolean; + -- Compare an operator node with a function call + + --------- + -- FCL -- + --------- + + function FCL (L1, L2 : List_Id) return Boolean is + N1, N2 : Node_Id; + + begin + if L1 = No_List then + N1 := Empty; + else + N1 := First (L1); + end if; + + if L2 = No_List then + N2 := Empty; + else + N2 := First (L2); + end if; + + -- Compare two lists, skipping rewrite insertions (we want to + -- compare the original trees, not the expanded versions!) + + loop + if Is_Rewrite_Insertion (N1) then + Next (N1); + elsif Is_Rewrite_Insertion (N2) then + Next (N2); + elsif No (N1) then + return No (N2); + elsif No (N2) then + return False; + elsif not FCE (N1, N2) then + return False; + else + Next (N1); + Next (N2); + end if; + end loop; + end FCL; + + --------- + -- FCO -- + --------- + + function FCO (Op_Node, Call_Node : Node_Id) return Boolean is + Actuals : constant List_Id := Parameter_Associations (Call_Node); + Act : Node_Id; + + begin + if No (Actuals) + or else Entity (Op_Node) /= Entity (Name (Call_Node)) + then + return False; + + else + Act := First (Actuals); + + if Nkind (Op_Node) in N_Binary_Op then + if not FCE (Left_Opnd (Op_Node), Act) then + return False; + end if; + + Next (Act); + end if; + + return Present (Act) + and then FCE (Right_Opnd (Op_Node), Act) + and then No (Next (Act)); + end if; + end FCO; + + -- Start of processing for Fully_Conformant_Expressions + + begin + -- Non-conformant if paren count does not match. Note: if some idiot + -- complains that we don't do this right for more than 3 levels of + -- parentheses, they will be treated with the respect they deserve! + + if Paren_Count (E1) /= Paren_Count (E2) then + return False; + + -- If same entities are referenced, then they are conformant even if + -- they have different forms (RM 8.3.1(19-20)). + + elsif Is_Entity_Name (E1) and then Is_Entity_Name (E2) then + if Present (Entity (E1)) then + return Entity (E1) = Entity (E2) + or else (Chars (Entity (E1)) = Chars (Entity (E2)) + and then Ekind (Entity (E1)) = E_Discriminant + and then Ekind (Entity (E2)) = E_In_Parameter); + + elsif Nkind (E1) = N_Expanded_Name + and then Nkind (E2) = N_Expanded_Name + and then Nkind (Selector_Name (E1)) = N_Character_Literal + and then Nkind (Selector_Name (E2)) = N_Character_Literal + then + return Chars (Selector_Name (E1)) = Chars (Selector_Name (E2)); + + else + -- Identifiers in component associations don't always have + -- entities, but their names must conform. + + return Nkind (E1) = N_Identifier + and then Nkind (E2) = N_Identifier + and then Chars (E1) = Chars (E2); + end if; + + elsif Nkind (E1) = N_Character_Literal + and then Nkind (E2) = N_Expanded_Name + then + return Nkind (Selector_Name (E2)) = N_Character_Literal + and then Chars (E1) = Chars (Selector_Name (E2)); + + elsif Nkind (E2) = N_Character_Literal + and then Nkind (E1) = N_Expanded_Name + then + return Nkind (Selector_Name (E1)) = N_Character_Literal + and then Chars (E2) = Chars (Selector_Name (E1)); + + elsif Nkind (E1) in N_Op + and then Nkind (E2) = N_Function_Call + then + return FCO (E1, E2); + + elsif Nkind (E2) in N_Op + and then Nkind (E1) = N_Function_Call + then + return FCO (E2, E1); + + -- Otherwise we must have the same syntactic entity + + elsif Nkind (E1) /= Nkind (E2) then + return False; + + -- At this point, we specialize by node type + + else + case Nkind (E1) is + + when N_Aggregate => + return + FCL (Expressions (E1), Expressions (E2)) + and then + FCL (Component_Associations (E1), + Component_Associations (E2)); + + when N_Allocator => + if Nkind (Expression (E1)) = N_Qualified_Expression + or else + Nkind (Expression (E2)) = N_Qualified_Expression + then + return FCE (Expression (E1), Expression (E2)); + + -- Check that the subtype marks and any constraints + -- are conformant + + else + declare + Indic1 : constant Node_Id := Expression (E1); + Indic2 : constant Node_Id := Expression (E2); + Elt1 : Node_Id; + Elt2 : Node_Id; + + begin + if Nkind (Indic1) /= N_Subtype_Indication then + return + Nkind (Indic2) /= N_Subtype_Indication + and then Entity (Indic1) = Entity (Indic2); + + elsif Nkind (Indic2) /= N_Subtype_Indication then + return + Nkind (Indic1) /= N_Subtype_Indication + and then Entity (Indic1) = Entity (Indic2); + + else + if Entity (Subtype_Mark (Indic1)) /= + Entity (Subtype_Mark (Indic2)) + then + return False; + end if; + + Elt1 := First (Constraints (Constraint (Indic1))); + Elt2 := First (Constraints (Constraint (Indic2))); + while Present (Elt1) and then Present (Elt2) loop + if not FCE (Elt1, Elt2) then + return False; + end if; + + Next (Elt1); + Next (Elt2); + end loop; + + return True; + end if; + end; + end if; + + when N_Attribute_Reference => + return + Attribute_Name (E1) = Attribute_Name (E2) + and then FCL (Expressions (E1), Expressions (E2)); + + when N_Binary_Op => + return + Entity (E1) = Entity (E2) + and then FCE (Left_Opnd (E1), Left_Opnd (E2)) + and then FCE (Right_Opnd (E1), Right_Opnd (E2)); + + when N_Short_Circuit | N_Membership_Test => + return + FCE (Left_Opnd (E1), Left_Opnd (E2)) + and then + FCE (Right_Opnd (E1), Right_Opnd (E2)); + + when N_Case_Expression => + declare + Alt1 : Node_Id; + Alt2 : Node_Id; + + begin + if not FCE (Expression (E1), Expression (E2)) then + return False; + + else + Alt1 := First (Alternatives (E1)); + Alt2 := First (Alternatives (E2)); + loop + if Present (Alt1) /= Present (Alt2) then + return False; + elsif No (Alt1) then + return True; + end if; + + if not FCE (Expression (Alt1), Expression (Alt2)) + or else not FCL (Discrete_Choices (Alt1), + Discrete_Choices (Alt2)) + then + return False; + end if; + + Next (Alt1); + Next (Alt2); + end loop; + end if; + end; + + when N_Character_Literal => + return + Char_Literal_Value (E1) = Char_Literal_Value (E2); + + when N_Component_Association => + return + FCL (Choices (E1), Choices (E2)) + and then + FCE (Expression (E1), Expression (E2)); + + when N_Conditional_Expression => + return + FCL (Expressions (E1), Expressions (E2)); + + when N_Explicit_Dereference => + return + FCE (Prefix (E1), Prefix (E2)); + + when N_Extension_Aggregate => + return + FCL (Expressions (E1), Expressions (E2)) + and then Null_Record_Present (E1) = + Null_Record_Present (E2) + and then FCL (Component_Associations (E1), + Component_Associations (E2)); + + when N_Function_Call => + return + FCE (Name (E1), Name (E2)) + and then + FCL (Parameter_Associations (E1), + Parameter_Associations (E2)); + + when N_Indexed_Component => + return + FCE (Prefix (E1), Prefix (E2)) + and then + FCL (Expressions (E1), Expressions (E2)); + + when N_Integer_Literal => + return (Intval (E1) = Intval (E2)); + + when N_Null => + return True; + + when N_Operator_Symbol => + return + Chars (E1) = Chars (E2); + + when N_Others_Choice => + return True; + + when N_Parameter_Association => + return + Chars (Selector_Name (E1)) = Chars (Selector_Name (E2)) + and then FCE (Explicit_Actual_Parameter (E1), + Explicit_Actual_Parameter (E2)); + + when N_Qualified_Expression => + return + FCE (Subtype_Mark (E1), Subtype_Mark (E2)) + and then + FCE (Expression (E1), Expression (E2)); + + when N_Range => + return + FCE (Low_Bound (E1), Low_Bound (E2)) + and then + FCE (High_Bound (E1), High_Bound (E2)); + + when N_Real_Literal => + return (Realval (E1) = Realval (E2)); + + when N_Selected_Component => + return + FCE (Prefix (E1), Prefix (E2)) + and then + FCE (Selector_Name (E1), Selector_Name (E2)); + + when N_Slice => + return + FCE (Prefix (E1), Prefix (E2)) + and then + FCE (Discrete_Range (E1), Discrete_Range (E2)); + + when N_String_Literal => + declare + S1 : constant String_Id := Strval (E1); + S2 : constant String_Id := Strval (E2); + L1 : constant Nat := String_Length (S1); + L2 : constant Nat := String_Length (S2); + + begin + if L1 /= L2 then + return False; + + else + for J in 1 .. L1 loop + if Get_String_Char (S1, J) /= + Get_String_Char (S2, J) + then + return False; + end if; + end loop; + + return True; + end if; + end; + + when N_Type_Conversion => + return + FCE (Subtype_Mark (E1), Subtype_Mark (E2)) + and then + FCE (Expression (E1), Expression (E2)); + + when N_Unary_Op => + return + Entity (E1) = Entity (E2) + and then + FCE (Right_Opnd (E1), Right_Opnd (E2)); + + when N_Unchecked_Type_Conversion => + return + FCE (Subtype_Mark (E1), Subtype_Mark (E2)) + and then + FCE (Expression (E1), Expression (E2)); + + -- All other node types cannot appear in this context. Strictly + -- we should raise a fatal internal error. Instead we just ignore + -- the nodes. This means that if anyone makes a mistake in the + -- expander and mucks an expression tree irretrievably, the + -- result will be a failure to detect a (probably very obscure) + -- case of non-conformance, which is better than bombing on some + -- case where two expressions do in fact conform. + + when others => + return True; + + end case; + end if; + end Fully_Conformant_Expressions; + + ---------------------------------------- + -- Fully_Conformant_Discrete_Subtypes -- + ---------------------------------------- + + function Fully_Conformant_Discrete_Subtypes + (Given_S1 : Node_Id; + Given_S2 : Node_Id) return Boolean + is + S1 : constant Node_Id := Original_Node (Given_S1); + S2 : constant Node_Id := Original_Node (Given_S2); + + function Conforming_Bounds (B1, B2 : Node_Id) return Boolean; + -- Special-case for a bound given by a discriminant, which in the body + -- is replaced with the discriminal of the enclosing type. + + function Conforming_Ranges (R1, R2 : Node_Id) return Boolean; + -- Check both bounds + + ----------------------- + -- Conforming_Bounds -- + ----------------------- + + function Conforming_Bounds (B1, B2 : Node_Id) return Boolean is + begin + if Is_Entity_Name (B1) + and then Is_Entity_Name (B2) + and then Ekind (Entity (B1)) = E_Discriminant + then + return Chars (B1) = Chars (B2); + + else + return Fully_Conformant_Expressions (B1, B2); + end if; + end Conforming_Bounds; + + ----------------------- + -- Conforming_Ranges -- + ----------------------- + + function Conforming_Ranges (R1, R2 : Node_Id) return Boolean is + begin + return + Conforming_Bounds (Low_Bound (R1), Low_Bound (R2)) + and then + Conforming_Bounds (High_Bound (R1), High_Bound (R2)); + end Conforming_Ranges; + + -- Start of processing for Fully_Conformant_Discrete_Subtypes + + begin + if Nkind (S1) /= Nkind (S2) then + return False; + + elsif Is_Entity_Name (S1) then + return Entity (S1) = Entity (S2); + + elsif Nkind (S1) = N_Range then + return Conforming_Ranges (S1, S2); + + elsif Nkind (S1) = N_Subtype_Indication then + return + Entity (Subtype_Mark (S1)) = Entity (Subtype_Mark (S2)) + and then + Conforming_Ranges + (Range_Expression (Constraint (S1)), + Range_Expression (Constraint (S2))); + else + return True; + end if; + end Fully_Conformant_Discrete_Subtypes; + + -------------------- + -- Install_Entity -- + -------------------- + + procedure Install_Entity (E : Entity_Id) is + Prev : constant Entity_Id := Current_Entity (E); + begin + Set_Is_Immediately_Visible (E); + Set_Current_Entity (E); + Set_Homonym (E, Prev); + end Install_Entity; + + --------------------- + -- Install_Formals -- + --------------------- + + procedure Install_Formals (Id : Entity_Id) is + F : Entity_Id; + begin + F := First_Formal (Id); + while Present (F) loop + Install_Entity (F); + Next_Formal (F); + end loop; + end Install_Formals; + + ----------------------------- + -- Is_Interface_Conformant -- + ----------------------------- + + function Is_Interface_Conformant + (Tagged_Type : Entity_Id; + Iface_Prim : Entity_Id; + Prim : Entity_Id) return Boolean + is + Iface : constant Entity_Id := Find_Dispatching_Type (Iface_Prim); + Typ : constant Entity_Id := Find_Dispatching_Type (Prim); + + begin + pragma Assert (Is_Subprogram (Iface_Prim) + and then Is_Subprogram (Prim) + and then Is_Dispatching_Operation (Iface_Prim) + and then Is_Dispatching_Operation (Prim)); + + pragma Assert (Is_Interface (Iface) + or else (Present (Alias (Iface_Prim)) + and then + Is_Interface + (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim))))); + + if Prim = Iface_Prim + or else not Is_Subprogram (Prim) + or else Ekind (Prim) /= Ekind (Iface_Prim) + or else not Is_Dispatching_Operation (Prim) + or else Scope (Prim) /= Scope (Tagged_Type) + or else No (Typ) + or else Base_Type (Typ) /= Tagged_Type + or else not Primitive_Names_Match (Iface_Prim, Prim) + then + return False; + + -- Case of a procedure, or a function that does not have a controlling + -- result (I or access I). + + elsif Ekind (Iface_Prim) = E_Procedure + or else Etype (Prim) = Etype (Iface_Prim) + or else not Has_Controlling_Result (Prim) + then + return Type_Conformant + (Iface_Prim, Prim, Skip_Controlling_Formals => True); + + -- Case of a function returning an interface, or an access to one. + -- Check that the return types correspond. + + elsif Implements_Interface (Typ, Iface) then + if (Ekind (Etype (Prim)) = E_Anonymous_Access_Type) + /= + (Ekind (Etype (Iface_Prim)) = E_Anonymous_Access_Type) + then + return False; + else + return + Type_Conformant (Prim, Iface_Prim, + Skip_Controlling_Formals => True); + end if; + + else + return False; + end if; + end Is_Interface_Conformant; + + --------------------------------- + -- Is_Non_Overriding_Operation -- + --------------------------------- + + function Is_Non_Overriding_Operation + (Prev_E : Entity_Id; + New_E : Entity_Id) return Boolean + is + Formal : Entity_Id; + F_Typ : Entity_Id; + G_Typ : Entity_Id := Empty; + + function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id; + -- If F_Type is a derived type associated with a generic actual subtype, + -- then return its Generic_Parent_Type attribute, else return Empty. + + function Types_Correspond + (P_Type : Entity_Id; + N_Type : Entity_Id) return Boolean; + -- Returns true if and only if the types (or designated types in the + -- case of anonymous access types) are the same or N_Type is derived + -- directly or indirectly from P_Type. + + ----------------------------- + -- Get_Generic_Parent_Type -- + ----------------------------- + + function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id is + G_Typ : Entity_Id; + Indic : Node_Id; + + begin + if Is_Derived_Type (F_Typ) + and then Nkind (Parent (F_Typ)) = N_Full_Type_Declaration + then + -- The tree must be traversed to determine the parent subtype in + -- the generic unit, which unfortunately isn't always available + -- via semantic attributes. ??? (Note: The use of Original_Node + -- is needed for cases where a full derived type has been + -- rewritten.) + + Indic := Subtype_Indication + (Type_Definition (Original_Node (Parent (F_Typ)))); + + if Nkind (Indic) = N_Subtype_Indication then + G_Typ := Entity (Subtype_Mark (Indic)); + else + G_Typ := Entity (Indic); + end if; + + if Nkind (Parent (G_Typ)) = N_Subtype_Declaration + and then Present (Generic_Parent_Type (Parent (G_Typ))) + then + return Generic_Parent_Type (Parent (G_Typ)); + end if; + end if; + + return Empty; + end Get_Generic_Parent_Type; + + ---------------------- + -- Types_Correspond -- + ---------------------- + + function Types_Correspond + (P_Type : Entity_Id; + N_Type : Entity_Id) return Boolean + is + Prev_Type : Entity_Id := Base_Type (P_Type); + New_Type : Entity_Id := Base_Type (N_Type); + + begin + if Ekind (Prev_Type) = E_Anonymous_Access_Type then + Prev_Type := Designated_Type (Prev_Type); + end if; + + if Ekind (New_Type) = E_Anonymous_Access_Type then + New_Type := Designated_Type (New_Type); + end if; + + if Prev_Type = New_Type then + return True; + + elsif not Is_Class_Wide_Type (New_Type) then + while Etype (New_Type) /= New_Type loop + New_Type := Etype (New_Type); + if New_Type = Prev_Type then + return True; + end if; + end loop; + end if; + return False; + end Types_Correspond; + + -- Start of processing for Is_Non_Overriding_Operation + + begin + -- In the case where both operations are implicit derived subprograms + -- then neither overrides the other. This can only occur in certain + -- obscure cases (e.g., derivation from homographs created in a generic + -- instantiation). + + if Present (Alias (Prev_E)) and then Present (Alias (New_E)) then + return True; + + elsif Ekind (Current_Scope) = E_Package + and then Is_Generic_Instance (Current_Scope) + and then In_Private_Part (Current_Scope) + and then Comes_From_Source (New_E) + then + -- We examine the formals and result subtype of the inherited + -- operation, to determine whether their type is derived from (the + -- instance of) a generic type. + + Formal := First_Formal (Prev_E); + while Present (Formal) loop + F_Typ := Base_Type (Etype (Formal)); + + if Ekind (F_Typ) = E_Anonymous_Access_Type then + F_Typ := Designated_Type (F_Typ); + end if; + + G_Typ := Get_Generic_Parent_Type (F_Typ); + + Next_Formal (Formal); + end loop; + + if No (G_Typ) and then Ekind (Prev_E) = E_Function then + G_Typ := Get_Generic_Parent_Type (Base_Type (Etype (Prev_E))); + end if; + + if No (G_Typ) then + return False; + end if; + + -- If the generic type is a private type, then the original operation + -- was not overriding in the generic, because there was no primitive + -- operation to override. + + if Nkind (Parent (G_Typ)) = N_Formal_Type_Declaration + and then Nkind (Formal_Type_Definition (Parent (G_Typ))) = + N_Formal_Private_Type_Definition + then + return True; + + -- The generic parent type is the ancestor of a formal derived + -- type declaration. We need to check whether it has a primitive + -- operation that should be overridden by New_E in the generic. + + else + declare + P_Formal : Entity_Id; + N_Formal : Entity_Id; + P_Typ : Entity_Id; + N_Typ : Entity_Id; + P_Prim : Entity_Id; + Prim_Elt : Elmt_Id := First_Elmt (Primitive_Operations (G_Typ)); + + begin + while Present (Prim_Elt) loop + P_Prim := Node (Prim_Elt); + + if Chars (P_Prim) = Chars (New_E) + and then Ekind (P_Prim) = Ekind (New_E) + then + P_Formal := First_Formal (P_Prim); + N_Formal := First_Formal (New_E); + while Present (P_Formal) and then Present (N_Formal) loop + P_Typ := Etype (P_Formal); + N_Typ := Etype (N_Formal); + + if not Types_Correspond (P_Typ, N_Typ) then + exit; + end if; + + Next_Entity (P_Formal); + Next_Entity (N_Formal); + end loop; + + -- Found a matching primitive operation belonging to the + -- formal ancestor type, so the new subprogram is + -- overriding. + + if No (P_Formal) + and then No (N_Formal) + and then (Ekind (New_E) /= E_Function + or else + Types_Correspond + (Etype (P_Prim), Etype (New_E))) + then + return False; + end if; + end if; + + Next_Elmt (Prim_Elt); + end loop; + + -- If no match found, then the new subprogram does not + -- override in the generic (nor in the instance). + + return True; + end; + end if; + else + return False; + end if; + end Is_Non_Overriding_Operation; + + ------------------------------------- + -- List_Inherited_Pre_Post_Aspects -- + ------------------------------------- + + procedure List_Inherited_Pre_Post_Aspects (E : Entity_Id) is + begin + if Opt.List_Inherited_Aspects + and then (Is_Subprogram (E) or else Is_Generic_Subprogram (E)) + then + declare + Inherited : constant Subprogram_List := + Inherited_Subprograms (E); + P : Node_Id; + + begin + for J in Inherited'Range loop + P := Spec_PPC_List (Inherited (J)); + while Present (P) loop + Error_Msg_Sloc := Sloc (P); + + if Class_Present (P) and then not Split_PPC (P) then + if Pragma_Name (P) = Name_Precondition then + Error_Msg_N + ("?info: & inherits `Pre''Class` aspect from #", E); + else + Error_Msg_N + ("?info: & inherits `Post''Class` aspect from #", E); + end if; + end if; + + P := Next_Pragma (P); + end loop; + end loop; + end; + end if; + end List_Inherited_Pre_Post_Aspects; + + ------------------------------ + -- Make_Inequality_Operator -- + ------------------------------ + + -- S is the defining identifier of an equality operator. We build a + -- subprogram declaration with the right signature. This operation is + -- intrinsic, because it is always expanded as the negation of the + -- call to the equality function. + + procedure Make_Inequality_Operator (S : Entity_Id) is + Loc : constant Source_Ptr := Sloc (S); + Decl : Node_Id; + Formals : List_Id; + Op_Name : Entity_Id; + + FF : constant Entity_Id := First_Formal (S); + NF : constant Entity_Id := Next_Formal (FF); + + begin + -- Check that equality was properly defined, ignore call if not + + if No (NF) then + return; + end if; + + declare + A : constant Entity_Id := + Make_Defining_Identifier (Sloc (FF), + Chars => Chars (FF)); + + B : constant Entity_Id := + Make_Defining_Identifier (Sloc (NF), + Chars => Chars (NF)); + + begin + Op_Name := Make_Defining_Operator_Symbol (Loc, Name_Op_Ne); + + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => A, + Parameter_Type => + New_Reference_To (Etype (First_Formal (S)), + Sloc (Etype (First_Formal (S))))), + + Make_Parameter_Specification (Loc, + Defining_Identifier => B, + Parameter_Type => + New_Reference_To (Etype (Next_Formal (First_Formal (S))), + Sloc (Etype (Next_Formal (First_Formal (S))))))); + + Decl := + Make_Subprogram_Declaration (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Op_Name, + Parameter_Specifications => Formals, + Result_Definition => + New_Reference_To (Standard_Boolean, Loc))); + + -- Insert inequality right after equality if it is explicit or after + -- the derived type when implicit. These entities are created only + -- for visibility purposes, and eventually replaced in the course of + -- expansion, so they do not need to be attached to the tree and seen + -- by the back-end. Keeping them internal also avoids spurious + -- freezing problems. The declaration is inserted in the tree for + -- analysis, and removed afterwards. If the equality operator comes + -- from an explicit declaration, attach the inequality immediately + -- after. Else the equality is inherited from a derived type + -- declaration, so insert inequality after that declaration. + + if No (Alias (S)) then + Insert_After (Unit_Declaration_Node (S), Decl); + elsif Is_List_Member (Parent (S)) then + Insert_After (Parent (S), Decl); + else + Insert_After (Parent (Etype (First_Formal (S))), Decl); + end if; + + Mark_Rewrite_Insertion (Decl); + Set_Is_Intrinsic_Subprogram (Op_Name); + Analyze (Decl); + Remove (Decl); + Set_Has_Completion (Op_Name); + Set_Corresponding_Equality (Op_Name, S); + Set_Is_Abstract_Subprogram (Op_Name, Is_Abstract_Subprogram (S)); + end; + end Make_Inequality_Operator; + + ---------------------- + -- May_Need_Actuals -- + ---------------------- + + procedure May_Need_Actuals (Fun : Entity_Id) is + F : Entity_Id; + B : Boolean; + + begin + F := First_Formal (Fun); + B := True; + while Present (F) loop + if No (Default_Value (F)) then + B := False; + exit; + end if; + + Next_Formal (F); + end loop; + + Set_Needs_No_Actuals (Fun, B); + end May_Need_Actuals; + + --------------------- + -- Mode_Conformant -- + --------------------- + + function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is + Result : Boolean; + begin + Check_Conformance (New_Id, Old_Id, Mode_Conformant, False, Result); + return Result; + end Mode_Conformant; + + --------------------------- + -- New_Overloaded_Entity -- + --------------------------- + + procedure New_Overloaded_Entity + (S : Entity_Id; + Derived_Type : Entity_Id := Empty) + is + Overridden_Subp : Entity_Id := Empty; + -- Set if the current scope has an operation that is type-conformant + -- with S, and becomes hidden by S. + + Is_Primitive_Subp : Boolean; + -- Set to True if the new subprogram is primitive + + E : Entity_Id; + -- Entity that S overrides + + Prev_Vis : Entity_Id := Empty; + -- Predecessor of E in Homonym chain + + procedure Check_For_Primitive_Subprogram + (Is_Primitive : out Boolean; + Is_Overriding : Boolean := False); + -- If the subprogram being analyzed is a primitive operation of the type + -- of a formal or result, set the Has_Primitive_Operations flag on the + -- type, and set Is_Primitive to True (otherwise set to False). Set the + -- corresponding flag on the entity itself for later use. + + procedure Check_Synchronized_Overriding + (Def_Id : Entity_Id; + Overridden_Subp : out Entity_Id); + -- First determine if Def_Id is an entry or a subprogram either defined + -- in the scope of a task or protected type, or is a primitive of such + -- a type. Check whether Def_Id overrides a subprogram of an interface + -- implemented by the synchronized type, return the overridden entity + -- or Empty. + + function Is_Private_Declaration (E : Entity_Id) return Boolean; + -- Check that E is declared in the private part of the current package, + -- or in the package body, where it may hide a previous declaration. + -- We can't use In_Private_Part by itself because this flag is also + -- set when freezing entities, so we must examine the place of the + -- declaration in the tree, and recognize wrapper packages as well. + + function Is_Overriding_Alias + (Old_E : Entity_Id; + New_E : Entity_Id) return Boolean; + -- Check whether new subprogram and old subprogram are both inherited + -- from subprograms that have distinct dispatch table entries. This can + -- occur with derivations from instances with accidental homonyms. + -- The function is conservative given that the converse is only true + -- within instances that contain accidental overloadings. + + ------------------------------------ + -- Check_For_Primitive_Subprogram -- + ------------------------------------ + + procedure Check_For_Primitive_Subprogram + (Is_Primitive : out Boolean; + Is_Overriding : Boolean := False) + is + Formal : Entity_Id; + F_Typ : Entity_Id; + B_Typ : Entity_Id; + + function Visible_Part_Type (T : Entity_Id) return Boolean; + -- Returns true if T is declared in the visible part of the current + -- package scope; otherwise returns false. Assumes that T is declared + -- in a package. + + procedure Check_Private_Overriding (T : Entity_Id); + -- Checks that if a primitive abstract subprogram of a visible + -- abstract type is declared in a private part, then it must override + -- an abstract subprogram declared in the visible part. Also checks + -- that if a primitive function with a controlling result is declared + -- in a private part, then it must override a function declared in + -- the visible part. + + ------------------------------ + -- Check_Private_Overriding -- + ------------------------------ + + procedure Check_Private_Overriding (T : Entity_Id) is + begin + if Is_Package_Or_Generic_Package (Current_Scope) + and then In_Private_Part (Current_Scope) + and then Visible_Part_Type (T) + and then not In_Instance + then + if Is_Abstract_Type (T) + and then Is_Abstract_Subprogram (S) + and then (not Is_Overriding + or else not Is_Abstract_Subprogram (E)) + then + Error_Msg_N + ("abstract subprograms must be visible " + & "(RM 3.9.3(10))!", S); + + elsif Ekind (S) = E_Function + and then not Is_Overriding + then + if Is_Tagged_Type (T) + and then T = Base_Type (Etype (S)) + then + Error_Msg_N + ("private function with tagged result must" + & " override visible-part function", S); + Error_Msg_N + ("\move subprogram to the visible part" + & " (RM 3.9.3(10))", S); + + -- AI05-0073: extend this test to the case of a function + -- with a controlling access result. + + elsif Ekind (Etype (S)) = E_Anonymous_Access_Type + and then Is_Tagged_Type (Designated_Type (Etype (S))) + and then + not Is_Class_Wide_Type (Designated_Type (Etype (S))) + and then Ada_Version >= Ada_2012 + then + Error_Msg_N + ("private function with controlling access result " + & "must override visible-part function", S); + Error_Msg_N + ("\move subprogram to the visible part" + & " (RM 3.9.3(10))", S); + end if; + end if; + end if; + end Check_Private_Overriding; + + ----------------------- + -- Visible_Part_Type -- + ----------------------- + + function Visible_Part_Type (T : Entity_Id) return Boolean is + P : constant Node_Id := Unit_Declaration_Node (Scope (T)); + N : Node_Id; + + begin + -- If the entity is a private type, then it must be declared in a + -- visible part. + + if Ekind (T) in Private_Kind then + return True; + end if; + + -- Otherwise, we traverse the visible part looking for its + -- corresponding declaration. We cannot use the declaration + -- node directly because in the private part the entity of a + -- private type is the one in the full view, which does not + -- indicate that it is the completion of something visible. + + N := First (Visible_Declarations (Specification (P))); + while Present (N) loop + if Nkind (N) = N_Full_Type_Declaration + and then Present (Defining_Identifier (N)) + and then T = Defining_Identifier (N) + then + return True; + + elsif Nkind_In (N, N_Private_Type_Declaration, + N_Private_Extension_Declaration) + and then Present (Defining_Identifier (N)) + and then T = Full_View (Defining_Identifier (N)) + then + return True; + end if; + + Next (N); + end loop; + + return False; + end Visible_Part_Type; + + -- Start of processing for Check_For_Primitive_Subprogram + + begin + Is_Primitive := False; + + if not Comes_From_Source (S) then + null; + + -- If subprogram is at library level, it is not primitive operation + + elsif Current_Scope = Standard_Standard then + null; + + elsif (Is_Package_Or_Generic_Package (Current_Scope) + and then not In_Package_Body (Current_Scope)) + or else Is_Overriding + then + -- For function, check return type + + if Ekind (S) = E_Function then + if Ekind (Etype (S)) = E_Anonymous_Access_Type then + F_Typ := Designated_Type (Etype (S)); + else + F_Typ := Etype (S); + end if; + + B_Typ := Base_Type (F_Typ); + + if Scope (B_Typ) = Current_Scope + and then not Is_Class_Wide_Type (B_Typ) + and then not Is_Generic_Type (B_Typ) + then + Is_Primitive := True; + Set_Has_Primitive_Operations (B_Typ); + Set_Is_Primitive (S); + Check_Private_Overriding (B_Typ); + end if; + end if; + + -- For all subprograms, check formals + + Formal := First_Formal (S); + while Present (Formal) loop + if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then + F_Typ := Designated_Type (Etype (Formal)); + else + F_Typ := Etype (Formal); + end if; + + B_Typ := Base_Type (F_Typ); + + if Ekind (B_Typ) = E_Access_Subtype then + B_Typ := Base_Type (B_Typ); + end if; + + if Scope (B_Typ) = Current_Scope + and then not Is_Class_Wide_Type (B_Typ) + and then not Is_Generic_Type (B_Typ) + then + Is_Primitive := True; + Set_Is_Primitive (S); + Set_Has_Primitive_Operations (B_Typ); + Check_Private_Overriding (B_Typ); + end if; + + Next_Formal (Formal); + end loop; + end if; + end Check_For_Primitive_Subprogram; + + ----------------------------------- + -- Check_Synchronized_Overriding -- + ----------------------------------- + + procedure Check_Synchronized_Overriding + (Def_Id : Entity_Id; + Overridden_Subp : out Entity_Id) + is + Ifaces_List : Elist_Id; + In_Scope : Boolean; + Typ : Entity_Id; + + function Matches_Prefixed_View_Profile + (Prim_Params : List_Id; + Iface_Params : List_Id) return Boolean; + -- Determine whether a subprogram's parameter profile Prim_Params + -- matches that of a potentially overridden interface subprogram + -- Iface_Params. Also determine if the type of first parameter of + -- Iface_Params is an implemented interface. + + ----------------------------------- + -- Matches_Prefixed_View_Profile -- + ----------------------------------- + + function Matches_Prefixed_View_Profile + (Prim_Params : List_Id; + Iface_Params : List_Id) return Boolean + is + Iface_Id : Entity_Id; + Iface_Param : Node_Id; + Iface_Typ : Entity_Id; + Prim_Id : Entity_Id; + Prim_Param : Node_Id; + Prim_Typ : Entity_Id; + + function Is_Implemented + (Ifaces_List : Elist_Id; + Iface : Entity_Id) return Boolean; + -- Determine if Iface is implemented by the current task or + -- protected type. + + -------------------- + -- Is_Implemented -- + -------------------- + + function Is_Implemented + (Ifaces_List : Elist_Id; + Iface : Entity_Id) return Boolean + is + Iface_Elmt : Elmt_Id; + + begin + Iface_Elmt := First_Elmt (Ifaces_List); + while Present (Iface_Elmt) loop + if Node (Iface_Elmt) = Iface then + return True; + end if; + + Next_Elmt (Iface_Elmt); + end loop; + + return False; + end Is_Implemented; + + -- Start of processing for Matches_Prefixed_View_Profile + + begin + Iface_Param := First (Iface_Params); + Iface_Typ := Etype (Defining_Identifier (Iface_Param)); + + if Is_Access_Type (Iface_Typ) then + Iface_Typ := Designated_Type (Iface_Typ); + end if; + + Prim_Param := First (Prim_Params); + + -- The first parameter of the potentially overridden subprogram + -- must be an interface implemented by Prim. + + if not Is_Interface (Iface_Typ) + or else not Is_Implemented (Ifaces_List, Iface_Typ) + then + return False; + end if; + + -- The checks on the object parameters are done, move onto the + -- rest of the parameters. + + if not In_Scope then + Prim_Param := Next (Prim_Param); + end if; + + Iface_Param := Next (Iface_Param); + while Present (Iface_Param) and then Present (Prim_Param) loop + Iface_Id := Defining_Identifier (Iface_Param); + Iface_Typ := Find_Parameter_Type (Iface_Param); + + Prim_Id := Defining_Identifier (Prim_Param); + Prim_Typ := Find_Parameter_Type (Prim_Param); + + if Ekind (Iface_Typ) = E_Anonymous_Access_Type + and then Ekind (Prim_Typ) = E_Anonymous_Access_Type + and then Is_Concurrent_Type (Designated_Type (Prim_Typ)) + then + Iface_Typ := Designated_Type (Iface_Typ); + Prim_Typ := Designated_Type (Prim_Typ); + end if; + + -- Case of multiple interface types inside a parameter profile + + -- (Obj_Param : in out Iface; ...; Param : Iface) + + -- If the interface type is implemented, then the matching type + -- in the primitive should be the implementing record type. + + if Ekind (Iface_Typ) = E_Record_Type + and then Is_Interface (Iface_Typ) + and then Is_Implemented (Ifaces_List, Iface_Typ) + then + if Prim_Typ /= Typ then + return False; + end if; + + -- The two parameters must be both mode and subtype conformant + + elsif Ekind (Iface_Id) /= Ekind (Prim_Id) + or else not + Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant) + then + return False; + end if; + + Next (Iface_Param); + Next (Prim_Param); + end loop; + + -- One of the two lists contains more parameters than the other + + if Present (Iface_Param) or else Present (Prim_Param) then + return False; + end if; + + return True; + end Matches_Prefixed_View_Profile; + + -- Start of processing for Check_Synchronized_Overriding + + begin + Overridden_Subp := Empty; + + -- Def_Id must be an entry or a subprogram. We should skip predefined + -- primitives internally generated by the frontend; however at this + -- stage predefined primitives are still not fully decorated. As a + -- minor optimization we skip here internally generated subprograms. + + if (Ekind (Def_Id) /= E_Entry + and then Ekind (Def_Id) /= E_Function + and then Ekind (Def_Id) /= E_Procedure) + or else not Comes_From_Source (Def_Id) + then + return; + end if; + + -- Search for the concurrent declaration since it contains the list + -- of all implemented interfaces. In this case, the subprogram is + -- declared within the scope of a protected or a task type. + + if Present (Scope (Def_Id)) + and then Is_Concurrent_Type (Scope (Def_Id)) + and then not Is_Generic_Actual_Type (Scope (Def_Id)) + then + Typ := Scope (Def_Id); + In_Scope := True; + + -- The enclosing scope is not a synchronized type and the subprogram + -- has no formals. + + elsif No (First_Formal (Def_Id)) then + return; + + -- The subprogram has formals and hence it may be a primitive of a + -- concurrent type. + + else + Typ := Etype (First_Formal (Def_Id)); + + if Is_Access_Type (Typ) then + Typ := Directly_Designated_Type (Typ); + end if; + + if Is_Concurrent_Type (Typ) + and then not Is_Generic_Actual_Type (Typ) + then + In_Scope := False; + + -- This case occurs when the concurrent type is declared within + -- a generic unit. As a result the corresponding record has been + -- built and used as the type of the first formal, we just have + -- to retrieve the corresponding concurrent type. + + elsif Is_Concurrent_Record_Type (Typ) + and then Present (Corresponding_Concurrent_Type (Typ)) + then + Typ := Corresponding_Concurrent_Type (Typ); + In_Scope := False; + + else + return; + end if; + end if; + + -- There is no overriding to check if is an inherited operation in a + -- type derivation on for a generic actual. + + Collect_Interfaces (Typ, Ifaces_List); + + if Is_Empty_Elmt_List (Ifaces_List) then + return; + end if; + + -- Determine whether entry or subprogram Def_Id overrides a primitive + -- operation that belongs to one of the interfaces in Ifaces_List. + + declare + Candidate : Entity_Id := Empty; + Hom : Entity_Id := Empty; + Iface_Typ : Entity_Id; + Subp : Entity_Id := Empty; + + begin + -- Traverse the homonym chain, looking for a potentially + -- overridden subprogram that belongs to an implemented + -- interface. + + Hom := Current_Entity_In_Scope (Def_Id); + while Present (Hom) loop + Subp := Hom; + + if Subp = Def_Id + or else not Is_Overloadable (Subp) + or else not Is_Primitive (Subp) + or else not Is_Dispatching_Operation (Subp) + or else not Present (Find_Dispatching_Type (Subp)) + or else not Is_Interface (Find_Dispatching_Type (Subp)) + then + null; + + -- Entries and procedures can override abstract or null + -- interface procedures. + + elsif (Ekind (Def_Id) = E_Procedure + or else Ekind (Def_Id) = E_Entry) + and then Ekind (Subp) = E_Procedure + and then Matches_Prefixed_View_Profile + (Parameter_Specifications (Parent (Def_Id)), + Parameter_Specifications (Parent (Subp))) + then + Candidate := Subp; + + -- For an overridden subprogram Subp, check whether the mode + -- of its first parameter is correct depending on the kind + -- of synchronized type. + + declare + Formal : constant Node_Id := First_Formal (Candidate); + + begin + -- In order for an entry or a protected procedure to + -- override, the first parameter of the overridden + -- routine must be of mode "out", "in out" or + -- access-to-variable. + + if (Ekind (Candidate) = E_Entry + or else Ekind (Candidate) = E_Procedure) + and then Is_Protected_Type (Typ) + and then Ekind (Formal) /= E_In_Out_Parameter + and then Ekind (Formal) /= E_Out_Parameter + and then Nkind (Parameter_Type (Parent (Formal))) + /= N_Access_Definition + then + null; + + -- All other cases are OK since a task entry or routine + -- does not have a restriction on the mode of the first + -- parameter of the overridden interface routine. + + else + Overridden_Subp := Candidate; + return; + end if; + end; + + -- Functions can override abstract interface functions + + elsif Ekind (Def_Id) = E_Function + and then Ekind (Subp) = E_Function + and then Matches_Prefixed_View_Profile + (Parameter_Specifications (Parent (Def_Id)), + Parameter_Specifications (Parent (Subp))) + and then Etype (Result_Definition (Parent (Def_Id))) = + Etype (Result_Definition (Parent (Subp))) + then + Overridden_Subp := Subp; + return; + end if; + + Hom := Homonym (Hom); + end loop; + + -- After examining all candidates for overriding, we are left with + -- the best match which is a mode incompatible interface routine. + -- Do not emit an error if the Expander is active since this error + -- will be detected later on after all concurrent types are + -- expanded and all wrappers are built. This check is meant for + -- spec-only compilations. + + if Present (Candidate) and then not Expander_Active then + Iface_Typ := + Find_Parameter_Type (Parent (First_Formal (Candidate))); + + -- Def_Id is primitive of a protected type, declared inside the + -- type, and the candidate is primitive of a limited or + -- synchronized interface. + + if In_Scope + and then Is_Protected_Type (Typ) + and then + (Is_Limited_Interface (Iface_Typ) + or else Is_Protected_Interface (Iface_Typ) + or else Is_Synchronized_Interface (Iface_Typ) + or else Is_Task_Interface (Iface_Typ)) + then + Error_Msg_NE + ("first formal of & must be of mode `OUT`, `IN OUT`" + & " or access-to-variable", Typ, Candidate); + Error_Msg_N + ("\in order to be overridden by protected procedure or " + & "entry (RM 9.4(11.9/2))", Typ); + end if; + end if; + + Overridden_Subp := Candidate; + return; + end; + end Check_Synchronized_Overriding; + + ---------------------------- + -- Is_Private_Declaration -- + ---------------------------- + + function Is_Private_Declaration (E : Entity_Id) return Boolean is + Priv_Decls : List_Id; + Decl : constant Node_Id := Unit_Declaration_Node (E); + + begin + if Is_Package_Or_Generic_Package (Current_Scope) + and then In_Private_Part (Current_Scope) + then + Priv_Decls := + Private_Declarations ( + Specification (Unit_Declaration_Node (Current_Scope))); + + return In_Package_Body (Current_Scope) + or else + (Is_List_Member (Decl) + and then List_Containing (Decl) = Priv_Decls) + or else (Nkind (Parent (Decl)) = N_Package_Specification + and then not + Is_Compilation_Unit + (Defining_Entity (Parent (Decl))) + and then List_Containing (Parent (Parent (Decl))) + = Priv_Decls); + else + return False; + end if; + end Is_Private_Declaration; + + -------------------------- + -- Is_Overriding_Alias -- + -------------------------- + + function Is_Overriding_Alias + (Old_E : Entity_Id; + New_E : Entity_Id) return Boolean + is + AO : constant Entity_Id := Alias (Old_E); + AN : constant Entity_Id := Alias (New_E); + + begin + return Scope (AO) /= Scope (AN) + or else No (DTC_Entity (AO)) + or else No (DTC_Entity (AN)) + or else DT_Position (AO) = DT_Position (AN); + end Is_Overriding_Alias; + + -- Start of processing for New_Overloaded_Entity + + begin + -- We need to look for an entity that S may override. This must be a + -- homonym in the current scope, so we look for the first homonym of + -- S in the current scope as the starting point for the search. + + E := Current_Entity_In_Scope (S); + + -- Ada 2005 (AI-251): Derivation of abstract interface primitives. + -- They are directly added to the list of primitive operations of + -- Derived_Type, unless this is a rederivation in the private part + -- of an operation that was already derived in the visible part of + -- the current package. + + if Ada_Version >= Ada_2005 + and then Present (Derived_Type) + and then Present (Alias (S)) + and then Is_Dispatching_Operation (Alias (S)) + and then Present (Find_Dispatching_Type (Alias (S))) + and then Is_Interface (Find_Dispatching_Type (Alias (S))) + then + -- For private types, when the full-view is processed we propagate to + -- the full view the non-overridden entities whose attribute "alias" + -- references an interface primitive. These entities were added by + -- Derive_Subprograms to ensure that interface primitives are + -- covered. + + -- Inside_Freeze_Actions is non zero when S corresponds with an + -- internal entity that links an interface primitive with its + -- covering primitive through attribute Interface_Alias (see + -- Add_Internal_Interface_Entities). + + if Inside_Freezing_Actions = 0 + and then Is_Package_Or_Generic_Package (Current_Scope) + and then In_Private_Part (Current_Scope) + and then Nkind (Parent (E)) = N_Private_Extension_Declaration + and then Nkind (Parent (S)) = N_Full_Type_Declaration + and then Full_View (Defining_Identifier (Parent (E))) + = Defining_Identifier (Parent (S)) + and then Alias (E) = Alias (S) + then + Check_Operation_From_Private_View (S, E); + Set_Is_Dispatching_Operation (S); + + -- Common case + + else + Enter_Overloaded_Entity (S); + Check_Dispatching_Operation (S, Empty); + Check_For_Primitive_Subprogram (Is_Primitive_Subp); + end if; + + return; + end if; + + -- If there is no homonym then this is definitely not overriding + + if No (E) then + Enter_Overloaded_Entity (S); + Check_Dispatching_Operation (S, Empty); + Check_For_Primitive_Subprogram (Is_Primitive_Subp); + + -- If subprogram has an explicit declaration, check whether it + -- has an overriding indicator. + + if Comes_From_Source (S) then + Check_Synchronized_Overriding (S, Overridden_Subp); + + -- (Ada 2012: AI05-0125-1): If S is a dispatching operation then + -- it may have overridden some hidden inherited primitive. Update + -- Overridden_Subp to avoid spurious errors when checking the + -- overriding indicator. + + if Ada_Version >= Ada_2012 + and then No (Overridden_Subp) + and then Is_Dispatching_Operation (S) + and then Present (Overridden_Operation (S)) + then + Overridden_Subp := Overridden_Operation (S); + end if; + + Check_Overriding_Indicator + (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp); + end if; + + -- If there is a homonym that is not overloadable, then we have an + -- error, except for the special cases checked explicitly below. + + elsif not Is_Overloadable (E) then + + -- Check for spurious conflict produced by a subprogram that has the + -- same name as that of the enclosing generic package. The conflict + -- occurs within an instance, between the subprogram and the renaming + -- declaration for the package. After the subprogram, the package + -- renaming declaration becomes hidden. + + if Ekind (E) = E_Package + and then Present (Renamed_Object (E)) + and then Renamed_Object (E) = Current_Scope + and then Nkind (Parent (Renamed_Object (E))) = + N_Package_Specification + and then Present (Generic_Parent (Parent (Renamed_Object (E)))) + then + Set_Is_Hidden (E); + Set_Is_Immediately_Visible (E, False); + Enter_Overloaded_Entity (S); + Set_Homonym (S, Homonym (E)); + Check_Dispatching_Operation (S, Empty); + Check_Overriding_Indicator (S, Empty, Is_Primitive => False); + + -- If the subprogram is implicit it is hidden by the previous + -- declaration. However if it is dispatching, it must appear in the + -- dispatch table anyway, because it can be dispatched to even if it + -- cannot be called directly. + + elsif Present (Alias (S)) and then not Comes_From_Source (S) then + Set_Scope (S, Current_Scope); + + if Is_Dispatching_Operation (Alias (S)) then + Check_Dispatching_Operation (S, Empty); + end if; + + return; + + else + Error_Msg_Sloc := Sloc (E); + + -- Generate message, with useful additional warning if in generic + + if Is_Generic_Unit (E) then + Error_Msg_N ("previous generic unit cannot be overloaded", S); + Error_Msg_N ("\& conflicts with declaration#", S); + else + Error_Msg_N ("& conflicts with declaration#", S); + end if; + + return; + end if; + + -- E exists and is overloadable + + else + Check_Synchronized_Overriding (S, Overridden_Subp); + + -- Loop through E and its homonyms to determine if any of them is + -- the candidate for overriding by S. + + while Present (E) loop + + -- Definitely not interesting if not in the current scope + + if Scope (E) /= Current_Scope then + null; + + -- Check if we have type conformance + + elsif Type_Conformant (E, S) then + + -- If the old and new entities have the same profile and one + -- is not the body of the other, then this is an error, unless + -- one of them is implicitly declared. + + -- There are some cases when both can be implicit, for example + -- when both a literal and a function that overrides it are + -- inherited in a derivation, or when an inherited operation + -- of a tagged full type overrides the inherited operation of + -- a private extension. Ada 83 had a special rule for the + -- literal case. In Ada95, the later implicit operation hides + -- the former, and the literal is always the former. In the + -- odd case where both are derived operations declared at the + -- same point, both operations should be declared, and in that + -- case we bypass the following test and proceed to the next + -- part. This can only occur for certain obscure cases in + -- instances, when an operation on a type derived from a formal + -- private type does not override a homograph inherited from + -- the actual. In subsequent derivations of such a type, the + -- DT positions of these operations remain distinct, if they + -- have been set. + + if Present (Alias (S)) + and then (No (Alias (E)) + or else Comes_From_Source (E) + or else Is_Abstract_Subprogram (S) + or else + (Is_Dispatching_Operation (E) + and then Is_Overriding_Alias (E, S))) + and then Ekind (E) /= E_Enumeration_Literal + then + -- When an derived operation is overloaded it may be due to + -- the fact that the full view of a private extension + -- re-inherits. It has to be dealt with. + + if Is_Package_Or_Generic_Package (Current_Scope) + and then In_Private_Part (Current_Scope) + then + Check_Operation_From_Private_View (S, E); + end if; + + -- In any case the implicit operation remains hidden by the + -- existing declaration, which is overriding. Indicate that + -- E overrides the operation from which S is inherited. + + if Present (Alias (S)) then + Set_Overridden_Operation (E, Alias (S)); + else + Set_Overridden_Operation (E, S); + end if; + + if Comes_From_Source (E) then + Check_Overriding_Indicator (E, S, Is_Primitive => False); + end if; + + return; + + -- Within an instance, the renaming declarations for actual + -- subprograms may become ambiguous, but they do not hide each + -- other. + + elsif Ekind (E) /= E_Entry + and then not Comes_From_Source (E) + and then not Is_Generic_Instance (E) + and then (Present (Alias (E)) + or else Is_Intrinsic_Subprogram (E)) + and then (not In_Instance + or else No (Parent (E)) + or else Nkind (Unit_Declaration_Node (E)) /= + N_Subprogram_Renaming_Declaration) + then + -- A subprogram child unit is not allowed to override an + -- inherited subprogram (10.1.1(20)). + + if Is_Child_Unit (S) then + Error_Msg_N + ("child unit overrides inherited subprogram in parent", + S); + return; + end if; + + if Is_Non_Overriding_Operation (E, S) then + Enter_Overloaded_Entity (S); + + if No (Derived_Type) + or else Is_Tagged_Type (Derived_Type) + then + Check_Dispatching_Operation (S, Empty); + end if; + + return; + end if; + + -- E is a derived operation or an internal operator which + -- is being overridden. Remove E from further visibility. + -- Furthermore, if E is a dispatching operation, it must be + -- replaced in the list of primitive operations of its type + -- (see Override_Dispatching_Operation). + + Overridden_Subp := E; + + declare + Prev : Entity_Id; + + begin + Prev := First_Entity (Current_Scope); + while Present (Prev) + and then Next_Entity (Prev) /= E + loop + Next_Entity (Prev); + end loop; + + -- It is possible for E to be in the current scope and + -- yet not in the entity chain. This can only occur in a + -- generic context where E is an implicit concatenation + -- in the formal part, because in a generic body the + -- entity chain starts with the formals. + + pragma Assert + (Present (Prev) or else Chars (E) = Name_Op_Concat); + + -- E must be removed both from the entity_list of the + -- current scope, and from the visibility chain + + if Debug_Flag_E then + Write_Str ("Override implicit operation "); + Write_Int (Int (E)); + Write_Eol; + end if; + + -- If E is a predefined concatenation, it stands for four + -- different operations. As a result, a single explicit + -- declaration does not hide it. In a possible ambiguous + -- situation, Disambiguate chooses the user-defined op, + -- so it is correct to retain the previous internal one. + + if Chars (E) /= Name_Op_Concat + or else Ekind (E) /= E_Operator + then + -- For nondispatching derived operations that are + -- overridden by a subprogram declared in the private + -- part of a package, we retain the derived subprogram + -- but mark it as not immediately visible. If the + -- derived operation was declared in the visible part + -- then this ensures that it will still be visible + -- outside the package with the proper signature + -- (calls from outside must also be directed to this + -- version rather than the overriding one, unlike the + -- dispatching case). Calls from inside the package + -- will still resolve to the overriding subprogram + -- since the derived one is marked as not visible + -- within the package. + + -- If the private operation is dispatching, we achieve + -- the overriding by keeping the implicit operation + -- but setting its alias to be the overriding one. In + -- this fashion the proper body is executed in all + -- cases, but the original signature is used outside + -- of the package. + + -- If the overriding is not in the private part, we + -- remove the implicit operation altogether. + + if Is_Private_Declaration (S) then + if not Is_Dispatching_Operation (E) then + Set_Is_Immediately_Visible (E, False); + else + -- Work done in Override_Dispatching_Operation, + -- so nothing else need to be done here. + + null; + end if; + + else + -- Find predecessor of E in Homonym chain + + if E = Current_Entity (E) then + Prev_Vis := Empty; + else + Prev_Vis := Current_Entity (E); + while Homonym (Prev_Vis) /= E loop + Prev_Vis := Homonym (Prev_Vis); + end loop; + end if; + + if Prev_Vis /= Empty then + + -- Skip E in the visibility chain + + Set_Homonym (Prev_Vis, Homonym (E)); + + else + Set_Name_Entity_Id (Chars (E), Homonym (E)); + end if; + + Set_Next_Entity (Prev, Next_Entity (E)); + + if No (Next_Entity (Prev)) then + Set_Last_Entity (Current_Scope, Prev); + end if; + end if; + end if; + + Enter_Overloaded_Entity (S); + + -- For entities generated by Derive_Subprograms the + -- overridden operation is the inherited primitive + -- (which is available through the attribute alias). + + if not (Comes_From_Source (E)) + and then Is_Dispatching_Operation (E) + and then Find_Dispatching_Type (E) = + Find_Dispatching_Type (S) + and then Present (Alias (E)) + and then Comes_From_Source (Alias (E)) + then + Set_Overridden_Operation (S, Alias (E)); + else + Set_Overridden_Operation (S, E); + end if; + + Check_Overriding_Indicator (S, E, Is_Primitive => True); + + -- If S is a user-defined subprogram or a null procedure + -- expanded to override an inherited null procedure, or a + -- predefined dispatching primitive then indicate that E + -- overrides the operation from which S is inherited. + + if Comes_From_Source (S) + or else + (Present (Parent (S)) + and then + Nkind (Parent (S)) = N_Procedure_Specification + and then + Null_Present (Parent (S))) + or else + (Present (Alias (E)) + and then + Is_Predefined_Dispatching_Operation (Alias (E))) + then + if Present (Alias (E)) then + Set_Overridden_Operation (S, Alias (E)); + end if; + end if; + + if Is_Dispatching_Operation (E) then + + -- An overriding dispatching subprogram inherits the + -- convention of the overridden subprogram (AI-117). + + Set_Convention (S, Convention (E)); + Check_Dispatching_Operation (S, E); + + else + Check_Dispatching_Operation (S, Empty); + end if; + + Check_For_Primitive_Subprogram + (Is_Primitive_Subp, Is_Overriding => True); + goto Check_Inequality; + end; + + -- Apparent redeclarations in instances can occur when two + -- formal types get the same actual type. The subprograms in + -- in the instance are legal, even if not callable from the + -- outside. Calls from within are disambiguated elsewhere. + -- For dispatching operations in the visible part, the usual + -- rules apply, and operations with the same profile are not + -- legal (B830001). + + elsif (In_Instance_Visible_Part + and then not Is_Dispatching_Operation (E)) + or else In_Instance_Not_Visible + then + null; + + -- Here we have a real error (identical profile) + + else + Error_Msg_Sloc := Sloc (E); + + -- Avoid cascaded errors if the entity appears in + -- subsequent calls. + + Set_Scope (S, Current_Scope); + + -- Generate error, with extra useful warning for the case + -- of a generic instance with no completion. + + if Is_Generic_Instance (S) + and then not Has_Completion (E) + then + Error_Msg_N + ("instantiation cannot provide body for&", S); + Error_Msg_N ("\& conflicts with declaration#", S); + else + Error_Msg_N ("& conflicts with declaration#", S); + end if; + + return; + end if; + + else + -- If one subprogram has an access parameter and the other + -- a parameter of an access type, calls to either might be + -- ambiguous. Verify that parameters match except for the + -- access parameter. + + if May_Hide_Profile then + declare + F1 : Entity_Id; + F2 : Entity_Id; + + begin + F1 := First_Formal (S); + F2 := First_Formal (E); + while Present (F1) and then Present (F2) loop + if Is_Access_Type (Etype (F1)) then + if not Is_Access_Type (Etype (F2)) + or else not Conforming_Types + (Designated_Type (Etype (F1)), + Designated_Type (Etype (F2)), + Type_Conformant) + then + May_Hide_Profile := False; + end if; + + elsif + not Conforming_Types + (Etype (F1), Etype (F2), Type_Conformant) + then + May_Hide_Profile := False; + end if; + + Next_Formal (F1); + Next_Formal (F2); + end loop; + + if May_Hide_Profile + and then No (F1) + and then No (F2) + then + Error_Msg_NE ("calls to& may be ambiguous?", S, S); + end if; + end; + end if; + end if; + + E := Homonym (E); + end loop; + + -- On exit, we know that S is a new entity + + Enter_Overloaded_Entity (S); + Check_For_Primitive_Subprogram (Is_Primitive_Subp); + Check_Overriding_Indicator + (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp); + + -- If S is a derived operation for an untagged type then by + -- definition it's not a dispatching operation (even if the parent + -- operation was dispatching), so we don't call + -- Check_Dispatching_Operation in that case. + + if No (Derived_Type) + or else Is_Tagged_Type (Derived_Type) + then + Check_Dispatching_Operation (S, Empty); + end if; + end if; + + -- If this is a user-defined equality operator that is not a derived + -- subprogram, create the corresponding inequality. If the operation is + -- dispatching, the expansion is done elsewhere, and we do not create + -- an explicit inequality operation. + + <> + if Chars (S) = Name_Op_Eq + and then Etype (S) = Standard_Boolean + and then Present (Parent (S)) + and then not Is_Dispatching_Operation (S) + then + Make_Inequality_Operator (S); + + if Ada_Version >= Ada_2012 then + Check_Untagged_Equality (S); + end if; + end if; + end New_Overloaded_Entity; + + --------------------- + -- Process_Formals -- + --------------------- + + procedure Process_Formals + (T : List_Id; + Related_Nod : Node_Id) + is + Param_Spec : Node_Id; + Formal : Entity_Id; + Formal_Type : Entity_Id; + Default : Node_Id; + Ptype : Entity_Id; + + Num_Out_Params : Nat := 0; + First_Out_Param : Entity_Id := Empty; + -- Used for setting Is_Only_Out_Parameter + + function Designates_From_With_Type (Typ : Entity_Id) return Boolean; + -- Determine whether an access type designates a type coming from a + -- limited view. + + function Is_Class_Wide_Default (D : Node_Id) return Boolean; + -- Check whether the default has a class-wide type. After analysis the + -- default has the type of the formal, so we must also check explicitly + -- for an access attribute. + + ------------------------------- + -- Designates_From_With_Type -- + ------------------------------- + + function Designates_From_With_Type (Typ : Entity_Id) return Boolean is + Desig : Entity_Id := Typ; + + begin + if Is_Access_Type (Desig) then + Desig := Directly_Designated_Type (Desig); + end if; + + if Is_Class_Wide_Type (Desig) then + Desig := Root_Type (Desig); + end if; + + return + Ekind (Desig) = E_Incomplete_Type + and then From_With_Type (Desig); + end Designates_From_With_Type; + + --------------------------- + -- Is_Class_Wide_Default -- + --------------------------- + + function Is_Class_Wide_Default (D : Node_Id) return Boolean is + begin + return Is_Class_Wide_Type (Designated_Type (Etype (D))) + or else (Nkind (D) = N_Attribute_Reference + and then Attribute_Name (D) = Name_Access + and then Is_Class_Wide_Type (Etype (Prefix (D)))); + end Is_Class_Wide_Default; + + -- Start of processing for Process_Formals + + begin + -- In order to prevent premature use of the formals in the same formal + -- part, the Ekind is left undefined until all default expressions are + -- analyzed. The Ekind is established in a separate loop at the end. + + Param_Spec := First (T); + while Present (Param_Spec) loop + Formal := Defining_Identifier (Param_Spec); + Set_Never_Set_In_Source (Formal, True); + Enter_Name (Formal); + + -- Case of ordinary parameters + + if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then + Find_Type (Parameter_Type (Param_Spec)); + Ptype := Parameter_Type (Param_Spec); + + if Ptype = Error then + goto Continue; + end if; + + Formal_Type := Entity (Ptype); + + if Is_Incomplete_Type (Formal_Type) + or else + (Is_Class_Wide_Type (Formal_Type) + and then Is_Incomplete_Type (Root_Type (Formal_Type))) + then + -- Ada 2005 (AI-326): Tagged incomplete types allowed in + -- primitive operations, as long as their completion is + -- in the same declarative part. If in the private part + -- this means that the type cannot be a Taft-amendment type. + -- Check is done on package exit. For access to subprograms, + -- the use is legal for Taft-amendment types. + + if Is_Tagged_Type (Formal_Type) then + if Ekind (Scope (Current_Scope)) = E_Package + and then In_Private_Part (Scope (Current_Scope)) + and then not From_With_Type (Formal_Type) + and then not Is_Class_Wide_Type (Formal_Type) + then + if not Nkind_In + (Parent (T), N_Access_Function_Definition, + N_Access_Procedure_Definition) + then + Append_Elmt + (Current_Scope, + Private_Dependents (Base_Type (Formal_Type))); + end if; + end if; + + -- Special handling of Value_Type for CIL case + + elsif Is_Value_Type (Formal_Type) then + null; + + elsif not Nkind_In (Parent (T), N_Access_Function_Definition, + N_Access_Procedure_Definition) + then + + -- AI05-0151: Tagged incomplete types are allowed in all + -- formal parts. Untagged incomplete types are not allowed + -- in bodies. + + if Ada_Version >= Ada_2012 then + if Is_Tagged_Type (Formal_Type) then + null; + + elsif Nkind_In (Parent (Parent (T)), N_Accept_Statement, + N_Entry_Body, + N_Subprogram_Body) + then + Error_Msg_NE + ("invalid use of untagged incomplete type&", + Ptype, Formal_Type); + end if; + + else + Error_Msg_NE + ("invalid use of incomplete type&", + Param_Spec, Formal_Type); + + -- Further checks on the legality of incomplete types + -- in formal parts are delayed until the freeze point + -- of the enclosing subprogram or access to subprogram. + end if; + end if; + + elsif Ekind (Formal_Type) = E_Void then + Error_Msg_NE + ("premature use of&", + Parameter_Type (Param_Spec), Formal_Type); + end if; + + -- Ada 2005 (AI-231): Create and decorate an internal subtype + -- declaration corresponding to the null-excluding type of the + -- formal in the enclosing scope. Finally, replace the parameter + -- type of the formal with the internal subtype. + + if Ada_Version >= Ada_2005 + and then Null_Exclusion_Present (Param_Spec) + then + if not Is_Access_Type (Formal_Type) then + Error_Msg_N + ("`NOT NULL` allowed only for an access type", Param_Spec); + + else + if Can_Never_Be_Null (Formal_Type) + and then Comes_From_Source (Related_Nod) + then + Error_Msg_NE + ("`NOT NULL` not allowed (& already excludes null)", + Param_Spec, Formal_Type); + end if; + + Formal_Type := + Create_Null_Excluding_Itype + (T => Formal_Type, + Related_Nod => Related_Nod, + Scope_Id => Scope (Current_Scope)); + + -- If the designated type of the itype is an itype we + -- decorate it with the Has_Delayed_Freeze attribute to + -- avoid problems with the backend. + + -- Example: + -- type T is access procedure; + -- procedure Op (O : not null T); + + if Is_Itype (Directly_Designated_Type (Formal_Type)) then + Set_Has_Delayed_Freeze (Formal_Type); + end if; + end if; + end if; + + -- An access formal type + + else + Formal_Type := + Access_Definition (Related_Nod, Parameter_Type (Param_Spec)); + + -- No need to continue if we already notified errors + + if not Present (Formal_Type) then + return; + end if; + + -- Ada 2005 (AI-254) + + declare + AD : constant Node_Id := + Access_To_Subprogram_Definition + (Parameter_Type (Param_Spec)); + begin + if Present (AD) and then Protected_Present (AD) then + Formal_Type := + Replace_Anonymous_Access_To_Protected_Subprogram + (Param_Spec); + end if; + end; + end if; + + Set_Etype (Formal, Formal_Type); + Default := Expression (Param_Spec); + + if Present (Default) then + if Out_Present (Param_Spec) then + Error_Msg_N + ("default initialization only allowed for IN parameters", + Param_Spec); + end if; + + -- Do the special preanalysis of the expression (see section on + -- "Handling of Default Expressions" in the spec of package Sem). + + Preanalyze_Spec_Expression (Default, Formal_Type); + + -- An access to constant cannot be the default for + -- an access parameter that is an access to variable. + + if Ekind (Formal_Type) = E_Anonymous_Access_Type + and then not Is_Access_Constant (Formal_Type) + and then Is_Access_Type (Etype (Default)) + and then Is_Access_Constant (Etype (Default)) + then + Error_Msg_N + ("formal that is access to variable cannot be initialized " & + "with an access-to-constant expression", Default); + end if; + + -- Check that the designated type of an access parameter's default + -- is not a class-wide type unless the parameter's designated type + -- is also class-wide. + + if Ekind (Formal_Type) = E_Anonymous_Access_Type + and then not Designates_From_With_Type (Formal_Type) + and then Is_Class_Wide_Default (Default) + and then not Is_Class_Wide_Type (Designated_Type (Formal_Type)) + then + Error_Msg_N + ("access to class-wide expression not allowed here", Default); + end if; + + -- Check incorrect use of dynamically tagged expressions + + if Is_Tagged_Type (Formal_Type) then + Check_Dynamically_Tagged_Expression + (Expr => Default, + Typ => Formal_Type, + Related_Nod => Default); + end if; + end if; + + -- Ada 2005 (AI-231): Static checks + + if Ada_Version >= Ada_2005 + and then Is_Access_Type (Etype (Formal)) + and then Can_Never_Be_Null (Etype (Formal)) + then + Null_Exclusion_Static_Checks (Param_Spec); + end if; + + <> + Next (Param_Spec); + end loop; + + -- If this is the formal part of a function specification, analyze the + -- subtype mark in the context where the formals are visible but not + -- yet usable, and may hide outer homographs. + + if Nkind (Related_Nod) = N_Function_Specification then + Analyze_Return_Type (Related_Nod); + end if; + + -- Now set the kind (mode) of each formal + + Param_Spec := First (T); + while Present (Param_Spec) loop + Formal := Defining_Identifier (Param_Spec); + Set_Formal_Mode (Formal); + + if Ekind (Formal) = E_In_Parameter then + Set_Default_Value (Formal, Expression (Param_Spec)); + + if Present (Expression (Param_Spec)) then + Default := Expression (Param_Spec); + + if Is_Scalar_Type (Etype (Default)) then + if Nkind + (Parameter_Type (Param_Spec)) /= N_Access_Definition + then + Formal_Type := Entity (Parameter_Type (Param_Spec)); + + else + Formal_Type := Access_Definition + (Related_Nod, Parameter_Type (Param_Spec)); + end if; + + Apply_Scalar_Range_Check (Default, Formal_Type); + end if; + end if; + + elsif Ekind (Formal) = E_Out_Parameter then + Num_Out_Params := Num_Out_Params + 1; + + if Num_Out_Params = 1 then + First_Out_Param := Formal; + end if; + + elsif Ekind (Formal) = E_In_Out_Parameter then + Num_Out_Params := Num_Out_Params + 1; + end if; + + Next (Param_Spec); + end loop; + + if Present (First_Out_Param) and then Num_Out_Params = 1 then + Set_Is_Only_Out_Parameter (First_Out_Param); + end if; + end Process_Formals; + + ------------------ + -- Process_PPCs -- + ------------------ + + procedure Process_PPCs + (N : Node_Id; + Spec_Id : Entity_Id; + Body_Id : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Prag : Node_Id; + Parms : List_Id; + + Designator : Entity_Id; + -- Subprogram designator, set from Spec_Id if present, else Body_Id + + Precond : Node_Id := Empty; + -- Set non-Empty if we prepend precondition to the declarations. This + -- is used to hook up inherited preconditions (adding the condition + -- expression with OR ELSE, and adding the message). + + Inherited_Precond : Node_Id; + -- Precondition inherited from parent subprogram + + Inherited : constant Subprogram_List := + Inherited_Subprograms (Spec_Id); + -- List of subprograms inherited by this subprogram + + Plist : List_Id := No_List; + -- List of generated postconditions + + function Grab_PPC (Pspec : Entity_Id := Empty) return Node_Id; + -- Prag contains an analyzed precondition or postcondition pragma. This + -- function copies the pragma, changes it to the corresponding Check + -- pragma and returns the Check pragma as the result. If Pspec is non- + -- empty, this is the case of inheriting a PPC, where we must change + -- references to parameters of the inherited subprogram to point to the + -- corresponding parameters of the current subprogram. + + function Invariants_Or_Predicates_Present return Boolean; + -- Determines if any invariants or predicates are present for any OUT + -- or IN OUT parameters of the subprogram, or (for a function) if the + -- return value has an invariant. + + -------------- + -- Grab_PPC -- + -------------- + + function Grab_PPC (Pspec : Entity_Id := Empty) return Node_Id is + Nam : constant Name_Id := Pragma_Name (Prag); + Map : Elist_Id; + CP : Node_Id; + + begin + -- Prepare map if this is the case where we have to map entities of + -- arguments in the overridden subprogram to corresponding entities + -- of the current subprogram. + + if No (Pspec) then + Map := No_Elist; + + else + declare + PF : Entity_Id; + CF : Entity_Id; + + begin + Map := New_Elmt_List; + PF := First_Formal (Pspec); + CF := First_Formal (Designator); + while Present (PF) loop + Append_Elmt (PF, Map); + Append_Elmt (CF, Map); + Next_Formal (PF); + Next_Formal (CF); + end loop; + end; + end if; + + -- Now we can copy the tree, doing any required substitutions + + CP := New_Copy_Tree (Prag, Map => Map, New_Scope => Current_Scope); + + -- Set Analyzed to false, since we want to reanalyze the check + -- procedure. Note that it is only at the outer level that we + -- do this fiddling, for the spec cases, the already preanalyzed + -- parameters are not affected. + + Set_Analyzed (CP, False); + + -- We also make sure Comes_From_Source is False for the copy + + Set_Comes_From_Source (CP, False); + + -- For a postcondition pragma within a generic, preserve the pragma + -- for later expansion. + + if Nam = Name_Postcondition + and then not Expander_Active + then + return CP; + end if; + + -- Change copy of pragma into corresponding pragma Check + + Prepend_To (Pragma_Argument_Associations (CP), + Make_Pragma_Argument_Association (Sloc (Prag), + Expression => Make_Identifier (Loc, Nam))); + Set_Pragma_Identifier (CP, Make_Identifier (Sloc (Prag), Name_Check)); + + -- If this is inherited case and the current message starts with + -- "failed p", we change it to "failed inherited p...". + + if Present (Pspec) then + declare + Msg : constant Node_Id := + Last (Pragma_Argument_Associations (CP)); + + begin + if Chars (Msg) = Name_Message then + String_To_Name_Buffer (Strval (Expression (Msg))); + + if Name_Buffer (1 .. 8) = "failed p" then + Insert_Str_In_Name_Buffer ("inherited ", 8); + Set_Strval + (Expression (Last (Pragma_Argument_Associations (CP))), + String_From_Name_Buffer); + end if; + end if; + end; + end if; + + -- Return the check pragma + + return CP; + end Grab_PPC; + + -------------------------------------- + -- Invariants_Or_Predicates_Present -- + -------------------------------------- + + function Invariants_Or_Predicates_Present return Boolean is + Formal : Entity_Id; + + begin + -- Check function return result + + if Ekind (Designator) /= E_Procedure + and then Has_Invariants (Etype (Designator)) + then + return True; + end if; + + -- Check parameters + + Formal := First_Formal (Designator); + while Present (Formal) loop + if Ekind (Formal) /= E_In_Parameter + and then + (Has_Invariants (Etype (Formal)) + or else Present (Predicate_Function (Etype (Formal)))) + then + return True; + end if; + + Next_Formal (Formal); + end loop; + + return False; + end Invariants_Or_Predicates_Present; + + -- Start of processing for Process_PPCs + + begin + -- Capture designator from spec if present, else from body + + if Present (Spec_Id) then + Designator := Spec_Id; + else + Designator := Body_Id; + end if; + + -- Grab preconditions from spec + + if Present (Spec_Id) then + + -- Loop through PPC pragmas from spec. Note that preconditions from + -- the body will be analyzed and converted when we scan the body + -- declarations below. + + Prag := Spec_PPC_List (Spec_Id); + while Present (Prag) loop + if Pragma_Name (Prag) = Name_Precondition then + + -- For Pre (or Precondition pragma), we simply prepend the + -- pragma to the list of declarations right away so that it + -- will be executed at the start of the procedure. Note that + -- this processing reverses the order of the list, which is + -- what we want since new entries were chained to the head of + -- the list. There can be more then one precondition when we + -- use pragma Precondition + + if not Class_Present (Prag) then + Prepend (Grab_PPC, Declarations (N)); + + -- For Pre'Class there can only be one pragma, and we save + -- it in Precond for now. We will add inherited Pre'Class + -- stuff before inserting this pragma in the declarations. + else + Precond := Grab_PPC; + end if; + end if; + + Prag := Next_Pragma (Prag); + end loop; + + -- Now deal with inherited preconditions + + for J in Inherited'Range loop + Prag := Spec_PPC_List (Inherited (J)); + + while Present (Prag) loop + if Pragma_Name (Prag) = Name_Precondition + and then Class_Present (Prag) + then + Inherited_Precond := Grab_PPC (Inherited (J)); + + -- No precondition so far, so establish this as the first + + if No (Precond) then + Precond := Inherited_Precond; + + -- Here we already have a precondition, add inherited one + + else + -- Add new precondition to old one using OR ELSE + + declare + New_Expr : constant Node_Id := + Get_Pragma_Arg + (Next + (First + (Pragma_Argument_Associations + (Inherited_Precond)))); + Old_Expr : constant Node_Id := + Get_Pragma_Arg + (Next + (First + (Pragma_Argument_Associations + (Precond)))); + + begin + if Paren_Count (Old_Expr) = 0 then + Set_Paren_Count (Old_Expr, 1); + end if; + + if Paren_Count (New_Expr) = 0 then + Set_Paren_Count (New_Expr, 1); + end if; + + Rewrite (Old_Expr, + Make_Or_Else (Sloc (Old_Expr), + Left_Opnd => Relocate_Node (Old_Expr), + Right_Opnd => New_Expr)); + end; + + -- Add new message in the form: + + -- failed precondition from bla + -- also failed inherited precondition from bla + -- ... + + -- Skip this if exception locations are suppressed + + if not Exception_Locations_Suppressed then + declare + New_Msg : constant Node_Id := + Get_Pragma_Arg + (Last + (Pragma_Argument_Associations + (Inherited_Precond))); + Old_Msg : constant Node_Id := + Get_Pragma_Arg + (Last + (Pragma_Argument_Associations + (Precond))); + begin + Start_String (Strval (Old_Msg)); + Store_String_Chars (ASCII.LF & " also "); + Store_String_Chars (Strval (New_Msg)); + Set_Strval (Old_Msg, End_String); + end; + end if; + end if; + end if; + + Prag := Next_Pragma (Prag); + end loop; + end loop; + + -- If we have built a precondition for Pre'Class (including any + -- Pre'Class aspects inherited from parent subprograms), then we + -- insert this composite precondition at this stage. + + if Present (Precond) then + Prepend (Precond, Declarations (N)); + end if; + end if; + + -- Build postconditions procedure if needed and prepend the following + -- declaration to the start of the declarations for the subprogram. + + -- procedure _postconditions [(_Result : resulttype)] is + -- begin + -- pragma Check (Postcondition, condition [,message]); + -- pragma Check (Postcondition, condition [,message]); + -- ... + -- Invariant_Procedure (_Result) ... + -- Invariant_Procedure (Arg1) + -- ... + -- end; + + -- First we deal with the postconditions in the body + + if Is_Non_Empty_List (Declarations (N)) then + + -- Loop through declarations + + Prag := First (Declarations (N)); + while Present (Prag) loop + if Nkind (Prag) = N_Pragma then + + -- If pragma, capture if enabled postcondition, else ignore + + if Pragma_Name (Prag) = Name_Postcondition + and then Check_Enabled (Name_Postcondition) + then + if Plist = No_List then + Plist := Empty_List; + end if; + + Analyze (Prag); + + -- If expansion is disabled, as in a generic unit, save + -- pragma for later expansion. + + if not Expander_Active then + Prepend (Grab_PPC, Declarations (N)); + else + Append (Grab_PPC, Plist); + end if; + end if; + + Next (Prag); + + -- Not a pragma, if comes from source, then end scan + + elsif Comes_From_Source (Prag) then + exit; + + -- Skip stuff not coming from source + + else + Next (Prag); + end if; + end loop; + end if; + + -- Now deal with any postconditions from the spec + + if Present (Spec_Id) then + Spec_Postconditions : declare + procedure Process_Post_Conditions + (Spec : Node_Id; + Class : Boolean); + -- This processes the Spec_PPC_List from Spec, processing any + -- postconditions from the list. If Class is True, then only + -- postconditions marked with Class_Present are considered. + -- The caller has checked that Spec_PPC_List is non-Empty. + + ----------------------------- + -- Process_Post_Conditions -- + ----------------------------- + + procedure Process_Post_Conditions + (Spec : Node_Id; + Class : Boolean) + is + Pspec : Node_Id; + + begin + if Class then + Pspec := Spec; + else + Pspec := Empty; + end if; + + -- Loop through PPC pragmas from spec + + Prag := Spec_PPC_List (Spec); + loop + if Pragma_Name (Prag) = Name_Postcondition + and then (not Class or else Class_Present (Prag)) + then + if Plist = No_List then + Plist := Empty_List; + end if; + + if not Expander_Active then + Prepend + (Grab_PPC (Pspec), Declarations (N)); + else + Append (Grab_PPC (Pspec), Plist); + end if; + end if; + + Prag := Next_Pragma (Prag); + exit when No (Prag); + end loop; + end Process_Post_Conditions; + + -- Start of processing for Spec_Postconditions + + begin + if Present (Spec_PPC_List (Spec_Id)) then + Process_Post_Conditions (Spec_Id, Class => False); + end if; + + -- Process inherited postconditions + + for J in Inherited'Range loop + if Present (Spec_PPC_List (Inherited (J))) then + Process_Post_Conditions (Inherited (J), Class => True); + end if; + end loop; + end Spec_Postconditions; + end if; + + -- If we had any postconditions and expansion is enabled, or if the + -- procedure has invariants, then build the _Postconditions procedure. + + if (Present (Plist) or else Invariants_Or_Predicates_Present) + and then Expander_Active + then + if No (Plist) then + Plist := Empty_List; + end if; + + -- Special processing for function case + + if Ekind (Designator) /= E_Procedure then + declare + Rent : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_uResult); + Ftyp : constant Entity_Id := Etype (Designator); + + begin + Set_Etype (Rent, Ftyp); + + -- Add argument for return + + Parms := + New_List ( + Make_Parameter_Specification (Loc, + Parameter_Type => New_Occurrence_Of (Ftyp, Loc), + Defining_Identifier => Rent)); + + -- Add invariant call if returning type with invariants + + if Has_Invariants (Etype (Rent)) + and then Present (Invariant_Procedure (Etype (Rent))) + then + Append_To (Plist, + Make_Invariant_Call (New_Occurrence_Of (Rent, Loc))); + end if; + end; + + -- Procedure rather than a function + + else + Parms := No_List; + end if; + + -- Add invariant calls and predicate calls for parameters. Note that + -- this is done for functions as well, since in Ada 2012 they can + -- have IN OUT args. + + declare + Formal : Entity_Id; + Ftype : Entity_Id; + + begin + Formal := First_Formal (Designator); + while Present (Formal) loop + if Ekind (Formal) /= E_In_Parameter then + Ftype := Etype (Formal); + + if Has_Invariants (Ftype) + and then Present (Invariant_Procedure (Ftype)) + then + Append_To (Plist, + Make_Invariant_Call + (New_Occurrence_Of (Formal, Loc))); + end if; + + if Present (Predicate_Function (Ftype)) then + Append_To (Plist, + Make_Predicate_Check + (Ftype, New_Occurrence_Of (Formal, Loc))); + end if; + end if; + + Next_Formal (Formal); + end loop; + end; + + -- Build and insert postcondition procedure + + declare + Post_Proc : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_uPostconditions); + -- The entity for the _Postconditions procedure + + begin + Prepend_To (Declarations (N), + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Post_Proc, + Parameter_Specifications => Parms), + + Declarations => Empty_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Plist))); + + -- If this is a procedure, set the Postcondition_Proc attribute on + -- the proper defining entity for the subprogram. + + if Ekind (Designator) = E_Procedure then + Set_Postcondition_Proc (Designator, Post_Proc); + end if; + end; + + Set_Has_Postconditions (Designator); + end if; + end Process_PPCs; + + ---------------------------- + -- Reference_Body_Formals -- + ---------------------------- + + procedure Reference_Body_Formals (Spec : Entity_Id; Bod : Entity_Id) is + Fs : Entity_Id; + Fb : Entity_Id; + + begin + if Error_Posted (Spec) then + return; + end if; + + -- Iterate over both lists. They may be of different lengths if the two + -- specs are not conformant. + + Fs := First_Formal (Spec); + Fb := First_Formal (Bod); + while Present (Fs) and then Present (Fb) loop + Generate_Reference (Fs, Fb, 'b'); + + if Style_Check then + Style.Check_Identifier (Fb, Fs); + end if; + + Set_Spec_Entity (Fb, Fs); + Set_Referenced (Fs, False); + Next_Formal (Fs); + Next_Formal (Fb); + end loop; + end Reference_Body_Formals; + + ------------------------- + -- Set_Actual_Subtypes -- + ------------------------- + + procedure Set_Actual_Subtypes (N : Node_Id; Subp : Entity_Id) is + Decl : Node_Id; + Formal : Entity_Id; + T : Entity_Id; + First_Stmt : Node_Id := Empty; + AS_Needed : Boolean; + + begin + -- If this is an empty initialization procedure, no need to create + -- actual subtypes (small optimization). + + if Ekind (Subp) = E_Procedure + and then Is_Null_Init_Proc (Subp) + then + return; + end if; + + Formal := First_Formal (Subp); + while Present (Formal) loop + T := Etype (Formal); + + -- We never need an actual subtype for a constrained formal + + if Is_Constrained (T) then + AS_Needed := False; + + -- If we have unknown discriminants, then we do not need an actual + -- subtype, or more accurately we cannot figure it out! Note that + -- all class-wide types have unknown discriminants. + + elsif Has_Unknown_Discriminants (T) then + AS_Needed := False; + + -- At this stage we have an unconstrained type that may need an + -- actual subtype. For sure the actual subtype is needed if we have + -- an unconstrained array type. + + elsif Is_Array_Type (T) then + AS_Needed := True; + + -- The only other case needing an actual subtype is an unconstrained + -- record type which is an IN parameter (we cannot generate actual + -- subtypes for the OUT or IN OUT case, since an assignment can + -- change the discriminant values. However we exclude the case of + -- initialization procedures, since discriminants are handled very + -- specially in this context, see the section entitled "Handling of + -- Discriminants" in Einfo. + + -- We also exclude the case of Discrim_SO_Functions (functions used + -- in front end layout mode for size/offset values), since in such + -- functions only discriminants are referenced, and not only are such + -- subtypes not needed, but they cannot always be generated, because + -- of order of elaboration issues. + + elsif Is_Record_Type (T) + and then Ekind (Formal) = E_In_Parameter + and then Chars (Formal) /= Name_uInit + and then not Is_Unchecked_Union (T) + and then not Is_Discrim_SO_Function (Subp) + then + AS_Needed := True; + + -- All other cases do not need an actual subtype + + else + AS_Needed := False; + end if; + + -- Generate actual subtypes for unconstrained arrays and + -- unconstrained discriminated records. + + if AS_Needed then + if Nkind (N) = N_Accept_Statement then + + -- If expansion is active, The formal is replaced by a local + -- variable that renames the corresponding entry of the + -- parameter block, and it is this local variable that may + -- require an actual subtype. + + if Expander_Active then + Decl := Build_Actual_Subtype (T, Renamed_Object (Formal)); + else + Decl := Build_Actual_Subtype (T, Formal); + end if; + + if Present (Handled_Statement_Sequence (N)) then + First_Stmt := + First (Statements (Handled_Statement_Sequence (N))); + Prepend (Decl, Statements (Handled_Statement_Sequence (N))); + Mark_Rewrite_Insertion (Decl); + else + -- If the accept statement has no body, there will be no + -- reference to the actuals, so no need to compute actual + -- subtypes. + + return; + end if; + + else + Decl := Build_Actual_Subtype (T, Formal); + Prepend (Decl, Declarations (N)); + Mark_Rewrite_Insertion (Decl); + end if; + + -- The declaration uses the bounds of an existing object, and + -- therefore needs no constraint checks. + + Analyze (Decl, Suppress => All_Checks); + + -- We need to freeze manually the generated type when it is + -- inserted anywhere else than in a declarative part. + + if Present (First_Stmt) then + Insert_List_Before_And_Analyze (First_Stmt, + Freeze_Entity (Defining_Identifier (Decl), N)); + end if; + + if Nkind (N) = N_Accept_Statement + and then Expander_Active + then + Set_Actual_Subtype (Renamed_Object (Formal), + Defining_Identifier (Decl)); + else + Set_Actual_Subtype (Formal, Defining_Identifier (Decl)); + end if; + end if; + + Next_Formal (Formal); + end loop; + end Set_Actual_Subtypes; + + --------------------- + -- Set_Formal_Mode -- + --------------------- + + procedure Set_Formal_Mode (Formal_Id : Entity_Id) is + Spec : constant Node_Id := Parent (Formal_Id); + + begin + -- Note: we set Is_Known_Valid for IN parameters and IN OUT parameters + -- since we ensure that corresponding actuals are always valid at the + -- point of the call. + + if Out_Present (Spec) then + if Ekind (Scope (Formal_Id)) = E_Function + or else Ekind (Scope (Formal_Id)) = E_Generic_Function + then + -- [IN] OUT parameters allowed for functions in Ada 2012 + + if Ada_Version >= Ada_2012 then + if In_Present (Spec) then + Set_Ekind (Formal_Id, E_In_Out_Parameter); + else + Set_Ekind (Formal_Id, E_Out_Parameter); + end if; + + -- But not in earlier versions of Ada + + else + Error_Msg_N ("functions can only have IN parameters", Spec); + Set_Ekind (Formal_Id, E_In_Parameter); + end if; + + elsif In_Present (Spec) then + Set_Ekind (Formal_Id, E_In_Out_Parameter); + + else + Set_Ekind (Formal_Id, E_Out_Parameter); + Set_Never_Set_In_Source (Formal_Id, True); + Set_Is_True_Constant (Formal_Id, False); + Set_Current_Value (Formal_Id, Empty); + end if; + + else + Set_Ekind (Formal_Id, E_In_Parameter); + end if; + + -- Set Is_Known_Non_Null for access parameters since the language + -- guarantees that access parameters are always non-null. We also set + -- Can_Never_Be_Null, since there is no way to change the value. + + if Nkind (Parameter_Type (Spec)) = N_Access_Definition then + + -- Ada 2005 (AI-231): In Ada95, access parameters are always non- + -- null; In Ada 2005, only if then null_exclusion is explicit. + + if Ada_Version < Ada_2005 + or else Can_Never_Be_Null (Etype (Formal_Id)) + then + Set_Is_Known_Non_Null (Formal_Id); + Set_Can_Never_Be_Null (Formal_Id); + end if; + + -- Ada 2005 (AI-231): Null-exclusion access subtype + + elsif Is_Access_Type (Etype (Formal_Id)) + and then Can_Never_Be_Null (Etype (Formal_Id)) + then + Set_Is_Known_Non_Null (Formal_Id); + end if; + + Set_Mechanism (Formal_Id, Default_Mechanism); + Set_Formal_Validity (Formal_Id); + end Set_Formal_Mode; + + ------------------------- + -- Set_Formal_Validity -- + ------------------------- + + procedure Set_Formal_Validity (Formal_Id : Entity_Id) is + begin + -- If no validity checking, then we cannot assume anything about the + -- validity of parameters, since we do not know there is any checking + -- of the validity on the call side. + + if not Validity_Checks_On then + return; + + -- If validity checking for parameters is enabled, this means we are + -- not supposed to make any assumptions about argument values. + + elsif Validity_Check_Parameters then + return; + + -- If we are checking in parameters, we will assume that the caller is + -- also checking parameters, so we can assume the parameter is valid. + + elsif Ekind (Formal_Id) = E_In_Parameter + and then Validity_Check_In_Params + then + Set_Is_Known_Valid (Formal_Id, True); + + -- Similar treatment for IN OUT parameters + + elsif Ekind (Formal_Id) = E_In_Out_Parameter + and then Validity_Check_In_Out_Params + then + Set_Is_Known_Valid (Formal_Id, True); + end if; + end Set_Formal_Validity; + + ------------------------ + -- Subtype_Conformant -- + ------------------------ + + function Subtype_Conformant + (New_Id : Entity_Id; + Old_Id : Entity_Id; + Skip_Controlling_Formals : Boolean := False) return Boolean + is + Result : Boolean; + begin + Check_Conformance (New_Id, Old_Id, Subtype_Conformant, False, Result, + Skip_Controlling_Formals => Skip_Controlling_Formals); + return Result; + end Subtype_Conformant; + + --------------------- + -- Type_Conformant -- + --------------------- + + function Type_Conformant + (New_Id : Entity_Id; + Old_Id : Entity_Id; + Skip_Controlling_Formals : Boolean := False) return Boolean + is + Result : Boolean; + begin + May_Hide_Profile := False; + + Check_Conformance + (New_Id, Old_Id, Type_Conformant, False, Result, + Skip_Controlling_Formals => Skip_Controlling_Formals); + return Result; + end Type_Conformant; + + ------------------------------- + -- Valid_Operator_Definition -- + ------------------------------- + + procedure Valid_Operator_Definition (Designator : Entity_Id) is + N : Integer := 0; + F : Entity_Id; + Id : constant Name_Id := Chars (Designator); + N_OK : Boolean; + + begin + F := First_Formal (Designator); + while Present (F) loop + N := N + 1; + + if Present (Default_Value (F)) then + Error_Msg_N + ("default values not allowed for operator parameters", + Parent (F)); + end if; + + Next_Formal (F); + end loop; + + -- Verify that user-defined operators have proper number of arguments + -- First case of operators which can only be unary + + if Id = Name_Op_Not + or else Id = Name_Op_Abs + then + N_OK := (N = 1); + + -- Case of operators which can be unary or binary + + elsif Id = Name_Op_Add + or Id = Name_Op_Subtract + then + N_OK := (N in 1 .. 2); + + -- All other operators can only be binary + + else + N_OK := (N = 2); + end if; + + if not N_OK then + Error_Msg_N + ("incorrect number of arguments for operator", Designator); + end if; + + if Id = Name_Op_Ne + and then Base_Type (Etype (Designator)) = Standard_Boolean + and then not Is_Intrinsic_Subprogram (Designator) + then + Error_Msg_N + ("explicit definition of inequality not allowed", Designator); + end if; + end Valid_Operator_Definition; + +end Sem_Ch6; diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads new file mode 100644 index 000000000..39dc1147a --- /dev/null +++ b/gcc/ada/sem_ch6.ads @@ -0,0 +1,260 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 6 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Types; use Types; +package Sem_Ch6 is + + type Conformance_Type is + (Type_Conformant, Mode_Conformant, Subtype_Conformant, Fully_Conformant); + pragma Ordered (Conformance_Type); + -- Conformance type used in conformance checks between specs and bodies, + -- and for overriding. The literals match the RM definitions of the + -- corresponding terms. This is an ordered type, since each conformance + -- type is stronger than the ones preceding it. + + procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id); + procedure Analyze_Extended_Return_Statement (N : Node_Id); + procedure Analyze_Function_Call (N : Node_Id); + procedure Analyze_Operator_Symbol (N : Node_Id); + procedure Analyze_Parameter_Association (N : Node_Id); + procedure Analyze_Parameterized_Expression (N : Node_Id); + procedure Analyze_Procedure_Call (N : Node_Id); + procedure Analyze_Simple_Return_Statement (N : Node_Id); + procedure Analyze_Subprogram_Declaration (N : Node_Id); + procedure Analyze_Subprogram_Body (N : Node_Id); + + function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id; + -- Analyze subprogram specification in both subprogram declarations + -- and body declarations. Returns the defining entity for the + -- specification N. + + procedure Cannot_Inline (Msg : String; N : Node_Id; Subp : Entity_Id); + -- This procedure is called if the node N, an instance of a call to + -- subprogram Subp, cannot be inlined. Msg is the message to be issued, + -- and has a ? as the last character. If Subp has a pragma Always_Inlined, + -- then an error message is issued (by removing the last character of Msg). + -- If Subp is not Always_Inlined, then a warning is issued if the flag + -- Ineffective_Inline_Warnings is set, and if not, the call has no effect. + + procedure Check_Conventions (Typ : Entity_Id); + -- Ada 2005 (AI-430): Check that the conventions of all inherited and + -- overridden dispatching operations of type Typ are consistent with their + -- respective counterparts. + + procedure Check_Delayed_Subprogram (Designator : Entity_Id); + -- Designator can be a E_Subprogram_Type, E_Procedure or E_Function. If a + -- type in its profile depends on a private type without a full + -- declaration, indicate that the subprogram or type is delayed. + + procedure Check_Discriminant_Conformance + (N : Node_Id; + Prev : Entity_Id; + Prev_Loc : Node_Id); + -- Check that the discriminants of a full type N fully conform to the + -- discriminants of the corresponding partial view Prev. Prev_Loc indicates + -- the source location of the partial view, which may be different than + -- Prev in the case of private types. + + procedure Check_Fully_Conformant + (New_Id : Entity_Id; + Old_Id : Entity_Id; + Err_Loc : Node_Id := Empty); + -- Check that two callable entities (subprograms, entries, literals) + -- are fully conformant, post error message if not (RM 6.3.1(17)) with + -- the flag being placed on the Err_Loc node if it is specified, and + -- on the appropriate component of the New_Id construct if not. Note: + -- when checking spec/body conformance, New_Id must be the body entity + -- and Old_Id is the spec entity (the code in the implementation relies + -- on this ordering, and in any case, this makes sense, since if flags + -- are to be placed on the construct, they clearly belong on the body. + + procedure Check_Mode_Conformant + (New_Id : Entity_Id; + Old_Id : Entity_Id; + Err_Loc : Node_Id := Empty; + Get_Inst : Boolean := False); + -- Check that two callable entities (subprograms, entries, literals) + -- are mode conformant, post error message if not (RM 6.3.1(15)) with + -- the flag being placed on the Err_Loc node if it is specified, and + -- on the appropriate component of the New_Id construct if not. The + -- argument Get_Inst is set to True when this is a check against a + -- formal access-to-subprogram type, indicating that mapping of types + -- is needed. + + procedure Check_Overriding_Indicator + (Subp : Entity_Id; + Overridden_Subp : Entity_Id; + Is_Primitive : Boolean); + -- Verify the consistency of an overriding_indicator given for subprogram + -- declaration, body, renaming, or instantiation. Overridden_Subp is set + -- if the scope where we are introducing the subprogram contains a + -- type-conformant subprogram that becomes hidden by the new subprogram. + -- Is_Primitive indicates whether the subprogram is primitive. + + procedure Check_Subtype_Conformant + (New_Id : Entity_Id; + Old_Id : Entity_Id; + Err_Loc : Node_Id := Empty; + Skip_Controlling_Formals : Boolean := False); + -- Check that two callable entities (subprograms, entries, literals) + -- are subtype conformant, post error message if not (RM 6.3.1(16)), + -- the flag being placed on the Err_Loc node if it is specified, and + -- on the appropriate component of the New_Id construct if not. + -- Skip_Controlling_Formals is True when checking the conformance of + -- a subprogram that implements an interface operation. In that case, + -- only the non-controlling formals can (and must) be examined. + + procedure Check_Type_Conformant + (New_Id : Entity_Id; + Old_Id : Entity_Id; + Err_Loc : Node_Id := Empty); + -- Check that two callable entities (subprograms, entries, literals) + -- are type conformant, post error message if not (RM 6.3.1(14)) with + -- the flag being placed on the Err_Loc node if it is specified, and + -- on the appropriate component of the New_Id construct if not. + + function Conforming_Types + (T1 : Entity_Id; + T2 : Entity_Id; + Ctype : Conformance_Type; + Get_Inst : Boolean := False) return Boolean; + -- Check that the types of two formal parameters are conforming. In most + -- cases this is just a name comparison, but within an instance it involves + -- generic actual types, and in the presence of anonymous access types it + -- must examine the designated types. + + procedure Create_Extra_Formals (E : Entity_Id); + -- For each parameter of a subprogram or entry that requires an additional + -- formal (such as for access parameters and indefinite discriminated + -- parameters), creates the appropriate formal and attach it to its + -- associated parameter. Each extra formal will also be appended to + -- the end of Subp's parameter list (with each subsequent extra formal + -- being attached to the preceding extra formal). + + function Find_Corresponding_Spec + (N : Node_Id; + Post_Error : Boolean := True) return Entity_Id; + -- Use the subprogram specification in the body to retrieve the previous + -- subprogram declaration, if any. + + function Fully_Conformant (New_Id, Old_Id : Entity_Id) return Boolean; + -- Determine whether two callable entities (subprograms, entries, + -- literals) are fully conformant (RM 6.3.1(17)) + + function Fully_Conformant_Expressions + (Given_E1 : Node_Id; + Given_E2 : Node_Id) return Boolean; + -- Determines if two (non-empty) expressions are fully conformant + -- as defined by (RM 6.3.1(18-21)) + + function Fully_Conformant_Discrete_Subtypes + (Given_S1 : Node_Id; + Given_S2 : Node_Id) return Boolean; + -- Determines if two subtype definitions are fully conformant. Used + -- for entry family conformance checks (RM 6.3.1 (24)). + + procedure Install_Formals (Id : Entity_Id); + -- On entry to a subprogram body, make the formals visible. Note that + -- simply placing the subprogram on the scope stack is not sufficient: + -- the formals must become the current entities for their names. This + -- procedure is also used to get visibility to the formals when analyzing + -- preconditions and postconditions appearing in the spec. + + function Is_Interface_Conformant + (Tagged_Type : Entity_Id; + Iface_Prim : Entity_Id; + Prim : Entity_Id) return Boolean; + -- Returns true if both primitives have a matching name (including support + -- for names of inherited private primitives --which have suffix 'P'), they + -- are type conformant, and Prim is defined in the scope of Tagged_Type. + -- Special management is done for functions returning interfaces. + + procedure List_Inherited_Pre_Post_Aspects (E : Entity_Id); + -- E is the entity for a subprogram or generic subprogram spec. This call + -- lists all inherited Pre/Post aspects if List_Inherited_Pre_Post is True. + + function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean; + -- Determine whether two callable entities (subprograms, entries, + -- literals) are mode conformant (RM 6.3.1(15)) + + procedure New_Overloaded_Entity + (S : Entity_Id; + Derived_Type : Entity_Id := Empty); + -- Process new overloaded entity. Overloaded entities are created by + -- enumeration type declarations, subprogram specifications, entry + -- declarations, and (implicitly) by type derivations. Derived_Type non- + -- Empty indicates that this is subprogram derived for that type. + + procedure Process_Formals (T : List_Id; Related_Nod : Node_Id); + -- Enter the formals in the scope of the subprogram or entry, and + -- analyze default expressions if any. The implicit types created for + -- access parameter are attached to the Related_Nod which comes from the + -- context. + + procedure Reference_Body_Formals (Spec : Entity_Id; Bod : Entity_Id); + -- If there is a separate spec for a subprogram or generic subprogram, the + -- formals of the body are treated as references to the corresponding + -- formals of the spec. This reference does not count as an actual use of + -- the formal, in order to diagnose formals that are unused in the body. + -- This procedure is also used in renaming_as_body declarations, where + -- the formals of the specification must be treated as body formals that + -- correspond to the previous subprogram declaration, and not as new + -- entities with their defining entry in the cross-reference information. + + procedure Set_Actual_Subtypes (N : Node_Id; Subp : Entity_Id); + -- If the formals of a subprogram are unconstrained, build a subtype + -- declaration that uses the bounds or discriminants of the actual to + -- construct an actual subtype for them. This is an optimization that + -- is done only in some cases where the actual subtype cannot change + -- during execution of the subprogram. By setting the actual subtype + -- once, we avoid recomputing it unnecessarily. + + procedure Set_Formal_Mode (Formal_Id : Entity_Id); + -- Set proper Ekind to reflect formal mode (in, out, in out) + + function Subtype_Conformant + (New_Id : Entity_Id; + Old_Id : Entity_Id; + Skip_Controlling_Formals : Boolean := False) return Boolean; + -- Determine whether two callable entities (subprograms, entries, literals) + -- are subtype conformant (RM6.3.1(16)). Skip_Controlling_Formals is True + -- when checking the conformance of a subprogram that implements an + -- interface operation. In that case, only the non-controlling formals + -- can (and must) be examined. + + function Type_Conformant + (New_Id : Entity_Id; + Old_Id : Entity_Id; + Skip_Controlling_Formals : Boolean := False) return Boolean; + -- Determine whether two callable entities (subprograms, entries, literals) + -- are type conformant (RM6.3.1(14)). Skip_Controlling_Formals is True when + -- checking the conformance of a subprogram that implements an interface + -- operation. In that case, only the non-controlling formals can (and must) + -- be examined. + + procedure Valid_Operator_Definition (Designator : Entity_Id); + -- Verify that an operator definition has the proper number of formals + +end Sem_Ch6; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb new file mode 100644 index 000000000..324f1a973 --- /dev/null +++ b/gcc/ada/sem_ch7.adb @@ -0,0 +1,2583 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M . C H 7 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 to process package specifications and +-- bodies. The most important semantic aspects of package processing are the +-- handling of private and full declarations, and the construction of dispatch +-- tables for tagged types. + +with Aspects; use Aspects; +with Atree; use Atree; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Disp; use Exp_Disp; +with Exp_Dist; use Exp_Dist; +with Exp_Dbug; use Exp_Dbug; +with Lib; use Lib; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; +with Nmake; use Nmake; +with Nlists; use Nlists; +with Opt; use Opt; +with Output; use Output; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Cat; use Sem_Cat; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch10; use Sem_Ch10; +with Sem_Ch12; use Sem_Ch12; +with Sem_Ch13; use Sem_Ch13; +with Sem_Disp; use Sem_Disp; +with Sem_Eval; use Sem_Eval; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Snames; use Snames; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Style; +with Uintp; use Uintp; + +package body Sem_Ch7 is + + ----------------------------------- + -- Handling private declarations -- + ----------------------------------- + + -- The principle that each entity has a single defining occurrence clashes + -- with the presence of two separate definitions for private types: the + -- first is the private type declaration, and the second is the full type + -- declaration. It is important that all references to the type point to + -- the same defining occurrence, namely the first one. To enforce the two + -- separate views of the entity, the corresponding information is swapped + -- between the two declarations. Outside of the package, the defining + -- occurrence only contains the private declaration information, while in + -- the private part and the body of the package the defining occurrence + -- contains the full declaration. To simplify the swap, the defining + -- occurrence that currently holds the private declaration points to the + -- full declaration. During semantic processing the defining occurrence + -- also points to a list of private dependents, that is to say access types + -- or composite types whose designated types or component types are + -- subtypes or derived types of the private type in question. After the + -- full declaration has been seen, the private dependents are updated to + -- indicate that they have full definitions. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Analyze_Package_Body_Helper (N : Node_Id); + -- Does all the real work of Analyze_Package_Body + + procedure Check_Anonymous_Access_Types + (Spec_Id : Entity_Id; + P_Body : Node_Id); + -- If the spec of a package has a limited_with_clause, it may declare + -- anonymous access types whose designated type is a limited view, such an + -- anonymous access return type for a function. This access type cannot be + -- elaborated in the spec itself, but it may need an itype reference if it + -- is used within a nested scope. In that case the itype reference is + -- created at the beginning of the corresponding package body and inserted + -- before other body declarations. + + procedure Install_Package_Entity (Id : Entity_Id); + -- Supporting procedure for Install_{Visible,Private}_Declarations. Places + -- one entity on its visibility chain, and recurses on the visible part if + -- the entity is an inner package. + + function Is_Private_Base_Type (E : Entity_Id) return Boolean; + -- True for a private type that is not a subtype + + function Is_Visible_Dependent (Dep : Entity_Id) return Boolean; + -- If the private dependent is a private type whose full view is derived + -- from the parent type, its full properties are revealed only if we are in + -- the immediate scope of the private dependent. Should this predicate be + -- tightened further??? + + procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id); + -- Called upon entering the private part of a public child package and the + -- body of a nested package, to potentially declare certain inherited + -- subprograms that were inherited by types in the visible part, but whose + -- declaration was deferred because the parent operation was private and + -- not visible at that point. These subprograms are located by traversing + -- the visible part declarations looking for non-private type extensions + -- and then examining each of the primitive operations of such types to + -- find those that were inherited but declared with a special internal + -- name. Each such operation is now declared as an operation with a normal + -- name (using the name of the parent operation) and replaces the previous + -- implicit operation in the primitive operations list of the type. If the + -- inherited private operation has been overridden, then it's replaced by + -- the overriding operation. + + -------------------------- + -- Analyze_Package_Body -- + -------------------------- + + procedure Analyze_Package_Body (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + begin + if Debug_Flag_C then + Write_Str ("==> package body "); + Write_Name (Chars (Defining_Entity (N))); + Write_Str (" from "); + Write_Location (Loc); + Write_Eol; + Indent; + end if; + + -- The real work is split out into the helper, so it can do "return;" + -- without skipping the debug output. + + Analyze_Package_Body_Helper (N); + + if Debug_Flag_C then + Outdent; + Write_Str ("<== package body "); + Write_Name (Chars (Defining_Entity (N))); + Write_Str (" from "); + Write_Location (Loc); + Write_Eol; + end if; + end Analyze_Package_Body; + + --------------------------------- + -- Analyze_Package_Body_Helper -- + --------------------------------- + + procedure Analyze_Package_Body_Helper (N : Node_Id) is + HSS : Node_Id; + Body_Id : Entity_Id; + Spec_Id : Entity_Id; + Last_Spec_Entity : Entity_Id; + New_N : Node_Id; + Pack_Decl : Node_Id; + + procedure Install_Composite_Operations (P : Entity_Id); + -- Composite types declared in the current scope may depend on types + -- that were private at the point of declaration, and whose full view + -- is now in scope. Indicate that the corresponding operations on the + -- composite type are available. + + ---------------------------------- + -- Install_Composite_Operations -- + ---------------------------------- + + procedure Install_Composite_Operations (P : Entity_Id) is + Id : Entity_Id; + + begin + Id := First_Entity (P); + while Present (Id) loop + if Is_Type (Id) + and then (Is_Limited_Composite (Id) + or else Is_Private_Composite (Id)) + and then No (Private_Component (Id)) + then + Set_Is_Limited_Composite (Id, False); + Set_Is_Private_Composite (Id, False); + end if; + + Next_Entity (Id); + end loop; + end Install_Composite_Operations; + + -- Start of processing for Analyze_Package_Body_Helper + + begin + -- Find corresponding package specification, and establish the current + -- scope. The visible defining entity for the package is the defining + -- occurrence in the spec. On exit from the package body, all body + -- declarations are attached to the defining entity for the body, but + -- the later is never used for name resolution. In this fashion there + -- is only one visible entity that denotes the package. + + -- Set Body_Id. Note that this Will be reset to point to the generic + -- copy later on in the generic case. + + Body_Id := Defining_Entity (N); + + if Present (Corresponding_Spec (N)) then + + -- Body is body of package instantiation. Corresponding spec has + -- already been set. + + Spec_Id := Corresponding_Spec (N); + Pack_Decl := Unit_Declaration_Node (Spec_Id); + + else + Spec_Id := Current_Entity_In_Scope (Defining_Entity (N)); + + if Present (Spec_Id) + and then Is_Package_Or_Generic_Package (Spec_Id) + then + Pack_Decl := Unit_Declaration_Node (Spec_Id); + + if Nkind (Pack_Decl) = N_Package_Renaming_Declaration then + Error_Msg_N ("cannot supply body for package renaming", N); + return; + + elsif Present (Corresponding_Body (Pack_Decl)) then + Error_Msg_N ("redefinition of package body", N); + return; + end if; + + else + Error_Msg_N ("missing specification for package body", N); + return; + end if; + + if Is_Package_Or_Generic_Package (Spec_Id) + and then (Scope (Spec_Id) = Standard_Standard + or else Is_Child_Unit (Spec_Id)) + and then not Unit_Requires_Body (Spec_Id) + then + if Ada_Version = Ada_83 then + Error_Msg_N + ("optional package body (not allowed in Ada 95)?", N); + else + Error_Msg_N ("spec of this package does not allow a body", N); + end if; + end if; + end if; + + Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id)); + Style.Check_Identifier (Body_Id, Spec_Id); + + if Is_Child_Unit (Spec_Id) then + if Nkind (Parent (N)) /= N_Compilation_Unit then + Error_Msg_NE + ("body of child unit& cannot be an inner package", N, Spec_Id); + end if; + + Set_Is_Child_Unit (Body_Id); + end if; + + -- Generic package case + + if Ekind (Spec_Id) = E_Generic_Package then + + -- Disable expansion and perform semantic analysis on copy. The + -- unannotated body will be used in all instantiations. + + Body_Id := Defining_Entity (N); + Set_Ekind (Body_Id, E_Package_Body); + Set_Scope (Body_Id, Scope (Spec_Id)); + Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Spec_Id)); + Set_Body_Entity (Spec_Id, Body_Id); + Set_Spec_Entity (Body_Id, Spec_Id); + + New_N := Copy_Generic_Node (N, Empty, Instantiating => False); + Rewrite (N, New_N); + + -- Update Body_Id to point to the copied node for the remainder of + -- the processing. + + Body_Id := Defining_Entity (N); + Start_Generic; + end if; + + -- The Body_Id is that of the copied node in the generic case, the + -- current node otherwise. Note that N was rewritten above, so we must + -- be sure to get the latest Body_Id value. + + Set_Ekind (Body_Id, E_Package_Body); + Set_Body_Entity (Spec_Id, Body_Id); + Set_Spec_Entity (Body_Id, Spec_Id); + + -- Defining name for the package body is not a visible entity: Only the + -- defining name for the declaration is visible. + + Set_Etype (Body_Id, Standard_Void_Type); + Set_Scope (Body_Id, Scope (Spec_Id)); + Set_Corresponding_Spec (N, Spec_Id); + Set_Corresponding_Body (Pack_Decl, Body_Id); + + -- The body entity is not used for semantics or code generation, but + -- it is attached to the entity list of the enclosing scope to simplify + -- the listing of back-annotations for the types it main contain. + + if Scope (Spec_Id) /= Standard_Standard then + Append_Entity (Body_Id, Scope (Spec_Id)); + end if; + + -- Indicate that we are currently compiling the body of the package + + Set_In_Package_Body (Spec_Id); + Set_Has_Completion (Spec_Id); + Last_Spec_Entity := Last_Entity (Spec_Id); + + Push_Scope (Spec_Id); + + Set_Categorization_From_Pragmas (N); + + Install_Visible_Declarations (Spec_Id); + Install_Private_Declarations (Spec_Id); + Install_Private_With_Clauses (Spec_Id); + Install_Composite_Operations (Spec_Id); + + Check_Anonymous_Access_Types (Spec_Id, N); + + if Ekind (Spec_Id) = E_Generic_Package then + Set_Use (Generic_Formal_Declarations (Pack_Decl)); + end if; + + Set_Use (Visible_Declarations (Specification (Pack_Decl))); + Set_Use (Private_Declarations (Specification (Pack_Decl))); + + -- This is a nested package, so it may be necessary to declare certain + -- inherited subprograms that are not yet visible because the parent + -- type's subprograms are now visible. + + if Ekind (Scope (Spec_Id)) = E_Package + and then Scope (Spec_Id) /= Standard_Standard + then + Declare_Inherited_Private_Subprograms (Spec_Id); + end if; + + if Present (Declarations (N)) then + Analyze_Declarations (Declarations (N)); + Inspect_Deferred_Constant_Completion (Declarations (N)); + end if; + + -- Analyze_Declarations has caused freezing of all types. Now generate + -- bodies for RACW primitives and stream attributes, if any. + + if Ekind (Spec_Id) = E_Package and then Has_RACW (Spec_Id) then + + -- Attach subprogram bodies to support RACWs declared in spec + + Append_RACW_Bodies (Declarations (N), Spec_Id); + Analyze_List (Declarations (N)); + end if; + + HSS := Handled_Statement_Sequence (N); + + if Present (HSS) then + Process_End_Label (HSS, 't', Spec_Id); + Analyze (HSS); + + -- Check that elaboration code in a preelaborable package body is + -- empty other than null statements and labels (RM 10.2.1(6)). + + Validate_Null_Statement_Sequence (N); + end if; + + Validate_Categorization_Dependency (N, Spec_Id); + Check_Completion (Body_Id); + + -- Generate start of body reference. Note that we do this fairly late, + -- because the call will use In_Extended_Main_Source_Unit as a check, + -- and we want to make sure that Corresponding_Stub links are set + + Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False); + + -- For a generic package, collect global references and mark them on + -- the original body so that they are not resolved again at the point + -- of instantiation. + + if Ekind (Spec_Id) /= E_Package then + Save_Global_References (Original_Node (N)); + End_Generic; + end if; + + -- The entities of the package body have so far been chained onto the + -- declaration chain for the spec. That's been fine while we were in the + -- body, since we wanted them to be visible, but now that we are leaving + -- the package body, they are no longer visible, so we remove them from + -- the entity chain of the package spec entity, and copy them to the + -- entity chain of the package body entity, where they will never again + -- be visible. + + if Present (Last_Spec_Entity) then + Set_First_Entity (Body_Id, Next_Entity (Last_Spec_Entity)); + Set_Next_Entity (Last_Spec_Entity, Empty); + Set_Last_Entity (Body_Id, Last_Entity (Spec_Id)); + Set_Last_Entity (Spec_Id, Last_Spec_Entity); + + else + Set_First_Entity (Body_Id, First_Entity (Spec_Id)); + Set_Last_Entity (Body_Id, Last_Entity (Spec_Id)); + Set_First_Entity (Spec_Id, Empty); + Set_Last_Entity (Spec_Id, Empty); + end if; + + End_Package_Scope (Spec_Id); + + -- All entities declared in body are not visible + + declare + E : Entity_Id; + + begin + E := First_Entity (Body_Id); + while Present (E) loop + Set_Is_Immediately_Visible (E, False); + Set_Is_Potentially_Use_Visible (E, False); + Set_Is_Hidden (E); + + -- Child units may appear on the entity list (e.g. if they appear + -- in the context of a subunit) but they are not body entities. + + if not Is_Child_Unit (E) then + Set_Is_Package_Body_Entity (E); + end if; + + Next_Entity (E); + end loop; + end; + + Check_References (Body_Id); + + -- For a generic unit, check that the formal parameters are referenced, + -- and that local variables are used, as for regular packages. + + if Ekind (Spec_Id) = E_Generic_Package then + Check_References (Spec_Id); + end if; + + -- The processing so far has made all entities of the package body + -- public (i.e. externally visible to the linker). This is in general + -- necessary, since inlined or generic bodies, for which code is + -- generated in other units, may need to see these entities. The + -- following loop runs backwards from the end of the entities of the + -- package body making these entities invisible until we reach a + -- referencer, i.e. a declaration that could reference a previous + -- declaration, a generic body or an inlined body, or a stub (which may + -- contain either of these). This is of course an approximation, but it + -- is conservative and definitely correct. + + -- We only do this at the outer (library) level non-generic packages. + -- The reason is simply to cut down on the number of global symbols + -- generated, which has a double effect: (1) to make the compilation + -- process more efficient and (2) to give the code generator more + -- freedom to optimize within each unit, especially subprograms. + + if (Scope (Spec_Id) = Standard_Standard or else Is_Child_Unit (Spec_Id)) + and then not Is_Generic_Unit (Spec_Id) + and then Present (Declarations (N)) + then + Make_Non_Public_Where_Possible : declare + + function Has_Referencer + (L : List_Id; + Outer : Boolean) return Boolean; + -- Traverse the given list of declarations in reverse order. + -- Return True if a referencer is present. Return False if none is + -- found. The Outer parameter is True for the outer level call and + -- False for inner level calls for nested packages. If Outer is + -- True, then any entities up to the point of hitting a referencer + -- get their Is_Public flag cleared, so that the entities will be + -- treated as static entities in the C sense, and need not have + -- fully qualified names. Furthermore, if the referencer is an + -- inlined subprogram that doesn't reference other subprograms, + -- we keep clearing the Is_Public flag on subprograms. For inner + -- levels, we need all names to be fully qualified to deal with + -- the same name appearing in parallel packages (right now this + -- is tied to their being external). + + -------------------- + -- Has_Referencer -- + -------------------- + + function Has_Referencer + (L : List_Id; + Outer : Boolean) return Boolean + is + Has_Referencer_Except_For_Subprograms : Boolean := False; + + D : Node_Id; + E : Entity_Id; + K : Node_Kind; + S : Entity_Id; + + function Check_Subprogram_Ref (N : Node_Id) + return Traverse_Result; + -- Look for references to subprograms + + -------------------------- + -- Check_Subprogram_Ref -- + -------------------------- + + function Check_Subprogram_Ref (N : Node_Id) + return Traverse_Result + is + V : Node_Id; + + begin + -- Check name of procedure or function calls + + if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) + and then Is_Entity_Name (Name (N)) + then + return Abandon; + end if; + + -- Check prefix of attribute references + + if Nkind (N) = N_Attribute_Reference + and then Is_Entity_Name (Prefix (N)) + and then Present (Entity (Prefix (N))) + and then Ekind (Entity (Prefix (N))) in Subprogram_Kind + then + return Abandon; + end if; + + -- Check value of constants + + if Nkind (N) = N_Identifier + and then Present (Entity (N)) + and then Ekind (Entity (N)) = E_Constant + then + V := Constant_Value (Entity (N)); + if Present (V) + and then not Compile_Time_Known_Value_Or_Aggr (V) + then + return Abandon; + end if; + end if; + + return OK; + end Check_Subprogram_Ref; + + function Check_Subprogram_Refs is + new Traverse_Func (Check_Subprogram_Ref); + + -- Start of processing for Has_Referencer + + begin + if No (L) then + return False; + end if; + + D := Last (L); + while Present (D) loop + K := Nkind (D); + + if K in N_Body_Stub then + return True; + + -- Processing for subprogram bodies + + elsif K = N_Subprogram_Body then + if Acts_As_Spec (D) then + E := Defining_Entity (D); + + -- An inlined body acts as a referencer. Note also + -- that we never reset Is_Public for an inlined + -- subprogram. Gigi requires Is_Public to be set. + + -- Note that we test Has_Pragma_Inline here rather + -- than Is_Inlined. We are compiling this for a + -- client, and it is the client who will decide if + -- actual inlining should occur, so we need to assume + -- that the procedure could be inlined for the purpose + -- of accessing global entities. + + if Has_Pragma_Inline (E) then + if Outer + and then Check_Subprogram_Refs (D) = OK + then + Has_Referencer_Except_For_Subprograms := True; + else + return True; + end if; + else + Set_Is_Public (E, False); + end if; + + else + E := Corresponding_Spec (D); + + if Present (E) then + + -- A generic subprogram body acts as a referencer + + if Is_Generic_Unit (E) then + return True; + end if; + + if Has_Pragma_Inline (E) or else Is_Inlined (E) then + if Outer + and then Check_Subprogram_Refs (D) = OK + then + Has_Referencer_Except_For_Subprograms := True; + else + return True; + end if; + end if; + end if; + end if; + + -- Processing for package bodies + + elsif K = N_Package_Body + and then not Has_Referencer_Except_For_Subprograms + and then Present (Corresponding_Spec (D)) + then + E := Corresponding_Spec (D); + + -- Generic package body is a referencer. It would seem + -- that we only have to consider generics that can be + -- exported, i.e. where the corresponding spec is the + -- spec of the current package, but because of nested + -- instantiations, a fully private generic body may + -- export other private body entities. + + if Is_Generic_Unit (E) then + return True; + + -- For non-generic package body, recurse into body unless + -- this is an instance, we ignore instances since they + -- cannot have references that affect outer entities. + + elsif not Is_Generic_Instance (E) then + if Has_Referencer + (Declarations (D), Outer => False) + then + return True; + end if; + end if; + + -- Processing for package specs, recurse into declarations. + -- Again we skip this for the case of generic instances. + + elsif K = N_Package_Declaration + and then not Has_Referencer_Except_For_Subprograms + then + S := Specification (D); + + if not Is_Generic_Unit (Defining_Entity (S)) then + if Has_Referencer + (Private_Declarations (S), Outer => False) + then + return True; + elsif Has_Referencer + (Visible_Declarations (S), Outer => False) + then + return True; + end if; + end if; + + -- Objects and exceptions need not be public if we have not + -- encountered a referencer so far. We only reset the flag + -- for outer level entities that are not imported/exported, + -- and which have no interface name. + + elsif Nkind_In (K, N_Object_Declaration, + N_Exception_Declaration, + N_Subprogram_Declaration) + then + E := Defining_Entity (D); + + if Outer + and then (not Has_Referencer_Except_For_Subprograms + or else K = N_Subprogram_Declaration) + and then not Is_Imported (E) + and then not Is_Exported (E) + and then No (Interface_Name (E)) + then + Set_Is_Public (E, False); + end if; + end if; + + Prev (D); + end loop; + + return Has_Referencer_Except_For_Subprograms; + end Has_Referencer; + + -- Start of processing for Make_Non_Public_Where_Possible + + begin + declare + Discard : Boolean; + pragma Warnings (Off, Discard); + + begin + Discard := Has_Referencer (Declarations (N), Outer => True); + end; + end Make_Non_Public_Where_Possible; + end if; + + -- If expander is not active, then here is where we turn off the + -- In_Package_Body flag, otherwise it is turned off at the end of the + -- corresponding expansion routine. If this is an instance body, we need + -- to qualify names of local entities, because the body may have been + -- compiled as a preliminary to another instantiation. + + if not Expander_Active then + Set_In_Package_Body (Spec_Id, False); + + if Is_Generic_Instance (Spec_Id) + and then Operating_Mode = Generate_Code + then + Qualify_Entity_Names (N); + end if; + end if; + end Analyze_Package_Body_Helper; + + --------------------------------- + -- Analyze_Package_Declaration -- + --------------------------------- + + procedure Analyze_Package_Declaration (N : Node_Id) is + Id : constant Node_Id := Defining_Entity (N); + + PF : Boolean; + -- True when in the context of a declared pure library unit + + Body_Required : Boolean; + -- True when this package declaration requires a corresponding body + + Comp_Unit : Boolean; + -- True when this package declaration is not a nested declaration + + begin + -- Ada 2005 (AI-217): Check if the package has been erroneously named + -- in a limited-with clause of its own context. In this case the error + -- has been previously notified by Analyze_Context. + + -- limited with Pkg; -- ERROR + -- package Pkg is ... + + if From_With_Type (Id) then + goto Leave; + end if; + + if Debug_Flag_C then + Write_Str ("==> package spec "); + Write_Name (Chars (Id)); + Write_Str (" from "); + Write_Location (Sloc (N)); + Write_Eol; + Indent; + end if; + + Generate_Definition (Id); + Enter_Name (Id); + Set_Ekind (Id, E_Package); + Set_Etype (Id, Standard_Void_Type); + + Push_Scope (Id); + + PF := Is_Pure (Enclosing_Lib_Unit_Entity); + Set_Is_Pure (Id, PF); + + Set_Categorization_From_Pragmas (N); + + Analyze (Specification (N)); + Validate_Categorization_Dependency (N, Id); + + Body_Required := Unit_Requires_Body (Id); + + -- When this spec does not require an explicit body, we know that there + -- are no entities requiring completion in the language sense; we call + -- Check_Completion here only to ensure that any nested package + -- declaration that requires an implicit body gets one. (In the case + -- where a body is required, Check_Completion is called at the end of + -- the body's declarative part.) + + if not Body_Required then + Check_Completion; + end if; + + Comp_Unit := Nkind (Parent (N)) = N_Compilation_Unit; + if Comp_Unit then + + -- Set Body_Required indication on the compilation unit node, and + -- determine whether elaboration warnings may be meaningful on it. + + Set_Body_Required (Parent (N), Body_Required); + + if not Body_Required then + Set_Suppress_Elaboration_Warnings (Id); + end if; + + end if; + + End_Package_Scope (Id); + + -- For the declaration of a library unit that is a remote types package, + -- check legality rules regarding availability of stream attributes for + -- types that contain non-remote access values. This subprogram performs + -- visibility tests that rely on the fact that we have exited the scope + -- of Id. + + if Comp_Unit then + Validate_RT_RAT_Component (N); + end if; + + if Debug_Flag_C then + Outdent; + Write_Str ("<== package spec "); + Write_Name (Chars (Id)); + Write_Str (" from "); + Write_Location (Sloc (N)); + Write_Eol; + end if; + + <> + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); + end Analyze_Package_Declaration; + + ----------------------------------- + -- Analyze_Package_Specification -- + ----------------------------------- + + -- Note that this code is shared for the analysis of generic package specs + -- (see Sem_Ch12.Analyze_Generic_Package_Declaration for details). + + procedure Analyze_Package_Specification (N : Node_Id) is + Id : constant Entity_Id := Defining_Entity (N); + Orig_Decl : constant Node_Id := Original_Node (Parent (N)); + Vis_Decls : constant List_Id := Visible_Declarations (N); + Priv_Decls : constant List_Id := Private_Declarations (N); + E : Entity_Id; + L : Entity_Id; + Public_Child : Boolean; + + Private_With_Clauses_Installed : Boolean := False; + -- In Ada 2005, private with_clauses are visible in the private part + -- of a nested package, even if it appears in the public part of the + -- enclosing package. This requires a separate step to install these + -- private_with_clauses, and remove them at the end of the nested + -- package. + + procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id); + -- Clears constant indications (Never_Set_In_Source, Constant_Value, and + -- Is_True_Constant) on all variables that are entities of Id, and on + -- the chain whose first element is FE. A recursive call is made for all + -- packages and generic packages. + + procedure Generate_Parent_References; + -- For a child unit, generate references to parent units, for + -- GPS navigation purposes. + + function Is_Public_Child (Child, Unit : Entity_Id) return Boolean; + -- Child and Unit are entities of compilation units. True if Child + -- is a public child of Parent as defined in 10.1.1 + + procedure Inspect_Unchecked_Union_Completion (Decls : List_Id); + -- Detects all incomplete or private type declarations having a known + -- discriminant part that are completed by an Unchecked_Union. Emits + -- the error message "Unchecked_Union may not complete discriminated + -- partial view". + + procedure Install_Parent_Private_Declarations (Inst_Id : Entity_Id); + -- Given the package entity of a generic package instantiation or + -- formal package whose corresponding generic is a child unit, installs + -- the private declarations of each of the child unit's parents. + -- This has to be done at the point of entering the instance package's + -- private part rather than being done in Sem_Ch12.Install_Parent + -- (which is where the parents' visible declarations are installed). + + --------------------- + -- Clear_Constants -- + --------------------- + + procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id) is + E : Entity_Id; + + begin + -- Ignore package renamings, not interesting and they can cause self + -- referential loops in the code below. + + if Nkind (Parent (Id)) = N_Package_Renaming_Declaration then + return; + end if; + + -- Note: in the loop below, the check for Next_Entity pointing back + -- to the package entity may seem odd, but it is needed, because a + -- package can contain a renaming declaration to itself, and such + -- renamings are generated automatically within package instances. + + E := FE; + while Present (E) and then E /= Id loop + if Is_Assignable (E) then + Set_Never_Set_In_Source (E, False); + Set_Is_True_Constant (E, False); + Set_Current_Value (E, Empty); + Set_Is_Known_Null (E, False); + Set_Last_Assignment (E, Empty); + + if not Can_Never_Be_Null (E) then + Set_Is_Known_Non_Null (E, False); + end if; + + elsif Is_Package_Or_Generic_Package (E) then + Clear_Constants (E, First_Entity (E)); + Clear_Constants (E, First_Private_Entity (E)); + end if; + + Next_Entity (E); + end loop; + end Clear_Constants; + + -------------------------------- + -- Generate_Parent_References -- + -------------------------------- + + procedure Generate_Parent_References is + Decl : constant Node_Id := Parent (N); + + begin + if Id = Cunit_Entity (Main_Unit) + or else Parent (Decl) = Library_Unit (Cunit (Main_Unit)) + then + Generate_Reference (Id, Scope (Id), 'k', False); + + elsif not Nkind_In (Unit (Cunit (Main_Unit)), N_Subprogram_Body, + N_Subunit) + then + -- If current unit is an ancestor of main unit, generate a + -- reference to its own parent. + + declare + U : Node_Id; + Main_Spec : Node_Id := Unit (Cunit (Main_Unit)); + + begin + if Nkind (Main_Spec) = N_Package_Body then + Main_Spec := Unit (Library_Unit (Cunit (Main_Unit))); + end if; + + U := Parent_Spec (Main_Spec); + while Present (U) loop + if U = Parent (Decl) then + Generate_Reference (Id, Scope (Id), 'k', False); + exit; + + elsif Nkind (Unit (U)) = N_Package_Body then + exit; + + else + U := Parent_Spec (Unit (U)); + end if; + end loop; + end; + end if; + end Generate_Parent_References; + + --------------------- + -- Is_Public_Child -- + --------------------- + + function Is_Public_Child (Child, Unit : Entity_Id) return Boolean is + begin + if not Is_Private_Descendant (Child) then + return True; + else + if Child = Unit then + return not Private_Present ( + Parent (Unit_Declaration_Node (Child))); + else + return Is_Public_Child (Scope (Child), Unit); + end if; + end if; + end Is_Public_Child; + + ---------------------------------------- + -- Inspect_Unchecked_Union_Completion -- + ---------------------------------------- + + procedure Inspect_Unchecked_Union_Completion (Decls : List_Id) is + Decl : Node_Id; + + begin + Decl := First (Decls); + while Present (Decl) loop + + -- We are looking at an incomplete or private type declaration + -- with a known_discriminant_part whose full view is an + -- Unchecked_Union. + + if Nkind_In (Decl, N_Incomplete_Type_Declaration, + N_Private_Type_Declaration) + and then Has_Discriminants (Defining_Identifier (Decl)) + and then Present (Full_View (Defining_Identifier (Decl))) + and then + Is_Unchecked_Union (Full_View (Defining_Identifier (Decl))) + then + Error_Msg_N + ("completion of discriminated partial view " + & "cannot be an Unchecked_Union", + Full_View (Defining_Identifier (Decl))); + end if; + + Next (Decl); + end loop; + end Inspect_Unchecked_Union_Completion; + + ----------------------------------------- + -- Install_Parent_Private_Declarations -- + ----------------------------------------- + + procedure Install_Parent_Private_Declarations (Inst_Id : Entity_Id) is + Inst_Par : Entity_Id; + Gen_Par : Entity_Id; + Inst_Node : Node_Id; + + begin + Inst_Par := Inst_Id; + + Gen_Par := + Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par))); + while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop + Inst_Node := Get_Package_Instantiation_Node (Inst_Par); + + if Nkind_In (Inst_Node, N_Package_Instantiation, + N_Formal_Package_Declaration) + and then Nkind (Name (Inst_Node)) = N_Expanded_Name + then + Inst_Par := Entity (Prefix (Name (Inst_Node))); + + if Present (Renamed_Entity (Inst_Par)) then + Inst_Par := Renamed_Entity (Inst_Par); + end if; + + Gen_Par := + Generic_Parent + (Specification (Unit_Declaration_Node (Inst_Par))); + + -- Install the private declarations and private use clauses + -- of a parent instance of the child instance, unless the + -- parent instance private declarations have already been + -- installed earlier in Analyze_Package_Specification, which + -- happens when a generic child is instantiated, and the + -- instance is a child of the parent instance. + + -- Installing the use clauses of the parent instance twice + -- is both unnecessary and wrong, because it would cause the + -- clauses to be chained to themselves in the use clauses + -- list of the scope stack entry. That in turn would cause + -- an endless loop from End_Use_Clauses upon scope exit. + + -- The parent is now fully visible. It may be a hidden open + -- scope if we are currently compiling some child instance + -- declared within it, but while the current instance is being + -- compiled the parent is immediately visible. In particular + -- its entities must remain visible if a stack save/restore + -- takes place through a call to Rtsfind. + + if Present (Gen_Par) then + if not In_Private_Part (Inst_Par) then + Install_Private_Declarations (Inst_Par); + Set_Use (Private_Declarations + (Specification + (Unit_Declaration_Node (Inst_Par)))); + Set_Is_Hidden_Open_Scope (Inst_Par, False); + end if; + + -- If we've reached the end of the generic instance parents, + -- then finish off by looping through the nongeneric parents + -- and installing their private declarations. + + else + while Present (Inst_Par) + and then Inst_Par /= Standard_Standard + and then (not In_Open_Scopes (Inst_Par) + or else not In_Private_Part (Inst_Par)) + loop + Install_Private_Declarations (Inst_Par); + Set_Use (Private_Declarations + (Specification + (Unit_Declaration_Node (Inst_Par)))); + Inst_Par := Scope (Inst_Par); + end loop; + + exit; + end if; + + else + exit; + end if; + end loop; + end Install_Parent_Private_Declarations; + + -- Start of processing for Analyze_Package_Specification + + begin + if Present (Vis_Decls) then + Analyze_Declarations (Vis_Decls); + end if; + + -- Verify that incomplete types have received full declarations and + -- also build invariant procedures for any types with invariants. + + E := First_Entity (Id); + while Present (E) loop + + -- Check on incomplete types + + if Ekind (E) = E_Incomplete_Type + and then No (Full_View (E)) + then + Error_Msg_N ("no declaration in visible part for incomplete}", E); + end if; + + -- Build invariant procedures + + if Is_Type (E) and then Has_Invariants (E) then + Build_Invariant_Procedure (E, N); + end if; + + Next_Entity (E); + end loop; + + if Is_Remote_Call_Interface (Id) + and then Nkind (Parent (Parent (N))) = N_Compilation_Unit + then + Validate_RCI_Declarations (Id); + end if; + + -- Save global references in the visible declarations, before installing + -- private declarations of parent unit if there is one, because the + -- privacy status of types defined in the parent will change. This is + -- only relevant for generic child units, but is done in all cases for + -- uniformity. + + if Ekind (Id) = E_Generic_Package + and then Nkind (Orig_Decl) = N_Generic_Package_Declaration + then + declare + Orig_Spec : constant Node_Id := Specification (Orig_Decl); + Save_Priv : constant List_Id := Private_Declarations (Orig_Spec); + begin + Set_Private_Declarations (Orig_Spec, Empty_List); + Save_Global_References (Orig_Decl); + Set_Private_Declarations (Orig_Spec, Save_Priv); + end; + end if; + + -- If package is a public child unit, then make the private declarations + -- of the parent visible. + + Public_Child := False; + + declare + Par : Entity_Id; + Pack_Decl : Node_Id; + Par_Spec : Node_Id; + + begin + Par := Id; + Par_Spec := Parent_Spec (Parent (N)); + + -- If the package is formal package of an enclosing generic, it is + -- transformed into a local generic declaration, and compiled to make + -- its spec available. We need to retrieve the original generic to + -- determine whether it is a child unit, and install its parents. + + if No (Par_Spec) + and then + Nkind (Original_Node (Parent (N))) = N_Formal_Package_Declaration + then + Par := Entity (Name (Original_Node (Parent (N)))); + Par_Spec := Parent_Spec (Unit_Declaration_Node (Par)); + end if; + + if Present (Par_Spec) then + Generate_Parent_References; + + while Scope (Par) /= Standard_Standard + and then Is_Public_Child (Id, Par) + and then In_Open_Scopes (Par) + loop + Public_Child := True; + Par := Scope (Par); + Install_Private_Declarations (Par); + Install_Private_With_Clauses (Par); + Pack_Decl := Unit_Declaration_Node (Par); + Set_Use (Private_Declarations (Specification (Pack_Decl))); + end loop; + end if; + end; + + if Is_Compilation_Unit (Id) then + Install_Private_With_Clauses (Id); + else + + -- The current compilation unit may include private with_clauses, + -- which are visible in the private part of the current nested + -- package, and have to be installed now. This is not done for + -- nested instantiations, where the private with_clauses of the + -- enclosing unit have no effect once the instantiation info is + -- established and we start analyzing the package declaration. + + declare + Comp_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); + begin + if Is_Package_Or_Generic_Package (Comp_Unit) + and then not In_Private_Part (Comp_Unit) + and then not In_Instance + then + Install_Private_With_Clauses (Comp_Unit); + Private_With_Clauses_Installed := True; + end if; + end; + end if; + + -- If this is a package associated with a generic instance or formal + -- package, then the private declarations of each of the generic's + -- parents must be installed at this point. + + if Is_Generic_Instance (Id) then + Install_Parent_Private_Declarations (Id); + end if; + + -- Analyze private part if present. The flag In_Private_Part is reset + -- in End_Package_Scope. + + L := Last_Entity (Id); + + if Present (Priv_Decls) then + Set_In_Private_Part (Id); + + -- Upon entering a public child's private part, it may be necessary + -- to declare subprograms that were derived in the package's visible + -- part but not yet made visible. + + if Public_Child then + Declare_Inherited_Private_Subprograms (Id); + end if; + + Analyze_Declarations (Priv_Decls); + + -- Check the private declarations for incomplete deferred constants + + Inspect_Deferred_Constant_Completion (Priv_Decls); + + -- The first private entity is the immediate follower of the last + -- visible entity, if there was one. + + if Present (L) then + Set_First_Private_Entity (Id, Next_Entity (L)); + else + Set_First_Private_Entity (Id, First_Entity (Id)); + end if; + + -- There may be inherited private subprograms that need to be declared, + -- even in the absence of an explicit private part. If there are any + -- public declarations in the package and the package is a public child + -- unit, then an implicit private part is assumed. + + elsif Present (L) and then Public_Child then + Set_In_Private_Part (Id); + Declare_Inherited_Private_Subprograms (Id); + Set_First_Private_Entity (Id, Next_Entity (L)); + end if; + + E := First_Entity (Id); + while Present (E) loop + + -- Check rule of 3.6(11), which in general requires waiting till all + -- full types have been seen. + + if Ekind (E) = E_Record_Type or else Ekind (E) = E_Array_Type then + Check_Aliased_Component_Types (E); + end if; + + -- Check preelaborable initialization for full type completing a + -- private type for which pragma Preelaborable_Initialization given. + + if Is_Type (E) + and then Must_Have_Preelab_Init (E) + and then not Has_Preelaborable_Initialization (E) + then + Error_Msg_N + ("full view of & does not have preelaborable initialization", E); + end if; + + Next_Entity (E); + end loop; + + -- Ada 2005 (AI-216): The completion of an incomplete or private type + -- declaration having a known_discriminant_part shall not be an + -- Unchecked_Union type. + + if Present (Vis_Decls) then + Inspect_Unchecked_Union_Completion (Vis_Decls); + end if; + + if Present (Priv_Decls) then + Inspect_Unchecked_Union_Completion (Priv_Decls); + end if; + + if Ekind (Id) = E_Generic_Package + and then Nkind (Orig_Decl) = N_Generic_Package_Declaration + and then Present (Priv_Decls) + then + -- Save global references in private declarations, ignoring the + -- visible declarations that were processed earlier. + + declare + Orig_Spec : constant Node_Id := Specification (Orig_Decl); + Save_Vis : constant List_Id := Visible_Declarations (Orig_Spec); + Save_Form : constant List_Id := + Generic_Formal_Declarations (Orig_Decl); + + begin + Set_Visible_Declarations (Orig_Spec, Empty_List); + Set_Generic_Formal_Declarations (Orig_Decl, Empty_List); + Save_Global_References (Orig_Decl); + Set_Generic_Formal_Declarations (Orig_Decl, Save_Form); + Set_Visible_Declarations (Orig_Spec, Save_Vis); + end; + end if; + + Process_End_Label (N, 'e', Id); + + -- Remove private_with_clauses of enclosing compilation unit, if they + -- were installed. + + if Private_With_Clauses_Installed then + Remove_Private_With_Clauses (Cunit (Current_Sem_Unit)); + end if; + + -- For the case of a library level package, we must go through all the + -- entities clearing the indications that the value may be constant and + -- not modified. Why? Because any client of this package may modify + -- these values freely from anywhere. This also applies to any nested + -- packages or generic packages. + + -- For now we unconditionally clear constants for packages that are + -- instances of generic packages. The reason is that we do not have the + -- body yet, and we otherwise think things are unreferenced when they + -- are not. This should be fixed sometime (the effect is not terrible, + -- we just lose some warnings, and also some cases of value propagation) + -- ??? + + if Is_Library_Level_Entity (Id) + or else Is_Generic_Instance (Id) + then + Clear_Constants (Id, First_Entity (Id)); + Clear_Constants (Id, First_Private_Entity (Id)); + end if; + end Analyze_Package_Specification; + + -------------------------------------- + -- Analyze_Private_Type_Declaration -- + -------------------------------------- + + procedure Analyze_Private_Type_Declaration (N : Node_Id) is + PF : constant Boolean := Is_Pure (Enclosing_Lib_Unit_Entity); + Id : constant Entity_Id := Defining_Identifier (N); + + begin + Generate_Definition (Id); + Set_Is_Pure (Id, PF); + Init_Size_Align (Id); + + if not Is_Package_Or_Generic_Package (Current_Scope) + or else In_Private_Part (Current_Scope) + then + Error_Msg_N ("invalid context for private declaration", N); + end if; + + New_Private_Type (N, Id, N); + Set_Depends_On_Private (Id); + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); + end Analyze_Private_Type_Declaration; + + ---------------------------------- + -- Check_Anonymous_Access_Types -- + ---------------------------------- + + procedure Check_Anonymous_Access_Types + (Spec_Id : Entity_Id; + P_Body : Node_Id) + is + E : Entity_Id; + IR : Node_Id; + + begin + -- Itype references are only needed by gigi, to force elaboration of + -- itypes. In the absence of code generation, they are not needed. + + if not Expander_Active then + return; + end if; + + E := First_Entity (Spec_Id); + while Present (E) loop + if Ekind (E) = E_Anonymous_Access_Type + and then From_With_Type (E) + then + IR := Make_Itype_Reference (Sloc (P_Body)); + Set_Itype (IR, E); + + if No (Declarations (P_Body)) then + Set_Declarations (P_Body, New_List (IR)); + else + Prepend (IR, Declarations (P_Body)); + end if; + end if; + + Next_Entity (E); + end loop; + end Check_Anonymous_Access_Types; + + ------------------------------------------- + -- Declare_Inherited_Private_Subprograms -- + ------------------------------------------- + + procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id) is + + function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean; + -- Check whether an inherited subprogram is an operation of an untagged + -- derived type. + + --------------------- + -- Is_Primitive_Of -- + --------------------- + + function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean is + Formal : Entity_Id; + + begin + -- If the full view is a scalar type, the type is the anonymous base + -- type, but the operation mentions the first subtype, so check the + -- signature against the base type. + + if Base_Type (Etype (S)) = Base_Type (T) then + return True; + + else + Formal := First_Formal (S); + while Present (Formal) loop + if Base_Type (Etype (Formal)) = Base_Type (T) then + return True; + end if; + + Next_Formal (Formal); + end loop; + + return False; + end if; + end Is_Primitive_Of; + + -- Local variables + + E : Entity_Id; + Op_List : Elist_Id; + Op_Elmt : Elmt_Id; + Op_Elmt_2 : Elmt_Id; + Prim_Op : Entity_Id; + New_Op : Entity_Id := Empty; + Parent_Subp : Entity_Id; + Tag : Entity_Id; + + -- Start of processing for Declare_Inherited_Private_Subprograms + + begin + E := First_Entity (Id); + while Present (E) loop + + -- If the entity is a nonprivate type extension whose parent type + -- is declared in an open scope, then the type may have inherited + -- operations that now need to be made visible. Ditto if the entity + -- is a formal derived type in a child unit. + + if ((Is_Derived_Type (E) and then not Is_Private_Type (E)) + or else + (Nkind (Parent (E)) = N_Private_Extension_Declaration + and then Is_Generic_Type (E))) + and then In_Open_Scopes (Scope (Etype (E))) + and then Is_Base_Type (E) + then + if Is_Tagged_Type (E) then + Op_List := Primitive_Operations (E); + New_Op := Empty; + Tag := First_Tag_Component (E); + + Op_Elmt := First_Elmt (Op_List); + while Present (Op_Elmt) loop + Prim_Op := Node (Op_Elmt); + + -- Search primitives that are implicit operations with an + -- internal name whose parent operation has a normal name. + + if Present (Alias (Prim_Op)) + and then Find_Dispatching_Type (Alias (Prim_Op)) /= E + and then not Comes_From_Source (Prim_Op) + and then Is_Internal_Name (Chars (Prim_Op)) + and then not Is_Internal_Name (Chars (Alias (Prim_Op))) + then + Parent_Subp := Alias (Prim_Op); + + -- Case 1: Check if the type has also an explicit + -- overriding for this primitive. + + Op_Elmt_2 := Next_Elmt (Op_Elmt); + while Present (Op_Elmt_2) loop + + -- Skip entities with attribute Interface_Alias since + -- they are not overriding primitives (these entities + -- link an interface primitive with their covering + -- primitive) + + if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp) + and then Type_Conformant (Prim_Op, Node (Op_Elmt_2)) + and then No (Interface_Alias (Node (Op_Elmt_2))) + then + -- The private inherited operation has been + -- overridden by an explicit subprogram: replace + -- the former by the latter. + + New_Op := Node (Op_Elmt_2); + Replace_Elmt (Op_Elmt, New_Op); + Remove_Elmt (Op_List, Op_Elmt_2); + Set_Overridden_Operation (New_Op, Parent_Subp); + + -- We don't need to inherit its dispatching slot. + -- Set_All_DT_Position has previously ensured that + -- the same slot was assigned to the two primitives + + if Present (Tag) + and then Present (DTC_Entity (New_Op)) + and then Present (DTC_Entity (Prim_Op)) + then + pragma Assert (DT_Position (New_Op) + = DT_Position (Prim_Op)); + null; + end if; + + goto Next_Primitive; + end if; + + Next_Elmt (Op_Elmt_2); + end loop; + + -- Case 2: We have not found any explicit overriding and + -- hence we need to declare the operation (i.e., make it + -- visible). + + Derive_Subprogram (New_Op, Alias (Prim_Op), E, Etype (E)); + + -- Inherit the dispatching slot if E is already frozen + + if Is_Frozen (E) + and then Present (DTC_Entity (Alias (Prim_Op))) + then + Set_DTC_Entity_Value (E, New_Op); + Set_DT_Position (New_Op, + DT_Position (Alias (Prim_Op))); + end if; + + pragma Assert + (Is_Dispatching_Operation (New_Op) + and then Node (Last_Elmt (Op_List)) = New_Op); + + -- Substitute the new operation for the old one in the + -- type's primitive operations list. Since the new + -- operation was also just added to the end of list, + -- the last element must be removed. + + -- (Question: is there a simpler way of declaring the + -- operation, say by just replacing the name of the + -- earlier operation, reentering it in the in the symbol + -- table (how?), and marking it as private???) + + Replace_Elmt (Op_Elmt, New_Op); + Remove_Last_Elmt (Op_List); + end if; + + <> + Next_Elmt (Op_Elmt); + end loop; + + -- Generate listing showing the contents of the dispatch table + + if Debug_Flag_ZZ then + Write_DT (E); + end if; + + else + -- Non-tagged type, scan forward to locate inherited hidden + -- operations. + + Prim_Op := Next_Entity (E); + while Present (Prim_Op) loop + if Is_Subprogram (Prim_Op) + and then Present (Alias (Prim_Op)) + and then not Comes_From_Source (Prim_Op) + and then Is_Internal_Name (Chars (Prim_Op)) + and then not Is_Internal_Name (Chars (Alias (Prim_Op))) + and then Is_Primitive_Of (E, Prim_Op) + then + Derive_Subprogram (New_Op, Alias (Prim_Op), E, Etype (E)); + end if; + + Next_Entity (Prim_Op); + end loop; + end if; + end if; + + Next_Entity (E); + end loop; + end Declare_Inherited_Private_Subprograms; + + ----------------------- + -- End_Package_Scope -- + ----------------------- + + procedure End_Package_Scope (P : Entity_Id) is + begin + Uninstall_Declarations (P); + Pop_Scope; + end End_Package_Scope; + + --------------------------- + -- Exchange_Declarations -- + --------------------------- + + procedure Exchange_Declarations (Id : Entity_Id) is + Full_Id : constant Entity_Id := Full_View (Id); + H1 : constant Entity_Id := Homonym (Id); + Next1 : constant Entity_Id := Next_Entity (Id); + H2 : Entity_Id; + Next2 : Entity_Id; + + begin + -- If missing full declaration for type, nothing to exchange + + if No (Full_Id) then + return; + end if; + + -- Otherwise complete the exchange, and preserve semantic links + + Next2 := Next_Entity (Full_Id); + H2 := Homonym (Full_Id); + + -- Reset full declaration pointer to reflect the switched entities and + -- readjust the next entity chains. + + Exchange_Entities (Id, Full_Id); + + Set_Next_Entity (Id, Next1); + Set_Homonym (Id, H1); + + Set_Full_View (Full_Id, Id); + Set_Next_Entity (Full_Id, Next2); + Set_Homonym (Full_Id, H2); + end Exchange_Declarations; + + ---------------------------- + -- Install_Package_Entity -- + ---------------------------- + + procedure Install_Package_Entity (Id : Entity_Id) is + begin + if not Is_Internal (Id) then + if Debug_Flag_E then + Write_Str ("Install: "); + Write_Name (Chars (Id)); + Write_Eol; + end if; + + if not Is_Child_Unit (Id) then + Set_Is_Immediately_Visible (Id); + end if; + + end if; + end Install_Package_Entity; + + ---------------------------------- + -- Install_Private_Declarations -- + ---------------------------------- + + procedure Install_Private_Declarations (P : Entity_Id) is + Id : Entity_Id; + Priv_Elmt : Elmt_Id; + Priv : Entity_Id; + Full : Entity_Id; + + begin + -- First exchange declarations for private types, so that the full + -- declaration is visible. For each private type, we check its + -- Private_Dependents list and also exchange any subtypes of or derived + -- types from it. Finally, if this is a Taft amendment type, the + -- incomplete declaration is irrelevant, and we want to link the + -- eventual full declaration with the original private one so we also + -- skip the exchange. + + Id := First_Entity (P); + while Present (Id) and then Id /= First_Private_Entity (P) loop + if Is_Private_Base_Type (Id) + and then Comes_From_Source (Full_View (Id)) + and then Present (Full_View (Id)) + and then Scope (Full_View (Id)) = Scope (Id) + and then Ekind (Full_View (Id)) /= E_Incomplete_Type + then + -- If there is a use-type clause on the private type, set the + -- full view accordingly. + + Set_In_Use (Full_View (Id), In_Use (Id)); + Full := Full_View (Id); + + if Is_Private_Base_Type (Full) + and then Has_Private_Declaration (Full) + and then Nkind (Parent (Full)) = N_Full_Type_Declaration + and then In_Open_Scopes (Scope (Etype (Full))) + and then In_Package_Body (Current_Scope) + and then not Is_Private_Type (Etype (Full)) + then + -- This is the completion of a private type by a derivation + -- from another private type which is not private anymore. This + -- can only happen in a package nested within a child package, + -- when the parent type is defined in the parent unit. At this + -- point the current type is not private either, and we have to + -- install the underlying full view, which is now visible. Save + -- the current full view as well, so that all views can be + -- restored on exit. It may seem that after compiling the child + -- body there are not environments to restore, but the back-end + -- expects those links to be valid, and freeze nodes depend on + -- them. + + if No (Full_View (Full)) + and then Present (Underlying_Full_View (Full)) + then + Set_Full_View (Id, Underlying_Full_View (Full)); + Set_Underlying_Full_View (Id, Full); + + Set_Underlying_Full_View (Full, Empty); + Set_Is_Frozen (Full_View (Id)); + end if; + end if; + + Priv_Elmt := First_Elmt (Private_Dependents (Id)); + + Exchange_Declarations (Id); + Set_Is_Immediately_Visible (Id); + + while Present (Priv_Elmt) loop + Priv := Node (Priv_Elmt); + + -- Before the exchange, verify that the presence of the + -- Full_View field. It will be empty if the entity has already + -- been installed due to a previous call. + + if Present (Full_View (Priv)) + and then Is_Visible_Dependent (Priv) + then + + -- For each subtype that is swapped, we also swap the + -- reference to it in Private_Dependents, to allow access + -- to it when we swap them out in End_Package_Scope. + + Replace_Elmt (Priv_Elmt, Full_View (Priv)); + Exchange_Declarations (Priv); + Set_Is_Immediately_Visible + (Priv, In_Open_Scopes (Scope (Priv))); + Set_Is_Potentially_Use_Visible + (Priv, Is_Potentially_Use_Visible (Node (Priv_Elmt))); + end if; + + Next_Elmt (Priv_Elmt); + end loop; + end if; + + Next_Entity (Id); + end loop; + + -- Next make other declarations in the private part visible as well + + Id := First_Private_Entity (P); + while Present (Id) loop + Install_Package_Entity (Id); + Set_Is_Hidden (Id, False); + Next_Entity (Id); + end loop; + + -- Indicate that the private part is currently visible, so it can be + -- properly reset on exit. + + Set_In_Private_Part (P); + end Install_Private_Declarations; + + ---------------------------------- + -- Install_Visible_Declarations -- + ---------------------------------- + + procedure Install_Visible_Declarations (P : Entity_Id) is + Id : Entity_Id; + Last_Entity : Entity_Id; + + begin + pragma Assert + (Is_Package_Or_Generic_Package (P) or else Is_Record_Type (P)); + + if Is_Package_Or_Generic_Package (P) then + Last_Entity := First_Private_Entity (P); + else + Last_Entity := Empty; + end if; + + Id := First_Entity (P); + while Present (Id) and then Id /= Last_Entity loop + Install_Package_Entity (Id); + Next_Entity (Id); + end loop; + end Install_Visible_Declarations; + + -------------------------- + -- Is_Private_Base_Type -- + -------------------------- + + function Is_Private_Base_Type (E : Entity_Id) return Boolean is + begin + return Ekind (E) = E_Private_Type + or else Ekind (E) = E_Limited_Private_Type + or else Ekind (E) = E_Record_Type_With_Private; + end Is_Private_Base_Type; + + -------------------------- + -- Is_Visible_Dependent -- + -------------------------- + + function Is_Visible_Dependent (Dep : Entity_Id) return Boolean + is + S : constant Entity_Id := Scope (Dep); + + begin + -- Renamings created for actual types have the visibility of the actual + + if Ekind (S) = E_Package + and then Is_Generic_Instance (S) + and then (Is_Generic_Actual_Type (Dep) + or else Is_Generic_Actual_Type (Full_View (Dep))) + then + return True; + + elsif not (Is_Derived_Type (Dep)) + and then Is_Derived_Type (Full_View (Dep)) + then + -- When instantiating a package body, the scope stack is empty, so + -- check instead whether the dependent type is defined in the same + -- scope as the instance itself. + + return In_Open_Scopes (S) + or else (Is_Generic_Instance (Current_Scope) + and then Scope (Dep) = Scope (Current_Scope)); + else + return True; + end if; + end Is_Visible_Dependent; + + ---------------------------- + -- May_Need_Implicit_Body -- + ---------------------------- + + procedure May_Need_Implicit_Body (E : Entity_Id) is + P : constant Node_Id := Unit_Declaration_Node (E); + S : constant Node_Id := Parent (P); + B : Node_Id; + Decls : List_Id; + + begin + if not Has_Completion (E) + and then Nkind (P) = N_Package_Declaration + and then (Present (Activation_Chain_Entity (P)) or else Has_RACW (E)) + then + B := + Make_Package_Body (Sloc (E), + Defining_Unit_Name => Make_Defining_Identifier (Sloc (E), + Chars => Chars (E)), + Declarations => New_List); + + if Nkind (S) = N_Package_Specification then + if Present (Private_Declarations (S)) then + Decls := Private_Declarations (S); + else + Decls := Visible_Declarations (S); + end if; + else + Decls := Declarations (S); + end if; + + Append (B, Decls); + Analyze (B); + end if; + end May_Need_Implicit_Body; + + ---------------------- + -- New_Private_Type -- + ---------------------- + + procedure New_Private_Type (N : Node_Id; Id : Entity_Id; Def : Node_Id) is + begin + -- For other than Ada 2012, enter the name in the current scope + + if Ada_Version < Ada_2012 then + Enter_Name (Id); + + -- Ada 2012 (AI05-0162): Enter the name in the current scope handling + -- private type that completes an incomplete type. + + else + declare + Prev : Entity_Id; + begin + Prev := Find_Type_Name (N); + pragma Assert (Prev = Id + or else (Ekind (Prev) = E_Incomplete_Type + and then Present (Full_View (Prev)) + and then Full_View (Prev) = Id)); + end; + end if; + + if Limited_Present (Def) then + Set_Ekind (Id, E_Limited_Private_Type); + else + Set_Ekind (Id, E_Private_Type); + end if; + + Set_Etype (Id, Id); + Set_Has_Delayed_Freeze (Id); + Set_Is_First_Subtype (Id); + Init_Size_Align (Id); + + Set_Is_Constrained (Id, + No (Discriminant_Specifications (N)) + and then not Unknown_Discriminants_Present (N)); + + -- Set tagged flag before processing discriminants, to catch illegal + -- usage. + + Set_Is_Tagged_Type (Id, Tagged_Present (Def)); + + Set_Discriminant_Constraint (Id, No_Elist); + Set_Stored_Constraint (Id, No_Elist); + + if Present (Discriminant_Specifications (N)) then + Push_Scope (Id); + Process_Discriminants (N); + End_Scope; + + elsif Unknown_Discriminants_Present (N) then + Set_Has_Unknown_Discriminants (Id); + end if; + + Set_Private_Dependents (Id, New_Elmt_List); + + if Tagged_Present (Def) then + Set_Ekind (Id, E_Record_Type_With_Private); + Set_Direct_Primitive_Operations (Id, New_Elmt_List); + Set_Is_Abstract_Type (Id, Abstract_Present (Def)); + Set_Is_Limited_Record (Id, Limited_Present (Def)); + Set_Has_Delayed_Freeze (Id, True); + + -- Create a class-wide type with the same attributes + + Make_Class_Wide_Type (Id); + + elsif Abstract_Present (Def) then + Error_Msg_N ("only a tagged type can be abstract", N); + end if; + end New_Private_Type; + + ---------------------------- + -- Uninstall_Declarations -- + ---------------------------- + + procedure Uninstall_Declarations (P : Entity_Id) is + Decl : constant Node_Id := Unit_Declaration_Node (P); + Id : Entity_Id; + Full : Entity_Id; + Priv_Elmt : Elmt_Id; + Priv_Sub : Entity_Id; + + procedure Preserve_Full_Attributes (Priv, Full : Entity_Id); + -- Copy to the private declaration the attributes of the full view that + -- need to be available for the partial view also. + + function Type_In_Use (T : Entity_Id) return Boolean; + -- Check whether type or base type appear in an active use_type clause + + ------------------------------ + -- Preserve_Full_Attributes -- + ------------------------------ + + procedure Preserve_Full_Attributes (Priv, Full : Entity_Id) is + Priv_Is_Base_Type : constant Boolean := Is_Base_Type (Priv); + + begin + Set_Size_Info (Priv, (Full)); + Set_RM_Size (Priv, RM_Size (Full)); + Set_Size_Known_At_Compile_Time + (Priv, Size_Known_At_Compile_Time (Full)); + Set_Is_Volatile (Priv, Is_Volatile (Full)); + Set_Treat_As_Volatile (Priv, Treat_As_Volatile (Full)); + Set_Is_Ada_2005_Only (Priv, Is_Ada_2005_Only (Full)); + Set_Is_Ada_2012_Only (Priv, Is_Ada_2012_Only (Full)); + Set_Has_Pragma_Unmodified (Priv, Has_Pragma_Unmodified (Full)); + Set_Has_Pragma_Unreferenced (Priv, Has_Pragma_Unreferenced (Full)); + Set_Has_Pragma_Unreferenced_Objects + (Priv, Has_Pragma_Unreferenced_Objects + (Full)); + if Is_Unchecked_Union (Full) then + Set_Is_Unchecked_Union (Base_Type (Priv)); + end if; + -- Why is atomic not copied here ??? + + if Referenced (Full) then + Set_Referenced (Priv); + end if; + + if Priv_Is_Base_Type then + Set_Is_Controlled (Priv, Is_Controlled (Base_Type (Full))); + Set_Finalize_Storage_Only (Priv, Finalize_Storage_Only + (Base_Type (Full))); + Set_Has_Task (Priv, Has_Task (Base_Type (Full))); + Set_Has_Controlled_Component (Priv, Has_Controlled_Component + (Base_Type (Full))); + end if; + + Set_Freeze_Node (Priv, Freeze_Node (Full)); + + if Is_Tagged_Type (Priv) + and then Is_Tagged_Type (Full) + and then not Error_Posted (Full) + then + if Priv_Is_Base_Type then + + -- Ada 2005 (AI-345): The full view of a type implementing an + -- interface can be a task type. + + -- type T is new I with private; + -- private + -- task type T is new I with ... + + if Is_Interface (Etype (Priv)) + and then Is_Concurrent_Type (Base_Type (Full)) + then + -- Protect the frontend against previous errors + + if Present (Corresponding_Record_Type + (Base_Type (Full))) + then + Set_Access_Disp_Table + (Priv, Access_Disp_Table + (Corresponding_Record_Type (Base_Type (Full)))); + + -- Generic context, or previous errors + + else + null; + end if; + + else + Set_Access_Disp_Table + (Priv, Access_Disp_Table (Base_Type (Full))); + end if; + end if; + + if Is_Tagged_Type (Priv) then + + -- If the type is tagged, the tag itself must be available on + -- the partial view, for expansion purposes. + + Set_First_Entity (Priv, First_Entity (Full)); + + -- If there are discriminants in the partial view, these remain + -- visible. Otherwise only the tag itself is visible, and there + -- are no nameable components in the partial view. + + if No (Last_Entity (Priv)) then + Set_Last_Entity (Priv, First_Entity (Priv)); + end if; + end if; + + Set_Has_Discriminants (Priv, Has_Discriminants (Full)); + + if Has_Discriminants (Full) then + Set_Discriminant_Constraint (Priv, + Discriminant_Constraint (Full)); + end if; + end if; + end Preserve_Full_Attributes; + + ----------------- + -- Type_In_Use -- + ----------------- + + function Type_In_Use (T : Entity_Id) return Boolean is + begin + return Scope (Base_Type (T)) = P + and then (In_Use (T) or else In_Use (Base_Type (T))); + end Type_In_Use; + + -- Start of processing for Uninstall_Declarations + + begin + Id := First_Entity (P); + while Present (Id) and then Id /= First_Private_Entity (P) loop + if Debug_Flag_E then + Write_Str ("unlinking visible entity "); + Write_Int (Int (Id)); + Write_Eol; + end if; + + -- On exit from the package scope, we must preserve the visibility + -- established by use clauses in the current scope. Two cases: + + -- a) If the entity is an operator, it may be a primitive operator of + -- a type for which there is a visible use-type clause. + + -- b) for other entities, their use-visibility is determined by a + -- visible use clause for the package itself. For a generic instance, + -- the instantiation of the formals appears in the visible part, + -- but the formals are private and remain so. + + if Ekind (Id) = E_Function + and then Is_Operator_Symbol_Name (Chars (Id)) + and then not Is_Hidden (Id) + and then not Error_Posted (Id) + then + Set_Is_Potentially_Use_Visible (Id, + In_Use (P) + or else Type_In_Use (Etype (Id)) + or else Type_In_Use (Etype (First_Formal (Id))) + or else (Present (Next_Formal (First_Formal (Id))) + and then + Type_In_Use + (Etype (Next_Formal (First_Formal (Id)))))); + else + if In_Use (P) and then not Is_Hidden (Id) then + + -- A child unit of a use-visible package remains use-visible + -- only if it is itself a visible child unit. Otherwise it + -- would remain visible in other contexts where P is use- + -- visible, because once compiled it stays in the entity list + -- of its parent unit. + + if Is_Child_Unit (Id) then + Set_Is_Potentially_Use_Visible (Id, + Is_Visible_Child_Unit (Id)); + else + Set_Is_Potentially_Use_Visible (Id); + end if; + + else + Set_Is_Potentially_Use_Visible (Id, False); + end if; + end if; + + -- Local entities are not immediately visible outside of the package + + Set_Is_Immediately_Visible (Id, False); + + -- If this is a private type with a full view (for example a local + -- subtype of a private type declared elsewhere), ensure that the + -- full view is also removed from visibility: it may be exposed when + -- swapping views in an instantiation. + + if Is_Type (Id) + and then Present (Full_View (Id)) + then + Set_Is_Immediately_Visible (Full_View (Id), False); + end if; + + if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then + Check_Abstract_Overriding (Id); + Check_Conventions (Id); + end if; + + if (Ekind (Id) = E_Private_Type + or else Ekind (Id) = E_Limited_Private_Type) + and then No (Full_View (Id)) + and then not Is_Generic_Type (Id) + and then not Is_Derived_Type (Id) + then + Error_Msg_N ("missing full declaration for private type&", Id); + + elsif Ekind (Id) = E_Record_Type_With_Private + and then not Is_Generic_Type (Id) + and then No (Full_View (Id)) + then + if Nkind (Parent (Id)) = N_Private_Type_Declaration then + Error_Msg_N ("missing full declaration for private type&", Id); + else + Error_Msg_N + ("missing full declaration for private extension", Id); + end if; + + -- Case of constant, check for deferred constant declaration with + -- no full view. Likely just a matter of a missing expression, or + -- accidental use of the keyword constant. + + elsif Ekind (Id) = E_Constant + + -- OK if constant value present + + and then No (Constant_Value (Id)) + + -- OK if full view present + + and then No (Full_View (Id)) + + -- OK if imported, since that provides the completion + + and then not Is_Imported (Id) + + -- OK if object declaration replaced by renaming declaration as + -- a result of OK_To_Rename processing (e.g. for concatenation) + + and then Nkind (Parent (Id)) /= N_Object_Renaming_Declaration + + -- OK if object declaration with the No_Initialization flag set + + and then not (Nkind (Parent (Id)) = N_Object_Declaration + and then No_Initialization (Parent (Id))) + then + -- If no private declaration is present, we assume the user did + -- not intend a deferred constant declaration and the problem + -- is simply that the initializing expression is missing. + + if not Has_Private_Declaration (Etype (Id)) then + + -- We assume that the user did not intend a deferred constant + -- declaration, and the expression is just missing. + + Error_Msg_N + ("constant declaration requires initialization expression", + Parent (Id)); + + if Is_Limited_Type (Etype (Id)) then + Error_Msg_N + ("\if variable intended, remove CONSTANT from declaration", + Parent (Id)); + end if; + + -- Otherwise if a private declaration is present, then we are + -- missing the full declaration for the deferred constant. + + else + Error_Msg_N + ("missing full declaration for deferred constant (RM 7.4)", + Id); + + if Is_Limited_Type (Etype (Id)) then + Error_Msg_N + ("\if variable intended, remove CONSTANT from declaration", + Parent (Id)); + end if; + end if; + end if; + + Next_Entity (Id); + end loop; + + -- If the specification was installed as the parent of a public child + -- unit, the private declarations were not installed, and there is + -- nothing to do. + + if not In_Private_Part (P) then + return; + else + Set_In_Private_Part (P, False); + end if; + + -- Make private entities invisible and exchange full and private + -- declarations for private types. Id is now the first private entity + -- in the package. + + while Present (Id) loop + if Debug_Flag_E then + Write_Str ("unlinking private entity "); + Write_Int (Int (Id)); + Write_Eol; + end if; + + if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then + Check_Abstract_Overriding (Id); + Check_Conventions (Id); + end if; + + Set_Is_Immediately_Visible (Id, False); + + if Is_Private_Base_Type (Id) + and then Present (Full_View (Id)) + then + Full := Full_View (Id); + + -- If the partial view is not declared in the visible part of the + -- package (as is the case when it is a type derived from some + -- other private type in the private part of the current package), + -- no exchange takes place. + + if No (Parent (Id)) + or else List_Containing (Parent (Id)) + /= Visible_Declarations (Specification (Decl)) + then + goto Next_Id; + end if; + + -- The entry in the private part points to the full declaration, + -- which is currently visible. Exchange them so only the private + -- type declaration remains accessible, and link private and full + -- declaration in the opposite direction. Before the actual + -- exchange, we copy back attributes of the full view that must + -- be available to the partial view too. + + Preserve_Full_Attributes (Id, Full); + + Set_Is_Potentially_Use_Visible (Id, In_Use (P)); + + if Is_Indefinite_Subtype (Full) + and then not Is_Indefinite_Subtype (Id) + then + Error_Msg_N + ("full view of type must be definite subtype", Full); + end if; + + Priv_Elmt := First_Elmt (Private_Dependents (Id)); + + -- Swap out the subtypes and derived types of Id that were + -- compiled in this scope, or installed previously by + -- Install_Private_Declarations. + + -- Before we do the swap, we verify the presence of the Full_View + -- field which may be empty due to a swap by a previous call to + -- End_Package_Scope (e.g. from the freezing mechanism). + + while Present (Priv_Elmt) loop + Priv_Sub := Node (Priv_Elmt); + + if Present (Full_View (Priv_Sub)) then + + if Scope (Priv_Sub) = P + or else not In_Open_Scopes (Scope (Priv_Sub)) + then + Set_Is_Immediately_Visible (Priv_Sub, False); + end if; + + if Is_Visible_Dependent (Priv_Sub) then + Preserve_Full_Attributes + (Priv_Sub, Full_View (Priv_Sub)); + Replace_Elmt (Priv_Elmt, Full_View (Priv_Sub)); + Exchange_Declarations (Priv_Sub); + end if; + end if; + + Next_Elmt (Priv_Elmt); + end loop; + + -- Now restore the type itself to its private view + + Exchange_Declarations (Id); + + -- If we have installed an underlying full view for a type derived + -- from a private type in a child unit, restore the proper views + -- of private and full view. See corresponding code in + -- Install_Private_Declarations. + + -- After the exchange, Full denotes the private type in the + -- visible part of the package. + + if Is_Private_Base_Type (Full) + and then Present (Full_View (Full)) + and then Present (Underlying_Full_View (Full)) + and then In_Package_Body (Current_Scope) + then + Set_Full_View (Full, Underlying_Full_View (Full)); + Set_Underlying_Full_View (Full, Empty); + end if; + + elsif Ekind (Id) = E_Incomplete_Type + and then Comes_From_Source (Id) + and then No (Full_View (Id)) + then + -- Mark Taft amendment types. Verify that there are no primitive + -- operations declared for the type (3.10.1(9)). + + Set_Has_Completion_In_Body (Id); + + declare + Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + Elmt := First_Elmt (Private_Dependents (Id)); + while Present (Elmt) loop + Subp := Node (Elmt); + + if Is_Overloadable (Subp) then + Error_Msg_NE + ("type& must be completed in the private part", + Parent (Subp), Id); + + -- The return type of an access_to_function cannot be a + -- Taft-amendment type. + + elsif Ekind (Subp) = E_Subprogram_Type then + if Etype (Subp) = Id + or else + (Is_Class_Wide_Type (Etype (Subp)) + and then Etype (Etype (Subp)) = Id) + then + Error_Msg_NE + ("type& must be completed in the private part", + Associated_Node_For_Itype (Subp), Id); + end if; + end if; + + Next_Elmt (Elmt); + end loop; + end; + + elsif not Is_Child_Unit (Id) + and then (not Is_Private_Type (Id) + or else No (Full_View (Id))) + then + Set_Is_Hidden (Id); + Set_Is_Potentially_Use_Visible (Id, False); + end if; + + <> + Next_Entity (Id); + end loop; + end Uninstall_Declarations; + + ------------------------ + -- Unit_Requires_Body -- + ------------------------ + + function Unit_Requires_Body (P : Entity_Id) return Boolean is + E : Entity_Id; + + begin + -- Imported entity never requires body. Right now, only subprograms can + -- be imported, but perhaps in the future we will allow import of + -- packages. + + if Is_Imported (P) then + return False; + + -- Body required if library package with pragma Elaborate_Body + + elsif Has_Pragma_Elaborate_Body (P) then + return True; + + -- Body required if subprogram + + elsif Is_Subprogram (P) or else Is_Generic_Subprogram (P) then + return True; + + -- Treat a block as requiring a body + + elsif Ekind (P) = E_Block then + return True; + + elsif Ekind (P) = E_Package + and then Nkind (Parent (P)) = N_Package_Specification + and then Present (Generic_Parent (Parent (P))) + then + declare + G_P : constant Entity_Id := Generic_Parent (Parent (P)); + begin + if Has_Pragma_Elaborate_Body (G_P) then + return True; + end if; + end; + end if; + + -- Otherwise search entity chain for entity requiring completion + + E := First_Entity (P); + while Present (E) loop + + -- Always ignore child units. Child units get added to the entity + -- list of a parent unit, but are not original entities of the + -- parent, and so do not affect whether the parent needs a body. + + if Is_Child_Unit (E) then + null; + + -- Ignore formal packages and their renamings + + elsif Ekind (E) = E_Package + and then Nkind (Original_Node (Unit_Declaration_Node (E))) = + N_Formal_Package_Declaration + then + null; + + -- Otherwise test to see if entity requires a completion. + -- Note that subprogram entities whose declaration does not come + -- from source are ignored here on the basis that we assume the + -- expander will provide an implicit completion at some point. + + elsif (Is_Overloadable (E) + and then Ekind (E) /= E_Enumeration_Literal + and then Ekind (E) /= E_Operator + and then not Is_Abstract_Subprogram (E) + and then not Has_Completion (E) + and then Comes_From_Source (Parent (E))) + + or else + (Ekind (E) = E_Package + and then E /= P + and then not Has_Completion (E) + and then Unit_Requires_Body (E)) + + or else + (Ekind (E) = E_Incomplete_Type and then No (Full_View (E))) + + or else + ((Ekind (E) = E_Task_Type or else + Ekind (E) = E_Protected_Type) + and then not Has_Completion (E)) + + or else + (Ekind (E) = E_Generic_Package and then E /= P + and then not Has_Completion (E) + and then Unit_Requires_Body (E)) + + or else + (Is_Generic_Subprogram (E) + and then not Has_Completion (E)) + + then + return True; + + -- Entity that does not require completion + + else + null; + end if; + + Next_Entity (E); + end loop; + + return False; + end Unit_Requires_Body; + +end Sem_Ch7; diff --git a/gcc/ada/sem_ch7.ads b/gcc/ada/sem_ch7.ads new file mode 100644 index 000000000..0445b2429 --- /dev/null +++ b/gcc/ada/sem_ch7.ads @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 7 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Types; use Types; + +package Sem_Ch7 is + + procedure Analyze_Package_Body (N : Node_Id); + procedure Analyze_Package_Declaration (N : Node_Id); + procedure Analyze_Package_Specification (N : Node_Id); + procedure Analyze_Private_Type_Declaration (N : Node_Id); + + procedure End_Package_Scope (P : Entity_Id); + -- Calls Uninstall_Declarations, and then pops the scope stack + + procedure Exchange_Declarations (Id : Entity_Id); + -- Exchange private and full declaration on entry/exit from a package + -- declaration or body. The semantic links of the respective nodes + -- are preserved in the exchange. + + procedure Install_Visible_Declarations (P : Entity_Id); + procedure Install_Private_Declarations (P : Entity_Id); + + -- On entrance to a package body, make declarations in package spec + -- immediately visible. + + -- When compiling the body of a package, both routines are called in + -- succession. When compiling the body of a child package, the call + -- to Install_Private_Declaration is immediate for private children, + -- but is deferred until the compilation of the private part of the + -- child for public child packages. + + function Unit_Requires_Body (P : Entity_Id) return Boolean; + -- Check if a unit requires a body. A specification requires a body + -- if it contains declarations that require completion in a body. + + procedure May_Need_Implicit_Body (E : Entity_Id); + -- If a package declaration contains tasks or RACWs and does not require + -- a body, create an implicit body at the end of the current declarative + -- part to activate those tasks or contain the bodies for the RACW + -- calling stubs. + + procedure New_Private_Type (N : Node_Id; Id : Entity_Id; Def : Node_Id); + -- Common processing for private type declarations and for formal + -- private type declarations. For private types, N and Def are the type + -- declaration node; for formal private types, Def is the formal type + -- definition. + + procedure Uninstall_Declarations (P : Entity_Id); + -- At the end of a package declaration or body, declarations in the + -- visible part are no longer immediately visible, and declarations in + -- the private part are not visible at all. For inner packages, place + -- visible entities at the end of their homonym chains. For compilation + -- units, make all entities invisible. In both cases, exchange private + -- and visible declarations to restore order of elaboration. + +end Sem_Ch7; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb new file mode 100644 index 000000000..c14c446fe --- /dev/null +++ b/gcc/ada/sem_ch8.adb @@ -0,0 +1,7828 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M . C H 8 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Fname; use Fname; +with Freeze; use Freeze; +with Impunit; use Impunit; +with Lib; use Lib; +with Lib.Load; use Lib.Load; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; +with Namet.Sp; use Namet.Sp; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Output; use Output; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Cat; use Sem_Cat; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch4; use Sem_Ch4; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch12; use Sem_Ch12; +with Sem_Disp; use Sem_Disp; +with Sem_Dist; use Sem_Dist; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sem_Type; use Sem_Type; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Sinfo.CN; use Sinfo.CN; +with Snames; use Snames; +with Style; use Style; +with Table; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +package body Sem_Ch8 is + + ------------------------------------ + -- Visibility and Name Resolution -- + ------------------------------------ + + -- This package handles name resolution and the collection of + -- interpretations for overloaded names, prior to overload resolution. + + -- Name resolution is the process that establishes a mapping between source + -- identifiers and the entities they denote at each point in the program. + -- Each entity is represented by a defining occurrence. Each identifier + -- that denotes an entity points to the corresponding defining occurrence. + -- This is the entity of the applied occurrence. Each occurrence holds + -- an index into the names table, where source identifiers are stored. + + -- Each entry in the names table for an identifier or designator uses the + -- Info pointer to hold a link to the currently visible entity that has + -- this name (see subprograms Get_Name_Entity_Id and Set_Name_Entity_Id + -- in package Sem_Util). The visibility is initialized at the beginning of + -- semantic processing to make entities in package Standard immediately + -- visible. The visibility table is used in a more subtle way when + -- compiling subunits (see below). + + -- Entities that have the same name (i.e. homonyms) are chained. In the + -- case of overloaded entities, this chain holds all the possible meanings + -- of a given identifier. The process of overload resolution uses type + -- information to select from this chain the unique meaning of a given + -- identifier. + + -- Entities are also chained in their scope, through the Next_Entity link. + -- As a consequence, the name space is organized as a sparse matrix, where + -- each row corresponds to a scope, and each column to a source identifier. + -- Open scopes, that is to say scopes currently being compiled, have their + -- corresponding rows of entities in order, innermost scope first. + + -- The scopes of packages that are mentioned in context clauses appear in + -- no particular order, interspersed among open scopes. This is because + -- in the course of analyzing the context of a compilation, a package + -- declaration is first an open scope, and subsequently an element of the + -- context. If subunits or child units are present, a parent unit may + -- appear under various guises at various times in the compilation. + + -- When the compilation of the innermost scope is complete, the entities + -- defined therein are no longer visible. If the scope is not a package + -- declaration, these entities are never visible subsequently, and can be + -- removed from visibility chains. If the scope is a package declaration, + -- its visible declarations may still be accessible. Therefore the entities + -- defined in such a scope are left on the visibility chains, and only + -- their visibility (immediately visibility or potential use-visibility) + -- is affected. + + -- The ordering of homonyms on their chain does not necessarily follow + -- the order of their corresponding scopes on the scope stack. For + -- example, if package P and the enclosing scope both contain entities + -- named E, then when compiling the package body the chain for E will + -- hold the global entity first, and the local one (corresponding to + -- the current inner scope) next. As a result, name resolution routines + -- do not assume any relative ordering of the homonym chains, either + -- for scope nesting or to order of appearance of context clauses. + + -- When compiling a child unit, entities in the parent scope are always + -- immediately visible. When compiling the body of a child unit, private + -- entities in the parent must also be made immediately visible. There + -- are separate routines to make the visible and private declarations + -- visible at various times (see package Sem_Ch7). + + -- +--------+ +-----+ + -- | In use |-------->| EU1 |--------------------------> + -- +--------+ +-----+ + -- | | + -- +--------+ +-----+ +-----+ + -- | Stand. |---------------->| ES1 |--------------->| ES2 |---> + -- +--------+ +-----+ +-----+ + -- | | + -- +---------+ | +-----+ + -- | with'ed |------------------------------>| EW2 |---> + -- +---------+ | +-----+ + -- | | + -- +--------+ +-----+ +-----+ + -- | Scope2 |---------------->| E12 |--------------->| E22 |---> + -- +--------+ +-----+ +-----+ + -- | | + -- +--------+ +-----+ +-----+ + -- | Scope1 |---------------->| E11 |--------------->| E12 |---> + -- +--------+ +-----+ +-----+ + -- ^ | | + -- | | | + -- | +---------+ | | + -- | | with'ed |-----------------------------------------> + -- | +---------+ | | + -- | | | + -- Scope stack | | + -- (innermost first) | | + -- +----------------------------+ + -- Names table => | Id1 | | | | Id2 | + -- +----------------------------+ + + -- Name resolution must deal with several syntactic forms: simple names, + -- qualified names, indexed names, and various forms of calls. + + -- Each identifier points to an entry in the names table. The resolution + -- of a simple name consists in traversing the homonym chain, starting + -- from the names table. If an entry is immediately visible, it is the one + -- designated by the identifier. If only potentially use-visible entities + -- are on the chain, we must verify that they do not hide each other. If + -- the entity we find is overloadable, we collect all other overloadable + -- entities on the chain as long as they are not hidden. + -- + -- To resolve expanded names, we must find the entity at the intersection + -- of the entity chain for the scope (the prefix) and the homonym chain + -- for the selector. In general, homonym chains will be much shorter than + -- entity chains, so it is preferable to start from the names table as + -- well. If the entity found is overloadable, we must collect all other + -- interpretations that are defined in the scope denoted by the prefix. + + -- For records, protected types, and tasks, their local entities are + -- removed from visibility chains on exit from the corresponding scope. + -- From the outside, these entities are always accessed by selected + -- notation, and the entity chain for the record type, protected type, + -- etc. is traversed sequentially in order to find the designated entity. + + -- The discriminants of a type and the operations of a protected type or + -- task are unchained on exit from the first view of the type, (such as + -- a private or incomplete type declaration, or a protected type speci- + -- fication) and re-chained when compiling the second view. + + -- In the case of operators, we do not make operators on derived types + -- explicit. As a result, the notation P."+" may denote either a user- + -- defined function with name "+", or else an implicit declaration of the + -- operator "+" in package P. The resolution of expanded names always + -- tries to resolve an operator name as such an implicitly defined entity, + -- in addition to looking for explicit declarations. + + -- All forms of names that denote entities (simple names, expanded names, + -- character literals in some cases) have a Entity attribute, which + -- identifies the entity denoted by the name. + + --------------------- + -- The Scope Stack -- + --------------------- + + -- The Scope stack keeps track of the scopes currently been compiled. + -- Every entity that contains declarations (including records) is placed + -- on the scope stack while it is being processed, and removed at the end. + -- Whenever a non-package scope is exited, the entities defined therein + -- are removed from the visibility table, so that entities in outer scopes + -- become visible (see previous description). On entry to Sem, the scope + -- stack only contains the package Standard. As usual, subunits complicate + -- this picture ever so slightly. + + -- The Rtsfind mechanism can force a call to Semantics while another + -- compilation is in progress. The unit retrieved by Rtsfind must be + -- compiled in its own context, and has no access to the visibility of + -- the unit currently being compiled. The procedures Save_Scope_Stack and + -- Restore_Scope_Stack make entities in current open scopes invisible + -- before compiling the retrieved unit, and restore the compilation + -- environment afterwards. + + ------------------------ + -- Compiling subunits -- + ------------------------ + + -- Subunits must be compiled in the environment of the corresponding stub, + -- that is to say with the same visibility into the parent (and its + -- context) that is available at the point of the stub declaration, but + -- with the additional visibility provided by the context clause of the + -- subunit itself. As a result, compilation of a subunit forces compilation + -- of the parent (see description in lib-). At the point of the stub + -- declaration, Analyze is called recursively to compile the proper body of + -- the subunit, but without reinitializing the names table, nor the scope + -- stack (i.e. standard is not pushed on the stack). In this fashion the + -- context of the subunit is added to the context of the parent, and the + -- subunit is compiled in the correct environment. Note that in the course + -- of processing the context of a subunit, Standard will appear twice on + -- the scope stack: once for the parent of the subunit, and once for the + -- unit in the context clause being compiled. However, the two sets of + -- entities are not linked by homonym chains, so that the compilation of + -- any context unit happens in a fresh visibility environment. + + ------------------------------- + -- Processing of USE Clauses -- + ------------------------------- + + -- Every defining occurrence has a flag indicating if it is potentially use + -- visible. Resolution of simple names examines this flag. The processing + -- of use clauses consists in setting this flag on all visible entities + -- defined in the corresponding package. On exit from the scope of the use + -- clause, the corresponding flag must be reset. However, a package may + -- appear in several nested use clauses (pathological but legal, alas!) + -- which forces us to use a slightly more involved scheme: + + -- a) The defining occurrence for a package holds a flag -In_Use- to + -- indicate that it is currently in the scope of a use clause. If a + -- redundant use clause is encountered, then the corresponding occurrence + -- of the package name is flagged -Redundant_Use-. + + -- b) On exit from a scope, the use clauses in its declarative part are + -- scanned. The visibility flag is reset in all entities declared in + -- package named in a use clause, as long as the package is not flagged + -- as being in a redundant use clause (in which case the outer use + -- clause is still in effect, and the direct visibility of its entities + -- must be retained). + + -- Note that entities are not removed from their homonym chains on exit + -- from the package specification. A subsequent use clause does not need + -- to rechain the visible entities, but only to establish their direct + -- visibility. + + ----------------------------------- + -- Handling private declarations -- + ----------------------------------- + + -- The principle that each entity has a single defining occurrence clashes + -- with the presence of two separate definitions for private types: the + -- first is the private type declaration, and second is the full type + -- declaration. It is important that all references to the type point to + -- the same defining occurrence, namely the first one. To enforce the two + -- separate views of the entity, the corresponding information is swapped + -- between the two declarations. Outside of the package, the defining + -- occurrence only contains the private declaration information, while in + -- the private part and the body of the package the defining occurrence + -- contains the full declaration. To simplify the swap, the defining + -- occurrence that currently holds the private declaration points to the + -- full declaration. During semantic processing the defining occurrence + -- also points to a list of private dependents, that is to say access types + -- or composite types whose designated types or component types are + -- subtypes or derived types of the private type in question. After the + -- full declaration has been seen, the private dependents are updated to + -- indicate that they have full definitions. + + ------------------------------------ + -- Handling of Undefined Messages -- + ------------------------------------ + + -- In normal mode, only the first use of an undefined identifier generates + -- a message. The table Urefs is used to record error messages that have + -- been issued so that second and subsequent ones do not generate further + -- messages. However, the second reference causes text to be added to the + -- original undefined message noting "(more references follow)". The + -- full error list option (-gnatf) forces messages to be generated for + -- every reference and disconnects the use of this table. + + type Uref_Entry is record + Node : Node_Id; + -- Node for identifier for which original message was posted. The + -- Chars field of this identifier is used to detect later references + -- to the same identifier. + + Err : Error_Msg_Id; + -- Records error message Id of original undefined message. Reset to + -- No_Error_Msg after the second occurrence, where it is used to add + -- text to the original message as described above. + + Nvis : Boolean; + -- Set if the message is not visible rather than undefined + + Loc : Source_Ptr; + -- Records location of error message. Used to make sure that we do + -- not consider a, b : undefined as two separate instances, which + -- would otherwise happen, since the parser converts this sequence + -- to a : undefined; b : undefined. + + end record; + + package Urefs is new Table.Table ( + Table_Component_Type => Uref_Entry, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Urefs"); + + Candidate_Renaming : Entity_Id; + -- Holds a candidate interpretation that appears in a subprogram renaming + -- declaration and does not match the given specification, but matches at + -- least on the first formal. Allows better error message when given + -- specification omits defaulted parameters, a common error. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Analyze_Generic_Renaming + (N : Node_Id; + K : Entity_Kind); + -- Common processing for all three kinds of generic renaming declarations. + -- Enter new name and indicate that it renames the generic unit. + + procedure Analyze_Renamed_Character + (N : Node_Id; + New_S : Entity_Id; + Is_Body : Boolean); + -- Renamed entity is given by a character literal, which must belong + -- to the return type of the new entity. Is_Body indicates whether the + -- declaration is a renaming_as_body. If the original declaration has + -- already been frozen (because of an intervening body, e.g.) the body of + -- the function must be built now. The same applies to the following + -- various renaming procedures. + + procedure Analyze_Renamed_Dereference + (N : Node_Id; + New_S : Entity_Id; + Is_Body : Boolean); + -- Renamed entity is given by an explicit dereference. Prefix must be a + -- conformant access_to_subprogram type. + + procedure Analyze_Renamed_Entry + (N : Node_Id; + New_S : Entity_Id; + Is_Body : Boolean); + -- If the renamed entity in a subprogram renaming is an entry or protected + -- subprogram, build a body for the new entity whose only statement is a + -- call to the renamed entity. + + procedure Analyze_Renamed_Family_Member + (N : Node_Id; + New_S : Entity_Id; + Is_Body : Boolean); + -- Used when the renamed entity is an indexed component. The prefix must + -- denote an entry family. + + procedure Analyze_Renamed_Primitive_Operation + (N : Node_Id; + New_S : Entity_Id; + Is_Body : Boolean); + -- If the renamed entity in a subprogram renaming is a primitive operation + -- or a class-wide operation in prefix form, save the target object, which + -- must be added to the list of actuals in any subsequent call. + + function Applicable_Use (Pack_Name : Node_Id) return Boolean; + -- Common code to Use_One_Package and Set_Use, to determine whether use + -- clause must be processed. Pack_Name is an entity name that references + -- the package in question. + + procedure Attribute_Renaming (N : Node_Id); + -- Analyze renaming of attribute as subprogram. The renaming declaration N + -- is rewritten as a subprogram body that returns the attribute reference + -- applied to the formals of the function. + + procedure Set_Entity_Or_Discriminal (N : Node_Id; E : Entity_Id); + -- Set Entity, with style check if need be. For a discriminant reference, + -- replace by the corresponding discriminal, i.e. the parameter of the + -- initialization procedure that corresponds to the discriminant. + + procedure Check_Frozen_Renaming (N : Node_Id; Subp : Entity_Id); + -- A renaming_as_body may occur after the entity of the original decla- + -- ration has been frozen. In that case, the body of the new entity must + -- be built now, because the usual mechanism of building the renamed + -- body at the point of freezing will not work. Subp is the subprogram + -- for which N provides the Renaming_As_Body. + + procedure Check_In_Previous_With_Clause + (N : Node_Id; + Nam : Node_Id); + -- N is a use_package clause and Nam the package name, or N is a use_type + -- clause and Nam is the prefix of the type name. In either case, verify + -- that the package is visible at that point in the context: either it + -- appears in a previous with_clause, or because it is a fully qualified + -- name and the root ancestor appears in a previous with_clause. + + procedure Check_Library_Unit_Renaming (N : Node_Id; Old_E : Entity_Id); + -- Verify that the entity in a renaming declaration that is a library unit + -- is itself a library unit and not a nested unit or subunit. Also check + -- that if the renaming is a child unit of a generic parent, then the + -- renamed unit must also be a child unit of that parent. Finally, verify + -- that a renamed generic unit is not an implicit child declared within + -- an instance of the parent. + + procedure Chain_Use_Clause (N : Node_Id); + -- Chain use clause onto list of uses clauses headed by First_Use_Clause in + -- the proper scope table entry. This is usually the current scope, but it + -- will be an inner scope when installing the use clauses of the private + -- declarations of a parent unit prior to compiling the private part of a + -- child unit. This chain is traversed when installing/removing use clauses + -- when compiling a subunit or instantiating a generic body on the fly, + -- when it is necessary to save and restore full environments. + + function Has_Implicit_Character_Literal (N : Node_Id) return Boolean; + -- Find a type derived from Character or Wide_Character in the prefix of N. + -- Used to resolved qualified names whose selector is a character literal. + + function Has_Private_With (E : Entity_Id) return Boolean; + -- Ada 2005 (AI-262): Determines if the current compilation unit has a + -- private with on E. + + procedure Find_Expanded_Name (N : Node_Id); + -- The input is a selected component is known to be expanded name. Verify + -- legality of selector given the scope denoted by prefix, and change node + -- N into a expanded name with a properly set Entity field. + + function Find_Renamed_Entity + (N : Node_Id; + Nam : Node_Id; + New_S : Entity_Id; + Is_Actual : Boolean := False) return Entity_Id; + -- Find the renamed entity that corresponds to the given parameter profile + -- in a subprogram renaming declaration. The renamed entity may be an + -- operator, a subprogram, an entry, or a protected operation. Is_Actual + -- indicates that the renaming is the one generated for an actual subpro- + -- gram in an instance, for which special visibility checks apply. + + function Has_Implicit_Operator (N : Node_Id) return Boolean; + -- N is an expanded name whose selector is an operator name (e.g. P."+"). + -- declarative part contains an implicit declaration of an operator if it + -- has a declaration of a type to which one of the predefined operators + -- apply. The existence of this routine is an implementation artifact. A + -- more straightforward but more space-consuming choice would be to make + -- all inherited operators explicit in the symbol table. + + procedure Inherit_Renamed_Profile (New_S : Entity_Id; Old_S : Entity_Id); + -- A subprogram defined by a renaming declaration inherits the parameter + -- profile of the renamed entity. The subtypes given in the subprogram + -- specification are discarded and replaced with those of the renamed + -- subprogram, which are then used to recheck the default values. + + function Is_Appropriate_For_Record (T : Entity_Id) return Boolean; + -- Prefix is appropriate for record if it is of a record type, or an access + -- to such. + + function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean; + -- True if it is of a task type, a protected type, or else an access to one + -- of these types. + + procedure Note_Redundant_Use (Clause : Node_Id); + -- Mark the name in a use clause as redundant if the corresponding entity + -- is already use-visible. Emit a warning if the use clause comes from + -- source and the proper warnings are enabled. + + procedure Premature_Usage (N : Node_Id); + -- Diagnose usage of an entity before it is visible + + procedure Use_One_Package (P : Entity_Id; N : Node_Id); + -- Make visible entities declared in package P potentially use-visible + -- in the current context. Also used in the analysis of subunits, when + -- re-installing use clauses of parent units. N is the use_clause that + -- names P (and possibly other packages). + + procedure Use_One_Type (Id : Node_Id); + -- Id is the subtype mark from a use type clause. This procedure makes + -- the primitive operators of the type potentially use-visible. + + procedure Write_Info; + -- Write debugging information on entities declared in current scope + + -------------------------------- + -- Analyze_Exception_Renaming -- + -------------------------------- + + -- The language only allows a single identifier, but the tree holds an + -- identifier list. The parser has already issued an error message if + -- there is more than one element in the list. + + procedure Analyze_Exception_Renaming (N : Node_Id) is + Id : constant Node_Id := Defining_Identifier (N); + Nam : constant Node_Id := Name (N); + + begin + Enter_Name (Id); + Analyze (Nam); + + Set_Ekind (Id, E_Exception); + Set_Exception_Code (Id, Uint_0); + Set_Etype (Id, Standard_Exception_Type); + Set_Is_Pure (Id, Is_Pure (Current_Scope)); + + if not Is_Entity_Name (Nam) or else + Ekind (Entity (Nam)) /= E_Exception + then + Error_Msg_N ("invalid exception name in renaming", Nam); + else + if Present (Renamed_Object (Entity (Nam))) then + Set_Renamed_Object (Id, Renamed_Object (Entity (Nam))); + else + Set_Renamed_Object (Id, Entity (Nam)); + end if; + end if; + end Analyze_Exception_Renaming; + + --------------------------- + -- Analyze_Expanded_Name -- + --------------------------- + + procedure Analyze_Expanded_Name (N : Node_Id) is + begin + -- If the entity pointer is already set, this is an internal node, or a + -- node that is analyzed more than once, after a tree modification. In + -- such a case there is no resolution to perform, just set the type. For + -- completeness, analyze prefix as well. + + if Present (Entity (N)) then + if Is_Type (Entity (N)) then + Set_Etype (N, Entity (N)); + else + Set_Etype (N, Etype (Entity (N))); + end if; + + Analyze (Prefix (N)); + return; + else + Find_Expanded_Name (N); + end if; + end Analyze_Expanded_Name; + + --------------------------------------- + -- Analyze_Generic_Function_Renaming -- + --------------------------------------- + + procedure Analyze_Generic_Function_Renaming (N : Node_Id) is + begin + Analyze_Generic_Renaming (N, E_Generic_Function); + end Analyze_Generic_Function_Renaming; + + -------------------------------------- + -- Analyze_Generic_Package_Renaming -- + -------------------------------------- + + procedure Analyze_Generic_Package_Renaming (N : Node_Id) is + begin + -- Apply the Text_IO Kludge here, since we may be renaming one of the + -- subpackages of Text_IO, then join common routine. + + Text_IO_Kludge (Name (N)); + + Analyze_Generic_Renaming (N, E_Generic_Package); + end Analyze_Generic_Package_Renaming; + + ---------------------------------------- + -- Analyze_Generic_Procedure_Renaming -- + ---------------------------------------- + + procedure Analyze_Generic_Procedure_Renaming (N : Node_Id) is + begin + Analyze_Generic_Renaming (N, E_Generic_Procedure); + end Analyze_Generic_Procedure_Renaming; + + ------------------------------ + -- Analyze_Generic_Renaming -- + ------------------------------ + + procedure Analyze_Generic_Renaming + (N : Node_Id; + K : Entity_Kind) + is + New_P : constant Entity_Id := Defining_Entity (N); + Old_P : Entity_Id; + Inst : Boolean := False; -- prevent junk warning + + begin + if Name (N) = Error then + return; + end if; + + Generate_Definition (New_P); + + if Current_Scope /= Standard_Standard then + Set_Is_Pure (New_P, Is_Pure (Current_Scope)); + end if; + + if Nkind (Name (N)) = N_Selected_Component then + Check_Generic_Child_Unit (Name (N), Inst); + else + Analyze (Name (N)); + end if; + + if not Is_Entity_Name (Name (N)) then + Error_Msg_N ("expect entity name in renaming declaration", Name (N)); + Old_P := Any_Id; + else + Old_P := Entity (Name (N)); + end if; + + Enter_Name (New_P); + Set_Ekind (New_P, K); + + if Etype (Old_P) = Any_Type then + null; + + elsif Ekind (Old_P) /= K then + Error_Msg_N ("invalid generic unit name", Name (N)); + + else + if Present (Renamed_Object (Old_P)) then + Set_Renamed_Object (New_P, Renamed_Object (Old_P)); + else + Set_Renamed_Object (New_P, Old_P); + end if; + + Set_Is_Pure (New_P, Is_Pure (Old_P)); + Set_Is_Preelaborated (New_P, Is_Preelaborated (Old_P)); + + Set_Etype (New_P, Etype (Old_P)); + Set_Has_Completion (New_P); + + if In_Open_Scopes (Old_P) then + Error_Msg_N ("within its scope, generic denotes its instance", N); + end if; + + Check_Library_Unit_Renaming (N, Old_P); + end if; + end Analyze_Generic_Renaming; + + ----------------------------- + -- Analyze_Object_Renaming -- + ----------------------------- + + procedure Analyze_Object_Renaming (N : Node_Id) is + Id : constant Entity_Id := Defining_Identifier (N); + Dec : Node_Id; + Nam : constant Node_Id := Name (N); + T : Entity_Id; + T2 : Entity_Id; + + function In_Generic_Scope (E : Entity_Id) return Boolean; + -- Determine whether entity E is inside a generic cope + + ---------------------- + -- In_Generic_Scope -- + ---------------------- + + function In_Generic_Scope (E : Entity_Id) return Boolean is + S : Entity_Id; + + begin + S := Scope (E); + while Present (S) and then S /= Standard_Standard loop + if Is_Generic_Unit (S) then + return True; + end if; + + S := Scope (S); + end loop; + + return False; + end In_Generic_Scope; + + -- Start of processing for Analyze_Object_Renaming + + begin + if Nam = Error then + return; + end if; + + Set_Is_Pure (Id, Is_Pure (Current_Scope)); + Enter_Name (Id); + + -- The renaming of a component that depends on a discriminant requires + -- an actual subtype, because in subsequent use of the object Gigi will + -- be unable to locate the actual bounds. This explicit step is required + -- when the renaming is generated in removing side effects of an + -- already-analyzed expression. + + if Nkind (Nam) = N_Selected_Component + and then Analyzed (Nam) + then + T := Etype (Nam); + Dec := Build_Actual_Subtype_Of_Component (Etype (Nam), Nam); + + if Present (Dec) then + Insert_Action (N, Dec); + T := Defining_Identifier (Dec); + Set_Etype (Nam, T); + end if; + + -- Complete analysis of the subtype mark in any case, for ASIS use + + if Present (Subtype_Mark (N)) then + Find_Type (Subtype_Mark (N)); + end if; + + elsif Present (Subtype_Mark (N)) then + Find_Type (Subtype_Mark (N)); + T := Entity (Subtype_Mark (N)); + Analyze (Nam); + + if Nkind (Nam) = N_Type_Conversion + and then not Is_Tagged_Type (T) + then + Error_Msg_N + ("renaming of conversion only allowed for tagged types", Nam); + end if; + + Resolve (Nam, T); + + -- Check that a class-wide object is not being renamed as an object + -- of a specific type. The test for access types is needed to exclude + -- cases where the renamed object is a dynamically tagged access + -- result, such as occurs in certain expansions. + + if Is_Tagged_Type (T) then + Check_Dynamically_Tagged_Expression + (Expr => Nam, + Typ => T, + Related_Nod => N); + end if; + + -- Ada 2005 (AI-230/AI-254): Access renaming + + else pragma Assert (Present (Access_Definition (N))); + T := Access_Definition + (Related_Nod => N, + N => Access_Definition (N)); + + Analyze (Nam); + + -- Ada 2005 AI05-105: if the declaration has an anonymous access + -- type, the renamed object must also have an anonymous type, and + -- this is a name resolution rule. This was implicit in the last + -- part of the first sentence in 8.5.1.(3/2), and is made explicit + -- by this recent AI. + + if not Is_Overloaded (Nam) then + if Ekind (Etype (Nam)) /= Ekind (T) then + Error_Msg_N + ("expect anonymous access type in object renaming", N); + end if; + + else + declare + I : Interp_Index; + It : Interp; + Typ : Entity_Id := Empty; + Seen : Boolean := False; + + begin + Get_First_Interp (Nam, I, It); + while Present (It.Typ) loop + + -- Renaming is ambiguous if more than one candidate + -- interpretation is type-conformant with the context. + + if Ekind (It.Typ) = Ekind (T) then + if Ekind (T) = E_Anonymous_Access_Subprogram_Type + and then + Type_Conformant + (Designated_Type (T), Designated_Type (It.Typ)) + then + if not Seen then + Seen := True; + else + Error_Msg_N + ("ambiguous expression in renaming", Nam); + end if; + + elsif Ekind (T) = E_Anonymous_Access_Type + and then + Covers (Designated_Type (T), Designated_Type (It.Typ)) + then + if not Seen then + Seen := True; + else + Error_Msg_N + ("ambiguous expression in renaming", Nam); + end if; + end if; + + if Covers (T, It.Typ) then + Typ := It.Typ; + Set_Etype (Nam, Typ); + Set_Is_Overloaded (Nam, False); + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + end; + end if; + + Resolve (Nam, T); + + -- Ada 2005 (AI-231): "In the case where the type is defined by an + -- access_definition, the renamed entity shall be of an access-to- + -- constant type if and only if the access_definition defines an + -- access-to-constant type" ARM 8.5.1(4) + + if Constant_Present (Access_Definition (N)) + and then not Is_Access_Constant (Etype (Nam)) + then + Error_Msg_N ("(Ada 2005): the renamed object is not " + & "access-to-constant (RM 8.5.1(6))", N); + + elsif not Constant_Present (Access_Definition (N)) + and then Is_Access_Constant (Etype (Nam)) + then + Error_Msg_N ("(Ada 2005): the renamed object is not " + & "access-to-variable (RM 8.5.1(6))", N); + end if; + + if Is_Access_Subprogram_Type (Etype (Nam)) then + Check_Subtype_Conformant + (Designated_Type (T), Designated_Type (Etype (Nam))); + + elsif not Subtypes_Statically_Match + (Designated_Type (T), Designated_Type (Etype (Nam))) + then + Error_Msg_N + ("subtype of renamed object does not statically match", N); + end if; + end if; + + -- Special processing for renaming function return object. Some errors + -- and warnings are produced only for calls that come from source. + + if Nkind (Nam) = N_Function_Call then + case Ada_Version is + + -- Usage is illegal in Ada 83 + + when Ada_83 => + if Comes_From_Source (Nam) then + Error_Msg_N + ("(Ada 83) cannot rename function return object", Nam); + end if; + + -- In Ada 95, warn for odd case of renaming parameterless function + -- call if this is not a limited type (where this is useful). + + when others => + if Warn_On_Object_Renames_Function + and then No (Parameter_Associations (Nam)) + and then not Is_Limited_Type (Etype (Nam)) + and then Comes_From_Source (Nam) + then + Error_Msg_N + ("?renaming function result object is suspicious", Nam); + Error_Msg_NE + ("\?function & will be called only once", Nam, + Entity (Name (Nam))); + Error_Msg_N -- CODEFIX + ("\?suggest using an initialized constant object instead", + Nam); + end if; + + -- If the function call returns an unconstrained type, we must + -- build a constrained subtype for the new entity, in a way + -- similar to what is done for an object declaration with an + -- unconstrained nominal type. + + if Is_Composite_Type (Etype (Nam)) + and then not Is_Constrained (Etype (Nam)) + and then not Has_Unknown_Discriminants (Etype (Nam)) + and then Expander_Active + then + declare + Loc : constant Source_Ptr := Sloc (N); + Subt : constant Entity_Id := Make_Temporary (Loc, 'T'); + begin + Remove_Side_Effects (Nam); + Insert_Action (N, + Make_Subtype_Declaration (Loc, + Defining_Identifier => Subt, + Subtype_Indication => + Make_Subtype_From_Expr (Nam, Etype (Nam)))); + Rewrite (Subtype_Mark (N), New_Occurrence_Of (Subt, Loc)); + Set_Etype (Nam, Subt); + end; + end if; + end case; + end if; + + -- An object renaming requires an exact match of the type. Class-wide + -- matching is not allowed. + + if Is_Class_Wide_Type (T) + and then Base_Type (Etype (Nam)) /= Base_Type (T) + then + Wrong_Type (Nam, T); + end if; + + T2 := Etype (Nam); + + -- (Ada 2005: AI-326): Handle wrong use of incomplete type + + if Nkind (Nam) = N_Explicit_Dereference + and then Ekind (Etype (T2)) = E_Incomplete_Type + then + Error_Msg_NE ("invalid use of incomplete type&", Id, T2); + return; + + elsif Ekind (Etype (T)) = E_Incomplete_Type then + Error_Msg_NE ("invalid use of incomplete type&", Id, T); + return; + end if; + + -- Ada 2005 (AI-327) + + if Ada_Version >= Ada_2005 + and then Nkind (Nam) = N_Attribute_Reference + and then Attribute_Name (Nam) = Name_Priority + then + null; + + elsif Ada_Version >= Ada_2005 + and then Nkind (Nam) in N_Has_Entity + then + declare + Nam_Decl : Node_Id; + Nam_Ent : Entity_Id; + + begin + if Nkind (Nam) = N_Attribute_Reference then + Nam_Ent := Entity (Prefix (Nam)); + else + Nam_Ent := Entity (Nam); + end if; + + Nam_Decl := Parent (Nam_Ent); + + if Has_Null_Exclusion (N) + and then not Has_Null_Exclusion (Nam_Decl) + then + -- Ada 2005 (AI-423): If the object name denotes a generic + -- formal object of a generic unit G, and the object renaming + -- declaration occurs within the body of G or within the body + -- of a generic unit declared within the declarative region + -- of G, then the declaration of the formal object of G must + -- have a null exclusion or a null-excluding subtype. + + if Is_Formal_Object (Nam_Ent) + and then In_Generic_Scope (Id) + then + if not Can_Never_Be_Null (Etype (Nam_Ent)) then + Error_Msg_N + ("renamed formal does not exclude `NULL` " + & "(RM 8.5.1(4.6/2))", N); + + elsif In_Package_Body (Scope (Id)) then + Error_Msg_N + ("formal object does not have a null exclusion" + & "(RM 8.5.1(4.6/2))", N); + end if; + + -- Ada 2005 (AI-423): Otherwise, the subtype of the object name + -- shall exclude null. + + elsif not Can_Never_Be_Null (Etype (Nam_Ent)) then + Error_Msg_N + ("renamed object does not exclude `NULL` " + & "(RM 8.5.1(4.6/2))", N); + + -- An instance is illegal if it contains a renaming that + -- excludes null, and the actual does not. The renaming + -- declaration has already indicated that the declaration + -- of the renamed actual in the instance will raise + -- constraint_error. + + elsif Nkind (Nam_Decl) = N_Object_Declaration + and then In_Instance + and then Present + (Corresponding_Generic_Association (Nam_Decl)) + and then Nkind (Expression (Nam_Decl)) + = N_Raise_Constraint_Error + then + Error_Msg_N + ("renamed actual does not exclude `NULL` " + & "(RM 8.5.1(4.6/2))", N); + + -- Finally, if there is a null exclusion, the subtype mark + -- must not be null-excluding. + + elsif No (Access_Definition (N)) + and then Can_Never_Be_Null (T) + then + Error_Msg_NE + ("`NOT NULL` not allowed (& already excludes null)", + N, T); + + end if; + + elsif Can_Never_Be_Null (T) + and then not Can_Never_Be_Null (Etype (Nam_Ent)) + then + Error_Msg_N + ("renamed object does not exclude `NULL` " + & "(RM 8.5.1(4.6/2))", N); + + elsif Has_Null_Exclusion (N) + and then No (Access_Definition (N)) + and then Can_Never_Be_Null (T) + then + Error_Msg_NE + ("`NOT NULL` not allowed (& already excludes null)", N, T); + end if; + end; + end if; + + Set_Ekind (Id, E_Variable); + Init_Size_Align (Id); + + if T = Any_Type or else Etype (Nam) = Any_Type then + return; + + -- Verify that the renamed entity is an object or a function call. It + -- may have been rewritten in several ways. + + elsif Is_Object_Reference (Nam) then + if Comes_From_Source (N) + and then Is_Dependent_Component_Of_Mutable_Object (Nam) + then + Error_Msg_N + ("illegal renaming of discriminant-dependent component", Nam); + end if; + + -- A static function call may have been folded into a literal + + elsif Nkind (Original_Node (Nam)) = N_Function_Call + + -- When expansion is disabled, attribute reference is not + -- rewritten as function call. Otherwise it may be rewritten + -- as a conversion, so check original node. + + or else (Nkind (Original_Node (Nam)) = N_Attribute_Reference + and then Is_Function_Attribute_Name + (Attribute_Name (Original_Node (Nam)))) + + -- Weird but legal, equivalent to renaming a function call. + -- Illegal if the literal is the result of constant-folding an + -- attribute reference that is not a function. + + or else (Is_Entity_Name (Nam) + and then Ekind (Entity (Nam)) = E_Enumeration_Literal + and then + Nkind (Original_Node (Nam)) /= N_Attribute_Reference) + + or else (Nkind (Nam) = N_Type_Conversion + and then Is_Tagged_Type (Entity (Subtype_Mark (Nam)))) + then + null; + + elsif Nkind (Nam) = N_Type_Conversion then + Error_Msg_N + ("renaming of conversion only allowed for tagged types", Nam); + + -- Ada 2005 (AI-327) + + elsif Ada_Version >= Ada_2005 + and then Nkind (Nam) = N_Attribute_Reference + and then Attribute_Name (Nam) = Name_Priority + then + null; + + -- Allow internally generated x'Reference expression + + elsif Nkind (Nam) = N_Reference then + null; + + else + Error_Msg_N ("expect object name in renaming", Nam); + end if; + + Set_Etype (Id, T2); + + if not Is_Variable (Nam) then + Set_Ekind (Id, E_Constant); + Set_Never_Set_In_Source (Id, True); + Set_Is_True_Constant (Id, True); + end if; + + Set_Renamed_Object (Id, Nam); + end Analyze_Object_Renaming; + + ------------------------------ + -- Analyze_Package_Renaming -- + ------------------------------ + + procedure Analyze_Package_Renaming (N : Node_Id) is + New_P : constant Entity_Id := Defining_Entity (N); + Old_P : Entity_Id; + Spec : Node_Id; + + begin + if Name (N) = Error then + return; + end if; + + -- Apply Text_IO kludge here since we may be renaming a child of Text_IO + + Text_IO_Kludge (Name (N)); + + if Current_Scope /= Standard_Standard then + Set_Is_Pure (New_P, Is_Pure (Current_Scope)); + end if; + + Enter_Name (New_P); + Analyze (Name (N)); + + if Is_Entity_Name (Name (N)) then + Old_P := Entity (Name (N)); + else + Old_P := Any_Id; + end if; + + if Etype (Old_P) = Any_Type then + Error_Msg_N ("expect package name in renaming", Name (N)); + + elsif Ekind (Old_P) /= E_Package + and then not (Ekind (Old_P) = E_Generic_Package + and then In_Open_Scopes (Old_P)) + then + if Ekind (Old_P) = E_Generic_Package then + Error_Msg_N + ("generic package cannot be renamed as a package", Name (N)); + else + Error_Msg_Sloc := Sloc (Old_P); + Error_Msg_NE + ("expect package name in renaming, found& declared#", + Name (N), Old_P); + end if; + + -- Set basic attributes to minimize cascaded errors + + Set_Ekind (New_P, E_Package); + Set_Etype (New_P, Standard_Void_Type); + + -- Here for OK package renaming + + else + -- Entities in the old package are accessible through the renaming + -- entity. The simplest implementation is to have both packages share + -- the entity list. + + Set_Ekind (New_P, E_Package); + Set_Etype (New_P, Standard_Void_Type); + + if Present (Renamed_Object (Old_P)) then + Set_Renamed_Object (New_P, Renamed_Object (Old_P)); + else + Set_Renamed_Object (New_P, Old_P); + end if; + + Set_Has_Completion (New_P); + + Set_First_Entity (New_P, First_Entity (Old_P)); + Set_Last_Entity (New_P, Last_Entity (Old_P)); + Set_First_Private_Entity (New_P, First_Private_Entity (Old_P)); + Check_Library_Unit_Renaming (N, Old_P); + Generate_Reference (Old_P, Name (N)); + + -- If the renaming is in the visible part of a package, then we set + -- Renamed_In_Spec for the renamed package, to prevent giving + -- warnings about no entities referenced. Such a warning would be + -- overenthusiastic, since clients can see entities in the renamed + -- package via the visible package renaming. + + declare + Ent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); + begin + if Ekind (Ent) = E_Package + and then not In_Private_Part (Ent) + and then In_Extended_Main_Source_Unit (N) + and then Ekind (Old_P) = E_Package + then + Set_Renamed_In_Spec (Old_P); + end if; + end; + + -- If this is the renaming declaration of a package instantiation + -- within itself, it is the declaration that ends the list of actuals + -- for the instantiation. At this point, the subtypes that rename + -- the actuals are flagged as generic, to avoid spurious ambiguities + -- if the actuals for two distinct formals happen to coincide. If + -- the actual is a private type, the subtype has a private completion + -- that is flagged in the same fashion. + + -- Resolution is identical to what is was in the original generic. + -- On exit from the generic instance, these are turned into regular + -- subtypes again, so they are compatible with types in their class. + + if not Is_Generic_Instance (Old_P) then + return; + else + Spec := Specification (Unit_Declaration_Node (Old_P)); + end if; + + if Nkind (Spec) = N_Package_Specification + and then Present (Generic_Parent (Spec)) + and then Old_P = Current_Scope + and then Chars (New_P) = Chars (Generic_Parent (Spec)) + then + declare + E : Entity_Id; + + begin + E := First_Entity (Old_P); + while Present (E) + and then E /= New_P + loop + if Is_Type (E) + and then Nkind (Parent (E)) = N_Subtype_Declaration + then + Set_Is_Generic_Actual_Type (E); + + if Is_Private_Type (E) + and then Present (Full_View (E)) + then + Set_Is_Generic_Actual_Type (Full_View (E)); + end if; + end if; + + Next_Entity (E); + end loop; + end; + end if; + end if; + end Analyze_Package_Renaming; + + ------------------------------- + -- Analyze_Renamed_Character -- + ------------------------------- + + procedure Analyze_Renamed_Character + (N : Node_Id; + New_S : Entity_Id; + Is_Body : Boolean) + is + C : constant Node_Id := Name (N); + + begin + if Ekind (New_S) = E_Function then + Resolve (C, Etype (New_S)); + + if Is_Body then + Check_Frozen_Renaming (N, New_S); + end if; + + else + Error_Msg_N ("character literal can only be renamed as function", N); + end if; + end Analyze_Renamed_Character; + + --------------------------------- + -- Analyze_Renamed_Dereference -- + --------------------------------- + + procedure Analyze_Renamed_Dereference + (N : Node_Id; + New_S : Entity_Id; + Is_Body : Boolean) + is + Nam : constant Node_Id := Name (N); + P : constant Node_Id := Prefix (Nam); + Typ : Entity_Id; + Ind : Interp_Index; + It : Interp; + + begin + if not Is_Overloaded (P) then + if Ekind (Etype (Nam)) /= E_Subprogram_Type + or else not Type_Conformant (Etype (Nam), New_S) + then + Error_Msg_N ("designated type does not match specification", P); + else + Resolve (P); + end if; + + return; + + else + Typ := Any_Type; + Get_First_Interp (Nam, Ind, It); + + while Present (It.Nam) loop + + if Ekind (It.Nam) = E_Subprogram_Type + and then Type_Conformant (It.Nam, New_S) + then + if Typ /= Any_Id then + Error_Msg_N ("ambiguous renaming", P); + return; + else + Typ := It.Nam; + end if; + end if; + + Get_Next_Interp (Ind, It); + end loop; + + if Typ = Any_Type then + Error_Msg_N ("designated type does not match specification", P); + else + Resolve (N, Typ); + + if Is_Body then + Check_Frozen_Renaming (N, New_S); + end if; + end if; + end if; + end Analyze_Renamed_Dereference; + + --------------------------- + -- Analyze_Renamed_Entry -- + --------------------------- + + procedure Analyze_Renamed_Entry + (N : Node_Id; + New_S : Entity_Id; + Is_Body : Boolean) + is + Nam : constant Node_Id := Name (N); + Sel : constant Node_Id := Selector_Name (Nam); + Old_S : Entity_Id; + + begin + if Entity (Sel) = Any_Id then + + -- Selector is undefined on prefix. Error emitted already + + Set_Has_Completion (New_S); + return; + end if; + + -- Otherwise find renamed entity and build body of New_S as a call to it + + Old_S := Find_Renamed_Entity (N, Selector_Name (Nam), New_S); + + if Old_S = Any_Id then + Error_Msg_N (" no subprogram or entry matches specification", N); + else + if Is_Body then + Check_Subtype_Conformant (New_S, Old_S, N); + Generate_Reference (New_S, Defining_Entity (N), 'b'); + Style.Check_Identifier (Defining_Entity (N), New_S); + + else + -- Only mode conformance required for a renaming_as_declaration + + Check_Mode_Conformant (New_S, Old_S, N); + end if; + + Inherit_Renamed_Profile (New_S, Old_S); + + -- The prefix can be an arbitrary expression that yields a task type, + -- so it must be resolved. + + Resolve (Prefix (Nam), Scope (Old_S)); + end if; + + Set_Convention (New_S, Convention (Old_S)); + Set_Has_Completion (New_S, Inside_A_Generic); + + if Is_Body then + Check_Frozen_Renaming (N, New_S); + end if; + end Analyze_Renamed_Entry; + + ----------------------------------- + -- Analyze_Renamed_Family_Member -- + ----------------------------------- + + procedure Analyze_Renamed_Family_Member + (N : Node_Id; + New_S : Entity_Id; + Is_Body : Boolean) + is + Nam : constant Node_Id := Name (N); + P : constant Node_Id := Prefix (Nam); + Old_S : Entity_Id; + + begin + if (Is_Entity_Name (P) and then Ekind (Entity (P)) = E_Entry_Family) + or else (Nkind (P) = N_Selected_Component + and then + Ekind (Entity (Selector_Name (P))) = E_Entry_Family) + then + if Is_Entity_Name (P) then + Old_S := Entity (P); + else + Old_S := Entity (Selector_Name (P)); + end if; + + if not Entity_Matches_Spec (Old_S, New_S) then + Error_Msg_N ("entry family does not match specification", N); + + elsif Is_Body then + Check_Subtype_Conformant (New_S, Old_S, N); + Generate_Reference (New_S, Defining_Entity (N), 'b'); + Style.Check_Identifier (Defining_Entity (N), New_S); + end if; + + else + Error_Msg_N ("no entry family matches specification", N); + end if; + + Set_Has_Completion (New_S, Inside_A_Generic); + + if Is_Body then + Check_Frozen_Renaming (N, New_S); + end if; + end Analyze_Renamed_Family_Member; + + ----------------------------------------- + -- Analyze_Renamed_Primitive_Operation -- + ----------------------------------------- + + procedure Analyze_Renamed_Primitive_Operation + (N : Node_Id; + New_S : Entity_Id; + Is_Body : Boolean) + is + Old_S : Entity_Id; + + function Conforms + (Subp : Entity_Id; + Ctyp : Conformance_Type) return Boolean; + -- Verify that the signatures of the renamed entity and the new entity + -- match. The first formal of the renamed entity is skipped because it + -- is the target object in any subsequent call. + + function Conforms + (Subp : Entity_Id; + Ctyp : Conformance_Type) return Boolean + is + Old_F : Entity_Id; + New_F : Entity_Id; + + begin + if Ekind (Subp) /= Ekind (New_S) then + return False; + end if; + + Old_F := Next_Formal (First_Formal (Subp)); + New_F := First_Formal (New_S); + while Present (Old_F) and then Present (New_F) loop + if not Conforming_Types (Etype (Old_F), Etype (New_F), Ctyp) then + return False; + end if; + + if Ctyp >= Mode_Conformant + and then Ekind (Old_F) /= Ekind (New_F) + then + return False; + end if; + + Next_Formal (New_F); + Next_Formal (Old_F); + end loop; + + return True; + end Conforms; + + begin + if not Is_Overloaded (Selector_Name (Name (N))) then + Old_S := Entity (Selector_Name (Name (N))); + + if not Conforms (Old_S, Type_Conformant) then + Old_S := Any_Id; + end if; + + else + -- Find the operation that matches the given signature + + declare + It : Interp; + Ind : Interp_Index; + + begin + Old_S := Any_Id; + Get_First_Interp (Selector_Name (Name (N)), Ind, It); + + while Present (It.Nam) loop + if Conforms (It.Nam, Type_Conformant) then + Old_S := It.Nam; + end if; + + Get_Next_Interp (Ind, It); + end loop; + end; + end if; + + if Old_S = Any_Id then + Error_Msg_N (" no subprogram or entry matches specification", N); + + else + if Is_Body then + if not Conforms (Old_S, Subtype_Conformant) then + Error_Msg_N ("subtype conformance error in renaming", N); + end if; + + Generate_Reference (New_S, Defining_Entity (N), 'b'); + Style.Check_Identifier (Defining_Entity (N), New_S); + + else + -- Only mode conformance required for a renaming_as_declaration + + if not Conforms (Old_S, Mode_Conformant) then + Error_Msg_N ("mode conformance error in renaming", N); + end if; + end if; + + -- Inherit_Renamed_Profile (New_S, Old_S); + + -- The prefix can be an arbitrary expression that yields an + -- object, so it must be resolved. + + Resolve (Prefix (Name (N))); + end if; + end Analyze_Renamed_Primitive_Operation; + + --------------------------------- + -- Analyze_Subprogram_Renaming -- + --------------------------------- + + procedure Analyze_Subprogram_Renaming (N : Node_Id) is + Formal_Spec : constant Node_Id := Corresponding_Formal_Spec (N); + Is_Actual : constant Boolean := Present (Formal_Spec); + Inst_Node : Node_Id := Empty; + Nam : constant Node_Id := Name (N); + New_S : Entity_Id; + Old_S : Entity_Id := Empty; + Rename_Spec : Entity_Id; + Save_AV : constant Ada_Version_Type := Ada_Version; + Save_AV_Exp : constant Ada_Version_Type := Ada_Version_Explicit; + Spec : constant Node_Id := Specification (N); + + procedure Check_Null_Exclusion + (Ren : Entity_Id; + Sub : Entity_Id); + -- Ada 2005 (AI-423): Given renaming Ren of subprogram Sub, check the + -- following AI rules: + -- + -- If Ren is a renaming of a formal subprogram and one of its + -- parameters has a null exclusion, then the corresponding formal + -- in Sub must also have one. Otherwise the subtype of the Sub's + -- formal parameter must exclude null. + -- + -- If Ren is a renaming of a formal function and its return + -- profile has a null exclusion, then Sub's return profile must + -- have one. Otherwise the subtype of Sub's return profile must + -- exclude null. + + function Original_Subprogram (Subp : Entity_Id) return Entity_Id; + -- Find renamed entity when the declaration is a renaming_as_body and + -- the renamed entity may itself be a renaming_as_body. Used to enforce + -- rule that a renaming_as_body is illegal if the declaration occurs + -- before the subprogram it completes is frozen, and renaming indirectly + -- renames the subprogram itself.(Defect Report 8652/0027). + + -------------------------- + -- Check_Null_Exclusion -- + -------------------------- + + procedure Check_Null_Exclusion + (Ren : Entity_Id; + Sub : Entity_Id) + is + Ren_Formal : Entity_Id; + Sub_Formal : Entity_Id; + + begin + -- Parameter check + + Ren_Formal := First_Formal (Ren); + Sub_Formal := First_Formal (Sub); + while Present (Ren_Formal) + and then Present (Sub_Formal) + loop + if Has_Null_Exclusion (Parent (Ren_Formal)) + and then + not (Has_Null_Exclusion (Parent (Sub_Formal)) + or else Can_Never_Be_Null (Etype (Sub_Formal))) + then + Error_Msg_NE + ("`NOT NULL` required for parameter &", + Parent (Sub_Formal), Sub_Formal); + end if; + + Next_Formal (Ren_Formal); + Next_Formal (Sub_Formal); + end loop; + + -- Return profile check + + if Nkind (Parent (Ren)) = N_Function_Specification + and then Nkind (Parent (Sub)) = N_Function_Specification + and then Has_Null_Exclusion (Parent (Ren)) + and then + not (Has_Null_Exclusion (Parent (Sub)) + or else Can_Never_Be_Null (Etype (Sub))) + then + Error_Msg_N + ("return must specify `NOT NULL`", + Result_Definition (Parent (Sub))); + end if; + end Check_Null_Exclusion; + + ------------------------- + -- Original_Subprogram -- + ------------------------- + + function Original_Subprogram (Subp : Entity_Id) return Entity_Id is + Orig_Decl : Node_Id; + Orig_Subp : Entity_Id; + + begin + -- First case: renamed entity is itself a renaming + + if Present (Alias (Subp)) then + return Alias (Subp); + + elsif + Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Declaration + and then Present + (Corresponding_Body (Unit_Declaration_Node (Subp))) + then + -- Check if renamed entity is a renaming_as_body + + Orig_Decl := + Unit_Declaration_Node + (Corresponding_Body (Unit_Declaration_Node (Subp))); + + if Nkind (Orig_Decl) = N_Subprogram_Renaming_Declaration then + Orig_Subp := Entity (Name (Orig_Decl)); + + if Orig_Subp = Rename_Spec then + + -- Circularity detected + + return Orig_Subp; + + else + return (Original_Subprogram (Orig_Subp)); + end if; + else + return Subp; + end if; + else + return Subp; + end if; + end Original_Subprogram; + + -- Start of processing for Analyze_Subprogram_Renaming + + begin + -- We must test for the attribute renaming case before the Analyze + -- call because otherwise Sem_Attr will complain that the attribute + -- is missing an argument when it is analyzed. + + if Nkind (Nam) = N_Attribute_Reference then + + -- In the case of an abstract formal subprogram association, rewrite + -- an actual given by a stream attribute as the name of the + -- corresponding stream primitive of the type. + + -- In a generic context the stream operations are not generated, and + -- this must be treated as a normal attribute reference, to be + -- expanded in subsequent instantiations. + + if Is_Actual and then Is_Abstract_Subprogram (Formal_Spec) + and then Expander_Active + then + declare + Stream_Prim : Entity_Id; + Prefix_Type : constant Entity_Id := Entity (Prefix (Nam)); + + begin + -- The class-wide forms of the stream attributes are not + -- primitive dispatching operations (even though they + -- internally dispatch to a stream attribute). + + if Is_Class_Wide_Type (Prefix_Type) then + Error_Msg_N + ("attribute must be a primitive dispatching operation", + Nam); + return; + end if; + + -- Retrieve the primitive subprogram associated with the + -- attribute. This can only be a stream attribute, since those + -- are the only ones that are dispatching (and the actual for + -- an abstract formal subprogram must be dispatching + -- operation). + + begin + case Attribute_Name (Nam) is + when Name_Input => + Stream_Prim := + Find_Prim_Op (Prefix_Type, TSS_Stream_Input); + when Name_Output => + Stream_Prim := + Find_Prim_Op (Prefix_Type, TSS_Stream_Output); + when Name_Read => + Stream_Prim := + Find_Prim_Op (Prefix_Type, TSS_Stream_Read); + when Name_Write => + Stream_Prim := + Find_Prim_Op (Prefix_Type, TSS_Stream_Write); + when others => + Error_Msg_N + ("attribute must be a primitive" + & " dispatching operation", Nam); + return; + end case; + + exception + + -- If no operation was found, and the type is limited, + -- the user should have defined one. + + when Program_Error => + if Is_Limited_Type (Prefix_Type) then + Error_Msg_NE + ("stream operation not defined for type&", + N, Prefix_Type); + return; + + -- Otherwise, compiler should have generated default + + else + raise; + end if; + end; + + -- Rewrite the attribute into the name of its corresponding + -- primitive dispatching subprogram. We can then proceed with + -- the usual processing for subprogram renamings. + + declare + Prim_Name : constant Node_Id := + Make_Identifier (Sloc (Nam), + Chars => Chars (Stream_Prim)); + begin + Set_Entity (Prim_Name, Stream_Prim); + Rewrite (Nam, Prim_Name); + Analyze (Nam); + end; + end; + + -- Normal processing for a renaming of an attribute + + else + Attribute_Renaming (N); + return; + end if; + end if; + + -- Check whether this declaration corresponds to the instantiation + -- of a formal subprogram. + + -- If this is an instantiation, the corresponding actual is frozen and + -- error messages can be made more precise. If this is a default + -- subprogram, the entity is already established in the generic, and is + -- not retrieved by visibility. If it is a default with a box, the + -- candidate interpretations, if any, have been collected when building + -- the renaming declaration. If overloaded, the proper interpretation is + -- determined in Find_Renamed_Entity. If the entity is an operator, + -- Find_Renamed_Entity applies additional visibility checks. + + if Is_Actual then + Inst_Node := Unit_Declaration_Node (Formal_Spec); + + if Is_Entity_Name (Nam) + and then Present (Entity (Nam)) + and then not Comes_From_Source (Nam) + and then not Is_Overloaded (Nam) + then + Old_S := Entity (Nam); + New_S := Analyze_Subprogram_Specification (Spec); + + -- Operator case + + if Ekind (Entity (Nam)) = E_Operator then + + -- Box present + + if Box_Present (Inst_Node) then + Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual); + + -- If there is an immediately visible homonym of the operator + -- and the declaration has a default, this is worth a warning + -- because the user probably did not intend to get the pre- + -- defined operator, visible in the generic declaration. To + -- find if there is an intended candidate, analyze the renaming + -- again in the current context. + + elsif Scope (Old_S) = Standard_Standard + and then Present (Default_Name (Inst_Node)) + then + declare + Decl : constant Node_Id := New_Copy_Tree (N); + Hidden : Entity_Id; + + begin + Set_Entity (Name (Decl), Empty); + Analyze (Name (Decl)); + Hidden := + Find_Renamed_Entity (Decl, Name (Decl), New_S, True); + + if Present (Hidden) + and then In_Open_Scopes (Scope (Hidden)) + and then Is_Immediately_Visible (Hidden) + and then Comes_From_Source (Hidden) + and then Hidden /= Old_S + then + Error_Msg_Sloc := Sloc (Hidden); + Error_Msg_N ("?default subprogram is resolved " & + "in the generic declaration " & + "(RM 12.6(17))", N); + Error_Msg_NE ("\?and will not use & #", N, Hidden); + end if; + end; + end if; + end if; + + else + Analyze (Nam); + New_S := Analyze_Subprogram_Specification (Spec); + end if; + + else + -- Renamed entity must be analyzed first, to avoid being hidden by + -- new name (which might be the same in a generic instance). + + Analyze (Nam); + + -- The renaming defines a new overloaded entity, which is analyzed + -- like a subprogram declaration. + + New_S := Analyze_Subprogram_Specification (Spec); + end if; + + if Current_Scope /= Standard_Standard then + Set_Is_Pure (New_S, Is_Pure (Current_Scope)); + end if; + + Rename_Spec := Find_Corresponding_Spec (N); + + -- Case of Renaming_As_Body + + if Present (Rename_Spec) then + + -- Renaming declaration is the completion of the declaration of + -- Rename_Spec. We build an actual body for it at the freezing point. + + Set_Corresponding_Spec (N, Rename_Spec); + + -- Deal with special case of stream functions of abstract types + -- and interfaces. + + if Nkind (Unit_Declaration_Node (Rename_Spec)) = + N_Abstract_Subprogram_Declaration + then + -- Input stream functions are abstract if the object type is + -- abstract. Similarly, all default stream functions for an + -- interface type are abstract. However, these subprograms may + -- receive explicit declarations in representation clauses, making + -- the attribute subprograms usable as defaults in subsequent + -- type extensions. + -- In this case we rewrite the declaration to make the subprogram + -- non-abstract. We remove the previous declaration, and insert + -- the new one at the point of the renaming, to prevent premature + -- access to unfrozen types. The new declaration reuses the + -- specification of the previous one, and must not be analyzed. + + pragma Assert + (Is_Primitive (Entity (Nam)) + and then + Is_Abstract_Type (Find_Dispatching_Type (Entity (Nam)))); + declare + Old_Decl : constant Node_Id := + Unit_Declaration_Node (Rename_Spec); + New_Decl : constant Node_Id := + Make_Subprogram_Declaration (Sloc (N), + Specification => + Relocate_Node (Specification (Old_Decl))); + begin + Remove (Old_Decl); + Insert_After (N, New_Decl); + Set_Is_Abstract_Subprogram (Rename_Spec, False); + Set_Analyzed (New_Decl); + end; + end if; + + Set_Corresponding_Body (Unit_Declaration_Node (Rename_Spec), New_S); + + if Ada_Version = Ada_83 and then Comes_From_Source (N) then + Error_Msg_N ("(Ada 83) renaming cannot serve as a body", N); + end if; + + Set_Convention (New_S, Convention (Rename_Spec)); + Check_Fully_Conformant (New_S, Rename_Spec); + Set_Public_Status (New_S); + + -- The specification does not introduce new formals, but only + -- repeats the formals of the original subprogram declaration. + -- For cross-reference purposes, and for refactoring tools, we + -- treat the formals of the renaming declaration as body formals. + + Reference_Body_Formals (Rename_Spec, New_S); + + -- Indicate that the entity in the declaration functions like the + -- corresponding body, and is not a new entity. The body will be + -- constructed later at the freeze point, so indicate that the + -- completion has not been seen yet. + + Set_Ekind (New_S, E_Subprogram_Body); + New_S := Rename_Spec; + Set_Has_Completion (Rename_Spec, False); + + -- Ada 2005: check overriding indicator + + if Present (Overridden_Operation (Rename_Spec)) then + if Must_Not_Override (Specification (N)) then + Error_Msg_NE + ("subprogram& overrides inherited operation", + N, Rename_Spec); + elsif + Style_Check and then not Must_Override (Specification (N)) + then + Style.Missing_Overriding (N, Rename_Spec); + end if; + + elsif Must_Override (Specification (N)) then + Error_Msg_NE ("subprogram& is not overriding", N, Rename_Spec); + end if; + + -- Normal subprogram renaming (not renaming as body) + + else + Generate_Definition (New_S); + New_Overloaded_Entity (New_S); + + if Is_Entity_Name (Nam) + and then Is_Intrinsic_Subprogram (Entity (Nam)) + then + null; + else + Check_Delayed_Subprogram (New_S); + end if; + end if; + + -- There is no need for elaboration checks on the new entity, which may + -- be called before the next freezing point where the body will appear. + -- Elaboration checks refer to the real entity, not the one created by + -- the renaming declaration. + + Set_Kill_Elaboration_Checks (New_S, True); + + if Etype (Nam) = Any_Type then + Set_Has_Completion (New_S); + return; + + elsif Nkind (Nam) = N_Selected_Component then + + -- A prefix of the form A.B can designate an entry of task A, a + -- protected operation of protected object A, or finally a primitive + -- operation of object A. In the later case, A is an object of some + -- tagged type, or an access type that denotes one such. To further + -- distinguish these cases, note that the scope of a task entry or + -- protected operation is type of the prefix. + + -- The prefix could be an overloaded function call that returns both + -- kinds of operations. This overloading pathology is left to the + -- dedicated reader ??? + + declare + T : constant Entity_Id := Etype (Prefix (Nam)); + + begin + if Present (T) + and then + (Is_Tagged_Type (T) + or else + (Is_Access_Type (T) + and then + Is_Tagged_Type (Designated_Type (T)))) + and then Scope (Entity (Selector_Name (Nam))) /= T + then + Analyze_Renamed_Primitive_Operation + (N, New_S, Present (Rename_Spec)); + return; + + else + -- Renamed entity is an entry or protected operation. For those + -- cases an explicit body is built (at the point of freezing of + -- this entity) that contains a call to the renamed entity. + + -- This is not allowed for renaming as body if the renamed + -- spec is already frozen (see RM 8.5.4(5) for details). + + if Present (Rename_Spec) + and then Is_Frozen (Rename_Spec) + then + Error_Msg_N + ("renaming-as-body cannot rename entry as subprogram", N); + Error_Msg_NE + ("\since & is already frozen (RM 8.5.4(5))", + N, Rename_Spec); + else + Analyze_Renamed_Entry (N, New_S, Present (Rename_Spec)); + end if; + + return; + end if; + end; + + elsif Nkind (Nam) = N_Explicit_Dereference then + + -- Renamed entity is designated by access_to_subprogram expression. + -- Must build body to encapsulate call, as in the entry case. + + Analyze_Renamed_Dereference (N, New_S, Present (Rename_Spec)); + return; + + elsif Nkind (Nam) = N_Indexed_Component then + Analyze_Renamed_Family_Member (N, New_S, Present (Rename_Spec)); + return; + + elsif Nkind (Nam) = N_Character_Literal then + Analyze_Renamed_Character (N, New_S, Present (Rename_Spec)); + return; + + elsif not Is_Entity_Name (Nam) + or else not Is_Overloadable (Entity (Nam)) + then + Error_Msg_N ("expect valid subprogram name in renaming", N); + return; + end if; + + -- Find the renamed entity that matches the given specification. Disable + -- Ada_83 because there is no requirement of full conformance between + -- renamed entity and new entity, even though the same circuit is used. + + -- This is a bit of a kludge, which introduces a really irregular use of + -- Ada_Version[_Explicit]. Would be nice to find cleaner way to do this + -- ??? + + Ada_Version := Ada_Version_Type'Max (Ada_Version, Ada_95); + Ada_Version_Explicit := Ada_Version; + + if No (Old_S) then + Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual); + + -- The visible operation may be an inherited abstract operation that + -- was overridden in the private part, in which case a call will + -- dispatch to the overriding operation. Use the overriding one in + -- the renaming declaration, to prevent spurious errors below. + + if Is_Overloadable (Old_S) + and then Is_Abstract_Subprogram (Old_S) + and then No (DTC_Entity (Old_S)) + and then Present (Alias (Old_S)) + and then not Is_Abstract_Subprogram (Alias (Old_S)) + and then Present (Overridden_Operation (Alias (Old_S))) + then + Old_S := Alias (Old_S); + end if; + + -- When the renamed subprogram is overloaded and used as an actual + -- of a generic, its entity is set to the first available homonym. + -- We must first disambiguate the name, then set the proper entity. + + if Is_Actual + and then Is_Overloaded (Nam) + then + Set_Entity (Nam, Old_S); + end if; + end if; + + -- Most common case: subprogram renames subprogram. No body is generated + -- in this case, so we must indicate the declaration is complete as is. + -- and inherit various attributes of the renamed subprogram. + + if No (Rename_Spec) then + Set_Has_Completion (New_S); + Set_Is_Imported (New_S, Is_Imported (Entity (Nam))); + Set_Is_Pure (New_S, Is_Pure (Entity (Nam))); + Set_Is_Preelaborated (New_S, Is_Preelaborated (Entity (Nam))); + + -- Ada 2005 (AI-423): Check the consistency of null exclusions + -- between a subprogram and its correct renaming. + + -- Note: the Any_Id check is a guard that prevents compiler crashes + -- when performing a null exclusion check between a renaming and a + -- renamed subprogram that has been found to be illegal. + + if Ada_Version >= Ada_2005 + and then Entity (Nam) /= Any_Id + then + Check_Null_Exclusion + (Ren => New_S, + Sub => Entity (Nam)); + end if; + + -- Enforce the Ada 2005 rule that the renamed entity cannot require + -- overriding. The flag Requires_Overriding is set very selectively + -- and misses some other illegal cases. The additional conditions + -- checked below are sufficient but not necessary ??? + + -- The rule does not apply to the renaming generated for an actual + -- subprogram in an instance. + + if Is_Actual then + null; + + -- Guard against previous errors, and omit renamings of predefined + -- operators. + + elsif not Ekind_In (Old_S, E_Function, E_Procedure) then + null; + + elsif Requires_Overriding (Old_S) + or else + (Is_Abstract_Subprogram (Old_S) + and then Present (Find_Dispatching_Type (Old_S)) + and then + not Is_Abstract_Type (Find_Dispatching_Type (Old_S))) + then + Error_Msg_N + ("renamed entity cannot be " + & "subprogram that requires overriding (RM 8.5.4 (5.1))", N); + end if; + end if; + + if Old_S /= Any_Id then + if Is_Actual + and then From_Default (N) + then + -- This is an implicit reference to the default actual + + Generate_Reference (Old_S, Nam, Typ => 'i', Force => True); + else + Generate_Reference (Old_S, Nam); + end if; + + -- For a renaming-as-body, require subtype conformance, but if the + -- declaration being completed has not been frozen, then inherit the + -- convention of the renamed subprogram prior to checking conformance + -- (unless the renaming has an explicit convention established; the + -- rule stated in the RM doesn't seem to address this ???). + + if Present (Rename_Spec) then + Generate_Reference (Rename_Spec, Defining_Entity (Spec), 'b'); + Style.Check_Identifier (Defining_Entity (Spec), Rename_Spec); + + if not Is_Frozen (Rename_Spec) then + if not Has_Convention_Pragma (Rename_Spec) then + Set_Convention (New_S, Convention (Old_S)); + end if; + + if Ekind (Old_S) /= E_Operator then + Check_Mode_Conformant (New_S, Old_S, Spec); + end if; + + if Original_Subprogram (Old_S) = Rename_Spec then + Error_Msg_N ("unfrozen subprogram cannot rename itself ", N); + end if; + else + Check_Subtype_Conformant (New_S, Old_S, Spec); + end if; + + Check_Frozen_Renaming (N, Rename_Spec); + + -- Check explicitly that renamed entity is not intrinsic, because + -- in a generic the renamed body is not built. In this case, + -- the renaming_as_body is a completion. + + if Inside_A_Generic then + if Is_Frozen (Rename_Spec) + and then Is_Intrinsic_Subprogram (Old_S) + then + Error_Msg_N + ("subprogram in renaming_as_body cannot be intrinsic", + Name (N)); + end if; + + Set_Has_Completion (Rename_Spec); + end if; + + elsif Ekind (Old_S) /= E_Operator then + Check_Mode_Conformant (New_S, Old_S); + + if Is_Actual + and then Error_Posted (New_S) + then + Error_Msg_NE ("invalid actual subprogram: & #!", N, Old_S); + end if; + end if; + + if No (Rename_Spec) then + + -- The parameter profile of the new entity is that of the renamed + -- entity: the subtypes given in the specification are irrelevant. + + Inherit_Renamed_Profile (New_S, Old_S); + + -- A call to the subprogram is transformed into a call to the + -- renamed entity. This is transitive if the renamed entity is + -- itself a renaming. + + if Present (Alias (Old_S)) then + Set_Alias (New_S, Alias (Old_S)); + else + Set_Alias (New_S, Old_S); + end if; + + -- Note that we do not set Is_Intrinsic_Subprogram if we have a + -- renaming as body, since the entity in this case is not an + -- intrinsic (it calls an intrinsic, but we have a real body for + -- this call, and it is in this body that the required intrinsic + -- processing will take place). + + -- Also, if this is a renaming of inequality, the renamed operator + -- is intrinsic, but what matters is the corresponding equality + -- operator, which may be user-defined. + + Set_Is_Intrinsic_Subprogram + (New_S, + Is_Intrinsic_Subprogram (Old_S) + and then + (Chars (Old_S) /= Name_Op_Ne + or else Ekind (Old_S) = E_Operator + or else + Is_Intrinsic_Subprogram + (Corresponding_Equality (Old_S)))); + + if Ekind (Alias (New_S)) = E_Operator then + Set_Has_Delayed_Freeze (New_S, False); + end if; + + -- If the renaming corresponds to an association for an abstract + -- formal subprogram, then various attributes must be set to + -- indicate that the renaming is an abstract dispatching operation + -- with a controlling type. + + if Is_Actual and then Is_Abstract_Subprogram (Formal_Spec) then + + -- Mark the renaming as abstract here, so Find_Dispatching_Type + -- see it as corresponding to a generic association for a + -- formal abstract subprogram + + Set_Is_Abstract_Subprogram (New_S); + + declare + New_S_Ctrl_Type : constant Entity_Id := + Find_Dispatching_Type (New_S); + Old_S_Ctrl_Type : constant Entity_Id := + Find_Dispatching_Type (Old_S); + + begin + if Old_S_Ctrl_Type /= New_S_Ctrl_Type then + Error_Msg_NE + ("actual must be dispatching subprogram for type&", + Nam, New_S_Ctrl_Type); + + else + Set_Is_Dispatching_Operation (New_S); + Check_Controlling_Formals (New_S_Ctrl_Type, New_S); + + -- If the actual in the formal subprogram is itself a + -- formal abstract subprogram association, there's no + -- dispatch table component or position to inherit. + + if Present (DTC_Entity (Old_S)) then + Set_DTC_Entity (New_S, DTC_Entity (Old_S)); + Set_DT_Position (New_S, DT_Position (Old_S)); + end if; + end if; + end; + end if; + end if; + + if not Is_Actual + and then (Old_S = New_S + or else (Nkind (Nam) /= N_Expanded_Name + and then Chars (Old_S) = Chars (New_S))) + then + Error_Msg_N ("subprogram cannot rename itself", N); + end if; + + Set_Convention (New_S, Convention (Old_S)); + + if Is_Abstract_Subprogram (Old_S) then + if Present (Rename_Spec) then + Error_Msg_N + ("a renaming-as-body cannot rename an abstract subprogram", + N); + Set_Has_Completion (Rename_Spec); + else + Set_Is_Abstract_Subprogram (New_S); + end if; + end if; + + Check_Library_Unit_Renaming (N, Old_S); + + -- Pathological case: procedure renames entry in the scope of its + -- task. Entry is given by simple name, but body must be built for + -- procedure. Of course if called it will deadlock. + + if Ekind (Old_S) = E_Entry then + Set_Has_Completion (New_S, False); + Set_Alias (New_S, Empty); + end if; + + if Is_Actual then + Freeze_Before (N, Old_S); + Set_Has_Delayed_Freeze (New_S, False); + Freeze_Before (N, New_S); + + -- An abstract subprogram is only allowed as an actual in the case + -- where the formal subprogram is also abstract. + + if (Ekind (Old_S) = E_Procedure or else Ekind (Old_S) = E_Function) + and then Is_Abstract_Subprogram (Old_S) + and then not Is_Abstract_Subprogram (Formal_Spec) + then + Error_Msg_N + ("abstract subprogram not allowed as generic actual", Nam); + end if; + end if; + + else + -- A common error is to assume that implicit operators for types are + -- defined in Standard, or in the scope of a subtype. In those cases + -- where the renamed entity is given with an expanded name, it is + -- worth mentioning that operators for the type are not declared in + -- the scope given by the prefix. + + if Nkind (Nam) = N_Expanded_Name + and then Nkind (Selector_Name (Nam)) = N_Operator_Symbol + and then Scope (Entity (Nam)) = Standard_Standard + then + declare + T : constant Entity_Id := + Base_Type (Etype (First_Formal (New_S))); + begin + Error_Msg_Node_2 := Prefix (Nam); + Error_Msg_NE + ("operator for type& is not declared in&", Prefix (Nam), T); + end; + + else + Error_Msg_NE + ("no visible subprogram matches the specification for&", + Spec, New_S); + end if; + + if Present (Candidate_Renaming) then + declare + F1 : Entity_Id; + F2 : Entity_Id; + T1 : Entity_Id; + + begin + F1 := First_Formal (Candidate_Renaming); + F2 := First_Formal (New_S); + T1 := First_Subtype (Etype (F1)); + + while Present (F1) and then Present (F2) loop + Next_Formal (F1); + Next_Formal (F2); + end loop; + + if Present (F1) and then Present (Default_Value (F1)) then + if Present (Next_Formal (F1)) then + Error_Msg_NE + ("\missing specification for &" & + " and other formals with defaults", Spec, F1); + else + Error_Msg_NE + ("\missing specification for &", Spec, F1); + end if; + end if; + + if Nkind (Nam) = N_Operator_Symbol + and then From_Default (N) + then + Error_Msg_Node_2 := T1; + Error_Msg_NE + ("default & on & is not directly visible", + Nam, Nam); + end if; + end; + end if; + end if; + + -- Ada 2005 AI 404: if the new subprogram is dispatching, verify that + -- controlling access parameters are known non-null for the renamed + -- subprogram. Test also applies to a subprogram instantiation that + -- is dispatching. Test is skipped if some previous error was detected + -- that set Old_S to Any_Id. + + if Ada_Version >= Ada_2005 + and then Old_S /= Any_Id + and then not Is_Dispatching_Operation (Old_S) + and then Is_Dispatching_Operation (New_S) + then + declare + Old_F : Entity_Id; + New_F : Entity_Id; + + begin + Old_F := First_Formal (Old_S); + New_F := First_Formal (New_S); + while Present (Old_F) loop + if Ekind (Etype (Old_F)) = E_Anonymous_Access_Type + and then Is_Controlling_Formal (New_F) + and then not Can_Never_Be_Null (Old_F) + then + Error_Msg_N ("access parameter is controlling,", New_F); + Error_Msg_NE + ("\corresponding parameter of& " + & "must be explicitly null excluding", New_F, Old_S); + end if; + + Next_Formal (Old_F); + Next_Formal (New_F); + end loop; + end; + end if; + + -- A useful warning, suggested by Ada Bug Finder (Ada-Europe 2005) + -- is to warn if an operator is being renamed as a different operator. + -- If the operator is predefined, examine the kind of the entity, not + -- the abbreviated declaration in Standard. + + if Comes_From_Source (N) + and then Present (Old_S) + and then + (Nkind (Old_S) = N_Defining_Operator_Symbol + or else Ekind (Old_S) = E_Operator) + and then Nkind (New_S) = N_Defining_Operator_Symbol + and then Chars (Old_S) /= Chars (New_S) + then + Error_Msg_NE + ("?& is being renamed as a different operator", N, Old_S); + end if; + + -- Check for renaming of obsolescent subprogram + + Check_Obsolescent_2005_Entity (Entity (Nam), Nam); + + -- Another warning or some utility: if the new subprogram as the same + -- name as the old one, the old one is not hidden by an outer homograph, + -- the new one is not a public symbol, and the old one is otherwise + -- directly visible, the renaming is superfluous. + + if Chars (Old_S) = Chars (New_S) + and then Comes_From_Source (N) + and then Scope (Old_S) /= Standard_Standard + and then Warn_On_Redundant_Constructs + and then + (Is_Immediately_Visible (Old_S) + or else Is_Potentially_Use_Visible (Old_S)) + and then Is_Overloadable (Current_Scope) + and then Chars (Current_Scope) /= Chars (Old_S) + then + Error_Msg_N + ("?redundant renaming, entity is directly visible", Name (N)); + end if; + + Ada_Version := Save_AV; + Ada_Version_Explicit := Save_AV_Exp; + end Analyze_Subprogram_Renaming; + + ------------------------- + -- Analyze_Use_Package -- + ------------------------- + + -- Resolve the package names in the use clause, and make all the visible + -- entities defined in the package potentially use-visible. If the package + -- is already in use from a previous use clause, its visible entities are + -- already use-visible. In that case, mark the occurrence as a redundant + -- use. If the package is an open scope, i.e. if the use clause occurs + -- within the package itself, ignore it. + + procedure Analyze_Use_Package (N : Node_Id) is + Pack_Name : Node_Id; + Pack : Entity_Id; + + -- Start of processing for Analyze_Use_Package + + begin + Set_Hidden_By_Use_Clause (N, No_Elist); + + -- Use clause is not allowed in a spec of a predefined package + -- declaration except that packages whose file name starts a-n are OK + -- (these are children of Ada.Numerics, and such packages are never + -- loaded by Rtsfind). + + if Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit)) + and then Name_Buffer (1 .. 3) /= "a-n" + and then + Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration + then + Error_Msg_N ("use clause not allowed in predefined spec", N); + end if; + + -- Chain clause to list of use clauses in current scope + + if Nkind (Parent (N)) /= N_Compilation_Unit then + Chain_Use_Clause (N); + end if; + + -- Loop through package names to identify referenced packages + + Pack_Name := First (Names (N)); + while Present (Pack_Name) loop + Analyze (Pack_Name); + + if Nkind (Parent (N)) = N_Compilation_Unit + and then Nkind (Pack_Name) = N_Expanded_Name + then + declare + Pref : Node_Id; + + begin + Pref := Prefix (Pack_Name); + while Nkind (Pref) = N_Expanded_Name loop + Pref := Prefix (Pref); + end loop; + + if Entity (Pref) = Standard_Standard then + Error_Msg_N + ("predefined package Standard cannot appear" + & " in a context clause", Pref); + end if; + end; + end if; + + Next (Pack_Name); + end loop; + + -- Loop through package names to mark all entities as potentially + -- use visible. + + Pack_Name := First (Names (N)); + while Present (Pack_Name) loop + if Is_Entity_Name (Pack_Name) then + Pack := Entity (Pack_Name); + + if Ekind (Pack) /= E_Package + and then Etype (Pack) /= Any_Type + then + if Ekind (Pack) = E_Generic_Package then + Error_Msg_N -- CODEFIX + ("a generic package is not allowed in a use clause", + Pack_Name); + else + Error_Msg_N ("& is not a usable package", Pack_Name); + end if; + + else + if Nkind (Parent (N)) = N_Compilation_Unit then + Check_In_Previous_With_Clause (N, Pack_Name); + end if; + + if Applicable_Use (Pack_Name) then + Use_One_Package (Pack, N); + end if; + end if; + + -- Report error because name denotes something other than a package + + else + Error_Msg_N ("& is not a package", Pack_Name); + end if; + + Next (Pack_Name); + end loop; + end Analyze_Use_Package; + + ---------------------- + -- Analyze_Use_Type -- + ---------------------- + + procedure Analyze_Use_Type (N : Node_Id) is + E : Entity_Id; + Id : Node_Id; + + begin + Set_Hidden_By_Use_Clause (N, No_Elist); + + -- Chain clause to list of use clauses in current scope + + if Nkind (Parent (N)) /= N_Compilation_Unit then + Chain_Use_Clause (N); + end if; + + Id := First (Subtype_Marks (N)); + while Present (Id) loop + Find_Type (Id); + E := Entity (Id); + + if E /= Any_Type then + Use_One_Type (Id); + + if Nkind (Parent (N)) = N_Compilation_Unit then + if Nkind (Id) = N_Identifier then + Error_Msg_N ("type is not directly visible", Id); + + elsif Is_Child_Unit (Scope (E)) + and then Scope (E) /= System_Aux_Id + then + Check_In_Previous_With_Clause (N, Prefix (Id)); + end if; + end if; + + else + -- If the use_type_clause appears in a compilation unit context, + -- check whether it comes from a unit that may appear in a + -- limited_with_clause, for a better error message. + + if Nkind (Parent (N)) = N_Compilation_Unit + and then Nkind (Id) /= N_Identifier + then + declare + Item : Node_Id; + Pref : Node_Id; + + function Mentioned (Nam : Node_Id) return Boolean; + -- Check whether the prefix of expanded name for the type + -- appears in the prefix of some limited_with_clause. + + --------------- + -- Mentioned -- + --------------- + + function Mentioned (Nam : Node_Id) return Boolean is + begin + return Nkind (Name (Item)) = N_Selected_Component + and then + Chars (Prefix (Name (Item))) = Chars (Nam); + end Mentioned; + + begin + Pref := Prefix (Id); + Item := First (Context_Items (Parent (N))); + + while Present (Item) and then Item /= N loop + if Nkind (Item) = N_With_Clause + and then Limited_Present (Item) + and then Mentioned (Pref) + then + Change_Error_Text + (Get_Msg_Id, "premature usage of incomplete type"); + end if; + + Next (Item); + end loop; + end; + end if; + end if; + + Next (Id); + end loop; + end Analyze_Use_Type; + + -------------------- + -- Applicable_Use -- + -------------------- + + function Applicable_Use (Pack_Name : Node_Id) return Boolean is + Pack : constant Entity_Id := Entity (Pack_Name); + + begin + if In_Open_Scopes (Pack) then + if Warn_On_Redundant_Constructs + and then Pack = Current_Scope + then + Error_Msg_NE -- CODEFIX + ("& is already use-visible within itself?", Pack_Name, Pack); + end if; + + return False; + + elsif In_Use (Pack) then + Note_Redundant_Use (Pack_Name); + return False; + + elsif Present (Renamed_Object (Pack)) + and then In_Use (Renamed_Object (Pack)) + then + Note_Redundant_Use (Pack_Name); + return False; + + else + return True; + end if; + end Applicable_Use; + + ------------------------ + -- Attribute_Renaming -- + ------------------------ + + procedure Attribute_Renaming (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Nam : constant Node_Id := Name (N); + Spec : constant Node_Id := Specification (N); + New_S : constant Entity_Id := Defining_Unit_Name (Spec); + Aname : constant Name_Id := Attribute_Name (Nam); + + Form_Num : Nat := 0; + Expr_List : List_Id := No_List; + + Attr_Node : Node_Id; + Body_Node : Node_Id; + Param_Spec : Node_Id; + + begin + Generate_Definition (New_S); + + -- This procedure is called in the context of subprogram renaming, and + -- thus the attribute must be one that is a subprogram. All of those + -- have at least one formal parameter, with the singular exception of + -- AST_Entry (which is a real oddity, it is odd that this can be renamed + -- at all!) + + if not Is_Non_Empty_List (Parameter_Specifications (Spec)) then + if Aname /= Name_AST_Entry then + Error_Msg_N + ("subprogram renaming an attribute must have formals", N); + return; + end if; + + else + Param_Spec := First (Parameter_Specifications (Spec)); + while Present (Param_Spec) loop + Form_Num := Form_Num + 1; + + if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then + Find_Type (Parameter_Type (Param_Spec)); + + -- The profile of the new entity denotes the base type (s) of + -- the types given in the specification. For access parameters + -- there are no subtypes involved. + + Rewrite (Parameter_Type (Param_Spec), + New_Reference_To + (Base_Type (Entity (Parameter_Type (Param_Spec))), Loc)); + end if; + + if No (Expr_List) then + Expr_List := New_List; + end if; + + Append_To (Expr_List, + Make_Identifier (Loc, + Chars => Chars (Defining_Identifier (Param_Spec)))); + + -- The expressions in the attribute reference are not freeze + -- points. Neither is the attribute as a whole, see below. + + Set_Must_Not_Freeze (Last (Expr_List)); + Next (Param_Spec); + end loop; + end if; + + -- Immediate error if too many formals. Other mismatches in number or + -- types of parameters are detected when we analyze the body of the + -- subprogram that we construct. + + if Form_Num > 2 then + Error_Msg_N ("too many formals for attribute", N); + + -- Error if the attribute reference has expressions that look like + -- formal parameters. + + elsif Present (Expressions (Nam)) then + Error_Msg_N ("illegal expressions in attribute reference", Nam); + + elsif + Aname = Name_Compose or else + Aname = Name_Exponent or else + Aname = Name_Leading_Part or else + Aname = Name_Pos or else + Aname = Name_Round or else + Aname = Name_Scaling or else + Aname = Name_Val + then + if Nkind (N) = N_Subprogram_Renaming_Declaration + and then Present (Corresponding_Formal_Spec (N)) + then + Error_Msg_N + ("generic actual cannot be attribute involving universal type", + Nam); + else + Error_Msg_N + ("attribute involving a universal type cannot be renamed", + Nam); + end if; + end if; + + -- AST_Entry is an odd case. It doesn't really make much sense to allow + -- it to be renamed, but that's the DEC rule, so we have to do it right. + -- The point is that the AST_Entry call should be made now, and what the + -- function will return is the returned value. + + -- Note that there is no Expr_List in this case anyway + + if Aname = Name_AST_Entry then + declare + Ent : constant Entity_Id := Make_Temporary (Loc, 'R', Nam); + Decl : Node_Id; + + begin + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Ent, + Object_Definition => + New_Occurrence_Of (RTE (RE_AST_Handler), Loc), + Expression => Nam, + Constant_Present => True); + + Set_Assignment_OK (Decl, True); + Insert_Action (N, Decl); + Attr_Node := Make_Identifier (Loc, Chars (Ent)); + end; + + -- For all other attributes, we rewrite the attribute node to have + -- a list of expressions corresponding to the subprogram formals. + -- A renaming declaration is not a freeze point, and the analysis of + -- the attribute reference should not freeze the type of the prefix. + + else + Attr_Node := + Make_Attribute_Reference (Loc, + Prefix => Prefix (Nam), + Attribute_Name => Aname, + Expressions => Expr_List); + + Set_Must_Not_Freeze (Attr_Node); + Set_Must_Not_Freeze (Prefix (Nam)); + end if; + + -- Case of renaming a function + + if Nkind (Spec) = N_Function_Specification then + if Is_Procedure_Attribute_Name (Aname) then + Error_Msg_N ("attribute can only be renamed as procedure", Nam); + return; + end if; + + Find_Type (Result_Definition (Spec)); + Rewrite (Result_Definition (Spec), + New_Reference_To ( + Base_Type (Entity (Result_Definition (Spec))), Loc)); + + Body_Node := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => Attr_Node)))); + + -- Case of renaming a procedure + + else + if not Is_Procedure_Attribute_Name (Aname) then + Error_Msg_N ("attribute can only be renamed as function", Nam); + return; + end if; + + Body_Node := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Attr_Node))); + end if; + + -- In case of tagged types we add the body of the generated function to + -- the freezing actions of the type (because in the general case such + -- type is still not frozen). We exclude from this processing generic + -- formal subprograms found in instantiations and AST_Entry renamings. + + -- We must exclude VM targets because entity AST_Handler is defined in + -- package System.Aux_Dec which is not available in those platforms. + + if VM_Target = No_VM + and then not Present (Corresponding_Formal_Spec (N)) + and then Etype (Nam) /= RTE (RE_AST_Handler) + then + declare + P : constant Entity_Id := Prefix (Nam); + + begin + Find_Type (P); + + if Is_Tagged_Type (Etype (P)) then + Ensure_Freeze_Node (Etype (P)); + Append_Freeze_Action (Etype (P), Body_Node); + else + Rewrite (N, Body_Node); + Analyze (N); + Set_Etype (New_S, Base_Type (Etype (New_S))); + end if; + end; + + -- Generic formal subprograms or AST_Handler renaming + + else + Rewrite (N, Body_Node); + Analyze (N); + Set_Etype (New_S, Base_Type (Etype (New_S))); + end if; + + if Is_Compilation_Unit (New_S) then + Error_Msg_N + ("a library unit can only rename another library unit", N); + end if; + + -- We suppress elaboration warnings for the resulting entity, since + -- clearly they are not needed, and more particularly, in the case + -- of a generic formal subprogram, the resulting entity can appear + -- after the instantiation itself, and thus look like a bogus case + -- of access before elaboration. + + Set_Suppress_Elaboration_Warnings (New_S); + + end Attribute_Renaming; + + ---------------------- + -- Chain_Use_Clause -- + ---------------------- + + procedure Chain_Use_Clause (N : Node_Id) is + Pack : Entity_Id; + Level : Int := Scope_Stack.Last; + + begin + if not Is_Compilation_Unit (Current_Scope) + or else not Is_Child_Unit (Current_Scope) + then + null; -- Common case + + elsif Defining_Entity (Parent (N)) = Current_Scope then + null; -- Common case for compilation unit + + else + -- If declaration appears in some other scope, it must be in some + -- parent unit when compiling a child. + + Pack := Defining_Entity (Parent (N)); + if not In_Open_Scopes (Pack) then + null; -- default as well + + else + -- Find entry for parent unit in scope stack + + while Scope_Stack.Table (Level).Entity /= Pack loop + Level := Level - 1; + end loop; + end if; + end if; + + Set_Next_Use_Clause (N, + Scope_Stack.Table (Level).First_Use_Clause); + Scope_Stack.Table (Level).First_Use_Clause := N; + end Chain_Use_Clause; + + --------------------------- + -- Check_Frozen_Renaming -- + --------------------------- + + procedure Check_Frozen_Renaming (N : Node_Id; Subp : Entity_Id) is + B_Node : Node_Id; + Old_S : Entity_Id; + + begin + if Is_Frozen (Subp) + and then not Has_Completion (Subp) + then + B_Node := + Build_Renamed_Body + (Parent (Declaration_Node (Subp)), Defining_Entity (N)); + + if Is_Entity_Name (Name (N)) then + Old_S := Entity (Name (N)); + + if not Is_Frozen (Old_S) + and then Operating_Mode /= Check_Semantics + then + Append_Freeze_Action (Old_S, B_Node); + else + Insert_After (N, B_Node); + Analyze (B_Node); + end if; + + if Is_Intrinsic_Subprogram (Old_S) + and then not In_Instance + then + Error_Msg_N + ("subprogram used in renaming_as_body cannot be intrinsic", + Name (N)); + end if; + + else + Insert_After (N, B_Node); + Analyze (B_Node); + end if; + end if; + end Check_Frozen_Renaming; + + ------------------------------- + -- Set_Entity_Or_Discriminal -- + ------------------------------- + + procedure Set_Entity_Or_Discriminal (N : Node_Id; E : Entity_Id) is + P : Node_Id; + + begin + -- If the entity is not a discriminant, or else expansion is disabled, + -- simply set the entity. + + if not In_Spec_Expression + or else Ekind (E) /= E_Discriminant + or else Inside_A_Generic + then + Set_Entity_With_Style_Check (N, E); + + -- The replacement of a discriminant by the corresponding discriminal + -- is not done for a task discriminant that appears in a default + -- expression of an entry parameter. See Exp_Ch2.Expand_Discriminant + -- for details on their handling. + + elsif Is_Concurrent_Type (Scope (E)) then + + P := Parent (N); + while Present (P) + and then not Nkind_In (P, N_Parameter_Specification, + N_Component_Declaration) + loop + P := Parent (P); + end loop; + + if Present (P) + and then Nkind (P) = N_Parameter_Specification + then + null; + + else + Set_Entity (N, Discriminal (E)); + end if; + + -- Otherwise, this is a discriminant in a context in which + -- it is a reference to the corresponding parameter of the + -- init proc for the enclosing type. + + else + Set_Entity (N, Discriminal (E)); + end if; + end Set_Entity_Or_Discriminal; + + ----------------------------------- + -- Check_In_Previous_With_Clause -- + ----------------------------------- + + procedure Check_In_Previous_With_Clause + (N : Node_Id; + Nam : Entity_Id) + is + Pack : constant Entity_Id := Entity (Original_Node (Nam)); + Item : Node_Id; + Par : Node_Id; + + begin + Item := First (Context_Items (Parent (N))); + + while Present (Item) + and then Item /= N + loop + if Nkind (Item) = N_With_Clause + + -- Protect the frontend against previous critical errors + + and then Nkind (Name (Item)) /= N_Selected_Component + and then Entity (Name (Item)) = Pack + then + Par := Nam; + + -- Find root library unit in with_clause + + while Nkind (Par) = N_Expanded_Name loop + Par := Prefix (Par); + end loop; + + if Is_Child_Unit (Entity (Original_Node (Par))) then + Error_Msg_NE ("& is not directly visible", Par, Entity (Par)); + else + return; + end if; + end if; + + Next (Item); + end loop; + + -- On exit, package is not mentioned in a previous with_clause. + -- Check if its prefix is. + + if Nkind (Nam) = N_Expanded_Name then + Check_In_Previous_With_Clause (N, Prefix (Nam)); + + elsif Pack /= Any_Id then + Error_Msg_NE ("& is not visible", Nam, Pack); + end if; + end Check_In_Previous_With_Clause; + + --------------------------------- + -- Check_Library_Unit_Renaming -- + --------------------------------- + + procedure Check_Library_Unit_Renaming (N : Node_Id; Old_E : Entity_Id) is + New_E : Entity_Id; + + begin + if Nkind (Parent (N)) /= N_Compilation_Unit then + return; + + -- Check for library unit. Note that we used to check for the scope + -- being Standard here, but that was wrong for Standard itself. + + elsif not Is_Compilation_Unit (Old_E) + and then not Is_Child_Unit (Old_E) + then + Error_Msg_N ("renamed unit must be a library unit", Name (N)); + + -- Entities defined in Standard (operators and boolean literals) cannot + -- be renamed as library units. + + elsif Scope (Old_E) = Standard_Standard + and then Sloc (Old_E) = Standard_Location + then + Error_Msg_N ("renamed unit must be a library unit", Name (N)); + + elsif Present (Parent_Spec (N)) + and then Nkind (Unit (Parent_Spec (N))) = N_Generic_Package_Declaration + and then not Is_Child_Unit (Old_E) + then + Error_Msg_N + ("renamed unit must be a child unit of generic parent", Name (N)); + + elsif Nkind (N) in N_Generic_Renaming_Declaration + and then Nkind (Name (N)) = N_Expanded_Name + and then Is_Generic_Instance (Entity (Prefix (Name (N)))) + and then Is_Generic_Unit (Old_E) + then + Error_Msg_N + ("renamed generic unit must be a library unit", Name (N)); + + elsif Is_Package_Or_Generic_Package (Old_E) then + + -- Inherit categorization flags + + New_E := Defining_Entity (N); + Set_Is_Pure (New_E, Is_Pure (Old_E)); + Set_Is_Preelaborated (New_E, Is_Preelaborated (Old_E)); + Set_Is_Remote_Call_Interface (New_E, + Is_Remote_Call_Interface (Old_E)); + Set_Is_Remote_Types (New_E, Is_Remote_Types (Old_E)); + Set_Is_Shared_Passive (New_E, Is_Shared_Passive (Old_E)); + end if; + end Check_Library_Unit_Renaming; + + --------------- + -- End_Scope -- + --------------- + + procedure End_Scope is + Id : Entity_Id; + Prev : Entity_Id; + Outer : Entity_Id; + + begin + Id := First_Entity (Current_Scope); + while Present (Id) loop + -- An entity in the current scope is not necessarily the first one + -- on its homonym chain. Find its predecessor if any, + -- If it is an internal entity, it will not be in the visibility + -- chain altogether, and there is nothing to unchain. + + if Id /= Current_Entity (Id) then + Prev := Current_Entity (Id); + while Present (Prev) + and then Present (Homonym (Prev)) + and then Homonym (Prev) /= Id + loop + Prev := Homonym (Prev); + end loop; + + -- Skip to end of loop if Id is not in the visibility chain + + if No (Prev) or else Homonym (Prev) /= Id then + goto Next_Ent; + end if; + + else + Prev := Empty; + end if; + + Set_Is_Immediately_Visible (Id, False); + + Outer := Homonym (Id); + while Present (Outer) and then Scope (Outer) = Current_Scope loop + Outer := Homonym (Outer); + end loop; + + -- Reset homonym link of other entities, but do not modify link + -- between entities in current scope, so that the back-end can have + -- a proper count of local overloadings. + + if No (Prev) then + Set_Name_Entity_Id (Chars (Id), Outer); + + elsif Scope (Prev) /= Scope (Id) then + Set_Homonym (Prev, Outer); + end if; + + <> + Next_Entity (Id); + end loop; + + -- If the scope generated freeze actions, place them before the + -- current declaration and analyze them. Type declarations and + -- the bodies of initialization procedures can generate such nodes. + -- We follow the parent chain until we reach a list node, which is + -- the enclosing list of declarations. If the list appears within + -- a protected definition, move freeze nodes outside the protected + -- type altogether. + + if Present + (Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions) + then + declare + Decl : Node_Id; + L : constant List_Id := Scope_Stack.Table + (Scope_Stack.Last).Pending_Freeze_Actions; + + begin + if Is_Itype (Current_Scope) then + Decl := Associated_Node_For_Itype (Current_Scope); + else + Decl := Parent (Current_Scope); + end if; + + Pop_Scope; + + while not (Is_List_Member (Decl)) + or else Nkind_In (Parent (Decl), N_Protected_Definition, + N_Task_Definition) + loop + Decl := Parent (Decl); + end loop; + + Insert_List_Before_And_Analyze (Decl, L); + end; + + else + Pop_Scope; + end if; + + end End_Scope; + + --------------------- + -- End_Use_Clauses -- + --------------------- + + procedure End_Use_Clauses (Clause : Node_Id) is + U : Node_Id; + + begin + -- Remove Use_Type clauses first, because they affect the + -- visibility of operators in subsequent used packages. + + U := Clause; + while Present (U) loop + if Nkind (U) = N_Use_Type_Clause then + End_Use_Type (U); + end if; + + Next_Use_Clause (U); + end loop; + + U := Clause; + while Present (U) loop + if Nkind (U) = N_Use_Package_Clause then + End_Use_Package (U); + end if; + + Next_Use_Clause (U); + end loop; + end End_Use_Clauses; + + --------------------- + -- End_Use_Package -- + --------------------- + + procedure End_Use_Package (N : Node_Id) is + Pack_Name : Node_Id; + Pack : Entity_Id; + Id : Entity_Id; + Elmt : Elmt_Id; + + function Is_Primitive_Operator_In_Use + (Op : Entity_Id; + F : Entity_Id) return Boolean; + -- Check whether Op is a primitive operator of a use-visible type + + ---------------------------------- + -- Is_Primitive_Operator_In_Use -- + ---------------------------------- + + function Is_Primitive_Operator_In_Use + (Op : Entity_Id; + F : Entity_Id) return Boolean + is + T : constant Entity_Id := Etype (F); + begin + return (In_Use (T) + or else Present (Current_Use_Clause (Base_Type (T)))) + and then Scope (T) = Scope (Op); + end Is_Primitive_Operator_In_Use; + + -- Start of processing for End_Use_Package + + begin + Pack_Name := First (Names (N)); + while Present (Pack_Name) loop + + -- Test that Pack_Name actually denotes a package before processing + + if Is_Entity_Name (Pack_Name) + and then Ekind (Entity (Pack_Name)) = E_Package + then + Pack := Entity (Pack_Name); + + if In_Open_Scopes (Pack) then + null; + + elsif not Redundant_Use (Pack_Name) then + Set_In_Use (Pack, False); + Set_Current_Use_Clause (Pack, Empty); + + Id := First_Entity (Pack); + while Present (Id) loop + + -- Preserve use-visibility of operators that are primitive + -- operators of a type that is use-visible through an active + -- use_type clause. + + if Nkind (Id) = N_Defining_Operator_Symbol + and then + (Is_Primitive_Operator_In_Use + (Id, First_Formal (Id)) + or else + (Present (Next_Formal (First_Formal (Id))) + and then + Is_Primitive_Operator_In_Use + (Id, Next_Formal (First_Formal (Id))))) + then + null; + + else + Set_Is_Potentially_Use_Visible (Id, False); + end if; + + if Is_Private_Type (Id) + and then Present (Full_View (Id)) + then + Set_Is_Potentially_Use_Visible (Full_View (Id), False); + end if; + + Next_Entity (Id); + end loop; + + if Present (Renamed_Object (Pack)) then + Set_In_Use (Renamed_Object (Pack), False); + Set_Current_Use_Clause (Renamed_Object (Pack), Empty); + end if; + + if Chars (Pack) = Name_System + and then Scope (Pack) = Standard_Standard + and then Present_System_Aux + then + Id := First_Entity (System_Aux_Id); + while Present (Id) loop + Set_Is_Potentially_Use_Visible (Id, False); + + if Is_Private_Type (Id) + and then Present (Full_View (Id)) + then + Set_Is_Potentially_Use_Visible (Full_View (Id), False); + end if; + + Next_Entity (Id); + end loop; + + Set_In_Use (System_Aux_Id, False); + end if; + + else + Set_Redundant_Use (Pack_Name, False); + end if; + end if; + + Next (Pack_Name); + end loop; + + if Present (Hidden_By_Use_Clause (N)) then + Elmt := First_Elmt (Hidden_By_Use_Clause (N)); + while Present (Elmt) loop + declare + E : constant Entity_Id := Node (Elmt); + + begin + -- Reset either Use_Visibility or Direct_Visibility, depending + -- on how the entity was hidden by the use clause. + + if In_Use (Scope (E)) + and then Used_As_Generic_Actual (Scope (E)) + then + Set_Is_Potentially_Use_Visible (Node (Elmt)); + else + Set_Is_Immediately_Visible (Node (Elmt)); + end if; + + Next_Elmt (Elmt); + end; + end loop; + + Set_Hidden_By_Use_Clause (N, No_Elist); + end if; + end End_Use_Package; + + ------------------ + -- End_Use_Type -- + ------------------ + + procedure End_Use_Type (N : Node_Id) is + Elmt : Elmt_Id; + Id : Entity_Id; + Op_List : Elist_Id; + Op : Entity_Id; + T : Entity_Id; + + function May_Be_Used_Primitive_Of (T : Entity_Id) return Boolean; + -- An operator may be primitive in several types, if they are declared + -- in the same scope as the operator. To determine the use-visibility of + -- the operator in such cases we must examine all types in the profile. + + ------------------------------ + -- May_Be_Used_Primitive_Of -- + ------------------------------ + + function May_Be_Used_Primitive_Of (T : Entity_Id) return Boolean is + begin + return Scope (Op) = Scope (T) + and then (In_Use (T) or else Is_Potentially_Use_Visible (T)); + end May_Be_Used_Primitive_Of; + + -- Start of processing for End_Use_Type + + begin + Id := First (Subtype_Marks (N)); + while Present (Id) loop + + -- A call to Rtsfind may occur while analyzing a use_type clause, + -- in which case the type marks are not resolved yet, and there is + -- nothing to remove. + + if not Is_Entity_Name (Id) or else No (Entity (Id)) then + goto Continue; + end if; + + T := Entity (Id); + + if T = Any_Type or else From_With_Type (T) then + null; + + -- Note that the use_type clause may mention a subtype of the type + -- whose primitive operations have been made visible. Here as + -- elsewhere, it is the base type that matters for visibility. + + elsif In_Open_Scopes (Scope (Base_Type (T))) then + null; + + elsif not Redundant_Use (Id) then + Set_In_Use (T, False); + Set_In_Use (Base_Type (T), False); + Set_Current_Use_Clause (T, Empty); + Set_Current_Use_Clause (Base_Type (T), Empty); + Op_List := Collect_Primitive_Operations (T); + + Elmt := First_Elmt (Op_List); + while Present (Elmt) loop + Op := Node (Elmt); + + if Nkind (Op) = N_Defining_Operator_Symbol then + declare + T_First : constant Entity_Id := + Base_Type (Etype (First_Formal (Op))); + T_Res : constant Entity_Id := Base_Type (Etype (Op)); + T_Next : Entity_Id; + + begin + if Present (Next_Formal (First_Formal (Op))) then + T_Next := + Base_Type (Etype (Next_Formal (First_Formal (Op)))); + else + T_Next := T_First; + end if; + + if not May_Be_Used_Primitive_Of (T_First) + and then not May_Be_Used_Primitive_Of (T_Next) + and then not May_Be_Used_Primitive_Of (T_Res) + then + Set_Is_Potentially_Use_Visible (Op, False); + end if; + end; + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + <> + Next (Id); + end loop; + end End_Use_Type; + + ---------------------- + -- Find_Direct_Name -- + ---------------------- + + procedure Find_Direct_Name (N : Node_Id) is + E : Entity_Id; + E2 : Entity_Id; + Msg : Boolean; + + Inst : Entity_Id := Empty; + -- Enclosing instance, if any + + Homonyms : Entity_Id; + -- Saves start of homonym chain + + Nvis_Entity : Boolean; + -- Set True to indicate that there is at least one entity on the homonym + -- chain which, while not visible, is visible enough from the user point + -- of view to warrant an error message of "not visible" rather than + -- undefined. + + Nvis_Is_Private_Subprg : Boolean := False; + -- Ada 2005 (AI-262): Set True to indicate that a form of Beaujolais + -- effect concerning library subprograms has been detected. Used to + -- generate the precise error message. + + function From_Actual_Package (E : Entity_Id) return Boolean; + -- Returns true if the entity is declared in a package that is + -- an actual for a formal package of the current instance. Such an + -- entity requires special handling because it may be use-visible + -- but hides directly visible entities defined outside the instance. + + function Is_Actual_Parameter return Boolean; + -- This function checks if the node N is an identifier that is an actual + -- parameter of a procedure call. If so it returns True, otherwise it + -- return False. The reason for this check is that at this stage we do + -- not know what procedure is being called if the procedure might be + -- overloaded, so it is premature to go setting referenced flags or + -- making calls to Generate_Reference. We will wait till Resolve_Actuals + -- for that processing + + function Known_But_Invisible (E : Entity_Id) return Boolean; + -- This function determines whether the entity E (which is not + -- visible) can reasonably be considered to be known to the writer + -- of the reference. This is a heuristic test, used only for the + -- purposes of figuring out whether we prefer to complain that an + -- entity is undefined or invisible (and identify the declaration + -- of the invisible entity in the latter case). The point here is + -- that we don't want to complain that something is invisible and + -- then point to something entirely mysterious to the writer. + + procedure Nvis_Messages; + -- Called if there are no visible entries for N, but there is at least + -- one non-directly visible, or hidden declaration. This procedure + -- outputs an appropriate set of error messages. + + procedure Undefined (Nvis : Boolean); + -- This function is called if the current node has no corresponding + -- visible entity or entities. The value set in Msg indicates whether + -- an error message was generated (multiple error messages for the + -- same variable are generally suppressed, see body for details). + -- Msg is True if an error message was generated, False if not. This + -- value is used by the caller to determine whether or not to output + -- additional messages where appropriate. The parameter is set False + -- to get the message "X is undefined", and True to get the message + -- "X is not visible". + + ------------------------- + -- From_Actual_Package -- + ------------------------- + + function From_Actual_Package (E : Entity_Id) return Boolean is + Scop : constant Entity_Id := Scope (E); + Act : Entity_Id; + + begin + if not In_Instance then + return False; + else + Inst := Current_Scope; + while Present (Inst) + and then Ekind (Inst) /= E_Package + and then not Is_Generic_Instance (Inst) + loop + Inst := Scope (Inst); + end loop; + + if No (Inst) then + return False; + end if; + + Act := First_Entity (Inst); + while Present (Act) loop + if Ekind (Act) = E_Package then + + -- Check for end of actuals list + + if Renamed_Object (Act) = Inst then + return False; + + elsif Present (Associated_Formal_Package (Act)) + and then Renamed_Object (Act) = Scop + then + -- Entity comes from (instance of) formal package + + return True; + + else + Next_Entity (Act); + end if; + + else + Next_Entity (Act); + end if; + end loop; + + return False; + end if; + end From_Actual_Package; + + ------------------------- + -- Is_Actual_Parameter -- + ------------------------- + + function Is_Actual_Parameter return Boolean is + begin + return + Nkind (N) = N_Identifier + and then + (Nkind (Parent (N)) = N_Procedure_Call_Statement + or else + (Nkind (Parent (N)) = N_Parameter_Association + and then N = Explicit_Actual_Parameter (Parent (N)) + and then Nkind (Parent (Parent (N))) = + N_Procedure_Call_Statement)); + end Is_Actual_Parameter; + + ------------------------- + -- Known_But_Invisible -- + ------------------------- + + function Known_But_Invisible (E : Entity_Id) return Boolean is + Fname : File_Name_Type; + + begin + -- Entities in Standard are always considered to be known + + if Sloc (E) <= Standard_Location then + return True; + + -- An entity that does not come from source is always considered + -- to be unknown, since it is an artifact of code expansion. + + elsif not Comes_From_Source (E) then + return False; + + -- In gnat internal mode, we consider all entities known + + elsif GNAT_Mode then + return True; + end if; + + -- Here we have an entity that is not from package Standard, and + -- which comes from Source. See if it comes from an internal file. + + Fname := Unit_File_Name (Get_Source_Unit (E)); + + -- Case of from internal file + + if Is_Internal_File_Name (Fname) then + + -- Private part entities in internal files are never considered + -- to be known to the writer of normal application code. + + if Is_Hidden (E) then + return False; + end if; + + -- Entities from System packages other than System and + -- System.Storage_Elements are not considered to be known. + -- System.Auxxxx files are also considered known to the user. + + -- Should refine this at some point to generally distinguish + -- between known and unknown internal files ??? + + Get_Name_String (Fname); + + return + Name_Len < 2 + or else + Name_Buffer (1 .. 2) /= "s-" + or else + Name_Buffer (3 .. 8) = "stoele" + or else + Name_Buffer (3 .. 5) = "aux"; + + -- If not an internal file, then entity is definitely known, + -- even if it is in a private part (the message generated will + -- note that it is in a private part) + + else + return True; + end if; + end Known_But_Invisible; + + ------------------- + -- Nvis_Messages -- + ------------------- + + procedure Nvis_Messages is + Comp_Unit : Node_Id; + Ent : Entity_Id; + Found : Boolean := False; + Hidden : Boolean := False; + Item : Node_Id; + + begin + -- Ada 2005 (AI-262): Generate a precise error concerning the + -- Beaujolais effect that was previously detected + + if Nvis_Is_Private_Subprg then + + pragma Assert (Nkind (E2) = N_Defining_Identifier + and then Ekind (E2) = E_Function + and then Scope (E2) = Standard_Standard + and then Has_Private_With (E2)); + + -- Find the sloc corresponding to the private with'ed unit + + Comp_Unit := Cunit (Current_Sem_Unit); + Error_Msg_Sloc := No_Location; + + Item := First (Context_Items (Comp_Unit)); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then Private_Present (Item) + and then Entity (Name (Item)) = E2 + then + Error_Msg_Sloc := Sloc (Item); + exit; + end if; + + Next (Item); + end loop; + + pragma Assert (Error_Msg_Sloc /= No_Location); + + Error_Msg_N ("(Ada 2005): hidden by private with clause #", N); + return; + end if; + + Undefined (Nvis => True); + + if Msg then + + -- First loop does hidden declarations + + Ent := Homonyms; + while Present (Ent) loop + if Is_Potentially_Use_Visible (Ent) then + if not Hidden then + Error_Msg_N -- CODEFIX + ("multiple use clauses cause hiding!", N); + Hidden := True; + end if; + + Error_Msg_Sloc := Sloc (Ent); + Error_Msg_N -- CODEFIX + ("hidden declaration#!", N); + end if; + + Ent := Homonym (Ent); + end loop; + + -- If we found hidden declarations, then that's enough, don't + -- bother looking for non-visible declarations as well. + + if Hidden then + return; + end if; + + -- Second loop does non-directly visible declarations + + Ent := Homonyms; + while Present (Ent) loop + if not Is_Potentially_Use_Visible (Ent) then + + -- Do not bother the user with unknown entities + + if not Known_But_Invisible (Ent) then + goto Continue; + end if; + + Error_Msg_Sloc := Sloc (Ent); + + -- Output message noting that there is a non-visible + -- declaration, distinguishing the private part case. + + if Is_Hidden (Ent) then + Error_Msg_N ("non-visible (private) declaration#!", N); + + -- If the entity is declared in a generic package, it + -- cannot be visible, so there is no point in adding it + -- to the list of candidates if another homograph from a + -- non-generic package has been seen. + + elsif Ekind (Scope (Ent)) = E_Generic_Package + and then Found + then + null; + + else + Error_Msg_N -- CODEFIX + ("non-visible declaration#!", N); + + if Ekind (Scope (Ent)) /= E_Generic_Package then + Found := True; + end if; + + if Is_Compilation_Unit (Ent) + and then + Nkind (Parent (Parent (N))) = N_Use_Package_Clause + then + Error_Msg_Qual_Level := 99; + Error_Msg_NE -- CODEFIX + ("\\missing `WITH &;`", N, Ent); + Error_Msg_Qual_Level := 0; + end if; + + if Ekind (Ent) = E_Discriminant + and then Present (Corresponding_Discriminant (Ent)) + and then Scope (Corresponding_Discriminant (Ent)) = + Etype (Scope (Ent)) + then + Error_Msg_N + ("inherited discriminant not allowed here" & + " (RM 3.8 (12), 3.8.1 (6))!", N); + end if; + end if; + + -- Set entity and its containing package as referenced. We + -- can't be sure of this, but this seems a better choice + -- to avoid unused entity messages. + + if Comes_From_Source (Ent) then + Set_Referenced (Ent); + Set_Referenced (Cunit_Entity (Get_Source_Unit (Ent))); + end if; + end if; + + <> + Ent := Homonym (Ent); + end loop; + end if; + end Nvis_Messages; + + --------------- + -- Undefined -- + --------------- + + procedure Undefined (Nvis : Boolean) is + Emsg : Error_Msg_Id; + + begin + -- We should never find an undefined internal name. If we do, then + -- see if we have previous errors. If so, ignore on the grounds that + -- it is probably a cascaded message (e.g. a block label from a badly + -- formed block). If no previous errors, then we have a real internal + -- error of some kind so raise an exception. + + if Is_Internal_Name (Chars (N)) then + if Total_Errors_Detected /= 0 then + return; + else + raise Program_Error; + end if; + end if; + + -- A very specialized error check, if the undefined variable is + -- a case tag, and the case type is an enumeration type, check + -- for a possible misspelling, and if so, modify the identifier + + -- Named aggregate should also be handled similarly ??? + + if Nkind (N) = N_Identifier + and then Nkind (Parent (N)) = N_Case_Statement_Alternative + then + declare + Case_Stm : constant Node_Id := Parent (Parent (N)); + Case_Typ : constant Entity_Id := Etype (Expression (Case_Stm)); + + Lit : Node_Id; + + begin + if Is_Enumeration_Type (Case_Typ) + and then not Is_Standard_Character_Type (Case_Typ) + then + Lit := First_Literal (Case_Typ); + Get_Name_String (Chars (Lit)); + + if Chars (Lit) /= Chars (N) + and then Is_Bad_Spelling_Of (Chars (N), Chars (Lit)) then + Error_Msg_Node_2 := Lit; + Error_Msg_N -- CODEFIX + ("& is undefined, assume misspelling of &", N); + Rewrite (N, New_Occurrence_Of (Lit, Sloc (N))); + return; + end if; + + Lit := Next_Literal (Lit); + end if; + end; + end if; + + -- Normal processing + + Set_Entity (N, Any_Id); + Set_Etype (N, Any_Type); + + -- We use the table Urefs to keep track of entities for which we + -- have issued errors for undefined references. Multiple errors + -- for a single name are normally suppressed, however we modify + -- the error message to alert the programmer to this effect. + + for J in Urefs.First .. Urefs.Last loop + if Chars (N) = Chars (Urefs.Table (J).Node) then + if Urefs.Table (J).Err /= No_Error_Msg + and then Sloc (N) /= Urefs.Table (J).Loc + then + Error_Msg_Node_1 := Urefs.Table (J).Node; + + if Urefs.Table (J).Nvis then + Change_Error_Text (Urefs.Table (J).Err, + "& is not visible (more references follow)"); + else + Change_Error_Text (Urefs.Table (J).Err, + "& is undefined (more references follow)"); + end if; + + Urefs.Table (J).Err := No_Error_Msg; + end if; + + -- Although we will set Msg False, and thus suppress the + -- message, we also set Error_Posted True, to avoid any + -- cascaded messages resulting from the undefined reference. + + Msg := False; + Set_Error_Posted (N, True); + return; + end if; + end loop; + + -- If entry not found, this is first undefined occurrence + + if Nvis then + Error_Msg_N ("& is not visible!", N); + Emsg := Get_Msg_Id; + + else + Error_Msg_N ("& is undefined!", N); + Emsg := Get_Msg_Id; + + -- A very bizarre special check, if the undefined identifier + -- is put or put_line, then add a special error message (since + -- this is a very common error for beginners to make). + + if Chars (N) = Name_Put or else Chars (N) = Name_Put_Line then + Error_Msg_N -- CODEFIX + ("\\possible missing `WITH Ada.Text_'I'O; " & + "USE Ada.Text_'I'O`!", N); + + -- Another special check if N is the prefix of a selected + -- component which is a known unit, add message complaining + -- about missing with for this unit. + + elsif Nkind (Parent (N)) = N_Selected_Component + and then N = Prefix (Parent (N)) + and then Is_Known_Unit (Parent (N)) + then + Error_Msg_Node_2 := Selector_Name (Parent (N)); + Error_Msg_N -- CODEFIX + ("\\missing `WITH &.&;`", Prefix (Parent (N))); + end if; + + -- Now check for possible misspellings + + declare + E : Entity_Id; + Ematch : Entity_Id := Empty; + + Last_Name_Id : constant Name_Id := + Name_Id (Nat (First_Name_Id) + + Name_Entries_Count - 1); + + begin + for Nam in First_Name_Id .. Last_Name_Id loop + E := Get_Name_Entity_Id (Nam); + + if Present (E) + and then (Is_Immediately_Visible (E) + or else + Is_Potentially_Use_Visible (E)) + then + if Is_Bad_Spelling_Of (Chars (N), Nam) then + Ematch := E; + exit; + end if; + end if; + end loop; + + if Present (Ematch) then + Error_Msg_NE -- CODEFIX + ("\possible misspelling of&", N, Ematch); + end if; + end; + end if; + + -- Make entry in undefined references table unless the full errors + -- switch is set, in which case by refraining from generating the + -- table entry, we guarantee that we get an error message for every + -- undefined reference. + + if not All_Errors_Mode then + Urefs.Append ( + (Node => N, + Err => Emsg, + Nvis => Nvis, + Loc => Sloc (N))); + end if; + + Msg := True; + end Undefined; + + -- Start of processing for Find_Direct_Name + + begin + -- If the entity pointer is already set, this is an internal node, or + -- a node that is analyzed more than once, after a tree modification. + -- In such a case there is no resolution to perform, just set the type. + + if Present (Entity (N)) then + if Is_Type (Entity (N)) then + Set_Etype (N, Entity (N)); + + else + declare + Entyp : constant Entity_Id := Etype (Entity (N)); + + begin + -- One special case here. If the Etype field is already set, + -- and references the packed array type corresponding to the + -- etype of the referenced entity, then leave it alone. This + -- happens for trees generated from Exp_Pakd, where expressions + -- can be deliberately "mis-typed" to the packed array type. + + if Is_Array_Type (Entyp) + and then Is_Packed (Entyp) + and then Present (Etype (N)) + and then Etype (N) = Packed_Array_Type (Entyp) + then + null; + + -- If not that special case, then just reset the Etype + + else + Set_Etype (N, Etype (Entity (N))); + end if; + end; + end if; + + return; + end if; + + -- Here if Entity pointer was not set, we need full visibility analysis + -- First we generate debugging output if the debug E flag is set. + + if Debug_Flag_E then + Write_Str ("Looking for "); + Write_Name (Chars (N)); + Write_Eol; + end if; + + Homonyms := Current_Entity (N); + Nvis_Entity := False; + + E := Homonyms; + while Present (E) loop + + -- If entity is immediately visible or potentially use visible, then + -- process the entity and we are done. + + if Is_Immediately_Visible (E) then + goto Immediately_Visible_Entity; + + elsif Is_Potentially_Use_Visible (E) then + goto Potentially_Use_Visible_Entity; + + -- Note if a known but invisible entity encountered + + elsif Known_But_Invisible (E) then + Nvis_Entity := True; + end if; + + -- Move to next entity in chain and continue search + + E := Homonym (E); + end loop; + + -- If no entries on homonym chain that were potentially visible, + -- and no entities reasonably considered as non-visible, then + -- we have a plain undefined reference, with no additional + -- explanation required! + + if not Nvis_Entity then + Undefined (Nvis => False); + + -- Otherwise there is at least one entry on the homonym chain that + -- is reasonably considered as being known and non-visible. + + else + Nvis_Messages; + end if; + + return; + + -- Processing for a potentially use visible entry found. We must search + -- the rest of the homonym chain for two reasons. First, if there is a + -- directly visible entry, then none of the potentially use-visible + -- entities are directly visible (RM 8.4(10)). Second, we need to check + -- for the case of multiple potentially use-visible entries hiding one + -- another and as a result being non-directly visible (RM 8.4(11)). + + <> declare + Only_One_Visible : Boolean := True; + All_Overloadable : Boolean := Is_Overloadable (E); + + begin + E2 := Homonym (E); + while Present (E2) loop + if Is_Immediately_Visible (E2) then + + -- If the use-visible entity comes from the actual for a + -- formal package, it hides a directly visible entity from + -- outside the instance. + + if From_Actual_Package (E) + and then Scope_Depth (E2) < Scope_Depth (Inst) + then + goto Found; + else + E := E2; + goto Immediately_Visible_Entity; + end if; + + elsif Is_Potentially_Use_Visible (E2) then + Only_One_Visible := False; + All_Overloadable := All_Overloadable and Is_Overloadable (E2); + + -- Ada 2005 (AI-262): Protect against a form of Beaujolais effect + -- that can occur in private_with clauses. Example: + + -- with A; + -- private with B; package A is + -- package C is function B return Integer; + -- use A; end A; + -- V1 : Integer := B; + -- private function B return Integer; + -- V2 : Integer := B; + -- end C; + + -- V1 resolves to A.B, but V2 resolves to library unit B + + elsif Ekind (E2) = E_Function + and then Scope (E2) = Standard_Standard + and then Has_Private_With (E2) + then + Only_One_Visible := False; + All_Overloadable := False; + Nvis_Is_Private_Subprg := True; + exit; + end if; + + E2 := Homonym (E2); + end loop; + + -- On falling through this loop, we have checked that there are no + -- immediately visible entities. Only_One_Visible is set if exactly + -- one potentially use visible entity exists. All_Overloadable is + -- set if all the potentially use visible entities are overloadable. + -- The condition for legality is that either there is one potentially + -- use visible entity, or if there is more than one, then all of them + -- are overloadable. + + if Only_One_Visible or All_Overloadable then + goto Found; + + -- If there is more than one potentially use-visible entity and at + -- least one of them non-overloadable, we have an error (RM 8.4(11). + -- Note that E points to the first such entity on the homonym list. + -- Special case: if one of the entities is declared in an actual + -- package, it was visible in the generic, and takes precedence over + -- other entities that are potentially use-visible. Same if it is + -- declared in a local instantiation of the current instance. + + else + if In_Instance then + + -- Find current instance + + Inst := Current_Scope; + while Present (Inst) + and then Inst /= Standard_Standard + loop + if Is_Generic_Instance (Inst) then + exit; + end if; + + Inst := Scope (Inst); + end loop; + + E2 := E; + while Present (E2) loop + if From_Actual_Package (E2) + or else + (Is_Generic_Instance (Scope (E2)) + and then Scope_Depth (Scope (E2)) > Scope_Depth (Inst)) + then + E := E2; + goto Found; + end if; + + E2 := Homonym (E2); + end loop; + + Nvis_Messages; + return; + + elsif + Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit)) + then + -- A use-clause in the body of a system file creates conflict + -- with some entity in a user scope, while rtsfind is active. + -- Keep only the entity coming from another predefined unit. + + E2 := E; + while Present (E2) loop + if Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Sloc (E2)))) + then + E := E2; + goto Found; + end if; + + E2 := Homonym (E2); + end loop; + + -- Entity must exist because predefined unit is correct + + raise Program_Error; + + else + Nvis_Messages; + return; + end if; + end if; + end; + + -- Come here with E set to the first immediately visible entity on + -- the homonym chain. This is the one we want unless there is another + -- immediately visible entity further on in the chain for an inner + -- scope (RM 8.3(8)). + + <> declare + Level : Int; + Scop : Entity_Id; + + begin + -- Find scope level of initial entity. When compiling through + -- Rtsfind, the previous context is not completely invisible, and + -- an outer entity may appear on the chain, whose scope is below + -- the entry for Standard that delimits the current scope stack. + -- Indicate that the level for this spurious entry is outside of + -- the current scope stack. + + Level := Scope_Stack.Last; + loop + Scop := Scope_Stack.Table (Level).Entity; + exit when Scop = Scope (E); + Level := Level - 1; + exit when Scop = Standard_Standard; + end loop; + + -- Now search remainder of homonym chain for more inner entry + -- If the entity is Standard itself, it has no scope, and we + -- compare it with the stack entry directly. + + E2 := Homonym (E); + while Present (E2) loop + if Is_Immediately_Visible (E2) then + + -- If a generic package contains a local declaration that + -- has the same name as the generic, there may be a visibility + -- conflict in an instance, where the local declaration must + -- also hide the name of the corresponding package renaming. + -- We check explicitly for a package declared by a renaming, + -- whose renamed entity is an instance that is on the scope + -- stack, and that contains a homonym in the same scope. Once + -- we have found it, we know that the package renaming is not + -- immediately visible, and that the identifier denotes the + -- other entity (and its homonyms if overloaded). + + if Scope (E) = Scope (E2) + and then Ekind (E) = E_Package + and then Present (Renamed_Object (E)) + and then Is_Generic_Instance (Renamed_Object (E)) + and then In_Open_Scopes (Renamed_Object (E)) + and then Comes_From_Source (N) + then + Set_Is_Immediately_Visible (E, False); + E := E2; + + else + for J in Level + 1 .. Scope_Stack.Last loop + if Scope_Stack.Table (J).Entity = Scope (E2) + or else Scope_Stack.Table (J).Entity = E2 + then + Level := J; + E := E2; + exit; + end if; + end loop; + end if; + end if; + + E2 := Homonym (E2); + end loop; + + -- At the end of that loop, E is the innermost immediately + -- visible entity, so we are all set. + end; + + -- Come here with entity found, and stored in E + + <> begin + + -- Check violation of No_Wide_Characters restriction + + Check_Wide_Character_Restriction (E, N); + + -- When distribution features are available (Get_PCS_Name /= + -- Name_No_DSA), a remote access-to-subprogram type is converted + -- into a record type holding whatever information is needed to + -- perform a remote call on an RCI subprogram. In that case we + -- rewrite any occurrence of the RAS type into the equivalent record + -- type here. 'Access attribute references and RAS dereferences are + -- then implemented using specific TSSs. However when distribution is + -- not available (case of Get_PCS_Name = Name_No_DSA), we bypass the + -- generation of these TSSs, and we must keep the RAS type in its + -- original access-to-subprogram form (since all calls through a + -- value of such type will be local anyway in the absence of a PCS). + + if Comes_From_Source (N) + and then Is_Remote_Access_To_Subprogram_Type (E) + and then Expander_Active + and then Get_PCS_Name /= Name_No_DSA + then + Rewrite (N, + New_Occurrence_Of (Equivalent_Type (E), Sloc (N))); + return; + end if; + + -- Set the entity. Note that the reason we call Set_Entity for the + -- overloadable case, as opposed to Set_Entity_With_Style_Check is + -- that in the overloaded case, the initial call can set the wrong + -- homonym. The call that sets the right homonym is in Sem_Res and + -- that call does use Set_Entity_With_Style_Check, so we don't miss + -- a style check. + + if Is_Overloadable (E) then + Set_Entity (N, E); + else + Set_Entity_With_Style_Check (N, E); + end if; + + if Is_Type (E) then + Set_Etype (N, E); + else + Set_Etype (N, Get_Full_View (Etype (E))); + end if; + + if Debug_Flag_E then + Write_Str (" found "); + Write_Entity_Info (E, " "); + end if; + + -- If the Ekind of the entity is Void, it means that all homonyms + -- are hidden from all visibility (RM 8.3(5,14-20)). However, this + -- test is skipped if the current scope is a record and the name is + -- a pragma argument expression (case of Atomic and Volatile pragmas + -- and possibly other similar pragmas added later, which are allowed + -- to reference components in the current record). + + if Ekind (E) = E_Void + and then + (not Is_Record_Type (Current_Scope) + or else Nkind (Parent (N)) /= N_Pragma_Argument_Association) + then + Premature_Usage (N); + + -- If the entity is overloadable, collect all interpretations of the + -- name for subsequent overload resolution. We optimize a bit here to + -- do this only if we have an overloadable entity that is not on its + -- own on the homonym chain. + + elsif Is_Overloadable (E) + and then (Present (Homonym (E)) or else Current_Entity (N) /= E) + then + Collect_Interps (N); + + -- If no homonyms were visible, the entity is unambiguous + + if not Is_Overloaded (N) then + if not Is_Actual_Parameter then + Generate_Reference (E, N); + end if; + end if; + + -- Case of non-overloadable entity, set the entity providing that + -- we do not have the case of a discriminant reference within a + -- default expression. Such references are replaced with the + -- corresponding discriminal, which is the formal corresponding to + -- to the discriminant in the initialization procedure. + + else + -- Entity is unambiguous, indicate that it is referenced here + + -- For a renaming of an object, always generate simple reference, + -- we don't try to keep track of assignments in this case. + + if Is_Object (E) and then Present (Renamed_Object (E)) then + Generate_Reference (E, N); + + -- If the renamed entity is a private protected component, + -- reference the original component as well. This needs to be + -- done because the private renamings are installed before any + -- analysis has occurred. Reference to a private component will + -- resolve to the renaming and the original component will be + -- left unreferenced, hence the following. + + if Is_Prival (E) then + Generate_Reference (Prival_Link (E), N); + end if; + + -- One odd case is that we do not want to set the Referenced flag + -- if the entity is a label, and the identifier is the label in + -- the source, since this is not a reference from the point of + -- view of the user. + + elsif Nkind (Parent (N)) = N_Label then + declare + R : constant Boolean := Referenced (E); + + begin + -- Generate reference unless this is an actual parameter + -- (see comment below) + + if Is_Actual_Parameter then + Generate_Reference (E, N); + Set_Referenced (E, R); + end if; + end; + + -- Normal case, not a label: generate reference + + -- ??? It is too early to generate a reference here even if + -- the entity is unambiguous, because the tree is not + -- sufficiently typed at this point for Generate_Reference to + -- determine whether this reference modifies the denoted object + -- (because implicit dereferences cannot be identified prior to + -- full type resolution). + -- + -- The Is_Actual_Parameter routine takes care of one of these + -- cases but there are others probably ??? + + else + if not Is_Actual_Parameter then + Generate_Reference (E, N); + end if; + + Check_Nested_Access (E); + end if; + + Set_Entity_Or_Discriminal (N, E); + end if; + end; + end Find_Direct_Name; + + ------------------------ + -- Find_Expanded_Name -- + ------------------------ + + -- This routine searches the homonym chain of the entity until it finds + -- an entity declared in the scope denoted by the prefix. If the entity + -- is private, it may nevertheless be immediately visible, if we are in + -- the scope of its declaration. + + procedure Find_Expanded_Name (N : Node_Id) is + Selector : constant Node_Id := Selector_Name (N); + Candidate : Entity_Id := Empty; + P_Name : Entity_Id; + O_Name : Entity_Id; + Id : Entity_Id; + + begin + P_Name := Entity (Prefix (N)); + O_Name := P_Name; + + -- If the prefix is a renamed package, look for the entity in the + -- original package. + + if Ekind (P_Name) = E_Package + and then Present (Renamed_Object (P_Name)) + then + P_Name := Renamed_Object (P_Name); + + -- Rewrite node with entity field pointing to renamed object + + Rewrite (Prefix (N), New_Copy (Prefix (N))); + Set_Entity (Prefix (N), P_Name); + + -- If the prefix is an object of a concurrent type, look for + -- the entity in the associated task or protected type. + + elsif Is_Concurrent_Type (Etype (P_Name)) then + P_Name := Etype (P_Name); + end if; + + Id := Current_Entity (Selector); + + declare + Is_New_Candidate : Boolean; + + begin + while Present (Id) loop + if Scope (Id) = P_Name then + Candidate := Id; + Is_New_Candidate := True; + + -- Ada 2005 (AI-217): Handle shadow entities associated with types + -- declared in limited-withed nested packages. We don't need to + -- handle E_Incomplete_Subtype entities because the entities in + -- the limited view are always E_Incomplete_Type entities (see + -- Build_Limited_Views). Regarding the expression used to evaluate + -- the scope, it is important to note that the limited view also + -- has shadow entities associated nested packages. For this reason + -- the correct scope of the entity is the scope of the real entity + -- The non-limited view may itself be incomplete, in which case + -- get the full view if available. + + elsif From_With_Type (Id) + and then Is_Type (Id) + and then Ekind (Id) = E_Incomplete_Type + and then Present (Non_Limited_View (Id)) + and then Scope (Non_Limited_View (Id)) = P_Name + then + Candidate := Get_Full_View (Non_Limited_View (Id)); + Is_New_Candidate := True; + + else + Is_New_Candidate := False; + end if; + + if Is_New_Candidate then + if Is_Child_Unit (Id) then + exit when Is_Visible_Child_Unit (Id) + or else Is_Immediately_Visible (Id); + + else + exit when not Is_Hidden (Id) + or else Is_Immediately_Visible (Id); + end if; + end if; + + Id := Homonym (Id); + end loop; + end; + + if No (Id) + and then (Ekind (P_Name) = E_Procedure + or else + Ekind (P_Name) = E_Function) + and then Is_Generic_Instance (P_Name) + then + -- Expanded name denotes entity in (instance of) generic subprogram. + -- The entity may be in the subprogram instance, or may denote one of + -- the formals, which is declared in the enclosing wrapper package. + + P_Name := Scope (P_Name); + + Id := Current_Entity (Selector); + while Present (Id) loop + exit when Scope (Id) = P_Name; + Id := Homonym (Id); + end loop; + end if; + + if No (Id) or else Chars (Id) /= Chars (Selector) then + Set_Etype (N, Any_Type); + + -- If we are looking for an entity defined in System, try to find it + -- in the child package that may have been provided as an extension + -- to System. The Extend_System pragma will have supplied the name of + -- the extension, which may have to be loaded. + + if Chars (P_Name) = Name_System + and then Scope (P_Name) = Standard_Standard + and then Present (System_Extend_Unit) + and then Present_System_Aux (N) + then + Set_Entity (Prefix (N), System_Aux_Id); + Find_Expanded_Name (N); + return; + + elsif Nkind (Selector) = N_Operator_Symbol + and then Has_Implicit_Operator (N) + then + -- There is an implicit instance of the predefined operator in + -- the given scope. The operator entity is defined in Standard. + -- Has_Implicit_Operator makes the node into an Expanded_Name. + + return; + + elsif Nkind (Selector) = N_Character_Literal + and then Has_Implicit_Character_Literal (N) + then + -- If there is no literal defined in the scope denoted by the + -- prefix, the literal may belong to (a type derived from) + -- Standard_Character, for which we have no explicit literals. + + return; + + else + -- If the prefix is a single concurrent object, use its name in + -- the error message, rather than that of the anonymous type. + + if Is_Concurrent_Type (P_Name) + and then Is_Internal_Name (Chars (P_Name)) + then + Error_Msg_Node_2 := Entity (Prefix (N)); + else + Error_Msg_Node_2 := P_Name; + end if; + + if P_Name = System_Aux_Id then + P_Name := Scope (P_Name); + Set_Entity (Prefix (N), P_Name); + end if; + + if Present (Candidate) then + + -- If we know that the unit is a child unit we can give a more + -- accurate error message. + + if Is_Child_Unit (Candidate) then + + -- If the candidate is a private child unit and we are in + -- the visible part of a public unit, specialize the error + -- message. There might be a private with_clause for it, + -- but it is not currently active. + + if Is_Private_Descendant (Candidate) + and then Ekind (Current_Scope) = E_Package + and then not In_Private_Part (Current_Scope) + and then not Is_Private_Descendant (Current_Scope) + then + Error_Msg_N ("private child unit& is not visible here", + Selector); + + -- Normal case where we have a missing with for a child unit + + else + Error_Msg_Qual_Level := 99; + Error_Msg_NE -- CODEFIX + ("missing `WITH &;`", Selector, Candidate); + Error_Msg_Qual_Level := 0; + end if; + + -- Here we don't know that this is a child unit + + else + Error_Msg_NE ("& is not a visible entity of&", N, Selector); + end if; + + else + -- Within the instantiation of a child unit, the prefix may + -- denote the parent instance, but the selector has the name + -- of the original child. Find whether we are within the + -- corresponding instance, and get the proper entity, which + -- can only be an enclosing scope. + + if O_Name /= P_Name + and then In_Open_Scopes (P_Name) + and then Is_Generic_Instance (P_Name) + then + declare + S : Entity_Id := Current_Scope; + P : Entity_Id; + + begin + for J in reverse 0 .. Scope_Stack.Last loop + S := Scope_Stack.Table (J).Entity; + + exit when S = Standard_Standard; + + if Ekind_In (S, E_Function, + E_Package, + E_Procedure) + then + P := Generic_Parent (Specification + (Unit_Declaration_Node (S))); + + if Present (P) + and then Chars (Scope (P)) = Chars (O_Name) + and then Chars (P) = Chars (Selector) + then + Id := S; + goto Found; + end if; + end if; + + end loop; + end; + end if; + + -- If this is a selection from Ada, System or Interfaces, then + -- we assume a missing with for the corresponding package. + + if Is_Known_Unit (N) then + if not Error_Posted (N) then + Error_Msg_Node_2 := Selector; + Error_Msg_N -- CODEFIX + ("missing `WITH &.&;`", Prefix (N)); + end if; + + -- If this is a selection from a dummy package, then suppress + -- the error message, of course the entity is missing if the + -- package is missing! + + elsif Sloc (Error_Msg_Node_2) = No_Location then + null; + + -- Here we have the case of an undefined component + + else + + -- The prefix may hide a homonym in the context that + -- declares the desired entity. This error can use a + -- specialized message. + + if In_Open_Scopes (P_Name) + and then Present (Homonym (P_Name)) + and then Is_Compilation_Unit (Homonym (P_Name)) + and then + (Is_Immediately_Visible (Homonym (P_Name)) + or else Is_Visible_Child_Unit (Homonym (P_Name))) + then + declare + H : constant Entity_Id := Homonym (P_Name); + + begin + Id := First_Entity (H); + while Present (Id) loop + if Chars (Id) = Chars (Selector) then + Error_Msg_Qual_Level := 99; + Error_Msg_Name_1 := Chars (Selector); + Error_Msg_NE + ("% not declared in&", N, P_Name); + Error_Msg_NE + ("\use fully qualified name starting with" + & " Standard to make& visible", N, H); + Error_Msg_Qual_Level := 0; + goto Done; + end if; + + Next_Entity (Id); + end loop; + + -- If not found, standard error message. + + Error_Msg_NE ("& not declared in&", N, Selector); + + <> null; + end; + + else + Error_Msg_NE ("& not declared in&", N, Selector); + end if; + + -- Check for misspelling of some entity in prefix + + Id := First_Entity (P_Name); + while Present (Id) loop + if Is_Bad_Spelling_Of (Chars (Id), Chars (Selector)) + and then not Is_Internal_Name (Chars (Id)) + then + Error_Msg_NE -- CODEFIX + ("possible misspelling of&", Selector, Id); + exit; + end if; + + Next_Entity (Id); + end loop; + + -- Specialize the message if this may be an instantiation + -- of a child unit that was not mentioned in the context. + + if Nkind (Parent (N)) = N_Package_Instantiation + and then Is_Generic_Instance (Entity (Prefix (N))) + and then Is_Compilation_Unit + (Generic_Parent (Parent (Entity (Prefix (N))))) + then + Error_Msg_Node_2 := Selector; + Error_Msg_N -- CODEFIX + ("\missing `WITH &.&;`", Prefix (N)); + end if; + end if; + end if; + + Id := Any_Id; + end if; + end if; + + <> + if Comes_From_Source (N) + and then Is_Remote_Access_To_Subprogram_Type (Id) + and then Present (Equivalent_Type (Id)) + then + -- If we are not actually generating distribution code (i.e. the + -- current PCS is the dummy non-distributed version), then the + -- Equivalent_Type will be missing, and Id should be treated as + -- a regular access-to-subprogram type. + + Id := Equivalent_Type (Id); + Set_Chars (Selector, Chars (Id)); + end if; + + -- Ada 2005 (AI-50217): Check usage of entities in limited withed units + + if Ekind (P_Name) = E_Package + and then From_With_Type (P_Name) + then + if From_With_Type (Id) + or else Is_Type (Id) + or else Ekind (Id) = E_Package + then + null; + else + Error_Msg_N + ("limited withed package can only be used to access " + & "incomplete types", + N); + end if; + end if; + + if Is_Task_Type (P_Name) + and then ((Ekind (Id) = E_Entry + and then Nkind (Parent (N)) /= N_Attribute_Reference) + or else + (Ekind (Id) = E_Entry_Family + and then + Nkind (Parent (Parent (N))) /= N_Attribute_Reference)) + then + -- It is an entry call after all, either to the current task (which + -- will deadlock) or to an enclosing task. + + Analyze_Selected_Component (N); + return; + end if; + + Change_Selected_Component_To_Expanded_Name (N); + + -- Do style check and generate reference, but skip both steps if this + -- entity has homonyms, since we may not have the right homonym set yet. + -- The proper homonym will be set during the resolve phase. + + if Has_Homonym (Id) then + Set_Entity (N, Id); + else + Set_Entity_Or_Discriminal (N, Id); + Generate_Reference (Id, N); + end if; + + if Is_Type (Id) then + Set_Etype (N, Id); + else + Set_Etype (N, Get_Full_View (Etype (Id))); + end if; + + -- Check for violation of No_Wide_Characters + + Check_Wide_Character_Restriction (Id, N); + + -- If the Ekind of the entity is Void, it means that all homonyms are + -- hidden from all visibility (RM 8.3(5,14-20)). + + if Ekind (Id) = E_Void then + Premature_Usage (N); + + elsif Is_Overloadable (Id) + and then Present (Homonym (Id)) + then + declare + H : Entity_Id := Homonym (Id); + + begin + while Present (H) loop + if Scope (H) = Scope (Id) + and then + (not Is_Hidden (H) + or else Is_Immediately_Visible (H)) + then + Collect_Interps (N); + exit; + end if; + + H := Homonym (H); + end loop; + + -- If an extension of System is present, collect possible explicit + -- overloadings declared in the extension. + + if Chars (P_Name) = Name_System + and then Scope (P_Name) = Standard_Standard + and then Present (System_Extend_Unit) + and then Present_System_Aux (N) + then + H := Current_Entity (Id); + + while Present (H) loop + if Scope (H) = System_Aux_Id then + Add_One_Interp (N, H, Etype (H)); + end if; + + H := Homonym (H); + end loop; + end if; + end; + end if; + + if Nkind (Selector_Name (N)) = N_Operator_Symbol + and then Scope (Id) /= Standard_Standard + then + -- In addition to user-defined operators in the given scope, there + -- may be an implicit instance of the predefined operator. The + -- operator (defined in Standard) is found in Has_Implicit_Operator, + -- and added to the interpretations. Procedure Add_One_Interp will + -- determine which hides which. + + if Has_Implicit_Operator (N) then + null; + end if; + end if; + end Find_Expanded_Name; + + ------------------------- + -- Find_Renamed_Entity -- + ------------------------- + + function Find_Renamed_Entity + (N : Node_Id; + Nam : Node_Id; + New_S : Entity_Id; + Is_Actual : Boolean := False) return Entity_Id + is + Ind : Interp_Index; + I1 : Interp_Index := 0; -- Suppress junk warnings + It : Interp; + It1 : Interp; + Old_S : Entity_Id; + Inst : Entity_Id; + + function Enclosing_Instance return Entity_Id; + -- If the renaming determines the entity for the default of a formal + -- subprogram nested within another instance, choose the innermost + -- candidate. This is because if the formal has a box, and we are within + -- an enclosing instance where some candidate interpretations are local + -- to this enclosing instance, we know that the default was properly + -- resolved when analyzing the generic, so we prefer the local + -- candidates to those that are external. This is not always the case + -- but is a reasonable heuristic on the use of nested generics. The + -- proper solution requires a full renaming model. + + function Is_Visible_Operation (Op : Entity_Id) return Boolean; + -- If the renamed entity is an implicit operator, check whether it is + -- visible because its operand type is properly visible. This check + -- applies to explicit renamed entities that appear in the source in a + -- renaming declaration or a formal subprogram instance, but not to + -- default generic actuals with a name. + + function Report_Overload return Entity_Id; + -- List possible interpretations, and specialize message in the + -- case of a generic actual. + + function Within (Inner, Outer : Entity_Id) return Boolean; + -- Determine whether a candidate subprogram is defined within the + -- enclosing instance. If yes, it has precedence over outer candidates. + + ------------------------ + -- Enclosing_Instance -- + ------------------------ + + function Enclosing_Instance return Entity_Id is + S : Entity_Id; + + begin + if not Is_Generic_Instance (Current_Scope) + and then not Is_Actual + then + return Empty; + end if; + + S := Scope (Current_Scope); + while S /= Standard_Standard loop + if Is_Generic_Instance (S) then + return S; + end if; + + S := Scope (S); + end loop; + + return Empty; + end Enclosing_Instance; + + -------------------------- + -- Is_Visible_Operation -- + -------------------------- + + function Is_Visible_Operation (Op : Entity_Id) return Boolean is + Scop : Entity_Id; + Typ : Entity_Id; + Btyp : Entity_Id; + + begin + if Ekind (Op) /= E_Operator + or else Scope (Op) /= Standard_Standard + or else (In_Instance + and then + (not Is_Actual + or else Present (Enclosing_Instance))) + then + return True; + + else + -- For a fixed point type operator, check the resulting type, + -- because it may be a mixed mode integer * fixed operation. + + if Present (Next_Formal (First_Formal (New_S))) + and then Is_Fixed_Point_Type (Etype (New_S)) + then + Typ := Etype (New_S); + else + Typ := Etype (First_Formal (New_S)); + end if; + + Btyp := Base_Type (Typ); + + if Nkind (Nam) /= N_Expanded_Name then + return (In_Open_Scopes (Scope (Btyp)) + or else Is_Potentially_Use_Visible (Btyp) + or else In_Use (Btyp) + or else In_Use (Scope (Btyp))); + + else + Scop := Entity (Prefix (Nam)); + + if Ekind (Scop) = E_Package + and then Present (Renamed_Object (Scop)) + then + Scop := Renamed_Object (Scop); + end if; + + -- Operator is visible if prefix of expanded name denotes + -- scope of type, or else type is defined in System_Aux + -- and the prefix denotes System. + + return Scope (Btyp) = Scop + or else (Scope (Btyp) = System_Aux_Id + and then Scope (Scope (Btyp)) = Scop); + end if; + end if; + end Is_Visible_Operation; + + ------------ + -- Within -- + ------------ + + function Within (Inner, Outer : Entity_Id) return Boolean is + Sc : Entity_Id; + + begin + Sc := Scope (Inner); + while Sc /= Standard_Standard loop + if Sc = Outer then + return True; + else + Sc := Scope (Sc); + end if; + end loop; + + return False; + end Within; + + --------------------- + -- Report_Overload -- + --------------------- + + function Report_Overload return Entity_Id is + begin + if Is_Actual then + Error_Msg_NE -- CODEFIX + ("ambiguous actual subprogram&, " & + "possible interpretations:", N, Nam); + else + Error_Msg_N -- CODEFIX + ("ambiguous subprogram, " & + "possible interpretations:", N); + end if; + + List_Interps (Nam, N); + return Old_S; + end Report_Overload; + + -- Start of processing for Find_Renamed_Entry + + begin + Old_S := Any_Id; + Candidate_Renaming := Empty; + + if not Is_Overloaded (Nam) then + if Entity_Matches_Spec (Entity (Nam), New_S) then + Candidate_Renaming := New_S; + + if Is_Visible_Operation (Entity (Nam)) then + Old_S := Entity (Nam); + end if; + + elsif + Present (First_Formal (Entity (Nam))) + and then Present (First_Formal (New_S)) + and then (Base_Type (Etype (First_Formal (Entity (Nam)))) + = Base_Type (Etype (First_Formal (New_S)))) + then + Candidate_Renaming := Entity (Nam); + end if; + + else + Get_First_Interp (Nam, Ind, It); + while Present (It.Nam) loop + if Entity_Matches_Spec (It.Nam, New_S) + and then Is_Visible_Operation (It.Nam) + then + if Old_S /= Any_Id then + + -- Note: The call to Disambiguate only happens if a + -- previous interpretation was found, in which case I1 + -- has received a value. + + It1 := Disambiguate (Nam, I1, Ind, Etype (Old_S)); + + if It1 = No_Interp then + Inst := Enclosing_Instance; + + if Present (Inst) then + if Within (It.Nam, Inst) then + return (It.Nam); + elsif Within (Old_S, Inst) then + return (Old_S); + else + return Report_Overload; + end if; + + else + return Report_Overload; + end if; + + else + Old_S := It1.Nam; + exit; + end if; + + else + I1 := Ind; + Old_S := It.Nam; + end if; + + elsif + Present (First_Formal (It.Nam)) + and then Present (First_Formal (New_S)) + and then (Base_Type (Etype (First_Formal (It.Nam))) + = Base_Type (Etype (First_Formal (New_S)))) + then + Candidate_Renaming := It.Nam; + end if; + + Get_Next_Interp (Ind, It); + end loop; + + Set_Entity (Nam, Old_S); + Set_Is_Overloaded (Nam, False); + end if; + + return Old_S; + end Find_Renamed_Entity; + + ----------------------------- + -- Find_Selected_Component -- + ----------------------------- + + procedure Find_Selected_Component (N : Node_Id) is + P : constant Node_Id := Prefix (N); + + P_Name : Entity_Id; + -- Entity denoted by prefix + + P_Type : Entity_Id; + -- and its type + + Nam : Node_Id; + + begin + Analyze (P); + + if Nkind (P) = N_Error then + return; + + -- If the selector already has an entity, the node has been constructed + -- in the course of expansion, and is known to be valid. Do not verify + -- that it is defined for the type (it may be a private component used + -- in the expansion of record equality). + + elsif Present (Entity (Selector_Name (N))) then + if No (Etype (N)) + or else Etype (N) = Any_Type + then + declare + Sel_Name : constant Node_Id := Selector_Name (N); + Selector : constant Entity_Id := Entity (Sel_Name); + C_Etype : Node_Id; + + begin + Set_Etype (Sel_Name, Etype (Selector)); + + if not Is_Entity_Name (P) then + Resolve (P); + end if; + + -- Build an actual subtype except for the first parameter + -- of an init proc, where this actual subtype is by + -- definition incorrect, since the object is uninitialized + -- (and does not even have defined discriminants etc.) + + if Is_Entity_Name (P) + and then Ekind (Entity (P)) = E_Function + then + Nam := New_Copy (P); + + if Is_Overloaded (P) then + Save_Interps (P, Nam); + end if; + + Rewrite (P, + Make_Function_Call (Sloc (P), Name => Nam)); + Analyze_Call (P); + Analyze_Selected_Component (N); + return; + + elsif Ekind (Selector) = E_Component + and then (not Is_Entity_Name (P) + or else Chars (Entity (P)) /= Name_uInit) + then + -- Do not build the subtype when referencing components of + -- dispatch table wrappers. Required to avoid generating + -- elaboration code with HI runtimes. + + if RTU_Loaded (Ada_Tags) + and then RTE_Available (RE_Dispatch_Table_Wrapper) + and then Scope (Selector) = RTE (RE_Dispatch_Table_Wrapper) + then + C_Etype := Empty; + + elsif RTU_Loaded (Ada_Tags) + and then RTE_Available (RE_No_Dispatch_Table_Wrapper) + and then Scope (Selector) + = RTE (RE_No_Dispatch_Table_Wrapper) + then + C_Etype := Empty; + + else + C_Etype := + Build_Actual_Subtype_Of_Component ( + Etype (Selector), N); + end if; + + else + C_Etype := Empty; + end if; + + if No (C_Etype) then + C_Etype := Etype (Selector); + else + Insert_Action (N, C_Etype); + C_Etype := Defining_Identifier (C_Etype); + end if; + + Set_Etype (N, C_Etype); + end; + + -- If this is the name of an entry or protected operation, and + -- the prefix is an access type, insert an explicit dereference, + -- so that entry calls are treated uniformly. + + if Is_Access_Type (Etype (P)) + and then Is_Concurrent_Type (Designated_Type (Etype (P))) + then + declare + New_P : constant Node_Id := + Make_Explicit_Dereference (Sloc (P), + Prefix => Relocate_Node (P)); + begin + Rewrite (P, New_P); + Set_Etype (P, Designated_Type (Etype (Prefix (P)))); + end; + end if; + + -- If the selected component appears within a default expression + -- and it has an actual subtype, the pre-analysis has not yet + -- completed its analysis, because Insert_Actions is disabled in + -- that context. Within the init proc of the enclosing type we + -- must complete this analysis, if an actual subtype was created. + + elsif Inside_Init_Proc then + declare + Typ : constant Entity_Id := Etype (N); + Decl : constant Node_Id := Declaration_Node (Typ); + begin + if Nkind (Decl) = N_Subtype_Declaration + and then not Analyzed (Decl) + and then Is_List_Member (Decl) + and then No (Parent (Decl)) + then + Remove (Decl); + Insert_Action (N, Decl); + end if; + end; + end if; + + return; + + elsif Is_Entity_Name (P) then + P_Name := Entity (P); + + -- The prefix may denote an enclosing type which is the completion + -- of an incomplete type declaration. + + if Is_Type (P_Name) then + Set_Entity (P, Get_Full_View (P_Name)); + Set_Etype (P, Entity (P)); + P_Name := Entity (P); + end if; + + P_Type := Base_Type (Etype (P)); + + if Debug_Flag_E then + Write_Str ("Found prefix type to be "); + Write_Entity_Info (P_Type, " "); Write_Eol; + end if; + + -- First check for components of a record object (not the + -- result of a call, which is handled below). + + if Is_Appropriate_For_Record (P_Type) + and then not Is_Overloadable (P_Name) + and then not Is_Type (P_Name) + then + -- Selected component of record. Type checking will validate + -- name of selector. + -- ??? could we rewrite an implicit dereference into an explicit + -- one here? + + Analyze_Selected_Component (N); + + -- Reference to type name in predicate/invariant expression + + elsif Is_Appropriate_For_Entry_Prefix (P_Type) + and then not In_Open_Scopes (P_Name) + and then (not Is_Concurrent_Type (Etype (P_Name)) + or else not In_Open_Scopes (Etype (P_Name))) + then + -- Call to protected operation or entry. Type checking is + -- needed on the prefix. + + Analyze_Selected_Component (N); + + elsif (In_Open_Scopes (P_Name) + and then Ekind (P_Name) /= E_Void + and then not Is_Overloadable (P_Name)) + or else (Is_Concurrent_Type (Etype (P_Name)) + and then In_Open_Scopes (Etype (P_Name))) + then + -- Prefix denotes an enclosing loop, block, or task, i.e. an + -- enclosing construct that is not a subprogram or accept. + + Find_Expanded_Name (N); + + elsif Ekind (P_Name) = E_Package then + Find_Expanded_Name (N); + + elsif Is_Overloadable (P_Name) then + + -- The subprogram may be a renaming (of an enclosing scope) as + -- in the case of the name of the generic within an instantiation. + + if Ekind_In (P_Name, E_Procedure, E_Function) + and then Present (Alias (P_Name)) + and then Is_Generic_Instance (Alias (P_Name)) + then + P_Name := Alias (P_Name); + end if; + + if Is_Overloaded (P) then + + -- The prefix must resolve to a unique enclosing construct + + declare + Found : Boolean := False; + Ind : Interp_Index; + It : Interp; + + begin + Get_First_Interp (P, Ind, It); + while Present (It.Nam) loop + if In_Open_Scopes (It.Nam) then + if Found then + Error_Msg_N ( + "prefix must be unique enclosing scope", N); + Set_Entity (N, Any_Id); + Set_Etype (N, Any_Type); + return; + + else + Found := True; + P_Name := It.Nam; + end if; + end if; + + Get_Next_Interp (Ind, It); + end loop; + end; + end if; + + if In_Open_Scopes (P_Name) then + Set_Entity (P, P_Name); + Set_Is_Overloaded (P, False); + Find_Expanded_Name (N); + + else + -- If no interpretation as an expanded name is possible, it + -- must be a selected component of a record returned by a + -- function call. Reformat prefix as a function call, the rest + -- is done by type resolution. If the prefix is procedure or + -- entry, as is P.X; this is an error. + + if Ekind (P_Name) /= E_Function + and then (not Is_Overloaded (P) + or else + Nkind (Parent (N)) = N_Procedure_Call_Statement) + then + -- Prefix may mention a package that is hidden by a local + -- declaration: let the user know. Scan the full homonym + -- chain, the candidate package may be anywhere on it. + + if Present (Homonym (Current_Entity (P_Name))) then + + P_Name := Current_Entity (P_Name); + + while Present (P_Name) loop + exit when Ekind (P_Name) = E_Package; + P_Name := Homonym (P_Name); + end loop; + + if Present (P_Name) then + Error_Msg_Sloc := Sloc (Entity (Prefix (N))); + + Error_Msg_NE + ("package& is hidden by declaration#", + N, P_Name); + + Set_Entity (Prefix (N), P_Name); + Find_Expanded_Name (N); + return; + else + P_Name := Entity (Prefix (N)); + end if; + end if; + + Error_Msg_NE + ("invalid prefix in selected component&", N, P_Name); + Change_Selected_Component_To_Expanded_Name (N); + Set_Entity (N, Any_Id); + Set_Etype (N, Any_Type); + + else + Nam := New_Copy (P); + Save_Interps (P, Nam); + Rewrite (P, + Make_Function_Call (Sloc (P), Name => Nam)); + Analyze_Call (P); + Analyze_Selected_Component (N); + end if; + end if; + + -- Remaining cases generate various error messages + + else + -- Format node as expanded name, to avoid cascaded errors + + Change_Selected_Component_To_Expanded_Name (N); + Set_Entity (N, Any_Id); + Set_Etype (N, Any_Type); + + -- Issue error message, but avoid this if error issued already. + -- Use identifier of prefix if one is available. + + if P_Name = Any_Id then + null; + + elsif Ekind (P_Name) = E_Void then + Premature_Usage (P); + + elsif Nkind (P) /= N_Attribute_Reference then + Error_Msg_N ( + "invalid prefix in selected component&", P); + + if Is_Access_Type (P_Type) + and then Ekind (Designated_Type (P_Type)) = E_Incomplete_Type + then + Error_Msg_N + ("\dereference must not be of an incomplete type " & + "(RM 3.10.1)", P); + end if; + + else + Error_Msg_N ( + "invalid prefix in selected component", P); + end if; + end if; + + else + -- If prefix is not the name of an entity, it must be an expression, + -- whose type is appropriate for a record. This is determined by + -- type resolution. + + Analyze_Selected_Component (N); + end if; + end Find_Selected_Component; + + --------------- + -- Find_Type -- + --------------- + + procedure Find_Type (N : Node_Id) is + C : Entity_Id; + Typ : Entity_Id; + T : Entity_Id; + T_Name : Entity_Id; + + begin + if N = Error then + return; + + elsif Nkind (N) = N_Attribute_Reference then + + -- Class attribute. This is not valid in Ada 83 mode, but we do not + -- need to enforce that at this point, since the declaration of the + -- tagged type in the prefix would have been flagged already. + + if Attribute_Name (N) = Name_Class then + Check_Restriction (No_Dispatch, N); + Find_Type (Prefix (N)); + + -- Propagate error from bad prefix + + if Etype (Prefix (N)) = Any_Type then + Set_Entity (N, Any_Type); + Set_Etype (N, Any_Type); + return; + end if; + + T := Base_Type (Entity (Prefix (N))); + + -- Case where type is not known to be tagged. Its appearance in + -- the prefix of the 'Class attribute indicates that the full view + -- will be tagged. + + if not Is_Tagged_Type (T) then + if Ekind (T) = E_Incomplete_Type then + + -- It is legal to denote the class type of an incomplete + -- type. The full type will have to be tagged, of course. + -- In Ada 2005 this usage is declared obsolescent, so we + -- warn accordingly. This usage is only legal if the type + -- is completed in the current scope, and not for a limited + -- view of a type. + + if not Is_Tagged_Type (T) + and then Ada_Version >= Ada_2005 + then + if From_With_Type (T) then + Error_Msg_N + ("prefix of Class attribute must be tagged", N); + Set_Etype (N, Any_Type); + Set_Entity (N, Any_Type); + return; + + -- ??? This test is temporarily disabled (always False) + -- because it causes an unwanted warning on GNAT sources + -- (built with -gnatg, which includes Warn_On_Obsolescent_ + -- Feature). Once this issue is cleared in the sources, it + -- can be enabled. + + elsif Warn_On_Obsolescent_Feature + and then False + then + Error_Msg_N + ("applying 'Class to an untagged incomplete type" + & " is an obsolescent feature (RM J.11)", N); + end if; + end if; + + Set_Is_Tagged_Type (T); + Set_Direct_Primitive_Operations (T, New_Elmt_List); + Make_Class_Wide_Type (T); + Set_Entity (N, Class_Wide_Type (T)); + Set_Etype (N, Class_Wide_Type (T)); + + elsif Ekind (T) = E_Private_Type + and then not Is_Generic_Type (T) + and then In_Private_Part (Scope (T)) + then + -- The Class attribute can be applied to an untagged private + -- type fulfilled by a tagged type prior to the full type + -- declaration (but only within the parent package's private + -- part). Create the class-wide type now and check that the + -- full type is tagged later during its analysis. Note that + -- we do not mark the private type as tagged, unlike the + -- case of incomplete types, because the type must still + -- appear untagged to outside units. + + if No (Class_Wide_Type (T)) then + Make_Class_Wide_Type (T); + end if; + + Set_Entity (N, Class_Wide_Type (T)); + Set_Etype (N, Class_Wide_Type (T)); + + else + -- Should we introduce a type Any_Tagged and use Wrong_Type + -- here, it would be a bit more consistent??? + + Error_Msg_NE + ("tagged type required, found}", + Prefix (N), First_Subtype (T)); + Set_Entity (N, Any_Type); + return; + end if; + + -- Case of tagged type + + else + if Is_Concurrent_Type (T) then + if No (Corresponding_Record_Type (Entity (Prefix (N)))) then + + -- Previous error. Use current type, which at least + -- provides some operations. + + C := Entity (Prefix (N)); + + else + C := Class_Wide_Type + (Corresponding_Record_Type (Entity (Prefix (N)))); + end if; + + else + C := Class_Wide_Type (Entity (Prefix (N))); + end if; + + Set_Entity_With_Style_Check (N, C); + Generate_Reference (C, N); + Set_Etype (N, C); + end if; + + -- Base attribute, not allowed in Ada 83 + + elsif Attribute_Name (N) = Name_Base then + if Ada_Version = Ada_83 and then Comes_From_Source (N) then + Error_Msg_N + ("(Ada 83) Base attribute not allowed in subtype mark", N); + + else + Find_Type (Prefix (N)); + Typ := Entity (Prefix (N)); + + if Ada_Version >= Ada_95 + and then not Is_Scalar_Type (Typ) + and then not Is_Generic_Type (Typ) + then + Error_Msg_N + ("prefix of Base attribute must be scalar type", + Prefix (N)); + + elsif Warn_On_Redundant_Constructs + and then Base_Type (Typ) = Typ + then + Error_Msg_NE -- CODEFIX + ("?redundant attribute, & is its own base type", N, Typ); + end if; + + T := Base_Type (Typ); + + -- Rewrite attribute reference with type itself (see similar + -- processing in Analyze_Attribute, case Base). Preserve prefix + -- if present, for other legality checks. + + if Nkind (Prefix (N)) = N_Expanded_Name then + Rewrite (N, + Make_Expanded_Name (Sloc (N), + Chars => Chars (T), + Prefix => New_Copy (Prefix (Prefix (N))), + Selector_Name => New_Reference_To (T, Sloc (N)))); + + else + Rewrite (N, New_Reference_To (T, Sloc (N))); + end if; + + Set_Entity (N, T); + Set_Etype (N, T); + end if; + + elsif Attribute_Name (N) = Name_Stub_Type then + + -- This is handled in Analyze_Attribute + + Analyze (N); + + -- All other attributes are invalid in a subtype mark + + else + Error_Msg_N ("invalid attribute in subtype mark", N); + end if; + + else + Analyze (N); + + if Is_Entity_Name (N) then + T_Name := Entity (N); + else + Error_Msg_N ("subtype mark required in this context", N); + Set_Etype (N, Any_Type); + return; + end if; + + if T_Name = Any_Id or else Etype (N) = Any_Type then + + -- Undefined id. Make it into a valid type + + Set_Entity (N, Any_Type); + + elsif not Is_Type (T_Name) + and then T_Name /= Standard_Void_Type + then + Error_Msg_Sloc := Sloc (T_Name); + Error_Msg_N ("subtype mark required in this context", N); + Error_Msg_NE ("\\found & declared#", N, T_Name); + Set_Entity (N, Any_Type); + + else + -- If the type is an incomplete type created to handle + -- anonymous access components of a record type, then the + -- incomplete type is the visible entity and subsequent + -- references will point to it. Mark the original full + -- type as referenced, to prevent spurious warnings. + + if Is_Incomplete_Type (T_Name) + and then Present (Full_View (T_Name)) + and then not Comes_From_Source (T_Name) + then + Set_Referenced (Full_View (T_Name)); + end if; + + T_Name := Get_Full_View (T_Name); + + -- Ada 2005 (AI-251, AI-50217): Handle interfaces visible through + -- limited-with clauses + + if From_With_Type (T_Name) + and then Ekind (T_Name) in Incomplete_Kind + and then Present (Non_Limited_View (T_Name)) + and then Is_Interface (Non_Limited_View (T_Name)) + then + T_Name := Non_Limited_View (T_Name); + end if; + + if In_Open_Scopes (T_Name) then + if Ekind (Base_Type (T_Name)) = E_Task_Type then + + -- In Ada 2005, a task name can be used in an access + -- definition within its own body. It cannot be used + -- in the discriminant part of the task declaration, + -- nor anywhere else in the declaration because entries + -- cannot have access parameters. + + if Ada_Version >= Ada_2005 + and then Nkind (Parent (N)) = N_Access_Definition + then + Set_Entity (N, T_Name); + Set_Etype (N, T_Name); + + if Has_Completion (T_Name) then + return; + + else + Error_Msg_N + ("task type cannot be used as type mark " & + "within its own declaration", N); + end if; + + else + Error_Msg_N + ("task type cannot be used as type mark " & + "within its own spec or body", N); + end if; + + elsif Ekind (Base_Type (T_Name)) = E_Protected_Type then + + -- In Ada 2005, a protected name can be used in an access + -- definition within its own body. + + if Ada_Version >= Ada_2005 + and then Nkind (Parent (N)) = N_Access_Definition + then + Set_Entity (N, T_Name); + Set_Etype (N, T_Name); + return; + + else + Error_Msg_N + ("protected type cannot be used as type mark " & + "within its own spec or body", N); + end if; + + else + Error_Msg_N ("type declaration cannot refer to itself", N); + end if; + + Set_Etype (N, Any_Type); + Set_Entity (N, Any_Type); + Set_Error_Posted (T_Name); + return; + end if; + + Set_Entity (N, T_Name); + Set_Etype (N, T_Name); + end if; + end if; + + if Present (Etype (N)) and then Comes_From_Source (N) then + if Is_Fixed_Point_Type (Etype (N)) then + Check_Restriction (No_Fixed_Point, N); + elsif Is_Floating_Point_Type (Etype (N)) then + Check_Restriction (No_Floating_Point, N); + end if; + end if; + end Find_Type; + + ------------------------------------ + -- Has_Implicit_Character_Literal -- + ------------------------------------ + + function Has_Implicit_Character_Literal (N : Node_Id) return Boolean is + Id : Entity_Id; + Found : Boolean := False; + P : constant Entity_Id := Entity (Prefix (N)); + Priv_Id : Entity_Id := Empty; + + begin + if Ekind (P) = E_Package + and then not In_Open_Scopes (P) + then + Priv_Id := First_Private_Entity (P); + end if; + + if P = Standard_Standard then + Change_Selected_Component_To_Expanded_Name (N); + Rewrite (N, Selector_Name (N)); + Analyze (N); + Set_Etype (Original_Node (N), Standard_Character); + return True; + end if; + + Id := First_Entity (P); + while Present (Id) + and then Id /= Priv_Id + loop + if Is_Standard_Character_Type (Id) and then Is_Base_Type (Id) then + + -- We replace the node with the literal itself, resolve as a + -- character, and set the type correctly. + + if not Found then + Change_Selected_Component_To_Expanded_Name (N); + Rewrite (N, Selector_Name (N)); + Analyze (N); + Set_Etype (N, Id); + Set_Etype (Original_Node (N), Id); + Found := True; + + else + -- More than one type derived from Character in given scope. + -- Collect all possible interpretations. + + Add_One_Interp (N, Id, Id); + end if; + end if; + + Next_Entity (Id); + end loop; + + return Found; + end Has_Implicit_Character_Literal; + + ---------------------- + -- Has_Private_With -- + ---------------------- + + function Has_Private_With (E : Entity_Id) return Boolean is + Comp_Unit : constant Node_Id := Cunit (Current_Sem_Unit); + Item : Node_Id; + + begin + Item := First (Context_Items (Comp_Unit)); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then Private_Present (Item) + and then Entity (Name (Item)) = E + then + return True; + end if; + + Next (Item); + end loop; + + return False; + end Has_Private_With; + + --------------------------- + -- Has_Implicit_Operator -- + --------------------------- + + function Has_Implicit_Operator (N : Node_Id) return Boolean is + Op_Id : constant Name_Id := Chars (Selector_Name (N)); + P : constant Entity_Id := Entity (Prefix (N)); + Id : Entity_Id; + Priv_Id : Entity_Id := Empty; + + procedure Add_Implicit_Operator + (T : Entity_Id; + Op_Type : Entity_Id := Empty); + -- Add implicit interpretation to node N, using the type for which a + -- predefined operator exists. If the operator yields a boolean type, + -- the Operand_Type is implicitly referenced by the operator, and a + -- reference to it must be generated. + + --------------------------- + -- Add_Implicit_Operator -- + --------------------------- + + procedure Add_Implicit_Operator + (T : Entity_Id; + Op_Type : Entity_Id := Empty) + is + Predef_Op : Entity_Id; + + begin + Predef_Op := Current_Entity (Selector_Name (N)); + + while Present (Predef_Op) + and then Scope (Predef_Op) /= Standard_Standard + loop + Predef_Op := Homonym (Predef_Op); + end loop; + + if Nkind (N) = N_Selected_Component then + Change_Selected_Component_To_Expanded_Name (N); + end if; + + -- If the context is an unanalyzed function call, determine whether + -- a binary or unary interpretation is required. + + if Nkind (Parent (N)) = N_Indexed_Component then + declare + Is_Binary_Call : constant Boolean := + Present + (Next (First (Expressions (Parent (N))))); + Is_Binary_Op : constant Boolean := + First_Entity + (Predef_Op) /= Last_Entity (Predef_Op); + Predef_Op2 : constant Entity_Id := Homonym (Predef_Op); + + begin + if Is_Binary_Call then + if Is_Binary_Op then + Add_One_Interp (N, Predef_Op, T); + else + Add_One_Interp (N, Predef_Op2, T); + end if; + + else + if not Is_Binary_Op then + Add_One_Interp (N, Predef_Op, T); + else + Add_One_Interp (N, Predef_Op2, T); + end if; + end if; + end; + + else + Add_One_Interp (N, Predef_Op, T); + + -- For operators with unary and binary interpretations, if + -- context is not a call, add both + + if Present (Homonym (Predef_Op)) then + Add_One_Interp (N, Homonym (Predef_Op), T); + end if; + end if; + + -- The node is a reference to a predefined operator, and + -- an implicit reference to the type of its operands. + + if Present (Op_Type) then + Generate_Operator_Reference (N, Op_Type); + else + Generate_Operator_Reference (N, T); + end if; + end Add_Implicit_Operator; + + -- Start of processing for Has_Implicit_Operator + + begin + if Ekind (P) = E_Package + and then not In_Open_Scopes (P) + then + Priv_Id := First_Private_Entity (P); + end if; + + Id := First_Entity (P); + + case Op_Id is + + -- Boolean operators: an implicit declaration exists if the scope + -- contains a declaration for a derived Boolean type, or for an + -- array of Boolean type. + + when Name_Op_And | Name_Op_Not | Name_Op_Or | Name_Op_Xor => + while Id /= Priv_Id loop + if Valid_Boolean_Arg (Id) and then Is_Base_Type (Id) then + Add_Implicit_Operator (Id); + return True; + end if; + + Next_Entity (Id); + end loop; + + -- Equality: look for any non-limited type (result is Boolean) + + when Name_Op_Eq | Name_Op_Ne => + while Id /= Priv_Id loop + if Is_Type (Id) + and then not Is_Limited_Type (Id) + and then Is_Base_Type (Id) + then + Add_Implicit_Operator (Standard_Boolean, Id); + return True; + end if; + + Next_Entity (Id); + end loop; + + -- Comparison operators: scalar type, or array of scalar + + when Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge => + while Id /= Priv_Id loop + if (Is_Scalar_Type (Id) + or else (Is_Array_Type (Id) + and then Is_Scalar_Type (Component_Type (Id)))) + and then Is_Base_Type (Id) + then + Add_Implicit_Operator (Standard_Boolean, Id); + return True; + end if; + + Next_Entity (Id); + end loop; + + -- Arithmetic operators: any numeric type + + when Name_Op_Abs | + Name_Op_Add | + Name_Op_Mod | + Name_Op_Rem | + Name_Op_Subtract | + Name_Op_Multiply | + Name_Op_Divide | + Name_Op_Expon => + while Id /= Priv_Id loop + if Is_Numeric_Type (Id) and then Is_Base_Type (Id) then + Add_Implicit_Operator (Id); + return True; + end if; + + Next_Entity (Id); + end loop; + + -- Concatenation: any one-dimensional array type + + when Name_Op_Concat => + while Id /= Priv_Id loop + if Is_Array_Type (Id) + and then Number_Dimensions (Id) = 1 + and then Is_Base_Type (Id) + then + Add_Implicit_Operator (Id); + return True; + end if; + + Next_Entity (Id); + end loop; + + -- What is the others condition here? Should we be using a + -- subtype of Name_Id that would restrict to operators ??? + + when others => null; + end case; + + -- If we fall through, then we do not have an implicit operator + + return False; + + end Has_Implicit_Operator; + + -------------------- + -- In_Open_Scopes -- + -------------------- + + function In_Open_Scopes (S : Entity_Id) return Boolean is + begin + -- Several scope stacks are maintained by Scope_Stack. The base of the + -- currently active scope stack is denoted by the Is_Active_Stack_Base + -- flag in the scope stack entry. Note that the scope stacks used to + -- simply be delimited implicitly by the presence of Standard_Standard + -- at their base, but there now are cases where this is not sufficient + -- because Standard_Standard actually may appear in the middle of the + -- active set of scopes. + + for J in reverse 0 .. Scope_Stack.Last loop + if Scope_Stack.Table (J).Entity = S then + return True; + end if; + + -- Check Is_Active_Stack_Base to tell us when to stop, as there are + -- cases where Standard_Standard appears in the middle of the active + -- set of scopes. This affects the declaration and overriding of + -- private inherited operations in instantiations of generic child + -- units. + + exit when Scope_Stack.Table (J).Is_Active_Stack_Base; + end loop; + + return False; + end In_Open_Scopes; + + ----------------------------- + -- Inherit_Renamed_Profile -- + ----------------------------- + + procedure Inherit_Renamed_Profile (New_S : Entity_Id; Old_S : Entity_Id) is + New_F : Entity_Id; + Old_F : Entity_Id; + Old_T : Entity_Id; + New_T : Entity_Id; + + begin + if Ekind (Old_S) = E_Operator then + New_F := First_Formal (New_S); + + while Present (New_F) loop + Set_Etype (New_F, Base_Type (Etype (New_F))); + Next_Formal (New_F); + end loop; + + Set_Etype (New_S, Base_Type (Etype (New_S))); + + else + New_F := First_Formal (New_S); + Old_F := First_Formal (Old_S); + + while Present (New_F) loop + New_T := Etype (New_F); + Old_T := Etype (Old_F); + + -- If the new type is a renaming of the old one, as is the + -- case for actuals in instances, retain its name, to simplify + -- later disambiguation. + + if Nkind (Parent (New_T)) = N_Subtype_Declaration + and then Is_Entity_Name (Subtype_Indication (Parent (New_T))) + and then Entity (Subtype_Indication (Parent (New_T))) = Old_T + then + null; + else + Set_Etype (New_F, Old_T); + end if; + + Next_Formal (New_F); + Next_Formal (Old_F); + end loop; + + if Ekind_In (Old_S, E_Function, E_Enumeration_Literal) then + Set_Etype (New_S, Etype (Old_S)); + end if; + end if; + end Inherit_Renamed_Profile; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Urefs.Init; + end Initialize; + + ------------------------- + -- Install_Use_Clauses -- + ------------------------- + + procedure Install_Use_Clauses + (Clause : Node_Id; + Force_Installation : Boolean := False) + is + U : Node_Id; + P : Node_Id; + Id : Entity_Id; + + begin + U := Clause; + while Present (U) loop + + -- Case of USE package + + if Nkind (U) = N_Use_Package_Clause then + P := First (Names (U)); + while Present (P) loop + Id := Entity (P); + + if Ekind (Id) = E_Package then + if In_Use (Id) then + Note_Redundant_Use (P); + + elsif Present (Renamed_Object (Id)) + and then In_Use (Renamed_Object (Id)) + then + Note_Redundant_Use (P); + + elsif Force_Installation or else Applicable_Use (P) then + Use_One_Package (Id, U); + + end if; + end if; + + Next (P); + end loop; + + -- Case of USE TYPE + + else + P := First (Subtype_Marks (U)); + while Present (P) loop + if not Is_Entity_Name (P) + or else No (Entity (P)) + then + null; + + elsif Entity (P) /= Any_Type then + Use_One_Type (P); + end if; + + Next (P); + end loop; + end if; + + Next_Use_Clause (U); + end loop; + end Install_Use_Clauses; + + ------------------------------------- + -- Is_Appropriate_For_Entry_Prefix -- + ------------------------------------- + + function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean is + P_Type : Entity_Id := T; + + begin + if Is_Access_Type (P_Type) then + P_Type := Designated_Type (P_Type); + end if; + + return Is_Task_Type (P_Type) or else Is_Protected_Type (P_Type); + end Is_Appropriate_For_Entry_Prefix; + + ------------------------------- + -- Is_Appropriate_For_Record -- + ------------------------------- + + function Is_Appropriate_For_Record (T : Entity_Id) return Boolean is + + function Has_Components (T1 : Entity_Id) return Boolean; + -- Determine if given type has components (i.e. is either a record + -- type or a type that has discriminants). + + -------------------- + -- Has_Components -- + -------------------- + + function Has_Components (T1 : Entity_Id) return Boolean is + begin + return Is_Record_Type (T1) + or else (Is_Private_Type (T1) and then Has_Discriminants (T1)) + or else (Is_Task_Type (T1) and then Has_Discriminants (T1)) + or else (Is_Incomplete_Type (T1) + and then From_With_Type (T1) + and then Present (Non_Limited_View (T1)) + and then Is_Record_Type + (Get_Full_View (Non_Limited_View (T1)))); + end Has_Components; + + -- Start of processing for Is_Appropriate_For_Record + + begin + return + Present (T) + and then (Has_Components (T) + or else (Is_Access_Type (T) + and then Has_Components (Designated_Type (T)))); + end Is_Appropriate_For_Record; + + ------------------------ + -- Note_Redundant_Use -- + ------------------------ + + procedure Note_Redundant_Use (Clause : Node_Id) is + Pack_Name : constant Entity_Id := Entity (Clause); + Cur_Use : constant Node_Id := Current_Use_Clause (Pack_Name); + Decl : constant Node_Id := Parent (Clause); + + Prev_Use : Node_Id := Empty; + Redundant : Node_Id := Empty; + -- The Use_Clause which is actually redundant. In the simplest case it + -- is Pack itself, but when we compile a body we install its context + -- before that of its spec, in which case it is the use_clause in the + -- spec that will appear to be redundant, and we want the warning to be + -- placed on the body. Similar complications appear when the redundancy + -- is between a child unit and one of its ancestors. + + begin + Set_Redundant_Use (Clause, True); + + if not Comes_From_Source (Clause) + or else In_Instance + or else not Warn_On_Redundant_Constructs + then + return; + end if; + + if not Is_Compilation_Unit (Current_Scope) then + + -- If the use_clause is in an inner scope, it is made redundant by + -- some clause in the current context, with one exception: If we're + -- compiling a nested package body, and the use_clause comes from the + -- corresponding spec, the clause is not necessarily fully redundant, + -- so we should not warn. If a warning was warranted, it would have + -- been given when the spec was processed. + + if Nkind (Parent (Decl)) = N_Package_Specification then + declare + Package_Spec_Entity : constant Entity_Id := + Defining_Unit_Name (Parent (Decl)); + begin + if In_Package_Body (Package_Spec_Entity) then + return; + end if; + end; + end if; + + Redundant := Clause; + Prev_Use := Cur_Use; + + elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then + declare + Cur_Unit : constant Unit_Number_Type := Get_Source_Unit (Cur_Use); + New_Unit : constant Unit_Number_Type := Get_Source_Unit (Clause); + Scop : Entity_Id; + + begin + if Cur_Unit = New_Unit then + + -- Redundant clause in same body + + Redundant := Clause; + Prev_Use := Cur_Use; + + elsif Cur_Unit = Current_Sem_Unit then + + -- If the new clause is not in the current unit it has been + -- analyzed first, and it makes the other one redundant. + -- However, if the new clause appears in a subunit, Cur_Unit + -- is still the parent, and in that case the redundant one + -- is the one appearing in the subunit. + + if Nkind (Unit (Cunit (New_Unit))) = N_Subunit then + Redundant := Clause; + Prev_Use := Cur_Use; + + -- Most common case: redundant clause in body, + -- original clause in spec. Current scope is spec entity. + + elsif + Current_Scope = + Defining_Entity ( + Unit (Library_Unit (Cunit (Current_Sem_Unit)))) + then + Redundant := Cur_Use; + Prev_Use := Clause; + + else + -- The new clause may appear in an unrelated unit, when + -- the parents of a generic are being installed prior to + -- instantiation. In this case there must be no warning. + -- We detect this case by checking whether the current top + -- of the stack is related to the current compilation. + + Scop := Current_Scope; + while Present (Scop) + and then Scop /= Standard_Standard + loop + if Is_Compilation_Unit (Scop) + and then not Is_Child_Unit (Scop) + then + return; + + elsif Scop = Cunit_Entity (Current_Sem_Unit) then + exit; + end if; + + Scop := Scope (Scop); + end loop; + + Redundant := Cur_Use; + Prev_Use := Clause; + end if; + + elsif New_Unit = Current_Sem_Unit then + Redundant := Clause; + Prev_Use := Cur_Use; + + else + -- Neither is the current unit, so they appear in parent or + -- sibling units. Warning will be emitted elsewhere. + + return; + end if; + end; + + elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration + and then Present (Parent_Spec (Unit (Cunit (Current_Sem_Unit)))) + then + -- Use_clause is in child unit of current unit, and the child unit + -- appears in the context of the body of the parent, so it has been + -- installed first, even though it is the redundant one. Depending on + -- their placement in the context, the visible or the private parts + -- of the two units, either might appear as redundant, but the + -- message has to be on the current unit. + + if Get_Source_Unit (Cur_Use) = Current_Sem_Unit then + Redundant := Cur_Use; + Prev_Use := Clause; + else + Redundant := Clause; + Prev_Use := Cur_Use; + end if; + + -- If the new use clause appears in the private part of a parent unit + -- it may appear to be redundant w.r.t. a use clause in a child unit, + -- but the previous use clause was needed in the visible part of the + -- child, and no warning should be emitted. + + if Nkind (Parent (Decl)) = N_Package_Specification + and then + List_Containing (Decl) = Private_Declarations (Parent (Decl)) + then + declare + Par : constant Entity_Id := Defining_Entity (Parent (Decl)); + Spec : constant Node_Id := + Specification (Unit (Cunit (Current_Sem_Unit))); + + begin + if Is_Compilation_Unit (Par) + and then Par /= Cunit_Entity (Current_Sem_Unit) + and then Parent (Cur_Use) = Spec + and then + List_Containing (Cur_Use) = Visible_Declarations (Spec) + then + return; + end if; + end; + end if; + + -- Finally, if the current use clause is in the context then + -- the clause is redundant when it is nested within the unit. + + elsif Nkind (Parent (Cur_Use)) = N_Compilation_Unit + and then Nkind (Parent (Parent (Clause))) /= N_Compilation_Unit + and then Get_Source_Unit (Cur_Use) = Get_Source_Unit (Clause) + then + Redundant := Clause; + Prev_Use := Cur_Use; + + else + null; + end if; + + if Present (Redundant) then + Error_Msg_Sloc := Sloc (Prev_Use); + Error_Msg_NE -- CODEFIX + ("& is already use-visible through previous use clause #?", + Redundant, Pack_Name); + end if; + end Note_Redundant_Use; + + --------------- + -- Pop_Scope -- + --------------- + + procedure Pop_Scope is + SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); + S : constant Entity_Id := SST.Entity; + + begin + if Debug_Flag_E then + Write_Info; + end if; + + -- Set Default_Storage_Pool field of the library unit if necessary + + if Ekind_In (S, E_Package, E_Generic_Package) + and then + Nkind (Parent (Unit_Declaration_Node (S))) = N_Compilation_Unit + then + declare + Aux : constant Node_Id := + Aux_Decls_Node (Parent (Unit_Declaration_Node (S))); + begin + if No (Default_Storage_Pool (Aux)) then + Set_Default_Storage_Pool (Aux, Default_Pool); + end if; + end; + end if; + + Scope_Suppress := SST.Save_Scope_Suppress; + Local_Suppress_Stack_Top := SST.Save_Local_Suppress_Stack_Top; + Check_Policy_List := SST.Save_Check_Policy_List; + Default_Pool := SST.Save_Default_Storage_Pool; + + if Debug_Flag_W then + Write_Str ("<-- exiting scope: "); + Write_Name (Chars (Current_Scope)); + Write_Str (", Depth="); + Write_Int (Int (Scope_Stack.Last)); + Write_Eol; + end if; + + End_Use_Clauses (SST.First_Use_Clause); + + -- If the actions to be wrapped are still there they will get lost + -- causing incomplete code to be generated. It is better to abort in + -- this case (and we do the abort even with assertions off since the + -- penalty is incorrect code generation) + + if SST.Actions_To_Be_Wrapped_Before /= No_List + or else + SST.Actions_To_Be_Wrapped_After /= No_List + then + raise Program_Error; + end if; + + -- Free last subprogram name if allocated, and pop scope + + Free (SST.Last_Subprogram_Name); + Scope_Stack.Decrement_Last; + end Pop_Scope; + + --------------- + -- Push_Scope -- + --------------- + + procedure Push_Scope (S : Entity_Id) is + E : constant Entity_Id := Scope (S); + + begin + if Ekind (S) = E_Void then + null; + + -- Set scope depth if not a non-concurrent type, and we have not yet set + -- the scope depth. This means that we have the first occurrence of the + -- scope, and this is where the depth is set. + + elsif (not Is_Type (S) or else Is_Concurrent_Type (S)) + and then not Scope_Depth_Set (S) + then + if S = Standard_Standard then + Set_Scope_Depth_Value (S, Uint_0); + + elsif Is_Child_Unit (S) then + Set_Scope_Depth_Value (S, Uint_1); + + elsif not Is_Record_Type (Current_Scope) then + if Ekind (S) = E_Loop then + Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope)); + else + Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope) + 1); + end if; + end if; + end if; + + Scope_Stack.Increment_Last; + + declare + SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); + + begin + SST.Entity := S; + SST.Save_Scope_Suppress := Scope_Suppress; + SST.Save_Local_Suppress_Stack_Top := Local_Suppress_Stack_Top; + SST.Save_Check_Policy_List := Check_Policy_List; + SST.Save_Default_Storage_Pool := Default_Pool; + + if Scope_Stack.Last > Scope_Stack.First then + SST.Component_Alignment_Default := Scope_Stack.Table + (Scope_Stack.Last - 1). + Component_Alignment_Default; + end if; + + SST.Last_Subprogram_Name := null; + SST.Is_Transient := False; + SST.Node_To_Be_Wrapped := Empty; + SST.Pending_Freeze_Actions := No_List; + SST.Actions_To_Be_Wrapped_Before := No_List; + SST.Actions_To_Be_Wrapped_After := No_List; + SST.First_Use_Clause := Empty; + SST.Is_Active_Stack_Base := False; + SST.Previous_Visibility := False; + end; + + if Debug_Flag_W then + Write_Str ("--> new scope: "); + Write_Name (Chars (Current_Scope)); + Write_Str (", Id="); + Write_Int (Int (Current_Scope)); + Write_Str (", Depth="); + Write_Int (Int (Scope_Stack.Last)); + Write_Eol; + end if; + + -- Deal with copying flags from the previous scope to this one. This is + -- not necessary if either scope is standard, or if the new scope is a + -- child unit. + + if S /= Standard_Standard + and then Scope (S) /= Standard_Standard + and then not Is_Child_Unit (S) + then + if Nkind (E) not in N_Entity then + return; + end if; + + -- Copy categorization flags from Scope (S) to S, this is not done + -- when Scope (S) is Standard_Standard since propagation is from + -- library unit entity inwards. Copy other relevant attributes as + -- well (Discard_Names in particular). + + -- We only propagate inwards for library level entities, + -- inner level subprograms do not inherit the categorization. + + if Is_Library_Level_Entity (S) then + Set_Is_Preelaborated (S, Is_Preelaborated (E)); + Set_Is_Shared_Passive (S, Is_Shared_Passive (E)); + Set_Discard_Names (S, Discard_Names (E)); + Set_Suppress_Value_Tracking_On_Call + (S, Suppress_Value_Tracking_On_Call (E)); + Set_Categorization_From_Scope (E => S, Scop => E); + end if; + end if; + + if Is_Child_Unit (S) + and then Present (E) + and then Ekind_In (E, E_Package, E_Generic_Package) + and then + Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit + then + declare + Aux : constant Node_Id := + Aux_Decls_Node (Parent (Unit_Declaration_Node (E))); + begin + if Present (Default_Storage_Pool (Aux)) then + Default_Pool := Default_Storage_Pool (Aux); + end if; + end; + end if; + end Push_Scope; + + --------------------- + -- Premature_Usage -- + --------------------- + + procedure Premature_Usage (N : Node_Id) is + Kind : constant Node_Kind := Nkind (Parent (Entity (N))); + E : Entity_Id := Entity (N); + + begin + -- Within an instance, the analysis of the actual for a formal object + -- does not see the name of the object itself. This is significant only + -- if the object is an aggregate, where its analysis does not do any + -- name resolution on component associations. (see 4717-008). In such a + -- case, look for the visible homonym on the chain. + + if In_Instance + and then Present (Homonym (E)) + then + E := Homonym (E); + + while Present (E) + and then not In_Open_Scopes (Scope (E)) + loop + E := Homonym (E); + end loop; + + if Present (E) then + Set_Entity (N, E); + Set_Etype (N, Etype (E)); + return; + end if; + end if; + + if Kind = N_Component_Declaration then + Error_Msg_N + ("component&! cannot be used before end of record declaration", N); + + elsif Kind = N_Parameter_Specification then + Error_Msg_N + ("formal parameter&! cannot be used before end of specification", + N); + + elsif Kind = N_Discriminant_Specification then + Error_Msg_N + ("discriminant&! cannot be used before end of discriminant part", + N); + + elsif Kind = N_Procedure_Specification + or else Kind = N_Function_Specification + then + Error_Msg_N + ("subprogram&! cannot be used before end of its declaration", + N); + + elsif Kind = N_Full_Type_Declaration then + Error_Msg_N + ("type& cannot be used before end of its declaration!", N); + + else + Error_Msg_N + ("object& cannot be used before end of its declaration!", N); + end if; + end Premature_Usage; + + ------------------------ + -- Present_System_Aux -- + ------------------------ + + function Present_System_Aux (N : Node_Id := Empty) return Boolean is + Loc : Source_Ptr; + Aux_Name : Unit_Name_Type; + Unum : Unit_Number_Type; + Withn : Node_Id; + With_Sys : Node_Id; + The_Unit : Node_Id; + + function Find_System (C_Unit : Node_Id) return Entity_Id; + -- Scan context clause of compilation unit to find with_clause + -- for System. + + ----------------- + -- Find_System -- + ----------------- + + function Find_System (C_Unit : Node_Id) return Entity_Id is + With_Clause : Node_Id; + + begin + With_Clause := First (Context_Items (C_Unit)); + while Present (With_Clause) loop + if (Nkind (With_Clause) = N_With_Clause + and then Chars (Name (With_Clause)) = Name_System) + and then Comes_From_Source (With_Clause) + then + return With_Clause; + end if; + + Next (With_Clause); + end loop; + + return Empty; + end Find_System; + + -- Start of processing for Present_System_Aux + + begin + -- The child unit may have been loaded and analyzed already + + if Present (System_Aux_Id) then + return True; + + -- If no previous pragma for System.Aux, nothing to load + + elsif No (System_Extend_Unit) then + return False; + + -- Use the unit name given in the pragma to retrieve the unit. + -- Verify that System itself appears in the context clause of the + -- current compilation. If System is not present, an error will + -- have been reported already. + + else + With_Sys := Find_System (Cunit (Current_Sem_Unit)); + + The_Unit := Unit (Cunit (Current_Sem_Unit)); + + if No (With_Sys) + and then + (Nkind (The_Unit) = N_Package_Body + or else (Nkind (The_Unit) = N_Subprogram_Body + and then + not Acts_As_Spec (Cunit (Current_Sem_Unit)))) + then + With_Sys := Find_System (Library_Unit (Cunit (Current_Sem_Unit))); + end if; + + if No (With_Sys) + and then Present (N) + then + -- If we are compiling a subunit, we need to examine its + -- context as well (Current_Sem_Unit is the parent unit); + + The_Unit := Parent (N); + while Nkind (The_Unit) /= N_Compilation_Unit loop + The_Unit := Parent (The_Unit); + end loop; + + if Nkind (Unit (The_Unit)) = N_Subunit then + With_Sys := Find_System (The_Unit); + end if; + end if; + + if No (With_Sys) then + return False; + end if; + + Loc := Sloc (With_Sys); + Get_Name_String (Chars (Expression (System_Extend_Unit))); + Name_Buffer (8 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len); + Name_Buffer (1 .. 7) := "system."; + Name_Buffer (Name_Len + 8) := '%'; + Name_Buffer (Name_Len + 9) := 's'; + Name_Len := Name_Len + 9; + Aux_Name := Name_Find; + + Unum := + Load_Unit + (Load_Name => Aux_Name, + Required => False, + Subunit => False, + Error_Node => With_Sys); + + if Unum /= No_Unit then + Semantics (Cunit (Unum)); + System_Aux_Id := + Defining_Entity (Specification (Unit (Cunit (Unum)))); + + Withn := + Make_With_Clause (Loc, + Name => + Make_Expanded_Name (Loc, + Chars => Chars (System_Aux_Id), + Prefix => New_Reference_To (Scope (System_Aux_Id), Loc), + Selector_Name => New_Reference_To (System_Aux_Id, Loc))); + + Set_Entity (Name (Withn), System_Aux_Id); + + Set_Library_Unit (Withn, Cunit (Unum)); + Set_Corresponding_Spec (Withn, System_Aux_Id); + Set_First_Name (Withn, True); + Set_Implicit_With (Withn, True); + + Insert_After (With_Sys, Withn); + Mark_Rewrite_Insertion (Withn); + Set_Context_Installed (Withn); + + return True; + + -- Here if unit load failed + + else + Error_Msg_Name_1 := Name_System; + Error_Msg_Name_2 := Chars (Expression (System_Extend_Unit)); + Error_Msg_N + ("extension package `%.%` does not exist", + Opt.System_Extend_Unit); + return False; + end if; + end if; + end Present_System_Aux; + + ------------------------- + -- Restore_Scope_Stack -- + ------------------------- + + procedure Restore_Scope_Stack (Handle_Use : Boolean := True) is + E : Entity_Id; + S : Entity_Id; + Comp_Unit : Node_Id; + In_Child : Boolean := False; + Full_Vis : Boolean := True; + SS_Last : constant Int := Scope_Stack.Last; + + begin + -- Restore visibility of previous scope stack, if any + + for J in reverse 0 .. Scope_Stack.Last loop + exit when Scope_Stack.Table (J).Entity = Standard_Standard + or else No (Scope_Stack.Table (J).Entity); + + S := Scope_Stack.Table (J).Entity; + + if not Is_Hidden_Open_Scope (S) then + + -- If the parent scope is hidden, its entities are hidden as + -- well, unless the entity is the instantiation currently + -- being analyzed. + + if not Is_Hidden_Open_Scope (Scope (S)) + or else not Analyzed (Parent (S)) + or else Scope (S) = Standard_Standard + then + Set_Is_Immediately_Visible (S, True); + end if; + + E := First_Entity (S); + while Present (E) loop + if Is_Child_Unit (E) then + if not From_With_Type (E) then + Set_Is_Immediately_Visible (E, + Is_Visible_Child_Unit (E) or else In_Open_Scopes (E)); + + else + pragma Assert + (Nkind (Parent (E)) = N_Defining_Program_Unit_Name + and then + Nkind (Parent (Parent (E))) = N_Package_Specification); + Set_Is_Immediately_Visible (E, + Limited_View_Installed (Parent (Parent (E)))); + end if; + else + Set_Is_Immediately_Visible (E, True); + end if; + + Next_Entity (E); + + if not Full_Vis + and then Is_Package_Or_Generic_Package (S) + then + -- We are in the visible part of the package scope + + exit when E = First_Private_Entity (S); + end if; + end loop; + + -- The visibility of child units (siblings of current compilation) + -- must be restored in any case. Their declarations may appear + -- after the private part of the parent. + + if not Full_Vis then + while Present (E) loop + if Is_Child_Unit (E) then + Set_Is_Immediately_Visible (E, + Is_Visible_Child_Unit (E) or else In_Open_Scopes (E)); + end if; + + Next_Entity (E); + end loop; + end if; + end if; + + if Is_Child_Unit (S) + and not In_Child -- check only for current unit + then + In_Child := True; + + -- Restore visibility of parents according to whether the child + -- is private and whether we are in its visible part. + + Comp_Unit := Parent (Unit_Declaration_Node (S)); + + if Nkind (Comp_Unit) = N_Compilation_Unit + and then Private_Present (Comp_Unit) + then + Full_Vis := True; + + elsif Is_Package_Or_Generic_Package (S) + and then (In_Private_Part (S) or else In_Package_Body (S)) + then + Full_Vis := True; + + -- if S is the scope of some instance (which has already been + -- seen on the stack) it does not affect the visibility of + -- other scopes. + + elsif Is_Hidden_Open_Scope (S) then + null; + + elsif (Ekind (S) = E_Procedure + or else Ekind (S) = E_Function) + and then Has_Completion (S) + then + Full_Vis := True; + else + Full_Vis := False; + end if; + else + Full_Vis := True; + end if; + end loop; + + if SS_Last >= Scope_Stack.First + and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard + and then Handle_Use + then + Install_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause); + end if; + end Restore_Scope_Stack; + + ---------------------- + -- Save_Scope_Stack -- + ---------------------- + + procedure Save_Scope_Stack (Handle_Use : Boolean := True) is + E : Entity_Id; + S : Entity_Id; + SS_Last : constant Int := Scope_Stack.Last; + + begin + if SS_Last >= Scope_Stack.First + and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard + then + if Handle_Use then + End_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause); + end if; + + -- If the call is from within a compilation unit, as when called from + -- Rtsfind, make current entries in scope stack invisible while we + -- analyze the new unit. + + for J in reverse 0 .. SS_Last loop + exit when Scope_Stack.Table (J).Entity = Standard_Standard + or else No (Scope_Stack.Table (J).Entity); + + S := Scope_Stack.Table (J).Entity; + Set_Is_Immediately_Visible (S, False); + + E := First_Entity (S); + while Present (E) loop + Set_Is_Immediately_Visible (E, False); + Next_Entity (E); + end loop; + end loop; + + end if; + end Save_Scope_Stack; + + ------------- + -- Set_Use -- + ------------- + + procedure Set_Use (L : List_Id) is + Decl : Node_Id; + Pack_Name : Node_Id; + Pack : Entity_Id; + Id : Entity_Id; + + begin + if Present (L) then + Decl := First (L); + while Present (Decl) loop + if Nkind (Decl) = N_Use_Package_Clause then + Chain_Use_Clause (Decl); + + Pack_Name := First (Names (Decl)); + while Present (Pack_Name) loop + Pack := Entity (Pack_Name); + + if Ekind (Pack) = E_Package + and then Applicable_Use (Pack_Name) + then + Use_One_Package (Pack, Decl); + end if; + + Next (Pack_Name); + end loop; + + elsif Nkind (Decl) = N_Use_Type_Clause then + Chain_Use_Clause (Decl); + + Id := First (Subtype_Marks (Decl)); + while Present (Id) loop + if Entity (Id) /= Any_Type then + Use_One_Type (Id); + end if; + + Next (Id); + end loop; + end if; + + Next (Decl); + end loop; + end if; + end Set_Use; + + --------------------- + -- Use_One_Package -- + --------------------- + + procedure Use_One_Package (P : Entity_Id; N : Node_Id) is + Id : Entity_Id; + Prev : Entity_Id; + Current_Instance : Entity_Id := Empty; + Real_P : Entity_Id; + Private_With_OK : Boolean := False; + + begin + if Ekind (P) /= E_Package then + return; + end if; + + Set_In_Use (P); + Set_Current_Use_Clause (P, N); + + -- Ada 2005 (AI-50217): Check restriction + + if From_With_Type (P) then + Error_Msg_N ("limited withed package cannot appear in use clause", N); + end if; + + -- Find enclosing instance, if any + + if In_Instance then + Current_Instance := Current_Scope; + while not Is_Generic_Instance (Current_Instance) loop + Current_Instance := Scope (Current_Instance); + end loop; + + if No (Hidden_By_Use_Clause (N)) then + Set_Hidden_By_Use_Clause (N, New_Elmt_List); + end if; + end if; + + -- If unit is a package renaming, indicate that the renamed + -- package is also in use (the flags on both entities must + -- remain consistent, and a subsequent use of either of them + -- should be recognized as redundant). + + if Present (Renamed_Object (P)) then + Set_In_Use (Renamed_Object (P)); + Set_Current_Use_Clause (Renamed_Object (P), N); + Real_P := Renamed_Object (P); + else + Real_P := P; + end if; + + -- Ada 2005 (AI-262): Check the use_clause of a private withed package + -- found in the private part of a package specification + + if In_Private_Part (Current_Scope) + and then Has_Private_With (P) + and then Is_Child_Unit (Current_Scope) + and then Is_Child_Unit (P) + and then Is_Ancestor_Package (Scope (Current_Scope), P) + then + Private_With_OK := True; + end if; + + -- Loop through entities in one package making them potentially + -- use-visible. + + Id := First_Entity (P); + while Present (Id) + and then (Id /= First_Private_Entity (P) + or else Private_With_OK) -- Ada 2005 (AI-262) + loop + Prev := Current_Entity (Id); + while Present (Prev) loop + if Is_Immediately_Visible (Prev) + and then (not Is_Overloadable (Prev) + or else not Is_Overloadable (Id) + or else (Type_Conformant (Id, Prev))) + then + if No (Current_Instance) then + + -- Potentially use-visible entity remains hidden + + goto Next_Usable_Entity; + + -- A use clause within an instance hides outer global entities, + -- which are not used to resolve local entities in the + -- instance. Note that the predefined entities in Standard + -- could not have been hidden in the generic by a use clause, + -- and therefore remain visible. Other compilation units whose + -- entities appear in Standard must be hidden in an instance. + + -- To determine whether an entity is external to the instance + -- we compare the scope depth of its scope with that of the + -- current instance. However, a generic actual of a subprogram + -- instance is declared in the wrapper package but will not be + -- hidden by a use-visible entity. similarly, an entity that is + -- declared in an enclosing instance will not be hidden by an + -- an entity declared in a generic actual, which can only have + -- been use-visible in the generic and will not have hidden the + -- entity in the generic parent. + + -- If Id is called Standard, the predefined package with the + -- same name is in the homonym chain. It has to be ignored + -- because it has no defined scope (being the only entity in + -- the system with this mandated behavior). + + elsif not Is_Hidden (Id) + and then Present (Scope (Prev)) + and then not Is_Wrapper_Package (Scope (Prev)) + and then Scope_Depth (Scope (Prev)) < + Scope_Depth (Current_Instance) + and then (Scope (Prev) /= Standard_Standard + or else Sloc (Prev) > Standard_Location) + then + if In_Open_Scopes (Scope (Prev)) + and then Is_Generic_Instance (Scope (Prev)) + and then Present (Associated_Formal_Package (P)) + then + null; + + else + Set_Is_Potentially_Use_Visible (Id); + Set_Is_Immediately_Visible (Prev, False); + Append_Elmt (Prev, Hidden_By_Use_Clause (N)); + end if; + end if; + + -- A user-defined operator is not use-visible if the predefined + -- operator for the type is immediately visible, which is the case + -- if the type of the operand is in an open scope. This does not + -- apply to user-defined operators that have operands of different + -- types, because the predefined mixed mode operations (multiply + -- and divide) apply to universal types and do not hide anything. + + elsif Ekind (Prev) = E_Operator + and then Operator_Matches_Spec (Prev, Id) + and then In_Open_Scopes + (Scope (Base_Type (Etype (First_Formal (Id))))) + and then (No (Next_Formal (First_Formal (Id))) + or else Etype (First_Formal (Id)) + = Etype (Next_Formal (First_Formal (Id))) + or else Chars (Prev) = Name_Op_Expon) + then + goto Next_Usable_Entity; + + -- In an instance, two homonyms may become use_visible through the + -- actuals of distinct formal packages. In the generic, only the + -- current one would have been visible, so make the other one + -- not use_visible. + + elsif Present (Current_Instance) + and then Is_Potentially_Use_Visible (Prev) + and then not Is_Overloadable (Prev) + and then Scope (Id) /= Scope (Prev) + and then Used_As_Generic_Actual (Scope (Prev)) + and then Used_As_Generic_Actual (Scope (Id)) + and then not In_Same_List (Current_Use_Clause (Scope (Prev)), + Current_Use_Clause (Scope (Id))) + then + Set_Is_Potentially_Use_Visible (Prev, False); + Append_Elmt (Prev, Hidden_By_Use_Clause (N)); + end if; + + Prev := Homonym (Prev); + end loop; + + -- On exit, we know entity is not hidden, unless it is private + + if not Is_Hidden (Id) + and then ((not Is_Child_Unit (Id)) + or else Is_Visible_Child_Unit (Id)) + then + Set_Is_Potentially_Use_Visible (Id); + + if Is_Private_Type (Id) + and then Present (Full_View (Id)) + then + Set_Is_Potentially_Use_Visible (Full_View (Id)); + end if; + end if; + + <> + Next_Entity (Id); + end loop; + + -- Child units are also made use-visible by a use clause, but they may + -- appear after all visible declarations in the parent entity list. + + while Present (Id) loop + if Is_Child_Unit (Id) + and then Is_Visible_Child_Unit (Id) + then + Set_Is_Potentially_Use_Visible (Id); + end if; + + Next_Entity (Id); + end loop; + + if Chars (Real_P) = Name_System + and then Scope (Real_P) = Standard_Standard + and then Present_System_Aux (N) + then + Use_One_Package (System_Aux_Id, N); + end if; + + end Use_One_Package; + + ------------------ + -- Use_One_Type -- + ------------------ + + procedure Use_One_Type (Id : Node_Id) is + Elmt : Elmt_Id; + Is_Known_Used : Boolean; + Op_List : Elist_Id; + T : Entity_Id; + + function Spec_Reloaded_For_Body return Boolean; + -- Determine whether the compilation unit is a package body and the use + -- type clause is in the spec of the same package. Even though the spec + -- was analyzed first, its context is reloaded when analysing the body. + + ---------------------------- + -- Spec_Reloaded_For_Body -- + ---------------------------- + + function Spec_Reloaded_For_Body return Boolean is + begin + if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then + declare + Spec : constant Node_Id := + Parent (List_Containing (Parent (Id))); + begin + return + Nkind (Spec) = N_Package_Specification + and then Corresponding_Body (Parent (Spec)) = + Cunit_Entity (Current_Sem_Unit); + end; + end if; + + return False; + end Spec_Reloaded_For_Body; + + -- Start of processing for Use_One_Type; + + begin + -- It is the type determined by the subtype mark (8.4(8)) whose + -- operations become potentially use-visible. + + T := Base_Type (Entity (Id)); + + -- Either the type itself is used, the package where it is declared + -- is in use or the entity is declared in the current package, thus + -- use-visible. + + Is_Known_Used := + In_Use (T) + or else In_Use (Scope (T)) + or else Scope (T) = Current_Scope; + + Set_Redundant_Use (Id, + Is_Known_Used or else Is_Potentially_Use_Visible (T)); + + if Ekind (T) = E_Incomplete_Type then + Error_Msg_N ("premature usage of incomplete type", Id); + + elsif In_Open_Scopes (Scope (T)) then + null; + + -- A limited view cannot appear in a use_type clause. However, an access + -- type whose designated type is limited has the flag but is not itself + -- a limited view unless we only have a limited view of its enclosing + -- package. + + elsif From_With_Type (T) + and then From_With_Type (Scope (T)) + then + Error_Msg_N + ("incomplete type from limited view " + & "cannot appear in use clause", Id); + + -- If the subtype mark designates a subtype in a different package, + -- we have to check that the parent type is visible, otherwise the + -- use type clause is a noop. Not clear how to do that??? + + elsif not Redundant_Use (Id) then + Set_In_Use (T); + + -- If T is tagged, primitive operators on class-wide operands + -- are also available. + + if Is_Tagged_Type (T) then + Set_In_Use (Class_Wide_Type (T)); + end if; + + Set_Current_Use_Clause (T, Parent (Id)); + Op_List := Collect_Primitive_Operations (T); + + Elmt := First_Elmt (Op_List); + while Present (Elmt) loop + if (Nkind (Node (Elmt)) = N_Defining_Operator_Symbol + or else Chars (Node (Elmt)) in Any_Operator_Name) + and then not Is_Hidden (Node (Elmt)) + then + Set_Is_Potentially_Use_Visible (Node (Elmt)); + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + -- If warning on redundant constructs, check for unnecessary WITH + + if Warn_On_Redundant_Constructs + and then Is_Known_Used + + -- with P; with P; use P; + -- package P is package X is package body X is + -- type T ... use P.T; + + -- The compilation unit is the body of X. GNAT first compiles the + -- spec of X, then proceeds to the body. At that point P is marked + -- as use visible. The analysis then reinstalls the spec along with + -- its context. The use clause P.T is now recognized as redundant, + -- but in the wrong context. Do not emit a warning in such cases. + -- Do not emit a warning either if we are in an instance, there is + -- no redundancy between an outer use_clause and one that appears + -- within the generic. + + and then not Spec_Reloaded_For_Body + and then not In_Instance + then + -- The type already has a use clause + + if In_Use (T) then + + -- Case where we know the current use clause for the type + + if Present (Current_Use_Clause (T)) then + Use_Clause_Known : declare + Clause1 : constant Node_Id := Parent (Id); + Clause2 : constant Node_Id := Current_Use_Clause (T); + Ent1 : Entity_Id; + Ent2 : Entity_Id; + Err_No : Node_Id; + Unit1 : Node_Id; + Unit2 : Node_Id; + + function Entity_Of_Unit (U : Node_Id) return Entity_Id; + -- Return the appropriate entity for determining which unit + -- has a deeper scope: the defining entity for U, unless U + -- is a package instance, in which case we retrieve the + -- entity of the instance spec. + + -------------------- + -- Entity_Of_Unit -- + -------------------- + + function Entity_Of_Unit (U : Node_Id) return Entity_Id is + begin + if Nkind (U) = N_Package_Instantiation + and then Analyzed (U) + then + return Defining_Entity (Instance_Spec (U)); + else + return Defining_Entity (U); + end if; + end Entity_Of_Unit; + + -- Start of processing for Use_Clause_Known + + begin + -- If both current use type clause and the use type clause + -- for the type are at the compilation unit level, one of + -- the units must be an ancestor of the other, and the + -- warning belongs on the descendant. + + if Nkind (Parent (Clause1)) = N_Compilation_Unit + and then + Nkind (Parent (Clause2)) = N_Compilation_Unit + then + + -- If the unit is a subprogram body that acts as spec, + -- the context clause is shared with the constructed + -- subprogram spec. Clearly there is no redundancy. + + if Clause1 = Clause2 then + return; + end if; + + Unit1 := Unit (Parent (Clause1)); + Unit2 := Unit (Parent (Clause2)); + + -- If both clauses are on same unit, or one is the body + -- of the other, or one of them is in a subunit, report + -- redundancy on the later one. + + if Unit1 = Unit2 then + Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); + Error_Msg_NE -- CODEFIX + ("& is already use-visible through previous " + & "use_type_clause #?", Clause1, T); + return; + + elsif Nkind (Unit1) = N_Subunit then + Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); + Error_Msg_NE -- CODEFIX + ("& is already use-visible through previous " + & "use_type_clause #?", Clause1, T); + return; + + elsif Nkind_In (Unit2, N_Package_Body, N_Subprogram_Body) + and then Nkind (Unit1) /= Nkind (Unit2) + and then Nkind (Unit1) /= N_Subunit + then + Error_Msg_Sloc := Sloc (Clause1); + Error_Msg_NE -- CODEFIX + ("& is already use-visible through previous " + & "use_type_clause #?", Current_Use_Clause (T), T); + return; + end if; + + -- There is a redundant use type clause in a child unit. + -- Determine which of the units is more deeply nested. + -- If a unit is a package instance, retrieve the entity + -- and its scope from the instance spec. + + Ent1 := Entity_Of_Unit (Unit1); + Ent2 := Entity_Of_Unit (Unit2); + + if Scope (Ent2) = Standard_Standard then + Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); + Err_No := Clause1; + + elsif Scope (Ent1) = Standard_Standard then + Error_Msg_Sloc := Sloc (Id); + Err_No := Clause2; + + -- If both units are child units, we determine which one + -- is the descendant by the scope distance to the + -- ultimate parent unit. + + else + declare + S1, S2 : Entity_Id; + + begin + S1 := Scope (Ent1); + S2 := Scope (Ent2); + while Present (S1) + and then Present (S2) + and then S1 /= Standard_Standard + and then S2 /= Standard_Standard + loop + S1 := Scope (S1); + S2 := Scope (S2); + end loop; + + if S1 = Standard_Standard then + Error_Msg_Sloc := Sloc (Id); + Err_No := Clause2; + else + Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); + Err_No := Clause1; + end if; + end; + end if; + + Error_Msg_NE -- CODEFIX + ("& is already use-visible through previous " + & "use_type_clause #?", Err_No, Id); + + -- Case where current use type clause and the use type + -- clause for the type are not both at the compilation unit + -- level. In this case we don't have location information. + + else + Error_Msg_NE -- CODEFIX + ("& is already use-visible through previous " + & "use type clause?", Id, T); + end if; + end Use_Clause_Known; + + -- Here if Current_Use_Clause is not set for T, another case + -- where we do not have the location information available. + + else + Error_Msg_NE -- CODEFIX + ("& is already use-visible through previous " + & "use type clause?", Id, T); + end if; + + -- The package where T is declared is already used + + elsif In_Use (Scope (T)) then + Error_Msg_Sloc := Sloc (Current_Use_Clause (Scope (T))); + Error_Msg_NE -- CODEFIX + ("& is already use-visible through package use clause #?", + Id, T); + + -- The current scope is the package where T is declared + + else + Error_Msg_Node_2 := Scope (T); + Error_Msg_NE -- CODEFIX + ("& is already use-visible inside package &?", Id, T); + end if; + end if; + end Use_One_Type; + + ---------------- + -- Write_Info -- + ---------------- + + procedure Write_Info is + Id : Entity_Id := First_Entity (Current_Scope); + + begin + -- No point in dumping standard entities + + if Current_Scope = Standard_Standard then + return; + end if; + + Write_Str ("========================================================"); + Write_Eol; + Write_Str (" Defined Entities in "); + Write_Name (Chars (Current_Scope)); + Write_Eol; + Write_Str ("========================================================"); + Write_Eol; + + if No (Id) then + Write_Str ("-- none --"); + Write_Eol; + + else + while Present (Id) loop + Write_Entity_Info (Id, " "); + Next_Entity (Id); + end loop; + end if; + + if Scope (Current_Scope) = Standard_Standard then + + -- Print information on the current unit itself + + Write_Entity_Info (Current_Scope, " "); + end if; + + Write_Eol; + end Write_Info; + + -------- + -- ws -- + -------- + + procedure ws is + S : Entity_Id; + begin + for J in reverse 1 .. Scope_Stack.Last loop + S := Scope_Stack.Table (J).Entity; + Write_Int (Int (S)); + Write_Str (" === "); + Write_Name (Chars (S)); + Write_Eol; + end loop; + end ws; + +end Sem_Ch8; diff --git a/gcc/ada/sem_ch8.ads b/gcc/ada/sem_ch8.ads new file mode 100644 index 000000000..a7f0af95d --- /dev/null +++ b/gcc/ada/sem_ch8.ads @@ -0,0 +1,160 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 8 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Types; use Types; +package Sem_Ch8 is + + ----------------------------------- + -- Handling extensions of System -- + ----------------------------------- + + -- For targets that define a much larger System package than given in + -- the RM, we use a child package containing additional declarations, + -- which is loaded when needed, and whose entities are conceptually + -- within System itself. The presence of this auxiliary package is + -- controlled with the pragma Extend_System. The following variable + -- holds the entity of the auxiliary package, to simplify the special + -- visibility rules that apply to it. + + System_Aux_Id : Entity_Id := Empty; + + ----------------- + -- Subprograms -- + ----------------- + + procedure Analyze_Exception_Renaming (N : Node_Id); + procedure Analyze_Expanded_Name (N : Node_Id); + procedure Analyze_Generic_Function_Renaming (N : Node_Id); + procedure Analyze_Generic_Package_Renaming (N : Node_Id); + procedure Analyze_Generic_Procedure_Renaming (N : Node_Id); + procedure Analyze_Object_Renaming (N : Node_Id); + procedure Analyze_Package_Renaming (N : Node_Id); + procedure Analyze_Subprogram_Renaming (N : Node_Id); + procedure Analyze_Use_Package (N : Node_Id); + procedure Analyze_Use_Type (N : Node_Id); + + procedure End_Scope; + -- Called at end of scope. On exit from blocks and bodies (subprogram, + -- package, task, and protected bodies), the name of the current scope + -- must be removed from the scope stack, and the local entities must be + -- removed from their homonym chains. On exit from record declarations, + -- from package specifications, and from tasks and protected type + -- specifications, more specialized procedures are invoked. + + procedure End_Use_Clauses (Clause : Node_Id); + -- Invoked on scope exit, to undo the effect of local use clauses. Clause + -- is the first use-clause of a scope being exited. This can be the current + -- scope, or some enclosing scopes when building a clean environment to + -- compile an instance body for inlining. + + procedure End_Use_Package (N : Node_Id); + procedure End_Use_Type (N : Node_Id); + -- Subsidiaries of End_Use_Clauses. Also called directly for use clauses + -- appearing in context clauses. + + procedure Find_Direct_Name (N : Node_Id); + -- Given a direct name (Identifier or Operator_Symbol), this routine scans + -- the homonym chain for the name searching for corresponding visible + -- entities to find the referenced entity (or in the case of overloading, + -- entities). On return, the Entity and Etype fields are set. In the + -- non-overloaded case, these are the correct final entries. In the + -- overloaded case, Is_Overloaded is set, Etype and Entity refer to an + -- arbitrary element of the overloads set, and an appropriate list of + -- entries has been made in the overload interpretation table (to be + -- disambiguated in the resolve phase). + + procedure Find_Selected_Component (N : Node_Id); + -- Resolve various cases of selected components, recognize expanded names + + procedure Find_Type (N : Node_Id); + -- Perform name resolution, and verify that the name found is that of a + -- type. On return the Entity and Etype fields of the node N are set + -- appropriately. If it is an incomplete type whose full declaration has + -- been seen, they are set to the entity in the full declaration. If it + -- is an incomplete type associated with an interface visible through a + -- limited-with clause, whose full declaration has been seen, they are + -- set to the entity in the full declaration. Similarly, if the type is + -- private, it has received a full declaration, and we are in the private + -- part or body of the package, then the two fields are set to the entity + -- of the full declaration as well. This procedure also has special + -- processing for 'Class attribute references. + + procedure Initialize; + -- Initializes data structures used for visibility analysis. Must be + -- called before analyzing each new main source program. + + procedure Install_Use_Clauses + (Clause : Node_Id; + Force_Installation : Boolean := False); + -- Applies the use clauses appearing in a given declarative part, + -- when the corresponding scope has been placed back on the scope + -- stack after unstacking to compile a different context (subunit or + -- parent of generic body). Force_Installation is used when called from + -- Analyze_Subunit.Re_Install_Use_Clauses to insure that, after the + -- analysis of the subunit, the parent's environment is again identical. + + function In_Open_Scopes (S : Entity_Id) return Boolean; + -- S is the entity of a scope. This function determines if this scope + -- is currently open (i.e. it appears somewhere in the scope stack). + + procedure Push_Scope (S : Entity_Id); + -- Make new scope stack entry, pushing S, the entity for a scope + -- onto the top of the scope table. The current setting of the scope + -- suppress flags is saved for restoration on exit. + + procedure Pop_Scope; + -- Remove top entry from scope stack, restoring the saved setting + -- of the scope suppress flags. + + function Present_System_Aux (N : Node_Id := Empty) return Boolean; + -- Return True if the auxiliary system file has been successfully loaded. + -- Otherwise attempt to load it, using the name supplied by a previous + -- Extend_System pragma, and report on the success of the load. If N is + -- present, it is a selected component whose prefix is System, or else a + -- with-clause on system. N is absent when the function is called to find + -- the visibility of implicit operators. + + procedure Restore_Scope_Stack (Handle_Use : Boolean := True); + procedure Save_Scope_Stack (Handle_Use : Boolean := True); + -- These two procedures are called from Semantics, when a unit U1 is to + -- be compiled in the course of the compilation of another unit U2. This + -- happens whenever Rtsfind is called. U1, the unit retrieved by Rtsfind, + -- must be compiled in its own context, and the current scope stack + -- containing U2 and local scopes must be made unreachable. On return, the + -- contents of the scope stack must be made accessible again. The flag + -- Handle_Use indicates whether local use clauses must be removed or + -- installed. In the case of inlining of instance bodies, the visibility + -- handling is done fully in Inline_Instance_Body, and use clauses are + -- handled there. + + procedure Set_Use (L : List_Id); + -- Find use clauses that are declarative items in a package declaration + -- and set the potentially use-visible flags of imported entities before + -- analyzing the corresponding package body. + + procedure ws; + -- Debugging routine for use in gdb: dump all entities on scope stack + +end Sem_Ch8; diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb new file mode 100644 index 000000000..a88b2d887 --- /dev/null +++ b/gcc/ada/sem_ch9.adb @@ -0,0 +1,2486 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 9 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Aspects; use Aspects; +with Atree; use Atree; +with Checks; use Checks; +with Einfo; use Einfo; +with Errout; use Errout; +with Exp_Ch9; use Exp_Ch9; +with Elists; use Elists; +with Freeze; use Freeze; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch5; use Sem_Ch5; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch13; use Sem_Ch13; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Snames; use Snames; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Style; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +package body Sem_Ch9 is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions); + -- Given either a protected definition or a task definition in D, check + -- the corresponding restriction parameter identifier R, and if it is set, + -- count the entries (checking the static requirement), and compare with + -- the given maximum. + + procedure Check_Interfaces (N : Node_Id; T : Entity_Id); + -- N is an N_Protected_Type_Declaration or N_Task_Type_Declaration node. + -- Complete decoration of T and check legality of the covered interfaces. + + procedure Check_Triggering_Statement + (Trigger : Node_Id; + Error_Node : Node_Id; + Is_Dispatching : out Boolean); + -- Examine the triggering statement of a select statement, conditional or + -- timed entry call. If Trigger is a dispatching call, return its status + -- in Is_Dispatching and check whether the primitive belongs to a limited + -- interface. If it does not, emit an error at Error_Node. + + function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id; + -- Find entity in corresponding task or protected declaration. Use full + -- view if first declaration was for an incomplete type. + + procedure Install_Declarations (Spec : Entity_Id); + -- Utility to make visible in corresponding body the entities defined in + -- task, protected type declaration, or entry declaration. + + ----------------------------- + -- Analyze_Abort_Statement -- + ----------------------------- + + procedure Analyze_Abort_Statement (N : Node_Id) is + T_Name : Node_Id; + + begin + Tasking_Used := True; + T_Name := First (Names (N)); + while Present (T_Name) loop + Analyze (T_Name); + + if Is_Task_Type (Etype (T_Name)) + or else (Ada_Version >= Ada_2005 + and then Ekind (Etype (T_Name)) = E_Class_Wide_Type + and then Is_Interface (Etype (T_Name)) + and then Is_Task_Interface (Etype (T_Name))) + then + Resolve (T_Name); + else + if Ada_Version >= Ada_2005 then + Error_Msg_N ("expect task name or task interface class-wide " + & "object for ABORT", T_Name); + else + Error_Msg_N ("expect task name for ABORT", T_Name); + end if; + + return; + end if; + + Next (T_Name); + end loop; + + Check_Restriction (No_Abort_Statements, N); + Check_Potentially_Blocking_Operation (N); + end Analyze_Abort_Statement; + + -------------------------------- + -- Analyze_Accept_Alternative -- + -------------------------------- + + procedure Analyze_Accept_Alternative (N : Node_Id) is + begin + Tasking_Used := True; + + if Present (Pragmas_Before (N)) then + Analyze_List (Pragmas_Before (N)); + end if; + + if Present (Condition (N)) then + Analyze_And_Resolve (Condition (N), Any_Boolean); + end if; + + Analyze (Accept_Statement (N)); + + if Is_Non_Empty_List (Statements (N)) then + Analyze_Statements (Statements (N)); + end if; + end Analyze_Accept_Alternative; + + ------------------------------ + -- Analyze_Accept_Statement -- + ------------------------------ + + procedure Analyze_Accept_Statement (N : Node_Id) is + Nam : constant Entity_Id := Entry_Direct_Name (N); + Formals : constant List_Id := Parameter_Specifications (N); + Index : constant Node_Id := Entry_Index (N); + Stats : constant Node_Id := Handled_Statement_Sequence (N); + Accept_Id : Entity_Id; + Entry_Nam : Entity_Id; + E : Entity_Id; + Kind : Entity_Kind; + Task_Nam : Entity_Id; + + begin + Tasking_Used := True; + + -- Entry name is initialized to Any_Id. It should get reset to the + -- matching entry entity. An error is signalled if it is not reset. + + Entry_Nam := Any_Id; + + for J in reverse 0 .. Scope_Stack.Last loop + Task_Nam := Scope_Stack.Table (J).Entity; + exit when Ekind (Etype (Task_Nam)) = E_Task_Type; + Kind := Ekind (Task_Nam); + + if Kind /= E_Block and then Kind /= E_Loop + and then not Is_Entry (Task_Nam) + then + Error_Msg_N ("enclosing body of accept must be a task", N); + return; + end if; + end loop; + + if Ekind (Etype (Task_Nam)) /= E_Task_Type then + Error_Msg_N ("invalid context for accept statement", N); + return; + end if; + + -- In order to process the parameters, we create a defining identifier + -- that can be used as the name of the scope. The name of the accept + -- statement itself is not a defining identifier, and we cannot use + -- its name directly because the task may have any number of accept + -- statements for the same entry. + + if Present (Index) then + Accept_Id := New_Internal_Entity + (E_Entry_Family, Current_Scope, Sloc (N), 'E'); + else + Accept_Id := New_Internal_Entity + (E_Entry, Current_Scope, Sloc (N), 'E'); + end if; + + Set_Etype (Accept_Id, Standard_Void_Type); + Set_Accept_Address (Accept_Id, New_Elmt_List); + + if Present (Formals) then + Push_Scope (Accept_Id); + Process_Formals (Formals, N); + Create_Extra_Formals (Accept_Id); + End_Scope; + end if; + + -- We set the default expressions processed flag because we don't need + -- default expression functions. This is really more like body entity + -- than a spec entity anyway. + + Set_Default_Expressions_Processed (Accept_Id); + + E := First_Entity (Etype (Task_Nam)); + while Present (E) loop + if Chars (E) = Chars (Nam) + and then (Ekind (E) = Ekind (Accept_Id)) + and then Type_Conformant (Accept_Id, E) + then + Entry_Nam := E; + exit; + end if; + + Next_Entity (E); + end loop; + + if Entry_Nam = Any_Id then + Error_Msg_N ("no entry declaration matches accept statement", N); + return; + else + Set_Entity (Nam, Entry_Nam); + Generate_Reference (Entry_Nam, Nam, 'b', Set_Ref => False); + Style.Check_Identifier (Nam, Entry_Nam); + end if; + + -- Verify that the entry is not hidden by a procedure declared in the + -- current block (pathological but possible). + + if Current_Scope /= Task_Nam then + declare + E1 : Entity_Id; + + begin + E1 := First_Entity (Current_Scope); + while Present (E1) loop + if Ekind (E1) = E_Procedure + and then Chars (E1) = Chars (Entry_Nam) + and then Type_Conformant (E1, Entry_Nam) + then + Error_Msg_N ("entry name is not visible", N); + end if; + + Next_Entity (E1); + end loop; + end; + end if; + + Set_Convention (Accept_Id, Convention (Entry_Nam)); + Check_Fully_Conformant (Accept_Id, Entry_Nam, N); + + for J in reverse 0 .. Scope_Stack.Last loop + exit when Task_Nam = Scope_Stack.Table (J).Entity; + + if Entry_Nam = Scope_Stack.Table (J).Entity then + Error_Msg_N ("duplicate accept statement for same entry", N); + end if; + end loop; + + declare + P : Node_Id := N; + begin + loop + P := Parent (P); + case Nkind (P) is + when N_Task_Body | N_Compilation_Unit => + exit; + when N_Asynchronous_Select => + Error_Msg_N ("accept statements are not allowed within" & + " an asynchronous select inner" & + " to the enclosing task body", N); + exit; + when others => + null; + end case; + end loop; + end; + + if Ekind (E) = E_Entry_Family then + if No (Index) then + Error_Msg_N ("missing entry index in accept for entry family", N); + else + Analyze_And_Resolve (Index, Entry_Index_Type (E)); + Apply_Range_Check (Index, Entry_Index_Type (E)); + end if; + + elsif Present (Index) then + Error_Msg_N ("invalid entry index in accept for simple entry", N); + end if; + + -- If label declarations present, analyze them. They are declared in the + -- enclosing task, but their enclosing scope is the entry itself, so + -- that goto's to the label are recognized as local to the accept. + + if Present (Declarations (N)) then + declare + Decl : Node_Id; + Id : Entity_Id; + + begin + Decl := First (Declarations (N)); + while Present (Decl) loop + Analyze (Decl); + + pragma Assert + (Nkind (Decl) = N_Implicit_Label_Declaration); + + Id := Defining_Identifier (Decl); + Set_Enclosing_Scope (Id, Entry_Nam); + Next (Decl); + end loop; + end; + end if; + + -- If statements are present, they must be analyzed in the context of + -- the entry, so that references to formals are correctly resolved. We + -- also have to add the declarations that are required by the expansion + -- of the accept statement in this case if expansion active. + + -- In the case of a select alternative of a selective accept, the + -- expander references the address declaration even if there is no + -- statement list. + + -- We also need to create the renaming declarations for the local + -- variables that will replace references to the formals within the + -- accept statement. + + Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam); + + -- Set Never_Set_In_Source and clear Is_True_Constant/Current_Value + -- fields on all entry formals (this loop ignores all other entities). + -- Reset Referenced, Referenced_As_xxx and Has_Pragma_Unreferenced as + -- well, so that we can post accurate warnings on each accept statement + -- for the same entry. + + E := First_Entity (Entry_Nam); + while Present (E) loop + if Is_Formal (E) then + Set_Never_Set_In_Source (E, True); + Set_Is_True_Constant (E, False); + Set_Current_Value (E, Empty); + Set_Referenced (E, False); + Set_Referenced_As_LHS (E, False); + Set_Referenced_As_Out_Parameter (E, False); + Set_Has_Pragma_Unreferenced (E, False); + end if; + + Next_Entity (E); + end loop; + + -- Analyze statements if present + + if Present (Stats) then + Push_Scope (Entry_Nam); + Install_Declarations (Entry_Nam); + + Set_Actual_Subtypes (N, Current_Scope); + + Analyze (Stats); + Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Nam); + End_Scope; + end if; + + -- Some warning checks + + Check_Potentially_Blocking_Operation (N); + Check_References (Entry_Nam, N); + Set_Entry_Accepted (Entry_Nam); + end Analyze_Accept_Statement; + + --------------------------------- + -- Analyze_Asynchronous_Select -- + --------------------------------- + + procedure Analyze_Asynchronous_Select (N : Node_Id) is + Is_Disp_Select : Boolean := False; + Trigger : Node_Id; + + begin + Tasking_Used := True; + Check_Restriction (Max_Asynchronous_Select_Nesting, N); + Check_Restriction (No_Select_Statements, N); + + if Ada_Version >= Ada_2005 then + Trigger := Triggering_Statement (Triggering_Alternative (N)); + + Analyze (Trigger); + + -- Ada 2005 (AI-345): Check for a potential dispatching select + + Check_Triggering_Statement (Trigger, N, Is_Disp_Select); + end if; + + -- Ada 2005 (AI-345): The expansion of the dispatching asynchronous + -- select will have to duplicate the triggering statements. Postpone + -- the analysis of the statements till expansion. Analyze only if the + -- expander is disabled in order to catch any semantic errors. + + if Is_Disp_Select then + if not Expander_Active then + Analyze_Statements (Statements (Abortable_Part (N))); + Analyze (Triggering_Alternative (N)); + end if; + + -- Analyze the statements. We analyze statements in the abortable part, + -- because this is the section that is executed first, and that way our + -- remembering of saved values and checks is accurate. + + else + Analyze_Statements (Statements (Abortable_Part (N))); + Analyze (Triggering_Alternative (N)); + end if; + end Analyze_Asynchronous_Select; + + ------------------------------------ + -- Analyze_Conditional_Entry_Call -- + ------------------------------------ + + procedure Analyze_Conditional_Entry_Call (N : Node_Id) is + Trigger : constant Node_Id := + Entry_Call_Statement (Entry_Call_Alternative (N)); + Is_Disp_Select : Boolean := False; + + begin + Check_Restriction (No_Select_Statements, N); + Tasking_Used := True; + + -- Ada 2005 (AI-345): The trigger may be a dispatching call + + if Ada_Version >= Ada_2005 then + Analyze (Trigger); + Check_Triggering_Statement (Trigger, N, Is_Disp_Select); + end if; + + if List_Length (Else_Statements (N)) = 1 + and then Nkind (First (Else_Statements (N))) in N_Delay_Statement + then + Error_Msg_N + ("suspicious form of conditional entry call?!", N); + Error_Msg_N + ("\`SELECT OR` may be intended rather than `SELECT ELSE`!", N); + end if; + + -- Postpone the analysis of the statements till expansion. Analyze only + -- if the expander is disabled in order to catch any semantic errors. + + if Is_Disp_Select then + if not Expander_Active then + Analyze (Entry_Call_Alternative (N)); + Analyze_Statements (Else_Statements (N)); + end if; + + -- Regular select analysis + + else + Analyze (Entry_Call_Alternative (N)); + Analyze_Statements (Else_Statements (N)); + end if; + end Analyze_Conditional_Entry_Call; + + -------------------------------- + -- Analyze_Delay_Alternative -- + -------------------------------- + + procedure Analyze_Delay_Alternative (N : Node_Id) is + Expr : Node_Id; + Typ : Entity_Id; + + begin + Tasking_Used := True; + Check_Restriction (No_Delay, N); + + if Present (Pragmas_Before (N)) then + Analyze_List (Pragmas_Before (N)); + end if; + + if Nkind_In (Parent (N), N_Selective_Accept, N_Timed_Entry_Call) then + Expr := Expression (Delay_Statement (N)); + + -- Defer full analysis until the statement is expanded, to insure + -- that generated code does not move past the guard. The delay + -- expression is only evaluated if the guard is open. + + if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then + Preanalyze_And_Resolve (Expr, Standard_Duration); + else + Preanalyze_And_Resolve (Expr); + end if; + + Typ := First_Subtype (Etype (Expr)); + + if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement + and then not Is_RTE (Typ, RO_CA_Time) + and then not Is_RTE (Typ, RO_RT_Time) + then + Error_Msg_N ("expect Time types for `DELAY UNTIL`", Expr); + end if; + + Check_Restriction (No_Fixed_Point, Expr); + + else + Analyze (Delay_Statement (N)); + end if; + + if Present (Condition (N)) then + Analyze_And_Resolve (Condition (N), Any_Boolean); + end if; + + if Is_Non_Empty_List (Statements (N)) then + Analyze_Statements (Statements (N)); + end if; + end Analyze_Delay_Alternative; + + ---------------------------- + -- Analyze_Delay_Relative -- + ---------------------------- + + procedure Analyze_Delay_Relative (N : Node_Id) is + E : constant Node_Id := Expression (N); + begin + Check_Restriction (No_Relative_Delay, N); + Tasking_Used := True; + Check_Restriction (No_Delay, N); + Check_Potentially_Blocking_Operation (N); + Analyze_And_Resolve (E, Standard_Duration); + Check_Restriction (No_Fixed_Point, E); + end Analyze_Delay_Relative; + + ------------------------- + -- Analyze_Delay_Until -- + ------------------------- + + procedure Analyze_Delay_Until (N : Node_Id) is + E : constant Node_Id := Expression (N); + Typ : Entity_Id; + + begin + Tasking_Used := True; + Check_Restriction (No_Delay, N); + Check_Potentially_Blocking_Operation (N); + Analyze (E); + Typ := First_Subtype (Etype (E)); + + if not Is_RTE (Typ, RO_CA_Time) and then + not Is_RTE (Typ, RO_RT_Time) + then + Error_Msg_N ("expect Time types for `DELAY UNTIL`", E); + end if; + end Analyze_Delay_Until; + + ------------------------ + -- Analyze_Entry_Body -- + ------------------------ + + procedure Analyze_Entry_Body (N : Node_Id) is + Id : constant Entity_Id := Defining_Identifier (N); + Decls : constant List_Id := Declarations (N); + Stats : constant Node_Id := Handled_Statement_Sequence (N); + Formals : constant Node_Id := Entry_Body_Formal_Part (N); + P_Type : constant Entity_Id := Current_Scope; + E : Entity_Id; + Entry_Name : Entity_Id; + + begin + Tasking_Used := True; + + -- Entry_Name is initialized to Any_Id. It should get reset to the + -- matching entry entity. An error is signalled if it is not reset + + Entry_Name := Any_Id; + + Analyze (Formals); + + if Present (Entry_Index_Specification (Formals)) then + Set_Ekind (Id, E_Entry_Family); + else + Set_Ekind (Id, E_Entry); + end if; + + Set_Scope (Id, Current_Scope); + Set_Etype (Id, Standard_Void_Type); + Set_Accept_Address (Id, New_Elmt_List); + + E := First_Entity (P_Type); + while Present (E) loop + if Chars (E) = Chars (Id) + and then (Ekind (E) = Ekind (Id)) + and then Type_Conformant (Id, E) + then + Entry_Name := E; + Set_Convention (Id, Convention (E)); + Set_Corresponding_Body (Parent (Entry_Name), Id); + Check_Fully_Conformant (Id, E, N); + + if Ekind (Id) = E_Entry_Family then + if not Fully_Conformant_Discrete_Subtypes ( + Discrete_Subtype_Definition (Parent (E)), + Discrete_Subtype_Definition + (Entry_Index_Specification (Formals))) + then + Error_Msg_N + ("index not fully conformant with previous declaration", + Discrete_Subtype_Definition + (Entry_Index_Specification (Formals))); + + else + -- The elaboration of the entry body does not recompute the + -- bounds of the index, which may have side effects. Inherit + -- the bounds from the entry declaration. This is critical + -- if the entry has a per-object constraint. If a bound is + -- given by a discriminant, it must be reanalyzed in order + -- to capture the discriminal of the current entry, rather + -- than that of the protected type. + + declare + Index_Spec : constant Node_Id := + Entry_Index_Specification (Formals); + + Def : constant Node_Id := + New_Copy_Tree + (Discrete_Subtype_Definition (Parent (E))); + + begin + if Nkind + (Original_Node + (Discrete_Subtype_Definition (Index_Spec))) = N_Range + then + Set_Etype (Def, Empty); + Set_Analyzed (Def, False); + + -- Keep the original subtree to ensure a properly + -- formed tree (e.g. for ASIS use). + + Rewrite + (Discrete_Subtype_Definition (Index_Spec), Def); + + Set_Analyzed (Low_Bound (Def), False); + Set_Analyzed (High_Bound (Def), False); + + if Denotes_Discriminant (Low_Bound (Def)) then + Set_Entity (Low_Bound (Def), Empty); + end if; + + if Denotes_Discriminant (High_Bound (Def)) then + Set_Entity (High_Bound (Def), Empty); + end if; + + Analyze (Def); + Make_Index (Def, Index_Spec); + Set_Etype + (Defining_Identifier (Index_Spec), Etype (Def)); + end if; + end; + end if; + end if; + + exit; + end if; + + Next_Entity (E); + end loop; + + if Entry_Name = Any_Id then + Error_Msg_N ("no entry declaration matches entry body", N); + return; + + elsif Has_Completion (Entry_Name) then + Error_Msg_N ("duplicate entry body", N); + return; + + else + Set_Has_Completion (Entry_Name); + Generate_Reference (Entry_Name, Id, 'b', Set_Ref => False); + Style.Check_Identifier (Id, Entry_Name); + end if; + + Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name); + Push_Scope (Entry_Name); + + Install_Declarations (Entry_Name); + Set_Actual_Subtypes (N, Current_Scope); + + -- The entity for the protected subprogram corresponding to the entry + -- has been created. We retain the name of this entity in the entry + -- body, for use when the corresponding subprogram body is created. + -- Note that entry bodies have no corresponding_spec, and there is no + -- easy link back in the tree between the entry body and the entity for + -- the entry itself, which is why we must propagate some attributes + -- explicitly from spec to body. + + Set_Protected_Body_Subprogram + (Id, Protected_Body_Subprogram (Entry_Name)); + + Set_Entry_Parameters_Type + (Id, Entry_Parameters_Type (Entry_Name)); + + -- Add a declaration for the Protection object, renaming declarations + -- for the discriminals and privals and finally a declaration for the + -- entry family index (if applicable). + + if Expander_Active + and then Is_Protected_Type (P_Type) + then + Install_Private_Data_Declarations + (Sloc (N), Entry_Name, P_Type, N, Decls); + end if; + + if Present (Decls) then + Analyze_Declarations (Decls); + Inspect_Deferred_Constant_Completion (Decls); + end if; + + if Present (Stats) then + Analyze (Stats); + end if; + + -- Check for unreferenced variables etc. Before the Check_References + -- call, we transfer Never_Set_In_Source and Referenced flags from + -- parameters in the spec to the corresponding entities in the body, + -- since we want the warnings on the body entities. Note that we do + -- not have to transfer Referenced_As_LHS, since that flag can only + -- be set for simple variables. + + -- At the same time, we set the flags on the spec entities to suppress + -- any warnings on the spec formals, since we also scan the spec. + -- Finally, we propagate the Entry_Component attribute to the body + -- formals, for use in the renaming declarations created later for the + -- formals (see exp_ch9.Add_Formal_Renamings). + + declare + E1 : Entity_Id; + E2 : Entity_Id; + + begin + E1 := First_Entity (Entry_Name); + while Present (E1) loop + E2 := First_Entity (Id); + while Present (E2) loop + exit when Chars (E1) = Chars (E2); + Next_Entity (E2); + end loop; + + -- If no matching body entity, then we already had a detected + -- error of some kind, so just don't worry about these warnings. + + if No (E2) then + goto Continue; + end if; + + if Ekind (E1) = E_Out_Parameter then + Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1)); + Set_Never_Set_In_Source (E1, False); + end if; + + Set_Referenced (E2, Referenced (E1)); + Set_Referenced (E1); + Set_Entry_Component (E2, Entry_Component (E1)); + + <> + Next_Entity (E1); + end loop; + + Check_References (Id); + end; + + -- We still need to check references for the spec, since objects + -- declared in the body are chained (in the First_Entity sense) to + -- the spec rather than the body in the case of entries. + + Check_References (Entry_Name); + + -- Process the end label, and terminate the scope + + Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Name); + End_Scope; + + -- If this is an entry family, remove the loop created to provide + -- a scope for the entry index. + + if Ekind (Id) = E_Entry_Family + and then Present (Entry_Index_Specification (Formals)) + then + End_Scope; + end if; + end Analyze_Entry_Body; + + ------------------------------------ + -- Analyze_Entry_Body_Formal_Part -- + ------------------------------------ + + procedure Analyze_Entry_Body_Formal_Part (N : Node_Id) is + Id : constant Entity_Id := Defining_Identifier (Parent (N)); + Index : constant Node_Id := Entry_Index_Specification (N); + Formals : constant List_Id := Parameter_Specifications (N); + + begin + Tasking_Used := True; + + if Present (Index) then + Analyze (Index); + + -- The entry index functions like a loop variable, thus it is known + -- to have a valid value. + + Set_Is_Known_Valid (Defining_Identifier (Index)); + end if; + + if Present (Formals) then + Set_Scope (Id, Current_Scope); + Push_Scope (Id); + Process_Formals (Formals, Parent (N)); + End_Scope; + end if; + end Analyze_Entry_Body_Formal_Part; + + ------------------------------------ + -- Analyze_Entry_Call_Alternative -- + ------------------------------------ + + procedure Analyze_Entry_Call_Alternative (N : Node_Id) is + Call : constant Node_Id := Entry_Call_Statement (N); + + begin + Tasking_Used := True; + + if Present (Pragmas_Before (N)) then + Analyze_List (Pragmas_Before (N)); + end if; + + if Nkind (Call) = N_Attribute_Reference then + + -- Possibly a stream attribute, but definitely illegal. Other + -- illegalities, such as procedure calls, are diagnosed after + -- resolution. + + Error_Msg_N ("entry call alternative requires an entry call", Call); + return; + end if; + + Analyze (Call); + + if Is_Non_Empty_List (Statements (N)) then + Analyze_Statements (Statements (N)); + end if; + end Analyze_Entry_Call_Alternative; + + ------------------------------- + -- Analyze_Entry_Declaration -- + ------------------------------- + + procedure Analyze_Entry_Declaration (N : Node_Id) is + D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N); + Def_Id : constant Entity_Id := Defining_Identifier (N); + Formals : constant List_Id := Parameter_Specifications (N); + + begin + Generate_Definition (Def_Id); + Tasking_Used := True; + + -- Case of no discrete subtype definition + + if No (D_Sdef) then + Set_Ekind (Def_Id, E_Entry); + + -- Processing for discrete subtype definition present + + else + Enter_Name (Def_Id); + Set_Ekind (Def_Id, E_Entry_Family); + Analyze (D_Sdef); + Make_Index (D_Sdef, N, Def_Id); + + -- Check subtype with predicate in entry family + + Bad_Predicated_Subtype_Use + ("subtype& has predicate, not allowed in entry family", + D_Sdef, Etype (D_Sdef)); + end if; + + -- Decorate Def_Id + + Set_Etype (Def_Id, Standard_Void_Type); + Set_Convention (Def_Id, Convention_Entry); + Set_Accept_Address (Def_Id, New_Elmt_List); + + -- Process formals + + if Present (Formals) then + Set_Scope (Def_Id, Current_Scope); + Push_Scope (Def_Id); + Process_Formals (Formals, N); + Create_Extra_Formals (Def_Id); + End_Scope; + end if; + + if Ekind (Def_Id) = E_Entry then + New_Overloaded_Entity (Def_Id); + end if; + + Generate_Reference_To_Formals (Def_Id); + Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N)); + end Analyze_Entry_Declaration; + + --------------------------------------- + -- Analyze_Entry_Index_Specification -- + --------------------------------------- + + -- The Defining_Identifier of the entry index specification is local to the + -- entry body, but it must be available in the entry barrier which is + -- evaluated outside of the entry body. The index is eventually renamed as + -- a run-time object, so is visibility is strictly a front-end concern. In + -- order to make it available to the barrier, we create an additional + -- scope, as for a loop, whose only declaration is the index name. This + -- loop is not attached to the tree and does not appear as an entity local + -- to the protected type, so its existence need only be known to routines + -- that process entry families. + + procedure Analyze_Entry_Index_Specification (N : Node_Id) is + Iden : constant Node_Id := Defining_Identifier (N); + Def : constant Node_Id := Discrete_Subtype_Definition (N); + Loop_Id : constant Entity_Id := Make_Temporary (Sloc (N), 'L'); + + begin + Tasking_Used := True; + Analyze (Def); + + -- There is no elaboration of the entry index specification. Therefore, + -- if the index is a range, it is not resolved and expanded, but the + -- bounds are inherited from the entry declaration, and reanalyzed. + -- See Analyze_Entry_Body. + + if Nkind (Def) /= N_Range then + Make_Index (Def, N); + end if; + + Set_Ekind (Loop_Id, E_Loop); + Set_Scope (Loop_Id, Current_Scope); + Push_Scope (Loop_Id); + Enter_Name (Iden); + Set_Ekind (Iden, E_Entry_Index_Parameter); + Set_Etype (Iden, Etype (Def)); + end Analyze_Entry_Index_Specification; + + ---------------------------- + -- Analyze_Protected_Body -- + ---------------------------- + + procedure Analyze_Protected_Body (N : Node_Id) is + Body_Id : constant Entity_Id := Defining_Identifier (N); + Last_E : Entity_Id; + + Spec_Id : Entity_Id; + -- This is initially the entity of the protected object or protected + -- type involved, but is replaced by the protected type always in the + -- case of a single protected declaration, since this is the proper + -- scope to be used. + + Ref_Id : Entity_Id; + -- This is the entity of the protected object or protected type + -- involved, and is the entity used for cross-reference purposes (it + -- differs from Spec_Id in the case of a single protected object, since + -- Spec_Id is set to the protected type in this case). + + begin + Tasking_Used := True; + Set_Ekind (Body_Id, E_Protected_Body); + Spec_Id := Find_Concurrent_Spec (Body_Id); + + if Present (Spec_Id) + and then Ekind (Spec_Id) = E_Protected_Type + then + null; + + elsif Present (Spec_Id) + and then Ekind (Etype (Spec_Id)) = E_Protected_Type + and then not Comes_From_Source (Etype (Spec_Id)) + then + null; + + else + Error_Msg_N ("missing specification for protected body", Body_Id); + return; + end if; + + Ref_Id := Spec_Id; + Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False); + Style.Check_Identifier (Body_Id, Spec_Id); + + -- The declarations are always attached to the type + + if Ekind (Spec_Id) /= E_Protected_Type then + Spec_Id := Etype (Spec_Id); + end if; + + Push_Scope (Spec_Id); + Set_Corresponding_Spec (N, Spec_Id); + Set_Corresponding_Body (Parent (Spec_Id), Body_Id); + Set_Has_Completion (Spec_Id); + Install_Declarations (Spec_Id); + + Expand_Protected_Body_Declarations (N, Spec_Id); + + Last_E := Last_Entity (Spec_Id); + + Analyze_Declarations (Declarations (N)); + + -- For visibility purposes, all entities in the body are private. Set + -- First_Private_Entity accordingly, if there was no private part in the + -- protected declaration. + + if No (First_Private_Entity (Spec_Id)) then + if Present (Last_E) then + Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E)); + else + Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id)); + end if; + end if; + + Check_Completion (Body_Id); + Check_References (Spec_Id); + Process_End_Label (N, 't', Ref_Id); + End_Scope; + end Analyze_Protected_Body; + + ---------------------------------- + -- Analyze_Protected_Definition -- + ---------------------------------- + + procedure Analyze_Protected_Definition (N : Node_Id) is + E : Entity_Id; + L : Entity_Id; + + procedure Undelay_Itypes (T : Entity_Id); + -- Itypes created for the private components of a protected type + -- do not receive freeze nodes, because there is no scope in which + -- they can be elaborated, and they can depend on discriminants of + -- the enclosed protected type. Given that the components can be + -- composite types with inner components, we traverse recursively + -- the private components of the protected type, and indicate that + -- all itypes within are frozen. This ensures that no freeze nodes + -- will be generated for them. + -- + -- On the other hand, components of the corresponding record are + -- frozen (or receive itype references) as for other records. + + -------------------- + -- Undelay_Itypes -- + -------------------- + + procedure Undelay_Itypes (T : Entity_Id) is + Comp : Entity_Id; + + begin + if Is_Protected_Type (T) then + Comp := First_Private_Entity (T); + elsif Is_Record_Type (T) then + Comp := First_Entity (T); + else + return; + end if; + + while Present (Comp) loop + if Is_Type (Comp) + and then Is_Itype (Comp) + then + Set_Has_Delayed_Freeze (Comp, False); + Set_Is_Frozen (Comp); + + if Is_Record_Type (Comp) + or else Is_Protected_Type (Comp) + then + Undelay_Itypes (Comp); + end if; + end if; + + Next_Entity (Comp); + end loop; + end Undelay_Itypes; + + -- Start of processing for Analyze_Protected_Definition + + begin + Tasking_Used := True; + Analyze_Declarations (Visible_Declarations (N)); + + if Present (Private_Declarations (N)) + and then not Is_Empty_List (Private_Declarations (N)) + then + L := Last_Entity (Current_Scope); + Analyze_Declarations (Private_Declarations (N)); + + if Present (L) then + Set_First_Private_Entity (Current_Scope, Next_Entity (L)); + else + Set_First_Private_Entity (Current_Scope, + First_Entity (Current_Scope)); + end if; + end if; + + E := First_Entity (Current_Scope); + while Present (E) loop + if Ekind_In (E, E_Function, E_Procedure) then + Set_Convention (E, Convention_Protected); + + elsif Is_Task_Type (Etype (E)) + or else Has_Task (Etype (E)) + then + Set_Has_Task (Current_Scope); + end if; + + Next_Entity (E); + end loop; + + Undelay_Itypes (Current_Scope); + + Check_Max_Entries (N, Max_Protected_Entries); + Process_End_Label (N, 'e', Current_Scope); + end Analyze_Protected_Definition; + + ---------------------------------------- + -- Analyze_Protected_Type_Declaration -- + ---------------------------------------- + + procedure Analyze_Protected_Type_Declaration (N : Node_Id) is + Def_Id : constant Entity_Id := Defining_Identifier (N); + E : Entity_Id; + T : Entity_Id; + + begin + if No_Run_Time_Mode then + Error_Msg_CRT ("protected type", N); + goto Leave; + end if; + + Tasking_Used := True; + Check_Restriction (No_Protected_Types, N); + + T := Find_Type_Name (N); + + -- In the case of an incomplete type, use the full view, unless it's not + -- present (as can occur for an incomplete view from a limited with). + + if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then + T := Full_View (T); + Set_Completion_Referenced (T); + end if; + + Set_Ekind (T, E_Protected_Type); + Set_Is_First_Subtype (T, True); + Init_Size_Align (T); + Set_Etype (T, T); + Set_Has_Delayed_Freeze (T, True); + Set_Stored_Constraint (T, No_Elist); + Push_Scope (T); + + if Ada_Version >= Ada_2005 then + Check_Interfaces (N, T); + end if; + + if Present (Discriminant_Specifications (N)) then + if Has_Discriminants (T) then + + -- Install discriminants. Also, verify conformance of + -- discriminants of previous and current view. ??? + + Install_Declarations (T); + else + Process_Discriminants (N); + end if; + end if; + + Set_Is_Constrained (T, not Has_Discriminants (T)); + + Analyze (Protected_Definition (N)); + + -- In the case where the protected type is declared at a nested level + -- and the No_Local_Protected_Objects restriction applies, issue a + -- warning that objects of the type will violate the restriction. + + if Restriction_Check_Required (No_Local_Protected_Objects) + and then not Is_Library_Level_Entity (T) + and then Comes_From_Source (T) + then + Error_Msg_Sloc := Restrictions_Loc (No_Local_Protected_Objects); + + if Error_Msg_Sloc = No_Location then + Error_Msg_N + ("objects of this type will violate " & + "`No_Local_Protected_Objects`?", N); + else + Error_Msg_N + ("objects of this type will violate " & + "`No_Local_Protected_Objects`?#", N); + end if; + end if; + + -- Protected types with entries are controlled (because of the + -- Protection component if nothing else), same for any protected type + -- with interrupt handlers. Note that we need to analyze the protected + -- definition to set Has_Entries and such. + + if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False + or else Number_Entries (T) > 1) + and then + (Has_Entries (T) + or else Has_Interrupt_Handler (T) + or else Has_Attach_Handler (T)) + then + Set_Has_Controlled_Component (T, True); + end if; + + -- The Ekind of components is E_Void during analysis to detect illegal + -- uses. Now it can be set correctly. + + E := First_Entity (Current_Scope); + while Present (E) loop + if Ekind (E) = E_Void then + Set_Ekind (E, E_Component); + Init_Component_Location (E); + end if; + + Next_Entity (E); + end loop; + + End_Scope; + + -- Case of a completion of a private declaration + + if T /= Def_Id + and then Is_Private_Type (Def_Id) + then + -- Deal with preelaborable initialization. Note that this processing + -- is done by Process_Full_View, but as can be seen below, in this + -- case the call to Process_Full_View is skipped if any serious + -- errors have occurred, and we don't want to lose this check. + + if Known_To_Have_Preelab_Init (Def_Id) then + Set_Must_Have_Preelab_Init (T); + end if; + + -- Create corresponding record now, because some private dependents + -- may be subtypes of the partial view. Skip if errors are present, + -- to prevent cascaded messages. + + if Serious_Errors_Detected = 0 + and then Expander_Active + then + Expand_N_Protected_Type_Declaration (N); + Process_Full_View (N, T, Def_Id); + end if; + end if; + + <> + Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N)); + end Analyze_Protected_Type_Declaration; + + --------------------- + -- Analyze_Requeue -- + --------------------- + + procedure Analyze_Requeue (N : Node_Id) is + Count : Natural := 0; + Entry_Name : Node_Id := Name (N); + Entry_Id : Entity_Id; + I : Interp_Index; + Is_Disp_Req : Boolean; + It : Interp; + Enclosing : Entity_Id; + Target_Obj : Node_Id := Empty; + Req_Scope : Entity_Id; + Outer_Ent : Entity_Id; + + begin + Check_Restriction (No_Requeue_Statements, N); + Check_Unreachable_Code (N); + Tasking_Used := True; + + Enclosing := Empty; + for J in reverse 0 .. Scope_Stack.Last loop + Enclosing := Scope_Stack.Table (J).Entity; + exit when Is_Entry (Enclosing); + + if not Ekind_In (Enclosing, E_Block, E_Loop) then + Error_Msg_N ("requeue must appear within accept or entry body", N); + return; + end if; + end loop; + + Analyze (Entry_Name); + + if Etype (Entry_Name) = Any_Type then + return; + end if; + + if Nkind (Entry_Name) = N_Selected_Component then + Target_Obj := Prefix (Entry_Name); + Entry_Name := Selector_Name (Entry_Name); + end if; + + -- If an explicit target object is given then we have to check the + -- restrictions of 9.5.4(6). + + if Present (Target_Obj) then + + -- Locate containing concurrent unit and determine enclosing entry + -- body or outermost enclosing accept statement within the unit. + + Outer_Ent := Empty; + for S in reverse 0 .. Scope_Stack.Last loop + Req_Scope := Scope_Stack.Table (S).Entity; + + exit when Ekind (Req_Scope) in Task_Kind + or else Ekind (Req_Scope) in Protected_Kind; + + if Is_Entry (Req_Scope) then + Outer_Ent := Req_Scope; + end if; + end loop; + + pragma Assert (Present (Outer_Ent)); + + -- Check that the accessibility level of the target object is not + -- greater or equal to the outermost enclosing accept statement (or + -- entry body) unless it is a parameter of the innermost enclosing + -- accept statement (or entry body). + + if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent) + and then + (not Is_Entity_Name (Target_Obj) + or else Ekind (Entity (Target_Obj)) not in Formal_Kind + or else Enclosing /= Scope (Entity (Target_Obj))) + then + Error_Msg_N + ("target object has invalid level for requeue", Target_Obj); + end if; + end if; + + -- Overloaded case, find right interpretation + + if Is_Overloaded (Entry_Name) then + Entry_Id := Empty; + + -- Loop over candidate interpretations and filter out any that are + -- not parameterless, are not type conformant, are not entries, or + -- do not come from source. + + Get_First_Interp (Entry_Name, I, It); + while Present (It.Nam) loop + + -- Note: we test type conformance here, not subtype conformance. + -- Subtype conformance will be tested later on, but it is better + -- for error output in some cases not to do that here. + + if (No (First_Formal (It.Nam)) + or else (Type_Conformant (Enclosing, It.Nam))) + and then Ekind (It.Nam) = E_Entry + then + -- Ada 2005 (AI-345): Since protected and task types have + -- primitive entry wrappers, we only consider source entries. + + if Comes_From_Source (It.Nam) then + Count := Count + 1; + Entry_Id := It.Nam; + else + Remove_Interp (I); + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + + if Count = 0 then + Error_Msg_N ("no entry matches context", N); + return; + + elsif Count > 1 then + Error_Msg_N ("ambiguous entry name in requeue", N); + return; + + else + Set_Is_Overloaded (Entry_Name, False); + Set_Entity (Entry_Name, Entry_Id); + end if; + + -- Non-overloaded cases + + -- For the case of a reference to an element of an entry family, the + -- Entry_Name is an indexed component. + + elsif Nkind (Entry_Name) = N_Indexed_Component then + + -- Requeue to an entry out of the body + + if Nkind (Prefix (Entry_Name)) = N_Selected_Component then + Entry_Id := Entity (Selector_Name (Prefix (Entry_Name))); + + -- Requeue from within the body itself + + elsif Nkind (Prefix (Entry_Name)) = N_Identifier then + Entry_Id := Entity (Prefix (Entry_Name)); + + else + Error_Msg_N ("invalid entry_name specified", N); + return; + end if; + + -- If we had a requeue of the form REQUEUE A (B), then the parser + -- accepted it (because it could have been a requeue on an entry index. + -- If A turns out not to be an entry family, then the analysis of A (B) + -- turned it into a function call. + + elsif Nkind (Entry_Name) = N_Function_Call then + Error_Msg_N + ("arguments not allowed in requeue statement", + First (Parameter_Associations (Entry_Name))); + return; + + -- Normal case of no entry family, no argument + + else + Entry_Id := Entity (Entry_Name); + end if; + + -- Ada 2012 (AI05-0030): Potential dispatching requeue statement. The + -- target type must be a concurrent interface class-wide type and the + -- target must be a procedure, flagged by pragma Implemented. + + Is_Disp_Req := + Ada_Version >= Ada_2012 + and then Present (Target_Obj) + and then Is_Class_Wide_Type (Etype (Target_Obj)) + and then Is_Concurrent_Interface (Etype (Target_Obj)) + and then Ekind (Entry_Id) = E_Procedure + and then Has_Rep_Pragma (Entry_Id, Name_Implemented); + + -- Resolve entry, and check that it is subtype conformant with the + -- enclosing construct if this construct has formals (RM 9.5.4(5)). + -- Ada 2005 (AI05-0030): Do not emit an error for this specific case. + + if not Is_Entry (Entry_Id) + and then not Is_Disp_Req + then + Error_Msg_N ("expect entry name in requeue statement", Name (N)); + + elsif Ekind (Entry_Id) = E_Entry_Family + and then Nkind (Entry_Name) /= N_Indexed_Component + then + Error_Msg_N ("missing index for entry family component", Name (N)); + + else + Resolve_Entry (Name (N)); + Generate_Reference (Entry_Id, Entry_Name); + + if Present (First_Formal (Entry_Id)) then + if VM_Target = JVM_Target then + Error_Msg_N + ("arguments unsupported in requeue statement", + First_Formal (Entry_Id)); + return; + end if; + + -- Ada 2012 (AI05-0030): Perform type conformance after skipping + -- the first parameter of Entry_Id since it is the interface + -- controlling formal. + + if Ada_Version >= Ada_2012 + and then Is_Disp_Req + then + declare + Enclosing_Formal : Entity_Id; + Target_Formal : Entity_Id; + + begin + Enclosing_Formal := First_Formal (Enclosing); + Target_Formal := Next_Formal (First_Formal (Entry_Id)); + while Present (Enclosing_Formal) + and then Present (Target_Formal) + loop + if not Conforming_Types + (T1 => Etype (Enclosing_Formal), + T2 => Etype (Target_Formal), + Ctype => Subtype_Conformant) + then + Error_Msg_Node_2 := Target_Formal; + Error_Msg_NE + ("formal & is not subtype conformant with &" & + "in dispatching requeue", N, Enclosing_Formal); + end if; + + Next_Formal (Enclosing_Formal); + Next_Formal (Target_Formal); + end loop; + end; + else + Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N)); + end if; + + -- Processing for parameters accessed by the requeue + + declare + Ent : Entity_Id; + + begin + Ent := First_Formal (Enclosing); + while Present (Ent) loop + + -- For OUT or IN OUT parameter, the effect of the requeue is + -- to assign the parameter a value on exit from the requeued + -- body, so we can set it as source assigned. We also clear + -- the Is_True_Constant indication. We do not need to clear + -- Current_Value, since the effect of the requeue is to + -- perform an unconditional goto so that any further + -- references will not occur anyway. + + if Ekind_In (Ent, E_Out_Parameter, E_In_Out_Parameter) then + Set_Never_Set_In_Source (Ent, False); + Set_Is_True_Constant (Ent, False); + end if; + + -- For all parameters, the requeue acts as a reference, + -- since the value of the parameter is passed to the new + -- entry, so we want to suppress unreferenced warnings. + + Set_Referenced (Ent); + Next_Formal (Ent); + end loop; + end; + end if; + end if; + end Analyze_Requeue; + + ------------------------------ + -- Analyze_Selective_Accept -- + ------------------------------ + + procedure Analyze_Selective_Accept (N : Node_Id) is + Alts : constant List_Id := Select_Alternatives (N); + Alt : Node_Id; + + Accept_Present : Boolean := False; + Terminate_Present : Boolean := False; + Delay_Present : Boolean := False; + Relative_Present : Boolean := False; + Alt_Count : Uint := Uint_0; + + begin + Check_Restriction (No_Select_Statements, N); + Tasking_Used := True; + + -- Loop to analyze alternatives + + Alt := First (Alts); + while Present (Alt) loop + Alt_Count := Alt_Count + 1; + Analyze (Alt); + + if Nkind (Alt) = N_Delay_Alternative then + if Delay_Present then + + if Relative_Present /= + (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement) + then + Error_Msg_N + ("delay_until and delay_relative alternatives ", Alt); + Error_Msg_N + ("\cannot appear in the same selective_wait", Alt); + end if; + + else + Delay_Present := True; + Relative_Present := + Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement; + end if; + + elsif Nkind (Alt) = N_Terminate_Alternative then + if Terminate_Present then + Error_Msg_N ("only one terminate alternative allowed", N); + else + Terminate_Present := True; + Check_Restriction (No_Terminate_Alternatives, N); + end if; + + elsif Nkind (Alt) = N_Accept_Alternative then + Accept_Present := True; + + -- Check for duplicate accept + + declare + Alt1 : Node_Id; + Stm : constant Node_Id := Accept_Statement (Alt); + EDN : constant Node_Id := Entry_Direct_Name (Stm); + Ent : Entity_Id; + + begin + if Nkind (EDN) = N_Identifier + and then No (Condition (Alt)) + and then Present (Entity (EDN)) -- defend against junk + and then Ekind (Entity (EDN)) = E_Entry + then + Ent := Entity (EDN); + + Alt1 := First (Alts); + while Alt1 /= Alt loop + if Nkind (Alt1) = N_Accept_Alternative + and then No (Condition (Alt1)) + then + declare + Stm1 : constant Node_Id := Accept_Statement (Alt1); + EDN1 : constant Node_Id := Entry_Direct_Name (Stm1); + + begin + if Nkind (EDN1) = N_Identifier then + if Entity (EDN1) = Ent then + Error_Msg_Sloc := Sloc (Stm1); + Error_Msg_N + ("?accept duplicates one on line#", Stm); + exit; + end if; + end if; + end; + end if; + + Next (Alt1); + end loop; + end if; + end; + end if; + + Next (Alt); + end loop; + + Check_Restriction (Max_Select_Alternatives, N, Alt_Count); + Check_Potentially_Blocking_Operation (N); + + if Terminate_Present and Delay_Present then + Error_Msg_N ("at most one of terminate or delay alternative", N); + + elsif not Accept_Present then + Error_Msg_N + ("select must contain at least one accept alternative", N); + end if; + + if Present (Else_Statements (N)) then + if Terminate_Present or Delay_Present then + Error_Msg_N ("else part not allowed with other alternatives", N); + end if; + + Analyze_Statements (Else_Statements (N)); + end if; + end Analyze_Selective_Accept; + + ------------------------------------------ + -- Analyze_Single_Protected_Declaration -- + ------------------------------------------ + + procedure Analyze_Single_Protected_Declaration (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Id : constant Node_Id := Defining_Identifier (N); + T : Entity_Id; + T_Decl : Node_Id; + O_Decl : Node_Id; + O_Name : constant Entity_Id := Id; + + begin + Generate_Definition (Id); + Tasking_Used := True; + + -- The node is rewritten as a protected type declaration, in exact + -- analogy with what is done with single tasks. + + T := + Make_Defining_Identifier (Sloc (Id), + New_External_Name (Chars (Id), 'T')); + + T_Decl := + Make_Protected_Type_Declaration (Loc, + Defining_Identifier => T, + Protected_Definition => Relocate_Node (Protected_Definition (N)), + Interface_List => Interface_List (N)); + + O_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => O_Name, + Object_Definition => Make_Identifier (Loc, Chars (T))); + + Move_Aspects (N, O_Decl); + Rewrite (N, T_Decl); + Insert_After (N, O_Decl); + Mark_Rewrite_Insertion (O_Decl); + + -- Enter names of type and object before analysis, because the name of + -- the object may be used in its own body. + + Enter_Name (T); + Set_Ekind (T, E_Protected_Type); + Set_Etype (T, T); + + Enter_Name (O_Name); + Set_Ekind (O_Name, E_Variable); + Set_Etype (O_Name, T); + + -- Instead of calling Analyze on the new node, call the proper analysis + -- procedure directly. Otherwise the node would be expanded twice, with + -- disastrous result. + + Analyze_Protected_Type_Declaration (N); + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); + end Analyze_Single_Protected_Declaration; + + ------------------------------------- + -- Analyze_Single_Task_Declaration -- + ------------------------------------- + + procedure Analyze_Single_Task_Declaration (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Id : constant Node_Id := Defining_Identifier (N); + T : Entity_Id; + T_Decl : Node_Id; + O_Decl : Node_Id; + O_Name : constant Entity_Id := Id; + + begin + Generate_Definition (Id); + Tasking_Used := True; + + -- The node is rewritten as a task type declaration, followed by an + -- object declaration of that anonymous task type. + + T := + Make_Defining_Identifier (Sloc (Id), + New_External_Name (Chars (Id), Suffix => "TK")); + + T_Decl := + Make_Task_Type_Declaration (Loc, + Defining_Identifier => T, + Task_Definition => Relocate_Node (Task_Definition (N)), + Interface_List => Interface_List (N)); + + -- We use the original defining identifier of the single task in the + -- generated object declaration, so that debugging information can + -- be attached to it when compiling with -gnatD. The parent of the + -- entity is the new object declaration. The single_task_declaration + -- is not used further in semantics or code generation, but is scanned + -- when generating debug information, and therefore needs the updated + -- Sloc information for the entity (see Sprint). Aspect specifications + -- are moved from the single task node to the object declaration node. + + O_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => O_Name, + Object_Definition => Make_Identifier (Loc, Chars (T))); + + Move_Aspects (N, O_Decl); + Rewrite (N, T_Decl); + Insert_After (N, O_Decl); + Mark_Rewrite_Insertion (O_Decl); + + -- Enter names of type and object before analysis, because the name of + -- the object may be used in its own body. + + Enter_Name (T); + Set_Ekind (T, E_Task_Type); + Set_Etype (T, T); + + Enter_Name (O_Name); + Set_Ekind (O_Name, E_Variable); + Set_Etype (O_Name, T); + + -- Instead of calling Analyze on the new node, call the proper analysis + -- procedure directly. Otherwise the node would be expanded twice, with + -- disastrous result. + + Analyze_Task_Type_Declaration (N); + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); + end Analyze_Single_Task_Declaration; + + ----------------------- + -- Analyze_Task_Body -- + ----------------------- + + procedure Analyze_Task_Body (N : Node_Id) is + Body_Id : constant Entity_Id := Defining_Identifier (N); + Decls : constant List_Id := Declarations (N); + HSS : constant Node_Id := Handled_Statement_Sequence (N); + Last_E : Entity_Id; + + Spec_Id : Entity_Id; + -- This is initially the entity of the task or task type involved, but + -- is replaced by the task type always in the case of a single task + -- declaration, since this is the proper scope to be used. + + Ref_Id : Entity_Id; + -- This is the entity of the task or task type, and is the entity used + -- for cross-reference purposes (it differs from Spec_Id in the case of + -- a single task, since Spec_Id is set to the task type) + + begin + Tasking_Used := True; + Set_Ekind (Body_Id, E_Task_Body); + Set_Scope (Body_Id, Current_Scope); + Spec_Id := Find_Concurrent_Spec (Body_Id); + + -- The spec is either a task type declaration, or a single task + -- declaration for which we have created an anonymous type. + + if Present (Spec_Id) + and then Ekind (Spec_Id) = E_Task_Type + then + null; + + elsif Present (Spec_Id) + and then Ekind (Etype (Spec_Id)) = E_Task_Type + and then not Comes_From_Source (Etype (Spec_Id)) + then + null; + + else + Error_Msg_N ("missing specification for task body", Body_Id); + return; + end if; + + if Has_Completion (Spec_Id) + and then Present (Corresponding_Body (Parent (Spec_Id))) + then + if Nkind (Parent (Spec_Id)) = N_Task_Type_Declaration then + Error_Msg_NE ("duplicate body for task type&", N, Spec_Id); + + else + Error_Msg_NE ("duplicate body for task&", N, Spec_Id); + end if; + end if; + + Ref_Id := Spec_Id; + Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False); + Style.Check_Identifier (Body_Id, Spec_Id); + + -- Deal with case of body of single task (anonymous type was created) + + if Ekind (Spec_Id) = E_Variable then + Spec_Id := Etype (Spec_Id); + end if; + + Push_Scope (Spec_Id); + Set_Corresponding_Spec (N, Spec_Id); + Set_Corresponding_Body (Parent (Spec_Id), Body_Id); + Set_Has_Completion (Spec_Id); + Install_Declarations (Spec_Id); + Last_E := Last_Entity (Spec_Id); + + Analyze_Declarations (Decls); + Inspect_Deferred_Constant_Completion (Decls); + + -- For visibility purposes, all entities in the body are private. Set + -- First_Private_Entity accordingly, if there was no private part in the + -- protected declaration. + + if No (First_Private_Entity (Spec_Id)) then + if Present (Last_E) then + Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E)); + else + Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id)); + end if; + end if; + + -- Mark all handlers as not suitable for local raise optimization, + -- since this optimization causes difficulties in a task context. + + if Present (Exception_Handlers (HSS)) then + declare + Handlr : Node_Id; + begin + Handlr := First (Exception_Handlers (HSS)); + while Present (Handlr) loop + Set_Local_Raise_Not_OK (Handlr); + Next (Handlr); + end loop; + end; + end if; + + -- Now go ahead and complete analysis of the task body + + Analyze (HSS); + Check_Completion (Body_Id); + Check_References (Body_Id); + Check_References (Spec_Id); + + -- Check for entries with no corresponding accept + + declare + Ent : Entity_Id; + + begin + Ent := First_Entity (Spec_Id); + while Present (Ent) loop + if Is_Entry (Ent) + and then not Entry_Accepted (Ent) + and then Comes_From_Source (Ent) + then + Error_Msg_NE ("no accept for entry &?", N, Ent); + end if; + + Next_Entity (Ent); + end loop; + end; + + Process_End_Label (HSS, 't', Ref_Id); + End_Scope; + end Analyze_Task_Body; + + ----------------------------- + -- Analyze_Task_Definition -- + ----------------------------- + + procedure Analyze_Task_Definition (N : Node_Id) is + L : Entity_Id; + + begin + Tasking_Used := True; + + if Present (Visible_Declarations (N)) then + Analyze_Declarations (Visible_Declarations (N)); + end if; + + if Present (Private_Declarations (N)) then + L := Last_Entity (Current_Scope); + Analyze_Declarations (Private_Declarations (N)); + + if Present (L) then + Set_First_Private_Entity + (Current_Scope, Next_Entity (L)); + else + Set_First_Private_Entity + (Current_Scope, First_Entity (Current_Scope)); + end if; + end if; + + Check_Max_Entries (N, Max_Task_Entries); + Process_End_Label (N, 'e', Current_Scope); + end Analyze_Task_Definition; + + ----------------------------------- + -- Analyze_Task_Type_Declaration -- + ----------------------------------- + + procedure Analyze_Task_Type_Declaration (N : Node_Id) is + Def_Id : constant Entity_Id := Defining_Identifier (N); + T : Entity_Id; + + begin + Check_Restriction (No_Tasking, N); + Tasking_Used := True; + T := Find_Type_Name (N); + Generate_Definition (T); + + -- In the case of an incomplete type, use the full view, unless it's not + -- present (as can occur for an incomplete view from a limited with). + + if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then + T := Full_View (T); + Set_Completion_Referenced (T); + end if; + + Set_Ekind (T, E_Task_Type); + Set_Is_First_Subtype (T, True); + Set_Has_Task (T, True); + Init_Size_Align (T); + Set_Etype (T, T); + Set_Has_Delayed_Freeze (T, True); + Set_Stored_Constraint (T, No_Elist); + Push_Scope (T); + + if Ada_Version >= Ada_2005 then + Check_Interfaces (N, T); + end if; + + if Present (Discriminant_Specifications (N)) then + if Ada_Version = Ada_83 and then Comes_From_Source (N) then + Error_Msg_N ("(Ada 83) task discriminant not allowed!", N); + end if; + + if Has_Discriminants (T) then + + -- Install discriminants. Also, verify conformance of + -- discriminants of previous and current view. ??? + + Install_Declarations (T); + else + Process_Discriminants (N); + end if; + end if; + + Set_Is_Constrained (T, not Has_Discriminants (T)); + + if Present (Task_Definition (N)) then + Analyze_Task_Definition (Task_Definition (N)); + end if; + + -- In the case where the task type is declared at a nested level and the + -- No_Task_Hierarchy restriction applies, issue a warning that objects + -- of the type will violate the restriction. + + if Restriction_Check_Required (No_Task_Hierarchy) + and then not Is_Library_Level_Entity (T) + and then Comes_From_Source (T) + then + Error_Msg_Sloc := Restrictions_Loc (No_Task_Hierarchy); + + if Error_Msg_Sloc = No_Location then + Error_Msg_N + ("objects of this type will violate `No_Task_Hierarchy`?", N); + else + Error_Msg_N + ("objects of this type will violate `No_Task_Hierarchy`?#", N); + end if; + end if; + + End_Scope; + + -- Case of a completion of a private declaration + + if T /= Def_Id + and then Is_Private_Type (Def_Id) + then + -- Deal with preelaborable initialization. Note that this processing + -- is done by Process_Full_View, but as can be seen below, in this + -- case the call to Process_Full_View is skipped if any serious + -- errors have occurred, and we don't want to lose this check. + + if Known_To_Have_Preelab_Init (Def_Id) then + Set_Must_Have_Preelab_Init (T); + end if; + + -- Create corresponding record now, because some private dependents + -- may be subtypes of the partial view. Skip if errors are present, + -- to prevent cascaded messages. + + if Serious_Errors_Detected = 0 + and then Expander_Active + then + Expand_N_Task_Type_Declaration (N); + Process_Full_View (N, T, Def_Id); + end if; + end if; + + Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N)); + end Analyze_Task_Type_Declaration; + + ----------------------------------- + -- Analyze_Terminate_Alternative -- + ----------------------------------- + + procedure Analyze_Terminate_Alternative (N : Node_Id) is + begin + Tasking_Used := True; + + if Present (Pragmas_Before (N)) then + Analyze_List (Pragmas_Before (N)); + end if; + + if Present (Condition (N)) then + Analyze_And_Resolve (Condition (N), Any_Boolean); + end if; + end Analyze_Terminate_Alternative; + + ------------------------------ + -- Analyze_Timed_Entry_Call -- + ------------------------------ + + procedure Analyze_Timed_Entry_Call (N : Node_Id) is + Trigger : constant Node_Id := + Entry_Call_Statement (Entry_Call_Alternative (N)); + Is_Disp_Select : Boolean := False; + + begin + Check_Restriction (No_Select_Statements, N); + Tasking_Used := True; + + -- Ada 2005 (AI-345): The trigger may be a dispatching call + + if Ada_Version >= Ada_2005 then + Analyze (Trigger); + Check_Triggering_Statement (Trigger, N, Is_Disp_Select); + end if; + + -- Postpone the analysis of the statements till expansion. Analyze only + -- if the expander is disabled in order to catch any semantic errors. + + if Is_Disp_Select then + if not Expander_Active then + Analyze (Entry_Call_Alternative (N)); + Analyze (Delay_Alternative (N)); + end if; + + -- Regular select analysis + + else + Analyze (Entry_Call_Alternative (N)); + Analyze (Delay_Alternative (N)); + end if; + end Analyze_Timed_Entry_Call; + + ------------------------------------ + -- Analyze_Triggering_Alternative -- + ------------------------------------ + + procedure Analyze_Triggering_Alternative (N : Node_Id) is + Trigger : constant Node_Id := Triggering_Statement (N); + + begin + Tasking_Used := True; + + if Present (Pragmas_Before (N)) then + Analyze_List (Pragmas_Before (N)); + end if; + + Analyze (Trigger); + + if Comes_From_Source (Trigger) + and then Nkind (Trigger) not in N_Delay_Statement + and then Nkind (Trigger) /= N_Entry_Call_Statement + then + if Ada_Version < Ada_2005 then + Error_Msg_N + ("triggering statement must be delay or entry call", Trigger); + + -- Ada 2005 (AI-345): If a procedure_call_statement is used for a + -- procedure_or_entry_call, the procedure_name or procedure_prefix + -- of the procedure_call_statement shall denote an entry renamed by a + -- procedure, or (a view of) a primitive subprogram of a limited + -- interface whose first parameter is a controlling parameter. + + elsif Nkind (Trigger) = N_Procedure_Call_Statement + and then not Is_Renamed_Entry (Entity (Name (Trigger))) + and then not Is_Controlling_Limited_Procedure + (Entity (Name (Trigger))) + then + Error_Msg_N ("triggering statement must be delay, procedure " & + "or entry call", Trigger); + end if; + end if; + + if Is_Non_Empty_List (Statements (N)) then + Analyze_Statements (Statements (N)); + end if; + end Analyze_Triggering_Alternative; + + ----------------------- + -- Check_Max_Entries -- + ----------------------- + + procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions) is + Ecount : Uint; + + procedure Count (L : List_Id); + -- Count entries in given declaration list + + ----------- + -- Count -- + ----------- + + procedure Count (L : List_Id) is + D : Node_Id; + + begin + if No (L) then + return; + end if; + + D := First (L); + while Present (D) loop + if Nkind (D) = N_Entry_Declaration then + declare + DSD : constant Node_Id := + Discrete_Subtype_Definition (D); + + begin + -- If not an entry family, then just one entry + + if No (DSD) then + Ecount := Ecount + 1; + + -- If entry family with static bounds, count entries + + elsif Is_OK_Static_Subtype (Etype (DSD)) then + declare + Lo : constant Uint := + Expr_Value + (Type_Low_Bound (Etype (DSD))); + Hi : constant Uint := + Expr_Value + (Type_High_Bound (Etype (DSD))); + + begin + if Hi >= Lo then + Ecount := Ecount + Hi - Lo + 1; + end if; + end; + + -- Entry family with non-static bounds + + else + -- Record an unknown count restriction, and if the + -- restriction is active, post a message or warning. + + Check_Restriction (R, D); + end if; + end; + end if; + + Next (D); + end loop; + end Count; + + -- Start of processing for Check_Max_Entries + + begin + Ecount := Uint_0; + Count (Visible_Declarations (D)); + Count (Private_Declarations (D)); + + if Ecount > 0 then + Check_Restriction (R, D, Ecount); + end if; + end Check_Max_Entries; + + ---------------------- + -- Check_Interfaces -- + ---------------------- + + procedure Check_Interfaces (N : Node_Id; T : Entity_Id) is + Iface : Node_Id; + Iface_Typ : Entity_Id; + + begin + pragma Assert + (Nkind_In (N, N_Protected_Type_Declaration, N_Task_Type_Declaration)); + + if Present (Interface_List (N)) then + Set_Is_Tagged_Type (T); + + Iface := First (Interface_List (N)); + while Present (Iface) loop + Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); + + if not Is_Interface (Iface_Typ) then + Error_Msg_NE + ("(Ada 2005) & must be an interface", Iface, Iface_Typ); + + else + -- Ada 2005 (AI-251): "The declaration of a specific descendant + -- of an interface type freezes the interface type" RM 13.14. + + Freeze_Before (N, Etype (Iface)); + + if Nkind (N) = N_Protected_Type_Declaration then + + -- Ada 2005 (AI-345): Protected types can only implement + -- limited, synchronized, or protected interfaces (note that + -- the predicate Is_Limited_Interface includes synchronized + -- and protected interfaces). + + if Is_Task_Interface (Iface_Typ) then + Error_Msg_N ("(Ada 2005) protected type cannot implement " + & "a task interface", Iface); + + elsif not Is_Limited_Interface (Iface_Typ) then + Error_Msg_N ("(Ada 2005) protected type cannot implement " + & "a non-limited interface", Iface); + end if; + + else pragma Assert (Nkind (N) = N_Task_Type_Declaration); + + -- Ada 2005 (AI-345): Task types can only implement limited, + -- synchronized, or task interfaces (note that the predicate + -- Is_Limited_Interface includes synchronized and task + -- interfaces). + + if Is_Protected_Interface (Iface_Typ) then + Error_Msg_N ("(Ada 2005) task type cannot implement a " & + "protected interface", Iface); + + elsif not Is_Limited_Interface (Iface_Typ) then + Error_Msg_N ("(Ada 2005) task type cannot implement a " & + "non-limited interface", Iface); + end if; + end if; + end if; + + Next (Iface); + end loop; + end if; + + if not Has_Private_Declaration (T) then + return; + end if; + + -- Additional checks on full-types associated with private type + -- declarations. Search for the private type declaration. + + declare + Full_T_Ifaces : Elist_Id; + Iface : Node_Id; + Priv_T : Entity_Id; + Priv_T_Ifaces : Elist_Id; + + begin + Priv_T := First_Entity (Scope (T)); + loop + pragma Assert (Present (Priv_T)); + + if Is_Type (Priv_T) and then Present (Full_View (Priv_T)) then + exit when Full_View (Priv_T) = T; + end if; + + Next_Entity (Priv_T); + end loop; + + -- In case of synchronized types covering interfaces the private type + -- declaration must be limited. + + if Present (Interface_List (N)) + and then not Is_Limited_Record (Priv_T) + then + Error_Msg_Sloc := Sloc (Priv_T); + Error_Msg_N ("(Ada 2005) limited type declaration expected for " & + "private type#", T); + end if; + + -- RM 7.3 (7.1/2): If the full view has a partial view that is + -- tagged then check RM 7.3 subsidiary rules. + + if Is_Tagged_Type (Priv_T) + and then not Error_Posted (N) + then + -- RM 7.3 (7.2/2): The partial view shall be a synchronized tagged + -- type if and only if the full type is a synchronized tagged type + + if Is_Synchronized_Tagged_Type (Priv_T) + and then not Is_Synchronized_Tagged_Type (T) + then + Error_Msg_N + ("(Ada 2005) full view must be a synchronized tagged " & + "type (RM 7.3 (7.2/2))", Priv_T); + + elsif Is_Synchronized_Tagged_Type (T) + and then not Is_Synchronized_Tagged_Type (Priv_T) + then + Error_Msg_N + ("(Ada 2005) partial view must be a synchronized tagged " & + "type (RM 7.3 (7.2/2))", T); + end if; + + -- RM 7.3 (7.3/2): The partial view shall be a descendant of an + -- interface type if and only if the full type is descendant of + -- the interface type. + + if Present (Interface_List (N)) + or else (Is_Tagged_Type (Priv_T) + and then Has_Interfaces + (Priv_T, Use_Full_View => False)) + then + if Is_Tagged_Type (Priv_T) then + Collect_Interfaces + (Priv_T, Priv_T_Ifaces, Use_Full_View => False); + end if; + + if Is_Tagged_Type (T) then + Collect_Interfaces (T, Full_T_Ifaces); + end if; + + Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); + + if Present (Iface) then + Error_Msg_NE + ("interface & not implemented by full type " & + "(RM-2005 7.3 (7.3/2))", Priv_T, Iface); + end if; + + Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); + + if Present (Iface) then + Error_Msg_NE + ("interface & not implemented by partial " & + "view (RM-2005 7.3 (7.3/2))", T, Iface); + end if; + end if; + end if; + end; + end Check_Interfaces; + + -------------------------------- + -- Check_Triggering_Statement -- + -------------------------------- + + procedure Check_Triggering_Statement + (Trigger : Node_Id; + Error_Node : Node_Id; + Is_Dispatching : out Boolean) + is + Param : Node_Id; + + begin + Is_Dispatching := False; + + -- It is not possible to have a dispatching trigger if we are not in + -- Ada 2005 mode. + + if Ada_Version >= Ada_2005 + and then Nkind (Trigger) = N_Procedure_Call_Statement + and then Present (Parameter_Associations (Trigger)) + then + Param := First (Parameter_Associations (Trigger)); + + if Is_Controlling_Actual (Param) + and then Is_Interface (Etype (Param)) + then + if Is_Limited_Record (Etype (Param)) then + Is_Dispatching := True; + else + Error_Msg_N + ("dispatching operation of limited or synchronized " & + "interface required (RM 9.7.2(3))!", Error_Node); + end if; + end if; + end if; + end Check_Triggering_Statement; + + -------------------------- + -- Find_Concurrent_Spec -- + -------------------------- + + function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id is + Spec_Id : Entity_Id := Current_Entity_In_Scope (Body_Id); + + begin + -- The type may have been given by an incomplete type declaration. + -- Find full view now. + + if Present (Spec_Id) and then Ekind (Spec_Id) = E_Incomplete_Type then + Spec_Id := Full_View (Spec_Id); + end if; + + return Spec_Id; + end Find_Concurrent_Spec; + + -------------------------- + -- Install_Declarations -- + -------------------------- + + procedure Install_Declarations (Spec : Entity_Id) is + E : Entity_Id; + Prev : Entity_Id; + begin + E := First_Entity (Spec); + while Present (E) loop + Prev := Current_Entity (E); + Set_Current_Entity (E); + Set_Is_Immediately_Visible (E); + Set_Homonym (E, Prev); + Next_Entity (E); + end loop; + end Install_Declarations; + +end Sem_Ch9; diff --git a/gcc/ada/sem_ch9.ads b/gcc/ada/sem_ch9.ads new file mode 100644 index 000000000..34e921f69 --- /dev/null +++ b/gcc/ada/sem_ch9.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 9 -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Types; use Types; + +package Sem_Ch9 is + procedure Analyze_Abort_Statement (N : Node_Id); + procedure Analyze_Accept_Alternative (N : Node_Id); + procedure Analyze_Accept_Statement (N : Node_Id); + procedure Analyze_Asynchronous_Select (N : Node_Id); + procedure Analyze_Conditional_Entry_Call (N : Node_Id); + procedure Analyze_Delay_Alternative (N : Node_Id); + procedure Analyze_Delay_Relative (N : Node_Id); + procedure Analyze_Delay_Until (N : Node_Id); + procedure Analyze_Entry_Body (N : Node_Id); + procedure Analyze_Entry_Body_Formal_Part (N : Node_Id); + procedure Analyze_Entry_Call_Alternative (N : Node_Id); + procedure Analyze_Entry_Declaration (N : Node_Id); + procedure Analyze_Entry_Index_Specification (N : Node_Id); + procedure Analyze_Protected_Body (N : Node_Id); + procedure Analyze_Protected_Definition (N : Node_Id); + procedure Analyze_Protected_Type_Declaration (N : Node_Id); + procedure Analyze_Requeue (N : Node_Id); + procedure Analyze_Selective_Accept (N : Node_Id); + procedure Analyze_Single_Protected_Declaration (N : Node_Id); + procedure Analyze_Single_Task_Declaration (N : Node_Id); + procedure Analyze_Task_Body (N : Node_Id); + procedure Analyze_Task_Definition (N : Node_Id); + procedure Analyze_Task_Type_Declaration (N : Node_Id); + procedure Analyze_Terminate_Alternative (N : Node_Id); + procedure Analyze_Timed_Entry_Call (N : Node_Id); + procedure Analyze_Triggering_Alternative (N : Node_Id); +end Sem_Ch9; diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb new file mode 100644 index 000000000..818f9b855 --- /dev/null +++ b/gcc/ada/sem_disp.adb @@ -0,0 +1,2268 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ D I S P -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Debug; use Debug; +with Elists; use Elists; +with Einfo; use Einfo; +with Exp_Disp; use Exp_Disp; +with Exp_Util; use Exp_Util; +with Exp_Ch7; use Exp_Ch7; +with Exp_Tss; use Exp_Tss; +with Errout; use Errout; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Output; use Output; +with Restrict; use Restrict; +with Rident; use Rident; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch6; use Sem_Ch6; +with Sem_Eval; use Sem_Eval; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Snames; use Snames; +with Sinfo; use Sinfo; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +package body Sem_Disp is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Add_Dispatching_Operation + (Tagged_Type : Entity_Id; + New_Op : Entity_Id); + -- Add New_Op in the list of primitive operations of Tagged_Type + + function Check_Controlling_Type + (T : Entity_Id; + Subp : Entity_Id) return Entity_Id; + -- T is the tagged type of a formal parameter or the result of Subp. + -- If the subprogram has a controlling parameter or result that matches + -- the type, then returns the tagged type of that parameter or result + -- (returning the designated tagged type in the case of an access + -- parameter); otherwise returns empty. + + function Find_Hidden_Overridden_Primitive (S : Entity_Id) return Entity_Id; + -- [Ada 2012:AI-0125] Find an inherited hidden primitive of the dispatching + -- type of S that has the same name of S, a type-conformant profile, an + -- original corresponding operation O that is a primitive of a visible + -- ancestor of the dispatching type of S and O is visible at the point of + -- of declaration of S. If the entity is found the Alias of S is set to the + -- original corresponding operation S and its Overridden_Operation is set + -- to the found entity; otherwise return Empty. + -- + -- This routine does not search for non-hidden primitives since they are + -- covered by the normal Ada 2005 rules. + + ------------------------------- + -- Add_Dispatching_Operation -- + ------------------------------- + + procedure Add_Dispatching_Operation + (Tagged_Type : Entity_Id; + New_Op : Entity_Id) + is + List : constant Elist_Id := Primitive_Operations (Tagged_Type); + + begin + -- The dispatching operation may already be on the list, if it is the + -- wrapper for an inherited function of a null extension (see Exp_Ch3 + -- for the construction of function wrappers). The list of primitive + -- operations must not contain duplicates. + + Append_Unique_Elmt (New_Op, List); + end Add_Dispatching_Operation; + + --------------------------- + -- Covers_Some_Interface -- + --------------------------- + + function Covers_Some_Interface (Prim : Entity_Id) return Boolean is + Tagged_Type : constant Entity_Id := Find_Dispatching_Type (Prim); + Elmt : Elmt_Id; + E : Entity_Id; + + begin + pragma Assert (Is_Dispatching_Operation (Prim)); + + -- Although this is a dispatching primitive we must check if its + -- dispatching type is available because it may be the primitive + -- of a private type not defined as tagged in its partial view. + + if Present (Tagged_Type) and then Has_Interfaces (Tagged_Type) then + + -- If the tagged type is frozen then the internal entities associated + -- with interfaces are available in the list of primitives of the + -- tagged type and can be used to speed up this search. + + if Is_Frozen (Tagged_Type) then + Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); + while Present (Elmt) loop + E := Node (Elmt); + + if Present (Interface_Alias (E)) + and then Alias (E) = Prim + then + return True; + end if; + + Next_Elmt (Elmt); + end loop; + + -- Otherwise we must collect all the interface primitives and check + -- if the Prim will override some interface primitive. + + else + declare + Ifaces_List : Elist_Id; + Iface_Elmt : Elmt_Id; + Iface : Entity_Id; + Iface_Prim : Entity_Id; + + begin + Collect_Interfaces (Tagged_Type, Ifaces_List); + Iface_Elmt := First_Elmt (Ifaces_List); + while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); + + Elmt := First_Elmt (Primitive_Operations (Iface)); + while Present (Elmt) loop + Iface_Prim := Node (Elmt); + + if Chars (E) = Chars (Prim) + and then Is_Interface_Conformant + (Tagged_Type, Iface_Prim, Prim) + then + return True; + end if; + + Next_Elmt (Elmt); + end loop; + + Next_Elmt (Iface_Elmt); + end loop; + end; + end if; + end if; + + return False; + end Covers_Some_Interface; + + ------------------------------- + -- Check_Controlling_Formals -- + ------------------------------- + + procedure Check_Controlling_Formals + (Typ : Entity_Id; + Subp : Entity_Id) + is + Formal : Entity_Id; + Ctrl_Type : Entity_Id; + + begin + Formal := First_Formal (Subp); + while Present (Formal) loop + Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp); + + if Present (Ctrl_Type) then + + -- When controlling type is concurrent and declared within a + -- generic or inside an instance use corresponding record type. + + if Is_Concurrent_Type (Ctrl_Type) + and then Present (Corresponding_Record_Type (Ctrl_Type)) + then + Ctrl_Type := Corresponding_Record_Type (Ctrl_Type); + end if; + + if Ctrl_Type = Typ then + Set_Is_Controlling_Formal (Formal); + + -- Ada 2005 (AI-231): Anonymous access types that are used in + -- controlling parameters exclude null because it is necessary + -- to read the tag to dispatch, and null has no tag. + + if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then + Set_Can_Never_Be_Null (Etype (Formal)); + Set_Is_Known_Non_Null (Etype (Formal)); + end if; + + -- Check that the parameter's nominal subtype statically + -- matches the first subtype. + + if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then + if not Subtypes_Statically_Match + (Typ, Designated_Type (Etype (Formal))) + then + Error_Msg_N + ("parameter subtype does not match controlling type", + Formal); + end if; + + elsif not Subtypes_Statically_Match (Typ, Etype (Formal)) then + Error_Msg_N + ("parameter subtype does not match controlling type", + Formal); + end if; + + if Present (Default_Value (Formal)) then + + -- In Ada 2005, access parameters can have defaults + + if Ekind (Etype (Formal)) = E_Anonymous_Access_Type + and then Ada_Version < Ada_2005 + then + Error_Msg_N + ("default not allowed for controlling access parameter", + Default_Value (Formal)); + + elsif not Is_Tag_Indeterminate (Default_Value (Formal)) then + Error_Msg_N + ("default expression must be a tag indeterminate" & + " function call", Default_Value (Formal)); + end if; + end if; + + elsif Comes_From_Source (Subp) then + Error_Msg_N + ("operation can be dispatching in only one type", Subp); + end if; + end if; + + Next_Formal (Formal); + end loop; + + if Ekind_In (Subp, E_Function, E_Generic_Function) then + Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp); + + if Present (Ctrl_Type) then + if Ctrl_Type = Typ then + Set_Has_Controlling_Result (Subp); + + -- Check that result subtype statically matches first subtype + -- (Ada 2005): Subp may have a controlling access result. + + if Subtypes_Statically_Match (Typ, Etype (Subp)) + or else (Ekind (Etype (Subp)) = E_Anonymous_Access_Type + and then + Subtypes_Statically_Match + (Typ, Designated_Type (Etype (Subp)))) + then + null; + + else + Error_Msg_N + ("result subtype does not match controlling type", Subp); + end if; + + elsif Comes_From_Source (Subp) then + Error_Msg_N + ("operation can be dispatching in only one type", Subp); + end if; + end if; + end if; + end Check_Controlling_Formals; + + ---------------------------- + -- Check_Controlling_Type -- + ---------------------------- + + function Check_Controlling_Type + (T : Entity_Id; + Subp : Entity_Id) return Entity_Id + is + Tagged_Type : Entity_Id := Empty; + + begin + if Is_Tagged_Type (T) then + if Is_First_Subtype (T) then + Tagged_Type := T; + else + Tagged_Type := Base_Type (T); + end if; + + elsif Ekind (T) = E_Anonymous_Access_Type + and then Is_Tagged_Type (Designated_Type (T)) + then + if Ekind (Designated_Type (T)) /= E_Incomplete_Type then + if Is_First_Subtype (Designated_Type (T)) then + Tagged_Type := Designated_Type (T); + else + Tagged_Type := Base_Type (Designated_Type (T)); + end if; + + -- Ada 2005: an incomplete type can be tagged. An operation with an + -- access parameter of the type is dispatching. + + elsif Scope (Designated_Type (T)) = Current_Scope then + Tagged_Type := Designated_Type (T); + + -- Ada 2005 (AI-50217) + + elsif From_With_Type (Designated_Type (T)) + and then Present (Non_Limited_View (Designated_Type (T))) + then + if Is_First_Subtype (Non_Limited_View (Designated_Type (T))) then + Tagged_Type := Non_Limited_View (Designated_Type (T)); + else + Tagged_Type := Base_Type (Non_Limited_View + (Designated_Type (T))); + end if; + end if; + end if; + + if No (Tagged_Type) or else Is_Class_Wide_Type (Tagged_Type) then + return Empty; + + -- The dispatching type and the primitive operation must be defined in + -- the same scope, except in the case of internal operations and formal + -- abstract subprograms. + + elsif ((Scope (Subp) = Scope (Tagged_Type) or else Is_Internal (Subp)) + and then (not Is_Generic_Type (Tagged_Type) + or else not Comes_From_Source (Subp))) + or else + (Is_Formal_Subprogram (Subp) and then Is_Abstract_Subprogram (Subp)) + or else + (Nkind (Parent (Parent (Subp))) = N_Subprogram_Renaming_Declaration + and then + Present (Corresponding_Formal_Spec (Parent (Parent (Subp)))) + and then + Is_Abstract_Subprogram (Subp)) + then + return Tagged_Type; + + else + return Empty; + end if; + end Check_Controlling_Type; + + ---------------------------- + -- Check_Dispatching_Call -- + ---------------------------- + + procedure Check_Dispatching_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Actual : Node_Id; + Formal : Entity_Id; + Control : Node_Id := Empty; + Func : Entity_Id; + Subp_Entity : Entity_Id; + Indeterm_Ancestor_Call : Boolean := False; + Indeterm_Ctrl_Type : Entity_Id; + + Static_Tag : Node_Id := Empty; + -- If a controlling formal has a statically tagged actual, the tag of + -- this actual is to be used for any tag-indeterminate actual. + + procedure Check_Direct_Call; + -- In the case when the controlling actual is a class-wide type whose + -- root type's completion is a task or protected type, the call is in + -- fact direct. This routine detects the above case and modifies the + -- call accordingly. + + procedure Check_Dispatching_Context; + -- If the call is tag-indeterminate and the entity being called is + -- abstract, verify that the context is a call that will eventually + -- provide a tag for dispatching, or has provided one already. + + ----------------------- + -- Check_Direct_Call -- + ----------------------- + + procedure Check_Direct_Call is + Typ : Entity_Id := Etype (Control); + + function Is_User_Defined_Equality (Id : Entity_Id) return Boolean; + -- Determine whether an entity denotes a user-defined equality + + ------------------------------ + -- Is_User_Defined_Equality -- + ------------------------------ + + function Is_User_Defined_Equality (Id : Entity_Id) return Boolean is + begin + return + Ekind (Id) = E_Function + and then Chars (Id) = Name_Op_Eq + and then Comes_From_Source (Id) + + -- Internally generated equalities have a full type declaration + -- as their parent. + + and then Nkind (Parent (Id)) = N_Function_Specification; + end Is_User_Defined_Equality; + + -- Start of processing for Check_Direct_Call + + begin + -- Predefined primitives do not receive wrappers since they are built + -- from scratch for the corresponding record of synchronized types. + -- Equality is in general predefined, but is excluded from the check + -- when it is user-defined. + + if Is_Predefined_Dispatching_Operation (Subp_Entity) + and then not Is_User_Defined_Equality (Subp_Entity) + then + return; + end if; + + if Is_Class_Wide_Type (Typ) then + Typ := Root_Type (Typ); + end if; + + if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then + Typ := Full_View (Typ); + end if; + + if Is_Concurrent_Type (Typ) + and then + Present (Corresponding_Record_Type (Typ)) + then + Typ := Corresponding_Record_Type (Typ); + + -- The concurrent record's list of primitives should contain a + -- wrapper for the entity of the call, retrieve it. + + declare + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + Wrapper_Found : Boolean := False; + + begin + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if Is_Primitive_Wrapper (Prim) + and then Wrapped_Entity (Prim) = Subp_Entity + then + Wrapper_Found := True; + exit; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + -- A primitive declared between two views should have a + -- corresponding wrapper. + + pragma Assert (Wrapper_Found); + + -- Modify the call by setting the proper entity + + Set_Entity (Name (N), Prim); + end; + end if; + end Check_Direct_Call; + + ------------------------------- + -- Check_Dispatching_Context -- + ------------------------------- + + procedure Check_Dispatching_Context is + Subp : constant Entity_Id := Entity (Name (N)); + Par : Node_Id; + + begin + if Is_Abstract_Subprogram (Subp) + and then No (Controlling_Argument (N)) + then + if Present (Alias (Subp)) + and then not Is_Abstract_Subprogram (Alias (Subp)) + and then No (DTC_Entity (Subp)) + then + -- Private overriding of inherited abstract operation, call is + -- legal. + + Set_Entity (Name (N), Alias (Subp)); + return; + + else + Par := Parent (N); + while Present (Par) loop + if Nkind_In (Par, N_Function_Call, + N_Procedure_Call_Statement, + N_Assignment_Statement, + N_Op_Eq, + N_Op_Ne) + and then Is_Tagged_Type (Etype (Subp)) + then + return; + + elsif Nkind (Par) = N_Qualified_Expression + or else Nkind (Par) = N_Unchecked_Type_Conversion + then + Par := Parent (Par); + + else + if Ekind (Subp) = E_Function then + Error_Msg_N + ("call to abstract function must be dispatching", N); + + -- This error can occur for a procedure in the case of a + -- call to an abstract formal procedure with a statically + -- tagged operand. + + else + Error_Msg_N + ("call to abstract procedure must be dispatching", + N); + end if; + + return; + end if; + end loop; + end if; + end if; + end Check_Dispatching_Context; + + -- Start of processing for Check_Dispatching_Call + + begin + -- Find a controlling argument, if any + + if Present (Parameter_Associations (N)) then + Subp_Entity := Entity (Name (N)); + + Actual := First_Actual (N); + Formal := First_Formal (Subp_Entity); + while Present (Actual) loop + Control := Find_Controlling_Arg (Actual); + exit when Present (Control); + + -- Check for the case where the actual is a tag-indeterminate call + -- whose result type is different than the tagged type associated + -- with the containing call, but is an ancestor of the type. + + if Is_Controlling_Formal (Formal) + and then Is_Tag_Indeterminate (Actual) + and then Base_Type (Etype (Actual)) /= Base_Type (Etype (Formal)) + and then Is_Ancestor (Etype (Actual), Etype (Formal)) + then + Indeterm_Ancestor_Call := True; + Indeterm_Ctrl_Type := Etype (Formal); + + -- If the formal is controlling but the actual is not, the type + -- of the actual is statically known, and may be used as the + -- controlling tag for some other tag-indeterminate actual. + + elsif Is_Controlling_Formal (Formal) + and then Is_Entity_Name (Actual) + and then Is_Tagged_Type (Etype (Actual)) + then + Static_Tag := Actual; + end if; + + Next_Actual (Actual); + Next_Formal (Formal); + end loop; + + -- If the call doesn't have a controlling actual but does have an + -- indeterminate actual that requires dispatching treatment, then an + -- object is needed that will serve as the controlling argument for a + -- dispatching call on the indeterminate actual. This can only occur + -- in the unusual situation of a default actual given by a + -- tag-indeterminate call and where the type of the call is an + -- ancestor of the type associated with a containing call to an + -- inherited operation (see AI-239). + + -- Rather than create an object of the tagged type, which would be + -- problematic for various reasons (default initialization, + -- discriminants), the tag of the containing call's associated tagged + -- type is directly used to control the dispatching. + + if No (Control) + and then Indeterm_Ancestor_Call + and then No (Static_Tag) + then + Control := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Indeterm_Ctrl_Type, Loc), + Attribute_Name => Name_Tag); + + Analyze (Control); + end if; + + if Present (Control) then + + -- Verify that no controlling arguments are statically tagged + + if Debug_Flag_E then + Write_Str ("Found Dispatching call"); + Write_Int (Int (N)); + Write_Eol; + end if; + + Actual := First_Actual (N); + while Present (Actual) loop + if Actual /= Control then + + if not Is_Controlling_Actual (Actual) then + null; -- Can be anything + + elsif Is_Dynamically_Tagged (Actual) then + null; -- Valid parameter + + elsif Is_Tag_Indeterminate (Actual) then + + -- The tag is inherited from the enclosing call (the node + -- we are currently analyzing). Explicitly expand the + -- actual, since the previous call to Expand (from + -- Resolve_Call) had no way of knowing about the required + -- dispatching. + + Propagate_Tag (Control, Actual); + + else + Error_Msg_N + ("controlling argument is not dynamically tagged", + Actual); + return; + end if; + end if; + + Next_Actual (Actual); + end loop; + + -- Mark call as a dispatching call + + Set_Controlling_Argument (N, Control); + Check_Restriction (No_Dispatching_Calls, N); + + -- The dispatching call may need to be converted into a direct + -- call in certain cases. + + Check_Direct_Call; + + -- If there is a statically tagged actual and a tag-indeterminate + -- call to a function of the ancestor (such as that provided by a + -- default), then treat this as a dispatching call and propagate + -- the tag to the tag-indeterminate call(s). + + elsif Present (Static_Tag) and then Indeterm_Ancestor_Call then + Control := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Etype (Static_Tag), Loc), + Attribute_Name => Name_Tag); + + Analyze (Control); + + Actual := First_Actual (N); + Formal := First_Formal (Subp_Entity); + while Present (Actual) loop + if Is_Tag_Indeterminate (Actual) + and then Is_Controlling_Formal (Formal) + then + Propagate_Tag (Control, Actual); + end if; + + Next_Actual (Actual); + Next_Formal (Formal); + end loop; + + Check_Dispatching_Context; + + else + -- The call is not dispatching, so check that there aren't any + -- tag-indeterminate abstract calls left. + + Actual := First_Actual (N); + while Present (Actual) loop + if Is_Tag_Indeterminate (Actual) then + + -- Function call case + + if Nkind (Original_Node (Actual)) = N_Function_Call then + Func := Entity (Name (Original_Node (Actual))); + + -- If the actual is an attribute then it can't be abstract + -- (the only current case of a tag-indeterminate attribute + -- is the stream Input attribute). + + elsif + Nkind (Original_Node (Actual)) = N_Attribute_Reference + then + Func := Empty; + + -- Only other possibility is a qualified expression whose + -- constituent expression is itself a call. + + else + Func := + Entity (Name + (Original_Node + (Expression (Original_Node (Actual))))); + end if; + + if Present (Func) and then Is_Abstract_Subprogram (Func) then + Error_Msg_N + ("call to abstract function must be dispatching", N); + end if; + end if; + + Next_Actual (Actual); + end loop; + + Check_Dispatching_Context; + end if; + + else + -- If dispatching on result, the enclosing call, if any, will + -- determine the controlling argument. Otherwise this is the + -- primitive operation of the root type. + + Check_Dispatching_Context; + end if; + end Check_Dispatching_Call; + + --------------------------------- + -- Check_Dispatching_Operation -- + --------------------------------- + + procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is + Tagged_Type : Entity_Id; + Has_Dispatching_Parent : Boolean := False; + Body_Is_Last_Primitive : Boolean := False; + Ovr_Subp : Entity_Id := Empty; + + begin + if not Ekind_In (Subp, E_Procedure, E_Function) then + return; + end if; + + Set_Is_Dispatching_Operation (Subp, False); + Tagged_Type := Find_Dispatching_Type (Subp); + + -- Ada 2005 (AI-345): Use the corresponding record (if available). + -- Required because primitives of concurrent types are be attached + -- to the corresponding record (not to the concurrent type). + + if Ada_Version >= Ada_2005 + and then Present (Tagged_Type) + and then Is_Concurrent_Type (Tagged_Type) + and then Present (Corresponding_Record_Type (Tagged_Type)) + then + Tagged_Type := Corresponding_Record_Type (Tagged_Type); + end if; + + -- (AI-345): The task body procedure is not a primitive of the tagged + -- type + + if Present (Tagged_Type) + and then Is_Concurrent_Record_Type (Tagged_Type) + and then Present (Corresponding_Concurrent_Type (Tagged_Type)) + and then Is_Task_Type (Corresponding_Concurrent_Type (Tagged_Type)) + and then Subp = Get_Task_Body_Procedure + (Corresponding_Concurrent_Type (Tagged_Type)) + then + return; + end if; + + -- If Subp is derived from a dispatching operation then it should + -- always be treated as dispatching. In this case various checks + -- below will be bypassed. Makes sure that late declarations for + -- inherited private subprograms are treated as dispatching, even + -- if the associated tagged type is already frozen. + + Has_Dispatching_Parent := + Present (Alias (Subp)) + and then Is_Dispatching_Operation (Alias (Subp)); + + if No (Tagged_Type) then + + -- Ada 2005 (AI-251): Check that Subp is not a primitive associated + -- with an abstract interface type unless the interface acts as a + -- parent type in a derivation. If the interface type is a formal + -- type then the operation is not primitive and therefore legal. + + declare + E : Entity_Id; + Typ : Entity_Id; + + begin + E := First_Entity (Subp); + while Present (E) loop + + -- For an access parameter, check designated type + + if Ekind (Etype (E)) = E_Anonymous_Access_Type then + Typ := Designated_Type (Etype (E)); + else + Typ := Etype (E); + end if; + + if Comes_From_Source (Subp) + and then Is_Interface (Typ) + and then not Is_Class_Wide_Type (Typ) + and then not Is_Derived_Type (Typ) + and then not Is_Generic_Type (Typ) + and then not In_Instance + then + Error_Msg_N ("?declaration of& is too late!", Subp); + Error_Msg_NE -- CODEFIX?? + ("\spec should appear immediately after declaration of &!", + Subp, Typ); + exit; + end if; + + Next_Entity (E); + end loop; + + -- In case of functions check also the result type + + if Ekind (Subp) = E_Function then + if Is_Access_Type (Etype (Subp)) then + Typ := Designated_Type (Etype (Subp)); + else + Typ := Etype (Subp); + end if; + + if not Is_Class_Wide_Type (Typ) + and then Is_Interface (Typ) + and then not Is_Derived_Type (Typ) + then + Error_Msg_N ("?declaration of& is too late!", Subp); + Error_Msg_NE + ("\spec should appear immediately after declaration of &!", + Subp, Typ); + end if; + end if; + end; + + return; + + -- The subprograms build internally after the freezing point (such as + -- init procs, interface thunks, type support subprograms, and Offset + -- to top functions for accessing interface components in variable + -- size tagged types) are not primitives. + + elsif Is_Frozen (Tagged_Type) + and then not Comes_From_Source (Subp) + and then not Has_Dispatching_Parent + then + -- Complete decoration of internally built subprograms that override + -- a dispatching primitive. These entities correspond with the + -- following cases: + + -- 1. Ada 2005 (AI-391): Wrapper functions built by the expander + -- to override functions of nonabstract null extensions. These + -- primitives were added to the list of primitives of the tagged + -- type by Make_Controlling_Function_Wrappers. However, attribute + -- Is_Dispatching_Operation must be set to true. + + -- 2. Ada 2005 (AI-251): Wrapper procedures of null interface + -- primitives. + + -- 3. Subprograms associated with stream attributes (built by + -- New_Stream_Subprogram) + + if Present (Old_Subp) + and then Present (Overridden_Operation (Subp)) + and then Is_Dispatching_Operation (Old_Subp) + then + pragma Assert + ((Ekind (Subp) = E_Function + and then Is_Dispatching_Operation (Old_Subp) + and then Is_Null_Extension (Base_Type (Etype (Subp)))) + or else + (Ekind (Subp) = E_Procedure + and then Is_Dispatching_Operation (Old_Subp) + and then Present (Alias (Old_Subp)) + and then Is_Null_Interface_Primitive + (Ultimate_Alias (Old_Subp))) + or else Get_TSS_Name (Subp) = TSS_Stream_Read + or else Get_TSS_Name (Subp) = TSS_Stream_Write); + + Check_Controlling_Formals (Tagged_Type, Subp); + Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp); + Set_Is_Dispatching_Operation (Subp); + end if; + + return; + + -- The operation may be a child unit, whose scope is the defining + -- package, but which is not a primitive operation of the type. + + elsif Is_Child_Unit (Subp) then + return; + + -- If the subprogram is not defined in a package spec, the only case + -- where it can be a dispatching op is when it overrides an operation + -- before the freezing point of the type. + + elsif ((not Is_Package_Or_Generic_Package (Scope (Subp))) + or else In_Package_Body (Scope (Subp))) + and then not Has_Dispatching_Parent + then + if not Comes_From_Source (Subp) + or else (Present (Old_Subp) and then not Is_Frozen (Tagged_Type)) + then + null; + + -- If the type is already frozen, the overriding is not allowed + -- except when Old_Subp is not a dispatching operation (which can + -- occur when Old_Subp was inherited by an untagged type). However, + -- a body with no previous spec freezes the type *after* its + -- declaration, and therefore is a legal overriding (unless the type + -- has already been frozen). Only the first such body is legal. + + elsif Present (Old_Subp) + and then Is_Dispatching_Operation (Old_Subp) + then + if Comes_From_Source (Subp) + and then + (Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Body + or else Nkind (Unit_Declaration_Node (Subp)) in N_Body_Stub) + then + declare + Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp); + Decl_Item : Node_Id; + + begin + -- ??? The checks here for whether the type has been + -- frozen prior to the new body are not complete. It's + -- not simple to check frozenness at this point since + -- the body has already caused the type to be prematurely + -- frozen in Analyze_Declarations, but we're forced to + -- recheck this here because of the odd rule interpretation + -- that allows the overriding if the type wasn't frozen + -- prior to the body. The freezing action should probably + -- be delayed until after the spec is seen, but that's + -- a tricky change to the delicate freezing code. + + -- Look at each declaration following the type up until the + -- new subprogram body. If any of the declarations is a body + -- then the type has been frozen already so the overriding + -- primitive is illegal. + + Decl_Item := Next (Parent (Tagged_Type)); + while Present (Decl_Item) + and then (Decl_Item /= Subp_Body) + loop + if Comes_From_Source (Decl_Item) + and then (Nkind (Decl_Item) in N_Proper_Body + or else Nkind (Decl_Item) in N_Body_Stub) + then + Error_Msg_N ("overriding of& is too late!", Subp); + Error_Msg_N + ("\spec should appear immediately after the type!", + Subp); + exit; + end if; + + Next (Decl_Item); + end loop; + + -- If the subprogram doesn't follow in the list of + -- declarations including the type then the type has + -- definitely been frozen already and the body is illegal. + + if No (Decl_Item) then + Error_Msg_N ("overriding of& is too late!", Subp); + Error_Msg_N + ("\spec should appear immediately after the type!", + Subp); + + elsif Is_Frozen (Subp) then + + -- The subprogram body declares a primitive operation. + -- if the subprogram is already frozen, we must update + -- its dispatching information explicitly here. The + -- information is taken from the overridden subprogram. + -- We must also generate a cross-reference entry because + -- references to other primitives were already created + -- when type was frozen. + + Body_Is_Last_Primitive := True; + + if Present (DTC_Entity (Old_Subp)) then + Set_DTC_Entity (Subp, DTC_Entity (Old_Subp)); + Set_DT_Position (Subp, DT_Position (Old_Subp)); + + if not Restriction_Active (No_Dispatching_Calls) then + if Building_Static_DT (Tagged_Type) then + + -- If the static dispatch table has not been + -- built then there is nothing else to do now; + -- otherwise we notify that we cannot build the + -- static dispatch table. + + if Has_Dispatch_Table (Tagged_Type) then + Error_Msg_N + ("overriding of& is too late for building" & + " static dispatch tables!", Subp); + Error_Msg_N + ("\spec should appear immediately after" & + " the type!", Subp); + end if; + + else + Insert_Actions_After (Subp_Body, + Register_Primitive (Sloc (Subp_Body), + Prim => Subp)); + end if; + + -- Indicate that this is an overriding operation, + -- and replace the overridden entry in the list of + -- primitive operations, which is used for xref + -- generation subsequently. + + Generate_Reference (Tagged_Type, Subp, 'P', False); + Override_Dispatching_Operation + (Tagged_Type, Old_Subp, Subp); + end if; + end if; + end if; + end; + + else + Error_Msg_N ("overriding of& is too late!", Subp); + Error_Msg_N + ("\subprogram spec should appear immediately after the type!", + Subp); + end if; + + -- If the type is not frozen yet and we are not in the overriding + -- case it looks suspiciously like an attempt to define a primitive + -- operation, which requires the declaration to be in a package spec + -- (3.2.3(6)). Only report cases where the type and subprogram are + -- in the same declaration list (by checking the enclosing parent + -- declarations), to avoid spurious warnings on subprograms in + -- instance bodies when the type is declared in the instance spec but + -- hasn't been frozen by the instance body. + + elsif not Is_Frozen (Tagged_Type) + and then In_Same_List (Parent (Tagged_Type), Parent (Parent (Subp))) + then + Error_Msg_N + ("?not dispatching (must be defined in a package spec)", Subp); + return; + + -- When the type is frozen, it is legitimate to define a new + -- non-primitive operation. + + else + return; + end if; + + -- Now, we are sure that the scope is a package spec. If the subprogram + -- is declared after the freezing point of the type that's an error + + elsif Is_Frozen (Tagged_Type) and then not Has_Dispatching_Parent then + Error_Msg_N ("this primitive operation is declared too late", Subp); + Error_Msg_NE + ("?no primitive operations for& after this line", + Freeze_Node (Tagged_Type), + Tagged_Type); + return; + end if; + + Check_Controlling_Formals (Tagged_Type, Subp); + + Ovr_Subp := Old_Subp; + + -- [Ada 2012:AI-0125]: Search for inherited hidden primitive that may be + -- overridden by Subp + + if No (Ovr_Subp) + and then Ada_Version >= Ada_2012 + then + Ovr_Subp := Find_Hidden_Overridden_Primitive (Subp); + end if; + + -- Now it should be a correct primitive operation, put it in the list + + if Present (Ovr_Subp) then + + -- If the type has interfaces we complete this check after we set + -- attribute Is_Dispatching_Operation. + + Check_Subtype_Conformant (Subp, Ovr_Subp); + + if (Chars (Subp) = Name_Initialize + or else Chars (Subp) = Name_Adjust + or else Chars (Subp) = Name_Finalize) + and then Is_Controlled (Tagged_Type) + and then not Is_Visibly_Controlled (Tagged_Type) + then + Set_Overridden_Operation (Subp, Empty); + + -- If the subprogram specification carries an overriding + -- indicator, no need for the warning: it is either redundant, + -- or else an error will be reported. + + if Nkind (Parent (Subp)) = N_Procedure_Specification + and then + (Must_Override (Parent (Subp)) + or else Must_Not_Override (Parent (Subp))) + then + null; + + -- Here we need the warning + + else + Error_Msg_NE + ("operation does not override inherited&?", Subp, Subp); + end if; + + else + Override_Dispatching_Operation (Tagged_Type, Ovr_Subp, Subp); + + -- Ada 2005 (AI-251): In case of late overriding of a primitive + -- that covers abstract interface subprograms we must register it + -- in all the secondary dispatch tables associated with abstract + -- interfaces. We do this now only if not building static tables. + -- Otherwise the patch code is emitted after those tables are + -- built, to prevent access_before_elaboration in gigi. + + if Body_Is_Last_Primitive then + declare + Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp); + Elmt : Elmt_Id; + Prim : Node_Id; + + begin + Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); + while Present (Elmt) loop + Prim := Node (Elmt); + + if Present (Alias (Prim)) + and then Present (Interface_Alias (Prim)) + and then Alias (Prim) = Subp + and then not Building_Static_DT (Tagged_Type) + then + Insert_Actions_After (Subp_Body, + Register_Primitive (Sloc (Subp_Body), Prim => Prim)); + end if; + + Next_Elmt (Elmt); + end loop; + + -- Redisplay the contents of the updated dispatch table + + if Debug_Flag_ZZ then + Write_Str ("Late overriding: "); + Write_DT (Tagged_Type); + end if; + end; + end if; + end if; + + -- If the tagged type is a concurrent type then we must be compiling + -- with no code generation (we are either compiling a generic unit or + -- compiling under -gnatc mode) because we have previously tested that + -- no serious errors has been reported. In this case we do not add the + -- primitive to the list of primitives of Tagged_Type but we leave the + -- primitive decorated as a dispatching operation to be able to analyze + -- and report errors associated with the Object.Operation notation. + + elsif Is_Concurrent_Type (Tagged_Type) then + pragma Assert (not Expander_Active); + null; + + -- If no old subprogram, then we add this as a dispatching operation, + -- but we avoid doing this if an error was posted, to prevent annoying + -- cascaded errors. + + elsif not Error_Posted (Subp) then + Add_Dispatching_Operation (Tagged_Type, Subp); + end if; + + Set_Is_Dispatching_Operation (Subp, True); + + -- Ada 2005 (AI-251): If the type implements interfaces we must check + -- subtype conformance against all the interfaces covered by this + -- primitive. + + if Present (Ovr_Subp) + and then Has_Interfaces (Tagged_Type) + then + declare + Ifaces_List : Elist_Id; + Iface_Elmt : Elmt_Id; + Iface_Prim_Elmt : Elmt_Id; + Iface_Prim : Entity_Id; + Ret_Typ : Entity_Id; + + begin + Collect_Interfaces (Tagged_Type, Ifaces_List); + + Iface_Elmt := First_Elmt (Ifaces_List); + while Present (Iface_Elmt) loop + if not Is_Ancestor (Node (Iface_Elmt), Tagged_Type) then + Iface_Prim_Elmt := + First_Elmt (Primitive_Operations (Node (Iface_Elmt))); + while Present (Iface_Prim_Elmt) loop + Iface_Prim := Node (Iface_Prim_Elmt); + + if Is_Interface_Conformant + (Tagged_Type, Iface_Prim, Subp) + then + -- Handle procedures, functions whose return type + -- matches, or functions not returning interfaces + + if Ekind (Subp) = E_Procedure + or else Etype (Iface_Prim) = Etype (Subp) + or else not Is_Interface (Etype (Iface_Prim)) + then + Check_Subtype_Conformant + (New_Id => Subp, + Old_Id => Iface_Prim, + Err_Loc => Subp, + Skip_Controlling_Formals => True); + + -- Handle functions returning interfaces + + elsif Implements_Interface + (Etype (Subp), Etype (Iface_Prim)) + then + -- Temporarily force both entities to return the + -- same type. Required because Subtype_Conformant + -- does not handle this case. + + Ret_Typ := Etype (Iface_Prim); + Set_Etype (Iface_Prim, Etype (Subp)); + + Check_Subtype_Conformant + (New_Id => Subp, + Old_Id => Iface_Prim, + Err_Loc => Subp, + Skip_Controlling_Formals => True); + + Set_Etype (Iface_Prim, Ret_Typ); + end if; + end if; + + Next_Elmt (Iface_Prim_Elmt); + end loop; + end if; + + Next_Elmt (Iface_Elmt); + end loop; + end; + end if; + + if not Body_Is_Last_Primitive then + Set_DT_Position (Subp, No_Uint); + + elsif Has_Controlled_Component (Tagged_Type) + and then + (Chars (Subp) = Name_Initialize + or else + Chars (Subp) = Name_Adjust + or else + Chars (Subp) = Name_Finalize) + then + declare + F_Node : constant Node_Id := Freeze_Node (Tagged_Type); + Decl : Node_Id; + Old_P : Entity_Id; + Old_Bod : Node_Id; + Old_Spec : Entity_Id; + + C_Names : constant array (1 .. 3) of Name_Id := + (Name_Initialize, + Name_Adjust, + Name_Finalize); + + D_Names : constant array (1 .. 3) of TSS_Name_Type := + (TSS_Deep_Initialize, + TSS_Deep_Adjust, + TSS_Deep_Finalize); + + begin + -- Remove previous controlled function which was constructed and + -- analyzed when the type was frozen. This requires removing the + -- body of the redefined primitive, as well as its specification + -- if needed (there is no spec created for Deep_Initialize, see + -- exp_ch3.adb). We must also dismantle the exception information + -- that may have been generated for it when front end zero-cost + -- tables are enabled. + + for J in D_Names'Range loop + Old_P := TSS (Tagged_Type, D_Names (J)); + + if Present (Old_P) + and then Chars (Subp) = C_Names (J) + then + Old_Bod := Unit_Declaration_Node (Old_P); + Remove (Old_Bod); + Set_Is_Eliminated (Old_P); + Set_Scope (Old_P, Scope (Current_Scope)); + + if Nkind (Old_Bod) = N_Subprogram_Body + and then Present (Corresponding_Spec (Old_Bod)) + then + Old_Spec := Corresponding_Spec (Old_Bod); + Set_Has_Completion (Old_Spec, False); + end if; + end if; + end loop; + + Build_Late_Proc (Tagged_Type, Chars (Subp)); + + -- The new operation is added to the actions of the freeze node + -- for the type, but this node has already been analyzed, so we + -- must retrieve and analyze explicitly the new body. + + if Present (F_Node) + and then Present (Actions (F_Node)) + then + Decl := Last (Actions (F_Node)); + Analyze (Decl); + end if; + end; + end if; + end Check_Dispatching_Operation; + + ------------------------------------------ + -- Check_Operation_From_Incomplete_Type -- + ------------------------------------------ + + procedure Check_Operation_From_Incomplete_Type + (Subp : Entity_Id; + Typ : Entity_Id) + is + Full : constant Entity_Id := Full_View (Typ); + Parent_Typ : constant Entity_Id := Etype (Full); + Old_Prim : constant Elist_Id := Primitive_Operations (Parent_Typ); + New_Prim : constant Elist_Id := Primitive_Operations (Full); + Op1, Op2 : Elmt_Id; + Prev : Elmt_Id := No_Elmt; + + function Derives_From (Proc : Entity_Id) return Boolean; + -- Check that Subp has the signature of an operation derived from Proc. + -- Subp has an access parameter that designates Typ. + + ------------------ + -- Derives_From -- + ------------------ + + function Derives_From (Proc : Entity_Id) return Boolean is + F1, F2 : Entity_Id; + + begin + if Chars (Proc) /= Chars (Subp) then + return False; + end if; + + F1 := First_Formal (Proc); + F2 := First_Formal (Subp); + while Present (F1) and then Present (F2) loop + if Ekind (Etype (F1)) = E_Anonymous_Access_Type then + if Ekind (Etype (F2)) /= E_Anonymous_Access_Type then + return False; + elsif Designated_Type (Etype (F1)) = Parent_Typ + and then Designated_Type (Etype (F2)) /= Full + then + return False; + end if; + + elsif Ekind (Etype (F2)) = E_Anonymous_Access_Type then + return False; + + elsif Etype (F1) /= Etype (F2) then + return False; + end if; + + Next_Formal (F1); + Next_Formal (F2); + end loop; + + return No (F1) and then No (F2); + end Derives_From; + + -- Start of processing for Check_Operation_From_Incomplete_Type + + begin + -- The operation may override an inherited one, or may be a new one + -- altogether. The inherited operation will have been hidden by the + -- current one at the point of the type derivation, so it does not + -- appear in the list of primitive operations of the type. We have to + -- find the proper place of insertion in the list of primitive opera- + -- tions by iterating over the list for the parent type. + + Op1 := First_Elmt (Old_Prim); + Op2 := First_Elmt (New_Prim); + while Present (Op1) and then Present (Op2) loop + if Derives_From (Node (Op1)) then + if No (Prev) then + + -- Avoid adding it to the list of primitives if already there! + + if Node (Op2) /= Subp then + Prepend_Elmt (Subp, New_Prim); + end if; + + else + Insert_Elmt_After (Subp, Prev); + end if; + + return; + end if; + + Prev := Op2; + Next_Elmt (Op1); + Next_Elmt (Op2); + end loop; + + -- Operation is a new primitive + + Append_Elmt (Subp, New_Prim); + end Check_Operation_From_Incomplete_Type; + + --------------------------------------- + -- Check_Operation_From_Private_View -- + --------------------------------------- + + procedure Check_Operation_From_Private_View (Subp, Old_Subp : Entity_Id) is + Tagged_Type : Entity_Id; + + begin + if Is_Dispatching_Operation (Alias (Subp)) then + Set_Scope (Subp, Current_Scope); + Tagged_Type := Find_Dispatching_Type (Subp); + + -- Add Old_Subp to primitive operations if not already present + + if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then + Append_Unique_Elmt (Old_Subp, Primitive_Operations (Tagged_Type)); + + -- If Old_Subp isn't already marked as dispatching then + -- this is the case of an operation of an untagged private + -- type fulfilled by a tagged type that overrides an + -- inherited dispatching operation, so we set the necessary + -- dispatching attributes here. + + if not Is_Dispatching_Operation (Old_Subp) then + + -- If the untagged type has no discriminants, and the full + -- view is constrained, there will be a spurious mismatch + -- of subtypes on the controlling arguments, because the tagged + -- type is the internal base type introduced in the derivation. + -- Use the original type to verify conformance, rather than the + -- base type. + + if not Comes_From_Source (Tagged_Type) + and then Has_Discriminants (Tagged_Type) + then + declare + Formal : Entity_Id; + + begin + Formal := First_Formal (Old_Subp); + while Present (Formal) loop + if Tagged_Type = Base_Type (Etype (Formal)) then + Tagged_Type := Etype (Formal); + end if; + + Next_Formal (Formal); + end loop; + end; + + if Tagged_Type = Base_Type (Etype (Old_Subp)) then + Tagged_Type := Etype (Old_Subp); + end if; + end if; + + Check_Controlling_Formals (Tagged_Type, Old_Subp); + Set_Is_Dispatching_Operation (Old_Subp, True); + Set_DT_Position (Old_Subp, No_Uint); + end if; + + -- If the old subprogram is an explicit renaming of some other + -- entity, it is not overridden by the inherited subprogram. + -- Otherwise, update its alias and other attributes. + + if Present (Alias (Old_Subp)) + and then Nkind (Unit_Declaration_Node (Old_Subp)) /= + N_Subprogram_Renaming_Declaration + then + Set_Alias (Old_Subp, Alias (Subp)); + + -- The derived subprogram should inherit the abstractness + -- of the parent subprogram (except in the case of a function + -- returning the type). This sets the abstractness properly + -- for cases where a private extension may have inherited + -- an abstract operation, but the full type is derived from + -- a descendant type and inherits a nonabstract version. + + if Etype (Subp) /= Tagged_Type then + Set_Is_Abstract_Subprogram + (Old_Subp, Is_Abstract_Subprogram (Alias (Subp))); + end if; + end if; + end if; + end if; + end Check_Operation_From_Private_View; + + -------------------------- + -- Find_Controlling_Arg -- + -------------------------- + + function Find_Controlling_Arg (N : Node_Id) return Node_Id is + Orig_Node : constant Node_Id := Original_Node (N); + Typ : Entity_Id; + + begin + if Nkind (Orig_Node) = N_Qualified_Expression then + return Find_Controlling_Arg (Expression (Orig_Node)); + end if; + + -- Dispatching on result case. If expansion is disabled, the node still + -- has the structure of a function call. However, if the function name + -- is an operator and the call was given in infix form, the original + -- node has no controlling result and we must examine the current node. + + if Nkind (N) = N_Function_Call + and then Present (Controlling_Argument (N)) + and then Has_Controlling_Result (Entity (Name (N))) + then + return Controlling_Argument (N); + + -- If expansion is enabled, the call may have been transformed into + -- an indirect call, and we need to recover the original node. + + elsif Nkind (Orig_Node) = N_Function_Call + and then Present (Controlling_Argument (Orig_Node)) + and then Has_Controlling_Result (Entity (Name (Orig_Node))) + then + return Controlling_Argument (Orig_Node); + + -- Normal case + + elsif Is_Controlling_Actual (N) + or else + (Nkind (Parent (N)) = N_Qualified_Expression + and then Is_Controlling_Actual (Parent (N))) + then + Typ := Etype (N); + + if Is_Access_Type (Typ) then + + -- In the case of an Access attribute, use the type of the prefix, + -- since in the case of an actual for an access parameter, the + -- attribute's type may be of a specific designated type, even + -- though the prefix type is class-wide. + + if Nkind (N) = N_Attribute_Reference then + Typ := Etype (Prefix (N)); + + -- An allocator is dispatching if the type of qualified expression + -- is class_wide, in which case this is the controlling type. + + elsif Nkind (Orig_Node) = N_Allocator + and then Nkind (Expression (Orig_Node)) = N_Qualified_Expression + then + Typ := Etype (Expression (Orig_Node)); + else + Typ := Designated_Type (Typ); + end if; + end if; + + if Is_Class_Wide_Type (Typ) + or else + (Nkind (Parent (N)) = N_Qualified_Expression + and then Is_Access_Type (Etype (N)) + and then Is_Class_Wide_Type (Designated_Type (Etype (N)))) + then + return N; + end if; + end if; + + return Empty; + end Find_Controlling_Arg; + + --------------------------- + -- Find_Dispatching_Type -- + --------------------------- + + function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id is + A_Formal : Entity_Id; + Formal : Entity_Id; + Ctrl_Type : Entity_Id; + + begin + if Present (DTC_Entity (Subp)) then + return Scope (DTC_Entity (Subp)); + + -- For subprograms internally generated by derivations of tagged types + -- use the alias subprogram as a reference to locate the dispatching + -- type of Subp. + + elsif not Comes_From_Source (Subp) + and then Present (Alias (Subp)) + and then Is_Dispatching_Operation (Alias (Subp)) + then + if Ekind (Alias (Subp)) = E_Function + and then Has_Controlling_Result (Alias (Subp)) + then + return Check_Controlling_Type (Etype (Subp), Subp); + + else + Formal := First_Formal (Subp); + A_Formal := First_Formal (Alias (Subp)); + while Present (A_Formal) loop + if Is_Controlling_Formal (A_Formal) then + return Check_Controlling_Type (Etype (Formal), Subp); + end if; + + Next_Formal (Formal); + Next_Formal (A_Formal); + end loop; + + pragma Assert (False); + return Empty; + end if; + + -- General case + + else + Formal := First_Formal (Subp); + while Present (Formal) loop + Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp); + + if Present (Ctrl_Type) then + return Ctrl_Type; + end if; + + Next_Formal (Formal); + end loop; + + -- The subprogram may also be dispatching on result + + if Present (Etype (Subp)) then + return Check_Controlling_Type (Etype (Subp), Subp); + end if; + end if; + + pragma Assert (not Is_Dispatching_Operation (Subp)); + return Empty; + end Find_Dispatching_Type; + + -------------------------------------- + -- Find_Hidden_Overridden_Primitive -- + -------------------------------------- + + function Find_Hidden_Overridden_Primitive (S : Entity_Id) return Entity_Id + is + Tag_Typ : constant Entity_Id := Find_Dispatching_Type (S); + Elmt : Elmt_Id; + Orig_Prim : Entity_Id; + Prim : Entity_Id; + Vis_List : Elist_Id; + + begin + -- This Ada 2012 rule is valid only for type extensions or private + -- extensions. + + if No (Tag_Typ) + or else not Is_Record_Type (Tag_Typ) + or else Etype (Tag_Typ) = Tag_Typ + then + return Empty; + end if; + + -- Collect the list of visible ancestor of the tagged type + + Vis_List := Visible_Ancestors (Tag_Typ); + + Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Elmt) loop + Prim := Node (Elmt); + + -- Find an inherited hidden dispatching primitive with the name of S + -- and a type-conformant profile. + + if Present (Alias (Prim)) + and then Is_Hidden (Alias (Prim)) + and then Find_Dispatching_Type (Alias (Prim)) /= Tag_Typ + and then Primitive_Names_Match (S, Prim) + and then Type_Conformant (S, Prim) + then + declare + Vis_Ancestor : Elmt_Id; + Elmt : Elmt_Id; + + begin + -- The original corresponding operation of Prim must be an + -- operation of a visible ancestor of the dispatching type + -- S, and the original corresponding operation of S2 must + -- be visible. + + Orig_Prim := Original_Corresponding_Operation (Prim); + + if Orig_Prim /= Prim + and then Is_Immediately_Visible (Orig_Prim) + then + Vis_Ancestor := First_Elmt (Vis_List); + while Present (Vis_Ancestor) loop + Elmt := + First_Elmt (Primitive_Operations (Node (Vis_Ancestor))); + while Present (Elmt) loop + if Node (Elmt) = Orig_Prim then + Set_Overridden_Operation (S, Prim); + Set_Alias (Prim, Orig_Prim); + return Prim; + end if; + + Next_Elmt (Elmt); + end loop; + + Next_Elmt (Vis_Ancestor); + end loop; + end if; + end; + end if; + + Next_Elmt (Elmt); + end loop; + + return Empty; + end Find_Hidden_Overridden_Primitive; + + --------------------------------------- + -- Find_Primitive_Covering_Interface -- + --------------------------------------- + + function Find_Primitive_Covering_Interface + (Tagged_Type : Entity_Id; + Iface_Prim : Entity_Id) return Entity_Id + is + E : Entity_Id; + El : Elmt_Id; + + begin + pragma Assert (Is_Interface (Find_Dispatching_Type (Iface_Prim)) + or else (Present (Alias (Iface_Prim)) + and then + Is_Interface + (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim))))); + + -- Search in the homonym chain. Done to speed up locating visible + -- entities and required to catch primitives associated with the partial + -- view of private types when processing the corresponding full view. + + E := Current_Entity (Iface_Prim); + while Present (E) loop + if Is_Subprogram (E) + and then Is_Dispatching_Operation (E) + and then Is_Interface_Conformant (Tagged_Type, Iface_Prim, E) + then + return E; + end if; + + E := Homonym (E); + end loop; + + -- Search in the list of primitives of the type. Required to locate the + -- covering primitive if the covering primitive is not visible (for + -- example, non-visible inherited primitive of private type). + + El := First_Elmt (Primitive_Operations (Tagged_Type)); + while Present (El) loop + E := Node (El); + + -- Keep separate the management of internal entities that link + -- primitives with interface primitives from tagged type primitives. + + if No (Interface_Alias (E)) then + if Present (Alias (E)) then + + -- This interface primitive has not been covered yet + + if Alias (E) = Iface_Prim then + return E; + + -- The covering primitive was inherited + + elsif Overridden_Operation (Ultimate_Alias (E)) + = Iface_Prim + then + return E; + end if; + end if; + + -- Check if E covers the interface primitive (includes case in + -- which E is an inherited private primitive). + + if Is_Interface_Conformant (Tagged_Type, Iface_Prim, E) then + return E; + end if; + + -- Use the internal entity that links the interface primitive with + -- the covering primitive to locate the entity. + + elsif Interface_Alias (E) = Iface_Prim then + return Alias (E); + end if; + + Next_Elmt (El); + end loop; + + -- Not found + + return Empty; + end Find_Primitive_Covering_Interface; + + --------------------------- + -- Inherited_Subprograms -- + --------------------------- + + function Inherited_Subprograms (S : Entity_Id) return Subprogram_List is + Result : Subprogram_List (1 .. 6000); + -- 6000 here is intended to be infinity. We could use an expandable + -- table, but it would be awfully heavy, and there is no way that we + -- could reasonably exceed this value. + + N : Int := 0; + -- Number of entries in Result + + Parent_Op : Entity_Id; + -- Traverses the Overridden_Operation chain + + procedure Store_IS (E : Entity_Id); + -- Stores E in Result if not already stored + + -------------- + -- Store_IS -- + -------------- + + procedure Store_IS (E : Entity_Id) is + begin + for J in 1 .. N loop + if E = Result (J) then + return; + end if; + end loop; + + N := N + 1; + Result (N) := E; + end Store_IS; + + -- Start of processing for Inherited_Subprograms + + begin + if Present (S) and then Is_Dispatching_Operation (S) then + + -- Deal with direct inheritance + + Parent_Op := S; + loop + Parent_Op := Overridden_Operation (Parent_Op); + exit when No (Parent_Op); + + if Is_Subprogram (Parent_Op) + or else Is_Generic_Subprogram (Parent_Op) + then + Store_IS (Parent_Op); + end if; + end loop; + + -- Now deal with interfaces + + declare + Tag_Typ : Entity_Id; + Prim : Entity_Id; + Elmt : Elmt_Id; + + begin + Tag_Typ := Find_Dispatching_Type (S); + + if Is_Concurrent_Type (Tag_Typ) then + Tag_Typ := Corresponding_Record_Type (Tag_Typ); + end if; + + -- Search primitive operations of dispatching type + + if Present (Tag_Typ) + and then Present (Primitive_Operations (Tag_Typ)) + then + Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Elmt) loop + Prim := Node (Elmt); + + -- The following test eliminates some odd cases in which + -- Ekind (Prim) is Void, to be investigated further ??? + + if not (Is_Subprogram (Prim) + or else + Is_Generic_Subprogram (Prim)) + then + null; + + -- For [generic] subprogram, look at interface alias + + elsif Present (Interface_Alias (Prim)) + and then Alias (Prim) = S + then + -- We have found a primitive covered by S + + Store_IS (Interface_Alias (Prim)); + end if; + + Next_Elmt (Elmt); + end loop; + end if; + end; + end if; + + return Result (1 .. N); + end Inherited_Subprograms; + + --------------------------- + -- Is_Dynamically_Tagged -- + --------------------------- + + function Is_Dynamically_Tagged (N : Node_Id) return Boolean is + begin + if Nkind (N) = N_Error then + return False; + else + return Find_Controlling_Arg (N) /= Empty; + end if; + end Is_Dynamically_Tagged; + + --------------------------------- + -- Is_Null_Interface_Primitive -- + --------------------------------- + + function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean is + begin + return Comes_From_Source (E) + and then Is_Dispatching_Operation (E) + and then Ekind (E) = E_Procedure + and then Null_Present (Parent (E)) + and then Is_Interface (Find_Dispatching_Type (E)); + end Is_Null_Interface_Primitive; + + -------------------------- + -- Is_Tag_Indeterminate -- + -------------------------- + + function Is_Tag_Indeterminate (N : Node_Id) return Boolean is + Nam : Entity_Id; + Actual : Node_Id; + Orig_Node : constant Node_Id := Original_Node (N); + + begin + if Nkind (Orig_Node) = N_Function_Call + and then Is_Entity_Name (Name (Orig_Node)) + then + Nam := Entity (Name (Orig_Node)); + + if not Has_Controlling_Result (Nam) then + return False; + + -- An explicit dereference means that the call has already been + -- expanded and there is no tag to propagate. + + elsif Nkind (N) = N_Explicit_Dereference then + return False; + + -- If there are no actuals, the call is tag-indeterminate + + elsif No (Parameter_Associations (Orig_Node)) then + return True; + + else + Actual := First_Actual (Orig_Node); + while Present (Actual) loop + if Is_Controlling_Actual (Actual) + and then not Is_Tag_Indeterminate (Actual) + then + return False; -- one operand is dispatching + end if; + + Next_Actual (Actual); + end loop; + + return True; + end if; + + elsif Nkind (Orig_Node) = N_Qualified_Expression then + return Is_Tag_Indeterminate (Expression (Orig_Node)); + + -- Case of a call to the Input attribute (possibly rewritten), which is + -- always tag-indeterminate except when its prefix is a Class attribute. + + elsif Nkind (Orig_Node) = N_Attribute_Reference + and then + Get_Attribute_Id (Attribute_Name (Orig_Node)) = Attribute_Input + and then + Nkind (Prefix (Orig_Node)) /= N_Attribute_Reference + then + return True; + + -- In Ada 2005 a function that returns an anonymous access type can + -- dispatching, and the dereference of a call to such a function + -- is also tag-indeterminate. + + elsif Nkind (Orig_Node) = N_Explicit_Dereference + and then Ada_Version >= Ada_2005 + then + return Is_Tag_Indeterminate (Prefix (Orig_Node)); + + else + return False; + end if; + end Is_Tag_Indeterminate; + + ------------------------------------ + -- Override_Dispatching_Operation -- + ------------------------------------ + + procedure Override_Dispatching_Operation + (Tagged_Type : Entity_Id; + Prev_Op : Entity_Id; + New_Op : Entity_Id) + is + Elmt : Elmt_Id; + Prim : Node_Id; + + begin + -- Diagnose failure to match No_Return in parent (Ada-2005, AI-414, but + -- we do it unconditionally in Ada 95 now, since this is our pragma!) + + if No_Return (Prev_Op) and then not No_Return (New_Op) then + Error_Msg_N ("procedure & must have No_Return pragma", New_Op); + Error_Msg_N ("\since overridden procedure has No_Return", New_Op); + end if; + + -- If there is no previous operation to override, the type declaration + -- was malformed, and an error must have been emitted already. + + Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); + while Present (Elmt) + and then Node (Elmt) /= Prev_Op + loop + Next_Elmt (Elmt); + end loop; + + if No (Elmt) then + return; + end if; + + -- The location of entities that come from source in the list of + -- primitives of the tagged type must follow their order of occurrence + -- in the sources to fulfill the C++ ABI. If the overridden entity is a + -- primitive of an interface that is not an ancestor of this tagged + -- type (that is, it is an entity added to the list of primitives by + -- Derive_Interface_Progenitors), then we must append the new entity + -- at the end of the list of primitives. + + if Present (Alias (Prev_Op)) + and then Is_Interface (Find_Dispatching_Type (Alias (Prev_Op))) + and then not Is_Ancestor (Find_Dispatching_Type (Alias (Prev_Op)), + Tagged_Type) + then + Remove_Elmt (Primitive_Operations (Tagged_Type), Elmt); + Append_Elmt (New_Op, Primitive_Operations (Tagged_Type)); + + -- The new primitive replaces the overridden entity. Required to ensure + -- that overriding primitive is assigned the same dispatch table slot. + + else + Replace_Elmt (Elmt, New_Op); + end if; + + if Ada_Version >= Ada_2005 + and then Has_Interfaces (Tagged_Type) + then + -- Ada 2005 (AI-251): Update the attribute alias of all the aliased + -- entities of the overridden primitive to reference New_Op, and also + -- propagate the proper value of Is_Abstract_Subprogram. Verify + -- that the new operation is subtype conformant with the interface + -- operations that it implements (for operations inherited from the + -- parent itself, this check is made when building the derived type). + + -- Note: This code is only executed in case of late overriding + + Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); + while Present (Elmt) loop + Prim := Node (Elmt); + + if Prim = New_Op then + null; + + -- Note: The check on Is_Subprogram protects the frontend against + -- reading attributes in entities that are not yet fully decorated + + elsif Is_Subprogram (Prim) + and then Present (Interface_Alias (Prim)) + and then Alias (Prim) = Prev_Op + and then Present (Etype (New_Op)) + then + Set_Alias (Prim, New_Op); + Check_Subtype_Conformant (New_Op, Prim); + Set_Is_Abstract_Subprogram (Prim, + Is_Abstract_Subprogram (New_Op)); + + -- Ensure that this entity will be expanded to fill the + -- corresponding entry in its dispatch table. + + if not Is_Abstract_Subprogram (Prim) then + Set_Has_Delayed_Freeze (Prim); + end if; + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + if (not Is_Package_Or_Generic_Package (Current_Scope)) + or else not In_Private_Part (Current_Scope) + then + -- Not a private primitive + + null; + + else pragma Assert (Is_Inherited_Operation (Prev_Op)); + + -- Make the overriding operation into an alias of the implicit one. + -- In this fashion a call from outside ends up calling the new body + -- even if non-dispatching, and a call from inside calls the over- + -- riding operation because it hides the implicit one. To indicate + -- that the body of Prev_Op is never called, set its dispatch table + -- entity to Empty. If the overridden operation has a dispatching + -- result, so does the overriding one. + + Set_Alias (Prev_Op, New_Op); + Set_DTC_Entity (Prev_Op, Empty); + Set_Has_Controlling_Result (New_Op, Has_Controlling_Result (Prev_Op)); + return; + end if; + end Override_Dispatching_Operation; + + ------------------- + -- Propagate_Tag -- + ------------------- + + procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id) is + Call_Node : Node_Id; + Arg : Node_Id; + + begin + if Nkind (Actual) = N_Function_Call then + Call_Node := Actual; + + elsif Nkind (Actual) = N_Identifier + and then Nkind (Original_Node (Actual)) = N_Function_Call + then + -- Call rewritten as object declaration when stack-checking is + -- enabled. Propagate tag to expression in declaration, which is + -- original call. + + Call_Node := Expression (Parent (Entity (Actual))); + + -- Ada 2005: If this is a dereference of a call to a function with a + -- dispatching access-result, the tag is propagated when the dereference + -- itself is expanded (see exp_ch6.adb) and there is nothing else to do. + + elsif Nkind (Actual) = N_Explicit_Dereference + and then Nkind (Original_Node (Prefix (Actual))) = N_Function_Call + then + return; + + -- Only other possibilities are parenthesized or qualified expression, + -- or an expander-generated unchecked conversion of a function call to + -- a stream Input attribute. + + else + Call_Node := Expression (Actual); + end if; + + -- Do not set the Controlling_Argument if already set. This happens in + -- the special case of _Input (see Exp_Attr, case Input). + + if No (Controlling_Argument (Call_Node)) then + Set_Controlling_Argument (Call_Node, Control); + end if; + + Arg := First_Actual (Call_Node); + while Present (Arg) loop + if Is_Tag_Indeterminate (Arg) then + Propagate_Tag (Control, Arg); + end if; + + Next_Actual (Arg); + end loop; + + -- Expansion of dispatching calls is suppressed when VM_Target, because + -- the VM back-ends directly handle the generation of dispatching calls + -- and would have to undo any expansion to an indirect call. + + if Tagged_Type_Expansion then + declare + Call_Typ : constant Entity_Id := Etype (Call_Node); + + begin + Expand_Dispatching_Call (Call_Node); + + -- If the controlling argument is an interface type and the type + -- of Call_Node differs then we must add an implicit conversion to + -- force displacement of the pointer to the object to reference + -- the secondary dispatch table of the interface. + + if Is_Interface (Etype (Control)) + and then Etype (Control) /= Call_Typ + then + -- Cannot use Convert_To because the previous call to + -- Expand_Dispatching_Call leaves decorated the Call_Node + -- with the type of Control. + + Rewrite (Call_Node, + Make_Type_Conversion (Sloc (Call_Node), + Subtype_Mark => + New_Occurrence_Of (Etype (Control), Sloc (Call_Node)), + Expression => Relocate_Node (Call_Node))); + Set_Etype (Call_Node, Etype (Control)); + Set_Analyzed (Call_Node); + + Expand_Interface_Conversion (Call_Node, Is_Static => False); + end if; + end; + + -- Expansion of a dispatching call results in an indirect call, which in + -- turn causes current values to be killed (see Resolve_Call), so on VM + -- targets we do the call here to ensure consistent warnings between VM + -- and non-VM targets. + + else + Kill_Current_Values; + end if; + end Propagate_Tag; + +end Sem_Disp; diff --git a/gcc/ada/sem_disp.ads b/gcc/ada/sem_disp.ads new file mode 100644 index 000000000..c27346dd4 --- /dev/null +++ b/gcc/ada/sem_disp.ads @@ -0,0 +1,135 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ D I S P -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 involved in tagged types and dynamic +-- dispatching. + +with Types; use Types; +package Sem_Disp is + + procedure Check_Controlling_Formals (Typ : Entity_Id; Subp : Entity_Id); + -- Check that all controlling parameters of Subp are of type Typ, + -- that defaults for controlling parameters are tag-indeterminate, + -- and that the nominal subtype of the parameters and result + -- statically match the first subtype of the controlling type. + + procedure Check_Dispatching_Call (N : Node_Id); + -- Check if a call is a dispatching call. The subprogram is known to + -- be a dispatching operation. The call is dispatching if all the + -- controlling actuals are dynamically tagged. This procedure is called + -- after overload resolution, so the call is known to be unambiguous. + + procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id); + -- Add "Subp" to the list of primitive operations of the corresponding type + -- if it has a parameter of this type and is defined at a proper place for + -- primitive operations (new primitives are only defined in package spec, + -- overridden operation can be defined in any scope). If Old_Subp is not + -- Empty we are in the overriding case. If the tagged type associated with + -- Subp is a concurrent type (case that occurs when the type is declared in + -- a generic because the analysis of generics disables generation of the + -- corresponding record) then this routine does does not add "Subp" to the + -- list of primitive operations but leaves Subp decorated as dispatching + -- operation to enable checks associated with the Object.Operation notation + + procedure Check_Operation_From_Incomplete_Type + (Subp : Entity_Id; + Typ : Entity_Id); + -- If a primitive operation was defined for the incomplete view of the + -- type, and the full type declaration is a derived type definition, + -- the operation may override an inherited one. + + procedure Check_Operation_From_Private_View (Subp, Old_Subp : Entity_Id); + -- Add "Old_Subp" to the list of primitive operations of the corresponding + -- tagged type if it is the full view of a private tagged type. The Alias + -- of "OldSubp" is adjusted to point to the inherited procedure of the + -- full view because it is always this one which has to be called. + + function Covers_Some_Interface (Prim : Entity_Id) return Boolean; + -- Returns true if Prim covers some interface primitive of its associated + -- tagged type. The tagged type of Prim must be frozen when this function + -- is invoked. + + function Find_Controlling_Arg (N : Node_Id) return Node_Id; + -- Returns the actual controlling argument if N is dynamically tagged, + -- and Empty if it is not dynamically tagged. + + function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id; + -- Check whether a subprogram is dispatching, and find the tagged type of + -- the controlling argument or arguments. Returns Empty if Subp is not a + -- dispatching operation. + + function Find_Primitive_Covering_Interface + (Tagged_Type : Entity_Id; + Iface_Prim : Entity_Id) return Entity_Id; + -- Search in the homonym chain for the primitive of Tagged_Type that covers + -- Iface_Prim. The homonym chain traversal is required to catch primitives + -- associated with the partial view of private types when processing the + -- corresponding full view. If the entity is not found then search for it + -- in the list of primitives of Tagged_Type. This latter search is needed + -- when the interface primitive is covered by a private subprogram. If the + -- primitive has not been covered yet then return the entity that will be + -- overridden when the primitive is covered (that is, return the entity + -- whose alias attribute references the interface primitive). If none of + -- these entities is found then return Empty. + + type Subprogram_List is array (Nat range <>) of Entity_Id; + -- Type returned by Inherited_Subprograms function + + function Inherited_Subprograms (S : Entity_Id) return Subprogram_List; + -- Given the spec of a subprogram, this function gathers any inherited + -- subprograms from direct inheritance or via interfaces. The list is + -- a list of entity id's of the specs of inherited subprograms. Returns + -- a null array if passed an Empty spec id. Note that the returned array + -- only includes subprograms and generic subprograms (and excludes any + -- other inherited entities, in particular enumeration literals). + + function Is_Dynamically_Tagged (N : Node_Id) return Boolean; + -- Used to determine whether a call is dispatching, i.e. if is an + -- an expression of a class_Wide type, or a call to a function with + -- controlling result where at least one operand is dynamically tagged. + + function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean; + -- Returns True if E is a null procedure that is an interface primitive + + function Is_Tag_Indeterminate (N : Node_Id) return Boolean; + -- An expression is tag-indeterminate if it is a call that dispatches + -- on result, and all controlling operands are also indeterminate. + -- Such a function call may inherit a tag from an enclosing call. + + procedure Override_Dispatching_Operation + (Tagged_Type : Entity_Id; + Prev_Op : Entity_Id; + New_Op : Entity_Id); + -- Replace an implicit dispatching operation with an explicit one. + -- Prev_Op is an inherited primitive operation which is overridden + -- by the explicit declaration of New_Op. + + procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id); + -- If a function call is tag-indeterminate, its controlling argument is + -- found in the context; either an enclosing call, or the left-hand side + -- of the enclosing assignment statement. The tag must be propagated + -- recursively to the tag-indeterminate actuals of the call. + +end Sem_Disp; diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb new file mode 100644 index 000000000..f9a3c2ae9 --- /dev/null +++ b/gcc/ada/sem_dist.adb @@ -0,0 +1,786 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ D I S T -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Casing; use Casing; +with Einfo; use Einfo; +with Errout; use Errout; +with Exp_Dist; use Exp_Dist; +with Exp_Tss; use Exp_Tss; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Namet; use Namet; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Disp; use Sem_Disp; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Stand; use Stand; +with Stringt; use Stringt; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +package body Sem_Dist is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure RAS_E_Dereference (Pref : Node_Id); + -- Handles explicit dereference of Remote Access to Subprograms + + function Full_Qualified_Name (E : Entity_Id) return String_Id; + -- returns the full qualified name of the entity in lower case + + ------------------------- + -- Add_Stub_Constructs -- + ------------------------- + + procedure Add_Stub_Constructs (N : Node_Id) is + U : constant Node_Id := Unit (N); + Spec : Entity_Id := Empty; + + Exp : Node_Id := U; + -- Unit that will be expanded + + begin + pragma Assert (Distribution_Stub_Mode /= No_Stubs); + + if Nkind (U) = N_Package_Declaration then + Spec := Defining_Entity (Specification (U)); + + elsif Nkind (U) = N_Package_Body then + Spec := Corresponding_Spec (U); + + else pragma Assert (Nkind (U) = N_Package_Instantiation); + Exp := Instance_Spec (U); + Spec := Defining_Entity (Specification (Exp)); + end if; + + pragma Assert (Is_Shared_Passive (Spec) + or else Is_Remote_Call_Interface (Spec)); + + if Distribution_Stub_Mode = Generate_Caller_Stub_Body then + if Is_Shared_Passive (Spec) then + null; + elsif Nkind (U) = N_Package_Body then + Error_Msg_N + ("Specification file expected from command line", U); + else + Expand_Calling_Stubs_Bodies (Exp); + end if; + + else + if Is_Shared_Passive (Spec) then + Build_Passive_Partition_Stub (Exp); + else + Expand_Receiving_Stubs_Bodies (Exp); + end if; + + end if; + end Add_Stub_Constructs; + + --------------------------------------- + -- Build_RAS_Primitive_Specification -- + --------------------------------------- + + function Build_RAS_Primitive_Specification + (Subp_Spec : Node_Id; + Remote_Object_Type : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Subp_Spec); + + Primitive_Spec : constant Node_Id := + Copy_Specification (Loc, + Spec => Subp_Spec, + New_Name => Name_uCall); + + Subtype_Mark_For_Self : Node_Id; + + begin + if No (Parameter_Specifications (Primitive_Spec)) then + Set_Parameter_Specifications (Primitive_Spec, New_List); + end if; + + if Nkind (Remote_Object_Type) in N_Entity then + Subtype_Mark_For_Self := + New_Occurrence_Of (Remote_Object_Type, Loc); + else + Subtype_Mark_For_Self := Remote_Object_Type; + end if; + + Prepend_To ( + Parameter_Specifications (Primitive_Spec), + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uS), + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + Subtype_Mark_For_Self))); + + -- Trick later semantic analysis into considering this operation as a + -- primitive (dispatching) operation of tagged type Obj_Type. + + Set_Comes_From_Source ( + Defining_Unit_Name (Primitive_Spec), True); + + return Primitive_Spec; + end Build_RAS_Primitive_Specification; + + ------------------------- + -- Full_Qualified_Name -- + ------------------------- + + function Full_Qualified_Name (E : Entity_Id) return String_Id is + Ent : Entity_Id := E; + Parent_Name : String_Id := No_String; + + begin + -- Deals properly with child units + + if Nkind (Ent) = N_Defining_Program_Unit_Name then + Ent := Defining_Identifier (Ent); + end if; + + -- Compute recursively the qualification (only "Standard" has no scope) + + if Present (Scope (Scope (Ent))) then + Parent_Name := Full_Qualified_Name (Scope (Ent)); + end if; + + -- Every entity should have a name except some expanded blocks. Do not + -- bother about those. + + if Chars (Ent) = No_Name then + return Parent_Name; + end if; + + -- Add a period between Name and qualification + + if Parent_Name /= No_String then + Start_String (Parent_Name); + Store_String_Char (Get_Char_Code ('.')); + else + Start_String; + end if; + + -- Generates the entity name in upper case + + Get_Name_String (Chars (Ent)); + Set_Casing (All_Lower_Case); + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + return End_String; + end Full_Qualified_Name; + + ------------------ + -- Get_PCS_Name -- + ------------------ + + function Get_PCS_Name return PCS_Names is + begin + return + Chars (Entity (Expression (Parent (RTE (RE_DSA_Implementation))))); + end Get_PCS_Name; + + --------------------- + -- Get_PCS_Version -- + --------------------- + + function Get_PCS_Version return Int is + PCS_Version_Entity : Entity_Id; + PCS_Version : Int; + + begin + if RTE_Available (RE_PCS_Version) then + PCS_Version_Entity := RTE (RE_PCS_Version); + pragma Assert (Ekind (PCS_Version_Entity) = E_Named_Integer); + PCS_Version := + UI_To_Int (Expr_Value (Constant_Value (PCS_Version_Entity))); + + else + -- Case of System.Partition_Interface.PCS_Version not found: + -- return a null version. + + PCS_Version := 0; + end if; + + return PCS_Version; + end Get_PCS_Version; + + ------------------------ + -- Is_All_Remote_Call -- + ------------------------ + + function Is_All_Remote_Call (N : Node_Id) return Boolean is + Par : Node_Id; + + begin + if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) + and then Nkind (Name (N)) in N_Has_Entity + and then Is_Remote_Call_Interface (Entity (Name (N))) + and then Has_All_Calls_Remote (Scope (Entity (Name (N)))) + and then Comes_From_Source (N) + then + Par := Parent (Entity (Name (N))); + while Present (Par) + and then (Nkind (Par) /= N_Package_Specification + or else Is_Wrapper_Package (Defining_Entity (Par))) + loop + Par := Parent (Par); + end loop; + + if Present (Par) then + return + not Scope_Within_Or_Same (Current_Scope, Defining_Entity (Par)); + else + return False; + end if; + else + return False; + end if; + end Is_All_Remote_Call; + + --------------------------------- + -- Is_RACW_Stub_Type_Operation -- + --------------------------------- + + function Is_RACW_Stub_Type_Operation (Op : Entity_Id) return Boolean is + Dispatching_Type : Entity_Id; + + begin + case Ekind (Op) is + when E_Function | E_Procedure => + Dispatching_Type := Find_Dispatching_Type (Op); + return Present (Dispatching_Type) + and then Is_RACW_Stub_Type (Dispatching_Type) + and then not Is_Internal (Op); + + when others => + return False; + end case; + end Is_RACW_Stub_Type_Operation; + + ------------------------------------ + -- Package_Specification_Of_Scope -- + ------------------------------------ + + function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is + N : Node_Id; + + begin + N := Parent (E); + while Nkind (N) /= N_Package_Specification loop + N := Parent (N); + end loop; + + return N; + end Package_Specification_Of_Scope; + + -------------------------- + -- Process_Partition_ID -- + -------------------------- + + procedure Process_Partition_Id (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ety : Entity_Id; + Get_Pt_Id : Node_Id; + Get_Pt_Id_Call : Node_Id; + Prefix_String : String_Id; + Typ : constant Entity_Id := Etype (N); + + begin + -- In case prefix is not a library unit entity, get the entity + -- of library unit. + + Ety := Entity (Prefix (N)); + while (Present (Scope (Ety)) + and then Scope (Ety) /= Standard_Standard) + and not Is_Child_Unit (Ety) + loop + Ety := Scope (Ety); + end loop; + + -- Retrieve the proper function to call + + if Is_Remote_Call_Interface (Ety) then + Get_Pt_Id := New_Occurrence_Of + (RTE (RE_Get_Active_Partition_Id), Loc); + + elsif Is_Shared_Passive (Ety) then + Get_Pt_Id := New_Occurrence_Of + (RTE (RE_Get_Passive_Partition_Id), Loc); + + else + Get_Pt_Id := New_Occurrence_Of + (RTE (RE_Get_Local_Partition_Id), Loc); + end if; + + -- Get and store the String_Id corresponding to the name of the + -- library unit whose Partition_Id is needed. + + Get_Library_Unit_Name_String (Unit_Declaration_Node (Ety)); + Prefix_String := String_From_Name_Buffer; + + -- Build the function call which will replace the attribute + + if Is_Remote_Call_Interface (Ety) or else Is_Shared_Passive (Ety) then + Get_Pt_Id_Call := + Make_Function_Call (Loc, + Name => Get_Pt_Id, + Parameter_Associations => + New_List (Make_String_Literal (Loc, Prefix_String))); + + else + Get_Pt_Id_Call := Make_Function_Call (Loc, Get_Pt_Id); + end if; + + -- Replace the attribute node by a conversion of the function call + -- to the target type. + + Rewrite (N, Convert_To (Typ, Get_Pt_Id_Call)); + Analyze_And_Resolve (N, Typ); + end Process_Partition_Id; + + ---------------------------------- + -- Process_Remote_AST_Attribute -- + ---------------------------------- + + procedure Process_Remote_AST_Attribute + (N : Node_Id; + New_Type : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Remote_Subp : Entity_Id; + Tick_Access_Conv_Call : Node_Id; + Remote_Subp_Decl : Node_Id; + RS_Pkg_Specif : Node_Id; + RS_Pkg_E : Entity_Id; + RAS_Type : Entity_Id := New_Type; + Async_E : Entity_Id; + All_Calls_Remote_E : Entity_Id; + Attribute_Subp : Entity_Id; + + begin + -- Check if we have to expand the access attribute + + Remote_Subp := Entity (Prefix (N)); + + if not Expander_Active or else Get_PCS_Name = Name_No_DSA then + return; + end if; + + if Ekind (RAS_Type) /= E_Record_Type then + RAS_Type := Equivalent_Type (RAS_Type); + end if; + + Attribute_Subp := TSS (RAS_Type, TSS_RAS_Access); + pragma Assert (Present (Attribute_Subp)); + Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp); + + if Nkind (Remote_Subp_Decl) = N_Subprogram_Body then + Remote_Subp := Corresponding_Spec (Remote_Subp_Decl); + Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp); + end if; + + RS_Pkg_Specif := Parent (Remote_Subp_Decl); + RS_Pkg_E := Defining_Entity (RS_Pkg_Specif); + + Async_E := + Boolean_Literals (Ekind (Remote_Subp) = E_Procedure + and then Is_Asynchronous (Remote_Subp)); + + All_Calls_Remote_E := + Boolean_Literals (Has_All_Calls_Remote (RS_Pkg_E)); + + Tick_Access_Conv_Call := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Attribute_Subp, Loc), + Parameter_Associations => + New_List ( + Make_String_Literal (Loc, + Strval => Full_Qualified_Name (RS_Pkg_E)), + Build_Subprogram_Id (Loc, Remote_Subp), + New_Occurrence_Of (Async_E, Loc), + New_Occurrence_Of (All_Calls_Remote_E, Loc))); + + Rewrite (N, Tick_Access_Conv_Call); + Analyze_And_Resolve (N, RAS_Type); + end Process_Remote_AST_Attribute; + + ------------------------------------ + -- Process_Remote_AST_Declaration -- + ------------------------------------ + + procedure Process_Remote_AST_Declaration (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + User_Type : constant Node_Id := Defining_Identifier (N); + Scop : constant Entity_Id := Scope (User_Type); + Is_RCI : constant Boolean := Is_Remote_Call_Interface (Scop); + Is_RT : constant Boolean := Is_Remote_Types (Scop); + Type_Def : constant Node_Id := Type_Definition (N); + Parameter : Node_Id; + + Is_Degenerate : Boolean; + -- True iff this RAS has an access formal parameter (see + -- Exp_Dist.Add_RAS_Dereference_TSS for details). + + Subpkg : constant Entity_Id := Make_Temporary (Loc, 'S'); + Subpkg_Decl : Node_Id; + Subpkg_Body : Node_Id; + Vis_Decls : constant List_Id := New_List; + Priv_Decls : constant List_Id := New_List; + + Obj_Type : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (User_Type), 'R')); + + Full_Obj_Type : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars (Obj_Type)); + + RACW_Type : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (User_Type), 'P')); + + Fat_Type : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars (User_Type)); + + Fat_Type_Decl : Node_Id; + + begin + Is_Degenerate := False; + Parameter := First (Parameter_Specifications (Type_Def)); + while Present (Parameter) loop + if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then + Error_Msg_N ("formal parameter& has anonymous access type?", + Defining_Identifier (Parameter)); + Is_Degenerate := True; + exit; + end if; + + Next (Parameter); + end loop; + + if Is_Degenerate then + Error_Msg_NE + ("remote access-to-subprogram type& can only be null?", + Defining_Identifier (Parameter), User_Type); + + -- The only legal value for a RAS with a formal parameter of an + -- anonymous access type is null, because it cannot be subtype- + -- conformant with any legal remote subprogram declaration. In this + -- case, we cannot generate a corresponding primitive operation. + + end if; + + if Get_PCS_Name = Name_No_DSA then + return; + end if; + + -- The tagged private type, primitive operation and RACW type associated + -- with a RAS need to all be declared in a subpackage of the one that + -- contains the RAS declaration, because the primitive of the object + -- type, and the associated primitive of the stub type, need to be + -- dispatching operations of these types, and the profile of the RAS + -- might contain tagged types declared in the same scope. + + Append_To (Vis_Decls, + Make_Private_Type_Declaration (Loc, + Defining_Identifier => Obj_Type, + Abstract_Present => True, + Tagged_Present => True, + Limited_Present => True)); + + Append_To (Priv_Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Full_Obj_Type, + Type_Definition => + Make_Record_Definition (Loc, + Abstract_Present => True, + Tagged_Present => True, + Limited_Present => True, + Null_Present => True, + Component_List => Empty))); + + -- Trick semantic analysis into swapping the public and full view when + -- freezing the public view. + + Set_Comes_From_Source (Full_Obj_Type, True); + + if not Is_Degenerate then + Append_To (Vis_Decls, + Make_Abstract_Subprogram_Declaration (Loc, + Specification => Build_RAS_Primitive_Specification ( + Subp_Spec => Type_Def, + Remote_Object_Type => Obj_Type))); + end if; + + Append_To (Vis_Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => RACW_Type, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Obj_Type, Loc), + Attribute_Name => Name_Class)))); + + Set_Is_Remote_Call_Interface (RACW_Type, Is_RCI); + Set_Is_Remote_Types (RACW_Type, Is_RT); + + Subpkg_Decl := + Make_Package_Declaration (Loc, + Make_Package_Specification (Loc, + Defining_Unit_Name => Subpkg, + Visible_Declarations => Vis_Decls, + Private_Declarations => Priv_Decls, + End_Label => New_Occurrence_Of (Subpkg, Loc))); + + Set_Is_Remote_Call_Interface (Subpkg, Is_RCI); + Set_Is_Remote_Types (Subpkg, Is_RT); + Insert_After_And_Analyze (N, Subpkg_Decl); + + -- Generate package body to receive RACW calling stubs + + -- Note: Analyze_Declarations has an absolute requirement that the + -- declaration list be non-empty, so provide dummy null statement here. + + Subpkg_Body := + Make_Package_Body (Loc, + Defining_Unit_Name => Make_Defining_Identifier (Loc, Chars (Subpkg)), + Declarations => New_List (Make_Null_Statement (Loc))); + Insert_After_And_Analyze (Subpkg_Decl, Subpkg_Body); + + -- Many parts of the analyzer and expander expect + -- that the fat pointer type used to implement remote + -- access to subprogram types be a record. + -- Note: The structure of this type must be kept consistent + -- with the code generated by Remote_AST_Null_Value for the + -- corresponding 'null' expression. + + Fat_Type_Decl := Make_Full_Type_Declaration (Loc, + Defining_Identifier => Fat_Type, + Type_Definition => + Make_Record_Definition (Loc, + Component_List => + Make_Component_List (Loc, + Component_Items => New_List ( + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Ras), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (RACW_Type, Loc))))))); + + Set_Equivalent_Type (User_Type, Fat_Type); + Set_Corresponding_Remote_Type (Fat_Type, User_Type); + Insert_After_And_Analyze (Subpkg_Body, Fat_Type_Decl); + + -- The reason we suppress the initialization procedure is that we know + -- that no initialization is required (even if Initialize_Scalars mode + -- is active), and there are order of elaboration problems if we do try + -- to generate an init proc for this created record type. + + Set_Suppress_Init_Proc (Fat_Type); + + if Expander_Active then + Add_RAST_Features (Parent (User_Type)); + end if; + end Process_Remote_AST_Declaration; + + ----------------------- + -- RAS_E_Dereference -- + ----------------------- + + procedure RAS_E_Dereference (Pref : Node_Id) is + Loc : constant Source_Ptr := Sloc (Pref); + Call_Node : Node_Id; + New_Type : constant Entity_Id := Etype (Pref); + Explicit_Deref : constant Node_Id := Parent (Pref); + Deref_Subp_Call : constant Node_Id := Parent (Explicit_Deref); + Deref_Proc : Entity_Id; + Params : List_Id; + + begin + if Nkind (Deref_Subp_Call) = N_Procedure_Call_Statement then + Params := Parameter_Associations (Deref_Subp_Call); + + if Present (Params) then + Prepend (Pref, Params); + else + Params := New_List (Pref); + end if; + + elsif Nkind (Deref_Subp_Call) = N_Indexed_Component then + Params := Expressions (Deref_Subp_Call); + + if Present (Params) then + Prepend (Pref, Params); + else + Params := New_List (Pref); + end if; + + else + -- Context is not a call + + return; + end if; + + if not Expander_Active or else Get_PCS_Name = Name_No_DSA then + return; + end if; + + Deref_Proc := TSS (New_Type, TSS_RAS_Dereference); + pragma Assert (Present (Deref_Proc)); + + if Ekind (Deref_Proc) = E_Function then + Call_Node := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Deref_Proc, Loc), + Parameter_Associations => Params); + else + Call_Node := + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Deref_Proc, Loc), + Parameter_Associations => Params); + end if; + + Rewrite (Deref_Subp_Call, Call_Node); + Analyze (Deref_Subp_Call); + end RAS_E_Dereference; + + ------------------------------ + -- Remote_AST_E_Dereference -- + ------------------------------ + + function Remote_AST_E_Dereference (P : Node_Id) return Boolean is + ET : constant Entity_Id := Etype (P); + + begin + -- Perform the changes only on original dereferences, and only if + -- we are generating code. + + if Comes_From_Source (P) + and then Is_Record_Type (ET) + and then (Is_Remote_Call_Interface (ET) + or else Is_Remote_Types (ET)) + and then Present (Corresponding_Remote_Type (ET)) + and then Nkind_In (Parent (Parent (P)), N_Procedure_Call_Statement, + N_Indexed_Component) + and then Expander_Active + then + RAS_E_Dereference (P); + return True; + else + return False; + end if; + end Remote_AST_E_Dereference; + + ------------------------------ + -- Remote_AST_I_Dereference -- + ------------------------------ + + function Remote_AST_I_Dereference (P : Node_Id) return Boolean is + ET : constant Entity_Id := Etype (P); + Deref : Node_Id; + + begin + if Comes_From_Source (P) + and then (Is_Remote_Call_Interface (ET) + or else Is_Remote_Types (ET)) + and then Present (Corresponding_Remote_Type (ET)) + and then Ekind (Entity (P)) /= E_Function + then + Deref := + Make_Explicit_Dereference (Sloc (P), + Prefix => Relocate_Node (P)); + Rewrite (P, Deref); + Set_Etype (P, ET); + RAS_E_Dereference (Prefix (P)); + return True; + end if; + + return False; + end Remote_AST_I_Dereference; + + --------------------------- + -- Remote_AST_Null_Value -- + --------------------------- + + function Remote_AST_Null_Value + (N : Node_Id; + Typ : Entity_Id) return Boolean + is + Loc : constant Source_Ptr := Sloc (N); + Target_Type : Entity_Id; + + begin + if not Expander_Active or else Get_PCS_Name = Name_No_DSA then + return False; + + elsif Ekind (Typ) = E_Access_Subprogram_Type + and then (Is_Remote_Call_Interface (Typ) + or else Is_Remote_Types (Typ)) + and then Comes_From_Source (N) + and then Expander_Active + then + -- Any null that comes from source and is of the RAS type must + -- be expanded, except if expansion is not active (nothing + -- gets expanded into the equivalent record type). + + Target_Type := Equivalent_Type (Typ); + + elsif Ekind (Typ) = E_Record_Type + and then Present (Corresponding_Remote_Type (Typ)) + then + -- This is a record type representing a RAS type, this must be + -- expanded. + + Target_Type := Typ; + + else + -- We do not have to handle this case + + return False; + end if; + + Rewrite (N, + Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List (Make_Identifier (Loc, Name_Ras)), + Expression => Make_Null (Loc))))); + Analyze_And_Resolve (N, Target_Type); + return True; + end Remote_AST_Null_Value; + +end Sem_Dist; diff --git a/gcc/ada/sem_dist.ads b/gcc/ada/sem_dist.ads new file mode 100644 index 000000000..38a164a41 --- /dev/null +++ b/gcc/ada/sem_dist.ads @@ -0,0 +1,106 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ D I S T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Semantic processing for distribution annex facilities + +with Snames; use Snames; +with Types; use Types; + +package Sem_Dist is + + function Get_PCS_Name return PCS_Names; + -- Return the name of a literal of type DSA_Implementation_Name in package + -- System.Partition_Interface indicating what PCS is currently in use. + + function Get_PCS_Version return Int; + -- Return the version number of the PCS API implemented by the PCS. + -- The consistency of this version with the one expected by Exp_Dist + -- (Exp_Dist.PCS_Version_Number) in Rtsfind.RTE.Check_RPC. + -- If no PCS version information is available, 0 is returned. + + procedure Add_Stub_Constructs (N : Node_Id); + -- Create the stubs constructs for a remote call interface package + -- specification or body or for a shared passive specification. For caller + -- stubs, expansion takes place directly in the specification and no + -- additional compilation unit is created. + + function Build_RAS_Primitive_Specification + (Subp_Spec : Node_Id; + Remote_Object_Type : Node_Id) return Node_Id; + -- Build a subprogram specification for the primitive operation of the + -- Remote_Object_Type used to implement a remote access-to-subprogram + -- type whose parameter profile is given by specification Subp_Spec. + + function Is_All_Remote_Call (N : Node_Id) return Boolean; + -- Check whether a function or procedure call should be expanded into + -- a remote call, because the entity is declared in a package decl that + -- is not currently in scope, and the proper pragmas apply. + + procedure Process_Partition_Id (N : Node_Id); + -- Replace attribute reference with call to runtime function. The result + -- is converted to the context type, because the attribute yields a + -- universal integer value. + + procedure Process_Remote_AST_Attribute (N : Node_Id; New_Type : Entity_Id); + -- Given N, an access attribute reference node whose prefix is a + -- remote subprogram, rewrite N with a call to a conversion function + -- whose return type is New_Type. + + procedure Process_Remote_AST_Declaration (N : Node_Id); + -- Given N, an access to subprogram type declaration node in RCI or remote + -- types unit, build a new record (fat pointer) type declaration using the + -- old Defining_Identifier of N and a link to the old declaration node N + -- whose Defining_Identifier is changed. We also construct declarations of + -- two subprograms in the unit specification which handle remote access to + -- subprogram type (fat pointer) dereference and the unit receiver that + -- handles remote calls (from remote access to subprogram type values.) + + function Remote_AST_E_Dereference (P : Node_Id) return Boolean; + -- If the prefix of an explicit dereference is a record type that + -- represent the fat pointer for an Remote access to subprogram, in the + -- context of a call, rewrite the enclosing call node into remote call, + -- the first actual of which is the fat pointer. Return true if the + -- context is correct and the transformation took place. + + function Remote_AST_I_Dereference (P : Node_Id) return Boolean; + -- If P is a record type that represents the fat pointer for a remote + -- access to subprogram, and P is the prefix of a call, insert an explicit + -- dereference and perform the transformation described for the previous + -- function. + + function Remote_AST_Null_Value + (N : Node_Id; + Typ : Entity_Id) return Boolean; + -- If N is a null value and Typ a remote access to subprogram type, this + -- function will check if null needs to be replaced with an aggregate and + -- will return True in this case. Otherwise, it will return False. + + function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id; + -- Return the N_Package_Specification corresponding to a scope E + + function Is_RACW_Stub_Type_Operation (Op : Entity_Id) return Boolean; + -- True when Op is a primitive operation of an RACW stub type + +end Sem_Dist; diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb new file mode 100644 index 000000000..73f5b10b5 --- /dev/null +++ b/gcc/ada/sem_elab.adb @@ -0,0 +1,3190 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ E L A B -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Expander; use Expander; +with Fname; use Fname; +with Lib; use Lib; +with Lib.Load; use Lib.Load; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Output; use Output; +with Restrict; use Restrict; +with Rident; use Rident; +with Sem; use Sem; +with Sem_Cat; use Sem_Cat; +with Sem_Ch7; use Sem_Ch7; +with Sem_Ch8; use Sem_Ch8; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with Stand; use Stand; +with Table; +with Tbuild; use Tbuild; +with Uname; use Uname; + +package body Sem_Elab is + + -- The following table records the recursive call chain for output in the + -- Output routine. Each entry records the call node and the entity of the + -- called routine. The number of entries in the table (i.e. the value of + -- Elab_Call.Last) indicates the current depth of recursion and is used to + -- identify the outer level. + + type Elab_Call_Entry is record + Cloc : Source_Ptr; + Ent : Entity_Id; + end record; + + package Elab_Call is new Table.Table ( + Table_Component_Type => Elab_Call_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 100, + Table_Name => "Elab_Call"); + + -- This table is initialized at the start of each outer level call. It + -- holds the entities for all subprograms that have been examined for this + -- particular outer level call, and is used to prevent both infinite + -- recursion, and useless reanalysis of bodies already seen + + package Elab_Visited is new Table.Table ( + Table_Component_Type => Entity_Id, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 200, + Table_Increment => 100, + Table_Name => "Elab_Visited"); + + -- This table stores calls to Check_Internal_Call that are delayed + -- until all generics are instantiated, and in particular that all + -- generic bodies have been inserted. We need to delay, because we + -- need to be able to look through the inserted bodies. + + type Delay_Element is record + N : Node_Id; + -- The parameter N from the call to Check_Internal_Call. Note that + -- this node may get rewritten over the delay period by expansion + -- in the call case (but not in the instantiation case). + + E : Entity_Id; + -- The parameter E from the call to Check_Internal_Call + + Orig_Ent : Entity_Id; + -- The parameter Orig_Ent from the call to Check_Internal_Call + + Curscop : Entity_Id; + -- The current scope of the call. This is restored when we complete + -- the delayed call, so that we do this in the right scope. + + From_Elab_Code : Boolean; + -- Save indication of whether this call is from elaboration code + + Outer_Scope : Entity_Id; + -- Save scope of outer level call + end record; + + package Delay_Check is new Table.Table ( + Table_Component_Type => Delay_Element, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 1000, + Table_Increment => 100, + Table_Name => "Delay_Check"); + + C_Scope : Entity_Id; + -- Top level scope of current scope. Compute this only once at the outer + -- level, i.e. for a call to Check_Elab_Call from outside this unit. + + Outer_Level_Sloc : Source_Ptr; + -- Save Sloc value for outer level call node for comparisons of source + -- locations. A body is too late if it appears after the *outer* level + -- call, not the particular call that is being analyzed. + + From_Elab_Code : Boolean; + -- This flag shows whether the outer level call currently being examined + -- is or is not in elaboration code. We are only interested in calls to + -- routines in other units if this flag is True. + + In_Task_Activation : Boolean := False; + -- This flag indicates whether we are performing elaboration checks on + -- task procedures, at the point of activation. If true, we do not trace + -- internal calls in these procedures, because all local bodies are known + -- to be elaborated. + + Delaying_Elab_Checks : Boolean := True; + -- This is set True till the compilation is complete, including the + -- insertion of all instance bodies. Then when Check_Elab_Calls is called, + -- the delay table is used to make the delayed calls and this flag is reset + -- to False, so that the calls are processed + + ----------------------- + -- Local Subprograms -- + ----------------------- + + -- Note: Outer_Scope in all following specs represents the scope of + -- interest of the outer level call. If it is set to Standard_Standard, + -- then it means the outer level call was at elaboration level, and that + -- thus all calls are of interest. If it was set to some other scope, + -- then the original call was an inner call, and we are not interested + -- in calls that go outside this scope. + + procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id); + -- Analysis of construct N shows that we should set Elaborate_All_Desirable + -- for the WITH clause for unit U (which will always be present). A special + -- case is when N is a function or procedure instantiation, in which case + -- it is sufficient to set Elaborate_Desirable, since in this case there is + -- no possibility of transitive elaboration issues. + + procedure Check_A_Call + (N : Node_Id; + E : Entity_Id; + Outer_Scope : Entity_Id; + Inter_Unit_Only : Boolean; + Generate_Warnings : Boolean := True); + -- This is the internal recursive routine that is called to check for a + -- possible elaboration error. The argument N is a subprogram call or + -- generic instantiation to be checked, and E is the entity of the called + -- subprogram, or instantiated generic unit. The flag Outer_Scope is the + -- outer level scope for the original call. Inter_Unit_Only is set if the + -- call is only to be checked in the case where it is to another unit (and + -- skipped if within a unit). Generate_Warnings is set to False to suppress + -- warning messages about missing pragma Elaborate_All's. These messages + -- are not wanted for inner calls in the dynamic model. + + procedure Check_Bad_Instantiation (N : Node_Id); + -- N is a node for an instantiation (if called with any other node kind, + -- Check_Bad_Instantiation ignores the call). This subprogram checks for + -- the special case of a generic instantiation of a generic spec in the + -- same declarative part as the instantiation where a body is present and + -- has not yet been seen. This is an obvious error, but needs to be checked + -- specially at the time of the instantiation, since it is a case where we + -- cannot insert the body anywhere. If this case is detected, warnings are + -- generated, and a raise of Program_Error is inserted. In addition any + -- subprograms in the generic spec are stubbed, and the Bad_Instantiation + -- flag is set on the instantiation node. The caller in Sem_Ch12 uses this + -- flag as an indication that no attempt should be made to insert an + -- instance body. + + procedure Check_Internal_Call + (N : Node_Id; + E : Entity_Id; + Outer_Scope : Entity_Id; + Orig_Ent : Entity_Id); + -- N is a function call or procedure statement call node and E is the + -- entity of the called function, which is within the current compilation + -- unit (where subunits count as part of the parent). This call checks if + -- this call, or any call within any accessed body could cause an ABE, and + -- if so, outputs a warning. Orig_Ent differs from E only in the case of + -- renamings, and points to the original name of the entity. This is used + -- for error messages. Outer_Scope is the outer level scope for the + -- original call. + + procedure Check_Internal_Call_Continue + (N : Node_Id; + E : Entity_Id; + Outer_Scope : Entity_Id; + Orig_Ent : Entity_Id); + -- The processing for Check_Internal_Call is divided up into two phases, + -- and this represents the second phase. The second phase is delayed if + -- Delaying_Elab_Calls is set to True. In this delayed case, the first + -- phase makes an entry in the Delay_Check table, which is processed when + -- Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to + -- Check_Internal_Call. Outer_Scope is the outer level scope for the + -- original call. + + procedure Set_Elaboration_Constraint + (Call : Node_Id; + Subp : Entity_Id; + Scop : Entity_Id); + -- The current unit U may depend semantically on some unit P which is not + -- in the current context. If there is an elaboration call that reaches P, + -- we need to indicate that P requires an Elaborate_All, but this is not + -- effective in U's ali file, if there is no with_clause for P. In this + -- case we add the Elaborate_All on the unit Q that directly or indirectly + -- makes P available. This can happen in two cases: + -- + -- a) Q declares a subtype of a type declared in P, and the call is an + -- initialization call for an object of that subtype. + -- + -- b) Q declares an object of some tagged type whose root type is + -- declared in P, and the initialization call uses object notation on + -- that object to reach a primitive operation or a classwide operation + -- declared in P. + -- + -- If P appears in the context of U, the current processing is correct. + -- Otherwise we must identify these two cases to retrieve Q and place the + -- Elaborate_All_Desirable on it. + + function Has_Generic_Body (N : Node_Id) return Boolean; + -- N is a generic package instantiation node, and this routine determines + -- if this package spec does in fact have a generic body. If so, then + -- True is returned, otherwise False. Note that this is not at all the + -- same as checking if the unit requires a body, since it deals with + -- the case of optional bodies accurately (i.e. if a body is optional, + -- then it looks to see if a body is actually present). Note: this + -- function can only do a fully correct job if in generating code mode + -- where all bodies have to be present. If we are operating in semantics + -- check only mode, then in some cases of optional bodies, a result of + -- False may incorrectly be given. In practice this simply means that + -- some cases of warnings for incorrect order of elaboration will only + -- be given when generating code, which is not a big problem (and is + -- inevitable, given the optional body semantics of Ada). + + procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty); + -- Given code for an elaboration check (or unconditional raise if the check + -- is not needed), inserts the code in the appropriate place. N is the call + -- or instantiation node for which the check code is required. C is the + -- test whose failure triggers the raise. + + procedure Output_Calls (N : Node_Id); + -- Outputs chain of calls stored in the Elab_Call table. The caller has + -- already generated the main warning message, so the warnings generated + -- are all continuation messages. The argument is the call node at which + -- the messages are to be placed. + + function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean; + -- Given two scopes, determine whether they are the same scope from an + -- elaboration point of view, i.e. packages and blocks are ignored. + + procedure Set_C_Scope; + -- On entry C_Scope is set to some scope. On return, C_Scope is reset + -- to be the enclosing compilation unit of this scope. + + function Spec_Entity (E : Entity_Id) return Entity_Id; + -- Given a compilation unit entity, if it is a spec entity, it is returned + -- unchanged. If it is a body entity, then the spec for the corresponding + -- spec is returned + + procedure Supply_Bodies (N : Node_Id); + -- Given a node, N, that is either a subprogram declaration or a package + -- declaration, this procedure supplies dummy bodies for the subprogram + -- or for all subprograms in the package. If the given node is not one + -- of these two possibilities, then Supply_Bodies does nothing. The + -- dummy body contains a single Raise statement. + + procedure Supply_Bodies (L : List_Id); + -- Calls Supply_Bodies for all elements of the given list L + + function Within (E1, E2 : Entity_Id) return Boolean; + -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one + -- of its contained scopes, False otherwise. + + function Within_Elaborate_All (E : Entity_Id) return Boolean; + -- Before emitting a warning on a scope E for a missing elaborate_all, + -- check whether E may be in the context of a directly visible unit U to + -- which the pragma applies. This prevents spurious warnings when the + -- called entity is renamed within U. + + -------------------------------------- + -- Activate_Elaborate_All_Desirable -- + -------------------------------------- + + procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id) is + UN : constant Unit_Number_Type := Get_Code_Unit (N); + CU : constant Node_Id := Cunit (UN); + UE : constant Entity_Id := Cunit_Entity (UN); + Unm : constant Unit_Name_Type := Unit_Name (UN); + CI : constant List_Id := Context_Items (CU); + Itm : Node_Id; + Ent : Entity_Id; + + procedure Add_To_Context_And_Mark (Itm : Node_Id); + -- This procedure is called when the elaborate indication must be + -- applied to a unit not in the context of the referencing unit. The + -- unit gets added to the context as an implicit with. + + function In_Withs_Of (UEs : Entity_Id) return Boolean; + -- UEs is the spec entity of a unit. If the unit to be marked is + -- in the context item list of this unit spec, then the call returns + -- True and Itm is left set to point to the relevant N_With_Clause node. + + procedure Set_Elab_Flag (Itm : Node_Id); + -- Sets Elaborate_[All_]Desirable as appropriate on Itm + + ----------------------------- + -- Add_To_Context_And_Mark -- + ----------------------------- + + procedure Add_To_Context_And_Mark (Itm : Node_Id) is + CW : constant Node_Id := + Make_With_Clause (Sloc (Itm), + Name => Name (Itm)); + + begin + Set_Library_Unit (CW, Library_Unit (Itm)); + Set_Implicit_With (CW, True); + + -- Set elaborate all desirable on copy and then append the copy to + -- the list of body with's and we are done. + + Set_Elab_Flag (CW); + Append_To (CI, CW); + end Add_To_Context_And_Mark; + + ----------------- + -- In_Withs_Of -- + ----------------- + + function In_Withs_Of (UEs : Entity_Id) return Boolean is + UNs : constant Unit_Number_Type := Get_Source_Unit (UEs); + CUs : constant Node_Id := Cunit (UNs); + CIs : constant List_Id := Context_Items (CUs); + + begin + Itm := First (CIs); + while Present (Itm) loop + if Nkind (Itm) = N_With_Clause then + Ent := + Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); + + if U = Ent then + return True; + end if; + end if; + + Next (Itm); + end loop; + + return False; + end In_Withs_Of; + + ------------------- + -- Set_Elab_Flag -- + ------------------- + + procedure Set_Elab_Flag (Itm : Node_Id) is + begin + if Nkind (N) in N_Subprogram_Instantiation then + Set_Elaborate_Desirable (Itm); + else + Set_Elaborate_All_Desirable (Itm); + end if; + end Set_Elab_Flag; + + -- Start of processing for Activate_Elaborate_All_Desirable + + begin + -- Do not set binder indication if expansion is disabled, as when + -- compiling a generic unit. + + if not Expander_Active then + return; + end if; + + Itm := First (CI); + while Present (Itm) loop + if Nkind (Itm) = N_With_Clause then + Ent := Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); + + -- If we find it, then mark elaborate all desirable and return + + if U = Ent then + Set_Elab_Flag (Itm); + return; + end if; + end if; + + Next (Itm); + end loop; + + -- If we fall through then the with clause is not present in the + -- current unit. One legitimate possibility is that the with clause + -- is present in the spec when we are a body. + + if Is_Body_Name (Unm) + and then In_Withs_Of (Spec_Entity (UE)) + then + Add_To_Context_And_Mark (Itm); + return; + end if; + + -- Similarly, we may be in the spec or body of a child unit, where + -- the unit in question is with'ed by some ancestor of the child unit. + + if Is_Child_Name (Unm) then + declare + Pkg : Entity_Id; + + begin + Pkg := UE; + loop + Pkg := Scope (Pkg); + exit when Pkg = Standard_Standard; + + if In_Withs_Of (Pkg) then + Add_To_Context_And_Mark (Itm); + return; + end if; + end loop; + end; + end if; + + -- Here if we do not find with clause on spec or body. We just ignore + -- this case, it means that the elaboration involves some other unit + -- than the unit being compiled, and will be caught elsewhere. + + null; + end Activate_Elaborate_All_Desirable; + + ------------------ + -- Check_A_Call -- + ------------------ + + procedure Check_A_Call + (N : Node_Id; + E : Entity_Id; + Outer_Scope : Entity_Id; + Inter_Unit_Only : Boolean; + Generate_Warnings : Boolean := True) + is + Loc : constant Source_Ptr := Sloc (N); + Ent : Entity_Id; + Decl : Node_Id; + + E_Scope : Entity_Id; + -- Top level scope of entity for called subprogram. This value includes + -- following renamings and derivations, so this scope can be in a + -- non-visible unit. This is the scope that is to be investigated to + -- see whether an elaboration check is required. + + W_Scope : Entity_Id; + -- Top level scope of directly called entity for subprogram. This + -- differs from E_Scope in the case where renamings or derivations + -- are involved, since it does not follow these links. W_Scope is + -- generally in a visible unit, and it is this scope that may require + -- an Elaborate_All. However, there are some cases (initialization + -- calls and calls involving object notation) where W_Scope might not + -- be in the context of the current unit, and there is an intermediate + -- package that is, in which case the Elaborate_All has to be placed + -- on this intermediate package. These special cases are handled in + -- Set_Elaboration_Constraint. + + Body_Acts_As_Spec : Boolean; + -- Set to true if call is to body acting as spec (no separate spec) + + Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; + -- Indicates if we have instantiation case + + Caller_Unit_Internal : Boolean; + Callee_Unit_Internal : Boolean; + + Inst_Caller : Source_Ptr; + Inst_Callee : Source_Ptr; + + Unit_Caller : Unit_Number_Type; + Unit_Callee : Unit_Number_Type; + + Cunit_SC : Boolean := False; + -- Set to suppress dynamic elaboration checks where one of the + -- enclosing scopes has Elaboration_Checks_Suppressed set, or else + -- if a pragma Elaborate (_All) applies to that scope, in which case + -- warnings on the scope are also suppressed. For the internal case, + -- we ignore this flag. + + begin + -- If the call is known to be within a local Suppress Elaboration + -- pragma, nothing to check. This can happen in task bodies. + + if (Nkind (N) = N_Function_Call + or else Nkind (N) = N_Procedure_Call_Statement) + and then No_Elaboration_Check (N) + then + return; + end if; + + -- Go to parent for derived subprogram, or to original subprogram in the + -- case of a renaming (Alias covers both these cases). + + Ent := E; + loop + if (Suppress_Elaboration_Warnings (Ent) + or else Elaboration_Checks_Suppressed (Ent)) + and then (Inst_Case or else No (Alias (Ent))) + then + return; + end if; + + -- Nothing to do for imported entities + + if Is_Imported (Ent) then + return; + end if; + + exit when Inst_Case or else No (Alias (Ent)); + Ent := Alias (Ent); + end loop; + + Decl := Unit_Declaration_Node (Ent); + + if Nkind (Decl) = N_Subprogram_Body then + Body_Acts_As_Spec := True; + + elsif Nkind (Decl) = N_Subprogram_Declaration + or else Nkind (Decl) = N_Subprogram_Body_Stub + or else Inst_Case + then + Body_Acts_As_Spec := False; + + -- If we have none of an instantiation, subprogram body or + -- subprogram declaration, then it is not a case that we want + -- to check. (One case is a call to a generic formal subprogram, + -- where we do not want the check in the template). + + else + return; + end if; + + E_Scope := Ent; + loop + if Elaboration_Checks_Suppressed (E_Scope) + or else Suppress_Elaboration_Warnings (E_Scope) + then + Cunit_SC := True; + end if; + + -- Exit when we get to compilation unit, not counting subunits + + exit when Is_Compilation_Unit (E_Scope) + and then (Is_Child_Unit (E_Scope) + or else Scope (E_Scope) = Standard_Standard); + + -- If we did not find a compilation unit, other than standard, + -- then nothing to check (happens in some instantiation cases) + + if E_Scope = Standard_Standard then + return; + + -- Otherwise move up a scope looking for compilation unit + + else + E_Scope := Scope (E_Scope); + end if; + end loop; + + -- No checks needed for pure or preelaborated compilation units + + if Is_Pure (E_Scope) or else Is_Preelaborated (E_Scope) then + return; + end if; + + -- If the generic entity is within a deeper instance than we are, then + -- either the instantiation to which we refer itself caused an ABE, in + -- which case that will be handled separately, or else we know that the + -- body we need appears as needed at the point of the instantiation. + -- However, this assumption is only valid if we are in static mode. + + if not Dynamic_Elaboration_Checks + and then Instantiation_Depth (Sloc (Ent)) > + Instantiation_Depth (Sloc (N)) + then + return; + end if; + + -- Do not give a warning for a package with no body + + if Ekind (Ent) = E_Generic_Package + and then not Has_Generic_Body (N) + then + return; + end if; + + -- Case of entity is not in current unit (i.e. with'ed unit case) + + if E_Scope /= C_Scope then + + -- We are only interested in such calls if the outer call was from + -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode. + + if not From_Elab_Code and then not Dynamic_Elaboration_Checks then + return; + end if; + + -- Nothing to do if some scope said that no checks were required + + if Cunit_SC then + return; + end if; + + -- Nothing to do for a generic instance, because in this case the + -- checking was at the point of instantiation of the generic However, + -- this shortcut is only applicable in static mode. + + if Is_Generic_Instance (Ent) and not Dynamic_Elaboration_Checks then + return; + end if; + + -- Nothing to do if subprogram with no separate spec. However, a + -- call to Deep_Initialize may result in a call to a user-defined + -- Initialize procedure, which imposes a body dependency. This + -- happens only if the type is controlled and the Initialize + -- procedure is not inherited. + + if Body_Acts_As_Spec then + if Is_TSS (Ent, TSS_Deep_Initialize) then + declare + Typ : Entity_Id; + Init : Entity_Id; + begin + Typ := Etype (Next_Formal (First_Formal (Ent))); + + if not Is_Controlled (Typ) then + return; + else + Init := Find_Prim_Op (Typ, Name_Initialize); + + if Comes_From_Source (Init) then + Ent := Init; + else + return; + end if; + end if; + end; + + else + return; + end if; + end if; + + -- Check cases of internal units + + Callee_Unit_Internal := + Is_Internal_File_Name + (Unit_File_Name (Get_Source_Unit (E_Scope))); + + -- Do not give a warning if the with'ed unit is internal + -- and this is the generic instantiation case (this saves a + -- lot of hassle dealing with the Text_IO special child units) + + if Callee_Unit_Internal and Inst_Case then + return; + end if; + + if C_Scope = Standard_Standard then + Caller_Unit_Internal := False; + else + Caller_Unit_Internal := + Is_Internal_File_Name + (Unit_File_Name (Get_Source_Unit (C_Scope))); + end if; + + -- Do not give a warning if the with'ed unit is internal + -- and the caller is not internal (since the binder always + -- elaborates internal units first). + + if Callee_Unit_Internal and (not Caller_Unit_Internal) then + return; + end if; + + -- For now, if debug flag -gnatdE is not set, do no checking for + -- one internal unit withing another. This fixes the problem with + -- the sgi build and storage errors. To be resolved later ??? + + if (Callee_Unit_Internal and Caller_Unit_Internal) + and then not Debug_Flag_EE + then + return; + end if; + + if Is_TSS (E, TSS_Deep_Initialize) then + Ent := E; + end if; + + -- If the call is in an instance, and the called entity is not + -- defined in the same instance, then the elaboration issue + -- focuses around the unit containing the template, it is + -- this unit which requires an Elaborate_All. + + -- However, if we are doing dynamic elaboration, we need to + -- chase the call in the usual manner. + + -- We do not handle the case of calling a generic formal correctly + -- in the static case. See test 4703-004 to explore this gap ??? + + Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N))); + Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent))); + + if Inst_Caller = No_Location then + Unit_Caller := No_Unit; + else + Unit_Caller := Get_Source_Unit (N); + end if; + + if Inst_Callee = No_Location then + Unit_Callee := No_Unit; + else + Unit_Callee := Get_Source_Unit (Ent); + end if; + + if Unit_Caller /= No_Unit + and then Unit_Callee /= Unit_Caller + and then not Dynamic_Elaboration_Checks + then + E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller)); + + -- If we don't get a spec entity, just ignore call. Not quite + -- clear why this check is necessary. ??? + + if No (E_Scope) then + return; + end if; + + -- Otherwise step to enclosing compilation unit + + while not Is_Compilation_Unit (E_Scope) loop + E_Scope := Scope (E_Scope); + end loop; + + -- For the case N is not an instance, or a call within instance, we + -- recompute E_Scope for the error message, since we do NOT want to + -- go to the unit which has the ultimate declaration in the case of + -- renaming and derivation and we also want to go to the generic unit + -- in the case of an instance, and no further. + + else + -- Loop to carefully follow renamings and derivations one step + -- outside the current unit, but not further. + + if not Inst_Case + and then Present (Alias (Ent)) + then + E_Scope := Alias (Ent); + else + E_Scope := Ent; + end if; + + loop + while not Is_Compilation_Unit (E_Scope) loop + E_Scope := Scope (E_Scope); + end loop; + + -- If E_Scope is the same as C_Scope, it means that there + -- definitely was a local renaming or derivation, and we + -- are not yet out of the current unit. + + exit when E_Scope /= C_Scope; + Ent := Alias (Ent); + E_Scope := Ent; + + -- If no alias, there is a previous error + + if No (Ent) then + return; + end if; + end loop; + end if; + + if Within_Elaborate_All (E_Scope) then + return; + end if; + + -- Find top level scope for called entity (not following renamings + -- or derivations). This is where the Elaborate_All will go if it + -- is needed. We start with the called entity, except in the case + -- of an initialization procedure outside the current package, where + -- the init proc is in the root package, and we start from the entity + -- of the name in the call. + + if Is_Entity_Name (Name (N)) + and then Is_Init_Proc (Entity (Name (N))) + and then not In_Same_Extended_Unit (N, Entity (Name (N))) + then + W_Scope := Scope (Entity (Name (N))); + else + W_Scope := E; + end if; + + while not Is_Compilation_Unit (W_Scope) loop + W_Scope := Scope (W_Scope); + end loop; + + -- Now check if an elaborate_all (or dynamic check) is needed + + if not Suppress_Elaboration_Warnings (Ent) + and then not Elaboration_Checks_Suppressed (Ent) + and then not Suppress_Elaboration_Warnings (E_Scope) + and then not Elaboration_Checks_Suppressed (E_Scope) + and then Elab_Warnings + and then Generate_Warnings + then + Generate_Elab_Warnings : declare + procedure Elab_Warning + (Msg_D : String; + Msg_S : String; + Ent : Node_Or_Entity_Id); + -- Generate a call to Error_Msg_NE with parameters Msg_D or + -- Msg_S (for dynamic or static elaboration model), N and Ent. + + ------------------ + -- Elab_Warning -- + ------------------ + + procedure Elab_Warning + (Msg_D : String; + Msg_S : String; + Ent : Node_Or_Entity_Id) + is + begin + if Dynamic_Elaboration_Checks then + Error_Msg_NE (Msg_D, N, Ent); + else + Error_Msg_NE (Msg_S, N, Ent); + end if; + end Elab_Warning; + + -- Start of processing for Generate_Elab_Warnings + + begin + if Inst_Case then + Elab_Warning + ("instantiation of& may raise Program_Error?", + "info: instantiation of& during elaboration?", Ent); + + else + if Nkind (Name (N)) in N_Has_Entity + and then Is_Init_Proc (Entity (Name (N))) + and then Comes_From_Source (Ent) + then + Elab_Warning + ("implicit call to & may raise Program_Error?", + "info: implicit call to & during elaboration?", + Ent); + + else + Elab_Warning + ("call to & may raise Program_Error?", + "info: call to & during elaboration?", + Ent); + end if; + end if; + + Error_Msg_Qual_Level := Nat'Last; + + if Nkind (N) in N_Subprogram_Instantiation then + Elab_Warning + ("\missing pragma Elaborate for&?", + "\info: implicit pragma Elaborate for& generated?", + W_Scope); + else + Elab_Warning + ("\missing pragma Elaborate_All for&?", + "\info: implicit pragma Elaborate_All for & generated?", + W_Scope); + end if; + end Generate_Elab_Warnings; + + Error_Msg_Qual_Level := 0; + Output_Calls (N); + + -- Set flag to prevent further warnings for same unit unless in + -- All_Errors_Mode. + + if not All_Errors_Mode and not Dynamic_Elaboration_Checks then + Set_Suppress_Elaboration_Warnings (W_Scope, True); + end if; + end if; + + -- Check for runtime elaboration check required + + if Dynamic_Elaboration_Checks then + if not Elaboration_Checks_Suppressed (Ent) + and then not Elaboration_Checks_Suppressed (W_Scope) + and then not Elaboration_Checks_Suppressed (E_Scope) + and then not Cunit_SC + then + -- Runtime elaboration check required. Generate check of the + -- elaboration Boolean for the unit containing the entity. + + -- Note that for this case, we do check the real unit (the one + -- from following renamings, since that is the issue!) + + -- Could this possibly miss a useless but required PE??? + + Insert_Elab_Check (N, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Elaborated, + Prefix => New_Occurrence_Of (Spec_Entity (E_Scope), Loc))); + + -- Prevent duplicate elaboration checks on the same call, + -- which can happen if the body enclosing the call appears + -- itself in a call whose elaboration check is delayed. + + if Nkind_In (N, N_Function_Call, + N_Procedure_Call_Statement) + then + Set_No_Elaboration_Check (N); + end if; + end if; + + -- Case of static elaboration model + + else + -- Do not do anything if elaboration checks suppressed. Note that + -- we check Ent here, not E, since we want the real entity for the + -- body to see if checks are suppressed for it, not the dummy + -- entry for renamings or derivations. + + if Elaboration_Checks_Suppressed (Ent) + or else Elaboration_Checks_Suppressed (E_Scope) + or else Elaboration_Checks_Suppressed (W_Scope) + then + null; + + -- Here we need to generate an implicit elaborate all + + else + -- Generate elaborate_all warning unless suppressed + + if (Elab_Warnings and Generate_Warnings and not Inst_Case) + and then not Suppress_Elaboration_Warnings (Ent) + and then not Suppress_Elaboration_Warnings (E_Scope) + and then not Suppress_Elaboration_Warnings (W_Scope) + then + Error_Msg_Node_2 := W_Scope; + Error_Msg_NE + ("call to& in elaboration code " & + "requires pragma Elaborate_All on&?", N, E); + end if; + + -- Set indication for binder to generate Elaborate_All + + Set_Elaboration_Constraint (N, E, W_Scope); + end if; + end if; + + -- Case of entity is in same unit as call or instantiation + + elsif not Inter_Unit_Only then + Check_Internal_Call (N, Ent, Outer_Scope, E); + end if; + end Check_A_Call; + + ----------------------------- + -- Check_Bad_Instantiation -- + ----------------------------- + + procedure Check_Bad_Instantiation (N : Node_Id) is + Ent : Entity_Id; + + begin + -- Nothing to do if we do not have an instantiation (happens in some + -- error cases, and also in the formal package declaration case) + + if Nkind (N) not in N_Generic_Instantiation then + return; + + -- Nothing to do if serious errors detected (avoid cascaded errors) + + elsif Serious_Errors_Detected /= 0 then + return; + + -- Nothing to do if not in full analysis mode + + elsif not Full_Analysis then + return; + + -- Nothing to do if inside a generic template + + elsif Inside_A_Generic then + return; + + -- Nothing to do if a library level instantiation + + elsif Nkind (Parent (N)) = N_Compilation_Unit then + return; + + -- Nothing to do if we are compiling a proper body for semantic + -- purposes only. The generic body may be in another proper body. + + elsif + Nkind (Parent (Unit_Declaration_Node (Main_Unit_Entity))) = N_Subunit + then + return; + end if; + + Ent := Get_Generic_Entity (N); + + -- The case we are interested in is when the generic spec is in the + -- current declarative part + + if not Same_Elaboration_Scope (Current_Scope, Scope (Ent)) + or else not In_Same_Extended_Unit (N, Ent) + then + return; + end if; + + -- If the generic entity is within a deeper instance than we are, then + -- either the instantiation to which we refer itself caused an ABE, in + -- which case that will be handled separately. Otherwise, we know that + -- the body we need appears as needed at the point of the instantiation. + -- If they are both at the same level but not within the same instance + -- then the body of the generic will be in the earlier instance. + + declare + D1 : constant Int := Instantiation_Depth (Sloc (Ent)); + D2 : constant Int := Instantiation_Depth (Sloc (N)); + + begin + if D1 > D2 then + return; + + elsif D1 = D2 + and then Is_Generic_Instance (Scope (Ent)) + and then not In_Open_Scopes (Scope (Ent)) + then + return; + end if; + end; + + -- Now we can proceed, if the entity being called has a completion, + -- then we are definitely OK, since we have already seen the body. + + if Has_Completion (Ent) then + return; + end if; + + -- If there is no body, then nothing to do + + if not Has_Generic_Body (N) then + return; + end if; + + -- Here we definitely have a bad instantiation + + Error_Msg_NE + ("?cannot instantiate& before body seen", N, Ent); + + if Present (Instance_Spec (N)) then + Supply_Bodies (Instance_Spec (N)); + end if; + + Error_Msg_N + ("\?Program_Error will be raised at run time", N); + Insert_Elab_Check (N); + Set_ABE_Is_Certain (N); + end Check_Bad_Instantiation; + + --------------------- + -- Check_Elab_Call -- + --------------------- + + procedure Check_Elab_Call + (N : Node_Id; + Outer_Scope : Entity_Id := Empty) + is + Ent : Entity_Id; + P : Node_Id; + + function Get_Called_Ent return Entity_Id; + -- Retrieve called entity. If this is a call to a protected subprogram, + -- entity is a selected component. The callable entity may be absent, + -- in which case there is no check to perform. This happens with + -- non-analyzed calls in nested generics. + + -------------------- + -- Get_Called_Ent -- + -------------------- + + function Get_Called_Ent return Entity_Id is + Nam : Node_Id; + + begin + Nam := Name (N); + + if No (Nam) then + return Empty; + + elsif Nkind (Nam) = N_Selected_Component then + return Entity (Selector_Name (Nam)); + + elsif not Is_Entity_Name (Nam) then + return Empty; + + else + return Entity (Nam); + end if; + end Get_Called_Ent; + + -- Start of processing for Check_Elab_Call + + begin + -- If the call does not come from the main unit, there is nothing to + -- check. Elaboration call from units in the context of the main unit + -- will lead to semantic dependencies when those units are compiled. + + if not In_Extended_Main_Code_Unit (N) then + return; + end if; + + -- For an entry call, check relevant restriction + + if Nkind (N) = N_Entry_Call_Statement + and then not In_Subprogram_Or_Concurrent_Unit + then + Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N); + + -- Nothing to do if this is not a call (happens in some error + -- conditions, and in some cases where rewriting occurs). + + elsif Nkind (N) /= N_Function_Call + and then Nkind (N) /= N_Procedure_Call_Statement + then + return; + + -- Nothing to do if this is a call already rewritten for elab checking + + elsif Nkind (Parent (N)) = N_Conditional_Expression then + return; + + -- Nothing to do if inside a generic template + + elsif Inside_A_Generic + and then No (Enclosing_Generic_Body (N)) + then + return; + end if; + + -- Here we have a call at elaboration time which must be checked + + if Debug_Flag_LL then + Write_Str (" Check_Elab_Call: "); + + if No (Name (N)) + or else not Is_Entity_Name (Name (N)) + then + Write_Str ("<> "); + else + Write_Name (Chars (Entity (Name (N)))); + end if; + + Write_Str (" call at "); + Write_Location (Sloc (N)); + Write_Eol; + end if; + + -- Climb up the tree to make sure we are not inside default expression + -- of a parameter specification or a record component, since in both + -- these cases, we will be doing the actual call later, not now, and it + -- is at the time of the actual call (statically speaking) that we must + -- do our static check, not at the time of its initial analysis). + + -- However, we have to check calls within component definitions (e.g. + -- a function call that determines an array component bound), so we + -- terminate the loop in that case. + + P := Parent (N); + while Present (P) loop + if Nkind (P) = N_Parameter_Specification + or else + Nkind (P) = N_Component_Declaration + then + return; + + -- The call occurs within the constraint of a component, + -- so it must be checked. + + elsif Nkind (P) = N_Component_Definition then + exit; + + else + P := Parent (P); + end if; + end loop; + + -- Stuff that happens only at the outer level + + if No (Outer_Scope) then + Elab_Visited.Set_Last (0); + + -- Nothing to do if current scope is Standard (this is a bit odd, but + -- it happens in the case of generic instantiations). + + C_Scope := Current_Scope; + + if C_Scope = Standard_Standard then + return; + end if; + + -- First case, we are in elaboration code + + From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; + if From_Elab_Code then + + -- Complain if call that comes from source in preelaborated unit + -- and we are not inside a subprogram (i.e. we are in elab code). + + if Comes_From_Source (N) + and then In_Preelaborated_Unit + and then not In_Inlined_Body + then + -- This is a warning in GNAT mode allowing such calls to be + -- used in the predefined library with appropriate care. + + Error_Msg_Warn := GNAT_Mode; + Error_Msg_N + (" False); + + elsif Elaboration_Checks_Suppressed (Current_Scope) then + null; + + elsif From_Elab_Code then + Set_C_Scope; + Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); + + elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then + Set_C_Scope; + Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); + + -- If none of those cases holds, but Dynamic_Elaboration_Checks mode + -- is set, then we will do the check, but only in the inter-unit case + -- (this is to accommodate unguarded elaboration calls from other units + -- in which this same mode is set). We don't want warnings in this case, + -- it would generate warnings having nothing to do with elaboration. + + elsif Dynamic_Elaboration_Checks then + Set_C_Scope; + Check_A_Call + (N, + Ent, + Standard_Standard, + Inter_Unit_Only => True, + Generate_Warnings => False); + + -- Otherwise nothing to do + + else + return; + end if; + + -- A call to an Init_Proc in elaboration code may bring additional + -- dependencies, if some of the record components thereof have + -- initializations that are function calls that come from source. We + -- treat the current node as a call to each of these functions, to check + -- their elaboration impact. + + if Is_Init_Proc (Ent) + and then From_Elab_Code + then + Process_Init_Proc : declare + Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent); + + function Check_Init_Call (Nod : Node_Id) return Traverse_Result; + -- Find subprogram calls within body of Init_Proc for Traverse + -- instantiation below. + + procedure Traverse_Body is new Traverse_Proc (Check_Init_Call); + -- Traversal procedure to find all calls with body of Init_Proc + + --------------------- + -- Check_Init_Call -- + --------------------- + + function Check_Init_Call (Nod : Node_Id) return Traverse_Result is + Func : Entity_Id; + + begin + if (Nkind (Nod) = N_Function_Call + or else Nkind (Nod) = N_Procedure_Call_Statement) + and then Is_Entity_Name (Name (Nod)) + then + Func := Entity (Name (Nod)); + + if Comes_From_Source (Func) then + Check_A_Call + (N, Func, Standard_Standard, Inter_Unit_Only => True); + end if; + + return OK; + + else + return OK; + end if; + end Check_Init_Call; + + -- Start of processing for Process_Init_Proc + + begin + if Nkind (Unit_Decl) = N_Subprogram_Body then + Traverse_Body (Handled_Statement_Sequence (Unit_Decl)); + end if; + end Process_Init_Proc; + end if; + end Check_Elab_Call; + + ----------------------- + -- Check_Elab_Assign -- + ----------------------- + + procedure Check_Elab_Assign (N : Node_Id) is + Ent : Entity_Id; + Scop : Entity_Id; + + Pkg_Spec : Entity_Id; + Pkg_Body : Entity_Id; + + begin + -- For record or array component, check prefix. If it is an access type, + -- then there is nothing to do (we do not know what is being assigned), + -- but otherwise this is an assignment to the prefix. + + if Nkind (N) = N_Indexed_Component + or else + Nkind (N) = N_Selected_Component + or else + Nkind (N) = N_Slice + then + if not Is_Access_Type (Etype (Prefix (N))) then + Check_Elab_Assign (Prefix (N)); + end if; + + return; + end if; + + -- For type conversion, check expression + + if Nkind (N) = N_Type_Conversion then + Check_Elab_Assign (Expression (N)); + return; + end if; + + -- Nothing to do if this is not an entity reference otherwise get entity + + if Is_Entity_Name (N) then + Ent := Entity (N); + else + return; + end if; + + -- What we are looking for is a reference in the body of a package that + -- modifies a variable declared in the visible part of the package spec. + + if Present (Ent) + and then Comes_From_Source (N) + and then not Suppress_Elaboration_Warnings (Ent) + and then Ekind (Ent) = E_Variable + and then not In_Private_Part (Ent) + and then Is_Library_Level_Entity (Ent) + then + Scop := Current_Scope; + loop + if No (Scop) or else Scop = Standard_Standard then + return; + elsif Ekind (Scop) = E_Package + and then Is_Compilation_Unit (Scop) + then + exit; + else + Scop := Scope (Scop); + end if; + end loop; + + -- Here Scop points to the containing library package + + Pkg_Spec := Scop; + Pkg_Body := Body_Entity (Pkg_Spec); + + -- All OK if the package has an Elaborate_Body pragma + + if Has_Pragma_Elaborate_Body (Scop) then + return; + end if; + + -- OK if entity being modified is not in containing package spec + + if not In_Same_Source_Unit (Scop, Ent) then + return; + end if; + + -- All OK if entity appears in generic package or generic instance. + -- We just get too messed up trying to give proper warnings in the + -- presence of generics. Better no message than a junk one. + + Scop := Scope (Ent); + while Present (Scop) and then Scop /= Pkg_Spec loop + if Ekind (Scop) = E_Generic_Package then + return; + elsif Ekind (Scop) = E_Package + and then Is_Generic_Instance (Scop) + then + return; + end if; + + Scop := Scope (Scop); + end loop; + + -- All OK if in task, don't issue warnings there + + if In_Task_Activation then + return; + end if; + + -- OK if no package body + + if No (Pkg_Body) then + return; + end if; + + -- OK if reference is not in package body + + if not In_Same_Source_Unit (Pkg_Body, N) then + return; + end if; + + -- OK if package body has no handled statement sequence + + declare + HSS : constant Node_Id := + Handled_Statement_Sequence (Declaration_Node (Pkg_Body)); + begin + if No (HSS) or else not Comes_From_Source (HSS) then + return; + end if; + end; + + -- We definitely have a case of a modification of an entity in + -- the package spec from the elaboration code of the package body. + -- We may not give the warning (because there are some additional + -- checks to avoid too many false positives), but it would be a good + -- idea for the binder to try to keep the body elaboration close to + -- the spec elaboration. + + Set_Elaborate_Body_Desirable (Pkg_Spec); + + -- All OK in gnat mode (we know what we are doing) + + if GNAT_Mode then + return; + end if; + + -- All OK if all warnings suppressed + + if Warning_Mode = Suppress then + return; + end if; + + -- All OK if elaboration checks suppressed for entity + + if Checks_May_Be_Suppressed (Ent) + and then Is_Check_Suppressed (Ent, Elaboration_Check) + then + return; + end if; + + -- OK if the entity is initialized. Note that the No_Initialization + -- flag usually means that the initialization has been rewritten into + -- assignments, but that still counts for us. + + declare + Decl : constant Node_Id := Declaration_Node (Ent); + begin + if Nkind (Decl) = N_Object_Declaration + and then (Present (Expression (Decl)) + or else No_Initialization (Decl)) + then + return; + end if; + end; + + -- Here is where we give the warning + + -- All OK if warnings suppressed on the entity + + if not Has_Warnings_Off (Ent) then + Error_Msg_Sloc := Sloc (Ent); + + Error_Msg_NE + ("?elaboration code may access& before it is initialized", + N, Ent); + Error_Msg_NE + ("\?suggest adding pragma Elaborate_Body to spec of &", + N, Scop); + Error_Msg_N + ("\?or an explicit initialization could be added #", N); + end if; + + if not All_Errors_Mode then + Set_Suppress_Elaboration_Warnings (Ent); + end if; + end if; + end Check_Elab_Assign; + + ---------------------- + -- Check_Elab_Calls -- + ---------------------- + + procedure Check_Elab_Calls is + begin + -- If expansion is disabled, do not generate any checks. Also skip + -- checks if any subunits are missing because in either case we lack the + -- full information that we need, and no object file will be created in + -- any case. + + if not Expander_Active + or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) + or else Subunits_Missing + then + return; + end if; + + -- Skip delayed calls if we had any errors + + if Serious_Errors_Detected = 0 then + Delaying_Elab_Checks := False; + Expander_Mode_Save_And_Set (True); + + for J in Delay_Check.First .. Delay_Check.Last loop + Push_Scope (Delay_Check.Table (J).Curscop); + From_Elab_Code := Delay_Check.Table (J).From_Elab_Code; + + Check_Internal_Call_Continue ( + N => Delay_Check.Table (J).N, + E => Delay_Check.Table (J).E, + Outer_Scope => Delay_Check.Table (J).Outer_Scope, + Orig_Ent => Delay_Check.Table (J).Orig_Ent); + + Pop_Scope; + end loop; + + -- Set Delaying_Elab_Checks back on for next main compilation + + Expander_Mode_Restore; + Delaying_Elab_Checks := True; + end if; + end Check_Elab_Calls; + + ------------------------------ + -- Check_Elab_Instantiation -- + ------------------------------ + + procedure Check_Elab_Instantiation + (N : Node_Id; + Outer_Scope : Entity_Id := Empty) + is + Ent : Entity_Id; + + begin + -- Check for and deal with bad instantiation case. There is some + -- duplicated code here, but we will worry about this later ??? + + Check_Bad_Instantiation (N); + + if ABE_Is_Certain (N) then + return; + end if; + + -- Nothing to do if we do not have an instantiation (happens in some + -- error cases, and also in the formal package declaration case) + + if Nkind (N) not in N_Generic_Instantiation then + return; + end if; + + -- Nothing to do if inside a generic template + + if Inside_A_Generic then + return; + end if; + + -- Nothing to do if the instantiation is not in the main unit + + if not In_Extended_Main_Code_Unit (N) then + return; + end if; + + Ent := Get_Generic_Entity (N); + From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; + + -- See if we need to analyze this instantiation. We analyze it if + -- either of the following conditions is met: + + -- It is an inner level instantiation (since in this case it was + -- triggered by an outer level call from elaboration code), but + -- only if the instantiation is within the scope of the original + -- outer level call. + + -- It is an outer level instantiation from elaboration code, or the + -- instantiated entity is in the same elaboration scope. + + -- And in these cases, we will check both the inter-unit case and + -- the intra-unit (within a single unit) case. + + C_Scope := Current_Scope; + + if Present (Outer_Scope) + and then Within (Scope (Ent), Outer_Scope) + then + Set_C_Scope; + Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False); + + elsif From_Elab_Code then + Set_C_Scope; + Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); + + elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then + Set_C_Scope; + Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); + + -- If none of those cases holds, but Dynamic_Elaboration_Checks mode is + -- set, then we will do the check, but only in the inter-unit case (this + -- is to accommodate unguarded elaboration calls from other units in + -- which this same mode is set). We inhibit warnings in this case, since + -- this instantiation is not occurring in elaboration code. + + elsif Dynamic_Elaboration_Checks then + Set_C_Scope; + Check_A_Call + (N, + Ent, + Standard_Standard, + Inter_Unit_Only => True, + Generate_Warnings => False); + + else + return; + end if; + end Check_Elab_Instantiation; + + ------------------------- + -- Check_Internal_Call -- + ------------------------- + + procedure Check_Internal_Call + (N : Node_Id; + E : Entity_Id; + Outer_Scope : Entity_Id; + Orig_Ent : Entity_Id) + is + Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; + + begin + -- If not function or procedure call or instantiation, then ignore + -- call (this happens in some error case and rewriting cases) + + if Nkind (N) /= N_Function_Call + and then + Nkind (N) /= N_Procedure_Call_Statement + and then + not Inst_Case + then + return; + + -- Nothing to do if this is a call or instantiation that has + -- already been found to be a sure ABE + + elsif ABE_Is_Certain (N) then + return; + + -- Nothing to do if errors already detected (avoid cascaded errors) + + elsif Serious_Errors_Detected /= 0 then + return; + + -- Nothing to do if not in full analysis mode + + elsif not Full_Analysis then + return; + + -- Nothing to do if analyzing in special spec-expression mode, since the + -- call is not actually being made at this time. + + elsif In_Spec_Expression then + return; + + -- Nothing to do for call to intrinsic subprogram + + elsif Is_Intrinsic_Subprogram (E) then + return; + + -- No need to trace local calls if checking task activation, because + -- other local bodies are elaborated already. + + elsif In_Task_Activation then + return; + + -- Nothing to do if call is within a generic unit + + elsif Inside_A_Generic then + return; + end if; + + -- Delay this call if we are still delaying calls + + if Delaying_Elab_Checks then + Delay_Check.Append ( + (N => N, + E => E, + Orig_Ent => Orig_Ent, + Curscop => Current_Scope, + Outer_Scope => Outer_Scope, + From_Elab_Code => From_Elab_Code)); + return; + + -- Otherwise, call phase 2 continuation right now + + else + Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent); + end if; + end Check_Internal_Call; + + ---------------------------------- + -- Check_Internal_Call_Continue -- + ---------------------------------- + + procedure Check_Internal_Call_Continue + (N : Node_Id; + E : Entity_Id; + Outer_Scope : Entity_Id; + Orig_Ent : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Inst_Case : constant Boolean := Is_Generic_Unit (E); + + Sbody : Node_Id; + Ebody : Entity_Id; + + function Find_Elab_Reference (N : Node_Id) return Traverse_Result; + -- Function applied to each node as we traverse the body. Checks for + -- call or entity reference that needs checking, and if so checks it. + -- Always returns OK, so entire tree is traversed, except that as + -- described below subprogram bodies are skipped for now. + + procedure Traverse is new Atree.Traverse_Proc (Find_Elab_Reference); + -- Traverse procedure using above Find_Elab_Reference function + + ------------------------- + -- Find_Elab_Reference -- + ------------------------- + + function Find_Elab_Reference (N : Node_Id) return Traverse_Result is + Actual : Node_Id; + + begin + -- If user has specified that there are no entry calls in elaboration + -- code, do not trace past an accept statement, because the rendez- + -- vous will happen after elaboration. + + if (Nkind (Original_Node (N)) = N_Accept_Statement + or else Nkind (Original_Node (N)) = N_Selective_Accept) + and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code) + then + return Abandon; + + -- If we have a function call, check it + + elsif Nkind (N) = N_Function_Call then + Check_Elab_Call (N, Outer_Scope); + return OK; + + -- If we have a procedure call, check the call, and also check + -- arguments that are assignments (OUT or IN OUT mode formals). + + elsif Nkind (N) = N_Procedure_Call_Statement then + Check_Elab_Call (N, Outer_Scope); + + Actual := First_Actual (N); + while Present (Actual) loop + if Known_To_Be_Assigned (Actual) then + Check_Elab_Assign (Actual); + end if; + + Next_Actual (Actual); + end loop; + + return OK; + + -- If we have a generic instantiation, check it + + elsif Nkind (N) in N_Generic_Instantiation then + Check_Elab_Instantiation (N, Outer_Scope); + return OK; + + -- Skip subprogram bodies that come from source (wait for call to + -- analyze these). The reason for the come from source test is to + -- avoid catching task bodies. + + -- For task bodies, we should really avoid these too, waiting for the + -- task activation, but that's too much trouble to catch for now, so + -- we go in unconditionally. This is not so terrible, it means the + -- error backtrace is not quite complete, and we are too eager to + -- scan bodies of tasks that are unused, but this is hardly very + -- significant! + + elsif Nkind (N) = N_Subprogram_Body + and then Comes_From_Source (N) + then + return Skip; + + elsif Nkind (N) = N_Assignment_Statement + and then Comes_From_Source (N) + then + Check_Elab_Assign (Name (N)); + return OK; + + else + return OK; + end if; + end Find_Elab_Reference; + + -- Start of processing for Check_Internal_Call_Continue + + begin + -- Save outer level call if at outer level + + if Elab_Call.Last = 0 then + Outer_Level_Sloc := Loc; + end if; + + Elab_Visited.Append (E); + + -- If the call is to a function that renames a literal, no check + -- is needed. + + if Ekind (E) = E_Enumeration_Literal then + return; + end if; + + Sbody := Unit_Declaration_Node (E); + + if Nkind (Sbody) /= N_Subprogram_Body + and then + Nkind (Sbody) /= N_Package_Body + then + Ebody := Corresponding_Body (Sbody); + + if No (Ebody) then + return; + else + Sbody := Unit_Declaration_Node (Ebody); + end if; + end if; + + -- If the body appears after the outer level call or instantiation then + -- we have an error case handled below. + + if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody)) + and then not In_Task_Activation + then + null; + + -- If we have the instantiation case we are done, since we now + -- know that the body of the generic appeared earlier. + + elsif Inst_Case then + return; + + -- Otherwise we have a call, so we trace through the called body to see + -- if it has any problems. + + else + pragma Assert (Nkind (Sbody) = N_Subprogram_Body); + + Elab_Call.Append ((Cloc => Loc, Ent => E)); + + if Debug_Flag_LL then + Write_Str ("Elab_Call.Last = "); + Write_Int (Int (Elab_Call.Last)); + Write_Str (" Ent = "); + Write_Name (Chars (E)); + Write_Str (" at "); + Write_Location (Sloc (N)); + Write_Eol; + end if; + + -- Now traverse declarations and statements of subprogram body. Note + -- that we cannot simply Traverse (Sbody), since traverse does not + -- normally visit subprogram bodies. + + declare + Decl : Node_Id; + begin + Decl := First (Declarations (Sbody)); + while Present (Decl) loop + Traverse (Decl); + Next (Decl); + end loop; + end; + + Traverse (Handled_Statement_Sequence (Sbody)); + + Elab_Call.Decrement_Last; + return; + end if; + + -- Here is the case of calling a subprogram where the body has not yet + -- been encountered, a warning message is needed. + + -- If we have nothing in the call stack, then this is at the outer + -- level, and the ABE is bound to occur. + + if Elab_Call.Last = 0 then + if Inst_Case then + Error_Msg_NE + ("?cannot instantiate& before body seen", N, Orig_Ent); + else + Error_Msg_NE + ("?cannot call& before body seen", N, Orig_Ent); + end if; + + Error_Msg_N + ("\?Program_Error will be raised at run time", N); + Insert_Elab_Check (N); + + -- Call is not at outer level + + else + -- Deal with dynamic elaboration check + + if not Elaboration_Checks_Suppressed (E) then + Set_Elaboration_Entity_Required (E); + + -- Case of no elaboration entity allocated yet + + if No (Elaboration_Entity (E)) then + + -- Create object declaration for elaboration entity, and put it + -- just in front of the spec of the subprogram or generic unit, + -- in the same scope as this unit. + + declare + Loce : constant Source_Ptr := Sloc (E); + Ent : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (E), 'E')); + + begin + Set_Elaboration_Entity (E, Ent); + Push_Scope (Scope (E)); + + Insert_Action (Declaration_Node (E), + Make_Object_Declaration (Loce, + Defining_Identifier => Ent, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loce), + Expression => New_Occurrence_Of (Standard_False, Loce))); + + -- Set elaboration flag at the point of the body + + Set_Elaboration_Flag (Sbody, E); + + -- Kill current value indication. This is necessary because + -- the tests of this flag are inserted out of sequence and + -- must not pick up bogus indications of the wrong constant + -- value. Also, this is never a true constant, since one way + -- or another, it gets reset. + + Set_Current_Value (Ent, Empty); + Set_Last_Assignment (Ent, Empty); + Set_Is_True_Constant (Ent, False); + Pop_Scope; + end; + end if; + + -- Generate check of the elaboration Boolean + + Insert_Elab_Check (N, + New_Occurrence_Of (Elaboration_Entity (E), Loc)); + end if; + + -- Generate the warning + + if not Suppress_Elaboration_Warnings (E) + and then not Elaboration_Checks_Suppressed (E) + then + if Inst_Case then + Error_Msg_NE + ("instantiation of& may occur before body is seen?", + N, Orig_Ent); + else + Error_Msg_NE + ("call to& may occur before body is seen?", N, Orig_Ent); + end if; + + Error_Msg_N + ("\Program_Error may be raised at run time?", N); + + Output_Calls (N); + end if; + end if; + + -- Set flag to suppress further warnings on same subprogram + -- unless in all errors mode + + if not All_Errors_Mode then + Set_Suppress_Elaboration_Warnings (E); + end if; + end Check_Internal_Call_Continue; + + --------------------------- + -- Check_Task_Activation -- + --------------------------- + + procedure Check_Task_Activation (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Inter_Procs : constant Elist_Id := New_Elmt_List; + Intra_Procs : constant Elist_Id := New_Elmt_List; + Ent : Entity_Id; + P : Entity_Id; + Task_Scope : Entity_Id; + Cunit_SC : Boolean := False; + Decl : Node_Id; + Elmt : Elmt_Id; + Enclosing : Entity_Id; + + procedure Add_Task_Proc (Typ : Entity_Id); + -- Add to Task_Procs the task body procedure(s) of task types in Typ. + -- For record types, this procedure recurses over component types. + + procedure Collect_Tasks (Decls : List_Id); + -- Collect the types of the tasks that are to be activated in the given + -- list of declarations, in order to perform elaboration checks on the + -- corresponding task procedures which are called implicitly here. + + function Outer_Unit (E : Entity_Id) return Entity_Id; + -- find enclosing compilation unit of Entity, ignoring subunits, or + -- else enclosing subprogram. If E is not a package, there is no need + -- for inter-unit elaboration checks. + + ------------------- + -- Add_Task_Proc -- + ------------------- + + procedure Add_Task_Proc (Typ : Entity_Id) is + Comp : Entity_Id; + Proc : Entity_Id := Empty; + + begin + if Is_Task_Type (Typ) then + Proc := Get_Task_Body_Procedure (Typ); + + elsif Is_Array_Type (Typ) + and then Has_Task (Base_Type (Typ)) + then + Add_Task_Proc (Component_Type (Typ)); + + elsif Is_Record_Type (Typ) + and then Has_Task (Base_Type (Typ)) + then + Comp := First_Component (Typ); + while Present (Comp) loop + Add_Task_Proc (Etype (Comp)); + Comp := Next_Component (Comp); + end loop; + end if; + + -- If the task type is another unit, we will perform the usual + -- elaboration check on its enclosing unit. If the type is in the + -- same unit, we can trace the task body as for an internal call, + -- but we only need to examine other external calls, because at + -- the point the task is activated, internal subprogram bodies + -- will have been elaborated already. We keep separate lists for + -- each kind of task. + + -- Skip this test if errors have occurred, since in this case + -- we can get false indications. + + if Serious_Errors_Detected /= 0 then + return; + end if; + + if Present (Proc) then + if Outer_Unit (Scope (Proc)) = Enclosing then + + if No (Corresponding_Body (Unit_Declaration_Node (Proc))) + and then + (not Is_Generic_Instance (Scope (Proc)) + or else + Scope (Proc) = Scope (Defining_Identifier (Decl))) + then + Error_Msg_N + ("task will be activated before elaboration of its body?", + Decl); + Error_Msg_N + ("\Program_Error will be raised at run time?", Decl); + + elsif + Present (Corresponding_Body (Unit_Declaration_Node (Proc))) + then + Append_Elmt (Proc, Intra_Procs); + end if; + + else + -- No need for multiple entries of the same type + + Elmt := First_Elmt (Inter_Procs); + while Present (Elmt) loop + if Node (Elmt) = Proc then + return; + end if; + + Next_Elmt (Elmt); + end loop; + + Append_Elmt (Proc, Inter_Procs); + end if; + end if; + end Add_Task_Proc; + + ------------------- + -- Collect_Tasks -- + ------------------- + + procedure Collect_Tasks (Decls : List_Id) is + begin + if Present (Decls) then + Decl := First (Decls); + while Present (Decl) loop + if Nkind (Decl) = N_Object_Declaration + and then Has_Task (Etype (Defining_Identifier (Decl))) + then + Add_Task_Proc (Etype (Defining_Identifier (Decl))); + end if; + + Next (Decl); + end loop; + end if; + end Collect_Tasks; + + ---------------- + -- Outer_Unit -- + ---------------- + + function Outer_Unit (E : Entity_Id) return Entity_Id is + Outer : Entity_Id; + + begin + Outer := E; + while Present (Outer) loop + if Elaboration_Checks_Suppressed (Outer) then + Cunit_SC := True; + end if; + + exit when Is_Child_Unit (Outer) + or else Scope (Outer) = Standard_Standard + or else Ekind (Outer) /= E_Package; + Outer := Scope (Outer); + end loop; + + return Outer; + end Outer_Unit; + + -- Start of processing for Check_Task_Activation + + begin + Enclosing := Outer_Unit (Current_Scope); + + -- Find all tasks declared in the current unit + + if Nkind (N) = N_Package_Body then + P := Unit_Declaration_Node (Corresponding_Spec (N)); + + Collect_Tasks (Declarations (N)); + Collect_Tasks (Visible_Declarations (Specification (P))); + Collect_Tasks (Private_Declarations (Specification (P))); + + elsif Nkind (N) = N_Package_Declaration then + Collect_Tasks (Visible_Declarations (Specification (N))); + Collect_Tasks (Private_Declarations (Specification (N))); + + else + Collect_Tasks (Declarations (N)); + end if; + + -- We only perform detailed checks in all tasks are library level + -- entities. If the master is a subprogram or task, activation will + -- depend on the activation of the master itself. + + -- Should dynamic checks be added in the more general case??? + + if Ekind (Enclosing) /= E_Package then + return; + end if; + + -- For task types defined in other units, we want the unit containing + -- the task body to be elaborated before the current one. + + Elmt := First_Elmt (Inter_Procs); + while Present (Elmt) loop + Ent := Node (Elmt); + Task_Scope := Outer_Unit (Scope (Ent)); + + if not Is_Compilation_Unit (Task_Scope) then + null; + + elsif Suppress_Elaboration_Warnings (Task_Scope) + or else Elaboration_Checks_Suppressed (Task_Scope) + then + null; + + elsif Dynamic_Elaboration_Checks then + if not Elaboration_Checks_Suppressed (Ent) + and then not Cunit_SC + and then + not Restriction_Active (No_Entry_Calls_In_Elaboration_Code) + then + -- Runtime elaboration check required. Generate check of the + -- elaboration Boolean for the unit containing the entity. + + Insert_Elab_Check (N, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Elaborated, + Prefix => + New_Occurrence_Of (Spec_Entity (Task_Scope), Loc))); + end if; + + else + -- Force the binder to elaborate other unit first + + if not Suppress_Elaboration_Warnings (Ent) + and then not Elaboration_Checks_Suppressed (Ent) + and then Elab_Warnings + and then not Suppress_Elaboration_Warnings (Task_Scope) + and then not Elaboration_Checks_Suppressed (Task_Scope) + then + Error_Msg_Node_2 := Task_Scope; + Error_Msg_NE + ("activation of an instance of task type&" & + " requires pragma Elaborate_All on &?", N, Ent); + end if; + + Activate_Elaborate_All_Desirable (N, Task_Scope); + Set_Suppress_Elaboration_Warnings (Task_Scope); + end if; + + Next_Elmt (Elmt); + end loop; + + -- For tasks declared in the current unit, trace other calls within + -- the task procedure bodies, which are available. + + In_Task_Activation := True; + + Elmt := First_Elmt (Intra_Procs); + while Present (Elmt) loop + Ent := Node (Elmt); + Check_Internal_Call_Continue (N, Ent, Enclosing, Ent); + Next_Elmt (Elmt); + end loop; + + In_Task_Activation := False; + end Check_Task_Activation; + + -------------------------------- + -- Set_Elaboration_Constraint -- + -------------------------------- + + procedure Set_Elaboration_Constraint + (Call : Node_Id; + Subp : Entity_Id; + Scop : Entity_Id) + is + Elab_Unit : Entity_Id; + Init_Call : constant Boolean := + Chars (Subp) = Name_Initialize + and then Comes_From_Source (Subp) + and then Present (Parameter_Associations (Call)) + and then Is_Controlled (Etype (First_Actual (Call))); + begin + -- If the unit is mentioned in a with_clause of the current unit, it is + -- visible, and we can set the elaboration flag. + + if Is_Immediately_Visible (Scop) + or else (Is_Child_Unit (Scop) and then Is_Visible_Child_Unit (Scop)) + then + Activate_Elaborate_All_Desirable (Call, Scop); + Set_Suppress_Elaboration_Warnings (Scop, True); + return; + end if; + + -- If this is not an initialization call or a call using object notation + -- we know that the unit of the called entity is in the context, and + -- we can set the flag as well. The unit need not be visible if the call + -- occurs within an instantiation. + + if Is_Init_Proc (Subp) + or else Init_Call + or else Nkind (Original_Node (Call)) = N_Selected_Component + then + null; -- detailed processing follows. + + else + Activate_Elaborate_All_Desirable (Call, Scop); + Set_Suppress_Elaboration_Warnings (Scop, True); + return; + end if; + + -- If the unit is not in the context, there must be an intermediate unit + -- that is, on which we need to place to elaboration flag. This happens + -- with init proc calls. + + if Is_Init_Proc (Subp) + or else Init_Call + then + -- The initialization call is on an object whose type is not declared + -- in the same scope as the subprogram. The type of the object must + -- be a subtype of the type of operation. This object is the first + -- actual in the call. + + declare + Typ : constant Entity_Id := + Etype (First (Parameter_Associations (Call))); + begin + Elab_Unit := Scope (Typ); + while (Present (Elab_Unit)) + and then not Is_Compilation_Unit (Elab_Unit) + loop + Elab_Unit := Scope (Elab_Unit); + end loop; + end; + + -- If original node uses selected component notation, the prefix is + -- visible and determines the scope that must be elaborated. After + -- rewriting, the prefix is the first actual in the call. + + elsif Nkind (Original_Node (Call)) = N_Selected_Component then + Elab_Unit := Scope (Etype (First (Parameter_Associations (Call)))); + + -- Not one of special cases above + + else + -- Using previously computed scope. If the elaboration check is + -- done after analysis, the scope is not visible any longer, but + -- must still be in the context. + + Elab_Unit := Scop; + end if; + + Activate_Elaborate_All_Desirable (Call, Elab_Unit); + Set_Suppress_Elaboration_Warnings (Elab_Unit, True); + end Set_Elaboration_Constraint; + + ---------------------- + -- Has_Generic_Body -- + ---------------------- + + function Has_Generic_Body (N : Node_Id) return Boolean is + Ent : constant Entity_Id := Get_Generic_Entity (N); + Decl : constant Node_Id := Unit_Declaration_Node (Ent); + Scop : Entity_Id; + + function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id; + -- Determine if the list of nodes headed by N and linked by Next + -- contains a package body for the package spec entity E, and if so + -- return the package body. If not, then returns Empty. + + function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id; + -- This procedure is called load the unit whose name is given by Nam. + -- This unit is being loaded to see whether it contains an optional + -- generic body. The returned value is the loaded unit, which is always + -- a package body (only package bodies can contain other entities in the + -- sense in which Has_Generic_Body is interested). We only attempt to + -- load bodies if we are generating code. If we are in semantics check + -- only mode, then it would be wrong to load bodies that are not + -- required from a semantic point of view, so in this case we return + -- Empty. The result is that the caller may incorrectly decide that a + -- generic spec does not have a body when in fact it does, but the only + -- harm in this is that some warnings on elaboration problems may be + -- lost in semantic checks only mode, which is not big loss. We also + -- return Empty if we go for a body and it is not there. + + function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id; + -- PE is the entity for a package spec. This function locates the + -- corresponding package body, returning Empty if none is found. The + -- package body returned is fully parsed but may not yet be analyzed, + -- so only syntactic fields should be referenced. + + ------------------ + -- Find_Body_In -- + ------------------ + + function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id is + Nod : Node_Id; + + begin + Nod := N; + while Present (Nod) loop + + -- If we found the package body we are looking for, return it + + if Nkind (Nod) = N_Package_Body + and then Chars (Defining_Unit_Name (Nod)) = Chars (E) + then + return Nod; + + -- If we found the stub for the body, go after the subunit, + -- loading it if necessary. + + elsif Nkind (Nod) = N_Package_Body_Stub + and then Chars (Defining_Identifier (Nod)) = Chars (E) + then + if Present (Library_Unit (Nod)) then + return Unit (Library_Unit (Nod)); + + else + return Load_Package_Body (Get_Unit_Name (Nod)); + end if; + + -- If neither package body nor stub, keep looking on chain + + else + Next (Nod); + end if; + end loop; + + return Empty; + end Find_Body_In; + + ----------------------- + -- Load_Package_Body -- + ----------------------- + + function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id is + U : Unit_Number_Type; + + begin + if Operating_Mode /= Generate_Code then + return Empty; + else + U := + Load_Unit + (Load_Name => Nam, + Required => False, + Subunit => False, + Error_Node => N); + + if U = No_Unit then + return Empty; + else + return Unit (Cunit (U)); + end if; + end if; + end Load_Package_Body; + + ------------------------------- + -- Locate_Corresponding_Body -- + ------------------------------- + + function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id is + Spec : constant Node_Id := Declaration_Node (PE); + Decl : constant Node_Id := Parent (Spec); + Scop : constant Entity_Id := Scope (PE); + PBody : Node_Id; + + begin + if Is_Library_Level_Entity (PE) then + + -- If package is a library unit that requires a body, we have no + -- choice but to go after that body because it might contain an + -- optional body for the original generic package. + + if Unit_Requires_Body (PE) then + + -- Load the body. Note that we are a little careful here to use + -- Spec to get the unit number, rather than PE or Decl, since + -- in the case where the package is itself a library level + -- instantiation, Spec will properly reference the generic + -- template, which is what we really want. + + return + Load_Package_Body + (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec)))); + + -- But if the package is a library unit that does NOT require + -- a body, then no body is permitted, so we are sure that there + -- is no body for the original generic package. + + else + return Empty; + end if; + + -- Otherwise look and see if we are embedded in a further package + + elsif Is_Package_Or_Generic_Package (Scop) then + + -- If so, get the body of the enclosing package, and look in + -- its package body for the package body we are looking for. + + PBody := Locate_Corresponding_Body (Scop); + + if No (PBody) then + return Empty; + else + return Find_Body_In (PE, First (Declarations (PBody))); + end if; + + -- If we are not embedded in a further package, then the body + -- must be in the same declarative part as we are. + + else + return Find_Body_In (PE, Next (Decl)); + end if; + end Locate_Corresponding_Body; + + -- Start of processing for Has_Generic_Body + + begin + if Present (Corresponding_Body (Decl)) then + return True; + + elsif Unit_Requires_Body (Ent) then + return True; + + -- Compilation units cannot have optional bodies + + elsif Is_Compilation_Unit (Ent) then + return False; + + -- Otherwise look at what scope we are in + + else + Scop := Scope (Ent); + + -- Case of entity is in other than a package spec, in this case + -- the body, if present, must be in the same declarative part. + + if not Is_Package_Or_Generic_Package (Scop) then + declare + P : Node_Id; + + begin + -- Declaration node may get us a spec, so if so, go to + -- the parent declaration. + + P := Declaration_Node (Ent); + while not Is_List_Member (P) loop + P := Parent (P); + end loop; + + return Present (Find_Body_In (Ent, Next (P))); + end; + + -- If the entity is in a package spec, then we have to locate + -- the corresponding package body, and look there. + + else + declare + PBody : constant Node_Id := Locate_Corresponding_Body (Scop); + + begin + if No (PBody) then + return False; + else + return + Present + (Find_Body_In (Ent, (First (Declarations (PBody))))); + end if; + end; + end if; + end if; + end Has_Generic_Body; + + ----------------------- + -- Insert_Elab_Check -- + ----------------------- + + procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty) is + Nod : Node_Id; + Loc : constant Source_Ptr := Sloc (N); + + begin + -- If expansion is disabled, do not generate any checks. Also + -- skip checks if any subunits are missing because in either + -- case we lack the full information that we need, and no object + -- file will be created in any case. + + if not Expander_Active or else Subunits_Missing then + return; + end if; + + -- If we have a generic instantiation, where Instance_Spec is set, + -- then this field points to a generic instance spec that has + -- been inserted before the instantiation node itself, so that + -- is where we want to insert a check. + + if Nkind (N) in N_Generic_Instantiation + and then Present (Instance_Spec (N)) + then + Nod := Instance_Spec (N); + else + Nod := N; + end if; + + -- If we are inserting at the top level, insert in Aux_Decls + + if Nkind (Parent (Nod)) = N_Compilation_Unit then + declare + ADN : constant Node_Id := Aux_Decls_Node (Parent (Nod)); + R : Node_Id; + + begin + if No (C) then + R := + Make_Raise_Program_Error (Loc, + Reason => PE_Access_Before_Elaboration); + else + R := + Make_Raise_Program_Error (Loc, + Condition => Make_Op_Not (Loc, C), + Reason => PE_Access_Before_Elaboration); + end if; + + if No (Declarations (ADN)) then + Set_Declarations (ADN, New_List (R)); + else + Append_To (Declarations (ADN), R); + end if; + + Analyze (R); + end; + + -- Otherwise just insert before the node in question. However, if + -- the context of the call has already been analyzed, an insertion + -- will not work if it depends on subsequent expansion (e.g. a call in + -- a branch of a short-circuit). In that case we replace the call with + -- a conditional expression, or with a Raise if it is unconditional. + -- Unfortunately this does not work if the call has a dynamic size, + -- because gigi regards it as a dynamic-sized temporary. If such a call + -- appears in a short-circuit expression, the elaboration check will be + -- missed (rare enough ???). Otherwise, the code below inserts the check + -- at the appropriate place before the call. Same applies in the even + -- rarer case the return type has a known size but is unconstrained. + + else + if Nkind (N) = N_Function_Call + and then Analyzed (Parent (N)) + and then Size_Known_At_Compile_Time (Etype (N)) + and then + (not Has_Discriminants (Etype (N)) + or else Is_Constrained (Etype (N))) + + then + declare + Typ : constant Entity_Id := Etype (N); + Chk : constant Boolean := Do_Range_Check (N); + + R : constant Node_Id := + Make_Raise_Program_Error (Loc, + Reason => PE_Access_Before_Elaboration); + + Reloc_N : Node_Id; + + begin + Set_Etype (R, Typ); + + if No (C) then + Rewrite (N, R); + + else + Reloc_N := Relocate_Node (N); + Save_Interps (N, Reloc_N); + Rewrite (N, + Make_Conditional_Expression (Loc, + Expressions => New_List (C, Reloc_N, R))); + end if; + + Analyze_And_Resolve (N, Typ); + + -- If the original call requires a range check, so does the + -- conditional expression. + + if Chk then + Enable_Range_Check (N); + else + Set_Do_Range_Check (N, False); + end if; + end; + + else + if No (C) then + Insert_Action (Nod, + Make_Raise_Program_Error (Loc, + Reason => PE_Access_Before_Elaboration)); + else + Insert_Action (Nod, + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => C), + Reason => PE_Access_Before_Elaboration)); + end if; + end if; + end if; + end Insert_Elab_Check; + + ------------------ + -- Output_Calls -- + ------------------ + + procedure Output_Calls (N : Node_Id) is + Ent : Entity_Id; + + function Is_Printable_Error_Name (Nm : Name_Id) return Boolean; + -- An internal function, used to determine if a name, Nm, is either + -- a non-internal name, or is an internal name that is printable + -- by the error message circuits (i.e. it has a single upper + -- case letter at the end). + + function Is_Printable_Error_Name (Nm : Name_Id) return Boolean is + begin + if not Is_Internal_Name (Nm) then + return True; + + elsif Name_Len = 1 then + return False; + + else + Name_Len := Name_Len - 1; + return not Is_Internal_Name; + end if; + end Is_Printable_Error_Name; + + -- Start of processing for Output_Calls + + begin + for J in reverse 1 .. Elab_Call.Last loop + Error_Msg_Sloc := Elab_Call.Table (J).Cloc; + + Ent := Elab_Call.Table (J).Ent; + + if Is_Generic_Unit (Ent) then + Error_Msg_NE ("\?& instantiated #", N, Ent); + + elsif Is_Init_Proc (Ent) then + Error_Msg_N ("\?initialization procedure called #", N); + + elsif Is_Printable_Error_Name (Chars (Ent)) then + Error_Msg_NE ("\?& called #", N, Ent); + + else + Error_Msg_N ("\? called #", N); + end if; + end loop; + end Output_Calls; + + ---------------------------- + -- Same_Elaboration_Scope -- + ---------------------------- + + function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is + S1 : Entity_Id; + S2 : Entity_Id; + + begin + -- Find elaboration scope for Scop1 + -- This is either a subprogram or a compilation unit. + + S1 := Scop1; + while S1 /= Standard_Standard + and then not Is_Compilation_Unit (S1) + and then (Ekind (S1) = E_Package + or else + Ekind (S1) = E_Protected_Type + or else + Ekind (S1) = E_Block) + loop + S1 := Scope (S1); + end loop; + + -- Find elaboration scope for Scop2 + + S2 := Scop2; + while S2 /= Standard_Standard + and then not Is_Compilation_Unit (S2) + and then (Ekind (S2) = E_Package + or else + Ekind (S2) = E_Protected_Type + or else + Ekind (S2) = E_Block) + loop + S2 := Scope (S2); + end loop; + + return S1 = S2; + end Same_Elaboration_Scope; + + ----------------- + -- Set_C_Scope -- + ----------------- + + procedure Set_C_Scope is + begin + while not Is_Compilation_Unit (C_Scope) loop + C_Scope := Scope (C_Scope); + end loop; + end Set_C_Scope; + + ----------------- + -- Spec_Entity -- + ----------------- + + function Spec_Entity (E : Entity_Id) return Entity_Id is + Decl : Node_Id; + + begin + -- Check for case of body entity + -- Why is the check for E_Void needed??? + + if Ekind_In (E, E_Void, E_Subprogram_Body, E_Package_Body) then + Decl := E; + + loop + Decl := Parent (Decl); + exit when Nkind (Decl) in N_Proper_Body; + end loop; + + return Corresponding_Spec (Decl); + + else + return E; + end if; + end Spec_Entity; + + ------------------- + -- Supply_Bodies -- + ------------------- + + procedure Supply_Bodies (N : Node_Id) is + begin + if Nkind (N) = N_Subprogram_Declaration then + declare + Ent : constant Entity_Id := Defining_Unit_Name (Specification (N)); + begin + + -- Internal subprograms will already have a generated body, so + -- there is no need to provide a stub for them. + + if No (Corresponding_Body (N)) then + declare + Loc : constant Source_Ptr := Sloc (N); + B : Node_Id; + Formals : constant List_Id := Copy_Parameter_List (Ent); + Nam : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars (Ent)); + Spec : Node_Id; + Stats : constant List_Id := + New_List + (Make_Raise_Program_Error (Loc, + Reason => PE_Access_Before_Elaboration)); + + begin + if Ekind (Ent) = E_Function then + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Nam, + Parameter_Specifications => Formals, + Result_Definition => + New_Copy_Tree + (Result_Definition (Specification (N)))); + + -- We cannot reliably make a return statement for this + -- body, but none is needed because the call raises + -- program error. + + Set_Return_Present (Ent); + + else + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Nam, + Parameter_Specifications => Formals); + end if; + + B := Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stats)); + Insert_After (N, B); + Analyze (B); + end; + end if; + end; + + elsif Nkind (N) = N_Package_Declaration then + declare + Spec : constant Node_Id := Specification (N); + begin + Push_Scope (Defining_Unit_Name (Spec)); + Supply_Bodies (Visible_Declarations (Spec)); + Supply_Bodies (Private_Declarations (Spec)); + Pop_Scope; + end; + end if; + end Supply_Bodies; + + procedure Supply_Bodies (L : List_Id) is + Elmt : Node_Id; + begin + if Present (L) then + Elmt := First (L); + while Present (Elmt) loop + Supply_Bodies (Elmt); + Next (Elmt); + end loop; + end if; + end Supply_Bodies; + + ------------ + -- Within -- + ------------ + + function Within (E1, E2 : Entity_Id) return Boolean is + Scop : Entity_Id; + begin + Scop := E1; + loop + if Scop = E2 then + return True; + elsif Scop = Standard_Standard then + return False; + else + Scop := Scope (Scop); + end if; + end loop; + end Within; + + -------------------------- + -- Within_Elaborate_All -- + -------------------------- + + function Within_Elaborate_All (E : Entity_Id) return Boolean is + Item : Node_Id; + Item2 : Node_Id; + Elab_Id : Entity_Id; + Par : Node_Id; + + begin + Item := First (Context_Items (Cunit (Current_Sem_Unit))); + while Present (Item) loop + if Nkind (Item) = N_Pragma + and then Pragma_Name (Item) = Name_Elaborate_All + then + -- Return if some previous error on the pragma itself + + if Error_Posted (Item) then + return False; + end if; + + Elab_Id := + Entity + (Expression (First (Pragma_Argument_Associations (Item)))); + + Par := Parent (Unit_Declaration_Node (Elab_Id)); + + Item2 := First (Context_Items (Par)); + while Present (Item2) loop + if Nkind (Item2) = N_With_Clause + and then Entity (Name (Item2)) = E + then + return True; + end if; + + Next (Item2); + end loop; + end if; + + Next (Item); + end loop; + + return False; + end Within_Elaborate_All; + +end Sem_Elab; diff --git a/gcc/ada/sem_elab.ads b/gcc/ada/sem_elab.ads new file mode 100644 index 000000000..7b85b6f88 --- /dev/null +++ b/gcc/ada/sem_elab.ads @@ -0,0 +1,159 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ E L A B -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1997-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 to deal with issuing warnings +-- for cases of calls that may require warnings about possible access +-- before elaboration. + +with Types; use Types; + +package Sem_Elab is + + ----------------------------- + -- Description of Approach -- + ----------------------------- + + -- Every non-static call that is encountered by Sem_Res results in + -- a call to Check_Elab_Call, with N being the call node, and Outer + -- set to its default value of True. + + -- The goal of Check_Elab_Call is to determine whether or not the + -- call in question can generate an access before elaboration + -- error (raising Program_Error) either by directly calling a + -- subprogram whose body has not yet been elaborated, or indirectly, + -- by calling a subprogram whose body has been elaborated, but which + -- contains a call to such a subprogram. + + -- The only calls that we need to look at at the outer level are + -- calls that occur in elaboration code. There are two cases. The + -- call can be at the outer level of elaboration code, or it can + -- be within another unit, e.g. the elaboration code of a subprogram. + + -- In the case of an elaboration call at the outer level, we must + -- trace all calls to outer level routines either within the current + -- unit or to other units that are with'ed. For calls within the + -- current unit, we can determine if the body has been elaborated + -- or not, and if it has not, then a warning is generated. + + -- Note that there are two subcases. If the original call directly + -- calls a subprogram whose body has not been elaborated, then we + -- know that an ABE will take place, and we replace the call by + -- a raise of Program_Error. If the call is indirect, then we don't + -- know that the PE will be raised, since the call might be guarded + -- by a conditional. In this case we set Do_Elab_Check on the call + -- so that a dynamic check is generated, and output a warning. + + -- For calls to a subprogram in a with'ed unit, we require that + -- a pragma Elaborate_All or pragma Elaborate be present, or that + -- the referenced unit have a pragma Preelaborate, pragma Pure, or + -- pragma Elaborate_Body. If none of these conditions is met, then + -- a warning is generated that a pragma Elaborate_All may be needed. + + -- For the case of an elaboration call at some inner level, we are + -- interested in tracing only calls to subprograms at the same level, + -- i.e. those that can be called during elaboration. Any calls to + -- outer level routines cannot cause ABE's as a result of the original + -- call (there might be an outer level call to the subprogram from + -- outside that causes the ABE, but that gets analyzed separately). + + -- Note that we never trace calls to inner level subprograms, since + -- these cannot result in ABE's unless there is an elaboration problem + -- at a lower level, which will be separately detected. + + -- Note on pragma Elaborate. The checking here assumes that a pragma + -- Elaborate on a with'ed unit guarantees that subprograms within the + -- unit can be called without causing an ABE. This is not in fact the + -- case since pragma Elaborate does not guarantee the transitive + -- coverage guaranteed by Elaborate_All. However, we leave this issue + -- up to the binder, which has generates warnings if there are possible + -- problems in the use of pragma Elaborate. + + -------------------------------------- + -- Instantiation Elaboration Errors -- + -------------------------------------- + + -- A special case arises when an instantiation appears in a context + -- that is known to be before the body is elaborated, e.g. + + -- generic package x is ... + -- ... + -- package xx is new x; + -- ... + -- package body x is ... + + -- In this situation it is certain that an elaboration error will + -- occur, and an unconditional raise Program_Error statement is + -- inserted before the instantiation, and a warning generated. + + -- The problem is that in this case we have no place to put the + -- body of the instantiation. We can't put it in the normal place, + -- because it is too early, and will cause errors to occur as a + -- result of referencing entities before they are declared. + + -- Our approach in this case is simply to avoid creating the body + -- of the instantiation in such a case. The instantiation spec is + -- modified to include dummy bodies for all subprograms, so that + -- the resulting code does not contain subprogram specs with no + -- corresponding bodies. + + procedure Check_Elab_Call (N : Node_Id; Outer_Scope : Entity_Id := Empty); + -- Check a call for possible elaboration problems. The node N is either + -- an N_Function_Call or N_Procedure_Call_Statement node. The Outer_Scope + -- argument indicates whether this is an outer level call from Sem_Res + -- (Outer_Scope set to Empty), or an internal recursive call (Outer_Scope + -- set to entity of outermost call, see body). + + procedure Check_Elab_Calls; + -- Not all the processing for Check_Elab_Call can be done at the time + -- of calls to Check_Elab_Call. This is because for internal calls, we + -- need to wait to complete the check until all generic bodies have been + -- instantiated. The Check_Elab_Calls procedure cleans up these waiting + -- checks. It is called once after the completion of instantiation. + + procedure Check_Elab_Assign (N : Node_Id); + -- N is either the left side of an assignment, or a procedure argument for + -- a mode OUT or IN OUT formal. This procedure checks for a possible case + -- of access to an entity from elaboration code before the entity has been + -- initialized, and issues appropriate warnings. + + procedure Check_Elab_Instantiation + (N : Node_Id; + Outer_Scope : Entity_Id := Empty); + -- Check an instantiation for possible elaboration problems. N is an + -- instantiation node (N_Package_Instantiation, N_Function_Instantiation, + -- or N_Procedure_Instantiation), and Outer_Scope indicates if this is + -- an outer level call from Sem_Ch12 (Outer_Scope set to Empty), or an + -- internal recursive call (Outer_Scope set to scope of outermost call, + -- see body for further details). The returned value is relevant only + -- for an outer level call, and is set to False if an elaboration error + -- is bound to occur on the instantiation, and True otherwise. This is + -- used by the caller to signal that the body of the instance should + -- not be generated (see detailed description in body). + + procedure Check_Task_Activation (N : Node_Id); + -- at the point at which tasks are activated in a package body, check + -- that the bodies of the tasks are elaborated. + +end Sem_Elab; diff --git a/gcc/ada/sem_elim.adb b/gcc/ada/sem_elim.adb new file mode 100644 index 000000000..9f6374e3b --- /dev/null +++ b/gcc/ada/sem_elim.adb @@ -0,0 +1,997 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ E L I M -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Errout; use Errout; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Opt; use Opt; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Prag; use Sem_Prag; +with Sem_Util; use Sem_Util; +with Sinput; use Sinput; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Table; + +with GNAT.HTable; use GNAT.HTable; + +package body Sem_Elim is + + No_Elimination : Boolean; + -- Set True if no Eliminate pragmas active + + --------------------- + -- Data Structures -- + --------------------- + + -- A single pragma Eliminate is represented by the following record + + type Elim_Data; + type Access_Elim_Data is access Elim_Data; + + type Names is array (Nat range <>) of Name_Id; + -- Type used to represent set of names. Used for names in Unit_Name + -- and also the set of names in Argument_Types. + + type Access_Names is access Names; + + type Elim_Data is record + + Unit_Name : Access_Names; + -- Unit name, broken down into a set of names (e.g. A.B.C is + -- represented as Name_Id values for A, B, C in sequence). + + Entity_Name : Name_Id; + -- Entity name if Entity parameter if present. If no Entity parameter + -- was supplied, then Entity_Node is set to Empty, and the Entity_Name + -- field contains the last identifier name in the Unit_Name. + + Entity_Scope : Access_Names; + -- Static scope of the entity within the compilation unit represented by + -- Unit_Name. + + Entity_Node : Node_Id; + -- Save node of entity argument, for posting error messages. Set + -- to Empty if there is no entity argument. + + Parameter_Types : Access_Names; + -- Set to set of names given for parameter types. If no parameter + -- types argument is present, this argument is set to null. + + Result_Type : Name_Id; + -- Result type name if Result_Types parameter present, No_Name if not + + Source_Location : Name_Id; + -- String describing the source location of subprogram defining name if + -- Source_Location parameter present, No_Name if not + + Hash_Link : Access_Elim_Data; + -- Link for hash table use + + Homonym : Access_Elim_Data; + -- Pointer to next entry with same key + + Prag : Node_Id; + -- Node_Id for Eliminate pragma + + end record; + + ---------------- + -- Hash_Table -- + ---------------- + + -- Setup hash table using the Entity_Name field as the hash key + + subtype Element is Elim_Data; + subtype Elmt_Ptr is Access_Elim_Data; + + subtype Key is Name_Id; + + type Header_Num is range 0 .. 1023; + + Null_Ptr : constant Elmt_Ptr := null; + + ---------------------- + -- Hash_Subprograms -- + ---------------------- + + package Hash_Subprograms is + + function Equal (F1, F2 : Key) return Boolean; + pragma Inline (Equal); + + function Get_Key (E : Elmt_Ptr) return Key; + pragma Inline (Get_Key); + + function Hash (F : Key) return Header_Num; + pragma Inline (Hash); + + function Next (E : Elmt_Ptr) return Elmt_Ptr; + pragma Inline (Next); + + procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); + pragma Inline (Set_Next); + + end Hash_Subprograms; + + package body Hash_Subprograms is + + ----------- + -- Equal -- + ----------- + + function Equal (F1, F2 : Key) return Boolean is + begin + return F1 = F2; + end Equal; + + ------------- + -- Get_Key -- + ------------- + + function Get_Key (E : Elmt_Ptr) return Key is + begin + return E.Entity_Name; + end Get_Key; + + ---------- + -- Hash -- + ---------- + + function Hash (F : Key) return Header_Num is + begin + return Header_Num (Int (F) mod 1024); + end Hash; + + ---------- + -- Next -- + ---------- + + function Next (E : Elmt_Ptr) return Elmt_Ptr is + begin + return E.Hash_Link; + end Next; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is + begin + E.Hash_Link := Next; + end Set_Next; + end Hash_Subprograms; + + ------------ + -- Tables -- + ------------ + + -- The following table records the data for each pragmas, using the + -- entity name as the hash key for retrieval. Entries in this table + -- are set by Process_Eliminate_Pragma and read by Check_Eliminated. + + package Elim_Hash_Table is new Static_HTable ( + Header_Num => Header_Num, + Element => Element, + Elmt_Ptr => Elmt_Ptr, + Null_Ptr => Null_Ptr, + Set_Next => Hash_Subprograms.Set_Next, + Next => Hash_Subprograms.Next, + Key => Key, + Get_Key => Hash_Subprograms.Get_Key, + Hash => Hash_Subprograms.Hash, + Equal => Hash_Subprograms.Equal); + + -- The following table records entities for subprograms that are + -- eliminated, and corresponding eliminate pragmas that caused the + -- elimination. Entries in this table are set by Check_Eliminated + -- and read by Eliminate_Error_Msg. + + type Elim_Entity_Entry is record + Prag : Node_Id; + Subp : Entity_Id; + end record; + + package Elim_Entities is new Table.Table ( + Table_Component_Type => Elim_Entity_Entry, + Table_Index_Type => Name_Id'Base, + Table_Low_Bound => First_Name_Id, + Table_Initial => 50, + Table_Increment => 200, + Table_Name => "Elim_Entries"); + + ---------------------- + -- Check_Eliminated -- + ---------------------- + + procedure Check_Eliminated (E : Entity_Id) is + Elmt : Access_Elim_Data; + Scop : Entity_Id; + Form : Entity_Id; + Up : Nat; + + begin + if No_Elimination then + return; + + -- Elimination of objects and types is not implemented yet + + elsif Ekind (E) not in Subprogram_Kind then + return; + end if; + + -- Loop through homonyms for this key + + Elmt := Elim_Hash_Table.Get (Chars (E)); + while Elmt /= null loop + Check_Homonyms : declare + procedure Set_Eliminated; + -- Set current subprogram entity as eliminated + + -------------------- + -- Set_Eliminated -- + -------------------- + + procedure Set_Eliminated is + begin + if Is_Dispatching_Operation (E) then + + -- If an overriding dispatching primitive is eliminated then + -- its parent must have been eliminated. + + if Present (Overridden_Operation (E)) + and then not Is_Eliminated (Overridden_Operation (E)) + then + Error_Msg_Name_1 := Chars (E); + Error_Msg_N ("cannot eliminate subprogram %", E); + return; + end if; + end if; + + Set_Is_Eliminated (E); + Elim_Entities.Append ((Prag => Elmt.Prag, Subp => E)); + end Set_Eliminated; + + -- Start of processing for Check_Homonyms + + begin + -- First we check that the name of the entity matches + + if Elmt.Entity_Name /= Chars (E) then + goto Continue; + end if; + + -- Find enclosing unit, and verify that its name and those of its + -- parents match. + + Scop := Cunit_Entity (Current_Sem_Unit); + + -- Now see if compilation unit matches + + Up := Elmt.Unit_Name'Last; + + -- If we are within a subunit, the name in the pragma has been + -- parsed as a child unit, but the current compilation unit is in + -- fact the parent in which the subunit is embedded. We must skip + -- the first name which is that of the subunit to match the pragma + -- specification. Body may be that of a package or subprogram. + + declare + Par : Node_Id; + + begin + Par := Parent (E); + while Present (Par) loop + if Nkind (Par) = N_Subunit then + if Chars (Defining_Entity (Proper_Body (Par))) = + Elmt.Unit_Name (Up) + then + Up := Up - 1; + exit; + + else + goto Continue; + end if; + end if; + + Par := Parent (Par); + end loop; + end; + + for J in reverse Elmt.Unit_Name'First .. Up loop + if Elmt.Unit_Name (J) /= Chars (Scop) then + goto Continue; + end if; + + Scop := Scope (Scop); + + if Scop /= Standard_Standard and then J = 1 then + goto Continue; + end if; + end loop; + + if Scop /= Standard_Standard then + goto Continue; + end if; + + if Present (Elmt.Entity_Node) + and then Elmt.Entity_Scope /= null + then + -- Check that names of enclosing scopes match. Skip blocks and + -- wrapper package of subprogram instances, which do not appear + -- in the pragma. + + Scop := Scope (E); + + for J in reverse Elmt.Entity_Scope'Range loop + while Ekind (Scop) = E_Block + or else + (Ekind (Scop) = E_Package + and then Is_Wrapper_Package (Scop)) + loop + Scop := Scope (Scop); + end loop; + + if Elmt.Entity_Scope (J) /= Chars (Scop) then + if Ekind (Scop) /= E_Protected_Type + or else Comes_From_Source (Scop) + then + goto Continue; + + -- For simple protected declarations, retrieve the source + -- name of the object, which appeared in the Eliminate + -- pragma. + + else + declare + Decl : constant Node_Id := + Original_Node (Parent (Scop)); + + begin + if Elmt.Entity_Scope (J) /= + Chars (Defining_Identifier (Decl)) + then + if J > 0 then + null; + end if; + goto Continue; + end if; + end; + end if; + + end if; + + Scop := Scope (Scop); + end loop; + end if; + + -- If given entity is a library level subprogram and pragma had a + -- single parameter, a match! + + if Is_Compilation_Unit (E) + and then Is_Subprogram (E) + and then No (Elmt.Entity_Node) + then + Set_Eliminated; + return; + + -- Check for case of type or object with two parameter case + + elsif (Is_Type (E) or else Is_Object (E)) + and then Elmt.Result_Type = No_Name + and then Elmt.Parameter_Types = null + then + Set_Eliminated; + return; + + -- Check for case of subprogram + + elsif Ekind_In (E, E_Function, E_Procedure) then + + -- If Source_Location present, then see if it matches + + if Elmt.Source_Location /= No_Name then + Get_Name_String (Elmt.Source_Location); + + declare + Sloc_Trace : constant String := + Name_Buffer (1 .. Name_Len); + + Idx : Natural := Sloc_Trace'First; + -- Index in Sloc_Trace, if equals to 0, then we have + -- completely traversed Sloc_Trace + + Last : constant Natural := Sloc_Trace'Last; + + P : Source_Ptr; + Sindex : Source_File_Index; + + function File_Name_Match return Boolean; + -- This function is supposed to be called when Idx points + -- to the beginning of the new file name, and Name_Buffer + -- is set to contain the name of the proper source file + -- from the chain corresponding to the Sloc of E. First + -- it checks that these two files have the same name. If + -- this check is successful, moves Idx to point to the + -- beginning of the column number. + + function Line_Num_Match return Boolean; + -- This function is supposed to be called when Idx points + -- to the beginning of the column number, and P is + -- set to point to the proper Sloc the chain + -- corresponding to the Sloc of E. First it checks that + -- the line number Idx points on and the line number + -- corresponding to P are the same. If this check is + -- successful, moves Idx to point to the beginning of + -- the next file name in Sloc_Trace. If there is no file + -- name any more, Idx is set to 0. + + function Different_Trace_Lengths return Boolean; + -- From Idx and P, defines if there are in both traces + -- more element(s) in the instantiation chains. Returns + -- False if one trace contains more element(s), but + -- another does not. If both traces contains more + -- elements (that is, the function returns False), moves + -- P ahead in the chain corresponding to E, recomputes + -- Sindex and sets the name of the corresponding file in + -- Name_Buffer + + function Skip_Spaces return Natural; + -- If Sloc_Trace (Idx) is not space character, returns + -- Idx. Otherwise returns the index of the nearest + -- non-space character in Sloc_Trace to the right of Idx. + -- Returns 0 if there is no such character. + + ----------------------------- + -- Different_Trace_Lengths -- + ----------------------------- + + function Different_Trace_Lengths return Boolean is + begin + P := Instantiation (Sindex); + + if (P = No_Location and then Idx /= 0) + or else + (P /= No_Location and then Idx = 0) + then + return True; + + else + if P /= No_Location then + Sindex := Get_Source_File_Index (P); + Get_Name_String (File_Name (Sindex)); + end if; + + return False; + end if; + end Different_Trace_Lengths; + + --------------------- + -- File_Name_Match -- + --------------------- + + function File_Name_Match return Boolean is + Tmp_Idx : Natural; + End_Idx : Natural; + + begin + if Idx = 0 then + return False; + end if; + + -- Find first colon. If no colon, then return False. + -- If there is a colon, Tmp_Idx is set to point just + -- before the colon. + + Tmp_Idx := Idx - 1; + loop + if Tmp_Idx >= Last then + return False; + elsif Sloc_Trace (Tmp_Idx + 1) = ':' then + exit; + else + Tmp_Idx := Tmp_Idx + 1; + end if; + end loop; + + -- Find last non-space before this colon. If there is + -- no space character before this colon, then return + -- False. Otherwise, End_Idx is set to point to this + -- non-space character. + + End_Idx := Tmp_Idx; + loop + if End_Idx < Idx then + return False; + + elsif Sloc_Trace (End_Idx) /= ' ' then + exit; + + else + End_Idx := End_Idx - 1; + end if; + end loop; + + -- Now see if file name matches what is in Name_Buffer + -- and if so, step Idx past it and return True. If the + -- name does not match, return False. + + if Sloc_Trace (Idx .. End_Idx) = + Name_Buffer (1 .. Name_Len) + then + Idx := Tmp_Idx + 2; + Idx := Skip_Spaces; + return True; + else + return False; + end if; + end File_Name_Match; + + -------------------- + -- Line_Num_Match -- + -------------------- + + function Line_Num_Match return Boolean is + N : Int := 0; + + begin + if Idx = 0 then + return False; + end if; + + while Idx <= Last + and then Sloc_Trace (Idx) in '0' .. '9' + loop + N := N * 10 + + (Character'Pos (Sloc_Trace (Idx)) - + Character'Pos ('0')); + Idx := Idx + 1; + end loop; + + if Get_Physical_Line_Number (P) = + Physical_Line_Number (N) + then + while Idx <= Last and then + Sloc_Trace (Idx) /= '[' + loop + Idx := Idx + 1; + end loop; + + if Idx <= Last and then + Sloc_Trace (Idx) = '[' + then + Idx := Idx + 1; + Idx := Skip_Spaces; + else + Idx := 0; + end if; + + return True; + + else + return False; + end if; + end Line_Num_Match; + + ----------------- + -- Skip_Spaces -- + ----------------- + + function Skip_Spaces return Natural is + Res : Natural; + + begin + Res := Idx; + while Sloc_Trace (Res) = ' ' loop + Res := Res + 1; + + if Res > Last then + Res := 0; + exit; + end if; + end loop; + + return Res; + end Skip_Spaces; + + begin + P := Sloc (E); + Sindex := Get_Source_File_Index (P); + Get_Name_String (File_Name (Sindex)); + + Idx := Skip_Spaces; + while Idx > 0 loop + if not File_Name_Match then + goto Continue; + elsif not Line_Num_Match then + goto Continue; + end if; + + if Different_Trace_Lengths then + goto Continue; + end if; + end loop; + end; + end if; + + -- If we have a Result_Type, then we must have a function with + -- the proper result type. + + if Elmt.Result_Type /= No_Name then + if Ekind (E) /= E_Function + or else Chars (Etype (E)) /= Elmt.Result_Type + then + goto Continue; + end if; + end if; + + -- If we have Parameter_Types, they must match + + if Elmt.Parameter_Types /= null then + Form := First_Formal (E); + + if No (Form) + and then Elmt.Parameter_Types'Length = 1 + and then Elmt.Parameter_Types (1) = No_Name + then + -- Parameterless procedure matches + + null; + + elsif Elmt.Parameter_Types = null then + goto Continue; + + else + for J in Elmt.Parameter_Types'Range loop + if No (Form) + or else + Chars (Etype (Form)) /= Elmt.Parameter_Types (J) + then + goto Continue; + else + Next_Formal (Form); + end if; + end loop; + + if Present (Form) then + goto Continue; + end if; + end if; + end if; + + -- If we fall through, this is match + + Set_Eliminated; + return; + end if; + end Check_Homonyms; + + <> + Elmt := Elmt.Homonym; + end loop; + + return; + end Check_Eliminated; + + ------------------------------------- + -- Check_For_Eliminated_Subprogram -- + ------------------------------------- + + procedure Check_For_Eliminated_Subprogram (N : Node_Id; S : Entity_Id) is + Ultimate_Subp : constant Entity_Id := Ultimate_Alias (S); + Enclosing_Subp : Entity_Id; + + begin + if Is_Eliminated (Ultimate_Subp) + and then not Inside_A_Generic + and then not Is_Generic_Unit (Cunit_Entity (Current_Sem_Unit)) + then + Enclosing_Subp := Current_Subprogram; + while Present (Enclosing_Subp) loop + if Is_Eliminated (Enclosing_Subp) then + return; + end if; + + Enclosing_Subp := Enclosing_Subprogram (Enclosing_Subp); + end loop; + + -- Emit error, unless we are within an instance body and the expander + -- is disabled, indicating an instance within an enclosing generic. + -- In an instance, the ultimate alias is an internal entity, so place + -- the message on the original subprogram. + + if In_Instance_Body and then not Expander_Active then + null; + + elsif Comes_From_Source (Ultimate_Subp) then + Eliminate_Error_Msg (N, Ultimate_Subp); + + else + Eliminate_Error_Msg (N, S); + end if; + end if; + end Check_For_Eliminated_Subprogram; + + ------------------------- + -- Eliminate_Error_Msg -- + ------------------------- + + procedure Eliminate_Error_Msg (N : Node_Id; E : Entity_Id) is + begin + for J in Elim_Entities.First .. Elim_Entities.Last loop + if E = Elim_Entities.Table (J).Subp then + Error_Msg_Sloc := Sloc (Elim_Entities.Table (J).Prag); + Error_Msg_NE ("cannot reference subprogram & eliminated #", N, E); + return; + end if; + end loop; + + -- If this is an internal operation generated for a protected operation, + -- its name does not match the source name, so just report the error. + + if not Comes_From_Source (E) + and then Present (First_Entity (E)) + and then Is_Concurrent_Record_Type (Etype (First_Entity (E))) + then + Error_Msg_NE + ("cannot reference eliminated protected subprogram", N, E); + + -- Otherwise should not fall through, entry should be in table + + else + Error_Msg_NE + ("subprogram& is called but its alias is eliminated", N, E); + -- raise Program_Error; + end if; + end Eliminate_Error_Msg; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Elim_Hash_Table.Reset; + Elim_Entities.Init; + No_Elimination := True; + end Initialize; + + ------------------------------ + -- Process_Eliminate_Pragma -- + ------------------------------ + + procedure Process_Eliminate_Pragma + (Pragma_Node : Node_Id; + Arg_Unit_Name : Node_Id; + Arg_Entity : Node_Id; + Arg_Parameter_Types : Node_Id; + Arg_Result_Type : Node_Id; + Arg_Source_Location : Node_Id) + is + Data : constant Access_Elim_Data := new Elim_Data; + -- Build result data here + + Elmt : Access_Elim_Data; + + Num_Names : Nat := 0; + -- Number of names in unit name + + Lit : Node_Id; + Arg_Ent : Entity_Id; + Arg_Uname : Node_Id; + + function OK_Selected_Component (N : Node_Id) return Boolean; + -- Test if N is a selected component with all identifiers, or a + -- selected component whose selector is an operator symbol. As a + -- side effect if result is True, sets Num_Names to the number + -- of names present (identifiers and operator if any). + + --------------------------- + -- OK_Selected_Component -- + --------------------------- + + function OK_Selected_Component (N : Node_Id) return Boolean is + begin + if Nkind (N) = N_Identifier + or else Nkind (N) = N_Operator_Symbol + then + Num_Names := Num_Names + 1; + return True; + + elsif Nkind (N) = N_Selected_Component then + return OK_Selected_Component (Prefix (N)) + and then OK_Selected_Component (Selector_Name (N)); + + else + return False; + end if; + end OK_Selected_Component; + + -- Start of processing for Process_Eliminate_Pragma + + begin + Data.Prag := Pragma_Node; + Error_Msg_Name_1 := Name_Eliminate; + + -- Process Unit_Name argument + + if Nkind (Arg_Unit_Name) = N_Identifier then + Data.Unit_Name := new Names'(1 => Chars (Arg_Unit_Name)); + Num_Names := 1; + + elsif OK_Selected_Component (Arg_Unit_Name) then + Data.Unit_Name := new Names (1 .. Num_Names); + + Arg_Uname := Arg_Unit_Name; + for J in reverse 2 .. Num_Names loop + Data.Unit_Name (J) := Chars (Selector_Name (Arg_Uname)); + Arg_Uname := Prefix (Arg_Uname); + end loop; + + Data.Unit_Name (1) := Chars (Arg_Uname); + + else + Error_Msg_N + ("wrong form for Unit_Name parameter of pragma%", Arg_Unit_Name); + return; + end if; + + -- Process Entity argument + + if Present (Arg_Entity) then + Num_Names := 0; + + if Nkind (Arg_Entity) = N_Identifier + or else Nkind (Arg_Entity) = N_Operator_Symbol + then + Data.Entity_Name := Chars (Arg_Entity); + Data.Entity_Node := Arg_Entity; + Data.Entity_Scope := null; + + elsif OK_Selected_Component (Arg_Entity) then + Data.Entity_Scope := new Names (1 .. Num_Names - 1); + Data.Entity_Name := Chars (Selector_Name (Arg_Entity)); + Data.Entity_Node := Arg_Entity; + + Arg_Ent := Prefix (Arg_Entity); + for J in reverse 2 .. Num_Names - 1 loop + Data.Entity_Scope (J) := Chars (Selector_Name (Arg_Ent)); + Arg_Ent := Prefix (Arg_Ent); + end loop; + + Data.Entity_Scope (1) := Chars (Arg_Ent); + + elsif Is_Config_Static_String (Arg_Entity) then + Data.Entity_Name := Name_Find; + Data.Entity_Node := Arg_Entity; + + else + return; + end if; + else + Data.Entity_Node := Empty; + Data.Entity_Name := Data.Unit_Name (Num_Names); + end if; + + -- Process Parameter_Types argument + + if Present (Arg_Parameter_Types) then + + -- Here for aggregate case + + if Nkind (Arg_Parameter_Types) = N_Aggregate then + Data.Parameter_Types := + new Names + (1 .. List_Length (Expressions (Arg_Parameter_Types))); + + Lit := First (Expressions (Arg_Parameter_Types)); + for J in Data.Parameter_Types'Range loop + if Is_Config_Static_String (Lit) then + Data.Parameter_Types (J) := Name_Find; + Next (Lit); + else + return; + end if; + end loop; + + -- Otherwise we must have case of one name, which looks like a + -- parenthesized literal rather than an aggregate. + + elsif Paren_Count (Arg_Parameter_Types) /= 1 then + Error_Msg_N + ("wrong form for argument of pragma Eliminate", + Arg_Parameter_Types); + return; + + elsif Is_Config_Static_String (Arg_Parameter_Types) then + String_To_Name_Buffer (Strval (Arg_Parameter_Types)); + + if Name_Len = 0 then + + -- Parameterless procedure + + Data.Parameter_Types := new Names'(1 => No_Name); + + else + Data.Parameter_Types := new Names'(1 => Name_Find); + end if; + + else + return; + end if; + end if; + + -- Process Result_Types argument + + if Present (Arg_Result_Type) then + if Is_Config_Static_String (Arg_Result_Type) then + Data.Result_Type := Name_Find; + else + return; + end if; + + -- Here if no Result_Types argument + + else + Data.Result_Type := No_Name; + end if; + + -- Process Source_Location argument + + if Present (Arg_Source_Location) then + if Is_Config_Static_String (Arg_Source_Location) then + Data.Source_Location := Name_Find; + else + return; + end if; + else + Data.Source_Location := No_Name; + end if; + + Elmt := Elim_Hash_Table.Get (Hash_Subprograms.Get_Key (Data)); + + -- If we already have an entry with this same key, then link + -- it into the chain of entries for this key. + + if Elmt /= null then + Data.Homonym := Elmt.Homonym; + Elmt.Homonym := Data; + + -- Otherwise create a new entry + + else + Elim_Hash_Table.Set (Data); + end if; + + No_Elimination := False; + end Process_Eliminate_Pragma; + +end Sem_Elim; diff --git a/gcc/ada/sem_elim.ads b/gcc/ada/sem_elim.ads new file mode 100644 index 000000000..9bb159633 --- /dev/null +++ b/gcc/ada/sem_elim.ads @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ E L I M -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1997-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 to process the Eliminate pragma + +with Types; use Types; + +package Sem_Elim is + + procedure Initialize; + -- Initialize for new main source program + + procedure Process_Eliminate_Pragma + (Pragma_Node : Node_Id; + Arg_Unit_Name : Node_Id; + Arg_Entity : Node_Id; + Arg_Parameter_Types : Node_Id; + Arg_Result_Type : Node_Id; + Arg_Source_Location : Node_Id); + -- Process eliminate pragma (given by Pragma_Node). The number of + -- arguments has been checked, as well as possible optional identifiers, + -- but no other checks have been made. This subprogram completes the + -- checking, and then if the pragma is well formed, makes appropriate + -- entries in the internal tables used to keep track of Eliminate pragmas. + -- The other five arguments are expressions (rather than pragma argument + -- associations) for the possible pragma arguments. A parameter that + -- is not present is set to Empty. + + procedure Check_Eliminated (E : Entity_Id); + -- Checks if entity E is eliminated, and if so sets the Is_Eliminated + -- flag on the given entity. + + procedure Check_For_Eliminated_Subprogram (N : Node_Id; S : Entity_Id); + -- Check that the subprogram S (or its ultimate parent in the case of a + -- derived subprogram or renaming) has not been eliminated. An error will + -- be flagged if the subprogram has been eliminated, unless the node N + -- occurs within an eliminated subprogram or within a generic unit. The + -- error will be posted on N. + + procedure Eliminate_Error_Msg (N : Node_Id; E : Entity_Id); + -- Called by the front-end and back-end on encountering a reference to an + -- eliminated subprogram. N is the node for the reference (such as occurs + -- in a call or attribute), and E is the entity of the subprogram that has + -- been eliminated. + +end Sem_Elim; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb new file mode 100644 index 000000000..caa0f704f --- /dev/null +++ b/gcc/ada/sem_eval.adb @@ -0,0 +1,5453 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ E V A L -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Eval_Fat; use Eval_Fat; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Lib; use Lib; +with Namet; use Namet; +with Nmake; use Nmake; +with Nlists; use Nlists; +with Opt; use Opt; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Cat; use Sem_Cat; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sem_Type; use Sem_Type; +with Sem_Warn; use Sem_Warn; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Tbuild; use Tbuild; + +package body Sem_Eval is + + ----------------------------------------- + -- Handling of Compile Time Evaluation -- + ----------------------------------------- + + -- The compile time evaluation of expressions is distributed over several + -- Eval_xxx procedures. These procedures are called immediately after + -- a subexpression is resolved and is therefore accomplished in a bottom + -- up fashion. The flags are synthesized using the following approach. + + -- Is_Static_Expression is determined by following the detailed rules + -- in RM 4.9(4-14). This involves testing the Is_Static_Expression + -- flag of the operands in many cases. + + -- Raises_Constraint_Error is set if any of the operands have the flag + -- set or if an attempt to compute the value of the current expression + -- results in detection of a runtime constraint error. + + -- As described in the spec, the requirement is that Is_Static_Expression + -- be accurately set, and in addition for nodes for which this flag is set, + -- Raises_Constraint_Error must also be set. Furthermore a node which has + -- Is_Static_Expression set, and Raises_Constraint_Error clear, then the + -- requirement is that the expression value must be precomputed, and the + -- node is either a literal, or the name of a constant entity whose value + -- is a static expression. + + -- The general approach is as follows. First compute Is_Static_Expression. + -- If the node is not static, then the flag is left off in the node and + -- we are all done. Otherwise for a static node, we test if any of the + -- operands will raise constraint error, and if so, propagate the flag + -- Raises_Constraint_Error to the result node and we are done (since the + -- error was already posted at a lower level). + + -- For the case of a static node whose operands do not raise constraint + -- error, we attempt to evaluate the node. If this evaluation succeeds, + -- then the node is replaced by the result of this computation. If the + -- evaluation raises constraint error, then we rewrite the node with + -- Apply_Compile_Time_Constraint_Error to raise the exception and also + -- to post appropriate error messages. + + ---------------- + -- Local Data -- + ---------------- + + type Bits is array (Nat range <>) of Boolean; + -- Used to convert unsigned (modular) values for folding logical ops + + -- The following definitions are used to maintain a cache of nodes that + -- have compile time known values. The cache is maintained only for + -- discrete types (the most common case), and is populated by calls to + -- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value + -- since it is possible for the status to change (in particular it is + -- possible for a node to get replaced by a constraint error node). + + CV_Bits : constant := 5; + -- Number of low order bits of Node_Id value used to reference entries + -- in the cache table. + + CV_Cache_Size : constant Nat := 2 ** CV_Bits; + -- Size of cache for compile time values + + subtype CV_Range is Nat range 0 .. CV_Cache_Size; + + type CV_Entry is record + N : Node_Id; + V : Uint; + end record; + + type CV_Cache_Array is array (CV_Range) of CV_Entry; + + CV_Cache : CV_Cache_Array := (others => (Node_High_Bound, Uint_0)); + -- This is the actual cache, with entries consisting of node/value pairs, + -- and the impossible value Node_High_Bound used for unset entries. + + type Range_Membership is (In_Range, Out_Of_Range, Unknown); + -- Range membership may either be statically known to be in range or out + -- of range, or not statically known. Used for Test_In_Range below. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function From_Bits (B : Bits; T : Entity_Id) return Uint; + -- Converts a bit string of length B'Length to a Uint value to be used + -- for a target of type T, which is a modular type. This procedure + -- includes the necessary reduction by the modulus in the case of a + -- non-binary modulus (for a binary modulus, the bit string is the + -- right length any way so all is well). + + function Get_String_Val (N : Node_Id) return Node_Id; + -- Given a tree node for a folded string or character value, returns + -- the corresponding string literal or character literal (one of the + -- two must be available, or the operand would not have been marked + -- as foldable in the earlier analysis of the operation). + + function OK_Bits (N : Node_Id; Bits : Uint) return Boolean; + -- Bits represents the number of bits in an integer value to be computed + -- (but the value has not been computed yet). If this value in Bits is + -- reasonable, a result of True is returned, with the implication that + -- the caller should go ahead and complete the calculation. If the value + -- in Bits is unreasonably large, then an error is posted on node N, and + -- False is returned (and the caller skips the proposed calculation). + + procedure Out_Of_Range (N : Node_Id); + -- This procedure is called if it is determined that node N, which + -- appears in a non-static context, is a compile time known value + -- which is outside its range, i.e. the range of Etype. This is used + -- in contexts where this is an illegality if N is static, and should + -- generate a warning otherwise. + + procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id); + -- N and Exp are nodes representing an expression, Exp is known + -- to raise CE. N is rewritten in term of Exp in the optimal way. + + function String_Type_Len (Stype : Entity_Id) return Uint; + -- Given a string type, determines the length of the index type, or, + -- if this index type is non-static, the length of the base type of + -- this index type. Note that if the string type is itself static, + -- then the index type is static, so the second case applies only + -- if the string type passed is non-static. + + function Test (Cond : Boolean) return Uint; + pragma Inline (Test); + -- This function simply returns the appropriate Boolean'Pos value + -- corresponding to the value of Cond as a universal integer. It is + -- used for producing the result of the static evaluation of the + -- logical operators + + function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id; + -- Check whether an arithmetic operation with universal operands which + -- is a rewritten function call with an explicit scope indication is + -- ambiguous: P."+" (1, 2) will be ambiguous if there is more than one + -- visible numeric type declared in P and the context does not impose a + -- type on the result (e.g. in the expression of a type conversion). + -- If ambiguous, emit an error and return Empty, else return the result + -- type of the operator. + + procedure Test_Expression_Is_Foldable + (N : Node_Id; + Op1 : Node_Id; + Stat : out Boolean; + Fold : out Boolean); + -- Tests to see if expression N whose single operand is Op1 is foldable, + -- i.e. the operand value is known at compile time. If the operation is + -- foldable, then Fold is True on return, and Stat indicates whether + -- the result is static (i.e. both operands were static). Note that it + -- is quite possible for Fold to be True, and Stat to be False, since + -- there are cases in which we know the value of an operand even though + -- it is not technically static (e.g. the static lower bound of a range + -- whose upper bound is non-static). + -- + -- If Stat is set False on return, then Test_Expression_Is_Foldable makes a + -- call to Check_Non_Static_Context on the operand. If Fold is False on + -- return, then all processing is complete, and the caller should + -- return, since there is nothing else to do. + -- + -- If Stat is set True on return, then Is_Static_Expression is also set + -- true in node N. There are some cases where this is over-enthusiastic, + -- e.g. in the two operand case below, for string comparison, the result + -- is not static even though the two operands are static. In such cases, + -- the caller must reset the Is_Static_Expression flag in N. + + procedure Test_Expression_Is_Foldable + (N : Node_Id; + Op1 : Node_Id; + Op2 : Node_Id; + Stat : out Boolean; + Fold : out Boolean); + -- Same processing, except applies to an expression N with two operands + -- Op1 and Op2. + + function Test_In_Range + (N : Node_Id; + Typ : Entity_Id; + Assume_Valid : Boolean; + Fixed_Int : Boolean; + Int_Real : Boolean) return Range_Membership; + -- Common processing for Is_In_Range and Is_Out_Of_Range: + -- Returns In_Range or Out_Of_Range if it can be guaranteed at compile time + -- that expression N is known to be in or out of range of the subtype Typ. + -- If not compile time known, Unknown is returned. + -- See documentation of Is_In_Range for complete description of parameters. + + procedure To_Bits (U : Uint; B : out Bits); + -- Converts a Uint value to a bit string of length B'Length + + ------------------------------ + -- Check_Non_Static_Context -- + ------------------------------ + + procedure Check_Non_Static_Context (N : Node_Id) is + T : constant Entity_Id := Etype (N); + Checks_On : constant Boolean := + not Index_Checks_Suppressed (T) + and not Range_Checks_Suppressed (T); + + begin + -- Ignore cases of non-scalar types or error types + + if T = Any_Type or else not Is_Scalar_Type (T) then + return; + end if; + + -- At this stage we have a scalar type. If we have an expression + -- that raises CE, then we already issued a warning or error msg + -- so there is nothing more to be done in this routine. + + if Raises_Constraint_Error (N) then + return; + end if; + + -- Now we have a scalar type which is not marked as raising a + -- constraint error exception. The main purpose of this routine + -- is to deal with static expressions appearing in a non-static + -- context. That means that if we do not have a static expression + -- then there is not much to do. The one case that we deal with + -- here is that if we have a floating-point value that is out of + -- range, then we post a warning that an infinity will result. + + if not Is_Static_Expression (N) then + if Is_Floating_Point_Type (T) + and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) + then + Error_Msg_N + ("?float value out of range, infinity will be generated", N); + end if; + + return; + end if; + + -- Here we have the case of outer level static expression of + -- scalar type, where the processing of this procedure is needed. + + -- For real types, this is where we convert the value to a machine + -- number (see RM 4.9(38)). Also see ACVC test C490001. We should + -- only need to do this if the parent is a constant declaration, + -- since in other cases, gigi should do the necessary conversion + -- correctly, but experimentation shows that this is not the case + -- on all machines, in particular if we do not convert all literals + -- to machine values in non-static contexts, then ACVC test C490001 + -- fails on Sparc/Solaris and SGI/Irix. + + if Nkind (N) = N_Real_Literal + and then not Is_Machine_Number (N) + and then not Is_Generic_Type (Etype (N)) + and then Etype (N) /= Universal_Real + then + -- Check that value is in bounds before converting to machine + -- number, so as not to lose case where value overflows in the + -- least significant bit or less. See B490001. + + if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then + Out_Of_Range (N); + return; + end if; + + -- Note: we have to copy the node, to avoid problems with conformance + -- of very similar numbers (see ACVC tests B4A010C and B63103A). + + Rewrite (N, New_Copy (N)); + + if not Is_Floating_Point_Type (T) then + Set_Realval + (N, Corresponding_Integer_Value (N) * Small_Value (T)); + + elsif not UR_Is_Zero (Realval (N)) then + + -- Note: even though RM 4.9(38) specifies biased rounding, + -- this has been modified by AI-100 in order to prevent + -- confusing differences in rounding between static and + -- non-static expressions. AI-100 specifies that the effect + -- of such rounding is implementation dependent, and in GNAT + -- we round to nearest even to match the run-time behavior. + + Set_Realval + (N, Machine (Base_Type (T), Realval (N), Round_Even, N)); + end if; + + Set_Is_Machine_Number (N); + end if; + + -- Check for out of range universal integer. This is a non-static + -- context, so the integer value must be in range of the runtime + -- representation of universal integers. + + -- We do this only within an expression, because that is the only + -- case in which non-static universal integer values can occur, and + -- furthermore, Check_Non_Static_Context is currently (incorrectly???) + -- called in contexts like the expression of a number declaration where + -- we certainly want to allow out of range values. + + if Etype (N) = Universal_Integer + and then Nkind (N) = N_Integer_Literal + and then Nkind (Parent (N)) in N_Subexpr + and then + (Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer)) + or else + Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer))) + then + Apply_Compile_Time_Constraint_Error + (N, "non-static universal integer value out of range?", + CE_Range_Check_Failed); + + -- Check out of range of base type + + elsif Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then + Out_Of_Range (N); + + -- Give warning if outside subtype (where one or both of the bounds of + -- the subtype is static). This warning is omitted if the expression + -- appears in a range that could be null (warnings are handled elsewhere + -- for this case). + + elsif T /= Base_Type (T) + and then Nkind (Parent (N)) /= N_Range + then + if Is_In_Range (N, T, Assume_Valid => True) then + null; + + elsif Is_Out_Of_Range (N, T, Assume_Valid => True) then + Apply_Compile_Time_Constraint_Error + (N, "value not in range of}?", CE_Range_Check_Failed); + + elsif Checks_On then + Enable_Range_Check (N); + + else + Set_Do_Range_Check (N, False); + end if; + end if; + end Check_Non_Static_Context; + + --------------------------------- + -- Check_String_Literal_Length -- + --------------------------------- + + procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is + begin + if not Raises_Constraint_Error (N) + and then Is_Constrained (Ttype) + then + if + UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype) + then + Apply_Compile_Time_Constraint_Error + (N, "string length wrong for}?", + CE_Length_Check_Failed, + Ent => Ttype, + Typ => Ttype); + end if; + end if; + end Check_String_Literal_Length; + + -------------------------- + -- Compile_Time_Compare -- + -------------------------- + + function Compile_Time_Compare + (L, R : Node_Id; + Assume_Valid : Boolean) return Compare_Result + is + Discard : aliased Uint; + begin + return Compile_Time_Compare (L, R, Discard'Access, Assume_Valid); + end Compile_Time_Compare; + + function Compile_Time_Compare + (L, R : Node_Id; + Diff : access Uint; + Assume_Valid : Boolean; + Rec : Boolean := False) return Compare_Result + is + Ltyp : Entity_Id := Underlying_Type (Etype (L)); + Rtyp : Entity_Id := Underlying_Type (Etype (R)); + -- These get reset to the base type for the case of entities where + -- Is_Known_Valid is not set. This takes care of handling possible + -- invalid representations using the value of the base type, in + -- accordance with RM 13.9.1(10). + + Discard : aliased Uint; + + procedure Compare_Decompose + (N : Node_Id; + R : out Node_Id; + V : out Uint); + -- This procedure decomposes the node N into an expression node and a + -- signed offset, so that the value of N is equal to the value of R plus + -- the value V (which may be negative). If no such decomposition is + -- possible, then on return R is a copy of N, and V is set to zero. + + function Compare_Fixup (N : Node_Id) return Node_Id; + -- This function deals with replacing 'Last and 'First references with + -- their corresponding type bounds, which we then can compare. The + -- argument is the original node, the result is the identity, unless we + -- have a 'Last/'First reference in which case the value returned is the + -- appropriate type bound. + + function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean; + -- Even if the context does not assume that values are valid, some + -- simple cases can be recognized. + + function Is_Same_Value (L, R : Node_Id) return Boolean; + -- Returns True iff L and R represent expressions that definitely + -- have identical (but not necessarily compile time known) values + -- Indeed the caller is expected to have already dealt with the + -- cases of compile time known values, so these are not tested here. + + ----------------------- + -- Compare_Decompose -- + ----------------------- + + procedure Compare_Decompose + (N : Node_Id; + R : out Node_Id; + V : out Uint) + is + begin + if Nkind (N) = N_Op_Add + and then Nkind (Right_Opnd (N)) = N_Integer_Literal + then + R := Left_Opnd (N); + V := Intval (Right_Opnd (N)); + return; + + elsif Nkind (N) = N_Op_Subtract + and then Nkind (Right_Opnd (N)) = N_Integer_Literal + then + R := Left_Opnd (N); + V := UI_Negate (Intval (Right_Opnd (N))); + return; + + elsif Nkind (N) = N_Attribute_Reference then + if Attribute_Name (N) = Name_Succ then + R := First (Expressions (N)); + V := Uint_1; + return; + + elsif Attribute_Name (N) = Name_Pred then + R := First (Expressions (N)); + V := Uint_Minus_1; + return; + end if; + end if; + + R := N; + V := Uint_0; + end Compare_Decompose; + + ------------------- + -- Compare_Fixup -- + ------------------- + + function Compare_Fixup (N : Node_Id) return Node_Id is + Indx : Node_Id; + Xtyp : Entity_Id; + Subs : Nat; + + begin + if Nkind (N) = N_Attribute_Reference + and then (Attribute_Name (N) = Name_First + or else + Attribute_Name (N) = Name_Last) + then + Xtyp := Etype (Prefix (N)); + + -- If we have no type, then just abandon the attempt to do + -- a fixup, this is probably the result of some other error. + + if No (Xtyp) then + return N; + end if; + + -- Dereference an access type + + if Is_Access_Type (Xtyp) then + Xtyp := Designated_Type (Xtyp); + end if; + + -- If we don't have an array type at this stage, something + -- is peculiar, e.g. another error, and we abandon the attempt + -- at a fixup. + + if not Is_Array_Type (Xtyp) then + return N; + end if; + + -- Ignore unconstrained array, since bounds are not meaningful + + if not Is_Constrained (Xtyp) then + return N; + end if; + + if Ekind (Xtyp) = E_String_Literal_Subtype then + if Attribute_Name (N) = Name_First then + return String_Literal_Low_Bound (Xtyp); + + else -- Attribute_Name (N) = Name_Last + return Make_Integer_Literal (Sloc (N), + Intval => Intval (String_Literal_Low_Bound (Xtyp)) + + String_Literal_Length (Xtyp)); + end if; + end if; + + -- Find correct index type + + Indx := First_Index (Xtyp); + + if Present (Expressions (N)) then + Subs := UI_To_Int (Expr_Value (First (Expressions (N)))); + + for J in 2 .. Subs loop + Indx := Next_Index (Indx); + end loop; + end if; + + Xtyp := Etype (Indx); + + if Attribute_Name (N) = Name_First then + return Type_Low_Bound (Xtyp); + + else -- Attribute_Name (N) = Name_Last + return Type_High_Bound (Xtyp); + end if; + end if; + + return N; + end Compare_Fixup; + + ---------------------------- + -- Is_Known_Valid_Operand -- + ---------------------------- + + function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean is + begin + return (Is_Entity_Name (Opnd) + and then + (Is_Known_Valid (Entity (Opnd)) + or else Ekind (Entity (Opnd)) = E_In_Parameter + or else + (Ekind (Entity (Opnd)) in Object_Kind + and then Present (Current_Value (Entity (Opnd)))))) + or else Is_OK_Static_Expression (Opnd); + end Is_Known_Valid_Operand; + + ------------------- + -- Is_Same_Value -- + ------------------- + + function Is_Same_Value (L, R : Node_Id) return Boolean is + Lf : constant Node_Id := Compare_Fixup (L); + Rf : constant Node_Id := Compare_Fixup (R); + + function Is_Same_Subscript (L, R : List_Id) return Boolean; + -- L, R are the Expressions values from two attribute nodes for First + -- or Last attributes. Either may be set to No_List if no expressions + -- are present (indicating subscript 1). The result is True if both + -- expressions represent the same subscript (note one case is where + -- one subscript is missing and the other is explicitly set to 1). + + ----------------------- + -- Is_Same_Subscript -- + ----------------------- + + function Is_Same_Subscript (L, R : List_Id) return Boolean is + begin + if L = No_List then + if R = No_List then + return True; + else + return Expr_Value (First (R)) = Uint_1; + end if; + + else + if R = No_List then + return Expr_Value (First (L)) = Uint_1; + else + return Expr_Value (First (L)) = Expr_Value (First (R)); + end if; + end if; + end Is_Same_Subscript; + + -- Start of processing for Is_Same_Value + + begin + -- Values are the same if they refer to the same entity and the + -- entity is non-volatile. This does not however apply to Float + -- types, since we may have two NaN values and they should never + -- compare equal. + + -- If the entity is a discriminant, the two expressions may be bounds + -- of components of objects of the same discriminated type. The + -- values of the discriminants are not static, and therefore the + -- result is unknown. + + -- It would be better to comment individual branches of this test ??? + + if Nkind_In (Lf, N_Identifier, N_Expanded_Name) + and then Nkind_In (Rf, N_Identifier, N_Expanded_Name) + and then Entity (Lf) = Entity (Rf) + and then Ekind (Entity (Lf)) /= E_Discriminant + and then Present (Entity (Lf)) + and then not Is_Floating_Point_Type (Etype (L)) + and then not Is_Volatile_Reference (L) + and then not Is_Volatile_Reference (R) + then + return True; + + -- Or if they are compile time known and identical + + elsif Compile_Time_Known_Value (Lf) + and then + Compile_Time_Known_Value (Rf) + and then Expr_Value (Lf) = Expr_Value (Rf) + then + return True; + + -- False if Nkind of the two nodes is different for remaining cases + + elsif Nkind (Lf) /= Nkind (Rf) then + return False; + + -- True if both 'First or 'Last values applying to the same entity + -- (first and last don't change even if value does). Note that we + -- need this even with the calls to Compare_Fixup, to handle the + -- case of unconstrained array attributes where Compare_Fixup + -- cannot find useful bounds. + + elsif Nkind (Lf) = N_Attribute_Reference + and then Attribute_Name (Lf) = Attribute_Name (Rf) + and then (Attribute_Name (Lf) = Name_First + or else + Attribute_Name (Lf) = Name_Last) + and then Nkind_In (Prefix (Lf), N_Identifier, N_Expanded_Name) + and then Nkind_In (Prefix (Rf), N_Identifier, N_Expanded_Name) + and then Entity (Prefix (Lf)) = Entity (Prefix (Rf)) + and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf)) + then + return True; + + -- True if the same selected component from the same record + + elsif Nkind (Lf) = N_Selected_Component + and then Selector_Name (Lf) = Selector_Name (Rf) + and then Is_Same_Value (Prefix (Lf), Prefix (Rf)) + then + return True; + + -- True if the same unary operator applied to the same operand + + elsif Nkind (Lf) in N_Unary_Op + and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf)) + then + return True; + + -- True if the same binary operator applied to the same operands + + elsif Nkind (Lf) in N_Binary_Op + and then Is_Same_Value (Left_Opnd (Lf), Left_Opnd (Rf)) + and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf)) + then + return True; + + -- All other cases, we can't tell, so return False + + else + return False; + end if; + end Is_Same_Value; + + -- Start of processing for Compile_Time_Compare + + begin + Diff.all := No_Uint; + + -- If either operand could raise constraint error, then we cannot + -- know the result at compile time (since CE may be raised!) + + if not (Cannot_Raise_Constraint_Error (L) + and then + Cannot_Raise_Constraint_Error (R)) + then + return Unknown; + end if; + + -- Identical operands are most certainly equal + + if L = R then + return EQ; + + -- If expressions have no types, then do not attempt to determine if + -- they are the same, since something funny is going on. One case in + -- which this happens is during generic template analysis, when bounds + -- are not fully analyzed. + + elsif No (Ltyp) or else No (Rtyp) then + return Unknown; + + -- We do not attempt comparisons for packed arrays arrays represented as + -- modular types, where the semantics of comparison is quite different. + + elsif Is_Packed_Array_Type (Ltyp) + and then Is_Modular_Integer_Type (Ltyp) + then + return Unknown; + + -- For access types, the only time we know the result at compile time + -- (apart from identical operands, which we handled already) is if we + -- know one operand is null and the other is not, or both operands are + -- known null. + + elsif Is_Access_Type (Ltyp) then + if Known_Null (L) then + if Known_Null (R) then + return EQ; + elsif Known_Non_Null (R) then + return NE; + else + return Unknown; + end if; + + elsif Known_Non_Null (L) and then Known_Null (R) then + return NE; + + else + return Unknown; + end if; + + -- Case where comparison involves two compile time known values + + elsif Compile_Time_Known_Value (L) + and then Compile_Time_Known_Value (R) + then + -- For the floating-point case, we have to be a little careful, since + -- at compile time we are dealing with universal exact values, but at + -- runtime, these will be in non-exact target form. That's why the + -- returned results are LE and GE below instead of LT and GT. + + if Is_Floating_Point_Type (Ltyp) + or else + Is_Floating_Point_Type (Rtyp) + then + declare + Lo : constant Ureal := Expr_Value_R (L); + Hi : constant Ureal := Expr_Value_R (R); + + begin + if Lo < Hi then + return LE; + elsif Lo = Hi then + return EQ; + else + return GE; + end if; + end; + + -- For string types, we have two string literals and we proceed to + -- compare them using the Ada style dictionary string comparison. + + elsif not Is_Scalar_Type (Ltyp) then + declare + Lstring : constant String_Id := Strval (Expr_Value_S (L)); + Rstring : constant String_Id := Strval (Expr_Value_S (R)); + Llen : constant Nat := String_Length (Lstring); + Rlen : constant Nat := String_Length (Rstring); + + begin + for J in 1 .. Nat'Min (Llen, Rlen) loop + declare + LC : constant Char_Code := Get_String_Char (Lstring, J); + RC : constant Char_Code := Get_String_Char (Rstring, J); + begin + if LC < RC then + return LT; + elsif LC > RC then + return GT; + end if; + end; + end loop; + + if Llen < Rlen then + return LT; + elsif Llen > Rlen then + return GT; + else + return EQ; + end if; + end; + + -- For remaining scalar cases we know exactly (note that this does + -- include the fixed-point case, where we know the run time integer + -- values now). + + else + declare + Lo : constant Uint := Expr_Value (L); + Hi : constant Uint := Expr_Value (R); + + begin + if Lo < Hi then + Diff.all := Hi - Lo; + return LT; + + elsif Lo = Hi then + return EQ; + + else + Diff.all := Lo - Hi; + return GT; + end if; + end; + end if; + + -- Cases where at least one operand is not known at compile time + + else + -- Remaining checks apply only for discrete types + + if not Is_Discrete_Type (Ltyp) + or else not Is_Discrete_Type (Rtyp) + then + return Unknown; + end if; + + -- Defend against generic types, or actually any expressions that + -- contain a reference to a generic type from within a generic + -- template. We don't want to do any range analysis of such + -- expressions for two reasons. First, the bounds of a generic type + -- itself are junk and cannot be used for any kind of analysis. + -- Second, we may have a case where the range at run time is indeed + -- known, but we don't want to do compile time analysis in the + -- template based on that range since in an instance the value may be + -- static, and able to be elaborated without reference to the bounds + -- of types involved. As an example, consider: + + -- (F'Pos (F'Last) + 1) > Integer'Last + + -- The expression on the left side of > is Universal_Integer and thus + -- acquires the type Integer for evaluation at run time, and at run + -- time it is true that this condition is always False, but within + -- an instance F may be a type with a static range greater than the + -- range of Integer, and the expression statically evaluates to True. + + if References_Generic_Formal_Type (L) + or else + References_Generic_Formal_Type (R) + then + return Unknown; + end if; + + -- Replace types by base types for the case of entities which are + -- not known to have valid representations. This takes care of + -- properly dealing with invalid representations. + + if not Assume_Valid and then not Assume_No_Invalid_Values then + if Is_Entity_Name (L) and then not Is_Known_Valid (Entity (L)) then + Ltyp := Underlying_Type (Base_Type (Ltyp)); + end if; + + if Is_Entity_Name (R) and then not Is_Known_Valid (Entity (R)) then + Rtyp := Underlying_Type (Base_Type (Rtyp)); + end if; + end if; + + -- Try range analysis on variables and see if ranges are disjoint + + declare + LOK, ROK : Boolean; + LLo, LHi : Uint; + RLo, RHi : Uint; + + begin + Determine_Range (L, LOK, LLo, LHi, Assume_Valid); + Determine_Range (R, ROK, RLo, RHi, Assume_Valid); + + if LOK and ROK then + if LHi < RLo then + return LT; + + elsif RHi < LLo then + return GT; + + elsif LLo = LHi + and then RLo = RHi + and then LLo = RLo + then + + -- If the range includes a single literal and we can assume + -- validity then the result is known even if an operand is + -- not static. + + if Assume_Valid then + return EQ; + else + return Unknown; + end if; + + elsif LHi = RLo then + return LE; + + elsif RHi = LLo then + return GE; + + elsif not Is_Known_Valid_Operand (L) + and then not Assume_Valid + then + if Is_Same_Value (L, R) then + return EQ; + else + return Unknown; + end if; + end if; + end if; + end; + + -- Here is where we check for comparisons against maximum bounds of + -- types, where we know that no value can be outside the bounds of + -- the subtype. Note that this routine is allowed to assume that all + -- expressions are within their subtype bounds. Callers wishing to + -- deal with possibly invalid values must in any case take special + -- steps (e.g. conversions to larger types) to avoid this kind of + -- optimization, which is always considered to be valid. We do not + -- attempt this optimization with generic types, since the type + -- bounds may not be meaningful in this case. + + -- We are in danger of an infinite recursion here. It does not seem + -- useful to go more than one level deep, so the parameter Rec is + -- used to protect ourselves against this infinite recursion. + + if not Rec then + + -- See if we can get a decisive check against one operand and + -- a bound of the other operand (four possible tests here). + -- Note that we avoid testing junk bounds of a generic type. + + if not Is_Generic_Type (Rtyp) then + case Compile_Time_Compare (L, Type_Low_Bound (Rtyp), + Discard'Access, + Assume_Valid, Rec => True) + is + when LT => return LT; + when LE => return LE; + when EQ => return LE; + when others => null; + end case; + + case Compile_Time_Compare (L, Type_High_Bound (Rtyp), + Discard'Access, + Assume_Valid, Rec => True) + is + when GT => return GT; + when GE => return GE; + when EQ => return GE; + when others => null; + end case; + end if; + + if not Is_Generic_Type (Ltyp) then + case Compile_Time_Compare (Type_Low_Bound (Ltyp), R, + Discard'Access, + Assume_Valid, Rec => True) + is + when GT => return GT; + when GE => return GE; + when EQ => return GE; + when others => null; + end case; + + case Compile_Time_Compare (Type_High_Bound (Ltyp), R, + Discard'Access, + Assume_Valid, Rec => True) + is + when LT => return LT; + when LE => return LE; + when EQ => return LE; + when others => null; + end case; + end if; + end if; + + -- Next attempt is to decompose the expressions to extract + -- a constant offset resulting from the use of any of the forms: + + -- expr + literal + -- expr - literal + -- typ'Succ (expr) + -- typ'Pred (expr) + + -- Then we see if the two expressions are the same value, and if so + -- the result is obtained by comparing the offsets. + + declare + Lnode : Node_Id; + Loffs : Uint; + Rnode : Node_Id; + Roffs : Uint; + + begin + Compare_Decompose (L, Lnode, Loffs); + Compare_Decompose (R, Rnode, Roffs); + + if Is_Same_Value (Lnode, Rnode) then + if Loffs = Roffs then + return EQ; + + elsif Loffs < Roffs then + Diff.all := Roffs - Loffs; + return LT; + + else + Diff.all := Loffs - Roffs; + return GT; + end if; + end if; + end; + + -- Next attempt is to see if we have an entity compared with a + -- compile time known value, where there is a current value + -- conditional for the entity which can tell us the result. + + declare + Var : Node_Id; + -- Entity variable (left operand) + + Val : Uint; + -- Value (right operand) + + Inv : Boolean; + -- If False, we have reversed the operands + + Op : Node_Kind; + -- Comparison operator kind from Get_Current_Value_Condition call + + Opn : Node_Id; + -- Value from Get_Current_Value_Condition call + + Opv : Uint; + -- Value of Opn + + Result : Compare_Result; + -- Known result before inversion + + begin + if Is_Entity_Name (L) + and then Compile_Time_Known_Value (R) + then + Var := L; + Val := Expr_Value (R); + Inv := False; + + elsif Is_Entity_Name (R) + and then Compile_Time_Known_Value (L) + then + Var := R; + Val := Expr_Value (L); + Inv := True; + + -- That was the last chance at finding a compile time result + + else + return Unknown; + end if; + + Get_Current_Value_Condition (Var, Op, Opn); + + -- That was the last chance, so if we got nothing return + + if No (Opn) then + return Unknown; + end if; + + Opv := Expr_Value (Opn); + + -- We got a comparison, so we might have something interesting + + -- Convert LE to LT and GE to GT, just so we have fewer cases + + if Op = N_Op_Le then + Op := N_Op_Lt; + Opv := Opv + 1; + + elsif Op = N_Op_Ge then + Op := N_Op_Gt; + Opv := Opv - 1; + end if; + + -- Deal with equality case + + if Op = N_Op_Eq then + if Val = Opv then + Result := EQ; + elsif Opv < Val then + Result := LT; + else + Result := GT; + end if; + + -- Deal with inequality case + + elsif Op = N_Op_Ne then + if Val = Opv then + Result := NE; + else + return Unknown; + end if; + + -- Deal with greater than case + + elsif Op = N_Op_Gt then + if Opv >= Val then + Result := GT; + elsif Opv = Val - 1 then + Result := GE; + else + return Unknown; + end if; + + -- Deal with less than case + + else pragma Assert (Op = N_Op_Lt); + if Opv <= Val then + Result := LT; + elsif Opv = Val + 1 then + Result := LE; + else + return Unknown; + end if; + end if; + + -- Deal with inverting result + + if Inv then + case Result is + when GT => return LT; + when GE => return LE; + when LT => return GT; + when LE => return GE; + when others => return Result; + end case; + end if; + + return Result; + end; + end if; + end Compile_Time_Compare; + + ------------------------------- + -- Compile_Time_Known_Bounds -- + ------------------------------- + + function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean is + Indx : Node_Id; + Typ : Entity_Id; + + begin + if not Is_Array_Type (T) then + return False; + end if; + + Indx := First_Index (T); + while Present (Indx) loop + Typ := Underlying_Type (Etype (Indx)); + + -- Never look at junk bounds of a generic type + + if Is_Generic_Type (Typ) then + return False; + end if; + + -- Otherwise check bounds for compile time known + + if not Compile_Time_Known_Value (Type_Low_Bound (Typ)) then + return False; + elsif not Compile_Time_Known_Value (Type_High_Bound (Typ)) then + return False; + else + Next_Index (Indx); + end if; + end loop; + + return True; + end Compile_Time_Known_Bounds; + + ------------------------------ + -- Compile_Time_Known_Value -- + ------------------------------ + + function Compile_Time_Known_Value (Op : Node_Id) return Boolean is + K : constant Node_Kind := Nkind (Op); + CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size); + + begin + -- Never known at compile time if bad type or raises constraint error + -- or empty (latter case occurs only as a result of a previous error) + + if No (Op) + or else Op = Error + or else Etype (Op) = Any_Type + or else Raises_Constraint_Error (Op) + then + return False; + end if; + + -- If this is not a static expression or a null literal, and we are in + -- configurable run-time mode, then we consider it not known at compile + -- time. This avoids anomalies where whether something is allowed with a + -- given configurable run-time library depends on how good the compiler + -- is at optimizing and knowing that things are constant when they are + -- nonstatic. + + if Configurable_Run_Time_Mode + and then K /= N_Null + and then not Is_Static_Expression (Op) + then + return False; + end if; + + -- If we have an entity name, then see if it is the name of a constant + -- and if so, test the corresponding constant value, or the name of + -- an enumeration literal, which is always a constant. + + if Present (Etype (Op)) and then Is_Entity_Name (Op) then + declare + E : constant Entity_Id := Entity (Op); + V : Node_Id; + + begin + -- Never known at compile time if it is a packed array value. + -- We might want to try to evaluate these at compile time one + -- day, but we do not make that attempt now. + + if Is_Packed_Array_Type (Etype (Op)) then + return False; + end if; + + if Ekind (E) = E_Enumeration_Literal then + return True; + + elsif Ekind (E) = E_Constant then + V := Constant_Value (E); + return Present (V) and then Compile_Time_Known_Value (V); + end if; + end; + + -- We have a value, see if it is compile time known + + else + -- Integer literals are worth storing in the cache + + if K = N_Integer_Literal then + CV_Ent.N := Op; + CV_Ent.V := Intval (Op); + return True; + + -- Other literals and NULL are known at compile time + + elsif + K = N_Character_Literal + or else + K = N_Real_Literal + or else + K = N_String_Literal + or else + K = N_Null + then + return True; + + -- Any reference to Null_Parameter is known at compile time. No + -- other attribute references (that have not already been folded) + -- are known at compile time. + + elsif K = N_Attribute_Reference then + return Attribute_Name (Op) = Name_Null_Parameter; + end if; + end if; + + -- If we fall through, not known at compile time + + return False; + + -- If we get an exception while trying to do this test, then some error + -- has occurred, and we simply say that the value is not known after all + + exception + when others => + return False; + end Compile_Time_Known_Value; + + -------------------------------------- + -- Compile_Time_Known_Value_Or_Aggr -- + -------------------------------------- + + function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean is + begin + -- If we have an entity name, then see if it is the name of a constant + -- and if so, test the corresponding constant value, or the name of + -- an enumeration literal, which is always a constant. + + if Is_Entity_Name (Op) then + declare + E : constant Entity_Id := Entity (Op); + V : Node_Id; + + begin + if Ekind (E) = E_Enumeration_Literal then + return True; + + elsif Ekind (E) /= E_Constant then + return False; + + else + V := Constant_Value (E); + return Present (V) + and then Compile_Time_Known_Value_Or_Aggr (V); + end if; + end; + + -- We have a value, see if it is compile time known + + else + if Compile_Time_Known_Value (Op) then + return True; + + elsif Nkind (Op) = N_Aggregate then + + if Present (Expressions (Op)) then + declare + Expr : Node_Id; + + begin + Expr := First (Expressions (Op)); + while Present (Expr) loop + if not Compile_Time_Known_Value_Or_Aggr (Expr) then + return False; + end if; + + Next (Expr); + end loop; + end; + end if; + + if Present (Component_Associations (Op)) then + declare + Cass : Node_Id; + + begin + Cass := First (Component_Associations (Op)); + while Present (Cass) loop + if not + Compile_Time_Known_Value_Or_Aggr (Expression (Cass)) + then + return False; + end if; + + Next (Cass); + end loop; + end; + end if; + + return True; + + -- All other types of values are not known at compile time + + else + return False; + end if; + + end if; + end Compile_Time_Known_Value_Or_Aggr; + + ----------------- + -- Eval_Actual -- + ----------------- + + -- This is only called for actuals of functions that are not predefined + -- operators (which have already been rewritten as operators at this + -- stage), so the call can never be folded, and all that needs doing for + -- the actual is to do the check for a non-static context. + + procedure Eval_Actual (N : Node_Id) is + begin + Check_Non_Static_Context (N); + end Eval_Actual; + + -------------------- + -- Eval_Allocator -- + -------------------- + + -- Allocators are never static, so all we have to do is to do the + -- check for a non-static context if an expression is present. + + procedure Eval_Allocator (N : Node_Id) is + Expr : constant Node_Id := Expression (N); + + begin + if Nkind (Expr) = N_Qualified_Expression then + Check_Non_Static_Context (Expression (Expr)); + end if; + end Eval_Allocator; + + ------------------------ + -- Eval_Arithmetic_Op -- + ------------------------ + + -- Arithmetic operations are static functions, so the result is static + -- if both operands are static (RM 4.9(7), 4.9(20)). + + procedure Eval_Arithmetic_Op (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + Ltype : constant Entity_Id := Etype (Left); + Rtype : constant Entity_Id := Etype (Right); + Otype : Entity_Id := Empty; + Stat : Boolean; + Fold : Boolean; + + begin + -- If not foldable we are done + + Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold); + + if not Fold then + return; + end if; + + if Is_Universal_Numeric_Type (Etype (Left)) + and then + Is_Universal_Numeric_Type (Etype (Right)) + then + Otype := Find_Universal_Operator_Type (N); + end if; + + -- Fold for cases where both operands are of integer type + + if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then + declare + Left_Int : constant Uint := Expr_Value (Left); + Right_Int : constant Uint := Expr_Value (Right); + Result : Uint; + + begin + case Nkind (N) is + + when N_Op_Add => + Result := Left_Int + Right_Int; + + when N_Op_Subtract => + Result := Left_Int - Right_Int; + + when N_Op_Multiply => + if OK_Bits + (N, UI_From_Int + (Num_Bits (Left_Int) + Num_Bits (Right_Int))) + then + Result := Left_Int * Right_Int; + else + Result := Left_Int; + end if; + + when N_Op_Divide => + + -- The exception Constraint_Error is raised by integer + -- division, rem and mod if the right operand is zero. + + if Right_Int = 0 then + Apply_Compile_Time_Constraint_Error + (N, "division by zero", + CE_Divide_By_Zero, + Warn => not Stat); + return; + + else + Result := Left_Int / Right_Int; + end if; + + when N_Op_Mod => + + -- The exception Constraint_Error is raised by integer + -- division, rem and mod if the right operand is zero. + + if Right_Int = 0 then + Apply_Compile_Time_Constraint_Error + (N, "mod with zero divisor", + CE_Divide_By_Zero, + Warn => not Stat); + return; + else + Result := Left_Int mod Right_Int; + end if; + + when N_Op_Rem => + + -- The exception Constraint_Error is raised by integer + -- division, rem and mod if the right operand is zero. + + if Right_Int = 0 then + Apply_Compile_Time_Constraint_Error + (N, "rem with zero divisor", + CE_Divide_By_Zero, + Warn => not Stat); + return; + + else + Result := Left_Int rem Right_Int; + end if; + + when others => + raise Program_Error; + end case; + + -- Adjust the result by the modulus if the type is a modular type + + if Is_Modular_Integer_Type (Ltype) then + Result := Result mod Modulus (Ltype); + + -- For a signed integer type, check non-static overflow + + elsif (not Stat) and then Is_Signed_Integer_Type (Ltype) then + declare + BT : constant Entity_Id := Base_Type (Ltype); + Lo : constant Uint := Expr_Value (Type_Low_Bound (BT)); + Hi : constant Uint := Expr_Value (Type_High_Bound (BT)); + begin + if Result < Lo or else Result > Hi then + Apply_Compile_Time_Constraint_Error + (N, "value not in range of }?", + CE_Overflow_Check_Failed, + Ent => BT); + return; + end if; + end; + end if; + + -- If we get here we can fold the result + + Fold_Uint (N, Result, Stat); + end; + + -- Cases where at least one operand is a real. We handle the cases of + -- both reals, or mixed/real integer cases (the latter happen only for + -- divide and multiply, and the result is always real). + + elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then + declare + Left_Real : Ureal; + Right_Real : Ureal; + Result : Ureal; + + begin + if Is_Real_Type (Ltype) then + Left_Real := Expr_Value_R (Left); + else + Left_Real := UR_From_Uint (Expr_Value (Left)); + end if; + + if Is_Real_Type (Rtype) then + Right_Real := Expr_Value_R (Right); + else + Right_Real := UR_From_Uint (Expr_Value (Right)); + end if; + + if Nkind (N) = N_Op_Add then + Result := Left_Real + Right_Real; + + elsif Nkind (N) = N_Op_Subtract then + Result := Left_Real - Right_Real; + + elsif Nkind (N) = N_Op_Multiply then + Result := Left_Real * Right_Real; + + else pragma Assert (Nkind (N) = N_Op_Divide); + if UR_Is_Zero (Right_Real) then + Apply_Compile_Time_Constraint_Error + (N, "division by zero", CE_Divide_By_Zero); + return; + end if; + + Result := Left_Real / Right_Real; + end if; + + Fold_Ureal (N, Result, Stat); + end; + end if; + + -- If the operator was resolved to a specific type, make sure that type + -- is frozen even if the expression is folded into a literal (which has + -- a universal type). + + if Present (Otype) then + Freeze_Before (N, Otype); + end if; + end Eval_Arithmetic_Op; + + ---------------------------- + -- Eval_Character_Literal -- + ---------------------------- + + -- Nothing to be done! + + procedure Eval_Character_Literal (N : Node_Id) is + pragma Warnings (Off, N); + begin + null; + end Eval_Character_Literal; + + --------------- + -- Eval_Call -- + --------------- + + -- Static function calls are either calls to predefined operators + -- with static arguments, or calls to functions that rename a literal. + -- Only the latter case is handled here, predefined operators are + -- constant-folded elsewhere. + + -- If the function is itself inherited (see 7423-001) the literal of + -- the parent type must be explicitly converted to the return type + -- of the function. + + procedure Eval_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Lit : Entity_Id; + + begin + if Nkind (N) = N_Function_Call + and then No (Parameter_Associations (N)) + and then Is_Entity_Name (Name (N)) + and then Present (Alias (Entity (Name (N)))) + and then Is_Enumeration_Type (Base_Type (Typ)) + then + Lit := Ultimate_Alias (Entity (Name (N))); + + if Ekind (Lit) = E_Enumeration_Literal then + if Base_Type (Etype (Lit)) /= Base_Type (Typ) then + Rewrite + (N, Convert_To (Typ, New_Occurrence_Of (Lit, Loc))); + else + Rewrite (N, New_Occurrence_Of (Lit, Loc)); + end if; + + Resolve (N, Typ); + end if; + end if; + end Eval_Call; + + -------------------------- + -- Eval_Case_Expression -- + -------------------------- + + -- Right now we do not attempt folding of any case expressions, and the + -- language does not require it, so the only required processing is to + -- do the check for all expressions appearing in the case expression. + + procedure Eval_Case_Expression (N : Node_Id) is + Alt : Node_Id; + + begin + Check_Non_Static_Context (Expression (N)); + + Alt := First (Alternatives (N)); + while Present (Alt) loop + Check_Non_Static_Context (Expression (Alt)); + Next (Alt); + end loop; + end Eval_Case_Expression; + + ------------------------ + -- Eval_Concatenation -- + ------------------------ + + -- Concatenation is a static function, so the result is static if both + -- operands are static (RM 4.9(7), 4.9(21)). + + procedure Eval_Concatenation (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + C_Typ : constant Entity_Id := Root_Type (Component_Type (Etype (N))); + Stat : Boolean; + Fold : Boolean; + + begin + -- Concatenation is never static in Ada 83, so if Ada 83 check operand + -- non-static context. + + if Ada_Version = Ada_83 + and then Comes_From_Source (N) + then + Check_Non_Static_Context (Left); + Check_Non_Static_Context (Right); + return; + end if; + + -- If not foldable we are done. In principle concatenation that yields + -- any string type is static (i.e. an array type of character types). + -- However, character types can include enumeration literals, and + -- concatenation in that case cannot be described by a literal, so we + -- only consider the operation static if the result is an array of + -- (a descendant of) a predefined character type. + + Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold); + + if not (Is_Standard_Character_Type (C_Typ) and then Fold) then + Set_Is_Static_Expression (N, False); + return; + end if; + + -- Compile time string concatenation + + -- ??? Note that operands that are aggregates can be marked as static, + -- so we should attempt at a later stage to fold concatenations with + -- such aggregates. + + declare + Left_Str : constant Node_Id := Get_String_Val (Left); + Left_Len : Nat; + Right_Str : constant Node_Id := Get_String_Val (Right); + Folded_Val : String_Id; + + begin + -- Establish new string literal, and store left operand. We make + -- sure to use the special Start_String that takes an operand if + -- the left operand is a string literal. Since this is optimized + -- in the case where that is the most recently created string + -- literal, we ensure efficient time/space behavior for the + -- case of a concatenation of a series of string literals. + + if Nkind (Left_Str) = N_String_Literal then + Left_Len := String_Length (Strval (Left_Str)); + + -- If the left operand is the empty string, and the right operand + -- is a string literal (the case of "" & "..."), the result is the + -- value of the right operand. This optimization is important when + -- Is_Folded_In_Parser, to avoid copying an enormous right + -- operand. + + if Left_Len = 0 and then Nkind (Right_Str) = N_String_Literal then + Folded_Val := Strval (Right_Str); + else + Start_String (Strval (Left_Str)); + end if; + + else + Start_String; + Store_String_Char (UI_To_CC (Char_Literal_Value (Left_Str))); + Left_Len := 1; + end if; + + -- Now append the characters of the right operand, unless we + -- optimized the "" & "..." case above. + + if Nkind (Right_Str) = N_String_Literal then + if Left_Len /= 0 then + Store_String_Chars (Strval (Right_Str)); + Folded_Val := End_String; + end if; + else + Store_String_Char (UI_To_CC (Char_Literal_Value (Right_Str))); + Folded_Val := End_String; + end if; + + Set_Is_Static_Expression (N, Stat); + + if Stat then + + -- If left operand is the empty string, the result is the + -- right operand, including its bounds if anomalous. + + if Left_Len = 0 + and then Is_Array_Type (Etype (Right)) + and then Etype (Right) /= Any_String + then + Set_Etype (N, Etype (Right)); + end if; + + Fold_Str (N, Folded_Val, Static => True); + end if; + end; + end Eval_Concatenation; + + --------------------------------- + -- Eval_Conditional_Expression -- + --------------------------------- + + -- We can fold to a static expression if the condition and both constituent + -- expressions are static. Otherwise, the only required processing is to do + -- the check for non-static context for the then and else expressions. + + procedure Eval_Conditional_Expression (N : Node_Id) is + Condition : constant Node_Id := First (Expressions (N)); + Then_Expr : constant Node_Id := Next (Condition); + Else_Expr : constant Node_Id := Next (Then_Expr); + Result : Node_Id; + Non_Result : Node_Id; + + Rstat : constant Boolean := + Is_Static_Expression (Condition) + and then + Is_Static_Expression (Then_Expr) + and then + Is_Static_Expression (Else_Expr); + + begin + -- If any operand is Any_Type, just propagate to result and do not try + -- to fold, this prevents cascaded errors. + + if Etype (Condition) = Any_Type or else + Etype (Then_Expr) = Any_Type or else + Etype (Else_Expr) = Any_Type + then + Set_Etype (N, Any_Type); + Set_Is_Static_Expression (N, False); + return; + + -- Static case where we can fold. Note that we don't try to fold cases + -- where the condition is known at compile time, but the result is + -- non-static. This avoids possible cases of infinite recursion where + -- the expander puts in a redundant test and we remove it. Instead we + -- deal with these cases in the expander. + + elsif Rstat then + + -- Select result operand + + if Is_True (Expr_Value (Condition)) then + Result := Then_Expr; + Non_Result := Else_Expr; + else + Result := Else_Expr; + Non_Result := Then_Expr; + end if; + + -- Note that it does not matter if the non-result operand raises a + -- Constraint_Error, but if the result raises constraint error then + -- we replace the node with a raise constraint error. This will + -- properly propagate Raises_Constraint_Error since this flag is + -- set in Result. + + if Raises_Constraint_Error (Result) then + Rewrite_In_Raise_CE (N, Result); + Check_Non_Static_Context (Non_Result); + + -- Otherwise the result operand replaces the original node + + else + Rewrite (N, Relocate_Node (Result)); + end if; + + -- Case of condition not known at compile time + + else + Check_Non_Static_Context (Condition); + Check_Non_Static_Context (Then_Expr); + Check_Non_Static_Context (Else_Expr); + end if; + + Set_Is_Static_Expression (N, Rstat); + end Eval_Conditional_Expression; + + ---------------------- + -- Eval_Entity_Name -- + ---------------------- + + -- This procedure is used for identifiers and expanded names other than + -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are + -- static if they denote a static constant (RM 4.9(6)) or if the name + -- denotes an enumeration literal (RM 4.9(22)). + + procedure Eval_Entity_Name (N : Node_Id) is + Def_Id : constant Entity_Id := Entity (N); + Val : Node_Id; + + begin + -- Enumeration literals are always considered to be constants + -- and cannot raise constraint error (RM 4.9(22)). + + if Ekind (Def_Id) = E_Enumeration_Literal then + Set_Is_Static_Expression (N); + return; + + -- A name is static if it denotes a static constant (RM 4.9(5)), and + -- we also copy Raise_Constraint_Error. Notice that even if non-static, + -- it does not violate 10.2.1(8) here, since this is not a variable. + + elsif Ekind (Def_Id) = E_Constant then + + -- Deferred constants must always be treated as nonstatic + -- outside the scope of their full view. + + if Present (Full_View (Def_Id)) + and then not In_Open_Scopes (Scope (Def_Id)) + then + Val := Empty; + else + Val := Constant_Value (Def_Id); + end if; + + if Present (Val) then + Set_Is_Static_Expression + (N, Is_Static_Expression (Val) + and then Is_Static_Subtype (Etype (Def_Id))); + Set_Raises_Constraint_Error (N, Raises_Constraint_Error (Val)); + + if not Is_Static_Expression (N) + and then not Is_Generic_Type (Etype (N)) + then + Validate_Static_Object_Name (N); + end if; + + return; + end if; + end if; + + -- Fall through if the name is not static + + Validate_Static_Object_Name (N); + end Eval_Entity_Name; + + ---------------------------- + -- Eval_Indexed_Component -- + ---------------------------- + + -- Indexed components are never static, so we need to perform the check + -- for non-static context on the index values. Then, we check if the + -- value can be obtained at compile time, even though it is non-static. + + procedure Eval_Indexed_Component (N : Node_Id) is + Expr : Node_Id; + + begin + -- Check for non-static context on index values + + Expr := First (Expressions (N)); + while Present (Expr) loop + Check_Non_Static_Context (Expr); + Next (Expr); + end loop; + + -- If the indexed component appears in an object renaming declaration + -- then we do not want to try to evaluate it, since in this case we + -- need the identity of the array element. + + if Nkind (Parent (N)) = N_Object_Renaming_Declaration then + return; + + -- Similarly if the indexed component appears as the prefix of an + -- attribute we don't want to evaluate it, because at least for + -- some cases of attributes we need the identify (e.g. Access, Size) + + elsif Nkind (Parent (N)) = N_Attribute_Reference then + return; + end if; + + -- Note: there are other cases, such as the left side of an assignment, + -- or an OUT parameter for a call, where the replacement results in the + -- illegal use of a constant, But these cases are illegal in the first + -- place, so the replacement, though silly, is harmless. + + -- Now see if this is a constant array reference + + if List_Length (Expressions (N)) = 1 + and then Is_Entity_Name (Prefix (N)) + and then Ekind (Entity (Prefix (N))) = E_Constant + and then Present (Constant_Value (Entity (Prefix (N)))) + then + declare + Loc : constant Source_Ptr := Sloc (N); + Arr : constant Node_Id := Constant_Value (Entity (Prefix (N))); + Sub : constant Node_Id := First (Expressions (N)); + + Atyp : Entity_Id; + -- Type of array + + Lin : Nat; + -- Linear one's origin subscript value for array reference + + Lbd : Node_Id; + -- Lower bound of the first array index + + Elm : Node_Id; + -- Value from constant array + + begin + Atyp := Etype (Arr); + + if Is_Access_Type (Atyp) then + Atyp := Designated_Type (Atyp); + end if; + + -- If we have an array type (we should have but perhaps there are + -- error cases where this is not the case), then see if we can do + -- a constant evaluation of the array reference. + + if Is_Array_Type (Atyp) and then Atyp /= Any_Composite then + if Ekind (Atyp) = E_String_Literal_Subtype then + Lbd := String_Literal_Low_Bound (Atyp); + else + Lbd := Type_Low_Bound (Etype (First_Index (Atyp))); + end if; + + if Compile_Time_Known_Value (Sub) + and then Nkind (Arr) = N_Aggregate + and then Compile_Time_Known_Value (Lbd) + and then Is_Discrete_Type (Component_Type (Atyp)) + then + Lin := UI_To_Int (Expr_Value (Sub) - Expr_Value (Lbd)) + 1; + + if List_Length (Expressions (Arr)) >= Lin then + Elm := Pick (Expressions (Arr), Lin); + + -- If the resulting expression is compile time known, + -- then we can rewrite the indexed component with this + -- value, being sure to mark the result as non-static. + -- We also reset the Sloc, in case this generates an + -- error later on (e.g. 136'Access). + + if Compile_Time_Known_Value (Elm) then + Rewrite (N, Duplicate_Subexpr_No_Checks (Elm)); + Set_Is_Static_Expression (N, False); + Set_Sloc (N, Loc); + end if; + end if; + + -- We can also constant-fold if the prefix is a string literal. + -- This will be useful in an instantiation or an inlining. + + elsif Compile_Time_Known_Value (Sub) + and then Nkind (Arr) = N_String_Literal + and then Compile_Time_Known_Value (Lbd) + and then Expr_Value (Lbd) = 1 + and then Expr_Value (Sub) <= + String_Literal_Length (Etype (Arr)) + then + declare + C : constant Char_Code := + Get_String_Char (Strval (Arr), + UI_To_Int (Expr_Value (Sub))); + begin + Set_Character_Literal_Name (C); + + Elm := + Make_Character_Literal (Loc, + Chars => Name_Find, + Char_Literal_Value => UI_From_CC (C)); + Set_Etype (Elm, Component_Type (Atyp)); + Rewrite (N, Duplicate_Subexpr_No_Checks (Elm)); + Set_Is_Static_Expression (N, False); + end; + end if; + end if; + end; + end if; + end Eval_Indexed_Component; + + -------------------------- + -- Eval_Integer_Literal -- + -------------------------- + + -- Numeric literals are static (RM 4.9(1)), and have already been marked + -- as static by the analyzer. The reason we did it that early is to allow + -- the possibility of turning off the Is_Static_Expression flag after + -- analysis, but before resolution, when integer literals are generated in + -- the expander that do not correspond to static expressions. + + procedure Eval_Integer_Literal (N : Node_Id) is + T : constant Entity_Id := Etype (N); + + function In_Any_Integer_Context return Boolean; + -- If the literal is resolved with a specific type in a context where + -- the expected type is Any_Integer, there are no range checks on the + -- literal. By the time the literal is evaluated, it carries the type + -- imposed by the enclosing expression, and we must recover the context + -- to determine that Any_Integer is meant. + + ---------------------------- + -- In_Any_Integer_Context -- + ---------------------------- + + function In_Any_Integer_Context return Boolean is + Par : constant Node_Id := Parent (N); + K : constant Node_Kind := Nkind (Par); + + begin + -- Any_Integer also appears in digits specifications for real types, + -- but those have bounds smaller that those of any integer base type, + -- so we can safely ignore these cases. + + return K = N_Number_Declaration + or else K = N_Attribute_Reference + or else K = N_Attribute_Definition_Clause + or else K = N_Modular_Type_Definition + or else K = N_Signed_Integer_Type_Definition; + end In_Any_Integer_Context; + + -- Start of processing for Eval_Integer_Literal + + begin + + -- If the literal appears in a non-expression context, then it is + -- certainly appearing in a non-static context, so check it. This is + -- actually a redundant check, since Check_Non_Static_Context would + -- check it, but it seems worth while avoiding the call. + + if Nkind (Parent (N)) not in N_Subexpr + and then not In_Any_Integer_Context + then + Check_Non_Static_Context (N); + end if; + + -- Modular integer literals must be in their base range + + if Is_Modular_Integer_Type (T) + and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) + then + Out_Of_Range (N); + end if; + end Eval_Integer_Literal; + + --------------------- + -- Eval_Logical_Op -- + --------------------- + + -- Logical operations are static functions, so the result is potentially + -- static if both operands are potentially static (RM 4.9(7), 4.9(20)). + + procedure Eval_Logical_Op (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + Stat : Boolean; + Fold : Boolean; + + begin + -- If not foldable we are done + + Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold); + + if not Fold then + return; + end if; + + -- Compile time evaluation of logical operation + + declare + Left_Int : constant Uint := Expr_Value (Left); + Right_Int : constant Uint := Expr_Value (Right); + + begin + -- VMS includes bitwise operations on signed types + + if Is_Modular_Integer_Type (Etype (N)) + or else Is_VMS_Operator (Entity (N)) + then + declare + Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1); + Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1); + + begin + To_Bits (Left_Int, Left_Bits); + To_Bits (Right_Int, Right_Bits); + + -- Note: should really be able to use array ops instead of + -- these loops, but they weren't working at the time ??? + + if Nkind (N) = N_Op_And then + for J in Left_Bits'Range loop + Left_Bits (J) := Left_Bits (J) and Right_Bits (J); + end loop; + + elsif Nkind (N) = N_Op_Or then + for J in Left_Bits'Range loop + Left_Bits (J) := Left_Bits (J) or Right_Bits (J); + end loop; + + else + pragma Assert (Nkind (N) = N_Op_Xor); + + for J in Left_Bits'Range loop + Left_Bits (J) := Left_Bits (J) xor Right_Bits (J); + end loop; + end if; + + Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat); + end; + + else + pragma Assert (Is_Boolean_Type (Etype (N))); + + if Nkind (N) = N_Op_And then + Fold_Uint (N, + Test (Is_True (Left_Int) and then Is_True (Right_Int)), Stat); + + elsif Nkind (N) = N_Op_Or then + Fold_Uint (N, + Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat); + + else + pragma Assert (Nkind (N) = N_Op_Xor); + Fold_Uint (N, + Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat); + end if; + end if; + end; + end Eval_Logical_Op; + + ------------------------ + -- Eval_Membership_Op -- + ------------------------ + + -- A membership test is potentially static if the expression is static, and + -- the range is a potentially static range, or is a subtype mark denoting a + -- static subtype (RM 4.9(12)). + + procedure Eval_Membership_Op (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + Def_Id : Entity_Id; + Lo : Node_Id; + Hi : Node_Id; + Result : Boolean; + Stat : Boolean; + Fold : Boolean; + + begin + -- Ignore if error in either operand, except to make sure that Any_Type + -- is properly propagated to avoid junk cascaded errors. + + if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then + Set_Etype (N, Any_Type); + return; + end if; + + -- Ignore if types involved have predicates + + if Present (Predicate_Function (Etype (Left))) + or else + Present (Predicate_Function (Etype (Right))) + then + return; + end if; + + -- Case of right operand is a subtype name + + if Is_Entity_Name (Right) then + Def_Id := Entity (Right); + + if (Is_Scalar_Type (Def_Id) or else Is_String_Type (Def_Id)) + and then Is_OK_Static_Subtype (Def_Id) + then + Test_Expression_Is_Foldable (N, Left, Stat, Fold); + + if not Fold or else not Stat then + return; + end if; + else + Check_Non_Static_Context (Left); + return; + end if; + + -- For string membership tests we will check the length further on + + if not Is_String_Type (Def_Id) then + Lo := Type_Low_Bound (Def_Id); + Hi := Type_High_Bound (Def_Id); + + else + Lo := Empty; + Hi := Empty; + end if; + + -- Case of right operand is a range + + else + if Is_Static_Range (Right) then + Test_Expression_Is_Foldable (N, Left, Stat, Fold); + + if not Fold or else not Stat then + return; + + -- If one bound of range raises CE, then don't try to fold + + elsif not Is_OK_Static_Range (Right) then + Check_Non_Static_Context (Left); + return; + end if; + + else + Check_Non_Static_Context (Left); + return; + end if; + + -- Here we know range is an OK static range + + Lo := Low_Bound (Right); + Hi := High_Bound (Right); + end if; + + -- For strings we check that the length of the string expression is + -- compatible with the string subtype if the subtype is constrained, + -- or if unconstrained then the test is always true. + + if Is_String_Type (Etype (Right)) then + if not Is_Constrained (Etype (Right)) then + Result := True; + + else + declare + Typlen : constant Uint := String_Type_Len (Etype (Right)); + Strlen : constant Uint := + UI_From_Int + (String_Length (Strval (Get_String_Val (Left)))); + begin + Result := (Typlen = Strlen); + end; + end if; + + -- Fold the membership test. We know we have a static range and Lo and + -- Hi are set to the expressions for the end points of this range. + + elsif Is_Real_Type (Etype (Right)) then + declare + Leftval : constant Ureal := Expr_Value_R (Left); + + begin + Result := Expr_Value_R (Lo) <= Leftval + and then Leftval <= Expr_Value_R (Hi); + end; + + else + declare + Leftval : constant Uint := Expr_Value (Left); + + begin + Result := Expr_Value (Lo) <= Leftval + and then Leftval <= Expr_Value (Hi); + end; + end if; + + if Nkind (N) = N_Not_In then + Result := not Result; + end if; + + Fold_Uint (N, Test (Result), True); + + Warn_On_Known_Condition (N); + end Eval_Membership_Op; + + ------------------------ + -- Eval_Named_Integer -- + ------------------------ + + procedure Eval_Named_Integer (N : Node_Id) is + begin + Fold_Uint (N, + Expr_Value (Expression (Declaration_Node (Entity (N)))), True); + end Eval_Named_Integer; + + --------------------- + -- Eval_Named_Real -- + --------------------- + + procedure Eval_Named_Real (N : Node_Id) is + begin + Fold_Ureal (N, + Expr_Value_R (Expression (Declaration_Node (Entity (N)))), True); + end Eval_Named_Real; + + ------------------- + -- Eval_Op_Expon -- + ------------------- + + -- Exponentiation is a static functions, so the result is potentially + -- static if both operands are potentially static (RM 4.9(7), 4.9(20)). + + procedure Eval_Op_Expon (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + Stat : Boolean; + Fold : Boolean; + + begin + -- If not foldable we are done + + Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold); + + if not Fold then + return; + end if; + + -- Fold exponentiation operation + + declare + Right_Int : constant Uint := Expr_Value (Right); + + begin + -- Integer case + + if Is_Integer_Type (Etype (Left)) then + declare + Left_Int : constant Uint := Expr_Value (Left); + Result : Uint; + + begin + -- Exponentiation of an integer raises Constraint_Error for a + -- negative exponent (RM 4.5.6). + + if Right_Int < 0 then + Apply_Compile_Time_Constraint_Error + (N, "integer exponent negative", + CE_Range_Check_Failed, + Warn => not Stat); + return; + + else + if OK_Bits (N, Num_Bits (Left_Int) * Right_Int) then + Result := Left_Int ** Right_Int; + else + Result := Left_Int; + end if; + + if Is_Modular_Integer_Type (Etype (N)) then + Result := Result mod Modulus (Etype (N)); + end if; + + Fold_Uint (N, Result, Stat); + end if; + end; + + -- Real case + + else + declare + Left_Real : constant Ureal := Expr_Value_R (Left); + + begin + -- Cannot have a zero base with a negative exponent + + if UR_Is_Zero (Left_Real) then + + if Right_Int < 0 then + Apply_Compile_Time_Constraint_Error + (N, "zero ** negative integer", + CE_Range_Check_Failed, + Warn => not Stat); + return; + else + Fold_Ureal (N, Ureal_0, Stat); + end if; + + else + Fold_Ureal (N, Left_Real ** Right_Int, Stat); + end if; + end; + end if; + end; + end Eval_Op_Expon; + + ----------------- + -- Eval_Op_Not -- + ----------------- + + -- The not operation is a static functions, so the result is potentially + -- static if the operand is potentially static (RM 4.9(7), 4.9(20)). + + procedure Eval_Op_Not (N : Node_Id) is + Right : constant Node_Id := Right_Opnd (N); + Stat : Boolean; + Fold : Boolean; + + begin + -- If not foldable we are done + + Test_Expression_Is_Foldable (N, Right, Stat, Fold); + + if not Fold then + return; + end if; + + -- Fold not operation + + declare + Rint : constant Uint := Expr_Value (Right); + Typ : constant Entity_Id := Etype (N); + + begin + -- Negation is equivalent to subtracting from the modulus minus one. + -- For a binary modulus this is equivalent to the ones-complement of + -- the original value. For non-binary modulus this is an arbitrary + -- but consistent definition. + + if Is_Modular_Integer_Type (Typ) then + Fold_Uint (N, Modulus (Typ) - 1 - Rint, Stat); + + else + pragma Assert (Is_Boolean_Type (Typ)); + Fold_Uint (N, Test (not Is_True (Rint)), Stat); + end if; + + Set_Is_Static_Expression (N, Stat); + end; + end Eval_Op_Not; + + ------------------------------- + -- Eval_Qualified_Expression -- + ------------------------------- + + -- A qualified expression is potentially static if its subtype mark denotes + -- a static subtype and its expression is potentially static (RM 4.9 (11)). + + procedure Eval_Qualified_Expression (N : Node_Id) is + Operand : constant Node_Id := Expression (N); + Target_Type : constant Entity_Id := Entity (Subtype_Mark (N)); + + Stat : Boolean; + Fold : Boolean; + Hex : Boolean; + + begin + -- Can only fold if target is string or scalar and subtype is static. + -- Also, do not fold if our parent is an allocator (this is because the + -- qualified expression is really part of the syntactic structure of an + -- allocator, and we do not want to end up with something that + -- corresponds to "new 1" where the 1 is the result of folding a + -- qualified expression). + + if not Is_Static_Subtype (Target_Type) + or else Nkind (Parent (N)) = N_Allocator + then + Check_Non_Static_Context (Operand); + + -- If operand is known to raise constraint_error, set the flag on the + -- expression so it does not get optimized away. + + if Nkind (Operand) = N_Raise_Constraint_Error then + Set_Raises_Constraint_Error (N); + end if; + + return; + end if; + + -- If not foldable we are done + + Test_Expression_Is_Foldable (N, Operand, Stat, Fold); + + if not Fold then + return; + + -- Don't try fold if target type has constraint error bounds + + elsif not Is_OK_Static_Subtype (Target_Type) then + Set_Raises_Constraint_Error (N); + return; + end if; + + -- Here we will fold, save Print_In_Hex indication + + Hex := Nkind (Operand) = N_Integer_Literal + and then Print_In_Hex (Operand); + + -- Fold the result of qualification + + if Is_Discrete_Type (Target_Type) then + Fold_Uint (N, Expr_Value (Operand), Stat); + + -- Preserve Print_In_Hex indication + + if Hex and then Nkind (N) = N_Integer_Literal then + Set_Print_In_Hex (N); + end if; + + elsif Is_Real_Type (Target_Type) then + Fold_Ureal (N, Expr_Value_R (Operand), Stat); + + else + Fold_Str (N, Strval (Get_String_Val (Operand)), Stat); + + if not Stat then + Set_Is_Static_Expression (N, False); + else + Check_String_Literal_Length (N, Target_Type); + end if; + + return; + end if; + + -- The expression may be foldable but not static + + Set_Is_Static_Expression (N, Stat); + + if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then + Out_Of_Range (N); + end if; + end Eval_Qualified_Expression; + + ----------------------- + -- Eval_Real_Literal -- + ----------------------- + + -- Numeric literals are static (RM 4.9(1)), and have already been marked + -- as static by the analyzer. The reason we did it that early is to allow + -- the possibility of turning off the Is_Static_Expression flag after + -- analysis, but before resolution, when integer literals are generated + -- in the expander that do not correspond to static expressions. + + procedure Eval_Real_Literal (N : Node_Id) is + PK : constant Node_Kind := Nkind (Parent (N)); + + begin + -- If the literal appears in a non-expression context and not as part of + -- a number declaration, then it is appearing in a non-static context, + -- so check it. + + if PK not in N_Subexpr and then PK /= N_Number_Declaration then + Check_Non_Static_Context (N); + end if; + end Eval_Real_Literal; + + ------------------------ + -- Eval_Relational_Op -- + ------------------------ + + -- Relational operations are static functions, so the result is static if + -- both operands are static (RM 4.9(7), 4.9(20)), except that for strings, + -- the result is never static, even if the operands are. + + procedure Eval_Relational_Op (N : Node_Id) is + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + Typ : constant Entity_Id := Etype (Left); + Otype : Entity_Id := Empty; + Result : Boolean; + Stat : Boolean; + Fold : Boolean; + + begin + -- One special case to deal with first. If we can tell that the result + -- will be false because the lengths of one or more index subtypes are + -- compile time known and different, then we can replace the entire + -- result by False. We only do this for one dimensional arrays, because + -- the case of multi-dimensional arrays is rare and too much trouble! If + -- one of the operands is an illegal aggregate, its type might still be + -- an arbitrary composite type, so nothing to do. + + if Is_Array_Type (Typ) + and then Typ /= Any_Composite + and then Number_Dimensions (Typ) = 1 + and then (Nkind (N) = N_Op_Eq or else Nkind (N) = N_Op_Ne) + then + if Raises_Constraint_Error (Left) + or else Raises_Constraint_Error (Right) + then + return; + end if; + + -- OK, we have the case where we may be able to do this fold + + Length_Mismatch : declare + procedure Get_Static_Length (Op : Node_Id; Len : out Uint); + -- If Op is an expression for a constrained array with a known at + -- compile time length, then Len is set to this (non-negative + -- length). Otherwise Len is set to minus 1. + + ----------------------- + -- Get_Static_Length -- + ----------------------- + + procedure Get_Static_Length (Op : Node_Id; Len : out Uint) is + T : Entity_Id; + + begin + -- First easy case string literal + + if Nkind (Op) = N_String_Literal then + Len := UI_From_Int (String_Length (Strval (Op))); + return; + end if; + + -- Second easy case, not constrained subtype, so no length + + if not Is_Constrained (Etype (Op)) then + Len := Uint_Minus_1; + return; + end if; + + -- General case + + T := Etype (First_Index (Etype (Op))); + + -- The simple case, both bounds are known at compile time + + if Is_Discrete_Type (T) + and then + Compile_Time_Known_Value (Type_Low_Bound (T)) + and then + Compile_Time_Known_Value (Type_High_Bound (T)) + then + Len := UI_Max (Uint_0, + Expr_Value (Type_High_Bound (T)) - + Expr_Value (Type_Low_Bound (T)) + 1); + return; + end if; + + -- A more complex case, where the bounds are of the form + -- X [+/- K1] .. X [+/- K2]), where X is an expression that is + -- either A'First or A'Last (with A an entity name), or X is an + -- entity name, and the two X's are the same and K1 and K2 are + -- known at compile time, in this case, the length can also be + -- computed at compile time, even though the bounds are not + -- known. A common case of this is e.g. (X'First .. X'First+5). + + Extract_Length : declare + procedure Decompose_Expr + (Expr : Node_Id; + Ent : out Entity_Id; + Kind : out Character; + Cons : out Uint); + -- Given an expression, see if is of the form above, + -- X [+/- K]. If so Ent is set to the entity in X, + -- Kind is 'F','L','E' for 'First/'Last/simple entity, + -- and Cons is the value of K. If the expression is + -- not of the required form, Ent is set to Empty. + + -------------------- + -- Decompose_Expr -- + -------------------- + + procedure Decompose_Expr + (Expr : Node_Id; + Ent : out Entity_Id; + Kind : out Character; + Cons : out Uint) + is + Exp : Node_Id; + + begin + if Nkind (Expr) = N_Op_Add + and then Compile_Time_Known_Value (Right_Opnd (Expr)) + then + Exp := Left_Opnd (Expr); + Cons := Expr_Value (Right_Opnd (Expr)); + + elsif Nkind (Expr) = N_Op_Subtract + and then Compile_Time_Known_Value (Right_Opnd (Expr)) + then + Exp := Left_Opnd (Expr); + Cons := -Expr_Value (Right_Opnd (Expr)); + + -- If the bound is a constant created to remove side + -- effects, recover original expression to see if it has + -- one of the recognizable forms. + + elsif Nkind (Expr) = N_Identifier + and then not Comes_From_Source (Entity (Expr)) + and then Ekind (Entity (Expr)) = E_Constant + and then + Nkind (Parent (Entity (Expr))) = N_Object_Declaration + then + Exp := Expression (Parent (Entity (Expr))); + Decompose_Expr (Exp, Ent, Kind, Cons); + + -- If original expression includes an entity, create a + -- reference to it for use below. + + if Present (Ent) then + Exp := New_Occurrence_Of (Ent, Sloc (Ent)); + end if; + + else + Exp := Expr; + Cons := Uint_0; + end if; + + -- At this stage Exp is set to the potential X + + if Nkind (Exp) = N_Attribute_Reference then + if Attribute_Name (Exp) = Name_First then + Kind := 'F'; + + elsif Attribute_Name (Exp) = Name_Last then + Kind := 'L'; + + else + Ent := Empty; + return; + end if; + + Exp := Prefix (Exp); + + else + Kind := 'E'; + end if; + + if Is_Entity_Name (Exp) + and then Present (Entity (Exp)) + then + Ent := Entity (Exp); + else + Ent := Empty; + end if; + end Decompose_Expr; + + -- Local Variables + + Ent1, Ent2 : Entity_Id; + Kind1, Kind2 : Character; + Cons1, Cons2 : Uint; + + -- Start of processing for Extract_Length + + begin + Decompose_Expr + (Original_Node (Type_Low_Bound (T)), Ent1, Kind1, Cons1); + Decompose_Expr + (Original_Node (Type_High_Bound (T)), Ent2, Kind2, Cons2); + + if Present (Ent1) + and then Kind1 = Kind2 + and then Ent1 = Ent2 + then + Len := Cons2 - Cons1 + 1; + else + Len := Uint_Minus_1; + end if; + end Extract_Length; + end Get_Static_Length; + + -- Local Variables + + Len_L : Uint; + Len_R : Uint; + + -- Start of processing for Length_Mismatch + + begin + Get_Static_Length (Left, Len_L); + Get_Static_Length (Right, Len_R); + + if Len_L /= Uint_Minus_1 + and then Len_R /= Uint_Minus_1 + and then Len_L /= Len_R + then + Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False); + Warn_On_Known_Condition (N); + return; + end if; + end Length_Mismatch; + end if; + + -- Test for expression being foldable + + Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold); + + -- Only comparisons of scalars can give static results. In particular, + -- comparisons of strings never yield a static result, even if both + -- operands are static strings. + + if not Is_Scalar_Type (Typ) then + Stat := False; + Set_Is_Static_Expression (N, False); + end if; + + -- For operators on universal numeric types called as functions with + -- an explicit scope, determine appropriate specific numeric type, and + -- diagnose possible ambiguity. + + if Is_Universal_Numeric_Type (Etype (Left)) + and then + Is_Universal_Numeric_Type (Etype (Right)) + then + Otype := Find_Universal_Operator_Type (N); + end if; + + -- For static real type expressions, we cannot use Compile_Time_Compare + -- since it worries about run-time results which are not exact. + + if Stat and then Is_Real_Type (Typ) then + declare + Left_Real : constant Ureal := Expr_Value_R (Left); + Right_Real : constant Ureal := Expr_Value_R (Right); + + begin + case Nkind (N) is + when N_Op_Eq => Result := (Left_Real = Right_Real); + when N_Op_Ne => Result := (Left_Real /= Right_Real); + when N_Op_Lt => Result := (Left_Real < Right_Real); + when N_Op_Le => Result := (Left_Real <= Right_Real); + when N_Op_Gt => Result := (Left_Real > Right_Real); + when N_Op_Ge => Result := (Left_Real >= Right_Real); + + when others => + raise Program_Error; + end case; + + Fold_Uint (N, Test (Result), True); + end; + + -- For all other cases, we use Compile_Time_Compare to do the compare + + else + declare + CR : constant Compare_Result := + Compile_Time_Compare (Left, Right, Assume_Valid => False); + + begin + if CR = Unknown then + return; + end if; + + case Nkind (N) is + when N_Op_Eq => + if CR = EQ then + Result := True; + elsif CR = NE or else CR = GT or else CR = LT then + Result := False; + else + return; + end if; + + when N_Op_Ne => + if CR = NE or else CR = GT or else CR = LT then + Result := True; + elsif CR = EQ then + Result := False; + else + return; + end if; + + when N_Op_Lt => + if CR = LT then + Result := True; + elsif CR = EQ or else CR = GT or else CR = GE then + Result := False; + else + return; + end if; + + when N_Op_Le => + if CR = LT or else CR = EQ or else CR = LE then + Result := True; + elsif CR = GT then + Result := False; + else + return; + end if; + + when N_Op_Gt => + if CR = GT then + Result := True; + elsif CR = EQ or else CR = LT or else CR = LE then + Result := False; + else + return; + end if; + + when N_Op_Ge => + if CR = GT or else CR = EQ or else CR = GE then + Result := True; + elsif CR = LT then + Result := False; + else + return; + end if; + + when others => + raise Program_Error; + end case; + end; + + Fold_Uint (N, Test (Result), Stat); + end if; + + -- For the case of a folded relational operator on a specific numeric + -- type, freeze operand type now. + + if Present (Otype) then + Freeze_Before (N, Otype); + end if; + + Warn_On_Known_Condition (N); + end Eval_Relational_Op; + + ---------------- + -- Eval_Shift -- + ---------------- + + -- Shift operations are intrinsic operations that can never be static, so + -- the only processing required is to perform the required check for a non + -- static context for the two operands. + + -- Actually we could do some compile time evaluation here some time ??? + + procedure Eval_Shift (N : Node_Id) is + begin + Check_Non_Static_Context (Left_Opnd (N)); + Check_Non_Static_Context (Right_Opnd (N)); + end Eval_Shift; + + ------------------------ + -- Eval_Short_Circuit -- + ------------------------ + + -- A short circuit operation is potentially static if both operands are + -- potentially static (RM 4.9 (13)). + + procedure Eval_Short_Circuit (N : Node_Id) is + Kind : constant Node_Kind := Nkind (N); + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + Left_Int : Uint; + + Rstat : constant Boolean := + Is_Static_Expression (Left) + and then + Is_Static_Expression (Right); + + begin + -- Short circuit operations are never static in Ada 83 + + if Ada_Version = Ada_83 and then Comes_From_Source (N) then + Check_Non_Static_Context (Left); + Check_Non_Static_Context (Right); + return; + end if; + + -- Now look at the operands, we can't quite use the normal call to + -- Test_Expression_Is_Foldable here because short circuit operations + -- are a special case, they can still be foldable, even if the right + -- operand raises constraint error. + + -- If either operand is Any_Type, just propagate to result and do not + -- try to fold, this prevents cascaded errors. + + if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then + Set_Etype (N, Any_Type); + return; + + -- If left operand raises constraint error, then replace node N with + -- the raise constraint error node, and we are obviously not foldable. + -- Is_Static_Expression is set from the two operands in the normal way, + -- and we check the right operand if it is in a non-static context. + + elsif Raises_Constraint_Error (Left) then + if not Rstat then + Check_Non_Static_Context (Right); + end if; + + Rewrite_In_Raise_CE (N, Left); + Set_Is_Static_Expression (N, Rstat); + return; + + -- If the result is not static, then we won't in any case fold + + elsif not Rstat then + Check_Non_Static_Context (Left); + Check_Non_Static_Context (Right); + return; + end if; + + -- Here the result is static, note that, unlike the normal processing + -- in Test_Expression_Is_Foldable, we did *not* check above to see if + -- the right operand raises constraint error, that's because it is not + -- significant if the left operand is decisive. + + Set_Is_Static_Expression (N); + + -- It does not matter if the right operand raises constraint error if + -- it will not be evaluated. So deal specially with the cases where + -- the right operand is not evaluated. Note that we will fold these + -- cases even if the right operand is non-static, which is fine, but + -- of course in these cases the result is not potentially static. + + Left_Int := Expr_Value (Left); + + if (Kind = N_And_Then and then Is_False (Left_Int)) + or else + (Kind = N_Or_Else and then Is_True (Left_Int)) + then + Fold_Uint (N, Left_Int, Rstat); + return; + end if; + + -- If first operand not decisive, then it does matter if the right + -- operand raises constraint error, since it will be evaluated, so + -- we simply replace the node with the right operand. Note that this + -- properly propagates Is_Static_Expression and Raises_Constraint_Error + -- (both are set to True in Right). + + if Raises_Constraint_Error (Right) then + Rewrite_In_Raise_CE (N, Right); + Check_Non_Static_Context (Left); + return; + end if; + + -- Otherwise the result depends on the right operand + + Fold_Uint (N, Expr_Value (Right), Rstat); + return; + end Eval_Short_Circuit; + + ---------------- + -- Eval_Slice -- + ---------------- + + -- Slices can never be static, so the only processing required is to check + -- for non-static context if an explicit range is given. + + procedure Eval_Slice (N : Node_Id) is + Drange : constant Node_Id := Discrete_Range (N); + begin + if Nkind (Drange) = N_Range then + Check_Non_Static_Context (Low_Bound (Drange)); + Check_Non_Static_Context (High_Bound (Drange)); + end if; + + -- A slice of the form A (subtype), when the subtype is the index of + -- the type of A, is redundant, the slice can be replaced with A, and + -- this is worth a warning. + + if Is_Entity_Name (Prefix (N)) then + declare + E : constant Entity_Id := Entity (Prefix (N)); + T : constant Entity_Id := Etype (E); + begin + if Ekind (E) = E_Constant + and then Is_Array_Type (T) + and then Is_Entity_Name (Drange) + then + if Is_Entity_Name (Original_Node (First_Index (T))) + and then Entity (Original_Node (First_Index (T))) + = Entity (Drange) + then + if Warn_On_Redundant_Constructs then + Error_Msg_N ("redundant slice denotes whole array?", N); + end if; + + -- The following might be a useful optimization???? + + -- Rewrite (N, New_Occurrence_Of (E, Sloc (N))); + end if; + end if; + end; + end if; + end Eval_Slice; + + ------------------------- + -- Eval_String_Literal -- + ------------------------- + + procedure Eval_String_Literal (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + Bas : constant Entity_Id := Base_Type (Typ); + Xtp : Entity_Id; + Len : Nat; + Lo : Node_Id; + + begin + -- Nothing to do if error type (handles cases like default expressions + -- or generics where we have not yet fully resolved the type). + + if Bas = Any_Type or else Bas = Any_String then + return; + end if; + + -- String literals are static if the subtype is static (RM 4.9(2)), so + -- reset the static expression flag (it was set unconditionally in + -- Analyze_String_Literal) if the subtype is non-static. We tell if + -- the subtype is static by looking at the lower bound. + + if Ekind (Typ) = E_String_Literal_Subtype then + if not Is_OK_Static_Expression (String_Literal_Low_Bound (Typ)) then + Set_Is_Static_Expression (N, False); + return; + end if; + + -- Here if Etype of string literal is normal Etype (not yet possible, + -- but may be possible in future). + + elsif not Is_OK_Static_Expression + (Type_Low_Bound (Etype (First_Index (Typ)))) + then + Set_Is_Static_Expression (N, False); + return; + end if; + + -- If original node was a type conversion, then result if non-static + + if Nkind (Original_Node (N)) = N_Type_Conversion then + Set_Is_Static_Expression (N, False); + return; + end if; + + -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95 + -- if its bounds are outside the index base type and this index type is + -- static. This can happen in only two ways. Either the string literal + -- is too long, or it is null, and the lower bound is type'First. In + -- either case it is the upper bound that is out of range of the index + -- type. + + if Ada_Version >= Ada_95 then + if Root_Type (Bas) = Standard_String + or else + Root_Type (Bas) = Standard_Wide_String + then + Xtp := Standard_Positive; + else + Xtp := Etype (First_Index (Bas)); + end if; + + if Ekind (Typ) = E_String_Literal_Subtype then + Lo := String_Literal_Low_Bound (Typ); + else + Lo := Type_Low_Bound (Etype (First_Index (Typ))); + end if; + + Len := String_Length (Strval (N)); + + if UI_From_Int (Len) > String_Type_Len (Bas) then + Apply_Compile_Time_Constraint_Error + (N, "string literal too long for}", CE_Length_Check_Failed, + Ent => Bas, + Typ => First_Subtype (Bas)); + + elsif Len = 0 + and then not Is_Generic_Type (Xtp) + and then + Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp))) + then + Apply_Compile_Time_Constraint_Error + (N, "null string literal not allowed for}", + CE_Length_Check_Failed, + Ent => Bas, + Typ => First_Subtype (Bas)); + end if; + end if; + end Eval_String_Literal; + + -------------------------- + -- Eval_Type_Conversion -- + -------------------------- + + -- A type conversion is potentially static if its subtype mark is for a + -- static scalar subtype, and its operand expression is potentially static + -- (RM 4.9(10)). + + procedure Eval_Type_Conversion (N : Node_Id) is + Operand : constant Node_Id := Expression (N); + Source_Type : constant Entity_Id := Etype (Operand); + Target_Type : constant Entity_Id := Etype (N); + + Stat : Boolean; + Fold : Boolean; + + function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean; + -- Returns true if type T is an integer type, or if it is a fixed-point + -- type to be treated as an integer (i.e. the flag Conversion_OK is set + -- on the conversion node). + + function To_Be_Treated_As_Real (T : Entity_Id) return Boolean; + -- Returns true if type T is a floating-point type, or if it is a + -- fixed-point type that is not to be treated as an integer (i.e. the + -- flag Conversion_OK is not set on the conversion node). + + ------------------------------ + -- To_Be_Treated_As_Integer -- + ------------------------------ + + function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is + begin + return + Is_Integer_Type (T) + or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N)); + end To_Be_Treated_As_Integer; + + --------------------------- + -- To_Be_Treated_As_Real -- + --------------------------- + + function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is + begin + return + Is_Floating_Point_Type (T) + or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N)); + end To_Be_Treated_As_Real; + + -- Start of processing for Eval_Type_Conversion + + begin + -- Cannot fold if target type is non-static or if semantic error + + if not Is_Static_Subtype (Target_Type) then + Check_Non_Static_Context (Operand); + return; + + elsif Error_Posted (N) then + return; + end if; + + -- If not foldable we are done + + Test_Expression_Is_Foldable (N, Operand, Stat, Fold); + + if not Fold then + return; + + -- Don't try fold if target type has constraint error bounds + + elsif not Is_OK_Static_Subtype (Target_Type) then + Set_Raises_Constraint_Error (N); + return; + end if; + + -- Remaining processing depends on operand types. Note that in the + -- following type test, fixed-point counts as real unless the flag + -- Conversion_OK is set, in which case it counts as integer. + + -- Fold conversion, case of string type. The result is not static + + if Is_String_Type (Target_Type) then + Fold_Str (N, Strval (Get_String_Val (Operand)), Static => False); + + return; + + -- Fold conversion, case of integer target type + + elsif To_Be_Treated_As_Integer (Target_Type) then + declare + Result : Uint; + + begin + -- Integer to integer conversion + + if To_Be_Treated_As_Integer (Source_Type) then + Result := Expr_Value (Operand); + + -- Real to integer conversion + + else + Result := UR_To_Uint (Expr_Value_R (Operand)); + end if; + + -- If fixed-point type (Conversion_OK must be set), then the + -- result is logically an integer, but we must replace the + -- conversion with the corresponding real literal, since the + -- type from a semantic point of view is still fixed-point. + + if Is_Fixed_Point_Type (Target_Type) then + Fold_Ureal + (N, UR_From_Uint (Result) * Small_Value (Target_Type), Stat); + + -- Otherwise result is integer literal + + else + Fold_Uint (N, Result, Stat); + end if; + end; + + -- Fold conversion, case of real target type + + elsif To_Be_Treated_As_Real (Target_Type) then + declare + Result : Ureal; + + begin + if To_Be_Treated_As_Real (Source_Type) then + Result := Expr_Value_R (Operand); + else + Result := UR_From_Uint (Expr_Value (Operand)); + end if; + + Fold_Ureal (N, Result, Stat); + end; + + -- Enumeration types + + else + Fold_Uint (N, Expr_Value (Operand), Stat); + end if; + + if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then + Out_Of_Range (N); + end if; + + end Eval_Type_Conversion; + + ------------------- + -- Eval_Unary_Op -- + ------------------- + + -- Predefined unary operators are static functions (RM 4.9(20)) and thus + -- are potentially static if the operand is potentially static (RM 4.9(7)). + + procedure Eval_Unary_Op (N : Node_Id) is + Right : constant Node_Id := Right_Opnd (N); + Otype : Entity_Id := Empty; + Stat : Boolean; + Fold : Boolean; + + begin + -- If not foldable we are done + + Test_Expression_Is_Foldable (N, Right, Stat, Fold); + + if not Fold then + return; + end if; + + if Etype (Right) = Universal_Integer + or else + Etype (Right) = Universal_Real + then + Otype := Find_Universal_Operator_Type (N); + end if; + + -- Fold for integer case + + if Is_Integer_Type (Etype (N)) then + declare + Rint : constant Uint := Expr_Value (Right); + Result : Uint; + + begin + -- In the case of modular unary plus and abs there is no need + -- to adjust the result of the operation since if the original + -- operand was in bounds the result will be in the bounds of the + -- modular type. However, in the case of modular unary minus the + -- result may go out of the bounds of the modular type and needs + -- adjustment. + + if Nkind (N) = N_Op_Plus then + Result := Rint; + + elsif Nkind (N) = N_Op_Minus then + if Is_Modular_Integer_Type (Etype (N)) then + Result := (-Rint) mod Modulus (Etype (N)); + else + Result := (-Rint); + end if; + + else + pragma Assert (Nkind (N) = N_Op_Abs); + Result := abs Rint; + end if; + + Fold_Uint (N, Result, Stat); + end; + + -- Fold for real case + + elsif Is_Real_Type (Etype (N)) then + declare + Rreal : constant Ureal := Expr_Value_R (Right); + Result : Ureal; + + begin + if Nkind (N) = N_Op_Plus then + Result := Rreal; + + elsif Nkind (N) = N_Op_Minus then + Result := UR_Negate (Rreal); + + else + pragma Assert (Nkind (N) = N_Op_Abs); + Result := abs Rreal; + end if; + + Fold_Ureal (N, Result, Stat); + end; + end if; + + -- If the operator was resolved to a specific type, make sure that type + -- is frozen even if the expression is folded into a literal (which has + -- a universal type). + + if Present (Otype) then + Freeze_Before (N, Otype); + end if; + end Eval_Unary_Op; + + ------------------------------- + -- Eval_Unchecked_Conversion -- + ------------------------------- + + -- Unchecked conversions can never be static, so the only required + -- processing is to check for a non-static context for the operand. + + procedure Eval_Unchecked_Conversion (N : Node_Id) is + begin + Check_Non_Static_Context (Expression (N)); + end Eval_Unchecked_Conversion; + + -------------------- + -- Expr_Rep_Value -- + -------------------- + + function Expr_Rep_Value (N : Node_Id) return Uint is + Kind : constant Node_Kind := Nkind (N); + Ent : Entity_Id; + + begin + if Is_Entity_Name (N) then + Ent := Entity (N); + + -- An enumeration literal that was either in the source or created + -- as a result of static evaluation. + + if Ekind (Ent) = E_Enumeration_Literal then + return Enumeration_Rep (Ent); + + -- A user defined static constant + + else + pragma Assert (Ekind (Ent) = E_Constant); + return Expr_Rep_Value (Constant_Value (Ent)); + end if; + + -- An integer literal that was either in the source or created as a + -- result of static evaluation. + + elsif Kind = N_Integer_Literal then + return Intval (N); + + -- A real literal for a fixed-point type. This must be the fixed-point + -- case, either the literal is of a fixed-point type, or it is a bound + -- of a fixed-point type, with type universal real. In either case we + -- obtain the desired value from Corresponding_Integer_Value. + + elsif Kind = N_Real_Literal then + pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N)))); + return Corresponding_Integer_Value (N); + + -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero + + elsif Kind = N_Attribute_Reference + and then Attribute_Name (N) = Name_Null_Parameter + then + return Uint_0; + + -- Otherwise must be character literal + + else + pragma Assert (Kind = N_Character_Literal); + Ent := Entity (N); + + -- Since Character literals of type Standard.Character don't have any + -- defining character literals built for them, they do not have their + -- Entity set, so just use their Char code. Otherwise for user- + -- defined character literals use their Pos value as usual which is + -- the same as the Rep value. + + if No (Ent) then + return Char_Literal_Value (N); + else + return Enumeration_Rep (Ent); + end if; + end if; + end Expr_Rep_Value; + + ---------------- + -- Expr_Value -- + ---------------- + + function Expr_Value (N : Node_Id) return Uint is + Kind : constant Node_Kind := Nkind (N); + CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size); + Ent : Entity_Id; + Val : Uint; + + begin + -- If already in cache, then we know it's compile time known and we can + -- return the value that was previously stored in the cache since + -- compile time known values cannot change. + + if CV_Ent.N = N then + return CV_Ent.V; + end if; + + -- Otherwise proceed to test value + + if Is_Entity_Name (N) then + Ent := Entity (N); + + -- An enumeration literal that was either in the source or created as + -- a result of static evaluation. + + if Ekind (Ent) = E_Enumeration_Literal then + Val := Enumeration_Pos (Ent); + + -- A user defined static constant + + else + pragma Assert (Ekind (Ent) = E_Constant); + Val := Expr_Value (Constant_Value (Ent)); + end if; + + -- An integer literal that was either in the source or created as a + -- result of static evaluation. + + elsif Kind = N_Integer_Literal then + Val := Intval (N); + + -- A real literal for a fixed-point type. This must be the fixed-point + -- case, either the literal is of a fixed-point type, or it is a bound + -- of a fixed-point type, with type universal real. In either case we + -- obtain the desired value from Corresponding_Integer_Value. + + elsif Kind = N_Real_Literal then + + pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N)))); + Val := Corresponding_Integer_Value (N); + + -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero + + elsif Kind = N_Attribute_Reference + and then Attribute_Name (N) = Name_Null_Parameter + then + Val := Uint_0; + + -- Otherwise must be character literal + + else + pragma Assert (Kind = N_Character_Literal); + Ent := Entity (N); + + -- Since Character literals of type Standard.Character don't + -- have any defining character literals built for them, they + -- do not have their Entity set, so just use their Char + -- code. Otherwise for user-defined character literals use + -- their Pos value as usual. + + if No (Ent) then + Val := Char_Literal_Value (N); + else + Val := Enumeration_Pos (Ent); + end if; + end if; + + -- Come here with Val set to value to be returned, set cache + + CV_Ent.N := N; + CV_Ent.V := Val; + return Val; + end Expr_Value; + + ------------------ + -- Expr_Value_E -- + ------------------ + + function Expr_Value_E (N : Node_Id) return Entity_Id is + Ent : constant Entity_Id := Entity (N); + + begin + if Ekind (Ent) = E_Enumeration_Literal then + return Ent; + else + pragma Assert (Ekind (Ent) = E_Constant); + return Expr_Value_E (Constant_Value (Ent)); + end if; + end Expr_Value_E; + + ------------------ + -- Expr_Value_R -- + ------------------ + + function Expr_Value_R (N : Node_Id) return Ureal is + Kind : constant Node_Kind := Nkind (N); + Ent : Entity_Id; + Expr : Node_Id; + + begin + if Kind = N_Real_Literal then + return Realval (N); + + elsif Kind = N_Identifier or else Kind = N_Expanded_Name then + Ent := Entity (N); + pragma Assert (Ekind (Ent) = E_Constant); + return Expr_Value_R (Constant_Value (Ent)); + + elsif Kind = N_Integer_Literal then + return UR_From_Uint (Expr_Value (N)); + + -- Strange case of VAX literals, which are at this stage transformed + -- into Vax_Type!x_To_y(IEEE_Literal). See Expand_N_Real_Literal in + -- Exp_Vfpt for further details. + + elsif Vax_Float (Etype (N)) + and then Nkind (N) = N_Unchecked_Type_Conversion + then + Expr := Expression (N); + + if Nkind (Expr) = N_Function_Call + and then Present (Parameter_Associations (Expr)) + then + Expr := First (Parameter_Associations (Expr)); + + if Nkind (Expr) = N_Real_Literal then + return Realval (Expr); + end if; + end if; + + -- Peculiar VMS case, if we have xxx'Null_Parameter, return 0.0 + + elsif Kind = N_Attribute_Reference + and then Attribute_Name (N) = Name_Null_Parameter + then + return Ureal_0; + end if; + + -- If we fall through, we have a node that cannot be interpreted as a + -- compile time constant. That is definitely an error. + + raise Program_Error; + end Expr_Value_R; + + ------------------ + -- Expr_Value_S -- + ------------------ + + function Expr_Value_S (N : Node_Id) return Node_Id is + begin + if Nkind (N) = N_String_Literal then + return N; + else + pragma Assert (Ekind (Entity (N)) = E_Constant); + return Expr_Value_S (Constant_Value (Entity (N))); + end if; + end Expr_Value_S; + + ---------------------------------- + -- Find_Universal_Operator_Type -- + ---------------------------------- + + function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id is + PN : constant Node_Id := Parent (N); + Call : constant Node_Id := Original_Node (N); + Is_Int : constant Boolean := Is_Integer_Type (Etype (N)); + + Is_Fix : constant Boolean := + Nkind (N) in N_Binary_Op + and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N)); + -- A mixed-mode operation in this context indicates the presence of + -- fixed-point type in the designated package. + + Is_Relational : constant Boolean := Etype (N) = Standard_Boolean; + -- Case where N is a relational (or membership) operator (else it is an + -- arithmetic one). + + In_Membership : constant Boolean := + Nkind (PN) in N_Membership_Test + and then + Nkind (Right_Opnd (PN)) = N_Range + and then + Is_Universal_Numeric_Type (Etype (Left_Opnd (PN))) + and then + Is_Universal_Numeric_Type + (Etype (Low_Bound (Right_Opnd (PN)))) + and then + Is_Universal_Numeric_Type + (Etype (High_Bound (Right_Opnd (PN)))); + -- Case where N is part of a membership test with a universal range + + E : Entity_Id; + Pack : Entity_Id; + Typ1 : Entity_Id := Empty; + Priv_E : Entity_Id; + + function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean; + -- Check whether one operand is a mixed-mode operation that requires the + -- presence of a fixed-point type. Given that all operands are universal + -- and have been constant-folded, retrieve the original function call. + + --------------------------- + -- Is_Mixed_Mode_Operand -- + --------------------------- + + function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean is + Onod : constant Node_Id := Original_Node (Op); + begin + return Nkind (Onod) = N_Function_Call + and then Present (Next_Actual (First_Actual (Onod))) + and then Etype (First_Actual (Onod)) /= + Etype (Next_Actual (First_Actual (Onod))); + end Is_Mixed_Mode_Operand; + + -- Start of processing for Find_Universal_Operator_Type + + begin + if Nkind (Call) /= N_Function_Call + or else Nkind (Name (Call)) /= N_Expanded_Name + then + return Empty; + + -- There are several cases where the context does not imply the type of + -- the operands: + -- - the universal expression appears in a type conversion; + -- - the expression is a relational operator applied to universal + -- operands; + -- - the expression is a membership test with a universal operand + -- and a range with universal bounds. + + elsif Nkind (Parent (N)) = N_Type_Conversion + or else Is_Relational + or else In_Membership + then + Pack := Entity (Prefix (Name (Call))); + + -- If the prefix is a package declared elsewhere, iterate over its + -- visible entities, otherwise iterate over all declarations in the + -- designated scope. + + if Ekind (Pack) = E_Package + and then not In_Open_Scopes (Pack) + then + Priv_E := First_Private_Entity (Pack); + else + Priv_E := Empty; + end if; + + Typ1 := Empty; + E := First_Entity (Pack); + while Present (E) and then E /= Priv_E loop + if Is_Numeric_Type (E) + and then Nkind (Parent (E)) /= N_Subtype_Declaration + and then Comes_From_Source (E) + and then Is_Integer_Type (E) = Is_Int + and then + (Nkind (N) in N_Unary_Op + or else Is_Relational + or else Is_Fixed_Point_Type (E) = Is_Fix) + then + if No (Typ1) then + Typ1 := E; + + -- Before emitting an error, check for the presence of a + -- mixed-mode operation that specifies a fixed point type. + + elsif Is_Relational + and then + (Is_Mixed_Mode_Operand (Left_Opnd (N)) + or else Is_Mixed_Mode_Operand (Right_Opnd (N))) + and then Is_Fixed_Point_Type (E) /= Is_Fixed_Point_Type (Typ1) + + then + if Is_Fixed_Point_Type (E) then + Typ1 := E; + end if; + + else + -- More than one type of the proper class declared in P + + Error_Msg_N ("ambiguous operation", N); + Error_Msg_Sloc := Sloc (Typ1); + Error_Msg_N ("\possible interpretation (inherited)#", N); + Error_Msg_Sloc := Sloc (E); + Error_Msg_N ("\possible interpretation (inherited)#", N); + return Empty; + end if; + end if; + + Next_Entity (E); + end loop; + end if; + + return Typ1; + end Find_Universal_Operator_Type; + + -------------------------- + -- Flag_Non_Static_Expr -- + -------------------------- + + procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id) is + begin + if Error_Posted (Expr) and then not All_Errors_Mode then + return; + else + Error_Msg_F (Msg, Expr); + Why_Not_Static (Expr); + end if; + end Flag_Non_Static_Expr; + + -------------- + -- Fold_Str -- + -------------- + + procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + + begin + Rewrite (N, Make_String_Literal (Loc, Strval => Val)); + + -- We now have the literal with the right value, both the actual type + -- and the expected type of this literal are taken from the expression + -- that was evaluated. + + Analyze (N); + Set_Is_Static_Expression (N, Static); + Set_Etype (N, Typ); + Resolve (N); + end Fold_Str; + + --------------- + -- Fold_Uint -- + --------------- + + procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean) is + Loc : constant Source_Ptr := Sloc (N); + Typ : Entity_Id := Etype (N); + Ent : Entity_Id; + + begin + -- If we are folding a named number, retain the entity in the literal, + -- for ASIS use. + + if Is_Entity_Name (N) + and then Ekind (Entity (N)) = E_Named_Integer + then + Ent := Entity (N); + else + Ent := Empty; + end if; + + if Is_Private_Type (Typ) then + Typ := Full_View (Typ); + end if; + + -- For a result of type integer, substitute an N_Integer_Literal node + -- for the result of the compile time evaluation of the expression. + -- For ASIS use, set a link to the original named number when not in + -- a generic context. + + if Is_Integer_Type (Typ) then + Rewrite (N, Make_Integer_Literal (Loc, Val)); + + Set_Original_Entity (N, Ent); + + -- Otherwise we have an enumeration type, and we substitute either + -- an N_Identifier or N_Character_Literal to represent the enumeration + -- literal corresponding to the given value, which must always be in + -- range, because appropriate tests have already been made for this. + + else pragma Assert (Is_Enumeration_Type (Typ)); + Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc)); + end if; + + -- We now have the literal with the right value, both the actual type + -- and the expected type of this literal are taken from the expression + -- that was evaluated. + + Analyze (N); + Set_Is_Static_Expression (N, Static); + Set_Etype (N, Typ); + Resolve (N); + end Fold_Uint; + + ---------------- + -- Fold_Ureal -- + ---------------- + + procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Ent : Entity_Id; + + begin + -- If we are folding a named number, retain the entity in the literal, + -- for ASIS use. + + if Is_Entity_Name (N) + and then Ekind (Entity (N)) = E_Named_Real + then + Ent := Entity (N); + else + Ent := Empty; + end if; + + Rewrite (N, Make_Real_Literal (Loc, Realval => Val)); + + -- Set link to original named number, for ASIS use + + Set_Original_Entity (N, Ent); + + -- Both the actual and expected type comes from the original expression + + Analyze (N); + Set_Is_Static_Expression (N, Static); + Set_Etype (N, Typ); + Resolve (N); + end Fold_Ureal; + + --------------- + -- From_Bits -- + --------------- + + function From_Bits (B : Bits; T : Entity_Id) return Uint is + V : Uint := Uint_0; + + begin + for J in 0 .. B'Last loop + if B (J) then + V := V + 2 ** J; + end if; + end loop; + + if Non_Binary_Modulus (T) then + V := V mod Modulus (T); + end if; + + return V; + end From_Bits; + + -------------------- + -- Get_String_Val -- + -------------------- + + function Get_String_Val (N : Node_Id) return Node_Id is + begin + if Nkind (N) = N_String_Literal then + return N; + + elsif Nkind (N) = N_Character_Literal then + return N; + + else + pragma Assert (Is_Entity_Name (N)); + return Get_String_Val (Constant_Value (Entity (N))); + end if; + end Get_String_Val; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + CV_Cache := (others => (Node_High_Bound, Uint_0)); + end Initialize; + + -------------------- + -- In_Subrange_Of -- + -------------------- + + function In_Subrange_Of + (T1 : Entity_Id; + T2 : Entity_Id; + Fixed_Int : Boolean := False) return Boolean + is + L1 : Node_Id; + H1 : Node_Id; + + L2 : Node_Id; + H2 : Node_Id; + + begin + if T1 = T2 or else Is_Subtype_Of (T1, T2) then + return True; + + -- Never in range if both types are not scalar. Don't know if this can + -- actually happen, but just in case. + + elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T1) then + return False; + + -- If T1 has infinities but T2 doesn't have infinities, then T1 is + -- definitely not compatible with T2. + + elsif Is_Floating_Point_Type (T1) + and then Has_Infinities (T1) + and then Is_Floating_Point_Type (T2) + and then not Has_Infinities (T2) + then + return False; + + else + L1 := Type_Low_Bound (T1); + H1 := Type_High_Bound (T1); + + L2 := Type_Low_Bound (T2); + H2 := Type_High_Bound (T2); + + -- Check bounds to see if comparison possible at compile time + + if Compile_Time_Compare (L1, L2, Assume_Valid => True) in Compare_GE + and then + Compile_Time_Compare (H1, H2, Assume_Valid => True) in Compare_LE + then + return True; + end if; + + -- If bounds not comparable at compile time, then the bounds of T2 + -- must be compile time known or we cannot answer the query. + + if not Compile_Time_Known_Value (L2) + or else not Compile_Time_Known_Value (H2) + then + return False; + end if; + + -- If the bounds of T1 are know at compile time then use these + -- ones, otherwise use the bounds of the base type (which are of + -- course always static). + + if not Compile_Time_Known_Value (L1) then + L1 := Type_Low_Bound (Base_Type (T1)); + end if; + + if not Compile_Time_Known_Value (H1) then + H1 := Type_High_Bound (Base_Type (T1)); + end if; + + -- Fixed point types should be considered as such only if + -- flag Fixed_Int is set to False. + + if Is_Floating_Point_Type (T1) or else Is_Floating_Point_Type (T2) + or else (Is_Fixed_Point_Type (T1) and then not Fixed_Int) + or else (Is_Fixed_Point_Type (T2) and then not Fixed_Int) + then + return + Expr_Value_R (L2) <= Expr_Value_R (L1) + and then + Expr_Value_R (H2) >= Expr_Value_R (H1); + + else + return + Expr_Value (L2) <= Expr_Value (L1) + and then + Expr_Value (H2) >= Expr_Value (H1); + + end if; + end if; + + -- If any exception occurs, it means that we have some bug in the compiler + -- possibly triggered by a previous error, or by some unforeseen peculiar + -- occurrence. However, this is only an optimization attempt, so there is + -- really no point in crashing the compiler. Instead we just decide, too + -- bad, we can't figure out the answer in this case after all. + + exception + when others => + + -- Debug flag K disables this behavior (useful for debugging) + + if Debug_Flag_K then + raise; + else + return False; + end if; + end In_Subrange_Of; + + ----------------- + -- Is_In_Range -- + ----------------- + + function Is_In_Range + (N : Node_Id; + Typ : Entity_Id; + Assume_Valid : Boolean := False; + Fixed_Int : Boolean := False; + Int_Real : Boolean := False) return Boolean + is + begin + return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) + = In_Range; + end Is_In_Range; + + ------------------- + -- Is_Null_Range -- + ------------------- + + function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is + Typ : constant Entity_Id := Etype (Lo); + + begin + if not Compile_Time_Known_Value (Lo) + or else not Compile_Time_Known_Value (Hi) + then + return False; + end if; + + if Is_Discrete_Type (Typ) then + return Expr_Value (Lo) > Expr_Value (Hi); + + else + pragma Assert (Is_Real_Type (Typ)); + return Expr_Value_R (Lo) > Expr_Value_R (Hi); + end if; + end Is_Null_Range; + + ----------------------------- + -- Is_OK_Static_Expression -- + ----------------------------- + + function Is_OK_Static_Expression (N : Node_Id) return Boolean is + begin + return Is_Static_Expression (N) + and then not Raises_Constraint_Error (N); + end Is_OK_Static_Expression; + + ------------------------ + -- Is_OK_Static_Range -- + ------------------------ + + -- A static range is a range whose bounds are static expressions, or a + -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)). + -- We have already converted range attribute references, so we get the + -- "or" part of this rule without needing a special test. + + function Is_OK_Static_Range (N : Node_Id) return Boolean is + begin + return Is_OK_Static_Expression (Low_Bound (N)) + and then Is_OK_Static_Expression (High_Bound (N)); + end Is_OK_Static_Range; + + -------------------------- + -- Is_OK_Static_Subtype -- + -------------------------- + + -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where + -- neither bound raises constraint error when evaluated. + + function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is + Base_T : constant Entity_Id := Base_Type (Typ); + Anc_Subt : Entity_Id; + + begin + -- First a quick check on the non static subtype flag. As described + -- in further detail in Einfo, this flag is not decisive in all cases, + -- but if it is set, then the subtype is definitely non-static. + + if Is_Non_Static_Subtype (Typ) then + return False; + end if; + + Anc_Subt := Ancestor_Subtype (Typ); + + if Anc_Subt = Empty then + Anc_Subt := Base_T; + end if; + + if Is_Generic_Type (Root_Type (Base_T)) + or else Is_Generic_Actual_Type (Base_T) + then + return False; + + -- String types + + elsif Is_String_Type (Typ) then + return + Ekind (Typ) = E_String_Literal_Subtype + or else + (Is_OK_Static_Subtype (Component_Type (Typ)) + and then Is_OK_Static_Subtype (Etype (First_Index (Typ)))); + + -- Scalar types + + elsif Is_Scalar_Type (Typ) then + if Base_T = Typ then + return True; + + else + -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use + -- Get_Type_{Low,High}_Bound. + + return Is_OK_Static_Subtype (Anc_Subt) + and then Is_OK_Static_Expression (Type_Low_Bound (Typ)) + and then Is_OK_Static_Expression (Type_High_Bound (Typ)); + end if; + + -- Types other than string and scalar types are never static + + else + return False; + end if; + end Is_OK_Static_Subtype; + + --------------------- + -- Is_Out_Of_Range -- + --------------------- + + function Is_Out_Of_Range + (N : Node_Id; + Typ : Entity_Id; + Assume_Valid : Boolean := False; + Fixed_Int : Boolean := False; + Int_Real : Boolean := False) return Boolean + is + begin + return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) + = Out_Of_Range; + end Is_Out_Of_Range; + + --------------------- + -- Is_Static_Range -- + --------------------- + + -- A static range is a range whose bounds are static expressions, or a + -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)). + -- We have already converted range attribute references, so we get the + -- "or" part of this rule without needing a special test. + + function Is_Static_Range (N : Node_Id) return Boolean is + begin + return Is_Static_Expression (Low_Bound (N)) + and then Is_Static_Expression (High_Bound (N)); + end Is_Static_Range; + + ----------------------- + -- Is_Static_Subtype -- + ----------------------- + + -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) + + function Is_Static_Subtype (Typ : Entity_Id) return Boolean is + Base_T : constant Entity_Id := Base_Type (Typ); + Anc_Subt : Entity_Id; + + begin + -- First a quick check on the non static subtype flag. As described + -- in further detail in Einfo, this flag is not decisive in all cases, + -- but if it is set, then the subtype is definitely non-static. + + if Is_Non_Static_Subtype (Typ) then + return False; + end if; + + Anc_Subt := Ancestor_Subtype (Typ); + + if Anc_Subt = Empty then + Anc_Subt := Base_T; + end if; + + if Is_Generic_Type (Root_Type (Base_T)) + or else Is_Generic_Actual_Type (Base_T) + then + return False; + + -- String types + + elsif Is_String_Type (Typ) then + return + Ekind (Typ) = E_String_Literal_Subtype + or else + (Is_Static_Subtype (Component_Type (Typ)) + and then Is_Static_Subtype (Etype (First_Index (Typ)))); + + -- Scalar types + + elsif Is_Scalar_Type (Typ) then + if Base_T = Typ then + return True; + + else + return Is_Static_Subtype (Anc_Subt) + and then Is_Static_Expression (Type_Low_Bound (Typ)) + and then Is_Static_Expression (Type_High_Bound (Typ)); + end if; + + -- Types other than string and scalar types are never static + + else + return False; + end if; + end Is_Static_Subtype; + + -------------------- + -- Not_Null_Range -- + -------------------- + + function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is + Typ : constant Entity_Id := Etype (Lo); + + begin + if not Compile_Time_Known_Value (Lo) + or else not Compile_Time_Known_Value (Hi) + then + return False; + end if; + + if Is_Discrete_Type (Typ) then + return Expr_Value (Lo) <= Expr_Value (Hi); + + else + pragma Assert (Is_Real_Type (Typ)); + + return Expr_Value_R (Lo) <= Expr_Value_R (Hi); + end if; + end Not_Null_Range; + + ------------- + -- OK_Bits -- + ------------- + + function OK_Bits (N : Node_Id; Bits : Uint) return Boolean is + begin + -- We allow a maximum of 500,000 bits which seems a reasonable limit + + if Bits < 500_000 then + return True; + + else + Error_Msg_N ("static value too large, capacity exceeded", N); + return False; + end if; + end OK_Bits; + + ------------------ + -- Out_Of_Range -- + ------------------ + + procedure Out_Of_Range (N : Node_Id) is + begin + -- If we have the static expression case, then this is an illegality + -- in Ada 95 mode, except that in an instance, we never generate an + -- error (if the error is legitimate, it was already diagnosed in the + -- template). The expression to compute the length of a packed array is + -- attached to the array type itself, and deserves a separate message. + + if Is_Static_Expression (N) + and then not In_Instance + and then not In_Inlined_Body + and then Ada_Version >= Ada_95 + then + if Nkind (Parent (N)) = N_Defining_Identifier + and then Is_Array_Type (Parent (N)) + and then Present (Packed_Array_Type (Parent (N))) + and then Present (First_Rep_Item (Parent (N))) + then + Error_Msg_N + ("length of packed array must not exceed Integer''Last", + First_Rep_Item (Parent (N))); + Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1)); + + else + Apply_Compile_Time_Constraint_Error + (N, "value not in range of}", CE_Range_Check_Failed); + end if; + + -- Here we generate a warning for the Ada 83 case, or when we are in an + -- instance, or when we have a non-static expression case. + + else + Apply_Compile_Time_Constraint_Error + (N, "value not in range of}?", CE_Range_Check_Failed); + end if; + end Out_Of_Range; + + ------------------------- + -- Rewrite_In_Raise_CE -- + ------------------------- + + procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is + Typ : constant Entity_Id := Etype (N); + + begin + -- If we want to raise CE in the condition of a N_Raise_CE node + -- we may as well get rid of the condition. + + if Present (Parent (N)) + and then Nkind (Parent (N)) = N_Raise_Constraint_Error + then + Set_Condition (Parent (N), Empty); + + -- If the expression raising CE is a N_Raise_CE node, we can use that + -- one. We just preserve the type of the context. + + elsif Nkind (Exp) = N_Raise_Constraint_Error then + Rewrite (N, Exp); + Set_Etype (N, Typ); + + -- Else build an explcit N_Raise_CE + + else + Rewrite (N, + Make_Raise_Constraint_Error (Sloc (Exp), + Reason => CE_Range_Check_Failed)); + Set_Raises_Constraint_Error (N); + Set_Etype (N, Typ); + end if; + end Rewrite_In_Raise_CE; + + --------------------- + -- String_Type_Len -- + --------------------- + + function String_Type_Len (Stype : Entity_Id) return Uint is + NT : constant Entity_Id := Etype (First_Index (Stype)); + T : Entity_Id; + + begin + if Is_OK_Static_Subtype (NT) then + T := NT; + else + T := Base_Type (NT); + end if; + + return Expr_Value (Type_High_Bound (T)) - + Expr_Value (Type_Low_Bound (T)) + 1; + end String_Type_Len; + + ------------------------------------ + -- Subtypes_Statically_Compatible -- + ------------------------------------ + + function Subtypes_Statically_Compatible + (T1 : Entity_Id; + T2 : Entity_Id) return Boolean + is + begin + -- Scalar types + + if Is_Scalar_Type (T1) then + + -- Definitely compatible if we match + + if Subtypes_Statically_Match (T1, T2) then + return True; + + -- If either subtype is nonstatic then they're not compatible + + elsif not Is_Static_Subtype (T1) + or else not Is_Static_Subtype (T2) + then + return False; + + -- If either type has constraint error bounds, then consider that + -- they match to avoid junk cascaded errors here. + + elsif not Is_OK_Static_Subtype (T1) + or else not Is_OK_Static_Subtype (T2) + then + return True; + + -- Base types must match, but we don't check that (should we???) but + -- we do at least check that both types are real, or both types are + -- not real. + + elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then + return False; + + -- Here we check the bounds + + else + declare + LB1 : constant Node_Id := Type_Low_Bound (T1); + HB1 : constant Node_Id := Type_High_Bound (T1); + LB2 : constant Node_Id := Type_Low_Bound (T2); + HB2 : constant Node_Id := Type_High_Bound (T2); + + begin + if Is_Real_Type (T1) then + return + (Expr_Value_R (LB1) > Expr_Value_R (HB1)) + or else + (Expr_Value_R (LB2) <= Expr_Value_R (LB1) + and then + Expr_Value_R (HB1) <= Expr_Value_R (HB2)); + + else + return + (Expr_Value (LB1) > Expr_Value (HB1)) + or else + (Expr_Value (LB2) <= Expr_Value (LB1) + and then + Expr_Value (HB1) <= Expr_Value (HB2)); + end if; + end; + end if; + + -- Access types + + elsif Is_Access_Type (T1) then + return (not Is_Constrained (T2) + or else (Subtypes_Statically_Match + (Designated_Type (T1), Designated_Type (T2)))) + and then not (Can_Never_Be_Null (T2) + and then not Can_Never_Be_Null (T1)); + + -- All other cases + + else + return (Is_Composite_Type (T1) and then not Is_Constrained (T2)) + or else Subtypes_Statically_Match (T1, T2); + end if; + end Subtypes_Statically_Compatible; + + ------------------------------- + -- Subtypes_Statically_Match -- + ------------------------------- + + -- Subtypes statically match if they have statically matching constraints + -- (RM 4.9.1(2)). Constraints statically match if there are none, or if + -- they are the same identical constraint, or if they are static and the + -- values match (RM 4.9.1(1)). + + function Subtypes_Statically_Match (T1, T2 : Entity_Id) return Boolean is + begin + -- A type always statically matches itself + + if T1 = T2 then + return True; + + -- Scalar types + + elsif Is_Scalar_Type (T1) then + + -- Base types must be the same + + if Base_Type (T1) /= Base_Type (T2) then + return False; + end if; + + -- A constrained numeric subtype never matches an unconstrained + -- subtype, i.e. both types must be constrained or unconstrained. + + -- To understand the requirement for this test, see RM 4.9.1(1). + -- As is made clear in RM 3.5.4(11), type Integer, for example is + -- a constrained subtype with constraint bounds matching the bounds + -- of its corresponding unconstrained base type. In this situation, + -- Integer and Integer'Base do not statically match, even though + -- they have the same bounds. + + -- We only apply this test to types in Standard and types that appear + -- in user programs. That way, we do not have to be too careful about + -- setting Is_Constrained right for Itypes. + + if Is_Numeric_Type (T1) + and then (Is_Constrained (T1) /= Is_Constrained (T2)) + and then (Scope (T1) = Standard_Standard + or else Comes_From_Source (T1)) + and then (Scope (T2) = Standard_Standard + or else Comes_From_Source (T2)) + then + return False; + + -- A generic scalar type does not statically match its base type + -- (AI-311). In this case we make sure that the formals, which are + -- first subtypes of their bases, are constrained. + + elsif Is_Generic_Type (T1) + and then Is_Generic_Type (T2) + and then (Is_Constrained (T1) /= Is_Constrained (T2)) + then + return False; + end if; + + -- If there was an error in either range, then just assume the types + -- statically match to avoid further junk errors. + + if No (Scalar_Range (T1)) or else No (Scalar_Range (T2)) + or else Error_Posted (Scalar_Range (T1)) + or else Error_Posted (Scalar_Range (T2)) + then + return True; + end if; + + -- Otherwise both types have bound that can be compared + + declare + LB1 : constant Node_Id := Type_Low_Bound (T1); + HB1 : constant Node_Id := Type_High_Bound (T1); + LB2 : constant Node_Id := Type_Low_Bound (T2); + HB2 : constant Node_Id := Type_High_Bound (T2); + + begin + -- If the bounds are the same tree node, then match + + if LB1 = LB2 and then HB1 = HB2 then + return True; + + -- Otherwise bounds must be static and identical value + + else + if not Is_Static_Subtype (T1) + or else not Is_Static_Subtype (T2) + then + return False; + + -- If either type has constraint error bounds, then say that + -- they match to avoid junk cascaded errors here. + + elsif not Is_OK_Static_Subtype (T1) + or else not Is_OK_Static_Subtype (T2) + then + return True; + + elsif Is_Real_Type (T1) then + return + (Expr_Value_R (LB1) = Expr_Value_R (LB2)) + and then + (Expr_Value_R (HB1) = Expr_Value_R (HB2)); + + else + return + Expr_Value (LB1) = Expr_Value (LB2) + and then + Expr_Value (HB1) = Expr_Value (HB2); + end if; + end if; + end; + + -- Type with discriminants + + elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then + + -- Because of view exchanges in multiple instantiations, conformance + -- checking might try to match a partial view of a type with no + -- discriminants with a full view that has defaulted discriminants. + -- In such a case, use the discriminant constraint of the full view, + -- which must exist because we know that the two subtypes have the + -- same base type. + + if Has_Discriminants (T1) /= Has_Discriminants (T2) then + if In_Instance then + if Is_Private_Type (T2) + and then Present (Full_View (T2)) + and then Has_Discriminants (Full_View (T2)) + then + return Subtypes_Statically_Match (T1, Full_View (T2)); + + elsif Is_Private_Type (T1) + and then Present (Full_View (T1)) + and then Has_Discriminants (Full_View (T1)) + then + return Subtypes_Statically_Match (Full_View (T1), T2); + + else + return False; + end if; + else + return False; + end if; + end if; + + declare + DL1 : constant Elist_Id := Discriminant_Constraint (T1); + DL2 : constant Elist_Id := Discriminant_Constraint (T2); + + DA1 : Elmt_Id; + DA2 : Elmt_Id; + + begin + if DL1 = DL2 then + return True; + elsif Is_Constrained (T1) /= Is_Constrained (T2) then + return False; + end if; + + -- Now loop through the discriminant constraints + + -- Note: the guard here seems necessary, since it is possible at + -- least for DL1 to be No_Elist. Not clear this is reasonable ??? + + if Present (DL1) and then Present (DL2) then + DA1 := First_Elmt (DL1); + DA2 := First_Elmt (DL2); + while Present (DA1) loop + declare + Expr1 : constant Node_Id := Node (DA1); + Expr2 : constant Node_Id := Node (DA2); + + begin + if not Is_Static_Expression (Expr1) + or else not Is_Static_Expression (Expr2) + then + return False; + + -- If either expression raised a constraint error, + -- consider the expressions as matching, since this + -- helps to prevent cascading errors. + + elsif Raises_Constraint_Error (Expr1) + or else Raises_Constraint_Error (Expr2) + then + null; + + elsif Expr_Value (Expr1) /= Expr_Value (Expr2) then + return False; + end if; + end; + + Next_Elmt (DA1); + Next_Elmt (DA2); + end loop; + end if; + end; + + return True; + + -- A definite type does not match an indefinite or classwide type. + -- However, a generic type with unknown discriminants may be + -- instantiated with a type with no discriminants, and conformance + -- checking on an inherited operation may compare the actual with the + -- subtype that renames it in the instance. + + elsif + Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2) + then + return + Is_Generic_Actual_Type (T1) or else Is_Generic_Actual_Type (T2); + + -- Array type + + elsif Is_Array_Type (T1) then + + -- If either subtype is unconstrained then both must be, and if both + -- are unconstrained then no further checking is needed. + + if not Is_Constrained (T1) or else not Is_Constrained (T2) then + return not (Is_Constrained (T1) or else Is_Constrained (T2)); + end if; + + -- Both subtypes are constrained, so check that the index subtypes + -- statically match. + + declare + Index1 : Node_Id := First_Index (T1); + Index2 : Node_Id := First_Index (T2); + + begin + while Present (Index1) loop + if not + Subtypes_Statically_Match (Etype (Index1), Etype (Index2)) + then + return False; + end if; + + Next_Index (Index1); + Next_Index (Index2); + end loop; + + return True; + end; + + elsif Is_Access_Type (T1) then + if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then + return False; + + elsif Ekind_In (T1, E_Access_Subprogram_Type, + E_Anonymous_Access_Subprogram_Type) + then + return + Subtype_Conformant + (Designated_Type (T1), + Designated_Type (T2)); + else + return + Subtypes_Statically_Match + (Designated_Type (T1), + Designated_Type (T2)) + and then Is_Access_Constant (T1) = Is_Access_Constant (T2); + end if; + + -- All other types definitely match + + else + return True; + end if; + end Subtypes_Statically_Match; + + ---------- + -- Test -- + ---------- + + function Test (Cond : Boolean) return Uint is + begin + if Cond then + return Uint_1; + else + return Uint_0; + end if; + end Test; + + --------------------------------- + -- Test_Expression_Is_Foldable -- + --------------------------------- + + -- One operand case + + procedure Test_Expression_Is_Foldable + (N : Node_Id; + Op1 : Node_Id; + Stat : out Boolean; + Fold : out Boolean) + is + begin + Stat := False; + Fold := False; + + if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then + return; + end if; + + -- If operand is Any_Type, just propagate to result and do not + -- try to fold, this prevents cascaded errors. + + if Etype (Op1) = Any_Type then + Set_Etype (N, Any_Type); + return; + + -- If operand raises constraint error, then replace node N with the + -- raise constraint error node, and we are obviously not foldable. + -- Note that this replacement inherits the Is_Static_Expression flag + -- from the operand. + + elsif Raises_Constraint_Error (Op1) then + Rewrite_In_Raise_CE (N, Op1); + return; + + -- If the operand is not static, then the result is not static, and + -- all we have to do is to check the operand since it is now known + -- to appear in a non-static context. + + elsif not Is_Static_Expression (Op1) then + Check_Non_Static_Context (Op1); + Fold := Compile_Time_Known_Value (Op1); + return; + + -- An expression of a formal modular type is not foldable because + -- the modulus is unknown. + + elsif Is_Modular_Integer_Type (Etype (Op1)) + and then Is_Generic_Type (Etype (Op1)) + then + Check_Non_Static_Context (Op1); + return; + + -- Here we have the case of an operand whose type is OK, which is + -- static, and which does not raise constraint error, we can fold. + + else + Set_Is_Static_Expression (N); + Fold := True; + Stat := True; + end if; + end Test_Expression_Is_Foldable; + + -- Two operand case + + procedure Test_Expression_Is_Foldable + (N : Node_Id; + Op1 : Node_Id; + Op2 : Node_Id; + Stat : out Boolean; + Fold : out Boolean) + is + Rstat : constant Boolean := Is_Static_Expression (Op1) + and then Is_Static_Expression (Op2); + + begin + Stat := False; + Fold := False; + + if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then + return; + end if; + + -- If either operand is Any_Type, just propagate to result and + -- do not try to fold, this prevents cascaded errors. + + if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then + Set_Etype (N, Any_Type); + return; + + -- If left operand raises constraint error, then replace node N with the + -- Raise_Constraint_Error node, and we are obviously not foldable. + -- Is_Static_Expression is set from the two operands in the normal way, + -- and we check the right operand if it is in a non-static context. + + elsif Raises_Constraint_Error (Op1) then + if not Rstat then + Check_Non_Static_Context (Op2); + end if; + + Rewrite_In_Raise_CE (N, Op1); + Set_Is_Static_Expression (N, Rstat); + return; + + -- Similar processing for the case of the right operand. Note that we + -- don't use this routine for the short-circuit case, so we do not have + -- to worry about that special case here. + + elsif Raises_Constraint_Error (Op2) then + if not Rstat then + Check_Non_Static_Context (Op1); + end if; + + Rewrite_In_Raise_CE (N, Op2); + Set_Is_Static_Expression (N, Rstat); + return; + + -- Exclude expressions of a generic modular type, as above + + elsif Is_Modular_Integer_Type (Etype (Op1)) + and then Is_Generic_Type (Etype (Op1)) + then + Check_Non_Static_Context (Op1); + return; + + -- If result is not static, then check non-static contexts on operands + -- since one of them may be static and the other one may not be static. + + elsif not Rstat then + Check_Non_Static_Context (Op1); + Check_Non_Static_Context (Op2); + Fold := Compile_Time_Known_Value (Op1) + and then Compile_Time_Known_Value (Op2); + return; + + -- Else result is static and foldable. Both operands are static, and + -- neither raises constraint error, so we can definitely fold. + + else + Set_Is_Static_Expression (N); + Fold := True; + Stat := True; + return; + end if; + end Test_Expression_Is_Foldable; + + ------------------- + -- Test_In_Range -- + ------------------- + + function Test_In_Range + (N : Node_Id; + Typ : Entity_Id; + Assume_Valid : Boolean; + Fixed_Int : Boolean; + Int_Real : Boolean) return Range_Membership + is + Val : Uint; + Valr : Ureal; + + pragma Warnings (Off, Assume_Valid); + -- For now Assume_Valid is unreferenced since the current implementation + -- always returns Unknown if N is not a compile time known value, but we + -- keep the parameter to allow for future enhancements in which we try + -- to get the information in the variable case as well. + + begin + -- Universal types have no range limits, so always in range + + if Typ = Universal_Integer or else Typ = Universal_Real then + return In_Range; + + -- Never known if not scalar type. Don't know if this can actually + -- happen, but our spec allows it, so we must check! + + elsif not Is_Scalar_Type (Typ) then + return Unknown; + + -- Never known if this is a generic type, since the bounds of generic + -- types are junk. Note that if we only checked for static expressions + -- (instead of compile time known values) below, we would not need this + -- check, because values of a generic type can never be static, but they + -- can be known at compile time. + + elsif Is_Generic_Type (Typ) then + return Unknown; + + -- Never known unless we have a compile time known value + + elsif not Compile_Time_Known_Value (N) then + return Unknown; + + -- General processing with a known compile time value + + else + declare + Lo : Node_Id; + Hi : Node_Id; + + LB_Known : Boolean; + HB_Known : Boolean; + + begin + Lo := Type_Low_Bound (Typ); + Hi := Type_High_Bound (Typ); + + LB_Known := Compile_Time_Known_Value (Lo); + HB_Known := Compile_Time_Known_Value (Hi); + + -- Fixed point types should be considered as such only if flag + -- Fixed_Int is set to False. + + if Is_Floating_Point_Type (Typ) + or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int) + or else Int_Real + then + Valr := Expr_Value_R (N); + + if LB_Known and HB_Known then + if Valr >= Expr_Value_R (Lo) + and then + Valr <= Expr_Value_R (Hi) + then + return In_Range; + else + return Out_Of_Range; + end if; + + elsif (LB_Known and then Valr < Expr_Value_R (Lo)) + or else + (HB_Known and then Valr > Expr_Value_R (Hi)) + then + return Out_Of_Range; + + else + return Unknown; + end if; + + else + Val := Expr_Value (N); + + if LB_Known and HB_Known then + if Val >= Expr_Value (Lo) + and then + Val <= Expr_Value (Hi) + then + return In_Range; + else + return Out_Of_Range; + end if; + + elsif (LB_Known and then Val < Expr_Value (Lo)) + or else + (HB_Known and then Val > Expr_Value (Hi)) + then + return Out_Of_Range; + + else + return Unknown; + end if; + end if; + end; + end if; + end Test_In_Range; + + -------------- + -- To_Bits -- + -------------- + + procedure To_Bits (U : Uint; B : out Bits) is + begin + for J in 0 .. B'Last loop + B (J) := (U / (2 ** J)) mod 2 /= 0; + end loop; + end To_Bits; + + -------------------- + -- Why_Not_Static -- + -------------------- + + procedure Why_Not_Static (Expr : Node_Id) is + N : constant Node_Id := Original_Node (Expr); + Typ : Entity_Id; + E : Entity_Id; + + procedure Why_Not_Static_List (L : List_Id); + -- A version that can be called on a list of expressions. Finds all + -- non-static violations in any element of the list. + + ------------------------- + -- Why_Not_Static_List -- + ------------------------- + + procedure Why_Not_Static_List (L : List_Id) is + N : Node_Id; + + begin + if Is_Non_Empty_List (L) then + N := First (L); + while Present (N) loop + Why_Not_Static (N); + Next (N); + end loop; + end if; + end Why_Not_Static_List; + + -- Start of processing for Why_Not_Static + + begin + -- If in ACATS mode (debug flag 2), then suppress all these messages, + -- this avoids massive updates to the ACATS base line. + + if Debug_Flag_2 then + return; + end if; + + -- Ignore call on error or empty node + + if No (Expr) or else Nkind (Expr) = N_Error then + return; + end if; + + -- Preprocessing for sub expressions + + if Nkind (Expr) in N_Subexpr then + + -- Nothing to do if expression is static + + if Is_OK_Static_Expression (Expr) then + return; + end if; + + -- Test for constraint error raised + + if Raises_Constraint_Error (Expr) then + Error_Msg_N + ("expression raises exception, cannot be static " & + "(RM 4.9(34))!", N); + return; + end if; + + -- If no type, then something is pretty wrong, so ignore + + Typ := Etype (Expr); + + if No (Typ) then + return; + end if; + + -- Type must be scalar or string type + + if not Is_Scalar_Type (Typ) + and then not Is_String_Type (Typ) + then + Error_Msg_N + ("static expression must have scalar or string type " & + "(RM 4.9(2))!", N); + return; + end if; + end if; + + -- If we got through those checks, test particular node kind + + case Nkind (N) is + when N_Expanded_Name | N_Identifier | N_Operator_Symbol => + E := Entity (N); + + if Is_Named_Number (E) then + null; + + elsif Ekind (E) = E_Constant then + if not Is_Static_Expression (Constant_Value (E)) then + Error_Msg_NE + ("& is not a static constant (RM 4.9(5))!", N, E); + end if; + + else + Error_Msg_NE + ("& is not static constant or named number " & + "(RM 4.9(5))!", N, E); + end if; + + when N_Binary_Op | N_Short_Circuit | N_Membership_Test => + if Nkind (N) in N_Op_Shift then + Error_Msg_N + ("shift functions are never static (RM 4.9(6,18))!", N); + + else + Why_Not_Static (Left_Opnd (N)); + Why_Not_Static (Right_Opnd (N)); + end if; + + when N_Unary_Op => + Why_Not_Static (Right_Opnd (N)); + + when N_Attribute_Reference => + Why_Not_Static_List (Expressions (N)); + + E := Etype (Prefix (N)); + + if E = Standard_Void_Type then + return; + end if; + + -- Special case non-scalar'Size since this is a common error + + if Attribute_Name (N) = Name_Size then + Error_Msg_N + ("size attribute is only static for static scalar type " & + "(RM 4.9(7,8))", N); + + -- Flag array cases + + elsif Is_Array_Type (E) then + if Attribute_Name (N) /= Name_First + and then + Attribute_Name (N) /= Name_Last + and then + Attribute_Name (N) /= Name_Length + then + Error_Msg_N + ("static array attribute must be Length, First, or Last " & + "(RM 4.9(8))!", N); + + -- Since we know the expression is not-static (we already + -- tested for this, must mean array is not static). + + else + Error_Msg_N + ("prefix is non-static array (RM 4.9(8))!", Prefix (N)); + end if; + + return; + + -- Special case generic types, since again this is a common source + -- of confusion. + + elsif Is_Generic_Actual_Type (E) + or else + Is_Generic_Type (E) + then + Error_Msg_N + ("attribute of generic type is never static " & + "(RM 4.9(7,8))!", N); + + elsif Is_Static_Subtype (E) then + null; + + elsif Is_Scalar_Type (E) then + Error_Msg_N + ("prefix type for attribute is not static scalar subtype " & + "(RM 4.9(7))!", N); + + else + Error_Msg_N + ("static attribute must apply to array/scalar type " & + "(RM 4.9(7,8))!", N); + end if; + + when N_String_Literal => + Error_Msg_N + ("subtype of string literal is non-static (RM 4.9(4))!", N); + + when N_Explicit_Dereference => + Error_Msg_N + ("explicit dereference is never static (RM 4.9)!", N); + + when N_Function_Call => + Why_Not_Static_List (Parameter_Associations (N)); + Error_Msg_N ("non-static function call (RM 4.9(6,18))!", N); + + when N_Parameter_Association => + Why_Not_Static (Explicit_Actual_Parameter (N)); + + when N_Indexed_Component => + Error_Msg_N + ("indexed component is never static (RM 4.9)!", N); + + when N_Procedure_Call_Statement => + Error_Msg_N + ("procedure call is never static (RM 4.9)!", N); + + when N_Qualified_Expression => + Why_Not_Static (Expression (N)); + + when N_Aggregate | N_Extension_Aggregate => + Error_Msg_N + ("an aggregate is never static (RM 4.9)!", N); + + when N_Range => + Why_Not_Static (Low_Bound (N)); + Why_Not_Static (High_Bound (N)); + + when N_Range_Constraint => + Why_Not_Static (Range_Expression (N)); + + when N_Subtype_Indication => + Why_Not_Static (Constraint (N)); + + when N_Selected_Component => + Error_Msg_N + ("selected component is never static (RM 4.9)!", N); + + when N_Slice => + Error_Msg_N + ("slice is never static (RM 4.9)!", N); + + when N_Type_Conversion => + Why_Not_Static (Expression (N)); + + if not Is_Scalar_Type (Entity (Subtype_Mark (N))) + or else not Is_Static_Subtype (Entity (Subtype_Mark (N))) + then + Error_Msg_N + ("static conversion requires static scalar subtype result " & + "(RM 4.9(9))!", N); + end if; + + when N_Unchecked_Type_Conversion => + Error_Msg_N + ("unchecked type conversion is never static (RM 4.9)!", N); + + when others => + null; + + end case; + end Why_Not_Static; + +end Sem_Eval; diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads new file mode 100644 index 000000000..078ac375c --- /dev/null +++ b/gcc/ada/sem_eval.ads @@ -0,0 +1,438 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ E V A L -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains various subprograms involved in compile time +-- evaluation of expressions and checks for staticness of expressions and +-- types. It also contains the circuitry for checking for violations of pure +-- and preelaborated conditions (this naturally goes here, since these rules +-- involve consideration of staticness). + +-- Note: the static evaluation for attributes is found in Sem_Attr even though +-- logically it belongs here. We have done this so that it is easier to add +-- new attributes to GNAT. + +with Types; use Types; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package Sem_Eval is + + ------------------------------------ + -- Handling of Static Expressions -- + ------------------------------------ + + -- This package contains a set of routines that process individual + -- subexpression nodes with the objective of folding (precomputing) the + -- value of static expressions that are known at compile time and properly + -- computing the setting of two flags that appear in every subexpression + -- node: + + -- Is_Static_Expression + + -- This flag is set on any expression that is static according to the + -- rules in (RM 4.9(3-32)). + + -- Raises_Constraint_Error + + -- This flag indicates that it is known at compile time that the + -- evaluation of an expression raises constraint error. If the + -- expression is static, and this flag is off, then it is also known at + -- compile time that the expression does not raise constraint error + -- (i.e. the flag is accurate for static expressions, and conservative + -- for non-static expressions. + + -- If a static expression does not raise constraint error, then the + -- Raises_Constraint_Error flag is off, and the expression must be computed + -- at compile time, which means that it has the form of either a literal, + -- or a constant that is itself (recursively) either a literal or a + -- constant. + + -- The above rules must be followed exactly in order for legality checks to + -- be accurate. For subexpressions that are not static according to the RM + -- definition, they are sometimes folded anyway, but of course in this case + -- Is_Static_Expression is not set. + + ------------------------------- + -- Compile-Time Known Values -- + ------------------------------- + + -- For most legality checking purposes the flag Is_Static_Expression + -- defined in Sinfo should be used. This package also provides a routine + -- called Is_OK_Static_Expression which in addition of checking that an + -- expression is static in the RM 4.9 sense, it checks that the expression + -- does not raise constraint error. In fact for certain legality checks not + -- only do we need to ascertain that the expression is static, but we must + -- also ensure that it does not raise constraint error. + -- + -- Neither of Is_Static_Expression and Is_OK_Static_Expression should be + -- used for compile time evaluation purposes. In fact certain expression + -- whose value is known at compile time are not static in the RM 4.9 sense. + -- A typical example is: + -- + -- C : constant Integer := Record_Type'Size; + -- + -- The expression 'C' is not static in the technical RM sense, but for many + -- simple record types, the size is in fact known at compile time. When we + -- are trying to perform compile time constant folding (for instance for + -- expressions like C + 1, Is_Static_Expression or Is_OK_Static_Expression + -- are not the right functions to test if folding is possible. Instead, we + -- use Compile_Time_Known_Value. All static expressions that do not raise + -- constraint error (i.e. those for which Is_OK_Static_Expression is true) + -- are known at compile time, but as shown by the above example, there are + -- cases of non-static expressions which are known at compile time. + + ----------------- + -- Subprograms -- + ----------------- + + procedure Check_Non_Static_Context (N : Node_Id); + -- Deals with the special check required for a static expression that + -- appears in a non-static context, i.e. is not part of a larger static + -- expression (see RM 4.9(35)), i.e. the value of the expression must be + -- within the base range of the base type of its expected type. A check is + -- also made for expressions that are inside the base range, but outside + -- the range of the expected subtype (this is a warning message rather than + -- an illegality). + -- + -- Note: most cases of non-static context checks are handled within + -- Sem_Eval itself, including all cases of expressions at the outer level + -- (i.e. those that are not a subexpression). Currently the only outside + -- customer for this procedure is Sem_Attr (because Eval_Attribute is + -- there). There is also one special case arising from ranges (see body of + -- Resolve_Range). + + procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id); + -- N is either a string literal, or a constraint error node. In the latter + -- case, the situation is already dealt with, and the call has no effect. + -- In the former case, if the target type, Ttyp is constrained, then a + -- check is made to see if the string literal is of appropriate length. + + type Compare_Result is (LT, LE, EQ, GT, GE, NE, Unknown); + subtype Compare_GE is Compare_Result range EQ .. GE; + subtype Compare_LE is Compare_Result range LT .. EQ; + -- Result subtypes for Compile_Time_Compare subprograms + + function Compile_Time_Compare + (L, R : Node_Id; + Assume_Valid : Boolean) return Compare_Result; + pragma Inline (Compile_Time_Compare); + -- Given two expression nodes, finds out whether it can be determined at + -- compile time how the runtime values will compare. An Unknown result + -- means that the result of a comparison cannot be determined at compile + -- time, otherwise the returned result indicates the known result of the + -- comparison, given as tightly as possible (i.e. EQ or LT is preferred + -- returned value to LE). If Assume_Valid is true, the result reflects + -- the result of assuming that entities involved in the comparison have + -- valid representations. If Assume_Valid is false, then the base type of + -- any involved entity is used so that no assumption of validity is made. + + function Compile_Time_Compare + (L, R : Node_Id; + Diff : access Uint; + Assume_Valid : Boolean; + Rec : Boolean := False) return Compare_Result; + -- This version of Compile_Time_Compare returns extra information if the + -- result is GT or LT. In these cases, if the magnitude of the difference + -- can be determined at compile time, this (positive) magnitude is returned + -- in Diff.all. If the magnitude of the difference cannot be determined + -- then Diff.all contains No_Uint on return. Rec is a parameter that is set + -- True for a recursive call from within Compile_Time_Compare to avoid some + -- infinite recursion cases. It should never be set by a client. + + procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id); + -- This procedure is called after it has been determined that Expr is not + -- static when it is required to be. Msg is the text of a message that + -- explains the error. This procedure checks if an error is already posted + -- on Expr, if so, it does nothing unless All_Errors_Mode is set in which + -- case this flag is ignored. Otherwise the given message is posted using + -- Error_Msg_F, and then Why_Not_Static is called on Expr to generate + -- additional messages. The string given as Msg should end with ! to make + -- it an unconditional message, to ensure that if it is posted, the entire + -- set of messages is all posted. + + function Is_OK_Static_Expression (N : Node_Id) return Boolean; + -- An OK static expression is one that is static in the RM definition sense + -- and which does not raise constraint error. For most legality checking + -- purposes you should use Is_Static_Expression. For those legality checks + -- where the expression N should not raise constraint error use this + -- routine. This routine is *not* to be used in contexts where the test is + -- for compile time evaluation purposes. Use Compile_Time_Known_Value + -- instead (see section on "Compile-Time Known Values" above). + + function Is_Static_Range (N : Node_Id) return Boolean; + -- Determine if range is static, as defined in RM 4.9(26). The only allowed + -- argument is an N_Range node (but note that the semantic analysis of + -- equivalent range attribute references already turned them into the + -- equivalent range). + + function Is_OK_Static_Range (N : Node_Id) return Boolean; + -- Like Is_Static_Range, but also makes sure that the bounds of the range + -- are compile-time evaluable (i.e. do not raise constraint error). A + -- result of true means that the bounds are compile time evaluable. A + -- result of false means they are not (either because the range is not + -- static, or because one or the other bound raises CE). + + function Is_Static_Subtype (Typ : Entity_Id) return Boolean; + -- Determines whether a subtype fits the definition of an Ada static + -- subtype as given in (RM 4.9(26)). + + function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean; + -- Like Is_Static_Subtype but also makes sure that the bounds of the + -- subtype are compile-time evaluable (i.e. do not raise constraint error). + -- A result of true means that the bounds are compile time evaluable. A + -- result of false means they are not (either because the range is not + -- static, or because one or the other bound raises CE). + + function Subtypes_Statically_Compatible + (T1 : Entity_Id; + T2 : Entity_Id) return Boolean; + -- Returns true if the subtypes are unconstrained or the constraint on + -- on T1 is statically compatible with T2 (as defined by 4.9.1(4)). + -- Otherwise returns false. + + function Subtypes_Statically_Match (T1, T2 : Entity_Id) return Boolean; + -- Determine whether two types T1, T2, which have the same base type, + -- are statically matching subtypes (RM 4.9.1(1-2)). + + function Compile_Time_Known_Value (Op : Node_Id) return Boolean; + -- Returns true if Op is an expression not raising constraint error whose + -- value is known at compile time. This is true if Op is a static + -- expression, but can also be true for expressions which are technically + -- non-static but which are in fact known at compile time, such as the + -- static lower bound of a non-static range or the value of a constant + -- object whose initial value is static. Note that this routine is defended + -- against unanalyzed expressions. Such expressions will not cause a + -- blowup, they may cause pessimistic (i.e. False) results to be returned. + + function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean; + -- Similar to Compile_Time_Known_Value, but also returns True if the value + -- is a compile time known aggregate, i.e. an aggregate all of whose + -- constituent expressions are either compile time known values or compile + -- time known aggregates. + + function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean; + -- If T is an array whose index bounds are all known at compile time, then + -- True is returned, if T is not an array, or one or more of its index + -- bounds is not known at compile time, then False is returned. + + function Expr_Value (N : Node_Id) return Uint; + -- Returns the folded value of the expression N. This function is called in + -- instances where it has already been determined that the expression is + -- static or its value is compile time known (Compile_Time_Known_Value (N) + -- returns True). This version is used for integer values, and enumeration + -- or character literals. In the latter two cases, the value returned is + -- the Pos value in the relevant enumeration type. It can also be used for + -- fixed-point values, in which case it returns the corresponding integer + -- value. It cannot be used for floating-point values. + + function Expr_Value_E (N : Node_Id) return Entity_Id; + -- Returns the folded value of the expression. This function is called in + -- instances where it has already been determined that the expression is + -- static or its value known at compile time. This version is used for + -- enumeration types and returns the corresponding enumeration literal. + + function Expr_Value_R (N : Node_Id) return Ureal; + -- Returns the folded value of the expression. This function is called in + -- instances where it has already been determined that the expression is + -- static or its value known at compile time. This version is used for real + -- values (including both the floating-point and fixed-point cases). In the + -- case of a fixed-point type, the real value is returned (cf above version + -- returning Uint). + + function Expr_Value_S (N : Node_Id) return Node_Id; + -- Returns the folded value of the expression. This function is called + -- in instances where it has already been determined that the expression + -- is static or its value is known at compile time. This version is used + -- for string types and returns the corresponding N_String_Literal node. + + function Expr_Rep_Value (N : Node_Id) return Uint; + -- This is identical to Expr_Value, except in the case of enumeration + -- literals of types for which an enumeration representation clause has + -- been given, in which case it returns the representation value rather + -- than the pos value. This is the value that is needed for generating code + -- sequences, while the Expr_Value value is appropriate for compile time + -- constraint errors or getting the logical value. Note that this function + -- does NOT concern itself with biased values, if the caller needs a + -- properly biased value, the subtraction of the bias must be handled + -- explicitly. + + procedure Eval_Actual (N : Node_Id); + procedure Eval_Allocator (N : Node_Id); + procedure Eval_Arithmetic_Op (N : Node_Id); + procedure Eval_Call (N : Node_Id); + procedure Eval_Case_Expression (N : Node_Id); + procedure Eval_Character_Literal (N : Node_Id); + procedure Eval_Concatenation (N : Node_Id); + procedure Eval_Conditional_Expression (N : Node_Id); + procedure Eval_Entity_Name (N : Node_Id); + procedure Eval_Indexed_Component (N : Node_Id); + procedure Eval_Integer_Literal (N : Node_Id); + procedure Eval_Logical_Op (N : Node_Id); + procedure Eval_Membership_Op (N : Node_Id); + procedure Eval_Named_Integer (N : Node_Id); + procedure Eval_Named_Real (N : Node_Id); + procedure Eval_Op_Expon (N : Node_Id); + procedure Eval_Op_Not (N : Node_Id); + procedure Eval_Real_Literal (N : Node_Id); + procedure Eval_Relational_Op (N : Node_Id); + procedure Eval_Shift (N : Node_Id); + procedure Eval_Short_Circuit (N : Node_Id); + procedure Eval_Slice (N : Node_Id); + procedure Eval_String_Literal (N : Node_Id); + procedure Eval_Qualified_Expression (N : Node_Id); + procedure Eval_Type_Conversion (N : Node_Id); + procedure Eval_Unary_Op (N : Node_Id); + procedure Eval_Unchecked_Conversion (N : Node_Id); + + procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean); + -- Rewrite N with a new N_String_Literal node as the result of the compile + -- time evaluation of the node N. Val is the resulting string value from + -- the folding operation. The Is_Static_Expression flag is set in the + -- result node. The result is fully analyzed and resolved. Static indicates + -- whether the result should be considered static or not (True = consider + -- static). The point here is that normally all string literals are static, + -- but if this was the result of some sequence of evaluation where values + -- were known at compile time but not static, then the result is not + -- static. + + procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean); + -- Rewrite N with a (N_Integer_Literal, N_Identifier, N_Character_Literal) + -- node as the result of the compile time evaluation of the node N. Val is + -- the result in the integer case and is the position of the literal in the + -- literals list for the enumeration case. Is_Static_Expression is set True + -- in the result node. The result is fully analyzed/resolved. Static + -- indicates whether the result should be considered static or not (True = + -- consider static). The point here is that normally all integer literals + -- are static, but if this was the result of some sequence of evaluation + -- where values were known at compile time but not static, then the result + -- is not static. + + procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean); + -- Rewrite N with a new N_Real_Literal node as the result of the compile + -- time evaluation of the node N. Val is the resulting real value from the + -- folding operation. The Is_Static_Expression flag is set in the result + -- node. The result is fully analyzed and result. Static indicates whether + -- the result should be considered static or not (True = consider static). + -- The point here is that normally all string literals are static, but if + -- this was the result of some sequence of evaluation where values were + -- known at compile time but not static, then the result is not static. + + function Is_In_Range + (N : Node_Id; + Typ : Entity_Id; + Assume_Valid : Boolean := False; + Fixed_Int : Boolean := False; + Int_Real : Boolean := False) return Boolean; + -- Returns True if it can be guaranteed at compile time that expression is + -- known to be in range of the subtype Typ. A result of False does not mean + -- that the expression is out of range, merely that it cannot be determined + -- at compile time that it is in range. If Typ is a floating point type or + -- Int_Real is set, any integer value is treated as though it was a real + -- value (i.e. the underlying real value is used). In this case we use the + -- corresponding real value, both for the bounds of Typ, and for the value + -- of the expression N. If Typ is a fixed type or a discrete type and + -- Int_Real is False but flag Fixed_Int is True then any fixed-point value + -- is treated as though it was discrete value (i.e. the underlying integer + -- value is used). In this case we use the corresponding integer value, + -- both for the bounds of Typ, and for the value of the expression N. If + -- Typ is a discrete type and Fixed_Int as well as Int_Real are false, + -- integer values are used throughout. + -- + -- If Assume_Valid is set True, then N is always assumed to contain a valid + -- value. If Assume_Valid is set False, then N may be invalid (unless there + -- is some independent way of knowing that it is valid, i.e. either it is + -- an entity with Is_Known_Valid set, or Assume_No_Invalid_Values is True. + + function Is_Out_Of_Range + (N : Node_Id; + Typ : Entity_Id; + Assume_Valid : Boolean := False; + Fixed_Int : Boolean := False; + Int_Real : Boolean := False) return Boolean; + -- Returns True if it can be guaranteed at compile time that expression is + -- known to be out of range of the subtype Typ. True is returned if Typ is + -- a scalar type, and the value of N can be determined to be outside the + -- range of Typ. A result of False does not mean that the expression is in + -- range, but rather merely that it cannot be determined at compile time + -- that it is out of range. The parameters Assume_Valid, Fixed_Int, and + -- Int_Real are as described for Is_In_Range above. + + function In_Subrange_Of + (T1 : Entity_Id; + T2 : Entity_Id; + Fixed_Int : Boolean := False) return Boolean; + -- Returns True if it can be guaranteed at compile time that the range of + -- values for scalar type T1 are always in the range of scalar type T2. A + -- result of False does not mean that T1 is not in T2's subrange, only that + -- it cannot be determined at compile time. Flag Fixed_Int is used as in + -- routine Is_In_Range above. + + function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean; + -- Returns True if it can guarantee that Lo .. Hi is a null range. If it + -- cannot (because the value of Lo or Hi is not known at compile time) then + -- it returns False. + + function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean; + -- Returns True if it can guarantee that Lo .. Hi is not a null range. If + -- it cannot (because the value of Lo or Hi is not known at compile time) + -- then it returns False. + + procedure Why_Not_Static (Expr : Node_Id); + -- This procedure may be called after generating an error message that + -- complains that something is non-static. If it finds good reasons, it + -- generates one or more error messages pointing the appropriate offending + -- component of the expression. If no good reasons can be figured out, then + -- no messages are generated. The expectation here is that the caller has + -- already issued a message complaining that the expression is non-static. + -- Note that this message should be placed using Error_Msg_F or + -- Error_Msg_FE, so that it will sort before any messages placed by this + -- call. Note that it is fine to call Why_Not_Static with something that is + -- not an expression, and usually this has no effect, but in some cases + -- (N_Parameter_Association or N_Range), it makes sense for the internal + -- recursive calls. + + procedure Initialize; + -- Initializes the internal data structures. Must be called before each + -- separate main program unit (e.g. in a GNSA/ASIS context). + +private + -- The Eval routines are all marked inline, since they are called once + + pragma Inline (Eval_Actual); + pragma Inline (Eval_Allocator); + pragma Inline (Eval_Character_Literal); + pragma Inline (Eval_Conditional_Expression); + pragma Inline (Eval_Indexed_Component); + pragma Inline (Eval_Named_Integer); + pragma Inline (Eval_Named_Real); + pragma Inline (Eval_Real_Literal); + pragma Inline (Eval_Shift); + pragma Inline (Eval_Slice); + pragma Inline (Eval_String_Literal); + pragma Inline (Eval_Unchecked_Conversion); + + pragma Inline (Is_OK_Static_Expression); + +end Sem_Eval; diff --git a/gcc/ada/sem_intr.adb b/gcc/ada/sem_intr.adb new file mode 100644 index 000000000..9203a9af8 --- /dev/null +++ b/gcc/ada/sem_intr.adb @@ -0,0 +1,488 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ I N T 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Processing for intrinsic subprogram declarations + +with Atree; use Atree; +with Einfo; use Einfo; +with Errout; use Errout; +with Fname; use Fname; +with Lib; use Lib; +with Namet; use Namet; +with Sem_Aux; use Sem_Aux; +with Sem_Eval; use Sem_Eval; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Targparm; use Targparm; +with Uintp; use Uintp; + +package body Sem_Intr is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Check_Exception_Function (E : Entity_Id; N : Node_Id); + -- Check use of intrinsic Exception_Message, Exception_Info or + -- Exception_Name, as used in the DEC compatible Current_Exceptions + -- package. In each case we must have a parameterless function that + -- returns type String. + + procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id); + -- Check that operator is one of the binary arithmetic operators, and that + -- the types involved both have underlying integer types. + + procedure Check_Shift (E : Entity_Id; N : Node_Id); + -- Check intrinsic shift subprogram, the two arguments are the same + -- as for Check_Intrinsic_Subprogram (i.e. the entity of the subprogram + -- declaration, and the node for the pragma argument, used for messages) + + procedure Errint (Msg : String; S : Node_Id; N : Node_Id); + -- Post error message for bad intrinsic, the message itself is posted + -- on the appropriate spec node and another message is placed on the + -- pragma itself, referring to the spec. S is the node in the spec on + -- which the message is to be placed, and N is the pragma argument node. + + ------------------------------ + -- Check_Exception_Function -- + ------------------------------ + + procedure Check_Exception_Function (E : Entity_Id; N : Node_Id) is + begin + if not Ekind_In (E, E_Function, E_Generic_Function) then + Errint + ("intrinsic exception subprogram must be a function", E, N); + + elsif Present (First_Formal (E)) then + Errint + ("intrinsic exception subprogram may not have parameters", + E, First_Formal (E)); + return; + + elsif Etype (E) /= Standard_String then + Errint + ("return type of exception subprogram must be String", E, N); + return; + end if; + end Check_Exception_Function; + + -------------------------- + -- Check_Intrinsic_Call -- + -------------------------- + + procedure Check_Intrinsic_Call (N : Node_Id) is + Nam : constant Entity_Id := Entity (Name (N)); + Arg1 : constant Node_Id := First_Actual (N); + Typ : Entity_Id; + Rtyp : Entity_Id; + Cnam : Name_Id; + Unam : Node_Id; + + begin + -- Set argument type if argument present + + if Present (Arg1) then + Typ := Etype (Arg1); + Rtyp := Underlying_Type (Root_Type (Typ)); + end if; + + -- Set intrinsic name (getting original name in the generic case) + + Unam := Ultimate_Alias (Nam); + + if Present (Parent (Unam)) + and then Present (Generic_Parent (Parent (Unam))) + then + Cnam := Chars (Generic_Parent (Parent (Unam))); + else + Cnam := Chars (Nam); + end if; + + -- For Import_xxx calls, argument must be static string. A string + -- literal is legal even in Ada83 mode, where such literals are + -- not static. + + if Cnam = Name_Import_Address + or else + Cnam = Name_Import_Largest_Value + or else + Cnam = Name_Import_Value + then + if Etype (Arg1) = Any_Type + or else Raises_Constraint_Error (Arg1) + then + null; + + elsif Nkind (Arg1) /= N_String_Literal + and then not Is_Static_Expression (Arg1) + then + Error_Msg_FE + ("call to & requires static string argument!", N, Nam); + Why_Not_Static (Arg1); + + elsif String_Length (Strval (Expr_Value_S (Arg1))) = 0 then + Error_Msg_NE + ("call to & does not permit null string", N, Nam); + + elsif OpenVMS_On_Target + and then String_Length (Strval (Expr_Value_S (Arg1))) > 31 + then + Error_Msg_NE + ("argument in call to & must be 31 characters or less", N, Nam); + end if; + + -- Check for the case of freeing a non-null object which will raise + -- Constraint_Error. Issue warning here, do the expansion in Exp_Intr. + + elsif Cnam = Name_Unchecked_Deallocation + and then Can_Never_Be_Null (Etype (Arg1)) + then + Error_Msg_N + ("freeing `NOT NULL` object will raise Constraint_Error?", N); + + -- For unchecked deallocation, error to deallocate from empty pool. + -- Note: this test used to be in Exp_Intr as a warning, but AI 157 + -- issues a binding interpretation that this should be an error, and + -- consequently it needs to be done in the semantic analysis so that + -- the error is issued even in semantics only mode. + + elsif Cnam = Name_Unchecked_Deallocation + and then No_Pool_Assigned (Rtyp) + then + Error_Msg_N ("deallocation from empty storage pool!", N); + + -- For now, no other special checks are required + + else + return; + end if; + end Check_Intrinsic_Call; + + ------------------------------ + -- Check_Intrinsic_Operator -- + ------------------------------ + + procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id) is + Ret : constant Entity_Id := Etype (E); + Nam : constant Name_Id := Chars (E); + T1 : Entity_Id; + T2 : Entity_Id; + + begin + -- Arithmetic operators + + if Nam = Name_Op_Add + or else + Nam = Name_Op_Subtract + or else + Nam = Name_Op_Multiply + or else + Nam = Name_Op_Divide + or else + Nam = Name_Op_Rem + or else + Nam = Name_Op_Mod + or else + Nam = Name_Op_Abs + then + T1 := Etype (First_Formal (E)); + + if No (Next_Formal (First_Formal (E))) then + + if Nam = Name_Op_Add + or else + Nam = Name_Op_Subtract + or else + Nam = Name_Op_Abs + then + T2 := T1; + + -- Previous error in declaration + + else + return; + end if; + + else + T2 := Etype (Next_Formal (First_Formal (E))); + end if; + + -- Same types, predefined operator will apply + + if Root_Type (T1) = Root_Type (T2) + or else Root_Type (T1) = Root_Type (Ret) + then + null; + + -- Expansion will introduce conversions if sizes are not equal + + elsif Is_Integer_Type (Underlying_Type (T1)) + and then Is_Integer_Type (Underlying_Type (T2)) + and then Is_Integer_Type (Underlying_Type (Ret)) + then + null; + + else + Errint + ("types of intrinsic operator operands do not match", E, N); + end if; + + -- Comparison operators + + elsif Nam = Name_Op_Eq + or else + Nam = Name_Op_Ge + or else + Nam = Name_Op_Gt + or else + Nam = Name_Op_Le + or else + Nam = Name_Op_Lt + or else + Nam = Name_Op_Ne + then + T1 := Etype (First_Formal (E)); + + -- Return if previous error in declaration, otherwise get T2 type + + if No (Next_Formal (First_Formal (E))) then + return; + else + T2 := Etype (Next_Formal (First_Formal (E))); + end if; + + if Root_Type (T1) /= Root_Type (T2) then + Errint + ("types of intrinsic operator must have the same size", E, N); + end if; + + if Root_Type (Ret) /= Standard_Boolean then + Errint + ("result type of intrinsic comparison must be boolean", E, N); + end if; + + -- Exponentiation + + elsif Nam = Name_Op_Expon then + T1 := Etype (First_Formal (E)); + + if No (Next_Formal (First_Formal (E))) then + + -- Previous error in declaration + + return; + + else + T2 := Etype (Next_Formal (First_Formal (E))); + end if; + + if not (Is_Integer_Type (T1) + or else + Is_Floating_Point_Type (T1)) + or else Root_Type (T1) /= Root_Type (Ret) + or else Root_Type (T2) /= Root_Type (Standard_Integer) + then + Errint ("incorrect operands for intrinsic operator", N, E); + end if; + + -- All other operators (are there any?) are not handled + + else + Errint ("incorrect context for ""Intrinsic"" convention", E, N); + return; + end if; + + if not Is_Numeric_Type (Underlying_Type (T1)) then + Errint ("intrinsic operator can only apply to numeric types", E, N); + end if; + end Check_Intrinsic_Operator; + + -------------------------------- + -- Check_Intrinsic_Subprogram -- + -------------------------------- + + procedure Check_Intrinsic_Subprogram (E : Entity_Id; N : Node_Id) is + Spec : constant Node_Id := Specification (Unit_Declaration_Node (E)); + Nam : Name_Id; + + begin + if Present (Spec) + and then Present (Generic_Parent (Spec)) + then + Nam := Chars (Generic_Parent (Spec)); + else + Nam := Chars (E); + end if; + + -- Check name is valid intrinsic name + + Get_Name_String (Nam); + + if Name_Buffer (1) /= 'O' + and then Nam /= Name_Asm + and then Nam /= Name_To_Address + and then Nam not in First_Intrinsic_Name .. Last_Intrinsic_Name + then + Errint ("unrecognized intrinsic subprogram", E, N); + + -- We always allow intrinsic specifications in language defined units + -- and in expanded code. We assume that the GNAT implementors know what + -- they are doing, and do not write or generate junk use of intrinsic! + + elsif not Comes_From_Source (E) + or else not Comes_From_Source (N) + or else Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (N))) + then + null; + + -- Shift cases. We allow user specification of intrinsic shift + -- operators for any numeric types. + + elsif + Nam = Name_Rotate_Left + or else + Nam = Name_Rotate_Right + or else + Nam = Name_Shift_Left + or else + Nam = Name_Shift_Right + or else + Nam = Name_Shift_Right_Arithmetic + then + Check_Shift (E, N); + + elsif + Nam = Name_Exception_Information + or else + Nam = Name_Exception_Message + or else + Nam = Name_Exception_Name + then + Check_Exception_Function (E, N); + + elsif Nkind (E) = N_Defining_Operator_Symbol then + Check_Intrinsic_Operator (E, N); + + elsif Nam = Name_File + or else Nam = Name_Line + or else Nam = Name_Source_Location + or else Nam = Name_Enclosing_Entity + then + null; + + -- For now, no other intrinsic subprograms are recognized in user code + + else + Errint ("incorrect context for ""Intrinsic"" convention", E, N); + end if; + end Check_Intrinsic_Subprogram; + + ----------------- + -- Check_Shift -- + ----------------- + + procedure Check_Shift (E : Entity_Id; N : Node_Id) is + Arg1 : Node_Id; + Arg2 : Node_Id; + Size : Nat; + Typ1 : Entity_Id; + Typ2 : Entity_Id; + Ptyp1 : Node_Id; + Ptyp2 : Node_Id; + + begin + if not Ekind_In (E, E_Function, E_Generic_Function) then + Errint ("intrinsic shift subprogram must be a function", E, N); + return; + end if; + + Arg1 := First_Formal (E); + + if Present (Arg1) then + Arg2 := Next_Formal (Arg1); + else + Arg2 := Empty; + end if; + + if Arg1 = Empty or else Arg2 = Empty then + Errint ("intrinsic shift function must have two arguments", E, N); + return; + end if; + + Typ1 := Etype (Arg1); + Typ2 := Etype (Arg2); + + Ptyp1 := Parameter_Type (Parent (Arg1)); + Ptyp2 := Parameter_Type (Parent (Arg2)); + + if not Is_Integer_Type (Typ1) then + Errint ("first argument to shift must be integer type", Ptyp1, N); + return; + end if; + + if Typ2 /= Standard_Natural then + Errint ("second argument to shift must be type Natural", Ptyp2, N); + return; + end if; + + Size := UI_To_Int (Esize (Typ1)); + + if Size /= 8 + and then Size /= 16 + and then Size /= 32 + and then Size /= 64 + then + Errint + ("first argument for shift must have size 8, 16, 32 or 64", + Ptyp1, N); + return; + + elsif Non_Binary_Modulus (Typ1) then + Errint + ("shifts not allowed for non-binary modular types", + Ptyp1, N); + + elsif Etype (Arg1) /= Etype (E) then + Errint + ("first argument of shift must match return type", Ptyp1, N); + return; + end if; + end Check_Shift; + + ------------ + -- Errint -- + ------------ + + procedure Errint (Msg : String; S : Node_Id; N : Node_Id) is + begin + Error_Msg_N (Msg, S); + Error_Msg_N ("incorrect intrinsic subprogram, see spec", N); + end Errint; + +end Sem_Intr; diff --git a/gcc/ada/sem_intr.ads b/gcc/ada/sem_intr.ads new file mode 100644 index 000000000..ffe001d3c --- /dev/null +++ b/gcc/ada/sem_intr.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ I N T R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Processing for intrinsic subprogram declarations + +with Types; use Types; + +package Sem_Intr is + + procedure Check_Intrinsic_Call (N : Node_Id); + -- Perform legality check for intrinsic call N (which is either function + -- call or a procedure call node). All the normal semantic checks have + -- been performed already. Check_Intrinsic_Call applies any additional + -- checks required by the fact that an intrinsic subprogram is involved. + + procedure Check_Intrinsic_Subprogram (E : Entity_Id; N : Node_Id); + -- Special processing for pragma Import or pragma Interface when the + -- convention is Intrinsic. E is the Entity_Id of the spec of the + -- subprogram, and N is the second (subprogram) argument of the pragma. + -- Check_Intrinsic_Subprogram checks that the referenced subprogram is + -- known as an intrinsic and has an appropriate profile. If so the flag + -- Is_Intrinsic_Subprogram is set, otherwise an error message is posted. + +end Sem_Intr; diff --git a/gcc/ada/sem_mech.adb b/gcc/ada/sem_mech.adb new file mode 100644 index 000000000..1954b3deb --- /dev/null +++ b/gcc/ada/sem_mech.adb @@ -0,0 +1,493 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ M E C H -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1996-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Errout; use Errout; +with Namet; use Namet; +with Nlists; use Nlists; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Targparm; use Targparm; + +package body Sem_Mech is + + ------------------------- + -- Set_Mechanism_Value -- + ------------------------- + + procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is + Class : Node_Id; + Param : Node_Id; + + procedure Bad_Class; + -- Signal bad descriptor class name + + procedure Bad_Mechanism; + -- Signal bad mechanism name + + procedure Bad_Class is + begin + Error_Msg_N ("unrecognized descriptor class name", Class); + end Bad_Class; + + procedure Bad_Mechanism is + begin + Error_Msg_N ("unrecognized mechanism name", Mech_Name); + end Bad_Mechanism; + + -- Start of processing for Set_Mechanism_Value + + begin + if Mechanism (Ent) /= Default_Mechanism then + Error_Msg_NE + ("mechanism for & has already been set", Mech_Name, Ent); + end if; + + -- MECHANISM_NAME ::= value | reference | descriptor | short_descriptor + + if Nkind (Mech_Name) = N_Identifier then + if Chars (Mech_Name) = Name_Value then + Set_Mechanism_With_Checks (Ent, By_Copy, Mech_Name); + return; + + elsif Chars (Mech_Name) = Name_Reference then + Set_Mechanism_With_Checks (Ent, By_Reference, Mech_Name); + return; + + elsif Chars (Mech_Name) = Name_Descriptor then + Check_VMS (Mech_Name); + Set_Mechanism_With_Checks (Ent, By_Descriptor, Mech_Name); + return; + + elsif Chars (Mech_Name) = Name_Short_Descriptor then + Check_VMS (Mech_Name); + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor, Mech_Name); + return; + + elsif Chars (Mech_Name) = Name_Copy then + Error_Msg_N ("bad mechanism name, Value assumed", Mech_Name); + Set_Mechanism (Ent, By_Copy); + + else + Bad_Mechanism; + return; + end if; + + -- MECHANISM_NAME ::= descriptor (CLASS_NAME) | + -- short_descriptor (CLASS_NAME) + -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca + + -- Note: this form is parsed as an indexed component + + elsif Nkind (Mech_Name) = N_Indexed_Component then + Class := First (Expressions (Mech_Name)); + + if Nkind (Prefix (Mech_Name)) /= N_Identifier + or else not (Chars (Prefix (Mech_Name)) = Name_Descriptor or else + Chars (Prefix (Mech_Name)) = Name_Short_Descriptor) + or else Present (Next (Class)) + then + Bad_Mechanism; + return; + end if; + + -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) | + -- short_descriptor (Class => CLASS_NAME) + -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca + + -- Note: this form is parsed as a function call + + elsif Nkind (Mech_Name) = N_Function_Call then + + Param := First (Parameter_Associations (Mech_Name)); + + if Nkind (Name (Mech_Name)) /= N_Identifier + or else not (Chars (Name (Mech_Name)) = Name_Descriptor or else + Chars (Name (Mech_Name)) = Name_Short_Descriptor) + or else Present (Next (Param)) + or else No (Selector_Name (Param)) + or else Chars (Selector_Name (Param)) /= Name_Class + then + Bad_Mechanism; + return; + else + Class := Explicit_Actual_Parameter (Param); + end if; + + else + Bad_Mechanism; + return; + end if; + + -- Fall through here with Class set to descriptor class name + + Check_VMS (Mech_Name); + + if Nkind (Class) /= N_Identifier then + Bad_Class; + return; + + elsif Chars (Name (Mech_Name)) = Name_Descriptor + and then Chars (Class) = Name_UBS + then + Set_Mechanism_With_Checks (Ent, By_Descriptor_UBS, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Descriptor + and then Chars (Class) = Name_UBSB + then + Set_Mechanism_With_Checks (Ent, By_Descriptor_UBSB, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Descriptor + and then Chars (Class) = Name_UBA + then + Set_Mechanism_With_Checks (Ent, By_Descriptor_UBA, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Descriptor + and then Chars (Class) = Name_S + then + Set_Mechanism_With_Checks (Ent, By_Descriptor_S, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Descriptor + and then Chars (Class) = Name_SB + then + Set_Mechanism_With_Checks (Ent, By_Descriptor_SB, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Descriptor + and then Chars (Class) = Name_A + then + Set_Mechanism_With_Checks (Ent, By_Descriptor_A, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Descriptor + and then Chars (Class) = Name_NCA + then + Set_Mechanism_With_Checks (Ent, By_Descriptor_NCA, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor + and then Chars (Class) = Name_UBS + then + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBS, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor + and then Chars (Class) = Name_UBSB + then + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBSB, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor + and then Chars (Class) = Name_UBA + then + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBA, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor + and then Chars (Class) = Name_S + then + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_S, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor + and then Chars (Class) = Name_SB + then + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_SB, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor + and then Chars (Class) = Name_A + then + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_A, Mech_Name); + + elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor + and then Chars (Class) = Name_NCA + then + Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_NCA, Mech_Name); + + else + Bad_Class; + return; + end if; + end Set_Mechanism_Value; + + ------------------------------- + -- Set_Mechanism_With_Checks -- + ------------------------------- + + procedure Set_Mechanism_With_Checks + (Ent : Entity_Id; + Mech : Mechanism_Type; + Enod : Node_Id) + is + begin + -- Right now we only do some checks for functions returning arguments + -- by descriptor. Probably mode checks need to be added here ??? + + if Mech in Descriptor_Codes and then not Is_Formal (Ent) then + if Is_Record_Type (Etype (Ent)) then + Error_Msg_N ("?records cannot be returned by Descriptor", Enod); + return; + end if; + end if; + + -- If we fall through, all checks have passed + + Set_Mechanism (Ent, Mech); + end Set_Mechanism_With_Checks; + + -------------------- + -- Set_Mechanisms -- + -------------------- + + procedure Set_Mechanisms (E : Entity_Id) is + Formal : Entity_Id; + Typ : Entity_Id; + + begin + -- Skip this processing if inside a generic template. Not only is + -- it unnecessary (since neither extra formals nor mechanisms are + -- relevant for the template itself), but at least at the moment, + -- procedures get frozen early inside a template so attempting to + -- look at the formal types does not work too well if they are + -- private types that have not been frozen yet. + + if Inside_A_Generic then + return; + end if; + + -- Loop through formals + + Formal := First_Formal (E); + while Present (Formal) loop + + if Mechanism (Formal) = Default_Mechanism then + Typ := Underlying_Type (Etype (Formal)); + + -- If there is no underlying type, then skip this processing and + -- leave the convention set to Default_Mechanism. It seems odd + -- that there should ever be such cases but there are (see + -- comments for filed regression tests 1418-001 and 1912-009) ??? + + if No (Typ) then + goto Skip_Formal; + end if; + + case Convention (E) is + + --------- + -- Ada -- + --------- + + -- Note: all RM defined conventions are treated the same + -- from the point of view of parameter passing mechanism + + when Convention_Ada | + Convention_Intrinsic | + Convention_Entry | + Convention_Protected | + Convention_Stubbed => + + -- By reference types are passed by reference (RM 6.2(4)) + + if Is_By_Reference_Type (Typ) then + Set_Mechanism (Formal, By_Reference); + + -- By copy types are passed by copy (RM 6.2(3)) + + elsif Is_By_Copy_Type (Typ) then + Set_Mechanism (Formal, By_Copy); + + -- All other types we leave the Default_Mechanism set, so + -- that the backend can choose the appropriate method. + + else + null; + end if; + + ------- + -- C -- + ------- + + -- Note: Assembler, C++, Java, Stdcall also use C conventions + + when Convention_Assembler | + Convention_C | + Convention_CIL | + Convention_CPP | + Convention_Java | + Convention_Stdcall => + + -- The following values are passed by copy + + -- IN Scalar parameters (RM B.3(66)) + -- IN parameters of access types (RM B.3(67)) + -- Access parameters (RM B.3(68)) + -- Access to subprogram types (RM B.3(71)) + + -- Note: in the case of access parameters, it is the + -- pointer that is passed by value. In GNAT access + -- parameters are treated as IN parameters of an + -- anonymous access type, so this falls out free. + + -- The bottom line is that all IN elementary types + -- are passed by copy in GNAT. + + if Is_Elementary_Type (Typ) then + if Ekind (Formal) = E_In_Parameter then + Set_Mechanism (Formal, By_Copy); + + -- OUT and IN OUT parameters of elementary types are + -- passed by reference (RM B.3(68)). Note that we are + -- not following the advice to pass the address of a + -- copy to preserve by copy semantics. + + else + Set_Mechanism (Formal, By_Reference); + end if; + + -- Records are normally passed by reference (RM B.3(69)). + -- However, this can be overridden by the use of the + -- C_Pass_By_Copy pragma or C_Pass_By_Copy convention. + + elsif Is_Record_Type (Typ) then + + -- If the record is not convention C, then we always + -- pass by reference, C_Pass_By_Copy does not apply. + + if Convention (Typ) /= Convention_C then + Set_Mechanism (Formal, By_Reference); + + -- If convention C_Pass_By_Copy was specified for + -- the record type, then we pass by copy. + + elsif C_Pass_By_Copy (Typ) then + Set_Mechanism (Formal, By_Copy); + + -- Otherwise, for a C convention record, we set the + -- convention in accordance with a possible use of + -- the C_Pass_By_Copy pragma. Note that the value of + -- Default_C_Record_Mechanism in the absence of such + -- a pragma is By_Reference. + + else + Set_Mechanism (Formal, Default_C_Record_Mechanism); + end if; + + -- Array types are passed by reference (B.3 (71)) + + elsif Is_Array_Type (Typ) then + Set_Mechanism (Formal, By_Reference); + + -- For all other types, use Default_Mechanism mechanism + + else + null; + end if; + + ----------- + -- COBOL -- + ----------- + + when Convention_COBOL => + + -- Access parameters (which in GNAT look like IN parameters + -- of an access type) are passed by copy (RM B.4(96)) as + -- are all other IN parameters of scalar type (RM B.4(97)). + + -- For now we pass these parameters by reference as well. + -- The RM specifies the intent BY_CONTENT, but gigi does + -- not currently transform By_Copy properly. If we pass by + -- reference, it will be imperative to introduce copies ??? + + if Is_Elementary_Type (Typ) + and then Ekind (Formal) = E_In_Parameter + then + Set_Mechanism (Formal, By_Reference); + + -- All other parameters (i.e. all non-scalar types, and + -- all OUT or IN OUT parameters) are passed by reference. + -- Note that at the moment we are not bothering to make + -- copies of scalar types as recommended in the RM. + + else + Set_Mechanism (Formal, By_Reference); + end if; + + ------------- + -- Fortran -- + ------------- + + when Convention_Fortran => + + -- In OpenVMS, pass a character of array of character + -- value using Descriptor(S). + + if OpenVMS_On_Target + and then (Root_Type (Typ) = Standard_Character + or else + (Is_Array_Type (Typ) + and then + Root_Type (Component_Type (Typ)) = + Standard_Character)) + then + Set_Mechanism (Formal, By_Descriptor_S); + + -- Access types are passed by default (presumably this + -- will mean they are passed by copy) + + elsif Is_Access_Type (Typ) then + null; + + -- For now, we pass all other parameters by reference. + -- It is not clear that this is right in the long run, + -- but it seems to correspond to what gnu f77 wants. + + else + Set_Mechanism (Formal, By_Reference); + end if; + + end case; + end if; + + <> -- remove this when problem above is fixed ??? + + Next_Formal (Formal); + end loop; + + -- Note: there is nothing we need to do for the return type here. + -- We deal with returning by reference in the Ada sense, by use of + -- the flag By_Ref, rather than by messing with mechanisms. + + -- A mechanism of Reference for the return means that an extra + -- parameter must be provided for the return value (that is the + -- DEC meaning of the pragma), and is unrelated to the Ada notion + -- of return by reference. + + -- Note: there was originally code here to set the mechanism to + -- By_Reference for types that are "by reference" in the Ada sense, + -- but, in accordance with the discussion above, this is wrong, and + -- the code was removed. + + end Set_Mechanisms; + +end Sem_Mech; diff --git a/gcc/ada/sem_mech.ads b/gcc/ada/sem_mech.ads new file mode 100644 index 000000000..93f6080f1 --- /dev/null +++ b/gcc/ada/sem_mech.ads @@ -0,0 +1,178 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ M E C H -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1996-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 establish calling mechanisms +-- The reason we separate this off into its own package is that it is +-- entirely possible that it may need some target specific specialization. + +with Types; use Types; + +package Sem_Mech is + + ------------------------------------------------- + -- Definitions for Parameter Mechanism Control -- + ------------------------------------------------- + + -- For parameters passed to subprograms, and for function return values, + -- as passing mechanism is defined. The entity attribute Mechanism returns + -- an indication of the mechanism, and Set_Mechanism can be used to set + -- the mechanism. At the program level, there are three ways to explicitly + -- set the mechanism: + + -- An Import_xxx or Export_xxx pragma (where xxx is Function, Procedure, + -- or Valued_Procedure) can explicitly set the mechanism for either a + -- parameter or a function return value. A mechanism explicitly set by + -- such a pragma overrides the effect of C_Pass_By_Copy described below. + + -- If convention C_Pass_By_Copy is set for a record, and the record type + -- is used as the formal type of a subprogram with a foreign convention, + -- then the mechanism is set to By_Copy. + + -- If a pragma C_Pass_By_Copy applies, and a record type has Convention + -- C, and the record type is used as the formal type of a subprogram + -- with a foreign convention, then the mechanism is set to use By_Copy + -- if the size of the record is sufficiently small (as determined by + -- the value of the parameter to pragma C_Pass_By_Copy). + + -- The subtype Mechanism_Type (declared in Types) is used to describe + -- the mechanism to be used. The following special values of this type + -- specify the mechanism, as follows. + + Default_Mechanism : constant Mechanism_Type := 0; + -- The default setting indicates that the backend will choose the proper + -- default mechanism. This depends on the convention of the subprogram + -- involved, and is generally target dependent. In the compiler, the + -- backend chooses the mechanism in this case in accordance with any + -- requirements imposed by the ABI. Note that Default is never used for + -- record types on foreign convention subprograms, since By_Reference + -- is forced for such types unless one of the above described approaches + -- is used to explicitly force By_Copy. + + By_Copy : constant Mechanism_Type := -1; + -- Passing by copy is forced. The exact meaning of By_Copy (e.g. whether + -- at a low level the value is passed in registers, or the value is copied + -- and a pointer is passed), is determined by the backend in accordance + -- with requirements imposed by the ABI. Note that in the extended import + -- and export pragma mechanisms, this is called Value, rather than Copy. + + By_Reference : constant Mechanism_Type := -2; + -- Passing by reference is forced. This is always equivalent to passing + -- a simple pointer in the case of subprograms with a foreign convention. + -- For unconstrained arrays passed to foreign convention subprograms, the + -- address of the first element of the array is passed. For convention + -- Ada, the result is logically to pass a reference, but the precise + -- mechanism (e.g. to pass bounds of unconstrained types and other needed + -- special information) is determined by the backend in accordance with + -- requirements imposed by the ABI as interpreted for Ada. + + By_Descriptor : constant Mechanism_Type := -3; + By_Descriptor_UBS : constant Mechanism_Type := -4; + By_Descriptor_UBSB : constant Mechanism_Type := -5; + By_Descriptor_UBA : constant Mechanism_Type := -6; + By_Descriptor_S : constant Mechanism_Type := -7; + By_Descriptor_SB : constant Mechanism_Type := -8; + By_Descriptor_A : constant Mechanism_Type := -9; + By_Descriptor_NCA : constant Mechanism_Type := -10; + By_Short_Descriptor : constant Mechanism_Type := -11; + By_Short_Descriptor_UBS : constant Mechanism_Type := -12; + By_Short_Descriptor_UBSB : constant Mechanism_Type := -13; + By_Short_Descriptor_UBA : constant Mechanism_Type := -14; + By_Short_Descriptor_S : constant Mechanism_Type := -15; + By_Short_Descriptor_SB : constant Mechanism_Type := -16; + By_Short_Descriptor_A : constant Mechanism_Type := -17; + By_Short_Descriptor_NCA : constant Mechanism_Type := -18; + -- These values are used only in OpenVMS ports of GNAT. Pass by descriptor + -- is forced, as described in the OpenVMS ABI. The suffix indicates the + -- descriptor type: + -- + -- UBS unaligned bit string + -- UBSB aligned bit string with arbitrary bounds + -- UBA unaligned bit array + -- S string, also a scalar or access type parameter + -- SB string with arbitrary bounds + -- A contiguous array + -- NCA non-contiguous array + -- + -- Note: the form with no suffix is used if the Import/Export pragma + -- uses the simple form of the mechanism name where no descriptor + -- type is supplied. In this case the back end assigns a descriptor + -- type based on the Ada type in accordance with the OpenVMS ABI. + + subtype Descriptor_Codes is Mechanism_Type + range By_Short_Descriptor_NCA .. By_Descriptor; + -- Subtype including all descriptor mechanisms + + -- All the above special values are non-positive. Positive values for + -- Mechanism_Type values have a special meaning. They are used only in + -- the case of records, as a result of the use of the C_Pass_By_Copy + -- pragma, and the meaning is that if the size of the record is known + -- at compile time and does not exceed the mechanism type value, then + -- By_Copy passing is forced, otherwise By_Reference is forced. + + ---------------------- + -- Global Variables -- + ---------------------- + + Default_C_Record_Mechanism : Mechanism_Type := By_Reference; + -- This value is the default mechanism used for C convention records + -- in foreign-convention subprograms if no mechanism is otherwise + -- specified. This value is modified appropriately by the occurrence + -- of a C_Pass_By_Copy configuration pragma. + + ----------------- + -- Subprograms -- + ----------------- + + procedure Set_Mechanisms (E : Entity_Id); + -- E is a subprogram or subprogram type that has been frozen, so the + -- convention of the subprogram and all its formal types and result + -- type in the case of a function are established. The function of + -- this call is to set mechanism values for formals and for the + -- function return if they have not already been explicitly set by + -- a use of an extended Import or Export pragma. The idea is to set + -- mechanism values wherever the semantics is dictated by either + -- requirements or implementation advice in the RM, and to leave + -- the mechanism set to Default if there is no requirement, so that + -- the back-end is free to choose the most efficient method. + + procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id); + -- Mech is a parameter passing mechanism (see Import_Function syntax + -- for MECHANISM_NAME). This routine checks that the mechanism argument + -- has the right form, and if not issues an error message. If the + -- argument has the right form then the Mechanism field of Ent is + -- set appropriately. It also performs some error checks. Note that + -- the mechanism name has not been analyzed (and cannot indeed be + -- analyzed, since it is semantic nonsense), so we get it in the + -- exact form created by the parser. + + procedure Set_Mechanism_With_Checks + (Ent : Entity_Id; + Mech : Mechanism_Type; + Enod : Node_Id); + -- Sets the mechanism of Ent to the given Mech value, after first checking + -- that the request makes sense. If it does not make sense, a warning is + -- posted on node Enod, and the Mechanism of Ent is unchanged. + +end Sem_Mech; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb new file mode 100644 index 000000000..fd509c482 --- /dev/null +++ b/gcc/ada/sem_prag.adb @@ -0,0 +1,14404 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ P R A G -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit contains the semantic processing for all pragmas, both language +-- and implementation defined. For most pragmas, the parser only does the +-- most basic job of checking the syntax, so Sem_Prag also contains the code +-- to complete the syntax checks. Certain pragmas are handled partially or +-- completely by the parser (see Par.Prag for further details). + +with Atree; use Atree; +with Casing; use Casing; +with Checks; use Checks; +with Csets; use Csets; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Ch7; use Exp_Ch7; +with Exp_Dist; use Exp_Dist; +with Lib; use Lib; +with Lib.Writ; use Lib.Writ; +with Lib.Xref; use Lib.Xref; +with Namet.Sp; use Namet.Sp; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Output; use Output; +with Par_SCO; use Par_SCO; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch12; use Sem_Ch12; +with Sem_Ch13; use Sem_Ch13; +with Sem_Disp; use Sem_Disp; +with Sem_Dist; use Sem_Dist; +with Sem_Elim; use Sem_Elim; +with Sem_Eval; use Sem_Eval; +with Sem_Intr; use Sem_Intr; +with Sem_Mech; use Sem_Mech; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sem_VFpt; use Sem_VFpt; +with Sem_Warn; use Sem_Warn; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Sinfo.CN; use Sinfo.CN; +with Sinput; use Sinput; +with Snames; use Snames; +with Stringt; use Stringt; +with Stylesw; use Stylesw; +with Table; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Ttypes; +with Uintp; use Uintp; +with Uname; use Uname; +with Urealp; use Urealp; +with Validsw; use Validsw; + +package body Sem_Prag is + + ---------------------------------------------- + -- Common Handling of Import-Export Pragmas -- + ---------------------------------------------- + + -- In the following section, a number of Import_xxx and Export_xxx pragmas + -- are defined by GNAT. These are compatible with the DEC pragmas of the + -- same name, and all have the following common form and processing: + + -- pragma Export_xxx + -- [Internal =>] LOCAL_NAME + -- [, [External =>] EXTERNAL_SYMBOL] + -- [, other optional parameters ]); + + -- pragma Import_xxx + -- [Internal =>] LOCAL_NAME + -- [, [External =>] EXTERNAL_SYMBOL] + -- [, other optional parameters ]); + + -- EXTERNAL_SYMBOL ::= + -- IDENTIFIER + -- | static_string_EXPRESSION + + -- The internal LOCAL_NAME designates the entity that is imported or + -- exported, and must refer to an entity in the current declarative + -- part (as required by the rules for LOCAL_NAME). + + -- The external linker name is designated by the External parameter if + -- given, or the Internal parameter if not (if there is no External + -- parameter, the External parameter is a copy of the Internal name). + + -- If the External parameter is given as a string, then this string is + -- treated as an external name (exactly as though it had been given as an + -- External_Name parameter for a normal Import pragma). + + -- If the External parameter is given as an identifier (or there is no + -- External parameter, so that the Internal identifier is used), then + -- the external name is the characters of the identifier, translated + -- to all upper case letters for OpenVMS versions of GNAT, and to all + -- lower case letters for all other versions + + -- Note: the external name specified or implied by any of these special + -- Import_xxx or Export_xxx pragmas override an external or link name + -- specified in a previous Import or Export pragma. + + -- Note: these and all other DEC-compatible GNAT pragmas allow full use of + -- named notation, following the standard rules for subprogram calls, i.e. + -- parameters can be given in any order if named notation is used, and + -- positional and named notation can be mixed, subject to the rule that all + -- positional parameters must appear first. + + -- Note: All these pragmas are implemented exactly following the DEC design + -- and implementation and are intended to be fully compatible with the use + -- of these pragmas in the DEC Ada compiler. + + -------------------------------------------- + -- Checking for Duplicated External Names -- + -------------------------------------------- + + -- It is suspicious if two separate Export pragmas use the same external + -- name. The following table is used to diagnose this situation so that + -- an appropriate warning can be issued. + + -- The Node_Id stored is for the N_String_Literal node created to hold + -- the value of the external name. The Sloc of this node is used to + -- cross-reference the location of the duplication. + + package Externals is new Table.Table ( + Table_Component_Type => Node_Id, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 100, + Table_Increment => 100, + Table_Name => "Name_Externals"); + + ------------------------------------- + -- Local Subprograms and Variables -- + ------------------------------------- + + function Adjust_External_Name_Case (N : Node_Id) return Node_Id; + -- This routine is used for possible casing adjustment of an explicit + -- external name supplied as a string literal (the node N), according to + -- the casing requirement of Opt.External_Name_Casing. If this is set to + -- As_Is, then the string literal is returned unchanged, but if it is set + -- to Uppercase or Lowercase, then a new string literal with appropriate + -- casing is constructed. + + function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id; + -- If Def_Id refers to a renamed subprogram, then the base subprogram (the + -- original one, following the renaming chain) is returned. Otherwise the + -- entity is returned unchanged. Should be in Einfo??? + + procedure rv; + -- This is a dummy function called by the processing for pragma Reviewable. + -- It is there for assisting front end debugging. By placing a Reviewable + -- pragma in the source program, a breakpoint on rv catches this place in + -- the source, allowing convenient stepping to the point of interest. + + procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id); + -- Place semantic information on the argument of an Elaborate/Elaborate_All + -- pragma. Entity name for unit and its parents is taken from item in + -- previous with_clause that mentions the unit. + + ------------------------------- + -- Adjust_External_Name_Case -- + ------------------------------- + + function Adjust_External_Name_Case (N : Node_Id) return Node_Id is + CC : Char_Code; + + begin + -- Adjust case of literal if required + + if Opt.External_Name_Exp_Casing = As_Is then + return N; + + else + -- Copy existing string + + Start_String; + + -- Set proper casing + + for J in 1 .. String_Length (Strval (N)) loop + CC := Get_String_Char (Strval (N), J); + + if Opt.External_Name_Exp_Casing = Uppercase + and then CC >= Get_Char_Code ('a') + and then CC <= Get_Char_Code ('z') + then + Store_String_Char (CC - 32); + + elsif Opt.External_Name_Exp_Casing = Lowercase + and then CC >= Get_Char_Code ('A') + and then CC <= Get_Char_Code ('Z') + then + Store_String_Char (CC + 32); + + else + Store_String_Char (CC); + end if; + end loop; + + return + Make_String_Literal (Sloc (N), + Strval => End_String); + end if; + end Adjust_External_Name_Case; + + ------------------------------ + -- Analyze_PPC_In_Decl_Part -- + ------------------------------ + + procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is + Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); + + begin + -- Install formals and push subprogram spec onto scope stack so that we + -- can see the formals from the pragma. + + Install_Formals (S); + Push_Scope (S); + + -- Preanalyze the boolean expression, we treat this as a spec expression + -- (i.e. similar to a default expression). + + Preanalyze_Spec_Expression + (Get_Pragma_Arg (Arg1), Standard_Boolean); + + -- Remove the subprogram from the scope stack now that the pre-analysis + -- of the precondition/postcondition is done. + + End_Scope; + end Analyze_PPC_In_Decl_Part; + + -------------------- + -- Analyze_Pragma -- + -------------------- + + procedure Analyze_Pragma (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Pname : constant Name_Id := Pragma_Name (N); + Prag_Id : Pragma_Id; + + Sense : constant Boolean := not Aspect_Cancel (N); + -- Sense is True if we have the normal case of a pragma that is active + -- and turns the corresponding aspect on. It is false only for the case + -- of a pragma coming from an aspect which is explicitly turned off by + -- using aspect => False. If Sense is False, the effect of the pragma + -- is to turn the corresponding aspect off. + + Pragma_Exit : exception; + -- This exception is used to exit pragma processing completely. It is + -- used when an error is detected, and no further processing is + -- required. It is also used if an earlier error has left the tree in + -- a state where the pragma should not be processed. + + Arg_Count : Nat; + -- Number of pragma argument associations + + Arg1 : Node_Id; + Arg2 : Node_Id; + Arg3 : Node_Id; + Arg4 : Node_Id; + -- First four pragma arguments (pragma argument association nodes, or + -- Empty if the corresponding argument does not exist). + + type Name_List is array (Natural range <>) of Name_Id; + type Args_List is array (Natural range <>) of Node_Id; + -- Types used for arguments to Check_Arg_Order and Gather_Associations + + procedure Ada_2005_Pragma; + -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In + -- Ada 95 mode, these are implementation defined pragmas, so should be + -- caught by the No_Implementation_Pragmas restriction. + + procedure Ada_2012_Pragma; + -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05. + -- In Ada 95 or 05 mode, these are implementation defined pragmas, so + -- should be caught by the No_Implementation_Pragmas restriction. + + procedure Check_Ada_83_Warning; + -- Issues a warning message for the current pragma if operating in Ada + -- 83 mode (used for language pragmas that are not a standard part of + -- Ada 83). This procedure does not raise Error_Pragma. Also notes use + -- of 95 pragma. + + procedure Check_Arg_Count (Required : Nat); + -- Check argument count for pragma is equal to given parameter. If not, + -- then issue an error message and raise Pragma_Exit. + + -- Note: all routines whose name is Check_Arg_Is_xxx take an argument + -- Arg which can either be a pragma argument association, in which case + -- the check is applied to the expression of the association or an + -- expression directly. + + procedure Check_Arg_Is_External_Name (Arg : Node_Id); + -- Check that an argument has the right form for an EXTERNAL_NAME + -- parameter of an extended import/export pragma. The rule is that the + -- name must be an identifier or string literal (in Ada 83 mode) or a + -- static string expression (in Ada 95 mode). + + procedure Check_Arg_Is_Identifier (Arg : Node_Id); + -- Check the specified argument Arg to make sure that it is an + -- identifier. If not give error and raise Pragma_Exit. + + procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id); + -- Check the specified argument Arg to make sure that it is an integer + -- literal. If not give error and raise Pragma_Exit. + + procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id); + -- Check the specified argument Arg to make sure that it has the proper + -- syntactic form for a local name and meets the semantic requirements + -- for a local name. The local name is analyzed as part of the + -- processing for this call. In addition, the local name is required + -- to represent an entity at the library level. + + procedure Check_Arg_Is_Local_Name (Arg : Node_Id); + -- Check the specified argument Arg to make sure that it has the proper + -- syntactic form for a local name and meets the semantic requirements + -- for a local name. The local name is analyzed as part of the + -- processing for this call. + + procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id); + -- Check the specified argument Arg to make sure that it is a valid + -- locking policy name. If not give error and raise Pragma_Exit. + + procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id); + procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3 : Name_Id); + procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3, N4 : Name_Id); + -- Check the specified argument Arg to make sure that it is an + -- identifier whose name matches either N1 or N2 (or N3 if present). + -- If not then give error and raise Pragma_Exit. + + procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id); + -- Check the specified argument Arg to make sure that it is a valid + -- queuing policy name. If not give error and raise Pragma_Exit. + + procedure Check_Arg_Is_Static_Expression + (Arg : Node_Id; + Typ : Entity_Id := Empty); + -- Check the specified argument Arg to make sure that it is a static + -- expression of the given type (i.e. it will be analyzed and resolved + -- using this type, which can be any valid argument to Resolve, e.g. + -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If + -- Typ is left Empty, then any static expression is allowed. + + procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id); + -- Check the specified argument Arg to make sure that it is a valid task + -- dispatching policy name. If not give error and raise Pragma_Exit. + + procedure Check_Arg_Order (Names : Name_List); + -- Checks for an instance of two arguments with identifiers for the + -- current pragma which are not in the sequence indicated by Names, + -- and if so, generates a fatal message about bad order of arguments. + + procedure Check_At_Least_N_Arguments (N : Nat); + -- Check there are at least N arguments present + + procedure Check_At_Most_N_Arguments (N : Nat); + -- Check there are no more than N arguments present + + procedure Check_Component + (Comp : Node_Id; + UU_Typ : Entity_Id; + In_Variant_Part : Boolean := False); + -- Examine an Unchecked_Union component for correct use of per-object + -- constrained subtypes, and for restrictions on finalizable components. + -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part + -- should be set when Comp comes from a record variant. + + procedure Check_Duplicate_Pragma (E : Entity_Id); + -- Check if a pragma of the same name as the current pragma is already + -- chained as a rep pragma to the given entity. If so give a message + -- about the duplicate, and then raise Pragma_Exit so does not return. + -- Also checks for delayed aspect specification node in the chain. + + procedure Check_Duplicated_Export_Name (Nam : Node_Id); + -- Nam is an N_String_Literal node containing the external name set by + -- an Import or Export pragma (or extended Import or Export pragma). + -- This procedure checks for possible duplications if this is the export + -- case, and if found, issues an appropriate error message. + + procedure Check_First_Subtype (Arg : Node_Id); + -- Checks that Arg, whose expression is an entity name, references a + -- first subtype. + + procedure Check_In_Main_Program; + -- Common checks for pragmas that appear within a main program + -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU). + + procedure Check_Interrupt_Or_Attach_Handler; + -- Common processing for first argument of pragma Interrupt_Handler or + -- pragma Attach_Handler. + + procedure Check_Is_In_Decl_Part_Or_Package_Spec; + -- Check that pragma appears in a declarative part, or in a package + -- specification, i.e. that it does not occur in a statement sequence + -- in a body. + + procedure Check_No_Identifier (Arg : Node_Id); + -- Checks that the given argument does not have an identifier. If + -- an identifier is present, then an error message is issued, and + -- Pragma_Exit is raised. + + procedure Check_No_Identifiers; + -- Checks that none of the arguments to the pragma has an identifier. + -- If any argument has an identifier, then an error message is issued, + -- and Pragma_Exit is raised. + + procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id); + -- Checks if the given argument has an identifier, and if so, requires + -- it to match the given identifier name. If there is a non-matching + -- identifier, then an error message is given and Error_Pragmas raised. + + procedure Check_Optional_Identifier (Arg : Node_Id; Id : String); + -- Checks if the given argument has an identifier, and if so, requires + -- it to match the given identifier name. If there is a non-matching + -- identifier, then an error message is given and Error_Pragmas raised. + -- In this version of the procedure, the identifier name is given as + -- a string with lower case letters. + + procedure Check_Precondition_Postcondition (In_Body : out Boolean); + -- Called to process a precondition or postcondition pragma. There are + -- three cases: + -- + -- The pragma appears after a subprogram spec + -- + -- If the corresponding check is not enabled, the pragma is analyzed + -- but otherwise ignored and control returns with In_Body set False. + -- + -- If the check is enabled, then the first step is to analyze the + -- pragma, but this is skipped if the subprogram spec appears within + -- a package specification (because this is the case where we delay + -- analysis till the end of the spec). Then (whether or not it was + -- analyzed), the pragma is chained to the subprogram in question + -- (using Spec_PPC_List and Next_Pragma) and control returns to the + -- caller with In_Body set False. + -- + -- The pragma appears at the start of subprogram body declarations + -- + -- In this case an immediate return to the caller is made with + -- In_Body set True, and the pragma is NOT analyzed. + -- + -- In all other cases, an error message for bad placement is given + + procedure Check_Static_Constraint (Constr : Node_Id); + -- Constr is a constraint from an N_Subtype_Indication node from a + -- component constraint in an Unchecked_Union type. This routine checks + -- that the constraint is static as required by the restrictions for + -- Unchecked_Union. + + procedure Check_Valid_Configuration_Pragma; + -- Legality checks for placement of a configuration pragma + + procedure Check_Valid_Library_Unit_Pragma; + -- Legality checks for library unit pragmas. A special case arises for + -- pragmas in generic instances that come from copies of the original + -- library unit pragmas in the generic templates. In the case of other + -- than library level instantiations these can appear in contexts which + -- would normally be invalid (they only apply to the original template + -- and to library level instantiations), and they are simply ignored, + -- which is implemented by rewriting them as null statements. + + procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id); + -- Check an Unchecked_Union variant for lack of nested variants and + -- presence of at least one component. UU_Typ is the related Unchecked_ + -- Union type. + + procedure Error_Pragma (Msg : String); + pragma No_Return (Error_Pragma); + -- Outputs error message for current pragma. The message contains a % + -- that will be replaced with the pragma name, and the flag is placed + -- on the pragma itself. Pragma_Exit is then raised. + + procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id); + pragma No_Return (Error_Pragma_Arg); + -- Outputs error message for current pragma. The message may contain + -- a % that will be replaced with the pragma name. The parameter Arg + -- may either be a pragma argument association, in which case the flag + -- is placed on the expression of this association, or an expression, + -- in which case the flag is placed directly on the expression. The + -- message is placed using Error_Msg_N, so the message may also contain + -- an & insertion character which will reference the given Arg value. + -- After placing the message, Pragma_Exit is raised. + + procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id); + pragma No_Return (Error_Pragma_Arg); + -- Similar to above form of Error_Pragma_Arg except that two messages + -- are provided, the second is a continuation comment starting with \. + + procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id); + pragma No_Return (Error_Pragma_Arg_Ident); + -- Outputs error message for current pragma. The message may contain + -- a % that will be replaced with the pragma name. The parameter Arg + -- must be a pragma argument association with a non-empty identifier + -- (i.e. its Chars field must be set), and the error message is placed + -- on the identifier. The message is placed using Error_Msg_N so + -- the message may also contain an & insertion character which will + -- reference the identifier. After placing the message, Pragma_Exit + -- is raised. + + procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id); + pragma No_Return (Error_Pragma_Ref); + -- Outputs error message for current pragma. The message may contain + -- a % that will be replaced with the pragma name. The parameter Ref + -- must be an entity whose name can be referenced by & and sloc by #. + -- After placing the message, Pragma_Exit is raised. + + function Find_Lib_Unit_Name return Entity_Id; + -- Used for a library unit pragma to find the entity to which the + -- library unit pragma applies, returns the entity found. + + procedure Find_Program_Unit_Name (Id : Node_Id); + -- If the pragma is a compilation unit pragma, the id must denote the + -- compilation unit in the same compilation, and the pragma must appear + -- in the list of preceding or trailing pragmas. If it is a program + -- unit pragma that is not a compilation unit pragma, then the + -- identifier must be visible. + + function Find_Unique_Parameterless_Procedure + (Name : Entity_Id; + Arg : Node_Id) return Entity_Id; + -- Used for a procedure pragma to find the unique parameterless + -- procedure identified by Name, returns it if it exists, otherwise + -- errors out and uses Arg as the pragma argument for the message. + + procedure Fix_Error (Msg : in out String); + -- This is called prior to issuing an error message. Msg is a string + -- which typically contains the substring pragma. If the current pragma + -- comes from an aspect, each such "pragma" substring is replaced with + -- the characters "aspect", and if Error_Msg_Name_1 is Name_Precondition + -- (resp Name_Postcondition) it is changed to Name_Pre (resp Name_Post). + + procedure Gather_Associations + (Names : Name_List; + Args : out Args_List); + -- This procedure is used to gather the arguments for a pragma that + -- permits arbitrary ordering of parameters using the normal rules + -- for named and positional parameters. The Names argument is a list + -- of Name_Id values that corresponds to the allowed pragma argument + -- association identifiers in order. The result returned in Args is + -- a list of corresponding expressions that are the pragma arguments. + -- Note that this is a list of expressions, not of pragma argument + -- associations (Gather_Associations has completely checked all the + -- optional identifiers when it returns). An entry in Args is Empty + -- on return if the corresponding argument is not present. + + procedure GNAT_Pragma; + -- Called for all GNAT defined pragmas to check the relevant restriction + -- (No_Implementation_Pragmas). + + function Is_Before_First_Decl + (Pragma_Node : Node_Id; + Decls : List_Id) return Boolean; + -- Return True if Pragma_Node is before the first declarative item in + -- Decls where Decls is the list of declarative items. + + function Is_Configuration_Pragma return Boolean; + -- Determines if the placement of the current pragma is appropriate + -- for a configuration pragma. + + function Is_In_Context_Clause return Boolean; + -- Returns True if pragma appears within the context clause of a unit, + -- and False for any other placement (does not generate any messages). + + function Is_Static_String_Expression (Arg : Node_Id) return Boolean; + -- Analyzes the argument, and determines if it is a static string + -- expression, returns True if so, False if non-static or not String. + + procedure Pragma_Misplaced; + pragma No_Return (Pragma_Misplaced); + -- Issue fatal error message for misplaced pragma + + procedure Process_Atomic_Shared_Volatile; + -- Common processing for pragmas Atomic, Shared, Volatile. Note that + -- Shared is an obsolete Ada 83 pragma, treated as being identical + -- in effect to pragma Atomic. + + procedure Process_Compile_Time_Warning_Or_Error; + -- Common processing for Compile_Time_Error and Compile_Time_Warning + + procedure Process_Convention + (C : out Convention_Id; + Ent : out Entity_Id); + -- Common processing for Convention, Interface, Import and Export. + -- Checks first two arguments of pragma, and sets the appropriate + -- convention value in the specified entity or entities. On return + -- C is the convention, Ent is the referenced entity. + + procedure Process_Extended_Import_Export_Exception_Pragma + (Arg_Internal : Node_Id; + Arg_External : Node_Id; + Arg_Form : Node_Id; + Arg_Code : Node_Id); + -- Common processing for the pragmas Import/Export_Exception. The three + -- arguments correspond to the three named parameters of the pragma. An + -- argument is empty if the corresponding parameter is not present in + -- the pragma. + + procedure Process_Extended_Import_Export_Object_Pragma + (Arg_Internal : Node_Id; + Arg_External : Node_Id; + Arg_Size : Node_Id); + -- Common processing for the pragmas Import/Export_Object. The three + -- arguments correspond to the three named parameters of the pragmas. An + -- argument is empty if the corresponding parameter is not present in + -- the pragma. + + procedure Process_Extended_Import_Export_Internal_Arg + (Arg_Internal : Node_Id := Empty); + -- Common processing for all extended Import and Export pragmas. The + -- argument is the pragma parameter for the Internal argument. If + -- Arg_Internal is empty or inappropriate, an error message is posted. + -- Otherwise, on normal return, the Entity_Field of Arg_Internal is + -- set to identify the referenced entity. + + procedure Process_Extended_Import_Export_Subprogram_Pragma + (Arg_Internal : Node_Id; + Arg_External : Node_Id; + Arg_Parameter_Types : Node_Id; + Arg_Result_Type : Node_Id := Empty; + Arg_Mechanism : Node_Id; + Arg_Result_Mechanism : Node_Id := Empty; + Arg_First_Optional_Parameter : Node_Id := Empty); + -- Common processing for all extended Import and Export pragmas applying + -- to subprograms. The caller omits any arguments that do not apply to + -- the pragma in question (for example, Arg_Result_Type can be non-Empty + -- only in the Import_Function and Export_Function cases). The argument + -- names correspond to the allowed pragma association identifiers. + + procedure Process_Generic_List; + -- Common processing for Share_Generic and Inline_Generic + + procedure Process_Import_Or_Interface; + -- Common processing for Import of Interface + + procedure Process_Inline (Active : Boolean); + -- Common processing for Inline and Inline_Always. The parameter + -- indicates if the inline pragma is active, i.e. if it should actually + -- cause inlining to occur. + + procedure Process_Interface_Name + (Subprogram_Def : Entity_Id; + Ext_Arg : Node_Id; + Link_Arg : Node_Id); + -- Given the last two arguments of pragma Import, pragma Export, or + -- pragma Interface_Name, performs validity checks and sets the + -- Interface_Name field of the given subprogram entity to the + -- appropriate external or link name, depending on the arguments given. + -- Ext_Arg is always present, but Link_Arg may be missing. Note that + -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and + -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg + -- nor Link_Arg is present, the interface name is set to the default + -- from the subprogram name. + + procedure Process_Interrupt_Or_Attach_Handler; + -- Common processing for Interrupt and Attach_Handler pragmas + + procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean); + -- Common processing for Restrictions and Restriction_Warnings pragmas. + -- Warn is True for Restriction_Warnings, or for Restrictions if the + -- flag Treat_Restrictions_As_Warnings is set, and False if this flag + -- is not set in the Restrictions case. + + procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean); + -- Common processing for Suppress and Unsuppress. The boolean parameter + -- Suppress_Case is True for the Suppress case, and False for the + -- Unsuppress case. + + procedure Set_Exported (E : Entity_Id; Arg : Node_Id); + -- This procedure sets the Is_Exported flag for the given entity, + -- checking that the entity was not previously imported. Arg is + -- the argument that specified the entity. A check is also made + -- for exporting inappropriate entities. + + procedure Set_Extended_Import_Export_External_Name + (Internal_Ent : Entity_Id; + Arg_External : Node_Id); + -- Common processing for all extended import export pragmas. The first + -- argument, Internal_Ent, is the internal entity, which has already + -- been checked for validity by the caller. Arg_External is from the + -- Import or Export pragma, and may be null if no External parameter + -- was present. If Arg_External is present and is a non-null string + -- (a null string is treated as the default), then the Interface_Name + -- field of Internal_Ent is set appropriately. + + procedure Set_Imported (E : Entity_Id); + -- This procedure sets the Is_Imported flag for the given entity, + -- checking that it is not previously exported or imported. + + procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id); + -- Mech is a parameter passing mechanism (see Import_Function syntax + -- for MECHANISM_NAME). This routine checks that the mechanism argument + -- has the right form, and if not issues an error message. If the + -- argument has the right form then the Mechanism field of Ent is + -- set appropriately. + + procedure Set_Ravenscar_Profile (N : Node_Id); + -- Activate the set of configuration pragmas and restrictions that make + -- up the Ravenscar Profile. N is the corresponding pragma node, which + -- is used for error messages on any constructs that violate the + -- profile. + + --------------------- + -- Ada_2005_Pragma -- + --------------------- + + procedure Ada_2005_Pragma is + begin + if Ada_Version <= Ada_95 then + Check_Restriction (No_Implementation_Pragmas, N); + end if; + end Ada_2005_Pragma; + + --------------------- + -- Ada_2012_Pragma -- + --------------------- + + procedure Ada_2012_Pragma is + begin + if Ada_Version <= Ada_2005 then + Check_Restriction (No_Implementation_Pragmas, N); + end if; + end Ada_2012_Pragma; + + -------------------------- + -- Check_Ada_83_Warning -- + -------------------------- + + procedure Check_Ada_83_Warning is + begin + if Ada_Version = Ada_83 and then Comes_From_Source (N) then + Error_Msg_N ("(Ada 83) pragma& is non-standard?", N); + end if; + end Check_Ada_83_Warning; + + --------------------- + -- Check_Arg_Count -- + --------------------- + + procedure Check_Arg_Count (Required : Nat) is + begin + if Arg_Count /= Required then + Error_Pragma ("wrong number of arguments for pragma%"); + end if; + end Check_Arg_Count; + + -------------------------------- + -- Check_Arg_Is_External_Name -- + -------------------------------- + + procedure Check_Arg_Is_External_Name (Arg : Node_Id) is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); + + begin + if Nkind (Argx) = N_Identifier then + return; + + else + Analyze_And_Resolve (Argx, Standard_String); + + if Is_OK_Static_Expression (Argx) then + return; + + elsif Etype (Argx) = Any_Type then + raise Pragma_Exit; + + -- An interesting special case, if we have a string literal and + -- we are in Ada 83 mode, then we allow it even though it will + -- not be flagged as static. This allows expected Ada 83 mode + -- use of external names which are string literals, even though + -- technically these are not static in Ada 83. + + elsif Ada_Version = Ada_83 + and then Nkind (Argx) = N_String_Literal + then + return; + + -- Static expression that raises Constraint_Error. This has + -- already been flagged, so just exit from pragma processing. + + elsif Is_Static_Expression (Argx) then + raise Pragma_Exit; + + -- Here we have a real error (non-static expression) + + else + Error_Msg_Name_1 := Pname; + + declare + Msg : String := + "argument for pragma% must be a identifier or " + & "static string expression!"; + begin + Fix_Error (Msg); + Flag_Non_Static_Expr (Msg, Argx); + raise Pragma_Exit; + end; + end if; + end if; + end Check_Arg_Is_External_Name; + + ----------------------------- + -- Check_Arg_Is_Identifier -- + ----------------------------- + + procedure Check_Arg_Is_Identifier (Arg : Node_Id) is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); + begin + if Nkind (Argx) /= N_Identifier then + Error_Pragma_Arg + ("argument for pragma% must be identifier", Argx); + end if; + end Check_Arg_Is_Identifier; + + ---------------------------------- + -- Check_Arg_Is_Integer_Literal -- + ---------------------------------- + + procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); + begin + if Nkind (Argx) /= N_Integer_Literal then + Error_Pragma_Arg + ("argument for pragma% must be integer literal", Argx); + end if; + end Check_Arg_Is_Integer_Literal; + + ------------------------------------------- + -- Check_Arg_Is_Library_Level_Local_Name -- + ------------------------------------------- + + -- LOCAL_NAME ::= + -- DIRECT_NAME + -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR + -- | library_unit_NAME + + procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is + begin + Check_Arg_Is_Local_Name (Arg); + + if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg))) + and then Comes_From_Source (N) + then + Error_Pragma_Arg + ("argument for pragma% must be library level entity", Arg); + end if; + end Check_Arg_Is_Library_Level_Local_Name; + + ----------------------------- + -- Check_Arg_Is_Local_Name -- + ----------------------------- + + -- LOCAL_NAME ::= + -- DIRECT_NAME + -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR + -- | library_unit_NAME + + procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); + + begin + Analyze (Argx); + + if Nkind (Argx) not in N_Direct_Name + and then (Nkind (Argx) /= N_Attribute_Reference + or else Present (Expressions (Argx)) + or else Nkind (Prefix (Argx)) /= N_Identifier) + and then (not Is_Entity_Name (Argx) + or else not Is_Compilation_Unit (Entity (Argx))) + then + Error_Pragma_Arg ("argument for pragma% must be local name", Argx); + end if; + + -- No further check required if not an entity name + + if not Is_Entity_Name (Argx) then + null; + + else + declare + OK : Boolean; + Ent : constant Entity_Id := Entity (Argx); + Scop : constant Entity_Id := Scope (Ent); + begin + -- Case of a pragma applied to a compilation unit: pragma must + -- occur immediately after the program unit in the compilation. + + if Is_Compilation_Unit (Ent) then + declare + Decl : constant Node_Id := Unit_Declaration_Node (Ent); + begin + -- Case of pragma placed immediately after spec + + if Parent (N) = Aux_Decls_Node (Parent (Decl)) then + OK := True; + + -- Case of pragma placed immediately after body + + elsif Nkind (Decl) = N_Subprogram_Declaration + and then Present (Corresponding_Body (Decl)) + then + OK := Parent (N) = + Aux_Decls_Node + (Parent (Unit_Declaration_Node + (Corresponding_Body (Decl)))); + + -- All other cases are illegal + + else + OK := False; + end if; + end; + + -- Special restricted placement rule from 10.2.1(11.8/2) + + elsif Is_Generic_Formal (Ent) + and then Prag_Id = Pragma_Preelaborable_Initialization + then + OK := List_Containing (N) = + Generic_Formal_Declarations + (Unit_Declaration_Node (Scop)); + + -- Default case, just check that the pragma occurs in the scope + -- of the entity denoted by the name. + + else + OK := Current_Scope = Scop; + end if; + + if not OK then + Error_Pragma_Arg + ("pragma% argument must be in same declarative part", Arg); + end if; + end; + end if; + end Check_Arg_Is_Local_Name; + + --------------------------------- + -- Check_Arg_Is_Locking_Policy -- + --------------------------------- + + procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); + + begin + Check_Arg_Is_Identifier (Argx); + + if not Is_Locking_Policy_Name (Chars (Argx)) then + Error_Pragma_Arg ("& is not a valid locking policy name", Argx); + end if; + end Check_Arg_Is_Locking_Policy; + + ------------------------- + -- Check_Arg_Is_One_Of -- + ------------------------- + + procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); + + begin + Check_Arg_Is_Identifier (Argx); + + if Chars (Argx) /= N1 and then Chars (Argx) /= N2 then + Error_Msg_Name_2 := N1; + Error_Msg_Name_3 := N2; + Error_Pragma_Arg ("argument for pragma% must be% or%", Argx); + end if; + end Check_Arg_Is_One_Of; + + procedure Check_Arg_Is_One_Of + (Arg : Node_Id; + N1, N2, N3 : Name_Id) + is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); + + begin + Check_Arg_Is_Identifier (Argx); + + if Chars (Argx) /= N1 + and then Chars (Argx) /= N2 + and then Chars (Argx) /= N3 + then + Error_Pragma_Arg ("invalid argument for pragma%", Argx); + end if; + end Check_Arg_Is_One_Of; + + procedure Check_Arg_Is_One_Of + (Arg : Node_Id; + N1, N2, N3, N4 : Name_Id) + is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); + + begin + Check_Arg_Is_Identifier (Argx); + + if Chars (Argx) /= N1 + and then Chars (Argx) /= N2 + and then Chars (Argx) /= N3 + and then Chars (Argx) /= N4 + then + Error_Pragma_Arg ("invalid argument for pragma%", Argx); + end if; + end Check_Arg_Is_One_Of; + --------------------------------- + -- Check_Arg_Is_Queuing_Policy -- + --------------------------------- + + procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); + + begin + Check_Arg_Is_Identifier (Argx); + + if not Is_Queuing_Policy_Name (Chars (Argx)) then + Error_Pragma_Arg ("& is not a valid queuing policy name", Argx); + end if; + end Check_Arg_Is_Queuing_Policy; + + ------------------------------------ + -- Check_Arg_Is_Static_Expression -- + ------------------------------------ + + procedure Check_Arg_Is_Static_Expression + (Arg : Node_Id; + Typ : Entity_Id := Empty) + is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); + + begin + if Present (Typ) then + Analyze_And_Resolve (Argx, Typ); + else + Analyze_And_Resolve (Argx); + end if; + + if Is_OK_Static_Expression (Argx) then + return; + + elsif Etype (Argx) = Any_Type then + raise Pragma_Exit; + + -- An interesting special case, if we have a string literal and we + -- are in Ada 83 mode, then we allow it even though it will not be + -- flagged as static. This allows the use of Ada 95 pragmas like + -- Import in Ada 83 mode. They will of course be flagged with + -- warnings as usual, but will not cause errors. + + elsif Ada_Version = Ada_83 + and then Nkind (Argx) = N_String_Literal + then + return; + + -- Static expression that raises Constraint_Error. This has already + -- been flagged, so just exit from pragma processing. + + elsif Is_Static_Expression (Argx) then + raise Pragma_Exit; + + -- Finally, we have a real error + + else + Error_Msg_Name_1 := Pname; + + declare + Msg : String := + "argument for pragma% must be a static expression!"; + begin + Fix_Error (Msg); + Flag_Non_Static_Expr (Msg, Argx); + end; + + raise Pragma_Exit; + end if; + end Check_Arg_Is_Static_Expression; + + ------------------------------------------ + -- Check_Arg_Is_Task_Dispatching_Policy -- + ------------------------------------------ + + procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); + + begin + Check_Arg_Is_Identifier (Argx); + + if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then + Error_Pragma_Arg + ("& is not a valid task dispatching policy name", Argx); + end if; + end Check_Arg_Is_Task_Dispatching_Policy; + + --------------------- + -- Check_Arg_Order -- + --------------------- + + procedure Check_Arg_Order (Names : Name_List) is + Arg : Node_Id; + + Highest_So_Far : Natural := 0; + -- Highest index in Names seen do far + + begin + Arg := Arg1; + for J in 1 .. Arg_Count loop + if Chars (Arg) /= No_Name then + for K in Names'Range loop + if Chars (Arg) = Names (K) then + if K < Highest_So_Far then + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("parameters out of order for pragma%", Arg); + Error_Msg_Name_1 := Names (K); + Error_Msg_Name_2 := Names (Highest_So_Far); + Error_Msg_N ("\% must appear before %", Arg); + raise Pragma_Exit; + + else + Highest_So_Far := K; + end if; + end if; + end loop; + end if; + + Arg := Next (Arg); + end loop; + end Check_Arg_Order; + + -------------------------------- + -- Check_At_Least_N_Arguments -- + -------------------------------- + + procedure Check_At_Least_N_Arguments (N : Nat) is + begin + if Arg_Count < N then + Error_Pragma ("too few arguments for pragma%"); + end if; + end Check_At_Least_N_Arguments; + + ------------------------------- + -- Check_At_Most_N_Arguments -- + ------------------------------- + + procedure Check_At_Most_N_Arguments (N : Nat) is + Arg : Node_Id; + begin + if Arg_Count > N then + Arg := Arg1; + for J in 1 .. N loop + Next (Arg); + Error_Pragma_Arg ("too many arguments for pragma%", Arg); + end loop; + end if; + end Check_At_Most_N_Arguments; + + --------------------- + -- Check_Component -- + --------------------- + + procedure Check_Component + (Comp : Node_Id; + UU_Typ : Entity_Id; + In_Variant_Part : Boolean := False) + is + Comp_Id : constant Entity_Id := Defining_Identifier (Comp); + Sindic : constant Node_Id := + Subtype_Indication (Component_Definition (Comp)); + Typ : constant Entity_Id := Etype (Comp_Id); + + function Inside_Generic_Body (Id : Entity_Id) return Boolean; + -- Determine whether entity Id appears inside a generic body. + -- Shouldn't this be in a more general place ??? + + ------------------------- + -- Inside_Generic_Body -- + ------------------------- + + function Inside_Generic_Body (Id : Entity_Id) return Boolean is + S : Entity_Id; + + begin + S := Id; + while Present (S) and then S /= Standard_Standard loop + if Ekind (S) = E_Generic_Package + and then In_Package_Body (S) + then + return True; + end if; + + S := Scope (S); + end loop; + + return False; + end Inside_Generic_Body; + + -- Start of processing for Check_Component + + begin + -- Ada 2005 (AI-216): If a component subtype is subject to a per- + -- object constraint, then the component type shall be an Unchecked_ + -- Union. + + if Nkind (Sindic) = N_Subtype_Indication + and then Has_Per_Object_Constraint (Comp_Id) + and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic))) + then + Error_Msg_N + ("component subtype subject to per-object constraint " & + "must be an Unchecked_Union", Comp); + + -- Ada 2012 (AI05-0026): For an unchecked union type declared within + -- the body of a generic unit, or within the body of any of its + -- descendant library units, no part of the type of a component + -- declared in a variant_part of the unchecked union type shall be of + -- a formal private type or formal private extension declared within + -- the formal part of the generic unit. + + elsif Ada_Version >= Ada_2012 + and then Inside_Generic_Body (UU_Typ) + and then In_Variant_Part + and then Is_Private_Type (Typ) + and then Is_Generic_Type (Typ) + then + Error_Msg_N + ("component of Unchecked_Union cannot be of generic type", Comp); + + elsif Needs_Finalization (Typ) then + Error_Msg_N + ("component of Unchecked_Union cannot be controlled", Comp); + + elsif Has_Task (Typ) then + Error_Msg_N + ("component of Unchecked_Union cannot have tasks", Comp); + end if; + end Check_Component; + + ---------------------------- + -- Check_Duplicate_Pragma -- + ---------------------------- + + procedure Check_Duplicate_Pragma (E : Entity_Id) is + P : Node_Id; + + begin + -- Nothing to do if this pragma comes from an aspect specification, + -- since we could not be duplicating a pragma, and we dealt with the + -- case of duplicated aspects in Analyze_Aspect_Specifications. + + if From_Aspect_Specification (N) then + return; + end if; + + -- Otherwise current pragma may duplicate previous pragma or a + -- previously given aspect specification for the same pragma. + + P := Get_Rep_Item_For_Entity (E, Pragma_Name (N)); + + if Present (P) then + Error_Msg_Name_1 := Pragma_Name (N); + Error_Msg_Sloc := Sloc (P); + + if Nkind (P) = N_Aspect_Specification + or else From_Aspect_Specification (P) + then + Error_Msg_NE ("aspect% for & previously given#", N, E); + else + Error_Msg_NE ("pragma% for & duplicates pragma#", N, E); + end if; + + raise Pragma_Exit; + end if; + end Check_Duplicate_Pragma; + + ---------------------------------- + -- Check_Duplicated_Export_Name -- + ---------------------------------- + + procedure Check_Duplicated_Export_Name (Nam : Node_Id) is + String_Val : constant String_Id := Strval (Nam); + + begin + -- We are only interested in the export case, and in the case of + -- generics, it is the instance, not the template, that is the + -- problem (the template will generate a warning in any case). + + if not Inside_A_Generic + and then (Prag_Id = Pragma_Export + or else + Prag_Id = Pragma_Export_Procedure + or else + Prag_Id = Pragma_Export_Valued_Procedure + or else + Prag_Id = Pragma_Export_Function) + then + for J in Externals.First .. Externals.Last loop + if String_Equal (String_Val, Strval (Externals.Table (J))) then + Error_Msg_Sloc := Sloc (Externals.Table (J)); + Error_Msg_N ("external name duplicates name given#", Nam); + exit; + end if; + end loop; + + Externals.Append (Nam); + end if; + end Check_Duplicated_Export_Name; + + ------------------------- + -- Check_First_Subtype -- + ------------------------- + + procedure Check_First_Subtype (Arg : Node_Id) is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); + Ent : constant Entity_Id := Entity (Argx); + + begin + if Is_First_Subtype (Ent) then + null; + + elsif Is_Type (Ent) then + Error_Pragma_Arg + ("pragma% cannot apply to subtype", Argx); + + elsif Is_Object (Ent) then + Error_Pragma_Arg + ("pragma% cannot apply to object, requires a type", Argx); + + else + Error_Pragma_Arg + ("pragma% cannot apply to&, requires a type", Argx); + end if; + end Check_First_Subtype; + + --------------------------- + -- Check_In_Main_Program -- + --------------------------- + + procedure Check_In_Main_Program is + P : constant Node_Id := Parent (N); + + begin + -- Must be at in subprogram body + + if Nkind (P) /= N_Subprogram_Body then + Error_Pragma ("% pragma allowed only in subprogram"); + + -- Otherwise warn if obviously not main program + + elsif Present (Parameter_Specifications (Specification (P))) + or else not Is_Compilation_Unit (Defining_Entity (P)) + then + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("?pragma% is only effective in main program", N); + end if; + end Check_In_Main_Program; + + --------------------------------------- + -- Check_Interrupt_Or_Attach_Handler -- + --------------------------------------- + + procedure Check_Interrupt_Or_Attach_Handler is + Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1); + Handler_Proc, Proc_Scope : Entity_Id; + + begin + Analyze (Arg1_X); + + if Prag_Id = Pragma_Interrupt_Handler then + Check_Restriction (No_Dynamic_Attachment, N); + end if; + + Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1); + Proc_Scope := Scope (Handler_Proc); + + -- On AAMP only, a pragma Interrupt_Handler is supported for + -- nonprotected parameterless procedures. + + if not AAMP_On_Target + or else Prag_Id = Pragma_Attach_Handler + then + if Ekind (Proc_Scope) /= E_Protected_Type then + Error_Pragma_Arg + ("argument of pragma% must be protected procedure", Arg1); + end if; + + if Parent (N) /= Protected_Definition (Parent (Proc_Scope)) then + Error_Pragma ("pragma% must be in protected definition"); + end if; + end if; + + if not Is_Library_Level_Entity (Proc_Scope) + or else (AAMP_On_Target + and then not Is_Library_Level_Entity (Handler_Proc)) + then + Error_Pragma_Arg + ("argument for pragma% must be library level entity", Arg1); + end if; + + -- AI05-0033: A pragma cannot appear within a generic body, because + -- instance can be in a nested scope. The check that protected type + -- is itself a library-level declaration is done elsewhere. + + -- Note: we omit this check in Codepeer mode to properly handle code + -- prior to AI-0033 (pragmas don't matter to codepeer in any case). + + if Inside_A_Generic then + if Ekind (Scope (Current_Scope)) = E_Generic_Package + and then In_Package_Body (Scope (Current_Scope)) + and then not CodePeer_Mode + then + Error_Pragma ("pragma% cannot be used inside a generic"); + end if; + end if; + end Check_Interrupt_Or_Attach_Handler; + + ------------------------------------------- + -- Check_Is_In_Decl_Part_Or_Package_Spec -- + ------------------------------------------- + + procedure Check_Is_In_Decl_Part_Or_Package_Spec is + P : Node_Id; + + begin + P := Parent (N); + loop + if No (P) then + exit; + + elsif Nkind (P) = N_Handled_Sequence_Of_Statements then + exit; + + elsif Nkind_In (P, N_Package_Specification, + N_Block_Statement) + then + return; + + -- Note: the following tests seem a little peculiar, because + -- they test for bodies, but if we were in the statement part + -- of the body, we would already have hit the handled statement + -- sequence, so the only way we get here is by being in the + -- declarative part of the body. + + elsif Nkind_In (P, N_Subprogram_Body, + N_Package_Body, + N_Task_Body, + N_Entry_Body) + then + return; + end if; + + P := Parent (P); + end loop; + + Error_Pragma ("pragma% is not in declarative part or package spec"); + end Check_Is_In_Decl_Part_Or_Package_Spec; + + ------------------------- + -- Check_No_Identifier -- + ------------------------- + + procedure Check_No_Identifier (Arg : Node_Id) is + begin + if Nkind (Arg) = N_Pragma_Argument_Association + and then Chars (Arg) /= No_Name + then + Error_Pragma_Arg_Ident + ("pragma% does not permit identifier& here", Arg); + end if; + end Check_No_Identifier; + + -------------------------- + -- Check_No_Identifiers -- + -------------------------- + + procedure Check_No_Identifiers is + Arg_Node : Node_Id; + begin + if Arg_Count > 0 then + Arg_Node := Arg1; + while Present (Arg_Node) loop + Check_No_Identifier (Arg_Node); + Next (Arg_Node); + end loop; + end if; + end Check_No_Identifiers; + + ------------------------------- + -- Check_Optional_Identifier -- + ------------------------------- + + procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is + begin + if Present (Arg) + and then Nkind (Arg) = N_Pragma_Argument_Association + and then Chars (Arg) /= No_Name + then + if Chars (Arg) /= Id then + Error_Msg_Name_1 := Pname; + Error_Msg_Name_2 := Id; + Error_Msg_N ("pragma% argument expects identifier%", Arg); + raise Pragma_Exit; + end if; + end if; + end Check_Optional_Identifier; + + procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is + begin + Name_Buffer (1 .. Id'Length) := Id; + Name_Len := Id'Length; + Check_Optional_Identifier (Arg, Name_Find); + end Check_Optional_Identifier; + + -------------------------------------- + -- Check_Precondition_Postcondition -- + -------------------------------------- + + procedure Check_Precondition_Postcondition (In_Body : out Boolean) is + P : Node_Id; + PO : Node_Id; + + procedure Chain_PPC (PO : Node_Id); + -- If PO is a subprogram declaration node (or a generic subprogram + -- declaration node), then the precondition/postcondition applies + -- to this subprogram and the processing for the pragma is completed. + -- Otherwise the pragma is misplaced. + + --------------- + -- Chain_PPC -- + --------------- + + procedure Chain_PPC (PO : Node_Id) is + S : Entity_Id; + P : Node_Id; + + begin + if Nkind (PO) = N_Abstract_Subprogram_Declaration then + if not From_Aspect_Specification (N) then + Error_Pragma + ("pragma% cannot be applied to abstract subprogram"); + + elsif Class_Present (N) then + null; + + else + Error_Pragma + ("aspect % requires ''Class for abstract subprogram"); + end if; + + elsif not Nkind_In (PO, N_Subprogram_Declaration, + N_Generic_Subprogram_Declaration, + N_Entry_Declaration) + then + Pragma_Misplaced; + end if; + + -- Here if we have [generic] subprogram or entry declaration + + if Nkind (PO) = N_Entry_Declaration then + S := Defining_Entity (PO); + else + S := Defining_Unit_Name (Specification (PO)); + end if; + + -- Make sure we do not have the case of a precondition pragma when + -- the Pre'Class aspect is present. + + -- We do this by looking at pragmas already chained to the entity + -- since the aspect derived pragma will be put on this list first. + + if Pragma_Name (N) = Name_Precondition then + if not From_Aspect_Specification (N) then + P := Spec_PPC_List (S); + while Present (P) loop + if Pragma_Name (P) = Name_Precondition + and then From_Aspect_Specification (P) + and then Class_Present (P) + then + Error_Msg_Sloc := Sloc (P); + Error_Pragma + ("pragma% not allowed, `Pre''Class` aspect given#"); + end if; + + P := Next_Pragma (P); + end loop; + end if; + end if; + + -- Similarly check for Pre with inherited Pre'Class. Note that + -- we cover the aspect case as well here. + + if Pragma_Name (N) = Name_Precondition + and then not Class_Present (N) + then + declare + Inherited : constant Subprogram_List := + Inherited_Subprograms (S); + P : Node_Id; + + begin + for J in Inherited'Range loop + P := Spec_PPC_List (Inherited (J)); + while Present (P) loop + if Pragma_Name (P) = Name_Precondition + and then Class_Present (P) + then + Error_Msg_Sloc := Sloc (P); + Error_Pragma + ("pragma% not allowed, `Pre''Class` " + & "aspect inherited from#"); + end if; + + P := Next_Pragma (P); + end loop; + end loop; + end; + end if; + + -- Note: we do not analyze the pragma at this point. Instead we + -- delay this analysis until the end of the declarative part in + -- which the pragma appears. This implements the required delay + -- in this analysis, allowing forward references. The analysis + -- happens at the end of Analyze_Declarations. + + -- Chain spec PPC pragma to list for subprogram + + Set_Next_Pragma (N, Spec_PPC_List (S)); + Set_Spec_PPC_List (S, N); + + -- Return indicating spec case + + In_Body := False; + return; + end Chain_PPC; + + -- Start of processing for Check_Precondition_Postcondition + + begin + if not Is_List_Member (N) then + Pragma_Misplaced; + end if; + + -- Preanalyze message argument if present. Visibility in this + -- argument is established at the point of pragma occurrence. + + if Arg_Count = 2 then + Check_Optional_Identifier (Arg2, Name_Message); + Preanalyze_Spec_Expression + (Get_Pragma_Arg (Arg2), Standard_String); + end if; + + -- Record if pragma is enabled + + if Check_Enabled (Pname) then + Set_Pragma_Enabled (N); + Set_SCO_Pragma_Enabled (Loc); + end if; + + -- If we are within an inlined body, the legality of the pragma + -- has been checked already. + + if In_Inlined_Body then + In_Body := True; + return; + end if; + + -- Search prior declarations + + P := N; + while Present (Prev (P)) loop + P := Prev (P); + + -- If the previous node is a generic subprogram, do not go to to + -- the original node, which is the unanalyzed tree: we need to + -- attach the pre/postconditions to the analyzed version at this + -- point. They get propagated to the original tree when analyzing + -- the corresponding body. + + if Nkind (P) not in N_Generic_Declaration then + PO := Original_Node (P); + else + PO := P; + end if; + + -- Skip past prior pragma + + if Nkind (PO) = N_Pragma then + null; + + -- Skip stuff not coming from source + + elsif not Comes_From_Source (PO) then + null; + + -- Only remaining possibility is subprogram declaration + + else + Chain_PPC (PO); + return; + end if; + end loop; + + -- If we fall through loop, pragma is at start of list, so see if it + -- is at the start of declarations of a subprogram body. + + if Nkind (Parent (N)) = N_Subprogram_Body + and then List_Containing (N) = Declarations (Parent (N)) + then + if Operating_Mode /= Generate_Code + or else Inside_A_Generic + then + -- Analyze pragma expression for correctness and for ASIS use + + Preanalyze_Spec_Expression + (Get_Pragma_Arg (Arg1), Standard_Boolean); + end if; + + In_Body := True; + return; + + -- See if it is in the pragmas after a library level subprogram + + elsif Nkind (Parent (N)) = N_Compilation_Unit_Aux then + Chain_PPC (Unit (Parent (Parent (N)))); + return; + end if; + + -- If we fall through, pragma was misplaced + + Pragma_Misplaced; + end Check_Precondition_Postcondition; + + ----------------------------- + -- Check_Static_Constraint -- + ----------------------------- + + -- Note: for convenience in writing this procedure, in addition to + -- the officially (i.e. by spec) allowed argument which is always a + -- constraint, it also allows ranges and discriminant associations. + -- Above is not clear ??? + + procedure Check_Static_Constraint (Constr : Node_Id) is + + procedure Require_Static (E : Node_Id); + -- Require given expression to be static expression + + -------------------- + -- Require_Static -- + -------------------- + + procedure Require_Static (E : Node_Id) is + begin + if not Is_OK_Static_Expression (E) then + Flag_Non_Static_Expr + ("non-static constraint not allowed in Unchecked_Union!", E); + raise Pragma_Exit; + end if; + end Require_Static; + + -- Start of processing for Check_Static_Constraint + + begin + case Nkind (Constr) is + when N_Discriminant_Association => + Require_Static (Expression (Constr)); + + when N_Range => + Require_Static (Low_Bound (Constr)); + Require_Static (High_Bound (Constr)); + + when N_Attribute_Reference => + Require_Static (Type_Low_Bound (Etype (Prefix (Constr)))); + Require_Static (Type_High_Bound (Etype (Prefix (Constr)))); + + when N_Range_Constraint => + Check_Static_Constraint (Range_Expression (Constr)); + + when N_Index_Or_Discriminant_Constraint => + declare + IDC : Entity_Id; + begin + IDC := First (Constraints (Constr)); + while Present (IDC) loop + Check_Static_Constraint (IDC); + Next (IDC); + end loop; + end; + + when others => + null; + end case; + end Check_Static_Constraint; + + -------------------------------------- + -- Check_Valid_Configuration_Pragma -- + -------------------------------------- + + -- A configuration pragma must appear in the context clause of a + -- compilation unit, and only other pragmas may precede it. Note that + -- the test also allows use in a configuration pragma file. + + procedure Check_Valid_Configuration_Pragma is + begin + if not Is_Configuration_Pragma then + Error_Pragma ("incorrect placement for configuration pragma%"); + end if; + end Check_Valid_Configuration_Pragma; + + ------------------------------------- + -- Check_Valid_Library_Unit_Pragma -- + ------------------------------------- + + procedure Check_Valid_Library_Unit_Pragma is + Plist : List_Id; + Parent_Node : Node_Id; + Unit_Name : Entity_Id; + Unit_Kind : Node_Kind; + Unit_Node : Node_Id; + Sindex : Source_File_Index; + + begin + if not Is_List_Member (N) then + Pragma_Misplaced; + + else + Plist := List_Containing (N); + Parent_Node := Parent (Plist); + + if Parent_Node = Empty then + Pragma_Misplaced; + + -- Case of pragma appearing after a compilation unit. In this case + -- it must have an argument with the corresponding name and must + -- be part of the following pragmas of its parent. + + elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then + if Plist /= Pragmas_After (Parent_Node) then + Pragma_Misplaced; + + elsif Arg_Count = 0 then + Error_Pragma + ("argument required if outside compilation unit"); + + else + Check_No_Identifiers; + Check_Arg_Count (1); + Unit_Node := Unit (Parent (Parent_Node)); + Unit_Kind := Nkind (Unit_Node); + + Analyze (Get_Pragma_Arg (Arg1)); + + if Unit_Kind = N_Generic_Subprogram_Declaration + or else Unit_Kind = N_Subprogram_Declaration + then + Unit_Name := Defining_Entity (Unit_Node); + + elsif Unit_Kind in N_Generic_Instantiation then + Unit_Name := Defining_Entity (Unit_Node); + + else + Unit_Name := Cunit_Entity (Current_Sem_Unit); + end if; + + if Chars (Unit_Name) /= + Chars (Entity (Get_Pragma_Arg (Arg1))) + then + Error_Pragma_Arg + ("pragma% argument is not current unit name", Arg1); + end if; + + if Ekind (Unit_Name) = E_Package + and then Present (Renamed_Entity (Unit_Name)) + then + Error_Pragma ("pragma% not allowed for renamed package"); + end if; + end if; + + -- Pragma appears other than after a compilation unit + + else + -- Here we check for the generic instantiation case and also + -- for the case of processing a generic formal package. We + -- detect these cases by noting that the Sloc on the node + -- does not belong to the current compilation unit. + + Sindex := Source_Index (Current_Sem_Unit); + + if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then + Rewrite (N, Make_Null_Statement (Loc)); + return; + + -- If before first declaration, the pragma applies to the + -- enclosing unit, and the name if present must be this name. + + elsif Is_Before_First_Decl (N, Plist) then + Unit_Node := Unit_Declaration_Node (Current_Scope); + Unit_Kind := Nkind (Unit_Node); + + if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then + Pragma_Misplaced; + + elsif Unit_Kind = N_Subprogram_Body + and then not Acts_As_Spec (Unit_Node) + then + Pragma_Misplaced; + + elsif Nkind (Parent_Node) = N_Package_Body then + Pragma_Misplaced; + + elsif Nkind (Parent_Node) = N_Package_Specification + and then Plist = Private_Declarations (Parent_Node) + then + Pragma_Misplaced; + + elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration + or else Nkind (Parent_Node) = + N_Generic_Subprogram_Declaration) + and then Plist = Generic_Formal_Declarations (Parent_Node) + then + Pragma_Misplaced; + + elsif Arg_Count > 0 then + Analyze (Get_Pragma_Arg (Arg1)); + + if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then + Error_Pragma_Arg + ("name in pragma% must be enclosing unit", Arg1); + end if; + + -- It is legal to have no argument in this context + + else + return; + end if; + + -- Error if not before first declaration. This is because a + -- library unit pragma argument must be the name of a library + -- unit (RM 10.1.5(7)), but the only names permitted in this + -- context are (RM 10.1.5(6)) names of subprogram declarations, + -- generic subprogram declarations or generic instantiations. + + else + Error_Pragma + ("pragma% misplaced, must be before first declaration"); + end if; + end if; + end if; + end Check_Valid_Library_Unit_Pragma; + + ------------------- + -- Check_Variant -- + ------------------- + + procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is + Clist : constant Node_Id := Component_List (Variant); + Comp : Node_Id; + + begin + if not Is_Non_Empty_List (Component_Items (Clist)) then + Error_Msg_N + ("Unchecked_Union may not have empty component list", + Variant); + return; + end if; + + Comp := First (Component_Items (Clist)); + while Present (Comp) loop + Check_Component (Comp, UU_Typ, In_Variant_Part => True); + Next (Comp); + end loop; + end Check_Variant; + + ------------------ + -- Error_Pragma -- + ------------------ + + procedure Error_Pragma (Msg : String) is + MsgF : String := Msg; + begin + Error_Msg_Name_1 := Pname; + Fix_Error (MsgF); + Error_Msg_N (MsgF, N); + raise Pragma_Exit; + end Error_Pragma; + + ---------------------- + -- Error_Pragma_Arg -- + ---------------------- + + procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is + MsgF : String := Msg; + begin + Error_Msg_Name_1 := Pname; + Fix_Error (MsgF); + Error_Msg_N (MsgF, Get_Pragma_Arg (Arg)); + raise Pragma_Exit; + end Error_Pragma_Arg; + + procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is + MsgF : String := Msg1; + begin + Error_Msg_Name_1 := Pname; + Fix_Error (MsgF); + Error_Msg_N (MsgF, Get_Pragma_Arg (Arg)); + Error_Pragma_Arg (Msg2, Arg); + end Error_Pragma_Arg; + + ---------------------------- + -- Error_Pragma_Arg_Ident -- + ---------------------------- + + procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is + MsgF : String := Msg; + begin + Error_Msg_Name_1 := Pname; + Fix_Error (MsgF); + Error_Msg_N (MsgF, Arg); + raise Pragma_Exit; + end Error_Pragma_Arg_Ident; + + ---------------------- + -- Error_Pragma_Ref -- + ---------------------- + + procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is + MsgF : String := Msg; + begin + Error_Msg_Name_1 := Pname; + Fix_Error (MsgF); + Error_Msg_Sloc := Sloc (Ref); + Error_Msg_NE (MsgF, N, Ref); + raise Pragma_Exit; + end Error_Pragma_Ref; + + ------------------------ + -- Find_Lib_Unit_Name -- + ------------------------ + + function Find_Lib_Unit_Name return Entity_Id is + begin + -- Return inner compilation unit entity, for case of nested + -- categorization pragmas. This happens in generic unit. + + if Nkind (Parent (N)) = N_Package_Specification + and then Defining_Entity (Parent (N)) /= Current_Scope + then + return Defining_Entity (Parent (N)); + else + return Current_Scope; + end if; + end Find_Lib_Unit_Name; + + ---------------------------- + -- Find_Program_Unit_Name -- + ---------------------------- + + procedure Find_Program_Unit_Name (Id : Node_Id) is + Unit_Name : Entity_Id; + Unit_Kind : Node_Kind; + P : constant Node_Id := Parent (N); + + begin + if Nkind (P) = N_Compilation_Unit then + Unit_Kind := Nkind (Unit (P)); + + if Unit_Kind = N_Subprogram_Declaration + or else Unit_Kind = N_Package_Declaration + or else Unit_Kind in N_Generic_Declaration + then + Unit_Name := Defining_Entity (Unit (P)); + + if Chars (Id) = Chars (Unit_Name) then + Set_Entity (Id, Unit_Name); + Set_Etype (Id, Etype (Unit_Name)); + else + Set_Etype (Id, Any_Type); + Error_Pragma + ("cannot find program unit referenced by pragma%"); + end if; + + else + Set_Etype (Id, Any_Type); + Error_Pragma ("pragma% inapplicable to this unit"); + end if; + + else + Analyze (Id); + end if; + end Find_Program_Unit_Name; + + ----------------------------------------- + -- Find_Unique_Parameterless_Procedure -- + ----------------------------------------- + + function Find_Unique_Parameterless_Procedure + (Name : Entity_Id; + Arg : Node_Id) return Entity_Id + is + Proc : Entity_Id := Empty; + + begin + -- The body of this procedure needs some comments ??? + + if not Is_Entity_Name (Name) then + Error_Pragma_Arg + ("argument of pragma% must be entity name", Arg); + + elsif not Is_Overloaded (Name) then + Proc := Entity (Name); + + if Ekind (Proc) /= E_Procedure + or else Present (First_Formal (Proc)) + then + Error_Pragma_Arg + ("argument of pragma% must be parameterless procedure", Arg); + end if; + + else + declare + Found : Boolean := False; + It : Interp; + Index : Interp_Index; + + begin + Get_First_Interp (Name, Index, It); + while Present (It.Nam) loop + Proc := It.Nam; + + if Ekind (Proc) = E_Procedure + and then No (First_Formal (Proc)) + then + if not Found then + Found := True; + Set_Entity (Name, Proc); + Set_Is_Overloaded (Name, False); + else + Error_Pragma_Arg + ("ambiguous handler name for pragma% ", Arg); + end if; + end if; + + Get_Next_Interp (Index, It); + end loop; + + if not Found then + Error_Pragma_Arg + ("argument of pragma% must be parameterless procedure", + Arg); + else + Proc := Entity (Name); + end if; + end; + end if; + + return Proc; + end Find_Unique_Parameterless_Procedure; + + --------------- + -- Fix_Error -- + --------------- + + procedure Fix_Error (Msg : in out String) is + begin + if From_Aspect_Specification (N) then + for J in Msg'First .. Msg'Last - 5 loop + if Msg (J .. J + 5) = "pragma" then + Msg (J .. J + 5) := "aspect"; + end if; + end loop; + + if Error_Msg_Name_1 = Name_Precondition then + Error_Msg_Name_1 := Name_Pre; + elsif Error_Msg_Name_1 = Name_Postcondition then + Error_Msg_Name_1 := Name_Post; + end if; + end if; + end Fix_Error; + + ------------------------- + -- Gather_Associations -- + ------------------------- + + procedure Gather_Associations + (Names : Name_List; + Args : out Args_List) + is + Arg : Node_Id; + + begin + -- Initialize all parameters to Empty + + for J in Args'Range loop + Args (J) := Empty; + end loop; + + -- That's all we have to do if there are no argument associations + + if No (Pragma_Argument_Associations (N)) then + return; + end if; + + -- Otherwise first deal with any positional parameters present + + Arg := First (Pragma_Argument_Associations (N)); + for Index in Args'Range loop + exit when No (Arg) or else Chars (Arg) /= No_Name; + Args (Index) := Get_Pragma_Arg (Arg); + Next (Arg); + end loop; + + -- Positional parameters all processed, if any left, then we + -- have too many positional parameters. + + if Present (Arg) and then Chars (Arg) = No_Name then + Error_Pragma_Arg + ("too many positional associations for pragma%", Arg); + end if; + + -- Process named parameters if any are present + + while Present (Arg) loop + if Chars (Arg) = No_Name then + Error_Pragma_Arg + ("positional association cannot follow named association", + Arg); + + else + for Index in Names'Range loop + if Names (Index) = Chars (Arg) then + if Present (Args (Index)) then + Error_Pragma_Arg + ("duplicate argument association for pragma%", Arg); + else + Args (Index) := Get_Pragma_Arg (Arg); + exit; + end if; + end if; + + if Index = Names'Last then + Error_Msg_Name_1 := Pname; + Error_Msg_N ("pragma% does not allow & argument", Arg); + + -- Check for possible misspelling + + for Index1 in Names'Range loop + if Is_Bad_Spelling_Of + (Chars (Arg), Names (Index1)) + then + Error_Msg_Name_1 := Names (Index1); + Error_Msg_N -- CODEFIX + ("\possible misspelling of%", Arg); + exit; + end if; + end loop; + + raise Pragma_Exit; + end if; + end loop; + end if; + + Next (Arg); + end loop; + end Gather_Associations; + + ----------------- + -- GNAT_Pragma -- + ----------------- + + procedure GNAT_Pragma is + begin + Check_Restriction (No_Implementation_Pragmas, N); + end GNAT_Pragma; + + -------------------------- + -- Is_Before_First_Decl -- + -------------------------- + + function Is_Before_First_Decl + (Pragma_Node : Node_Id; + Decls : List_Id) return Boolean + is + Item : Node_Id := First (Decls); + + begin + -- Only other pragmas can come before this pragma + + loop + if No (Item) or else Nkind (Item) /= N_Pragma then + return False; + + elsif Item = Pragma_Node then + return True; + end if; + + Next (Item); + end loop; + end Is_Before_First_Decl; + + ----------------------------- + -- Is_Configuration_Pragma -- + ----------------------------- + + -- A configuration pragma must appear in the context clause of a + -- compilation unit, and only other pragmas may precede it. Note that + -- the test below also permits use in a configuration pragma file. + + function Is_Configuration_Pragma return Boolean is + Lis : constant List_Id := List_Containing (N); + Par : constant Node_Id := Parent (N); + Prg : Node_Id; + + begin + -- If no parent, then we are in the configuration pragma file, + -- so the placement is definitely appropriate. + + if No (Par) then + return True; + + -- Otherwise we must be in the context clause of a compilation unit + -- and the only thing allowed before us in the context list is more + -- configuration pragmas. + + elsif Nkind (Par) = N_Compilation_Unit + and then Context_Items (Par) = Lis + then + Prg := First (Lis); + + loop + if Prg = N then + return True; + elsif Nkind (Prg) /= N_Pragma then + return False; + end if; + + Next (Prg); + end loop; + + else + return False; + end if; + end Is_Configuration_Pragma; + + -------------------------- + -- Is_In_Context_Clause -- + -------------------------- + + function Is_In_Context_Clause return Boolean is + Plist : List_Id; + Parent_Node : Node_Id; + + begin + if not Is_List_Member (N) then + return False; + + else + Plist := List_Containing (N); + Parent_Node := Parent (Plist); + + if Parent_Node = Empty + or else Nkind (Parent_Node) /= N_Compilation_Unit + or else Context_Items (Parent_Node) /= Plist + then + return False; + end if; + end if; + + return True; + end Is_In_Context_Clause; + + --------------------------------- + -- Is_Static_String_Expression -- + --------------------------------- + + function Is_Static_String_Expression (Arg : Node_Id) return Boolean is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); + + begin + Analyze_And_Resolve (Argx); + return Is_OK_Static_Expression (Argx) + and then Nkind (Argx) = N_String_Literal; + end Is_Static_String_Expression; + + ---------------------- + -- Pragma_Misplaced -- + ---------------------- + + procedure Pragma_Misplaced is + begin + Error_Pragma ("incorrect placement of pragma%"); + end Pragma_Misplaced; + + ------------------------------------ + -- Process Atomic_Shared_Volatile -- + ------------------------------------ + + procedure Process_Atomic_Shared_Volatile is + E_Id : Node_Id; + E : Entity_Id; + D : Node_Id; + K : Node_Kind; + Utyp : Entity_Id; + + procedure Set_Atomic (E : Entity_Id); + -- Set given type as atomic, and if no explicit alignment was given, + -- set alignment to unknown, since back end knows what the alignment + -- requirements are for atomic arrays. Note: this step is necessary + -- for derived types. + + ---------------- + -- Set_Atomic -- + ---------------- + + procedure Set_Atomic (E : Entity_Id) is + begin + Set_Is_Atomic (E, Sense); + + if Sense and then not Has_Alignment_Clause (E) then + Set_Alignment (E, Uint_0); + end if; + end Set_Atomic; + + -- Start of processing for Process_Atomic_Shared_Volatile + + begin + Check_Ada_83_Warning; + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + E_Id := Get_Pragma_Arg (Arg1); + + if Etype (E_Id) = Any_Type then + return; + end if; + + E := Entity (E_Id); + D := Declaration_Node (E); + K := Nkind (D); + + -- Check duplicate before we chain ourselves! + + Check_Duplicate_Pragma (E); + + -- Now check appropriateness of the entity + + if Is_Type (E) then + if Rep_Item_Too_Early (E, N) + or else + Rep_Item_Too_Late (E, N) + then + return; + else + Check_First_Subtype (Arg1); + end if; + + if Prag_Id /= Pragma_Volatile then + Set_Atomic (E); + Set_Atomic (Underlying_Type (E)); + Set_Atomic (Base_Type (E)); + end if; + + -- Attribute belongs on the base type. If the view of the type is + -- currently private, it also belongs on the underlying type. + + Set_Is_Volatile (Base_Type (E), Sense); + Set_Is_Volatile (Underlying_Type (E), Sense); + + Set_Treat_As_Volatile (E, Sense); + Set_Treat_As_Volatile (Underlying_Type (E), Sense); + + elsif K = N_Object_Declaration + or else (K = N_Component_Declaration + and then Original_Record_Component (E) = E) + then + if Rep_Item_Too_Late (E, N) then + return; + end if; + + if Prag_Id /= Pragma_Volatile then + Set_Is_Atomic (E, Sense); + + -- If the object declaration has an explicit initialization, a + -- temporary may have to be created to hold the expression, to + -- ensure that access to the object remain atomic. + + if Nkind (Parent (E)) = N_Object_Declaration + and then Present (Expression (Parent (E))) + and then Sense + then + Set_Has_Delayed_Freeze (E); + end if; + + -- An interesting improvement here. If an object of type X is + -- declared atomic, and the type X is not atomic, that's a + -- pity, since it may not have appropriate alignment etc. We + -- can rescue this in the special case where the object and + -- type are in the same unit by just setting the type as + -- atomic, so that the back end will process it as atomic. + + Utyp := Underlying_Type (Etype (E)); + + if Present (Utyp) + and then Sloc (E) > No_Location + and then Sloc (Utyp) > No_Location + and then + Get_Source_File_Index (Sloc (E)) = + Get_Source_File_Index (Sloc (Underlying_Type (Etype (E)))) + then + Set_Is_Atomic (Underlying_Type (Etype (E)), Sense); + end if; + end if; + + Set_Is_Volatile (E); + Set_Treat_As_Volatile (E); + + else + Error_Pragma_Arg + ("inappropriate entity for pragma%", Arg1); + end if; + end Process_Atomic_Shared_Volatile; + + ------------------------------------------- + -- Process_Compile_Time_Warning_Or_Error -- + ------------------------------------------- + + procedure Process_Compile_Time_Warning_Or_Error is + Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1); + + begin + Check_Arg_Count (2); + Check_No_Identifiers; + Check_Arg_Is_Static_Expression (Arg2, Standard_String); + Analyze_And_Resolve (Arg1x, Standard_Boolean); + + if Compile_Time_Known_Value (Arg1x) then + if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then + declare + Str : constant String_Id := + Strval (Get_Pragma_Arg (Arg2)); + Len : constant Int := String_Length (Str); + Cont : Boolean; + Ptr : Nat; + CC : Char_Code; + C : Character; + Cent : constant Entity_Id := + Cunit_Entity (Current_Sem_Unit); + + Force : constant Boolean := + Prag_Id = Pragma_Compile_Time_Warning + and then + Is_Spec_Name (Unit_Name (Current_Sem_Unit)) + and then (Ekind (Cent) /= E_Package + or else not In_Private_Part (Cent)); + -- Set True if this is the warning case, and we are in the + -- visible part of a package spec, or in a subprogram spec, + -- in which case we want to force the client to see the + -- warning, even though it is not in the main unit. + + begin + -- Loop through segments of message separated by line feeds. + -- We output these segments as separate messages with + -- continuation marks for all but the first. + + Cont := False; + Ptr := 1; + loop + Error_Msg_Strlen := 0; + + -- Loop to copy characters from argument to error message + -- string buffer. + + loop + exit when Ptr > Len; + CC := Get_String_Char (Str, Ptr); + Ptr := Ptr + 1; + + -- Ignore wide chars ??? else store character + + if In_Character_Range (CC) then + C := Get_Character (CC); + exit when C = ASCII.LF; + Error_Msg_Strlen := Error_Msg_Strlen + 1; + Error_Msg_String (Error_Msg_Strlen) := C; + end if; + end loop; + + -- Here with one line ready to go + + Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning; + + -- If this is a warning in a spec, then we want clients + -- to see the warning, so mark the message with the + -- special sequence !! to force the warning. In the case + -- of a package spec, we do not force this if we are in + -- the private part of the spec. + + if Force then + if Cont = False then + Error_Msg_N ("<~!!", Arg1); + Cont := True; + else + Error_Msg_N ("\<~!!", Arg1); + end if; + + -- Error, rather than warning, or in a body, so we do not + -- need to force visibility for client (error will be + -- output in any case, and this is the situation in which + -- we do not want a client to get a warning, since the + -- warning is in the body or the spec private part). + + else + if Cont = False then + Error_Msg_N ("<~", Arg1); + Cont := True; + else + Error_Msg_N ("\<~", Arg1); + end if; + end if; + + exit when Ptr > Len; + end loop; + end; + end if; + end if; + end Process_Compile_Time_Warning_Or_Error; + + ------------------------ + -- Process_Convention -- + ------------------------ + + procedure Process_Convention + (C : out Convention_Id; + Ent : out Entity_Id) + is + Id : Node_Id; + E : Entity_Id; + E1 : Entity_Id; + Cname : Name_Id; + Comp_Unit : Unit_Number_Type; + + procedure Diagnose_Multiple_Pragmas (S : Entity_Id); + -- Called if we have more than one Export/Import/Convention pragma. + -- This is generally illegal, but we have a special case of allowing + -- Import and Interface to coexist if they specify the convention in + -- a consistent manner. We are allowed to do this, since Interface is + -- an implementation defined pragma, and we choose to do it since we + -- know Rational allows this combination. S is the entity id of the + -- subprogram in question. This procedure also sets the special flag + -- Import_Interface_Present in both pragmas in the case where we do + -- have matching Import and Interface pragmas. + + procedure Set_Convention_From_Pragma (E : Entity_Id); + -- Set convention in entity E, and also flag that the entity has a + -- convention pragma. If entity is for a private or incomplete type, + -- also set convention and flag on underlying type. This procedure + -- also deals with the special case of C_Pass_By_Copy convention. + + ------------------------------- + -- Diagnose_Multiple_Pragmas -- + ------------------------------- + + procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is + Pdec : constant Node_Id := Declaration_Node (S); + Decl : Node_Id; + Err : Boolean; + + function Same_Convention (Decl : Node_Id) return Boolean; + -- Decl is a pragma node. This function returns True if this + -- pragma has a first argument that is an identifier with a + -- Chars field corresponding to the Convention_Id C. + + function Same_Name (Decl : Node_Id) return Boolean; + -- Decl is a pragma node. This function returns True if this + -- pragma has a second argument that is an identifier with a + -- Chars field that matches the Chars of the current subprogram. + + --------------------- + -- Same_Convention -- + --------------------- + + function Same_Convention (Decl : Node_Id) return Boolean is + Arg1 : constant Node_Id := + First (Pragma_Argument_Associations (Decl)); + + begin + if Present (Arg1) then + declare + Arg : constant Node_Id := Get_Pragma_Arg (Arg1); + begin + if Nkind (Arg) = N_Identifier + and then Is_Convention_Name (Chars (Arg)) + and then Get_Convention_Id (Chars (Arg)) = C + then + return True; + end if; + end; + end if; + + return False; + end Same_Convention; + + --------------- + -- Same_Name -- + --------------- + + function Same_Name (Decl : Node_Id) return Boolean is + Arg1 : constant Node_Id := + First (Pragma_Argument_Associations (Decl)); + Arg2 : Node_Id; + + begin + if No (Arg1) then + return False; + end if; + + Arg2 := Next (Arg1); + + if No (Arg2) then + return False; + end if; + + declare + Arg : constant Node_Id := Get_Pragma_Arg (Arg2); + begin + if Nkind (Arg) = N_Identifier + and then Chars (Arg) = Chars (S) + then + return True; + end if; + end; + + return False; + end Same_Name; + + -- Start of processing for Diagnose_Multiple_Pragmas + + begin + Err := True; + + -- Definitely give message if we have Convention/Export here + + if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then + null; + + -- If we have an Import or Export, scan back from pragma to + -- find any previous pragma applying to the same procedure. + -- The scan will be terminated by the start of the list, or + -- hitting the subprogram declaration. This won't allow one + -- pragma to appear in the public part and one in the private + -- part, but that seems very unlikely in practice. + + else + Decl := Prev (N); + while Present (Decl) and then Decl /= Pdec loop + + -- Look for pragma with same name as us + + if Nkind (Decl) = N_Pragma + and then Same_Name (Decl) + then + -- Give error if same as our pragma or Export/Convention + + if Pragma_Name (Decl) = Name_Export + or else + Pragma_Name (Decl) = Name_Convention + or else + Pragma_Name (Decl) = Pragma_Name (N) + then + exit; + + -- Case of Import/Interface or the other way round + + elsif Pragma_Name (Decl) = Name_Interface + or else + Pragma_Name (Decl) = Name_Import + then + -- Here we know that we have Import and Interface. It + -- doesn't matter which way round they are. See if + -- they specify the same convention. If so, all OK, + -- and set special flags to stop other messages + + if Same_Convention (Decl) then + Set_Import_Interface_Present (N); + Set_Import_Interface_Present (Decl); + Err := False; + + -- If different conventions, special message + + else + Error_Msg_Sloc := Sloc (Decl); + Error_Pragma_Arg + ("convention differs from that given#", Arg1); + return; + end if; + end if; + end if; + + Next (Decl); + end loop; + end if; + + -- Give message if needed if we fall through those tests + + if Err then + Error_Pragma_Arg + ("at most one Convention/Export/Import pragma is allowed", + Arg2); + end if; + end Diagnose_Multiple_Pragmas; + + -------------------------------- + -- Set_Convention_From_Pragma -- + -------------------------------- + + procedure Set_Convention_From_Pragma (E : Entity_Id) is + begin + -- Ada 2005 (AI-430): Check invalid attempt to change convention + -- for an overridden dispatching operation. Technically this is + -- an amendment and should only be done in Ada 2005 mode. However, + -- this is clearly a mistake, since the problem that is addressed + -- by this AI is that there is a clear gap in the RM! + + if Is_Dispatching_Operation (E) + and then Present (Overridden_Operation (E)) + and then C /= Convention (Overridden_Operation (E)) + then + Error_Pragma_Arg + ("cannot change convention for " & + "overridden dispatching operation", + Arg1); + end if; + + -- Set the convention + + Set_Convention (E, C); + Set_Has_Convention_Pragma (E); + + if Is_Incomplete_Or_Private_Type (E) then + Set_Convention (Underlying_Type (E), C); + Set_Has_Convention_Pragma (Underlying_Type (E), True); + end if; + + -- A class-wide type should inherit the convention of the specific + -- root type (although this isn't specified clearly by the RM). + + if Is_Type (E) and then Present (Class_Wide_Type (E)) then + Set_Convention (Class_Wide_Type (E), C); + end if; + + -- If the entity is a record type, then check for special case of + -- C_Pass_By_Copy, which is treated the same as C except that the + -- special record flag is set. This convention is only permitted + -- on record types (see AI95-00131). + + if Cname = Name_C_Pass_By_Copy then + if Is_Record_Type (E) then + Set_C_Pass_By_Copy (Base_Type (E)); + elsif Is_Incomplete_Or_Private_Type (E) + and then Is_Record_Type (Underlying_Type (E)) + then + Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E))); + else + Error_Pragma_Arg + ("C_Pass_By_Copy convention allowed only for record type", + Arg2); + end if; + end if; + + -- If the entity is a derived boolean type, check for the special + -- case of convention C, C++, or Fortran, where we consider any + -- nonzero value to represent true. + + if Is_Discrete_Type (E) + and then Root_Type (Etype (E)) = Standard_Boolean + and then + (C = Convention_C + or else + C = Convention_CPP + or else + C = Convention_Fortran) + then + Set_Nonzero_Is_True (Base_Type (E)); + end if; + end Set_Convention_From_Pragma; + + -- Start of processing for Process_Convention + + begin + Check_At_Least_N_Arguments (2); + Check_Optional_Identifier (Arg1, Name_Convention); + Check_Arg_Is_Identifier (Arg1); + Cname := Chars (Get_Pragma_Arg (Arg1)); + + -- C_Pass_By_Copy is treated as a synonym for convention C (this is + -- tested again below to set the critical flag). + + if Cname = Name_C_Pass_By_Copy then + C := Convention_C; + + -- Otherwise we must have something in the standard convention list + + elsif Is_Convention_Name (Cname) then + C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1))); + + -- In DEC VMS, it seems that there is an undocumented feature that + -- any unrecognized convention is treated as the default, which for + -- us is convention C. It does not seem so terrible to do this + -- unconditionally, silently in the VMS case, and with a warning + -- in the non-VMS case. + + else + if Warn_On_Export_Import and not OpenVMS_On_Target then + Error_Msg_N + ("?unrecognized convention name, C assumed", + Get_Pragma_Arg (Arg1)); + end if; + + C := Convention_C; + end if; + + Check_Optional_Identifier (Arg2, Name_Entity); + Check_Arg_Is_Local_Name (Arg2); + + Id := Get_Pragma_Arg (Arg2); + Analyze (Id); + + if not Is_Entity_Name (Id) then + Error_Pragma_Arg ("entity name required", Arg2); + end if; + + E := Entity (Id); + + -- Set entity to return + + Ent := E; + + -- Go to renamed subprogram if present, since convention applies to + -- the actual renamed entity, not to the renaming entity. If the + -- subprogram is inherited, go to parent subprogram. + + if Is_Subprogram (E) + and then Present (Alias (E)) + then + if Nkind (Parent (Declaration_Node (E))) = + N_Subprogram_Renaming_Declaration + then + if Scope (E) /= Scope (Alias (E)) then + Error_Pragma_Ref + ("cannot apply pragma% to non-local entity&#", E); + end if; + + E := Alias (E); + + elsif Nkind_In (Parent (E), N_Full_Type_Declaration, + N_Private_Extension_Declaration) + and then Scope (E) = Scope (Alias (E)) + then + E := Alias (E); + + -- Return the parent subprogram the entity was inherited from + + Ent := E; + end if; + end if; + + -- Check that we are not applying this to a specless body + + if Is_Subprogram (E) + and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body + then + Error_Pragma + ("pragma% requires separate spec and must come before body"); + end if; + + -- Check that we are not applying this to a named constant + + if Ekind_In (E, E_Named_Integer, E_Named_Real) then + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("cannot apply pragma% to named constant!", + Get_Pragma_Arg (Arg2)); + Error_Pragma_Arg + ("\supply appropriate type for&!", Arg2); + end if; + + if Ekind (E) = E_Enumeration_Literal then + Error_Pragma ("enumeration literal not allowed for pragma%"); + end if; + + -- Check for rep item appearing too early or too late + + if Etype (E) = Any_Type + or else Rep_Item_Too_Early (E, N) + then + raise Pragma_Exit; + else + E := Underlying_Type (E); + end if; + + if Rep_Item_Too_Late (E, N) then + raise Pragma_Exit; + end if; + + if Has_Convention_Pragma (E) then + Diagnose_Multiple_Pragmas (E); + + elsif Convention (E) = Convention_Protected + or else Ekind (Scope (E)) = E_Protected_Type + then + Error_Pragma_Arg + ("a protected operation cannot be given a different convention", + Arg2); + end if; + + -- For Intrinsic, a subprogram is required + + if C = Convention_Intrinsic + and then not Is_Subprogram (E) + and then not Is_Generic_Subprogram (E) + then + Error_Pragma_Arg + ("second argument of pragma% must be a subprogram", Arg2); + end if; + + -- For Stdcall, a subprogram, variable or subprogram type is required + + if C = Convention_Stdcall + and then not Is_Subprogram (E) + and then not Is_Generic_Subprogram (E) + and then Ekind (E) /= E_Variable + and then not + (Is_Access_Type (E) + and then Ekind (Designated_Type (E)) = E_Subprogram_Type) + then + Error_Pragma_Arg + ("second argument of pragma% must be subprogram (type)", + Arg2); + end if; + + if not Is_Subprogram (E) + and then not Is_Generic_Subprogram (E) + then + Set_Convention_From_Pragma (E); + + if Is_Type (E) then + Check_First_Subtype (Arg2); + Set_Convention_From_Pragma (Base_Type (E)); + + -- For subprograms, we must set the convention on the + -- internally generated directly designated type as well. + + if Ekind (E) = E_Access_Subprogram_Type then + Set_Convention_From_Pragma (Directly_Designated_Type (E)); + end if; + end if; + + -- For the subprogram case, set proper convention for all homonyms + -- in same scope and the same declarative part, i.e. the same + -- compilation unit. + + else + Comp_Unit := Get_Source_Unit (E); + Set_Convention_From_Pragma (E); + + -- Treat a pragma Import as an implicit body, for GPS use + + if Prag_Id = Pragma_Import then + Generate_Reference (E, Id, 'b'); + end if; + + -- Loop through the homonyms of the pragma argument's entity + + E1 := Ent; + loop + E1 := Homonym (E1); + exit when No (E1) or else Scope (E1) /= Current_Scope; + + -- Do not set the pragma on inherited operations or on formal + -- subprograms. + + if Comes_From_Source (E1) + and then Comp_Unit = Get_Source_Unit (E1) + and then not Is_Formal_Subprogram (E1) + and then Nkind (Original_Node (Parent (E1))) /= + N_Full_Type_Declaration + then + if Present (Alias (E1)) + and then Scope (E1) /= Scope (Alias (E1)) + then + Error_Pragma_Ref + ("cannot apply pragma% to non-local entity& declared#", + E1); + end if; + + Set_Convention_From_Pragma (E1); + + if Prag_Id = Pragma_Import then + Generate_Reference (E1, Id, 'b'); + end if; + end if; + + -- For aspect case, do NOT apply to homonyms + + exit when From_Aspect_Specification (N); + end loop; + end if; + end Process_Convention; + + ----------------------------------------------------- + -- Process_Extended_Import_Export_Exception_Pragma -- + ----------------------------------------------------- + + procedure Process_Extended_Import_Export_Exception_Pragma + (Arg_Internal : Node_Id; + Arg_External : Node_Id; + Arg_Form : Node_Id; + Arg_Code : Node_Id) + is + Def_Id : Entity_Id; + Code_Val : Uint; + + begin + if not OpenVMS_On_Target then + Error_Pragma + ("?pragma% ignored (applies only to Open'V'M'S)"); + end if; + + Process_Extended_Import_Export_Internal_Arg (Arg_Internal); + Def_Id := Entity (Arg_Internal); + + if Ekind (Def_Id) /= E_Exception then + Error_Pragma_Arg + ("pragma% must refer to declared exception", Arg_Internal); + end if; + + Set_Extended_Import_Export_External_Name (Def_Id, Arg_External); + + if Present (Arg_Form) then + Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS); + end if; + + if Present (Arg_Form) + and then Chars (Arg_Form) = Name_Ada + then + null; + else + Set_Is_VMS_Exception (Def_Id); + Set_Exception_Code (Def_Id, No_Uint); + end if; + + if Present (Arg_Code) then + if not Is_VMS_Exception (Def_Id) then + Error_Pragma_Arg + ("Code option for pragma% not allowed for Ada case", + Arg_Code); + end if; + + Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer); + Code_Val := Expr_Value (Arg_Code); + + if not UI_Is_In_Int_Range (Code_Val) then + Error_Pragma_Arg + ("Code option for pragma% must be in 32-bit range", + Arg_Code); + + else + Set_Exception_Code (Def_Id, Code_Val); + end if; + end if; + end Process_Extended_Import_Export_Exception_Pragma; + + ------------------------------------------------- + -- Process_Extended_Import_Export_Internal_Arg -- + ------------------------------------------------- + + procedure Process_Extended_Import_Export_Internal_Arg + (Arg_Internal : Node_Id := Empty) + is + begin + if No (Arg_Internal) then + Error_Pragma ("Internal parameter required for pragma%"); + end if; + + if Nkind (Arg_Internal) = N_Identifier then + null; + + elsif Nkind (Arg_Internal) = N_Operator_Symbol + and then (Prag_Id = Pragma_Import_Function + or else + Prag_Id = Pragma_Export_Function) + then + null; + + else + Error_Pragma_Arg + ("wrong form for Internal parameter for pragma%", Arg_Internal); + end if; + + Check_Arg_Is_Local_Name (Arg_Internal); + end Process_Extended_Import_Export_Internal_Arg; + + -------------------------------------------------- + -- Process_Extended_Import_Export_Object_Pragma -- + -------------------------------------------------- + + procedure Process_Extended_Import_Export_Object_Pragma + (Arg_Internal : Node_Id; + Arg_External : Node_Id; + Arg_Size : Node_Id) + is + Def_Id : Entity_Id; + + begin + Process_Extended_Import_Export_Internal_Arg (Arg_Internal); + Def_Id := Entity (Arg_Internal); + + if not Ekind_In (Def_Id, E_Constant, E_Variable) then + Error_Pragma_Arg + ("pragma% must designate an object", Arg_Internal); + end if; + + if Has_Rep_Pragma (Def_Id, Name_Common_Object) + or else + Has_Rep_Pragma (Def_Id, Name_Psect_Object) + then + Error_Pragma_Arg + ("previous Common/Psect_Object applies, pragma % not permitted", + Arg_Internal); + end if; + + if Rep_Item_Too_Late (Def_Id, N) then + raise Pragma_Exit; + end if; + + Set_Extended_Import_Export_External_Name (Def_Id, Arg_External); + + if Present (Arg_Size) then + Check_Arg_Is_External_Name (Arg_Size); + end if; + + -- Export_Object case + + if Prag_Id = Pragma_Export_Object then + if not Is_Library_Level_Entity (Def_Id) then + Error_Pragma_Arg + ("argument for pragma% must be library level entity", + Arg_Internal); + end if; + + if Ekind (Current_Scope) = E_Generic_Package then + Error_Pragma ("pragma& cannot appear in a generic unit"); + end if; + + if not Size_Known_At_Compile_Time (Etype (Def_Id)) then + Error_Pragma_Arg + ("exported object must have compile time known size", + Arg_Internal); + end if; + + if Warn_On_Export_Import and then Is_Exported (Def_Id) then + Error_Msg_N ("?duplicate Export_Object pragma", N); + else + Set_Exported (Def_Id, Arg_Internal); + end if; + + -- Import_Object case + + else + if Is_Concurrent_Type (Etype (Def_Id)) then + Error_Pragma_Arg + ("cannot use pragma% for task/protected object", + Arg_Internal); + end if; + + if Ekind (Def_Id) = E_Constant then + Error_Pragma_Arg + ("cannot import a constant", Arg_Internal); + end if; + + if Warn_On_Export_Import + and then Has_Discriminants (Etype (Def_Id)) + then + Error_Msg_N + ("imported value must be initialized?", Arg_Internal); + end if; + + if Warn_On_Export_Import + and then Is_Access_Type (Etype (Def_Id)) + then + Error_Pragma_Arg + ("cannot import object of an access type?", Arg_Internal); + end if; + + if Warn_On_Export_Import + and then Is_Imported (Def_Id) + then + Error_Msg_N + ("?duplicate Import_Object pragma", N); + + -- Check for explicit initialization present. Note that an + -- initialization generated by the code generator, e.g. for an + -- access type, does not count here. + + elsif Present (Expression (Parent (Def_Id))) + and then + Comes_From_Source + (Original_Node (Expression (Parent (Def_Id)))) + then + Error_Msg_Sloc := Sloc (Def_Id); + Error_Pragma_Arg + ("imported entities cannot be initialized (RM B.1(24))", + "\no initialization allowed for & declared#", Arg1); + else + Set_Imported (Def_Id); + Note_Possible_Modification (Arg_Internal, Sure => False); + end if; + end if; + end Process_Extended_Import_Export_Object_Pragma; + + ------------------------------------------------------ + -- Process_Extended_Import_Export_Subprogram_Pragma -- + ------------------------------------------------------ + + procedure Process_Extended_Import_Export_Subprogram_Pragma + (Arg_Internal : Node_Id; + Arg_External : Node_Id; + Arg_Parameter_Types : Node_Id; + Arg_Result_Type : Node_Id := Empty; + Arg_Mechanism : Node_Id; + Arg_Result_Mechanism : Node_Id := Empty; + Arg_First_Optional_Parameter : Node_Id := Empty) + is + Ent : Entity_Id; + Def_Id : Entity_Id; + Hom_Id : Entity_Id; + Formal : Entity_Id; + Ambiguous : Boolean; + Match : Boolean; + Dval : Node_Id; + + function Same_Base_Type + (Ptype : Node_Id; + Formal : Entity_Id) return Boolean; + -- Determines if Ptype references the type of Formal. Note that only + -- the base types need to match according to the spec. Ptype here is + -- the argument from the pragma, which is either a type name, or an + -- access attribute. + + -------------------- + -- Same_Base_Type -- + -------------------- + + function Same_Base_Type + (Ptype : Node_Id; + Formal : Entity_Id) return Boolean + is + Ftyp : constant Entity_Id := Base_Type (Etype (Formal)); + Pref : Node_Id; + + begin + -- Case where pragma argument is typ'Access + + if Nkind (Ptype) = N_Attribute_Reference + and then Attribute_Name (Ptype) = Name_Access + then + Pref := Prefix (Ptype); + Find_Type (Pref); + + if not Is_Entity_Name (Pref) + or else Entity (Pref) = Any_Type + then + raise Pragma_Exit; + end if; + + -- We have a match if the corresponding argument is of an + -- anonymous access type, and its designated type matches the + -- type of the prefix of the access attribute + + return Ekind (Ftyp) = E_Anonymous_Access_Type + and then Base_Type (Entity (Pref)) = + Base_Type (Etype (Designated_Type (Ftyp))); + + -- Case where pragma argument is a type name + + else + Find_Type (Ptype); + + if not Is_Entity_Name (Ptype) + or else Entity (Ptype) = Any_Type + then + raise Pragma_Exit; + end if; + + -- We have a match if the corresponding argument is of the type + -- given in the pragma (comparing base types) + + return Base_Type (Entity (Ptype)) = Ftyp; + end if; + end Same_Base_Type; + + -- Start of processing for + -- Process_Extended_Import_Export_Subprogram_Pragma + + begin + Process_Extended_Import_Export_Internal_Arg (Arg_Internal); + Ent := Empty; + Ambiguous := False; + + -- Loop through homonyms (overloadings) of the entity + + Hom_Id := Entity (Arg_Internal); + while Present (Hom_Id) loop + Def_Id := Get_Base_Subprogram (Hom_Id); + + -- We need a subprogram in the current scope + + if not Is_Subprogram (Def_Id) + or else Scope (Def_Id) /= Current_Scope + then + null; + + else + Match := True; + + -- Pragma cannot apply to subprogram body + + if Is_Subprogram (Def_Id) + and then Nkind (Parent (Declaration_Node (Def_Id))) = + N_Subprogram_Body + then + Error_Pragma + ("pragma% requires separate spec" + & " and must come before body"); + end if; + + -- Test result type if given, note that the result type + -- parameter can only be present for the function cases. + + if Present (Arg_Result_Type) + and then not Same_Base_Type (Arg_Result_Type, Def_Id) + then + Match := False; + + elsif Etype (Def_Id) /= Standard_Void_Type + and then + (Pname = Name_Export_Procedure + or else + Pname = Name_Import_Procedure) + then + Match := False; + + -- Test parameter types if given. Note that this parameter + -- has not been analyzed (and must not be, since it is + -- semantic nonsense), so we get it as the parser left it. + + elsif Present (Arg_Parameter_Types) then + Check_Matching_Types : declare + Formal : Entity_Id; + Ptype : Node_Id; + + begin + Formal := First_Formal (Def_Id); + + if Nkind (Arg_Parameter_Types) = N_Null then + if Present (Formal) then + Match := False; + end if; + + -- A list of one type, e.g. (List) is parsed as + -- a parenthesized expression. + + elsif Nkind (Arg_Parameter_Types) /= N_Aggregate + and then Paren_Count (Arg_Parameter_Types) = 1 + then + if No (Formal) + or else Present (Next_Formal (Formal)) + then + Match := False; + else + Match := + Same_Base_Type (Arg_Parameter_Types, Formal); + end if; + + -- A list of more than one type is parsed as a aggregate + + elsif Nkind (Arg_Parameter_Types) = N_Aggregate + and then Paren_Count (Arg_Parameter_Types) = 0 + then + Ptype := First (Expressions (Arg_Parameter_Types)); + while Present (Ptype) or else Present (Formal) loop + if No (Ptype) + or else No (Formal) + or else not Same_Base_Type (Ptype, Formal) + then + Match := False; + exit; + else + Next_Formal (Formal); + Next (Ptype); + end if; + end loop; + + -- Anything else is of the wrong form + + else + Error_Pragma_Arg + ("wrong form for Parameter_Types parameter", + Arg_Parameter_Types); + end if; + end Check_Matching_Types; + end if; + + -- Match is now False if the entry we found did not match + -- either a supplied Parameter_Types or Result_Types argument + + if Match then + if No (Ent) then + Ent := Def_Id; + + -- Ambiguous case, the flag Ambiguous shows if we already + -- detected this and output the initial messages. + + else + if not Ambiguous then + Ambiguous := True; + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("pragma% does not uniquely identify subprogram!", + N); + Error_Msg_Sloc := Sloc (Ent); + Error_Msg_N ("matching subprogram #!", N); + Ent := Empty; + end if; + + Error_Msg_Sloc := Sloc (Def_Id); + Error_Msg_N ("matching subprogram #!", N); + end if; + end if; + end if; + + Hom_Id := Homonym (Hom_Id); + end loop; + + -- See if we found an entry + + if No (Ent) then + if not Ambiguous then + if Is_Generic_Subprogram (Entity (Arg_Internal)) then + Error_Pragma + ("pragma% cannot be given for generic subprogram"); + else + Error_Pragma + ("pragma% does not identify local subprogram"); + end if; + end if; + + return; + end if; + + -- Import pragmas must be for imported entities + + if Prag_Id = Pragma_Import_Function + or else + Prag_Id = Pragma_Import_Procedure + or else + Prag_Id = Pragma_Import_Valued_Procedure + then + if not Is_Imported (Ent) then + Error_Pragma + ("pragma Import or Interface must precede pragma%"); + end if; + + -- Here we have the Export case which can set the entity as exported + + -- But does not do so if the specified external name is null, since + -- that is taken as a signal in DEC Ada 83 (with which we want to be + -- compatible) to request no external name. + + elsif Nkind (Arg_External) = N_String_Literal + and then String_Length (Strval (Arg_External)) = 0 + then + null; + + -- In all other cases, set entity as exported + + else + Set_Exported (Ent, Arg_Internal); + end if; + + -- Special processing for Valued_Procedure cases + + if Prag_Id = Pragma_Import_Valued_Procedure + or else + Prag_Id = Pragma_Export_Valued_Procedure + then + Formal := First_Formal (Ent); + + if No (Formal) then + Error_Pragma ("at least one parameter required for pragma%"); + + elsif Ekind (Formal) /= E_Out_Parameter then + Error_Pragma ("first parameter must have mode out for pragma%"); + + else + Set_Is_Valued_Procedure (Ent); + end if; + end if; + + Set_Extended_Import_Export_External_Name (Ent, Arg_External); + + -- Process Result_Mechanism argument if present. We have already + -- checked that this is only allowed for the function case. + + if Present (Arg_Result_Mechanism) then + Set_Mechanism_Value (Ent, Arg_Result_Mechanism); + end if; + + -- Process Mechanism parameter if present. Note that this parameter + -- is not analyzed, and must not be analyzed since it is semantic + -- nonsense, so we get it in exactly as the parser left it. + + if Present (Arg_Mechanism) then + declare + Formal : Entity_Id; + Massoc : Node_Id; + Mname : Node_Id; + Choice : Node_Id; + + begin + -- A single mechanism association without a formal parameter + -- name is parsed as a parenthesized expression. All other + -- cases are parsed as aggregates, so we rewrite the single + -- parameter case as an aggregate for consistency. + + if Nkind (Arg_Mechanism) /= N_Aggregate + and then Paren_Count (Arg_Mechanism) = 1 + then + Rewrite (Arg_Mechanism, + Make_Aggregate (Sloc (Arg_Mechanism), + Expressions => New_List ( + Relocate_Node (Arg_Mechanism)))); + end if; + + -- Case of only mechanism name given, applies to all formals + + if Nkind (Arg_Mechanism) /= N_Aggregate then + Formal := First_Formal (Ent); + while Present (Formal) loop + Set_Mechanism_Value (Formal, Arg_Mechanism); + Next_Formal (Formal); + end loop; + + -- Case of list of mechanism associations given + + else + if Null_Record_Present (Arg_Mechanism) then + Error_Pragma_Arg + ("inappropriate form for Mechanism parameter", + Arg_Mechanism); + end if; + + -- Deal with positional ones first + + Formal := First_Formal (Ent); + + if Present (Expressions (Arg_Mechanism)) then + Mname := First (Expressions (Arg_Mechanism)); + while Present (Mname) loop + if No (Formal) then + Error_Pragma_Arg + ("too many mechanism associations", Mname); + end if; + + Set_Mechanism_Value (Formal, Mname); + Next_Formal (Formal); + Next (Mname); + end loop; + end if; + + -- Deal with named entries + + if Present (Component_Associations (Arg_Mechanism)) then + Massoc := First (Component_Associations (Arg_Mechanism)); + while Present (Massoc) loop + Choice := First (Choices (Massoc)); + + if Nkind (Choice) /= N_Identifier + or else Present (Next (Choice)) + then + Error_Pragma_Arg + ("incorrect form for mechanism association", + Massoc); + end if; + + Formal := First_Formal (Ent); + loop + if No (Formal) then + Error_Pragma_Arg + ("parameter name & not present", Choice); + end if; + + if Chars (Choice) = Chars (Formal) then + Set_Mechanism_Value + (Formal, Expression (Massoc)); + + -- Set entity on identifier (needed by ASIS) + + Set_Entity (Choice, Formal); + + exit; + end if; + + Next_Formal (Formal); + end loop; + + Next (Massoc); + end loop; + end if; + end if; + end; + end if; + + -- Process First_Optional_Parameter argument if present. We have + -- already checked that this is only allowed for the Import case. + + if Present (Arg_First_Optional_Parameter) then + if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then + Error_Pragma_Arg + ("first optional parameter must be formal parameter name", + Arg_First_Optional_Parameter); + end if; + + Formal := First_Formal (Ent); + loop + if No (Formal) then + Error_Pragma_Arg + ("specified formal parameter& not found", + Arg_First_Optional_Parameter); + end if; + + exit when Chars (Formal) = + Chars (Arg_First_Optional_Parameter); + + Next_Formal (Formal); + end loop; + + Set_First_Optional_Parameter (Ent, Formal); + + -- Check specified and all remaining formals have right form + + while Present (Formal) loop + if Ekind (Formal) /= E_In_Parameter then + Error_Msg_NE + ("optional formal& is not of mode in!", + Arg_First_Optional_Parameter, Formal); + + else + Dval := Default_Value (Formal); + + if No (Dval) then + Error_Msg_NE + ("optional formal& does not have default value!", + Arg_First_Optional_Parameter, Formal); + + elsif Compile_Time_Known_Value_Or_Aggr (Dval) then + null; + + else + Error_Msg_FE + ("default value for optional formal& is non-static!", + Arg_First_Optional_Parameter, Formal); + end if; + end if; + + Set_Is_Optional_Parameter (Formal); + Next_Formal (Formal); + end loop; + end if; + end Process_Extended_Import_Export_Subprogram_Pragma; + + -------------------------- + -- Process_Generic_List -- + -------------------------- + + procedure Process_Generic_List is + Arg : Node_Id; + Exp : Node_Id; + + begin + Check_No_Identifiers; + Check_At_Least_N_Arguments (1); + + Arg := Arg1; + while Present (Arg) loop + Exp := Get_Pragma_Arg (Arg); + Analyze (Exp); + + if not Is_Entity_Name (Exp) + or else + (not Is_Generic_Instance (Entity (Exp)) + and then + not Is_Generic_Unit (Entity (Exp))) + then + Error_Pragma_Arg + ("pragma% argument must be name of generic unit/instance", + Arg); + end if; + + Next (Arg); + end loop; + end Process_Generic_List; + + --------------------------------- + -- Process_Import_Or_Interface -- + --------------------------------- + + procedure Process_Import_Or_Interface is + C : Convention_Id; + Def_Id : Entity_Id; + Hom_Id : Entity_Id; + + begin + Process_Convention (C, Def_Id); + Kill_Size_Check_Code (Def_Id); + Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False); + + if Ekind_In (Def_Id, E_Variable, E_Constant) then + + -- We do not permit Import to apply to a renaming declaration + + if Present (Renamed_Object (Def_Id)) then + Error_Pragma_Arg + ("pragma% not allowed for object renaming", Arg2); + + -- User initialization is not allowed for imported object, but + -- the object declaration may contain a default initialization, + -- that will be discarded. Note that an explicit initialization + -- only counts if it comes from source, otherwise it is simply + -- the code generator making an implicit initialization explicit. + + elsif Present (Expression (Parent (Def_Id))) + and then Comes_From_Source (Expression (Parent (Def_Id))) + then + Error_Msg_Sloc := Sloc (Def_Id); + Error_Pragma_Arg + ("no initialization allowed for declaration of& #", + "\imported entities cannot be initialized (RM B.1(24))", + Arg2); + + else + Set_Imported (Def_Id); + Process_Interface_Name (Def_Id, Arg3, Arg4); + + -- Note that we do not set Is_Public here. That's because we + -- only want to set it if there is no address clause, and we + -- don't know that yet, so we delay that processing till + -- freeze time. + + -- pragma Import completes deferred constants + + if Ekind (Def_Id) = E_Constant then + Set_Has_Completion (Def_Id); + end if; + + -- It is not possible to import a constant of an unconstrained + -- array type (e.g. string) because there is no simple way to + -- write a meaningful subtype for it. + + if Is_Array_Type (Etype (Def_Id)) + and then not Is_Constrained (Etype (Def_Id)) + then + Error_Msg_NE + ("imported constant& must have a constrained subtype", + N, Def_Id); + end if; + end if; + + elsif Is_Subprogram (Def_Id) + or else Is_Generic_Subprogram (Def_Id) + then + -- If the name is overloaded, pragma applies to all of the denoted + -- entities in the same declarative part. + + Hom_Id := Def_Id; + while Present (Hom_Id) loop + Def_Id := Get_Base_Subprogram (Hom_Id); + + -- Ignore inherited subprograms because the pragma will apply + -- to the parent operation, which is the one called. + + if Is_Overloadable (Def_Id) + and then Present (Alias (Def_Id)) + then + null; + + -- If it is not a subprogram, it must be in an outer scope and + -- pragma does not apply. + + elsif not Is_Subprogram (Def_Id) + and then not Is_Generic_Subprogram (Def_Id) + then + null; + + -- The pragma does not apply to primitives of interfaces + + elsif Is_Dispatching_Operation (Def_Id) + and then Present (Find_Dispatching_Type (Def_Id)) + and then Is_Interface (Find_Dispatching_Type (Def_Id)) + then + null; + + -- Verify that the homonym is in the same declarative part (not + -- just the same scope). + + elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N) + and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux + then + exit; + + else + Set_Imported (Def_Id); + + -- Reject an Import applied to an abstract subprogram + + if Is_Subprogram (Def_Id) + and then Is_Abstract_Subprogram (Def_Id) + then + Error_Msg_Sloc := Sloc (Def_Id); + Error_Msg_NE + ("cannot import abstract subprogram& declared#", + Arg2, Def_Id); + end if; + + -- Special processing for Convention_Intrinsic + + if C = Convention_Intrinsic then + + -- Link_Name argument not allowed for intrinsic + + if Present (Arg3) + and then Chars (Arg3) = Name_Link_Name + then + Arg4 := Arg3; + end if; + + if Present (Arg4) then + Error_Pragma_Arg + ("Link_Name argument not allowed for " & + "Import Intrinsic", + Arg4); + end if; + + Set_Is_Intrinsic_Subprogram (Def_Id); + + -- If no external name is present, then check that this + -- is a valid intrinsic subprogram. If an external name + -- is present, then this is handled by the back end. + + if No (Arg3) then + Check_Intrinsic_Subprogram + (Def_Id, Get_Pragma_Arg (Arg2)); + end if; + end if; + + -- All interfaced procedures need an external symbol created + -- for them since they are always referenced from another + -- object file. + + Set_Is_Public (Def_Id); + + -- Verify that the subprogram does not have a completion + -- through a renaming declaration. For other completions the + -- pragma appears as a too late representation. + + declare + Decl : constant Node_Id := Unit_Declaration_Node (Def_Id); + + begin + if Present (Decl) + and then Nkind (Decl) = N_Subprogram_Declaration + and then Present (Corresponding_Body (Decl)) + and then Nkind (Unit_Declaration_Node + (Corresponding_Body (Decl))) = + N_Subprogram_Renaming_Declaration + then + Error_Msg_Sloc := Sloc (Def_Id); + Error_Msg_NE + ("cannot import&, renaming already provided for " & + "declaration #", N, Def_Id); + end if; + end; + + Set_Has_Completion (Def_Id); + Process_Interface_Name (Def_Id, Arg3, Arg4); + end if; + + if Is_Compilation_Unit (Hom_Id) then + + -- Its possible homonyms are not affected by the pragma. + -- Such homonyms might be present in the context of other + -- units being compiled. + + exit; + + else + Hom_Id := Homonym (Hom_Id); + end if; + end loop; + + -- When the convention is Java or CIL, we also allow Import to be + -- given for packages, generic packages, exceptions, record + -- components, and access to subprograms. + + elsif (C = Convention_Java or else C = Convention_CIL) + and then + (Is_Package_Or_Generic_Package (Def_Id) + or else Ekind (Def_Id) = E_Exception + or else Ekind (Def_Id) = E_Access_Subprogram_Type + or else Nkind (Parent (Def_Id)) = N_Component_Declaration) + then + Set_Imported (Def_Id); + Set_Is_Public (Def_Id); + Process_Interface_Name (Def_Id, Arg3, Arg4); + + -- Import a CPP class + + elsif Is_Record_Type (Def_Id) + and then C = Convention_CPP + then + -- Types treated as CPP classes are treated as limited, but we + -- don't require them to be declared this way. A warning is issued + -- to encourage the user to declare them as limited. This is not + -- an error, for compatibility reasons, because these types have + -- been supported this way for some time. + + if not Is_Limited_Type (Def_Id) then + Error_Msg_N + ("imported 'C'P'P type should be " & + "explicitly declared limited?", + Get_Pragma_Arg (Arg2)); + Error_Msg_N + ("\type will be considered limited", + Get_Pragma_Arg (Arg2)); + end if; + + Set_Is_CPP_Class (Def_Id); + Set_Is_Limited_Record (Def_Id); + + -- Imported CPP types must not have discriminants (because C++ + -- classes do not have discriminants). + + if Has_Discriminants (Def_Id) then + Error_Msg_N + ("imported 'C'P'P type cannot have discriminants", + First (Discriminant_Specifications + (Declaration_Node (Def_Id)))); + end if; + + -- Components of imported CPP types must not have default + -- expressions because the constructor (if any) is on the + -- C++ side. + + declare + Tdef : constant Node_Id := + Type_Definition (Declaration_Node (Def_Id)); + Clist : Node_Id; + Comp : Node_Id; + + begin + if Nkind (Tdef) = N_Record_Definition then + Clist := Component_List (Tdef); + + else + pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition); + Clist := Component_List (Record_Extension_Part (Tdef)); + end if; + + if Present (Clist) then + Comp := First (Component_Items (Clist)); + while Present (Comp) loop + if Present (Expression (Comp)) then + Error_Msg_N + ("component of imported 'C'P'P type cannot have" & + " default expression", Expression (Comp)); + end if; + + Next (Comp); + end loop; + end if; + end; + + else + Error_Pragma_Arg + ("second argument of pragma% must be object or subprogram", + Arg2); + end if; + + -- If this pragma applies to a compilation unit, then the unit, which + -- is a subprogram, does not require (or allow) a body. We also do + -- not need to elaborate imported procedures. + + if Nkind (Parent (N)) = N_Compilation_Unit_Aux then + declare + Cunit : constant Node_Id := Parent (Parent (N)); + begin + Set_Body_Required (Cunit, False); + end; + end if; + end Process_Import_Or_Interface; + + -------------------- + -- Process_Inline -- + -------------------- + + procedure Process_Inline (Active : Boolean) is + Assoc : Node_Id; + Decl : Node_Id; + Subp_Id : Node_Id; + Subp : Entity_Id; + Applies : Boolean; + Effective : Boolean := False; + + procedure Make_Inline (Subp : Entity_Id); + -- Subp is the defining unit name of the subprogram declaration. Set + -- the flag, as well as the flag in the corresponding body, if there + -- is one present. + + procedure Set_Inline_Flags (Subp : Entity_Id); + -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also + -- Has_Pragma_Inline_Always for the Inline_Always case. + + function Inlining_Not_Possible (Subp : Entity_Id) return Boolean; + -- Returns True if it can be determined at this stage that inlining + -- is not possible, for example if the body is available and contains + -- exception handlers, we prevent inlining, since otherwise we can + -- get undefined symbols at link time. This function also emits a + -- warning if front-end inlining is enabled and the pragma appears + -- too late. + -- + -- ??? is business with link symbols still valid, or does it relate + -- to front end ZCX which is being phased out ??? + + --------------------------- + -- Inlining_Not_Possible -- + --------------------------- + + function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is + Decl : constant Node_Id := Unit_Declaration_Node (Subp); + Stats : Node_Id; + + begin + if Nkind (Decl) = N_Subprogram_Body then + Stats := Handled_Statement_Sequence (Decl); + return Present (Exception_Handlers (Stats)) + or else Present (At_End_Proc (Stats)); + + elsif Nkind (Decl) = N_Subprogram_Declaration + and then Present (Corresponding_Body (Decl)) + then + if Front_End_Inlining + and then Analyzed (Corresponding_Body (Decl)) + then + Error_Msg_N ("pragma appears too late, ignored?", N); + return True; + + -- If the subprogram is a renaming as body, the body is just a + -- call to the renamed subprogram, and inlining is trivially + -- possible. + + elsif + Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) = + N_Subprogram_Renaming_Declaration + then + return False; + + else + Stats := + Handled_Statement_Sequence + (Unit_Declaration_Node (Corresponding_Body (Decl))); + + return + Present (Exception_Handlers (Stats)) + or else Present (At_End_Proc (Stats)); + end if; + + else + -- If body is not available, assume the best, the check is + -- performed again when compiling enclosing package bodies. + + return False; + end if; + end Inlining_Not_Possible; + + ----------------- + -- Make_Inline -- + ----------------- + + procedure Make_Inline (Subp : Entity_Id) is + Kind : constant Entity_Kind := Ekind (Subp); + Inner_Subp : Entity_Id := Subp; + + begin + -- Ignore if bad type, avoid cascaded error + + if Etype (Subp) = Any_Type then + Applies := True; + return; + + -- Ignore if all inlining is suppressed + + elsif Suppress_All_Inlining then + Applies := True; + return; + + -- If inlining is not possible, for now do not treat as an error + + elsif Inlining_Not_Possible (Subp) then + Applies := True; + return; + + -- Here we have a candidate for inlining, but we must exclude + -- derived operations. Otherwise we would end up trying to inline + -- a phantom declaration, and the result would be to drag in a + -- body which has no direct inlining associated with it. That + -- would not only be inefficient but would also result in the + -- backend doing cross-unit inlining in cases where it was + -- definitely inappropriate to do so. + + -- However, a simple Comes_From_Source test is insufficient, since + -- we do want to allow inlining of generic instances which also do + -- not come from source. We also need to recognize specs generated + -- by the front-end for bodies that carry the pragma. Finally, + -- predefined operators do not come from source but are not + -- inlineable either. + + elsif Is_Generic_Instance (Subp) + or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration + then + null; + + elsif not Comes_From_Source (Subp) + and then Scope (Subp) /= Standard_Standard + then + Applies := True; + return; + end if; + + -- The referenced entity must either be the enclosing entity, or + -- an entity declared within the current open scope. + + if Present (Scope (Subp)) + and then Scope (Subp) /= Current_Scope + and then Subp /= Current_Scope + then + Error_Pragma_Arg + ("argument of% must be entity in current scope", Assoc); + return; + end if; + + -- Processing for procedure, operator or function. If subprogram + -- is aliased (as for an instance) indicate that the renamed + -- entity (if declared in the same unit) is inlined. + + if Is_Subprogram (Subp) then + + if not Sense then + return; + end if; + + Inner_Subp := Ultimate_Alias (Inner_Subp); + + if In_Same_Source_Unit (Subp, Inner_Subp) then + Set_Inline_Flags (Inner_Subp); + + Decl := Parent (Parent (Inner_Subp)); + + if Nkind (Decl) = N_Subprogram_Declaration + and then Present (Corresponding_Body (Decl)) + then + Set_Inline_Flags (Corresponding_Body (Decl)); + + elsif Is_Generic_Instance (Subp) then + + -- Indicate that the body needs to be created for + -- inlining subsequent calls. The instantiation node + -- follows the declaration of the wrapper package + -- created for it. + + if Scope (Subp) /= Standard_Standard + and then + Need_Subprogram_Instance_Body + (Next (Unit_Declaration_Node (Scope (Alias (Subp)))), + Subp) + then + null; + end if; + end if; + end if; + + Applies := True; + + -- For a generic subprogram set flag as well, for use at the point + -- of instantiation, to determine whether the body should be + -- generated. + + elsif Is_Generic_Subprogram (Subp) then + Set_Inline_Flags (Subp); + Applies := True; + + -- Literals are by definition inlined + + elsif Kind = E_Enumeration_Literal then + null; + + -- Anything else is an error + + else + Error_Pragma_Arg + ("expect subprogram name for pragma%", Assoc); + end if; + end Make_Inline; + + ---------------------- + -- Set_Inline_Flags -- + ---------------------- + + procedure Set_Inline_Flags (Subp : Entity_Id) is + begin + if Active then + Set_Is_Inlined (Subp, Sense); + end if; + + if not Has_Pragma_Inline (Subp) then + Set_Has_Pragma_Inline (Subp, Sense); + Effective := True; + end if; + + if Prag_Id = Pragma_Inline_Always then + Set_Has_Pragma_Inline_Always (Subp, Sense); + end if; + end Set_Inline_Flags; + + -- Start of processing for Process_Inline + + begin + Check_No_Identifiers; + Check_At_Least_N_Arguments (1); + + if Active then + Inline_Processing_Required := True; + end if; + + Assoc := Arg1; + while Present (Assoc) loop + Subp_Id := Get_Pragma_Arg (Assoc); + Analyze (Subp_Id); + Applies := False; + + if Is_Entity_Name (Subp_Id) then + Subp := Entity (Subp_Id); + + if Subp = Any_Id then + + -- If previous error, avoid cascaded errors + + Applies := True; + Effective := True; + + else + Make_Inline (Subp); + + if not From_Aspect_Specification (N) then + while Present (Homonym (Subp)) + and then Scope (Homonym (Subp)) = Current_Scope + loop + Make_Inline (Homonym (Subp)); + Subp := Homonym (Subp); + end loop; + end if; + end if; + end if; + + if not Applies then + Error_Pragma_Arg + ("inappropriate argument for pragma%", Assoc); + + elsif not Effective + and then Warn_On_Redundant_Constructs + and then not Suppress_All_Inlining + then + if Inlining_Not_Possible (Subp) then + Error_Msg_NE + ("pragma Inline for& is ignored?", N, Entity (Subp_Id)); + else + Error_Msg_NE + ("pragma Inline for& is redundant?", N, Entity (Subp_Id)); + end if; + end if; + + Next (Assoc); + end loop; + end Process_Inline; + + ---------------------------- + -- Process_Interface_Name -- + ---------------------------- + + procedure Process_Interface_Name + (Subprogram_Def : Entity_Id; + Ext_Arg : Node_Id; + Link_Arg : Node_Id) + is + Ext_Nam : Node_Id; + Link_Nam : Node_Id; + String_Val : String_Id; + + procedure Check_Form_Of_Interface_Name + (SN : Node_Id; + Ext_Name_Case : Boolean); + -- SN is a string literal node for an interface name. This routine + -- performs some minimal checks that the name is reasonable. In + -- particular that no spaces or other obviously incorrect characters + -- appear. This is only a warning, since any characters are allowed. + -- Ext_Name_Case is True for an External_Name, False for a Link_Name. + + ---------------------------------- + -- Check_Form_Of_Interface_Name -- + ---------------------------------- + + procedure Check_Form_Of_Interface_Name + (SN : Node_Id; + Ext_Name_Case : Boolean) + is + S : constant String_Id := Strval (Expr_Value_S (SN)); + SL : constant Nat := String_Length (S); + C : Char_Code; + + begin + if SL = 0 then + Error_Msg_N ("interface name cannot be null string", SN); + end if; + + for J in 1 .. SL loop + C := Get_String_Char (S, J); + + -- Look for dubious character and issue unconditional warning. + -- Definitely dubious if not in character range. + + if not In_Character_Range (C) + + -- For all cases except CLI target, + -- commas, spaces and slashes are dubious (in CLI, we use + -- commas and backslashes in external names to specify + -- assembly version and public key, while slashes and spaces + -- can be used in names to mark nested classes and + -- valuetypes). + + or else ((not Ext_Name_Case or else VM_Target /= CLI_Target) + and then (Get_Character (C) = ',' + or else + Get_Character (C) = '\')) + or else (VM_Target /= CLI_Target + and then (Get_Character (C) = ' ' + or else + Get_Character (C) = '/')) + then + Error_Msg + ("?interface name contains illegal character", + Sloc (SN) + Source_Ptr (J)); + end if; + end loop; + end Check_Form_Of_Interface_Name; + + -- Start of processing for Process_Interface_Name + + begin + if No (Link_Arg) then + if No (Ext_Arg) then + if VM_Target = CLI_Target + and then Ekind (Subprogram_Def) = E_Package + and then Nkind (Parent (Subprogram_Def)) = + N_Package_Specification + and then Present (Generic_Parent (Parent (Subprogram_Def))) + then + Set_Interface_Name + (Subprogram_Def, + Interface_Name + (Generic_Parent (Parent (Subprogram_Def)))); + end if; + + return; + + elsif Chars (Ext_Arg) = Name_Link_Name then + Ext_Nam := Empty; + Link_Nam := Expression (Ext_Arg); + + else + Check_Optional_Identifier (Ext_Arg, Name_External_Name); + Ext_Nam := Expression (Ext_Arg); + Link_Nam := Empty; + end if; + + else + Check_Optional_Identifier (Ext_Arg, Name_External_Name); + Check_Optional_Identifier (Link_Arg, Name_Link_Name); + Ext_Nam := Expression (Ext_Arg); + Link_Nam := Expression (Link_Arg); + end if; + + -- Check expressions for external name and link name are static + + if Present (Ext_Nam) then + Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String); + Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True); + + -- Verify that external name is not the name of a local entity, + -- which would hide the imported one and could lead to run-time + -- surprises. The problem can only arise for entities declared in + -- a package body (otherwise the external name is fully qualified + -- and will not conflict). + + declare + Nam : Name_Id; + E : Entity_Id; + Par : Node_Id; + + begin + if Prag_Id = Pragma_Import then + String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam))); + Nam := Name_Find; + E := Entity_Id (Get_Name_Table_Info (Nam)); + + if Nam /= Chars (Subprogram_Def) + and then Present (E) + and then not Is_Overloadable (E) + and then Is_Immediately_Visible (E) + and then not Is_Imported (E) + and then Ekind (Scope (E)) = E_Package + then + Par := Parent (E); + while Present (Par) loop + if Nkind (Par) = N_Package_Body then + Error_Msg_Sloc := Sloc (E); + Error_Msg_NE + ("imported entity is hidden by & declared#", + Ext_Arg, E); + exit; + end if; + + Par := Parent (Par); + end loop; + end if; + end if; + end; + end if; + + if Present (Link_Nam) then + Check_Arg_Is_Static_Expression (Link_Nam, Standard_String); + Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False); + end if; + + -- If there is no link name, just set the external name + + if No (Link_Nam) then + Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam)); + + -- For the Link_Name case, the given literal is preceded by an + -- asterisk, which indicates to GCC that the given name should be + -- taken literally, and in particular that no prepending of + -- underlines should occur, even in systems where this is the + -- normal default. + + else + Start_String; + + if VM_Target = No_VM then + Store_String_Char (Get_Char_Code ('*')); + end if; + + String_Val := Strval (Expr_Value_S (Link_Nam)); + Store_String_Chars (String_Val); + Link_Nam := + Make_String_Literal (Sloc (Link_Nam), + Strval => End_String); + end if; + + Set_Encoded_Interface_Name + (Get_Base_Subprogram (Subprogram_Def), Link_Nam); + + -- We allow duplicated export names in CIL, as they are always + -- enclosed in a namespace that differentiates them, and overloaded + -- entities are supported by the VM. + + if Convention (Subprogram_Def) /= Convention_CIL then + Check_Duplicated_Export_Name (Link_Nam); + end if; + end Process_Interface_Name; + + ----------------------------------------- + -- Process_Interrupt_Or_Attach_Handler -- + ----------------------------------------- + + procedure Process_Interrupt_Or_Attach_Handler is + Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1); + Handler_Proc : constant Entity_Id := Entity (Arg1_X); + Proc_Scope : constant Entity_Id := Scope (Handler_Proc); + + begin + Set_Is_Interrupt_Handler (Handler_Proc); + + -- If the pragma is not associated with a handler procedure within a + -- protected type, then it must be for a nonprotected procedure for + -- the AAMP target, in which case we don't associate a representation + -- item with the procedure's scope. + + if Ekind (Proc_Scope) = E_Protected_Type then + if Prag_Id = Pragma_Interrupt_Handler + or else + Prag_Id = Pragma_Attach_Handler + then + Record_Rep_Item (Proc_Scope, N); + end if; + end if; + end Process_Interrupt_Or_Attach_Handler; + + -------------------------------------------------- + -- Process_Restrictions_Or_Restriction_Warnings -- + -------------------------------------------------- + + -- Note: some of the simple identifier cases were handled in par-prag, + -- but it is harmless (and more straightforward) to simply handle all + -- cases here, even if it means we repeat a bit of work in some cases. + + procedure Process_Restrictions_Or_Restriction_Warnings + (Warn : Boolean) + is + Arg : Node_Id; + R_Id : Restriction_Id; + Id : Name_Id; + Expr : Node_Id; + Val : Uint; + + procedure Check_Unit_Name (N : Node_Id); + -- Checks unit name parameter for No_Dependence. Returns if it has + -- an appropriate form, otherwise raises pragma argument error. + + --------------------- + -- Check_Unit_Name -- + --------------------- + + procedure Check_Unit_Name (N : Node_Id) is + begin + if Nkind (N) = N_Selected_Component then + Check_Unit_Name (Prefix (N)); + Check_Unit_Name (Selector_Name (N)); + + elsif Nkind (N) = N_Identifier then + return; + + else + Error_Pragma_Arg + ("wrong form for unit name for No_Dependence", N); + end if; + end Check_Unit_Name; + + -- Start of processing for Process_Restrictions_Or_Restriction_Warnings + + begin + -- Ignore all Restrictions pragma in CodePeer mode + + if CodePeer_Mode then + return; + end if; + + Check_Ada_83_Warning; + Check_At_Least_N_Arguments (1); + Check_Valid_Configuration_Pragma; + + Arg := Arg1; + while Present (Arg) loop + Id := Chars (Arg); + Expr := Get_Pragma_Arg (Arg); + + -- Case of no restriction identifier present + + if Id = No_Name then + if Nkind (Expr) /= N_Identifier then + Error_Pragma_Arg + ("invalid form for restriction", Arg); + end if; + + R_Id := + Get_Restriction_Id + (Process_Restriction_Synonyms (Expr)); + + if R_Id not in All_Boolean_Restrictions then + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("invalid restriction identifier&", Get_Pragma_Arg (Arg)); + + -- Check for possible misspelling + + for J in Restriction_Id loop + declare + Rnm : constant String := Restriction_Id'Image (J); + + begin + Name_Buffer (1 .. Rnm'Length) := Rnm; + Name_Len := Rnm'Length; + Set_Casing (All_Lower_Case); + + if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then + Set_Casing + (Identifier_Casing (Current_Source_File)); + Error_Msg_String (1 .. Rnm'Length) := + Name_Buffer (1 .. Name_Len); + Error_Msg_Strlen := Rnm'Length; + Error_Msg_N -- CODEFIX + ("\possible misspelling of ""~""", + Get_Pragma_Arg (Arg)); + exit; + end if; + end; + end loop; + + raise Pragma_Exit; + end if; + + if Implementation_Restriction (R_Id) then + Check_Restriction (No_Implementation_Restrictions, Arg); + end if; + + -- If this is a warning, then set the warning unless we already + -- have a real restriction active (we never want a warning to + -- override a real restriction). + + if Warn then + if not Restriction_Active (R_Id) then + Set_Restriction (R_Id, N); + Restriction_Warnings (R_Id) := True; + end if; + + -- If real restriction case, then set it and make sure that the + -- restriction warning flag is off, since a real restriction + -- always overrides a warning. + + else + Set_Restriction (R_Id, N); + Restriction_Warnings (R_Id) := False; + end if; + + -- Check for obsolescent restrictions in Ada 2005 mode + + if not Warn + and then Ada_Version >= Ada_2005 + and then (R_Id = No_Asynchronous_Control + or else + R_Id = No_Unchecked_Deallocation + or else + R_Id = No_Unchecked_Conversion) + then + Check_Restriction (No_Obsolescent_Features, N); + end if; + + -- A very special case that must be processed here: pragma + -- Restrictions (No_Exceptions) turns off all run-time + -- checking. This is a bit dubious in terms of the formal + -- language definition, but it is what is intended by RM + -- H.4(12). Restriction_Warnings never affects generated code + -- so this is done only in the real restriction case. + + if R_Id = No_Exceptions and then not Warn then + Scope_Suppress := (others => True); + end if; + + -- Case of No_Dependence => unit-name. Note that the parser + -- already made the necessary entry in the No_Dependence table. + + elsif Id = Name_No_Dependence then + Check_Unit_Name (Expr); + + -- All other cases of restriction identifier present + + else + R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg)); + Analyze_And_Resolve (Expr, Any_Integer); + + if R_Id not in All_Parameter_Restrictions then + Error_Pragma_Arg + ("invalid restriction parameter identifier", Arg); + + elsif not Is_OK_Static_Expression (Expr) then + Flag_Non_Static_Expr + ("value must be static expression!", Expr); + raise Pragma_Exit; + + elsif not Is_Integer_Type (Etype (Expr)) + or else Expr_Value (Expr) < 0 + then + Error_Pragma_Arg + ("value must be non-negative integer", Arg); + end if; + + -- Restriction pragma is active + + Val := Expr_Value (Expr); + + if not UI_Is_In_Int_Range (Val) then + Error_Pragma_Arg + ("pragma ignored, value too large?", Arg); + end if; + + -- Warning case. If the real restriction is active, then we + -- ignore the request, since warning never overrides a real + -- restriction. Otherwise we set the proper warning. Note that + -- this circuit sets the warning again if it is already set, + -- which is what we want, since the constant may have changed. + + if Warn then + if not Restriction_Active (R_Id) then + Set_Restriction + (R_Id, N, Integer (UI_To_Int (Val))); + Restriction_Warnings (R_Id) := True; + end if; + + -- Real restriction case, set restriction and make sure warning + -- flag is off since real restriction always overrides warning. + + else + Set_Restriction (R_Id, N, Integer (UI_To_Int (Val))); + Restriction_Warnings (R_Id) := False; + end if; + end if; + + Next (Arg); + end loop; + end Process_Restrictions_Or_Restriction_Warnings; + + --------------------------------- + -- Process_Suppress_Unsuppress -- + --------------------------------- + + -- Note: this procedure makes entries in the check suppress data + -- structures managed by Sem. See spec of package Sem for full + -- details on how we handle recording of check suppression. + + procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is + C : Check_Id; + E_Id : Node_Id; + E : Entity_Id; + + In_Package_Spec : constant Boolean := + Is_Package_Or_Generic_Package (Current_Scope) + and then not In_Package_Body (Current_Scope); + + procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id); + -- Used to suppress a single check on the given entity + + -------------------------------- + -- Suppress_Unsuppress_Echeck -- + -------------------------------- + + procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is + begin + Set_Checks_May_Be_Suppressed (E); + + if In_Package_Spec then + Push_Global_Suppress_Stack_Entry + (Entity => E, + Check => C, + Suppress => Suppress_Case); + + else + Push_Local_Suppress_Stack_Entry + (Entity => E, + Check => C, + Suppress => Suppress_Case); + end if; + + -- If this is a first subtype, and the base type is distinct, + -- then also set the suppress flags on the base type. + + if Is_First_Subtype (E) + and then Etype (E) /= E + then + Suppress_Unsuppress_Echeck (Etype (E), C); + end if; + end Suppress_Unsuppress_Echeck; + + -- Start of processing for Process_Suppress_Unsuppress + + begin + -- Ignore pragma Suppress/Unsuppress in codepeer mode on user code: + -- we want to generate checks for analysis purposes, as set by -gnatC + + if CodePeer_Mode and then Comes_From_Source (N) then + return; + end if; + + -- Suppress/Unsuppress can appear as a configuration pragma, or in a + -- declarative part or a package spec (RM 11.5(5)). + + if not Is_Configuration_Pragma then + Check_Is_In_Decl_Part_Or_Package_Spec; + end if; + + Check_At_Least_N_Arguments (1); + Check_At_Most_N_Arguments (2); + Check_No_Identifier (Arg1); + Check_Arg_Is_Identifier (Arg1); + + C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1))); + + if C = No_Check_Id then + Error_Pragma_Arg + ("argument of pragma% is not valid check name", Arg1); + end if; + + if not Suppress_Case + and then (C = All_Checks or else C = Overflow_Check) + then + Opt.Overflow_Checks_Unsuppressed := True; + end if; + + if Arg_Count = 1 then + + -- Make an entry in the local scope suppress table. This is the + -- table that directly shows the current value of the scope + -- suppress check for any check id value. + + if C = All_Checks then + + -- For All_Checks, we set all specific predefined checks with + -- the exception of Elaboration_Check, which is handled + -- specially because of not wanting All_Checks to have the + -- effect of deactivating static elaboration order processing. + + for J in Scope_Suppress'Range loop + if J /= Elaboration_Check then + Scope_Suppress (J) := Suppress_Case; + end if; + end loop; + + -- If not All_Checks, and predefined check, then set appropriate + -- scope entry. Note that we will set Elaboration_Check if this + -- is explicitly specified. + + elsif C in Predefined_Check_Id then + Scope_Suppress (C) := Suppress_Case; + end if; + + -- Also make an entry in the Local_Entity_Suppress table + + Push_Local_Suppress_Stack_Entry + (Entity => Empty, + Check => C, + Suppress => Suppress_Case); + + -- Case of two arguments present, where the check is suppressed for + -- a specified entity (given as the second argument of the pragma) + + else + -- This is obsolescent in Ada 2005 mode + + if Ada_Version >= Ada_2005 then + Check_Restriction (No_Obsolescent_Features, Arg2); + end if; + + Check_Optional_Identifier (Arg2, Name_On); + E_Id := Get_Pragma_Arg (Arg2); + Analyze (E_Id); + + if not Is_Entity_Name (E_Id) then + Error_Pragma_Arg + ("second argument of pragma% must be entity name", Arg2); + end if; + + E := Entity (E_Id); + + if E = Any_Id then + return; + end if; + + -- Enforce RM 11.5(7) which requires that for a pragma that + -- appears within a package spec, the named entity must be + -- within the package spec. We allow the package name itself + -- to be mentioned since that makes sense, although it is not + -- strictly allowed by 11.5(7). + + if In_Package_Spec + and then E /= Current_Scope + and then Scope (E) /= Current_Scope + then + Error_Pragma_Arg + ("entity in pragma% is not in package spec (RM 11.5(7))", + Arg2); + end if; + + -- Loop through homonyms. As noted below, in the case of a package + -- spec, only homonyms within the package spec are considered. + + loop + Suppress_Unsuppress_Echeck (E, C); + + if Is_Generic_Instance (E) + and then Is_Subprogram (E) + and then Present (Alias (E)) + then + Suppress_Unsuppress_Echeck (Alias (E), C); + end if; + + -- Move to next homonym if not aspect spec case + + exit when From_Aspect_Specification (N); + E := Homonym (E); + exit when No (E); + + -- If we are within a package specification, the pragma only + -- applies to homonyms in the same scope. + + exit when In_Package_Spec + and then Scope (E) /= Current_Scope; + end loop; + end if; + end Process_Suppress_Unsuppress; + + ------------------ + -- Set_Exported -- + ------------------ + + procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is + begin + if Is_Imported (E) then + Error_Pragma_Arg + ("cannot export entity& that was previously imported", Arg); + + elsif Present (Address_Clause (E)) and then not CodePeer_Mode then + Error_Pragma_Arg + ("cannot export entity& that has an address clause", Arg); + end if; + + Set_Is_Exported (E); + + -- Generate a reference for entity explicitly, because the + -- identifier may be overloaded and name resolution will not + -- generate one. + + Generate_Reference (E, Arg); + + -- Deal with exporting non-library level entity + + if not Is_Library_Level_Entity (E) then + + -- Not allowed at all for subprograms + + if Is_Subprogram (E) then + Error_Pragma_Arg ("local subprogram& cannot be exported", Arg); + + -- Otherwise set public and statically allocated + + else + Set_Is_Public (E); + Set_Is_Statically_Allocated (E); + + -- Warn if the corresponding W flag is set and the pragma comes + -- from source. The latter may not be true e.g. on VMS where we + -- expand export pragmas for exception codes associated with + -- imported or exported exceptions. We do not want to generate + -- a warning for something that the user did not write. + + if Warn_On_Export_Import + and then Comes_From_Source (Arg) + then + Error_Msg_NE + ("?& has been made static as a result of Export", Arg, E); + Error_Msg_N + ("\this usage is non-standard and non-portable", Arg); + end if; + end if; + end if; + + if Warn_On_Export_Import and then Is_Type (E) then + Error_Msg_NE ("exporting a type has no effect?", Arg, E); + end if; + + if Warn_On_Export_Import and Inside_A_Generic then + Error_Msg_NE + ("all instances of& will have the same external name?", Arg, E); + end if; + end Set_Exported; + + ---------------------------------------------- + -- Set_Extended_Import_Export_External_Name -- + ---------------------------------------------- + + procedure Set_Extended_Import_Export_External_Name + (Internal_Ent : Entity_Id; + Arg_External : Node_Id) + is + Old_Name : constant Node_Id := Interface_Name (Internal_Ent); + New_Name : Node_Id; + + begin + if No (Arg_External) then + return; + end if; + + Check_Arg_Is_External_Name (Arg_External); + + if Nkind (Arg_External) = N_String_Literal then + if String_Length (Strval (Arg_External)) = 0 then + return; + else + New_Name := Adjust_External_Name_Case (Arg_External); + end if; + + elsif Nkind (Arg_External) = N_Identifier then + New_Name := Get_Default_External_Name (Arg_External); + + -- Check_Arg_Is_External_Name should let through only identifiers and + -- string literals or static string expressions (which are folded to + -- string literals). + + else + raise Program_Error; + end if; + + -- If we already have an external name set (by a prior normal Import + -- or Export pragma), then the external names must match + + if Present (Interface_Name (Internal_Ent)) then + Check_Matching_Internal_Names : declare + S1 : constant String_Id := Strval (Old_Name); + S2 : constant String_Id := Strval (New_Name); + + procedure Mismatch; + -- Called if names do not match + + -------------- + -- Mismatch -- + -------------- + + procedure Mismatch is + begin + Error_Msg_Sloc := Sloc (Old_Name); + Error_Pragma_Arg + ("external name does not match that given #", + Arg_External); + end Mismatch; + + -- Start of processing for Check_Matching_Internal_Names + + begin + if String_Length (S1) /= String_Length (S2) then + Mismatch; + + else + for J in 1 .. String_Length (S1) loop + if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then + Mismatch; + end if; + end loop; + end if; + end Check_Matching_Internal_Names; + + -- Otherwise set the given name + + else + Set_Encoded_Interface_Name (Internal_Ent, New_Name); + Check_Duplicated_Export_Name (New_Name); + end if; + end Set_Extended_Import_Export_External_Name; + + ------------------ + -- Set_Imported -- + ------------------ + + procedure Set_Imported (E : Entity_Id) is + begin + -- Error message if already imported or exported + + if Is_Exported (E) or else Is_Imported (E) then + + -- Error if being set Exported twice + + if Is_Exported (E) then + Error_Msg_NE ("entity& was previously exported", N, E); + + -- OK if Import/Interface case + + elsif Import_Interface_Present (N) then + goto OK; + + -- Error if being set Imported twice + + else + Error_Msg_NE ("entity& was previously imported", N, E); + end if; + + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("\(pragma% applies to all previous entities)", N); + + Error_Msg_Sloc := Sloc (E); + Error_Msg_NE ("\import not allowed for& declared#", N, E); + + -- Here if not previously imported or exported, OK to import + + else + Set_Is_Imported (E); + + -- If the entity is an object that is not at the library level, + -- then it is statically allocated. We do not worry about objects + -- with address clauses in this context since they are not really + -- imported in the linker sense. + + if Is_Object (E) + and then not Is_Library_Level_Entity (E) + and then No (Address_Clause (E)) + then + Set_Is_Statically_Allocated (E); + end if; + end if; + + <> null; + end Set_Imported; + + ------------------------- + -- Set_Mechanism_Value -- + ------------------------- + + -- Note: the mechanism name has not been analyzed (and cannot indeed be + -- analyzed, since it is semantic nonsense), so we get it in the exact + -- form created by the parser. + + procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is + Class : Node_Id; + Param : Node_Id; + Mech_Name_Id : Name_Id; + + procedure Bad_Class; + -- Signal bad descriptor class name + + procedure Bad_Mechanism; + -- Signal bad mechanism name + + --------------- + -- Bad_Class -- + --------------- + + procedure Bad_Class is + begin + Error_Pragma_Arg ("unrecognized descriptor class name", Class); + end Bad_Class; + + ------------------------- + -- Bad_Mechanism_Value -- + ------------------------- + + procedure Bad_Mechanism is + begin + Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name); + end Bad_Mechanism; + + -- Start of processing for Set_Mechanism_Value + + begin + if Mechanism (Ent) /= Default_Mechanism then + Error_Msg_NE + ("mechanism for & has already been set", Mech_Name, Ent); + end if; + + -- MECHANISM_NAME ::= value | reference | descriptor | + -- short_descriptor + + if Nkind (Mech_Name) = N_Identifier then + if Chars (Mech_Name) = Name_Value then + Set_Mechanism (Ent, By_Copy); + return; + + elsif Chars (Mech_Name) = Name_Reference then + Set_Mechanism (Ent, By_Reference); + return; + + elsif Chars (Mech_Name) = Name_Descriptor then + Check_VMS (Mech_Name); + + -- Descriptor => Short_Descriptor if pragma was given + + if Short_Descriptors then + Set_Mechanism (Ent, By_Short_Descriptor); + else + Set_Mechanism (Ent, By_Descriptor); + end if; + + return; + + elsif Chars (Mech_Name) = Name_Short_Descriptor then + Check_VMS (Mech_Name); + Set_Mechanism (Ent, By_Short_Descriptor); + return; + + elsif Chars (Mech_Name) = Name_Copy then + Error_Pragma_Arg + ("bad mechanism name, Value assumed", Mech_Name); + + else + Bad_Mechanism; + end if; + + -- MECHANISM_NAME ::= descriptor (CLASS_NAME) | + -- short_descriptor (CLASS_NAME) + -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca + + -- Note: this form is parsed as an indexed component + + elsif Nkind (Mech_Name) = N_Indexed_Component then + Class := First (Expressions (Mech_Name)); + + if Nkind (Prefix (Mech_Name)) /= N_Identifier + or else not (Chars (Prefix (Mech_Name)) = Name_Descriptor or else + Chars (Prefix (Mech_Name)) = Name_Short_Descriptor) + or else Present (Next (Class)) + then + Bad_Mechanism; + else + Mech_Name_Id := Chars (Prefix (Mech_Name)); + + -- Change Descriptor => Short_Descriptor if pragma was given + + if Mech_Name_Id = Name_Descriptor + and then Short_Descriptors + then + Mech_Name_Id := Name_Short_Descriptor; + end if; + end if; + + -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) | + -- short_descriptor (Class => CLASS_NAME) + -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca + + -- Note: this form is parsed as a function call + + elsif Nkind (Mech_Name) = N_Function_Call then + Param := First (Parameter_Associations (Mech_Name)); + + if Nkind (Name (Mech_Name)) /= N_Identifier + or else not (Chars (Name (Mech_Name)) = Name_Descriptor or else + Chars (Name (Mech_Name)) = Name_Short_Descriptor) + or else Present (Next (Param)) + or else No (Selector_Name (Param)) + or else Chars (Selector_Name (Param)) /= Name_Class + then + Bad_Mechanism; + else + Class := Explicit_Actual_Parameter (Param); + Mech_Name_Id := Chars (Name (Mech_Name)); + end if; + + else + Bad_Mechanism; + end if; + + -- Fall through here with Class set to descriptor class name + + Check_VMS (Mech_Name); + + if Nkind (Class) /= N_Identifier then + Bad_Class; + + elsif Mech_Name_Id = Name_Descriptor + and then Chars (Class) = Name_UBS + then + Set_Mechanism (Ent, By_Descriptor_UBS); + + elsif Mech_Name_Id = Name_Descriptor + and then Chars (Class) = Name_UBSB + then + Set_Mechanism (Ent, By_Descriptor_UBSB); + + elsif Mech_Name_Id = Name_Descriptor + and then Chars (Class) = Name_UBA + then + Set_Mechanism (Ent, By_Descriptor_UBA); + + elsif Mech_Name_Id = Name_Descriptor + and then Chars (Class) = Name_S + then + Set_Mechanism (Ent, By_Descriptor_S); + + elsif Mech_Name_Id = Name_Descriptor + and then Chars (Class) = Name_SB + then + Set_Mechanism (Ent, By_Descriptor_SB); + + elsif Mech_Name_Id = Name_Descriptor + and then Chars (Class) = Name_A + then + Set_Mechanism (Ent, By_Descriptor_A); + + elsif Mech_Name_Id = Name_Descriptor + and then Chars (Class) = Name_NCA + then + Set_Mechanism (Ent, By_Descriptor_NCA); + + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_UBS + then + Set_Mechanism (Ent, By_Short_Descriptor_UBS); + + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_UBSB + then + Set_Mechanism (Ent, By_Short_Descriptor_UBSB); + + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_UBA + then + Set_Mechanism (Ent, By_Short_Descriptor_UBA); + + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_S + then + Set_Mechanism (Ent, By_Short_Descriptor_S); + + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_SB + then + Set_Mechanism (Ent, By_Short_Descriptor_SB); + + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_A + then + Set_Mechanism (Ent, By_Short_Descriptor_A); + + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_NCA + then + Set_Mechanism (Ent, By_Short_Descriptor_NCA); + + else + Bad_Class; + end if; + end Set_Mechanism_Value; + + --------------------------- + -- Set_Ravenscar_Profile -- + --------------------------- + + -- The tasks to be done here are + + -- Set required policies + + -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities) + -- pragma Locking_Policy (Ceiling_Locking) + + -- Set Detect_Blocking mode + + -- Set required restrictions (see System.Rident for detailed list) + + -- Set the No_Dependence rules + -- No_Dependence => Ada.Asynchronous_Task_Control + -- No_Dependence => Ada.Calendar + -- No_Dependence => Ada.Execution_Time.Group_Budget + -- No_Dependence => Ada.Execution_Time.Timers + -- No_Dependence => Ada.Task_Attributes + -- No_Dependence => System.Multiprocessors.Dispatching_Domains + + procedure Set_Ravenscar_Profile (N : Node_Id) is + Prefix_Entity : Entity_Id; + Selector_Entity : Entity_Id; + Prefix_Node : Node_Id; + Node : Node_Id; + + begin + -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities) + + if Task_Dispatching_Policy /= ' ' + and then Task_Dispatching_Policy /= 'F' + then + Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; + Error_Pragma ("Profile (Ravenscar) incompatible with policy#"); + + -- Set the FIFO_Within_Priorities policy, but always preserve + -- System_Location since we like the error message with the run time + -- name. + + else + Task_Dispatching_Policy := 'F'; + + if Task_Dispatching_Policy_Sloc /= System_Location then + Task_Dispatching_Policy_Sloc := Loc; + end if; + end if; + + -- pragma Locking_Policy (Ceiling_Locking) + + if Locking_Policy /= ' ' + and then Locking_Policy /= 'C' + then + Error_Msg_Sloc := Locking_Policy_Sloc; + Error_Pragma ("Profile (Ravenscar) incompatible with policy#"); + + -- Set the Ceiling_Locking policy, but preserve System_Location since + -- we like the error message with the run time name. + + else + Locking_Policy := 'C'; + + if Locking_Policy_Sloc /= System_Location then + Locking_Policy_Sloc := Loc; + end if; + end if; + + -- pragma Detect_Blocking + + Detect_Blocking := True; + + -- Set the corresponding restrictions + + Set_Profile_Restrictions + (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings); + + -- Set the No_Dependence restrictions + + -- The following No_Dependence restrictions: + -- No_Dependence => Ada.Asynchronous_Task_Control + -- No_Dependence => Ada.Calendar + -- No_Dependence => Ada.Task_Attributes + -- are already set by previous call to Set_Profile_Restrictions. + + -- Set the following restrictions which were added to Ada 2005: + -- No_Dependence => Ada.Execution_Time.Group_Budget + -- No_Dependence => Ada.Execution_Time.Timers + + if Ada_Version >= Ada_2005 then + Name_Buffer (1 .. 3) := "ada"; + Name_Len := 3; + + Prefix_Entity := Make_Identifier (Loc, Name_Find); + + Name_Buffer (1 .. 14) := "execution_time"; + Name_Len := 14; + + Selector_Entity := Make_Identifier (Loc, Name_Find); + + Prefix_Node := + Make_Selected_Component + (Sloc => Loc, + Prefix => Prefix_Entity, + Selector_Name => Selector_Entity); + + Name_Buffer (1 .. 13) := "group_budgets"; + Name_Len := 13; + + Selector_Entity := Make_Identifier (Loc, Name_Find); + + Node := + Make_Selected_Component + (Sloc => Loc, + Prefix => Prefix_Node, + Selector_Name => Selector_Entity); + + Set_Restriction_No_Dependence + (Unit => Node, + Warn => Treat_Restrictions_As_Warnings, + Profile => Ravenscar); + + Name_Buffer (1 .. 6) := "timers"; + Name_Len := 6; + + Selector_Entity := Make_Identifier (Loc, Name_Find); + + Node := + Make_Selected_Component + (Sloc => Loc, + Prefix => Prefix_Node, + Selector_Name => Selector_Entity); + + Set_Restriction_No_Dependence + (Unit => Node, + Warn => Treat_Restrictions_As_Warnings, + Profile => Ravenscar); + end if; + + -- Set the following restrictions which was added to Ada 2012 (see + -- AI-0171): + -- No_Dependence => System.Multiprocessors.Dispatching_Domains + + if Ada_Version >= Ada_2012 then + Name_Buffer (1 .. 6) := "system"; + Name_Len := 6; + + Prefix_Entity := Make_Identifier (Loc, Name_Find); + + Name_Buffer (1 .. 15) := "multiprocessors"; + Name_Len := 15; + + Selector_Entity := Make_Identifier (Loc, Name_Find); + + Prefix_Node := + Make_Selected_Component + (Sloc => Loc, + Prefix => Prefix_Entity, + Selector_Name => Selector_Entity); + + Name_Buffer (1 .. 19) := "dispatching_domains"; + Name_Len := 19; + + Selector_Entity := Make_Identifier (Loc, Name_Find); + + Node := + Make_Selected_Component + (Sloc => Loc, + Prefix => Prefix_Node, + Selector_Name => Selector_Entity); + + Set_Restriction_No_Dependence + (Unit => Node, + Warn => Treat_Restrictions_As_Warnings, + Profile => Ravenscar); + end if; + end Set_Ravenscar_Profile; + + -- Start of processing for Analyze_Pragma + + begin + -- Deal with unrecognized pragma + + if not Is_Pragma_Name (Pname) then + if Warn_On_Unrecognized_Pragma then + Error_Msg_Name_1 := Pname; + Error_Msg_N ("?unrecognized pragma%!", Pragma_Identifier (N)); + + for PN in First_Pragma_Name .. Last_Pragma_Name loop + if Is_Bad_Spelling_Of (Pname, PN) then + Error_Msg_Name_1 := PN; + Error_Msg_N -- CODEFIX + ("\?possible misspelling of %!", Pragma_Identifier (N)); + exit; + end if; + end loop; + end if; + + return; + end if; + + -- Here to start processing for recognized pragma + + Prag_Id := Get_Pragma_Id (Pname); + + -- Preset arguments + + Arg1 := Empty; + Arg2 := Empty; + Arg3 := Empty; + Arg4 := Empty; + + if Present (Pragma_Argument_Associations (N)) then + Arg1 := First (Pragma_Argument_Associations (N)); + + if Present (Arg1) then + Arg2 := Next (Arg1); + + if Present (Arg2) then + Arg3 := Next (Arg2); + + if Present (Arg3) then + Arg4 := Next (Arg3); + end if; + end if; + end if; + end if; + + -- Count number of arguments + + declare + Arg_Node : Node_Id; + begin + Arg_Count := 0; + Arg_Node := Arg1; + while Present (Arg_Node) loop + Arg_Count := Arg_Count + 1; + Next (Arg_Node); + end loop; + end; + + -- An enumeration type defines the pragmas that are supported by the + -- implementation. Get_Pragma_Id (in package Prag) transforms a name + -- into the corresponding enumeration value for the following case. + + case Prag_Id is + + ----------------- + -- Abort_Defer -- + ----------------- + + -- pragma Abort_Defer; + + when Pragma_Abort_Defer => + GNAT_Pragma; + Check_Arg_Count (0); + + -- The only required semantic processing is to check the + -- placement. This pragma must appear at the start of the + -- statement sequence of a handled sequence of statements. + + if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements + or else N /= First (Statements (Parent (N))) + then + Pragma_Misplaced; + end if; + + ------------ + -- Ada_83 -- + ------------ + + -- pragma Ada_83; + + -- Note: this pragma also has some specific processing in Par.Prag + -- because we want to set the Ada version mode during parsing. + + when Pragma_Ada_83 => + GNAT_Pragma; + Check_Arg_Count (0); + + -- We really should check unconditionally for proper configuration + -- pragma placement, since we really don't want mixed Ada modes + -- within a single unit, and the GNAT reference manual has always + -- said this was a configuration pragma, but we did not check and + -- are hesitant to add the check now. + + -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012 + -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005 + -- or Ada 2012 mode. + + if Ada_Version >= Ada_2005 then + Check_Valid_Configuration_Pragma; + end if; + + -- Now set Ada 83 mode + + Ada_Version := Ada_83; + Ada_Version_Explicit := Ada_Version; + + ------------ + -- Ada_95 -- + ------------ + + -- pragma Ada_95; + + -- Note: this pragma also has some specific processing in Par.Prag + -- because we want to set the Ada 83 version mode during parsing. + + when Pragma_Ada_95 => + GNAT_Pragma; + Check_Arg_Count (0); + + -- We really should check unconditionally for proper configuration + -- pragma placement, since we really don't want mixed Ada modes + -- within a single unit, and the GNAT reference manual has always + -- said this was a configuration pragma, but we did not check and + -- are hesitant to add the check now. + + -- However, we really cannot tolerate mixing Ada 2005 with Ada 83 + -- or Ada 95, so we must check if we are in Ada 2005 mode. + + if Ada_Version >= Ada_2005 then + Check_Valid_Configuration_Pragma; + end if; + + -- Now set Ada 95 mode + + Ada_Version := Ada_95; + Ada_Version_Explicit := Ada_Version; + + --------------------- + -- Ada_05/Ada_2005 -- + --------------------- + + -- pragma Ada_05; + -- pragma Ada_05 (LOCAL_NAME); + + -- pragma Ada_2005; + -- pragma Ada_2005 (LOCAL_NAME): + + -- Note: these pragmas also have some specific processing in Par.Prag + -- because we want to set the Ada 2005 version mode during parsing. + + when Pragma_Ada_05 | Pragma_Ada_2005 => declare + E_Id : Node_Id; + + begin + GNAT_Pragma; + + if Arg_Count = 1 then + Check_Arg_Is_Local_Name (Arg1); + E_Id := Get_Pragma_Arg (Arg1); + + if Etype (E_Id) = Any_Type then + return; + end if; + + Set_Is_Ada_2005_Only (Entity (E_Id)); + + else + Check_Arg_Count (0); + + -- For Ada_2005 we unconditionally enforce the documented + -- configuration pragma placement, since we do not want to + -- tolerate mixed modes in a unit involving Ada 2005. That + -- would cause real difficulties for those cases where there + -- are incompatibilities between Ada 95 and Ada 2005. + + Check_Valid_Configuration_Pragma; + + -- Now set appropriate Ada mode + + if Sense then + Ada_Version := Ada_2005; + else + Ada_Version := Ada_Version_Default; + end if; + + Ada_Version_Explicit := Ada_2005; + end if; + end; + + --------------------- + -- Ada_12/Ada_2012 -- + --------------------- + + -- pragma Ada_12; + -- pragma Ada_12 (LOCAL_NAME); + + -- pragma Ada_2012; + -- pragma Ada_2012 (LOCAL_NAME): + + -- Note: these pragmas also have some specific processing in Par.Prag + -- because we want to set the Ada 2012 version mode during parsing. + + when Pragma_Ada_12 | Pragma_Ada_2012 => declare + E_Id : Node_Id; + + begin + GNAT_Pragma; + + if Arg_Count = 1 then + Check_Arg_Is_Local_Name (Arg1); + E_Id := Get_Pragma_Arg (Arg1); + + if Etype (E_Id) = Any_Type then + return; + end if; + + Set_Is_Ada_2012_Only (Entity (E_Id)); + + else + Check_Arg_Count (0); + + -- For Ada_2012 we unconditionally enforce the documented + -- configuration pragma placement, since we do not want to + -- tolerate mixed modes in a unit involving Ada 2012. That + -- would cause real difficulties for those cases where there + -- are incompatibilities between Ada 95 and Ada 2012. We could + -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it. + + Check_Valid_Configuration_Pragma; + + -- Now set appropriate Ada mode + + if Sense then + Ada_Version := Ada_2012; + else + Ada_Version := Ada_Version_Default; + end if; + + Ada_Version_Explicit := Ada_2012; + end if; + end; + + ---------------------- + -- All_Calls_Remote -- + ---------------------- + + -- pragma All_Calls_Remote [(library_package_NAME)]; + + when Pragma_All_Calls_Remote => All_Calls_Remote : declare + Lib_Entity : Entity_Id; + + begin + Check_Ada_83_Warning; + Check_Valid_Library_Unit_Pragma; + + if Nkind (N) = N_Null_Statement then + return; + end if; + + Lib_Entity := Find_Lib_Unit_Name; + + -- This pragma should only apply to a RCI unit (RM E.2.3(23)) + + if Present (Lib_Entity) + and then not Debug_Flag_U + then + if not Is_Remote_Call_Interface (Lib_Entity) then + Error_Pragma ("pragma% only apply to rci unit"); + + -- Set flag for entity of the library unit + + else + Set_Has_All_Calls_Remote (Lib_Entity); + end if; + + end if; + end All_Calls_Remote; + + -------------- + -- Annotate -- + -------------- + + -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]); + -- ARG ::= NAME | EXPRESSION + + -- The first two arguments are by convention intended to refer to an + -- external tool and a tool-specific function. These arguments are + -- not analyzed. + + when Pragma_Annotate => Annotate : begin + GNAT_Pragma; + Check_At_Least_N_Arguments (1); + Check_Arg_Is_Identifier (Arg1); + Check_No_Identifiers; + Store_Note (N); + + declare + Arg : Node_Id; + Exp : Node_Id; + + begin + -- Second unanalyzed parameter is optional + + if No (Arg2) then + null; + else + Arg := Next (Arg2); + while Present (Arg) loop + Exp := Get_Pragma_Arg (Arg); + Analyze (Exp); + + if Is_Entity_Name (Exp) then + null; + + -- For string literals, we assume Standard_String as the + -- type, unless the string contains wide or wide_wide + -- characters. + + elsif Nkind (Exp) = N_String_Literal then + if Has_Wide_Wide_Character (Exp) then + Resolve (Exp, Standard_Wide_Wide_String); + elsif Has_Wide_Character (Exp) then + Resolve (Exp, Standard_Wide_String); + else + Resolve (Exp, Standard_String); + end if; + + elsif Is_Overloaded (Exp) then + Error_Pragma_Arg + ("ambiguous argument for pragma%", Exp); + + else + Resolve (Exp); + end if; + + Next (Arg); + end loop; + end if; + end; + end Annotate; + + ------------ + -- Assert -- + ------------ + + -- pragma Assert ([Check =>] Boolean_EXPRESSION + -- [, [Message =>] Static_String_EXPRESSION]); + + when Pragma_Assert => Assert : declare + Expr : Node_Id; + Newa : List_Id; + + begin + Ada_2005_Pragma; + Check_At_Least_N_Arguments (1); + Check_At_Most_N_Arguments (2); + Check_Arg_Order ((Name_Check, Name_Message)); + Check_Optional_Identifier (Arg1, Name_Check); + + -- We treat pragma Assert as equivalent to: + + -- pragma Check (Assertion, condition [, msg]); + + -- So rewrite pragma in this manner, and analyze the result + + Expr := Get_Pragma_Arg (Arg1); + Newa := New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_Assertion)), + + Make_Pragma_Argument_Association (Sloc (Expr), + Expression => Expr)); + + if Arg_Count > 1 then + Check_Optional_Identifier (Arg2, Name_Message); + Analyze_And_Resolve (Get_Pragma_Arg (Arg2), Standard_String); + Append_To (Newa, Relocate_Node (Arg2)); + end if; + + Rewrite (N, + Make_Pragma (Loc, + Chars => Name_Check, + Pragma_Argument_Associations => Newa)); + Analyze (N); + end Assert; + + ---------------------- + -- Assertion_Policy -- + ---------------------- + + -- pragma Assertion_Policy (Check | Ignore) + + when Pragma_Assertion_Policy => Assertion_Policy : declare + Policy : Node_Id; + + begin + Ada_2005_Pragma; + Check_Valid_Configuration_Pragma; + Check_Arg_Count (1); + Check_No_Identifiers; + Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore); + + -- We treat pragma Assertion_Policy as equivalent to: + + -- pragma Check_Policy (Assertion, policy) + + -- So rewrite the pragma in that manner and link on to the chain + -- of Check_Policy pragmas, marking the pragma as analyzed. + + Policy := Get_Pragma_Arg (Arg1); + + Rewrite (N, + Make_Pragma (Loc, + Chars => Name_Check_Policy, + + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_Assertion)), + + Make_Pragma_Argument_Association (Loc, + Expression => + Make_Identifier (Sloc (Policy), Chars (Policy)))))); + + Set_Analyzed (N); + Set_Next_Pragma (N, Opt.Check_Policy_List); + Opt.Check_Policy_List := N; + end Assertion_Policy; + + ------------------------------ + -- Assume_No_Invalid_Values -- + ------------------------------ + + -- pragma Assume_No_Invalid_Values (On | Off); + + when Pragma_Assume_No_Invalid_Values => + GNAT_Pragma; + Check_Valid_Configuration_Pragma; + Check_Arg_Count (1); + Check_No_Identifiers; + Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); + + if Chars (Get_Pragma_Arg (Arg1)) = Name_On then + Assume_No_Invalid_Values := True; + else + Assume_No_Invalid_Values := False; + end if; + + --------------- + -- AST_Entry -- + --------------- + + -- pragma AST_Entry (entry_IDENTIFIER); + + when Pragma_AST_Entry => AST_Entry : declare + Ent : Node_Id; + + begin + GNAT_Pragma; + Check_VMS (N); + Check_Arg_Count (1); + Check_No_Identifiers; + Check_Arg_Is_Local_Name (Arg1); + Ent := Entity (Get_Pragma_Arg (Arg1)); + + -- Note: the implementation of the AST_Entry pragma could handle + -- the entry family case fine, but for now we are consistent with + -- the DEC rules, and do not allow the pragma, which of course + -- has the effect of also forbidding the attribute. + + if Ekind (Ent) /= E_Entry then + Error_Pragma_Arg + ("pragma% argument must be simple entry name", Arg1); + + elsif Is_AST_Entry (Ent) then + Error_Pragma_Arg + ("duplicate % pragma for entry", Arg1); + + elsif Has_Homonym (Ent) then + Error_Pragma_Arg + ("pragma% argument cannot specify overloaded entry", Arg1); + + else + declare + FF : constant Entity_Id := First_Formal (Ent); + + begin + if Present (FF) then + if Present (Next_Formal (FF)) then + Error_Pragma_Arg + ("entry for pragma% can have only one argument", + Arg1); + + elsif Parameter_Mode (FF) /= E_In_Parameter then + Error_Pragma_Arg + ("entry parameter for pragma% must have mode IN", + Arg1); + end if; + end if; + end; + + Set_Is_AST_Entry (Ent); + end if; + end AST_Entry; + + ------------------ + -- Asynchronous -- + ------------------ + + -- pragma Asynchronous (LOCAL_NAME); + + when Pragma_Asynchronous => Asynchronous : declare + Nm : Entity_Id; + C_Ent : Entity_Id; + L : List_Id; + S : Node_Id; + N : Node_Id; + Formal : Entity_Id; + + procedure Process_Async_Pragma; + -- Common processing for procedure and access-to-procedure case + + -------------------------- + -- Process_Async_Pragma -- + -------------------------- + + procedure Process_Async_Pragma is + begin + if No (L) then + Set_Is_Asynchronous (Nm); + return; + end if; + + -- The formals should be of mode IN (RM E.4.1(6)) + + S := First (L); + while Present (S) loop + Formal := Defining_Identifier (S); + + if Nkind (Formal) = N_Defining_Identifier + and then Ekind (Formal) /= E_In_Parameter + then + Error_Pragma_Arg + ("pragma% procedure can only have IN parameter", + Arg1); + end if; + + Next (S); + end loop; + + Set_Is_Asynchronous (Nm); + end Process_Async_Pragma; + + -- Start of processing for pragma Asynchronous + + begin + Check_Ada_83_Warning; + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + + if Debug_Flag_U then + return; + end if; + + C_Ent := Cunit_Entity (Current_Sem_Unit); + Analyze (Get_Pragma_Arg (Arg1)); + Nm := Entity (Get_Pragma_Arg (Arg1)); + + if not Is_Remote_Call_Interface (C_Ent) + and then not Is_Remote_Types (C_Ent) + then + -- This pragma should only appear in an RCI or Remote Types + -- unit (RM E.4.1(4)). + + Error_Pragma + ("pragma% not in Remote_Call_Interface or " & + "Remote_Types unit"); + end if; + + if Ekind (Nm) = E_Procedure + and then Nkind (Parent (Nm)) = N_Procedure_Specification + then + if not Is_Remote_Call_Interface (Nm) then + Error_Pragma_Arg + ("pragma% cannot be applied on non-remote procedure", + Arg1); + end if; + + L := Parameter_Specifications (Parent (Nm)); + Process_Async_Pragma; + return; + + elsif Ekind (Nm) = E_Function then + Error_Pragma_Arg + ("pragma% cannot be applied to function", Arg1); + + elsif Is_Remote_Access_To_Subprogram_Type (Nm) then + + if Is_Record_Type (Nm) then + + -- A record type that is the Equivalent_Type for a remote + -- access-to-subprogram type. + + N := Declaration_Node (Corresponding_Remote_Type (Nm)); + + else + -- A non-expanded RAS type (distribution is not enabled) + + N := Declaration_Node (Nm); + end if; + + if Nkind (N) = N_Full_Type_Declaration + and then Nkind (Type_Definition (N)) = + N_Access_Procedure_Definition + then + L := Parameter_Specifications (Type_Definition (N)); + Process_Async_Pragma; + + if Is_Asynchronous (Nm) + and then Expander_Active + and then Get_PCS_Name /= Name_No_DSA + then + RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm)); + end if; + + else + Error_Pragma_Arg + ("pragma% cannot reference access-to-function type", + Arg1); + end if; + + -- Only other possibility is Access-to-class-wide type + + elsif Is_Access_Type (Nm) + and then Is_Class_Wide_Type (Designated_Type (Nm)) + then + Check_First_Subtype (Arg1); + Set_Is_Asynchronous (Nm); + if Expander_Active then + RACW_Type_Is_Asynchronous (Nm); + end if; + + else + Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1); + end if; + end Asynchronous; + + ------------ + -- Atomic -- + ------------ + + -- pragma Atomic (LOCAL_NAME); + + when Pragma_Atomic => + Process_Atomic_Shared_Volatile; + + ----------------------- + -- Atomic_Components -- + ----------------------- + + -- pragma Atomic_Components (array_LOCAL_NAME); + + -- This processing is shared by Volatile_Components + + when Pragma_Atomic_Components | + Pragma_Volatile_Components => + + Atomic_Components : declare + E_Id : Node_Id; + E : Entity_Id; + D : Node_Id; + K : Node_Kind; + + begin + Check_Ada_83_Warning; + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + E_Id := Get_Pragma_Arg (Arg1); + + if Etype (E_Id) = Any_Type then + return; + end if; + + E := Entity (E_Id); + + Check_Duplicate_Pragma (E); + + if Rep_Item_Too_Early (E, N) + or else + Rep_Item_Too_Late (E, N) + then + return; + end if; + + D := Declaration_Node (E); + K := Nkind (D); + + if (K = N_Full_Type_Declaration and then Is_Array_Type (E)) + or else + ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable) + and then Nkind (D) = N_Object_Declaration + and then Nkind (Object_Definition (D)) = + N_Constrained_Array_Definition) + then + -- The flag is set on the object, or on the base type + + if Nkind (D) /= N_Object_Declaration then + E := Base_Type (E); + end if; + + Set_Has_Volatile_Components (E, Sense); + + if Prag_Id = Pragma_Atomic_Components then + Set_Has_Atomic_Components (E, Sense); + end if; + + else + Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); + end if; + end Atomic_Components; + + -------------------- + -- Attach_Handler -- + -------------------- + + -- pragma Attach_Handler (handler_NAME, EXPRESSION); + + when Pragma_Attach_Handler => + Check_Ada_83_Warning; + Check_No_Identifiers; + Check_Arg_Count (2); + + if No_Run_Time_Mode then + Error_Msg_CRT ("Attach_Handler pragma", N); + else + Check_Interrupt_Or_Attach_Handler; + + -- The expression that designates the attribute may depend on a + -- discriminant, and is therefore a per- object expression, to + -- be expanded in the init proc. If expansion is enabled, then + -- perform semantic checks on a copy only. + + if Expander_Active then + declare + Temp : constant Node_Id := + New_Copy_Tree (Get_Pragma_Arg (Arg2)); + begin + Set_Parent (Temp, N); + Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID)); + end; + + else + Analyze (Get_Pragma_Arg (Arg2)); + Resolve (Get_Pragma_Arg (Arg2), RTE (RE_Interrupt_ID)); + end if; + + Process_Interrupt_Or_Attach_Handler; + end if; + + -------------------- + -- C_Pass_By_Copy -- + -------------------- + + -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION); + + when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare + Arg : Node_Id; + Val : Uint; + + begin + GNAT_Pragma; + Check_Valid_Configuration_Pragma; + Check_Arg_Count (1); + Check_Optional_Identifier (Arg1, "max_size"); + + Arg := Get_Pragma_Arg (Arg1); + Check_Arg_Is_Static_Expression (Arg, Any_Integer); + + Val := Expr_Value (Arg); + + if Val <= 0 then + Error_Pragma_Arg + ("maximum size for pragma% must be positive", Arg1); + + elsif UI_Is_In_Int_Range (Val) then + Default_C_Record_Mechanism := UI_To_Int (Val); + + -- If a giant value is given, Int'Last will do well enough. + -- If sometime someone complains that a record larger than + -- two gigabytes is not copied, we will worry about it then! + + else + Default_C_Record_Mechanism := Mechanism_Type'Last; + end if; + end C_Pass_By_Copy; + + ----------- + -- Check -- + ----------- + + -- pragma Check ([Name =>] Identifier, + -- [Check =>] Boolean_Expression + -- [,[Message =>] String_Expression]); + + when Pragma_Check => Check : declare + Expr : Node_Id; + Eloc : Source_Ptr; + + Check_On : Boolean; + -- Set True if category of assertions referenced by Name enabled + + begin + GNAT_Pragma; + Check_At_Least_N_Arguments (2); + Check_At_Most_N_Arguments (3); + Check_Optional_Identifier (Arg1, Name_Name); + Check_Optional_Identifier (Arg2, Name_Check); + + if Arg_Count = 3 then + Check_Optional_Identifier (Arg3, Name_Message); + Analyze_And_Resolve (Get_Pragma_Arg (Arg3), Standard_String); + end if; + + Check_Arg_Is_Identifier (Arg1); + + -- Indicate if pragma is enabled. The Original_Node reference here + -- is to deal with pragma Assert rewritten as a Check pragma. + + Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1))); + + if Check_On then + Set_Pragma_Enabled (N); + Set_Pragma_Enabled (Original_Node (N)); + Set_SCO_Pragma_Enabled (Loc); + end if; + + -- If expansion is active and the check is not enabled then we + -- rewrite the Check as: + + -- if False and then condition then + -- null; + -- end if; + + -- The reason we do this rewriting during semantic analysis rather + -- than as part of normal expansion is that we cannot analyze and + -- expand the code for the boolean expression directly, or it may + -- cause insertion of actions that would escape the attempt to + -- suppress the check code. + + -- Note that the Sloc for the if statement corresponds to the + -- argument condition, not the pragma itself. The reason for this + -- is that we may generate a warning if the condition is False at + -- compile time, and we do not want to delete this warning when we + -- delete the if statement. + + Expr := Get_Pragma_Arg (Arg2); + + if Expander_Active and then not Check_On then + Eloc := Sloc (Expr); + + Rewrite (N, + Make_If_Statement (Eloc, + Condition => + Make_And_Then (Eloc, + Left_Opnd => New_Occurrence_Of (Standard_False, Eloc), + Right_Opnd => Expr), + Then_Statements => New_List ( + Make_Null_Statement (Eloc)))); + + Analyze (N); + + -- Check is active + + else + Analyze_And_Resolve (Expr, Any_Boolean); + end if; + end Check; + + ---------------- + -- Check_Name -- + ---------------- + + -- pragma Check_Name (check_IDENTIFIER); + + when Pragma_Check_Name => + Check_No_Identifiers; + GNAT_Pragma; + Check_Valid_Configuration_Pragma; + Check_Arg_Count (1); + Check_Arg_Is_Identifier (Arg1); + + declare + Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1)); + + begin + for J in Check_Names.First .. Check_Names.Last loop + if Check_Names.Table (J) = Nam then + return; + end if; + end loop; + + Check_Names.Append (Nam); + end; + + ------------------ + -- Check_Policy -- + ------------------ + + -- pragma Check_Policy ( + -- [Name =>] IDENTIFIER, + -- [Policy =>] POLICY_IDENTIFIER); + + -- POLICY_IDENTIFIER ::= ON | OFF | CHECK | IGNORE + + -- Note: this is a configuration pragma, but it is allowed to appear + -- anywhere else. + + when Pragma_Check_Policy => + GNAT_Pragma; + Check_Arg_Count (2); + Check_Optional_Identifier (Arg1, Name_Name); + Check_Optional_Identifier (Arg2, Name_Policy); + Check_Arg_Is_One_Of + (Arg2, Name_On, Name_Off, Name_Check, Name_Ignore); + + -- A Check_Policy pragma can appear either as a configuration + -- pragma, or in a declarative part or a package spec (see RM + -- 11.5(5) for rules for Suppress/Unsuppress which are also + -- followed for Check_Policy). + + if not Is_Configuration_Pragma then + Check_Is_In_Decl_Part_Or_Package_Spec; + end if; + + Set_Next_Pragma (N, Opt.Check_Policy_List); + Opt.Check_Policy_List := N; + + --------------------- + -- CIL_Constructor -- + --------------------- + + -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME); + + -- Processing for this pragma is shared with Java_Constructor + + ------------- + -- Comment -- + ------------- + + -- pragma Comment (static_string_EXPRESSION) + + -- Processing for pragma Comment shares the circuitry for pragma + -- Ident. The only differences are that Ident enforces a limit of 31 + -- characters on its argument, and also enforces limitations on + -- placement for DEC compatibility. Pragma Comment shares neither of + -- these restrictions. + + ------------------- + -- Common_Object -- + ------------------- + + -- pragma Common_Object ( + -- [Internal =>] LOCAL_NAME + -- [, [External =>] EXTERNAL_SYMBOL] + -- [, [Size =>] EXTERNAL_SYMBOL]); + + -- Processing for this pragma is shared with Psect_Object + + ------------------------ + -- Compile_Time_Error -- + ------------------------ + + -- pragma Compile_Time_Error + -- (boolean_EXPRESSION, static_string_EXPRESSION); + + when Pragma_Compile_Time_Error => + GNAT_Pragma; + Process_Compile_Time_Warning_Or_Error; + + -------------------------- + -- Compile_Time_Warning -- + -------------------------- + + -- pragma Compile_Time_Warning + -- (boolean_EXPRESSION, static_string_EXPRESSION); + + when Pragma_Compile_Time_Warning => + GNAT_Pragma; + Process_Compile_Time_Warning_Or_Error; + + ------------------- + -- Compiler_Unit -- + ------------------- + + when Pragma_Compiler_Unit => + GNAT_Pragma; + Check_Arg_Count (0); + Set_Is_Compiler_Unit (Get_Source_Unit (N)); + + ----------------------------- + -- Complete_Representation -- + ----------------------------- + + -- pragma Complete_Representation; + + when Pragma_Complete_Representation => + GNAT_Pragma; + Check_Arg_Count (0); + + if Nkind (Parent (N)) /= N_Record_Representation_Clause then + Error_Pragma + ("pragma & must appear within record representation clause"); + end if; + + ---------------------------- + -- Complex_Representation -- + ---------------------------- + + -- pragma Complex_Representation ([Entity =>] LOCAL_NAME); + + when Pragma_Complex_Representation => Complex_Representation : declare + E_Id : Entity_Id; + E : Entity_Id; + Ent : Entity_Id; + + begin + GNAT_Pragma; + Check_Arg_Count (1); + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Arg_Is_Local_Name (Arg1); + E_Id := Get_Pragma_Arg (Arg1); + + if Etype (E_Id) = Any_Type then + return; + end if; + + E := Entity (E_Id); + + if not Is_Record_Type (E) then + Error_Pragma_Arg + ("argument for pragma% must be record type", Arg1); + end if; + + Ent := First_Entity (E); + + if No (Ent) + or else No (Next_Entity (Ent)) + or else Present (Next_Entity (Next_Entity (Ent))) + or else not Is_Floating_Point_Type (Etype (Ent)) + or else Etype (Ent) /= Etype (Next_Entity (Ent)) + then + Error_Pragma_Arg + ("record for pragma% must have two fields of the same " + & "floating-point type", Arg1); + + else + Set_Has_Complex_Representation (Base_Type (E)); + + -- We need to treat the type has having a non-standard + -- representation, for back-end purposes, even though in + -- general a complex will have the default representation + -- of a record with two real components. + + Set_Has_Non_Standard_Rep (Base_Type (E)); + end if; + end Complex_Representation; + + ------------------------- + -- Component_Alignment -- + ------------------------- + + -- pragma Component_Alignment ( + -- [Form =>] ALIGNMENT_CHOICE + -- [, [Name =>] type_LOCAL_NAME]); + -- + -- ALIGNMENT_CHOICE ::= + -- Component_Size + -- | Component_Size_4 + -- | Storage_Unit + -- | Default + + when Pragma_Component_Alignment => Component_AlignmentP : declare + Args : Args_List (1 .. 2); + Names : constant Name_List (1 .. 2) := ( + Name_Form, + Name_Name); + + Form : Node_Id renames Args (1); + Name : Node_Id renames Args (2); + + Atype : Component_Alignment_Kind; + Typ : Entity_Id; + + begin + GNAT_Pragma; + Gather_Associations (Names, Args); + + if No (Form) then + Error_Pragma ("missing Form argument for pragma%"); + end if; + + Check_Arg_Is_Identifier (Form); + + -- Get proper alignment, note that Default = Component_Size on all + -- machines we have so far, and we want to set this value rather + -- than the default value to indicate that it has been explicitly + -- set (and thus will not get overridden by the default component + -- alignment for the current scope) + + if Chars (Form) = Name_Component_Size then + Atype := Calign_Component_Size; + + elsif Chars (Form) = Name_Component_Size_4 then + Atype := Calign_Component_Size_4; + + elsif Chars (Form) = Name_Default then + Atype := Calign_Component_Size; + + elsif Chars (Form) = Name_Storage_Unit then + Atype := Calign_Storage_Unit; + + else + Error_Pragma_Arg + ("invalid Form parameter for pragma%", Form); + end if; + + -- Case with no name, supplied, affects scope table entry + + if No (Name) then + Scope_Stack.Table + (Scope_Stack.Last).Component_Alignment_Default := Atype; + + -- Case of name supplied + + else + Check_Arg_Is_Local_Name (Name); + Find_Type (Name); + Typ := Entity (Name); + + if Typ = Any_Type + or else Rep_Item_Too_Early (Typ, N) + then + return; + else + Typ := Underlying_Type (Typ); + end if; + + if not Is_Record_Type (Typ) + and then not Is_Array_Type (Typ) + then + Error_Pragma_Arg + ("Name parameter of pragma% must identify record or " & + "array type", Name); + end if; + + -- An explicit Component_Alignment pragma overrides an + -- implicit pragma Pack, but not an explicit one. + + if not Has_Pragma_Pack (Base_Type (Typ)) then + Set_Is_Packed (Base_Type (Typ), False); + Set_Component_Alignment (Base_Type (Typ), Atype); + end if; + end if; + end Component_AlignmentP; + + ---------------- + -- Controlled -- + ---------------- + + -- pragma Controlled (first_subtype_LOCAL_NAME); + + when Pragma_Controlled => Controlled : declare + Arg : Node_Id; + + begin + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + Arg := Get_Pragma_Arg (Arg1); + + if not Is_Entity_Name (Arg) + or else not Is_Access_Type (Entity (Arg)) + then + Error_Pragma_Arg ("pragma% requires access type", Arg1); + else + Set_Has_Pragma_Controlled (Base_Type (Entity (Arg))); + end if; + end Controlled; + + ---------------- + -- Convention -- + ---------------- + + -- pragma Convention ([Convention =>] convention_IDENTIFIER, + -- [Entity =>] LOCAL_NAME); + + when Pragma_Convention => Convention : declare + C : Convention_Id; + E : Entity_Id; + pragma Warnings (Off, C); + pragma Warnings (Off, E); + begin + Check_Arg_Order ((Name_Convention, Name_Entity)); + Check_Ada_83_Warning; + Check_Arg_Count (2); + Process_Convention (C, E); + end Convention; + + --------------------------- + -- Convention_Identifier -- + --------------------------- + + -- pragma Convention_Identifier ([Name =>] IDENTIFIER, + -- [Convention =>] convention_IDENTIFIER); + + when Pragma_Convention_Identifier => Convention_Identifier : declare + Idnam : Name_Id; + Cname : Name_Id; + + begin + GNAT_Pragma; + Check_Arg_Order ((Name_Name, Name_Convention)); + Check_Arg_Count (2); + Check_Optional_Identifier (Arg1, Name_Name); + Check_Optional_Identifier (Arg2, Name_Convention); + Check_Arg_Is_Identifier (Arg1); + Check_Arg_Is_Identifier (Arg2); + Idnam := Chars (Get_Pragma_Arg (Arg1)); + Cname := Chars (Get_Pragma_Arg (Arg2)); + + if Is_Convention_Name (Cname) then + Record_Convention_Identifier + (Idnam, Get_Convention_Id (Cname)); + else + Error_Pragma_Arg + ("second arg for % pragma must be convention", Arg2); + end if; + end Convention_Identifier; + + --------------- + -- CPP_Class -- + --------------- + + -- pragma CPP_Class ([Entity =>] local_NAME) + + when Pragma_CPP_Class => CPP_Class : declare + Arg : Node_Id; + Typ : Entity_Id; + + begin + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("'G'N'A'T pragma cpp'_class is now obsolete; replace it" & + " by pragma import?", N); + end if; + + GNAT_Pragma; + Check_Arg_Count (1); + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Arg_Is_Local_Name (Arg1); + + Arg := Get_Pragma_Arg (Arg1); + Analyze (Arg); + + if Etype (Arg) = Any_Type then + return; + end if; + + if not Is_Entity_Name (Arg) + or else not Is_Type (Entity (Arg)) + then + Error_Pragma_Arg ("pragma% requires a type mark", Arg1); + end if; + + Typ := Entity (Arg); + + if not Is_Tagged_Type (Typ) then + Error_Pragma_Arg ("pragma% applicable to tagged types ", Arg1); + end if; + + -- Types treated as CPP classes are treated as limited, but we + -- don't require them to be declared this way. A warning is issued + -- to encourage the user to declare them as limited. This is not + -- an error, for compatibility reasons, because these types have + -- been supported this way for some time. + + if not Is_Limited_Type (Typ) then + Error_Msg_N + ("imported 'C'P'P type should be " & + "explicitly declared limited?", + Get_Pragma_Arg (Arg1)); + Error_Msg_N + ("\type will be considered limited", + Get_Pragma_Arg (Arg1)); + end if; + + Set_Is_CPP_Class (Typ); + Set_Is_Limited_Record (Typ); + Set_Convention (Typ, Convention_CPP); + + -- Imported CPP types must not have discriminants (because C++ + -- classes do not have discriminants). + + if Has_Discriminants (Typ) then + Error_Msg_N + ("imported 'C'P'P type cannot have discriminants", + First (Discriminant_Specifications + (Declaration_Node (Typ)))); + end if; + + -- Components of imported CPP types must not have default + -- expressions because the constructor (if any) is in the + -- C++ side. + + if Is_Incomplete_Or_Private_Type (Typ) + and then No (Underlying_Type (Typ)) + then + -- It should be an error to apply pragma CPP to a private + -- type if the underlying type is not visible (as it is + -- for any representation item). For now, for backward + -- compatibility we do nothing but we cannot check components + -- because they are not available at this stage. All this code + -- will be removed when we cleanup this obsolete GNAT pragma??? + + null; + + else + declare + Tdef : constant Node_Id := + Type_Definition (Declaration_Node (Typ)); + Clist : Node_Id; + Comp : Node_Id; + + begin + if Nkind (Tdef) = N_Record_Definition then + Clist := Component_List (Tdef); + else + pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition); + Clist := Component_List (Record_Extension_Part (Tdef)); + end if; + + if Present (Clist) then + Comp := First (Component_Items (Clist)); + while Present (Comp) loop + if Present (Expression (Comp)) then + Error_Msg_N + ("component of imported 'C'P'P type cannot have" & + " default expression", Expression (Comp)); + end if; + + Next (Comp); + end loop; + end if; + end; + end if; + end CPP_Class; + + --------------------- + -- CPP_Constructor -- + --------------------- + + -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME + -- [, [External_Name =>] static_string_EXPRESSION ] + -- [, [Link_Name =>] static_string_EXPRESSION ]); + + when Pragma_CPP_Constructor => CPP_Constructor : declare + Elmt : Elmt_Id; + Id : Entity_Id; + Def_Id : Entity_Id; + Tag_Typ : Entity_Id; + + begin + GNAT_Pragma; + Check_At_Least_N_Arguments (1); + Check_At_Most_N_Arguments (3); + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Arg_Is_Local_Name (Arg1); + + Id := Get_Pragma_Arg (Arg1); + Find_Program_Unit_Name (Id); + + -- If we did not find the name, we are done + + if Etype (Id) = Any_Type then + return; + end if; + + Def_Id := Entity (Id); + + -- Check if already defined as constructor + + if Is_Constructor (Def_Id) then + Error_Msg_N + ("?duplicate argument for pragma 'C'P'P_Constructor", Arg1); + return; + end if; + + if Ekind (Def_Id) = E_Function + and then (Is_CPP_Class (Etype (Def_Id)) + or else (Is_Class_Wide_Type (Etype (Def_Id)) + and then + Is_CPP_Class (Root_Type (Etype (Def_Id))))) + then + if Arg_Count >= 2 then + Set_Imported (Def_Id); + Set_Is_Public (Def_Id); + Process_Interface_Name (Def_Id, Arg2, Arg3); + end if; + + Set_Has_Completion (Def_Id); + Set_Is_Constructor (Def_Id); + + -- Imported C++ constructors are not dispatching primitives + -- because in C++ they don't have a dispatch table slot. + -- However, in Ada the constructor has the profile of a + -- function that returns a tagged type and therefore it has + -- been treated as a primitive operation during semantic + -- analysis. We now remove it from the list of primitive + -- operations of the type. + + if Is_Tagged_Type (Etype (Def_Id)) + and then not Is_Class_Wide_Type (Etype (Def_Id)) + then + pragma Assert (Is_Dispatching_Operation (Def_Id)); + Tag_Typ := Etype (Def_Id); + + Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Elmt) and then Node (Elmt) /= Def_Id loop + Next_Elmt (Elmt); + end loop; + + Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt); + Set_Is_Dispatching_Operation (Def_Id, False); + end if; + + -- For backward compatibility, if the constructor returns a + -- class wide type, and we internally change the return type to + -- the corresponding root type. + + if Is_Class_Wide_Type (Etype (Def_Id)) then + Set_Etype (Def_Id, Root_Type (Etype (Def_Id))); + end if; + else + Error_Pragma_Arg + ("pragma% requires function returning a 'C'P'P_Class type", + Arg1); + end if; + end CPP_Constructor; + + ----------------- + -- CPP_Virtual -- + ----------------- + + when Pragma_CPP_Virtual => CPP_Virtual : declare + begin + GNAT_Pragma; + + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("'G'N'A'T pragma cpp'_virtual is now obsolete and has " & + "no effect?", N); + end if; + end CPP_Virtual; + + ---------------- + -- CPP_Vtable -- + ---------------- + + when Pragma_CPP_Vtable => CPP_Vtable : declare + begin + GNAT_Pragma; + + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("'G'N'A'T pragma cpp'_vtable is now obsolete and has " & + "no effect?", N); + end if; + end CPP_Vtable; + + --------- + -- CPU -- + --------- + + -- pragma CPU (EXPRESSION); + + when Pragma_CPU => CPU : declare + P : constant Node_Id := Parent (N); + Arg : Node_Id; + + begin + Ada_2012_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + + -- Subprogram case + + if Nkind (P) = N_Subprogram_Body then + Check_In_Main_Program; + + Arg := Get_Pragma_Arg (Arg1); + Analyze_And_Resolve (Arg, Any_Integer); + + -- Must be static + + if not Is_Static_Expression (Arg) then + Flag_Non_Static_Expr + ("main subprogram affinity is not static!", Arg); + raise Pragma_Exit; + + -- If constraint error, then we already signalled an error + + elsif Raises_Constraint_Error (Arg) then + null; + + -- Otherwise check in range + + else + declare + CPU_Id : constant Entity_Id := RTE (RE_CPU_Range); + -- This is the entity System.Multiprocessors.CPU_Range; + + Val : constant Uint := Expr_Value (Arg); + + begin + if Val < Expr_Value (Type_Low_Bound (CPU_Id)) + or else + Val > Expr_Value (Type_High_Bound (CPU_Id)) + then + Error_Pragma_Arg + ("main subprogram CPU is out of range", Arg1); + end if; + end; + end if; + + Set_Main_CPU + (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg))); + + -- Task case + + elsif Nkind (P) = N_Task_Definition then + Arg := Get_Pragma_Arg (Arg1); + + -- The expression must be analyzed in the special manner + -- described in "Handling of Default and Per-Object + -- Expressions" in sem.ads. + + Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range)); + + -- Anything else is incorrect + + else + Pragma_Misplaced; + end if; + + if Has_Pragma_CPU (P) then + Error_Pragma ("duplicate pragma% not allowed"); + else + Set_Has_Pragma_CPU (P, True); + + if Nkind (P) = N_Task_Definition then + Record_Rep_Item (Defining_Identifier (Parent (P)), N); + end if; + end if; + end CPU; + + ----------- + -- Debug -- + ----------- + + -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT); + + when Pragma_Debug => Debug : declare + Cond : Node_Id; + + begin + GNAT_Pragma; + + Cond := + New_Occurrence_Of + (Boolean_Literals (Debug_Pragmas_Enabled and Expander_Active), + Loc); + + if Arg_Count = 2 then + Cond := + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (Cond), + Right_Opnd => Get_Pragma_Arg (Arg1)); + end if; + + -- Rewrite into a conditional with an appropriate condition. We + -- wrap the procedure call in a block so that overhead from e.g. + -- use of the secondary stack does not generate execution overhead + -- for suppressed conditions. + + Rewrite (N, Make_Implicit_If_Statement (N, + Condition => Cond, + Then_Statements => New_List ( + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Relocate_Node (Debug_Statement (N)))))))); + Analyze (N); + end Debug; + + ------------------ + -- Debug_Policy -- + ------------------ + + -- pragma Debug_Policy (Check | Ignore) + + when Pragma_Debug_Policy => + GNAT_Pragma; + Check_Arg_Count (1); + Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore); + Debug_Pragmas_Enabled := + Chars (Get_Pragma_Arg (Arg1)) = Name_Check; + + --------------------- + -- Detect_Blocking -- + --------------------- + + -- pragma Detect_Blocking; + + when Pragma_Detect_Blocking => + Ada_2005_Pragma; + Check_Arg_Count (0); + Check_Valid_Configuration_Pragma; + Detect_Blocking := True; + + -------------------------- + -- Default_Storage_Pool -- + -------------------------- + + -- pragma Default_Storage_Pool (storage_pool_NAME | null); + + when Pragma_Default_Storage_Pool => + Ada_2012_Pragma; + Check_Arg_Count (1); + + -- Default_Storage_Pool can appear as a configuration pragma, or + -- in a declarative part or a package spec. + + if not Is_Configuration_Pragma then + Check_Is_In_Decl_Part_Or_Package_Spec; + end if; + + -- Case of Default_Storage_Pool (null); + + if Nkind (Expression (Arg1)) = N_Null then + Analyze (Expression (Arg1)); + + -- This is an odd case, this is not really an expression, so + -- we don't have a type for it. So just set the type to Empty. + + Set_Etype (Expression (Arg1), Empty); + + -- Case of Default_Storage_Pool (storage_pool_NAME); + + else + -- If it's a configuration pragma, then the only allowed + -- argument is "null". + + if Is_Configuration_Pragma then + Error_Pragma_Arg ("NULL expected", Arg1); + end if; + + -- The expected type for a non-"null" argument is + -- Root_Storage_Pool'Class. + + Analyze_And_Resolve + (Get_Pragma_Arg (Arg1), + Typ => Class_Wide_Type (RTE (RE_Root_Storage_Pool))); + end if; + + -- Finally, record the pool name (or null). Freeze.Freeze_Entity + -- for an access type will use this information to set the + -- appropriate attributes of the access type. + + Default_Pool := Expression (Arg1); + + --------------- + -- Dimension -- + --------------- + + when Pragma_Dimension => + GNAT_Pragma; + Check_Arg_Count (4); + Check_No_Identifiers; + Check_Arg_Is_Local_Name (Arg1); + + if not Is_Type (Arg1) then + Error_Pragma ("first argument for pragma% must be subtype"); + end if; + + Check_Arg_Is_Static_Expression (Arg2, Standard_Integer); + Check_Arg_Is_Static_Expression (Arg3, Standard_Integer); + Check_Arg_Is_Static_Expression (Arg4, Standard_Integer); + + ------------------- + -- Discard_Names -- + ------------------- + + -- pragma Discard_Names [([On =>] LOCAL_NAME)]; + + when Pragma_Discard_Names => Discard_Names : declare + E : Entity_Id; + E_Id : Entity_Id; + + begin + Check_Ada_83_Warning; + + -- Deal with configuration pragma case + + if Arg_Count = 0 and then Is_Configuration_Pragma then + Global_Discard_Names := True; + return; + + -- Otherwise, check correct appropriate context + + else + Check_Is_In_Decl_Part_Or_Package_Spec; + + if Arg_Count = 0 then + + -- If there is no parameter, then from now on this pragma + -- applies to any enumeration, exception or tagged type + -- defined in the current declarative part, and recursively + -- to any nested scope. + + Set_Discard_Names (Current_Scope, Sense); + return; + + else + Check_Arg_Count (1); + Check_Optional_Identifier (Arg1, Name_On); + Check_Arg_Is_Local_Name (Arg1); + + E_Id := Get_Pragma_Arg (Arg1); + + if Etype (E_Id) = Any_Type then + return; + else + E := Entity (E_Id); + end if; + + if (Is_First_Subtype (E) + and then + (Is_Enumeration_Type (E) or else Is_Tagged_Type (E))) + or else Ekind (E) = E_Exception + then + Set_Discard_Names (E, Sense); + else + Error_Pragma_Arg + ("inappropriate entity for pragma%", Arg1); + end if; + + end if; + end if; + end Discard_Names; + + --------------- + -- Elaborate -- + --------------- + + -- pragma Elaborate (library_unit_NAME {, library_unit_NAME}); + + when Pragma_Elaborate => Elaborate : declare + Arg : Node_Id; + Citem : Node_Id; + + begin + -- Pragma must be in context items list of a compilation unit + + if not Is_In_Context_Clause then + Pragma_Misplaced; + end if; + + -- Must be at least one argument + + if Arg_Count = 0 then + Error_Pragma ("pragma% requires at least one argument"); + end if; + + -- In Ada 83 mode, there can be no items following it in the + -- context list except other pragmas and implicit with clauses + -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this + -- placement rule does not apply. + + if Ada_Version = Ada_83 and then Comes_From_Source (N) then + Citem := Next (N); + while Present (Citem) loop + if Nkind (Citem) = N_Pragma + or else (Nkind (Citem) = N_With_Clause + and then Implicit_With (Citem)) + then + null; + else + Error_Pragma + ("(Ada 83) pragma% must be at end of context clause"); + end if; + + Next (Citem); + end loop; + end if; + + -- Finally, the arguments must all be units mentioned in a with + -- clause in the same context clause. Note we already checked (in + -- Par.Prag) that the arguments are all identifiers or selected + -- components. + + Arg := Arg1; + Outer : while Present (Arg) loop + Citem := First (List_Containing (N)); + Inner : while Citem /= N loop + if Nkind (Citem) = N_With_Clause + and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg)) + then + Set_Elaborate_Present (Citem, True); + Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem)); + + -- With the pragma present, elaboration calls on + -- subprograms from the named unit need no further + -- checks, as long as the pragma appears in the current + -- compilation unit. If the pragma appears in some unit + -- in the context, there might still be a need for an + -- Elaborate_All_Desirable from the current compilation + -- to the named unit, so we keep the check enabled. + + if In_Extended_Main_Source_Unit (N) then + Set_Suppress_Elaboration_Warnings + (Entity (Name (Citem))); + end if; + + exit Inner; + end if; + + Next (Citem); + end loop Inner; + + if Citem = N then + Error_Pragma_Arg + ("argument of pragma% is not with'ed unit", Arg); + end if; + + Next (Arg); + end loop Outer; + + -- Give a warning if operating in static mode with -gnatwl + -- (elaboration warnings enabled) switch set. + + if Elab_Warnings and not Dynamic_Elaboration_Checks then + Error_Msg_N + ("?use of pragma Elaborate may not be safe", N); + Error_Msg_N + ("?use pragma Elaborate_All instead if possible", N); + end if; + end Elaborate; + + ------------------- + -- Elaborate_All -- + ------------------- + + -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME}); + + when Pragma_Elaborate_All => Elaborate_All : declare + Arg : Node_Id; + Citem : Node_Id; + + begin + Check_Ada_83_Warning; + + -- Pragma must be in context items list of a compilation unit + + if not Is_In_Context_Clause then + Pragma_Misplaced; + end if; + + -- Must be at least one argument + + if Arg_Count = 0 then + Error_Pragma ("pragma% requires at least one argument"); + end if; + + -- Note: unlike pragma Elaborate, pragma Elaborate_All does not + -- have to appear at the end of the context clause, but may + -- appear mixed in with other items, even in Ada 83 mode. + + -- Final check: the arguments must all be units mentioned in + -- a with clause in the same context clause. Note that we + -- already checked (in Par.Prag) that all the arguments are + -- either identifiers or selected components. + + Arg := Arg1; + Outr : while Present (Arg) loop + Citem := First (List_Containing (N)); + Innr : while Citem /= N loop + if Nkind (Citem) = N_With_Clause + and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg)) + then + Set_Elaborate_All_Present (Citem, True); + Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem)); + + -- Suppress warnings and elaboration checks on the named + -- unit if the pragma is in the current compilation, as + -- for pragma Elaborate. + + if In_Extended_Main_Source_Unit (N) then + Set_Suppress_Elaboration_Warnings + (Entity (Name (Citem))); + end if; + exit Innr; + end if; + + Next (Citem); + end loop Innr; + + if Citem = N then + Set_Error_Posted (N); + Error_Pragma_Arg + ("argument of pragma% is not with'ed unit", Arg); + end if; + + Next (Arg); + end loop Outr; + end Elaborate_All; + + -------------------- + -- Elaborate_Body -- + -------------------- + + -- pragma Elaborate_Body [( library_unit_NAME )]; + + when Pragma_Elaborate_Body => Elaborate_Body : declare + Cunit_Node : Node_Id; + Cunit_Ent : Entity_Id; + + begin + Check_Ada_83_Warning; + Check_Valid_Library_Unit_Pragma; + + if Nkind (N) = N_Null_Statement then + return; + end if; + + Cunit_Node := Cunit (Current_Sem_Unit); + Cunit_Ent := Cunit_Entity (Current_Sem_Unit); + + if Nkind_In (Unit (Cunit_Node), N_Package_Body, + N_Subprogram_Body) + then + Error_Pragma ("pragma% must refer to a spec, not a body"); + else + Set_Body_Required (Cunit_Node, True); + Set_Has_Pragma_Elaborate_Body (Cunit_Ent); + + -- If we are in dynamic elaboration mode, then we suppress + -- elaboration warnings for the unit, since it is definitely + -- fine NOT to do dynamic checks at the first level (and such + -- checks will be suppressed because no elaboration boolean + -- is created for Elaborate_Body packages). + + -- But in the static model of elaboration, Elaborate_Body is + -- definitely NOT good enough to ensure elaboration safety on + -- its own, since the body may WITH other units that are not + -- safe from an elaboration point of view, so a client must + -- still do an Elaborate_All on such units. + + -- Debug flag -gnatdD restores the old behavior of 3.13, where + -- Elaborate_Body always suppressed elab warnings. + + if Dynamic_Elaboration_Checks or Debug_Flag_DD then + Set_Suppress_Elaboration_Warnings (Cunit_Ent); + end if; + end if; + end Elaborate_Body; + + ------------------------ + -- Elaboration_Checks -- + ------------------------ + + -- pragma Elaboration_Checks (Static | Dynamic); + + when Pragma_Elaboration_Checks => + GNAT_Pragma; + Check_Arg_Count (1); + Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic); + Dynamic_Elaboration_Checks := + (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic); + + --------------- + -- Eliminate -- + --------------- + + -- pragma Eliminate ( + -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT, + -- [,[Entity =>] IDENTIFIER | + -- SELECTED_COMPONENT | + -- STRING_LITERAL] + -- [, OVERLOADING_RESOLUTION]); + + -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE | + -- SOURCE_LOCATION + + -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE | + -- FUNCTION_PROFILE + + -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES + + -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,] + -- Result_Type => result_SUBTYPE_NAME] + + -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME}) + -- SUBTYPE_NAME ::= STRING_LITERAL + + -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE + -- SOURCE_TRACE ::= STRING_LITERAL + + when Pragma_Eliminate => Eliminate : declare + Args : Args_List (1 .. 5); + Names : constant Name_List (1 .. 5) := ( + Name_Unit_Name, + Name_Entity, + Name_Parameter_Types, + Name_Result_Type, + Name_Source_Location); + + Unit_Name : Node_Id renames Args (1); + Entity : Node_Id renames Args (2); + Parameter_Types : Node_Id renames Args (3); + Result_Type : Node_Id renames Args (4); + Source_Location : Node_Id renames Args (5); + + begin + GNAT_Pragma; + Check_Valid_Configuration_Pragma; + Gather_Associations (Names, Args); + + if No (Unit_Name) then + Error_Pragma ("missing Unit_Name argument for pragma%"); + end if; + + if No (Entity) + and then (Present (Parameter_Types) + or else + Present (Result_Type) + or else + Present (Source_Location)) + then + Error_Pragma ("missing Entity argument for pragma%"); + end if; + + if (Present (Parameter_Types) + or else + Present (Result_Type)) + and then + Present (Source_Location) + then + Error_Pragma + ("parameter profile and source location cannot " & + "be used together in pragma%"); + end if; + + Process_Eliminate_Pragma + (N, + Unit_Name, + Entity, + Parameter_Types, + Result_Type, + Source_Location); + end Eliminate; + + ------------ + -- Export -- + ------------ + + -- pragma Export ( + -- [ Convention =>] convention_IDENTIFIER, + -- [ Entity =>] local_NAME + -- [, [External_Name =>] static_string_EXPRESSION ] + -- [, [Link_Name =>] static_string_EXPRESSION ]); + + when Pragma_Export => Export : declare + C : Convention_Id; + Def_Id : Entity_Id; + + pragma Warnings (Off, C); + + begin + Check_Ada_83_Warning; + Check_Arg_Order + ((Name_Convention, + Name_Entity, + Name_External_Name, + Name_Link_Name)); + Check_At_Least_N_Arguments (2); + Check_At_Most_N_Arguments (4); + Process_Convention (C, Def_Id); + + if Ekind (Def_Id) /= E_Constant then + Note_Possible_Modification + (Get_Pragma_Arg (Arg2), Sure => False); + end if; + + Process_Interface_Name (Def_Id, Arg3, Arg4); + Set_Exported (Def_Id, Arg2); + + -- If the entity is a deferred constant, propagate the information + -- to the full view, because gigi elaborates the full view only. + + if Ekind (Def_Id) = E_Constant + and then Present (Full_View (Def_Id)) + then + declare + Id2 : constant Entity_Id := Full_View (Def_Id); + begin + Set_Is_Exported (Id2, Is_Exported (Def_Id)); + Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id)); + Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id)); + end; + end if; + end Export; + + ---------------------- + -- Export_Exception -- + ---------------------- + + -- pragma Export_Exception ( + -- [Internal =>] LOCAL_NAME + -- [, [External =>] EXTERNAL_SYMBOL] + -- [, [Form =>] Ada | VMS] + -- [, [Code =>] static_integer_EXPRESSION]); + + when Pragma_Export_Exception => Export_Exception : declare + Args : Args_List (1 .. 4); + Names : constant Name_List (1 .. 4) := ( + Name_Internal, + Name_External, + Name_Form, + Name_Code); + + Internal : Node_Id renames Args (1); + External : Node_Id renames Args (2); + Form : Node_Id renames Args (3); + Code : Node_Id renames Args (4); + + begin + GNAT_Pragma; + + if Inside_A_Generic then + Error_Pragma ("pragma% cannot be used for generic entities"); + end if; + + Gather_Associations (Names, Args); + Process_Extended_Import_Export_Exception_Pragma ( + Arg_Internal => Internal, + Arg_External => External, + Arg_Form => Form, + Arg_Code => Code); + + if not Is_VMS_Exception (Entity (Internal)) then + Set_Exported (Entity (Internal), Internal); + end if; + end Export_Exception; + + --------------------- + -- Export_Function -- + --------------------- + + -- pragma Export_Function ( + -- [Internal =>] LOCAL_NAME + -- [, [External =>] EXTERNAL_SYMBOL] + -- [, [Parameter_Types =>] (PARAMETER_TYPES)] + -- [, [Result_Type =>] TYPE_DESIGNATOR] + -- [, [Mechanism =>] MECHANISM] + -- [, [Result_Mechanism =>] MECHANISM_NAME]); + + -- EXTERNAL_SYMBOL ::= + -- IDENTIFIER + -- | static_string_EXPRESSION + + -- PARAMETER_TYPES ::= + -- null + -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} + + -- TYPE_DESIGNATOR ::= + -- subtype_NAME + -- | subtype_Name ' Access + + -- MECHANISM ::= + -- MECHANISM_NAME + -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) + + -- MECHANISM_ASSOCIATION ::= + -- [formal_parameter_NAME =>] MECHANISM_NAME + + -- MECHANISM_NAME ::= + -- Value + -- | Reference + -- | Descriptor [([Class =>] CLASS_NAME)] + + -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca + + when Pragma_Export_Function => Export_Function : declare + Args : Args_List (1 .. 6); + Names : constant Name_List (1 .. 6) := ( + Name_Internal, + Name_External, + Name_Parameter_Types, + Name_Result_Type, + Name_Mechanism, + Name_Result_Mechanism); + + Internal : Node_Id renames Args (1); + External : Node_Id renames Args (2); + Parameter_Types : Node_Id renames Args (3); + Result_Type : Node_Id renames Args (4); + Mechanism : Node_Id renames Args (5); + Result_Mechanism : Node_Id renames Args (6); + + begin + GNAT_Pragma; + Gather_Associations (Names, Args); + Process_Extended_Import_Export_Subprogram_Pragma ( + Arg_Internal => Internal, + Arg_External => External, + Arg_Parameter_Types => Parameter_Types, + Arg_Result_Type => Result_Type, + Arg_Mechanism => Mechanism, + Arg_Result_Mechanism => Result_Mechanism); + end Export_Function; + + ------------------- + -- Export_Object -- + ------------------- + + -- pragma Export_Object ( + -- [Internal =>] LOCAL_NAME + -- [, [External =>] EXTERNAL_SYMBOL] + -- [, [Size =>] EXTERNAL_SYMBOL]); + + -- EXTERNAL_SYMBOL ::= + -- IDENTIFIER + -- | static_string_EXPRESSION + + -- PARAMETER_TYPES ::= + -- null + -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} + + -- TYPE_DESIGNATOR ::= + -- subtype_NAME + -- | subtype_Name ' Access + + -- MECHANISM ::= + -- MECHANISM_NAME + -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) + + -- MECHANISM_ASSOCIATION ::= + -- [formal_parameter_NAME =>] MECHANISM_NAME + + -- MECHANISM_NAME ::= + -- Value + -- | Reference + -- | Descriptor [([Class =>] CLASS_NAME)] + + -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca + + when Pragma_Export_Object => Export_Object : declare + Args : Args_List (1 .. 3); + Names : constant Name_List (1 .. 3) := ( + Name_Internal, + Name_External, + Name_Size); + + Internal : Node_Id renames Args (1); + External : Node_Id renames Args (2); + Size : Node_Id renames Args (3); + + begin + GNAT_Pragma; + Gather_Associations (Names, Args); + Process_Extended_Import_Export_Object_Pragma ( + Arg_Internal => Internal, + Arg_External => External, + Arg_Size => Size); + end Export_Object; + + ---------------------- + -- Export_Procedure -- + ---------------------- + + -- pragma Export_Procedure ( + -- [Internal =>] LOCAL_NAME + -- [, [External =>] EXTERNAL_SYMBOL] + -- [, [Parameter_Types =>] (PARAMETER_TYPES)] + -- [, [Mechanism =>] MECHANISM]); + + -- EXTERNAL_SYMBOL ::= + -- IDENTIFIER + -- | static_string_EXPRESSION + + -- PARAMETER_TYPES ::= + -- null + -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} + + -- TYPE_DESIGNATOR ::= + -- subtype_NAME + -- | subtype_Name ' Access + + -- MECHANISM ::= + -- MECHANISM_NAME + -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) + + -- MECHANISM_ASSOCIATION ::= + -- [formal_parameter_NAME =>] MECHANISM_NAME + + -- MECHANISM_NAME ::= + -- Value + -- | Reference + -- | Descriptor [([Class =>] CLASS_NAME)] + + -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca + + when Pragma_Export_Procedure => Export_Procedure : declare + Args : Args_List (1 .. 4); + Names : constant Name_List (1 .. 4) := ( + Name_Internal, + Name_External, + Name_Parameter_Types, + Name_Mechanism); + + Internal : Node_Id renames Args (1); + External : Node_Id renames Args (2); + Parameter_Types : Node_Id renames Args (3); + Mechanism : Node_Id renames Args (4); + + begin + GNAT_Pragma; + Gather_Associations (Names, Args); + Process_Extended_Import_Export_Subprogram_Pragma ( + Arg_Internal => Internal, + Arg_External => External, + Arg_Parameter_Types => Parameter_Types, + Arg_Mechanism => Mechanism); + end Export_Procedure; + + ------------------ + -- Export_Value -- + ------------------ + + -- pragma Export_Value ( + -- [Value =>] static_integer_EXPRESSION, + -- [Link_Name =>] static_string_EXPRESSION); + + when Pragma_Export_Value => + GNAT_Pragma; + Check_Arg_Order ((Name_Value, Name_Link_Name)); + Check_Arg_Count (2); + + Check_Optional_Identifier (Arg1, Name_Value); + Check_Arg_Is_Static_Expression (Arg1, Any_Integer); + + Check_Optional_Identifier (Arg2, Name_Link_Name); + Check_Arg_Is_Static_Expression (Arg2, Standard_String); + + ----------------------------- + -- Export_Valued_Procedure -- + ----------------------------- + + -- pragma Export_Valued_Procedure ( + -- [Internal =>] LOCAL_NAME + -- [, [External =>] EXTERNAL_SYMBOL,] + -- [, [Parameter_Types =>] (PARAMETER_TYPES)] + -- [, [Mechanism =>] MECHANISM]); + + -- EXTERNAL_SYMBOL ::= + -- IDENTIFIER + -- | static_string_EXPRESSION + + -- PARAMETER_TYPES ::= + -- null + -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} + + -- TYPE_DESIGNATOR ::= + -- subtype_NAME + -- | subtype_Name ' Access + + -- MECHANISM ::= + -- MECHANISM_NAME + -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) + + -- MECHANISM_ASSOCIATION ::= + -- [formal_parameter_NAME =>] MECHANISM_NAME + + -- MECHANISM_NAME ::= + -- Value + -- | Reference + -- | Descriptor [([Class =>] CLASS_NAME)] + + -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca + + when Pragma_Export_Valued_Procedure => + Export_Valued_Procedure : declare + Args : Args_List (1 .. 4); + Names : constant Name_List (1 .. 4) := ( + Name_Internal, + Name_External, + Name_Parameter_Types, + Name_Mechanism); + + Internal : Node_Id renames Args (1); + External : Node_Id renames Args (2); + Parameter_Types : Node_Id renames Args (3); + Mechanism : Node_Id renames Args (4); + + begin + GNAT_Pragma; + Gather_Associations (Names, Args); + Process_Extended_Import_Export_Subprogram_Pragma ( + Arg_Internal => Internal, + Arg_External => External, + Arg_Parameter_Types => Parameter_Types, + Arg_Mechanism => Mechanism); + end Export_Valued_Procedure; + + ------------------- + -- Extend_System -- + ------------------- + + -- pragma Extend_System ([Name =>] Identifier); + + when Pragma_Extend_System => Extend_System : declare + begin + GNAT_Pragma; + Check_Valid_Configuration_Pragma; + Check_Arg_Count (1); + Check_Optional_Identifier (Arg1, Name_Name); + Check_Arg_Is_Identifier (Arg1); + + Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); + + if Name_Len > 4 + and then Name_Buffer (1 .. 4) = "aux_" + then + if Present (System_Extend_Pragma_Arg) then + if Chars (Get_Pragma_Arg (Arg1)) = + Chars (Expression (System_Extend_Pragma_Arg)) + then + null; + else + Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg); + Error_Pragma ("pragma% conflicts with that #"); + end if; + + else + System_Extend_Pragma_Arg := Arg1; + + if not GNAT_Mode then + System_Extend_Unit := Arg1; + end if; + end if; + else + Error_Pragma ("incorrect name for pragma%, must be Aux_xxx"); + end if; + end Extend_System; + + ------------------------ + -- Extensions_Allowed -- + ------------------------ + + -- pragma Extensions_Allowed (ON | OFF); + + when Pragma_Extensions_Allowed => + GNAT_Pragma; + Check_Arg_Count (1); + Check_No_Identifiers; + Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); + + if Chars (Get_Pragma_Arg (Arg1)) = Name_On then + Extensions_Allowed := True; + Ada_Version := Ada_Version_Type'Last; + + else + Extensions_Allowed := False; + Ada_Version := Ada_Version_Explicit; + end if; + + -------------- + -- External -- + -------------- + + -- pragma External ( + -- [ Convention =>] convention_IDENTIFIER, + -- [ Entity =>] local_NAME + -- [, [External_Name =>] static_string_EXPRESSION ] + -- [, [Link_Name =>] static_string_EXPRESSION ]); + + when Pragma_External => External : declare + Def_Id : Entity_Id; + + C : Convention_Id; + pragma Warnings (Off, C); + + begin + GNAT_Pragma; + Check_Arg_Order + ((Name_Convention, + Name_Entity, + Name_External_Name, + Name_Link_Name)); + Check_At_Least_N_Arguments (2); + Check_At_Most_N_Arguments (4); + Process_Convention (C, Def_Id); + Note_Possible_Modification + (Get_Pragma_Arg (Arg2), Sure => False); + Process_Interface_Name (Def_Id, Arg3, Arg4); + Set_Exported (Def_Id, Arg2); + end External; + + -------------------------- + -- External_Name_Casing -- + -------------------------- + + -- pragma External_Name_Casing ( + -- UPPERCASE | LOWERCASE + -- [, AS_IS | UPPERCASE | LOWERCASE]); + + when Pragma_External_Name_Casing => External_Name_Casing : declare + begin + GNAT_Pragma; + Check_No_Identifiers; + + if Arg_Count = 2 then + Check_Arg_Is_One_Of + (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase); + + case Chars (Get_Pragma_Arg (Arg2)) is + when Name_As_Is => + Opt.External_Name_Exp_Casing := As_Is; + + when Name_Uppercase => + Opt.External_Name_Exp_Casing := Uppercase; + + when Name_Lowercase => + Opt.External_Name_Exp_Casing := Lowercase; + + when others => + null; + end case; + + else + Check_Arg_Count (1); + end if; + + Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase); + + case Chars (Get_Pragma_Arg (Arg1)) is + when Name_Uppercase => + Opt.External_Name_Imp_Casing := Uppercase; + + when Name_Lowercase => + Opt.External_Name_Imp_Casing := Lowercase; + + when others => + null; + end case; + end External_Name_Casing; + + -------------------------- + -- Favor_Top_Level -- + -------------------------- + + -- pragma Favor_Top_Level (type_NAME); + + when Pragma_Favor_Top_Level => Favor_Top_Level : declare + Named_Entity : Entity_Id; + + begin + GNAT_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + Named_Entity := Entity (Get_Pragma_Arg (Arg1)); + + -- If it's an access-to-subprogram type (in particular, not a + -- subtype), set the flag on that type. + + if Is_Access_Subprogram_Type (Named_Entity) then + if Sense then + Set_Can_Use_Internal_Rep (Named_Entity, False); + end if; + + -- Otherwise it's an error (name denotes the wrong sort of entity) + + else + Error_Pragma_Arg + ("access-to-subprogram type expected", + Get_Pragma_Arg (Arg1)); + end if; + end Favor_Top_Level; + + --------------- + -- Fast_Math -- + --------------- + + -- pragma Fast_Math; + + when Pragma_Fast_Math => + GNAT_Pragma; + Check_No_Identifiers; + Check_Valid_Configuration_Pragma; + Fast_Math := True; + + --------------------------- + -- Finalize_Storage_Only -- + --------------------------- + + -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME); + + when Pragma_Finalize_Storage_Only => Finalize_Storage : declare + Assoc : constant Node_Id := Arg1; + Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc); + Typ : Entity_Id; + + begin + GNAT_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + + Find_Type (Type_Id); + Typ := Entity (Type_Id); + + if Typ = Any_Type + or else Rep_Item_Too_Early (Typ, N) + then + return; + else + Typ := Underlying_Type (Typ); + end if; + + if not Is_Controlled (Typ) then + Error_Pragma ("pragma% must specify controlled type"); + end if; + + Check_First_Subtype (Arg1); + + if Finalize_Storage_Only (Typ) then + Error_Pragma ("duplicate pragma%, only one allowed"); + + elsif not Rep_Item_Too_Late (Typ, N) then + Set_Finalize_Storage_Only (Base_Type (Typ), True); + end if; + end Finalize_Storage; + + -------------------------- + -- Float_Representation -- + -------------------------- + + -- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]); + + -- FLOAT_REP ::= VAX_Float | IEEE_Float + + when Pragma_Float_Representation => Float_Representation : declare + Argx : Node_Id; + Digs : Nat; + Ent : Entity_Id; + + begin + GNAT_Pragma; + + if Arg_Count = 1 then + Check_Valid_Configuration_Pragma; + else + Check_Arg_Count (2); + Check_Optional_Identifier (Arg2, Name_Entity); + Check_Arg_Is_Local_Name (Arg2); + end if; + + Check_No_Identifier (Arg1); + Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float); + + if not OpenVMS_On_Target then + if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then + Error_Pragma + ("?pragma% ignored (applies only to Open'V'M'S)"); + end if; + + return; + end if; + + -- One argument case + + if Arg_Count = 1 then + if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then + if Opt.Float_Format = 'I' then + Error_Pragma ("'I'E'E'E format previously specified"); + end if; + + Opt.Float_Format := 'V'; + + else + if Opt.Float_Format = 'V' then + Error_Pragma ("'V'A'X format previously specified"); + end if; + + Opt.Float_Format := 'I'; + end if; + + Set_Standard_Fpt_Formats; + + -- Two argument case + + else + Argx := Get_Pragma_Arg (Arg2); + + if not Is_Entity_Name (Argx) + or else not Is_Floating_Point_Type (Entity (Argx)) + then + Error_Pragma_Arg + ("second argument of% pragma must be floating-point type", + Arg2); + end if; + + Ent := Entity (Argx); + Digs := UI_To_Int (Digits_Value (Ent)); + + -- Two arguments, VAX_Float case + + if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then + case Digs is + when 6 => Set_F_Float (Ent); + when 9 => Set_D_Float (Ent); + when 15 => Set_G_Float (Ent); + + when others => + Error_Pragma_Arg + ("wrong digits value, must be 6,9 or 15", Arg2); + end case; + + -- Two arguments, IEEE_Float case + + else + case Digs is + when 6 => Set_IEEE_Short (Ent); + when 15 => Set_IEEE_Long (Ent); + + when others => + Error_Pragma_Arg + ("wrong digits value, must be 6 or 15", Arg2); + end case; + end if; + end if; + end Float_Representation; + + ----------- + -- Ident -- + ----------- + + -- pragma Ident (static_string_EXPRESSION) + + -- Note: pragma Comment shares this processing. Pragma Comment is + -- identical to Ident, except that the restriction of the argument to + -- 31 characters and the placement restrictions are not enforced for + -- pragma Comment. + + when Pragma_Ident | Pragma_Comment => Ident : declare + Str : Node_Id; + + begin + GNAT_Pragma; + Check_Arg_Count (1); + Check_No_Identifiers; + Check_Arg_Is_Static_Expression (Arg1, Standard_String); + Store_Note (N); + + -- For pragma Ident, preserve DEC compatibility by requiring the + -- pragma to appear in a declarative part or package spec. + + if Prag_Id = Pragma_Ident then + Check_Is_In_Decl_Part_Or_Package_Spec; + end if; + + Str := Expr_Value_S (Get_Pragma_Arg (Arg1)); + + declare + CS : Node_Id; + GP : Node_Id; + + begin + GP := Parent (Parent (N)); + + if Nkind_In (GP, N_Package_Declaration, + N_Generic_Package_Declaration) + then + GP := Parent (GP); + end if; + + -- If we have a compilation unit, then record the ident value, + -- checking for improper duplication. + + if Nkind (GP) = N_Compilation_Unit then + CS := Ident_String (Current_Sem_Unit); + + if Present (CS) then + + -- For Ident, we do not permit multiple instances + + if Prag_Id = Pragma_Ident then + Error_Pragma ("duplicate% pragma not permitted"); + + -- For Comment, we concatenate the string, unless we want + -- to preserve the tree structure for ASIS. + + elsif not ASIS_Mode then + Start_String (Strval (CS)); + Store_String_Char (' '); + Store_String_Chars (Strval (Str)); + Set_Strval (CS, End_String); + end if; + + else + -- In VMS, the effect of IDENT is achieved by passing + -- --identification=name as a --for-linker switch. + + if OpenVMS_On_Target then + Start_String; + Store_String_Chars + ("--for-linker=--identification="); + String_To_Name_Buffer (Strval (Str)); + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + + -- Only the last processed IDENT is saved. The main + -- purpose is so an IDENT associated with a main + -- procedure will be used in preference to an IDENT + -- associated with a with'd package. + + Replace_Linker_Option_String + (End_String, "--for-linker=--identification="); + end if; + + Set_Ident_String (Current_Sem_Unit, Str); + end if; + + -- For subunits, we just ignore the Ident, since in GNAT these + -- are not separate object files, and hence not separate units + -- in the unit table. + + elsif Nkind (GP) = N_Subunit then + null; + + -- Otherwise we have a misplaced pragma Ident, but we ignore + -- this if we are in an instantiation, since it comes from + -- a generic, and has no relevance to the instantiation. + + elsif Prag_Id = Pragma_Ident then + if Instantiation_Location (Loc) = No_Location then + Error_Pragma ("pragma% only allowed at outer level"); + end if; + end if; + end; + end Ident; + + ----------------- + -- Implemented -- + ----------------- + + -- pragma Implemented (procedure_LOCAL_NAME, implementation_kind); + -- implementation_kind ::= By_Entry | By_Protected_Procedure | By_Any + + when Pragma_Implemented => Implemented : declare + Proc_Id : Entity_Id; + Typ : Entity_Id; + + begin + Ada_2012_Pragma; + Check_Arg_Count (2); + Check_No_Identifiers; + Check_Arg_Is_Identifier (Arg1); + Check_Arg_Is_Local_Name (Arg1); + Check_Arg_Is_One_Of + (Arg2, Name_By_Any, Name_By_Entry, Name_By_Protected_Procedure); + + -- Extract the name of the local procedure + + Proc_Id := Entity (Get_Pragma_Arg (Arg1)); + + -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a + -- primitive procedure of a synchronized tagged type. + + if Ekind (Proc_Id) = E_Procedure + and then Is_Primitive (Proc_Id) + and then Present (First_Formal (Proc_Id)) + then + Typ := Etype (First_Formal (Proc_Id)); + + if Is_Tagged_Type (Typ) + and then + + -- Check for a protected, a synchronized or a task interface + + ((Is_Interface (Typ) + and then Is_Synchronized_Interface (Typ)) + + -- Check for a protected type or a task type that implements + -- an interface. + + or else + (Is_Concurrent_Record_Type (Typ) + and then Present (Interfaces (Typ))) + + -- Check for a private record extension with keyword + -- "synchronized". + + or else + (Ekind_In (Typ, E_Record_Type_With_Private, + E_Record_Subtype_With_Private) + and then Synchronized_Present (Parent (Typ)))) + then + null; + else + Error_Pragma_Arg + ("controlling formal must be of synchronized " & + "tagged type", Arg1); + return; + end if; + + -- Procedures declared inside a protected type must be accepted + + elsif Ekind (Proc_Id) = E_Procedure + and then Is_Protected_Type (Scope (Proc_Id)) + then + null; + + -- The first argument is not a primitive procedure + + else + Error_Pragma_Arg + ("pragma % must be applied to a primitive procedure", Arg1); + return; + end if; + + -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind + -- By_Protected_Procedure to the primitive procedure of a task + -- interface. + + if Chars (Arg2) = Name_By_Protected_Procedure + and then Is_Interface (Typ) + and then Is_Task_Interface (Typ) + then + Error_Pragma_Arg + ("implementation kind By_Protected_Procedure cannot be " & + "applied to a task interface primitive", Arg2); + return; + end if; + + Record_Rep_Item (Proc_Id, N); + end Implemented; + + ---------------------- + -- Implicit_Packing -- + ---------------------- + + -- pragma Implicit_Packing; + + when Pragma_Implicit_Packing => + GNAT_Pragma; + Check_Arg_Count (0); + Implicit_Packing := True; + + ------------ + -- Import -- + ------------ + + -- pragma Import ( + -- [Convention =>] convention_IDENTIFIER, + -- [Entity =>] local_NAME + -- [, [External_Name =>] static_string_EXPRESSION ] + -- [, [Link_Name =>] static_string_EXPRESSION ]); + + when Pragma_Import => + Check_Ada_83_Warning; + Check_Arg_Order + ((Name_Convention, + Name_Entity, + Name_External_Name, + Name_Link_Name)); + Check_At_Least_N_Arguments (2); + Check_At_Most_N_Arguments (4); + Process_Import_Or_Interface; + + ---------------------- + -- Import_Exception -- + ---------------------- + + -- pragma Import_Exception ( + -- [Internal =>] LOCAL_NAME + -- [, [External =>] EXTERNAL_SYMBOL] + -- [, [Form =>] Ada | VMS] + -- [, [Code =>] static_integer_EXPRESSION]); + + when Pragma_Import_Exception => Import_Exception : declare + Args : Args_List (1 .. 4); + Names : constant Name_List (1 .. 4) := ( + Name_Internal, + Name_External, + Name_Form, + Name_Code); + + Internal : Node_Id renames Args (1); + External : Node_Id renames Args (2); + Form : Node_Id renames Args (3); + Code : Node_Id renames Args (4); + + begin + GNAT_Pragma; + Gather_Associations (Names, Args); + + if Present (External) and then Present (Code) then + Error_Pragma + ("cannot give both External and Code options for pragma%"); + end if; + + Process_Extended_Import_Export_Exception_Pragma ( + Arg_Internal => Internal, + Arg_External => External, + Arg_Form => Form, + Arg_Code => Code); + + if not Is_VMS_Exception (Entity (Internal)) then + Set_Imported (Entity (Internal)); + end if; + end Import_Exception; + + --------------------- + -- Import_Function -- + --------------------- + + -- pragma Import_Function ( + -- [Internal =>] LOCAL_NAME, + -- [, [External =>] EXTERNAL_SYMBOL] + -- [, [Parameter_Types =>] (PARAMETER_TYPES)] + -- [, [Result_Type =>] SUBTYPE_MARK] + -- [, [Mechanism =>] MECHANISM] + -- [, [Result_Mechanism =>] MECHANISM_NAME] + -- [, [First_Optional_Parameter =>] IDENTIFIER]); + + -- EXTERNAL_SYMBOL ::= + -- IDENTIFIER + -- | static_string_EXPRESSION + + -- PARAMETER_TYPES ::= + -- null + -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} + + -- TYPE_DESIGNATOR ::= + -- subtype_NAME + -- | subtype_Name ' Access + + -- MECHANISM ::= + -- MECHANISM_NAME + -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) + + -- MECHANISM_ASSOCIATION ::= + -- [formal_parameter_NAME =>] MECHANISM_NAME + + -- MECHANISM_NAME ::= + -- Value + -- | Reference + -- | Descriptor [([Class =>] CLASS_NAME)] + + -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca + + when Pragma_Import_Function => Import_Function : declare + Args : Args_List (1 .. 7); + Names : constant Name_List (1 .. 7) := ( + Name_Internal, + Name_External, + Name_Parameter_Types, + Name_Result_Type, + Name_Mechanism, + Name_Result_Mechanism, + Name_First_Optional_Parameter); + + Internal : Node_Id renames Args (1); + External : Node_Id renames Args (2); + Parameter_Types : Node_Id renames Args (3); + Result_Type : Node_Id renames Args (4); + Mechanism : Node_Id renames Args (5); + Result_Mechanism : Node_Id renames Args (6); + First_Optional_Parameter : Node_Id renames Args (7); + + begin + GNAT_Pragma; + Gather_Associations (Names, Args); + Process_Extended_Import_Export_Subprogram_Pragma ( + Arg_Internal => Internal, + Arg_External => External, + Arg_Parameter_Types => Parameter_Types, + Arg_Result_Type => Result_Type, + Arg_Mechanism => Mechanism, + Arg_Result_Mechanism => Result_Mechanism, + Arg_First_Optional_Parameter => First_Optional_Parameter); + end Import_Function; + + ------------------- + -- Import_Object -- + ------------------- + + -- pragma Import_Object ( + -- [Internal =>] LOCAL_NAME + -- [, [External =>] EXTERNAL_SYMBOL] + -- [, [Size =>] EXTERNAL_SYMBOL]); + + -- EXTERNAL_SYMBOL ::= + -- IDENTIFIER + -- | static_string_EXPRESSION + + when Pragma_Import_Object => Import_Object : declare + Args : Args_List (1 .. 3); + Names : constant Name_List (1 .. 3) := ( + Name_Internal, + Name_External, + Name_Size); + + Internal : Node_Id renames Args (1); + External : Node_Id renames Args (2); + Size : Node_Id renames Args (3); + + begin + GNAT_Pragma; + Gather_Associations (Names, Args); + Process_Extended_Import_Export_Object_Pragma ( + Arg_Internal => Internal, + Arg_External => External, + Arg_Size => Size); + end Import_Object; + + ---------------------- + -- Import_Procedure -- + ---------------------- + + -- pragma Import_Procedure ( + -- [Internal =>] LOCAL_NAME + -- [, [External =>] EXTERNAL_SYMBOL] + -- [, [Parameter_Types =>] (PARAMETER_TYPES)] + -- [, [Mechanism =>] MECHANISM] + -- [, [First_Optional_Parameter =>] IDENTIFIER]); + + -- EXTERNAL_SYMBOL ::= + -- IDENTIFIER + -- | static_string_EXPRESSION + + -- PARAMETER_TYPES ::= + -- null + -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} + + -- TYPE_DESIGNATOR ::= + -- subtype_NAME + -- | subtype_Name ' Access + + -- MECHANISM ::= + -- MECHANISM_NAME + -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) + + -- MECHANISM_ASSOCIATION ::= + -- [formal_parameter_NAME =>] MECHANISM_NAME + + -- MECHANISM_NAME ::= + -- Value + -- | Reference + -- | Descriptor [([Class =>] CLASS_NAME)] + + -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca + + when Pragma_Import_Procedure => Import_Procedure : declare + Args : Args_List (1 .. 5); + Names : constant Name_List (1 .. 5) := ( + Name_Internal, + Name_External, + Name_Parameter_Types, + Name_Mechanism, + Name_First_Optional_Parameter); + + Internal : Node_Id renames Args (1); + External : Node_Id renames Args (2); + Parameter_Types : Node_Id renames Args (3); + Mechanism : Node_Id renames Args (4); + First_Optional_Parameter : Node_Id renames Args (5); + + begin + GNAT_Pragma; + Gather_Associations (Names, Args); + Process_Extended_Import_Export_Subprogram_Pragma ( + Arg_Internal => Internal, + Arg_External => External, + Arg_Parameter_Types => Parameter_Types, + Arg_Mechanism => Mechanism, + Arg_First_Optional_Parameter => First_Optional_Parameter); + end Import_Procedure; + + ----------------------------- + -- Import_Valued_Procedure -- + ----------------------------- + + -- pragma Import_Valued_Procedure ( + -- [Internal =>] LOCAL_NAME + -- [, [External =>] EXTERNAL_SYMBOL] + -- [, [Parameter_Types =>] (PARAMETER_TYPES)] + -- [, [Mechanism =>] MECHANISM] + -- [, [First_Optional_Parameter =>] IDENTIFIER]); + + -- EXTERNAL_SYMBOL ::= + -- IDENTIFIER + -- | static_string_EXPRESSION + + -- PARAMETER_TYPES ::= + -- null + -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} + + -- TYPE_DESIGNATOR ::= + -- subtype_NAME + -- | subtype_Name ' Access + + -- MECHANISM ::= + -- MECHANISM_NAME + -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) + + -- MECHANISM_ASSOCIATION ::= + -- [formal_parameter_NAME =>] MECHANISM_NAME + + -- MECHANISM_NAME ::= + -- Value + -- | Reference + -- | Descriptor [([Class =>] CLASS_NAME)] + + -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca + + when Pragma_Import_Valued_Procedure => + Import_Valued_Procedure : declare + Args : Args_List (1 .. 5); + Names : constant Name_List (1 .. 5) := ( + Name_Internal, + Name_External, + Name_Parameter_Types, + Name_Mechanism, + Name_First_Optional_Parameter); + + Internal : Node_Id renames Args (1); + External : Node_Id renames Args (2); + Parameter_Types : Node_Id renames Args (3); + Mechanism : Node_Id renames Args (4); + First_Optional_Parameter : Node_Id renames Args (5); + + begin + GNAT_Pragma; + Gather_Associations (Names, Args); + Process_Extended_Import_Export_Subprogram_Pragma ( + Arg_Internal => Internal, + Arg_External => External, + Arg_Parameter_Types => Parameter_Types, + Arg_Mechanism => Mechanism, + Arg_First_Optional_Parameter => First_Optional_Parameter); + end Import_Valued_Procedure; + + ----------------- + -- Independent -- + ----------------- + + -- pragma Independent (LOCAL_NAME); + + when Pragma_Independent => Independent : declare + E_Id : Node_Id; + E : Entity_Id; + D : Node_Id; + K : Node_Kind; + + begin + Check_Ada_83_Warning; + Ada_2012_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + E_Id := Get_Pragma_Arg (Arg1); + + if Etype (E_Id) = Any_Type then + return; + end if; + + E := Entity (E_Id); + D := Declaration_Node (E); + K := Nkind (D); + + -- Check duplicate before we chain ourselves! + + Check_Duplicate_Pragma (E); + + -- Check appropriate entity + + if Is_Type (E) then + if Rep_Item_Too_Early (E, N) + or else + Rep_Item_Too_Late (E, N) + then + return; + else + Check_First_Subtype (Arg1); + end if; + + elsif K = N_Object_Declaration + or else (K = N_Component_Declaration + and then Original_Record_Component (E) = E) + then + if Rep_Item_Too_Late (E, N) then + return; + end if; + + else + Error_Pragma_Arg + ("inappropriate entity for pragma%", Arg1); + end if; + + Independence_Checks.Append ((N, E)); + end Independent; + + ---------------------------- + -- Independent_Components -- + ---------------------------- + + -- pragma Atomic_Components (array_LOCAL_NAME); + + -- This processing is shared by Volatile_Components + + when Pragma_Independent_Components => Independent_Components : declare + E_Id : Node_Id; + E : Entity_Id; + D : Node_Id; + K : Node_Kind; + + begin + Check_Ada_83_Warning; + Ada_2012_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + E_Id := Get_Pragma_Arg (Arg1); + + if Etype (E_Id) = Any_Type then + return; + end if; + + E := Entity (E_Id); + + -- Check duplicate before we chain ourselves! + + Check_Duplicate_Pragma (E); + + -- Check appropriate entity + + if Rep_Item_Too_Early (E, N) + or else + Rep_Item_Too_Late (E, N) + then + return; + end if; + + D := Declaration_Node (E); + K := Nkind (D); + + if (K = N_Full_Type_Declaration + and then (Is_Array_Type (E) or else Is_Record_Type (E))) + or else + ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable) + and then Nkind (D) = N_Object_Declaration + and then Nkind (Object_Definition (D)) = + N_Constrained_Array_Definition) + then + Independence_Checks.Append ((N, E)); + + else + Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); + end if; + end Independent_Components; + + ------------------------ + -- Initialize_Scalars -- + ------------------------ + + -- pragma Initialize_Scalars; + + when Pragma_Initialize_Scalars => + GNAT_Pragma; + Check_Arg_Count (0); + Check_Valid_Configuration_Pragma; + Check_Restriction (No_Initialize_Scalars, N); + + -- Initialize_Scalars creates false positives in CodePeer, + -- so ignore this pragma in this mode. + + if not Restriction_Active (No_Initialize_Scalars) + and then not CodePeer_Mode + then + Init_Or_Norm_Scalars := True; + Initialize_Scalars := True; + end if; + + ------------ + -- Inline -- + ------------ + + -- pragma Inline ( NAME {, NAME} ); + + when Pragma_Inline => + + -- Pragma is active if inlining option is active + + Process_Inline (Inline_Active); + + ------------------- + -- Inline_Always -- + ------------------- + + -- pragma Inline_Always ( NAME {, NAME} ); + + when Pragma_Inline_Always => + GNAT_Pragma; + + -- Pragma always active unless in CodePeer mode, since this causes + -- walk order issues. + + if not CodePeer_Mode then + Process_Inline (True); + end if; + + -------------------- + -- Inline_Generic -- + -------------------- + + -- pragma Inline_Generic (NAME {, NAME}); + + when Pragma_Inline_Generic => + GNAT_Pragma; + Process_Generic_List; + + ---------------------- + -- Inspection_Point -- + ---------------------- + + -- pragma Inspection_Point [(object_NAME {, object_NAME})]; + + when Pragma_Inspection_Point => Inspection_Point : declare + Arg : Node_Id; + Exp : Node_Id; + + begin + if Arg_Count > 0 then + Arg := Arg1; + loop + Exp := Get_Pragma_Arg (Arg); + Analyze (Exp); + + if not Is_Entity_Name (Exp) + or else not Is_Object (Entity (Exp)) + then + Error_Pragma_Arg ("object name required", Arg); + end if; + + Next (Arg); + exit when No (Arg); + end loop; + end if; + end Inspection_Point; + + --------------- + -- Interface -- + --------------- + + -- pragma Interface ( + -- [ Convention =>] convention_IDENTIFIER, + -- [ Entity =>] local_NAME + -- [, [External_Name =>] static_string_EXPRESSION ] + -- [, [Link_Name =>] static_string_EXPRESSION ]); + + when Pragma_Interface => + GNAT_Pragma; + Check_Arg_Order + ((Name_Convention, + Name_Entity, + Name_External_Name, + Name_Link_Name)); + Check_At_Least_N_Arguments (2); + Check_At_Most_N_Arguments (4); + Process_Import_Or_Interface; + + -- In Ada 2005, the permission to use Interface (a reserved word) + -- as a pragma name is considered an obsolescent feature. + + if Ada_Version >= Ada_2005 then + Check_Restriction + (No_Obsolescent_Features, Pragma_Identifier (N)); + end if; + + -------------------- + -- Interface_Name -- + -------------------- + + -- pragma Interface_Name ( + -- [ Entity =>] local_NAME + -- [,[External_Name =>] static_string_EXPRESSION ] + -- [,[Link_Name =>] static_string_EXPRESSION ]); + + when Pragma_Interface_Name => Interface_Name : declare + Id : Node_Id; + Def_Id : Entity_Id; + Hom_Id : Entity_Id; + Found : Boolean; + + begin + GNAT_Pragma; + Check_Arg_Order + ((Name_Entity, Name_External_Name, Name_Link_Name)); + Check_At_Least_N_Arguments (2); + Check_At_Most_N_Arguments (3); + Id := Get_Pragma_Arg (Arg1); + Analyze (Id); + + if not Is_Entity_Name (Id) then + Error_Pragma_Arg + ("first argument for pragma% must be entity name", Arg1); + elsif Etype (Id) = Any_Type then + return; + else + Def_Id := Entity (Id); + end if; + + -- Special DEC-compatible processing for the object case, forces + -- object to be imported. + + if Ekind (Def_Id) = E_Variable then + Kill_Size_Check_Code (Def_Id); + Note_Possible_Modification (Id, Sure => False); + + -- Initialization is not allowed for imported variable + + if Present (Expression (Parent (Def_Id))) + and then Comes_From_Source (Expression (Parent (Def_Id))) + then + Error_Msg_Sloc := Sloc (Def_Id); + Error_Pragma_Arg + ("no initialization allowed for declaration of& #", + Arg2); + + else + -- For compatibility, support VADS usage of providing both + -- pragmas Interface and Interface_Name to obtain the effect + -- of a single Import pragma. + + if Is_Imported (Def_Id) + and then Present (First_Rep_Item (Def_Id)) + and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma + and then + Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface + then + null; + else + Set_Imported (Def_Id); + end if; + + Set_Is_Public (Def_Id); + Process_Interface_Name (Def_Id, Arg2, Arg3); + end if; + + -- Otherwise must be subprogram + + elsif not Is_Subprogram (Def_Id) then + Error_Pragma_Arg + ("argument of pragma% is not subprogram", Arg1); + + else + Check_At_Most_N_Arguments (3); + Hom_Id := Def_Id; + Found := False; + + -- Loop through homonyms + + loop + Def_Id := Get_Base_Subprogram (Hom_Id); + + if Is_Imported (Def_Id) then + Process_Interface_Name (Def_Id, Arg2, Arg3); + Found := True; + end if; + + exit when From_Aspect_Specification (N); + Hom_Id := Homonym (Hom_Id); + + exit when No (Hom_Id) + or else Scope (Hom_Id) /= Current_Scope; + end loop; + + if not Found then + Error_Pragma_Arg + ("argument of pragma% is not imported subprogram", + Arg1); + end if; + end if; + end Interface_Name; + + ----------------------- + -- Interrupt_Handler -- + ----------------------- + + -- pragma Interrupt_Handler (handler_NAME); + + when Pragma_Interrupt_Handler => + Check_Ada_83_Warning; + Check_Arg_Count (1); + Check_No_Identifiers; + + if No_Run_Time_Mode then + Error_Msg_CRT ("Interrupt_Handler pragma", N); + else + Check_Interrupt_Or_Attach_Handler; + Process_Interrupt_Or_Attach_Handler; + end if; + + ------------------------ + -- Interrupt_Priority -- + ------------------------ + + -- pragma Interrupt_Priority [(EXPRESSION)]; + + when Pragma_Interrupt_Priority => Interrupt_Priority : declare + P : constant Node_Id := Parent (N); + Arg : Node_Id; + + begin + Check_Ada_83_Warning; + + if Arg_Count /= 0 then + Arg := Get_Pragma_Arg (Arg1); + Check_Arg_Count (1); + Check_No_Identifiers; + + -- The expression must be analyzed in the special manner + -- described in "Handling of Default and Per-Object + -- Expressions" in sem.ads. + + Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority)); + end if; + + if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then + Pragma_Misplaced; + return; + + elsif Has_Pragma_Priority (P) then + Error_Pragma ("duplicate pragma% not allowed"); + + else + Set_Has_Pragma_Priority (P, True); + Record_Rep_Item (Defining_Identifier (Parent (P)), N); + end if; + end Interrupt_Priority; + + --------------------- + -- Interrupt_State -- + --------------------- + + -- pragma Interrupt_State ( + -- [Name =>] INTERRUPT_ID, + -- [State =>] INTERRUPT_STATE); + + -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION + -- INTERRUPT_STATE => System | Runtime | User + + -- Note: if the interrupt id is given as an identifier, then it must + -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is + -- given as a static integer expression which must be in the range of + -- Ada.Interrupts.Interrupt_ID. + + when Pragma_Interrupt_State => Interrupt_State : declare + + Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID); + -- This is the entity Ada.Interrupts.Interrupt_ID; + + State_Type : Character; + -- Set to 's'/'r'/'u' for System/Runtime/User + + IST_Num : Pos; + -- Index to entry in Interrupt_States table + + Int_Val : Uint; + -- Value of interrupt + + Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1); + -- The first argument to the pragma + + Int_Ent : Entity_Id; + -- Interrupt entity in Ada.Interrupts.Names + + begin + GNAT_Pragma; + Check_Arg_Order ((Name_Name, Name_State)); + Check_Arg_Count (2); + + Check_Optional_Identifier (Arg1, Name_Name); + Check_Optional_Identifier (Arg2, Name_State); + Check_Arg_Is_Identifier (Arg2); + + -- First argument is identifier + + if Nkind (Arg1X) = N_Identifier then + + -- Search list of names in Ada.Interrupts.Names + + Int_Ent := First_Entity (RTE (RE_Names)); + loop + if No (Int_Ent) then + Error_Pragma_Arg ("invalid interrupt name", Arg1); + + elsif Chars (Int_Ent) = Chars (Arg1X) then + Int_Val := Expr_Value (Constant_Value (Int_Ent)); + exit; + end if; + + Next_Entity (Int_Ent); + end loop; + + -- First argument is not an identifier, so it must be a static + -- expression of type Ada.Interrupts.Interrupt_ID. + + else + Check_Arg_Is_Static_Expression (Arg1, Any_Integer); + Int_Val := Expr_Value (Arg1X); + + if Int_Val < Expr_Value (Type_Low_Bound (Int_Id)) + or else + Int_Val > Expr_Value (Type_High_Bound (Int_Id)) + then + Error_Pragma_Arg + ("value not in range of type " & + """Ada.Interrupts.Interrupt_'I'D""", Arg1); + end if; + end if; + + -- Check OK state + + case Chars (Get_Pragma_Arg (Arg2)) is + when Name_Runtime => State_Type := 'r'; + when Name_System => State_Type := 's'; + when Name_User => State_Type := 'u'; + + when others => + Error_Pragma_Arg ("invalid interrupt state", Arg2); + end case; + + -- Check if entry is already stored + + IST_Num := Interrupt_States.First; + loop + -- If entry not found, add it + + if IST_Num > Interrupt_States.Last then + Interrupt_States.Append + ((Interrupt_Number => UI_To_Int (Int_Val), + Interrupt_State => State_Type, + Pragma_Loc => Loc)); + exit; + + -- Case of entry for the same entry + + elsif Int_Val = Interrupt_States.Table (IST_Num). + Interrupt_Number + then + -- If state matches, done, no need to make redundant entry + + exit when + State_Type = Interrupt_States.Table (IST_Num). + Interrupt_State; + + -- Otherwise if state does not match, error + + Error_Msg_Sloc := + Interrupt_States.Table (IST_Num).Pragma_Loc; + Error_Pragma_Arg + ("state conflicts with that given #", Arg2); + exit; + end if; + + IST_Num := IST_Num + 1; + end loop; + end Interrupt_State; + + --------------- + -- Invariant -- + --------------- + + -- pragma Invariant + -- ([Entity =>] type_LOCAL_NAME, + -- [Check =>] EXPRESSION + -- [,[Message =>] String_Expression]); + + when Pragma_Invariant => Invariant : declare + Type_Id : Node_Id; + Typ : Entity_Id; + + Discard : Boolean; + pragma Unreferenced (Discard); + + begin + GNAT_Pragma; + Check_At_Least_N_Arguments (2); + Check_At_Most_N_Arguments (3); + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Optional_Identifier (Arg2, Name_Check); + + if Arg_Count = 3 then + Check_Optional_Identifier (Arg3, Name_Message); + Check_Arg_Is_Static_Expression (Arg3, Standard_String); + end if; + + Check_Arg_Is_Local_Name (Arg1); + + Type_Id := Get_Pragma_Arg (Arg1); + Find_Type (Type_Id); + Typ := Entity (Type_Id); + + if Typ = Any_Type then + return; + + elsif not Ekind_In (Typ, E_Private_Type, + E_Record_Type_With_Private, + E_Limited_Private_Type) + then + Error_Pragma_Arg + ("pragma% only allowed for private type", Arg1); + end if; + + -- Note that the type has at least one invariant, and also that + -- it has inheritable invariants if we have Invariant'Class. + + Set_Has_Invariants (Typ); + + if Class_Present (N) then + Set_Has_Inheritable_Invariants (Typ); + end if; + + -- The remaining processing is simply to link the pragma on to + -- the rep item chain, for processing when the type is frozen. + -- This is accomplished by a call to Rep_Item_Too_Late. + + Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); + end Invariant; + + ---------------------- + -- Java_Constructor -- + ---------------------- + + -- pragma Java_Constructor ([Entity =>] LOCAL_NAME); + + -- Also handles pragma CIL_Constructor + + when Pragma_CIL_Constructor | Pragma_Java_Constructor => + Java_Constructor : declare + Convention : Convention_Id; + Def_Id : Entity_Id; + Hom_Id : Entity_Id; + Id : Entity_Id; + This_Formal : Entity_Id; + + begin + GNAT_Pragma; + Check_Arg_Count (1); + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Arg_Is_Local_Name (Arg1); + + Id := Get_Pragma_Arg (Arg1); + Find_Program_Unit_Name (Id); + + -- If we did not find the name, we are done + + if Etype (Id) = Any_Type then + return; + end if; + + -- Check wrong use of pragma in wrong VM target + + if VM_Target = No_VM then + return; + + elsif VM_Target = CLI_Target + and then Prag_Id = Pragma_Java_Constructor + then + Error_Pragma ("must use pragma 'C'I'L_'Constructor"); + + elsif VM_Target = JVM_Target + and then Prag_Id = Pragma_CIL_Constructor + then + Error_Pragma ("must use pragma 'Java_'Constructor"); + end if; + + case Prag_Id is + when Pragma_CIL_Constructor => Convention := Convention_CIL; + when Pragma_Java_Constructor => Convention := Convention_Java; + when others => null; + end case; + + Hom_Id := Entity (Id); + + -- Loop through homonyms + + loop + Def_Id := Get_Base_Subprogram (Hom_Id); + + -- The constructor is required to be a function + + if Ekind (Def_Id) /= E_Function then + if VM_Target = JVM_Target then + Error_Pragma_Arg + ("pragma% requires function returning a " & + "'Java access type", Def_Id); + else + Error_Pragma_Arg + ("pragma% requires function returning a " & + "'C'I'L access type", Def_Id); + end if; + end if; + + -- Check arguments: For tagged type the first formal must be + -- named "this" and its type must be a named access type + -- designating a class-wide tagged type that has convention + -- CIL/Java. The first formal must also have a null default + -- value. For example: + + -- type Typ is tagged ... + -- type Ref is access all Typ; + -- pragma Convention (CIL, Typ); + + -- function New_Typ (This : Ref) return Ref; + -- function New_Typ (This : Ref; I : Integer) return Ref; + -- pragma Cil_Constructor (New_Typ); + + -- Reason: The first formal must NOT be a primitive of the + -- tagged type. + + -- This rule also applies to constructors of delegates used + -- to interface with standard target libraries. For example: + + -- type Delegate is access procedure ... + -- pragma Import (CIL, Delegate, ...); + + -- function new_Delegate + -- (This : Delegate := null; ... ) return Delegate; + + -- For value-types this rule does not apply. + + if not Is_Value_Type (Etype (Def_Id)) then + if No (First_Formal (Def_Id)) then + Error_Msg_Name_1 := Pname; + Error_Msg_N ("% function must have parameters", Def_Id); + return; + end if; + + -- In the JRE library we have several occurrences in which + -- the "this" parameter is not the first formal. + + This_Formal := First_Formal (Def_Id); + + -- In the JRE library we have several occurrences in which + -- the "this" parameter is not the first formal. Search for + -- it. + + if VM_Target = JVM_Target then + while Present (This_Formal) + and then Get_Name_String (Chars (This_Formal)) /= "this" + loop + Next_Formal (This_Formal); + end loop; + + if No (This_Formal) then + This_Formal := First_Formal (Def_Id); + end if; + end if; + + -- Warning: The first parameter should be named "this". + -- We temporarily allow it because we have the following + -- case in the Java runtime (file s-osinte.ads) ??? + + -- function new_Thread + -- (Self_Id : System.Address) return Thread_Id; + -- pragma Java_Constructor (new_Thread); + + if VM_Target = JVM_Target + and then Get_Name_String (Chars (First_Formal (Def_Id))) + = "self_id" + and then Etype (First_Formal (Def_Id)) = RTE (RE_Address) + then + null; + + elsif Get_Name_String (Chars (This_Formal)) /= "this" then + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("first formal of % function must be named `this`", + Parent (This_Formal)); + + elsif not Is_Access_Type (Etype (This_Formal)) then + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("first formal of % function must be an access type", + Parameter_Type (Parent (This_Formal))); + + -- For delegates the type of the first formal must be a + -- named access-to-subprogram type (see previous example) + + elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type + and then Ekind (Etype (This_Formal)) + /= E_Access_Subprogram_Type + then + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("first formal of % function must be a named access" & + " to subprogram type", + Parameter_Type (Parent (This_Formal))); + + -- Warning: We should reject anonymous access types because + -- the constructor must not be handled as a primitive of the + -- tagged type. We temporarily allow it because this profile + -- is currently generated by cil2ada??? + + elsif Ekind (Etype (Def_Id)) /= E_Access_Subprogram_Type + and then not Ekind_In (Etype (This_Formal), + E_Access_Type, + E_General_Access_Type, + E_Anonymous_Access_Type) + then + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("first formal of % function must be a named access" & + " type", + Parameter_Type (Parent (This_Formal))); + + elsif Atree.Convention + (Designated_Type (Etype (This_Formal))) /= Convention + then + Error_Msg_Name_1 := Pname; + + if Convention = Convention_Java then + Error_Msg_N + ("pragma% requires convention 'Cil in designated" & + " type", + Parameter_Type (Parent (This_Formal))); + else + Error_Msg_N + ("pragma% requires convention 'Java in designated" & + " type", + Parameter_Type (Parent (This_Formal))); + end if; + + elsif No (Expression (Parent (This_Formal))) + or else Nkind (Expression (Parent (This_Formal))) /= N_Null + then + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("pragma% requires first formal with default `null`", + Parameter_Type (Parent (This_Formal))); + end if; + end if; + + -- Check result type: the constructor must be a function + -- returning: + -- * a value type (only allowed in the CIL compiler) + -- * an access-to-subprogram type with convention Java/CIL + -- * an access-type designating a type that has convention + -- Java/CIL. + + if Is_Value_Type (Etype (Def_Id)) then + null; + + -- Access-to-subprogram type with convention Java/CIL + + elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type then + if Atree.Convention (Etype (Def_Id)) /= Convention then + if Convention = Convention_Java then + Error_Pragma_Arg + ("pragma% requires function returning a " & + "'Java access type", Arg1); + else + pragma Assert (Convention = Convention_CIL); + Error_Pragma_Arg + ("pragma% requires function returning a " & + "'C'I'L access type", Arg1); + end if; + end if; + + elsif Ekind (Etype (Def_Id)) in Access_Kind then + if not Ekind_In (Etype (Def_Id), E_Access_Type, + E_General_Access_Type) + or else + Atree.Convention + (Designated_Type (Etype (Def_Id))) /= Convention + then + Error_Msg_Name_1 := Pname; + + if Convention = Convention_Java then + Error_Pragma_Arg + ("pragma% requires function returning a named" & + "'Java access type", Arg1); + else + Error_Pragma_Arg + ("pragma% requires function returning a named" & + "'C'I'L access type", Arg1); + end if; + end if; + end if; + + Set_Is_Constructor (Def_Id); + Set_Convention (Def_Id, Convention); + Set_Is_Imported (Def_Id); + + exit when From_Aspect_Specification (N); + Hom_Id := Homonym (Hom_Id); + + exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope; + end loop; + end Java_Constructor; + + ---------------------- + -- Java_Interface -- + ---------------------- + + -- pragma Java_Interface ([Entity =>] LOCAL_NAME); + + when Pragma_Java_Interface => Java_Interface : declare + Arg : Node_Id; + Typ : Entity_Id; + + begin + GNAT_Pragma; + Check_Arg_Count (1); + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Arg_Is_Local_Name (Arg1); + + Arg := Get_Pragma_Arg (Arg1); + Analyze (Arg); + + if Etype (Arg) = Any_Type then + return; + end if; + + if not Is_Entity_Name (Arg) + or else not Is_Type (Entity (Arg)) + then + Error_Pragma_Arg ("pragma% requires a type mark", Arg1); + end if; + + Typ := Underlying_Type (Entity (Arg)); + + -- For now simply check some of the semantic constraints on the + -- type. This currently leaves out some restrictions on interface + -- types, namely that the parent type must be java.lang.Object.Typ + -- and that all primitives of the type should be declared + -- abstract. ??? + + if not Is_Tagged_Type (Typ) or else not Is_Abstract_Type (Typ) then + Error_Pragma_Arg ("pragma% requires an abstract " + & "tagged type", Arg1); + + elsif not Has_Discriminants (Typ) + or else Ekind (Etype (First_Discriminant (Typ))) + /= E_Anonymous_Access_Type + or else + not Is_Class_Wide_Type + (Designated_Type (Etype (First_Discriminant (Typ)))) + then + Error_Pragma_Arg + ("type must have a class-wide access discriminant", Arg1); + end if; + end Java_Interface; + + ---------------- + -- Keep_Names -- + ---------------- + + -- pragma Keep_Names ([On => ] local_NAME); + + when Pragma_Keep_Names => Keep_Names : declare + Arg : Node_Id; + + begin + GNAT_Pragma; + Check_Arg_Count (1); + Check_Optional_Identifier (Arg1, Name_On); + Check_Arg_Is_Local_Name (Arg1); + + Arg := Get_Pragma_Arg (Arg1); + Analyze (Arg); + + if Etype (Arg) = Any_Type then + return; + end if; + + if not Is_Entity_Name (Arg) + or else Ekind (Entity (Arg)) /= E_Enumeration_Type + then + Error_Pragma_Arg + ("pragma% requires a local enumeration type", Arg1); + end if; + + Set_Discard_Names (Entity (Arg), False); + end Keep_Names; + + ------------- + -- License -- + ------------- + + -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL); + + when Pragma_License => + GNAT_Pragma; + Check_Arg_Count (1); + Check_No_Identifiers; + Check_Valid_Configuration_Pragma; + Check_Arg_Is_Identifier (Arg1); + + declare + Sind : constant Source_File_Index := + Source_Index (Current_Sem_Unit); + + begin + case Chars (Get_Pragma_Arg (Arg1)) is + when Name_GPL => + Set_License (Sind, GPL); + + when Name_Modified_GPL => + Set_License (Sind, Modified_GPL); + + when Name_Restricted => + Set_License (Sind, Restricted); + + when Name_Unrestricted => + Set_License (Sind, Unrestricted); + + when others => + Error_Pragma_Arg ("invalid license name", Arg1); + end case; + end; + + --------------- + -- Link_With -- + --------------- + + -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION}); + + when Pragma_Link_With => Link_With : declare + Arg : Node_Id; + + begin + GNAT_Pragma; + + if Operating_Mode = Generate_Code + and then In_Extended_Main_Source_Unit (N) + then + Check_At_Least_N_Arguments (1); + Check_No_Identifiers; + Check_Is_In_Decl_Part_Or_Package_Spec; + Check_Arg_Is_Static_Expression (Arg1, Standard_String); + Start_String; + + Arg := Arg1; + while Present (Arg) loop + Check_Arg_Is_Static_Expression (Arg, Standard_String); + + -- Store argument, converting sequences of spaces to a + -- single null character (this is one of the differences + -- in processing between Link_With and Linker_Options). + + Arg_Store : declare + C : constant Char_Code := Get_Char_Code (' '); + S : constant String_Id := + Strval (Expr_Value_S (Get_Pragma_Arg (Arg))); + L : constant Nat := String_Length (S); + F : Nat := 1; + + procedure Skip_Spaces; + -- Advance F past any spaces + + ----------------- + -- Skip_Spaces -- + ----------------- + + procedure Skip_Spaces is + begin + while F <= L and then Get_String_Char (S, F) = C loop + F := F + 1; + end loop; + end Skip_Spaces; + + -- Start of processing for Arg_Store + + begin + Skip_Spaces; -- skip leading spaces + + -- Loop through characters, changing any embedded + -- sequence of spaces to a single null character (this + -- is how Link_With/Linker_Options differ) + + while F <= L loop + if Get_String_Char (S, F) = C then + Skip_Spaces; + exit when F > L; + Store_String_Char (ASCII.NUL); + + else + Store_String_Char (Get_String_Char (S, F)); + F := F + 1; + end if; + end loop; + end Arg_Store; + + Arg := Next (Arg); + + if Present (Arg) then + Store_String_Char (ASCII.NUL); + end if; + end loop; + + Store_Linker_Option_String (End_String); + end if; + end Link_With; + + ------------------ + -- Linker_Alias -- + ------------------ + + -- pragma Linker_Alias ( + -- [Entity =>] LOCAL_NAME + -- [Target =>] static_string_EXPRESSION); + + when Pragma_Linker_Alias => + GNAT_Pragma; + Check_Arg_Order ((Name_Entity, Name_Target)); + Check_Arg_Count (2); + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Optional_Identifier (Arg2, Name_Target); + Check_Arg_Is_Library_Level_Local_Name (Arg1); + Check_Arg_Is_Static_Expression (Arg2, Standard_String); + + -- The only processing required is to link this item on to the + -- list of rep items for the given entity. This is accomplished + -- by the call to Rep_Item_Too_Late (when no error is detected + -- and False is returned). + + if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then + return; + else + Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1))); + end if; + + ------------------------ + -- Linker_Constructor -- + ------------------------ + + -- pragma Linker_Constructor (procedure_LOCAL_NAME); + + -- Code is shared with Linker_Destructor + + ----------------------- + -- Linker_Destructor -- + ----------------------- + + -- pragma Linker_Destructor (procedure_LOCAL_NAME); + + when Pragma_Linker_Constructor | + Pragma_Linker_Destructor => + Linker_Constructor : declare + Arg1_X : Node_Id; + Proc : Entity_Id; + + begin + GNAT_Pragma; + Check_Arg_Count (1); + Check_No_Identifiers; + Check_Arg_Is_Local_Name (Arg1); + Arg1_X := Get_Pragma_Arg (Arg1); + Analyze (Arg1_X); + Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1); + + if not Is_Library_Level_Entity (Proc) then + Error_Pragma_Arg + ("argument for pragma% must be library level entity", Arg1); + end if; + + -- The only processing required is to link this item on to the + -- list of rep items for the given entity. This is accomplished + -- by the call to Rep_Item_Too_Late (when no error is detected + -- and False is returned). + + if Rep_Item_Too_Late (Proc, N) then + return; + else + Set_Has_Gigi_Rep_Item (Proc); + end if; + end Linker_Constructor; + + -------------------- + -- Linker_Options -- + -------------------- + + -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION}); + + when Pragma_Linker_Options => Linker_Options : declare + Arg : Node_Id; + + begin + Check_Ada_83_Warning; + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Is_In_Decl_Part_Or_Package_Spec; + Check_Arg_Is_Static_Expression (Arg1, Standard_String); + Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1)))); + + Arg := Arg2; + while Present (Arg) loop + Check_Arg_Is_Static_Expression (Arg, Standard_String); + Store_String_Char (ASCII.NUL); + Store_String_Chars + (Strval (Expr_Value_S (Get_Pragma_Arg (Arg)))); + Arg := Next (Arg); + end loop; + + if Operating_Mode = Generate_Code + and then In_Extended_Main_Source_Unit (N) + then + Store_Linker_Option_String (End_String); + end if; + end Linker_Options; + + -------------------- + -- Linker_Section -- + -------------------- + + -- pragma Linker_Section ( + -- [Entity =>] LOCAL_NAME + -- [Section =>] static_string_EXPRESSION); + + when Pragma_Linker_Section => + GNAT_Pragma; + Check_Arg_Order ((Name_Entity, Name_Section)); + Check_Arg_Count (2); + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Optional_Identifier (Arg2, Name_Section); + Check_Arg_Is_Library_Level_Local_Name (Arg1); + Check_Arg_Is_Static_Expression (Arg2, Standard_String); + + -- This pragma applies only to objects + + if not Is_Object (Entity (Get_Pragma_Arg (Arg1))) then + Error_Pragma_Arg ("pragma% applies only to objects", Arg1); + end if; + + -- The only processing required is to link this item on to the + -- list of rep items for the given entity. This is accomplished + -- by the call to Rep_Item_Too_Late (when no error is detected + -- and False is returned). + + if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then + return; + else + Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1))); + end if; + + ---------- + -- List -- + ---------- + + -- pragma List (On | Off) + + -- There is nothing to do here, since we did all the processing for + -- this pragma in Par.Prag (so that it works properly even in syntax + -- only mode). + + when Pragma_List => + null; + + -------------------- + -- Locking_Policy -- + -------------------- + + -- pragma Locking_Policy (policy_IDENTIFIER); + + when Pragma_Locking_Policy => declare + LP : Character; + + begin + Check_Ada_83_Warning; + Check_Arg_Count (1); + Check_No_Identifiers; + Check_Arg_Is_Locking_Policy (Arg1); + Check_Valid_Configuration_Pragma; + Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); + LP := Fold_Upper (Name_Buffer (1)); + + if Locking_Policy /= ' ' + and then Locking_Policy /= LP + then + Error_Msg_Sloc := Locking_Policy_Sloc; + Error_Pragma ("locking policy incompatible with policy#"); + + -- Set new policy, but always preserve System_Location since we + -- like the error message with the run time name. + + else + Locking_Policy := LP; + + if Locking_Policy_Sloc /= System_Location then + Locking_Policy_Sloc := Loc; + end if; + end if; + end; + + ---------------- + -- Long_Float -- + ---------------- + + -- pragma Long_Float (D_Float | G_Float); + + when Pragma_Long_Float => + GNAT_Pragma; + Check_Valid_Configuration_Pragma; + Check_Arg_Count (1); + Check_No_Identifier (Arg1); + Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float); + + if not OpenVMS_On_Target then + Error_Pragma ("?pragma% ignored (applies only to Open'V'M'S)"); + end if; + + -- D_Float case + + if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then + if Opt.Float_Format_Long = 'G' then + Error_Pragma ("G_Float previously specified"); + end if; + + Opt.Float_Format_Long := 'D'; + + -- G_Float case (this is the default, does not need overriding) + + else + if Opt.Float_Format_Long = 'D' then + Error_Pragma ("D_Float previously specified"); + end if; + + Opt.Float_Format_Long := 'G'; + end if; + + Set_Standard_Fpt_Formats; + + ----------------------- + -- Machine_Attribute -- + ----------------------- + + -- pragma Machine_Attribute ( + -- [Entity =>] LOCAL_NAME, + -- [Attribute_Name =>] static_string_EXPRESSION + -- [, [Info =>] static_EXPRESSION] ); + + when Pragma_Machine_Attribute => Machine_Attribute : declare + Def_Id : Entity_Id; + + begin + GNAT_Pragma; + Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info)); + + if Arg_Count = 3 then + Check_Optional_Identifier (Arg3, Name_Info); + Check_Arg_Is_Static_Expression (Arg3); + else + Check_Arg_Count (2); + end if; + + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Optional_Identifier (Arg2, Name_Attribute_Name); + Check_Arg_Is_Local_Name (Arg1); + Check_Arg_Is_Static_Expression (Arg2, Standard_String); + Def_Id := Entity (Get_Pragma_Arg (Arg1)); + + if Is_Access_Type (Def_Id) then + Def_Id := Designated_Type (Def_Id); + end if; + + if Rep_Item_Too_Early (Def_Id, N) then + return; + end if; + + Def_Id := Underlying_Type (Def_Id); + + -- The only processing required is to link this item on to the + -- list of rep items for the given entity. This is accomplished + -- by the call to Rep_Item_Too_Late (when no error is detected + -- and False is returned). + + if Rep_Item_Too_Late (Def_Id, N) then + return; + else + Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1))); + end if; + end Machine_Attribute; + + ---------- + -- Main -- + ---------- + + -- pragma Main + -- (MAIN_OPTION [, MAIN_OPTION]); + + -- MAIN_OPTION ::= + -- [STACK_SIZE =>] static_integer_EXPRESSION + -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION + -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION + + when Pragma_Main => Main : declare + Args : Args_List (1 .. 3); + Names : constant Name_List (1 .. 3) := ( + Name_Stack_Size, + Name_Task_Stack_Size_Default, + Name_Time_Slicing_Enabled); + + Nod : Node_Id; + + begin + GNAT_Pragma; + Gather_Associations (Names, Args); + + for J in 1 .. 2 loop + if Present (Args (J)) then + Check_Arg_Is_Static_Expression (Args (J), Any_Integer); + end if; + end loop; + + if Present (Args (3)) then + Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean); + end if; + + Nod := Next (N); + while Present (Nod) loop + if Nkind (Nod) = N_Pragma + and then Pragma_Name (Nod) = Name_Main + then + Error_Msg_Name_1 := Pname; + Error_Msg_N ("duplicate pragma% not permitted", Nod); + end if; + + Next (Nod); + end loop; + end Main; + + ------------------ + -- Main_Storage -- + ------------------ + + -- pragma Main_Storage + -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]); + + -- MAIN_STORAGE_OPTION ::= + -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION + -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION + + when Pragma_Main_Storage => Main_Storage : declare + Args : Args_List (1 .. 2); + Names : constant Name_List (1 .. 2) := ( + Name_Working_Storage, + Name_Top_Guard); + + Nod : Node_Id; + + begin + GNAT_Pragma; + Gather_Associations (Names, Args); + + for J in 1 .. 2 loop + if Present (Args (J)) then + Check_Arg_Is_Static_Expression (Args (J), Any_Integer); + end if; + end loop; + + Check_In_Main_Program; + + Nod := Next (N); + while Present (Nod) loop + if Nkind (Nod) = N_Pragma + and then Pragma_Name (Nod) = Name_Main_Storage + then + Error_Msg_Name_1 := Pname; + Error_Msg_N ("duplicate pragma% not permitted", Nod); + end if; + + Next (Nod); + end loop; + end Main_Storage; + + ----------------- + -- Memory_Size -- + ----------------- + + -- pragma Memory_Size (NUMERIC_LITERAL) + + when Pragma_Memory_Size => + GNAT_Pragma; + + -- Memory size is simply ignored + + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Integer_Literal (Arg1); + + ------------- + -- No_Body -- + ------------- + + -- pragma No_Body; + + -- The only correct use of this pragma is on its own in a file, in + -- which case it is specially processed (see Gnat1drv.Check_Bad_Body + -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to + -- check for a file containing nothing but a No_Body pragma). If we + -- attempt to process it during normal semantics processing, it means + -- it was misplaced. + + when Pragma_No_Body => + GNAT_Pragma; + Pragma_Misplaced; + + --------------- + -- No_Return -- + --------------- + + -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name}); + + when Pragma_No_Return => No_Return : declare + Id : Node_Id; + E : Entity_Id; + Found : Boolean; + Arg : Node_Id; + + begin + Ada_2005_Pragma; + Check_At_Least_N_Arguments (1); + + -- Loop through arguments of pragma + + Arg := Arg1; + while Present (Arg) loop + Check_Arg_Is_Local_Name (Arg); + Id := Get_Pragma_Arg (Arg); + Analyze (Id); + + if not Is_Entity_Name (Id) then + Error_Pragma_Arg ("entity name required", Arg); + end if; + + if Etype (Id) = Any_Type then + raise Pragma_Exit; + end if; + + -- Loop to find matching procedures + + E := Entity (Id); + Found := False; + while Present (E) + and then Scope (E) = Current_Scope + loop + if Ekind_In (E, E_Procedure, E_Generic_Procedure) then + Set_No_Return (E); + + -- Set flag on any alias as well + + if Is_Overloadable (E) and then Present (Alias (E)) then + Set_No_Return (Alias (E)); + end if; + + Found := True; + end if; + + exit when From_Aspect_Specification (N); + E := Homonym (E); + end loop; + + if not Found then + Error_Pragma_Arg ("no procedure & found for pragma%", Arg); + end if; + + Next (Arg); + end loop; + end No_Return; + + ----------------- + -- No_Run_Time -- + ----------------- + + -- pragma No_Run_Time; + + -- Note: this pragma is retained for backwards compatibility. See + -- body of Rtsfind for full details on its handling. + + when Pragma_No_Run_Time => + GNAT_Pragma; + Check_Valid_Configuration_Pragma; + Check_Arg_Count (0); + + No_Run_Time_Mode := True; + Configurable_Run_Time_Mode := True; + + -- Set Duration to 32 bits if word size is 32 + + if Ttypes.System_Word_Size = 32 then + Duration_32_Bits_On_Target := True; + end if; + + -- Set appropriate restrictions + + Set_Restriction (No_Finalization, N); + Set_Restriction (No_Exception_Handlers, N); + Set_Restriction (Max_Tasks, N, 0); + Set_Restriction (No_Tasking, N); + + ------------------------ + -- No_Strict_Aliasing -- + ------------------------ + + -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)]; + + when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare + E_Id : Entity_Id; + + begin + GNAT_Pragma; + Check_At_Most_N_Arguments (1); + + if Arg_Count = 0 then + Check_Valid_Configuration_Pragma; + Opt.No_Strict_Aliasing := True; + + else + Check_Optional_Identifier (Arg2, Name_Entity); + Check_Arg_Is_Local_Name (Arg1); + E_Id := Entity (Get_Pragma_Arg (Arg1)); + + if E_Id = Any_Type then + return; + elsif No (E_Id) or else not Is_Access_Type (E_Id) then + Error_Pragma_Arg ("pragma% requires access type", Arg1); + end if; + + Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id)); + end if; + end No_Strict_Aliasing; + + ----------------------- + -- Normalize_Scalars -- + ----------------------- + + -- pragma Normalize_Scalars; + + when Pragma_Normalize_Scalars => + Check_Ada_83_Warning; + Check_Arg_Count (0); + Check_Valid_Configuration_Pragma; + + -- Normalize_Scalars creates false positives in CodePeer, so + -- ignore this pragma in this mode. + + if not CodePeer_Mode then + Normalize_Scalars := True; + Init_Or_Norm_Scalars := True; + end if; + + ----------------- + -- Obsolescent -- + ----------------- + + -- pragma Obsolescent; + + -- pragma Obsolescent ( + -- [Message =>] static_string_EXPRESSION + -- [,[Version =>] Ada_05]]); + + -- pragma Obsolescent ( + -- [Entity =>] NAME + -- [,[Message =>] static_string_EXPRESSION + -- [,[Version =>] Ada_05]] ); + + when Pragma_Obsolescent => Obsolescent : declare + Ename : Node_Id; + Decl : Node_Id; + + procedure Set_Obsolescent (E : Entity_Id); + -- Given an entity Ent, mark it as obsolescent if appropriate + + --------------------- + -- Set_Obsolescent -- + --------------------- + + procedure Set_Obsolescent (E : Entity_Id) is + Active : Boolean; + Ent : Entity_Id; + S : String_Id; + + begin + Active := True; + Ent := E; + + -- Entity name was given + + if Present (Ename) then + + -- If entity name matches, we are fine. Save entity in + -- pragma argument, for ASIS use. + + if Chars (Ename) = Chars (Ent) then + Set_Entity (Ename, Ent); + Generate_Reference (Ent, Ename); + + -- If entity name does not match, only possibility is an + -- enumeration literal from an enumeration type declaration. + + elsif Ekind (Ent) /= E_Enumeration_Type then + Error_Pragma + ("pragma % entity name does not match declaration"); + + else + Ent := First_Literal (E); + loop + if No (Ent) then + Error_Pragma + ("pragma % entity name does not match any " & + "enumeration literal"); + + elsif Chars (Ent) = Chars (Ename) then + Set_Entity (Ename, Ent); + Generate_Reference (Ent, Ename); + exit; + + else + Ent := Next_Literal (Ent); + end if; + end loop; + end if; + end if; + + -- Ent points to entity to be marked + + if Arg_Count >= 1 then + + -- Deal with static string argument + + Check_Arg_Is_Static_Expression (Arg1, Standard_String); + S := Strval (Get_Pragma_Arg (Arg1)); + + for J in 1 .. String_Length (S) loop + if not In_Character_Range (Get_String_Char (S, J)) then + Error_Pragma_Arg + ("pragma% argument does not allow wide characters", + Arg1); + end if; + end loop; + + Obsolescent_Warnings.Append + ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1)))); + + -- Check for Ada_05 parameter + + if Arg_Count /= 1 then + Check_Arg_Count (2); + + declare + Argx : constant Node_Id := Get_Pragma_Arg (Arg2); + + begin + Check_Arg_Is_Identifier (Argx); + + if Chars (Argx) /= Name_Ada_05 then + Error_Msg_Name_2 := Name_Ada_05; + Error_Pragma_Arg + ("only allowed argument for pragma% is %", Argx); + end if; + + if Ada_Version_Explicit < Ada_2005 + or else not Warn_On_Ada_2005_Compatibility + then + Active := False; + end if; + end; + end if; + end if; + + -- Set flag if pragma active + + if Active then + Set_Is_Obsolescent (Ent); + end if; + + return; + end Set_Obsolescent; + + -- Start of processing for pragma Obsolescent + + begin + GNAT_Pragma; + + Check_At_Most_N_Arguments (3); + + -- See if first argument specifies an entity name + + if Arg_Count >= 1 + and then + (Chars (Arg1) = Name_Entity + or else + Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal, + N_Identifier, + N_Operator_Symbol)) + then + Ename := Get_Pragma_Arg (Arg1); + + -- Eliminate first argument, so we can share processing + + Arg1 := Arg2; + Arg2 := Arg3; + Arg_Count := Arg_Count - 1; + + -- No Entity name argument given + + else + Ename := Empty; + end if; + + if Arg_Count >= 1 then + Check_Optional_Identifier (Arg1, Name_Message); + + if Arg_Count = 2 then + Check_Optional_Identifier (Arg2, Name_Version); + end if; + end if; + + -- Get immediately preceding declaration + + Decl := Prev (N); + while Present (Decl) and then Nkind (Decl) = N_Pragma loop + Prev (Decl); + end loop; + + -- Cases where we do not follow anything other than another pragma + + if No (Decl) then + + -- First case: library level compilation unit declaration with + -- the pragma immediately following the declaration. + + if Nkind (Parent (N)) = N_Compilation_Unit_Aux then + Set_Obsolescent + (Defining_Entity (Unit (Parent (Parent (N))))); + return; + + -- Case 2: library unit placement for package + + else + declare + Ent : constant Entity_Id := Find_Lib_Unit_Name; + begin + if Is_Package_Or_Generic_Package (Ent) then + Set_Obsolescent (Ent); + return; + end if; + end; + end if; + + -- Cases where we must follow a declaration + + else + if Nkind (Decl) not in N_Declaration + and then Nkind (Decl) not in N_Later_Decl_Item + and then Nkind (Decl) not in N_Generic_Declaration + and then Nkind (Decl) not in N_Renaming_Declaration + then + Error_Pragma + ("pragma% misplaced, " + & "must immediately follow a declaration"); + + else + Set_Obsolescent (Defining_Entity (Decl)); + return; + end if; + end if; + end Obsolescent; + + -------------- + -- Optimize -- + -------------- + + -- pragma Optimize (Time | Space | Off); + + -- The actual check for optimize is done in Gigi. Note that this + -- pragma does not actually change the optimization setting, it + -- simply checks that it is consistent with the pragma. + + when Pragma_Optimize => + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off); + + ------------------------ + -- Optimize_Alignment -- + ------------------------ + + -- pragma Optimize_Alignment (Time | Space | Off); + + when Pragma_Optimize_Alignment => Optimize_Alignment : begin + GNAT_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Valid_Configuration_Pragma; + + declare + Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1)); + begin + case Nam is + when Name_Time => + Opt.Optimize_Alignment := 'T'; + when Name_Space => + Opt.Optimize_Alignment := 'S'; + when Name_Off => + Opt.Optimize_Alignment := 'O'; + when others => + Error_Pragma_Arg ("invalid argument for pragma%", Arg1); + end case; + end; + + -- Set indication that mode is set locally. If we are in fact in a + -- configuration pragma file, this setting is harmless since the + -- switch will get reset anyway at the start of each unit. + + Optimize_Alignment_Local := True; + end Optimize_Alignment; + + ------------- + -- Ordered -- + ------------- + + -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME); + + when Pragma_Ordered => Ordered : declare + Assoc : constant Node_Id := Arg1; + Type_Id : Node_Id; + Typ : Entity_Id; + + begin + GNAT_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + + Type_Id := Get_Pragma_Arg (Assoc); + Find_Type (Type_Id); + Typ := Entity (Type_Id); + + if Typ = Any_Type then + return; + else + Typ := Underlying_Type (Typ); + end if; + + if not Is_Enumeration_Type (Typ) then + Error_Pragma ("pragma% must specify enumeration type"); + end if; + + Check_First_Subtype (Arg1); + Set_Has_Pragma_Ordered (Base_Type (Typ)); + end Ordered; + + ---------- + -- Pack -- + ---------- + + -- pragma Pack (first_subtype_LOCAL_NAME); + + when Pragma_Pack => Pack : declare + Assoc : constant Node_Id := Arg1; + Type_Id : Node_Id; + Typ : Entity_Id; + Ctyp : Entity_Id; + Ignore : Boolean := False; + + begin + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + + Type_Id := Get_Pragma_Arg (Assoc); + Find_Type (Type_Id); + Typ := Entity (Type_Id); + + if Typ = Any_Type + or else Rep_Item_Too_Early (Typ, N) + then + return; + else + Typ := Underlying_Type (Typ); + end if; + + if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then + Error_Pragma ("pragma% must specify array or record type"); + end if; + + Check_First_Subtype (Arg1); + Check_Duplicate_Pragma (Typ); + + -- Array type + + if Is_Array_Type (Typ) then + Ctyp := Component_Type (Typ); + + -- Ignore pack that does nothing + + if Known_Static_Esize (Ctyp) + and then Known_Static_RM_Size (Ctyp) + and then Esize (Ctyp) = RM_Size (Ctyp) + and then Addressable (Esize (Ctyp)) + then + Ignore := True; + end if; + + -- Process OK pragma Pack. Note that if there is a separate + -- component clause present, the Pack will be cancelled. This + -- processing is in Freeze. + + if not Rep_Item_Too_Late (Typ, N) then + + -- In the context of static code analysis, we do not need + -- complex front-end expansions related to pragma Pack, + -- so disable handling of pragma Pack in this case. + + if CodePeer_Mode then + null; + + -- Don't attempt any packing for VM targets. We possibly + -- could deal with some cases of array bit-packing, but we + -- don't bother, since this is not a typical kind of + -- representation in the VM context anyway (and would not + -- for example work nicely with the debugger). + + elsif VM_Target /= No_VM then + if not GNAT_Mode then + Error_Pragma + ("?pragma% ignored in this configuration"); + end if; + + -- Normal case where we do the pack action + + else + if not Ignore then + Set_Is_Packed (Base_Type (Typ), Sense); + Set_Has_Non_Standard_Rep (Base_Type (Typ), Sense); + end if; + + Set_Has_Pragma_Pack (Base_Type (Typ), Sense); + + -- Complete reset action for Aspect_Cancel case + + if Sense = False then + + -- Cancel size unless explicitly set + + if not Has_Size_Clause (Typ) + and then not Has_Object_Size_Clause (Typ) + then + Set_Esize (Typ, Uint_0); + Set_RM_Size (Typ, Uint_0); + Set_Alignment (Typ, Uint_0); + Set_Packed_Array_Type (Typ, Empty); + end if; + + -- Reset component size unless explicitly set + + if not Has_Component_Size_Clause (Typ) then + if Known_Static_Esize (Ctyp) + and then Known_Static_RM_Size (Ctyp) + and then Esize (Ctyp) = RM_Size (Ctyp) + and then Addressable (Esize (Ctyp)) + then + Set_Component_Size + (Base_Type (Typ), Esize (Ctyp)); + else + Set_Component_Size + (Base_Type (Typ), Uint_0); + end if; + end if; + end if; + end if; + end if; + + -- For record types, the pack is always effective + + else pragma Assert (Is_Record_Type (Typ)); + if not Rep_Item_Too_Late (Typ, N) then + + -- Ignore pack request with warning in VM mode (skip warning + -- if we are compiling GNAT run time library). + + if VM_Target /= No_VM then + if not GNAT_Mode then + Error_Pragma + ("?pragma% ignored in this configuration"); + end if; + + -- Normal case of pack request active + + else + Set_Is_Packed (Base_Type (Typ), Sense); + Set_Has_Pragma_Pack (Base_Type (Typ), Sense); + Set_Has_Non_Standard_Rep (Base_Type (Typ), Sense); + + -- Complete reset action for Aspect_Cancel case + + if Sense = False then + + -- Cancel size if not explicitly given + + if not Has_Size_Clause (Typ) + and then not Has_Object_Size_Clause (Typ) + then + Set_Esize (Typ, Uint_0); + Set_Alignment (Typ, Uint_0); + end if; + end if; + end if; + end if; + end if; + end Pack; + + ---------- + -- Page -- + ---------- + + -- pragma Page; + + -- There is nothing to do here, since we did all the processing for + -- this pragma in Par.Prag (so that it works properly even in syntax + -- only mode). + + when Pragma_Page => + null; + + ------------- + -- Passive -- + ------------- + + -- pragma Passive [(PASSIVE_FORM)]; + + -- PASSIVE_FORM ::= Semaphore | No + + when Pragma_Passive => + GNAT_Pragma; + + if Nkind (Parent (N)) /= N_Task_Definition then + Error_Pragma ("pragma% must be within task definition"); + end if; + + if Arg_Count /= 0 then + Check_Arg_Count (1); + Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No); + end if; + + ---------------------------------- + -- Preelaborable_Initialization -- + ---------------------------------- + + -- pragma Preelaborable_Initialization (DIRECT_NAME); + + when Pragma_Preelaborable_Initialization => Preelab_Init : declare + Ent : Entity_Id; + + begin + Ada_2005_Pragma; + Check_Arg_Count (1); + Check_No_Identifiers; + Check_Arg_Is_Identifier (Arg1); + Check_Arg_Is_Local_Name (Arg1); + Check_First_Subtype (Arg1); + Ent := Entity (Get_Pragma_Arg (Arg1)); + + if not (Is_Private_Type (Ent) + or else + Is_Protected_Type (Ent) + or else + (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))) + then + Error_Pragma_Arg + ("pragma % can only be applied to private, formal derived or " + & "protected type", + Arg1); + end if; + + -- Give an error if the pragma is applied to a protected type that + -- does not qualify (due to having entries, or due to components + -- that do not qualify). + + if Is_Protected_Type (Ent) + and then not Has_Preelaborable_Initialization (Ent) + then + Error_Msg_N + ("protected type & does not have preelaborable " & + "initialization", Ent); + + -- Otherwise mark the type as definitely having preelaborable + -- initialization. + + else + Set_Known_To_Have_Preelab_Init (Ent); + end if; + + if Has_Pragma_Preelab_Init (Ent) + and then Warn_On_Redundant_Constructs + then + Error_Pragma ("?duplicate pragma%!"); + else + Set_Has_Pragma_Preelab_Init (Ent); + end if; + end Preelab_Init; + + -------------------- + -- Persistent_BSS -- + -------------------- + + -- pragma Persistent_BSS [(object_NAME)]; + + when Pragma_Persistent_BSS => Persistent_BSS : declare + Decl : Node_Id; + Ent : Entity_Id; + Prag : Node_Id; + + begin + GNAT_Pragma; + Check_At_Most_N_Arguments (1); + + -- Case of application to specific object (one argument) + + if Arg_Count = 1 then + Check_Arg_Is_Library_Level_Local_Name (Arg1); + + if not Is_Entity_Name (Get_Pragma_Arg (Arg1)) + or else not + Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable, + E_Constant) + then + Error_Pragma_Arg ("pragma% only applies to objects", Arg1); + end if; + + Ent := Entity (Get_Pragma_Arg (Arg1)); + Decl := Parent (Ent); + + if Rep_Item_Too_Late (Ent, N) then + return; + end if; + + if Present (Expression (Decl)) then + Error_Pragma_Arg + ("object for pragma% cannot have initialization", Arg1); + end if; + + if not Is_Potentially_Persistent_Type (Etype (Ent)) then + Error_Pragma_Arg + ("object type for pragma% is not potentially persistent", + Arg1); + end if; + + Check_Duplicate_Pragma (Ent); + + if Sense then + Prag := + Make_Linker_Section_Pragma + (Ent, Sloc (N), ".persistent.bss"); + Insert_After (N, Prag); + Analyze (Prag); + end if; + + -- Case of use as configuration pragma with no arguments + + else + Check_Valid_Configuration_Pragma; + Persistent_BSS_Mode := True; + end if; + end Persistent_BSS; + + ------------- + -- Polling -- + ------------- + + -- pragma Polling (ON | OFF); + + when Pragma_Polling => + GNAT_Pragma; + Check_Arg_Count (1); + Check_No_Identifiers; + Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); + Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On); + + ------------------- + -- Postcondition -- + ------------------- + + -- pragma Postcondition ([Check =>] Boolean_Expression + -- [,[Message =>] String_Expression]); + + when Pragma_Postcondition => Postcondition : declare + In_Body : Boolean; + pragma Warnings (Off, In_Body); + + begin + GNAT_Pragma; + Check_At_Least_N_Arguments (1); + Check_At_Most_N_Arguments (2); + Check_Optional_Identifier (Arg1, Name_Check); + + -- All we need to do here is call the common check procedure, + -- the remainder of the processing is found in Sem_Ch6/Sem_Ch7. + + Check_Precondition_Postcondition (In_Body); + end Postcondition; + + ------------------ + -- Precondition -- + ------------------ + + -- pragma Precondition ([Check =>] Boolean_Expression + -- [,[Message =>] String_Expression]); + + when Pragma_Precondition => Precondition : declare + In_Body : Boolean; + + begin + GNAT_Pragma; + Check_At_Least_N_Arguments (1); + Check_At_Most_N_Arguments (2); + Check_Optional_Identifier (Arg1, Name_Check); + Check_Precondition_Postcondition (In_Body); + + -- If in spec, nothing more to do. If in body, then we convert the + -- pragma to pragma Check (Precondition, cond [, msg]). Note we do + -- this whether or not precondition checks are enabled. That works + -- fine since pragma Check will do this check, and will also + -- analyze the condition itself in the proper context. + + if In_Body then + Rewrite (N, + Make_Pragma (Loc, + Chars => Name_Check, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_Precondition)), + + Make_Pragma_Argument_Association (Sloc (Arg1), + Expression => Relocate_Node (Get_Pragma_Arg (Arg1)))))); + + if Arg_Count = 2 then + Append_To (Pragma_Argument_Associations (N), + Make_Pragma_Argument_Association (Sloc (Arg2), + Expression => Relocate_Node (Get_Pragma_Arg (Arg2)))); + end if; + + Analyze (N); + end if; + end Precondition; + + --------------- + -- Predicate -- + --------------- + + -- pragma Predicate + -- ([Entity =>] type_LOCAL_NAME, + -- [Check =>] EXPRESSION); + + when Pragma_Predicate => Predicate : declare + Type_Id : Node_Id; + Typ : Entity_Id; + + Discard : Boolean; + pragma Unreferenced (Discard); + + begin + GNAT_Pragma; + Check_Arg_Count (2); + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Optional_Identifier (Arg2, Name_Check); + + Check_Arg_Is_Local_Name (Arg1); + + Type_Id := Get_Pragma_Arg (Arg1); + Find_Type (Type_Id); + Typ := Entity (Type_Id); + + if Typ = Any_Type then + return; + end if; + + -- The remaining processing is simply to link the pragma on to + -- the rep item chain, for processing when the type is frozen. + -- This is accomplished by a call to Rep_Item_Too_Late. We also + -- mark the type as having predicates. + + Set_Has_Predicates (Typ); + Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); + end Predicate; + + ------------------ + -- Preelaborate -- + ------------------ + + -- pragma Preelaborate [(library_unit_NAME)]; + + -- Set the flag Is_Preelaborated of program unit name entity + + when Pragma_Preelaborate => Preelaborate : declare + Pa : constant Node_Id := Parent (N); + Pk : constant Node_Kind := Nkind (Pa); + Ent : Entity_Id; + + begin + Check_Ada_83_Warning; + Check_Valid_Library_Unit_Pragma; + + if Nkind (N) = N_Null_Statement then + return; + end if; + + Ent := Find_Lib_Unit_Name; + Check_Duplicate_Pragma (Ent); + + -- This filters out pragmas inside generic parent then + -- show up inside instantiation + + if Present (Ent) + and then not (Pk = N_Package_Specification + and then Present (Generic_Parent (Pa))) + then + if not Debug_Flag_U then + Set_Is_Preelaborated (Ent, Sense); + Set_Suppress_Elaboration_Warnings (Ent, Sense); + end if; + end if; + end Preelaborate; + + --------------------- + -- Preelaborate_05 -- + --------------------- + + -- pragma Preelaborate_05 [(library_unit_NAME)]; + + -- This pragma is useable only in GNAT_Mode, where it is used like + -- pragma Preelaborate but it is only effective in Ada 2005 mode + -- (otherwise it is ignored). This is used to implement AI-362 which + -- recategorizes some run-time packages in Ada 2005 mode. + + when Pragma_Preelaborate_05 => Preelaborate_05 : declare + Ent : Entity_Id; + + begin + GNAT_Pragma; + Check_Valid_Library_Unit_Pragma; + + if not GNAT_Mode then + Error_Pragma ("pragma% only available in GNAT mode"); + end if; + + if Nkind (N) = N_Null_Statement then + return; + end if; + + -- This is one of the few cases where we need to test the value of + -- Ada_Version_Explicit rather than Ada_Version (which is always + -- set to Ada_2012 in a predefined unit), we need to know the + -- explicit version set to know if this pragma is active. + + if Ada_Version_Explicit >= Ada_2005 then + Ent := Find_Lib_Unit_Name; + Set_Is_Preelaborated (Ent); + Set_Suppress_Elaboration_Warnings (Ent); + end if; + end Preelaborate_05; + + -------------- + -- Priority -- + -------------- + + -- pragma Priority (EXPRESSION); + + when Pragma_Priority => Priority : declare + P : constant Node_Id := Parent (N); + Arg : Node_Id; + + begin + Check_No_Identifiers; + Check_Arg_Count (1); + + -- Subprogram case + + if Nkind (P) = N_Subprogram_Body then + Check_In_Main_Program; + + Arg := Get_Pragma_Arg (Arg1); + Analyze_And_Resolve (Arg, Standard_Integer); + + -- Must be static + + if not Is_Static_Expression (Arg) then + Flag_Non_Static_Expr + ("main subprogram priority is not static!", Arg); + raise Pragma_Exit; + + -- If constraint error, then we already signalled an error + + elsif Raises_Constraint_Error (Arg) then + null; + + -- Otherwise check in range + + else + declare + Val : constant Uint := Expr_Value (Arg); + + begin + if Val < 0 + or else Val > Expr_Value (Expression + (Parent (RTE (RE_Max_Priority)))) + then + Error_Pragma_Arg + ("main subprogram priority is out of range", Arg1); + end if; + end; + end if; + + Set_Main_Priority + (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg))); + + -- Load an arbitrary entity from System.Tasking to make sure + -- this package is implicitly with'ed, since we need to have + -- the tasking run-time active for the pragma Priority to have + -- any effect. + + declare + Discard : Entity_Id; + pragma Warnings (Off, Discard); + begin + Discard := RTE (RE_Task_List); + end; + + -- Task or Protected, must be of type Integer + + elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then + Arg := Get_Pragma_Arg (Arg1); + + -- The expression must be analyzed in the special manner + -- described in "Handling of Default and Per-Object + -- Expressions" in sem.ads. + + Preanalyze_Spec_Expression (Arg, Standard_Integer); + + if not Is_Static_Expression (Arg) then + Check_Restriction (Static_Priorities, Arg); + end if; + + -- Anything else is incorrect + + else + Pragma_Misplaced; + end if; + + if Has_Pragma_Priority (P) then + Error_Pragma ("duplicate pragma% not allowed"); + else + Set_Has_Pragma_Priority (P, True); + + if Nkind_In (P, N_Protected_Definition, N_Task_Definition) then + Record_Rep_Item (Defining_Identifier (Parent (P)), N); + -- exp_ch9 should use this ??? + end if; + end if; + end Priority; + + ----------------------------------- + -- Priority_Specific_Dispatching -- + ----------------------------------- + + -- pragma Priority_Specific_Dispatching ( + -- policy_IDENTIFIER, + -- first_priority_EXPRESSION, + -- last_priority_EXPRESSION); + + when Pragma_Priority_Specific_Dispatching => + Priority_Specific_Dispatching : declare + Prio_Id : constant Entity_Id := RTE (RE_Any_Priority); + -- This is the entity System.Any_Priority; + + DP : Character; + Lower_Bound : Node_Id; + Upper_Bound : Node_Id; + Lower_Val : Uint; + Upper_Val : Uint; + + begin + Ada_2005_Pragma; + Check_Arg_Count (3); + Check_No_Identifiers; + Check_Arg_Is_Task_Dispatching_Policy (Arg1); + Check_Valid_Configuration_Pragma; + Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); + DP := Fold_Upper (Name_Buffer (1)); + + Lower_Bound := Get_Pragma_Arg (Arg2); + Check_Arg_Is_Static_Expression (Lower_Bound, Standard_Integer); + Lower_Val := Expr_Value (Lower_Bound); + + Upper_Bound := Get_Pragma_Arg (Arg3); + Check_Arg_Is_Static_Expression (Upper_Bound, Standard_Integer); + Upper_Val := Expr_Value (Upper_Bound); + + -- It is not allowed to use Task_Dispatching_Policy and + -- Priority_Specific_Dispatching in the same partition. + + if Task_Dispatching_Policy /= ' ' then + Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; + Error_Pragma + ("pragma% incompatible with Task_Dispatching_Policy#"); + + -- Check lower bound in range + + elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id)) + or else + Lower_Val > Expr_Value (Type_High_Bound (Prio_Id)) + then + Error_Pragma_Arg + ("first_priority is out of range", Arg2); + + -- Check upper bound in range + + elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id)) + or else + Upper_Val > Expr_Value (Type_High_Bound (Prio_Id)) + then + Error_Pragma_Arg + ("last_priority is out of range", Arg3); + + -- Check that the priority range is valid + + elsif Lower_Val > Upper_Val then + Error_Pragma + ("last_priority_expression must be greater than" & + " or equal to first_priority_expression"); + + -- Store the new policy, but always preserve System_Location since + -- we like the error message with the run-time name. + + else + -- Check overlapping in the priority ranges specified in other + -- Priority_Specific_Dispatching pragmas within the same + -- partition. We can only check those we know about! + + for J in + Specific_Dispatching.First .. Specific_Dispatching.Last + loop + if Specific_Dispatching.Table (J).First_Priority in + UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val) + or else Specific_Dispatching.Table (J).Last_Priority in + UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val) + then + Error_Msg_Sloc := + Specific_Dispatching.Table (J).Pragma_Loc; + Error_Pragma + ("priority range overlaps with " + & "Priority_Specific_Dispatching#"); + end if; + end loop; + + -- The use of Priority_Specific_Dispatching is incompatible + -- with Task_Dispatching_Policy. + + if Task_Dispatching_Policy /= ' ' then + Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; + Error_Pragma + ("Priority_Specific_Dispatching incompatible " + & "with Task_Dispatching_Policy#"); + end if; + + -- The use of Priority_Specific_Dispatching forces ceiling + -- locking policy. + + if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then + Error_Msg_Sloc := Locking_Policy_Sloc; + Error_Pragma + ("Priority_Specific_Dispatching incompatible " + & "with Locking_Policy#"); + + -- Set the Ceiling_Locking policy, but preserve System_Location + -- since we like the error message with the run time name. + + else + Locking_Policy := 'C'; + + if Locking_Policy_Sloc /= System_Location then + Locking_Policy_Sloc := Loc; + end if; + end if; + + -- Add entry in the table + + Specific_Dispatching.Append + ((Dispatching_Policy => DP, + First_Priority => UI_To_Int (Lower_Val), + Last_Priority => UI_To_Int (Upper_Val), + Pragma_Loc => Loc)); + end if; + end Priority_Specific_Dispatching; + + ------------- + -- Profile -- + ------------- + + -- pragma Profile (profile_IDENTIFIER); + + -- profile_IDENTIFIER => Restricted | Ravenscar + + when Pragma_Profile => + Ada_2005_Pragma; + Check_Arg_Count (1); + Check_Valid_Configuration_Pragma; + Check_No_Identifiers; + + declare + Argx : constant Node_Id := Get_Pragma_Arg (Arg1); + begin + if Chars (Argx) = Name_Ravenscar then + Set_Ravenscar_Profile (N); + elsif Chars (Argx) = Name_Restricted then + Set_Profile_Restrictions + (Restricted, N, Warn => Treat_Restrictions_As_Warnings); + else + Error_Pragma_Arg ("& is not a valid profile", Argx); + end if; + end; + + ---------------------- + -- Profile_Warnings -- + ---------------------- + + -- pragma Profile_Warnings (profile_IDENTIFIER); + + -- profile_IDENTIFIER => Restricted | Ravenscar + + when Pragma_Profile_Warnings => + GNAT_Pragma; + Check_Arg_Count (1); + Check_Valid_Configuration_Pragma; + Check_No_Identifiers; + + declare + Argx : constant Node_Id := Get_Pragma_Arg (Arg1); + begin + if Chars (Argx) = Name_Ravenscar then + Set_Profile_Restrictions (Ravenscar, N, Warn => True); + elsif Chars (Argx) = Name_Restricted then + Set_Profile_Restrictions (Restricted, N, Warn => True); + else + Error_Pragma_Arg ("& is not a valid profile", Argx); + end if; + end; + + -------------------------- + -- Propagate_Exceptions -- + -------------------------- + + -- pragma Propagate_Exceptions; + + -- Note: this pragma is obsolete and has no effect + + when Pragma_Propagate_Exceptions => + GNAT_Pragma; + Check_Arg_Count (0); + + if In_Extended_Main_Source_Unit (N) then + Propagate_Exceptions := True; + end if; + + ------------------ + -- Psect_Object -- + ------------------ + + -- pragma Psect_Object ( + -- [Internal =>] LOCAL_NAME, + -- [, [External =>] EXTERNAL_SYMBOL] + -- [, [Size =>] EXTERNAL_SYMBOL]); + + when Pragma_Psect_Object | Pragma_Common_Object => + Psect_Object : declare + Args : Args_List (1 .. 3); + Names : constant Name_List (1 .. 3) := ( + Name_Internal, + Name_External, + Name_Size); + + Internal : Node_Id renames Args (1); + External : Node_Id renames Args (2); + Size : Node_Id renames Args (3); + + Def_Id : Entity_Id; + + procedure Check_Too_Long (Arg : Node_Id); + -- Posts message if the argument is an identifier with more + -- than 31 characters, or a string literal with more than + -- 31 characters, and we are operating under VMS + + -------------------- + -- Check_Too_Long -- + -------------------- + + procedure Check_Too_Long (Arg : Node_Id) is + X : constant Node_Id := Original_Node (Arg); + + begin + if not Nkind_In (X, N_String_Literal, N_Identifier) then + Error_Pragma_Arg + ("inappropriate argument for pragma %", Arg); + end if; + + if OpenVMS_On_Target then + if (Nkind (X) = N_String_Literal + and then String_Length (Strval (X)) > 31) + or else + (Nkind (X) = N_Identifier + and then Length_Of_Name (Chars (X)) > 31) + then + Error_Pragma_Arg + ("argument for pragma % is longer than 31 characters", + Arg); + end if; + end if; + end Check_Too_Long; + + -- Start of processing for Common_Object/Psect_Object + + begin + GNAT_Pragma; + Gather_Associations (Names, Args); + Process_Extended_Import_Export_Internal_Arg (Internal); + + Def_Id := Entity (Internal); + + if not Ekind_In (Def_Id, E_Constant, E_Variable) then + Error_Pragma_Arg + ("pragma% must designate an object", Internal); + end if; + + Check_Too_Long (Internal); + + if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then + Error_Pragma_Arg + ("cannot use pragma% for imported/exported object", + Internal); + end if; + + if Is_Concurrent_Type (Etype (Internal)) then + Error_Pragma_Arg + ("cannot specify pragma % for task/protected object", + Internal); + end if; + + if Has_Rep_Pragma (Def_Id, Name_Common_Object) + or else + Has_Rep_Pragma (Def_Id, Name_Psect_Object) + then + Error_Msg_N ("?duplicate Common/Psect_Object pragma", N); + end if; + + if Ekind (Def_Id) = E_Constant then + Error_Pragma_Arg + ("cannot specify pragma % for a constant", Internal); + end if; + + if Is_Record_Type (Etype (Internal)) then + declare + Ent : Entity_Id; + Decl : Entity_Id; + + begin + Ent := First_Entity (Etype (Internal)); + while Present (Ent) loop + Decl := Declaration_Node (Ent); + + if Ekind (Ent) = E_Component + and then Nkind (Decl) = N_Component_Declaration + and then Present (Expression (Decl)) + and then Warn_On_Export_Import + then + Error_Msg_N + ("?object for pragma % has defaults", Internal); + exit; + + else + Next_Entity (Ent); + end if; + end loop; + end; + end if; + + if Present (Size) then + Check_Too_Long (Size); + end if; + + if Present (External) then + Check_Arg_Is_External_Name (External); + Check_Too_Long (External); + end if; + + -- If all error tests pass, link pragma on to the rep item chain + + Record_Rep_Item (Def_Id, N); + end Psect_Object; + + ---------- + -- Pure -- + ---------- + + -- pragma Pure [(library_unit_NAME)]; + + when Pragma_Pure => Pure : declare + Ent : Entity_Id; + + begin + Check_Ada_83_Warning; + Check_Valid_Library_Unit_Pragma; + + if Nkind (N) = N_Null_Statement then + return; + end if; + + Ent := Find_Lib_Unit_Name; + Set_Is_Pure (Ent); + Set_Has_Pragma_Pure (Ent); + Set_Suppress_Elaboration_Warnings (Ent); + end Pure; + + ------------- + -- Pure_05 -- + ------------- + + -- pragma Pure_05 [(library_unit_NAME)]; + + -- This pragma is useable only in GNAT_Mode, where it is used like + -- pragma Pure but it is only effective in Ada 2005 mode (otherwise + -- it is ignored). It may be used after a pragma Preelaborate, in + -- which case it overrides the effect of the pragma Preelaborate. + -- This is used to implement AI-362 which recategorizes some run-time + -- packages in Ada 2005 mode. + + when Pragma_Pure_05 => Pure_05 : declare + Ent : Entity_Id; + + begin + GNAT_Pragma; + Check_Valid_Library_Unit_Pragma; + + if not GNAT_Mode then + Error_Pragma ("pragma% only available in GNAT mode"); + end if; + + if Nkind (N) = N_Null_Statement then + return; + end if; + + -- This is one of the few cases where we need to test the value of + -- Ada_Version_Explicit rather than Ada_Version (which is always + -- set to Ada_2012 in a predefined unit), we need to know the + -- explicit version set to know if this pragma is active. + + if Ada_Version_Explicit >= Ada_2005 then + Ent := Find_Lib_Unit_Name; + Set_Is_Preelaborated (Ent, False); + Set_Is_Pure (Ent); + Set_Suppress_Elaboration_Warnings (Ent); + end if; + end Pure_05; + + ------------------- + -- Pure_Function -- + ------------------- + + -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME); + + when Pragma_Pure_Function => Pure_Function : declare + E_Id : Node_Id; + E : Entity_Id; + Def_Id : Entity_Id; + Effective : Boolean := False; + + begin + GNAT_Pragma; + Check_Arg_Count (1); + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Arg_Is_Local_Name (Arg1); + E_Id := Get_Pragma_Arg (Arg1); + + if Error_Posted (E_Id) then + return; + end if; + + -- Loop through homonyms (overloadings) of referenced entity + + E := Entity (E_Id); + + if Present (E) then + loop + Def_Id := Get_Base_Subprogram (E); + + if not Ekind_In (Def_Id, E_Function, + E_Generic_Function, + E_Operator) + then + Error_Pragma_Arg + ("pragma% requires a function name", Arg1); + end if; + + Set_Is_Pure (Def_Id, Sense); + + if not Has_Pragma_Pure_Function (Def_Id) then + Set_Has_Pragma_Pure_Function (Def_Id, Sense); + Effective := Sense; + end if; + + exit when From_Aspect_Specification (N); + E := Homonym (E); + exit when No (E) or else Scope (E) /= Current_Scope; + end loop; + + if Sense and then not Effective + and then Warn_On_Redundant_Constructs + then + Error_Msg_NE + ("pragma Pure_Function on& is redundant?", + N, Entity (E_Id)); + end if; + end if; + end Pure_Function; + + -------------------- + -- Queuing_Policy -- + -------------------- + + -- pragma Queuing_Policy (policy_IDENTIFIER); + + when Pragma_Queuing_Policy => declare + QP : Character; + + begin + Check_Ada_83_Warning; + Check_Arg_Count (1); + Check_No_Identifiers; + Check_Arg_Is_Queuing_Policy (Arg1); + Check_Valid_Configuration_Pragma; + Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); + QP := Fold_Upper (Name_Buffer (1)); + + if Queuing_Policy /= ' ' + and then Queuing_Policy /= QP + then + Error_Msg_Sloc := Queuing_Policy_Sloc; + Error_Pragma ("queuing policy incompatible with policy#"); + + -- Set new policy, but always preserve System_Location since we + -- like the error message with the run time name. + + else + Queuing_Policy := QP; + + if Queuing_Policy_Sloc /= System_Location then + Queuing_Policy_Sloc := Loc; + end if; + end if; + end; + + ----------------------- + -- Relative_Deadline -- + ----------------------- + + -- pragma Relative_Deadline (time_span_EXPRESSION); + + when Pragma_Relative_Deadline => Relative_Deadline : declare + P : constant Node_Id := Parent (N); + Arg : Node_Id; + + begin + Ada_2005_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + + Arg := Get_Pragma_Arg (Arg1); + + -- The expression must be analyzed in the special manner described + -- in "Handling of Default and Per-Object Expressions" in sem.ads. + + Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span)); + + -- Subprogram case + + if Nkind (P) = N_Subprogram_Body then + Check_In_Main_Program; + + -- Tasks + + elsif Nkind (P) = N_Task_Definition then + null; + + -- Anything else is incorrect + + else + Pragma_Misplaced; + end if; + + if Has_Relative_Deadline_Pragma (P) then + Error_Pragma ("duplicate pragma% not allowed"); + else + Set_Has_Relative_Deadline_Pragma (P, True); + + if Nkind (P) = N_Task_Definition then + Record_Rep_Item (Defining_Identifier (Parent (P)), N); + end if; + end if; + end Relative_Deadline; + + --------------------------- + -- Remote_Call_Interface -- + --------------------------- + + -- pragma Remote_Call_Interface [(library_unit_NAME)]; + + when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare + Cunit_Node : Node_Id; + Cunit_Ent : Entity_Id; + K : Node_Kind; + + begin + Check_Ada_83_Warning; + Check_Valid_Library_Unit_Pragma; + + if Nkind (N) = N_Null_Statement then + return; + end if; + + Cunit_Node := Cunit (Current_Sem_Unit); + K := Nkind (Unit (Cunit_Node)); + Cunit_Ent := Cunit_Entity (Current_Sem_Unit); + + if K = N_Package_Declaration + or else K = N_Generic_Package_Declaration + or else K = N_Subprogram_Declaration + or else K = N_Generic_Subprogram_Declaration + or else (K = N_Subprogram_Body + and then Acts_As_Spec (Unit (Cunit_Node))) + then + null; + else + Error_Pragma ( + "pragma% must apply to package or subprogram declaration"); + end if; + + Set_Is_Remote_Call_Interface (Cunit_Ent); + end Remote_Call_Interface; + + ------------------ + -- Remote_Types -- + ------------------ + + -- pragma Remote_Types [(library_unit_NAME)]; + + when Pragma_Remote_Types => Remote_Types : declare + Cunit_Node : Node_Id; + Cunit_Ent : Entity_Id; + + begin + Check_Ada_83_Warning; + Check_Valid_Library_Unit_Pragma; + + if Nkind (N) = N_Null_Statement then + return; + end if; + + Cunit_Node := Cunit (Current_Sem_Unit); + Cunit_Ent := Cunit_Entity (Current_Sem_Unit); + + if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration, + N_Generic_Package_Declaration) + then + Error_Pragma + ("pragma% can only apply to a package declaration"); + end if; + + Set_Is_Remote_Types (Cunit_Ent); + end Remote_Types; + + --------------- + -- Ravenscar -- + --------------- + + -- pragma Ravenscar; + + when Pragma_Ravenscar => + GNAT_Pragma; + Check_Arg_Count (0); + Check_Valid_Configuration_Pragma; + Set_Ravenscar_Profile (N); + + if Warn_On_Obsolescent_Feature then + Error_Msg_N ("pragma Ravenscar is an obsolescent feature?", N); + Error_Msg_N ("|use pragma Profile (Ravenscar) instead", N); + end if; + + ------------------------- + -- Restricted_Run_Time -- + ------------------------- + + -- pragma Restricted_Run_Time; + + when Pragma_Restricted_Run_Time => + GNAT_Pragma; + Check_Arg_Count (0); + Check_Valid_Configuration_Pragma; + Set_Profile_Restrictions + (Restricted, N, Warn => Treat_Restrictions_As_Warnings); + + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("pragma Restricted_Run_Time is an obsolescent feature?", N); + Error_Msg_N ("|use pragma Profile (Restricted) instead", N); + end if; + + ------------------ + -- Restrictions -- + ------------------ + + -- pragma Restrictions (RESTRICTION {, RESTRICTION}); + + -- RESTRICTION ::= + -- restriction_IDENTIFIER + -- | restriction_parameter_IDENTIFIER => EXPRESSION + + when Pragma_Restrictions => + Process_Restrictions_Or_Restriction_Warnings + (Warn => Treat_Restrictions_As_Warnings); + + -------------------------- + -- Restriction_Warnings -- + -------------------------- + + -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION}); + + -- RESTRICTION ::= + -- restriction_IDENTIFIER + -- | restriction_parameter_IDENTIFIER => EXPRESSION + + when Pragma_Restriction_Warnings => + GNAT_Pragma; + Process_Restrictions_Or_Restriction_Warnings (Warn => True); + + ---------------- + -- Reviewable -- + ---------------- + + -- pragma Reviewable; + + when Pragma_Reviewable => + Check_Ada_83_Warning; + Check_Arg_Count (0); + + -- Call dummy debugging function rv. This is done to assist front + -- end debugging. By placing a Reviewable pragma in the source + -- program, a breakpoint on rv catches this place in the source, + -- allowing convenient stepping to the point of interest. + + rv; + + -------------------------- + -- Short_Circuit_And_Or -- + -------------------------- + + when Pragma_Short_Circuit_And_Or => + GNAT_Pragma; + Check_Arg_Count (0); + Check_Valid_Configuration_Pragma; + Short_Circuit_And_Or := True; + + ------------------- + -- Share_Generic -- + ------------------- + + -- pragma Share_Generic (NAME {, NAME}); + + when Pragma_Share_Generic => + GNAT_Pragma; + Process_Generic_List; + + ------------ + -- Shared -- + ------------ + + -- pragma Shared (LOCAL_NAME); + + when Pragma_Shared => + GNAT_Pragma; + Process_Atomic_Shared_Volatile; + + -------------------- + -- Shared_Passive -- + -------------------- + + -- pragma Shared_Passive [(library_unit_NAME)]; + + -- Set the flag Is_Shared_Passive of program unit name entity + + when Pragma_Shared_Passive => Shared_Passive : declare + Cunit_Node : Node_Id; + Cunit_Ent : Entity_Id; + + begin + Check_Ada_83_Warning; + Check_Valid_Library_Unit_Pragma; + + if Nkind (N) = N_Null_Statement then + return; + end if; + + Cunit_Node := Cunit (Current_Sem_Unit); + Cunit_Ent := Cunit_Entity (Current_Sem_Unit); + + if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration, + N_Generic_Package_Declaration) + then + Error_Pragma + ("pragma% can only apply to a package declaration"); + end if; + + Set_Is_Shared_Passive (Cunit_Ent); + end Shared_Passive; + + ----------------------- + -- Short_Descriptors -- + ----------------------- + + -- pragma Short_Descriptors; + + when Pragma_Short_Descriptors => + GNAT_Pragma; + Check_Arg_Count (0); + Check_Valid_Configuration_Pragma; + Short_Descriptors := True; + + ---------------------- + -- Source_File_Name -- + ---------------------- + + -- There are five forms for this pragma: + + -- pragma Source_File_Name ( + -- [UNIT_NAME =>] unit_NAME, + -- BODY_FILE_NAME => STRING_LITERAL + -- [, [INDEX =>] INTEGER_LITERAL]); + + -- pragma Source_File_Name ( + -- [UNIT_NAME =>] unit_NAME, + -- SPEC_FILE_NAME => STRING_LITERAL + -- [, [INDEX =>] INTEGER_LITERAL]); + + -- pragma Source_File_Name ( + -- BODY_FILE_NAME => STRING_LITERAL + -- [, DOT_REPLACEMENT => STRING_LITERAL] + -- [, CASING => CASING_SPEC]); + + -- pragma Source_File_Name ( + -- SPEC_FILE_NAME => STRING_LITERAL + -- [, DOT_REPLACEMENT => STRING_LITERAL] + -- [, CASING => CASING_SPEC]); + + -- pragma Source_File_Name ( + -- SUBUNIT_FILE_NAME => STRING_LITERAL + -- [, DOT_REPLACEMENT => STRING_LITERAL] + -- [, CASING => CASING_SPEC]); + + -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase + + -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma + -- Source_File_Name (SFN), however their usage is exclusive: SFN can + -- only be used when no project file is used, while SFNP can only be + -- used when a project file is used. + + -- No processing here. Processing was completed during parsing, since + -- we need to have file names set as early as possible. Units are + -- loaded well before semantic processing starts. + + -- The only processing we defer to this point is the check for + -- correct placement. + + when Pragma_Source_File_Name => + GNAT_Pragma; + Check_Valid_Configuration_Pragma; + + ------------------------------ + -- Source_File_Name_Project -- + ------------------------------ + + -- See Source_File_Name for syntax + + -- No processing here. Processing was completed during parsing, since + -- we need to have file names set as early as possible. Units are + -- loaded well before semantic processing starts. + + -- The only processing we defer to this point is the check for + -- correct placement. + + when Pragma_Source_File_Name_Project => + GNAT_Pragma; + Check_Valid_Configuration_Pragma; + + -- Check that a pragma Source_File_Name_Project is used only in a + -- configuration pragmas file. + + -- Pragmas Source_File_Name_Project should only be generated by + -- the Project Manager in configuration pragmas files. + + -- This is really an ugly test. It seems to depend on some + -- accidental and undocumented property. At the very least it + -- needs to be documented, but it would be better to have a + -- clean way of testing if we are in a configuration file??? + + if Present (Parent (N)) then + Error_Pragma + ("pragma% can only appear in a configuration pragmas file"); + end if; + + ---------------------- + -- Source_Reference -- + ---------------------- + + -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]); + + -- Nothing to do, all processing completed in Par.Prag, since we need + -- the information for possible parser messages that are output. + + when Pragma_Source_Reference => + GNAT_Pragma; + + -------------------------------- + -- Static_Elaboration_Desired -- + -------------------------------- + + -- pragma Static_Elaboration_Desired (DIRECT_NAME); + + when Pragma_Static_Elaboration_Desired => + GNAT_Pragma; + Check_At_Most_N_Arguments (1); + + if Is_Compilation_Unit (Current_Scope) + and then Ekind (Current_Scope) = E_Package + then + Set_Static_Elaboration_Desired (Current_Scope, True); + else + Error_Pragma ("pragma% must apply to a library-level package"); + end if; + + ------------------ + -- Storage_Size -- + ------------------ + + -- pragma Storage_Size (EXPRESSION); + + when Pragma_Storage_Size => Storage_Size : declare + P : constant Node_Id := Parent (N); + Arg : Node_Id; + + begin + Check_No_Identifiers; + Check_Arg_Count (1); + + -- The expression must be analyzed in the special manner described + -- in "Handling of Default Expressions" in sem.ads. + + Arg := Get_Pragma_Arg (Arg1); + Preanalyze_Spec_Expression (Arg, Any_Integer); + + if not Is_Static_Expression (Arg) then + Check_Restriction (Static_Storage_Size, Arg); + end if; + + if Nkind (P) /= N_Task_Definition then + Pragma_Misplaced; + return; + + else + if Has_Storage_Size_Pragma (P) then + Error_Pragma ("duplicate pragma% not allowed"); + else + Set_Has_Storage_Size_Pragma (P, True); + end if; + + Record_Rep_Item (Defining_Identifier (Parent (P)), N); + -- ??? exp_ch9 should use this! + end if; + end Storage_Size; + + ------------------ + -- Storage_Unit -- + ------------------ + + -- pragma Storage_Unit (NUMERIC_LITERAL); + + -- Only permitted argument is System'Storage_Unit value + + when Pragma_Storage_Unit => + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Integer_Literal (Arg1); + + if Intval (Get_Pragma_Arg (Arg1)) /= + UI_From_Int (Ttypes.System_Storage_Unit) + then + Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit); + Error_Pragma_Arg + ("the only allowed argument for pragma% is ^", Arg1); + end if; + + -------------------- + -- Stream_Convert -- + -------------------- + + -- pragma Stream_Convert ( + -- [Entity =>] type_LOCAL_NAME, + -- [Read =>] function_NAME, + -- [Write =>] function NAME); + + when Pragma_Stream_Convert => Stream_Convert : declare + + procedure Check_OK_Stream_Convert_Function (Arg : Node_Id); + -- Check that the given argument is the name of a local function + -- of one argument that is not overloaded earlier in the current + -- local scope. A check is also made that the argument is a + -- function with one parameter. + + -------------------------------------- + -- Check_OK_Stream_Convert_Function -- + -------------------------------------- + + procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is + Ent : Entity_Id; + + begin + Check_Arg_Is_Local_Name (Arg); + Ent := Entity (Get_Pragma_Arg (Arg)); + + if Has_Homonym (Ent) then + Error_Pragma_Arg + ("argument for pragma% may not be overloaded", Arg); + end if; + + if Ekind (Ent) /= E_Function + or else No (First_Formal (Ent)) + or else Present (Next_Formal (First_Formal (Ent))) + then + Error_Pragma_Arg + ("argument for pragma% must be" & + " function of one argument", Arg); + end if; + end Check_OK_Stream_Convert_Function; + + -- Start of processing for Stream_Convert + + begin + GNAT_Pragma; + Check_Arg_Order ((Name_Entity, Name_Read, Name_Write)); + Check_Arg_Count (3); + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Optional_Identifier (Arg2, Name_Read); + Check_Optional_Identifier (Arg3, Name_Write); + Check_Arg_Is_Local_Name (Arg1); + Check_OK_Stream_Convert_Function (Arg2); + Check_OK_Stream_Convert_Function (Arg3); + + declare + Typ : constant Entity_Id := + Underlying_Type (Entity (Get_Pragma_Arg (Arg1))); + Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2)); + Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3)); + + begin + Check_First_Subtype (Arg1); + + -- Check for too early or too late. Note that we don't enforce + -- the rule about primitive operations in this case, since, as + -- is the case for explicit stream attributes themselves, these + -- restrictions are not appropriate. Note that the chaining of + -- the pragma by Rep_Item_Too_Late is actually the critical + -- processing done for this pragma. + + if Rep_Item_Too_Early (Typ, N) + or else + Rep_Item_Too_Late (Typ, N, FOnly => True) + then + return; + end if; + + -- Return if previous error + + if Etype (Typ) = Any_Type + or else + Etype (Read) = Any_Type + or else + Etype (Write) = Any_Type + then + return; + end if; + + -- Error checks + + if Underlying_Type (Etype (Read)) /= Typ then + Error_Pragma_Arg + ("incorrect return type for function&", Arg2); + end if; + + if Underlying_Type (Etype (First_Formal (Write))) /= Typ then + Error_Pragma_Arg + ("incorrect parameter type for function&", Arg3); + end if; + + if Underlying_Type (Etype (First_Formal (Read))) /= + Underlying_Type (Etype (Write)) + then + Error_Pragma_Arg + ("result type of & does not match Read parameter type", + Arg3); + end if; + end; + end Stream_Convert; + + ------------------------- + -- Style_Checks (GNAT) -- + ------------------------- + + -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); + + -- This is processed by the parser since some of the style checks + -- take place during source scanning and parsing. This means that + -- we don't need to issue error messages here. + + when Pragma_Style_Checks => Style_Checks : declare + A : constant Node_Id := Get_Pragma_Arg (Arg1); + S : String_Id; + C : Char_Code; + + begin + GNAT_Pragma; + Check_No_Identifiers; + + -- Two argument form + + if Arg_Count = 2 then + Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); + + declare + E_Id : Node_Id; + E : Entity_Id; + + begin + E_Id := Get_Pragma_Arg (Arg2); + Analyze (E_Id); + + if not Is_Entity_Name (E_Id) then + Error_Pragma_Arg + ("second argument of pragma% must be entity name", + Arg2); + end if; + + E := Entity (E_Id); + + if E = Any_Id then + return; + else + loop + Set_Suppress_Style_Checks (E, + (Chars (Get_Pragma_Arg (Arg1)) = Name_Off)); + exit when No (Homonym (E)); + E := Homonym (E); + end loop; + end if; + end; + + -- One argument form + + else + Check_Arg_Count (1); + + if Nkind (A) = N_String_Literal then + S := Strval (A); + + declare + Slen : constant Natural := Natural (String_Length (S)); + Options : String (1 .. Slen); + J : Natural; + + begin + J := 1; + loop + C := Get_String_Char (S, Int (J)); + exit when not In_Character_Range (C); + Options (J) := Get_Character (C); + + -- If at end of string, set options. As per discussion + -- above, no need to check for errors, since we issued + -- them in the parser. + + if J = Slen then + Set_Style_Check_Options (Options); + exit; + end if; + + J := J + 1; + end loop; + end; + + elsif Nkind (A) = N_Identifier then + if Chars (A) = Name_All_Checks then + if GNAT_Mode then + Set_GNAT_Style_Check_Options; + else + Set_Default_Style_Check_Options; + end if; + + elsif Chars (A) = Name_On then + Style_Check := True; + + elsif Chars (A) = Name_Off then + Style_Check := False; + end if; + end if; + end if; + end Style_Checks; + + -------------- + -- Subtitle -- + -------------- + + -- pragma Subtitle ([Subtitle =>] STRING_LITERAL); + + when Pragma_Subtitle => + GNAT_Pragma; + Check_Arg_Count (1); + Check_Optional_Identifier (Arg1, Name_Subtitle); + Check_Arg_Is_Static_Expression (Arg1, Standard_String); + Store_Note (N); + + -------------- + -- Suppress -- + -------------- + + -- pragma Suppress (IDENTIFIER [, [On =>] NAME]); + + when Pragma_Suppress => + Process_Suppress_Unsuppress (True); + + ------------------ + -- Suppress_All -- + ------------------ + + -- pragma Suppress_All; + + -- The only check made here is that the pragma has no arguments. + -- There are no placement rules, and the processing required (setting + -- the Has_Pragma_Suppress_All flag in the compilation unit node was + -- taken care of by the parser). Process_Compilation_Unit_Pragmas + -- then creates and inserts a pragma Suppress (All_Checks). + + when Pragma_Suppress_All => + GNAT_Pragma; + Check_Arg_Count (0); + + ------------------------- + -- Suppress_Debug_Info -- + ------------------------- + + -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME); + + when Pragma_Suppress_Debug_Info => + GNAT_Pragma; + Check_Arg_Count (1); + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Arg_Is_Local_Name (Arg1); + Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)), Sense); + + ---------------------------------- + -- Suppress_Exception_Locations -- + ---------------------------------- + + -- pragma Suppress_Exception_Locations; + + when Pragma_Suppress_Exception_Locations => + GNAT_Pragma; + Check_Arg_Count (0); + Check_Valid_Configuration_Pragma; + Exception_Locations_Suppressed := True; + + ----------------------------- + -- Suppress_Initialization -- + ----------------------------- + + -- pragma Suppress_Initialization ([Entity =>] type_Name); + + when Pragma_Suppress_Initialization => Suppress_Init : declare + E_Id : Node_Id; + E : Entity_Id; + + begin + GNAT_Pragma; + Check_Arg_Count (1); + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Arg_Is_Local_Name (Arg1); + + E_Id := Get_Pragma_Arg (Arg1); + + if Etype (E_Id) = Any_Type then + return; + end if; + + E := Entity (E_Id); + + if Is_Type (E) then + if Is_Incomplete_Or_Private_Type (E) then + if No (Full_View (Base_Type (E))) then + Error_Pragma_Arg + ("argument of pragma% cannot be an incomplete type", + Arg1); + else + Set_Suppress_Init_Proc (Full_View (Base_Type (E))); + end if; + else + Set_Suppress_Init_Proc (Base_Type (E)); + end if; + + else + Error_Pragma_Arg + ("pragma% requires argument that is a type name", Arg1); + end if; + end Suppress_Init; + + ----------------- + -- System_Name -- + ----------------- + + -- pragma System_Name (DIRECT_NAME); + + -- Syntax check: one argument, which must be the identifier GNAT or + -- the identifier GCC, no other identifiers are acceptable. + + when Pragma_System_Name => + GNAT_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat); + + ----------------------------- + -- Task_Dispatching_Policy -- + ----------------------------- + + -- pragma Task_Dispatching_Policy (policy_IDENTIFIER); + + when Pragma_Task_Dispatching_Policy => declare + DP : Character; + + begin + Check_Ada_83_Warning; + Check_Arg_Count (1); + Check_No_Identifiers; + Check_Arg_Is_Task_Dispatching_Policy (Arg1); + Check_Valid_Configuration_Pragma; + Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); + DP := Fold_Upper (Name_Buffer (1)); + + if Task_Dispatching_Policy /= ' ' + and then Task_Dispatching_Policy /= DP + then + Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; + Error_Pragma + ("task dispatching policy incompatible with policy#"); + + -- Set new policy, but always preserve System_Location since we + -- like the error message with the run time name. + + else + Task_Dispatching_Policy := DP; + + if Task_Dispatching_Policy_Sloc /= System_Location then + Task_Dispatching_Policy_Sloc := Loc; + end if; + end if; + end; + + -------------- + -- Task_Info -- + -------------- + + -- pragma Task_Info (EXPRESSION); + + when Pragma_Task_Info => Task_Info : declare + P : constant Node_Id := Parent (N); + + begin + GNAT_Pragma; + + if Nkind (P) /= N_Task_Definition then + Error_Pragma ("pragma% must appear in task definition"); + end if; + + Check_No_Identifiers; + Check_Arg_Count (1); + + Analyze_And_Resolve + (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type)); + + if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then + return; + end if; + + if Has_Task_Info_Pragma (P) then + Error_Pragma ("duplicate pragma% not allowed"); + else + Set_Has_Task_Info_Pragma (P, True); + end if; + end Task_Info; + + --------------- + -- Task_Name -- + --------------- + + -- pragma Task_Name (string_EXPRESSION); + + when Pragma_Task_Name => Task_Name : declare + P : constant Node_Id := Parent (N); + Arg : Node_Id; + + begin + Check_No_Identifiers; + Check_Arg_Count (1); + + Arg := Get_Pragma_Arg (Arg1); + + -- The expression is used in the call to Create_Task, and must be + -- expanded there, not in the context of the current spec. It must + -- however be analyzed to capture global references, in case it + -- appears in a generic context. + + Preanalyze_And_Resolve (Arg, Standard_String); + + if Nkind (P) /= N_Task_Definition then + Pragma_Misplaced; + end if; + + if Has_Task_Name_Pragma (P) then + Error_Pragma ("duplicate pragma% not allowed"); + else + Set_Has_Task_Name_Pragma (P, True); + Record_Rep_Item (Defining_Identifier (Parent (P)), N); + end if; + end Task_Name; + + ------------------ + -- Task_Storage -- + ------------------ + + -- pragma Task_Storage ( + -- [Task_Type =>] LOCAL_NAME, + -- [Top_Guard =>] static_integer_EXPRESSION); + + when Pragma_Task_Storage => Task_Storage : declare + Args : Args_List (1 .. 2); + Names : constant Name_List (1 .. 2) := ( + Name_Task_Type, + Name_Top_Guard); + + Task_Type : Node_Id renames Args (1); + Top_Guard : Node_Id renames Args (2); + + Ent : Entity_Id; + + begin + GNAT_Pragma; + Gather_Associations (Names, Args); + + if No (Task_Type) then + Error_Pragma + ("missing task_type argument for pragma%"); + end if; + + Check_Arg_Is_Local_Name (Task_Type); + + Ent := Entity (Task_Type); + + if not Is_Task_Type (Ent) then + Error_Pragma_Arg + ("argument for pragma% must be task type", Task_Type); + end if; + + if No (Top_Guard) then + Error_Pragma_Arg + ("pragma% takes two arguments", Task_Type); + else + Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer); + end if; + + Check_First_Subtype (Task_Type); + + if Rep_Item_Too_Late (Ent, N) then + raise Pragma_Exit; + end if; + end Task_Storage; + + -------------------------- + -- Thread_Local_Storage -- + -------------------------- + + -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME); + + when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare + Id : Node_Id; + E : Entity_Id; + + begin + GNAT_Pragma; + Check_Arg_Count (1); + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Arg_Is_Library_Level_Local_Name (Arg1); + + Id := Get_Pragma_Arg (Arg1); + Analyze (Id); + + if not Is_Entity_Name (Id) + or else Ekind (Entity (Id)) /= E_Variable + then + Error_Pragma_Arg ("local variable name required", Arg1); + end if; + + E := Entity (Id); + + if Rep_Item_Too_Early (E, N) + or else Rep_Item_Too_Late (E, N) + then + raise Pragma_Exit; + end if; + + Set_Has_Pragma_Thread_Local_Storage (E); + Set_Has_Gigi_Rep_Item (E); + end Thread_Local_Storage; + + ---------------- + -- Time_Slice -- + ---------------- + + -- pragma Time_Slice (static_duration_EXPRESSION); + + when Pragma_Time_Slice => Time_Slice : declare + Val : Ureal; + Nod : Node_Id; + + begin + GNAT_Pragma; + Check_Arg_Count (1); + Check_No_Identifiers; + Check_In_Main_Program; + Check_Arg_Is_Static_Expression (Arg1, Standard_Duration); + + if not Error_Posted (Arg1) then + Nod := Next (N); + while Present (Nod) loop + if Nkind (Nod) = N_Pragma + and then Pragma_Name (Nod) = Name_Time_Slice + then + Error_Msg_Name_1 := Pname; + Error_Msg_N ("duplicate pragma% not permitted", Nod); + end if; + + Next (Nod); + end loop; + end if; + + -- Process only if in main unit + + if Get_Source_Unit (Loc) = Main_Unit then + Opt.Time_Slice_Set := True; + Val := Expr_Value_R (Get_Pragma_Arg (Arg1)); + + if Val <= Ureal_0 then + Opt.Time_Slice_Value := 0; + + elsif Val > UR_From_Uint (UI_From_Int (1000)) then + Opt.Time_Slice_Value := 1_000_000_000; + + else + Opt.Time_Slice_Value := + UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000))); + end if; + end if; + end Time_Slice; + + ----------- + -- Title -- + ----------- + + -- pragma Title (TITLING_OPTION [, TITLING OPTION]); + + -- TITLING_OPTION ::= + -- [Title =>] STRING_LITERAL + -- | [Subtitle =>] STRING_LITERAL + + when Pragma_Title => Title : declare + Args : Args_List (1 .. 2); + Names : constant Name_List (1 .. 2) := ( + Name_Title, + Name_Subtitle); + + begin + GNAT_Pragma; + Gather_Associations (Names, Args); + Store_Note (N); + + for J in 1 .. 2 loop + if Present (Args (J)) then + Check_Arg_Is_Static_Expression (Args (J), Standard_String); + end if; + end loop; + end Title; + + --------------------- + -- Unchecked_Union -- + --------------------- + + -- pragma Unchecked_Union (first_subtype_LOCAL_NAME) + + when Pragma_Unchecked_Union => Unchecked_Union : declare + Assoc : constant Node_Id := Arg1; + Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc); + Typ : Entity_Id; + Discr : Entity_Id; + Tdef : Node_Id; + Clist : Node_Id; + Vpart : Node_Id; + Comp : Node_Id; + Variant : Node_Id; + + begin + Ada_2005_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + + Find_Type (Type_Id); + Typ := Entity (Type_Id); + + if Typ = Any_Type + or else Rep_Item_Too_Early (Typ, N) + then + return; + else + Typ := Underlying_Type (Typ); + end if; + + if Rep_Item_Too_Late (Typ, N) then + return; + end if; + + Check_First_Subtype (Arg1); + + -- Note remaining cases are references to a type in the current + -- declarative part. If we find an error, we post the error on + -- the relevant type declaration at an appropriate point. + + if not Is_Record_Type (Typ) then + Error_Msg_N ("Unchecked_Union must be record type", Typ); + return; + + elsif Is_Tagged_Type (Typ) then + Error_Msg_N ("Unchecked_Union must not be tagged", Typ); + return; + + elsif Is_Limited_Type (Typ) then + Error_Msg_N + ("Unchecked_Union must not be limited record type", Typ); + Explain_Limited_Type (Typ, Typ); + return; + + else + if not Has_Discriminants (Typ) then + Error_Msg_N + ("Unchecked_Union must have one discriminant", Typ); + return; + end if; + + Discr := First_Discriminant (Typ); + while Present (Discr) loop + if No (Discriminant_Default_Value (Discr)) then + Error_Msg_N + ("Unchecked_Union discriminant must have default value", + Discr); + end if; + + Next_Discriminant (Discr); + end loop; + + Tdef := Type_Definition (Declaration_Node (Typ)); + Clist := Component_List (Tdef); + + Comp := First (Component_Items (Clist)); + while Present (Comp) loop + Check_Component (Comp, Typ); + Next (Comp); + end loop; + + if No (Clist) or else No (Variant_Part (Clist)) then + Error_Msg_N + ("Unchecked_Union must have variant part", + Tdef); + return; + end if; + + Vpart := Variant_Part (Clist); + + Variant := First (Variants (Vpart)); + while Present (Variant) loop + Check_Variant (Variant, Typ); + Next (Variant); + end loop; + end if; + + Set_Is_Unchecked_Union (Typ, Sense); + + if Sense then + Set_Convention (Typ, Convention_C); + end if; + + Set_Has_Unchecked_Union (Base_Type (Typ), Sense); + Set_Is_Unchecked_Union (Base_Type (Typ), Sense); + end Unchecked_Union; + + ------------------------ + -- Unimplemented_Unit -- + ------------------------ + + -- pragma Unimplemented_Unit; + + -- Note: this only gives an error if we are generating code, or if + -- we are in a generic library unit (where the pragma appears in the + -- body, not in the spec). + + when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare + Cunitent : constant Entity_Id := + Cunit_Entity (Get_Source_Unit (Loc)); + Ent_Kind : constant Entity_Kind := + Ekind (Cunitent); + + begin + GNAT_Pragma; + Check_Arg_Count (0); + + if Operating_Mode = Generate_Code + or else Ent_Kind = E_Generic_Function + or else Ent_Kind = E_Generic_Procedure + or else Ent_Kind = E_Generic_Package + then + Get_Name_String (Chars (Cunitent)); + Set_Casing (Mixed_Case); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Str (" is not supported in this configuration"); + Write_Eol; + raise Unrecoverable_Error; + end if; + end Unimplemented_Unit; + + ------------------------ + -- Universal_Aliasing -- + ------------------------ + + -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)]; + + when Pragma_Universal_Aliasing => Universal_Alias : declare + E_Id : Entity_Id; + + begin + GNAT_Pragma; + Check_Arg_Count (1); + Check_Optional_Identifier (Arg2, Name_Entity); + Check_Arg_Is_Local_Name (Arg1); + E_Id := Entity (Get_Pragma_Arg (Arg1)); + + if E_Id = Any_Type then + return; + elsif No (E_Id) or else not Is_Type (E_Id) then + Error_Pragma_Arg ("pragma% requires type", Arg1); + end if; + + Set_Universal_Aliasing (Implementation_Base_Type (E_Id), Sense); + end Universal_Alias; + + -------------------- + -- Universal_Data -- + -------------------- + + -- pragma Universal_Data [(library_unit_NAME)]; + + when Pragma_Universal_Data => + GNAT_Pragma; + + -- If this is a configuration pragma, then set the universal + -- addressing option, otherwise confirm that the pragma satisfies + -- the requirements of library unit pragma placement and leave it + -- to the GNAAMP back end to detect the pragma (avoids transitive + -- setting of the option due to withed units). + + if Is_Configuration_Pragma then + Universal_Addressing_On_AAMP := True; + else + Check_Valid_Library_Unit_Pragma; + end if; + + if not AAMP_On_Target then + Error_Pragma ("?pragma% ignored (applies only to AAMP)"); + end if; + + ---------------- + -- Unmodified -- + ---------------- + + -- pragma Unmodified (local_Name {, local_Name}); + + when Pragma_Unmodified => Unmodified : declare + Arg_Node : Node_Id; + Arg_Expr : Node_Id; + Arg_Ent : Entity_Id; + + begin + GNAT_Pragma; + Check_At_Least_N_Arguments (1); + + -- Loop through arguments + + Arg_Node := Arg1; + while Present (Arg_Node) loop + Check_No_Identifier (Arg_Node); + + -- Note: the analyze call done by Check_Arg_Is_Local_Name will + -- in fact generate reference, so that the entity will have a + -- reference, which will inhibit any warnings about it not + -- being referenced, and also properly show up in the ali file + -- as a reference. But this reference is recorded before the + -- Has_Pragma_Unreferenced flag is set, so that no warning is + -- generated for this reference. + + Check_Arg_Is_Local_Name (Arg_Node); + Arg_Expr := Get_Pragma_Arg (Arg_Node); + + if Is_Entity_Name (Arg_Expr) then + Arg_Ent := Entity (Arg_Expr); + + if not Is_Assignable (Arg_Ent) then + Error_Pragma_Arg + ("pragma% can only be applied to a variable", + Arg_Expr); + else + Set_Has_Pragma_Unmodified (Arg_Ent, Sense); + end if; + end if; + + Next (Arg_Node); + end loop; + end Unmodified; + + ------------------ + -- Unreferenced -- + ------------------ + + -- pragma Unreferenced (local_Name {, local_Name}); + + -- or when used in a context clause: + + -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME} + + when Pragma_Unreferenced => Unreferenced : declare + Arg_Node : Node_Id; + Arg_Expr : Node_Id; + Arg_Ent : Entity_Id; + Citem : Node_Id; + + begin + GNAT_Pragma; + Check_At_Least_N_Arguments (1); + + -- Check case of appearing within context clause + + if Is_In_Context_Clause then + + -- The arguments must all be units mentioned in a with clause + -- in the same context clause. Note we already checked (in + -- Par.Prag) that the arguments are either identifiers or + -- selected components. + + Arg_Node := Arg1; + while Present (Arg_Node) loop + Citem := First (List_Containing (N)); + while Citem /= N loop + if Nkind (Citem) = N_With_Clause + and then + Same_Name (Name (Citem), Get_Pragma_Arg (Arg_Node)) + then + Set_Has_Pragma_Unreferenced + (Cunit_Entity + (Get_Source_Unit + (Library_Unit (Citem)))); + Set_Unit_Name + (Get_Pragma_Arg (Arg_Node), Name (Citem)); + exit; + end if; + + Next (Citem); + end loop; + + if Citem = N then + Error_Pragma_Arg + ("argument of pragma% is not with'ed unit", Arg_Node); + end if; + + Next (Arg_Node); + end loop; + + -- Case of not in list of context items + + else + Arg_Node := Arg1; + while Present (Arg_Node) loop + Check_No_Identifier (Arg_Node); + + -- Note: the analyze call done by Check_Arg_Is_Local_Name + -- will in fact generate reference, so that the entity will + -- have a reference, which will inhibit any warnings about + -- it not being referenced, and also properly show up in the + -- ali file as a reference. But this reference is recorded + -- before the Has_Pragma_Unreferenced flag is set, so that + -- no warning is generated for this reference. + + Check_Arg_Is_Local_Name (Arg_Node); + Arg_Expr := Get_Pragma_Arg (Arg_Node); + + if Is_Entity_Name (Arg_Expr) then + Arg_Ent := Entity (Arg_Expr); + + -- If the entity is overloaded, the pragma applies to the + -- most recent overloading, as documented. In this case, + -- name resolution does not generate a reference, so it + -- must be done here explicitly. + + if Is_Overloaded (Arg_Expr) then + Generate_Reference (Arg_Ent, N); + end if; + + Set_Has_Pragma_Unreferenced (Arg_Ent, Sense); + end if; + + Next (Arg_Node); + end loop; + end if; + end Unreferenced; + + -------------------------- + -- Unreferenced_Objects -- + -------------------------- + + -- pragma Unreferenced_Objects (local_Name {, local_Name}); + + when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare + Arg_Node : Node_Id; + Arg_Expr : Node_Id; + + begin + GNAT_Pragma; + Check_At_Least_N_Arguments (1); + + Arg_Node := Arg1; + while Present (Arg_Node) loop + Check_No_Identifier (Arg_Node); + Check_Arg_Is_Local_Name (Arg_Node); + Arg_Expr := Get_Pragma_Arg (Arg_Node); + + if not Is_Entity_Name (Arg_Expr) + or else not Is_Type (Entity (Arg_Expr)) + then + Error_Pragma_Arg + ("argument for pragma% must be type or subtype", Arg_Node); + end if; + + Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr), Sense); + Next (Arg_Node); + end loop; + end Unreferenced_Objects; + + ------------------------------ + -- Unreserve_All_Interrupts -- + ------------------------------ + + -- pragma Unreserve_All_Interrupts; + + when Pragma_Unreserve_All_Interrupts => + GNAT_Pragma; + Check_Arg_Count (0); + + if In_Extended_Main_Code_Unit (Main_Unit_Entity) then + Unreserve_All_Interrupts := True; + end if; + + ---------------- + -- Unsuppress -- + ---------------- + + -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]); + + when Pragma_Unsuppress => + Ada_2005_Pragma; + Process_Suppress_Unsuppress (False); + + ------------------- + -- Use_VADS_Size -- + ------------------- + + -- pragma Use_VADS_Size; + + when Pragma_Use_VADS_Size => + GNAT_Pragma; + Check_Arg_Count (0); + Check_Valid_Configuration_Pragma; + Use_VADS_Size := True; + + --------------------- + -- Validity_Checks -- + --------------------- + + -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); + + when Pragma_Validity_Checks => Validity_Checks : declare + A : constant Node_Id := Get_Pragma_Arg (Arg1); + S : String_Id; + C : Char_Code; + + begin + GNAT_Pragma; + Check_Arg_Count (1); + Check_No_Identifiers; + + if Nkind (A) = N_String_Literal then + S := Strval (A); + + declare + Slen : constant Natural := Natural (String_Length (S)); + Options : String (1 .. Slen); + J : Natural; + + begin + J := 1; + loop + C := Get_String_Char (S, Int (J)); + exit when not In_Character_Range (C); + Options (J) := Get_Character (C); + + if J = Slen then + Set_Validity_Check_Options (Options); + exit; + else + J := J + 1; + end if; + end loop; + end; + + elsif Nkind (A) = N_Identifier then + + if Chars (A) = Name_All_Checks then + Set_Validity_Check_Options ("a"); + + elsif Chars (A) = Name_On then + Validity_Checks_On := True; + + elsif Chars (A) = Name_Off then + Validity_Checks_On := False; + + end if; + end if; + end Validity_Checks; + + -------------- + -- Volatile -- + -------------- + + -- pragma Volatile (LOCAL_NAME); + + when Pragma_Volatile => + Process_Atomic_Shared_Volatile; + + ------------------------- + -- Volatile_Components -- + ------------------------- + + -- pragma Volatile_Components (array_LOCAL_NAME); + + -- Volatile is handled by the same circuit as Atomic_Components + + -------------- + -- Warnings -- + -------------- + + -- pragma Warnings (On | Off); + -- pragma Warnings (On | Off, LOCAL_NAME); + -- pragma Warnings (static_string_EXPRESSION); + -- pragma Warnings (On | Off, STRING_LITERAL); + + when Pragma_Warnings => Warnings : begin + GNAT_Pragma; + Check_At_Least_N_Arguments (1); + Check_No_Identifiers; + + -- If debug flag -gnatd.i is set, pragma is ignored + + if Debug_Flag_Dot_I then + return; + end if; + + -- Process various forms of the pragma + + declare + Argx : constant Node_Id := Get_Pragma_Arg (Arg1); + + begin + -- One argument case + + if Arg_Count = 1 then + + -- On/Off one argument case was processed by parser + + if Nkind (Argx) = N_Identifier + and then + (Chars (Argx) = Name_On + or else + Chars (Argx) = Name_Off) + then + null; + + -- One argument case must be ON/OFF or static string expr + + elsif not Is_Static_String_Expression (Arg1) then + Error_Pragma_Arg + ("argument of pragma% must be On/Off or " & + "static string expression", Arg1); + + -- One argument string expression case + + else + declare + Lit : constant Node_Id := Expr_Value_S (Argx); + Str : constant String_Id := Strval (Lit); + Len : constant Nat := String_Length (Str); + C : Char_Code; + J : Nat; + OK : Boolean; + Chr : Character; + + begin + J := 1; + while J <= Len loop + C := Get_String_Char (Str, J); + OK := In_Character_Range (C); + + if OK then + Chr := Get_Character (C); + + -- Dot case + + if J < Len and then Chr = '.' then + J := J + 1; + C := Get_String_Char (Str, J); + Chr := Get_Character (C); + + if not Set_Dot_Warning_Switch (Chr) then + Error_Pragma_Arg + ("invalid warning switch character " & + '.' & Chr, Arg1); + end if; + + -- Non-Dot case + + else + OK := Set_Warning_Switch (Chr); + end if; + end if; + + if not OK then + Error_Pragma_Arg + ("invalid warning switch character " & Chr, + Arg1); + end if; + + J := J + 1; + end loop; + end; + end if; + + -- Two or more arguments (must be two) + + else + Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); + Check_At_Most_N_Arguments (2); + + declare + E_Id : Node_Id; + E : Entity_Id; + Err : Boolean; + + begin + E_Id := Get_Pragma_Arg (Arg2); + Analyze (E_Id); + + -- In the expansion of an inlined body, a reference to + -- the formal may be wrapped in a conversion if the + -- actual is a conversion. Retrieve the real entity name. + + if (In_Instance_Body + or else In_Inlined_Body) + and then Nkind (E_Id) = N_Unchecked_Type_Conversion + then + E_Id := Expression (E_Id); + end if; + + -- Entity name case + + if Is_Entity_Name (E_Id) then + E := Entity (E_Id); + + if E = Any_Id then + return; + else + loop + Set_Warnings_Off + (E, (Chars (Get_Pragma_Arg (Arg1)) = + Name_Off)); + + if Chars (Get_Pragma_Arg (Arg1)) = Name_Off + and then Warn_On_Warnings_Off + then + Warnings_Off_Pragmas.Append ((N, E)); + end if; + + if Is_Enumeration_Type (E) then + declare + Lit : Entity_Id; + begin + Lit := First_Literal (E); + while Present (Lit) loop + Set_Warnings_Off (Lit); + Next_Literal (Lit); + end loop; + end; + end if; + + exit when No (Homonym (E)); + E := Homonym (E); + end loop; + end if; + + -- Error if not entity or static string literal case + + elsif not Is_Static_String_Expression (Arg2) then + Error_Pragma_Arg + ("second argument of pragma% must be entity " & + "name or static string expression", Arg2); + + -- String literal case + + else + String_To_Name_Buffer + (Strval (Expr_Value_S (Get_Pragma_Arg (Arg2)))); + + -- Note on configuration pragma case: If this is a + -- configuration pragma, then for an OFF pragma, we + -- just set Config True in the call, which is all + -- that needs to be done. For the case of ON, this + -- is normally an error, unless it is canceling the + -- effect of a previous OFF pragma in the same file. + -- In any other case, an error will be signalled (ON + -- with no matching OFF). + + if Chars (Argx) = Name_Off then + Set_Specific_Warning_Off + (Loc, Name_Buffer (1 .. Name_Len), + Config => Is_Configuration_Pragma); + + elsif Chars (Argx) = Name_On then + Set_Specific_Warning_On + (Loc, Name_Buffer (1 .. Name_Len), Err); + + if Err then + Error_Msg + ("?pragma Warnings On with no " & + "matching Warnings Off", + Loc); + end if; + end if; + end if; + end; + end if; + end; + end Warnings; + + ------------------- + -- Weak_External -- + ------------------- + + -- pragma Weak_External ([Entity =>] LOCAL_NAME); + + when Pragma_Weak_External => Weak_External : declare + Ent : Entity_Id; + + begin + GNAT_Pragma; + Check_Arg_Count (1); + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Arg_Is_Library_Level_Local_Name (Arg1); + Ent := Entity (Get_Pragma_Arg (Arg1)); + + if Rep_Item_Too_Early (Ent, N) then + return; + else + Ent := Underlying_Type (Ent); + end if; + + -- The only processing required is to link this item on to the + -- list of rep items for the given entity. This is accomplished + -- by the call to Rep_Item_Too_Late (when no error is detected + -- and False is returned). + + if Rep_Item_Too_Late (Ent, N) then + return; + else + Set_Has_Gigi_Rep_Item (Ent); + end if; + end Weak_External; + + ----------------------------- + -- Wide_Character_Encoding -- + ----------------------------- + + -- pragma Wide_Character_Encoding (IDENTIFIER); + + when Pragma_Wide_Character_Encoding => + GNAT_Pragma; + + -- Nothing to do, handled in parser. Note that we do not enforce + -- configuration pragma placement, this pragma can appear at any + -- place in the source, allowing mixed encodings within a single + -- source program. + + null; + + -------------------- + -- Unknown_Pragma -- + -------------------- + + -- Should be impossible, since the case of an unknown pragma is + -- separately processed before the case statement is entered. + + when Unknown_Pragma => + raise Program_Error; + end case; + + -- AI05-0144: detect dangerous order dependence. Disabled for now, + -- until AI is formally approved. + + -- Check_Order_Dependence; + + exception + when Pragma_Exit => null; + end Analyze_Pragma; + + ------------------- + -- Check_Enabled -- + ------------------- + + function Check_Enabled (Nam : Name_Id) return Boolean is + PP : Node_Id; + + begin + -- Loop through entries in check policy list + + PP := Opt.Check_Policy_List; + loop + -- If there are no specific entries that matched, then we let the + -- setting of assertions govern. Note that this provides the needed + -- compatibility with the RM for the cases of assertion, invariant, + -- precondition, predicate, and postcondition. + + if No (PP) then + return Assertions_Enabled; + + -- Here we have an entry see if it matches + + else + declare + PPA : constant List_Id := Pragma_Argument_Associations (PP); + + begin + if Nam = Chars (Get_Pragma_Arg (First (PPA))) then + case (Chars (Get_Pragma_Arg (Last (PPA)))) is + when Name_On | Name_Check => + return True; + when Name_Off | Name_Ignore => + return False; + when others => + raise Program_Error; + end case; + + else + PP := Next_Pragma (PP); + end if; + end; + end if; + end loop; + end Check_Enabled; + + --------------------------------- + -- Delay_Config_Pragma_Analyze -- + --------------------------------- + + function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is + begin + return Pragma_Name (N) = Name_Interrupt_State + or else + Pragma_Name (N) = Name_Priority_Specific_Dispatching; + end Delay_Config_Pragma_Analyze; + + ------------------------- + -- Get_Base_Subprogram -- + ------------------------- + + function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is + Result : Entity_Id; + + begin + -- Follow subprogram renaming chain + + Result := Def_Id; + while Is_Subprogram (Result) + and then + (Is_Generic_Instance (Result) + or else Nkind (Parent (Declaration_Node (Result))) = + N_Subprogram_Renaming_Declaration) + and then Present (Alias (Result)) + loop + Result := Alias (Result); + end loop; + + return Result; + end Get_Base_Subprogram; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Externals.Init; + end Initialize; + + ----------------------------- + -- Is_Config_Static_String -- + ----------------------------- + + function Is_Config_Static_String (Arg : Node_Id) return Boolean is + + function Add_Config_Static_String (Arg : Node_Id) return Boolean; + -- This is an internal recursive function that is just like the outer + -- function except that it adds the string to the name buffer rather + -- than placing the string in the name buffer. + + ------------------------------ + -- Add_Config_Static_String -- + ------------------------------ + + function Add_Config_Static_String (Arg : Node_Id) return Boolean is + N : Node_Id; + C : Char_Code; + + begin + N := Arg; + + if Nkind (N) = N_Op_Concat then + if Add_Config_Static_String (Left_Opnd (N)) then + N := Right_Opnd (N); + else + return False; + end if; + end if; + + if Nkind (N) /= N_String_Literal then + Error_Msg_N ("string literal expected for pragma argument", N); + return False; + + else + for J in 1 .. String_Length (Strval (N)) loop + C := Get_String_Char (Strval (N), J); + + if not In_Character_Range (C) then + Error_Msg + ("string literal contains invalid wide character", + Sloc (N) + 1 + Source_Ptr (J)); + return False; + end if; + + Add_Char_To_Name_Buffer (Get_Character (C)); + end loop; + end if; + + return True; + end Add_Config_Static_String; + + -- Start of processing for Is_Config_Static_String + + begin + + Name_Len := 0; + return Add_Config_Static_String (Arg); + end Is_Config_Static_String; + + ----------------------------------------- + -- Is_Non_Significant_Pragma_Reference -- + ----------------------------------------- + + -- This function makes use of the following static table which indicates + -- whether a given pragma is significant. + + -- -1 indicates that references in any argument position are significant + -- 0 indicates that appearance in any argument is not significant + -- +n indicates that appearance as argument n is significant, but all + -- other arguments are not significant + -- 99 special processing required (e.g. for pragma Check) + + Sig_Flags : constant array (Pragma_Id) of Int := + (Pragma_AST_Entry => -1, + Pragma_Abort_Defer => -1, + Pragma_Ada_83 => -1, + Pragma_Ada_95 => -1, + Pragma_Ada_05 => -1, + Pragma_Ada_2005 => -1, + Pragma_Ada_12 => -1, + Pragma_Ada_2012 => -1, + Pragma_All_Calls_Remote => -1, + Pragma_Annotate => -1, + Pragma_Assert => -1, + Pragma_Assertion_Policy => 0, + Pragma_Assume_No_Invalid_Values => 0, + Pragma_Asynchronous => -1, + Pragma_Atomic => 0, + Pragma_Atomic_Components => 0, + Pragma_Attach_Handler => -1, + Pragma_Check => 99, + Pragma_Check_Name => 0, + Pragma_Check_Policy => 0, + Pragma_CIL_Constructor => -1, + Pragma_CPP_Class => 0, + Pragma_CPP_Constructor => 0, + Pragma_CPP_Virtual => 0, + Pragma_CPP_Vtable => 0, + Pragma_CPU => -1, + Pragma_C_Pass_By_Copy => 0, + Pragma_Comment => 0, + Pragma_Common_Object => -1, + Pragma_Compile_Time_Error => -1, + Pragma_Compile_Time_Warning => -1, + Pragma_Compiler_Unit => 0, + Pragma_Complete_Representation => 0, + Pragma_Complex_Representation => 0, + Pragma_Component_Alignment => -1, + Pragma_Controlled => 0, + Pragma_Convention => 0, + Pragma_Convention_Identifier => 0, + Pragma_Debug => -1, + Pragma_Debug_Policy => 0, + Pragma_Detect_Blocking => -1, + Pragma_Default_Storage_Pool => -1, + Pragma_Dimension => -1, + Pragma_Discard_Names => 0, + Pragma_Elaborate => -1, + Pragma_Elaborate_All => -1, + Pragma_Elaborate_Body => -1, + Pragma_Elaboration_Checks => -1, + Pragma_Eliminate => -1, + Pragma_Export => -1, + Pragma_Export_Exception => -1, + Pragma_Export_Function => -1, + Pragma_Export_Object => -1, + Pragma_Export_Procedure => -1, + Pragma_Export_Value => -1, + Pragma_Export_Valued_Procedure => -1, + Pragma_Extend_System => -1, + Pragma_Extensions_Allowed => -1, + Pragma_External => -1, + Pragma_Favor_Top_Level => -1, + Pragma_External_Name_Casing => -1, + Pragma_Fast_Math => -1, + Pragma_Finalize_Storage_Only => 0, + Pragma_Float_Representation => 0, + Pragma_Ident => -1, + Pragma_Implemented => -1, + Pragma_Implicit_Packing => 0, + Pragma_Import => +2, + Pragma_Import_Exception => 0, + Pragma_Import_Function => 0, + Pragma_Import_Object => 0, + Pragma_Import_Procedure => 0, + Pragma_Import_Valued_Procedure => 0, + Pragma_Independent => 0, + Pragma_Independent_Components => 0, + Pragma_Initialize_Scalars => -1, + Pragma_Inline => 0, + Pragma_Inline_Always => 0, + Pragma_Inline_Generic => 0, + Pragma_Inspection_Point => -1, + Pragma_Interface => +2, + Pragma_Interface_Name => +2, + Pragma_Interrupt_Handler => -1, + Pragma_Interrupt_Priority => -1, + Pragma_Interrupt_State => -1, + Pragma_Invariant => -1, + Pragma_Java_Constructor => -1, + Pragma_Java_Interface => -1, + Pragma_Keep_Names => 0, + Pragma_License => -1, + Pragma_Link_With => -1, + Pragma_Linker_Alias => -1, + Pragma_Linker_Constructor => -1, + Pragma_Linker_Destructor => -1, + Pragma_Linker_Options => -1, + Pragma_Linker_Section => -1, + Pragma_List => -1, + Pragma_Locking_Policy => -1, + Pragma_Long_Float => -1, + Pragma_Machine_Attribute => -1, + Pragma_Main => -1, + Pragma_Main_Storage => -1, + Pragma_Memory_Size => -1, + Pragma_No_Return => 0, + Pragma_No_Body => 0, + Pragma_No_Run_Time => -1, + Pragma_No_Strict_Aliasing => -1, + Pragma_Normalize_Scalars => -1, + Pragma_Obsolescent => 0, + Pragma_Optimize => -1, + Pragma_Optimize_Alignment => -1, + Pragma_Ordered => 0, + Pragma_Pack => 0, + Pragma_Page => -1, + Pragma_Passive => -1, + Pragma_Preelaborable_Initialization => -1, + Pragma_Polling => -1, + Pragma_Persistent_BSS => 0, + Pragma_Postcondition => -1, + Pragma_Precondition => -1, + Pragma_Predicate => -1, + Pragma_Preelaborate => -1, + Pragma_Preelaborate_05 => -1, + Pragma_Priority => -1, + Pragma_Priority_Specific_Dispatching => -1, + Pragma_Profile => 0, + Pragma_Profile_Warnings => 0, + Pragma_Propagate_Exceptions => -1, + Pragma_Psect_Object => -1, + Pragma_Pure => -1, + Pragma_Pure_05 => -1, + Pragma_Pure_Function => -1, + Pragma_Queuing_Policy => -1, + Pragma_Ravenscar => -1, + Pragma_Relative_Deadline => -1, + Pragma_Remote_Call_Interface => -1, + Pragma_Remote_Types => -1, + Pragma_Restricted_Run_Time => -1, + Pragma_Restriction_Warnings => -1, + Pragma_Restrictions => -1, + Pragma_Reviewable => -1, + Pragma_Short_Circuit_And_Or => -1, + Pragma_Share_Generic => -1, + Pragma_Shared => -1, + Pragma_Shared_Passive => -1, + Pragma_Short_Descriptors => 0, + Pragma_Source_File_Name => -1, + Pragma_Source_File_Name_Project => -1, + Pragma_Source_Reference => -1, + Pragma_Storage_Size => -1, + Pragma_Storage_Unit => -1, + Pragma_Static_Elaboration_Desired => -1, + Pragma_Stream_Convert => -1, + Pragma_Style_Checks => -1, + Pragma_Subtitle => -1, + Pragma_Suppress => 0, + Pragma_Suppress_Exception_Locations => 0, + Pragma_Suppress_All => -1, + Pragma_Suppress_Debug_Info => 0, + Pragma_Suppress_Initialization => 0, + Pragma_System_Name => -1, + Pragma_Task_Dispatching_Policy => -1, + Pragma_Task_Info => -1, + Pragma_Task_Name => -1, + Pragma_Task_Storage => 0, + Pragma_Thread_Local_Storage => 0, + Pragma_Time_Slice => -1, + Pragma_Title => -1, + Pragma_Unchecked_Union => 0, + Pragma_Unimplemented_Unit => -1, + Pragma_Universal_Aliasing => -1, + Pragma_Universal_Data => -1, + Pragma_Unmodified => -1, + Pragma_Unreferenced => -1, + Pragma_Unreferenced_Objects => -1, + Pragma_Unreserve_All_Interrupts => -1, + Pragma_Unsuppress => 0, + Pragma_Use_VADS_Size => -1, + Pragma_Validity_Checks => -1, + Pragma_Volatile => 0, + Pragma_Volatile_Components => 0, + Pragma_Warnings => -1, + Pragma_Weak_External => -1, + Pragma_Wide_Character_Encoding => 0, + Unknown_Pragma => 0); + + function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is + Id : Pragma_Id; + P : Node_Id; + C : Int; + A : Node_Id; + + begin + P := Parent (N); + + if Nkind (P) /= N_Pragma_Argument_Association then + return False; + + else + Id := Get_Pragma_Id (Parent (P)); + C := Sig_Flags (Id); + + case C is + when -1 => + return False; + + when 0 => + return True; + + when 99 => + case Id is + + -- For pragma Check, the first argument is not significant, + -- the second and the third (if present) arguments are + -- significant. + + when Pragma_Check => + return + P = First (Pragma_Argument_Associations (Parent (P))); + + when others => + raise Program_Error; + end case; + + when others => + A := First (Pragma_Argument_Associations (Parent (P))); + for J in 1 .. C - 1 loop + if No (A) then + return False; + end if; + + Next (A); + end loop; + + return A = P; -- is this wrong way round ??? + end case; + end if; + end Is_Non_Significant_Pragma_Reference; + + ------------------------------ + -- Is_Pragma_String_Literal -- + ------------------------------ + + -- This function returns true if the corresponding pragma argument is a + -- static string expression. These are the only cases in which string + -- literals can appear as pragma arguments. We also allow a string literal + -- as the first argument to pragma Assert (although it will of course + -- always generate a type error). + + function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is + Pragn : constant Node_Id := Parent (Par); + Assoc : constant List_Id := Pragma_Argument_Associations (Pragn); + Pname : constant Name_Id := Pragma_Name (Pragn); + Argn : Natural; + N : Node_Id; + + begin + Argn := 1; + N := First (Assoc); + loop + exit when N = Par; + Argn := Argn + 1; + Next (N); + end loop; + + if Pname = Name_Assert then + return True; + + elsif Pname = Name_Export then + return Argn > 2; + + elsif Pname = Name_Ident then + return Argn = 1; + + elsif Pname = Name_Import then + return Argn > 2; + + elsif Pname = Name_Interface_Name then + return Argn > 1; + + elsif Pname = Name_Linker_Alias then + return Argn = 2; + + elsif Pname = Name_Linker_Section then + return Argn = 2; + + elsif Pname = Name_Machine_Attribute then + return Argn = 2; + + elsif Pname = Name_Source_File_Name then + return True; + + elsif Pname = Name_Source_Reference then + return Argn = 2; + + elsif Pname = Name_Title then + return True; + + elsif Pname = Name_Subtitle then + return True; + + else + return False; + end if; + end Is_Pragma_String_Literal; + + -------------------------------------- + -- Process_Compilation_Unit_Pragmas -- + -------------------------------------- + + procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is + begin + -- A special check for pragma Suppress_All, a very strange DEC pragma, + -- strange because it comes at the end of the unit. Rational has the + -- same name for a pragma, but treats it as a program unit pragma, In + -- GNAT we just decide to allow it anywhere at all. If it appeared then + -- the flag Has_Pragma_Suppress_All was set on the compilation unit + -- node, and we insert a pragma Suppress (All_Checks) at the start of + -- the context clause to ensure the correct processing. + + if Has_Pragma_Suppress_All (N) then + Prepend_To (Context_Items (N), + Make_Pragma (Sloc (N), + Chars => Name_Suppress, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Sloc (N), + Expression => Make_Identifier (Sloc (N), Name_All_Checks))))); + end if; + + -- Nothing else to do at the current time! + + end Process_Compilation_Unit_Pragmas; + + -------- + -- rv -- + -------- + + procedure rv is + begin + null; + end rv; + + -------------------------------- + -- Set_Encoded_Interface_Name -- + -------------------------------- + + procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is + Str : constant String_Id := Strval (S); + Len : constant Int := String_Length (Str); + CC : Char_Code; + C : Character; + J : Int; + + Hex : constant array (0 .. 15) of Character := "0123456789abcdef"; + + procedure Encode; + -- Stores encoded value of character code CC. The encoding we use an + -- underscore followed by four lower case hex digits. + + ------------ + -- Encode -- + ------------ + + procedure Encode is + begin + Store_String_Char (Get_Char_Code ('_')); + Store_String_Char + (Get_Char_Code (Hex (Integer (CC / 2 ** 12)))); + Store_String_Char + (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#)))); + Store_String_Char + (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#)))); + Store_String_Char + (Get_Char_Code (Hex (Integer (CC and 16#0F#)))); + end Encode; + + -- Start of processing for Set_Encoded_Interface_Name + + begin + -- If first character is asterisk, this is a link name, and we leave it + -- completely unmodified. We also ignore null strings (the latter case + -- happens only in error cases) and no encoding should occur for Java or + -- AAMP interface names. + + if Len = 0 + or else Get_String_Char (Str, 1) = Get_Char_Code ('*') + or else VM_Target /= No_VM + or else AAMP_On_Target + then + Set_Interface_Name (E, S); + + else + J := 1; + loop + CC := Get_String_Char (Str, J); + + exit when not In_Character_Range (CC); + + C := Get_Character (CC); + + exit when C /= '_' and then C /= '$' + and then C not in '0' .. '9' + and then C not in 'a' .. 'z' + and then C not in 'A' .. 'Z'; + + if J = Len then + Set_Interface_Name (E, S); + return; + + else + J := J + 1; + end if; + end loop; + + -- Here we need to encode. The encoding we use as follows: + -- three underscores + four hex digits (lower case) + + Start_String; + + for J in 1 .. String_Length (Str) loop + CC := Get_String_Char (Str, J); + + if not In_Character_Range (CC) then + Encode; + else + C := Get_Character (CC); + + if C = '_' or else C = '$' + or else C in '0' .. '9' + or else C in 'a' .. 'z' + or else C in 'A' .. 'Z' + then + Store_String_Char (CC); + else + Encode; + end if; + end if; + end loop; + + Set_Interface_Name (E, + Make_String_Literal (Sloc (S), + Strval => End_String)); + end if; + end Set_Encoded_Interface_Name; + + ------------------- + -- Set_Unit_Name -- + ------------------- + + procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id) is + Pref : Node_Id; + Scop : Entity_Id; + + begin + if Nkind (N) = N_Identifier + and then Nkind (With_Item) = N_Identifier + then + Set_Entity (N, Entity (With_Item)); + + elsif Nkind (N) = N_Selected_Component then + Change_Selected_Component_To_Expanded_Name (N); + Set_Entity (N, Entity (With_Item)); + Set_Entity (Selector_Name (N), Entity (N)); + + Pref := Prefix (N); + Scop := Scope (Entity (N)); + while Nkind (Pref) = N_Selected_Component loop + Change_Selected_Component_To_Expanded_Name (Pref); + Set_Entity (Selector_Name (Pref), Scop); + Set_Entity (Pref, Scop); + Pref := Prefix (Pref); + Scop := Scope (Scop); + end loop; + + Set_Entity (Pref, Scop); + end if; + end Set_Unit_Name; + +end Sem_Prag; diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads new file mode 100644 index 000000000..4106120b0 --- /dev/null +++ b/gcc/ada/sem_prag.ads @@ -0,0 +1,115 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ P R A G -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Pragma handling is isolated in a separate package +-- (logically this processing belongs in chapter 4) + +with Namet; use Namet; +with Types; use Types; + +package Sem_Prag is + + ----------------- + -- Subprograms -- + ----------------- + + procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id); + -- Special analyze routine for precondition/postcondition pragma that + -- appears within a declarative part where the pragma is associated + -- with a subprogram specification. N is the pragma node, and S is the + -- entity for the related subprogram. This procedure does a preanalysis + -- of the expressions in the pragma as "spec expressions" (see section + -- in Sem "Handling of Default and Per-Object Expressions..."). + + procedure Analyze_Pragma (N : Node_Id); + -- Analyze procedure for pragma reference node N + + function Check_Enabled (Nam : Name_Id) return Boolean; + -- This function is used in connection with pragmas Assertion, Check, + -- Precondition, and Postcondition to determine if Check pragmas (or + -- corresponding Assert, Precondition, or Postcondition pragmas) are + -- currently active, as determined by the presence of -gnata on the + -- command line (which sets the default), and the appearance of pragmas + -- Check_Policy and Assertion_Policy as configuration pragmas either in + -- a configuration pragma file, or at the start of the current unit. + -- True is returned if the specified check is enabled. + + function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean; + -- N is a pragma appearing in a configuration pragma file. Most such + -- pragmas are analyzed when the file is read, before parsing and analyzing + -- the main unit. However, the analysis of certain pragmas results in + -- adding information to the compiled main unit, and this cannot be done + -- till the main unit is processed. Such pragmas return True from this + -- function and in Frontend pragmas where Delay_Config_Pragma_Analyze is + -- True have their analysis delayed until after the main program is parsed + -- and analyzed. + + procedure Initialize; + -- Initializes data structures used for pragma processing. Must be called + -- before analyzing each new main source program. + + function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean; + -- The node N is a node for an entity and the issue is whether the + -- occurrence is a reference for the purposes of giving warnings about + -- unreferenced variables. This function returns True if the reference is + -- not a reference from this point of view (e.g. the occurrence in a pragma + -- Pack) and False if it is a real reference (e.g. the occurrence in a + -- pragma Export); + + function Is_Pragma_String_Literal (Par : Node_Id) return Boolean; + -- Given an N_Pragma_Argument_Association node, Par, which has the form of + -- an operator symbol, determines whether or not it should be treated as an + -- string literal. This is called by Sem_Ch6.Analyze_Operator_Symbol. If + -- True is returned, the argument is converted to a string literal. If + -- False is returned, then the argument is treated as an entity reference + -- to the operator. + + function Is_Config_Static_String (Arg : Node_Id) return Boolean; + -- This is called for a configuration pragma that requires either string + -- literal or a concatenation of string literals. We cannot use normal + -- static string processing because it is too early in the case of the + -- pragma appearing in a configuration pragmas file. If Arg is of an + -- appropriate form, then this call obtains the string (doing any necessary + -- concatenations) and places it in Name_Buffer, setting Name_Len to its + -- length, and then returns True. If it is not of the correct form, then an + -- appropriate error message is posted, and False is returned. + + procedure Process_Compilation_Unit_Pragmas (N : Node_Id); + -- Called at the start of processing compilation unit N to deal with any + -- special issues regarding pragmas. In particular, we have to deal with + -- Suppress_All at this stage, since it can appear after the unit instead + -- of before (actually we allow it to appear anywhere). + + procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id); + -- This routine is used to set an encoded interface name. The node S is an + -- N_String_Literal node for the external name to be set, and E is an + -- entity whose Interface_Name field is to be set. In the normal case where + -- S contains a name that is a valid C identifier, then S is simply set as + -- the value of the Interface_Name. Otherwise it is encoded. See the body + -- for details of the encoding. This encoding is only done on VMS systems, + -- since it seems pretty silly, but is needed to pass some dubious tests in + -- the test suite. + +end Sem_Prag; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb new file mode 100644 index 000000000..ce5323d85 --- /dev/null +++ b/gcc/ada/sem_res.adb @@ -0,0 +1,10542 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ R 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Debug; use Debug; +with Debug_A; use Debug_A; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Expander; use Expander; +with Exp_Disp; use Exp_Disp; +with Exp_Ch6; use Exp_Ch6; +with Exp_Ch7; use Exp_Ch7; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Fname; use Fname; +with Freeze; use Freeze; +with Itypes; use Itypes; +with Lib; use Lib; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; +with Nmake; use Nmake; +with Nlists; use Nlists; +with Opt; use Opt; +with Output; use Output; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Aggr; use Sem_Aggr; +with Sem_Attr; use Sem_Attr; +with Sem_Cat; use Sem_Cat; +with Sem_Ch4; use Sem_Ch4; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch13; use Sem_Ch13; +with Sem_Disp; use Sem_Disp; +with Sem_Dist; use Sem_Dist; +with Sem_Elim; use Sem_Elim; +with Sem_Elab; use Sem_Elab; +with Sem_Eval; use Sem_Eval; +with Sem_Intr; use Sem_Intr; +with Sem_Util; use Sem_Util; +with Sem_Type; use Sem_Type; +with Sem_Warn; use Sem_Warn; +with Sinfo; use Sinfo; +with Sinfo.CN; use Sinfo.CN; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Style; use Style; +with Tbuild; use Tbuild; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package body Sem_Res is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + -- Second pass (top-down) type checking and overload resolution procedures + -- Typ is the type required by context. These procedures propagate the + -- type information recursively to the descendants of N. If the node + -- is not overloaded, its Etype is established in the first pass. If + -- overloaded, the Resolve routines set the correct type. For arith. + -- operators, the Etype is the base type of the context. + + -- Note that Resolve_Attribute is separated off in Sem_Attr + + function Bad_Unordered_Enumeration_Reference + (N : Node_Id; + T : Entity_Id) return Boolean; + -- Node N contains a potentially dubious reference to type T, either an + -- explicit comparison, or an explicit range. This function returns True + -- if the type T is an enumeration type for which No pragma Order has been + -- given, and the reference N is not in the same extended source unit as + -- the declaration of T. + + procedure Check_Discriminant_Use (N : Node_Id); + -- Enforce the restrictions on the use of discriminants when constraining + -- a component of a discriminated type (record or concurrent type). + + procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id); + -- Given a node for an operator associated with type T, check that + -- the operator is visible. Operators all of whose operands are + -- universal must be checked for visibility during resolution + -- because their type is not determinable based on their operands. + + procedure Check_Fully_Declared_Prefix + (Typ : Entity_Id; + Pref : Node_Id); + -- Check that the type of the prefix of a dereference is not incomplete + + function Check_Infinite_Recursion (N : Node_Id) return Boolean; + -- Given a call node, N, which is known to occur immediately within the + -- subprogram being called, determines whether it is a detectable case of + -- an infinite recursion, and if so, outputs appropriate messages. Returns + -- True if an infinite recursion is detected, and False otherwise. + + procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id); + -- If the type of the object being initialized uses the secondary stack + -- directly or indirectly, create a transient scope for the call to the + -- init proc. This is because we do not create transient scopes for the + -- initialization of individual components within the init proc itself. + -- Could be optimized away perhaps? + + procedure Check_No_Direct_Boolean_Operators (N : Node_Id); + -- N is the node for a logical operator. If the operator is predefined, and + -- the root type of the operands is Standard.Boolean, then a check is made + -- for restriction No_Direct_Boolean_Operators. This procedure also handles + -- the style check for Style_Check_Boolean_And_Or. + + function Is_Definite_Access_Type (E : Entity_Id) return Boolean; + -- Determine whether E is an access type declared by an access + -- declaration, and not an (anonymous) allocator type. + + function Is_Predefined_Op (Nam : Entity_Id) return Boolean; + -- Utility to check whether the entity for an operator is a predefined + -- operator, in which case the expression is left as an operator in the + -- tree (else it is rewritten into a call). An instance of an intrinsic + -- conversion operation may be given an operator name, but is not treated + -- like an operator. Note that an operator that is an imported back-end + -- builtin has convention Intrinsic, but is expected to be rewritten into + -- a call, so such an operator is not treated as predefined by this + -- predicate. + + procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id); + -- If a default expression in entry call N depends on the discriminants + -- of the task, it must be replaced with a reference to the discriminant + -- of the task being called. + + procedure Resolve_Op_Concat_Arg + (N : Node_Id; + Arg : Node_Id; + Typ : Entity_Id; + Is_Comp : Boolean); + -- Internal procedure for Resolve_Op_Concat to resolve one operand of + -- concatenation operator. The operand is either of the array type or of + -- the component type. If the operand is an aggregate, and the component + -- type is composite, this is ambiguous if component type has aggregates. + + procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id); + -- Does the first part of the work of Resolve_Op_Concat + + procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id); + -- Does the "rest" of the work of Resolve_Op_Concat, after the left operand + -- has been resolved. See Resolve_Op_Concat for details. + + procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Call (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Expression_With_Actions (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Null (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Quantified_Expression (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Range (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Shift (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id); + procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Subprogram_Info (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Unchecked_Expression (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Unchecked_Type_Conversion (N : Node_Id; Typ : Entity_Id); + + function Operator_Kind + (Op_Name : Name_Id; + Is_Binary : Boolean) return Node_Kind; + -- Utility to map the name of an operator into the corresponding Node. Used + -- by other node rewriting procedures. + + procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id); + -- Resolve actuals of call, and add default expressions for missing ones. + -- N is the Node_Id for the subprogram call, and Nam is the entity of the + -- called subprogram. + + procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id); + -- Called from Resolve_Call, when the prefix denotes an entry or element + -- of entry family. Actuals are resolved as for subprograms, and the node + -- is rebuilt as an entry call. Also called for protected operations. Typ + -- is the context type, which is used when the operation is a protected + -- function with no arguments, and the return value is indexed. + + procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id); + -- A call to a user-defined intrinsic operator is rewritten as a call + -- to the corresponding predefined operator, with suitable conversions. + -- Note that this applies only for intrinsic operators that denote + -- predefined operators, not operators that are intrinsic imports of + -- back-end builtins. + + procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id); + -- Ditto, for unary operators (arithmetic ones and "not" on signed + -- integer types for VMS). + + procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id); + -- If an operator node resolves to a call to a user-defined operator, + -- rewrite the node as a function call. + + procedure Make_Call_Into_Operator + (N : Node_Id; + Typ : Entity_Id; + Op_Id : Entity_Id); + -- Inverse transformation: if an operator is given in functional notation, + -- then after resolving the node, transform into an operator node, so + -- that operands are resolved properly. Recall that predefined operators + -- do not have a full signature and special resolution rules apply. + + procedure Rewrite_Renamed_Operator + (N : Node_Id; + Op : Entity_Id; + Typ : Entity_Id); + -- An operator can rename another, e.g. in an instantiation. In that + -- case, the proper operator node must be constructed and resolved. + + procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id); + -- The String_Literal_Subtype is built for all strings that are not + -- operands of a static concatenation operation. If the argument is + -- not a N_String_Literal node, then the call has no effect. + + procedure Set_Slice_Subtype (N : Node_Id); + -- Build subtype of array type, with the range specified by the slice + + procedure Simplify_Type_Conversion (N : Node_Id); + -- Called after N has been resolved and evaluated, but before range checks + -- have been applied. Currently simplifies a combination of floating-point + -- to integer conversion and Truncation attribute. + + function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id; + -- A universal_fixed expression in an universal context is unambiguous + -- if there is only one applicable fixed point type. Determining whether + -- there is only one requires a search over all visible entities, and + -- happens only in very pathological cases (see 6115-006). + + function Valid_Conversion + (N : Node_Id; + Target : Entity_Id; + Operand : Node_Id) return Boolean; + -- Verify legality rules given in 4.6 (8-23). Target is the target + -- type of the conversion, which may be an implicit conversion of + -- an actual parameter to an anonymous access type (in which case + -- N denotes the actual parameter and N = Operand). + + ------------------------- + -- Ambiguous_Character -- + ------------------------- + + procedure Ambiguous_Character (C : Node_Id) is + E : Entity_Id; + + begin + if Nkind (C) = N_Character_Literal then + Error_Msg_N ("ambiguous character literal", C); + + -- First the ones in Standard + + Error_Msg_N ("\\possible interpretation: Character!", C); + Error_Msg_N ("\\possible interpretation: Wide_Character!", C); + + -- Include Wide_Wide_Character in Ada 2005 mode + + if Ada_Version >= Ada_2005 then + Error_Msg_N ("\\possible interpretation: Wide_Wide_Character!", C); + end if; + + -- Now any other types that match + + E := Current_Entity (C); + while Present (E) loop + Error_Msg_NE ("\\possible interpretation:}!", C, Etype (E)); + E := Homonym (E); + end loop; + end if; + end Ambiguous_Character; + + ------------------------- + -- Analyze_And_Resolve -- + ------------------------- + + procedure Analyze_And_Resolve (N : Node_Id) is + begin + Analyze (N); + Resolve (N); + end Analyze_And_Resolve; + + procedure Analyze_And_Resolve (N : Node_Id; Typ : Entity_Id) is + begin + Analyze (N); + Resolve (N, Typ); + end Analyze_And_Resolve; + + -- Version withs check(s) suppressed + + procedure Analyze_And_Resolve + (N : Node_Id; + Typ : Entity_Id; + Suppress : Check_Id) + is + Scop : constant Entity_Id := Current_Scope; + + begin + if Suppress = All_Checks then + declare + Svg : constant Suppress_Array := Scope_Suppress; + begin + Scope_Suppress := (others => True); + Analyze_And_Resolve (N, Typ); + Scope_Suppress := Svg; + end; + + else + declare + Svg : constant Boolean := Scope_Suppress (Suppress); + + begin + Scope_Suppress (Suppress) := True; + Analyze_And_Resolve (N, Typ); + Scope_Suppress (Suppress) := Svg; + end; + end if; + + if Current_Scope /= Scop + and then Scope_Is_Transient + then + -- This can only happen if a transient scope was created + -- for an inner expression, which will be removed upon + -- completion of the analysis of an enclosing construct. + -- The transient scope must have the suppress status of + -- the enclosing environment, not of this Analyze call. + + Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress := + Scope_Suppress; + end if; + end Analyze_And_Resolve; + + procedure Analyze_And_Resolve + (N : Node_Id; + Suppress : Check_Id) + is + Scop : constant Entity_Id := Current_Scope; + + begin + if Suppress = All_Checks then + declare + Svg : constant Suppress_Array := Scope_Suppress; + begin + Scope_Suppress := (others => True); + Analyze_And_Resolve (N); + Scope_Suppress := Svg; + end; + + else + declare + Svg : constant Boolean := Scope_Suppress (Suppress); + + begin + Scope_Suppress (Suppress) := True; + Analyze_And_Resolve (N); + Scope_Suppress (Suppress) := Svg; + end; + end if; + + if Current_Scope /= Scop + and then Scope_Is_Transient + then + Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress := + Scope_Suppress; + end if; + end Analyze_And_Resolve; + + ---------------------------------------- + -- Bad_Unordered_Enumeration_Reference -- + ---------------------------------------- + + function Bad_Unordered_Enumeration_Reference + (N : Node_Id; + T : Entity_Id) return Boolean + is + begin + return Is_Enumeration_Type (T) + and then Comes_From_Source (N) + and then Warn_On_Unordered_Enumeration_Type + and then not Has_Pragma_Ordered (T) + and then not In_Same_Extended_Unit (N, T); + end Bad_Unordered_Enumeration_Reference; + + ---------------------------- + -- Check_Discriminant_Use -- + ---------------------------- + + procedure Check_Discriminant_Use (N : Node_Id) is + PN : constant Node_Id := Parent (N); + Disc : constant Entity_Id := Entity (N); + P : Node_Id; + D : Node_Id; + + begin + -- Any use in a spec-expression is legal + + if In_Spec_Expression then + null; + + elsif Nkind (PN) = N_Range then + + -- Discriminant cannot be used to constrain a scalar type + + P := Parent (PN); + + if Nkind (P) = N_Range_Constraint + and then Nkind (Parent (P)) = N_Subtype_Indication + and then Nkind (Parent (Parent (P))) = N_Component_Definition + then + Error_Msg_N ("discriminant cannot constrain scalar type", N); + + elsif Nkind (P) = N_Index_Or_Discriminant_Constraint then + + -- The following check catches the unusual case where + -- a discriminant appears within an index constraint + -- that is part of a larger expression within a constraint + -- on a component, e.g. "C : Int range 1 .. F (new A(1 .. D))". + -- For now we only check case of record components, and + -- note that a similar check should also apply in the + -- case of discriminant constraints below. ??? + + -- Note that the check for N_Subtype_Declaration below is to + -- detect the valid use of discriminants in the constraints of a + -- subtype declaration when this subtype declaration appears + -- inside the scope of a record type (which is syntactically + -- illegal, but which may be created as part of derived type + -- processing for records). See Sem_Ch3.Build_Derived_Record_Type + -- for more info. + + if Ekind (Current_Scope) = E_Record_Type + and then Scope (Disc) = Current_Scope + and then not + (Nkind (Parent (P)) = N_Subtype_Indication + and then + Nkind_In (Parent (Parent (P)), N_Component_Definition, + N_Subtype_Declaration) + and then Paren_Count (N) = 0) + then + Error_Msg_N + ("discriminant must appear alone in component constraint", N); + return; + end if; + + -- Detect a common error: + + -- type R (D : Positive := 100) is record + -- Name : String (1 .. D); + -- end record; + + -- The default value causes an object of type R to be allocated + -- with room for Positive'Last characters. The RM does not mandate + -- the allocation of the maximum size, but that is what GNAT does + -- so we should warn the programmer that there is a problem. + + Check_Large : declare + SI : Node_Id; + T : Entity_Id; + TB : Node_Id; + CB : Entity_Id; + + function Large_Storage_Type (T : Entity_Id) return Boolean; + -- Return True if type T has a large enough range that + -- any array whose index type covered the whole range of + -- the type would likely raise Storage_Error. + + ------------------------ + -- Large_Storage_Type -- + ------------------------ + + function Large_Storage_Type (T : Entity_Id) return Boolean is + begin + -- The type is considered large if its bounds are known at + -- compile time and if it requires at least as many bits as + -- a Positive to store the possible values. + + return Compile_Time_Known_Value (Type_Low_Bound (T)) + and then Compile_Time_Known_Value (Type_High_Bound (T)) + and then + Minimum_Size (T, Biased => True) >= + RM_Size (Standard_Positive); + end Large_Storage_Type; + + -- Start of processing for Check_Large + + begin + -- Check that the Disc has a large range + + if not Large_Storage_Type (Etype (Disc)) then + goto No_Danger; + end if; + + -- If the enclosing type is limited, we allocate only the + -- default value, not the maximum, and there is no need for + -- a warning. + + if Is_Limited_Type (Scope (Disc)) then + goto No_Danger; + end if; + + -- Check that it is the high bound + + if N /= High_Bound (PN) + or else No (Discriminant_Default_Value (Disc)) + then + goto No_Danger; + end if; + + -- Check the array allows a large range at this bound. + -- First find the array + + SI := Parent (P); + + if Nkind (SI) /= N_Subtype_Indication then + goto No_Danger; + end if; + + T := Entity (Subtype_Mark (SI)); + + if not Is_Array_Type (T) then + goto No_Danger; + end if; + + -- Next, find the dimension + + TB := First_Index (T); + CB := First (Constraints (P)); + while True + and then Present (TB) + and then Present (CB) + and then CB /= PN + loop + Next_Index (TB); + Next (CB); + end loop; + + if CB /= PN then + goto No_Danger; + end if; + + -- Now, check the dimension has a large range + + if not Large_Storage_Type (Etype (TB)) then + goto No_Danger; + end if; + + -- Warn about the danger + + Error_Msg_N + ("?creation of & object may raise Storage_Error!", + Scope (Disc)); + + <> + null; + + end Check_Large; + end if; + + -- Legal case is in index or discriminant constraint + + elsif Nkind_In (PN, N_Index_Or_Discriminant_Constraint, + N_Discriminant_Association) + then + if Paren_Count (N) > 0 then + Error_Msg_N + ("discriminant in constraint must appear alone", N); + + elsif Nkind (N) = N_Expanded_Name + and then Comes_From_Source (N) + then + Error_Msg_N + ("discriminant must appear alone as a direct name", N); + end if; + + return; + + -- Otherwise, context is an expression. It should not be within + -- (i.e. a subexpression of) a constraint for a component. + + else + D := PN; + P := Parent (PN); + while not Nkind_In (P, N_Component_Declaration, + N_Subtype_Indication, + N_Entry_Declaration) + loop + D := P; + P := Parent (P); + exit when No (P); + end loop; + + -- If the discriminant is used in an expression that is a bound + -- of a scalar type, an Itype is created and the bounds are attached + -- to its range, not to the original subtype indication. Such use + -- is of course a double fault. + + if (Nkind (P) = N_Subtype_Indication + and then Nkind_In (Parent (P), N_Component_Definition, + N_Derived_Type_Definition) + and then D = Constraint (P)) + + -- The constraint itself may be given by a subtype indication, + -- rather than by a more common discrete range. + + or else (Nkind (P) = N_Subtype_Indication + and then + Nkind (Parent (P)) = N_Index_Or_Discriminant_Constraint) + or else Nkind (P) = N_Entry_Declaration + or else Nkind (D) = N_Defining_Identifier + then + Error_Msg_N + ("discriminant in constraint must appear alone", N); + end if; + end if; + end Check_Discriminant_Use; + + -------------------------------- + -- Check_For_Visible_Operator -- + -------------------------------- + + procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is + begin + if Is_Invisible_Operator (N, T) then + Error_Msg_NE -- CODEFIX + ("operator for} is not directly visible!", N, First_Subtype (T)); + Error_Msg_N -- CODEFIX + ("use clause would make operation legal!", N); + end if; + end Check_For_Visible_Operator; + + ---------------------------------- + -- Check_Fully_Declared_Prefix -- + ---------------------------------- + + procedure Check_Fully_Declared_Prefix + (Typ : Entity_Id; + Pref : Node_Id) + is + begin + -- Check that the designated type of the prefix of a dereference is + -- not an incomplete type. This cannot be done unconditionally, because + -- dereferences of private types are legal in default expressions. This + -- case is taken care of in Check_Fully_Declared, called below. There + -- are also 2005 cases where it is legal for the prefix to be unfrozen. + + -- This consideration also applies to similar checks for allocators, + -- qualified expressions, and type conversions. + + -- An additional exception concerns other per-object expressions that + -- are not directly related to component declarations, in particular + -- representation pragmas for tasks. These will be per-object + -- expressions if they depend on discriminants or some global entity. + -- If the task has access discriminants, the designated type may be + -- incomplete at the point the expression is resolved. This resolution + -- takes place within the body of the initialization procedure, where + -- the discriminant is replaced by its discriminal. + + if Is_Entity_Name (Pref) + and then Ekind (Entity (Pref)) = E_In_Parameter + then + null; + + -- Ada 2005 (AI-326): Tagged incomplete types allowed. The wrong usages + -- are handled by Analyze_Access_Attribute, Analyze_Assignment, + -- Analyze_Object_Renaming, and Freeze_Entity. + + elsif Ada_Version >= Ada_2005 + and then Is_Entity_Name (Pref) + and then Is_Access_Type (Etype (Pref)) + and then Ekind (Directly_Designated_Type (Etype (Pref))) = + E_Incomplete_Type + and then Is_Tagged_Type (Directly_Designated_Type (Etype (Pref))) + then + null; + else + Check_Fully_Declared (Typ, Parent (Pref)); + end if; + end Check_Fully_Declared_Prefix; + + ------------------------------ + -- Check_Infinite_Recursion -- + ------------------------------ + + function Check_Infinite_Recursion (N : Node_Id) return Boolean is + P : Node_Id; + C : Node_Id; + + function Same_Argument_List return Boolean; + -- Check whether list of actuals is identical to list of formals + -- of called function (which is also the enclosing scope). + + ------------------------ + -- Same_Argument_List -- + ------------------------ + + function Same_Argument_List return Boolean is + A : Node_Id; + F : Entity_Id; + Subp : Entity_Id; + + begin + if not Is_Entity_Name (Name (N)) then + return False; + else + Subp := Entity (Name (N)); + end if; + + F := First_Formal (Subp); + A := First_Actual (N); + while Present (F) and then Present (A) loop + if not Is_Entity_Name (A) + or else Entity (A) /= F + then + return False; + end if; + + Next_Actual (A); + Next_Formal (F); + end loop; + + return True; + end Same_Argument_List; + + -- Start of processing for Check_Infinite_Recursion + + begin + -- Special case, if this is a procedure call and is a call to the + -- current procedure with the same argument list, then this is for + -- sure an infinite recursion and we insert a call to raise SE. + + if Is_List_Member (N) + and then List_Length (List_Containing (N)) = 1 + and then Same_Argument_List + then + declare + P : constant Node_Id := Parent (N); + begin + if Nkind (P) = N_Handled_Sequence_Of_Statements + and then Nkind (Parent (P)) = N_Subprogram_Body + and then Is_Empty_List (Declarations (Parent (P))) + then + Error_Msg_N ("!?infinite recursion", N); + Error_Msg_N ("\!?Storage_Error will be raised at run time", N); + Insert_Action (N, + Make_Raise_Storage_Error (Sloc (N), + Reason => SE_Infinite_Recursion)); + return True; + end if; + end; + end if; + + -- If not that special case, search up tree, quitting if we reach a + -- construct (e.g. a conditional) that tells us that this is not a + -- case for an infinite recursion warning. + + C := N; + loop + P := Parent (C); + + -- If no parent, then we were not inside a subprogram, this can for + -- example happen when processing certain pragmas in a spec. Just + -- return False in this case. + + if No (P) then + return False; + end if; + + -- Done if we get to subprogram body, this is definitely an infinite + -- recursion case if we did not find anything to stop us. + + exit when Nkind (P) = N_Subprogram_Body; + + -- If appearing in conditional, result is false + + if Nkind_In (P, N_Or_Else, + N_And_Then, + N_Case_Expression, + N_Case_Statement, + N_Conditional_Expression, + N_If_Statement) + then + return False; + + elsif Nkind (P) = N_Handled_Sequence_Of_Statements + and then C /= First (Statements (P)) + then + -- If the call is the expression of a return statement and the + -- actuals are identical to the formals, it's worth a warning. + -- However, we skip this if there is an immediately preceding + -- raise statement, since the call is never executed. + + -- Furthermore, this corresponds to a common idiom: + + -- function F (L : Thing) return Boolean is + -- begin + -- raise Program_Error; + -- return F (L); + -- end F; + + -- for generating a stub function + + if Nkind (Parent (N)) = N_Simple_Return_Statement + and then Same_Argument_List + then + exit when not Is_List_Member (Parent (N)); + + -- OK, return statement is in a statement list, look for raise + + declare + Nod : Node_Id; + + begin + -- Skip past N_Freeze_Entity nodes generated by expansion + + Nod := Prev (Parent (N)); + while Present (Nod) + and then Nkind (Nod) = N_Freeze_Entity + loop + Prev (Nod); + end loop; + + -- If no raise statement, give warning + + exit when Nkind (Nod) /= N_Raise_Statement + and then + (Nkind (Nod) not in N_Raise_xxx_Error + or else Present (Condition (Nod))); + end; + end if; + + return False; + + else + C := P; + end if; + end loop; + + Error_Msg_N ("!?possible infinite recursion", N); + Error_Msg_N ("\!?Storage_Error may be raised at run time", N); + + return True; + end Check_Infinite_Recursion; + + ------------------------------- + -- Check_Initialization_Call -- + ------------------------------- + + procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id) is + Typ : constant Entity_Id := Etype (First_Formal (Nam)); + + function Uses_SS (T : Entity_Id) return Boolean; + -- Check whether the creation of an object of the type will involve + -- use of the secondary stack. If T is a record type, this is true + -- if the expression for some component uses the secondary stack, e.g. + -- through a call to a function that returns an unconstrained value. + -- False if T is controlled, because cleanups occur elsewhere. + + ------------- + -- Uses_SS -- + ------------- + + function Uses_SS (T : Entity_Id) return Boolean is + Comp : Entity_Id; + Expr : Node_Id; + Full_Type : Entity_Id := Underlying_Type (T); + + begin + -- Normally we want to use the underlying type, but if it's not set + -- then continue with T. + + if not Present (Full_Type) then + Full_Type := T; + end if; + + if Is_Controlled (Full_Type) then + return False; + + elsif Is_Array_Type (Full_Type) then + return Uses_SS (Component_Type (Full_Type)); + + elsif Is_Record_Type (Full_Type) then + Comp := First_Component (Full_Type); + while Present (Comp) loop + if Ekind (Comp) = E_Component + and then Nkind (Parent (Comp)) = N_Component_Declaration + then + -- The expression for a dynamic component may be rewritten + -- as a dereference, so retrieve original node. + + Expr := Original_Node (Expression (Parent (Comp))); + + -- Return True if the expression is a call to a function + -- (including an attribute function such as Image, or a + -- user-defined operator) with a result that requires a + -- transient scope. + + if (Nkind (Expr) = N_Function_Call + or else Nkind (Expr) in N_Op + or else (Nkind (Expr) = N_Attribute_Reference + and then Present (Expressions (Expr)))) + and then Requires_Transient_Scope (Etype (Expr)) + then + return True; + + elsif Uses_SS (Etype (Comp)) then + return True; + end if; + end if; + + Next_Component (Comp); + end loop; + + return False; + + else + return False; + end if; + end Uses_SS; + + -- Start of processing for Check_Initialization_Call + + begin + -- Establish a transient scope if the type needs it + + if Uses_SS (Typ) then + Establish_Transient_Scope (First_Actual (N), Sec_Stack => True); + end if; + end Check_Initialization_Call; + + --------------------------------------- + -- Check_No_Direct_Boolean_Operators -- + --------------------------------------- + + procedure Check_No_Direct_Boolean_Operators (N : Node_Id) is + begin + if Scope (Entity (N)) = Standard_Standard + and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean + then + -- Restriction only applies to original source code + + if Comes_From_Source (N) then + Check_Restriction (No_Direct_Boolean_Operators, N); + end if; + end if; + + if Style_Check then + Check_Boolean_Operator (N); + end if; + end Check_No_Direct_Boolean_Operators; + + ------------------------------ + -- Check_Parameterless_Call -- + ------------------------------ + + procedure Check_Parameterless_Call (N : Node_Id) is + Nam : Node_Id; + + function Prefix_Is_Access_Subp return Boolean; + -- If the prefix is of an access_to_subprogram type, the node must be + -- rewritten as a call. Ditto if the prefix is overloaded and all its + -- interpretations are access to subprograms. + + --------------------------- + -- Prefix_Is_Access_Subp -- + --------------------------- + + function Prefix_Is_Access_Subp return Boolean is + I : Interp_Index; + It : Interp; + + begin + -- If the context is an attribute reference that can apply to + -- functions, this is never a parameterless call (RM 4.1.4(6)). + + if Nkind (Parent (N)) = N_Attribute_Reference + and then (Attribute_Name (Parent (N)) = Name_Address + or else Attribute_Name (Parent (N)) = Name_Code_Address + or else Attribute_Name (Parent (N)) = Name_Access) + then + return False; + end if; + + if not Is_Overloaded (N) then + return + Ekind (Etype (N)) = E_Subprogram_Type + and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type; + else + Get_First_Interp (N, I, It); + while Present (It.Typ) loop + if Ekind (It.Typ) /= E_Subprogram_Type + or else Base_Type (Etype (It.Typ)) = Standard_Void_Type + then + return False; + end if; + + Get_Next_Interp (I, It); + end loop; + + return True; + end if; + end Prefix_Is_Access_Subp; + + -- Start of processing for Check_Parameterless_Call + + begin + -- Defend against junk stuff if errors already detected + + if Total_Errors_Detected /= 0 then + if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then + return; + elsif Nkind (N) in N_Has_Chars + and then Chars (N) in Error_Name_Or_No_Name + then + return; + end if; + + Require_Entity (N); + end if; + + -- If the context expects a value, and the name is a procedure, this is + -- most likely a missing 'Access. Don't try to resolve the parameterless + -- call, error will be caught when the outer call is analyzed. + + if Is_Entity_Name (N) + and then Ekind (Entity (N)) = E_Procedure + and then not Is_Overloaded (N) + and then + Nkind_In (Parent (N), N_Parameter_Association, + N_Function_Call, + N_Procedure_Call_Statement) + then + return; + end if; + + -- Rewrite as call if overloadable entity that is (or could be, in the + -- overloaded case) a function call. If we know for sure that the entity + -- is an enumeration literal, we do not rewrite it. + + -- If the entity is the name of an operator, it cannot be a call because + -- operators cannot have default parameters. In this case, this must be + -- a string whose contents coincide with an operator name. Set the kind + -- of the node appropriately. + + if (Is_Entity_Name (N) + and then Nkind (N) /= N_Operator_Symbol + and then Is_Overloadable (Entity (N)) + and then (Ekind (Entity (N)) /= E_Enumeration_Literal + or else Is_Overloaded (N))) + + -- Rewrite as call if it is an explicit dereference of an expression of + -- a subprogram access type, and the subprogram type is not that of a + -- procedure or entry. + + or else + (Nkind (N) = N_Explicit_Dereference and then Prefix_Is_Access_Subp) + + -- Rewrite as call if it is a selected component which is a function, + -- this is the case of a call to a protected function (which may be + -- overloaded with other protected operations). + + or else + (Nkind (N) = N_Selected_Component + and then (Ekind (Entity (Selector_Name (N))) = E_Function + or else + (Ekind_In (Entity (Selector_Name (N)), E_Entry, + E_Procedure) + and then Is_Overloaded (Selector_Name (N))))) + + -- If one of the above three conditions is met, rewrite as call. + -- Apply the rewriting only once. + + then + if Nkind (Parent (N)) /= N_Function_Call + or else N /= Name (Parent (N)) + then + Nam := New_Copy (N); + + -- If overloaded, overload set belongs to new copy + + Save_Interps (N, Nam); + + -- Change node to parameterless function call (note that the + -- Parameter_Associations associations field is left set to Empty, + -- its normal default value since there are no parameters) + + Change_Node (N, N_Function_Call); + Set_Name (N, Nam); + Set_Sloc (N, Sloc (Nam)); + Analyze_Call (N); + end if; + + elsif Nkind (N) = N_Parameter_Association then + Check_Parameterless_Call (Explicit_Actual_Parameter (N)); + + elsif Nkind (N) = N_Operator_Symbol then + Change_Operator_Symbol_To_String_Literal (N); + Set_Is_Overloaded (N, False); + Set_Etype (N, Any_String); + end if; + end Check_Parameterless_Call; + + ----------------------------- + -- Is_Definite_Access_Type -- + ----------------------------- + + function Is_Definite_Access_Type (E : Entity_Id) return Boolean is + Btyp : constant Entity_Id := Base_Type (E); + begin + return Ekind (Btyp) = E_Access_Type + or else (Ekind (Btyp) = E_Access_Subprogram_Type + and then Comes_From_Source (Btyp)); + end Is_Definite_Access_Type; + + ---------------------- + -- Is_Predefined_Op -- + ---------------------- + + function Is_Predefined_Op (Nam : Entity_Id) return Boolean is + begin + -- Predefined operators are intrinsic subprograms + + if not Is_Intrinsic_Subprogram (Nam) then + return False; + end if; + + -- A call to a back-end builtin is never a predefined operator + + if Is_Imported (Nam) and then Present (Interface_Name (Nam)) then + return False; + end if; + + return not Is_Generic_Instance (Nam) + and then Chars (Nam) in Any_Operator_Name + and then (No (Alias (Nam)) or else Is_Predefined_Op (Alias (Nam))); + end Is_Predefined_Op; + + ----------------------------- + -- Make_Call_Into_Operator -- + ----------------------------- + + procedure Make_Call_Into_Operator + (N : Node_Id; + Typ : Entity_Id; + Op_Id : Entity_Id) + is + Op_Name : constant Name_Id := Chars (Op_Id); + Act1 : Node_Id := First_Actual (N); + Act2 : Node_Id := Next_Actual (Act1); + Error : Boolean := False; + Func : constant Entity_Id := Entity (Name (N)); + Is_Binary : constant Boolean := Present (Act2); + Op_Node : Node_Id; + Opnd_Type : Entity_Id; + Orig_Type : Entity_Id := Empty; + Pack : Entity_Id; + + type Kind_Test is access function (E : Entity_Id) return Boolean; + + function Operand_Type_In_Scope (S : Entity_Id) return Boolean; + -- If the operand is not universal, and the operator is given by an + -- expanded name, verify that the operand has an interpretation with a + -- type defined in the given scope of the operator. + + function Type_In_P (Test : Kind_Test) return Entity_Id; + -- Find a type of the given class in package Pack that contains the + -- operator. + + --------------------------- + -- Operand_Type_In_Scope -- + --------------------------- + + function Operand_Type_In_Scope (S : Entity_Id) return Boolean is + Nod : constant Node_Id := Right_Opnd (Op_Node); + I : Interp_Index; + It : Interp; + + begin + if not Is_Overloaded (Nod) then + return Scope (Base_Type (Etype (Nod))) = S; + + else + Get_First_Interp (Nod, I, It); + while Present (It.Typ) loop + if Scope (Base_Type (It.Typ)) = S then + return True; + end if; + + Get_Next_Interp (I, It); + end loop; + + return False; + end if; + end Operand_Type_In_Scope; + + --------------- + -- Type_In_P -- + --------------- + + function Type_In_P (Test : Kind_Test) return Entity_Id is + E : Entity_Id; + + function In_Decl return Boolean; + -- Verify that node is not part of the type declaration for the + -- candidate type, which would otherwise be invisible. + + ------------- + -- In_Decl -- + ------------- + + function In_Decl return Boolean is + Decl_Node : constant Node_Id := Parent (E); + N2 : Node_Id; + + begin + N2 := N; + + if Etype (E) = Any_Type then + return True; + + elsif No (Decl_Node) then + return False; + + else + while Present (N2) + and then Nkind (N2) /= N_Compilation_Unit + loop + if N2 = Decl_Node then + return True; + else + N2 := Parent (N2); + end if; + end loop; + + return False; + end if; + end In_Decl; + + -- Start of processing for Type_In_P + + begin + -- If the context type is declared in the prefix package, this is the + -- desired base type. + + if Scope (Base_Type (Typ)) = Pack and then Test (Typ) then + return Base_Type (Typ); + + else + E := First_Entity (Pack); + while Present (E) loop + if Test (E) + and then not In_Decl + then + return E; + end if; + + Next_Entity (E); + end loop; + + return Empty; + end if; + end Type_In_P; + + -- Start of processing for Make_Call_Into_Operator + + begin + Op_Node := New_Node (Operator_Kind (Op_Name, Is_Binary), Sloc (N)); + + -- Binary operator + + if Is_Binary then + Set_Left_Opnd (Op_Node, Relocate_Node (Act1)); + Set_Right_Opnd (Op_Node, Relocate_Node (Act2)); + Save_Interps (Act1, Left_Opnd (Op_Node)); + Save_Interps (Act2, Right_Opnd (Op_Node)); + Act1 := Left_Opnd (Op_Node); + Act2 := Right_Opnd (Op_Node); + + -- Unary operator + + else + Set_Right_Opnd (Op_Node, Relocate_Node (Act1)); + Save_Interps (Act1, Right_Opnd (Op_Node)); + Act1 := Right_Opnd (Op_Node); + end if; + + -- If the operator is denoted by an expanded name, and the prefix is + -- not Standard, but the operator is a predefined one whose scope is + -- Standard, then this is an implicit_operator, inserted as an + -- interpretation by the procedure of the same name. This procedure + -- overestimates the presence of implicit operators, because it does + -- not examine the type of the operands. Verify now that the operand + -- type appears in the given scope. If right operand is universal, + -- check the other operand. In the case of concatenation, either + -- argument can be the component type, so check the type of the result. + -- If both arguments are literals, look for a type of the right kind + -- defined in the given scope. This elaborate nonsense is brought to + -- you courtesy of b33302a. The type itself must be frozen, so we must + -- find the type of the proper class in the given scope. + + -- A final wrinkle is the multiplication operator for fixed point types, + -- which is defined in Standard only, and not in the scope of the + -- fixed point type itself. + + if Nkind (Name (N)) = N_Expanded_Name then + Pack := Entity (Prefix (Name (N))); + + -- If the entity being called is defined in the given package, it is + -- a renaming of a predefined operator, and known to be legal. + + if Scope (Entity (Name (N))) = Pack + and then Pack /= Standard_Standard + then + null; + + -- Visibility does not need to be checked in an instance: if the + -- operator was not visible in the generic it has been diagnosed + -- already, else there is an implicit copy of it in the instance. + + elsif In_Instance then + null; + + elsif (Op_Name = Name_Op_Multiply or else Op_Name = Name_Op_Divide) + and then Is_Fixed_Point_Type (Etype (Left_Opnd (Op_Node))) + and then Is_Fixed_Point_Type (Etype (Right_Opnd (Op_Node))) + then + if Pack /= Standard_Standard then + Error := True; + end if; + + -- Ada 2005 AI-420: Predefined equality on Universal_Access is + -- available. + + elsif Ada_Version >= Ada_2005 + and then (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne) + and then Ekind (Etype (Act1)) = E_Anonymous_Access_Type + then + null; + + else + Opnd_Type := Base_Type (Etype (Right_Opnd (Op_Node))); + + if Op_Name = Name_Op_Concat then + Opnd_Type := Base_Type (Typ); + + elsif (Scope (Opnd_Type) = Standard_Standard + and then Is_Binary) + or else (Nkind (Right_Opnd (Op_Node)) = N_Attribute_Reference + and then Is_Binary + and then not Comes_From_Source (Opnd_Type)) + then + Opnd_Type := Base_Type (Etype (Left_Opnd (Op_Node))); + end if; + + if Scope (Opnd_Type) = Standard_Standard then + + -- Verify that the scope contains a type that corresponds to + -- the given literal. Optimize the case where Pack is Standard. + + if Pack /= Standard_Standard then + + if Opnd_Type = Universal_Integer then + Orig_Type := Type_In_P (Is_Integer_Type'Access); + + elsif Opnd_Type = Universal_Real then + Orig_Type := Type_In_P (Is_Real_Type'Access); + + elsif Opnd_Type = Any_String then + Orig_Type := Type_In_P (Is_String_Type'Access); + + elsif Opnd_Type = Any_Access then + Orig_Type := Type_In_P (Is_Definite_Access_Type'Access); + + elsif Opnd_Type = Any_Composite then + Orig_Type := Type_In_P (Is_Composite_Type'Access); + + if Present (Orig_Type) then + if Has_Private_Component (Orig_Type) then + Orig_Type := Empty; + else + Set_Etype (Act1, Orig_Type); + + if Is_Binary then + Set_Etype (Act2, Orig_Type); + end if; + end if; + end if; + + else + Orig_Type := Empty; + end if; + + Error := No (Orig_Type); + end if; + + elsif Ekind (Opnd_Type) = E_Allocator_Type + and then No (Type_In_P (Is_Definite_Access_Type'Access)) + then + Error := True; + + -- If the type is defined elsewhere, and the operator is not + -- defined in the given scope (by a renaming declaration, e.g.) + -- then this is an error as well. If an extension of System is + -- present, and the type may be defined there, Pack must be + -- System itself. + + elsif Scope (Opnd_Type) /= Pack + and then Scope (Op_Id) /= Pack + and then (No (System_Aux_Id) + or else Scope (Opnd_Type) /= System_Aux_Id + or else Pack /= Scope (System_Aux_Id)) + then + if not Is_Overloaded (Right_Opnd (Op_Node)) then + Error := True; + else + Error := not Operand_Type_In_Scope (Pack); + end if; + + elsif Pack = Standard_Standard + and then not Operand_Type_In_Scope (Standard_Standard) + then + Error := True; + end if; + end if; + + if Error then + Error_Msg_Node_2 := Pack; + Error_Msg_NE + ("& not declared in&", N, Selector_Name (Name (N))); + Set_Etype (N, Any_Type); + return; + + -- Detect a mismatch between the context type and the result type + -- in the named package, which is otherwise not detected if the + -- operands are universal. Check is only needed if source entity is + -- an operator, not a function that renames an operator. + + elsif Nkind (Parent (N)) /= N_Type_Conversion + and then Ekind (Entity (Name (N))) = E_Operator + and then Is_Numeric_Type (Typ) + and then not Is_Universal_Numeric_Type (Typ) + and then Scope (Base_Type (Typ)) /= Pack + and then not In_Instance + then + if Is_Fixed_Point_Type (Typ) + and then (Op_Name = Name_Op_Multiply + or else + Op_Name = Name_Op_Divide) + then + -- Already checked above + + null; + + -- Operator may be defined in an extension of System + + elsif Present (System_Aux_Id) + and then Scope (Opnd_Type) = System_Aux_Id + then + null; + + else + -- Could we use Wrong_Type here??? (this would require setting + -- Etype (N) to the actual type found where Typ was expected). + + Error_Msg_NE ("expect }", N, Typ); + end if; + end if; + end if; + + Set_Chars (Op_Node, Op_Name); + + if not Is_Private_Type (Etype (N)) then + Set_Etype (Op_Node, Base_Type (Etype (N))); + else + Set_Etype (Op_Node, Etype (N)); + end if; + + -- If this is a call to a function that renames a predefined equality, + -- the renaming declaration provides a type that must be used to + -- resolve the operands. This must be done now because resolution of + -- the equality node will not resolve any remaining ambiguity, and it + -- assumes that the first operand is not overloaded. + + if (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne) + and then Ekind (Func) = E_Function + and then Is_Overloaded (Act1) + then + Resolve (Act1, Base_Type (Etype (First_Formal (Func)))); + Resolve (Act2, Base_Type (Etype (First_Formal (Func)))); + end if; + + Set_Entity (Op_Node, Op_Id); + Generate_Reference (Op_Id, N, ' '); + + -- Do rewrite setting Comes_From_Source on the result if the original + -- call came from source. Although it is not strictly the case that the + -- operator as such comes from the source, logically it corresponds + -- exactly to the function call in the source, so it should be marked + -- this way (e.g. to make sure that validity checks work fine). + + declare + CS : constant Boolean := Comes_From_Source (N); + begin + Rewrite (N, Op_Node); + Set_Comes_From_Source (N, CS); + end; + + -- If this is an arithmetic operator and the result type is private, + -- the operands and the result must be wrapped in conversion to + -- expose the underlying numeric type and expand the proper checks, + -- e.g. on division. + + if Is_Private_Type (Typ) then + case Nkind (N) is + when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide | + N_Op_Expon | N_Op_Mod | N_Op_Rem => + Resolve_Intrinsic_Operator (N, Typ); + + when N_Op_Plus | N_Op_Minus | N_Op_Abs => + Resolve_Intrinsic_Unary_Operator (N, Typ); + + when others => + Resolve (N, Typ); + end case; + else + Resolve (N, Typ); + end if; + end Make_Call_Into_Operator; + + ------------------- + -- Operator_Kind -- + ------------------- + + function Operator_Kind + (Op_Name : Name_Id; + Is_Binary : Boolean) return Node_Kind + is + Kind : Node_Kind; + + begin + if Is_Binary then + if Op_Name = Name_Op_And then + Kind := N_Op_And; + elsif Op_Name = Name_Op_Or then + Kind := N_Op_Or; + elsif Op_Name = Name_Op_Xor then + Kind := N_Op_Xor; + elsif Op_Name = Name_Op_Eq then + Kind := N_Op_Eq; + elsif Op_Name = Name_Op_Ne then + Kind := N_Op_Ne; + elsif Op_Name = Name_Op_Lt then + Kind := N_Op_Lt; + elsif Op_Name = Name_Op_Le then + Kind := N_Op_Le; + elsif Op_Name = Name_Op_Gt then + Kind := N_Op_Gt; + elsif Op_Name = Name_Op_Ge then + Kind := N_Op_Ge; + elsif Op_Name = Name_Op_Add then + Kind := N_Op_Add; + elsif Op_Name = Name_Op_Subtract then + Kind := N_Op_Subtract; + elsif Op_Name = Name_Op_Concat then + Kind := N_Op_Concat; + elsif Op_Name = Name_Op_Multiply then + Kind := N_Op_Multiply; + elsif Op_Name = Name_Op_Divide then + Kind := N_Op_Divide; + elsif Op_Name = Name_Op_Mod then + Kind := N_Op_Mod; + elsif Op_Name = Name_Op_Rem then + Kind := N_Op_Rem; + elsif Op_Name = Name_Op_Expon then + Kind := N_Op_Expon; + else + raise Program_Error; + end if; + + -- Unary operators + + else + if Op_Name = Name_Op_Add then + Kind := N_Op_Plus; + elsif Op_Name = Name_Op_Subtract then + Kind := N_Op_Minus; + elsif Op_Name = Name_Op_Abs then + Kind := N_Op_Abs; + elsif Op_Name = Name_Op_Not then + Kind := N_Op_Not; + else + raise Program_Error; + end if; + end if; + + return Kind; + end Operator_Kind; + + ---------------------------- + -- Preanalyze_And_Resolve -- + ---------------------------- + + procedure Preanalyze_And_Resolve (N : Node_Id; T : Entity_Id) is + Save_Full_Analysis : constant Boolean := Full_Analysis; + + begin + Full_Analysis := False; + Expander_Mode_Save_And_Set (False); + + -- We suppress all checks for this analysis, since the checks will + -- be applied properly, and in the right location, when the default + -- expression is reanalyzed and reexpanded later on. + + Analyze_And_Resolve (N, T, Suppress => All_Checks); + + Expander_Mode_Restore; + Full_Analysis := Save_Full_Analysis; + end Preanalyze_And_Resolve; + + -- Version without context type + + procedure Preanalyze_And_Resolve (N : Node_Id) is + Save_Full_Analysis : constant Boolean := Full_Analysis; + + begin + Full_Analysis := False; + Expander_Mode_Save_And_Set (False); + + Analyze (N); + Resolve (N, Etype (N), Suppress => All_Checks); + + Expander_Mode_Restore; + Full_Analysis := Save_Full_Analysis; + end Preanalyze_And_Resolve; + + ---------------------------------- + -- Replace_Actual_Discriminants -- + ---------------------------------- + + procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Tsk : Node_Id := Empty; + + function Process_Discr (Nod : Node_Id) return Traverse_Result; + + ------------------- + -- Process_Discr -- + ------------------- + + function Process_Discr (Nod : Node_Id) return Traverse_Result is + Ent : Entity_Id; + + begin + if Nkind (Nod) = N_Identifier then + Ent := Entity (Nod); + + if Present (Ent) + and then Ekind (Ent) = E_Discriminant + then + Rewrite (Nod, + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Tsk, New_Sloc => Loc), + Selector_Name => Make_Identifier (Loc, Chars (Ent)))); + + Set_Etype (Nod, Etype (Ent)); + end if; + + end if; + + return OK; + end Process_Discr; + + procedure Replace_Discrs is new Traverse_Proc (Process_Discr); + + -- Start of processing for Replace_Actual_Discriminants + + begin + if not Expander_Active then + return; + end if; + + if Nkind (Name (N)) = N_Selected_Component then + Tsk := Prefix (Name (N)); + + elsif Nkind (Name (N)) = N_Indexed_Component then + Tsk := Prefix (Prefix (Name (N))); + end if; + + if No (Tsk) then + return; + else + Replace_Discrs (Default); + end if; + end Replace_Actual_Discriminants; + + ------------- + -- Resolve -- + ------------- + + procedure Resolve (N : Node_Id; Typ : Entity_Id) is + Ambiguous : Boolean := False; + Ctx_Type : Entity_Id := Typ; + Expr_Type : Entity_Id := Empty; -- prevent junk warning + Err_Type : Entity_Id := Empty; + Found : Boolean := False; + From_Lib : Boolean; + I : Interp_Index; + I1 : Interp_Index := 0; -- prevent junk warning + It : Interp; + It1 : Interp; + Seen : Entity_Id := Empty; -- prevent junk warning + + function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean; + -- Determine whether a node comes from a predefined library unit or + -- Standard. + + procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id); + -- Try and fix up a literal so that it matches its expected type. New + -- literals are manufactured if necessary to avoid cascaded errors. + + procedure Report_Ambiguous_Argument; + -- Additional diagnostics when an ambiguous call has an ambiguous + -- argument (typically a controlling actual). + + procedure Resolution_Failed; + -- Called when attempt at resolving current expression fails + + ------------------------------------ + -- Comes_From_Predefined_Lib_Unit -- + ------------------------------------- + + function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean is + begin + return + Sloc (Nod) = Standard_Location + or else Is_Predefined_File_Name (Unit_File_Name ( + Get_Source_Unit (Sloc (Nod)))); + end Comes_From_Predefined_Lib_Unit; + + -------------------- + -- Patch_Up_Value -- + -------------------- + + procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id) is + begin + if Nkind (N) = N_Integer_Literal + and then Is_Real_Type (Typ) + then + Rewrite (N, + Make_Real_Literal (Sloc (N), + Realval => UR_From_Uint (Intval (N)))); + Set_Etype (N, Universal_Real); + Set_Is_Static_Expression (N); + + elsif Nkind (N) = N_Real_Literal + and then Is_Integer_Type (Typ) + then + Rewrite (N, + Make_Integer_Literal (Sloc (N), + Intval => UR_To_Uint (Realval (N)))); + Set_Etype (N, Universal_Integer); + Set_Is_Static_Expression (N); + + elsif Nkind (N) = N_String_Literal + and then Is_Character_Type (Typ) + then + Set_Character_Literal_Name (Char_Code (Character'Pos ('A'))); + Rewrite (N, + Make_Character_Literal (Sloc (N), + Chars => Name_Find, + Char_Literal_Value => + UI_From_Int (Character'Pos ('A')))); + Set_Etype (N, Any_Character); + Set_Is_Static_Expression (N); + + elsif Nkind (N) /= N_String_Literal + and then Is_String_Type (Typ) + then + Rewrite (N, + Make_String_Literal (Sloc (N), + Strval => End_String)); + + elsif Nkind (N) = N_Range then + Patch_Up_Value (Low_Bound (N), Typ); + Patch_Up_Value (High_Bound (N), Typ); + end if; + end Patch_Up_Value; + + ------------------------------- + -- Report_Ambiguous_Argument -- + ------------------------------- + + procedure Report_Ambiguous_Argument is + Arg : constant Node_Id := First (Parameter_Associations (N)); + I : Interp_Index; + It : Interp; + + begin + if Nkind (Arg) = N_Function_Call + and then Is_Entity_Name (Name (Arg)) + and then Is_Overloaded (Name (Arg)) + then + Error_Msg_NE ("ambiguous call to&", Arg, Name (Arg)); + + -- Could use comments on what is going on here ??? + + Get_First_Interp (Name (Arg), I, It); + while Present (It.Nam) loop + Error_Msg_Sloc := Sloc (It.Nam); + + if Nkind (Parent (It.Nam)) = N_Full_Type_Declaration then + Error_Msg_N ("interpretation (inherited) #!", Arg); + else + Error_Msg_N ("interpretation #!", Arg); + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + end Report_Ambiguous_Argument; + + ----------------------- + -- Resolution_Failed -- + ----------------------- + + procedure Resolution_Failed is + begin + Patch_Up_Value (N, Typ); + Set_Etype (N, Typ); + Debug_A_Exit ("resolving ", N, " (done, resolution failed)"); + Set_Is_Overloaded (N, False); + + -- The caller will return without calling the expander, so we need + -- to set the analyzed flag. Note that it is fine to set Analyzed + -- to True even if we are in the middle of a shallow analysis, + -- (see the spec of sem for more details) since this is an error + -- situation anyway, and there is no point in repeating the + -- analysis later (indeed it won't work to repeat it later, since + -- we haven't got a clear resolution of which entity is being + -- referenced.) + + Set_Analyzed (N, True); + return; + end Resolution_Failed; + + -- Start of processing for Resolve + + begin + if N = Error then + return; + end if; + + -- Access attribute on remote subprogram cannot be used for + -- a non-remote access-to-subprogram type. + + if Nkind (N) = N_Attribute_Reference + and then (Attribute_Name (N) = Name_Access + or else Attribute_Name (N) = Name_Unrestricted_Access + or else Attribute_Name (N) = Name_Unchecked_Access) + and then Comes_From_Source (N) + and then Is_Entity_Name (Prefix (N)) + and then Is_Subprogram (Entity (Prefix (N))) + and then Is_Remote_Call_Interface (Entity (Prefix (N))) + and then not Is_Remote_Access_To_Subprogram_Type (Typ) + then + Error_Msg_N + ("prefix must statically denote a non-remote subprogram", N); + end if; + + From_Lib := Comes_From_Predefined_Lib_Unit (N); + + -- If the context is a Remote_Access_To_Subprogram, access attributes + -- must be resolved with the corresponding fat pointer. There is no need + -- to check for the attribute name since the return type of an + -- attribute is never a remote type. + + if Nkind (N) = N_Attribute_Reference + and then Comes_From_Source (N) + and then (Is_Remote_Call_Interface (Typ) + or else Is_Remote_Types (Typ)) + then + declare + Attr : constant Attribute_Id := + Get_Attribute_Id (Attribute_Name (N)); + Pref : constant Node_Id := Prefix (N); + Decl : Node_Id; + Spec : Node_Id; + Is_Remote : Boolean := True; + + begin + -- Check that Typ is a remote access-to-subprogram type + + if Is_Remote_Access_To_Subprogram_Type (Typ) then + + -- Prefix (N) must statically denote a remote subprogram + -- declared in a package specification. + + if Attr = Attribute_Access then + Decl := Unit_Declaration_Node (Entity (Pref)); + + if Nkind (Decl) = N_Subprogram_Body then + Spec := Corresponding_Spec (Decl); + + if not No (Spec) then + Decl := Unit_Declaration_Node (Spec); + end if; + end if; + + Spec := Parent (Decl); + + if not Is_Entity_Name (Prefix (N)) + or else Nkind (Spec) /= N_Package_Specification + or else + not Is_Remote_Call_Interface (Defining_Entity (Spec)) + then + Is_Remote := False; + Error_Msg_N + ("prefix must statically denote a remote subprogram ", + N); + end if; + end if; + + -- If we are generating code for a distributed program. + -- perform semantic checks against the corresponding + -- remote entities. + + if (Attr = Attribute_Access + or else Attr = Attribute_Unchecked_Access + or else Attr = Attribute_Unrestricted_Access) + and then Expander_Active + and then Get_PCS_Name /= Name_No_DSA + then + Check_Subtype_Conformant + (New_Id => Entity (Prefix (N)), + Old_Id => Designated_Type + (Corresponding_Remote_Type (Typ)), + Err_Loc => N); + + if Is_Remote then + Process_Remote_AST_Attribute (N, Typ); + end if; + end if; + end if; + end; + end if; + + Debug_A_Entry ("resolving ", N); + + if Comes_From_Source (N) then + if Is_Fixed_Point_Type (Typ) then + Check_Restriction (No_Fixed_Point, N); + + elsif Is_Floating_Point_Type (Typ) + and then Typ /= Universal_Real + and then Typ /= Any_Real + then + Check_Restriction (No_Floating_Point, N); + end if; + end if; + + -- Return if already analyzed + + if Analyzed (N) then + Debug_A_Exit ("resolving ", N, " (done, already analyzed)"); + return; + + -- Return if type = Any_Type (previous error encountered) + + elsif Etype (N) = Any_Type then + Debug_A_Exit ("resolving ", N, " (done, Etype = Any_Type)"); + return; + end if; + + Check_Parameterless_Call (N); + + -- If not overloaded, then we know the type, and all that needs doing + -- is to check that this type is compatible with the context. + + if not Is_Overloaded (N) then + Found := Covers (Typ, Etype (N)); + Expr_Type := Etype (N); + + -- In the overloaded case, we must select the interpretation that + -- is compatible with the context (i.e. the type passed to Resolve) + + else + -- Loop through possible interpretations + + Get_First_Interp (N, I, It); + Interp_Loop : while Present (It.Typ) loop + + -- We are only interested in interpretations that are compatible + -- with the expected type, any other interpretations are ignored. + + if not Covers (Typ, It.Typ) then + if Debug_Flag_V then + Write_Str (" interpretation incompatible with context"); + Write_Eol; + end if; + + else + -- Skip the current interpretation if it is disabled by an + -- abstract operator. This action is performed only when the + -- type against which we are resolving is the same as the + -- type of the interpretation. + + if Ada_Version >= Ada_2005 + and then It.Typ = Typ + and then Typ /= Universal_Integer + and then Typ /= Universal_Real + and then Present (It.Abstract_Op) + then + goto Continue; + end if; + + -- First matching interpretation + + if not Found then + Found := True; + I1 := I; + Seen := It.Nam; + Expr_Type := It.Typ; + + -- Matching interpretation that is not the first, maybe an + -- error, but there are some cases where preference rules are + -- used to choose between the two possibilities. These and + -- some more obscure cases are handled in Disambiguate. + + else + -- If the current statement is part of a predefined library + -- unit, then all interpretations which come from user level + -- packages should not be considered. + + if From_Lib + and then not Comes_From_Predefined_Lib_Unit (It.Nam) + then + goto Continue; + end if; + + Error_Msg_Sloc := Sloc (Seen); + It1 := Disambiguate (N, I1, I, Typ); + + -- Disambiguation has succeeded. Skip the remaining + -- interpretations. + + if It1 /= No_Interp then + Seen := It1.Nam; + Expr_Type := It1.Typ; + + while Present (It.Typ) loop + Get_Next_Interp (I, It); + end loop; + + else + -- Before we issue an ambiguity complaint, check for + -- the case of a subprogram call where at least one + -- of the arguments is Any_Type, and if so, suppress + -- the message, since it is a cascaded error. + + if Nkind_In (N, N_Function_Call, + N_Procedure_Call_Statement) + then + declare + A : Node_Id; + E : Node_Id; + + begin + A := First_Actual (N); + while Present (A) loop + E := A; + + if Nkind (E) = N_Parameter_Association then + E := Explicit_Actual_Parameter (E); + end if; + + if Etype (E) = Any_Type then + if Debug_Flag_V then + Write_Str ("Any_Type in call"); + Write_Eol; + end if; + + exit Interp_Loop; + end if; + + Next_Actual (A); + end loop; + end; + + elsif Nkind (N) in N_Binary_Op + and then (Etype (Left_Opnd (N)) = Any_Type + or else Etype (Right_Opnd (N)) = Any_Type) + then + exit Interp_Loop; + + elsif Nkind (N) in N_Unary_Op + and then Etype (Right_Opnd (N)) = Any_Type + then + exit Interp_Loop; + end if; + + -- Not that special case, so issue message using the + -- flag Ambiguous to control printing of the header + -- message only at the start of an ambiguous set. + + if not Ambiguous then + if Nkind (N) = N_Function_Call + and then Nkind (Name (N)) = N_Explicit_Dereference + then + Error_Msg_N + ("ambiguous expression " + & "(cannot resolve indirect call)!", N); + else + Error_Msg_NE -- CODEFIX + ("ambiguous expression (cannot resolve&)!", + N, It.Nam); + end if; + + Ambiguous := True; + + if Nkind (Parent (Seen)) = N_Full_Type_Declaration then + Error_Msg_N + ("\\possible interpretation (inherited)#!", N); + else + Error_Msg_N -- CODEFIX + ("\\possible interpretation#!", N); + end if; + + if Nkind_In + (N, N_Procedure_Call_Statement, N_Function_Call) + and then Present (Parameter_Associations (N)) + then + Report_Ambiguous_Argument; + end if; + end if; + + Error_Msg_Sloc := Sloc (It.Nam); + + -- By default, the error message refers to the candidate + -- interpretation. But if it is a predefined operator, it + -- is implicitly declared at the declaration of the type + -- of the operand. Recover the sloc of that declaration + -- for the error message. + + if Nkind (N) in N_Op + and then Scope (It.Nam) = Standard_Standard + and then not Is_Overloaded (Right_Opnd (N)) + and then Scope (Base_Type (Etype (Right_Opnd (N)))) /= + Standard_Standard + then + Err_Type := First_Subtype (Etype (Right_Opnd (N))); + + if Comes_From_Source (Err_Type) + and then Present (Parent (Err_Type)) + then + Error_Msg_Sloc := Sloc (Parent (Err_Type)); + end if; + + elsif Nkind (N) in N_Binary_Op + and then Scope (It.Nam) = Standard_Standard + and then not Is_Overloaded (Left_Opnd (N)) + and then Scope (Base_Type (Etype (Left_Opnd (N)))) /= + Standard_Standard + then + Err_Type := First_Subtype (Etype (Left_Opnd (N))); + + if Comes_From_Source (Err_Type) + and then Present (Parent (Err_Type)) + then + Error_Msg_Sloc := Sloc (Parent (Err_Type)); + end if; + + -- If this is an indirect call, use the subprogram_type + -- in the message, to have a meaningful location. + -- Also indicate if this is an inherited operation, + -- created by a type declaration. + + elsif Nkind (N) = N_Function_Call + and then Nkind (Name (N)) = N_Explicit_Dereference + and then Is_Type (It.Nam) + then + Err_Type := It.Nam; + Error_Msg_Sloc := + Sloc (Associated_Node_For_Itype (Err_Type)); + else + Err_Type := Empty; + end if; + + if Nkind (N) in N_Op + and then Scope (It.Nam) = Standard_Standard + and then Present (Err_Type) + then + -- Special-case the message for universal_fixed + -- operators, which are not declared with the type + -- of the operand, but appear forever in Standard. + + if It.Typ = Universal_Fixed + and then Scope (It.Nam) = Standard_Standard + then + Error_Msg_N + ("\\possible interpretation as " & + "universal_fixed operation " & + "(RM 4.5.5 (19))", N); + else + Error_Msg_N + ("\\possible interpretation (predefined)#!", N); + end if; + + elsif + Nkind (Parent (It.Nam)) = N_Full_Type_Declaration + then + Error_Msg_N + ("\\possible interpretation (inherited)#!", N); + else + Error_Msg_N -- CODEFIX + ("\\possible interpretation#!", N); + end if; + + end if; + end if; + + -- We have a matching interpretation, Expr_Type is the type + -- from this interpretation, and Seen is the entity. + + -- For an operator, just set the entity name. The type will be + -- set by the specific operator resolution routine. + + if Nkind (N) in N_Op then + Set_Entity (N, Seen); + Generate_Reference (Seen, N); + + elsif Nkind (N) = N_Case_Expression then + Set_Etype (N, Expr_Type); + + elsif Nkind (N) = N_Character_Literal then + Set_Etype (N, Expr_Type); + + elsif Nkind (N) = N_Conditional_Expression then + Set_Etype (N, Expr_Type); + + -- For an explicit dereference, attribute reference, range, + -- short-circuit form (which is not an operator node), or call + -- with a name that is an explicit dereference, there is + -- nothing to be done at this point. + + elsif Nkind_In (N, N_Explicit_Dereference, + N_Attribute_Reference, + N_And_Then, + N_Indexed_Component, + N_Or_Else, + N_Range, + N_Selected_Component, + N_Slice) + or else Nkind (Name (N)) = N_Explicit_Dereference + then + null; + + -- For procedure or function calls, set the type of the name, + -- and also the entity pointer for the prefix. + + elsif Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) + and then Is_Entity_Name (Name (N)) + then + Set_Etype (Name (N), Expr_Type); + Set_Entity (Name (N), Seen); + Generate_Reference (Seen, Name (N)); + + elsif Nkind (N) = N_Function_Call + and then Nkind (Name (N)) = N_Selected_Component + then + Set_Etype (Name (N), Expr_Type); + Set_Entity (Selector_Name (Name (N)), Seen); + Generate_Reference (Seen, Selector_Name (Name (N))); + + -- For all other cases, just set the type of the Name + + else + Set_Etype (Name (N), Expr_Type); + end if; + + end if; + + <> + + -- Move to next interpretation + + exit Interp_Loop when No (It.Typ); + + Get_Next_Interp (I, It); + end loop Interp_Loop; + end if; + + -- At this stage Found indicates whether or not an acceptable + -- interpretation exists. If not, then we have an error, except that if + -- the context is Any_Type as a result of some other error, then we + -- suppress the error report. + + if not Found then + if Typ /= Any_Type then + + -- If type we are looking for is Void, then this is the procedure + -- call case, and the error is simply that what we gave is not a + -- procedure name (we think of procedure calls as expressions with + -- types internally, but the user doesn't think of them this way!) + + if Typ = Standard_Void_Type then + + -- Special case message if function used as a procedure + + if Nkind (N) = N_Procedure_Call_Statement + and then Is_Entity_Name (Name (N)) + and then Ekind (Entity (Name (N))) = E_Function + then + Error_Msg_NE + ("cannot use function & in a procedure call", + Name (N), Entity (Name (N))); + + -- Otherwise give general message (not clear what cases this + -- covers, but no harm in providing for them!) + + else + Error_Msg_N ("expect procedure name in procedure call", N); + end if; + + Found := True; + + -- Otherwise we do have a subexpression with the wrong type + + -- Check for the case of an allocator which uses an access type + -- instead of the designated type. This is a common error and we + -- specialize the message, posting an error on the operand of the + -- allocator, complaining that we expected the designated type of + -- the allocator. + + elsif Nkind (N) = N_Allocator + and then Ekind (Typ) in Access_Kind + and then Ekind (Etype (N)) in Access_Kind + and then Designated_Type (Etype (N)) = Typ + then + Wrong_Type (Expression (N), Designated_Type (Typ)); + Found := True; + + -- Check for view mismatch on Null in instances, for which the + -- view-swapping mechanism has no identifier. + + elsif (In_Instance or else In_Inlined_Body) + and then (Nkind (N) = N_Null) + and then Is_Private_Type (Typ) + and then Is_Access_Type (Full_View (Typ)) + then + Resolve (N, Full_View (Typ)); + Set_Etype (N, Typ); + return; + + -- Check for an aggregate. Sometimes we can get bogus aggregates + -- from misuse of parentheses, and we are about to complain about + -- the aggregate without even looking inside it. + + -- Instead, if we have an aggregate of type Any_Composite, then + -- analyze and resolve the component fields, and then only issue + -- another message if we get no errors doing this (otherwise + -- assume that the errors in the aggregate caused the problem). + + elsif Nkind (N) = N_Aggregate + and then Etype (N) = Any_Composite + then + -- Disable expansion in any case. If there is a type mismatch + -- it may be fatal to try to expand the aggregate. The flag + -- would otherwise be set to false when the error is posted. + + Expander_Active := False; + + declare + procedure Check_Aggr (Aggr : Node_Id); + -- Check one aggregate, and set Found to True if we have a + -- definite error in any of its elements + + procedure Check_Elmt (Aelmt : Node_Id); + -- Check one element of aggregate and set Found to True if + -- we definitely have an error in the element. + + ---------------- + -- Check_Aggr -- + ---------------- + + procedure Check_Aggr (Aggr : Node_Id) is + Elmt : Node_Id; + + begin + if Present (Expressions (Aggr)) then + Elmt := First (Expressions (Aggr)); + while Present (Elmt) loop + Check_Elmt (Elmt); + Next (Elmt); + end loop; + end if; + + if Present (Component_Associations (Aggr)) then + Elmt := First (Component_Associations (Aggr)); + while Present (Elmt) loop + + -- If this is a default-initialized component, then + -- there is nothing to check. The box will be + -- replaced by the appropriate call during late + -- expansion. + + if not Box_Present (Elmt) then + Check_Elmt (Expression (Elmt)); + end if; + + Next (Elmt); + end loop; + end if; + end Check_Aggr; + + ---------------- + -- Check_Elmt -- + ---------------- + + procedure Check_Elmt (Aelmt : Node_Id) is + begin + -- If we have a nested aggregate, go inside it (to + -- attempt a naked analyze-resolve of the aggregate + -- can cause undesirable cascaded errors). Do not + -- resolve expression if it needs a type from context, + -- as for integer * fixed expression. + + if Nkind (Aelmt) = N_Aggregate then + Check_Aggr (Aelmt); + + else + Analyze (Aelmt); + + if not Is_Overloaded (Aelmt) + and then Etype (Aelmt) /= Any_Fixed + then + Resolve (Aelmt); + end if; + + if Etype (Aelmt) = Any_Type then + Found := True; + end if; + end if; + end Check_Elmt; + + begin + Check_Aggr (N); + end; + end if; + + -- If an error message was issued already, Found got reset + -- to True, so if it is still False, issue the standard + -- Wrong_Type message. + + if not Found then + if Is_Overloaded (N) + and then Nkind (N) = N_Function_Call + then + declare + Subp_Name : Node_Id; + begin + if Is_Entity_Name (Name (N)) then + Subp_Name := Name (N); + + elsif Nkind (Name (N)) = N_Selected_Component then + + -- Protected operation: retrieve operation name + + Subp_Name := Selector_Name (Name (N)); + else + raise Program_Error; + end if; + + Error_Msg_Node_2 := Typ; + Error_Msg_NE ("no visible interpretation of&" & + " matches expected type&", N, Subp_Name); + end; + + if All_Errors_Mode then + declare + Index : Interp_Index; + It : Interp; + + begin + Error_Msg_N ("\\possible interpretations:", N); + + Get_First_Interp (Name (N), Index, It); + while Present (It.Nam) loop + Error_Msg_Sloc := Sloc (It.Nam); + Error_Msg_Node_2 := It.Nam; + Error_Msg_NE + ("\\ type& for & declared#", N, It.Typ); + Get_Next_Interp (Index, It); + end loop; + end; + + else + Error_Msg_N ("\use -gnatf for details", N); + end if; + else + Wrong_Type (N, Typ); + end if; + end if; + end if; + + Resolution_Failed; + return; + + -- Test if we have more than one interpretation for the context + + elsif Ambiguous then + Resolution_Failed; + return; + + -- Here we have an acceptable interpretation for the context + + else + -- Propagate type information and normalize tree for various + -- predefined operations. If the context only imposes a class of + -- types, rather than a specific type, propagate the actual type + -- downward. + + if Typ = Any_Integer + or else Typ = Any_Boolean + or else Typ = Any_Modular + or else Typ = Any_Real + or else Typ = Any_Discrete + then + Ctx_Type := Expr_Type; + + -- Any_Fixed is legal in a real context only if a specific + -- fixed point type is imposed. If Norman Cohen can be + -- confused by this, it deserves a separate message. + + if Typ = Any_Real + and then Expr_Type = Any_Fixed + then + Error_Msg_N ("illegal context for mixed mode operation", N); + Set_Etype (N, Universal_Real); + Ctx_Type := Universal_Real; + end if; + end if; + + -- A user-defined operator is transformed into a function call at + -- this point, so that further processing knows that operators are + -- really operators (i.e. are predefined operators). User-defined + -- operators that are intrinsic are just renamings of the predefined + -- ones, and need not be turned into calls either, but if they rename + -- a different operator, we must transform the node accordingly. + -- Instantiations of Unchecked_Conversion are intrinsic but are + -- treated as functions, even if given an operator designator. + + if Nkind (N) in N_Op + and then Present (Entity (N)) + and then Ekind (Entity (N)) /= E_Operator + then + + if not Is_Predefined_Op (Entity (N)) then + Rewrite_Operator_As_Call (N, Entity (N)); + + elsif Present (Alias (Entity (N))) + and then + Nkind (Parent (Parent (Entity (N)))) = + N_Subprogram_Renaming_Declaration + then + Rewrite_Renamed_Operator (N, Alias (Entity (N)), Typ); + + -- If the node is rewritten, it will be fully resolved in + -- Rewrite_Renamed_Operator. + + if Analyzed (N) then + return; + end if; + end if; + end if; + + case N_Subexpr'(Nkind (N)) is + + when N_Aggregate => Resolve_Aggregate (N, Ctx_Type); + + when N_Allocator => Resolve_Allocator (N, Ctx_Type); + + when N_Short_Circuit + => Resolve_Short_Circuit (N, Ctx_Type); + + when N_Attribute_Reference + => Resolve_Attribute (N, Ctx_Type); + + when N_Case_Expression + => Resolve_Case_Expression (N, Ctx_Type); + + when N_Character_Literal + => Resolve_Character_Literal (N, Ctx_Type); + + when N_Conditional_Expression + => Resolve_Conditional_Expression (N, Ctx_Type); + + when N_Expanded_Name + => Resolve_Entity_Name (N, Ctx_Type); + + when N_Explicit_Dereference + => Resolve_Explicit_Dereference (N, Ctx_Type); + + when N_Expression_With_Actions + => Resolve_Expression_With_Actions (N, Ctx_Type); + + when N_Extension_Aggregate + => Resolve_Extension_Aggregate (N, Ctx_Type); + + when N_Function_Call + => Resolve_Call (N, Ctx_Type); + + when N_Identifier + => Resolve_Entity_Name (N, Ctx_Type); + + when N_Indexed_Component + => Resolve_Indexed_Component (N, Ctx_Type); + + when N_Integer_Literal + => Resolve_Integer_Literal (N, Ctx_Type); + + when N_Membership_Test + => Resolve_Membership_Op (N, Ctx_Type); + + when N_Null => Resolve_Null (N, Ctx_Type); + + when N_Op_And | N_Op_Or | N_Op_Xor + => Resolve_Logical_Op (N, Ctx_Type); + + when N_Op_Eq | N_Op_Ne + => Resolve_Equality_Op (N, Ctx_Type); + + when N_Op_Lt | N_Op_Le | N_Op_Gt | N_Op_Ge + => Resolve_Comparison_Op (N, Ctx_Type); + + when N_Op_Not => Resolve_Op_Not (N, Ctx_Type); + + when N_Op_Add | N_Op_Subtract | N_Op_Multiply | + N_Op_Divide | N_Op_Mod | N_Op_Rem + + => Resolve_Arithmetic_Op (N, Ctx_Type); + + when N_Op_Concat => Resolve_Op_Concat (N, Ctx_Type); + + when N_Op_Expon => Resolve_Op_Expon (N, Ctx_Type); + + when N_Op_Plus | N_Op_Minus | N_Op_Abs + => Resolve_Unary_Op (N, Ctx_Type); + + when N_Op_Shift => Resolve_Shift (N, Ctx_Type); + + when N_Procedure_Call_Statement + => Resolve_Call (N, Ctx_Type); + + when N_Operator_Symbol + => Resolve_Operator_Symbol (N, Ctx_Type); + + when N_Qualified_Expression + => Resolve_Qualified_Expression (N, Ctx_Type); + + when N_Quantified_Expression + => Resolve_Quantified_Expression (N, Ctx_Type); + + when N_Raise_xxx_Error + => Set_Etype (N, Ctx_Type); + + when N_Range => Resolve_Range (N, Ctx_Type); + + when N_Real_Literal + => Resolve_Real_Literal (N, Ctx_Type); + + when N_Reference => Resolve_Reference (N, Ctx_Type); + + when N_Selected_Component + => Resolve_Selected_Component (N, Ctx_Type); + + when N_Slice => Resolve_Slice (N, Ctx_Type); + + when N_String_Literal + => Resolve_String_Literal (N, Ctx_Type); + + when N_Subprogram_Info + => Resolve_Subprogram_Info (N, Ctx_Type); + + when N_Type_Conversion + => Resolve_Type_Conversion (N, Ctx_Type); + + when N_Unchecked_Expression => + Resolve_Unchecked_Expression (N, Ctx_Type); + + when N_Unchecked_Type_Conversion => + Resolve_Unchecked_Type_Conversion (N, Ctx_Type); + end case; + + -- If the subexpression was replaced by a non-subexpression, then + -- all we do is to expand it. The only legitimate case we know of + -- is converting procedure call statement to entry call statements, + -- but there may be others, so we are making this test general. + + if Nkind (N) not in N_Subexpr then + Debug_A_Exit ("resolving ", N, " (done)"); + Expand (N); + return; + end if; + + -- AI05-144-2: Check dangerous order dependence within an expression + -- that is not a subexpression. Exclude RHS of an assignment, because + -- both sides may have side-effects and the check must be performed + -- over the statement. + + if Nkind (Parent (N)) not in N_Subexpr + and then Nkind (Parent (N)) /= N_Assignment_Statement + and then Nkind (Parent (N)) /= N_Procedure_Call_Statement + then + Check_Order_Dependence; + end if; + + -- The expression is definitely NOT overloaded at this point, so + -- we reset the Is_Overloaded flag to avoid any confusion when + -- reanalyzing the node. + + Set_Is_Overloaded (N, False); + + -- Freeze expression type, entity if it is a name, and designated + -- type if it is an allocator (RM 13.14(10,11,13)). + + -- Now that the resolution of the type of the node is complete, + -- and we did not detect an error, we can expand this node. We + -- skip the expand call if we are in a default expression, see + -- section "Handling of Default Expressions" in Sem spec. + + Debug_A_Exit ("resolving ", N, " (done)"); + + -- We unconditionally freeze the expression, even if we are in + -- default expression mode (the Freeze_Expression routine tests + -- this flag and only freezes static types if it is set). + + Freeze_Expression (N); + + -- Now we can do the expansion + + Expand (N); + end if; + end Resolve; + + ------------- + -- Resolve -- + ------------- + + -- Version with check(s) suppressed + + procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id) is + begin + if Suppress = All_Checks then + declare + Svg : constant Suppress_Array := Scope_Suppress; + begin + Scope_Suppress := (others => True); + Resolve (N, Typ); + Scope_Suppress := Svg; + end; + + else + declare + Svg : constant Boolean := Scope_Suppress (Suppress); + begin + Scope_Suppress (Suppress) := True; + Resolve (N, Typ); + Scope_Suppress (Suppress) := Svg; + end; + end if; + end Resolve; + + ------------- + -- Resolve -- + ------------- + + -- Version with implicit type + + procedure Resolve (N : Node_Id) is + begin + Resolve (N, Etype (N)); + end Resolve; + + --------------------- + -- Resolve_Actuals -- + --------------------- + + procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + A : Node_Id; + F : Entity_Id; + A_Typ : Entity_Id; + F_Typ : Entity_Id; + Prev : Node_Id := Empty; + Orig_A : Node_Id; + + procedure Check_Argument_Order; + -- Performs a check for the case where the actuals are all simple + -- identifiers that correspond to the formal names, but in the wrong + -- order, which is considered suspicious and cause for a warning. + + procedure Check_Prefixed_Call; + -- If the original node is an overloaded call in prefix notation, + -- insert an 'Access or a dereference as needed over the first actual. + -- Try_Object_Operation has already verified that there is a valid + -- interpretation, but the form of the actual can only be determined + -- once the primitive operation is identified. + + procedure Insert_Default; + -- If the actual is missing in a call, insert in the actuals list + -- an instance of the default expression. The insertion is always + -- a named association. + + function Same_Ancestor (T1, T2 : Entity_Id) return Boolean; + -- Check whether T1 and T2, or their full views, are derived from a + -- common type. Used to enforce the restrictions on array conversions + -- of AI95-00246. + + function Static_Concatenation (N : Node_Id) return Boolean; + -- Predicate to determine whether an actual that is a concatenation + -- will be evaluated statically and does not need a transient scope. + -- This must be determined before the actual is resolved and expanded + -- because if needed the transient scope must be introduced earlier. + + -------------------------- + -- Check_Argument_Order -- + -------------------------- + + procedure Check_Argument_Order is + begin + -- Nothing to do if no parameters, or original node is neither a + -- function call nor a procedure call statement (happens in the + -- operator-transformed-to-function call case), or the call does + -- not come from source, or this warning is off. + + if not Warn_On_Parameter_Order + or else + No (Parameter_Associations (N)) + or else + not Nkind_In (Original_Node (N), N_Procedure_Call_Statement, + N_Function_Call) + or else + not Comes_From_Source (N) + then + return; + end if; + + declare + Nargs : constant Nat := List_Length (Parameter_Associations (N)); + + begin + -- Nothing to do if only one parameter + + if Nargs < 2 then + return; + end if; + + -- Here if at least two arguments + + declare + Actuals : array (1 .. Nargs) of Node_Id; + Actual : Node_Id; + Formal : Node_Id; + + Wrong_Order : Boolean := False; + -- Set True if an out of order case is found + + begin + -- Collect identifier names of actuals, fail if any actual is + -- not a simple identifier, and record max length of name. + + Actual := First (Parameter_Associations (N)); + for J in Actuals'Range loop + if Nkind (Actual) /= N_Identifier then + return; + else + Actuals (J) := Actual; + Next (Actual); + end if; + end loop; + + -- If we got this far, all actuals are identifiers and the list + -- of their names is stored in the Actuals array. + + Formal := First_Formal (Nam); + for J in Actuals'Range loop + + -- If we ran out of formals, that's odd, probably an error + -- which will be detected elsewhere, but abandon the search. + + if No (Formal) then + return; + end if; + + -- If name matches and is in order OK + + if Chars (Formal) = Chars (Actuals (J)) then + null; + + else + -- If no match, see if it is elsewhere in list and if so + -- flag potential wrong order if type is compatible. + + for K in Actuals'Range loop + if Chars (Formal) = Chars (Actuals (K)) + and then + Has_Compatible_Type (Actuals (K), Etype (Formal)) + then + Wrong_Order := True; + goto Continue; + end if; + end loop; + + -- No match + + return; + end if; + + <> Next_Formal (Formal); + end loop; + + -- If Formals left over, also probably an error, skip warning + + if Present (Formal) then + return; + end if; + + -- Here we give the warning if something was out of order + + if Wrong_Order then + Error_Msg_N + ("actuals for this call may be in wrong order?", N); + end if; + end; + end; + end Check_Argument_Order; + + ------------------------- + -- Check_Prefixed_Call -- + ------------------------- + + procedure Check_Prefixed_Call is + Act : constant Node_Id := First_Actual (N); + A_Type : constant Entity_Id := Etype (Act); + F_Type : constant Entity_Id := Etype (First_Formal (Nam)); + Orig : constant Node_Id := Original_Node (N); + New_A : Node_Id; + + begin + -- Check whether the call is a prefixed call, with or without + -- additional actuals. + + if Nkind (Orig) = N_Selected_Component + or else + (Nkind (Orig) = N_Indexed_Component + and then Nkind (Prefix (Orig)) = N_Selected_Component + and then Is_Entity_Name (Prefix (Prefix (Orig))) + and then Is_Entity_Name (Act) + and then Chars (Act) = Chars (Prefix (Prefix (Orig)))) + then + if Is_Access_Type (A_Type) + and then not Is_Access_Type (F_Type) + then + -- Introduce dereference on object in prefix + + New_A := + Make_Explicit_Dereference (Sloc (Act), + Prefix => Relocate_Node (Act)); + Rewrite (Act, New_A); + Analyze (Act); + + elsif Is_Access_Type (F_Type) + and then not Is_Access_Type (A_Type) + then + -- Introduce an implicit 'Access in prefix + + if not Is_Aliased_View (Act) then + Error_Msg_NE + ("object in prefixed call to& must be aliased" + & " (RM-2005 4.3.1 (13))", + Prefix (Act), Nam); + end if; + + Rewrite (Act, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Access, + Prefix => Relocate_Node (Act))); + end if; + + Analyze (Act); + end if; + end Check_Prefixed_Call; + + -------------------- + -- Insert_Default -- + -------------------- + + procedure Insert_Default is + Actval : Node_Id; + Assoc : Node_Id; + + begin + -- Missing argument in call, nothing to insert + + if No (Default_Value (F)) then + return; + + else + -- Note that we do a full New_Copy_Tree, so that any associated + -- Itypes are properly copied. This may not be needed any more, + -- but it does no harm as a safety measure! Defaults of a generic + -- formal may be out of bounds of the corresponding actual (see + -- cc1311b) and an additional check may be required. + + Actval := + New_Copy_Tree + (Default_Value (F), + New_Scope => Current_Scope, + New_Sloc => Loc); + + if Is_Concurrent_Type (Scope (Nam)) + and then Has_Discriminants (Scope (Nam)) + then + Replace_Actual_Discriminants (N, Actval); + end if; + + if Is_Overloadable (Nam) + and then Present (Alias (Nam)) + then + if Base_Type (Etype (F)) /= Base_Type (Etype (Actval)) + and then not Is_Tagged_Type (Etype (F)) + then + -- If default is a real literal, do not introduce a + -- conversion whose effect may depend on the run-time + -- size of universal real. + + if Nkind (Actval) = N_Real_Literal then + Set_Etype (Actval, Base_Type (Etype (F))); + else + Actval := Unchecked_Convert_To (Etype (F), Actval); + end if; + end if; + + if Is_Scalar_Type (Etype (F)) then + Enable_Range_Check (Actval); + end if; + + Set_Parent (Actval, N); + + -- Resolve aggregates with their base type, to avoid scope + -- anomalies: the subtype was first built in the subprogram + -- declaration, and the current call may be nested. + + if Nkind (Actval) = N_Aggregate then + Analyze_And_Resolve (Actval, Etype (F)); + else + Analyze_And_Resolve (Actval, Etype (Actval)); + end if; + + else + Set_Parent (Actval, N); + + -- See note above concerning aggregates + + if Nkind (Actval) = N_Aggregate + and then Has_Discriminants (Etype (Actval)) + then + Analyze_And_Resolve (Actval, Base_Type (Etype (Actval))); + + -- Resolve entities with their own type, which may differ + -- from the type of a reference in a generic context (the + -- view swapping mechanism did not anticipate the re-analysis + -- of default values in calls). + + elsif Is_Entity_Name (Actval) then + Analyze_And_Resolve (Actval, Etype (Entity (Actval))); + + else + Analyze_And_Resolve (Actval, Etype (Actval)); + end if; + end if; + + -- If default is a tag indeterminate function call, propagate + -- tag to obtain proper dispatching. + + if Is_Controlling_Formal (F) + and then Nkind (Default_Value (F)) = N_Function_Call + then + Set_Is_Controlling_Actual (Actval); + end if; + + end if; + + -- If the default expression raises constraint error, then just + -- silently replace it with an N_Raise_Constraint_Error node, + -- since we already gave the warning on the subprogram spec. + -- If node is already a Raise_Constraint_Error leave as is, to + -- prevent loops in the warnings removal machinery. + + if Raises_Constraint_Error (Actval) + and then Nkind (Actval) /= N_Raise_Constraint_Error + then + Rewrite (Actval, + Make_Raise_Constraint_Error (Loc, + Reason => CE_Range_Check_Failed)); + Set_Raises_Constraint_Error (Actval); + Set_Etype (Actval, Etype (F)); + end if; + + Assoc := + Make_Parameter_Association (Loc, + Explicit_Actual_Parameter => Actval, + Selector_Name => Make_Identifier (Loc, Chars (F))); + + -- Case of insertion is first named actual + + if No (Prev) or else + Nkind (Parent (Prev)) /= N_Parameter_Association + then + Set_Next_Named_Actual (Assoc, First_Named_Actual (N)); + Set_First_Named_Actual (N, Actval); + + if No (Prev) then + if No (Parameter_Associations (N)) then + Set_Parameter_Associations (N, New_List (Assoc)); + else + Append (Assoc, Parameter_Associations (N)); + end if; + + else + Insert_After (Prev, Assoc); + end if; + + -- Case of insertion is not first named actual + + else + Set_Next_Named_Actual + (Assoc, Next_Named_Actual (Parent (Prev))); + Set_Next_Named_Actual (Parent (Prev), Actval); + Append (Assoc, Parameter_Associations (N)); + end if; + + Mark_Rewrite_Insertion (Assoc); + Mark_Rewrite_Insertion (Actval); + + Prev := Actval; + end Insert_Default; + + ------------------- + -- Same_Ancestor -- + ------------------- + + function Same_Ancestor (T1, T2 : Entity_Id) return Boolean is + FT1 : Entity_Id := T1; + FT2 : Entity_Id := T2; + + begin + if Is_Private_Type (T1) + and then Present (Full_View (T1)) + then + FT1 := Full_View (T1); + end if; + + if Is_Private_Type (T2) + and then Present (Full_View (T2)) + then + FT2 := Full_View (T2); + end if; + + return Root_Type (Base_Type (FT1)) = Root_Type (Base_Type (FT2)); + end Same_Ancestor; + + -------------------------- + -- Static_Concatenation -- + -------------------------- + + function Static_Concatenation (N : Node_Id) return Boolean is + begin + case Nkind (N) is + when N_String_Literal => + return True; + + when N_Op_Concat => + + -- Concatenation is static when both operands are static + -- and the concatenation operator is a predefined one. + + return Scope (Entity (N)) = Standard_Standard + and then + Static_Concatenation (Left_Opnd (N)) + and then + Static_Concatenation (Right_Opnd (N)); + + when others => + if Is_Entity_Name (N) then + declare + Ent : constant Entity_Id := Entity (N); + begin + return Ekind (Ent) = E_Constant + and then Present (Constant_Value (Ent)) + and then + Is_Static_Expression (Constant_Value (Ent)); + end; + + else + return False; + end if; + end case; + end Static_Concatenation; + + -- Start of processing for Resolve_Actuals + + begin + Check_Argument_Order; + + if Present (First_Actual (N)) then + Check_Prefixed_Call; + end if; + + A := First_Actual (N); + F := First_Formal (Nam); + while Present (F) loop + if No (A) and then Needs_No_Actuals (Nam) then + null; + + -- If we have an error in any actual or formal, indicated by a type + -- of Any_Type, then abandon resolution attempt, and set result type + -- to Any_Type. + + elsif (Present (A) and then Etype (A) = Any_Type) + or else Etype (F) = Any_Type + then + Set_Etype (N, Any_Type); + return; + end if; + + -- Case where actual is present + + -- If the actual is an entity, generate a reference to it now. We + -- do this before the actual is resolved, because a formal of some + -- protected subprogram, or a task discriminant, will be rewritten + -- during expansion, and the reference to the source entity may + -- be lost. + + if Present (A) + and then Is_Entity_Name (A) + and then Comes_From_Source (N) + then + Orig_A := Entity (A); + + if Present (Orig_A) then + if Is_Formal (Orig_A) + and then Ekind (F) /= E_In_Parameter + then + Generate_Reference (Orig_A, A, 'm'); + elsif not Is_Overloaded (A) then + Generate_Reference (Orig_A, A); + end if; + end if; + end if; + + if Present (A) + and then (Nkind (Parent (A)) /= N_Parameter_Association + or else + Chars (Selector_Name (Parent (A))) = Chars (F)) + then + -- If style checking mode on, check match of formal name + + if Style_Check then + if Nkind (Parent (A)) = N_Parameter_Association then + Check_Identifier (Selector_Name (Parent (A)), F); + end if; + end if; + + -- If the formal is Out or In_Out, do not resolve and expand the + -- conversion, because it is subsequently expanded into explicit + -- temporaries and assignments. However, the object of the + -- conversion can be resolved. An exception is the case of tagged + -- type conversion with a class-wide actual. In that case we want + -- the tag check to occur and no temporary will be needed (no + -- representation change can occur) and the parameter is passed by + -- reference, so we go ahead and resolve the type conversion. + -- Another exception is the case of reference to component or + -- subcomponent of a bit-packed array, in which case we want to + -- defer expansion to the point the in and out assignments are + -- performed. + + if Ekind (F) /= E_In_Parameter + and then Nkind (A) = N_Type_Conversion + and then not Is_Class_Wide_Type (Etype (Expression (A))) + then + if Ekind (F) = E_In_Out_Parameter + and then Is_Array_Type (Etype (F)) + then + -- In a view conversion, the conversion must be legal in + -- both directions, and thus both component types must be + -- aliased, or neither (4.6 (8)). + + -- The extra rule in 4.6 (24.9.2) seems unduly restrictive: + -- the privacy requirement should not apply to generic + -- types, and should be checked in an instance. ARG query + -- is in order ??? + + if Has_Aliased_Components (Etype (Expression (A))) /= + Has_Aliased_Components (Etype (F)) + then + Error_Msg_N + ("both component types in a view conversion must be" + & " aliased, or neither", A); + + -- Comment here??? what set of cases??? + + elsif + not Same_Ancestor (Etype (F), Etype (Expression (A))) + then + -- Check view conv between unrelated by ref array types + + if Is_By_Reference_Type (Etype (F)) + or else Is_By_Reference_Type (Etype (Expression (A))) + then + Error_Msg_N + ("view conversion between unrelated by reference " & + "array types not allowed (\'A'I-00246)", A); + + -- In Ada 2005 mode, check view conversion component + -- type cannot be private, tagged, or volatile. Note + -- that we only apply this to source conversions. The + -- generated code can contain conversions which are + -- not subject to this test, and we cannot extract the + -- component type in such cases since it is not present. + + elsif Comes_From_Source (A) + and then Ada_Version >= Ada_2005 + then + declare + Comp_Type : constant Entity_Id := + Component_Type + (Etype (Expression (A))); + begin + if (Is_Private_Type (Comp_Type) + and then not Is_Generic_Type (Comp_Type)) + or else Is_Tagged_Type (Comp_Type) + or else Is_Volatile (Comp_Type) + then + Error_Msg_N + ("component type of a view conversion cannot" + & " be private, tagged, or volatile" + & " (RM 4.6 (24))", + Expression (A)); + end if; + end; + end if; + end if; + end if; + + -- Resolve expression if conversion is all OK + + if (Conversion_OK (A) + or else Valid_Conversion (A, Etype (A), Expression (A))) + and then not Is_Ref_To_Bit_Packed_Array (Expression (A)) + then + Resolve (Expression (A)); + end if; + + -- If the actual is a function call that returns a limited + -- unconstrained object that needs finalization, create a + -- transient scope for it, so that it can receive the proper + -- finalization list. + + elsif Nkind (A) = N_Function_Call + and then Is_Limited_Record (Etype (F)) + and then not Is_Constrained (Etype (F)) + and then Expander_Active + and then + (Is_Controlled (Etype (F)) or else Has_Task (Etype (F))) + then + Establish_Transient_Scope (A, False); + + -- A small optimization: if one of the actuals is a concatenation + -- create a block around a procedure call to recover stack space. + -- This alleviates stack usage when several procedure calls in + -- the same statement list use concatenation. We do not perform + -- this wrapping for code statements, where the argument is a + -- static string, and we want to preserve warnings involving + -- sequences of such statements. + + elsif Nkind (A) = N_Op_Concat + and then Nkind (N) = N_Procedure_Call_Statement + and then Expander_Active + and then + not (Is_Intrinsic_Subprogram (Nam) + and then Chars (Nam) = Name_Asm) + and then not Static_Concatenation (A) + then + Establish_Transient_Scope (A, False); + Resolve (A, Etype (F)); + + else + if Nkind (A) = N_Type_Conversion + and then Is_Array_Type (Etype (F)) + and then not Same_Ancestor (Etype (F), Etype (Expression (A))) + and then + (Is_Limited_Type (Etype (F)) + or else Is_Limited_Type (Etype (Expression (A)))) + then + Error_Msg_N + ("conversion between unrelated limited array types " & + "not allowed (\A\I-00246)", A); + + if Is_Limited_Type (Etype (F)) then + Explain_Limited_Type (Etype (F), A); + end if; + + if Is_Limited_Type (Etype (Expression (A))) then + Explain_Limited_Type (Etype (Expression (A)), A); + end if; + end if; + + -- (Ada 2005: AI-251): If the actual is an allocator whose + -- directly designated type is a class-wide interface, we build + -- an anonymous access type to use it as the type of the + -- allocator. Later, when the subprogram call is expanded, if + -- the interface has a secondary dispatch table the expander + -- will add a type conversion to force the correct displacement + -- of the pointer. + + if Nkind (A) = N_Allocator then + declare + DDT : constant Entity_Id := + Directly_Designated_Type (Base_Type (Etype (F))); + + New_Itype : Entity_Id; + + begin + if Is_Class_Wide_Type (DDT) + and then Is_Interface (DDT) + then + New_Itype := Create_Itype (E_Anonymous_Access_Type, A); + Set_Etype (New_Itype, Etype (A)); + Set_Directly_Designated_Type (New_Itype, + Directly_Designated_Type (Etype (A))); + Set_Etype (A, New_Itype); + end if; + + -- Ada 2005, AI-162:If the actual is an allocator, the + -- innermost enclosing statement is the master of the + -- created object. This needs to be done with expansion + -- enabled only, otherwise the transient scope will not + -- be removed in the expansion of the wrapped construct. + + if (Is_Controlled (DDT) or else Has_Task (DDT)) + and then Expander_Active + then + Establish_Transient_Scope (A, False); + end if; + end; + end if; + + -- (Ada 2005): The call may be to a primitive operation of + -- a tagged synchronized type, declared outside of the type. + -- In this case the controlling actual must be converted to + -- its corresponding record type, which is the formal type. + -- The actual may be a subtype, either because of a constraint + -- or because it is a generic actual, so use base type to + -- locate concurrent type. + + A_Typ := Base_Type (Etype (A)); + F_Typ := Base_Type (Etype (F)); + + declare + Full_A_Typ : Entity_Id; + + begin + if Present (Full_View (A_Typ)) then + Full_A_Typ := Base_Type (Full_View (A_Typ)); + else + Full_A_Typ := A_Typ; + end if; + + -- Tagged synchronized type (case 1): the actual is a + -- concurrent type + + if Is_Concurrent_Type (A_Typ) + and then Corresponding_Record_Type (A_Typ) = F_Typ + then + Rewrite (A, + Unchecked_Convert_To + (Corresponding_Record_Type (A_Typ), A)); + Resolve (A, Etype (F)); + + -- Tagged synchronized type (case 2): the formal is a + -- concurrent type + + elsif Ekind (Full_A_Typ) = E_Record_Type + and then Present + (Corresponding_Concurrent_Type (Full_A_Typ)) + and then Is_Concurrent_Type (F_Typ) + and then Present (Corresponding_Record_Type (F_Typ)) + and then Full_A_Typ = Corresponding_Record_Type (F_Typ) + then + Resolve (A, Corresponding_Record_Type (F_Typ)); + + -- Common case + + else + Resolve (A, Etype (F)); + end if; + end; + end if; + + A_Typ := Etype (A); + F_Typ := Etype (F); + + -- Save actual for subsequent check on order dependence, and + -- indicate whether actual is modifiable. For AI05-0144-2. + + Save_Actual (A, Ekind (F) /= E_In_Parameter); + + -- For mode IN, if actual is an entity, and the type of the formal + -- has warnings suppressed, then we reset Never_Set_In_Source for + -- the calling entity. The reason for this is to catch cases like + -- GNAT.Spitbol.Patterns.Vstring_Var where the called subprogram + -- uses trickery to modify an IN parameter. + + if Ekind (F) = E_In_Parameter + and then Is_Entity_Name (A) + and then Present (Entity (A)) + and then Ekind (Entity (A)) = E_Variable + and then Has_Warnings_Off (F_Typ) + then + Set_Never_Set_In_Source (Entity (A), False); + end if; + + -- Perform error checks for IN and IN OUT parameters + + if Ekind (F) /= E_Out_Parameter then + + -- Check unset reference. For scalar parameters, it is clearly + -- wrong to pass an uninitialized value as either an IN or + -- IN-OUT parameter. For composites, it is also clearly an + -- error to pass a completely uninitialized value as an IN + -- parameter, but the case of IN OUT is trickier. We prefer + -- not to give a warning here. For example, suppose there is + -- a routine that sets some component of a record to False. + -- It is perfectly reasonable to make this IN-OUT and allow + -- either initialized or uninitialized records to be passed + -- in this case. + + -- For partially initialized composite values, we also avoid + -- warnings, since it is quite likely that we are passing a + -- partially initialized value and only the initialized fields + -- will in fact be read in the subprogram. + + if Is_Scalar_Type (A_Typ) + or else (Ekind (F) = E_In_Parameter + and then not Is_Partially_Initialized_Type (A_Typ)) + then + Check_Unset_Reference (A); + end if; + + -- In Ada 83 we cannot pass an OUT parameter as an IN or IN OUT + -- actual to a nested call, since this is case of reading an + -- out parameter, which is not allowed. + + if Ada_Version = Ada_83 + and then Is_Entity_Name (A) + and then Ekind (Entity (A)) = E_Out_Parameter + then + Error_Msg_N ("(Ada 83) illegal reading of out parameter", A); + end if; + end if; + + -- Case of OUT or IN OUT parameter + + if Ekind (F) /= E_In_Parameter then + + -- For an Out parameter, check for useless assignment. Note + -- that we can't set Last_Assignment this early, because we may + -- kill current values in Resolve_Call, and that call would + -- clobber the Last_Assignment field. + + -- Note: call Warn_On_Useless_Assignment before doing the check + -- below for Is_OK_Variable_For_Out_Formal so that the setting + -- of Referenced_As_LHS/Referenced_As_Out_Formal properly + -- reflects the last assignment, not this one! + + if Ekind (F) = E_Out_Parameter then + if Warn_On_Modified_As_Out_Parameter (F) + and then Is_Entity_Name (A) + and then Present (Entity (A)) + and then Comes_From_Source (N) + then + Warn_On_Useless_Assignment (Entity (A), A); + end if; + end if; + + -- Validate the form of the actual. Note that the call to + -- Is_OK_Variable_For_Out_Formal generates the required + -- reference in this case. + + if not Is_OK_Variable_For_Out_Formal (A) then + Error_Msg_NE ("actual for& must be a variable", A, F); + end if; + + -- What's the following about??? + + if Is_Entity_Name (A) then + Kill_Checks (Entity (A)); + else + Kill_All_Checks; + end if; + end if; + + if Etype (A) = Any_Type then + Set_Etype (N, Any_Type); + return; + end if; + + -- Apply appropriate range checks for in, out, and in-out + -- parameters. Out and in-out parameters also need a separate + -- check, if there is a type conversion, to make sure the return + -- value meets the constraints of the variable before the + -- conversion. + + -- Gigi looks at the check flag and uses the appropriate types. + -- For now since one flag is used there is an optimization which + -- might not be done in the In Out case since Gigi does not do + -- any analysis. More thought required about this ??? + + if Ekind_In (F, E_In_Parameter, E_In_Out_Parameter) then + + -- Apply predicate checks, unless this is a call to the + -- predicate check function itself, which would cause an + -- infinite recursion. + + if not (Ekind (Nam) = E_Function + and then Has_Predicates (Nam)) + then + Apply_Predicate_Check (A, F_Typ); + end if; + + -- Apply required constraint checks + + if Is_Scalar_Type (Etype (A)) then + Apply_Scalar_Range_Check (A, F_Typ); + + elsif Is_Array_Type (Etype (A)) then + Apply_Length_Check (A, F_Typ); + + elsif Is_Record_Type (F_Typ) + and then Has_Discriminants (F_Typ) + and then Is_Constrained (F_Typ) + and then (not Is_Derived_Type (F_Typ) + or else Comes_From_Source (Nam)) + then + Apply_Discriminant_Check (A, F_Typ); + + elsif Is_Access_Type (F_Typ) + and then Is_Array_Type (Designated_Type (F_Typ)) + and then Is_Constrained (Designated_Type (F_Typ)) + then + Apply_Length_Check (A, F_Typ); + + elsif Is_Access_Type (F_Typ) + and then Has_Discriminants (Designated_Type (F_Typ)) + and then Is_Constrained (Designated_Type (F_Typ)) + then + Apply_Discriminant_Check (A, F_Typ); + + else + Apply_Range_Check (A, F_Typ); + end if; + + -- Ada 2005 (AI-231): Note that the controlling parameter case + -- already existed in Ada 95, which is partially checked + -- elsewhere (see Checks), and we don't want the warning + -- message to differ. + + if Is_Access_Type (F_Typ) + and then Can_Never_Be_Null (F_Typ) + and then Known_Null (A) + then + if Is_Controlling_Formal (F) then + Apply_Compile_Time_Constraint_Error + (N => A, + Msg => "null value not allowed here?", + Reason => CE_Access_Check_Failed); + + elsif Ada_Version >= Ada_2005 then + Apply_Compile_Time_Constraint_Error + (N => A, + Msg => "(Ada 2005) null not allowed in " + & "null-excluding formal?", + Reason => CE_Null_Not_Allowed); + end if; + end if; + end if; + + if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) then + if Nkind (A) = N_Type_Conversion then + if Is_Scalar_Type (A_Typ) then + Apply_Scalar_Range_Check + (Expression (A), Etype (Expression (A)), A_Typ); + else + Apply_Range_Check + (Expression (A), Etype (Expression (A)), A_Typ); + end if; + + else + if Is_Scalar_Type (F_Typ) then + Apply_Scalar_Range_Check (A, A_Typ, F_Typ); + + elsif Is_Array_Type (F_Typ) + and then Ekind (F) = E_Out_Parameter + then + Apply_Length_Check (A, F_Typ); + + else + Apply_Range_Check (A, A_Typ, F_Typ); + end if; + end if; + end if; + + -- An actual associated with an access parameter is implicitly + -- converted to the anonymous access type of the formal and must + -- satisfy the legality checks for access conversions. + + if Ekind (F_Typ) = E_Anonymous_Access_Type then + if not Valid_Conversion (A, F_Typ, A) then + Error_Msg_N + ("invalid implicit conversion for access parameter", A); + end if; + end if; + + -- Check bad case of atomic/volatile argument (RM C.6(12)) + + if Is_By_Reference_Type (Etype (F)) + and then Comes_From_Source (N) + then + if Is_Atomic_Object (A) + and then not Is_Atomic (Etype (F)) + then + Error_Msg_N + ("cannot pass atomic argument to non-atomic formal", + N); + + elsif Is_Volatile_Object (A) + and then not Is_Volatile (Etype (F)) + then + Error_Msg_N + ("cannot pass volatile argument to non-volatile formal", + N); + end if; + end if; + + -- Check that subprograms don't have improper controlling + -- arguments (RM 3.9.2 (9)). + + -- A primitive operation may have an access parameter of an + -- incomplete tagged type, but a dispatching call is illegal + -- if the type is still incomplete. + + if Is_Controlling_Formal (F) then + Set_Is_Controlling_Actual (A); + + if Ekind (Etype (F)) = E_Anonymous_Access_Type then + declare + Desig : constant Entity_Id := Designated_Type (Etype (F)); + begin + if Ekind (Desig) = E_Incomplete_Type + and then No (Full_View (Desig)) + and then No (Non_Limited_View (Desig)) + then + Error_Msg_NE + ("premature use of incomplete type& " & + "in dispatching call", A, Desig); + end if; + end; + end if; + + elsif Nkind (A) = N_Explicit_Dereference then + Validate_Remote_Access_To_Class_Wide_Type (A); + end if; + + if (Is_Class_Wide_Type (A_Typ) or else Is_Dynamically_Tagged (A)) + and then not Is_Class_Wide_Type (F_Typ) + and then not Is_Controlling_Formal (F) + then + Error_Msg_N ("class-wide argument not allowed here!", A); + + if Is_Subprogram (Nam) + and then Comes_From_Source (Nam) + then + Error_Msg_Node_2 := F_Typ; + Error_Msg_NE + ("& is not a dispatching operation of &!", A, Nam); + end if; + + elsif Is_Access_Type (A_Typ) + and then Is_Access_Type (F_Typ) + and then Ekind (F_Typ) /= E_Access_Subprogram_Type + and then Ekind (F_Typ) /= E_Anonymous_Access_Subprogram_Type + and then (Is_Class_Wide_Type (Designated_Type (A_Typ)) + or else (Nkind (A) = N_Attribute_Reference + and then + Is_Class_Wide_Type (Etype (Prefix (A))))) + and then not Is_Class_Wide_Type (Designated_Type (F_Typ)) + and then not Is_Controlling_Formal (F) + + -- Disable these checks for call to imported C++ subprograms + + and then not + (Is_Entity_Name (Name (N)) + and then Is_Imported (Entity (Name (N))) + and then Convention (Entity (Name (N))) = Convention_CPP) + then + Error_Msg_N + ("access to class-wide argument not allowed here!", A); + + if Is_Subprogram (Nam) + and then Comes_From_Source (Nam) + then + Error_Msg_Node_2 := Designated_Type (F_Typ); + Error_Msg_NE + ("& is not a dispatching operation of &!", A, Nam); + end if; + end if; + + Eval_Actual (A); + + -- If it is a named association, treat the selector_name as a + -- proper identifier, and mark the corresponding entity. + + if Nkind (Parent (A)) = N_Parameter_Association then + Set_Entity (Selector_Name (Parent (A)), F); + Generate_Reference (F, Selector_Name (Parent (A))); + Set_Etype (Selector_Name (Parent (A)), F_Typ); + Generate_Reference (F_Typ, N, ' '); + end if; + + Prev := A; + + if Ekind (F) /= E_Out_Parameter then + Check_Unset_Reference (A); + end if; + + Next_Actual (A); + + -- Case where actual is not present + + else + Insert_Default; + end if; + + Next_Formal (F); + end loop; + end Resolve_Actuals; + + ----------------------- + -- Resolve_Allocator -- + ----------------------- + + procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id) is + E : constant Node_Id := Expression (N); + Subtyp : Entity_Id; + Discrim : Entity_Id; + Constr : Node_Id; + Aggr : Node_Id; + Assoc : Node_Id := Empty; + Disc_Exp : Node_Id; + + procedure Check_Allocator_Discrim_Accessibility + (Disc_Exp : Node_Id; + Alloc_Typ : Entity_Id); + -- Check that accessibility level associated with an access discriminant + -- initialized in an allocator by the expression Disc_Exp is not deeper + -- than the level of the allocator type Alloc_Typ. An error message is + -- issued if this condition is violated. Specialized checks are done for + -- the cases of a constraint expression which is an access attribute or + -- an access discriminant. + + function In_Dispatching_Context return Boolean; + -- If the allocator is an actual in a call, it is allowed to be class- + -- wide when the context is not because it is a controlling actual. + + procedure Propagate_Coextensions (Root : Node_Id); + -- Propagate all nested coextensions which are located one nesting + -- level down the tree to the node Root. Example: + -- + -- Top_Record + -- Level_1_Coextension + -- Level_2_Coextension + -- + -- The algorithm is paired with delay actions done by the Expander. In + -- the above example, assume all coextensions are controlled types. + -- The cycle of analysis, resolution and expansion will yield: + -- + -- 1) Analyze Top_Record + -- 2) Analyze Level_1_Coextension + -- 3) Analyze Level_2_Coextension + -- 4) Resolve Level_2_Coextension. The allocator is marked as a + -- coextension. + -- 5) Expand Level_2_Coextension. A temporary variable Temp_1 is + -- generated to capture the allocated object. Temp_1 is attached + -- to the coextension chain of Level_2_Coextension. + -- 6) Resolve Level_1_Coextension. The allocator is marked as a + -- coextension. A forward tree traversal is performed which finds + -- Level_2_Coextension's list and copies its contents into its + -- own list. + -- 7) Expand Level_1_Coextension. A temporary variable Temp_2 is + -- generated to capture the allocated object. Temp_2 is attached + -- to the coextension chain of Level_1_Coextension. Currently, the + -- contents of the list are [Temp_2, Temp_1]. + -- 8) Resolve Top_Record. A forward tree traversal is performed which + -- finds Level_1_Coextension's list and copies its contents into + -- its own list. + -- 9) Expand Top_Record. Generate finalization calls for Temp_1 and + -- Temp_2 and attach them to Top_Record's finalization list. + + ------------------------------------------- + -- Check_Allocator_Discrim_Accessibility -- + ------------------------------------------- + + procedure Check_Allocator_Discrim_Accessibility + (Disc_Exp : Node_Id; + Alloc_Typ : Entity_Id) + is + begin + if Type_Access_Level (Etype (Disc_Exp)) > + Type_Access_Level (Alloc_Typ) + then + Error_Msg_N + ("operand type has deeper level than allocator type", Disc_Exp); + + -- When the expression is an Access attribute the level of the prefix + -- object must not be deeper than that of the allocator's type. + + elsif Nkind (Disc_Exp) = N_Attribute_Reference + and then Get_Attribute_Id (Attribute_Name (Disc_Exp)) + = Attribute_Access + and then Object_Access_Level (Prefix (Disc_Exp)) + > Type_Access_Level (Alloc_Typ) + then + Error_Msg_N + ("prefix of attribute has deeper level than allocator type", + Disc_Exp); + + -- When the expression is an access discriminant the check is against + -- the level of the prefix object. + + elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type + and then Nkind (Disc_Exp) = N_Selected_Component + and then Object_Access_Level (Prefix (Disc_Exp)) + > Type_Access_Level (Alloc_Typ) + then + Error_Msg_N + ("access discriminant has deeper level than allocator type", + Disc_Exp); + + -- All other cases are legal + + else + null; + end if; + end Check_Allocator_Discrim_Accessibility; + + ---------------------------- + -- In_Dispatching_Context -- + ---------------------------- + + function In_Dispatching_Context return Boolean is + Par : constant Node_Id := Parent (N); + begin + return Nkind_In (Par, N_Function_Call, N_Procedure_Call_Statement) + and then Is_Entity_Name (Name (Par)) + and then Is_Dispatching_Operation (Entity (Name (Par))); + end In_Dispatching_Context; + + ---------------------------- + -- Propagate_Coextensions -- + ---------------------------- + + procedure Propagate_Coextensions (Root : Node_Id) is + + procedure Copy_List (From : Elist_Id; To : Elist_Id); + -- Copy the contents of list From into list To, preserving the + -- order of elements. + + function Process_Allocator (Nod : Node_Id) return Traverse_Result; + -- Recognize an allocator or a rewritten allocator node and add it + -- along with its nested coextensions to the list of Root. + + --------------- + -- Copy_List -- + --------------- + + procedure Copy_List (From : Elist_Id; To : Elist_Id) is + From_Elmt : Elmt_Id; + begin + From_Elmt := First_Elmt (From); + while Present (From_Elmt) loop + Append_Elmt (Node (From_Elmt), To); + Next_Elmt (From_Elmt); + end loop; + end Copy_List; + + ----------------------- + -- Process_Allocator -- + ----------------------- + + function Process_Allocator (Nod : Node_Id) return Traverse_Result is + Orig_Nod : Node_Id := Nod; + + begin + -- This is a possible rewritten subtype indication allocator. Any + -- nested coextensions will appear as discriminant constraints. + + if Nkind (Nod) = N_Identifier + and then Present (Original_Node (Nod)) + and then Nkind (Original_Node (Nod)) = N_Subtype_Indication + then + declare + Discr : Node_Id; + Discr_Elmt : Elmt_Id; + + begin + if Is_Record_Type (Entity (Nod)) then + Discr_Elmt := + First_Elmt (Discriminant_Constraint (Entity (Nod))); + while Present (Discr_Elmt) loop + Discr := Node (Discr_Elmt); + + if Nkind (Discr) = N_Identifier + and then Present (Original_Node (Discr)) + and then Nkind (Original_Node (Discr)) = N_Allocator + and then Present (Coextensions ( + Original_Node (Discr))) + then + if No (Coextensions (Root)) then + Set_Coextensions (Root, New_Elmt_List); + end if; + + Copy_List + (From => Coextensions (Original_Node (Discr)), + To => Coextensions (Root)); + end if; + + Next_Elmt (Discr_Elmt); + end loop; + + -- There is no need to continue the traversal of this + -- subtree since all the information has already been + -- propagated. + + return Skip; + end if; + end; + + -- Case of either a stand alone allocator or a rewritten allocator + -- with an aggregate. + + else + if Present (Original_Node (Nod)) then + Orig_Nod := Original_Node (Nod); + end if; + + if Nkind (Orig_Nod) = N_Allocator then + + -- Propagate the list of nested coextensions to the Root + -- allocator. This is done through list copy since a single + -- allocator may have multiple coextensions. Do not touch + -- coextensions roots. + + if not Is_Coextension_Root (Orig_Nod) + and then Present (Coextensions (Orig_Nod)) + then + if No (Coextensions (Root)) then + Set_Coextensions (Root, New_Elmt_List); + end if; + + Copy_List + (From => Coextensions (Orig_Nod), + To => Coextensions (Root)); + end if; + + -- There is no need to continue the traversal of this + -- subtree since all the information has already been + -- propagated. + + return Skip; + end if; + end if; + + -- Keep on traversing, looking for the next allocator + + return OK; + end Process_Allocator; + + procedure Process_Allocators is + new Traverse_Proc (Process_Allocator); + + -- Start of processing for Propagate_Coextensions + + begin + Process_Allocators (Expression (Root)); + end Propagate_Coextensions; + + -- Start of processing for Resolve_Allocator + + begin + -- Replace general access with specific type + + if Ekind (Etype (N)) = E_Allocator_Type then + Set_Etype (N, Base_Type (Typ)); + end if; + + if Is_Abstract_Type (Typ) then + Error_Msg_N ("type of allocator cannot be abstract", N); + end if; + + -- For qualified expression, resolve the expression using the + -- given subtype (nothing to do for type mark, subtype indication) + + if Nkind (E) = N_Qualified_Expression then + if Is_Class_Wide_Type (Etype (E)) + and then not Is_Class_Wide_Type (Designated_Type (Typ)) + and then not In_Dispatching_Context + then + Error_Msg_N + ("class-wide allocator not allowed for this access type", N); + end if; + + Resolve (Expression (E), Etype (E)); + Check_Unset_Reference (Expression (E)); + + -- A qualified expression requires an exact match of the type, + -- class-wide matching is not allowed. + + if (Is_Class_Wide_Type (Etype (Expression (E))) + or else Is_Class_Wide_Type (Etype (E))) + and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E)) + then + Wrong_Type (Expression (E), Etype (E)); + end if; + + -- A special accessibility check is needed for allocators that + -- constrain access discriminants. The level of the type of the + -- expression used to constrain an access discriminant cannot be + -- deeper than the type of the allocator (in contrast to access + -- parameters, where the level of the actual can be arbitrary). + + -- We can't use Valid_Conversion to perform this check because + -- in general the type of the allocator is unrelated to the type + -- of the access discriminant. + + if Ekind (Typ) /= E_Anonymous_Access_Type + or else Is_Local_Anonymous_Access (Typ) + then + Subtyp := Entity (Subtype_Mark (E)); + + Aggr := Original_Node (Expression (E)); + + if Has_Discriminants (Subtyp) + and then Nkind_In (Aggr, N_Aggregate, N_Extension_Aggregate) + then + Discrim := First_Discriminant (Base_Type (Subtyp)); + + -- Get the first component expression of the aggregate + + if Present (Expressions (Aggr)) then + Disc_Exp := First (Expressions (Aggr)); + + elsif Present (Component_Associations (Aggr)) then + Assoc := First (Component_Associations (Aggr)); + + if Present (Assoc) then + Disc_Exp := Expression (Assoc); + else + Disc_Exp := Empty; + end if; + + else + Disc_Exp := Empty; + end if; + + while Present (Discrim) and then Present (Disc_Exp) loop + if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then + Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ); + end if; + + Next_Discriminant (Discrim); + + if Present (Discrim) then + if Present (Assoc) then + Next (Assoc); + Disc_Exp := Expression (Assoc); + + elsif Present (Next (Disc_Exp)) then + Next (Disc_Exp); + + else + Assoc := First (Component_Associations (Aggr)); + + if Present (Assoc) then + Disc_Exp := Expression (Assoc); + else + Disc_Exp := Empty; + end if; + end if; + end if; + end loop; + end if; + end if; + + -- For a subtype mark or subtype indication, freeze the subtype + + else + Freeze_Expression (E); + + if Is_Access_Constant (Typ) and then not No_Initialization (N) then + Error_Msg_N + ("initialization required for access-to-constant allocator", N); + end if; + + -- A special accessibility check is needed for allocators that + -- constrain access discriminants. The level of the type of the + -- expression used to constrain an access discriminant cannot be + -- deeper than the type of the allocator (in contrast to access + -- parameters, where the level of the actual can be arbitrary). + -- We can't use Valid_Conversion to perform this check because + -- in general the type of the allocator is unrelated to the type + -- of the access discriminant. + + if Nkind (Original_Node (E)) = N_Subtype_Indication + and then (Ekind (Typ) /= E_Anonymous_Access_Type + or else Is_Local_Anonymous_Access (Typ)) + then + Subtyp := Entity (Subtype_Mark (Original_Node (E))); + + if Has_Discriminants (Subtyp) then + Discrim := First_Discriminant (Base_Type (Subtyp)); + Constr := First (Constraints (Constraint (Original_Node (E)))); + while Present (Discrim) and then Present (Constr) loop + if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then + if Nkind (Constr) = N_Discriminant_Association then + Disc_Exp := Original_Node (Expression (Constr)); + else + Disc_Exp := Original_Node (Constr); + end if; + + Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ); + end if; + + Next_Discriminant (Discrim); + Next (Constr); + end loop; + end if; + end if; + end if; + + -- Ada 2005 (AI-344): A class-wide allocator requires an accessibility + -- check that the level of the type of the created object is not deeper + -- than the level of the allocator's access type, since extensions can + -- now occur at deeper levels than their ancestor types. This is a + -- static accessibility level check; a run-time check is also needed in + -- the case of an initialized allocator with a class-wide argument (see + -- Expand_Allocator_Expression). + + if Ada_Version >= Ada_2005 + and then Is_Class_Wide_Type (Designated_Type (Typ)) + then + declare + Exp_Typ : Entity_Id; + + begin + if Nkind (E) = N_Qualified_Expression then + Exp_Typ := Etype (E); + elsif Nkind (E) = N_Subtype_Indication then + Exp_Typ := Entity (Subtype_Mark (Original_Node (E))); + else + Exp_Typ := Entity (E); + end if; + + if Type_Access_Level (Exp_Typ) > Type_Access_Level (Typ) then + if In_Instance_Body then + Error_Msg_N ("?type in allocator has deeper level than" & + " designated class-wide type", E); + Error_Msg_N ("\?Program_Error will be raised at run time", + E); + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Accessibility_Check_Failed)); + Set_Etype (N, Typ); + + -- Do not apply Ada 2005 accessibility checks on a class-wide + -- allocator if the type given in the allocator is a formal + -- type. A run-time check will be performed in the instance. + + elsif not Is_Generic_Type (Exp_Typ) then + Error_Msg_N ("type in allocator has deeper level than" & + " designated class-wide type", E); + end if; + end if; + end; + end if; + + -- Check for allocation from an empty storage pool + + if No_Pool_Assigned (Typ) then + Error_Msg_N ("allocation from empty storage pool!", N); + + -- If the context is an unchecked conversion, as may happen within + -- an inlined subprogram, the allocator is being resolved with its + -- own anonymous type. In that case, if the target type has a specific + -- storage pool, it must be inherited explicitly by the allocator type. + + elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion + and then No (Associated_Storage_Pool (Typ)) + then + Set_Associated_Storage_Pool + (Typ, Associated_Storage_Pool (Etype (Parent (N)))); + end if; + + if Ekind (Etype (N)) = E_Anonymous_Access_Type then + Check_Restriction (No_Anonymous_Allocators, N); + end if; + + -- An erroneous allocator may be rewritten as a raise Program_Error + -- statement. + + if Nkind (N) = N_Allocator then + + -- An anonymous access discriminant is the definition of a + -- coextension. + + if Ekind (Typ) = E_Anonymous_Access_Type + and then Nkind (Associated_Node_For_Itype (Typ)) = + N_Discriminant_Specification + then + -- Avoid marking an allocator as a dynamic coextension if it is + -- within a static construct. + + if not Is_Static_Coextension (N) then + Set_Is_Dynamic_Coextension (N); + end if; + + -- Cleanup for potential static coextensions + + else + Set_Is_Dynamic_Coextension (N, False); + Set_Is_Static_Coextension (N, False); + end if; + + -- There is no need to propagate any nested coextensions if they + -- are marked as static since they will be rewritten on the spot. + + if not Is_Static_Coextension (N) then + Propagate_Coextensions (N); + end if; + end if; + end Resolve_Allocator; + + --------------------------- + -- Resolve_Arithmetic_Op -- + --------------------------- + + -- Used for resolving all arithmetic operators except exponentiation + + procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id) is + L : constant Node_Id := Left_Opnd (N); + R : constant Node_Id := Right_Opnd (N); + TL : constant Entity_Id := Base_Type (Etype (L)); + TR : constant Entity_Id := Base_Type (Etype (R)); + T : Entity_Id; + Rop : Node_Id; + + B_Typ : constant Entity_Id := Base_Type (Typ); + -- We do the resolution using the base type, because intermediate values + -- in expressions always are of the base type, not a subtype of it. + + function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean; + -- Returns True if N is in a context that expects "any real type" + + function Is_Integer_Or_Universal (N : Node_Id) return Boolean; + -- Return True iff given type is Integer or universal real/integer + + procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id); + -- Choose type of integer literal in fixed-point operation to conform + -- to available fixed-point type. T is the type of the other operand, + -- which is needed to determine the expected type of N. + + procedure Set_Operand_Type (N : Node_Id); + -- Set operand type to T if universal + + ------------------------------- + -- Expected_Type_Is_Any_Real -- + ------------------------------- + + function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean is + begin + -- N is the expression after "delta" in a fixed_point_definition; + -- see RM-3.5.9(6): + + return Nkind_In (Parent (N), N_Ordinary_Fixed_Point_Definition, + N_Decimal_Fixed_Point_Definition, + + -- N is one of the bounds in a real_range_specification; + -- see RM-3.5.7(5): + + N_Real_Range_Specification, + + -- N is the expression of a delta_constraint; + -- see RM-J.3(3): + + N_Delta_Constraint); + end Expected_Type_Is_Any_Real; + + ----------------------------- + -- Is_Integer_Or_Universal -- + ----------------------------- + + function Is_Integer_Or_Universal (N : Node_Id) return Boolean is + T : Entity_Id; + Index : Interp_Index; + It : Interp; + + begin + if not Is_Overloaded (N) then + T := Etype (N); + return Base_Type (T) = Base_Type (Standard_Integer) + or else T = Universal_Integer + or else T = Universal_Real; + else + Get_First_Interp (N, Index, It); + while Present (It.Typ) loop + if Base_Type (It.Typ) = Base_Type (Standard_Integer) + or else It.Typ = Universal_Integer + or else It.Typ = Universal_Real + then + return True; + end if; + + Get_Next_Interp (Index, It); + end loop; + end if; + + return False; + end Is_Integer_Or_Universal; + + ---------------------------- + -- Set_Mixed_Mode_Operand -- + ---------------------------- + + procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id) is + Index : Interp_Index; + It : Interp; + + begin + if Universal_Interpretation (N) = Universal_Integer then + + -- A universal integer literal is resolved as standard integer + -- except in the case of a fixed-point result, where we leave it + -- as universal (to be handled by Exp_Fixd later on) + + if Is_Fixed_Point_Type (T) then + Resolve (N, Universal_Integer); + else + Resolve (N, Standard_Integer); + end if; + + elsif Universal_Interpretation (N) = Universal_Real + and then (T = Base_Type (Standard_Integer) + or else T = Universal_Integer + or else T = Universal_Real) + then + -- A universal real can appear in a fixed-type context. We resolve + -- the literal with that context, even though this might raise an + -- exception prematurely (the other operand may be zero). + + Resolve (N, B_Typ); + + elsif Etype (N) = Base_Type (Standard_Integer) + and then T = Universal_Real + and then Is_Overloaded (N) + then + -- Integer arg in mixed-mode operation. Resolve with universal + -- type, in case preference rule must be applied. + + Resolve (N, Universal_Integer); + + elsif Etype (N) = T + and then B_Typ /= Universal_Fixed + then + -- Not a mixed-mode operation, resolve with context + + Resolve (N, B_Typ); + + elsif Etype (N) = Any_Fixed then + + -- N may itself be a mixed-mode operation, so use context type + + Resolve (N, B_Typ); + + elsif Is_Fixed_Point_Type (T) + and then B_Typ = Universal_Fixed + and then Is_Overloaded (N) + then + -- Must be (fixed * fixed) operation, operand must have one + -- compatible interpretation. + + Resolve (N, Any_Fixed); + + elsif Is_Fixed_Point_Type (B_Typ) + and then (T = Universal_Real + or else Is_Fixed_Point_Type (T)) + and then Is_Overloaded (N) + then + -- C * F(X) in a fixed context, where C is a real literal or a + -- fixed-point expression. F must have either a fixed type + -- interpretation or an integer interpretation, but not both. + + Get_First_Interp (N, Index, It); + while Present (It.Typ) loop + if Base_Type (It.Typ) = Base_Type (Standard_Integer) then + + if Analyzed (N) then + Error_Msg_N ("ambiguous operand in fixed operation", N); + else + Resolve (N, Standard_Integer); + end if; + + elsif Is_Fixed_Point_Type (It.Typ) then + + if Analyzed (N) then + Error_Msg_N ("ambiguous operand in fixed operation", N); + else + Resolve (N, It.Typ); + end if; + end if; + + Get_Next_Interp (Index, It); + end loop; + + -- Reanalyze the literal with the fixed type of the context. If + -- context is Universal_Fixed, we are within a conversion, leave + -- the literal as a universal real because there is no usable + -- fixed type, and the target of the conversion plays no role in + -- the resolution. + + declare + Op2 : Node_Id; + T2 : Entity_Id; + + begin + if N = L then + Op2 := R; + else + Op2 := L; + end if; + + if B_Typ = Universal_Fixed + and then Nkind (Op2) = N_Real_Literal + then + T2 := Universal_Real; + else + T2 := B_Typ; + end if; + + Set_Analyzed (Op2, False); + Resolve (Op2, T2); + end; + + else + Resolve (N); + end if; + end Set_Mixed_Mode_Operand; + + ---------------------- + -- Set_Operand_Type -- + ---------------------- + + procedure Set_Operand_Type (N : Node_Id) is + begin + if Etype (N) = Universal_Integer + or else Etype (N) = Universal_Real + then + Set_Etype (N, T); + end if; + end Set_Operand_Type; + + -- Start of processing for Resolve_Arithmetic_Op + + begin + if Comes_From_Source (N) + and then Ekind (Entity (N)) = E_Function + and then Is_Imported (Entity (N)) + and then Is_Intrinsic_Subprogram (Entity (N)) + then + Resolve_Intrinsic_Operator (N, Typ); + return; + + -- Special-case for mixed-mode universal expressions or fixed point + -- type operation: each argument is resolved separately. The same + -- treatment is required if one of the operands of a fixed point + -- operation is universal real, since in this case we don't do a + -- conversion to a specific fixed-point type (instead the expander + -- takes care of the case). + + elsif (B_Typ = Universal_Integer or else B_Typ = Universal_Real) + and then Present (Universal_Interpretation (L)) + and then Present (Universal_Interpretation (R)) + then + Resolve (L, Universal_Interpretation (L)); + Resolve (R, Universal_Interpretation (R)); + Set_Etype (N, B_Typ); + + elsif (B_Typ = Universal_Real + or else Etype (N) = Universal_Fixed + or else (Etype (N) = Any_Fixed + and then Is_Fixed_Point_Type (B_Typ)) + or else (Is_Fixed_Point_Type (B_Typ) + and then (Is_Integer_Or_Universal (L) + or else + Is_Integer_Or_Universal (R)))) + and then Nkind_In (N, N_Op_Multiply, N_Op_Divide) + then + if TL = Universal_Integer or else TR = Universal_Integer then + Check_For_Visible_Operator (N, B_Typ); + end if; + + -- If context is a fixed type and one operand is integer, the + -- other is resolved with the type of the context. + + if Is_Fixed_Point_Type (B_Typ) + and then (Base_Type (TL) = Base_Type (Standard_Integer) + or else TL = Universal_Integer) + then + Resolve (R, B_Typ); + Resolve (L, TL); + + elsif Is_Fixed_Point_Type (B_Typ) + and then (Base_Type (TR) = Base_Type (Standard_Integer) + or else TR = Universal_Integer) + then + Resolve (L, B_Typ); + Resolve (R, TR); + + else + Set_Mixed_Mode_Operand (L, TR); + Set_Mixed_Mode_Operand (R, TL); + end if; + + -- Check the rule in RM05-4.5.5(19.1/2) disallowing universal_fixed + -- multiplying operators from being used when the expected type is + -- also universal_fixed. Note that B_Typ will be Universal_Fixed in + -- some cases where the expected type is actually Any_Real; + -- Expected_Type_Is_Any_Real takes care of that case. + + if Etype (N) = Universal_Fixed + or else Etype (N) = Any_Fixed + then + if B_Typ = Universal_Fixed + and then not Expected_Type_Is_Any_Real (N) + and then not Nkind_In (Parent (N), N_Type_Conversion, + N_Unchecked_Type_Conversion) + then + Error_Msg_N ("type cannot be determined from context!", N); + Error_Msg_N ("\explicit conversion to result type required", N); + + Set_Etype (L, Any_Type); + Set_Etype (R, Any_Type); + + else + if Ada_Version = Ada_83 + and then Etype (N) = Universal_Fixed + and then not + Nkind_In (Parent (N), N_Type_Conversion, + N_Unchecked_Type_Conversion) + then + Error_Msg_N + ("(Ada 83) fixed-point operation " + & "needs explicit conversion", N); + end if; + + -- The expected type is "any real type" in contexts like + -- type T is delta ... + -- in which case we need to set the type to Universal_Real + -- so that static expression evaluation will work properly. + + if Expected_Type_Is_Any_Real (N) then + Set_Etype (N, Universal_Real); + else + Set_Etype (N, B_Typ); + end if; + end if; + + elsif Is_Fixed_Point_Type (B_Typ) + and then (Is_Integer_Or_Universal (L) + or else Nkind (L) = N_Real_Literal + or else Nkind (R) = N_Real_Literal + or else Is_Integer_Or_Universal (R)) + then + Set_Etype (N, B_Typ); + + elsif Etype (N) = Any_Fixed then + + -- If no previous errors, this is only possible if one operand + -- is overloaded and the context is universal. Resolve as such. + + Set_Etype (N, B_Typ); + end if; + + else + if (TL = Universal_Integer or else TL = Universal_Real) + and then + (TR = Universal_Integer or else TR = Universal_Real) + then + Check_For_Visible_Operator (N, B_Typ); + end if; + + -- If the context is Universal_Fixed and the operands are also + -- universal fixed, this is an error, unless there is only one + -- applicable fixed_point type (usually Duration). + + if B_Typ = Universal_Fixed and then Etype (L) = Universal_Fixed then + T := Unique_Fixed_Point_Type (N); + + if T = Any_Type then + Set_Etype (N, T); + return; + else + Resolve (L, T); + Resolve (R, T); + end if; + + else + Resolve (L, B_Typ); + Resolve (R, B_Typ); + end if; + + -- If one of the arguments was resolved to a non-universal type. + -- label the result of the operation itself with the same type. + -- Do the same for the universal argument, if any. + + T := Intersect_Types (L, R); + Set_Etype (N, Base_Type (T)); + Set_Operand_Type (L); + Set_Operand_Type (R); + end if; + + Generate_Operator_Reference (N, Typ); + Eval_Arithmetic_Op (N); + + -- Set overflow and division checking bit. Much cleverer code needed + -- here eventually and perhaps the Resolve routines should be separated + -- for the various arithmetic operations, since they will need + -- different processing. ??? + + if Nkind (N) in N_Op then + if not Overflow_Checks_Suppressed (Etype (N)) then + Enable_Overflow_Check (N); + end if; + + -- Give warning if explicit division by zero + + if Nkind_In (N, N_Op_Divide, N_Op_Rem, N_Op_Mod) + and then not Division_Checks_Suppressed (Etype (N)) + then + Rop := Right_Opnd (N); + + if Compile_Time_Known_Value (Rop) + and then ((Is_Integer_Type (Etype (Rop)) + and then Expr_Value (Rop) = Uint_0) + or else + (Is_Real_Type (Etype (Rop)) + and then Expr_Value_R (Rop) = Ureal_0)) + then + -- Specialize the warning message according to the operation + + case Nkind (N) is + when N_Op_Divide => + Apply_Compile_Time_Constraint_Error + (N, "division by zero?", CE_Divide_By_Zero, + Loc => Sloc (Right_Opnd (N))); + + when N_Op_Rem => + Apply_Compile_Time_Constraint_Error + (N, "rem with zero divisor?", CE_Divide_By_Zero, + Loc => Sloc (Right_Opnd (N))); + + when N_Op_Mod => + Apply_Compile_Time_Constraint_Error + (N, "mod with zero divisor?", CE_Divide_By_Zero, + Loc => Sloc (Right_Opnd (N))); + + -- Division by zero can only happen with division, rem, + -- and mod operations. + + when others => + raise Program_Error; + end case; + + -- Otherwise just set the flag to check at run time + + else + Activate_Division_Check (N); + end if; + end if; + + -- If Restriction No_Implicit_Conditionals is active, then it is + -- violated if either operand can be negative for mod, or for rem + -- if both operands can be negative. + + if Restriction_Check_Required (No_Implicit_Conditionals) + and then Nkind_In (N, N_Op_Rem, N_Op_Mod) + then + declare + Lo : Uint; + Hi : Uint; + OK : Boolean; + + LNeg : Boolean; + RNeg : Boolean; + -- Set if corresponding operand might be negative + + begin + Determine_Range + (Left_Opnd (N), OK, Lo, Hi, Assume_Valid => True); + LNeg := (not OK) or else Lo < 0; + + Determine_Range + (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True); + RNeg := (not OK) or else Lo < 0; + + -- Check if we will be generating conditionals. There are two + -- cases where that can happen, first for REM, the only case + -- is largest negative integer mod -1, where the division can + -- overflow, but we still have to give the right result. The + -- front end generates a test for this annoying case. Here we + -- just test if both operands can be negative (that's what the + -- expander does, so we match its logic here). + + -- The second case is mod where either operand can be negative. + -- In this case, the back end has to generate additional tests. + + if (Nkind (N) = N_Op_Rem and then (LNeg and RNeg)) + or else + (Nkind (N) = N_Op_Mod and then (LNeg or RNeg)) + then + Check_Restriction (No_Implicit_Conditionals, N); + end if; + end; + end if; + end if; + + Check_Unset_Reference (L); + Check_Unset_Reference (R); + end Resolve_Arithmetic_Op; + + ------------------ + -- Resolve_Call -- + ------------------ + + procedure Resolve_Call (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Subp : constant Node_Id := Name (N); + Nam : Entity_Id; + I : Interp_Index; + It : Interp; + Norm_OK : Boolean; + Scop : Entity_Id; + Rtype : Entity_Id; + + function Same_Or_Aliased_Subprograms + (S : Entity_Id; + E : Entity_Id) return Boolean; + -- Returns True if the subprogram entity S is the same as E or else + -- S is an alias of E. + + --------------------------------- + -- Same_Or_Aliased_Subprograms -- + --------------------------------- + + function Same_Or_Aliased_Subprograms + (S : Entity_Id; + E : Entity_Id) return Boolean + is + Subp_Alias : constant Entity_Id := Alias (S); + begin + return S = E + or else (Present (Subp_Alias) and then Subp_Alias = E); + end Same_Or_Aliased_Subprograms; + + -- Start of processing for Resolve_Call + + begin + -- The context imposes a unique interpretation with type Typ on a + -- procedure or function call. Find the entity of the subprogram that + -- yields the expected type, and propagate the corresponding formal + -- constraints on the actuals. The caller has established that an + -- interpretation exists, and emitted an error if not unique. + + -- First deal with the case of a call to an access-to-subprogram, + -- dereference made explicit in Analyze_Call. + + if Ekind (Etype (Subp)) = E_Subprogram_Type then + if not Is_Overloaded (Subp) then + Nam := Etype (Subp); + + else + -- Find the interpretation whose type (a subprogram type) has a + -- return type that is compatible with the context. Analysis of + -- the node has established that one exists. + + Nam := Empty; + + Get_First_Interp (Subp, I, It); + while Present (It.Typ) loop + if Covers (Typ, Etype (It.Typ)) then + Nam := It.Typ; + exit; + end if; + + Get_Next_Interp (I, It); + end loop; + + if No (Nam) then + raise Program_Error; + end if; + end if; + + -- If the prefix is not an entity, then resolve it + + if not Is_Entity_Name (Subp) then + Resolve (Subp, Nam); + end if; + + -- For an indirect call, we always invalidate checks, since we do not + -- know whether the subprogram is local or global. Yes we could do + -- better here, e.g. by knowing that there are no local subprograms, + -- but it does not seem worth the effort. Similarly, we kill all + -- knowledge of current constant values. + + Kill_Current_Values; + + -- If this is a procedure call which is really an entry call, do + -- the conversion of the procedure call to an entry call. Protected + -- operations use the same circuitry because the name in the call + -- can be an arbitrary expression with special resolution rules. + + elsif Nkind_In (Subp, N_Selected_Component, N_Indexed_Component) + or else (Is_Entity_Name (Subp) + and then Ekind (Entity (Subp)) = E_Entry) + then + Resolve_Entry_Call (N, Typ); + Check_Elab_Call (N); + + -- Kill checks and constant values, as above for indirect case + -- Who knows what happens when another task is activated? + + Kill_Current_Values; + return; + + -- Normal subprogram call with name established in Resolve + + elsif not (Is_Type (Entity (Subp))) then + Nam := Entity (Subp); + Set_Entity_With_Style_Check (Subp, Nam); + + -- Otherwise we must have the case of an overloaded call + + else + pragma Assert (Is_Overloaded (Subp)); + + -- Initialize Nam to prevent warning (we know it will be assigned + -- in the loop below, but the compiler does not know that). + + Nam := Empty; + + Get_First_Interp (Subp, I, It); + while Present (It.Typ) loop + if Covers (Typ, It.Typ) then + Nam := It.Nam; + Set_Entity_With_Style_Check (Subp, Nam); + exit; + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + + if Is_Access_Subprogram_Type (Base_Type (Etype (Nam))) + and then not Is_Access_Subprogram_Type (Base_Type (Typ)) + and then Nkind (Subp) /= N_Explicit_Dereference + and then Present (Parameter_Associations (N)) + then + -- The prefix is a parameterless function call that returns an access + -- to subprogram. If parameters are present in the current call, add + -- add an explicit dereference. We use the base type here because + -- within an instance these may be subtypes. + + -- The dereference is added either in Analyze_Call or here. Should + -- be consolidated ??? + + Set_Is_Overloaded (Subp, False); + Set_Etype (Subp, Etype (Nam)); + Insert_Explicit_Dereference (Subp); + Nam := Designated_Type (Etype (Nam)); + Resolve (Subp, Nam); + end if; + + -- Check that a call to Current_Task does not occur in an entry body + + if Is_RTE (Nam, RE_Current_Task) then + declare + P : Node_Id; + + begin + P := N; + loop + P := Parent (P); + + -- Exclude calls that occur within the default of a formal + -- parameter of the entry, since those are evaluated outside + -- of the body. + + exit when No (P) or else Nkind (P) = N_Parameter_Specification; + + if Nkind (P) = N_Entry_Body + or else (Nkind (P) = N_Subprogram_Body + and then Is_Entry_Barrier_Function (P)) + then + Rtype := Etype (N); + Error_Msg_NE + ("?& should not be used in entry body (RM C.7(17))", + N, Nam); + Error_Msg_NE + ("\Program_Error will be raised at run time?", N, Nam); + Rewrite (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Current_Task_In_Entry_Body)); + Set_Etype (N, Rtype); + return; + end if; + end loop; + end; + end if; + + -- Check that a procedure call does not occur in the context of the + -- entry call statement of a conditional or timed entry call. Note that + -- the case of a call to a subprogram renaming of an entry will also be + -- rejected. The test for N not being an N_Entry_Call_Statement is + -- defensive, covering the possibility that the processing of entry + -- calls might reach this point due to later modifications of the code + -- above. + + if Nkind (Parent (N)) = N_Entry_Call_Alternative + and then Nkind (N) /= N_Entry_Call_Statement + and then Entry_Call_Statement (Parent (N)) = N + then + if Ada_Version < Ada_2005 then + Error_Msg_N ("entry call required in select statement", N); + + -- Ada 2005 (AI-345): If a procedure_call_statement is used + -- for a procedure_or_entry_call, the procedure_name or + -- procedure_prefix of the procedure_call_statement shall denote + -- an entry renamed by a procedure, or (a view of) a primitive + -- subprogram of a limited interface whose first parameter is + -- a controlling parameter. + + elsif Nkind (N) = N_Procedure_Call_Statement + and then not Is_Renamed_Entry (Nam) + and then not Is_Controlling_Limited_Procedure (Nam) + then + Error_Msg_N + ("entry call or dispatching primitive of interface required", N); + end if; + end if; + + -- Check that this is not a call to a protected procedure or entry from + -- within a protected function. + + if Ekind (Current_Scope) = E_Function + and then Ekind (Scope (Current_Scope)) = E_Protected_Type + and then Ekind (Nam) /= E_Function + and then Scope (Nam) = Scope (Current_Scope) + then + Error_Msg_N ("within protected function, protected " & + "object is constant", N); + Error_Msg_N ("\cannot call operation that may modify it", N); + end if; + + -- Freeze the subprogram name if not in a spec-expression. Note that we + -- freeze procedure calls as well as function calls. Procedure calls are + -- not frozen according to the rules (RM 13.14(14)) because it is + -- impossible to have a procedure call to a non-frozen procedure in pure + -- Ada, but in the code that we generate in the expander, this rule + -- needs extending because we can generate procedure calls that need + -- freezing. + + if Is_Entity_Name (Subp) and then not In_Spec_Expression then + Freeze_Expression (Subp); + end if; + + -- For a predefined operator, the type of the result is the type imposed + -- by context, except for a predefined operation on universal fixed. + -- Otherwise The type of the call is the type returned by the subprogram + -- being called. + + if Is_Predefined_Op (Nam) then + if Etype (N) /= Universal_Fixed then + Set_Etype (N, Typ); + end if; + + -- If the subprogram returns an array type, and the context requires the + -- component type of that array type, the node is really an indexing of + -- the parameterless call. Resolve as such. A pathological case occurs + -- when the type of the component is an access to the array type. In + -- this case the call is truly ambiguous. + + elsif (Needs_No_Actuals (Nam) or else Needs_One_Actual (Nam)) + and then + ((Is_Array_Type (Etype (Nam)) + and then Covers (Typ, Component_Type (Etype (Nam)))) + or else (Is_Access_Type (Etype (Nam)) + and then Is_Array_Type (Designated_Type (Etype (Nam))) + and then + Covers (Typ, + Component_Type (Designated_Type (Etype (Nam)))))) + then + declare + Index_Node : Node_Id; + New_Subp : Node_Id; + Ret_Type : constant Entity_Id := Etype (Nam); + + begin + if Is_Access_Type (Ret_Type) + and then Ret_Type = Component_Type (Designated_Type (Ret_Type)) + then + Error_Msg_N + ("cannot disambiguate function call and indexing", N); + else + New_Subp := Relocate_Node (Subp); + Set_Entity (Subp, Nam); + + if (Is_Array_Type (Ret_Type) + and then Component_Type (Ret_Type) /= Any_Type) + or else + (Is_Access_Type (Ret_Type) + and then + Component_Type (Designated_Type (Ret_Type)) /= Any_Type) + then + if Needs_No_Actuals (Nam) then + + -- Indexed call to a parameterless function + + Index_Node := + Make_Indexed_Component (Loc, + Prefix => + Make_Function_Call (Loc, + Name => New_Subp), + Expressions => Parameter_Associations (N)); + else + -- An Ada 2005 prefixed call to a primitive operation + -- whose first parameter is the prefix. This prefix was + -- prepended to the parameter list, which is actually a + -- list of indexes. Remove the prefix in order to build + -- the proper indexed component. + + Index_Node := + Make_Indexed_Component (Loc, + Prefix => + Make_Function_Call (Loc, + Name => New_Subp, + Parameter_Associations => + New_List + (Remove_Head (Parameter_Associations (N)))), + Expressions => Parameter_Associations (N)); + end if; + + -- Preserve the parenthesis count of the node + + Set_Paren_Count (Index_Node, Paren_Count (N)); + + -- Since we are correcting a node classification error made + -- by the parser, we call Replace rather than Rewrite. + + Replace (N, Index_Node); + + Set_Etype (Prefix (N), Ret_Type); + Set_Etype (N, Typ); + Resolve_Indexed_Component (N, Typ); + Check_Elab_Call (Prefix (N)); + end if; + end if; + + return; + end; + + else + Set_Etype (N, Etype (Nam)); + end if; + + -- In the case where the call is to an overloaded subprogram, Analyze + -- calls Normalize_Actuals once per overloaded subprogram. Therefore in + -- such a case Normalize_Actuals needs to be called once more to order + -- the actuals correctly. Otherwise the call will have the ordering + -- given by the last overloaded subprogram whether this is the correct + -- one being called or not. + + if Is_Overloaded (Subp) then + Normalize_Actuals (N, Nam, False, Norm_OK); + pragma Assert (Norm_OK); + end if; + + -- In any case, call is fully resolved now. Reset Overload flag, to + -- prevent subsequent overload resolution if node is analyzed again + + Set_Is_Overloaded (Subp, False); + Set_Is_Overloaded (N, False); + + -- If we are calling the current subprogram from immediately within its + -- body, then that is the case where we can sometimes detect cases of + -- infinite recursion statically. Do not try this in case restriction + -- No_Recursion is in effect anyway, and do it only for source calls. + + if Comes_From_Source (N) then + Scop := Current_Scope; + + -- Issue warning for possible infinite recursion in the absence + -- of the No_Recursion restriction. + + if Same_Or_Aliased_Subprograms (Nam, Scop) + and then not Restriction_Active (No_Recursion) + and then Check_Infinite_Recursion (N) + then + -- Here we detected and flagged an infinite recursion, so we do + -- not need to test the case below for further warnings. Also we + -- are all done if we now have a raise SE node. + + if Nkind (N) = N_Raise_Storage_Error then + return; + end if; + + -- If call is to immediately containing subprogram, then check for + -- the case of a possible run-time detectable infinite recursion. + + else + Scope_Loop : while Scop /= Standard_Standard loop + if Same_Or_Aliased_Subprograms (Nam, Scop) then + + -- Although in general case, recursion is not statically + -- checkable, the case of calling an immediately containing + -- subprogram is easy to catch. + + Check_Restriction (No_Recursion, N); + + -- If the recursive call is to a parameterless subprogram, + -- then even if we can't statically detect infinite + -- recursion, this is pretty suspicious, and we output a + -- warning. Furthermore, we will try later to detect some + -- cases here at run time by expanding checking code (see + -- Detect_Infinite_Recursion in package Exp_Ch6). + + -- If the recursive call is within a handler, do not emit a + -- warning, because this is a common idiom: loop until input + -- is correct, catch illegal input in handler and restart. + + if No (First_Formal (Nam)) + and then Etype (Nam) = Standard_Void_Type + and then not Error_Posted (N) + and then Nkind (Parent (N)) /= N_Exception_Handler + then + -- For the case of a procedure call. We give the message + -- only if the call is the first statement in a sequence + -- of statements, or if all previous statements are + -- simple assignments. This is simply a heuristic to + -- decrease false positives, without losing too many good + -- warnings. The idea is that these previous statements + -- may affect global variables the procedure depends on. + + if Nkind (N) = N_Procedure_Call_Statement + and then Is_List_Member (N) + then + declare + P : Node_Id; + begin + P := Prev (N); + while Present (P) loop + if Nkind (P) /= N_Assignment_Statement then + exit Scope_Loop; + end if; + + Prev (P); + end loop; + end; + end if; + + -- Do not give warning if we are in a conditional context + + declare + K : constant Node_Kind := Nkind (Parent (N)); + begin + if (K = N_Loop_Statement + and then Present (Iteration_Scheme (Parent (N)))) + or else K = N_If_Statement + or else K = N_Elsif_Part + or else K = N_Case_Statement_Alternative + then + exit Scope_Loop; + end if; + end; + + -- Here warning is to be issued + + Set_Has_Recursive_Call (Nam); + Error_Msg_N + ("?possible infinite recursion!", N); + Error_Msg_N + ("\?Storage_Error may be raised at run time!", N); + end if; + + exit Scope_Loop; + end if; + + Scop := Scope (Scop); + end loop Scope_Loop; + end if; + end if; + + -- Check obsolescent reference to Ada.Characters.Handling subprogram + + Check_Obsolescent_2005_Entity (Nam, Subp); + + -- If subprogram name is a predefined operator, it was given in + -- functional notation. Replace call node with operator node, so + -- that actuals can be resolved appropriately. + + if Is_Predefined_Op (Nam) or else Ekind (Nam) = E_Operator then + Make_Call_Into_Operator (N, Typ, Entity (Name (N))); + return; + + elsif Present (Alias (Nam)) + and then Is_Predefined_Op (Alias (Nam)) + then + Resolve_Actuals (N, Nam); + Make_Call_Into_Operator (N, Typ, Alias (Nam)); + return; + end if; + + -- Create a transient scope if the resulting type requires it + + -- There are several notable exceptions: + + -- a) In init procs, the transient scope overhead is not needed, and is + -- even incorrect when the call is a nested initialization call for a + -- component whose expansion may generate adjust calls. However, if the + -- call is some other procedure call within an initialization procedure + -- (for example a call to Create_Task in the init_proc of the task + -- run-time record) a transient scope must be created around this call. + + -- b) Enumeration literal pseudo-calls need no transient scope + + -- c) Intrinsic subprograms (Unchecked_Conversion and source info + -- functions) do not use the secondary stack even though the return + -- type may be unconstrained. + + -- d) Calls to a build-in-place function, since such functions may + -- allocate their result directly in a target object, and cases where + -- the result does get allocated in the secondary stack are checked for + -- within the specialized Exp_Ch6 procedures for expanding those + -- build-in-place calls. + + -- e) If the subprogram is marked Inline_Always, then even if it returns + -- an unconstrained type the call does not require use of the secondary + -- stack. However, inlining will only take place if the body to inline + -- is already present. It may not be available if e.g. the subprogram is + -- declared in a child instance. + + -- If this is an initialization call for a type whose construction + -- uses the secondary stack, and it is not a nested call to initialize + -- a component, we do need to create a transient scope for it. We + -- check for this by traversing the type in Check_Initialization_Call. + + if Is_Inlined (Nam) + and then Has_Pragma_Inline_Always (Nam) + and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration + and then Present (Body_To_Inline (Unit_Declaration_Node (Nam))) + then + null; + + elsif Ekind (Nam) = E_Enumeration_Literal + or else Is_Build_In_Place_Function (Nam) + or else Is_Intrinsic_Subprogram (Nam) + then + null; + + elsif Expander_Active + and then Is_Type (Etype (Nam)) + and then Requires_Transient_Scope (Etype (Nam)) + and then + (not Within_Init_Proc + or else + (not Is_Init_Proc (Nam) and then Ekind (Nam) /= E_Function)) + then + Establish_Transient_Scope (N, Sec_Stack => True); + + -- If the call appears within the bounds of a loop, it will + -- be rewritten and reanalyzed, nothing left to do here. + + if Nkind (N) /= N_Function_Call then + return; + end if; + + elsif Is_Init_Proc (Nam) + and then not Within_Init_Proc + then + Check_Initialization_Call (N, Nam); + end if; + + -- A protected function cannot be called within the definition of the + -- enclosing protected type. + + if Is_Protected_Type (Scope (Nam)) + and then In_Open_Scopes (Scope (Nam)) + and then not Has_Completion (Scope (Nam)) + then + Error_Msg_NE + ("& cannot be called before end of protected definition", N, Nam); + end if; + + -- Propagate interpretation to actuals, and add default expressions + -- where needed. + + if Present (First_Formal (Nam)) then + Resolve_Actuals (N, Nam); + + -- Overloaded literals are rewritten as function calls, for purpose of + -- resolution. After resolution, we can replace the call with the + -- literal itself. + + elsif Ekind (Nam) = E_Enumeration_Literal then + Copy_Node (Subp, N); + Resolve_Entity_Name (N, Typ); + + -- Avoid validation, since it is a static function call + + Generate_Reference (Nam, Subp); + return; + end if; + + -- If the subprogram is not global, then kill all saved values and + -- checks. This is a bit conservative, since in many cases we could do + -- better, but it is not worth the effort. Similarly, we kill constant + -- values. However we do not need to do this for internal entities + -- (unless they are inherited user-defined subprograms), since they + -- are not in the business of molesting local values. + + -- If the flag Suppress_Value_Tracking_On_Calls is set, then we also + -- kill all checks and values for calls to global subprograms. This + -- takes care of the case where an access to a local subprogram is + -- taken, and could be passed directly or indirectly and then called + -- from almost any context. + + -- Note: we do not do this step till after resolving the actuals. That + -- way we still take advantage of the current value information while + -- scanning the actuals. + + -- We suppress killing values if we are processing the nodes associated + -- with N_Freeze_Entity nodes. Otherwise the declaration of a tagged + -- type kills all the values as part of analyzing the code that + -- initializes the dispatch tables. + + if Inside_Freezing_Actions = 0 + and then (not Is_Library_Level_Entity (Nam) + or else Suppress_Value_Tracking_On_Call + (Nearest_Dynamic_Scope (Current_Scope))) + and then (Comes_From_Source (Nam) + or else (Present (Alias (Nam)) + and then Comes_From_Source (Alias (Nam)))) + then + Kill_Current_Values; + end if; + + -- If we are warning about unread OUT parameters, this is the place to + -- set Last_Assignment for OUT and IN OUT parameters. We have to do this + -- after the above call to Kill_Current_Values (since that call clears + -- the Last_Assignment field of all local variables). + + if (Warn_On_Modified_Unread or Warn_On_All_Unread_Out_Parameters) + and then Comes_From_Source (N) + and then In_Extended_Main_Source_Unit (N) + then + declare + F : Entity_Id; + A : Node_Id; + + begin + F := First_Formal (Nam); + A := First_Actual (N); + while Present (F) and then Present (A) loop + if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) + and then Warn_On_Modified_As_Out_Parameter (F) + and then Is_Entity_Name (A) + and then Present (Entity (A)) + and then Comes_From_Source (N) + and then Safe_To_Capture_Value (N, Entity (A)) + then + Set_Last_Assignment (Entity (A), A); + end if; + + Next_Formal (F); + Next_Actual (A); + end loop; + end; + end if; + + -- If the subprogram is a primitive operation, check whether or not + -- it is a correct dispatching call. + + if Is_Overloadable (Nam) + and then Is_Dispatching_Operation (Nam) + then + Check_Dispatching_Call (N); + + elsif Ekind (Nam) /= E_Subprogram_Type + and then Is_Abstract_Subprogram (Nam) + and then not In_Instance + then + Error_Msg_NE ("cannot call abstract subprogram &!", N, Nam); + end if; + + -- If this is a dispatching call, generate the appropriate reference, + -- for better source navigation in GPS. + + if Is_Overloadable (Nam) + and then Present (Controlling_Argument (N)) + then + Generate_Reference (Nam, Subp, 'R'); + + -- Normal case, not a dispatching call. Generate a call reference. + + else + Generate_Reference (Nam, Subp, 's'); + end if; + + if Is_Intrinsic_Subprogram (Nam) then + Check_Intrinsic_Call (N); + end if; + + -- Check for violation of restriction No_Specific_Termination_Handlers + -- and warn on a potentially blocking call to Abort_Task. + + if Is_RTE (Nam, RE_Set_Specific_Handler) + or else + Is_RTE (Nam, RE_Specific_Handler) + then + Check_Restriction (No_Specific_Termination_Handlers, N); + + elsif Is_RTE (Nam, RE_Abort_Task) then + Check_Potentially_Blocking_Operation (N); + end if; + + -- A call to Ada.Real_Time.Timing_Events.Set_Handler violates + -- restriction No_Relative_Delay (AI-0211). + + if Is_RTE (Nam, RE_Set_Handler) then + Check_Restriction (No_Relative_Delay, N); + end if; + + -- Issue an error for a call to an eliminated subprogram. We skip this + -- in a spec expression, e.g. a call in a default parameter value, since + -- we are not really doing a call at this time. That's important because + -- the spec expression may itself belong to an eliminated subprogram. + + if not In_Spec_Expression then + Check_For_Eliminated_Subprogram (Subp, Nam); + end if; + + -- All done, evaluate call and deal with elaboration issues + + Eval_Call (N); + Check_Elab_Call (N); + Warn_On_Overlapping_Actuals (Nam, N); + end Resolve_Call; + + ----------------------------- + -- Resolve_Case_Expression -- + ----------------------------- + + procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id) is + Alt : Node_Id; + + begin + Alt := First (Alternatives (N)); + while Present (Alt) loop + Resolve (Expression (Alt), Typ); + Next (Alt); + end loop; + + Set_Etype (N, Typ); + Eval_Case_Expression (N); + end Resolve_Case_Expression; + + ------------------------------- + -- Resolve_Character_Literal -- + ------------------------------- + + procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id) is + B_Typ : constant Entity_Id := Base_Type (Typ); + C : Entity_Id; + + begin + -- Verify that the character does belong to the type of the context + + Set_Etype (N, B_Typ); + Eval_Character_Literal (N); + + -- Wide_Wide_Character literals must always be defined, since the set + -- of wide wide character literals is complete, i.e. if a character + -- literal is accepted by the parser, then it is OK for wide wide + -- character (out of range character literals are rejected). + + if Root_Type (B_Typ) = Standard_Wide_Wide_Character then + return; + + -- Always accept character literal for type Any_Character, which + -- occurs in error situations and in comparisons of literals, both + -- of which should accept all literals. + + elsif B_Typ = Any_Character then + return; + + -- For Standard.Character or a type derived from it, check that + -- the literal is in range + + elsif Root_Type (B_Typ) = Standard_Character then + if In_Character_Range (UI_To_CC (Char_Literal_Value (N))) then + return; + end if; + + -- For Standard.Wide_Character or a type derived from it, check + -- that the literal is in range + + elsif Root_Type (B_Typ) = Standard_Wide_Character then + if In_Wide_Character_Range (UI_To_CC (Char_Literal_Value (N))) then + return; + end if; + + -- For Standard.Wide_Wide_Character or a type derived from it, we + -- know the literal is in range, since the parser checked! + + elsif Root_Type (B_Typ) = Standard_Wide_Wide_Character then + return; + + -- If the entity is already set, this has already been resolved in a + -- generic context, or comes from expansion. Nothing else to do. + + elsif Present (Entity (N)) then + return; + + -- Otherwise we have a user defined character type, and we can use the + -- standard visibility mechanisms to locate the referenced entity. + + else + C := Current_Entity (N); + while Present (C) loop + if Etype (C) = B_Typ then + Set_Entity_With_Style_Check (N, C); + Generate_Reference (C, N); + return; + end if; + + C := Homonym (C); + end loop; + end if; + + -- If we fall through, then the literal does not match any of the + -- entries of the enumeration type. This isn't just a constraint + -- error situation, it is an illegality (see RM 4.2). + + Error_Msg_NE + ("character not defined for }", N, First_Subtype (B_Typ)); + end Resolve_Character_Literal; + + --------------------------- + -- Resolve_Comparison_Op -- + --------------------------- + + -- Context requires a boolean type, and plays no role in resolution. + -- Processing identical to that for equality operators. The result + -- type is the base type, which matters when pathological subtypes of + -- booleans with limited ranges are used. + + procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id) is + L : constant Node_Id := Left_Opnd (N); + R : constant Node_Id := Right_Opnd (N); + T : Entity_Id; + + begin + -- If this is an intrinsic operation which is not predefined, use the + -- types of its declared arguments to resolve the possibly overloaded + -- operands. Otherwise the operands are unambiguous and specify the + -- expected type. + + if Scope (Entity (N)) /= Standard_Standard then + T := Etype (First_Entity (Entity (N))); + + else + T := Find_Unique_Type (L, R); + + if T = Any_Fixed then + T := Unique_Fixed_Point_Type (L); + end if; + end if; + + Set_Etype (N, Base_Type (Typ)); + Generate_Reference (T, N, ' '); + + -- Skip remaining processing if already set to Any_Type + + if T = Any_Type then + return; + end if; + + -- Deal with other error cases + + if T = Any_String or else + T = Any_Composite or else + T = Any_Character + then + if T = Any_Character then + Ambiguous_Character (L); + else + Error_Msg_N ("ambiguous operands for comparison", N); + end if; + + Set_Etype (N, Any_Type); + return; + end if; + + -- Resolve the operands if types OK + + Resolve (L, T); + Resolve (R, T); + Check_Unset_Reference (L); + Check_Unset_Reference (R); + Generate_Operator_Reference (N, T); + Check_Low_Bound_Tested (N); + + -- Check comparison on unordered enumeration + + if Comes_From_Source (N) + and then Bad_Unordered_Enumeration_Reference (N, Etype (L)) + then + Error_Msg_N ("comparison on unordered enumeration type?", N); + end if; + + -- Evaluate the relation (note we do this after the above check + -- since this Eval call may change N to True/False. + + Eval_Relational_Op (N); + end Resolve_Comparison_Op; + + ------------------------------------ + -- Resolve_Conditional_Expression -- + ------------------------------------ + + procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id) is + Condition : constant Node_Id := First (Expressions (N)); + Then_Expr : constant Node_Id := Next (Condition); + Else_Expr : Node_Id := Next (Then_Expr); + + begin + Resolve (Condition, Any_Boolean); + Resolve (Then_Expr, Typ); + + -- If ELSE expression present, just resolve using the determined type + + if Present (Else_Expr) then + Resolve (Else_Expr, Typ); + + -- If no ELSE expression is present, root type must be Standard.Boolean + -- and we provide a Standard.True result converted to the appropriate + -- Boolean type (in case it is a derived boolean type). + + elsif Root_Type (Typ) = Standard_Boolean then + Else_Expr := + Convert_To (Typ, New_Occurrence_Of (Standard_True, Sloc (N))); + Analyze_And_Resolve (Else_Expr, Typ); + Append_To (Expressions (N), Else_Expr); + + else + Error_Msg_N ("can only omit ELSE expression in Boolean case", N); + Append_To (Expressions (N), Error); + end if; + + Set_Etype (N, Typ); + Eval_Conditional_Expression (N); + end Resolve_Conditional_Expression; + + ----------------------------------------- + -- Resolve_Discrete_Subtype_Indication -- + ----------------------------------------- + + procedure Resolve_Discrete_Subtype_Indication + (N : Node_Id; + Typ : Entity_Id) + is + R : Node_Id; + S : Entity_Id; + + begin + Analyze (Subtype_Mark (N)); + S := Entity (Subtype_Mark (N)); + + if Nkind (Constraint (N)) /= N_Range_Constraint then + Error_Msg_N ("expect range constraint for discrete type", N); + Set_Etype (N, Any_Type); + + else + R := Range_Expression (Constraint (N)); + + if R = Error then + return; + end if; + + Analyze (R); + + if Base_Type (S) /= Base_Type (Typ) then + Error_Msg_NE + ("expect subtype of }", N, First_Subtype (Typ)); + + -- Rewrite the constraint as a range of Typ + -- to allow compilation to proceed further. + + Set_Etype (N, Typ); + Rewrite (Low_Bound (R), + Make_Attribute_Reference (Sloc (Low_Bound (R)), + Prefix => New_Occurrence_Of (Typ, Sloc (R)), + Attribute_Name => Name_First)); + Rewrite (High_Bound (R), + Make_Attribute_Reference (Sloc (High_Bound (R)), + Prefix => New_Occurrence_Of (Typ, Sloc (R)), + Attribute_Name => Name_First)); + + else + Resolve (R, Typ); + Set_Etype (N, Etype (R)); + + -- Additionally, we must check that the bounds are compatible + -- with the given subtype, which might be different from the + -- type of the context. + + Apply_Range_Check (R, S); + + -- ??? If the above check statically detects a Constraint_Error + -- it replaces the offending bound(s) of the range R with a + -- Constraint_Error node. When the itype which uses these bounds + -- is frozen the resulting call to Duplicate_Subexpr generates + -- a new temporary for the bounds. + + -- Unfortunately there are other itypes that are also made depend + -- on these bounds, so when Duplicate_Subexpr is called they get + -- a forward reference to the newly created temporaries and Gigi + -- aborts on such forward references. This is probably sign of a + -- more fundamental problem somewhere else in either the order of + -- itype freezing or the way certain itypes are constructed. + + -- To get around this problem we call Remove_Side_Effects right + -- away if either bounds of R are a Constraint_Error. + + declare + L : constant Node_Id := Low_Bound (R); + H : constant Node_Id := High_Bound (R); + + begin + if Nkind (L) = N_Raise_Constraint_Error then + Remove_Side_Effects (L); + end if; + + if Nkind (H) = N_Raise_Constraint_Error then + Remove_Side_Effects (H); + end if; + end; + + Check_Unset_Reference (Low_Bound (R)); + Check_Unset_Reference (High_Bound (R)); + end if; + end if; + end Resolve_Discrete_Subtype_Indication; + + ------------------------- + -- Resolve_Entity_Name -- + ------------------------- + + -- Used to resolve identifiers and expanded names + + procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id) is + E : constant Entity_Id := Entity (N); + + begin + -- If garbage from errors, set to Any_Type and return + + if No (E) and then Total_Errors_Detected /= 0 then + Set_Etype (N, Any_Type); + return; + end if; + + -- Replace named numbers by corresponding literals. Note that this is + -- the one case where Resolve_Entity_Name must reset the Etype, since + -- it is currently marked as universal. + + if Ekind (E) = E_Named_Integer then + Set_Etype (N, Typ); + Eval_Named_Integer (N); + + elsif Ekind (E) = E_Named_Real then + Set_Etype (N, Typ); + Eval_Named_Real (N); + + -- For enumeration literals, we need to make sure that a proper style + -- check is done, since such literals are overloaded, and thus we did + -- not do a style check during the first phase of analysis. + + elsif Ekind (E) = E_Enumeration_Literal then + Set_Entity_With_Style_Check (N, E); + Eval_Entity_Name (N); + + -- Case of subtype name appearing as an operand in expression + + elsif Is_Type (E) then + + -- Allow use of subtype if it is a concurrent type where we are + -- currently inside the body. This will eventually be expanded into a + -- call to Self (for tasks) or _object (for protected objects). Any + -- other use of a subtype is invalid. + + if Is_Concurrent_Type (E) + and then In_Open_Scopes (E) + then + null; + + -- Any other use is an error + + else + Error_Msg_N + ("invalid use of subtype mark in expression or call", N); + end if; + + -- Check discriminant use if entity is discriminant in current scope, + -- i.e. discriminant of record or concurrent type currently being + -- analyzed. Uses in corresponding body are unrestricted. + + elsif Ekind (E) = E_Discriminant + and then Scope (E) = Current_Scope + and then not Has_Completion (Current_Scope) + then + Check_Discriminant_Use (N); + + -- A parameterless generic function cannot appear in a context that + -- requires resolution. + + elsif Ekind (E) = E_Generic_Function then + Error_Msg_N ("illegal use of generic function", N); + + elsif Ekind (E) = E_Out_Parameter + and then Ada_Version = Ada_83 + and then (Nkind (Parent (N)) in N_Op + or else (Nkind (Parent (N)) = N_Assignment_Statement + and then N = Expression (Parent (N))) + or else Nkind (Parent (N)) = N_Explicit_Dereference) + then + Error_Msg_N ("(Ada 83) illegal reading of out parameter", N); + + -- In all other cases, just do the possible static evaluation + + else + -- A deferred constant that appears in an expression must have a + -- completion, unless it has been removed by in-place expansion of + -- an aggregate. + + if Ekind (E) = E_Constant + and then Comes_From_Source (E) + and then No (Constant_Value (E)) + and then Is_Frozen (Etype (E)) + and then not In_Spec_Expression + and then not Is_Imported (E) + then + if No_Initialization (Parent (E)) + or else (Present (Full_View (E)) + and then No_Initialization (Parent (Full_View (E)))) + then + null; + else + Error_Msg_N ( + "deferred constant is frozen before completion", N); + end if; + end if; + + Eval_Entity_Name (N); + end if; + end Resolve_Entity_Name; + + ------------------- + -- Resolve_Entry -- + ------------------- + + procedure Resolve_Entry (Entry_Name : Node_Id) is + Loc : constant Source_Ptr := Sloc (Entry_Name); + Nam : Entity_Id; + New_N : Node_Id; + S : Entity_Id; + Tsk : Entity_Id; + E_Name : Node_Id; + Index : Node_Id; + + function Actual_Index_Type (E : Entity_Id) return Entity_Id; + -- If the bounds of the entry family being called depend on task + -- discriminants, build a new index subtype where a discriminant is + -- replaced with the value of the discriminant of the target task. + -- The target task is the prefix of the entry name in the call. + + ----------------------- + -- Actual_Index_Type -- + ----------------------- + + function Actual_Index_Type (E : Entity_Id) return Entity_Id is + Typ : constant Entity_Id := Entry_Index_Type (E); + Tsk : constant Entity_Id := Scope (E); + Lo : constant Node_Id := Type_Low_Bound (Typ); + Hi : constant Node_Id := Type_High_Bound (Typ); + New_T : Entity_Id; + + function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id; + -- If the bound is given by a discriminant, replace with a reference + -- to the discriminant of the same name in the target task. If the + -- entry name is the target of a requeue statement and the entry is + -- in the current protected object, the bound to be used is the + -- discriminal of the object (see Apply_Range_Checks for details of + -- the transformation). + + ----------------------------- + -- Actual_Discriminant_Ref -- + ----------------------------- + + function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is + Typ : constant Entity_Id := Etype (Bound); + Ref : Node_Id; + + begin + Remove_Side_Effects (Bound); + + if not Is_Entity_Name (Bound) + or else Ekind (Entity (Bound)) /= E_Discriminant + then + return Bound; + + elsif Is_Protected_Type (Tsk) + and then In_Open_Scopes (Tsk) + and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement + then + -- Note: here Bound denotes a discriminant of the corresponding + -- record type tskV, whose discriminal is a formal of the + -- init-proc tskVIP. What we want is the body discriminal, + -- which is associated to the discriminant of the original + -- concurrent type tsk. + + return New_Occurrence_Of + (Find_Body_Discriminal (Entity (Bound)), Loc); + + else + Ref := + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Prefix (Prefix (Entry_Name))), + Selector_Name => New_Occurrence_Of (Entity (Bound), Loc)); + Analyze (Ref); + Resolve (Ref, Typ); + return Ref; + end if; + end Actual_Discriminant_Ref; + + -- Start of processing for Actual_Index_Type + + begin + if not Has_Discriminants (Tsk) + or else (not Is_Entity_Name (Lo) + and then + not Is_Entity_Name (Hi)) + then + return Entry_Index_Type (E); + + else + New_T := Create_Itype (Ekind (Typ), Parent (Entry_Name)); + Set_Etype (New_T, Base_Type (Typ)); + Set_Size_Info (New_T, Typ); + Set_RM_Size (New_T, RM_Size (Typ)); + Set_Scalar_Range (New_T, + Make_Range (Sloc (Entry_Name), + Low_Bound => Actual_Discriminant_Ref (Lo), + High_Bound => Actual_Discriminant_Ref (Hi))); + + return New_T; + end if; + end Actual_Index_Type; + + -- Start of processing of Resolve_Entry + + begin + -- Find name of entry being called, and resolve prefix of name + -- with its own type. The prefix can be overloaded, and the name + -- and signature of the entry must be taken into account. + + if Nkind (Entry_Name) = N_Indexed_Component then + + -- Case of dealing with entry family within the current tasks + + E_Name := Prefix (Entry_Name); + + else + E_Name := Entry_Name; + end if; + + if Is_Entity_Name (E_Name) then + + -- Entry call to an entry (or entry family) in the current task. This + -- is legal even though the task will deadlock. Rewrite as call to + -- current task. + + -- This can also be a call to an entry in an enclosing task. If this + -- is a single task, we have to retrieve its name, because the scope + -- of the entry is the task type, not the object. If the enclosing + -- task is a task type, the identity of the task is given by its own + -- self variable. + + -- Finally this can be a requeue on an entry of the same task or + -- protected object. + + S := Scope (Entity (E_Name)); + + for J in reverse 0 .. Scope_Stack.Last loop + if Is_Task_Type (Scope_Stack.Table (J).Entity) + and then not Comes_From_Source (S) + then + -- S is an enclosing task or protected object. The concurrent + -- declaration has been converted into a type declaration, and + -- the object itself has an object declaration that follows + -- the type in the same declarative part. + + Tsk := Next_Entity (S); + while Etype (Tsk) /= S loop + Next_Entity (Tsk); + end loop; + + S := Tsk; + exit; + + elsif S = Scope_Stack.Table (J).Entity then + + -- Call to current task. Will be transformed into call to Self + + exit; + + end if; + end loop; + + New_N := + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (S, Loc), + Selector_Name => + New_Occurrence_Of (Entity (E_Name), Loc)); + Rewrite (E_Name, New_N); + Analyze (E_Name); + + elsif Nkind (Entry_Name) = N_Selected_Component + and then Is_Overloaded (Prefix (Entry_Name)) + then + -- Use the entry name (which must be unique at this point) to find + -- the prefix that returns the corresponding task type or protected + -- type. + + declare + Pref : constant Node_Id := Prefix (Entry_Name); + Ent : constant Entity_Id := Entity (Selector_Name (Entry_Name)); + I : Interp_Index; + It : Interp; + + begin + Get_First_Interp (Pref, I, It); + while Present (It.Typ) loop + if Scope (Ent) = It.Typ then + Set_Etype (Pref, It.Typ); + exit; + end if; + + Get_Next_Interp (I, It); + end loop; + end; + end if; + + if Nkind (Entry_Name) = N_Selected_Component then + Resolve (Prefix (Entry_Name)); + + else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component); + Nam := Entity (Selector_Name (Prefix (Entry_Name))); + Resolve (Prefix (Prefix (Entry_Name))); + Index := First (Expressions (Entry_Name)); + Resolve (Index, Entry_Index_Type (Nam)); + + -- Up to this point the expression could have been the actual in a + -- simple entry call, and be given by a named association. + + if Nkind (Index) = N_Parameter_Association then + Error_Msg_N ("expect expression for entry index", Index); + else + Apply_Range_Check (Index, Actual_Index_Type (Nam)); + end if; + end if; + end Resolve_Entry; + + ------------------------ + -- Resolve_Entry_Call -- + ------------------------ + + procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id) is + Entry_Name : constant Node_Id := Name (N); + Loc : constant Source_Ptr := Sloc (Entry_Name); + Actuals : List_Id; + First_Named : Node_Id; + Nam : Entity_Id; + Norm_OK : Boolean; + Obj : Node_Id; + Was_Over : Boolean; + + begin + -- We kill all checks here, because it does not seem worth the effort to + -- do anything better, an entry call is a big operation. + + Kill_All_Checks; + + -- Processing of the name is similar for entry calls and protected + -- operation calls. Once the entity is determined, we can complete + -- the resolution of the actuals. + + -- The selector may be overloaded, in the case of a protected object + -- with overloaded functions. The type of the context is used for + -- resolution. + + if Nkind (Entry_Name) = N_Selected_Component + and then Is_Overloaded (Selector_Name (Entry_Name)) + and then Typ /= Standard_Void_Type + then + declare + I : Interp_Index; + It : Interp; + + begin + Get_First_Interp (Selector_Name (Entry_Name), I, It); + while Present (It.Typ) loop + if Covers (Typ, It.Typ) then + Set_Entity (Selector_Name (Entry_Name), It.Nam); + Set_Etype (Entry_Name, It.Typ); + + Generate_Reference (It.Typ, N, ' '); + end if; + + Get_Next_Interp (I, It); + end loop; + end; + end if; + + Resolve_Entry (Entry_Name); + + if Nkind (Entry_Name) = N_Selected_Component then + + -- Simple entry call + + Nam := Entity (Selector_Name (Entry_Name)); + Obj := Prefix (Entry_Name); + Was_Over := Is_Overloaded (Selector_Name (Entry_Name)); + + else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component); + + -- Call to member of entry family + + Nam := Entity (Selector_Name (Prefix (Entry_Name))); + Obj := Prefix (Prefix (Entry_Name)); + Was_Over := Is_Overloaded (Selector_Name (Prefix (Entry_Name))); + end if; + + -- We cannot in general check the maximum depth of protected entry + -- calls at compile time. But we can tell that any protected entry + -- call at all violates a specified nesting depth of zero. + + if Is_Protected_Type (Scope (Nam)) then + Check_Restriction (Max_Entry_Queue_Length, N); + end if; + + -- Use context type to disambiguate a protected function that can be + -- called without actuals and that returns an array type, and where + -- the argument list may be an indexing of the returned value. + + if Ekind (Nam) = E_Function + and then Needs_No_Actuals (Nam) + and then Present (Parameter_Associations (N)) + and then + ((Is_Array_Type (Etype (Nam)) + and then Covers (Typ, Component_Type (Etype (Nam)))) + + or else (Is_Access_Type (Etype (Nam)) + and then Is_Array_Type (Designated_Type (Etype (Nam))) + and then Covers (Typ, + Component_Type (Designated_Type (Etype (Nam)))))) + then + declare + Index_Node : Node_Id; + + begin + Index_Node := + Make_Indexed_Component (Loc, + Prefix => + Make_Function_Call (Loc, + Name => Relocate_Node (Entry_Name)), + Expressions => Parameter_Associations (N)); + + -- Since we are correcting a node classification error made by + -- the parser, we call Replace rather than Rewrite. + + Replace (N, Index_Node); + Set_Etype (Prefix (N), Etype (Nam)); + Set_Etype (N, Typ); + Resolve_Indexed_Component (N, Typ); + return; + end; + end if; + + if Ekind_In (Nam, E_Entry, E_Entry_Family) + and then Present (PPC_Wrapper (Nam)) + and then Current_Scope /= PPC_Wrapper (Nam) + then + -- Rewrite as call to the precondition wrapper, adding the task + -- object to the list of actuals. If the call is to a member of + -- an entry family, include the index as well. + + declare + New_Call : Node_Id; + New_Actuals : List_Id; + begin + New_Actuals := New_List (Obj); + + if Nkind (Entry_Name) = N_Indexed_Component then + Append_To (New_Actuals, + New_Copy_Tree (First (Expressions (Entry_Name)))); + end if; + + Append_List (Parameter_Associations (N), New_Actuals); + New_Call := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (PPC_Wrapper (Nam), Loc), + Parameter_Associations => New_Actuals); + Rewrite (N, New_Call); + Analyze_And_Resolve (N); + return; + end; + end if; + + -- The operation name may have been overloaded. Order the actuals + -- according to the formals of the resolved entity, and set the + -- return type to that of the operation. + + if Was_Over then + Normalize_Actuals (N, Nam, False, Norm_OK); + pragma Assert (Norm_OK); + Set_Etype (N, Etype (Nam)); + end if; + + Resolve_Actuals (N, Nam); + + -- Create a call reference to the entry + + Generate_Reference (Nam, Entry_Name, 's'); + + if Ekind_In (Nam, E_Entry, E_Entry_Family) then + Check_Potentially_Blocking_Operation (N); + end if; + + -- Verify that a procedure call cannot masquerade as an entry + -- call where an entry call is expected. + + if Ekind (Nam) = E_Procedure then + if Nkind (Parent (N)) = N_Entry_Call_Alternative + and then N = Entry_Call_Statement (Parent (N)) + then + Error_Msg_N ("entry call required in select statement", N); + + elsif Nkind (Parent (N)) = N_Triggering_Alternative + and then N = Triggering_Statement (Parent (N)) + then + Error_Msg_N ("triggering statement cannot be procedure call", N); + + elsif Ekind (Scope (Nam)) = E_Task_Type + and then not In_Open_Scopes (Scope (Nam)) + then + Error_Msg_N ("task has no entry with this name", Entry_Name); + end if; + end if; + + -- After resolution, entry calls and protected procedure calls are + -- changed into entry calls, for expansion. The structure of the node + -- does not change, so it can safely be done in place. Protected + -- function calls must keep their structure because they are + -- subexpressions. + + if Ekind (Nam) /= E_Function then + + -- A protected operation that is not a function may modify the + -- corresponding object, and cannot apply to a constant. If this + -- is an internal call, the prefix is the type itself. + + if Is_Protected_Type (Scope (Nam)) + and then not Is_Variable (Obj) + and then (not Is_Entity_Name (Obj) + or else not Is_Type (Entity (Obj))) + then + Error_Msg_N + ("prefix of protected procedure or entry call must be variable", + Entry_Name); + end if; + + Actuals := Parameter_Associations (N); + First_Named := First_Named_Actual (N); + + Rewrite (N, + Make_Entry_Call_Statement (Loc, + Name => Entry_Name, + Parameter_Associations => Actuals)); + + Set_First_Named_Actual (N, First_Named); + Set_Analyzed (N, True); + + -- Protected functions can return on the secondary stack, in which + -- case we must trigger the transient scope mechanism. + + elsif Expander_Active + and then Requires_Transient_Scope (Etype (Nam)) + then + Establish_Transient_Scope (N, Sec_Stack => True); + end if; + end Resolve_Entry_Call; + + ------------------------- + -- Resolve_Equality_Op -- + ------------------------- + + -- Both arguments must have the same type, and the boolean context does + -- not participate in the resolution. The first pass verifies that the + -- interpretation is not ambiguous, and the type of the left argument is + -- correctly set, or is Any_Type in case of ambiguity. If both arguments + -- are strings or aggregates, allocators, or Null, they are ambiguous even + -- though they carry a single (universal) type. Diagnose this case here. + + procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id) is + L : constant Node_Id := Left_Opnd (N); + R : constant Node_Id := Right_Opnd (N); + T : Entity_Id := Find_Unique_Type (L, R); + + procedure Check_Conditional_Expression (Cond : Node_Id); + -- The resolution rule for conditional expressions requires that each + -- such must have a unique type. This means that if several dependent + -- expressions are of a non-null anonymous access type, and the context + -- does not impose an expected type (as can be the case in an equality + -- operation) the expression must be rejected. + + function Find_Unique_Access_Type return Entity_Id; + -- In the case of allocators, make a last-ditch attempt to find a single + -- access type with the right designated type. This is semantically + -- dubious, and of no interest to any real code, but c48008a makes it + -- all worthwhile. + + ---------------------------------- + -- Check_Conditional_Expression -- + ---------------------------------- + + procedure Check_Conditional_Expression (Cond : Node_Id) is + Then_Expr : Node_Id; + Else_Expr : Node_Id; + + begin + if Nkind (Cond) = N_Conditional_Expression then + Then_Expr := Next (First (Expressions (Cond))); + Else_Expr := Next (Then_Expr); + + if Nkind (Then_Expr) /= N_Null + and then Nkind (Else_Expr) /= N_Null + then + Error_Msg_N + ("cannot determine type of conditional expression", Cond); + end if; + end if; + end Check_Conditional_Expression; + + ----------------------------- + -- Find_Unique_Access_Type -- + ----------------------------- + + function Find_Unique_Access_Type return Entity_Id is + Acc : Entity_Id; + E : Entity_Id; + S : Entity_Id; + + begin + if Ekind (Etype (R)) = E_Allocator_Type then + Acc := Designated_Type (Etype (R)); + elsif Ekind (Etype (L)) = E_Allocator_Type then + Acc := Designated_Type (Etype (L)); + else + return Empty; + end if; + + S := Current_Scope; + while S /= Standard_Standard loop + E := First_Entity (S); + while Present (E) loop + if Is_Type (E) + and then Is_Access_Type (E) + and then Ekind (E) /= E_Allocator_Type + and then Designated_Type (E) = Base_Type (Acc) + then + return E; + end if; + + Next_Entity (E); + end loop; + + S := Scope (S); + end loop; + + return Empty; + end Find_Unique_Access_Type; + + -- Start of processing for Resolve_Equality_Op + + begin + Set_Etype (N, Base_Type (Typ)); + Generate_Reference (T, N, ' '); + + if T = Any_Fixed then + T := Unique_Fixed_Point_Type (L); + end if; + + if T /= Any_Type then + if T = Any_String + or else T = Any_Composite + or else T = Any_Character + then + if T = Any_Character then + Ambiguous_Character (L); + else + Error_Msg_N ("ambiguous operands for equality", N); + end if; + + Set_Etype (N, Any_Type); + return; + + elsif T = Any_Access + or else Ekind_In (T, E_Allocator_Type, E_Access_Attribute_Type) + then + T := Find_Unique_Access_Type; + + if No (T) then + Error_Msg_N ("ambiguous operands for equality", N); + Set_Etype (N, Any_Type); + return; + end if; + + -- Conditional expressions must have a single type, and if the + -- context does not impose one the dependent expressions cannot + -- be anonymous access types. + + elsif Ada_Version >= Ada_2012 + and then Ekind_In (Etype (L), E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) + and then Ekind_In (Etype (R), E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) + then + Check_Conditional_Expression (L); + Check_Conditional_Expression (R); + end if; + + Resolve (L, T); + Resolve (R, T); + + -- If the unique type is a class-wide type then it will be expanded + -- into a dispatching call to the predefined primitive. Therefore we + -- check here for potential violation of such restriction. + + if Is_Class_Wide_Type (T) then + Check_Restriction (No_Dispatching_Calls, N); + end if; + + if Warn_On_Redundant_Constructs + and then Comes_From_Source (N) + and then Is_Entity_Name (R) + and then Entity (R) = Standard_True + and then Comes_From_Source (R) + then + Error_Msg_N -- CODEFIX + ("?comparison with True is redundant!", R); + end if; + + Check_Unset_Reference (L); + Check_Unset_Reference (R); + Generate_Operator_Reference (N, T); + Check_Low_Bound_Tested (N); + + -- If this is an inequality, it may be the implicit inequality + -- created for a user-defined operation, in which case the corres- + -- ponding equality operation is not intrinsic, and the operation + -- cannot be constant-folded. Else fold. + + if Nkind (N) = N_Op_Eq + or else Comes_From_Source (Entity (N)) + or else Ekind (Entity (N)) = E_Operator + or else Is_Intrinsic_Subprogram + (Corresponding_Equality (Entity (N))) + then + Eval_Relational_Op (N); + + elsif Nkind (N) = N_Op_Ne + and then Is_Abstract_Subprogram (Entity (N)) + then + Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N)); + end if; + + -- Ada 2005: If one operand is an anonymous access type, convert the + -- other operand to it, to ensure that the underlying types match in + -- the back-end. Same for access_to_subprogram, and the conversion + -- verifies that the types are subtype conformant. + + -- We apply the same conversion in the case one of the operands is a + -- private subtype of the type of the other. + + -- Why the Expander_Active test here ??? + + if Expander_Active + and then + (Ekind_In (T, E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) + or else Is_Private_Type (T)) + then + if Etype (L) /= T then + Rewrite (L, + Make_Unchecked_Type_Conversion (Sloc (L), + Subtype_Mark => New_Occurrence_Of (T, Sloc (L)), + Expression => Relocate_Node (L))); + Analyze_And_Resolve (L, T); + end if; + + if (Etype (R)) /= T then + Rewrite (R, + Make_Unchecked_Type_Conversion (Sloc (R), + Subtype_Mark => New_Occurrence_Of (Etype (L), Sloc (R)), + Expression => Relocate_Node (R))); + Analyze_And_Resolve (R, T); + end if; + end if; + end if; + end Resolve_Equality_Op; + + ---------------------------------- + -- Resolve_Explicit_Dereference -- + ---------------------------------- + + procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + New_N : Node_Id; + P : constant Node_Id := Prefix (N); + I : Interp_Index; + It : Interp; + + begin + Check_Fully_Declared_Prefix (Typ, P); + + if Is_Overloaded (P) then + + -- Use the context type to select the prefix that has the correct + -- designated type. + + Get_First_Interp (P, I, It); + while Present (It.Typ) loop + exit when Is_Access_Type (It.Typ) + and then Covers (Typ, Designated_Type (It.Typ)); + Get_Next_Interp (I, It); + end loop; + + if Present (It.Typ) then + Resolve (P, It.Typ); + else + -- If no interpretation covers the designated type of the prefix, + -- this is the pathological case where not all implementations of + -- the prefix allow the interpretation of the node as a call. Now + -- that the expected type is known, Remove other interpretations + -- from prefix, rewrite it as a call, and resolve again, so that + -- the proper call node is generated. + + Get_First_Interp (P, I, It); + while Present (It.Typ) loop + if Ekind (It.Typ) /= E_Access_Subprogram_Type then + Remove_Interp (I); + end if; + + Get_Next_Interp (I, It); + end loop; + + New_N := + Make_Function_Call (Loc, + Name => + Make_Explicit_Dereference (Loc, + Prefix => P), + Parameter_Associations => New_List); + + Save_Interps (N, New_N); + Rewrite (N, New_N); + Analyze_And_Resolve (N, Typ); + return; + end if; + + Set_Etype (N, Designated_Type (It.Typ)); + + else + Resolve (P); + end if; + + if Is_Access_Type (Etype (P)) then + Apply_Access_Check (N); + end if; + + -- If the designated type is a packed unconstrained array type, and the + -- explicit dereference is not in the context of an attribute reference, + -- then we must compute and set the actual subtype, since it is needed + -- by Gigi. The reason we exclude the attribute case is that this is + -- handled fine by Gigi, and in fact we use such attributes to build the + -- actual subtype. We also exclude generated code (which builds actual + -- subtypes directly if they are needed). + + if Is_Array_Type (Etype (N)) + and then Is_Packed (Etype (N)) + and then not Is_Constrained (Etype (N)) + and then Nkind (Parent (N)) /= N_Attribute_Reference + and then Comes_From_Source (N) + then + Set_Etype (N, Get_Actual_Subtype (N)); + end if; + + -- Note: No Eval processing is required for an explicit dereference, + -- because such a name can never be static. + + end Resolve_Explicit_Dereference; + + ------------------------------------- + -- Resolve_Expression_With_Actions -- + ------------------------------------- + + procedure Resolve_Expression_With_Actions (N : Node_Id; Typ : Entity_Id) is + begin + Set_Etype (N, Typ); + end Resolve_Expression_With_Actions; + + ------------------------------- + -- Resolve_Indexed_Component -- + ------------------------------- + + procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id) is + Name : constant Node_Id := Prefix (N); + Expr : Node_Id; + Array_Type : Entity_Id := Empty; -- to prevent junk warning + Index : Node_Id; + + begin + if Is_Overloaded (Name) then + + -- Use the context type to select the prefix that yields the correct + -- component type. + + declare + I : Interp_Index; + It : Interp; + I1 : Interp_Index := 0; + P : constant Node_Id := Prefix (N); + Found : Boolean := False; + + begin + Get_First_Interp (P, I, It); + while Present (It.Typ) loop + if (Is_Array_Type (It.Typ) + and then Covers (Typ, Component_Type (It.Typ))) + or else (Is_Access_Type (It.Typ) + and then Is_Array_Type (Designated_Type (It.Typ)) + and then Covers + (Typ, Component_Type (Designated_Type (It.Typ)))) + then + if Found then + It := Disambiguate (P, I1, I, Any_Type); + + if It = No_Interp then + Error_Msg_N ("ambiguous prefix for indexing", N); + Set_Etype (N, Typ); + return; + + else + Found := True; + Array_Type := It.Typ; + I1 := I; + end if; + + else + Found := True; + Array_Type := It.Typ; + I1 := I; + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + end; + + else + Array_Type := Etype (Name); + end if; + + Resolve (Name, Array_Type); + Array_Type := Get_Actual_Subtype_If_Available (Name); + + -- If prefix is access type, dereference to get real array type. + -- Note: we do not apply an access check because the expander always + -- introduces an explicit dereference, and the check will happen there. + + if Is_Access_Type (Array_Type) then + Array_Type := Designated_Type (Array_Type); + end if; + + -- If name was overloaded, set component type correctly now + -- If a misplaced call to an entry family (which has no index types) + -- return. Error will be diagnosed from calling context. + + if Is_Array_Type (Array_Type) then + Set_Etype (N, Component_Type (Array_Type)); + else + return; + end if; + + Index := First_Index (Array_Type); + Expr := First (Expressions (N)); + + -- The prefix may have resolved to a string literal, in which case its + -- etype has a special representation. This is only possible currently + -- if the prefix is a static concatenation, written in functional + -- notation. + + if Ekind (Array_Type) = E_String_Literal_Subtype then + Resolve (Expr, Standard_Positive); + + else + while Present (Index) and Present (Expr) loop + Resolve (Expr, Etype (Index)); + Check_Unset_Reference (Expr); + + if Is_Scalar_Type (Etype (Expr)) then + Apply_Scalar_Range_Check (Expr, Etype (Index)); + else + Apply_Range_Check (Expr, Get_Actual_Subtype (Index)); + end if; + + Next_Index (Index); + Next (Expr); + end loop; + end if; + + -- Do not generate the warning on suspicious index if we are analyzing + -- package Ada.Tags; otherwise we will report the warning with the + -- Prims_Ptr field of the dispatch table. + + if Scope (Etype (Prefix (N))) = Standard_Standard + or else not + Is_RTU (Cunit_Entity (Get_Source_Unit (Etype (Prefix (N)))), + Ada_Tags) + then + Warn_On_Suspicious_Index (Name, First (Expressions (N))); + Eval_Indexed_Component (N); + end if; + + -- If the array type is atomic, and is packed, and we are in a left side + -- context, then this is worth a warning, since we have a situation + -- where the access to the component may cause extra read/writes of + -- the atomic array object, which could be considered unexpected. + + if Nkind (N) = N_Indexed_Component + and then (Is_Atomic (Array_Type) + or else (Is_Entity_Name (Prefix (N)) + and then Is_Atomic (Entity (Prefix (N))))) + and then Is_Bit_Packed_Array (Array_Type) + and then Is_LHS (N) + then + Error_Msg_N ("?assignment to component of packed atomic array", + Prefix (N)); + Error_Msg_N ("?\may cause unexpected accesses to atomic object", + Prefix (N)); + end if; + end Resolve_Indexed_Component; + + ----------------------------- + -- Resolve_Integer_Literal -- + ----------------------------- + + procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id) is + begin + Set_Etype (N, Typ); + Eval_Integer_Literal (N); + end Resolve_Integer_Literal; + + -------------------------------- + -- Resolve_Intrinsic_Operator -- + -------------------------------- + + procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is + Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); + Op : Entity_Id; + Orig_Op : constant Entity_Id := Entity (N); + Arg1 : Node_Id; + Arg2 : Node_Id; + + begin + -- We must preserve the original entity in a generic setting, so that + -- the legality of the operation can be verified in an instance. + + if not Expander_Active then + return; + end if; + + Op := Entity (N); + while Scope (Op) /= Standard_Standard loop + Op := Homonym (Op); + pragma Assert (Present (Op)); + end loop; + + Set_Entity (N, Op); + Set_Is_Overloaded (N, False); + + -- If the operand type is private, rewrite with suitable conversions on + -- the operands and the result, to expose the proper underlying numeric + -- type. + + if Is_Private_Type (Typ) then + Arg1 := Unchecked_Convert_To (Btyp, Left_Opnd (N)); + + if Nkind (N) = N_Op_Expon then + Arg2 := Unchecked_Convert_To (Standard_Integer, Right_Opnd (N)); + else + Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N)); + end if; + + if Nkind (Arg1) = N_Type_Conversion then + Save_Interps (Left_Opnd (N), Expression (Arg1)); + end if; + + if Nkind (Arg2) = N_Type_Conversion then + Save_Interps (Right_Opnd (N), Expression (Arg2)); + end if; + + Set_Left_Opnd (N, Arg1); + Set_Right_Opnd (N, Arg2); + + Set_Etype (N, Btyp); + Rewrite (N, Unchecked_Convert_To (Typ, N)); + Resolve (N, Typ); + + elsif Typ /= Etype (Left_Opnd (N)) + or else Typ /= Etype (Right_Opnd (N)) + then + -- Add explicit conversion where needed, and save interpretations in + -- case operands are overloaded. If the context is a VMS operation, + -- assert that the conversion is legal (the operands have the proper + -- types to select the VMS intrinsic). Note that in rare cases the + -- VMS operators may be visible, but the default System is being used + -- and Address is a private type. + + Arg1 := Convert_To (Typ, Left_Opnd (N)); + Arg2 := Convert_To (Typ, Right_Opnd (N)); + + if Nkind (Arg1) = N_Type_Conversion then + Save_Interps (Left_Opnd (N), Expression (Arg1)); + + if Is_VMS_Operator (Orig_Op) then + Set_Conversion_OK (Arg1); + end if; + else + Save_Interps (Left_Opnd (N), Arg1); + end if; + + if Nkind (Arg2) = N_Type_Conversion then + Save_Interps (Right_Opnd (N), Expression (Arg2)); + + if Is_VMS_Operator (Orig_Op) then + Set_Conversion_OK (Arg2); + end if; + else + Save_Interps (Right_Opnd (N), Arg2); + end if; + + Rewrite (Left_Opnd (N), Arg1); + Rewrite (Right_Opnd (N), Arg2); + Analyze (Arg1); + Analyze (Arg2); + Resolve_Arithmetic_Op (N, Typ); + + else + Resolve_Arithmetic_Op (N, Typ); + end if; + end Resolve_Intrinsic_Operator; + + -------------------------------------- + -- Resolve_Intrinsic_Unary_Operator -- + -------------------------------------- + + procedure Resolve_Intrinsic_Unary_Operator + (N : Node_Id; + Typ : Entity_Id) + is + Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); + Op : Entity_Id; + Arg2 : Node_Id; + + begin + Op := Entity (N); + while Scope (Op) /= Standard_Standard loop + Op := Homonym (Op); + pragma Assert (Present (Op)); + end loop; + + Set_Entity (N, Op); + + if Is_Private_Type (Typ) then + Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N)); + Save_Interps (Right_Opnd (N), Expression (Arg2)); + + Set_Right_Opnd (N, Arg2); + + Set_Etype (N, Btyp); + Rewrite (N, Unchecked_Convert_To (Typ, N)); + Resolve (N, Typ); + + else + Resolve_Unary_Op (N, Typ); + end if; + end Resolve_Intrinsic_Unary_Operator; + + ------------------------ + -- Resolve_Logical_Op -- + ------------------------ + + procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is + B_Typ : Entity_Id; + + begin + Check_No_Direct_Boolean_Operators (N); + + -- Predefined operations on scalar types yield the base type. On the + -- other hand, logical operations on arrays yield the type of the + -- arguments (and the context). + + if Is_Array_Type (Typ) then + B_Typ := Typ; + else + B_Typ := Base_Type (Typ); + end if; + + -- OK if this is a VMS-specific intrinsic operation + + if Is_VMS_Operator (Entity (N)) then + null; + + -- The following test is required because the operands of the operation + -- may be literals, in which case the resulting type appears to be + -- compatible with a signed integer type, when in fact it is compatible + -- only with modular types. If the context itself is universal, the + -- operation is illegal. + + elsif not Valid_Boolean_Arg (Typ) then + Error_Msg_N ("invalid context for logical operation", N); + Set_Etype (N, Any_Type); + return; + + elsif Typ = Any_Modular then + Error_Msg_N + ("no modular type available in this context", N); + Set_Etype (N, Any_Type); + return; + elsif Is_Modular_Integer_Type (Typ) + and then Etype (Left_Opnd (N)) = Universal_Integer + and then Etype (Right_Opnd (N)) = Universal_Integer + then + Check_For_Visible_Operator (N, B_Typ); + end if; + + Resolve (Left_Opnd (N), B_Typ); + Resolve (Right_Opnd (N), B_Typ); + + Check_Unset_Reference (Left_Opnd (N)); + Check_Unset_Reference (Right_Opnd (N)); + + Set_Etype (N, B_Typ); + Generate_Operator_Reference (N, B_Typ); + Eval_Logical_Op (N); + end Resolve_Logical_Op; + + --------------------------- + -- Resolve_Membership_Op -- + --------------------------- + + -- The context can only be a boolean type, and does not determine + -- the arguments. Arguments should be unambiguous, but the preference + -- rule for universal types applies. + + procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is + pragma Warnings (Off, Typ); + + L : constant Node_Id := Left_Opnd (N); + R : constant Node_Id := Right_Opnd (N); + T : Entity_Id; + + procedure Resolve_Set_Membership; + -- Analysis has determined a unique type for the left operand. + -- Use it to resolve the disjuncts. + + ---------------------------- + -- Resolve_Set_Membership -- + ---------------------------- + + procedure Resolve_Set_Membership is + Alt : Node_Id; + + begin + Resolve (L, Etype (L)); + + Alt := First (Alternatives (N)); + while Present (Alt) loop + + -- Alternative is an expression, a range + -- or a subtype mark. + + if not Is_Entity_Name (Alt) + or else not Is_Type (Entity (Alt)) + then + Resolve (Alt, Etype (L)); + end if; + + Next (Alt); + end loop; + end Resolve_Set_Membership; + + -- Start of processing for Resolve_Membership_Op + + begin + if L = Error or else R = Error then + return; + end if; + + if Present (Alternatives (N)) then + Resolve_Set_Membership; + return; + + elsif not Is_Overloaded (R) + and then + (Etype (R) = Universal_Integer or else + Etype (R) = Universal_Real) + and then Is_Overloaded (L) + then + T := Etype (R); + + -- Ada 2005 (AI-251): Support the following case: + + -- type I is interface; + -- type T is tagged ... + + -- function Test (O : I'Class) is + -- begin + -- return O in T'Class. + -- end Test; + + -- In this case we have nothing else to do. The membership test will be + -- done at run time. + + elsif Ada_Version >= Ada_2005 + and then Is_Class_Wide_Type (Etype (L)) + and then Is_Interface (Etype (L)) + and then Is_Class_Wide_Type (Etype (R)) + and then not Is_Interface (Etype (R)) + then + return; + + else + T := Intersect_Types (L, R); + end if; + + -- If mixed-mode operations are present and operands are all literal, + -- the only interpretation involves Duration, which is probably not + -- the intention of the programmer. + + if T = Any_Fixed then + T := Unique_Fixed_Point_Type (N); + + if T = Any_Type then + return; + end if; + end if; + + Resolve (L, T); + Check_Unset_Reference (L); + + if Nkind (R) = N_Range + and then not Is_Scalar_Type (T) + then + Error_Msg_N ("scalar type required for range", R); + end if; + + if Is_Entity_Name (R) then + Freeze_Expression (R); + else + Resolve (R, T); + Check_Unset_Reference (R); + end if; + + Eval_Membership_Op (N); + end Resolve_Membership_Op; + + ------------------ + -- Resolve_Null -- + ------------------ + + procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + + begin + -- Handle restriction against anonymous null access values This + -- restriction can be turned off using -gnatdj. + + -- Ada 2005 (AI-231): Remove restriction + + if Ada_Version < Ada_2005 + and then not Debug_Flag_J + and then Ekind (Typ) = E_Anonymous_Access_Type + and then Comes_From_Source (N) + then + -- In the common case of a call which uses an explicitly null value + -- for an access parameter, give specialized error message. + + if Nkind_In (Parent (N), N_Procedure_Call_Statement, + N_Function_Call) + then + Error_Msg_N + ("null is not allowed as argument for an access parameter", N); + + -- Standard message for all other cases (are there any?) + + else + Error_Msg_N + ("null cannot be of an anonymous access type", N); + end if; + end if; + + -- Ada 2005 (AI-231): Generate the null-excluding check in case of + -- assignment to a null-excluding object + + if Ada_Version >= Ada_2005 + and then Can_Never_Be_Null (Typ) + and then Nkind (Parent (N)) = N_Assignment_Statement + then + if not Inside_Init_Proc then + Insert_Action + (Compile_Time_Constraint_Error (N, + "(Ada 2005) null not allowed in null-excluding objects?"), + Make_Raise_Constraint_Error (Loc, + Reason => CE_Access_Check_Failed)); + else + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Reason => CE_Access_Check_Failed)); + end if; + end if; + + -- In a distributed context, null for a remote access to subprogram may + -- need to be replaced with a special record aggregate. In this case, + -- return after having done the transformation. + + if (Ekind (Typ) = E_Record_Type + or else Is_Remote_Access_To_Subprogram_Type (Typ)) + and then Remote_AST_Null_Value (N, Typ) + then + return; + end if; + + -- The null literal takes its type from the context + + Set_Etype (N, Typ); + end Resolve_Null; + + ----------------------- + -- Resolve_Op_Concat -- + ----------------------- + + procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id) is + + -- We wish to avoid deep recursion, because concatenations are often + -- deeply nested, as in A&B&...&Z. Therefore, we walk down the left + -- operands nonrecursively until we find something that is not a simple + -- concatenation (A in this case). We resolve that, and then walk back + -- up the tree following Parent pointers, calling Resolve_Op_Concat_Rest + -- to do the rest of the work at each level. The Parent pointers allow + -- us to avoid recursion, and thus avoid running out of memory. See also + -- Sem_Ch4.Analyze_Concatenation, where a similar approach is used. + + NN : Node_Id := N; + Op1 : Node_Id; + + begin + -- The following code is equivalent to: + + -- Resolve_Op_Concat_First (NN, Typ); + -- Resolve_Op_Concat_Arg (N, ...); + -- Resolve_Op_Concat_Rest (N, Typ); + + -- where the Resolve_Op_Concat_Arg call recurses back here if the left + -- operand is a concatenation. + + -- Walk down left operands + + loop + Resolve_Op_Concat_First (NN, Typ); + Op1 := Left_Opnd (NN); + exit when not (Nkind (Op1) = N_Op_Concat + and then not Is_Array_Type (Component_Type (Typ)) + and then Entity (Op1) = Entity (NN)); + NN := Op1; + end loop; + + -- Now (given the above example) NN is A&B and Op1 is A + + -- First resolve Op1 ... + + Resolve_Op_Concat_Arg (NN, Op1, Typ, Is_Component_Left_Opnd (NN)); + + -- ... then walk NN back up until we reach N (where we started), calling + -- Resolve_Op_Concat_Rest along the way. + + loop + Resolve_Op_Concat_Rest (NN, Typ); + exit when NN = N; + NN := Parent (NN); + end loop; + end Resolve_Op_Concat; + + --------------------------- + -- Resolve_Op_Concat_Arg -- + --------------------------- + + procedure Resolve_Op_Concat_Arg + (N : Node_Id; + Arg : Node_Id; + Typ : Entity_Id; + Is_Comp : Boolean) + is + Btyp : constant Entity_Id := Base_Type (Typ); + + begin + if In_Instance then + if Is_Comp + or else (not Is_Overloaded (Arg) + and then Etype (Arg) /= Any_Composite + and then Covers (Component_Type (Typ), Etype (Arg))) + then + Resolve (Arg, Component_Type (Typ)); + else + Resolve (Arg, Btyp); + end if; + + elsif Has_Compatible_Type (Arg, Component_Type (Typ)) then + if Nkind (Arg) = N_Aggregate + and then Is_Composite_Type (Component_Type (Typ)) + then + if Is_Private_Type (Component_Type (Typ)) then + Resolve (Arg, Btyp); + else + Error_Msg_N ("ambiguous aggregate must be qualified", Arg); + Set_Etype (Arg, Any_Type); + end if; + + else + if Is_Overloaded (Arg) + and then Has_Compatible_Type (Arg, Typ) + and then Etype (Arg) /= Any_Type + then + declare + I : Interp_Index; + It : Interp; + Func : Entity_Id; + + begin + Get_First_Interp (Arg, I, It); + Func := It.Nam; + Get_Next_Interp (I, It); + + -- Special-case the error message when the overloading is + -- caused by a function that yields an array and can be + -- called without parameters. + + if It.Nam = Func then + Error_Msg_Sloc := Sloc (Func); + Error_Msg_N ("ambiguous call to function#", Arg); + Error_Msg_NE + ("\\interpretation as call yields&", Arg, Typ); + Error_Msg_NE + ("\\interpretation as indexing of call yields&", + Arg, Component_Type (Typ)); + + else + Error_Msg_N + ("ambiguous operand for concatenation!", Arg); + Get_First_Interp (Arg, I, It); + while Present (It.Nam) loop + Error_Msg_Sloc := Sloc (It.Nam); + + if Base_Type (It.Typ) = Base_Type (Typ) + or else Base_Type (It.Typ) = + Base_Type (Component_Type (Typ)) + then + Error_Msg_N -- CODEFIX + ("\\possible interpretation#", Arg); + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + end; + end if; + + Resolve (Arg, Component_Type (Typ)); + + if Nkind (Arg) = N_String_Literal then + Set_Etype (Arg, Component_Type (Typ)); + end if; + + if Arg = Left_Opnd (N) then + Set_Is_Component_Left_Opnd (N); + else + Set_Is_Component_Right_Opnd (N); + end if; + end if; + + else + Resolve (Arg, Btyp); + end if; + + Check_Unset_Reference (Arg); + end Resolve_Op_Concat_Arg; + + ----------------------------- + -- Resolve_Op_Concat_First -- + ----------------------------- + + procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id) is + Btyp : constant Entity_Id := Base_Type (Typ); + Op1 : constant Node_Id := Left_Opnd (N); + Op2 : constant Node_Id := Right_Opnd (N); + + begin + -- The parser folds an enormous sequence of concatenations of string + -- literals into "" & "...", where the Is_Folded_In_Parser flag is set + -- in the right operand. If the expression resolves to a predefined "&" + -- operator, all is well. Otherwise, the parser's folding is wrong, so + -- we give an error. See P_Simple_Expression in Par.Ch4. + + if Nkind (Op2) = N_String_Literal + and then Is_Folded_In_Parser (Op2) + and then Ekind (Entity (N)) = E_Function + then + pragma Assert (Nkind (Op1) = N_String_Literal -- should be "" + and then String_Length (Strval (Op1)) = 0); + Error_Msg_N ("too many user-defined concatenations", N); + return; + end if; + + Set_Etype (N, Btyp); + + if Is_Limited_Composite (Btyp) then + Error_Msg_N ("concatenation not available for limited array", N); + Explain_Limited_Type (Btyp, N); + end if; + end Resolve_Op_Concat_First; + + ---------------------------- + -- Resolve_Op_Concat_Rest -- + ---------------------------- + + procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id) is + Op1 : constant Node_Id := Left_Opnd (N); + Op2 : constant Node_Id := Right_Opnd (N); + + begin + Resolve_Op_Concat_Arg (N, Op2, Typ, Is_Component_Right_Opnd (N)); + + Generate_Operator_Reference (N, Typ); + + if Is_String_Type (Typ) then + Eval_Concatenation (N); + end if; + + -- If this is not a static concatenation, but the result is a string + -- type (and not an array of strings) ensure that static string operands + -- have their subtypes properly constructed. + + if Nkind (N) /= N_String_Literal + and then Is_Character_Type (Component_Type (Typ)) + then + Set_String_Literal_Subtype (Op1, Typ); + Set_String_Literal_Subtype (Op2, Typ); + end if; + end Resolve_Op_Concat_Rest; + + ---------------------- + -- Resolve_Op_Expon -- + ---------------------- + + procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id) is + B_Typ : constant Entity_Id := Base_Type (Typ); + + begin + -- Catch attempts to do fixed-point exponentiation with universal + -- operands, which is a case where the illegality is not caught during + -- normal operator analysis. + + if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then + Error_Msg_N ("exponentiation not available for fixed point", N); + return; + end if; + + if Comes_From_Source (N) + and then Ekind (Entity (N)) = E_Function + and then Is_Imported (Entity (N)) + and then Is_Intrinsic_Subprogram (Entity (N)) + then + Resolve_Intrinsic_Operator (N, Typ); + return; + end if; + + if Etype (Left_Opnd (N)) = Universal_Integer + or else Etype (Left_Opnd (N)) = Universal_Real + then + Check_For_Visible_Operator (N, B_Typ); + end if; + + -- We do the resolution using the base type, because intermediate values + -- in expressions always are of the base type, not a subtype of it. + + Resolve (Left_Opnd (N), B_Typ); + Resolve (Right_Opnd (N), Standard_Integer); + + Check_Unset_Reference (Left_Opnd (N)); + Check_Unset_Reference (Right_Opnd (N)); + + Set_Etype (N, B_Typ); + Generate_Operator_Reference (N, B_Typ); + Eval_Op_Expon (N); + + -- Set overflow checking bit. Much cleverer code needed here eventually + -- and perhaps the Resolve routines should be separated for the various + -- arithmetic operations, since they will need different processing. ??? + + if Nkind (N) in N_Op then + if not Overflow_Checks_Suppressed (Etype (N)) then + Enable_Overflow_Check (N); + end if; + end if; + end Resolve_Op_Expon; + + -------------------- + -- Resolve_Op_Not -- + -------------------- + + procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id) is + B_Typ : Entity_Id; + + function Parent_Is_Boolean return Boolean; + -- This function determines if the parent node is a boolean operator + -- or operation (comparison op, membership test, or short circuit form) + -- and the not in question is the left operand of this operation. + -- Note that if the not is in parens, then false is returned. + + ----------------------- + -- Parent_Is_Boolean -- + ----------------------- + + function Parent_Is_Boolean return Boolean is + begin + if Paren_Count (N) /= 0 then + return False; + + else + case Nkind (Parent (N)) is + when N_Op_And | + N_Op_Eq | + N_Op_Ge | + N_Op_Gt | + N_Op_Le | + N_Op_Lt | + N_Op_Ne | + N_Op_Or | + N_Op_Xor | + N_In | + N_Not_In | + N_And_Then | + N_Or_Else => + + return Left_Opnd (Parent (N)) = N; + + when others => + return False; + end case; + end if; + end Parent_Is_Boolean; + + -- Start of processing for Resolve_Op_Not + + begin + -- Predefined operations on scalar types yield the base type. On the + -- other hand, logical operations on arrays yield the type of the + -- arguments (and the context). + + if Is_Array_Type (Typ) then + B_Typ := Typ; + else + B_Typ := Base_Type (Typ); + end if; + + if Is_VMS_Operator (Entity (N)) then + null; + + -- Straightforward case of incorrect arguments + + elsif not Valid_Boolean_Arg (Typ) then + Error_Msg_N ("invalid operand type for operator&", N); + Set_Etype (N, Any_Type); + return; + + -- Special case of probable missing parens + + elsif Typ = Universal_Integer or else Typ = Any_Modular then + if Parent_Is_Boolean then + Error_Msg_N + ("operand of not must be enclosed in parentheses", + Right_Opnd (N)); + else + Error_Msg_N + ("no modular type available in this context", N); + end if; + + Set_Etype (N, Any_Type); + return; + + -- OK resolution of not + + else + -- Warn if non-boolean types involved. This is a case like not a < b + -- where a and b are modular, where we will get (not a) < b and most + -- likely not (a < b) was intended. + + if Warn_On_Questionable_Missing_Parens + and then not Is_Boolean_Type (Typ) + and then Parent_Is_Boolean + then + Error_Msg_N ("?not expression should be parenthesized here!", N); + end if; + + -- Warn on double negation if checking redundant constructs + + if Warn_On_Redundant_Constructs + and then Comes_From_Source (N) + and then Comes_From_Source (Right_Opnd (N)) + and then Root_Type (Typ) = Standard_Boolean + and then Nkind (Right_Opnd (N)) = N_Op_Not + then + Error_Msg_N ("redundant double negation?", N); + end if; + + -- Complete resolution and evaluation of NOT + + Resolve (Right_Opnd (N), B_Typ); + Check_Unset_Reference (Right_Opnd (N)); + Set_Etype (N, B_Typ); + Generate_Operator_Reference (N, B_Typ); + Eval_Op_Not (N); + end if; + end Resolve_Op_Not; + + ----------------------------- + -- Resolve_Operator_Symbol -- + ----------------------------- + + -- Nothing to be done, all resolved already + + procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id) is + pragma Warnings (Off, N); + pragma Warnings (Off, Typ); + + begin + null; + end Resolve_Operator_Symbol; + + ---------------------------------- + -- Resolve_Qualified_Expression -- + ---------------------------------- + + procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id) is + pragma Warnings (Off, Typ); + + Target_Typ : constant Entity_Id := Entity (Subtype_Mark (N)); + Expr : constant Node_Id := Expression (N); + + begin + Resolve (Expr, Target_Typ); + + -- A qualified expression requires an exact match of the type, + -- class-wide matching is not allowed. However, if the qualifying + -- type is specific and the expression has a class-wide type, it + -- may still be okay, since it can be the result of the expansion + -- of a call to a dispatching function, so we also have to check + -- class-wideness of the type of the expression's original node. + + if (Is_Class_Wide_Type (Target_Typ) + or else + (Is_Class_Wide_Type (Etype (Expr)) + and then Is_Class_Wide_Type (Etype (Original_Node (Expr))))) + and then Base_Type (Etype (Expr)) /= Base_Type (Target_Typ) + then + Wrong_Type (Expr, Target_Typ); + end if; + + -- If the target type is unconstrained, then we reset the type of the + -- result from the type of the expression. For other cases, the actual + -- subtype of the expression is the target type. + + if Is_Composite_Type (Target_Typ) + and then not Is_Constrained (Target_Typ) + then + Set_Etype (N, Etype (Expr)); + end if; + + Eval_Qualified_Expression (N); + end Resolve_Qualified_Expression; + + ----------------------------------- + -- Resolve_Quantified_Expression -- + ----------------------------------- + + procedure Resolve_Quantified_Expression (N : Node_Id; Typ : Entity_Id) is + begin + -- The loop structure is already resolved during its analysis, only the + -- resolution of the condition needs to be done. Expansion is disabled + -- so that checks and other generated code are inserted in the tree + -- after expression has been rewritten as a loop. + + Expander_Mode_Save_And_Set (False); + Resolve (Condition (N), Typ); + Expander_Mode_Restore; + end Resolve_Quantified_Expression; + + ------------------- + -- Resolve_Range -- + ------------------- + + procedure Resolve_Range (N : Node_Id; Typ : Entity_Id) is + L : constant Node_Id := Low_Bound (N); + H : constant Node_Id := High_Bound (N); + + function First_Last_Ref return Boolean; + -- Returns True if N is of the form X'First .. X'Last where X is the + -- same entity for both attributes. + + -------------------- + -- First_Last_Ref -- + -------------------- + + function First_Last_Ref return Boolean is + Lorig : constant Node_Id := Original_Node (L); + Horig : constant Node_Id := Original_Node (H); + + begin + if Nkind (Lorig) = N_Attribute_Reference + and then Nkind (Horig) = N_Attribute_Reference + and then Attribute_Name (Lorig) = Name_First + and then Attribute_Name (Horig) = Name_Last + then + declare + PL : constant Node_Id := Prefix (Lorig); + PH : constant Node_Id := Prefix (Horig); + begin + if Is_Entity_Name (PL) + and then Is_Entity_Name (PH) + and then Entity (PL) = Entity (PH) + then + return True; + end if; + end; + end if; + + return False; + end First_Last_Ref; + + -- Start of processing for Resolve_Range + + begin + Set_Etype (N, Typ); + Resolve (L, Typ); + Resolve (H, Typ); + + -- Check for inappropriate range on unordered enumeration type + + if Bad_Unordered_Enumeration_Reference (N, Typ) + + -- Exclude X'First .. X'Last if X is the same entity for both + + and then not First_Last_Ref + then + Error_Msg ("subrange of unordered enumeration type?", Sloc (N)); + end if; + + Check_Unset_Reference (L); + Check_Unset_Reference (H); + + -- We have to check the bounds for being within the base range as + -- required for a non-static context. Normally this is automatic and + -- done as part of evaluating expressions, but the N_Range node is an + -- exception, since in GNAT we consider this node to be a subexpression, + -- even though in Ada it is not. The circuit in Sem_Eval could check for + -- this, but that would put the test on the main evaluation path for + -- expressions. + + Check_Non_Static_Context (L); + Check_Non_Static_Context (H); + + -- Check for an ambiguous range over character literals. This will + -- happen with a membership test involving only literals. + + if Typ = Any_Character then + Ambiguous_Character (L); + Set_Etype (N, Any_Type); + return; + end if; + + -- If bounds are static, constant-fold them, so size computations + -- are identical between front-end and back-end. Do not perform this + -- transformation while analyzing generic units, as type information + -- would then be lost when reanalyzing the constant node in the + -- instance. + + if Is_Discrete_Type (Typ) and then Expander_Active then + if Is_OK_Static_Expression (L) then + Fold_Uint (L, Expr_Value (L), Is_Static_Expression (L)); + end if; + + if Is_OK_Static_Expression (H) then + Fold_Uint (H, Expr_Value (H), Is_Static_Expression (H)); + end if; + end if; + end Resolve_Range; + + -------------------------- + -- Resolve_Real_Literal -- + -------------------------- + + procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id) is + Actual_Typ : constant Entity_Id := Etype (N); + + begin + -- Special processing for fixed-point literals to make sure that the + -- value is an exact multiple of small where this is required. We + -- skip this for the universal real case, and also for generic types. + + if Is_Fixed_Point_Type (Typ) + and then Typ /= Universal_Fixed + and then Typ /= Any_Fixed + and then not Is_Generic_Type (Typ) + then + declare + Val : constant Ureal := Realval (N); + Cintr : constant Ureal := Val / Small_Value (Typ); + Cint : constant Uint := UR_Trunc (Cintr); + Den : constant Uint := Norm_Den (Cintr); + Stat : Boolean; + + begin + -- Case of literal is not an exact multiple of the Small + + if Den /= 1 then + + -- For a source program literal for a decimal fixed-point + -- type, this is statically illegal (RM 4.9(36)). + + if Is_Decimal_Fixed_Point_Type (Typ) + and then Actual_Typ = Universal_Real + and then Comes_From_Source (N) + then + Error_Msg_N ("value has extraneous low order digits", N); + end if; + + -- Generate a warning if literal from source + + if Is_Static_Expression (N) + and then Warn_On_Bad_Fixed_Value + then + Error_Msg_N + ("?static fixed-point value is not a multiple of Small!", + N); + end if; + + -- Replace literal by a value that is the exact representation + -- of a value of the type, i.e. a multiple of the small value, + -- by truncation, since Machine_Rounds is false for all GNAT + -- fixed-point types (RM 4.9(38)). + + Stat := Is_Static_Expression (N); + Rewrite (N, + Make_Real_Literal (Sloc (N), + Realval => Small_Value (Typ) * Cint)); + + Set_Is_Static_Expression (N, Stat); + end if; + + -- In all cases, set the corresponding integer field + + Set_Corresponding_Integer_Value (N, Cint); + end; + end if; + + -- Now replace the actual type by the expected type as usual + + Set_Etype (N, Typ); + Eval_Real_Literal (N); + end Resolve_Real_Literal; + + ----------------------- + -- Resolve_Reference -- + ----------------------- + + procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id) is + P : constant Node_Id := Prefix (N); + + begin + -- Replace general access with specific type + + if Ekind (Etype (N)) = E_Allocator_Type then + Set_Etype (N, Base_Type (Typ)); + end if; + + Resolve (P, Designated_Type (Etype (N))); + + -- If we are taking the reference of a volatile entity, then treat + -- it as a potential modification of this entity. This is much too + -- conservative, but is necessary because remove side effects can + -- result in transformations of normal assignments into reference + -- sequences that otherwise fail to notice the modification. + + if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then + Note_Possible_Modification (P, Sure => False); + end if; + end Resolve_Reference; + + -------------------------------- + -- Resolve_Selected_Component -- + -------------------------------- + + procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id) is + Comp : Entity_Id; + Comp1 : Entity_Id := Empty; -- prevent junk warning + P : constant Node_Id := Prefix (N); + S : constant Node_Id := Selector_Name (N); + T : Entity_Id := Etype (P); + I : Interp_Index; + I1 : Interp_Index := 0; -- prevent junk warning + It : Interp; + It1 : Interp; + Found : Boolean; + + function Init_Component return Boolean; + -- Check whether this is the initialization of a component within an + -- init proc (by assignment or call to another init proc). If true, + -- there is no need for a discriminant check. + + -------------------- + -- Init_Component -- + -------------------- + + function Init_Component return Boolean is + begin + return Inside_Init_Proc + and then Nkind (Prefix (N)) = N_Identifier + and then Chars (Prefix (N)) = Name_uInit + and then Nkind (Parent (Parent (N))) = N_Case_Statement_Alternative; + end Init_Component; + + -- Start of processing for Resolve_Selected_Component + + begin + if Is_Overloaded (P) then + + -- Use the context type to select the prefix that has a selector + -- of the correct name and type. + + Found := False; + Get_First_Interp (P, I, It); + + Search : while Present (It.Typ) loop + if Is_Access_Type (It.Typ) then + T := Designated_Type (It.Typ); + else + T := It.Typ; + end if; + + if Is_Record_Type (T) then + + -- The visible components of a class-wide type are those of + -- the root type. + + if Is_Class_Wide_Type (T) then + T := Etype (T); + end if; + + Comp := First_Entity (T); + while Present (Comp) loop + if Chars (Comp) = Chars (S) + and then Covers (Etype (Comp), Typ) + then + if not Found then + Found := True; + I1 := I; + It1 := It; + Comp1 := Comp; + + else + It := Disambiguate (P, I1, I, Any_Type); + + if It = No_Interp then + Error_Msg_N + ("ambiguous prefix for selected component", N); + Set_Etype (N, Typ); + return; + + else + It1 := It; + + -- There may be an implicit dereference. Retrieve + -- designated record type. + + if Is_Access_Type (It1.Typ) then + T := Designated_Type (It1.Typ); + else + T := It1.Typ; + end if; + + if Scope (Comp1) /= T then + + -- Resolution chooses the new interpretation. + -- Find the component with the right name. + + Comp1 := First_Entity (T); + while Present (Comp1) + and then Chars (Comp1) /= Chars (S) + loop + Comp1 := Next_Entity (Comp1); + end loop; + end if; + + exit Search; + end if; + end if; + end if; + + Comp := Next_Entity (Comp); + end loop; + end if; + + Get_Next_Interp (I, It); + end loop Search; + + Resolve (P, It1.Typ); + Set_Etype (N, Typ); + Set_Entity_With_Style_Check (S, Comp1); + + else + -- Resolve prefix with its type + + Resolve (P, T); + end if; + + -- Generate cross-reference. We needed to wait until full overloading + -- resolution was complete to do this, since otherwise we can't tell if + -- we are an lvalue or not. + + if May_Be_Lvalue (N) then + Generate_Reference (Entity (S), S, 'm'); + else + Generate_Reference (Entity (S), S, 'r'); + end if; + + -- If prefix is an access type, the node will be transformed into an + -- explicit dereference during expansion. The type of the node is the + -- designated type of that of the prefix. + + if Is_Access_Type (Etype (P)) then + T := Designated_Type (Etype (P)); + Check_Fully_Declared_Prefix (T, P); + else + T := Etype (P); + end if; + + if Has_Discriminants (T) + and then Ekind_In (Entity (S), E_Component, E_Discriminant) + and then Present (Original_Record_Component (Entity (S))) + and then Ekind (Original_Record_Component (Entity (S))) = E_Component + and then Present (Discriminant_Checking_Func + (Original_Record_Component (Entity (S)))) + and then not Discriminant_Checks_Suppressed (T) + and then not Init_Component + then + Set_Do_Discriminant_Check (N); + end if; + + if Ekind (Entity (S)) = E_Void then + Error_Msg_N ("premature use of component", S); + end if; + + -- If the prefix is a record conversion, this may be a renamed + -- discriminant whose bounds differ from those of the original + -- one, so we must ensure that a range check is performed. + + if Nkind (P) = N_Type_Conversion + and then Ekind (Entity (S)) = E_Discriminant + and then Is_Discrete_Type (Typ) + then + Set_Etype (N, Base_Type (Typ)); + end if; + + -- Note: No Eval processing is required, because the prefix is of a + -- record type, or protected type, and neither can possibly be static. + + -- If the array type is atomic, and is packed, and we are in a left side + -- context, then this is worth a warning, since we have a situation + -- where the access to the component may cause extra read/writes of + -- the atomic array object, which could be considered unexpected. + + if Nkind (N) = N_Selected_Component + and then (Is_Atomic (T) + or else (Is_Entity_Name (Prefix (N)) + and then Is_Atomic (Entity (Prefix (N))))) + and then Is_Packed (T) + and then Is_LHS (N) + then + Error_Msg_N ("?assignment to component of packed atomic record", + Prefix (N)); + Error_Msg_N ("?\may cause unexpected accesses to atomic object", + Prefix (N)); + end if; + end Resolve_Selected_Component; + + ------------------- + -- Resolve_Shift -- + ------------------- + + procedure Resolve_Shift (N : Node_Id; Typ : Entity_Id) is + B_Typ : constant Entity_Id := Base_Type (Typ); + L : constant Node_Id := Left_Opnd (N); + R : constant Node_Id := Right_Opnd (N); + + begin + -- We do the resolution using the base type, because intermediate values + -- in expressions always are of the base type, not a subtype of it. + + Resolve (L, B_Typ); + Resolve (R, Standard_Natural); + + Check_Unset_Reference (L); + Check_Unset_Reference (R); + + Set_Etype (N, B_Typ); + Generate_Operator_Reference (N, B_Typ); + Eval_Shift (N); + end Resolve_Shift; + + --------------------------- + -- Resolve_Short_Circuit -- + --------------------------- + + procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id) is + B_Typ : constant Entity_Id := Base_Type (Typ); + L : constant Node_Id := Left_Opnd (N); + R : constant Node_Id := Right_Opnd (N); + + begin + Resolve (L, B_Typ); + Resolve (R, B_Typ); + + -- Check for issuing warning for always False assert/check, this happens + -- when assertions are turned off, in which case the pragma Assert/Check + -- was transformed into: + + -- if False and then then ... + + -- and we detect this pattern + + if Warn_On_Assertion_Failure + and then Is_Entity_Name (R) + and then Entity (R) = Standard_False + and then Nkind (Parent (N)) = N_If_Statement + and then Nkind (N) = N_And_Then + and then Is_Entity_Name (L) + and then Entity (L) = Standard_False + then + declare + Orig : constant Node_Id := Original_Node (Parent (N)); + + begin + if Nkind (Orig) = N_Pragma + and then Pragma_Name (Orig) = Name_Assert + then + -- Don't want to warn if original condition is explicit False + + declare + Expr : constant Node_Id := + Original_Node + (Expression + (First (Pragma_Argument_Associations (Orig)))); + begin + if Is_Entity_Name (Expr) + and then Entity (Expr) = Standard_False + then + null; + else + -- Issue warning. We do not want the deletion of the + -- IF/AND-THEN to take this message with it. We achieve + -- this by making sure that the expanded code points to + -- the Sloc of the expression, not the original pragma. + + Error_Msg_N + ("?assertion would fail at run time!", + Expression + (First (Pragma_Argument_Associations (Orig)))); + end if; + end; + + -- Similar processing for Check pragma + + elsif Nkind (Orig) = N_Pragma + and then Pragma_Name (Orig) = Name_Check + then + -- Don't want to warn if original condition is explicit False + + declare + Expr : constant Node_Id := + Original_Node + (Expression + (Next (First + (Pragma_Argument_Associations (Orig))))); + begin + if Is_Entity_Name (Expr) + and then Entity (Expr) = Standard_False + then + null; + else + Error_Msg_N + ("?check would fail at run time!", + Expression + (Last (Pragma_Argument_Associations (Orig)))); + end if; + end; + end if; + end; + end if; + + -- Continue with processing of short circuit + + Check_Unset_Reference (L); + Check_Unset_Reference (R); + + Set_Etype (N, B_Typ); + Eval_Short_Circuit (N); + end Resolve_Short_Circuit; + + ------------------- + -- Resolve_Slice -- + ------------------- + + procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id) is + Name : constant Node_Id := Prefix (N); + Drange : constant Node_Id := Discrete_Range (N); + Array_Type : Entity_Id := Empty; + Index : Node_Id; + + begin + if Is_Overloaded (Name) then + + -- Use the context type to select the prefix that yields the correct + -- array type. + + declare + I : Interp_Index; + I1 : Interp_Index := 0; + It : Interp; + P : constant Node_Id := Prefix (N); + Found : Boolean := False; + + begin + Get_First_Interp (P, I, It); + while Present (It.Typ) loop + if (Is_Array_Type (It.Typ) + and then Covers (Typ, It.Typ)) + or else (Is_Access_Type (It.Typ) + and then Is_Array_Type (Designated_Type (It.Typ)) + and then Covers (Typ, Designated_Type (It.Typ))) + then + if Found then + It := Disambiguate (P, I1, I, Any_Type); + + if It = No_Interp then + Error_Msg_N ("ambiguous prefix for slicing", N); + Set_Etype (N, Typ); + return; + else + Found := True; + Array_Type := It.Typ; + I1 := I; + end if; + else + Found := True; + Array_Type := It.Typ; + I1 := I; + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + end; + + else + Array_Type := Etype (Name); + end if; + + Resolve (Name, Array_Type); + + if Is_Access_Type (Array_Type) then + Apply_Access_Check (N); + Array_Type := Designated_Type (Array_Type); + + -- If the prefix is an access to an unconstrained array, we must use + -- the actual subtype of the object to perform the index checks. The + -- object denoted by the prefix is implicit in the node, so we build + -- an explicit representation for it in order to compute the actual + -- subtype. + + if not Is_Constrained (Array_Type) then + Remove_Side_Effects (Prefix (N)); + + declare + Obj : constant Node_Id := + Make_Explicit_Dereference (Sloc (N), + Prefix => New_Copy_Tree (Prefix (N))); + begin + Set_Etype (Obj, Array_Type); + Set_Parent (Obj, Parent (N)); + Array_Type := Get_Actual_Subtype (Obj); + end; + end if; + + elsif Is_Entity_Name (Name) + or else Nkind (Name) = N_Explicit_Dereference + or else (Nkind (Name) = N_Function_Call + and then not Is_Constrained (Etype (Name))) + then + Array_Type := Get_Actual_Subtype (Name); + + -- If the name is a selected component that depends on discriminants, + -- build an actual subtype for it. This can happen only when the name + -- itself is overloaded; otherwise the actual subtype is created when + -- the selected component is analyzed. + + elsif Nkind (Name) = N_Selected_Component + and then Full_Analysis + and then Depends_On_Discriminant (First_Index (Array_Type)) + then + declare + Act_Decl : constant Node_Id := + Build_Actual_Subtype_Of_Component (Array_Type, Name); + begin + Insert_Action (N, Act_Decl); + Array_Type := Defining_Identifier (Act_Decl); + end; + + -- Maybe this should just be "else", instead of checking for the + -- specific case of slice??? This is needed for the case where + -- the prefix is an Image attribute, which gets expanded to a + -- slice, and so has a constrained subtype which we want to use + -- for the slice range check applied below (the range check won't + -- get done if the unconstrained subtype of the 'Image is used). + + elsif Nkind (Name) = N_Slice then + Array_Type := Etype (Name); + end if; + + -- If name was overloaded, set slice type correctly now + + Set_Etype (N, Array_Type); + + -- If the range is specified by a subtype mark, no resolution is + -- necessary. Else resolve the bounds, and apply needed checks. + + if not Is_Entity_Name (Drange) then + Index := First_Index (Array_Type); + Resolve (Drange, Base_Type (Etype (Index))); + + if Nkind (Drange) = N_Range then + + -- Ensure that side effects in the bounds are properly handled + + Remove_Side_Effects (Low_Bound (Drange), Variable_Ref => True); + Remove_Side_Effects (High_Bound (Drange), Variable_Ref => True); + + -- Do not apply the range check to nodes associated with the + -- frontend expansion of the dispatch table. We first check + -- if Ada.Tags is already loaded to avoid the addition of an + -- undesired dependence on such run-time unit. + + if not Tagged_Type_Expansion + or else not + (RTU_Loaded (Ada_Tags) + and then Nkind (Prefix (N)) = N_Selected_Component + and then Present (Entity (Selector_Name (Prefix (N)))) + and then Entity (Selector_Name (Prefix (N))) = + RTE_Record_Component (RE_Prims_Ptr)) + then + Apply_Range_Check (Drange, Etype (Index)); + end if; + end if; + end if; + + Set_Slice_Subtype (N); + + -- Check bad use of type with predicates + + if Has_Predicates (Etype (Drange)) then + Bad_Predicated_Subtype_Use + ("subtype& has predicate, not allowed in slice", + Drange, Etype (Drange)); + + -- Otherwise here is where we check suspicious indexes + + elsif Nkind (Drange) = N_Range then + Warn_On_Suspicious_Index (Name, Low_Bound (Drange)); + Warn_On_Suspicious_Index (Name, High_Bound (Drange)); + end if; + + Eval_Slice (N); + end Resolve_Slice; + + ---------------------------- + -- Resolve_String_Literal -- + ---------------------------- + + procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id) is + C_Typ : constant Entity_Id := Component_Type (Typ); + R_Typ : constant Entity_Id := Root_Type (C_Typ); + Loc : constant Source_Ptr := Sloc (N); + Str : constant String_Id := Strval (N); + Strlen : constant Nat := String_Length (Str); + Subtype_Id : Entity_Id; + Need_Check : Boolean; + + begin + -- For a string appearing in a concatenation, defer creation of the + -- string_literal_subtype until the end of the resolution of the + -- concatenation, because the literal may be constant-folded away. This + -- is a useful optimization for long concatenation expressions. + + -- If the string is an aggregate built for a single character (which + -- happens in a non-static context) or a is null string to which special + -- checks may apply, we build the subtype. Wide strings must also get a + -- string subtype if they come from a one character aggregate. Strings + -- generated by attributes might be static, but it is often hard to + -- determine whether the enclosing context is static, so we generate + -- subtypes for them as well, thus losing some rarer optimizations ??? + -- Same for strings that come from a static conversion. + + Need_Check := + (Strlen = 0 and then Typ /= Standard_String) + or else Nkind (Parent (N)) /= N_Op_Concat + or else (N /= Left_Opnd (Parent (N)) + and then N /= Right_Opnd (Parent (N))) + or else ((Typ = Standard_Wide_String + or else Typ = Standard_Wide_Wide_String) + and then Nkind (Original_Node (N)) /= N_String_Literal); + + -- If the resolving type is itself a string literal subtype, we can just + -- reuse it, since there is no point in creating another. + + if Ekind (Typ) = E_String_Literal_Subtype then + Subtype_Id := Typ; + + elsif Nkind (Parent (N)) = N_Op_Concat + and then not Need_Check + and then not Nkind_In (Original_Node (N), N_Character_Literal, + N_Attribute_Reference, + N_Qualified_Expression, + N_Type_Conversion) + then + Subtype_Id := Typ; + + -- Otherwise we must create a string literal subtype. Note that the + -- whole idea of string literal subtypes is simply to avoid the need + -- for building a full fledged array subtype for each literal. + + else + Set_String_Literal_Subtype (N, Typ); + Subtype_Id := Etype (N); + end if; + + if Nkind (Parent (N)) /= N_Op_Concat + or else Need_Check + then + Set_Etype (N, Subtype_Id); + Eval_String_Literal (N); + end if; + + if Is_Limited_Composite (Typ) + or else Is_Private_Composite (Typ) + then + Error_Msg_N ("string literal not available for private array", N); + Set_Etype (N, Any_Type); + return; + end if; + + -- The validity of a null string has been checked in the call to + -- Eval_String_Literal. + + if Strlen = 0 then + return; + + -- Always accept string literal with component type Any_Character, which + -- occurs in error situations and in comparisons of literals, both of + -- which should accept all literals. + + elsif R_Typ = Any_Character then + return; + + -- If the type is bit-packed, then we always transform the string + -- literal into a full fledged aggregate. + + elsif Is_Bit_Packed_Array (Typ) then + null; + + -- Deal with cases of Wide_Wide_String, Wide_String, and String + + else + -- For Standard.Wide_Wide_String, or any other type whose component + -- type is Standard.Wide_Wide_Character, we know that all the + -- characters in the string must be acceptable, since the parser + -- accepted the characters as valid character literals. + + if R_Typ = Standard_Wide_Wide_Character then + null; + + -- For the case of Standard.String, or any other type whose component + -- type is Standard.Character, we must make sure that there are no + -- wide characters in the string, i.e. that it is entirely composed + -- of characters in range of type Character. + + -- If the string literal is the result of a static concatenation, the + -- test has already been performed on the components, and need not be + -- repeated. + + elsif R_Typ = Standard_Character + and then Nkind (Original_Node (N)) /= N_Op_Concat + then + for J in 1 .. Strlen loop + if not In_Character_Range (Get_String_Char (Str, J)) then + + -- If we are out of range, post error. This is one of the + -- very few places that we place the flag in the middle of + -- a token, right under the offending wide character. Not + -- quite clear if this is right wrt wide character encoding + -- sequences, but it's only an error message! + + Error_Msg + ("literal out of range of type Standard.Character", + Source_Ptr (Int (Loc) + J)); + return; + end if; + end loop; + + -- For the case of Standard.Wide_String, or any other type whose + -- component type is Standard.Wide_Character, we must make sure that + -- there are no wide characters in the string, i.e. that it is + -- entirely composed of characters in range of type Wide_Character. + + -- If the string literal is the result of a static concatenation, + -- the test has already been performed on the components, and need + -- not be repeated. + + elsif R_Typ = Standard_Wide_Character + and then Nkind (Original_Node (N)) /= N_Op_Concat + then + for J in 1 .. Strlen loop + if not In_Wide_Character_Range (Get_String_Char (Str, J)) then + + -- If we are out of range, post error. This is one of the + -- very few places that we place the flag in the middle of + -- a token, right under the offending wide character. + + -- This is not quite right, because characters in general + -- will take more than one character position ??? + + Error_Msg + ("literal out of range of type Standard.Wide_Character", + Source_Ptr (Int (Loc) + J)); + return; + end if; + end loop; + + -- If the root type is not a standard character, then we will convert + -- the string into an aggregate and will let the aggregate code do + -- the checking. Standard Wide_Wide_Character is also OK here. + + else + null; + end if; + + -- See if the component type of the array corresponding to the string + -- has compile time known bounds. If yes we can directly check + -- whether the evaluation of the string will raise constraint error. + -- Otherwise we need to transform the string literal into the + -- corresponding character aggregate and let the aggregate + -- code do the checking. + + if Is_Standard_Character_Type (R_Typ) then + + -- Check for the case of full range, where we are definitely OK + + if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then + return; + end if; + + -- Here the range is not the complete base type range, so check + + declare + Comp_Typ_Lo : constant Node_Id := + Type_Low_Bound (Component_Type (Typ)); + Comp_Typ_Hi : constant Node_Id := + Type_High_Bound (Component_Type (Typ)); + + Char_Val : Uint; + + begin + if Compile_Time_Known_Value (Comp_Typ_Lo) + and then Compile_Time_Known_Value (Comp_Typ_Hi) + then + for J in 1 .. Strlen loop + Char_Val := UI_From_Int (Int (Get_String_Char (Str, J))); + + if Char_Val < Expr_Value (Comp_Typ_Lo) + or else Char_Val > Expr_Value (Comp_Typ_Hi) + then + Apply_Compile_Time_Constraint_Error + (N, "character out of range?", CE_Range_Check_Failed, + Loc => Source_Ptr (Int (Loc) + J)); + end if; + end loop; + + return; + end if; + end; + end if; + end if; + + -- If we got here we meed to transform the string literal into the + -- equivalent qualified positional array aggregate. This is rather + -- heavy artillery for this situation, but it is hard work to avoid. + + declare + Lits : constant List_Id := New_List; + P : Source_Ptr := Loc + 1; + C : Char_Code; + + begin + -- Build the character literals, we give them source locations that + -- correspond to the string positions, which is a bit tricky given + -- the possible presence of wide character escape sequences. + + for J in 1 .. Strlen loop + C := Get_String_Char (Str, J); + Set_Character_Literal_Name (C); + + Append_To (Lits, + Make_Character_Literal (P, + Chars => Name_Find, + Char_Literal_Value => UI_From_CC (C))); + + if In_Character_Range (C) then + P := P + 1; + + -- Should we have a call to Skip_Wide here ??? + -- ??? else + -- Skip_Wide (P); + + end if; + end loop; + + Rewrite (N, + Make_Qualified_Expression (Loc, + Subtype_Mark => New_Reference_To (Typ, Loc), + Expression => + Make_Aggregate (Loc, Expressions => Lits))); + + Analyze_And_Resolve (N, Typ); + end; + end Resolve_String_Literal; + + ----------------------------- + -- Resolve_Subprogram_Info -- + ----------------------------- + + procedure Resolve_Subprogram_Info (N : Node_Id; Typ : Entity_Id) is + begin + Set_Etype (N, Typ); + end Resolve_Subprogram_Info; + + ----------------------------- + -- Resolve_Type_Conversion -- + ----------------------------- + + procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is + Conv_OK : constant Boolean := Conversion_OK (N); + Operand : constant Node_Id := Expression (N); + Operand_Typ : constant Entity_Id := Etype (Operand); + Target_Typ : constant Entity_Id := Etype (N); + Rop : Node_Id; + Orig_N : Node_Id; + Orig_T : Node_Id; + + Test_Redundant : Boolean := Warn_On_Redundant_Constructs; + -- Set to False to suppress cases where we want to suppress the test + -- for redundancy to avoid possible false positives on this warning. + + begin + if not Conv_OK + and then not Valid_Conversion (N, Target_Typ, Operand) + then + return; + end if; + + -- If the Operand Etype is Universal_Fixed, then the conversion is + -- never redundant. We need this check because by the time we have + -- finished the rather complex transformation, the conversion looks + -- redundant when it is not. + + if Operand_Typ = Universal_Fixed then + Test_Redundant := False; + + -- If the operand is marked as Any_Fixed, then special processing is + -- required. This is also a case where we suppress the test for a + -- redundant conversion, since most certainly it is not redundant. + + elsif Operand_Typ = Any_Fixed then + Test_Redundant := False; + + -- Mixed-mode operation involving a literal. Context must be a fixed + -- type which is applied to the literal subsequently. + + if Is_Fixed_Point_Type (Typ) then + Set_Etype (Operand, Universal_Real); + + elsif Is_Numeric_Type (Typ) + and then Nkind_In (Operand, N_Op_Multiply, N_Op_Divide) + and then (Etype (Right_Opnd (Operand)) = Universal_Real + or else + Etype (Left_Opnd (Operand)) = Universal_Real) + then + -- Return if expression is ambiguous + + if Unique_Fixed_Point_Type (N) = Any_Type then + return; + + -- If nothing else, the available fixed type is Duration + + else + Set_Etype (Operand, Standard_Duration); + end if; + + -- Resolve the real operand with largest available precision + + if Etype (Right_Opnd (Operand)) = Universal_Real then + Rop := New_Copy_Tree (Right_Opnd (Operand)); + else + Rop := New_Copy_Tree (Left_Opnd (Operand)); + end if; + + Resolve (Rop, Universal_Real); + + -- If the operand is a literal (it could be a non-static and + -- illegal exponentiation) check whether the use of Duration + -- is potentially inaccurate. + + if Nkind (Rop) = N_Real_Literal + and then Realval (Rop) /= Ureal_0 + and then abs (Realval (Rop)) < Delta_Value (Standard_Duration) + then + Error_Msg_N + ("?universal real operand can only " & + "be interpreted as Duration!", + Rop); + Error_Msg_N + ("\?precision will be lost in the conversion!", Rop); + end if; + + elsif Is_Numeric_Type (Typ) + and then Nkind (Operand) in N_Op + and then Unique_Fixed_Point_Type (N) /= Any_Type + then + Set_Etype (Operand, Standard_Duration); + + else + Error_Msg_N ("invalid context for mixed mode operation", N); + Set_Etype (Operand, Any_Type); + return; + end if; + end if; + + Resolve (Operand); + + -- Note: we do the Eval_Type_Conversion call before applying the + -- required checks for a subtype conversion. This is important, since + -- both are prepared under certain circumstances to change the type + -- conversion to a constraint error node, but in the case of + -- Eval_Type_Conversion this may reflect an illegality in the static + -- case, and we would miss the illegality (getting only a warning + -- message), if we applied the type conversion checks first. + + Eval_Type_Conversion (N); + + -- Even when evaluation is not possible, we may be able to simplify the + -- conversion or its expression. This needs to be done before applying + -- checks, since otherwise the checks may use the original expression + -- and defeat the simplifications. This is specifically the case for + -- elimination of the floating-point Truncation attribute in + -- float-to-int conversions. + + Simplify_Type_Conversion (N); + + -- If after evaluation we still have a type conversion, then we may need + -- to apply checks required for a subtype conversion. + + -- Skip these type conversion checks if universal fixed operands + -- operands involved, since range checks are handled separately for + -- these cases (in the appropriate Expand routines in unit Exp_Fixd). + + if Nkind (N) = N_Type_Conversion + and then not Is_Generic_Type (Root_Type (Target_Typ)) + and then Target_Typ /= Universal_Fixed + and then Operand_Typ /= Universal_Fixed + then + Apply_Type_Conversion_Checks (N); + end if; + + -- Issue warning for conversion of simple object to its own type. We + -- have to test the original nodes, since they may have been rewritten + -- by various optimizations. + + Orig_N := Original_Node (N); + + -- Here we test for a redundant conversion if the warning mode is + -- active (and was not locally reset), and we have a type conversion + -- from source not appearing in a generic instance. + + if Test_Redundant + and then Nkind (Orig_N) = N_Type_Conversion + and then Comes_From_Source (Orig_N) + and then not In_Instance + then + Orig_N := Original_Node (Expression (Orig_N)); + Orig_T := Target_Typ; + + -- If the node is part of a larger expression, the Target_Type + -- may not be the original type of the node if the context is a + -- condition. Recover original type to see if conversion is needed. + + if Is_Boolean_Type (Orig_T) + and then Nkind (Parent (N)) in N_Op + then + Orig_T := Etype (Parent (N)); + end if; + + -- If we have an entity name, then give the warning if the entity + -- is the right type, or if it is a loop parameter covered by the + -- original type (that's needed because loop parameters have an + -- odd subtype coming from the bounds). + + if (Is_Entity_Name (Orig_N) + and then + (Etype (Entity (Orig_N)) = Orig_T + or else + (Ekind (Entity (Orig_N)) = E_Loop_Parameter + and then Covers (Orig_T, Etype (Entity (Orig_N)))))) + + -- If not an entity, then type of expression must match + + or else Etype (Orig_N) = Orig_T + then + -- One more check, do not give warning if the analyzed conversion + -- has an expression with non-static bounds, and the bounds of the + -- target are static. This avoids junk warnings in cases where the + -- conversion is necessary to establish staticness, for example in + -- a case statement. + + if not Is_OK_Static_Subtype (Operand_Typ) + and then Is_OK_Static_Subtype (Target_Typ) + then + null; + + -- Finally, if this type conversion occurs in a context that + -- requires a prefix, and the expression is a qualified expression + -- then the type conversion is not redundant, because a qualified + -- expression is not a prefix, whereas a type conversion is. For + -- example, "X := T'(Funx(...)).Y;" is illegal because a selected + -- component requires a prefix, but a type conversion makes it + -- legal: "X := T(T'(Funx(...))).Y;" + + -- In Ada 2012, a qualified expression is a name, so this idiom is + -- no longer needed, but we still suppress the warning because it + -- seems unfriendly for warnings to pop up when you switch to the + -- newer language version. + + elsif Nkind (Orig_N) = N_Qualified_Expression + and then Nkind_In (Parent (N), N_Attribute_Reference, + N_Indexed_Component, + N_Selected_Component, + N_Slice, + N_Explicit_Dereference) + then + null; + + -- Here we give the redundant conversion warning. If it is an + -- entity, give the name of the entity in the message. If not, + -- just mention the expression. + + else + if Is_Entity_Name (Orig_N) then + Error_Msg_Node_2 := Orig_T; + Error_Msg_NE -- CODEFIX + ("?redundant conversion, & is of type &!", + N, Entity (Orig_N)); + else + Error_Msg_NE + ("?redundant conversion, expression is of type&!", + N, Orig_T); + end if; + end if; + end if; + end if; + + -- Ada 2005 (AI-251): Handle class-wide interface type conversions. + -- No need to perform any interface conversion if the type of the + -- expression coincides with the target type. + + if Ada_Version >= Ada_2005 + and then Expander_Active + and then Operand_Typ /= Target_Typ + then + declare + Opnd : Entity_Id := Operand_Typ; + Target : Entity_Id := Target_Typ; + + begin + if Is_Access_Type (Opnd) then + Opnd := Designated_Type (Opnd); + end if; + + if Is_Access_Type (Target_Typ) then + Target := Designated_Type (Target); + end if; + + if Opnd = Target then + null; + + -- Conversion from interface type + + elsif Is_Interface (Opnd) then + + -- Ada 2005 (AI-217): Handle entities from limited views + + if From_With_Type (Opnd) then + Error_Msg_Qual_Level := 99; + Error_Msg_NE -- CODEFIX + ("missing WITH clause on package &", N, + Cunit_Entity (Get_Source_Unit (Base_Type (Opnd)))); + Error_Msg_N + ("type conversions require visibility of the full view", + N); + + elsif From_With_Type (Target) + and then not + (Is_Access_Type (Target_Typ) + and then Present (Non_Limited_View (Etype (Target)))) + then + Error_Msg_Qual_Level := 99; + Error_Msg_NE -- CODEFIX + ("missing WITH clause on package &", N, + Cunit_Entity (Get_Source_Unit (Base_Type (Target)))); + Error_Msg_N + ("type conversions require visibility of the full view", + N); + + else + Expand_Interface_Conversion (N, Is_Static => False); + end if; + + -- Conversion to interface type + + elsif Is_Interface (Target) then + + -- Handle subtypes + + if Ekind_In (Opnd, E_Protected_Subtype, E_Task_Subtype) then + Opnd := Etype (Opnd); + end if; + + if not Interface_Present_In_Ancestor + (Typ => Opnd, + Iface => Target) + then + if Is_Class_Wide_Type (Opnd) then + + -- The static analysis is not enough to know if the + -- interface is implemented or not. Hence we must pass + -- the work to the expander to generate code to evaluate + -- the conversion at run time. + + Expand_Interface_Conversion (N, Is_Static => False); + + else + Error_Msg_Name_1 := Chars (Etype (Target)); + Error_Msg_Name_2 := Chars (Opnd); + Error_Msg_N + ("wrong interface conversion (% is not a progenitor " & + "of %)", N); + end if; + + else + Expand_Interface_Conversion (N); + end if; + end if; + end; + end if; + end Resolve_Type_Conversion; + + ---------------------- + -- Resolve_Unary_Op -- + ---------------------- + + procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id) is + B_Typ : constant Entity_Id := Base_Type (Typ); + R : constant Node_Id := Right_Opnd (N); + OK : Boolean; + Lo : Uint; + Hi : Uint; + + begin + -- Deal with intrinsic unary operators + + if Comes_From_Source (N) + and then Ekind (Entity (N)) = E_Function + and then Is_Imported (Entity (N)) + and then Is_Intrinsic_Subprogram (Entity (N)) + then + Resolve_Intrinsic_Unary_Operator (N, Typ); + return; + end if; + + -- Deal with universal cases + + if Etype (R) = Universal_Integer + or else + Etype (R) = Universal_Real + then + Check_For_Visible_Operator (N, B_Typ); + end if; + + Set_Etype (N, B_Typ); + Resolve (R, B_Typ); + + -- Generate warning for expressions like abs (x mod 2) + + if Warn_On_Redundant_Constructs + and then Nkind (N) = N_Op_Abs + then + Determine_Range (Right_Opnd (N), OK, Lo, Hi); + + if OK and then Hi >= Lo and then Lo >= 0 then + Error_Msg_N -- CODEFIX + ("?abs applied to known non-negative value has no effect", N); + end if; + end if; + + -- Deal with reference generation + + Check_Unset_Reference (R); + Generate_Operator_Reference (N, B_Typ); + Eval_Unary_Op (N); + + -- Set overflow checking bit. Much cleverer code needed here eventually + -- and perhaps the Resolve routines should be separated for the various + -- arithmetic operations, since they will need different processing ??? + + if Nkind (N) in N_Op then + if not Overflow_Checks_Suppressed (Etype (N)) then + Enable_Overflow_Check (N); + end if; + end if; + + -- Generate warning for expressions like -5 mod 3 for integers. No need + -- to worry in the floating-point case, since parens do not affect the + -- result so there is no point in giving in a warning. + + declare + Norig : constant Node_Id := Original_Node (N); + Rorig : Node_Id; + Val : Uint; + HB : Uint; + LB : Uint; + Lval : Uint; + Opnd : Node_Id; + + begin + if Warn_On_Questionable_Missing_Parens + and then Comes_From_Source (Norig) + and then Is_Integer_Type (Typ) + and then Nkind (Norig) = N_Op_Minus + then + Rorig := Original_Node (Right_Opnd (Norig)); + + -- We are looking for cases where the right operand is not + -- parenthesized, and is a binary operator, multiply, divide, or + -- mod. These are the cases where the grouping can affect results. + + if Paren_Count (Rorig) = 0 + and then Nkind_In (Rorig, N_Op_Mod, N_Op_Multiply, N_Op_Divide) + then + -- For mod, we always give the warning, since the value is + -- affected by the parenthesization (e.g. (-5) mod 315 /= + -- -(5 mod 315)). But for the other cases, the only concern is + -- overflow, e.g. for the case of 8 big signed (-(2 * 64) + -- overflows, but (-2) * 64 does not). So we try to give the + -- message only when overflow is possible. + + if Nkind (Rorig) /= N_Op_Mod + and then Compile_Time_Known_Value (R) + then + Val := Expr_Value (R); + + if Compile_Time_Known_Value (Type_High_Bound (Typ)) then + HB := Expr_Value (Type_High_Bound (Typ)); + else + HB := Expr_Value (Type_High_Bound (Base_Type (Typ))); + end if; + + if Compile_Time_Known_Value (Type_Low_Bound (Typ)) then + LB := Expr_Value (Type_Low_Bound (Typ)); + else + LB := Expr_Value (Type_Low_Bound (Base_Type (Typ))); + end if; + + -- Note that the test below is deliberately excluding the + -- largest negative number, since that is a potentially + -- troublesome case (e.g. -2 * x, where the result is the + -- largest negative integer has an overflow with 2 * x). + + if Val > LB and then Val <= HB then + return; + end if; + end if; + + -- For the multiplication case, the only case we have to worry + -- about is when (-a)*b is exactly the largest negative number + -- so that -(a*b) can cause overflow. This can only happen if + -- a is a power of 2, and more generally if any operand is a + -- constant that is not a power of 2, then the parentheses + -- cannot affect whether overflow occurs. We only bother to + -- test the left most operand + + -- Loop looking at left operands for one that has known value + + Opnd := Rorig; + Opnd_Loop : while Nkind (Opnd) = N_Op_Multiply loop + if Compile_Time_Known_Value (Left_Opnd (Opnd)) then + Lval := UI_Abs (Expr_Value (Left_Opnd (Opnd))); + + -- Operand value of 0 or 1 skips warning + + if Lval <= 1 then + return; + + -- Otherwise check power of 2, if power of 2, warn, if + -- anything else, skip warning. + + else + while Lval /= 2 loop + if Lval mod 2 = 1 then + return; + else + Lval := Lval / 2; + end if; + end loop; + + exit Opnd_Loop; + end if; + end if; + + -- Keep looking at left operands + + Opnd := Left_Opnd (Opnd); + end loop Opnd_Loop; + + -- For rem or "/" we can only have a problematic situation + -- if the divisor has a value of minus one or one. Otherwise + -- overflow is impossible (divisor > 1) or we have a case of + -- division by zero in any case. + + if Nkind_In (Rorig, N_Op_Divide, N_Op_Rem) + and then Compile_Time_Known_Value (Right_Opnd (Rorig)) + and then UI_Abs (Expr_Value (Right_Opnd (Rorig))) /= 1 + then + return; + end if; + + -- If we fall through warning should be issued + + Error_Msg_N + ("?unary minus expression should be parenthesized here!", N); + end if; + end if; + end; + end Resolve_Unary_Op; + + ---------------------------------- + -- Resolve_Unchecked_Expression -- + ---------------------------------- + + procedure Resolve_Unchecked_Expression + (N : Node_Id; + Typ : Entity_Id) + is + begin + Resolve (Expression (N), Typ, Suppress => All_Checks); + Set_Etype (N, Typ); + end Resolve_Unchecked_Expression; + + --------------------------------------- + -- Resolve_Unchecked_Type_Conversion -- + --------------------------------------- + + procedure Resolve_Unchecked_Type_Conversion + (N : Node_Id; + Typ : Entity_Id) + is + pragma Warnings (Off, Typ); + + Operand : constant Node_Id := Expression (N); + Opnd_Type : constant Entity_Id := Etype (Operand); + + begin + -- Resolve operand using its own type + + Resolve (Operand, Opnd_Type); + Eval_Unchecked_Conversion (N); + end Resolve_Unchecked_Type_Conversion; + + ------------------------------ + -- Rewrite_Operator_As_Call -- + ------------------------------ + + procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Actuals : constant List_Id := New_List; + New_N : Node_Id; + + begin + if Nkind (N) in N_Binary_Op then + Append (Left_Opnd (N), Actuals); + end if; + + Append (Right_Opnd (N), Actuals); + + New_N := + Make_Function_Call (Sloc => Loc, + Name => New_Occurrence_Of (Nam, Loc), + Parameter_Associations => Actuals); + + Preserve_Comes_From_Source (New_N, N); + Preserve_Comes_From_Source (Name (New_N), N); + Rewrite (N, New_N); + Set_Etype (N, Etype (Nam)); + end Rewrite_Operator_As_Call; + + ------------------------------ + -- Rewrite_Renamed_Operator -- + ------------------------------ + + procedure Rewrite_Renamed_Operator + (N : Node_Id; + Op : Entity_Id; + Typ : Entity_Id) + is + Nam : constant Name_Id := Chars (Op); + Is_Binary : constant Boolean := Nkind (N) in N_Binary_Op; + Op_Node : Node_Id; + + begin + -- Rewrite the operator node using the real operator, not its renaming. + -- Exclude user-defined intrinsic operations of the same name, which are + -- treated separately and rewritten as calls. + + if Ekind (Op) /= E_Function or else Chars (N) /= Nam then + Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N)); + Set_Chars (Op_Node, Nam); + Set_Etype (Op_Node, Etype (N)); + Set_Entity (Op_Node, Op); + Set_Right_Opnd (Op_Node, Right_Opnd (N)); + + -- Indicate that both the original entity and its renaming are + -- referenced at this point. + + Generate_Reference (Entity (N), N); + Generate_Reference (Op, N); + + if Is_Binary then + Set_Left_Opnd (Op_Node, Left_Opnd (N)); + end if; + + Rewrite (N, Op_Node); + + -- If the context type is private, add the appropriate conversions so + -- that the operator is applied to the full view. This is done in the + -- routines that resolve intrinsic operators. + + if Is_Intrinsic_Subprogram (Op) + and then Is_Private_Type (Typ) + then + case Nkind (N) is + when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide | + N_Op_Expon | N_Op_Mod | N_Op_Rem => + Resolve_Intrinsic_Operator (N, Typ); + + when N_Op_Plus | N_Op_Minus | N_Op_Abs => + Resolve_Intrinsic_Unary_Operator (N, Typ); + + when others => + Resolve (N, Typ); + end case; + end if; + + elsif Ekind (Op) = E_Function and then Is_Intrinsic_Subprogram (Op) then + + -- Operator renames a user-defined operator of the same name. Use the + -- original operator in the node, which is the one Gigi knows about. + + Set_Entity (N, Op); + Set_Is_Overloaded (N, False); + end if; + end Rewrite_Renamed_Operator; + + ----------------------- + -- Set_Slice_Subtype -- + ----------------------- + + -- Build an implicit subtype declaration to represent the type delivered by + -- the slice. This is an abbreviated version of an array subtype. We define + -- an index subtype for the slice, using either the subtype name or the + -- discrete range of the slice. To be consistent with index usage elsewhere + -- we create a list header to hold the single index. This list is not + -- otherwise attached to the syntax tree. + + procedure Set_Slice_Subtype (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Index_List : constant List_Id := New_List; + Index : Node_Id; + Index_Subtype : Entity_Id; + Index_Type : Entity_Id; + Slice_Subtype : Entity_Id; + Drange : constant Node_Id := Discrete_Range (N); + + begin + if Is_Entity_Name (Drange) then + Index_Subtype := Entity (Drange); + + else + -- We force the evaluation of a range. This is definitely needed in + -- the renamed case, and seems safer to do unconditionally. Note in + -- any case that since we will create and insert an Itype referring + -- to this range, we must make sure any side effect removal actions + -- are inserted before the Itype definition. + + if Nkind (Drange) = N_Range then + Force_Evaluation (Low_Bound (Drange)); + Force_Evaluation (High_Bound (Drange)); + end if; + + Index_Type := Base_Type (Etype (Drange)); + + Index_Subtype := Create_Itype (Subtype_Kind (Ekind (Index_Type)), N); + + -- Take a new copy of Drange (where bounds have been rewritten to + -- reference side-effect-free names). Using a separate tree ensures + -- that further expansion (e.g. while rewriting a slice assignment + -- into a FOR loop) does not attempt to remove side effects on the + -- bounds again (which would cause the bounds in the index subtype + -- definition to refer to temporaries before they are defined) (the + -- reason is that some names are considered side effect free here + -- for the subtype, but not in the context of a loop iteration + -- scheme). + + Set_Scalar_Range (Index_Subtype, New_Copy_Tree (Drange)); + Set_Etype (Index_Subtype, Index_Type); + Set_Size_Info (Index_Subtype, Index_Type); + Set_RM_Size (Index_Subtype, RM_Size (Index_Type)); + end if; + + Slice_Subtype := Create_Itype (E_Array_Subtype, N); + + Index := New_Occurrence_Of (Index_Subtype, Loc); + Set_Etype (Index, Index_Subtype); + Append (Index, Index_List); + + Set_First_Index (Slice_Subtype, Index); + Set_Etype (Slice_Subtype, Base_Type (Etype (N))); + Set_Is_Constrained (Slice_Subtype, True); + + Check_Compile_Time_Size (Slice_Subtype); + + -- The Etype of the existing Slice node is reset to this slice subtype. + -- Its bounds are obtained from its first index. + + Set_Etype (N, Slice_Subtype); + + -- For packed slice subtypes, freeze immediately (except in the + -- case of being in a "spec expression" where we never freeze + -- when we first see the expression). + + if Is_Packed (Slice_Subtype) and not In_Spec_Expression then + Freeze_Itype (Slice_Subtype, N); + + -- For all other cases insert an itype reference in the slice's actions + -- so that the itype is frozen at the proper place in the tree (i.e. at + -- the point where actions for the slice are analyzed). Note that this + -- is different from freezing the itype immediately, which might be + -- premature (e.g. if the slice is within a transient scope). + + else + Ensure_Defined (Typ => Slice_Subtype, N => N); + end if; + end Set_Slice_Subtype; + + -------------------------------- + -- Set_String_Literal_Subtype -- + -------------------------------- + + procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Low_Bound : constant Node_Id := + Type_Low_Bound (Etype (First_Index (Typ))); + Subtype_Id : Entity_Id; + + begin + if Nkind (N) /= N_String_Literal then + return; + end if; + + Subtype_Id := Create_Itype (E_String_Literal_Subtype, N); + Set_String_Literal_Length (Subtype_Id, UI_From_Int + (String_Length (Strval (N)))); + Set_Etype (Subtype_Id, Base_Type (Typ)); + Set_Is_Constrained (Subtype_Id); + Set_Etype (N, Subtype_Id); + + if Is_OK_Static_Expression (Low_Bound) then + + -- The low bound is set from the low bound of the corresponding index + -- type. Note that we do not store the high bound in the string literal + -- subtype, but it can be deduced if necessary from the length and the + -- low bound. + + Set_String_Literal_Low_Bound (Subtype_Id, Low_Bound); + + else + Set_String_Literal_Low_Bound + (Subtype_Id, Make_Integer_Literal (Loc, 1)); + Set_Etype (String_Literal_Low_Bound (Subtype_Id), Standard_Positive); + + -- Build bona fide subtype for the string, and wrap it in an + -- unchecked conversion, because the backend expects the + -- String_Literal_Subtype to have a static lower bound. + + declare + Index_List : constant List_Id := New_List; + Index_Type : constant Entity_Id := Etype (First_Index (Typ)); + High_Bound : constant Node_Id := + Make_Op_Add (Loc, + Left_Opnd => New_Copy_Tree (Low_Bound), + Right_Opnd => + Make_Integer_Literal (Loc, + String_Length (Strval (N)) - 1)); + Array_Subtype : Entity_Id; + Index_Subtype : Entity_Id; + Drange : Node_Id; + Index : Node_Id; + + begin + Index_Subtype := + Create_Itype (Subtype_Kind (Ekind (Index_Type)), N); + Drange := Make_Range (Loc, New_Copy_Tree (Low_Bound), High_Bound); + Set_Scalar_Range (Index_Subtype, Drange); + Set_Parent (Drange, N); + Analyze_And_Resolve (Drange, Index_Type); + + -- In the context, the Index_Type may already have a constraint, + -- so use common base type on string subtype. The base type may + -- be used when generating attributes of the string, for example + -- in the context of a slice assignment. + + Set_Etype (Index_Subtype, Base_Type (Index_Type)); + Set_Size_Info (Index_Subtype, Index_Type); + Set_RM_Size (Index_Subtype, RM_Size (Index_Type)); + + Array_Subtype := Create_Itype (E_Array_Subtype, N); + + Index := New_Occurrence_Of (Index_Subtype, Loc); + Set_Etype (Index, Index_Subtype); + Append (Index, Index_List); + + Set_First_Index (Array_Subtype, Index); + Set_Etype (Array_Subtype, Base_Type (Typ)); + Set_Is_Constrained (Array_Subtype, True); + + Rewrite (N, + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Array_Subtype, Loc), + Expression => Relocate_Node (N))); + Set_Etype (N, Array_Subtype); + end; + end if; + end Set_String_Literal_Subtype; + + ------------------------------ + -- Simplify_Type_Conversion -- + ------------------------------ + + procedure Simplify_Type_Conversion (N : Node_Id) is + begin + if Nkind (N) = N_Type_Conversion then + declare + Operand : constant Node_Id := Expression (N); + Target_Typ : constant Entity_Id := Etype (N); + Opnd_Typ : constant Entity_Id := Etype (Operand); + + begin + if Is_Floating_Point_Type (Opnd_Typ) + and then + (Is_Integer_Type (Target_Typ) + or else (Is_Fixed_Point_Type (Target_Typ) + and then Conversion_OK (N))) + and then Nkind (Operand) = N_Attribute_Reference + and then Attribute_Name (Operand) = Name_Truncation + + -- Special processing required if the conversion is the expression + -- of a Truncation attribute reference. In this case we replace: + + -- ityp (ftyp'Truncation (x)) + + -- by + + -- ityp (x) + + -- with the Float_Truncate flag set, which is more efficient. + + then + Rewrite (Operand, + Relocate_Node (First (Expressions (Operand)))); + Set_Float_Truncate (N, True); + end if; + end; + end if; + end Simplify_Type_Conversion; + + ----------------------------- + -- Unique_Fixed_Point_Type -- + ----------------------------- + + function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id is + T1 : Entity_Id := Empty; + T2 : Entity_Id; + Item : Node_Id; + Scop : Entity_Id; + + procedure Fixed_Point_Error; + -- Give error messages for true ambiguity. Messages are posted on node + -- N, and entities T1, T2 are the possible interpretations. + + ----------------------- + -- Fixed_Point_Error -- + ----------------------- + + procedure Fixed_Point_Error is + begin + Error_Msg_N ("ambiguous universal_fixed_expression", N); + Error_Msg_NE ("\\possible interpretation as}", N, T1); + Error_Msg_NE ("\\possible interpretation as}", N, T2); + end Fixed_Point_Error; + + -- Start of processing for Unique_Fixed_Point_Type + + begin + -- The operations on Duration are visible, so Duration is always a + -- possible interpretation. + + T1 := Standard_Duration; + + -- Look for fixed-point types in enclosing scopes + + Scop := Current_Scope; + while Scop /= Standard_Standard loop + T2 := First_Entity (Scop); + while Present (T2) loop + if Is_Fixed_Point_Type (T2) + and then Current_Entity (T2) = T2 + and then Scope (Base_Type (T2)) = Scop + then + if Present (T1) then + Fixed_Point_Error; + return Any_Type; + else + T1 := T2; + end if; + end if; + + Next_Entity (T2); + end loop; + + Scop := Scope (Scop); + end loop; + + -- Look for visible fixed type declarations in the context + + Item := First (Context_Items (Cunit (Current_Sem_Unit))); + while Present (Item) loop + if Nkind (Item) = N_With_Clause then + Scop := Entity (Name (Item)); + T2 := First_Entity (Scop); + while Present (T2) loop + if Is_Fixed_Point_Type (T2) + and then Scope (Base_Type (T2)) = Scop + and then (Is_Potentially_Use_Visible (T2) + or else In_Use (T2)) + then + if Present (T1) then + Fixed_Point_Error; + return Any_Type; + else + T1 := T2; + end if; + end if; + + Next_Entity (T2); + end loop; + end if; + + Next (Item); + end loop; + + if Nkind (N) = N_Real_Literal then + Error_Msg_NE ("?real literal interpreted as }!", N, T1); + else + Error_Msg_NE ("?universal_fixed expression interpreted as }!", N, T1); + end if; + + return T1; + end Unique_Fixed_Point_Type; + + ---------------------- + -- Valid_Conversion -- + ---------------------- + + function Valid_Conversion + (N : Node_Id; + Target : Entity_Id; + Operand : Node_Id) return Boolean + is + Target_Type : constant Entity_Id := Base_Type (Target); + Opnd_Type : Entity_Id := Etype (Operand); + + function Conversion_Check + (Valid : Boolean; + Msg : String) return Boolean; + -- Little routine to post Msg if Valid is False, returns Valid value + + function Valid_Tagged_Conversion + (Target_Type : Entity_Id; + Opnd_Type : Entity_Id) return Boolean; + -- Specifically test for validity of tagged conversions + + function Valid_Array_Conversion return Boolean; + -- Check index and component conformance, and accessibility levels if + -- the component types are anonymous access types (Ada 2005). + + ---------------------- + -- Conversion_Check -- + ---------------------- + + function Conversion_Check + (Valid : Boolean; + Msg : String) return Boolean + is + begin + if not Valid then + Error_Msg_N (Msg, Operand); + end if; + + return Valid; + end Conversion_Check; + + ---------------------------- + -- Valid_Array_Conversion -- + ---------------------------- + + function Valid_Array_Conversion return Boolean + is + Opnd_Comp_Type : constant Entity_Id := Component_Type (Opnd_Type); + Opnd_Comp_Base : constant Entity_Id := Base_Type (Opnd_Comp_Type); + + Opnd_Index : Node_Id; + Opnd_Index_Type : Entity_Id; + + Target_Comp_Type : constant Entity_Id := + Component_Type (Target_Type); + Target_Comp_Base : constant Entity_Id := + Base_Type (Target_Comp_Type); + + Target_Index : Node_Id; + Target_Index_Type : Entity_Id; + + begin + -- Error if wrong number of dimensions + + if + Number_Dimensions (Target_Type) /= Number_Dimensions (Opnd_Type) + then + Error_Msg_N + ("incompatible number of dimensions for conversion", Operand); + return False; + + -- Number of dimensions matches + + else + -- Loop through indexes of the two arrays + + Target_Index := First_Index (Target_Type); + Opnd_Index := First_Index (Opnd_Type); + while Present (Target_Index) and then Present (Opnd_Index) loop + Target_Index_Type := Etype (Target_Index); + Opnd_Index_Type := Etype (Opnd_Index); + + -- Error if index types are incompatible + + if not (Is_Integer_Type (Target_Index_Type) + and then Is_Integer_Type (Opnd_Index_Type)) + and then (Root_Type (Target_Index_Type) + /= Root_Type (Opnd_Index_Type)) + then + Error_Msg_N + ("incompatible index types for array conversion", + Operand); + return False; + end if; + + Next_Index (Target_Index); + Next_Index (Opnd_Index); + end loop; + + -- If component types have same base type, all set + + if Target_Comp_Base = Opnd_Comp_Base then + null; + + -- Here if base types of components are not the same. The only + -- time this is allowed is if we have anonymous access types. + + -- The conversion of arrays of anonymous access types can lead + -- to dangling pointers. AI-392 formalizes the accessibility + -- checks that must be applied to such conversions to prevent + -- out-of-scope references. + + elsif + Ekind_In (Target_Comp_Base, E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) + and then Ekind (Opnd_Comp_Base) = Ekind (Target_Comp_Base) + and then + Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type) + then + if Type_Access_Level (Target_Type) < + Type_Access_Level (Opnd_Type) + then + if In_Instance_Body then + Error_Msg_N ("?source array type " & + "has deeper accessibility level than target", Operand); + Error_Msg_N ("\?Program_Error will be raised at run time", + Operand); + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Accessibility_Check_Failed)); + Set_Etype (N, Target_Type); + return False; + + -- Conversion not allowed because of accessibility levels + + else + Error_Msg_N ("source array type " & + "has deeper accessibility level than target", Operand); + return False; + end if; + else + null; + end if; + + -- All other cases where component base types do not match + + else + Error_Msg_N + ("incompatible component types for array conversion", + Operand); + return False; + end if; + + -- Check that component subtypes statically match. For numeric + -- types this means that both must be either constrained or + -- unconstrained. For enumeration types the bounds must match. + -- All of this is checked in Subtypes_Statically_Match. + + if not Subtypes_Statically_Match + (Target_Comp_Type, Opnd_Comp_Type) + then + Error_Msg_N + ("component subtypes must statically match", Operand); + return False; + end if; + end if; + + return True; + end Valid_Array_Conversion; + + ----------------------------- + -- Valid_Tagged_Conversion -- + ----------------------------- + + function Valid_Tagged_Conversion + (Target_Type : Entity_Id; + Opnd_Type : Entity_Id) return Boolean + is + begin + -- Upward conversions are allowed (RM 4.6(22)) + + if Covers (Target_Type, Opnd_Type) + or else Is_Ancestor (Target_Type, Opnd_Type) + then + return True; + + -- Downward conversion are allowed if the operand is class-wide + -- (RM 4.6(23)). + + elsif Is_Class_Wide_Type (Opnd_Type) + and then Covers (Opnd_Type, Target_Type) + then + return True; + + elsif Covers (Opnd_Type, Target_Type) + or else Is_Ancestor (Opnd_Type, Target_Type) + then + return + Conversion_Check (False, + "downward conversion of tagged objects not allowed"); + + -- Ada 2005 (AI-251): The conversion to/from interface types is + -- always valid + + elsif Is_Interface (Target_Type) or else Is_Interface (Opnd_Type) then + return True; + + -- If the operand is a class-wide type obtained through a limited_ + -- with clause, and the context includes the non-limited view, use + -- it to determine whether the conversion is legal. + + elsif Is_Class_Wide_Type (Opnd_Type) + and then From_With_Type (Opnd_Type) + and then Present (Non_Limited_View (Etype (Opnd_Type))) + and then Is_Interface (Non_Limited_View (Etype (Opnd_Type))) + then + return True; + + elsif Is_Access_Type (Opnd_Type) + and then Is_Interface (Directly_Designated_Type (Opnd_Type)) + then + return True; + + else + Error_Msg_NE + ("invalid tagged conversion, not compatible with}", + N, First_Subtype (Opnd_Type)); + return False; + end if; + end Valid_Tagged_Conversion; + + -- Start of processing for Valid_Conversion + + begin + Check_Parameterless_Call (Operand); + + if Is_Overloaded (Operand) then + declare + I : Interp_Index; + I1 : Interp_Index; + It : Interp; + It1 : Interp; + N1 : Entity_Id; + T1 : Entity_Id; + + begin + -- Remove procedure calls, which syntactically cannot appear in + -- this context, but which cannot be removed by type checking, + -- because the context does not impose a type. + + -- When compiling for VMS, spurious ambiguities can be produced + -- when arithmetic operations have a literal operand and return + -- System.Address or a descendant of it. These ambiguities are + -- otherwise resolved by the context, but for conversions there + -- is no context type and the removal of the spurious operations + -- must be done explicitly here. + + -- The node may be labelled overloaded, but still contain only one + -- interpretation because others were discarded earlier. If this + -- is the case, retain the single interpretation if legal. + + Get_First_Interp (Operand, I, It); + Opnd_Type := It.Typ; + Get_Next_Interp (I, It); + + if Present (It.Typ) + and then Opnd_Type /= Standard_Void_Type + then + -- More than one candidate interpretation is available + + Get_First_Interp (Operand, I, It); + while Present (It.Typ) loop + if It.Typ = Standard_Void_Type then + Remove_Interp (I); + end if; + + if Present (System_Aux_Id) + and then Is_Descendent_Of_Address (It.Typ) + then + Remove_Interp (I); + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + + Get_First_Interp (Operand, I, It); + I1 := I; + It1 := It; + + if No (It.Typ) then + Error_Msg_N ("illegal operand in conversion", Operand); + return False; + end if; + + Get_Next_Interp (I, It); + + if Present (It.Typ) then + N1 := It1.Nam; + T1 := It1.Typ; + It1 := Disambiguate (Operand, I1, I, Any_Type); + + if It1 = No_Interp then + Error_Msg_N ("ambiguous operand in conversion", Operand); + + -- If the interpretation involves a standard operator, use + -- the location of the type, which may be user-defined. + + if Sloc (It.Nam) = Standard_Location then + Error_Msg_Sloc := Sloc (It.Typ); + else + Error_Msg_Sloc := Sloc (It.Nam); + end if; + + Error_Msg_N -- CODEFIX + ("\\possible interpretation#!", Operand); + + if Sloc (N1) = Standard_Location then + Error_Msg_Sloc := Sloc (T1); + else + Error_Msg_Sloc := Sloc (N1); + end if; + + Error_Msg_N -- CODEFIX + ("\\possible interpretation#!", Operand); + + return False; + end if; + end if; + + Set_Etype (Operand, It1.Typ); + Opnd_Type := It1.Typ; + end; + end if; + + -- Numeric types + + if Is_Numeric_Type (Target_Type) then + + -- A universal fixed expression can be converted to any numeric type + + if Opnd_Type = Universal_Fixed then + return True; + + -- Also no need to check when in an instance or inlined body, because + -- the legality has been established when the template was analyzed. + -- Furthermore, numeric conversions may occur where only a private + -- view of the operand type is visible at the instantiation point. + -- This results in a spurious error if we check that the operand type + -- is a numeric type. + + -- Note: in a previous version of this unit, the following tests were + -- applied only for generated code (Comes_From_Source set to False), + -- but in fact the test is required for source code as well, since + -- this situation can arise in source code. + + elsif In_Instance or else In_Inlined_Body then + return True; + + -- Otherwise we need the conversion check + + else + return Conversion_Check + (Is_Numeric_Type (Opnd_Type), + "illegal operand for numeric conversion"); + end if; + + -- Array types + + elsif Is_Array_Type (Target_Type) then + if not Is_Array_Type (Opnd_Type) + or else Opnd_Type = Any_Composite + or else Opnd_Type = Any_String + then + Error_Msg_N ("illegal operand for array conversion", Operand); + return False; + else + return Valid_Array_Conversion; + end if; + + -- Ada 2005 (AI-251): Anonymous access types where target references an + -- interface type. + + elsif Ekind_In (Target_Type, E_General_Access_Type, + E_Anonymous_Access_Type) + and then Is_Interface (Directly_Designated_Type (Target_Type)) + then + -- Check the static accessibility rule of 4.6(17). Note that the + -- check is not enforced when within an instance body, since the + -- RM requires such cases to be caught at run time. + + if Ekind (Target_Type) /= E_Anonymous_Access_Type then + if Type_Access_Level (Opnd_Type) > + Type_Access_Level (Target_Type) + then + -- In an instance, this is a run-time check, but one we know + -- will fail, so generate an appropriate warning. The raise + -- will be generated by Expand_N_Type_Conversion. + + if In_Instance_Body then + Error_Msg_N + ("?cannot convert local pointer to non-local access type", + Operand); + Error_Msg_N + ("\?Program_Error will be raised at run time", Operand); + else + Error_Msg_N + ("cannot convert local pointer to non-local access type", + Operand); + return False; + end if; + + -- Special accessibility checks are needed in the case of access + -- discriminants declared for a limited type. + + elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type + and then not Is_Local_Anonymous_Access (Opnd_Type) + then + -- When the operand is a selected access discriminant the check + -- needs to be made against the level of the object denoted by + -- the prefix of the selected name (Object_Access_Level handles + -- checking the prefix of the operand for this case). + + if Nkind (Operand) = N_Selected_Component + and then Object_Access_Level (Operand) > + Type_Access_Level (Target_Type) + then + -- In an instance, this is a run-time check, but one we know + -- will fail, so generate an appropriate warning. The raise + -- will be generated by Expand_N_Type_Conversion. + + if In_Instance_Body then + Error_Msg_N + ("?cannot convert access discriminant to non-local" & + " access type", Operand); + Error_Msg_N + ("\?Program_Error will be raised at run time", Operand); + else + Error_Msg_N + ("cannot convert access discriminant to non-local" & + " access type", Operand); + return False; + end if; + end if; + + -- The case of a reference to an access discriminant from + -- within a limited type declaration (which will appear as + -- a discriminal) is always illegal because the level of the + -- discriminant is considered to be deeper than any (nameable) + -- access type. + + if Is_Entity_Name (Operand) + and then not Is_Local_Anonymous_Access (Opnd_Type) + and then + Ekind_In (Entity (Operand), E_In_Parameter, E_Constant) + and then Present (Discriminal_Link (Entity (Operand))) + then + Error_Msg_N + ("discriminant has deeper accessibility level than target", + Operand); + return False; + end if; + end if; + end if; + + return True; + + -- General and anonymous access types + + elsif Ekind_In (Target_Type, E_General_Access_Type, + E_Anonymous_Access_Type) + and then + Conversion_Check + (Is_Access_Type (Opnd_Type) + and then not + Ekind_In (Opnd_Type, E_Access_Subprogram_Type, + E_Access_Protected_Subprogram_Type), + "must be an access-to-object type") + then + if Is_Access_Constant (Opnd_Type) + and then not Is_Access_Constant (Target_Type) + then + Error_Msg_N + ("access-to-constant operand type not allowed", Operand); + return False; + end if; + + -- Check the static accessibility rule of 4.6(17). Note that the + -- check is not enforced when within an instance body, since the RM + -- requires such cases to be caught at run time. + + if Ekind (Target_Type) /= E_Anonymous_Access_Type + or else Is_Local_Anonymous_Access (Target_Type) + then + if Type_Access_Level (Opnd_Type) + > Type_Access_Level (Target_Type) + then + -- In an instance, this is a run-time check, but one we know + -- will fail, so generate an appropriate warning. The raise + -- will be generated by Expand_N_Type_Conversion. + + if In_Instance_Body then + Error_Msg_N + ("?cannot convert local pointer to non-local access type", + Operand); + Error_Msg_N + ("\?Program_Error will be raised at run time", Operand); + + else + -- Avoid generation of spurious error message + + if not Error_Posted (N) then + Error_Msg_N + ("cannot convert local pointer to non-local access type", + Operand); + end if; + + return False; + end if; + + -- Special accessibility checks are needed in the case of access + -- discriminants declared for a limited type. + + elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type + and then not Is_Local_Anonymous_Access (Opnd_Type) + then + -- When the operand is a selected access discriminant the check + -- needs to be made against the level of the object denoted by + -- the prefix of the selected name (Object_Access_Level handles + -- checking the prefix of the operand for this case). + + if Nkind (Operand) = N_Selected_Component + and then Object_Access_Level (Operand) > + Type_Access_Level (Target_Type) + then + -- In an instance, this is a run-time check, but one we know + -- will fail, so generate an appropriate warning. The raise + -- will be generated by Expand_N_Type_Conversion. + + if In_Instance_Body then + Error_Msg_N + ("?cannot convert access discriminant to non-local" & + " access type", Operand); + Error_Msg_N + ("\?Program_Error will be raised at run time", + Operand); + + else + Error_Msg_N + ("cannot convert access discriminant to non-local" & + " access type", Operand); + return False; + end if; + end if; + + -- The case of a reference to an access discriminant from + -- within a limited type declaration (which will appear as + -- a discriminal) is always illegal because the level of the + -- discriminant is considered to be deeper than any (nameable) + -- access type. + + if Is_Entity_Name (Operand) + and then + Ekind_In (Entity (Operand), E_In_Parameter, E_Constant) + and then Present (Discriminal_Link (Entity (Operand))) + then + Error_Msg_N + ("discriminant has deeper accessibility level than target", + Operand); + return False; + end if; + end if; + end if; + + -- In the presence of limited_with clauses we have to use non-limited + -- views, if available. + + Check_Limited : declare + function Full_Designated_Type (T : Entity_Id) return Entity_Id; + -- Helper function to handle limited views + + -------------------------- + -- Full_Designated_Type -- + -------------------------- + + function Full_Designated_Type (T : Entity_Id) return Entity_Id is + Desig : constant Entity_Id := Designated_Type (T); + + begin + -- Handle the limited view of a type + + if Is_Incomplete_Type (Desig) + and then From_With_Type (Desig) + and then Present (Non_Limited_View (Desig)) + then + return Available_View (Desig); + else + return Desig; + end if; + end Full_Designated_Type; + + -- Local Declarations + + Target : constant Entity_Id := Full_Designated_Type (Target_Type); + Opnd : constant Entity_Id := Full_Designated_Type (Opnd_Type); + + Same_Base : constant Boolean := + Base_Type (Target) = Base_Type (Opnd); + + -- Start of processing for Check_Limited + + begin + if Is_Tagged_Type (Target) then + return Valid_Tagged_Conversion (Target, Opnd); + + else + if not Same_Base then + Error_Msg_NE + ("target designated type not compatible with }", + N, Base_Type (Opnd)); + return False; + + -- Ada 2005 AI-384: legality rule is symmetric in both + -- designated types. The conversion is legal (with possible + -- constraint check) if either designated type is + -- unconstrained. + + elsif Subtypes_Statically_Match (Target, Opnd) + or else + (Has_Discriminants (Target) + and then + (not Is_Constrained (Opnd) + or else not Is_Constrained (Target))) + then + -- Special case, if Value_Size has been used to make the + -- sizes different, the conversion is not allowed even + -- though the subtypes statically match. + + if Known_Static_RM_Size (Target) + and then Known_Static_RM_Size (Opnd) + and then RM_Size (Target) /= RM_Size (Opnd) + then + Error_Msg_NE + ("target designated subtype not compatible with }", + N, Opnd); + Error_Msg_NE + ("\because sizes of the two designated subtypes differ", + N, Opnd); + return False; + + -- Normal case where conversion is allowed + + else + return True; + end if; + + else + Error_Msg_NE + ("target designated subtype not compatible with }", + N, Opnd); + return False; + end if; + end if; + end Check_Limited; + + -- Access to subprogram types. If the operand is an access parameter, + -- the type has a deeper accessibility that any master, and cannot be + -- assigned. We must make an exception if the conversion is part of an + -- assignment and the target is the return object of an extended return + -- statement, because in that case the accessibility check takes place + -- after the return. + + elsif Is_Access_Subprogram_Type (Target_Type) + and then No (Corresponding_Remote_Type (Opnd_Type)) + then + if Ekind (Base_Type (Opnd_Type)) = E_Anonymous_Access_Subprogram_Type + and then Is_Entity_Name (Operand) + and then Ekind (Entity (Operand)) = E_In_Parameter + and then + (Nkind (Parent (N)) /= N_Assignment_Statement + or else not Is_Entity_Name (Name (Parent (N))) + or else not Is_Return_Object (Entity (Name (Parent (N))))) + then + Error_Msg_N + ("illegal attempt to store anonymous access to subprogram", + Operand); + Error_Msg_N + ("\value has deeper accessibility than any master " & + "(RM 3.10.2 (13))", + Operand); + + Error_Msg_NE + ("\use named access type for& instead of access parameter", + Operand, Entity (Operand)); + end if; + + -- Check that the designated types are subtype conformant + + Check_Subtype_Conformant (New_Id => Designated_Type (Target_Type), + Old_Id => Designated_Type (Opnd_Type), + Err_Loc => N); + + -- Check the static accessibility rule of 4.6(20) + + if Type_Access_Level (Opnd_Type) > + Type_Access_Level (Target_Type) + then + Error_Msg_N + ("operand type has deeper accessibility level than target", + Operand); + + -- Check that if the operand type is declared in a generic body, + -- then the target type must be declared within that same body + -- (enforces last sentence of 4.6(20)). + + elsif Present (Enclosing_Generic_Body (Opnd_Type)) then + declare + O_Gen : constant Node_Id := + Enclosing_Generic_Body (Opnd_Type); + + T_Gen : Node_Id; + + begin + T_Gen := Enclosing_Generic_Body (Target_Type); + while Present (T_Gen) and then T_Gen /= O_Gen loop + T_Gen := Enclosing_Generic_Body (T_Gen); + end loop; + + if T_Gen /= O_Gen then + Error_Msg_N + ("target type must be declared in same generic body" + & " as operand type", N); + end if; + end; + end if; + + return True; + + -- Remote subprogram access types + + elsif Is_Remote_Access_To_Subprogram_Type (Target_Type) + and then Is_Remote_Access_To_Subprogram_Type (Opnd_Type) + then + -- It is valid to convert from one RAS type to another provided + -- that their specification statically match. + + Check_Subtype_Conformant + (New_Id => + Designated_Type (Corresponding_Remote_Type (Target_Type)), + Old_Id => + Designated_Type (Corresponding_Remote_Type (Opnd_Type)), + Err_Loc => + N); + return True; + + -- If both are tagged types, check legality of view conversions + + elsif Is_Tagged_Type (Target_Type) + and then + Is_Tagged_Type (Opnd_Type) + then + return Valid_Tagged_Conversion (Target_Type, Opnd_Type); + + -- Types derived from the same root type are convertible + + elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then + return True; + + -- In an instance or an inlined body, there may be inconsistent views of + -- the same type, or of types derived from a common root. + + elsif (In_Instance or In_Inlined_Body) + and then + Root_Type (Underlying_Type (Target_Type)) = + Root_Type (Underlying_Type (Opnd_Type)) + then + return True; + + -- Special check for common access type error case + + elsif Ekind (Target_Type) = E_Access_Type + and then Is_Access_Type (Opnd_Type) + then + Error_Msg_N ("target type must be general access type!", N); + Error_Msg_NE -- CODEFIX + ("add ALL to }!", N, Target_Type); + return False; + + else + Error_Msg_NE ("invalid conversion, not compatible with }", + N, Opnd_Type); + return False; + end if; + end Valid_Conversion; + +end Sem_Res; diff --git a/gcc/ada/sem_res.ads b/gcc/ada/sem_res.ads new file mode 100644 index 000000000..70b534bf5 --- /dev/null +++ b/gcc/ada/sem_res.ads @@ -0,0 +1,131 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ R E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Resolution processing for all subexpression nodes. Note that the separate +-- package Sem_Aggr contains the actual resolution routines for aggregates, +-- which are separated off since aggregate processing is complex. + +with Types; use Types; + +package Sem_Res is + + -- As described in Sem_Ch4, the type resolution proceeds in two phases. + -- The first phase is a bottom up pass that is achieved during the + -- recursive traversal performed by the Analyze procedures. This phase + -- determines unambiguous types, and collects sets of possible types + -- where the interpretation is potentially ambiguous. + + -- On completing this bottom up pass, which corresponds to a call to + -- Analyze on a complete context, the Resolve routine is called which + -- performs a top down resolution with recursive calls to itself to + -- resolve operands. + + -- Since in practice a lot of semantic analysis has to be postponed until + -- types are known (e.g. static folding, setting of suppress flags), the + -- Resolve routines also complete the semantic analysis, and call the + -- expander for possibly expansion of the completely type resolved node. + + procedure Resolve (N : Node_Id; Typ : Entity_Id); + procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id); + -- Top level type-checking procedure, called in a complete context. The + -- construct N, which is a subexpression, has already been analyzed, and + -- is required to be of type Typ given the analysis of the context (which + -- uses the information gathered on the bottom up phase in Analyze). The + -- resolve routines do various other processing, e.g. static evaluation. + -- If a Suppress argument is present, then the resolution is done with the + -- specified check suppressed (can be All_Checks to suppress all checks). + + procedure Resolve (N : Node_Id); + -- A version of Resolve where the type to be used for resolution is + -- taken from the Etype (N). This is commonly used in cases where the + -- context does not add anything and the first pass of analysis found + -- the correct expected type. + + procedure Resolve_Discrete_Subtype_Indication + (N : Node_Id; + Typ : Entity_Id); + -- Resolve subtype indications in choices (case statements and + -- aggregates) and in index constraints. Note that the resulting Etype + -- of the subtype indication node is set to the Etype of the contained + -- range (i.e. an Itype is not constructed for the actual subtype). + + procedure Resolve_Entry (Entry_Name : Node_Id); + -- Find name of entry being called, and resolve prefix of name with its + -- own type. For now we assume that the prefix cannot be overloaded and + -- the name of the entry plays no role in the resolution. + + procedure Analyze_And_Resolve (N : Node_Id); + procedure Analyze_And_Resolve (N : Node_Id; Typ : Entity_Id); + procedure Analyze_And_Resolve + (N : Node_Id; + Typ : Entity_Id; + Suppress : Check_Id); + procedure Analyze_And_Resolve + (N : Node_Id; + Suppress : Check_Id); + -- These routines combine the effect of Analyze and Resolve. If a Suppress + -- argument is present, then the analysis is done with the specified check + -- suppressed (can be All_Checks to suppress all checks). These checks are + -- suppressed for both the analysis and resolution. If the type argument + -- is not present, then the Etype of the expression after the Analyze + -- call is used for the Resolve. + + procedure Ambiguous_Character (C : Node_Id); + -- Give list of candidate interpretations when a character literal cannot + -- be resolved, for example in a (useless) comparison such as 'A' = 'B'. + -- In Ada95 the literals in question can be of type Character or Wide_ + -- Character. In Ada2005 Wide_Wide_Character is also a candidate. The + -- node may also be overloaded with user-defined character types. + + procedure Check_Parameterless_Call (N : Node_Id); + -- Several forms of names can denote calls to entities without para- + -- meters. The context determines whether the name denotes the entity + -- or a call to it. When it is a call, the node must be rebuilt + -- accordingly and reanalyzed to obtain possible interpretations. + -- + -- The name may be that of an overloadable construct, or it can be an + -- explicit dereference of a prefix that denotes an access to subprogram. + -- In that case, we want to convert the name into a call only if the + -- context requires the return type of the subprogram. Finally, a + -- parameterless protected subprogram appears as a selected component. + -- + -- The parameter T is the Typ for the corresponding resolve call. + + procedure Preanalyze_And_Resolve (N : Node_Id; T : Entity_Id); + -- Performs a pre-analysis of expression node N. During pre-analysis, + -- N is analyzed and then resolved against type T, but no expansion + -- is carried out for N or its children. For more info on pre-analysis + -- read the spec of Sem. + + procedure Preanalyze_And_Resolve (N : Node_Id); + -- Same, but use type of node because context does not impose a single type + +private + procedure Resolve_Implicit_Type (N : Node_Id) renames Resolve; + pragma Inline (Resolve_Implicit_Type); + -- We use this renaming to make the application of Inline very explicit + -- to this version, since other versions of Resolve are not inlined. + +end Sem_Res; diff --git a/gcc/ada/sem_scil.adb b/gcc/ada/sem_scil.adb new file mode 100644 index 000000000..a069a0a63 --- /dev/null +++ b/gcc/ada/sem_scil.adb @@ -0,0 +1,223 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ S C I L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Einfo; use Einfo; +with Nlists; use Nlists; +with Rtsfind; use Rtsfind; +with Sem_Aux; use Sem_Aux; +with Sinfo; use Sinfo; +with Stand; use Stand; +with SCIL_LL; use SCIL_LL; + +package body Sem_SCIL is + + --------------------- + -- Check_SCIL_Node -- + --------------------- + + function Check_SCIL_Node (N : Node_Id) return Traverse_Result is + SCIL_Node : constant Node_Id := Get_SCIL_Node (N); + Ctrl_Tag : Node_Id; + Ctrl_Typ : Entity_Id; + + begin + -- For nodes that do not have SCIL node continue traversing the tree + + if No (SCIL_Node) then + return OK; + end if; + + case Nkind (SCIL_Node) is + when N_SCIL_Dispatch_Table_Tag_Init => + pragma Assert (Nkind (N) = N_Object_Declaration); + null; + + when N_SCIL_Dispatching_Call => + Ctrl_Tag := SCIL_Controlling_Tag (SCIL_Node); + + -- Parent of SCIL dispatching call nodes MUST be a subprogram call + + if not Nkind_In (N, N_Function_Call, + N_Procedure_Call_Statement) + then + pragma Assert (False); + raise Program_Error; + + -- In simple cases the controlling tag is the tag of the + -- controlling argument (i.e. Obj.Tag). + + elsif Nkind (Ctrl_Tag) = N_Selected_Component then + Ctrl_Typ := Etype (Ctrl_Tag); + + -- Interface types are unsupported + + if Is_Interface (Ctrl_Typ) + or else (RTE_Available (RE_Interface_Tag) + and then Ctrl_Typ = RTE (RE_Interface_Tag)) + then + null; + + else + pragma Assert (Ctrl_Typ = RTE (RE_Tag)); + null; + end if; + + -- When the controlling tag of a dispatching call is an identifier + -- the SCIL_Controlling_Tag attribute references the corresponding + -- object or parameter declaration. Interface types are still + -- unsupported. + + elsif Nkind_In (Ctrl_Tag, N_Object_Declaration, + N_Parameter_Specification) + then + Ctrl_Typ := Etype (Defining_Identifier (Ctrl_Tag)); + + -- Interface types are unsupported. + + if Is_Interface (Ctrl_Typ) + or else (RTE_Available (RE_Interface_Tag) + and then Ctrl_Typ = RTE (RE_Interface_Tag)) + or else (Is_Access_Type (Ctrl_Typ) + and then + Is_Interface + (Available_View + (Base_Type (Designated_Type (Ctrl_Typ))))) + then + null; + + else + pragma Assert + (Ctrl_Typ = RTE (RE_Tag) + or else + (Is_Access_Type (Ctrl_Typ) + and then Available_View + (Base_Type (Designated_Type (Ctrl_Typ))) + = RTE (RE_Tag))); + null; + end if; + + -- Interface types are unsupported + + elsif Is_Interface (Etype (Ctrl_Tag)) then + null; + + else + pragma Assert (False); + raise Program_Error; + end if; + + return Skip; + + when N_SCIL_Membership_Test => + + -- Check contents of the boolean expression associated with the + -- membership test. + + pragma Assert (Nkind_In (N, N_Identifier, + N_And_Then, + N_Or_Else, + N_Expression_With_Actions) + and then Etype (N) = Standard_Boolean); + + -- Check the entity identifier of the associated tagged type (that + -- is, in testing for membership in T'Class, the entity id of the + -- specific type T). + + -- Note: When the SCIL node is generated the private and full-view + -- of the tagged types may have been swapped and hence the node + -- referenced by attribute SCIL_Entity may be the private view. + -- Therefore, in order to uniformly locate the full-view we use + -- attribute Underlying_Type. + + pragma Assert + (Is_Tagged_Type (Underlying_Type (SCIL_Entity (SCIL_Node)))); + + -- Interface types are unsupported + + pragma Assert + (not Is_Interface (Underlying_Type (SCIL_Entity (SCIL_Node)))); + + -- Check the decoration of the expression that denotes the tag + -- value being tested + + Ctrl_Tag := SCIL_Tag_Value (SCIL_Node); + + case Nkind (Ctrl_Tag) is + + -- For class-wide membership tests the SCIL tag value is the + -- tag of the tested object (i.e. Obj.Tag). + + when N_Selected_Component => + pragma Assert (Etype (Ctrl_Tag) = RTE (RE_Tag)); + null; + + when others => + pragma Assert (False); + null; + end case; + + return Skip; + + when others => + pragma Assert (False); + raise Program_Error; + end case; + + return Skip; + end Check_SCIL_Node; + + ------------------------- + -- First_Non_SCIL_Node -- + ------------------------- + + function First_Non_SCIL_Node (L : List_Id) return Node_Id is + N : Node_Id; + + begin + N := First (L); + while Nkind (N) in N_SCIL_Node loop + Next (N); + end loop; + + return N; + end First_Non_SCIL_Node; + + ------------------------ + -- Next_Non_SCIL_Node -- + ------------------------ + + function Next_Non_SCIL_Node (N : Node_Id) return Node_Id is + Aux_N : Node_Id; + + begin + Aux_N := Next (N); + while Nkind (Aux_N) in N_SCIL_Node loop + Next (Aux_N); + end loop; + + return Aux_N; + end Next_Non_SCIL_Node; + +end Sem_SCIL; diff --git a/gcc/ada/sem_scil.ads b/gcc/ada/sem_scil.ads new file mode 100644 index 000000000..1a6e45caa --- /dev/null +++ b/gcc/ada/sem_scil.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ S C I L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 involved in the frontend addition and +-- verification of SCIL nodes. + +with Atree; use Atree; +with Types; use Types; + +package Sem_SCIL is + + -- Here would be a good place to document what SCIL is all about ??? + + function Check_SCIL_Node (N : Node_Id) return Traverse_Result; + -- Process a single node during the tree traversal. Done to verify that + -- SCIL nodes decoration fulfill the requirements of the SCIL backend. + + procedure Check_SCIL_Nodes is new Traverse_Proc (Check_SCIL_Node); + -- The traversal procedure itself + + function First_Non_SCIL_Node (L : List_Id) return Node_Id; + -- Returns the first non-SCIL node of list L + + function Next_Non_SCIL_Node (N : Node_Id) return Node_Id; + -- N must be a member of a list. Returns the next non SCIL node in the list + -- containing N, or Empty if this is the last non SCIL node in the list. + +end Sem_SCIL; diff --git a/gcc/ada/sem_smem.adb b/gcc/ada/sem_smem.adb new file mode 100644 index 000000000..bca184ef6 --- /dev/null +++ b/gcc/ada/sem_smem.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ S M E M -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Errout; use Errout; +with Namet; use Namet; +with Sem_Aux; use Sem_Aux; +with Sinfo; use Sinfo; +with Snames; use Snames; + +package body Sem_Smem is + + function Contains_Access_Type (T : Entity_Id) return Boolean; + -- This function determines if type T is an access type, or contains + -- a component (array, record, protected type cases) that contains + -- an access type (recursively defined in the appropriate manner). + + ---------------------- + -- Check_Shared_Var -- + ---------------------- + + procedure Check_Shared_Var + (Id : Entity_Id; + T : Entity_Id; + N : Node_Id) + is + begin + -- We cannot tolerate aliased variables, because they might be + -- modified via an aliased pointer, and we could not detect that + -- this was happening (to update the corresponding shared memory + -- file), so we must disallow all use of Aliased + + if Aliased_Present (N) then + Error_Msg_N + ("aliased variables " & + "not supported in Shared_Passive partitions", + N); + + -- We can't support access types at all, since they are local + -- pointers that cannot in any simple way be transmitted to other + -- partitions. + + elsif Is_Access_Type (T) then + Error_Msg_N + ("access type variables " & + "not supported in Shared_Passive partitions", + Id); + + -- We cannot tolerate types that contain access types, same reasons + + elsif Contains_Access_Type (T) then + Error_Msg_N + ("types containing access components " & + "not supported in Shared_Passive partitions", + Id); + + -- Objects with default-initialized types will be rejected when + -- the initialization code is generated. However we must flag tasks + -- earlier on, to prevent expansion of stream attributes that is + -- bound to fail. + + elsif Has_Task (T) then + Error_Msg_N + ("Shared_Passive partitions cannot contain tasks", Id); + + -- Currently we do not support unconstrained record types, since we + -- use 'Write to write out values. This could probably be special + -- cased and handled in the future if necessary. + + elsif Is_Record_Type (T) + and then not Is_Constrained (T) + then + Error_Msg_N + ("unconstrained variant records " & + "not supported in Shared_Passive partitions", + Id); + end if; + end Check_Shared_Var; + + -------------------------- + -- Contains_Access_Type -- + -------------------------- + + function Contains_Access_Type (T : Entity_Id) return Boolean is + C : Entity_Id; + + begin + if Is_Access_Type (T) then + return True; + + elsif Is_Array_Type (T) then + return Contains_Access_Type (Component_Type (T)); + + elsif Is_Record_Type (T) then + if Has_Discriminants (T) then + C := First_Discriminant (T); + while Present (C) loop + if Comes_From_Source (C) then + return True; + else + C := Next_Discriminant (C); + end if; + end loop; + end if; + + C := First_Component (T); + while Present (C) loop + + -- For components, ignore internal components other than _Parent + + if Comes_From_Source (T) + and then + (Chars (C) = Name_uParent + or else + not Is_Internal_Name (Chars (C))) + and then Contains_Access_Type (Etype (C)) + then + return True; + else + C := Next_Component (C); + end if; + end loop; + + return False; + + elsif Is_Protected_Type (T) then + return Contains_Access_Type (Corresponding_Record_Type (T)); + + else + return False; + end if; + end Contains_Access_Type; + +end Sem_Smem; diff --git a/gcc/ada/sem_smem.ads b/gcc/ada/sem_smem.ads new file mode 100644 index 000000000..82bcb05a5 --- /dev/null +++ b/gcc/ada/sem_smem.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ S M E M -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 involved in processing of shared memory +-- variables, i.e. variables declared in shared passive partitions. + +with Types; use Types; +package Sem_Smem is + + procedure Check_Shared_Var + (Id : Entity_Id; + T : Entity_Id; + N : Node_Id); + -- This routine checks that the object declaration, N, for identifier, + -- Id, of type, T, is valid, i.e. that it does not violate restrictions + -- on the kind of variables we support in shared passive partitions. + +end Sem_Smem; diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb new file mode 100644 index 000000000..08d273e37 --- /dev/null +++ b/gcc/ada/sem_type.adb @@ -0,0 +1,3295 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ T Y P E -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Alloc; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Nlists; use Nlists; +with Errout; use Errout; +with Lib; use Lib; +with Namet; use Namet; +with Opt; use Opt; +with Output; use Output; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch12; use Sem_Ch12; +with Sem_Disp; use Sem_Disp; +with Sem_Dist; use Sem_Dist; +with Sem_Util; use Sem_Util; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Table; +with Uintp; use Uintp; + +package body Sem_Type is + + --------------------- + -- Data Structures -- + --------------------- + + -- The following data structures establish a mapping between nodes and + -- their interpretations. An overloaded node has an entry in Interp_Map, + -- which in turn contains a pointer into the All_Interp array. The + -- interpretations of a given node are contiguous in All_Interp. Each set + -- of interpretations is terminated with the marker No_Interp. In order to + -- speed up the retrieval of the interpretations of an overloaded node, the + -- Interp_Map table is accessed by means of a simple hashing scheme, and + -- the entries in Interp_Map are chained. The heads of clash lists are + -- stored in array Headers. + + -- Headers Interp_Map All_Interp + + -- _ +-----+ +--------+ + -- |_| |_____| --->|interp1 | + -- |_|---------->|node | | |interp2 | + -- |_| |index|---------| |nointerp| + -- |_| |next | | | + -- |-----| | | + -- +-----+ +--------+ + + -- This scheme does not currently reclaim interpretations. In principle, + -- after a unit is compiled, all overloadings have been resolved, and the + -- candidate interpretations should be deleted. This should be easier + -- now than with the previous scheme??? + + package All_Interp is new Table.Table ( + Table_Component_Type => Interp, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.All_Interp_Initial, + Table_Increment => Alloc.All_Interp_Increment, + Table_Name => "All_Interp"); + + type Interp_Ref is record + Node : Node_Id; + Index : Interp_Index; + Next : Int; + end record; + + Header_Size : constant Int := 2 ** 12; + No_Entry : constant Int := -1; + Headers : array (0 .. Header_Size) of Int := (others => No_Entry); + + package Interp_Map is new Table.Table ( + Table_Component_Type => Interp_Ref, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.Interp_Map_Initial, + Table_Increment => Alloc.Interp_Map_Increment, + Table_Name => "Interp_Map"); + + function Hash (N : Node_Id) return Int; + -- A trivial hashing function for nodes, used to insert an overloaded + -- node into the Interp_Map table. + + ------------------------------------- + -- Handling of Overload Resolution -- + ------------------------------------- + + -- Overload resolution uses two passes over the syntax tree of a complete + -- context. In the first, bottom-up pass, the types of actuals in calls + -- are used to resolve possibly overloaded subprogram and operator names. + -- In the second top-down pass, the type of the context (for example the + -- condition in a while statement) is used to resolve a possibly ambiguous + -- call, and the unique subprogram name in turn imposes a specific context + -- on each of its actuals. + + -- Most expressions are in fact unambiguous, and the bottom-up pass is + -- sufficient to resolve most everything. To simplify the common case, + -- names and expressions carry a flag Is_Overloaded to indicate whether + -- they have more than one interpretation. If the flag is off, then each + -- name has already a unique meaning and type, and the bottom-up pass is + -- sufficient (and much simpler). + + -------------------------- + -- Operator Overloading -- + -------------------------- + + -- The visibility of operators is handled differently from that of other + -- entities. We do not introduce explicit versions of primitive operators + -- for each type definition. As a result, there is only one entity + -- corresponding to predefined addition on all numeric types, etc. The + -- back-end resolves predefined operators according to their type. The + -- visibility of primitive operations then reduces to the visibility of the + -- resulting type: (a + b) is a legal interpretation of some primitive + -- operator + if the type of the result (which must also be the type of a + -- and b) is directly visible (either immediately visible or use-visible). + + -- User-defined operators are treated like other functions, but the + -- visibility of these user-defined operations must be special-cased + -- to determine whether they hide or are hidden by predefined operators. + -- The form P."+" (x, y) requires additional handling. + + -- Concatenation is treated more conventionally: for every one-dimensional + -- array type we introduce a explicit concatenation operator. This is + -- necessary to handle the case of (element & element => array) which + -- cannot be handled conveniently if there is no explicit instance of + -- resulting type of the operation. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure All_Overloads; + pragma Warnings (Off, All_Overloads); + -- Debugging procedure: list full contents of Overloads table + + function Binary_Op_Interp_Has_Abstract_Op + (N : Node_Id; + E : Entity_Id) return Entity_Id; + -- Given the node and entity of a binary operator, determine whether the + -- actuals of E contain an abstract interpretation with regards to the + -- types of their corresponding formals. Return the abstract operation or + -- Empty. + + function Function_Interp_Has_Abstract_Op + (N : Node_Id; + E : Entity_Id) return Entity_Id; + -- Given the node and entity of a function call, determine whether the + -- actuals of E contain an abstract interpretation with regards to the + -- types of their corresponding formals. Return the abstract operation or + -- Empty. + + function Has_Abstract_Op + (N : Node_Id; + Typ : Entity_Id) return Entity_Id; + -- Subsidiary routine to Binary_Op_Interp_Has_Abstract_Op and Function_ + -- Interp_Has_Abstract_Op. Determine whether an overloaded node has an + -- abstract interpretation which yields type Typ. + + procedure New_Interps (N : Node_Id); + -- Initialize collection of interpretations for the given node, which is + -- either an overloaded entity, or an operation whose arguments have + -- multiple interpretations. Interpretations can be added to only one + -- node at a time. + + function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id; + -- If Typ_1 and Typ_2 are compatible, return the one that is not universal + -- or is not a "class" type (any_character, etc). + + -------------------- + -- Add_One_Interp -- + -------------------- + + procedure Add_One_Interp + (N : Node_Id; + E : Entity_Id; + T : Entity_Id; + Opnd_Type : Entity_Id := Empty) + is + Vis_Type : Entity_Id; + + procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id); + -- Add one interpretation to an overloaded node. Add a new entry if + -- not hidden by previous one, and remove previous one if hidden by + -- new one. + + function Is_Universal_Operation (Op : Entity_Id) return Boolean; + -- True if the entity is a predefined operator and the operands have + -- a universal Interpretation. + + --------------- + -- Add_Entry -- + --------------- + + procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id) is + Abstr_Op : Entity_Id := Empty; + I : Interp_Index; + It : Interp; + + -- Start of processing for Add_Entry + + begin + -- Find out whether the new entry references interpretations that + -- are abstract or disabled by abstract operators. + + if Ada_Version >= Ada_2005 then + if Nkind (N) in N_Binary_Op then + Abstr_Op := Binary_Op_Interp_Has_Abstract_Op (N, Name); + elsif Nkind (N) = N_Function_Call then + Abstr_Op := Function_Interp_Has_Abstract_Op (N, Name); + end if; + end if; + + Get_First_Interp (N, I, It); + while Present (It.Nam) loop + + -- A user-defined subprogram hides another declared at an outer + -- level, or one that is use-visible. So return if previous + -- definition hides new one (which is either in an outer + -- scope, or use-visible). Note that for functions use-visible + -- is the same as potentially use-visible. If new one hides + -- previous one, replace entry in table of interpretations. + -- If this is a universal operation, retain the operator in case + -- preference rule applies. + + if (((Ekind (Name) = E_Function or else Ekind (Name) = E_Procedure) + and then Ekind (Name) = Ekind (It.Nam)) + or else (Ekind (Name) = E_Operator + and then Ekind (It.Nam) = E_Function)) + + and then Is_Immediately_Visible (It.Nam) + and then Type_Conformant (Name, It.Nam) + and then Base_Type (It.Typ) = Base_Type (T) + then + if Is_Universal_Operation (Name) then + exit; + + -- If node is an operator symbol, we have no actuals with + -- which to check hiding, and this is done in full in the + -- caller (Analyze_Subprogram_Renaming) so we include the + -- predefined operator in any case. + + elsif Nkind (N) = N_Operator_Symbol + or else (Nkind (N) = N_Expanded_Name + and then + Nkind (Selector_Name (N)) = N_Operator_Symbol) + then + exit; + + elsif not In_Open_Scopes (Scope (Name)) + or else Scope_Depth (Scope (Name)) <= + Scope_Depth (Scope (It.Nam)) + then + -- If ambiguity within instance, and entity is not an + -- implicit operation, save for later disambiguation. + + if Scope (Name) = Scope (It.Nam) + and then not Is_Inherited_Operation (Name) + and then In_Instance + then + exit; + else + return; + end if; + + else + All_Interp.Table (I).Nam := Name; + return; + end if; + + -- Avoid making duplicate entries in overloads + + elsif Name = It.Nam + and then Base_Type (It.Typ) = Base_Type (T) + then + return; + + -- Otherwise keep going + + else + Get_Next_Interp (I, It); + end if; + + end loop; + + All_Interp.Table (All_Interp.Last) := (Name, Typ, Abstr_Op); + All_Interp.Append (No_Interp); + end Add_Entry; + + ---------------------------- + -- Is_Universal_Operation -- + ---------------------------- + + function Is_Universal_Operation (Op : Entity_Id) return Boolean is + Arg : Node_Id; + + begin + if Ekind (Op) /= E_Operator then + return False; + + elsif Nkind (N) in N_Binary_Op then + return Present (Universal_Interpretation (Left_Opnd (N))) + and then Present (Universal_Interpretation (Right_Opnd (N))); + + elsif Nkind (N) in N_Unary_Op then + return Present (Universal_Interpretation (Right_Opnd (N))); + + elsif Nkind (N) = N_Function_Call then + Arg := First_Actual (N); + while Present (Arg) loop + if No (Universal_Interpretation (Arg)) then + return False; + end if; + + Next_Actual (Arg); + end loop; + + return True; + + else + return False; + end if; + end Is_Universal_Operation; + + -- Start of processing for Add_One_Interp + + begin + -- If the interpretation is a predefined operator, verify that the + -- result type is visible, or that the entity has already been + -- resolved (case of an instantiation node that refers to a predefined + -- operation, or an internally generated operator node, or an operator + -- given as an expanded name). If the operator is a comparison or + -- equality, it is the type of the operand that matters to determine + -- whether the operator is visible. In an instance, the check is not + -- performed, given that the operator was visible in the generic. + + if Ekind (E) = E_Operator then + if Present (Opnd_Type) then + Vis_Type := Opnd_Type; + else + Vis_Type := Base_Type (T); + end if; + + if In_Open_Scopes (Scope (Vis_Type)) + or else Is_Potentially_Use_Visible (Vis_Type) + or else In_Use (Vis_Type) + or else (In_Use (Scope (Vis_Type)) + and then not Is_Hidden (Vis_Type)) + or else Nkind (N) = N_Expanded_Name + or else (Nkind (N) in N_Op and then E = Entity (N)) + or else In_Instance + or else Ekind (Vis_Type) = E_Anonymous_Access_Type + then + null; + + -- If the node is given in functional notation and the prefix + -- is an expanded name, then the operator is visible if the + -- prefix is the scope of the result type as well. If the + -- operator is (implicitly) defined in an extension of system, + -- it is know to be valid (see Defined_In_Scope, sem_ch4.adb). + + elsif Nkind (N) = N_Function_Call + and then Nkind (Name (N)) = N_Expanded_Name + and then (Entity (Prefix (Name (N))) = Scope (Base_Type (T)) + or else Entity (Prefix (Name (N))) = Scope (Vis_Type) + or else Scope (Vis_Type) = System_Aux_Id) + then + null; + + -- Save type for subsequent error message, in case no other + -- interpretation is found. + + else + Candidate_Type := Vis_Type; + return; + end if; + + -- In an instance, an abstract non-dispatching operation cannot be a + -- candidate interpretation, because it could not have been one in the + -- generic (it may be a spurious overloading in the instance). + + elsif In_Instance + and then Is_Overloadable (E) + and then Is_Abstract_Subprogram (E) + and then not Is_Dispatching_Operation (E) + then + return; + + -- An inherited interface operation that is implemented by some derived + -- type does not participate in overload resolution, only the + -- implementation operation does. + + elsif Is_Hidden (E) + and then Is_Subprogram (E) + and then Present (Interface_Alias (E)) + then + -- Ada 2005 (AI-251): If this primitive operation corresponds with + -- an immediate ancestor interface there is no need to add it to the + -- list of interpretations. The corresponding aliased primitive is + -- also in this list of primitive operations and will be used instead + -- because otherwise we have a dummy ambiguity between the two + -- subprograms which are in fact the same. + + if not Is_Ancestor + (Find_Dispatching_Type (Interface_Alias (E)), + Find_Dispatching_Type (E)) + then + Add_One_Interp (N, Interface_Alias (E), T); + end if; + + return; + + -- Calling stubs for an RACW operation never participate in resolution, + -- they are executed only through dispatching calls. + + elsif Is_RACW_Stub_Type_Operation (E) then + return; + end if; + + -- If this is the first interpretation of N, N has type Any_Type. + -- In that case place the new type on the node. If one interpretation + -- already exists, indicate that the node is overloaded, and store + -- both the previous and the new interpretation in All_Interp. If + -- this is a later interpretation, just add it to the set. + + if Etype (N) = Any_Type then + if Is_Type (E) then + Set_Etype (N, T); + + else + -- Record both the operator or subprogram name, and its type + + if Nkind (N) in N_Op or else Is_Entity_Name (N) then + Set_Entity (N, E); + end if; + + Set_Etype (N, T); + end if; + + -- Either there is no current interpretation in the table for any + -- node or the interpretation that is present is for a different + -- node. In both cases add a new interpretation to the table. + + elsif Interp_Map.Last < 0 + or else + (Interp_Map.Table (Interp_Map.Last).Node /= N + and then not Is_Overloaded (N)) + then + New_Interps (N); + + if (Nkind (N) in N_Op or else Is_Entity_Name (N)) + and then Present (Entity (N)) + then + Add_Entry (Entity (N), Etype (N)); + + elsif Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) + and then Is_Entity_Name (Name (N)) + then + Add_Entry (Entity (Name (N)), Etype (N)); + + -- If this is an indirect call there will be no name associated + -- with the previous entry. To make diagnostics clearer, save + -- Subprogram_Type of first interpretation, so that the error will + -- point to the anonymous access to subprogram, not to the result + -- type of the call itself. + + elsif (Nkind (N)) = N_Function_Call + and then Nkind (Name (N)) = N_Explicit_Dereference + and then Is_Overloaded (Name (N)) + then + declare + It : Interp; + + Itn : Interp_Index; + pragma Warnings (Off, Itn); + + begin + Get_First_Interp (Name (N), Itn, It); + Add_Entry (It.Nam, Etype (N)); + end; + + else + -- Overloaded prefix in indexed or selected component, or call + -- whose name is an expression or another call. + + Add_Entry (Etype (N), Etype (N)); + end if; + + Add_Entry (E, T); + + else + Add_Entry (E, T); + end if; + end Add_One_Interp; + + ------------------- + -- All_Overloads -- + ------------------- + + procedure All_Overloads is + begin + for J in All_Interp.First .. All_Interp.Last loop + + if Present (All_Interp.Table (J).Nam) then + Write_Entity_Info (All_Interp.Table (J). Nam, " "); + else + Write_Str ("No Interp"); + Write_Eol; + end if; + + Write_Str ("================="); + Write_Eol; + end loop; + end All_Overloads; + + -------------------------------------- + -- Binary_Op_Interp_Has_Abstract_Op -- + -------------------------------------- + + function Binary_Op_Interp_Has_Abstract_Op + (N : Node_Id; + E : Entity_Id) return Entity_Id + is + Abstr_Op : Entity_Id; + E_Left : constant Node_Id := First_Formal (E); + E_Right : constant Node_Id := Next_Formal (E_Left); + + begin + Abstr_Op := Has_Abstract_Op (Left_Opnd (N), Etype (E_Left)); + if Present (Abstr_Op) then + return Abstr_Op; + end if; + + return Has_Abstract_Op (Right_Opnd (N), Etype (E_Right)); + end Binary_Op_Interp_Has_Abstract_Op; + + --------------------- + -- Collect_Interps -- + --------------------- + + procedure Collect_Interps (N : Node_Id) is + Ent : constant Entity_Id := Entity (N); + H : Entity_Id; + First_Interp : Interp_Index; + + begin + New_Interps (N); + + -- Unconditionally add the entity that was initially matched + + First_Interp := All_Interp.Last; + Add_One_Interp (N, Ent, Etype (N)); + + -- For expanded name, pick up all additional entities from the + -- same scope, since these are obviously also visible. Note that + -- these are not necessarily contiguous on the homonym chain. + + if Nkind (N) = N_Expanded_Name then + H := Homonym (Ent); + while Present (H) loop + if Scope (H) = Scope (Entity (N)) then + Add_One_Interp (N, H, Etype (H)); + end if; + + H := Homonym (H); + end loop; + + -- Case of direct name + + else + -- First, search the homonym chain for directly visible entities + + H := Current_Entity (Ent); + while Present (H) loop + exit when (not Is_Overloadable (H)) + and then Is_Immediately_Visible (H); + + if Is_Immediately_Visible (H) + and then H /= Ent + then + -- Only add interpretation if not hidden by an inner + -- immediately visible one. + + for J in First_Interp .. All_Interp.Last - 1 loop + + -- Current homograph is not hidden. Add to overloads + + if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then + exit; + + -- Homograph is hidden, unless it is a predefined operator + + elsif Type_Conformant (H, All_Interp.Table (J).Nam) then + + -- A homograph in the same scope can occur within an + -- instantiation, the resulting ambiguity has to be + -- resolved later. + + if Scope (H) = Scope (Ent) + and then In_Instance + and then not Is_Inherited_Operation (H) + then + All_Interp.Table (All_Interp.Last) := + (H, Etype (H), Empty); + All_Interp.Append (No_Interp); + goto Next_Homograph; + + elsif Scope (H) /= Standard_Standard then + goto Next_Homograph; + end if; + end if; + end loop; + + -- On exit, we know that current homograph is not hidden + + Add_One_Interp (N, H, Etype (H)); + + if Debug_Flag_E then + Write_Str ("Add overloaded interpretation "); + Write_Int (Int (H)); + Write_Eol; + end if; + end if; + + <> + H := Homonym (H); + end loop; + + -- Scan list of homographs for use-visible entities only + + H := Current_Entity (Ent); + + while Present (H) loop + if Is_Potentially_Use_Visible (H) + and then H /= Ent + and then Is_Overloadable (H) + then + for J in First_Interp .. All_Interp.Last - 1 loop + + if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then + exit; + + elsif Type_Conformant (H, All_Interp.Table (J).Nam) then + goto Next_Use_Homograph; + end if; + end loop; + + Add_One_Interp (N, H, Etype (H)); + end if; + + <> + H := Homonym (H); + end loop; + end if; + + if All_Interp.Last = First_Interp + 1 then + + -- The final interpretation is in fact not overloaded. Note that the + -- unique legal interpretation may or may not be the original one, + -- so we need to update N's entity and etype now, because once N + -- is marked as not overloaded it is also expected to carry the + -- proper interpretation. + + Set_Is_Overloaded (N, False); + Set_Entity (N, All_Interp.Table (First_Interp).Nam); + Set_Etype (N, All_Interp.Table (First_Interp).Typ); + end if; + end Collect_Interps; + + ------------ + -- Covers -- + ------------ + + function Covers (T1, T2 : Entity_Id) return Boolean is + + BT1 : Entity_Id; + BT2 : Entity_Id; + + function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean; + -- In an instance the proper view may not always be correct for + -- private types, but private and full view are compatible. This + -- removes spurious errors from nested instantiations that involve, + -- among other things, types derived from private types. + + ---------------------- + -- Full_View_Covers -- + ---------------------- + + function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean is + begin + return + Is_Private_Type (Typ1) + and then + ((Present (Full_View (Typ1)) + and then Covers (Full_View (Typ1), Typ2)) + or else Base_Type (Typ1) = Typ2 + or else Base_Type (Typ2) = Typ1); + end Full_View_Covers; + + -- Start of processing for Covers + + begin + -- If either operand missing, then this is an error, but ignore it (and + -- pretend we have a cover) if errors already detected, since this may + -- simply mean we have malformed trees or a semantic error upstream. + + if No (T1) or else No (T2) then + if Total_Errors_Detected /= 0 then + return True; + else + raise Program_Error; + end if; + + else + BT1 := Base_Type (T1); + BT2 := Base_Type (T2); + + -- Handle underlying view of records with unknown discriminants + -- using the original entity that motivated the construction of + -- this underlying record view (see Build_Derived_Private_Type). + + if Is_Underlying_Record_View (BT1) then + BT1 := Underlying_Record_View (BT1); + end if; + + if Is_Underlying_Record_View (BT2) then + BT2 := Underlying_Record_View (BT2); + end if; + end if; + + -- First check for Standard_Void_Type, which is special. Subsequent + -- processing in this routine assumes T1 and T2 are bona fide types; + -- Standard_Void_Type is a special entity that has some, but not all, + -- properties of types. + + if (T1 = Standard_Void_Type) /= (T2 = Standard_Void_Type) then + return False; + + -- Simplest case: same types are compatible, and types that have the + -- same base type and are not generic actuals are compatible. Generic + -- actuals belong to their class but are not compatible with other + -- types of their class, and in particular with other generic actuals. + -- They are however compatible with their own subtypes, and itypes + -- with the same base are compatible as well. Similarly, constrained + -- subtypes obtained from expressions of an unconstrained nominal type + -- are compatible with the base type (may lead to spurious ambiguities + -- in obscure cases ???) + + -- Generic actuals require special treatment to avoid spurious ambi- + -- guities in an instance, when two formal types are instantiated with + -- the same actual, so that different subprograms end up with the same + -- signature in the instance. + + elsif T1 = T2 then + return True; + + elsif BT1 = BT2 + or else BT1 = T2 + or else BT2 = T1 + then + if not Is_Generic_Actual_Type (T1) then + return True; + else + return (not Is_Generic_Actual_Type (T2) + or else Is_Itype (T1) + or else Is_Itype (T2) + or else Is_Constr_Subt_For_U_Nominal (T1) + or else Is_Constr_Subt_For_U_Nominal (T2) + or else Scope (T1) /= Scope (T2)); + end if; + + -- Literals are compatible with types in a given "class" + + elsif (T2 = Universal_Integer and then Is_Integer_Type (T1)) + or else (T2 = Universal_Real and then Is_Real_Type (T1)) + or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1)) + or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1)) + or else (T2 = Any_String and then Is_String_Type (T1)) + or else (T2 = Any_Character and then Is_Character_Type (T1)) + or else (T2 = Any_Access and then Is_Access_Type (T1)) + then + return True; + + -- The context may be class wide, and a class-wide type is compatible + -- with any member of the class. + + elsif Is_Class_Wide_Type (T1) + and then Is_Ancestor (Root_Type (T1), T2) + then + return True; + + elsif Is_Class_Wide_Type (T1) + and then Is_Class_Wide_Type (T2) + and then Base_Type (Etype (T1)) = Base_Type (Etype (T2)) + then + return True; + + -- Ada 2005 (AI-345): A class-wide abstract interface type covers a + -- task_type or protected_type that implements the interface. + + elsif Ada_Version >= Ada_2005 + and then Is_Class_Wide_Type (T1) + and then Is_Interface (Etype (T1)) + and then Is_Concurrent_Type (T2) + and then Interface_Present_In_Ancestor + (Typ => Base_Type (T2), + Iface => Etype (T1)) + then + return True; + + -- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an + -- object T2 implementing T1 + + elsif Ada_Version >= Ada_2005 + and then Is_Class_Wide_Type (T1) + and then Is_Interface (Etype (T1)) + and then Is_Tagged_Type (T2) + then + if Interface_Present_In_Ancestor (Typ => T2, + Iface => Etype (T1)) + then + return True; + end if; + + declare + E : Entity_Id; + Elmt : Elmt_Id; + + begin + if Is_Concurrent_Type (BT2) then + E := Corresponding_Record_Type (BT2); + else + E := BT2; + end if; + + -- Ada 2005 (AI-251): A class-wide abstract interface type T1 + -- covers an object T2 that implements a direct derivation of T1. + -- Note: test for presence of E is defense against previous error. + + if Present (E) + and then Present (Interfaces (E)) + then + Elmt := First_Elmt (Interfaces (E)); + while Present (Elmt) loop + if Is_Ancestor (Etype (T1), Node (Elmt)) then + return True; + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + -- We should also check the case in which T1 is an ancestor of + -- some implemented interface??? + + return False; + end; + + -- In a dispatching call the actual may be class-wide, the formal + -- may be its specific type, or that of a descendent of it. + + elsif Is_Class_Wide_Type (T2) + and then + (Class_Wide_Type (T1) = T2 + or else Base_Type (Root_Type (T2)) = Base_Type (T1)) + then + return True; + + -- Some contexts require a class of types rather than a specific type. + -- For example, conditions require any boolean type, fixed point + -- attributes require some real type, etc. The built-in types Any_XXX + -- represent these classes. + + elsif (T1 = Any_Integer and then Is_Integer_Type (T2)) + or else (T1 = Any_Boolean and then Is_Boolean_Type (T2)) + or else (T1 = Any_Real and then Is_Real_Type (T2)) + or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2)) + or else (T1 = Any_Discrete and then Is_Discrete_Type (T2)) + then + return True; + + -- An aggregate is compatible with an array or record type + + elsif T2 = Any_Composite + and then Is_Aggregate_Type (T1) + then + return True; + + -- If the expected type is an anonymous access, the designated type must + -- cover that of the expression. Use the base type for this check: even + -- though access subtypes are rare in sources, they are generated for + -- actuals in instantiations. + + elsif Ekind (BT1) = E_Anonymous_Access_Type + and then Is_Access_Type (T2) + and then Covers (Designated_Type (T1), Designated_Type (T2)) + then + return True; + + -- An Access_To_Subprogram is compatible with itself, or with an + -- anonymous type created for an attribute reference Access. + + elsif (Ekind (BT1) = E_Access_Subprogram_Type + or else + Ekind (BT1) = E_Access_Protected_Subprogram_Type) + and then Is_Access_Type (T2) + and then (not Comes_From_Source (T1) + or else not Comes_From_Source (T2)) + and then (Is_Overloadable (Designated_Type (T2)) + or else + Ekind (Designated_Type (T2)) = E_Subprogram_Type) + and then + Type_Conformant (Designated_Type (T1), Designated_Type (T2)) + and then + Mode_Conformant (Designated_Type (T1), Designated_Type (T2)) + then + return True; + + -- Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible + -- with itself, or with an anonymous type created for an attribute + -- reference Access. + + elsif (Ekind (BT1) = E_Anonymous_Access_Subprogram_Type + or else + Ekind (BT1) + = E_Anonymous_Access_Protected_Subprogram_Type) + and then Is_Access_Type (T2) + and then (not Comes_From_Source (T1) + or else not Comes_From_Source (T2)) + and then (Is_Overloadable (Designated_Type (T2)) + or else + Ekind (Designated_Type (T2)) = E_Subprogram_Type) + and then + Type_Conformant (Designated_Type (T1), Designated_Type (T2)) + and then + Mode_Conformant (Designated_Type (T1), Designated_Type (T2)) + then + return True; + + -- The context can be a remote access type, and the expression the + -- corresponding source type declared in a categorized package, or + -- vice versa. + + elsif Is_Record_Type (T1) + and then (Is_Remote_Call_Interface (T1) + or else Is_Remote_Types (T1)) + and then Present (Corresponding_Remote_Type (T1)) + then + return Covers (Corresponding_Remote_Type (T1), T2); + + -- and conversely. + + elsif Is_Record_Type (T2) + and then (Is_Remote_Call_Interface (T2) + or else Is_Remote_Types (T2)) + and then Present (Corresponding_Remote_Type (T2)) + then + return Covers (Corresponding_Remote_Type (T2), T1); + + -- Synchronized types are represented at run time by their corresponding + -- record type. During expansion one is replaced with the other, but + -- they are compatible views of the same type. + + elsif Is_Record_Type (T1) + and then Is_Concurrent_Type (T2) + and then Present (Corresponding_Record_Type (T2)) + then + return Covers (T1, Corresponding_Record_Type (T2)); + + elsif Is_Concurrent_Type (T1) + and then Present (Corresponding_Record_Type (T1)) + and then Is_Record_Type (T2) + then + return Covers (Corresponding_Record_Type (T1), T2); + + -- During analysis, an attribute reference 'Access has a special type + -- kind: Access_Attribute_Type, to be replaced eventually with the type + -- imposed by context. + + elsif Ekind (T2) = E_Access_Attribute_Type + and then Ekind_In (BT1, E_General_Access_Type, E_Access_Type) + and then Covers (Designated_Type (T1), Designated_Type (T2)) + then + -- If the target type is a RACW type while the source is an access + -- attribute type, we are building a RACW that may be exported. + + if Is_Remote_Access_To_Class_Wide_Type (BT1) then + Set_Has_RACW (Current_Sem_Unit); + end if; + + return True; + + -- Ditto for allocators, which eventually resolve to the context type + + elsif Ekind (T2) = E_Allocator_Type + and then Is_Access_Type (T1) + then + return Covers (Designated_Type (T1), Designated_Type (T2)) + or else + (From_With_Type (Designated_Type (T1)) + and then Covers (Designated_Type (T2), Designated_Type (T1))); + + -- A boolean operation on integer literals is compatible with modular + -- context. + + elsif T2 = Any_Modular + and then Is_Modular_Integer_Type (T1) + then + return True; + + -- The actual type may be the result of a previous error + + elsif Base_Type (T2) = Any_Type then + return True; + + -- A packed array type covers its corresponding non-packed type. This is + -- not legitimate Ada, but allows the omission of a number of otherwise + -- useless unchecked conversions, and since this can only arise in + -- (known correct) expanded code, no harm is done. + + elsif Is_Array_Type (T2) + and then Is_Packed (T2) + and then T1 = Packed_Array_Type (T2) + then + return True; + + -- Similarly an array type covers its corresponding packed array type + + elsif Is_Array_Type (T1) + and then Is_Packed (T1) + and then T2 = Packed_Array_Type (T1) + then + return True; + + -- In instances, or with types exported from instantiations, check + -- whether a partial and a full view match. Verify that types are + -- legal, to prevent cascaded errors. + + elsif In_Instance + and then + (Full_View_Covers (T1, T2) + or else Full_View_Covers (T2, T1)) + then + return True; + + elsif Is_Type (T2) + and then Is_Generic_Actual_Type (T2) + and then Full_View_Covers (T1, T2) + then + return True; + + elsif Is_Type (T1) + and then Is_Generic_Actual_Type (T1) + and then Full_View_Covers (T2, T1) + then + return True; + + -- In the expansion of inlined bodies, types are compatible if they + -- are structurally equivalent. + + elsif In_Inlined_Body + and then (Underlying_Type (T1) = Underlying_Type (T2) + or else (Is_Access_Type (T1) + and then Is_Access_Type (T2) + and then + Designated_Type (T1) = Designated_Type (T2)) + or else (T1 = Any_Access + and then Is_Access_Type (Underlying_Type (T2))) + or else (T2 = Any_Composite + and then + Is_Composite_Type (Underlying_Type (T1)))) + then + return True; + + -- Ada 2005 (AI-50217): Additional branches to make the shadow entity + -- obtained through a limited_with compatible with its real entity. + + elsif From_With_Type (T1) then + + -- If the expected type is the non-limited view of a type, the + -- expression may have the limited view. If that one in turn is + -- incomplete, get full view if available. + + if Is_Incomplete_Type (T1) then + return Covers (Get_Full_View (Non_Limited_View (T1)), T2); + + elsif Ekind (T1) = E_Class_Wide_Type then + return + Covers (Class_Wide_Type (Non_Limited_View (Etype (T1))), T2); + else + return False; + end if; + + elsif From_With_Type (T2) then + + -- If units in the context have Limited_With clauses on each other, + -- either type might have a limited view. Checks performed elsewhere + -- verify that the context type is the nonlimited view. + + if Is_Incomplete_Type (T2) then + return Covers (T1, Get_Full_View (Non_Limited_View (T2))); + + elsif Ekind (T2) = E_Class_Wide_Type then + return + Present (Non_Limited_View (Etype (T2))) + and then + Covers (T1, Class_Wide_Type (Non_Limited_View (Etype (T2)))); + else + return False; + end if; + + -- Ada 2005 (AI-412): Coverage for regular incomplete subtypes + + elsif Ekind (T1) = E_Incomplete_Subtype then + return Covers (Full_View (Etype (T1)), T2); + + elsif Ekind (T2) = E_Incomplete_Subtype then + return Covers (T1, Full_View (Etype (T2))); + + -- Ada 2005 (AI-423): Coverage of formal anonymous access types + -- and actual anonymous access types in the context of generic + -- instantiations. We have the following situation: + + -- generic + -- type Formal is private; + -- Formal_Obj : access Formal; -- T1 + -- package G is ... + + -- package P is + -- type Actual is ... + -- Actual_Obj : access Actual; -- T2 + -- package Instance is new G (Formal => Actual, + -- Formal_Obj => Actual_Obj); + + elsif Ada_Version >= Ada_2005 + and then Ekind (T1) = E_Anonymous_Access_Type + and then Ekind (T2) = E_Anonymous_Access_Type + and then Is_Generic_Type (Directly_Designated_Type (T1)) + and then Get_Instance_Of (Directly_Designated_Type (T1)) = + Directly_Designated_Type (T2) + then + return True; + + -- Otherwise, types are not compatible! + + else + return False; + end if; + end Covers; + + ------------------ + -- Disambiguate -- + ------------------ + + function Disambiguate + (N : Node_Id; + I1, I2 : Interp_Index; + Typ : Entity_Id) return Interp + is + I : Interp_Index; + It : Interp; + It1, It2 : Interp; + Nam1, Nam2 : Entity_Id; + Predef_Subp : Entity_Id; + User_Subp : Entity_Id; + + function Inherited_From_Actual (S : Entity_Id) return Boolean; + -- Determine whether one of the candidates is an operation inherited by + -- a type that is derived from an actual in an instantiation. + + function Is_Actual_Subprogram (S : Entity_Id) return Boolean; + -- Determine whether a subprogram is an actual in an enclosing instance. + -- An overloading between such a subprogram and one declared outside the + -- instance is resolved in favor of the first, because it resolved in + -- the generic. + + function Matches (Actual, Formal : Node_Id) return Boolean; + -- Look for exact type match in an instance, to remove spurious + -- ambiguities when two formal types have the same actual. + + function Standard_Operator return Boolean; + -- Check whether subprogram is predefined operator declared in Standard. + -- It may given by an operator name, or by an expanded name whose prefix + -- is Standard. + + function Remove_Conversions return Interp; + -- Last chance for pathological cases involving comparisons on literals, + -- and user overloadings of the same operator. Such pathologies have + -- been removed from the ACVC, but still appear in two DEC tests, with + -- the following notable quote from Ben Brosgol: + -- + -- [Note: I disclaim all credit/responsibility/blame for coming up with + -- this example; Robert Dewar brought it to our attention, since it is + -- apparently found in the ACVC 1.5. I did not attempt to find the + -- reason in the Reference Manual that makes the example legal, since I + -- was too nauseated by it to want to pursue it further.] + -- + -- Accordingly, this is not a fully recursive solution, but it handles + -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes + -- pathology in the other direction with calls whose multiple overloaded + -- actuals make them truly unresolvable. + + -- The new rules concerning abstract operations create additional need + -- for special handling of expressions with universal operands, see + -- comments to Has_Abstract_Interpretation below. + + --------------------------- + -- Inherited_From_Actual -- + --------------------------- + + function Inherited_From_Actual (S : Entity_Id) return Boolean is + Par : constant Node_Id := Parent (S); + begin + if Nkind (Par) /= N_Full_Type_Declaration + or else Nkind (Type_Definition (Par)) /= N_Derived_Type_Definition + then + return False; + else + return Is_Entity_Name (Subtype_Indication (Type_Definition (Par))) + and then + Is_Generic_Actual_Type ( + Entity (Subtype_Indication (Type_Definition (Par)))); + end if; + end Inherited_From_Actual; + + -------------------------- + -- Is_Actual_Subprogram -- + -------------------------- + + function Is_Actual_Subprogram (S : Entity_Id) return Boolean is + begin + return In_Open_Scopes (Scope (S)) + and then + (Is_Generic_Instance (Scope (S)) + or else Is_Wrapper_Package (Scope (S))); + end Is_Actual_Subprogram; + + ------------- + -- Matches -- + ------------- + + function Matches (Actual, Formal : Node_Id) return Boolean is + T1 : constant Entity_Id := Etype (Actual); + T2 : constant Entity_Id := Etype (Formal); + begin + return T1 = T2 + or else + (Is_Numeric_Type (T2) + and then (T1 = Universal_Real or else T1 = Universal_Integer)); + end Matches; + + ------------------------ + -- Remove_Conversions -- + ------------------------ + + function Remove_Conversions return Interp is + I : Interp_Index; + It : Interp; + It1 : Interp; + F1 : Entity_Id; + Act1 : Node_Id; + Act2 : Node_Id; + + function Has_Abstract_Interpretation (N : Node_Id) return Boolean; + -- If an operation has universal operands the universal operation + -- is present among its interpretations. If there is an abstract + -- interpretation for the operator, with a numeric result, this + -- interpretation was already removed in sem_ch4, but the universal + -- one is still visible. We must rescan the list of operators and + -- remove the universal interpretation to resolve the ambiguity. + + --------------------------------- + -- Has_Abstract_Interpretation -- + --------------------------------- + + function Has_Abstract_Interpretation (N : Node_Id) return Boolean is + E : Entity_Id; + + begin + if Nkind (N) not in N_Op + or else Ada_Version < Ada_2005 + or else not Is_Overloaded (N) + or else No (Universal_Interpretation (N)) + then + return False; + + else + E := Get_Name_Entity_Id (Chars (N)); + while Present (E) loop + if Is_Overloadable (E) + and then Is_Abstract_Subprogram (E) + and then Is_Numeric_Type (Etype (E)) + then + return True; + else + E := Homonym (E); + end if; + end loop; + + -- Finally, if an operand of the binary operator is itself + -- an operator, recurse to see whether its own abstract + -- interpretation is responsible for the spurious ambiguity. + + if Nkind (N) in N_Binary_Op then + return Has_Abstract_Interpretation (Left_Opnd (N)) + or else Has_Abstract_Interpretation (Right_Opnd (N)); + + elsif Nkind (N) in N_Unary_Op then + return Has_Abstract_Interpretation (Right_Opnd (N)); + + else + return False; + end if; + end if; + end Has_Abstract_Interpretation; + + -- Start of processing for Remove_Conversions + + begin + It1 := No_Interp; + + Get_First_Interp (N, I, It); + while Present (It.Typ) loop + if not Is_Overloadable (It.Nam) then + return No_Interp; + end if; + + F1 := First_Formal (It.Nam); + + if No (F1) then + return It1; + + else + if Nkind (N) = N_Function_Call + or else Nkind (N) = N_Procedure_Call_Statement + then + Act1 := First_Actual (N); + + if Present (Act1) then + Act2 := Next_Actual (Act1); + else + Act2 := Empty; + end if; + + elsif Nkind (N) in N_Unary_Op then + Act1 := Right_Opnd (N); + Act2 := Empty; + + elsif Nkind (N) in N_Binary_Op then + Act1 := Left_Opnd (N); + Act2 := Right_Opnd (N); + + -- Use type of second formal, so as to include + -- exponentiation, where the exponent may be + -- ambiguous and the result non-universal. + + Next_Formal (F1); + + else + return It1; + end if; + + if Nkind (Act1) in N_Op + and then Is_Overloaded (Act1) + and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal + or else Nkind (Right_Opnd (Act1)) = N_Real_Literal) + and then Has_Compatible_Type (Act1, Standard_Boolean) + and then Etype (F1) = Standard_Boolean + then + -- If the two candidates are the original ones, the + -- ambiguity is real. Otherwise keep the original, further + -- calls to Disambiguate will take care of others in the + -- list of candidates. + + if It1 /= No_Interp then + if It = Disambiguate.It1 + or else It = Disambiguate.It2 + then + if It1 = Disambiguate.It1 + or else It1 = Disambiguate.It2 + then + return No_Interp; + else + It1 := It; + end if; + end if; + + elsif Present (Act2) + and then Nkind (Act2) in N_Op + and then Is_Overloaded (Act2) + and then Nkind_In (Right_Opnd (Act2), N_Integer_Literal, + N_Real_Literal) + and then Has_Compatible_Type (Act2, Standard_Boolean) + then + -- The preference rule on the first actual is not + -- sufficient to disambiguate. + + goto Next_Interp; + + else + It1 := It; + end if; + + elsif Is_Numeric_Type (Etype (F1)) + and then Has_Abstract_Interpretation (Act1) + then + -- Current interpretation is not the right one because it + -- expects a numeric operand. Examine all the other ones. + + declare + I : Interp_Index; + It : Interp; + + begin + Get_First_Interp (N, I, It); + while Present (It.Typ) loop + if + not Is_Numeric_Type (Etype (First_Formal (It.Nam))) + then + if No (Act2) + or else not Has_Abstract_Interpretation (Act2) + or else not + Is_Numeric_Type + (Etype (Next_Formal (First_Formal (It.Nam)))) + then + return It; + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + + return No_Interp; + end; + end if; + end if; + + <> + Get_Next_Interp (I, It); + end loop; + + -- After some error, a formal may have Any_Type and yield a spurious + -- match. To avoid cascaded errors if possible, check for such a + -- formal in either candidate. + + if Serious_Errors_Detected > 0 then + declare + Formal : Entity_Id; + + begin + Formal := First_Formal (Nam1); + while Present (Formal) loop + if Etype (Formal) = Any_Type then + return Disambiguate.It2; + end if; + + Next_Formal (Formal); + end loop; + + Formal := First_Formal (Nam2); + while Present (Formal) loop + if Etype (Formal) = Any_Type then + return Disambiguate.It1; + end if; + + Next_Formal (Formal); + end loop; + end; + end if; + + return It1; + end Remove_Conversions; + + ----------------------- + -- Standard_Operator -- + ----------------------- + + function Standard_Operator return Boolean is + Nam : Node_Id; + + begin + if Nkind (N) in N_Op then + return True; + + elsif Nkind (N) = N_Function_Call then + Nam := Name (N); + + if Nkind (Nam) /= N_Expanded_Name then + return True; + else + return Entity (Prefix (Nam)) = Standard_Standard; + end if; + else + return False; + end if; + end Standard_Operator; + + -- Start of processing for Disambiguate + + begin + -- Recover the two legal interpretations + + Get_First_Interp (N, I, It); + while I /= I1 loop + Get_Next_Interp (I, It); + end loop; + + It1 := It; + Nam1 := It.Nam; + while I /= I2 loop + Get_Next_Interp (I, It); + end loop; + + It2 := It; + Nam2 := It.Nam; + + -- Check whether one of the entities is an Ada 2005/2012 and we are + -- operating in an earlier mode, in which case we discard the Ada + -- 2005/2012 entity, so that we get proper Ada 95 overload resolution. + + if Ada_Version < Ada_2005 then + if Is_Ada_2005_Only (Nam1) or else Is_Ada_2012_Only (Nam1) then + return It2; + elsif Is_Ada_2005_Only (Nam2) or else Is_Ada_2012_Only (Nam1) then + return It1; + end if; + end if; + + -- Check whether one of the entities is an Ada 2012 entity and we are + -- operating in Ada 2005 mode, in which case we discard the Ada 2012 + -- entity, so that we get proper Ada 2005 overload resolution. + + if Ada_Version = Ada_2005 then + if Is_Ada_2012_Only (Nam1) then + return It2; + elsif Is_Ada_2012_Only (Nam2) then + return It1; + end if; + end if; + + -- Check for overloaded CIL convention stuff because the CIL libraries + -- do sick things like Console.Write_Line where it matches two different + -- overloads, so just pick the first ??? + + if Convention (Nam1) = Convention_CIL + and then Convention (Nam2) = Convention_CIL + and then Ekind (Nam1) = Ekind (Nam2) + and then (Ekind (Nam1) = E_Procedure + or else Ekind (Nam1) = E_Function) + then + return It2; + end if; + + -- If the context is universal, the predefined operator is preferred. + -- This includes bounds in numeric type declarations, and expressions + -- in type conversions. If no interpretation yields a universal type, + -- then we must check whether the user-defined entity hides the prede- + -- fined one. + + if Chars (Nam1) in Any_Operator_Name + and then Standard_Operator + then + if Typ = Universal_Integer + or else Typ = Universal_Real + or else Typ = Any_Integer + or else Typ = Any_Discrete + or else Typ = Any_Real + or else Typ = Any_Type + then + -- Find an interpretation that yields the universal type, or else + -- a predefined operator that yields a predefined numeric type. + + declare + Candidate : Interp := No_Interp; + + begin + Get_First_Interp (N, I, It); + while Present (It.Typ) loop + if (Covers (Typ, It.Typ) + or else Typ = Any_Type) + and then + (It.Typ = Universal_Integer + or else It.Typ = Universal_Real) + then + return It; + + elsif Covers (Typ, It.Typ) + and then Scope (It.Typ) = Standard_Standard + and then Scope (It.Nam) = Standard_Standard + and then Is_Numeric_Type (It.Typ) + then + Candidate := It; + end if; + + Get_Next_Interp (I, It); + end loop; + + if Candidate /= No_Interp then + return Candidate; + end if; + end; + + elsif Chars (Nam1) /= Name_Op_Not + and then (Typ = Standard_Boolean or else Typ = Any_Boolean) + then + -- Equality or comparison operation. Choose predefined operator if + -- arguments are universal. The node may be an operator, name, or + -- a function call, so unpack arguments accordingly. + + declare + Arg1, Arg2 : Node_Id; + + begin + if Nkind (N) in N_Op then + Arg1 := Left_Opnd (N); + Arg2 := Right_Opnd (N); + + elsif Is_Entity_Name (N) then + Arg1 := First_Entity (Entity (N)); + Arg2 := Next_Entity (Arg1); + + else + Arg1 := First_Actual (N); + Arg2 := Next_Actual (Arg1); + end if; + + if Present (Arg2) + and then Present (Universal_Interpretation (Arg1)) + and then Universal_Interpretation (Arg2) = + Universal_Interpretation (Arg1) + then + Get_First_Interp (N, I, It); + while Scope (It.Nam) /= Standard_Standard loop + Get_Next_Interp (I, It); + end loop; + + return It; + end if; + end; + end if; + end if; + + -- If no universal interpretation, check whether user-defined operator + -- hides predefined one, as well as other special cases. If the node + -- is a range, then one or both bounds are ambiguous. Each will have + -- to be disambiguated w.r.t. the context type. The type of the range + -- itself is imposed by the context, so we can return either legal + -- interpretation. + + if Ekind (Nam1) = E_Operator then + Predef_Subp := Nam1; + User_Subp := Nam2; + + elsif Ekind (Nam2) = E_Operator then + Predef_Subp := Nam2; + User_Subp := Nam1; + + elsif Nkind (N) = N_Range then + return It1; + + -- Implement AI05-105: A renaming declaration with an access + -- definition must resolve to an anonymous access type. This + -- is a resolution rule and can be used to disambiguate. + + elsif Nkind (Parent (N)) = N_Object_Renaming_Declaration + and then Present (Access_Definition (Parent (N))) + then + if Ekind_In (It1.Typ, E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) + then + if Ekind (It2.Typ) = Ekind (It1.Typ) then + + -- True ambiguity + + return No_Interp; + + else + return It1; + end if; + + elsif Ekind_In (It2.Typ, E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) + then + return It2; + + -- No legal interpretation + + else + return No_Interp; + end if; + + -- If two user defined-subprograms are visible, it is a true ambiguity, + -- unless one of them is an entry and the context is a conditional or + -- timed entry call, or unless we are within an instance and this is + -- results from two formals types with the same actual. + + else + if Nkind (N) = N_Procedure_Call_Statement + and then Nkind (Parent (N)) = N_Entry_Call_Alternative + and then N = Entry_Call_Statement (Parent (N)) + then + if Ekind (Nam2) = E_Entry then + return It2; + elsif Ekind (Nam1) = E_Entry then + return It1; + else + return No_Interp; + end if; + + -- If the ambiguity occurs within an instance, it is due to several + -- formal types with the same actual. Look for an exact match between + -- the types of the formals of the overloadable entities, and the + -- actuals in the call, to recover the unambiguous match in the + -- original generic. + + -- The ambiguity can also be due to an overloading between a formal + -- subprogram and a subprogram declared outside the generic. If the + -- node is overloaded, it did not resolve to the global entity in + -- the generic, and we choose the formal subprogram. + + -- Finally, the ambiguity can be between an explicit subprogram and + -- one inherited (with different defaults) from an actual. In this + -- case the resolution was to the explicit declaration in the + -- generic, and remains so in the instance. + + elsif In_Instance + and then not In_Generic_Actual (N) + then + if Nkind (N) = N_Function_Call + or else Nkind (N) = N_Procedure_Call_Statement + then + declare + Actual : Node_Id; + Formal : Entity_Id; + Is_Act1 : constant Boolean := Is_Actual_Subprogram (Nam1); + Is_Act2 : constant Boolean := Is_Actual_Subprogram (Nam2); + + begin + if Is_Act1 and then not Is_Act2 then + return It1; + + elsif Is_Act2 and then not Is_Act1 then + return It2; + + elsif Inherited_From_Actual (Nam1) + and then Comes_From_Source (Nam2) + then + return It2; + + elsif Inherited_From_Actual (Nam2) + and then Comes_From_Source (Nam1) + then + return It1; + end if; + + Actual := First_Actual (N); + Formal := First_Formal (Nam1); + while Present (Actual) loop + if Etype (Actual) /= Etype (Formal) then + return It2; + end if; + + Next_Actual (Actual); + Next_Formal (Formal); + end loop; + + return It1; + end; + + elsif Nkind (N) in N_Binary_Op then + if Matches (Left_Opnd (N), First_Formal (Nam1)) + and then + Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1))) + then + return It1; + else + return It2; + end if; + + elsif Nkind (N) in N_Unary_Op then + if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then + return It1; + else + return It2; + end if; + + else + return Remove_Conversions; + end if; + else + return Remove_Conversions; + end if; + end if; + + -- An implicit concatenation operator on a string type cannot be + -- disambiguated from the predefined concatenation. This can only + -- happen with concatenation of string literals. + + if Chars (User_Subp) = Name_Op_Concat + and then Ekind (User_Subp) = E_Operator + and then Is_String_Type (Etype (First_Formal (User_Subp))) + then + return No_Interp; + + -- If the user-defined operator is in an open scope, or in the scope + -- of the resulting type, or given by an expanded name that names its + -- scope, it hides the predefined operator for the type. Exponentiation + -- has to be special-cased because the implicit operator does not have + -- a symmetric signature, and may not be hidden by the explicit one. + + elsif (Nkind (N) = N_Function_Call + and then Nkind (Name (N)) = N_Expanded_Name + and then (Chars (Predef_Subp) /= Name_Op_Expon + or else Hides_Op (User_Subp, Predef_Subp)) + and then Scope (User_Subp) = Entity (Prefix (Name (N)))) + or else Hides_Op (User_Subp, Predef_Subp) + then + if It1.Nam = User_Subp then + return It1; + else + return It2; + end if; + + -- Otherwise, the predefined operator has precedence, or if the user- + -- defined operation is directly visible we have a true ambiguity. If + -- this is a fixed-point multiplication and division in Ada83 mode, + -- exclude the universal_fixed operator, which often causes ambiguities + -- in legacy code. + + else + if (In_Open_Scopes (Scope (User_Subp)) + or else Is_Potentially_Use_Visible (User_Subp)) + and then not In_Instance + then + if Is_Fixed_Point_Type (Typ) + and then (Chars (Nam1) = Name_Op_Multiply + or else Chars (Nam1) = Name_Op_Divide) + and then Ada_Version = Ada_83 + then + if It2.Nam = Predef_Subp then + return It1; + else + return It2; + end if; + + -- Ada 2005, AI-420: preference rule for "=" on Universal_Access + -- states that the operator defined in Standard is not available + -- if there is a user-defined equality with the proper signature, + -- declared in the same declarative list as the type. The node + -- may be an operator or a function call. + + elsif (Chars (Nam1) = Name_Op_Eq + or else + Chars (Nam1) = Name_Op_Ne) + and then Ada_Version >= Ada_2005 + and then Etype (User_Subp) = Standard_Boolean + then + declare + Opnd : Node_Id; + + begin + if Nkind (N) = N_Function_Call then + Opnd := First_Actual (N); + else + Opnd := Left_Opnd (N); + end if; + + if Ekind (Etype (Opnd)) = E_Anonymous_Access_Type + and then + In_Same_List (Parent (Designated_Type (Etype (Opnd))), + Unit_Declaration_Node (User_Subp)) + then + if It2.Nam = Predef_Subp then + return It1; + else + return It2; + end if; + else + return Remove_Conversions; + end if; + end; + + else + return No_Interp; + end if; + + elsif It1.Nam = Predef_Subp then + return It1; + + else + return It2; + end if; + end if; + end Disambiguate; + + --------------------- + -- End_Interp_List -- + --------------------- + + procedure End_Interp_List is + begin + All_Interp.Table (All_Interp.Last) := No_Interp; + All_Interp.Increment_Last; + end End_Interp_List; + + ------------------------- + -- Entity_Matches_Spec -- + ------------------------- + + function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean is + begin + -- Simple case: same entity kinds, type conformance is required. A + -- parameterless function can also rename a literal. + + if Ekind (Old_S) = Ekind (New_S) + or else (Ekind (New_S) = E_Function + and then Ekind (Old_S) = E_Enumeration_Literal) + then + return Type_Conformant (New_S, Old_S); + + elsif Ekind (New_S) = E_Function + and then Ekind (Old_S) = E_Operator + then + return Operator_Matches_Spec (Old_S, New_S); + + elsif Ekind (New_S) = E_Procedure + and then Is_Entry (Old_S) + then + return Type_Conformant (New_S, Old_S); + + else + return False; + end if; + end Entity_Matches_Spec; + + ---------------------- + -- Find_Unique_Type -- + ---------------------- + + function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is + T : constant Entity_Id := Etype (L); + I : Interp_Index; + It : Interp; + TR : Entity_Id := Any_Type; + + begin + if Is_Overloaded (R) then + Get_First_Interp (R, I, It); + while Present (It.Typ) loop + if Covers (T, It.Typ) or else Covers (It.Typ, T) then + + -- If several interpretations are possible and L is universal, + -- apply preference rule. + + if TR /= Any_Type then + + if (T = Universal_Integer or else T = Universal_Real) + and then It.Typ = T + then + TR := It.Typ; + end if; + + else + TR := It.Typ; + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + + Set_Etype (R, TR); + + -- In the non-overloaded case, the Etype of R is already set correctly + + else + null; + end if; + + -- If one of the operands is Universal_Fixed, the type of the other + -- operand provides the context. + + if Etype (R) = Universal_Fixed then + return T; + + elsif T = Universal_Fixed then + return Etype (R); + + -- Ada 2005 (AI-230): Support the following operators: + + -- function "=" (L, R : universal_access) return Boolean; + -- function "/=" (L, R : universal_access) return Boolean; + + -- Pool specific access types (E_Access_Type) are not covered by these + -- operators because of the legality rule of 4.5.2(9.2): "The operands + -- of the equality operators for universal_access shall be convertible + -- to one another (see 4.6)". For example, considering the type decla- + -- ration "type P is access Integer" and an anonymous access to Integer, + -- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there + -- is no rule in 4.6 that allows "access Integer" to be converted to P. + + elsif Ada_Version >= Ada_2005 + and then + (Ekind (Etype (L)) = E_Anonymous_Access_Type + or else + Ekind (Etype (L)) = E_Anonymous_Access_Subprogram_Type) + and then Is_Access_Type (Etype (R)) + and then Ekind (Etype (R)) /= E_Access_Type + then + return Etype (L); + + elsif Ada_Version >= Ada_2005 + and then + (Ekind (Etype (R)) = E_Anonymous_Access_Type + or else Ekind (Etype (R)) = E_Anonymous_Access_Subprogram_Type) + and then Is_Access_Type (Etype (L)) + and then Ekind (Etype (L)) /= E_Access_Type + then + return Etype (R); + + else + return Specific_Type (T, Etype (R)); + end if; + end Find_Unique_Type; + + ------------------------------------- + -- Function_Interp_Has_Abstract_Op -- + ------------------------------------- + + function Function_Interp_Has_Abstract_Op + (N : Node_Id; + E : Entity_Id) return Entity_Id + is + Abstr_Op : Entity_Id; + Act : Node_Id; + Act_Parm : Node_Id; + Form_Parm : Node_Id; + + begin + -- Why is check on E needed below ??? + -- In any case this para needs comments ??? + + if Is_Overloaded (N) and then Is_Overloadable (E) then + Act_Parm := First_Actual (N); + Form_Parm := First_Formal (E); + while Present (Act_Parm) + and then Present (Form_Parm) + loop + Act := Act_Parm; + + if Nkind (Act) = N_Parameter_Association then + Act := Explicit_Actual_Parameter (Act); + end if; + + Abstr_Op := Has_Abstract_Op (Act, Etype (Form_Parm)); + + if Present (Abstr_Op) then + return Abstr_Op; + end if; + + Next_Actual (Act_Parm); + Next_Formal (Form_Parm); + end loop; + end if; + + return Empty; + end Function_Interp_Has_Abstract_Op; + + ---------------------- + -- Get_First_Interp -- + ---------------------- + + procedure Get_First_Interp + (N : Node_Id; + I : out Interp_Index; + It : out Interp) + is + Int_Ind : Interp_Index; + Map_Ptr : Int; + O_N : Node_Id; + + begin + -- If a selected component is overloaded because the selector has + -- multiple interpretations, the node is a call to a protected + -- operation or an indirect call. Retrieve the interpretation from + -- the selector name. The selected component may be overloaded as well + -- if the prefix is overloaded. That case is unchanged. + + if Nkind (N) = N_Selected_Component + and then Is_Overloaded (Selector_Name (N)) + then + O_N := Selector_Name (N); + else + O_N := N; + end if; + + Map_Ptr := Headers (Hash (O_N)); + while Map_Ptr /= No_Entry loop + if Interp_Map.Table (Map_Ptr).Node = O_N then + Int_Ind := Interp_Map.Table (Map_Ptr).Index; + It := All_Interp.Table (Int_Ind); + I := Int_Ind; + return; + else + Map_Ptr := Interp_Map.Table (Map_Ptr).Next; + end if; + end loop; + + -- Procedure should never be called if the node has no interpretations + + raise Program_Error; + end Get_First_Interp; + + --------------------- + -- Get_Next_Interp -- + --------------------- + + procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp) is + begin + I := I + 1; + It := All_Interp.Table (I); + end Get_Next_Interp; + + ------------------------- + -- Has_Compatible_Type -- + ------------------------- + + function Has_Compatible_Type + (N : Node_Id; + Typ : Entity_Id) return Boolean + is + I : Interp_Index; + It : Interp; + + begin + if N = Error then + return False; + end if; + + if Nkind (N) = N_Subtype_Indication + or else not Is_Overloaded (N) + then + return + Covers (Typ, Etype (N)) + + -- Ada 2005 (AI-345): The context may be a synchronized interface. + -- If the type is already frozen use the corresponding_record + -- to check whether it is a proper descendant. + + or else + (Is_Record_Type (Typ) + and then Is_Concurrent_Type (Etype (N)) + and then Present (Corresponding_Record_Type (Etype (N))) + and then Covers (Typ, Corresponding_Record_Type (Etype (N)))) + + or else + (Is_Concurrent_Type (Typ) + and then Is_Record_Type (Etype (N)) + and then Present (Corresponding_Record_Type (Typ)) + and then Covers (Corresponding_Record_Type (Typ), Etype (N))) + + or else + (not Is_Tagged_Type (Typ) + and then Ekind (Typ) /= E_Anonymous_Access_Type + and then Covers (Etype (N), Typ)); + + else + Get_First_Interp (N, I, It); + while Present (It.Typ) loop + if (Covers (Typ, It.Typ) + and then + (Scope (It.Nam) /= Standard_Standard + or else not Is_Invisible_Operator (N, Base_Type (Typ)))) + + -- Ada 2005 (AI-345) + + or else + (Is_Concurrent_Type (It.Typ) + and then Present (Corresponding_Record_Type + (Etype (It.Typ))) + and then Covers (Typ, Corresponding_Record_Type + (Etype (It.Typ)))) + + or else (not Is_Tagged_Type (Typ) + and then Ekind (Typ) /= E_Anonymous_Access_Type + and then Covers (It.Typ, Typ)) + then + return True; + end if; + + Get_Next_Interp (I, It); + end loop; + + return False; + end if; + end Has_Compatible_Type; + + --------------------- + -- Has_Abstract_Op -- + --------------------- + + function Has_Abstract_Op + (N : Node_Id; + Typ : Entity_Id) return Entity_Id + is + I : Interp_Index; + It : Interp; + + begin + if Is_Overloaded (N) then + Get_First_Interp (N, I, It); + while Present (It.Nam) loop + if Present (It.Abstract_Op) + and then Etype (It.Abstract_Op) = Typ + then + return It.Abstract_Op; + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + + return Empty; + end Has_Abstract_Op; + + ---------- + -- Hash -- + ---------- + + function Hash (N : Node_Id) return Int is + begin + -- Nodes have a size that is power of two, so to select significant + -- bits only we remove the low-order bits. + + return ((Int (N) / 2 ** 5) mod Header_Size); + end Hash; + + -------------- + -- Hides_Op -- + -------------- + + function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean is + Btyp : constant Entity_Id := Base_Type (Etype (First_Formal (F))); + begin + return Operator_Matches_Spec (Op, F) + and then (In_Open_Scopes (Scope (F)) + or else Scope (F) = Scope (Btyp) + or else (not In_Open_Scopes (Scope (Btyp)) + and then not In_Use (Btyp) + and then not In_Use (Scope (Btyp)))); + end Hides_Op; + + ------------------------ + -- Init_Interp_Tables -- + ------------------------ + + procedure Init_Interp_Tables is + begin + All_Interp.Init; + Interp_Map.Init; + Headers := (others => No_Entry); + end Init_Interp_Tables; + + ----------------------------------- + -- Interface_Present_In_Ancestor -- + ----------------------------------- + + function Interface_Present_In_Ancestor + (Typ : Entity_Id; + Iface : Entity_Id) return Boolean + is + Target_Typ : Entity_Id; + Iface_Typ : Entity_Id; + + function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean; + -- Returns True if Typ or some ancestor of Typ implements Iface + + ------------------------------- + -- Iface_Present_In_Ancestor -- + ------------------------------- + + function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean is + E : Entity_Id; + AI : Entity_Id; + Elmt : Elmt_Id; + + begin + if Typ = Iface_Typ then + return True; + end if; + + -- Handle private types + + if Present (Full_View (Typ)) + and then not Is_Concurrent_Type (Full_View (Typ)) + then + E := Full_View (Typ); + else + E := Typ; + end if; + + loop + if Present (Interfaces (E)) + and then Present (Interfaces (E)) + and then not Is_Empty_Elmt_List (Interfaces (E)) + then + Elmt := First_Elmt (Interfaces (E)); + while Present (Elmt) loop + AI := Node (Elmt); + + if AI = Iface_Typ or else Is_Ancestor (Iface_Typ, AI) then + return True; + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + exit when Etype (E) = E + + -- Handle private types + + or else (Present (Full_View (Etype (E))) + and then Full_View (Etype (E)) = E); + + -- Check if the current type is a direct derivation of the + -- interface + + if Etype (E) = Iface_Typ then + return True; + end if; + + -- Climb to the immediate ancestor handling private types + + if Present (Full_View (Etype (E))) then + E := Full_View (Etype (E)); + else + E := Etype (E); + end if; + end loop; + + return False; + end Iface_Present_In_Ancestor; + + -- Start of processing for Interface_Present_In_Ancestor + + begin + -- Iface might be a class-wide subtype, so we have to apply Base_Type + + if Is_Class_Wide_Type (Iface) then + Iface_Typ := Etype (Base_Type (Iface)); + else + Iface_Typ := Iface; + end if; + + -- Handle subtypes + + Iface_Typ := Base_Type (Iface_Typ); + + if Is_Access_Type (Typ) then + Target_Typ := Etype (Directly_Designated_Type (Typ)); + else + Target_Typ := Typ; + end if; + + if Is_Concurrent_Record_Type (Target_Typ) then + Target_Typ := Corresponding_Concurrent_Type (Target_Typ); + end if; + + Target_Typ := Base_Type (Target_Typ); + + -- In case of concurrent types we can't use the Corresponding Record_Typ + -- to look for the interface because it is built by the expander (and + -- hence it is not always available). For this reason we traverse the + -- list of interfaces (available in the parent of the concurrent type) + + if Is_Concurrent_Type (Target_Typ) then + if Present (Interface_List (Parent (Target_Typ))) then + declare + AI : Node_Id; + + begin + AI := First (Interface_List (Parent (Target_Typ))); + while Present (AI) loop + if Etype (AI) = Iface_Typ then + return True; + + elsif Present (Interfaces (Etype (AI))) + and then Iface_Present_In_Ancestor (Etype (AI)) + then + return True; + end if; + + Next (AI); + end loop; + end; + end if; + + return False; + end if; + + if Is_Class_Wide_Type (Target_Typ) then + Target_Typ := Etype (Target_Typ); + end if; + + if Ekind (Target_Typ) = E_Incomplete_Type then + pragma Assert (Present (Non_Limited_View (Target_Typ))); + Target_Typ := Non_Limited_View (Target_Typ); + + -- Protect the frontend against previously detected errors + + if Ekind (Target_Typ) = E_Incomplete_Type then + return False; + end if; + end if; + + return Iface_Present_In_Ancestor (Target_Typ); + end Interface_Present_In_Ancestor; + + --------------------- + -- Intersect_Types -- + --------------------- + + function Intersect_Types (L, R : Node_Id) return Entity_Id is + Index : Interp_Index; + It : Interp; + Typ : Entity_Id; + + function Check_Right_Argument (T : Entity_Id) return Entity_Id; + -- Find interpretation of right arg that has type compatible with T + + -------------------------- + -- Check_Right_Argument -- + -------------------------- + + function Check_Right_Argument (T : Entity_Id) return Entity_Id is + Index : Interp_Index; + It : Interp; + T2 : Entity_Id; + + begin + if not Is_Overloaded (R) then + return Specific_Type (T, Etype (R)); + + else + Get_First_Interp (R, Index, It); + loop + T2 := Specific_Type (T, It.Typ); + + if T2 /= Any_Type then + return T2; + end if; + + Get_Next_Interp (Index, It); + exit when No (It.Typ); + end loop; + + return Any_Type; + end if; + end Check_Right_Argument; + + -- Start of processing for Intersect_Types + + begin + if Etype (L) = Any_Type or else Etype (R) = Any_Type then + return Any_Type; + end if; + + if not Is_Overloaded (L) then + Typ := Check_Right_Argument (Etype (L)); + + else + Typ := Any_Type; + Get_First_Interp (L, Index, It); + while Present (It.Typ) loop + Typ := Check_Right_Argument (It.Typ); + exit when Typ /= Any_Type; + Get_Next_Interp (Index, It); + end loop; + + end if; + + -- If Typ is Any_Type, it means no compatible pair of types was found + + if Typ = Any_Type then + if Nkind (Parent (L)) in N_Op then + Error_Msg_N ("incompatible types for operator", Parent (L)); + + elsif Nkind (Parent (L)) = N_Range then + Error_Msg_N ("incompatible types given in constraint", Parent (L)); + + -- Ada 2005 (AI-251): Complete the error notification + + elsif Is_Class_Wide_Type (Etype (R)) + and then Is_Interface (Etype (Class_Wide_Type (Etype (R)))) + then + Error_Msg_NE ("(Ada 2005) does not implement interface }", + L, Etype (Class_Wide_Type (Etype (R)))); + + else + Error_Msg_N ("incompatible types", Parent (L)); + end if; + end if; + + return Typ; + end Intersect_Types; + + ----------------------- + -- In_Generic_Actual -- + ----------------------- + + function In_Generic_Actual (Exp : Node_Id) return Boolean is + Par : constant Node_Id := Parent (Exp); + + begin + if No (Par) then + return False; + + elsif Nkind (Par) in N_Declaration then + if Nkind (Par) = N_Object_Declaration then + return Present (Corresponding_Generic_Association (Par)); + else + return False; + end if; + + elsif Nkind (Par) = N_Object_Renaming_Declaration then + return Present (Corresponding_Generic_Association (Par)); + + elsif Nkind (Par) in N_Statement_Other_Than_Procedure_Call then + return False; + + else + return In_Generic_Actual (Parent (Par)); + end if; + end In_Generic_Actual; + + ----------------- + -- Is_Ancestor -- + ----------------- + + function Is_Ancestor (T1, T2 : Entity_Id) return Boolean is + BT1 : Entity_Id; + BT2 : Entity_Id; + Par : Entity_Id; + + begin + BT1 := Base_Type (T1); + BT2 := Base_Type (T2); + + -- Handle underlying view of records with unknown discriminants using + -- the original entity that motivated the construction of this + -- underlying record view (see Build_Derived_Private_Type). + + if Is_Underlying_Record_View (BT1) then + BT1 := Underlying_Record_View (BT1); + end if; + + if Is_Underlying_Record_View (BT2) then + BT2 := Underlying_Record_View (BT2); + end if; + + if BT1 = BT2 then + return True; + + -- The predicate must look past privacy + + elsif Is_Private_Type (T1) + and then Present (Full_View (T1)) + and then BT2 = Base_Type (Full_View (T1)) + then + return True; + + elsif Is_Private_Type (T2) + and then Present (Full_View (T2)) + and then BT1 = Base_Type (Full_View (T2)) + then + return True; + + else + Par := Etype (BT2); + + loop + -- If there was a error on the type declaration, do not recurse + + if Error_Posted (Par) then + return False; + + elsif BT1 = Base_Type (Par) + or else (Is_Private_Type (T1) + and then Present (Full_View (T1)) + and then Base_Type (Par) = Base_Type (Full_View (T1))) + then + return True; + + elsif Is_Private_Type (Par) + and then Present (Full_View (Par)) + and then Full_View (Par) = BT1 + then + return True; + + elsif Etype (Par) /= Par then + + -- If this is a private type and its parent is an interface + -- then use the parent of the full view (which is a type that + -- implements such interface) + + if Is_Private_Type (Par) + and then Is_Interface (Etype (Par)) + and then Present (Full_View (Par)) + then + Par := Etype (Full_View (Par)); + else + Par := Etype (Par); + end if; + + -- For all other cases return False, not an Ancestor + + else + return False; + end if; + end loop; + end if; + end Is_Ancestor; + + --------------------------- + -- Is_Invisible_Operator -- + --------------------------- + + function Is_Invisible_Operator + (N : Node_Id; + T : Entity_Id) return Boolean + is + Orig_Node : constant Node_Id := Original_Node (N); + + begin + if Nkind (N) not in N_Op then + return False; + + elsif not Comes_From_Source (N) then + return False; + + elsif No (Universal_Interpretation (Right_Opnd (N))) then + return False; + + elsif Nkind (N) in N_Binary_Op + and then No (Universal_Interpretation (Left_Opnd (N))) + then + return False; + + else + return Is_Numeric_Type (T) + and then not In_Open_Scopes (Scope (T)) + and then not Is_Potentially_Use_Visible (T) + and then not In_Use (T) + and then not In_Use (Scope (T)) + and then + (Nkind (Orig_Node) /= N_Function_Call + or else Nkind (Name (Orig_Node)) /= N_Expanded_Name + or else Entity (Prefix (Name (Orig_Node))) /= Scope (T)) + and then not In_Instance; + end if; + end Is_Invisible_Operator; + + -------------------- + -- Is_Progenitor -- + -------------------- + + function Is_Progenitor + (Iface : Entity_Id; + Typ : Entity_Id) return Boolean + is + begin + return Implements_Interface (Typ, Iface, Exclude_Parents => True); + end Is_Progenitor; + + ------------------- + -- Is_Subtype_Of -- + ------------------- + + function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is + S : Entity_Id; + + begin + S := Ancestor_Subtype (T1); + while Present (S) loop + if S = T2 then + return True; + else + S := Ancestor_Subtype (S); + end if; + end loop; + + return False; + end Is_Subtype_Of; + + ------------------ + -- List_Interps -- + ------------------ + + procedure List_Interps (Nam : Node_Id; Err : Node_Id) is + Index : Interp_Index; + It : Interp; + + begin + Get_First_Interp (Nam, Index, It); + while Present (It.Nam) loop + if Scope (It.Nam) = Standard_Standard + and then Scope (It.Typ) /= Standard_Standard + then + Error_Msg_Sloc := Sloc (Parent (It.Typ)); + Error_Msg_NE ("\\& (inherited) declared#!", Err, It.Nam); + + else + Error_Msg_Sloc := Sloc (It.Nam); + Error_Msg_NE ("\\& declared#!", Err, It.Nam); + end if; + + Get_Next_Interp (Index, It); + end loop; + end List_Interps; + + ----------------- + -- New_Interps -- + ----------------- + + procedure New_Interps (N : Node_Id) is + Map_Ptr : Int; + + begin + All_Interp.Append (No_Interp); + + Map_Ptr := Headers (Hash (N)); + + if Map_Ptr = No_Entry then + + -- Place new node at end of table + + Interp_Map.Increment_Last; + Headers (Hash (N)) := Interp_Map.Last; + + else + -- Place node at end of chain, or locate its previous entry + + loop + if Interp_Map.Table (Map_Ptr).Node = N then + + -- Node is already in the table, and is being rewritten. + -- Start a new interp section, retain hash link. + + Interp_Map.Table (Map_Ptr).Node := N; + Interp_Map.Table (Map_Ptr).Index := All_Interp.Last; + Set_Is_Overloaded (N, True); + return; + + else + exit when Interp_Map.Table (Map_Ptr).Next = No_Entry; + Map_Ptr := Interp_Map.Table (Map_Ptr).Next; + end if; + end loop; + + -- Chain the new node + + Interp_Map.Increment_Last; + Interp_Map.Table (Map_Ptr).Next := Interp_Map.Last; + end if; + + Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last, No_Entry); + Set_Is_Overloaded (N, True); + end New_Interps; + + --------------------------- + -- Operator_Matches_Spec -- + --------------------------- + + function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean is + Op_Name : constant Name_Id := Chars (Op); + T : constant Entity_Id := Etype (New_S); + New_F : Entity_Id; + Old_F : Entity_Id; + Num : Int; + T1 : Entity_Id; + T2 : Entity_Id; + + begin + -- To verify that a predefined operator matches a given signature, + -- do a case analysis of the operator classes. Function can have one + -- or two formals and must have the proper result type. + + New_F := First_Formal (New_S); + Old_F := First_Formal (Op); + Num := 0; + while Present (New_F) and then Present (Old_F) loop + Num := Num + 1; + Next_Formal (New_F); + Next_Formal (Old_F); + end loop; + + -- Definite mismatch if different number of parameters + + if Present (Old_F) or else Present (New_F) then + return False; + + -- Unary operators + + elsif Num = 1 then + T1 := Etype (First_Formal (New_S)); + + if Op_Name = Name_Op_Subtract + or else Op_Name = Name_Op_Add + or else Op_Name = Name_Op_Abs + then + return Base_Type (T1) = Base_Type (T) + and then Is_Numeric_Type (T); + + elsif Op_Name = Name_Op_Not then + return Base_Type (T1) = Base_Type (T) + and then Valid_Boolean_Arg (Base_Type (T)); + + else + return False; + end if; + + -- Binary operators + + else + T1 := Etype (First_Formal (New_S)); + T2 := Etype (Next_Formal (First_Formal (New_S))); + + if Op_Name = Name_Op_And or else Op_Name = Name_Op_Or + or else Op_Name = Name_Op_Xor + then + return Base_Type (T1) = Base_Type (T2) + and then Base_Type (T1) = Base_Type (T) + and then Valid_Boolean_Arg (Base_Type (T)); + + elsif Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne then + return Base_Type (T1) = Base_Type (T2) + and then not Is_Limited_Type (T1) + and then Is_Boolean_Type (T); + + elsif Op_Name = Name_Op_Lt or else Op_Name = Name_Op_Le + or else Op_Name = Name_Op_Gt or else Op_Name = Name_Op_Ge + then + return Base_Type (T1) = Base_Type (T2) + and then Valid_Comparison_Arg (T1) + and then Is_Boolean_Type (T); + + elsif Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then + return Base_Type (T1) = Base_Type (T2) + and then Base_Type (T1) = Base_Type (T) + and then Is_Numeric_Type (T); + + -- For division and multiplication, a user-defined function does not + -- match the predefined universal_fixed operation, except in Ada 83. + + elsif Op_Name = Name_Op_Divide then + return (Base_Type (T1) = Base_Type (T2) + and then Base_Type (T1) = Base_Type (T) + and then Is_Numeric_Type (T) + and then (not Is_Fixed_Point_Type (T) + or else Ada_Version = Ada_83)) + + -- Mixed_Mode operations on fixed-point types + + or else (Base_Type (T1) = Base_Type (T) + and then Base_Type (T2) = Base_Type (Standard_Integer) + and then Is_Fixed_Point_Type (T)) + + -- A user defined operator can also match (and hide) a mixed + -- operation on universal literals. + + or else (Is_Integer_Type (T2) + and then Is_Floating_Point_Type (T1) + and then Base_Type (T1) = Base_Type (T)); + + elsif Op_Name = Name_Op_Multiply then + return (Base_Type (T1) = Base_Type (T2) + and then Base_Type (T1) = Base_Type (T) + and then Is_Numeric_Type (T) + and then (not Is_Fixed_Point_Type (T) + or else Ada_Version = Ada_83)) + + -- Mixed_Mode operations on fixed-point types + + or else (Base_Type (T1) = Base_Type (T) + and then Base_Type (T2) = Base_Type (Standard_Integer) + and then Is_Fixed_Point_Type (T)) + + or else (Base_Type (T2) = Base_Type (T) + and then Base_Type (T1) = Base_Type (Standard_Integer) + and then Is_Fixed_Point_Type (T)) + + or else (Is_Integer_Type (T2) + and then Is_Floating_Point_Type (T1) + and then Base_Type (T1) = Base_Type (T)) + + or else (Is_Integer_Type (T1) + and then Is_Floating_Point_Type (T2) + and then Base_Type (T2) = Base_Type (T)); + + elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then + return Base_Type (T1) = Base_Type (T2) + and then Base_Type (T1) = Base_Type (T) + and then Is_Integer_Type (T); + + elsif Op_Name = Name_Op_Expon then + return Base_Type (T1) = Base_Type (T) + and then Is_Numeric_Type (T) + and then Base_Type (T2) = Base_Type (Standard_Integer); + + elsif Op_Name = Name_Op_Concat then + return Is_Array_Type (T) + and then (Base_Type (T) = Base_Type (Etype (Op))) + and then (Base_Type (T1) = Base_Type (T) + or else + Base_Type (T1) = Base_Type (Component_Type (T))) + and then (Base_Type (T2) = Base_Type (T) + or else + Base_Type (T2) = Base_Type (Component_Type (T))); + + else + return False; + end if; + end if; + end Operator_Matches_Spec; + + ------------------- + -- Remove_Interp -- + ------------------- + + procedure Remove_Interp (I : in out Interp_Index) is + II : Interp_Index; + + begin + -- Find end of interp list and copy downward to erase the discarded one + + II := I + 1; + while Present (All_Interp.Table (II).Typ) loop + II := II + 1; + end loop; + + for J in I + 1 .. II loop + All_Interp.Table (J - 1) := All_Interp.Table (J); + end loop; + + -- Back up interp index to insure that iterator will pick up next + -- available interpretation. + + I := I - 1; + end Remove_Interp; + + ------------------ + -- Save_Interps -- + ------------------ + + procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id) is + Map_Ptr : Int; + O_N : Node_Id := Old_N; + + begin + if Is_Overloaded (Old_N) then + if Nkind (Old_N) = N_Selected_Component + and then Is_Overloaded (Selector_Name (Old_N)) + then + O_N := Selector_Name (Old_N); + end if; + + Map_Ptr := Headers (Hash (O_N)); + + while Interp_Map.Table (Map_Ptr).Node /= O_N loop + Map_Ptr := Interp_Map.Table (Map_Ptr).Next; + pragma Assert (Map_Ptr /= No_Entry); + end loop; + + New_Interps (New_N); + Interp_Map.Table (Interp_Map.Last).Index := + Interp_Map.Table (Map_Ptr).Index; + end if; + end Save_Interps; + + ------------------- + -- Specific_Type -- + ------------------- + + function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id is + T1 : constant Entity_Id := Available_View (Typ_1); + T2 : constant Entity_Id := Available_View (Typ_2); + B1 : constant Entity_Id := Base_Type (T1); + B2 : constant Entity_Id := Base_Type (T2); + + function Is_Remote_Access (T : Entity_Id) return Boolean; + -- Check whether T is the equivalent type of a remote access type. + -- If distribution is enabled, T is a legal context for Null. + + ---------------------- + -- Is_Remote_Access -- + ---------------------- + + function Is_Remote_Access (T : Entity_Id) return Boolean is + begin + return Is_Record_Type (T) + and then (Is_Remote_Call_Interface (T) + or else Is_Remote_Types (T)) + and then Present (Corresponding_Remote_Type (T)) + and then Is_Access_Type (Corresponding_Remote_Type (T)); + end Is_Remote_Access; + + -- Start of processing for Specific_Type + + begin + if T1 = Any_Type or else T2 = Any_Type then + return Any_Type; + end if; + + if B1 = B2 then + return B1; + + elsif (T1 = Universal_Integer and then Is_Integer_Type (T2)) + or else (T1 = Universal_Real and then Is_Real_Type (T2)) + or else (T1 = Universal_Fixed and then Is_Fixed_Point_Type (T2)) + or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2)) + then + return B2; + + elsif (T2 = Universal_Integer and then Is_Integer_Type (T1)) + or else (T2 = Universal_Real and then Is_Real_Type (T1)) + or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1)) + or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1)) + then + return B1; + + elsif T2 = Any_String and then Is_String_Type (T1) then + return B1; + + elsif T1 = Any_String and then Is_String_Type (T2) then + return B2; + + elsif T2 = Any_Character and then Is_Character_Type (T1) then + return B1; + + elsif T1 = Any_Character and then Is_Character_Type (T2) then + return B2; + + elsif T1 = Any_Access + and then (Is_Access_Type (T2) or else Is_Remote_Access (T2)) + then + return T2; + + elsif T2 = Any_Access + and then (Is_Access_Type (T1) or else Is_Remote_Access (T1)) + then + return T1; + + elsif T2 = Any_Composite + and then Is_Aggregate_Type (T1) + then + return T1; + + elsif T1 = Any_Composite + and then Is_Aggregate_Type (T2) + then + return T2; + + elsif T1 = Any_Modular and then Is_Modular_Integer_Type (T2) then + return T2; + + elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then + return T1; + + -- ---------------------------------------------------------- + -- Special cases for equality operators (all other predefined + -- operators can never apply to tagged types) + -- ---------------------------------------------------------- + + -- Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an + -- interface + + elsif Is_Class_Wide_Type (T1) + and then Is_Class_Wide_Type (T2) + and then Is_Interface (Etype (T2)) + then + return T1; + + -- Ada 2005 (AI-251): T1 is a concrete type that implements the + -- class-wide interface T2 + + elsif Is_Class_Wide_Type (T2) + and then Is_Interface (Etype (T2)) + and then Interface_Present_In_Ancestor (Typ => T1, + Iface => Etype (T2)) + then + return T1; + + elsif Is_Class_Wide_Type (T1) + and then Is_Ancestor (Root_Type (T1), T2) + then + return T1; + + elsif Is_Class_Wide_Type (T2) + and then Is_Ancestor (Root_Type (T2), T1) + then + return T2; + + elsif (Ekind (B1) = E_Access_Subprogram_Type + or else + Ekind (B1) = E_Access_Protected_Subprogram_Type) + and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type + and then Is_Access_Type (T2) + then + return T2; + + elsif (Ekind (B2) = E_Access_Subprogram_Type + or else + Ekind (B2) = E_Access_Protected_Subprogram_Type) + and then Ekind (Designated_Type (B2)) /= E_Subprogram_Type + and then Is_Access_Type (T1) + then + return T1; + + elsif (Ekind (T1) = E_Allocator_Type + or else Ekind (T1) = E_Access_Attribute_Type + or else Ekind (T1) = E_Anonymous_Access_Type) + and then Is_Access_Type (T2) + then + return T2; + + elsif (Ekind (T2) = E_Allocator_Type + or else Ekind (T2) = E_Access_Attribute_Type + or else Ekind (T2) = E_Anonymous_Access_Type) + and then Is_Access_Type (T1) + then + return T1; + + -- If none of the above cases applies, types are not compatible + + else + return Any_Type; + end if; + end Specific_Type; + + --------------------- + -- Set_Abstract_Op -- + --------------------- + + procedure Set_Abstract_Op (I : Interp_Index; V : Entity_Id) is + begin + All_Interp.Table (I).Abstract_Op := V; + end Set_Abstract_Op; + + ----------------------- + -- Valid_Boolean_Arg -- + ----------------------- + + -- In addition to booleans and arrays of booleans, we must include + -- aggregates as valid boolean arguments, because in the first pass of + -- resolution their components are not examined. If it turns out not to be + -- an aggregate of booleans, this will be diagnosed in Resolve. + -- Any_Composite must be checked for prior to the array type checks because + -- Any_Composite does not have any associated indexes. + + function Valid_Boolean_Arg (T : Entity_Id) return Boolean is + begin + return Is_Boolean_Type (T) + or else T = Any_Composite + or else (Is_Array_Type (T) + and then T /= Any_String + and then Number_Dimensions (T) = 1 + and then Is_Boolean_Type (Component_Type (T)) + and then (not Is_Private_Composite (T) + or else In_Instance) + and then (not Is_Limited_Composite (T) + or else In_Instance)) + or else Is_Modular_Integer_Type (T) + or else T = Universal_Integer; + end Valid_Boolean_Arg; + + -------------------------- + -- Valid_Comparison_Arg -- + -------------------------- + + function Valid_Comparison_Arg (T : Entity_Id) return Boolean is + begin + + if T = Any_Composite then + return False; + elsif Is_Discrete_Type (T) + or else Is_Real_Type (T) + then + return True; + elsif Is_Array_Type (T) + and then Number_Dimensions (T) = 1 + and then Is_Discrete_Type (Component_Type (T)) + and then (not Is_Private_Composite (T) + or else In_Instance) + and then (not Is_Limited_Composite (T) + or else In_Instance) + then + return True; + elsif Is_String_Type (T) then + return True; + else + return False; + end if; + end Valid_Comparison_Arg; + + ---------------------- + -- Write_Interp_Ref -- + ---------------------- + + procedure Write_Interp_Ref (Map_Ptr : Int) is + begin + Write_Str (" Node: "); + Write_Int (Int (Interp_Map.Table (Map_Ptr).Node)); + Write_Str (" Index: "); + Write_Int (Int (Interp_Map.Table (Map_Ptr).Index)); + Write_Str (" Next: "); + Write_Int (Interp_Map.Table (Map_Ptr).Next); + Write_Eol; + end Write_Interp_Ref; + + --------------------- + -- Write_Overloads -- + --------------------- + + procedure Write_Overloads (N : Node_Id) is + I : Interp_Index; + It : Interp; + Nam : Entity_Id; + + begin + if not Is_Overloaded (N) then + Write_Str ("Non-overloaded entity "); + Write_Eol; + Write_Entity_Info (Entity (N), " "); + + else + Get_First_Interp (N, I, It); + Write_Str ("Overloaded entity "); + Write_Eol; + Write_Str (" Name Type Abstract Op"); + Write_Eol; + Write_Str ("==============================================="); + Write_Eol; + Nam := It.Nam; + + while Present (Nam) loop + Write_Int (Int (Nam)); + Write_Str (" "); + Write_Name (Chars (Nam)); + Write_Str (" "); + Write_Int (Int (It.Typ)); + Write_Str (" "); + Write_Name (Chars (It.Typ)); + + if Present (It.Abstract_Op) then + Write_Str (" "); + Write_Int (Int (It.Abstract_Op)); + Write_Str (" "); + Write_Name (Chars (It.Abstract_Op)); + end if; + + Write_Eol; + Get_Next_Interp (I, It); + Nam := It.Nam; + end loop; + end if; + end Write_Overloads; + +end Sem_Type; diff --git a/gcc/ada/sem_type.ads b/gcc/ada/sem_type.ads new file mode 100644 index 000000000..83d4bb98e --- /dev/null +++ b/gcc/ada/sem_type.ads @@ -0,0 +1,260 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ T Y P E -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit contains the routines used to handle type determination, +-- including the routine used to support overload resolution. + +with Types; use Types; + +package Sem_Type is + + --------------------------------------------- + -- Data Structures for Overload Resolution -- + --------------------------------------------- + + -- To determine the unique meaning of an identifier, overload resolution + -- may have to be performed if the visibility rules alone identify more + -- than one possible entity as the denotation of a given identifier. When + -- the visibility rules find such a potential ambiguity, the set of + -- possible interpretations must be attached to the identifier, and + -- overload resolution must be performed over the innermost enclosing + -- complete context. At the end of the resolution, either a single + -- interpretation is found for all identifiers in the context, or else a + -- type error (invalid type or ambiguous reference) must be signalled. + + -- The set of interpretations of a given name is stored in a data structure + -- that is separate from the syntax tree, because it corresponds to + -- transient information. The interpretations themselves are stored in + -- table All_Interp. A mapping from tree nodes to sets of interpretations + -- called Interp_Map, is maintained by the overload resolution routines. + -- Both these structures are initialized at the beginning of every complete + -- context. + + -- Corresponding to the set of interpretations for a given overloadable + -- identifier, there is a set of possible types corresponding to the types + -- that the overloaded call may return. We keep a 1-to-1 correspondence + -- between interpretations and types: for user-defined subprograms the type + -- is the declared return type. For operators, the type is determined by + -- the type of the arguments. If the arguments themselves are overloaded, + -- we enter the operator name in the names table for each possible result + -- type. In most cases, arguments are not overloaded and only one + -- interpretation is present anyway. + + type Interp is record + Nam : Entity_Id; + Typ : Entity_Id; + Abstract_Op : Entity_Id := Empty; + end record; + + -- Entity Abstract_Op is set to the abstract operation which potentially + -- disables the interpretation in Ada 2005 mode. + + No_Interp : constant Interp := (Empty, Empty, Empty); + + subtype Interp_Index is Int; + + --------------------- + -- Error Reporting -- + --------------------- + + -- A common error is the use of an operator in infix notation on arguments + -- of a type that is not directly visible. Rather than diagnosing a type + -- mismatch, it is better to indicate that the type can be made use-visible + -- with the appropriate use clause. The global variable Candidate_Type is + -- set in Add_One_Interp whenever an interpretation might be legal for an + -- operator if the type were directly visible. This variable is used in + -- sem_ch4 when no legal interpretation is found. + + Candidate_Type : Entity_Id; + + ----------------- + -- Subprograms -- + ----------------- + + procedure Init_Interp_Tables; + -- Invoked by gnatf when processing multiple files + + procedure Collect_Interps (N : Node_Id); + -- Invoked when the name N has more than one visible interpretation. This + -- is the high level routine which accumulates the possible interpretations + -- of the node. The first meaning and type of N have already been stored + -- in N. If the name is an expanded name, the homonyms are only those that + -- belong to the same scope. + + function Is_Invisible_Operator (N : Node_Id; T : Entity_Id) return Boolean; + -- Check whether a predefined operation with universal operands appears in + -- a context in which the operators of the expected type are not visible. + + procedure List_Interps (Nam : Node_Id; Err : Node_Id); + -- List candidate interpretations of an overloaded name. Used for various + -- error reports. + + procedure Add_One_Interp + (N : Node_Id; + E : Entity_Id; + T : Entity_Id; + Opnd_Type : Entity_Id := Empty); + -- Add (E, T) to the list of interpretations of the node being resolved. + -- For calls and operators, i.e. for nodes that have a name field, E is an + -- overloadable entity, and T is its type. For constructs such as indexed + -- expressions, the caller sets E equal to T, because the overloading comes + -- from other fields, and the node itself has no name to resolve. Hidden + -- denotes whether an interpretation has been disabled by an abstract + -- operator. Add_One_Interp includes semantic processing to deal with + -- adding entries that hide one another etc. + + -- For operators, the legality of the operation depends on the visibility + -- of T and its scope. If the operator is an equality or comparison, T is + -- always Boolean, and we use Opnd_Type, which is a candidate type for one + -- of the operands of N, to check visibility. + + procedure End_Interp_List; + -- End the list of interpretations of current node + + procedure Get_First_Interp + (N : Node_Id; + I : out Interp_Index; + It : out Interp); + -- Initialize iteration over set of interpretations for Node N. The first + -- interpretation is placed in It, and I is initialized for subsequent + -- calls to Get_Next_Interp. + + procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp); + -- Iteration step over set of interpretations. Using the value in I, which + -- was set by a previous call to Get_First_Interp or Get_Next_Interp, the + -- next interpretation is placed in It, and I is updated for the next call. + -- The end of the list of interpretations is signalled by It.Nam = Empty. + + procedure Remove_Interp (I : in out Interp_Index); + -- Remove an interpretation that his hidden by another, or that does not + -- match the context. The value of I on input was set by a call to either + -- Get_First_Interp or Get_Next_Interp and references the interpretation + -- to be removed. The only allowed use of the exit value of I is as input + -- to a subsequent call to Get_Next_Interp, which yields the interpretation + -- following the removed one. + + procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id); + -- If an overloaded node is rewritten during semantic analysis, its + -- possible interpretations must be linked to the copy. This procedure + -- transfers the overload information from Old_N, the old node, to + -- New_N, its new copy. It has no effect in the non-overloaded case. + + function Covers (T1, T2 : Entity_Id) return Boolean; + -- This is the basic type compatibility routine. T1 is the expected type, + -- imposed by context, and T2 is the actual type. The processing reflects + -- both the definition of type coverage and the rules for operand matching. + + function Disambiguate + (N : Node_Id; + I1, I2 : Interp_Index; + Typ : Entity_Id) return Interp; + -- If more than one interpretation of a name in a call is legal, apply + -- preference rules (universal types first) and operator visibility in + -- order to remove ambiguity. I1 and I2 are the first two interpretations + -- that are compatible with the context, but there may be others. + + function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean; + -- To resolve subprogram renaming and default formal subprograms in generic + -- definitions. Old_S is a possible interpretation of the entity being + -- renamed, New_S has an explicit signature. If Old_S is a subprogram, as + -- opposed to an operator, type and mode conformance are required. + + function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id; + -- Used in second pass of resolution, for equality and comparison nodes. L + -- is the left operand, whose type is known to be correct, and R is the + -- right operand, which has one interpretation compatible with that of L. + -- Return the type intersection of the two. + + function Has_Compatible_Type (N : Node_Id; Typ : Entity_Id) return Boolean; + -- Verify that some interpretation of the node N has a type compatible with + -- Typ. If N is not overloaded, then its unique type must be compatible + -- with Typ. Otherwise iterate through the interpretations of N looking for + -- a compatible one. + + function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean; + -- A user-defined function hides a predefined operator if it is matches the + -- signature of the operator, and is declared in an open scope, or in the + -- scope of the result type. + + function Interface_Present_In_Ancestor + (Typ : Entity_Id; + Iface : Entity_Id) return Boolean; + -- Ada 2005 (AI-251): Typ must be a tagged record type/subtype and Iface + -- must be an abstract interface type (or a class-wide abstract interface). + -- This function is used to check if Typ or some ancestor of Typ implements + -- Iface (returning True only if so). + + function Intersect_Types (L, R : Node_Id) return Entity_Id; + -- Find the common interpretation to two analyzed nodes. If one of the + -- interpretations is universal, choose the non-universal one. If either + -- node is overloaded, find single common interpretation. + + function In_Generic_Actual (Exp : Node_Id) return Boolean; + -- Determine whether the expression is part of a generic actual. At the + -- time the actual is resolved the scope is already that of the instance, + -- but conceptually the resolution of the actual takes place in the + -- enclosing context and no special disambiguation rules should be applied. + + function Is_Ancestor (T1, T2 : Entity_Id) return Boolean; + -- T1 is a tagged type (not class-wide). Verify that it is one of the + -- ancestors of type T2 (which may or not be class-wide). + + function Is_Progenitor + (Iface : Entity_Id; + Typ : Entity_Id) return Boolean; + -- Determine whether the interface Iface is implemented by Typ. It requires + -- traversing the list of abstract interfaces of the type, as well as that + -- of the ancestor types. The predicate is used to determine when a formal + -- in the signature of an inherited operation must carry the derived type. + + function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean; + -- Checks whether T1 is any subtype of T2 directly or indirectly. Applies + -- only to scalar subtypes??? + + function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean; + -- Used to resolve subprograms renaming operators, and calls to user + -- defined operators. Determines whether a given operator Op, matches + -- a specification, New_S. + + procedure Set_Abstract_Op (I : Interp_Index; V : Entity_Id); + -- Set the abstract operation field of an interpretation + + function Valid_Comparison_Arg (T : Entity_Id) return Boolean; + -- A valid argument to an ordering operator must be a discrete type, a + -- real type, or a one dimensional array with a discrete component type. + + function Valid_Boolean_Arg (T : Entity_Id) return Boolean; + -- A valid argument of a boolean operator is either some boolean type, or a + -- one-dimensional array of boolean type. + + procedure Write_Interp_Ref (Map_Ptr : Int); + -- Debugging procedure to display entry in Interp_Map. Would not be needed + -- if it were possible to debug instantiations of Table. + + procedure Write_Overloads (N : Node_Id); + -- Debugging procedure to output info on possibly overloaded entities for + -- specified node. + +end Sem_Type; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb new file mode 100644 index 000000000..b218b8ea6 --- /dev/null +++ b/gcc/ada/sem_util.adb @@ -0,0 +1,11921 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ U T I L -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Casing; use Casing; +with Checks; use Checks; +with Debug; use Debug; +with Errout; use Errout; +with Elists; use Elists; +with Exp_Ch11; use Exp_Ch11; +with Exp_Disp; use Exp_Disp; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Fname; use Fname; +with Freeze; use Freeze; +with Lib; use Lib; +with Lib.Xref; use Lib.Xref; +with Nlists; use Nlists; +with Output; use Output; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Attr; use Sem_Attr; +with Sem_Ch8; use Sem_Ch8; +with Sem_Disp; use Sem_Disp; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Stand; use Stand; +with Style; +with Stringt; use Stringt; +with Table; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uname; use Uname; + +with GNAT.HTable; use GNAT.HTable; + +package body Sem_Util is + + ---------------------------------------- + -- Global_Variables for New_Copy_Tree -- + ---------------------------------------- + + -- These global variables are used by New_Copy_Tree. See description + -- of the body of this subprogram for details. Global variables can be + -- safely used by New_Copy_Tree, since there is no case of a recursive + -- call from the processing inside New_Copy_Tree. + + NCT_Hash_Threshold : constant := 20; + -- If there are more than this number of pairs of entries in the + -- map, then Hash_Tables_Used will be set, and the hash tables will + -- be initialized and used for the searches. + + NCT_Hash_Tables_Used : Boolean := False; + -- Set to True if hash tables are in use + + NCT_Table_Entries : Nat; + -- Count entries in table to see if threshold is reached + + NCT_Hash_Table_Setup : Boolean := False; + -- Set to True if hash table contains data. We set this True if we + -- setup the hash table with data, and leave it set permanently + -- from then on, this is a signal that second and subsequent users + -- of the hash table must clear the old entries before reuse. + + subtype NCT_Header_Num is Int range 0 .. 511; + -- Defines range of headers in hash tables (512 headers) + + ---------------------------------- + -- Order Dependence (AI05-0144) -- + ---------------------------------- + + -- Each actual in a call is entered into the table below. A flag indicates + -- whether the corresponding formal is OUT or IN OUT. Each top-level call + -- (procedure call, condition, assignment) examines all the actuals for a + -- possible order dependence. The table is reset after each such check. + -- The actuals to be checked in a call to Check_Order_Dependence are at + -- positions 1 .. Last. + + type Actual_Name is record + Act : Node_Id; + Is_Writable : Boolean; + end record; + + package Actuals_In_Call is new Table.Table ( + Table_Component_Type => Actual_Name, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Actuals"); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Build_Component_Subtype + (C : List_Id; + Loc : Source_Ptr; + T : Entity_Id) return Node_Id; + -- This function builds the subtype for Build_Actual_Subtype_Of_Component + -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints, + -- Loc is the source location, T is the original subtype. + + function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean; + -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type + -- with discriminants whose default values are static, examine only the + -- components in the selected variant to determine whether all of them + -- have a default. + + function Has_Null_Extension (T : Entity_Id) return Boolean; + -- T is a derived tagged type. Check whether the type extension is null. + -- If the parent type is fully initialized, T can be treated as such. + + ------------------------------ + -- Abstract_Interface_List -- + ------------------------------ + + function Abstract_Interface_List (Typ : Entity_Id) return List_Id is + Nod : Node_Id; + + begin + if Is_Concurrent_Type (Typ) then + + -- If we are dealing with a synchronized subtype, go to the base + -- type, whose declaration has the interface list. + + -- Shouldn't this be Declaration_Node??? + + Nod := Parent (Base_Type (Typ)); + + if Nkind (Nod) = N_Full_Type_Declaration then + return Empty_List; + end if; + + elsif Ekind (Typ) = E_Record_Type_With_Private then + if Nkind (Parent (Typ)) = N_Full_Type_Declaration then + Nod := Type_Definition (Parent (Typ)); + + elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then + if Present (Full_View (Typ)) then + Nod := Type_Definition (Parent (Full_View (Typ))); + + -- If the full-view is not available we cannot do anything else + -- here (the source has errors). + + else + return Empty_List; + end if; + + -- Support for generic formals with interfaces is still missing ??? + + elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then + return Empty_List; + + else + pragma Assert + (Nkind (Parent (Typ)) = N_Private_Extension_Declaration); + Nod := Parent (Typ); + end if; + + elsif Ekind (Typ) = E_Record_Subtype then + Nod := Type_Definition (Parent (Etype (Typ))); + + elsif Ekind (Typ) = E_Record_Subtype_With_Private then + + -- Recurse, because parent may still be a private extension. Also + -- note that the full view of the subtype or the full view of its + -- base type may (both) be unavailable. + + return Abstract_Interface_List (Etype (Typ)); + + else pragma Assert ((Ekind (Typ)) = E_Record_Type); + if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then + Nod := Formal_Type_Definition (Parent (Typ)); + else + Nod := Type_Definition (Parent (Typ)); + end if; + end if; + + return Interface_List (Nod); + end Abstract_Interface_List; + + -------------------------------- + -- Add_Access_Type_To_Process -- + -------------------------------- + + procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is + L : Elist_Id; + + begin + Ensure_Freeze_Node (E); + L := Access_Types_To_Process (Freeze_Node (E)); + + if No (L) then + L := New_Elmt_List; + Set_Access_Types_To_Process (Freeze_Node (E), L); + end if; + + Append_Elmt (A, L); + end Add_Access_Type_To_Process; + + ---------------------------- + -- Add_Global_Declaration -- + ---------------------------- + + procedure Add_Global_Declaration (N : Node_Id) is + Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit)); + + begin + if No (Declarations (Aux_Node)) then + Set_Declarations (Aux_Node, New_List); + end if; + + Append_To (Declarations (Aux_Node), N); + Analyze (N); + end Add_Global_Declaration; + + ----------------- + -- Addressable -- + ----------------- + + -- For now, just 8/16/32/64. but analyze later if AAMP is special??? + + function Addressable (V : Uint) return Boolean is + begin + return V = Uint_8 or else + V = Uint_16 or else + V = Uint_32 or else + V = Uint_64; + end Addressable; + + function Addressable (V : Int) return Boolean is + begin + return V = 8 or else + V = 16 or else + V = 32 or else + V = 64; + end Addressable; + + ----------------------- + -- Alignment_In_Bits -- + ----------------------- + + function Alignment_In_Bits (E : Entity_Id) return Uint is + begin + return Alignment (E) * System_Storage_Unit; + end Alignment_In_Bits; + + ----------------------------------------- + -- Apply_Compile_Time_Constraint_Error -- + ----------------------------------------- + + procedure Apply_Compile_Time_Constraint_Error + (N : Node_Id; + Msg : String; + Reason : RT_Exception_Code; + Ent : Entity_Id := Empty; + Typ : Entity_Id := Empty; + Loc : Source_Ptr := No_Location; + Rep : Boolean := True; + Warn : Boolean := False) + is + Stat : constant Boolean := Is_Static_Expression (N); + R_Stat : constant Node_Id := + Make_Raise_Constraint_Error (Sloc (N), Reason => Reason); + Rtyp : Entity_Id; + + begin + if No (Typ) then + Rtyp := Etype (N); + else + Rtyp := Typ; + end if; + + Discard_Node + (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn)); + + if not Rep then + return; + end if; + + -- Now we replace the node by an N_Raise_Constraint_Error node + -- This does not need reanalyzing, so set it as analyzed now. + + Rewrite (N, R_Stat); + Set_Analyzed (N, True); + + Set_Etype (N, Rtyp); + Set_Raises_Constraint_Error (N); + + -- Now deal with possible local raise handling + + Possible_Local_Raise (N, Standard_Constraint_Error); + + -- If the original expression was marked as static, the result is + -- still marked as static, but the Raises_Constraint_Error flag is + -- always set so that further static evaluation is not attempted. + + if Stat then + Set_Is_Static_Expression (N); + end if; + end Apply_Compile_Time_Constraint_Error; + + -------------------------------- + -- Bad_Predicated_Subtype_Use -- + -------------------------------- + + procedure Bad_Predicated_Subtype_Use + (Msg : String; + N : Node_Id; + Typ : Entity_Id) + is + begin + if Has_Predicates (Typ) then + if Is_Generic_Actual_Type (Typ) then + Error_Msg_FE (Msg & '?', N, Typ); + Error_Msg_F ("\Program_Error will be raised at run time?", N); + Insert_Action (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Bad_Predicated_Generic_Type)); + + else + Error_Msg_FE (Msg, N, Typ); + end if; + end if; + end Bad_Predicated_Subtype_Use; + + -------------------------- + -- Build_Actual_Subtype -- + -------------------------- + + function Build_Actual_Subtype + (T : Entity_Id; + N : Node_Or_Entity_Id) return Node_Id + is + Loc : Source_Ptr; + -- Normally Sloc (N), but may point to corresponding body in some cases + + Constraints : List_Id; + Decl : Node_Id; + Discr : Entity_Id; + Hi : Node_Id; + Lo : Node_Id; + Subt : Entity_Id; + Disc_Type : Entity_Id; + Obj : Node_Id; + + begin + Loc := Sloc (N); + + if Nkind (N) = N_Defining_Identifier then + Obj := New_Reference_To (N, Loc); + + -- If this is a formal parameter of a subprogram declaration, and + -- we are compiling the body, we want the declaration for the + -- actual subtype to carry the source position of the body, to + -- prevent anomalies in gdb when stepping through the code. + + if Is_Formal (N) then + declare + Decl : constant Node_Id := Unit_Declaration_Node (Scope (N)); + begin + if Nkind (Decl) = N_Subprogram_Declaration + and then Present (Corresponding_Body (Decl)) + then + Loc := Sloc (Corresponding_Body (Decl)); + end if; + end; + end if; + + else + Obj := N; + end if; + + if Is_Array_Type (T) then + Constraints := New_List; + for J in 1 .. Number_Dimensions (T) loop + + -- Build an array subtype declaration with the nominal subtype and + -- the bounds of the actual. Add the declaration in front of the + -- local declarations for the subprogram, for analysis before any + -- reference to the formal in the body. + + Lo := + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), + Attribute_Name => Name_First, + Expressions => New_List ( + Make_Integer_Literal (Loc, J))); + + Hi := + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), + Attribute_Name => Name_Last, + Expressions => New_List ( + Make_Integer_Literal (Loc, J))); + + Append (Make_Range (Loc, Lo, Hi), Constraints); + end loop; + + -- If the type has unknown discriminants there is no constrained + -- subtype to build. This is never called for a formal or for a + -- lhs, so returning the type is ok ??? + + elsif Has_Unknown_Discriminants (T) then + return T; + + else + Constraints := New_List; + + -- Type T is a generic derived type, inherit the discriminants from + -- the parent type. + + if Is_Private_Type (T) + and then No (Full_View (T)) + + -- T was flagged as an error if it was declared as a formal + -- derived type with known discriminants. In this case there + -- is no need to look at the parent type since T already carries + -- its own discriminants. + + and then not Error_Posted (T) + then + Disc_Type := Etype (Base_Type (T)); + else + Disc_Type := T; + end if; + + Discr := First_Discriminant (Disc_Type); + while Present (Discr) loop + Append_To (Constraints, + Make_Selected_Component (Loc, + Prefix => + Duplicate_Subexpr_No_Checks (Obj), + Selector_Name => New_Occurrence_Of (Discr, Loc))); + Next_Discriminant (Discr); + end loop; + end if; + + Subt := Make_Temporary (Loc, 'S', Related_Node => N); + Set_Is_Internal (Subt); + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Subt, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (T, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Constraints))); + + Mark_Rewrite_Insertion (Decl); + return Decl; + end Build_Actual_Subtype; + + --------------------------------------- + -- Build_Actual_Subtype_Of_Component -- + --------------------------------------- + + function Build_Actual_Subtype_Of_Component + (T : Entity_Id; + N : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + P : constant Node_Id := Prefix (N); + D : Elmt_Id; + Id : Node_Id; + Indx_Type : Entity_Id; + + Deaccessed_T : Entity_Id; + -- This is either a copy of T, or if T is an access type, then it is + -- the directly designated type of this access type. + + function Build_Actual_Array_Constraint return List_Id; + -- If one or more of the bounds of the component depends on + -- discriminants, build actual constraint using the discriminants + -- of the prefix. + + function Build_Actual_Record_Constraint return List_Id; + -- Similar to previous one, for discriminated components constrained + -- by the discriminant of the enclosing object. + + ----------------------------------- + -- Build_Actual_Array_Constraint -- + ----------------------------------- + + function Build_Actual_Array_Constraint return List_Id is + Constraints : constant List_Id := New_List; + Indx : Node_Id; + Hi : Node_Id; + Lo : Node_Id; + Old_Hi : Node_Id; + Old_Lo : Node_Id; + + begin + Indx := First_Index (Deaccessed_T); + while Present (Indx) loop + Old_Lo := Type_Low_Bound (Etype (Indx)); + Old_Hi := Type_High_Bound (Etype (Indx)); + + if Denotes_Discriminant (Old_Lo) then + Lo := + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (P), + Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc)); + + else + Lo := New_Copy_Tree (Old_Lo); + + -- The new bound will be reanalyzed in the enclosing + -- declaration. For literal bounds that come from a type + -- declaration, the type of the context must be imposed, so + -- insure that analysis will take place. For non-universal + -- types this is not strictly necessary. + + Set_Analyzed (Lo, False); + end if; + + if Denotes_Discriminant (Old_Hi) then + Hi := + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (P), + Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc)); + + else + Hi := New_Copy_Tree (Old_Hi); + Set_Analyzed (Hi, False); + end if; + + Append (Make_Range (Loc, Lo, Hi), Constraints); + Next_Index (Indx); + end loop; + + return Constraints; + end Build_Actual_Array_Constraint; + + ------------------------------------ + -- Build_Actual_Record_Constraint -- + ------------------------------------ + + function Build_Actual_Record_Constraint return List_Id is + Constraints : constant List_Id := New_List; + D : Elmt_Id; + D_Val : Node_Id; + + begin + D := First_Elmt (Discriminant_Constraint (Deaccessed_T)); + while Present (D) loop + if Denotes_Discriminant (Node (D)) then + D_Val := Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (P), + Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc)); + + else + D_Val := New_Copy_Tree (Node (D)); + end if; + + Append (D_Val, Constraints); + Next_Elmt (D); + end loop; + + return Constraints; + end Build_Actual_Record_Constraint; + + -- Start of processing for Build_Actual_Subtype_Of_Component + + begin + -- Why the test for Spec_Expression mode here??? + + if In_Spec_Expression then + return Empty; + + -- More comments for the rest of this body would be good ??? + + elsif Nkind (N) = N_Explicit_Dereference then + if Is_Composite_Type (T) + and then not Is_Constrained (T) + and then not (Is_Class_Wide_Type (T) + and then Is_Constrained (Root_Type (T))) + and then not Has_Unknown_Discriminants (T) + then + -- If the type of the dereference is already constrained, it is an + -- actual subtype. + + if Is_Array_Type (Etype (N)) + and then Is_Constrained (Etype (N)) + then + return Empty; + else + Remove_Side_Effects (P); + return Build_Actual_Subtype (T, N); + end if; + else + return Empty; + end if; + end if; + + if Ekind (T) = E_Access_Subtype then + Deaccessed_T := Designated_Type (T); + else + Deaccessed_T := T; + end if; + + if Ekind (Deaccessed_T) = E_Array_Subtype then + Id := First_Index (Deaccessed_T); + while Present (Id) loop + Indx_Type := Underlying_Type (Etype (Id)); + + if Denotes_Discriminant (Type_Low_Bound (Indx_Type)) + or else + Denotes_Discriminant (Type_High_Bound (Indx_Type)) + then + Remove_Side_Effects (P); + return + Build_Component_Subtype + (Build_Actual_Array_Constraint, Loc, Base_Type (T)); + end if; + + Next_Index (Id); + end loop; + + elsif Is_Composite_Type (Deaccessed_T) + and then Has_Discriminants (Deaccessed_T) + and then not Has_Unknown_Discriminants (Deaccessed_T) + then + D := First_Elmt (Discriminant_Constraint (Deaccessed_T)); + while Present (D) loop + if Denotes_Discriminant (Node (D)) then + Remove_Side_Effects (P); + return + Build_Component_Subtype ( + Build_Actual_Record_Constraint, Loc, Base_Type (T)); + end if; + + Next_Elmt (D); + end loop; + end if; + + -- If none of the above, the actual and nominal subtypes are the same + + return Empty; + end Build_Actual_Subtype_Of_Component; + + ----------------------------- + -- Build_Component_Subtype -- + ----------------------------- + + function Build_Component_Subtype + (C : List_Id; + Loc : Source_Ptr; + T : Entity_Id) return Node_Id + is + Subt : Entity_Id; + Decl : Node_Id; + + begin + -- Unchecked_Union components do not require component subtypes + + if Is_Unchecked_Union (T) then + return Empty; + end if; + + Subt := Make_Temporary (Loc, 'S'); + Set_Is_Internal (Subt); + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Subt, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (Base_Type (T), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => C))); + + Mark_Rewrite_Insertion (Decl); + return Decl; + end Build_Component_Subtype; + + --------------------------- + -- Build_Default_Subtype -- + --------------------------- + + function Build_Default_Subtype + (T : Entity_Id; + N : Node_Id) return Entity_Id + is + Loc : constant Source_Ptr := Sloc (N); + Disc : Entity_Id; + + begin + if not Has_Discriminants (T) or else Is_Constrained (T) then + return T; + end if; + + Disc := First_Discriminant (T); + + if No (Discriminant_Default_Value (Disc)) then + return T; + end if; + + declare + Act : constant Entity_Id := Make_Temporary (Loc, 'S'); + Constraints : constant List_Id := New_List; + Decl : Node_Id; + + begin + while Present (Disc) loop + Append_To (Constraints, + New_Copy_Tree (Discriminant_Default_Value (Disc))); + Next_Discriminant (Disc); + end loop; + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Act, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (T, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Constraints))); + + Insert_Action (N, Decl); + Analyze (Decl); + return Act; + end; + end Build_Default_Subtype; + + -------------------------------------------- + -- Build_Discriminal_Subtype_Of_Component -- + -------------------------------------------- + + function Build_Discriminal_Subtype_Of_Component + (T : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (T); + D : Elmt_Id; + Id : Node_Id; + + function Build_Discriminal_Array_Constraint return List_Id; + -- If one or more of the bounds of the component depends on + -- discriminants, build actual constraint using the discriminants + -- of the prefix. + + function Build_Discriminal_Record_Constraint return List_Id; + -- Similar to previous one, for discriminated components constrained + -- by the discriminant of the enclosing object. + + ---------------------------------------- + -- Build_Discriminal_Array_Constraint -- + ---------------------------------------- + + function Build_Discriminal_Array_Constraint return List_Id is + Constraints : constant List_Id := New_List; + Indx : Node_Id; + Hi : Node_Id; + Lo : Node_Id; + Old_Hi : Node_Id; + Old_Lo : Node_Id; + + begin + Indx := First_Index (T); + while Present (Indx) loop + Old_Lo := Type_Low_Bound (Etype (Indx)); + Old_Hi := Type_High_Bound (Etype (Indx)); + + if Denotes_Discriminant (Old_Lo) then + Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc); + + else + Lo := New_Copy_Tree (Old_Lo); + end if; + + if Denotes_Discriminant (Old_Hi) then + Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc); + + else + Hi := New_Copy_Tree (Old_Hi); + end if; + + Append (Make_Range (Loc, Lo, Hi), Constraints); + Next_Index (Indx); + end loop; + + return Constraints; + end Build_Discriminal_Array_Constraint; + + ----------------------------------------- + -- Build_Discriminal_Record_Constraint -- + ----------------------------------------- + + function Build_Discriminal_Record_Constraint return List_Id is + Constraints : constant List_Id := New_List; + D : Elmt_Id; + D_Val : Node_Id; + + begin + D := First_Elmt (Discriminant_Constraint (T)); + while Present (D) loop + if Denotes_Discriminant (Node (D)) then + D_Val := + New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc); + + else + D_Val := New_Copy_Tree (Node (D)); + end if; + + Append (D_Val, Constraints); + Next_Elmt (D); + end loop; + + return Constraints; + end Build_Discriminal_Record_Constraint; + + -- Start of processing for Build_Discriminal_Subtype_Of_Component + + begin + if Ekind (T) = E_Array_Subtype then + Id := First_Index (T); + while Present (Id) loop + if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) or else + Denotes_Discriminant (Type_High_Bound (Etype (Id))) + then + return Build_Component_Subtype + (Build_Discriminal_Array_Constraint, Loc, T); + end if; + + Next_Index (Id); + end loop; + + elsif Ekind (T) = E_Record_Subtype + and then Has_Discriminants (T) + and then not Has_Unknown_Discriminants (T) + then + D := First_Elmt (Discriminant_Constraint (T)); + while Present (D) loop + if Denotes_Discriminant (Node (D)) then + return Build_Component_Subtype + (Build_Discriminal_Record_Constraint, Loc, T); + end if; + + Next_Elmt (D); + end loop; + end if; + + -- If none of the above, the actual and nominal subtypes are the same + + return Empty; + end Build_Discriminal_Subtype_Of_Component; + + ------------------------------ + -- Build_Elaboration_Entity -- + ------------------------------ + + procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Decl : Node_Id; + Elab_Ent : Entity_Id; + + procedure Set_Package_Name (Ent : Entity_Id); + -- Given an entity, sets the fully qualified name of the entity in + -- Name_Buffer, with components separated by double underscores. This + -- is a recursive routine that climbs the scope chain to Standard. + + ---------------------- + -- Set_Package_Name -- + ---------------------- + + procedure Set_Package_Name (Ent : Entity_Id) is + begin + if Scope (Ent) /= Standard_Standard then + Set_Package_Name (Scope (Ent)); + + declare + Nam : constant String := Get_Name_String (Chars (Ent)); + begin + Name_Buffer (Name_Len + 1) := '_'; + Name_Buffer (Name_Len + 2) := '_'; + Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam; + Name_Len := Name_Len + Nam'Length + 2; + end; + + else + Get_Name_String (Chars (Ent)); + end if; + end Set_Package_Name; + + -- Start of processing for Build_Elaboration_Entity + + begin + -- Ignore if already constructed + + if Present (Elaboration_Entity (Spec_Id)) then + return; + end if; + + -- Construct name of elaboration entity as xxx_E, where xxx is the unit + -- name with dots replaced by double underscore. We have to manually + -- construct this name, since it will be elaborated in the outer scope, + -- and thus will not have the unit name automatically prepended. + + Set_Package_Name (Spec_Id); + + -- Append _E + + Name_Buffer (Name_Len + 1) := '_'; + Name_Buffer (Name_Len + 2) := 'E'; + Name_Len := Name_Len + 2; + + -- Create elaboration flag + + Elab_Ent := + Make_Defining_Identifier (Loc, Chars => Name_Find); + Set_Elaboration_Entity (Spec_Id, Elab_Ent); + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Elab_Ent, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc), + Expression => + New_Occurrence_Of (Standard_False, Loc)); + + Push_Scope (Standard_Standard); + Add_Global_Declaration (Decl); + Pop_Scope; + + -- Reset True_Constant indication, since we will indeed assign a value + -- to the variable in the binder main. We also kill the Current_Value + -- and Last_Assignment fields for the same reason. + + Set_Is_True_Constant (Elab_Ent, False); + Set_Current_Value (Elab_Ent, Empty); + Set_Last_Assignment (Elab_Ent, Empty); + + -- We do not want any further qualification of the name (if we did + -- not do this, we would pick up the name of the generic package + -- in the case of a library level generic instantiation). + + Set_Has_Qualified_Name (Elab_Ent); + Set_Has_Fully_Qualified_Name (Elab_Ent); + end Build_Elaboration_Entity; + + ----------------------------------- + -- Cannot_Raise_Constraint_Error -- + ----------------------------------- + + function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is + begin + if Compile_Time_Known_Value (Expr) then + return True; + + elsif Do_Range_Check (Expr) then + return False; + + elsif Raises_Constraint_Error (Expr) then + return False; + + else + case Nkind (Expr) is + when N_Identifier => + return True; + + when N_Expanded_Name => + return True; + + when N_Selected_Component => + return not Do_Discriminant_Check (Expr); + + when N_Attribute_Reference => + if Do_Overflow_Check (Expr) then + return False; + + elsif No (Expressions (Expr)) then + return True; + + else + declare + N : Node_Id; + + begin + N := First (Expressions (Expr)); + while Present (N) loop + if Cannot_Raise_Constraint_Error (N) then + Next (N); + else + return False; + end if; + end loop; + + return True; + end; + end if; + + when N_Type_Conversion => + if Do_Overflow_Check (Expr) + or else Do_Length_Check (Expr) + or else Do_Tag_Check (Expr) + then + return False; + else + return + Cannot_Raise_Constraint_Error (Expression (Expr)); + end if; + + when N_Unchecked_Type_Conversion => + return Cannot_Raise_Constraint_Error (Expression (Expr)); + + when N_Unary_Op => + if Do_Overflow_Check (Expr) then + return False; + else + return + Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); + end if; + + when N_Op_Divide | + N_Op_Mod | + N_Op_Rem + => + if Do_Division_Check (Expr) + or else Do_Overflow_Check (Expr) + then + return False; + else + return + Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) + and then + Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); + end if; + + when N_Op_Add | + N_Op_And | + N_Op_Concat | + N_Op_Eq | + N_Op_Expon | + N_Op_Ge | + N_Op_Gt | + N_Op_Le | + N_Op_Lt | + N_Op_Multiply | + N_Op_Ne | + N_Op_Or | + N_Op_Rotate_Left | + N_Op_Rotate_Right | + N_Op_Shift_Left | + N_Op_Shift_Right | + N_Op_Shift_Right_Arithmetic | + N_Op_Subtract | + N_Op_Xor + => + if Do_Overflow_Check (Expr) then + return False; + else + return + Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) + and then + Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); + end if; + + when others => + return False; + end case; + end if; + end Cannot_Raise_Constraint_Error; + + ----------------------------------------- + -- Check_Dynamically_Tagged_Expression -- + ----------------------------------------- + + procedure Check_Dynamically_Tagged_Expression + (Expr : Node_Id; + Typ : Entity_Id; + Related_Nod : Node_Id) + is + begin + pragma Assert (Is_Tagged_Type (Typ)); + + -- In order to avoid spurious errors when analyzing the expanded code, + -- this check is done only for nodes that come from source and for + -- actuals of generic instantiations. + + if (Comes_From_Source (Related_Nod) + or else In_Generic_Actual (Expr)) + and then (Is_Class_Wide_Type (Etype (Expr)) + or else Is_Dynamically_Tagged (Expr)) + and then Is_Tagged_Type (Typ) + and then not Is_Class_Wide_Type (Typ) + then + Error_Msg_N ("dynamically tagged expression not allowed!", Expr); + end if; + end Check_Dynamically_Tagged_Expression; + + -------------------------- + -- Check_Fully_Declared -- + -------------------------- + + procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is + begin + if Ekind (T) = E_Incomplete_Type then + + -- Ada 2005 (AI-50217): If the type is available through a limited + -- with_clause, verify that its full view has been analyzed. + + if From_With_Type (T) + and then Present (Non_Limited_View (T)) + and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type + then + -- The non-limited view is fully declared + null; + + else + Error_Msg_NE + ("premature usage of incomplete}", N, First_Subtype (T)); + end if; + + -- Need comments for these tests ??? + + elsif Has_Private_Component (T) + and then not Is_Generic_Type (Root_Type (T)) + and then not In_Spec_Expression + then + -- Special case: if T is the anonymous type created for a single + -- task or protected object, use the name of the source object. + + if Is_Concurrent_Type (T) + and then not Comes_From_Source (T) + and then Nkind (N) = N_Object_Declaration + then + Error_Msg_NE ("type of& has incomplete component", N, + Defining_Identifier (N)); + + else + Error_Msg_NE + ("premature usage of incomplete}", N, First_Subtype (T)); + end if; + end if; + end Check_Fully_Declared; + + ------------------------- + -- Check_Nested_Access -- + ------------------------- + + procedure Check_Nested_Access (Ent : Entity_Id) is + Scop : constant Entity_Id := Current_Scope; + Current_Subp : Entity_Id; + Enclosing : Entity_Id; + + begin + -- Currently only enabled for VM back-ends for efficiency, should we + -- enable it more systematically ??? + + -- Check for Is_Imported needs commenting below ??? + + if VM_Target /= No_VM + and then (Ekind (Ent) = E_Variable + or else + Ekind (Ent) = E_Constant + or else + Ekind (Ent) = E_Loop_Parameter) + and then Scope (Ent) /= Empty + and then not Is_Library_Level_Entity (Ent) + and then not Is_Imported (Ent) + then + if Is_Subprogram (Scop) + or else Is_Generic_Subprogram (Scop) + or else Is_Entry (Scop) + then + Current_Subp := Scop; + else + Current_Subp := Current_Subprogram; + end if; + + Enclosing := Enclosing_Subprogram (Ent); + + if Enclosing /= Empty + and then Enclosing /= Current_Subp + then + Set_Has_Up_Level_Access (Ent, True); + end if; + end if; + end Check_Nested_Access; + + ---------------------------- + -- Check_Order_Dependence -- + ---------------------------- + + procedure Check_Order_Dependence is + Act1 : Node_Id; + Act2 : Node_Id; + + begin + if Ada_Version < Ada_2012 then + return; + end if; + + -- Ada 2012 AI04-0144-2: Dangerous order dependence. Actuals in nested + -- calls within a construct have been collected. If one of them is + -- writable and overlaps with another one, evaluation of the enclosing + -- construct is nondeterministic. This is illegal in Ada 2012, but is + -- treated as a warning for now. + + for J in 1 .. Actuals_In_Call.Last loop + if Actuals_In_Call.Table (J).Is_Writable then + Act1 := Actuals_In_Call.Table (J).Act; + + if Nkind (Act1) = N_Attribute_Reference then + Act1 := Prefix (Act1); + end if; + + for K in 1 .. Actuals_In_Call.Last loop + if K /= J then + Act2 := Actuals_In_Call.Table (K).Act; + + if Nkind (Act2) = N_Attribute_Reference then + Act2 := Prefix (Act2); + end if; + + if Actuals_In_Call.Table (K).Is_Writable + and then K < J + then + -- Already checked + + null; + + elsif Denotes_Same_Object (Act1, Act2) + and then Parent (Act1) /= Parent (Act2) + then + Error_Msg_N + ("result may differ if evaluated " + & "after other actual in expression?", Act1); + end if; + end if; + end loop; + end if; + end loop; + + -- Remove checked actuals from table + + Actuals_In_Call.Set_Last (0); + end Check_Order_Dependence; + + ------------------------------------------ + -- Check_Potentially_Blocking_Operation -- + ------------------------------------------ + + procedure Check_Potentially_Blocking_Operation (N : Node_Id) is + S : Entity_Id; + + begin + -- N is one of the potentially blocking operations listed in 9.5.1(8). + -- When pragma Detect_Blocking is active, the run time will raise + -- Program_Error. Here we only issue a warning, since we generally + -- support the use of potentially blocking operations in the absence + -- of the pragma. + + -- Indirect blocking through a subprogram call cannot be diagnosed + -- statically without interprocedural analysis, so we do not attempt + -- to do it here. + + S := Scope (Current_Scope); + while Present (S) and then S /= Standard_Standard loop + if Is_Protected_Type (S) then + Error_Msg_N + ("potentially blocking operation in protected operation?", N); + return; + end if; + + S := Scope (S); + end loop; + end Check_Potentially_Blocking_Operation; + + ------------------------------ + -- Check_Unprotected_Access -- + ------------------------------ + + procedure Check_Unprotected_Access + (Context : Node_Id; + Expr : Node_Id) + is + Cont_Encl_Typ : Entity_Id; + Pref_Encl_Typ : Entity_Id; + + function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id; + -- Check whether Obj is a private component of a protected object. + -- Return the protected type where the component resides, Empty + -- otherwise. + + function Is_Public_Operation return Boolean; + -- Verify that the enclosing operation is callable from outside the + -- protected object, to minimize false positives. + + ------------------------------ + -- Enclosing_Protected_Type -- + ------------------------------ + + function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is + begin + if Is_Entity_Name (Obj) then + declare + Ent : Entity_Id := Entity (Obj); + + begin + -- The object can be a renaming of a private component, use + -- the original record component. + + if Is_Prival (Ent) then + Ent := Prival_Link (Ent); + end if; + + if Is_Protected_Type (Scope (Ent)) then + return Scope (Ent); + end if; + end; + end if; + + -- For indexed and selected components, recursively check the prefix + + if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then + return Enclosing_Protected_Type (Prefix (Obj)); + + -- The object does not denote a protected component + + else + return Empty; + end if; + end Enclosing_Protected_Type; + + ------------------------- + -- Is_Public_Operation -- + ------------------------- + + function Is_Public_Operation return Boolean is + S : Entity_Id; + E : Entity_Id; + + begin + S := Current_Scope; + while Present (S) + and then S /= Pref_Encl_Typ + loop + if Scope (S) = Pref_Encl_Typ then + E := First_Entity (Pref_Encl_Typ); + while Present (E) + and then E /= First_Private_Entity (Pref_Encl_Typ) + loop + if E = S then + return True; + end if; + Next_Entity (E); + end loop; + end if; + + S := Scope (S); + end loop; + + return False; + end Is_Public_Operation; + + -- Start of processing for Check_Unprotected_Access + + begin + if Nkind (Expr) = N_Attribute_Reference + and then Attribute_Name (Expr) = Name_Unchecked_Access + then + Cont_Encl_Typ := Enclosing_Protected_Type (Context); + Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr)); + + -- Check whether we are trying to export a protected component to a + -- context with an equal or lower access level. + + if Present (Pref_Encl_Typ) + and then No (Cont_Encl_Typ) + and then Is_Public_Operation + and then Scope_Depth (Pref_Encl_Typ) >= + Object_Access_Level (Context) + then + Error_Msg_N + ("?possible unprotected access to protected data", Expr); + end if; + end if; + end Check_Unprotected_Access; + + --------------- + -- Check_VMS -- + --------------- + + procedure Check_VMS (Construct : Node_Id) is + begin + if not OpenVMS_On_Target then + Error_Msg_N + ("this construct is allowed only in Open'V'M'S", Construct); + end if; + end Check_VMS; + + ------------------------ + -- Collect_Interfaces -- + ------------------------ + + procedure Collect_Interfaces + (T : Entity_Id; + Ifaces_List : out Elist_Id; + Exclude_Parents : Boolean := False; + Use_Full_View : Boolean := True) + is + procedure Collect (Typ : Entity_Id); + -- Subsidiary subprogram used to traverse the whole list + -- of directly and indirectly implemented interfaces + + ------------- + -- Collect -- + ------------- + + procedure Collect (Typ : Entity_Id) is + Ancestor : Entity_Id; + Full_T : Entity_Id; + Id : Node_Id; + Iface : Entity_Id; + + begin + Full_T := Typ; + + -- Handle private types + + if Use_Full_View + and then Is_Private_Type (Typ) + and then Present (Full_View (Typ)) + then + Full_T := Full_View (Typ); + end if; + + -- Include the ancestor if we are generating the whole list of + -- abstract interfaces. + + if Etype (Full_T) /= Typ + + -- Protect the frontend against wrong sources. For example: + + -- package P is + -- type A is tagged null record; + -- type B is new A with private; + -- type C is new A with private; + -- private + -- type B is new C with null record; + -- type C is new B with null record; + -- end P; + + and then Etype (Full_T) /= T + then + Ancestor := Etype (Full_T); + Collect (Ancestor); + + if Is_Interface (Ancestor) + and then not Exclude_Parents + then + Append_Unique_Elmt (Ancestor, Ifaces_List); + end if; + end if; + + -- Traverse the graph of ancestor interfaces + + if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then + Id := First (Abstract_Interface_List (Full_T)); + while Present (Id) loop + Iface := Etype (Id); + + -- Protect against wrong uses. For example: + -- type I is interface; + -- type O is tagged null record; + -- type Wrong is new I and O with null record; -- ERROR + + if Is_Interface (Iface) then + if Exclude_Parents + and then Etype (T) /= T + and then Interface_Present_In_Ancestor (Etype (T), Iface) + then + null; + else + Collect (Iface); + Append_Unique_Elmt (Iface, Ifaces_List); + end if; + end if; + + Next (Id); + end loop; + end if; + end Collect; + + -- Start of processing for Collect_Interfaces + + begin + pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T)); + Ifaces_List := New_Elmt_List; + Collect (T); + end Collect_Interfaces; + + ---------------------------------- + -- Collect_Interface_Components -- + ---------------------------------- + + procedure Collect_Interface_Components + (Tagged_Type : Entity_Id; + Components_List : out Elist_Id) + is + procedure Collect (Typ : Entity_Id); + -- Subsidiary subprogram used to climb to the parents + + ------------- + -- Collect -- + ------------- + + procedure Collect (Typ : Entity_Id) is + Tag_Comp : Entity_Id; + Parent_Typ : Entity_Id; + + begin + -- Handle private types + + if Present (Full_View (Etype (Typ))) then + Parent_Typ := Full_View (Etype (Typ)); + else + Parent_Typ := Etype (Typ); + end if; + + if Parent_Typ /= Typ + + -- Protect the frontend against wrong sources. For example: + + -- package P is + -- type A is tagged null record; + -- type B is new A with private; + -- type C is new A with private; + -- private + -- type B is new C with null record; + -- type C is new B with null record; + -- end P; + + and then Parent_Typ /= Tagged_Type + then + Collect (Parent_Typ); + end if; + + -- Collect the components containing tags of secondary dispatch + -- tables. + + Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ)); + while Present (Tag_Comp) loop + pragma Assert (Present (Related_Type (Tag_Comp))); + Append_Elmt (Tag_Comp, Components_List); + + Tag_Comp := Next_Tag_Component (Tag_Comp); + end loop; + end Collect; + + -- Start of processing for Collect_Interface_Components + + begin + pragma Assert (Ekind (Tagged_Type) = E_Record_Type + and then Is_Tagged_Type (Tagged_Type)); + + Components_List := New_Elmt_List; + Collect (Tagged_Type); + end Collect_Interface_Components; + + ----------------------------- + -- Collect_Interfaces_Info -- + ----------------------------- + + procedure Collect_Interfaces_Info + (T : Entity_Id; + Ifaces_List : out Elist_Id; + Components_List : out Elist_Id; + Tags_List : out Elist_Id) + is + Comps_List : Elist_Id; + Comp_Elmt : Elmt_Id; + Comp_Iface : Entity_Id; + Iface_Elmt : Elmt_Id; + Iface : Entity_Id; + + function Search_Tag (Iface : Entity_Id) return Entity_Id; + -- Search for the secondary tag associated with the interface type + -- Iface that is implemented by T. + + ---------------- + -- Search_Tag -- + ---------------- + + function Search_Tag (Iface : Entity_Id) return Entity_Id is + ADT : Elmt_Id; + begin + if not Is_CPP_Class (T) then + ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T)))); + else + ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T))); + end if; + + while Present (ADT) + and then Is_Tag (Node (ADT)) + and then Related_Type (Node (ADT)) /= Iface + loop + -- Skip secondary dispatch table referencing thunks to user + -- defined primitives covered by this interface. + + pragma Assert (Has_Suffix (Node (ADT), 'P')); + Next_Elmt (ADT); + + -- Skip secondary dispatch tables of Ada types + + if not Is_CPP_Class (T) then + + -- Skip secondary dispatch table referencing thunks to + -- predefined primitives. + + pragma Assert (Has_Suffix (Node (ADT), 'Y')); + Next_Elmt (ADT); + + -- Skip secondary dispatch table referencing user-defined + -- primitives covered by this interface. + + pragma Assert (Has_Suffix (Node (ADT), 'D')); + Next_Elmt (ADT); + + -- Skip secondary dispatch table referencing predefined + -- primitives. + + pragma Assert (Has_Suffix (Node (ADT), 'Z')); + Next_Elmt (ADT); + end if; + end loop; + + pragma Assert (Is_Tag (Node (ADT))); + return Node (ADT); + end Search_Tag; + + -- Start of processing for Collect_Interfaces_Info + + begin + Collect_Interfaces (T, Ifaces_List); + Collect_Interface_Components (T, Comps_List); + + -- Search for the record component and tag associated with each + -- interface type of T. + + Components_List := New_Elmt_List; + Tags_List := New_Elmt_List; + + Iface_Elmt := First_Elmt (Ifaces_List); + while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); + + -- Associate the primary tag component and the primary dispatch table + -- with all the interfaces that are parents of T + + if Is_Ancestor (Iface, T) then + Append_Elmt (First_Tag_Component (T), Components_List); + Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List); + + -- Otherwise search for the tag component and secondary dispatch + -- table of Iface + + else + Comp_Elmt := First_Elmt (Comps_List); + while Present (Comp_Elmt) loop + Comp_Iface := Related_Type (Node (Comp_Elmt)); + + if Comp_Iface = Iface + or else Is_Ancestor (Iface, Comp_Iface) + then + Append_Elmt (Node (Comp_Elmt), Components_List); + Append_Elmt (Search_Tag (Comp_Iface), Tags_List); + exit; + end if; + + Next_Elmt (Comp_Elmt); + end loop; + pragma Assert (Present (Comp_Elmt)); + end if; + + Next_Elmt (Iface_Elmt); + end loop; + end Collect_Interfaces_Info; + + --------------------- + -- Collect_Parents -- + --------------------- + + procedure Collect_Parents + (T : Entity_Id; + List : out Elist_Id; + Use_Full_View : Boolean := True) + is + Current_Typ : Entity_Id := T; + Parent_Typ : Entity_Id; + + begin + List := New_Elmt_List; + + -- No action if the if the type has no parents + + if T = Etype (T) then + return; + end if; + + loop + Parent_Typ := Etype (Current_Typ); + + if Is_Private_Type (Parent_Typ) + and then Present (Full_View (Parent_Typ)) + and then Use_Full_View + then + Parent_Typ := Full_View (Base_Type (Parent_Typ)); + end if; + + Append_Elmt (Parent_Typ, List); + + exit when Parent_Typ = Current_Typ; + Current_Typ := Parent_Typ; + end loop; + end Collect_Parents; + + ---------------------------------- + -- Collect_Primitive_Operations -- + ---------------------------------- + + function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is + B_Type : constant Entity_Id := Base_Type (T); + B_Decl : constant Node_Id := Original_Node (Parent (B_Type)); + B_Scope : Entity_Id := Scope (B_Type); + Op_List : Elist_Id; + Formal : Entity_Id; + Is_Prim : Boolean; + Formal_Derived : Boolean := False; + Id : Entity_Id; + + function Match (E : Entity_Id) return Boolean; + -- True if E's base type is B_Type, or E is of an anonymous access type + -- and the base type of its designated type is B_Type. + + ----------- + -- Match -- + ----------- + + function Match (E : Entity_Id) return Boolean is + Etyp : Entity_Id := Etype (E); + + begin + if Ekind (Etyp) = E_Anonymous_Access_Type then + Etyp := Designated_Type (Etyp); + end if; + + return Base_Type (Etyp) = B_Type; + end Match; + + -- Start of processing for Collect_Primitive_Operations + + begin + -- For tagged types, the primitive operations are collected as they + -- are declared, and held in an explicit list which is simply returned. + + if Is_Tagged_Type (B_Type) then + return Primitive_Operations (B_Type); + + -- An untagged generic type that is a derived type inherits the + -- primitive operations of its parent type. Other formal types only + -- have predefined operators, which are not explicitly represented. + + elsif Is_Generic_Type (B_Type) then + if Nkind (B_Decl) = N_Formal_Type_Declaration + and then Nkind (Formal_Type_Definition (B_Decl)) + = N_Formal_Derived_Type_Definition + then + Formal_Derived := True; + else + return New_Elmt_List; + end if; + end if; + + Op_List := New_Elmt_List; + + if B_Scope = Standard_Standard then + if B_Type = Standard_String then + Append_Elmt (Standard_Op_Concat, Op_List); + + elsif B_Type = Standard_Wide_String then + Append_Elmt (Standard_Op_Concatw, Op_List); + + else + null; + end if; + + elsif (Is_Package_Or_Generic_Package (B_Scope) + and then + Nkind (Parent (Declaration_Node (First_Subtype (T)))) /= + N_Package_Body) + or else Is_Derived_Type (B_Type) + then + -- The primitive operations appear after the base type, except + -- if the derivation happens within the private part of B_Scope + -- and the type is a private type, in which case both the type + -- and some primitive operations may appear before the base + -- type, and the list of candidates starts after the type. + + if In_Open_Scopes (B_Scope) + and then Scope (T) = B_Scope + and then In_Private_Part (B_Scope) + then + Id := Next_Entity (T); + else + Id := Next_Entity (B_Type); + end if; + + while Present (Id) loop + + -- Note that generic formal subprograms are not + -- considered to be primitive operations and thus + -- are never inherited. + + if Is_Overloadable (Id) + and then Nkind (Parent (Parent (Id))) + not in N_Formal_Subprogram_Declaration + then + Is_Prim := False; + + if Match (Id) then + Is_Prim := True; + + else + Formal := First_Formal (Id); + while Present (Formal) loop + if Match (Formal) then + Is_Prim := True; + exit; + end if; + + Next_Formal (Formal); + end loop; + end if; + + -- For a formal derived type, the only primitives are the + -- ones inherited from the parent type. Operations appearing + -- in the package declaration are not primitive for it. + + if Is_Prim + and then (not Formal_Derived + or else Present (Alias (Id))) + then + -- In the special case of an equality operator aliased to + -- an overriding dispatching equality belonging to the same + -- type, we don't include it in the list of primitives. + -- This avoids inheriting multiple equality operators when + -- deriving from untagged private types whose full type is + -- tagged, which can otherwise cause ambiguities. Note that + -- this should only happen for this kind of untagged parent + -- type, since normally dispatching operations are inherited + -- using the type's Primitive_Operations list. + + if Chars (Id) = Name_Op_Eq + and then Is_Dispatching_Operation (Id) + and then Present (Alias (Id)) + and then Present (Overridden_Operation (Alias (Id))) + and then Base_Type (Etype (First_Entity (Id))) = + Base_Type (Etype (First_Entity (Alias (Id)))) + then + null; + + -- Include the subprogram in the list of primitives + + else + Append_Elmt (Id, Op_List); + end if; + end if; + end if; + + Next_Entity (Id); + + -- For a type declared in System, some of its operations may + -- appear in the target-specific extension to System. + + if No (Id) + and then B_Scope = RTU_Entity (System) + and then Present_System_Aux + then + B_Scope := System_Aux_Id; + Id := First_Entity (System_Aux_Id); + end if; + end loop; + end if; + + return Op_List; + end Collect_Primitive_Operations; + + ----------------------------------- + -- Compile_Time_Constraint_Error -- + ----------------------------------- + + function Compile_Time_Constraint_Error + (N : Node_Id; + Msg : String; + Ent : Entity_Id := Empty; + Loc : Source_Ptr := No_Location; + Warn : Boolean := False) return Node_Id + is + Msgc : String (1 .. Msg'Length + 2); + -- Copy of message, with room for possible ? and ! at end + + Msgl : Natural; + Wmsg : Boolean; + P : Node_Id; + OldP : Node_Id; + Msgs : Boolean; + Eloc : Source_Ptr; + + begin + -- A static constraint error in an instance body is not a fatal error. + -- we choose to inhibit the message altogether, because there is no + -- obvious node (for now) on which to post it. On the other hand the + -- offending node must be replaced with a constraint_error in any case. + + -- No messages are generated if we already posted an error on this node + + if not Error_Posted (N) then + if Loc /= No_Location then + Eloc := Loc; + else + Eloc := Sloc (N); + end if; + + Msgc (1 .. Msg'Length) := Msg; + Msgl := Msg'Length; + + -- Message is a warning, even in Ada 95 case + + if Msg (Msg'Last) = '?' then + Wmsg := True; + + -- In Ada 83, all messages are warnings. In the private part and + -- the body of an instance, constraint_checks are only warnings. + -- We also make this a warning if the Warn parameter is set. + + elsif Warn + or else (Ada_Version = Ada_83 and then Comes_From_Source (N)) + then + Msgl := Msgl + 1; + Msgc (Msgl) := '?'; + Wmsg := True; + + elsif In_Instance_Not_Visible then + Msgl := Msgl + 1; + Msgc (Msgl) := '?'; + Wmsg := True; + + -- Otherwise we have a real error message (Ada 95 static case) + -- and we make this an unconditional message. Note that in the + -- warning case we do not make the message unconditional, it seems + -- quite reasonable to delete messages like this (about exceptions + -- that will be raised) in dead code. + + else + Wmsg := False; + Msgl := Msgl + 1; + Msgc (Msgl) := '!'; + end if; + + -- Should we generate a warning? The answer is not quite yes. The + -- very annoying exception occurs in the case of a short circuit + -- operator where the left operand is static and decisive. Climb + -- parents to see if that is the case we have here. Conditional + -- expressions with decisive conditions are a similar situation. + + Msgs := True; + P := N; + loop + OldP := P; + P := Parent (P); + + -- And then with False as left operand + + if Nkind (P) = N_And_Then + and then Compile_Time_Known_Value (Left_Opnd (P)) + and then Is_False (Expr_Value (Left_Opnd (P))) + then + Msgs := False; + exit; + + -- OR ELSE with True as left operand + + elsif Nkind (P) = N_Or_Else + and then Compile_Time_Known_Value (Left_Opnd (P)) + and then Is_True (Expr_Value (Left_Opnd (P))) + then + Msgs := False; + exit; + + -- Conditional expression + + elsif Nkind (P) = N_Conditional_Expression then + declare + Cond : constant Node_Id := First (Expressions (P)); + Texp : constant Node_Id := Next (Cond); + Fexp : constant Node_Id := Next (Texp); + + begin + if Compile_Time_Known_Value (Cond) then + + -- Condition is True and we are in the right operand + + if Is_True (Expr_Value (Cond)) + and then OldP = Fexp + then + Msgs := False; + exit; + + -- Condition is False and we are in the left operand + + elsif Is_False (Expr_Value (Cond)) + and then OldP = Texp + then + Msgs := False; + exit; + end if; + end if; + end; + + -- Special case for component association in aggregates, where + -- we want to keep climbing up to the parent aggregate. + + elsif Nkind (P) = N_Component_Association + and then Nkind (Parent (P)) = N_Aggregate + then + null; + + -- Keep going if within subexpression + + else + exit when Nkind (P) not in N_Subexpr; + end if; + end loop; + + if Msgs then + if Present (Ent) then + Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc); + else + Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc); + end if; + + if Wmsg then + if Inside_Init_Proc then + Error_Msg_NEL + ("\?& will be raised for objects of this type", + N, Standard_Constraint_Error, Eloc); + else + Error_Msg_NEL + ("\?& will be raised at run time", + N, Standard_Constraint_Error, Eloc); + end if; + + else + Error_Msg + ("\static expression fails Constraint_Check", Eloc); + Set_Error_Posted (N); + end if; + end if; + end if; + + return N; + end Compile_Time_Constraint_Error; + + ----------------------- + -- Conditional_Delay -- + ----------------------- + + procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is + begin + if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then + Set_Has_Delayed_Freeze (New_Ent); + end if; + end Conditional_Delay; + + ------------------------- + -- Copy_Parameter_List -- + ------------------------- + + function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (Subp_Id); + Plist : List_Id; + Formal : Entity_Id; + + begin + if No (First_Formal (Subp_Id)) then + return No_List; + else + Plist := New_List; + Formal := First_Formal (Subp_Id); + while Present (Formal) loop + Append + (Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Sloc (Formal), + Chars => Chars (Formal)), + In_Present => In_Present (Parent (Formal)), + Out_Present => Out_Present (Parent (Formal)), + Parameter_Type => + New_Reference_To (Etype (Formal), Loc), + Expression => + New_Copy_Tree (Expression (Parent (Formal)))), + Plist); + + Next_Formal (Formal); + end loop; + end if; + + return Plist; + end Copy_Parameter_List; + + -------------------- + -- Current_Entity -- + -------------------- + + -- The currently visible definition for a given identifier is the + -- one most chained at the start of the visibility chain, i.e. the + -- one that is referenced by the Node_Id value of the name of the + -- given identifier. + + function Current_Entity (N : Node_Id) return Entity_Id is + begin + return Get_Name_Entity_Id (Chars (N)); + end Current_Entity; + + ----------------------------- + -- Current_Entity_In_Scope -- + ----------------------------- + + function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is + E : Entity_Id; + CS : constant Entity_Id := Current_Scope; + + Transient_Case : constant Boolean := Scope_Is_Transient; + + begin + E := Get_Name_Entity_Id (Chars (N)); + while Present (E) + and then Scope (E) /= CS + and then (not Transient_Case or else Scope (E) /= Scope (CS)) + loop + E := Homonym (E); + end loop; + + return E; + end Current_Entity_In_Scope; + + ------------------- + -- Current_Scope -- + ------------------- + + function Current_Scope return Entity_Id is + begin + if Scope_Stack.Last = -1 then + return Standard_Standard; + else + declare + C : constant Entity_Id := + Scope_Stack.Table (Scope_Stack.Last).Entity; + begin + if Present (C) then + return C; + else + return Standard_Standard; + end if; + end; + end if; + end Current_Scope; + + ------------------------ + -- Current_Subprogram -- + ------------------------ + + function Current_Subprogram return Entity_Id is + Scop : constant Entity_Id := Current_Scope; + begin + if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then + return Scop; + else + return Enclosing_Subprogram (Scop); + end if; + end Current_Subprogram; + + --------------------- + -- Defining_Entity -- + --------------------- + + function Defining_Entity (N : Node_Id) return Entity_Id is + K : constant Node_Kind := Nkind (N); + Err : Entity_Id := Empty; + + begin + case K is + when + N_Subprogram_Declaration | + N_Abstract_Subprogram_Declaration | + N_Subprogram_Body | + N_Package_Declaration | + N_Subprogram_Renaming_Declaration | + N_Subprogram_Body_Stub | + N_Generic_Subprogram_Declaration | + N_Generic_Package_Declaration | + N_Formal_Subprogram_Declaration + => + return Defining_Entity (Specification (N)); + + when + N_Component_Declaration | + N_Defining_Program_Unit_Name | + N_Discriminant_Specification | + N_Entry_Body | + N_Entry_Declaration | + N_Entry_Index_Specification | + N_Exception_Declaration | + N_Exception_Renaming_Declaration | + N_Formal_Object_Declaration | + N_Formal_Package_Declaration | + N_Formal_Type_Declaration | + N_Full_Type_Declaration | + N_Implicit_Label_Declaration | + N_Incomplete_Type_Declaration | + N_Loop_Parameter_Specification | + N_Number_Declaration | + N_Object_Declaration | + N_Object_Renaming_Declaration | + N_Package_Body_Stub | + N_Parameter_Specification | + N_Private_Extension_Declaration | + N_Private_Type_Declaration | + N_Protected_Body | + N_Protected_Body_Stub | + N_Protected_Type_Declaration | + N_Single_Protected_Declaration | + N_Single_Task_Declaration | + N_Subtype_Declaration | + N_Task_Body | + N_Task_Body_Stub | + N_Task_Type_Declaration + => + return Defining_Identifier (N); + + when N_Subunit => + return Defining_Entity (Proper_Body (N)); + + when + N_Function_Instantiation | + N_Function_Specification | + N_Generic_Function_Renaming_Declaration | + N_Generic_Package_Renaming_Declaration | + N_Generic_Procedure_Renaming_Declaration | + N_Package_Body | + N_Package_Instantiation | + N_Package_Renaming_Declaration | + N_Package_Specification | + N_Procedure_Instantiation | + N_Procedure_Specification + => + declare + Nam : constant Node_Id := Defining_Unit_Name (N); + + begin + if Nkind (Nam) in N_Entity then + return Nam; + + -- For Error, make up a name and attach to declaration + -- so we can continue semantic analysis + + elsif Nam = Error then + Err := Make_Temporary (Sloc (N), 'T'); + Set_Defining_Unit_Name (N, Err); + + return Err; + -- If not an entity, get defining identifier + + else + return Defining_Identifier (Nam); + end if; + end; + + when N_Block_Statement => + return Entity (Identifier (N)); + + when others => + raise Program_Error; + + end case; + end Defining_Entity; + + -------------------------- + -- Denotes_Discriminant -- + -------------------------- + + function Denotes_Discriminant + (N : Node_Id; + Check_Concurrent : Boolean := False) return Boolean + is + E : Entity_Id; + begin + if not Is_Entity_Name (N) + or else No (Entity (N)) + then + return False; + else + E := Entity (N); + end if; + + -- If we are checking for a protected type, the discriminant may have + -- been rewritten as the corresponding discriminal of the original type + -- or of the corresponding concurrent record, depending on whether we + -- are in the spec or body of the protected type. + + return Ekind (E) = E_Discriminant + or else + (Check_Concurrent + and then Ekind (E) = E_In_Parameter + and then Present (Discriminal_Link (E)) + and then + (Is_Concurrent_Type (Scope (Discriminal_Link (E))) + or else + Is_Concurrent_Record_Type (Scope (Discriminal_Link (E))))); + + end Denotes_Discriminant; + + ------------------------- + -- Denotes_Same_Object -- + ------------------------- + + function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is + Obj1 : Node_Id := A1; + Obj2 : Node_Id := A2; + + procedure Check_Renaming (Obj : in out Node_Id); + -- If an object is a renaming, examine renamed object. If it is a + -- dereference of a variable, or an indexed expression with non-constant + -- indexes, no overlap check can be reported. + + -------------------- + -- Check_Renaming -- + -------------------- + + procedure Check_Renaming (Obj : in out Node_Id) is + begin + if Is_Entity_Name (Obj) + and then Present (Renamed_Entity (Entity (Obj))) + then + Obj := Renamed_Entity (Entity (Obj)); + if Nkind (Obj) = N_Explicit_Dereference + and then Is_Variable (Prefix (Obj)) + then + Obj := Empty; + + elsif Nkind (Obj) = N_Indexed_Component then + declare + Indx : Node_Id; + + begin + Indx := First (Expressions (Obj)); + while Present (Indx) loop + if not Is_OK_Static_Expression (Indx) then + Obj := Empty; + exit; + end if; + + Next_Index (Indx); + end loop; + end; + end if; + end if; + end Check_Renaming; + + -- Start of processing for Denotes_Same_Object + + begin + Check_Renaming (Obj1); + Check_Renaming (Obj2); + + if No (Obj1) + or else No (Obj2) + then + return False; + end if; + + -- If we have entity names, then must be same entity + + if Is_Entity_Name (Obj1) then + if Is_Entity_Name (Obj2) then + return Entity (Obj1) = Entity (Obj2); + else + return False; + end if; + + -- No match if not same node kind + + elsif Nkind (Obj1) /= Nkind (Obj2) then + return False; + + -- For selected components, must have same prefix and selector + + elsif Nkind (Obj1) = N_Selected_Component then + return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) + and then + Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2)); + + -- For explicit dereferences, prefixes must be same + + elsif Nkind (Obj1) = N_Explicit_Dereference then + return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)); + + -- For indexed components, prefixes and all subscripts must be the same + + elsif Nkind (Obj1) = N_Indexed_Component then + if Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then + declare + Indx1 : Node_Id; + Indx2 : Node_Id; + + begin + Indx1 := First (Expressions (Obj1)); + Indx2 := First (Expressions (Obj2)); + while Present (Indx1) loop + + -- Indexes must denote the same static value or same object + + if Is_OK_Static_Expression (Indx1) then + if not Is_OK_Static_Expression (Indx2) then + return False; + + elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then + return False; + end if; + + elsif not Denotes_Same_Object (Indx1, Indx2) then + return False; + end if; + + Next (Indx1); + Next (Indx2); + end loop; + + return True; + end; + else + return False; + end if; + + -- For slices, prefixes must match and bounds must match + + elsif Nkind (Obj1) = N_Slice + and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) + then + declare + Lo1, Lo2, Hi1, Hi2 : Node_Id; + + begin + Get_Index_Bounds (Etype (Obj1), Lo1, Hi1); + Get_Index_Bounds (Etype (Obj2), Lo2, Hi2); + + -- Check whether bounds are statically identical. There is no + -- attempt to detect partial overlap of slices. + + return Denotes_Same_Object (Lo1, Lo2) + and then Denotes_Same_Object (Hi1, Hi2); + end; + + -- Literals will appear as indexes. Isn't this where we should check + -- Known_At_Compile_Time at least if we are generating warnings ??? + + elsif Nkind (Obj1) = N_Integer_Literal then + return Intval (Obj1) = Intval (Obj2); + + else + return False; + end if; + end Denotes_Same_Object; + + ------------------------- + -- Denotes_Same_Prefix -- + ------------------------- + + function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is + + begin + if Is_Entity_Name (A1) then + if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) + and then not Is_Access_Type (Etype (A1)) + then + return Denotes_Same_Object (A1, Prefix (A2)) + or else Denotes_Same_Prefix (A1, Prefix (A2)); + else + return False; + end if; + + elsif Is_Entity_Name (A2) then + return Denotes_Same_Prefix (A2, A1); + + elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice) + and then + Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice) + then + declare + Root1, Root2 : Node_Id; + Depth1, Depth2 : Int := 0; + + begin + Root1 := Prefix (A1); + while not Is_Entity_Name (Root1) loop + if not Nkind_In + (Root1, N_Selected_Component, N_Indexed_Component) + then + return False; + else + Root1 := Prefix (Root1); + end if; + + Depth1 := Depth1 + 1; + end loop; + + Root2 := Prefix (A2); + while not Is_Entity_Name (Root2) loop + if not Nkind_In + (Root2, N_Selected_Component, N_Indexed_Component) + then + return False; + else + Root2 := Prefix (Root2); + end if; + + Depth2 := Depth2 + 1; + end loop; + + -- If both have the same depth and they do not denote the same + -- object, they are disjoint and not warning is needed. + + if Depth1 = Depth2 then + return False; + + elsif Depth1 > Depth2 then + Root1 := Prefix (A1); + for I in 1 .. Depth1 - Depth2 - 1 loop + Root1 := Prefix (Root1); + end loop; + + return Denotes_Same_Object (Root1, A2); + + else + Root2 := Prefix (A2); + for I in 1 .. Depth2 - Depth1 - 1 loop + Root2 := Prefix (Root2); + end loop; + + return Denotes_Same_Object (A1, Root2); + end if; + end; + + else + return False; + end if; + end Denotes_Same_Prefix; + + ---------------------- + -- Denotes_Variable -- + ---------------------- + + function Denotes_Variable (N : Node_Id) return Boolean is + begin + return Is_Variable (N) and then Paren_Count (N) = 0; + end Denotes_Variable; + + ----------------------------- + -- Depends_On_Discriminant -- + ----------------------------- + + function Depends_On_Discriminant (N : Node_Id) return Boolean is + L : Node_Id; + H : Node_Id; + + begin + Get_Index_Bounds (N, L, H); + return Denotes_Discriminant (L) or else Denotes_Discriminant (H); + end Depends_On_Discriminant; + + ------------------------- + -- Designate_Same_Unit -- + ------------------------- + + function Designate_Same_Unit + (Name1 : Node_Id; + Name2 : Node_Id) return Boolean + is + K1 : constant Node_Kind := Nkind (Name1); + K2 : constant Node_Kind := Nkind (Name2); + + function Prefix_Node (N : Node_Id) return Node_Id; + -- Returns the parent unit name node of a defining program unit name + -- or the prefix if N is a selected component or an expanded name. + + function Select_Node (N : Node_Id) return Node_Id; + -- Returns the defining identifier node of a defining program unit + -- name or the selector node if N is a selected component or an + -- expanded name. + + ----------------- + -- Prefix_Node -- + ----------------- + + function Prefix_Node (N : Node_Id) return Node_Id is + begin + if Nkind (N) = N_Defining_Program_Unit_Name then + return Name (N); + + else + return Prefix (N); + end if; + end Prefix_Node; + + ----------------- + -- Select_Node -- + ----------------- + + function Select_Node (N : Node_Id) return Node_Id is + begin + if Nkind (N) = N_Defining_Program_Unit_Name then + return Defining_Identifier (N); + + else + return Selector_Name (N); + end if; + end Select_Node; + + -- Start of processing for Designate_Next_Unit + + begin + if (K1 = N_Identifier or else + K1 = N_Defining_Identifier) + and then + (K2 = N_Identifier or else + K2 = N_Defining_Identifier) + then + return Chars (Name1) = Chars (Name2); + + elsif + (K1 = N_Expanded_Name or else + K1 = N_Selected_Component or else + K1 = N_Defining_Program_Unit_Name) + and then + (K2 = N_Expanded_Name or else + K2 = N_Selected_Component or else + K2 = N_Defining_Program_Unit_Name) + then + return + (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2))) + and then + Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2)); + + else + return False; + end if; + end Designate_Same_Unit; + + -------------------------- + -- Enclosing_CPP_Parent -- + -------------------------- + + function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is + Parent_Typ : Entity_Id := Typ; + + begin + while not Is_CPP_Class (Parent_Typ) + and then Etype (Parent_Typ) /= Parent_Typ + loop + Parent_Typ := Etype (Parent_Typ); + + if Is_Private_Type (Parent_Typ) then + Parent_Typ := Full_View (Base_Type (Parent_Typ)); + end if; + end loop; + + pragma Assert (Is_CPP_Class (Parent_Typ)); + return Parent_Typ; + end Enclosing_CPP_Parent; + + ---------------------------- + -- Enclosing_Generic_Body -- + ---------------------------- + + function Enclosing_Generic_Body + (N : Node_Id) return Node_Id + is + P : Node_Id; + Decl : Node_Id; + Spec : Node_Id; + + begin + P := Parent (N); + while Present (P) loop + if Nkind (P) = N_Package_Body + or else Nkind (P) = N_Subprogram_Body + then + Spec := Corresponding_Spec (P); + + if Present (Spec) then + Decl := Unit_Declaration_Node (Spec); + + if Nkind (Decl) = N_Generic_Package_Declaration + or else Nkind (Decl) = N_Generic_Subprogram_Declaration + then + return P; + end if; + end if; + end if; + + P := Parent (P); + end loop; + + return Empty; + end Enclosing_Generic_Body; + + ---------------------------- + -- Enclosing_Generic_Unit -- + ---------------------------- + + function Enclosing_Generic_Unit + (N : Node_Id) return Node_Id + is + P : Node_Id; + Decl : Node_Id; + Spec : Node_Id; + + begin + P := Parent (N); + while Present (P) loop + if Nkind (P) = N_Generic_Package_Declaration + or else Nkind (P) = N_Generic_Subprogram_Declaration + then + return P; + + elsif Nkind (P) = N_Package_Body + or else Nkind (P) = N_Subprogram_Body + then + Spec := Corresponding_Spec (P); + + if Present (Spec) then + Decl := Unit_Declaration_Node (Spec); + + if Nkind (Decl) = N_Generic_Package_Declaration + or else Nkind (Decl) = N_Generic_Subprogram_Declaration + then + return Decl; + end if; + end if; + end if; + + P := Parent (P); + end loop; + + return Empty; + end Enclosing_Generic_Unit; + + ------------------------------- + -- Enclosing_Lib_Unit_Entity -- + ------------------------------- + + function Enclosing_Lib_Unit_Entity return Entity_Id is + Unit_Entity : Entity_Id; + + begin + -- Look for enclosing library unit entity by following scope links. + -- Equivalent to, but faster than indexing through the scope stack. + + Unit_Entity := Current_Scope; + while (Present (Scope (Unit_Entity)) + and then Scope (Unit_Entity) /= Standard_Standard) + and not Is_Child_Unit (Unit_Entity) + loop + Unit_Entity := Scope (Unit_Entity); + end loop; + + return Unit_Entity; + end Enclosing_Lib_Unit_Entity; + + ----------------------------- + -- Enclosing_Lib_Unit_Node -- + ----------------------------- + + function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is + Current_Node : Node_Id; + + begin + Current_Node := N; + while Present (Current_Node) + and then Nkind (Current_Node) /= N_Compilation_Unit + loop + Current_Node := Parent (Current_Node); + end loop; + + if Nkind (Current_Node) /= N_Compilation_Unit then + return Empty; + end if; + + return Current_Node; + end Enclosing_Lib_Unit_Node; + + -------------------------- + -- Enclosing_Subprogram -- + -------------------------- + + function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is + Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E); + + begin + if Dynamic_Scope = Standard_Standard then + return Empty; + + elsif Dynamic_Scope = Empty then + return Empty; + + elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then + return Corresponding_Spec (Parent (Parent (Dynamic_Scope))); + + elsif Ekind (Dynamic_Scope) = E_Block + or else Ekind (Dynamic_Scope) = E_Return_Statement + then + return Enclosing_Subprogram (Dynamic_Scope); + + elsif Ekind (Dynamic_Scope) = E_Task_Type then + return Get_Task_Body_Procedure (Dynamic_Scope); + + elsif Ekind (Dynamic_Scope) = E_Limited_Private_Type + and then Present (Full_View (Dynamic_Scope)) + and then Ekind (Full_View (Dynamic_Scope)) = E_Task_Type + then + return Get_Task_Body_Procedure (Full_View (Dynamic_Scope)); + + -- No body is generated if the protected operation is eliminated + + elsif Convention (Dynamic_Scope) = Convention_Protected + and then not Is_Eliminated (Dynamic_Scope) + and then Present (Protected_Body_Subprogram (Dynamic_Scope)) + then + return Protected_Body_Subprogram (Dynamic_Scope); + + else + return Dynamic_Scope; + end if; + end Enclosing_Subprogram; + + ------------------------ + -- Ensure_Freeze_Node -- + ------------------------ + + procedure Ensure_Freeze_Node (E : Entity_Id) is + FN : Node_Id; + + begin + if No (Freeze_Node (E)) then + FN := Make_Freeze_Entity (Sloc (E)); + Set_Has_Delayed_Freeze (E); + Set_Freeze_Node (E, FN); + Set_Access_Types_To_Process (FN, No_Elist); + Set_TSS_Elist (FN, No_Elist); + Set_Entity (FN, E); + end if; + end Ensure_Freeze_Node; + + ---------------- + -- Enter_Name -- + ---------------- + + procedure Enter_Name (Def_Id : Entity_Id) is + C : constant Entity_Id := Current_Entity (Def_Id); + E : constant Entity_Id := Current_Entity_In_Scope (Def_Id); + S : constant Entity_Id := Current_Scope; + + begin + Generate_Definition (Def_Id); + + -- Add new name to current scope declarations. Check for duplicate + -- declaration, which may or may not be a genuine error. + + if Present (E) then + + -- Case of previous entity entered because of a missing declaration + -- or else a bad subtype indication. Best is to use the new entity, + -- and make the previous one invisible. + + if Etype (E) = Any_Type then + Set_Is_Immediately_Visible (E, False); + + -- Case of renaming declaration constructed for package instances. + -- if there is an explicit declaration with the same identifier, + -- the renaming is not immediately visible any longer, but remains + -- visible through selected component notation. + + elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration + and then not Comes_From_Source (E) + then + Set_Is_Immediately_Visible (E, False); + + -- The new entity may be the package renaming, which has the same + -- same name as a generic formal which has been seen already. + + elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration + and then not Comes_From_Source (Def_Id) + then + Set_Is_Immediately_Visible (E, False); + + -- For a fat pointer corresponding to a remote access to subprogram, + -- we use the same identifier as the RAS type, so that the proper + -- name appears in the stub. This type is only retrieved through + -- the RAS type and never by visibility, and is not added to the + -- visibility list (see below). + + elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration + and then Present (Corresponding_Remote_Type (Def_Id)) + then + null; + + -- A controller component for a type extension overrides the + -- inherited component. + + elsif Chars (E) = Name_uController then + null; + + -- Case of an implicit operation or derived literal. The new entity + -- hides the implicit one, which is removed from all visibility, + -- i.e. the entity list of its scope, and homonym chain of its name. + + elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E)) + or else Is_Internal (E) + then + declare + Prev : Entity_Id; + Prev_Vis : Entity_Id; + Decl : constant Node_Id := Parent (E); + + begin + -- If E is an implicit declaration, it cannot be the first + -- entity in the scope. + + Prev := First_Entity (Current_Scope); + while Present (Prev) + and then Next_Entity (Prev) /= E + loop + Next_Entity (Prev); + end loop; + + if No (Prev) then + + -- If E is not on the entity chain of the current scope, + -- it is an implicit declaration in the generic formal + -- part of a generic subprogram. When analyzing the body, + -- the generic formals are visible but not on the entity + -- chain of the subprogram. The new entity will become + -- the visible one in the body. + + pragma Assert + (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration); + null; + + else + Set_Next_Entity (Prev, Next_Entity (E)); + + if No (Next_Entity (Prev)) then + Set_Last_Entity (Current_Scope, Prev); + end if; + + if E = Current_Entity (E) then + Prev_Vis := Empty; + + else + Prev_Vis := Current_Entity (E); + while Homonym (Prev_Vis) /= E loop + Prev_Vis := Homonym (Prev_Vis); + end loop; + end if; + + if Present (Prev_Vis) then + + -- Skip E in the visibility chain + + Set_Homonym (Prev_Vis, Homonym (E)); + + else + Set_Name_Entity_Id (Chars (E), Homonym (E)); + end if; + end if; + end; + + -- This section of code could use a comment ??? + + elsif Present (Etype (E)) + and then Is_Concurrent_Type (Etype (E)) + and then E = Def_Id + then + return; + + -- If the homograph is a protected component renaming, it should not + -- be hiding the current entity. Such renamings are treated as weak + -- declarations. + + elsif Is_Prival (E) then + Set_Is_Immediately_Visible (E, False); + + -- In this case the current entity is a protected component renaming. + -- Perform minimal decoration by setting the scope and return since + -- the prival should not be hiding other visible entities. + + elsif Is_Prival (Def_Id) then + Set_Scope (Def_Id, Current_Scope); + return; + + -- Analogous to privals, the discriminal generated for an entry index + -- parameter acts as a weak declaration. Perform minimal decoration + -- to avoid bogus errors. + + elsif Is_Discriminal (Def_Id) + and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter + then + Set_Scope (Def_Id, Current_Scope); + return; + + -- In the body or private part of an instance, a type extension may + -- introduce a component with the same name as that of an actual. The + -- legality rule is not enforced, but the semantics of the full type + -- with two components of same name are not clear at this point??? + + elsif In_Instance_Not_Visible then + null; + + -- When compiling a package body, some child units may have become + -- visible. They cannot conflict with local entities that hide them. + + elsif Is_Child_Unit (E) + and then In_Open_Scopes (Scope (E)) + and then not Is_Immediately_Visible (E) + then + null; + + -- Conversely, with front-end inlining we may compile the parent body + -- first, and a child unit subsequently. The context is now the + -- parent spec, and body entities are not visible. + + elsif Is_Child_Unit (Def_Id) + and then Is_Package_Body_Entity (E) + and then not In_Package_Body (Current_Scope) + then + null; + + -- Case of genuine duplicate declaration + + else + Error_Msg_Sloc := Sloc (E); + + -- If the previous declaration is an incomplete type declaration + -- this may be an attempt to complete it with a private type. The + -- following avoids confusing cascaded errors. + + if Nkind (Parent (E)) = N_Incomplete_Type_Declaration + and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration + then + Error_Msg_N + ("incomplete type cannot be completed with a private " & + "declaration", Parent (Def_Id)); + Set_Is_Immediately_Visible (E, False); + Set_Full_View (E, Def_Id); + + -- An inherited component of a record conflicts with a new + -- discriminant. The discriminant is inserted first in the scope, + -- but the error should be posted on it, not on the component. + + elsif Ekind (E) = E_Discriminant + and then Present (Scope (Def_Id)) + and then Scope (Def_Id) /= Current_Scope + then + Error_Msg_Sloc := Sloc (Def_Id); + Error_Msg_N ("& conflicts with declaration#", E); + return; + + -- If the name of the unit appears in its own context clause, a + -- dummy package with the name has already been created, and the + -- error emitted. Try to continue quietly. + + elsif Error_Posted (E) + and then Sloc (E) = No_Location + and then Nkind (Parent (E)) = N_Package_Specification + and then Current_Scope = Standard_Standard + then + Set_Scope (Def_Id, Current_Scope); + return; + + else + Error_Msg_N ("& conflicts with declaration#", Def_Id); + + -- Avoid cascaded messages with duplicate components in + -- derived types. + + if Ekind_In (E, E_Component, E_Discriminant) then + return; + end if; + end if; + + if Nkind (Parent (Parent (Def_Id))) = + N_Generic_Subprogram_Declaration + and then Def_Id = + Defining_Entity (Specification (Parent (Parent (Def_Id)))) + then + Error_Msg_N ("\generic units cannot be overloaded", Def_Id); + end if; + + -- If entity is in standard, then we are in trouble, because it + -- means that we have a library package with a duplicated name. + -- That's hard to recover from, so abort! + + if S = Standard_Standard then + raise Unrecoverable_Error; + + -- Otherwise we continue with the declaration. Having two + -- identical declarations should not cause us too much trouble! + + else + null; + end if; + end if; + end if; + + -- If we fall through, declaration is OK, at least OK enough to continue + + -- If Def_Id is a discriminant or a record component we are in the midst + -- of inheriting components in a derived record definition. Preserve + -- their Ekind and Etype. + + if Ekind_In (Def_Id, E_Discriminant, E_Component) then + null; + + -- If a type is already set, leave it alone (happens when a type + -- declaration is reanalyzed following a call to the optimizer). + + elsif Present (Etype (Def_Id)) then + null; + + -- Otherwise, the kind E_Void insures that premature uses of the entity + -- will be detected. Any_Type insures that no cascaded errors will occur + + else + Set_Ekind (Def_Id, E_Void); + Set_Etype (Def_Id, Any_Type); + end if; + + -- Inherited discriminants and components in derived record types are + -- immediately visible. Itypes are not. + + if Ekind_In (Def_Id, E_Discriminant, E_Component) + or else (No (Corresponding_Remote_Type (Def_Id)) + and then not Is_Itype (Def_Id)) + then + Set_Is_Immediately_Visible (Def_Id); + Set_Current_Entity (Def_Id); + end if; + + Set_Homonym (Def_Id, C); + Append_Entity (Def_Id, S); + Set_Public_Status (Def_Id); + + -- Warn if new entity hides an old one + + if Warn_On_Hiding and then Present (C) + + -- Don't warn for record components since they always have a well + -- defined scope which does not confuse other uses. Note that in + -- some cases, Ekind has not been set yet. + + and then Ekind (C) /= E_Component + and then Ekind (C) /= E_Discriminant + and then Nkind (Parent (C)) /= N_Component_Declaration + and then Ekind (Def_Id) /= E_Component + and then Ekind (Def_Id) /= E_Discriminant + and then Nkind (Parent (Def_Id)) /= N_Component_Declaration + + -- Don't warn for one character variables. It is too common to use + -- such variables as locals and will just cause too many false hits. + + and then Length_Of_Name (Chars (C)) /= 1 + + -- Don't warn for non-source entities + + and then Comes_From_Source (C) + and then Comes_From_Source (Def_Id) + + -- Don't warn unless entity in question is in extended main source + + and then In_Extended_Main_Source_Unit (Def_Id) + + -- Finally, the hidden entity must be either immediately visible or + -- use visible (i.e. from a used package). + + and then + (Is_Immediately_Visible (C) + or else + Is_Potentially_Use_Visible (C)) + then + Error_Msg_Sloc := Sloc (C); + Error_Msg_N ("declaration hides &#?", Def_Id); + end if; + end Enter_Name; + + -------------------------- + -- Explain_Limited_Type -- + -------------------------- + + procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is + C : Entity_Id; + + begin + -- For array, component type must be limited + + if Is_Array_Type (T) then + Error_Msg_Node_2 := T; + Error_Msg_NE + ("\component type& of type& is limited", N, Component_Type (T)); + Explain_Limited_Type (Component_Type (T), N); + + elsif Is_Record_Type (T) then + + -- No need for extra messages if explicit limited record + + if Is_Limited_Record (Base_Type (T)) then + return; + end if; + + -- Otherwise find a limited component. Check only components that + -- come from source, or inherited components that appear in the + -- source of the ancestor. + + C := First_Component (T); + while Present (C) loop + if Is_Limited_Type (Etype (C)) + and then + (Comes_From_Source (C) + or else + (Present (Original_Record_Component (C)) + and then + Comes_From_Source (Original_Record_Component (C)))) + then + Error_Msg_Node_2 := T; + Error_Msg_NE ("\component& of type& has limited type", N, C); + Explain_Limited_Type (Etype (C), N); + return; + end if; + + Next_Component (C); + end loop; + + -- The type may be declared explicitly limited, even if no component + -- of it is limited, in which case we fall out of the loop. + return; + end if; + end Explain_Limited_Type; + + ----------------- + -- Find_Actual -- + ----------------- + + procedure Find_Actual + (N : Node_Id; + Formal : out Entity_Id; + Call : out Node_Id) + is + Parnt : constant Node_Id := Parent (N); + Actual : Node_Id; + + begin + if (Nkind (Parnt) = N_Indexed_Component + or else + Nkind (Parnt) = N_Selected_Component) + and then N = Prefix (Parnt) + then + Find_Actual (Parnt, Formal, Call); + return; + + elsif Nkind (Parnt) = N_Parameter_Association + and then N = Explicit_Actual_Parameter (Parnt) + then + Call := Parent (Parnt); + + elsif Nkind (Parnt) = N_Procedure_Call_Statement then + Call := Parnt; + + else + Formal := Empty; + Call := Empty; + return; + end if; + + -- If we have a call to a subprogram look for the parameter. Note that + -- we exclude overloaded calls, since we don't know enough to be sure + -- of giving the right answer in this case. + + if Is_Entity_Name (Name (Call)) + and then Present (Entity (Name (Call))) + and then Is_Overloadable (Entity (Name (Call))) + and then not Is_Overloaded (Name (Call)) + then + -- Fall here if we are definitely a parameter + + Actual := First_Actual (Call); + Formal := First_Formal (Entity (Name (Call))); + while Present (Formal) and then Present (Actual) loop + if Actual = N then + return; + else + Actual := Next_Actual (Actual); + Formal := Next_Formal (Formal); + end if; + end loop; + end if; + + -- Fall through here if we did not find matching actual + + Formal := Empty; + Call := Empty; + end Find_Actual; + + --------------------------- + -- Find_Body_Discriminal -- + --------------------------- + + function Find_Body_Discriminal + (Spec_Discriminant : Entity_Id) return Entity_Id + is + pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant))); + + Tsk : constant Entity_Id := + Corresponding_Concurrent_Type (Scope (Spec_Discriminant)); + Disc : Entity_Id; + + begin + -- Find discriminant of original concurrent type, and use its current + -- discriminal, which is the renaming within the task/protected body. + + Disc := First_Discriminant (Tsk); + while Present (Disc) loop + if Chars (Disc) = Chars (Spec_Discriminant) then + return Discriminal (Disc); + end if; + + Next_Discriminant (Disc); + end loop; + + -- That loop should always succeed in finding a matching entry and + -- returning. Fatal error if not. + + raise Program_Error; + end Find_Body_Discriminal; + + ------------------------------------- + -- Find_Corresponding_Discriminant -- + ------------------------------------- + + function Find_Corresponding_Discriminant + (Id : Node_Id; + Typ : Entity_Id) return Entity_Id + is + Par_Disc : Entity_Id; + Old_Disc : Entity_Id; + New_Disc : Entity_Id; + + begin + Par_Disc := Original_Record_Component (Original_Discriminant (Id)); + + -- The original type may currently be private, and the discriminant + -- only appear on its full view. + + if Is_Private_Type (Scope (Par_Disc)) + and then not Has_Discriminants (Scope (Par_Disc)) + and then Present (Full_View (Scope (Par_Disc))) + then + Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc))); + else + Old_Disc := First_Discriminant (Scope (Par_Disc)); + end if; + + if Is_Class_Wide_Type (Typ) then + New_Disc := First_Discriminant (Root_Type (Typ)); + else + New_Disc := First_Discriminant (Typ); + end if; + + while Present (Old_Disc) and then Present (New_Disc) loop + if Old_Disc = Par_Disc then + return New_Disc; + else + Next_Discriminant (Old_Disc); + Next_Discriminant (New_Disc); + end if; + end loop; + + -- Should always find it + + raise Program_Error; + end Find_Corresponding_Discriminant; + + -------------------------- + -- Find_Overlaid_Entity -- + -------------------------- + + procedure Find_Overlaid_Entity + (N : Node_Id; + Ent : out Entity_Id; + Off : out Boolean) + is + Expr : Node_Id; + + begin + -- We are looking for one of the two following forms: + + -- for X'Address use Y'Address + + -- or + + -- Const : constant Address := expr; + -- ... + -- for X'Address use Const; + + -- In the second case, the expr is either Y'Address, or recursively a + -- constant that eventually references Y'Address. + + Ent := Empty; + Off := False; + + if Nkind (N) = N_Attribute_Definition_Clause + and then Chars (N) = Name_Address + then + Expr := Expression (N); + + -- This loop checks the form of the expression for Y'Address, + -- using recursion to deal with intermediate constants. + + loop + -- Check for Y'Address + + if Nkind (Expr) = N_Attribute_Reference + and then Attribute_Name (Expr) = Name_Address + then + Expr := Prefix (Expr); + exit; + + -- Check for Const where Const is a constant entity + + elsif Is_Entity_Name (Expr) + and then Ekind (Entity (Expr)) = E_Constant + then + Expr := Constant_Value (Entity (Expr)); + + -- Anything else does not need checking + + else + return; + end if; + end loop; + + -- This loop checks the form of the prefix for an entity, + -- using recursion to deal with intermediate components. + + loop + -- Check for Y where Y is an entity + + if Is_Entity_Name (Expr) then + Ent := Entity (Expr); + return; + + -- Check for components + + elsif + Nkind_In (Expr, N_Selected_Component, N_Indexed_Component) then + + Expr := Prefix (Expr); + Off := True; + + -- Anything else does not need checking + + else + return; + end if; + end loop; + end if; + end Find_Overlaid_Entity; + + ------------------------- + -- Find_Parameter_Type -- + ------------------------- + + function Find_Parameter_Type (Param : Node_Id) return Entity_Id is + begin + if Nkind (Param) /= N_Parameter_Specification then + return Empty; + + -- For an access parameter, obtain the type from the formal entity + -- itself, because access to subprogram nodes do not carry a type. + -- Shouldn't we always use the formal entity ??? + + elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then + return Etype (Defining_Identifier (Param)); + + else + return Etype (Parameter_Type (Param)); + end if; + end Find_Parameter_Type; + + ----------------------------- + -- Find_Static_Alternative -- + ----------------------------- + + function Find_Static_Alternative (N : Node_Id) return Node_Id is + Expr : constant Node_Id := Expression (N); + Val : constant Uint := Expr_Value (Expr); + Alt : Node_Id; + Choice : Node_Id; + + begin + Alt := First (Alternatives (N)); + + Search : loop + if Nkind (Alt) /= N_Pragma then + Choice := First (Discrete_Choices (Alt)); + while Present (Choice) loop + + -- Others choice, always matches + + if Nkind (Choice) = N_Others_Choice then + exit Search; + + -- Range, check if value is in the range + + elsif Nkind (Choice) = N_Range then + exit Search when + Val >= Expr_Value (Low_Bound (Choice)) + and then + Val <= Expr_Value (High_Bound (Choice)); + + -- Choice is a subtype name. Note that we know it must + -- be a static subtype, since otherwise it would have + -- been diagnosed as illegal. + + elsif Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + then + exit Search when Is_In_Range (Expr, Etype (Choice), + Assume_Valid => False); + + -- Choice is a subtype indication + + elsif Nkind (Choice) = N_Subtype_Indication then + declare + C : constant Node_Id := Constraint (Choice); + R : constant Node_Id := Range_Expression (C); + + begin + exit Search when + Val >= Expr_Value (Low_Bound (R)) + and then + Val <= Expr_Value (High_Bound (R)); + end; + + -- Choice is a simple expression + + else + exit Search when Val = Expr_Value (Choice); + end if; + + Next (Choice); + end loop; + end if; + + Next (Alt); + pragma Assert (Present (Alt)); + end loop Search; + + -- The above loop *must* terminate by finding a match, since + -- we know the case statement is valid, and the value of the + -- expression is known at compile time. When we fall out of + -- the loop, Alt points to the alternative that we know will + -- be selected at run time. + + return Alt; + end Find_Static_Alternative; + + ------------------ + -- First_Actual -- + ------------------ + + function First_Actual (Node : Node_Id) return Node_Id is + N : Node_Id; + + begin + if No (Parameter_Associations (Node)) then + return Empty; + end if; + + N := First (Parameter_Associations (Node)); + + if Nkind (N) = N_Parameter_Association then + return First_Named_Actual (Node); + else + return N; + end if; + end First_Actual; + + ----------------------- + -- Gather_Components -- + ----------------------- + + procedure Gather_Components + (Typ : Entity_Id; + Comp_List : Node_Id; + Governed_By : List_Id; + Into : Elist_Id; + Report_Errors : out Boolean) + is + Assoc : Node_Id; + Variant : Node_Id; + Discrete_Choice : Node_Id; + Comp_Item : Node_Id; + + Discrim : Entity_Id; + Discrim_Name : Node_Id; + Discrim_Value : Node_Id; + + begin + Report_Errors := False; + + if No (Comp_List) or else Null_Present (Comp_List) then + return; + + elsif Present (Component_Items (Comp_List)) then + Comp_Item := First (Component_Items (Comp_List)); + + else + Comp_Item := Empty; + end if; + + while Present (Comp_Item) loop + + -- Skip the tag of a tagged record, the interface tags, as well + -- as all items that are not user components (anonymous types, + -- rep clauses, Parent field, controller field). + + if Nkind (Comp_Item) = N_Component_Declaration then + declare + Comp : constant Entity_Id := Defining_Identifier (Comp_Item); + begin + if not Is_Tag (Comp) + and then Chars (Comp) /= Name_uParent + and then Chars (Comp) /= Name_uController + then + Append_Elmt (Comp, Into); + end if; + end; + end if; + + Next (Comp_Item); + end loop; + + if No (Variant_Part (Comp_List)) then + return; + else + Discrim_Name := Name (Variant_Part (Comp_List)); + Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); + end if; + + -- Look for the discriminant that governs this variant part. + -- The discriminant *must* be in the Governed_By List + + Assoc := First (Governed_By); + Find_Constraint : loop + Discrim := First (Choices (Assoc)); + exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim) + or else (Present (Corresponding_Discriminant (Entity (Discrim))) + and then + Chars (Corresponding_Discriminant (Entity (Discrim))) + = Chars (Discrim_Name)) + or else Chars (Original_Record_Component (Entity (Discrim))) + = Chars (Discrim_Name); + + if No (Next (Assoc)) then + if not Is_Constrained (Typ) + and then Is_Derived_Type (Typ) + and then Present (Stored_Constraint (Typ)) + then + -- If the type is a tagged type with inherited discriminants, + -- use the stored constraint on the parent in order to find + -- the values of discriminants that are otherwise hidden by an + -- explicit constraint. Renamed discriminants are handled in + -- the code above. + + -- If several parent discriminants are renamed by a single + -- discriminant of the derived type, the call to obtain the + -- Corresponding_Discriminant field only retrieves the last + -- of them. We recover the constraint on the others from the + -- Stored_Constraint as well. + + declare + D : Entity_Id; + C : Elmt_Id; + + begin + D := First_Discriminant (Etype (Typ)); + C := First_Elmt (Stored_Constraint (Typ)); + while Present (D) and then Present (C) loop + if Chars (Discrim_Name) = Chars (D) then + if Is_Entity_Name (Node (C)) + and then Entity (Node (C)) = Entity (Discrim) + then + -- D is renamed by Discrim, whose value is given in + -- Assoc. + + null; + + else + Assoc := + Make_Component_Association (Sloc (Typ), + New_List + (New_Occurrence_Of (D, Sloc (Typ))), + Duplicate_Subexpr_No_Checks (Node (C))); + end if; + exit Find_Constraint; + end if; + + Next_Discriminant (D); + Next_Elmt (C); + end loop; + end; + end if; + end if; + + if No (Next (Assoc)) then + Error_Msg_NE (" missing value for discriminant&", + First (Governed_By), Discrim_Name); + Report_Errors := True; + return; + end if; + + Next (Assoc); + end loop Find_Constraint; + + Discrim_Value := Expression (Assoc); + + if not Is_OK_Static_Expression (Discrim_Value) then + Error_Msg_FE + ("value for discriminant & must be static!", + Discrim_Value, Discrim); + Why_Not_Static (Discrim_Value); + Report_Errors := True; + return; + end if; + + Search_For_Discriminant_Value : declare + Low : Node_Id; + High : Node_Id; + + UI_High : Uint; + UI_Low : Uint; + UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value); + + begin + Find_Discrete_Value : while Present (Variant) loop + Discrete_Choice := First (Discrete_Choices (Variant)); + while Present (Discrete_Choice) loop + + exit Find_Discrete_Value when + Nkind (Discrete_Choice) = N_Others_Choice; + + Get_Index_Bounds (Discrete_Choice, Low, High); + + UI_Low := Expr_Value (Low); + UI_High := Expr_Value (High); + + exit Find_Discrete_Value when + UI_Low <= UI_Discrim_Value + and then + UI_High >= UI_Discrim_Value; + + Next (Discrete_Choice); + end loop; + + Next_Non_Pragma (Variant); + end loop Find_Discrete_Value; + end Search_For_Discriminant_Value; + + if No (Variant) then + Error_Msg_NE + ("value of discriminant & is out of range", Discrim_Value, Discrim); + Report_Errors := True; + return; + end if; + + -- If we have found the corresponding choice, recursively add its + -- components to the Into list. + + Gather_Components (Empty, + Component_List (Variant), Governed_By, Into, Report_Errors); + end Gather_Components; + + ------------------------ + -- Get_Actual_Subtype -- + ------------------------ + + function Get_Actual_Subtype (N : Node_Id) return Entity_Id is + Typ : constant Entity_Id := Etype (N); + Utyp : Entity_Id := Underlying_Type (Typ); + Decl : Node_Id; + Atyp : Entity_Id; + + begin + if No (Utyp) then + Utyp := Typ; + end if; + + -- If what we have is an identifier that references a subprogram + -- formal, or a variable or constant object, then we get the actual + -- subtype from the referenced entity if one has been built. + + if Nkind (N) = N_Identifier + and then + (Is_Formal (Entity (N)) + or else Ekind (Entity (N)) = E_Constant + or else Ekind (Entity (N)) = E_Variable) + and then Present (Actual_Subtype (Entity (N))) + then + return Actual_Subtype (Entity (N)); + + -- Actual subtype of unchecked union is always itself. We never need + -- the "real" actual subtype. If we did, we couldn't get it anyway + -- because the discriminant is not available. The restrictions on + -- Unchecked_Union are designed to make sure that this is OK. + + elsif Is_Unchecked_Union (Base_Type (Utyp)) then + return Typ; + + -- Here for the unconstrained case, we must find actual subtype + -- No actual subtype is available, so we must build it on the fly. + + -- Checking the type, not the underlying type, for constrainedness + -- seems to be necessary. Maybe all the tests should be on the type??? + + elsif (not Is_Constrained (Typ)) + and then (Is_Array_Type (Utyp) + or else (Is_Record_Type (Utyp) + and then Has_Discriminants (Utyp))) + and then not Has_Unknown_Discriminants (Utyp) + and then not (Ekind (Utyp) = E_String_Literal_Subtype) + then + -- Nothing to do if in spec expression (why not???) + + if In_Spec_Expression then + return Typ; + + elsif Is_Private_Type (Typ) + and then not Has_Discriminants (Typ) + then + -- If the type has no discriminants, there is no subtype to + -- build, even if the underlying type is discriminated. + + return Typ; + + -- Else build the actual subtype + + else + Decl := Build_Actual_Subtype (Typ, N); + Atyp := Defining_Identifier (Decl); + + -- If Build_Actual_Subtype generated a new declaration then use it + + if Atyp /= Typ then + + -- The actual subtype is an Itype, so analyze the declaration, + -- but do not attach it to the tree, to get the type defined. + + Set_Parent (Decl, N); + Set_Is_Itype (Atyp); + Analyze (Decl, Suppress => All_Checks); + Set_Associated_Node_For_Itype (Atyp, N); + Set_Has_Delayed_Freeze (Atyp, False); + + -- We need to freeze the actual subtype immediately. This is + -- needed, because otherwise this Itype will not get frozen + -- at all, and it is always safe to freeze on creation because + -- any associated types must be frozen at this point. + + Freeze_Itype (Atyp, N); + return Atyp; + + -- Otherwise we did not build a declaration, so return original + + else + return Typ; + end if; + end if; + + -- For all remaining cases, the actual subtype is the same as + -- the nominal type. + + else + return Typ; + end if; + end Get_Actual_Subtype; + + ------------------------------------- + -- Get_Actual_Subtype_If_Available -- + ------------------------------------- + + function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is + Typ : constant Entity_Id := Etype (N); + + begin + -- If what we have is an identifier that references a subprogram + -- formal, or a variable or constant object, then we get the actual + -- subtype from the referenced entity if one has been built. + + if Nkind (N) = N_Identifier + and then + (Is_Formal (Entity (N)) + or else Ekind (Entity (N)) = E_Constant + or else Ekind (Entity (N)) = E_Variable) + and then Present (Actual_Subtype (Entity (N))) + then + return Actual_Subtype (Entity (N)); + + -- Otherwise the Etype of N is returned unchanged + + else + return Typ; + end if; + end Get_Actual_Subtype_If_Available; + + ------------------------------- + -- Get_Default_External_Name -- + ------------------------------- + + function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is + begin + Get_Decoded_Name_String (Chars (E)); + + if Opt.External_Name_Imp_Casing = Uppercase then + Set_Casing (All_Upper_Case); + else + Set_Casing (All_Lower_Case); + end if; + + return + Make_String_Literal (Sloc (E), + Strval => String_From_Name_Buffer); + end Get_Default_External_Name; + + --------------------------- + -- Get_Enum_Lit_From_Pos -- + --------------------------- + + function Get_Enum_Lit_From_Pos + (T : Entity_Id; + Pos : Uint; + Loc : Source_Ptr) return Node_Id + is + Lit : Node_Id; + + begin + -- In the case where the literal is of type Character, Wide_Character + -- or Wide_Wide_Character or of a type derived from them, there needs + -- to be some special handling since there is no explicit chain of + -- literals to search. Instead, an N_Character_Literal node is created + -- with the appropriate Char_Code and Chars fields. + + if Is_Standard_Character_Type (T) then + Set_Character_Literal_Name (UI_To_CC (Pos)); + return + Make_Character_Literal (Loc, + Chars => Name_Find, + Char_Literal_Value => Pos); + + -- For all other cases, we have a complete table of literals, and + -- we simply iterate through the chain of literal until the one + -- with the desired position value is found. + -- + + else + Lit := First_Literal (Base_Type (T)); + for J in 1 .. UI_To_Int (Pos) loop + Next_Literal (Lit); + end loop; + + return New_Occurrence_Of (Lit, Loc); + end if; + end Get_Enum_Lit_From_Pos; + + ------------------------ + -- Get_Generic_Entity -- + ------------------------ + + function Get_Generic_Entity (N : Node_Id) return Entity_Id is + Ent : constant Entity_Id := Entity (Name (N)); + begin + if Present (Renamed_Object (Ent)) then + return Renamed_Object (Ent); + else + return Ent; + end if; + end Get_Generic_Entity; + + ---------------------- + -- Get_Index_Bounds -- + ---------------------- + + procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is + Kind : constant Node_Kind := Nkind (N); + R : Node_Id; + + begin + if Kind = N_Range then + L := Low_Bound (N); + H := High_Bound (N); + + elsif Kind = N_Subtype_Indication then + R := Range_Expression (Constraint (N)); + + if R = Error then + L := Error; + H := Error; + return; + + else + L := Low_Bound (Range_Expression (Constraint (N))); + H := High_Bound (Range_Expression (Constraint (N))); + end if; + + elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then + if Error_Posted (Scalar_Range (Entity (N))) then + L := Error; + H := Error; + + elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then + Get_Index_Bounds (Scalar_Range (Entity (N)), L, H); + + else + L := Low_Bound (Scalar_Range (Entity (N))); + H := High_Bound (Scalar_Range (Entity (N))); + end if; + + else + -- N is an expression, indicating a range with one value + + L := N; + H := N; + end if; + end Get_Index_Bounds; + + ---------------------------------- + -- Get_Library_Unit_Name_string -- + ---------------------------------- + + procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is + Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node); + + begin + Get_Unit_Name_String (Unit_Name_Id); + + -- Remove seven last character (" (spec)" or " (body)") + + Name_Len := Name_Len - 7; + pragma Assert (Name_Buffer (Name_Len + 1) = ' '); + end Get_Library_Unit_Name_String; + + ------------------------ + -- Get_Name_Entity_Id -- + ------------------------ + + function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is + begin + return Entity_Id (Get_Name_Table_Info (Id)); + end Get_Name_Entity_Id; + + ------------------- + -- Get_Pragma_Id -- + ------------------- + + function Get_Pragma_Id (N : Node_Id) return Pragma_Id is + begin + return Get_Pragma_Id (Pragma_Name (N)); + end Get_Pragma_Id; + + --------------------------- + -- Get_Referenced_Object -- + --------------------------- + + function Get_Referenced_Object (N : Node_Id) return Node_Id is + R : Node_Id; + + begin + R := N; + while Is_Entity_Name (R) + and then Present (Renamed_Object (Entity (R))) + loop + R := Renamed_Object (Entity (R)); + end loop; + + return R; + end Get_Referenced_Object; + + ------------------------ + -- Get_Renamed_Entity -- + ------------------------ + + function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is + R : Entity_Id; + + begin + R := E; + while Present (Renamed_Entity (R)) loop + R := Renamed_Entity (R); + end loop; + + return R; + end Get_Renamed_Entity; + + ------------------------- + -- Get_Subprogram_Body -- + ------------------------- + + function Get_Subprogram_Body (E : Entity_Id) return Node_Id is + Decl : Node_Id; + + begin + Decl := Unit_Declaration_Node (E); + + if Nkind (Decl) = N_Subprogram_Body then + return Decl; + + -- The below comment is bad, because it is possible for + -- Nkind (Decl) to be an N_Subprogram_Body_Stub ??? + + else -- Nkind (Decl) = N_Subprogram_Declaration + + if Present (Corresponding_Body (Decl)) then + return Unit_Declaration_Node (Corresponding_Body (Decl)); + + -- Imported subprogram case + + else + return Empty; + end if; + end if; + end Get_Subprogram_Body; + + --------------------------- + -- Get_Subprogram_Entity -- + --------------------------- + + function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is + Nam : Node_Id; + Proc : Entity_Id; + + begin + if Nkind (Nod) = N_Accept_Statement then + Nam := Entry_Direct_Name (Nod); + + -- For an entry call, the prefix of the call is a selected component. + -- Need additional code for internal calls ??? + + elsif Nkind (Nod) = N_Entry_Call_Statement then + if Nkind (Name (Nod)) = N_Selected_Component then + Nam := Entity (Selector_Name (Name (Nod))); + else + Nam := Empty; + end if; + + else + Nam := Name (Nod); + end if; + + if Nkind (Nam) = N_Explicit_Dereference then + Proc := Etype (Prefix (Nam)); + elsif Is_Entity_Name (Nam) then + Proc := Entity (Nam); + else + return Empty; + end if; + + if Is_Object (Proc) then + Proc := Etype (Proc); + end if; + + if Ekind (Proc) = E_Access_Subprogram_Type then + Proc := Directly_Designated_Type (Proc); + end if; + + if not Is_Subprogram (Proc) + and then Ekind (Proc) /= E_Subprogram_Type + then + return Empty; + else + return Proc; + end if; + end Get_Subprogram_Entity; + + ----------------------------- + -- Get_Task_Body_Procedure -- + ----------------------------- + + function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is + begin + -- Note: A task type may be the completion of a private type with + -- discriminants. When performing elaboration checks on a task + -- declaration, the current view of the type may be the private one, + -- and the procedure that holds the body of the task is held in its + -- underlying type. + + -- This is an odd function, why not have Task_Body_Procedure do + -- the following digging??? + + return Task_Body_Procedure (Underlying_Type (Root_Type (E))); + end Get_Task_Body_Procedure; + + ----------------------- + -- Has_Access_Values -- + ----------------------- + + function Has_Access_Values (T : Entity_Id) return Boolean is + Typ : constant Entity_Id := Underlying_Type (T); + + begin + -- Case of a private type which is not completed yet. This can only + -- happen in the case of a generic format type appearing directly, or + -- as a component of the type to which this function is being applied + -- at the top level. Return False in this case, since we certainly do + -- not know that the type contains access types. + + if No (Typ) then + return False; + + elsif Is_Access_Type (Typ) then + return True; + + elsif Is_Array_Type (Typ) then + return Has_Access_Values (Component_Type (Typ)); + + elsif Is_Record_Type (Typ) then + declare + Comp : Entity_Id; + + begin + -- Loop to Check components + + Comp := First_Component_Or_Discriminant (Typ); + while Present (Comp) loop + + -- Check for access component, tag field does not count, even + -- though it is implemented internally using an access type. + + if Has_Access_Values (Etype (Comp)) + and then Chars (Comp) /= Name_uTag + then + return True; + end if; + + Next_Component_Or_Discriminant (Comp); + end loop; + end; + + return False; + + else + return False; + end if; + end Has_Access_Values; + + ------------------------------ + -- Has_Compatible_Alignment -- + ------------------------------ + + function Has_Compatible_Alignment + (Obj : Entity_Id; + Expr : Node_Id) return Alignment_Result + is + function Has_Compatible_Alignment_Internal + (Obj : Entity_Id; + Expr : Node_Id; + Default : Alignment_Result) return Alignment_Result; + -- This is the internal recursive function that actually does the work. + -- There is one additional parameter, which says what the result should + -- be if no alignment information is found, and there is no definite + -- indication of compatible alignments. At the outer level, this is set + -- to Unknown, but for internal recursive calls in the case where types + -- are known to be correct, it is set to Known_Compatible. + + --------------------------------------- + -- Has_Compatible_Alignment_Internal -- + --------------------------------------- + + function Has_Compatible_Alignment_Internal + (Obj : Entity_Id; + Expr : Node_Id; + Default : Alignment_Result) return Alignment_Result + is + Result : Alignment_Result := Known_Compatible; + -- Holds the current status of the result. Note that once a value of + -- Known_Incompatible is set, it is sticky and does not get changed + -- to Unknown (the value in Result only gets worse as we go along, + -- never better). + + Offs : Uint := No_Uint; + -- Set to a factor of the offset from the base object when Expr is a + -- selected or indexed component, based on Component_Bit_Offset and + -- Component_Size respectively. A negative value is used to represent + -- a value which is not known at compile time. + + procedure Check_Prefix; + -- Checks the prefix recursively in the case where the expression + -- is an indexed or selected component. + + procedure Set_Result (R : Alignment_Result); + -- If R represents a worse outcome (unknown instead of known + -- compatible, or known incompatible), then set Result to R. + + ------------------ + -- Check_Prefix -- + ------------------ + + procedure Check_Prefix is + begin + -- The subtlety here is that in doing a recursive call to check + -- the prefix, we have to decide what to do in the case where we + -- don't find any specific indication of an alignment problem. + + -- At the outer level, we normally set Unknown as the result in + -- this case, since we can only set Known_Compatible if we really + -- know that the alignment value is OK, but for the recursive + -- call, in the case where the types match, and we have not + -- specified a peculiar alignment for the object, we are only + -- concerned about suspicious rep clauses, the default case does + -- not affect us, since the compiler will, in the absence of such + -- rep clauses, ensure that the alignment is correct. + + if Default = Known_Compatible + or else + (Etype (Obj) = Etype (Expr) + and then (Unknown_Alignment (Obj) + or else + Alignment (Obj) = Alignment (Etype (Obj)))) + then + Set_Result + (Has_Compatible_Alignment_Internal + (Obj, Prefix (Expr), Known_Compatible)); + + -- In all other cases, we need a full check on the prefix + + else + Set_Result + (Has_Compatible_Alignment_Internal + (Obj, Prefix (Expr), Unknown)); + end if; + end Check_Prefix; + + ---------------- + -- Set_Result -- + ---------------- + + procedure Set_Result (R : Alignment_Result) is + begin + if R > Result then + Result := R; + end if; + end Set_Result; + + -- Start of processing for Has_Compatible_Alignment_Internal + + begin + -- If Expr is a selected component, we must make sure there is no + -- potentially troublesome component clause, and that the record is + -- not packed. + + if Nkind (Expr) = N_Selected_Component then + + -- Packed record always generate unknown alignment + + if Is_Packed (Etype (Prefix (Expr))) then + Set_Result (Unknown); + end if; + + -- Check prefix and component offset + + Check_Prefix; + Offs := Component_Bit_Offset (Entity (Selector_Name (Expr))); + + -- If Expr is an indexed component, we must make sure there is no + -- potentially troublesome Component_Size clause and that the array + -- is not bit-packed. + + elsif Nkind (Expr) = N_Indexed_Component then + declare + Typ : constant Entity_Id := Etype (Prefix (Expr)); + Ind : constant Node_Id := First_Index (Typ); + + begin + -- Bit packed array always generates unknown alignment + + if Is_Bit_Packed_Array (Typ) then + Set_Result (Unknown); + end if; + + -- Check prefix and component offset + + Check_Prefix; + Offs := Component_Size (Typ); + + -- Small optimization: compute the full offset when possible + + if Offs /= No_Uint + and then Offs > Uint_0 + and then Present (Ind) + and then Nkind (Ind) = N_Range + and then Compile_Time_Known_Value (Low_Bound (Ind)) + and then Compile_Time_Known_Value (First (Expressions (Expr))) + then + Offs := Offs * (Expr_Value (First (Expressions (Expr))) + - Expr_Value (Low_Bound ((Ind)))); + end if; + end; + end if; + + -- If we have a null offset, the result is entirely determined by + -- the base object and has already been computed recursively. + + if Offs = Uint_0 then + null; + + -- Case where we know the alignment of the object + + elsif Known_Alignment (Obj) then + declare + ObjA : constant Uint := Alignment (Obj); + ExpA : Uint := No_Uint; + SizA : Uint := No_Uint; + + begin + -- If alignment of Obj is 1, then we are always OK + + if ObjA = 1 then + Set_Result (Known_Compatible); + + -- Alignment of Obj is greater than 1, so we need to check + + else + -- If we have an offset, see if it is compatible + + if Offs /= No_Uint and Offs > Uint_0 then + if Offs mod (System_Storage_Unit * ObjA) /= 0 then + Set_Result (Known_Incompatible); + end if; + + -- See if Expr is an object with known alignment + + elsif Is_Entity_Name (Expr) + and then Known_Alignment (Entity (Expr)) + then + ExpA := Alignment (Entity (Expr)); + + -- Otherwise, we can use the alignment of the type of + -- Expr given that we already checked for + -- discombobulating rep clauses for the cases of indexed + -- and selected components above. + + elsif Known_Alignment (Etype (Expr)) then + ExpA := Alignment (Etype (Expr)); + + -- Otherwise the alignment is unknown + + else + Set_Result (Default); + end if; + + -- If we got an alignment, see if it is acceptable + + if ExpA /= No_Uint and then ExpA < ObjA then + Set_Result (Known_Incompatible); + end if; + + -- If Expr is not a piece of a larger object, see if size + -- is given. If so, check that it is not too small for the + -- required alignment. + + if Offs /= No_Uint then + null; + + -- See if Expr is an object with known size + + elsif Is_Entity_Name (Expr) + and then Known_Static_Esize (Entity (Expr)) + then + SizA := Esize (Entity (Expr)); + + -- Otherwise, we check the object size of the Expr type + + elsif Known_Static_Esize (Etype (Expr)) then + SizA := Esize (Etype (Expr)); + end if; + + -- If we got a size, see if it is a multiple of the Obj + -- alignment, if not, then the alignment cannot be + -- acceptable, since the size is always a multiple of the + -- alignment. + + if SizA /= No_Uint then + if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then + Set_Result (Known_Incompatible); + end if; + end if; + end if; + end; + + -- If we do not know required alignment, any non-zero offset is a + -- potential problem (but certainly may be OK, so result is unknown). + + elsif Offs /= No_Uint then + Set_Result (Unknown); + + -- If we can't find the result by direct comparison of alignment + -- values, then there is still one case that we can determine known + -- result, and that is when we can determine that the types are the + -- same, and no alignments are specified. Then we known that the + -- alignments are compatible, even if we don't know the alignment + -- value in the front end. + + elsif Etype (Obj) = Etype (Expr) then + + -- Types are the same, but we have to check for possible size + -- and alignments on the Expr object that may make the alignment + -- different, even though the types are the same. + + if Is_Entity_Name (Expr) then + + -- First check alignment of the Expr object. Any alignment less + -- than Maximum_Alignment is worrisome since this is the case + -- where we do not know the alignment of Obj. + + if Known_Alignment (Entity (Expr)) + and then + UI_To_Int (Alignment (Entity (Expr))) < + Ttypes.Maximum_Alignment + then + Set_Result (Unknown); + + -- Now check size of Expr object. Any size that is not an + -- even multiple of Maximum_Alignment is also worrisome + -- since it may cause the alignment of the object to be less + -- than the alignment of the type. + + elsif Known_Static_Esize (Entity (Expr)) + and then + (UI_To_Int (Esize (Entity (Expr))) mod + (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit)) + /= 0 + then + Set_Result (Unknown); + + -- Otherwise same type is decisive + + else + Set_Result (Known_Compatible); + end if; + end if; + + -- Another case to deal with is when there is an explicit size or + -- alignment clause when the types are not the same. If so, then the + -- result is Unknown. We don't need to do this test if the Default is + -- Unknown, since that result will be set in any case. + + elsif Default /= Unknown + and then (Has_Size_Clause (Etype (Expr)) + or else + Has_Alignment_Clause (Etype (Expr))) + then + Set_Result (Unknown); + + -- If no indication found, set default + + else + Set_Result (Default); + end if; + + -- Return worst result found + + return Result; + end Has_Compatible_Alignment_Internal; + + -- Start of processing for Has_Compatible_Alignment + + begin + -- If Obj has no specified alignment, then set alignment from the type + -- alignment. Perhaps we should always do this, but for sure we should + -- do it when there is an address clause since we can do more if the + -- alignment is known. + + if Unknown_Alignment (Obj) then + Set_Alignment (Obj, Alignment (Etype (Obj))); + end if; + + -- Now do the internal call that does all the work + + return Has_Compatible_Alignment_Internal (Obj, Expr, Unknown); + end Has_Compatible_Alignment; + + ---------------------- + -- Has_Declarations -- + ---------------------- + + function Has_Declarations (N : Node_Id) return Boolean is + begin + return Nkind_In (Nkind (N), N_Accept_Statement, + N_Block_Statement, + N_Compilation_Unit_Aux, + N_Entry_Body, + N_Package_Body, + N_Protected_Body, + N_Subprogram_Body, + N_Task_Body, + N_Package_Specification); + end Has_Declarations; + + ------------------------------------------- + -- Has_Discriminant_Dependent_Constraint -- + ------------------------------------------- + + function Has_Discriminant_Dependent_Constraint + (Comp : Entity_Id) return Boolean + is + Comp_Decl : constant Node_Id := Parent (Comp); + Subt_Indic : constant Node_Id := + Subtype_Indication (Component_Definition (Comp_Decl)); + Constr : Node_Id; + Assn : Node_Id; + + begin + if Nkind (Subt_Indic) = N_Subtype_Indication then + Constr := Constraint (Subt_Indic); + + if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then + Assn := First (Constraints (Constr)); + while Present (Assn) loop + case Nkind (Assn) is + when N_Subtype_Indication | + N_Range | + N_Identifier + => + if Depends_On_Discriminant (Assn) then + return True; + end if; + + when N_Discriminant_Association => + if Depends_On_Discriminant (Expression (Assn)) then + return True; + end if; + + when others => + null; + + end case; + + Next (Assn); + end loop; + end if; + end if; + + return False; + end Has_Discriminant_Dependent_Constraint; + + -------------------- + -- Has_Infinities -- + -------------------- + + function Has_Infinities (E : Entity_Id) return Boolean is + begin + return + Is_Floating_Point_Type (E) + and then Nkind (Scalar_Range (E)) = N_Range + and then Includes_Infinities (Scalar_Range (E)); + end Has_Infinities; + + -------------------- + -- Has_Interfaces -- + -------------------- + + function Has_Interfaces + (T : Entity_Id; + Use_Full_View : Boolean := True) return Boolean + is + Typ : Entity_Id := Base_Type (T); + + begin + -- Handle concurrent types + + if Is_Concurrent_Type (Typ) then + Typ := Corresponding_Record_Type (Typ); + end if; + + if not Present (Typ) + or else not Is_Record_Type (Typ) + or else not Is_Tagged_Type (Typ) + then + return False; + end if; + + -- Handle private types + + if Use_Full_View + and then Present (Full_View (Typ)) + then + Typ := Full_View (Typ); + end if; + + -- Handle concurrent record types + + if Is_Concurrent_Record_Type (Typ) + and then Is_Non_Empty_List (Abstract_Interface_List (Typ)) + then + return True; + end if; + + loop + if Is_Interface (Typ) + or else + (Is_Record_Type (Typ) + and then Present (Interfaces (Typ)) + and then not Is_Empty_Elmt_List (Interfaces (Typ))) + then + return True; + end if; + + exit when Etype (Typ) = Typ + + -- Handle private types + + or else (Present (Full_View (Etype (Typ))) + and then Full_View (Etype (Typ)) = Typ) + + -- Protect the frontend against wrong source with cyclic + -- derivations + + or else Etype (Typ) = T; + + -- Climb to the ancestor type handling private types + + if Present (Full_View (Etype (Typ))) then + Typ := Full_View (Etype (Typ)); + else + Typ := Etype (Typ); + end if; + end loop; + + return False; + end Has_Interfaces; + + ------------------------ + -- Has_Null_Exclusion -- + ------------------------ + + function Has_Null_Exclusion (N : Node_Id) return Boolean is + begin + case Nkind (N) is + when N_Access_Definition | + N_Access_Function_Definition | + N_Access_Procedure_Definition | + N_Access_To_Object_Definition | + N_Allocator | + N_Derived_Type_Definition | + N_Function_Specification | + N_Subtype_Declaration => + return Null_Exclusion_Present (N); + + when N_Component_Definition | + N_Formal_Object_Declaration | + N_Object_Renaming_Declaration => + if Present (Subtype_Mark (N)) then + return Null_Exclusion_Present (N); + else pragma Assert (Present (Access_Definition (N))); + return Null_Exclusion_Present (Access_Definition (N)); + end if; + + when N_Discriminant_Specification => + if Nkind (Discriminant_Type (N)) = N_Access_Definition then + return Null_Exclusion_Present (Discriminant_Type (N)); + else + return Null_Exclusion_Present (N); + end if; + + when N_Object_Declaration => + if Nkind (Object_Definition (N)) = N_Access_Definition then + return Null_Exclusion_Present (Object_Definition (N)); + else + return Null_Exclusion_Present (N); + end if; + + when N_Parameter_Specification => + if Nkind (Parameter_Type (N)) = N_Access_Definition then + return Null_Exclusion_Present (Parameter_Type (N)); + else + return Null_Exclusion_Present (N); + end if; + + when others => + return False; + + end case; + end Has_Null_Exclusion; + + ------------------------ + -- Has_Null_Extension -- + ------------------------ + + function Has_Null_Extension (T : Entity_Id) return Boolean is + B : constant Entity_Id := Base_Type (T); + Comps : Node_Id; + Ext : Node_Id; + + begin + if Nkind (Parent (B)) = N_Full_Type_Declaration + and then Present (Record_Extension_Part (Type_Definition (Parent (B)))) + then + Ext := Record_Extension_Part (Type_Definition (Parent (B))); + + if Present (Ext) then + if Null_Present (Ext) then + return True; + else + Comps := Component_List (Ext); + + -- The null component list is rewritten during analysis to + -- include the parent component. Any other component indicates + -- that the extension was not originally null. + + return Null_Present (Comps) + or else No (Next (First (Component_Items (Comps)))); + end if; + else + return False; + end if; + + else + return False; + end if; + end Has_Null_Extension; + + ------------------------------- + -- Has_Overriding_Initialize -- + ------------------------------- + + function Has_Overriding_Initialize (T : Entity_Id) return Boolean is + BT : constant Entity_Id := Base_Type (T); + Comp : Entity_Id; + P : Elmt_Id; + + begin + if Is_Controlled (BT) then + + -- For derived types, check immediate ancestor, excluding + -- Controlled itself. + + if Is_Derived_Type (BT) + and then not In_Predefined_Unit (Etype (BT)) + and then Has_Overriding_Initialize (Etype (BT)) + then + return True; + + elsif Present (Primitive_Operations (BT)) then + P := First_Elmt (Primitive_Operations (BT)); + while Present (P) loop + if Chars (Node (P)) = Name_Initialize + and then Comes_From_Source (Node (P)) + then + return True; + end if; + + Next_Elmt (P); + end loop; + end if; + + return False; + + elsif Has_Controlled_Component (BT) then + Comp := First_Component (BT); + while Present (Comp) loop + if Has_Overriding_Initialize (Etype (Comp)) then + return True; + end if; + + Next_Component (Comp); + end loop; + + return False; + + else + return False; + end if; + end Has_Overriding_Initialize; + + -------------------------------------- + -- Has_Preelaborable_Initialization -- + -------------------------------------- + + function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is + Has_PE : Boolean; + + procedure Check_Components (E : Entity_Id); + -- Check component/discriminant chain, sets Has_PE False if a component + -- or discriminant does not meet the preelaborable initialization rules. + + ---------------------- + -- Check_Components -- + ---------------------- + + procedure Check_Components (E : Entity_Id) is + Ent : Entity_Id; + Exp : Node_Id; + + function Is_Preelaborable_Expression (N : Node_Id) return Boolean; + -- Returns True if and only if the expression denoted by N does not + -- violate restrictions on preelaborable constructs (RM-10.2.1(5-9)). + + --------------------------------- + -- Is_Preelaborable_Expression -- + --------------------------------- + + function Is_Preelaborable_Expression (N : Node_Id) return Boolean is + Exp : Node_Id; + Assn : Node_Id; + Choice : Node_Id; + Comp_Type : Entity_Id; + Is_Array_Aggr : Boolean; + + begin + if Is_Static_Expression (N) then + return True; + + elsif Nkind (N) = N_Null then + return True; + + -- Attributes are allowed in general, even if their prefix is a + -- formal type. (It seems that certain attributes known not to be + -- static might not be allowed, but there are no rules to prevent + -- them.) + + elsif Nkind (N) = N_Attribute_Reference then + return True; + + -- The name of a discriminant evaluated within its parent type is + -- defined to be preelaborable (10.2.1(8)). Note that we test for + -- names that denote discriminals as well as discriminants to + -- catch references occurring within init procs. + + elsif Is_Entity_Name (N) + and then + (Ekind (Entity (N)) = E_Discriminant + or else + ((Ekind (Entity (N)) = E_Constant + or else Ekind (Entity (N)) = E_In_Parameter) + and then Present (Discriminal_Link (Entity (N))))) + then + return True; + + elsif Nkind (N) = N_Qualified_Expression then + return Is_Preelaborable_Expression (Expression (N)); + + -- For aggregates we have to check that each of the associations + -- is preelaborable. + + elsif Nkind (N) = N_Aggregate + or else Nkind (N) = N_Extension_Aggregate + then + Is_Array_Aggr := Is_Array_Type (Etype (N)); + + if Is_Array_Aggr then + Comp_Type := Component_Type (Etype (N)); + end if; + + -- Check the ancestor part of extension aggregates, which must + -- be either the name of a type that has preelaborable init or + -- an expression that is preelaborable. + + if Nkind (N) = N_Extension_Aggregate then + declare + Anc_Part : constant Node_Id := Ancestor_Part (N); + + begin + if Is_Entity_Name (Anc_Part) + and then Is_Type (Entity (Anc_Part)) + then + if not Has_Preelaborable_Initialization + (Entity (Anc_Part)) + then + return False; + end if; + + elsif not Is_Preelaborable_Expression (Anc_Part) then + return False; + end if; + end; + end if; + + -- Check positional associations + + Exp := First (Expressions (N)); + while Present (Exp) loop + if not Is_Preelaborable_Expression (Exp) then + return False; + end if; + + Next (Exp); + end loop; + + -- Check named associations + + Assn := First (Component_Associations (N)); + while Present (Assn) loop + Choice := First (Choices (Assn)); + while Present (Choice) loop + if Is_Array_Aggr then + if Nkind (Choice) = N_Others_Choice then + null; + + elsif Nkind (Choice) = N_Range then + if not Is_Static_Range (Choice) then + return False; + end if; + + elsif not Is_Static_Expression (Choice) then + return False; + end if; + + else + Comp_Type := Etype (Choice); + end if; + + Next (Choice); + end loop; + + -- If the association has a <> at this point, then we have + -- to check whether the component's type has preelaborable + -- initialization. Note that this only occurs when the + -- association's corresponding component does not have a + -- default expression, the latter case having already been + -- expanded as an expression for the association. + + if Box_Present (Assn) then + if not Has_Preelaborable_Initialization (Comp_Type) then + return False; + end if; + + -- In the expression case we check whether the expression + -- is preelaborable. + + elsif + not Is_Preelaborable_Expression (Expression (Assn)) + then + return False; + end if; + + Next (Assn); + end loop; + + -- If we get here then aggregate as a whole is preelaborable + + return True; + + -- All other cases are not preelaborable + + else + return False; + end if; + end Is_Preelaborable_Expression; + + -- Start of processing for Check_Components + + begin + -- Loop through entities of record or protected type + + Ent := E; + while Present (Ent) loop + + -- We are interested only in components and discriminants + + Exp := Empty; + + case Ekind (Ent) is + when E_Component => + + -- Get default expression if any. If there is no declaration + -- node, it means we have an internal entity. The parent and + -- tag fields are examples of such entities. For such cases, + -- we just test the type of the entity. + + if Present (Declaration_Node (Ent)) then + Exp := Expression (Declaration_Node (Ent)); + end if; + + when E_Discriminant => + + -- Note: for a renamed discriminant, the Declaration_Node + -- may point to the one from the ancestor, and have a + -- different expression, so use the proper attribute to + -- retrieve the expression from the derived constraint. + + Exp := Discriminant_Default_Value (Ent); + + when others => + goto Check_Next_Entity; + end case; + + -- A component has PI if it has no default expression and the + -- component type has PI. + + if No (Exp) then + if not Has_Preelaborable_Initialization (Etype (Ent)) then + Has_PE := False; + exit; + end if; + + -- Require the default expression to be preelaborable + + elsif not Is_Preelaborable_Expression (Exp) then + Has_PE := False; + exit; + end if; + + <> + Next_Entity (Ent); + end loop; + end Check_Components; + + -- Start of processing for Has_Preelaborable_Initialization + + begin + -- Immediate return if already marked as known preelaborable init. This + -- covers types for which this function has already been called once + -- and returned True (in which case the result is cached), and also + -- types to which a pragma Preelaborable_Initialization applies. + + if Known_To_Have_Preelab_Init (E) then + return True; + end if; + + -- If the type is a subtype representing a generic actual type, then + -- test whether its base type has preelaborable initialization since + -- the subtype representing the actual does not inherit this attribute + -- from the actual or formal. (but maybe it should???) + + if Is_Generic_Actual_Type (E) then + return Has_Preelaborable_Initialization (Base_Type (E)); + end if; + + -- All elementary types have preelaborable initialization + + if Is_Elementary_Type (E) then + Has_PE := True; + + -- Array types have PI if the component type has PI + + elsif Is_Array_Type (E) then + Has_PE := Has_Preelaborable_Initialization (Component_Type (E)); + + -- A derived type has preelaborable initialization if its parent type + -- has preelaborable initialization and (in the case of a derived record + -- extension) if the non-inherited components all have preelaborable + -- initialization. However, a user-defined controlled type with an + -- overriding Initialize procedure does not have preelaborable + -- initialization. + + elsif Is_Derived_Type (E) then + + -- If the derived type is a private extension then it doesn't have + -- preelaborable initialization. + + if Ekind (Base_Type (E)) = E_Record_Type_With_Private then + return False; + end if; + + -- First check whether ancestor type has preelaborable initialization + + Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E))); + + -- If OK, check extension components (if any) + + if Has_PE and then Is_Record_Type (E) then + Check_Components (First_Entity (E)); + end if; + + -- Check specifically for 10.2.1(11.4/2) exception: a controlled type + -- with a user defined Initialize procedure does not have PI. + + if Has_PE + and then Is_Controlled (E) + and then Has_Overriding_Initialize (E) + then + Has_PE := False; + end if; + + -- Private types not derived from a type having preelaborable init and + -- that are not marked with pragma Preelaborable_Initialization do not + -- have preelaborable initialization. + + elsif Is_Private_Type (E) then + return False; + + -- Record type has PI if it is non private and all components have PI + + elsif Is_Record_Type (E) then + Has_PE := True; + Check_Components (First_Entity (E)); + + -- Protected types must not have entries, and components must meet + -- same set of rules as for record components. + + elsif Is_Protected_Type (E) then + if Has_Entries (E) then + Has_PE := False; + else + Has_PE := True; + Check_Components (First_Entity (E)); + Check_Components (First_Private_Entity (E)); + end if; + + -- Type System.Address always has preelaborable initialization + + elsif Is_RTE (E, RE_Address) then + Has_PE := True; + + -- In all other cases, type does not have preelaborable initialization + + else + return False; + end if; + + -- If type has preelaborable initialization, cache result + + if Has_PE then + Set_Known_To_Have_Preelab_Init (E); + end if; + + return Has_PE; + end Has_Preelaborable_Initialization; + + --------------------------- + -- Has_Private_Component -- + --------------------------- + + function Has_Private_Component (Type_Id : Entity_Id) return Boolean is + Btype : Entity_Id := Base_Type (Type_Id); + Component : Entity_Id; + + begin + if Error_Posted (Type_Id) + or else Error_Posted (Btype) + then + return False; + end if; + + if Is_Class_Wide_Type (Btype) then + Btype := Root_Type (Btype); + end if; + + if Is_Private_Type (Btype) then + declare + UT : constant Entity_Id := Underlying_Type (Btype); + begin + if No (UT) then + if No (Full_View (Btype)) then + return not Is_Generic_Type (Btype) + and then not Is_Generic_Type (Root_Type (Btype)); + else + return not Is_Generic_Type (Root_Type (Full_View (Btype))); + end if; + else + return not Is_Frozen (UT) and then Has_Private_Component (UT); + end if; + end; + + elsif Is_Array_Type (Btype) then + return Has_Private_Component (Component_Type (Btype)); + + elsif Is_Record_Type (Btype) then + Component := First_Component (Btype); + while Present (Component) loop + if Has_Private_Component (Etype (Component)) then + return True; + end if; + + Next_Component (Component); + end loop; + + return False; + + elsif Is_Protected_Type (Btype) + and then Present (Corresponding_Record_Type (Btype)) + then + return Has_Private_Component (Corresponding_Record_Type (Btype)); + + else + return False; + end if; + end Has_Private_Component; + + ---------------- + -- Has_Stream -- + ---------------- + + function Has_Stream (T : Entity_Id) return Boolean is + E : Entity_Id; + + begin + if No (T) then + return False; + + elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then + return True; + + elsif Is_Array_Type (T) then + return Has_Stream (Component_Type (T)); + + elsif Is_Record_Type (T) then + E := First_Component (T); + while Present (E) loop + if Has_Stream (Etype (E)) then + return True; + else + Next_Component (E); + end if; + end loop; + + return False; + + elsif Is_Private_Type (T) then + return Has_Stream (Underlying_Type (T)); + + else + return False; + end if; + end Has_Stream; + + ---------------- + -- Has_Suffix -- + ---------------- + + function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is + begin + Get_Name_String (Chars (E)); + return Name_Buffer (Name_Len) = Suffix; + end Has_Suffix; + + -------------------------- + -- Has_Tagged_Component -- + -------------------------- + + function Has_Tagged_Component (Typ : Entity_Id) return Boolean is + Comp : Entity_Id; + + begin + if Is_Private_Type (Typ) + and then Present (Underlying_Type (Typ)) + then + return Has_Tagged_Component (Underlying_Type (Typ)); + + elsif Is_Array_Type (Typ) then + return Has_Tagged_Component (Component_Type (Typ)); + + elsif Is_Tagged_Type (Typ) then + return True; + + elsif Is_Record_Type (Typ) then + Comp := First_Component (Typ); + while Present (Comp) loop + if Has_Tagged_Component (Etype (Comp)) then + return True; + end if; + + Next_Component (Comp); + end loop; + + return False; + + else + return False; + end if; + end Has_Tagged_Component; + + ------------------------- + -- Implementation_Kind -- + ------------------------- + + function Implementation_Kind (Subp : Entity_Id) return Name_Id is + Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented); + begin + pragma Assert (Present (Impl_Prag)); + return + Chars (Expression (Last (Pragma_Argument_Associations (Impl_Prag)))); + end Implementation_Kind; + + -------------------------- + -- Implements_Interface -- + -------------------------- + + function Implements_Interface + (Typ_Ent : Entity_Id; + Iface_Ent : Entity_Id; + Exclude_Parents : Boolean := False) return Boolean + is + Ifaces_List : Elist_Id; + Elmt : Elmt_Id; + Iface : Entity_Id := Base_Type (Iface_Ent); + Typ : Entity_Id := Base_Type (Typ_Ent); + + begin + if Is_Class_Wide_Type (Typ) then + Typ := Root_Type (Typ); + end if; + + if not Has_Interfaces (Typ) then + return False; + end if; + + if Is_Class_Wide_Type (Iface) then + Iface := Root_Type (Iface); + end if; + + Collect_Interfaces (Typ, Ifaces_List); + + Elmt := First_Elmt (Ifaces_List); + while Present (Elmt) loop + if Is_Ancestor (Node (Elmt), Typ) + and then Exclude_Parents + then + null; + + elsif Node (Elmt) = Iface then + return True; + end if; + + Next_Elmt (Elmt); + end loop; + + return False; + end Implements_Interface; + + ----------------- + -- In_Instance -- + ----------------- + + function In_Instance return Boolean is + Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); + S : Entity_Id; + + begin + S := Current_Scope; + while Present (S) + and then S /= Standard_Standard + loop + if (Ekind (S) = E_Function + or else Ekind (S) = E_Package + or else Ekind (S) = E_Procedure) + and then Is_Generic_Instance (S) + then + -- A child instance is always compiled in the context of a parent + -- instance. Nevertheless, the actuals are not analyzed in an + -- instance context. We detect this case by examining the current + -- compilation unit, which must be a child instance, and checking + -- that it is not currently on the scope stack. + + if Is_Child_Unit (Curr_Unit) + and then + Nkind (Unit (Cunit (Current_Sem_Unit))) + = N_Package_Instantiation + and then not In_Open_Scopes (Curr_Unit) + then + return False; + else + return True; + end if; + end if; + + S := Scope (S); + end loop; + + return False; + end In_Instance; + + ---------------------- + -- In_Instance_Body -- + ---------------------- + + function In_Instance_Body return Boolean is + S : Entity_Id; + + begin + S := Current_Scope; + while Present (S) + and then S /= Standard_Standard + loop + if (Ekind (S) = E_Function + or else Ekind (S) = E_Procedure) + and then Is_Generic_Instance (S) + then + return True; + + elsif Ekind (S) = E_Package + and then In_Package_Body (S) + and then Is_Generic_Instance (S) + then + return True; + end if; + + S := Scope (S); + end loop; + + return False; + end In_Instance_Body; + + ----------------------------- + -- In_Instance_Not_Visible -- + ----------------------------- + + function In_Instance_Not_Visible return Boolean is + S : Entity_Id; + + begin + S := Current_Scope; + while Present (S) + and then S /= Standard_Standard + loop + if (Ekind (S) = E_Function + or else Ekind (S) = E_Procedure) + and then Is_Generic_Instance (S) + then + return True; + + elsif Ekind (S) = E_Package + and then (In_Package_Body (S) or else In_Private_Part (S)) + and then Is_Generic_Instance (S) + then + return True; + end if; + + S := Scope (S); + end loop; + + return False; + end In_Instance_Not_Visible; + + ------------------------------ + -- In_Instance_Visible_Part -- + ------------------------------ + + function In_Instance_Visible_Part return Boolean is + S : Entity_Id; + + begin + S := Current_Scope; + while Present (S) + and then S /= Standard_Standard + loop + if Ekind (S) = E_Package + and then Is_Generic_Instance (S) + and then not In_Package_Body (S) + and then not In_Private_Part (S) + then + return True; + end if; + + S := Scope (S); + end loop; + + return False; + end In_Instance_Visible_Part; + + --------------------- + -- In_Package_Body -- + --------------------- + + function In_Package_Body return Boolean is + S : Entity_Id; + + begin + S := Current_Scope; + while Present (S) + and then S /= Standard_Standard + loop + if Ekind (S) = E_Package + and then In_Package_Body (S) + then + return True; + else + S := Scope (S); + end if; + end loop; + + return False; + end In_Package_Body; + + -------------------------------- + -- In_Parameter_Specification -- + -------------------------------- + + function In_Parameter_Specification (N : Node_Id) return Boolean is + PN : Node_Id; + + begin + PN := Parent (N); + while Present (PN) loop + if Nkind (PN) = N_Parameter_Specification then + return True; + end if; + + PN := Parent (PN); + end loop; + + return False; + end In_Parameter_Specification; + + -------------------------------------- + -- In_Subprogram_Or_Concurrent_Unit -- + -------------------------------------- + + function In_Subprogram_Or_Concurrent_Unit return Boolean is + E : Entity_Id; + K : Entity_Kind; + + begin + -- Use scope chain to check successively outer scopes + + E := Current_Scope; + loop + K := Ekind (E); + + if K in Subprogram_Kind + or else K in Concurrent_Kind + or else K in Generic_Subprogram_Kind + then + return True; + + elsif E = Standard_Standard then + return False; + end if; + + E := Scope (E); + end loop; + end In_Subprogram_Or_Concurrent_Unit; + + --------------------- + -- In_Visible_Part -- + --------------------- + + function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is + begin + return + Is_Package_Or_Generic_Package (Scope_Id) + and then In_Open_Scopes (Scope_Id) + and then not In_Package_Body (Scope_Id) + and then not In_Private_Part (Scope_Id); + end In_Visible_Part; + + --------------------------------- + -- Insert_Explicit_Dereference -- + --------------------------------- + + procedure Insert_Explicit_Dereference (N : Node_Id) is + New_Prefix : constant Node_Id := Relocate_Node (N); + Ent : Entity_Id := Empty; + Pref : Node_Id; + I : Interp_Index; + It : Interp; + T : Entity_Id; + + begin + Save_Interps (N, New_Prefix); + + Rewrite (N, + Make_Explicit_Dereference (Sloc (Parent (N)), + Prefix => New_Prefix)); + + Set_Etype (N, Designated_Type (Etype (New_Prefix))); + + if Is_Overloaded (New_Prefix) then + + -- The dereference is also overloaded, and its interpretations are + -- the designated types of the interpretations of the original node. + + Set_Etype (N, Any_Type); + + Get_First_Interp (New_Prefix, I, It); + while Present (It.Nam) loop + T := It.Typ; + + if Is_Access_Type (T) then + Add_One_Interp (N, Designated_Type (T), Designated_Type (T)); + end if; + + Get_Next_Interp (I, It); + end loop; + + End_Interp_List; + + else + -- Prefix is unambiguous: mark the original prefix (which might + -- Come_From_Source) as a reference, since the new (relocated) one + -- won't be taken into account. + + if Is_Entity_Name (New_Prefix) then + Ent := Entity (New_Prefix); + Pref := New_Prefix; + + -- For a retrieval of a subcomponent of some composite object, + -- retrieve the ultimate entity if there is one. + + elsif Nkind (New_Prefix) = N_Selected_Component + or else Nkind (New_Prefix) = N_Indexed_Component + then + Pref := Prefix (New_Prefix); + while Present (Pref) + and then + (Nkind (Pref) = N_Selected_Component + or else Nkind (Pref) = N_Indexed_Component) + loop + Pref := Prefix (Pref); + end loop; + + if Present (Pref) and then Is_Entity_Name (Pref) then + Ent := Entity (Pref); + end if; + end if; + + -- Place the reference on the entity node + + if Present (Ent) then + Generate_Reference (Ent, Pref); + end if; + end if; + end Insert_Explicit_Dereference; + + ------------------------------------------ + -- Inspect_Deferred_Constant_Completion -- + ------------------------------------------ + + procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is + Decl : Node_Id; + + begin + Decl := First (Decls); + while Present (Decl) loop + + -- Deferred constant signature + + if Nkind (Decl) = N_Object_Declaration + and then Constant_Present (Decl) + and then No (Expression (Decl)) + + -- No need to check internally generated constants + + and then Comes_From_Source (Decl) + + -- The constant is not completed. A full object declaration or a + -- pragma Import complete a deferred constant. + + and then not Has_Completion (Defining_Identifier (Decl)) + then + Error_Msg_N + ("constant declaration requires initialization expression", + Defining_Identifier (Decl)); + end if; + + Decl := Next (Decl); + end loop; + end Inspect_Deferred_Constant_Completion; + + ----------------------------- + -- Is_Actual_Out_Parameter -- + ----------------------------- + + function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is + Formal : Entity_Id; + Call : Node_Id; + begin + Find_Actual (N, Formal, Call); + return Present (Formal) and then Ekind (Formal) = E_Out_Parameter; + end Is_Actual_Out_Parameter; + + ------------------------- + -- Is_Actual_Parameter -- + ------------------------- + + function Is_Actual_Parameter (N : Node_Id) return Boolean is + PK : constant Node_Kind := Nkind (Parent (N)); + + begin + case PK is + when N_Parameter_Association => + return N = Explicit_Actual_Parameter (Parent (N)); + + when N_Function_Call | N_Procedure_Call_Statement => + return Is_List_Member (N) + and then + List_Containing (N) = Parameter_Associations (Parent (N)); + + when others => + return False; + end case; + end Is_Actual_Parameter; + + --------------------- + -- Is_Aliased_View -- + --------------------- + + function Is_Aliased_View (Obj : Node_Id) return Boolean is + E : Entity_Id; + + begin + if Is_Entity_Name (Obj) then + + E := Entity (Obj); + + return + (Is_Object (E) + and then + (Is_Aliased (E) + or else (Present (Renamed_Object (E)) + and then Is_Aliased_View (Renamed_Object (E))))) + + or else ((Is_Formal (E) + or else Ekind (E) = E_Generic_In_Out_Parameter + or else Ekind (E) = E_Generic_In_Parameter) + and then Is_Tagged_Type (Etype (E))) + + or else (Is_Concurrent_Type (E) + and then In_Open_Scopes (E)) + + -- Current instance of type, either directly or as rewritten + -- reference to the current object. + + or else (Is_Entity_Name (Original_Node (Obj)) + and then Present (Entity (Original_Node (Obj))) + and then Is_Type (Entity (Original_Node (Obj)))) + + or else (Is_Type (E) and then E = Current_Scope) + + or else (Is_Incomplete_Or_Private_Type (E) + and then Full_View (E) = Current_Scope); + + elsif Nkind (Obj) = N_Selected_Component then + return Is_Aliased (Entity (Selector_Name (Obj))); + + elsif Nkind (Obj) = N_Indexed_Component then + return Has_Aliased_Components (Etype (Prefix (Obj))) + or else + (Is_Access_Type (Etype (Prefix (Obj))) + and then + Has_Aliased_Components + (Designated_Type (Etype (Prefix (Obj))))); + + elsif Nkind (Obj) = N_Unchecked_Type_Conversion + or else Nkind (Obj) = N_Type_Conversion + then + return Is_Tagged_Type (Etype (Obj)) + and then Is_Aliased_View (Expression (Obj)); + + elsif Nkind (Obj) = N_Explicit_Dereference then + return Nkind (Original_Node (Obj)) /= N_Function_Call; + + else + return False; + end if; + end Is_Aliased_View; + + ------------------------- + -- Is_Ancestor_Package -- + ------------------------- + + function Is_Ancestor_Package + (E1 : Entity_Id; + E2 : Entity_Id) return Boolean + is + Par : Entity_Id; + + begin + Par := E2; + while Present (Par) + and then Par /= Standard_Standard + loop + if Par = E1 then + return True; + end if; + + Par := Scope (Par); + end loop; + + return False; + end Is_Ancestor_Package; + + ---------------------- + -- Is_Atomic_Object -- + ---------------------- + + function Is_Atomic_Object (N : Node_Id) return Boolean is + + function Object_Has_Atomic_Components (N : Node_Id) return Boolean; + -- Determines if given object has atomic components + + function Is_Atomic_Prefix (N : Node_Id) return Boolean; + -- If prefix is an implicit dereference, examine designated type + + ---------------------- + -- Is_Atomic_Prefix -- + ---------------------- + + function Is_Atomic_Prefix (N : Node_Id) return Boolean is + begin + if Is_Access_Type (Etype (N)) then + return + Has_Atomic_Components (Designated_Type (Etype (N))); + else + return Object_Has_Atomic_Components (N); + end if; + end Is_Atomic_Prefix; + + ---------------------------------- + -- Object_Has_Atomic_Components -- + ---------------------------------- + + function Object_Has_Atomic_Components (N : Node_Id) return Boolean is + begin + if Has_Atomic_Components (Etype (N)) + or else Is_Atomic (Etype (N)) + then + return True; + + elsif Is_Entity_Name (N) + and then (Has_Atomic_Components (Entity (N)) + or else Is_Atomic (Entity (N))) + then + return True; + + elsif Nkind (N) = N_Indexed_Component + or else Nkind (N) = N_Selected_Component + then + return Is_Atomic_Prefix (Prefix (N)); + + else + return False; + end if; + end Object_Has_Atomic_Components; + + -- Start of processing for Is_Atomic_Object + + begin + -- Predicate is not relevant to subprograms + + if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then + return False; + + elsif Is_Atomic (Etype (N)) + or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N))) + then + return True; + + elsif Nkind (N) = N_Indexed_Component + or else Nkind (N) = N_Selected_Component + then + return Is_Atomic_Prefix (Prefix (N)); + + else + return False; + end if; + end Is_Atomic_Object; + + ------------------------- + -- Is_Coextension_Root -- + ------------------------- + + function Is_Coextension_Root (N : Node_Id) return Boolean is + begin + return + Nkind (N) = N_Allocator + and then Present (Coextensions (N)) + + -- Anonymous access discriminants carry a list of all nested + -- controlled coextensions. + + and then not Is_Dynamic_Coextension (N) + and then not Is_Static_Coextension (N); + end Is_Coextension_Root; + + ----------------------------- + -- Is_Concurrent_Interface -- + ----------------------------- + + function Is_Concurrent_Interface (T : Entity_Id) return Boolean is + begin + return + Is_Interface (T) + and then + (Is_Protected_Interface (T) + or else Is_Synchronized_Interface (T) + or else Is_Task_Interface (T)); + end Is_Concurrent_Interface; + + -------------------------------------- + -- Is_Controlling_Limited_Procedure -- + -------------------------------------- + + function Is_Controlling_Limited_Procedure + (Proc_Nam : Entity_Id) return Boolean + is + Param_Typ : Entity_Id := Empty; + + begin + if Ekind (Proc_Nam) = E_Procedure + and then Present (Parameter_Specifications (Parent (Proc_Nam))) + then + Param_Typ := Etype (Parameter_Type (First ( + Parameter_Specifications (Parent (Proc_Nam))))); + + -- In this case where an Itype was created, the procedure call has been + -- rewritten. + + elsif Present (Associated_Node_For_Itype (Proc_Nam)) + and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam))) + and then + Present (Parameter_Associations + (Associated_Node_For_Itype (Proc_Nam))) + then + Param_Typ := + Etype (First (Parameter_Associations + (Associated_Node_For_Itype (Proc_Nam)))); + end if; + + if Present (Param_Typ) then + return + Is_Interface (Param_Typ) + and then Is_Limited_Record (Param_Typ); + end if; + + return False; + end Is_Controlling_Limited_Procedure; + + ----------------------------- + -- Is_CPP_Constructor_Call -- + ----------------------------- + + function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is + begin + return Nkind (N) = N_Function_Call + and then Is_CPP_Class (Etype (Etype (N))) + and then Is_Constructor (Entity (Name (N))) + and then Is_Imported (Entity (Name (N))); + end Is_CPP_Constructor_Call; + + ----------------- + -- Is_Delegate -- + ----------------- + + function Is_Delegate (T : Entity_Id) return Boolean is + Desig_Type : Entity_Id; + + begin + if VM_Target /= CLI_Target then + return False; + end if; + + -- Access-to-subprograms are delegates in CIL + + if Ekind (T) = E_Access_Subprogram_Type then + return True; + end if; + + if Ekind (T) not in Access_Kind then + + -- A delegate is a managed pointer. If no designated type is defined + -- it means that it's not a delegate. + + return False; + end if; + + Desig_Type := Etype (Directly_Designated_Type (T)); + + if not Is_Tagged_Type (Desig_Type) then + return False; + end if; + + -- Test if the type is inherited from [mscorlib]System.Delegate + + while Etype (Desig_Type) /= Desig_Type loop + if Chars (Scope (Desig_Type)) /= No_Name + and then Is_Imported (Scope (Desig_Type)) + and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate" + then + return True; + end if; + + Desig_Type := Etype (Desig_Type); + end loop; + + return False; + end Is_Delegate; + + ---------------------------------------------- + -- Is_Dependent_Component_Of_Mutable_Object -- + ---------------------------------------------- + + function Is_Dependent_Component_Of_Mutable_Object + (Object : Node_Id) return Boolean + is + P : Node_Id; + Prefix_Type : Entity_Id; + P_Aliased : Boolean := False; + Comp : Entity_Id; + + function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean; + -- Returns True if and only if Comp is declared within a variant part + + -------------------------------- + -- Is_Declared_Within_Variant -- + -------------------------------- + + function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is + Comp_Decl : constant Node_Id := Parent (Comp); + Comp_List : constant Node_Id := Parent (Comp_Decl); + begin + return Nkind (Parent (Comp_List)) = N_Variant; + end Is_Declared_Within_Variant; + + -- Start of processing for Is_Dependent_Component_Of_Mutable_Object + + begin + if Is_Variable (Object) then + + if Nkind (Object) = N_Selected_Component then + P := Prefix (Object); + Prefix_Type := Etype (P); + + if Is_Entity_Name (P) then + + if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then + Prefix_Type := Base_Type (Prefix_Type); + end if; + + if Is_Aliased (Entity (P)) then + P_Aliased := True; + end if; + + -- A discriminant check on a selected component may be expanded + -- into a dereference when removing side-effects. Recover the + -- original node and its type, which may be unconstrained. + + elsif Nkind (P) = N_Explicit_Dereference + and then not (Comes_From_Source (P)) + then + P := Original_Node (P); + Prefix_Type := Etype (P); + + else + -- Check for prefix being an aliased component??? + + null; + + end if; + + -- A heap object is constrained by its initial value + + -- Ada 2005 (AI-363): Always assume the object could be mutable in + -- the dereferenced case, since the access value might denote an + -- unconstrained aliased object, whereas in Ada 95 the designated + -- object is guaranteed to be constrained. A worst-case assumption + -- has to apply in Ada 2005 because we can't tell at compile time + -- whether the object is "constrained by its initial value" + -- (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are + -- semantic rules -- these rules are acknowledged to need fixing). + + if Ada_Version < Ada_2005 then + if Is_Access_Type (Prefix_Type) + or else Nkind (P) = N_Explicit_Dereference + then + return False; + end if; + + elsif Ada_Version >= Ada_2005 then + if Is_Access_Type (Prefix_Type) then + + -- If the access type is pool-specific, and there is no + -- constrained partial view of the designated type, then the + -- designated object is known to be constrained. + + if Ekind (Prefix_Type) = E_Access_Type + and then not Has_Constrained_Partial_View + (Designated_Type (Prefix_Type)) + then + return False; + + -- Otherwise (general access type, or there is a constrained + -- partial view of the designated type), we need to check + -- based on the designated type. + + else + Prefix_Type := Designated_Type (Prefix_Type); + end if; + end if; + end if; + + Comp := + Original_Record_Component (Entity (Selector_Name (Object))); + + -- As per AI-0017, the renaming is illegal in a generic body, even + -- if the subtype is indefinite. + + -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable + + if not Is_Constrained (Prefix_Type) + and then (not Is_Indefinite_Subtype (Prefix_Type) + or else + (Is_Generic_Type (Prefix_Type) + and then Ekind (Current_Scope) = E_Generic_Package + and then In_Package_Body (Current_Scope))) + + and then (Is_Declared_Within_Variant (Comp) + or else Has_Discriminant_Dependent_Constraint (Comp)) + and then (not P_Aliased or else Ada_Version >= Ada_2005) + then + return True; + + else + return + Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); + + end if; + + elsif Nkind (Object) = N_Indexed_Component + or else Nkind (Object) = N_Slice + then + return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); + + -- A type conversion that Is_Variable is a view conversion: + -- go back to the denoted object. + + elsif Nkind (Object) = N_Type_Conversion then + return + Is_Dependent_Component_Of_Mutable_Object (Expression (Object)); + end if; + end if; + + return False; + end Is_Dependent_Component_Of_Mutable_Object; + + --------------------- + -- Is_Dereferenced -- + --------------------- + + function Is_Dereferenced (N : Node_Id) return Boolean is + P : constant Node_Id := Parent (N); + begin + return + (Nkind (P) = N_Selected_Component + or else + Nkind (P) = N_Explicit_Dereference + or else + Nkind (P) = N_Indexed_Component + or else + Nkind (P) = N_Slice) + and then Prefix (P) = N; + end Is_Dereferenced; + + ---------------------- + -- Is_Descendent_Of -- + ---------------------- + + function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is + T : Entity_Id; + Etyp : Entity_Id; + + begin + pragma Assert (Nkind (T1) in N_Entity); + pragma Assert (Nkind (T2) in N_Entity); + + T := Base_Type (T1); + + -- Immediate return if the types match + + if T = T2 then + return True; + + -- Comment needed here ??? + + elsif Ekind (T) = E_Class_Wide_Type then + return Etype (T) = T2; + + -- All other cases + + else + loop + Etyp := Etype (T); + + -- Done if we found the type we are looking for + + if Etyp = T2 then + return True; + + -- Done if no more derivations to check + + elsif T = T1 + or else T = Etyp + then + return False; + + -- Following test catches error cases resulting from prev errors + + elsif No (Etyp) then + return False; + + elsif Is_Private_Type (T) and then Etyp = Full_View (T) then + return False; + + elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then + return False; + end if; + + T := Base_Type (Etyp); + end loop; + end if; + end Is_Descendent_Of; + + -------------- + -- Is_False -- + -------------- + + function Is_False (U : Uint) return Boolean is + begin + return (U = 0); + end Is_False; + + --------------------------- + -- Is_Fixed_Model_Number -- + --------------------------- + + function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is + S : constant Ureal := Small_Value (T); + M : Urealp.Save_Mark; + R : Boolean; + begin + M := Urealp.Mark; + R := (U = UR_Trunc (U / S) * S); + Urealp.Release (M); + return R; + end Is_Fixed_Model_Number; + + ------------------------------- + -- Is_Fully_Initialized_Type -- + ------------------------------- + + function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is + begin + if Is_Scalar_Type (Typ) then + return False; + + elsif Is_Access_Type (Typ) then + return True; + + elsif Is_Array_Type (Typ) then + if Is_Fully_Initialized_Type (Component_Type (Typ)) then + return True; + end if; + + -- An interesting case, if we have a constrained type one of whose + -- bounds is known to be null, then there are no elements to be + -- initialized, so all the elements are initialized! + + if Is_Constrained (Typ) then + declare + Indx : Node_Id; + Indx_Typ : Entity_Id; + Lbd, Hbd : Node_Id; + + begin + Indx := First_Index (Typ); + while Present (Indx) loop + if Etype (Indx) = Any_Type then + return False; + + -- If index is a range, use directly + + elsif Nkind (Indx) = N_Range then + Lbd := Low_Bound (Indx); + Hbd := High_Bound (Indx); + + else + Indx_Typ := Etype (Indx); + + if Is_Private_Type (Indx_Typ) then + Indx_Typ := Full_View (Indx_Typ); + end if; + + if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then + return False; + else + Lbd := Type_Low_Bound (Indx_Typ); + Hbd := Type_High_Bound (Indx_Typ); + end if; + end if; + + if Compile_Time_Known_Value (Lbd) + and then Compile_Time_Known_Value (Hbd) + then + if Expr_Value (Hbd) < Expr_Value (Lbd) then + return True; + end if; + end if; + + Next_Index (Indx); + end loop; + end; + end if; + + -- If no null indexes, then type is not fully initialized + + return False; + + -- Record types + + elsif Is_Record_Type (Typ) then + if Has_Discriminants (Typ) + and then + Present (Discriminant_Default_Value (First_Discriminant (Typ))) + and then Is_Fully_Initialized_Variant (Typ) + then + return True; + end if; + + -- Controlled records are considered to be fully initialized if + -- there is a user defined Initialize routine. This may not be + -- entirely correct, but as the spec notes, we are guessing here + -- what is best from the point of view of issuing warnings. + + if Is_Controlled (Typ) then + declare + Utyp : constant Entity_Id := Underlying_Type (Typ); + + begin + if Present (Utyp) then + declare + Init : constant Entity_Id := + (Find_Prim_Op + (Underlying_Type (Typ), Name_Initialize)); + + begin + if Present (Init) + and then Comes_From_Source (Init) + and then not + Is_Predefined_File_Name + (File_Name (Get_Source_File_Index (Sloc (Init)))) + then + return True; + + elsif Has_Null_Extension (Typ) + and then + Is_Fully_Initialized_Type + (Etype (Base_Type (Typ))) + then + return True; + end if; + end; + end if; + end; + end if; + + -- Otherwise see if all record components are initialized + + declare + Ent : Entity_Id; + + begin + Ent := First_Entity (Typ); + while Present (Ent) loop + if Chars (Ent) = Name_uController then + null; + + elsif Ekind (Ent) = E_Component + and then (No (Parent (Ent)) + or else No (Expression (Parent (Ent)))) + and then not Is_Fully_Initialized_Type (Etype (Ent)) + + -- Special VM case for tag components, which need to be + -- defined in this case, but are never initialized as VMs + -- are using other dispatching mechanisms. Ignore this + -- uninitialized case. Note that this applies both to the + -- uTag entry and the main vtable pointer (CPP_Class case). + + and then (Tagged_Type_Expansion or else not Is_Tag (Ent)) + then + return False; + end if; + + Next_Entity (Ent); + end loop; + end; + + -- No uninitialized components, so type is fully initialized. + -- Note that this catches the case of no components as well. + + return True; + + elsif Is_Concurrent_Type (Typ) then + return True; + + elsif Is_Private_Type (Typ) then + declare + U : constant Entity_Id := Underlying_Type (Typ); + + begin + if No (U) then + return False; + else + return Is_Fully_Initialized_Type (U); + end if; + end; + + else + return False; + end if; + end Is_Fully_Initialized_Type; + + ---------------------------------- + -- Is_Fully_Initialized_Variant -- + ---------------------------------- + + function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is + Loc : constant Source_Ptr := Sloc (Typ); + Constraints : constant List_Id := New_List; + Components : constant Elist_Id := New_Elmt_List; + Comp_Elmt : Elmt_Id; + Comp_Id : Node_Id; + Comp_List : Node_Id; + Discr : Entity_Id; + Discr_Val : Node_Id; + + Report_Errors : Boolean; + pragma Warnings (Off, Report_Errors); + + begin + if Serious_Errors_Detected > 0 then + return False; + end if; + + if Is_Record_Type (Typ) + and then Nkind (Parent (Typ)) = N_Full_Type_Declaration + and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition + then + Comp_List := Component_List (Type_Definition (Parent (Typ))); + + Discr := First_Discriminant (Typ); + while Present (Discr) loop + if Nkind (Parent (Discr)) = N_Discriminant_Specification then + Discr_Val := Expression (Parent (Discr)); + + if Present (Discr_Val) + and then Is_OK_Static_Expression (Discr_Val) + then + Append_To (Constraints, + Make_Component_Association (Loc, + Choices => New_List (New_Occurrence_Of (Discr, Loc)), + Expression => New_Copy (Discr_Val))); + else + return False; + end if; + else + return False; + end if; + + Next_Discriminant (Discr); + end loop; + + Gather_Components + (Typ => Typ, + Comp_List => Comp_List, + Governed_By => Constraints, + Into => Components, + Report_Errors => Report_Errors); + + -- Check that each component present is fully initialized + + Comp_Elmt := First_Elmt (Components); + while Present (Comp_Elmt) loop + Comp_Id := Node (Comp_Elmt); + + if Ekind (Comp_Id) = E_Component + and then (No (Parent (Comp_Id)) + or else No (Expression (Parent (Comp_Id)))) + and then not Is_Fully_Initialized_Type (Etype (Comp_Id)) + then + return False; + end if; + + Next_Elmt (Comp_Elmt); + end loop; + + return True; + + elsif Is_Private_Type (Typ) then + declare + U : constant Entity_Id := Underlying_Type (Typ); + + begin + if No (U) then + return False; + else + return Is_Fully_Initialized_Variant (U); + end if; + end; + else + return False; + end if; + end Is_Fully_Initialized_Variant; + + ------------ + -- Is_LHS -- + ------------ + + -- We seem to have a lot of overlapping functions that do similar things + -- (testing for left hand sides or lvalues???). Anyway, since this one is + -- purely syntactic, it should be in Sem_Aux I would think??? + + function Is_LHS (N : Node_Id) return Boolean is + P : constant Node_Id := Parent (N); + begin + return Nkind (P) = N_Assignment_Statement + and then Name (P) = N; + end Is_LHS; + + ---------------------------- + -- Is_Inherited_Operation -- + ---------------------------- + + function Is_Inherited_Operation (E : Entity_Id) return Boolean is + Kind : constant Node_Kind := Nkind (Parent (E)); + begin + pragma Assert (Is_Overloadable (E)); + return Kind = N_Full_Type_Declaration + or else Kind = N_Private_Extension_Declaration + or else Kind = N_Subtype_Declaration + or else (Ekind (E) = E_Enumeration_Literal + and then Is_Derived_Type (Etype (E))); + end Is_Inherited_Operation; + + ----------------------------- + -- Is_Library_Level_Entity -- + ----------------------------- + + function Is_Library_Level_Entity (E : Entity_Id) return Boolean is + begin + -- The following is a small optimization, and it also properly handles + -- discriminals, which in task bodies might appear in expressions before + -- the corresponding procedure has been created, and which therefore do + -- not have an assigned scope. + + if Is_Formal (E) then + return False; + end if; + + -- Normal test is simply that the enclosing dynamic scope is Standard + + return Enclosing_Dynamic_Scope (E) = Standard_Standard; + end Is_Library_Level_Entity; + + --------------------------------- + -- Is_Local_Variable_Reference -- + --------------------------------- + + function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is + begin + if not Is_Entity_Name (Expr) then + return False; + + else + declare + Ent : constant Entity_Id := Entity (Expr); + Sub : constant Entity_Id := Enclosing_Subprogram (Ent); + begin + if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then + return False; + else + return Present (Sub) and then Sub = Current_Subprogram; + end if; + end; + end if; + end Is_Local_Variable_Reference; + + ------------------------- + -- Is_Object_Reference -- + ------------------------- + + function Is_Object_Reference (N : Node_Id) return Boolean is + begin + if Is_Entity_Name (N) then + return Present (Entity (N)) and then Is_Object (Entity (N)); + + else + case Nkind (N) is + when N_Indexed_Component | N_Slice => + return + Is_Object_Reference (Prefix (N)) + or else Is_Access_Type (Etype (Prefix (N))); + + -- In Ada95, a function call is a constant object; a procedure + -- call is not. + + when N_Function_Call => + return Etype (N) /= Standard_Void_Type; + + -- A reference to the stream attribute Input is a function call + + when N_Attribute_Reference => + return Attribute_Name (N) = Name_Input; + + when N_Selected_Component => + return + Is_Object_Reference (Selector_Name (N)) + and then + (Is_Object_Reference (Prefix (N)) + or else Is_Access_Type (Etype (Prefix (N)))); + + when N_Explicit_Dereference => + return True; + + -- A view conversion of a tagged object is an object reference + + when N_Type_Conversion => + return Is_Tagged_Type (Etype (Subtype_Mark (N))) + and then Is_Tagged_Type (Etype (Expression (N))) + and then Is_Object_Reference (Expression (N)); + + -- An unchecked type conversion is considered to be an object if + -- the operand is an object (this construction arises only as a + -- result of expansion activities). + + when N_Unchecked_Type_Conversion => + return True; + + when others => + return False; + end case; + end if; + end Is_Object_Reference; + + ----------------------------------- + -- Is_OK_Variable_For_Out_Formal -- + ----------------------------------- + + function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is + begin + Note_Possible_Modification (AV, Sure => True); + + -- We must reject parenthesized variable names. The check for + -- Comes_From_Source is present because there are currently + -- cases where the compiler violates this rule (e.g. passing + -- a task object to its controlled Initialize routine). + + if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then + return False; + + -- A variable is always allowed + + elsif Is_Variable (AV) then + return True; + + -- Unchecked conversions are allowed only if they come from the + -- generated code, which sometimes uses unchecked conversions for out + -- parameters in cases where code generation is unaffected. We tell + -- source unchecked conversions by seeing if they are rewrites of an + -- original Unchecked_Conversion function call, or of an explicit + -- conversion of a function call. + + elsif Nkind (AV) = N_Unchecked_Type_Conversion then + if Nkind (Original_Node (AV)) = N_Function_Call then + return False; + + elsif Comes_From_Source (AV) + and then Nkind (Original_Node (Expression (AV))) = N_Function_Call + then + return False; + + elsif Nkind (Original_Node (AV)) = N_Type_Conversion then + return Is_OK_Variable_For_Out_Formal (Expression (AV)); + + else + return True; + end if; + + -- Normal type conversions are allowed if argument is a variable + + elsif Nkind (AV) = N_Type_Conversion then + if Is_Variable (Expression (AV)) + and then Paren_Count (Expression (AV)) = 0 + then + Note_Possible_Modification (Expression (AV), Sure => True); + return True; + + -- We also allow a non-parenthesized expression that raises + -- constraint error if it rewrites what used to be a variable + + elsif Raises_Constraint_Error (Expression (AV)) + and then Paren_Count (Expression (AV)) = 0 + and then Is_Variable (Original_Node (Expression (AV))) + then + return True; + + -- Type conversion of something other than a variable + + else + return False; + end if; + + -- If this node is rewritten, then test the original form, if that is + -- OK, then we consider the rewritten node OK (for example, if the + -- original node is a conversion, then Is_Variable will not be true + -- but we still want to allow the conversion if it converts a variable). + + elsif Original_Node (AV) /= AV then + return Is_OK_Variable_For_Out_Formal (Original_Node (AV)); + + -- All other non-variables are rejected + + else + return False; + end if; + end Is_OK_Variable_For_Out_Formal; + + ----------------------------------- + -- Is_Partially_Initialized_Type -- + ----------------------------------- + + function Is_Partially_Initialized_Type + (Typ : Entity_Id; + Include_Implicit : Boolean := True) return Boolean + is + begin + if Is_Scalar_Type (Typ) then + return False; + + elsif Is_Access_Type (Typ) then + return Include_Implicit; + + elsif Is_Array_Type (Typ) then + + -- If component type is partially initialized, so is array type + + if Is_Partially_Initialized_Type + (Component_Type (Typ), Include_Implicit) + then + return True; + + -- Otherwise we are only partially initialized if we are fully + -- initialized (this is the empty array case, no point in us + -- duplicating that code here). + + else + return Is_Fully_Initialized_Type (Typ); + end if; + + elsif Is_Record_Type (Typ) then + + -- A discriminated type is always partially initialized if in + -- all mode + + if Has_Discriminants (Typ) and then Include_Implicit then + return True; + + -- A tagged type is always partially initialized + + elsif Is_Tagged_Type (Typ) then + return True; + + -- Case of non-discriminated record + + else + declare + Ent : Entity_Id; + + Component_Present : Boolean := False; + -- Set True if at least one component is present. If no + -- components are present, then record type is fully + -- initialized (another odd case, like the null array). + + begin + -- Loop through components + + Ent := First_Entity (Typ); + while Present (Ent) loop + if Ekind (Ent) = E_Component then + Component_Present := True; + + -- If a component has an initialization expression then + -- the enclosing record type is partially initialized + + if Present (Parent (Ent)) + and then Present (Expression (Parent (Ent))) + then + return True; + + -- If a component is of a type which is itself partially + -- initialized, then the enclosing record type is also. + + elsif Is_Partially_Initialized_Type + (Etype (Ent), Include_Implicit) + then + return True; + end if; + end if; + + Next_Entity (Ent); + end loop; + + -- No initialized components found. If we found any components + -- they were all uninitialized so the result is false. + + if Component_Present then + return False; + + -- But if we found no components, then all the components are + -- initialized so we consider the type to be initialized. + + else + return True; + end if; + end; + end if; + + -- Concurrent types are always fully initialized + + elsif Is_Concurrent_Type (Typ) then + return True; + + -- For a private type, go to underlying type. If there is no underlying + -- type then just assume this partially initialized. Not clear if this + -- can happen in a non-error case, but no harm in testing for this. + + elsif Is_Private_Type (Typ) then + declare + U : constant Entity_Id := Underlying_Type (Typ); + begin + if No (U) then + return True; + else + return Is_Partially_Initialized_Type (U, Include_Implicit); + end if; + end; + + -- For any other type (are there any?) assume partially initialized + + else + return True; + end if; + end Is_Partially_Initialized_Type; + + ------------------------------------ + -- Is_Potentially_Persistent_Type -- + ------------------------------------ + + function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is + Comp : Entity_Id; + Indx : Node_Id; + + begin + -- For private type, test corresponding full type + + if Is_Private_Type (T) then + return Is_Potentially_Persistent_Type (Full_View (T)); + + -- Scalar types are potentially persistent + + elsif Is_Scalar_Type (T) then + return True; + + -- Record type is potentially persistent if not tagged and the types of + -- all it components are potentially persistent, and no component has + -- an initialization expression. + + elsif Is_Record_Type (T) + and then not Is_Tagged_Type (T) + and then not Is_Partially_Initialized_Type (T) + then + Comp := First_Component (T); + while Present (Comp) loop + if not Is_Potentially_Persistent_Type (Etype (Comp)) then + return False; + else + Next_Entity (Comp); + end if; + end loop; + + return True; + + -- Array type is potentially persistent if its component type is + -- potentially persistent and if all its constraints are static. + + elsif Is_Array_Type (T) then + if not Is_Potentially_Persistent_Type (Component_Type (T)) then + return False; + end if; + + Indx := First_Index (T); + while Present (Indx) loop + if not Is_OK_Static_Subtype (Etype (Indx)) then + return False; + else + Next_Index (Indx); + end if; + end loop; + + return True; + + -- All other types are not potentially persistent + + else + return False; + end if; + end Is_Potentially_Persistent_Type; + + --------------------------------- + -- Is_Protected_Self_Reference -- + --------------------------------- + + function Is_Protected_Self_Reference (N : Node_Id) return Boolean is + + function In_Access_Definition (N : Node_Id) return Boolean; + -- Returns true if N belongs to an access definition + + -------------------------- + -- In_Access_Definition -- + -------------------------- + + function In_Access_Definition (N : Node_Id) return Boolean is + P : Node_Id; + + begin + P := Parent (N); + while Present (P) loop + if Nkind (P) = N_Access_Definition then + return True; + end if; + + P := Parent (P); + end loop; + + return False; + end In_Access_Definition; + + -- Start of processing for Is_Protected_Self_Reference + + begin + -- Verify that prefix is analyzed and has the proper form. Note that + -- the attributes Elab_Spec, Elab_Body, and UET_Address, which also + -- produce the address of an entity, do not analyze their prefix + -- because they denote entities that are not necessarily visible. + -- Neither of them can apply to a protected type. + + return Ada_Version >= Ada_2005 + and then Is_Entity_Name (N) + and then Present (Entity (N)) + and then Is_Protected_Type (Entity (N)) + and then In_Open_Scopes (Entity (N)) + and then not In_Access_Definition (N); + end Is_Protected_Self_Reference; + + ----------------------------- + -- Is_RCI_Pkg_Spec_Or_Body -- + ----------------------------- + + function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is + + function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean; + -- Return True if the unit of Cunit is an RCI package declaration + + --------------------------- + -- Is_RCI_Pkg_Decl_Cunit -- + --------------------------- + + function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is + The_Unit : constant Node_Id := Unit (Cunit); + + begin + if Nkind (The_Unit) /= N_Package_Declaration then + return False; + end if; + + return Is_Remote_Call_Interface (Defining_Entity (The_Unit)); + end Is_RCI_Pkg_Decl_Cunit; + + -- Start of processing for Is_RCI_Pkg_Spec_Or_Body + + begin + return Is_RCI_Pkg_Decl_Cunit (Cunit) + or else + (Nkind (Unit (Cunit)) = N_Package_Body + and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit))); + end Is_RCI_Pkg_Spec_Or_Body; + + ----------------------------------------- + -- Is_Remote_Access_To_Class_Wide_Type -- + ----------------------------------------- + + function Is_Remote_Access_To_Class_Wide_Type + (E : Entity_Id) return Boolean + is + begin + -- A remote access to class-wide type is a general access to object type + -- declared in the visible part of a Remote_Types or Remote_Call_ + -- Interface unit. + + return Ekind (E) = E_General_Access_Type + and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); + end Is_Remote_Access_To_Class_Wide_Type; + + ----------------------------------------- + -- Is_Remote_Access_To_Subprogram_Type -- + ----------------------------------------- + + function Is_Remote_Access_To_Subprogram_Type + (E : Entity_Id) return Boolean + is + begin + return (Ekind (E) = E_Access_Subprogram_Type + or else (Ekind (E) = E_Record_Type + and then Present (Corresponding_Remote_Type (E)))) + and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); + end Is_Remote_Access_To_Subprogram_Type; + + -------------------- + -- Is_Remote_Call -- + -------------------- + + function Is_Remote_Call (N : Node_Id) return Boolean is + begin + if Nkind (N) /= N_Procedure_Call_Statement + and then Nkind (N) /= N_Function_Call + then + -- An entry call cannot be remote + + return False; + + elsif Nkind (Name (N)) in N_Has_Entity + and then Is_Remote_Call_Interface (Entity (Name (N))) + then + -- A subprogram declared in the spec of a RCI package is remote + + return True; + + elsif Nkind (Name (N)) = N_Explicit_Dereference + and then Is_Remote_Access_To_Subprogram_Type + (Etype (Prefix (Name (N)))) + then + -- The dereference of a RAS is a remote call + + return True; + + elsif Present (Controlling_Argument (N)) + and then Is_Remote_Access_To_Class_Wide_Type + (Etype (Controlling_Argument (N))) + then + -- Any primitive operation call with a controlling argument of + -- a RACW type is a remote call. + + return True; + end if; + + -- All other calls are local calls + + return False; + end Is_Remote_Call; + + ---------------------- + -- Is_Renamed_Entry -- + ---------------------- + + function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is + Orig_Node : Node_Id := Empty; + Subp_Decl : Node_Id := Parent (Parent (Proc_Nam)); + + function Is_Entry (Nam : Node_Id) return Boolean; + -- Determine whether Nam is an entry. Traverse selectors if there are + -- nested selected components. + + -------------- + -- Is_Entry -- + -------------- + + function Is_Entry (Nam : Node_Id) return Boolean is + begin + if Nkind (Nam) = N_Selected_Component then + return Is_Entry (Selector_Name (Nam)); + end if; + + return Ekind (Entity (Nam)) = E_Entry; + end Is_Entry; + + -- Start of processing for Is_Renamed_Entry + + begin + if Present (Alias (Proc_Nam)) then + Subp_Decl := Parent (Parent (Alias (Proc_Nam))); + end if; + + -- Look for a rewritten subprogram renaming declaration + + if Nkind (Subp_Decl) = N_Subprogram_Declaration + and then Present (Original_Node (Subp_Decl)) + then + Orig_Node := Original_Node (Subp_Decl); + end if; + + -- The rewritten subprogram is actually an entry + + if Present (Orig_Node) + and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration + and then Is_Entry (Name (Orig_Node)) + then + return True; + end if; + + return False; + end Is_Renamed_Entry; + + ---------------------- + -- Is_Selector_Name -- + ---------------------- + + function Is_Selector_Name (N : Node_Id) return Boolean is + begin + if not Is_List_Member (N) then + declare + P : constant Node_Id := Parent (N); + K : constant Node_Kind := Nkind (P); + begin + return + (K = N_Expanded_Name or else + K = N_Generic_Association or else + K = N_Parameter_Association or else + K = N_Selected_Component) + and then Selector_Name (P) = N; + end; + + else + declare + L : constant List_Id := List_Containing (N); + P : constant Node_Id := Parent (L); + begin + return (Nkind (P) = N_Discriminant_Association + and then Selector_Names (P) = L) + or else + (Nkind (P) = N_Component_Association + and then Choices (P) = L); + end; + end if; + end Is_Selector_Name; + + ------------------ + -- Is_Statement -- + ------------------ + + function Is_Statement (N : Node_Id) return Boolean is + begin + return + Nkind (N) in N_Statement_Other_Than_Procedure_Call + or else Nkind (N) = N_Procedure_Call_Statement; + end Is_Statement; + + --------------------------------- + -- Is_Synchronized_Tagged_Type -- + --------------------------------- + + function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is + Kind : constant Entity_Kind := Ekind (Base_Type (E)); + + begin + -- A task or protected type derived from an interface is a tagged type. + -- Such a tagged type is called a synchronized tagged type, as are + -- synchronized interfaces and private extensions whose declaration + -- includes the reserved word synchronized. + + return (Is_Tagged_Type (E) + and then (Kind = E_Task_Type + or else Kind = E_Protected_Type)) + or else + (Is_Interface (E) + and then Is_Synchronized_Interface (E)) + or else + (Ekind (E) = E_Record_Type_With_Private + and then (Synchronized_Present (Parent (E)) + or else Is_Synchronized_Interface (Etype (E)))); + end Is_Synchronized_Tagged_Type; + + ----------------- + -- Is_Transfer -- + ----------------- + + function Is_Transfer (N : Node_Id) return Boolean is + Kind : constant Node_Kind := Nkind (N); + + begin + if Kind = N_Simple_Return_Statement + or else + Kind = N_Extended_Return_Statement + or else + Kind = N_Goto_Statement + or else + Kind = N_Raise_Statement + or else + Kind = N_Requeue_Statement + then + return True; + + elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error) + and then No (Condition (N)) + then + return True; + + elsif Kind = N_Procedure_Call_Statement + and then Is_Entity_Name (Name (N)) + and then Present (Entity (Name (N))) + and then No_Return (Entity (Name (N))) + then + return True; + + elsif Nkind (Original_Node (N)) = N_Raise_Statement then + return True; + + else + return False; + end if; + end Is_Transfer; + + ------------- + -- Is_True -- + ------------- + + function Is_True (U : Uint) return Boolean is + begin + return (U /= 0); + end Is_True; + + ------------------------------- + -- Is_Universal_Numeric_Type -- + ------------------------------- + + function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is + begin + return T = Universal_Integer or else T = Universal_Real; + end Is_Universal_Numeric_Type; + + ------------------- + -- Is_Value_Type -- + ------------------- + + function Is_Value_Type (T : Entity_Id) return Boolean is + begin + return VM_Target = CLI_Target + and then Nkind (T) in N_Has_Chars + and then Chars (T) /= No_Name + and then Get_Name_String (Chars (T)) = "valuetype"; + end Is_Value_Type; + + --------------------- + -- Is_VMS_Operator -- + --------------------- + + function Is_VMS_Operator (Op : Entity_Id) return Boolean is + begin + -- The VMS operators are declared in a child of System that is loaded + -- through pragma Extend_System. In some rare cases a program is run + -- with this extension but without indicating that the target is VMS. + + return Ekind (Op) = E_Function + and then Is_Intrinsic_Subprogram (Op) + and then + ((Present_System_Aux + and then Scope (Op) = System_Aux_Id) + or else + (True_VMS_Target + and then Scope (Scope (Op)) = RTU_Entity (System))); + end Is_VMS_Operator; + + ----------------- + -- Is_Variable -- + ----------------- + + function Is_Variable (N : Node_Id) return Boolean is + + Orig_Node : constant Node_Id := Original_Node (N); + -- We do the test on the original node, since this is basically a test + -- of syntactic categories, so it must not be disturbed by whatever + -- rewriting might have occurred. For example, an aggregate, which is + -- certainly NOT a variable, could be turned into a variable by + -- expansion. + + function In_Protected_Function (E : Entity_Id) return Boolean; + -- Within a protected function, the private components of the enclosing + -- protected type are constants. A function nested within a (protected) + -- procedure is not itself protected. + + function Is_Variable_Prefix (P : Node_Id) return Boolean; + -- Prefixes can involve implicit dereferences, in which case we must + -- test for the case of a reference of a constant access type, which can + -- can never be a variable. + + --------------------------- + -- In_Protected_Function -- + --------------------------- + + function In_Protected_Function (E : Entity_Id) return Boolean is + Prot : constant Entity_Id := Scope (E); + S : Entity_Id; + + begin + if not Is_Protected_Type (Prot) then + return False; + else + S := Current_Scope; + while Present (S) and then S /= Prot loop + if Ekind (S) = E_Function and then Scope (S) = Prot then + return True; + end if; + + S := Scope (S); + end loop; + + return False; + end if; + end In_Protected_Function; + + ------------------------ + -- Is_Variable_Prefix -- + ------------------------ + + function Is_Variable_Prefix (P : Node_Id) return Boolean is + begin + if Is_Access_Type (Etype (P)) then + return not Is_Access_Constant (Root_Type (Etype (P))); + + -- For the case of an indexed component whose prefix has a packed + -- array type, the prefix has been rewritten into a type conversion. + -- Determine variable-ness from the converted expression. + + elsif Nkind (P) = N_Type_Conversion + and then not Comes_From_Source (P) + and then Is_Array_Type (Etype (P)) + and then Is_Packed (Etype (P)) + then + return Is_Variable (Expression (P)); + + else + return Is_Variable (P); + end if; + end Is_Variable_Prefix; + + -- Start of processing for Is_Variable + + begin + -- Definitely OK if Assignment_OK is set. Since this is something that + -- only gets set for expanded nodes, the test is on N, not Orig_Node. + + if Nkind (N) in N_Subexpr and then Assignment_OK (N) then + return True; + + -- Normally we go to the original node, but there is one exception where + -- we use the rewritten node, namely when it is an explicit dereference. + -- The generated code may rewrite a prefix which is an access type with + -- an explicit dereference. The dereference is a variable, even though + -- the original node may not be (since it could be a constant of the + -- access type). + + -- In Ada 2005 we have a further case to consider: the prefix may be a + -- function call given in prefix notation. The original node appears to + -- be a selected component, but we need to examine the call. + + elsif Nkind (N) = N_Explicit_Dereference + and then Nkind (Orig_Node) /= N_Explicit_Dereference + and then Present (Etype (Orig_Node)) + and then Is_Access_Type (Etype (Orig_Node)) + then + -- Note that if the prefix is an explicit dereference that does not + -- come from source, we must check for a rewritten function call in + -- prefixed notation before other forms of rewriting, to prevent a + -- compiler crash. + + return + (Nkind (Orig_Node) = N_Function_Call + and then not Is_Access_Constant (Etype (Prefix (N)))) + or else + Is_Variable_Prefix (Original_Node (Prefix (N))); + + -- A function call is never a variable + + elsif Nkind (N) = N_Function_Call then + return False; + + -- All remaining checks use the original node + + elsif Is_Entity_Name (Orig_Node) + and then Present (Entity (Orig_Node)) + then + declare + E : constant Entity_Id := Entity (Orig_Node); + K : constant Entity_Kind := Ekind (E); + + begin + return (K = E_Variable + and then Nkind (Parent (E)) /= N_Exception_Handler) + or else (K = E_Component + and then not In_Protected_Function (E)) + or else K = E_Out_Parameter + or else K = E_In_Out_Parameter + or else K = E_Generic_In_Out_Parameter + + -- Current instance of type: + + or else (Is_Type (E) and then In_Open_Scopes (E)) + or else (Is_Incomplete_Or_Private_Type (E) + and then In_Open_Scopes (Full_View (E))); + end; + + else + case Nkind (Orig_Node) is + when N_Indexed_Component | N_Slice => + return Is_Variable_Prefix (Prefix (Orig_Node)); + + when N_Selected_Component => + return Is_Variable_Prefix (Prefix (Orig_Node)) + and then Is_Variable (Selector_Name (Orig_Node)); + + -- For an explicit dereference, the type of the prefix cannot + -- be an access to constant or an access to subprogram. + + when N_Explicit_Dereference => + declare + Typ : constant Entity_Id := Etype (Prefix (Orig_Node)); + begin + return Is_Access_Type (Typ) + and then not Is_Access_Constant (Root_Type (Typ)) + and then Ekind (Typ) /= E_Access_Subprogram_Type; + end; + + -- The type conversion is the case where we do not deal with the + -- context dependent special case of an actual parameter. Thus + -- the type conversion is only considered a variable for the + -- purposes of this routine if the target type is tagged. However, + -- a type conversion is considered to be a variable if it does not + -- come from source (this deals for example with the conversions + -- of expressions to their actual subtypes). + + when N_Type_Conversion => + return Is_Variable (Expression (Orig_Node)) + and then + (not Comes_From_Source (Orig_Node) + or else + (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node))) + and then + Is_Tagged_Type (Etype (Expression (Orig_Node))))); + + -- GNAT allows an unchecked type conversion as a variable. This + -- only affects the generation of internal expanded code, since + -- calls to instantiations of Unchecked_Conversion are never + -- considered variables (since they are function calls). + -- This is also true for expression actions. + + when N_Unchecked_Type_Conversion => + return Is_Variable (Expression (Orig_Node)); + + when others => + return False; + end case; + end if; + end Is_Variable; + + --------------------------- + -- Is_Visibly_Controlled -- + --------------------------- + + function Is_Visibly_Controlled (T : Entity_Id) return Boolean is + Root : constant Entity_Id := Root_Type (T); + begin + return Chars (Scope (Root)) = Name_Finalization + and then Chars (Scope (Scope (Root))) = Name_Ada + and then Scope (Scope (Scope (Root))) = Standard_Standard; + end Is_Visibly_Controlled; + + ------------------------ + -- Is_Volatile_Object -- + ------------------------ + + function Is_Volatile_Object (N : Node_Id) return Boolean is + + function Object_Has_Volatile_Components (N : Node_Id) return Boolean; + -- Determines if given object has volatile components + + function Is_Volatile_Prefix (N : Node_Id) return Boolean; + -- If prefix is an implicit dereference, examine designated type + + ------------------------ + -- Is_Volatile_Prefix -- + ------------------------ + + function Is_Volatile_Prefix (N : Node_Id) return Boolean is + Typ : constant Entity_Id := Etype (N); + + begin + if Is_Access_Type (Typ) then + declare + Dtyp : constant Entity_Id := Designated_Type (Typ); + + begin + return Is_Volatile (Dtyp) + or else Has_Volatile_Components (Dtyp); + end; + + else + return Object_Has_Volatile_Components (N); + end if; + end Is_Volatile_Prefix; + + ------------------------------------ + -- Object_Has_Volatile_Components -- + ------------------------------------ + + function Object_Has_Volatile_Components (N : Node_Id) return Boolean is + Typ : constant Entity_Id := Etype (N); + + begin + if Is_Volatile (Typ) + or else Has_Volatile_Components (Typ) + then + return True; + + elsif Is_Entity_Name (N) + and then (Has_Volatile_Components (Entity (N)) + or else Is_Volatile (Entity (N))) + then + return True; + + elsif Nkind (N) = N_Indexed_Component + or else Nkind (N) = N_Selected_Component + then + return Is_Volatile_Prefix (Prefix (N)); + + else + return False; + end if; + end Object_Has_Volatile_Components; + + -- Start of processing for Is_Volatile_Object + + begin + if Is_Volatile (Etype (N)) + or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N))) + then + return True; + + elsif Nkind (N) = N_Indexed_Component + or else Nkind (N) = N_Selected_Component + then + return Is_Volatile_Prefix (Prefix (N)); + + else + return False; + end if; + end Is_Volatile_Object; + + ------------------------- + -- Kill_Current_Values -- + ------------------------- + + procedure Kill_Current_Values + (Ent : Entity_Id; + Last_Assignment_Only : Boolean := False) + is + begin + -- ??? do we have to worry about clearing cached checks? + + if Is_Assignable (Ent) then + Set_Last_Assignment (Ent, Empty); + end if; + + if Is_Object (Ent) then + if not Last_Assignment_Only then + Kill_Checks (Ent); + Set_Current_Value (Ent, Empty); + + if not Can_Never_Be_Null (Ent) then + Set_Is_Known_Non_Null (Ent, False); + end if; + + Set_Is_Known_Null (Ent, False); + + -- Reset Is_Known_Valid unless type is always valid, or if we have + -- a loop parameter (loop parameters are always valid, since their + -- bounds are defined by the bounds given in the loop header). + + if not Is_Known_Valid (Etype (Ent)) + and then Ekind (Ent) /= E_Loop_Parameter + then + Set_Is_Known_Valid (Ent, False); + end if; + end if; + end if; + end Kill_Current_Values; + + procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is + S : Entity_Id; + + procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id); + -- Clear current value for entity E and all entities chained to E + + ------------------------------------------ + -- Kill_Current_Values_For_Entity_Chain -- + ------------------------------------------ + + procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is + Ent : Entity_Id; + begin + Ent := E; + while Present (Ent) loop + Kill_Current_Values (Ent, Last_Assignment_Only); + Next_Entity (Ent); + end loop; + end Kill_Current_Values_For_Entity_Chain; + + -- Start of processing for Kill_Current_Values + + begin + -- Kill all saved checks, a special case of killing saved values + + if not Last_Assignment_Only then + Kill_All_Checks; + end if; + + -- Loop through relevant scopes, which includes the current scope and + -- any parent scopes if the current scope is a block or a package. + + S := Current_Scope; + Scope_Loop : loop + + -- Clear current values of all entities in current scope + + Kill_Current_Values_For_Entity_Chain (First_Entity (S)); + + -- If scope is a package, also clear current values of all + -- private entities in the scope. + + if Is_Package_Or_Generic_Package (S) + or else Is_Concurrent_Type (S) + then + Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S)); + end if; + + -- If this is a not a subprogram, deal with parents + + if not Is_Subprogram (S) then + S := Scope (S); + exit Scope_Loop when S = Standard_Standard; + else + exit Scope_Loop; + end if; + end loop Scope_Loop; + end Kill_Current_Values; + + -------------------------- + -- Kill_Size_Check_Code -- + -------------------------- + + procedure Kill_Size_Check_Code (E : Entity_Id) is + begin + if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) + and then Present (Size_Check_Code (E)) + then + Remove (Size_Check_Code (E)); + Set_Size_Check_Code (E, Empty); + end if; + end Kill_Size_Check_Code; + + -------------------------- + -- Known_To_Be_Assigned -- + -------------------------- + + function Known_To_Be_Assigned (N : Node_Id) return Boolean is + P : constant Node_Id := Parent (N); + + begin + case Nkind (P) is + + -- Test left side of assignment + + when N_Assignment_Statement => + return N = Name (P); + + -- Function call arguments are never lvalues + + when N_Function_Call => + return False; + + -- Positional parameter for procedure or accept call + + when N_Procedure_Call_Statement | + N_Accept_Statement + => + declare + Proc : Entity_Id; + Form : Entity_Id; + Act : Node_Id; + + begin + Proc := Get_Subprogram_Entity (P); + + if No (Proc) then + return False; + end if; + + -- If we are not a list member, something is strange, so + -- be conservative and return False. + + if not Is_List_Member (N) then + return False; + end if; + + -- We are going to find the right formal by stepping forward + -- through the formals, as we step backwards in the actuals. + + Form := First_Formal (Proc); + Act := N; + loop + -- If no formal, something is weird, so be conservative + -- and return False. + + if No (Form) then + return False; + end if; + + Prev (Act); + exit when No (Act); + Next_Formal (Form); + end loop; + + return Ekind (Form) /= E_In_Parameter; + end; + + -- Named parameter for procedure or accept call + + when N_Parameter_Association => + declare + Proc : Entity_Id; + Form : Entity_Id; + + begin + Proc := Get_Subprogram_Entity (Parent (P)); + + if No (Proc) then + return False; + end if; + + -- Loop through formals to find the one that matches + + Form := First_Formal (Proc); + loop + -- If no matching formal, that's peculiar, some kind of + -- previous error, so return False to be conservative. + + if No (Form) then + return False; + end if; + + -- Else test for match + + if Chars (Form) = Chars (Selector_Name (P)) then + return Ekind (Form) /= E_In_Parameter; + end if; + + Next_Formal (Form); + end loop; + end; + + -- Test for appearing in a conversion that itself appears + -- in an lvalue context, since this should be an lvalue. + + when N_Type_Conversion => + return Known_To_Be_Assigned (P); + + -- All other references are definitely not known to be modifications + + when others => + return False; + + end case; + end Known_To_Be_Assigned; + + ------------------- + -- May_Be_Lvalue -- + ------------------- + + function May_Be_Lvalue (N : Node_Id) return Boolean is + P : constant Node_Id := Parent (N); + + begin + case Nkind (P) is + + -- Test left side of assignment + + when N_Assignment_Statement => + return N = Name (P); + + -- Test prefix of component or attribute. Note that the prefix of an + -- explicit or implicit dereference cannot be an l-value. + + when N_Attribute_Reference => + return N = Prefix (P) + and then Name_Implies_Lvalue_Prefix (Attribute_Name (P)); + + -- For an expanded name, the name is an lvalue if the expanded name + -- is an lvalue, but the prefix is never an lvalue, since it is just + -- the scope where the name is found. + + when N_Expanded_Name => + if N = Prefix (P) then + return May_Be_Lvalue (P); + else + return False; + end if; + + -- For a selected component A.B, A is certainly an lvalue if A.B is. + -- B is a little interesting, if we have A.B := 3, there is some + -- discussion as to whether B is an lvalue or not, we choose to say + -- it is. Note however that A is not an lvalue if it is of an access + -- type since this is an implicit dereference. + + when N_Selected_Component => + if N = Prefix (P) + and then Present (Etype (N)) + and then Is_Access_Type (Etype (N)) + then + return False; + else + return May_Be_Lvalue (P); + end if; + + -- For an indexed component or slice, the index or slice bounds is + -- never an lvalue. The prefix is an lvalue if the indexed component + -- or slice is an lvalue, except if it is an access type, where we + -- have an implicit dereference. + + when N_Indexed_Component => + if N /= Prefix (P) + or else (Present (Etype (N)) and then Is_Access_Type (Etype (N))) + then + return False; + else + return May_Be_Lvalue (P); + end if; + + -- Prefix of a reference is an lvalue if the reference is an lvalue + + when N_Reference => + return May_Be_Lvalue (P); + + -- Prefix of explicit dereference is never an lvalue + + when N_Explicit_Dereference => + return False; + + -- Positional parameter for subprogram, entry, or accept call. + -- In older versions of Ada function call arguments are never + -- lvalues. In Ada 2012 functions can have in-out parameters. + + when N_Function_Call | + N_Procedure_Call_Statement | + N_Entry_Call_Statement | + N_Accept_Statement + => + if Nkind (P) = N_Function_Call + and then Ada_Version < Ada_2012 + then + return False; + end if; + + -- The following mechanism is clumsy and fragile. A single + -- flag set in Resolve_Actuals would be preferable ??? + + declare + Proc : Entity_Id; + Form : Entity_Id; + Act : Node_Id; + + begin + Proc := Get_Subprogram_Entity (P); + + if No (Proc) then + return True; + end if; + + -- If we are not a list member, something is strange, so + -- be conservative and return True. + + if not Is_List_Member (N) then + return True; + end if; + + -- We are going to find the right formal by stepping forward + -- through the formals, as we step backwards in the actuals. + + Form := First_Formal (Proc); + Act := N; + loop + -- If no formal, something is weird, so be conservative + -- and return True. + + if No (Form) then + return True; + end if; + + Prev (Act); + exit when No (Act); + Next_Formal (Form); + end loop; + + return Ekind (Form) /= E_In_Parameter; + end; + + -- Named parameter for procedure or accept call + + when N_Parameter_Association => + declare + Proc : Entity_Id; + Form : Entity_Id; + + begin + Proc := Get_Subprogram_Entity (Parent (P)); + + if No (Proc) then + return True; + end if; + + -- Loop through formals to find the one that matches + + Form := First_Formal (Proc); + loop + -- If no matching formal, that's peculiar, some kind of + -- previous error, so return True to be conservative. + + if No (Form) then + return True; + end if; + + -- Else test for match + + if Chars (Form) = Chars (Selector_Name (P)) then + return Ekind (Form) /= E_In_Parameter; + end if; + + Next_Formal (Form); + end loop; + end; + + -- Test for appearing in a conversion that itself appears in an + -- lvalue context, since this should be an lvalue. + + when N_Type_Conversion => + return May_Be_Lvalue (P); + + -- Test for appearance in object renaming declaration + + when N_Object_Renaming_Declaration => + return True; + + -- All other references are definitely not lvalues + + when others => + return False; + + end case; + end May_Be_Lvalue; + + ----------------------- + -- Mark_Coextensions -- + ----------------------- + + procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is + Is_Dynamic : Boolean; + -- Indicates whether the context causes nested coextensions to be + -- dynamic or static + + function Mark_Allocator (N : Node_Id) return Traverse_Result; + -- Recognize an allocator node and label it as a dynamic coextension + + -------------------- + -- Mark_Allocator -- + -------------------- + + function Mark_Allocator (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Allocator then + if Is_Dynamic then + Set_Is_Dynamic_Coextension (N); + + -- If the allocator expression is potentially dynamic, it may + -- be expanded out of order and require dynamic allocation + -- anyway, so we treat the coextension itself as dynamic. + -- Potential optimization ??? + + elsif Nkind (Expression (N)) = N_Qualified_Expression + and then Nkind (Expression (Expression (N))) = N_Op_Concat + then + Set_Is_Dynamic_Coextension (N); + + else + Set_Is_Static_Coextension (N); + end if; + end if; + + return OK; + end Mark_Allocator; + + procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator); + + -- Start of processing Mark_Coextensions + + begin + case Nkind (Context_Nod) is + when N_Assignment_Statement | + N_Simple_Return_Statement => + Is_Dynamic := Nkind (Expression (Context_Nod)) = N_Allocator; + + when N_Object_Declaration => + Is_Dynamic := Nkind (Root_Nod) = N_Allocator; + + -- This routine should not be called for constructs which may not + -- contain coextensions. + + when others => + raise Program_Error; + end case; + + Mark_Allocators (Root_Nod); + end Mark_Coextensions; + + ---------------------- + -- Needs_One_Actual -- + ---------------------- + + function Needs_One_Actual (E : Entity_Id) return Boolean is + Formal : Entity_Id; + + begin + if Ada_Version >= Ada_2005 + and then Present (First_Formal (E)) + then + Formal := Next_Formal (First_Formal (E)); + while Present (Formal) loop + if No (Default_Value (Formal)) then + return False; + end if; + + Next_Formal (Formal); + end loop; + + return True; + + else + return False; + end if; + end Needs_One_Actual; + + ------------------------ + -- New_Copy_List_Tree -- + ------------------------ + + function New_Copy_List_Tree (List : List_Id) return List_Id is + NL : List_Id; + E : Node_Id; + + begin + if List = No_List then + return No_List; + + else + NL := New_List; + E := First (List); + + while Present (E) loop + Append (New_Copy_Tree (E), NL); + E := Next (E); + end loop; + + return NL; + end if; + end New_Copy_List_Tree; + + ------------------- + -- New_Copy_Tree -- + ------------------- + + use Atree.Unchecked_Access; + use Atree_Private_Part; + + -- Our approach here requires a two pass traversal of the tree. The + -- first pass visits all nodes that eventually will be copied looking + -- for defining Itypes. If any defining Itypes are found, then they are + -- copied, and an entry is added to the replacement map. In the second + -- phase, the tree is copied, using the replacement map to replace any + -- Itype references within the copied tree. + + -- The following hash tables are used if the Map supplied has more + -- than hash threshold entries to speed up access to the map. If + -- there are fewer entries, then the map is searched sequentially + -- (because setting up a hash table for only a few entries takes + -- more time than it saves. + + function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num; + -- Hash function used for hash operations + + ------------------- + -- New_Copy_Hash -- + ------------------- + + function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is + begin + return Nat (E) mod (NCT_Header_Num'Last + 1); + end New_Copy_Hash; + + --------------- + -- NCT_Assoc -- + --------------- + + -- The hash table NCT_Assoc associates old entities in the table + -- with their corresponding new entities (i.e. the pairs of entries + -- presented in the original Map argument are Key-Element pairs). + + package NCT_Assoc is new Simple_HTable ( + Header_Num => NCT_Header_Num, + Element => Entity_Id, + No_Element => Empty, + Key => Entity_Id, + Hash => New_Copy_Hash, + Equal => Types."="); + + --------------------- + -- NCT_Itype_Assoc -- + --------------------- + + -- The hash table NCT_Itype_Assoc contains entries only for those + -- old nodes which have a non-empty Associated_Node_For_Itype set. + -- The key is the associated node, and the element is the new node + -- itself (NOT the associated node for the new node). + + package NCT_Itype_Assoc is new Simple_HTable ( + Header_Num => NCT_Header_Num, + Element => Entity_Id, + No_Element => Empty, + Key => Entity_Id, + Hash => New_Copy_Hash, + Equal => Types."="); + + -- Start of processing for New_Copy_Tree function + + function New_Copy_Tree + (Source : Node_Id; + Map : Elist_Id := No_Elist; + New_Sloc : Source_Ptr := No_Location; + New_Scope : Entity_Id := Empty) return Node_Id + is + Actual_Map : Elist_Id := Map; + -- This is the actual map for the copy. It is initialized with the + -- given elements, and then enlarged as required for Itypes that are + -- copied during the first phase of the copy operation. The visit + -- procedures add elements to this map as Itypes are encountered. + -- The reason we cannot use Map directly, is that it may well be + -- (and normally is) initialized to No_Elist, and if we have mapped + -- entities, we have to reset it to point to a real Elist. + + function Assoc (N : Node_Or_Entity_Id) return Node_Id; + -- Called during second phase to map entities into their corresponding + -- copies using Actual_Map. If the argument is not an entity, or is not + -- in Actual_Map, then it is returned unchanged. + + procedure Build_NCT_Hash_Tables; + -- Builds hash tables (number of elements >= threshold value) + + function Copy_Elist_With_Replacement + (Old_Elist : Elist_Id) return Elist_Id; + -- Called during second phase to copy element list doing replacements + + procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id); + -- Called during the second phase to process a copied Itype. The actual + -- copy happened during the first phase (so that we could make the entry + -- in the mapping), but we still have to deal with the descendents of + -- the copied Itype and copy them where necessary. + + function Copy_List_With_Replacement (Old_List : List_Id) return List_Id; + -- Called during second phase to copy list doing replacements + + function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id; + -- Called during second phase to copy node doing replacements + + procedure Visit_Elist (E : Elist_Id); + -- Called during first phase to visit all elements of an Elist + + procedure Visit_Field (F : Union_Id; N : Node_Id); + -- Visit a single field, recursing to call Visit_Node or Visit_List + -- if the field is a syntactic descendent of the current node (i.e. + -- its parent is Node N). + + procedure Visit_Itype (Old_Itype : Entity_Id); + -- Called during first phase to visit subsidiary fields of a defining + -- Itype, and also create a copy and make an entry in the replacement + -- map for the new copy. + + procedure Visit_List (L : List_Id); + -- Called during first phase to visit all elements of a List + + procedure Visit_Node (N : Node_Or_Entity_Id); + -- Called during first phase to visit a node and all its subtrees + + ----------- + -- Assoc -- + ----------- + + function Assoc (N : Node_Or_Entity_Id) return Node_Id is + E : Elmt_Id; + Ent : Entity_Id; + + begin + if not Has_Extension (N) or else No (Actual_Map) then + return N; + + elsif NCT_Hash_Tables_Used then + Ent := NCT_Assoc.Get (Entity_Id (N)); + + if Present (Ent) then + return Ent; + else + return N; + end if; + + -- No hash table used, do serial search + + else + E := First_Elmt (Actual_Map); + while Present (E) loop + if Node (E) = N then + return Node (Next_Elmt (E)); + else + E := Next_Elmt (Next_Elmt (E)); + end if; + end loop; + end if; + + return N; + end Assoc; + + --------------------------- + -- Build_NCT_Hash_Tables -- + --------------------------- + + procedure Build_NCT_Hash_Tables is + Elmt : Elmt_Id; + Ent : Entity_Id; + begin + if NCT_Hash_Table_Setup then + NCT_Assoc.Reset; + NCT_Itype_Assoc.Reset; + end if; + + Elmt := First_Elmt (Actual_Map); + while Present (Elmt) loop + Ent := Node (Elmt); + + -- Get new entity, and associate old and new + + Next_Elmt (Elmt); + NCT_Assoc.Set (Ent, Node (Elmt)); + + if Is_Type (Ent) then + declare + Anode : constant Entity_Id := + Associated_Node_For_Itype (Ent); + + begin + if Present (Anode) then + + -- Enter a link between the associated node of the + -- old Itype and the new Itype, for updating later + -- when node is copied. + + NCT_Itype_Assoc.Set (Anode, Node (Elmt)); + end if; + end; + end if; + + Next_Elmt (Elmt); + end loop; + + NCT_Hash_Tables_Used := True; + NCT_Hash_Table_Setup := True; + end Build_NCT_Hash_Tables; + + --------------------------------- + -- Copy_Elist_With_Replacement -- + --------------------------------- + + function Copy_Elist_With_Replacement + (Old_Elist : Elist_Id) return Elist_Id + is + M : Elmt_Id; + New_Elist : Elist_Id; + + begin + if No (Old_Elist) then + return No_Elist; + + else + New_Elist := New_Elmt_List; + + M := First_Elmt (Old_Elist); + while Present (M) loop + Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist); + Next_Elmt (M); + end loop; + end if; + + return New_Elist; + end Copy_Elist_With_Replacement; + + --------------------------------- + -- Copy_Itype_With_Replacement -- + --------------------------------- + + -- This routine exactly parallels its phase one analog Visit_Itype, + + procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is + begin + -- Translate Next_Entity, Scope and Etype fields, in case they + -- reference entities that have been mapped into copies. + + Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype))); + Set_Etype (New_Itype, Assoc (Etype (New_Itype))); + + if Present (New_Scope) then + Set_Scope (New_Itype, New_Scope); + else + Set_Scope (New_Itype, Assoc (Scope (New_Itype))); + end if; + + -- Copy referenced fields + + if Is_Discrete_Type (New_Itype) then + Set_Scalar_Range (New_Itype, + Copy_Node_With_Replacement (Scalar_Range (New_Itype))); + + elsif Has_Discriminants (Base_Type (New_Itype)) then + Set_Discriminant_Constraint (New_Itype, + Copy_Elist_With_Replacement + (Discriminant_Constraint (New_Itype))); + + elsif Is_Array_Type (New_Itype) then + if Present (First_Index (New_Itype)) then + Set_First_Index (New_Itype, + First (Copy_List_With_Replacement + (List_Containing (First_Index (New_Itype))))); + end if; + + if Is_Packed (New_Itype) then + Set_Packed_Array_Type (New_Itype, + Copy_Node_With_Replacement + (Packed_Array_Type (New_Itype))); + end if; + end if; + end Copy_Itype_With_Replacement; + + -------------------------------- + -- Copy_List_With_Replacement -- + -------------------------------- + + function Copy_List_With_Replacement + (Old_List : List_Id) return List_Id + is + New_List : List_Id; + E : Node_Id; + + begin + if Old_List = No_List then + return No_List; + + else + New_List := Empty_List; + + E := First (Old_List); + while Present (E) loop + Append (Copy_Node_With_Replacement (E), New_List); + Next (E); + end loop; + + return New_List; + end if; + end Copy_List_With_Replacement; + + -------------------------------- + -- Copy_Node_With_Replacement -- + -------------------------------- + + function Copy_Node_With_Replacement + (Old_Node : Node_Id) return Node_Id + is + New_Node : Node_Id; + + procedure Adjust_Named_Associations + (Old_Node : Node_Id; + New_Node : Node_Id); + -- If a call node has named associations, these are chained through + -- the First_Named_Actual, Next_Named_Actual links. These must be + -- propagated separately to the new parameter list, because these + -- are not syntactic fields. + + function Copy_Field_With_Replacement + (Field : Union_Id) return Union_Id; + -- Given Field, which is a field of Old_Node, return a copy of it + -- if it is a syntactic field (i.e. its parent is Node), setting + -- the parent of the copy to poit to New_Node. Otherwise returns + -- the field (possibly mapped if it is an entity). + + ------------------------------- + -- Adjust_Named_Associations -- + ------------------------------- + + procedure Adjust_Named_Associations + (Old_Node : Node_Id; + New_Node : Node_Id) + is + Old_E : Node_Id; + New_E : Node_Id; + + Old_Next : Node_Id; + New_Next : Node_Id; + + begin + Old_E := First (Parameter_Associations (Old_Node)); + New_E := First (Parameter_Associations (New_Node)); + while Present (Old_E) loop + if Nkind (Old_E) = N_Parameter_Association + and then Present (Next_Named_Actual (Old_E)) + then + if First_Named_Actual (Old_Node) + = Explicit_Actual_Parameter (Old_E) + then + Set_First_Named_Actual + (New_Node, Explicit_Actual_Parameter (New_E)); + end if; + + -- Now scan parameter list from the beginning,to locate + -- next named actual, which can be out of order. + + Old_Next := First (Parameter_Associations (Old_Node)); + New_Next := First (Parameter_Associations (New_Node)); + + while Nkind (Old_Next) /= N_Parameter_Association + or else Explicit_Actual_Parameter (Old_Next) + /= Next_Named_Actual (Old_E) + loop + Next (Old_Next); + Next (New_Next); + end loop; + + Set_Next_Named_Actual + (New_E, Explicit_Actual_Parameter (New_Next)); + end if; + + Next (Old_E); + Next (New_E); + end loop; + end Adjust_Named_Associations; + + --------------------------------- + -- Copy_Field_With_Replacement -- + --------------------------------- + + function Copy_Field_With_Replacement + (Field : Union_Id) return Union_Id + is + begin + if Field = Union_Id (Empty) then + return Field; + + elsif Field in Node_Range then + declare + Old_N : constant Node_Id := Node_Id (Field); + New_N : Node_Id; + + begin + -- If syntactic field, as indicated by the parent pointer + -- being set, then copy the referenced node recursively. + + if Parent (Old_N) = Old_Node then + New_N := Copy_Node_With_Replacement (Old_N); + + if New_N /= Old_N then + Set_Parent (New_N, New_Node); + end if; + + -- For semantic fields, update possible entity reference + -- from the replacement map. + + else + New_N := Assoc (Old_N); + end if; + + return Union_Id (New_N); + end; + + elsif Field in List_Range then + declare + Old_L : constant List_Id := List_Id (Field); + New_L : List_Id; + + begin + -- If syntactic field, as indicated by the parent pointer, + -- then recursively copy the entire referenced list. + + if Parent (Old_L) = Old_Node then + New_L := Copy_List_With_Replacement (Old_L); + Set_Parent (New_L, New_Node); + + -- For semantic list, just returned unchanged + + else + New_L := Old_L; + end if; + + return Union_Id (New_L); + end; + + -- Anything other than a list or a node is returned unchanged + + else + return Field; + end if; + end Copy_Field_With_Replacement; + + -- Start of processing for Copy_Node_With_Replacement + + begin + if Old_Node <= Empty_Or_Error then + return Old_Node; + + elsif Has_Extension (Old_Node) then + return Assoc (Old_Node); + + else + New_Node := New_Copy (Old_Node); + + -- If the node we are copying is the associated node of a + -- previously copied Itype, then adjust the associated node + -- of the copy of that Itype accordingly. + + if Present (Actual_Map) then + declare + E : Elmt_Id; + Ent : Entity_Id; + + begin + -- Case of hash table used + + if NCT_Hash_Tables_Used then + Ent := NCT_Itype_Assoc.Get (Old_Node); + + if Present (Ent) then + Set_Associated_Node_For_Itype (Ent, New_Node); + end if; + + -- Case of no hash table used + + else + E := First_Elmt (Actual_Map); + while Present (E) loop + if Is_Itype (Node (E)) + and then + Old_Node = Associated_Node_For_Itype (Node (E)) + then + Set_Associated_Node_For_Itype + (Node (Next_Elmt (E)), New_Node); + end if; + + E := Next_Elmt (Next_Elmt (E)); + end loop; + end if; + end; + end if; + + -- Recursively copy descendents + + Set_Field1 + (New_Node, Copy_Field_With_Replacement (Field1 (New_Node))); + Set_Field2 + (New_Node, Copy_Field_With_Replacement (Field2 (New_Node))); + Set_Field3 + (New_Node, Copy_Field_With_Replacement (Field3 (New_Node))); + Set_Field4 + (New_Node, Copy_Field_With_Replacement (Field4 (New_Node))); + Set_Field5 + (New_Node, Copy_Field_With_Replacement (Field5 (New_Node))); + + -- Adjust Sloc of new node if necessary + + if New_Sloc /= No_Location then + Set_Sloc (New_Node, New_Sloc); + + -- If we adjust the Sloc, then we are essentially making + -- a completely new node, so the Comes_From_Source flag + -- should be reset to the proper default value. + + Nodes.Table (New_Node).Comes_From_Source := + Default_Node.Comes_From_Source; + end if; + + -- If the node is call and has named associations, + -- set the corresponding links in the copy. + + if (Nkind (Old_Node) = N_Function_Call + or else Nkind (Old_Node) = N_Entry_Call_Statement + or else + Nkind (Old_Node) = N_Procedure_Call_Statement) + and then Present (First_Named_Actual (Old_Node)) + then + Adjust_Named_Associations (Old_Node, New_Node); + end if; + + -- Reset First_Real_Statement for Handled_Sequence_Of_Statements. + -- The replacement mechanism applies to entities, and is not used + -- here. Eventually we may need a more general graph-copying + -- routine. For now, do a sequential search to find desired node. + + if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements + and then Present (First_Real_Statement (Old_Node)) + then + declare + Old_F : constant Node_Id := First_Real_Statement (Old_Node); + N1, N2 : Node_Id; + + begin + N1 := First (Statements (Old_Node)); + N2 := First (Statements (New_Node)); + + while N1 /= Old_F loop + Next (N1); + Next (N2); + end loop; + + Set_First_Real_Statement (New_Node, N2); + end; + end if; + end if; + + -- All done, return copied node + + return New_Node; + end Copy_Node_With_Replacement; + + ----------------- + -- Visit_Elist -- + ----------------- + + procedure Visit_Elist (E : Elist_Id) is + Elmt : Elmt_Id; + begin + if Present (E) then + Elmt := First_Elmt (E); + + while Elmt /= No_Elmt loop + Visit_Node (Node (Elmt)); + Next_Elmt (Elmt); + end loop; + end if; + end Visit_Elist; + + ----------------- + -- Visit_Field -- + ----------------- + + procedure Visit_Field (F : Union_Id; N : Node_Id) is + begin + if F = Union_Id (Empty) then + return; + + elsif F in Node_Range then + + -- Copy node if it is syntactic, i.e. its parent pointer is + -- set to point to the field that referenced it (certain + -- Itypes will also meet this criterion, which is fine, since + -- these are clearly Itypes that do need to be copied, since + -- we are copying their parent.) + + if Parent (Node_Id (F)) = N then + Visit_Node (Node_Id (F)); + return; + + -- Another case, if we are pointing to an Itype, then we want + -- to copy it if its associated node is somewhere in the tree + -- being copied. + + -- Note: the exclusion of self-referential copies is just an + -- optimization, since the search of the already copied list + -- would catch it, but it is a common case (Etype pointing + -- to itself for an Itype that is a base type). + + elsif Has_Extension (Node_Id (F)) + and then Is_Itype (Entity_Id (F)) + and then Node_Id (F) /= N + then + declare + P : Node_Id; + + begin + P := Associated_Node_For_Itype (Node_Id (F)); + while Present (P) loop + if P = Source then + Visit_Node (Node_Id (F)); + return; + else + P := Parent (P); + end if; + end loop; + + -- An Itype whose parent is not being copied definitely + -- should NOT be copied, since it does not belong in any + -- sense to the copied subtree. + + return; + end; + end if; + + elsif F in List_Range + and then Parent (List_Id (F)) = N + then + Visit_List (List_Id (F)); + return; + end if; + end Visit_Field; + + ----------------- + -- Visit_Itype -- + ----------------- + + procedure Visit_Itype (Old_Itype : Entity_Id) is + New_Itype : Entity_Id; + E : Elmt_Id; + Ent : Entity_Id; + + begin + -- Itypes that describe the designated type of access to subprograms + -- have the structure of subprogram declarations, with signatures, + -- etc. Either we duplicate the signatures completely, or choose to + -- share such itypes, which is fine because their elaboration will + -- have no side effects. + + if Ekind (Old_Itype) = E_Subprogram_Type then + return; + end if; + + New_Itype := New_Copy (Old_Itype); + + -- The new Itype has all the attributes of the old one, and + -- we just copy the contents of the entity. However, the back-end + -- needs different names for debugging purposes, so we create a + -- new internal name for it in all cases. + + Set_Chars (New_Itype, New_Internal_Name ('T')); + + -- If our associated node is an entity that has already been copied, + -- then set the associated node of the copy to point to the right + -- copy. If we have copied an Itype that is itself the associated + -- node of some previously copied Itype, then we set the right + -- pointer in the other direction. + + if Present (Actual_Map) then + + -- Case of hash tables used + + if NCT_Hash_Tables_Used then + + Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype)); + + if Present (Ent) then + Set_Associated_Node_For_Itype (New_Itype, Ent); + end if; + + Ent := NCT_Itype_Assoc.Get (Old_Itype); + if Present (Ent) then + Set_Associated_Node_For_Itype (Ent, New_Itype); + + -- If the hash table has no association for this Itype and + -- its associated node, enter one now. + + else + NCT_Itype_Assoc.Set + (Associated_Node_For_Itype (Old_Itype), New_Itype); + end if; + + -- Case of hash tables not used + + else + E := First_Elmt (Actual_Map); + while Present (E) loop + if Associated_Node_For_Itype (Old_Itype) = Node (E) then + Set_Associated_Node_For_Itype + (New_Itype, Node (Next_Elmt (E))); + end if; + + if Is_Type (Node (E)) + and then + Old_Itype = Associated_Node_For_Itype (Node (E)) + then + Set_Associated_Node_For_Itype + (Node (Next_Elmt (E)), New_Itype); + end if; + + E := Next_Elmt (Next_Elmt (E)); + end loop; + end if; + end if; + + if Present (Freeze_Node (New_Itype)) then + Set_Is_Frozen (New_Itype, False); + Set_Freeze_Node (New_Itype, Empty); + end if; + + -- Add new association to map + + if No (Actual_Map) then + Actual_Map := New_Elmt_List; + end if; + + Append_Elmt (Old_Itype, Actual_Map); + Append_Elmt (New_Itype, Actual_Map); + + if NCT_Hash_Tables_Used then + NCT_Assoc.Set (Old_Itype, New_Itype); + + else + NCT_Table_Entries := NCT_Table_Entries + 1; + + if NCT_Table_Entries > NCT_Hash_Threshold then + Build_NCT_Hash_Tables; + end if; + end if; + + -- If a record subtype is simply copied, the entity list will be + -- shared. Thus cloned_Subtype must be set to indicate the sharing. + + if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then + Set_Cloned_Subtype (New_Itype, Old_Itype); + end if; + + -- Visit descendents that eventually get copied + + Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype); + + if Is_Discrete_Type (Old_Itype) then + Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype); + + elsif Has_Discriminants (Base_Type (Old_Itype)) then + -- ??? This should involve call to Visit_Field + Visit_Elist (Discriminant_Constraint (Old_Itype)); + + elsif Is_Array_Type (Old_Itype) then + if Present (First_Index (Old_Itype)) then + Visit_Field (Union_Id (List_Containing + (First_Index (Old_Itype))), + Old_Itype); + end if; + + if Is_Packed (Old_Itype) then + Visit_Field (Union_Id (Packed_Array_Type (Old_Itype)), + Old_Itype); + end if; + end if; + end Visit_Itype; + + ---------------- + -- Visit_List -- + ---------------- + + procedure Visit_List (L : List_Id) is + N : Node_Id; + begin + if L /= No_List then + N := First (L); + + while Present (N) loop + Visit_Node (N); + Next (N); + end loop; + end if; + end Visit_List; + + ---------------- + -- Visit_Node -- + ---------------- + + procedure Visit_Node (N : Node_Or_Entity_Id) is + + -- Start of processing for Visit_Node + + begin + -- Handle case of an Itype, which must be copied + + if Has_Extension (N) + and then Is_Itype (N) + then + -- Nothing to do if already in the list. This can happen with an + -- Itype entity that appears more than once in the tree. + -- Note that we do not want to visit descendents in this case. + + -- Test for already in list when hash table is used + + if NCT_Hash_Tables_Used then + if Present (NCT_Assoc.Get (Entity_Id (N))) then + return; + end if; + + -- Test for already in list when hash table not used + + else + declare + E : Elmt_Id; + begin + if Present (Actual_Map) then + E := First_Elmt (Actual_Map); + while Present (E) loop + if Node (E) = N then + return; + else + E := Next_Elmt (Next_Elmt (E)); + end if; + end loop; + end if; + end; + end if; + + Visit_Itype (N); + end if; + + -- Visit descendents + + Visit_Field (Field1 (N), N); + Visit_Field (Field2 (N), N); + Visit_Field (Field3 (N), N); + Visit_Field (Field4 (N), N); + Visit_Field (Field5 (N), N); + end Visit_Node; + + -- Start of processing for New_Copy_Tree + + begin + Actual_Map := Map; + + -- See if we should use hash table + + if No (Actual_Map) then + NCT_Hash_Tables_Used := False; + + else + declare + Elmt : Elmt_Id; + + begin + NCT_Table_Entries := 0; + + Elmt := First_Elmt (Actual_Map); + while Present (Elmt) loop + NCT_Table_Entries := NCT_Table_Entries + 1; + Next_Elmt (Elmt); + Next_Elmt (Elmt); + end loop; + + if NCT_Table_Entries > NCT_Hash_Threshold then + Build_NCT_Hash_Tables; + else + NCT_Hash_Tables_Used := False; + end if; + end; + end if; + + -- Hash table set up if required, now start phase one by visiting + -- top node (we will recursively visit the descendents). + + Visit_Node (Source); + + -- Now the second phase of the copy can start. First we process + -- all the mapped entities, copying their descendents. + + if Present (Actual_Map) then + declare + Elmt : Elmt_Id; + New_Itype : Entity_Id; + begin + Elmt := First_Elmt (Actual_Map); + while Present (Elmt) loop + Next_Elmt (Elmt); + New_Itype := Node (Elmt); + Copy_Itype_With_Replacement (New_Itype); + Next_Elmt (Elmt); + end loop; + end; + end if; + + -- Now we can copy the actual tree + + return Copy_Node_With_Replacement (Source); + end New_Copy_Tree; + + ------------------------- + -- New_External_Entity -- + ------------------------- + + function New_External_Entity + (Kind : Entity_Kind; + Scope_Id : Entity_Id; + Sloc_Value : Source_Ptr; + Related_Id : Entity_Id; + Suffix : Character; + Suffix_Index : Nat := 0; + Prefix : Character := ' ') return Entity_Id + is + N : constant Entity_Id := + Make_Defining_Identifier (Sloc_Value, + New_External_Name + (Chars (Related_Id), Suffix, Suffix_Index, Prefix)); + + begin + Set_Ekind (N, Kind); + Set_Is_Internal (N, True); + Append_Entity (N, Scope_Id); + Set_Public_Status (N); + + if Kind in Type_Kind then + Init_Size_Align (N); + end if; + + return N; + end New_External_Entity; + + ------------------------- + -- New_Internal_Entity -- + ------------------------- + + function New_Internal_Entity + (Kind : Entity_Kind; + Scope_Id : Entity_Id; + Sloc_Value : Source_Ptr; + Id_Char : Character) return Entity_Id + is + N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char); + + begin + Set_Ekind (N, Kind); + Set_Is_Internal (N, True); + Append_Entity (N, Scope_Id); + + if Kind in Type_Kind then + Init_Size_Align (N); + end if; + + return N; + end New_Internal_Entity; + + ----------------- + -- Next_Actual -- + ----------------- + + function Next_Actual (Actual_Id : Node_Id) return Node_Id is + N : Node_Id; + + begin + -- If we are pointing at a positional parameter, it is a member of a + -- node list (the list of parameters), and the next parameter is the + -- next node on the list, unless we hit a parameter association, then + -- we shift to using the chain whose head is the First_Named_Actual in + -- the parent, and then is threaded using the Next_Named_Actual of the + -- Parameter_Association. All this fiddling is because the original node + -- list is in the textual call order, and what we need is the + -- declaration order. + + if Is_List_Member (Actual_Id) then + N := Next (Actual_Id); + + if Nkind (N) = N_Parameter_Association then + return First_Named_Actual (Parent (Actual_Id)); + else + return N; + end if; + + else + return Next_Named_Actual (Parent (Actual_Id)); + end if; + end Next_Actual; + + procedure Next_Actual (Actual_Id : in out Node_Id) is + begin + Actual_Id := Next_Actual (Actual_Id); + end Next_Actual; + + ----------------------- + -- Normalize_Actuals -- + ----------------------- + + -- Chain actuals according to formals of subprogram. If there are no named + -- associations, the chain is simply the list of Parameter Associations, + -- since the order is the same as the declaration order. If there are named + -- associations, then the First_Named_Actual field in the N_Function_Call + -- or N_Procedure_Call_Statement node points to the Parameter_Association + -- node for the parameter that comes first in declaration order. The + -- remaining named parameters are then chained in declaration order using + -- Next_Named_Actual. + + -- This routine also verifies that the number of actuals is compatible with + -- the number and default values of formals, but performs no type checking + -- (type checking is done by the caller). + + -- If the matching succeeds, Success is set to True and the caller proceeds + -- with type-checking. If the match is unsuccessful, then Success is set to + -- False, and the caller attempts a different interpretation, if there is + -- one. + + -- If the flag Report is on, the call is not overloaded, and a failure to + -- match can be reported here, rather than in the caller. + + procedure Normalize_Actuals + (N : Node_Id; + S : Entity_Id; + Report : Boolean; + Success : out Boolean) + is + Actuals : constant List_Id := Parameter_Associations (N); + Actual : Node_Id := Empty; + Formal : Entity_Id; + Last : Node_Id := Empty; + First_Named : Node_Id := Empty; + Found : Boolean; + + Formals_To_Match : Integer := 0; + Actuals_To_Match : Integer := 0; + + procedure Chain (A : Node_Id); + -- Add named actual at the proper place in the list, using the + -- Next_Named_Actual link. + + function Reporting return Boolean; + -- Determines if an error is to be reported. To report an error, we + -- need Report to be True, and also we do not report errors caused + -- by calls to init procs that occur within other init procs. Such + -- errors must always be cascaded errors, since if all the types are + -- declared correctly, the compiler will certainly build decent calls! + + ----------- + -- Chain -- + ----------- + + procedure Chain (A : Node_Id) is + begin + if No (Last) then + + -- Call node points to first actual in list + + Set_First_Named_Actual (N, Explicit_Actual_Parameter (A)); + + else + Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A)); + end if; + + Last := A; + Set_Next_Named_Actual (Last, Empty); + end Chain; + + --------------- + -- Reporting -- + --------------- + + function Reporting return Boolean is + begin + if not Report then + return False; + + elsif not Within_Init_Proc then + return True; + + elsif Is_Init_Proc (Entity (Name (N))) then + return False; + + else + return True; + end if; + end Reporting; + + -- Start of processing for Normalize_Actuals + + begin + if Is_Access_Type (S) then + + -- The name in the call is a function call that returns an access + -- to subprogram. The designated type has the list of formals. + + Formal := First_Formal (Designated_Type (S)); + else + Formal := First_Formal (S); + end if; + + while Present (Formal) loop + Formals_To_Match := Formals_To_Match + 1; + Next_Formal (Formal); + end loop; + + -- Find if there is a named association, and verify that no positional + -- associations appear after named ones. + + if Present (Actuals) then + Actual := First (Actuals); + end if; + + while Present (Actual) + and then Nkind (Actual) /= N_Parameter_Association + loop + Actuals_To_Match := Actuals_To_Match + 1; + Next (Actual); + end loop; + + if No (Actual) and Actuals_To_Match = Formals_To_Match then + + -- Most common case: positional notation, no defaults + + Success := True; + return; + + elsif Actuals_To_Match > Formals_To_Match then + + -- Too many actuals: will not work + + if Reporting then + if Is_Entity_Name (Name (N)) then + Error_Msg_N ("too many arguments in call to&", Name (N)); + else + Error_Msg_N ("too many arguments in call", N); + end if; + end if; + + Success := False; + return; + end if; + + First_Named := Actual; + + while Present (Actual) loop + if Nkind (Actual) /= N_Parameter_Association then + Error_Msg_N + ("positional parameters not allowed after named ones", Actual); + Success := False; + return; + + else + Actuals_To_Match := Actuals_To_Match + 1; + end if; + + Next (Actual); + end loop; + + if Present (Actuals) then + Actual := First (Actuals); + end if; + + Formal := First_Formal (S); + while Present (Formal) loop + + -- Match the formals in order. If the corresponding actual is + -- positional, nothing to do. Else scan the list of named actuals + -- to find the one with the right name. + + if Present (Actual) + and then Nkind (Actual) /= N_Parameter_Association + then + Next (Actual); + Actuals_To_Match := Actuals_To_Match - 1; + Formals_To_Match := Formals_To_Match - 1; + + else + -- For named parameters, search the list of actuals to find + -- one that matches the next formal name. + + Actual := First_Named; + Found := False; + while Present (Actual) loop + if Chars (Selector_Name (Actual)) = Chars (Formal) then + Found := True; + Chain (Actual); + Actuals_To_Match := Actuals_To_Match - 1; + Formals_To_Match := Formals_To_Match - 1; + exit; + end if; + + Next (Actual); + end loop; + + if not Found then + if Ekind (Formal) /= E_In_Parameter + or else No (Default_Value (Formal)) + then + if Reporting then + if (Comes_From_Source (S) + or else Sloc (S) = Standard_Location) + and then Is_Overloadable (S) + then + if No (Actuals) + and then + (Nkind (Parent (N)) = N_Procedure_Call_Statement + or else + (Nkind (Parent (N)) = N_Function_Call + or else + Nkind (Parent (N)) = N_Parameter_Association)) + and then Ekind (S) /= E_Function + then + Set_Etype (N, Etype (S)); + else + Error_Msg_Name_1 := Chars (S); + Error_Msg_Sloc := Sloc (S); + Error_Msg_NE + ("missing argument for parameter & " & + "in call to % declared #", N, Formal); + end if; + + elsif Is_Overloadable (S) then + Error_Msg_Name_1 := Chars (S); + + -- Point to type derivation that generated the + -- operation. + + Error_Msg_Sloc := Sloc (Parent (S)); + + Error_Msg_NE + ("missing argument for parameter & " & + "in call to % (inherited) #", N, Formal); + + else + Error_Msg_NE + ("missing argument for parameter &", N, Formal); + end if; + end if; + + Success := False; + return; + + else + Formals_To_Match := Formals_To_Match - 1; + end if; + end if; + end if; + + Next_Formal (Formal); + end loop; + + if Formals_To_Match = 0 and then Actuals_To_Match = 0 then + Success := True; + return; + + else + if Reporting then + + -- Find some superfluous named actual that did not get + -- attached to the list of associations. + + Actual := First (Actuals); + while Present (Actual) loop + if Nkind (Actual) = N_Parameter_Association + and then Actual /= Last + and then No (Next_Named_Actual (Actual)) + then + Error_Msg_N ("unmatched actual & in call", + Selector_Name (Actual)); + exit; + end if; + + Next (Actual); + end loop; + end if; + + Success := False; + return; + end if; + end Normalize_Actuals; + + -------------------------------- + -- Note_Possible_Modification -- + -------------------------------- + + procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is + Modification_Comes_From_Source : constant Boolean := + Comes_From_Source (Parent (N)); + + Ent : Entity_Id; + Exp : Node_Id; + + begin + -- Loop to find referenced entity, if there is one + + Exp := N; + loop + <> + Ent := Empty; + + if Is_Entity_Name (Exp) then + Ent := Entity (Exp); + + -- If the entity is missing, it is an undeclared identifier, + -- and there is nothing to annotate. + + if No (Ent) then + return; + end if; + + elsif Nkind (Exp) = N_Explicit_Dereference then + declare + P : constant Node_Id := Prefix (Exp); + + begin + if Nkind (P) = N_Selected_Component + and then Present ( + Entry_Formal (Entity (Selector_Name (P)))) + then + -- Case of a reference to an entry formal + + Ent := Entry_Formal (Entity (Selector_Name (P))); + + elsif Nkind (P) = N_Identifier + and then Nkind (Parent (Entity (P))) = N_Object_Declaration + and then Present (Expression (Parent (Entity (P)))) + and then Nkind (Expression (Parent (Entity (P)))) + = N_Reference + then + -- Case of a reference to a value on which side effects have + -- been removed. + + Exp := Prefix (Expression (Parent (Entity (P)))); + goto Continue; + + else + return; + + end if; + end; + + elsif Nkind (Exp) = N_Type_Conversion + or else Nkind (Exp) = N_Unchecked_Type_Conversion + then + Exp := Expression (Exp); + goto Continue; + + elsif Nkind (Exp) = N_Slice + or else Nkind (Exp) = N_Indexed_Component + or else Nkind (Exp) = N_Selected_Component + then + Exp := Prefix (Exp); + goto Continue; + + else + return; + end if; + + -- Now look for entity being referenced + + if Present (Ent) then + if Is_Object (Ent) then + if Comes_From_Source (Exp) + or else Modification_Comes_From_Source + then + -- Give warning if pragma unmodified given and we are + -- sure this is a modification. + + if Has_Pragma_Unmodified (Ent) and then Sure then + Error_Msg_NE ("?pragma Unmodified given for &!", N, Ent); + end if; + + Set_Never_Set_In_Source (Ent, False); + end if; + + Set_Is_True_Constant (Ent, False); + Set_Current_Value (Ent, Empty); + Set_Is_Known_Null (Ent, False); + + if not Can_Never_Be_Null (Ent) then + Set_Is_Known_Non_Null (Ent, False); + end if; + + -- Follow renaming chain + + if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant) + and then Present (Renamed_Object (Ent)) + then + Exp := Renamed_Object (Ent); + goto Continue; + end if; + + -- Generate a reference only if the assignment comes from + -- source. This excludes, for example, calls to a dispatching + -- assignment operation when the left-hand side is tagged. + + if Modification_Comes_From_Source then + Generate_Reference (Ent, Exp, 'm'); + + -- If the target of the assignment is the bound variable + -- in an iterator, indicate that the corresponding array + -- or container is also modified. + + if Ada_Version >= Ada_2012 + and then + Nkind (Parent (Ent)) = N_Iterator_Specification + then + declare + Domain : constant Node_Id := Name (Parent (Ent)); + + begin + -- TBD : in the full version of the construct, the + -- domain of iteration can be given by an expression. + + if Is_Entity_Name (Domain) then + Generate_Reference (Entity (Domain), Exp, 'm'); + Set_Is_True_Constant (Entity (Domain), False); + Set_Never_Set_In_Source (Entity (Domain), False); + end if; + end; + end if; + end if; + + Check_Nested_Access (Ent); + end if; + + Kill_Checks (Ent); + + -- If we are sure this is a modification from source, and we know + -- this modifies a constant, then give an appropriate warning. + + if Overlays_Constant (Ent) + and then Modification_Comes_From_Source + and then Sure + then + declare + A : constant Node_Id := Address_Clause (Ent); + begin + if Present (A) then + declare + Exp : constant Node_Id := Expression (A); + begin + if Nkind (Exp) = N_Attribute_Reference + and then Attribute_Name (Exp) = Name_Address + and then Is_Entity_Name (Prefix (Exp)) + then + Error_Msg_Sloc := Sloc (A); + Error_Msg_NE + ("constant& may be modified via address clause#?", + N, Entity (Prefix (Exp))); + end if; + end; + end if; + end; + end if; + + return; + end if; + end loop; + end Note_Possible_Modification; + + ------------------------- + -- Object_Access_Level -- + ------------------------- + + function Object_Access_Level (Obj : Node_Id) return Uint is + E : Entity_Id; + + -- Returns the static accessibility level of the view denoted by Obj. Note + -- that the value returned is the result of a call to Scope_Depth. Only + -- scope depths associated with dynamic scopes can actually be returned. + -- Since only relative levels matter for accessibility checking, the fact + -- that the distance between successive levels of accessibility is not + -- always one is immaterial (invariant: if level(E2) is deeper than + -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)). + + function Reference_To (Obj : Node_Id) return Node_Id; + -- An explicit dereference is created when removing side-effects from + -- expressions for constraint checking purposes. In this case a local + -- access type is created for it. The correct access level is that of + -- the original source node. We detect this case by noting that the + -- prefix of the dereference is created by an object declaration whose + -- initial expression is a reference. + + ------------------ + -- Reference_To -- + ------------------ + + function Reference_To (Obj : Node_Id) return Node_Id is + Pref : constant Node_Id := Prefix (Obj); + begin + if Is_Entity_Name (Pref) + and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration + and then Present (Expression (Parent (Entity (Pref)))) + and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference + then + return (Prefix (Expression (Parent (Entity (Pref))))); + else + return Empty; + end if; + end Reference_To; + + -- Start of processing for Object_Access_Level + + begin + if Is_Entity_Name (Obj) then + E := Entity (Obj); + + if Is_Prival (E) then + E := Prival_Link (E); + end if; + + -- If E is a type then it denotes a current instance. For this case + -- we add one to the normal accessibility level of the type to ensure + -- that current instances are treated as always being deeper than + -- than the level of any visible named access type (see 3.10.2(21)). + + if Is_Type (E) then + return Type_Access_Level (E) + 1; + + elsif Present (Renamed_Object (E)) then + return Object_Access_Level (Renamed_Object (E)); + + -- Similarly, if E is a component of the current instance of a + -- protected type, any instance of it is assumed to be at a deeper + -- level than the type. For a protected object (whose type is an + -- anonymous protected type) its components are at the same level + -- as the type itself. + + elsif not Is_Overloadable (E) + and then Ekind (Scope (E)) = E_Protected_Type + and then Comes_From_Source (Scope (E)) + then + return Type_Access_Level (Scope (E)) + 1; + + else + return Scope_Depth (Enclosing_Dynamic_Scope (E)); + end if; + + elsif Nkind (Obj) = N_Selected_Component then + if Is_Access_Type (Etype (Prefix (Obj))) then + return Type_Access_Level (Etype (Prefix (Obj))); + else + return Object_Access_Level (Prefix (Obj)); + end if; + + elsif Nkind (Obj) = N_Indexed_Component then + if Is_Access_Type (Etype (Prefix (Obj))) then + return Type_Access_Level (Etype (Prefix (Obj))); + else + return Object_Access_Level (Prefix (Obj)); + end if; + + elsif Nkind (Obj) = N_Explicit_Dereference then + + -- If the prefix is a selected access discriminant then we make a + -- recursive call on the prefix, which will in turn check the level + -- of the prefix object of the selected discriminant. + + if Nkind (Prefix (Obj)) = N_Selected_Component + and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type + and then + Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant + then + return Object_Access_Level (Prefix (Obj)); + + elsif not (Comes_From_Source (Obj)) then + declare + Ref : constant Node_Id := Reference_To (Obj); + begin + if Present (Ref) then + return Object_Access_Level (Ref); + else + return Type_Access_Level (Etype (Prefix (Obj))); + end if; + end; + + else + return Type_Access_Level (Etype (Prefix (Obj))); + end if; + + elsif Nkind (Obj) = N_Type_Conversion + or else Nkind (Obj) = N_Unchecked_Type_Conversion + then + return Object_Access_Level (Expression (Obj)); + + elsif Nkind (Obj) = N_Function_Call then + + -- Function results are objects, so we get either the access level of + -- the function or, in the case of an indirect call, the level of the + -- access-to-subprogram type. (This code is used for Ada 95, but it + -- looks wrong, because it seems that we should be checking the level + -- of the call itself, even for Ada 95. However, using the Ada 2005 + -- version of the code causes regressions in several tests that are + -- compiled with -gnat95. ???) + + if Ada_Version < Ada_2005 then + if Is_Entity_Name (Name (Obj)) then + return Subprogram_Access_Level (Entity (Name (Obj))); + else + return Type_Access_Level (Etype (Prefix (Name (Obj)))); + end if; + + -- For Ada 2005, the level of the result object of a function call is + -- defined to be the level of the call's innermost enclosing master. + -- We determine that by querying the depth of the innermost enclosing + -- dynamic scope. + + else + Return_Master_Scope_Depth_Of_Call : declare + + function Innermost_Master_Scope_Depth + (N : Node_Id) return Uint; + -- Returns the scope depth of the given node's innermost + -- enclosing dynamic scope (effectively the accessibility + -- level of the innermost enclosing master). + + ---------------------------------- + -- Innermost_Master_Scope_Depth -- + ---------------------------------- + + function Innermost_Master_Scope_Depth + (N : Node_Id) return Uint + is + Node_Par : Node_Id := Parent (N); + + begin + -- Locate the nearest enclosing node (by traversing Parents) + -- that Defining_Entity can be applied to, and return the + -- depth of that entity's nearest enclosing dynamic scope. + + while Present (Node_Par) loop + case Nkind (Node_Par) is + when N_Component_Declaration | + N_Entry_Declaration | + N_Formal_Object_Declaration | + N_Formal_Type_Declaration | + N_Full_Type_Declaration | + N_Incomplete_Type_Declaration | + N_Loop_Parameter_Specification | + N_Object_Declaration | + N_Protected_Type_Declaration | + N_Private_Extension_Declaration | + N_Private_Type_Declaration | + N_Subtype_Declaration | + N_Function_Specification | + N_Procedure_Specification | + N_Task_Type_Declaration | + N_Body_Stub | + N_Generic_Instantiation | + N_Proper_Body | + N_Implicit_Label_Declaration | + N_Package_Declaration | + N_Single_Task_Declaration | + N_Subprogram_Declaration | + N_Generic_Declaration | + N_Renaming_Declaration | + N_Block_Statement | + N_Formal_Subprogram_Declaration | + N_Abstract_Subprogram_Declaration | + N_Entry_Body | + N_Exception_Declaration | + N_Formal_Package_Declaration | + N_Number_Declaration | + N_Package_Specification | + N_Parameter_Specification | + N_Single_Protected_Declaration | + N_Subunit => + + return Scope_Depth + (Nearest_Dynamic_Scope + (Defining_Entity (Node_Par))); + + when others => + null; + end case; + + Node_Par := Parent (Node_Par); + end loop; + + pragma Assert (False); + + -- Should never reach the following return + + return Scope_Depth (Current_Scope) + 1; + end Innermost_Master_Scope_Depth; + + -- Start of processing for Return_Master_Scope_Depth_Of_Call + + begin + return Innermost_Master_Scope_Depth (Obj); + end Return_Master_Scope_Depth_Of_Call; + end if; + + -- For convenience we handle qualified expressions, even though + -- they aren't technically object names. + + elsif Nkind (Obj) = N_Qualified_Expression then + return Object_Access_Level (Expression (Obj)); + + -- Otherwise return the scope level of Standard. + -- (If there are cases that fall through + -- to this point they will be treated as + -- having global accessibility for now. ???) + + else + return Scope_Depth (Standard_Standard); + end if; + end Object_Access_Level; + + -------------------------------------- + -- Original_Corresponding_Operation -- + -------------------------------------- + + function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id + is + Typ : constant Entity_Id := Find_Dispatching_Type (S); + + begin + -- If S is an inherited primitive S2 the original corresponding + -- operation of S is the original corresponding operation of S2 + + if Present (Alias (S)) + and then Find_Dispatching_Type (Alias (S)) /= Typ + then + return Original_Corresponding_Operation (Alias (S)); + + -- If S overrides an inherited subprogram S2 the original corresponding + -- operation of S is the original corresponding operation of S2 + + elsif Present (Overridden_Operation (S)) then + return Original_Corresponding_Operation (Overridden_Operation (S)); + + -- otherwise it is S itself + + else + return S; + end if; + end Original_Corresponding_Operation; + + ----------------------- + -- Private_Component -- + ----------------------- + + function Private_Component (Type_Id : Entity_Id) return Entity_Id is + Ancestor : constant Entity_Id := Base_Type (Type_Id); + + function Trace_Components + (T : Entity_Id; + Check : Boolean) return Entity_Id; + -- Recursive function that does the work, and checks against circular + -- definition for each subcomponent type. + + ---------------------- + -- Trace_Components -- + ---------------------- + + function Trace_Components + (T : Entity_Id; + Check : Boolean) return Entity_Id + is + Btype : constant Entity_Id := Base_Type (T); + Component : Entity_Id; + P : Entity_Id; + Candidate : Entity_Id := Empty; + + begin + if Check and then Btype = Ancestor then + Error_Msg_N ("circular type definition", Type_Id); + return Any_Type; + end if; + + if Is_Private_Type (Btype) + and then not Is_Generic_Type (Btype) + then + if Present (Full_View (Btype)) + and then Is_Record_Type (Full_View (Btype)) + and then not Is_Frozen (Btype) + then + -- To indicate that the ancestor depends on a private type, the + -- current Btype is sufficient. However, to check for circular + -- definition we must recurse on the full view. + + Candidate := Trace_Components (Full_View (Btype), True); + + if Candidate = Any_Type then + return Any_Type; + else + return Btype; + end if; + + else + return Btype; + end if; + + elsif Is_Array_Type (Btype) then + return Trace_Components (Component_Type (Btype), True); + + elsif Is_Record_Type (Btype) then + Component := First_Entity (Btype); + while Present (Component) loop + + -- Skip anonymous types generated by constrained components + + if not Is_Type (Component) then + P := Trace_Components (Etype (Component), True); + + if Present (P) then + if P = Any_Type then + return P; + else + Candidate := P; + end if; + end if; + end if; + + Next_Entity (Component); + end loop; + + return Candidate; + + else + return Empty; + end if; + end Trace_Components; + + -- Start of processing for Private_Component + + begin + return Trace_Components (Type_Id, False); + end Private_Component; + + --------------------------- + -- Primitive_Names_Match -- + --------------------------- + + function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is + + function Non_Internal_Name (E : Entity_Id) return Name_Id; + -- Given an internal name, returns the corresponding non-internal name + + ------------------------ + -- Non_Internal_Name -- + ------------------------ + + function Non_Internal_Name (E : Entity_Id) return Name_Id is + begin + Get_Name_String (Chars (E)); + Name_Len := Name_Len - 1; + return Name_Find; + end Non_Internal_Name; + + -- Start of processing for Primitive_Names_Match + + begin + pragma Assert (Present (E1) and then Present (E2)); + + return Chars (E1) = Chars (E2) + or else + (not Is_Internal_Name (Chars (E1)) + and then Is_Internal_Name (Chars (E2)) + and then Non_Internal_Name (E2) = Chars (E1)) + or else + (not Is_Internal_Name (Chars (E2)) + and then Is_Internal_Name (Chars (E1)) + and then Non_Internal_Name (E1) = Chars (E2)) + or else + (Is_Predefined_Dispatching_Operation (E1) + and then Is_Predefined_Dispatching_Operation (E2) + and then Same_TSS (E1, E2)) + or else + (Is_Init_Proc (E1) and then Is_Init_Proc (E2)); + end Primitive_Names_Match; + + ----------------------- + -- Process_End_Label -- + ----------------------- + + procedure Process_End_Label + (N : Node_Id; + Typ : Character; + Ent : Entity_Id) + is + Loc : Source_Ptr; + Nam : Node_Id; + Scop : Entity_Id; + + Label_Ref : Boolean; + -- Set True if reference to end label itself is required + + Endl : Node_Id; + -- Gets set to the operator symbol or identifier that references the + -- entity Ent. For the child unit case, this is the identifier from the + -- designator. For other cases, this is simply Endl. + + procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id); + -- N is an identifier node that appears as a parent unit reference in + -- the case where Ent is a child unit. This procedure generates an + -- appropriate cross-reference entry. E is the corresponding entity. + + ------------------------- + -- Generate_Parent_Ref -- + ------------------------- + + procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is + begin + -- If names do not match, something weird, skip reference + + if Chars (E) = Chars (N) then + + -- Generate the reference. We do NOT consider this as a reference + -- for unreferenced symbol purposes. + + Generate_Reference (E, N, 'r', Set_Ref => False, Force => True); + + if Style_Check then + Style.Check_Identifier (N, E); + end if; + end if; + end Generate_Parent_Ref; + + -- Start of processing for Process_End_Label + + begin + -- If no node, ignore. This happens in some error situations, and + -- also for some internally generated structures where no end label + -- references are required in any case. + + if No (N) then + return; + end if; + + -- Nothing to do if no End_Label, happens for internally generated + -- constructs where we don't want an end label reference anyway. Also + -- nothing to do if Endl is a string literal, which means there was + -- some prior error (bad operator symbol) + + Endl := End_Label (N); + + if No (Endl) or else Nkind (Endl) = N_String_Literal then + return; + end if; + + -- Reference node is not in extended main source unit + + if not In_Extended_Main_Source_Unit (N) then + + -- Generally we do not collect references except for the extended + -- main source unit. The one exception is the 'e' entry for a + -- package spec, where it is useful for a client to have the + -- ending information to define scopes. + + if Typ /= 'e' then + return; + + else + Label_Ref := False; + + -- For this case, we can ignore any parent references, but we + -- need the package name itself for the 'e' entry. + + if Nkind (Endl) = N_Designator then + Endl := Identifier (Endl); + end if; + end if; + + -- Reference is in extended main source unit + + else + Label_Ref := True; + + -- For designator, generate references for the parent entries + + if Nkind (Endl) = N_Designator then + + -- Generate references for the prefix if the END line comes from + -- source (otherwise we do not need these references) We climb the + -- scope stack to find the expected entities. + + if Comes_From_Source (Endl) then + Nam := Name (Endl); + Scop := Current_Scope; + while Nkind (Nam) = N_Selected_Component loop + Scop := Scope (Scop); + exit when No (Scop); + Generate_Parent_Ref (Selector_Name (Nam), Scop); + Nam := Prefix (Nam); + end loop; + + if Present (Scop) then + Generate_Parent_Ref (Nam, Scope (Scop)); + end if; + end if; + + Endl := Identifier (Endl); + end if; + end if; + + -- If the end label is not for the given entity, then either we have + -- some previous error, or this is a generic instantiation for which + -- we do not need to make a cross-reference in this case anyway. In + -- either case we simply ignore the call. + + if Chars (Ent) /= Chars (Endl) then + return; + end if; + + -- If label was really there, then generate a normal reference and then + -- adjust the location in the end label to point past the name (which + -- should almost always be the semicolon). + + Loc := Sloc (Endl); + + if Comes_From_Source (Endl) then + + -- If a label reference is required, then do the style check and + -- generate an l-type cross-reference entry for the label + + if Label_Ref then + if Style_Check then + Style.Check_Identifier (Endl, Ent); + end if; + + Generate_Reference (Ent, Endl, 'l', Set_Ref => False); + end if; + + -- Set the location to point past the label (normally this will + -- mean the semicolon immediately following the label). This is + -- done for the sake of the 'e' or 't' entry generated below. + + Get_Decoded_Name_String (Chars (Endl)); + Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len)); + end if; + + -- Now generate the e/t reference + + Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True); + + -- Restore Sloc, in case modified above, since we have an identifier + -- and the normal Sloc should be left set in the tree. + + Set_Sloc (Endl, Loc); + end Process_End_Label; + + ------------------------------------ + -- References_Generic_Formal_Type -- + ------------------------------------ + + function References_Generic_Formal_Type (N : Node_Id) return Boolean is + + function Process (N : Node_Id) return Traverse_Result; + -- Process one node in search for generic formal type + + ------------- + -- Process -- + ------------- + + function Process (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) in N_Has_Entity then + declare + E : constant Entity_Id := Entity (N); + begin + if Present (E) then + if Is_Generic_Type (E) then + return Abandon; + elsif Present (Etype (E)) + and then Is_Generic_Type (Etype (E)) + then + return Abandon; + end if; + end if; + end; + end if; + + return Atree.OK; + end Process; + + function Traverse is new Traverse_Func (Process); + -- Traverse tree to look for generic type + + begin + if Inside_A_Generic then + return Traverse (N) = Abandon; + else + return False; + end if; + end References_Generic_Formal_Type; + + -------------------- + -- Remove_Homonym -- + -------------------- + + procedure Remove_Homonym (E : Entity_Id) is + Prev : Entity_Id := Empty; + H : Entity_Id; + + begin + if E = Current_Entity (E) then + if Present (Homonym (E)) then + Set_Current_Entity (Homonym (E)); + else + Set_Name_Entity_Id (Chars (E), Empty); + end if; + else + H := Current_Entity (E); + while Present (H) and then H /= E loop + Prev := H; + H := Homonym (H); + end loop; + + Set_Homonym (Prev, Homonym (E)); + end if; + end Remove_Homonym; + + --------------------- + -- Rep_To_Pos_Flag -- + --------------------- + + function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is + begin + return New_Occurrence_Of + (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc); + end Rep_To_Pos_Flag; + + -------------------- + -- Require_Entity -- + -------------------- + + procedure Require_Entity (N : Node_Id) is + begin + if Is_Entity_Name (N) and then No (Entity (N)) then + if Total_Errors_Detected /= 0 then + Set_Entity (N, Any_Id); + else + raise Program_Error; + end if; + end if; + end Require_Entity; + + ------------------------------ + -- Requires_Transient_Scope -- + ------------------------------ + + -- A transient scope is required when variable-sized temporaries are + -- allocated in the primary or secondary stack, or when finalization + -- actions must be generated before the next instruction. + + function Requires_Transient_Scope (Id : Entity_Id) return Boolean is + Typ : constant Entity_Id := Underlying_Type (Id); + + -- Start of processing for Requires_Transient_Scope + + begin + -- This is a private type which is not completed yet. This can only + -- happen in a default expression (of a formal parameter or of a + -- record component). Do not expand transient scope in this case + + if No (Typ) then + return False; + + -- Do not expand transient scope for non-existent procedure return + + elsif Typ = Standard_Void_Type then + return False; + + -- Elementary types do not require a transient scope + + elsif Is_Elementary_Type (Typ) then + return False; + + -- Generally, indefinite subtypes require a transient scope, since the + -- back end cannot generate temporaries, since this is not a valid type + -- for declaring an object. It might be possible to relax this in the + -- future, e.g. by declaring the maximum possible space for the type. + + elsif Is_Indefinite_Subtype (Typ) then + return True; + + -- Functions returning tagged types may dispatch on result so their + -- returned value is allocated on the secondary stack. Controlled + -- type temporaries need finalization. + + elsif Is_Tagged_Type (Typ) + or else Has_Controlled_Component (Typ) + then + return not Is_Value_Type (Typ); + + -- Record type + + elsif Is_Record_Type (Typ) then + declare + Comp : Entity_Id; + begin + Comp := First_Entity (Typ); + while Present (Comp) loop + if Ekind (Comp) = E_Component + and then Requires_Transient_Scope (Etype (Comp)) + then + return True; + else + Next_Entity (Comp); + end if; + end loop; + end; + + return False; + + -- String literal types never require transient scope + + elsif Ekind (Typ) = E_String_Literal_Subtype then + return False; + + -- Array type. Note that we already know that this is a constrained + -- array, since unconstrained arrays will fail the indefinite test. + + elsif Is_Array_Type (Typ) then + + -- If component type requires a transient scope, the array does too + + if Requires_Transient_Scope (Component_Type (Typ)) then + return True; + + -- Otherwise, we only need a transient scope if the size is not + -- known at compile time. + + else + return not Size_Known_At_Compile_Time (Typ); + end if; + + -- All other cases do not require a transient scope + + else + return False; + end if; + end Requires_Transient_Scope; + + -------------------------- + -- Reset_Analyzed_Flags -- + -------------------------- + + procedure Reset_Analyzed_Flags (N : Node_Id) is + + function Clear_Analyzed (N : Node_Id) return Traverse_Result; + -- Function used to reset Analyzed flags in tree. Note that we do + -- not reset Analyzed flags in entities, since there is no need to + -- reanalyze entities, and indeed, it is wrong to do so, since it + -- can result in generating auxiliary stuff more than once. + + -------------------- + -- Clear_Analyzed -- + -------------------- + + function Clear_Analyzed (N : Node_Id) return Traverse_Result is + begin + if not Has_Extension (N) then + Set_Analyzed (N, False); + end if; + + return OK; + end Clear_Analyzed; + + procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed); + + -- Start of processing for Reset_Analyzed_Flags + + begin + Reset_Analyzed (N); + end Reset_Analyzed_Flags; + + --------------------------- + -- Safe_To_Capture_Value -- + --------------------------- + + function Safe_To_Capture_Value + (N : Node_Id; + Ent : Entity_Id; + Cond : Boolean := False) return Boolean + is + begin + -- The only entities for which we track constant values are variables + -- which are not renamings, constants, out parameters, and in out + -- parameters, so check if we have this case. + + -- Note: it may seem odd to track constant values for constants, but in + -- fact this routine is used for other purposes than simply capturing + -- the value. In particular, the setting of Known[_Non]_Null. + + if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent))) + or else + Ekind (Ent) = E_Constant + or else + Ekind (Ent) = E_Out_Parameter + or else + Ekind (Ent) = E_In_Out_Parameter + then + null; + + -- For conditionals, we also allow loop parameters and all formals, + -- including in parameters. + + elsif Cond + and then + (Ekind (Ent) = E_Loop_Parameter + or else + Ekind (Ent) = E_In_Parameter) + then + null; + + -- For all other cases, not just unsafe, but impossible to capture + -- Current_Value, since the above are the only entities which have + -- Current_Value fields. + + else + return False; + end if; + + -- Skip if volatile or aliased, since funny things might be going on in + -- these cases which we cannot necessarily track. Also skip any variable + -- for which an address clause is given, or whose address is taken. Also + -- never capture value of library level variables (an attempt to do so + -- can occur in the case of package elaboration code). + + if Treat_As_Volatile (Ent) + or else Is_Aliased (Ent) + or else Present (Address_Clause (Ent)) + or else Address_Taken (Ent) + or else (Is_Library_Level_Entity (Ent) + and then Ekind (Ent) = E_Variable) + then + return False; + end if; + + -- OK, all above conditions are met. We also require that the scope of + -- the reference be the same as the scope of the entity, not counting + -- packages and blocks and loops. + + declare + E_Scope : constant Entity_Id := Scope (Ent); + R_Scope : Entity_Id; + + begin + R_Scope := Current_Scope; + while R_Scope /= Standard_Standard loop + exit when R_Scope = E_Scope; + + if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then + return False; + else + R_Scope := Scope (R_Scope); + end if; + end loop; + end; + + -- We also require that the reference does not appear in a context + -- where it is not sure to be executed (i.e. a conditional context + -- or an exception handler). We skip this if Cond is True, since the + -- capturing of values from conditional tests handles this ok. + + if Cond then + return True; + end if; + + declare + Desc : Node_Id; + P : Node_Id; + + begin + Desc := N; + + P := Parent (N); + while Present (P) loop + if Nkind (P) = N_If_Statement + or else Nkind (P) = N_Case_Statement + or else (Nkind (P) in N_Short_Circuit + and then Desc = Right_Opnd (P)) + or else (Nkind (P) = N_Conditional_Expression + and then Desc /= First (Expressions (P))) + or else Nkind (P) = N_Exception_Handler + or else Nkind (P) = N_Selective_Accept + or else Nkind (P) = N_Conditional_Entry_Call + or else Nkind (P) = N_Timed_Entry_Call + or else Nkind (P) = N_Asynchronous_Select + then + return False; + else + Desc := P; + P := Parent (P); + end if; + end loop; + end; + + -- OK, looks safe to set value + + return True; + end Safe_To_Capture_Value; + + --------------- + -- Same_Name -- + --------------- + + function Same_Name (N1, N2 : Node_Id) return Boolean is + K1 : constant Node_Kind := Nkind (N1); + K2 : constant Node_Kind := Nkind (N2); + + begin + if (K1 = N_Identifier or else K1 = N_Defining_Identifier) + and then (K2 = N_Identifier or else K2 = N_Defining_Identifier) + then + return Chars (N1) = Chars (N2); + + elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name) + and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name) + then + return Same_Name (Selector_Name (N1), Selector_Name (N2)) + and then Same_Name (Prefix (N1), Prefix (N2)); + + else + return False; + end if; + end Same_Name; + + ----------------- + -- Same_Object -- + ----------------- + + function Same_Object (Node1, Node2 : Node_Id) return Boolean is + N1 : constant Node_Id := Original_Node (Node1); + N2 : constant Node_Id := Original_Node (Node2); + -- We do the tests on original nodes, since we are most interested + -- in the original source, not any expansion that got in the way. + + K1 : constant Node_Kind := Nkind (N1); + K2 : constant Node_Kind := Nkind (N2); + + begin + -- First case, both are entities with same entity + + if K1 in N_Has_Entity and then K2 in N_Has_Entity then + declare + EN1 : constant Entity_Id := Entity (N1); + EN2 : constant Entity_Id := Entity (N2); + begin + if Present (EN1) and then Present (EN2) + and then (Ekind_In (EN1, E_Variable, E_Constant) + or else Is_Formal (EN1)) + and then EN1 = EN2 + then + return True; + end if; + end; + end if; + + -- Second case, selected component with same selector, same record + + if K1 = N_Selected_Component + and then K2 = N_Selected_Component + and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2)) + then + return Same_Object (Prefix (N1), Prefix (N2)); + + -- Third case, indexed component with same subscripts, same array + + elsif K1 = N_Indexed_Component + and then K2 = N_Indexed_Component + and then Same_Object (Prefix (N1), Prefix (N2)) + then + declare + E1, E2 : Node_Id; + begin + E1 := First (Expressions (N1)); + E2 := First (Expressions (N2)); + while Present (E1) loop + if not Same_Value (E1, E2) then + return False; + else + Next (E1); + Next (E2); + end if; + end loop; + + return True; + end; + + -- Fourth case, slice of same array with same bounds + + elsif K1 = N_Slice + and then K2 = N_Slice + and then Nkind (Discrete_Range (N1)) = N_Range + and then Nkind (Discrete_Range (N2)) = N_Range + and then Same_Value (Low_Bound (Discrete_Range (N1)), + Low_Bound (Discrete_Range (N2))) + and then Same_Value (High_Bound (Discrete_Range (N1)), + High_Bound (Discrete_Range (N2))) + then + return Same_Name (Prefix (N1), Prefix (N2)); + + -- All other cases, not clearly the same object + + else + return False; + end if; + end Same_Object; + + --------------- + -- Same_Type -- + --------------- + + function Same_Type (T1, T2 : Entity_Id) return Boolean is + begin + if T1 = T2 then + return True; + + elsif not Is_Constrained (T1) + and then not Is_Constrained (T2) + and then Base_Type (T1) = Base_Type (T2) + then + return True; + + -- For now don't bother with case of identical constraints, to be + -- fiddled with later on perhaps (this is only used for optimization + -- purposes, so it is not critical to do a best possible job) + + else + return False; + end if; + end Same_Type; + + ---------------- + -- Same_Value -- + ---------------- + + function Same_Value (Node1, Node2 : Node_Id) return Boolean is + begin + if Compile_Time_Known_Value (Node1) + and then Compile_Time_Known_Value (Node2) + and then Expr_Value (Node1) = Expr_Value (Node2) + then + return True; + elsif Same_Object (Node1, Node2) then + return True; + else + return False; + end if; + end Same_Value; + + ----------------- + -- Save_Actual -- + ----------------- + + procedure Save_Actual (N : Node_Id; Writable : Boolean := False) is + begin + if Ada_Version < Ada_2012 then + return; + + elsif Is_Entity_Name (N) + or else + Nkind_In (N, N_Indexed_Component, N_Selected_Component, N_Slice) + or else + (Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) = Name_Access) + + then + -- We are only interested in IN OUT parameters of inner calls + + if not Writable + or else Nkind (Parent (N)) = N_Function_Call + or else Nkind (Parent (N)) in N_Op + then + Actuals_In_Call.Increment_Last; + Actuals_In_Call.Table (Actuals_In_Call.Last) := (N, Writable); + end if; + end if; + end Save_Actual; + + ------------------------ + -- Scope_Is_Transient -- + ------------------------ + + function Scope_Is_Transient return Boolean is + begin + return Scope_Stack.Table (Scope_Stack.Last).Is_Transient; + end Scope_Is_Transient; + + ------------------ + -- Scope_Within -- + ------------------ + + function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is + Scop : Entity_Id; + + begin + Scop := Scope1; + while Scop /= Standard_Standard loop + Scop := Scope (Scop); + + if Scop = Scope2 then + return True; + end if; + end loop; + + return False; + end Scope_Within; + + -------------------------- + -- Scope_Within_Or_Same -- + -------------------------- + + function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is + Scop : Entity_Id; + + begin + Scop := Scope1; + while Scop /= Standard_Standard loop + if Scop = Scope2 then + return True; + else + Scop := Scope (Scop); + end if; + end loop; + + return False; + end Scope_Within_Or_Same; + + -------------------- + -- Set_Convention -- + -------------------- + + procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is + begin + Basic_Set_Convention (E, Val); + + if Is_Type (E) + and then Is_Access_Subprogram_Type (Base_Type (E)) + and then Has_Foreign_Convention (E) + then + Set_Can_Use_Internal_Rep (E, False); + end if; + end Set_Convention; + + ------------------------ + -- Set_Current_Entity -- + ------------------------ + + -- The given entity is to be set as the currently visible definition + -- of its associated name (i.e. the Node_Id associated with its name). + -- All we have to do is to get the name from the identifier, and + -- then set the associated Node_Id to point to the given entity. + + procedure Set_Current_Entity (E : Entity_Id) is + begin + Set_Name_Entity_Id (Chars (E), E); + end Set_Current_Entity; + + --------------------------- + -- Set_Debug_Info_Needed -- + --------------------------- + + procedure Set_Debug_Info_Needed (T : Entity_Id) is + + procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id); + pragma Inline (Set_Debug_Info_Needed_If_Not_Set); + -- Used to set debug info in a related node if not set already + + -------------------------------------- + -- Set_Debug_Info_Needed_If_Not_Set -- + -------------------------------------- + + procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is + begin + if Present (E) + and then not Needs_Debug_Info (E) + then + Set_Debug_Info_Needed (E); + + -- For a private type, indicate that the full view also needs + -- debug information. + + if Is_Type (E) + and then Is_Private_Type (E) + and then Present (Full_View (E)) + then + Set_Debug_Info_Needed (Full_View (E)); + end if; + end if; + end Set_Debug_Info_Needed_If_Not_Set; + + -- Start of processing for Set_Debug_Info_Needed + + begin + -- Nothing to do if argument is Empty or has Debug_Info_Off set, which + -- indicates that Debug_Info_Needed is never required for the entity. + + if No (T) + or else Debug_Info_Off (T) + then + return; + end if; + + -- Set flag in entity itself. Note that we will go through the following + -- circuitry even if the flag is already set on T. That's intentional, + -- it makes sure that the flag will be set in subsidiary entities. + + Set_Needs_Debug_Info (T); + + -- Set flag on subsidiary entities if not set already + + if Is_Object (T) then + Set_Debug_Info_Needed_If_Not_Set (Etype (T)); + + elsif Is_Type (T) then + Set_Debug_Info_Needed_If_Not_Set (Etype (T)); + + if Is_Record_Type (T) then + declare + Ent : Entity_Id := First_Entity (T); + begin + while Present (Ent) loop + Set_Debug_Info_Needed_If_Not_Set (Ent); + Next_Entity (Ent); + end loop; + end; + + -- For a class wide subtype, we also need debug information + -- for the equivalent type. + + if Ekind (T) = E_Class_Wide_Subtype then + Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T)); + end if; + + elsif Is_Array_Type (T) then + Set_Debug_Info_Needed_If_Not_Set (Component_Type (T)); + + declare + Indx : Node_Id := First_Index (T); + begin + while Present (Indx) loop + Set_Debug_Info_Needed_If_Not_Set (Etype (Indx)); + Indx := Next_Index (Indx); + end loop; + end; + + if Is_Packed (T) then + Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Type (T)); + end if; + + elsif Is_Access_Type (T) then + Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T)); + + elsif Is_Private_Type (T) then + Set_Debug_Info_Needed_If_Not_Set (Full_View (T)); + + elsif Is_Protected_Type (T) then + Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T)); + end if; + end if; + end Set_Debug_Info_Needed; + + --------------------------------- + -- Set_Entity_With_Style_Check -- + --------------------------------- + + procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id) is + Val_Actual : Entity_Id; + Nod : Node_Id; + + begin + Set_Entity (N, Val); + + if Style_Check + and then not Suppress_Style_Checks (Val) + and then not In_Instance + then + if Nkind (N) = N_Identifier then + Nod := N; + elsif Nkind (N) = N_Expanded_Name then + Nod := Selector_Name (N); + else + return; + end if; + + -- A special situation arises for derived operations, where we want + -- to do the check against the parent (since the Sloc of the derived + -- operation points to the derived type declaration itself). + + Val_Actual := Val; + while not Comes_From_Source (Val_Actual) + and then Nkind (Val_Actual) in N_Entity + and then (Ekind (Val_Actual) = E_Enumeration_Literal + or else Is_Subprogram (Val_Actual) + or else Is_Generic_Subprogram (Val_Actual)) + and then Present (Alias (Val_Actual)) + loop + Val_Actual := Alias (Val_Actual); + end loop; + + -- Renaming declarations for generic actuals do not come from source, + -- and have a different name from that of the entity they rename, so + -- there is no style check to perform here. + + if Chars (Nod) = Chars (Val_Actual) then + Style.Check_Identifier (Nod, Val_Actual); + end if; + end if; + + Set_Entity (N, Val); + end Set_Entity_With_Style_Check; + + ------------------------ + -- Set_Name_Entity_Id -- + ------------------------ + + procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is + begin + Set_Name_Table_Info (Id, Int (Val)); + end Set_Name_Entity_Id; + + --------------------- + -- Set_Next_Actual -- + --------------------- + + procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is + begin + if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then + Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id); + end if; + end Set_Next_Actual; + + ---------------------------------- + -- Set_Optimize_Alignment_Flags -- + ---------------------------------- + + procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is + begin + if Optimize_Alignment = 'S' then + Set_Optimize_Alignment_Space (E); + elsif Optimize_Alignment = 'T' then + Set_Optimize_Alignment_Time (E); + end if; + end Set_Optimize_Alignment_Flags; + + ----------------------- + -- Set_Public_Status -- + ----------------------- + + procedure Set_Public_Status (Id : Entity_Id) is + S : constant Entity_Id := Current_Scope; + + function Within_HSS_Or_If (E : Entity_Id) return Boolean; + -- Determines if E is defined within handled statement sequence or + -- an if statement, returns True if so, False otherwise. + + ---------------------- + -- Within_HSS_Or_If -- + ---------------------- + + function Within_HSS_Or_If (E : Entity_Id) return Boolean is + N : Node_Id; + begin + N := Declaration_Node (E); + loop + N := Parent (N); + + if No (N) then + return False; + + elsif Nkind_In (N, N_Handled_Sequence_Of_Statements, + N_If_Statement) + then + return True; + end if; + end loop; + end Within_HSS_Or_If; + + -- Start of processing for Set_Public_Status + + begin + -- Everything in the scope of Standard is public + + if S = Standard_Standard then + Set_Is_Public (Id); + + -- Entity is definitely not public if enclosing scope is not public + + elsif not Is_Public (S) then + return; + + -- An object or function declaration that occurs in a handled sequence + -- of statements or within an if statement is the declaration for a + -- temporary object or local subprogram generated by the expander. It + -- never needs to be made public and furthermore, making it public can + -- cause back end problems. + + elsif Nkind_In (Parent (Id), N_Object_Declaration, + N_Function_Specification) + and then Within_HSS_Or_If (Id) + then + return; + + -- Entities in public packages or records are public + + elsif Ekind (S) = E_Package or Is_Record_Type (S) then + Set_Is_Public (Id); + + -- The bounds of an entry family declaration can generate object + -- declarations that are visible to the back-end, e.g. in the + -- the declaration of a composite type that contains tasks. + + elsif Is_Concurrent_Type (S) + and then not Has_Completion (S) + and then Nkind (Parent (Id)) = N_Object_Declaration + then + Set_Is_Public (Id); + end if; + end Set_Public_Status; + + ----------------------------- + -- Set_Referenced_Modified -- + ----------------------------- + + procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is + Pref : Node_Id; + + begin + -- Deal with indexed or selected component where prefix is modified + + if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then + Pref := Prefix (N); + + -- If prefix is access type, then it is the designated object that is + -- being modified, which means we have no entity to set the flag on. + + if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then + return; + + -- Otherwise chase the prefix + + else + Set_Referenced_Modified (Pref, Out_Param); + end if; + + -- Otherwise see if we have an entity name (only other case to process) + + elsif Is_Entity_Name (N) and then Present (Entity (N)) then + Set_Referenced_As_LHS (Entity (N), not Out_Param); + Set_Referenced_As_Out_Parameter (Entity (N), Out_Param); + end if; + end Set_Referenced_Modified; + + ---------------------------- + -- Set_Scope_Is_Transient -- + ---------------------------- + + procedure Set_Scope_Is_Transient (V : Boolean := True) is + begin + Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V; + end Set_Scope_Is_Transient; + + ------------------- + -- Set_Size_Info -- + ------------------- + + procedure Set_Size_Info (T1, T2 : Entity_Id) is + begin + -- We copy Esize, but not RM_Size, since in general RM_Size is + -- subtype specific and does not get inherited by all subtypes. + + Set_Esize (T1, Esize (T2)); + Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2)); + + if Is_Discrete_Or_Fixed_Point_Type (T1) + and then + Is_Discrete_Or_Fixed_Point_Type (T2) + then + Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2)); + end if; + + Set_Alignment (T1, Alignment (T2)); + end Set_Size_Info; + + -------------------- + -- Static_Integer -- + -------------------- + + function Static_Integer (N : Node_Id) return Uint is + begin + Analyze_And_Resolve (N, Any_Integer); + + if N = Error + or else Error_Posted (N) + or else Etype (N) = Any_Type + then + return No_Uint; + end if; + + if Is_Static_Expression (N) then + if not Raises_Constraint_Error (N) then + return Expr_Value (N); + else + return No_Uint; + end if; + + elsif Etype (N) = Any_Type then + return No_Uint; + + else + Flag_Non_Static_Expr + ("static integer expression required here", N); + return No_Uint; + end if; + end Static_Integer; + + -------------------------- + -- Statically_Different -- + -------------------------- + + function Statically_Different (E1, E2 : Node_Id) return Boolean is + R1 : constant Node_Id := Get_Referenced_Object (E1); + R2 : constant Node_Id := Get_Referenced_Object (E2); + begin + return Is_Entity_Name (R1) + and then Is_Entity_Name (R2) + and then Entity (R1) /= Entity (R2) + and then not Is_Formal (Entity (R1)) + and then not Is_Formal (Entity (R2)); + end Statically_Different; + + ----------------------------- + -- Subprogram_Access_Level -- + ----------------------------- + + function Subprogram_Access_Level (Subp : Entity_Id) return Uint is + begin + if Present (Alias (Subp)) then + return Subprogram_Access_Level (Alias (Subp)); + else + return Scope_Depth (Enclosing_Dynamic_Scope (Subp)); + end if; + end Subprogram_Access_Level; + + ----------------- + -- Trace_Scope -- + ----------------- + + procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is + begin + if Debug_Flag_W then + for J in 0 .. Scope_Stack.Last loop + Write_Str (" "); + end loop; + + Write_Str (Msg); + Write_Name (Chars (E)); + Write_Str (" from "); + Write_Location (Sloc (N)); + Write_Eol; + end if; + end Trace_Scope; + + ----------------------- + -- Transfer_Entities -- + ----------------------- + + procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is + Ent : Entity_Id := First_Entity (From); + + begin + if No (Ent) then + return; + end if; + + if (Last_Entity (To)) = Empty then + Set_First_Entity (To, Ent); + else + Set_Next_Entity (Last_Entity (To), Ent); + end if; + + Set_Last_Entity (To, Last_Entity (From)); + + while Present (Ent) loop + Set_Scope (Ent, To); + + if not Is_Public (Ent) then + Set_Public_Status (Ent); + + if Is_Public (Ent) + and then Ekind (Ent) = E_Record_Subtype + + then + -- The components of the propagated Itype must be public + -- as well. + + declare + Comp : Entity_Id; + begin + Comp := First_Entity (Ent); + while Present (Comp) loop + Set_Is_Public (Comp); + Next_Entity (Comp); + end loop; + end; + end if; + end if; + + Next_Entity (Ent); + end loop; + + Set_First_Entity (From, Empty); + Set_Last_Entity (From, Empty); + end Transfer_Entities; + + ----------------------- + -- Type_Access_Level -- + ----------------------- + + function Type_Access_Level (Typ : Entity_Id) return Uint is + Btyp : Entity_Id; + + begin + Btyp := Base_Type (Typ); + + -- Ada 2005 (AI-230): For most cases of anonymous access types, we + -- simply use the level where the type is declared. This is true for + -- stand-alone object declarations, and for anonymous access types + -- associated with components the level is the same as that of the + -- enclosing composite type. However, special treatment is needed for + -- the cases of access parameters, return objects of an anonymous access + -- type, and, in Ada 95, access discriminants of limited types. + + if Ekind (Btyp) in Access_Kind then + if Ekind (Btyp) = E_Anonymous_Access_Type then + + -- If the type is a nonlocal anonymous access type (such as for + -- an access parameter) we treat it as being declared at the + -- library level to ensure that names such as X.all'access don't + -- fail static accessibility checks. + + if not Is_Local_Anonymous_Access (Typ) then + return Scope_Depth (Standard_Standard); + + -- If this is a return object, the accessibility level is that of + -- the result subtype of the enclosing function. The test here is + -- little complicated, because we have to account for extended + -- return statements that have been rewritten as blocks, in which + -- case we have to find and the Is_Return_Object attribute of the + -- itype's associated object. It would be nice to find a way to + -- simplify this test, but it doesn't seem worthwhile to add a new + -- flag just for purposes of this test. ??? + + elsif Ekind (Scope (Btyp)) = E_Return_Statement + or else + (Is_Itype (Btyp) + and then Nkind (Associated_Node_For_Itype (Btyp)) = + N_Object_Declaration + and then Is_Return_Object + (Defining_Identifier + (Associated_Node_For_Itype (Btyp)))) + then + declare + Scop : Entity_Id; + + begin + Scop := Scope (Scope (Btyp)); + while Present (Scop) loop + exit when Ekind (Scop) = E_Function; + Scop := Scope (Scop); + end loop; + + -- Treat the return object's type as having the level of the + -- function's result subtype (as per RM05-6.5(5.3/2)). + + return Type_Access_Level (Etype (Scop)); + end; + end if; + end if; + + Btyp := Root_Type (Btyp); + + -- The accessibility level of anonymous access types associated with + -- discriminants is that of the current instance of the type, and + -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)). + + -- AI-402: access discriminants have accessibility based on the + -- object rather than the type in Ada 2005, so the above paragraph + -- doesn't apply. + + -- ??? Needs completion with rules from AI-416 + + if Ada_Version <= Ada_95 + and then Ekind (Typ) = E_Anonymous_Access_Type + and then Present (Associated_Node_For_Itype (Typ)) + and then Nkind (Associated_Node_For_Itype (Typ)) = + N_Discriminant_Specification + then + return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1; + end if; + end if; + + return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); + end Type_Access_Level; + + -------------------------- + -- Unit_Declaration_Node -- + -------------------------- + + function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is + N : Node_Id := Parent (Unit_Id); + + begin + -- Predefined operators do not have a full function declaration + + if Ekind (Unit_Id) = E_Operator then + return N; + end if; + + -- Isn't there some better way to express the following ??? + + while Nkind (N) /= N_Abstract_Subprogram_Declaration + and then Nkind (N) /= N_Formal_Package_Declaration + and then Nkind (N) /= N_Function_Instantiation + and then Nkind (N) /= N_Generic_Package_Declaration + and then Nkind (N) /= N_Generic_Subprogram_Declaration + and then Nkind (N) /= N_Package_Declaration + and then Nkind (N) /= N_Package_Body + and then Nkind (N) /= N_Package_Instantiation + and then Nkind (N) /= N_Package_Renaming_Declaration + and then Nkind (N) /= N_Procedure_Instantiation + and then Nkind (N) /= N_Protected_Body + and then Nkind (N) /= N_Subprogram_Declaration + and then Nkind (N) /= N_Subprogram_Body + and then Nkind (N) /= N_Subprogram_Body_Stub + and then Nkind (N) /= N_Subprogram_Renaming_Declaration + and then Nkind (N) /= N_Task_Body + and then Nkind (N) /= N_Task_Type_Declaration + and then Nkind (N) not in N_Formal_Subprogram_Declaration + and then Nkind (N) not in N_Generic_Renaming_Declaration + loop + N := Parent (N); + pragma Assert (Present (N)); + end loop; + + return N; + end Unit_Declaration_Node; + + ------------------------------ + -- Universal_Interpretation -- + ------------------------------ + + function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is + Index : Interp_Index; + It : Interp; + + begin + -- The argument may be a formal parameter of an operator or subprogram + -- with multiple interpretations, or else an expression for an actual. + + if Nkind (Opnd) = N_Defining_Identifier + or else not Is_Overloaded (Opnd) + then + if Etype (Opnd) = Universal_Integer + or else Etype (Opnd) = Universal_Real + then + return Etype (Opnd); + else + return Empty; + end if; + + else + Get_First_Interp (Opnd, Index, It); + while Present (It.Typ) loop + if It.Typ = Universal_Integer + or else It.Typ = Universal_Real + then + return It.Typ; + end if; + + Get_Next_Interp (Index, It); + end loop; + + return Empty; + end if; + end Universal_Interpretation; + + --------------- + -- Unqualify -- + --------------- + + function Unqualify (Expr : Node_Id) return Node_Id is + begin + -- Recurse to handle unlikely case of multiple levels of qualification + + if Nkind (Expr) = N_Qualified_Expression then + return Unqualify (Expression (Expr)); + + -- Normal case, not a qualified expression + + else + return Expr; + end if; + end Unqualify; + + ----------------------- + -- Visible_Ancestors -- + ----------------------- + + function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is + List_1 : Elist_Id; + List_2 : Elist_Id; + Elmt : Elmt_Id; + + begin + pragma Assert (Is_Record_Type (Typ) + and then Is_Tagged_Type (Typ)); + + -- Collect all the parents and progenitors of Typ. If the full-view of + -- private parents and progenitors is available then it is used to + -- generate the list of visible ancestors; otherwise their partial + -- view is added to the resulting list. + + Collect_Parents + (T => Typ, + List => List_1, + Use_Full_View => True); + + Collect_Interfaces + (T => Typ, + Ifaces_List => List_2, + Exclude_Parents => True, + Use_Full_View => True); + + -- Join the two lists. Avoid duplications because an interface may + -- simultaneously be parent and progenitor of a type. + + Elmt := First_Elmt (List_2); + while Present (Elmt) loop + Append_Unique_Elmt (Node (Elmt), List_1); + Next_Elmt (Elmt); + end loop; + + return List_1; + end Visible_Ancestors; + + ---------------------- + -- Within_Init_Proc -- + ---------------------- + + function Within_Init_Proc return Boolean is + S : Entity_Id; + + begin + S := Current_Scope; + while not Is_Overloadable (S) loop + if S = Standard_Standard then + return False; + else + S := Scope (S); + end if; + end loop; + + return Is_Init_Proc (S); + end Within_Init_Proc; + + ---------------- + -- Wrong_Type -- + ---------------- + + procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is + Found_Type : constant Entity_Id := First_Subtype (Etype (Expr)); + Expec_Type : constant Entity_Id := First_Subtype (Expected_Type); + + function Has_One_Matching_Field return Boolean; + -- Determines if Expec_Type is a record type with a single component or + -- discriminant whose type matches the found type or is one dimensional + -- array whose component type matches the found type. + + ---------------------------- + -- Has_One_Matching_Field -- + ---------------------------- + + function Has_One_Matching_Field return Boolean is + E : Entity_Id; + + begin + if Is_Array_Type (Expec_Type) + and then Number_Dimensions (Expec_Type) = 1 + and then + Covers (Etype (Component_Type (Expec_Type)), Found_Type) + then + return True; + + elsif not Is_Record_Type (Expec_Type) then + return False; + + else + E := First_Entity (Expec_Type); + loop + if No (E) then + return False; + + elsif (Ekind (E) /= E_Discriminant + and then Ekind (E) /= E_Component) + or else (Chars (E) = Name_uTag + or else Chars (E) = Name_uParent) + then + Next_Entity (E); + + else + exit; + end if; + end loop; + + if not Covers (Etype (E), Found_Type) then + return False; + + elsif Present (Next_Entity (E)) then + return False; + + else + return True; + end if; + end if; + end Has_One_Matching_Field; + + -- Start of processing for Wrong_Type + + begin + -- Don't output message if either type is Any_Type, or if a message + -- has already been posted for this node. We need to do the latter + -- check explicitly (it is ordinarily done in Errout), because we + -- are using ! to force the output of the error messages. + + if Expec_Type = Any_Type + or else Found_Type = Any_Type + or else Error_Posted (Expr) + then + return; + + -- In an instance, there is an ongoing problem with completion of + -- type derived from private types. Their structure is what Gigi + -- expects, but the Etype is the parent type rather than the + -- derived private type itself. Do not flag error in this case. The + -- private completion is an entity without a parent, like an Itype. + -- Similarly, full and partial views may be incorrect in the instance. + -- There is no simple way to insure that it is consistent ??? + + elsif In_Instance then + if Etype (Etype (Expr)) = Etype (Expected_Type) + and then + (Has_Private_Declaration (Expected_Type) + or else Has_Private_Declaration (Etype (Expr))) + and then No (Parent (Expected_Type)) + then + return; + end if; + end if; + + -- An interesting special check. If the expression is parenthesized + -- and its type corresponds to the type of the sole component of the + -- expected record type, or to the component type of the expected one + -- dimensional array type, then assume we have a bad aggregate attempt. + + if Nkind (Expr) in N_Subexpr + and then Paren_Count (Expr) /= 0 + and then Has_One_Matching_Field + then + Error_Msg_N ("positional aggregate cannot have one component", Expr); + + -- Another special check, if we are looking for a pool-specific access + -- type and we found an E_Access_Attribute_Type, then we have the case + -- of an Access attribute being used in a context which needs a pool- + -- specific type, which is never allowed. The one extra check we make + -- is that the expected designated type covers the Found_Type. + + elsif Is_Access_Type (Expec_Type) + and then Ekind (Found_Type) = E_Access_Attribute_Type + and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type + and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type + and then Covers + (Designated_Type (Expec_Type), Designated_Type (Found_Type)) + then + Error_Msg_N -- CODEFIX + ("result must be general access type!", Expr); + Error_Msg_NE -- CODEFIX + ("add ALL to }!", Expr, Expec_Type); + + -- Another special check, if the expected type is an integer type, + -- but the expression is of type System.Address, and the parent is + -- an addition or subtraction operation whose left operand is the + -- expression in question and whose right operand is of an integral + -- type, then this is an attempt at address arithmetic, so give + -- appropriate message. + + elsif Is_Integer_Type (Expec_Type) + and then Is_RTE (Found_Type, RE_Address) + and then (Nkind (Parent (Expr)) = N_Op_Add + or else + Nkind (Parent (Expr)) = N_Op_Subtract) + and then Expr = Left_Opnd (Parent (Expr)) + and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr)))) + then + Error_Msg_N + ("address arithmetic not predefined in package System", + Parent (Expr)); + Error_Msg_N + ("\possible missing with/use of System.Storage_Elements", + Parent (Expr)); + return; + + -- If the expected type is an anonymous access type, as for access + -- parameters and discriminants, the error is on the designated types. + + elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then + if Comes_From_Source (Expec_Type) then + Error_Msg_NE ("expected}!", Expr, Expec_Type); + else + Error_Msg_NE + ("expected an access type with designated}", + Expr, Designated_Type (Expec_Type)); + end if; + + if Is_Access_Type (Found_Type) + and then not Comes_From_Source (Found_Type) + then + Error_Msg_NE + ("\\found an access type with designated}!", + Expr, Designated_Type (Found_Type)); + else + if From_With_Type (Found_Type) then + Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type); + Error_Msg_Qual_Level := 99; + Error_Msg_NE -- CODEFIX + ("\\missing `WITH &;", Expr, Scope (Found_Type)); + Error_Msg_Qual_Level := 0; + else + Error_Msg_NE ("found}!", Expr, Found_Type); + end if; + end if; + + -- Normal case of one type found, some other type expected + + else + -- If the names of the two types are the same, see if some number + -- of levels of qualification will help. Don't try more than three + -- levels, and if we get to standard, it's no use (and probably + -- represents an error in the compiler) Also do not bother with + -- internal scope names. + + declare + Expec_Scope : Entity_Id; + Found_Scope : Entity_Id; + + begin + Expec_Scope := Expec_Type; + Found_Scope := Found_Type; + + for Levels in Int range 0 .. 3 loop + if Chars (Expec_Scope) /= Chars (Found_Scope) then + Error_Msg_Qual_Level := Levels; + exit; + end if; + + Expec_Scope := Scope (Expec_Scope); + Found_Scope := Scope (Found_Scope); + + exit when Expec_Scope = Standard_Standard + or else Found_Scope = Standard_Standard + or else not Comes_From_Source (Expec_Scope) + or else not Comes_From_Source (Found_Scope); + end loop; + end; + + if Is_Record_Type (Expec_Type) + and then Present (Corresponding_Remote_Type (Expec_Type)) + then + Error_Msg_NE ("expected}!", Expr, + Corresponding_Remote_Type (Expec_Type)); + else + Error_Msg_NE ("expected}!", Expr, Expec_Type); + end if; + + if Is_Entity_Name (Expr) + and then Is_Package_Or_Generic_Package (Entity (Expr)) + then + Error_Msg_N ("\\found package name!", Expr); + + elsif Is_Entity_Name (Expr) + and then + (Ekind (Entity (Expr)) = E_Procedure + or else + Ekind (Entity (Expr)) = E_Generic_Procedure) + then + if Ekind (Expec_Type) = E_Access_Subprogram_Type then + Error_Msg_N + ("found procedure name, possibly missing Access attribute!", + Expr); + else + Error_Msg_N + ("\\found procedure name instead of function!", Expr); + end if; + + elsif Nkind (Expr) = N_Function_Call + and then Ekind (Expec_Type) = E_Access_Subprogram_Type + and then Etype (Designated_Type (Expec_Type)) = Etype (Expr) + and then No (Parameter_Associations (Expr)) + then + Error_Msg_N + ("found function name, possibly missing Access attribute!", + Expr); + + -- Catch common error: a prefix or infix operator which is not + -- directly visible because the type isn't. + + elsif Nkind (Expr) in N_Op + and then Is_Overloaded (Expr) + and then not Is_Immediately_Visible (Expec_Type) + and then not Is_Potentially_Use_Visible (Expec_Type) + and then not In_Use (Expec_Type) + and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type) + then + Error_Msg_N + ("operator of the type is not directly visible!", Expr); + + elsif Ekind (Found_Type) = E_Void + and then Present (Parent (Found_Type)) + and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration + then + Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type); + + else + Error_Msg_NE ("\\found}!", Expr, Found_Type); + end if; + + -- A special check for cases like M1 and M2 = 0 where M1 and M2 are + -- of the same modular type, and (M1 and M2) = 0 was intended. + + if Expec_Type = Standard_Boolean + and then Is_Modular_Integer_Type (Found_Type) + and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor) + and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare + then + declare + Op : constant Node_Id := Right_Opnd (Parent (Expr)); + L : constant Node_Id := Left_Opnd (Op); + R : constant Node_Id := Right_Opnd (Op); + begin + -- The case for the message is when the left operand of the + -- comparison is the same modular type, or when it is an + -- integer literal (or other universal integer expression), + -- which would have been typed as the modular type if the + -- parens had been there. + + if (Etype (L) = Found_Type + or else + Etype (L) = Universal_Integer) + and then Is_Integer_Type (Etype (R)) + then + Error_Msg_N + ("\\possible missing parens for modular operation", Expr); + end if; + end; + end if; + + -- Reset error message qualification indication + + Error_Msg_Qual_Level := 0; + end if; + end Wrong_Type; + +end Sem_Util; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads new file mode 100644 index 000000000..40a3df32c --- /dev/null +++ b/gcc/ada/sem_util.ads @@ -0,0 +1,1336 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ U T I L -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Package containing utility procedures used throughout the semantics + +with Einfo; use Einfo; +with Namet; use Namet; +with Nmake; use Nmake; +with Snames; use Snames; +with Types; use Types; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package Sem_Util is + + function Abstract_Interface_List (Typ : Entity_Id) return List_Id; + -- Given a type that implements interfaces look for its associated + -- definition node and return its list of interfaces. + + procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id); + -- Add A to the list of access types to process when expanding the + -- freeze node of E. + + procedure Add_Global_Declaration (N : Node_Id); + -- These procedures adds a declaration N at the library level, to be + -- elaborated before any other code in the unit. It is used for example + -- for the entity that marks whether a unit has been elaborated. The + -- declaration is added to the Declarations list of the Aux_Decls_Node + -- for the current unit. The declarations are added in the current scope, + -- so the caller should push a new scope as required before the call. + + function Addressable (V : Uint) return Boolean; + function Addressable (V : Int) return Boolean; + pragma Inline (Addressable); + -- Returns True if the value of V is the word size of an addressable + -- factor of the word size (typically 8, 16, 32 or 64). + + function Alignment_In_Bits (E : Entity_Id) return Uint; + -- If the alignment of the type or object E is currently known to the + -- compiler, then this function returns the alignment value in bits. + -- Otherwise Uint_0 is returned, indicating that the alignment of the + -- entity is not yet known to the compiler. + + procedure Apply_Compile_Time_Constraint_Error + (N : Node_Id; + Msg : String; + Reason : RT_Exception_Code; + Ent : Entity_Id := Empty; + Typ : Entity_Id := Empty; + Loc : Source_Ptr := No_Location; + Rep : Boolean := True; + Warn : Boolean := False); + -- N is a subexpression which will raise constraint error when evaluated + -- at runtime. Msg is a message that explains the reason for raising the + -- exception. The last character is ? if the message is always a warning, + -- even in Ada 95, and is not a ? if the message represents an illegality + -- (because of violation of static expression rules) in Ada 95 (but not + -- in Ada 83). Typically this routine posts all messages at the Sloc of + -- node N. However, if Loc /= No_Location, Loc is the Sloc used to output + -- the message. After posting the appropriate message, and if the flag + -- Rep is set, this routine replaces the expression with an appropriate + -- N_Raise_Constraint_Error node using the given Reason code. This node + -- is then marked as being static if the original node is static, but + -- sets the flag Raises_Constraint_Error, preventing further evaluation. + -- The error message may contain a } or & insertion character. This + -- normally references Etype (N), unless the Ent argument is given + -- explicitly, in which case it is used instead. The type of the raise + -- node that is built is normally Etype (N), but if the Typ parameter + -- is present, this is used instead. Warn is normally False. If it is + -- True then the message is treated as a warning even though it does + -- not end with a ? (this is used when the caller wants to parameterize + -- whether an error or warning is given. + + procedure Bad_Predicated_Subtype_Use + (Msg : String; + N : Node_Id; + Typ : Entity_Id); + -- This is called when Typ, a predicated subtype, is used in a context + -- which does not allow the use of a predicated subtype. Msg is passed + -- to Error_Msg_FE to output an appropriate message using N as the + -- location, and Typ as the entity. The caller must set up any insertions + -- other than the & for the type itself. Note that if Typ is a generic + -- actual type, then the message will be output as a warning, and a + -- raise Program_Error is inserted using Insert_Action with node N as + -- the insertion point. Node N also supplies the source location for + -- construction of the raise node. If Typ is NOT a type with predicates + -- this call has no effect. + + function Build_Actual_Subtype + (T : Entity_Id; + N : Node_Or_Entity_Id) return Node_Id; + -- Build an anonymous subtype for an entity or expression, using the + -- bounds of the entity or the discriminants of the enclosing record. + -- T is the type for which the actual subtype is required, and N is either + -- a defining identifier, or any subexpression. + + function Build_Actual_Subtype_Of_Component + (T : Entity_Id; + N : Node_Id) return Node_Id; + -- Determine whether a selected component has a type that depends on + -- discriminants, and build actual subtype for it if so. + + function Build_Default_Subtype + (T : Entity_Id; + N : Node_Id) return Entity_Id; + -- If T is an unconstrained type with defaulted discriminants, build a + -- subtype constrained by the default values, insert the subtype + -- declaration in the tree before N, and return the entity of that + -- subtype. Otherwise, simply return T. + + function Build_Discriminal_Subtype_Of_Component + (T : Entity_Id) return Node_Id; + -- Determine whether a record component has a type that depends on + -- discriminants, and build actual subtype for it if so. + + procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id); + -- Given a compilation unit node N, allocate an elaboration boolean for + -- the compilation unit, and install it in the Elaboration_Entity field + -- of Spec_Id, the entity for the compilation unit. + + function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean; + -- Returns True if the expression cannot possibly raise Constraint_Error. + -- The response is conservative in the sense that a result of False does + -- not necessarily mean that CE could be raised, but a response of True + -- means that for sure CE cannot be raised. + + procedure Check_Dynamically_Tagged_Expression + (Expr : Node_Id; + Typ : Entity_Id; + Related_Nod : Node_Id); + -- Check wrong use of dynamically tagged expression + + procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id); + -- Verify that the full declaration of type T has been seen. If not, place + -- error message on node N. Used in object declarations, type conversions + -- and qualified expressions. + + procedure Check_Nested_Access (Ent : Entity_Id); + -- Check whether Ent denotes an entity declared in an uplevel scope, which + -- is accessed inside a nested procedure, and set Has_Up_Level_Access flag + -- accordingly. This is currently only enabled for VM_Target /= No_VM. + + procedure Check_Order_Dependence; + -- Examine the actuals in a top-level call to determine whether aliasing + -- between two actuals, one of which is writable, can make the call + -- order-dependent. + + procedure Check_Potentially_Blocking_Operation (N : Node_Id); + -- N is one of the statement forms that is a potentially blocking + -- operation. If it appears within a protected action, emit warning. + + procedure Check_Unprotected_Access + (Context : Node_Id; + Expr : Node_Id); + -- Check whether the expression is a pointer to a protected component, + -- and the context is external to the protected operation, to warn against + -- a possible unlocked access to data. + + procedure Check_VMS (Construct : Node_Id); + -- Check that this the target is OpenVMS, and if so, return with no effect, + -- otherwise post an error noting this can only be used with OpenVMS ports. + -- The argument is the construct in question and is used to post the error + -- message. + + procedure Collect_Interfaces + (T : Entity_Id; + Ifaces_List : out Elist_Id; + Exclude_Parents : Boolean := False; + Use_Full_View : Boolean := True); + -- Ada 2005 (AI-251): Collect whole list of abstract interfaces that are + -- directly or indirectly implemented by T. Exclude_Parents is used to + -- avoid the addition of inherited interfaces to the generated list. + -- Use_Full_View is used to collect the interfaces using the full-view + -- (if available). + + procedure Collect_Interface_Components + (Tagged_Type : Entity_Id; + Components_List : out Elist_Id); + -- Ada 2005 (AI-251): Collect all the tag components associated with the + -- secondary dispatch tables of a tagged type. + + procedure Collect_Interfaces_Info + (T : Entity_Id; + Ifaces_List : out Elist_Id; + Components_List : out Elist_Id; + Tags_List : out Elist_Id); + -- Ada 2005 (AI-251): Collect all the interfaces associated with T plus + -- the record component and tag associated with each of these interfaces. + -- On exit Ifaces_List, Components_List and Tags_List have the same number + -- of elements, and elements at the same position on these tables provide + -- information on the same interface type. + + procedure Collect_Parents + (T : Entity_Id; + List : out Elist_Id; + Use_Full_View : Boolean := True); + -- Collect all the parents of Typ. Use_Full_View is used to collect them + -- using the full-view of private parents (if available). + + function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id; + -- Called upon type derivation and extension. We scan the declarative part + -- in which the type appears, and collect subprograms that have one + -- subsidiary subtype of the type. These subprograms can only appear after + -- the type itself. + + function Compile_Time_Constraint_Error + (N : Node_Id; + Msg : String; + Ent : Entity_Id := Empty; + Loc : Source_Ptr := No_Location; + Warn : Boolean := False) return Node_Id; + -- This is similar to Apply_Compile_Time_Constraint_Error in that it + -- generates a warning (or error) message in the same manner, but it does + -- not replace any nodes. For convenience, the function always returns its + -- first argument. The message is a warning if the message ends with ?, or + -- we are operating in Ada 83 mode, or the Warn parameter is set to True. + + procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id); + -- Sets the Has_Delayed_Freeze flag of New if the Delayed_Freeze flag of + -- Old is set and Old has no yet been Frozen (i.e. Is_Frozen is false). + + function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id; + -- Utility to create a parameter profile for a new subprogram spec, when + -- the subprogram has a body that acts as spec. This is done for some cases + -- of inlining, and for private protected ops. Also used to create bodies + -- for stubbed subprograms. + + function Current_Entity (N : Node_Id) return Entity_Id; + pragma Inline (Current_Entity); + -- Find the currently visible definition for a given identifier, that is to + -- say the first entry in the visibility chain for the Chars of N. + + function Current_Entity_In_Scope (N : Node_Id) return Entity_Id; + -- Find whether there is a previous definition for identifier N in the + -- current scope. Because declarations for a scope are not necessarily + -- contiguous (e.g. for packages) the first entry on the visibility chain + -- for N is not necessarily in the current scope. + + function Current_Scope return Entity_Id; + -- Get entity representing current scope + + function Current_Subprogram return Entity_Id; + -- Returns current enclosing subprogram. If Current_Scope is a subprogram, + -- then that is what is returned, otherwise the Enclosing_Subprogram of the + -- Current_Scope is returned. The returned value is Empty if this is called + -- from a library package which is not within any subprogram. + + function Defining_Entity (N : Node_Id) return Entity_Id; + -- Given a declaration N, returns the associated defining entity. If the + -- declaration has a specification, the entity is obtained from the + -- specification. If the declaration has a defining unit name, then the + -- defining entity is obtained from the defining unit name ignoring any + -- child unit prefixes. + + function Denotes_Discriminant + (N : Node_Id; + Check_Concurrent : Boolean := False) return Boolean; + -- Returns True if node N is an Entity_Name node for a discriminant. If the + -- flag Check_Concurrent is true, function also returns true when N denotes + -- the discriminal of the discriminant of a concurrent type. This is needed + -- to disable some optimizations on private components of protected types, + -- and constraint checks on entry families constrained by discriminants. + + function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean; + function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean; + -- Functions to detect suspicious overlapping between actuals in a call, + -- when one of them is writable. The predicates are those proposed in + -- AI05-0144, to detect dangerous order dependence in complex calls. + -- I would add a parameter Warn which enables more extensive testing of + -- cases as we find appropriate when we are only warning ??? Or perhaps + -- return an indication of (Error, Warn, OK) ??? + + function Denotes_Variable (N : Node_Id) return Boolean; + -- Returns True if node N denotes a single variable without parentheses + + function Depends_On_Discriminant (N : Node_Id) return Boolean; + -- Returns True if N denotes a discriminant or if N is a range, a subtype + -- indication or a scalar subtype where one of the bounds is a + -- discriminant. + + function Designate_Same_Unit + (Name1 : Node_Id; + Name2 : Node_Id) return Boolean; + -- Return true if Name1 and Name2 designate the same unit name; each of + -- these names is supposed to be a selected component name, an expanded + -- name, a defining program unit name or an identifier. + + function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id; + -- Returns the closest ancestor of Typ that is a CPP type. + + function Enclosing_Generic_Body + (N : Node_Id) return Node_Id; + -- Returns the Node_Id associated with the innermost enclosing generic + -- body, if any. If none, then returns Empty. + + function Enclosing_Generic_Unit + (N : Node_Id) return Node_Id; + -- Returns the Node_Id associated with the innermost enclosing generic + -- unit, if any. If none, then returns Empty. + + function Enclosing_Lib_Unit_Entity return Entity_Id; + -- Returns the entity of enclosing N_Compilation_Unit Node which is the + -- root of the current scope (which must not be Standard_Standard, and the + -- caller is responsible for ensuring this condition). + + function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id; + -- Returns the enclosing N_Compilation_Unit Node that is the root of a + -- subtree containing N. + + function Enclosing_Subprogram (E : Entity_Id) return Entity_Id; + -- Utility function to return the Ada entity of the subprogram enclosing + -- the entity E, if any. Returns Empty if no enclosing subprogram. + + procedure Ensure_Freeze_Node (E : Entity_Id); + -- Make sure a freeze node is allocated for entity E. If necessary, build + -- and initialize a new freeze node and set Has_Delayed_Freeze True for E. + + procedure Enter_Name (Def_Id : Entity_Id); + -- Insert new name in symbol table of current scope with check for + -- duplications (error message is issued if a conflict is found). + -- Note: Enter_Name is not used for overloadable entities, instead these + -- are entered using Sem_Ch6.Enter_Overloadable_Entity. + + procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id); + -- This procedure is called after issuing a message complaining about an + -- inappropriate use of limited type T. If useful, it adds additional + -- continuation lines to the message explaining why type T is limited. + -- Messages are placed at node N. + + procedure Find_Actual + (N : Node_Id; + Formal : out Entity_Id; + Call : out Node_Id); + -- Determines if the node N is an actual parameter of a procedure call. If + -- so, then Formal points to the entity for the formal (whose Ekind is one + -- of E_In_Parameter, E_Out_Parameter, E_In_Out_Parameter) and Call is set + -- to the node for the corresponding call. If the node N is not an actual + -- parameter, or is an actual parameter of a function call, then Formal and + -- Call are set to Empty. + + function Find_Corresponding_Discriminant + (Id : Node_Id; + Typ : Entity_Id) return Entity_Id; + -- Because discriminants may have different names in a generic unit and in + -- an instance, they are resolved positionally when possible. A reference + -- to a discriminant carries the discriminant that it denotes when it is + -- analyzed. Subsequent uses of this id on a different type denotes the + -- discriminant at the same position in this new type. + + procedure Find_Overlaid_Entity + (N : Node_Id; + Ent : out Entity_Id; + Off : out Boolean); + -- The node N should be an address representation clause. Determines if the + -- target expression is the address of an entity with an optional offset. + -- If so, Ent is set to the entity and, if there is an offset, Off is set + -- to True, otherwise to False. If N is not an address representation + -- clause, or if it is not possible to determine that the address is of + -- this form, then Ent is set to Empty, and Off is set to False. + + function Find_Parameter_Type (Param : Node_Id) return Entity_Id; + -- Return the type of formal parameter Param as determined by its + -- specification. + + function Find_Static_Alternative (N : Node_Id) return Node_Id; + -- N is a case statement whose expression is a compile-time value. + -- Determine the alternative chosen, so that the code of non-selected + -- alternatives, and the warnings that may apply to them, are removed. + + function Find_Body_Discriminal + (Spec_Discriminant : Entity_Id) return Entity_Id; + -- Given a discriminant of the record type that implements a task or + -- protected type, return the discriminal of the corresponding discriminant + -- of the actual concurrent type. + + function First_Actual (Node : Node_Id) return Node_Id; + -- Node is an N_Function_Call or N_Procedure_Call_Statement node. The + -- result returned is the first actual parameter in declaration order + -- (not the order of parameters as they appeared in the source, which + -- can be quite different as a result of the use of named parameters). + -- Empty is returned for a call with no parameters. The procedure for + -- iterating through the actuals in declaration order is to use this + -- function to find the first actual, and then use Next_Actual to obtain + -- the next actual in declaration order. Note that the value returned + -- is always the expression (not the N_Parameter_Association nodes, + -- even if named association is used). + + procedure Gather_Components + (Typ : Entity_Id; + Comp_List : Node_Id; + Governed_By : List_Id; + Into : Elist_Id; + Report_Errors : out Boolean); + -- The purpose of this procedure is to gather the valid components in a + -- record type according to the values of its discriminants, in order to + -- validate the components of a record aggregate. + -- + -- Typ is the type of the aggregate when its constrained discriminants + -- need to be collected, otherwise it is Empty. + -- + -- Comp_List is an N_Component_List node. + -- + -- Governed_By is a list of N_Component_Association nodes, where each + -- choice list contains the name of a discriminant and the expression + -- field gives its value. The values of the discriminants governing + -- the (possibly nested) variant parts in Comp_List are found in this + -- Component_Association List. + -- + -- Into is the list where the valid components are appended. Note that + -- Into need not be an Empty list. If it's not, components are attached + -- to its tail. + -- + -- Report_Errors is set to True if the values of the discriminants are + -- non-static. + -- + -- This procedure is also used when building a record subtype. If the + -- discriminant constraint of the subtype is static, the components of the + -- subtype are only those of the variants selected by the values of the + -- discriminants. Otherwise all components of the parent must be included + -- in the subtype for semantic analysis. + + function Get_Actual_Subtype (N : Node_Id) return Entity_Id; + -- Given a node for an expression, obtain the actual subtype of the + -- expression. In the case of a parameter where the formal is an + -- unconstrained array or discriminated type, this will be the previously + -- constructed subtype of the actual. Note that this is not quite the + -- "Actual Subtype" of the RM, since it is always a constrained type, i.e. + -- it is the subtype of the value of the actual. The actual subtype is also + -- returned in other cases where it has already been constructed for an + -- object. Otherwise the expression type is returned unchanged, except for + -- the case of an unconstrained array type, where an actual subtype is + -- created, using Insert_Actions if necessary to insert any associated + -- actions. + + function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id; + -- This is like Get_Actual_Subtype, except that it never constructs an + -- actual subtype. If an actual subtype is already available, i.e. the + -- Actual_Subtype field of the corresponding entity is set, then it is + -- returned. Otherwise the Etype of the node is returned. + + function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id; + -- This is used to construct the string literal node representing a + -- default external name, i.e. one that is constructed from the name of an + -- entity, or (in the case of extended DEC import/export pragmas, an + -- identifier provided as the external name. Letters in the name are + -- according to the setting of Opt.External_Name_Default_Casing. + + function Get_Generic_Entity (N : Node_Id) return Entity_Id; + -- Returns the true generic entity in an instantiation. If the name in the + -- instantiation is a renaming, the function returns the renamed generic. + + procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id); + -- This procedure assigns to L and H respectively the values of the low and + -- high bounds of node N, which must be a range, subtype indication, or the + -- name of a scalar subtype. The result in L, H may be set to Error if + -- there was an earlier error in the range. + + function Get_Enum_Lit_From_Pos + (T : Entity_Id; + Pos : Uint; + Loc : Source_Ptr) return Node_Id; + -- This function obtains the E_Enumeration_Literal entity for the specified + -- value from the enumeration type or subtype T and returns an identifier + -- node referencing this value. The second argument is the Pos value, which + -- is assumed to be in range. The third argument supplies a source location + -- for constructed nodes returned by this function. + + procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id); + -- Retrieve the fully expanded name of the library unit declared by + -- Decl_Node into the name buffer. + + function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id; + pragma Inline (Get_Name_Entity_Id); + -- An entity value is associated with each name in the name table. The + -- Get_Name_Entity_Id function fetches the Entity_Id of this entity, which + -- is the innermost visible entity with the given name. See the body of + -- Sem_Ch8 for further details on handling of entity visibility. + + function Get_Pragma_Id (N : Node_Id) return Pragma_Id; + pragma Inline (Get_Pragma_Id); + -- Obtains the Pragma_Id from the Chars field of Pragma_Identifier (N) + + function Get_Referenced_Object (N : Node_Id) return Node_Id; + -- Given a node, return the renamed object if the node represents a renamed + -- object, otherwise return the node unchanged. The node may represent an + -- arbitrary expression. + + function Get_Renamed_Entity (E : Entity_Id) return Entity_Id; + -- Given an entity for an exception, package, subprogram or generic unit, + -- returns the ultimately renamed entity if this is a renaming. If this is + -- not a renamed entity, returns its argument. It is an error to call this + -- with any other kind of entity. + + function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id; + -- Nod is either a procedure call statement, or a function call, or an + -- accept statement node. This procedure finds the Entity_Id of the related + -- subprogram or entry and returns it, or if no subprogram can be found, + -- returns Empty. + + function Get_Subprogram_Body (E : Entity_Id) return Node_Id; + -- Given the entity for a subprogram (E_Function or E_Procedure), return + -- the corresponding N_Subprogram_Body node. If the corresponding body + -- is missing (as for an imported subprogram), return Empty. + + function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id; + pragma Inline (Get_Task_Body_Procedure); + -- Given an entity for a task type or subtype, retrieves the + -- Task_Body_Procedure field from the corresponding task type declaration. + + function Has_Access_Values (T : Entity_Id) return Boolean; + -- Returns true if type or subtype T is an access type, or has a component + -- (at any recursive level) that is an access type. This is a conservative + -- predicate, if it is not known whether or not T contains access values + -- (happens for generic formals in some cases), then False is returned. + -- Note that tagged types return False. Even though the tag is implemented + -- as an access type internally, this function tests only for access types + -- known to the programmer. See also Has_Tagged_Component. + + type Alignment_Result is (Known_Compatible, Unknown, Known_Incompatible); + -- Result of Has_Compatible_Alignment test, description found below. Note + -- that the values are arranged in increasing order of problematicness. + + function Has_Compatible_Alignment + (Obj : Entity_Id; + Expr : Node_Id) return Alignment_Result; + -- Obj is an object entity, and expr is a node for an object reference. If + -- the alignment of the object referenced by Expr is known to be compatible + -- with the alignment of Obj (i.e. is larger or the same), then the result + -- is Known_Compatible. If the alignment of the object referenced by Expr + -- is known to be less than the alignment of Obj, then Known_Incompatible + -- is returned. If neither condition can be reliably established at compile + -- time, then Unknown is returned. This is used to determine if alignment + -- checks are required for address clauses, and also whether copies must + -- be made when objects are passed by reference. + -- + -- Note: Known_Incompatible does not mean that at run time the alignment + -- of Expr is known to be wrong for Obj, just that it can be determined + -- that alignments have been explicitly or implicitly specified which are + -- incompatible (whereas Unknown means that even this is not known). The + -- appropriate reaction of a caller to Known_Incompatible is to treat it as + -- Unknown, but issue a warning that there may be an alignment error. + + function Has_Declarations (N : Node_Id) return Boolean; + -- Determines if the node can have declarations + + function Has_Discriminant_Dependent_Constraint + (Comp : Entity_Id) return Boolean; + -- Returns True if and only if Comp has a constrained subtype that depends + -- on a discriminant. + + function Has_Infinities (E : Entity_Id) return Boolean; + -- Determines if the range of the floating-point type E includes + -- infinities. Returns False if E is not a floating-point type. + + function Has_Interfaces + (T : Entity_Id; + Use_Full_View : Boolean := True) return Boolean; + -- Where T is a concurrent type or a record type, returns true if T covers + -- any abstract interface types. In case of private types the argument + -- Use_Full_View controls if the check is done using its full view (if + -- available). + + function Has_Null_Exclusion (N : Node_Id) return Boolean; + -- Determine whether node N has a null exclusion + + function Has_Overriding_Initialize (T : Entity_Id) return Boolean; + -- Predicate to determine whether a controlled type has a user-defined + -- Initialize primitive, which makes the type not preelaborable. + + function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean; + -- Return True iff type E has preelaborable initialization as defined in + -- Ada 2005 (see AI-161 for details of the definition of this attribute). + + function Has_Private_Component (Type_Id : Entity_Id) return Boolean; + -- Check if a type has a (sub)component of a private type that has not + -- yet received a full declaration. + + function Has_Stream (T : Entity_Id) return Boolean; + -- Tests if type T is derived from Ada.Streams.Root_Stream_Type, or in the + -- case of a composite type, has a component for which this predicate is + -- True, and if so returns True. Otherwise a result of False means that + -- there is no Stream type in sight. For a private type, the test is + -- applied to the underlying type (or returns False if there is no + -- underlying type). + + function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean; + -- Returns true if the last character of E is Suffix. Used in Assertions. + + function Has_Tagged_Component (Typ : Entity_Id) return Boolean; + -- Returns True if Typ is a composite type (array or record) which is + -- either itself a tagged type, or has a component (recursively) which is + -- a tagged type. Returns False for non-composite type, or if no tagged + -- component is present. This function is used to check if "=" has to be + -- expanded into a bunch component comparisons. + + function Implementation_Kind (Subp : Entity_Id) return Name_Id; + -- Subp is a subprogram marked with pragma Implemented. Return the specific + -- implementation requirement which the pragma imposes. The return value is + -- either Name_By_Any, Name_By_Entry or Name_By_Protected_Procedure. + + function Implements_Interface + (Typ_Ent : Entity_Id; + Iface_Ent : Entity_Id; + Exclude_Parents : Boolean := False) return Boolean; + -- Returns true if the Typ_Ent implements interface Iface_Ent + + function In_Instance return Boolean; + -- Returns True if the current scope is within a generic instance + + function In_Instance_Body return Boolean; + -- Returns True if current scope is within the body of an instance, where + -- several semantic checks (e.g. accessibility checks) are relaxed. + + function In_Instance_Not_Visible return Boolean; + -- Returns True if current scope is with the private part or the body of + -- an instance. Other semantic checks are suppressed in this context. + + function In_Instance_Visible_Part return Boolean; + -- Returns True if current scope is within the visible part of a package + -- instance, where several additional semantic checks apply. + + function In_Package_Body return Boolean; + -- Returns True if current scope is within a package body + + function In_Parameter_Specification (N : Node_Id) return Boolean; + -- Returns True if node N belongs to a parameter specification + + function In_Subprogram_Or_Concurrent_Unit return Boolean; + -- Determines if the current scope is within a subprogram compilation unit + -- (inside a subprogram declaration, subprogram body, or generic + -- subprogram declaration) or within a task or protected body. The test is + -- for appearing anywhere within such a construct (that is it does not need + -- to be directly within). + + function In_Visible_Part (Scope_Id : Entity_Id) return Boolean; + -- Determine whether a declaration occurs within the visible part of a + -- package specification. The package must be on the scope stack, and the + -- corresponding private part must not. + + procedure Insert_Explicit_Dereference (N : Node_Id); + -- In a context that requires a composite or subprogram type and where a + -- prefix is an access type, rewrite the access type node N (which is the + -- prefix, e.g. of an indexed component) as an explicit dereference. + + procedure Inspect_Deferred_Constant_Completion (Decls : List_Id); + -- Examine all deferred constants in the declaration list Decls and check + -- whether they have been completed by a full constant declaration or an + -- Import pragma. Emit the error message if that is not the case. + + function Is_Actual_Out_Parameter (N : Node_Id) return Boolean; + -- Determines if N is an actual parameter of out mode in a subprogram call + + function Is_Actual_Parameter (N : Node_Id) return Boolean; + -- Determines if N is an actual parameter in a subprogram call + + function Is_Aliased_View (Obj : Node_Id) return Boolean; + -- Determine if Obj is an aliased view, i.e. the name of an object to which + -- 'Access or 'Unchecked_Access can apply. + + function Is_Ancestor_Package + (E1 : Entity_Id; + E2 : Entity_Id) return Boolean; + -- Determine whether package E1 is an ancestor of E2 + + function Is_Atomic_Object (N : Node_Id) return Boolean; + -- Determines if the given node denotes an atomic object in the sense of + -- the legality checks described in RM C.6(12). + + function Is_Coextension_Root (N : Node_Id) return Boolean; + -- Determine whether node N is an allocator which acts as a coextension + -- root. + + function Is_Controlling_Limited_Procedure + (Proc_Nam : Entity_Id) return Boolean; + -- Ada 2005 (AI-345): Determine whether Proc_Nam is a primitive procedure + -- of a limited interface with a controlling first parameter. + + function Is_CPP_Constructor_Call (N : Node_Id) return Boolean; + -- Returns True if N is a call to a CPP constructor + + function Is_Dependent_Component_Of_Mutable_Object + (Object : Node_Id) return Boolean; + -- Returns True if Object is the name of a subcomponent that depends on + -- discriminants of a variable whose nominal subtype is unconstrained and + -- not indefinite, and the variable is not aliased. Otherwise returns + -- False. The nodes passed to this function are assumed to denote objects. + + function Is_Dereferenced (N : Node_Id) return Boolean; + -- N is a subexpression node of an access type. This function returns true + -- if N appears as the prefix of a node that does a dereference of the + -- access value (selected/indexed component, explicit dereference or a + -- slice), and false otherwise. + + function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean; + -- Returns True if type T1 is a descendent of type T2, and false otherwise. + -- This is the RM definition, a type is a descendent of another type if it + -- is the same type or is derived from a descendent of the other type. + + function Is_Concurrent_Interface (T : Entity_Id) return Boolean; + -- First determine whether type T is an interface and then check whether + -- it is of protected, synchronized or task kind. + + function Is_False (U : Uint) return Boolean; + pragma Inline (Is_False); + -- The argument is a Uint value which is the Boolean'Pos value of a Boolean + -- operand (i.e. is either 0 for False, or 1 for True). This function tests + -- if it is False (i.e. zero). + + function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean; + -- Returns True iff the number U is a model number of the fixed- + -- point type T, i.e. if it is an exact multiple of Small. + + function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean; + -- Typ is a type entity. This function returns true if this type is fully + -- initialized, meaning that an object of the type is fully initialized. + -- Note that initialization resulting from use of pragma Normalized_Scalars + -- does not count. Note that this is only used for the purpose of issuing + -- warnings for objects that are potentially referenced uninitialized. This + -- means that the result returned is not crucial, but should err on the + -- side of thinking things are fully initialized if it does not know. + + function Is_Inherited_Operation (E : Entity_Id) return Boolean; + -- E is a subprogram. Return True is E is an implicit operation inherited + -- by a derived type declarations. + + function Is_LHS (N : Node_Id) return Boolean; + -- Returns True iff N is used as Name in an assignment statement + + function Is_Library_Level_Entity (E : Entity_Id) return Boolean; + -- A library-level declaration is one that is accessible from Standard, + -- i.e. a library unit or an entity declared in a library package. + + function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean; + -- Determines whether Expr is a reference to a variable or IN OUT mode + -- parameter of the current enclosing subprogram. + -- Why are OUT parameters not considered here ??? + + function Is_Object_Reference (N : Node_Id) return Boolean; + -- Determines if the tree referenced by N represents an object. Both + -- variable and constant objects return True (compare Is_Variable). + + function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean; + -- Used to test if AV is an acceptable formal for an OUT or IN OUT formal. + -- Note that the Is_Variable function is not quite the right test because + -- this is a case in which conversions whose expression is a variable (in + -- the Is_Variable sense) with a non-tagged type target are considered view + -- conversions and hence variables. + + function Is_Partially_Initialized_Type + (Typ : Entity_Id; + Include_Implicit : Boolean := True) return Boolean; + -- Typ is a type entity. This function returns true if this type is partly + -- initialized, meaning that an object of the type is at least partly + -- initialized (in particular in the record case, that at least one + -- component has an initialization expression). Note that initialization + -- resulting from the use of pragma Normalized_Scalars does not count. + -- Include_Implicit controls whether implicit initialization of access + -- values to null, and of discriminant values, is counted as making the + -- type be partially initialized. For the default setting of True, these + -- implicit cases do count, and discriminated types or types containing + -- access values not explicitly initialized will return True. Otherwise + -- if Include_Implicit is False, these cases do not count as making the + -- type be partially initialized. + + function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean; + -- Determines if type T is a potentially persistent type. A potentially + -- persistent type is defined (recursively) as a scalar type, a non-tagged + -- record whose components are all of a potentially persistent type, or an + -- array with all static constraints whose component type is potentially + -- persistent. A private type is potentially persistent if the full type + -- is potentially persistent. + + function Is_Protected_Self_Reference (N : Node_Id) return Boolean; + -- Return True if node N denotes a protected type name which represents + -- the current instance of a protected object according to RM 9.4(21/2). + + function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean; + -- Return True if a compilation unit is the specification or the + -- body of a remote call interface package. + + function Is_Remote_Access_To_Class_Wide_Type (E : Entity_Id) return Boolean; + -- Return True if E is a remote access-to-class-wide type + + function Is_Remote_Access_To_Subprogram_Type (E : Entity_Id) return Boolean; + -- Return True if E is a remote access to subprogram type + + function Is_Remote_Call (N : Node_Id) return Boolean; + -- Return True if N denotes a potentially remote call + + function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean; + -- Return True if Proc_Nam is a procedure renaming of an entry + + function Is_Selector_Name (N : Node_Id) return Boolean; + -- Given an N_Identifier node N, determines if it is a Selector_Name. + -- As described in Sinfo, Selector_Names are special because they + -- represent use of the N_Identifier node for a true identifier, when + -- normally such nodes represent a direct name. + + function Is_Statement (N : Node_Id) return Boolean; + pragma Inline (Is_Statement); + -- Check if the node N is a statement node. Note that this includes + -- the case of procedure call statements (unlike the direct use of + -- the N_Statement_Other_Than_Procedure_Call subtype from Sinfo). + -- Note that a label is *not* a statement, and will return False. + + function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean; + -- Returns True if E is a synchronized tagged type (AARM 3.9.4 (6/2)) + + function Is_Transfer (N : Node_Id) return Boolean; + -- Returns True if the node N is a statement which is known to cause an + -- unconditional transfer of control at runtime, i.e. the following + -- statement definitely will not be executed. + + function Is_True (U : Uint) return Boolean; + pragma Inline (Is_True); + -- The argument is a Uint value which is the Boolean'Pos value of a Boolean + -- operand (i.e. is either 0 for False, or 1 for True). This function tests + -- if it is True (i.e. non-zero). + + function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean; + pragma Inline (Is_Universal_Numeric_Type); + -- True if T is Universal_Integer or Universal_Real + + function Is_Value_Type (T : Entity_Id) return Boolean; + -- Returns true if type T represents a value type. This is only relevant to + -- CIL, will always return false for other targets. A value type is a CIL + -- object that is accessed directly, as opposed to the other CIL objects + -- that are accessed through managed pointers. + + function Is_VMS_Operator (Op : Entity_Id) return Boolean; + -- Determine whether an operator is one of the intrinsics defined + -- in the DEC system extension. + + function Is_Delegate (T : Entity_Id) return Boolean; + -- Returns true if type T represents a delegate. A Delegate is the CIL + -- object used to represent access-to-subprogram types. This is only + -- relevant to CIL, will always return false for other targets. + + function Is_Variable (N : Node_Id) return Boolean; + -- Determines if the tree referenced by N represents a variable, i.e. can + -- appear on the left side of an assignment. There is one situation (formal + -- parameters) in which non-tagged type conversions are also considered + -- variables, but Is_Variable returns False for such cases, since it has + -- no knowledge of the context. Note that this is the point at which + -- Assignment_OK is checked, and True is returned for any tree thus marked. + + function Is_Visibly_Controlled (T : Entity_Id) return Boolean; + -- Check whether T is derived from a visibly controlled type. This is true + -- if the root type is declared in Ada.Finalization. If T is derived + -- instead from a private type whose full view is controlled, an explicit + -- Initialize/Adjust/Finalize subprogram does not override the inherited + -- one. + + function Is_Volatile_Object (N : Node_Id) return Boolean; + -- Determines if the given node denotes an volatile object in the sense of + -- the legality checks described in RM C.6(12). Note that the test here is + -- for something actually declared as volatile, not for an object that gets + -- treated as volatile (see Einfo.Treat_As_Volatile). + + procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False); + -- This procedure is called to clear all constant indications from all + -- entities in the current scope and in any parent scopes if the current + -- scope is a block or a package (and that recursion continues to the top + -- scope that is not a block or a package). This is used when the + -- sequential flow-of-control assumption is violated (occurrence of a + -- label, head of a loop, or start of an exception handler). The effect of + -- the call is to clear the Constant_Value field (but we do not need to + -- clear the Is_True_Constant flag, since that only gets reset if there + -- really is an assignment somewhere in the entity scope). This procedure + -- also calls Kill_All_Checks, since this is a special case of needing to + -- forget saved values. This procedure also clears the Is_Known_Null and + -- Is_Known_Non_Null and Is_Known_Valid flags in variables, constants or + -- parameters since these are also not known to be trustable any more. + -- + -- The Last_Assignment_Only flag is set True to clear only Last_Assignment + -- fields and leave other fields unchanged. This is used when we encounter + -- an unconditional flow of control change (return, goto, raise). In such + -- cases we don't need to clear the current values, since it may be that + -- the flow of control change occurs in a conditional context, and if it + -- is not taken, then it is just fine to keep the current values. But the + -- Last_Assignment field is different, if we have a sequence assign-to-v, + -- conditional-return, assign-to-v, we do not want to complain that the + -- second assignment clobbers the first. + + procedure Kill_Current_Values + (Ent : Entity_Id; + Last_Assignment_Only : Boolean := False); + -- This performs the same processing as described above for the form with + -- no argument, but for the specific entity given. The call has no effect + -- if the entity Ent is not for an object. Last_Assignment_Only has the + -- same meaning as for the call with no Ent. + + procedure Kill_Size_Check_Code (E : Entity_Id); + -- Called when an address clause or pragma Import is applied to an entity. + -- If the entity is a variable or a constant, and size check code is + -- present, this size check code is killed, since the object will not be + -- allocated by the program. + + function Known_To_Be_Assigned (N : Node_Id) return Boolean; + -- The node N is an entity reference. This function determines whether the + -- reference is for sure an assignment of the entity, returning True if + -- so. This differs from May_Be_Lvalue in that it defaults in the other + -- direction. Cases which may possibly be assignments but are not known to + -- be may return True from May_Be_Lvalue, but False from this function. + + function Make_Simple_Return_Statement + (Sloc : Source_Ptr; + Expression : Node_Id := Empty) return Node_Id + renames Make_Return_Statement; + -- See Sinfo. We rename Make_Return_Statement to the correct Ada 2005 + -- terminology here. Clients should use Make_Simple_Return_Statement. + + Make_Return_Statement : constant := -2 ** 33; + -- Attempt to prevent accidental uses of Make_Return_Statement. If this + -- and the one in Nmake are both potentially use-visible, it will cause + -- a compilation error. Note that type and value are irrelevant. + + N_Return_Statement : constant := -2**33; + -- Attempt to prevent accidental uses of N_Return_Statement; similar to + -- Make_Return_Statement above. + + procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id); + -- Given a node which designates the context of analysis and an origin in + -- the tree, traverse from Root_Nod and mark all allocators as either + -- dynamic or static depending on Context_Nod. Any erroneous marking is + -- cleaned up during resolution. + + function May_Be_Lvalue (N : Node_Id) return Boolean; + -- Determines if N could be an lvalue (e.g. an assignment left hand side). + -- An lvalue is defined as any expression which appears in a context where + -- a name is required by the syntax, and the identity, rather than merely + -- the value of the node is needed (for example, the prefix of an Access + -- attribute is in this category). Note that, as implied by the name, this + -- test is conservative. If it cannot be sure that N is NOT an lvalue, then + -- it returns True. It tries hard to get the answer right, but it is hard + -- to guarantee this in all cases. Note that it is more possible to give + -- correct answer if the tree is fully analyzed. + + function Needs_One_Actual (E : Entity_Id) return Boolean; + -- Returns True if a function has defaults for all but its first + -- formal. Used in Ada 2005 mode to solve the syntactic ambiguity that + -- results from an indexing of a function call written in prefix form. + + function New_Copy_List_Tree (List : List_Id) return List_Id; + -- Copy recursively an analyzed list of nodes. Uses New_Copy_Tree defined + -- below. As for New_Copy_Tree, it is illegal to attempt to copy extended + -- nodes (entities) either directly or indirectly using this function. + + function New_Copy_Tree + (Source : Node_Id; + Map : Elist_Id := No_Elist; + New_Sloc : Source_Ptr := No_Location; + New_Scope : Entity_Id := Empty) return Node_Id; + -- Given a node that is the root of a subtree, Copy_Tree copies the entire + -- syntactic subtree, including recursively any descendents whose parent + -- field references a copied node (descendents not linked to a copied node + -- by the parent field are not copied, instead the copied tree references + -- the same descendent as the original in this case, which is appropriate + -- for non-syntactic fields such as Etype). The parent pointers in the + -- copy are properly set. Copy_Tree (Empty/Error) returns Empty/Error. + -- The one exception to the rule of not copying semantic fields is that + -- any implicit types attached to the subtree are duplicated, so that + -- the copy contains a distinct set of implicit type entities. Thus this + -- function is used when it is necessary to duplicate an analyzed tree, + -- declared in the same or some other compilation unit. This function is + -- declared here rather than in atree because it uses semantic information + -- in particular concerning the structure of itypes and the generation of + -- public symbols. + + -- The Map argument, if set to a non-empty Elist, specifies a set of + -- mappings to be applied to entities in the tree. The map has the form: + -- + -- old entity 1 + -- new entity to replace references to entity 1 + -- old entity 2 + -- new entity to replace references to entity 2 + -- ... + -- + -- The call destroys the contents of Map in this case + -- + -- The parameter New_Sloc, if set to a value other than No_Location, is + -- used as the Sloc value for all nodes in the new copy. If New_Sloc is + -- set to its default value No_Location, then the Sloc values of the + -- nodes in the copy are simply copied from the corresponding original. + -- + -- The Comes_From_Source indication is unchanged if New_Sloc is set to + -- the default No_Location value, but is reset if New_Sloc is given, since + -- in this case the result clearly is neither a source node or an exact + -- copy of a source node. + -- + -- The parameter New_Scope, if set to a value other than Empty, is the + -- value to use as the Scope for any Itypes that are copied. The most + -- typical value for this parameter, if given, is Current_Scope. + + function New_External_Entity + (Kind : Entity_Kind; + Scope_Id : Entity_Id; + Sloc_Value : Source_Ptr; + Related_Id : Entity_Id; + Suffix : Character; + Suffix_Index : Nat := 0; + Prefix : Character := ' ') return Entity_Id; + -- This function creates an N_Defining_Identifier node for an internal + -- created entity, such as an implicit type or subtype, or a record + -- initialization procedure. The entity name is constructed with a call + -- to New_External_Name (Related_Id, Suffix, Suffix_Index, Prefix), so + -- that the generated name may be referenced as a public entry, and the + -- Is_Public flag is set if needed (using Set_Public_Status). If the + -- entity is for a type or subtype, the size/align fields are initialized + -- to unknown (Uint_0). + + function New_Internal_Entity + (Kind : Entity_Kind; + Scope_Id : Entity_Id; + Sloc_Value : Source_Ptr; + Id_Char : Character) return Entity_Id; + -- This function is similar to New_External_Entity, except that the + -- name is constructed by New_Internal_Name (Id_Char). This is used + -- when the resulting entity does not have to be referenced as a + -- public entity (and in this case Is_Public is not set). + + procedure Next_Actual (Actual_Id : in out Node_Id); + pragma Inline (Next_Actual); + -- Next_Actual (N) is equivalent to N := Next_Actual (N). Note that we + -- inline this procedural form, but not the functional form that follows. + + function Next_Actual (Actual_Id : Node_Id) return Node_Id; + -- Find next actual parameter in declaration order. As described for + -- First_Actual, this is the next actual in the declaration order, not + -- the call order, so this does not correspond to simply taking the + -- next entry of the Parameter_Associations list. The argument is an + -- actual previously returned by a call to First_Actual or Next_Actual. + -- Note that the result produced is always an expression, not a parameter + -- association node, even if named notation was used. + + procedure Normalize_Actuals + (N : Node_Id; + S : Entity_Id; + Report : Boolean; + Success : out Boolean); + -- Reorders lists of actuals according to names of formals, value returned + -- in Success indicates success of reordering. For more details, see body. + -- Errors are reported only if Report is set to True. + + procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean); + -- This routine is called if the sub-expression N maybe the target of + -- an assignment (e.g. it is the left side of an assignment, used as + -- an out parameters, or used as prefixes of access attributes). It + -- sets May_Be_Modified in the associated entity if there is one, + -- taking into account the rule that in the case of renamed objects, + -- it is the flag in the renamed object that must be set. + -- + -- The parameter Sure is set True if the modification is sure to occur + -- (e.g. target of assignment, or out parameter), and to False if the + -- modification is only potential (e.g. address of entity taken). + + function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id; + -- [Ada 2012: AI05-0125-1]: If S is an inherited dispatching primitive S2, + -- or overrides an inherited dispatching primitive S2, the original + -- corresponding operation of S is the original corresponding operation of + -- S2. Otherwise, it is S itself. + + function Object_Access_Level (Obj : Node_Id) return Uint; + -- Return the accessibility level of the view of the object Obj. + -- For convenience, qualified expressions applied to object names + -- are also allowed as actuals for this function. + + function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean; + -- Returns True if the names of both entities correspond with matching + -- primitives. This routine includes support for the case in which one + -- or both entities correspond with entities built by Derive_Subprogram + -- with a special name to avoid being overridden (i.e. return true in case + -- of entities with names "nameP" and "name" or vice versa). + + function Private_Component (Type_Id : Entity_Id) return Entity_Id; + -- Returns some private component (if any) of the given Type_Id. + -- Used to enforce the rules on visibility of operations on composite + -- types, that depend on the full view of the component type. For a + -- record type there may be several such components, we just return + -- the first one. + + procedure Process_End_Label + (N : Node_Id; + Typ : Character; + Ent : Entity_Id); + -- N is a node whose End_Label is to be processed, generating all + -- appropriate cross-reference entries, and performing style checks + -- for any identifier references in the end label. Typ is either + -- 'e' or 't indicating the type of the cross-reference entity + -- (e for spec, t for body, see Lib.Xref spec for details). The + -- parameter Ent gives the entity to which the End_Label refers, + -- and to which cross-references are to be generated. + + function References_Generic_Formal_Type (N : Node_Id) return Boolean; + -- Returns True if the expression Expr contains any references to a + -- generic type. This can only happen within a generic template. + + procedure Remove_Homonym (E : Entity_Id); + -- Removes E from the homonym chain + + function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id; + -- This is used to construct the second argument in a call to Rep_To_Pos + -- which is Standard_True if range checks are enabled (E is an entity to + -- which the Range_Checks_Suppressed test is applied), and Standard_False + -- if range checks are suppressed. Loc is the location for the node that + -- is returned (which is a New_Occurrence of the appropriate entity). + -- + -- Note: one might think that it would be fine to always use True and + -- to ignore the suppress in this case, but it is generally better to + -- believe a request to suppress exceptions if possible, and further + -- more there is at least one case in the generated code (the code for + -- array assignment in a loop) that depends on this suppression. + + procedure Require_Entity (N : Node_Id); + -- N is a node which should have an entity value if it is an entity name. + -- If not, then check if there were previous errors. If so, just fill + -- in with Any_Id and ignore. Otherwise signal a program error exception. + -- This is used as a defense mechanism against ill-formed trees caused by + -- previous errors (particularly in -gnatq mode). + + function Requires_Transient_Scope (Id : Entity_Id) return Boolean; + -- E is a type entity. The result is True when temporaries of this + -- type need to be wrapped in a transient scope to be reclaimed + -- properly when a secondary stack is in use. Examples of types + -- requiring such wrapping are controlled types and variable-sized + -- types including unconstrained arrays + + procedure Reset_Analyzed_Flags (N : Node_Id); + -- Reset the Analyzed flags in all nodes of the tree whose root is N + + function Safe_To_Capture_Value + (N : Node_Id; + Ent : Entity_Id; + Cond : Boolean := False) return Boolean; + -- The caller is interested in capturing a value (either the current value, + -- or an indication that the value is non-null) for the given entity Ent. + -- This value can only be captured if sequential execution semantics can be + -- properly guaranteed so that a subsequent reference will indeed be sure + -- that this current value indication is correct. The node N is the + -- construct which resulted in the possible capture of the value (this + -- is used to check if we are in a conditional). + -- + -- Cond is used to skip the test for being inside a conditional. It is used + -- in the case of capturing values from if/while tests, which already do a + -- proper job of handling scoping issues without this help. + -- + -- The only entities whose values can be captured are OUT and IN OUT formal + -- parameters, and variables unless Cond is True, in which case we also + -- allow IN formals, loop parameters and constants, where we cannot ever + -- capture actual value information, but we can capture conditional tests. + + function Same_Name (N1, N2 : Node_Id) return Boolean; + -- Determine if two (possibly expanded) names are the same name. This is + -- a purely syntactic test, and N1 and N2 need not be analyzed. + + function Same_Object (Node1, Node2 : Node_Id) return Boolean; + -- Determine if Node1 and Node2 are known to designate the same object. + -- This is a semantic test and both nodes must be fully analyzed. A result + -- of True is decisively correct. A result of False does not necessarily + -- mean that different objects are designated, just that this could not + -- be reliably determined at compile time. + + function Same_Type (T1, T2 : Entity_Id) return Boolean; + -- Determines if T1 and T2 represent exactly the same type. Two types + -- are the same if they are identical, or if one is an unconstrained + -- subtype of the other, or they are both common subtypes of the same + -- type with identical constraints. The result returned is conservative. + -- It is True if the types are known to be the same, but a result of + -- False is indecisive (e.g. the compiler may not be able to tell that + -- two constraints are identical). + + function Same_Value (Node1, Node2 : Node_Id) return Boolean; + -- Determines if Node1 and Node2 are known to be the same value, which is + -- true if they are both compile time known values and have the same value, + -- or if they are the same object (in the sense of function Same_Object). + -- A result of False does not necessarily mean they have different values, + -- just that it is not possible to determine they have the same value. + + function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean; + -- Determines if the entity Scope1 is the same as Scope2, or if it is + -- inside it, where both entities represent scopes. Note that scopes + -- are only partially ordered, so Scope_Within_Or_Same (A,B) and + -- Scope_Within_Or_Same (B,A) can both be False for a given pair A,B. + + procedure Save_Actual (N : Node_Id; Writable : Boolean := False); + -- Enter an actual in a call in a table global, for subsequent check of + -- possible order dependence in the presence of IN OUT parameters for + -- functions in Ada 2012 (or access parameters in older language versions). + + function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean; + -- Like Scope_Within_Or_Same, except that this function returns + -- False in the case where Scope1 and Scope2 are the same scope. + + procedure Set_Convention (E : Entity_Id; Val : Convention_Id); + -- Same as Basic_Set_Convention, but with an extra check for access types. + -- In particular, if E is an access-to-subprogram type, and Val is a + -- foreign convention, then we set Can_Use_Internal_Rep to False on E. + + procedure Set_Current_Entity (E : Entity_Id); + pragma Inline (Set_Current_Entity); + -- Establish the entity E as the currently visible definition of its + -- associated name (i.e. the Node_Id associated with its name) + + procedure Set_Debug_Info_Needed (T : Entity_Id); + -- Sets the Debug_Info_Needed flag on entity T , and also on any entities + -- that are needed by T (for an object, the type of the object is needed, + -- and for a type, various subsidiary types are needed -- see body for + -- details). Never has any effect on T if the Debug_Info_Off flag is set. + -- This routine should always be used instead of Set_Needs_Debug_Info to + -- ensure that subsidiary entities are properly handled. + + procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id); + -- This procedure has the same calling sequence as Set_Entity, but + -- if Style_Check is set, then it calls a style checking routine which + -- can check identifier spelling style. + + procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id); + pragma Inline (Set_Name_Entity_Id); + -- Sets the Entity_Id value associated with the given name, which is the + -- Id of the innermost visible entity with the given name. See the body + -- of package Sem_Ch8 for further details on the handling of visibility. + + procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id); + -- The arguments may be parameter associations, whose descendants + -- are the optional formal name and the actual parameter. Positional + -- parameters are already members of a list, and do not need to be + -- chained separately. See also First_Actual and Next_Actual. + + procedure Set_Optimize_Alignment_Flags (E : Entity_Id); + pragma Inline (Set_Optimize_Alignment_Flags); + -- Sets Optimize_Alignment_Space/Time flags in E from current settings + + procedure Set_Public_Status (Id : Entity_Id); + -- If an entity (visible or otherwise) is defined in a library + -- package, or a package that is itself public, then this subprogram + -- labels the entity public as well. + + procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean); + -- N is the node for either a left hand side (Out_Param set to False), + -- or an Out or In_Out parameter (Out_Param set to True). If there is + -- an assignable entity being referenced, then the appropriate flag + -- (Referenced_As_LHS if Out_Param is False, Referenced_As_Out_Parameter + -- if Out_Param is True) is set True, and the other flag set False. + + procedure Set_Scope_Is_Transient (V : Boolean := True); + -- Set the flag Is_Transient of the current scope + + procedure Set_Size_Info (T1, T2 : Entity_Id); + pragma Inline (Set_Size_Info); + -- Copies the Esize field and Has_Biased_Representation flag from sub(type) + -- entity T2 to (sub)type entity T1. Also copies the Is_Unsigned_Type flag + -- in the fixed-point and discrete cases, and also copies the alignment + -- value from T2 to T1. It does NOT copy the RM_Size field, which must be + -- separately set if this is required to be copied also. + + function Scope_Is_Transient return Boolean; + -- True if the current scope is transient + + function Static_Integer (N : Node_Id) return Uint; + -- This function analyzes the given expression node and then resolves it + -- as any integer type. If the result is static, then the value of the + -- universal expression is returned, otherwise an error message is output + -- and a value of No_Uint is returned. + + function Statically_Different (E1, E2 : Node_Id) return Boolean; + -- Return True if it can be statically determined that the Expressions + -- E1 and E2 refer to different objects + + function Subprogram_Access_Level (Subp : Entity_Id) return Uint; + -- Return the accessibility level of the view denoted by Subp + + procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String); + -- Print debugging information on entry to each unit being analyzed + + procedure Transfer_Entities (From : Entity_Id; To : Entity_Id); + -- Move a list of entities from one scope to another, and recompute + -- Is_Public based upon the new scope. + + function Type_Access_Level (Typ : Entity_Id) return Uint; + -- Return the accessibility level of Typ + + function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id; + -- Unit_Id is the simple name of a program unit, this function returns the + -- corresponding xxx_Declaration node for the entity. Also applies to the + -- body entities for subprograms, tasks and protected units, in which case + -- it returns the subprogram, task or protected body node for it. The unit + -- may be a child unit with any number of ancestors. + + function Universal_Interpretation (Opnd : Node_Id) return Entity_Id; + -- Yields Universal_Integer or Universal_Real if this is a candidate + + function Unqualify (Expr : Node_Id) return Node_Id; + pragma Inline (Unqualify); + -- Removes any qualifications from Expr. For example, for T1'(T2'(X)), this + -- returns X. If Expr is not a qualified expression, returns Expr. + + function Visible_Ancestors (Typ : Entity_Id) return Elist_Id; + -- [Ada 2012:AI-0125-1]: Collect all the visible parents and progenitors + -- of a type extension or private extension declaration. If the full-view + -- of private parents and progenitors is available then it is used to + -- generate the list of visible ancestors; otherwise their partial + -- view is added to the resulting list. + + function Within_Init_Proc return Boolean; + -- Determines if Current_Scope is within an init proc + + procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id); + -- Output error message for incorrectly typed expression. Expr is the node + -- for the incorrectly typed construct (Etype (Expr) is the type found), + -- and Expected_Type is the entity for the expected type. Note that Expr + -- does not have to be a subexpression, anything with an Etype field may + -- be used. + +end Sem_Util; diff --git a/gcc/ada/sem_vfpt.adb b/gcc/ada/sem_vfpt.adb new file mode 100644 index 000000000..5ea780a39 --- /dev/null +++ b/gcc/ada/sem_vfpt.adb @@ -0,0 +1,168 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ V F P T -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with CStand; use CStand; +with Einfo; use Einfo; +with Opt; use Opt; +with Stand; use Stand; +with Targparm; use Targparm; + +package body Sem_VFpt is + + ----------------- + -- Set_D_Float -- + ----------------- + + procedure Set_D_Float (E : Entity_Id) is + VAXDF_Digits : constant := 9; + + begin + Init_Size (Base_Type (E), 64); + Init_Alignment (Base_Type (E)); + Init_Digits_Value (Base_Type (E), VAXDF_Digits); + Set_Float_Rep (Base_Type (E), VAX_Native); + Set_Float_Bounds (Base_Type (E)); + + Init_Size (E, 64); + Init_Alignment (E); + Init_Digits_Value (E, VAXDF_Digits); + Set_Scalar_Range (E, Scalar_Range (Base_Type (E))); + end Set_D_Float; + + ----------------- + -- Set_F_Float -- + ----------------- + + procedure Set_F_Float (E : Entity_Id) is + VAXFF_Digits : constant := 6; + + begin + Init_Size (Base_Type (E), 32); + Init_Alignment (Base_Type (E)); + Init_Digits_Value (Base_Type (E), VAXFF_Digits); + Set_Float_Rep (Base_Type (E), VAX_Native); + Set_Float_Bounds (Base_Type (E)); + + Init_Size (E, 32); + Init_Alignment (E); + Init_Digits_Value (E, VAXFF_Digits); + Set_Scalar_Range (E, Scalar_Range (Base_Type (E))); + end Set_F_Float; + + ----------------- + -- Set_G_Float -- + ----------------- + + procedure Set_G_Float (E : Entity_Id) is + VAXGF_Digits : constant := 15; + + begin + Init_Size (Base_Type (E), 64); + Init_Alignment (Base_Type (E)); + Init_Digits_Value (Base_Type (E), VAXGF_Digits); + Set_Float_Rep (Base_Type (E), VAX_Native); + Set_Float_Bounds (Base_Type (E)); + + Init_Size (E, 64); + Init_Alignment (E); + Init_Digits_Value (E, VAXGF_Digits); + Set_Scalar_Range (E, Scalar_Range (Base_Type (E))); + end Set_G_Float; + + ------------------- + -- Set_IEEE_Long -- + ------------------- + + procedure Set_IEEE_Long (E : Entity_Id) is + IEEEL_Digits : constant := 15; + + begin + Init_Size (Base_Type (E), 64); + Init_Alignment (Base_Type (E)); + Init_Digits_Value (Base_Type (E), IEEEL_Digits); + Set_Float_Rep (Base_Type (E), IEEE_Binary); + Set_Float_Bounds (Base_Type (E)); + + Init_Size (E, 64); + Init_Alignment (E); + Init_Digits_Value (E, IEEEL_Digits); + Set_Scalar_Range (E, Scalar_Range (Base_Type (E))); + end Set_IEEE_Long; + + -------------------- + -- Set_IEEE_Short -- + -------------------- + + procedure Set_IEEE_Short (E : Entity_Id) is + IEEES_Digits : constant := 6; + + begin + Init_Size (Base_Type (E), 32); + Init_Alignment (Base_Type (E)); + Init_Digits_Value (Base_Type (E), IEEES_Digits); + Set_Float_Rep (Base_Type (E), IEEE_Binary); + Set_Float_Bounds (Base_Type (E)); + + Init_Size (E, 32); + Init_Alignment (E); + Init_Digits_Value (E, IEEES_Digits); + Set_Scalar_Range (E, Scalar_Range (Base_Type (E))); + end Set_IEEE_Short; + + ------------------------------ + -- Set_Standard_Fpt_Formats -- + ------------------------------ + + procedure Set_Standard_Fpt_Formats is + begin + -- IEEE case + + if Opt.Float_Format = 'I' then + Set_IEEE_Short (Standard_Float); + Set_IEEE_Long (Standard_Long_Float); + Set_IEEE_Long (Standard_Long_Long_Float); + + -- Vax float case + + else + Set_F_Float (Standard_Float); + + if Opt.Float_Format_Long = 'D' then + Set_D_Float (Standard_Long_Float); + else + Set_G_Float (Standard_Long_Float); + end if; + + -- Note: Long_Long_Float gets set only in the real VMS case, + -- because this gives better results for testing out the use + -- of VAX float on non-VMS environments with the -gnatdm switch. + + if OpenVMS_On_Target then + Set_G_Float (Standard_Long_Long_Float); + end if; + end if; + end Set_Standard_Fpt_Formats; + +end Sem_VFpt; diff --git a/gcc/ada/sem_vfpt.ads b/gcc/ada/sem_vfpt.ads new file mode 100644 index 000000000..b6c9465ac --- /dev/null +++ b/gcc/ada/sem_vfpt.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ V F P T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1997-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains specialized routines for handling the Alpha +-- floating point formats. It is used only in Alpha implementations. +-- Note that this means that the caller can assume that we are on an +-- Alpha implementation, and that Vax floating-point formats are valid. + +with Types; use Types; + +package Sem_VFpt is + + procedure Set_D_Float (E : Entity_Id); + -- Sets the given floating-point entity to have Vax D_Float format + + procedure Set_F_Float (E : Entity_Id); + -- Sets the given floating-point entity to have Vax F_Float format + + procedure Set_G_Float (E : Entity_Id); + -- Sets the given floating-point entity to have Vax G_Float format + + procedure Set_IEEE_Short (E : Entity_Id); + -- Sets the given floating-point entity to have IEEE Short format + + procedure Set_IEEE_Long (E : Entity_Id); + -- Sets the given floating-point entity to have IEEE Long format + + procedure Set_Standard_Fpt_Formats; + -- This procedure sets the appropriate formats for the standard + -- floating-point types in Standard, based on the setting of + -- the flags Opt.Float_Format and Opt.Float_Format_Long + +end Sem_VFpt; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb new file mode 100644 index 000000000..9388c6629 --- /dev/null +++ b/gcc/ada/sem_warn.adb @@ -0,0 +1,4534 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ W A R N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Debug; use Debug; +with Einfo; use Einfo; +with Errout; use Errout; +with Exp_Code; use Exp_Code; +with Fname; use Fname; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Opt; use Opt; +with Par_SCO; use Par_SCO; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Ch8; use Sem_Ch8; +with Sem_Aux; use Sem_Aux; +with Sem_Eval; use Sem_Eval; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Uintp; use Uintp; + +package body Sem_Warn is + + -- The following table collects Id's of entities that are potentially + -- unreferenced. See Check_Unset_Reference for further details. + -- ??? Check_Unset_Reference has zero information about this table. + + package Unreferenced_Entities is new Table.Table ( + Table_Component_Type => Entity_Id, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => Alloc.Unreferenced_Entities_Initial, + Table_Increment => Alloc.Unreferenced_Entities_Increment, + Table_Name => "Unreferenced_Entities"); + + -- The following table collects potential warnings for IN OUT parameters + -- that are referenced but not modified. These warnings are processed when + -- the front end calls the procedure Output_Non_Modified_In_Out_Warnings. + -- The reason that we defer output of these messages is that we want to + -- detect the case where the relevant procedure is used as a generic actual + -- in an instantiation, since we suppress the warnings in this case. The + -- flag Used_As_Generic_Actual will be set in this case, but only at the + -- point of usage. Similarly, we suppress the message if the address of the + -- procedure is taken, where the flag Address_Taken may be set later. + + package In_Out_Warnings is new Table.Table ( + Table_Component_Type => Entity_Id, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => Alloc.In_Out_Warnings_Initial, + Table_Increment => Alloc.In_Out_Warnings_Increment, + Table_Name => "In_Out_Warnings"); + + -------------------------------------------------------- + -- Handling of Warnings Off, Unmodified, Unreferenced -- + -------------------------------------------------------- + + -- The functions Has_Warnings_Off, Has_Unmodified, Has_Unreferenced must + -- generally be used instead of Warnings_Off, Has_Pragma_Unmodified and + -- Has_Pragma_Unreferenced, as noted in the specs in Einfo. + + -- In order to avoid losing warnings in -gnatw.w (warn on unnecessary + -- warnings off pragma) mode, i.e. to avoid false negatives, the code + -- must follow some important rules. + + -- Call these functions as late as possible, after completing all other + -- tests, just before the warnings is given. For example, don't write: + + -- if not Has_Warnings_Off (E) + -- and then some-other-predicate-on-E then .. + + -- Instead the following is preferred + + -- if some-other-predicate-on-E + -- and then Has_Warnings_Off (E) + + -- This way if some-other-predicate is false, we avoid a false indication + -- that a Warnings (Off,E) pragma was useful in preventing a warning. + + -- The second rule is that if both Has_Unmodified and Has_Warnings_Off, or + -- Has_Unreferenced and Has_Warnings_Off are called, make sure that the + -- call to Has_Unmodified/Has_Unreferenced comes first, this way we record + -- that the Warnings (Off) could have been Unreferenced or Unmodified. In + -- fact Has_Unmodified/Has_Unreferenced includes a test for Warnings Off, + -- and so a subsequent test is not needed anyway (though it is harmless). + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Generic_Package_Spec_Entity (E : Entity_Id) return Boolean; + -- This returns true if the entity E is declared within a generic package. + -- The point of this is to detect variables which are not assigned within + -- the generic, but might be assigned outside the package for any given + -- instance. These are cases where we leave the warnings to be posted for + -- the instance, when we will know more. + + function Goto_Spec_Entity (E : Entity_Id) return Entity_Id; + -- If E is a parameter entity for a subprogram body, then this function + -- returns the corresponding spec entity, if not, E is returned unchanged. + + function Has_Pragma_Unmodified_Check_Spec (E : Entity_Id) return Boolean; + -- Tests Has_Pragma_Unmodified flag for entity E. If E is not a formal, + -- this is simply the setting of the flag Has_Pragma_Unmodified. If E is + -- a body formal, the setting of the flag in the corresponding spec is + -- also checked (and True returned if either flag is True). + + function Has_Pragma_Unreferenced_Check_Spec (E : Entity_Id) return Boolean; + -- Tests Has_Pragma_Unreferenced flag for entity E. If E is not a formal, + -- this is simply the setting of the flag Has_Pragma_Unreferenced. If E is + -- a body formal, the setting of the flag in the corresponding spec is + -- also checked (and True returned if either flag is True). + + function Never_Set_In_Source_Check_Spec (E : Entity_Id) return Boolean; + -- Tests Never_Set_In_Source status for entity E. If E is not a formal, + -- this is simply the setting of the flag Never_Set_In_Source. If E is + -- a body formal, the setting of the flag in the corresponding spec is + -- also checked (and False returned if either flag is False). + + function Operand_Has_Warnings_Suppressed (N : Node_Id) return Boolean; + -- This function traverses the expression tree represented by the node N + -- and determines if any sub-operand is a reference to an entity for which + -- the Warnings_Off flag is set. True is returned if such an entity is + -- encountered, and False otherwise. + + function Referenced_Check_Spec (E : Entity_Id) return Boolean; + -- Tests Referenced status for entity E. If E is not a formal, this is + -- simply the setting of the flag Referenced. If E is a body formal, the + -- setting of the flag in the corresponding spec is also checked (and True + -- returned if either flag is True). + + function Referenced_As_LHS_Check_Spec (E : Entity_Id) return Boolean; + -- Tests Referenced_As_LHS status for entity E. If E is not a formal, this + -- is simply the setting of the flag Referenced_As_LHS. If E is a body + -- formal, the setting of the flag in the corresponding spec is also + -- checked (and True returned if either flag is True). + + function Referenced_As_Out_Parameter_Check_Spec + (E : Entity_Id) return Boolean; + -- Tests Referenced_As_Out_Parameter status for entity E. If E is not a + -- formal, this is simply the setting of Referenced_As_Out_Parameter. If E + -- is a body formal, the setting of the flag in the corresponding spec is + -- also checked (and True returned if either flag is True). + + procedure Warn_On_Unreferenced_Entity + (Spec_E : Entity_Id; + Body_E : Entity_Id := Empty); + -- Output warnings for unreferenced entity E. For the case of an entry + -- formal, Body_E is the corresponding body entity for a particular + -- accept statement, and the message is posted on Body_E. In all other + -- cases, Body_E is ignored and must be Empty. + + function Warnings_Off_Check_Spec (E : Entity_Id) return Boolean; + -- Returns True if Warnings_Off is set for the entity E or (in the case + -- where there is a Spec_Entity), Warnings_Off is set for the Spec_Entity. + + -------------------------- + -- Check_Code_Statement -- + -------------------------- + + procedure Check_Code_Statement (N : Node_Id) is + begin + -- If volatile, nothing to worry about + + if Is_Asm_Volatile (N) then + return; + end if; + + -- Warn if no input or no output + + Setup_Asm_Inputs (N); + + if No (Asm_Input_Value) then + Error_Msg_F + ("?code statement with no inputs should usually be Volatile!", N); + return; + end if; + + Setup_Asm_Outputs (N); + + if No (Asm_Output_Variable) then + Error_Msg_F + ("?code statement with no outputs should usually be Volatile!", N); + return; + end if; + + -- Check multiple code statements in a row + + if Is_List_Member (N) + and then Present (Prev (N)) + and then Nkind (Prev (N)) = N_Code_Statement + then + Error_Msg_F + ("?code statements in sequence should usually be Volatile!", N); + Error_Msg_F + ("\?(suggest using template with multiple instructions)!", N); + end if; + end Check_Code_Statement; + + --------------------------------- + -- Check_Infinite_Loop_Warning -- + --------------------------------- + + -- The case we look for is a while loop which tests a local variable, where + -- there is no obvious direct or possible indirect update of the variable + -- within the body of the loop. + + procedure Check_Infinite_Loop_Warning (Loop_Statement : Node_Id) is + Expression : Node_Id := Empty; + -- Set to WHILE or EXIT WHEN condition to be tested + + Ref : Node_Id := Empty; + -- Reference in Expression to variable that might not be modified + -- in loop, indicating a possible infinite loop. + + Var : Entity_Id := Empty; + -- Corresponding entity (entity of Ref) + + Function_Call_Found : Boolean := False; + -- True if Find_Var found a function call in the condition + + procedure Find_Var (N : Node_Id); + -- Inspect condition to see if it depends on a single entity reference. + -- If so, Ref is set to point to the reference node, and Var is set to + -- the referenced Entity. + + function Has_Indirection (T : Entity_Id) return Boolean; + -- If the controlling variable is an access type, or is a record type + -- with access components, assume that it is changed indirectly and + -- suppress the warning. As a concession to low-level programming, in + -- particular within Declib, we also suppress warnings on a record + -- type that contains components of type Address or Short_Address. + + function Is_Suspicious_Function_Name (E : Entity_Id) return Boolean; + -- Given an entity name, see if the name appears to have something to + -- do with I/O or network stuff, and if so, return True. Used to kill + -- some false positives on a heuristic basis that such functions will + -- likely have some strange side effect dependencies. A rather funny + -- kludge, but warning messages are in the heuristics business. + + function Test_Ref (N : Node_Id) return Traverse_Result; + -- Test for reference to variable in question. Returns Abandon if + -- matching reference found. Used in instantiation of No_Ref_Found. + + function No_Ref_Found is new Traverse_Func (Test_Ref); + -- Function to traverse body of procedure. Returns Abandon if matching + -- reference found. + + -------------- + -- Find_Var -- + -------------- + + procedure Find_Var (N : Node_Id) is + begin + -- Condition is a direct variable reference + + if Is_Entity_Name (N) then + Ref := N; + Var := Entity (Ref); + + -- Case of condition is a comparison with compile time known value + + elsif Nkind (N) in N_Op_Compare then + if Compile_Time_Known_Value (Right_Opnd (N)) then + Find_Var (Left_Opnd (N)); + + elsif Compile_Time_Known_Value (Left_Opnd (N)) then + Find_Var (Right_Opnd (N)); + + -- Ignore any other comparison + + else + return; + end if; + + -- If condition is a negation, check its operand + + elsif Nkind (N) = N_Op_Not then + Find_Var (Right_Opnd (N)); + + -- Case of condition is function call + + elsif Nkind (N) = N_Function_Call then + + Function_Call_Found := True; + + -- Forget it if function name is not entity, who knows what + -- we might be calling? + + if not Is_Entity_Name (Name (N)) then + return; + + -- Forget it if function name is suspicious. A strange test + -- but warning generation is in the heuristics business! + + elsif Is_Suspicious_Function_Name (Entity (Name (N))) then + return; + + -- Forget it if warnings are suppressed on function entity + + elsif Has_Warnings_Off (Entity (Name (N))) then + return; + end if; + + -- OK, see if we have one argument + + declare + PA : constant List_Id := Parameter_Associations (N); + + begin + -- One argument, so check the argument + + if Present (PA) + and then List_Length (PA) = 1 + then + if Nkind (First (PA)) = N_Parameter_Association then + Find_Var (Explicit_Actual_Parameter (First (PA))); + else + Find_Var (First (PA)); + end if; + + -- Not one argument + + else + return; + end if; + end; + + -- Any other kind of node is not something we warn for + + else + return; + end if; + end Find_Var; + + --------------------- + -- Has_Indirection -- + --------------------- + + function Has_Indirection (T : Entity_Id) return Boolean is + Comp : Entity_Id; + Rec : Entity_Id; + + begin + if Is_Access_Type (T) then + return True; + + elsif Is_Private_Type (T) + and then Present (Full_View (T)) + and then Is_Access_Type (Full_View (T)) + then + return True; + + elsif Is_Record_Type (T) then + Rec := T; + + elsif Is_Private_Type (T) + and then Present (Full_View (T)) + and then Is_Record_Type (Full_View (T)) + then + Rec := Full_View (T); + else + return False; + end if; + + Comp := First_Component (Rec); + while Present (Comp) loop + if Is_Access_Type (Etype (Comp)) + or else Is_Descendent_Of_Address (Etype (Comp)) + then + return True; + end if; + + Next_Component (Comp); + end loop; + + return False; + end Has_Indirection; + + --------------------------------- + -- Is_Suspicious_Function_Name -- + --------------------------------- + + function Is_Suspicious_Function_Name (E : Entity_Id) return Boolean is + S : Entity_Id; + + function Substring_Present (S : String) return Boolean; + -- Returns True if name buffer has given string delimited by non- + -- alphabetic characters or by end of string. S is lower case. + + ----------------------- + -- Substring_Present -- + ----------------------- + + function Substring_Present (S : String) return Boolean is + Len : constant Natural := S'Length; + + begin + for J in 1 .. Name_Len - (Len - 1) loop + if Name_Buffer (J .. J + (Len - 1)) = S + and then + (J = 1 + or else Name_Buffer (J - 1) not in 'a' .. 'z') + and then + (J + Len > Name_Len + or else Name_Buffer (J + Len) not in 'a' .. 'z') + then + return True; + end if; + end loop; + + return False; + end Substring_Present; + + -- Start of processing for Is_Suspicious_Function_Name + + begin + S := E; + while Present (S) and then S /= Standard_Standard loop + Get_Name_String (Chars (S)); + + if Substring_Present ("io") + or else Substring_Present ("file") + or else Substring_Present ("network") + then + return True; + else + S := Scope (S); + end if; + end loop; + + return False; + end Is_Suspicious_Function_Name; + + -------------- + -- Test_Ref -- + -------------- + + function Test_Ref (N : Node_Id) return Traverse_Result is + begin + -- Waste of time to look at the expression we are testing + + if N = Expression then + return Skip; + + -- Direct reference to variable in question + + elsif Is_Entity_Name (N) + and then Present (Entity (N)) + and then Entity (N) = Var + then + -- If this is an lvalue, then definitely abandon, since + -- this could be a direct modification of the variable. + + if May_Be_Lvalue (N) then + return Abandon; + end if; + + -- If we appear in the context of a procedure call, then also + -- abandon, since there may be issues of non-visible side + -- effects going on in the call. + + declare + P : Node_Id; + + begin + P := N; + loop + P := Parent (P); + exit when P = Loop_Statement; + + -- Abandon if at procedure call, or something strange is + -- going on (perhaps a node with no parent that should + -- have one but does not?) As always, for a warning we + -- prefer to just abandon the warning than get into the + -- business of complaining about the tree structure here! + + if No (P) or else Nkind (P) = N_Procedure_Call_Statement then + return Abandon; + end if; + end loop; + end; + + -- Reference to variable renaming variable in question + + elsif Is_Entity_Name (N) + and then Present (Entity (N)) + and then Ekind (Entity (N)) = E_Variable + and then Present (Renamed_Object (Entity (N))) + and then Is_Entity_Name (Renamed_Object (Entity (N))) + and then Entity (Renamed_Object (Entity (N))) = Var + and then May_Be_Lvalue (N) + then + return Abandon; + + -- Call to subprogram + + elsif Nkind (N) = N_Procedure_Call_Statement + or else Nkind (N) = N_Function_Call + then + -- If subprogram is within the scope of the entity we are dealing + -- with as the loop variable, then it could modify this parameter, + -- so we abandon in this case. In the case of a subprogram that is + -- not an entity we also abandon. The check for no entity being + -- present is a defense against previous errors. + + if not Is_Entity_Name (Name (N)) + or else No (Entity (Name (N))) + or else Scope_Within (Entity (Name (N)), Scope (Var)) + then + return Abandon; + end if; + + -- If any of the arguments are of type access to subprogram, then + -- we may have funny side effects, so no warning in this case. + + declare + Actual : Node_Id; + begin + Actual := First_Actual (N); + while Present (Actual) loop + if Is_Access_Subprogram_Type (Etype (Actual)) then + return Abandon; + else + Next_Actual (Actual); + end if; + end loop; + end; + + -- Declaration of the variable in question + + elsif Nkind (N) = N_Object_Declaration + and then Defining_Identifier (N) = Var + then + return Abandon; + end if; + + -- All OK, continue scan + + return OK; + end Test_Ref; + + -- Start of processing for Check_Infinite_Loop_Warning + + begin + -- Skip processing if debug flag gnatd.w is set + + if Debug_Flag_Dot_W then + return; + end if; + + -- Deal with Iteration scheme present + + declare + Iter : constant Node_Id := Iteration_Scheme (Loop_Statement); + + begin + if Present (Iter) then + + -- While iteration + + if Present (Condition (Iter)) then + + -- Skip processing for while iteration with conditions actions, + -- since they make it too complicated to get the warning right. + + if Present (Condition_Actions (Iter)) then + return; + end if; + + -- Capture WHILE condition + + Expression := Condition (Iter); + + -- For iteration, do not process, since loop will always terminate + + elsif Present (Loop_Parameter_Specification (Iter)) then + return; + end if; + end if; + end; + + -- Check chain of EXIT statements, we only process loops that have a + -- single exit condition (either a single EXIT WHEN statement, or a + -- WHILE loop not containing any EXIT WHEN statements). + + declare + Ident : constant Node_Id := Identifier (Loop_Statement); + Exit_Stmt : Node_Id; + + begin + -- If we don't have a proper chain set, ignore call entirely. This + -- happens because of previous errors. + + if No (Entity (Ident)) + or else Ekind (Entity (Ident)) /= E_Loop + then + return; + end if; + + -- Otherwise prepare to scan list of EXIT statements + + Exit_Stmt := First_Exit_Statement (Entity (Ident)); + while Present (Exit_Stmt) loop + + -- Check for EXIT WHEN + + if Present (Condition (Exit_Stmt)) then + + -- Quit processing if EXIT WHEN in WHILE loop, or more than + -- one EXIT WHEN statement present in the loop. + + if Present (Expression) then + return; + + -- Otherwise capture condition from EXIT WHEN statement + + else + Expression := Condition (Exit_Stmt); + end if; + end if; + + Exit_Stmt := Next_Exit_Statement (Exit_Stmt); + end loop; + end; + + -- Return if no condition to test + + if No (Expression) then + return; + end if; + + -- Initial conditions met, see if condition is of right form + + Find_Var (Expression); + + -- Nothing to do if local variable from source not found. If it's a + -- renaming, it is probably renaming something too complicated to deal + -- with here. + + if No (Var) + or else Ekind (Var) /= E_Variable + or else Is_Library_Level_Entity (Var) + or else not Comes_From_Source (Var) + or else Nkind (Parent (Var)) = N_Object_Renaming_Declaration + then + return; + + -- Nothing to do if there is some indirection involved (assume that the + -- designated variable might be modified in some way we don't see). + -- However, if no function call was found, then we don't care about + -- indirections, because the condition must be something like "while X + -- /= null loop", so we don't care if X.all is modified in the loop. + + elsif Function_Call_Found and then Has_Indirection (Etype (Var)) then + return; + + -- Same sort of thing for volatile variable, might be modified by + -- some other task or by the operating system in some way. + + elsif Is_Volatile (Var) then + return; + end if; + + -- Filter out case of original statement sequence starting with delay. + -- We assume this is a multi-tasking program and that the condition + -- is affected by other threads (some kind of busy wait). + + declare + Fstm : constant Node_Id := + Original_Node (First (Statements (Loop_Statement))); + begin + if Nkind (Fstm) = N_Delay_Relative_Statement + or else Nkind (Fstm) = N_Delay_Until_Statement + then + return; + end if; + end; + + -- We have a variable reference of the right form, now we scan the loop + -- body to see if it looks like it might not be modified + + if No_Ref_Found (Loop_Statement) = OK then + Error_Msg_NE + ("?variable& is not modified in loop body!", Ref, Var); + Error_Msg_N + ("\?possible infinite loop!", Ref); + end if; + end Check_Infinite_Loop_Warning; + + ---------------------------- + -- Check_Low_Bound_Tested -- + ---------------------------- + + procedure Check_Low_Bound_Tested (Expr : Node_Id) is + begin + if Comes_From_Source (Expr) then + declare + L : constant Node_Id := Left_Opnd (Expr); + R : constant Node_Id := Right_Opnd (Expr); + begin + if Nkind (L) = N_Attribute_Reference + and then Attribute_Name (L) = Name_First + and then Is_Entity_Name (Prefix (L)) + and then Is_Formal (Entity (Prefix (L))) + then + Set_Low_Bound_Tested (Entity (Prefix (L))); + end if; + + if Nkind (R) = N_Attribute_Reference + and then Attribute_Name (R) = Name_First + and then Is_Entity_Name (Prefix (R)) + and then Is_Formal (Entity (Prefix (R))) + then + Set_Low_Bound_Tested (Entity (Prefix (R))); + end if; + end; + end if; + end Check_Low_Bound_Tested; + + ---------------------- + -- Check_References -- + ---------------------- + + procedure Check_References (E : Entity_Id; Anod : Node_Id := Empty) is + E1 : Entity_Id; + E1T : Entity_Id; + UR : Node_Id; + + function Body_Formal + (E : Entity_Id; + Accept_Statement : Node_Id) return Entity_Id; + -- For an entry formal entity from an entry declaration, find the + -- corresponding body formal from the given accept statement. + + function Missing_Subunits return Boolean; + -- We suppress warnings when there are missing subunits, because this + -- may generate too many false positives: entities in a parent may only + -- be referenced in one of the subunits. We make an exception for + -- subunits that contain no other stubs. + + procedure Output_Reference_Error (M : String); + -- Used to output an error message. Deals with posting the error on the + -- body formal in the accept case. + + function Publicly_Referenceable (Ent : Entity_Id) return Boolean; + -- This is true if the entity in question is potentially referenceable + -- from another unit. This is true for entities in packages that are at + -- the library level. + + function Warnings_Off_E1 return Boolean; + -- Return True if Warnings_Off is set for E1, or for its Etype (E1T), + -- or for the base type of E1T. + + ----------------- + -- Body_Formal -- + ----------------- + + function Body_Formal + (E : Entity_Id; + Accept_Statement : Node_Id) return Entity_Id + is + Body_Param : Node_Id; + Body_E : Entity_Id; + + begin + -- Loop to find matching parameter in accept statement + + Body_Param := First (Parameter_Specifications (Accept_Statement)); + while Present (Body_Param) loop + Body_E := Defining_Identifier (Body_Param); + + if Chars (Body_E) = Chars (E) then + return Body_E; + end if; + + Next (Body_Param); + end loop; + + -- Should never fall through, should always find a match + + raise Program_Error; + end Body_Formal; + + ---------------------- + -- Missing_Subunits -- + ---------------------- + + function Missing_Subunits return Boolean is + D : Node_Id; + + begin + if not Unloaded_Subunits then + + -- Normal compilation, all subunits are present + + return False; + + elsif E /= Main_Unit_Entity then + + -- No warnings on a stub that is not the main unit + + return True; + + elsif Nkind (Unit_Declaration_Node (E)) in N_Proper_Body then + D := First (Declarations (Unit_Declaration_Node (E))); + while Present (D) loop + + -- No warnings if the proper body contains nested stubs + + if Nkind (D) in N_Body_Stub then + return True; + end if; + + Next (D); + end loop; + + return False; + + else + -- Missing stubs elsewhere + + return True; + end if; + end Missing_Subunits; + + ---------------------------- + -- Output_Reference_Error -- + ---------------------------- + + procedure Output_Reference_Error (M : String) is + begin + -- Never issue messages for internal names, nor for renamings + + if Is_Internal_Name (Chars (E1)) + or else Nkind (Parent (E1)) = N_Object_Renaming_Declaration + then + return; + end if; + + -- Don't output message for IN OUT formal unless we have the warning + -- flag specifically set. It is a bit odd to distinguish IN OUT + -- formals from other cases. This distinction is historical in + -- nature. Warnings for IN OUT formals were added fairly late. + + if Ekind (E1) = E_In_Out_Parameter + and then not Check_Unreferenced_Formals + then + return; + end if; + + -- Other than accept case, post error on defining identifier + + if No (Anod) then + Error_Msg_N (M, E1); + + -- Accept case, find body formal to post the message + + else + Error_Msg_NE (M, Body_Formal (E1, Accept_Statement => Anod), E1); + + end if; + end Output_Reference_Error; + + ---------------------------- + -- Publicly_Referenceable -- + ---------------------------- + + function Publicly_Referenceable (Ent : Entity_Id) return Boolean is + P : Node_Id; + Prev : Node_Id; + + begin + -- A formal parameter is never referenceable outside the body of its + -- subprogram or entry. + + if Is_Formal (Ent) then + return False; + end if; + + -- Examine parents to look for a library level package spec. But if + -- we find a body or block or other similar construct along the way, + -- we cannot be referenced. + + Prev := Ent; + P := Parent (Ent); + loop + case Nkind (P) is + + -- If we get to top of tree, then publicly referenceable + + when N_Empty => + return True; + + -- If we reach a generic package declaration, then always + -- consider this referenceable, since any instantiation will + -- have access to the entities in the generic package. Note + -- that the package itself may not be instantiated, but then + -- we will get a warning for the package entity. + + -- Note that generic formal parameters are themselves not + -- publicly referenceable in an instance, and warnings on them + -- are useful. + + when N_Generic_Package_Declaration => + return + not Is_List_Member (Prev) + or else List_Containing (Prev) + /= Generic_Formal_Declarations (P); + + -- Similarly, the generic formals of a generic subprogram are + -- not accessible. + + when N_Generic_Subprogram_Declaration => + if Is_List_Member (Prev) + and then List_Containing (Prev) = + Generic_Formal_Declarations (P) + then + return False; + else + P := Parent (P); + end if; + + -- If we reach a subprogram body, entity is not referenceable + -- unless it is the defining entity of the body. This will + -- happen, e.g. when a function is an attribute renaming that + -- is rewritten as a body. + + when N_Subprogram_Body => + if Ent /= Defining_Entity (P) then + return False; + else + P := Parent (P); + end if; + + -- If we reach any other body, definitely not referenceable + + when N_Package_Body | + N_Task_Body | + N_Entry_Body | + N_Protected_Body | + N_Block_Statement | + N_Subunit => + return False; + + -- For all other cases, keep looking up tree + + when others => + Prev := P; + P := Parent (P); + end case; + end loop; + end Publicly_Referenceable; + + --------------------- + -- Warnings_Off_E1 -- + --------------------- + + function Warnings_Off_E1 return Boolean is + begin + return Has_Warnings_Off (E1T) + or else Has_Warnings_Off (Base_Type (E1T)) + or else Warnings_Off_Check_Spec (E1); + end Warnings_Off_E1; + + -- Start of processing for Check_References + + begin + -- No messages if warnings are suppressed, or if we have detected any + -- real errors so far (this last check avoids junk messages resulting + -- from errors, e.g. a subunit that is not loaded). + + if Warning_Mode = Suppress + or else Serious_Errors_Detected /= 0 + then + return; + end if; + + -- We also skip the messages if any subunits were not loaded (see + -- comment in Sem_Ch10 to understand how this is set, and why it is + -- necessary to suppress the warnings in this case). + + if Missing_Subunits then + return; + end if; + + -- Otherwise loop through entities, looking for suspicious stuff + + E1 := First_Entity (E); + while Present (E1) loop + E1T := Etype (E1); + + -- We are only interested in source entities. We also don't issue + -- warnings within instances, since the proper place for such + -- warnings is on the template when it is compiled. + + if Comes_From_Source (E1) + and then Instantiation_Location (Sloc (E1)) = No_Location + then + -- We are interested in variables and out/in-out parameters, but + -- we exclude protected types, too complicated to worry about. + + if Ekind (E1) = E_Variable + or else + (Ekind_In (E1, E_Out_Parameter, E_In_Out_Parameter) + and then not Is_Protected_Type (Current_Scope)) + then + -- Case of an unassigned variable + + -- First gather any Unset_Reference indication for E1. In the + -- case of a parameter, it is the Spec_Entity that is relevant. + + if Ekind (E1) = E_Out_Parameter + and then Present (Spec_Entity (E1)) + then + UR := Unset_Reference (Spec_Entity (E1)); + else + UR := Unset_Reference (E1); + end if; + + -- Special processing for access types + + if Present (UR) + and then Is_Access_Type (E1T) + then + -- For access types, the only time we made a UR entry was + -- for a dereference, and so we post the appropriate warning + -- here (note that the dereference may not be explicit in + -- the source, for example in the case of a dispatching call + -- with an anonymous access controlling formal, or of an + -- assignment of a pointer involving discriminant check on + -- the designated object). + + if not Warnings_Off_E1 then + Error_Msg_NE ("?& may be null!", UR, E1); + end if; + + goto Continue; + + -- Case of variable that could be a constant. Note that we + -- never signal such messages for generic package entities, + -- since a given instance could have modifications outside + -- the package. + + elsif Warn_On_Constant + and then (Ekind (E1) = E_Variable + and then Has_Initial_Value (E1)) + and then Never_Set_In_Source_Check_Spec (E1) + and then not Address_Taken (E1) + and then not Generic_Package_Spec_Entity (E1) + then + -- A special case, if this variable is volatile and not + -- imported, it is not helpful to tell the programmer + -- to mark the variable as constant, since this would be + -- illegal by virtue of RM C.6(13). + + if (Is_Volatile (E1) or else Has_Volatile_Components (E1)) + and then not Is_Imported (E1) + then + Error_Msg_N + ("?& is not modified, volatile has no effect!", E1); + + -- Another special case, Exception_Occurrence, this catches + -- the case of exception choice (and a bit more too, but not + -- worth doing more investigation here). + + elsif Is_RTE (E1T, RE_Exception_Occurrence) then + null; + + -- Here we give the warning if referenced and no pragma + -- Unreferenced or Unmodified is present. + + else + -- Variable case + + if Ekind (E1) = E_Variable then + if Referenced_Check_Spec (E1) + and then not Has_Pragma_Unreferenced_Check_Spec (E1) + and then not Has_Pragma_Unmodified_Check_Spec (E1) + then + if not Warnings_Off_E1 then + Error_Msg_N -- CODEFIX + ("?& is not modified, " + & "could be declared constant!", + E1); + end if; + end if; + end if; + end if; + + -- Other cases of a variable or parameter never set in source + + elsif Never_Set_In_Source_Check_Spec (E1) + + -- No warning if warning for this case turned off + + and then Warn_On_No_Value_Assigned + + -- No warning if address taken somewhere + + and then not Address_Taken (E1) + + -- No warning if explicit initial value + + and then not Has_Initial_Value (E1) + + -- No warning for generic package spec entities, since we + -- might set them in a child unit or something like that + + and then not Generic_Package_Spec_Entity (E1) + + -- No warning if fully initialized type, except that for + -- this purpose we do not consider access types to qualify + -- as fully initialized types (relying on an access type + -- variable being null when it is never set is a bit odd!) + + -- Also we generate warning for an out parameter that is + -- never referenced, since again it seems odd to rely on + -- default initialization to set an out parameter value. + + and then (Is_Access_Type (E1T) + or else Ekind (E1) = E_Out_Parameter + or else not Is_Fully_Initialized_Type (E1T)) + then + -- Do not output complaint about never being assigned a + -- value if a pragma Unmodified applies to the variable + -- we are examining, or if it is a parameter, if there is + -- a pragma Unreferenced for the corresponding spec, or + -- if the type is marked as having unreferenced objects. + -- The last is a little peculiar, but better too few than + -- too many warnings in this situation. + + if Has_Pragma_Unreferenced_Objects (E1T) + or else Has_Pragma_Unmodified_Check_Spec (E1) + then + null; + + -- IN OUT parameter case where parameter is referenced. We + -- separate this out, since this is the case where we delay + -- output of the warning until more information is available + -- (about use in an instantiation or address being taken). + + elsif Ekind (E1) = E_In_Out_Parameter + and then Referenced_Check_Spec (E1) + then + -- Suppress warning if private type, and the procedure + -- has a separate declaration in a different unit. This + -- is the case where the client of a package sees only + -- the private type, and it may be quite reasonable + -- for the logical view to be IN OUT, even if the + -- implementation ends up using access types or some + -- other method to achieve the local effect of a + -- modification. On the other hand if the spec and body + -- are in the same unit, we are in the package body and + -- there we have less excuse for a junk IN OUT parameter. + + if Has_Private_Declaration (E1T) + and then Present (Spec_Entity (E1)) + and then not In_Same_Source_Unit (E1, Spec_Entity (E1)) + then + null; + + -- Suppress warning for any parameter of a dispatching + -- operation, since it is quite reasonable to have an + -- operation that is overridden, and for some subclasses + -- needs the formal to be IN OUT and for others happens + -- not to assign it. + + elsif Is_Dispatching_Operation + (Scope (Goto_Spec_Entity (E1))) + then + null; + + -- Suppress warning if composite type contains any access + -- component, since the logical effect of modifying a + -- parameter may be achieved by modifying a referenced + -- object. + + elsif Is_Composite_Type (E1T) + and then Has_Access_Values (E1T) + then + null; + + -- Suppress warning on formals of an entry body. All + -- references are attached to the formal in the entry + -- declaration, which are marked Is_Entry_Formal. + + elsif Ekind (Scope (E1)) = E_Entry + and then not Is_Entry_Formal (E1) + then + null; + + -- OK, looks like warning for an IN OUT parameter that + -- could be IN makes sense, but we delay the output of + -- the warning, pending possibly finding out later on + -- that the associated subprogram is used as a generic + -- actual, or its address/access is taken. In these two + -- cases, we suppress the warning because the context may + -- force use of IN OUT, even if in this particular case + -- the formal is not modified. + + else + In_Out_Warnings.Append (E1); + end if; + + -- Other cases of formals + + elsif Is_Formal (E1) then + if not Is_Trivial_Subprogram (Scope (E1)) then + if Referenced_Check_Spec (E1) then + if not Has_Pragma_Unmodified_Check_Spec (E1) + and then not Warnings_Off_E1 + then + Output_Reference_Error + ("?formal parameter& is read but " + & "never assigned!"); + end if; + + elsif not Has_Pragma_Unreferenced_Check_Spec (E1) + and then not Warnings_Off_E1 + then + Output_Reference_Error + ("?formal parameter& is not referenced!"); + end if; + end if; + + -- Case of variable + + else + if Referenced (E1) then + if not Has_Unmodified (E1) + and then not Warnings_Off_E1 + then + Output_Reference_Error + ("?variable& is read but never assigned!"); + end if; + + elsif not Has_Unreferenced (E1) + and then not Warnings_Off_E1 + then + Output_Reference_Error -- CODEFIX + ("?variable& is never read and never assigned!"); + end if; + + -- Deal with special case where this variable is hidden + -- by a loop variable. + + if Ekind (E1) = E_Variable + and then Present (Hiding_Loop_Variable (E1)) + and then not Warnings_Off_E1 + then + Error_Msg_N + ("?for loop implicitly declares loop variable!", + Hiding_Loop_Variable (E1)); + + Error_Msg_Sloc := Sloc (E1); + Error_Msg_N + ("\?declaration hides & declared#!", + Hiding_Loop_Variable (E1)); + end if; + end if; + + goto Continue; + end if; + + -- Check for unset reference + + if Warn_On_No_Value_Assigned and then Present (UR) then + + -- For other than access type, go back to original node to + -- deal with case where original unset reference has been + -- rewritten during expansion. + + -- In some cases, the original node may be a type conversion + -- or qualification, and in this case we want the object + -- entity inside. + + UR := Original_Node (UR); + while Nkind (UR) = N_Type_Conversion + or else Nkind (UR) = N_Qualified_Expression + loop + UR := Expression (UR); + end loop; + + -- Here we issue the warning, all checks completed + + -- If we have a return statement, this was a case of an OUT + -- parameter not being set at the time of the return. (Note: + -- it can't be N_Extended_Return_Statement, because those + -- are only for functions, and functions do not allow OUT + -- parameters.) + + if not Is_Trivial_Subprogram (Scope (E1)) then + if Nkind (UR) = N_Simple_Return_Statement + and then not Has_Pragma_Unmodified_Check_Spec (E1) + then + if not Warnings_Off_E1 then + Error_Msg_NE + ("?OUT parameter& not set before return", UR, E1); + end if; + + -- If the unset reference is a selected component + -- prefix from source, mention the component as well. + -- If the selected component comes from expansion, all + -- we know is that the entity is not fully initialized + -- at the point of the reference. Locate a random + -- uninitialized component to get a better message. + + elsif Nkind (Parent (UR)) = N_Selected_Component then + Error_Msg_Node_2 := Selector_Name (Parent (UR)); + + if not Comes_From_Source (Parent (UR)) then + declare + Comp : Entity_Id; + + begin + Comp := First_Entity (E1T); + while Present (Comp) loop + if Ekind (Comp) = E_Component + and then Nkind (Parent (Comp)) = + N_Component_Declaration + and then No (Expression (Parent (Comp))) + then + Error_Msg_Node_2 := Comp; + exit; + end if; + + Next_Entity (Comp); + end loop; + end; + end if; + + -- Issue proper warning. This is a case of referencing + -- a variable before it has been explicitly assigned. + -- For access types, UR was only set for dereferences, + -- so the issue is that the value may be null. + + if not Is_Trivial_Subprogram (Scope (E1)) then + if not Warnings_Off_E1 then + if Is_Access_Type (Etype (Parent (UR))) then + Error_Msg_N ("?`&.&` may be null!", UR); + else + Error_Msg_N + ("?`&.&` may be referenced before " + & "it has a value!", UR); + end if; + end if; + end if; + + -- All other cases of unset reference active + + elsif not Warnings_Off_E1 then + Error_Msg_N + ("?& may be referenced before it has a value!", + UR); + end if; + end if; + + goto Continue; + end if; + end if; + + -- Then check for unreferenced entities. Note that we are only + -- interested in entities whose Referenced flag is not set. + + if not Referenced_Check_Spec (E1) + + -- If Referenced_As_LHS is set, then that's still interesting + -- (potential "assigned but never read" case), but not if we + -- have pragma Unreferenced, which cancels this warning. + + and then (not Referenced_As_LHS_Check_Spec (E1) + or else not Has_Unreferenced (E1)) + + -- Check that warnings on unreferenced entities are enabled + + and then + ((Check_Unreferenced and then not Is_Formal (E1)) + + -- Case of warning on unreferenced formal + + or else + (Check_Unreferenced_Formals and then Is_Formal (E1)) + + -- Case of warning on unread variables modified by an + -- assignment, or an OUT parameter if it is the only one. + + or else + (Warn_On_Modified_Unread + and then Referenced_As_LHS_Check_Spec (E1)) + + -- Case of warning on any unread OUT parameter (note + -- such indications are only set if the appropriate + -- warning options were set, so no need to recheck here. + + or else + Referenced_As_Out_Parameter_Check_Spec (E1)) + + -- All other entities, including local packages that cannot be + -- referenced from elsewhere, including those declared within a + -- package body. + + and then (Is_Object (E1) + or else + Is_Type (E1) + or else + Ekind (E1) = E_Label + or else + Ekind (E1) = E_Exception + or else + Ekind (E1) = E_Named_Integer + or else + Ekind (E1) = E_Named_Real + or else + Is_Overloadable (E1) + + -- Package case, if the main unit is a package spec + -- or generic package spec, then there may be a + -- corresponding body that references this package + -- in some other file. Otherwise we can be sure + -- that there is no other reference. + + or else + (Ekind (E1) = E_Package + and then + not Is_Package_Or_Generic_Package + (Cunit_Entity (Current_Sem_Unit)))) + + -- Exclude instantiations, since there is no reason why every + -- entity in an instantiation should be referenced. + + and then Instantiation_Location (Sloc (E1)) = No_Location + + -- Exclude formal parameters from bodies if the corresponding + -- spec entity has been referenced in the case where there is + -- a separate spec. + + and then not (Is_Formal (E1) + and then Ekind (Scope (E1)) = E_Subprogram_Body + and then Present (Spec_Entity (E1)) + and then Referenced (Spec_Entity (E1))) + + -- Consider private type referenced if full view is referenced. + -- If there is not full view, this is a generic type on which + -- warnings are also useful. + + and then + not (Is_Private_Type (E1) + and then Present (Full_View (E1)) + and then Referenced (Full_View (E1))) + + -- Don't worry about full view, only about private type + + and then not Has_Private_Declaration (E1) + + -- Eliminate dispatching operations from consideration, we + -- cannot tell if these are referenced or not in any easy + -- manner (note this also catches Adjust/Finalize/Initialize). + + and then not Is_Dispatching_Operation (E1) + + -- Check entity that can be publicly referenced (we do not give + -- messages for such entities, since there could be other + -- units, not involved in this compilation, that contain + -- relevant references. + + and then not Publicly_Referenceable (E1) + + -- Class wide types are marked as source entities, but they are + -- not really source entities, and are always created, so we do + -- not care if they are not referenced. + + and then Ekind (E1) /= E_Class_Wide_Type + + -- Objects other than parameters of task types are allowed to + -- be non-referenced, since they start up tasks! + + and then ((Ekind (E1) /= E_Variable + and then Ekind (E1) /= E_Constant + and then Ekind (E1) /= E_Component) + or else not Is_Task_Type (E1T)) + + -- For subunits, only place warnings on the main unit itself, + -- since parent units are not completely compiled. + + and then (Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit + or else Get_Source_Unit (E1) = Main_Unit) + + -- No warning on a return object, because these are often + -- created with a single expression and an implicit return. + -- If the object is a variable there will be a warning + -- indicating that it could be declared constant. + + and then not + (Ekind (E1) = E_Constant and then Is_Return_Object (E1)) + then + -- Suppress warnings in internal units if not in -gnatg mode + -- (these would be junk warnings for an applications program, + -- since they refer to problems in internal units). + + if GNAT_Mode + or else not Is_Internal_File_Name + (Unit_File_Name (Get_Source_Unit (E1))) + then + -- We do not immediately flag the error. This is because we + -- have not expanded generic bodies yet, and they may have + -- the missing reference. So instead we park the entity on a + -- list, for later processing. However for the case of an + -- accept statement we want to output messages now, since + -- we know we already have all information at hand, and we + -- also want to have separate warnings for each accept + -- statement for the same entry. + + if Present (Anod) then + pragma Assert (Is_Formal (E1)); + + -- The unreferenced entity is E1, but post the warning + -- on the body entity for this accept statement. + + if not Warnings_Off_E1 then + Warn_On_Unreferenced_Entity + (E1, Body_Formal (E1, Accept_Statement => Anod)); + end if; + + elsif not Warnings_Off_E1 then + Unreferenced_Entities.Append (E1); + end if; + end if; + + -- Generic units are referenced in the generic body, but if they + -- are not public and never instantiated we want to force a + -- warning on them. We treat them as redundant constructs to + -- minimize noise. + + elsif Is_Generic_Subprogram (E1) + and then not Is_Instantiated (E1) + and then not Publicly_Referenceable (E1) + and then Instantiation_Depth (Sloc (E1)) = 0 + and then Warn_On_Redundant_Constructs + then + if not Warnings_Off_E1 then + Unreferenced_Entities.Append (E1); + + -- Force warning on entity + + Set_Referenced (E1, False); + end if; + end if; + end if; + + -- Recurse into nested package or block. Do not recurse into a formal + -- package, because the corresponding body is not analyzed. + + <> + if (Is_Package_Or_Generic_Package (E1) + and then Nkind (Parent (E1)) = N_Package_Specification + and then + Nkind (Original_Node (Unit_Declaration_Node (E1))) + /= N_Formal_Package_Declaration) + + or else Ekind (E1) = E_Block + then + Check_References (E1); + end if; + + Next_Entity (E1); + end loop; + end Check_References; + + --------------------------- + -- Check_Unset_Reference -- + --------------------------- + + procedure Check_Unset_Reference (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + + function Is_OK_Fully_Initialized return Boolean; + -- This function returns true if the given node N is fully initialized + -- so that the reference is safe as far as this routine is concerned. + -- Safe generally means that the type of N is a fully initialized type. + -- The one special case is that for access types, which are always fully + -- initialized, we don't consider a dereference OK since it will surely + -- be dereferencing a null value, which won't do. + + function Prefix_Has_Dereference (Pref : Node_Id) return Boolean; + -- Used to test indexed or selected component or slice to see if the + -- evaluation of the prefix depends on a dereference, and if so, returns + -- True, in which case we always check the prefix, even if we know that + -- the referenced component is initialized. Pref is the prefix to test. + + ----------------------------- + -- Is_OK_Fully_Initialized -- + ----------------------------- + + function Is_OK_Fully_Initialized return Boolean is + begin + if Is_Access_Type (Typ) and then Is_Dereferenced (N) then + return False; + else + return Is_Fully_Initialized_Type (Typ); + end if; + end Is_OK_Fully_Initialized; + + ---------------------------- + -- Prefix_Has_Dereference -- + ---------------------------- + + function Prefix_Has_Dereference (Pref : Node_Id) return Boolean is + begin + -- If prefix is of an access type, it certainly needs a dereference + + if Is_Access_Type (Etype (Pref)) then + return True; + + -- If prefix is explicit dereference, that's a dereference for sure + + elsif Nkind (Pref) = N_Explicit_Dereference then + return True; + + -- If prefix is itself a component reference or slice check prefix + + elsif Nkind (Pref) = N_Slice + or else Nkind (Pref) = N_Indexed_Component + or else Nkind (Pref) = N_Selected_Component + then + return Prefix_Has_Dereference (Prefix (Pref)); + + -- All other cases do not involve a dereference + + else + return False; + end if; + end Prefix_Has_Dereference; + + -- Start of processing for Check_Unset_Reference + + begin + -- Nothing to do if warnings suppressed + + if Warning_Mode = Suppress then + return; + end if; + + -- Ignore reference unless it comes from source. Almost always if we + -- have a reference from generated code, it is bogus (e.g. calls to init + -- procs to set default discriminant values). + + if not Comes_From_Source (N) then + return; + end if; + + -- Otherwise see what kind of node we have. If the entity already has an + -- unset reference, it is not necessarily the earliest in the text, + -- because resolution of the prefix of selected components is completed + -- before the resolution of the selected component itself. As a result, + -- given (R /= null and then R.X > 0), the occurrences of R are examined + -- in right-to-left order. If there is already an unset reference, we + -- check whether N is earlier before proceeding. + + case Nkind (N) is + + -- For identifier or expanded name, examine the entity involved + + when N_Identifier | N_Expanded_Name => + declare + E : constant Entity_Id := Entity (N); + + begin + if (Ekind (E) = E_Variable + or else + Ekind (E) = E_Out_Parameter) + and then Never_Set_In_Source_Check_Spec (E) + and then not Has_Initial_Value (E) + and then (No (Unset_Reference (E)) + or else + Earlier_In_Extended_Unit + (Sloc (N), Sloc (Unset_Reference (E)))) + and then not Has_Pragma_Unmodified_Check_Spec (E) + and then not Warnings_Off_Check_Spec (E) + then + -- We may have an unset reference. The first test is whether + -- this is an access to a discriminant of a record or a + -- component with default initialization. Both of these + -- cases can be ignored, since the actual object that is + -- referenced is definitely initialized. Note that this + -- covers the case of reading discriminants of an OUT + -- parameter, which is OK even in Ada 83. + + -- Note that we are only interested in a direct reference to + -- a record component here. If the reference is through an + -- access type, then the access object is being referenced, + -- not the record, and still deserves an unset reference. + + if Nkind (Parent (N)) = N_Selected_Component + and not Is_Access_Type (Typ) + then + declare + ES : constant Entity_Id := + Entity (Selector_Name (Parent (N))); + begin + if Ekind (ES) = E_Discriminant + or else + (Present (Declaration_Node (ES)) + and then + Present (Expression (Declaration_Node (ES)))) + then + return; + end if; + end; + end if; + + -- Exclude fully initialized types + + if Is_OK_Fully_Initialized then + return; + end if; + + -- Here we have a potential unset reference. But before we + -- get worried about it, we have to make sure that the + -- entity declaration is in the same procedure as the + -- reference, since if they are in separate procedures, then + -- we have no idea about sequential execution. + + -- The tests in the loop below catch all such cases, but do + -- allow the reference to appear in a loop, block, or + -- package spec that is nested within the declaring scope. + -- As always, it is possible to construct cases where the + -- warning is wrong, that is why it is a warning! + + Potential_Unset_Reference : declare + SR : Entity_Id; + SE : constant Entity_Id := Scope (E); + + function Within_Postcondition return Boolean; + -- Returns True iff N is within a Precondition + + -------------------------- + -- Within_Postcondition -- + -------------------------- + + function Within_Postcondition return Boolean is + Nod : Node_Id; + + begin + Nod := Parent (N); + while Present (Nod) loop + if Nkind (Nod) = N_Pragma + and then Pragma_Name (Nod) = Name_Postcondition + then + return True; + end if; + + Nod := Parent (Nod); + end loop; + + return False; + end Within_Postcondition; + + -- Start of processing for Potential_Unset_Reference + + begin + SR := Current_Scope; + while SR /= SE loop + if SR = Standard_Standard + or else Is_Subprogram (SR) + or else Is_Concurrent_Body (SR) + or else Is_Concurrent_Type (SR) + then + return; + end if; + + SR := Scope (SR); + end loop; + + -- Case of reference has an access type. This is a + -- special case since access types are always set to null + -- so cannot be truly uninitialized, but we still want to + -- warn about cases of obvious null dereference. + + if Is_Access_Type (Typ) then + Access_Type_Case : declare + P : Node_Id; + + function Process + (N : Node_Id) return Traverse_Result; + -- Process function for instantiation of Traverse + -- below. Checks if N contains reference to E other + -- than a dereference. + + function Ref_In (Nod : Node_Id) return Boolean; + -- Determines whether Nod contains a reference to + -- the entity E that is not a dereference. + + ------------- + -- Process -- + ------------- + + function Process + (N : Node_Id) return Traverse_Result + is + begin + if Is_Entity_Name (N) + and then Entity (N) = E + and then not Is_Dereferenced (N) + then + return Abandon; + else + return OK; + end if; + end Process; + + ------------ + -- Ref_In -- + ------------ + + function Ref_In (Nod : Node_Id) return Boolean is + function Traverse is new Traverse_Func (Process); + begin + return Traverse (Nod) = Abandon; + end Ref_In; + + -- Start of processing for Access_Type_Case + + begin + -- Don't bother if we are inside an instance, since + -- the compilation of the generic template is where + -- the warning should be issued. + + if In_Instance then + return; + end if; + + -- Don't bother if this is not the main unit. If we + -- try to give this warning for with'ed units, we + -- get some false positives, since we do not record + -- references in other units. + + if not In_Extended_Main_Source_Unit (E) + or else + not In_Extended_Main_Source_Unit (N) + then + return; + end if; + + -- We are only interested in dereferences + + if not Is_Dereferenced (N) then + return; + end if; + + -- One more check, don't bother with references + -- that are inside conditional statements or WHILE + -- loops if the condition references the entity in + -- question. This avoids most false positives. + + P := Parent (N); + loop + P := Parent (P); + exit when No (P); + + if (Nkind (P) = N_If_Statement + or else + Nkind (P) = N_Elsif_Part) + and then Ref_In (Condition (P)) + then + return; + + elsif Nkind (P) = N_Loop_Statement + and then Present (Iteration_Scheme (P)) + and then + Ref_In (Condition (Iteration_Scheme (P))) + then + return; + end if; + end loop; + end Access_Type_Case; + end if; + + -- One more check, don't bother if we are within a + -- postcondition pragma, since the expression occurs + -- in a place unrelated to the actual test. + + if not Within_Postcondition then + + -- Here we definitely have a case for giving a warning + -- for a reference to an unset value. But we don't + -- give the warning now. Instead set Unset_Reference + -- in the identifier involved. The reason for this is + -- that if we find the variable is never ever assigned + -- a value then that warning is more important and + -- there is no point in giving the reference warning. + + -- If this is an identifier, set the field directly + + if Nkind (N) = N_Identifier then + Set_Unset_Reference (E, N); + + -- Otherwise it is an expanded name, so set the field + -- of the actual identifier for the reference. + + else + Set_Unset_Reference (E, Selector_Name (N)); + end if; + end if; + end Potential_Unset_Reference; + end if; + end; + + -- Indexed component or slice + + when N_Indexed_Component | N_Slice => + + -- If prefix does not involve dereferencing an access type, then + -- we know we are OK if the component type is fully initialized, + -- since the component will have been set as part of the default + -- initialization. + + if not Prefix_Has_Dereference (Prefix (N)) + and then Is_OK_Fully_Initialized + then + return; + + -- Look at prefix in access type case, or if the component is not + -- fully initialized. + + else + Check_Unset_Reference (Prefix (N)); + end if; + + -- Record component + + when N_Selected_Component => + declare + Pref : constant Node_Id := Prefix (N); + Ent : constant Entity_Id := Entity (Selector_Name (N)); + + begin + -- If prefix involves dereferencing an access type, always + -- check the prefix, since the issue then is whether this + -- access value is null. + + if Prefix_Has_Dereference (Pref) then + null; + + -- Always go to prefix if no selector entity is set. Can this + -- happen in the normal case? Not clear, but it definitely can + -- happen in error cases. + + elsif No (Ent) then + null; + + -- For a record component, check some cases where we have + -- reasonable cause to consider that the component is known to + -- be or probably is initialized. In this case, we don't care + -- if the prefix itself was explicitly initialized. + + -- Discriminants are always considered initialized + + elsif Ekind (Ent) = E_Discriminant then + return; + + -- An explicitly initialized component is certainly initialized + + elsif Nkind (Parent (Ent)) = N_Component_Declaration + and then Present (Expression (Parent (Ent))) + then + return; + + -- A fully initialized component is initialized + + elsif Is_OK_Fully_Initialized then + return; + end if; + + -- If none of those cases apply, check the record type prefix + + Check_Unset_Reference (Pref); + end; + + -- For type conversions or qualifications examine the expression + + when N_Type_Conversion | N_Qualified_Expression => + Check_Unset_Reference (Expression (N)); + + -- For explicit dereference, always check prefix, which will generate + -- an unset reference (since this is a case of dereferencing null). + + when N_Explicit_Dereference => + Check_Unset_Reference (Prefix (N)); + + -- All other cases are not cases of an unset reference + + when others => + null; + + end case; + end Check_Unset_Reference; + + ------------------------ + -- Check_Unused_Withs -- + ------------------------ + + procedure Check_Unused_Withs (Spec_Unit : Unit_Number_Type := No_Unit) is + Cnode : Node_Id; + Item : Node_Id; + Lunit : Node_Id; + Ent : Entity_Id; + + Munite : constant Entity_Id := Cunit_Entity (Main_Unit); + -- This is needed for checking the special renaming case + + procedure Check_One_Unit (Unit : Unit_Number_Type); + -- Subsidiary procedure, performs checks for specified unit + + -------------------- + -- Check_One_Unit -- + -------------------- + + procedure Check_One_Unit (Unit : Unit_Number_Type) is + Is_Visible_Renaming : Boolean := False; + Pack : Entity_Id; + + procedure Check_Inner_Package (Pack : Entity_Id); + -- Pack is a package local to a unit in a with_clause. Both the unit + -- and Pack are referenced. If none of the entities in Pack are + -- referenced, then the only occurrence of Pack is in a USE clause + -- or a pragma, and a warning is worthwhile as well. + + function Check_System_Aux return Boolean; + -- Before giving a warning on a with_clause for System, check whether + -- a system extension is present. + + function Find_Package_Renaming + (P : Entity_Id; + L : Entity_Id) return Entity_Id; + -- The only reference to a context unit may be in a renaming + -- declaration. If this renaming declares a visible entity, do not + -- warn that the context clause could be moved to the body, because + -- the renaming may be intended to re-export the unit. + + function Has_Visible_Entities (P : Entity_Id) return Boolean; + -- This function determines if a package has any visible entities. + -- True is returned if there is at least one declared visible entity, + -- otherwise False is returned (e.g. case of only pragmas present). + + ------------------------- + -- Check_Inner_Package -- + ------------------------- + + procedure Check_Inner_Package (Pack : Entity_Id) is + E : Entity_Id; + Un : constant Node_Id := Sinfo.Unit (Cnode); + + function Check_Use_Clause (N : Node_Id) return Traverse_Result; + -- If N is a use_clause for Pack, emit warning + + procedure Check_Use_Clauses is new + Traverse_Proc (Check_Use_Clause); + + ---------------------- + -- Check_Use_Clause -- + ---------------------- + + function Check_Use_Clause (N : Node_Id) return Traverse_Result is + Nam : Node_Id; + + begin + if Nkind (N) = N_Use_Package_Clause then + Nam := First (Names (N)); + while Present (Nam) loop + if Entity (Nam) = Pack then + Error_Msg_Qual_Level := 1; + Error_Msg_NE -- CODEFIX + ("?no entities of package& are referenced!", + Nam, Pack); + Error_Msg_Qual_Level := 0; + end if; + + Next (Nam); + end loop; + end if; + + return OK; + end Check_Use_Clause; + + -- Start of processing for Check_Inner_Package + + begin + E := First_Entity (Pack); + while Present (E) loop + if Referenced_Check_Spec (E) then + return; + end if; + + Next_Entity (E); + end loop; + + -- No entities of the package are referenced. Check whether the + -- reference to the package itself is a use clause, and if so + -- place a warning on it. + + Check_Use_Clauses (Un); + end Check_Inner_Package; + + ---------------------- + -- Check_System_Aux -- + ---------------------- + + function Check_System_Aux return Boolean is + Ent : Entity_Id; + + begin + if Chars (Lunit) = Name_System + and then Scope (Lunit) = Standard_Standard + and then Present_System_Aux + then + Ent := First_Entity (System_Aux_Id); + while Present (Ent) loop + if Referenced_Check_Spec (Ent) then + return True; + end if; + + Next_Entity (Ent); + end loop; + end if; + + return False; + end Check_System_Aux; + + --------------------------- + -- Find_Package_Renaming -- + --------------------------- + + function Find_Package_Renaming + (P : Entity_Id; + L : Entity_Id) return Entity_Id + is + E1 : Entity_Id; + R : Entity_Id; + + begin + Is_Visible_Renaming := False; + + E1 := First_Entity (P); + while Present (E1) loop + if Ekind (E1) = E_Package + and then Renamed_Object (E1) = L + then + Is_Visible_Renaming := not Is_Hidden (E1); + return E1; + + elsif Ekind (E1) = E_Package + and then No (Renamed_Object (E1)) + and then not Is_Generic_Instance (E1) + then + R := Find_Package_Renaming (E1, L); + + if Present (R) then + Is_Visible_Renaming := not Is_Hidden (R); + return R; + end if; + end if; + + Next_Entity (E1); + end loop; + + return Empty; + end Find_Package_Renaming; + + -------------------------- + -- Has_Visible_Entities -- + -------------------------- + + function Has_Visible_Entities (P : Entity_Id) return Boolean is + E : Entity_Id; + + begin + -- If unit in context is not a package, it is a subprogram that + -- is not called or a generic unit that is not instantiated + -- in the current unit, and warning is appropriate. + + if Ekind (P) /= E_Package then + return True; + end if; + + -- If unit comes from a limited_with clause, look for declaration + -- of shadow entities. + + if Present (Limited_View (P)) then + E := First_Entity (Limited_View (P)); + else + E := First_Entity (P); + end if; + + while Present (E) + and then E /= First_Private_Entity (P) + loop + if Comes_From_Source (E) + or else Present (Limited_View (P)) + then + return True; + end if; + + Next_Entity (E); + end loop; + + return False; + end Has_Visible_Entities; + + -- Start of processing for Check_One_Unit + + begin + Cnode := Cunit (Unit); + + -- Only do check in units that are part of the extended main unit. + -- This is actually a necessary restriction, because in the case of + -- subprogram acting as its own specification, there can be with's in + -- subunits that we will not see. + + if not In_Extended_Main_Source_Unit (Cnode) then + return; + + -- In configurable run time mode, we remove the bodies of non-inlined + -- subprograms, which may lead to spurious warnings, which are + -- clearly undesirable. + + elsif Configurable_Run_Time_Mode + and then Is_Predefined_File_Name (Unit_File_Name (Unit)) + then + return; + end if; + + -- Loop through context items in this unit + + Item := First (Context_Items (Cnode)); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then not Implicit_With (Item) + and then In_Extended_Main_Source_Unit (Item) + then + Lunit := Entity (Name (Item)); + + -- Check if this unit is referenced (skip the check if this + -- is explicitly marked by a pragma Unreferenced). + + if not Referenced (Lunit) + and then not Has_Unreferenced (Lunit) + then + -- Suppress warnings in internal units if not in -gnatg mode + -- (these would be junk warnings for an application program, + -- since they refer to problems in internal units). + + if GNAT_Mode + or else not Is_Internal_File_Name (Unit_File_Name (Unit)) + then + -- Here we definitely have a non-referenced unit. If it + -- is the special call for a spec unit, then just set the + -- flag to be read later. + + if Unit = Spec_Unit then + Set_Unreferenced_In_Spec (Item); + + -- Otherwise simple unreferenced message, but skip this + -- if no visible entities, because that is most likely a + -- case where warning would be false positive (e.g. a + -- package with only a linker options pragma and nothing + -- else or a pragma elaborate with a body library task). + + elsif Has_Visible_Entities (Entity (Name (Item))) then + Error_Msg_N -- CODEFIX + ("?unit& is not referenced!", Name (Item)); + end if; + end if; + + -- If main unit is a renaming of this unit, then we consider + -- the with to be OK (obviously it is needed in this case!) + -- This may be transitive: the unit in the with_clause may + -- itself be a renaming, in which case both it and the main + -- unit rename the same ultimate package. + + elsif Present (Renamed_Entity (Munite)) + and then + (Renamed_Entity (Munite) = Lunit + or else Renamed_Entity (Munite) = Renamed_Entity (Lunit)) + then + null; + + -- If this unit is referenced, and it is a package, we do + -- another test, to see if any of the entities in the package + -- are referenced. If none of the entities are referenced, we + -- still post a warning. This occurs if the only use of the + -- package is in a use clause, or in a package renaming + -- declaration. This check is skipped for packages that are + -- renamed in a spec, since the entities in such a package are + -- visible to clients via the renaming. + + elsif Ekind (Lunit) = E_Package + and then not Renamed_In_Spec (Lunit) + then + -- If Is_Instantiated is set, it means that the package is + -- implicitly instantiated (this is the case of parent + -- instance or an actual for a generic package formal), and + -- this counts as a reference. + + if Is_Instantiated (Lunit) then + null; + + -- If no entities in package, and there is a pragma + -- Elaborate_Body present, then assume that this with is + -- done for purposes of this elaboration. + + elsif No (First_Entity (Lunit)) + and then Has_Pragma_Elaborate_Body (Lunit) + then + null; + + -- Otherwise see if any entities have been referenced + + else + if Limited_Present (Item) then + Ent := First_Entity (Limited_View (Lunit)); + else + Ent := First_Entity (Lunit); + end if; + + loop + -- No more entities, and we did not find one that was + -- referenced. Means we have a definite case of a with + -- none of whose entities was referenced. + + if No (Ent) then + + -- If in spec, just set the flag + + if Unit = Spec_Unit then + Set_No_Entities_Ref_In_Spec (Item); + + elsif Check_System_Aux then + null; + + -- Else give the warning + + else + if not + Has_Unreferenced (Entity (Name (Item))) + then + Error_Msg_N -- CODEFIX + ("?no entities of & are referenced!", + Name (Item)); + end if; + + -- Look for renamings of this package, and flag + -- them as well. If the original package has + -- warnings off, we suppress the warning on the + -- renaming as well. + + Pack := Find_Package_Renaming (Munite, Lunit); + + if Present (Pack) + and then not Has_Warnings_Off (Lunit) + and then not Has_Unreferenced (Pack) + then + Error_Msg_NE -- CODEFIX + ("?no entities of & are referenced!", + Unit_Declaration_Node (Pack), + Pack); + end if; + end if; + + exit; + + -- Case of entity being referenced. The reference may + -- come from a limited_with_clause, in which case the + -- limited view of the entity carries the flag. + + elsif Referenced_Check_Spec (Ent) + or else Referenced_As_LHS_Check_Spec (Ent) + or else Referenced_As_Out_Parameter_Check_Spec (Ent) + or else + (From_With_Type (Ent) + and then Is_Incomplete_Type (Ent) + and then Present (Non_Limited_View (Ent)) + and then Referenced (Non_Limited_View (Ent))) + then + -- This means that the with is indeed fine, in that + -- it is definitely needed somewhere, and we can + -- quit worrying about this one... + + -- Except for one little detail: if either of the + -- flags was set during spec processing, this is + -- where we complain that the with could be moved + -- from the spec. If the spec contains a visible + -- renaming of the package, inhibit warning to move + -- with_clause to body. + + if Ekind (Munite) = E_Package_Body then + Pack := + Find_Package_Renaming + (Spec_Entity (Munite), Lunit); + end if; + + if Unreferenced_In_Spec (Item) then + Error_Msg_N -- CODEFIX + ("?unit& is not referenced in spec!", + Name (Item)); + + elsif No_Entities_Ref_In_Spec (Item) then + Error_Msg_N -- CODEFIX + ("?no entities of & are referenced in spec!", + Name (Item)); + + else + if Ekind (Ent) = E_Package then + Check_Inner_Package (Ent); + end if; + + exit; + end if; + + if not Is_Visible_Renaming then + Error_Msg_N -- CODEFIX + ("\?with clause might be moved to body!", + Name (Item)); + end if; + + exit; + + -- Move to next entity to continue search + + else + Next_Entity (Ent); + end if; + end loop; + end if; + + -- For a generic package, the only interesting kind of + -- reference is an instantiation, since entities cannot be + -- referenced directly. + + elsif Is_Generic_Unit (Lunit) then + + -- Unit was never instantiated, set flag for case of spec + -- call, or give warning for normal call. + + if not Is_Instantiated (Lunit) then + if Unit = Spec_Unit then + Set_Unreferenced_In_Spec (Item); + else + Error_Msg_N -- CODEFIX + ("?unit& is never instantiated!", Name (Item)); + end if; + + -- If unit was indeed instantiated, make sure that flag is + -- not set showing it was uninstantiated in the spec, and if + -- so, give warning. + + elsif Unreferenced_In_Spec (Item) then + Error_Msg_N + ("?unit& is not instantiated in spec!", Name (Item)); + Error_Msg_N -- CODEFIX + ("\?with clause can be moved to body!", Name (Item)); + end if; + end if; + end if; + + Next (Item); + end loop; + end Check_One_Unit; + + -- Start of processing for Check_Unused_Withs + + begin + if not Opt.Check_Withs + or else Operating_Mode = Check_Syntax + then + return; + end if; + + -- Flag any unused with clauses, but skip this step if we are compiling + -- a subunit on its own, since we do not have enough information to + -- determine whether with's are used. We will get the relevant warnings + -- when we compile the parent. This is the normal style of GNAT + -- compilation in any case. + + if Nkind (Unit (Cunit (Main_Unit))) = N_Subunit then + return; + end if; + + -- Process specified units + + if Spec_Unit = No_Unit then + + -- For main call, check all units + + for Unit in Main_Unit .. Last_Unit loop + Check_One_Unit (Unit); + end loop; + + else + -- For call for spec, check only the spec + + Check_One_Unit (Spec_Unit); + end if; + end Check_Unused_Withs; + + --------------------------------- + -- Generic_Package_Spec_Entity -- + --------------------------------- + + function Generic_Package_Spec_Entity (E : Entity_Id) return Boolean is + S : Entity_Id; + + begin + if Is_Package_Body_Entity (E) then + return False; + + else + S := Scope (E); + loop + if S = Standard_Standard then + return False; + + elsif Ekind (S) = E_Generic_Package then + return True; + + elsif Ekind (S) = E_Package then + S := Scope (S); + + else + return False; + end if; + end loop; + end if; + end Generic_Package_Spec_Entity; + + ---------------------- + -- Goto_Spec_Entity -- + ---------------------- + + function Goto_Spec_Entity (E : Entity_Id) return Entity_Id is + begin + if Is_Formal (E) + and then Present (Spec_Entity (E)) + then + return Spec_Entity (E); + else + return E; + end if; + end Goto_Spec_Entity; + + -------------------------------------- + -- Has_Pragma_Unmodified_Check_Spec -- + -------------------------------------- + + function Has_Pragma_Unmodified_Check_Spec + (E : Entity_Id) return Boolean + is + begin + if Is_Formal (E) and then Present (Spec_Entity (E)) then + + -- Note: use of OR instead of OR ELSE here is deliberate, we want + -- to mess with Unmodified flags on both body and spec entities. + + return Has_Unmodified (E) + or + Has_Unmodified (Spec_Entity (E)); + + else + return Has_Unmodified (E); + end if; + end Has_Pragma_Unmodified_Check_Spec; + + ---------------------------------------- + -- Has_Pragma_Unreferenced_Check_Spec -- + ---------------------------------------- + + function Has_Pragma_Unreferenced_Check_Spec + (E : Entity_Id) return Boolean + is + begin + if Is_Formal (E) and then Present (Spec_Entity (E)) then + + -- Note: use of OR here instead of OR ELSE is deliberate, we want + -- to mess with flags on both entities. + + return Has_Unreferenced (E) + or + Has_Unreferenced (Spec_Entity (E)); + + else + return Has_Unreferenced (E); + end if; + end Has_Pragma_Unreferenced_Check_Spec; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Warnings_Off_Pragmas.Init; + Unreferenced_Entities.Init; + In_Out_Warnings.Init; + end Initialize; + + ------------------------------------ + -- Never_Set_In_Source_Check_Spec -- + ------------------------------------ + + function Never_Set_In_Source_Check_Spec (E : Entity_Id) return Boolean is + begin + if Is_Formal (E) and then Present (Spec_Entity (E)) then + return Never_Set_In_Source (E) + and then + Never_Set_In_Source (Spec_Entity (E)); + else + return Never_Set_In_Source (E); + end if; + end Never_Set_In_Source_Check_Spec; + + ------------------------------------- + -- Operand_Has_Warnings_Suppressed -- + ------------------------------------- + + function Operand_Has_Warnings_Suppressed (N : Node_Id) return Boolean is + + function Check_For_Warnings (N : Node_Id) return Traverse_Result; + -- Function used to check one node to see if it is or was originally + -- a reference to an entity for which Warnings are off. If so, Abandon + -- is returned, otherwise OK_Orig is returned to continue the traversal + -- of the original expression. + + function Traverse is new Traverse_Func (Check_For_Warnings); + -- Function used to traverse tree looking for warnings + + ------------------------ + -- Check_For_Warnings -- + ------------------------ + + function Check_For_Warnings (N : Node_Id) return Traverse_Result is + R : constant Node_Id := Original_Node (N); + + begin + if Nkind (R) in N_Has_Entity + and then Present (Entity (R)) + and then Has_Warnings_Off (Entity (R)) + then + return Abandon; + else + return OK_Orig; + end if; + end Check_For_Warnings; + + -- Start of processing for Operand_Has_Warnings_Suppressed + + begin + return Traverse (N) = Abandon; + + -- If any exception occurs, then something has gone wrong, and this is + -- only a minor aesthetic issue anyway, so just say we did not find what + -- we are looking for, rather than blow up. + + exception + when others => + return False; + end Operand_Has_Warnings_Suppressed; + + ----------------------------------------- + -- Output_Non_Modified_In_Out_Warnings -- + ----------------------------------------- + + procedure Output_Non_Modified_In_Out_Warnings is + + function No_Warn_On_In_Out (E : Entity_Id) return Boolean; + -- Given a formal parameter entity E, determines if there is a reason to + -- suppress IN OUT warnings (not modified, could be IN) for formals of + -- the subprogram. We suppress these warnings if Warnings Off is set, or + -- if we have seen the address of the subprogram being taken, or if the + -- subprogram is used as a generic actual (in the latter cases the + -- context may force use of IN OUT, even if the parameter is not + -- modifies for this particular case. + + ----------------------- + -- No_Warn_On_In_Out -- + ----------------------- + + function No_Warn_On_In_Out (E : Entity_Id) return Boolean is + S : constant Entity_Id := Scope (E); + SE : constant Entity_Id := Spec_Entity (E); + + begin + -- Do not warn if address is taken, since funny business may be going + -- on in treating the parameter indirectly as IN OUT. + + if Address_Taken (S) + or else (Present (SE) and then Address_Taken (Scope (SE))) + then + return True; + + -- Do not warn if used as a generic actual, since the generic may be + -- what is forcing the use of an "unnecessary" IN OUT. + + elsif Used_As_Generic_Actual (S) + or else (Present (SE) and then Used_As_Generic_Actual (Scope (SE))) + then + return True; + + -- Else test warnings off + + elsif Warnings_Off_Check_Spec (S) then + return True; + + -- All tests for suppressing warning failed + + else + return False; + end if; + end No_Warn_On_In_Out; + + -- Start of processing for Output_Non_Modified_In_Out_Warnings + + begin + -- Loop through entities for which a warning may be needed + + for J in In_Out_Warnings.First .. In_Out_Warnings.Last loop + declare + E1 : constant Entity_Id := In_Out_Warnings.Table (J); + + begin + -- Suppress warning in specific cases (see details in comments for + -- No_Warn_On_In_Out), or if there is a pragma Unmodified. + + if Has_Pragma_Unmodified_Check_Spec (E1) + or else No_Warn_On_In_Out (E1) + then + null; + + -- Here we generate the warning + + else + -- If -gnatwc is set then output message that we could be IN + + if not Is_Trivial_Subprogram (Scope (E1)) then + if Warn_On_Constant then + Error_Msg_N + ("?formal parameter & is not modified!", E1); + Error_Msg_N + ("\?mode could be IN instead of `IN OUT`!", E1); + + -- We do not generate warnings for IN OUT parameters + -- unless we have at least -gnatwu. This is deliberately + -- inconsistent with the treatment of variables, but + -- otherwise we get too many unexpected warnings in + -- default mode. + + elsif Check_Unreferenced then + Error_Msg_N + ("?formal parameter& is read but " + & "never assigned!", E1); + end if; + end if; + + -- Kill any other warnings on this entity, since this is the + -- one that should dominate any other unreferenced warning. + + Set_Warnings_Off (E1); + end if; + end; + end loop; + end Output_Non_Modified_In_Out_Warnings; + + ---------------------------------------- + -- Output_Obsolescent_Entity_Warnings -- + ---------------------------------------- + + procedure Output_Obsolescent_Entity_Warnings (N : Node_Id; E : Entity_Id) is + P : constant Node_Id := Parent (N); + S : Entity_Id; + + begin + S := Current_Scope; + + -- Do not output message if we are the scope of standard. This means + -- we have a reference from a context clause from when it is originally + -- processed, and that's too early to tell whether it is an obsolescent + -- unit doing the with'ing. In Sem_Ch10.Analyze_Compilation_Unit we make + -- sure that we have a later call when the scope is available. This test + -- also eliminates all messages for use clauses, which is fine (we do + -- not want messages for use clauses, since they are always redundant + -- with respect to the associated with clause). + + if S = Standard_Standard then + return; + end if; + + -- Do not output message if we are in scope of an obsolescent package + -- or subprogram. + + loop + if Is_Obsolescent (S) then + return; + end if; + + S := Scope (S); + exit when S = Standard_Standard; + end loop; + + -- Here we will output the message + + Error_Msg_Sloc := Sloc (E); + + -- Case of with clause + + if Nkind (P) = N_With_Clause then + if Ekind (E) = E_Package then + Error_Msg_NE + ("?with of obsolescent package& declared#", N, E); + elsif Ekind (E) = E_Procedure then + Error_Msg_NE + ("?with of obsolescent procedure& declared#", N, E); + else + Error_Msg_NE + ("?with of obsolescent function& declared#", N, E); + end if; + + -- If we do not have a with clause, then ignore any reference to an + -- obsolescent package name. We only want to give the one warning of + -- withing the package, not one each time it is used to qualify. + + elsif Ekind (E) = E_Package then + return; + + -- Procedure call statement + + elsif Nkind (P) = N_Procedure_Call_Statement then + Error_Msg_NE + ("?call to obsolescent procedure& declared#", N, E); + + -- Function call + + elsif Nkind (P) = N_Function_Call then + Error_Msg_NE + ("?call to obsolescent function& declared#", N, E); + + -- Reference to obsolescent type + + elsif Is_Type (E) then + Error_Msg_NE + ("?reference to obsolescent type& declared#", N, E); + + -- Reference to obsolescent component + + elsif Ekind_In (E, E_Component, E_Discriminant) then + Error_Msg_NE + ("?reference to obsolescent component& declared#", N, E); + + -- Reference to obsolescent variable + + elsif Ekind (E) = E_Variable then + Error_Msg_NE + ("?reference to obsolescent variable& declared#", N, E); + + -- Reference to obsolescent constant + + elsif Ekind (E) = E_Constant + or else Ekind (E) in Named_Kind + then + Error_Msg_NE + ("?reference to obsolescent constant& declared#", N, E); + + -- Reference to obsolescent enumeration literal + + elsif Ekind (E) = E_Enumeration_Literal then + Error_Msg_NE + ("?reference to obsolescent enumeration literal& declared#", N, E); + + -- Generic message for any other case we missed + + else + Error_Msg_NE + ("?reference to obsolescent entity& declared#", N, E); + end if; + + -- Output additional warning if present + + for J in Obsolescent_Warnings.First .. Obsolescent_Warnings.Last loop + if Obsolescent_Warnings.Table (J).Ent = E then + String_To_Name_Buffer (Obsolescent_Warnings.Table (J).Msg); + Error_Msg_Strlen := Name_Len; + Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); + Error_Msg_N ("\\?~", N); + exit; + end if; + end loop; + end Output_Obsolescent_Entity_Warnings; + + ---------------------------------- + -- Output_Unreferenced_Messages -- + ---------------------------------- + + procedure Output_Unreferenced_Messages is + begin + for J in Unreferenced_Entities.First .. + Unreferenced_Entities.Last + loop + Warn_On_Unreferenced_Entity (Unreferenced_Entities.Table (J)); + end loop; + end Output_Unreferenced_Messages; + + ----------------------------------------- + -- Output_Unused_Warnings_Off_Warnings -- + ----------------------------------------- + + procedure Output_Unused_Warnings_Off_Warnings is + begin + for J in Warnings_Off_Pragmas.First .. Warnings_Off_Pragmas.Last loop + declare + Wentry : Warnings_Off_Entry renames Warnings_Off_Pragmas.Table (J); + N : Node_Id renames Wentry.N; + E : Node_Id renames Wentry.E; + + begin + -- Turn off Warnings_Off, or we won't get the warning! + + Set_Warnings_Off (E, False); + + -- Nothing to do if pragma was used to suppress a general warning + + if Warnings_Off_Used (E) then + null; + + -- If pragma was used both in unmodified and unreferenced contexts + -- then that's as good as the general case, no warning. + + elsif Warnings_Off_Used_Unmodified (E) + and + Warnings_Off_Used_Unreferenced (E) + then + null; + + -- Used only in context where Unmodified would have worked + + elsif Warnings_Off_Used_Unmodified (E) then + Error_Msg_NE + ("?could use Unmodified instead of " + & "Warnings Off for &", Pragma_Identifier (N), E); + + -- Used only in context where Unreferenced would have worked + + elsif Warnings_Off_Used_Unreferenced (E) then + Error_Msg_NE + ("?could use Unreferenced instead of " + & "Warnings Off for &", Pragma_Identifier (N), E); + + -- Not used at all + + else + Error_Msg_NE + ("?pragma Warnings Off for & unused, " + & "could be omitted", N, E); + end if; + end; + end loop; + end Output_Unused_Warnings_Off_Warnings; + + --------------------------- + -- Referenced_Check_Spec -- + --------------------------- + + function Referenced_Check_Spec (E : Entity_Id) return Boolean is + begin + if Is_Formal (E) and then Present (Spec_Entity (E)) then + return Referenced (E) or else Referenced (Spec_Entity (E)); + else + return Referenced (E); + end if; + end Referenced_Check_Spec; + + ---------------------------------- + -- Referenced_As_LHS_Check_Spec -- + ---------------------------------- + + function Referenced_As_LHS_Check_Spec (E : Entity_Id) return Boolean is + begin + if Is_Formal (E) and then Present (Spec_Entity (E)) then + return Referenced_As_LHS (E) + or else Referenced_As_LHS (Spec_Entity (E)); + else + return Referenced_As_LHS (E); + end if; + end Referenced_As_LHS_Check_Spec; + + -------------------------------------------- + -- Referenced_As_Out_Parameter_Check_Spec -- + -------------------------------------------- + + function Referenced_As_Out_Parameter_Check_Spec + (E : Entity_Id) return Boolean + is + begin + if Is_Formal (E) and then Present (Spec_Entity (E)) then + return Referenced_As_Out_Parameter (E) + or else Referenced_As_Out_Parameter (Spec_Entity (E)); + else + return Referenced_As_Out_Parameter (E); + end if; + end Referenced_As_Out_Parameter_Check_Spec; + + ---------------------------- + -- Set_Dot_Warning_Switch -- + ---------------------------- + + function Set_Dot_Warning_Switch (C : Character) return Boolean is + begin + case C is + when 'a' => + Warn_On_Assertion_Failure := True; + + when 'A' => + Warn_On_Assertion_Failure := False; + + when 'b' => + Warn_On_Biased_Representation := True; + + when 'B' => + Warn_On_Biased_Representation := False; + + when 'c' => + Warn_On_Unrepped_Components := True; + + when 'C' => + Warn_On_Unrepped_Components := False; + + when 'e' => + Address_Clause_Overlay_Warnings := True; + Check_Unreferenced := True; + Check_Unreferenced_Formals := True; + Check_Withs := True; + Constant_Condition_Warnings := True; + Elab_Warnings := True; + Implementation_Unit_Warnings := True; + Ineffective_Inline_Warnings := True; + List_Inherited_Aspects := True; + Warn_On_Ada_2005_Compatibility := True; + Warn_On_Ada_2012_Compatibility := True; + Warn_On_All_Unread_Out_Parameters := True; + Warn_On_Assertion_Failure := True; + Warn_On_Assumed_Low_Bound := True; + Warn_On_Bad_Fixed_Value := True; + Warn_On_Biased_Representation := True; + Warn_On_Constant := True; + Warn_On_Deleted_Code := True; + Warn_On_Dereference := True; + Warn_On_Export_Import := True; + Warn_On_Hiding := True; + Warn_On_Modified_Unread := True; + Warn_On_No_Value_Assigned := True; + Warn_On_Non_Local_Exception := True; + Warn_On_Object_Renames_Function := True; + Warn_On_Obsolescent_Feature := True; + Warn_On_Overlap := True; + Warn_On_Overridden_Size := True; + Warn_On_Parameter_Order := True; + Warn_On_Questionable_Missing_Parens := True; + Warn_On_Record_Holes := True; + Warn_On_Redundant_Constructs := True; + Warn_On_Reverse_Bit_Order := True; + Warn_On_Unchecked_Conversion := True; + Warn_On_Unordered_Enumeration_Type := True; + Warn_On_Unrecognized_Pragma := True; + Warn_On_Unrepped_Components := True; + Warn_On_Warnings_Off := True; + + when 'g' => + Set_GNAT_Mode_Warnings; + + when 'h' => + Warn_On_Record_Holes := True; + + when 'H' => + Warn_On_Record_Holes := False; + + when 'i' => + Warn_On_Overlap := True; + + when 'I' => + Warn_On_Overlap := False; + + when 'l' => + List_Inherited_Aspects := True; + + when 'L' => + List_Inherited_Aspects := False; + + when 'm' => + Warn_On_Suspicious_Modulus_Value := True; + + when 'M' => + Warn_On_Suspicious_Modulus_Value := False; + + when 'o' => + Warn_On_All_Unread_Out_Parameters := True; + + when 'O' => + Warn_On_All_Unread_Out_Parameters := False; + + when 'p' => + Warn_On_Parameter_Order := True; + + when 'P' => + Warn_On_Parameter_Order := False; + + when 'r' => + Warn_On_Object_Renames_Function := True; + + when 'R' => + Warn_On_Object_Renames_Function := False; + + when 's' => + Warn_On_Overridden_Size := True; + + when 'S' => + Warn_On_Overridden_Size := False; + + when 'u' => + Warn_On_Unordered_Enumeration_Type := True; + + when 'U' => + Warn_On_Unordered_Enumeration_Type := False; + + when 'v' => + Warn_On_Reverse_Bit_Order := True; + + when 'V' => + Warn_On_Reverse_Bit_Order := False; + + when 'w' => + Warn_On_Warnings_Off := True; + + when 'W' => + Warn_On_Warnings_Off := False; + + when 'x' => + Warn_On_Non_Local_Exception := True; + + when 'X' => + Warn_On_Non_Local_Exception := False; + No_Warn_On_Non_Local_Exception := True; + + when others => + return False; + end case; + + return True; + end Set_Dot_Warning_Switch; + + ---------------------------- + -- Set_GNAT_Mode_Warnings -- + ---------------------------- + + procedure Set_GNAT_Mode_Warnings is + begin + Address_Clause_Overlay_Warnings := True; + Check_Unreferenced := True; + Check_Unreferenced_Formals := True; + Check_Withs := True; + Constant_Condition_Warnings := True; + Elab_Warnings := False; + Implementation_Unit_Warnings := False; + Ineffective_Inline_Warnings := True; + List_Inherited_Aspects := False; + Warn_On_Ada_2005_Compatibility := True; + Warn_On_Ada_2012_Compatibility := True; + Warn_On_All_Unread_Out_Parameters := False; + Warn_On_Assertion_Failure := True; + Warn_On_Assumed_Low_Bound := True; + Warn_On_Bad_Fixed_Value := True; + Warn_On_Biased_Representation := True; + Warn_On_Constant := True; + Warn_On_Deleted_Code := False; + Warn_On_Dereference := False; + Warn_On_Export_Import := True; + Warn_On_Hiding := False; + Warn_On_Modified_Unread := True; + Warn_On_No_Value_Assigned := True; + Warn_On_Non_Local_Exception := False; + Warn_On_Object_Renames_Function := False; + Warn_On_Obsolescent_Feature := True; + Warn_On_Questionable_Missing_Parens := True; + Warn_On_Redundant_Constructs := True; + Warn_On_Reverse_Bit_Order := False; + Warn_On_Object_Renames_Function := True; + Warn_On_Unchecked_Conversion := True; + Warn_On_Unordered_Enumeration_Type := False; + Warn_On_Unrecognized_Pragma := True; + Warn_On_Unrepped_Components := False; + Warn_On_Warnings_Off := False; + end Set_GNAT_Mode_Warnings; + + ------------------------ + -- Set_Warning_Switch -- + ------------------------ + + function Set_Warning_Switch (C : Character) return Boolean is + begin + case C is + when 'a' => + Check_Unreferenced := True; + Check_Unreferenced_Formals := True; + Check_Withs := True; + Constant_Condition_Warnings := True; + Implementation_Unit_Warnings := True; + Ineffective_Inline_Warnings := True; + List_Inherited_Aspects := True; + Warn_On_Ada_2005_Compatibility := True; + Warn_On_Ada_2012_Compatibility := True; + Warn_On_Assertion_Failure := True; + Warn_On_Assumed_Low_Bound := True; + Warn_On_Bad_Fixed_Value := True; + Warn_On_Biased_Representation := True; + Warn_On_Constant := True; + Warn_On_Export_Import := True; + Warn_On_Modified_Unread := True; + Warn_On_No_Value_Assigned := True; + Warn_On_Non_Local_Exception := True; + Warn_On_Object_Renames_Function := True; + Warn_On_Obsolescent_Feature := True; + Warn_On_Parameter_Order := True; + Warn_On_Questionable_Missing_Parens := True; + Warn_On_Redundant_Constructs := True; + Warn_On_Reverse_Bit_Order := True; + Warn_On_Unchecked_Conversion := True; + Warn_On_Unrecognized_Pragma := True; + Warn_On_Unrepped_Components := True; + + when 'A' => + Address_Clause_Overlay_Warnings := False; + Check_Unreferenced := False; + Check_Unreferenced_Formals := False; + Check_Withs := False; + Constant_Condition_Warnings := False; + Elab_Warnings := False; + Implementation_Unit_Warnings := False; + Ineffective_Inline_Warnings := False; + List_Inherited_Aspects := False; + Warn_On_Ada_2005_Compatibility := False; + Warn_On_Ada_2012_Compatibility := False; + Warn_On_All_Unread_Out_Parameters := False; + Warn_On_Assertion_Failure := False; + Warn_On_Assumed_Low_Bound := False; + Warn_On_Bad_Fixed_Value := False; + Warn_On_Biased_Representation := False; + Warn_On_Constant := False; + Warn_On_Deleted_Code := False; + Warn_On_Dereference := False; + Warn_On_Export_Import := False; + Warn_On_Hiding := False; + Warn_On_Modified_Unread := False; + Warn_On_No_Value_Assigned := False; + Warn_On_Non_Local_Exception := False; + Warn_On_Object_Renames_Function := False; + Warn_On_Obsolescent_Feature := False; + Warn_On_Overlap := False; + Warn_On_Overridden_Size := False; + Warn_On_Parameter_Order := False; + Warn_On_Record_Holes := False; + Warn_On_Questionable_Missing_Parens := False; + Warn_On_Redundant_Constructs := False; + Warn_On_Reverse_Bit_Order := False; + Warn_On_Unchecked_Conversion := False; + Warn_On_Unordered_Enumeration_Type := False; + Warn_On_Unrecognized_Pragma := False; + Warn_On_Unrepped_Components := False; + Warn_On_Warnings_Off := False; + + No_Warn_On_Non_Local_Exception := True; + + when 'b' => + Warn_On_Bad_Fixed_Value := True; + + when 'B' => + Warn_On_Bad_Fixed_Value := False; + + when 'c' => + Constant_Condition_Warnings := True; + + when 'C' => + Constant_Condition_Warnings := False; + + when 'd' => + Warn_On_Dereference := True; + + when 'D' => + Warn_On_Dereference := False; + + when 'e' => + Warning_Mode := Treat_As_Error; + + when 'f' => + Check_Unreferenced_Formals := True; + + when 'F' => + Check_Unreferenced_Formals := False; + + when 'g' => + Warn_On_Unrecognized_Pragma := True; + + when 'G' => + Warn_On_Unrecognized_Pragma := False; + + when 'h' => + Warn_On_Hiding := True; + + when 'H' => + Warn_On_Hiding := False; + + when 'i' => + Implementation_Unit_Warnings := True; + + when 'I' => + Implementation_Unit_Warnings := False; + + when 'j' => + Warn_On_Obsolescent_Feature := True; + + when 'J' => + Warn_On_Obsolescent_Feature := False; + + when 'k' => + Warn_On_Constant := True; + + when 'K' => + Warn_On_Constant := False; + + when 'l' => + Elab_Warnings := True; + + when 'L' => + Elab_Warnings := False; + + when 'm' => + Warn_On_Modified_Unread := True; + + when 'M' => + Warn_On_Modified_Unread := False; + + when 'n' => + Warning_Mode := Normal; + + when 'o' => + Address_Clause_Overlay_Warnings := True; + + when 'O' => + Address_Clause_Overlay_Warnings := False; + + when 'p' => + Ineffective_Inline_Warnings := True; + + when 'P' => + Ineffective_Inline_Warnings := False; + + when 'q' => + Warn_On_Questionable_Missing_Parens := True; + + when 'Q' => + Warn_On_Questionable_Missing_Parens := False; + + when 'r' => + Warn_On_Redundant_Constructs := True; + + when 'R' => + Warn_On_Redundant_Constructs := False; + + when 's' => + Warning_Mode := Suppress; + + when 't' => + Warn_On_Deleted_Code := True; + + when 'T' => + Warn_On_Deleted_Code := False; + + when 'u' => + Check_Unreferenced := True; + Check_Withs := True; + Check_Unreferenced_Formals := True; + + when 'U' => + Check_Unreferenced := False; + Check_Withs := False; + Check_Unreferenced_Formals := False; + + when 'v' => + Warn_On_No_Value_Assigned := True; + + when 'V' => + Warn_On_No_Value_Assigned := False; + + when 'w' => + Warn_On_Assumed_Low_Bound := True; + + when 'W' => + Warn_On_Assumed_Low_Bound := False; + + when 'x' => + Warn_On_Export_Import := True; + + when 'X' => + Warn_On_Export_Import := False; + + when 'y' => + Warn_On_Ada_2005_Compatibility := True; + Warn_On_Ada_2012_Compatibility := True; + + when 'Y' => + Warn_On_Ada_2005_Compatibility := False; + Warn_On_Ada_2012_Compatibility := False; + + when 'z' => + Warn_On_Unchecked_Conversion := True; + + when 'Z' => + Warn_On_Unchecked_Conversion := False; + + when others => + return False; + end case; + + return True; + end Set_Warning_Switch; + + ----------------------------- + -- Warn_On_Known_Condition -- + ----------------------------- + + procedure Warn_On_Known_Condition (C : Node_Id) is + P : Node_Id; + Orig : constant Node_Id := Original_Node (C); + Test_Result : Boolean; + + function Is_Known_Branch return Boolean; + -- If the type of the condition is Boolean, the constant value of the + -- condition is a boolean literal. If the type is a derived boolean + -- type, the constant is wrapped in a type conversion of the derived + -- literal. If the value of the condition is not a literal, no warnings + -- can be produced. This function returns True if the result can be + -- determined, and Test_Result is set True/False accordingly. Otherwise + -- False is returned, and Test_Result is unchanged. + + procedure Track (N : Node_Id; Loc : Node_Id); + -- Adds continuation warning(s) pointing to reason (assignment or test) + -- for the operand of the conditional having a known value (or at least + -- enough is known about the value to issue the warning). N is the node + -- which is judged to have a known value. Loc is the warning location. + + --------------------- + -- Is_Known_Branch -- + --------------------- + + function Is_Known_Branch return Boolean is + begin + if Etype (C) = Standard_Boolean + and then Is_Entity_Name (C) + and then + (Entity (C) = Standard_False or else Entity (C) = Standard_True) + then + Test_Result := Entity (C) = Standard_True; + return True; + + elsif Is_Boolean_Type (Etype (C)) + and then Nkind (C) = N_Unchecked_Type_Conversion + and then Is_Entity_Name (Expression (C)) + and then Ekind (Entity (Expression (C))) = E_Enumeration_Literal + then + Test_Result := + Chars (Entity (Expression (C))) = Chars (Standard_True); + return True; + + else + return False; + end if; + end Is_Known_Branch; + + ----------- + -- Track -- + ----------- + + procedure Track (N : Node_Id; Loc : Node_Id) is + Nod : constant Node_Id := Original_Node (N); + + begin + if Nkind (Nod) in N_Op_Compare then + Track (Left_Opnd (Nod), Loc); + Track (Right_Opnd (Nod), Loc); + + elsif Is_Entity_Name (Nod) + and then Is_Object (Entity (Nod)) + then + declare + CV : constant Node_Id := Current_Value (Entity (Nod)); + + begin + if Present (CV) then + Error_Msg_Sloc := Sloc (CV); + + if Nkind (CV) not in N_Subexpr then + Error_Msg_N ("\\?(see test #)", Loc); + + elsif Nkind (Parent (CV)) = + N_Case_Statement_Alternative + then + Error_Msg_N ("\\?(see case alternative #)", Loc); + + else + Error_Msg_N ("\\?(see assignment #)", Loc); + end if; + end if; + end; + end if; + end Track; + + -- Start of processing for Warn_On_Known_Condition + + begin + -- Adjust SCO condition if from source + + if Generate_SCO + and then Comes_From_Source (Orig) + and then Is_Known_Branch + then + declare + Atrue : Boolean; + + begin + Atrue := Test_Result; + + if Present (Parent (C)) and then Nkind (Parent (C)) = N_Op_Not then + Atrue := not Atrue; + end if; + + Set_SCO_Condition (Orig, Atrue); + end; + end if; + + -- Argument replacement in an inlined body can make conditions static. + -- Do not emit warnings in this case. + + if In_Inlined_Body then + return; + end if; + + if Constant_Condition_Warnings + and then Is_Known_Branch + and then Comes_From_Source (Original_Node (C)) + and then not In_Instance + then + -- See if this is in a statement or a declaration + + P := Parent (C); + loop + -- If tree is not attached, do not issue warning (this is very + -- peculiar, and probably arises from some other error condition) + + if No (P) then + return; + + -- If we are in a declaration, then no warning, since in practice + -- conditionals in declarations are used for intended tests which + -- may be known at compile time, e.g. things like + + -- x : constant Integer := 2 + (Word'Size = 32); + + -- And a warning is annoying in such cases + + elsif Nkind (P) in N_Declaration + or else + Nkind (P) in N_Later_Decl_Item + then + return; + + -- Don't warn in assert or check pragma, since presumably tests in + -- such a context are very definitely intended, and might well be + -- known at compile time. Note that we have to test the original + -- node, since assert pragmas get rewritten at analysis time. + + elsif Nkind (Original_Node (P)) = N_Pragma + and then (Pragma_Name (Original_Node (P)) = Name_Assert + or else + Pragma_Name (Original_Node (P)) = Name_Check) + then + return; + end if; + + exit when Is_Statement (P); + P := Parent (P); + end loop; + + -- Here we issue the warning unless some sub-operand has warnings + -- set off, in which case we suppress the warning for the node. If + -- the original expression is an inequality, it has been expanded + -- into a negation, and the value of the original expression is the + -- negation of the equality. If the expression is an entity that + -- appears within a negation, it is clearer to flag the negation + -- itself, and report on its constant value. + + if not Operand_Has_Warnings_Suppressed (C) then + declare + True_Branch : Boolean := Test_Result; + Cond : Node_Id := C; + + begin + if Present (Parent (C)) + and then Nkind (Parent (C)) = N_Op_Not + then + True_Branch := not True_Branch; + Cond := Parent (C); + end if; + + if True_Branch then + if Is_Entity_Name (Original_Node (C)) + and then Nkind (Cond) /= N_Op_Not + then + Error_Msg_NE + ("object & is always True?", Cond, Original_Node (C)); + Track (Original_Node (C), Cond); + + else + Error_Msg_N ("condition is always True?", Cond); + Track (Cond, Cond); + end if; + + else + Error_Msg_N ("condition is always False?", Cond); + Track (Cond, Cond); + end if; + end; + end if; + end if; + end Warn_On_Known_Condition; + + --------------------------------------- + -- Warn_On_Modified_As_Out_Parameter -- + --------------------------------------- + + function Warn_On_Modified_As_Out_Parameter (E : Entity_Id) return Boolean is + begin + return + (Warn_On_Modified_Unread and then Is_Only_Out_Parameter (E)) + or else Warn_On_All_Unread_Out_Parameters; + end Warn_On_Modified_As_Out_Parameter; + + --------------------------------- + -- Warn_On_Overlapping_Actuals -- + --------------------------------- + + procedure Warn_On_Overlapping_Actuals (Subp : Entity_Id; N : Node_Id) is + Act1, Act2 : Node_Id; + Form1, Form2 : Entity_Id; + + begin + if not Warn_On_Overlap then + return; + end if; + + -- Exclude calls rewritten as enumeration literals + + if not Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) then + return; + end if; + + -- Exclude calls to library subprograms. Container operations specify + -- safe behavior when source and target coincide. + + if Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Sloc (Subp)))) + then + return; + end if; + + Form1 := First_Formal (Subp); + Act1 := First_Actual (N); + while Present (Form1) and then Present (Act1) loop + if Ekind (Form1) /= E_In_Parameter then + Form2 := First_Formal (Subp); + Act2 := First_Actual (N); + while Present (Form2) and then Present (Act2) loop + if Form1 /= Form2 + and then Ekind (Form2) /= E_Out_Parameter + and then + (Denotes_Same_Object (Act1, Act2) + or else + Denotes_Same_Prefix (Act1, Act2)) + then + -- Exclude generic types and guard against previous errors. + + if Error_Posted (N) + or else No (Etype (Act1)) + or else No (Etype (Act2)) + then + null; + + elsif Is_Generic_Type (Etype (Act1)) + or else + Is_Generic_Type (Etype (Act2)) + then + null; + + -- If the actual is a function call in prefix notation, + -- there is no real overlap. + + elsif Nkind (Act2) = N_Function_Call then + null; + + -- If type is not by-copy we can assume that the aliasing is + -- intended. + + elsif + Is_By_Reference_Type (Underlying_Type (Etype (Form1))) + then + null; + + else + declare + Act : Node_Id; + Form : Entity_Id; + + begin + -- Find matching actual + + Act := First_Actual (N); + Form := First_Formal (Subp); + while Act /= Act2 loop + Next_Formal (Form); + Next_Actual (Act); + end loop; + + if Is_Elementary_Type (Etype (Act1)) + and then Ekind (Form2) = E_In_Parameter + then + null; -- no real aliasing. + + elsif Is_Elementary_Type (Etype (Act2)) + and then Ekind (Form2) = E_In_Parameter + then + null; -- ditto + + -- If the call was written in prefix notation, and + -- thus its prefix before rewriting was a selected + -- component, count only visible actuals in the call. + + elsif Is_Entity_Name (First_Actual (N)) + and then Nkind (Original_Node (N)) = Nkind (N) + and then Nkind (Name (Original_Node (N))) = + N_Selected_Component + and then + Is_Entity_Name (Prefix (Name (Original_Node (N)))) + and then + Entity (Prefix (Name (Original_Node (N)))) = + Entity (First_Actual (N)) + then + if Act1 = First_Actual (N) then + Error_Msg_FE + ("`IN OUT` prefix overlaps with actual for&?", + Act1, Form); + else + Error_Msg_FE + ("writable actual overlaps with actual for&?", + Act1, Form); + end if; + + else + Error_Msg_Node_2 := Form; + Error_Msg_FE + ("writable actual for & overlaps with" + & " actual for&?", Act1, Form1); + end if; + end; + end if; + + return; + end if; + + Next_Formal (Form2); + Next_Actual (Act2); + end loop; + end if; + + Next_Formal (Form1); + Next_Actual (Act1); + end loop; + end Warn_On_Overlapping_Actuals; + + ------------------------------ + -- Warn_On_Suspicious_Index -- + ------------------------------ + + procedure Warn_On_Suspicious_Index (Name : Entity_Id; X : Node_Id) is + + Low_Bound : Uint; + -- Set to lower bound for a suspicious type + + Ent : Entity_Id; + -- Entity for array reference + + Typ : Entity_Id; + -- Array type + + function Is_Suspicious_Type (Typ : Entity_Id) return Boolean; + -- Tests to see if Typ is a type for which we may have a suspicious + -- index, namely an unconstrained array type, whose lower bound is + -- either zero or one. If so, True is returned, and Low_Bound is set + -- to this lower bound. If not, False is returned, and Low_Bound is + -- undefined on return. + -- + -- For now, we limit this to standard string types, so any other + -- unconstrained types return False. We may change our minds on this + -- later on, but strings seem the most important case. + + procedure Test_Suspicious_Index; + -- Test if index is of suspicious type and if so, generate warning + + ------------------------ + -- Is_Suspicious_Type -- + ------------------------ + + function Is_Suspicious_Type (Typ : Entity_Id) return Boolean is + LB : Node_Id; + + begin + if Is_Array_Type (Typ) + and then not Is_Constrained (Typ) + and then Number_Dimensions (Typ) = 1 + and then (Root_Type (Typ) = Standard_String + or else + Root_Type (Typ) = Standard_Wide_String + or else + Root_Type (Typ) = Standard_Wide_Wide_String) + and then not Has_Warnings_Off (Typ) + then + LB := Type_Low_Bound (Etype (First_Index (Typ))); + + if Compile_Time_Known_Value (LB) then + Low_Bound := Expr_Value (LB); + return Low_Bound = Uint_0 or else Low_Bound = Uint_1; + end if; + end if; + + return False; + end Is_Suspicious_Type; + + --------------------------- + -- Test_Suspicious_Index -- + --------------------------- + + procedure Test_Suspicious_Index is + + function Length_Reference (N : Node_Id) return Boolean; + -- Check if node N is of the form Name'Length + + procedure Warn1; + -- Generate first warning line + + ---------------------- + -- Length_Reference -- + ---------------------- + + function Length_Reference (N : Node_Id) return Boolean is + R : constant Node_Id := Original_Node (N); + begin + return + Nkind (R) = N_Attribute_Reference + and then Attribute_Name (R) = Name_Length + and then Is_Entity_Name (Prefix (R)) + and then Entity (Prefix (R)) = Ent; + end Length_Reference; + + ----------- + -- Warn1 -- + ----------- + + procedure Warn1 is + begin + Error_Msg_Uint_1 := Low_Bound; + Error_Msg_FE -- CODEFIX + ("?index for& may assume lower bound of^", X, Ent); + end Warn1; + + -- Start of processing for Test_Suspicious_Index + + begin + -- Nothing to do if subscript does not come from source (we don't + -- want to give garbage warnings on compiler expanded code, e.g. the + -- loops generated for slice assignments. Such junk warnings would + -- be placed on source constructs with no subscript in sight!) + + if not Comes_From_Source (Original_Node (X)) then + return; + end if; + + -- Case where subscript is a constant integer + + if Nkind (X) = N_Integer_Literal then + Warn1; + + -- Case where original form of subscript is an integer literal + + if Nkind (Original_Node (X)) = N_Integer_Literal then + if Intval (X) = Low_Bound then + Error_Msg_FE -- CODEFIX + ("\suggested replacement: `&''First`", X, Ent); + else + Error_Msg_Uint_1 := Intval (X) - Low_Bound; + Error_Msg_FE -- CODEFIX + ("\suggested replacement: `&''First + ^`", X, Ent); + + end if; + + -- Case where original form of subscript is more complex + + else + -- Build string X'First - 1 + expression where the expression + -- is the original subscript. If the expression starts with "1 + -- + ", then the "- 1 + 1" is elided. + + Error_Msg_String (1 .. 13) := "'First - 1 + "; + Error_Msg_Strlen := 13; + + declare + Sref : Source_Ptr := Sloc (First_Node (Original_Node (X))); + Tref : constant Source_Buffer_Ptr := + Source_Text (Get_Source_File_Index (Sref)); + -- Tref (Sref) is used to scan the subscript + + Pctr : Natural; + -- Parentheses counter when scanning subscript + + begin + -- Tref (Sref) points to start of subscript + + -- Elide - 1 if subscript starts with 1 + + + if Tref (Sref .. Sref + 2) = "1 +" then + Error_Msg_Strlen := Error_Msg_Strlen - 6; + Sref := Sref + 2; + + elsif Tref (Sref .. Sref + 1) = "1+" then + Error_Msg_Strlen := Error_Msg_Strlen - 6; + Sref := Sref + 1; + end if; + + -- Now we will copy the subscript to the string buffer + + Pctr := 0; + loop + -- Count parens, exit if terminating right paren. Note + -- check to ignore paren appearing as character literal. + + if Tref (Sref + 1) = ''' + and then + Tref (Sref - 1) = ''' + then + null; + else + if Tref (Sref) = '(' then + Pctr := Pctr + 1; + elsif Tref (Sref) = ')' then + exit when Pctr = 0; + Pctr := Pctr - 1; + end if; + end if; + + -- Done if terminating double dot (slice case) + + exit when Pctr = 0 + and then (Tref (Sref .. Sref + 1) = ".." + or else + Tref (Sref .. Sref + 2) = " .."); + + -- Quit if we have hit EOF character, something wrong + + if Tref (Sref) = EOF then + return; + end if; + + -- String literals are too much of a pain to handle + + if Tref (Sref) = '"' or else Tref (Sref) = '%' then + return; + end if; + + -- If we have a 'Range reference, then this is a case + -- where we cannot easily give a replacement. Don't try! + + if Tref (Sref .. Sref + 4) = "range" + and then Tref (Sref - 1) < 'A' + and then Tref (Sref + 5) < 'A' + then + return; + end if; + + -- Else store next character + + Error_Msg_Strlen := Error_Msg_Strlen + 1; + Error_Msg_String (Error_Msg_Strlen) := Tref (Sref); + Sref := Sref + 1; + + -- If we get more than 40 characters then the expression + -- is too long to copy, or something has gone wrong. In + -- either case, just skip the attempt at a suggested fix. + + if Error_Msg_Strlen > 40 then + return; + end if; + end loop; + end; + + -- Replacement subscript is now in string buffer + + Error_Msg_FE -- CODEFIX + ("\suggested replacement: `&~`", Original_Node (X), Ent); + end if; + + -- Case where subscript is of the form X'Length + + elsif Length_Reference (X) then + Warn1; + Error_Msg_Node_2 := Ent; + Error_Msg_FE + ("\suggest replacement of `&''Length` by `&''Last`", + X, Ent); + + -- Case where subscript is of the form X'Length - expression + + elsif Nkind (X) = N_Op_Subtract + and then Length_Reference (Left_Opnd (X)) + then + Warn1; + Error_Msg_Node_2 := Ent; + Error_Msg_FE + ("\suggest replacement of `&''Length` by `&''Last`", + Left_Opnd (X), Ent); + end if; + end Test_Suspicious_Index; + + -- Start of processing for Warn_On_Suspicious_Index + + begin + -- Only process if warnings activated + + if Warn_On_Assumed_Low_Bound then + + -- Test if array is simple entity name + + if Is_Entity_Name (Name) then + + -- Test if array is parameter of unconstrained string type + + Ent := Entity (Name); + Typ := Etype (Ent); + + if Is_Formal (Ent) + and then Is_Suspicious_Type (Typ) + and then not Low_Bound_Tested (Ent) + then + Test_Suspicious_Index; + end if; + end if; + end if; + end Warn_On_Suspicious_Index; + + -------------------------------------- + -- Warn_On_Unassigned_Out_Parameter -- + -------------------------------------- + + procedure Warn_On_Unassigned_Out_Parameter + (Return_Node : Node_Id; + Scope_Id : Entity_Id) + is + Form : Entity_Id; + Form2 : Entity_Id; + + begin + -- Ignore if procedure or return statement does not come from source + + if not Comes_From_Source (Scope_Id) + or else not Comes_From_Source (Return_Node) + then + return; + end if; + + -- Loop through formals + + Form := First_Formal (Scope_Id); + while Present (Form) loop + + -- We are only interested in OUT parameters that come from source + -- and are never set in the source, and furthermore only in scalars + -- since non-scalars generate too many false positives. + + if Ekind (Form) = E_Out_Parameter + and then Never_Set_In_Source_Check_Spec (Form) + and then Is_Scalar_Type (Etype (Form)) + and then not Present (Unset_Reference (Form)) + then + -- Before we issue the warning, an add ad hoc defence against the + -- most common case of false positives with this warning which is + -- the case where there is a Boolean OUT parameter that has been + -- set, and whose meaning is "ignore the values of the other + -- parameters". We can't of course reliably tell this case at + -- compile time, but the following test kills a lot of false + -- positives, without generating a significant number of false + -- negatives (missed real warnings). + + Form2 := First_Formal (Scope_Id); + while Present (Form2) loop + if Ekind (Form2) = E_Out_Parameter + and then Root_Type (Etype (Form2)) = Standard_Boolean + and then not Never_Set_In_Source_Check_Spec (Form2) + then + return; + end if; + + Next_Formal (Form2); + end loop; + + -- Here all conditions are met, record possible unset reference + + Set_Unset_Reference (Form, Return_Node); + end if; + + Next_Formal (Form); + end loop; + end Warn_On_Unassigned_Out_Parameter; + + --------------------------------- + -- Warn_On_Unreferenced_Entity -- + --------------------------------- + + procedure Warn_On_Unreferenced_Entity + (Spec_E : Entity_Id; + Body_E : Entity_Id := Empty) + is + E : Entity_Id := Spec_E; + + begin + if not Referenced_Check_Spec (E) + and then not Has_Pragma_Unreferenced_Check_Spec (E) + and then not Warnings_Off_Check_Spec (E) + then + case Ekind (E) is + when E_Variable => + + -- Case of variable that is assigned but not read. We suppress + -- the message if the variable is volatile, has an address + -- clause, is aliased, or is a renaming, or is imported. + + if Referenced_As_LHS_Check_Spec (E) + and then No (Address_Clause (E)) + and then not Is_Volatile (E) + then + if Warn_On_Modified_Unread + and then not Is_Imported (E) + and then not Is_Aliased (E) + and then No (Renamed_Object (E)) + then + if not Has_Pragma_Unmodified_Check_Spec (E) then + Error_Msg_N -- CODEFIX + ("?variable & is assigned but never read!", E); + end if; + + Set_Last_Assignment (E, Empty); + end if; + + -- Normal case of neither assigned nor read (exclude variables + -- referenced as out parameters, since we already generated + -- appropriate warnings at the call point in this case). + + elsif not Referenced_As_Out_Parameter (E) then + + -- We suppress the message for types for which a valid + -- pragma Unreferenced_Objects has been given, otherwise + -- we go ahead and give the message. + + if not Has_Pragma_Unreferenced_Objects (Etype (E)) then + + -- Distinguish renamed case in message + + if Present (Renamed_Object (E)) + and then Comes_From_Source (Renamed_Object (E)) + then + Error_Msg_N -- CODEFIX + ("?renamed variable & is not referenced!", E); + else + Error_Msg_N -- CODEFIX + ("?variable & is not referenced!", E); + end if; + end if; + end if; + + when E_Constant => + if Present (Renamed_Object (E)) + and then Comes_From_Source (Renamed_Object (E)) + then + Error_Msg_N -- CODEFIX + ("?renamed constant & is not referenced!", E); + else + Error_Msg_N -- CODEFIX + ("?constant & is not referenced!", E); + end if; + + when E_In_Parameter | + E_In_Out_Parameter => + + -- Do not emit message for formals of a renaming, because + -- they are never referenced explicitly. + + if Nkind (Original_Node (Unit_Declaration_Node (Scope (E)))) + /= N_Subprogram_Renaming_Declaration + then + -- Suppress this message for an IN OUT parameter of a + -- non-scalar type, since it is normal to have only an + -- assignment in such a case. + + if Ekind (E) = E_In_Parameter + or else not Referenced_As_LHS_Check_Spec (E) + or else Is_Scalar_Type (Etype (E)) + then + if Present (Body_E) then + E := Body_E; + end if; + + if not Is_Trivial_Subprogram (Scope (E)) then + Error_Msg_NE -- CODEFIX + ("?formal parameter & is not referenced!", + E, Spec_E); + end if; + end if; + end if; + + when E_Out_Parameter => + null; + + when E_Discriminant => + Error_Msg_N ("?discriminant & is not referenced!", E); + + when E_Named_Integer | + E_Named_Real => + Error_Msg_N -- CODEFIX + ("?named number & is not referenced!", E); + + when Formal_Object_Kind => + Error_Msg_N -- CODEFIX + ("?formal object & is not referenced!", E); + + when E_Enumeration_Literal => + Error_Msg_N -- CODEFIX + ("?literal & is not referenced!", E); + + when E_Function => + Error_Msg_N -- CODEFIX + ("?function & is not referenced!", E); + + when E_Procedure => + Error_Msg_N -- CODEFIX + ("?procedure & is not referenced!", E); + + when E_Package => + Error_Msg_N -- CODEFIX + ("?package & is not referenced!", E); + + when E_Exception => + Error_Msg_N -- CODEFIX + ("?exception & is not referenced!", E); + + when E_Label => + Error_Msg_N -- CODEFIX + ("?label & is not referenced!", E); + + when E_Generic_Procedure => + Error_Msg_N -- CODEFIX + ("?generic procedure & is never instantiated!", E); + + when E_Generic_Function => + Error_Msg_N -- CODEFIX + ("?generic function & is never instantiated!", E); + + when Type_Kind => + Error_Msg_N -- CODEFIX + ("?type & is not referenced!", E); + + when others => + Error_Msg_N -- CODEFIX + ("?& is not referenced!", E); + end case; + + -- Kill warnings on the entity on which the message has been posted + + Set_Warnings_Off (E); + end if; + end Warn_On_Unreferenced_Entity; + + -------------------------------- + -- Warn_On_Useless_Assignment -- + -------------------------------- + + procedure Warn_On_Useless_Assignment + (Ent : Entity_Id; + N : Node_Id := Empty) + is + P : Node_Id; + X : Node_Id; + + function Check_Ref (N : Node_Id) return Traverse_Result; + -- Used to instantiate Traverse_Func. Returns Abandon if a reference to + -- the entity in question is found. + + function Test_No_Refs is new Traverse_Func (Check_Ref); + + --------------- + -- Check_Ref -- + --------------- + + function Check_Ref (N : Node_Id) return Traverse_Result is + begin + -- Check reference to our identifier. We use name equality here + -- because the exception handlers have not yet been analyzed. This + -- is not quite right, but it really does not matter that we fail + -- to output the warning in some obscure cases of name clashes. + + if Nkind (N) = N_Identifier + and then Chars (N) = Chars (Ent) + then + return Abandon; + else + return OK; + end if; + end Check_Ref; + + -- Start of processing for Warn_On_Useless_Assignment + + begin + -- Check if this is a case we want to warn on, a scalar or access + -- variable with the last assignment field set, with warnings enabled, + -- and which is not imported or exported. We also check that it is OK + -- to capture the value. We are not going to capture any value, but + -- the warning message depends on the same kind of conditions. + + if Is_Assignable (Ent) + and then not Is_Return_Object (Ent) + and then Present (Last_Assignment (Ent)) + and then not Is_Imported (Ent) + and then not Is_Exported (Ent) + and then Safe_To_Capture_Value (N, Ent) + and then not Has_Pragma_Unreferenced_Check_Spec (Ent) + then + -- Before we issue the message, check covering exception handlers. + -- Search up tree for enclosing statement sequences and handlers. + + P := Parent (Last_Assignment (Ent)); + while Present (P) loop + + -- Something is really wrong if we don't find a handled statement + -- sequence, so just suppress the warning. + + if No (P) then + Set_Last_Assignment (Ent, Empty); + return; + + -- When we hit a package/subprogram body, issue warning and exit + + elsif Nkind (P) = N_Subprogram_Body + or else Nkind (P) = N_Package_Body + then + -- Case of assigned value never referenced + + if No (N) then + + -- Don't give this for OUT and IN OUT formals, since + -- clearly caller may reference the assigned value. Also + -- never give such warnings for internal variables. + + if Ekind (Ent) = E_Variable + and then not Is_Internal_Name (Chars (Ent)) + then + if Referenced_As_Out_Parameter (Ent) then + Error_Msg_NE + ("?& modified by call, but value never referenced", + Last_Assignment (Ent), Ent); + else + Error_Msg_NE -- CODEFIX + ("?useless assignment to&, value never referenced!", + Last_Assignment (Ent), Ent); + end if; + end if; + + -- Case of assigned value overwritten + + else + Error_Msg_Sloc := Sloc (N); + + if Referenced_As_Out_Parameter (Ent) then + Error_Msg_NE + ("?& modified by call, but value overwritten #!", + Last_Assignment (Ent), Ent); + else + Error_Msg_NE -- CODEFIX + ("?useless assignment to&, value overwritten #!", + Last_Assignment (Ent), Ent); + end if; + end if; + + -- Clear last assignment indication and we are done + + Set_Last_Assignment (Ent, Empty); + return; + + -- Enclosing handled sequence of statements + + elsif Nkind (P) = N_Handled_Sequence_Of_Statements then + + -- Check exception handlers present + + if Present (Exception_Handlers (P)) then + + -- If we are not at the top level, we regard an inner + -- exception handler as a decisive indicator that we should + -- not generate the warning, since the variable in question + -- may be accessed after an exception in the outer block. + + if Nkind (Parent (P)) /= N_Subprogram_Body + and then Nkind (Parent (P)) /= N_Package_Body + then + Set_Last_Assignment (Ent, Empty); + return; + + -- Otherwise we are at the outer level. An exception + -- handler is significant only if it references the + -- variable in question, or if the entity in question + -- is an OUT or IN OUT parameter, which which case + -- the caller can reference it after the exception + -- handler completes. + + else + if Is_Formal (Ent) then + Set_Last_Assignment (Ent, Empty); + return; + + else + X := First (Exception_Handlers (P)); + while Present (X) loop + if Test_No_Refs (X) = Abandon then + Set_Last_Assignment (Ent, Empty); + return; + end if; + + X := Next (X); + end loop; + end if; + end if; + end if; + end if; + + P := Parent (P); + end loop; + end if; + end Warn_On_Useless_Assignment; + + --------------------------------- + -- Warn_On_Useless_Assignments -- + --------------------------------- + + procedure Warn_On_Useless_Assignments (E : Entity_Id) is + Ent : Entity_Id; + begin + if Warn_On_Modified_Unread + and then In_Extended_Main_Source_Unit (E) + then + Ent := First_Entity (E); + while Present (Ent) loop + Warn_On_Useless_Assignment (Ent); + Next_Entity (Ent); + end loop; + end if; + end Warn_On_Useless_Assignments; + + ----------------------------- + -- Warnings_Off_Check_Spec -- + ----------------------------- + + function Warnings_Off_Check_Spec (E : Entity_Id) return Boolean is + begin + if Is_Formal (E) and then Present (Spec_Entity (E)) then + + -- Note: use of OR here instead of OR ELSE is deliberate, we want + -- to mess with flags on both entities. + + return Has_Warnings_Off (E) + or + Has_Warnings_Off (Spec_Entity (E)); + + else + return Has_Warnings_Off (E); + end if; + end Warnings_Off_Check_Spec; + +end Sem_Warn; diff --git a/gcc/ada/sem_warn.ads b/gcc/ada/sem_warn.ads new file mode 100644 index 000000000..eb756ed62 --- /dev/null +++ b/gcc/ada/sem_warn.ads @@ -0,0 +1,273 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ W A R N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1999-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 to deal with issuing warnings +-- about uses of uninitialized variables and unused with's. It also has +-- some unrelated routines related to the generation of warnings. + +with Alloc; use Alloc; +with Table; +with Types; use Types; + +package Sem_Warn is + + ------------------- + -- Warning Flags -- + ------------------- + + -- These flags are activated or deactivated by -gnatw switches and control + -- whether warnings of a given class will be generated or not. + + -- Note: most of these flags are still in opt, but the plan is to move them + -- here as time goes by. + + Warn_On_Record_Holes : Boolean := False; + -- Warn when explicit record component clauses leave uncovered holes (gaps) + -- in a record layout. Off by default, set by -gnatw.h (but not -gnatwa). + + Warn_On_Overridden_Size : Boolean := False; + -- Warn when explicit record component clause or array component_size + -- clause specifies a size that overrides a size for the type which was + -- set with an explicit size clause. Off by default, set by -gnatw.s (but + -- not -gnatwa). + + ------------------------ + -- Warnings Off Table -- + ------------------------ + + type Warnings_Off_Entry is record + N : Node_Id; + -- A pragma Warnings (Off, ent) node + + E : Entity_Id; + -- The entity involved + end record; + + -- An entry is made in the following table for any valid Pragma Warnings + -- (Off, entity) encountered while Opt.Warn_On_Warnings_Off is True. It + -- is used to generate warnings on any of these pragmas that turn out not + -- to be needed, or that could be replaced by Unmodified/Unreferenced. + + package Warnings_Off_Pragmas is new Table.Table ( + Table_Component_Type => Warnings_Off_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.Warnings_Off_Pragmas_Initial, + Table_Increment => Alloc.Warnings_Off_Pragmas_Increment, + Table_Name => "Name_Warnings_Off_Pragmas"); + + -------------------- + -- Initialization -- + -------------------- + + procedure Initialize; + -- Initialize this package for new compilation + + function Set_Warning_Switch (C : Character) return Boolean; + -- This function sets the warning switch or switches corresponding to the + -- given character. It is used to process a -gnatw switch on the command + -- line, or a character in a string literal in pragma Warnings. Returns + -- True for valid warning character C, False for invalid character. + + function Set_Dot_Warning_Switch (C : Character) return Boolean; + -- This function sets the warning switch or switches corresponding to the + -- given character preceded by a dot. Used to process a -gnatw. switch on + -- the command line or .C in a string literal in pragma Warnings. Returns + -- True for valid warning character C, False for invalid character. + + procedure Set_GNAT_Mode_Warnings; + -- This is called in -gnatg mode to set the warnings for gnat mode. It is + -- also used to set the proper warning statuses for -gnatw.g. + + ------------------------------------------ + -- Routines to Handle Unused References -- + ------------------------------------------ + + procedure Check_References (E : Entity_Id; Anod : Node_Id := Empty); + -- Called at the end of processing a declarative region. The entity E + -- is the entity for the scope. All entities declared in the region, + -- as indicated by First_Entity and the entity chain, are checked to + -- see if they are variables for which warnings need to be posted for + -- either no assignments, or a use before an assignment or no references + -- at all. The Anod node is present for the case of an accept statement, + -- and references the accept statement. This is used to place the warning + -- messages in the right place. + + procedure Check_Unset_Reference (N : Node_Id); + -- N is the node for an expression which occurs in a reference position, + -- e.g. as the right side of an assignment. This procedure checks to see + -- if the node is a reference to a variable entity where the entity has + -- Not_Assigned set. If so, the Unset_Reference field is set if it is not + -- the first occurrence. No warning is posted, instead warnings will be + -- posted later by Check_References. The reason we do things that + -- way is that if there are no assignments anywhere, we prefer to flag + -- the entity, rather than a reference to it. Note that for the purposes + -- of this routine, a type conversion or qualified expression whose + -- expression is an entity is also processed. The reason that we do not + -- process these at the point of occurrence is that both these constructs + -- can occur in non-reference positions (e.g. as out parameters). + + procedure Check_Unused_Withs (Spec_Unit : Unit_Number_Type := No_Unit); + -- This routine performs two kinds of checks. It checks that all with'ed + -- units are referenced, and that at least one entity of each with'ed + -- unit is referenced (the latter check catches units that are only + -- referenced in a use or package renaming statement). Appropriate + -- warning messages are generated if either of these situations is + -- detected. + -- + -- A special case arises when a package body or a subprogram body with + -- a separate spec is being compiled. In this case, a with may appear + -- on the spec, but be needed only by the body. This still generates + -- a warning, but the text is different (the with is not redundant, + -- it is misplaced). + -- + -- This special case is implemented by making an initial call to this + -- procedure with Spec_Unit set to the unit number of the separate spec. + -- This call does not generate any warning messages, but instead may + -- result in flags being set in the N_With_Clause node that record that + -- there was no use in the spec. + -- + -- The main call (made after all units have been analyzed, with Spec_Unit + -- set to the default value of No_Unit) generates the required warnings + -- using the flags set by the initial call where appropriate to specialize + -- the text of the warning messages. + + --------------------- + -- Output Routines -- + --------------------- + + procedure Output_Non_Modified_In_Out_Warnings; + -- Warnings about IN OUT parameters that could be IN are collected till + -- the end of the compilation process (see body of this routine for a + -- discussion of why this is done). This procedure outputs the warnings. + -- Note: this should be called before Output_Unreferenced_Messages, since + -- if we have an IN OUT warning, that's the one we want to see! + + procedure Output_Obsolescent_Entity_Warnings (N : Node_Id; E : Entity_Id); + -- N is a reference to obsolescent entity E, for which appropriate warning + -- messages are to be generated (caller has already checked that warnings + -- are active and appropriate for this entity). + + procedure Output_Unreferenced_Messages; + -- Warnings about unreferenced entities are collected till the end of + -- the compilation process (see Check_Unset_Reference for further + -- details). This procedure outputs waiting warnings, if any. + + procedure Output_Unused_Warnings_Off_Warnings; + -- Warnings about pragma Warnings (Off, ent) statements that are unused, + -- or could be replaced by Unmodified/Unreferenced pragmas, are collected + -- till the end of the compilation process. This procedure outputs waiting + -- warnings if any. + + ---------------------------- + -- Other Warning Routines -- + ---------------------------- + + procedure Check_Code_Statement (N : Node_Id); + -- Perform warning checks on a code statement node + + procedure Check_Infinite_Loop_Warning (Loop_Statement : Node_Id); + -- N is the node for a loop statement. This procedure checks if a warning + -- for a possible infinite loop should be given for a suspicious WHILE or + -- EXIT WHEN condition. + + procedure Check_Low_Bound_Tested (Expr : Node_Id); + -- Expr is the node for a comparison operation. This procedure checks if + -- the comparison is a source comparison of P'First with some other value + -- and if so, sets the Low_Bound_Tested flag on entity P to suppress + -- warnings about improper low bound assumptions (we assume that if the + -- code has a test that explicitly checks P'First, then it is not operating + -- in blind assumption mode). + + procedure Warn_On_Known_Condition (C : Node_Id); + -- C is a node for a boolean expression resulting from a relational + -- or membership operation. If the expression has a compile time known + -- value, then a warning is output if all the following conditions hold: + -- + -- 1. Original expression comes from source. We don't want to generate + -- warnings for internally generated conditionals. + -- + -- 2. As noted above, the expression is a relational or membership + -- test, we don't want to generate warnings for boolean variables + -- since this is typical of conditional compilation in Ada. + -- + -- 3. The expression appears in a statement, rather than a declaration. + -- In practice, most occurrences in declarations are legitimate + -- conditionalizations, but occurrences in statements are often + -- errors for which the warning is useful. + -- + -- 4. The expression does not occur within an instantiation. A non- + -- static expression in a generic may become constant because of + -- the attributes of the actuals, and we do not want to warn on + -- these legitimate constant foldings. + -- + -- If all these conditions are met, the warning is issued noting that + -- the result of the test is always false or always true as appropriate. + + function Warn_On_Modified_As_Out_Parameter (E : Entity_Id) return Boolean; + -- Returns True if we should activate warnings for entity E being modified + -- as an out parameter. True if either Warn_On_Modified_Unread is set for + -- an only OUT parameter, or if Warn_On_All_Unread_Out_Parameters is set. + + procedure Warn_On_Overlapping_Actuals (Subp : Entity_Id; N : Node_Id); + -- Called on a subprogram call. Checks whether an IN OUT actual that is + -- not by-copy may overlap with another actual, thus leading to aliasing + -- in the body of the called subprogram. + + procedure Warn_On_Suspicious_Index (Name : Entity_Id; X : Node_Id); + -- This is called after resolving an indexed component or a slice. Name + -- is the entity for the name of the indexed array, and X is the subscript + -- for the indexed component case, or one of the bounds in the slice case. + -- If Name is an unconstrained parameter of a standard string type, and + -- the index is of the form of a literal or Name'Length [- literal], then + -- a warning is generated that the subscripting operation is possibly + -- incorrectly assuming a lower bound of 1. + + procedure Warn_On_Unassigned_Out_Parameter + (Return_Node : Node_Id; + Scope_Id : Entity_Id); + -- Called when processing a return statement given by Return_Node. Scope_Id + -- is the Entity_Id for the procedure in which the return statement lives. + -- A check is made for the case of a procedure with out parameters that + -- have not yet been assigned, and appropriate warnings are given. + + procedure Warn_On_Useless_Assignment + (Ent : Entity_Id; + N : Node_Id := Empty); + -- Called to check if we have a case of a useless assignment to the given + -- entity Ent, as indicated by a non-empty Last_Assignment field. This call + -- should only be made if at least one of the flags Warn_On_Modified_Unread + -- or Warn_On_All_Unread_Out_Parameters is True, and if Ent is in the + -- extended main source unit. N is Empty for the end of block call + -- (warning message says value unreferenced), or the it is the node for + -- an overwriting assignment (warning message points to this assignment). + + procedure Warn_On_Useless_Assignments (E : Entity_Id); + pragma Inline (Warn_On_Useless_Assignments); + -- Called at the end of a block or subprogram. Scans the entities of the + -- block or subprogram to see if there are any variables for which useless + -- assignments were made (assignments whose values were never read). + +end Sem_Warn; diff --git a/gcc/ada/sequenio.ads b/gcc/ada/sequenio.ads new file mode 100644 index 000000000..42522fb90 --- /dev/null +++ b/gcc/ada/sequenio.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S E Q U E N T I A L _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2005; +-- Explicit setting of Ada 2005 mode is required here, since we want to with a +-- child unit (not possible in Ada 83 mode), and Sequential_IO is not +-- considered to be an internal unit that is automatically compiled in Ada +-- 2005 mode (since a user is allowed to redeclare Sequential_IO). + +with Ada.Sequential_IO; + +generic package Sequential_IO renames Ada.Sequential_IO; diff --git a/gcc/ada/sfn_scan.adb b/gcc/ada/sfn_scan.adb new file mode 100644 index 000000000..1d24ca227 --- /dev/null +++ b/gcc/ada/sfn_scan.adb @@ -0,0 +1,729 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S F N _ S C A N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2000-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.Exceptions; use Ada.Exceptions; + +package body SFN_Scan is + + use ASCII; + -- Allow easy access to control character definitions + + EOF : constant Character := ASCII.SUB; + -- The character SUB (16#1A#) is used in DOS-derived systems, such as + -- Windows to signal the end of a text file. If this character appears as + -- the last character of a file scanned by a call to Scan_SFN_Pragmas, then + -- it is ignored, otherwise it is treated as an illegal character. + + type String_Ptr is access String; + + S : String_Ptr; + -- Points to the gnat.adc input file + + P : Natural; + -- Subscript of next character to process in S + + Line_Num : Natural; + -- Current line number + + Start_Of_Line : Natural; + -- Subscript of first character at start of current line + + ---------------------- + -- Local Procedures -- + ---------------------- + + function Acquire_Integer return Natural; + -- This function skips white space, and then scans and returns + -- an unsigned integer. Raises Error if no integer is present + -- or if the integer is greater than 999. + + function Acquire_String (B : Natural; E : Natural) return String; + -- This function takes a string scanned out by Scan_String, strips + -- the enclosing quote characters and any internal doubled quote + -- characters, and returns the result as a String. The arguments + -- B and E are as returned from a call to Scan_String. The lower + -- bound of the string returned is always 1. + + function Acquire_Unit_Name return String; + -- Skips white space, and then scans and returns a unit name. The + -- unit name is cased exactly as it appears in the source file. + -- The terminating character must be white space, or a comma or + -- a right parenthesis or end of file. + + function At_EOF return Boolean; + pragma Inline (At_EOF); + -- Returns True if at end of file, False if not. Note that this + -- function does NOT skip white space, so P is always unchanged. + + procedure Check_Not_At_EOF; + pragma Inline (Check_Not_At_EOF); + -- Skips past white space if any, and then raises Error if at + -- end of file. Otherwise returns with P skipped past whitespace. + + function Check_File_Type return Character; + -- Skips white space if any, and then looks for any of the tokens + -- Spec_File_Name, Body_File_Name, or Subunit_File_Name. If one + -- of these is found then the value returned is 's', 'b' or 'u' + -- respectively, and P is bumped past the token. If none of + -- these tokens is found, then P is unchanged (except for + -- possible skip of white space), and a space is returned. + + function Check_Token (T : String) return Boolean; + -- Skips white space if any, and then checks if the string at the + -- current location matches the given string T, and the character + -- immediately following is non-alphabetic, non-numeric. If so, + -- P is stepped past the token, and True is returned. If not, + -- P is unchanged (except for possibly skipping past whitespace), + -- and False is returned. S may contain only lower-case letters + -- ('a' .. 'z'). + + procedure Error (Err : String); + -- Called if an error is detected. Raises Syntax_Error_In_GNAT_ADC + -- with a message of the form gnat.adc:line:col: xxx, where xxx is + -- the string Err passed as a parameter. + + procedure Require_Token (T : String); + -- Skips white space if any, and then requires the given string + -- to be present. If it is, the P is stepped past it, otherwise + -- Error is raised, since this is a syntax error. Require_Token + -- is used only for sequences of special characters, so there + -- is no issue of terminators, or casing of letters. + + procedure Scan_String (B : out Natural; E : out Natural); + -- Skips white space if any, then requires that a double quote + -- or percent be present (start of string). Raises error if + -- neither of these two characters is found. Otherwise scans + -- out the string, and returns with P pointing past the + -- closing quote and S (B .. E) contains the characters of the + -- string (including the enclosing quotes, with internal quotes + -- still doubled). Raises Error if the string is malformed. + + procedure Skip_WS; + -- Skips P past any white space characters (end of line + -- characters, spaces, comments, horizontal tab characters). + + --------------------- + -- Acquire_Integer -- + --------------------- + + function Acquire_Integer return Natural is + N : Natural := 0; + + begin + Skip_WS; + + if S (P) not in '0' .. '9' then + Error ("missing index parameter"); + end if; + + while S (P) in '0' .. '9' loop + N := N * 10 + Character'Pos (S (P)) - Character'Pos ('0'); + + if N > 999 then + Error ("index value greater than 999"); + end if; + + P := P + 1; + end loop; + + return N; + end Acquire_Integer; + + -------------------- + -- Acquire_String -- + -------------------- + + function Acquire_String (B : Natural; E : Natural) return String is + Str : String (1 .. E - B - 1); + Q : constant Character := S (B); + J : Natural; + Ptr : Natural; + + begin + Ptr := B + 1; + J := 0; + while Ptr < E loop + J := J + 1; + Str (J) := S (Ptr); + + if S (Ptr) = Q and then S (Ptr + 1) = Q then + Ptr := Ptr + 2; + else + Ptr := Ptr + 1; + end if; + end loop; + + return Str (1 .. J); + end Acquire_String; + + ----------------------- + -- Acquire_Unit_Name -- + ----------------------- + + function Acquire_Unit_Name return String is + B : Natural; + + begin + Check_Not_At_EOF; + B := P; + + while not At_EOF loop + exit when S (P) not in '0' .. '9' + and then S (P) /= '.' + and then S (P) /= '_' + and then not (S (P) = '[' and then S (P + 1) = '"') + and then not (S (P) = '"' and then S (P - 1) = '[') + and then not (S (P) = '"' and then S (P + 1) = ']') + and then not (S (P) = ']' and then S (P - 1) = '"') + and then S (P) < 'A'; + P := P + 1; + end loop; + + if P = B then + Error ("null unit name"); + end if; + + return S (B .. P - 1); + end Acquire_Unit_Name; + + ------------ + -- At_EOF -- + ------------ + + function At_EOF return Boolean is + begin + -- Immediate return (False) if before last character of file + + if P < S'Last then + return False; + + -- Special case: DOS EOF character as last character of file is + -- allowed and treated as an end of file. + + elsif P = S'Last then + return S (P) = EOF; + + -- If beyond last character of file, then definitely at EOF + + else + return True; + end if; + end At_EOF; + + --------------------- + -- Check_File_Type -- + --------------------- + + function Check_File_Type return Character is + begin + if Check_Token ("spec_file_name") then + return 's'; + elsif Check_Token ("body_file_name") then + return 'b'; + elsif Check_Token ("subunit_file_name") then + return 'u'; + else + return ' '; + end if; + end Check_File_Type; + + ---------------------- + -- Check_Not_At_EOF -- + ---------------------- + + procedure Check_Not_At_EOF is + begin + Skip_WS; + + if At_EOF then + Error ("unexpected end of file"); + end if; + + return; + end Check_Not_At_EOF; + + ----------------- + -- Check_Token -- + ----------------- + + function Check_Token (T : String) return Boolean is + Save_P : Natural; + C : Character; + + begin + Skip_WS; + Save_P := P; + + for K in T'Range loop + if At_EOF then + P := Save_P; + return False; + end if; + + C := S (P); + + if C in 'A' .. 'Z' then + C := Character'Val (Character'Pos (C) + + (Character'Pos ('a') - Character'Pos ('A'))); + end if; + + if C /= T (K) then + P := Save_P; + return False; + end if; + + P := P + 1; + end loop; + + if At_EOF then + return True; + end if; + + C := S (P); + + if C in '0' .. '9' + or else C in 'a' .. 'z' + or else C in 'A' .. 'Z' + or else C > Character'Val (127) + then + P := Save_P; + return False; + + else + return True; + end if; + end Check_Token; + + ----------- + -- Error -- + ----------- + + procedure Error (Err : String) is + C : Natural := 0; + -- Column number + + M : String (1 .. 80); + -- Buffer used to build resulting error msg + + LM : Natural := 0; + -- Pointer to last set location in M + + procedure Add_Nat (N : Natural); + -- Add chars of integer to error msg buffer + + ------------- + -- Add_Nat -- + ------------- + + procedure Add_Nat (N : Natural) is + begin + if N > 9 then + Add_Nat (N / 10); + end if; + + LM := LM + 1; + M (LM) := Character'Val (N mod 10 + Character'Pos ('0')); + end Add_Nat; + + -- Start of processing for Error + + begin + M (1 .. 9) := "gnat.adc:"; + LM := 9; + Add_Nat (Line_Num); + LM := LM + 1; + M (LM) := ':'; + + -- Determine column number + + for X in Start_Of_Line .. P loop + C := C + 1; + + if S (X) = HT then + C := (C + 7) / 8 * 8; + end if; + end loop; + + Add_Nat (C); + M (LM + 1) := ':'; + LM := LM + 1; + M (LM + 1) := ' '; + LM := LM + 1; + + M (LM + 1 .. LM + Err'Length) := Err; + LM := LM + Err'Length; + + Raise_Exception (Syntax_Error_In_GNAT_ADC'Identity, M (1 .. LM)); + end Error; + + ------------------- + -- Require_Token -- + ------------------- + + procedure Require_Token (T : String) is + SaveP : Natural; + + begin + Skip_WS; + SaveP := P; + + for J in T'Range loop + + if At_EOF or else S (P) /= T (J) then + declare + S : String (1 .. T'Length + 10); + + begin + S (1 .. 9) := "missing """; + S (10 .. T'Length + 9) := T; + S (T'Length + 10) := '"'; + P := SaveP; + Error (S); + end; + + else + P := P + 1; + end if; + end loop; + end Require_Token; + + ---------------------- + -- Scan_SFN_Pragmas -- + ---------------------- + + procedure Scan_SFN_Pragmas + (Source : String; + SFN_Ptr : Set_File_Name_Ptr; + SFNP_Ptr : Set_File_Name_Pattern_Ptr) + is + B, E : Natural; + Typ : Character; + Cas : Character; + + begin + Line_Num := 1; + S := Source'Unrestricted_Access; + P := Source'First; + Start_Of_Line := P; + + -- Loop through pragmas in file + + Main_Scan_Loop : loop + Skip_WS; + exit Main_Scan_Loop when At_EOF; + + -- Error if something other than pragma + + if not Check_Token ("pragma") then + Error ("non pragma encountered"); + end if; + + -- Source_File_Name pragma case + + if Check_Token ("source_file_name") + or else + Check_Token ("source_file_name_project") + then + Require_Token ("("); + + Typ := Check_File_Type; + + -- First format, with unit name first + + if Typ = ' ' then + if Check_Token ("unit_name") then + Require_Token ("=>"); + end if; + + declare + U : constant String := Acquire_Unit_Name; + + begin + Require_Token (","); + Typ := Check_File_Type; + + if Typ /= 's' and then Typ /= 'b' then + Error ("bad pragma"); + end if; + + Require_Token ("=>"); + Scan_String (B, E); + + declare + F : constant String := Acquire_String (B, E); + X : Natural; + + begin + -- Scan Index parameter if present + + if Check_Token (",") then + if Check_Token ("index") then + Require_Token ("=>"); + end if; + + X := Acquire_Integer; + else + X := 0; + end if; + + Require_Token (")"); + Require_Token (";"); + SFN_Ptr.all (Typ, U, F, X); + end; + end; + + -- Second format with pattern string + + else + Require_Token ("=>"); + Scan_String (B, E); + + declare + Pat : constant String := Acquire_String (B, E); + Nas : Natural := 0; + + begin + -- Check exactly one asterisk + + for J in Pat'Range loop + if Pat (J) = '*' then + Nas := Nas + 1; + end if; + end loop; + + if Nas /= 1 then + Error ("** not allowed"); + end if; + + B := 0; + E := 0; + Cas := ' '; + + -- Loop to scan out Casing or Dot_Replacement parameters + + loop + Check_Not_At_EOF; + exit when S (P) = ')'; + Require_Token (","); + + if Check_Token ("casing") then + Require_Token ("=>"); + + if Cas /= ' ' then + Error ("duplicate casing argument"); + elsif Check_Token ("lowercase") then + Cas := 'l'; + elsif Check_Token ("uppercase") then + Cas := 'u'; + elsif Check_Token ("mixedcase") then + Cas := 'm'; + else + Error ("invalid casing argument"); + end if; + + elsif Check_Token ("dot_replacement") then + Require_Token ("=>"); + + if E /= 0 then + Error ("duplicate dot_replacement"); + else + Scan_String (B, E); + end if; + + else + Error ("invalid argument"); + end if; + end loop; + + Require_Token (")"); + Require_Token (";"); + + if Cas = ' ' then + Cas := 'l'; + end if; + + if E = 0 then + SFNP_Ptr.all (Pat, Typ, ".", Cas); + + else + declare + Dot : constant String := Acquire_String (B, E); + + begin + SFNP_Ptr.all (Pat, Typ, Dot, Cas); + end; + end if; + end; + end if; + + -- Some other pragma, scan to semicolon at end of pragma + + else + Skip_Loop : loop + exit Main_Scan_Loop when At_EOF; + exit Skip_Loop when S (P) = ';'; + + if S (P) = '"' or else S (P) = '%' then + Scan_String (B, E); + else + P := P + 1; + end if; + end loop Skip_Loop; + + -- We successfully skipped to semicolon, so skip past it + + P := P + 1; + end if; + end loop Main_Scan_Loop; + + exception + when others => + Cursor := P - S'First + 1; + raise; + end Scan_SFN_Pragmas; + + ----------------- + -- Scan_String -- + ----------------- + + procedure Scan_String (B : out Natural; E : out Natural) is + Q : Character; + + begin + Check_Not_At_EOF; + + if S (P) = '"' then + Q := '"'; + elsif S (P) = '%' then + Q := '%'; + else + Error ("bad string"); + Q := '"'; + end if; + + -- Scan out the string, B points to first char + + B := P; + P := P + 1; + + loop + if At_EOF or else S (P) = LF or else S (P) = CR then + Error -- CODEFIX + ("missing string quote"); + + elsif S (P) = HT then + Error ("tab character in string"); + + elsif S (P) /= Q then + P := P + 1; + + -- We have a quote + + else + P := P + 1; + + -- Check for doubled quote + + if not At_EOF and then S (P) = Q then + P := P + 1; + + -- Otherwise this is the terminating quote + + else + E := P - 1; + return; + end if; + end if; + end loop; + end Scan_String; + + ------------- + -- Skip_WS -- + ------------- + + procedure Skip_WS is + begin + WS_Scan : while not At_EOF loop + case S (P) is + + -- End of physical line + + when CR | LF => + Line_Num := Line_Num + 1; + P := P + 1; + + while not At_EOF + and then (S (P) = CR or else S (P) = LF) + loop + Line_Num := Line_Num + 1; + P := P + 1; + end loop; + + Start_Of_Line := P; + + -- All other cases of white space characters + + when ' ' | FF | VT | HT => + P := P + 1; + + -- Comment + + when '-' => + P := P + 1; + + if At_EOF then + Error ("bad comment"); + + elsif S (P) = '-' then + P := P + 1; + + while not At_EOF loop + case S (P) is + when CR | LF | FF | VT => + exit; + when others => + P := P + 1; + end case; + end loop; + + else + P := P - 1; + exit WS_Scan; + end if; + + when others => + exit WS_Scan; + + end case; + end loop WS_Scan; + end Skip_WS; + +end SFN_Scan; diff --git a/gcc/ada/sfn_scan.ads b/gcc/ada/sfn_scan.ads new file mode 100644 index 000000000..bc9cbcaa5 --- /dev/null +++ b/gcc/ada/sfn_scan.ads @@ -0,0 +1,96 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S F N _ S C A N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a stand alone capability for scanning a gnat.adc +-- file for Source_File_Name pragmas. This is for use in tools other than +-- the compiler, which want to scan source file name pragmas without the +-- overhead of the full compiler scanner and parser. + +-- Note that neither the package spec, nor the package body, of this +-- unit contains any with statements at all. This is a completely +-- independent package, suitable for incorporation into tools that do +-- not access any other units in the GNAT compiler or tools sources. + +-- This package is NOT task safe, so multiple tasks that may call the +-- Scan_SFN_Pragmas procedure at the same time are responsible for +-- avoiding such multiple calls by appropriate synchronization. + +package SFN_Scan is + + -- The call to SFN_Scan passes pointers to two procedures that are + -- used to store the results of scanning any Source_File_Name pragmas + -- that are encountered. The following access types define the form + -- of these procedures: + + type Set_File_Name_Ptr is access + procedure + (Typ : Character; + U : String; + F : String; + Index : Natural); + -- The procedure with this profile is called when a Source_File_Name + -- pragma of the form having a unit name parameter. Typ is 'b' for + -- a body file name, and 's' for a spec file name. U is a string that + -- contains the unit name, exactly as it appeared in the source file, + -- and F is the file taken from the second parameter. Index is taken + -- from the third parameter, or is set to zero if no third parameter. + + type Set_File_Name_Pattern_Ptr is access + procedure (Pat : String; Typ : Character; Dot : String; Cas : Character); + -- This is called to process a Source_File_Name pragma whose first + -- argument is a file pattern. Pat is this pattern string, which + -- contains an asterisk to correspond to the unit. Typ is one of + -- ('b'/'s'/'u') for body/spec/subunit, Dot is the separator string + -- for child/subunit names (default is "."), and Cas is one of + -- ('l'/'u'/'m') indicating the required case for the file name. + -- The default setting for Cas is 'l' if no parameter is present. + + Cursor : Natural; + -- Used to record the cursor value if a syntax error is found + + Syntax_Error_In_GNAT_ADC : exception; + -- Exception raised if a syntax error is found + + procedure Scan_SFN_Pragmas + (Source : String; + SFN_Ptr : Set_File_Name_Ptr; + SFNP_Ptr : Set_File_Name_Pattern_Ptr); + -- This is the procedure called to scan a gnat.adc file. The Source + -- parameter points to the full text of the file, with normal line end + -- characters, in the format normally read by the compiler. The two + -- parameters SFN_Ptr and SFNP_Ptr point to procedures that will be + -- called to register Source_File_Name pragmas as they are found. + -- + -- If a syntax error is found, then Syntax_Error_In_GNAT_ADC is raised, + -- and the location SFN_Scan.Cursor contains the approximate index of + -- the error in the source string. + -- + -- The scan assumes that it is dealing with a valid gnat.adc file, + -- that includes only pragmas and comments. It does not do a full + -- syntax correctness scan by any means, but if it does find anything + -- that it can tell is wrong it will immediately raise the exception + -- to indicate the approximate location of the error + +end SFN_Scan; diff --git a/gcc/ada/sinfo-cn.adb b/gcc/ada/sinfo-cn.adb new file mode 100644 index 000000000..2b4eaa2d9 --- /dev/null +++ b/gcc/ada/sinfo-cn.adb @@ -0,0 +1,110 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S I N F O . C N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 Sinfo contains some routines that permit in place +-- alteration of existing tree nodes by changing the value in the Nkind +-- field. Since Nkind functions logically in a manner similar to a variant +-- record discriminant part, such alterations cannot be permitted in a +-- general manner, but in some specific cases, the fields of related nodes +-- have been deliberately layed out in a manner that permits such alteration. + +with Atree; use Atree; + +package body Sinfo.CN is + + use Atree.Unchecked_Access; + -- This package is one of the few packages which is allowed to make direct + -- references to tree nodes (since it is in the business of providing a + -- higher level of tree access which other clients are expected to use and + -- which implements checks). + + ------------------------------------------------------------ + -- Change_Character_Literal_To_Defining_Character_Literal -- + ------------------------------------------------------------ + + procedure Change_Character_Literal_To_Defining_Character_Literal + (N : in out Node_Id) + is + begin + Set_Nkind (N, N_Defining_Character_Literal); + N := Extend_Node (N); + end Change_Character_Literal_To_Defining_Character_Literal; + + ------------------------------------ + -- Change_Conversion_To_Unchecked -- + ------------------------------------ + + procedure Change_Conversion_To_Unchecked (N : Node_Id) is + begin + Set_Do_Overflow_Check (N, False); + Set_Do_Tag_Check (N, False); + Set_Do_Length_Check (N, False); + Set_Nkind (N, N_Unchecked_Type_Conversion); + end Change_Conversion_To_Unchecked; + + ---------------------------------------------- + -- Change_Identifier_To_Defining_Identifier -- + ---------------------------------------------- + + procedure Change_Identifier_To_Defining_Identifier (N : in out Node_Id) is + begin + Set_Nkind (N, N_Defining_Identifier); + N := Extend_Node (N); + end Change_Identifier_To_Defining_Identifier; + + -------------------------------------------------------- + -- Change_Operator_Symbol_To_Defining_Operator_Symbol -- + -------------------------------------------------------- + + procedure Change_Operator_Symbol_To_Defining_Operator_Symbol + (N : in out Node_Id) + is + begin + Set_Nkind (N, N_Defining_Operator_Symbol); + Set_Node2 (N, Empty); -- Clear unused Str2 field + N := Extend_Node (N); + end Change_Operator_Symbol_To_Defining_Operator_Symbol; + + ---------------------------------------------- + -- Change_Operator_Symbol_To_String_Literal -- + ---------------------------------------------- + + procedure Change_Operator_Symbol_To_String_Literal (N : Node_Id) is + begin + Set_Nkind (N, N_String_Literal); + Set_Node1 (N, Empty); -- clear Name1 field + end Change_Operator_Symbol_To_String_Literal; + + ------------------------------------------------ + -- Change_Selected_Component_To_Expanded_Name -- + ------------------------------------------------ + + procedure Change_Selected_Component_To_Expanded_Name (N : Node_Id) is + begin + Set_Nkind (N, N_Expanded_Name); + Set_Chars (N, Chars (Selector_Name (N))); + end Change_Selected_Component_To_Expanded_Name; + +end Sinfo.CN; diff --git a/gcc/ada/sinfo-cn.ads b/gcc/ada/sinfo-cn.ads new file mode 100644 index 000000000..6460e6c7f --- /dev/null +++ b/gcc/ada/sinfo-cn.ads @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S I N F O . C N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 Sinfo contains some routines that permit in place +-- alteration of existing tree nodes by changing the value in the Nkind +-- field. Since Nkind functions logically in a manner similar to a variant +-- record discriminant part, such alterations cannot be permitted in a +-- general manner, but in some specific cases, the fields of related nodes +-- have been deliberately laid out in a manner that permits such alteration. + +package Sinfo.CN is + + procedure Change_Identifier_To_Defining_Identifier (N : in out Node_Id); + -- N must refer to a node of type N_Identifier. This node is modified to + -- be of type N_Defining_Identifier. The scanner always returns identifiers + -- as N_Identifier. The parser then uses this routine to change the node + -- to be a defining identifier where the context demands it. This routine + -- also allocates the necessary extension node. Note that this procedure + -- may (but is not required to) change the Id of the node in question. + + procedure Change_Character_Literal_To_Defining_Character_Literal + (N : in out Node_Id); + -- Similar processing for a character literal + + procedure Change_Operator_Symbol_To_Defining_Operator_Symbol + (N : in out Node_Id); + -- Similar processing for an operator symbol + + procedure Change_Conversion_To_Unchecked (N : Node_Id); + -- Change checked conversion node to unchecked conversion node, clearing + -- irrelevant check flags (other fields in the two nodes are identical) + + procedure Change_Operator_Symbol_To_String_Literal (N : Node_Id); + -- The scanner returns any string that looks like an operator symbol as + -- a N_Operator_Symbol node. The parser then uses this procedure to change + -- the node to a normal N_String_Literal node if the context is not one + -- in which an operator symbol is required. There are some cases where the + -- parser cannot tell, in which case this transformation happens later on. + + procedure Change_Selected_Component_To_Expanded_Name (N : Node_Id); + -- The parser always generates Selected_Component nodes. The semantics + -- modifies these to Expanded_Name nodes where appropriate. Note that + -- on return the Chars field is set to a copy of the contents of the + -- Chars field of the Selector_Name field. + +end Sinfo.CN; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb new file mode 100644 index 000000000..64d060832 --- /dev/null +++ b/gcc/ada/sinfo.adb @@ -0,0 +1,6314 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S I N F O -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- No subprogram ordering check, due to logical grouping + +with Atree; use Atree; + +package body Sinfo is + + use Atree.Unchecked_Access; + -- This package is one of the few packages which is allowed to make direct + -- references to tree nodes (since it is in the business of providing a + -- higher level of tree access which other clients are expected to use and + -- which implements checks). + + use Atree_Private_Part; + -- The only reason that we ask for direct access to the private part of + -- the tree package is so that we can directly reference the Nkind field + -- of nodes table entries. We do this since it helps the efficiency of + -- the Sinfo debugging checks considerably (note that when we are checking + -- Nkind values, we don't need to check for a valid node reference, because + -- we will check that anyway when we reference the field). + + NT : Nodes.Table_Ptr renames Nodes.Table; + -- A short hand abbreviation, useful for the debugging checks + + ---------------------------- + -- Field Access Functions -- + ---------------------------- + + function ABE_Is_Certain + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Formal_Package_Declaration + or else NT (N).Nkind = N_Function_Call + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Package_Instantiation + or else NT (N).Nkind = N_Procedure_Call_Statement + or else NT (N).Nkind = N_Procedure_Instantiation); + return Flag18 (N); + end ABE_Is_Certain; + + function Abort_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Requeue_Statement); + return Flag15 (N); + end Abort_Present; + + function Abortable_Part + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Asynchronous_Select); + return Node2 (N); + end Abortable_Part; + + function Abstract_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Derived_Type_Definition + or else NT (N).Nkind = N_Formal_Derived_Type_Definition + or else NT (N).Nkind = N_Formal_Private_Type_Definition + or else NT (N).Nkind = N_Private_Extension_Declaration + or else NT (N).Nkind = N_Private_Type_Declaration + or else NT (N).Nkind = N_Record_Definition); + return Flag4 (N); + end Abstract_Present; + + function Accept_Handler_Records + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Accept_Alternative); + return List5 (N); + end Accept_Handler_Records; + + function Accept_Statement + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Accept_Alternative); + return Node2 (N); + end Accept_Statement; + + function Access_Definition + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Definition + or else NT (N).Nkind = N_Formal_Object_Declaration + or else NT (N).Nkind = N_Object_Renaming_Declaration); + return Node3 (N); + end Access_Definition; + + function Access_To_Subprogram_Definition + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_Definition); + return Node3 (N); + end Access_To_Subprogram_Definition; + + function Access_Types_To_Process + (N : Node_Id) return Elist_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Freeze_Entity); + return Elist2 (N); + end Access_Types_To_Process; + + function Actions + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_And_Then + or else NT (N).Nkind = N_Case_Expression_Alternative + or else NT (N).Nkind = N_Compilation_Unit_Aux + or else NT (N).Nkind = N_Expression_With_Actions + or else NT (N).Nkind = N_Freeze_Entity + or else NT (N).Nkind = N_Or_Else); + return List1 (N); + end Actions; + + function Activation_Chain_Entity + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Block_Statement + or else NT (N).Nkind = N_Entry_Body + or else NT (N).Nkind = N_Generic_Package_Declaration + or else NT (N).Nkind = N_Package_Declaration + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Task_Body); + return Node3 (N); + end Activation_Chain_Entity; + + function Acts_As_Spec + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit + or else NT (N).Nkind = N_Subprogram_Body); + return Flag4 (N); + end Acts_As_Spec; + + function Actual_Designated_Subtype + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Explicit_Dereference + or else NT (N).Nkind = N_Free_Statement); + return Node4 (N); + end Actual_Designated_Subtype; + + function Address_Warning_Posted + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Definition_Clause); + return Flag18 (N); + end Address_Warning_Posted; + + function Aggregate_Bounds + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aggregate); + return Node3 (N); + end Aggregate_Bounds; + + function Aliased_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Definition + or else NT (N).Nkind = N_Object_Declaration); + return Flag4 (N); + end Aliased_Present; + + function All_Others + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Others_Choice); + return Flag11 (N); + end All_Others; + + function All_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_Definition + or else NT (N).Nkind = N_Access_To_Object_Definition + or else NT (N).Nkind = N_Quantified_Expression + or else NT (N).Nkind = N_Use_Type_Clause); + return Flag15 (N); + end All_Present; + + function Alternatives + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Case_Expression + or else NT (N).Nkind = N_Case_Statement + or else NT (N).Nkind = N_In + or else NT (N).Nkind = N_Not_In); + return List4 (N); + end Alternatives; + + function Ancestor_Part + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Extension_Aggregate); + return Node3 (N); + end Ancestor_Part; + + function Array_Aggregate + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Enumeration_Representation_Clause); + return Node3 (N); + end Array_Aggregate; + + function Aspect_Cancel + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + return Flag11 (N); + end Aspect_Cancel; + + function Aspect_Rep_Item + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification); + return Node2 (N); + end Aspect_Rep_Item; + + function Assignment_OK + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Object_Declaration + or else NT (N).Nkind in N_Subexpr); + return Flag15 (N); + end Assignment_OK; + + function Associated_Node + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind in N_Has_Entity + or else NT (N).Nkind = N_Aggregate + or else NT (N).Nkind = N_Extension_Aggregate + or else NT (N).Nkind = N_Selected_Component); + return Node4 (N); + end Associated_Node; + + function At_End_Proc + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Handled_Sequence_Of_Statements); + return Node1 (N); + end At_End_Proc; + + function Attribute_Name + (N : Node_Id) return Name_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Reference); + return Name2 (N); + end Attribute_Name; + + function Aux_Decls_Node + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit); + return Node5 (N); + end Aux_Decls_Node; + + function Backwards_OK + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement); + return Flag6 (N); + end Backwards_OK; + + function Bad_Is_Detected + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Body); + return Flag15 (N); + end Bad_Is_Detected; + + function Body_Required + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit); + return Flag13 (N); + end Body_Required; + + function Body_To_Inline + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Declaration); + return Node3 (N); + end Body_To_Inline; + + function Box_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Association + or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration + or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration + or else NT (N).Nkind = N_Formal_Package_Declaration + or else NT (N).Nkind = N_Generic_Association); + return Flag15 (N); + end Box_Present; + + function By_Ref + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Extended_Return_Statement + or else NT (N).Nkind = N_Return_Statement); + return Flag5 (N); + end By_Ref; + + function Char_Literal_Value + (N : Node_Id) return Uint is + begin + pragma Assert (False + or else NT (N).Nkind = N_Character_Literal); + return Uint2 (N); + end Char_Literal_Value; + + function Chars + (N : Node_Id) return Name_Id is + begin + pragma Assert (False + or else NT (N).Nkind in N_Has_Chars); + return Name1 (N); + end Chars; + + function Check_Address_Alignment + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Definition_Clause); + return Flag11 (N); + end Check_Address_Alignment; + + function Choice_Parameter + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exception_Handler); + return Node2 (N); + end Choice_Parameter; + + function Choices + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Association); + return List1 (N); + end Choices; + + function Class_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_Pragma); + return Flag6 (N); + end Class_Present; + + function Coextensions + (N : Node_Id) return Elist_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Allocator); + return Elist4 (N); + end Coextensions; + + function Comes_From_Extended_Return_Statement + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Return_Statement); + return Flag18 (N); + end Comes_From_Extended_Return_Statement; + + function Compile_Time_Known_Aggregate + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aggregate); + return Flag18 (N); + end Compile_Time_Known_Aggregate; + + function Component_Associations + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aggregate + or else NT (N).Nkind = N_Extension_Aggregate); + return List2 (N); + end Component_Associations; + + function Component_Clauses + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Record_Representation_Clause); + return List3 (N); + end Component_Clauses; + + function Component_Definition + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Declaration + or else NT (N).Nkind = N_Constrained_Array_Definition + or else NT (N).Nkind = N_Unconstrained_Array_Definition); + return Node4 (N); + end Component_Definition; + + function Component_Items + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_List); + return List3 (N); + end Component_Items; + + function Component_List + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Record_Definition + or else NT (N).Nkind = N_Variant); + return Node1 (N); + end Component_List; + + function Component_Name + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Clause); + return Node1 (N); + end Component_Name; + + function Componentwise_Assignment + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement); + return Flag14 (N); + end Componentwise_Assignment; + + function Condition + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Accept_Alternative + or else NT (N).Nkind = N_Delay_Alternative + or else NT (N).Nkind = N_Elsif_Part + or else NT (N).Nkind = N_Entry_Body_Formal_Part + or else NT (N).Nkind = N_Exit_Statement + or else NT (N).Nkind = N_If_Statement + or else NT (N).Nkind = N_Iteration_Scheme + or else NT (N).Nkind = N_Quantified_Expression + or else NT (N).Nkind = N_Raise_Constraint_Error + or else NT (N).Nkind = N_Raise_Program_Error + or else NT (N).Nkind = N_Raise_Storage_Error + or else NT (N).Nkind = N_Terminate_Alternative); + return Node1 (N); + end Condition; + + function Condition_Actions + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Elsif_Part + or else NT (N).Nkind = N_Iteration_Scheme); + return List3 (N); + end Condition_Actions; + + function Config_Pragmas + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit_Aux); + return List4 (N); + end Config_Pragmas; + + function Constant_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_Definition + or else NT (N).Nkind = N_Access_To_Object_Definition + or else NT (N).Nkind = N_Object_Declaration); + return Flag17 (N); + end Constant_Present; + + function Constraint + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subtype_Indication); + return Node3 (N); + end Constraint; + + function Constraints + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Index_Or_Discriminant_Constraint); + return List1 (N); + end Constraints; + + function Context_Installed + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + return Flag13 (N); + end Context_Installed; + + function Context_Items + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit); + return List1 (N); + end Context_Items; + + function Context_Pending + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit); + return Flag16 (N); + end Context_Pending; + + function Controlling_Argument + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Function_Call + or else NT (N).Nkind = N_Procedure_Call_Statement); + return Node1 (N); + end Controlling_Argument; + + function Conversion_OK + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Type_Conversion); + return Flag14 (N); + end Conversion_OK; + + function Corresponding_Body + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Entry_Declaration + or else NT (N).Nkind = N_Generic_Package_Declaration + or else NT (N).Nkind = N_Generic_Subprogram_Declaration + or else NT (N).Nkind = N_Package_Body_Stub + or else NT (N).Nkind = N_Package_Declaration + or else NT (N).Nkind = N_Protected_Body_Stub + or else NT (N).Nkind = N_Protected_Type_Declaration + or else NT (N).Nkind = N_Subprogram_Body_Stub + or else NT (N).Nkind = N_Subprogram_Declaration + or else NT (N).Nkind = N_Task_Body_Stub + or else NT (N).Nkind = N_Task_Type_Declaration); + return Node5 (N); + end Corresponding_Body; + + function Corresponding_Formal_Spec + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Renaming_Declaration); + return Node3 (N); + end Corresponding_Formal_Spec; + + function Corresponding_Generic_Association + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Object_Declaration + or else NT (N).Nkind = N_Object_Renaming_Declaration); + return Node5 (N); + end Corresponding_Generic_Association; + + function Corresponding_Integer_Value + (N : Node_Id) return Uint is + begin + pragma Assert (False + or else NT (N).Nkind = N_Real_Literal); + return Uint4 (N); + end Corresponding_Integer_Value; + + function Corresponding_Spec + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Package_Body + or else NT (N).Nkind = N_Protected_Body + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Subprogram_Renaming_Declaration + or else NT (N).Nkind = N_Task_Body + or else NT (N).Nkind = N_With_Clause); + return Node5 (N); + end Corresponding_Spec; + + function Corresponding_Stub + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subunit); + return Node3 (N); + end Corresponding_Stub; + + function Dcheck_Function + (N : Node_Id) return Entity_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Variant); + return Node5 (N); + end Dcheck_Function; + + function Debug_Statement + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + return Node3 (N); + end Debug_Statement; + + function Declarations + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Accept_Statement + or else NT (N).Nkind = N_Block_Statement + or else NT (N).Nkind = N_Compilation_Unit_Aux + or else NT (N).Nkind = N_Entry_Body + or else NT (N).Nkind = N_Package_Body + or else NT (N).Nkind = N_Protected_Body + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Task_Body); + return List2 (N); + end Declarations; + + function Default_Expression + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Formal_Object_Declaration + or else NT (N).Nkind = N_Parameter_Specification); + return Node5 (N); + end Default_Expression; + + function Default_Storage_Pool + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit_Aux); + return Node3 (N); + end Default_Storage_Pool; + + function Default_Name + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration + or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration); + return Node2 (N); + end Default_Name; + + function Defining_Identifier + (N : Node_Id) return Entity_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Declaration + or else NT (N).Nkind = N_Defining_Program_Unit_Name + or else NT (N).Nkind = N_Discriminant_Specification + or else NT (N).Nkind = N_Entry_Body + or else NT (N).Nkind = N_Entry_Declaration + or else NT (N).Nkind = N_Entry_Index_Specification + or else NT (N).Nkind = N_Exception_Declaration + or else NT (N).Nkind = N_Exception_Renaming_Declaration + or else NT (N).Nkind = N_Formal_Object_Declaration + or else NT (N).Nkind = N_Formal_Package_Declaration + or else NT (N).Nkind = N_Formal_Type_Declaration + or else NT (N).Nkind = N_Full_Type_Declaration + or else NT (N).Nkind = N_Implicit_Label_Declaration + or else NT (N).Nkind = N_Incomplete_Type_Declaration + or else NT (N).Nkind = N_Iterator_Specification + or else NT (N).Nkind = N_Loop_Parameter_Specification + or else NT (N).Nkind = N_Number_Declaration + or else NT (N).Nkind = N_Object_Declaration + or else NT (N).Nkind = N_Object_Renaming_Declaration + or else NT (N).Nkind = N_Package_Body_Stub + or else NT (N).Nkind = N_Parameter_Specification + or else NT (N).Nkind = N_Private_Extension_Declaration + or else NT (N).Nkind = N_Private_Type_Declaration + or else NT (N).Nkind = N_Protected_Body + or else NT (N).Nkind = N_Protected_Body_Stub + or else NT (N).Nkind = N_Protected_Type_Declaration + or else NT (N).Nkind = N_Single_Protected_Declaration + or else NT (N).Nkind = N_Single_Task_Declaration + or else NT (N).Nkind = N_Subtype_Declaration + or else NT (N).Nkind = N_Task_Body + or else NT (N).Nkind = N_Task_Body_Stub + or else NT (N).Nkind = N_Task_Type_Declaration); + return Node1 (N); + end Defining_Identifier; + + function Defining_Unit_Name + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Function_Specification + or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration + or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration + or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration + or else NT (N).Nkind = N_Package_Body + or else NT (N).Nkind = N_Package_Instantiation + or else NT (N).Nkind = N_Package_Renaming_Declaration + or else NT (N).Nkind = N_Package_Specification + or else NT (N).Nkind = N_Procedure_Instantiation + or else NT (N).Nkind = N_Procedure_Specification); + return Node1 (N); + end Defining_Unit_Name; + + function Delay_Alternative + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Timed_Entry_Call); + return Node4 (N); + end Delay_Alternative; + + function Delay_Statement + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Delay_Alternative); + return Node2 (N); + end Delay_Statement; + + function Delta_Expression + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition + or else NT (N).Nkind = N_Delta_Constraint + or else NT (N).Nkind = N_Ordinary_Fixed_Point_Definition); + return Node3 (N); + end Delta_Expression; + + function Digits_Expression + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition + or else NT (N).Nkind = N_Digits_Constraint + or else NT (N).Nkind = N_Floating_Point_Definition); + return Node2 (N); + end Digits_Expression; + + function Discr_Check_Funcs_Built + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Full_Type_Declaration); + return Flag11 (N); + end Discr_Check_Funcs_Built; + + function Discrete_Choices + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Case_Expression_Alternative + or else NT (N).Nkind = N_Case_Statement_Alternative + or else NT (N).Nkind = N_Variant); + return List4 (N); + end Discrete_Choices; + + function Discrete_Range + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Slice); + return Node4 (N); + end Discrete_Range; + + function Discrete_Subtype_Definition + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Entry_Declaration + or else NT (N).Nkind = N_Entry_Index_Specification + or else NT (N).Nkind = N_Loop_Parameter_Specification); + return Node4 (N); + end Discrete_Subtype_Definition; + + function Discrete_Subtype_Definitions + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Constrained_Array_Definition); + return List2 (N); + end Discrete_Subtype_Definitions; + + function Discriminant_Specifications + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Formal_Type_Declaration + or else NT (N).Nkind = N_Full_Type_Declaration + or else NT (N).Nkind = N_Incomplete_Type_Declaration + or else NT (N).Nkind = N_Private_Extension_Declaration + or else NT (N).Nkind = N_Private_Type_Declaration + or else NT (N).Nkind = N_Protected_Type_Declaration + or else NT (N).Nkind = N_Task_Type_Declaration); + return List4 (N); + end Discriminant_Specifications; + + function Discriminant_Type + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Discriminant_Specification); + return Node5 (N); + end Discriminant_Type; + + function Do_Accessibility_Check + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Parameter_Specification); + return Flag13 (N); + end Do_Accessibility_Check; + + function Do_Discriminant_Check + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Selected_Component); + return Flag13 (N); + end Do_Discriminant_Check; + + function Do_Division_Check + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Op_Divide + or else NT (N).Nkind = N_Op_Mod + or else NT (N).Nkind = N_Op_Rem); + return Flag13 (N); + end Do_Division_Check; + + function Do_Length_Check + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement + or else NT (N).Nkind = N_Op_And + or else NT (N).Nkind = N_Op_Or + or else NT (N).Nkind = N_Op_Xor + or else NT (N).Nkind = N_Type_Conversion); + return Flag4 (N); + end Do_Length_Check; + + function Do_Overflow_Check + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind in N_Op + or else NT (N).Nkind = N_Attribute_Reference + or else NT (N).Nkind = N_Type_Conversion); + return Flag17 (N); + end Do_Overflow_Check; + + function Do_Range_Check + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind in N_Subexpr); + return Flag9 (N); + end Do_Range_Check; + + function Do_Storage_Check + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Allocator + or else NT (N).Nkind = N_Subprogram_Body); + return Flag17 (N); + end Do_Storage_Check; + + function Do_Tag_Check + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement + or else NT (N).Nkind = N_Extended_Return_Statement + or else NT (N).Nkind = N_Function_Call + or else NT (N).Nkind = N_Procedure_Call_Statement + or else NT (N).Nkind = N_Return_Statement + or else NT (N).Nkind = N_Type_Conversion); + return Flag13 (N); + end Do_Tag_Check; + + function Elaborate_All_Desirable + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + return Flag9 (N); + end Elaborate_All_Desirable; + + function Elaborate_All_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + return Flag14 (N); + end Elaborate_All_Present; + + function Elaborate_Desirable + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + return Flag11 (N); + end Elaborate_Desirable; + + function Elaborate_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + return Flag4 (N); + end Elaborate_Present; + + function Elaboration_Boolean + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Function_Specification + or else NT (N).Nkind = N_Procedure_Specification); + return Node2 (N); + end Elaboration_Boolean; + + function Else_Actions + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Conditional_Expression); + return List3 (N); + end Else_Actions; + + function Else_Statements + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Conditional_Entry_Call + or else NT (N).Nkind = N_If_Statement + or else NT (N).Nkind = N_Selective_Accept); + return List4 (N); + end Else_Statements; + + function Elsif_Parts + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_If_Statement); + return List3 (N); + end Elsif_Parts; + + function Enclosing_Variant + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Variant); + return Node2 (N); + end Enclosing_Variant; + + function End_Label + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Enumeration_Type_Definition + or else NT (N).Nkind = N_Handled_Sequence_Of_Statements + or else NT (N).Nkind = N_Loop_Statement + or else NT (N).Nkind = N_Package_Specification + or else NT (N).Nkind = N_Protected_Body + or else NT (N).Nkind = N_Protected_Definition + or else NT (N).Nkind = N_Record_Definition + or else NT (N).Nkind = N_Task_Definition); + return Node4 (N); + end End_Label; + + function End_Span + (N : Node_Id) return Uint is + begin + pragma Assert (False + or else NT (N).Nkind = N_Case_Statement + or else NT (N).Nkind = N_If_Statement); + return Uint5 (N); + end End_Span; + + function Entity + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind in N_Has_Entity + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Freeze_Entity); + return Node4 (N); + end Entity; + + function Entity_Or_Associated_Node + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind in N_Has_Entity + or else NT (N).Nkind = N_Freeze_Entity); + return Node4 (N); + end Entity_Or_Associated_Node; + + function Entry_Body_Formal_Part + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Entry_Body); + return Node5 (N); + end Entry_Body_Formal_Part; + + function Entry_Call_Alternative + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Conditional_Entry_Call + or else NT (N).Nkind = N_Timed_Entry_Call); + return Node1 (N); + end Entry_Call_Alternative; + + function Entry_Call_Statement + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Entry_Call_Alternative); + return Node1 (N); + end Entry_Call_Statement; + + function Entry_Direct_Name + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Accept_Statement); + return Node1 (N); + end Entry_Direct_Name; + + function Entry_Index + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Accept_Statement); + return Node5 (N); + end Entry_Index; + + function Entry_Index_Specification + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Entry_Body_Formal_Part); + return Node4 (N); + end Entry_Index_Specification; + + function Etype + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind in N_Has_Etype); + return Node5 (N); + end Etype; + + function Exception_Choices + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exception_Handler); + return List4 (N); + end Exception_Choices; + + function Exception_Handlers + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Handled_Sequence_Of_Statements); + return List5 (N); + end Exception_Handlers; + + function Exception_Junk + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Block_Statement + or else NT (N).Nkind = N_Goto_Statement + or else NT (N).Nkind = N_Label + or else NT (N).Nkind = N_Object_Declaration + or else NT (N).Nkind = N_Subtype_Declaration); + return Flag8 (N); + end Exception_Junk; + + function Exception_Label + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exception_Handler + or else NT (N).Nkind = N_Push_Constraint_Error_Label + or else NT (N).Nkind = N_Push_Program_Error_Label + or else NT (N).Nkind = N_Push_Storage_Error_Label); + return Node5 (N); + end Exception_Label; + + function Expansion_Delayed + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aggregate + or else NT (N).Nkind = N_Extension_Aggregate); + return Flag11 (N); + end Expansion_Delayed; + + function Explicit_Actual_Parameter + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Parameter_Association); + return Node3 (N); + end Explicit_Actual_Parameter; + + function Explicit_Generic_Actual_Parameter + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Generic_Association); + return Node1 (N); + end Explicit_Generic_Actual_Parameter; + + function Expression + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Allocator + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_Assignment_Statement + or else NT (N).Nkind = N_At_Clause + or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Case_Expression + or else NT (N).Nkind = N_Case_Expression_Alternative + or else NT (N).Nkind = N_Case_Statement + or else NT (N).Nkind = N_Code_Statement + or else NT (N).Nkind = N_Component_Association + or else NT (N).Nkind = N_Component_Declaration + or else NT (N).Nkind = N_Delay_Relative_Statement + or else NT (N).Nkind = N_Delay_Until_Statement + or else NT (N).Nkind = N_Discriminant_Association + or else NT (N).Nkind = N_Discriminant_Specification + or else NT (N).Nkind = N_Exception_Declaration + or else NT (N).Nkind = N_Expression_With_Actions + or else NT (N).Nkind = N_Free_Statement + or else NT (N).Nkind = N_Mod_Clause + or else NT (N).Nkind = N_Modular_Type_Definition + or else NT (N).Nkind = N_Number_Declaration + or else NT (N).Nkind = N_Object_Declaration + or else NT (N).Nkind = N_Parameter_Specification + or else NT (N).Nkind = N_Parameterized_Expression + or else NT (N).Nkind = N_Pragma_Argument_Association + or else NT (N).Nkind = N_Qualified_Expression + or else NT (N).Nkind = N_Raise_Statement + or else NT (N).Nkind = N_Return_Statement + or else NT (N).Nkind = N_Type_Conversion + or else NT (N).Nkind = N_Unchecked_Expression + or else NT (N).Nkind = N_Unchecked_Type_Conversion); + return Node3 (N); + end Expression; + + function Expressions + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aggregate + or else NT (N).Nkind = N_Attribute_Reference + or else NT (N).Nkind = N_Conditional_Expression + or else NT (N).Nkind = N_Extension_Aggregate + or else NT (N).Nkind = N_Indexed_Component); + return List1 (N); + end Expressions; + + function First_Bit + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Clause); + return Node3 (N); + end First_Bit; + + function First_Inlined_Subprogram + (N : Node_Id) return Entity_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit); + return Node3 (N); + end First_Inlined_Subprogram; + + function First_Name + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + return Flag5 (N); + end First_Name; + + function First_Named_Actual + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Entry_Call_Statement + or else NT (N).Nkind = N_Function_Call + or else NT (N).Nkind = N_Procedure_Call_Statement); + return Node4 (N); + end First_Named_Actual; + + function First_Real_Statement + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Handled_Sequence_Of_Statements); + return Node2 (N); + end First_Real_Statement; + + function First_Subtype_Link + (N : Node_Id) return Entity_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Freeze_Entity); + return Node5 (N); + end First_Subtype_Link; + + function Float_Truncate + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Type_Conversion); + return Flag11 (N); + end Float_Truncate; + + function Formal_Type_Definition + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Formal_Type_Declaration); + return Node3 (N); + end Formal_Type_Definition; + + function Forwards_OK + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement); + return Flag5 (N); + end Forwards_OK; + + function From_Aspect_Specification + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Pragma); + return Flag13 (N); + end From_Aspect_Specification; + + function From_At_End + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Raise_Statement); + return Flag4 (N); + end From_At_End; + + function From_At_Mod + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Definition_Clause); + return Flag4 (N); + end From_At_Mod; + + function From_Default + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Renaming_Declaration); + return Flag6 (N); + end From_Default; + + function Generic_Associations + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Formal_Package_Declaration + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Package_Instantiation + or else NT (N).Nkind = N_Procedure_Instantiation); + return List3 (N); + end Generic_Associations; + + function Generic_Formal_Declarations + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Generic_Package_Declaration + or else NT (N).Nkind = N_Generic_Subprogram_Declaration); + return List2 (N); + end Generic_Formal_Declarations; + + function Generic_Parent + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Function_Specification + or else NT (N).Nkind = N_Package_Specification + or else NT (N).Nkind = N_Procedure_Specification); + return Node5 (N); + end Generic_Parent; + + function Generic_Parent_Type + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subtype_Declaration); + return Node4 (N); + end Generic_Parent_Type; + + function Handled_Statement_Sequence + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Accept_Statement + or else NT (N).Nkind = N_Block_Statement + or else NT (N).Nkind = N_Entry_Body + or else NT (N).Nkind = N_Extended_Return_Statement + or else NT (N).Nkind = N_Package_Body + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Task_Body); + return Node4 (N); + end Handled_Statement_Sequence; + + function Handler_List_Entry + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Object_Declaration); + return Node2 (N); + end Handler_List_Entry; + + function Has_Created_Identifier + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Block_Statement + or else NT (N).Nkind = N_Loop_Statement); + return Flag15 (N); + end Has_Created_Identifier; + + function Has_Dynamic_Length_Check + (N : Node_Id) return Boolean is + begin + return Flag10 (N); + end Has_Dynamic_Length_Check; + function Has_Dynamic_Range_Check + (N : Node_Id) return Boolean is + begin + return Flag12 (N); + end Has_Dynamic_Range_Check; + + function Has_Init_Expression + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Object_Declaration); + return Flag14 (N); + end Has_Init_Expression; + + function Has_Local_Raise + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exception_Handler); + return Flag8 (N); + end Has_Local_Raise; + + function Has_No_Elaboration_Code + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit); + return Flag17 (N); + end Has_No_Elaboration_Code; + + function Has_Pragma_CPU + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Task_Definition); + return Flag14 (N); + end Has_Pragma_CPU; + + function Has_Pragma_Priority + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Protected_Definition + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Task_Definition); + return Flag6 (N); + end Has_Pragma_Priority; + + function Has_Pragma_Suppress_All + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit); + return Flag14 (N); + end Has_Pragma_Suppress_All; + + function Has_Private_View + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind in N_Op + or else NT (N).Nkind = N_Character_Literal + or else NT (N).Nkind = N_Expanded_Name + or else NT (N).Nkind = N_Identifier + or else NT (N).Nkind = N_Operator_Symbol); + return Flag11 (N); + end Has_Private_View; + + function Has_Relative_Deadline_Pragma + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Task_Definition); + return Flag9 (N); + end Has_Relative_Deadline_Pragma; + + function Has_Self_Reference + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aggregate + or else NT (N).Nkind = N_Extension_Aggregate); + return Flag13 (N); + end Has_Self_Reference; + + function Has_Storage_Size_Pragma + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Task_Definition); + return Flag5 (N); + end Has_Storage_Size_Pragma; + + function Has_Task_Info_Pragma + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Task_Definition); + return Flag7 (N); + end Has_Task_Info_Pragma; + + function Has_Task_Name_Pragma + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Task_Definition); + return Flag8 (N); + end Has_Task_Name_Pragma; + + function Has_Wide_Character + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_String_Literal); + return Flag11 (N); + end Has_Wide_Character; + + function Has_Wide_Wide_Character + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_String_Literal); + return Flag13 (N); + end Has_Wide_Wide_Character; + + function Hidden_By_Use_Clause + (N : Node_Id) return Elist_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Use_Package_Clause + or else NT (N).Nkind = N_Use_Type_Clause); + return Elist4 (N); + end Hidden_By_Use_Clause; + + function High_Bound + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Range + or else NT (N).Nkind = N_Real_Range_Specification + or else NT (N).Nkind = N_Signed_Integer_Type_Definition); + return Node2 (N); + end High_Bound; + + function Identifier + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_At_Clause + or else NT (N).Nkind = N_Block_Statement + or else NT (N).Nkind = N_Designator + or else NT (N).Nkind = N_Enumeration_Representation_Clause + or else NT (N).Nkind = N_Label + or else NT (N).Nkind = N_Loop_Statement + or else NT (N).Nkind = N_Record_Representation_Clause + or else NT (N).Nkind = N_Subprogram_Info); + return Node1 (N); + end Identifier; + + function Implicit_With + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + return Flag16 (N); + end Implicit_With; + + function Interface_List + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Derived_Type_Definition + or else NT (N).Nkind = N_Formal_Derived_Type_Definition + or else NT (N).Nkind = N_Private_Extension_Declaration + or else NT (N).Nkind = N_Protected_Type_Declaration + or else NT (N).Nkind = N_Record_Definition + or else NT (N).Nkind = N_Single_Protected_Declaration + or else NT (N).Nkind = N_Single_Task_Declaration + or else NT (N).Nkind = N_Task_Type_Declaration); + return List2 (N); + end Interface_List; + + function Interface_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Derived_Type_Definition + or else NT (N).Nkind = N_Record_Definition); + return Flag16 (N); + end Interface_Present; + + function Import_Interface_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + return Flag16 (N); + end Import_Interface_Present; + + function In_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Formal_Object_Declaration + or else NT (N).Nkind = N_Parameter_Specification); + return Flag15 (N); + end In_Present; + + function Includes_Infinities + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Range); + return Flag11 (N); + end Includes_Infinities; + + function Inherited_Discriminant + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Association); + return Flag13 (N); + end Inherited_Discriminant; + + function Instance_Spec + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Formal_Package_Declaration + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Package_Instantiation + or else NT (N).Nkind = N_Procedure_Instantiation); + return Node5 (N); + end Instance_Spec; + + function Intval + (N : Node_Id) return Uint is + begin + pragma Assert (False + or else NT (N).Nkind = N_Integer_Literal); + return Uint3 (N); + end Intval; + + function Is_Accessibility_Actual + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Parameter_Association); + return Flag13 (N); + end Is_Accessibility_Actual; + + function Is_Asynchronous_Call_Block + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Block_Statement); + return Flag7 (N); + end Is_Asynchronous_Call_Block; + + function Is_Component_Left_Opnd + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Op_Concat); + return Flag13 (N); + end Is_Component_Left_Opnd; + + function Is_Component_Right_Opnd + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Op_Concat); + return Flag14 (N); + end Is_Component_Right_Opnd; + + function Is_Controlling_Actual + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind in N_Subexpr); + return Flag16 (N); + end Is_Controlling_Actual; + + function Is_Delayed_Aspect + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Pragma); + return Flag14 (N); + end Is_Delayed_Aspect; + + function Is_Dynamic_Coextension + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Allocator); + return Flag18 (N); + end Is_Dynamic_Coextension; + + function Is_Elsif + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Conditional_Expression); + return Flag13 (N); + end Is_Elsif; + + function Is_Entry_Barrier_Function + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Body); + return Flag8 (N); + end Is_Entry_Barrier_Function; + + function Is_Expanded_Build_In_Place_Call + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Function_Call); + return Flag11 (N); + end Is_Expanded_Build_In_Place_Call; + + function Is_Folded_In_Parser + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_String_Literal); + return Flag4 (N); + end Is_Folded_In_Parser; + + function Is_In_Discriminant_Check + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Selected_Component); + return Flag11 (N); + end Is_In_Discriminant_Check; + + function Is_Machine_Number + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Real_Literal); + return Flag11 (N); + end Is_Machine_Number; + + function Is_Null_Loop + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Loop_Statement); + return Flag16 (N); + end Is_Null_Loop; + + function Is_Overloaded + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind in N_Subexpr); + return Flag5 (N); + end Is_Overloaded; + + function Is_Power_Of_2_For_Shift + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Op_Expon); + return Flag13 (N); + end Is_Power_Of_2_For_Shift; + + function Is_Protected_Subprogram_Body + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Body); + return Flag7 (N); + end Is_Protected_Subprogram_Body; + + function Is_Static_Coextension + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Allocator); + return Flag14 (N); + end Is_Static_Coextension; + + function Is_Static_Expression + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind in N_Subexpr); + return Flag6 (N); + end Is_Static_Expression; + + function Is_Subprogram_Descriptor + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Object_Declaration); + return Flag16 (N); + end Is_Subprogram_Descriptor; + + function Is_Task_Allocation_Block + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Block_Statement); + return Flag6 (N); + end Is_Task_Allocation_Block; + + function Is_Task_Master + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Block_Statement + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Task_Body); + return Flag5 (N); + end Is_Task_Master; + + function Iteration_Scheme + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Loop_Statement); + return Node2 (N); + end Iteration_Scheme; + + function Iterator_Specification + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Iteration_Scheme + or else NT (N).Nkind = N_Quantified_Expression); + return Node2 (N); + end Iterator_Specification; + + function Itype + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Itype_Reference); + return Node1 (N); + end Itype; + + function Kill_Range_Check + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Unchecked_Type_Conversion); + return Flag11 (N); + end Kill_Range_Check; + + function Label_Construct + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Implicit_Label_Declaration); + return Node2 (N); + end Label_Construct; + + function Last_Bit + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Clause); + return Node4 (N); + end Last_Bit; + + function Last_Name + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + return Flag6 (N); + end Last_Name; + + function Left_Opnd + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_And_Then + or else NT (N).Nkind = N_In + or else NT (N).Nkind = N_Not_In + or else NT (N).Nkind = N_Or_Else + or else NT (N).Nkind in N_Binary_Op); + return Node2 (N); + end Left_Opnd; + + function Library_Unit + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit + or else NT (N).Nkind = N_Package_Body_Stub + or else NT (N).Nkind = N_Protected_Body_Stub + or else NT (N).Nkind = N_Subprogram_Body_Stub + or else NT (N).Nkind = N_Task_Body_Stub + or else NT (N).Nkind = N_With_Clause); + return Node4 (N); + end Library_Unit; + + function Limited_View_Installed + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Package_Specification + or else NT (N).Nkind = N_With_Clause); + return Flag18 (N); + end Limited_View_Installed; + + function Limited_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Derived_Type_Definition + or else NT (N).Nkind = N_Formal_Derived_Type_Definition + or else NT (N).Nkind = N_Formal_Private_Type_Definition + or else NT (N).Nkind = N_Private_Extension_Declaration + or else NT (N).Nkind = N_Private_Type_Declaration + or else NT (N).Nkind = N_Record_Definition + or else NT (N).Nkind = N_With_Clause); + return Flag17 (N); + end Limited_Present; + + function Literals + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Enumeration_Type_Definition); + return List1 (N); + end Literals; + + function Local_Raise_Not_OK + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exception_Handler); + return Flag7 (N); + end Local_Raise_Not_OK; + + function Local_Raise_Statements + (N : Node_Id) return Elist_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exception_Handler); + return Elist1 (N); + end Local_Raise_Statements; + + function Loop_Actions + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Association); + return List2 (N); + end Loop_Actions; + + function Loop_Parameter_Specification + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Iteration_Scheme + or else NT (N).Nkind = N_Quantified_Expression); + return Node4 (N); + end Loop_Parameter_Specification; + + function Low_Bound + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Range + or else NT (N).Nkind = N_Real_Range_Specification + or else NT (N).Nkind = N_Signed_Integer_Type_Definition); + return Node1 (N); + end Low_Bound; + + function Mod_Clause + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Record_Representation_Clause); + return Node2 (N); + end Mod_Clause; + + function More_Ids + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Declaration + or else NT (N).Nkind = N_Discriminant_Specification + or else NT (N).Nkind = N_Exception_Declaration + or else NT (N).Nkind = N_Formal_Object_Declaration + or else NT (N).Nkind = N_Number_Declaration + or else NT (N).Nkind = N_Object_Declaration + or else NT (N).Nkind = N_Parameter_Specification); + return Flag5 (N); + end More_Ids; + + function Must_Be_Byte_Aligned + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Reference); + return Flag14 (N); + end Must_Be_Byte_Aligned; + + function Must_Not_Freeze + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subtype_Indication + or else NT (N).Nkind in N_Subexpr); + return Flag8 (N); + end Must_Not_Freeze; + + function Must_Not_Override + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Entry_Declaration + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Function_Specification + or else NT (N).Nkind = N_Procedure_Instantiation + or else NT (N).Nkind = N_Procedure_Specification); + return Flag15 (N); + end Must_Not_Override; + + function Must_Override + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Entry_Declaration + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Function_Specification + or else NT (N).Nkind = N_Procedure_Instantiation + or else NT (N).Nkind = N_Procedure_Specification); + return Flag14 (N); + end Must_Override; + + function Name + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement + or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Defining_Program_Unit_Name + or else NT (N).Nkind = N_Designator + or else NT (N).Nkind = N_Entry_Call_Statement + or else NT (N).Nkind = N_Exception_Renaming_Declaration + or else NT (N).Nkind = N_Exit_Statement + or else NT (N).Nkind = N_Formal_Package_Declaration + or else NT (N).Nkind = N_Function_Call + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration + or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration + or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration + or else NT (N).Nkind = N_Goto_Statement + or else NT (N).Nkind = N_Iterator_Specification + or else NT (N).Nkind = N_Object_Renaming_Declaration + or else NT (N).Nkind = N_Package_Instantiation + or else NT (N).Nkind = N_Package_Renaming_Declaration + or else NT (N).Nkind = N_Procedure_Call_Statement + or else NT (N).Nkind = N_Procedure_Instantiation + or else NT (N).Nkind = N_Raise_Statement + or else NT (N).Nkind = N_Requeue_Statement + or else NT (N).Nkind = N_Subprogram_Renaming_Declaration + or else NT (N).Nkind = N_Subunit + or else NT (N).Nkind = N_Variant_Part + or else NT (N).Nkind = N_With_Clause); + return Node2 (N); + end Name; + + function Names + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Abort_Statement + or else NT (N).Nkind = N_Use_Package_Clause); + return List2 (N); + end Names; + + function Next_Entity + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Defining_Character_Literal + or else NT (N).Nkind = N_Defining_Identifier + or else NT (N).Nkind = N_Defining_Operator_Symbol); + return Node2 (N); + end Next_Entity; + + function Next_Exit_Statement + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exit_Statement); + return Node3 (N); + end Next_Exit_Statement; + + function Next_Implicit_With + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + return Node3 (N); + end Next_Implicit_With; + + function Next_Named_Actual + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Parameter_Association); + return Node4 (N); + end Next_Named_Actual; + + function Next_Pragma + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + return Node1 (N); + end Next_Pragma; + + function Next_Rep_Item + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Enumeration_Representation_Clause + or else NT (N).Nkind = N_Pragma + or else NT (N).Nkind = N_Record_Representation_Clause); + return Node5 (N); + end Next_Rep_Item; + + function Next_Use_Clause + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Use_Package_Clause + or else NT (N).Nkind = N_Use_Type_Clause); + return Node3 (N); + end Next_Use_Clause; + + function No_Ctrl_Actions + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement); + return Flag7 (N); + end No_Ctrl_Actions; + + function No_Elaboration_Check + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Function_Call + or else NT (N).Nkind = N_Procedure_Call_Statement); + return Flag14 (N); + end No_Elaboration_Check; + + function No_Entities_Ref_In_Spec + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + return Flag8 (N); + end No_Entities_Ref_In_Spec; + + function No_Initialization + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Allocator + or else NT (N).Nkind = N_Object_Declaration); + return Flag13 (N); + end No_Initialization; + + function No_Truncation + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Unchecked_Type_Conversion); + return Flag17 (N); + end No_Truncation; + + function Null_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_List + or else NT (N).Nkind = N_Procedure_Specification + or else NT (N).Nkind = N_Record_Definition); + return Flag13 (N); + end Null_Present; + + function Null_Exclusion_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_Definition + or else NT (N).Nkind = N_Access_Function_Definition + or else NT (N).Nkind = N_Access_Procedure_Definition + or else NT (N).Nkind = N_Access_To_Object_Definition + or else NT (N).Nkind = N_Allocator + or else NT (N).Nkind = N_Component_Definition + or else NT (N).Nkind = N_Derived_Type_Definition + or else NT (N).Nkind = N_Discriminant_Specification + or else NT (N).Nkind = N_Formal_Object_Declaration + or else NT (N).Nkind = N_Function_Specification + or else NT (N).Nkind = N_Object_Declaration + or else NT (N).Nkind = N_Object_Renaming_Declaration + or else NT (N).Nkind = N_Parameter_Specification + or else NT (N).Nkind = N_Subtype_Declaration); + return Flag11 (N); + end Null_Exclusion_Present; + + function Null_Exclusion_In_Return_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_Function_Definition); + return Flag14 (N); + end Null_Exclusion_In_Return_Present; + + function Null_Record_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aggregate + or else NT (N).Nkind = N_Extension_Aggregate); + return Flag17 (N); + end Null_Record_Present; + + function Object_Definition + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Object_Declaration); + return Node4 (N); + end Object_Definition; + + function Of_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Iterator_Specification); + return Flag16 (N); + end Of_Present; + + function Original_Discriminant + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Identifier); + return Node2 (N); + end Original_Discriminant; + + function Original_Entity + (N : Node_Id) return Entity_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Integer_Literal + or else NT (N).Nkind = N_Real_Literal); + return Node2 (N); + end Original_Entity; + + function Others_Discrete_Choices + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Others_Choice); + return List1 (N); + end Others_Discrete_Choices; + + function Out_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Formal_Object_Declaration + or else NT (N).Nkind = N_Parameter_Specification); + return Flag17 (N); + end Out_Present; + + function Parameter_Associations + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Entry_Call_Statement + or else NT (N).Nkind = N_Function_Call + or else NT (N).Nkind = N_Procedure_Call_Statement); + return List3 (N); + end Parameter_Associations; + + function Parameter_List_Truncated + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Function_Call + or else NT (N).Nkind = N_Procedure_Call_Statement); + return Flag17 (N); + end Parameter_List_Truncated; + + function Parameter_Specifications + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Accept_Statement + or else NT (N).Nkind = N_Access_Function_Definition + or else NT (N).Nkind = N_Access_Procedure_Definition + or else NT (N).Nkind = N_Entry_Body_Formal_Part + or else NT (N).Nkind = N_Entry_Declaration + or else NT (N).Nkind = N_Function_Specification + or else NT (N).Nkind = N_Procedure_Specification); + return List3 (N); + end Parameter_Specifications; + + function Parameter_Type + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Parameter_Specification); + return Node2 (N); + end Parameter_Type; + + function Parent_Spec + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration + or else NT (N).Nkind = N_Generic_Package_Declaration + or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration + or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration + or else NT (N).Nkind = N_Generic_Subprogram_Declaration + or else NT (N).Nkind = N_Package_Declaration + or else NT (N).Nkind = N_Package_Instantiation + or else NT (N).Nkind = N_Package_Renaming_Declaration + or else NT (N).Nkind = N_Procedure_Instantiation + or else NT (N).Nkind = N_Subprogram_Declaration + or else NT (N).Nkind = N_Subprogram_Renaming_Declaration); + return Node4 (N); + end Parent_Spec; + + function Position + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Clause); + return Node2 (N); + end Position; + + function Pragma_Argument_Associations + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + return List2 (N); + end Pragma_Argument_Associations; + + function Pragma_Enabled + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + return Flag5 (N); + end Pragma_Enabled; + + function Pragma_Identifier + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + return Node4 (N); + end Pragma_Identifier; + + function Pragmas_After + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit_Aux + or else NT (N).Nkind = N_Terminate_Alternative); + return List5 (N); + end Pragmas_After; + + function Pragmas_Before + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Accept_Alternative + or else NT (N).Nkind = N_Delay_Alternative + or else NT (N).Nkind = N_Entry_Call_Alternative + or else NT (N).Nkind = N_Mod_Clause + or else NT (N).Nkind = N_Terminate_Alternative + or else NT (N).Nkind = N_Triggering_Alternative); + return List4 (N); + end Pragmas_Before; + + function Prefix + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Reference + or else NT (N).Nkind = N_Expanded_Name + or else NT (N).Nkind = N_Explicit_Dereference + or else NT (N).Nkind = N_Indexed_Component + or else NT (N).Nkind = N_Reference + or else NT (N).Nkind = N_Selected_Component + or else NT (N).Nkind = N_Slice); + return Node3 (N); + end Prefix; + + function Present_Expr + (N : Node_Id) return Uint is + begin + pragma Assert (False + or else NT (N).Nkind = N_Variant); + return Uint3 (N); + end Present_Expr; + + function Prev_Ids + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Declaration + or else NT (N).Nkind = N_Discriminant_Specification + or else NT (N).Nkind = N_Exception_Declaration + or else NT (N).Nkind = N_Formal_Object_Declaration + or else NT (N).Nkind = N_Number_Declaration + or else NT (N).Nkind = N_Object_Declaration + or else NT (N).Nkind = N_Parameter_Specification); + return Flag6 (N); + end Prev_Ids; + + function Print_In_Hex + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Integer_Literal); + return Flag13 (N); + end Print_In_Hex; + + function Private_Declarations + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Package_Specification + or else NT (N).Nkind = N_Protected_Definition + or else NT (N).Nkind = N_Task_Definition); + return List3 (N); + end Private_Declarations; + + function Private_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit + or else NT (N).Nkind = N_Formal_Derived_Type_Definition + or else NT (N).Nkind = N_With_Clause); + return Flag15 (N); + end Private_Present; + + function Procedure_To_Call + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Allocator + or else NT (N).Nkind = N_Extended_Return_Statement + or else NT (N).Nkind = N_Free_Statement + or else NT (N).Nkind = N_Return_Statement); + return Node2 (N); + end Procedure_To_Call; + + function Proper_Body + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subunit); + return Node1 (N); + end Proper_Body; + + function Protected_Definition + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Protected_Type_Declaration + or else NT (N).Nkind = N_Single_Protected_Declaration); + return Node3 (N); + end Protected_Definition; + + function Protected_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_Function_Definition + or else NT (N).Nkind = N_Access_Procedure_Definition + or else NT (N).Nkind = N_Derived_Type_Definition + or else NT (N).Nkind = N_Record_Definition); + return Flag6 (N); + end Protected_Present; + + function Raises_Constraint_Error + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind in N_Subexpr); + return Flag7 (N); + end Raises_Constraint_Error; + + function Range_Constraint + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Delta_Constraint + or else NT (N).Nkind = N_Digits_Constraint); + return Node4 (N); + end Range_Constraint; + + function Range_Expression + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Range_Constraint); + return Node4 (N); + end Range_Expression; + + function Real_Range_Specification + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition + or else NT (N).Nkind = N_Floating_Point_Definition + or else NT (N).Nkind = N_Ordinary_Fixed_Point_Definition); + return Node4 (N); + end Real_Range_Specification; + + function Realval + (N : Node_Id) return Ureal is + begin + pragma Assert (False + or else NT (N).Nkind = N_Real_Literal); + return Ureal3 (N); + end Realval; + + function Reason + (N : Node_Id) return Uint is + begin + pragma Assert (False + or else NT (N).Nkind = N_Raise_Constraint_Error + or else NT (N).Nkind = N_Raise_Program_Error + or else NT (N).Nkind = N_Raise_Storage_Error); + return Uint3 (N); + end Reason; + + function Record_Extension_Part + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Derived_Type_Definition); + return Node3 (N); + end Record_Extension_Part; + + function Redundant_Use + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Reference + or else NT (N).Nkind = N_Expanded_Name + or else NT (N).Nkind = N_Identifier); + return Flag13 (N); + end Redundant_Use; + + function Renaming_Exception + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exception_Declaration); + return Node2 (N); + end Renaming_Exception; + + function Result_Definition + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_Function_Definition + or else NT (N).Nkind = N_Function_Specification); + return Node4 (N); + end Result_Definition; + + function Return_Object_Declarations + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Extended_Return_Statement); + return List3 (N); + end Return_Object_Declarations; + + function Return_Statement_Entity + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Extended_Return_Statement + or else NT (N).Nkind = N_Return_Statement); + return Node5 (N); + end Return_Statement_Entity; + + function Reverse_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Iterator_Specification + or else NT (N).Nkind = N_Loop_Parameter_Specification); + return Flag15 (N); + end Reverse_Present; + + function Right_Opnd + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind in N_Op + or else NT (N).Nkind = N_And_Then + or else NT (N).Nkind = N_In + or else NT (N).Nkind = N_Not_In + or else NT (N).Nkind = N_Or_Else); + return Node3 (N); + end Right_Opnd; + + function Rounded_Result + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Op_Divide + or else NT (N).Nkind = N_Op_Multiply + or else NT (N).Nkind = N_Type_Conversion); + return Flag18 (N); + end Rounded_Result; + + function SCIL_Controlling_Tag + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_SCIL_Dispatching_Call); + return Node5 (N); + end SCIL_Controlling_Tag; + + function SCIL_Entity + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init + or else NT (N).Nkind = N_SCIL_Dispatching_Call + or else NT (N).Nkind = N_SCIL_Membership_Test); + return Node4 (N); + end SCIL_Entity; + + function SCIL_Tag_Value + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_SCIL_Membership_Test); + return Node5 (N); + end SCIL_Tag_Value; + + function SCIL_Target_Prim + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_SCIL_Dispatching_Call); + return Node2 (N); + end SCIL_Target_Prim; + + function Scope + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Defining_Character_Literal + or else NT (N).Nkind = N_Defining_Identifier + or else NT (N).Nkind = N_Defining_Operator_Symbol); + return Node3 (N); + end Scope; + + function Select_Alternatives + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Selective_Accept); + return List1 (N); + end Select_Alternatives; + + function Selector_Name + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Expanded_Name + or else NT (N).Nkind = N_Generic_Association + or else NT (N).Nkind = N_Parameter_Association + or else NT (N).Nkind = N_Selected_Component); + return Node2 (N); + end Selector_Name; + + function Selector_Names + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Discriminant_Association); + return List1 (N); + end Selector_Names; + + function Shift_Count_OK + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Op_Rotate_Left + or else NT (N).Nkind = N_Op_Rotate_Right + or else NT (N).Nkind = N_Op_Shift_Left + or else NT (N).Nkind = N_Op_Shift_Right + or else NT (N).Nkind = N_Op_Shift_Right_Arithmetic); + return Flag4 (N); + end Shift_Count_OK; + + function Source_Type + (N : Node_Id) return Entity_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Validate_Unchecked_Conversion); + return Node1 (N); + end Source_Type; + + function Specification + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Abstract_Subprogram_Declaration + or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration + or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration + or else NT (N).Nkind = N_Generic_Package_Declaration + or else NT (N).Nkind = N_Generic_Subprogram_Declaration + or else NT (N).Nkind = N_Package_Declaration + or else NT (N).Nkind = N_Parameterized_Expression + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Subprogram_Body_Stub + or else NT (N).Nkind = N_Subprogram_Declaration + or else NT (N).Nkind = N_Subprogram_Renaming_Declaration); + return Node1 (N); + end Specification; + + function Split_PPC + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_Pragma); + return Flag17 (N); + end Split_PPC; + + function Statements + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Abortable_Part + or else NT (N).Nkind = N_Accept_Alternative + or else NT (N).Nkind = N_Case_Statement_Alternative + or else NT (N).Nkind = N_Delay_Alternative + or else NT (N).Nkind = N_Entry_Call_Alternative + or else NT (N).Nkind = N_Exception_Handler + or else NT (N).Nkind = N_Handled_Sequence_Of_Statements + or else NT (N).Nkind = N_Loop_Statement + or else NT (N).Nkind = N_Triggering_Alternative); + return List3 (N); + end Statements; + + function Static_Processing_OK + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aggregate); + return Flag4 (N); + end Static_Processing_OK; + + function Storage_Pool + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Allocator + or else NT (N).Nkind = N_Extended_Return_Statement + or else NT (N).Nkind = N_Free_Statement + or else NT (N).Nkind = N_Return_Statement); + return Node1 (N); + end Storage_Pool; + + function Strval + (N : Node_Id) return String_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Operator_Symbol + or else NT (N).Nkind = N_String_Literal); + return Str3 (N); + end Strval; + + function Subtype_Indication + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_To_Object_Definition + or else NT (N).Nkind = N_Component_Definition + or else NT (N).Nkind = N_Derived_Type_Definition + or else NT (N).Nkind = N_Iterator_Specification + or else NT (N).Nkind = N_Private_Extension_Declaration + or else NT (N).Nkind = N_Subtype_Declaration); + return Node5 (N); + end Subtype_Indication; + + function Suppress_Assignment_Checks + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement + or else NT (N).Nkind = N_Object_Declaration); + return Flag18 (N); + end Suppress_Assignment_Checks; + + function Suppress_Loop_Warnings + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Loop_Statement); + return Flag17 (N); + end Suppress_Loop_Warnings; + + function Subtype_Mark + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_Definition + or else NT (N).Nkind = N_Formal_Derived_Type_Definition + or else NT (N).Nkind = N_Formal_Object_Declaration + or else NT (N).Nkind = N_Object_Renaming_Declaration + or else NT (N).Nkind = N_Qualified_Expression + or else NT (N).Nkind = N_Subtype_Indication + or else NT (N).Nkind = N_Type_Conversion + or else NT (N).Nkind = N_Unchecked_Type_Conversion); + return Node4 (N); + end Subtype_Mark; + + function Subtype_Marks + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Unconstrained_Array_Definition + or else NT (N).Nkind = N_Use_Type_Clause); + return List2 (N); + end Subtype_Marks; + + function Synchronized_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Derived_Type_Definition + or else NT (N).Nkind = N_Formal_Derived_Type_Definition + or else NT (N).Nkind = N_Private_Extension_Declaration + or else NT (N).Nkind = N_Record_Definition); + return Flag7 (N); + end Synchronized_Present; + + function Tagged_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Formal_Private_Type_Definition + or else NT (N).Nkind = N_Incomplete_Type_Declaration + or else NT (N).Nkind = N_Private_Type_Declaration + or else NT (N).Nkind = N_Record_Definition); + return Flag15 (N); + end Tagged_Present; + + function Target_Type + (N : Node_Id) return Entity_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Validate_Unchecked_Conversion); + return Node2 (N); + end Target_Type; + + function Task_Definition + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Single_Task_Declaration + or else NT (N).Nkind = N_Task_Type_Declaration); + return Node3 (N); + end Task_Definition; + + function Task_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Derived_Type_Definition + or else NT (N).Nkind = N_Record_Definition); + return Flag5 (N); + end Task_Present; + + function Then_Actions + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Conditional_Expression); + return List2 (N); + end Then_Actions; + + function Then_Statements + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Elsif_Part + or else NT (N).Nkind = N_If_Statement); + return List2 (N); + end Then_Statements; + + function Treat_Fixed_As_Integer + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Op_Divide + or else NT (N).Nkind = N_Op_Mod + or else NT (N).Nkind = N_Op_Multiply + or else NT (N).Nkind = N_Op_Rem); + return Flag14 (N); + end Treat_Fixed_As_Integer; + + function Triggering_Alternative + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Asynchronous_Select); + return Node1 (N); + end Triggering_Alternative; + + function Triggering_Statement + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Triggering_Alternative); + return Node1 (N); + end Triggering_Statement; + + function TSS_Elist + (N : Node_Id) return Elist_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Freeze_Entity); + return Elist3 (N); + end TSS_Elist; + + function Type_Definition + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Full_Type_Declaration); + return Node3 (N); + end Type_Definition; + + function Unit + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit); + return Node2 (N); + end Unit; + + function Unknown_Discriminants_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Formal_Type_Declaration + or else NT (N).Nkind = N_Incomplete_Type_Declaration + or else NT (N).Nkind = N_Private_Extension_Declaration + or else NT (N).Nkind = N_Private_Type_Declaration); + return Flag13 (N); + end Unknown_Discriminants_Present; + + function Unreferenced_In_Spec + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + return Flag7 (N); + end Unreferenced_In_Spec; + + function Variant_Part + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_List); + return Node4 (N); + end Variant_Part; + + function Variants + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Variant_Part); + return List1 (N); + end Variants; + + function Visible_Declarations + (N : Node_Id) return List_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Package_Specification + or else NT (N).Nkind = N_Protected_Definition + or else NT (N).Nkind = N_Task_Definition); + return List2 (N); + end Visible_Declarations; + + function Was_Originally_Stub + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Package_Body + or else NT (N).Nkind = N_Protected_Body + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Task_Body); + return Flag13 (N); + end Was_Originally_Stub; + + function Withed_Body + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + return Node1 (N); + end Withed_Body; + + function Zero_Cost_Handling + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exception_Handler + or else NT (N).Nkind = N_Handled_Sequence_Of_Statements); + return Flag5 (N); + end Zero_Cost_Handling; + + -------------------------- + -- Field Set Procedures -- + -------------------------- + + procedure Set_ABE_Is_Certain + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Formal_Package_Declaration + or else NT (N).Nkind = N_Function_Call + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Package_Instantiation + or else NT (N).Nkind = N_Procedure_Call_Statement + or else NT (N).Nkind = N_Procedure_Instantiation); + Set_Flag18 (N, Val); + end Set_ABE_Is_Certain; + + procedure Set_Abort_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Requeue_Statement); + Set_Flag15 (N, Val); + end Set_Abort_Present; + + procedure Set_Abortable_Part + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Asynchronous_Select); + Set_Node2_With_Parent (N, Val); + end Set_Abortable_Part; + + procedure Set_Abstract_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Derived_Type_Definition + or else NT (N).Nkind = N_Formal_Derived_Type_Definition + or else NT (N).Nkind = N_Formal_Private_Type_Definition + or else NT (N).Nkind = N_Private_Extension_Declaration + or else NT (N).Nkind = N_Private_Type_Declaration + or else NT (N).Nkind = N_Record_Definition); + Set_Flag4 (N, Val); + end Set_Abstract_Present; + + procedure Set_Accept_Handler_Records + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Accept_Alternative); + Set_List5 (N, Val); -- semantic field, no parent set + end Set_Accept_Handler_Records; + + procedure Set_Accept_Statement + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Accept_Alternative); + Set_Node2_With_Parent (N, Val); + end Set_Accept_Statement; + + procedure Set_Access_Definition + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Definition + or else NT (N).Nkind = N_Formal_Object_Declaration + or else NT (N).Nkind = N_Object_Renaming_Declaration); + Set_Node3_With_Parent (N, Val); + end Set_Access_Definition; + + procedure Set_Access_To_Subprogram_Definition + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_Definition); + Set_Node3_With_Parent (N, Val); + end Set_Access_To_Subprogram_Definition; + + procedure Set_Access_Types_To_Process + (N : Node_Id; Val : Elist_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Freeze_Entity); + Set_Elist2 (N, Val); -- semantic field, no parent set + end Set_Access_Types_To_Process; + + procedure Set_Actions + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_And_Then + or else NT (N).Nkind = N_Case_Expression_Alternative + or else NT (N).Nkind = N_Compilation_Unit_Aux + or else NT (N).Nkind = N_Expression_With_Actions + or else NT (N).Nkind = N_Freeze_Entity + or else NT (N).Nkind = N_Or_Else); + Set_List1_With_Parent (N, Val); + end Set_Actions; + + procedure Set_Activation_Chain_Entity + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Block_Statement + or else NT (N).Nkind = N_Entry_Body + or else NT (N).Nkind = N_Generic_Package_Declaration + or else NT (N).Nkind = N_Package_Declaration + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Task_Body); + Set_Node3 (N, Val); -- semantic field, no parent set + end Set_Activation_Chain_Entity; + + procedure Set_Acts_As_Spec + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit + or else NT (N).Nkind = N_Subprogram_Body); + Set_Flag4 (N, Val); + end Set_Acts_As_Spec; + + procedure Set_Actual_Designated_Subtype + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Explicit_Dereference + or else NT (N).Nkind = N_Free_Statement); + Set_Node4 (N, Val); + end Set_Actual_Designated_Subtype; + + procedure Set_Address_Warning_Posted + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Definition_Clause); + Set_Flag18 (N, Val); + end Set_Address_Warning_Posted; + + procedure Set_Aggregate_Bounds + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aggregate); + Set_Node3 (N, Val); -- semantic field, no parent set + end Set_Aggregate_Bounds; + + procedure Set_Aliased_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Definition + or else NT (N).Nkind = N_Object_Declaration); + Set_Flag4 (N, Val); + end Set_Aliased_Present; + + procedure Set_All_Others + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Others_Choice); + Set_Flag11 (N, Val); + end Set_All_Others; + + procedure Set_All_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_Definition + or else NT (N).Nkind = N_Access_To_Object_Definition + or else NT (N).Nkind = N_Quantified_Expression + or else NT (N).Nkind = N_Use_Type_Clause); + Set_Flag15 (N, Val); + end Set_All_Present; + + procedure Set_Alternatives + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Case_Expression + or else NT (N).Nkind = N_Case_Statement + or else NT (N).Nkind = N_In + or else NT (N).Nkind = N_Not_In); + Set_List4_With_Parent (N, Val); + end Set_Alternatives; + + procedure Set_Ancestor_Part + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Extension_Aggregate); + Set_Node3_With_Parent (N, Val); + end Set_Ancestor_Part; + + procedure Set_Array_Aggregate + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Enumeration_Representation_Clause); + Set_Node3_With_Parent (N, Val); + end Set_Array_Aggregate; + + procedure Set_Aspect_Cancel + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + Set_Flag11 (N, Val); + end Set_Aspect_Cancel; + + procedure Set_Aspect_Rep_Item + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification); + Set_Node2 (N, Val); + end Set_Aspect_Rep_Item; + + procedure Set_Assignment_OK + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Object_Declaration + or else NT (N).Nkind in N_Subexpr); + Set_Flag15 (N, Val); + end Set_Assignment_OK; + + procedure Set_Associated_Node + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind in N_Has_Entity + or else NT (N).Nkind = N_Aggregate + or else NT (N).Nkind = N_Extension_Aggregate + or else NT (N).Nkind = N_Selected_Component); + Set_Node4 (N, Val); -- semantic field, no parent set + end Set_Associated_Node; + + procedure Set_At_End_Proc + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Handled_Sequence_Of_Statements); + Set_Node1 (N, Val); + end Set_At_End_Proc; + + procedure Set_Attribute_Name + (N : Node_Id; Val : Name_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Reference); + Set_Name2 (N, Val); + end Set_Attribute_Name; + + procedure Set_Aux_Decls_Node + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit); + Set_Node5_With_Parent (N, Val); + end Set_Aux_Decls_Node; + + procedure Set_Backwards_OK + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement); + Set_Flag6 (N, Val); + end Set_Backwards_OK; + + procedure Set_Bad_Is_Detected + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Body); + Set_Flag15 (N, Val); + end Set_Bad_Is_Detected; + + procedure Set_Body_Required + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit); + Set_Flag13 (N, Val); + end Set_Body_Required; + + procedure Set_Body_To_Inline + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Declaration); + Set_Node3 (N, Val); + end Set_Body_To_Inline; + + procedure Set_Box_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Association + or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration + or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration + or else NT (N).Nkind = N_Formal_Package_Declaration + or else NT (N).Nkind = N_Generic_Association); + Set_Flag15 (N, Val); + end Set_Box_Present; + + procedure Set_By_Ref + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Extended_Return_Statement + or else NT (N).Nkind = N_Return_Statement); + Set_Flag5 (N, Val); + end Set_By_Ref; + + procedure Set_Char_Literal_Value + (N : Node_Id; Val : Uint) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Character_Literal); + Set_Uint2 (N, Val); + end Set_Char_Literal_Value; + + procedure Set_Chars + (N : Node_Id; Val : Name_Id) is + begin + pragma Assert (False + or else NT (N).Nkind in N_Has_Chars); + Set_Name1 (N, Val); + end Set_Chars; + + procedure Set_Check_Address_Alignment + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Definition_Clause); + Set_Flag11 (N, Val); + end Set_Check_Address_Alignment; + + procedure Set_Choice_Parameter + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exception_Handler); + Set_Node2_With_Parent (N, Val); + end Set_Choice_Parameter; + + procedure Set_Choices + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Association); + Set_List1_With_Parent (N, Val); + end Set_Choices; + + procedure Set_Class_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_Pragma); + Set_Flag6 (N, Val); + end Set_Class_Present; + + procedure Set_Coextensions + (N : Node_Id; Val : Elist_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Allocator); + Set_Elist4 (N, Val); + end Set_Coextensions; + + procedure Set_Comes_From_Extended_Return_Statement + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Return_Statement); + Set_Flag18 (N, Val); + end Set_Comes_From_Extended_Return_Statement; + + procedure Set_Compile_Time_Known_Aggregate + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aggregate); + Set_Flag18 (N, Val); + end Set_Compile_Time_Known_Aggregate; + + procedure Set_Component_Associations + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aggregate + or else NT (N).Nkind = N_Extension_Aggregate); + Set_List2_With_Parent (N, Val); + end Set_Component_Associations; + + procedure Set_Component_Clauses + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Record_Representation_Clause); + Set_List3_With_Parent (N, Val); + end Set_Component_Clauses; + + procedure Set_Component_Definition + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Declaration + or else NT (N).Nkind = N_Constrained_Array_Definition + or else NT (N).Nkind = N_Unconstrained_Array_Definition); + Set_Node4_With_Parent (N, Val); + end Set_Component_Definition; + + procedure Set_Component_Items + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_List); + Set_List3_With_Parent (N, Val); + end Set_Component_Items; + + procedure Set_Component_List + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Record_Definition + or else NT (N).Nkind = N_Variant); + Set_Node1_With_Parent (N, Val); + end Set_Component_List; + + procedure Set_Component_Name + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Clause); + Set_Node1_With_Parent (N, Val); + end Set_Component_Name; + + procedure Set_Componentwise_Assignment + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement); + Set_Flag14 (N, Val); + end Set_Componentwise_Assignment; + + procedure Set_Condition + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Accept_Alternative + or else NT (N).Nkind = N_Delay_Alternative + or else NT (N).Nkind = N_Elsif_Part + or else NT (N).Nkind = N_Entry_Body_Formal_Part + or else NT (N).Nkind = N_Exit_Statement + or else NT (N).Nkind = N_If_Statement + or else NT (N).Nkind = N_Iteration_Scheme + or else NT (N).Nkind = N_Quantified_Expression + or else NT (N).Nkind = N_Raise_Constraint_Error + or else NT (N).Nkind = N_Raise_Program_Error + or else NT (N).Nkind = N_Raise_Storage_Error + or else NT (N).Nkind = N_Terminate_Alternative); + Set_Node1_With_Parent (N, Val); + end Set_Condition; + + procedure Set_Condition_Actions + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Elsif_Part + or else NT (N).Nkind = N_Iteration_Scheme); + Set_List3 (N, Val); -- semantic field, no parent set + end Set_Condition_Actions; + + procedure Set_Config_Pragmas + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit_Aux); + Set_List4_With_Parent (N, Val); + end Set_Config_Pragmas; + + procedure Set_Constant_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_Definition + or else NT (N).Nkind = N_Access_To_Object_Definition + or else NT (N).Nkind = N_Object_Declaration); + Set_Flag17 (N, Val); + end Set_Constant_Present; + + procedure Set_Constraint + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subtype_Indication); + Set_Node3_With_Parent (N, Val); + end Set_Constraint; + + procedure Set_Constraints + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Index_Or_Discriminant_Constraint); + Set_List1_With_Parent (N, Val); + end Set_Constraints; + + procedure Set_Context_Installed + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + Set_Flag13 (N, Val); + end Set_Context_Installed; + + procedure Set_Context_Items + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit); + Set_List1_With_Parent (N, Val); + end Set_Context_Items; + + procedure Set_Context_Pending + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit); + Set_Flag16 (N, Val); + end Set_Context_Pending; + + procedure Set_Controlling_Argument + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Function_Call + or else NT (N).Nkind = N_Procedure_Call_Statement); + Set_Node1 (N, Val); -- semantic field, no parent set + end Set_Controlling_Argument; + + procedure Set_Conversion_OK + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Type_Conversion); + Set_Flag14 (N, Val); + end Set_Conversion_OK; + + procedure Set_Corresponding_Body + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Entry_Declaration + or else NT (N).Nkind = N_Generic_Package_Declaration + or else NT (N).Nkind = N_Generic_Subprogram_Declaration + or else NT (N).Nkind = N_Package_Body_Stub + or else NT (N).Nkind = N_Package_Declaration + or else NT (N).Nkind = N_Protected_Body_Stub + or else NT (N).Nkind = N_Protected_Type_Declaration + or else NT (N).Nkind = N_Subprogram_Body_Stub + or else NT (N).Nkind = N_Subprogram_Declaration + or else NT (N).Nkind = N_Task_Body_Stub + or else NT (N).Nkind = N_Task_Type_Declaration); + Set_Node5 (N, Val); -- semantic field, no parent set + end Set_Corresponding_Body; + + procedure Set_Corresponding_Formal_Spec + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Renaming_Declaration); + Set_Node3 (N, Val); -- semantic field, no parent set + end Set_Corresponding_Formal_Spec; + + procedure Set_Corresponding_Generic_Association + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Object_Declaration + or else NT (N).Nkind = N_Object_Renaming_Declaration); + Set_Node5 (N, Val); -- semantic field, no parent set + end Set_Corresponding_Generic_Association; + + procedure Set_Corresponding_Integer_Value + (N : Node_Id; Val : Uint) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Real_Literal); + Set_Uint4 (N, Val); -- semantic field, no parent set + end Set_Corresponding_Integer_Value; + + procedure Set_Corresponding_Spec + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Package_Body + or else NT (N).Nkind = N_Protected_Body + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Subprogram_Renaming_Declaration + or else NT (N).Nkind = N_Task_Body + or else NT (N).Nkind = N_With_Clause); + Set_Node5 (N, Val); -- semantic field, no parent set + end Set_Corresponding_Spec; + + procedure Set_Corresponding_Stub + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subunit); + Set_Node3 (N, Val); + end Set_Corresponding_Stub; + + procedure Set_Dcheck_Function + (N : Node_Id; Val : Entity_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Variant); + Set_Node5 (N, Val); -- semantic field, no parent set + end Set_Dcheck_Function; + + procedure Set_Debug_Statement + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + Set_Node3_With_Parent (N, Val); + end Set_Debug_Statement; + + procedure Set_Declarations + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Accept_Statement + or else NT (N).Nkind = N_Block_Statement + or else NT (N).Nkind = N_Compilation_Unit_Aux + or else NT (N).Nkind = N_Entry_Body + or else NT (N).Nkind = N_Package_Body + or else NT (N).Nkind = N_Protected_Body + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Task_Body); + Set_List2_With_Parent (N, Val); + end Set_Declarations; + + procedure Set_Default_Expression + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Formal_Object_Declaration + or else NT (N).Nkind = N_Parameter_Specification); + Set_Node5 (N, Val); -- semantic field, no parent set + end Set_Default_Expression; + + procedure Set_Default_Storage_Pool + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit_Aux); + Set_Node3 (N, Val); -- semantic field, no parent set + end Set_Default_Storage_Pool; + + procedure Set_Default_Name + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration + or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration); + Set_Node2_With_Parent (N, Val); + end Set_Default_Name; + + procedure Set_Defining_Identifier + (N : Node_Id; Val : Entity_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Declaration + or else NT (N).Nkind = N_Defining_Program_Unit_Name + or else NT (N).Nkind = N_Discriminant_Specification + or else NT (N).Nkind = N_Entry_Body + or else NT (N).Nkind = N_Entry_Declaration + or else NT (N).Nkind = N_Entry_Index_Specification + or else NT (N).Nkind = N_Exception_Declaration + or else NT (N).Nkind = N_Exception_Renaming_Declaration + or else NT (N).Nkind = N_Formal_Object_Declaration + or else NT (N).Nkind = N_Formal_Package_Declaration + or else NT (N).Nkind = N_Formal_Type_Declaration + or else NT (N).Nkind = N_Full_Type_Declaration + or else NT (N).Nkind = N_Implicit_Label_Declaration + or else NT (N).Nkind = N_Incomplete_Type_Declaration + or else NT (N).Nkind = N_Iterator_Specification + or else NT (N).Nkind = N_Loop_Parameter_Specification + or else NT (N).Nkind = N_Number_Declaration + or else NT (N).Nkind = N_Object_Declaration + or else NT (N).Nkind = N_Object_Renaming_Declaration + or else NT (N).Nkind = N_Package_Body_Stub + or else NT (N).Nkind = N_Parameter_Specification + or else NT (N).Nkind = N_Private_Extension_Declaration + or else NT (N).Nkind = N_Private_Type_Declaration + or else NT (N).Nkind = N_Protected_Body + or else NT (N).Nkind = N_Protected_Body_Stub + or else NT (N).Nkind = N_Protected_Type_Declaration + or else NT (N).Nkind = N_Single_Protected_Declaration + or else NT (N).Nkind = N_Single_Task_Declaration + or else NT (N).Nkind = N_Subtype_Declaration + or else NT (N).Nkind = N_Task_Body + or else NT (N).Nkind = N_Task_Body_Stub + or else NT (N).Nkind = N_Task_Type_Declaration); + Set_Node1_With_Parent (N, Val); + end Set_Defining_Identifier; + + procedure Set_Defining_Unit_Name + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Function_Specification + or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration + or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration + or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration + or else NT (N).Nkind = N_Package_Body + or else NT (N).Nkind = N_Package_Instantiation + or else NT (N).Nkind = N_Package_Renaming_Declaration + or else NT (N).Nkind = N_Package_Specification + or else NT (N).Nkind = N_Procedure_Instantiation + or else NT (N).Nkind = N_Procedure_Specification); + Set_Node1_With_Parent (N, Val); + end Set_Defining_Unit_Name; + + procedure Set_Delay_Alternative + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Timed_Entry_Call); + Set_Node4_With_Parent (N, Val); + end Set_Delay_Alternative; + + procedure Set_Delay_Statement + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Delay_Alternative); + Set_Node2_With_Parent (N, Val); + end Set_Delay_Statement; + + procedure Set_Delta_Expression + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition + or else NT (N).Nkind = N_Delta_Constraint + or else NT (N).Nkind = N_Ordinary_Fixed_Point_Definition); + Set_Node3_With_Parent (N, Val); + end Set_Delta_Expression; + + procedure Set_Digits_Expression + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition + or else NT (N).Nkind = N_Digits_Constraint + or else NT (N).Nkind = N_Floating_Point_Definition); + Set_Node2_With_Parent (N, Val); + end Set_Digits_Expression; + + procedure Set_Discr_Check_Funcs_Built + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Full_Type_Declaration); + Set_Flag11 (N, Val); + end Set_Discr_Check_Funcs_Built; + + procedure Set_Discrete_Choices + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Case_Expression_Alternative + or else NT (N).Nkind = N_Case_Statement_Alternative + or else NT (N).Nkind = N_Variant); + Set_List4_With_Parent (N, Val); + end Set_Discrete_Choices; + + procedure Set_Discrete_Range + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Slice); + Set_Node4_With_Parent (N, Val); + end Set_Discrete_Range; + + procedure Set_Discrete_Subtype_Definition + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Entry_Declaration + or else NT (N).Nkind = N_Entry_Index_Specification + or else NT (N).Nkind = N_Loop_Parameter_Specification); + Set_Node4_With_Parent (N, Val); + end Set_Discrete_Subtype_Definition; + + procedure Set_Discrete_Subtype_Definitions + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Constrained_Array_Definition); + Set_List2_With_Parent (N, Val); + end Set_Discrete_Subtype_Definitions; + + procedure Set_Discriminant_Specifications + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Formal_Type_Declaration + or else NT (N).Nkind = N_Full_Type_Declaration + or else NT (N).Nkind = N_Incomplete_Type_Declaration + or else NT (N).Nkind = N_Private_Extension_Declaration + or else NT (N).Nkind = N_Private_Type_Declaration + or else NT (N).Nkind = N_Protected_Type_Declaration + or else NT (N).Nkind = N_Task_Type_Declaration); + Set_List4_With_Parent (N, Val); + end Set_Discriminant_Specifications; + + procedure Set_Discriminant_Type + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Discriminant_Specification); + Set_Node5_With_Parent (N, Val); + end Set_Discriminant_Type; + + procedure Set_Do_Accessibility_Check + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Parameter_Specification); + Set_Flag13 (N, Val); + end Set_Do_Accessibility_Check; + + procedure Set_Do_Discriminant_Check + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Selected_Component); + Set_Flag13 (N, Val); + end Set_Do_Discriminant_Check; + + procedure Set_Do_Division_Check + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Op_Divide + or else NT (N).Nkind = N_Op_Mod + or else NT (N).Nkind = N_Op_Rem); + Set_Flag13 (N, Val); + end Set_Do_Division_Check; + + procedure Set_Do_Length_Check + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement + or else NT (N).Nkind = N_Op_And + or else NT (N).Nkind = N_Op_Or + or else NT (N).Nkind = N_Op_Xor + or else NT (N).Nkind = N_Type_Conversion); + Set_Flag4 (N, Val); + end Set_Do_Length_Check; + + procedure Set_Do_Overflow_Check + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind in N_Op + or else NT (N).Nkind = N_Attribute_Reference + or else NT (N).Nkind = N_Type_Conversion); + Set_Flag17 (N, Val); + end Set_Do_Overflow_Check; + + procedure Set_Do_Range_Check + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind in N_Subexpr); + Set_Flag9 (N, Val); + end Set_Do_Range_Check; + + procedure Set_Do_Storage_Check + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Allocator + or else NT (N).Nkind = N_Subprogram_Body); + Set_Flag17 (N, Val); + end Set_Do_Storage_Check; + + procedure Set_Do_Tag_Check + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement + or else NT (N).Nkind = N_Extended_Return_Statement + or else NT (N).Nkind = N_Function_Call + or else NT (N).Nkind = N_Procedure_Call_Statement + or else NT (N).Nkind = N_Return_Statement + or else NT (N).Nkind = N_Type_Conversion); + Set_Flag13 (N, Val); + end Set_Do_Tag_Check; + + procedure Set_Elaborate_All_Desirable + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + Set_Flag9 (N, Val); + end Set_Elaborate_All_Desirable; + + procedure Set_Elaborate_All_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + Set_Flag14 (N, Val); + end Set_Elaborate_All_Present; + + procedure Set_Elaborate_Desirable + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + Set_Flag11 (N, Val); + end Set_Elaborate_Desirable; + + procedure Set_Elaborate_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + Set_Flag4 (N, Val); + end Set_Elaborate_Present; + + procedure Set_Elaboration_Boolean + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Function_Specification + or else NT (N).Nkind = N_Procedure_Specification); + Set_Node2 (N, Val); + end Set_Elaboration_Boolean; + + procedure Set_Else_Actions + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Conditional_Expression); + Set_List3 (N, Val); -- semantic field, no parent set + end Set_Else_Actions; + + procedure Set_Else_Statements + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Conditional_Entry_Call + or else NT (N).Nkind = N_If_Statement + or else NT (N).Nkind = N_Selective_Accept); + Set_List4_With_Parent (N, Val); + end Set_Else_Statements; + + procedure Set_Elsif_Parts + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_If_Statement); + Set_List3_With_Parent (N, Val); + end Set_Elsif_Parts; + + procedure Set_Enclosing_Variant + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Variant); + Set_Node2 (N, Val); -- semantic field, no parent set + end Set_Enclosing_Variant; + + procedure Set_End_Label + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Enumeration_Type_Definition + or else NT (N).Nkind = N_Handled_Sequence_Of_Statements + or else NT (N).Nkind = N_Loop_Statement + or else NT (N).Nkind = N_Package_Specification + or else NT (N).Nkind = N_Protected_Body + or else NT (N).Nkind = N_Protected_Definition + or else NT (N).Nkind = N_Record_Definition + or else NT (N).Nkind = N_Task_Definition); + Set_Node4_With_Parent (N, Val); + end Set_End_Label; + + procedure Set_End_Span + (N : Node_Id; Val : Uint) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Case_Statement + or else NT (N).Nkind = N_If_Statement); + Set_Uint5 (N, Val); + end Set_End_Span; + + procedure Set_Entity + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind in N_Has_Entity + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Freeze_Entity); + Set_Node4 (N, Val); -- semantic field, no parent set + end Set_Entity; + + procedure Set_Entry_Body_Formal_Part + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Entry_Body); + Set_Node5_With_Parent (N, Val); + end Set_Entry_Body_Formal_Part; + + procedure Set_Entry_Call_Alternative + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Conditional_Entry_Call + or else NT (N).Nkind = N_Timed_Entry_Call); + Set_Node1_With_Parent (N, Val); + end Set_Entry_Call_Alternative; + + procedure Set_Entry_Call_Statement + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Entry_Call_Alternative); + Set_Node1_With_Parent (N, Val); + end Set_Entry_Call_Statement; + + procedure Set_Entry_Direct_Name + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Accept_Statement); + Set_Node1_With_Parent (N, Val); + end Set_Entry_Direct_Name; + + procedure Set_Entry_Index + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Accept_Statement); + Set_Node5_With_Parent (N, Val); + end Set_Entry_Index; + + procedure Set_Entry_Index_Specification + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Entry_Body_Formal_Part); + Set_Node4_With_Parent (N, Val); + end Set_Entry_Index_Specification; + + procedure Set_Etype + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind in N_Has_Etype); + Set_Node5 (N, Val); -- semantic field, no parent set + end Set_Etype; + + procedure Set_Exception_Choices + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exception_Handler); + Set_List4_With_Parent (N, Val); + end Set_Exception_Choices; + + procedure Set_Exception_Handlers + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Handled_Sequence_Of_Statements); + Set_List5_With_Parent (N, Val); + end Set_Exception_Handlers; + + procedure Set_Exception_Junk + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Block_Statement + or else NT (N).Nkind = N_Goto_Statement + or else NT (N).Nkind = N_Label + or else NT (N).Nkind = N_Object_Declaration + or else NT (N).Nkind = N_Subtype_Declaration); + Set_Flag8 (N, Val); + end Set_Exception_Junk; + + procedure Set_Exception_Label + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exception_Handler + or else NT (N).Nkind = N_Push_Constraint_Error_Label + or else NT (N).Nkind = N_Push_Program_Error_Label + or else NT (N).Nkind = N_Push_Storage_Error_Label); + Set_Node5 (N, Val); -- semantic field, no parent set + end Set_Exception_Label; + + procedure Set_Expansion_Delayed + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aggregate + or else NT (N).Nkind = N_Extension_Aggregate); + Set_Flag11 (N, Val); + end Set_Expansion_Delayed; + + procedure Set_Explicit_Actual_Parameter + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Parameter_Association); + Set_Node3_With_Parent (N, Val); + end Set_Explicit_Actual_Parameter; + + procedure Set_Explicit_Generic_Actual_Parameter + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Generic_Association); + Set_Node1_With_Parent (N, Val); + end Set_Explicit_Generic_Actual_Parameter; + + procedure Set_Expression + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Allocator + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_Assignment_Statement + or else NT (N).Nkind = N_At_Clause + or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Case_Expression + or else NT (N).Nkind = N_Case_Expression_Alternative + or else NT (N).Nkind = N_Case_Statement + or else NT (N).Nkind = N_Code_Statement + or else NT (N).Nkind = N_Component_Association + or else NT (N).Nkind = N_Component_Declaration + or else NT (N).Nkind = N_Delay_Relative_Statement + or else NT (N).Nkind = N_Delay_Until_Statement + or else NT (N).Nkind = N_Discriminant_Association + or else NT (N).Nkind = N_Discriminant_Specification + or else NT (N).Nkind = N_Exception_Declaration + or else NT (N).Nkind = N_Expression_With_Actions + or else NT (N).Nkind = N_Free_Statement + or else NT (N).Nkind = N_Mod_Clause + or else NT (N).Nkind = N_Modular_Type_Definition + or else NT (N).Nkind = N_Number_Declaration + or else NT (N).Nkind = N_Object_Declaration + or else NT (N).Nkind = N_Parameter_Specification + or else NT (N).Nkind = N_Parameterized_Expression + or else NT (N).Nkind = N_Pragma_Argument_Association + or else NT (N).Nkind = N_Qualified_Expression + or else NT (N).Nkind = N_Raise_Statement + or else NT (N).Nkind = N_Return_Statement + or else NT (N).Nkind = N_Type_Conversion + or else NT (N).Nkind = N_Unchecked_Expression + or else NT (N).Nkind = N_Unchecked_Type_Conversion); + Set_Node3_With_Parent (N, Val); + end Set_Expression; + + procedure Set_Expressions + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aggregate + or else NT (N).Nkind = N_Attribute_Reference + or else NT (N).Nkind = N_Conditional_Expression + or else NT (N).Nkind = N_Extension_Aggregate + or else NT (N).Nkind = N_Indexed_Component); + Set_List1_With_Parent (N, Val); + end Set_Expressions; + + procedure Set_First_Bit + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Clause); + Set_Node3_With_Parent (N, Val); + end Set_First_Bit; + + procedure Set_First_Inlined_Subprogram + (N : Node_Id; Val : Entity_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit); + Set_Node3 (N, Val); -- semantic field, no parent set + end Set_First_Inlined_Subprogram; + + procedure Set_First_Name + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + Set_Flag5 (N, Val); + end Set_First_Name; + + procedure Set_First_Named_Actual + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Entry_Call_Statement + or else NT (N).Nkind = N_Function_Call + or else NT (N).Nkind = N_Procedure_Call_Statement); + Set_Node4 (N, Val); -- semantic field, no parent set + end Set_First_Named_Actual; + + procedure Set_First_Real_Statement + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Handled_Sequence_Of_Statements); + Set_Node2 (N, Val); -- semantic field, no parent set + end Set_First_Real_Statement; + + procedure Set_First_Subtype_Link + (N : Node_Id; Val : Entity_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Freeze_Entity); + Set_Node5 (N, Val); -- semantic field, no parent set + end Set_First_Subtype_Link; + + procedure Set_Float_Truncate + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Type_Conversion); + Set_Flag11 (N, Val); + end Set_Float_Truncate; + + procedure Set_Formal_Type_Definition + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Formal_Type_Declaration); + Set_Node3_With_Parent (N, Val); + end Set_Formal_Type_Definition; + + procedure Set_Forwards_OK + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement); + Set_Flag5 (N, Val); + end Set_Forwards_OK; + + procedure Set_From_Aspect_Specification + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Pragma); + Set_Flag13 (N, Val); + end Set_From_Aspect_Specification; + + procedure Set_From_At_End + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Raise_Statement); + Set_Flag4 (N, Val); + end Set_From_At_End; + + procedure Set_From_At_Mod + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Definition_Clause); + Set_Flag4 (N, Val); + end Set_From_At_Mod; + + procedure Set_From_Default + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Renaming_Declaration); + Set_Flag6 (N, Val); + end Set_From_Default; + + procedure Set_Generic_Associations + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Formal_Package_Declaration + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Package_Instantiation + or else NT (N).Nkind = N_Procedure_Instantiation); + Set_List3_With_Parent (N, Val); + end Set_Generic_Associations; + + procedure Set_Generic_Formal_Declarations + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Generic_Package_Declaration + or else NT (N).Nkind = N_Generic_Subprogram_Declaration); + Set_List2_With_Parent (N, Val); + end Set_Generic_Formal_Declarations; + + procedure Set_Generic_Parent + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Function_Specification + or else NT (N).Nkind = N_Package_Specification + or else NT (N).Nkind = N_Procedure_Specification); + Set_Node5 (N, Val); + end Set_Generic_Parent; + + procedure Set_Generic_Parent_Type + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subtype_Declaration); + Set_Node4 (N, Val); + end Set_Generic_Parent_Type; + + procedure Set_Handled_Statement_Sequence + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Accept_Statement + or else NT (N).Nkind = N_Block_Statement + or else NT (N).Nkind = N_Entry_Body + or else NT (N).Nkind = N_Extended_Return_Statement + or else NT (N).Nkind = N_Package_Body + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Task_Body); + Set_Node4_With_Parent (N, Val); + end Set_Handled_Statement_Sequence; + + procedure Set_Handler_List_Entry + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Object_Declaration); + Set_Node2 (N, Val); + end Set_Handler_List_Entry; + + procedure Set_Has_Created_Identifier + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Block_Statement + or else NT (N).Nkind = N_Loop_Statement); + Set_Flag15 (N, Val); + end Set_Has_Created_Identifier; + + procedure Set_Has_Dynamic_Length_Check + (N : Node_Id; Val : Boolean := True) is + begin + Set_Flag10 (N, Val); + end Set_Has_Dynamic_Length_Check; + + procedure Set_Has_Dynamic_Range_Check + (N : Node_Id; Val : Boolean := True) is + begin + Set_Flag12 (N, Val); + end Set_Has_Dynamic_Range_Check; + + procedure Set_Has_Init_Expression + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Object_Declaration); + Set_Flag14 (N, Val); + end Set_Has_Init_Expression; + + procedure Set_Has_Local_Raise + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exception_Handler); + Set_Flag8 (N, Val); + end Set_Has_Local_Raise; + + procedure Set_Has_No_Elaboration_Code + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit); + Set_Flag17 (N, Val); + end Set_Has_No_Elaboration_Code; + + procedure Set_Has_Pragma_CPU + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Task_Definition); + Set_Flag14 (N, Val); + end Set_Has_Pragma_CPU; + + procedure Set_Has_Pragma_Priority + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Protected_Definition + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Task_Definition); + Set_Flag6 (N, Val); + end Set_Has_Pragma_Priority; + + procedure Set_Has_Pragma_Suppress_All + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit); + Set_Flag14 (N, Val); + end Set_Has_Pragma_Suppress_All; + + procedure Set_Has_Private_View + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind in N_Op + or else NT (N).Nkind = N_Character_Literal + or else NT (N).Nkind = N_Expanded_Name + or else NT (N).Nkind = N_Identifier + or else NT (N).Nkind = N_Operator_Symbol); + Set_Flag11 (N, Val); + end Set_Has_Private_View; + + procedure Set_Has_Relative_Deadline_Pragma + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Task_Definition); + Set_Flag9 (N, Val); + end Set_Has_Relative_Deadline_Pragma; + + procedure Set_Has_Self_Reference + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aggregate + or else NT (N).Nkind = N_Extension_Aggregate); + Set_Flag13 (N, Val); + end Set_Has_Self_Reference; + + procedure Set_Has_Storage_Size_Pragma + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Task_Definition); + Set_Flag5 (N, Val); + end Set_Has_Storage_Size_Pragma; + + procedure Set_Has_Task_Info_Pragma + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Task_Definition); + Set_Flag7 (N, Val); + end Set_Has_Task_Info_Pragma; + + procedure Set_Has_Task_Name_Pragma + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Task_Definition); + Set_Flag8 (N, Val); + end Set_Has_Task_Name_Pragma; + + procedure Set_Has_Wide_Character + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_String_Literal); + Set_Flag11 (N, Val); + end Set_Has_Wide_Character; + + procedure Set_Has_Wide_Wide_Character + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_String_Literal); + Set_Flag13 (N, Val); + end Set_Has_Wide_Wide_Character; + + procedure Set_Hidden_By_Use_Clause + (N : Node_Id; Val : Elist_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Use_Package_Clause + or else NT (N).Nkind = N_Use_Type_Clause); + Set_Elist4 (N, Val); + end Set_Hidden_By_Use_Clause; + + procedure Set_High_Bound + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Range + or else NT (N).Nkind = N_Real_Range_Specification + or else NT (N).Nkind = N_Signed_Integer_Type_Definition); + Set_Node2_With_Parent (N, Val); + end Set_High_Bound; + + procedure Set_Identifier + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_At_Clause + or else NT (N).Nkind = N_Block_Statement + or else NT (N).Nkind = N_Designator + or else NT (N).Nkind = N_Enumeration_Representation_Clause + or else NT (N).Nkind = N_Label + or else NT (N).Nkind = N_Loop_Statement + or else NT (N).Nkind = N_Record_Representation_Clause + or else NT (N).Nkind = N_Subprogram_Info); + Set_Node1_With_Parent (N, Val); + end Set_Identifier; + + procedure Set_Implicit_With + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + Set_Flag16 (N, Val); + end Set_Implicit_With; + + procedure Set_Interface_List + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Derived_Type_Definition + or else NT (N).Nkind = N_Formal_Derived_Type_Definition + or else NT (N).Nkind = N_Private_Extension_Declaration + or else NT (N).Nkind = N_Protected_Type_Declaration + or else NT (N).Nkind = N_Record_Definition + or else NT (N).Nkind = N_Single_Protected_Declaration + or else NT (N).Nkind = N_Single_Task_Declaration + or else NT (N).Nkind = N_Task_Type_Declaration); + Set_List2_With_Parent (N, Val); + end Set_Interface_List; + + procedure Set_Interface_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Derived_Type_Definition + or else NT (N).Nkind = N_Record_Definition); + Set_Flag16 (N, Val); + end Set_Interface_Present; + + procedure Set_Import_Interface_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + Set_Flag16 (N, Val); + end Set_Import_Interface_Present; + + procedure Set_In_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Formal_Object_Declaration + or else NT (N).Nkind = N_Parameter_Specification); + Set_Flag15 (N, Val); + end Set_In_Present; + + procedure Set_Includes_Infinities + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Range); + Set_Flag11 (N, Val); + end Set_Includes_Infinities; + + procedure Set_Inherited_Discriminant + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Association); + Set_Flag13 (N, Val); + end Set_Inherited_Discriminant; + + procedure Set_Instance_Spec + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Formal_Package_Declaration + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Package_Instantiation + or else NT (N).Nkind = N_Procedure_Instantiation); + Set_Node5 (N, Val); -- semantic field, no Parent set + end Set_Instance_Spec; + + procedure Set_Intval + (N : Node_Id; Val : Uint) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Integer_Literal); + Set_Uint3 (N, Val); + end Set_Intval; + + procedure Set_Is_Accessibility_Actual + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Parameter_Association); + Set_Flag13 (N, Val); + end Set_Is_Accessibility_Actual; + + procedure Set_Is_Asynchronous_Call_Block + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Block_Statement); + Set_Flag7 (N, Val); + end Set_Is_Asynchronous_Call_Block; + + procedure Set_Is_Component_Left_Opnd + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Op_Concat); + Set_Flag13 (N, Val); + end Set_Is_Component_Left_Opnd; + + procedure Set_Is_Component_Right_Opnd + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Op_Concat); + Set_Flag14 (N, Val); + end Set_Is_Component_Right_Opnd; + + procedure Set_Is_Controlling_Actual + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind in N_Subexpr); + Set_Flag16 (N, Val); + end Set_Is_Controlling_Actual; + + procedure Set_Is_Delayed_Aspect + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Pragma); + Set_Flag14 (N, Val); + end Set_Is_Delayed_Aspect; + + procedure Set_Is_Dynamic_Coextension + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Allocator); + Set_Flag18 (N, Val); + end Set_Is_Dynamic_Coextension; + + procedure Set_Is_Elsif + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Conditional_Expression); + Set_Flag13 (N, Val); + end Set_Is_Elsif; + + procedure Set_Is_Entry_Barrier_Function + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Body); + Set_Flag8 (N, Val); + end Set_Is_Entry_Barrier_Function; + + procedure Set_Is_Expanded_Build_In_Place_Call + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Function_Call); + Set_Flag11 (N, Val); + end Set_Is_Expanded_Build_In_Place_Call; + + procedure Set_Is_Folded_In_Parser + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_String_Literal); + Set_Flag4 (N, Val); + end Set_Is_Folded_In_Parser; + + procedure Set_Is_In_Discriminant_Check + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Selected_Component); + Set_Flag11 (N, Val); + end Set_Is_In_Discriminant_Check; + + procedure Set_Is_Machine_Number + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Real_Literal); + Set_Flag11 (N, Val); + end Set_Is_Machine_Number; + + procedure Set_Is_Null_Loop + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Loop_Statement); + Set_Flag16 (N, Val); + end Set_Is_Null_Loop; + + procedure Set_Is_Overloaded + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind in N_Subexpr); + Set_Flag5 (N, Val); + end Set_Is_Overloaded; + + procedure Set_Is_Power_Of_2_For_Shift + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Op_Expon); + Set_Flag13 (N, Val); + end Set_Is_Power_Of_2_For_Shift; + + procedure Set_Is_Protected_Subprogram_Body + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Body); + Set_Flag7 (N, Val); + end Set_Is_Protected_Subprogram_Body; + + procedure Set_Is_Static_Coextension + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Allocator); + Set_Flag14 (N, Val); + end Set_Is_Static_Coextension; + + procedure Set_Is_Static_Expression + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind in N_Subexpr); + Set_Flag6 (N, Val); + end Set_Is_Static_Expression; + + procedure Set_Is_Subprogram_Descriptor + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Object_Declaration); + Set_Flag16 (N, Val); + end Set_Is_Subprogram_Descriptor; + + procedure Set_Is_Task_Allocation_Block + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Block_Statement); + Set_Flag6 (N, Val); + end Set_Is_Task_Allocation_Block; + + procedure Set_Is_Task_Master + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Block_Statement + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Task_Body); + Set_Flag5 (N, Val); + end Set_Is_Task_Master; + + procedure Set_Iteration_Scheme + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Loop_Statement); + Set_Node2_With_Parent (N, Val); + end Set_Iteration_Scheme; + + procedure Set_Iterator_Specification + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Iteration_Scheme + or else NT (N).Nkind = N_Quantified_Expression); + Set_Node2_With_Parent (N, Val); + end Set_Iterator_Specification; + + procedure Set_Itype + (N : Node_Id; Val : Entity_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Itype_Reference); + Set_Node1 (N, Val); -- no parent, semantic field + end Set_Itype; + + procedure Set_Kill_Range_Check + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Unchecked_Type_Conversion); + Set_Flag11 (N, Val); + end Set_Kill_Range_Check; + + procedure Set_Label_Construct + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Implicit_Label_Declaration); + Set_Node2 (N, Val); -- semantic field, no parent set + end Set_Label_Construct; + + procedure Set_Last_Bit + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Clause); + Set_Node4_With_Parent (N, Val); + end Set_Last_Bit; + + procedure Set_Last_Name + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + Set_Flag6 (N, Val); + end Set_Last_Name; + + procedure Set_Left_Opnd + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_And_Then + or else NT (N).Nkind = N_In + or else NT (N).Nkind = N_Not_In + or else NT (N).Nkind = N_Or_Else + or else NT (N).Nkind in N_Binary_Op); + Set_Node2_With_Parent (N, Val); + end Set_Left_Opnd; + + procedure Set_Library_Unit + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit + or else NT (N).Nkind = N_Package_Body_Stub + or else NT (N).Nkind = N_Protected_Body_Stub + or else NT (N).Nkind = N_Subprogram_Body_Stub + or else NT (N).Nkind = N_Task_Body_Stub + or else NT (N).Nkind = N_With_Clause); + Set_Node4 (N, Val); -- semantic field, no parent set + end Set_Library_Unit; + + procedure Set_Limited_View_Installed + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Package_Specification + or else NT (N).Nkind = N_With_Clause); + Set_Flag18 (N, Val); + end Set_Limited_View_Installed; + + procedure Set_Limited_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Derived_Type_Definition + or else NT (N).Nkind = N_Formal_Derived_Type_Definition + or else NT (N).Nkind = N_Formal_Private_Type_Definition + or else NT (N).Nkind = N_Private_Extension_Declaration + or else NT (N).Nkind = N_Private_Type_Declaration + or else NT (N).Nkind = N_Record_Definition + or else NT (N).Nkind = N_With_Clause); + Set_Flag17 (N, Val); + end Set_Limited_Present; + + procedure Set_Literals + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Enumeration_Type_Definition); + Set_List1_With_Parent (N, Val); + end Set_Literals; + + procedure Set_Local_Raise_Not_OK + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exception_Handler); + Set_Flag7 (N, Val); + end Set_Local_Raise_Not_OK; + + procedure Set_Local_Raise_Statements + (N : Node_Id; Val : Elist_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exception_Handler); + Set_Elist1 (N, Val); + end Set_Local_Raise_Statements; + + procedure Set_Loop_Actions + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Association); + Set_List2 (N, Val); -- semantic field, no parent set + end Set_Loop_Actions; + + procedure Set_Loop_Parameter_Specification + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Iteration_Scheme + or else NT (N).Nkind = N_Quantified_Expression); + Set_Node4_With_Parent (N, Val); + end Set_Loop_Parameter_Specification; + + procedure Set_Low_Bound + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Range + or else NT (N).Nkind = N_Real_Range_Specification + or else NT (N).Nkind = N_Signed_Integer_Type_Definition); + Set_Node1_With_Parent (N, Val); + end Set_Low_Bound; + + procedure Set_Mod_Clause + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Record_Representation_Clause); + Set_Node2_With_Parent (N, Val); + end Set_Mod_Clause; + + procedure Set_More_Ids + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Declaration + or else NT (N).Nkind = N_Discriminant_Specification + or else NT (N).Nkind = N_Exception_Declaration + or else NT (N).Nkind = N_Formal_Object_Declaration + or else NT (N).Nkind = N_Number_Declaration + or else NT (N).Nkind = N_Object_Declaration + or else NT (N).Nkind = N_Parameter_Specification); + Set_Flag5 (N, Val); + end Set_More_Ids; + + procedure Set_Must_Be_Byte_Aligned + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Reference); + Set_Flag14 (N, Val); + end Set_Must_Be_Byte_Aligned; + + procedure Set_Must_Not_Freeze + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subtype_Indication + or else NT (N).Nkind in N_Subexpr); + Set_Flag8 (N, Val); + end Set_Must_Not_Freeze; + + procedure Set_Must_Not_Override + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Entry_Declaration + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Function_Specification + or else NT (N).Nkind = N_Procedure_Instantiation + or else NT (N).Nkind = N_Procedure_Specification); + Set_Flag15 (N, Val); + end Set_Must_Not_Override; + + procedure Set_Must_Override + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Entry_Declaration + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Function_Specification + or else NT (N).Nkind = N_Procedure_Instantiation + or else NT (N).Nkind = N_Procedure_Specification); + Set_Flag14 (N, Val); + end Set_Must_Override; + + procedure Set_Name + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement + or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Defining_Program_Unit_Name + or else NT (N).Nkind = N_Designator + or else NT (N).Nkind = N_Entry_Call_Statement + or else NT (N).Nkind = N_Exception_Renaming_Declaration + or else NT (N).Nkind = N_Exit_Statement + or else NT (N).Nkind = N_Formal_Package_Declaration + or else NT (N).Nkind = N_Function_Call + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration + or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration + or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration + or else NT (N).Nkind = N_Goto_Statement + or else NT (N).Nkind = N_Iterator_Specification + or else NT (N).Nkind = N_Object_Renaming_Declaration + or else NT (N).Nkind = N_Package_Instantiation + or else NT (N).Nkind = N_Package_Renaming_Declaration + or else NT (N).Nkind = N_Procedure_Call_Statement + or else NT (N).Nkind = N_Procedure_Instantiation + or else NT (N).Nkind = N_Raise_Statement + or else NT (N).Nkind = N_Requeue_Statement + or else NT (N).Nkind = N_Subprogram_Renaming_Declaration + or else NT (N).Nkind = N_Subunit + or else NT (N).Nkind = N_Variant_Part + or else NT (N).Nkind = N_With_Clause); + Set_Node2_With_Parent (N, Val); + end Set_Name; + + procedure Set_Names + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Abort_Statement + or else NT (N).Nkind = N_Use_Package_Clause); + Set_List2_With_Parent (N, Val); + end Set_Names; + + procedure Set_Next_Entity + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Defining_Character_Literal + or else NT (N).Nkind = N_Defining_Identifier + or else NT (N).Nkind = N_Defining_Operator_Symbol); + Set_Node2 (N, Val); -- semantic field, no parent set + end Set_Next_Entity; + + procedure Set_Next_Exit_Statement + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exit_Statement); + Set_Node3 (N, Val); -- semantic field, no parent set + end Set_Next_Exit_Statement; + + procedure Set_Next_Implicit_With + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + Set_Node3 (N, Val); -- semantic field, no parent set + end Set_Next_Implicit_With; + + procedure Set_Next_Named_Actual + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Parameter_Association); + Set_Node4 (N, Val); -- semantic field, no parent set + end Set_Next_Named_Actual; + + procedure Set_Next_Pragma + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + Set_Node1 (N, Val); -- semantic field, no parent set + end Set_Next_Pragma; + + procedure Set_Next_Rep_Item + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Enumeration_Representation_Clause + or else NT (N).Nkind = N_Pragma + or else NT (N).Nkind = N_Record_Representation_Clause); + Set_Node5 (N, Val); -- semantic field, no parent set + end Set_Next_Rep_Item; + + procedure Set_Next_Use_Clause + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Use_Package_Clause + or else NT (N).Nkind = N_Use_Type_Clause); + Set_Node3 (N, Val); -- semantic field, no parent set + end Set_Next_Use_Clause; + + procedure Set_No_Ctrl_Actions + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement); + Set_Flag7 (N, Val); + end Set_No_Ctrl_Actions; + + procedure Set_No_Elaboration_Check + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Function_Call + or else NT (N).Nkind = N_Procedure_Call_Statement); + Set_Flag14 (N, Val); + end Set_No_Elaboration_Check; + + procedure Set_No_Entities_Ref_In_Spec + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + Set_Flag8 (N, Val); + end Set_No_Entities_Ref_In_Spec; + + procedure Set_No_Initialization + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Allocator + or else NT (N).Nkind = N_Object_Declaration); + Set_Flag13 (N, Val); + end Set_No_Initialization; + + procedure Set_No_Truncation + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Unchecked_Type_Conversion); + Set_Flag17 (N, Val); + end Set_No_Truncation; + + procedure Set_Null_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_List + or else NT (N).Nkind = N_Procedure_Specification + or else NT (N).Nkind = N_Record_Definition); + Set_Flag13 (N, Val); + end Set_Null_Present; + + procedure Set_Null_Exclusion_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_Definition + or else NT (N).Nkind = N_Access_Function_Definition + or else NT (N).Nkind = N_Access_Procedure_Definition + or else NT (N).Nkind = N_Access_To_Object_Definition + or else NT (N).Nkind = N_Allocator + or else NT (N).Nkind = N_Component_Definition + or else NT (N).Nkind = N_Derived_Type_Definition + or else NT (N).Nkind = N_Discriminant_Specification + or else NT (N).Nkind = N_Formal_Object_Declaration + or else NT (N).Nkind = N_Function_Specification + or else NT (N).Nkind = N_Object_Declaration + or else NT (N).Nkind = N_Object_Renaming_Declaration + or else NT (N).Nkind = N_Parameter_Specification + or else NT (N).Nkind = N_Subtype_Declaration); + Set_Flag11 (N, Val); + end Set_Null_Exclusion_Present; + + procedure Set_Null_Exclusion_In_Return_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_Function_Definition); + Set_Flag14 (N, Val); + end Set_Null_Exclusion_In_Return_Present; + + procedure Set_Null_Record_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aggregate + or else NT (N).Nkind = N_Extension_Aggregate); + Set_Flag17 (N, Val); + end Set_Null_Record_Present; + + procedure Set_Object_Definition + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Object_Declaration); + Set_Node4_With_Parent (N, Val); + end Set_Object_Definition; + + procedure Set_Of_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Iterator_Specification); + Set_Flag16 (N, Val); + end Set_Of_Present; + + procedure Set_Original_Discriminant + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Identifier); + Set_Node2 (N, Val); -- semantic field, no parent set + end Set_Original_Discriminant; + + procedure Set_Original_Entity + (N : Node_Id; Val : Entity_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Integer_Literal + or else NT (N).Nkind = N_Real_Literal); + Set_Node2 (N, Val); -- semantic field, no parent set + end Set_Original_Entity; + + procedure Set_Others_Discrete_Choices + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Others_Choice); + Set_List1_With_Parent (N, Val); + end Set_Others_Discrete_Choices; + + procedure Set_Out_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Formal_Object_Declaration + or else NT (N).Nkind = N_Parameter_Specification); + Set_Flag17 (N, Val); + end Set_Out_Present; + + procedure Set_Parameter_Associations + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Entry_Call_Statement + or else NT (N).Nkind = N_Function_Call + or else NT (N).Nkind = N_Procedure_Call_Statement); + Set_List3_With_Parent (N, Val); + end Set_Parameter_Associations; + + procedure Set_Parameter_List_Truncated + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Function_Call + or else NT (N).Nkind = N_Procedure_Call_Statement); + Set_Flag17 (N, Val); + end Set_Parameter_List_Truncated; + + procedure Set_Parameter_Specifications + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Accept_Statement + or else NT (N).Nkind = N_Access_Function_Definition + or else NT (N).Nkind = N_Access_Procedure_Definition + or else NT (N).Nkind = N_Entry_Body_Formal_Part + or else NT (N).Nkind = N_Entry_Declaration + or else NT (N).Nkind = N_Function_Specification + or else NT (N).Nkind = N_Procedure_Specification); + Set_List3_With_Parent (N, Val); + end Set_Parameter_Specifications; + + procedure Set_Parameter_Type + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Parameter_Specification); + Set_Node2_With_Parent (N, Val); + end Set_Parameter_Type; + + procedure Set_Parent_Spec + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration + or else NT (N).Nkind = N_Generic_Package_Declaration + or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration + or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration + or else NT (N).Nkind = N_Generic_Subprogram_Declaration + or else NT (N).Nkind = N_Package_Declaration + or else NT (N).Nkind = N_Package_Instantiation + or else NT (N).Nkind = N_Package_Renaming_Declaration + or else NT (N).Nkind = N_Procedure_Instantiation + or else NT (N).Nkind = N_Subprogram_Declaration + or else NT (N).Nkind = N_Subprogram_Renaming_Declaration); + Set_Node4 (N, Val); -- semantic field, no parent set + end Set_Parent_Spec; + + procedure Set_Position + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Clause); + Set_Node2_With_Parent (N, Val); + end Set_Position; + + procedure Set_Pragma_Argument_Associations + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + Set_List2_With_Parent (N, Val); + end Set_Pragma_Argument_Associations; + + procedure Set_Pragma_Enabled + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + Set_Flag5 (N, Val); + end Set_Pragma_Enabled; + + procedure Set_Pragma_Identifier + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + Set_Node4_With_Parent (N, Val); + end Set_Pragma_Identifier; + + procedure Set_Pragmas_After + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit_Aux + or else NT (N).Nkind = N_Terminate_Alternative); + Set_List5_With_Parent (N, Val); + end Set_Pragmas_After; + + procedure Set_Pragmas_Before + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Accept_Alternative + or else NT (N).Nkind = N_Delay_Alternative + or else NT (N).Nkind = N_Entry_Call_Alternative + or else NT (N).Nkind = N_Mod_Clause + or else NT (N).Nkind = N_Terminate_Alternative + or else NT (N).Nkind = N_Triggering_Alternative); + Set_List4_With_Parent (N, Val); + end Set_Pragmas_Before; + + procedure Set_Prefix + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Reference + or else NT (N).Nkind = N_Expanded_Name + or else NT (N).Nkind = N_Explicit_Dereference + or else NT (N).Nkind = N_Indexed_Component + or else NT (N).Nkind = N_Reference + or else NT (N).Nkind = N_Selected_Component + or else NT (N).Nkind = N_Slice); + Set_Node3_With_Parent (N, Val); + end Set_Prefix; + + procedure Set_Present_Expr + (N : Node_Id; Val : Uint) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Variant); + Set_Uint3 (N, Val); + end Set_Present_Expr; + + procedure Set_Prev_Ids + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Declaration + or else NT (N).Nkind = N_Discriminant_Specification + or else NT (N).Nkind = N_Exception_Declaration + or else NT (N).Nkind = N_Formal_Object_Declaration + or else NT (N).Nkind = N_Number_Declaration + or else NT (N).Nkind = N_Object_Declaration + or else NT (N).Nkind = N_Parameter_Specification); + Set_Flag6 (N, Val); + end Set_Prev_Ids; + + procedure Set_Print_In_Hex + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Integer_Literal); + Set_Flag13 (N, Val); + end Set_Print_In_Hex; + + procedure Set_Private_Declarations + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Package_Specification + or else NT (N).Nkind = N_Protected_Definition + or else NT (N).Nkind = N_Task_Definition); + Set_List3_With_Parent (N, Val); + end Set_Private_Declarations; + + procedure Set_Private_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit + or else NT (N).Nkind = N_Formal_Derived_Type_Definition + or else NT (N).Nkind = N_With_Clause); + Set_Flag15 (N, Val); + end Set_Private_Present; + + procedure Set_Procedure_To_Call + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Allocator + or else NT (N).Nkind = N_Extended_Return_Statement + or else NT (N).Nkind = N_Free_Statement + or else NT (N).Nkind = N_Return_Statement); + Set_Node2 (N, Val); -- semantic field, no parent set + end Set_Procedure_To_Call; + + procedure Set_Proper_Body + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subunit); + Set_Node1_With_Parent (N, Val); + end Set_Proper_Body; + + procedure Set_Protected_Definition + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Protected_Type_Declaration + or else NT (N).Nkind = N_Single_Protected_Declaration); + Set_Node3_With_Parent (N, Val); + end Set_Protected_Definition; + + procedure Set_Protected_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_Function_Definition + or else NT (N).Nkind = N_Access_Procedure_Definition + or else NT (N).Nkind = N_Derived_Type_Definition + or else NT (N).Nkind = N_Record_Definition); + Set_Flag6 (N, Val); + end Set_Protected_Present; + + procedure Set_Raises_Constraint_Error + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind in N_Subexpr); + Set_Flag7 (N, Val); + end Set_Raises_Constraint_Error; + + procedure Set_Range_Constraint + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Delta_Constraint + or else NT (N).Nkind = N_Digits_Constraint); + Set_Node4_With_Parent (N, Val); + end Set_Range_Constraint; + + procedure Set_Range_Expression + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Range_Constraint); + Set_Node4_With_Parent (N, Val); + end Set_Range_Expression; + + procedure Set_Real_Range_Specification + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition + or else NT (N).Nkind = N_Floating_Point_Definition + or else NT (N).Nkind = N_Ordinary_Fixed_Point_Definition); + Set_Node4_With_Parent (N, Val); + end Set_Real_Range_Specification; + + procedure Set_Realval + (N : Node_Id; Val : Ureal) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Real_Literal); + Set_Ureal3 (N, Val); + end Set_Realval; + + procedure Set_Reason + (N : Node_Id; Val : Uint) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Raise_Constraint_Error + or else NT (N).Nkind = N_Raise_Program_Error + or else NT (N).Nkind = N_Raise_Storage_Error); + Set_Uint3 (N, Val); + end Set_Reason; + + procedure Set_Record_Extension_Part + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Derived_Type_Definition); + Set_Node3_With_Parent (N, Val); + end Set_Record_Extension_Part; + + procedure Set_Redundant_Use + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Reference + or else NT (N).Nkind = N_Expanded_Name + or else NT (N).Nkind = N_Identifier); + Set_Flag13 (N, Val); + end Set_Redundant_Use; + + procedure Set_Renaming_Exception + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exception_Declaration); + Set_Node2 (N, Val); + end Set_Renaming_Exception; + + procedure Set_Result_Definition + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_Function_Definition + or else NT (N).Nkind = N_Function_Specification); + Set_Node4_With_Parent (N, Val); + end Set_Result_Definition; + + procedure Set_Return_Object_Declarations + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Extended_Return_Statement); + Set_List3_With_Parent (N, Val); + end Set_Return_Object_Declarations; + + procedure Set_Return_Statement_Entity + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Extended_Return_Statement + or else NT (N).Nkind = N_Return_Statement); + Set_Node5 (N, Val); -- semantic field, no parent set + end Set_Return_Statement_Entity; + + procedure Set_Reverse_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Iterator_Specification + or else NT (N).Nkind = N_Loop_Parameter_Specification); + Set_Flag15 (N, Val); + end Set_Reverse_Present; + + procedure Set_Right_Opnd + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind in N_Op + or else NT (N).Nkind = N_And_Then + or else NT (N).Nkind = N_In + or else NT (N).Nkind = N_Not_In + or else NT (N).Nkind = N_Or_Else); + Set_Node3_With_Parent (N, Val); + end Set_Right_Opnd; + + procedure Set_Rounded_Result + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Op_Divide + or else NT (N).Nkind = N_Op_Multiply + or else NT (N).Nkind = N_Type_Conversion); + Set_Flag18 (N, Val); + end Set_Rounded_Result; + + procedure Set_SCIL_Controlling_Tag + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_SCIL_Dispatching_Call); + Set_Node5 (N, Val); -- semantic field, no parent set + end Set_SCIL_Controlling_Tag; + + procedure Set_SCIL_Entity + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init + or else NT (N).Nkind = N_SCIL_Dispatching_Call + or else NT (N).Nkind = N_SCIL_Membership_Test); + Set_Node4 (N, Val); -- semantic field, no parent set + end Set_SCIL_Entity; + + procedure Set_SCIL_Tag_Value + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_SCIL_Membership_Test); + Set_Node5 (N, Val); -- semantic field, no parent set + end Set_SCIL_Tag_Value; + + procedure Set_SCIL_Target_Prim + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_SCIL_Dispatching_Call); + Set_Node2 (N, Val); -- semantic field, no parent set + end Set_SCIL_Target_Prim; + + procedure Set_Scope + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Defining_Character_Literal + or else NT (N).Nkind = N_Defining_Identifier + or else NT (N).Nkind = N_Defining_Operator_Symbol); + Set_Node3 (N, Val); -- semantic field, no parent set + end Set_Scope; + + procedure Set_Select_Alternatives + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Selective_Accept); + Set_List1_With_Parent (N, Val); + end Set_Select_Alternatives; + + procedure Set_Selector_Name + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Expanded_Name + or else NT (N).Nkind = N_Generic_Association + or else NT (N).Nkind = N_Parameter_Association + or else NT (N).Nkind = N_Selected_Component); + Set_Node2_With_Parent (N, Val); + end Set_Selector_Name; + + procedure Set_Selector_Names + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Discriminant_Association); + Set_List1_With_Parent (N, Val); + end Set_Selector_Names; + + procedure Set_Shift_Count_OK + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Op_Rotate_Left + or else NT (N).Nkind = N_Op_Rotate_Right + or else NT (N).Nkind = N_Op_Shift_Left + or else NT (N).Nkind = N_Op_Shift_Right + or else NT (N).Nkind = N_Op_Shift_Right_Arithmetic); + Set_Flag4 (N, Val); + end Set_Shift_Count_OK; + + procedure Set_Source_Type + (N : Node_Id; Val : Entity_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Validate_Unchecked_Conversion); + Set_Node1 (N, Val); -- semantic field, no parent set + end Set_Source_Type; + + procedure Set_Specification + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Abstract_Subprogram_Declaration + or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration + or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration + or else NT (N).Nkind = N_Generic_Package_Declaration + or else NT (N).Nkind = N_Generic_Subprogram_Declaration + or else NT (N).Nkind = N_Package_Declaration + or else NT (N).Nkind = N_Parameterized_Expression + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Subprogram_Body_Stub + or else NT (N).Nkind = N_Subprogram_Declaration + or else NT (N).Nkind = N_Subprogram_Renaming_Declaration); + Set_Node1_With_Parent (N, Val); + end Set_Specification; + + procedure Set_Split_PPC + (N : Node_Id; Val : Boolean) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_Pragma); + Set_Flag17 (N, Val); + end Set_Split_PPC; + + procedure Set_Statements + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Abortable_Part + or else NT (N).Nkind = N_Accept_Alternative + or else NT (N).Nkind = N_Case_Statement_Alternative + or else NT (N).Nkind = N_Delay_Alternative + or else NT (N).Nkind = N_Entry_Call_Alternative + or else NT (N).Nkind = N_Exception_Handler + or else NT (N).Nkind = N_Handled_Sequence_Of_Statements + or else NT (N).Nkind = N_Loop_Statement + or else NT (N).Nkind = N_Triggering_Alternative); + Set_List3_With_Parent (N, Val); + end Set_Statements; + + procedure Set_Static_Processing_OK + (N : Node_Id; Val : Boolean) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aggregate); + Set_Flag4 (N, Val); + end Set_Static_Processing_OK; + + procedure Set_Storage_Pool + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Allocator + or else NT (N).Nkind = N_Extended_Return_Statement + or else NT (N).Nkind = N_Free_Statement + or else NT (N).Nkind = N_Return_Statement); + Set_Node1 (N, Val); -- semantic field, no parent set + end Set_Storage_Pool; + + procedure Set_Strval + (N : Node_Id; Val : String_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Operator_Symbol + or else NT (N).Nkind = N_String_Literal); + Set_Str3 (N, Val); + end Set_Strval; + + procedure Set_Subtype_Indication + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_To_Object_Definition + or else NT (N).Nkind = N_Component_Definition + or else NT (N).Nkind = N_Derived_Type_Definition + or else NT (N).Nkind = N_Iterator_Specification + or else NT (N).Nkind = N_Private_Extension_Declaration + or else NT (N).Nkind = N_Subtype_Declaration); + Set_Node5_With_Parent (N, Val); + end Set_Subtype_Indication; + + procedure Set_Subtype_Mark + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_Definition + or else NT (N).Nkind = N_Formal_Derived_Type_Definition + or else NT (N).Nkind = N_Formal_Object_Declaration + or else NT (N).Nkind = N_Object_Renaming_Declaration + or else NT (N).Nkind = N_Qualified_Expression + or else NT (N).Nkind = N_Subtype_Indication + or else NT (N).Nkind = N_Type_Conversion + or else NT (N).Nkind = N_Unchecked_Type_Conversion); + Set_Node4_With_Parent (N, Val); + end Set_Subtype_Mark; + + procedure Set_Subtype_Marks + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Unconstrained_Array_Definition + or else NT (N).Nkind = N_Use_Type_Clause); + Set_List2_With_Parent (N, Val); + end Set_Subtype_Marks; + + procedure Set_Suppress_Assignment_Checks + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement + or else NT (N).Nkind = N_Object_Declaration); + Set_Flag18 (N, Val); + end Set_Suppress_Assignment_Checks; + + procedure Set_Suppress_Loop_Warnings + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Loop_Statement); + Set_Flag17 (N, Val); + end Set_Suppress_Loop_Warnings; + + procedure Set_Synchronized_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Derived_Type_Definition + or else NT (N).Nkind = N_Formal_Derived_Type_Definition + or else NT (N).Nkind = N_Private_Extension_Declaration + or else NT (N).Nkind = N_Record_Definition); + Set_Flag7 (N, Val); + end Set_Synchronized_Present; + + procedure Set_Tagged_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Formal_Private_Type_Definition + or else NT (N).Nkind = N_Incomplete_Type_Declaration + or else NT (N).Nkind = N_Private_Type_Declaration + or else NT (N).Nkind = N_Record_Definition); + Set_Flag15 (N, Val); + end Set_Tagged_Present; + + procedure Set_Target_Type + (N : Node_Id; Val : Entity_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Validate_Unchecked_Conversion); + Set_Node2 (N, Val); -- semantic field, no parent set + end Set_Target_Type; + + procedure Set_Task_Definition + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Single_Task_Declaration + or else NT (N).Nkind = N_Task_Type_Declaration); + Set_Node3_With_Parent (N, Val); + end Set_Task_Definition; + + procedure Set_Task_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Derived_Type_Definition + or else NT (N).Nkind = N_Record_Definition); + Set_Flag5 (N, Val); + end Set_Task_Present; + + procedure Set_Then_Actions + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Conditional_Expression); + Set_List2 (N, Val); -- semantic field, no parent set + end Set_Then_Actions; + + procedure Set_Then_Statements + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Elsif_Part + or else NT (N).Nkind = N_If_Statement); + Set_List2_With_Parent (N, Val); + end Set_Then_Statements; + + procedure Set_Treat_Fixed_As_Integer + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Op_Divide + or else NT (N).Nkind = N_Op_Mod + or else NT (N).Nkind = N_Op_Multiply + or else NT (N).Nkind = N_Op_Rem); + Set_Flag14 (N, Val); + end Set_Treat_Fixed_As_Integer; + + procedure Set_Triggering_Alternative + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Asynchronous_Select); + Set_Node1_With_Parent (N, Val); + end Set_Triggering_Alternative; + + procedure Set_Triggering_Statement + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Triggering_Alternative); + Set_Node1_With_Parent (N, Val); + end Set_Triggering_Statement; + + procedure Set_TSS_Elist + (N : Node_Id; Val : Elist_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Freeze_Entity); + Set_Elist3 (N, Val); -- semantic field, no parent set + end Set_TSS_Elist; + + procedure Set_Type_Definition + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Full_Type_Declaration); + Set_Node3_With_Parent (N, Val); + end Set_Type_Definition; + + procedure Set_Unit + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit); + Set_Node2_With_Parent (N, Val); + end Set_Unit; + + procedure Set_Unknown_Discriminants_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Formal_Type_Declaration + or else NT (N).Nkind = N_Incomplete_Type_Declaration + or else NT (N).Nkind = N_Private_Extension_Declaration + or else NT (N).Nkind = N_Private_Type_Declaration); + Set_Flag13 (N, Val); + end Set_Unknown_Discriminants_Present; + + procedure Set_Unreferenced_In_Spec + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + Set_Flag7 (N, Val); + end Set_Unreferenced_In_Spec; + + procedure Set_Variant_Part + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_List); + Set_Node4_With_Parent (N, Val); + end Set_Variant_Part; + + procedure Set_Variants + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Variant_Part); + Set_List1_With_Parent (N, Val); + end Set_Variants; + + procedure Set_Visible_Declarations + (N : Node_Id; Val : List_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Package_Specification + or else NT (N).Nkind = N_Protected_Definition + or else NT (N).Nkind = N_Task_Definition); + Set_List2_With_Parent (N, Val); + end Set_Visible_Declarations; + + procedure Set_Was_Originally_Stub + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Package_Body + or else NT (N).Nkind = N_Protected_Body + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Task_Body); + Set_Flag13 (N, Val); + end Set_Was_Originally_Stub; + + procedure Set_Withed_Body + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + Set_Node1 (N, Val); + end Set_Withed_Body; + + procedure Set_Zero_Cost_Handling + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exception_Handler + or else NT (N).Nkind = N_Handled_Sequence_Of_Statements); + Set_Flag5 (N, Val); + end Set_Zero_Cost_Handling; + + ------------------------- + -- Iterator Procedures -- + ------------------------- + + procedure Next_Entity (N : in out Node_Id) is + begin + N := Next_Entity (N); + end Next_Entity; + + procedure Next_Named_Actual (N : in out Node_Id) is + begin + N := Next_Named_Actual (N); + end Next_Named_Actual; + + procedure Next_Rep_Item (N : in out Node_Id) is + begin + N := Next_Rep_Item (N); + end Next_Rep_Item; + + procedure Next_Use_Clause (N : in out Node_Id) is + begin + N := Next_Use_Clause (N); + end Next_Use_Clause; + + ------------------ + -- End_Location -- + ------------------ + + function End_Location (N : Node_Id) return Source_Ptr is + L : constant Uint := End_Span (N); + begin + if L = No_Uint then + return No_Location; + else + return Source_Ptr (Int (Sloc (N)) + UI_To_Int (L)); + end if; + end End_Location; + + -------------------- + -- Get_Pragma_Arg -- + -------------------- + + function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is + begin + if Nkind (Arg) = N_Pragma_Argument_Association then + return Expression (Arg); + else + return Arg; + end if; + end Get_Pragma_Arg; + + ---------------------- + -- Set_End_Location -- + ---------------------- + + procedure Set_End_Location (N : Node_Id; S : Source_Ptr) is + begin + Set_End_Span (N, + UI_From_Int (Int (S) - Int (Sloc (N)))); + end Set_End_Location; + + -------------- + -- Nkind_In -- + -------------- + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind) return Boolean + is + begin + return T = V1 or else + T = V2; + end Nkind_In; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3; + end Nkind_In; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4; + end Nkind_In; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4 or else + T = V5; + end Nkind_In; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4 or else + T = V5 or else + T = V6; + end Nkind_In; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind; + V7 : Node_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4 or else + T = V5 or else + T = V6 or else + T = V7; + end Nkind_In; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind; + V7 : Node_Kind; + V8 : Node_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4 or else + T = V5 or else + T = V6 or else + T = V7 or else + T = V8; + end Nkind_In; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind; + V7 : Node_Kind; + V8 : Node_Kind; + V9 : Node_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4 or else + T = V5 or else + T = V6 or else + T = V7 or else + T = V8 or else + T = V9; + end Nkind_In; + + ----------------- + -- Pragma_Name -- + ----------------- + + function Pragma_Name (N : Node_Id) return Name_Id is + begin + return Chars (Pragma_Identifier (N)); + end Pragma_Name; + +end Sinfo; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads new file mode 100644 index 000000000..8a6690360 --- /dev/null +++ b/gcc/ada/sinfo.ads @@ -0,0 +1,12262 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S I N F O -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package defines the structure of the abstract syntax tree. The Tree +-- package provides a basic tree structure. Sinfo describes how this structure +-- is used to represent the syntax of an Ada program. + +-- The grammar in the RM is followed very closely in the tree design, and is +-- repeated as part of this source file. + +-- The tree contains not only the full syntactic representation of the +-- program, but also the results of semantic analysis. In particular, the +-- nodes for defining identifiers, defining character literals and defining +-- operator symbols, collectively referred to as entities, represent what +-- would normally be regarded as the symbol table information. In addition a +-- number of the tree nodes contain semantic information. + +-- WARNING: Several files are automatically generated from this package. +-- See below for details. + +with Namet; use Namet; +with Types; use Types; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package Sinfo is + + --------------------------------- + -- Making Changes to This File -- + --------------------------------- + + -- If changes are made to this file, a number of related steps must be + -- carried out to ensure consistency. First, if a field access function is + -- added, it appears in these places: + + -- In sinfo.ads: + -- The documentation associated with the field (if semantic) + -- The documentation associated with the node + -- The spec of the access function + -- The spec of the set procedure + -- The entries in Is_Syntactic_Field + -- The pragma Inline for the access function + -- The pragma Inline for the set procedure + -- In sinfo.adb: + -- The body of the access function + -- The body of the set procedure + + -- The field chosen must be consistent in all places, and, for a node that + -- is a subexpression, must not overlap any of the standard expression + -- fields. + + -- In addition, if any of the standard expression fields is changed, then + -- the utility program which creates the Treeprs spec (in file treeprs.ads) + -- must be updated appropriately, since it special cases expression fields. + + -- If a new tree node is added, then the following changes are made + + -- Add it to the documentation in the appropriate place + -- Add its fields to this documentation section + -- Define it in the appropriate classification in Node_Kind + -- In the body (sinfo), add entries to the access functions for all + -- its fields (except standard expression fields) to include the new + -- node in the checks. + -- Add an appropriate section to the case statement in sprint.adb + -- Add an appropriate section to the case statement in sem.adb + -- Add an appropriate section to the case statement in exp_util.adb + -- (Insert_Actions procedure) + -- For a subexpression, add an appropriate section to the case + -- statement in sem_eval.adb + -- For a subexpression, add an appropriate section to the case + -- statement in sem_res.adb + + -- Finally, four utility programs must be run: + + -- (Optional.) Run CSinfo to check that you have made the changes + -- consistently. It checks most of the rules given above. This utility + -- reads sinfo.ads and sinfo.adb and generates a report to standard + -- output. This step is optional because XSinfo runs CSinfo. + + -- Run XSinfo to create sinfo.h, the corresponding C header. This + -- utility reads sinfo.ads and generates sinfo.h. Note that it does + -- not need to read sinfo.adb, since the contents of the body are + -- algorithmically determinable from the spec. + + -- Run XTreeprs to create treeprs.ads, an updated version of the module + -- that is used to drive the tree print routine. This utility reads (but + -- does not modify) treeprs.adt, the template that provides the basic + -- structure of the file, and then fills in the data from the comments + -- in sinfo.ads. + + -- Run XNmake to create nmake.ads and nmake.adb, the package body and + -- spec of the Nmake package which contains functions for constructing + -- nodes. + + -- The above steps are done automatically by the build scripts when you do + -- a full bootstrap. + + -- Note: sometime we could write a utility that actually generated the body + -- of sinfo from the spec instead of simply checking it, since, as noted + -- above, the contents of the body can be determined from the spec. + + -------------------------------- + -- Implicit Nodes in the Tree -- + -------------------------------- + + -- Generally the structure of the tree very closely follows the grammar as + -- defined in the RM. However, certain nodes are omitted to save space and + -- simplify semantic processing. Two general classes of such omitted nodes + -- are as follows: + + -- If the only possibilities for a non-terminal are one or more other + -- non-terminals (i.e. the rule is a "skinny" rule), then usually the + -- corresponding node is omitted from the tree, and the target construct + -- appears directly. For example, a real type definition is either + -- floating point definition or a fixed point definition. No explicit node + -- appears for real type definition. Instead either the floating point + -- definition or fixed point definition appears directly. + + -- If a non-terminal corresponds to a list of some other non-terminal + -- (possibly with separating punctuation), then usually it is omitted from + -- the tree, and a list of components appears instead. For example, + -- sequence of statements does not appear explicitly in the tree. Instead + -- a list of statements appears directly. + + -- Some additional cases of omitted nodes occur and are documented + -- individually. In particular, many nodes are omitted in the tree + -- generated for an expression. + + ------------------------------------------- + -- Handling of Defining Identifier Lists -- + ------------------------------------------- + + -- In several declarative forms in the syntax, lists of defining + -- identifiers appear (object declarations, component declarations, number + -- declarations etc.) + + -- The semantics of such statements are equivalent to a series of identical + -- declarations of single defining identifiers (except that conformance + -- checks require the same grouping of identifiers in the parameter case). + + -- To simplify semantic processing, the parser breaks down such multiple + -- declaration cases into sequences of single declarations, duplicating + -- type and initialization information as required. The flags More_Ids and + -- Prev_Ids are used to record the original form of the source in the case + -- where the original source used a list of names, More_Ids being set on + -- all but the last name and Prev_Ids being set on all but the first name. + -- These flags are used to reconstruct the original source (e.g. in the + -- Sprint package), and also are included in the conformance checks, but + -- otherwise have no semantic significance. + + -- Note: the reason that we use More_Ids and Prev_Ids rather than + -- First_Name and Last_Name flags is so that the flags are off in the + -- normal one identifier case, which minimizes tree print output. + + ----------------------- + -- Use of Node Lists -- + ----------------------- + + -- With a few exceptions, if a construction of the form {non-terminal} + -- appears in the tree, lists are used in the corresponding tree node (see + -- package Nlists for handling of node lists). In this case a field of the + -- parent node points to a list of nodes for the non-terminal. The field + -- name for such fields has a plural name which always ends in "s". For + -- example, a case statement has a field Alternatives pointing to list of + -- case statement alternative nodes. + + -- Only fields pointing to lists have names ending in "s", so generally the + -- structure is strongly typed, fields not ending in s point to single + -- nodes, and fields ending in s point to lists. + + -- The following example shows how a traversal of a list is written. We + -- suppose here that Stmt points to a N_Case_Statement node which has a + -- list field called Alternatives: + + -- Alt := First (Alternatives (Stmt)); + -- while Present (Alt) loop + -- .. + -- -- processing for case statement alternative Alt + -- .. + -- Alt := Next (Alt); + -- end loop; + + -- The Present function tests for Empty, which in this case signals the end + -- of the list. First returns Empty immediately if the list is empty. + -- Present is defined in Atree, First and Next are defined in Nlists. + + -- The exceptions to this rule occur with {DEFINING_IDENTIFIERS} in all + -- contexts, which is handled as described in the previous section, and + -- with {,library_unit_NAME} in the N_With_Clause mode, which is handled + -- using the First_Name and Last_Name flags, as further detailed in the + -- description of the N_With_Clause node. + + ------------- + -- Pragmas -- + ------------- + + -- Pragmas can appear in many different context, but are not included in + -- the grammar. Still they must appear in the tree, so they can be properly + -- processed. + + -- Two approaches are used. In some cases, an extra field is defined in an + -- appropriate node that contains a list of pragmas appearing in the + -- expected context. For example pragmas can appear before an + -- Accept_Alternative in a Selective_Accept_Statement, and these pragmas + -- appear in the Pragmas_Before field of the N_Accept_Alternative node. + + -- The other approach is to simply allow pragmas to appear in syntactic + -- lists where the grammar (of course) does not include the possibility. + -- For example, the Variants field of an N_Variant_Part node points to a + -- list that can contain both N_Pragma and N_Variant nodes. + + -- To make processing easier in the latter case, the Nlists package + -- provides a set of routines (First_Non_Pragma, Last_Non_Pragma, + -- Next_Non_Pragma, Prev_Non_Pragma) that allow such lists to be handled + -- ignoring all pragmas. + + -- In the case of the variants list, we can either write: + + -- Variant := First (Variants (N)); + -- while Present (Variant) loop + -- ... + -- Variant := Next (Variant); + -- end loop; + + -- or + + -- Variant := First_Non_Pragma (Variants (N)); + -- while Present (Variant) loop + -- ... + -- Variant := Next_Non_Pragma (Variant); + -- end loop; + + -- In the first form of the loop, Variant can either be an N_Pragma or an + -- N_Variant node. In the second form, Variant can only be N_Variant since + -- all pragmas are skipped. + + --------------------- + -- Optional Fields -- + --------------------- + + -- Fields which correspond to a section of the syntax enclosed in square + -- brackets are generally omitted (and the corresponding field set to Empty + -- for a node, or No_List for a list). The documentation of such fields + -- notes these cases. One exception to this rule occurs in the case of + -- possibly empty statement sequences (such as the sequence of statements + -- in an entry call alternative). Such cases appear in the syntax rules as + -- [SEQUENCE_OF_STATEMENTS] and the fields corresponding to such optional + -- statement sequences always contain an empty list (not No_List) if no + -- statements are present. + + -- Note: the utility program that constructs the body and spec of the Nmake + -- package relies on the format of the comments to determine if a field + -- should have a default value in the corresponding make routine. The rule + -- is that if the first line of the description of the field contains the + -- string "(set to xxx if", then a default value of xxx is provided for + -- this field in the corresponding Make_yyy routine. + + ----------------------------------- + -- Note on Body/Spec Terminology -- + ----------------------------------- + + -- In informal discussions about Ada, it is customary to refer to package + -- and subprogram specs and bodies. However, this is not technically + -- correct, what is normally referred to as a spec or specification is in + -- fact a package declaration or subprogram declaration. We are careful in + -- GNAT to use the correct terminology and in particular, the full word + -- specification is never used as an incorrect substitute for declaration. + -- The structure and terminology used in the tree also reflects the grammar + -- and thus uses declaration and specification in the technically correct + -- manner. + + -- However, there are contexts in which the informal terminology is useful. + -- We have the word "body" to refer to the Interp_Etype declared by the + -- declaration of a unit body, and in some contexts we need similar term to + -- refer to the entity declared by the package or subprogram declaration, + -- and simply using declaration can be confusing since the body also has a + -- declaration. + + -- An example of such a context is the link between the package body and + -- its declaration. With_Declaration is confusing, since the package body + -- itself is a declaration. + + -- To deal with this problem, we reserve the informal term Spec, i.e. the + -- popular abbreviation used in this context, to refer to the entity + -- declared by the package or subprogram declaration. So in the above + -- example case, the field in the body is called With_Spec. + + -- Another important context for the use of the word Spec is in error + -- messages, where a hyper-correct use of declaration would be confusing to + -- a typical Ada programmer, and even for an expert programmer can cause + -- confusion since the body has a declaration as well. + + -- So, to summarize: + + -- Declaration always refers to the syntactic entity that is called + -- a declaration. In particular, subprogram declaration + -- and package declaration are used to describe the + -- syntactic entity that includes the semicolon. + + -- Specification always refers to the syntactic entity that is called + -- a specification. In particular, the terms procedure + -- specification, function specification, package + -- specification, subprogram specification always refer + -- to the syntactic entity that has no semicolon. + + -- Spec is an informal term, used to refer to the entity + -- that is declared by a task declaration, protected + -- declaration, generic declaration, subprogram + -- declaration or package declaration. + + -- This convention is followed throughout the GNAT documentation + -- both internal and external, and in all error message text. + + ------------------------ + -- Internal Use Nodes -- + ------------------------ + + -- These are Node_Kind settings used in the internal implementation which + -- are not logically part of the specification. + + -- N_Unused_At_Start + -- Completely unused entry at the start of the enumeration type. This + -- is inserted so that no legitimate value is zero, which helps to get + -- better debugging behavior, since zero is a likely uninitialized value). + + -- N_Unused_At_End + -- Completely unused entry at the end of the enumeration type. This is + -- handy so that arrays with Node_Kind as the index type have an extra + -- entry at the end (see for example the use of the Pchar_Pos_Array in + -- Treepr, where the extra entry provides the limit value when dealing with + -- the last used entry in the array). + + ----------------------------------------- + -- Note on the settings of Sloc fields -- + ----------------------------------------- + + -- The Sloc field of nodes that come from the source is set by the parser. + -- For internal nodes, and nodes generated during expansion the Sloc is + -- usually set in the call to the constructor for the node. In general the + -- Sloc value chosen for an internal node is the Sloc of the source node + -- whose processing is responsible for the expansion. For example, the Sloc + -- of an inherited primitive operation is the Sloc of the corresponding + -- derived type declaration. + + -- For the nodes of a generic instantiation, the Sloc value is encoded to + -- represent both the original Sloc in the generic unit, and the Sloc of + -- the instantiation itself. See Sinput.ads for details. + + -- Subprogram instances create two callable entities: one is the visible + -- subprogram instance, and the other is an anonymous subprogram nested + -- within a wrapper package that contains the renamings for the actuals. + -- Both of these entities have the Sloc of the defining entity in the + -- instantiation node. This simplifies some ASIS queries. + + ----------------------- + -- Field Definitions -- + ----------------------- + + -- In the following node definitions, all fields, both syntactic and + -- semantic, are documented. The one exception is in the case of entities + -- (defining identifiers, character literals and operator symbols), where + -- the usage of the fields depends on the entity kind. Entity fields are + -- fully documented in the separate package Einfo. + + -- In the node definitions, three common sets of fields are abbreviated to + -- save both space in the documentation, and also space in the string + -- (defined in Tree_Print_Strings) used to print trees. The following + -- abbreviations are used: + + -- Note: the utility program that creates the Treeprs spec (in the file + -- xtreeprs.adb) knows about the special fields here, so it must be + -- modified if any change is made to these fields. + + -- "plus fields for binary operator" + -- Chars (Name1) Name_Id for the operator + -- Left_Opnd (Node2) left operand expression + -- Right_Opnd (Node3) right operand expression + -- Entity (Node4-Sem) defining entity for operator + -- Associated_Node (Node4-Sem) for generic processing + -- Do_Overflow_Check (Flag17-Sem) set if overflow check needed + -- Has_Private_View (Flag11-Sem) set in generic units. + + -- "plus fields for unary operator" + -- Chars (Name1) Name_Id for the operator + -- Right_Opnd (Node3) right operand expression + -- Entity (Node4-Sem) defining entity for operator + -- Associated_Node (Node4-Sem) for generic processing + -- Do_Overflow_Check (Flag17-Sem) set if overflow check needed + -- Has_Private_View (Flag11-Sem) set in generic units. + + -- "plus fields for expression" + -- Paren_Count number of parentheses levels + -- Etype (Node5-Sem) type of the expression + -- Is_Overloaded (Flag5-Sem) >1 type interpretation exists + -- Is_Static_Expression (Flag6-Sem) set for static expression + -- Raises_Constraint_Error (Flag7-Sem) evaluation raises CE + -- Must_Not_Freeze (Flag8-Sem) set if must not freeze + -- Do_Range_Check (Flag9-Sem) set if a range check needed + -- Assignment_OK (Flag15-Sem) set if modification is OK + -- Is_Controlling_Actual (Flag16-Sem) set for controlling argument + + -- Note: see under (EXPRESSION) for further details on the use of + -- the Paren_Count field to record the number of parentheses levels. + + -- Node_Kind is the type used in the Nkind field to indicate the node kind. + -- The actual definition of this type is given later (the reason for this + -- is that we want the descriptions ordered by logical chapter in the RM, + -- but the type definition is reordered to facilitate the definition of + -- some subtype ranges. The individual descriptions of the nodes show how + -- the various fields are used in each node kind, as well as providing + -- logical names for the fields. Functions and procedures are provided for + -- accessing and setting these fields using these logical names. + + ----------------------- + -- Gigi Restrictions -- + ----------------------- + + -- The tree passed to Gigi is more restricted than the general tree form. + -- For example, as a result of expansion, most of the tasking nodes can + -- never appear. For each node to which either a complete or partial + -- restriction applies, a note entitled "Gigi restriction" appears which + -- documents the restriction. + + -- Note that most of these restrictions apply only to trees generated when + -- code is being generated, since they involved expander actions that + -- destroy the tree. + + ------------------------ + -- Common Flag Fields -- + ------------------------ + + -- The following flag fields appear in all nodes + + -- Analyzed + -- This flag is used to indicate that a node (and all its children have + -- been analyzed. It is used to avoid reanalysis of a node that has + -- already been analyzed, both for efficiency and functional correctness + -- reasons. + + -- Comes_From_Source + -- This flag is set if the node comes directly from an explicit construct + -- in the source. It is normally on for any nodes built by the scanner or + -- parser from the source program, with the exception that in a few cases + -- the parser adds nodes to normalize the representation (in particular + -- a null statement is added to a package body if there is no begin/end + -- initialization section. + -- + -- Most nodes inserted by the analyzer or expander are not considered + -- as coming from source, so the flag is off for such nodes. In a few + -- cases, the expander constructs nodes closely equivalent to nodes + -- from the source program (e.g. the allocator built for build-in-place + -- case), and the Comes_From_Source flag is deliberately set. + + -- Error_Posted + -- This flag is used to avoid multiple error messages being posted on or + -- referring to the same node. This flag is set if an error message + -- refers to a node or is posted on its source location, and has the + -- effect of inhibiting further messages involving this same node. + + -- Has_Dynamic_Length_Check (Flag10-Sem) + -- This flag is present on all nodes. It is set to indicate that one of + -- the routines in unit Checks has generated a length check action which + -- has been inserted at the flagged node. This is used to avoid the + -- generation of duplicate checks. + + -- Has_Dynamic_Range_Check (Flag12-Sem) + -- This flag is present on all nodes. It is set to indicate that one of + -- the routines in unit Checks has generated a range check action which + -- has been inserted at the flagged node. This is used to avoid the + -- generation of duplicate checks. + + -- Has_Local_Raise (Flag8-Sem) + -- Present in exception handler nodes. Set if the handler can be entered + -- via a local raise that gets transformed to a goto statement. This will + -- always be set if Local_Raise_Statements is non-empty, but can also be + -- set as a result of generation of N_Raise_xxx nodes, or flags set in + -- nodes requiring generation of back end checks. + + ------------------------------------ + -- Description of Semantic Fields -- + ------------------------------------ + + -- The meaning of the syntactic fields is generally clear from their names + -- without any further description, since the names are chosen to + -- correspond very closely to the syntax in the reference manual. This + -- section describes the usage of the semantic fields, which are used to + -- contain additional information determined during semantic analysis. + + -- ABE_Is_Certain (Flag18-Sem) + -- This flag is set in an instantiation node or a call node is determined + -- to be sure to raise an ABE. This is used to trigger special handling + -- of such cases, particularly in the instantiation case where we avoid + -- instantiating the body if this flag is set. This flag is also present + -- in an N_Formal_Package_Declaration_Node since formal package + -- declarations are treated like instantiations, but it is always set to + -- False in this context. + + -- Accept_Handler_Records (List5-Sem) + -- This field is present only in an N_Accept_Alternative node. It is used + -- to temporarily hold the exception handler records from an accept + -- statement in a selective accept. These exception handlers will + -- eventually be placed in the Handler_Records list of the procedure + -- built for this accept (see Expand_N_Selective_Accept procedure in + -- Exp_Ch9 for further details). + + -- Access_Types_To_Process (Elist2-Sem) + -- Present in N_Freeze_Entity nodes for Incomplete or private types. + -- Contains the list of access types which may require specific treatment + -- when the nature of the type completion is completely known. An example + -- of such treatment is the generation of the associated_final_chain. + + -- Actions (List1-Sem) + -- This field contains a sequence of actions that are associated with the + -- node holding the field. See the individual node types for details of + -- how this field is used, as well as the description of the specific use + -- for a particular node type. + + -- Activation_Chain_Entity (Node3-Sem) + -- This is used in tree nodes representing task activators (blocks, + -- subprogram bodies, package declarations, and task bodies). It is + -- initially Empty, and then gets set to point to the entity for the + -- declared Activation_Chain variable when the first task is declared. + -- When tasks are declared in the corresponding declarative region this + -- entity is located by name (its name is always _Chain) and the declared + -- tasks are added to the chain. Note that N_Extended_Return_Statement + -- does not have this attribute, although it does have an activation + -- chain. This chain is used to store the tasks temporarily, and is not + -- used for activating them. On successful completion of the return + -- statement, the tasks are moved to the caller's chain, and the caller + -- activates them. + + -- Acts_As_Spec (Flag4-Sem) + -- A flag set in the N_Subprogram_Body node for a subprogram body which + -- is acting as its own spec, except in the case of a library level + -- subprogram, in which case the flag is set on the parent compilation + -- unit node instead (see further description in spec of Lib package). + -- ??? Above note about Lib is dubious since lib.ads does not mention + -- Acts_As_Spec at all. + + -- Actual_Designated_Subtype (Node4-Sem) + -- Present in N_Free_Statement and N_Explicit_Dereference nodes. If gigi + -- needs to known the dynamic constrained subtype of the designated + -- object, this attribute is set to that type. This is done for + -- N_Free_Statements for access-to-classwide types and access to + -- unconstrained packed array types, and for N_Explicit_Dereference when + -- the designated type is an unconstrained packed array and the + -- dereference is the prefix of a 'Size attribute reference. + + -- Address_Warning_Posted (Flag18-Sem) + -- Present in N_Attribute_Definition nodes. Set to indicate that we have + -- posted a warning for the address clause regarding size or alignment + -- issues. Used to inhibit multiple redundant messages. + + -- Aggregate_Bounds (Node3-Sem) + -- Present in array N_Aggregate nodes. If the bounds of the aggregate are + -- known at compile time, this field points to an N_Range node with those + -- bounds. Otherwise Empty. + + -- All_Others (Flag11-Sem) + -- Present in an N_Others_Choice node. This flag is set for an others + -- exception where all exceptions are to be caught, even those that are + -- not normally handled (in particular the tasking abort signal). This + -- is used for translation of the at end handler into a normal exception + -- handler. + + -- Aspect_Cancel (Flag11-Sem) + -- Processing of aspect specifications typically generates pragmas and + -- attribute definition clauses that are inserted into the tree after + -- the declaration node to get the desired aspect effect. In the case + -- of Boolean aspects that use "=> False" to cancel the effect of an + -- aspect (i.e. turn if off), the generated pragma has the Aspect_Cancel + -- flag set to indicate that the pragma operates in the opposite sense. + + -- Aspect_Rep_Item (Node2-Sem) + -- Present in N_Aspect_Specification nodes. Points to the corresponding + -- pragma/attribute definition node used to process the aspect. + + -- Assignment_OK (Flag15-Sem) + -- This flag is set in a subexpression node for an object, indicating + -- that the associated object can be modified, even if this would not + -- normally be permissible (either by direct assignment, or by being + -- passed as an out or in-out parameter). This is used by the expander + -- for a number of purposes, including initialization of constants and + -- limited type objects (such as tasks), setting discriminant fields, + -- setting tag values, etc. N_Object_Declaration nodes also have this + -- flag defined. Here it is used to indicate that an initialization + -- expression is valid, even where it would normally not be allowed + -- (e.g. where the type involved is limited). + + -- Associated_Node (Node4-Sem) + -- Present in nodes that can denote an entity: identifiers, character + -- literals, operator symbols, expanded names, operator nodes, and + -- attribute reference nodes (all these nodes have an Entity field). + -- This field is also present in N_Aggregate, N_Selected_Component, and + -- N_Extension_Aggregate nodes. This field is used in generic processing + -- to create links between the generic template and the generic copy. + -- See Sem_Ch12.Get_Associated_Node for full details. Note that this + -- field overlaps Entity, which is fine, since, as explained in Sem_Ch12, + -- the normal function of Entity is not required at the point where the + -- Associated_Node is set. Note also, that in generic templates, this + -- means that the Entity field does not necessarily point to an Entity. + -- Since the back end is expected to ignore generic templates, this is + -- harmless. + + -- At_End_Proc (Node1) + -- This field is present in an N_Handled_Sequence_Of_Statements node. + -- It contains an identifier reference for the cleanup procedure to be + -- called. See description of this node for further details. + + -- Backwards_OK (Flag6-Sem) + -- A flag present in the N_Assignment_Statement node. It is used only + -- if the type being assigned is an array type, and is set if analysis + -- determines that it is definitely safe to do the copy backwards, i.e. + -- starting at the highest addressed element. This is the case if either + -- the operands do not overlap, or they may overlap, but if they do, + -- then the left operand is at a higher address than the right operand. + -- + -- Note: If neither of the flags Forwards_OK or Backwards_OK is set, it + -- means that the front end could not determine that either direction is + -- definitely safe, and a runtime check may be required if the backend + -- cannot figure it out. If both flags Forwards_OK and Backwards_OK are + -- set, it means that the front end can assure no overlap of operands. + + -- Body_To_Inline (Node3-Sem) + -- present in subprogram declarations. Denotes analyzed but unexpanded + -- body of subprogram, to be used when inlining calls. Present when the + -- subprogram has an Inline pragma and inlining is enabled. If the + -- declaration is completed by a renaming_as_body, and the renamed en- + -- tity is a subprogram, the Body_To_Inline is the name of that entity, + -- which is used directly in later calls to the original subprogram. + + -- Body_Required (Flag13-Sem) + -- A flag that appears in the N_Compilation_Unit node indicating that + -- the corresponding unit requires a body. For the package case, this + -- indicates that a completion is required. In Ada 95, if the flag is not + -- set for the package case, then a body may not be present. In Ada 83, + -- if the flag is not set for the package case, then body is optional. + -- For a subprogram declaration, the flag is set except in the case where + -- a pragma Import or Interface applies, in which case no body is + -- permitted (in Ada 83 or Ada 95). + + -- By_Ref (Flag5-Sem) + -- Present in N_Simple_Return_Statement and N_Extended_Return_Statement, + -- this flag is set when the returned expression is already allocated on + -- the secondary stack and thus the result is passed by reference rather + -- than copied another time. + + -- Check_Address_Alignment (Flag11-Sem) + -- A flag present in N_Attribute_Definition clause for a 'Address + -- attribute definition. This flag is set if a dynamic check should be + -- generated at the freeze point for the entity to which this address + -- clause applies. The reason that we need this flag is that we want to + -- check for range checks being suppressed at the point where the + -- attribute definition clause is given, rather than testing this at the + -- freeze point. + + -- Coextensions (Elist4-Sem) + -- Present in allocators nodes. Points to list of allocators for the + -- access discriminants of the allocated object. + + -- Comes_From_Extended_Return_Statement (Flag18-Sem) + -- Present in N_Simple_Return_Statement nodes. True if this node was + -- constructed as part of the N_Extended_Return_Statement expansion. + + -- Compile_Time_Known_Aggregate (Flag18-Sem) + -- Present in N_Aggregate nodes. Set for aggregates which can be fully + -- evaluated at compile time without raising constraint error. Such + -- aggregates can be passed as is to Gigi without any expansion. See + -- Sem_Aggr for the specific conditions under which an aggregate has this + -- flag set. See also the flag Static_Processing_OK. + + -- Componentwise_Assignment (Flag14-Sem) + -- Present in N_Assignment_Statement nodes. Set for a record assignment + -- where all that needs doing is to expand it into component-by-component + -- assignments. This is used internally for the case of tagged types with + -- rep clauses, where we need to avoid recursion (we don't want to try to + -- generate a call to the primitive operation, because this is the case + -- where we are compiling the primitive operation). Note that when we are + -- expanding component assignments in this case, we never assign the _tag + -- field, but we recursively assign components of the parent type. + + -- Condition_Actions (List3-Sem) + -- This field appears in else-if nodes and in the iteration scheme node + -- for while loops. This field is only used during semantic processing to + -- temporarily hold actions inserted into the tree. In the tree passed + -- to gigi, the condition actions field is always set to No_List. For + -- details on how this field is used, see the routine Insert_Actions in + -- package Exp_Util, and also the expansion routines for the relevant + -- nodes. + + -- Context_Pending (Flag16-Sem) + -- This field appears in Compilation_Unit nodes, to indicate that the + -- context of the unit is being compiled. Used to detect circularities + -- that are not otherwise detected by the loading mechanism. Such + -- circularities can occur in the presence of limited and non-limited + -- with_clauses that mention the same units. + + -- Controlling_Argument (Node1-Sem) + -- This field is set in procedure and function call nodes if the call + -- is a dispatching call (it is Empty for a non-dispatching call). It + -- indicates the source of the call's controlling tag. For procedure + -- calls, the Controlling_Argument is one of the actuals. For function + -- that has a dispatching result, it is an entity in the context of the + -- call that can provide a tag, or else it is the tag of the root type + -- of the class. It can also specify a tag directly rather than being a + -- tagged object. The latter is needed by the implementations of AI-239 + -- and AI-260. + + -- Conversion_OK (Flag14-Sem) + -- A flag set on type conversion nodes to indicate that the conversion + -- is to be considered as being valid, even though it is the case that + -- the conversion is not valid Ada. This is used for attributes Enum_Rep, + -- Fixed_Value and Integer_Value, for internal conversions done for + -- fixed-point operations, and for certain conversions for calls to + -- initialization procedures. If Conversion_OK is set, then Etype must be + -- set (the analyzer assumes that Etype has been set). For the case of + -- fixed-point operands, it also indicates that the conversion is to be + -- direct conversion of the underlying integer result, with no regard to + -- the small operand. + + -- Corresponding_Body (Node5-Sem) + -- This field is set in subprogram declarations, package declarations, + -- entry declarations of protected types, and in generic units. It + -- points to the defining entity for the corresponding body (NOT the + -- node for the body itself). + + -- Corresponding_Formal_Spec (Node3-Sem) + -- This field is set in subprogram renaming declarations, where it points + -- to the defining entity for a formal subprogram in the case where the + -- renaming corresponds to a generic formal subprogram association in an + -- instantiation. The field is Empty if the renaming does not correspond + -- to such a formal association. + + -- Corresponding_Generic_Association (Node5-Sem) + -- This field is defined for object declarations and object renaming + -- declarations. It is set for the declarations within an instance that + -- map generic formals to their actuals. If set, the field points to + -- a generic_association which is the original parent of the expression + -- or name appearing in the declaration. This simplifies ASIS queries. + + -- Corresponding_Integer_Value (Uint4-Sem) + -- This field is set in real literals of fixed-point types (it is not + -- used for floating-point types). It contains the integer value used + -- to represent the fixed-point value. It is also set on the universal + -- real literals used to represent bounds of fixed-point base types + -- and their first named subtypes. + + -- Corresponding_Spec (Node5-Sem) + -- This field is set in subprogram, package, task, and protected body + -- nodes, where it points to the defining entity in the corresponding + -- spec. The attribute is also set in N_With_Clause nodes where it points + -- to the defining entity for the with'ed spec, and in a subprogram + -- renaming declaration when it is a Renaming_As_Body. The field is Empty + -- if there is no corresponding spec, as in the case of a subprogram body + -- that serves as its own spec. + + -- Corresponding_Stub (Node3-Sem) + -- This field is present in an N_Subunit node. It holds the node in + -- the parent unit that is the stub declaration for the subunit. It is + -- set when analysis of the stub forces loading of the proper body. If + -- expansion of the proper body creates new declarative nodes, they are + -- inserted at the point of the corresponding_stub. + + -- Dcheck_Function (Node5-Sem) + -- This field is present in an N_Variant node, It references the entity + -- for the discriminant checking function for the variant. + + -- Debug_Statement (Node3) + -- This field is present in an N_Pragma node. It is used only for a Debug + -- pragma. The parameter is of the form of an expression, as required by + -- the pragma syntax, but is actually a procedure call. To simplify + -- semantic processing, the parser creates a copy of the argument + -- rearranged into a procedure call statement and places it in the + -- Debug_Statement field. Note that this field is considered syntactic + -- field, since it is created by the parser. + + -- Default_Expression (Node5-Sem) + -- This field is Empty if there is no default expression. If there is a + -- simple default expression (one with no side effects), then this field + -- simply contains a copy of the Expression field (both point to the tree + -- for the default expression). Default_Expression is used for + -- conformance checking. + + -- Default_Storage_Pool (Node3-Sem) + -- This field is present in N_Compilation_Unit_Aux nodes. It is set to a + -- copy of Opt.Default_Pool at the end of the compilation unit. See + -- package Opt for details. This is used for inheriting the + -- Default_Storage_Pool in child units. + + -- Discr_Check_Funcs_Built (Flag11-Sem) + -- This flag is present in N_Full_Type_Declaration nodes. It is set when + -- discriminant checking functions are constructed. The purpose is to + -- avoid attempting to set these functions more than once. + + -- Do_Accessibility_Check (Flag13-Sem) + -- This flag is set on N_Parameter_Specification nodes to indicate + -- that an accessibility check is required for the parameter. It is + -- not yet decided who takes care of this check (TBD ???). + + -- Do_Discriminant_Check (Flag13-Sem) + -- This flag is set on N_Selected_Component nodes to indicate that a + -- discriminant check is required using the discriminant check routine + -- associated with the selector. The actual check is generated by the + -- expander when processing selected components. + + -- Do_Division_Check (Flag13-Sem) + -- This flag is set on a division operator (/ mod rem) to indicate + -- that a zero divide check is required. The actual check is dealt + -- with by the backend (all the front end does is to set the flag). + + -- Do_Length_Check (Flag4-Sem) + -- This flag is set in an N_Assignment_Statement, N_Op_And, N_Op_Or, + -- N_Op_Xor, or N_Type_Conversion node to indicate that a length check + -- is required. It is not determined who deals with this flag (???). + + -- Do_Overflow_Check (Flag17-Sem) + -- This flag is set on an operator where an overflow check is required on + -- the operation. The actual check is dealt with by the backend (all the + -- front end does is to set the flag). The other cases where this flag is + -- used is on a Type_Conversion node and for attribute reference nodes. + -- For a type conversion, it means that the conversion is from one base + -- type to another, and the value may not fit in the target base type. + -- See also the description of Do_Range_Check for this case. The only + -- attribute references which use this flag are Pred and Succ, where it + -- means that the result should be checked for going outside the base + -- range. Note that this flag is not set for modular types. + + -- Do_Range_Check (Flag9-Sem) + -- This flag is set on an expression which appears in a context where a + -- range check is required. The target type is clear from the context. + -- The contexts in which this flag can appear are the following: + + -- Right side of an assignment. In this case the target type is + -- taken from the left side of the assignment, which is referenced + -- by the Name of the N_Assignment_Statement node. + + -- Subscript expressions in an indexed component. In this case the + -- target type is determined from the type of the array, which is + -- referenced by the Prefix of the N_Indexed_Component node. + + -- Argument expression for a parameter, appearing either directly in + -- the Parameter_Associations list of a call or as the Expression of an + -- N_Parameter_Association node that appears in this list. In either + -- case, the check is against the type of the formal. Note that the + -- flag is relevant only in IN and IN OUT parameters, and will be + -- ignored for OUT parameters, where no check is required in the call, + -- and if a check is required on the return, it is generated explicitly + -- with a type conversion. + + -- Initialization expression for the initial value in an object + -- declaration. In this case the Do_Range_Check flag is set on + -- the initialization expression, and the check is against the + -- range of the type of the object being declared. + + -- The expression of a type conversion. In this case the range check is + -- against the target type of the conversion. See also the use of + -- Do_Overflow_Check on a type conversion. The distinction is that the + -- overflow check protects against a value that is outside the range of + -- the target base type, whereas a range check checks that the + -- resulting value (which is a value of the base type of the target + -- type), satisfies the range constraint of the target type. + + -- Note: when a range check is required in contexts other than those + -- listed above (e.g. in a return statement), an additional type + -- conversion node is introduced to represent the required check. + + -- Do_Storage_Check (Flag17-Sem) + -- This flag is set in an N_Allocator node to indicate that a storage + -- check is required for the allocation, or in an N_Subprogram_Body node + -- to indicate that a stack check is required in the subprogram prolog. + -- The N_Allocator case is handled by the routine that expands the call + -- to the runtime routine. The N_Subprogram_Body case is handled by the + -- backend, and all the semantics does is set the flag. + + -- Do_Tag_Check (Flag13-Sem) + -- This flag is set on an N_Assignment_Statement, N_Function_Call, + -- N_Procedure_Call_Statement, N_Type_Conversion, + -- N_Simple_Return_Statement, or N_Extended_Return_Statement + -- node to indicate that the tag check can be suppressed. It is not + -- yet decided how this flag is used (TBD ???). + + -- Elaborate_Present (Flag4-Sem) + -- This flag is set in the N_With_Clause node to indicate that pragma + -- Elaborate pragma appears for the with'ed units. + + -- Elaborate_All_Desirable (Flag9-Sem) + -- This flag is set in the N_With_Clause mode to indicate that the static + -- elaboration processing has determined that an Elaborate_All pragma is + -- desirable for correct elaboration for this unit. + + -- Elaborate_All_Present (Flag14-Sem) + -- This flag is set in the N_With_Clause node to indicate that a + -- pragma Elaborate_All pragma appears for the with'ed units. + + -- Elaborate_Desirable (Flag11-Sem) + -- This flag is set in the N_With_Clause mode to indicate that the static + -- elaboration processing has determined that an Elaborate pragma is + -- desirable for correct elaboration for this unit. + + -- Elaboration_Boolean (Node2-Sem) + -- This field is present in function and procedure specification nodes. + -- If set, it points to the entity for a Boolean flag that must be tested + -- for certain calls to check for access before elaboration. See body of + -- Sem_Elab for further details. This field is Empty if no elaboration + -- boolean is required. + + -- Else_Actions (List3-Sem) + -- This field is present in conditional expression nodes. During code + -- expansion we use the Insert_Actions procedure (in Exp_Util) to insert + -- actions at an appropriate place in the tree to get elaborated at the + -- right time. For conditional expressions, we have to be sure that the + -- actions for the Else branch are only elaborated if the condition is + -- False. The Else_Actions field is used as a temporary parking place for + -- these actions. The final tree is always rewritten to eliminate the + -- need for this field, so in the tree passed to Gigi, this field is + -- always set to No_List. + + -- Enclosing_Variant (Node2-Sem) + -- This field is present in the N_Variant node and identifies the Node_Id + -- corresponding to the immediately enclosing variant when the variant is + -- nested, and N_Empty otherwise. Set during semantic processing of the + -- variant part of a record type. + + -- Entity (Node4-Sem) + -- Appears in all direct names (identifiers, character literals, and + -- operator symbols), as well as expanded names, and attributes that + -- denote entities, such as 'Class. Points to entity for corresponding + -- defining occurrence. Set after name resolution. For identifiers in a + -- WITH list, the corresponding defining occurrence is in a separately + -- compiled file, and Entity must be set by the library Load procedure. + -- + -- Note: During name resolution, the value in Entity may be temporarily + -- incorrect (e.g. during overload resolution, Entity is initially set to + -- the first possible correct interpretation, and then later modified if + -- necessary to contain the correct value after resolution). + -- + -- Note: This field overlaps Associated_Node, which is used during + -- generic processing (see Sem_Ch12 for details). Note also that in + -- generic templates, this means that the Entity field does not always + -- point to an Entity. Since the back end is expected to ignore generic + -- templates, this is harmless. + -- + -- Note: This field also appears in N_Attribute_Definition_Clause nodes. + -- It is used only for stream attributes definition clauses. In this + -- case, it denotes a (possibly dummy) subprogram entity that is declared + -- conceptually at the point of the clause. Thus the visibility of the + -- attribute definition clause (in the sense of 8.3(23) as amended by + -- AI-195) can be checked by testing the visibility of that subprogram. + -- + -- Note: Normally the Entity field of an identifier points to the entity + -- for the corresponding defining identifier, and hence the Chars field + -- of an identifier will match the Chars field of the entity. However, + -- there is no requirement that these match, and there are obscure cases + -- of generated code where they do not match. + + -- Entity_Or_Associated_Node (Node4-Sem) + -- A synonym for both Entity and Associated_Node. Used by convention in + -- the code when referencing this field in cases where it is not known + -- whether the field contains an Entity or an Associated_Node. + + -- Etype (Node5-Sem) + -- Appears in all expression nodes, all direct names, and all entities. + -- Points to the entity for the related type. Set after type resolution. + -- Normally this is the actual subtype of the expression. However, in + -- certain contexts such as the right side of an assignment, subscripts, + -- arguments to calls, returned value in a function, initial value etc. + -- it is the desired target type. In the event that this is different + -- from the actual type, the Do_Range_Check flag will be set if a range + -- check is required. Note: if the Is_Overloaded flag is set, then Etype + -- points to an essentially arbitrary choice from the possible set of + -- types. + + -- Exception_Junk (Flag8-Sem) + -- This flag is set in a various nodes appearing in a statement sequence + -- to indicate that the corresponding node is an artifact of the + -- generated code for exception handling, and should be ignored when + -- analyzing the control flow of the relevant sequence of statements + -- (e.g. to check that it does not end with a bad return statement). + + -- Exception_Label (Node5-Sem) + -- Appears in N_Push_xxx_Label nodes. Points to the entity of the label + -- to be used for transforming the corresponding exception into a goto, + -- or contains Empty, if this exception is not to be transformed. Also + -- appears in N_Exception_Handler nodes, where, if set, it indicates + -- that there may be a local raise for the handler, so that expansion + -- to allow a goto is required (and this field contains the label for + -- this goto). See Exp_Ch11.Expand_Local_Exception_Handlers for details. + + -- Expansion_Delayed (Flag11-Sem) + -- Set on aggregates and extension aggregates that need a top-down rather + -- than bottom-up expansion. Typically aggregate expansion happens bottom + -- up. For nested aggregates the expansion is delayed until the enclosing + -- aggregate itself is expanded, e.g. in the context of a declaration. To + -- delay it we set this flag. This is done to avoid creating a temporary + -- for each level of a nested aggregates, and also to prevent the + -- premature generation of constraint checks. This is also a requirement + -- if we want to generate the proper attachment to the internal + -- finalization lists (for record with controlled components). Top down + -- expansion of aggregates is also used for in-place array aggregate + -- assignment or initialization. When the full context is known, the + -- target of the assignment or initialization is used to generate the + -- left-hand side of individual assignment to each sub-component. + + -- First_Inlined_Subprogram (Node3-Sem) + -- Present in the N_Compilation_Unit node for the main program. Points + -- to a chain of entities for subprograms that are to be inlined. The + -- Next_Inlined_Subprogram field of these entities is used as a link + -- pointer with Empty marking the end of the list. This field is Empty + -- if there are no inlined subprograms or inlining is not active. + + -- First_Named_Actual (Node4-Sem) + -- Present in procedure call statement and function call nodes, and also + -- in Intrinsic nodes. Set during semantic analysis to point to the first + -- named parameter where parameters are ordered by declaration order (as + -- opposed to the actual order in the call which may be different due to + -- named associations). Note: this field points to the explicit actual + -- parameter itself, not the N_Parameter_Association node (its parent). + + -- First_Real_Statement (Node2-Sem) + -- Present in N_Handled_Sequence_Of_Statements node. Normally set to + -- Empty. Used only when declarations are moved into the statement part + -- of a construct as a result of wrapping an AT END handler that is + -- required to cover the declarations. In this case, this field is used + -- to remember the location in the statements list of the first real + -- statement, i.e. the statement that used to be first in the statement + -- list before the declarations were prepended. + + -- First_Subtype_Link (Node5-Sem) + -- Present in N_Freeze_Entity node for an anonymous base type that is + -- implicitly created by the declaration of a first subtype. It points + -- to the entity for the first subtype. + + -- Float_Truncate (Flag11-Sem) + -- A flag present in type conversion nodes. This is used for float to + -- integer conversions where truncation is required rather than rounding. + -- Note that Gigi does not handle type conversions from real to integer + -- with rounding (see Expand_N_Type_Conversion). + + -- Forwards_OK (Flag5-Sem) + -- A flag present in the N_Assignment_Statement node. It is used only + -- if the type being assigned is an array type, and is set if analysis + -- determines that it is definitely safe to do the copy forwards, i.e. + -- starting at the lowest addressed element. This is the case if either + -- the operands do not overlap, or they may overlap, but if they do, + -- then the left operand is at a lower address than the right operand. + -- + -- Note: If neither of the flags Forwards_OK or Backwards_OK is set, it + -- means that the front end could not determine that either direction is + -- definitely safe, and a runtime check may be required if the backend + -- cannot figure it out. If both flags Forwards_OK and Backwards_OK are + -- set, it means that the front end can assure no overlap of operands. + + -- From_Aspect_Specification (Flag13-Sem) + -- Processing of aspect specifications typically results in insertion in + -- the tree of corresponding pragma or attribute definition clause nodes. + -- These generated nodes have the From_Aspect_Specification flag set to + -- indicate that they came from aspect specifications originally. + + -- From_At_End (Flag4-Sem) + -- This flag is set on an N_Raise_Statement node if it corresponds to + -- the reraise statement generated as the last statement of an AT END + -- handler when SJLJ exception handling is active. It is used to stop + -- a bogus violation of restriction (No_Exception_Propagation), bogus + -- because if the restriction is set, the reraise is not generated. + + -- From_At_Mod (Flag4-Sem) + -- This flag is set on the attribute definition clause node that is + -- generated by a transformation of an at mod phrase in a record + -- representation clause. This is used to give slightly different (Ada 83 + -- compatible) semantics to such a clause, namely it is used to specify a + -- minimum acceptable alignment for the base type and all subtypes. In + -- Ada 95 terms, the actual alignment of the base type and all subtypes + -- must be a multiple of the given value, and the representation clause + -- is considered to be type specific instead of subtype specific. + + -- From_Default (Flag6-Sem) + -- This flag is set on the subprogram renaming declaration created in an + -- instance for a formal subprogram, when the formal is declared with a + -- box, and there is no explicit actual. If the flag is present, the + -- declaration is treated as an implicit reference to the formal in the + -- ali file. + + -- Generic_Parent (Node5-Sem) + -- Generic_Parent is defined on declaration nodes that are instances. The + -- value of Generic_Parent is the generic entity from which the instance + -- is obtained. Generic_Parent is also defined for the renaming + -- declarations and object declarations created for the actuals in an + -- instantiation. The generic parent of such a declaration is the + -- corresponding generic association in the Instantiation node. + + -- Generic_Parent_Type (Node4-Sem) + -- Generic_Parent_Type is defined on Subtype_Declaration nodes for the + -- actuals of formal private and derived types. Within the instance, the + -- operations on the actual are those inherited from the parent. For a + -- formal private type, the parent type is the generic type itself. The + -- Generic_Parent_Type is also used in an instance to determine whether a + -- private operation overrides an inherited one. + + -- Handler_List_Entry (Node2-Sem) + -- This field is present in N_Object_Declaration nodes. It is set only + -- for the Handler_Record entry generated for an exception in zero cost + -- exception handling mode. It references the corresponding item in the + -- handler list, and is used to delete this entry if the corresponding + -- handler is deleted during optimization. For further details on why + -- this is required, see Exp_Ch11.Remove_Handler_Entries. + + -- Has_No_Elaboration_Code (Flag17-Sem) + -- A flag that appears in the N_Compilation_Unit node to indicate whether + -- or not elaboration code is present for this unit. It is initially set + -- true for subprogram specs and bodies and for all generic units and + -- false for non-generic package specs and bodies. Gigi may set the flag + -- in the non-generic package case if it determines that no elaboration + -- code is generated. Note that this flag is not related to the + -- Is_Preelaborated status, there can be preelaborated packages that + -- generate elaboration code, and non-preelaborated packages which do + -- not generate elaboration code. + + -- Has_Pragma_CPU (Flag14-Sem) + -- A flag present in N_Subprogram_Body and N_Task_Definition nodes to + -- flag the presence of a CPU pragma in the declaration sequence (public + -- or private in the task case). + + -- Has_Pragma_Suppress_All (Flag14-Sem) + -- This flag is set in an N_Compilation_Unit node if the Suppress_All + -- pragma appears anywhere in the unit. This accommodates the rather + -- strange placement rules of other compilers (DEC permits it at the + -- end of a unit, and Rational allows it as a program unit pragma). We + -- allow it anywhere at all, and consider it equivalent to a pragma + -- Suppress (All_Checks) appearing at the start of the configuration + -- pragmas for the unit. + + -- Has_Pragma_Priority (Flag6-Sem) + -- A flag present in N_Subprogram_Body, N_Task_Definition and + -- N_Protected_Definition nodes to flag the presence of either a Priority + -- or Interrupt_Priority pragma in the declaration sequence (public or + -- private in the task and protected cases) + + -- Has_Private_View (Flag11-Sem) + -- A flag present in generic nodes that have an entity, to indicate that + -- the node has a private type. Used to exchange private and full + -- declarations if the visibility at instantiation is different from the + -- visibility at generic definition. + + -- Has_Relative_Deadline_Pragma (Flag9-Sem) + -- A flag present in N_Subprogram_Body and N_Task_Definition nodes to + -- flag the presence of a pragma Relative_Deadline. + + -- Has_Self_Reference (Flag13-Sem) + -- Present in N_Aggregate and N_Extension_Aggregate. Indicates that one + -- of the expressions contains an access attribute reference to the + -- enclosing type. Such a self-reference can only appear in default- + -- initialized aggregate for a record type. + + -- Has_Storage_Size_Pragma (Flag5-Sem) + -- A flag present in an N_Task_Definition node to flag the presence of a + -- Storage_Size pragma. + + -- Has_Task_Info_Pragma (Flag7-Sem) + -- A flag present in an N_Task_Definition node to flag the presence of a + -- Task_Info pragma. Used to detect duplicate pragmas. + + -- Has_Task_Name_Pragma (Flag8-Sem) + -- A flag present in N_Task_Definition nodes to flag the presence of a + -- Task_Name pragma in the declaration sequence for the task. + + -- Has_Wide_Character (Flag11-Sem) + -- Present in string literals, set if any wide character (i.e. character + -- code outside the Character range but within Wide_Character range) + -- appears in the string. Used to implement pragma preference rules. + + -- Has_Wide_Wide_Character (Flag13-Sem) + -- Present in string literals, set if any wide character (i.e. character + -- code outside the Wide_Character range) appears in the string. Used to + -- implement pragma preference rules. + + -- Hidden_By_Use_Clause (Elist4-Sem) + -- An entity list present in use clauses that appear within + -- instantiations. For the resolution of local entities, entities + -- introduced by these use clauses have priority over global ones, and + -- outer entities must be explicitly hidden/restored on exit. + + -- Implicit_With (Flag16-Sem) + -- This flag is set in the N_With_Clause node that is implicitly + -- generated for runtime units that are loaded by the expander, and also + -- for package System, if it is loaded implicitly by a use of the + -- 'Address or 'Tag attribute. ???There are other implicit with clauses + -- as well. + + -- Import_Interface_Present (Flag16-Sem) + -- This flag is set in an Interface or Import pragma if a matching + -- pragma of the other kind is also present. This is used to avoid + -- generating some unwanted error messages. + + -- Includes_Infinities (Flag11-Sem) + -- This flag is present in N_Range nodes. It is set for the range of + -- unconstrained float types defined in Standard, which include not only + -- the given range of values, but also legitimately can include infinite + -- values. This flag is false for any float type for which an explicit + -- range is given by the programmer, even if that range is identical to + -- the range for Float. + + -- Inherited_Discriminant (Flag13-Sem) + -- This flag is present in N_Component_Association nodes. It indicates + -- that a given component association in an extension aggregate is the + -- value obtained from a constraint on an ancestor. Used to prevent + -- double expansion when the aggregate has expansion delayed. + + -- Instance_Spec (Node5-Sem) + -- This field is present in generic instantiation nodes, and also in + -- formal package declaration nodes (formal package declarations are + -- treated in a manner very similar to package instantiations). It points + -- to the node for the spec of the instance, inserted as part of the + -- semantic processing for instantiations in Sem_Ch12. + + -- Is_Accessibility_Actual (Flag12-Sem) + -- Present in N_Parameter_Association nodes. True if the parameter is + -- an extra actual that carries the accessibility level of the actual + -- for an access parameter, in a function that dispatches on result and + -- is called in a dispatching context. Used to prevent a formal/actual + -- mismatch when the call is rewritten as a dispatching call. + + -- Is_Asynchronous_Call_Block (Flag7-Sem) + -- A flag set in a Block_Statement node to indicate that it is the + -- expansion of an asynchronous entry call. Such a block needs cleanup + -- handler to assure that the call is cancelled. + + -- Is_Component_Left_Opnd (Flag13-Sem) + -- Is_Component_Right_Opnd (Flag14-Sem) + -- Present in concatenation nodes, to indicate that the corresponding + -- operand is of the component type of the result. Used in resolving + -- concatenation nodes in instances. + + -- Is_Delayed_Aspect (Flag14-Sem) + -- Present in N_Pragma and N_Attribute_Definition_Clause nodes which + -- come from aspect specifications, where the evaluation of the aspect + -- must be delayed to the freeze point. + + -- Is_Controlling_Actual (Flag16-Sem) + -- This flag is set on in an expression that is a controlling argument in + -- a dispatching call. It is off in all other cases. See Sem_Disp for + -- details of its use. + + -- Is_Dynamic_Coextension (Flag18-Sem) + -- Present in allocator nodes, to indicate that this is an allocator + -- for an access discriminant of a dynamically allocated object. The + -- coextension must be deallocated and finalized at the same time as + -- the enclosing object. + + -- Is_Entry_Barrier_Function (Flag8-Sem) + -- This flag is set in an N_Subprogram_Body node which is the expansion + -- of an entry barrier from a protected entry body. It is used for the + -- circuitry checking for incorrect use of Current_Task. + + -- Is_Expanded_Build_In_Place_Call (Flag11-Sem) + -- This flag is set in an N_Function_Call node to indicate that the extra + -- actuals to support a build-in-place style of call have been added to + -- the call. + + -- Is_In_Discriminant_Check (Flag11-Sem) + -- This flag is present in a selected component, and is used to indicate + -- that the reference occurs within a discriminant check. The + -- significance is that optimizations based on assuming that the + -- discriminant check has a correct value cannot be performed in this + -- case (or the discriminant check may be optimized away!) + + -- Is_Machine_Number (Flag11-Sem) + -- This flag is set in an N_Real_Literal node to indicate that the value + -- is a machine number. This avoids some unnecessary cases of converting + -- real literals to machine numbers. + + -- Is_Null_Loop (Flag16-Sem) + -- This flag is set in an N_Loop_Statement node if the corresponding loop + -- can be determined to be null at compile time. This is used to remove + -- the loop entirely at expansion time. + + -- Is_Overloaded (Flag5-Sem) + -- A flag present in all expression nodes. Used temporarily during + -- overloading determination. The setting of this flag is not relevant + -- once overloading analysis is complete. + + -- Is_Power_Of_2_For_Shift (Flag13-Sem) + -- A flag present only in N_Op_Expon nodes. It is set when the + -- exponentiation is of the form 2 ** N, where the type of N is an + -- unsigned integral subtype whose size does not exceed the size of + -- Standard_Integer (i.e. a type that can be safely converted to + -- Natural), and the exponentiation appears as the right operand of an + -- integer multiplication or an integer division where the dividend is + -- unsigned. It is also required that overflow checking is off for both + -- the exponentiation and the multiply/divide node. If this set of + -- conditions holds, and the flag is set, then the division or + -- multiplication can be (and is) converted to a shift. + + -- Is_Protected_Subprogram_Body (Flag7-Sem) + -- A flag set in a Subprogram_Body block to indicate that it is the + -- implementation of a protected subprogram. Such a body needs cleanup + -- handler to make sure that the associated protected object is unlocked + -- when the subprogram completes. + + -- Is_Static_Coextension (Flag14-Sem) + -- Present in N_Allocator nodes. Set if the allocator is a coextension + -- of an object allocated on the stack rather than the heap. + + -- Is_Static_Expression (Flag6-Sem) + -- Indicates that an expression is a static expression (RM 4.9). See spec + -- of package Sem_Eval for full details on the use of this flag. + + -- Is_Subprogram_Descriptor (Flag16-Sem) + -- Present in N_Object_Declaration, and set only for the object + -- declaration generated for a subprogram descriptor in fast exception + -- mode. See Exp_Ch11 for details of use. + + -- Is_Task_Allocation_Block (Flag6-Sem) + -- A flag set in a Block_Statement node to indicate that it is the + -- expansion of a task allocator, or the allocator of an object + -- containing tasks. Such a block requires a cleanup handler to call + -- Expunge_Unactivated_Tasks to complete any tasks that have been + -- allocated but not activated when the allocator completes abnormally. + + -- Is_Task_Master (Flag5-Sem) + -- A flag set in a Subprogram_Body, Block_Statement or Task_Body node to + -- indicate that the construct is a task master (i.e. has declared tasks + -- or declares an access to a task type). + + -- Itype (Node1-Sem) + -- Used in N_Itype_Reference node to reference an itype for which it is + -- important to ensure that it is defined. See description of this node + -- for further details. + + -- Kill_Range_Check (Flag11-Sem) + -- Used in an N_Unchecked_Type_Conversion node to indicate that the + -- result should not be subjected to range checks. This is used for the + -- implementation of Normalize_Scalars. + + -- Label_Construct (Node2-Sem) + -- Used in an N_Implicit_Label_Declaration node. Refers to an N_Label, + -- N_Block_Statement or N_Loop_Statement node to which the label + -- declaration applies. This is not currently used in the compiler + -- itself, but it is useful in the implementation of ASIS queries. + -- This field is left empty for the special labels generated as part + -- of expanding raise statements with a local exception handler. + + -- Library_Unit (Node4-Sem) + -- In a stub node, Library_Unit points to the compilation unit node of + -- the corresponding subunit. + -- + -- In a with clause node, Library_Unit points to the spec of the with'ed + -- unit. + -- + -- In a compilation unit node, the usage depends on the unit type: + -- + -- For a library unit body, Library_Unit points to the compilation unit + -- node of the corresponding spec, unless it's a subprogram body with + -- Acts_As_Spec set, in which case it points to itself. + -- + -- For a spec, Library_Unit points to the compilation unit node of the + -- corresponding body, if present. The body will be present if the spec + -- is or contains generics that we needed to instantiate. Similarly, the + -- body will be present if we needed it for inlining purposes. Thus, if + -- we have a spec/body pair, both of which are present, they point to + -- each other via Library_Unit. + -- + -- For a subunit, Library_Unit points to the compilation unit node of + -- the parent body. + -- + -- Note that this field is not used to hold the parent pointer for child + -- unit (which might in any case need to use it for some other purpose as + -- described above). Instead for a child unit, implicit with's are + -- generated for all parents. + + -- Local_Raise_Statements (Elist1) + -- This field is present in exception handler nodes. It is set to + -- No_Elist in the normal case. If there is at least one raise statement + -- which can potentially be handled as a local raise, then this field + -- points to a list of raise nodes, which are calls to a routine to raise + -- an exception. These are raise nodes which can be optimized into gotos + -- if the handler turns out to meet the conditions which permit this + -- transformation. Note that this does NOT include instances of the + -- N_Raise_xxx_Error nodes since the transformation of these nodes is + -- handled by the back end (using the N_Push/N_Pop mechanism). + + -- Loop_Actions (List2-Sem) + -- A list present in Component_Association nodes in array aggregates. + -- Used to collect actions that must be executed within the loop because + -- they may need to be evaluated anew each time through. + + -- Limited_View_Installed (Flag18-Sem) + -- Present in With_Clauses and in package specifications. If set on + -- with_clause, it indicates that this clause has created the current + -- limited view of the designated package. On a package specification, it + -- indicates that the limited view has already been created because the + -- package is mentioned in a limited_with_clause in the closure of the + -- unit being compiled. + + -- Local_Raise_Not_OK (Flag7-Sem) + -- Present in N_Exception_Handler nodes. Set if the handler contains + -- a construct (reraise statement, or call to subprogram in package + -- GNAT.Current_Exception) that makes the handler unsuitable as a target + -- for a local raise (one that could otherwise be converted to a goto). + + -- Must_Be_Byte_Aligned (Flag14-Sem) + -- This flag is present in N_Attribute_Reference nodes. It can be set + -- only for the Address and Unrestricted_Access attributes. If set it + -- means that the object for which the address/access is given must be on + -- a byte (more accurately a storage unit) boundary. If necessary, a copy + -- of the object is to be made before taking the address (this copy is in + -- the current scope on the stack frame). This is used for certain cases + -- of code generated by the expander that passes parameters by address. + -- + -- The reason the copy is not made by the front end is that the back end + -- has more information about type layout and may be able to (but is not + -- guaranteed to) prevent making unnecessary copies. + + -- Must_Not_Freeze (Flag8-Sem) + -- A flag present in all expression nodes. Normally expressions cause + -- freezing as described in the RM. If this flag is set, then this is + -- inhibited. This is used by the analyzer and expander to label nodes + -- that are created by semantic analysis or expansion and which must not + -- cause freezing even though they normally would. This flag is also + -- present in an N_Subtype_Indication node, since we also use these in + -- calls to Freeze_Expression. + + -- Next_Entity (Node2-Sem) + -- Present in defining identifiers, defining character literals and + -- defining operator symbols (i.e. in all entities). The entities of a + -- scope are chained, and this field is used as the forward pointer for + -- this list. See Einfo for further details. + + -- Next_Exit_Statement (Node3-Sem) + -- Present in N_Exit_Statement nodes. The exit statements for a loop are + -- chained (in reverse order of appearance) from the First_Exit_Statement + -- field of the E_Loop entity for the loop. Next_Exit_Statement points to + -- the next entry on this chain (Empty = end of list). + + -- Next_Implicit_With (Node3-Sem) + -- Present in N_With_Clause. Part of a chain of with_clauses generated + -- in rtsfind to indicate implicit dependencies on predefined units. Used + -- to prevent multiple with_clauses for the same unit in a given context. + -- A postorder traversal of the tree whose nodes are units and whose + -- links are with_clauses defines the order in which Inspector must + -- examine a compiled unit and its full context. This ordering ensures + -- that any subprogram call is examined after the subprogram declaration + -- has been seen. + + -- Next_Named_Actual (Node4-Sem) + -- Present in parameter association node. Set during semantic analysis to + -- point to the next named parameter, where parameters are ordered by + -- declaration order (as opposed to the actual order in the call, which + -- may be different due to named associations). Not that this field + -- points to the explicit actual parameter itself, not to the + -- N_Parameter_Association node (its parent). + + -- Next_Pragma (Node1-Sem) + -- Present in N_Pragma nodes. Used to create a linked list of pragma + -- nodes. Currently used for two purposes: + -- + -- Create a list of linked Check_Policy pragmas. The head of this list + -- is stored in Opt.Check_Policy_List (which has further details). + -- + -- Used by processing for Pre/Postcondition pragmas to store a list of + -- pragmas associated with the spec of a subprogram (see Sem_Prag for + -- details). + + -- Next_Rep_Item (Node5-Sem) + -- Present in pragma nodes, attribute definition nodes, enumeration rep + -- clauses, record rep clauses, aspect specification nodes. Used to link + -- representation items that apply to an entity. See full description of + -- First_Rep_Item field in Einfo for further details. + + -- Next_Use_Clause (Node3-Sem) + -- While use clauses are active during semantic processing, they are + -- chained from the scope stack entry, using Next_Use_Clause as a link + -- pointer, with Empty marking the end of the list. The head pointer is + -- in the scope stack entry (First_Use_Clause). At the end of semantic + -- processing (i.e. when Gigi sees the tree, the contents of this field + -- is undefined and should not be read). + + -- No_Ctrl_Actions (Flag7-Sem) + -- Present in N_Assignment_Statement to indicate that no finalize nor + -- adjust should take place on this assignment even though the rhs is + -- controlled. This is used in init procs and aggregate expansions where + -- the generated assignments are more initialisations than real + -- assignments. + + -- No_Elaboration_Check (Flag14-Sem) + -- Present in N_Function_Call and N_Procedure_Call_Statement. Indicates + -- that no elaboration check is needed on the call, because it appears in + -- the context of a local Suppress pragma. This is used on calls within + -- task bodies, where the actual elaboration checks are applied after + -- analysis, when the local scope stack is not present. + + -- No_Entities_Ref_In_Spec (Flag8-Sem) + -- Present in N_With_Clause nodes. Set if the with clause is on the + -- package or subprogram spec where the main unit is the corresponding + -- body, and no entities of the with'ed unit are referenced by the spec + -- (an entity may still be referenced in the body, so this flag is used + -- to generate the proper message (see Sem_Util.Check_Unused_Withs for + -- full details) + + -- No_Initialization (Flag13-Sem) + -- Present in N_Object_Declaration and N_Allocator to indicate that the + -- object must not be initialized (by Initialize or call to an init + -- proc). This is needed for controlled aggregates. When the Object + -- declaration has an expression, this flag means that this expression + -- should not be taken into account (needed for in place initialization + -- with aggregates). + + -- No_Truncation (Flag17-Sem) + -- Present in N_Unchecked_Type_Conversion node. This flag has an effect + -- only if the RM_Size of the source is greater than the RM_Size of the + -- target for scalar operands. Normally in such a case we truncate some + -- higher order bits of the source, and then sign/zero extend the result + -- to form the output value. But if this flag is set, then we do not do + -- any truncation, so for example, if an 8 bit input is converted to 5 + -- bit result which is in fact stored in 8 bits, then the high order + -- three bits of the target result will be copied from the source. This + -- is used for properly setting out of range values for use by pragmas + -- Initialize_Scalars and Normalize_Scalars. + + -- Original_Discriminant (Node2-Sem) + -- Present in identifiers. Used in references to discriminants that + -- appear in generic units. Because the names of the discriminants may be + -- different in an instance, we use this field to recover the position of + -- the discriminant in the original type, and replace it with the + -- discriminant at the same position in the instantiated type. + + -- Original_Entity (Node2-Sem) + -- Present in numeric literals. Used to denote the named number that has + -- been constant-folded into the given literal. If literal is from + -- source, or the result of some other constant-folding operation, then + -- Original_Entity is empty. This field is needed to handle properly + -- named numbers in generic units, where the Associated_Node field + -- interferes with the Entity field, making it impossible to preserve the + -- original entity at the point of instantiation (ASIS problem). + + -- Others_Discrete_Choices (List1-Sem) + -- When a case statement or variant is analyzed, the semantic checks + -- determine the actual list of choices that correspond to an others + -- choice. This list is materialized for later use by the expander and + -- the Others_Discrete_Choices field of an N_Others_Choice node points to + -- this materialized list of choices, which is in standard format for a + -- list of discrete choices, except that of course it cannot contain an + -- N_Others_Choice entry. + + -- Parameter_List_Truncated (Flag17-Sem) + -- Present in N_Function_Call and N_Procedure_Call_Statement nodes. Set + -- (for OpenVMS ports of GNAT only) if the parameter list is truncated as + -- a result of a First_Optional_Parameter specification in an + -- Import_Function, Import_Procedure, or Import_Valued_Procedure pragma. + -- The truncation is done by the expander by removing trailing parameters + -- from the argument list, in accordance with the set of rules allowing + -- such parameter removal. In particular, parameters can be removed + -- working from the end of the parameter list backwards up to and + -- including the entry designated by First_Optional_Parameter in the + -- Import pragma. Parameters can be removed if they are implicit and the + -- default value is a known-at-compile-time value, including the use of + -- the Null_Parameter attribute, or if explicit parameter values are + -- present that match the corresponding defaults. + + -- Parent_Spec (Node4-Sem) + -- For a library unit that is a child unit spec (package or subprogram + -- declaration, generic declaration or instantiation, or library level + -- rename, this field points to the compilation unit node for the parent + -- package specification. This field is Empty for library bodies (the + -- parent spec in this case can be found from the corresponding spec). + + -- Pragma_Enabled (Flag5-Sem) + -- Present in N_Pragma nodes. This flag is relevant only for pragmas + -- Assert, Check, Precondition, and Postcondition. It is true if the + -- check corresponding to the pragma type is enabled at the point where + -- the pragma appears. + + -- Present_Expr (Uint3-Sem) + -- Present in an N_Variant node. This has a meaningful value only after + -- Gigi has back annotated the tree with representation information. At + -- this point, it contains a reference to a gcc expression that depends + -- on the values of one or more discriminants. Give a set of discriminant + -- values, this expression evaluates to False (zero) if variant is not + -- present, and True (non-zero) if it is present. See unit Repinfo for + -- further details on gigi back annotation. This field is used during + -- ASIS processing (data decomposition annex) to determine if a field is + -- present or not. + + -- Print_In_Hex (Flag13-Sem) + -- Set on an N_Integer_Literal node to indicate that the value should be + -- printed in hexadecimal in the sprint listing. Has no effect on + -- legality or semantics of program, only on the displayed output. This + -- is used to clarify output from the packed array cases. + + -- Procedure_To_Call (Node2-Sem) + -- Present in N_Allocator, N_Free_Statement, N_Simple_Return_Statement, + -- and N_Extended_Return_Statement nodes. References the entity for the + -- declaration of the procedure to be called to accomplish the required + -- operation (i.e. for the Allocate procedure in the case of N_Allocator + -- and N_Simple_Return_Statement and N_Extended_Return_Statement (for + -- allocating the return value), and for the Deallocate procedure in the + -- case of N_Free_Statement. + + -- Raises_Constraint_Error (Flag7-Sem) + -- Set on an expression whose evaluation will definitely fail constraint + -- error check. In the case of static expressions, this flag must be set + -- accurately (and if it is set, the expression is typically illegal + -- unless it appears as a non-elaborated branch of a short-circuit form). + -- For a non-static expression, this flag may be set whenever an + -- expression (e.g. an aggregate) is known to raise constraint error. If + -- set, the expression definitely will raise CE if elaborated at runtime. + -- If not set, the expression may or may not raise CE. In other words, on + -- static expressions, the flag is set accurately, on non-static + -- expressions it is set conservatively. + + -- Redundant_Use (Flag13-Sem) + -- Present in nodes that can appear as an operand in a use clause or use + -- type clause (identifiers, expanded names, attribute references). Set + -- to indicate that a use is redundant (and therefore need not be undone + -- on scope exit). + + -- Renaming_Exception (Node2-Sem) + -- Present in N_Exception_Declaration node. Used to point back to the + -- exception renaming for an exception declared within a subprogram. + -- What happens is that an exception declared in a subprogram is moved + -- to the library level with a unique name, and the original exception + -- becomes a renaming. This link from the library level exception to the + -- renaming declaration allows registering of the proper exception name. + + -- Return_Statement_Entity (Node5-Sem) + -- Present in N_Simple_Return_Statement and N_Extended_Return_Statement. + -- Points to an E_Return_Statement representing the return statement. + + -- Return_Object_Declarations (List3) + -- Present in N_Extended_Return_Statement. + -- Points to a list initially containing a single + -- N_Object_Declaration representing the return object. + -- We use a list (instead of just a pointer to the object decl) + -- because Analyze wants to insert extra actions on this list. + + -- Rounded_Result (Flag18-Sem) + -- Present in N_Type_Conversion, N_Op_Divide and N_Op_Multiply nodes. + -- Used in the fixed-point cases to indicate that the result must be + -- rounded as a result of the use of the 'Round attribute. Also used for + -- integer N_Op_Divide nodes to indicate that the result should be + -- rounded to the nearest integer (breaking ties away from zero), rather + -- than truncated towards zero as usual. These rounded integer operations + -- are the result of expansion of rounded fixed-point divide, conversion + -- and multiplication operations. + + -- SCIL_Entity (Node4-Sem) + -- Present in SCIL nodes. Used to reference the tagged type associated + -- with the SCIL node. + + -- SCIL_Controlling_Tag (Node5-Sem) + -- Present in N_SCIL_Dispatching_Call nodes. Used to reference the + -- controlling tag of a dispatching call. + + -- SCIL_Tag_Value (Node5-Sem) + -- Present in N_SCIL_Membership_Test nodes. Used to reference the tag + -- value that is being tested. + + -- SCIL_Target_Prim (Node2-Sem) + -- Present in N_SCIL_Dispatching_Call nodes. Used to reference the tagged + -- type primitive associated with the SCIL node. + + -- Scope (Node3-Sem) + -- Present in defining identifiers, defining character literals and + -- defining operator symbols (i.e. in all entities). The entities of a + -- scope all use this field to reference the corresponding scope entity. + -- See Einfo for further details. + + -- Shift_Count_OK (Flag4-Sem) + -- A flag present in shift nodes to indicate that the shift count is + -- known to be in range, i.e. is in the range from zero to word length + -- minus one. If this flag is not set, then the shift count may be + -- outside this range, i.e. larger than the word length, and the code + -- must ensure that such shift counts give the appropriate result. + + -- Source_Type (Node1-Sem) + -- Used in an N_Validate_Unchecked_Conversion node to point to the + -- source type entity for the unchecked conversion instantiation + -- which gigi must do size validation for. + + -- Split_PPC (Flag17) + -- When a Pre or Postaspect specification is processed, it is broken + -- into AND THEN sections. The left most section has Split_PPC set to + -- False, indicating that it is the original specification (e.g. for + -- posting errors). For other sections, Split_PPC is set to True. + -- This flag is set in both the N_Aspect_Specification node itself, + -- and in the pragma which is generated from this node. + + -- Static_Processing_OK (Flag4-Sem) + -- Present in N_Aggregate nodes. When the Compile_Time_Known_Aggregate + -- flag is set, the full value of the aggregate can be determined at + -- compile time and the aggregate can be passed as is to the back-end. + -- In this event it is irrelevant whether this flag is set or not. + -- However, if the flag Compile_Time_Known_Aggregate is not set but + -- Static_Processing_OK is set, the aggregate can (but need not) be + -- converted into a compile time known aggregate by the expander. See + -- Sem_Aggr for the specific conditions under which an aggregate has its + -- Static_Processing_OK flag set. + + -- Storage_Pool (Node1-Sem) + -- Present in N_Allocator, N_Free_Statement, N_Simple_Return_Statement, + -- and N_Extended_Return_Statement nodes. References the entity for the + -- storage pool to be used for the allocate or free call or for the + -- allocation of the returned value from function. Empty indicates that + -- the global default pool is to be used. Note that in the case + -- of a return statement, this field is set only if the function returns + -- value of a type whose size is not known at compile time on the + -- secondary stack. + + -- Suppress_Assignment_Checks (Flag18-Sem) + -- Used in generated N_Assignment_Statement nodes to suppress predicate + -- and range checks in cases where the generated code knows that the + -- value being assigned is in range and satisfies any predicate. Also + -- can be set in N_Object_Declaration nodes, to similarly suppress any + -- checks on the initializing value. + + -- Suppress_Loop_Warnings (Flag17-Sem) + -- Used in N_Loop_Statement node to indicate that warnings within the + -- body of the loop should be suppressed. This is set when the range + -- of a FOR loop is known to be null, or is probably null (loop would + -- only execute if invalid values are present). + + -- Target_Type (Node2-Sem) + -- Used in an N_Validate_Unchecked_Conversion node to point to the target + -- type entity for the unchecked conversion instantiation which gigi must + -- do size validation for. + + -- Then_Actions (List3-Sem) + -- This field is present in conditional expression nodes. During code + -- expansion we use the Insert_Actions procedure (in Exp_Util) to insert + -- actions at an appropriate place in the tree to get elaborated at the + -- right time. For conditional expressions, we have to be sure that the + -- actions for the Then branch are only elaborated if the condition is + -- True. The Then_Actions field is used as a temporary parking place for + -- these actions. The final tree is always rewritten to eliminate the + -- need for this field, so in the tree passed to Gigi, this field is + -- always set to No_List. + + -- Treat_Fixed_As_Integer (Flag14-Sem) + -- This flag appears in operator nodes for divide, multiply, mod and rem + -- on fixed-point operands. It indicates that the operands are to be + -- treated as integer values, ignoring small values. This flag is only + -- set as a result of expansion of fixed-point operations. Typically a + -- fixed-point multiplication in the source generates subsidiary + -- multiplication and division operations that work with the underlying + -- integer values and have this flag set. Note that this flag is not + -- needed on other arithmetic operations (add, neg, subtract etc.) since + -- in these cases it is always the case that fixed is treated as integer. + -- The Etype field MUST be set if this flag is set. The analyzer knows to + -- leave such nodes alone, and whoever makes them must set the correct + -- Etype value. + + -- TSS_Elist (Elist3-Sem) + -- Present in N_Freeze_Entity nodes. Holds an element list containing + -- entries for each TSS (type support subprogram) associated with the + -- frozen type. The elements of the list are the entities for the + -- subprograms (see package Exp_TSS for further details). Set to No_Elist + -- if there are no type support subprograms for the type or if the freeze + -- node is not for a type. + + -- Unreferenced_In_Spec (Flag7-Sem) + -- Present in N_With_Clause nodes. Set if the with clause is on the + -- package or subprogram spec where the main unit is the corresponding + -- body, and is not referenced by the spec (it may still be referenced by + -- the body, so this flag is used to generate the proper message (see + -- Sem_Util.Check_Unused_Withs for details) + + -- Was_Originally_Stub (Flag13-Sem) + -- This flag is set in the node for a proper body that replaces stub. + -- During the analysis procedure, stubs in some situations get rewritten + -- by the corresponding bodies, and we set this flag to remember that + -- this happened. Note that it is not good enough to rely on the use of + -- Original_Node here because of the case of nested instantiations where + -- the substituted node can be copied. + + -- Withed_Body (Node1-Sem) + -- Present in N_With_Clause nodes. Set if the unit in whose context + -- the with_clause appears instantiates a generic contained in the + -- library unit of the with_clause and as a result loads its body. + -- Used for a more precise unit traversal for CodePeer. + + -- Zero_Cost_Handling (Flag5-Sem) + -- This flag is set in all handled sequence of statement and exception + -- handler nodes if exceptions are to be handled using the zero-cost + -- mechanism (see Ada.Exceptions and System.Exceptions in files + -- a-except.ads/adb and s-except.ads for full details). What gigi needs + -- to do for such a handler is simply to put the code in the handler + -- somewhere. The front end has generated all necessary labels. + + -------------------------------------------------- + -- Note on Use of End_Label and End_Span Fields -- + -------------------------------------------------- + + -- Several constructs have end lines: + + -- Loop Statement end loop [loop_IDENTIFIER]; + -- Package Specification end [[PARENT_UNIT_NAME .] IDENTIFIER] + -- Task Definition end [task_IDENTIFIER] + -- Protected Definition end [protected_IDENTIFIER] + -- Protected Body end [protected_IDENTIFIER] + + -- Block Statement end [block_IDENTIFIER]; + -- Subprogram Body end [DESIGNATOR]; + -- Package Body end [[PARENT_UNIT_NAME .] IDENTIFIER]; + -- Task Body end [task_IDENTIFIER]; + -- Accept Statement end [entry_IDENTIFIER]]; + -- Entry Body end [entry_IDENTIFIER]; + + -- If Statement end if; + -- Case Statement end case; + + -- Record Definition end record; + -- Enumeration Definition ); + + -- The End_Label and End_Span fields are used to mark the locations of + -- these lines, and also keep track of the label in the case where a label + -- is present. + + -- For the first group above, the End_Label field of the corresponding node + -- is used to point to the label identifier. In the case where there is no + -- label in the source, the parser supplies a dummy identifier (with + -- Comes_From_Source set to False), and the Sloc of this dummy identifier + -- marks the location of the token following the END token. + + -- For the second group, the use of End_Label is similar, but the End_Label + -- is found in the N_Handled_Sequence_Of_Statements node. This is done + -- simply because in some cases there is no room in the parent node. + + -- For the third group, there is never any label, and instead of using + -- End_Label, we use the End_Span field which gives the location of the + -- token following END, relative to the starting Sloc of the construct, + -- i.e. add Sloc (Node) + End_Span (Node) to get the Sloc of the IF or CASE + -- following the End_Label. + + -- The record definition case is handled specially, we treat it as though + -- it required an optional label which is never present, and so the parser + -- always builds a dummy identifier with Comes From Source set False. The + -- reason we do this, rather than using End_Span in this case, is that we + -- want to generate a cross-ref entry for the end of a record, since it + -- represents a scope for name declaration purposes. + + -- The enumeration definition case is handled in an exactly similar manner, + -- building a dummy identifier to get a cross-reference. + + -- Note: the reason we store the difference as a Uint, instead of storing + -- the Source_Ptr value directly, is that Source_Ptr values cannot be + -- distinguished from other types of values, and we count on all general + -- use fields being self describing. To make things easier for clients, + -- note that we provide function End_Location, and procedure + -- Set_End_Location to allow access to the logical value (which is the + -- Source_Ptr value for the end token). + + --------------------- + -- Syntactic Nodes -- + --------------------- + + --------------------- + -- 2.3 Identifier -- + --------------------- + + -- IDENTIFIER ::= IDENTIFIER_LETTER {[UNDERLINE] LETTER_OR_DIGIT} + -- LETTER_OR_DIGIT ::= IDENTIFIER_LETTER | DIGIT + + -- An IDENTIFIER shall not be a reserved word + + -- In the Ada grammar identifiers are the bottom level tokens which have + -- very few semantics. Actual program identifiers are direct names. If + -- we were being 100% honest with the grammar, then we would have a node + -- called N_Direct_Name which would point to an identifier. However, + -- that's too many extra nodes, so we just use the N_Identifier node + -- directly as a direct name, and it contains the expression fields and + -- Entity field that correspond to its use as a direct name. In those + -- few cases where identifiers appear in contexts where they are not + -- direct names (pragmas, pragma argument associations, attribute + -- references and attribute definition clauses), the Chars field of the + -- node contains the Name_Id for the identifier name. + + -- Note: in GNAT, a reserved word can be treated as an identifier in two + -- cases. First, an incorrect use of a reserved word as an identifier is + -- diagnosed and then treated as a normal identifier. Second, an + -- attribute designator of the form of a reserved word (access, delta, + -- digits, range) is treated as an identifier. + + -- Note: The set of letters that is permitted in an identifier depends + -- on the character set in use. See package Csets for full details. + + -- N_Identifier + -- Sloc points to identifier + -- Chars (Name1) contains the Name_Id for the identifier + -- Entity (Node4-Sem) + -- Associated_Node (Node4-Sem) + -- Original_Discriminant (Node2-Sem) + -- Redundant_Use (Flag13-Sem) + -- Has_Private_View (Flag11-Sem) (set in generic units) + -- plus fields for expression + + -------------------------- + -- 2.4 Numeric Literal -- + -------------------------- + + -- NUMERIC_LITERAL ::= DECIMAL_LITERAL | BASED_LITERAL + + ---------------------------- + -- 2.4.1 Decimal Literal -- + ---------------------------- + + -- DECIMAL_LITERAL ::= NUMERAL [.NUMERAL] [EXPONENT] + + -- NUMERAL ::= DIGIT {[UNDERLINE] DIGIT} + + -- EXPONENT ::= E [+] NUMERAL | E - NUMERAL + + -- Decimal literals appear in the tree as either integer literal nodes + -- or real literal nodes, depending on whether a period is present. + + -- Note: literal nodes appear as a result of direct use of literals + -- in the source program, and also as the result of evaluating + -- expressions at compile time. In the latter case, it is possible + -- to construct real literals that have no syntactic representation + -- using the standard literal format. Such literals are listed by + -- Sprint using the notation [numerator / denominator]. + + -- Note: the value of an integer literal node created by the front end + -- is never outside the range of values of the base type. However, it + -- can be the case that the created value is outside the range of the + -- particular subtype. This happens in the case of integer overflows + -- with checks suppressed. + + -- N_Integer_Literal + -- Sloc points to literal + -- Original_Entity (Node2-Sem) If not Empty, holds Named_Number that + -- has been constant-folded into its literal value. + -- Intval (Uint3) contains integer value of literal + -- plus fields for expression + -- Print_In_Hex (Flag13-Sem) + + -- N_Real_Literal + -- Sloc points to literal + -- Original_Entity (Node2-Sem) If not Empty, holds Named_Number that + -- has been constant-folded into its literal value. + -- Realval (Ureal3) contains real value of literal + -- Corresponding_Integer_Value (Uint4-Sem) + -- Is_Machine_Number (Flag11-Sem) + -- plus fields for expression + + -------------------------- + -- 2.4.2 Based Literal -- + -------------------------- + + -- BASED_LITERAL ::= + -- BASE # BASED_NUMERAL [.BASED_NUMERAL] # [EXPONENT] + + -- BASE ::= NUMERAL + + -- BASED_NUMERAL ::= + -- EXTENDED_DIGIT {[UNDERLINE] EXTENDED_DIGIT} + + -- EXTENDED_DIGIT ::= DIGIT | A | B | C | D | E | F + + -- Based literals appear in the tree as either integer literal nodes + -- or real literal nodes, depending on whether a period is present. + + ---------------------------- + -- 2.5 Character Literal -- + ---------------------------- + + -- CHARACTER_LITERAL ::= ' GRAPHIC_CHARACTER ' + + -- N_Character_Literal + -- Sloc points to literal + -- Chars (Name1) contains the Name_Id for the identifier + -- Char_Literal_Value (Uint2) contains the literal value + -- Entity (Node4-Sem) + -- Associated_Node (Node4-Sem) + -- Has_Private_View (Flag11-Sem) set in generic units. + -- plus fields for expression + + -- Note: the Entity field will be missing (set to Empty) for character + -- literals whose type is Standard.Wide_Character or Standard.Character + -- or a type derived from one of these two. In this case the character + -- literal stands for its own coding. The reason we take this irregular + -- short cut is to avoid the need to build lots of junk defining + -- character literal nodes. + + ------------------------- + -- 2.6 String Literal -- + ------------------------- + + -- STRING LITERAL ::= "{STRING_ELEMENT}" + + -- A STRING_ELEMENT is either a pair of quotation marks ("), or a + -- single GRAPHIC_CHARACTER other than a quotation mark. + -- + -- Is_Folded_In_Parser is True if the parser created this literal by + -- folding a sequence of "&" operators. For example, if the source code + -- says "aaa" & "bbb" & "ccc", and this produces "aaabbbccc", the flag + -- is set. This flag is needed because the parser doesn't know about + -- visibility, so the folded result might be wrong, and semantic + -- analysis needs to check for that. + + -- N_String_Literal + -- Sloc points to literal + -- Strval (Str3) contains Id of string value + -- Has_Wide_Character (Flag11-Sem) + -- Has_Wide_Wide_Character (Flag13-Sem) + -- Is_Folded_In_Parser (Flag4) + -- plus fields for expression + + ------------------ + -- 2.7 Comment -- + ------------------ + + -- A COMMENT starts with two adjacent hyphens and extends up to the + -- end of the line. A COMMENT may appear on any line of a program. + + -- Comments are skipped by the scanner and do not appear in the tree. + -- It is possible to reconstruct the position of comments with respect + -- to the elements of the tree by using the source position (Sloc) + -- pointers that appear in every tree node. + + ----------------- + -- 2.8 Pragma -- + ----------------- + + -- PRAGMA ::= pragma IDENTIFIER + -- [(PRAGMA_ARGUMENT_ASSOCIATION {, PRAGMA_ARGUMENT_ASSOCIATION})]; + + -- Note that a pragma may appear in the tree anywhere a declaration + -- or a statement may appear, as well as in some other situations + -- which are explicitly documented. + + -- N_Pragma + -- Sloc points to PRAGMA + -- Next_Pragma (Node1-Sem) + -- Pragma_Argument_Associations (List2) (set to No_List if none) + -- Debug_Statement (Node3) (set to Empty if not Debug) + -- Pragma_Identifier (Node4) + -- Next_Rep_Item (Node5-Sem) + -- Pragma_Enabled (Flag5-Sem) + -- From_Aspect_Specification (Flag13-Sem) + -- Is_Delayed_Aspect (Flag14-Sem) + -- Import_Interface_Present (Flag16-Sem) + -- Aspect_Cancel (Flag11-Sem) + -- Split_PPC (Flag17) set if corresponding aspect had Split_PPC set + -- Class_Present (Flag6) set if from Aspect with 'Class + + -- Note: we should have a section on what pragmas are passed on to + -- the back end to be processed. This section should note that pragma + -- Psect_Object is always converted to Common_Object, but there are + -- undoubtedly many other similar notes required ??? + + -- Note: a utility function Pragma_Name may be applied to pragma nodes + -- to conveniently obtain the Chars field of the Pragma_Identifier. + + -- Note: if From_Aspect_Specification is set, then Sloc points to the + -- aspect name, as does the Pragma_Identifier. In this case if the + -- pragma has a local name argument (such as pragma Inline), it is + -- resolved to point to the specific entity affected by the pragma. + + -------------------------------------- + -- 2.8 Pragma Argument Association -- + -------------------------------------- + + -- PRAGMA_ARGUMENT_ASSOCIATION ::= + -- [pragma_argument_IDENTIFIER =>] NAME + -- | [pragma_argument_IDENTIFIER =>] EXPRESSION + + -- N_Pragma_Argument_Association + -- Sloc points to first token in association + -- Chars (Name1) (set to No_Name if no pragma argument identifier) + -- Expression (Node3) + + ------------------------ + -- 2.9 Reserved Word -- + ------------------------ + + -- Reserved words are parsed by the scanner, and returned as the + -- corresponding token types (e.g. PACKAGE is returned as Tok_Package) + + ---------------------------- + -- 3.1 Basic Declaration -- + ---------------------------- + + -- BASIC_DECLARATION ::= + -- TYPE_DECLARATION | SUBTYPE_DECLARATION + -- | OBJECT_DECLARATION | NUMBER_DECLARATION + -- | SUBPROGRAM_DECLARATION | ABSTRACT_SUBPROGRAM_DECLARATION + -- | PACKAGE_DECLARATION | RENAMING_DECLARATION + -- | EXCEPTION_DECLARATION | GENERIC_DECLARATION + -- | GENERIC_INSTANTIATION + + -- Basic declaration also includes IMPLICIT_LABEL_DECLARATION + -- see further description in section on semantic nodes. + + -- Also, in the tree that is constructed, a pragma may appear + -- anywhere that a declaration may appear. + + ------------------------------ + -- 3.1 Defining Identifier -- + ------------------------------ + + -- DEFINING_IDENTIFIER ::= IDENTIFIER + + -- A defining identifier is an entity, which has additional fields + -- depending on the setting of the Ekind field. These additional + -- fields are defined (and access subprograms declared) in package + -- Einfo. + + -- Note: N_Defining_Identifier is an extended node whose fields are + -- deliberate layed out to match the layout of fields in an ordinary + -- N_Identifier node allowing for easy alteration of an identifier + -- node into a defining identifier node. For details, see procedure + -- Sinfo.CN.Change_Identifier_To_Defining_Identifier. + + -- N_Defining_Identifier + -- Sloc points to identifier + -- Chars (Name1) contains the Name_Id for the identifier + -- Next_Entity (Node2-Sem) + -- Scope (Node3-Sem) + -- Etype (Node5-Sem) + + ----------------------------- + -- 3.2.1 Type Declaration -- + ----------------------------- + + -- TYPE_DECLARATION ::= + -- FULL_TYPE_DECLARATION + -- | INCOMPLETE_TYPE_DECLARATION + -- | PRIVATE_TYPE_DECLARATION + -- | PRIVATE_EXTENSION_DECLARATION + + ---------------------------------- + -- 3.2.1 Full Type Declaration -- + ---------------------------------- + + -- FULL_TYPE_DECLARATION ::= + -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] + -- is TYPE_DEFINITION + -- [ASPECT_SPECIFICATIONS]; + + -- | TASK_TYPE_DECLARATION + -- | PROTECTED_TYPE_DECLARATION + + -- The full type declaration node is used only for the first case. The + -- second case (concurrent type declaration), is represented directly + -- by a task type declaration or a protected type declaration. + + -- N_Full_Type_Declaration + -- Sloc points to TYPE + -- Defining_Identifier (Node1) + -- Discriminant_Specifications (List4) (set to No_List if none) + -- Type_Definition (Node3) + -- Discr_Check_Funcs_Built (Flag11-Sem) + + ---------------------------- + -- 3.2.1 Type Definition -- + ---------------------------- + + -- TYPE_DEFINITION ::= + -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION + -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION + -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION + -- | DERIVED_TYPE_DEFINITION | INTERFACE_TYPE_DEFINITION + + -------------------------------- + -- 3.2.2 Subtype Declaration -- + -------------------------------- + + -- SUBTYPE_DECLARATION ::= + -- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION; + + -- The subtype indication field is set to Empty for subtypes + -- declared in package Standard (Positive, Natural). + + -- N_Subtype_Declaration + -- Sloc points to SUBTYPE + -- Defining_Identifier (Node1) + -- Null_Exclusion_Present (Flag11) + -- Subtype_Indication (Node5) + -- Generic_Parent_Type (Node4-Sem) (set for an actual derived type). + -- Exception_Junk (Flag8-Sem) + + ------------------------------- + -- 3.2.2 Subtype Indication -- + ------------------------------- + + -- SUBTYPE_INDICATION ::= SUBTYPE_MARK [CONSTRAINT] + + -- Note: if no constraint is present, the subtype indication appears + -- directly in the tree as a subtype mark. The N_Subtype_Indication + -- node is used only if a constraint is present. + + -- Note: [For Ada 2005 (AI-231)]: Because Ada 2005 extends this rule + -- with the null-exclusion part (see AI-231), we had to introduce a new + -- attribute in all the parents of subtype_indication nodes to indicate + -- if the null-exclusion is present. + + -- Note: the reason that this node has expression fields is that a + -- subtype indication can appear as an operand of a membership test. + + -- N_Subtype_Indication + -- Sloc points to first token of subtype mark + -- Subtype_Mark (Node4) + -- Constraint (Node3) + -- Etype (Node5-Sem) + -- Must_Not_Freeze (Flag8-Sem) + + -- Note: Etype is a copy of the Etype field of the Subtype_Mark. The + -- reason for this redundancy is so that in a list of array index types, + -- the Etype can be uniformly accessed to determine the subscript type. + -- This means that no Itype is constructed for the actual subtype that + -- is created by the subtype indication. If such an Itype is required, + -- it is constructed in the context in which the indication appears. + + ------------------------- + -- 3.2.2 Subtype Mark -- + ------------------------- + + -- SUBTYPE_MARK ::= subtype_NAME + + ----------------------- + -- 3.2.2 Constraint -- + ----------------------- + + -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT + + ------------------------------ + -- 3.2.2 Scalar Constraint -- + ------------------------------ + + -- SCALAR_CONSTRAINT ::= + -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT + + --------------------------------- + -- 3.2.2 Composite Constraint -- + --------------------------------- + + -- COMPOSITE_CONSTRAINT ::= + -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT + + ------------------------------- + -- 3.3.1 Object Declaration -- + ------------------------------- + + -- OBJECT_DECLARATION ::= + -- DEFINING_IDENTIFIER_LIST : [aliased] [constant] + -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; + -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] + -- ACCESS_DEFINITION [:= EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; + -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] + -- ARRAY_TYPE_DEFINITION [:= EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; + -- | SINGLE_TASK_DECLARATION + -- | SINGLE_PROTECTED_DECLARATION + + -- Note: aliased is not permitted in Ada 83 mode + + -- The N_Object_Declaration node is only for the first two cases. + -- Single task declaration is handled by P_Task (9.1) + -- Single protected declaration is handled by P_protected (9.5) + + -- Although the syntax allows multiple identifiers in the list, the + -- semantics is as though successive declarations were given with + -- identical type definition and expression components. To simplify + -- semantic processing, the parser represents a multiple declaration + -- case as a sequence of single declarations, using the More_Ids and + -- Prev_Ids flags to preserve the original source form as described + -- in the section on "Handling of Defining Identifier Lists". + + -- The flag Has_Init_Expression is set if an initializing expression + -- is present. Normally it is set if and only if Expression contains + -- a non-empty value, but there is an exception to this. When the + -- initializing expression is an aggregate which requires explicit + -- assignments, the Expression field gets set to Empty, but this flag + -- is still set, so we don't forget we had an initializing expression. + + -- Note: if a range check is required for the initialization + -- expression then the Do_Range_Check flag is set in the Expression, + -- with the check being done against the type given by the object + -- definition, which is also the Etype of the defining identifier. + + -- Note: the contents of the Expression field must be ignored (i.e. + -- treated as though it were Empty) if No_Initialization is set True. + + -- Note: the back end places some restrictions on the form of the + -- Expression field. If the object being declared is Atomic, then + -- the Expression may not have the form of an aggregate (since this + -- might cause the back end to generate separate assignments). In this + -- case the front end must generate an extra temporary and initialize + -- this temporary as required (the temporary itself is not atomic). + + -- Note: there is not node kind for object definition. Instead, the + -- corresponding field holds a subtype indication, an array type + -- definition, or (Ada 2005, AI-406) an access definition. + + -- N_Object_Declaration + -- Sloc points to first identifier + -- Defining_Identifier (Node1) + -- Aliased_Present (Flag4) set if ALIASED appears + -- Constant_Present (Flag17) set if CONSTANT appears + -- Null_Exclusion_Present (Flag11) + -- Object_Definition (Node4) subtype indic./array type def./access def. + -- Expression (Node3) (set to Empty if not present) + -- Handler_List_Entry (Node2-Sem) + -- Corresponding_Generic_Association (Node5-Sem) + -- More_Ids (Flag5) (set to False if no more identifiers in list) + -- Prev_Ids (Flag6) (set to False if no previous identifiers in list) + -- No_Initialization (Flag13-Sem) + -- Assignment_OK (Flag15-Sem) + -- Exception_Junk (Flag8-Sem) + -- Is_Subprogram_Descriptor (Flag16-Sem) + -- Has_Init_Expression (Flag14) + -- Suppress_Assignment_Checks (Flag18-Sem) + + ------------------------------------- + -- 3.3.1 Defining Identifier List -- + ------------------------------------- + + -- DEFINING_IDENTIFIER_LIST ::= + -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER} + + ------------------------------- + -- 3.3.2 Number Declaration -- + ------------------------------- + + -- NUMBER_DECLARATION ::= + -- DEFINING_IDENTIFIER_LIST : constant := static_EXPRESSION; + + -- Although the syntax allows multiple identifiers in the list, the + -- semantics is as though successive declarations were given with + -- identical expressions. To simplify semantic processing, the parser + -- represents a multiple declaration case as a sequence of single + -- declarations, using the More_Ids and Prev_Ids flags to preserve + -- the original source form as described in the section on "Handling + -- of Defining Identifier Lists". + + -- N_Number_Declaration + -- Sloc points to first identifier + -- Defining_Identifier (Node1) + -- Expression (Node3) + -- More_Ids (Flag5) (set to False if no more identifiers in list) + -- Prev_Ids (Flag6) (set to False if no previous identifiers in list) + + ---------------------------------- + -- 3.4 Derived Type Definition -- + ---------------------------------- + + -- DERIVED_TYPE_DEFINITION ::= + -- [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION + -- [[and INTERFACE_LIST] RECORD_EXTENSION_PART] + + -- Note: ABSTRACT, LIMITED and record extension part are not permitted + -- in Ada 83 mode + + -- Note: a record extension part is required if ABSTRACT is present + + -- N_Derived_Type_Definition + -- Sloc points to NEW + -- Abstract_Present (Flag4) + -- Null_Exclusion_Present (Flag11) (set to False if not present) + -- Subtype_Indication (Node5) + -- Record_Extension_Part (Node3) (set to Empty if not present) + -- Limited_Present (Flag17) + -- Task_Present (Flag5) set in task interfaces + -- Protected_Present (Flag6) set in protected interfaces + -- Synchronized_Present (Flag7) set in interfaces + -- Interface_List (List2) (set to No_List if none) + -- Interface_Present (Flag16) set in abstract interfaces + + -- Note: Task_Present, Protected_Present, Synchronized_Present, + -- Interface_List, and Interface_Present are used for abstract + -- interfaces (see comments for INTERFACE_TYPE_DEFINITION). + + --------------------------- + -- 3.5 Range Constraint -- + --------------------------- + + -- RANGE_CONSTRAINT ::= range RANGE + + -- N_Range_Constraint + -- Sloc points to RANGE + -- Range_Expression (Node4) + + ---------------- + -- 3.5 Range -- + ---------------- + + -- RANGE ::= + -- RANGE_ATTRIBUTE_REFERENCE + -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION + + -- Note: the case of a range given as a range attribute reference + -- appears directly in the tree as an attribute reference. + + -- Note: the field name for a reference to a range is Range_Expression + -- rather than Range, because range is a reserved keyword in Ada! + + -- Note: the reason that this node has expression fields is that a + -- range can appear as an operand of a membership test. The Etype + -- field is the type of the range (we do NOT construct an implicit + -- subtype to represent the range exactly). + + -- N_Range + -- Sloc points to .. + -- Low_Bound (Node1) + -- High_Bound (Node2) + -- Includes_Infinities (Flag11) + -- plus fields for expression + + -- Note: if the range appears in a context, such as a subtype + -- declaration, where range checks are required on one or both of + -- the expression fields, then type conversion nodes are inserted + -- to represent the required checks. + + ---------------------------------------- + -- 3.5.1 Enumeration Type Definition -- + ---------------------------------------- + + -- ENUMERATION_TYPE_DEFINITION ::= + -- (ENUMERATION_LITERAL_SPECIFICATION + -- {, ENUMERATION_LITERAL_SPECIFICATION}) + + -- Note: the Literals field in the node described below is null for + -- the case of the standard types CHARACTER and WIDE_CHARACTER, for + -- which special processing handles these types as special cases. + + -- N_Enumeration_Type_Definition + -- Sloc points to left parenthesis + -- Literals (List1) (Empty for CHARACTER or WIDE_CHARACTER) + -- End_Label (Node4) (set to Empty if internally generated record) + + ---------------------------------------------- + -- 3.5.1 Enumeration Literal Specification -- + ---------------------------------------------- + + -- ENUMERATION_LITERAL_SPECIFICATION ::= + -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL + + --------------------------------------- + -- 3.5.1 Defining Character Literal -- + --------------------------------------- + + -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL + + -- A defining character literal is an entity, which has additional + -- fields depending on the setting of the Ekind field. These + -- additional fields are defined (and access subprograms declared) + -- in package Einfo. + + -- Note: N_Defining_Character_Literal is an extended node whose fields + -- are deliberate layed out to match the layout of fields in an ordinary + -- N_Character_Literal node allowing for easy alteration of a character + -- literal node into a defining character literal node. For details, see + -- Sinfo.CN.Change_Character_Literal_To_Defining_Character_Literal. + + -- N_Defining_Character_Literal + -- Sloc points to literal + -- Chars (Name1) contains the Name_Id for the identifier + -- Next_Entity (Node2-Sem) + -- Scope (Node3-Sem) + -- Etype (Node5-Sem) + + ------------------------------------ + -- 3.5.4 Integer Type Definition -- + ------------------------------------ + + -- Note: there is an error in this rule in the latest version of the + -- grammar, so we have retained the old rule pending clarification. + + -- INTEGER_TYPE_DEFINITION ::= + -- SIGNED_INTEGER_TYPE_DEFINITION + -- | MODULAR_TYPE_DEFINITION + + ------------------------------------------- + -- 3.5.4 Signed Integer Type Definition -- + ------------------------------------------- + + -- SIGNED_INTEGER_TYPE_DEFINITION ::= + -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION + + -- Note: the Low_Bound and High_Bound fields are set to Empty + -- for integer types defined in package Standard. + + -- N_Signed_Integer_Type_Definition + -- Sloc points to RANGE + -- Low_Bound (Node1) + -- High_Bound (Node2) + + ------------------------------------ + -- 3.5.4 Modular Type Definition -- + ------------------------------------ + + -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION + + -- N_Modular_Type_Definition + -- Sloc points to MOD + -- Expression (Node3) + + --------------------------------- + -- 3.5.6 Real Type Definition -- + --------------------------------- + + -- REAL_TYPE_DEFINITION ::= + -- FLOATING_POINT_DEFINITION | FIXED_POINT_DEFINITION + + -------------------------------------- + -- 3.5.7 Floating Point Definition -- + -------------------------------------- + + -- FLOATING_POINT_DEFINITION ::= + -- digits static_SIMPLE_EXPRESSION [REAL_RANGE_SPECIFICATION] + + -- Note: The Digits_Expression and Real_Range_Specifications fields + -- are set to Empty for floating-point types declared in Standard. + + -- N_Floating_Point_Definition + -- Sloc points to DIGITS + -- Digits_Expression (Node2) + -- Real_Range_Specification (Node4) (set to Empty if not present) + + ------------------------------------- + -- 3.5.7 Real Range Specification -- + ------------------------------------- + + -- REAL_RANGE_SPECIFICATION ::= + -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION + + -- N_Real_Range_Specification + -- Sloc points to RANGE + -- Low_Bound (Node1) + -- High_Bound (Node2) + + ----------------------------------- + -- 3.5.9 Fixed Point Definition -- + ----------------------------------- + + -- FIXED_POINT_DEFINITION ::= + -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION + + -------------------------------------------- + -- 3.5.9 Ordinary Fixed Point Definition -- + -------------------------------------------- + + -- ORDINARY_FIXED_POINT_DEFINITION ::= + -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION + + -- Note: In Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION + + -- N_Ordinary_Fixed_Point_Definition + -- Sloc points to DELTA + -- Delta_Expression (Node3) + -- Real_Range_Specification (Node4) + + ------------------------------------------- + -- 3.5.9 Decimal Fixed Point Definition -- + ------------------------------------------- + + -- DECIMAL_FIXED_POINT_DEFINITION ::= + -- delta static_EXPRESSION + -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION] + + -- Note: decimal types are not permitted in Ada 83 mode + + -- N_Decimal_Fixed_Point_Definition + -- Sloc points to DELTA + -- Delta_Expression (Node3) + -- Digits_Expression (Node2) + -- Real_Range_Specification (Node4) (set to Empty if not present) + + ------------------------------ + -- 3.5.9 Digits Constraint -- + ------------------------------ + + -- DIGITS_CONSTRAINT ::= + -- digits static_EXPRESSION [RANGE_CONSTRAINT] + + -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION + -- Note: in Ada 95, reduced accuracy subtypes are obsolescent + + -- N_Digits_Constraint + -- Sloc points to DIGITS + -- Digits_Expression (Node2) + -- Range_Constraint (Node4) (set to Empty if not present) + + -------------------------------- + -- 3.6 Array Type Definition -- + -------------------------------- + + -- ARRAY_TYPE_DEFINITION ::= + -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION + + ----------------------------------------- + -- 3.6 Unconstrained Array Definition -- + ----------------------------------------- + + -- UNCONSTRAINED_ARRAY_DEFINITION ::= + -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of + -- COMPONENT_DEFINITION + + -- Note: dimensionality of array is indicated by number of entries in + -- the Subtype_Marks list, which has one entry for each dimension. + + -- N_Unconstrained_Array_Definition + -- Sloc points to ARRAY + -- Subtype_Marks (List2) + -- Component_Definition (Node4) + + ----------------------------------- + -- 3.6 Index Subtype Definition -- + ----------------------------------- + + -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <> + + -- There is no explicit node in the tree for an index subtype + -- definition since the N_Unconstrained_Array_Definition node + -- incorporates the type marks which appear in this context. + + --------------------------------------- + -- 3.6 Constrained Array Definition -- + --------------------------------------- + + -- CONSTRAINED_ARRAY_DEFINITION ::= + -- array (DISCRETE_SUBTYPE_DEFINITION + -- {, DISCRETE_SUBTYPE_DEFINITION}) + -- of COMPONENT_DEFINITION + + -- Note: dimensionality of array is indicated by number of entries + -- in the Discrete_Subtype_Definitions list, which has one entry + -- for each dimension. + + -- N_Constrained_Array_Definition + -- Sloc points to ARRAY + -- Discrete_Subtype_Definitions (List2) + -- Component_Definition (Node4) + + -------------------------------------- + -- 3.6 Discrete Subtype Definition -- + -------------------------------------- + + -- DISCRETE_SUBTYPE_DEFINITION ::= + -- discrete_SUBTYPE_INDICATION | RANGE + + ------------------------------- + -- 3.6 Component Definition -- + ------------------------------- + + -- COMPONENT_DEFINITION ::= + -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION + + -- Note: although the syntax does not permit a component definition to + -- be an anonymous array (and the parser will diagnose such an attempt + -- with an appropriate message), it is possible for anonymous arrays + -- to appear as component definitions. The semantics and back end handle + -- this case properly, and the expander in fact generates such cases. + -- Access_Definition is an optional field that gives support to + -- Ada 2005 (AI-230). The parser generates nodes that have either the + -- Subtype_Indication field or else the Access_Definition field. + + -- N_Component_Definition + -- Sloc points to ALIASED, ACCESS or to first token of subtype mark + -- Aliased_Present (Flag4) + -- Null_Exclusion_Present (Flag11) + -- Subtype_Indication (Node5) (set to Empty if not present) + -- Access_Definition (Node3) (set to Empty if not present) + + ----------------------------- + -- 3.6.1 Index Constraint -- + ----------------------------- + + -- INDEX_CONSTRAINT ::= (DISCRETE_RANGE {, DISCRETE_RANGE}) + + -- It is not in general possible to distinguish between discriminant + -- constraints and index constraints at parse time, since a simple + -- name could be either the subtype mark of a discrete range, or an + -- expression in a discriminant association with no name. Either + -- entry appears simply as the name, and the semantic parse must + -- distinguish between the two cases. Thus we use a common tree + -- node format for both of these constraint types. + + -- See Discriminant_Constraint for format of node + + --------------------------- + -- 3.6.1 Discrete Range -- + --------------------------- + + -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE + + ---------------------------- + -- 3.7 Discriminant Part -- + ---------------------------- + + -- DISCRIMINANT_PART ::= + -- UNKNOWN_DISCRIMINANT_PART | KNOWN_DISCRIMINANT_PART + + ------------------------------------ + -- 3.7 Unknown Discriminant Part -- + ------------------------------------ + + -- UNKNOWN_DISCRIMINANT_PART ::= (<>) + + -- Note: unknown discriminant parts are not permitted in Ada 83 mode + + -- There is no explicit node in the tree for an unknown discriminant + -- part. Instead the Unknown_Discriminants_Present flag is set in the + -- parent node. + + ---------------------------------- + -- 3.7 Known Discriminant Part -- + ---------------------------------- + + -- KNOWN_DISCRIMINANT_PART ::= + -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION}) + + ------------------------------------- + -- 3.7 Discriminant Specification -- + ------------------------------------- + + -- DISCRIMINANT_SPECIFICATION ::= + -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK + -- [:= DEFAULT_EXPRESSION] + -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION + -- [:= DEFAULT_EXPRESSION] + + -- Although the syntax allows multiple identifiers in the list, the + -- semantics is as though successive specifications were given with + -- identical type definition and expression components. To simplify + -- semantic processing, the parser represents a multiple declaration + -- case as a sequence of single specifications, using the More_Ids and + -- Prev_Ids flags to preserve the original source form as described + -- in the section on "Handling of Defining Identifier Lists". + + -- N_Discriminant_Specification + -- Sloc points to first identifier + -- Defining_Identifier (Node1) + -- Null_Exclusion_Present (Flag11) + -- Discriminant_Type (Node5) subtype mark or access parameter definition + -- Expression (Node3) (set to Empty if no default expression) + -- More_Ids (Flag5) (set to False if no more identifiers in list) + -- Prev_Ids (Flag6) (set to False if no previous identifiers in list) + + ----------------------------- + -- 3.7 Default Expression -- + ----------------------------- + + -- DEFAULT_EXPRESSION ::= EXPRESSION + + ------------------------------------ + -- 3.7.1 Discriminant Constraint -- + ------------------------------------ + + -- DISCRIMINANT_CONSTRAINT ::= + -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION}) + + -- It is not in general possible to distinguish between discriminant + -- constraints and index constraints at parse time, since a simple + -- name could be either the subtype mark of a discrete range, or an + -- expression in a discriminant association with no name. Either + -- entry appears simply as the name, and the semantic parse must + -- distinguish between the two cases. Thus we use a common tree + -- node format for both of these constraint types. + + -- N_Index_Or_Discriminant_Constraint + -- Sloc points to left paren + -- Constraints (List1) points to list of discrete ranges or + -- discriminant associations + + ------------------------------------- + -- 3.7.1 Discriminant Association -- + ------------------------------------- + + -- DISCRIMINANT_ASSOCIATION ::= + -- [discriminant_SELECTOR_NAME + -- {| discriminant_SELECTOR_NAME} =>] EXPRESSION + + -- Note: a discriminant association that has no selector name list + -- appears directly as an expression in the tree. + + -- N_Discriminant_Association + -- Sloc points to first token of discriminant association + -- Selector_Names (List1) (always non-empty, since if no selector + -- names are present, this node is not used, see comment above) + -- Expression (Node3) + + --------------------------------- + -- 3.8 Record Type Definition -- + --------------------------------- + + -- RECORD_TYPE_DEFINITION ::= + -- [[abstract] tagged] [limited] RECORD_DEFINITION + + -- Note: ABSTRACT, TAGGED, LIMITED are not permitted in Ada 83 mode + + -- There is no explicit node in the tree for a record type definition. + -- Instead the flags for Tagged_Present and Limited_Present appear in + -- the N_Record_Definition node for a record definition appearing in + -- the context of a record type definition. + + ---------------------------- + -- 3.8 Record Definition -- + ---------------------------- + + -- RECORD_DEFINITION ::= + -- record + -- COMPONENT_LIST + -- end record + -- | null record + + -- Note: the Abstract_Present, Tagged_Present and Limited_Present + -- flags appear only for a record definition appearing in a record + -- type definition. + + -- Note: the NULL RECORD case is not permitted in Ada 83 + + -- N_Record_Definition + -- Sloc points to RECORD or NULL + -- End_Label (Node4) (set to Empty if internally generated record) + -- Abstract_Present (Flag4) + -- Tagged_Present (Flag15) + -- Limited_Present (Flag17) + -- Component_List (Node1) empty in null record case + -- Null_Present (Flag13) set in null record case + -- Task_Present (Flag5) set in task interfaces + -- Protected_Present (Flag6) set in protected interfaces + -- Synchronized_Present (Flag7) set in interfaces + -- Interface_Present (Flag16) set in abstract interfaces + -- Interface_List (List2) (set to No_List if none) + + -- Note: Task_Present, Protected_Present, Synchronized _Present, + -- Interface_List and Interface_Present are used for abstract + -- interfaces (see comments for INTERFACE_TYPE_DEFINITION). + + ------------------------- + -- 3.8 Component List -- + ------------------------- + + -- COMPONENT_LIST ::= + -- COMPONENT_ITEM {COMPONENT_ITEM} + -- | {COMPONENT_ITEM} VARIANT_PART + -- | null; + + -- N_Component_List + -- Sloc points to first token of component list + -- Component_Items (List3) + -- Variant_Part (Node4) (set to Empty if no variant part) + -- Null_Present (Flag13) + + ------------------------- + -- 3.8 Component Item -- + ------------------------- + + -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE + + -- Note: A component item can also be a pragma, and in the tree + -- that is obtained after semantic processing, a component item + -- can be an N_Null node resulting from a non-recognized pragma. + + -------------------------------- + -- 3.8 Component Declaration -- + -------------------------------- + + -- COMPONENT_DECLARATION ::= + -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION + -- [:= DEFAULT_EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; + + -- Note: although the syntax does not permit a component definition to + -- be an anonymous array (and the parser will diagnose such an attempt + -- with an appropriate message), it is possible for anonymous arrays + -- to appear as component definitions. The semantics and back end handle + -- this case properly, and the expander in fact generates such cases. + + -- Although the syntax allows multiple identifiers in the list, the + -- semantics is as though successive declarations were given with the + -- same component definition and expression components. To simplify + -- semantic processing, the parser represents a multiple declaration + -- case as a sequence of single declarations, using the More_Ids and + -- Prev_Ids flags to preserve the original source form as described + -- in the section on "Handling of Defining Identifier Lists". + + -- N_Component_Declaration + -- Sloc points to first identifier + -- Defining_Identifier (Node1) + -- Component_Definition (Node4) + -- Expression (Node3) (set to Empty if no default expression) + -- More_Ids (Flag5) (set to False if no more identifiers in list) + -- Prev_Ids (Flag6) (set to False if no previous identifiers in list) + + ------------------------- + -- 3.8.1 Variant Part -- + ------------------------- + + -- VARIANT_PART ::= + -- case discriminant_DIRECT_NAME is + -- VARIANT + -- {VARIANT} + -- end case; + + -- Note: the variants list can contain pragmas as well as variants. + -- In a properly formed program there is at least one variant. + + -- N_Variant_Part + -- Sloc points to CASE + -- Name (Node2) + -- Variants (List1) + + -------------------- + -- 3.8.1 Variant -- + -------------------- + + -- VARIANT ::= + -- when DISCRETE_CHOICE_LIST => + -- COMPONENT_LIST + + -- N_Variant + -- Sloc points to WHEN + -- Discrete_Choices (List4) + -- Component_List (Node1) + -- Enclosing_Variant (Node2-Sem) + -- Present_Expr (Uint3-Sem) + -- Dcheck_Function (Node5-Sem) + + --------------------------------- + -- 3.8.1 Discrete Choice List -- + --------------------------------- + + -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE} + + ---------------------------- + -- 3.8.1 Discrete Choice -- + ---------------------------- + + -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others + + -- Note: in Ada 83 mode, the expression must be a simple expression + + -- The only choice that appears explicitly is the OTHERS choice, as + -- defined here. Other cases of discrete choice (expression and + -- discrete range) appear directly. This production is also used + -- for the OTHERS possibility of an exception choice. + + -- Note: in accordance with the syntax, the parser does not check that + -- OTHERS appears at the end on its own in a choice list context. This + -- is a semantic check. + + -- N_Others_Choice + -- Sloc points to OTHERS + -- Others_Discrete_Choices (List1-Sem) + -- All_Others (Flag11-Sem) + + ---------------------------------- + -- 3.9.1 Record Extension Part -- + ---------------------------------- + + -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION + + -- Note: record extension parts are not permitted in Ada 83 mode + + -------------------------------------- + -- 3.9.4 Interface Type Definition -- + -------------------------------------- + + -- INTERFACE_TYPE_DEFINITION ::= + -- [limited | task | protected | synchronized] + -- interface [interface_list] + + -- Note: Interfaces are implemented with N_Record_Definition and + -- N_Derived_Type_Definition nodes because most of the support + -- for the analysis of abstract types has been reused to + -- analyze abstract interfaces. + + ---------------------------------- + -- 3.10 Access Type Definition -- + ---------------------------------- + + -- ACCESS_TYPE_DEFINITION ::= + -- ACCESS_TO_OBJECT_DEFINITION + -- | ACCESS_TO_SUBPROGRAM_DEFINITION + + -------------------------- + -- 3.10 Null Exclusion -- + -------------------------- + + -- NULL_EXCLUSION ::= not null + + --------------------------------------- + -- 3.10 Access To Object Definition -- + --------------------------------------- + + -- ACCESS_TO_OBJECT_DEFINITION ::= + -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] + -- SUBTYPE_INDICATION + + -- N_Access_To_Object_Definition + -- Sloc points to ACCESS + -- All_Present (Flag15) + -- Null_Exclusion_Present (Flag11) + -- Subtype_Indication (Node5) + -- Constant_Present (Flag17) + + ----------------------------------- + -- 3.10 General Access Modifier -- + ----------------------------------- + + -- GENERAL_ACCESS_MODIFIER ::= all | constant + + -- Note: general access modifiers are not permitted in Ada 83 mode + + -- There is no explicit node in the tree for general access modifier. + -- Instead the All_Present or Constant_Present flags are set in the + -- parent node. + + ------------------------------------------- + -- 3.10 Access To Subprogram Definition -- + ------------------------------------------- + + -- ACCESS_TO_SUBPROGRAM_DEFINITION + -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE + -- | [NULL_EXCLUSION] access [protected] function + -- PARAMETER_AND_RESULT_PROFILE + + -- Note: access to subprograms are not permitted in Ada 83 mode + + -- N_Access_Function_Definition + -- Sloc points to ACCESS + -- Null_Exclusion_Present (Flag11) + -- Null_Exclusion_In_Return_Present (Flag14) + -- Protected_Present (Flag6) + -- Parameter_Specifications (List3) (set to No_List if no formal part) + -- Result_Definition (Node4) result subtype (subtype mark or access def) + + -- N_Access_Procedure_Definition + -- Sloc points to ACCESS + -- Null_Exclusion_Present (Flag11) + -- Protected_Present (Flag6) + -- Parameter_Specifications (List3) (set to No_List if no formal part) + + ----------------------------- + -- 3.10 Access Definition -- + ----------------------------- + + -- ACCESS_DEFINITION ::= + -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK + -- | ACCESS_TO_SUBPROGRAM_DEFINITION + + -- Note: access to subprograms are an Ada 2005 (AI-254) extension + + -- N_Access_Definition + -- Sloc points to ACCESS + -- Null_Exclusion_Present (Flag11) + -- All_Present (Flag15) + -- Constant_Present (Flag17) + -- Subtype_Mark (Node4) + -- Access_To_Subprogram_Definition (Node3) (set to Empty if not present) + + ----------------------------------------- + -- 3.10.1 Incomplete Type Declaration -- + ----------------------------------------- + + -- INCOMPLETE_TYPE_DECLARATION ::= + -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [IS TAGGED]; + + -- N_Incomplete_Type_Declaration + -- Sloc points to TYPE + -- Defining_Identifier (Node1) + -- Discriminant_Specifications (List4) (set to No_List if no + -- discriminant part, or if the discriminant part is an + -- unknown discriminant part) + -- Unknown_Discriminants_Present (Flag13) set if (<>) discriminant + -- Tagged_Present (Flag15) + + ---------------------------- + -- 3.11 Declarative Part -- + ---------------------------- + + -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM} + + -- Note: although the parser enforces the syntactic requirement that + -- a declarative part can contain only declarations, the semantic + -- processing may add statements to the list of actions in a + -- declarative part, so the code generator should be prepared + -- to accept a statement in this position. + + ---------------------------- + -- 3.11 Declarative Item -- + ---------------------------- + + -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY + + ---------------------------------- + -- 3.11 Basic Declarative Item -- + ---------------------------------- + + -- BASIC_DECLARATIVE_ITEM ::= + -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE + + ---------------- + -- 3.11 Body -- + ---------------- + + -- BODY ::= PROPER_BODY | BODY_STUB + + ----------------------- + -- 3.11 Proper Body -- + ----------------------- + + -- PROPER_BODY ::= + -- SUBPROGRAM_BODY | PACKAGE_BODY | TASK_BODY | PROTECTED_BODY + + --------------- + -- 4.1 Name -- + --------------- + + -- NAME ::= + -- DIRECT_NAME | EXPLICIT_DEREFERENCE + -- | INDEXED_COMPONENT | SLICE + -- | SELECTED_COMPONENT | ATTRIBUTE_REFERENCE + -- | TYPE_CONVERSION | FUNCTION_CALL + -- | CHARACTER_LITERAL + + ---------------------- + -- 4.1 Direct Name -- + ---------------------- + + -- DIRECT_NAME ::= IDENTIFIER | OPERATOR_SYMBOL + + ----------------- + -- 4.1 Prefix -- + ----------------- + + -- PREFIX ::= NAME | IMPLICIT_DEREFERENCE + + ------------------------------- + -- 4.1 Explicit Dereference -- + ------------------------------- + + -- EXPLICIT_DEREFERENCE ::= NAME . all + + -- N_Explicit_Dereference + -- Sloc points to ALL + -- Prefix (Node3) + -- Actual_Designated_Subtype (Node4-Sem) + -- plus fields for expression + + ------------------------------- + -- 4.1 Implicit Dereference -- + ------------------------------- + + -- IMPLICIT_DEREFERENCE ::= NAME + + ------------------------------ + -- 4.1.1 Indexed Component -- + ------------------------------ + + -- INDEXED_COMPONENT ::= PREFIX (EXPRESSION {, EXPRESSION}) + + -- Note: the parser may generate this node in some situations where it + -- should be a function call. The semantic pass must correct this + -- misidentification (which is inevitable at the parser level). + + -- N_Indexed_Component + -- Sloc contains a copy of the Sloc value of the Prefix + -- Prefix (Node3) + -- Expressions (List1) + -- plus fields for expression + + -- Note: if any of the subscripts requires a range check, then the + -- Do_Range_Check flag is set on the corresponding expression, with + -- the index type being determined from the type of the Prefix, which + -- references the array being indexed. + + -- Note: in a fully analyzed and expanded indexed component node, and + -- hence in any such node that gigi sees, if the prefix is an access + -- type, then an explicit dereference operation has been inserted. + + ------------------ + -- 4.1.2 Slice -- + ------------------ + + -- SLICE ::= PREFIX (DISCRETE_RANGE) + + -- Note: an implicit subtype is created to describe the resulting + -- type, so that the bounds of this type are the bounds of the slice. + + -- N_Slice + -- Sloc points to first token of prefix + -- Prefix (Node3) + -- Discrete_Range (Node4) + -- plus fields for expression + + ------------------------------- + -- 4.1.3 Selected Component -- + ------------------------------- + + -- SELECTED_COMPONENT ::= PREFIX . SELECTOR_NAME + + -- Note: selected components that are semantically expanded names get + -- changed during semantic processing into the separate N_Expanded_Name + -- node. See description of this node in the section on semantic nodes. + + -- N_Selected_Component + -- Sloc points to period + -- Prefix (Node3) + -- Selector_Name (Node2) + -- Associated_Node (Node4-Sem) + -- Do_Discriminant_Check (Flag13-Sem) + -- Is_In_Discriminant_Check (Flag11-Sem) + -- plus fields for expression + + -------------------------- + -- 4.1.3 Selector Name -- + -------------------------- + + -- SELECTOR_NAME ::= IDENTIFIER | CHARACTER_LITERAL | OPERATOR_SYMBOL + + -------------------------------- + -- 4.1.4 Attribute Reference -- + -------------------------------- + + -- ATTRIBUTE_REFERENCE ::= PREFIX ' ATTRIBUTE_DESIGNATOR + + -- Note: the syntax is quite ambiguous at this point. Consider: + + -- A'Length (X) X is part of the attribute designator + -- A'Pos (X) X is an explicit actual parameter of function A'Pos + -- A'Class (X) X is the expression of a type conversion + + -- It would be possible for the parser to distinguish these cases + -- by looking at the attribute identifier. However, that would mean + -- more work in introducing new implementation defined attributes, + -- and also it would mean that special processing for attributes + -- would be scattered around, instead of being centralized in the + -- semantic routine that handles an N_Attribute_Reference node. + -- Consequently, the parser in all the above cases stores the + -- expression (X in these examples) as a single element list in + -- in the Expressions field of the N_Attribute_Reference node. + + -- Similarly, for attributes like Max which take two arguments, + -- we store the two arguments as a two element list in the + -- Expressions field. Of course it is clear at parse time that + -- this case is really a function call with an attribute as the + -- prefix, but it turns out to be convenient to handle the two + -- argument case in a similar manner to the one argument case, + -- and indeed in general the parser will accept any number of + -- expressions in this position and store them as a list in the + -- attribute reference node. This allows for future addition of + -- attributes that take more than two arguments. + + -- Note: named associates are not permitted in function calls where + -- the function is an attribute (see RM 6.4(3)) so it is legitimate + -- to skip the normal subprogram argument processing. + + -- Note: for the attributes whose designators are technically keywords, + -- i.e. digits, access, delta, range, the Attribute_Name field contains + -- the corresponding name, even though no identifier is involved. + + -- Note: the generated code may contain stream attributes applied to + -- limited types for which no stream routines exist officially. In such + -- case, the result is to use the stream attribute for the underlying + -- full type, or in the case of a protected type, the components + -- (including any discriminants) are merely streamed in order. + + -- See Exp_Attr for a complete description of which attributes are + -- passed onto Gigi, and which are handled entirely by the front end. + + -- Gigi restriction: For the Pos attribute, the prefix cannot be + -- a non-standard enumeration type or a nonzero/zero semantics + -- boolean type, so the value is simply the stored representation. + + -- Gigi requirement: For the Mechanism_Code attribute, if the prefix + -- references a subprogram that is a renaming, then the front end must + -- rewrite the attribute to refer directly to the renamed entity. + + -- Note: In generated code, the Address and Unrestricted_Access + -- attributes can be applied to any expression, and the meaning is + -- to create an object containing the value (the object is in the + -- current stack frame), and pass the address of this value. If the + -- Must_Be_Byte_Aligned flag is set, then the object whose address + -- is taken must be on a byte (storage unit) boundary, and if it is + -- not (or may not be), then the generated code must create a copy + -- that is byte aligned, and pass the address of this copy. + + -- N_Attribute_Reference + -- Sloc points to apostrophe + -- Prefix (Node3) + -- Attribute_Name (Name2) identifier name from attribute designator + -- Expressions (List1) (set to No_List if no associated expressions) + -- Entity (Node4-Sem) used if the attribute yields a type + -- Associated_Node (Node4-Sem) + -- Do_Overflow_Check (Flag17-Sem) + -- Redundant_Use (Flag13-Sem) + -- Must_Be_Byte_Aligned (Flag14) + -- plus fields for expression + + --------------------------------- + -- 4.1.4 Attribute Designator -- + --------------------------------- + + -- ATTRIBUTE_DESIGNATOR ::= + -- IDENTIFIER [(static_EXPRESSION)] + -- | access | delta | digits + + -- There is no explicit node in the tree for an attribute designator. + -- Instead the Attribute_Name and Expressions fields of the parent + -- node (N_Attribute_Reference node) hold the information. + + -- Note: if ACCESS, DELTA or DIGITS appears in an attribute + -- designator, then they are treated as identifiers internally + -- rather than the keywords of the same name. + + -------------------------------------- + -- 4.1.4 Range Attribute Reference -- + -------------------------------------- + + -- RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR + + -- A range attribute reference is represented in the tree using the + -- normal N_Attribute_Reference node. + + --------------------------------------- + -- 4.1.4 Range Attribute Designator -- + --------------------------------------- + + -- RANGE_ATTRIBUTE_DESIGNATOR ::= Range [(static_EXPRESSION)] + + -- A range attribute designator is represented in the tree using the + -- normal N_Attribute_Reference node. + + -------------------- + -- 4.3 Aggregate -- + -------------------- + + -- AGGREGATE ::= + -- RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE + + ----------------------------- + -- 4.3.1 Record Aggregate -- + ----------------------------- + + -- RECORD_AGGREGATE ::= (RECORD_COMPONENT_ASSOCIATION_LIST) + + -- N_Aggregate + -- Sloc points to left parenthesis + -- Expressions (List1) (set to No_List if none or null record case) + -- Component_Associations (List2) (set to No_List if none) + -- Null_Record_Present (Flag17) + -- Aggregate_Bounds (Node3-Sem) + -- Associated_Node (Node4-Sem) + -- Static_Processing_OK (Flag4-Sem) + -- Compile_Time_Known_Aggregate (Flag18-Sem) + -- Expansion_Delayed (Flag11-Sem) + -- Has_Self_Reference (Flag13-Sem) + -- plus fields for expression + + -- Note: this structure is used for both record and array aggregates + -- since the two cases are not separable by the parser. The parser + -- makes no attempt to enforce consistency here, so it is up to the + -- semantic phase to make sure that the aggregate is consistent (i.e. + -- that it is not a "half-and-half" case that mixes record and array + -- syntax. In particular, for a record aggregate, the expressions + -- field will be set if there are positional associations. + + -- Note: N_Aggregate is not used for all aggregates; in particular, + -- there is a separate node kind for extension aggregates. + + -- Note: gigi/gcc can handle array aggregates correctly providing that + -- they are entirely positional, and the array subtype involved has a + -- known at compile time length and is not bit packed, or a convention + -- Fortran array with more than one dimension. If these conditions + -- are not met, then the front end must translate the aggregate into + -- an appropriate set of assignments into a temporary. + + -- Note: for the record aggregate case, gigi/gcc can handle all cases of + -- record aggregates, including those for packed, and rep-claused + -- records, and also variant records, providing that there are no + -- variable length fields whose size is not known at compile time, and + -- providing that the aggregate is presented in fully named form. + + ---------------------------------------------- + -- 4.3.1 Record Component Association List -- + ---------------------------------------------- + + -- RECORD_COMPONENT_ASSOCIATION_LIST ::= + -- RECORD_COMPONENT_ASSOCIATION {, RECORD_COMPONENT_ASSOCIATION} + -- | null record + + -- There is no explicit node in the tree for a record component + -- association list. Instead the Null_Record_Present flag is set in + -- the parent node for the NULL RECORD case. + + ------------------------------------------------------ + -- 4.3.1 Record Component Association (also 4.3.3) -- + ------------------------------------------------------ + + -- RECORD_COMPONENT_ASSOCIATION ::= + -- [COMPONENT_CHOICE_LIST =>] EXPRESSION + + -- N_Component_Association + -- Sloc points to first selector name + -- Choices (List1) + -- Loop_Actions (List2-Sem) + -- Expression (Node3) + -- Box_Present (Flag15) + -- Inherited_Discriminant (Flag13) + + -- Note: this structure is used for both record component associations + -- and array component associations, since the two cases aren't always + -- separable by the parser. The choices list may represent either a + -- list of selector names in the record aggregate case, or a list of + -- discrete choices in the array aggregate case or an N_Others_Choice + -- node (which appears as a singleton list). Box_Present gives support + -- to Ada 2005 (AI-287). + + ---------------------------------- + -- 4.3.1 Component Choice List -- + ---------------------------------- + + -- COMPONENT_CHOICE_LIST ::= + -- component_SELECTOR_NAME {| component_SELECTOR_NAME} + -- | others + + -- The entries of a component choice list appear in the Choices list of + -- the associated N_Component_Association, as either selector names, or + -- as an N_Others_Choice node. + + -------------------------------- + -- 4.3.2 Extension Aggregate -- + -------------------------------- + + -- EXTENSION_AGGREGATE ::= + -- (ANCESTOR_PART with RECORD_COMPONENT_ASSOCIATION_LIST) + + -- Note: extension aggregates are not permitted in Ada 83 mode + + -- N_Extension_Aggregate + -- Sloc points to left parenthesis + -- Ancestor_Part (Node3) + -- Associated_Node (Node4-Sem) + -- Expressions (List1) (set to No_List if none or null record case) + -- Component_Associations (List2) (set to No_List if none) + -- Null_Record_Present (Flag17) + -- Expansion_Delayed (Flag11-Sem) + -- Has_Self_Reference (Flag13-Sem) + -- plus fields for expression + + -------------------------- + -- 4.3.2 Ancestor Part -- + -------------------------- + + -- ANCESTOR_PART ::= EXPRESSION | SUBTYPE_MARK + + ---------------------------- + -- 4.3.3 Array Aggregate -- + ---------------------------- + + -- ARRAY_AGGREGATE ::= + -- POSITIONAL_ARRAY_AGGREGATE | NAMED_ARRAY_AGGREGATE + + --------------------------------------- + -- 4.3.3 Positional Array Aggregate -- + --------------------------------------- + + -- POSITIONAL_ARRAY_AGGREGATE ::= + -- (EXPRESSION, EXPRESSION {, EXPRESSION}) + -- | (EXPRESSION {, EXPRESSION}, others => EXPRESSION) + + -- See Record_Aggregate (4.3.1) for node structure + + ---------------------------------- + -- 4.3.3 Named Array Aggregate -- + ---------------------------------- + + -- NAMED_ARRAY_AGGREGATE ::= + -- | (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION}) + + -- See Record_Aggregate (4.3.1) for node structure + + ---------------------------------------- + -- 4.3.3 Array Component Association -- + ---------------------------------------- + + -- ARRAY_COMPONENT_ASSOCIATION ::= + -- DISCRETE_CHOICE_LIST => EXPRESSION + + -- See Record_Component_Association (4.3.1) for node structure + + -------------------------------------------------- + -- 4.4 Expression/Relation/Term/Factor/Primary -- + -------------------------------------------------- + + -- EXPRESSION ::= + -- RELATION {LOGICAL_OPERATOR RELATION} + + -- CHOICE_EXPRESSION ::= + -- CHOICE_RELATION {LOGICAL_OPERATOR CHOICE_RELATION} + + -- CHOICE_RELATION ::= + -- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION] + + -- RELATION ::= + -- SIMPLE_EXPRESSION [not] in MEMBERSHIP_CHOICE_LIST + + -- MEMBERSHIP_CHOICE_LIST ::= + -- MEMBERSHIP_CHOICE {'|' MEMBERSHIP CHOICE} + + -- MEMBERSHIP_CHOICE ::= + -- CHOICE_EXPRESSION | RANGE | SUBTYPE_MARK + + -- LOGICAL_OPERATOR ::= and | and then | or | or else | xor + + -- SIMPLE_EXPRESSION ::= + -- [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM} + + -- TERM ::= FACTOR {MULTIPLYING_OPERATOR FACTOR} + + -- FACTOR ::= PRIMARY [** PRIMARY] | abs PRIMARY | not PRIMARY + + -- No nodes are generated for any of these constructs. Instead, the + -- node for the operator appears directly. When we refer to an + -- expression in this description, we mean any of the possible + -- constituent components of an expression (e.g. identifier is + -- an example of an expression). + + -- Note: the above syntax is that Ada 2012 syntax which restricts + -- choice relations to simple expressions to avoid ambiguities in + -- some contexts with set membership notation. It has been decided + -- that in retrospect, the Ada 95 change allowing general expressions + -- in this context was a mistake, so we have reverted to the above + -- syntax in Ada 95 and Ada 2005 modes (the restriction to simple + -- expressions was there in Ada 83 from the start). + + ------------------ + -- 4.4 Primary -- + ------------------ + + -- PRIMARY ::= + -- NUMERIC_LITERAL | null + -- | STRING_LITERAL | AGGREGATE + -- | NAME | QUALIFIED_EXPRESSION + -- | ALLOCATOR | (EXPRESSION) + + -- Usually there is no explicit node in the tree for primary. Instead + -- the constituent (e.g. AGGREGATE) appears directly. There are two + -- exceptions. First, there is an explicit node for a null primary. + + -- N_Null + -- Sloc points to NULL + -- plus fields for expression + + -- Second, the case of (EXPRESSION) is handled specially. Ada requires + -- that the parser keep track of which subexpressions are enclosed + -- in parentheses, and how many levels of parentheses are used. This + -- information is required for optimization purposes, and also for + -- some semantic checks (e.g. (((1))) in a procedure spec does not + -- conform with ((((1)))) in the body). + + -- The parentheses are recorded by keeping a Paren_Count field in every + -- subexpression node (it is actually present in all nodes, but only + -- used in subexpression nodes). This count records the number of + -- levels of parentheses. If the number of levels in the source exceeds + -- the maximum accommodated by this count, then the count is simply left + -- at the maximum value. This means that there are some pathological + -- cases of failure to detect conformance failures (e.g. an expression + -- with 500 levels of parens will conform with one with 501 levels), + -- but we do not need to lose sleep over this. + + -- Historical note: in versions of GNAT prior to 1.75, there was a node + -- type N_Parenthesized_Expression used to accurately record unlimited + -- numbers of levels of parentheses. However, it turned out to be a + -- real nuisance to have to take into account the possible presence of + -- this node during semantic analysis, since basically parentheses have + -- zero relevance to semantic analysis. + + -- Note: the level of parentheses always present in things like + -- aggregates does not count, only the parentheses in the primary + -- (EXPRESSION) affect the setting of the Paren_Count field. + + -- 2nd Note: the contents of the Expression field must be ignored (i.e. + -- treated as though it were Empty) if No_Initialization is set True. + + -------------------------------------- + -- 4.5 Short Circuit Control Forms -- + -------------------------------------- + + -- EXPRESSION ::= + -- RELATION {and then RELATION} | RELATION {or else RELATION} + + -- Gigi restriction: For both these control forms, the operand and + -- result types are always Standard.Boolean. The expander inserts the + -- required conversion operations where needed to ensure this is the + -- case. + + -- N_And_Then + -- Sloc points to AND of AND THEN + -- Left_Opnd (Node2) + -- Right_Opnd (Node3) + -- Actions (List1-Sem) + -- plus fields for expression + + -- N_Or_Else + -- Sloc points to OR of OR ELSE + -- Left_Opnd (Node2) + -- Right_Opnd (Node3) + -- Actions (List1-Sem) + -- plus fields for expression + + -- Note: The Actions field is used to hold actions associated with + -- the right hand operand. These have to be treated specially since + -- they are not unconditionally executed. See Insert_Actions for a + -- more detailed description of how these actions are handled. + + --------------------------- + -- 4.5 Membership Tests -- + --------------------------- + + -- RELATION ::= + -- SIMPLE_EXPRESSION [not] in MEMBERSHIP_CHOICE_LIST + + -- MEMBERSHIP_CHOICE_LIST ::= + -- MEMBERSHIP_CHOICE {'|' MEMBERSHIP CHOICE} + + -- MEMBERSHIP_CHOICE ::= + -- CHOICE_EXPRESSION | RANGE | SUBTYPE_MARK + + -- Note: although the grammar above allows only a range or a subtype + -- mark, the parser in fact will accept any simple expression in place + -- of a subtype mark. This means that the semantic analyzer must be able + -- to deal with, and diagnose a simple expression other than a name for + -- the right operand. This simplifies error recovery in the parser. + + -- The Alternatives field below is present only if there is more + -- than one Membership_Choice present (which is legitimate only in + -- Ada 2012 mode) in which case Right_Opnd is Empty, and Alternatives + -- contains the list of choices. In the tree passed to the back end, + -- Alternatives is always No_List, and Right_Opnd is set (i.e. the + -- expansion circuitry expands out the complex set membership case + -- using simple membership operations). + + -- Should we rename Alternatives here to Membership_Choices ??? + + -- N_In + -- Sloc points to IN + -- Left_Opnd (Node2) + -- Right_Opnd (Node3) + -- Alternatives (List4) (set to No_List if only one set alternative) + -- plus fields for expression + + -- N_Not_In + -- Sloc points to NOT of NOT IN + -- Left_Opnd (Node2) + -- Right_Opnd (Node3) + -- Alternatives (List4) (set to No_List if only one set alternative) + -- plus fields for expression + + -------------------- + -- 4.5 Operators -- + -------------------- + + -- LOGICAL_OPERATOR ::= and | or | xor + + -- RELATIONAL_OPERATOR ::= = | /= | < | <= | > | >= + + -- BINARY_ADDING_OPERATOR ::= + | - | & + + -- UNARY_ADDING_OPERATOR ::= + | - + + -- MULTIPLYING_OPERATOR ::= * | / | mod | rem + + -- HIGHEST_PRECEDENCE_OPERATOR ::= ** | abs | not + + -- Sprint syntax if Treat_Fixed_As_Integer is set: + + -- x #* y + -- x #/ y + -- x #mod y + -- x #rem y + + -- Gigi restriction: For * / mod rem with fixed-point operands, Gigi + -- will only be given nodes with the Treat_Fixed_As_Integer flag set. + -- All handling of smalls for multiplication and division is handled + -- by the front end (mod and rem result only from expansion). Gigi + -- thus never needs to worry about small values (for other operators + -- operating on fixed-point, e.g. addition, the small value does not + -- have any semantic effect anyway, these are always integer operations. + + -- Gigi restriction: For all operators taking Boolean operands, the + -- type is always Standard.Boolean. The expander inserts the required + -- conversion operations where needed to ensure this is the case. + + -- N_Op_And + -- Sloc points to AND + -- Do_Length_Check (Flag4-Sem) + -- plus fields for binary operator + -- plus fields for expression + + -- N_Op_Or + -- Sloc points to OR + -- Do_Length_Check (Flag4-Sem) + -- plus fields for binary operator + -- plus fields for expression + + -- N_Op_Xor + -- Sloc points to XOR + -- Do_Length_Check (Flag4-Sem) + -- plus fields for binary operator + -- plus fields for expression + + -- N_Op_Eq + -- Sloc points to = + -- plus fields for binary operator + -- plus fields for expression + + -- N_Op_Ne + -- Sloc points to /= + -- plus fields for binary operator + -- plus fields for expression + + -- N_Op_Lt + -- Sloc points to < + -- plus fields for binary operator + -- plus fields for expression + + -- N_Op_Le + -- Sloc points to <= + -- plus fields for binary operator + -- plus fields for expression + + -- N_Op_Gt + -- Sloc points to > + -- plus fields for binary operator + -- plus fields for expression + + -- N_Op_Ge + -- Sloc points to >= + -- plus fields for binary operator + -- plus fields for expression + + -- N_Op_Add + -- Sloc points to + (binary) + -- plus fields for binary operator + -- plus fields for expression + + -- N_Op_Subtract + -- Sloc points to - (binary) + -- plus fields for binary operator + -- plus fields for expression + + -- N_Op_Concat + -- Sloc points to & + -- Is_Component_Left_Opnd (Flag13-Sem) + -- Is_Component_Right_Opnd (Flag14-Sem) + -- plus fields for binary operator + -- plus fields for expression + + -- N_Op_Multiply + -- Sloc points to * + -- Treat_Fixed_As_Integer (Flag14-Sem) + -- Rounded_Result (Flag18-Sem) + -- plus fields for binary operator + -- plus fields for expression + + -- N_Op_Divide + -- Sloc points to / + -- Treat_Fixed_As_Integer (Flag14-Sem) + -- Do_Division_Check (Flag13-Sem) + -- Rounded_Result (Flag18-Sem) + -- plus fields for binary operator + -- plus fields for expression + + -- N_Op_Mod + -- Sloc points to MOD + -- Treat_Fixed_As_Integer (Flag14-Sem) + -- Do_Division_Check (Flag13-Sem) + -- plus fields for binary operator + -- plus fields for expression + + -- N_Op_Rem + -- Sloc points to REM + -- Treat_Fixed_As_Integer (Flag14-Sem) + -- Do_Division_Check (Flag13-Sem) + -- plus fields for binary operator + -- plus fields for expression + + -- N_Op_Expon + -- Is_Power_Of_2_For_Shift (Flag13-Sem) + -- Sloc points to ** + -- plus fields for binary operator + -- plus fields for expression + + -- N_Op_Plus + -- Sloc points to + (unary) + -- plus fields for unary operator + -- plus fields for expression + + -- N_Op_Minus + -- Sloc points to - (unary) + -- plus fields for unary operator + -- plus fields for expression + + -- N_Op_Abs + -- Sloc points to ABS + -- plus fields for unary operator + -- plus fields for expression + + -- N_Op_Not + -- Sloc points to NOT + -- plus fields for unary operator + -- plus fields for expression + + -- See also shift operators in section B.2 + + -- Note on fixed-point operations passed to Gigi: For adding operators, + -- the semantics is to treat these simply as integer operations, with + -- the small values being ignored (the bounds are already stored in + -- units of small, so that constraint checking works as usual). For the + -- case of multiply/divide/rem/mod operations, Gigi will only see fixed + -- point operands if the Treat_Fixed_As_Integer flag is set and will + -- thus treat these nodes in identical manner, ignoring small values. + + --------------------------------- + -- 4.5.9 Quantified Expression -- + --------------------------------- + + -- QUANTIFIED_EXPRESSION ::= + -- for QUANTIFIER LOOP_PARAMETER_SPECIFICATION => PREDICATE + -- | for QUANTIFIER ITERATOR_SPECIFICATION => PREDICATE + -- + -- QUANTIFIER ::= all | some + + -- At most one of (Iterator_Specification, Loop_Parameter_Specification) + -- is present at a time, in which case the other one is empty. + + -- N_Quantified_Expression + -- Sloc points to FOR + -- Iterator_Specification (Node2) + -- Loop_Parameter_Specification (Node4) + -- Condition (Node1) + -- All_Present (Flag15) + + -------------------------- + -- 4.6 Type Conversion -- + -------------------------- + + -- TYPE_CONVERSION ::= + -- SUBTYPE_MARK (EXPRESSION) | SUBTYPE_MARK (NAME) + + -- In the (NAME) case, the name is stored as the expression + + -- Note: the parser never generates a type conversion node, since it + -- looks like an indexed component which is generated by preference. + -- The semantic pass must correct this misidentification. + + -- Gigi handles conversions that involve no change in the root type, + -- and also all conversions from integer to floating-point types. + -- Conversions from floating-point to integer are only handled in + -- the case where Float_Truncate flag set. Other conversions from + -- floating-point to integer (involving rounding) and all conversions + -- involving fixed-point types are handled by the expander. + + -- Sprint syntax if Float_Truncate set: X^(Y) + -- Sprint syntax if Conversion_OK set X?(Y) + -- Sprint syntax if both flags set X?^(Y) + + -- Note: If either the operand or result type is fixed-point, Gigi will + -- only see a type conversion node with Conversion_OK set. The front end + -- takes care of all handling of small's for fixed-point conversions. + + -- N_Type_Conversion + -- Sloc points to first token of subtype mark + -- Subtype_Mark (Node4) + -- Expression (Node3) + -- Do_Tag_Check (Flag13-Sem) + -- Do_Length_Check (Flag4-Sem) + -- Do_Overflow_Check (Flag17-Sem) + -- Float_Truncate (Flag11-Sem) + -- Rounded_Result (Flag18-Sem) + -- Conversion_OK (Flag14-Sem) + -- plus fields for expression + + -- Note: if a range check is required, then the Do_Range_Check flag + -- is set in the Expression with the check being done against the + -- target type range (after the base type conversion, if any). + + ------------------------------- + -- 4.7 Qualified Expression -- + ------------------------------- + + -- QUALIFIED_EXPRESSION ::= + -- SUBTYPE_MARK ' (EXPRESSION) | SUBTYPE_MARK ' AGGREGATE + + -- Note: the parentheses in the (EXPRESSION) case are deemed to enclose + -- the expression, so the Expression field of this node always points + -- to a parenthesized expression in this case (i.e. Paren_Count will + -- always be non-zero for the referenced expression if it is not an + -- aggregate). + + -- N_Qualified_Expression + -- Sloc points to apostrophe + -- Subtype_Mark (Node4) + -- Expression (Node3) expression or aggregate + -- plus fields for expression + + -------------------- + -- 4.8 Allocator -- + -------------------- + + -- ALLOCATOR ::= + -- new [NULL_EXCLUSION] SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION + + -- Sprint syntax (when storage pool present) + -- new xxx (storage_pool = pool) + + -- N_Allocator + -- Sloc points to NEW + -- Expression (Node3) subtype indication or qualified expression + -- Storage_Pool (Node1-Sem) + -- Procedure_To_Call (Node2-Sem) + -- Coextensions (Elist4-Sem) + -- Null_Exclusion_Present (Flag11) + -- No_Initialization (Flag13-Sem) + -- Is_Static_Coextension (Flag14-Sem) + -- Do_Storage_Check (Flag17-Sem) + -- Is_Dynamic_Coextension (Flag18-Sem) + -- plus fields for expression + + -- Note: like all nodes, the N_Allocator has the Comes_From_Source flag. + -- This flag has a special function in conjunction with the restriction + -- No_Implicit_Heap_Allocations, which will be triggered if this flag + -- is not set. This means that if a source allocator is replaced with + -- a constructed allocator, the Comes_From_Source flag should be copied + -- to the newly created allocator. + + --------------------------------- + -- 5.1 Sequence Of Statements -- + --------------------------------- + + -- SEQUENCE_OF_STATEMENTS ::= STATEMENT {STATEMENT} + + -- Note: Although the parser will not accept a declaration as a + -- statement, the semantic analyzer may insert declarations (e.g. + -- declarations of implicit types needed for execution of other + -- statements) into a sequence of statements, so the code generator + -- should be prepared to accept a declaration where a statement is + -- expected. Note also that pragmas can appear as statements. + + -------------------- + -- 5.1 Statement -- + -------------------- + + -- STATEMENT ::= + -- {LABEL} SIMPLE_STATEMENT | {LABEL} COMPOUND_STATEMENT + + -- There is no explicit node in the tree for a statement. Instead, the + -- individual statement appears directly. Labels are treated as a + -- kind of statement, i.e. they are linked into a statement list at + -- the point they appear, so the labeled statement appears following + -- the label or labels in the statement list. + + --------------------------- + -- 5.1 Simple Statement -- + --------------------------- + + -- SIMPLE_STATEMENT ::= NULL_STATEMENT + -- | ASSIGNMENT_STATEMENT | EXIT_STATEMENT + -- | GOTO_STATEMENT | PROCEDURE_CALL_STATEMENT + -- | SIMPLE_RETURN_STATEMENT | ENTRY_CALL_STATEMENT + -- | REQUEUE_STATEMENT | DELAY_STATEMENT + -- | ABORT_STATEMENT | RAISE_STATEMENT + -- | CODE_STATEMENT + + ----------------------------- + -- 5.1 Compound Statement -- + ----------------------------- + + -- COMPOUND_STATEMENT ::= + -- IF_STATEMENT | CASE_STATEMENT + -- | LOOP_STATEMENT | BLOCK_STATEMENT + -- | EXTENDED_RETURN_STATEMENT + -- | ACCEPT_STATEMENT | SELECT_STATEMENT + + ------------------------- + -- 5.1 Null Statement -- + ------------------------- + + -- NULL_STATEMENT ::= null; + + -- N_Null_Statement + -- Sloc points to NULL + + ---------------- + -- 5.1 Label -- + ---------------- + + -- LABEL ::= <> + + -- Note that the occurrence of a label is not a defining identifier, + -- but rather a referencing occurrence. The defining occurrence is + -- in the implicit label declaration which occurs in the innermost + -- enclosing block. + + -- N_Label + -- Sloc points to << + -- Identifier (Node1) direct name of statement identifier + -- Exception_Junk (Flag8-Sem) + + -- Note: Before Ada 2012, a label is always followed by a statement, + -- and this is true in the tree even in Ada 2012 mode (the parser + -- inserts a null statement marked with Comes_From_Source False). + + ------------------------------- + -- 5.1 Statement Identifier -- + ------------------------------- + + -- STATEMENT_IDENTIFIER ::= DIRECT_NAME + + -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier + -- (not an OPERATOR_SYMBOL) + + ------------------------------- + -- 5.2 Assignment Statement -- + ------------------------------- + + -- ASSIGNMENT_STATEMENT ::= + -- variable_NAME := EXPRESSION; + + -- N_Assignment_Statement + -- Sloc points to := + -- Name (Node2) + -- Expression (Node3) + -- Do_Tag_Check (Flag13-Sem) + -- Do_Length_Check (Flag4-Sem) + -- Forwards_OK (Flag5-Sem) + -- Backwards_OK (Flag6-Sem) + -- No_Ctrl_Actions (Flag7-Sem) + -- Componentwise_Assignment (Flag14-Sem) + -- Suppress_Assignment_Checks (Flag18-Sem) + + -- Note: if a range check is required, then the Do_Range_Check flag + -- is set in the Expression (right hand side), with the check being + -- done against the type of the Name (left hand side). + + -- Note: the back end places some restrictions on the form of the + -- Expression field. If the object being assigned to is Atomic, then + -- the Expression may not have the form of an aggregate (since this + -- might cause the back end to generate separate assignments). In this + -- case the front end must generate an extra temporary and initialize + -- this temporary as required (the temporary itself is not atomic). + + ----------------------- + -- 5.3 If Statement -- + ----------------------- + + -- IF_STATEMENT ::= + -- if CONDITION then + -- SEQUENCE_OF_STATEMENTS + -- {elsif CONDITION then + -- SEQUENCE_OF_STATEMENTS} + -- [else + -- SEQUENCE_OF_STATEMENTS] + -- end if; + + -- Gigi restriction: This expander ensures that the type of the + -- Condition fields is always Standard.Boolean, even if the type + -- in the source is some non-standard boolean type. + + -- N_If_Statement + -- Sloc points to IF + -- Condition (Node1) + -- Then_Statements (List2) + -- Elsif_Parts (List3) (set to No_List if none present) + -- Else_Statements (List4) (set to No_List if no else part present) + -- End_Span (Uint5) (set to No_Uint if expander generated) + + -- N_Elsif_Part + -- Sloc points to ELSIF + -- Condition (Node1) + -- Then_Statements (List2) + -- Condition_Actions (List3-Sem) + + -------------------- + -- 5.3 Condition -- + -------------------- + + -- CONDITION ::= boolean_EXPRESSION + + ------------------------- + -- 5.4 Case Statement -- + ------------------------- + + -- CASE_STATEMENT ::= + -- case EXPRESSION is + -- CASE_STATEMENT_ALTERNATIVE + -- {CASE_STATEMENT_ALTERNATIVE} + -- end case; + + -- Note: the Alternatives can contain pragmas. These only occur at + -- the start of the list, since any pragmas occurring after the first + -- alternative are absorbed into the corresponding statement sequence. + + -- N_Case_Statement + -- Sloc points to CASE + -- Expression (Node3) + -- Alternatives (List4) + -- End_Span (Uint5) (set to No_Uint if expander generated) + + -- Note: Before Ada 2012, a pragma in a statement sequence is always + -- followed by a statement, and this is true in the tree even in Ada + -- 2012 mode (the parser inserts a null statement marked with the flag + -- Comes_From_Source False). + + ------------------------------------- + -- 5.4 Case Statement Alternative -- + ------------------------------------- + + -- CASE_STATEMENT_ALTERNATIVE ::= + -- when DISCRETE_CHOICE_LIST => + -- SEQUENCE_OF_STATEMENTS + + -- N_Case_Statement_Alternative + -- Sloc points to WHEN + -- Discrete_Choices (List4) + -- Statements (List3) + + ------------------------- + -- 5.5 Loop Statement -- + ------------------------- + + -- LOOP_STATEMENT ::= + -- [loop_STATEMENT_IDENTIFIER :] + -- [ITERATION_SCHEME] loop + -- SEQUENCE_OF_STATEMENTS + -- end loop [loop_IDENTIFIER]; + + -- Note: The occurrence of a loop label is not a defining identifier + -- but rather a referencing occurrence. The defining occurrence is in + -- the implicit label declaration which occurs in the innermost + -- enclosing block. + + -- Note: there is always a loop statement identifier present in + -- the tree, even if none was given in the source. In the case where + -- no loop identifier is given in the source, the parser creates + -- a name of the form _Loop_n, where n is a decimal integer (the + -- two underlines ensure that the loop names created in this manner + -- do not conflict with any user defined identifiers), and the flag + -- Has_Created_Identifier is set to True. The only exception to the + -- rule that all loop statement nodes have identifiers occurs for + -- loops constructed by the expander, and the semantic analyzer will + -- create and supply dummy loop identifiers in these cases. + + -- N_Loop_Statement + -- Sloc points to LOOP + -- Identifier (Node1) loop identifier (set to Empty if no identifier) + -- Iteration_Scheme (Node2) (set to Empty if no iteration scheme) + -- Statements (List3) + -- End_Label (Node4) + -- Has_Created_Identifier (Flag15) + -- Is_Null_Loop (Flag16) + -- Suppress_Loop_Warnings (Flag17) + + -- Note: the parser fills in the Identifier field if there is an + -- explicit loop identifier. Otherwise the parser leaves this field + -- set to Empty, and then the semantic processing for a loop statement + -- creates an identifier, setting the Has_Created_Identifier flag to + -- True. So after semantic analysis, the Identifier is always set, + -- referencing an identifier whose entity has an Ekind of E_Loop. + + -------------------------- + -- 5.5 Iteration Scheme -- + -------------------------- + + -- ITERATION_SCHEME ::= + -- while CONDITION + -- | for LOOP_PARAMETER_SPECIFICATION + -- | for ITERATOR_SPECIFICATION + + -- At most one of (Iterator_Specification, Loop_Parameter_Specification) + -- is present at a time, in which case the other one is empty. Both are + -- empty in the case of a WHILE loop. + + -- Gigi restriction: This expander ensures that the type of the + -- Condition field is always Standard.Boolean, even if the type + -- in the source is some non-standard boolean type. + + -- N_Iteration_Scheme + -- Sloc points to WHILE or FOR + -- Condition (Node1) (set to Empty if FOR case) + -- Condition_Actions (List3-Sem) + -- Iterator_Specification (Node2) (set to Empty if WHILE case) + -- Loop_Parameter_Specification (Node4) (set to Empty if WHILE case) + + --------------------------------------- + -- 5.5 Loop parameter specification -- + --------------------------------------- + + -- LOOP_PARAMETER_SPECIFICATION ::= + -- DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION + + -- N_Loop_Parameter_Specification + -- Sloc points to first identifier + -- Defining_Identifier (Node1) + -- Reverse_Present (Flag15) + -- Discrete_Subtype_Definition (Node4) + + ---------------------------------- + -- 5.5.1 Iterator specification -- + ---------------------------------- + + -- ITERATOR_SPECIFICATION ::= + -- DEFINING_IDENTIFIER in [reverse] NAME + -- | DEFINING_IDENTIFIER [: SUBTYPE_INDICATION] of [reverse] NAME + + -- N_Iterator_Specification + -- Sloc points to defining identifier + -- Defining_Identifier (Node1) + -- Name (Node2) + -- Reverse_Present (Flag15) + -- Of_Present (Flag16) + -- Subtype_Indication (Node5) + + -- Note: The Of_Present flag distinguishes the two forms + + -------------------------- + -- 5.6 Block Statement -- + -------------------------- + + -- BLOCK_STATEMENT ::= + -- [block_STATEMENT_IDENTIFIER:] + -- [declare + -- DECLARATIVE_PART] + -- begin + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end [block_IDENTIFIER]; + + -- Note that the occurrence of a block identifier is not a defining + -- identifier, but rather a referencing occurrence. The defining + -- occurrence is an E_Block entity declared by the implicit label + -- declaration which occurs in the innermost enclosing block statement + -- or body; the block identifier denotes that E_Block. + + -- For block statements that come from source code, there is always a + -- block statement identifier present in the tree, denoting an + -- E_Block. In the case where no block identifier is given in the + -- source, the parser creates a name of the form B_n, where n is a + -- decimal integer, and the flag Has_Created_Identifier is set to + -- True. Blocks constructed by the expander usually have no identifier, + -- and no corresponding entity. + + -- Note: the block statement created for an extended return statement + -- has an entity, and this entity is an E_Return_Statement, rather than + -- the usual E_Block. + + -- Note: Exception_Junk is set for the wrapping blocks created during + -- local raise optimization (Exp_Ch11.Expand_Local_Exception_Handlers). + + -- N_Block_Statement + -- Sloc points to DECLARE or BEGIN + -- Identifier (Node1) block direct name (set to Empty if not present) + -- Declarations (List2) (set to No_List if no DECLARE part) + -- Handled_Statement_Sequence (Node4) + -- Is_Task_Master (Flag5-Sem) + -- Activation_Chain_Entity (Node3-Sem) + -- Has_Created_Identifier (Flag15) + -- Is_Task_Allocation_Block (Flag6) + -- Is_Asynchronous_Call_Block (Flag7) + -- Exception_Junk (Flag8-Sem) + + ------------------------- + -- 5.7 Exit Statement -- + ------------------------- + + -- EXIT_STATEMENT ::= exit [loop_NAME] [when CONDITION]; + + -- Gigi restriction: This expander ensures that the type of the + -- Condition field is always Standard.Boolean, even if the type + -- in the source is some non-standard boolean type. + + -- N_Exit_Statement + -- Sloc points to EXIT + -- Name (Node2) (set to Empty if no loop name present) + -- Condition (Node1) (set to Empty if no WHEN part present) + -- Next_Exit_Statement (Node3-Sem): Next exit on chain + + ------------------------- + -- 5.9 Goto Statement -- + ------------------------- + + -- GOTO_STATEMENT ::= goto label_NAME; + + -- N_Goto_Statement + -- Sloc points to GOTO + -- Name (Node2) + -- Exception_Junk (Flag8-Sem) + + --------------------------------- + -- 6.1 Subprogram Declaration -- + --------------------------------- + + -- SUBPROGRAM_DECLARATION ::= + -- SUBPROGRAM_SPECIFICATION + -- [ASPECT_SPECIFICATIONS]; + + -- N_Subprogram_Declaration + -- Sloc points to FUNCTION or PROCEDURE + -- Specification (Node1) + -- Body_To_Inline (Node3-Sem) + -- Corresponding_Body (Node5-Sem) + -- Parent_Spec (Node4-Sem) + + ------------------------------------------ + -- 6.1 Abstract Subprogram Declaration -- + ------------------------------------------ + + -- ABSTRACT_SUBPROGRAM_DECLARATION ::= + -- SUBPROGRAM_SPECIFICATION is abstract + -- [ASPECT_SPECIFICATIONS]; + + -- N_Abstract_Subprogram_Declaration + -- Sloc points to ABSTRACT + -- Specification (Node1) + + ----------------------------------- + -- 6.1 Subprogram Specification -- + ----------------------------------- + + -- SUBPROGRAM_SPECIFICATION ::= + -- [[not] overriding] + -- procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE + -- | [[not] overriding] + -- function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE + + -- Note: there are no separate nodes for the profiles, instead the + -- information appears directly in the following nodes. + + -- N_Function_Specification + -- Sloc points to FUNCTION + -- Defining_Unit_Name (Node1) (the designator) + -- Elaboration_Boolean (Node2-Sem) + -- Parameter_Specifications (List3) (set to No_List if no formal part) + -- Null_Exclusion_Present (Flag11) + -- Result_Definition (Node4) for result subtype + -- Generic_Parent (Node5-Sem) + -- Must_Override (Flag14) set if overriding indicator present + -- Must_Not_Override (Flag15) set if not_overriding indicator present + + -- N_Procedure_Specification + -- Sloc points to PROCEDURE + -- Defining_Unit_Name (Node1) + -- Elaboration_Boolean (Node2-Sem) + -- Parameter_Specifications (List3) (set to No_List if no formal part) + -- Generic_Parent (Node5-Sem) + -- Null_Present (Flag13) set for null procedure case (Ada 2005 feature) + -- Must_Override (Flag14) set if overriding indicator present + -- Must_Not_Override (Flag15) set if not_overriding indicator present + + -- Note: overriding indicator is an Ada 2005 feature + + --------------------- + -- 6.1 Designator -- + --------------------- + + -- DESIGNATOR ::= + -- [PARENT_UNIT_NAME .] IDENTIFIER | OPERATOR_SYMBOL + + -- Designators that are simply identifiers or operator symbols appear + -- directly in the tree in this form. The following node is used only + -- in the case where the designator has a parent unit name component. + + -- N_Designator + -- Sloc points to period + -- Name (Node2) holds the parent unit name. Note that this is always + -- non-Empty, since this node is only used for the case where a + -- parent library unit package name is present. + -- Identifier (Node1) + + -- Note that the identifier can also be an operator symbol here + + ------------------------------ + -- 6.1 Defining Designator -- + ------------------------------ + + -- DEFINING_DESIGNATOR ::= + -- DEFINING_PROGRAM_UNIT_NAME | DEFINING_OPERATOR_SYMBOL + + ------------------------------------- + -- 6.1 Defining Program Unit Name -- + ------------------------------------- + + -- DEFINING_PROGRAM_UNIT_NAME ::= + -- [PARENT_UNIT_NAME .] DEFINING_IDENTIFIER + + -- The parent unit name is present only in the case of a child unit + -- name (permissible only for Ada 95 for a library level unit, i.e. + -- a unit at scope level one). If no such name is present, the defining + -- program unit name is represented simply as the defining identifier. + -- In the child unit case, the following node is used to represent the + -- child unit name. + + -- N_Defining_Program_Unit_Name + -- Sloc points to period + -- Name (Node2) holds the parent unit name. Note that this is always + -- non-Empty, since this node is only used for the case where a + -- parent unit name is present. + -- Defining_Identifier (Node1) + + -------------------------- + -- 6.1 Operator Symbol -- + -------------------------- + + -- OPERATOR_SYMBOL ::= STRING_LITERAL + + -- Note: the fields of the N_Operator_Symbol node are laid out to + -- match the corresponding fields of an N_Character_Literal node. This + -- allows easy conversion of the operator symbol node into a character + -- literal node in the case where a string constant of the form of an + -- operator symbol is scanned out as such, but turns out semantically + -- to be a string literal that is not an operator. For details see + -- Sinfo.CN.Change_Operator_Symbol_To_String_Literal. + + -- N_Operator_Symbol + -- Sloc points to literal + -- Chars (Name1) contains the Name_Id for the operator symbol + -- Strval (Str3) Id of string value. This is used if the operator + -- symbol turns out to be a normal string after all. + -- Entity (Node4-Sem) + -- Associated_Node (Node4-Sem) + -- Has_Private_View (Flag11-Sem) set in generic units. + -- Etype (Node5-Sem) + + -- Note: the Strval field may be set to No_String for generated + -- operator symbols that are known not to be string literals + -- semantically. + + ----------------------------------- + -- 6.1 Defining Operator Symbol -- + ----------------------------------- + + -- DEFINING_OPERATOR_SYMBOL ::= OPERATOR_SYMBOL + + -- A defining operator symbol is an entity, which has additional + -- fields depending on the setting of the Ekind field. These + -- additional fields are defined (and access subprograms declared) + -- in package Einfo. + + -- Note: N_Defining_Operator_Symbol is an extended node whose fields + -- are deliberately layed out to match the layout of fields in an + -- ordinary N_Operator_Symbol node allowing for easy alteration of + -- an operator symbol node into a defining operator symbol node. + -- See Sinfo.CN.Change_Operator_Symbol_To_Defining_Operator_Symbol + -- for further details. + + -- N_Defining_Operator_Symbol + -- Sloc points to literal + -- Chars (Name1) contains the Name_Id for the operator symbol + -- Next_Entity (Node2-Sem) + -- Scope (Node3-Sem) + -- Etype (Node5-Sem) + + ---------------------------- + -- 6.1 Parameter Profile -- + ---------------------------- + + -- PARAMETER_PROFILE ::= [FORMAL_PART] + + --------------------------------------- + -- 6.1 Parameter and Result Profile -- + --------------------------------------- + + -- PARAMETER_AND_RESULT_PROFILE ::= + -- [FORMAL_PART] return [NULL_EXCLUSION] SUBTYPE_MARK + -- | [FORMAL_PART] return ACCESS_DEFINITION + + -- There is no explicit node in the tree for a parameter and result + -- profile. Instead the information appears directly in the parent. + + ---------------------- + -- 6.1 Formal part -- + ---------------------- + + -- FORMAL_PART ::= + -- (PARAMETER_SPECIFICATION {; PARAMETER_SPECIFICATION}) + + ---------------------------------- + -- 6.1 Parameter specification -- + ---------------------------------- + + -- PARAMETER_SPECIFICATION ::= + -- DEFINING_IDENTIFIER_LIST : MODE [NULL_EXCLUSION] SUBTYPE_MARK + -- [:= DEFAULT_EXPRESSION] + -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION + -- [:= DEFAULT_EXPRESSION] + + -- Although the syntax allows multiple identifiers in the list, the + -- semantics is as though successive specifications were given with + -- identical type definition and expression components. To simplify + -- semantic processing, the parser represents a multiple declaration + -- case as a sequence of single Specifications, using the More_Ids and + -- Prev_Ids flags to preserve the original source form as described + -- in the section on "Handling of Defining Identifier Lists". + + -- N_Parameter_Specification + -- Sloc points to first identifier + -- Defining_Identifier (Node1) + -- In_Present (Flag15) + -- Out_Present (Flag17) + -- Null_Exclusion_Present (Flag11) + -- Parameter_Type (Node2) subtype mark or access definition + -- Expression (Node3) (set to Empty if no default expression present) + -- Do_Accessibility_Check (Flag13-Sem) + -- More_Ids (Flag5) (set to False if no more identifiers in list) + -- Prev_Ids (Flag6) (set to False if no previous identifiers in list) + -- Default_Expression (Node5-Sem) + + --------------- + -- 6.1 Mode -- + --------------- + + -- MODE ::= [in] | in out | out + + -- There is no explicit node in the tree for the Mode. Instead the + -- In_Present and Out_Present flags are set in the parent node to + -- record the presence of keywords specifying the mode. + + -------------------------- + -- 6.3 Subprogram Body -- + -------------------------- + + -- SUBPROGRAM_BODY ::= + -- SUBPROGRAM_SPECIFICATION is + -- DECLARATIVE_PART + -- begin + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end [DESIGNATOR]; + + -- N_Subprogram_Body + -- Sloc points to FUNCTION or PROCEDURE + -- Specification (Node1) + -- Declarations (List2) + -- Handled_Statement_Sequence (Node4) + -- Activation_Chain_Entity (Node3-Sem) + -- Corresponding_Spec (Node5-Sem) + -- Acts_As_Spec (Flag4-Sem) + -- Bad_Is_Detected (Flag15) used only by parser + -- Do_Storage_Check (Flag17-Sem) + -- Has_Pragma_Priority (Flag6-Sem) + -- Is_Protected_Subprogram_Body (Flag7-Sem) + -- Is_Entry_Barrier_Function (Flag8-Sem) + -- Is_Task_Master (Flag5-Sem) + -- Was_Originally_Stub (Flag13-Sem) + -- Has_Relative_Deadline_Pragma (Flag9-Sem) + -- Has_Pragma_CPU (Flag14-Sem) + + ------------------------------ + -- Parameterized Expression -- + ------------------------------ + + -- This is an Ada 2012 extension, we put it here for now, to be labeled + -- and put in its proper section when we know exactly where that is! + + -- PARAMETERIZED_EXPRESSION ::= + -- FUNCTION SPECIFICATION IS (EXPRESSION); + + -- N_Parameterized_Expression + -- Sloc points to FUNCTION + -- Specification (Node1) + -- Expression (Node3) + + ----------------------------------- + -- 6.4 Procedure Call Statement -- + ----------------------------------- + + -- PROCEDURE_CALL_STATEMENT ::= + -- procedure_NAME; | procedure_PREFIX ACTUAL_PARAMETER_PART; + + -- Note: the reason that a procedure call has expression fields is + -- that it semantically resembles an expression, e.g. overloading is + -- allowed and a type is concocted for semantic processing purposes. + -- Certain of these fields, such as Parens are not relevant, but it + -- is easier to just supply all of them together! + + -- N_Procedure_Call_Statement + -- Sloc points to first token of name or prefix + -- Name (Node2) stores name or prefix + -- Parameter_Associations (List3) (set to No_List if no + -- actual parameter part) + -- First_Named_Actual (Node4-Sem) + -- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching) + -- Do_Tag_Check (Flag13-Sem) + -- No_Elaboration_Check (Flag14-Sem) + -- Parameter_List_Truncated (Flag17-Sem) + -- ABE_Is_Certain (Flag18-Sem) + -- plus fields for expression + + -- If any IN parameter requires a range check, then the corresponding + -- argument expression has the Do_Range_Check flag set, and the range + -- check is done against the formal type. Note that this argument + -- expression may appear directly in the Parameter_Associations list, + -- or may be a descendent of an N_Parameter_Association node that + -- appears in this list. + + ------------------------ + -- 6.4 Function Call -- + ------------------------ + + -- FUNCTION_CALL ::= + -- function_NAME | function_PREFIX ACTUAL_PARAMETER_PART + + -- Note: the parser may generate an indexed component node or simply + -- a name node instead of a function call node. The semantic pass must + -- correct this misidentification. + + -- N_Function_Call + -- Sloc points to first token of name or prefix + -- Name (Node2) stores name or prefix + -- Parameter_Associations (List3) (set to No_List if no + -- actual parameter part) + -- First_Named_Actual (Node4-Sem) + -- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching) + -- Is_Expanded_Build_In_Place_Call (Flag11-Sem) + -- Do_Tag_Check (Flag13-Sem) + -- No_Elaboration_Check (Flag14-Sem) + -- Parameter_List_Truncated (Flag17-Sem) + -- ABE_Is_Certain (Flag18-Sem) + -- plus fields for expression + + -------------------------------- + -- 6.4 Actual Parameter Part -- + -------------------------------- + + -- ACTUAL_PARAMETER_PART ::= + -- (PARAMETER_ASSOCIATION {,PARAMETER_ASSOCIATION}) + + -------------------------------- + -- 6.4 Parameter Association -- + -------------------------------- + + -- PARAMETER_ASSOCIATION ::= + -- [formal_parameter_SELECTOR_NAME =>] EXPLICIT_ACTUAL_PARAMETER + + -- Note: the N_Parameter_Association node is built only if a formal + -- parameter selector name is present, otherwise the parameter + -- association appears in the tree simply as the node for the + -- explicit actual parameter. + + -- N_Parameter_Association + -- Sloc points to formal parameter + -- Selector_Name (Node2) (always non-Empty) + -- Explicit_Actual_Parameter (Node3) + -- Next_Named_Actual (Node4-Sem) + -- Is_Accessibility_Actual (Flag13-Sem) + + --------------------------- + -- 6.4 Actual Parameter -- + --------------------------- + + -- EXPLICIT_ACTUAL_PARAMETER ::= EXPRESSION | variable_NAME + + --------------------------- + -- 6.5 Return Statement -- + --------------------------- + + -- RETURN_STATEMENT ::= return [EXPRESSION]; -- Ada 95 + + -- In Ada 2005, we have: + + -- SIMPLE_RETURN_STATEMENT ::= return [EXPRESSION]; + + -- EXTENDED_RETURN_STATEMENT ::= + -- return DEFINING_IDENTIFIER : [aliased] RETURN_SUBTYPE_INDICATION + -- [:= EXPRESSION] [do + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end return]; + + -- RETURN_SUBTYPE_INDICATION ::= SUBTYPE_INDICATION | ACCESS_DEFINITION + + -- So in Ada 2005, RETURN_STATEMENT is no longer a nonterminal, but + -- "return statement" is defined in 6.5 to mean a + -- SIMPLE_RETURN_STATEMENT or an EXTENDED_RETURN_STATEMENT. + + -- N_Return_Statement + -- Sloc points to RETURN + -- Return_Statement_Entity (Node5-Sem) + -- Expression (Node3) (set to Empty if no expression present) + -- Storage_Pool (Node1-Sem) + -- Procedure_To_Call (Node2-Sem) + -- Do_Tag_Check (Flag13-Sem) + -- By_Ref (Flag5-Sem) + -- Comes_From_Extended_Return_Statement (Flag18-Sem) + + -- N_Return_Statement represents a simple_return_statement, and is + -- renamed to be N_Simple_Return_Statement below. Clients should refer + -- to N_Simple_Return_Statement. We retain N_Return_Statement because + -- that's how gigi knows it. See also renaming of Make_Return_Statement + -- as Make_Simple_Return_Statement in Sem_Util. + + -- Note: Return_Statement_Entity points to an E_Return_Statement + + -- If a range check is required, then Do_Range_Check is set on the + -- Expression. The check is against the return subtype of the function. + + -- N_Extended_Return_Statement + -- Sloc points to RETURN + -- Return_Statement_Entity (Node5-Sem) + -- Return_Object_Declarations (List3) + -- Handled_Statement_Sequence (Node4) (set to Empty if not present) + -- Storage_Pool (Node1-Sem) + -- Procedure_To_Call (Node2-Sem) + -- Do_Tag_Check (Flag13-Sem) + -- By_Ref (Flag5-Sem) + + -- Note: Return_Statement_Entity points to an E_Return_Statement. + + -- Note that Return_Object_Declarations is a list containing the + -- N_Object_Declaration -- see comment on this field above. + + -- The declared object will have Is_Return_Object = True. + + -- There is no such syntactic category as return_object_declaration + -- in the RM. Return_Object_Declarations represents this portion of + -- the syntax for EXTENDED_RETURN_STATEMENT: + -- DEFINING_IDENTIFIER : [aliased] RETURN_SUBTYPE_INDICATION + -- [:= EXPRESSION] + + -- There are two entities associated with an extended_return_statement: + -- the Return_Statement_Entity represents the statement itself, and the + -- Defining_Identifier of the Object_Declaration in + -- Return_Object_Declarations represents the object being + -- returned. N_Simple_Return_Statement has only the former. + + ------------------------------ + -- 7.1 Package Declaration -- + ------------------------------ + + -- PACKAGE_DECLARATION ::= + -- PACKAGE_SPECIFICATION + -- [ASPECT_SPECIFICATIONS]; + + -- Note: the activation chain entity for a package spec is used for + -- all tasks declared in the package spec, or in the package body. + + -- N_Package_Declaration + -- Sloc points to PACKAGE + -- Specification (Node1) + -- Corresponding_Body (Node5-Sem) + -- Parent_Spec (Node4-Sem) + -- Activation_Chain_Entity (Node3-Sem) + + -------------------------------- + -- 7.1 Package Specification -- + -------------------------------- + + -- PACKAGE_SPECIFICATION ::= + -- package DEFINING_PROGRAM_UNIT_NAME is + -- {BASIC_DECLARATIVE_ITEM} + -- [private + -- {BASIC_DECLARATIVE_ITEM}] + -- end [[PARENT_UNIT_NAME .] IDENTIFIER] + + -- N_Package_Specification + -- Sloc points to PACKAGE + -- Defining_Unit_Name (Node1) + -- Visible_Declarations (List2) + -- Private_Declarations (List3) (set to No_List if no private + -- part present) + -- End_Label (Node4) + -- Generic_Parent (Node5-Sem) + -- Limited_View_Installed (Flag18-Sem) + + ----------------------- + -- 7.1 Package Body -- + ----------------------- + + -- PACKAGE_BODY ::= + -- package body DEFINING_PROGRAM_UNIT_NAME is + -- DECLARATIVE_PART + -- [begin + -- HANDLED_SEQUENCE_OF_STATEMENTS] + -- end [[PARENT_UNIT_NAME .] IDENTIFIER]; + + -- N_Package_Body + -- Sloc points to PACKAGE + -- Defining_Unit_Name (Node1) + -- Declarations (List2) + -- Handled_Statement_Sequence (Node4) (set to Empty if no HSS present) + -- Corresponding_Spec (Node5-Sem) + -- Was_Originally_Stub (Flag13-Sem) + + -- Note: if a source level package does not contain a handled sequence + -- of statements, then the parser supplies a dummy one with a null + -- sequence of statements. Comes_From_Source will be False in this + -- constructed sequence. The reason we need this is for the End_Label + -- field in the HSS. + + ----------------------------------- + -- 7.4 Private Type Declaration -- + ----------------------------------- + + -- PRIVATE_TYPE_DECLARATION ::= + -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] + -- is [[abstract] tagged] [limited] private; + + -- Note: TAGGED is not permitted in Ada 83 mode + + -- N_Private_Type_Declaration + -- Sloc points to TYPE + -- Defining_Identifier (Node1) + -- Discriminant_Specifications (List4) (set to No_List if no + -- discriminant part) + -- Unknown_Discriminants_Present (Flag13) set if (<>) discriminant + -- Abstract_Present (Flag4) + -- Tagged_Present (Flag15) + -- Limited_Present (Flag17) + + ---------------------------------------- + -- 7.4 Private Extension Declaration -- + ---------------------------------------- + + -- PRIVATE_EXTENSION_DECLARATION ::= + -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is + -- [abstract] [limited | synchronized] + -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST] + -- with private; + + -- Note: LIMITED, and private extension declarations are not allowed + -- in Ada 83 mode. + + -- N_Private_Extension_Declaration + -- Sloc points to TYPE + -- Defining_Identifier (Node1) + -- Discriminant_Specifications (List4) (set to No_List if no + -- discriminant part) + -- Unknown_Discriminants_Present (Flag13) set if (<>) discriminant + -- Abstract_Present (Flag4) + -- Limited_Present (Flag17) + -- Synchronized_Present (Flag7) + -- Subtype_Indication (Node5) + -- Interface_List (List2) (set to No_List if none) + + --------------------- + -- 8.4 Use Clause -- + --------------------- + + -- USE_CLAUSE ::= USE_PACKAGE_CLAUSE | USE_TYPE_CLAUSE + + ----------------------------- + -- 8.4 Use Package Clause -- + ----------------------------- + + -- USE_PACKAGE_CLAUSE ::= use package_NAME {, package_NAME}; + + -- N_Use_Package_Clause + -- Sloc points to USE + -- Names (List2) + -- Next_Use_Clause (Node3-Sem) + -- Hidden_By_Use_Clause (Elist4-Sem) + + -------------------------- + -- 8.4 Use Type Clause -- + -------------------------- + + -- USE_TYPE_CLAUSE ::= use [ALL] type SUBTYPE_MARK {, SUBTYPE_MARK}; + + -- Note: use type clause is not permitted in Ada 83 mode + + -- Note: the ALL keyword can appear only in Ada 2012 mode + + -- N_Use_Type_Clause + -- Sloc points to USE + -- Subtype_Marks (List2) + -- Next_Use_Clause (Node3-Sem) + -- Hidden_By_Use_Clause (Elist4-Sem) + -- All_Present (Flag15) + + ------------------------------- + -- 8.5 Renaming Declaration -- + ------------------------------- + + -- RENAMING_DECLARATION ::= + -- OBJECT_RENAMING_DECLARATION + -- | EXCEPTION_RENAMING_DECLARATION + -- | PACKAGE_RENAMING_DECLARATION + -- | SUBPROGRAM_RENAMING_DECLARATION + -- | GENERIC_RENAMING_DECLARATION + + -------------------------------------- + -- 8.5 Object Renaming Declaration -- + -------------------------------------- + + -- OBJECT_RENAMING_DECLARATION ::= + -- DEFINING_IDENTIFIER : + -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME; + -- | DEFINING_IDENTIFIER : + -- ACCESS_DEFINITION renames object_NAME; + + -- Note: Access_Definition is an optional field that gives support to + -- Ada 2005 (AI-230). The parser generates nodes that have either the + -- Subtype_Indication field or else the Access_Definition field. + + -- N_Object_Renaming_Declaration + -- Sloc points to first identifier + -- Defining_Identifier (Node1) + -- Null_Exclusion_Present (Flag11) (set to False if not present) + -- Subtype_Mark (Node4) (set to Empty if not present) + -- Access_Definition (Node3) (set to Empty if not present) + -- Name (Node2) + -- Corresponding_Generic_Association (Node5-Sem) + + ----------------------------------------- + -- 8.5 Exception Renaming Declaration -- + ----------------------------------------- + + -- EXCEPTION_RENAMING_DECLARATION ::= + -- DEFINING_IDENTIFIER : exception renames exception_NAME; + + -- N_Exception_Renaming_Declaration + -- Sloc points to first identifier + -- Defining_Identifier (Node1) + -- Name (Node2) + + --------------------------------------- + -- 8.5 Package Renaming Declaration -- + --------------------------------------- + + -- PACKAGE_RENAMING_DECLARATION ::= + -- package DEFINING_PROGRAM_UNIT_NAME renames package_NAME; + + -- N_Package_Renaming_Declaration + -- Sloc points to PACKAGE + -- Defining_Unit_Name (Node1) + -- Name (Node2) + -- Parent_Spec (Node4-Sem) + + ------------------------------------------ + -- 8.5 Subprogram Renaming Declaration -- + ------------------------------------------ + + -- SUBPROGRAM_RENAMING_DECLARATION ::= + -- SUBPROGRAM_SPECIFICATION renames callable_entity_NAME; + + -- N_Subprogram_Renaming_Declaration + -- Sloc points to RENAMES + -- Specification (Node1) + -- Name (Node2) + -- Parent_Spec (Node4-Sem) + -- Corresponding_Spec (Node5-Sem) + -- Corresponding_Formal_Spec (Node3-Sem) + -- From_Default (Flag6-Sem) + + ----------------------------------------- + -- 8.5.5 Generic Renaming Declaration -- + ----------------------------------------- + + -- GENERIC_RENAMING_DECLARATION ::= + -- generic package DEFINING_PROGRAM_UNIT_NAME + -- renames generic_package_NAME + -- | generic procedure DEFINING_PROGRAM_UNIT_NAME + -- renames generic_procedure_NAME + -- | generic function DEFINING_PROGRAM_UNIT_NAME + -- renames generic_function_NAME + + -- N_Generic_Package_Renaming_Declaration + -- Sloc points to GENERIC + -- Defining_Unit_Name (Node1) + -- Name (Node2) + -- Parent_Spec (Node4-Sem) + + -- N_Generic_Procedure_Renaming_Declaration + -- Sloc points to GENERIC + -- Defining_Unit_Name (Node1) + -- Name (Node2) + -- Parent_Spec (Node4-Sem) + + -- N_Generic_Function_Renaming_Declaration + -- Sloc points to GENERIC + -- Defining_Unit_Name (Node1) + -- Name (Node2) + -- Parent_Spec (Node4-Sem) + + -------------------------------- + -- 9.1 Task Type Declaration -- + -------------------------------- + + -- TASK_TYPE_DECLARATION ::= + -- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] + -- [is [new INTERFACE_LIST with] TASK_DEFINITION] + -- [ASPECT_SPECIFICATIONS]; + + -- N_Task_Type_Declaration + -- Sloc points to TASK + -- Defining_Identifier (Node1) + -- Discriminant_Specifications (List4) (set to No_List if no + -- discriminant part) + -- Interface_List (List2) (set to No_List if none) + -- Task_Definition (Node3) (set to Empty if not present) + -- Corresponding_Body (Node5-Sem) + + ---------------------------------- + -- 9.1 Single Task Declaration -- + ---------------------------------- + + -- SINGLE_TASK_DECLARATION ::= + -- task DEFINING_IDENTIFIER + -- [is [new INTERFACE_LIST with] TASK_DEFINITION] + -- [ASPECT_SPECIFICATIONS]; + + -- N_Single_Task_Declaration + -- Sloc points to TASK + -- Defining_Identifier (Node1) + -- Interface_List (List2) (set to No_List if none) + -- Task_Definition (Node3) (set to Empty if not present) + + -------------------------- + -- 9.1 Task Definition -- + -------------------------- + + -- TASK_DEFINITION ::= + -- {TASK_ITEM} + -- [private + -- {TASK_ITEM}] + -- end [task_IDENTIFIER] + + -- Note: as a result of semantic analysis, the list of task items can + -- include implicit type declarations resulting from entry families. + + -- N_Task_Definition + -- Sloc points to first token of task definition + -- Visible_Declarations (List2) + -- Private_Declarations (List3) (set to No_List if no private part) + -- End_Label (Node4) + -- Has_Pragma_Priority (Flag6-Sem) + -- Has_Storage_Size_Pragma (Flag5-Sem) + -- Has_Task_Info_Pragma (Flag7-Sem) + -- Has_Task_Name_Pragma (Flag8-Sem) + -- Has_Relative_Deadline_Pragma (Flag9-Sem) + -- Has_Pragma_CPU (Flag14-Sem) + + -------------------- + -- 9.1 Task Item -- + -------------------- + + -- TASK_ITEM ::= ENTRY_DECLARATION | REPRESENTATION_CLAUSE + + -------------------- + -- 9.1 Task Body -- + -------------------- + + -- TASK_BODY ::= + -- task body task_DEFINING_IDENTIFIER is + -- DECLARATIVE_PART + -- begin + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end [task_IDENTIFIER]; + + -- Gigi restriction: This node never appears + + -- N_Task_Body + -- Sloc points to TASK + -- Defining_Identifier (Node1) + -- Declarations (List2) + -- Handled_Statement_Sequence (Node4) + -- Is_Task_Master (Flag5-Sem) + -- Activation_Chain_Entity (Node3-Sem) + -- Corresponding_Spec (Node5-Sem) + -- Was_Originally_Stub (Flag13-Sem) + + ------------------------------------- + -- 9.4 Protected Type Declaration -- + ------------------------------------- + + -- PROTECTED_TYPE_DECLARATION ::= + -- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] + -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION + -- {ASPECT_SPECIFICATIONS]; + + -- Note: protected type declarations are not permitted in Ada 83 mode + + -- N_Protected_Type_Declaration + -- Sloc points to PROTECTED + -- Defining_Identifier (Node1) + -- Discriminant_Specifications (List4) (set to No_List if no + -- discriminant part) + -- Interface_List (List2) (set to No_List if none) + -- Protected_Definition (Node3) + -- Corresponding_Body (Node5-Sem) + + --------------------------------------- + -- 9.4 Single Protected Declaration -- + --------------------------------------- + + -- SINGLE_PROTECTED_DECLARATION ::= + -- protected DEFINING_IDENTIFIER + -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION + -- [ASPECT_SPECIFICATIONS]; + + -- Note: single protected declarations are not allowed in Ada 83 mode + + -- N_Single_Protected_Declaration + -- Sloc points to PROTECTED + -- Defining_Identifier (Node1) + -- Interface_List (List2) (set to No_List if none) + -- Protected_Definition (Node3) + + ------------------------------- + -- 9.4 Protected Definition -- + ------------------------------- + + -- PROTECTED_DEFINITION ::= + -- {PROTECTED_OPERATION_DECLARATION} + -- [private + -- {PROTECTED_ELEMENT_DECLARATION}] + -- end [protected_IDENTIFIER] + + -- N_Protected_Definition + -- Sloc points to first token of protected definition + -- Visible_Declarations (List2) + -- Private_Declarations (List3) (set to No_List if no private part) + -- End_Label (Node4) + -- Has_Pragma_Priority (Flag6-Sem) + + ------------------------------------------ + -- 9.4 Protected Operation Declaration -- + ------------------------------------------ + + -- PROTECTED_OPERATION_DECLARATION ::= + -- SUBPROGRAM_DECLARATION + -- | ENTRY_DECLARATION + -- | REPRESENTATION_CLAUSE + + ---------------------------------------- + -- 9.4 Protected Element Declaration -- + ---------------------------------------- + + -- PROTECTED_ELEMENT_DECLARATION ::= + -- PROTECTED_OPERATION_DECLARATION | COMPONENT_DECLARATION + + ------------------------- + -- 9.4 Protected Body -- + ------------------------- + + -- PROTECTED_BODY ::= + -- protected body DEFINING_IDENTIFIER is + -- {PROTECTED_OPERATION_ITEM} + -- end [protected_IDENTIFIER]; + + -- Note: protected bodies are not allowed in Ada 83 mode + + -- Gigi restriction: This node never appears + + -- N_Protected_Body + -- Sloc points to PROTECTED + -- Defining_Identifier (Node1) + -- Declarations (List2) protected operation items (and pragmas) + -- End_Label (Node4) + -- Corresponding_Spec (Node5-Sem) + -- Was_Originally_Stub (Flag13-Sem) + + ----------------------------------- + -- 9.4 Protected Operation Item -- + ----------------------------------- + + -- PROTECTED_OPERATION_ITEM ::= + -- SUBPROGRAM_DECLARATION + -- | SUBPROGRAM_BODY + -- | ENTRY_BODY + -- | REPRESENTATION_CLAUSE + + ------------------------------ + -- 9.5.2 Entry Declaration -- + ------------------------------ + + -- ENTRY_DECLARATION ::= + -- [[not] overriding] + -- entry DEFINING_IDENTIFIER + -- [(DISCRETE_SUBTYPE_DEFINITION)] PARAMETER_PROFILE; + + -- N_Entry_Declaration + -- Sloc points to ENTRY + -- Defining_Identifier (Node1) + -- Discrete_Subtype_Definition (Node4) (set to Empty if not present) + -- Parameter_Specifications (List3) (set to No_List if no formal part) + -- Corresponding_Body (Node5-Sem) + -- Must_Override (Flag14) set if overriding indicator present + -- Must_Not_Override (Flag15) set if not_overriding indicator present + + -- Note: overriding indicator is an Ada 2005 feature + + ----------------------------- + -- 9.5.2 Accept statement -- + ----------------------------- + + -- ACCEPT_STATEMENT ::= + -- accept entry_DIRECT_NAME + -- [(ENTRY_INDEX)] PARAMETER_PROFILE [do + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end [entry_IDENTIFIER]]; + + -- Gigi restriction: This node never appears + + -- Note: there are no explicit declarations allowed in an accept + -- statement. However, the implicit declarations for any statement + -- identifiers (labels and block/loop identifiers) are declarations + -- that belong logically to the accept statement, and that is why + -- there is a Declarations field in this node. + + -- N_Accept_Statement + -- Sloc points to ACCEPT + -- Entry_Direct_Name (Node1) + -- Entry_Index (Node5) (set to Empty if not present) + -- Parameter_Specifications (List3) (set to No_List if no formal part) + -- Handled_Statement_Sequence (Node4) + -- Declarations (List2) (set to No_List if no declarations) + + ------------------------ + -- 9.5.2 Entry Index -- + ------------------------ + + -- ENTRY_INDEX ::= EXPRESSION + + ----------------------- + -- 9.5.2 Entry Body -- + ----------------------- + + -- ENTRY_BODY ::= + -- entry DEFINING_IDENTIFIER ENTRY_BODY_FORMAL_PART ENTRY_BARRIER is + -- DECLARATIVE_PART + -- begin + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end [entry_IDENTIFIER]; + + -- ENTRY_BARRIER ::= when CONDITION + + -- Note: we store the CONDITION of the ENTRY_BARRIER in the node for + -- the ENTRY_BODY_FORMAL_PART to avoid the N_Entry_Body node getting + -- too full (it would otherwise have too many fields) + + -- Gigi restriction: This node never appears + + -- N_Entry_Body + -- Sloc points to ENTRY + -- Defining_Identifier (Node1) + -- Entry_Body_Formal_Part (Node5) + -- Declarations (List2) + -- Handled_Statement_Sequence (Node4) + -- Activation_Chain_Entity (Node3-Sem) + + ----------------------------------- + -- 9.5.2 Entry Body Formal Part -- + ----------------------------------- + + -- ENTRY_BODY_FORMAL_PART ::= + -- [(ENTRY_INDEX_SPECIFICATION)] PARAMETER_PROFILE + + -- Note that an entry body formal part node is present even if it is + -- empty. This reflects the grammar, in which it is the components of + -- the entry body formal part that are optional, not the entry body + -- formal part itself. Also this means that the barrier condition + -- always has somewhere to be stored. + + -- Gigi restriction: This node never appears + + -- N_Entry_Body_Formal_Part + -- Sloc points to first token + -- Entry_Index_Specification (Node4) (set to Empty if not present) + -- Parameter_Specifications (List3) (set to No_List if no formal part) + -- Condition (Node1) from entry barrier of entry body + + -------------------------- + -- 9.5.2 Entry Barrier -- + -------------------------- + + -- ENTRY_BARRIER ::= when CONDITION + + -------------------------------------- + -- 9.5.2 Entry Index Specification -- + -------------------------------------- + + -- ENTRY_INDEX_SPECIFICATION ::= + -- for DEFINING_IDENTIFIER in DISCRETE_SUBTYPE_DEFINITION + + -- Gigi restriction: This node never appears + + -- N_Entry_Index_Specification + -- Sloc points to FOR + -- Defining_Identifier (Node1) + -- Discrete_Subtype_Definition (Node4) + + --------------------------------- + -- 9.5.3 Entry Call Statement -- + --------------------------------- + + -- ENTRY_CALL_STATEMENT ::= entry_NAME [ACTUAL_PARAMETER_PART]; + + -- The parser may generate a procedure call for this construct. The + -- semantic pass must correct this misidentification where needed. + + -- Gigi restriction: This node never appears + + -- N_Entry_Call_Statement + -- Sloc points to first token of name + -- Name (Node2) + -- Parameter_Associations (List3) (set to No_List if no + -- actual parameter part) + -- First_Named_Actual (Node4-Sem) + + ------------------------------ + -- 9.5.4 Requeue Statement -- + ------------------------------ + + -- REQUEUE_STATEMENT ::= requeue entry_NAME [with abort]; + + -- Note: requeue statements are not permitted in Ada 83 mode + + -- Gigi restriction: This node never appears + + -- N_Requeue_Statement + -- Sloc points to REQUEUE + -- Name (Node2) + -- Abort_Present (Flag15) + + -------------------------- + -- 9.6 Delay Statement -- + -------------------------- + + -- DELAY_STATEMENT ::= + -- DELAY_UNTIL_STATEMENT + -- | DELAY_RELATIVE_STATEMENT + + -------------------------------- + -- 9.6 Delay Until Statement -- + -------------------------------- + + -- DELAY_UNTIL_STATEMENT ::= delay until delay_EXPRESSION; + + -- Note: delay until statements are not permitted in Ada 83 mode + + -- Gigi restriction: This node never appears + + -- N_Delay_Until_Statement + -- Sloc points to DELAY + -- Expression (Node3) + + ----------------------------------- + -- 9.6 Delay Relative Statement -- + ----------------------------------- + + -- DELAY_RELATIVE_STATEMENT ::= delay delay_EXPRESSION; + + -- Gigi restriction: This node never appears + + -- N_Delay_Relative_Statement + -- Sloc points to DELAY + -- Expression (Node3) + + --------------------------- + -- 9.7 Select Statement -- + --------------------------- + + -- SELECT_STATEMENT ::= + -- SELECTIVE_ACCEPT + -- | TIMED_ENTRY_CALL + -- | CONDITIONAL_ENTRY_CALL + -- | ASYNCHRONOUS_SELECT + + ----------------------------- + -- 9.7.1 Selective Accept -- + ----------------------------- + + -- SELECTIVE_ACCEPT ::= + -- select + -- [GUARD] + -- SELECT_ALTERNATIVE + -- {or + -- [GUARD] + -- SELECT_ALTERNATIVE} + -- [else + -- SEQUENCE_OF_STATEMENTS] + -- end select; + + -- Gigi restriction: This node never appears + + -- Note: the guard expression, if present, appears in the node for + -- the select alternative. + + -- N_Selective_Accept + -- Sloc points to SELECT + -- Select_Alternatives (List1) + -- Else_Statements (List4) (set to No_List if no else part) + + ------------------ + -- 9.7.1 Guard -- + ------------------ + + -- GUARD ::= when CONDITION => + + -- As noted above, the CONDITION that is part of a GUARD is included + -- in the node for the select alternative for convenience. + + ------------------------------- + -- 9.7.1 Select Alternative -- + ------------------------------- + + -- SELECT_ALTERNATIVE ::= + -- ACCEPT_ALTERNATIVE + -- | DELAY_ALTERNATIVE + -- | TERMINATE_ALTERNATIVE + + ------------------------------- + -- 9.7.1 Accept Alternative -- + ------------------------------- + + -- ACCEPT_ALTERNATIVE ::= + -- ACCEPT_STATEMENT [SEQUENCE_OF_STATEMENTS] + + -- Gigi restriction: This node never appears + + -- N_Accept_Alternative + -- Sloc points to ACCEPT + -- Accept_Statement (Node2) + -- Condition (Node1) from the guard (set to Empty if no guard present) + -- Statements (List3) (set to Empty_List if no statements) + -- Pragmas_Before (List4) pragmas before alt (set to No_List if none) + -- Accept_Handler_Records (List5-Sem) + + ------------------------------ + -- 9.7.1 Delay Alternative -- + ------------------------------ + + -- DELAY_ALTERNATIVE ::= + -- DELAY_STATEMENT [SEQUENCE_OF_STATEMENTS] + + -- Gigi restriction: This node never appears + + -- N_Delay_Alternative + -- Sloc points to DELAY + -- Delay_Statement (Node2) + -- Condition (Node1) from the guard (set to Empty if no guard present) + -- Statements (List3) (set to Empty_List if no statements) + -- Pragmas_Before (List4) pragmas before alt (set to No_List if none) + + ---------------------------------- + -- 9.7.1 Terminate Alternative -- + ---------------------------------- + + -- TERMINATE_ALTERNATIVE ::= terminate; + + -- Gigi restriction: This node never appears + + -- N_Terminate_Alternative + -- Sloc points to TERMINATE + -- Condition (Node1) from the guard (set to Empty if no guard present) + -- Pragmas_Before (List4) pragmas before alt (set to No_List if none) + -- Pragmas_After (List5) pragmas after alt (set to No_List if none) + + ----------------------------- + -- 9.7.2 Timed Entry Call -- + ----------------------------- + + -- TIMED_ENTRY_CALL ::= + -- select + -- ENTRY_CALL_ALTERNATIVE + -- or + -- DELAY_ALTERNATIVE + -- end select; + + -- Gigi restriction: This node never appears + + -- N_Timed_Entry_Call + -- Sloc points to SELECT + -- Entry_Call_Alternative (Node1) + -- Delay_Alternative (Node4) + + ----------------------------------- + -- 9.7.2 Entry Call Alternative -- + ----------------------------------- + + -- ENTRY_CALL_ALTERNATIVE ::= + -- PROCEDURE_OR_ENTRY_CALL [SEQUENCE_OF_STATEMENTS] + + -- PROCEDURE_OR_ENTRY_CALL ::= + -- PROCEDURE_CALL_STATEMENT | ENTRY_CALL_STATEMENT + + -- Gigi restriction: This node never appears + + -- N_Entry_Call_Alternative + -- Sloc points to first token of entry call statement + -- Entry_Call_Statement (Node1) + -- Statements (List3) (set to Empty_List if no statements) + -- Pragmas_Before (List4) pragmas before alt (set to No_List if none) + + ----------------------------------- + -- 9.7.3 Conditional Entry Call -- + ----------------------------------- + + -- CONDITIONAL_ENTRY_CALL ::= + -- select + -- ENTRY_CALL_ALTERNATIVE + -- else + -- SEQUENCE_OF_STATEMENTS + -- end select; + + -- Gigi restriction: This node never appears + + -- N_Conditional_Entry_Call + -- Sloc points to SELECT + -- Entry_Call_Alternative (Node1) + -- Else_Statements (List4) + + -------------------------------- + -- 9.7.4 Asynchronous Select -- + -------------------------------- + + -- ASYNCHRONOUS_SELECT ::= + -- select + -- TRIGGERING_ALTERNATIVE + -- then abort + -- ABORTABLE_PART + -- end select; + + -- Note: asynchronous select is not permitted in Ada 83 mode + + -- Gigi restriction: This node never appears + + -- N_Asynchronous_Select + -- Sloc points to SELECT + -- Triggering_Alternative (Node1) + -- Abortable_Part (Node2) + + ----------------------------------- + -- 9.7.4 Triggering Alternative -- + ----------------------------------- + + -- TRIGGERING_ALTERNATIVE ::= + -- TRIGGERING_STATEMENT [SEQUENCE_OF_STATEMENTS] + + -- Gigi restriction: This node never appears + + -- N_Triggering_Alternative + -- Sloc points to first token of triggering statement + -- Triggering_Statement (Node1) + -- Statements (List3) (set to Empty_List if no statements) + -- Pragmas_Before (List4) pragmas before alt (set to No_List if none) + + --------------------------------- + -- 9.7.4 Triggering Statement -- + --------------------------------- + + -- TRIGGERING_STATEMENT ::= PROCEDURE_OR_ENTRY_CALL | DELAY_STATEMENT + + --------------------------- + -- 9.7.4 Abortable Part -- + --------------------------- + + -- ABORTABLE_PART ::= SEQUENCE_OF_STATEMENTS + + -- Gigi restriction: This node never appears + + -- N_Abortable_Part + -- Sloc points to ABORT + -- Statements (List3) + + -------------------------- + -- 9.8 Abort Statement -- + -------------------------- + + -- ABORT_STATEMENT ::= abort task_NAME {, task_NAME}; + + -- Gigi restriction: This node never appears + + -- N_Abort_Statement + -- Sloc points to ABORT + -- Names (List2) + + ------------------------- + -- 10.1.1 Compilation -- + ------------------------- + + -- COMPILATION ::= {COMPILATION_UNIT} + + -- There is no explicit node in the tree for a compilation, since in + -- general the compiler is processing only a single compilation unit + -- at a time. It is possible to parse multiple units in syntax check + -- only mode, but the trees are discarded in that case. + + ------------------------------ + -- 10.1.1 Compilation Unit -- + ------------------------------ + + -- COMPILATION_UNIT ::= + -- CONTEXT_CLAUSE LIBRARY_ITEM + -- | CONTEXT_CLAUSE SUBUNIT + + -- The N_Compilation_Unit node itself represents the above syntax. + -- However, there are two additional items not reflected in the above + -- syntax. First we have the global declarations that are added by the + -- code generator. These are outer level declarations (so they cannot + -- be represented as being inside the units). An example is the wrapper + -- subprograms that are created to do ABE checking. As always a list of + -- declarations can contain actions as well (i.e. statements), and such + -- statements are executed as part of the elaboration of the unit. Note + -- that all such declarations are elaborated before the library unit. + + -- Similarly, certain actions need to be elaborated at the completion + -- of elaboration of the library unit (notably the statement that sets + -- the Boolean flag indicating that elaboration is complete). + + -- The third item not reflected in the syntax is pragmas that appear + -- after the compilation unit. As always pragmas are a problem since + -- they are not part of the formal syntax, but can be stuck into the + -- source following a set of ad hoc rules, and we have to find an ad + -- hoc way of sticking them into the tree. For pragmas that appear + -- before the library unit, we just consider them to be part of the + -- context clause, and pragmas can appear in the Context_Items list + -- of the compilation unit. However, pragmas can also appear after + -- the library item. + + -- To deal with all these problems, we create an auxiliary node for + -- a compilation unit, referenced from the N_Compilation_Unit node, + -- that contains these items. + + -- N_Compilation_Unit + -- Sloc points to first token of defining unit name + -- Library_Unit (Node4-Sem) corresponding/parent spec/body + -- Context_Items (List1) context items and pragmas preceding unit + -- Private_Present (Flag15) set if library unit has private keyword + -- Unit (Node2) library item or subunit + -- Aux_Decls_Node (Node5) points to the N_Compilation_Unit_Aux node + -- Has_No_Elaboration_Code (Flag17-Sem) + -- Body_Required (Flag13-Sem) set for spec if body is required + -- Acts_As_Spec (Flag4-Sem) flag for subprogram body with no spec + -- Context_Pending (Flag16-Sem) + -- First_Inlined_Subprogram (Node3-Sem) + -- Has_Pragma_Suppress_All (Flag14-Sem) + + -- N_Compilation_Unit_Aux + -- Sloc is a copy of the Sloc from the N_Compilation_Unit node + -- Declarations (List2) (set to No_List if no global declarations) + -- Actions (List1) (set to No_List if no actions) + -- Pragmas_After (List5) pragmas after unit (set to No_List if none) + -- Config_Pragmas (List4) config pragmas (set to Empty_List if none) + -- Default_Storage_Pool (Node3-Sem) + + -------------------------- + -- 10.1.1 Library Item -- + -------------------------- + + -- LIBRARY_ITEM ::= + -- [private] LIBRARY_UNIT_DECLARATION + -- | LIBRARY_UNIT_BODY + -- | [private] LIBRARY_UNIT_RENAMING_DECLARATION + + -- Note: PRIVATE is not allowed in Ada 83 mode + + -- There is no explicit node in the tree for library item, instead + -- the declaration or body, and the flag for private if present, + -- appear in the N_Compilation_Unit node. + + -------------------------------------- + -- 10.1.1 Library Unit Declaration -- + -------------------------------------- + + -- LIBRARY_UNIT_DECLARATION ::= + -- SUBPROGRAM_DECLARATION | PACKAGE_DECLARATION + -- | GENERIC_DECLARATION | GENERIC_INSTANTIATION + + ----------------------------------------------- + -- 10.1.1 Library Unit Renaming Declaration -- + ----------------------------------------------- + + -- LIBRARY_UNIT_RENAMING_DECLARATION ::= + -- PACKAGE_RENAMING_DECLARATION + -- | GENERIC_RENAMING_DECLARATION + -- | SUBPROGRAM_RENAMING_DECLARATION + + ------------------------------- + -- 10.1.1 Library unit body -- + ------------------------------- + + -- LIBRARY_UNIT_BODY ::= SUBPROGRAM_BODY | PACKAGE_BODY + + ------------------------------ + -- 10.1.1 Parent Unit Name -- + ------------------------------ + + -- PARENT_UNIT_NAME ::= NAME + + ---------------------------- + -- 10.1.2 Context clause -- + ---------------------------- + + -- CONTEXT_CLAUSE ::= {CONTEXT_ITEM} + + -- The context clause can include pragmas, and any pragmas that appear + -- before the context clause proper (i.e. all configuration pragmas, + -- also appear at the front of this list). + + -------------------------- + -- 10.1.2 Context_Item -- + -------------------------- + + -- CONTEXT_ITEM ::= WITH_CLAUSE | USE_CLAUSE | WITH_TYPE_CLAUSE + + ------------------------- + -- 10.1.2 With clause -- + ------------------------- + + -- WITH_CLAUSE ::= + -- with library_unit_NAME {,library_unit_NAME}; + + -- A separate With clause is built for each name, so that we have + -- a Corresponding_Spec field for each with'ed spec. The flags + -- First_Name and Last_Name are used to reconstruct the exact + -- source form. When a list of names appears in one with clause, + -- the first name in the list has First_Name set, and the last + -- has Last_Name set. If the with clause has only one name, then + -- both of the flags First_Name and Last_Name are set in this name. + + -- Note: in the case of implicit with's that are installed by the + -- Rtsfind routine, Implicit_With is set, and the Sloc is typically + -- set to Standard_Location, but it is incorrect to test the Sloc + -- to find out if a with clause is implicit, test the flag instead. + + -- N_With_Clause + -- Sloc points to first token of library unit name + -- Withed_Body (Node1-Sem) + -- Name (Node2) + -- Next_Implicit_With (Node3-Sem) + -- Library_Unit (Node4-Sem) + -- Corresponding_Spec (Node5-Sem) + -- First_Name (Flag5) (set to True if first name or only one name) + -- Last_Name (Flag6) (set to True if last name or only one name) + -- Context_Installed (Flag13-Sem) + -- Elaborate_Present (Flag4-Sem) + -- Elaborate_All_Present (Flag14-Sem) + -- Elaborate_All_Desirable (Flag9-Sem) + -- Elaborate_Desirable (Flag11-Sem) + -- Private_Present (Flag15) set if with_clause has private keyword + -- Implicit_With (Flag16-Sem) + -- Limited_Present (Flag17) set if LIMITED is present + -- Limited_View_Installed (Flag18-Sem) + -- Unreferenced_In_Spec (Flag7-Sem) + -- No_Entities_Ref_In_Spec (Flag8-Sem) + + -- Note: Limited_Present and Limited_View_Installed give support to + -- Ada 2005 (AI-50217). + -- Similarly, Private_Present gives support to AI-50262. + + ---------------------- + -- With_Type clause -- + ---------------------- + + -- This is a GNAT extension, used to implement mutually recursive + -- types declared in different packages. + -- Note: this is now obsolete. The functionality of this construct + -- is now implemented by the Ada 2005 Limited_with_Clause. + + --------------------- + -- 10.2 Body stub -- + --------------------- + + -- BODY_STUB ::= + -- SUBPROGRAM_BODY_STUB + -- | PACKAGE_BODY_STUB + -- | TASK_BODY_STUB + -- | PROTECTED_BODY_STUB + + ---------------------------------- + -- 10.1.3 Subprogram Body Stub -- + ---------------------------------- + + -- SUBPROGRAM_BODY_STUB ::= + -- SUBPROGRAM_SPECIFICATION is separate; + + -- N_Subprogram_Body_Stub + -- Sloc points to FUNCTION or PROCEDURE + -- Specification (Node1) + -- Library_Unit (Node4-Sem) points to the subunit + -- Corresponding_Body (Node5-Sem) + + ------------------------------- + -- 10.1.3 Package Body Stub -- + ------------------------------- + + -- PACKAGE_BODY_STUB ::= + -- package body DEFINING_IDENTIFIER is separate; + + -- N_Package_Body_Stub + -- Sloc points to PACKAGE + -- Defining_Identifier (Node1) + -- Library_Unit (Node4-Sem) points to the subunit + -- Corresponding_Body (Node5-Sem) + + ---------------------------- + -- 10.1.3 Task Body Stub -- + ---------------------------- + + -- TASK_BODY_STUB ::= + -- task body DEFINING_IDENTIFIER is separate; + + -- N_Task_Body_Stub + -- Sloc points to TASK + -- Defining_Identifier (Node1) + -- Library_Unit (Node4-Sem) points to the subunit + -- Corresponding_Body (Node5-Sem) + + --------------------------------- + -- 10.1.3 Protected Body Stub -- + --------------------------------- + + -- PROTECTED_BODY_STUB ::= + -- protected body DEFINING_IDENTIFIER is separate; + + -- Note: protected body stubs are not allowed in Ada 83 mode + + -- N_Protected_Body_Stub + -- Sloc points to PROTECTED + -- Defining_Identifier (Node1) + -- Library_Unit (Node4-Sem) points to the subunit + -- Corresponding_Body (Node5-Sem) + + --------------------- + -- 10.1.3 Subunit -- + --------------------- + + -- SUBUNIT ::= separate (PARENT_UNIT_NAME) PROPER_BODY + + -- N_Subunit + -- Sloc points to SEPARATE + -- Name (Node2) is the name of the parent unit + -- Proper_Body (Node1) is the subunit body + -- Corresponding_Stub (Node3-Sem) is the stub declaration for the unit. + + --------------------------------- + -- 11.1 Exception Declaration -- + --------------------------------- + + -- EXCEPTION_DECLARATION ::= DEFINING_IDENTIFIER_LIST : exception + -- [ASPECT_SPECIFICATIONS]; + + -- For consistency with object declarations etc., the parser converts + -- the case of multiple identifiers being declared to a series of + -- declarations in which the expression is copied, using the More_Ids + -- and Prev_Ids flags to remember the source form as described in the + -- section on "Handling of Defining Identifier Lists". + + -- N_Exception_Declaration + -- Sloc points to EXCEPTION + -- Defining_Identifier (Node1) + -- Expression (Node3-Sem) + -- Renaming_Exception (Node2-Sem) + -- More_Ids (Flag5) (set to False if no more identifiers in list) + -- Prev_Ids (Flag6) (set to False if no previous identifiers in list) + + ------------------------------------------ + -- 11.2 Handled Sequence Of Statements -- + ------------------------------------------ + + -- HANDLED_SEQUENCE_OF_STATEMENTS ::= + -- SEQUENCE_OF_STATEMENTS + -- [exception + -- EXCEPTION_HANDLER + -- {EXCEPTION_HANDLER}] + -- [at end + -- cleanup_procedure_call (param, param, param, ...);] + + -- The AT END phrase is a GNAT extension to provide for cleanups. It is + -- used only internally currently, but is considered to be syntactic. + -- At the moment, the only cleanup action allowed is a single call to + -- a parameterless procedure, and the Identifier field of the node is + -- the procedure to be called. Also there is a current restriction + -- that exception handles and a cleanup cannot be present in the same + -- frame, so at least one of Exception_Handlers or the Identifier must + -- be missing. + + -- Actually, more accurately, this restriction applies to the original + -- source program. In the expanded tree, if the At_End_Proc field is + -- present, then there will also be an exception handler of the form: + + -- when all others => + -- cleanup; + -- raise; + + -- where cleanup is the procedure to be generated. The reason we do + -- this is so that the front end can handle the necessary entries in + -- the exception tables, and other exception handler actions required + -- as part of the normal handling for exception handlers. + + -- The AT END cleanup handler protects only the sequence of statements + -- (not the associated declarations of the parent), just like exception + -- handlers. The big difference is that the cleanup procedure is called + -- on either a normal or an abnormal exit from the statement sequence. + + -- Note: the list of Exception_Handlers can contain pragmas as well + -- as actual handlers. In practice these pragmas can only occur at + -- the start of the list, since any pragmas occurring later on will + -- be included in the statement list of the corresponding handler. + + -- Note: although in the Ada syntax, the sequence of statements in + -- a handled sequence of statements can only contain statements, we + -- allow free mixing of declarations and statements in the resulting + -- expanded tree. This is for example used to deal with the case of + -- a cleanup procedure that must handle declarations as well as the + -- statements of a block. + + -- N_Handled_Sequence_Of_Statements + -- Sloc points to first token of first statement + -- Statements (List3) + -- End_Label (Node4) (set to Empty if expander generated) + -- Exception_Handlers (List5) (set to No_List if none present) + -- At_End_Proc (Node1) (set to Empty if no clean up procedure) + -- First_Real_Statement (Node2-Sem) + -- Zero_Cost_Handling (Flag5-Sem) + + -- Note: the parent always contains a Declarations field which contains + -- declarations associated with the handled sequence of statements. This + -- is true even in the case of an accept statement (see description of + -- the N_Accept_Statement node). + + -- End_Label refers to the containing construct + + ----------------------------- + -- 11.2 Exception Handler -- + ----------------------------- + + -- EXCEPTION_HANDLER ::= + -- when [CHOICE_PARAMETER_SPECIFICATION :] + -- EXCEPTION_CHOICE {| EXCEPTION_CHOICE} => + -- SEQUENCE_OF_STATEMENTS + + -- Note: choice parameter specification is not allowed in Ada 83 mode + + -- N_Exception_Handler + -- Sloc points to WHEN + -- Choice_Parameter (Node2) (set to Empty if not present) + -- Exception_Choices (List4) + -- Statements (List3) + -- Exception_Label (Node5-Sem) (set to Empty of not present) + -- Zero_Cost_Handling (Flag5-Sem) + -- Local_Raise_Statements (Elist1-Sem) (set to No_Elist if not present) + -- Local_Raise_Not_OK (Flag7-Sem) + -- Has_Local_Raise (Flag8-Sem) + + ------------------------------------------ + -- 11.2 Choice parameter specification -- + ------------------------------------------ + + -- CHOICE_PARAMETER_SPECIFICATION ::= DEFINING_IDENTIFIER + + ---------------------------- + -- 11.2 Exception Choice -- + ---------------------------- + + -- EXCEPTION_CHOICE ::= exception_NAME | others + + -- Except in the case of OTHERS, no explicit node appears in the tree + -- for exception choice. Instead the exception name appears directly. + -- An OTHERS choice is represented by a N_Others_Choice node (see + -- section 3.8.1. + + -- Note: for the exception choice created for an at end handler, the + -- exception choice is an N_Others_Choice node with All_Others set. + + --------------------------- + -- 11.3 Raise Statement -- + --------------------------- + + -- RAISE_STATEMENT ::= raise [exception_NAME]; + + -- In Ada 2005, we have + + -- RAISE_STATEMENT ::= raise; | raise exception_NAME [with EXPRESSION]; + + -- N_Raise_Statement + -- Sloc points to RAISE + -- Name (Node2) (set to Empty if no exception name present) + -- Expression (Node3) (set to Empty if no expression present) + -- From_At_End (Flag4-Sem) + + ------------------------------- + -- 12.1 Generic Declaration -- + ------------------------------- + + -- GENERIC_DECLARATION ::= + -- GENERIC_SUBPROGRAM_DECLARATION | GENERIC_PACKAGE_DECLARATION + + ------------------------------------------ + -- 12.1 Generic Subprogram Declaration -- + ------------------------------------------ + + -- GENERIC_SUBPROGRAM_DECLARATION ::= + -- GENERIC_FORMAL_PART SUBPROGRAM_SPECIFICATION; + + -- Note: Generic_Formal_Declarations can include pragmas + + -- N_Generic_Subprogram_Declaration + -- Sloc points to GENERIC + -- Specification (Node1) subprogram specification + -- Corresponding_Body (Node5-Sem) + -- Generic_Formal_Declarations (List2) from generic formal part + -- Parent_Spec (Node4-Sem) + + --------------------------------------- + -- 12.1 Generic Package Declaration -- + --------------------------------------- + + -- GENERIC_PACKAGE_DECLARATION ::= + -- GENERIC_FORMAL_PART PACKAGE_SPECIFICATION + -- [ASPECT_SPECIFICATIONS]; + + -- Note: when we do generics right, the Activation_Chain_Entity entry + -- for this node can be removed (since the expander won't see generic + -- units any more)???. + + -- Note: Generic_Formal_Declarations can include pragmas + + -- N_Generic_Package_Declaration + -- Sloc points to GENERIC + -- Specification (Node1) package specification + -- Corresponding_Body (Node5-Sem) + -- Generic_Formal_Declarations (List2) from generic formal part + -- Parent_Spec (Node4-Sem) + -- Activation_Chain_Entity (Node3-Sem) + + ------------------------------- + -- 12.1 Generic Formal Part -- + ------------------------------- + + -- GENERIC_FORMAL_PART ::= + -- generic {GENERIC_FORMAL_PARAMETER_DECLARATION | USE_CLAUSE} + + ------------------------------------------------ + -- 12.1 Generic Formal Parameter Declaration -- + ------------------------------------------------ + + -- GENERIC_FORMAL_PARAMETER_DECLARATION ::= + -- FORMAL_OBJECT_DECLARATION + -- | FORMAL_TYPE_DECLARATION + -- | FORMAL_SUBPROGRAM_DECLARATION + -- | FORMAL_PACKAGE_DECLARATION + + --------------------------------- + -- 12.3 Generic Instantiation -- + --------------------------------- + + -- GENERIC_INSTANTIATION ::= + -- package DEFINING_PROGRAM_UNIT_NAME is + -- new generic_package_NAME [GENERIC_ACTUAL_PART] + -- [ASPECT_SPECIFICATIONS]; + -- | [[not] overriding] + -- procedure DEFINING_PROGRAM_UNIT_NAME is + -- new generic_procedure_NAME [GENERIC_ACTUAL_PART] + -- [ASPECT_SPECIFICATIONS]; + -- | [[not] overriding] + -- function DEFINING_DESIGNATOR is + -- new generic_function_NAME [GENERIC_ACTUAL_PART] + -- [ASPECT_SPECIFICATIONS]; + + -- N_Package_Instantiation + -- Sloc points to PACKAGE + -- Defining_Unit_Name (Node1) + -- Name (Node2) + -- Generic_Associations (List3) (set to No_List if no + -- generic actual part) + -- Parent_Spec (Node4-Sem) + -- Instance_Spec (Node5-Sem) + -- ABE_Is_Certain (Flag18-Sem) + + -- N_Procedure_Instantiation + -- Sloc points to PROCEDURE + -- Defining_Unit_Name (Node1) + -- Name (Node2) + -- Parent_Spec (Node4-Sem) + -- Generic_Associations (List3) (set to No_List if no + -- generic actual part) + -- Instance_Spec (Node5-Sem) + -- Must_Override (Flag14) set if overriding indicator present + -- Must_Not_Override (Flag15) set if not_overriding indicator present + -- ABE_Is_Certain (Flag18-Sem) + + -- N_Function_Instantiation + -- Sloc points to FUNCTION + -- Defining_Unit_Name (Node1) + -- Name (Node2) + -- Generic_Associations (List3) (set to No_List if no + -- generic actual part) + -- Parent_Spec (Node4-Sem) + -- Instance_Spec (Node5-Sem) + -- Must_Override (Flag14) set if overriding indicator present + -- Must_Not_Override (Flag15) set if not_overriding indicator present + -- ABE_Is_Certain (Flag18-Sem) + + -- Note: overriding indicator is an Ada 2005 feature + + ------------------------------- + -- 12.3 Generic Actual Part -- + ------------------------------- + + -- GENERIC_ACTUAL_PART ::= + -- (GENERIC_ASSOCIATION {, GENERIC_ASSOCIATION}) + + ------------------------------- + -- 12.3 Generic Association -- + ------------------------------- + + -- GENERIC_ASSOCIATION ::= + -- [generic_formal_parameter_SELECTOR_NAME =>] + + -- Note: unlike the procedure call case, a generic association node + -- is generated for every association, even if no formal parameter + -- selector name is present. In this case the parser will leave the + -- Selector_Name field set to Empty, to be filled in later by the + -- semantic pass. + + -- In Ada 2005, a formal may be associated with a box, if the + -- association is part of the list of actuals for a formal package. + -- If the association is given by OTHERS => <>, the association is + -- an N_Others_Choice. + + -- N_Generic_Association + -- Sloc points to first token of generic association + -- Selector_Name (Node2) (set to Empty if no formal + -- parameter selector name) + -- Explicit_Generic_Actual_Parameter (Node1) (Empty if box present) + -- Box_Present (Flag15) (for formal_package associations with a box) + + --------------------------------------------- + -- 12.3 Explicit Generic Actual Parameter -- + --------------------------------------------- + + -- EXPLICIT_GENERIC_ACTUAL_PARAMETER ::= + -- EXPRESSION | variable_NAME | subprogram_NAME + -- | entry_NAME | SUBTYPE_MARK | package_instance_NAME + + ------------------------------------- + -- 12.4 Formal Object Declaration -- + ------------------------------------- + + -- FORMAL_OBJECT_DECLARATION ::= + -- DEFINING_IDENTIFIER_LIST : + -- MODE [NULL_EXCLUSION] SUBTYPE_MARK [:= DEFAULT_EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; + -- | DEFINING_IDENTIFIER_LIST : + -- MODE ACCESS_DEFINITION [:= DEFAULT_EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; + + -- Although the syntax allows multiple identifiers in the list, the + -- semantics is as though successive declarations were given with + -- identical type definition and expression components. To simplify + -- semantic processing, the parser represents a multiple declaration + -- case as a sequence of single declarations, using the More_Ids and + -- Prev_Ids flags to preserve the original source form as described + -- in the section on "Handling of Defining Identifier Lists". + + -- N_Formal_Object_Declaration + -- Sloc points to first identifier + -- Defining_Identifier (Node1) + -- In_Present (Flag15) + -- Out_Present (Flag17) + -- Null_Exclusion_Present (Flag11) (set to False if not present) + -- Subtype_Mark (Node4) (set to Empty if not present) + -- Access_Definition (Node3) (set to Empty if not present) + -- Default_Expression (Node5) (set to Empty if no default expression) + -- More_Ids (Flag5) (set to False if no more identifiers in list) + -- Prev_Ids (Flag6) (set to False if no previous identifiers in list) + + ----------------------------------- + -- 12.5 Formal Type Declaration -- + ----------------------------------- + + -- FORMAL_TYPE_DECLARATION ::= + -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] + -- is FORMAL_TYPE_DEFINITION + -- [ASPECT_SPECIFICATIONS]; + + -- N_Formal_Type_Declaration + -- Sloc points to TYPE + -- Defining_Identifier (Node1) + -- Formal_Type_Definition (Node3) + -- Discriminant_Specifications (List4) (set to No_List if no + -- discriminant part) + -- Unknown_Discriminants_Present (Flag13) set if (<>) discriminant + + ---------------------------------- + -- 12.5 Formal type definition -- + ---------------------------------- + + -- FORMAL_TYPE_DEFINITION ::= + -- FORMAL_PRIVATE_TYPE_DEFINITION + -- | FORMAL_DERIVED_TYPE_DEFINITION + -- | FORMAL_DISCRETE_TYPE_DEFINITION + -- | FORMAL_SIGNED_INTEGER_TYPE_DEFINITION + -- | FORMAL_MODULAR_TYPE_DEFINITION + -- | FORMAL_FLOATING_POINT_DEFINITION + -- | FORMAL_ORDINARY_FIXED_POINT_DEFINITION + -- | FORMAL_DECIMAL_FIXED_POINT_DEFINITION + -- | FORMAL_ARRAY_TYPE_DEFINITION + -- | FORMAL_ACCESS_TYPE_DEFINITION + -- | FORMAL_INTERFACE_TYPE_DEFINITION + + --------------------------------------------- + -- 12.5.1 Formal Private Type Definition -- + --------------------------------------------- + + -- FORMAL_PRIVATE_TYPE_DEFINITION ::= + -- [[abstract] tagged] [limited] private + + -- Note: TAGGED is not allowed in Ada 83 mode + + -- N_Formal_Private_Type_Definition + -- Sloc points to PRIVATE + -- Abstract_Present (Flag4) + -- Tagged_Present (Flag15) + -- Limited_Present (Flag17) + + -------------------------------------------- + -- 12.5.1 Formal Derived Type Definition -- + -------------------------------------------- + + -- FORMAL_DERIVED_TYPE_DEFINITION ::= + -- [abstract] [limited | synchronized] + -- new SUBTYPE_MARK [[and INTERFACE_LIST] with private] + -- Note: this construct is not allowed in Ada 83 mode + + -- N_Formal_Derived_Type_Definition + -- Sloc points to NEW + -- Subtype_Mark (Node4) + -- Private_Present (Flag15) + -- Abstract_Present (Flag4) + -- Limited_Present (Flag17) + -- Synchronized_Present (Flag7) + -- Interface_List (List2) (set to No_List if none) + + --------------------------------------------- + -- 12.5.2 Formal Discrete Type Definition -- + --------------------------------------------- + + -- FORMAL_DISCRETE_TYPE_DEFINITION ::= (<>) + + -- N_Formal_Discrete_Type_Definition + -- Sloc points to ( + + --------------------------------------------------- + -- 12.5.2 Formal Signed Integer Type Definition -- + --------------------------------------------------- + + -- FORMAL_SIGNED_INTEGER_TYPE_DEFINITION ::= range <> + + -- N_Formal_Signed_Integer_Type_Definition + -- Sloc points to RANGE + + -------------------------------------------- + -- 12.5.2 Formal Modular Type Definition -- + -------------------------------------------- + + -- FORMAL_MODULAR_TYPE_DEFINITION ::= mod <> + + -- N_Formal_Modular_Type_Definition + -- Sloc points to MOD + + ---------------------------------------------- + -- 12.5.2 Formal Floating Point Definition -- + ---------------------------------------------- + + -- FORMAL_FLOATING_POINT_DEFINITION ::= digits <> + + -- N_Formal_Floating_Point_Definition + -- Sloc points to DIGITS + + ---------------------------------------------------- + -- 12.5.2 Formal Ordinary Fixed Point Definition -- + ---------------------------------------------------- + + -- FORMAL_ORDINARY_FIXED_POINT_DEFINITION ::= delta <> + + -- N_Formal_Ordinary_Fixed_Point_Definition + -- Sloc points to DELTA + + --------------------------------------------------- + -- 12.5.2 Formal Decimal Fixed Point Definition -- + --------------------------------------------------- + + -- FORMAL_DECIMAL_FIXED_POINT_DEFINITION ::= delta <> digits <> + + -- Note: formal decimal fixed point definition not allowed in Ada 83 + + -- N_Formal_Decimal_Fixed_Point_Definition + -- Sloc points to DELTA + + ------------------------------------------ + -- 12.5.3 Formal Array Type Definition -- + ------------------------------------------ + + -- FORMAL_ARRAY_TYPE_DEFINITION ::= ARRAY_TYPE_DEFINITION + + ------------------------------------------- + -- 12.5.4 Formal Access Type Definition -- + ------------------------------------------- + + -- FORMAL_ACCESS_TYPE_DEFINITION ::= ACCESS_TYPE_DEFINITION + + ---------------------------------------------- + -- 12.5.5 Formal Interface Type Definition -- + ---------------------------------------------- + + -- FORMAL_INTERFACE_TYPE_DEFINITION ::= INTERFACE_TYPE_DEFINITION + + ----------------------------------------- + -- 12.6 Formal Subprogram Declaration -- + ----------------------------------------- + + -- FORMAL_SUBPROGRAM_DECLARATION ::= + -- FORMAL_CONCRETE_SUBPROGRAM_DECLARATION + -- | FORMAL_ABSTRACT_SUBPROGRAM_DECLARATION + + -------------------------------------------------- + -- 12.6 Formal Concrete Subprogram Declaration -- + -------------------------------------------------- + + -- FORMAL_CONCRETE_SUBPROGRAM_DECLARATION ::= + -- with SUBPROGRAM_SPECIFICATION [is SUBPROGRAM_DEFAULT] + -- [ASPECT_SPECIFICATIONS]; + + -- N_Formal_Concrete_Subprogram_Declaration + -- Sloc points to WITH + -- Specification (Node1) + -- Default_Name (Node2) (set to Empty if no subprogram default) + -- Box_Present (Flag15) + + -- Note: if no subprogram default is present, then Name is set + -- to Empty, and Box_Present is False. + + -------------------------------------------------- + -- 12.6 Formal Abstract Subprogram Declaration -- + -------------------------------------------------- + + -- FORMAL_ABSTRACT_SUBPROGRAM_DECLARATION ::= + -- with SUBPROGRAM_SPECIFICATION is abstract [SUBPROGRAM_DEFAULT] + -- [ASPECT_SPECIFICATIONS]; + + -- N_Formal_Abstract_Subprogram_Declaration + -- Sloc points to WITH + -- Specification (Node1) + -- Default_Name (Node2) (set to Empty if no subprogram default) + -- Box_Present (Flag15) + + -- Note: if no subprogram default is present, then Name is set + -- to Empty, and Box_Present is False. + + ------------------------------ + -- 12.6 Subprogram Default -- + ------------------------------ + + -- SUBPROGRAM_DEFAULT ::= DEFAULT_NAME | <> + + -- There is no separate node in the tree for a subprogram default. + -- Instead the parent (N_Formal_Concrete_Subprogram_Declaration + -- or N_Formal_Abstract_Subprogram_Declaration) node contains the + -- default name or box indication, as needed. + + ------------------------ + -- 12.6 Default Name -- + ------------------------ + + -- DEFAULT_NAME ::= NAME + + -------------------------------------- + -- 12.7 Formal Package Declaration -- + -------------------------------------- + + -- FORMAL_PACKAGE_DECLARATION ::= + -- with package DEFINING_IDENTIFIER + -- is new generic_package_NAME FORMAL_PACKAGE_ACTUAL_PART + -- [ASPECT_SPECIFICATIONS]; + + -- Note: formal package declarations not allowed in Ada 83 mode + + -- N_Formal_Package_Declaration + -- Sloc points to WITH + -- Defining_Identifier (Node1) + -- Name (Node2) + -- Generic_Associations (List3) (set to No_List if (<>) case or + -- empty generic actual part) + -- Box_Present (Flag15) + -- Instance_Spec (Node5-Sem) + -- ABE_Is_Certain (Flag18-Sem) + + -------------------------------------- + -- 12.7 Formal Package Actual Part -- + -------------------------------------- + + -- FORMAL_PACKAGE_ACTUAL_PART ::= + -- ([OTHERS] => <>) + -- | [GENERIC_ACTUAL_PART] + -- (FORMAL_PACKAGE_ASSOCIATION {. FORMAL_PACKAGE_ASSOCIATION} + + -- FORMAL_PACKAGE_ASSOCIATION ::= + -- GENERIC_ASSOCIATION + -- | GENERIC_FORMAL_PARAMETER_SELECTOR_NAME => <> + + -- There is no explicit node in the tree for a formal package actual + -- part. Instead the information appears in the parent node (i.e. the + -- formal package declaration node itself). + + -- There is no explicit node for a formal package association. All of + -- them are represented either by a generic association, possibly with + -- Box_Present, or by an N_Others_Choice. + + --------------------------------- + -- 13.1 Representation clause -- + --------------------------------- + + -- REPRESENTATION_CLAUSE ::= + -- ATTRIBUTE_DEFINITION_CLAUSE + -- | ENUMERATION_REPRESENTATION_CLAUSE + -- | RECORD_REPRESENTATION_CLAUSE + -- | AT_CLAUSE + + ---------------------- + -- 13.1 Local Name -- + ---------------------- + + -- LOCAL_NAME := + -- DIRECT_NAME + -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR + -- | library_unit_NAME + + -- The construct DIRECT_NAME'ATTRIBUTE_DESIGNATOR appears in the tree + -- as an attribute reference, which has essentially the same form. + + --------------------------------------- + -- 13.3 Attribute definition clause -- + --------------------------------------- + + -- ATTRIBUTE_DEFINITION_CLAUSE ::= + -- for LOCAL_NAME'ATTRIBUTE_DESIGNATOR use EXPRESSION; + -- | for LOCAL_NAME'ATTRIBUTE_DESIGNATOR use NAME; + + -- In Ada 83, the expression must be a simple expression and the + -- local name must be a direct name. + + -- Note: the only attribute definition clause that is processed by + -- gigi is an address clause. For all other cases, the information + -- is extracted by the front end and either results in setting entity + -- information, e.g. Esize for the Size clause, or in appropriate + -- expansion actions (e.g. in the case of Storage_Size). + + -- For an address clause, Gigi constructs the appropriate addressing + -- code. It also ensures that no aliasing optimizations are made + -- for the object for which the address clause appears. + + -- Note: for an address clause used to achieve an overlay: + + -- A : Integer; + -- B : Integer; + -- for B'Address use A'Address; + + -- the above rule means that Gigi will ensure that no optimizations + -- will be made for B that would violate the implementation advice + -- of RM 13.3(19). However, this advice applies only to B and not + -- to A, which seems unfortunate. The GNAT front end will mark the + -- object A as volatile to also prevent unwanted optimization + -- assumptions based on no aliasing being made for B. + + -- N_Attribute_Definition_Clause + -- Sloc points to FOR + -- Name (Node2) the local name + -- Chars (Name1) the identifier name from the attribute designator + -- Expression (Node3) the expression or name + -- Entity (Node4-Sem) + -- Next_Rep_Item (Node5-Sem) + -- From_At_Mod (Flag4-Sem) + -- Check_Address_Alignment (Flag11-Sem) + -- From_Aspect_Specification (Flag13-Sem) + -- Is_Delayed_Aspect (Flag14-Sem) + -- Address_Warning_Posted (Flag18-Sem) + + -- Note: if From_Aspect_Specification is set, then Sloc points to the + -- aspect name, and Entity is resolved already to reference the entity + -- to which the aspect applies. + + ----------------------------------- + -- 13.3.1 Aspect Specifications -- + ----------------------------------- + + -- We modify the RM grammar here, the RM grammar is: + + -- ASPECT_SPECIFICATION ::= + -- with ASPECT_MARK [=> ASPECT_DEFINITION] {. + -- ASPECT_MARK [=> ASPECT_DEFINITION] } + + -- ASPECT_MARK ::= aspect_IDENTIFIER['Class] + + -- ASPECT_DEFINITION ::= NAME | EXPRESSION + + -- That's inconvenient, since there is no non-terminal name for a single + -- entry in the list of aspects. So we use this grammar instead: + + -- ASPECT_SPECIFICATIONS ::= + -- with ASPECT_SPECIFICATION {, ASPECT_SPECIFICATION} + + -- ASPECT_SPECIFICATION => + -- ASPECT_MARK [=> ASPECT_DEFINITION] + + -- ASPECT_MARK ::= aspect_IDENTIFIER['Class] + + -- ASPECT_DEFINITION ::= NAME | EXPRESSION + + -- See separate package Aspects for details on the incorporation of + -- these nodes into the tree, and how aspect specifications for a given + -- declaration node are associated with that node. + + -- N_Aspect_Specification + -- Sloc points to aspect identifier + -- Identifier (Node1) aspect identifier + -- Aspect_Rep_Item (Node2-Sem) + -- Expression (Node3) Aspect_Definition (set to Empty if none) + -- Entity (Node4-Sem) entity to which the aspect applies + -- Class_Present (Flag6) Set if 'Class present + -- Next_Rep_Item (Node5-Sem) + -- Split_PPC (Flag17) Set if split pre/post attribute + + -- Note: Aspect_Specification is an Ada 2012 feature + + -- Note: When a Pre or Post aspect specification is processed, it is + -- broken into AND THEN sections. The left most section has Split_PPC + -- set to False, indicating that it is the original specification (e.g. + -- for posting errors). For the other sections, Split_PPC is set True. + + --------------------------------------------- + -- 13.4 Enumeration representation clause -- + --------------------------------------------- + + -- ENUMERATION_REPRESENTATION_CLAUSE ::= + -- for first_subtype_LOCAL_NAME use ENUMERATION_AGGREGATE; + + -- In Ada 83, the name must be a direct name + + -- N_Enumeration_Representation_Clause + -- Sloc points to FOR + -- Identifier (Node1) direct name + -- Array_Aggregate (Node3) + -- Next_Rep_Item (Node5-Sem) + + --------------------------------- + -- 13.4 Enumeration aggregate -- + --------------------------------- + + -- ENUMERATION_AGGREGATE ::= ARRAY_AGGREGATE + + ------------------------------------------ + -- 13.5.1 Record representation clause -- + ------------------------------------------ + + -- RECORD_REPRESENTATION_CLAUSE ::= + -- for first_subtype_LOCAL_NAME use + -- record [MOD_CLAUSE] + -- {COMPONENT_CLAUSE} + -- end record; + + -- Gigi restriction: Mod_Clause is always Empty (if present it is + -- replaced by a corresponding Alignment attribute definition clause). + + -- Note: Component_Clauses can include pragmas + + -- N_Record_Representation_Clause + -- Sloc points to FOR + -- Identifier (Node1) direct name + -- Mod_Clause (Node2) (set to Empty if no mod clause present) + -- Component_Clauses (List3) + -- Next_Rep_Item (Node5-Sem) + + ------------------------------ + -- 13.5.1 Component clause -- + ------------------------------ + + -- COMPONENT_CLAUSE ::= + -- component_LOCAL_NAME at POSITION + -- range FIRST_BIT .. LAST_BIT; + + -- N_Component_Clause + -- Sloc points to AT + -- Component_Name (Node1) points to Name or Attribute_Reference + -- Position (Node2) + -- First_Bit (Node3) + -- Last_Bit (Node4) + + ---------------------- + -- 13.5.1 Position -- + ---------------------- + + -- POSITION ::= static_EXPRESSION + + ----------------------- + -- 13.5.1 First_Bit -- + ----------------------- + + -- FIRST_BIT ::= static_SIMPLE_EXPRESSION + + ---------------------- + -- 13.5.1 Last_Bit -- + ---------------------- + + -- LAST_BIT ::= static_SIMPLE_EXPRESSION + + -------------------------- + -- 13.8 Code statement -- + -------------------------- + + -- CODE_STATEMENT ::= QUALIFIED_EXPRESSION; + + -- Note: in GNAT, the qualified expression has the form + + -- Asm_Insn'(Asm (...)); + + -- See package System.Machine_Code in file s-maccod.ads for details on + -- the allowed parameters to Asm. There are two ways this node can + -- arise, as a code statement, in which case the expression is the + -- qualified expression, or as a result of the expansion of an intrinsic + -- call to the Asm or Asm_Input procedure. + + -- N_Code_Statement + -- Sloc points to first token of the expression + -- Expression (Node3) + + -- Note: package Exp_Code contains an abstract functional interface + -- for use by Gigi in accessing the data from N_Code_Statement nodes. + + ------------------------ + -- 13.12 Restriction -- + ------------------------ + + -- RESTRICTION ::= + -- restriction_IDENTIFIER + -- | restriction_parameter_IDENTIFIER => EXPRESSION + + -- There is no explicit node for restrictions. Instead the restriction + -- appears in normal pragma syntax as a pragma argument association, + -- which has the same syntactic form. + + -------------------------- + -- B.2 Shift Operators -- + -------------------------- + + -- Calls to the intrinsic shift functions are converted to one of + -- the following shift nodes, which have the form of normal binary + -- operator names. Note that for a given shift operation, one node + -- covers all possible types, as for normal operators. + + -- Note: it is perfectly permissible for the expander to generate + -- shift operation nodes directly, in which case they will be analyzed + -- and parsed in the usual manner. + + -- Sprint syntax: shift-function-name!(expr, count) + + -- Note: the Left_Opnd field holds the first argument (the value to + -- be shifted). The Right_Opnd field holds the second argument (the + -- shift count). The Chars field is the name of the intrinsic function. + + -- N_Op_Rotate_Left + -- Sloc points to the function name + -- plus fields for binary operator + -- plus fields for expression + -- Shift_Count_OK (Flag4-Sem) + + -- N_Op_Rotate_Right + -- Sloc points to the function name + -- plus fields for binary operator + -- plus fields for expression + -- Shift_Count_OK (Flag4-Sem) + + -- N_Op_Shift_Left + -- Sloc points to the function name + -- plus fields for binary operator + -- plus fields for expression + -- Shift_Count_OK (Flag4-Sem) + + -- N_Op_Shift_Right_Arithmetic + -- Sloc points to the function name + -- plus fields for binary operator + -- plus fields for expression + -- Shift_Count_OK (Flag4-Sem) + + -- N_Op_Shift_Right + -- Sloc points to the function name + -- plus fields for binary operator + -- plus fields for expression + -- Shift_Count_OK (Flag4-Sem) + + -------------------------- + -- Obsolescent Features -- + -------------------------- + + -- The syntax descriptions and tree nodes for obsolescent features are + -- grouped together, corresponding to their location in appendix I in + -- the RM. However, parsing and semantic analysis for these constructs + -- is located in an appropriate chapter (see individual notes). + + --------------------------- + -- J.3 Delta Constraint -- + --------------------------- + + -- Note: the parse routine for this construct is located in section + -- 3.5.9 of Par-Ch3, and semantic analysis is in Sem_Ch3, which is + -- where delta constraint logically belongs. + + -- DELTA_CONSTRAINT ::= DELTA static_EXPRESSION [RANGE_CONSTRAINT] + + -- N_Delta_Constraint + -- Sloc points to DELTA + -- Delta_Expression (Node3) + -- Range_Constraint (Node4) (set to Empty if not present) + + -------------------- + -- J.7 At Clause -- + -------------------- + + -- AT_CLAUSE ::= for DIRECT_NAME use at EXPRESSION; + + -- Note: the parse routine for this construct is located in Par-Ch13, + -- and the semantic analysis is in Sem_Ch13, where at clause logically + -- belongs if it were not obsolescent. + + -- Note: in Ada 83 the expression must be a simple expression + + -- Gigi restriction: This node never appears, it is rewritten as an + -- address attribute definition clause. + + -- N_At_Clause + -- Sloc points to FOR + -- Identifier (Node1) + -- Expression (Node3) + + --------------------- + -- J.8 Mod clause -- + --------------------- + + -- MOD_CLAUSE ::= at mod static_EXPRESSION; + + -- Note: the parse routine for this construct is located in Par-Ch13, + -- and the semantic analysis is in Sem_Ch13, where mod clause logically + -- belongs if it were not obsolescent. + + -- Note: in Ada 83, the expression must be a simple expression + + -- Gigi restriction: this node never appears. It is replaced + -- by a corresponding Alignment attribute definition clause. + + -- Note: pragmas can appear before and after the MOD_CLAUSE since + -- its name has "clause" in it. This is rather strange, but is quite + -- definitely specified. The pragmas before are collected in the + -- Pragmas_Before field of the mod clause node itself, and pragmas + -- after are simply swallowed up in the list of component clauses. + + -- N_Mod_Clause + -- Sloc points to AT + -- Expression (Node3) + -- Pragmas_Before (List4) Pragmas before mod clause (No_List if none) + + -------------------- + -- Semantic Nodes -- + -------------------- + + -- These semantic nodes are used to hold additional semantic information. + -- They are inserted into the tree as a result of semantic processing. + -- Although there are no legitimate source syntax constructions that + -- correspond directly to these nodes, we need a source syntax for the + -- reconstructed tree printed by Sprint, and the node descriptions here + -- show this syntax. + + -- Note: Case_Expression and Conditional_Expression is in this section for + -- now, since they are extensions. We will move them to their appropriate + -- places when they are officially approved as extensions (and then we will + -- know what the exact grammar and place in the Reference Manual is!) + + --------------------- + -- Case Expression -- + --------------------- + + -- CASE_EXPRESSION ::= + -- case EXPRESSION is + -- CASE_EXPRESSION_ALTERNATIVE + -- {CASE_EXPRESSION_ALTERNATIVE} + + -- Note that the Alternatives cannot include pragmas (this contrasts + -- with the situation of case statements where pragmas are allowed). + + -- N_Case_Expression + -- Sloc points to CASE + -- Expression (Node3) + -- Alternatives (List4) + + --------------------------------- + -- Case Expression Alternative -- + --------------------------------- + + -- CASE_STATEMENT_ALTERNATIVE ::= + -- when DISCRETE_CHOICE_LIST => + -- EXPRESSION + + -- N_Case_Expression_Alternative + -- Sloc points to WHEN + -- Actions (List1) + -- Discrete_Choices (List4) + -- Expression (Node3) + + -- Note: The Actions field temporarily holds any actions associated with + -- evaluation of the Expression. During expansion of the case expression + -- these actions are wrapped into an N_Expressions_With_Actions node + -- replacing the original expression. + + ---------------------------- + -- Conditional Expression -- + ---------------------------- + + -- This node is used to represent an expression corresponding to the + -- C construct (condition ? then-expression : else_expression), where + -- Expressions is a three element list, whose first expression is the + -- condition, and whose second and third expressions are the then and + -- else expressions respectively. + + -- Note: the Then_Actions and Else_Actions fields are always set to + -- No_List in the tree passed to Gigi. These fields are used only + -- for temporary processing purposes in the expander. + + -- The Ada language does not permit conditional expressions, however + -- this is under discussion as a possible extension by the ARG, and we + -- have implemented a form of this capability in GNAT under control of + -- the -gnatX switch. The syntax is: + + -- CONDITIONAL_EXPRESSION ::= + -- if EXPRESSION then EXPRESSION + -- {elsif EXPRESSION then EXPRESSION} + -- [else EXPRESSION] + + -- And we add the additional constructs + + -- PRIMARY ::= ( CONDITIONAL_EXPRESSION ) + -- PRAGMA_ARGUMENT_ASSOCIATION ::= CONDITIONAL_EXPRESSION + + -- Note: if we have (IF x1 THEN x2 ELSIF x3 THEN x4 ELSE x5) then it + -- is represented as (IF x1 THEN x2 ELSE (IF x3 THEN x4 ELSE x5)) and + -- the Is_Elsif flag is set on the inner conditional expression. + + -- N_Conditional_Expression + -- Sloc points to IF or ELSIF keyword + -- Expressions (List1) + -- Then_Actions (List2-Sem) + -- Else_Actions (List3-Sem) + -- Is_Elsif (Flag13) (set if comes from ELSIF) + -- plus fields for expression + + ------------------- + -- Expanded_Name -- + ------------------- + + -- The N_Expanded_Name node is used to represent a selected component + -- name that has been resolved to an expanded name. The semantic phase + -- replaces N_Selected_Component nodes that represent names by the use + -- of this node, leaving the N_Selected_Component node used only when + -- the prefix is a record or protected type. + + -- The fields of the N_Expanded_Name node are layed out identically + -- to those of the N_Selected_Component node, allowing conversion of + -- an expanded name node to a selected component node to be done + -- easily, see Sinfo.CN.Change_Selected_Component_To_Expanded_Name. + + -- There is no special sprint syntax for an expanded name + + -- N_Expanded_Name + -- Sloc points to the period + -- Chars (Name1) copy of Chars field of selector name + -- Prefix (Node3) + -- Selector_Name (Node2) + -- Entity (Node4-Sem) + -- Associated_Node (Node4-Sem) + -- Redundant_Use (Flag13-Sem) + -- Has_Private_View (Flag11-Sem) set in generic units. + -- plus fields for expression + + ----------------------------- + -- Expression with Actions -- + ----------------------------- + + -- This node is created by the analyzer/expander to handle some + -- expansion cases, notably short circuit forms where there are + -- actions associated with the right hand operand. + + -- The N_Expression_With_Actions node represents an expression with + -- an associated set of actions (which are executable statements and + -- declarations, as might occur in a handled statement sequence). + + -- The required semantics is that the set of actions is executed in + -- the order in which it appears just before the expression is + -- evaluated (and these actions must only be executed if the value + -- of the expression is evaluated). The node is considered to be + -- a subexpression, whose value is the value of the Expression after + -- executing all the actions. + + -- Note: if the actions contain declarations, then these declarations + -- maybe referenced with in the expression. It is thus appropriate for + -- the back end to create a scope that encompasses the construct (any + -- declarations within the actions will definitely not be referenced + -- once elaboration of the construct is completed). + + -- Sprint syntax: do + -- action; + -- action; + -- ... + -- action; + -- in expression end + + -- N_Expression_With_Actions + -- Actions (List1) + -- Expression (Node3) + -- plus fields for expression + + -- Note: the actions list is always non-null, since we would + -- never have created this node if there weren't some actions. + + -------------------- + -- Free Statement -- + -------------------- + + -- The N_Free_Statement node is generated as a result of a call to an + -- instantiation of Unchecked_Deallocation. The instantiation of this + -- generic is handled specially and generates this node directly. + + -- Sprint syntax: free expression + + -- N_Free_Statement + -- Sloc is copied from the unchecked deallocation call + -- Expression (Node3) argument to unchecked deallocation call + -- Storage_Pool (Node1-Sem) + -- Procedure_To_Call (Node2-Sem) + -- Actual_Designated_Subtype (Node4-Sem) + + -- Note: in the case where a debug source file is generated, the Sloc + -- for this node points to the FREE keyword in the Sprint file output. + + ------------------- + -- Freeze Entity -- + ------------------- + + -- This node marks the point in a declarative part at which an entity + -- declared therein becomes frozen. The expander places initialization + -- procedures for types at those points. Gigi uses the freezing point + -- to elaborate entities that may depend on previous private types. + + -- See the section in Einfo "Delayed Freezing and Elaboration" for + -- a full description of the use of this node. + + -- The Entity field points back to the entity for the type (whose + -- Freeze_Node field points back to this freeze node). + + -- The Actions field contains a list of declarations and statements + -- generated by the expander which are associated with the freeze + -- node, and are elaborated as though the freeze node were replaced + -- by this sequence of actions. + + -- Note: the Sloc field in the freeze node references a construct + -- associated with the freezing point. This is used for posting + -- messages in some error/warning situations, e.g. the case where + -- a primitive operation of a tagged type is declared too late. + + -- Sprint syntax: freeze entity-name [ + -- freeze actions + -- ] + + -- N_Freeze_Entity + -- Sloc points near freeze point (see above special note) + -- Entity (Node4-Sem) + -- Access_Types_To_Process (Elist2-Sem) (set to No_Elist if none) + -- TSS_Elist (Elist3-Sem) (set to No_Elist if no associated TSS's) + -- Actions (List1) (set to No_List if no freeze actions) + -- First_Subtype_Link (Node5-Sem) (set to Empty if no link) + + -- The Actions field holds actions associated with the freeze. These + -- actions are elaborated at the point where the type is frozen. + + -- Note: in the case where a debug source file is generated, the Sloc + -- for this node points to the FREEZE keyword in the Sprint file output. + + -------------------------------- + -- Implicit Label Declaration -- + -------------------------------- + + -- An implicit label declaration is created for every occurrence of a + -- label on a statement or a label on a block or loop. It is chained + -- in the declarations of the innermost enclosing block as specified + -- in RM section 5.1 (3). + + -- The Defining_Identifier is the actual identifier for the statement + -- identifier. Note that the occurrence of the label is a reference, NOT + -- the defining occurrence. The defining occurrence occurs at the head + -- of the innermost enclosing block, and is represented by this node. + + -- Note: from the grammar, this might better be called an implicit + -- statement identifier declaration, but the term we choose seems + -- friendlier, since at least informally statement identifiers are + -- called labels in both cases (i.e. when used in labels, and when + -- used as the identifiers of blocks and loops). + + -- Note: although this is logically a semantic node, since it does not + -- correspond directly to a source syntax construction, these nodes are + -- actually created by the parser in a post pass done just after parsing + -- is complete, before semantic analysis is started (see Par.Labl). + + -- Sprint syntax: labelname : label; + + -- N_Implicit_Label_Declaration + -- Sloc points to the << of the label + -- Defining_Identifier (Node1) + -- Label_Construct (Node2-Sem) + + -- Note: in the case where a debug source file is generated, the Sloc + -- for this node points to the label name in the generated declaration. + + --------------------- + -- Itype_Reference -- + --------------------- + + -- This node is used to create a reference to an Itype. The only purpose + -- is to make sure the Itype is defined if this is the first reference. + + -- A typical use of this node is when an Itype is to be referenced in + -- two branches of an IF statement. In this case it is important that + -- the first use of the Itype not be inside the conditional, since then + -- it might not be defined if the other branch of the IF is taken, in + -- the case where the definition generates elaboration code. + + -- The Itype field points to the referenced Itype + + -- Sprint syntax: reference itype-name + + -- N_Itype_Reference + -- Sloc points to the node generating the reference + -- Itype (Node1-Sem) + + -- Note: in the case where a debug source file is generated, the Sloc + -- for this node points to the REFERENCE keyword in the file output. + + --------------------- + -- Raise_xxx_Error -- + --------------------- + + -- One of these nodes is created during semantic analysis to replace + -- a node for an expression that is determined to definitely raise + -- the corresponding exception. + + -- The N_Raise_xxx_Error node may also stand alone in place + -- of a declaration or statement, in which case it simply causes + -- the exception to be raised (i.e. it is equivalent to a raise + -- statement that raises the corresponding exception). This use + -- is distinguished by the fact that the Etype in this case is + -- Standard_Void_Type, In the subexpression case, the Etype is the + -- same as the type of the subexpression which it replaces. + + -- If Condition is empty, then the raise is unconditional. If the + -- Condition field is non-empty, it is a boolean expression which + -- is first evaluated, and the exception is raised only if the + -- value of the expression is True. In the unconditional case, the + -- creation of this node is usually accompanied by a warning message + -- error. The creation of this node will usually be accompanied by a + -- message (unless it appears within the right operand of a short + -- circuit form whose left argument is static and decisively + -- eliminates elaboration of the raise operation. The condition field + -- can ONLY be present when the node is used as a statement form, it + -- may NOT be present in the case where the node appears within an + -- expression. + + -- The exception is generated with a message that contains the + -- file name and line number, and then appended text. The Reason + -- code shows the text to be added. The Reason code is an element + -- of the type Types.RT_Exception_Code, and indicates both the + -- message to be added, and the exception to be raised (which must + -- match the node type). The value is stored by storing a Uint which + -- is the Pos value of the enumeration element in this type. + + -- Gigi restriction: This expander ensures that the type of the + -- Condition field is always Standard.Boolean, even if the type + -- in the source is some non-standard boolean type. + + -- Sprint syntax: [xxx_error "msg"] + -- or: [xxx_error when condition "msg"] + + -- N_Raise_Constraint_Error + -- Sloc references related construct + -- Condition (Node1) (set to Empty if no condition) + -- Reason (Uint3) + -- plus fields for expression + + -- N_Raise_Program_Error + -- Sloc references related construct + -- Condition (Node1) (set to Empty if no condition) + -- Reason (Uint3) + -- plus fields for expression + + -- N_Raise_Storage_Error + -- Sloc references related construct + -- Condition (Node1) (set to Empty if no condition) + -- Reason (Uint3) + -- plus fields for expression + + -- Note: Sloc is copied from the expression generating the exception. + -- In the case where a debug source file is generated, the Sloc for + -- this node points to the left bracket in the Sprint file output. + + -- Note: the back end may be required to translate these nodes into + -- appropriate goto statements. See description of N_Push/Pop_xxx_Label. + + --------------------------------------------- + -- Optimization of Exception Raise to Goto -- + --------------------------------------------- + + -- In some cases, the front end will determine that any exception raised + -- by the back end for a certain exception should be transformed into a + -- goto statement. + + -- There are three kinds of exceptions raised by the back end (note that + -- for this purpose we consider gigi to be part of the back end in the + -- gcc case): + + -- 1. Exceptions resulting from N_Raise_xxx_Error nodes + -- 2. Exceptions from checks triggered by Do_xxx_Check flags + -- 3. Other cases not specifically marked by the front end + + -- Normally all such exceptions are translated into calls to the proper + -- Rcheck_xx procedure, where xx encodes both the exception to be raised + -- and the exception message. + + -- The front end may determine that for a particular sequence of code, + -- exceptions in any of these three categories for a particular builtin + -- exception should result in a goto, rather than a call to Rcheck_xx. + -- The exact sequence to be generated is: + + -- Local_Raise (exception'Identity); + -- goto Label + + -- The front end marks such a sequence of code by bracketing it with + -- push and pop nodes: + + -- N_Push_xxx_Label (referencing the label) + -- ... + -- (code where transformation is expected for exception xxx) + -- ... + -- N_Pop_xxx_Label + + -- The use of push/pop reflects the fact that such regions can properly + -- nest, and one special case is a subregion in which no transformation + -- is allowed. Such a region is marked by a N_Push_xxx_Label node whose + -- Exception_Label field is Empty. + + -- N_Push_Constraint_Error_Label + -- Sloc references first statement in region covered + -- Exception_Label (Node5-Sem) + + -- N_Push_Program_Error_Label + -- Sloc references first statement in region covered + -- Exception_Label (Node5-Sem) + + -- N_Push_Storage_Error_Label + -- Sloc references first statement in region covered + -- Exception_Label (Node5-Sem) + + -- N_Pop_Constraint_Error_Label + -- Sloc references last statement in region covered + + -- N_Pop_Program_Error_Label + -- Sloc references last statement in region covered + + -- N_Pop_Storage_Error_Label + -- Sloc references last statement in region covered + + --------------- + -- Reference -- + --------------- + + -- For a number of purposes, we need to construct references to objects. + -- These references are subsequently treated as normal access values. + -- An example is the construction of the parameter block passed to a + -- task entry. The N_Reference node is provided for this purpose. It is + -- similar in effect to the use of the Unrestricted_Access attribute, + -- and like Unrestricted_Access can be applied to objects which would + -- not be valid prefixes for the Unchecked_Access attribute (e.g. + -- objects which are not aliased, and slices). In addition it can be + -- applied to composite type values as well as objects, including string + -- values and aggregates. + + -- Note: we use the Prefix field for this expression so that the + -- resulting node can be treated using common code with the attribute + -- nodes for the 'Access and related attributes. Logically it would make + -- more sense to call it an Expression field, but then we would have to + -- special case the treatment of the N_Reference node. + + -- Sprint syntax: prefix'reference + + -- N_Reference + -- Sloc is copied from the expression + -- Prefix (Node3) + -- plus fields for expression + + -- Note: in the case where a debug source file is generated, the Sloc + -- for this node points to the quote in the Sprint file output. + + ----------------- + -- SCIL Nodes -- + ----------------- + + -- SCIL nodes are special nodes added to the tree when the CodePeer + -- mode is active. They help the CodePeer backend to locate nodes that + -- require special processing. + + -- Major documentation on the general design of the SCIL interface, and + -- in particular detailed description of these nodes is missing and is + -- to be supplied in the future, when the design has finalized ??? + + -- Meanwhile these nodes should be considered in experimental form, and + -- should be ignored by all code generating back ends. ??? + + -- N_SCIL_Dispatch_Table_Tag_Init + -- Sloc references a node for a tag initialization + -- SCIL_Entity (Node4-Sem) + + -- N_SCIL_Dispatching_Call + -- Sloc references the node of a dispatching call + -- SCIL_Target_Prim (Node2-Sem) + -- SCIL_Entity (Node4-Sem) + -- SCIL_Controlling_Tag (Node5-Sem) + + -- N_SCIL_Membership_Test + -- Sloc references the node of a membership test + -- SCIL_Tag_Value (Node5-Sem) + -- SCIL_Entity (Node4-Sem) + + --------------------- + -- Subprogram_Info -- + --------------------- + + -- This node generates the appropriate Subprogram_Info value for a + -- given procedure. See Ada.Exceptions for further details + + -- Sprint syntax: subprog'subprogram_info + + -- N_Subprogram_Info + -- Sloc points to the entity for the procedure + -- Identifier (Node1) identifier referencing the procedure + -- Etype (Node5-Sem) type (always set to Ada.Exceptions.Code_Loc + + -- Note: in the case where a debug source file is generated, the Sloc + -- for this node points to the quote in the Sprint file output. + + -------------------------- + -- Unchecked Expression -- + -------------------------- + + -- An unchecked expression is one that must be analyzed and resolved + -- with all checks off, regardless of the current setting of scope + -- suppress flags. + + -- Sprint syntax: `(expression) + + -- Note: this node is always removed from the tree (and replaced by + -- its constituent expression) on completion of analysis, so it only + -- appears in intermediate trees, and will never be seen by Gigi. + + -- N_Unchecked_Expression + -- Sloc is a copy of the Sloc of the expression + -- Expression (Node3) + -- plus fields for expression + + -- Note: in the case where a debug source file is generated, the Sloc + -- for this node points to the back quote in the Sprint file output. + + ------------------------------- + -- Unchecked Type Conversion -- + ------------------------------- + + -- An unchecked type conversion node represents the semantic action + -- corresponding to a call to an instantiation of Unchecked_Conversion. + -- It is generated as a result of actual use of Unchecked_Conversion + -- and also the expander generates unchecked type conversion nodes + -- directly for expansion of complex semantic actions. + + -- Note: an unchecked type conversion is a variable as far as the + -- semantics are concerned, which is convenient for the expander. + -- This does not change what Ada source programs are legal, since + -- clearly a function call to an instantiation of Unchecked_Conversion + -- is not a variable in any case. + + -- Sprint syntax: subtype-mark!(expression) + + -- N_Unchecked_Type_Conversion + -- Sloc points to related node in source + -- Subtype_Mark (Node4) + -- Expression (Node3) + -- Kill_Range_Check (Flag11-Sem) + -- No_Truncation (Flag17-Sem) + -- plus fields for expression + + -- Note: in the case where a debug source file is generated, the Sloc + -- for this node points to the exclamation in the Sprint file output. + + ----------------------------------- + -- Validate_Unchecked_Conversion -- + ----------------------------------- + + -- The front end does most of the validation of unchecked conversion, + -- including checking sizes (this is done after the back end is called + -- to take advantage of back-annotation of calculated sizes). + + -- The front end also deals with specific cases that are not allowed + -- e.g. involving unconstrained array types. + + -- For the case of the standard gigi backend, this means that all + -- checks are done in the front-end. + + -- However, in the case of specialized back-ends, notably the JVM + -- backend for JGNAT, additional requirements and restrictions apply + -- to unchecked conversion, and these are most conveniently performed + -- in the specialized back-end. + + -- To accommodate this requirement, for such back ends, the following + -- special node is generated recording an unchecked conversion that + -- needs to be validated. The back end should post an appropriate + -- error message if the unchecked conversion is invalid or warrants + -- a special warning message. + + -- Source_Type and Target_Type point to the entities for the two + -- types involved in the unchecked conversion instantiation that + -- is to be validated. + + -- Sprint syntax: validate Unchecked_Conversion (source, target); + + -- N_Validate_Unchecked_Conversion + -- Sloc points to instantiation (location for warning message) + -- Source_Type (Node1-Sem) + -- Target_Type (Node2-Sem) + + -- Note: in the case where a debug source file is generated, the Sloc + -- for this node points to the VALIDATE keyword in the file output. + + ----------- + -- Empty -- + ----------- + + -- Used as the contents of the Nkind field of the dummy Empty node + -- and in some other situations to indicate an uninitialized value. + + -- N_Empty + -- Chars (Name1) is set to No_Name + + ----------- + -- Error -- + ----------- + + -- Used as the contents of the Nkind field of the dummy Error node. + -- Has an Etype field, which gets set to Any_Type later on, to help + -- error recovery (Error_Posted is also set in the Error node). + + -- N_Error + -- Chars (Name1) is set to Error_Name + -- Etype (Node5-Sem) + + -------------------------- + -- Node Type Definition -- + -------------------------- + + -- The following is the definition of the Node_Kind type. As previously + -- discussed, this is separated off to allow rearrangement of the order to + -- facilitate definition of subtype ranges. The comments show the subtype + -- classes which apply to each set of node kinds. The first entry in the + -- comment characterizes the following list of nodes. + + type Node_Kind is ( + N_Unused_At_Start, + + -- N_Representation_Clause + + N_At_Clause, + N_Component_Clause, + N_Enumeration_Representation_Clause, + N_Mod_Clause, + N_Record_Representation_Clause, + + -- N_Representation_Clause, N_Has_Chars + + N_Attribute_Definition_Clause, + + -- N_Has_Chars + + N_Empty, + N_Pragma_Argument_Association, + + -- N_Has_Etype + + N_Error, + + -- N_Entity, N_Has_Etype, N_Has_Chars + + N_Defining_Character_Literal, + N_Defining_Identifier, + N_Defining_Operator_Symbol, + + -- N_Subexpr, N_Has_Etype, N_Has_Chars, N_Has_Entity + + N_Expanded_Name, + + -- N_Direct_Name, N_Subexpr, N_Has_Etype, + -- N_Has_Chars, N_Has_Entity + + N_Identifier, + N_Operator_Symbol, + + -- N_Direct_Name, N_Subexpr, N_Has_Etype, + -- N_Has_Chars, N_Has_Entity + + N_Character_Literal, + + -- N_Binary_Op, N_Op, N_Subexpr, + -- N_Has_Etype, N_Has_Chars, N_Has_Entity + + N_Op_Add, + N_Op_Concat, + N_Op_Expon, + N_Op_Subtract, + + -- N_Binary_Op, N_Op, N_Subexpr, N_Has_Treat_Fixed_As_Integer + -- N_Has_Etype, N_Has_Chars, N_Has_Entity, N_Multiplying_Operator + + N_Op_Divide, + N_Op_Mod, + N_Op_Multiply, + N_Op_Rem, + + -- N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype + -- N_Has_Entity, N_Has_Chars, N_Op_Boolean + + N_Op_And, + + -- N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype + -- N_Has_Entity, N_Has_Chars, N_Op_Boolean, N_Op_Compare + + N_Op_Eq, + N_Op_Ge, + N_Op_Gt, + N_Op_Le, + N_Op_Lt, + N_Op_Ne, + + -- N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype + -- N_Has_Entity, N_Has_Chars, N_Op_Boolean + + N_Op_Or, + N_Op_Xor, + + -- N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype, + -- N_Op_Shift, N_Has_Chars, N_Has_Entity + + N_Op_Rotate_Left, + N_Op_Rotate_Right, + N_Op_Shift_Left, + N_Op_Shift_Right, + N_Op_Shift_Right_Arithmetic, + + -- N_Unary_Op, N_Op, N_Subexpr, N_Has_Etype, + -- N_Has_Chars, N_Has_Entity + + N_Op_Abs, + N_Op_Minus, + N_Op_Not, + N_Op_Plus, + + -- N_Subexpr, N_Has_Etype, N_Has_Entity + + N_Attribute_Reference, + + -- N_Subexpr, N_Has_Etype, N_Membership_Test + + N_In, + N_Not_In, + + -- N_Subexpr, N_Has_Etype, N_Short_Circuit + + N_And_Then, + N_Or_Else, + + -- N_Subexpr, N_Has_Etype + + N_Conditional_Expression, + N_Explicit_Dereference, + N_Expression_With_Actions, + N_Function_Call, + N_Indexed_Component, + N_Integer_Literal, + N_Null, + N_Procedure_Call_Statement, + N_Qualified_Expression, + N_Quantified_Expression, + + -- N_Raise_xxx_Error, N_Subexpr, N_Has_Etype + + N_Raise_Constraint_Error, + N_Raise_Program_Error, + N_Raise_Storage_Error, + + -- N_Subexpr, N_Has_Etype + + N_Aggregate, + N_Allocator, + N_Case_Expression, + N_Extension_Aggregate, + N_Range, + N_Real_Literal, + N_Reference, + N_Selected_Component, + N_Slice, + N_String_Literal, + N_Subprogram_Info, + N_Type_Conversion, + N_Unchecked_Expression, + N_Unchecked_Type_Conversion, + + -- N_Has_Etype + + N_Subtype_Indication, + + -- N_Declaration + + N_Component_Declaration, + N_Entry_Declaration, + N_Formal_Object_Declaration, + N_Formal_Type_Declaration, + N_Full_Type_Declaration, + N_Incomplete_Type_Declaration, + N_Iterator_Specification, + N_Loop_Parameter_Specification, + N_Object_Declaration, + N_Parameterized_Expression, + N_Protected_Type_Declaration, + N_Private_Extension_Declaration, + N_Private_Type_Declaration, + N_Subtype_Declaration, + + -- N_Subprogram_Specification, N_Declaration + + N_Function_Specification, + N_Procedure_Specification, + + -- N_Access_To_Subprogram_Definition + + N_Access_Function_Definition, + N_Access_Procedure_Definition, + + -- N_Later_Decl_Item + + N_Task_Type_Declaration, + + -- N_Body_Stub, N_Later_Decl_Item + + N_Package_Body_Stub, + N_Protected_Body_Stub, + N_Subprogram_Body_Stub, + N_Task_Body_Stub, + + -- N_Generic_Instantiation, N_Later_Decl_Item + -- N_Subprogram_Instantiation + + N_Function_Instantiation, + N_Procedure_Instantiation, + + -- N_Generic_Instantiation, N_Later_Decl_Item + + N_Package_Instantiation, + + -- N_Unit_Body, N_Later_Decl_Item, N_Proper_Body + + N_Package_Body, + N_Subprogram_Body, + + -- N_Later_Decl_Item, N_Proper_Body + + N_Protected_Body, + N_Task_Body, + + -- N_Later_Decl_Item + + N_Implicit_Label_Declaration, + N_Package_Declaration, + N_Single_Task_Declaration, + N_Subprogram_Declaration, + N_Use_Package_Clause, + + -- N_Generic_Declaration, N_Later_Decl_Item + + N_Generic_Package_Declaration, + N_Generic_Subprogram_Declaration, + + -- N_Array_Type_Definition + + N_Constrained_Array_Definition, + N_Unconstrained_Array_Definition, + + -- N_Renaming_Declaration + + N_Exception_Renaming_Declaration, + N_Object_Renaming_Declaration, + N_Package_Renaming_Declaration, + N_Subprogram_Renaming_Declaration, + + -- N_Generic_Renaming_Declaration, N_Renaming_Declaration + + N_Generic_Function_Renaming_Declaration, + N_Generic_Package_Renaming_Declaration, + N_Generic_Procedure_Renaming_Declaration, + + -- N_Statement_Other_Than_Procedure_Call + + N_Abort_Statement, + N_Accept_Statement, + N_Assignment_Statement, + N_Asynchronous_Select, + N_Block_Statement, + N_Case_Statement, + N_Code_Statement, + N_Conditional_Entry_Call, + + -- N_Statement_Other_Than_Procedure_Call. N_Delay_Statement + + N_Delay_Relative_Statement, + N_Delay_Until_Statement, + + -- N_Statement_Other_Than_Procedure_Call + + N_Entry_Call_Statement, + N_Free_Statement, + N_Goto_Statement, + N_Loop_Statement, + N_Null_Statement, + N_Raise_Statement, + N_Requeue_Statement, + N_Return_Statement, -- renamed as N_Simple_Return_Statement below + N_Extended_Return_Statement, + N_Selective_Accept, + N_Timed_Entry_Call, + + -- N_Statement_Other_Than_Procedure_Call, N_Has_Condition + + N_Exit_Statement, + N_If_Statement, + + -- N_Has_Condition + + N_Accept_Alternative, + N_Delay_Alternative, + N_Elsif_Part, + N_Entry_Body_Formal_Part, + N_Iteration_Scheme, + N_Terminate_Alternative, + + -- N_Formal_Subprogram_Declaration + + N_Formal_Abstract_Subprogram_Declaration, + N_Formal_Concrete_Subprogram_Declaration, + + -- N_Push_xxx_Label, N_Push_Pop_xxx_Label + + N_Push_Constraint_Error_Label, + N_Push_Program_Error_Label, + N_Push_Storage_Error_Label, + + -- N_Pop_xxx_Label, N_Push_Pop_xxx_Label + + N_Pop_Constraint_Error_Label, + N_Pop_Program_Error_Label, + N_Pop_Storage_Error_Label, + + -- SCIL nodes + + N_SCIL_Dispatch_Table_Tag_Init, + N_SCIL_Dispatching_Call, + N_SCIL_Membership_Test, + + -- Other nodes (not part of any subtype class) + + N_Abortable_Part, + N_Abstract_Subprogram_Declaration, + N_Access_Definition, + N_Access_To_Object_Definition, + N_Aspect_Specification, + N_Case_Expression_Alternative, + N_Case_Statement_Alternative, + N_Compilation_Unit, + N_Compilation_Unit_Aux, + N_Component_Association, + N_Component_Definition, + N_Component_List, + N_Derived_Type_Definition, + N_Decimal_Fixed_Point_Definition, + N_Defining_Program_Unit_Name, + N_Delta_Constraint, + N_Designator, + N_Digits_Constraint, + N_Discriminant_Association, + N_Discriminant_Specification, + N_Enumeration_Type_Definition, + N_Entry_Body, + N_Entry_Call_Alternative, + N_Entry_Index_Specification, + N_Exception_Declaration, + N_Exception_Handler, + N_Floating_Point_Definition, + N_Formal_Decimal_Fixed_Point_Definition, + N_Formal_Derived_Type_Definition, + N_Formal_Discrete_Type_Definition, + N_Formal_Floating_Point_Definition, + N_Formal_Modular_Type_Definition, + N_Formal_Ordinary_Fixed_Point_Definition, + N_Formal_Package_Declaration, + N_Formal_Private_Type_Definition, + N_Formal_Signed_Integer_Type_Definition, + N_Freeze_Entity, + N_Generic_Association, + N_Handled_Sequence_Of_Statements, + N_Index_Or_Discriminant_Constraint, + N_Itype_Reference, + N_Label, + N_Modular_Type_Definition, + N_Number_Declaration, + N_Ordinary_Fixed_Point_Definition, + N_Others_Choice, + N_Package_Specification, + N_Parameter_Association, + N_Parameter_Specification, + N_Pragma, + N_Protected_Definition, + N_Range_Constraint, + N_Real_Range_Specification, + N_Record_Definition, + N_Signed_Integer_Type_Definition, + N_Single_Protected_Declaration, + N_Subunit, + N_Task_Definition, + N_Triggering_Alternative, + N_Use_Type_Clause, + N_Validate_Unchecked_Conversion, + N_Variant, + N_Variant_Part, + N_With_Clause, + N_Unused_At_End); + + for Node_Kind'Size use 8; + -- The data structures in Atree assume this! + + ---------------------------- + -- Node Class Definitions -- + ---------------------------- + + subtype N_Access_To_Subprogram_Definition is Node_Kind range + N_Access_Function_Definition .. + N_Access_Procedure_Definition; + + subtype N_Array_Type_Definition is Node_Kind range + N_Constrained_Array_Definition .. + N_Unconstrained_Array_Definition; + + subtype N_Binary_Op is Node_Kind range + N_Op_Add .. + N_Op_Shift_Right_Arithmetic; + + subtype N_Body_Stub is Node_Kind range + N_Package_Body_Stub .. + N_Task_Body_Stub; + + subtype N_Declaration is Node_Kind range + N_Component_Declaration .. + N_Procedure_Specification; + -- Note: this includes all constructs normally thought of as declarations + -- except those which are separately grouped as later declarations. + + subtype N_Delay_Statement is Node_Kind range + N_Delay_Relative_Statement .. + N_Delay_Until_Statement; + + subtype N_Direct_Name is Node_Kind range + N_Identifier .. + N_Character_Literal; + + subtype N_Entity is Node_Kind range + N_Defining_Character_Literal .. + N_Defining_Operator_Symbol; + + subtype N_Formal_Subprogram_Declaration is Node_Kind range + N_Formal_Abstract_Subprogram_Declaration .. + N_Formal_Concrete_Subprogram_Declaration; + + subtype N_Generic_Declaration is Node_Kind range + N_Generic_Package_Declaration .. + N_Generic_Subprogram_Declaration; + + subtype N_Generic_Instantiation is Node_Kind range + N_Function_Instantiation .. + N_Package_Instantiation; + + subtype N_Generic_Renaming_Declaration is Node_Kind range + N_Generic_Function_Renaming_Declaration .. + N_Generic_Procedure_Renaming_Declaration; + + subtype N_Has_Chars is Node_Kind range + N_Attribute_Definition_Clause .. + N_Op_Plus; + + subtype N_Has_Entity is Node_Kind range + N_Expanded_Name .. + N_Attribute_Reference; + -- Nodes that have Entity fields + -- Warning: DOES NOT INCLUDE N_Freeze_Entity, N_Aspect_Specification, + -- or N_Attribute_Definition_Clause. + + subtype N_Has_Etype is Node_Kind range + N_Error .. + N_Subtype_Indication; + + subtype N_Has_Treat_Fixed_As_Integer is Node_Kind range + N_Op_Divide .. + N_Op_Rem; + + subtype N_Multiplying_Operator is Node_Kind range + N_Op_Divide .. + N_Op_Rem; + + subtype N_Later_Decl_Item is Node_Kind range + N_Task_Type_Declaration .. + N_Generic_Subprogram_Declaration; + -- Note: this is Ada 83 relevant only (see Ada 83 RM 3.9 (2)) and includes + -- only those items which can appear as later declarative items. This also + -- includes N_Implicit_Label_Declaration which is not specifically in the + -- grammar but may appear as a valid later declarative items. It does NOT + -- include N_Pragma which can also appear among later declarative items. + -- It does however include N_Protected_Body, which is a bit peculiar, but + -- harmless since this cannot appear in Ada 83 mode anyway. + + subtype N_Membership_Test is Node_Kind range + N_In .. + N_Not_In; + + subtype N_Op is Node_Kind range + N_Op_Add .. + N_Op_Plus; + + subtype N_Op_Boolean is Node_Kind range + N_Op_And .. + N_Op_Xor; + -- Binary operators which take operands of a boolean type, and yield + -- a result of a boolean type. + + subtype N_Op_Compare is Node_Kind range + N_Op_Eq .. + N_Op_Ne; + + subtype N_Op_Shift is Node_Kind range + N_Op_Rotate_Left .. + N_Op_Shift_Right_Arithmetic; + + subtype N_Proper_Body is Node_Kind range + N_Package_Body .. + N_Task_Body; + + subtype N_Push_xxx_Label is Node_Kind range + N_Push_Constraint_Error_Label .. + N_Push_Storage_Error_Label; + + subtype N_Pop_xxx_Label is Node_Kind range + N_Pop_Constraint_Error_Label .. + N_Pop_Storage_Error_Label; + + subtype N_Push_Pop_xxx_Label is Node_Kind range + N_Push_Constraint_Error_Label .. + N_Pop_Storage_Error_Label; + + subtype N_Raise_xxx_Error is Node_Kind range + N_Raise_Constraint_Error .. + N_Raise_Storage_Error; + + subtype N_Renaming_Declaration is Node_Kind range + N_Exception_Renaming_Declaration .. + N_Generic_Procedure_Renaming_Declaration; + + subtype N_Representation_Clause is Node_Kind range + N_At_Clause .. + N_Attribute_Definition_Clause; + + subtype N_Short_Circuit is Node_Kind range + N_And_Then .. + N_Or_Else; + + subtype N_SCIL_Node is Node_Kind range + N_SCIL_Dispatch_Table_Tag_Init .. + N_SCIL_Membership_Test; + + subtype N_Statement_Other_Than_Procedure_Call is Node_Kind range + N_Abort_Statement .. + N_If_Statement; + -- Note that this includes all statement types except for the cases of the + -- N_Procedure_Call_Statement which is considered to be a subexpression + -- (since overloading is possible, so it needs to go through the normal + -- overloading resolution for expressions). + + subtype N_Subprogram_Instantiation is Node_Kind range + N_Function_Instantiation .. + N_Procedure_Instantiation; + + subtype N_Has_Condition is Node_Kind range + N_Exit_Statement .. + N_Terminate_Alternative; + -- Nodes with condition fields (does not include N_Raise_xxx_Error) + + subtype N_Subexpr is Node_Kind range + N_Expanded_Name .. + N_Unchecked_Type_Conversion; + -- Nodes with expression fields + + subtype N_Subprogram_Specification is Node_Kind range + N_Function_Specification .. + N_Procedure_Specification; + + subtype N_Unary_Op is Node_Kind range + N_Op_Abs .. + N_Op_Plus; + + subtype N_Unit_Body is Node_Kind range + N_Package_Body .. + N_Subprogram_Body; + + --------------------------- + -- Node Access Functions -- + --------------------------- + + -- The following functions return the contents of the indicated field of + -- the node referenced by the argument, which is a Node_Id. They provide + -- logical access to fields in the node which could be accessed using the + -- Atree.Unchecked_Access package, but the idea is always to use these + -- higher level routines which preserve strong typing. In debug mode, + -- these routines check that they are being applied to an appropriate + -- node, as well as checking that the node is in range. + + function ABE_Is_Certain + (N : Node_Id) return Boolean; -- Flag18 + + function Abort_Present + (N : Node_Id) return Boolean; -- Flag15 + + function Abortable_Part + (N : Node_Id) return Node_Id; -- Node2 + + function Abstract_Present + (N : Node_Id) return Boolean; -- Flag4 + + function Accept_Handler_Records + (N : Node_Id) return List_Id; -- List5 + + function Accept_Statement + (N : Node_Id) return Node_Id; -- Node2 + + function Access_Definition + (N : Node_Id) return Node_Id; -- Node3 + + function Access_To_Subprogram_Definition + (N : Node_Id) return Node_Id; -- Node3 + + function Access_Types_To_Process + (N : Node_Id) return Elist_Id; -- Elist2 + + function Actions + (N : Node_Id) return List_Id; -- List1 + + function Activation_Chain_Entity + (N : Node_Id) return Node_Id; -- Node3 + + function Acts_As_Spec + (N : Node_Id) return Boolean; -- Flag4 + + function Actual_Designated_Subtype + (N : Node_Id) return Node_Id; -- Node4 + + function Address_Warning_Posted + (N : Node_Id) return Boolean; -- Flag18 + + function Aggregate_Bounds + (N : Node_Id) return Node_Id; -- Node3 + + function Aliased_Present + (N : Node_Id) return Boolean; -- Flag4 + + function All_Others + (N : Node_Id) return Boolean; -- Flag11 + + function All_Present + (N : Node_Id) return Boolean; -- Flag15 + + function Alternatives + (N : Node_Id) return List_Id; -- List4 + + function Ancestor_Part + (N : Node_Id) return Node_Id; -- Node3 + + function Array_Aggregate + (N : Node_Id) return Node_Id; -- Node3 + + function Aspect_Cancel + (N : Node_Id) return Boolean; -- Flag11 + + function Aspect_Rep_Item + (N : Node_Id) return Node_Id; -- Node2 + + function Assignment_OK + (N : Node_Id) return Boolean; -- Flag15 + + function Associated_Node + (N : Node_Id) return Node_Id; -- Node4 + + function At_End_Proc + (N : Node_Id) return Node_Id; -- Node1 + + function Attribute_Name + (N : Node_Id) return Name_Id; -- Name2 + + function Aux_Decls_Node + (N : Node_Id) return Node_Id; -- Node5 + + function Backwards_OK + (N : Node_Id) return Boolean; -- Flag6 + + function Bad_Is_Detected + (N : Node_Id) return Boolean; -- Flag15 + + function By_Ref + (N : Node_Id) return Boolean; -- Flag5 + + function Body_Required + (N : Node_Id) return Boolean; -- Flag13 + + function Body_To_Inline + (N : Node_Id) return Node_Id; -- Node3 + + function Box_Present + (N : Node_Id) return Boolean; -- Flag15 + + function Char_Literal_Value + (N : Node_Id) return Uint; -- Uint2 + + function Chars + (N : Node_Id) return Name_Id; -- Name1 + + function Check_Address_Alignment + (N : Node_Id) return Boolean; -- Flag11 + + function Choice_Parameter + (N : Node_Id) return Node_Id; -- Node2 + + function Choices + (N : Node_Id) return List_Id; -- List1 + + function Class_Present + (N : Node_Id) return Boolean; -- Flag6 + + function Coextensions + (N : Node_Id) return Elist_Id; -- Elist4 + + function Comes_From_Extended_Return_Statement + (N : Node_Id) return Boolean; -- Flag18 + + function Compile_Time_Known_Aggregate + (N : Node_Id) return Boolean; -- Flag18 + + function Component_Associations + (N : Node_Id) return List_Id; -- List2 + + function Component_Clauses + (N : Node_Id) return List_Id; -- List3 + + function Component_Definition + (N : Node_Id) return Node_Id; -- Node4 + + function Component_Items + (N : Node_Id) return List_Id; -- List3 + + function Component_List + (N : Node_Id) return Node_Id; -- Node1 + + function Component_Name + (N : Node_Id) return Node_Id; -- Node1 + + function Componentwise_Assignment + (N : Node_Id) return Boolean; -- Flag14 + + function Condition + (N : Node_Id) return Node_Id; -- Node1 + + function Condition_Actions + (N : Node_Id) return List_Id; -- List3 + + function Config_Pragmas + (N : Node_Id) return List_Id; -- List4 + + function Constant_Present + (N : Node_Id) return Boolean; -- Flag17 + + function Constraint + (N : Node_Id) return Node_Id; -- Node3 + + function Constraints + (N : Node_Id) return List_Id; -- List1 + + function Context_Installed + (N : Node_Id) return Boolean; -- Flag13 + + function Context_Pending + (N : Node_Id) return Boolean; -- Flag16 + + function Context_Items + (N : Node_Id) return List_Id; -- List1 + + function Controlling_Argument + (N : Node_Id) return Node_Id; -- Node1 + + function Conversion_OK + (N : Node_Id) return Boolean; -- Flag14 + + function Corresponding_Body + (N : Node_Id) return Node_Id; -- Node5 + + function Corresponding_Formal_Spec + (N : Node_Id) return Node_Id; -- Node3 + + function Corresponding_Generic_Association + (N : Node_Id) return Node_Id; -- Node5 + + function Corresponding_Integer_Value + (N : Node_Id) return Uint; -- Uint4 + + function Corresponding_Spec + (N : Node_Id) return Node_Id; -- Node5 + + function Corresponding_Stub + (N : Node_Id) return Node_Id; -- Node3 + + function Dcheck_Function + (N : Node_Id) return Entity_Id; -- Node5 + + function Debug_Statement + (N : Node_Id) return Node_Id; -- Node3 + + function Declarations + (N : Node_Id) return List_Id; -- List2 + + function Default_Expression + (N : Node_Id) return Node_Id; -- Node5 + + function Default_Storage_Pool + (N : Node_Id) return Node_Id; -- Node3 + + function Default_Name + (N : Node_Id) return Node_Id; -- Node2 + + function Defining_Identifier + (N : Node_Id) return Entity_Id; -- Node1 + + function Defining_Unit_Name + (N : Node_Id) return Node_Id; -- Node1 + + function Delay_Alternative + (N : Node_Id) return Node_Id; -- Node4 + + function Delay_Statement + (N : Node_Id) return Node_Id; -- Node2 + + function Delta_Expression + (N : Node_Id) return Node_Id; -- Node3 + + function Digits_Expression + (N : Node_Id) return Node_Id; -- Node2 + + function Discr_Check_Funcs_Built + (N : Node_Id) return Boolean; -- Flag11 + + function Discrete_Choices + (N : Node_Id) return List_Id; -- List4 + + function Discrete_Range + (N : Node_Id) return Node_Id; -- Node4 + + function Discrete_Subtype_Definition + (N : Node_Id) return Node_Id; -- Node4 + + function Discrete_Subtype_Definitions + (N : Node_Id) return List_Id; -- List2 + + function Discriminant_Specifications + (N : Node_Id) return List_Id; -- List4 + + function Discriminant_Type + (N : Node_Id) return Node_Id; -- Node5 + + function Do_Accessibility_Check + (N : Node_Id) return Boolean; -- Flag13 + + function Do_Discriminant_Check + (N : Node_Id) return Boolean; -- Flag13 + + function Do_Division_Check + (N : Node_Id) return Boolean; -- Flag13 + + function Do_Length_Check + (N : Node_Id) return Boolean; -- Flag4 + + function Do_Overflow_Check + (N : Node_Id) return Boolean; -- Flag17 + + function Do_Range_Check + (N : Node_Id) return Boolean; -- Flag9 + + function Do_Storage_Check + (N : Node_Id) return Boolean; -- Flag17 + + function Do_Tag_Check + (N : Node_Id) return Boolean; -- Flag13 + + function Elaborate_All_Desirable + (N : Node_Id) return Boolean; -- Flag9 + + function Elaborate_All_Present + (N : Node_Id) return Boolean; -- Flag14 + + function Elaborate_Desirable + (N : Node_Id) return Boolean; -- Flag11 + + function Elaborate_Present + (N : Node_Id) return Boolean; -- Flag4 + + function Elaboration_Boolean + (N : Node_Id) return Node_Id; -- Node2 + + function Else_Actions + (N : Node_Id) return List_Id; -- List3 + + function Else_Statements + (N : Node_Id) return List_Id; -- List4 + + function Elsif_Parts + (N : Node_Id) return List_Id; -- List3 + + function Enclosing_Variant + (N : Node_Id) return Node_Id; -- Node2 + + function End_Label + (N : Node_Id) return Node_Id; -- Node4 + + function End_Span + (N : Node_Id) return Uint; -- Uint5 + + function Entity + (N : Node_Id) return Node_Id; -- Node4 + + function Entity_Or_Associated_Node + (N : Node_Id) return Node_Id; -- Node4 + + function Entry_Body_Formal_Part + (N : Node_Id) return Node_Id; -- Node5 + + function Entry_Call_Alternative + (N : Node_Id) return Node_Id; -- Node1 + + function Entry_Call_Statement + (N : Node_Id) return Node_Id; -- Node1 + + function Entry_Direct_Name + (N : Node_Id) return Node_Id; -- Node1 + + function Entry_Index + (N : Node_Id) return Node_Id; -- Node5 + + function Entry_Index_Specification + (N : Node_Id) return Node_Id; -- Node4 + + function Etype + (N : Node_Id) return Node_Id; -- Node5 + + function Exception_Choices + (N : Node_Id) return List_Id; -- List4 + + function Exception_Handlers + (N : Node_Id) return List_Id; -- List5 + + function Exception_Junk + (N : Node_Id) return Boolean; -- Flag8 + + function Exception_Label + (N : Node_Id) return Node_Id; -- Node5 + + function Explicit_Actual_Parameter + (N : Node_Id) return Node_Id; -- Node3 + + function Expansion_Delayed + (N : Node_Id) return Boolean; -- Flag11 + + function Explicit_Generic_Actual_Parameter + (N : Node_Id) return Node_Id; -- Node1 + + function Expression + (N : Node_Id) return Node_Id; -- Node3 + + function Expressions + (N : Node_Id) return List_Id; -- List1 + + function First_Bit + (N : Node_Id) return Node_Id; -- Node3 + + function First_Inlined_Subprogram + (N : Node_Id) return Entity_Id; -- Node3 + + function First_Name + (N : Node_Id) return Boolean; -- Flag5 + + function First_Named_Actual + (N : Node_Id) return Node_Id; -- Node4 + + function First_Real_Statement + (N : Node_Id) return Node_Id; -- Node2 + + function First_Subtype_Link + (N : Node_Id) return Entity_Id; -- Node5 + + function Float_Truncate + (N : Node_Id) return Boolean; -- Flag11 + + function Formal_Type_Definition + (N : Node_Id) return Node_Id; -- Node3 + + function Forwards_OK + (N : Node_Id) return Boolean; -- Flag5 + + function From_Aspect_Specification + (N : Node_Id) return Boolean; -- Flag13 + + function From_At_End + (N : Node_Id) return Boolean; -- Flag4 + + function From_At_Mod + (N : Node_Id) return Boolean; -- Flag4 + + function From_Default + (N : Node_Id) return Boolean; -- Flag6 + + function Generic_Associations + (N : Node_Id) return List_Id; -- List3 + + function Generic_Formal_Declarations + (N : Node_Id) return List_Id; -- List2 + + function Generic_Parent + (N : Node_Id) return Node_Id; -- Node5 + + function Generic_Parent_Type + (N : Node_Id) return Node_Id; -- Node4 + + function Handled_Statement_Sequence + (N : Node_Id) return Node_Id; -- Node4 + + function Handler_List_Entry + (N : Node_Id) return Node_Id; -- Node2 + + function Has_Created_Identifier + (N : Node_Id) return Boolean; -- Flag15 + + function Has_Dynamic_Length_Check + (N : Node_Id) return Boolean; -- Flag10 + + function Has_Dynamic_Range_Check + (N : Node_Id) return Boolean; -- Flag12 + + function Has_Init_Expression + (N : Node_Id) return Boolean; -- Flag14 + + function Has_Local_Raise + (N : Node_Id) return Boolean; -- Flag8 + + function Has_No_Elaboration_Code + (N : Node_Id) return Boolean; -- Flag17 + + function Has_Pragma_CPU + (N : Node_Id) return Boolean; -- Flag14 + + function Has_Pragma_Priority + (N : Node_Id) return Boolean; -- Flag6 + + function Has_Pragma_Suppress_All + (N : Node_Id) return Boolean; -- Flag14 + + function Has_Private_View + (N : Node_Id) return Boolean; -- Flag11 + + function Has_Relative_Deadline_Pragma + (N : Node_Id) return Boolean; -- Flag9 + + function Has_Self_Reference + (N : Node_Id) return Boolean; -- Flag13 + + function Has_Storage_Size_Pragma + (N : Node_Id) return Boolean; -- Flag5 + + function Has_Task_Info_Pragma + (N : Node_Id) return Boolean; -- Flag7 + + function Has_Task_Name_Pragma + (N : Node_Id) return Boolean; -- Flag8 + + function Has_Wide_Character + (N : Node_Id) return Boolean; -- Flag11 + + function Has_Wide_Wide_Character + (N : Node_Id) return Boolean; -- Flag13 + + function Hidden_By_Use_Clause + (N : Node_Id) return Elist_Id; -- Elist4 + + function High_Bound + (N : Node_Id) return Node_Id; -- Node2 + + function Identifier + (N : Node_Id) return Node_Id; -- Node1 + + function Interface_List + (N : Node_Id) return List_Id; -- List2 + + function Interface_Present + (N : Node_Id) return Boolean; -- Flag16 + + function Implicit_With + (N : Node_Id) return Boolean; -- Flag16 + + function Import_Interface_Present + (N : Node_Id) return Boolean; -- Flag16 + + function In_Present + (N : Node_Id) return Boolean; -- Flag15 + + function Includes_Infinities + (N : Node_Id) return Boolean; -- Flag11 + + function Inherited_Discriminant + (N : Node_Id) return Boolean; -- Flag13 + + function Instance_Spec + (N : Node_Id) return Node_Id; -- Node5 + + function Intval + (N : Node_Id) return Uint; -- Uint3 + + function Is_Accessibility_Actual + (N : Node_Id) return Boolean; -- Flag13 + + function Is_Asynchronous_Call_Block + (N : Node_Id) return Boolean; -- Flag7 + + function Is_Component_Left_Opnd + (N : Node_Id) return Boolean; -- Flag13 + + function Is_Component_Right_Opnd + (N : Node_Id) return Boolean; -- Flag14 + + function Is_Controlling_Actual + (N : Node_Id) return Boolean; -- Flag16 + + function Is_Delayed_Aspect + (N : Node_Id) return Boolean; -- Flag14 + + function Is_Dynamic_Coextension + (N : Node_Id) return Boolean; -- Flag18 + + function Is_Elsif + (N : Node_Id) return Boolean; -- Flag13 + + function Is_Entry_Barrier_Function + (N : Node_Id) return Boolean; -- Flag8 + + function Is_Expanded_Build_In_Place_Call + (N : Node_Id) return Boolean; -- Flag11 + + function Is_Folded_In_Parser + (N : Node_Id) return Boolean; -- Flag4 + + function Is_In_Discriminant_Check + (N : Node_Id) return Boolean; -- Flag11 + + function Is_Machine_Number + (N : Node_Id) return Boolean; -- Flag11 + + function Is_Null_Loop + (N : Node_Id) return Boolean; -- Flag16 + + function Is_Overloaded + (N : Node_Id) return Boolean; -- Flag5 + + function Is_Power_Of_2_For_Shift + (N : Node_Id) return Boolean; -- Flag13 + + function Is_Protected_Subprogram_Body + (N : Node_Id) return Boolean; -- Flag7 + + function Is_Static_Coextension + (N : Node_Id) return Boolean; -- Flag14 + + function Is_Static_Expression + (N : Node_Id) return Boolean; -- Flag6 + + function Is_Subprogram_Descriptor + (N : Node_Id) return Boolean; -- Flag16 + + function Is_Task_Allocation_Block + (N : Node_Id) return Boolean; -- Flag6 + + function Is_Task_Master + (N : Node_Id) return Boolean; -- Flag5 + + function Iteration_Scheme + (N : Node_Id) return Node_Id; -- Node2 + + function Iterator_Specification + (N : Node_Id) return Node_Id; -- Node2 + + function Itype + (N : Node_Id) return Entity_Id; -- Node1 + + function Kill_Range_Check + (N : Node_Id) return Boolean; -- Flag11 + + function Label_Construct + (N : Node_Id) return Node_Id; -- Node2 + + function Left_Opnd + (N : Node_Id) return Node_Id; -- Node2 + + function Last_Bit + (N : Node_Id) return Node_Id; -- Node4 + + function Last_Name + (N : Node_Id) return Boolean; -- Flag6 + + function Library_Unit + (N : Node_Id) return Node_Id; -- Node4 + + function Limited_View_Installed + (N : Node_Id) return Boolean; -- Flag18 + + function Limited_Present + (N : Node_Id) return Boolean; -- Flag17 + + function Literals + (N : Node_Id) return List_Id; -- List1 + + function Local_Raise_Not_OK + (N : Node_Id) return Boolean; -- Flag7 + + function Local_Raise_Statements + (N : Node_Id) return Elist_Id; -- Elist1 + + function Loop_Actions + (N : Node_Id) return List_Id; -- List2 + + function Loop_Parameter_Specification + (N : Node_Id) return Node_Id; -- Node4 + + function Low_Bound + (N : Node_Id) return Node_Id; -- Node1 + + function Mod_Clause + (N : Node_Id) return Node_Id; -- Node2 + + function More_Ids + (N : Node_Id) return Boolean; -- Flag5 + + function Must_Be_Byte_Aligned + (N : Node_Id) return Boolean; -- Flag14 + + function Must_Not_Freeze + (N : Node_Id) return Boolean; -- Flag8 + + function Must_Not_Override + (N : Node_Id) return Boolean; -- Flag15 + + function Must_Override + (N : Node_Id) return Boolean; -- Flag14 + + function Name + (N : Node_Id) return Node_Id; -- Node2 + + function Names + (N : Node_Id) return List_Id; -- List2 + + function Next_Entity + (N : Node_Id) return Node_Id; -- Node2 + + function Next_Exit_Statement + (N : Node_Id) return Node_Id; -- Node3 + + function Next_Implicit_With + (N : Node_Id) return Node_Id; -- Node3 + + function Next_Named_Actual + (N : Node_Id) return Node_Id; -- Node4 + + function Next_Pragma + (N : Node_Id) return Node_Id; -- Node1 + + function Next_Rep_Item + (N : Node_Id) return Node_Id; -- Node5 + + function Next_Use_Clause + (N : Node_Id) return Node_Id; -- Node3 + + function No_Ctrl_Actions + (N : Node_Id) return Boolean; -- Flag7 + + function No_Elaboration_Check + (N : Node_Id) return Boolean; -- Flag14 + + function No_Entities_Ref_In_Spec + (N : Node_Id) return Boolean; -- Flag8 + + function No_Initialization + (N : Node_Id) return Boolean; -- Flag13 + + function No_Truncation + (N : Node_Id) return Boolean; -- Flag17 + + function Null_Present + (N : Node_Id) return Boolean; -- Flag13 + + function Null_Exclusion_Present + (N : Node_Id) return Boolean; -- Flag11 + + function Null_Exclusion_In_Return_Present + (N : Node_Id) return Boolean; -- Flag14 + + function Null_Record_Present + (N : Node_Id) return Boolean; -- Flag17 + + function Object_Definition + (N : Node_Id) return Node_Id; -- Node4 + + function Of_Present + (N : Node_Id) return Boolean; -- Flag16 + + function Original_Discriminant + (N : Node_Id) return Node_Id; -- Node2 + + function Original_Entity + (N : Node_Id) return Entity_Id; -- Node2 + + function Others_Discrete_Choices + (N : Node_Id) return List_Id; -- List1 + + function Out_Present + (N : Node_Id) return Boolean; -- Flag17 + + function Parameter_Associations + (N : Node_Id) return List_Id; -- List3 + + function Parameter_List_Truncated + (N : Node_Id) return Boolean; -- Flag17 + + function Parameter_Specifications + (N : Node_Id) return List_Id; -- List3 + + function Parameter_Type + (N : Node_Id) return Node_Id; -- Node2 + + function Parent_Spec + (N : Node_Id) return Node_Id; -- Node4 + + function Position + (N : Node_Id) return Node_Id; -- Node2 + + function Pragma_Argument_Associations + (N : Node_Id) return List_Id; -- List2 + + function Pragma_Enabled + (N : Node_Id) return Boolean; -- Flag5 + + function Pragma_Identifier + (N : Node_Id) return Node_Id; -- Node4 + + function Pragmas_After + (N : Node_Id) return List_Id; -- List5 + + function Pragmas_Before + (N : Node_Id) return List_Id; -- List4 + + function Prefix + (N : Node_Id) return Node_Id; -- Node3 + + function Present_Expr + (N : Node_Id) return Uint; -- Uint3 + + function Prev_Ids + (N : Node_Id) return Boolean; -- Flag6 + + function Print_In_Hex + (N : Node_Id) return Boolean; -- Flag13 + + function Private_Declarations + (N : Node_Id) return List_Id; -- List3 + + function Private_Present + (N : Node_Id) return Boolean; -- Flag15 + + function Procedure_To_Call + (N : Node_Id) return Node_Id; -- Node2 + + function Proper_Body + (N : Node_Id) return Node_Id; -- Node1 + + function Protected_Definition + (N : Node_Id) return Node_Id; -- Node3 + + function Protected_Present + (N : Node_Id) return Boolean; -- Flag6 + + function Raises_Constraint_Error + (N : Node_Id) return Boolean; -- Flag7 + + function Range_Constraint + (N : Node_Id) return Node_Id; -- Node4 + + function Range_Expression + (N : Node_Id) return Node_Id; -- Node4 + + function Real_Range_Specification + (N : Node_Id) return Node_Id; -- Node4 + + function Realval + (N : Node_Id) return Ureal; -- Ureal3 + + function Reason + (N : Node_Id) return Uint; -- Uint3 + + function Record_Extension_Part + (N : Node_Id) return Node_Id; -- Node3 + + function Redundant_Use + (N : Node_Id) return Boolean; -- Flag13 + + function Renaming_Exception + (N : Node_Id) return Node_Id; -- Node2 + + function Result_Definition + (N : Node_Id) return Node_Id; -- Node4 + + function Return_Object_Declarations + (N : Node_Id) return List_Id; -- List3 + + function Return_Statement_Entity + (N : Node_Id) return Node_Id; -- Node5 + + function Reverse_Present + (N : Node_Id) return Boolean; -- Flag15 + + function Right_Opnd + (N : Node_Id) return Node_Id; -- Node3 + + function Rounded_Result + (N : Node_Id) return Boolean; -- Flag18 + + function SCIL_Controlling_Tag + (N : Node_Id) return Node_Id; -- Node5 + + function SCIL_Entity + (N : Node_Id) return Node_Id; -- Node4 + + function SCIL_Tag_Value + (N : Node_Id) return Node_Id; -- Node5 + + function SCIL_Target_Prim + (N : Node_Id) return Node_Id; -- Node2 + + function Scope + (N : Node_Id) return Node_Id; -- Node3 + + function Select_Alternatives + (N : Node_Id) return List_Id; -- List1 + + function Selector_Name + (N : Node_Id) return Node_Id; -- Node2 + + function Selector_Names + (N : Node_Id) return List_Id; -- List1 + + function Shift_Count_OK + (N : Node_Id) return Boolean; -- Flag4 + + function Source_Type + (N : Node_Id) return Entity_Id; -- Node1 + + function Specification + (N : Node_Id) return Node_Id; -- Node1 + + function Split_PPC + (N : Node_Id) return Boolean; -- Flag17 + + function Statements + (N : Node_Id) return List_Id; -- List3 + + function Static_Processing_OK + (N : Node_Id) return Boolean; -- Flag4 + + function Storage_Pool + (N : Node_Id) return Node_Id; -- Node1 + + function Strval + (N : Node_Id) return String_Id; -- Str3 + + function Subtype_Indication + (N : Node_Id) return Node_Id; -- Node5 + + function Subtype_Mark + (N : Node_Id) return Node_Id; -- Node4 + + function Subtype_Marks + (N : Node_Id) return List_Id; -- List2 + + function Suppress_Assignment_Checks + (N : Node_Id) return Boolean; -- Flag18 + + function Suppress_Loop_Warnings + (N : Node_Id) return Boolean; -- Flag17 + + function Synchronized_Present + (N : Node_Id) return Boolean; -- Flag7 + + function Tagged_Present + (N : Node_Id) return Boolean; -- Flag15 + + function Target_Type + (N : Node_Id) return Entity_Id; -- Node2 + + function Task_Definition + (N : Node_Id) return Node_Id; -- Node3 + + function Task_Present + (N : Node_Id) return Boolean; -- Flag5 + + function Then_Actions + (N : Node_Id) return List_Id; -- List2 + + function Then_Statements + (N : Node_Id) return List_Id; -- List2 + + function Treat_Fixed_As_Integer + (N : Node_Id) return Boolean; -- Flag14 + + function Triggering_Alternative + (N : Node_Id) return Node_Id; -- Node1 + + function Triggering_Statement + (N : Node_Id) return Node_Id; -- Node1 + + function TSS_Elist + (N : Node_Id) return Elist_Id; -- Elist3 + + function Type_Definition + (N : Node_Id) return Node_Id; -- Node3 + + function Unit + (N : Node_Id) return Node_Id; -- Node2 + + function Unknown_Discriminants_Present + (N : Node_Id) return Boolean; -- Flag13 + + function Unreferenced_In_Spec + (N : Node_Id) return Boolean; -- Flag7 + + function Variant_Part + (N : Node_Id) return Node_Id; -- Node4 + + function Variants + (N : Node_Id) return List_Id; -- List1 + + function Visible_Declarations + (N : Node_Id) return List_Id; -- List2 + + function Was_Originally_Stub + (N : Node_Id) return Boolean; -- Flag13 + + function Withed_Body + (N : Node_Id) return Node_Id; -- Node1 + + function Zero_Cost_Handling + (N : Node_Id) return Boolean; -- Flag5 + + -- End functions (note used by xsinfo utility program to end processing) + + ---------------------------- + -- Node Update Procedures -- + ---------------------------- + + -- These are the corresponding node update routines, which again provide + -- a high level logical access with type checking. In addition to setting + -- the indicated field of the node N to the given Val, in the case of + -- tree pointers (List1-4), the parent pointer of the Val node is set to + -- point back to node N. This automates the setting of the parent pointer. + + procedure Set_ABE_Is_Certain + (N : Node_Id; Val : Boolean := True); -- Flag18 + + procedure Set_Abort_Present + (N : Node_Id; Val : Boolean := True); -- Flag15 + + procedure Set_Abortable_Part + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Abstract_Present + (N : Node_Id; Val : Boolean := True); -- Flag4 + + procedure Set_Accept_Handler_Records + (N : Node_Id; Val : List_Id); -- List5 + + procedure Set_Accept_Statement + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Access_Definition + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Access_To_Subprogram_Definition + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Access_Types_To_Process + (N : Node_Id; Val : Elist_Id); -- Elist2 + + procedure Set_Actions + (N : Node_Id; Val : List_Id); -- List1 + + procedure Set_Activation_Chain_Entity + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Acts_As_Spec + (N : Node_Id; Val : Boolean := True); -- Flag4 + + procedure Set_Actual_Designated_Subtype + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_Address_Warning_Posted + (N : Node_Id; Val : Boolean := True); -- Flag18 + + procedure Set_Aggregate_Bounds + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Aliased_Present + (N : Node_Id; Val : Boolean := True); -- Flag4 + + procedure Set_All_Others + (N : Node_Id; Val : Boolean := True); -- Flag11 + + procedure Set_All_Present + (N : Node_Id; Val : Boolean := True); -- Flag15 + + procedure Set_Alternatives + (N : Node_Id; Val : List_Id); -- List4 + + procedure Set_Ancestor_Part + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Array_Aggregate + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Aspect_Cancel + (N : Node_Id; Val : Boolean := True); -- Flag11 + + procedure Set_Aspect_Rep_Item + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Assignment_OK + (N : Node_Id; Val : Boolean := True); -- Flag15 + + procedure Set_Associated_Node + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_Attribute_Name + (N : Node_Id; Val : Name_Id); -- Name2 + + procedure Set_At_End_Proc + (N : Node_Id; Val : Node_Id); -- Node1 + + procedure Set_Aux_Decls_Node + (N : Node_Id; Val : Node_Id); -- Node5 + + procedure Set_Backwards_OK + (N : Node_Id; Val : Boolean := True); -- Flag6 + + procedure Set_Bad_Is_Detected + (N : Node_Id; Val : Boolean := True); -- Flag15 + + procedure Set_Body_Required + (N : Node_Id; Val : Boolean := True); -- Flag13 + + procedure Set_Body_To_Inline + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Box_Present + (N : Node_Id; Val : Boolean := True); -- Flag15 + + procedure Set_By_Ref + (N : Node_Id; Val : Boolean := True); -- Flag5 + + procedure Set_Char_Literal_Value + (N : Node_Id; Val : Uint); -- Uint2 + + procedure Set_Chars + (N : Node_Id; Val : Name_Id); -- Name1 + + procedure Set_Check_Address_Alignment + (N : Node_Id; Val : Boolean := True); -- Flag11 + + procedure Set_Choice_Parameter + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Choices + (N : Node_Id; Val : List_Id); -- List1 + + procedure Set_Class_Present + (N : Node_Id; Val : Boolean := True); -- Flag6 + + procedure Set_Coextensions + (N : Node_Id; Val : Elist_Id); -- Elist4 + + procedure Set_Comes_From_Extended_Return_Statement + (N : Node_Id; Val : Boolean := True); -- Flag18 + + procedure Set_Compile_Time_Known_Aggregate + (N : Node_Id; Val : Boolean := True); -- Flag18 + + procedure Set_Component_Associations + (N : Node_Id; Val : List_Id); -- List2 + + procedure Set_Component_Clauses + (N : Node_Id; Val : List_Id); -- List3 + + procedure Set_Component_Definition + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_Component_Items + (N : Node_Id; Val : List_Id); -- List3 + + procedure Set_Component_List + (N : Node_Id; Val : Node_Id); -- Node1 + + procedure Set_Component_Name + (N : Node_Id; Val : Node_Id); -- Node1 + + procedure Set_Componentwise_Assignment + (N : Node_Id; Val : Boolean := True); -- Flag14 + + procedure Set_Condition + (N : Node_Id; Val : Node_Id); -- Node1 + + procedure Set_Condition_Actions + (N : Node_Id; Val : List_Id); -- List3 + + procedure Set_Config_Pragmas + (N : Node_Id; Val : List_Id); -- List4 + + procedure Set_Constant_Present + (N : Node_Id; Val : Boolean := True); -- Flag17 + + procedure Set_Constraint + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Constraints + (N : Node_Id; Val : List_Id); -- List1 + + procedure Set_Context_Installed + (N : Node_Id; Val : Boolean := True); -- Flag13 + + procedure Set_Context_Items + (N : Node_Id; Val : List_Id); -- List1 + + procedure Set_Context_Pending + (N : Node_Id; Val : Boolean := True); -- Flag16 + + procedure Set_Controlling_Argument + (N : Node_Id; Val : Node_Id); -- Node1 + + procedure Set_Conversion_OK + (N : Node_Id; Val : Boolean := True); -- Flag14 + + procedure Set_Corresponding_Body + (N : Node_Id; Val : Node_Id); -- Node5 + + procedure Set_Corresponding_Formal_Spec + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Corresponding_Generic_Association + (N : Node_Id; Val : Node_Id); -- Node5 + + procedure Set_Corresponding_Integer_Value + (N : Node_Id; Val : Uint); -- Uint4 + + procedure Set_Corresponding_Spec + (N : Node_Id; Val : Node_Id); -- Node5 + + procedure Set_Corresponding_Stub + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Dcheck_Function + (N : Node_Id; Val : Entity_Id); -- Node5 + + procedure Set_Debug_Statement + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Declarations + (N : Node_Id; Val : List_Id); -- List2 + + procedure Set_Default_Expression + (N : Node_Id; Val : Node_Id); -- Node5 + + procedure Set_Default_Storage_Pool + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Default_Name + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Defining_Identifier + (N : Node_Id; Val : Entity_Id); -- Node1 + + procedure Set_Defining_Unit_Name + (N : Node_Id; Val : Node_Id); -- Node1 + + procedure Set_Delay_Alternative + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_Delay_Statement + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Delta_Expression + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Digits_Expression + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Discr_Check_Funcs_Built + (N : Node_Id; Val : Boolean := True); -- Flag11 + + procedure Set_Discrete_Choices + (N : Node_Id; Val : List_Id); -- List4 + + procedure Set_Discrete_Range + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_Discrete_Subtype_Definition + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_Discrete_Subtype_Definitions + (N : Node_Id; Val : List_Id); -- List2 + + procedure Set_Discriminant_Specifications + (N : Node_Id; Val : List_Id); -- List4 + + procedure Set_Discriminant_Type + (N : Node_Id; Val : Node_Id); -- Node5 + + procedure Set_Do_Accessibility_Check + (N : Node_Id; Val : Boolean := True); -- Flag13 + + procedure Set_Do_Discriminant_Check + (N : Node_Id; Val : Boolean := True); -- Flag13 + + procedure Set_Do_Division_Check + (N : Node_Id; Val : Boolean := True); -- Flag13 + + procedure Set_Do_Length_Check + (N : Node_Id; Val : Boolean := True); -- Flag4 + + procedure Set_Do_Overflow_Check + (N : Node_Id; Val : Boolean := True); -- Flag17 + + procedure Set_Do_Range_Check + (N : Node_Id; Val : Boolean := True); -- Flag9 + + procedure Set_Do_Storage_Check + (N : Node_Id; Val : Boolean := True); -- Flag17 + + procedure Set_Do_Tag_Check + (N : Node_Id; Val : Boolean := True); -- Flag13 + + procedure Set_Elaborate_All_Desirable + (N : Node_Id; Val : Boolean := True); -- Flag9 + + procedure Set_Elaborate_All_Present + (N : Node_Id; Val : Boolean := True); -- Flag14 + + procedure Set_Elaborate_Desirable + (N : Node_Id; Val : Boolean := True); -- Flag11 + + procedure Set_Elaborate_Present + (N : Node_Id; Val : Boolean := True); -- Flag4 + + procedure Set_Elaboration_Boolean + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Else_Actions + (N : Node_Id; Val : List_Id); -- List3 + + procedure Set_Else_Statements + (N : Node_Id; Val : List_Id); -- List4 + + procedure Set_Elsif_Parts + (N : Node_Id; Val : List_Id); -- List3 + + procedure Set_Enclosing_Variant + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_End_Label + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_End_Span + (N : Node_Id; Val : Uint); -- Uint5 + + procedure Set_Entity + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_Entry_Body_Formal_Part + (N : Node_Id; Val : Node_Id); -- Node5 + + procedure Set_Entry_Call_Alternative + (N : Node_Id; Val : Node_Id); -- Node1 + + procedure Set_Entry_Call_Statement + (N : Node_Id; Val : Node_Id); -- Node1 + + procedure Set_Entry_Direct_Name + (N : Node_Id; Val : Node_Id); -- Node1 + + procedure Set_Entry_Index + (N : Node_Id; Val : Node_Id); -- Node5 + + procedure Set_Entry_Index_Specification + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_Etype + (N : Node_Id; Val : Node_Id); -- Node5 + + procedure Set_Exception_Choices + (N : Node_Id; Val : List_Id); -- List4 + + procedure Set_Exception_Handlers + (N : Node_Id; Val : List_Id); -- List5 + + procedure Set_Exception_Junk + (N : Node_Id; Val : Boolean := True); -- Flag8 + + procedure Set_Exception_Label + (N : Node_Id; Val : Node_Id); -- Node5 + + procedure Set_Expansion_Delayed + (N : Node_Id; Val : Boolean := True); -- Flag11 + + procedure Set_Explicit_Actual_Parameter + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Explicit_Generic_Actual_Parameter + (N : Node_Id; Val : Node_Id); -- Node1 + + procedure Set_Expression + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Expressions + (N : Node_Id; Val : List_Id); -- List1 + + procedure Set_First_Bit + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_First_Inlined_Subprogram + (N : Node_Id; Val : Entity_Id); -- Node3 + + procedure Set_First_Name + (N : Node_Id; Val : Boolean := True); -- Flag5 + + procedure Set_First_Named_Actual + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_First_Real_Statement + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_First_Subtype_Link + (N : Node_Id; Val : Entity_Id); -- Node5 + + procedure Set_Float_Truncate + (N : Node_Id; Val : Boolean := True); -- Flag11 + + procedure Set_Formal_Type_Definition + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Forwards_OK + (N : Node_Id; Val : Boolean := True); -- Flag5 + + procedure Set_From_At_Mod + (N : Node_Id; Val : Boolean := True); -- Flag4 + + procedure Set_From_Aspect_Specification + (N : Node_Id; Val : Boolean := True); -- Flag13 + + procedure Set_From_At_End + (N : Node_Id; Val : Boolean := True); -- Flag4 + + procedure Set_From_Default + (N : Node_Id; Val : Boolean := True); -- Flag6 + + procedure Set_Generic_Associations + (N : Node_Id; Val : List_Id); -- List3 + + procedure Set_Generic_Formal_Declarations + (N : Node_Id; Val : List_Id); -- List2 + + procedure Set_Generic_Parent + (N : Node_Id; Val : Node_Id); -- Node5 + + procedure Set_Generic_Parent_Type + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_Handled_Statement_Sequence + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_Handler_List_Entry + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Has_Created_Identifier + (N : Node_Id; Val : Boolean := True); -- Flag15 + + procedure Set_Has_Dynamic_Length_Check + (N : Node_Id; Val : Boolean := True); -- Flag10 + + procedure Set_Has_Dynamic_Range_Check + (N : Node_Id; Val : Boolean := True); -- Flag12 + + procedure Set_Has_Init_Expression + (N : Node_Id; Val : Boolean := True); -- Flag14 + + procedure Set_Has_Local_Raise + (N : Node_Id; Val : Boolean := True); -- Flag8 + + procedure Set_Has_No_Elaboration_Code + (N : Node_Id; Val : Boolean := True); -- Flag17 + + procedure Set_Has_Pragma_CPU + (N : Node_Id; Val : Boolean := True); -- Flag14 + + procedure Set_Has_Pragma_Priority + (N : Node_Id; Val : Boolean := True); -- Flag6 + + procedure Set_Has_Pragma_Suppress_All + (N : Node_Id; Val : Boolean := True); -- Flag14 + + procedure Set_Has_Private_View + (N : Node_Id; Val : Boolean := True); -- Flag11 + + procedure Set_Has_Relative_Deadline_Pragma + (N : Node_Id; Val : Boolean := True); -- Flag9 + + procedure Set_Has_Self_Reference + (N : Node_Id; Val : Boolean := True); -- Flag13 + + procedure Set_Has_Storage_Size_Pragma + (N : Node_Id; Val : Boolean := True); -- Flag5 + + procedure Set_Has_Task_Info_Pragma + (N : Node_Id; Val : Boolean := True); -- Flag7 + + procedure Set_Has_Task_Name_Pragma + (N : Node_Id; Val : Boolean := True); -- Flag8 + + procedure Set_Has_Wide_Character + (N : Node_Id; Val : Boolean := True); -- Flag11 + + procedure Set_Has_Wide_Wide_Character + (N : Node_Id; Val : Boolean := True); -- Flag13 + + procedure Set_Hidden_By_Use_Clause + (N : Node_Id; Val : Elist_Id); -- Elist4 + + procedure Set_High_Bound + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Identifier + (N : Node_Id; Val : Node_Id); -- Node1 + + procedure Set_Interface_List + (N : Node_Id; Val : List_Id); -- List2 + + procedure Set_Interface_Present + (N : Node_Id; Val : Boolean := True); -- Flag16 + + procedure Set_Implicit_With + (N : Node_Id; Val : Boolean := True); -- Flag16 + + procedure Set_Import_Interface_Present + (N : Node_Id; Val : Boolean := True); -- Flag16 + + procedure Set_In_Present + (N : Node_Id; Val : Boolean := True); -- Flag15 + + procedure Set_Includes_Infinities + (N : Node_Id; Val : Boolean := True); -- Flag11 + + procedure Set_Inherited_Discriminant + (N : Node_Id; Val : Boolean := True); -- Flag13 + + procedure Set_Instance_Spec + (N : Node_Id; Val : Node_Id); -- Node5 + + procedure Set_Intval + (N : Node_Id; Val : Uint); -- Uint3 + + procedure Set_Is_Accessibility_Actual + (N : Node_Id; Val : Boolean := True); -- Flag13 + + procedure Set_Is_Asynchronous_Call_Block + (N : Node_Id; Val : Boolean := True); -- Flag7 + + procedure Set_Is_Component_Left_Opnd + (N : Node_Id; Val : Boolean := True); -- Flag13 + + procedure Set_Is_Component_Right_Opnd + (N : Node_Id; Val : Boolean := True); -- Flag14 + + procedure Set_Is_Controlling_Actual + (N : Node_Id; Val : Boolean := True); -- Flag16 + + procedure Set_Is_Delayed_Aspect + (N : Node_Id; Val : Boolean := True); -- Flag14 + + procedure Set_Is_Dynamic_Coextension + (N : Node_Id; Val : Boolean := True); -- Flag18 + + procedure Set_Is_Elsif + (N : Node_Id; Val : Boolean := True); -- Flag13 + + procedure Set_Is_Entry_Barrier_Function + (N : Node_Id; Val : Boolean := True); -- Flag8 + + procedure Set_Is_Expanded_Build_In_Place_Call + (N : Node_Id; Val : Boolean := True); -- Flag11 + + procedure Set_Is_Folded_In_Parser + (N : Node_Id; Val : Boolean := True); -- Flag4 + + procedure Set_Is_In_Discriminant_Check + (N : Node_Id; Val : Boolean := True); -- Flag11 + + procedure Set_Is_Machine_Number + (N : Node_Id; Val : Boolean := True); -- Flag11 + + procedure Set_Is_Null_Loop + (N : Node_Id; Val : Boolean := True); -- Flag16 + + procedure Set_Is_Overloaded + (N : Node_Id; Val : Boolean := True); -- Flag5 + + procedure Set_Is_Power_Of_2_For_Shift + (N : Node_Id; Val : Boolean := True); -- Flag13 + + procedure Set_Is_Protected_Subprogram_Body + (N : Node_Id; Val : Boolean := True); -- Flag7 + + procedure Set_Is_Static_Coextension + (N : Node_Id; Val : Boolean := True); -- Flag14 + + procedure Set_Is_Static_Expression + (N : Node_Id; Val : Boolean := True); -- Flag6 + + procedure Set_Is_Subprogram_Descriptor + (N : Node_Id; Val : Boolean := True); -- Flag16 + + procedure Set_Is_Task_Allocation_Block + (N : Node_Id; Val : Boolean := True); -- Flag6 + + procedure Set_Is_Task_Master + (N : Node_Id; Val : Boolean := True); -- Flag5 + + procedure Set_Iteration_Scheme + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Iterator_Specification + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Itype + (N : Node_Id; Val : Entity_Id); -- Node1 + + procedure Set_Kill_Range_Check + (N : Node_Id; Val : Boolean := True); -- Flag11 + + procedure Set_Last_Bit + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_Last_Name + (N : Node_Id; Val : Boolean := True); -- Flag6 + + procedure Set_Library_Unit + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_Label_Construct + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Left_Opnd + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Limited_View_Installed + (N : Node_Id; Val : Boolean := True); -- Flag18 + + procedure Set_Limited_Present + (N : Node_Id; Val : Boolean := True); -- Flag17 + + procedure Set_Literals + (N : Node_Id; Val : List_Id); -- List1 + + procedure Set_Local_Raise_Not_OK + (N : Node_Id; Val : Boolean := True); -- Flag7 + + procedure Set_Local_Raise_Statements + (N : Node_Id; Val : Elist_Id); -- Elist1 + + procedure Set_Loop_Actions + (N : Node_Id; Val : List_Id); -- List2 + + procedure Set_Loop_Parameter_Specification + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_Low_Bound + (N : Node_Id; Val : Node_Id); -- Node1 + + procedure Set_Mod_Clause + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_More_Ids + (N : Node_Id; Val : Boolean := True); -- Flag5 + + procedure Set_Must_Be_Byte_Aligned + (N : Node_Id; Val : Boolean := True); -- Flag14 + + procedure Set_Must_Not_Freeze + (N : Node_Id; Val : Boolean := True); -- Flag8 + + procedure Set_Must_Not_Override + (N : Node_Id; Val : Boolean := True); -- Flag15 + + procedure Set_Must_Override + (N : Node_Id; Val : Boolean := True); -- Flag14 + + procedure Set_Name + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Names + (N : Node_Id; Val : List_Id); -- List2 + + procedure Set_Next_Entity + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Next_Exit_Statement + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Next_Implicit_With + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Next_Named_Actual + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_Next_Pragma + (N : Node_Id; Val : Node_Id); -- Node1 + + procedure Set_Next_Rep_Item + (N : Node_Id; Val : Node_Id); -- Node5 + + procedure Set_Next_Use_Clause + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_No_Ctrl_Actions + (N : Node_Id; Val : Boolean := True); -- Flag7 + + procedure Set_No_Elaboration_Check + (N : Node_Id; Val : Boolean := True); -- Flag14 + + procedure Set_No_Entities_Ref_In_Spec + (N : Node_Id; Val : Boolean := True); -- Flag8 + + procedure Set_No_Initialization + (N : Node_Id; Val : Boolean := True); -- Flag13 + + procedure Set_No_Truncation + (N : Node_Id; Val : Boolean := True); -- Flag17 + + procedure Set_Null_Present + (N : Node_Id; Val : Boolean := True); -- Flag13 + + procedure Set_Null_Exclusion_Present + (N : Node_Id; Val : Boolean := True); -- Flag11 + + procedure Set_Null_Exclusion_In_Return_Present + (N : Node_Id; Val : Boolean := True); -- Flag14 + + procedure Set_Null_Record_Present + (N : Node_Id; Val : Boolean := True); -- Flag17 + + procedure Set_Object_Definition + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_Of_Present + (N : Node_Id; Val : Boolean := True); -- Flag16 + + procedure Set_Original_Discriminant + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Original_Entity + (N : Node_Id; Val : Entity_Id); -- Node2 + + procedure Set_Others_Discrete_Choices + (N : Node_Id; Val : List_Id); -- List1 + + procedure Set_Out_Present + (N : Node_Id; Val : Boolean := True); -- Flag17 + + procedure Set_Parameter_Associations + (N : Node_Id; Val : List_Id); -- List3 + + procedure Set_Parameter_List_Truncated + (N : Node_Id; Val : Boolean := True); -- Flag17 + + procedure Set_Parameter_Specifications + (N : Node_Id; Val : List_Id); -- List3 + + procedure Set_Parameter_Type + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Parent_Spec + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_Position + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Pragma_Argument_Associations + (N : Node_Id; Val : List_Id); -- List2 + + procedure Set_Pragma_Enabled + (N : Node_Id; Val : Boolean := True); -- Flag5 + + procedure Set_Pragma_Identifier + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_Pragmas_After + (N : Node_Id; Val : List_Id); -- List5 + + procedure Set_Pragmas_Before + (N : Node_Id; Val : List_Id); -- List4 + + procedure Set_Prefix + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Present_Expr + (N : Node_Id; Val : Uint); -- Uint3 + + procedure Set_Prev_Ids + (N : Node_Id; Val : Boolean := True); -- Flag6 + + procedure Set_Print_In_Hex + (N : Node_Id; Val : Boolean := True); -- Flag13 + + procedure Set_Private_Declarations + (N : Node_Id; Val : List_Id); -- List3 + + procedure Set_Private_Present + (N : Node_Id; Val : Boolean := True); -- Flag15 + + procedure Set_Procedure_To_Call + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Proper_Body + (N : Node_Id; Val : Node_Id); -- Node1 + + procedure Set_Protected_Definition + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Protected_Present + (N : Node_Id; Val : Boolean := True); -- Flag6 + + procedure Set_Raises_Constraint_Error + (N : Node_Id; Val : Boolean := True); -- Flag7 + + procedure Set_Range_Constraint + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_Range_Expression + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_Real_Range_Specification + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_Realval + (N : Node_Id; Val : Ureal); -- Ureal3 + + procedure Set_Reason + (N : Node_Id; Val : Uint); -- Uint3 + + procedure Set_Record_Extension_Part + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Redundant_Use + (N : Node_Id; Val : Boolean := True); -- Flag13 + + procedure Set_Renaming_Exception + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Result_Definition + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_Return_Object_Declarations + (N : Node_Id; Val : List_Id); -- List3 + + procedure Set_Return_Statement_Entity + (N : Node_Id; Val : Node_Id); -- Node5 + + procedure Set_Reverse_Present + (N : Node_Id; Val : Boolean := True); -- Flag15 + + procedure Set_Right_Opnd + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Rounded_Result + (N : Node_Id; Val : Boolean := True); -- Flag18 + + procedure Set_SCIL_Controlling_Tag + (N : Node_Id; Val : Node_Id); -- Node5 + + procedure Set_SCIL_Entity + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_SCIL_Tag_Value + (N : Node_Id; Val : Node_Id); -- Node5 + + procedure Set_SCIL_Target_Prim + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Scope + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Select_Alternatives + (N : Node_Id; Val : List_Id); -- List1 + + procedure Set_Selector_Name + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Selector_Names + (N : Node_Id; Val : List_Id); -- List1 + + procedure Set_Shift_Count_OK + (N : Node_Id; Val : Boolean := True); -- Flag4 + + procedure Set_Source_Type + (N : Node_Id; Val : Entity_Id); -- Node1 + + procedure Set_Specification + (N : Node_Id; Val : Node_Id); -- Node1 + + procedure Set_Split_PPC + (N : Node_Id; Val : Boolean); -- Flag17 + + procedure Set_Statements + (N : Node_Id; Val : List_Id); -- List3 + + procedure Set_Static_Processing_OK + (N : Node_Id; Val : Boolean); -- Flag4 + + procedure Set_Storage_Pool + (N : Node_Id; Val : Node_Id); -- Node1 + + procedure Set_Strval + (N : Node_Id; Val : String_Id); -- Str3 + + procedure Set_Subtype_Indication + (N : Node_Id; Val : Node_Id); -- Node5 + + procedure Set_Subtype_Mark + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_Subtype_Marks + (N : Node_Id; Val : List_Id); -- List2 + + procedure Set_Suppress_Assignment_Checks + (N : Node_Id; Val : Boolean := True); -- Flag18 + + procedure Set_Suppress_Loop_Warnings + (N : Node_Id; Val : Boolean := True); -- Flag17 + + procedure Set_Synchronized_Present + (N : Node_Id; Val : Boolean := True); -- Flag7 + + procedure Set_Tagged_Present + (N : Node_Id; Val : Boolean := True); -- Flag15 + + procedure Set_Target_Type + (N : Node_Id; Val : Entity_Id); -- Node2 + + procedure Set_Task_Definition + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Task_Present + (N : Node_Id; Val : Boolean := True); -- Flag5 + + procedure Set_Then_Actions + (N : Node_Id; Val : List_Id); -- List2 + + procedure Set_Then_Statements + (N : Node_Id; Val : List_Id); -- List2 + + procedure Set_Treat_Fixed_As_Integer + (N : Node_Id; Val : Boolean := True); -- Flag14 + + procedure Set_Triggering_Alternative + (N : Node_Id; Val : Node_Id); -- Node1 + + procedure Set_Triggering_Statement + (N : Node_Id; Val : Node_Id); -- Node1 + + procedure Set_TSS_Elist + (N : Node_Id; Val : Elist_Id); -- Elist3 + + procedure Set_Type_Definition + (N : Node_Id; Val : Node_Id); -- Node3 + + procedure Set_Unit + (N : Node_Id; Val : Node_Id); -- Node2 + + procedure Set_Unknown_Discriminants_Present + (N : Node_Id; Val : Boolean := True); -- Flag13 + + procedure Set_Unreferenced_In_Spec + (N : Node_Id; Val : Boolean := True); -- Flag7 + + procedure Set_Variant_Part + (N : Node_Id; Val : Node_Id); -- Node4 + + procedure Set_Variants + (N : Node_Id; Val : List_Id); -- List1 + + procedure Set_Visible_Declarations + (N : Node_Id; Val : List_Id); -- List2 + + procedure Set_Was_Originally_Stub + (N : Node_Id; Val : Boolean := True); -- Flag13 + + procedure Set_Withed_Body + (N : Node_Id; Val : Node_Id); -- Node1 + + procedure Set_Zero_Cost_Handling + (N : Node_Id; Val : Boolean := True); -- Flag5 + + ------------------------- + -- Iterator Procedures -- + ------------------------- + + -- The call to Next_xxx (N) is equivalent to N := Next_xxx (N) + + procedure Next_Entity (N : in out Node_Id); + procedure Next_Named_Actual (N : in out Node_Id); + procedure Next_Rep_Item (N : in out Node_Id); + procedure Next_Use_Clause (N : in out Node_Id); + + ------------------------------------------- + -- Miscellaneous Tree Access Subprograms -- + ------------------------------------------- + + function End_Location (N : Node_Id) return Source_Ptr; + -- N is an N_If_Statement or N_Case_Statement node, and this function + -- returns the location of the IF token in the END IF sequence by + -- translating the value of the End_Span field. + + procedure Set_End_Location (N : Node_Id; S : Source_Ptr); + -- N is an N_If_Statement or N_Case_Statement node. This procedure sets + -- the End_Span field to correspond to the given value S. In other words, + -- End_Span is set to the difference between S and Sloc (N), the starting + -- location. + + function Get_Pragma_Arg (Arg : Node_Id) return Node_Id; + -- Given an argument to a pragma Arg, this function returns the expression + -- for the argument. This is Arg itself, or, in the case where Arg is a + -- pragma argument association node, the expression from this node. + + -------------------------------- + -- Node_Kind Membership Tests -- + -------------------------------- + + -- The following functions allow a convenient notation for testing whether + -- a Node_Kind value matches any one of a list of possible values. In each + -- case True is returned if the given T argument is equal to any of the V + -- arguments. Note that there is a similar set of functions defined in + -- Atree where the first argument is a Node_Id whose Nkind field is tested. + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind) return Boolean; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind) return Boolean; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind) return Boolean; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind) return Boolean; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind) return Boolean; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind; + V7 : Node_Kind) return Boolean; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind; + V7 : Node_Kind; + V8 : Node_Kind) return Boolean; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind; + V7 : Node_Kind; + V8 : Node_Kind; + V9 : Node_Kind) return Boolean; + + pragma Inline (Nkind_In); + -- Inline all above functions + + ----------------------- + -- Utility Functions -- + ----------------------- + + function Pragma_Name (N : Node_Id) return Name_Id; + pragma Inline (Pragma_Name); + -- Convenient function to obtain Chars field of Pragma_Identifier + + ----------------------------- + -- Syntactic Parent Tables -- + ----------------------------- + + -- These tables show for each node, and for each of the five fields, + -- whether the corresponding field is syntactic (True) or semantic (False). + -- Unused entries are also set to False. + + subtype Field_Num is Natural range 1 .. 5; + + Is_Syntactic_Field : constant array (Node_Kind, Field_Num) of Boolean := ( + + -- Following entries can be built automatically from the sinfo sources + -- using the makeisf utility (currently this program is in spitbol). + + N_Identifier => + (1 => True, -- Chars (Name1) + 2 => False, -- Original_Discriminant (Node2-Sem) + 3 => False, -- unused + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Integer_Literal => + (1 => False, -- unused + 2 => False, -- Original_Entity (Node2-Sem) + 3 => True, -- Intval (Uint3) + 4 => False, -- unused + 5 => False), -- Etype (Node5-Sem) + + N_Real_Literal => + (1 => False, -- unused + 2 => False, -- Original_Entity (Node2-Sem) + 3 => True, -- Realval (Ureal3) + 4 => False, -- Corresponding_Integer_Value (Uint4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Character_Literal => + (1 => True, -- Chars (Name1) + 2 => True, -- Char_Literal_Value (Uint2) + 3 => False, -- unused + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_String_Literal => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Strval (Str3) + 4 => False, -- unused + 5 => False), -- Etype (Node5-Sem) + + N_Pragma => + (1 => False, -- Next_Pragma (Node1-Sem) + 2 => True, -- Pragma_Argument_Associations (List2) + 3 => True, -- Debug_Statement (Node3) + 4 => True, -- Pragma_Identifier (Node4) + 5 => False), -- Next_Rep_Item (Node5-Sem) + + N_Pragma_Argument_Association => + (1 => True, -- Chars (Name1) + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => False), -- unused + + N_Defining_Identifier => + (1 => True, -- Chars (Name1) + 2 => False, -- Next_Entity (Node2-Sem) + 3 => False, -- Scope (Node3-Sem) + 4 => False, -- unused + 5 => False), -- Etype (Node5-Sem) + + N_Full_Type_Declaration => + (1 => True, -- Defining_Identifier (Node1) + 2 => False, -- unused + 3 => True, -- Type_Definition (Node3) + 4 => True, -- Discriminant_Specifications (List4) + 5 => False), -- unused + + N_Subtype_Declaration => + (1 => True, -- Defining_Identifier (Node1) + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- Generic_Parent_Type (Node4-Sem) + 5 => True), -- Subtype_Indication (Node5) + + N_Subtype_Indication => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Constraint (Node3) + 4 => True, -- Subtype_Mark (Node4) + 5 => False), -- Etype (Node5-Sem) + + N_Object_Declaration => + (1 => True, -- Defining_Identifier (Node1) + 2 => False, -- Handler_List_Entry (Node2-Sem) + 3 => True, -- Expression (Node3) + 4 => True, -- Object_Definition (Node4) + 5 => False), -- Corresponding_Generic_Association (Node5-Sem) + + N_Number_Declaration => + (1 => True, -- Defining_Identifier (Node1) + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => False), -- unused + + N_Derived_Type_Definition => + (1 => False, -- unused + 2 => True, -- Interface_List (List2) + 3 => True, -- Record_Extension_Part (Node3) + 4 => False, -- unused + 5 => True), -- Subtype_Indication (Node5) + + N_Range_Constraint => + (1 => False, -- unused + 2 => False, -- unused + 3 => False, -- unused + 4 => True, -- Range_Expression (Node4) + 5 => False), -- unused + + N_Range => + (1 => True, -- Low_Bound (Node1) + 2 => True, -- High_Bound (Node2) + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- Etype (Node5-Sem) + + N_Enumeration_Type_Definition => + (1 => True, -- Literals (List1) + 2 => False, -- unused + 3 => False, -- unused + 4 => True, -- End_Label (Node4) + 5 => False), -- unused + + N_Defining_Character_Literal => + (1 => True, -- Chars (Name1) + 2 => False, -- Next_Entity (Node2-Sem) + 3 => False, -- Scope (Node3-Sem) + 4 => False, -- unused + 5 => False), -- Etype (Node5-Sem) + + N_Signed_Integer_Type_Definition => + (1 => True, -- Low_Bound (Node1) + 2 => True, -- High_Bound (Node2) + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Modular_Type_Definition => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => False), -- unused + + N_Floating_Point_Definition => + (1 => False, -- unused + 2 => True, -- Digits_Expression (Node2) + 3 => False, -- unused + 4 => True, -- Real_Range_Specification (Node4) + 5 => False), -- unused + + N_Real_Range_Specification => + (1 => True, -- Low_Bound (Node1) + 2 => True, -- High_Bound (Node2) + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Ordinary_Fixed_Point_Definition => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Delta_Expression (Node3) + 4 => True, -- Real_Range_Specification (Node4) + 5 => False), -- unused + + N_Decimal_Fixed_Point_Definition => + (1 => False, -- unused + 2 => True, -- Digits_Expression (Node2) + 3 => True, -- Delta_Expression (Node3) + 4 => True, -- Real_Range_Specification (Node4) + 5 => False), -- unused + + N_Digits_Constraint => + (1 => False, -- unused + 2 => True, -- Digits_Expression (Node2) + 3 => False, -- unused + 4 => True, -- Range_Constraint (Node4) + 5 => False), -- unused + + N_Unconstrained_Array_Definition => + (1 => False, -- unused + 2 => True, -- Subtype_Marks (List2) + 3 => False, -- unused + 4 => True, -- Component_Definition (Node4) + 5 => False), -- unused + + N_Constrained_Array_Definition => + (1 => False, -- unused + 2 => True, -- Discrete_Subtype_Definitions (List2) + 3 => False, -- unused + 4 => True, -- Component_Definition (Node4) + 5 => False), -- unused + + N_Component_Definition => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Access_Definition (Node3) + 4 => False, -- unused + 5 => True), -- Subtype_Indication (Node5) + + N_Discriminant_Specification => + (1 => True, -- Defining_Identifier (Node1) + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => True), -- Discriminant_Type (Node5) + + N_Index_Or_Discriminant_Constraint => + (1 => True, -- Constraints (List1) + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Discriminant_Association => + (1 => True, -- Selector_Names (List1) + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => False), -- unused + + N_Record_Definition => + (1 => True, -- Component_List (Node1) + 2 => True, -- Interface_List (List2) + 3 => False, -- unused + 4 => True, -- End_Label (Node4) + 5 => False), -- unused + + N_Component_List => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Component_Items (List3) + 4 => True, -- Variant_Part (Node4) + 5 => False), -- unused + + N_Component_Declaration => + (1 => True, -- Defining_Identifier (Node1) + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => True, -- Component_Definition (Node4) + 5 => False), -- unused + + N_Variant_Part => + (1 => True, -- Variants (List1) + 2 => True, -- Name (Node2) + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Variant => + (1 => True, -- Component_List (Node1) + 2 => False, -- Enclosing_Variant (Node2-Sem) + 3 => False, -- Present_Expr (Uint3-Sem) + 4 => True, -- Discrete_Choices (List4) + 5 => False), -- Dcheck_Function (Node5-Sem) + + N_Others_Choice => + (1 => False, -- Others_Discrete_Choices (List1-Sem) + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Access_To_Object_Definition => + (1 => False, -- unused + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => True), -- Subtype_Indication (Node5) + + N_Access_Function_Definition => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Parameter_Specifications (List3) + 4 => True, -- Result_Definition (Node4) + 5 => False), -- unused + + N_Access_Procedure_Definition => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Parameter_Specifications (List3) + 4 => False, -- unused + 5 => False), -- unused + + N_Access_Definition => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Access_To_Subprogram_Definition (Node3) + 4 => True, -- Subtype_Mark (Node4) + 5 => False), -- unused + + N_Incomplete_Type_Declaration => + (1 => True, -- Defining_Identifier (Node1) + 2 => False, -- unused + 3 => False, -- unused + 4 => True, -- Discriminant_Specifications (List4) + 5 => False), -- unused + + N_Explicit_Dereference => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Prefix (Node3) + 4 => False, -- Actual_Designated_Subtype (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Indexed_Component => + (1 => True, -- Expressions (List1) + 2 => False, -- unused + 3 => True, -- Prefix (Node3) + 4 => False, -- unused + 5 => False), -- Etype (Node5-Sem) + + N_Slice => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Prefix (Node3) + 4 => True, -- Discrete_Range (Node4) + 5 => False), -- Etype (Node5-Sem) + + N_Selected_Component => + (1 => False, -- unused + 2 => True, -- Selector_Name (Node2) + 3 => True, -- Prefix (Node3) + 4 => False, -- unused + 5 => False), -- Etype (Node5-Sem) + + N_Attribute_Reference => + (1 => True, -- Expressions (List1) + 2 => True, -- Attribute_Name (Name2) + 3 => True, -- Prefix (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Aggregate => + (1 => True, -- Expressions (List1) + 2 => True, -- Component_Associations (List2) + 3 => False, -- Aggregate_Bounds (Node3-Sem) + 4 => False, -- unused + 5 => False), -- Etype (Node5-Sem) + + N_Component_Association => + (1 => True, -- Choices (List1) + 2 => False, -- Loop_Actions (List2-Sem) + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => False), -- unused + + N_Extension_Aggregate => + (1 => True, -- Expressions (List1) + 2 => True, -- Component_Associations (List2) + 3 => True, -- Ancestor_Part (Node3) + 4 => False, -- unused + 5 => False), -- Etype (Node5-Sem) + + N_Null => + (1 => False, -- unused + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- Etype (Node5-Sem) + + N_And_Then => + (1 => False, -- Actions (List1-Sem) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- unused + 5 => False), -- Etype (Node5-Sem) + + N_Or_Else => + (1 => False, -- Actions (List1-Sem) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- unused + 5 => False), -- Etype (Node5-Sem) + + N_In => + (1 => False, -- unused + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => True, -- Alternatives (List4) + 5 => False), -- Etype (Node5-Sem) + + N_Not_In => + (1 => False, -- unused + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => True, -- Alternatives (List4) + 5 => False), -- Etype (Node5-Sem) + + N_Op_And => + (1 => True, -- Chars (Name1) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Or => + (1 => True, -- Chars (Name1) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Xor => + (1 => True, -- Chars (Name1) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Eq => + (1 => True, -- Chars (Name1) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Ne => + (1 => True, -- Chars (Name1) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Lt => + (1 => True, -- Chars (Name1) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Le => + (1 => True, -- Chars (Name1) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Gt => + (1 => True, -- Chars (Name1) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Ge => + (1 => True, -- Chars (Name1) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Add => + (1 => True, -- Chars (Name1) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Subtract => + (1 => True, -- Chars (Name1) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Concat => + (1 => True, -- Chars (Name1) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Multiply => + (1 => True, -- Chars (Name1) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Divide => + (1 => True, -- Chars (Name1) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Mod => + (1 => True, -- Chars (Name1) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Rem => + (1 => True, -- Chars (Name1) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Expon => + (1 => True, -- Chars (Name1) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Plus => + (1 => True, -- Chars (Name1) + 2 => False, -- unused + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Minus => + (1 => True, -- Chars (Name1) + 2 => False, -- unused + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Abs => + (1 => True, -- Chars (Name1) + 2 => False, -- unused + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Not => + (1 => True, -- Chars (Name1) + 2 => False, -- unused + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Type_Conversion => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => True, -- Subtype_Mark (Node4) + 5 => False), -- Etype (Node5-Sem) + + N_Qualified_Expression => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => True, -- Subtype_Mark (Node4) + 5 => False), -- Etype (Node5-Sem) + + N_Quantified_Expression => + (1 => True, -- Condition (Node1) + 2 => True, -- Iterator_Specification + 3 => False, -- unused + 4 => True, -- Loop_Parameter_Specification (Node4) + 5 => False), -- Etype (Node5-Sem) + + N_Allocator => + (1 => False, -- Storage_Pool (Node1-Sem) + 2 => False, -- Procedure_To_Call (Node2-Sem) + 3 => True, -- Expression (Node3) + 4 => False, -- Coextensions (Elist4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Null_Statement => + (1 => False, -- unused + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Label => + (1 => True, -- Identifier (Node1) + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Assignment_Statement => + (1 => False, -- unused + 2 => True, -- Name (Node2) + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => False), -- unused + + N_If_Statement => + (1 => True, -- Condition (Node1) + 2 => True, -- Then_Statements (List2) + 3 => True, -- Elsif_Parts (List3) + 4 => True, -- Else_Statements (List4) + 5 => True), -- End_Span (Uint5) + + N_Elsif_Part => + (1 => True, -- Condition (Node1) + 2 => True, -- Then_Statements (List2) + 3 => False, -- Condition_Actions (List3-Sem) + 4 => False, -- unused + 5 => False), -- unused + + N_Case_Expression => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => True, -- Alternatives (List4) + 5 => False), -- unused + + N_Case_Expression_Alternative => + (1 => False, -- Actions (List1-Sem) + 2 => False, -- unused + 3 => True, -- Statements (List3) + 4 => True, -- Expression (Node4) + 5 => False), -- unused + + N_Case_Statement => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => True, -- Alternatives (List4) + 5 => True), -- End_Span (Uint5) + + N_Case_Statement_Alternative => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Statements (List3) + 4 => True, -- Discrete_Choices (List4) + 5 => False), -- unused + + N_Loop_Statement => + (1 => True, -- Identifier (Node1) + 2 => True, -- Iteration_Scheme (Node2) + 3 => True, -- Statements (List3) + 4 => True, -- End_Label (Node4) + 5 => False), -- unused + + N_Iteration_Scheme => + (1 => True, -- Condition (Node1) + 2 => True, -- Iterator_Specification (Node2) + 3 => False, -- Condition_Actions (List3-Sem) + 4 => True, -- Loop_Parameter_Specification (Node4) + 5 => False), -- unused + + N_Loop_Parameter_Specification => + (1 => True, -- Defining_Identifier (Node1) + 2 => False, -- unused + 3 => False, -- unused + 4 => True, -- Discrete_Subtype_Definition (Node4) + 5 => False), -- unused + + N_Iterator_Specification => + (1 => True, -- Defining_Identifier (Node1) + 2 => True, -- Name (Node2) + 3 => False, -- Unused + 4 => False, -- Unused + 5 => True), -- Subtype_Indication (Node5) + + N_Block_Statement => + (1 => True, -- Identifier (Node1) + 2 => True, -- Declarations (List2) + 3 => False, -- Activation_Chain_Entity (Node3-Sem) + 4 => True, -- Handled_Statement_Sequence (Node4) + 5 => False), -- unused + + N_Exit_Statement => + (1 => True, -- Condition (Node1) + 2 => True, -- Name (Node2) + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Goto_Statement => + (1 => False, -- unused + 2 => True, -- Name (Node2) + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Subprogram_Declaration => + (1 => True, -- Specification (Node1) + 2 => False, -- unused + 3 => False, -- Body_To_Inline (Node3-Sem) + 4 => False, -- Parent_Spec (Node4-Sem) + 5 => False), -- Corresponding_Body (Node5-Sem) + + N_Abstract_Subprogram_Declaration => + (1 => True, -- Specification (Node1) + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Function_Specification => + (1 => True, -- Defining_Unit_Name (Node1) + 2 => False, -- Elaboration_Boolean (Node2-Sem) + 3 => True, -- Parameter_Specifications (List3) + 4 => True, -- Result_Definition (Node4) + 5 => False), -- Generic_Parent (Node5-Sem) + + N_Procedure_Specification => + (1 => True, -- Defining_Unit_Name (Node1) + 2 => False, -- Elaboration_Boolean (Node2-Sem) + 3 => True, -- Parameter_Specifications (List3) + 4 => False, -- unused + 5 => False), -- Generic_Parent (Node5-Sem) + + N_Designator => + (1 => True, -- Identifier (Node1) + 2 => True, -- Name (Node2) + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Defining_Program_Unit_Name => + (1 => True, -- Defining_Identifier (Node1) + 2 => True, -- Name (Node2) + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Operator_Symbol => + (1 => True, -- Chars (Name1) + 2 => False, -- unused + 3 => True, -- Strval (Str3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Defining_Operator_Symbol => + (1 => True, -- Chars (Name1) + 2 => False, -- Next_Entity (Node2-Sem) + 3 => False, -- Scope (Node3-Sem) + 4 => False, -- unused + 5 => False), -- Etype (Node5-Sem) + + N_Parameter_Specification => + (1 => True, -- Defining_Identifier (Node1) + 2 => True, -- Parameter_Type (Node2) + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => False), -- Default_Expression (Node5-Sem) + + N_Subprogram_Body => + (1 => True, -- Specification (Node1) + 2 => True, -- Declarations (List2) + 3 => False, -- Activation_Chain_Entity (Node3-Sem) + 4 => True, -- Handled_Statement_Sequence (Node4) + 5 => False), -- Corresponding_Spec (Node5-Sem) + + N_Parameterized_Expression => + (1 => True, -- Specification (Node1) + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => False), -- unused + + N_Procedure_Call_Statement => + (1 => False, -- Controlling_Argument (Node1-Sem) + 2 => True, -- Name (Node2) + 3 => True, -- Parameter_Associations (List3) + 4 => False, -- First_Named_Actual (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Function_Call => + (1 => False, -- Controlling_Argument (Node1-Sem) + 2 => True, -- Name (Node2) + 3 => True, -- Parameter_Associations (List3) + 4 => False, -- First_Named_Actual (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Parameter_Association => + (1 => False, -- unused + 2 => True, -- Selector_Name (Node2) + 3 => True, -- Explicit_Actual_Parameter (Node3) + 4 => False, -- Next_Named_Actual (Node4-Sem) + 5 => False), -- unused + + N_Return_Statement => + (1 => False, -- Storage_Pool (Node1-Sem) + 2 => False, -- Procedure_To_Call (Node2-Sem) + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => False), -- Return_Statement_Entity (Node5-Sem) + + N_Extended_Return_Statement => + (1 => False, -- Storage_Pool (Node1-Sem) + 2 => False, -- Procedure_To_Call (Node2-Sem) + 3 => True, -- Return_Object_Declarations (List3) + 4 => True, -- Handled_Statement_Sequence (Node4) + 5 => False), -- Return_Statement_Entity (Node5-Sem) + + N_Package_Declaration => + (1 => True, -- Specification (Node1) + 2 => False, -- unused + 3 => False, -- Activation_Chain_Entity (Node3-Sem) + 4 => False, -- Parent_Spec (Node4-Sem) + 5 => False), -- Corresponding_Body (Node5-Sem) + + N_Package_Specification => + (1 => True, -- Defining_Unit_Name (Node1) + 2 => True, -- Visible_Declarations (List2) + 3 => True, -- Private_Declarations (List3) + 4 => True, -- End_Label (Node4) + 5 => False), -- Generic_Parent (Node5-Sem) + + N_Package_Body => + (1 => True, -- Defining_Unit_Name (Node1) + 2 => True, -- Declarations (List2) + 3 => False, -- unused + 4 => True, -- Handled_Statement_Sequence (Node4) + 5 => False), -- Corresponding_Spec (Node5-Sem) + + N_Private_Type_Declaration => + (1 => True, -- Defining_Identifier (Node1) + 2 => False, -- unused + 3 => False, -- unused + 4 => True, -- Discriminant_Specifications (List4) + 5 => False), -- unused + + N_Private_Extension_Declaration => + (1 => True, -- Defining_Identifier (Node1) + 2 => True, -- Interface_List (List2) + 3 => False, -- unused + 4 => True, -- Discriminant_Specifications (List4) + 5 => True), -- Subtype_Indication (Node5) + + N_Use_Package_Clause => + (1 => False, -- unused + 2 => True, -- Names (List2) + 3 => False, -- Next_Use_Clause (Node3-Sem) + 4 => False, -- Hidden_By_Use_Clause (Elist4-Sem) + 5 => False), -- unused + + N_Use_Type_Clause => + (1 => False, -- unused + 2 => True, -- Subtype_Marks (List2) + 3 => False, -- Next_Use_Clause (Node3-Sem) + 4 => False, -- Hidden_By_Use_Clause (Elist4-Sem) + 5 => False), -- unused + + N_Object_Renaming_Declaration => + (1 => True, -- Defining_Identifier (Node1) + 2 => True, -- Name (Node2) + 3 => True, -- Access_Definition (Node3) + 4 => True, -- Subtype_Mark (Node4) + 5 => False), -- Corresponding_Generic_Association (Node5-Sem) + + N_Exception_Renaming_Declaration => + (1 => True, -- Defining_Identifier (Node1) + 2 => True, -- Name (Node2) + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Package_Renaming_Declaration => + (1 => True, -- Defining_Unit_Name (Node1) + 2 => True, -- Name (Node2) + 3 => False, -- unused + 4 => False, -- Parent_Spec (Node4-Sem) + 5 => False), -- unused + + N_Subprogram_Renaming_Declaration => + (1 => True, -- Specification (Node1) + 2 => True, -- Name (Node2) + 3 => False, -- Corresponding_Formal_Spec (Node3-Sem) + 4 => False, -- Parent_Spec (Node4-Sem) + 5 => False), -- Corresponding_Spec (Node5-Sem) + + N_Generic_Package_Renaming_Declaration => + (1 => True, -- Defining_Unit_Name (Node1) + 2 => True, -- Name (Node2) + 3 => False, -- unused + 4 => False, -- Parent_Spec (Node4-Sem) + 5 => False), -- unused + + N_Generic_Procedure_Renaming_Declaration => + (1 => True, -- Defining_Unit_Name (Node1) + 2 => True, -- Name (Node2) + 3 => False, -- unused + 4 => False, -- Parent_Spec (Node4-Sem) + 5 => False), -- unused + + N_Generic_Function_Renaming_Declaration => + (1 => True, -- Defining_Unit_Name (Node1) + 2 => True, -- Name (Node2) + 3 => False, -- unused + 4 => False, -- Parent_Spec (Node4-Sem) + 5 => False), -- unused + + N_Task_Type_Declaration => + (1 => True, -- Defining_Identifier (Node1) + 2 => True, -- Interface_List (List2) + 3 => True, -- Task_Definition (Node3) + 4 => True, -- Discriminant_Specifications (List4) + 5 => False), -- Corresponding_Body (Node5-Sem) + + N_Single_Task_Declaration => + (1 => True, -- Defining_Identifier (Node1) + 2 => True, -- Interface_List (List2) + 3 => True, -- Task_Definition (Node3) + 4 => False, -- unused + 5 => False), -- unused + + N_Task_Definition => + (1 => False, -- unused + 2 => True, -- Visible_Declarations (List2) + 3 => True, -- Private_Declarations (List3) + 4 => True, -- End_Label (Node4) + 5 => False), -- unused + + N_Task_Body => + (1 => True, -- Defining_Identifier (Node1) + 2 => True, -- Declarations (List2) + 3 => False, -- Activation_Chain_Entity (Node3-Sem) + 4 => True, -- Handled_Statement_Sequence (Node4) + 5 => False), -- Corresponding_Spec (Node5-Sem) + + N_Protected_Type_Declaration => + (1 => True, -- Defining_Identifier (Node1) + 2 => True, -- Interface_List (List2) + 3 => True, -- Protected_Definition (Node3) + 4 => True, -- Discriminant_Specifications (List4) + 5 => False), -- Corresponding_Body (Node5-Sem) + + N_Single_Protected_Declaration => + (1 => True, -- Defining_Identifier (Node1) + 2 => True, -- Interface_List (List2) + 3 => True, -- Protected_Definition (Node3) + 4 => False, -- unused + 5 => False), -- unused + + N_Protected_Definition => + (1 => False, -- unused + 2 => True, -- Visible_Declarations (List2) + 3 => True, -- Private_Declarations (List3) + 4 => True, -- End_Label (Node4) + 5 => False), -- unused + + N_Protected_Body => + (1 => True, -- Defining_Identifier (Node1) + 2 => True, -- Declarations (List2) + 3 => False, -- unused + 4 => True, -- End_Label (Node4) + 5 => False), -- Corresponding_Spec (Node5-Sem) + + N_Entry_Declaration => + (1 => True, -- Defining_Identifier (Node1) + 2 => False, -- unused + 3 => True, -- Parameter_Specifications (List3) + 4 => True, -- Discrete_Subtype_Definition (Node4) + 5 => False), -- Corresponding_Body (Node5-Sem) + + N_Accept_Statement => + (1 => True, -- Entry_Direct_Name (Node1) + 2 => True, -- Declarations (List2) + 3 => True, -- Parameter_Specifications (List3) + 4 => True, -- Handled_Statement_Sequence (Node4) + 5 => True), -- Entry_Index (Node5) + + N_Entry_Body => + (1 => True, -- Defining_Identifier (Node1) + 2 => True, -- Declarations (List2) + 3 => False, -- Activation_Chain_Entity (Node3-Sem) + 4 => True, -- Handled_Statement_Sequence (Node4) + 5 => True), -- Entry_Body_Formal_Part (Node5) + + N_Entry_Body_Formal_Part => + (1 => True, -- Condition (Node1) + 2 => False, -- unused + 3 => True, -- Parameter_Specifications (List3) + 4 => True, -- Entry_Index_Specification (Node4) + 5 => False), -- unused + + N_Entry_Index_Specification => + (1 => True, -- Defining_Identifier (Node1) + 2 => False, -- unused + 3 => False, -- unused + 4 => True, -- Discrete_Subtype_Definition (Node4) + 5 => False), -- unused + + N_Entry_Call_Statement => + (1 => False, -- unused + 2 => True, -- Name (Node2) + 3 => True, -- Parameter_Associations (List3) + 4 => False, -- First_Named_Actual (Node4-Sem) + 5 => False), -- unused + + N_Requeue_Statement => + (1 => False, -- unused + 2 => True, -- Name (Node2) + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Delay_Until_Statement => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => False), -- unused + + N_Delay_Relative_Statement => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => False), -- unused + + N_Selective_Accept => + (1 => True, -- Select_Alternatives (List1) + 2 => False, -- unused + 3 => False, -- unused + 4 => True, -- Else_Statements (List4) + 5 => False), -- unused + + N_Accept_Alternative => + (1 => True, -- Condition (Node1) + 2 => True, -- Accept_Statement (Node2) + 3 => True, -- Statements (List3) + 4 => True, -- Pragmas_Before (List4) + 5 => False), -- Accept_Handler_Records (List5-Sem) + + N_Delay_Alternative => + (1 => True, -- Condition (Node1) + 2 => True, -- Delay_Statement (Node2) + 3 => True, -- Statements (List3) + 4 => True, -- Pragmas_Before (List4) + 5 => False), -- unused + + N_Terminate_Alternative => + (1 => True, -- Condition (Node1) + 2 => False, -- unused + 3 => False, -- unused + 4 => True, -- Pragmas_Before (List4) + 5 => True), -- Pragmas_After (List5) + + N_Timed_Entry_Call => + (1 => True, -- Entry_Call_Alternative (Node1) + 2 => False, -- unused + 3 => False, -- unused + 4 => True, -- Delay_Alternative (Node4) + 5 => False), -- unused + + N_Entry_Call_Alternative => + (1 => True, -- Entry_Call_Statement (Node1) + 2 => False, -- unused + 3 => True, -- Statements (List3) + 4 => True, -- Pragmas_Before (List4) + 5 => False), -- unused + + N_Conditional_Entry_Call => + (1 => True, -- Entry_Call_Alternative (Node1) + 2 => False, -- unused + 3 => False, -- unused + 4 => True, -- Else_Statements (List4) + 5 => False), -- unused + + N_Asynchronous_Select => + (1 => True, -- Triggering_Alternative (Node1) + 2 => True, -- Abortable_Part (Node2) + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Triggering_Alternative => + (1 => True, -- Triggering_Statement (Node1) + 2 => False, -- unused + 3 => True, -- Statements (List3) + 4 => True, -- Pragmas_Before (List4) + 5 => False), -- unused + + N_Abortable_Part => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Statements (List3) + 4 => False, -- unused + 5 => False), -- unused + + N_Abort_Statement => + (1 => False, -- unused + 2 => True, -- Names (List2) + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Compilation_Unit => + (1 => True, -- Context_Items (List1) + 2 => True, -- Unit (Node2) + 3 => False, -- First_Inlined_Subprogram (Node3-Sem) + 4 => False, -- Library_Unit (Node4-Sem) + 5 => True), -- Aux_Decls_Node (Node5) + + N_Compilation_Unit_Aux => + (1 => True, -- Actions (List1) + 2 => True, -- Declarations (List2) + 3 => False, -- Default_Storage_Pool (Node3) + 4 => True, -- Config_Pragmas (List4) + 5 => True), -- Pragmas_After (List5) + + N_With_Clause => + (1 => False, -- unused + 2 => True, -- Name (Node2) + 3 => False, -- unused + 4 => False, -- Library_Unit (Node4-Sem) + 5 => False), -- Corresponding_Spec (Node5-Sem) + + N_Subprogram_Body_Stub => + (1 => True, -- Specification (Node1) + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- Library_Unit (Node4-Sem) + 5 => False), -- Corresponding_Body (Node5-Sem) + + N_Package_Body_Stub => + (1 => True, -- Defining_Identifier (Node1) + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- Library_Unit (Node4-Sem) + 5 => False), -- Corresponding_Body (Node5-Sem) + + N_Task_Body_Stub => + (1 => True, -- Defining_Identifier (Node1) + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- Library_Unit (Node4-Sem) + 5 => False), -- Corresponding_Body (Node5-Sem) + + N_Protected_Body_Stub => + (1 => True, -- Defining_Identifier (Node1) + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- Library_Unit (Node4-Sem) + 5 => False), -- Corresponding_Body (Node5-Sem) + + N_Subunit => + (1 => True, -- Proper_Body (Node1) + 2 => True, -- Name (Node2) + 3 => False, -- Corresponding_Stub (Node3-Sem) + 4 => False, -- unused + 5 => False), -- unused + + N_Exception_Declaration => + (1 => True, -- Defining_Identifier (Node1) + 2 => False, -- unused + 3 => False, -- Expression (Node3-Sem) + 4 => False, -- unused + 5 => False), -- unused + + N_Handled_Sequence_Of_Statements => + (1 => True, -- At_End_Proc (Node1) + 2 => False, -- First_Real_Statement (Node2-Sem) + 3 => True, -- Statements (List3) + 4 => True, -- End_Label (Node4) + 5 => True), -- Exception_Handlers (List5) + + N_Exception_Handler => + (1 => False, -- Local_Raise_Statements (Elist1) + 2 => True, -- Choice_Parameter (Node2) + 3 => True, -- Statements (List3) + 4 => True, -- Exception_Choices (List4) + 5 => False), -- Exception_Label (Node5) + + N_Raise_Statement => + (1 => False, -- unused + 2 => True, -- Name (Node2) + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => False), -- unused + + N_Generic_Subprogram_Declaration => + (1 => True, -- Specification (Node1) + 2 => True, -- Generic_Formal_Declarations (List2) + 3 => False, -- unused + 4 => False, -- Parent_Spec (Node4-Sem) + 5 => False), -- Corresponding_Body (Node5-Sem) + + N_Generic_Package_Declaration => + (1 => True, -- Specification (Node1) + 2 => True, -- Generic_Formal_Declarations (List2) + 3 => False, -- Activation_Chain_Entity (Node3-Sem) + 4 => False, -- Parent_Spec (Node4-Sem) + 5 => False), -- Corresponding_Body (Node5-Sem) + + N_Package_Instantiation => + (1 => True, -- Defining_Unit_Name (Node1) + 2 => True, -- Name (Node2) + 3 => True, -- Generic_Associations (List3) + 4 => False, -- Parent_Spec (Node4-Sem) + 5 => False), -- Instance_Spec (Node5-Sem) + + N_Procedure_Instantiation => + (1 => True, -- Defining_Unit_Name (Node1) + 2 => True, -- Name (Node2) + 3 => True, -- Generic_Associations (List3) + 4 => False, -- Parent_Spec (Node4-Sem) + 5 => False), -- Instance_Spec (Node5-Sem) + + N_Function_Instantiation => + (1 => True, -- Defining_Unit_Name (Node1) + 2 => True, -- Name (Node2) + 3 => True, -- Generic_Associations (List3) + 4 => False, -- Parent_Spec (Node4-Sem) + 5 => False), -- Instance_Spec (Node5-Sem) + + N_Generic_Association => + (1 => True, -- Explicit_Generic_Actual_Parameter (Node1) + 2 => True, -- Selector_Name (Node2) + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Formal_Object_Declaration => + (1 => True, -- Defining_Identifier (Node1) + 2 => False, -- unused + 3 => True, -- Access_Definition (Node3) + 4 => True, -- Subtype_Mark (Node4) + 5 => True), -- Default_Expression (Node5) + + N_Formal_Type_Declaration => + (1 => True, -- Defining_Identifier (Node1) + 2 => False, -- unused + 3 => True, -- Formal_Type_Definition (Node3) + 4 => True, -- Discriminant_Specifications (List4) + 5 => False), -- unused + + N_Formal_Private_Type_Definition => + (1 => False, -- unused + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Formal_Derived_Type_Definition => + (1 => False, -- unused + 2 => True, -- Interface_List (List2) + 3 => False, -- unused + 4 => True, -- Subtype_Mark (Node4) + 5 => False), -- unused + + N_Formal_Discrete_Type_Definition => + (1 => False, -- unused + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Formal_Signed_Integer_Type_Definition => + (1 => False, -- unused + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Formal_Modular_Type_Definition => + (1 => False, -- unused + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Formal_Floating_Point_Definition => + (1 => False, -- unused + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Formal_Ordinary_Fixed_Point_Definition => + (1 => False, -- unused + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Formal_Decimal_Fixed_Point_Definition => + (1 => False, -- unused + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Formal_Concrete_Subprogram_Declaration => + (1 => True, -- Specification (Node1) + 2 => True, -- Default_Name (Node2) + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Formal_Abstract_Subprogram_Declaration => + (1 => True, -- Specification (Node1) + 2 => True, -- Default_Name (Node2) + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Formal_Package_Declaration => + (1 => True, -- Defining_Identifier (Node1) + 2 => True, -- Name (Node2) + 3 => True, -- Generic_Associations (List3) + 4 => False, -- unused + 5 => False), -- Instance_Spec (Node5-Sem) + + N_Attribute_Definition_Clause => + (1 => True, -- Chars (Name1) + 2 => True, -- Name (Node2) + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => False), -- Next_Rep_Item (Node5-Sem) + + N_Aspect_Specification => + (1 => True, -- Identifier (Node1) + 2 => False, -- Aspect_Rep_Item (Node2-Sem) + 3 => True, -- Expression (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Next_Rep_Item (Node5-Sem) + + N_Enumeration_Representation_Clause => + (1 => True, -- Identifier (Node1) + 2 => False, -- unused + 3 => True, -- Array_Aggregate (Node3) + 4 => False, -- unused + 5 => False), -- Next_Rep_Item (Node5-Sem) + + N_Record_Representation_Clause => + (1 => True, -- Identifier (Node1) + 2 => True, -- Mod_Clause (Node2) + 3 => True, -- Component_Clauses (List3) + 4 => False, -- unused + 5 => False), -- Next_Rep_Item (Node5-Sem) + + N_Component_Clause => + (1 => True, -- Component_Name (Node1) + 2 => True, -- Position (Node2) + 3 => True, -- First_Bit (Node3) + 4 => True, -- Last_Bit (Node4) + 5 => False), -- unused + + N_Code_Statement => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => False), -- unused + + N_Op_Rotate_Left => + (1 => True, -- Chars (Name1) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Rotate_Right => + (1 => True, -- Chars (Name1) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Shift_Left => + (1 => True, -- Chars (Name1) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Shift_Right_Arithmetic => + (1 => True, -- Chars (Name1) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Op_Shift_Right => + (1 => True, -- Chars (Name1) + 2 => True, -- Left_Opnd (Node2) + 3 => True, -- Right_Opnd (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Delta_Constraint => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Delta_Expression (Node3) + 4 => True, -- Range_Constraint (Node4) + 5 => False), -- unused + + N_At_Clause => + (1 => True, -- Identifier (Node1) + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => False), -- unused + + N_Mod_Clause => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => True, -- Pragmas_Before (List4) + 5 => False), -- unused + + N_Conditional_Expression => + (1 => True, -- Expressions (List1) + 2 => False, -- Then_Actions (List2-Sem) + 3 => False, -- Else_Actions (List3-Sem) + 4 => False, -- unused + 5 => False), -- Etype (Node5-Sem) + + N_Expanded_Name => + (1 => True, -- Chars (Name1) + 2 => True, -- Selector_Name (Node2) + 3 => True, -- Prefix (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Etype (Node5-Sem) + + N_Expression_With_Actions => + (1 => True, -- Actions (List1) + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => False), -- unused + + N_Free_Statement => + (1 => False, -- Storage_Pool (Node1-Sem) + 2 => False, -- Procedure_To_Call (Node2-Sem) + 3 => True, -- Expression (Node3) + 4 => False, -- Actual_Designated_Subtype (Node4-Sem) + 5 => False), -- unused + + N_Freeze_Entity => + (1 => True, -- Actions (List1) + 2 => False, -- Access_Types_To_Process (Elist2-Sem) + 3 => False, -- TSS_Elist (Elist3-Sem) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- First_Subtype_Link (Node5-Sem) + + N_Implicit_Label_Declaration => + (1 => True, -- Defining_Identifier (Node1) + 2 => False, -- Label_Construct (Node2-Sem) + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Itype_Reference => + (1 => False, -- Itype (Node1-Sem) + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Raise_Constraint_Error => + (1 => True, -- Condition (Node1) + 2 => False, -- unused + 3 => True, -- Reason (Uint3) + 4 => False, -- unused + 5 => False), -- Etype (Node5-Sem) + + N_Raise_Program_Error => + (1 => True, -- Condition (Node1) + 2 => False, -- unused + 3 => True, -- Reason (Uint3) + 4 => False, -- unused + 5 => False), -- Etype (Node5-Sem) + + N_Raise_Storage_Error => + (1 => True, -- Condition (Node1) + 2 => False, -- unused + 3 => True, -- Reason (Uint3) + 4 => False, -- unused + 5 => False), -- Etype (Node5-Sem) + + N_Push_Constraint_Error_Label => + (1 => False, -- unused + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Push_Program_Error_Label => + (1 => False, -- Exception_Label + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- Exception_Label + + N_Push_Storage_Error_Label => + (1 => False, -- Exception_Label + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- Exception_Label + + N_Pop_Constraint_Error_Label => + (1 => False, -- unused + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Pop_Program_Error_Label => + (1 => False, -- unused + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Pop_Storage_Error_Label => + (1 => False, -- unused + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Reference => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Prefix (Node3) + 4 => False, -- unused + 5 => False), -- Etype (Node5-Sem) + + N_Subprogram_Info => + (1 => True, -- Identifier (Node1) + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- Etype (Node5-Sem) + + N_Unchecked_Expression => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => False), -- Etype (Node5-Sem) + + N_Unchecked_Type_Conversion => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => True, -- Subtype_Mark (Node4) + 5 => False), -- Etype (Node5-Sem) + + N_Validate_Unchecked_Conversion => + (1 => False, -- Source_Type (Node1-Sem) + 2 => False, -- Target_Type (Node2-Sem) + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + -- Entries for SCIL nodes + + N_SCIL_Dispatch_Table_Tag_Init => + (1 => False, -- unused + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- SCIL_Entity (Node4-Sem) + 5 => False), -- unused + + N_SCIL_Dispatching_Call => + (1 => False, -- unused + 2 => False, -- SCIL_Target_Prim (Node2-Sem) + 3 => False, -- unused + 4 => False, -- SCIL_Entity (Node4-Sem) + 5 => False), -- SCIL_Controlling_Tag (Node5-Sem) + + N_SCIL_Membership_Test => + (1 => False, -- unused + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- SCIL_Entity (Node4-Sem) + 5 => False), -- SCIL_Tag_Value (Node5-Sem) + + -- Entries for Empty, Error and Unused. Even thought these have a Chars + -- field for debugging purposes, they are not really syntactic fields, so + -- we mark all fields as unused. + + N_Empty => + (1 => False, -- unused + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Error => + (1 => False, -- unused + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Unused_At_Start => + (1 => False, -- unused + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + + N_Unused_At_End => + (1 => False, -- unused + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False)); -- unused + + -------------------- + -- Inline Pragmas -- + -------------------- + + pragma Inline (ABE_Is_Certain); + pragma Inline (Abort_Present); + pragma Inline (Abortable_Part); + pragma Inline (Abstract_Present); + pragma Inline (Accept_Handler_Records); + pragma Inline (Accept_Statement); + pragma Inline (Access_Definition); + pragma Inline (Access_To_Subprogram_Definition); + pragma Inline (Access_Types_To_Process); + pragma Inline (Actions); + pragma Inline (Activation_Chain_Entity); + pragma Inline (Acts_As_Spec); + pragma Inline (Actual_Designated_Subtype); + pragma Inline (Address_Warning_Posted); + pragma Inline (Aggregate_Bounds); + pragma Inline (Aliased_Present); + pragma Inline (All_Others); + pragma Inline (All_Present); + pragma Inline (Alternatives); + pragma Inline (Ancestor_Part); + pragma Inline (Array_Aggregate); + pragma Inline (Aspect_Cancel); + pragma Inline (Aspect_Rep_Item); + pragma Inline (Assignment_OK); + pragma Inline (Associated_Node); + pragma Inline (At_End_Proc); + pragma Inline (Attribute_Name); + pragma Inline (Aux_Decls_Node); + pragma Inline (Backwards_OK); + pragma Inline (Bad_Is_Detected); + pragma Inline (Body_To_Inline); + pragma Inline (Body_Required); + pragma Inline (By_Ref); + pragma Inline (Box_Present); + pragma Inline (Char_Literal_Value); + pragma Inline (Chars); + pragma Inline (Check_Address_Alignment); + pragma Inline (Choice_Parameter); + pragma Inline (Choices); + pragma Inline (Class_Present); + pragma Inline (Coextensions); + pragma Inline (Comes_From_Extended_Return_Statement); + pragma Inline (Compile_Time_Known_Aggregate); + pragma Inline (Component_Associations); + pragma Inline (Component_Clauses); + pragma Inline (Component_Definition); + pragma Inline (Component_Items); + pragma Inline (Component_List); + pragma Inline (Component_Name); + pragma Inline (Componentwise_Assignment); + pragma Inline (Condition); + pragma Inline (Condition_Actions); + pragma Inline (Config_Pragmas); + pragma Inline (Constant_Present); + pragma Inline (Constraint); + pragma Inline (Constraints); + pragma Inline (Context_Installed); + pragma Inline (Context_Items); + pragma Inline (Context_Pending); + pragma Inline (Controlling_Argument); + pragma Inline (Conversion_OK); + pragma Inline (Corresponding_Body); + pragma Inline (Corresponding_Formal_Spec); + pragma Inline (Corresponding_Generic_Association); + pragma Inline (Corresponding_Integer_Value); + pragma Inline (Corresponding_Spec); + pragma Inline (Corresponding_Stub); + pragma Inline (Dcheck_Function); + pragma Inline (Debug_Statement); + pragma Inline (Declarations); + pragma Inline (Default_Expression); + pragma Inline (Default_Storage_Pool); + pragma Inline (Default_Name); + pragma Inline (Defining_Identifier); + pragma Inline (Defining_Unit_Name); + pragma Inline (Delay_Alternative); + pragma Inline (Delay_Statement); + pragma Inline (Delta_Expression); + pragma Inline (Digits_Expression); + pragma Inline (Discr_Check_Funcs_Built); + pragma Inline (Discrete_Choices); + pragma Inline (Discrete_Range); + pragma Inline (Discrete_Subtype_Definition); + pragma Inline (Discrete_Subtype_Definitions); + pragma Inline (Discriminant_Specifications); + pragma Inline (Discriminant_Type); + pragma Inline (Do_Accessibility_Check); + pragma Inline (Do_Discriminant_Check); + pragma Inline (Do_Length_Check); + pragma Inline (Do_Division_Check); + pragma Inline (Do_Overflow_Check); + pragma Inline (Do_Range_Check); + pragma Inline (Do_Storage_Check); + pragma Inline (Do_Tag_Check); + pragma Inline (Elaborate_Present); + pragma Inline (Elaborate_All_Desirable); + pragma Inline (Elaborate_All_Present); + pragma Inline (Elaborate_Desirable); + pragma Inline (Elaboration_Boolean); + pragma Inline (Else_Actions); + pragma Inline (Else_Statements); + pragma Inline (Elsif_Parts); + pragma Inline (Enclosing_Variant); + pragma Inline (End_Label); + pragma Inline (End_Span); + pragma Inline (Entity); + pragma Inline (Entity_Or_Associated_Node); + pragma Inline (Entry_Body_Formal_Part); + pragma Inline (Entry_Call_Alternative); + pragma Inline (Entry_Call_Statement); + pragma Inline (Entry_Direct_Name); + pragma Inline (Entry_Index); + pragma Inline (Entry_Index_Specification); + pragma Inline (Etype); + pragma Inline (Exception_Choices); + pragma Inline (Exception_Handlers); + pragma Inline (Exception_Junk); + pragma Inline (Exception_Label); + pragma Inline (Expansion_Delayed); + pragma Inline (Explicit_Actual_Parameter); + pragma Inline (Explicit_Generic_Actual_Parameter); + pragma Inline (Expression); + pragma Inline (Expressions); + pragma Inline (First_Bit); + pragma Inline (First_Inlined_Subprogram); + pragma Inline (First_Name); + pragma Inline (First_Named_Actual); + pragma Inline (First_Real_Statement); + pragma Inline (First_Subtype_Link); + pragma Inline (Float_Truncate); + pragma Inline (Formal_Type_Definition); + pragma Inline (Forwards_OK); + pragma Inline (From_Aspect_Specification); + pragma Inline (From_At_End); + pragma Inline (From_At_Mod); + pragma Inline (From_Default); + pragma Inline (Generic_Associations); + pragma Inline (Generic_Formal_Declarations); + pragma Inline (Generic_Parent); + pragma Inline (Generic_Parent_Type); + pragma Inline (Handled_Statement_Sequence); + pragma Inline (Handler_List_Entry); + pragma Inline (Has_Created_Identifier); + pragma Inline (Has_Dynamic_Length_Check); + pragma Inline (Has_Dynamic_Range_Check); + pragma Inline (Has_Init_Expression); + pragma Inline (Has_Local_Raise); + pragma Inline (Has_Self_Reference); + pragma Inline (Has_No_Elaboration_Code); + pragma Inline (Has_Pragma_CPU); + pragma Inline (Has_Pragma_Priority); + pragma Inline (Has_Pragma_Suppress_All); + pragma Inline (Has_Private_View); + pragma Inline (Has_Relative_Deadline_Pragma); + pragma Inline (Has_Storage_Size_Pragma); + pragma Inline (Has_Task_Info_Pragma); + pragma Inline (Has_Task_Name_Pragma); + pragma Inline (Has_Wide_Character); + pragma Inline (Has_Wide_Wide_Character); + pragma Inline (Hidden_By_Use_Clause); + pragma Inline (High_Bound); + pragma Inline (Identifier); + pragma Inline (Implicit_With); + pragma Inline (Interface_List); + pragma Inline (Interface_Present); + pragma Inline (Includes_Infinities); + pragma Inline (Import_Interface_Present); + pragma Inline (In_Present); + pragma Inline (Inherited_Discriminant); + pragma Inline (Instance_Spec); + pragma Inline (Intval); + pragma Inline (Iterator_Specification); + pragma Inline (Is_Accessibility_Actual); + pragma Inline (Is_Asynchronous_Call_Block); + pragma Inline (Is_Component_Left_Opnd); + pragma Inline (Is_Component_Right_Opnd); + pragma Inline (Is_Controlling_Actual); + pragma Inline (Is_Delayed_Aspect); + pragma Inline (Is_Dynamic_Coextension); + pragma Inline (Is_Elsif); + pragma Inline (Is_Entry_Barrier_Function); + pragma Inline (Is_Expanded_Build_In_Place_Call); + pragma Inline (Is_Folded_In_Parser); + pragma Inline (Is_In_Discriminant_Check); + pragma Inline (Is_Machine_Number); + pragma Inline (Is_Null_Loop); + pragma Inline (Is_Overloaded); + pragma Inline (Is_Power_Of_2_For_Shift); + pragma Inline (Is_Protected_Subprogram_Body); + pragma Inline (Is_Static_Coextension); + pragma Inline (Is_Static_Expression); + pragma Inline (Is_Subprogram_Descriptor); + pragma Inline (Is_Task_Allocation_Block); + pragma Inline (Is_Task_Master); + pragma Inline (Iteration_Scheme); + pragma Inline (Itype); + pragma Inline (Kill_Range_Check); + pragma Inline (Last_Bit); + pragma Inline (Last_Name); + pragma Inline (Library_Unit); + pragma Inline (Label_Construct); + pragma Inline (Left_Opnd); + pragma Inline (Limited_View_Installed); + pragma Inline (Limited_Present); + pragma Inline (Literals); + pragma Inline (Local_Raise_Not_OK); + pragma Inline (Local_Raise_Statements); + pragma Inline (Loop_Actions); + pragma Inline (Loop_Parameter_Specification); + pragma Inline (Low_Bound); + pragma Inline (Mod_Clause); + pragma Inline (More_Ids); + pragma Inline (Must_Be_Byte_Aligned); + pragma Inline (Must_Not_Freeze); + pragma Inline (Must_Not_Override); + pragma Inline (Must_Override); + pragma Inline (Name); + pragma Inline (Names); + pragma Inline (Next_Entity); + pragma Inline (Next_Exit_Statement); + pragma Inline (Next_Implicit_With); + pragma Inline (Next_Named_Actual); + pragma Inline (Next_Pragma); + pragma Inline (Next_Rep_Item); + pragma Inline (Next_Use_Clause); + pragma Inline (No_Ctrl_Actions); + pragma Inline (No_Elaboration_Check); + pragma Inline (No_Entities_Ref_In_Spec); + pragma Inline (No_Initialization); + pragma Inline (No_Truncation); + pragma Inline (Null_Present); + pragma Inline (Null_Exclusion_Present); + pragma Inline (Null_Exclusion_In_Return_Present); + pragma Inline (Null_Record_Present); + pragma Inline (Object_Definition); + pragma Inline (Of_Present); + pragma Inline (Original_Discriminant); + pragma Inline (Original_Entity); + pragma Inline (Others_Discrete_Choices); + pragma Inline (Out_Present); + pragma Inline (Parameter_Associations); + pragma Inline (Parameter_Specifications); + pragma Inline (Parameter_List_Truncated); + pragma Inline (Parameter_Type); + pragma Inline (Parent_Spec); + pragma Inline (Position); + pragma Inline (Pragma_Argument_Associations); + pragma Inline (Pragma_Enabled); + pragma Inline (Pragma_Identifier); + pragma Inline (Pragmas_After); + pragma Inline (Pragmas_Before); + pragma Inline (Prefix); + pragma Inline (Present_Expr); + pragma Inline (Prev_Ids); + pragma Inline (Print_In_Hex); + pragma Inline (Private_Declarations); + pragma Inline (Private_Present); + pragma Inline (Procedure_To_Call); + pragma Inline (Proper_Body); + pragma Inline (Protected_Definition); + pragma Inline (Protected_Present); + pragma Inline (Raises_Constraint_Error); + pragma Inline (Range_Constraint); + pragma Inline (Range_Expression); + pragma Inline (Real_Range_Specification); + pragma Inline (Realval); + pragma Inline (Reason); + pragma Inline (Record_Extension_Part); + pragma Inline (Redundant_Use); + pragma Inline (Renaming_Exception); + pragma Inline (Result_Definition); + pragma Inline (Return_Object_Declarations); + pragma Inline (Return_Statement_Entity); + pragma Inline (Reverse_Present); + pragma Inline (Right_Opnd); + pragma Inline (Rounded_Result); + pragma Inline (SCIL_Controlling_Tag); + pragma Inline (SCIL_Entity); + pragma Inline (SCIL_Tag_Value); + pragma Inline (SCIL_Target_Prim); + pragma Inline (Scope); + pragma Inline (Select_Alternatives); + pragma Inline (Selector_Name); + pragma Inline (Selector_Names); + pragma Inline (Shift_Count_OK); + pragma Inline (Source_Type); + pragma Inline (Specification); + pragma Inline (Split_PPC); + pragma Inline (Statements); + pragma Inline (Static_Processing_OK); + pragma Inline (Storage_Pool); + pragma Inline (Strval); + pragma Inline (Subtype_Indication); + pragma Inline (Subtype_Mark); + pragma Inline (Subtype_Marks); + pragma Inline (Suppress_Assignment_Checks); + pragma Inline (Suppress_Loop_Warnings); + pragma Inline (Synchronized_Present); + pragma Inline (Tagged_Present); + pragma Inline (Target_Type); + pragma Inline (Task_Definition); + pragma Inline (Task_Present); + pragma Inline (Then_Actions); + pragma Inline (Then_Statements); + pragma Inline (Triggering_Alternative); + pragma Inline (Triggering_Statement); + pragma Inline (Treat_Fixed_As_Integer); + pragma Inline (TSS_Elist); + pragma Inline (Type_Definition); + pragma Inline (Unit); + pragma Inline (Unknown_Discriminants_Present); + pragma Inline (Unreferenced_In_Spec); + pragma Inline (Variant_Part); + pragma Inline (Variants); + pragma Inline (Visible_Declarations); + pragma Inline (Was_Originally_Stub); + pragma Inline (Withed_Body); + pragma Inline (Zero_Cost_Handling); + + pragma Inline (Set_ABE_Is_Certain); + pragma Inline (Set_Abort_Present); + pragma Inline (Set_Abortable_Part); + pragma Inline (Set_Abstract_Present); + pragma Inline (Set_Accept_Handler_Records); + pragma Inline (Set_Accept_Statement); + pragma Inline (Set_Access_Definition); + pragma Inline (Set_Access_To_Subprogram_Definition); + pragma Inline (Set_Access_Types_To_Process); + pragma Inline (Set_Actions); + pragma Inline (Set_Activation_Chain_Entity); + pragma Inline (Set_Acts_As_Spec); + pragma Inline (Set_Actual_Designated_Subtype); + pragma Inline (Set_Address_Warning_Posted); + pragma Inline (Set_Aggregate_Bounds); + pragma Inline (Set_Aliased_Present); + pragma Inline (Set_All_Others); + pragma Inline (Set_All_Present); + pragma Inline (Set_Alternatives); + pragma Inline (Set_Ancestor_Part); + pragma Inline (Set_Array_Aggregate); + pragma Inline (Set_Aspect_Cancel); + pragma Inline (Set_Aspect_Rep_Item); + pragma Inline (Set_Assignment_OK); + pragma Inline (Set_Associated_Node); + pragma Inline (Set_At_End_Proc); + pragma Inline (Set_Attribute_Name); + pragma Inline (Set_Aux_Decls_Node); + pragma Inline (Set_Backwards_OK); + pragma Inline (Set_Bad_Is_Detected); + pragma Inline (Set_Body_To_Inline); + pragma Inline (Set_Body_Required); + pragma Inline (Set_By_Ref); + pragma Inline (Set_Box_Present); + pragma Inline (Set_Char_Literal_Value); + pragma Inline (Set_Chars); + pragma Inline (Set_Check_Address_Alignment); + pragma Inline (Set_Choice_Parameter); + pragma Inline (Set_Choices); + pragma Inline (Set_Class_Present); + pragma Inline (Set_Coextensions); + pragma Inline (Set_Comes_From_Extended_Return_Statement); + pragma Inline (Set_Compile_Time_Known_Aggregate); + pragma Inline (Set_Component_Associations); + pragma Inline (Set_Component_Clauses); + pragma Inline (Set_Component_Definition); + pragma Inline (Set_Component_Items); + pragma Inline (Set_Component_List); + pragma Inline (Set_Component_Name); + pragma Inline (Set_Componentwise_Assignment); + pragma Inline (Set_Condition); + pragma Inline (Set_Condition_Actions); + pragma Inline (Set_Config_Pragmas); + pragma Inline (Set_Constant_Present); + pragma Inline (Set_Constraint); + pragma Inline (Set_Constraints); + pragma Inline (Set_Context_Installed); + pragma Inline (Set_Context_Items); + pragma Inline (Set_Context_Pending); + pragma Inline (Set_Controlling_Argument); + pragma Inline (Set_Conversion_OK); + pragma Inline (Set_Corresponding_Body); + pragma Inline (Set_Corresponding_Formal_Spec); + pragma Inline (Set_Corresponding_Generic_Association); + pragma Inline (Set_Corresponding_Integer_Value); + pragma Inline (Set_Corresponding_Spec); + pragma Inline (Set_Corresponding_Stub); + pragma Inline (Set_Dcheck_Function); + pragma Inline (Set_Debug_Statement); + pragma Inline (Set_Declarations); + pragma Inline (Set_Default_Expression); + pragma Inline (Set_Default_Storage_Pool); + pragma Inline (Set_Default_Name); + pragma Inline (Set_Defining_Identifier); + pragma Inline (Set_Defining_Unit_Name); + pragma Inline (Set_Delay_Alternative); + pragma Inline (Set_Delay_Statement); + pragma Inline (Set_Delta_Expression); + pragma Inline (Set_Digits_Expression); + pragma Inline (Set_Discr_Check_Funcs_Built); + pragma Inline (Set_Discrete_Choices); + pragma Inline (Set_Discrete_Range); + pragma Inline (Set_Discrete_Subtype_Definition); + pragma Inline (Set_Discrete_Subtype_Definitions); + pragma Inline (Set_Discriminant_Specifications); + pragma Inline (Set_Discriminant_Type); + pragma Inline (Set_Do_Accessibility_Check); + pragma Inline (Set_Do_Discriminant_Check); + pragma Inline (Set_Do_Length_Check); + pragma Inline (Set_Do_Division_Check); + pragma Inline (Set_Do_Overflow_Check); + pragma Inline (Set_Do_Range_Check); + pragma Inline (Set_Do_Storage_Check); + pragma Inline (Set_Do_Tag_Check); + pragma Inline (Set_Elaborate_Present); + pragma Inline (Set_Elaborate_All_Desirable); + pragma Inline (Set_Elaborate_All_Present); + pragma Inline (Set_Elaborate_Desirable); + pragma Inline (Set_Elaboration_Boolean); + pragma Inline (Set_Else_Actions); + pragma Inline (Set_Else_Statements); + pragma Inline (Set_Elsif_Parts); + pragma Inline (Set_Enclosing_Variant); + pragma Inline (Set_End_Label); + pragma Inline (Set_End_Span); + pragma Inline (Set_Entity); + pragma Inline (Set_Entry_Body_Formal_Part); + pragma Inline (Set_Entry_Call_Alternative); + pragma Inline (Set_Entry_Call_Statement); + pragma Inline (Set_Entry_Direct_Name); + pragma Inline (Set_Entry_Index); + pragma Inline (Set_Entry_Index_Specification); + pragma Inline (Set_Etype); + pragma Inline (Set_Exception_Choices); + pragma Inline (Set_Exception_Handlers); + pragma Inline (Set_Exception_Junk); + pragma Inline (Set_Exception_Label); + pragma Inline (Set_Expansion_Delayed); + pragma Inline (Set_Explicit_Actual_Parameter); + pragma Inline (Set_Explicit_Generic_Actual_Parameter); + pragma Inline (Set_Expression); + pragma Inline (Set_Expressions); + pragma Inline (Set_First_Bit); + pragma Inline (Set_First_Inlined_Subprogram); + pragma Inline (Set_First_Name); + pragma Inline (Set_First_Named_Actual); + pragma Inline (Set_First_Real_Statement); + pragma Inline (Set_First_Subtype_Link); + pragma Inline (Set_Float_Truncate); + pragma Inline (Set_Formal_Type_Definition); + pragma Inline (Set_Forwards_OK); + pragma Inline (Set_From_Aspect_Specification); + pragma Inline (Set_From_At_End); + pragma Inline (Set_From_At_Mod); + pragma Inline (Set_From_Default); + pragma Inline (Set_Generic_Associations); + pragma Inline (Set_Generic_Formal_Declarations); + pragma Inline (Set_Generic_Parent); + pragma Inline (Set_Generic_Parent_Type); + pragma Inline (Set_Handled_Statement_Sequence); + pragma Inline (Set_Handler_List_Entry); + pragma Inline (Set_Has_Created_Identifier); + pragma Inline (Set_Has_Dynamic_Length_Check); + pragma Inline (Set_Has_Init_Expression); + pragma Inline (Set_Has_Local_Raise); + pragma Inline (Set_Has_Dynamic_Range_Check); + pragma Inline (Set_Has_No_Elaboration_Code); + pragma Inline (Set_Has_Pragma_CPU); + pragma Inline (Set_Has_Pragma_Priority); + pragma Inline (Set_Has_Pragma_Suppress_All); + pragma Inline (Set_Has_Private_View); + pragma Inline (Set_Has_Relative_Deadline_Pragma); + pragma Inline (Set_Has_Storage_Size_Pragma); + pragma Inline (Set_Has_Task_Info_Pragma); + pragma Inline (Set_Has_Task_Name_Pragma); + pragma Inline (Set_Has_Wide_Character); + pragma Inline (Set_Has_Wide_Wide_Character); + pragma Inline (Set_Hidden_By_Use_Clause); + pragma Inline (Set_High_Bound); + pragma Inline (Set_Identifier); + pragma Inline (Set_Implicit_With); + pragma Inline (Set_Includes_Infinities); + pragma Inline (Set_Interface_List); + pragma Inline (Set_Interface_Present); + pragma Inline (Set_Import_Interface_Present); + pragma Inline (Set_In_Present); + pragma Inline (Set_Inherited_Discriminant); + pragma Inline (Set_Instance_Spec); + pragma Inline (Set_Intval); + pragma Inline (Set_Iterator_Specification); + pragma Inline (Set_Is_Accessibility_Actual); + pragma Inline (Set_Is_Asynchronous_Call_Block); + pragma Inline (Set_Is_Component_Left_Opnd); + pragma Inline (Set_Is_Component_Right_Opnd); + pragma Inline (Set_Is_Controlling_Actual); + pragma Inline (Set_Is_Delayed_Aspect); + pragma Inline (Set_Is_Dynamic_Coextension); + pragma Inline (Set_Is_Elsif); + pragma Inline (Set_Is_Entry_Barrier_Function); + pragma Inline (Set_Is_Expanded_Build_In_Place_Call); + pragma Inline (Set_Is_Folded_In_Parser); + pragma Inline (Set_Is_In_Discriminant_Check); + pragma Inline (Set_Is_Machine_Number); + pragma Inline (Set_Is_Null_Loop); + pragma Inline (Set_Is_Overloaded); + pragma Inline (Set_Is_Power_Of_2_For_Shift); + pragma Inline (Set_Is_Protected_Subprogram_Body); + pragma Inline (Set_Has_Self_Reference); + pragma Inline (Set_Is_Static_Coextension); + pragma Inline (Set_Is_Static_Expression); + pragma Inline (Set_Is_Subprogram_Descriptor); + pragma Inline (Set_Is_Task_Allocation_Block); + pragma Inline (Set_Is_Task_Master); + pragma Inline (Set_Iteration_Scheme); + pragma Inline (Set_Itype); + pragma Inline (Set_Kill_Range_Check); + pragma Inline (Set_Last_Bit); + pragma Inline (Set_Last_Name); + pragma Inline (Set_Library_Unit); + pragma Inline (Set_Label_Construct); + pragma Inline (Set_Left_Opnd); + pragma Inline (Set_Limited_View_Installed); + pragma Inline (Set_Limited_Present); + pragma Inline (Set_Literals); + pragma Inline (Set_Local_Raise_Not_OK); + pragma Inline (Set_Local_Raise_Statements); + pragma Inline (Set_Loop_Actions); + pragma Inline (Set_Loop_Parameter_Specification); + pragma Inline (Set_Low_Bound); + pragma Inline (Set_Mod_Clause); + pragma Inline (Set_More_Ids); + pragma Inline (Set_Must_Be_Byte_Aligned); + pragma Inline (Set_Must_Not_Freeze); + pragma Inline (Set_Must_Not_Override); + pragma Inline (Set_Must_Override); + pragma Inline (Set_Name); + pragma Inline (Set_Names); + pragma Inline (Set_Next_Entity); + pragma Inline (Set_Next_Exit_Statement); + pragma Inline (Set_Next_Implicit_With); + pragma Inline (Set_Next_Named_Actual); + pragma Inline (Set_Next_Pragma); + pragma Inline (Set_Next_Rep_Item); + pragma Inline (Set_Next_Use_Clause); + pragma Inline (Set_No_Ctrl_Actions); + pragma Inline (Set_No_Elaboration_Check); + pragma Inline (Set_No_Entities_Ref_In_Spec); + pragma Inline (Set_No_Initialization); + pragma Inline (Set_No_Truncation); + pragma Inline (Set_Null_Present); + pragma Inline (Set_Null_Exclusion_Present); + pragma Inline (Set_Null_Exclusion_In_Return_Present); + pragma Inline (Set_Null_Record_Present); + pragma Inline (Set_Object_Definition); + pragma Inline (Set_Of_Present); + pragma Inline (Set_Original_Discriminant); + pragma Inline (Set_Original_Entity); + pragma Inline (Set_Others_Discrete_Choices); + pragma Inline (Set_Out_Present); + pragma Inline (Set_Parameter_Associations); + pragma Inline (Set_Parameter_Specifications); + pragma Inline (Set_Parameter_List_Truncated); + pragma Inline (Set_Parameter_Type); + pragma Inline (Set_Parent_Spec); + pragma Inline (Set_Position); + pragma Inline (Set_Pragma_Argument_Associations); + pragma Inline (Set_Pragma_Enabled); + pragma Inline (Set_Pragma_Identifier); + pragma Inline (Set_Pragmas_After); + pragma Inline (Set_Pragmas_Before); + pragma Inline (Set_Prefix); + pragma Inline (Set_Present_Expr); + pragma Inline (Set_Prev_Ids); + pragma Inline (Set_Print_In_Hex); + pragma Inline (Set_Private_Declarations); + pragma Inline (Set_Private_Present); + pragma Inline (Set_Procedure_To_Call); + pragma Inline (Set_Proper_Body); + pragma Inline (Set_Protected_Definition); + pragma Inline (Set_Protected_Present); + pragma Inline (Set_Raises_Constraint_Error); + pragma Inline (Set_Range_Constraint); + pragma Inline (Set_Range_Expression); + pragma Inline (Set_Real_Range_Specification); + pragma Inline (Set_Realval); + pragma Inline (Set_Reason); + pragma Inline (Set_Record_Extension_Part); + pragma Inline (Set_Redundant_Use); + pragma Inline (Set_Renaming_Exception); + pragma Inline (Set_Result_Definition); + pragma Inline (Set_Return_Object_Declarations); + pragma Inline (Set_Reverse_Present); + pragma Inline (Set_Right_Opnd); + pragma Inline (Set_Rounded_Result); + pragma Inline (Set_SCIL_Controlling_Tag); + pragma Inline (Set_SCIL_Entity); + pragma Inline (Set_SCIL_Tag_Value); + pragma Inline (Set_SCIL_Target_Prim); + pragma Inline (Set_Scope); + pragma Inline (Set_Select_Alternatives); + pragma Inline (Set_Selector_Name); + pragma Inline (Set_Selector_Names); + pragma Inline (Set_Shift_Count_OK); + pragma Inline (Set_Source_Type); + pragma Inline (Set_Specification); + pragma Inline (Set_Split_PPC); + pragma Inline (Set_Statements); + pragma Inline (Set_Static_Processing_OK); + pragma Inline (Set_Storage_Pool); + pragma Inline (Set_Strval); + pragma Inline (Set_Subtype_Indication); + pragma Inline (Set_Subtype_Mark); + pragma Inline (Set_Subtype_Marks); + pragma Inline (Set_Suppress_Assignment_Checks); + pragma Inline (Set_Suppress_Loop_Warnings); + pragma Inline (Set_Synchronized_Present); + pragma Inline (Set_Tagged_Present); + pragma Inline (Set_Target_Type); + pragma Inline (Set_Task_Definition); + pragma Inline (Set_Task_Present); + pragma Inline (Set_Then_Actions); + pragma Inline (Set_Then_Statements); + pragma Inline (Set_Triggering_Alternative); + pragma Inline (Set_Triggering_Statement); + pragma Inline (Set_Treat_Fixed_As_Integer); + pragma Inline (Set_TSS_Elist); + pragma Inline (Set_Type_Definition); + pragma Inline (Set_Unit); + pragma Inline (Set_Unknown_Discriminants_Present); + pragma Inline (Set_Unreferenced_In_Spec); + pragma Inline (Set_Variant_Part); + pragma Inline (Set_Variants); + pragma Inline (Set_Visible_Declarations); + pragma Inline (Set_Was_Originally_Stub); + pragma Inline (Set_Withed_Body); + pragma Inline (Set_Zero_Cost_Handling); + + N_Simple_Return_Statement : constant Node_Kind := N_Return_Statement; + -- Rename N_Return_Statement to be N_Simple_Return_Statement. Clients + -- should refer to N_Simple_Return_Statement. + +end Sinfo; diff --git a/gcc/ada/sinput-c.adb b/gcc/ada/sinput-c.adb new file mode 100644 index 000000000..aebdcacdd --- /dev/null +++ b/gcc/ada/sinput-c.adb @@ -0,0 +1,209 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S I N P U T . C -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Opt; use Opt; +with System; use System; + +with Ada.Unchecked_Conversion; + +pragma Warnings (Off); +-- This package is used also by gnatcoll +with System.OS_Lib; use System.OS_Lib; +pragma Warnings (On); + +package body Sinput.C is + + --------------- + -- Load_File -- + --------------- + + function Load_File (Path : String) return Source_File_Index is + Src : Source_Buffer_Ptr; + X : Source_File_Index; + Lo : Source_Ptr; + Hi : Source_Ptr; + + Source_File_FD : File_Descriptor; + -- The file descriptor for the current source file. A negative value + -- indicates failure to open the specified source file. + + Len : Integer; + -- Length of file. Assume no more than 2 gigabytes of source! + + Actual_Len : Integer; + + Path_Id : File_Name_Type; + File_Id : File_Name_Type; + + begin + if Path = "" then + return No_Source_File; + end if; + + Source_File.Increment_Last; + X := Source_File.Last; + + if X = Source_File.First then + Lo := First_Source_Ptr; + else + Lo := Source_File.Table (X - 1).Source_Last + 1; + end if; + + Name_Len := Path'Length; + Name_Buffer (1 .. Name_Len) := Path; + Path_Id := Name_Find; + Name_Buffer (Name_Len + 1) := ASCII.NUL; + + -- Open the source FD, note that we open in binary mode, because as + -- documented in the spec, the caller is expected to handle either + -- DOS or Unix mode files, and there is no point in wasting time on + -- text translation when it is not required. + + Source_File_FD := Open_Read (Name_Buffer'Address, Binary); + + if Source_File_FD = Invalid_FD then + Source_File.Decrement_Last; + return No_Source_File; + + end if; + + Len := Integer (File_Length (Source_File_FD)); + + -- Set Hi so that length is one more than the physical length, + -- allowing for the extra EOF character at the end of the buffer + + Hi := Lo + Source_Ptr (Len); + + -- Do the actual read operation + + declare + subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi); + -- Physical buffer allocated + + type Actual_Source_Ptr is access Actual_Source_Buffer; + -- This is the pointer type for the physical buffer allocated + + Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer; + -- And this is the actual physical buffer + + begin + -- Allocate source buffer, allowing extra character at end for EOF + + -- Some systems (e.g. VMS) have file types that require one + -- read per line, so read until we get the Len bytes or until + -- there are no more characters. + + Hi := Lo; + loop + Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len); + Hi := Hi + Source_Ptr (Actual_Len); + exit when Actual_Len = Len or else Actual_Len <= 0; + end loop; + + Actual_Ptr (Hi) := EOF; + + -- Now we need to work out the proper virtual origin pointer to + -- return. This is exactly Actual_Ptr (0)'Address, but we have + -- to be careful to suppress checks to compute this address. + + declare + pragma Suppress (All_Checks); + + pragma Warnings (Off); + -- The following unchecked conversion is aliased safe, since it + -- is not used to create improperly aliased pointer values. + + function To_Source_Buffer_Ptr is new + Ada.Unchecked_Conversion (Address, Source_Buffer_Ptr); + + pragma Warnings (On); + + begin + Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address); + end; + end; + + -- Read is complete, close the file and we are done (no need to test + -- status from close, since we have successfully read the file!) + + Close (Source_File_FD); + + -- Get the file name, without path information + + declare + Index : Positive := Path'Last; + + begin + while Index > Path'First loop + exit when Path (Index - 1) = '/'; + exit when Path (Index - 1) = Directory_Separator; + Index := Index - 1; + end loop; + + Name_Len := Path'Last - Index + 1; + Name_Buffer (1 .. Name_Len) := Path (Index .. Path'Last); + File_Id := Name_Find; + end; + + declare + S : Source_File_Record renames Source_File.Table (X); + + begin + S := (Debug_Source_Name => File_Id, + File_Name => File_Id, + File_Type => Config, + First_Mapped_Line => No_Line_Number, + Full_Debug_Name => Path_Id, + Full_File_Name => Path_Id, + Full_Ref_Name => Path_Id, + Identifier_Casing => Unknown, + Inlined_Body => False, + Instantiation => No_Location, + Keyword_Casing => Unknown, + Last_Source_Line => 1, + License => Unknown, + Lines_Table => null, + Lines_Table_Max => 1, + Logical_Lines_Table => null, + Num_SRef_Pragmas => 0, + Reference_Name => File_Id, + Sloc_Adjust => 0, + Source_Checksum => 0, + Source_First => Lo, + Source_Last => Hi, + Source_Text => Src, + Template => No_Source_File, + Unit => No_Unit, + Time_Stamp => Empty_Time_Stamp); + + Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial); + S.Lines_Table (1) := Lo; + end; + + Set_Source_File_Index_Table (X); + return X; + end Load_File; + +end Sinput.C; diff --git a/gcc/ada/sinput-c.ads b/gcc/ada/sinput-c.ads new file mode 100644 index 000000000..50b729ca1 --- /dev/null +++ b/gcc/ada/sinput-c.ads @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S I N P U T . C -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This child package contains a procedure to load files + +-- It is used by Sinput.P to load project files, and by GPrep to load +-- preprocessor definition files and input files. + +package Sinput.C is + + function Load_File (Path : String) return Source_File_Index; + -- Load a file into memory and Initialize the Scans state + +end Sinput.C; diff --git a/gcc/ada/sinput-d.adb b/gcc/ada/sinput-d.adb new file mode 100644 index 000000000..a860058c9 --- /dev/null +++ b/gcc/ada/sinput-d.adb @@ -0,0 +1,114 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S I N P U T . D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Osint; use Osint; +with Osint.C; use Osint.C; + +package body Sinput.D is + + Dfile : Source_File_Index; + -- Index of currently active debug source file + + ------------------------ + -- Close_Debug_Source -- + ------------------------ + + procedure Close_Debug_Source is + S : Source_File_Record renames Source_File.Table (Dfile); + Src : Source_Buffer_Ptr; + + pragma Warnings (Off, S); + + begin + Trim_Lines_Table (Dfile); + Close_Debug_File; + + -- Now we need to read the file that we wrote and store it in memory for + -- subsequent access. + + Read_Source_File + (S.Full_Debug_Name, S.Source_First, S.Source_Last, Src); + S.Source_Text := Src; + end Close_Debug_Source; + + ------------------------- + -- Create_Debug_Source -- + ------------------------- + + procedure Create_Debug_Source + (Source : Source_File_Index; + Loc : out Source_Ptr) + is + begin + Loc := Source_File.Table (Source_File.Last).Source_Last + 1; + Source_File.Append (Source_File.Table (Source)); + Dfile := Source_File.Last; + + declare + S : Source_File_Record renames Source_File.Table (Dfile); + + begin + S.Full_Debug_Name := Create_Debug_File (S.File_Name); + S.Debug_Source_Name := Strip_Directory (S.Full_Debug_Name); + S.Source_First := Loc; + S.Source_Last := Loc; + S.Lines_Table := null; + S.Last_Source_Line := 1; + + -- Allocate lines table, guess that it needs to be three times bigger + -- than the original source (in number of lines). + + Alloc_Line_Tables + (S, Int (Source_File.Table (Source).Last_Source_Line * 3)); + S.Lines_Table (1) := Loc; + end; + end Create_Debug_Source; + + ---------------------- + -- Write_Debug_Line -- + ---------------------- + + procedure Write_Debug_Line (Str : String; Loc : in out Source_Ptr) is + S : Source_File_Record renames Source_File.Table (Dfile); + + begin + -- Ignore write request if null line at start of file + + if Str'Length = 0 and then Loc = S.Source_First then + return; + + -- Here we write the line, compute the source location for the following + -- line, allocate its table entry, and update the source record entry. + + else + Write_Debug_Info (Str (Str'First .. Str'Last - 1)); + Loc := Loc - 1 + Source_Ptr (Str'Length + Debug_File_Eol_Length); + Add_Line_Tables_Entry (S, Loc); + S.Source_Last := Loc; + Set_Source_File_Index_Table (Dfile); + end if; + end Write_Debug_Line; + +end Sinput.D; diff --git a/gcc/ada/sinput-d.ads b/gcc/ada/sinput-d.ads new file mode 100644 index 000000000..138743347 --- /dev/null +++ b/gcc/ada/sinput-d.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S I N P U T . D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This child package contains the routines used to write debug source +-- files. These routines are not in Sinput.L, because they are used only +-- by the compiler, while Sinput.L is also used by gnatmake. + +package Sinput.D is + + ------------------------------------------------ + -- Subprograms for Writing Debug Source Files -- + ------------------------------------------------ + + procedure Create_Debug_Source + (Source : Source_File_Index; + Loc : out Source_Ptr); + -- Given a source file, creates a new source file table entry to be used + -- for the debug source file output (Debug_Generated_Code switch set). + -- Loc is set to the initial Sloc value for the first line. This call + -- also creates the debug source output file (using Create_Debug_File). + + procedure Write_Debug_Line (Str : String; Loc : in out Source_Ptr); + -- This procedure is called to write a line to the debug source file + -- previously created by Create_Debug_Source using Write_Debug_Info. + -- Str is the source line to be written to the file (it does not include + -- an end of line character). On entry Loc is the Sloc value previously + -- returned by Create_Debug_Source or Write_Debug_Line, and on exit, + -- Sloc is updated to point to the start of the next line to be written, + -- taking into account the length of the terminator that was written by + -- Write_Debug_Info. + + procedure Close_Debug_Source; + -- This procedure completes the source table entry for the debug file + -- previously created by Create_Debug_Source, and written using the + -- Write_Debug_Line procedure. It then calls Close_Debug_File to + -- complete the writing of the file itself. + +end Sinput.D; diff --git a/gcc/ada/sinput-l.adb b/gcc/ada/sinput-l.adb new file mode 100644 index 000000000..52f3a713b --- /dev/null +++ b/gcc/ada/sinput-l.adb @@ -0,0 +1,784 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S I N P U T . L -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Alloc; +with Atree; use Atree; +with Debug; use Debug; +with Einfo; use Einfo; +with Errout; use Errout; +with Fname; use Fname; +with Hostparm; +with Lib; use Lib; +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; +with Prep; use Prep; +with Prepcomp; use Prepcomp; +with Scans; use Scans; +with Scn; use Scn; +with Sinfo; use Sinfo; +with Snames; use Snames; +with System; use System; + +with System.OS_Lib; use System.OS_Lib; + +with Unchecked_Conversion; + +package body Sinput.L is + + Prep_Buffer : Text_Buffer_Ptr := null; + -- A buffer to temporarily stored the result of preprocessing a source. + -- It is only allocated if there is at least one source to preprocess. + + Prep_Buffer_Last : Text_Ptr := 0; + -- Index of the last significant character in Prep_Buffer + + Initial_Size_Of_Prep_Buffer : constant := 10_000; + -- Size of Prep_Buffer when it is first allocated + + -- When a file is to be preprocessed and the options to list symbols + -- has been selected (switch -s), Prep.List_Symbols is called with a + -- "foreword", a single line indicating what source the symbols apply to. + -- The following two constant String are the start and the end of this + -- foreword. + + Foreword_Start : constant String := + "Preprocessing Symbols for source """; + + Foreword_End : constant String := """"; + + ----------------- + -- Subprograms -- + ----------------- + + procedure Put_Char_In_Prep_Buffer (C : Character); + -- Add one character in Prep_Buffer, extending Prep_Buffer if need be. + -- Used to initialize the preprocessor. + + procedure New_EOL_In_Prep_Buffer; + -- Add an LF to Prep_Buffer (used to initialize the preprocessor) + + function Load_File + (N : File_Name_Type; + T : Osint.File_Type) return Source_File_Index; + -- Load a source file, a configuration pragmas file or a definition file + -- Coding also allows preprocessing file, but not a library file ??? + + ------------------------------- + -- Adjust_Instantiation_Sloc -- + ------------------------------- + + procedure Adjust_Instantiation_Sloc (N : Node_Id; A : Sloc_Adjustment) is + Loc : constant Source_Ptr := Sloc (N); + + begin + -- We only do the adjustment if the value is between the appropriate low + -- and high values. It is not clear that this should ever not be the + -- case, but in practice there seem to be some nodes that get copied + -- twice, and this is a defence against that happening. + + if A.Lo <= Loc and then Loc <= A.Hi then + Set_Sloc (N, Loc + A.Adjust); + end if; + end Adjust_Instantiation_Sloc; + + -------------------------------- + -- Complete_Source_File_Entry -- + -------------------------------- + + procedure Complete_Source_File_Entry is + CSF : constant Source_File_Index := Current_Source_File; + + begin + Trim_Lines_Table (CSF); + Source_File.Table (CSF).Source_Checksum := Checksum; + end Complete_Source_File_Entry; + + --------------------------------- + -- Create_Instantiation_Source -- + --------------------------------- + + procedure Create_Instantiation_Source + (Inst_Node : Entity_Id; + Template_Id : Entity_Id; + Inlined_Body : Boolean; + A : out Sloc_Adjustment) + is + Dnod : constant Node_Id := Declaration_Node (Template_Id); + Xold : Source_File_Index; + Xnew : Source_File_Index; + + begin + Xold := Get_Source_File_Index (Sloc (Template_Id)); + A.Lo := Source_File.Table (Xold).Source_First; + A.Hi := Source_File.Table (Xold).Source_Last; + + Source_File.Append (Source_File.Table (Xold)); + Xnew := Source_File.Last; + + Source_File.Table (Xnew).Inlined_Body := Inlined_Body; + Source_File.Table (Xnew).Instantiation := Sloc (Inst_Node); + Source_File.Table (Xnew).Template := Xold; + + -- Now we need to compute the new values of Source_First, Source_Last + -- and adjust the source file pointer to have the correct virtual + -- origin for the new range of values. + + Source_File.Table (Xnew).Source_First := + Source_File.Table (Xnew - 1).Source_Last + 1; + A.Adjust := Source_File.Table (Xnew).Source_First - A.Lo; + Source_File.Table (Xnew).Source_Last := A.Hi + A.Adjust; + + Set_Source_File_Index_Table (Xnew); + + Source_File.Table (Xnew).Sloc_Adjust := + Source_File.Table (Xold).Sloc_Adjust - A.Adjust; + + if Debug_Flag_L then + Write_Eol; + Write_Str ("*** Create instantiation source for "); + + if Nkind (Dnod) in N_Proper_Body + and then Was_Originally_Stub (Dnod) + then + Write_Str ("subunit "); + + elsif Ekind (Template_Id) = E_Generic_Package then + if Nkind (Dnod) = N_Package_Body then + Write_Str ("body of package "); + else + Write_Str ("spec of package "); + end if; + + elsif Ekind (Template_Id) = E_Function then + Write_Str ("body of function "); + + elsif Ekind (Template_Id) = E_Procedure then + Write_Str ("body of procedure "); + + elsif Ekind (Template_Id) = E_Generic_Function then + Write_Str ("spec of function "); + + elsif Ekind (Template_Id) = E_Generic_Procedure then + Write_Str ("spec of procedure "); + + elsif Ekind (Template_Id) = E_Package_Body then + Write_Str ("body of package "); + + else pragma Assert (Ekind (Template_Id) = E_Subprogram_Body); + + if Nkind (Dnod) = N_Procedure_Specification then + Write_Str ("body of procedure "); + else + Write_Str ("body of function "); + end if; + end if; + + Write_Name (Chars (Template_Id)); + Write_Eol; + + Write_Str (" new source index = "); + Write_Int (Int (Xnew)); + Write_Eol; + + Write_Str (" copying from file name = "); + Write_Name (File_Name (Xold)); + Write_Eol; + + Write_Str (" old source index = "); + Write_Int (Int (Xold)); + Write_Eol; + + Write_Str (" old lo = "); + Write_Int (Int (A.Lo)); + Write_Eol; + + Write_Str (" old hi = "); + Write_Int (Int (A.Hi)); + Write_Eol; + + Write_Str (" new lo = "); + Write_Int (Int (Source_File.Table (Xnew).Source_First)); + Write_Eol; + + Write_Str (" new hi = "); + Write_Int (Int (Source_File.Table (Xnew).Source_Last)); + Write_Eol; + + Write_Str (" adjustment factor = "); + Write_Int (Int (A.Adjust)); + Write_Eol; + + Write_Str (" instantiation location: "); + Write_Location (Sloc (Inst_Node)); + Write_Eol; + end if; + + -- For a given character in the source, a higher subscript will be used + -- to access the instantiation, which means that the virtual origin must + -- have a corresponding lower value. We compute this new origin by + -- taking the address of the appropriate adjusted element in the old + -- array. Since this adjusted element will be at a negative subscript, + -- we must suppress checks. + + declare + pragma Suppress (All_Checks); + + pragma Warnings (Off); + -- This unchecked conversion is aliasing safe, since it is never used + -- to create improperly aliased pointer values. + + function To_Source_Buffer_Ptr is new + Unchecked_Conversion (Address, Source_Buffer_Ptr); + + pragma Warnings (On); + + begin + Source_File.Table (Xnew).Source_Text := + To_Source_Buffer_Ptr + (Source_File.Table (Xold).Source_Text (-A.Adjust)'Address); + end; + end Create_Instantiation_Source; + + ---------------------- + -- Load_Config_File -- + ---------------------- + + function Load_Config_File + (N : File_Name_Type) return Source_File_Index + is + begin + return Load_File (N, Osint.Config); + end Load_Config_File; + + -------------------------- + -- Load_Definition_File -- + -------------------------- + + function Load_Definition_File + (N : File_Name_Type) return Source_File_Index + is + begin + return Load_File (N, Osint.Definition); + end Load_Definition_File; + + --------------- + -- Load_File -- + --------------- + + function Load_File + (N : File_Name_Type; + T : Osint.File_Type) return Source_File_Index + is + Src : Source_Buffer_Ptr; + X : Source_File_Index; + Lo : Source_Ptr; + Hi : Source_Ptr; + + Preprocessing_Needed : Boolean := False; + + begin + -- If already there, don't need to reload file. An exception occurs + -- in multiple unit per file mode. It would be nice in this case to + -- share the same source file for each unit, but this leads to many + -- difficulties with assumptions (e.g. in the body of lib), that a + -- unit can be found by locating its source file index. Since we do + -- not expect much use of this mode, it's no big deal to waste a bit + -- of space and time by reading and storing the source multiple times. + + if Multiple_Unit_Index = 0 then + for J in 1 .. Source_File.Last loop + if Source_File.Table (J).File_Name = N then + return J; + end if; + end loop; + end if; + + -- Here we must build a new entry in the file table + + -- But first, we must check if a source needs to be preprocessed, + -- because we may have to load and parse a definition file, and we want + -- to do that before we load the source, so that the buffer of the + -- source will be the last created, and we will be able to replace it + -- and modify Hi without stepping on another buffer. + + if T = Osint.Source and then not Is_Internal_File_Name (N) then + Prepare_To_Preprocess + (Source => N, Preprocessing_Needed => Preprocessing_Needed); + end if; + + Source_File.Increment_Last; + X := Source_File.Last; + + if X = Source_File.First then + Lo := First_Source_Ptr; + else + Lo := Source_File.Table (X - 1).Source_Last + 1; + end if; + + Osint.Read_Source_File (N, Lo, Hi, Src, T); + + if Src = null then + Source_File.Decrement_Last; + return No_Source_File; + + else + if Debug_Flag_L then + Write_Eol; + Write_Str ("*** Build source file table entry, Index = "); + Write_Int (Int (X)); + Write_Str (", file name = "); + Write_Name (N); + Write_Eol; + Write_Str (" lo = "); + Write_Int (Int (Lo)); + Write_Eol; + Write_Str (" hi = "); + Write_Int (Int (Hi)); + Write_Eol; + + Write_Str (" first 10 chars -->"); + + declare + procedure Wchar (C : Character); + -- Writes character or ? for control character + + ----------- + -- Wchar -- + ----------- + + procedure Wchar (C : Character) is + begin + if C < ' ' + or else C in ASCII.DEL .. Character'Val (16#9F#) + then + Write_Char ('?'); + else + Write_Char (C); + end if; + end Wchar; + + begin + for J in Lo .. Lo + 9 loop + Wchar (Src (J)); + end loop; + + Write_Str ("<--"); + Write_Eol; + + Write_Str (" last 10 chars -->"); + + for J in Hi - 10 .. Hi - 1 loop + Wchar (Src (J)); + end loop; + + Write_Str ("<--"); + Write_Eol; + + if Src (Hi) /= EOF then + Write_Str (" error: no EOF at end"); + Write_Eol; + end if; + end; + end if; + + declare + S : Source_File_Record renames Source_File.Table (X); + File_Type : Type_Of_File; + + begin + case T is + when Osint.Source => + File_Type := Sinput.Src; + + when Osint.Library => + raise Program_Error; + + when Osint.Config => + File_Type := Sinput.Config; + + when Osint.Definition => + File_Type := Def; + + when Osint.Preprocessing_Data => + File_Type := Preproc; + end case; + + S := (Debug_Source_Name => N, + File_Name => N, + File_Type => File_Type, + First_Mapped_Line => No_Line_Number, + Full_Debug_Name => Osint.Full_Source_Name, + Full_File_Name => Osint.Full_Source_Name, + Full_Ref_Name => Osint.Full_Source_Name, + Identifier_Casing => Unknown, + Inlined_Body => False, + Instantiation => No_Location, + Keyword_Casing => Unknown, + Last_Source_Line => 1, + License => Unknown, + Lines_Table => null, + Lines_Table_Max => 1, + Logical_Lines_Table => null, + Num_SRef_Pragmas => 0, + Reference_Name => N, + Sloc_Adjust => 0, + Source_Checksum => 0, + Source_First => Lo, + Source_Last => Hi, + Source_Text => Src, + Template => No_Source_File, + Unit => No_Unit, + Time_Stamp => Osint.Current_Source_File_Stamp); + + Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial); + S.Lines_Table (1) := Lo; + end; + + -- Preprocess the source if it needs to be preprocessed + + if Preprocessing_Needed then + + -- Temporarily set the Source_File_Index_Table entries for the + -- source, to avoid crash when reporting an error. + + Set_Source_File_Index_Table (X); + + if Opt.List_Preprocessing_Symbols then + Get_Name_String (N); + + declare + Foreword : String (1 .. Foreword_Start'Length + + Name_Len + Foreword_End'Length); + + begin + Foreword (1 .. Foreword_Start'Length) := Foreword_Start; + Foreword (Foreword_Start'Length + 1 .. + Foreword_Start'Length + Name_Len) := + Name_Buffer (1 .. Name_Len); + Foreword (Foreword'Last - Foreword_End'Length + 1 .. + Foreword'Last) := Foreword_End; + Prep.List_Symbols (Foreword); + end; + end if; + + declare + T : constant Nat := Total_Errors_Detected; + -- Used to check if there were errors during preprocessing + + Save_Style_Check : Boolean; + -- Saved state of the Style_Check flag (which needs to be + -- temporarily set to False during preprocessing, see below). + + Modified : Boolean; + + begin + -- If this is the first time we preprocess a source, allocate + -- the preprocessing buffer. + + if Prep_Buffer = null then + Prep_Buffer := + new Text_Buffer (1 .. Initial_Size_Of_Prep_Buffer); + end if; + + -- Make sure the preprocessing buffer is empty + + Prep_Buffer_Last := 0; + + -- Initialize the preprocessor hooks + + Prep.Setup_Hooks + (Error_Msg => Errout.Error_Msg'Access, + Scan => Scn.Scanner.Scan'Access, + Set_Ignore_Errors => Errout.Set_Ignore_Errors'Access, + Put_Char => Put_Char_In_Prep_Buffer'Access, + New_EOL => New_EOL_In_Prep_Buffer'Access); + + -- Initialize scanner and set its behavior for preprocessing, + -- then preprocess. Also disable style checks, since some of + -- them are done in the scanner (specifically, those dealing + -- with line length and line termination), and cannot be done + -- during preprocessing (because the source file index table + -- has not been set yet). + + Scn.Scanner.Initialize_Scanner (X); + + Scn.Scanner.Set_Special_Character ('#'); + Scn.Scanner.Set_Special_Character ('$'); + Scn.Scanner.Set_End_Of_Line_As_Token (True); + Save_Style_Check := Opt.Style_Check; + Opt.Style_Check := False; + + -- The actual preprocessing step + + Preprocess (Modified); + + -- Reset the scanner to its standard behavior, and restore the + -- Style_Checks flag. + + Scn.Scanner.Reset_Special_Characters; + Scn.Scanner.Set_End_Of_Line_As_Token (False); + Opt.Style_Check := Save_Style_Check; + + -- If there were errors during preprocessing, record an error + -- at the start of the file, and do not change the source + -- buffer. + + if T /= Total_Errors_Detected then + Errout.Error_Msg + ("file could not be successfully preprocessed", Lo); + return No_Source_File; + + else + -- Output the result of the preprocessing, if requested and + -- the source has been modified by the preprocessing. Only + -- do that for the main unit (spec, body and subunits). + + if Generate_Processed_File + and then Modified + and then + ((Compiler_State = Parsing + and then Parsing_Main_Extended_Source) + or else + (Compiler_State = Analyzing + and then Analysing_Subunit_Of_Main)) + then + declare + FD : File_Descriptor; + NB : Integer; + Status : Boolean; + + begin + Get_Name_String (N); + + if Hostparm.OpenVMS then + Add_Str_To_Name_Buffer ("_prep"); + else + Add_Str_To_Name_Buffer (".prep"); + end if; + + Delete_File (Name_Buffer (1 .. Name_Len), Status); + + FD := + Create_New_File (Name_Buffer (1 .. Name_Len), Text); + + Status := FD /= Invalid_FD; + + if Status then + NB := + Write + (FD, + Prep_Buffer (1)'Address, + Integer (Prep_Buffer_Last)); + Status := NB = Integer (Prep_Buffer_Last); + end if; + + if Status then + Close (FD, Status); + end if; + + if not Status then + Errout.Error_Msg + ("?could not write processed file """ & + Name_Buffer (1 .. Name_Len) & '"', + Lo); + end if; + end; + end if; + + -- Set the new value of Hi + + Hi := Lo + Source_Ptr (Prep_Buffer_Last); + + -- Create the new source buffer + + declare + subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi); + -- Physical buffer allocated + + type Actual_Source_Ptr is access Actual_Source_Buffer; + -- Pointer type for the physical buffer allocated + + Actual_Ptr : constant Actual_Source_Ptr := + new Actual_Source_Buffer; + -- Actual physical buffer + + begin + Actual_Ptr (Lo .. Hi - 1) := + Prep_Buffer (1 .. Prep_Buffer_Last); + Actual_Ptr (Hi) := EOF; + + -- Now we need to work out the proper virtual origin + -- pointer to return. This is Actual_Ptr (0)'Address, but + -- we have to be careful to suppress checks to compute + -- this address. + + declare + pragma Suppress (All_Checks); + + pragma Warnings (Off); + -- This unchecked conversion is aliasing safe, since + -- it is never used to create improperly aliased + -- pointer values. + + function To_Source_Buffer_Ptr is new + Unchecked_Conversion (Address, Source_Buffer_Ptr); + + pragma Warnings (On); + + begin + Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address); + + -- Record in the table the new source buffer and the + -- new value of Hi. + + Source_File.Table (X).Source_Text := Src; + Source_File.Table (X).Source_Last := Hi; + + -- Reset Last_Line to 1, because the lines do not + -- have necessarily the same starts and lengths. + + Source_File.Table (X).Last_Source_Line := 1; + end; + end; + end if; + end; + end if; + + Set_Source_File_Index_Table (X); + return X; + end if; + end Load_File; + + ---------------------------------- + -- Load_Preprocessing_Data_File -- + ---------------------------------- + + function Load_Preprocessing_Data_File + (N : File_Name_Type) return Source_File_Index + is + begin + return Load_File (N, Osint.Preprocessing_Data); + end Load_Preprocessing_Data_File; + + ---------------------- + -- Load_Source_File -- + ---------------------- + + function Load_Source_File + (N : File_Name_Type) return Source_File_Index + is + begin + return Load_File (N, Osint.Source); + end Load_Source_File; + + ---------------------------- + -- New_EOL_In_Prep_Buffer -- + ---------------------------- + + procedure New_EOL_In_Prep_Buffer is + begin + Put_Char_In_Prep_Buffer (ASCII.LF); + end New_EOL_In_Prep_Buffer; + + ----------------------------- + -- Put_Char_In_Prep_Buffer -- + ----------------------------- + + procedure Put_Char_In_Prep_Buffer (C : Character) is + begin + -- If preprocessing buffer is not large enough, double it + + if Prep_Buffer_Last = Prep_Buffer'Last then + declare + New_Prep_Buffer : constant Text_Buffer_Ptr := + new Text_Buffer (1 .. 2 * Prep_Buffer_Last); + + begin + New_Prep_Buffer (Prep_Buffer'Range) := Prep_Buffer.all; + Free (Prep_Buffer); + Prep_Buffer := New_Prep_Buffer; + end; + end if; + + Prep_Buffer_Last := Prep_Buffer_Last + 1; + Prep_Buffer (Prep_Buffer_Last) := C; + end Put_Char_In_Prep_Buffer; + + ----------------------------------- + -- Source_File_Is_Pragma_No_Body -- + ----------------------------------- + + function Source_File_Is_No_Body (X : Source_File_Index) return Boolean is + begin + Initialize_Scanner (No_Unit, X); + + if Token /= Tok_Pragma then + return False; + end if; + + Scan; -- past pragma + + if Token /= Tok_Identifier + or else Chars (Token_Node) /= Name_No_Body + then + return False; + end if; + + Scan; -- past No_Body + + if Token /= Tok_Semicolon then + return False; + end if; + + Scan; -- past semicolon + + return Token = Tok_EOF; + end Source_File_Is_No_Body; + + ---------------------------- + -- Source_File_Is_Subunit -- + ---------------------------- + + function Source_File_Is_Subunit (X : Source_File_Index) return Boolean is + begin + Initialize_Scanner (No_Unit, X); + + -- We scan past junk to the first interesting compilation unit token, to + -- see if it is SEPARATE. We ignore WITH keywords during this and also + -- PRIVATE. The reason for ignoring PRIVATE is that it handles some + -- error situations, and also to handle PRIVATE WITH in Ada 2005 mode. + + while Token = Tok_With + or else Token = Tok_Private + or else (Token not in Token_Class_Cunit and then Token /= Tok_EOF) + loop + Scan; + end loop; + + return Token = Tok_Separate; + end Source_File_Is_Subunit; + +end Sinput.L; diff --git a/gcc/ada/sinput-l.ads b/gcc/ada/sinput-l.ads new file mode 100644 index 000000000..a72237bab --- /dev/null +++ b/gcc/ada/sinput-l.ads @@ -0,0 +1,129 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S I N P U T . L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This child package contains the routines used to actually load a source +-- file and create entries in the source file table. It also contains the +-- routines to create virtual entries for instantiations. This is separated +-- off into a child package to avoid a dependence of Sinput on Osint which +-- would cause trouble in the tree read/write routines. + +package Sinput.L is + + ------------------------------------------ + -- Subprograms for Loading Source Files -- + ------------------------------------------ + + function Load_Source_File (N : File_Name_Type) return Source_File_Index; + -- Given a source file name, returns the index of the corresponding entry + -- in the source file table. If the file is not currently loaded, then + -- this is the call that causes the source file to be read and an entry + -- made in the table. A new entry in the table has the file name and time + -- stamp entries set and the Casing entries set to Unknown. Version is set + -- to all blanks, and the lines table is initialized but only the first + -- entry is set (and Last_Line is set to 1). If the given source file + -- cannot be opened, then the value returned is No_Source_File. + + function Load_Config_File (N : File_Name_Type) return Source_File_Index; + -- Similar to Load_Source_File, except that the file name is always + -- interpreted in the context of the current working directory. + -- The file is never preprocessed. + + function Load_Definition_File + (N : File_Name_Type) return Source_File_Index; + -- Loads preprocessing definition file. Similar to Load_Source_File + -- except that this file is not itself preprocessed. + + function Load_Preprocessing_Data_File + (N : File_Name_Type) return Source_File_Index; + -- Loads preprocessing data file. Similar to Load_Source_File except + -- that this file is not itself preprocessed. + + procedure Complete_Source_File_Entry; + -- Called on completing the parsing of a source file. This call completes + -- the source file table entry for the current source file. + + function Source_File_Is_No_Body (X : Source_File_Index) return Boolean; + -- Returns true if the designated source file contains pragma No_Body; + -- and no other tokens. If the source file contains anything other than + -- this sequence of three tokens, then False is returned. + + function Source_File_Is_Subunit (X : Source_File_Index) return Boolean; + -- This function determines if a source file represents a subunit. It + -- works by scanning for the first compilation unit token, and returning + -- True if it is the token SEPARATE. It will return False otherwise, + -- meaning that the file cannot possibly be a legal subunit. This + -- function does NOT do a complete parse of the file, or build a + -- tree. It is used in the main driver in the check for bad bodies. + + ------------------------------------------------- + -- Subprograms for Dealing With Instantiations -- + ------------------------------------------------- + + type Sloc_Adjustment is private; + -- Type returned by Create_Instantiation_Source for use in subsequent + -- calls to Adjust_Instantiation_Sloc. + + procedure Create_Instantiation_Source + (Inst_Node : Entity_Id; + Template_Id : Entity_Id; + Inlined_Body : Boolean; + A : out Sloc_Adjustment); + -- This procedure creates the source table entry for an instantiation. + -- Inst_Node is the instantiation node, and Template_Id is the defining + -- identifier of the generic declaration or body unit as appropriate. + -- A is set to an adjustment factor to be used in subsequent calls to + -- Adjust_Instantiation_Sloc. The instantiation mechanism is also used + -- for inlined function and procedure calls. The parameter Inlined_Body + -- is set to True in such cases, and False for a generic instantiation. + -- This is used for generating error messages that distinguish these + -- two cases, otherwise the two cases are handled identically. + + procedure Adjust_Instantiation_Sloc (N : Node_Id; A : Sloc_Adjustment); + -- The instantiation tree is created by copying the tree of the generic + -- template (including the original Sloc values), and then applying + -- Adjust_Instantiation_Sloc to each copied node to adjust the Sloc + -- to reference the source entry for the instantiation. + +private + + type Sloc_Adjustment is record + Adjust : Source_Ptr; + -- Adjustment factor. To be added to source location values in the + -- source table entry for the template to get corresponding sloc + -- values for the instantiation image of the template. This is not + -- really a Source_Ptr value, but rather an offset, but it is more + -- convenient to represent it as a Source_Ptr value and this is a + -- private type anyway. + + Lo, Hi : Source_Ptr; + -- Lo and hi values to which adjustment factor can legitimately + -- be applied, used to ensure that no incorrect adjustments are + -- made. Really it is a bug if anyone ever tries to adjust outside + -- this range, but since we are only doing this anyway for getting + -- better error messages, it is not critical + + end record; + +end Sinput.L; diff --git a/gcc/ada/sinput-p.adb b/gcc/ada/sinput-p.adb new file mode 100644 index 000000000..cd513d010 --- /dev/null +++ b/gcc/ada/sinput-p.adb @@ -0,0 +1,184 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S I N P U T . P -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 Ada.Unchecked_Deallocation; + +with Prj.Err; +with Sinput.C; + +with System; + +package body Sinput.P is + + First : Boolean := True; + -- Flag used when Load_Project_File is called the first time, + -- to set Main_Source_File. + -- The flag is reset to False at the first call to Load_Project_File. + -- Calling Reset_First sets it back to True. + + procedure Free is new Ada.Unchecked_Deallocation + (Lines_Table_Type, Lines_Table_Ptr); + + procedure Free is new Ada.Unchecked_Deallocation + (Logical_Lines_Table_Type, Logical_Lines_Table_Ptr); + + ----------------------------- + -- Clear_Source_File_Table -- + ----------------------------- + + procedure Clear_Source_File_Table is + use System; + + begin + for X in 1 .. Source_File.Last loop + declare + S : Source_File_Record renames Source_File.Table (X); + Lo : constant Source_Ptr := S.Source_First; + Hi : constant Source_Ptr := S.Source_Last; + subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi); + -- Physical buffer allocated + + type Actual_Source_Ptr is access Actual_Source_Buffer; + -- This is the pointer type for the physical buffer allocated + + procedure Free is new Ada.Unchecked_Deallocation + (Actual_Source_Buffer, Actual_Source_Ptr); + + pragma Suppress (All_Checks); + + pragma Warnings (Off); + -- The following unchecked conversion is aliased safe, since it + -- is not used to create improperly aliased pointer values. + + function To_Actual_Source_Ptr is new + Ada.Unchecked_Conversion (Address, Actual_Source_Ptr); + + pragma Warnings (On); + + Actual_Ptr : Actual_Source_Ptr := + To_Actual_Source_Ptr (S.Source_Text (Lo)'Address); + + begin + Free (Actual_Ptr); + Free (S.Lines_Table); + Free (S.Logical_Lines_Table); + end; + end loop; + + Source_File.Free; + Sinput.Initialize; + end Clear_Source_File_Table; + + ----------------------- + -- Load_Project_File -- + ----------------------- + + function Load_Project_File (Path : String) return Source_File_Index is + X : Source_File_Index; + + begin + X := Sinput.C.Load_File (Path); + + if First then + Main_Source_File := X; + First := False; + end if; + + return X; + end Load_Project_File; + + ----------------- + -- Reset_First -- + ----------------- + + procedure Reset_First is + begin + First := True; + end Reset_First; + + -------------------------------- + -- Restore_Project_Scan_State -- + -------------------------------- + + procedure Restore_Project_Scan_State + (Saved_State : Saved_Project_Scan_State) + is + begin + Restore_Scan_State (Saved_State.Scan_State); + Source := Saved_State.Source; + Current_Source_File := Saved_State.Current_Source_File; + end Restore_Project_Scan_State; + + ----------------------------- + -- Save_Project_Scan_State -- + ----------------------------- + + procedure Save_Project_Scan_State + (Saved_State : out Saved_Project_Scan_State) + is + begin + Save_Scan_State (Saved_State.Scan_State); + Saved_State.Source := Source; + Saved_State.Current_Source_File := Current_Source_File; + end Save_Project_Scan_State; + + ---------------------------- + -- Source_File_Is_Subunit -- + ---------------------------- + + function Source_File_Is_Subunit (X : Source_File_Index) return Boolean is + begin + -- Nothing to do if X is no source file, so simply return False + + if X = No_Source_File then + return False; + end if; + + Prj.Err.Scanner.Initialize_Scanner (X); + + -- No error for special characters that are used for preprocessing + + Prj.Err.Scanner.Set_Special_Character ('#'); + Prj.Err.Scanner.Set_Special_Character ('$'); + + -- We scan past junk to the first interesting compilation unit token, to + -- see if it is SEPARATE. We ignore WITH keywords during this and also + -- PRIVATE. The reason for ignoring PRIVATE is that it handles some + -- error situations, and also to handle PRIVATE WITH in Ada 2005 mode. + + while Token = Tok_With + or else Token = Tok_Private + or else (Token not in Token_Class_Cunit and then Token /= Tok_EOF) + loop + Prj.Err.Scanner.Scan; + end loop; + + Prj.Err.Scanner.Reset_Special_Characters; + + return Token = Tok_Separate; + end Source_File_Is_Subunit; + +end Sinput.P; diff --git a/gcc/ada/sinput-p.ads b/gcc/ada/sinput-p.ads new file mode 100644 index 000000000..112a6f7d5 --- /dev/null +++ b/gcc/ada/sinput-p.ads @@ -0,0 +1,82 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S I N P U T . P -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This child package contains the routines used to actually load a project +-- file and create entries in the source file table. It also contains two +-- routines to save and restore a project scan context. + +with Scans; use Scans; + +package Sinput.P is + + procedure Clear_Source_File_Table; + -- This procedure frees memory allocated in the Source_File table (in the + -- private part of package Sinput). It should only be used when it is + -- guaranteed that all source files that have been loaded so far will not + -- be accessed before being reloaded. It is intended for tools that parse + -- several times sources, to avoid memory leaks. + + function Load_Project_File (Path : String) return Source_File_Index; + -- Load the source of a project source file into memory and initialize the + -- Scans state. + + procedure Reset_First; + -- Indicate that the next project loaded should be considered as the first + -- one, so that Sinput.Main_Source_File is set for this project file. This + -- is to get the correct number of lines when error finalization is called. + + function Source_File_Is_Subunit (X : Source_File_Index) return Boolean; + -- This function determines if a source file represents a subunit. It works + -- by scanning for the first compilation unit token, and returning True if + -- it is the token SEPARATE. It will return False otherwise, meaning that + -- the file cannot possibly be a legal subunit. This function does NOT do a + -- complete parse of the file, or build a tree. It is used in gnatmake and + -- gprbuild to decide if a body without a spec in a project file needs to + -- be compiled or not. Returns False if X = No_Source_File. + + type Saved_Project_Scan_State is limited private; + -- Used to save project scan state in following two routines + + procedure Save_Project_Scan_State + (Saved_State : out Saved_Project_Scan_State); + pragma Inline (Save_Project_Scan_State); + -- Save the Scans state, as well as the values of Source and + -- Current_Source_File. + + procedure Restore_Project_Scan_State + (Saved_State : Saved_Project_Scan_State); + pragma Inline (Restore_Project_Scan_State); + -- Restore the Scans state and the values of Source and + -- Current_Source_File. + +private + + type Saved_Project_Scan_State is record + Scan_State : Saved_Scan_State; + Source : Source_Buffer_Ptr; + Current_Source_File : Source_File_Index; + end record; + +end Sinput.P; diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb new file mode 100644 index 000000000..6d0be93a5 --- /dev/null +++ b/gcc/ada/sinput.adb @@ -0,0 +1,1266 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S I N P U T -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Subprograms not all in alpha order + +with Atree; use Atree; +with Debug; use Debug; +with Opt; use Opt; +with Output; use Output; +with Tree_IO; use Tree_IO; +with System; use System; +with Widechar; use Widechar; + +with System.Memory; + +with Unchecked_Conversion; +with Unchecked_Deallocation; + +package body Sinput is + + use ASCII; + -- Make control characters visible + + First_Time_Around : Boolean := True; + + -- Routines to support conversion between types Lines_Table_Ptr, + -- Logical_Lines_Table_Ptr and System.Address. + + pragma Warnings (Off); + -- These unchecked conversions are aliasing safe, since they are never + -- used to construct improperly aliased pointer values. + + function To_Address is + new Unchecked_Conversion (Lines_Table_Ptr, Address); + + function To_Address is + new Unchecked_Conversion (Logical_Lines_Table_Ptr, Address); + + function To_Pointer is + new Unchecked_Conversion (Address, Lines_Table_Ptr); + + function To_Pointer is + new Unchecked_Conversion (Address, Logical_Lines_Table_Ptr); + + pragma Warnings (On); + + --------------------------- + -- Add_Line_Tables_Entry -- + --------------------------- + + procedure Add_Line_Tables_Entry + (S : in out Source_File_Record; + P : Source_Ptr) + is + LL : Physical_Line_Number; + + begin + -- Reallocate the lines tables if necessary + + -- Note: the reason we do not use the normal Table package + -- mechanism is that we have several of these tables. We could + -- use the new GNAT.Dynamic_Tables package and that would probably + -- be a good idea ??? + + if S.Last_Source_Line = S.Lines_Table_Max then + Alloc_Line_Tables + (S, + Int (S.Last_Source_Line) * + ((100 + Alloc.Lines_Increment) / 100)); + + if Debug_Flag_D then + Write_Str ("--> Reallocating lines table, size = "); + Write_Int (Int (S.Lines_Table_Max)); + Write_Eol; + end if; + end if; + + S.Last_Source_Line := S.Last_Source_Line + 1; + LL := S.Last_Source_Line; + + S.Lines_Table (LL) := P; + + -- Deal with setting new entry in logical lines table if one is + -- present. Note that there is always space (because the call to + -- Alloc_Line_Tables makes sure both tables are the same length), + + if S.Logical_Lines_Table /= null then + + -- We can always set the entry from the previous one, because + -- the processing for a Source_Reference pragma ensures that + -- at least one entry following the pragma is set up correctly. + + S.Logical_Lines_Table (LL) := S.Logical_Lines_Table (LL - 1) + 1; + end if; + end Add_Line_Tables_Entry; + + ----------------------- + -- Alloc_Line_Tables -- + ----------------------- + + procedure Alloc_Line_Tables + (S : in out Source_File_Record; + New_Max : Nat) + is + subtype size_t is Memory.size_t; + + New_Table : Lines_Table_Ptr; + + New_Logical_Table : Logical_Lines_Table_Ptr; + + New_Size : constant size_t := + size_t (New_Max * Lines_Table_Type'Component_Size / + Storage_Unit); + + begin + if S.Lines_Table = null then + New_Table := To_Pointer (Memory.Alloc (New_Size)); + + else + New_Table := + To_Pointer (Memory.Realloc (To_Address (S.Lines_Table), New_Size)); + end if; + + if New_Table = null then + raise Storage_Error; + else + S.Lines_Table := New_Table; + S.Lines_Table_Max := Physical_Line_Number (New_Max); + end if; + + if S.Num_SRef_Pragmas /= 0 then + if S.Logical_Lines_Table = null then + New_Logical_Table := To_Pointer (Memory.Alloc (New_Size)); + else + New_Logical_Table := To_Pointer + (Memory.Realloc (To_Address (S.Logical_Lines_Table), New_Size)); + end if; + + if New_Logical_Table = null then + raise Storage_Error; + else + S.Logical_Lines_Table := New_Logical_Table; + end if; + end if; + end Alloc_Line_Tables; + + ----------------- + -- Backup_Line -- + ----------------- + + procedure Backup_Line (P : in out Source_Ptr) is + Sindex : constant Source_File_Index := Get_Source_File_Index (P); + Src : constant Source_Buffer_Ptr := + Source_File.Table (Sindex).Source_Text; + Sfirst : constant Source_Ptr := + Source_File.Table (Sindex).Source_First; + + begin + P := P - 1; + + if P = Sfirst then + return; + end if; + + if Src (P) = CR then + if Src (P - 1) = LF then + P := P - 1; + end if; + + else -- Src (P) = LF + if Src (P - 1) = CR then + P := P - 1; + end if; + end if; + + -- Now find first character of the previous line + + while P > Sfirst + and then Src (P - 1) /= LF + and then Src (P - 1) /= CR + loop + P := P - 1; + end loop; + end Backup_Line; + + --------------------------- + -- Build_Location_String -- + --------------------------- + + procedure Build_Location_String (Loc : Source_Ptr) is + Ptr : Source_Ptr; + + begin + -- Loop through instantiations + + Ptr := Loc; + loop + Get_Name_String_And_Append + (Reference_Name (Get_Source_File_Index (Ptr))); + Add_Char_To_Name_Buffer (':'); + Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (Ptr))); + + Ptr := Instantiation_Location (Ptr); + exit when Ptr = No_Location; + Add_Str_To_Name_Buffer (" instantiated at "); + end loop; + + Name_Buffer (Name_Len + 1) := NUL; + return; + end Build_Location_String; + + function Build_Location_String (Loc : Source_Ptr) return String is + begin + Name_Len := 0; + Build_Location_String (Loc); + return Name_Buffer (1 .. Name_Len); + end Build_Location_String; + + ----------------------- + -- Get_Column_Number -- + ----------------------- + + function Get_Column_Number (P : Source_Ptr) return Column_Number is + S : Source_Ptr; + C : Column_Number; + Sindex : Source_File_Index; + Src : Source_Buffer_Ptr; + + begin + -- If the input source pointer is not a meaningful value then return + -- at once with column number 1. This can happen for a file not found + -- condition for a file loaded indirectly by RTE, and also perhaps on + -- some unknown internal error conditions. In either case we certainly + -- don't want to blow up. + + if P < 1 then + return 1; + + else + Sindex := Get_Source_File_Index (P); + Src := Source_File.Table (Sindex).Source_Text; + S := Line_Start (P); + C := 1; + + while S < P loop + if Src (S) = HT then + C := (C - 1) / 8 * 8 + (8 + 1); + else + C := C + 1; + end if; + + S := S + 1; + end loop; + + return C; + end if; + end Get_Column_Number; + + ----------------------------- + -- Get_Logical_Line_Number -- + ----------------------------- + + function Get_Logical_Line_Number + (P : Source_Ptr) return Logical_Line_Number + is + SFR : Source_File_Record + renames Source_File.Table (Get_Source_File_Index (P)); + + L : constant Physical_Line_Number := Get_Physical_Line_Number (P); + + begin + if SFR.Num_SRef_Pragmas = 0 then + return Logical_Line_Number (L); + else + return SFR.Logical_Lines_Table (L); + end if; + end Get_Logical_Line_Number; + + --------------------------------- + -- Get_Logical_Line_Number_Img -- + --------------------------------- + + function Get_Logical_Line_Number_Img + (P : Source_Ptr) return String + is + begin + Name_Len := 0; + Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (P))); + return Name_Buffer (1 .. Name_Len); + end Get_Logical_Line_Number_Img; + + ------------------------------ + -- Get_Physical_Line_Number -- + ------------------------------ + + function Get_Physical_Line_Number + (P : Source_Ptr) return Physical_Line_Number + is + Sfile : Source_File_Index; + Table : Lines_Table_Ptr; + Lo : Physical_Line_Number; + Hi : Physical_Line_Number; + Mid : Physical_Line_Number; + Loc : Source_Ptr; + + begin + -- If the input source pointer is not a meaningful value then return + -- at once with line number 1. This can happen for a file not found + -- condition for a file loaded indirectly by RTE, and also perhaps on + -- some unknown internal error conditions. In either case we certainly + -- don't want to blow up. + + if P < 1 then + return 1; + + -- Otherwise we can do the binary search + + else + Sfile := Get_Source_File_Index (P); + Loc := P + Source_File.Table (Sfile).Sloc_Adjust; + Table := Source_File.Table (Sfile).Lines_Table; + Lo := 1; + Hi := Source_File.Table (Sfile).Last_Source_Line; + + loop + Mid := (Lo + Hi) / 2; + + if Loc < Table (Mid) then + Hi := Mid - 1; + + else -- Loc >= Table (Mid) + + if Mid = Hi or else + Loc < Table (Mid + 1) + then + return Mid; + else + Lo := Mid + 1; + end if; + + end if; + + end loop; + end if; + end Get_Physical_Line_Number; + + --------------------------- + -- Get_Source_File_Index -- + --------------------------- + + Source_Cache_First : Source_Ptr := 1; + Source_Cache_Last : Source_Ptr := 0; + -- Records the First and Last subscript values for the most recently + -- referenced entry in the source table, to optimize the common case of + -- repeated references to the same entry. The initial values force an + -- initial search to set the cache value. + + Source_Cache_Index : Source_File_Index := No_Source_File; + -- Contains the index of the entry corresponding to Source_Cache + + function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index is + begin + if S in Source_Cache_First .. Source_Cache_Last then + return Source_Cache_Index; + + else + pragma Assert (Source_File_Index_Table (Int (S) / Chunk_Size) + /= + No_Source_File); + for J in Source_File_Index_Table (Int (S) / Chunk_Size) + .. Source_File.Last + loop + if S in Source_File.Table (J).Source_First .. + Source_File.Table (J).Source_Last + then + Source_Cache_Index := J; + Source_Cache_First := + Source_File.Table (Source_Cache_Index).Source_First; + Source_Cache_Last := + Source_File.Table (Source_Cache_Index).Source_Last; + return Source_Cache_Index; + end if; + end loop; + end if; + + -- We must find a matching entry in the above loop! + + raise Program_Error; + end Get_Source_File_Index; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Source_Cache_First := 1; + Source_Cache_Last := 0; + Source_Cache_Index := No_Source_File; + Source_gnat_adc := No_Source_File; + First_Time_Around := True; + + Source_File.Init; + end Initialize; + + ------------------------- + -- Instantiation_Depth -- + ------------------------- + + function Instantiation_Depth (S : Source_Ptr) return Nat is + Sind : Source_File_Index; + Sval : Source_Ptr; + Depth : Nat; + + begin + Sval := S; + Depth := 0; + + loop + Sind := Get_Source_File_Index (Sval); + Sval := Instantiation (Sind); + exit when Sval = No_Location; + Depth := Depth + 1; + end loop; + + return Depth; + end Instantiation_Depth; + + ---------------------------- + -- Instantiation_Location -- + ---------------------------- + + function Instantiation_Location (S : Source_Ptr) return Source_Ptr is + begin + return Instantiation (Get_Source_File_Index (S)); + end Instantiation_Location; + + ---------------------- + -- Last_Source_File -- + ---------------------- + + function Last_Source_File return Source_File_Index is + begin + return Source_File.Last; + end Last_Source_File; + + ---------------- + -- Line_Start -- + ---------------- + + function Line_Start (P : Source_Ptr) return Source_Ptr is + Sindex : constant Source_File_Index := Get_Source_File_Index (P); + Src : constant Source_Buffer_Ptr := + Source_File.Table (Sindex).Source_Text; + Sfirst : constant Source_Ptr := + Source_File.Table (Sindex).Source_First; + S : Source_Ptr; + + begin + S := P; + while S > Sfirst + and then Src (S - 1) /= CR + and then Src (S - 1) /= LF + loop + S := S - 1; + end loop; + + return S; + end Line_Start; + + function Line_Start + (L : Physical_Line_Number; + S : Source_File_Index) return Source_Ptr + is + begin + return Source_File.Table (S).Lines_Table (L); + end Line_Start; + + ---------- + -- Lock -- + ---------- + + procedure Lock is + begin + Source_File.Locked := True; + Source_File.Release; + end Lock; + + ---------------------- + -- Num_Source_Files -- + ---------------------- + + function Num_Source_Files return Nat is + begin + return Int (Source_File.Last) - Int (Source_File.First) + 1; + end Num_Source_Files; + + ---------------------- + -- Num_Source_Lines -- + ---------------------- + + function Num_Source_Lines (S : Source_File_Index) return Nat is + begin + return Nat (Source_File.Table (S).Last_Source_Line); + end Num_Source_Lines; + + ----------------------- + -- Original_Location -- + ----------------------- + + function Original_Location (S : Source_Ptr) return Source_Ptr is + Sindex : Source_File_Index; + Tindex : Source_File_Index; + + begin + if S <= No_Location then + return S; + + else + Sindex := Get_Source_File_Index (S); + + if Instantiation (Sindex) = No_Location then + return S; + + else + Tindex := Template (Sindex); + while Instantiation (Tindex) /= No_Location loop + Tindex := Template (Tindex); + end loop; + + return S - Source_First (Sindex) + Source_First (Tindex); + end if; + end if; + end Original_Location; + + ------------------------- + -- Physical_To_Logical -- + ------------------------- + + function Physical_To_Logical + (Line : Physical_Line_Number; + S : Source_File_Index) return Logical_Line_Number + is + SFR : Source_File_Record renames Source_File.Table (S); + + begin + if SFR.Num_SRef_Pragmas = 0 then + return Logical_Line_Number (Line); + else + return SFR.Logical_Lines_Table (Line); + end if; + end Physical_To_Logical; + + -------------------------------- + -- Register_Source_Ref_Pragma -- + -------------------------------- + + procedure Register_Source_Ref_Pragma + (File_Name : File_Name_Type; + Stripped_File_Name : File_Name_Type; + Mapped_Line : Nat; + Line_After_Pragma : Physical_Line_Number) + is + subtype size_t is Memory.size_t; + + SFR : Source_File_Record renames Source_File.Table (Current_Source_File); + + ML : Logical_Line_Number; + + begin + if File_Name /= No_File then + SFR.Reference_Name := Stripped_File_Name; + SFR.Full_Ref_Name := File_Name; + + if not Debug_Generated_Code then + SFR.Debug_Source_Name := Stripped_File_Name; + SFR.Full_Debug_Name := File_Name; + end if; + + SFR.Num_SRef_Pragmas := SFR.Num_SRef_Pragmas + 1; + end if; + + if SFR.Num_SRef_Pragmas = 1 then + SFR.First_Mapped_Line := Logical_Line_Number (Mapped_Line); + end if; + + if SFR.Logical_Lines_Table = null then + SFR.Logical_Lines_Table := To_Pointer + (Memory.Alloc + (size_t (SFR.Lines_Table_Max * + Logical_Lines_Table_Type'Component_Size / + Storage_Unit))); + end if; + + SFR.Logical_Lines_Table (Line_After_Pragma - 1) := No_Line_Number; + + ML := Logical_Line_Number (Mapped_Line); + for J in Line_After_Pragma .. SFR.Last_Source_Line loop + SFR.Logical_Lines_Table (J) := ML; + ML := ML + 1; + end loop; + end Register_Source_Ref_Pragma; + + --------------------------------- + -- Set_Source_File_Index_Table -- + --------------------------------- + + procedure Set_Source_File_Index_Table (Xnew : Source_File_Index) is + Ind : Int; + SP : Source_Ptr; + SL : constant Source_Ptr := Source_File.Table (Xnew).Source_Last; + + begin + SP := (Source_File.Table (Xnew).Source_First + Chunk_Size - 1) + / Chunk_Size * Chunk_Size; + Ind := Int (SP) / Chunk_Size; + + while SP <= SL loop + Source_File_Index_Table (Ind) := Xnew; + SP := SP + Chunk_Size; + Ind := Ind + 1; + end loop; + end Set_Source_File_Index_Table; + + --------------------------- + -- Skip_Line_Terminators -- + --------------------------- + + procedure Skip_Line_Terminators + (P : in out Source_Ptr; + Physical : out Boolean) + is + Chr : constant Character := Source (P); + + begin + if Chr = CR then + if Source (P + 1) = LF then + P := P + 2; + else + P := P + 1; + end if; + + elsif Chr = LF then + P := P + 1; + + elsif Chr = FF or else Chr = VT then + P := P + 1; + Physical := False; + return; + + -- Otherwise we have a wide character + + else + Skip_Wide (Source, P); + end if; + + -- Fall through in the physical line terminator case. First deal with + -- making a possible entry into the lines table if one is needed. + + -- Note: we are dealing with a real source file here, this cannot be + -- the instantiation case, so we need not worry about Sloc adjustment. + + declare + S : Source_File_Record + renames Source_File.Table (Current_Source_File); + + begin + Physical := True; + + -- Make entry in lines table if not already made (in some scan backup + -- cases, we will be rescanning previously scanned source, so the + -- entry may have already been made on the previous forward scan). + + if Source (P) /= EOF + and then P > S.Lines_Table (S.Last_Source_Line) + then + Add_Line_Tables_Entry (S, P); + end if; + end; + end Skip_Line_Terminators; + + ---------------- + -- Sloc_Range -- + ---------------- + + procedure Sloc_Range (N : Node_Id; Min, Max : out Source_Ptr) is + + function Process (N : Node_Id) return Traverse_Result; + -- Process function for traversing the node tree + + procedure Traverse is new Traverse_Proc (Process); + + ------------- + -- Process -- + ------------- + + function Process (N : Node_Id) return Traverse_Result is + begin + if Sloc (N) < Min then + if Sloc (N) > No_Location then + Min := Sloc (N); + end if; + elsif Sloc (N) > Max then + if Sloc (N) > No_Location then + Max := Sloc (N); + end if; + end if; + + return OK; + end Process; + + -- Start of processing for Sloc_Range + + begin + Min := Sloc (N); + Max := Sloc (N); + Traverse (N); + end Sloc_Range; + + ------------------- + -- Source_Offset -- + ------------------- + + function Source_Offset (S : Source_Ptr) return Nat is + Sindex : constant Source_File_Index := Get_Source_File_Index (S); + Sfirst : constant Source_Ptr := + Source_File.Table (Sindex).Source_First; + begin + return Nat (S - Sfirst); + end Source_Offset; + + ------------------------ + -- Top_Level_Location -- + ------------------------ + + function Top_Level_Location (S : Source_Ptr) return Source_Ptr is + Oldloc : Source_Ptr; + Newloc : Source_Ptr; + + begin + Newloc := S; + loop + Oldloc := Newloc; + Newloc := Instantiation_Location (Oldloc); + exit when Newloc = No_Location; + end loop; + + return Oldloc; + end Top_Level_Location; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + begin + -- First we must free any old source buffer pointers + + if not First_Time_Around then + for J in Source_File.First .. Source_File.Last loop + declare + S : Source_File_Record renames Source_File.Table (J); + + procedure Free_Ptr is new Unchecked_Deallocation + (Big_Source_Buffer, Source_Buffer_Ptr); + + pragma Warnings (Off); + -- This unchecked conversion is aliasing safe, since it is not + -- used to create improperly aliased pointer values. + + function To_Source_Buffer_Ptr is new + Unchecked_Conversion (Address, Source_Buffer_Ptr); + + pragma Warnings (On); + + Tmp1 : Source_Buffer_Ptr; + + begin + if S.Instantiation /= No_Location then + null; + + else + -- Free the buffer, we use Free here, because we used malloc + -- or realloc directly to allocate the tables. That is + -- because we were playing the big array trick. + + -- We have to recreate a proper pointer to the actual array + -- from the zero origin pointer stored in the source table. + + Tmp1 := + To_Source_Buffer_Ptr + (S.Source_Text (S.Source_First)'Address); + Free_Ptr (Tmp1); + + if S.Lines_Table /= null then + Memory.Free (To_Address (S.Lines_Table)); + S.Lines_Table := null; + end if; + + if S.Logical_Lines_Table /= null then + Memory.Free (To_Address (S.Logical_Lines_Table)); + S.Logical_Lines_Table := null; + end if; + end if; + end; + end loop; + end if; + + -- Reset source cache pointers to force new read + + Source_Cache_First := 1; + Source_Cache_Last := 0; + + -- Read in source file table + + Source_File.Tree_Read; + + -- The pointers we read in there for the source buffer and lines + -- table pointers are junk. We now read in the actual data that + -- is referenced by these two fields. + + for J in Source_File.First .. Source_File.Last loop + declare + S : Source_File_Record renames Source_File.Table (J); + + begin + -- For the instantiation case, we do not read in any data. Instead + -- we share the data for the generic template entry. Since the + -- template always occurs first, we can safely refer to its data. + + if S.Instantiation /= No_Location then + declare + ST : Source_File_Record renames + Source_File.Table (S.Template); + + begin + -- The lines tables are copied from the template entry + + S.Lines_Table := + Source_File.Table (S.Template).Lines_Table; + S.Logical_Lines_Table := + Source_File.Table (S.Template).Logical_Lines_Table; + + -- In the case of the source table pointer, we share the + -- same data as the generic template, but the virtual origin + -- is adjusted. For example, if the first subscript of the + -- template is 100, and that of the instantiation is 200, + -- then the instantiation pointer is obtained by subtracting + -- 100 from the template pointer. + + declare + pragma Suppress (All_Checks); + + pragma Warnings (Off); + -- This unchecked conversion is aliasing safe since it + -- not used to create improperly aliased pointer values. + + function To_Source_Buffer_Ptr is new + Unchecked_Conversion (Address, Source_Buffer_Ptr); + + pragma Warnings (On); + + begin + S.Source_Text := + To_Source_Buffer_Ptr + (ST.Source_Text + (ST.Source_First - S.Source_First)'Address); + end; + end; + + -- Normal case (non-instantiation) + + else + First_Time_Around := False; + S.Lines_Table := null; + S.Logical_Lines_Table := null; + Alloc_Line_Tables (S, Int (S.Last_Source_Line)); + + for J in 1 .. S.Last_Source_Line loop + Tree_Read_Int (Int (S.Lines_Table (J))); + end loop; + + if S.Num_SRef_Pragmas /= 0 then + for J in 1 .. S.Last_Source_Line loop + Tree_Read_Int (Int (S.Logical_Lines_Table (J))); + end loop; + end if; + + -- Allocate source buffer and read in the data and then set the + -- virtual origin to point to the logical zero'th element. This + -- address must be computed with subscript checks turned off. + + declare + subtype B is Text_Buffer (S.Source_First .. S.Source_Last); + type Text_Buffer_Ptr is access B; + T : Text_Buffer_Ptr; + + pragma Suppress (All_Checks); + + pragma Warnings (Off); + -- This unchecked conversion is aliasing safe, since it is + -- never used to create improperly aliased pointer values. + + function To_Source_Buffer_Ptr is new + Unchecked_Conversion (Address, Source_Buffer_Ptr); + + pragma Warnings (On); + + begin + T := new B; + + Tree_Read_Data (T (S.Source_First)'Address, + Int (S.Source_Last) - Int (S.Source_First) + 1); + + S.Source_Text := To_Source_Buffer_Ptr (T (0)'Address); + end; + end if; + end; + + Set_Source_File_Index_Table (J); + end loop; + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + begin + Source_File.Tree_Write; + + -- The pointers we wrote out there for the source buffer and lines + -- table pointers are junk, we now write out the actual data that + -- is referenced by these two fields. + + for J in Source_File.First .. Source_File.Last loop + declare + S : Source_File_Record renames Source_File.Table (J); + + begin + -- For instantiations, there is nothing to do, since the data is + -- shared with the generic template. When the tree is read, the + -- pointers must be set, but no extra data needs to be written. + + if S.Instantiation /= No_Location then + null; + + -- For the normal case, write out the data of the tables + + else + -- Lines table + + for J in 1 .. S.Last_Source_Line loop + Tree_Write_Int (Int (S.Lines_Table (J))); + end loop; + + -- Logical lines table if present + + if S.Num_SRef_Pragmas /= 0 then + for J in 1 .. S.Last_Source_Line loop + Tree_Write_Int (Int (S.Logical_Lines_Table (J))); + end loop; + end if; + + -- Source buffer + + Tree_Write_Data + (S.Source_Text (S.Source_First)'Address, + Int (S.Source_Last) - Int (S.Source_First) + 1); + end if; + end; + end loop; + end Tree_Write; + + -------------------- + -- Write_Location -- + -------------------- + + procedure Write_Location (P : Source_Ptr) is + begin + if P = No_Location then + Write_Str (""); + + elsif P <= Standard_Location then + Write_Str (""); + + else + declare + SI : constant Source_File_Index := Get_Source_File_Index (P); + + begin + Write_Name (Debug_Source_Name (SI)); + Write_Char (':'); + Write_Int (Int (Get_Logical_Line_Number (P))); + Write_Char (':'); + Write_Int (Int (Get_Column_Number (P))); + + if Instantiation (SI) /= No_Location then + Write_Str (" ["); + Write_Location (Instantiation (SI)); + Write_Char (']'); + end if; + end; + end if; + end Write_Location; + + ---------------------- + -- Write_Time_Stamp -- + ---------------------- + + procedure Write_Time_Stamp (S : Source_File_Index) is + T : constant Time_Stamp_Type := Time_Stamp (S); + P : Natural; + + begin + if T (1) = '9' then + Write_Str ("19"); + P := 0; + else + Write_Char (T (1)); + Write_Char (T (2)); + P := 2; + end if; + + Write_Char (T (P + 1)); + Write_Char (T (P + 2)); + Write_Char ('-'); + + Write_Char (T (P + 3)); + Write_Char (T (P + 4)); + Write_Char ('-'); + + Write_Char (T (P + 5)); + Write_Char (T (P + 6)); + Write_Char (' '); + + Write_Char (T (P + 7)); + Write_Char (T (P + 8)); + Write_Char (':'); + + Write_Char (T (P + 9)); + Write_Char (T (P + 10)); + Write_Char (':'); + + Write_Char (T (P + 11)); + Write_Char (T (P + 12)); + end Write_Time_Stamp; + + ---------------------------------------------- + -- Access Subprograms for Source File Table -- + ---------------------------------------------- + + function Debug_Source_Name (S : SFI) return File_Name_Type is + begin + return Source_File.Table (S).Debug_Source_Name; + end Debug_Source_Name; + + function File_Name (S : SFI) return File_Name_Type is + begin + return Source_File.Table (S).File_Name; + end File_Name; + + function File_Type (S : SFI) return Type_Of_File is + begin + return Source_File.Table (S).File_Type; + end File_Type; + + function First_Mapped_Line (S : SFI) return Logical_Line_Number is + begin + return Source_File.Table (S).First_Mapped_Line; + end First_Mapped_Line; + + function Full_Debug_Name (S : SFI) return File_Name_Type is + begin + return Source_File.Table (S).Full_Debug_Name; + end Full_Debug_Name; + + function Full_File_Name (S : SFI) return File_Name_Type is + begin + return Source_File.Table (S).Full_File_Name; + end Full_File_Name; + + function Full_Ref_Name (S : SFI) return File_Name_Type is + begin + return Source_File.Table (S).Full_Ref_Name; + end Full_Ref_Name; + + function Identifier_Casing (S : SFI) return Casing_Type is + begin + return Source_File.Table (S).Identifier_Casing; + end Identifier_Casing; + + function Inlined_Body (S : SFI) return Boolean is + begin + return Source_File.Table (S).Inlined_Body; + end Inlined_Body; + + function Instantiation (S : SFI) return Source_Ptr is + begin + return Source_File.Table (S).Instantiation; + end Instantiation; + + function Keyword_Casing (S : SFI) return Casing_Type is + begin + return Source_File.Table (S).Keyword_Casing; + end Keyword_Casing; + + function Last_Source_Line (S : SFI) return Physical_Line_Number is + begin + return Source_File.Table (S).Last_Source_Line; + end Last_Source_Line; + + function License (S : SFI) return License_Type is + begin + return Source_File.Table (S).License; + end License; + + function Num_SRef_Pragmas (S : SFI) return Nat is + begin + return Source_File.Table (S).Num_SRef_Pragmas; + end Num_SRef_Pragmas; + + function Reference_Name (S : SFI) return File_Name_Type is + begin + return Source_File.Table (S).Reference_Name; + end Reference_Name; + + function Source_Checksum (S : SFI) return Word is + begin + return Source_File.Table (S).Source_Checksum; + end Source_Checksum; + + function Source_First (S : SFI) return Source_Ptr is + begin + if S = Internal_Source_File then + return Internal_Source'First; + else + return Source_File.Table (S).Source_First; + end if; + end Source_First; + + function Source_Last (S : SFI) return Source_Ptr is + begin + if S = Internal_Source_File then + return Internal_Source'Last; + else + return Source_File.Table (S).Source_Last; + end if; + end Source_Last; + + function Source_Text (S : SFI) return Source_Buffer_Ptr is + begin + if S = Internal_Source_File then + return Internal_Source_Ptr; + else + return Source_File.Table (S).Source_Text; + end if; + end Source_Text; + + function Template (S : SFI) return SFI is + begin + return Source_File.Table (S).Template; + end Template; + + function Time_Stamp (S : SFI) return Time_Stamp_Type is + begin + return Source_File.Table (S).Time_Stamp; + end Time_Stamp; + + function Unit (S : SFI) return Unit_Number_Type is + begin + return Source_File.Table (S).Unit; + end Unit; + + ------------------------------------------ + -- Set Procedures for Source File Table -- + ------------------------------------------ + + procedure Set_Identifier_Casing (S : SFI; C : Casing_Type) is + begin + Source_File.Table (S).Identifier_Casing := C; + end Set_Identifier_Casing; + + procedure Set_Keyword_Casing (S : SFI; C : Casing_Type) is + begin + Source_File.Table (S).Keyword_Casing := C; + end Set_Keyword_Casing; + + procedure Set_License (S : SFI; L : License_Type) is + begin + Source_File.Table (S).License := L; + end Set_License; + + procedure Set_Unit (S : SFI; U : Unit_Number_Type) is + begin + Source_File.Table (S).Unit := U; + end Set_Unit; + + ---------------------- + -- Trim_Lines_Table -- + ---------------------- + + procedure Trim_Lines_Table (S : Source_File_Index) is + Max : constant Nat := Nat (Source_File.Table (S).Last_Source_Line); + + begin + -- Release allocated storage that is no longer needed + + Source_File.Table (S).Lines_Table := To_Pointer + (Memory.Realloc + (To_Address (Source_File.Table (S).Lines_Table), + Memory.size_t + (Max * (Lines_Table_Type'Component_Size / System.Storage_Unit)))); + Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max); + end Trim_Lines_Table; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock is + begin + Source_File.Locked := False; + Source_File.Release; + end Unlock; + + -------- + -- wl -- + -------- + + procedure wl (P : Source_Ptr) is + begin + Write_Location (P); + Write_Eol; + end wl; + +end Sinput; diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads new file mode 100644 index 000000000..bdc268eaf --- /dev/null +++ b/gcc/ada/sinput.ads @@ -0,0 +1,827 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S I N P U T -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the input routines used for reading the +-- input source file. The actual I/O routines are in OS_Interface, +-- with this module containing only the system independent processing. + +-- General Note: throughout the compiler, we use the term line or source +-- line to refer to a physical line in the source, terminated by the end of +-- physical line sequence. + +-- There are two distinct concepts of line terminator in GNAT + +-- A logical line terminator is what corresponds to the "end of a line" as +-- described in RM 2.2 (13). Any of the characters FF, LF, CR or VT or any +-- wide character that is a Line or Paragraph Separator acts as an end of +-- logical line in this sense, and it is essentially irrelevant whether one +-- or more appears in sequence (since if sequence of such characters is +-- regarded as separate ends of line, then the intervening logical lines +-- are null in any case). + +-- A physical line terminator is a sequence of format effectors that is +-- treated as ending a physical line. Physical lines have no Ada semantic +-- significance, but they are significant for error reporting purposes, +-- since errors are identified by line and column location. + +-- In GNAT, a physical line is ended by any of the sequences LF, CR/LF, or +-- CR. LF is used in typical Unix systems, CR/LF in DOS systems, and CR +-- alone in System 7. In addition, we recognize any of these sequences in +-- any of the operating systems, for better behavior in treating foreign +-- files (e.g. a Unix file with LF terminators transferred to a DOS system). +-- Finally, wide character codes in categories Separator, Line and Separator, +-- Paragraph are considered to be physical line terminators. + +with Alloc; +with Casing; use Casing; +with Namet; use Namet; +with Table; +with Types; use Types; + +package Sinput is + + type Type_Of_File is ( + -- Indicates type of file being read + + Src, + -- Normal Ada source file + + Config, + -- Configuration pragma file + + Def, + -- Preprocessing definition file + + Preproc); + -- Source file with preprocessing commands to be preprocessed + + ---------------------------- + -- Source License Control -- + ---------------------------- + + -- The following type indicates the license state of a source if it + -- is known. + + type License_Type is + (Unknown, + -- Licensing status of this source unit is unknown + + Restricted, + -- This is a non-GPL'ed unit that is restricted from depending + -- on GPL'ed units (e.g. proprietary code is in this category) + + GPL, + -- This file is licensed under the unmodified GPL. It is not allowed + -- to depend on Non_GPL units, and Non_GPL units may not depend on + -- this source unit. + + Modified_GPL, + -- This file is licensed under the GNAT modified GPL (see header of + -- This file for wording of the modification). It may depend on other + -- Modified_GPL units or on unrestricted units. + + Unrestricted); + -- The license on this file is permitted to depend on any other + -- units, or have other units depend on it, without violating the + -- license of this unit. Examples are public domain units, and + -- units defined in the RM). + + -- The above license status is checked when the appropriate check is + -- activated and one source depends on another, and the licensing state + -- of both files is known: + + -- The prohibited combinations are: + + -- Restricted file may not depend on GPL file + + -- GPL file may not depend on Restricted file + + -- Modified GPL file may not depend on Restricted file + -- Modified_GPL file may not depend on GPL file + + -- The reason for the last restriction here is that a client depending + -- on a modified GPL file must be sure that the license condition is + -- correct considered transitively. + + -- The licensing status is determined either by the presence of a + -- specific pragma License, or by scanning the header for a predefined + -- file, or any file if compiling in -gnatg mode. + + ----------------------- + -- Source File Table -- + ----------------------- + + -- The source file table has an entry for each source file read in for + -- this run of the compiler. This table is (default) initialized when + -- the compiler is loaded, and simply accumulates entries as compilation + -- proceeds and various routines in Sinput and its child packages are + -- called to load required source files. + + -- Virtual entries are also created for generic templates when they are + -- instantiated, as described in a separate section later on. + + -- In the case where there are multiple main units (e.g. in the case of + -- the cross-reference tool), this table is not reset between these units, + -- so that a given source file is only read once if it is used by two + -- separate main units. + + -- The entries in the table are accessed using a Source_File_Index that + -- ranges from 1 to Last_Source_File. Each entry has the following fields + + -- Note: fields marked read-only are set by Sinput or one of its child + -- packages when a source file table entry is created, and cannot be + -- subsequently modified, or alternatively are set only by very special + -- circumstances, documented in the comments. + + -- File_Name : File_Name_Type (read-only) + -- Name of the source file (simple name with no directory information) + + -- Full_File_Name : File_Name_Type (read-only) + -- Full file name (full name with directory info), used for generation + -- of error messages, etc. + + -- File_Type : Type_Of_File (read-only) + -- Indicates type of file (source file, configuration pragmas file, + -- preprocessor definition file, preprocessor input file). + + -- Reference_Name : File_Name_Type (read-only) + -- Name to be used for source file references in error messages where + -- only the simple name of the file is required. Identical to File_Name + -- unless pragma Source_Reference is used to change it. Only processing + -- for the Source_Reference pragma circuit may set this field. + + -- Full_Ref_Name : File_Name_Type (read-only) + -- Name to be used for source file references in error messages where + -- the full name of the file is required. Identical to Full_File_Name + -- unless pragma Source_Reference is used to change it. Only processing + -- for the Source_Reference pragma may set this field. + + -- Debug_Source_Name : File_Name_Type (read-only) + -- Name to be used for source file references in debugging information + -- where only the simple name of the file is required. Identical to + -- Reference_Name unless the -gnatD (debug source file) switch is used. + -- Only processing in Sprint that generates this file is permitted to + -- set this field. + + -- Full_Debug_Name : File_Name_Type (read-only) + -- Name to be used for source file references in debugging information + -- where the full name of the file is required. This is identical to + -- Full_Ref_Name unless the -gnatD (debug source file) switch is used. + -- Only processing in Sprint that generates this file is permitted to + -- set this field. + + -- License : License_Type; + -- License status of source file + + -- Num_SRef_Pragmas : Nat; + -- Number of source reference pragmas present in source file + + -- First_Mapped_Line : Logical_Line_Number; + -- This field stores logical line number of the first line in the + -- file that is not a Source_Reference pragma. If no source reference + -- pragmas are used, then the value is set to No_Line_Number. + + -- Source_Text : Source_Buffer_Ptr (read-only) + -- Text of source file. Note that every source file has a distinct set + -- of non-overlapping logical bounds, so it is possible to determine + -- which file is referenced from a given subscript (Source_Ptr) value. + + -- Source_First : Source_Ptr; (read-only) + -- Subscript of first character in Source_Text. Note that this cannot + -- be obtained as Source_Text'First, because we use virtual origin + -- addressing. + + -- Source_Last : Source_Ptr; (read-only) + -- Subscript of last character in Source_Text. Note that this cannot + -- be obtained as Source_Text'Last, because we use virtual origin + -- addressing, so this value is always Source_Ptr'Last. + + -- Time_Stamp : Time_Stamp_Type; (read-only) + -- Time stamp of the source file + + -- Source_Checksum : Word; + -- Computed checksum for contents of source file. See separate section + -- later on in this spec for a description of the checksum algorithm. + + -- Last_Source_Line : Physical_Line_Number; + -- Physical line number of last source line. While a file is being + -- read, this refers to the last line scanned. Once a file has been + -- completely scanned, it is the number of the last line in the file, + -- and hence also gives the number of source lines in the file. + + -- Keyword_Casing : Casing_Type; + -- Casing style used in file for keyword casing. This is initialized + -- to Unknown, and then set from the first occurrence of a keyword. + -- This value is used only for formatting of error messages. + + -- Identifier_Casing : Casing_Type; + -- Casing style used in file for identifier casing. This is initialized + -- to Unknown, and then set from an identifier in the program as soon as + -- one is found whose casing is sufficiently clear to make a decision. + -- This value is used for formatting of error messages, and also is used + -- in the detection of keywords misused as identifiers. + + -- Instantiation : Source_Ptr; + -- Source file location of the instantiation if this source file entry + -- represents a generic instantiation. Set to No_Location for the case + -- of a normal non-instantiation entry. See section below for details. + -- This field is read-only for clients. + + -- Inlined_Body : Boolean; + -- This can only be set True if Instantiation has a value other than + -- No_Location. If true it indicates that the instantiation is actually + -- an instance of an inlined body. + + -- Template : Source_File_Index; (read-only) + -- Source file index of the source file containing the template if this + -- is a generic instantiation. Set to No_Source_File for the normal case + -- of a non-instantiation entry. See Sinput-L for details. + + -- Unit : Unit_Number_Type; + -- Identifies the unit contained in this source file. Set by + -- Initialize_Scanner, must not be subsequently altered. + + -- The source file table is accessed by clients using the following + -- subprogram interface: + + subtype SFI is Source_File_Index; + + System_Source_File_Index : SFI; + -- The file system.ads is always read by the compiler to determine the + -- settings of the target parameters in the private part of System. This + -- variable records the source file index of system.ads. Typically this + -- will be 1 since system.ads is read first. + + function Debug_Source_Name (S : SFI) return File_Name_Type; + function File_Name (S : SFI) return File_Name_Type; + function File_Type (S : SFI) return Type_Of_File; + function First_Mapped_Line (S : SFI) return Logical_Line_Number; + function Full_Debug_Name (S : SFI) return File_Name_Type; + function Full_File_Name (S : SFI) return File_Name_Type; + function Full_Ref_Name (S : SFI) return File_Name_Type; + function Identifier_Casing (S : SFI) return Casing_Type; + function Inlined_Body (S : SFI) return Boolean; + function Instantiation (S : SFI) return Source_Ptr; + function Keyword_Casing (S : SFI) return Casing_Type; + function Last_Source_Line (S : SFI) return Physical_Line_Number; + function License (S : SFI) return License_Type; + function Num_SRef_Pragmas (S : SFI) return Nat; + function Reference_Name (S : SFI) return File_Name_Type; + function Source_Checksum (S : SFI) return Word; + function Source_First (S : SFI) return Source_Ptr; + function Source_Last (S : SFI) return Source_Ptr; + function Source_Text (S : SFI) return Source_Buffer_Ptr; + function Template (S : SFI) return Source_File_Index; + function Unit (S : SFI) return Unit_Number_Type; + function Time_Stamp (S : SFI) return Time_Stamp_Type; + + procedure Set_Keyword_Casing (S : SFI; C : Casing_Type); + procedure Set_Identifier_Casing (S : SFI; C : Casing_Type); + procedure Set_License (S : SFI; L : License_Type); + procedure Set_Unit (S : SFI; U : Unit_Number_Type); + + function Last_Source_File return Source_File_Index; + -- Index of last source file table entry + + function Num_Source_Files return Nat; + -- Number of source file table entries + + procedure Initialize; + -- Initialize internal tables + + procedure Lock; + -- Lock internal tables + + procedure Unlock; + -- Unlock internal tables + + Main_Source_File : Source_File_Index := No_Source_File; + -- This is set to the source file index of the main unit + + ----------------------------- + -- Source_File_Index_Table -- + ----------------------------- + + -- The Get_Source_File_Index function is called very frequently. Earlier + -- versions cached a single entry, but then reverted to a serial search, + -- and this proved to be a significant source of inefficiency. To get + -- around this, we use the following directly indexed array. The space + -- of possible input values is a value of type Source_Ptr which is simply + -- an Int value. The values in this space are allocated sequentially as + -- new units are loaded. + + -- The following table has an entry for each 4K range of possible + -- Source_Ptr values. The value in the table is the lowest value + -- Source_File_Index whose Source_Ptr range contains value in the + -- range. + + -- For example, the entry with index 4 in this table represents Source_Ptr + -- values in the range 4*4096 .. 5*4096-1. The Source_File_Index value + -- stored would be the lowest numbered source file with at least one byte + -- in this range. + + -- The algorithm used in Get_Source_File_Index is simply to access this + -- table and then do a serial search starting at the given position. This + -- will almost always terminate with one or two checks. + + -- Note that this array is pretty large, but in most operating systems + -- it will not be allocated in physical memory unless it is actually used. + + Chunk_Power : constant := 12; + Chunk_Size : constant := 2 ** Chunk_Power; + -- Change comments above if value changed. Note that Chunk_Size must + -- be a power of 2 (to allow for efficient access to the table). + + Source_File_Index_Table : + array (Int range 0 .. Int'Last / Chunk_Size) of Source_File_Index; + + procedure Set_Source_File_Index_Table (Xnew : Source_File_Index); + -- Sets entries in the Source_File_Index_Table for the newly created + -- Source_File table entry whose index is Xnew. The Source_First and + -- Source_Last fields of this entry must be set before the call. + + ----------------------- + -- Checksum Handling -- + ----------------------- + + -- As a source file is scanned, a checksum is computed by taking all the + -- non-blank characters in the file, excluding comment characters, the + -- minus-minus sequence starting a comment, and all control characters + -- except ESC. + + -- The checksum algorithm used is the standard CRC-32 algorithm, as + -- implemented by System.CRC32, except that we do not bother with the + -- final XOR with all 1 bits. + + -- This algorithm ensures that the checksum includes all semantically + -- significant aspects of the program represented by the source file, + -- but is insensitive to layout, presence or contents of comments, wide + -- character representation method, or casing conventions outside strings. + + -- Scans.Checksum is initialized appropriately at the start of scanning + -- a file, and copied into the Source_Checksum field of the file table + -- entry when the end of file is encountered. + + ------------------------------------- + -- Handling Generic Instantiations -- + ------------------------------------- + + -- As described in Sem_Ch12, a generic instantiation involves making a + -- copy of the tree of the generic template. The source locations in + -- this tree directly reference the source of the template. However it + -- is also possible to find the location of the instantiation. + + -- This is achieved as follows. When an instantiation occurs, a new entry + -- is made in the source file table. This entry points to the same source + -- text, i.e. the file that contains the instantiation, but has a distinct + -- set of Source_Ptr index values. The separate range of Sloc values avoids + -- confusion, and means that the Sloc values can still be used to uniquely + -- identify the source file table entry. It is possible for both entries + -- to point to the same text, because of the virtual origin pointers used + -- in the source table. + + -- The Instantiation field of this source file index entry, usually set + -- to No_Source_File, instead contains the Sloc of the instantiation. In + -- the case of nested instantiations, this Sloc may itself refer to an + -- instantiation, so the complete chain can be traced. + + -- Two routines are used to build these special entries in the source + -- file table. Create_Instantiation_Source is first called to build + -- the virtual source table entry for the instantiation, and then the + -- Sloc values in the copy are adjusted using Adjust_Instantiation_Sloc. + -- See child unit Sinput.L for details on these two routines. + + ----------------- + -- Global Data -- + ----------------- + + Current_Source_File : Source_File_Index := No_Source_File; + -- Source_File table index of source file currently being scanned. + -- Initialized so that some tools (such as gprbuild) can be built with + -- -gnatVa and pragma Initialized_Scalars without problems. + + Current_Source_Unit : Unit_Number_Type; + -- Unit number of source file currently being scanned. The special value + -- of No_Unit indicates that the configuration pragma file is currently + -- being scanned (this has no entry in the unit table). + + Source_gnat_adc : Source_File_Index := No_Source_File; + -- This is set if a gnat.adc file is present to reference this file + + Source : Source_Buffer_Ptr; + -- Current source (copy of Source_File.Table (Current_Source_Unit).Source) + + Internal_Source : aliased Source_Buffer (1 .. 81); + -- This buffer is used internally in the compiler when the lexical analyzer + -- is used to scan a string from within the compiler. The procedure is to + -- establish Internal_Source_Ptr as the value of Source, set the string to + -- be scanned, appropriately terminated, in this buffer, and set Scan_Ptr + -- to point to the start of the buffer. It is a fatal error if the scanner + -- signals an error while scanning a token in this internal buffer. + + Internal_Source_Ptr : constant Source_Buffer_Ptr := + Internal_Source'Unrestricted_Access; + -- Pointer to internal source buffer + + ----------------- + -- Subprograms -- + ----------------- + + procedure Backup_Line (P : in out Source_Ptr); + -- Back up the argument pointer to the start of the previous line. On + -- entry, P points to the start of a physical line in the source buffer. + -- On return, P is updated to point to the start of the previous line. + -- The caller has checked that a Line_Terminator character precedes P so + -- that there definitely is a previous line in the source buffer. + + procedure Build_Location_String (Loc : Source_Ptr); + -- This function builds a string literal of the form "name:line", where + -- name is the file name corresponding to Loc, and line is the line number. + -- In the event that instantiations are involved, additional suffixes of + -- the same form are appended after the separating string " instantiated at + -- ". The returned string is appended to the Name_Buffer, terminated by + -- ASCII.NUL, with Name_Length indicating the length not including the + -- terminating Nul. + + function Build_Location_String (Loc : Source_Ptr) return String; + -- Functional form returning a string, which does not include a terminating + -- null character. The contents of Name_Buffer is destroyed. + + function Get_Column_Number (P : Source_Ptr) return Column_Number; + -- The ones-origin column number of the specified Source_Ptr value is + -- determined and returned. Tab characters if present are assumed to + -- represent the standard 1,9,17.. spacing pattern. + + function Get_Logical_Line_Number + (P : Source_Ptr) return Logical_Line_Number; + -- The line number of the specified source position is obtained by + -- doing a binary search on the source positions in the lines table + -- for the unit containing the given source position. The returned + -- value is the logical line number, already adjusted for the effect + -- of source reference pragmas. If P refers to the line of a source + -- reference pragma itself, then No_Line is returned. If no source + -- reference pragmas have been encountered, the value returned is + -- the same as the physical line number. + + function Get_Logical_Line_Number_Img + (P : Source_Ptr) return String; + -- Same as above function, but returns the line number as a string of + -- decimal digits, with no leading space. Destroys Name_Buffer. + + function Get_Physical_Line_Number + (P : Source_Ptr) return Physical_Line_Number; + -- The line number of the specified source position is obtained by + -- doing a binary search on the source positions in the lines table + -- for the unit containing the given source position. The returned + -- value is the physical line number in the source being compiled. + + function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index; + -- Return file table index of file identified by given source pointer + -- value. This call must always succeed, since any valid source pointer + -- value belongs to some previously loaded source file. + + function Instantiation_Depth (S : Source_Ptr) return Nat; + -- Determine instantiation depth for given Sloc value. A value of + -- zero means that the given Sloc is not in an instantiation. + + function Line_Start (P : Source_Ptr) return Source_Ptr; + -- Finds the source position of the start of the line containing the + -- given source location. + + function Line_Start + (L : Physical_Line_Number; + S : Source_File_Index) return Source_Ptr; + -- Finds the source position of the start of the given line in the + -- given source file, using a physical line number to identify the line. + + function Num_Source_Lines (S : Source_File_Index) return Nat; + -- Returns the number of source lines (this is equivalent to reading + -- the value of Last_Source_Line, but returns Nat rather than a + -- physical line number. + + procedure Register_Source_Ref_Pragma + (File_Name : File_Name_Type; + Stripped_File_Name : File_Name_Type; + Mapped_Line : Nat; + Line_After_Pragma : Physical_Line_Number); + -- Register a source reference pragma, the parameter File_Name is the + -- file name from the pragma, and Stripped_File_Name is this name with + -- the directory information stripped. Both these parameters are set + -- to No_Name if no file name parameter was given in the pragma. + -- (which can only happen for the second and subsequent pragmas). + -- Mapped_Line is the line number parameter from the pragma, and + -- Line_After_Pragma is the physical line number of the line that + -- follows the line containing the Source_Reference pragma. + + function Original_Location (S : Source_Ptr) return Source_Ptr; + -- Given a source pointer S, returns the corresponding source pointer + -- value ignoring instantiation copies. For locations that do not + -- correspond to instantiation copies of templates, the argument is + -- returned unchanged. For locations that do correspond to copies of + -- templates from instantiations, the location within the original + -- template is returned. This is useful in canonicalizing locations. + + function Instantiation_Location (S : Source_Ptr) return Source_Ptr; + pragma Inline (Instantiation_Location); + -- Given a source pointer S, returns the corresponding source pointer + -- value of the instantiation if this location is within an instance. + -- If S is not within an instance, then this returns No_Location. + + function Top_Level_Location (S : Source_Ptr) return Source_Ptr; + -- Given a source pointer S, returns the argument unchanged if it is + -- not in an instantiation. If S is in an instantiation, then it returns + -- the location of the top level instantiation, i.e. the outer level + -- instantiation in the nested case. + + function Physical_To_Logical + (Line : Physical_Line_Number; + S : Source_File_Index) return Logical_Line_Number; + -- Given a physical line number in source file whose source index is S, + -- return the corresponding logical line number. If the physical line + -- number is one containing a Source_Reference pragma, the result will + -- be No_Line_Number. + + procedure Skip_Line_Terminators + (P : in out Source_Ptr; + Physical : out Boolean); + -- On entry, P points to a line terminator that has been encountered, + -- which is one of FF,LF,VT,CR or a wide character sequence whose value is + -- in category Separator,Line or Separator,Paragraph. P points just past + -- the character that was scanned. The purpose of this routine is to + -- distinguish physical and logical line endings. A physical line ending + -- is one of: + -- + -- CR on its own (MAC System 7) + -- LF on its own (Unix and unix-like systems) + -- CR/LF (DOS, Windows) + -- Wide character in Separator,Line or Separator,Paragraph category + -- + -- Note: we no longer recognize LF/CR (which we did in some earlier + -- versions of GNAT. The reason for this is that this sequence is not + -- used and recognizing it generated confusion. For example given the + -- sequence LF/CR/LF we were interpreting that as (LF/CR) ending the + -- first line and a blank line ending with CR following, but it is + -- clearly better to interpret this as LF, with a blank line terminated + -- by CR/LF, given that LF and CR/LF are both in common use, but no + -- system we know of uses LF/CR. + -- + -- A logical line ending (that is not a physical line ending) is one of: + -- + -- VT on its own + -- FF on its own + -- + -- On return, P is bumped past the line ending sequence (one of the above + -- seven possibilities). Physical is set to True to indicate that a + -- physical end of line was encountered, in which case this routine also + -- makes sure that the lines table for the current source file has an + -- appropriate entry for the start of the new physical line. + + procedure Sloc_Range (N : Node_Id; Min, Max : out Source_Ptr); + -- Given a node, returns the minimum and maximum source locations of any + -- node in the syntactic subtree for the node. This is not quite the same + -- as the locations of the first and last token in the node construct + -- because parentheses at the outer level do not have a recorded Sloc. + -- + -- Note: if the tree for the expression contains no "real" Sloc values, + -- i.e. values > No_Location, then both Min and Max are set to Sloc (Expr). + + function Source_Offset (S : Source_Ptr) return Nat; + -- Returns the zero-origin offset of the given source location from the + -- start of its corresponding unit. This is used for creating canonical + -- names in some situations. + + procedure Write_Location (P : Source_Ptr); + -- Writes out a string of the form fff:nn:cc, where fff, nn, cc are the + -- file name, line number and column corresponding to the given source + -- location. No_Location and Standard_Location appear as the strings + -- and . If the location is within an + -- instantiation, then the instance location is appended, enclosed in + -- square brackets (which can nest if necessary). Note that this routine + -- is used only for internal compiler debugging output purposes (which + -- is why the somewhat cryptic use of brackets is acceptable). + + procedure wl (P : Source_Ptr); + pragma Export (Ada, wl); + -- Equivalent to Write_Location (P); Write_Eol; for calls from GDB + + procedure Write_Time_Stamp (S : Source_File_Index); + -- Writes time stamp of specified file in YY-MM-DD HH:MM.SS format + + procedure Tree_Read; + -- Initializes internal tables from current tree file using the relevant + -- Table.Tree_Read routines. + + procedure Tree_Write; + -- Writes out internal tables to current tree file using the relevant + -- Table.Tree_Write routines. + +private + pragma Inline (File_Name); + pragma Inline (First_Mapped_Line); + pragma Inline (Full_File_Name); + pragma Inline (Identifier_Casing); + pragma Inline (Instantiation); + pragma Inline (Keyword_Casing); + pragma Inline (Last_Source_Line); + pragma Inline (Last_Source_File); + pragma Inline (License); + pragma Inline (Num_SRef_Pragmas); + pragma Inline (Num_Source_Files); + pragma Inline (Num_Source_Lines); + pragma Inline (Reference_Name); + pragma Inline (Set_Keyword_Casing); + pragma Inline (Set_Identifier_Casing); + pragma Inline (Source_First); + pragma Inline (Source_Last); + pragma Inline (Source_Text); + pragma Inline (Template); + pragma Inline (Time_Stamp); + + ------------------------- + -- Source_Lines Tables -- + ------------------------- + + type Lines_Table_Type is + array (Physical_Line_Number) of Source_Ptr; + -- Type used for lines table. The entries are indexed by physical line + -- numbers. The values are the starting Source_Ptr values for the start + -- of the corresponding physical line. Note that we make this a bogus + -- big array, sized as required, so that we avoid the use of fat pointers. + + type Lines_Table_Ptr is access all Lines_Table_Type; + -- Type used for pointers to line tables + + type Logical_Lines_Table_Type is + array (Physical_Line_Number) of Logical_Line_Number; + -- Type used for logical lines table. This table is used if a source + -- reference pragma is present. It is indexed by physical line numbers, + -- and contains the corresponding logical line numbers. An entry that + -- corresponds to a source reference pragma is set to No_Line_Number. + -- Note that we make this a bogus big array, sized as required, so that + -- we avoid the use of fat pointers. + + type Logical_Lines_Table_Ptr is access all Logical_Lines_Table_Type; + -- Type used for pointers to logical line tables + + ----------------------- + -- Source_File Table -- + ----------------------- + + -- See earlier descriptions for meanings of public fields + + type Source_File_Record is record + File_Name : File_Name_Type; + Reference_Name : File_Name_Type; + Debug_Source_Name : File_Name_Type; + Full_Debug_Name : File_Name_Type; + Full_File_Name : File_Name_Type; + Full_Ref_Name : File_Name_Type; + Num_SRef_Pragmas : Nat; + First_Mapped_Line : Logical_Line_Number; + Source_Text : Source_Buffer_Ptr; + Source_First : Source_Ptr; + Source_Last : Source_Ptr; + Source_Checksum : Word; + Last_Source_Line : Physical_Line_Number; + Instantiation : Source_Ptr; + Template : Source_File_Index; + Unit : Unit_Number_Type; + Time_Stamp : Time_Stamp_Type; + File_Type : Type_Of_File; + Inlined_Body : Boolean; + License : License_Type; + Keyword_Casing : Casing_Type; + Identifier_Casing : Casing_Type; + + -- The following fields are for internal use only (i.e. only in the + -- body of Sinput or its children, with no direct access by clients). + + Sloc_Adjust : Source_Ptr; + -- A value to be added to Sloc values for this file to reference the + -- corresponding lines table. This is zero for the non-instantiation + -- case, and set so that the addition references the ultimate template + -- for the instantiation case. See Sinput-L for further details. + + Lines_Table : Lines_Table_Ptr; + -- Pointer to lines table for this source. Updated as additional + -- lines are accessed using the Skip_Line_Terminators procedure. + -- Note: the lines table for an instantiation entry refers to the + -- original line numbers of the template see Sinput-L for details. + + Logical_Lines_Table : Logical_Lines_Table_Ptr; + -- Pointer to logical lines table for this source. Non-null only if + -- a source reference pragma has been processed. Updated as lines + -- are accessed using the Skip_Line_Terminators procedure. + + Lines_Table_Max : Physical_Line_Number; + -- Maximum subscript values for currently allocated Lines_Table + -- and (if present) the allocated Logical_Lines_Table. The value + -- Max_Source_Line gives the maximum used value, this gives the + -- maximum allocated value. + + end record; + + -- The following representation clause ensures that the above record + -- has no holes. We do this so that when instances of this record are + -- written by Tree_Gen, we do not write uninitialized values to the file. + + AS : constant Pos := Standard'Address_Size; + + for Source_File_Record use record + File_Name at 0 range 0 .. 31; + Reference_Name at 4 range 0 .. 31; + Debug_Source_Name at 8 range 0 .. 31; + Full_Debug_Name at 12 range 0 .. 31; + Full_File_Name at 16 range 0 .. 31; + Full_Ref_Name at 20 range 0 .. 31; + Num_SRef_Pragmas at 24 range 0 .. 31; + First_Mapped_Line at 28 range 0 .. 31; + Source_First at 32 range 0 .. 31; + Source_Last at 36 range 0 .. 31; + Source_Checksum at 40 range 0 .. 31; + Last_Source_Line at 44 range 0 .. 31; + Instantiation at 48 range 0 .. 31; + Template at 52 range 0 .. 31; + Unit at 56 range 0 .. 31; + Time_Stamp at 60 range 0 .. 8 * Time_Stamp_Length - 1; + File_Type at 74 range 0 .. 7; + Inlined_Body at 75 range 0 .. 7; + License at 76 range 0 .. 7; + Keyword_Casing at 77 range 0 .. 7; + Identifier_Casing at 78 range 0 .. 15; + Sloc_Adjust at 80 range 0 .. 31; + Lines_Table_Max at 84 range 0 .. 31; + + -- The following fields are pointers, so we have to specialize their + -- lengths using pointer size, obtained above as Standard'Address_Size. + + Source_Text at 88 range 0 .. AS - 1; + Lines_Table at 88 range AS .. AS * 2 - 1; + Logical_Lines_Table at 88 range AS * 2 .. AS * 3 - 1; + end record; + + for Source_File_Record'Size use 88 * 8 + AS * 3; + -- This ensures that we did not leave out any fields + + package Source_File is new Table.Table ( + Table_Component_Type => Source_File_Record, + Table_Index_Type => Source_File_Index, + Table_Low_Bound => 1, + Table_Initial => Alloc.Source_File_Initial, + Table_Increment => Alloc.Source_File_Increment, + Table_Name => "Source_File"); + + ----------------- + -- Subprograms -- + ----------------- + + procedure Alloc_Line_Tables + (S : in out Source_File_Record; + New_Max : Nat); + -- Allocate or reallocate the lines table for the given source file so + -- that it can accommodate at least New_Max lines. Also allocates or + -- reallocates logical lines table if source ref pragmas are present. + + procedure Add_Line_Tables_Entry + (S : in out Source_File_Record; + P : Source_Ptr); + -- Increment line table size by one (reallocating the lines table if + -- needed) and set the new entry to contain the value P. Also bumps + -- the Source_Line_Count field. If source reference pragmas are + -- present, also increments logical lines table size by one, and + -- sets new entry. + + procedure Trim_Lines_Table (S : Source_File_Index); + -- Set lines table size for entry S in the source file table to + -- correspond to the current value of Num_Source_Lines, releasing + -- any unused storage. This is used by Sinput.L and Sinput.D. + +end Sinput; diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl new file mode 100644 index 000000000..164b11d35 --- /dev/null +++ b/gcc/ada/snames.adb-tmpl @@ -0,0 +1,458 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S N A M 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 Opt; use Opt; +with Table; +with Types; use Types; + +package body Snames is + + -- Table used to record convention identifiers + + type Convention_Id_Entry is record + Name : Name_Id; + Convention : Convention_Id; + end record; + + package Convention_Identifiers is new Table.Table ( + Table_Component_Type => Convention_Id_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 200, + Table_Name => "Name_Convention_Identifiers"); + + -- Table of names to be set by Initialize. Each name is terminated by a + -- single #, and the end of the list is marked by a null entry, i.e. by + -- two # marks in succession. Note that the table does not include the + -- entries for a-z, since these are initialized by Namet itself. + + Preset_Names : constant String := +!! TEMPLATE INSERTION POINT + "#"; + + --------------------- + -- Generated Names -- + --------------------- + + -- This section lists the various cases of generated names which are + -- built from existing names by adding unique leading and/or trailing + -- upper case letters. In some cases these names are built recursively, + -- in particular names built from types may be built from types which + -- themselves have generated names. In this list, xxx represents an + -- existing name to which identifying letters are prepended or appended, + -- and a trailing n represents a serial number in an external name that + -- has some semantic significance (e.g. the n'th index type of an array). + + -- xxxA access type for formal xxx in entry param record (Exp_Ch9) + -- xxxB tag table for tagged type xxx (Exp_Ch3) + -- xxxB task body procedure for task xxx (Exp_Ch9) + -- xxxD dispatch table for tagged type xxx (Exp_Ch3) + -- xxxD discriminal for discriminant xxx (Sem_Ch3) + -- xxxDn n'th discr check function for rec type xxx (Exp_Ch3) + -- xxxE elaboration boolean flag for task xxx (Exp_Ch9) + -- xxxE dispatch table pointer type for tagged type xxx (Exp_Ch3) + -- xxxE parameters for accept body for entry xxx (Exp_Ch9) + -- xxxFn n'th primitive of a tagged type (named xxx) (Exp_Ch3) + -- xxxJ tag table type index for tagged type xxx (Exp_Ch3) + -- xxxM master Id value for access type xxx (Exp_Ch3) + -- xxxP tag table pointer type for tagged type xxx (Exp_Ch3) + -- xxxP parameter record type for entry xxx (Exp_Ch9) + -- xxxPA access to parameter record type for entry xxx (Exp_Ch9) + -- xxxPn pointer type for n'th primitive of tagged type xxx (Exp_Ch3) + -- xxxR dispatch table pointer for tagged type xxx (Exp_Ch3) + -- xxxT tag table type for tagged type xxx (Exp_Ch3) + -- xxxT literal table for enumeration type xxx (Sem_Ch3) + -- xxxV type for task value record for task xxx (Exp_Ch9) + -- xxxX entry index constant (Exp_Ch9) + -- xxxY dispatch table type for tagged type xxx (Exp_Ch3) + -- xxxZ size variable for task xxx (Exp_Ch9) + + -- TSS names + + -- xxxDA deep adjust routine for type xxx (Exp_TSS) + -- xxxDF deep finalize routine for type xxx (Exp_TSS) + -- xxxDI deep initialize routine for type xxx (Exp_TSS) + -- xxxEQ composite equality routine for record type xxx (Exp_TSS) + -- xxxFA PolyORB/DSA From_Any converter for type xxx (Exp_TSS) + -- xxxIP initialization procedure for type xxx (Exp_TSS) + -- xxxRA RAS type access routine for type xxx (Exp_TSS) + -- xxxRD RAS type dereference routine for type xxx (Exp_TSS) + -- xxxRP Rep to Pos conversion for enumeration type xxx (Exp_TSS) + -- xxxSA array/slice assignment for controlled comp. arrays (Exp_TSS) + -- xxxSI stream input attribute subprogram for type xxx (Exp_TSS) + -- xxxSO stream output attribute subprogram for type xxx (Exp_TSS) + -- xxxSR stream read attribute subprogram for type xxx (Exp_TSS) + -- xxxSW stream write attribute subprogram for type xxx (Exp_TSS) + -- xxxTA PolyORB/DSA To_Any converter for type xxx (Exp_TSS) + -- xxxTC PolyORB/DSA Typecode for type xxx (Exp_TSS) + + -- Implicit type names + + -- TxxxT type of literal table for enumeration type xxx (Sem_Ch3) + + -- (Note: this list is not complete or accurate ???) + + ---------------------- + -- Get_Attribute_Id -- + ---------------------- + + function Get_Attribute_Id (N : Name_Id) return Attribute_Id is + begin + return Attribute_Id'Val (N - First_Attribute_Name); + end Get_Attribute_Id; + + ----------------------- + -- Get_Convention_Id -- + ----------------------- + + function Get_Convention_Id (N : Name_Id) return Convention_Id is + begin + case N is + when Name_Ada => return Convention_Ada; + when Name_Assembler => return Convention_Assembler; + when Name_C => return Convention_C; + when Name_CIL => return Convention_CIL; + when Name_COBOL => return Convention_COBOL; + when Name_CPP => return Convention_CPP; + when Name_Fortran => return Convention_Fortran; + when Name_Intrinsic => return Convention_Intrinsic; + when Name_Java => return Convention_Java; + when Name_Stdcall => return Convention_Stdcall; + when Name_Stubbed => return Convention_Stubbed; + + -- If no direct match, then we must have a convention + -- identifier pragma that has specified this name. + + when others => + for J in 1 .. Convention_Identifiers.Last loop + if N = Convention_Identifiers.Table (J).Name then + return Convention_Identifiers.Table (J).Convention; + end if; + end loop; + + raise Program_Error; + end case; + end Get_Convention_Id; + + ------------------------- + -- Get_Convention_Name -- + ------------------------- + + function Get_Convention_Name (C : Convention_Id) return Name_Id is + begin + case C is + when Convention_Ada => return Name_Ada; + when Convention_Assembler => return Name_Assembler; + when Convention_C => return Name_C; + when Convention_CIL => return Name_CIL; + when Convention_COBOL => return Name_COBOL; + when Convention_CPP => return Name_CPP; + when Convention_Entry => return Name_Entry; + when Convention_Fortran => return Name_Fortran; + when Convention_Intrinsic => return Name_Intrinsic; + when Convention_Java => return Name_Java; + when Convention_Protected => return Name_Protected; + when Convention_Stdcall => return Name_Stdcall; + when Convention_Stubbed => return Name_Stubbed; + end case; + end Get_Convention_Name; + + --------------------------- + -- Get_Locking_Policy_Id -- + --------------------------- + + function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id is + begin + return Locking_Policy_Id'Val (N - First_Locking_Policy_Name); + end Get_Locking_Policy_Id; + + ------------------- + -- Get_Pragma_Id -- + ------------------- + + function Get_Pragma_Id (N : Name_Id) return Pragma_Id is + begin + if N = Name_AST_Entry then + return Pragma_AST_Entry; + elsif N = Name_Fast_Math then + return Pragma_Fast_Math; + elsif N = Name_Interface then + return Pragma_Interface; + elsif N = Name_Priority then + return Pragma_Priority; + elsif N = Name_Relative_Deadline then + return Pragma_Relative_Deadline; + elsif N = Name_Storage_Size then + return Pragma_Storage_Size; + elsif N = Name_Storage_Unit then + return Pragma_Storage_Unit; + elsif N not in First_Pragma_Name .. Last_Pragma_Name then + return Unknown_Pragma; + else + return Pragma_Id'Val (N - First_Pragma_Name); + end if; + end Get_Pragma_Id; + + --------------------------- + -- Get_Queuing_Policy_Id -- + --------------------------- + + function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id is + begin + return Queuing_Policy_Id'Val (N - First_Queuing_Policy_Name); + end Get_Queuing_Policy_Id; + + ------------------------------------ + -- Get_Task_Dispatching_Policy_Id -- + ------------------------------------ + + function Get_Task_Dispatching_Policy_Id + (N : Name_Id) return Task_Dispatching_Policy_Id + is + begin + return Task_Dispatching_Policy_Id'Val + (N - First_Task_Dispatching_Policy_Name); + end Get_Task_Dispatching_Policy_Id; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + P_Index : Natural; + Discard_Name : Name_Id; + + begin + P_Index := Preset_Names'First; + loop + Name_Len := 0; + while Preset_Names (P_Index) /= '#' loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Preset_Names (P_Index); + P_Index := P_Index + 1; + end loop; + + -- We do the Name_Find call to enter the name into the table, but + -- we don't need to do anything with the result, since we already + -- initialized all the preset names to have the right value (we + -- are depending on the order of the names and Preset_Names). + + Discard_Name := Name_Find; + P_Index := P_Index + 1; + exit when Preset_Names (P_Index) = '#'; + end loop; + + -- Make sure that number of names in standard table is correct. If + -- this check fails, run utility program XSNAMES to construct a new + -- properly matching version of the body. + + pragma Assert (Discard_Name = Last_Predefined_Name); + + -- Initialize the convention identifiers table with the standard + -- set of synonyms that we recognize for conventions. + + Convention_Identifiers.Init; + + Convention_Identifiers.Append ((Name_Asm, Convention_Assembler)); + Convention_Identifiers.Append ((Name_Assembly, Convention_Assembler)); + + Convention_Identifiers.Append ((Name_Default, Convention_C)); + Convention_Identifiers.Append ((Name_External, Convention_C)); + + Convention_Identifiers.Append ((Name_C_Plus_Plus, Convention_CPP)); + + Convention_Identifiers.Append ((Name_DLL, Convention_Stdcall)); + Convention_Identifiers.Append ((Name_Win32, Convention_Stdcall)); + end Initialize; + + ----------------------- + -- Is_Attribute_Name -- + ----------------------- + + function Is_Attribute_Name (N : Name_Id) return Boolean is + begin + return N in First_Attribute_Name .. Last_Attribute_Name; + end Is_Attribute_Name; + + ---------------------------------- + -- Is_Configuration_Pragma_Name -- + ---------------------------------- + + function Is_Configuration_Pragma_Name (N : Name_Id) return Boolean is + begin + return N in First_Pragma_Name .. Last_Configuration_Pragma_Name + or else N = Name_Fast_Math; + end Is_Configuration_Pragma_Name; + + ------------------------ + -- Is_Convention_Name -- + ------------------------ + + function Is_Convention_Name (N : Name_Id) return Boolean is + begin + -- Check if this is one of the standard conventions + + if N in First_Convention_Name .. Last_Convention_Name + or else N = Name_C + then + return True; + + -- Otherwise check if it is in convention identifier table + + else + for J in 1 .. Convention_Identifiers.Last loop + if N = Convention_Identifiers.Table (J).Name then + return True; + end if; + end loop; + + return False; + end if; + end Is_Convention_Name; + + ------------------------------ + -- Is_Entity_Attribute_Name -- + ------------------------------ + + function Is_Entity_Attribute_Name (N : Name_Id) return Boolean is + begin + return N in First_Entity_Attribute_Name .. Last_Entity_Attribute_Name; + end Is_Entity_Attribute_Name; + + -------------------------------- + -- Is_Function_Attribute_Name -- + -------------------------------- + + function Is_Function_Attribute_Name (N : Name_Id) return Boolean is + begin + return N in + First_Renamable_Function_Attribute .. + Last_Renamable_Function_Attribute; + end Is_Function_Attribute_Name; + + --------------------- + -- Is_Keyword_Name -- + --------------------- + + function Is_Keyword_Name (N : Name_Id) return Boolean is + begin + return Get_Name_Table_Byte (N) /= 0 + and then (Ada_Version >= Ada_95 + or else N not in Ada_95_Reserved_Words) + and then (Ada_Version >= Ada_2005 + or else N not in Ada_2005_Reserved_Words); + end Is_Keyword_Name; + + ---------------------------- + -- Is_Locking_Policy_Name -- + ---------------------------- + + function Is_Locking_Policy_Name (N : Name_Id) return Boolean is + begin + return N in First_Locking_Policy_Name .. Last_Locking_Policy_Name; + end Is_Locking_Policy_Name; + + ----------------------------- + -- Is_Operator_Symbol_Name -- + ----------------------------- + + function Is_Operator_Symbol_Name (N : Name_Id) return Boolean is + begin + return N in First_Operator_Name .. Last_Operator_Name; + end Is_Operator_Symbol_Name; + + -------------------- + -- Is_Pragma_Name -- + -------------------- + + function Is_Pragma_Name (N : Name_Id) return Boolean is + begin + return N in First_Pragma_Name .. Last_Pragma_Name + or else N = Name_AST_Entry + or else N = Name_Fast_Math + or else N = Name_Interface + or else N = Name_Relative_Deadline + or else N = Name_Priority + or else N = Name_Storage_Size + or else N = Name_Storage_Unit; + end Is_Pragma_Name; + + --------------------------------- + -- Is_Procedure_Attribute_Name -- + --------------------------------- + + function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean is + begin + return N in First_Procedure_Attribute .. Last_Procedure_Attribute; + end Is_Procedure_Attribute_Name; + + ---------------------------- + -- Is_Queuing_Policy_Name -- + ---------------------------- + + function Is_Queuing_Policy_Name (N : Name_Id) return Boolean is + begin + return N in First_Queuing_Policy_Name .. Last_Queuing_Policy_Name; + end Is_Queuing_Policy_Name; + + ------------------------------------- + -- Is_Task_Dispatching_Policy_Name -- + ------------------------------------- + + function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean is + begin + return N in First_Task_Dispatching_Policy_Name .. + Last_Task_Dispatching_Policy_Name; + end Is_Task_Dispatching_Policy_Name; + + ---------------------------- + -- Is_Type_Attribute_Name -- + ---------------------------- + + function Is_Type_Attribute_Name (N : Name_Id) return Boolean is + begin + return N in First_Type_Attribute_Name .. Last_Type_Attribute_Name; + end Is_Type_Attribute_Name; + + ---------------------------------- + -- Record_Convention_Identifier -- + ---------------------------------- + + procedure Record_Convention_Identifier + (Id : Name_Id; + Convention : Convention_Id) + is + begin + Convention_Identifiers.Append ((Id, Convention)); + end Record_Convention_Identifier; + +end Snames; diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl new file mode 100644 index 000000000..1a5eb033e --- /dev/null +++ b/gcc/ada/snames.ads-tmpl @@ -0,0 +1,1800 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S N A M E S -- +-- -- +-- T e m p l a t e -- +-- -- +-- 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 Namet; use Namet; + +package Snames is + +-- This package contains definitions of standard names (i.e. entries in the +-- Names table) that are used throughout the GNAT compiler. It also contains +-- the definitions of some enumeration types whose definitions are tied to +-- the order of these preset names. + + ------------------ + -- Preset Names -- + ------------------ + + -- The following are preset entries in the names table, which are entered + -- at the start of every compilation for easy access. Note that the order + -- of initialization of these names in the body must be coordinated with + -- the order of names in this table. + + -- Note: a name may not appear more than once in the following list. If + -- additional pragmas or attributes are introduced which might otherwise + -- cause a duplicate, then list it only once in this table, and adjust the + -- definition of the functions for testing for pragma names and attribute + -- names, and returning their ID values. Of course everything is simpler + -- if no such duplications occur! + + -- First we have the one character names used to optimize the lookup + -- process for one character identifiers (to avoid the hashing in this + -- case) There are a full 256 of these, but only the entries for lower + -- case and upper case letters have identifiers + + -- The lower case letter entries are used for one character identifiers + -- appearing in the source, for example in pragma Interface (C). + + Name_A : constant Name_Id := First_Name_Id + Character'Pos ('a'); + Name_B : constant Name_Id := First_Name_Id + Character'Pos ('b'); + Name_C : constant Name_Id := First_Name_Id + Character'Pos ('c'); + Name_D : constant Name_Id := First_Name_Id + Character'Pos ('d'); + Name_E : constant Name_Id := First_Name_Id + Character'Pos ('e'); + Name_F : constant Name_Id := First_Name_Id + Character'Pos ('f'); + Name_G : constant Name_Id := First_Name_Id + Character'Pos ('g'); + Name_H : constant Name_Id := First_Name_Id + Character'Pos ('h'); + Name_I : constant Name_Id := First_Name_Id + Character'Pos ('i'); + Name_J : constant Name_Id := First_Name_Id + Character'Pos ('j'); + Name_K : constant Name_Id := First_Name_Id + Character'Pos ('k'); + Name_L : constant Name_Id := First_Name_Id + Character'Pos ('l'); + Name_M : constant Name_Id := First_Name_Id + Character'Pos ('m'); + Name_N : constant Name_Id := First_Name_Id + Character'Pos ('n'); + Name_O : constant Name_Id := First_Name_Id + Character'Pos ('o'); + Name_P : constant Name_Id := First_Name_Id + Character'Pos ('p'); + Name_Q : constant Name_Id := First_Name_Id + Character'Pos ('q'); + Name_R : constant Name_Id := First_Name_Id + Character'Pos ('r'); + Name_S : constant Name_Id := First_Name_Id + Character'Pos ('s'); + Name_T : constant Name_Id := First_Name_Id + Character'Pos ('t'); + Name_U : constant Name_Id := First_Name_Id + Character'Pos ('u'); + Name_V : constant Name_Id := First_Name_Id + Character'Pos ('v'); + Name_W : constant Name_Id := First_Name_Id + Character'Pos ('w'); + Name_X : constant Name_Id := First_Name_Id + Character'Pos ('x'); + Name_Y : constant Name_Id := First_Name_Id + Character'Pos ('y'); + Name_Z : constant Name_Id := First_Name_Id + Character'Pos ('z'); + + -- The upper case letter entries are used by expander code for local + -- variables that do not require unique names (e.g. formal parameter + -- names in constructed procedures) + + Name_uA : constant Name_Id := First_Name_Id + Character'Pos ('A'); + Name_uB : constant Name_Id := First_Name_Id + Character'Pos ('B'); + Name_uC : constant Name_Id := First_Name_Id + Character'Pos ('C'); + Name_uD : constant Name_Id := First_Name_Id + Character'Pos ('D'); + Name_uE : constant Name_Id := First_Name_Id + Character'Pos ('E'); + Name_uF : constant Name_Id := First_Name_Id + Character'Pos ('F'); + Name_uG : constant Name_Id := First_Name_Id + Character'Pos ('G'); + Name_uH : constant Name_Id := First_Name_Id + Character'Pos ('H'); + Name_uI : constant Name_Id := First_Name_Id + Character'Pos ('I'); + Name_uJ : constant Name_Id := First_Name_Id + Character'Pos ('J'); + Name_uK : constant Name_Id := First_Name_Id + Character'Pos ('K'); + Name_uL : constant Name_Id := First_Name_Id + Character'Pos ('L'); + Name_uM : constant Name_Id := First_Name_Id + Character'Pos ('M'); + Name_uN : constant Name_Id := First_Name_Id + Character'Pos ('N'); + Name_uO : constant Name_Id := First_Name_Id + Character'Pos ('O'); + Name_uP : constant Name_Id := First_Name_Id + Character'Pos ('P'); + Name_uQ : constant Name_Id := First_Name_Id + Character'Pos ('Q'); + Name_uR : constant Name_Id := First_Name_Id + Character'Pos ('R'); + Name_uS : constant Name_Id := First_Name_Id + Character'Pos ('S'); + Name_uT : constant Name_Id := First_Name_Id + Character'Pos ('T'); + Name_uU : constant Name_Id := First_Name_Id + Character'Pos ('U'); + Name_uV : constant Name_Id := First_Name_Id + Character'Pos ('V'); + Name_uW : constant Name_Id := First_Name_Id + Character'Pos ('W'); + Name_uX : constant Name_Id := First_Name_Id + Character'Pos ('X'); + Name_uY : constant Name_Id := First_Name_Id + Character'Pos ('Y'); + Name_uZ : constant Name_Id := First_Name_Id + Character'Pos ('Z'); + + -- Note: the following table is read by the utility program XSNAMES and + -- its format should not be changed without coordinating with this program. + + N : constant Name_Id := First_Name_Id + 256; + -- Synonym used in standard name definitions + + -- Names referenced in snames.h + + Name_uParent : constant Name_Id := N + $; + Name_uTag : constant Name_Id := N + $; + Name_Off : constant Name_Id := N + $; + Name_Space : constant Name_Id := N + $; + Name_Time : constant Name_Id := N + $; + + -- Names of aspects for which there are no matching pragmas or attributes + -- so that they need to be included for aspect specification use. + + Name_Post : constant Name_Id := N + $; + Name_Pre : constant Name_Id := N + $; + + -- Some special names used by the expander. Note that the lower case u's + -- at the start of these names get translated to extra underscores. These + -- names are only referenced internally by expander generated code. + + Name_uAbort_Signal : constant Name_Id := N + $; + Name_uAlignment : constant Name_Id := N + $; + Name_uAssign : constant Name_Id := N + $; + Name_uATCB : constant Name_Id := N + $; + Name_uChain : constant Name_Id := N + $; + Name_uClean : constant Name_Id := N + $; + Name_uController : constant Name_Id := N + $; + Name_uCPU : constant Name_Id := N + $; + Name_uEntry_Bodies : constant Name_Id := N + $; + Name_uExpunge : constant Name_Id := N + $; + Name_uFinal_List : constant Name_Id := N + $; + Name_uIdepth : constant Name_Id := N + $; + Name_uInit : constant Name_Id := N + $; + Name_uLocal_Final_List : constant Name_Id := N + $; + Name_uMaster : constant Name_Id := N + $; + Name_uObject : constant Name_Id := N + $; + Name_uPostconditions : constant Name_Id := N + $; + Name_uPriority : constant Name_Id := N + $; + Name_uProcess_ATSD : constant Name_Id := N + $; + Name_uRelative_Deadline : constant Name_Id := N + $; + Name_uResult : constant Name_Id := N + $; + Name_uSecondary_Stack : constant Name_Id := N + $; + Name_uService : constant Name_Id := N + $; + Name_uSize : constant Name_Id := N + $; + Name_uStack : constant Name_Id := N + $; + Name_uTags : constant Name_Id := N + $; + Name_uTask : constant Name_Id := N + $; + Name_uTask_Id : constant Name_Id := N + $; + Name_uTask_Info : constant Name_Id := N + $; + Name_uTask_Name : constant Name_Id := N + $; + Name_uTrace_Sp : constant Name_Id := N + $; + + -- Names of predefined primitives used in the expansion of dispatching + -- requeue and select statements, Abort, 'Callable and 'Terminated. + + Name_uDisp_Asynchronous_Select : constant Name_Id := N + $; + Name_uDisp_Conditional_Select : constant Name_Id := N + $; + Name_uDisp_Get_Prim_Op_Kind : constant Name_Id := N + $; + Name_uDisp_Get_Task_Id : constant Name_Id := N + $; + Name_uDisp_Requeue : constant Name_Id := N + $; + Name_uDisp_Timed_Select : constant Name_Id := N + $; + + -- Names of routines in Ada.Finalization, needed by expander + + Name_Initialize : constant Name_Id := N + $; + Name_Adjust : constant Name_Id := N + $; + Name_Finalize : constant Name_Id := N + $; + + -- Names of fields declared in System.Finalization_Implementation, + -- needed by the expander when generating code for finalization. + + Name_Next : constant Name_Id := N + $; + Name_Prev : constant Name_Id := N + $; + + -- Names of allocation routines, also needed by expander + + Name_Allocate : constant Name_Id := N + $; + Name_Deallocate : constant Name_Id := N + $; + Name_Dereference : constant Name_Id := N + $; + + -- Names of Text_IO generic subpackages (see Rtsfind.Text_IO_Kludge) + + First_Text_IO_Package : constant Name_Id := N + $; + Name_Decimal_IO : constant Name_Id := N + $; + Name_Enumeration_IO : constant Name_Id := N + $; + Name_Fixed_IO : constant Name_Id := N + $; + Name_Float_IO : constant Name_Id := N + $; + Name_Integer_IO : constant Name_Id := N + $; + Name_Modular_IO : constant Name_Id := N + $; + Last_Text_IO_Package : constant Name_Id := N + $; + + subtype Text_IO_Package_Name is Name_Id + range First_Text_IO_Package .. Last_Text_IO_Package; + + -- Some miscellaneous names used for error detection/recovery + + Name_Const : constant Name_Id := N + $; + Name_Error : constant Name_Id := N + $; + Name_Go : constant Name_Id := N + $; + Name_Put : constant Name_Id := N + $; + Name_Put_Line : constant Name_Id := N + $; + Name_To : constant Name_Id := N + $; + + -- Name used by the integrated preprocessor + + Name_Defined : constant Name_Id := N + $; + + -- Names for packages that are treated specially by the compiler + + Name_Exception_Traces : constant Name_Id := N + $; + Name_Finalization : constant Name_Id := N + $; + Name_Finalization_Root : constant Name_Id := N + $; + Name_Interfaces : constant Name_Id := N + $; + Name_Most_Recent_Exception : constant Name_Id := N + $; + Name_Standard : constant Name_Id := N + $; + Name_System : constant Name_Id := N + $; + Name_Text_IO : constant Name_Id := N + $; + Name_Wide_Text_IO : constant Name_Id := N + $; + Name_Wide_Wide_Text_IO : constant Name_Id := N + $; + + -- Names of implementations of the distributed systems annex + + First_PCS_Name : constant Name_Id := N + $; + Name_No_DSA : constant Name_Id := N + $; + Name_GARLIC_DSA : constant Name_Id := N + $; + Name_PolyORB_DSA : constant Name_Id := N + $; + Last_PCS_Name : constant Name_Id := N + $; + + subtype PCS_Names is Name_Id + range First_PCS_Name .. Last_PCS_Name; + + -- Names of identifiers used in expanding distribution stubs + + Name_Addr : constant Name_Id := N + $; + Name_Async : constant Name_Id := N + $; + Name_Get_Active_Partition_ID : constant Name_Id := N + $; + Name_Get_RCI_Package_Receiver : constant Name_Id := N + $; + Name_Get_RCI_Package_Ref : constant Name_Id := N + $; + Name_Origin : constant Name_Id := N + $; + Name_Params : constant Name_Id := N + $; + Name_Partition : constant Name_Id := N + $; + Name_Partition_Interface : constant Name_Id := N + $; + Name_Ras : constant Name_Id := N + $; + Name_uCall : constant Name_Id := N + $; + Name_RCI_Name : constant Name_Id := N + $; + Name_Receiver : constant Name_Id := N + $; + Name_Rpc : constant Name_Id := N + $; + Name_Subp_Id : constant Name_Id := N + $; + Name_Operation : constant Name_Id := N + $; + Name_Argument : constant Name_Id := N + $; + Name_Arg_Modes : constant Name_Id := N + $; + Name_Handler : constant Name_Id := N + $; + Name_Target : constant Name_Id := N + $; + Name_Req : constant Name_Id := N + $; + Name_Obj_TypeCode : constant Name_Id := N + $; + Name_Stub : constant Name_Id := N + $; + + -- Operator Symbol entries. The actual names have an upper case O at + -- the start in place of the Op_ prefix (e.g. the actual name that + -- corresponds to Name_Op_Abs is "Oabs". + + First_Operator_Name : constant Name_Id := N + $; + Name_Op_Abs : constant Name_Id := N + $; -- "abs" + Name_Op_And : constant Name_Id := N + $; -- "and" + Name_Op_Mod : constant Name_Id := N + $; -- "mod" + Name_Op_Not : constant Name_Id := N + $; -- "not" + Name_Op_Or : constant Name_Id := N + $; -- "or" + Name_Op_Rem : constant Name_Id := N + $; -- "rem" + Name_Op_Xor : constant Name_Id := N + $; -- "xor" + Name_Op_Eq : constant Name_Id := N + $; -- "=" + Name_Op_Ne : constant Name_Id := N + $; -- "/=" + Name_Op_Lt : constant Name_Id := N + $; -- "<" + Name_Op_Le : constant Name_Id := N + $; -- "<=" + Name_Op_Gt : constant Name_Id := N + $; -- ">" + Name_Op_Ge : constant Name_Id := N + $; -- ">=" + Name_Op_Add : constant Name_Id := N + $; -- "+" + Name_Op_Subtract : constant Name_Id := N + $; -- "-" + Name_Op_Concat : constant Name_Id := N + $; -- "&" + Name_Op_Multiply : constant Name_Id := N + $; -- "*" + Name_Op_Divide : constant Name_Id := N + $; -- "/" + Name_Op_Expon : constant Name_Id := N + $; -- "**" + Last_Operator_Name : constant Name_Id := N + $; + + -- Names for all pragmas recognized by GNAT. The entries with the comment + -- "Ada 83" are pragmas that are defined in Ada 83, but not in Ada 95. + -- These pragmas are fully implemented in all modes (Ada 83, Ada 95, and + -- Ada 2005). In Ada 95 and Ada 2005 modes, they are technically considered + -- to be implementation dependent pragmas. + + -- The entries marked GNAT are pragmas that are defined by GNAT and that + -- are implemented in all modes (Ada 83, Ada 95, and Ada 2005) Complete + -- descriptions of the syntax of these implementation dependent pragmas + -- may be found in the appropriate section in unit Sem_Prag in file + -- sem-prag.adb, and they are documented in the GNAT reference manual. + + -- The entries marked Ada 05 are Ada 2005 pragmas. They are implemented + -- in Ada 83 and Ada 95 mode as well, where they are technically considered + -- to be implementation dependent pragmas. + + -- The entries marked Ada 12 are Ada 2012 pragmas. They are implemented + -- in Ada 83, Ada 95, and Ada 2005 mode as well, where they are technically + -- considered to be implementation dependent pragmas. + + -- The entries marked VMS are VMS specific pragmas that are recognized + -- only in OpenVMS versions of GNAT. They are ignored in other versions + -- with an appropriate warning. + + -- The entries marked AAMP are AAMP specific pragmas that are recognized + -- only in GNAT for the AAMP. They are ignored in other versions with + -- appropriate warnings. + + First_Pragma_Name : constant Name_Id := N + $; + + -- Configuration pragmas are grouped at start. Note that there is a list + -- of these names in the GNAT Users guide, be sure to update this list if + -- a new configuration pragma is added. + + Name_Ada_83 : constant Name_Id := N + $; -- GNAT + Name_Ada_95 : constant Name_Id := N + $; -- GNAT + Name_Ada_05 : constant Name_Id := N + $; -- GNAT + Name_Ada_2005 : constant Name_Id := N + $; -- GNAT + Name_Ada_12 : constant Name_Id := N + $; -- GNAT + Name_Ada_2012 : constant Name_Id := N + $; -- GNAT + Name_Assertion_Policy : constant Name_Id := N + $; -- Ada 05 + Name_Assume_No_Invalid_Values : constant Name_Id := N + $; -- GNAT + Name_C_Pass_By_Copy : constant Name_Id := N + $; -- GNAT + Name_Check_Name : constant Name_Id := N + $; -- GNAT + Name_Check_Policy : constant Name_Id := N + $; -- GNAT + Name_Compile_Time_Error : constant Name_Id := N + $; -- GNAT + Name_Compile_Time_Warning : constant Name_Id := N + $; -- GNAT + Name_Compiler_Unit : constant Name_Id := N + $; -- GNAT + Name_Component_Alignment : constant Name_Id := N + $; -- GNAT + Name_Convention_Identifier : constant Name_Id := N + $; -- GNAT + Name_Debug_Policy : constant Name_Id := N + $; -- GNAT + Name_Detect_Blocking : constant Name_Id := N + $; -- Ada 05 + Name_Default_Storage_Pool : constant Name_Id := N + $; -- Ada 12 + Name_Discard_Names : constant Name_Id := N + $; + Name_Elaboration_Checks : constant Name_Id := N + $; -- GNAT + Name_Eliminate : constant Name_Id := N + $; -- GNAT + Name_Extend_System : constant Name_Id := N + $; -- GNAT + Name_Extensions_Allowed : constant Name_Id := N + $; -- GNAT + Name_External_Name_Casing : constant Name_Id := N + $; -- GNAT + + -- Note: Fast_Math is not in this list because its name matches -- GNAT + -- the name of the corresponding attribute. However, it is + -- included in the definition of the type Pragma_Id, and the + -- functions Get_Pragma_Id, Is_[Configuration_]Pragma_Id, and + -- correctly recognize and process Fast_Math. + + Name_Favor_Top_Level : constant Name_Id := N + $; -- GNAT + Name_Float_Representation : constant Name_Id := N + $; -- GNAT + Name_Implicit_Packing : constant Name_Id := N + $; -- GNAT + Name_Initialize_Scalars : constant Name_Id := N + $; -- GNAT + Name_Interrupt_State : constant Name_Id := N + $; -- GNAT + Name_License : constant Name_Id := N + $; -- GNAT + Name_Locking_Policy : constant Name_Id := N + $; + Name_Long_Float : constant Name_Id := N + $; -- VMS + Name_No_Run_Time : constant Name_Id := N + $; -- GNAT + Name_No_Strict_Aliasing : constant Name_Id := N + $; -- GNAT + Name_Normalize_Scalars : constant Name_Id := N + $; + Name_Optimize_Alignment : constant Name_Id := N + $; -- GNAT + Name_Persistent_BSS : constant Name_Id := N + $; -- GNAT + Name_Polling : constant Name_Id := N + $; -- GNAT + Name_Priority_Specific_Dispatching : constant Name_Id := N + $; -- Ada 05 + Name_Profile : constant Name_Id := N + $; -- Ada 05 + Name_Profile_Warnings : constant Name_Id := N + $; -- GNAT + Name_Propagate_Exceptions : constant Name_Id := N + $; -- GNAT + Name_Queuing_Policy : constant Name_Id := N + $; + Name_Ravenscar : constant Name_Id := N + $; -- GNAT + Name_Restricted_Run_Time : constant Name_Id := N + $; -- GNAT + Name_Restrictions : constant Name_Id := N + $; + Name_Restriction_Warnings : constant Name_Id := N + $; -- GNAT + Name_Reviewable : constant Name_Id := N + $; + Name_Short_Circuit_And_Or : constant Name_Id := N + $; -- GNAT + Name_Short_Descriptors : constant Name_Id := N + $; -- GNAT + Name_Source_File_Name : constant Name_Id := N + $; -- GNAT + Name_Source_File_Name_Project : constant Name_Id := N + $; -- GNAT + Name_Style_Checks : constant Name_Id := N + $; -- GNAT + Name_Suppress : constant Name_Id := N + $; + Name_Suppress_Exception_Locations : constant Name_Id := N + $; -- GNAT + Name_Task_Dispatching_Policy : constant Name_Id := N + $; + Name_Universal_Data : constant Name_Id := N + $; -- AAMP + Name_Unsuppress : constant Name_Id := N + $; -- Ada 05 + Name_Use_VADS_Size : constant Name_Id := N + $; -- GNAT + Name_Validity_Checks : constant Name_Id := N + $; -- GNAT + Name_Warnings : constant Name_Id := N + $; -- GNAT + Name_Wide_Character_Encoding : constant Name_Id := N + $; -- GNAT + Last_Configuration_Pragma_Name : constant Name_Id := N + $; + + -- Remaining pragma names + + Name_Abort_Defer : constant Name_Id := N + $; -- GNAT + Name_All_Calls_Remote : constant Name_Id := N + $; + Name_Annotate : constant Name_Id := N + $; -- GNAT + + -- Note: AST_Entry is not in this list because its name matches -- VMS + -- the name of the corresponding attribute. However, it is + -- included in the definition of the type Pragma_Id, and the + -- functions Get_Pragma_Id and Is_Pragma_Id correctly recognize + -- and process Name_AST_Entry. + + Name_Assert : constant Name_Id := N + $; -- Ada 05 + Name_Asynchronous : constant Name_Id := N + $; + Name_Atomic : constant Name_Id := N + $; + Name_Atomic_Components : constant Name_Id := N + $; + Name_Attach_Handler : constant Name_Id := N + $; + Name_Check : constant Name_Id := N + $; -- GNAT + Name_CIL_Constructor : constant Name_Id := N + $; -- GNAT + Name_Comment : constant Name_Id := N + $; -- GNAT + Name_Common_Object : constant Name_Id := N + $; -- GNAT + Name_Complete_Representation : constant Name_Id := N + $; -- GNAT + Name_Complex_Representation : constant Name_Id := N + $; -- GNAT + Name_Controlled : constant Name_Id := N + $; + Name_Convention : constant Name_Id := N + $; + Name_CPP_Class : constant Name_Id := N + $; -- GNAT + Name_CPP_Constructor : constant Name_Id := N + $; -- GNAT + Name_CPP_Virtual : constant Name_Id := N + $; -- GNAT + Name_CPP_Vtable : constant Name_Id := N + $; -- GNAT + Name_CPU : constant Name_Id := N + $; -- Ada 12 + Name_Debug : constant Name_Id := N + $; -- GNAT + Name_Dimension : constant Name_Id := N + $; -- GNAT + Name_Elaborate : constant Name_Id := N + $; -- Ada 83 + Name_Elaborate_All : constant Name_Id := N + $; + Name_Elaborate_Body : constant Name_Id := N + $; + Name_Export : constant Name_Id := N + $; + Name_Export_Exception : constant Name_Id := N + $; -- VMS + Name_Export_Function : constant Name_Id := N + $; -- GNAT + Name_Export_Object : constant Name_Id := N + $; -- GNAT + Name_Export_Procedure : constant Name_Id := N + $; -- GNAT + Name_Export_Value : constant Name_Id := N + $; -- GNAT + Name_Export_Valued_Procedure : constant Name_Id := N + $; -- GNAT + Name_External : constant Name_Id := N + $; -- GNAT + Name_Finalize_Storage_Only : constant Name_Id := N + $; -- GNAT + Name_Ident : constant Name_Id := N + $; -- VMS + Name_Implemented : constant Name_Id := N + $; -- Ada 12 + Name_Import : constant Name_Id := N + $; + Name_Import_Exception : constant Name_Id := N + $; -- VMS + Name_Import_Function : constant Name_Id := N + $; -- GNAT + Name_Import_Object : constant Name_Id := N + $; -- GNAT + Name_Import_Procedure : constant Name_Id := N + $; -- GNAT + Name_Import_Valued_Procedure : constant Name_Id := N + $; -- GNAT + Name_Independent : constant Name_Id := N + $; -- Ada 12 + Name_Independent_Components : constant Name_Id := N + $; -- Ada 12 + Name_Inline : constant Name_Id := N + $; + Name_Inline_Always : constant Name_Id := N + $; -- GNAT + Name_Inline_Generic : constant Name_Id := N + $; -- GNAT + Name_Inspection_Point : constant Name_Id := N + $; + + -- Note: Interface is not in this list because its name -- GNAT + -- matches an Ada 05 keyword. However it is included in + -- the definition of the type Attribute_Id, and the functions + -- Get_Pragma_Id and Is_Pragma_Id correctly recognize and + -- process Name_Storage_Size. + + Name_Interface_Name : constant Name_Id := N + $; -- GNAT + Name_Interrupt_Handler : constant Name_Id := N + $; + Name_Interrupt_Priority : constant Name_Id := N + $; + Name_Invariant : constant Name_Id := N + $; -- GNAT + Name_Java_Constructor : constant Name_Id := N + $; -- GNAT + Name_Java_Interface : constant Name_Id := N + $; -- GNAT + Name_Keep_Names : constant Name_Id := N + $; -- GNAT + Name_Link_With : constant Name_Id := N + $; -- GNAT + Name_Linker_Alias : constant Name_Id := N + $; -- GNAT + Name_Linker_Constructor : constant Name_Id := N + $; -- GNAT + Name_Linker_Destructor : constant Name_Id := N + $; -- GNAT + Name_Linker_Options : constant Name_Id := N + $; + Name_Linker_Section : constant Name_Id := N + $; -- GNAT + Name_List : constant Name_Id := N + $; + Name_Machine_Attribute : constant Name_Id := N + $; -- GNAT + Name_Main : constant Name_Id := N + $; -- GNAT + Name_Main_Storage : constant Name_Id := N + $; -- GNAT + Name_Memory_Size : constant Name_Id := N + $; -- Ada 83 + Name_No_Body : constant Name_Id := N + $; -- GNAT + Name_No_Return : constant Name_Id := N + $; -- Ada 05 + Name_Obsolescent : constant Name_Id := N + $; -- GNAT + Name_Optimize : constant Name_Id := N + $; + Name_Ordered : constant Name_Id := N + $; -- GNAT + Name_Pack : constant Name_Id := N + $; + Name_Page : constant Name_Id := N + $; + Name_Passive : constant Name_Id := N + $; -- GNAT + Name_Postcondition : constant Name_Id := N + $; -- GNAT + Name_Precondition : constant Name_Id := N + $; -- GNAT + Name_Predicate : constant Name_Id := N + $; -- GNAT + Name_Preelaborable_Initialization : constant Name_Id := N + $; -- Ada 05 + Name_Preelaborate : constant Name_Id := N + $; + Name_Preelaborate_05 : constant Name_Id := N + $; -- GNAT + + -- Note: Priority is not in this list because its name matches + -- the name of the corresponding attribute. However, it is + -- included in the definition of the type Pragma_Id, and the + -- functions Get_Pragma_Id and Is_Pragma_Id correctly recognize + -- and process Priority. Priority is a standard Ada 95 pragma. + + Name_Psect_Object : constant Name_Id := N + $; -- VMS + Name_Pure : constant Name_Id := N + $; + Name_Pure_05 : constant Name_Id := N + $; -- GNAT + Name_Pure_Function : constant Name_Id := N + $; -- GNAT + Name_Relative_Deadline : constant Name_Id := N + $; -- Ada 05 + Name_Remote_Call_Interface : constant Name_Id := N + $; + Name_Remote_Types : constant Name_Id := N + $; + Name_Share_Generic : constant Name_Id := N + $; -- GNAT + Name_Shared : constant Name_Id := N + $; -- Ada 83 + Name_Shared_Passive : constant Name_Id := N + $; + + -- Note: Storage_Size is not in this list because its name + -- matches the name of the corresponding attribute. However, + -- it is included in the definition of the type Attribute_Id, + -- and the functions Get_Pragma_Id and Is_Pragma_Id correctly + -- recognize and process Name_Storage_Size. + + -- Note: Storage_Unit is also omitted from the list because + -- of a clash with an attribute name, and is treated similarly. + + Name_Source_Reference : constant Name_Id := N + $; -- GNAT + Name_Static_Elaboration_Desired : constant Name_Id := N + $; -- GNAT + Name_Stream_Convert : constant Name_Id := N + $; -- GNAT + Name_Subtitle : constant Name_Id := N + $; -- GNAT + Name_Suppress_All : constant Name_Id := N + $; -- GNAT + Name_Suppress_Debug_Info : constant Name_Id := N + $; -- GNAT + Name_Suppress_Initialization : constant Name_Id := N + $; -- GNAT + Name_System_Name : constant Name_Id := N + $; -- Ada 83 + Name_Task_Info : constant Name_Id := N + $; -- GNAT + Name_Task_Name : constant Name_Id := N + $; -- GNAT + Name_Task_Storage : constant Name_Id := N + $; -- VMS + Name_Thread_Local_Storage : constant Name_Id := N + $; -- GNAT + Name_Time_Slice : constant Name_Id := N + $; -- GNAT + Name_Title : constant Name_Id := N + $; -- GNAT + Name_Unchecked_Union : constant Name_Id := N + $; -- Ada 05 + Name_Unimplemented_Unit : constant Name_Id := N + $; -- GNAT + Name_Universal_Aliasing : constant Name_Id := N + $; -- GNAT + Name_Unmodified : constant Name_Id := N + $; -- GNAT + Name_Unreferenced : constant Name_Id := N + $; -- GNAT + Name_Unreferenced_Objects : constant Name_Id := N + $; -- GNAT + Name_Unreserve_All_Interrupts : constant Name_Id := N + $; -- GNAT + Name_Volatile : constant Name_Id := N + $; + Name_Volatile_Components : constant Name_Id := N + $; + Name_Weak_External : constant Name_Id := N + $; -- GNAT + Last_Pragma_Name : constant Name_Id := N + $; + + -- Language convention names for pragma Convention/Export/Import/Interface + -- Note that Name_C is not included in this list, since it was already + -- declared earlier in the context of one-character identifier names + -- (where the order is critical to the fast look up process). + + -- Note: there are no convention names corresponding to the conventions + -- Entry and Protected, this is because these conventions cannot be + -- specified by a pragma. + + First_Convention_Name : constant Name_Id := N + $; + Name_Ada : constant Name_Id := N + $; + Name_Assembler : constant Name_Id := N + $; + Name_CIL : constant Name_Id := N + $; + Name_COBOL : constant Name_Id := N + $; + Name_CPP : constant Name_Id := N + $; + Name_Fortran : constant Name_Id := N + $; + Name_Intrinsic : constant Name_Id := N + $; + Name_Java : constant Name_Id := N + $; + Name_Stdcall : constant Name_Id := N + $; + Name_Stubbed : constant Name_Id := N + $; + Last_Convention_Name : constant Name_Id := N + $; + + -- The following names are preset as synonyms for Assembler + + Name_Asm : constant Name_Id := N + $; + Name_Assembly : constant Name_Id := N + $; + + -- The following names are preset as synonyms for C + + Name_Default : constant Name_Id := N + $; + -- Name_External (previously defined as pragma) + + -- The following names are preset as synonyms for CPP + + Name_C_Plus_Plus : constant Name_Id := N + $; + + -- The following names are present as synonyms for Stdcall + + Name_DLL : constant Name_Id := N + $; + Name_Win32 : constant Name_Id := N + $; + + -- Other special names used in processing pragmas + + Name_As_Is : constant Name_Id := N + $; + Name_Assertion : constant Name_Id := N + $; + Name_Attribute_Name : constant Name_Id := N + $; + Name_Body_File_Name : constant Name_Id := N + $; + Name_Boolean_Entry_Barriers : constant Name_Id := N + $; + Name_By_Any : constant Name_Id := N + $; + Name_By_Entry : constant Name_Id := N + $; + Name_By_Protected_Procedure : constant Name_Id := N + $; + Name_Casing : constant Name_Id := N + $; + Name_Code : constant Name_Id := N + $; + Name_Component : constant Name_Id := N + $; + Name_Component_Size_4 : constant Name_Id := N + $; + Name_Copy : constant Name_Id := N + $; + Name_D_Float : constant Name_Id := N + $; + Name_Descriptor : constant Name_Id := N + $; + Name_Dot_Replacement : constant Name_Id := N + $; + Name_Dynamic : constant Name_Id := N + $; + Name_Entity : constant Name_Id := N + $; + Name_Entry_Count : constant Name_Id := N + $; + Name_External_Name : constant Name_Id := N + $; + Name_First_Optional_Parameter : constant Name_Id := N + $; + Name_Form : constant Name_Id := N + $; + Name_G_Float : constant Name_Id := N + $; + Name_Gcc : constant Name_Id := N + $; + Name_Gnat : constant Name_Id := N + $; + Name_GPL : constant Name_Id := N + $; + Name_IEEE_Float : constant Name_Id := N + $; + Name_Ignore : constant Name_Id := N + $; + Name_Info : constant Name_Id := N + $; + Name_Internal : constant Name_Id := N + $; + Name_Link_Name : constant Name_Id := N + $; + Name_Lowercase : constant Name_Id := N + $; + Name_Max_Entry_Queue_Depth : constant Name_Id := N + $; + Name_Max_Entry_Queue_Length : constant Name_Id := N + $; + Name_Max_Size : constant Name_Id := N + $; + Name_Mechanism : constant Name_Id := N + $; + Name_Message : constant Name_Id := N + $; + Name_Mixedcase : constant Name_Id := N + $; + Name_Modified_GPL : constant Name_Id := N + $; + Name_Name : constant Name_Id := N + $; + Name_NCA : constant Name_Id := N + $; + Name_No : constant Name_Id := N + $; + Name_No_Dependence : constant Name_Id := N + $; + Name_No_Dynamic_Attachment : constant Name_Id := N + $; + Name_No_Dynamic_Interrupts : constant Name_Id := N + $; + Name_No_Requeue : constant Name_Id := N + $; + Name_No_Requeue_Statements : constant Name_Id := N + $; + Name_No_Task_Attributes : constant Name_Id := N + $; + Name_No_Task_Attributes_Package : constant Name_Id := N + $; + Name_On : constant Name_Id := N + $; + Name_Policy : constant Name_Id := N + $; + Name_Parameter_Types : constant Name_Id := N + $; + Name_Reference : constant Name_Id := N + $; + Name_Restricted : constant Name_Id := N + $; + Name_Result_Mechanism : constant Name_Id := N + $; + Name_Result_Type : constant Name_Id := N + $; + Name_Runtime : constant Name_Id := N + $; + Name_SB : constant Name_Id := N + $; + Name_Secondary_Stack_Size : constant Name_Id := N + $; + Name_Section : constant Name_Id := N + $; + Name_Semaphore : constant Name_Id := N + $; + Name_Short_Descriptor : constant Name_Id := N + $; + Name_Simple_Barriers : constant Name_Id := N + $; + Name_Spec_File_Name : constant Name_Id := N + $; + Name_State : constant Name_Id := N + $; + Name_Static : constant Name_Id := N + $; + Name_Stack_Size : constant Name_Id := N + $; + Name_Subunit_File_Name : constant Name_Id := N + $; + Name_Task_Stack_Size_Default : constant Name_Id := N + $; + Name_Task_Type : constant Name_Id := N + $; + Name_Time_Slicing_Enabled : constant Name_Id := N + $; + Name_Top_Guard : constant Name_Id := N + $; + Name_UBA : constant Name_Id := N + $; + Name_UBS : constant Name_Id := N + $; + Name_UBSB : constant Name_Id := N + $; + Name_Unit_Name : constant Name_Id := N + $; + Name_Unknown : constant Name_Id := N + $; + Name_Unrestricted : constant Name_Id := N + $; + Name_Uppercase : constant Name_Id := N + $; + Name_User : constant Name_Id := N + $; + Name_VAX_Float : constant Name_Id := N + $; + Name_VMS : constant Name_Id := N + $; + Name_Vtable_Ptr : constant Name_Id := N + $; + Name_Working_Storage : constant Name_Id := N + $; + + -- Names of recognized attributes. The entries with the comment "Ada 83" + -- are attributes that are defined in Ada 83, but not in Ada 95. These + -- attributes are implemented in both Ada 83 and Ada 95 modes in GNAT. + + -- The entries marked GNAT are attributes that are defined by GNAT + -- and implemented in both Ada 83 and Ada 95 modes. Full descriptions + -- of these implementation dependent attributes may be found in the + -- appropriate section in package Sem_Attr in file sem-attr.ads. + + -- The entries marked VMS are recognized only in OpenVMS implementations + -- of GNAT, and are treated as illegal in all other contexts. + + First_Attribute_Name : constant Name_Id := N + $; + Name_Abort_Signal : constant Name_Id := N + $; -- GNAT + Name_Access : constant Name_Id := N + $; + Name_Address : constant Name_Id := N + $; + Name_Address_Size : constant Name_Id := N + $; -- GNAT + Name_Aft : constant Name_Id := N + $; + Name_Alignment : constant Name_Id := N + $; + Name_Asm_Input : constant Name_Id := N + $; -- GNAT + Name_Asm_Output : constant Name_Id := N + $; -- GNAT + Name_AST_Entry : constant Name_Id := N + $; -- VMS + Name_Bit : constant Name_Id := N + $; -- GNAT + Name_Bit_Order : constant Name_Id := N + $; + Name_Bit_Position : constant Name_Id := N + $; -- GNAT + Name_Body_Version : constant Name_Id := N + $; + Name_Callable : constant Name_Id := N + $; + Name_Caller : constant Name_Id := N + $; + Name_Code_Address : constant Name_Id := N + $; -- GNAT + Name_Compiler_Version : constant Name_Id := N + $; -- GNAT + Name_Component_Size : constant Name_Id := N + $; + Name_Compose : constant Name_Id := N + $; + Name_Constrained : constant Name_Id := N + $; + Name_Count : constant Name_Id := N + $; + Name_Default_Bit_Order : constant Name_Id := N + $; -- GNAT + Name_Definite : constant Name_Id := N + $; + Name_Delta : constant Name_Id := N + $; + Name_Denorm : constant Name_Id := N + $; + Name_Digits : constant Name_Id := N + $; + Name_Elaborated : constant Name_Id := N + $; -- GNAT + Name_Emax : constant Name_Id := N + $; -- Ada 83 + Name_Enabled : constant Name_Id := N + $; -- GNAT + Name_Enum_Rep : constant Name_Id := N + $; -- GNAT + Name_Enum_Val : constant Name_Id := N + $; -- GNAT + Name_Epsilon : constant Name_Id := N + $; -- Ada 83 + Name_Exponent : constant Name_Id := N + $; + Name_External_Tag : constant Name_Id := N + $; + Name_Fast_Math : constant Name_Id := N + $; -- GNAT + Name_First : constant Name_Id := N + $; + Name_First_Bit : constant Name_Id := N + $; + Name_Fixed_Value : constant Name_Id := N + $; -- GNAT + Name_Fore : constant Name_Id := N + $; + Name_Has_Access_Values : constant Name_Id := N + $; -- GNAT + Name_Has_Discriminants : constant Name_Id := N + $; -- GNAT + Name_Has_Tagged_Values : constant Name_Id := N + $; -- GNAT + Name_Identity : constant Name_Id := N + $; + Name_Img : constant Name_Id := N + $; -- GNAT + Name_Integer_Value : constant Name_Id := N + $; -- GNAT + Name_Invalid_Value : constant Name_Id := N + $; -- GNAT + Name_Large : constant Name_Id := N + $; -- Ada 83 + Name_Last : constant Name_Id := N + $; + Name_Last_Bit : constant Name_Id := N + $; + Name_Leading_Part : constant Name_Id := N + $; + Name_Length : constant Name_Id := N + $; + Name_Machine_Emax : constant Name_Id := N + $; + Name_Machine_Emin : constant Name_Id := N + $; + Name_Machine_Mantissa : constant Name_Id := N + $; + Name_Machine_Overflows : constant Name_Id := N + $; + Name_Machine_Radix : constant Name_Id := N + $; + Name_Machine_Rounding : constant Name_Id := N + $; -- Ada 05 + Name_Machine_Rounds : constant Name_Id := N + $; + Name_Machine_Size : constant Name_Id := N + $; -- GNAT + Name_Mantissa : constant Name_Id := N + $; -- Ada 83 + Name_Max_Alignment_For_Allocation : constant Name_Id := N + $; -- Ada 12 + Name_Max_Size_In_Storage_Elements : constant Name_Id := N + $; + Name_Maximum_Alignment : constant Name_Id := N + $; -- GNAT + Name_Mechanism_Code : constant Name_Id := N + $; -- GNAT + Name_Mod : constant Name_Id := N + $; -- Ada 05 + Name_Model_Emin : constant Name_Id := N + $; + Name_Model_Epsilon : constant Name_Id := N + $; + Name_Model_Mantissa : constant Name_Id := N + $; + Name_Model_Small : constant Name_Id := N + $; + Name_Modulus : constant Name_Id := N + $; + Name_Null_Parameter : constant Name_Id := N + $; -- GNAT + Name_Object_Size : constant Name_Id := N + $; -- GNAT + Name_Old : constant Name_Id := N + $; -- GNAT + Name_Partition_ID : constant Name_Id := N + $; + Name_Passed_By_Reference : constant Name_Id := N + $; -- GNAT + Name_Pool_Address : constant Name_Id := N + $; + Name_Pos : constant Name_Id := N + $; + Name_Position : constant Name_Id := N + $; + Name_Priority : constant Name_Id := N + $; -- Ada 05 + Name_Range : constant Name_Id := N + $; + Name_Range_Length : constant Name_Id := N + $; -- GNAT + Name_Ref : constant Name_Id := N + $; -- GNAT + Name_Result : constant Name_Id := N + $; -- GNAT + Name_Round : constant Name_Id := N + $; + Name_Safe_Emax : constant Name_Id := N + $; -- Ada 83 + Name_Safe_First : constant Name_Id := N + $; + Name_Safe_Large : constant Name_Id := N + $; -- Ada 83 + Name_Safe_Last : constant Name_Id := N + $; + Name_Safe_Small : constant Name_Id := N + $; -- Ada 83 + Name_Scale : constant Name_Id := N + $; + Name_Scaling : constant Name_Id := N + $; + Name_Signed_Zeros : constant Name_Id := N + $; + Name_Size : constant Name_Id := N + $; + Name_Small : constant Name_Id := N + $; + Name_Storage_Size : constant Name_Id := N + $; + Name_Storage_Unit : constant Name_Id := N + $; -- GNAT + Name_Stream_Size : constant Name_Id := N + $; -- Ada 05 + Name_Tag : constant Name_Id := N + $; + Name_Target_Name : constant Name_Id := N + $; -- GNAT + Name_Terminated : constant Name_Id := N + $; + Name_To_Address : constant Name_Id := N + $; -- GNAT + Name_Type_Class : constant Name_Id := N + $; -- GNAT + Name_Type_Key : constant Name_Id := N + $; -- GNAT + Name_UET_Address : constant Name_Id := N + $; -- GNAT + Name_Unbiased_Rounding : constant Name_Id := N + $; + Name_Unchecked_Access : constant Name_Id := N + $; + Name_Unconstrained_Array : constant Name_Id := N + $; + Name_Universal_Literal_String : constant Name_Id := N + $; -- GNAT + Name_Unrestricted_Access : constant Name_Id := N + $; -- GNAT + Name_VADS_Size : constant Name_Id := N + $; -- GNAT + Name_Val : constant Name_Id := N + $; + Name_Valid : constant Name_Id := N + $; + Name_Value_Size : constant Name_Id := N + $; -- GNAT + Name_Version : constant Name_Id := N + $; + Name_Wchar_T_Size : constant Name_Id := N + $; -- GNAT + Name_Wide_Wide_Width : constant Name_Id := N + $; -- Ada 05 + Name_Wide_Width : constant Name_Id := N + $; + Name_Width : constant Name_Id := N + $; + Name_Word_Size : constant Name_Id := N + $; -- GNAT + + -- Attributes that designate attributes returning renamable functions, + -- i.e. functions that return other than a universal value and that + -- have non-universal arguments. + + First_Renamable_Function_Attribute : constant Name_Id := N + $; + Name_Adjacent : constant Name_Id := N + $; + Name_Ceiling : constant Name_Id := N + $; + Name_Copy_Sign : constant Name_Id := N + $; + Name_Floor : constant Name_Id := N + $; + Name_Fraction : constant Name_Id := N + $; + Name_From_Any : constant Name_Id := N + $; -- GNAT + Name_Image : constant Name_Id := N + $; + Name_Input : constant Name_Id := N + $; + Name_Machine : constant Name_Id := N + $; + Name_Max : constant Name_Id := N + $; + Name_Min : constant Name_Id := N + $; + Name_Model : constant Name_Id := N + $; + Name_Pred : constant Name_Id := N + $; + Name_Remainder : constant Name_Id := N + $; + Name_Rounding : constant Name_Id := N + $; + Name_Succ : constant Name_Id := N + $; + Name_To_Any : constant Name_Id := N + $; -- GNAT + Name_Truncation : constant Name_Id := N + $; + Name_TypeCode : constant Name_Id := N + $; -- GNAT + Name_Value : constant Name_Id := N + $; + Name_Wide_Image : constant Name_Id := N + $; + Name_Wide_Wide_Image : constant Name_Id := N + $; + Name_Wide_Value : constant Name_Id := N + $; + Name_Wide_Wide_Value : constant Name_Id := N + $; + Last_Renamable_Function_Attribute : constant Name_Id := N + $; + + -- Attributes that designate procedures + + First_Procedure_Attribute : constant Name_Id := N + $; + Name_Output : constant Name_Id := N + $; + Name_Read : constant Name_Id := N + $; + Name_Write : constant Name_Id := N + $; + Last_Procedure_Attribute : constant Name_Id := N + $; + + -- Remaining attributes are ones that return entities + + First_Entity_Attribute_Name : constant Name_Id := N + $; + Name_Elab_Body : constant Name_Id := N + $; -- GNAT + Name_Elab_Spec : constant Name_Id := N + $; -- GNAT + Name_Storage_Pool : constant Name_Id := N + $; + + -- These attributes are the ones that return types + + First_Type_Attribute_Name : constant Name_Id := N + $; + Name_Base : constant Name_Id := N + $; + Name_Class : constant Name_Id := N + $; + Name_Stub_Type : constant Name_Id := N + $; + Last_Type_Attribute_Name : constant Name_Id := N + $; + Last_Entity_Attribute_Name : constant Name_Id := N + $; + Last_Attribute_Name : constant Name_Id := N + $; + + -- Names of recognized locking policy identifiers + + -- Note: policies are identified by the first character of the + -- name (e.g. C for Ceiling_Locking). If new policy names are added, + -- the first character must be distinct. + + First_Locking_Policy_Name : constant Name_Id := N + $; + Name_Ceiling_Locking : constant Name_Id := N + $; + Name_Inheritance_Locking : constant Name_Id := N + $; + Last_Locking_Policy_Name : constant Name_Id := N + $; + + -- Names of recognized queuing policy identifiers + + -- Note: policies are identified by the first character of the + -- name (e.g. F for FIFO_Queuing). If new policy names are added, + -- the first character must be distinct. + + First_Queuing_Policy_Name : constant Name_Id := N + $; + Name_FIFO_Queuing : constant Name_Id := N + $; + Name_Priority_Queuing : constant Name_Id := N + $; + Last_Queuing_Policy_Name : constant Name_Id := N + $; + + -- Names of recognized task dispatching policy identifiers + + -- Note: policies are identified by the first character of the + -- name (e.g. F for FIFO_Within_Priorities). If new policy names + -- are added, the first character must be distinct. + + First_Task_Dispatching_Policy_Name : constant Name_Id := N + $; + Name_EDF_Across_Priorities : constant Name_Id := N + $; + Name_FIFO_Within_Priorities : constant Name_Id := N + $; + Name_Non_Preemptive_Within_Priorities : constant Name_Id := N + $; + Name_Round_Robin_Within_Priorities : constant Name_Id := N + $; + Last_Task_Dispatching_Policy_Name : constant Name_Id := N + $; + + -- Names of recognized checks for pragma Suppress + + First_Check_Name : constant Name_Id := N + $; + Name_Access_Check : constant Name_Id := N + $; + Name_Accessibility_Check : constant Name_Id := N + $; + Name_Alignment_Check : constant Name_Id := N + $; -- GNAT + Name_Discriminant_Check : constant Name_Id := N + $; + Name_Division_Check : constant Name_Id := N + $; + Name_Elaboration_Check : constant Name_Id := N + $; + Name_Index_Check : constant Name_Id := N + $; + Name_Length_Check : constant Name_Id := N + $; + Name_Overflow_Check : constant Name_Id := N + $; + Name_Range_Check : constant Name_Id := N + $; + Name_Storage_Check : constant Name_Id := N + $; + Name_Tag_Check : constant Name_Id := N + $; + Name_Validity_Check : constant Name_Id := N + $; -- GNAT + Name_All_Checks : constant Name_Id := N + $; + Last_Check_Name : constant Name_Id := N + $; + + -- Names corresponding to reserved keywords, excluding those already + -- declared in the attribute list (Access, Delta, Digits, Mod, Range). + + -- Note: Name_Some is here even though for now we do not treat it as being + -- reserved. We treat it instead as an unreserved keyword. This may change + -- in the future, but in any case it belongs in the following list. + + Name_Abort : constant Name_Id := N + $; + Name_Abs : constant Name_Id := N + $; + Name_Accept : constant Name_Id := N + $; + Name_And : constant Name_Id := N + $; + Name_All : constant Name_Id := N + $; + Name_Array : constant Name_Id := N + $; + Name_At : constant Name_Id := N + $; + Name_Begin : constant Name_Id := N + $; + Name_Body : constant Name_Id := N + $; + Name_Case : constant Name_Id := N + $; + Name_Constant : constant Name_Id := N + $; + Name_Declare : constant Name_Id := N + $; + Name_Delay : constant Name_Id := N + $; + Name_Do : constant Name_Id := N + $; + Name_Else : constant Name_Id := N + $; + Name_Elsif : constant Name_Id := N + $; + Name_End : constant Name_Id := N + $; + Name_Entry : constant Name_Id := N + $; + Name_Exception : constant Name_Id := N + $; + Name_Exit : constant Name_Id := N + $; + Name_For : constant Name_Id := N + $; + Name_Function : constant Name_Id := N + $; + Name_Generic : constant Name_Id := N + $; + Name_Goto : constant Name_Id := N + $; + Name_If : constant Name_Id := N + $; + Name_In : constant Name_Id := N + $; + Name_Is : constant Name_Id := N + $; + Name_Limited : constant Name_Id := N + $; + Name_Loop : constant Name_Id := N + $; + Name_New : constant Name_Id := N + $; + Name_Not : constant Name_Id := N + $; + Name_Null : constant Name_Id := N + $; + Name_Of : constant Name_Id := N + $; + Name_Or : constant Name_Id := N + $; + Name_Others : constant Name_Id := N + $; + Name_Out : constant Name_Id := N + $; + Name_Package : constant Name_Id := N + $; + Name_Pragma : constant Name_Id := N + $; + Name_Private : constant Name_Id := N + $; + Name_Procedure : constant Name_Id := N + $; + Name_Raise : constant Name_Id := N + $; + Name_Record : constant Name_Id := N + $; + Name_Rem : constant Name_Id := N + $; + Name_Renames : constant Name_Id := N + $; + Name_Return : constant Name_Id := N + $; + Name_Reverse : constant Name_Id := N + $; + Name_Select : constant Name_Id := N + $; + Name_Separate : constant Name_Id := N + $; + Name_Some : constant Name_Id := N + $; + Name_Subtype : constant Name_Id := N + $; + Name_Task : constant Name_Id := N + $; + Name_Terminate : constant Name_Id := N + $; + Name_Then : constant Name_Id := N + $; + Name_Type : constant Name_Id := N + $; + Name_Use : constant Name_Id := N + $; + Name_When : constant Name_Id := N + $; + Name_While : constant Name_Id := N + $; + Name_With : constant Name_Id := N + $; + Name_Xor : constant Name_Id := N + $; + + -- Names of intrinsic subprograms + + -- Note: Asm is missing from this list, since Asm is a legitimate + -- convention name. So is To_Address, which is a GNAT attribute. + + First_Intrinsic_Name : constant Name_Id := N + $; + Name_Divide : constant Name_Id := N + $; + Name_Enclosing_Entity : constant Name_Id := N + $; + Name_Exception_Information : constant Name_Id := N + $; + Name_Exception_Message : constant Name_Id := N + $; + Name_Exception_Name : constant Name_Id := N + $; + Name_File : constant Name_Id := N + $; + Name_Generic_Dispatching_Constructor : constant Name_Id := N + $; + Name_Import_Address : constant Name_Id := N + $; + Name_Import_Largest_Value : constant Name_Id := N + $; + Name_Import_Value : constant Name_Id := N + $; + Name_Is_Negative : constant Name_Id := N + $; + Name_Line : constant Name_Id := N + $; + Name_Rotate_Left : constant Name_Id := N + $; + Name_Rotate_Right : constant Name_Id := N + $; + Name_Shift_Left : constant Name_Id := N + $; + Name_Shift_Right : constant Name_Id := N + $; + Name_Shift_Right_Arithmetic : constant Name_Id := N + $; + Name_Source_Location : constant Name_Id := N + $; + Name_Unchecked_Conversion : constant Name_Id := N + $; + Name_Unchecked_Deallocation : constant Name_Id := N + $; + Name_To_Pointer : constant Name_Id := N + $; + Last_Intrinsic_Name : constant Name_Id := N + $; + + -- Names used in processing intrinsic calls + + Name_Free : constant Name_Id := N + $; + + -- Reserved words used only in Ada 95 + + First_95_Reserved_Word : constant Name_Id := N + $; + Name_Abstract : constant Name_Id := N + $; + Name_Aliased : constant Name_Id := N + $; + Name_Protected : constant Name_Id := N + $; + Name_Until : constant Name_Id := N + $; + Name_Requeue : constant Name_Id := N + $; + Name_Tagged : constant Name_Id := N + $; + Last_95_Reserved_Word : constant Name_Id := N + $; + + subtype Ada_95_Reserved_Words is + Name_Id range First_95_Reserved_Word .. Last_95_Reserved_Word; + + -- Miscellaneous names used in semantic checking + + Name_Raise_Exception : constant Name_Id := N + $; + + -- Additional reserved words and identifiers used in GNAT Project Files + -- Note that Name_External is already previously declared + -- The names with the -- GPR annotation are only used in gprbuild + + Name_Aggregate : constant Name_Id := N + $; + Name_Archive_Builder : constant Name_Id := N + $; + Name_Archive_Builder_Append_Option : constant Name_Id := N + $; + Name_Archive_Indexer : constant Name_Id := N + $; + Name_Archive_Suffix : constant Name_Id := N + $; + Name_Binder : constant Name_Id := N + $; + Name_Body_Suffix : constant Name_Id := N + $; + Name_Builder : constant Name_Id := N + $; + Name_Compiler : constant Name_Id := N + $; + Name_Compiler_Command : constant Name_Id := N + $; -- GPR + Name_Config_Body_File_Name : constant Name_Id := N + $; + Name_Config_Body_File_Name_Index : constant Name_Id := N + $; + Name_Config_Body_File_Name_Pattern : constant Name_Id := N + $; + Name_Config_File_Switches : constant Name_Id := N + $; + Name_Config_File_Unique : constant Name_Id := N + $; + Name_Config_Spec_File_Name : constant Name_Id := N + $; + Name_Config_Spec_File_Name_Index : constant Name_Id := N + $; + Name_Config_Spec_File_Name_Pattern : constant Name_Id := N + $; + Name_Configuration : constant Name_Id := N + $; + Name_Cross_Reference : constant Name_Id := N + $; + Name_Default_Language : constant Name_Id := N + $; + Name_Default_Switches : constant Name_Id := N + $; + Name_Dependency_Driver : constant Name_Id := N + $; + Name_Dependency_Switches : constant Name_Id := N + $; + Name_Driver : constant Name_Id := N + $; + Name_Excluded_Source_Dirs : constant Name_Id := N + $; + Name_Excluded_Source_Files : constant Name_Id := N + $; + Name_Excluded_Source_List_File : constant Name_Id := N + $; + Name_Exec_Dir : constant Name_Id := N + $; + Name_Executable : constant Name_Id := N + $; + Name_Executable_Suffix : constant Name_Id := N + $; + Name_Extends : constant Name_Id := N + $; + Name_External_As_List : constant Name_Id := N + $; + Name_Externally_Built : constant Name_Id := N + $; + Name_Finder : constant Name_Id := N + $; + Name_Global_Compilation_Switches : constant Name_Id := N + $; + Name_Global_Configuration_Pragmas : constant Name_Id := N + $; + Name_Global_Config_File : constant Name_Id := N + $; -- GPR + Name_Gnatls : constant Name_Id := N + $; + Name_Gnatstub : constant Name_Id := N + $; + Name_Gnu : constant Name_Id := N + $; + Name_Ide : constant Name_Id := N + $; + Name_Ignore_Source_Sub_Dirs : constant Name_Id := N + $; + Name_Implementation : constant Name_Id := N + $; + Name_Implementation_Exceptions : constant Name_Id := N + $; + Name_Implementation_Suffix : constant Name_Id := N + $; + Name_Include_Switches : constant Name_Id := N + $; + Name_Include_Path : constant Name_Id := N + $; + Name_Include_Path_File : constant Name_Id := N + $; + Name_Inherit_Source_Path : constant Name_Id := N + $; + Name_Languages : constant Name_Id := N + $; + Name_Leading_Library_Options : constant Name_Id := N + $; + Name_Leading_Required_Switches : constant Name_Id := N + $; + Name_Leading_Switches : constant Name_Id := N + $; + Name_Library : constant Name_Id := N + $; + Name_Library_Ali_Dir : constant Name_Id := N + $; + Name_Library_Auto_Init : constant Name_Id := N + $; + Name_Library_Auto_Init_Supported : constant Name_Id := N + $; + Name_Library_Builder : constant Name_Id := N + $; + Name_Library_Dir : constant Name_Id := N + $; + Name_Library_GCC : constant Name_Id := N + $; + Name_Library_Install_Name_Option : constant Name_Id := N + $; + Name_Library_Interface : constant Name_Id := N + $; + Name_Library_Kind : constant Name_Id := N + $; + Name_Library_Name : constant Name_Id := N + $; + Name_Library_Major_Minor_Id_Supported : constant Name_Id := N + $; + Name_Library_Options : constant Name_Id := N + $; + Name_Library_Partial_Linker : constant Name_Id := N + $; + Name_Library_Reference_Symbol_File : constant Name_Id := N + $; + Name_Library_Src_Dir : constant Name_Id := N + $; + Name_Library_Support : constant Name_Id := N + $; + Name_Library_Symbol_File : constant Name_Id := N + $; + Name_Library_Symbol_Policy : constant Name_Id := N + $; + Name_Library_Version : constant Name_Id := N + $; + Name_Library_Version_Switches : constant Name_Id := N + $; + Name_Linker : constant Name_Id := N + $; + Name_Linker_Executable_Option : constant Name_Id := N + $; + Name_Linker_Lib_Dir_Option : constant Name_Id := N + $; + Name_Linker_Lib_Name_Option : constant Name_Id := N + $; + Name_Local_Config_File : constant Name_Id := N + $; -- GPR + Name_Local_Configuration_Pragmas : constant Name_Id := N + $; + Name_Locally_Removed_Files : constant Name_Id := N + $; + Name_Map_File_Option : constant Name_Id := N + $; + Name_Mapping_File_Switches : constant Name_Id := N + $; + Name_Mapping_Spec_Suffix : constant Name_Id := N + $; + Name_Mapping_Body_Suffix : constant Name_Id := N + $; + Name_Max_Command_Line_Length : constant Name_Id := N + $; + Name_Metrics : constant Name_Id := N + $; + Name_Multi_Unit_Object_Separator : constant Name_Id := N + $; + Name_Multi_Unit_Switches : constant Name_Id := N + $; + Name_Naming : constant Name_Id := N + $; + Name_None : constant Name_Id := N + $; + Name_Object_File_Suffix : constant Name_Id := N + $; + Name_Object_File_Switches : constant Name_Id := N + $; + Name_Object_Generated : constant Name_Id := N + $; + Name_Object_List : constant Name_Id := N + $; + Name_Objects_Linked : constant Name_Id := N + $; + Name_Objects_Path : constant Name_Id := N + $; + Name_Objects_Path_File : constant Name_Id := N + $; + Name_Object_Dir : constant Name_Id := N + $; + Name_Option_List : constant Name_Id := N + $; + Name_Path_Syntax : constant Name_Id := N + $; + Name_Pic_Option : constant Name_Id := N + $; + Name_Pretty_Printer : constant Name_Id := N + $; + Name_Prefix : constant Name_Id := N + $; + Name_Project : constant Name_Id := N + $; + Name_Project_Dir : constant Name_Id := N + $; + Name_Project_Files : constant Name_Id := N + $; + Name_Project_Path : constant Name_Id := N + $; + Name_Response_File_Format : constant Name_Id := N + $; + Name_Response_File_Switches : constant Name_Id := N + $; + Name_Roots : constant Name_Id := N + $; -- GPR + Name_Required_Switches : constant Name_Id := N + $; + Name_Run_Path_Option : constant Name_Id := N + $; + Name_Run_Path_Origin : constant Name_Id := N + $; + Name_Separate_Run_Path_Options : constant Name_Id := N + $; + Name_Shared_Library_Minimum_Switches : constant Name_Id := N + $; + Name_Shared_Library_Prefix : constant Name_Id := N + $; + Name_Shared_Library_Suffix : constant Name_Id := N + $; + Name_Separate_Suffix : constant Name_Id := N + $; + Name_Source_Dirs : constant Name_Id := N + $; + Name_Source_Files : constant Name_Id := N + $; + Name_Source_List_File : constant Name_Id := N + $; + Name_Spec : constant Name_Id := N + $; + Name_Spec_Suffix : constant Name_Id := N + $; + Name_Specification : constant Name_Id := N + $; + Name_Specification_Exceptions : constant Name_Id := N + $; + Name_Specification_Suffix : constant Name_Id := N + $; + Name_Stack : constant Name_Id := N + $; + Name_Switches : constant Name_Id := N + $; + Name_Symbolic_Link_Supported : constant Name_Id := N + $; + Name_Synchronize : constant Name_Id := N + $; + Name_Toolchain_Description : constant Name_Id := N + $; + Name_Toolchain_Version : constant Name_Id := N + $; + Name_Trailing_Required_Switches : constant Name_Id := N + $; + Name_Runtime_Library_Dir : constant Name_Id := N + $; + Name_Runtime_Source_Dir : constant Name_Id := N + $; + + -- Other miscellaneous names used in front end + + Name_Unaligned_Valid : constant Name_Id := N + $; + + -- Names used to implement iterators over predefined containers + + Name_Cursor : constant Name_Id := N + $; + Name_Element : constant Name_Id := N + $; + Name_Element_Type : constant Name_Id := N + $; + Name_No_Element : constant Name_Id := N + $; + Name_Previous : constant Name_Id := N + $; + + -- Ada 05 reserved words + + First_2005_Reserved_Word : constant Name_Id := N + $; + Name_Interface : constant Name_Id := N + $; + Name_Overriding : constant Name_Id := N + $; + Name_Synchronized : constant Name_Id := N + $; + Last_2005_Reserved_Word : constant Name_Id := N + $; + + subtype Ada_2005_Reserved_Words is + Name_Id range First_2005_Reserved_Word .. Last_2005_Reserved_Word; + + -- Mark last defined name for consistency check in Snames body + + Last_Predefined_Name : constant Name_Id := N + $; + + --------------------------------------- + -- Subtypes Defining Name Categories -- + --------------------------------------- + + subtype Any_Operator_Name is Name_Id range + First_Operator_Name .. Last_Operator_Name; + + subtype Configuration_Pragma_Names is Name_Id range + First_Pragma_Name .. Last_Configuration_Pragma_Name; + + ------------------------------ + -- Attribute ID Definitions -- + ------------------------------ + + type Attribute_Id is ( + Attribute_Abort_Signal, + Attribute_Access, + Attribute_Address, + Attribute_Address_Size, + Attribute_Aft, + Attribute_Alignment, + Attribute_Asm_Input, + Attribute_Asm_Output, + Attribute_AST_Entry, + Attribute_Bit, + Attribute_Bit_Order, + Attribute_Bit_Position, + Attribute_Body_Version, + Attribute_Callable, + Attribute_Caller, + Attribute_Code_Address, + Attribute_Compiler_Version, + Attribute_Component_Size, + Attribute_Compose, + Attribute_Constrained, + Attribute_Count, + Attribute_Default_Bit_Order, + Attribute_Definite, + Attribute_Delta, + Attribute_Denorm, + Attribute_Digits, + Attribute_Elaborated, + Attribute_Emax, + Attribute_Enabled, + Attribute_Enum_Rep, + Attribute_Enum_Val, + Attribute_Epsilon, + Attribute_Exponent, + Attribute_External_Tag, + Attribute_Fast_Math, + Attribute_First, + Attribute_First_Bit, + Attribute_Fixed_Value, + Attribute_Fore, + Attribute_Has_Access_Values, + Attribute_Has_Discriminants, + Attribute_Has_Tagged_Values, + Attribute_Identity, + Attribute_Img, + Attribute_Integer_Value, + Attribute_Invalid_Value, + Attribute_Large, + Attribute_Last, + Attribute_Last_Bit, + Attribute_Leading_Part, + Attribute_Length, + Attribute_Machine_Emax, + Attribute_Machine_Emin, + Attribute_Machine_Mantissa, + Attribute_Machine_Overflows, + Attribute_Machine_Radix, + Attribute_Machine_Rounding, + Attribute_Machine_Rounds, + Attribute_Machine_Size, + Attribute_Mantissa, + Attribute_Max_Alignment_For_Allocation, + Attribute_Max_Size_In_Storage_Elements, + Attribute_Maximum_Alignment, + Attribute_Mechanism_Code, + Attribute_Mod, + Attribute_Model_Emin, + Attribute_Model_Epsilon, + Attribute_Model_Mantissa, + Attribute_Model_Small, + Attribute_Modulus, + Attribute_Null_Parameter, + Attribute_Object_Size, + Attribute_Old, + Attribute_Partition_ID, + Attribute_Passed_By_Reference, + Attribute_Pool_Address, + Attribute_Pos, + Attribute_Position, + Attribute_Priority, + Attribute_Range, + Attribute_Range_Length, + Attribute_Ref, + Attribute_Result, + Attribute_Round, + Attribute_Safe_Emax, + Attribute_Safe_First, + Attribute_Safe_Large, + Attribute_Safe_Last, + Attribute_Safe_Small, + Attribute_Scale, + Attribute_Scaling, + Attribute_Signed_Zeros, + Attribute_Size, + Attribute_Small, + Attribute_Storage_Size, + Attribute_Storage_Unit, + Attribute_Stream_Size, + Attribute_Tag, + Attribute_Target_Name, + Attribute_Terminated, + Attribute_To_Address, + Attribute_Type_Class, + Attribute_Type_Key, + Attribute_UET_Address, + Attribute_Unbiased_Rounding, + Attribute_Unchecked_Access, + Attribute_Unconstrained_Array, + Attribute_Universal_Literal_String, + Attribute_Unrestricted_Access, + Attribute_VADS_Size, + Attribute_Val, + Attribute_Valid, + Attribute_Value_Size, + Attribute_Version, + Attribute_Wchar_T_Size, + Attribute_Wide_Wide_Width, + Attribute_Wide_Width, + Attribute_Width, + Attribute_Word_Size, + + -- Attributes designating renamable functions + + Attribute_Adjacent, + Attribute_Ceiling, + Attribute_Copy_Sign, + Attribute_Floor, + Attribute_Fraction, + Attribute_From_Any, + Attribute_Image, + Attribute_Input, + Attribute_Machine, + Attribute_Max, + Attribute_Min, + Attribute_Model, + Attribute_Pred, + Attribute_Remainder, + Attribute_Rounding, + Attribute_Succ, + Attribute_To_Any, + Attribute_Truncation, + Attribute_TypeCode, + Attribute_Value, + Attribute_Wide_Image, + Attribute_Wide_Wide_Image, + Attribute_Wide_Value, + Attribute_Wide_Wide_Value, + + -- Attributes designating procedures + + Attribute_Output, + Attribute_Read, + Attribute_Write, + + -- Entity attributes (includes type attributes) + + Attribute_Elab_Body, + Attribute_Elab_Spec, + Attribute_Storage_Pool, + + -- Type attributes + + Attribute_Base, + Attribute_Class, + Attribute_Stub_Type); + + type Attribute_Class_Array is array (Attribute_Id) of Boolean; + -- Type used to build attribute classification flag arrays + + ------------------------------------ + -- Convention Name ID Definitions -- + ------------------------------------ + + type Convention_Id is ( + + -- The native-to-Ada (non-foreign) conventions come first. These include + -- the ones defined in the RM, plus Stubbed. + + Convention_Ada, + Convention_Intrinsic, + Convention_Entry, + Convention_Protected, + Convention_Stubbed, + + -- The remaining conventions are foreign language conventions + + Convention_Assembler, -- also Asm, Assembly + Convention_C, -- also Default, External + Convention_CIL, + Convention_COBOL, + Convention_CPP, + Convention_Fortran, + Convention_Java, + Convention_Stdcall); -- also DLL, Win32 + + -- Note: Convention C_Pass_By_Copy is allowed only for record + -- types (where it is treated like C except that the appropriate + -- flag is set in the record type). Recognizing this convention + -- is specially handled in Sem_Prag. + + for Convention_Id'Size use 8; + -- Plenty of space for expansion + + subtype Foreign_Convention is + Convention_Id range Convention_Assembler .. Convention_Id'Last; + + ----------------------------------- + -- Locking Policy ID Definitions -- + ----------------------------------- + + type Locking_Policy_Id is ( + Locking_Policy_Inheritance_Locking, + Locking_Policy_Ceiling_Locking); + + --------------------------- + -- Pragma ID Definitions -- + --------------------------- + + type Pragma_Id is ( + + -- Configuration pragmas + + -- Note: This list is in the GNAT users guide, so be sure that if any + -- additions or deletions are made to the following list, they are + -- properly reflected in the users guide. + + Pragma_Ada_83, + Pragma_Ada_95, + Pragma_Ada_05, + Pragma_Ada_2005, + Pragma_Ada_12, + Pragma_Ada_2012, + Pragma_Assertion_Policy, + Pragma_Assume_No_Invalid_Values, + Pragma_C_Pass_By_Copy, + Pragma_Check_Name, + Pragma_Check_Policy, + Pragma_Compile_Time_Error, + Pragma_Compile_Time_Warning, + Pragma_Compiler_Unit, + Pragma_Component_Alignment, + Pragma_Convention_Identifier, + Pragma_Debug_Policy, + Pragma_Detect_Blocking, + Pragma_Default_Storage_Pool, + Pragma_Discard_Names, + Pragma_Elaboration_Checks, + Pragma_Eliminate, + Pragma_Extend_System, + Pragma_Extensions_Allowed, + Pragma_External_Name_Casing, + Pragma_Favor_Top_Level, + Pragma_Float_Representation, + Pragma_Implicit_Packing, + Pragma_Initialize_Scalars, + Pragma_Interrupt_State, + Pragma_License, + Pragma_Locking_Policy, + Pragma_Long_Float, + Pragma_No_Run_Time, + Pragma_No_Strict_Aliasing, + Pragma_Normalize_Scalars, + Pragma_Optimize_Alignment, + Pragma_Persistent_BSS, + Pragma_Polling, + Pragma_Priority_Specific_Dispatching, + Pragma_Profile, + Pragma_Profile_Warnings, + Pragma_Propagate_Exceptions, + Pragma_Queuing_Policy, + Pragma_Ravenscar, + Pragma_Restricted_Run_Time, + Pragma_Restrictions, + Pragma_Restriction_Warnings, + Pragma_Reviewable, + Pragma_Short_Circuit_And_Or, + Pragma_Short_Descriptors, + Pragma_Source_File_Name, + Pragma_Source_File_Name_Project, + Pragma_Style_Checks, + Pragma_Suppress, + Pragma_Suppress_Exception_Locations, + Pragma_Task_Dispatching_Policy, + Pragma_Universal_Data, + Pragma_Unsuppress, + Pragma_Use_VADS_Size, + Pragma_Validity_Checks, + Pragma_Warnings, + Pragma_Wide_Character_Encoding, + + -- Remaining (non-configuration) pragmas + + Pragma_Abort_Defer, + Pragma_All_Calls_Remote, + Pragma_Annotate, + Pragma_Assert, + Pragma_Asynchronous, + Pragma_Atomic, + Pragma_Atomic_Components, + Pragma_Attach_Handler, + Pragma_Check, + Pragma_CIL_Constructor, + Pragma_Comment, + Pragma_Common_Object, + Pragma_Complete_Representation, + Pragma_Complex_Representation, + Pragma_Controlled, + Pragma_Convention, + Pragma_CPP_Class, + Pragma_CPP_Constructor, + Pragma_CPP_Virtual, + Pragma_CPP_Vtable, + Pragma_CPU, + Pragma_Debug, + Pragma_Dimension, + Pragma_Elaborate, + Pragma_Elaborate_All, + Pragma_Elaborate_Body, + Pragma_Export, + Pragma_Export_Exception, + Pragma_Export_Function, + Pragma_Export_Object, + Pragma_Export_Procedure, + Pragma_Export_Value, + Pragma_Export_Valued_Procedure, + Pragma_External, + Pragma_Finalize_Storage_Only, + Pragma_Ident, + Pragma_Implemented, + Pragma_Import, + Pragma_Import_Exception, + Pragma_Import_Function, + Pragma_Import_Object, + Pragma_Import_Procedure, + Pragma_Import_Valued_Procedure, + Pragma_Independent, + Pragma_Independent_Components, + Pragma_Inline, + Pragma_Inline_Always, + Pragma_Inline_Generic, + Pragma_Inspection_Point, + Pragma_Interface_Name, + Pragma_Interrupt_Handler, + Pragma_Interrupt_Priority, + Pragma_Invariant, + Pragma_Java_Constructor, + Pragma_Java_Interface, + Pragma_Keep_Names, + Pragma_Link_With, + Pragma_Linker_Alias, + Pragma_Linker_Constructor, + Pragma_Linker_Destructor, + Pragma_Linker_Options, + Pragma_Linker_Section, + Pragma_List, + Pragma_Machine_Attribute, + Pragma_Main, + Pragma_Main_Storage, + Pragma_Memory_Size, + Pragma_No_Body, + Pragma_No_Return, + Pragma_Obsolescent, + Pragma_Optimize, + Pragma_Ordered, + Pragma_Pack, + Pragma_Page, + Pragma_Passive, + Pragma_Postcondition, + Pragma_Precondition, + Pragma_Predicate, + Pragma_Preelaborable_Initialization, + Pragma_Preelaborate, + Pragma_Preelaborate_05, + Pragma_Psect_Object, + Pragma_Pure, + Pragma_Pure_05, + Pragma_Pure_Function, + Pragma_Relative_Deadline, + Pragma_Remote_Call_Interface, + Pragma_Remote_Types, + Pragma_Share_Generic, + Pragma_Shared, + Pragma_Shared_Passive, + Pragma_Source_Reference, + Pragma_Static_Elaboration_Desired, + Pragma_Stream_Convert, + Pragma_Subtitle, + Pragma_Suppress_All, + Pragma_Suppress_Debug_Info, + Pragma_Suppress_Initialization, + Pragma_System_Name, + Pragma_Task_Info, + Pragma_Task_Name, + Pragma_Task_Storage, + Pragma_Thread_Local_Storage, + Pragma_Time_Slice, + Pragma_Title, + Pragma_Unchecked_Union, + Pragma_Unimplemented_Unit, + Pragma_Universal_Aliasing, + Pragma_Unmodified, + Pragma_Unreferenced, + Pragma_Unreferenced_Objects, + Pragma_Unreserve_All_Interrupts, + Pragma_Volatile, + Pragma_Volatile_Components, + Pragma_Weak_External, + + -- The following pragmas are on their own, out of order, because of the + -- special processing required to deal with the fact that their names + -- match existing attribute names. + + Pragma_AST_Entry, + Pragma_Fast_Math, + Pragma_Interface, + Pragma_Priority, + Pragma_Storage_Size, + Pragma_Storage_Unit, + + -- The value to represent an unknown or unrecognized pragma + + Unknown_Pragma); + + ----------------------------------- + -- Queuing Policy ID definitions -- + ----------------------------------- + + type Queuing_Policy_Id is ( + Queuing_Policy_FIFO_Queuing, + Queuing_Policy_Priority_Queuing); + + -------------------------------------------- + -- Task Dispatching Policy ID definitions -- + -------------------------------------------- + + type Task_Dispatching_Policy_Id is ( + Task_Dispatching_FIFO_Within_Priorities); + -- Id values used to identify task dispatching policies + + ----------------- + -- Subprograms -- + ----------------- + + procedure Initialize; + -- Called to initialize the preset names in the names table + + function Is_Attribute_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of a recognized attribute + + function Is_Entity_Attribute_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of a recognized entity attribute, + -- i.e. an attribute reference that returns an entity. + + function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of a recognized attribute that + -- designates a procedure (and can therefore appear as a statement). + + function Is_Function_Attribute_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of a recognized attribute + -- that designates a renameable function, and can therefore appear in + -- a renaming statement. Note that not all attributes designating + -- functions are renamable, in particular, those returning a universal + -- value cannot be renamed. + + function Is_Type_Attribute_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of a recognized type attribute, + -- i.e. an attribute reference that returns a type + + function Is_Convention_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of one of the recognized + -- language conventions, as required by pragma Convention, Import, + -- Export, Interface. Returns True if so. Also returns True for a + -- name that has been specified by a Convention_Identifier pragma. + -- If neither case holds, returns False. + + function Is_Keyword_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is one of the (reserved) keyword names. This + -- includes all the keywords defined in the Ada standard (taking into + -- effect the Ada version). It also includes additional keywords in + -- contexts where additional keywords have been added. For example, in the + -- context of parsing project files, keywords such as PROJECT are included. + + function Is_Locking_Policy_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of a recognized locking policy + + function Is_Operator_Symbol_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of an operator symbol + + function Is_Pragma_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of a recognized pragma. Note that + -- pragmas AST_Entry, Fast_Math, Priority, Storage_Size, and Storage_Unit + -- are recognized as pragmas by this function even though their names are + -- separate from the other pragma names. For this reason, clients should + -- always use this function, rather than do range tests on Name_Id values. + + function Is_Configuration_Pragma_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of a recognized configuration + -- pragma. Note that pragma Fast_Math is recognized as a configuration + -- pragma by this function even though its name is separate from other + -- configuration pragma names. For this reason, clients should always + -- use this function, rather than do range tests on Name_Id values. + + function Is_Queuing_Policy_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of a recognized queuing policy + + function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of a recognized task + -- dispatching policy. + + function Get_Attribute_Id (N : Name_Id) return Attribute_Id; + -- Returns Id of attribute corresponding to given name. It is an error to + -- call this function with a name that is not the name of a attribute. + + function Get_Convention_Id (N : Name_Id) return Convention_Id; + -- Returns Id of language convention corresponding to given name. It is + -- an error to call this function with a name that is not the name of a + -- convention, or one that has been previously recorded using a call to + -- Record_Convention_Identifier. + + function Get_Convention_Name (C : Convention_Id) return Name_Id; + -- Returns the name of language convention corresponding to given + -- convention id. + + function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id; + -- Returns Id of locking policy corresponding to given name. It is an error + -- to call this function with a name that is not the name of a check. + + function Get_Pragma_Id (N : Name_Id) return Pragma_Id; + -- Returns Id of pragma corresponding to given name. Returns Unknown_Pragma + -- if N is not a name of a known (Ada defined or GNAT-specific) pragma. + -- Note that the function also works correctly for names of pragmas that + -- are not included in the main list of pragma Names (AST_Entry, Priority, + -- Storage_Size, and Storage_Unit (e.g. Name_Storage_Size returns + -- Pragma_Storage_Size). + + function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id; + -- Returns Id of queuing policy corresponding to given name. It is an error + -- to call this function with a name that is not the name of a check. + + function Get_Task_Dispatching_Policy_Id + (N : Name_Id) return Task_Dispatching_Policy_Id; + -- Returns Id of task dispatching policy corresponding to given name. It + -- is an error to call this function with a name that is not the name of + -- a defined check. + + procedure Record_Convention_Identifier + (Id : Name_Id; + Convention : Convention_Id); + -- A call to this procedure, resulting from an occurrence of a pragma + -- Convention_Identifier, records that from now on an occurrence of Id + -- will be recognized as a name for the specified convention. + +private + pragma Inline (Is_Attribute_Name); + pragma Inline (Is_Entity_Attribute_Name); + pragma Inline (Is_Type_Attribute_Name); + pragma Inline (Is_Locking_Policy_Name); + pragma Inline (Is_Operator_Symbol_Name); + pragma Inline (Is_Queuing_Policy_Name); + pragma Inline (Is_Pragma_Name); + pragma Inline (Is_Task_Dispatching_Policy_Name); + +end Snames; diff --git a/gcc/ada/snames.h-tmpl b/gcc/ada/snames.h-tmpl new file mode 100644 index 000000000..b15792a57 --- /dev/null +++ b/gcc/ada/snames.h-tmpl @@ -0,0 +1,66 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * S N A M E S * + * * + * C Header File * + * * + * Copyright (C) 1992-2008, Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING3. If not, go to * + * http://www.gnu.org/licenses for a complete copy of the license. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* This is the C file that corresponds to the Ada package specification + Snames. It was created automatically from the file snames.ads. */ + +/* Name_Id values */ + +#define Name_ !! TEMPLATE INSERTION POINT + +/* Define the function to return one of the numeric values below. Note + that it actually returns a char since an enumeration value of less + than 256 entries is represented that way in Ada. The operand is a Chars + field value. */ + +#define Get_Attribute_Id snames__get_attribute_id +extern unsigned char Get_Attribute_Id (int); + +/* Define the numeric values for attributes. */ + +#define Attr_ !! TEMPLATE INSERTION POINT + +/* Define the numeric values for the conventions. */ + +#define Convention_ !! TEMPLATE INSERTION POINT + +/* Define the function to check if a Name_Id value is a valid pragma */ + +#define Is_Pragma_Name snames__is_pragma_name +extern Boolean Is_Pragma_Name (Name_Id); + +/* Define the function to return one of the numeric values below. Note + that it actually returns a char since an enumeration value of less + than 256 entries is represented that way in Ada. The operand is a Chars + field value. */ + +#define Get_Pragma_Id snames__get_pragma_id +extern unsigned char Get_Pragma_Id (int); + +/* Define the numeric values for the pragmas. */ + +#define Pragma_ !! TEMPLATE_INSERTION_POINT + +/* End of snames.h (C version of Snames package spec) */ diff --git a/gcc/ada/socket.c b/gcc/ada/socket.c new file mode 100644 index 000000000..ee1f760da --- /dev/null +++ b/gcc/ada/socket.c @@ -0,0 +1,690 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * S O C K E T * + * * + * C Implementation File * + * * + * Copyright (C) 2003-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. * + * * + ****************************************************************************/ + +/* This file provides a portable binding to the sockets API */ + +#include "gsocket.h" + +#ifdef VMS +/* + * For VMS, gsocket.h can't include sockets-related DEC C header files + * when building the runtime (because these files are in a DEC C text library + * (DECC$RTLDEF.TLB) not accessible to GCC). So, we generate a separate header + * file along with s-oscons.ads and include it here. + */ +# include "s-oscons.h" + +/* + * We also need the declaration of struct hostent/servent, which s-oscons + * can't provide, so we copy it manually here. This needs to be kept in synch + * with the definition of that structure in the DEC C headers, which + * hopefully won't change frequently. + */ +typedef char *__netdb_char_ptr __attribute__ (( mode (SI) )); +typedef __netdb_char_ptr *__netdb_char_ptr_ptr __attribute__ (( mode (SI) )); + +struct hostent { + __netdb_char_ptr h_name; + __netdb_char_ptr_ptr h_aliases; + int h_addrtype; + int h_length; + __netdb_char_ptr_ptr h_addr_list; +}; + +struct servent { + __netdb_char_ptr s_name; + __netdb_char_ptr_ptr s_aliases; + int s_port; + __netdb_char_ptr s_proto; +}; +#endif + +#if defined(HAVE_SOCKETS) + +/* Include all the necessary system-specific headers and define the + * necessary macros (shared with gen-oscons). + */ + +#if !defined(SO_NOSIGPIPE) && !defined (MSG_NOSIGNAL) +#include +#endif +/* Required if we will be calling signal() in __gnat_disable_all_sigpipes() */ + +#include "raise.h" +/* Required for __gnat_malloc() */ + +#include +/* Required for memcpy() */ + +extern void __gnat_disable_sigpipe (int fd); +extern void __gnat_disable_all_sigpipes (void); +extern int __gnat_create_signalling_fds (int *fds); +extern int __gnat_read_signalling_fd (int rsig); +extern int __gnat_write_signalling_fd (int wsig); +extern void __gnat_close_signalling_fd (int sig); +extern void __gnat_last_socket_in_set (fd_set *, int *); +extern void __gnat_get_socket_from_set (fd_set *, int *, int *); +extern void __gnat_insert_socket_in_set (fd_set *, int); +extern int __gnat_is_socket_in_set (fd_set *, int); +extern fd_set *__gnat_new_socket_set (fd_set *); +extern void __gnat_remove_socket_from_set (fd_set *, int); +extern void __gnat_reset_socket_set (fd_set *); +extern int __gnat_get_h_errno (void); +extern int __gnat_socket_ioctl (int, int, int *); + +extern char * __gnat_servent_s_name (struct servent *); +extern char * __gnat_servent_s_alias (struct servent *, int index); +extern unsigned short __gnat_servent_s_port (struct servent *); +extern char * __gnat_servent_s_proto (struct servent *); + +extern char * __gnat_hostent_h_name (struct hostent *); +extern char * __gnat_hostent_h_alias (struct hostent *, int); +extern int __gnat_hostent_h_addrtype (struct hostent *); +extern int __gnat_hostent_h_length (struct hostent *); +extern char * __gnat_hostent_h_addr (struct hostent *, int); + +#ifndef HAVE_INET_PTON +extern int __gnat_inet_pton (int, const char *, void *); +#endif + +/* Disable the sending of SIGPIPE for writes on a broken stream */ + +void +__gnat_disable_sigpipe (int fd) +{ +#ifdef SO_NOSIGPIPE + int val = 1; + (void) setsockopt (fd, SOL_SOCKET, SO_NOSIGPIPE, &val, sizeof val); +#endif +} + +void +__gnat_disable_all_sigpipes (void) +{ +#if !defined(SO_NOSIGPIPE) && !defined(MSG_NOSIGNAL) && defined(SIGPIPE) + (void) signal (SIGPIPE, SIG_IGN); +#endif +} + +#if defined (_WIN32) || defined (__vxworks) || defined (VMS) +/* + * Signalling FDs operations are implemented in Ada for these platforms + * (see subunit GNAT.Sockets.Thin.Signalling_Fds). + */ +#else +/* + * Create a pair of connected file descriptors fds[0] and fds[1] used for + * signalling by a Selector object. fds[0] is the read end, and fds[1] the + * write end. + */ +int +__gnat_create_signalling_fds (int *fds) { + return pipe (fds); +} + +/* + * Read one byte of data from rsig, the read end of a pair of signalling fds + * created by __gnat_create_signalling_fds. + */ +int +__gnat_read_signalling_fd (int rsig) { + char c; + return read (rsig, &c, 1); +} + +/* + * Write one byte of data to wsig, the write end of a pair of signalling fds + * created by __gnat_create_signalling_fds. + */ +int +__gnat_write_signalling_fd (int wsig) { + char c = 0; + return write (wsig, &c, 1); +} + +/* + * Close one end of a pair of signalling fds + */ +void +__gnat_close_signalling_fd (int sig) { + (void) close (sig); +} +#endif + +/* + * Handling of gethostbyname, gethostbyaddr, getservbyname and getservbyport + * ========================================================================= + * + * This module exposes __gnat_getXXXbyYYY operations with the same signature + * as the reentrant variant getXXXbyYYY_r. + * + * On platforms where getXXXbyYYY is intrinsically reentrant, the provided user + * buffer argument is ignored. + * + * When getXXXbyYYY is not reentrant but getXXXbyYYY_r exists, the latter is + * used, and the provided buffer argument must point to a valid, thread-local + * buffer (usually on the caller's stack). + * + * When getXXXbyYYY is not reentrant and no reentrant getXXXbyYYY_r variant + * is available, the non-reentrant getXXXbyYYY is called, the provided user + * buffer is ignored, and the caller is expected to take care of mutual + * exclusion. + */ + +#ifdef HAVE_GETxxxBYyyy_R +int +__gnat_gethostbyname (const char *name, + struct hostent *ret, char *buf, size_t buflen, + int *h_errnop) +{ + struct hostent *rh; + int ri; + +#if defined(__linux__) || defined(__GLIBC__) + (void) gethostbyname_r (name, ret, buf, buflen, &rh, h_errnop); +#else + rh = gethostbyname_r (name, ret, buf, buflen, h_errnop); +#endif + ri = (rh == NULL) ? -1 : 0; + return ri; +} + +int +__gnat_gethostbyaddr (const char *addr, int len, int type, + struct hostent *ret, char *buf, size_t buflen, + int *h_errnop) +{ + struct hostent *rh; + int ri; + +#if defined(__linux__) || defined(__GLIBC__) + (void) gethostbyaddr_r (addr, len, type, ret, buf, buflen, &rh, h_errnop); +#else + rh = gethostbyaddr_r (addr, len, type, ret, buf, buflen, h_errnop); +#endif + ri = (rh == NULL) ? -1 : 0; + return ri; +} + +int +__gnat_getservbyname (const char *name, const char *proto, + struct servent *ret, char *buf, size_t buflen) +{ + struct servent *rh; + int ri; + +#if defined(__linux__) || defined(__GLIBC__) || defined(__rtems__) + (void) getservbyname_r (name, proto, ret, buf, buflen, &rh); +#else + rh = getservbyname_r (name, proto, ret, buf, buflen); +#endif + ri = (rh == NULL) ? -1 : 0; + return ri; +} + +int +__gnat_getservbyport (int port, const char *proto, + struct servent *ret, char *buf, size_t buflen) +{ + struct servent *rh; + int ri; + +#if defined(__linux__) || defined(__GLIBC__) || defined(__rtems__) + (void) getservbyport_r (port, proto, ret, buf, buflen, &rh); +#else + rh = getservbyport_r (port, proto, ret, buf, buflen); +#endif + ri = (rh == NULL) ? -1 : 0; + return ri; +} +#elif defined (__vxworks) +static char vxw_h_name[MAXHOSTNAMELEN + 1]; +static char *vxw_h_aliases[1] = { NULL }; +static int vxw_h_addr; +static char *vxw_h_addr_list[2] = { (char*) &vxw_h_addr, NULL }; + +int +__gnat_gethostbyname (const char *name, + struct hostent *ret, char *buf, size_t buflen, + int *h_errnop) +{ + vxw_h_addr = hostGetByName (name); + if (vxw_h_addr == ERROR) { + *h_errnop = __gnat_get_h_errno (); + return -1; + } + ret->h_name = name; + ret->h_aliases = &vxw_h_aliases; + ret->h_addrtype = AF_INET; + ret->h_length = 4; + ret->h_addr_list = &vxw_h_addr_list; + return 0; +} + +int +__gnat_gethostbyaddr (const char *addr, int len, int type, + struct hostent *ret, char *buf, size_t buflen, + int *h_errnop) +{ + if (type != AF_INET) { + *h_errnop = EAFNOSUPPORT; + return -1; + } + + if (addr == NULL || len != 4) { + *h_errnop = EINVAL; + return -1; + } + + if (hostGetByAddr (*(int*)addr, &vxw_h_name) != OK) { + *h_errnop = __gnat_get_h_errno (); + return -1; + } + + vxw_h_addr = addr; + + ret->h_name = &vxw_h_name; + ret->h_aliases = &vxw_h_aliases; + ret->h_addrtype = AF_INET; + ret->h_length = 4; + ret->h_addr_list = &vxw_h_addr_list; +} + +int +__gnat_getservbyname (const char *name, const char *proto, + struct servent *ret, char *buf, size_t buflen) +{ + /* Not available under VxWorks */ + return -1; +} + +int +__gnat_getservbyport (int port, const char *proto, + struct servent *ret, char *buf, size_t buflen) +{ + /* Not available under VxWorks */ + return -1; +} +#else +int +__gnat_gethostbyname (const char *name, + struct hostent *ret, char *buf, size_t buflen, + int *h_errnop) +{ + struct hostent *rh; + rh = gethostbyname (name); + if (rh == NULL) { + *h_errnop = __gnat_get_h_errno (); + return -1; + } + *ret = *rh; + *h_errnop = 0; + return 0; +} + +int +__gnat_gethostbyaddr (const char *addr, int len, int type, + struct hostent *ret, char *buf, size_t buflen, + int *h_errnop) +{ + struct hostent *rh; + rh = gethostbyaddr (addr, len, type); + if (rh == NULL) { + *h_errnop = __gnat_get_h_errno (); + return -1; + } + *ret = *rh; + *h_errnop = 0; + return 0; +} + +int +__gnat_getservbyname (const char *name, const char *proto, + struct servent *ret, char *buf, size_t buflen) +{ + struct servent *rh; + rh = getservbyname (name, proto); + if (rh == NULL) + return -1; + *ret = *rh; + return 0; +} + +int +__gnat_getservbyport (int port, const char *proto, + struct servent *ret, char *buf, size_t buflen) +{ + struct servent *rh; + rh = getservbyport (port, proto); + if (rh == NULL) + return -1; + *ret = *rh; + return 0; +} +#endif + +/* Find the largest socket in the socket set SET. This is needed for + `select'. LAST is the maximum value for the largest socket. This hint is + used to avoid scanning very large socket sets. On return, LAST is the + actual largest socket in the socket set. */ + +void +__gnat_last_socket_in_set (fd_set *set, int *last) +{ + int s; + int l; + l = -1; + +#ifdef _WIN32 + /* More efficient method for NT. */ + for (s = 0; s < set->fd_count; s++) + if ((int) set->fd_array[s] > l) + l = set->fd_array[s]; + +#else + + for (s = *last; s != -1; s--) + if (FD_ISSET (s, set)) + { + l = s; + break; + } +#endif + + *last = l; +} + +/* Get last socket and remove it from the socket set SET. LAST is the + maximum value of the largest socket. This hint is used to avoid scanning + very large socket sets. On return, LAST is set to the actual largest + socket in the socket set. */ + +void +__gnat_get_socket_from_set (fd_set *set, int *last, int *socket) +{ + *socket = *last; + FD_CLR (*socket, set); + __gnat_last_socket_in_set (set, last); +} + +/* Insert SOCKET in the socket set SET. */ + +void +__gnat_insert_socket_in_set (fd_set *set, int socket) +{ + FD_SET (socket, set); +} + +/* Check whether a given SOCKET is in the socket set SET. */ + +int +__gnat_is_socket_in_set (fd_set *set, int socket) +{ + return FD_ISSET (socket, set); +} + +/* Remove SOCKET from the socket set SET. */ + +void +__gnat_remove_socket_from_set (fd_set *set, int socket) +{ + FD_CLR (socket, set); +} + +/* Reset SET */ +void +__gnat_reset_socket_set (fd_set *set) +{ + FD_ZERO (set); +} + +/* Get the value of the last host error */ + +int +__gnat_get_h_errno (void) { +#ifdef __vxworks + int vxw_errno = errno; + + switch (vxw_errno) { + case 0: + return 0; + +#ifdef S_hostLib_HOST_NOT_FOUND + case S_hostLib_HOST_NOT_FOUND: +#endif + case S_hostLib_UNKNOWN_HOST: + return HOST_NOT_FOUND; + +#ifdef S_hostLib_TRY_AGAIN + case S_hostLib_TRY_AGAIN: + return TRY_AGAIN; +#endif + +#ifdef S_hostLib_NO_RECOVERY + case S_hostLib_NO_RECOVERY: +#endif +#ifdef S_hostLib_NETDB_INTERNAL + case S_hostLib_NETDB_INTERNAL: +#endif + case S_hostLib_INVALID_PARAMETER: + return NO_RECOVERY; + + default: + return -1; + } + +#elif defined (VMS) + /* h_errno is defined as follows in OpenVMS' version of . + * However this header file is not available when building the GNAT + * runtime library using GCC, so we are hardcoding the definition + * directly. Note that the returned address is thread-specific. + */ + extern int *decc$h_errno_get_addr (); + return *decc$h_errno_get_addr (); + +#elif defined (__rtems__) + /* At this stage in the tool build, no networking .h files are available. + * Newlib does not provide networking .h files and RTEMS is not built yet. + * So we need to explicitly extern h_errno to access it. + */ + extern int h_errno; + return h_errno; + +#else + return h_errno; +#endif +} + +/* Wrapper for ioctl(2), which is a variadic function */ + +int +__gnat_socket_ioctl (int fd, int req, int *arg) { +#if defined (_WIN32) + return ioctlsocket (fd, req, arg); +#elif defined (__APPLE__) + /* + * On Darwin, req is an unsigned long, and we want to convert without sign + * extension to get the proper bit pattern in the case of a 64 bit kernel. + */ + return ioctl (fd, (unsigned int) req, arg); +#else + return ioctl (fd, req, arg); +#endif +} + +#ifndef HAVE_INET_PTON + +#ifdef VMS +# define in_addr_t int +# define inet_addr decc$inet_addr +#endif + +int +__gnat_inet_pton (int af, const char *src, void *dst) { + switch (af) { +#if defined (_WIN32) && defined (AF_INET6) + case AF_INET6: +#endif + case AF_INET: + break; + default: + errno = EAFNOSUPPORT; + return -1; + } + +#if defined (__vxworks) + return (inet_aton (src, dst) == OK); + +#elif defined (_WIN32) + struct sockaddr_storage ss; + int sslen = sizeof ss; + int rc; + + ss.ss_family = af; + rc = WSAStringToAddressA (src, af, NULL, (struct sockaddr *)&ss, &sslen); + if (rc == 0) { + switch (af) { + case AF_INET: + *(struct in_addr *)dst = ((struct sockaddr_in *)&ss)->sin_addr; + break; +#ifdef AF_INET6 + case AF_INET6: + *(struct in6_addr *)dst = ((struct sockaddr_in6 *)&ss)->sin6_addr; + break; +#endif + } + } + return (rc == 0); + +#elif defined (__hpux__) || defined (VMS) + in_addr_t addr; + int rc = -1; + + if (src == NULL || dst == NULL) { + errno = EINVAL; + + } else if (!strcmp (src, "255.255.255.255")) { + addr = 0xffffffff; + rc = 1; + + } else { + addr = inet_addr (src); + rc = (addr != 0xffffffff); + } + if (rc == 1) { + *(in_addr_t *)dst = addr; + } + return rc; +#endif +} +#endif + +/* + * Accessor functions for struct hostent. + */ + +char * __gnat_hostent_h_name (struct hostent * h) { + return h->h_name; +} + +char * __gnat_hostent_h_alias (struct hostent * h, int index) { + return h->h_aliases[index]; +} + +int __gnat_hostent_h_addrtype (struct hostent * h) { + return h->h_addrtype; +} + +int __gnat_hostent_h_length (struct hostent * h) { + return h->h_length; +} + +char * __gnat_hostent_h_addr (struct hostent * h, int index) { + return h->h_addr_list[index]; +} + +/* + * Accessor functions for struct servent. + * + * These are needed because servent has different representations on different + * platforms, and we don't want to deal with that on the Ada side. For example, + * on Linux, we have (see /usr/include netdb.h): + * + * struct servent + * { + * char *s_name; + * char **s_aliases; + * int s_port; + * char *s_proto; + * }; + * + * and on Windows (see mingw's socket.h): + * + * struct servent { + * char *s_name; + * char **s_aliases; + * #ifdef _WIN64 + * char *s_proto; + * short s_port; + * #else + * short s_port; + * char *s_proto; + * #endif + * }; + */ + +char * +__gnat_servent_s_name (struct servent * s) +{ + return s->s_name; +} + +char * +__gnat_servent_s_alias (struct servent * s, int index) +{ + return s->s_aliases[index]; +} + +unsigned short +__gnat_servent_s_port (struct servent * s) +{ + return s->s_port; +} + +char * +__gnat_servent_s_proto (struct servent * s) +{ + return s->s_proto; +} + +#else +# warning Sockets are not supported on this platform +#endif /* defined(HAVE_SOCKETS) */ diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb new file mode 100644 index 000000000..e984b5bc8 --- /dev/null +++ b/gcc/ada/sprint.adb @@ -0,0 +1,4482 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S P R I N T -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Aspects; use Aspects; +with Atree; use Atree; +with Casing; use Casing; +with Csets; use Csets; +with Debug; use Debug; +with Einfo; use Einfo; +with Fname; use Fname; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Opt; use Opt; +with Output; use Output; +with Rtsfind; use Rtsfind; +with Sem_Eval; use Sem_Eval; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Sinput.D; use Sinput.D; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Uintp; use Uintp; +with Uname; use Uname; +with Urealp; use Urealp; + +package body Sprint is + Current_Source_File : Source_File_Index; + -- Index of source file whose generated code is being dumped + + Dump_Node : Node_Id := Empty; + -- This is set to the current node, used for printing line numbers. In + -- Debug_Generated_Code mode, Dump_Node is set to the current node + -- requiring Sloc fixup, until Set_Debug_Sloc is called to set the proper + -- value. The call clears it back to Empty. + + Debug_Sloc : Source_Ptr; + -- Sloc of first byte of line currently being written if we are + -- generating a source debug file. + + Dump_Original_Only : Boolean; + -- Set True if the -gnatdo (dump original tree) flag is set + + Dump_Generated_Only : Boolean; + -- Set True if the -gnatdG (dump generated tree) debug flag is set + -- or for Print_Generated_Code (-gnatG) or Dump_Generated_Code (-gnatD). + + Dump_Freeze_Null : Boolean; + -- Set True if freeze nodes and non-source null statements output + + Freeze_Indent : Int := 0; + -- Keep track of freeze indent level (controls output of blank lines before + -- procedures within expression freeze actions). Relevant only if we are + -- not in Dump_Source_Text mode, since in Dump_Source_Text mode we don't + -- output these blank lines in any case. + + Indent : Int := 0; + -- Number of columns for current line output indentation + + Indent_Annull_Flag : Boolean := False; + -- Set True if subsequent Write_Indent call to be ignored, gets reset + -- by this call, so it is only active to suppress a single indent call. + + Last_Line_Printed : Physical_Line_Number; + -- This keeps track of the physical line number of the last source line + -- that has been output. The value is only valid in Dump_Source_Text mode. + + ------------------------------- + -- Operator Precedence Table -- + ------------------------------- + + -- This table is used to decide whether a subexpression needs to be + -- parenthesized. The rule is that if an operand of an operator (which + -- for this purpose includes AND THEN and OR ELSE) is itself an operator + -- with a lower precedence than the operator (or equal precedence if + -- appearing as the right operand), then parentheses are required. + + Op_Prec : constant array (N_Subexpr) of Short_Short_Integer := + (N_Op_And => 1, + N_Op_Or => 1, + N_Op_Xor => 1, + N_And_Then => 1, + N_Or_Else => 1, + + N_In => 2, + N_Not_In => 2, + N_Op_Eq => 2, + N_Op_Ge => 2, + N_Op_Gt => 2, + N_Op_Le => 2, + N_Op_Lt => 2, + N_Op_Ne => 2, + + N_Op_Add => 3, + N_Op_Concat => 3, + N_Op_Subtract => 3, + N_Op_Plus => 3, + N_Op_Minus => 3, + + N_Op_Divide => 4, + N_Op_Mod => 4, + N_Op_Rem => 4, + N_Op_Multiply => 4, + + N_Op_Expon => 5, + N_Op_Abs => 5, + N_Op_Not => 5, + + others => 6); + + procedure Sprint_Left_Opnd (N : Node_Id); + -- Print left operand of operator, parenthesizing if necessary + + procedure Sprint_Right_Opnd (N : Node_Id); + -- Print right operand of operator, parenthesizing if necessary + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Col_Check (N : Nat); + -- Check that at least N characters remain on current line, and if not, + -- then start an extra line with two characters extra indentation for + -- continuing text on the next line. + + procedure Extra_Blank_Line; + -- In some situations we write extra blank lines to separate the generated + -- code to make it more readable. However, these extra blank lines are not + -- generated in Dump_Source_Text mode, since there the source text lines + -- output with preceding blank lines are quite sufficient as separators. + -- This procedure writes a blank line if Dump_Source_Text is False. + + procedure Indent_Annull; + -- Causes following call to Write_Indent to be ignored. This is used when + -- a higher level node wants to stop a lower level node from starting a + -- new line, when it would otherwise be inclined to do so (e.g. the case + -- of an accept statement called from an accept alternative with a guard) + + procedure Indent_Begin; + -- Increase indentation level + + procedure Indent_End; + -- Decrease indentation level + + procedure Print_Debug_Line (S : String); + -- Used to print output lines in Debug_Generated_Code mode (this is used + -- as the argument for a call to Set_Special_Output in package Output). + + procedure Process_TFAI_RR_Flags (Nod : Node_Id); + -- Given a divide, multiplication or division node, check the flags + -- Treat_Fixed_As_Integer and Rounded_Flags, and if set, output the + -- appropriate special syntax characters (# and @). + + procedure Set_Debug_Sloc; + -- If Dump_Node is non-empty, this routine sets the appropriate value + -- in its Sloc field, from the current location in the debug source file + -- that is currently being written. + + procedure Sprint_And_List (List : List_Id); + -- Print the given list with items separated by vertical "and" + + procedure Sprint_Aspect_Specifications (Node : Node_Id); + -- Node is a declaration node that has aspect specifications (Has_Aspects + -- flag set True). It is called after outputting the terminating semicolon + -- for the related node. The effect is to remove the semicolon and print + -- the aspect specifications, followed by a terminating semicolon. + + procedure Sprint_Bar_List (List : List_Id); + -- Print the given list with items separated by vertical bars + + procedure Sprint_End_Label + (Node : Node_Id; + Default : Node_Id); + -- Print the end label for a Handled_Sequence_Of_Statements in a body. + -- If there is not end label, use the defining identifier of the enclosing + -- construct. If the end label is present, treat it as a reference to the + -- defining entity of the construct: this guarantees that it carries the + -- proper sloc information for debugging purposes. + + procedure Sprint_Node_Actual (Node : Node_Id); + -- This routine prints its node argument. It is a lower level routine than + -- Sprint_Node, in that it does not bother about rewritten trees. + + procedure Sprint_Node_Sloc (Node : Node_Id); + -- Like Sprint_Node, but in addition, in Debug_Generated_Code mode, + -- sets the Sloc of the current debug node to be a copy of the Sloc + -- of the sprinted node Node. Note that this is done after printing + -- Node, so that the Sloc is the proper updated value for the debug file. + + procedure Update_Itype (Node : Node_Id); + -- Update the Sloc of an itype that is not attached to the tree, when + -- debugging expanded code. This routine is called from nodes whose + -- type can be an Itype, such as defining_identifiers that may be of + -- an anonymous access type, or ranges in slices. + + procedure Write_Char_Sloc (C : Character); + -- Like Write_Char, except that if C is non-blank, Set_Debug_Sloc is + -- called to ensure that the current node has a proper Sloc set. + + procedure Write_Condition_And_Reason (Node : Node_Id); + -- Write Condition and Reason codes of Raise_xxx_Error node + + procedure Write_Corresponding_Source (S : String); + -- If S is a string with a single keyword (possibly followed by a space), + -- and if the next non-comment non-blank source line matches this keyword, + -- then output all source lines up to this matching line. + + procedure Write_Discr_Specs (N : Node_Id); + -- Output discriminant specification for node, which is any of the type + -- declarations that can have discriminants. + + procedure Write_Ekind (E : Entity_Id); + -- Write the String corresponding to the Ekind without "E_" + + procedure Write_Id (N : Node_Id); + -- N is a node with a Chars field. This procedure writes the name that + -- will be used in the generated code associated with the name. For a + -- node with no associated entity, this is simply the Chars field. For + -- the case where there is an entity associated with the node, we print + -- the name associated with the entity (since it may have been encoded). + -- One other special case is that an entity has an active external name + -- (i.e. an external name present with no address clause), then this + -- external name is output. This procedure also deals with outputting + -- declarations of referenced itypes, if not output earlier. + + function Write_Identifiers (Node : Node_Id) return Boolean; + -- Handle node where the grammar has a list of defining identifiers, but + -- the tree has a separate declaration for each identifier. Handles the + -- printing of the defining identifier, and returns True if the type and + -- initialization information is to be printed, False if it is to be + -- skipped (the latter case happens when printing defining identifiers + -- other than the first in the original tree output case). + + procedure Write_Implicit_Def (E : Entity_Id); + pragma Warnings (Off, Write_Implicit_Def); + -- Write the definition of the implicit type E according to its Ekind + -- For now a debugging procedure, but might be used in the future. + + procedure Write_Indent; + -- Start a new line and write indentation spacing + + function Write_Indent_Identifiers (Node : Node_Id) return Boolean; + -- Like Write_Identifiers except that each new printed declaration + -- is at the start of a new line. + + function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean; + -- Like Write_Indent_Identifiers except that in Debug_Generated_Code + -- mode, the Sloc of the current debug node is set to point to the + -- first output identifier. + + procedure Write_Indent_Str (S : String); + -- Start a new line and write indent spacing followed by given string + + procedure Write_Indent_Str_Sloc (S : String); + -- Like Write_Indent_Str, but in addition, in Debug_Generated_Code mode, + -- the Sloc of the current node is set to the first non-blank character + -- in the string S. + + procedure Write_Itype (Typ : Entity_Id); + -- If Typ is an Itype that has not been written yet, write it. If Typ is + -- any other kind of entity or tree node, the call is ignored. + + procedure Write_Name_With_Col_Check (N : Name_Id); + -- Write name (using Write_Name) with initial column check, and possible + -- initial Write_Indent (to get new line) if current line is too full. + + procedure Write_Name_With_Col_Check_Sloc (N : Name_Id); + -- Like Write_Name_With_Col_Check but in addition, in Debug_Generated_Code + -- mode, sets Sloc of current debug node to first character of name. + + procedure Write_Operator (N : Node_Id; S : String); + -- Like Write_Str_Sloc, used for operators, encloses the string in + -- characters {} if the Do_Overflow flag is set on the node N. + + procedure Write_Param_Specs (N : Node_Id); + -- Output parameter specifications for node (which is either a function + -- or procedure specification with a Parameter_Specifications field) + + procedure Write_Rewrite_Str (S : String); + -- Writes out a string (typically containing <<< or >>>}) for a node + -- created by rewriting the tree. Suppressed if we are outputting the + -- generated code only, since in this case we don't specially mark nodes + -- created by rewriting). + + procedure Write_Source_Line (L : Physical_Line_Number); + -- If writing of interspersed source lines is enabled, then write the given + -- line from the source file, preceded by Eol, then an extra blank line if + -- the line has at least one blank, is not a comment and is not line one, + -- then "--" and the line number followed by period followed by text of the + -- source line (without terminating Eol). If interspersed source line + -- output not enabled, then the call has no effect. + + procedure Write_Source_Lines (L : Physical_Line_Number); + -- If writing of interspersed source lines is enabled, then writes source + -- lines Last_Line_Printed + 1 .. L, and updates Last_Line_Printed. If + -- interspersed source line output not enabled, then call has no effect. + + procedure Write_Str_Sloc (S : String); + -- Like Write_Str, but sets debug Sloc of current debug node to first + -- non-blank character if a current debug node is active. + + procedure Write_Str_With_Col_Check (S : String); + -- Write string (using Write_Str) with initial column check, and possible + -- initial Write_Indent (to get new line) if current line is too full. + + procedure Write_Str_With_Col_Check_Sloc (S : String); + -- Like Write_Str_With_Col_Check, but sets debug Sloc of current debug + -- node to first non-blank character if a current debug node is active. + + procedure Write_Subprogram_Name (N : Node_Id); + -- N is the Name field of a function call or procedure statement call. + -- The effect of the call is to output the name, preceded by a $ if the + -- call is identified as an implicit call to a run time routine. + + procedure Write_Uint_With_Col_Check (U : Uint; Format : UI_Format); + -- Write Uint (using UI_Write) with initial column check, and possible + -- initial Write_Indent (to get new line) if current line is too full. + -- The format parameter determines the output format (see UI_Write). + + procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format); + -- Write Uint (using UI_Write) with initial column check, and possible + -- initial Write_Indent (to get new line) if current line is too full. + -- The format parameter determines the output format (see UI_Write). + -- In addition, in Debug_Generated_Code mode, sets the current node + -- Sloc to the first character of the output value. + + procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal); + -- Write Ureal (using same output format as UR_Write) with column checks + -- and a possible initial Write_Indent (to get new line) if current line + -- is too full. In addition, in Debug_Generated_Code mode, sets the + -- current node Sloc to the first character of the output value. + + --------------- + -- Col_Check -- + --------------- + + procedure Col_Check (N : Nat) is + begin + if N + Column > Sprint_Line_Limit then + Write_Indent_Str (" "); + end if; + end Col_Check; + + ---------------------- + -- Extra_Blank_Line -- + ---------------------- + + procedure Extra_Blank_Line is + begin + if not Dump_Source_Text then + Write_Indent; + end if; + end Extra_Blank_Line; + + ------------------- + -- Indent_Annull -- + ------------------- + + procedure Indent_Annull is + begin + Indent_Annull_Flag := True; + end Indent_Annull; + + ------------------ + -- Indent_Begin -- + ------------------ + + procedure Indent_Begin is + begin + Indent := Indent + 3; + end Indent_Begin; + + ---------------- + -- Indent_End -- + ---------------- + + procedure Indent_End is + begin + Indent := Indent - 3; + end Indent_End; + + -------- + -- pg -- + -------- + + procedure pg (Arg : Union_Id) is + begin + Dump_Generated_Only := True; + Dump_Original_Only := False; + Dump_Freeze_Null := True; + Current_Source_File := No_Source_File; + + if Arg in List_Range then + Sprint_Node_List (List_Id (Arg)); + + elsif Arg in Node_Range then + Sprint_Node (Node_Id (Arg)); + + else + null; + end if; + + Write_Eol; + end pg; + + -------- + -- po -- + -------- + + procedure po (Arg : Union_Id) is + begin + Dump_Generated_Only := False; + Dump_Original_Only := True; + Current_Source_File := No_Source_File; + + if Arg in List_Range then + Sprint_Node_List (List_Id (Arg)); + + elsif Arg in Node_Range then + Sprint_Node (Node_Id (Arg)); + + else + null; + end if; + + Write_Eol; + end po; + + ---------------------- + -- Print_Debug_Line -- + ---------------------- + + procedure Print_Debug_Line (S : String) is + begin + Write_Debug_Line (S, Debug_Sloc); + end Print_Debug_Line; + + --------------------------- + -- Process_TFAI_RR_Flags -- + --------------------------- + + procedure Process_TFAI_RR_Flags (Nod : Node_Id) is + begin + if Treat_Fixed_As_Integer (Nod) then + Write_Char ('#'); + end if; + + if Rounded_Result (Nod) then + Write_Char ('@'); + end if; + end Process_TFAI_RR_Flags; + + -------- + -- ps -- + -------- + + procedure ps (Arg : Union_Id) is + begin + Dump_Generated_Only := False; + Dump_Original_Only := False; + Current_Source_File := No_Source_File; + + if Arg in List_Range then + Sprint_Node_List (List_Id (Arg)); + + elsif Arg in Node_Range then + Sprint_Node (Node_Id (Arg)); + + else + null; + end if; + + Write_Eol; + end ps; + + -------------------- + -- Set_Debug_Sloc -- + -------------------- + + procedure Set_Debug_Sloc is + begin + if Debug_Generated_Code and then Present (Dump_Node) then + Set_Sloc (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1)); + Dump_Node := Empty; + end if; + end Set_Debug_Sloc; + + ----------------- + -- Source_Dump -- + ----------------- + + procedure Source_Dump is + + procedure Underline; + -- Put underline under string we just printed + + --------------- + -- Underline -- + --------------- + + procedure Underline is + Col : constant Int := Column; + + begin + Write_Eol; + + while Col > Column loop + Write_Char ('-'); + end loop; + + Write_Eol; + end Underline; + + -- Start of processing for Source_Dump + + begin + Dump_Generated_Only := Debug_Flag_G or + Print_Generated_Code or + Debug_Generated_Code; + Dump_Original_Only := Debug_Flag_O; + Dump_Freeze_Null := Debug_Flag_S or Debug_Flag_G; + + -- Note that we turn off the tree dump flags immediately, before + -- starting the dump. This avoids generating two copies of the dump + -- if an abort occurs after printing the dump, and more importantly, + -- avoids an infinite loop if an abort occurs during the dump. + + if Debug_Flag_Z then + Current_Source_File := No_Source_File; + Debug_Flag_Z := False; + Write_Eol; + Write_Eol; + Write_Str ("Source recreated from tree of Standard (spec)"); + Underline; + Sprint_Node (Standard_Package_Node); + Write_Eol; + Write_Eol; + end if; + + if Debug_Flag_S or Dump_Generated_Only or Dump_Original_Only then + Debug_Flag_G := False; + Debug_Flag_O := False; + Debug_Flag_S := False; + + -- Dump requested units + + for U in Main_Unit .. Last_Unit loop + Current_Source_File := Source_Index (U); + + -- Dump all units if -gnatdf set, otherwise we dump only + -- the source files that are in the extended main source. + + if Debug_Flag_F + or else In_Extended_Main_Source_Unit (Cunit_Entity (U)) + then + -- If we are generating debug files, setup to write them + + if Debug_Generated_Code then + Set_Special_Output (Print_Debug_Line'Access); + Create_Debug_Source (Source_Index (U), Debug_Sloc); + Write_Source_Line (1); + Last_Line_Printed := 1; + Sprint_Node (Cunit (U)); + Write_Source_Lines (Last_Source_Line (Current_Source_File)); + Write_Eol; + Close_Debug_Source; + Set_Special_Output (null); + + -- Normal output to standard output file + + else + Write_Str ("Source recreated from tree for "); + Write_Unit_Name (Unit_Name (U)); + Underline; + Write_Source_Line (1); + Last_Line_Printed := 1; + Sprint_Node (Cunit (U)); + Write_Source_Lines (Last_Source_Line (Current_Source_File)); + Write_Eol; + Write_Eol; + end if; + end if; + end loop; + end if; + end Source_Dump; + + --------------------- + -- Sprint_And_List -- + --------------------- + + procedure Sprint_And_List (List : List_Id) is + Node : Node_Id; + begin + if Is_Non_Empty_List (List) then + Node := First (List); + loop + Sprint_Node (Node); + Next (Node); + exit when Node = Empty; + Write_Str (" and "); + end loop; + end if; + end Sprint_And_List; + + ---------------------------------- + -- Sprint_Aspect_Specifications -- + ---------------------------------- + + procedure Sprint_Aspect_Specifications (Node : Node_Id) is + AS : constant List_Id := Aspect_Specifications (Node); + A : Node_Id; + + begin + Write_Erase_Char (';'); + Indent := Indent + 2; + Write_Indent; + Write_Str ("with "); + Indent := Indent + 5; + + A := First (AS); + loop + Sprint_Node (Identifier (A)); + + if Class_Present (A) then + Write_Str ("'Class"); + end if; + + if Present (Expression (A)) then + Write_Str (" => "); + Sprint_Node (Expression (A)); + end if; + + Next (A); + + exit when No (A); + Write_Char (','); + Write_Indent; + end loop; + + Indent := Indent - 7; + Write_Char (';'); + end Sprint_Aspect_Specifications; + + --------------------- + -- Sprint_Bar_List -- + --------------------- + + procedure Sprint_Bar_List (List : List_Id) is + Node : Node_Id; + begin + if Is_Non_Empty_List (List) then + Node := First (List); + loop + Sprint_Node (Node); + Next (Node); + exit when Node = Empty; + Write_Str (" | "); + end loop; + end if; + end Sprint_Bar_List; + + ---------------------- + -- Sprint_End_Label -- + ---------------------- + + procedure Sprint_End_Label + (Node : Node_Id; + Default : Node_Id) + is + begin + if Present (Node) + and then Present (End_Label (Node)) + and then Is_Entity_Name (End_Label (Node)) + then + Set_Entity (End_Label (Node), Default); + + -- For a function whose name is an operator, use the qualified name + -- created for the defining entity. + + if Nkind (End_Label (Node)) = N_Operator_Symbol then + Set_Chars (End_Label (Node), Chars (Default)); + end if; + + Sprint_Node (End_Label (Node)); + else + Sprint_Node (Default); + end if; + end Sprint_End_Label; + + ----------------------- + -- Sprint_Comma_List -- + ----------------------- + + procedure Sprint_Comma_List (List : List_Id) is + Node : Node_Id; + + begin + if Is_Non_Empty_List (List) then + Node := First (List); + loop + Sprint_Node (Node); + Next (Node); + exit when Node = Empty; + + if not Is_Rewrite_Insertion (Node) + or else not Dump_Original_Only + then + Write_Str (", "); + end if; + end loop; + end if; + end Sprint_Comma_List; + + -------------------------- + -- Sprint_Indented_List -- + -------------------------- + + procedure Sprint_Indented_List (List : List_Id) is + begin + Indent_Begin; + Sprint_Node_List (List); + Indent_End; + end Sprint_Indented_List; + + --------------------- + -- Sprint_Left_Opnd -- + --------------------- + + procedure Sprint_Left_Opnd (N : Node_Id) is + Opnd : constant Node_Id := Left_Opnd (N); + + begin + if Paren_Count (Opnd) /= 0 + or else Op_Prec (Nkind (Opnd)) >= Op_Prec (Nkind (N)) + then + Sprint_Node (Opnd); + + else + Write_Char ('('); + Sprint_Node (Opnd); + Write_Char (')'); + end if; + end Sprint_Left_Opnd; + + ----------------- + -- Sprint_Node -- + ----------------- + + procedure Sprint_Node (Node : Node_Id) is + begin + if Is_Rewrite_Insertion (Node) then + if not Dump_Original_Only then + + -- For special cases of nodes that always output <<< >>> + -- do not duplicate the output at this point. + + if Nkind (Node) = N_Freeze_Entity + or else Nkind (Node) = N_Implicit_Label_Declaration + then + Sprint_Node_Actual (Node); + + -- Normal case where <<< >>> may be required + + else + Write_Rewrite_Str ("<<<"); + Sprint_Node_Actual (Node); + Write_Rewrite_Str (">>>"); + end if; + end if; + + elsif Is_Rewrite_Substitution (Node) then + + -- Case of dump generated only + + if Dump_Generated_Only then + Sprint_Node_Actual (Node); + + -- Case of dump original only + + elsif Dump_Original_Only then + Sprint_Node_Actual (Original_Node (Node)); + + -- Case of both being dumped + + else + Sprint_Node_Actual (Original_Node (Node)); + Write_Rewrite_Str ("<<<"); + Sprint_Node_Actual (Node); + Write_Rewrite_Str (">>>"); + end if; + + else + Sprint_Node_Actual (Node); + end if; + end Sprint_Node; + + ------------------------ + -- Sprint_Node_Actual -- + ------------------------ + + procedure Sprint_Node_Actual (Node : Node_Id) is + Save_Dump_Node : constant Node_Id := Dump_Node; + + begin + if Node = Empty then + return; + end if; + + for J in 1 .. Paren_Count (Node) loop + Write_Str_With_Col_Check ("("); + end loop; + + -- Setup current dump node + + Dump_Node := Node; + + if Nkind (Node) in N_Subexpr + and then Do_Range_Check (Node) + then + Write_Str_With_Col_Check ("{"); + end if; + + -- Select print circuit based on node kind + + case Nkind (Node) is + when N_Abort_Statement => + Write_Indent_Str_Sloc ("abort "); + Sprint_Comma_List (Names (Node)); + Write_Char (';'); + + when N_Abortable_Part => + Set_Debug_Sloc; + Write_Str_Sloc ("abort "); + Sprint_Indented_List (Statements (Node)); + + when N_Abstract_Subprogram_Declaration => + Write_Indent; + Sprint_Node (Specification (Node)); + Write_Str_With_Col_Check (" is "); + Write_Str_Sloc ("abstract;"); + + when N_Accept_Alternative => + Sprint_Node_List (Pragmas_Before (Node)); + + if Present (Condition (Node)) then + Write_Indent_Str ("when "); + Sprint_Node (Condition (Node)); + Write_Str (" => "); + Indent_Annull; + end if; + + Sprint_Node_Sloc (Accept_Statement (Node)); + Sprint_Node_List (Statements (Node)); + + when N_Accept_Statement => + Write_Indent_Str_Sloc ("accept "); + Write_Id (Entry_Direct_Name (Node)); + + if Present (Entry_Index (Node)) then + Write_Str_With_Col_Check (" ("); + Sprint_Node (Entry_Index (Node)); + Write_Char (')'); + end if; + + Write_Param_Specs (Node); + + if Present (Handled_Statement_Sequence (Node)) then + Write_Str_With_Col_Check (" do"); + Sprint_Node (Handled_Statement_Sequence (Node)); + Write_Indent_Str ("end "); + Write_Id (Entry_Direct_Name (Node)); + end if; + + Write_Char (';'); + + when N_Access_Definition => + + -- Ada 2005 (AI-254) + + if Present (Access_To_Subprogram_Definition (Node)) then + Sprint_Node (Access_To_Subprogram_Definition (Node)); + else + -- Ada 2005 (AI-231) + + if Null_Exclusion_Present (Node) then + Write_Str ("not null "); + end if; + + Write_Str_With_Col_Check_Sloc ("access "); + + if All_Present (Node) then + Write_Str ("all "); + elsif Constant_Present (Node) then + Write_Str ("constant "); + end if; + + Sprint_Node (Subtype_Mark (Node)); + end if; + + when N_Access_Function_Definition => + + -- Ada 2005 (AI-231) + + if Null_Exclusion_Present (Node) then + Write_Str ("not null "); + end if; + + Write_Str_With_Col_Check_Sloc ("access "); + + if Protected_Present (Node) then + Write_Str_With_Col_Check ("protected "); + end if; + + Write_Str_With_Col_Check ("function"); + Write_Param_Specs (Node); + Write_Str_With_Col_Check (" return "); + Sprint_Node (Result_Definition (Node)); + + when N_Access_Procedure_Definition => + + -- Ada 2005 (AI-231) + + if Null_Exclusion_Present (Node) then + Write_Str ("not null "); + end if; + + Write_Str_With_Col_Check_Sloc ("access "); + + if Protected_Present (Node) then + Write_Str_With_Col_Check ("protected "); + end if; + + Write_Str_With_Col_Check ("procedure"); + Write_Param_Specs (Node); + + when N_Access_To_Object_Definition => + Write_Str_With_Col_Check_Sloc ("access "); + + if All_Present (Node) then + Write_Str_With_Col_Check ("all "); + elsif Constant_Present (Node) then + Write_Str_With_Col_Check ("constant "); + end if; + + -- Ada 2005 (AI-231) + + if Null_Exclusion_Present (Node) then + Write_Str ("not null "); + end if; + + Sprint_Node (Subtype_Indication (Node)); + + when N_Aggregate => + if Null_Record_Present (Node) then + Write_Str_With_Col_Check_Sloc ("(null record)"); + + else + Write_Str_With_Col_Check_Sloc ("("); + + if Present (Expressions (Node)) then + Sprint_Comma_List (Expressions (Node)); + + if Present (Component_Associations (Node)) + and then not Is_Empty_List (Component_Associations (Node)) + then + Write_Str (", "); + end if; + end if; + + if Present (Component_Associations (Node)) + and then not Is_Empty_List (Component_Associations (Node)) + then + Indent_Begin; + + declare + Nd : Node_Id; + + begin + Nd := First (Component_Associations (Node)); + + loop + Write_Indent; + Sprint_Node (Nd); + Next (Nd); + exit when No (Nd); + + if not Is_Rewrite_Insertion (Nd) + or else not Dump_Original_Only + then + Write_Str (", "); + end if; + end loop; + end; + + Indent_End; + end if; + + Write_Char (')'); + end if; + + when N_Allocator => + Write_Str_With_Col_Check_Sloc ("new "); + + -- Ada 2005 (AI-231) + + if Null_Exclusion_Present (Node) then + Write_Str ("not null "); + end if; + + Sprint_Node (Expression (Node)); + + if Present (Storage_Pool (Node)) then + Write_Str_With_Col_Check ("[storage_pool = "); + Sprint_Node (Storage_Pool (Node)); + Write_Char (']'); + end if; + + when N_And_Then => + Sprint_Left_Opnd (Node); + Write_Str_Sloc (" and then "); + Sprint_Right_Opnd (Node); + + when N_Aspect_Specification => + raise Program_Error; + + when N_Assignment_Statement => + Write_Indent; + Sprint_Node (Name (Node)); + Write_Str_Sloc (" := "); + Sprint_Node (Expression (Node)); + Write_Char (';'); + + when N_Asynchronous_Select => + Write_Indent_Str_Sloc ("select"); + Indent_Begin; + Sprint_Node (Triggering_Alternative (Node)); + Indent_End; + + -- Note: let the printing of Abortable_Part handle outputting + -- the ABORT keyword, so that the Sloc can be set correctly. + + Write_Indent_Str ("then "); + Sprint_Node (Abortable_Part (Node)); + Write_Indent_Str ("end select;"); + + when N_At_Clause => + Write_Indent_Str_Sloc ("for "); + Write_Id (Identifier (Node)); + Write_Str_With_Col_Check (" use at "); + Sprint_Node (Expression (Node)); + Write_Char (';'); + + when N_Attribute_Definition_Clause => + Write_Indent_Str_Sloc ("for "); + Sprint_Node (Name (Node)); + Write_Char ('''); + Write_Name_With_Col_Check (Chars (Node)); + Write_Str_With_Col_Check (" use "); + Sprint_Node (Expression (Node)); + Write_Char (';'); + + when N_Attribute_Reference => + if Is_Procedure_Attribute_Name (Attribute_Name (Node)) then + Write_Indent; + end if; + + Sprint_Node (Prefix (Node)); + Write_Char_Sloc ('''); + Write_Name_With_Col_Check (Attribute_Name (Node)); + Sprint_Paren_Comma_List (Expressions (Node)); + + if Is_Procedure_Attribute_Name (Attribute_Name (Node)) then + Write_Char (';'); + end if; + + when N_Block_Statement => + Write_Indent; + + if Present (Identifier (Node)) + and then (not Has_Created_Identifier (Node) + or else not Dump_Original_Only) + then + Write_Rewrite_Str ("<<<"); + Write_Id (Identifier (Node)); + Write_Str (" : "); + Write_Rewrite_Str (">>>"); + end if; + + if Present (Declarations (Node)) then + Write_Str_With_Col_Check_Sloc ("declare"); + Sprint_Indented_List (Declarations (Node)); + Write_Indent; + end if; + + Write_Str_With_Col_Check_Sloc ("begin"); + Sprint_Node (Handled_Statement_Sequence (Node)); + Write_Indent_Str ("end"); + + if Present (Identifier (Node)) + and then (not Has_Created_Identifier (Node) + or else not Dump_Original_Only) + then + Write_Rewrite_Str ("<<<"); + Write_Char (' '); + Write_Id (Identifier (Node)); + Write_Rewrite_Str (">>>"); + end if; + + Write_Char (';'); + + when N_Case_Expression => + declare + Alt : Node_Id; + + begin + Write_Str_With_Col_Check_Sloc ("(case "); + Sprint_Node (Expression (Node)); + Write_Str_With_Col_Check (" is"); + + Alt := First (Alternatives (Node)); + loop + Sprint_Node (Alt); + Next (Alt); + exit when No (Alt); + Write_Char (','); + end loop; + + Write_Char (')'); + end; + + when N_Case_Expression_Alternative => + Write_Str_With_Col_Check (" when "); + Sprint_Bar_List (Discrete_Choices (Node)); + Write_Str (" => "); + Sprint_Node (Expression (Node)); + + when N_Case_Statement => + Write_Indent_Str_Sloc ("case "); + Sprint_Node (Expression (Node)); + Write_Str (" is"); + Sprint_Indented_List (Alternatives (Node)); + Write_Indent_Str ("end case;"); + + when N_Case_Statement_Alternative => + Write_Indent_Str_Sloc ("when "); + Sprint_Bar_List (Discrete_Choices (Node)); + Write_Str (" => "); + Sprint_Indented_List (Statements (Node)); + + when N_Character_Literal => + if Column > Sprint_Line_Limit - 2 then + Write_Indent_Str (" "); + end if; + + Write_Char_Sloc ('''); + Write_Char_Code (UI_To_CC (Char_Literal_Value (Node))); + Write_Char ('''); + + when N_Code_Statement => + Write_Indent; + Set_Debug_Sloc; + Sprint_Node (Expression (Node)); + Write_Char (';'); + + when N_Compilation_Unit => + Sprint_Node_List (Context_Items (Node)); + Sprint_Opt_Node_List (Declarations (Aux_Decls_Node (Node))); + + if Private_Present (Node) then + Write_Indent_Str ("private "); + Indent_Annull; + end if; + + Sprint_Node_Sloc (Unit (Node)); + + if Present (Actions (Aux_Decls_Node (Node))) + or else + Present (Pragmas_After (Aux_Decls_Node (Node))) + then + Write_Indent; + end if; + + Sprint_Opt_Node_List (Actions (Aux_Decls_Node (Node))); + Sprint_Opt_Node_List (Pragmas_After (Aux_Decls_Node (Node))); + + when N_Compilation_Unit_Aux => + null; -- nothing to do, never used, see above + + when N_Component_Association => + Set_Debug_Sloc; + Sprint_Bar_List (Choices (Node)); + Write_Str (" => "); + + -- Ada 2005 (AI-287): Print the box if present + + if Box_Present (Node) then + Write_Str_With_Col_Check ("<>"); + else + Sprint_Node (Expression (Node)); + end if; + + when N_Component_Clause => + Write_Indent; + Sprint_Node (Component_Name (Node)); + Write_Str_Sloc (" at "); + Sprint_Node (Position (Node)); + Write_Char (' '); + Write_Str_With_Col_Check ("range "); + Sprint_Node (First_Bit (Node)); + Write_Str (" .. "); + Sprint_Node (Last_Bit (Node)); + Write_Char (';'); + + when N_Component_Definition => + Set_Debug_Sloc; + + -- Ada 2005 (AI-230): Access definition components + + if Present (Access_Definition (Node)) then + Sprint_Node (Access_Definition (Node)); + + elsif Present (Subtype_Indication (Node)) then + if Aliased_Present (Node) then + Write_Str_With_Col_Check ("aliased "); + end if; + + -- Ada 2005 (AI-231) + + if Null_Exclusion_Present (Node) then + Write_Str (" not null "); + end if; + + Sprint_Node (Subtype_Indication (Node)); + + else + Write_Str (" ??? "); + end if; + + when N_Component_Declaration => + if Write_Indent_Identifiers_Sloc (Node) then + Write_Str (" : "); + Sprint_Node (Component_Definition (Node)); + + if Present (Expression (Node)) then + Write_Str (" := "); + Sprint_Node (Expression (Node)); + end if; + + Write_Char (';'); + end if; + + when N_Component_List => + if Null_Present (Node) then + Indent_Begin; + Write_Indent_Str_Sloc ("null"); + Write_Char (';'); + Indent_End; + + else + Set_Debug_Sloc; + Sprint_Indented_List (Component_Items (Node)); + Sprint_Node (Variant_Part (Node)); + end if; + + when N_Conditional_Entry_Call => + Write_Indent_Str_Sloc ("select"); + Indent_Begin; + Sprint_Node (Entry_Call_Alternative (Node)); + Indent_End; + Write_Indent_Str ("else"); + Sprint_Indented_List (Else_Statements (Node)); + Write_Indent_Str ("end select;"); + + when N_Conditional_Expression => + declare + Condition : constant Node_Id := First (Expressions (Node)); + Then_Expr : constant Node_Id := Next (Condition); + + begin + Write_Str_With_Col_Check_Sloc ("(if "); + Sprint_Node (Condition); + Write_Str_With_Col_Check (" then "); + + -- Defense against junk here! + + if Present (Then_Expr) then + Sprint_Node (Then_Expr); + Write_Str_With_Col_Check (" else "); + Sprint_Node (Next (Then_Expr)); + end if; + + Write_Char (')'); + end; + + when N_Constrained_Array_Definition => + Write_Str_With_Col_Check_Sloc ("array "); + Sprint_Paren_Comma_List (Discrete_Subtype_Definitions (Node)); + Write_Str (" of "); + + Sprint_Node (Component_Definition (Node)); + + when N_Decimal_Fixed_Point_Definition => + Write_Str_With_Col_Check_Sloc (" delta "); + Sprint_Node (Delta_Expression (Node)); + Write_Str_With_Col_Check ("digits "); + Sprint_Node (Digits_Expression (Node)); + Sprint_Opt_Node (Real_Range_Specification (Node)); + + when N_Defining_Character_Literal => + Write_Name_With_Col_Check_Sloc (Chars (Node)); + + when N_Defining_Identifier => + Set_Debug_Sloc; + Write_Id (Node); + + when N_Defining_Operator_Symbol => + Write_Name_With_Col_Check_Sloc (Chars (Node)); + + when N_Defining_Program_Unit_Name => + Set_Debug_Sloc; + Sprint_Node (Name (Node)); + Write_Char ('.'); + Write_Id (Defining_Identifier (Node)); + + when N_Delay_Alternative => + Sprint_Node_List (Pragmas_Before (Node)); + + if Present (Condition (Node)) then + Write_Indent; + Write_Str_With_Col_Check ("when "); + Sprint_Node (Condition (Node)); + Write_Str (" => "); + Indent_Annull; + end if; + + Sprint_Node_Sloc (Delay_Statement (Node)); + Sprint_Node_List (Statements (Node)); + + when N_Delay_Relative_Statement => + Write_Indent_Str_Sloc ("delay "); + Sprint_Node (Expression (Node)); + Write_Char (';'); + + when N_Delay_Until_Statement => + Write_Indent_Str_Sloc ("delay until "); + Sprint_Node (Expression (Node)); + Write_Char (';'); + + when N_Delta_Constraint => + Write_Str_With_Col_Check_Sloc ("delta "); + Sprint_Node (Delta_Expression (Node)); + Sprint_Opt_Node (Range_Constraint (Node)); + + when N_Derived_Type_Definition => + if Abstract_Present (Node) then + Write_Str_With_Col_Check ("abstract "); + end if; + + Write_Str_With_Col_Check ("new "); + + -- Ada 2005 (AI-231) + + if Null_Exclusion_Present (Node) then + Write_Str_With_Col_Check ("not null "); + end if; + + Sprint_Node (Subtype_Indication (Node)); + + if Present (Interface_List (Node)) then + Write_Str_With_Col_Check (" and "); + Sprint_And_List (Interface_List (Node)); + Write_Str_With_Col_Check (" with "); + end if; + + if Present (Record_Extension_Part (Node)) then + if No (Interface_List (Node)) then + Write_Str_With_Col_Check (" with "); + end if; + + Sprint_Node (Record_Extension_Part (Node)); + end if; + + when N_Designator => + Sprint_Node (Name (Node)); + Write_Char_Sloc ('.'); + Write_Id (Identifier (Node)); + + when N_Digits_Constraint => + Write_Str_With_Col_Check_Sloc ("digits "); + Sprint_Node (Digits_Expression (Node)); + Sprint_Opt_Node (Range_Constraint (Node)); + + when N_Discriminant_Association => + Set_Debug_Sloc; + + if Present (Selector_Names (Node)) then + Sprint_Bar_List (Selector_Names (Node)); + Write_Str (" => "); + end if; + + Set_Debug_Sloc; + Sprint_Node (Expression (Node)); + + when N_Discriminant_Specification => + Set_Debug_Sloc; + + if Write_Identifiers (Node) then + Write_Str (" : "); + + if Null_Exclusion_Present (Node) then + Write_Str ("not null "); + end if; + + Sprint_Node (Discriminant_Type (Node)); + + if Present (Expression (Node)) then + Write_Str (" := "); + Sprint_Node (Expression (Node)); + end if; + else + Write_Str (", "); + end if; + + when N_Elsif_Part => + Write_Indent_Str_Sloc ("elsif "); + Sprint_Node (Condition (Node)); + Write_Str_With_Col_Check (" then"); + Sprint_Indented_List (Then_Statements (Node)); + + when N_Empty => + null; + + when N_Entry_Body => + Write_Indent_Str_Sloc ("entry "); + Write_Id (Defining_Identifier (Node)); + Sprint_Node (Entry_Body_Formal_Part (Node)); + Write_Str_With_Col_Check (" is"); + Sprint_Indented_List (Declarations (Node)); + Write_Indent_Str ("begin"); + Sprint_Node (Handled_Statement_Sequence (Node)); + Write_Indent_Str ("end "); + Write_Id (Defining_Identifier (Node)); + Write_Char (';'); + + when N_Entry_Body_Formal_Part => + if Present (Entry_Index_Specification (Node)) then + Write_Str_With_Col_Check_Sloc (" ("); + Sprint_Node (Entry_Index_Specification (Node)); + Write_Char (')'); + end if; + + Write_Param_Specs (Node); + Write_Str_With_Col_Check_Sloc (" when "); + Sprint_Node (Condition (Node)); + + when N_Entry_Call_Alternative => + Sprint_Node_List (Pragmas_Before (Node)); + Sprint_Node_Sloc (Entry_Call_Statement (Node)); + Sprint_Node_List (Statements (Node)); + + when N_Entry_Call_Statement => + Write_Indent; + Sprint_Node_Sloc (Name (Node)); + Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node)); + Write_Char (';'); + + when N_Entry_Declaration => + Write_Indent_Str_Sloc ("entry "); + Write_Id (Defining_Identifier (Node)); + + if Present (Discrete_Subtype_Definition (Node)) then + Write_Str_With_Col_Check (" ("); + Sprint_Node (Discrete_Subtype_Definition (Node)); + Write_Char (')'); + end if; + + Write_Param_Specs (Node); + Write_Char (';'); + + when N_Entry_Index_Specification => + Write_Str_With_Col_Check_Sloc ("for "); + Write_Id (Defining_Identifier (Node)); + Write_Str_With_Col_Check (" in "); + Sprint_Node (Discrete_Subtype_Definition (Node)); + + when N_Enumeration_Representation_Clause => + Write_Indent_Str_Sloc ("for "); + Write_Id (Identifier (Node)); + Write_Str_With_Col_Check (" use "); + Sprint_Node (Array_Aggregate (Node)); + Write_Char (';'); + + when N_Enumeration_Type_Definition => + Set_Debug_Sloc; + + -- Skip attempt to print Literals field if it's not there and + -- we are in package Standard (case of Character, which is + -- handled specially (without an explicit literals list). + + if Sloc (Node) > Standard_Location + or else Present (Literals (Node)) + then + Sprint_Paren_Comma_List (Literals (Node)); + end if; + + when N_Error => + Write_Str_With_Col_Check_Sloc (""); + + when N_Exception_Declaration => + if Write_Indent_Identifiers (Node) then + Write_Str_With_Col_Check (" : "); + + if Is_Statically_Allocated (Defining_Identifier (Node)) then + Write_Str_With_Col_Check ("static "); + end if; + + Write_Str_Sloc ("exception"); + + if Present (Expression (Node)) then + Write_Str (" := "); + Sprint_Node (Expression (Node)); + end if; + + Write_Char (';'); + end if; + + when N_Exception_Handler => + Write_Indent_Str_Sloc ("when "); + + if Present (Choice_Parameter (Node)) then + Sprint_Node (Choice_Parameter (Node)); + Write_Str (" : "); + end if; + + Sprint_Bar_List (Exception_Choices (Node)); + Write_Str (" => "); + Sprint_Indented_List (Statements (Node)); + + when N_Exception_Renaming_Declaration => + Write_Indent; + Set_Debug_Sloc; + Sprint_Node (Defining_Identifier (Node)); + Write_Str_With_Col_Check (" : exception renames "); + Sprint_Node (Name (Node)); + Write_Char (';'); + + when N_Exit_Statement => + Write_Indent_Str_Sloc ("exit"); + Sprint_Opt_Node (Name (Node)); + + if Present (Condition (Node)) then + Write_Str_With_Col_Check (" when "); + Sprint_Node (Condition (Node)); + end if; + + Write_Char (';'); + + when N_Expanded_Name => + Sprint_Node (Prefix (Node)); + Write_Char_Sloc ('.'); + Sprint_Node (Selector_Name (Node)); + + when N_Explicit_Dereference => + Sprint_Node (Prefix (Node)); + Write_Char_Sloc ('.'); + Write_Str_Sloc ("all"); + + when N_Expression_With_Actions => + Indent_Begin; + Write_Indent_Str_Sloc ("do "); + Indent_Begin; + Sprint_Node_List (Actions (Node)); + Indent_End; + Write_Indent; + Write_Str_With_Col_Check_Sloc ("in "); + Sprint_Node (Expression (Node)); + Write_Str_With_Col_Check (" end"); + Indent_End; + Write_Indent; + + when N_Extended_Return_Statement => + Write_Indent_Str_Sloc ("return "); + Sprint_Node_List (Return_Object_Declarations (Node)); + + if Present (Handled_Statement_Sequence (Node)) then + Write_Str_With_Col_Check (" do"); + Sprint_Node (Handled_Statement_Sequence (Node)); + Write_Indent_Str ("end return;"); + else + Write_Indent_Str (";"); + end if; + + when N_Extension_Aggregate => + Write_Str_With_Col_Check_Sloc ("("); + Sprint_Node (Ancestor_Part (Node)); + Write_Str_With_Col_Check (" with "); + + if Null_Record_Present (Node) then + Write_Str_With_Col_Check ("null record"); + else + if Present (Expressions (Node)) then + Sprint_Comma_List (Expressions (Node)); + + if Present (Component_Associations (Node)) then + Write_Str (", "); + end if; + end if; + + if Present (Component_Associations (Node)) then + Sprint_Comma_List (Component_Associations (Node)); + end if; + end if; + + Write_Char (')'); + + when N_Floating_Point_Definition => + Write_Str_With_Col_Check_Sloc ("digits "); + Sprint_Node (Digits_Expression (Node)); + Sprint_Opt_Node (Real_Range_Specification (Node)); + + when N_Formal_Decimal_Fixed_Point_Definition => + Write_Str_With_Col_Check_Sloc ("delta <> digits <>"); + + when N_Formal_Derived_Type_Definition => + Write_Str_With_Col_Check_Sloc ("new "); + Sprint_Node (Subtype_Mark (Node)); + + if Present (Interface_List (Node)) then + Write_Str_With_Col_Check (" and "); + Sprint_And_List (Interface_List (Node)); + end if; + + if Private_Present (Node) then + Write_Str_With_Col_Check (" with private"); + end if; + + when N_Formal_Abstract_Subprogram_Declaration => + Write_Indent_Str_Sloc ("with "); + Sprint_Node (Specification (Node)); + + Write_Str_With_Col_Check (" is abstract"); + + if Box_Present (Node) then + Write_Str_With_Col_Check (" <>"); + elsif Present (Default_Name (Node)) then + Write_Str_With_Col_Check (" "); + Sprint_Node (Default_Name (Node)); + end if; + + Write_Char (';'); + + when N_Formal_Concrete_Subprogram_Declaration => + Write_Indent_Str_Sloc ("with "); + Sprint_Node (Specification (Node)); + + if Box_Present (Node) then + Write_Str_With_Col_Check (" is <>"); + elsif Present (Default_Name (Node)) then + Write_Str_With_Col_Check (" is "); + Sprint_Node (Default_Name (Node)); + end if; + + Write_Char (';'); + + when N_Formal_Discrete_Type_Definition => + Write_Str_With_Col_Check_Sloc ("<>"); + + when N_Formal_Floating_Point_Definition => + Write_Str_With_Col_Check_Sloc ("digits <>"); + + when N_Formal_Modular_Type_Definition => + Write_Str_With_Col_Check_Sloc ("mod <>"); + + when N_Formal_Object_Declaration => + Set_Debug_Sloc; + + if Write_Indent_Identifiers (Node) then + Write_Str (" : "); + + if In_Present (Node) then + Write_Str_With_Col_Check ("in "); + end if; + + if Out_Present (Node) then + Write_Str_With_Col_Check ("out "); + end if; + + if Present (Subtype_Mark (Node)) then + + -- Ada 2005 (AI-423): Formal object with null exclusion + + if Null_Exclusion_Present (Node) then + Write_Str ("not null "); + end if; + + Sprint_Node (Subtype_Mark (Node)); + + -- Ada 2005 (AI-423): Formal object with access definition + + else + pragma Assert (Present (Access_Definition (Node))); + + Sprint_Node (Access_Definition (Node)); + end if; + + if Present (Default_Expression (Node)) then + Write_Str (" := "); + Sprint_Node (Default_Expression (Node)); + end if; + + Write_Char (';'); + end if; + + when N_Formal_Ordinary_Fixed_Point_Definition => + Write_Str_With_Col_Check_Sloc ("delta <>"); + + when N_Formal_Package_Declaration => + Write_Indent_Str_Sloc ("with package "); + Write_Id (Defining_Identifier (Node)); + Write_Str_With_Col_Check (" is new "); + Sprint_Node (Name (Node)); + Write_Str_With_Col_Check (" (<>);"); + + when N_Formal_Private_Type_Definition => + if Abstract_Present (Node) then + Write_Str_With_Col_Check ("abstract "); + end if; + + if Tagged_Present (Node) then + Write_Str_With_Col_Check ("tagged "); + end if; + + if Limited_Present (Node) then + Write_Str_With_Col_Check ("limited "); + end if; + + Write_Str_With_Col_Check_Sloc ("private"); + + when N_Formal_Signed_Integer_Type_Definition => + Write_Str_With_Col_Check_Sloc ("range <>"); + + when N_Formal_Type_Declaration => + Write_Indent_Str_Sloc ("type "); + Write_Id (Defining_Identifier (Node)); + + if Present (Discriminant_Specifications (Node)) then + Write_Discr_Specs (Node); + elsif Unknown_Discriminants_Present (Node) then + Write_Str_With_Col_Check ("(<>)"); + end if; + + Write_Str_With_Col_Check (" is "); + Sprint_Node (Formal_Type_Definition (Node)); + Write_Char (';'); + + when N_Free_Statement => + Write_Indent_Str_Sloc ("free "); + Sprint_Node (Expression (Node)); + Write_Char (';'); + + when N_Freeze_Entity => + if Dump_Original_Only then + null; + + elsif Present (Actions (Node)) or else Dump_Freeze_Null then + Write_Indent; + Write_Rewrite_Str ("<<<"); + Write_Str_With_Col_Check_Sloc ("freeze "); + Write_Id (Entity (Node)); + Write_Str (" ["); + + if No (Actions (Node)) then + Write_Char (']'); + + else + -- Output freeze actions. We increment Freeze_Indent during + -- this output to avoid generating extra blank lines before + -- any procedures included in the freeze actions. + + Freeze_Indent := Freeze_Indent + 1; + Sprint_Indented_List (Actions (Node)); + Freeze_Indent := Freeze_Indent - 1; + Write_Indent_Str ("]"); + end if; + + Write_Rewrite_Str (">>>"); + end if; + + when N_Full_Type_Declaration => + Write_Indent_Str_Sloc ("type "); + Sprint_Node (Defining_Identifier (Node)); + Write_Discr_Specs (Node); + Write_Str_With_Col_Check (" is "); + Sprint_Node (Type_Definition (Node)); + Write_Char (';'); + + when N_Function_Call => + Set_Debug_Sloc; + Write_Subprogram_Name (Name (Node)); + Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node)); + + when N_Function_Instantiation => + Write_Indent_Str_Sloc ("function "); + Sprint_Node (Defining_Unit_Name (Node)); + Write_Str_With_Col_Check (" is new "); + Sprint_Node (Name (Node)); + Sprint_Opt_Paren_Comma_List (Generic_Associations (Node)); + Write_Char (';'); + + when N_Function_Specification => + Write_Str_With_Col_Check_Sloc ("function "); + Sprint_Node (Defining_Unit_Name (Node)); + Write_Param_Specs (Node); + Write_Str_With_Col_Check (" return "); + + -- Ada 2005 (AI-231) + + if Nkind (Result_Definition (Node)) /= N_Access_Definition + and then Null_Exclusion_Present (Node) + then + Write_Str (" not null "); + end if; + + Sprint_Node (Result_Definition (Node)); + + when N_Generic_Association => + Set_Debug_Sloc; + + if Present (Selector_Name (Node)) then + Sprint_Node (Selector_Name (Node)); + Write_Str (" => "); + end if; + + Sprint_Node (Explicit_Generic_Actual_Parameter (Node)); + + when N_Generic_Function_Renaming_Declaration => + Write_Indent_Str_Sloc ("generic function "); + Sprint_Node (Defining_Unit_Name (Node)); + Write_Str_With_Col_Check (" renames "); + Sprint_Node (Name (Node)); + Write_Char (';'); + + when N_Generic_Package_Declaration => + Extra_Blank_Line; + Write_Indent_Str_Sloc ("generic "); + Sprint_Indented_List (Generic_Formal_Declarations (Node)); + Write_Indent; + Sprint_Node (Specification (Node)); + Write_Char (';'); + + when N_Generic_Package_Renaming_Declaration => + Write_Indent_Str_Sloc ("generic package "); + Sprint_Node (Defining_Unit_Name (Node)); + Write_Str_With_Col_Check (" renames "); + Sprint_Node (Name (Node)); + Write_Char (';'); + + when N_Generic_Procedure_Renaming_Declaration => + Write_Indent_Str_Sloc ("generic procedure "); + Sprint_Node (Defining_Unit_Name (Node)); + Write_Str_With_Col_Check (" renames "); + Sprint_Node (Name (Node)); + Write_Char (';'); + + when N_Generic_Subprogram_Declaration => + Extra_Blank_Line; + Write_Indent_Str_Sloc ("generic "); + Sprint_Indented_List (Generic_Formal_Declarations (Node)); + Write_Indent; + Sprint_Node (Specification (Node)); + Write_Char (';'); + + when N_Goto_Statement => + Write_Indent_Str_Sloc ("goto "); + Sprint_Node (Name (Node)); + Write_Char (';'); + + if Nkind (Next (Node)) = N_Label then + Write_Indent; + end if; + + when N_Handled_Sequence_Of_Statements => + Set_Debug_Sloc; + Sprint_Indented_List (Statements (Node)); + + if Present (Exception_Handlers (Node)) then + Write_Indent_Str ("exception"); + Indent_Begin; + Sprint_Node_List (Exception_Handlers (Node)); + Indent_End; + end if; + + if Present (At_End_Proc (Node)) then + Write_Indent_Str ("at end"); + Indent_Begin; + Write_Indent; + Sprint_Node (At_End_Proc (Node)); + Write_Char (';'); + Indent_End; + end if; + + when N_Identifier => + Set_Debug_Sloc; + Write_Id (Node); + + when N_If_Statement => + Write_Indent_Str_Sloc ("if "); + Sprint_Node (Condition (Node)); + Write_Str_With_Col_Check (" then"); + Sprint_Indented_List (Then_Statements (Node)); + Sprint_Opt_Node_List (Elsif_Parts (Node)); + + if Present (Else_Statements (Node)) then + Write_Indent_Str ("else"); + Sprint_Indented_List (Else_Statements (Node)); + end if; + + Write_Indent_Str ("end if;"); + + when N_Implicit_Label_Declaration => + if not Dump_Original_Only then + Write_Indent; + Write_Rewrite_Str ("<<<"); + Set_Debug_Sloc; + Write_Id (Defining_Identifier (Node)); + Write_Str (" : "); + Write_Str_With_Col_Check ("label"); + Write_Rewrite_Str (">>>"); + end if; + + when N_In => + Sprint_Left_Opnd (Node); + Write_Str_Sloc (" in "); + + if Present (Right_Opnd (Node)) then + Sprint_Right_Opnd (Node); + else + Sprint_Bar_List (Alternatives (Node)); + end if; + + when N_Incomplete_Type_Declaration => + Write_Indent_Str_Sloc ("type "); + Write_Id (Defining_Identifier (Node)); + + if Present (Discriminant_Specifications (Node)) then + Write_Discr_Specs (Node); + elsif Unknown_Discriminants_Present (Node) then + Write_Str_With_Col_Check ("(<>)"); + end if; + + Write_Char (';'); + + when N_Index_Or_Discriminant_Constraint => + Set_Debug_Sloc; + Sprint_Paren_Comma_List (Constraints (Node)); + + when N_Indexed_Component => + Sprint_Node_Sloc (Prefix (Node)); + Sprint_Opt_Paren_Comma_List (Expressions (Node)); + + when N_Integer_Literal => + if Print_In_Hex (Node) then + Write_Uint_With_Col_Check_Sloc (Intval (Node), Hex); + else + Write_Uint_With_Col_Check_Sloc (Intval (Node), Auto); + end if; + + when N_Iteration_Scheme => + if Present (Condition (Node)) then + Write_Str_With_Col_Check_Sloc ("while "); + Sprint_Node (Condition (Node)); + else + Write_Str_With_Col_Check_Sloc ("for "); + + if Present (Iterator_Specification (Node)) then + Sprint_Node (Iterator_Specification (Node)); + else + Sprint_Node (Loop_Parameter_Specification (Node)); + end if; + end if; + + Write_Char (' '); + + when N_Iterator_Specification => + Set_Debug_Sloc; + Write_Id (Defining_Identifier (Node)); + + if Present (Subtype_Indication (Node)) then + Write_Str_With_Col_Check (" : "); + Sprint_Node (Subtype_Indication (Node)); + end if; + + if Of_Present (Node) then + Write_Str_With_Col_Check (" of "); + else + Write_Str_With_Col_Check (" in "); + end if; + + if Reverse_Present (Node) then + Write_Str_With_Col_Check ("reverse "); + end if; + + Sprint_Node (Name (Node)); + + when N_Itype_Reference => + Write_Indent_Str_Sloc ("reference "); + Write_Id (Itype (Node)); + + when N_Label => + Write_Indent_Str_Sloc ("<<"); + Write_Id (Identifier (Node)); + Write_Str (">>"); + + when N_Loop_Parameter_Specification => + Set_Debug_Sloc; + Write_Id (Defining_Identifier (Node)); + Write_Str_With_Col_Check (" in "); + + if Reverse_Present (Node) then + Write_Str_With_Col_Check ("reverse "); + end if; + + Sprint_Node (Discrete_Subtype_Definition (Node)); + + when N_Loop_Statement => + Write_Indent; + + if Present (Identifier (Node)) + and then (not Has_Created_Identifier (Node) + or else not Dump_Original_Only) + then + Write_Rewrite_Str ("<<<"); + Write_Id (Identifier (Node)); + Write_Str (" : "); + Write_Rewrite_Str (">>>"); + Sprint_Node (Iteration_Scheme (Node)); + Write_Str_With_Col_Check_Sloc ("loop"); + Sprint_Indented_List (Statements (Node)); + Write_Indent_Str ("end loop "); + Write_Rewrite_Str ("<<<"); + Write_Id (Identifier (Node)); + Write_Rewrite_Str (">>>"); + Write_Char (';'); + + else + Sprint_Node (Iteration_Scheme (Node)); + Write_Str_With_Col_Check_Sloc ("loop"); + Sprint_Indented_List (Statements (Node)); + Write_Indent_Str ("end loop;"); + end if; + + when N_Mod_Clause => + Sprint_Node_List (Pragmas_Before (Node)); + Write_Str_With_Col_Check_Sloc ("at mod "); + Sprint_Node (Expression (Node)); + + when N_Modular_Type_Definition => + Write_Str_With_Col_Check_Sloc ("mod "); + Sprint_Node (Expression (Node)); + + when N_Not_In => + Sprint_Left_Opnd (Node); + Write_Str_Sloc (" not in "); + + if Present (Right_Opnd (Node)) then + Sprint_Right_Opnd (Node); + else + Sprint_Bar_List (Alternatives (Node)); + end if; + + when N_Null => + Write_Str_With_Col_Check_Sloc ("null"); + + when N_Null_Statement => + if Comes_From_Source (Node) + or else Dump_Freeze_Null + or else not Is_List_Member (Node) + or else (No (Prev (Node)) and then No (Next (Node))) + then + Write_Indent_Str_Sloc ("null;"); + end if; + + when N_Number_Declaration => + Set_Debug_Sloc; + + if Write_Indent_Identifiers (Node) then + Write_Str_With_Col_Check (" : constant "); + Write_Str (" := "); + Sprint_Node (Expression (Node)); + Write_Char (';'); + end if; + + when N_Object_Declaration => + Set_Debug_Sloc; + + if Write_Indent_Identifiers (Node) then + declare + Def_Id : constant Entity_Id := Defining_Identifier (Node); + + begin + Write_Str_With_Col_Check (" : "); + + if Is_Statically_Allocated (Def_Id) then + Write_Str_With_Col_Check ("static "); + end if; + + if Aliased_Present (Node) then + Write_Str_With_Col_Check ("aliased "); + end if; + + if Constant_Present (Node) then + Write_Str_With_Col_Check ("constant "); + end if; + + -- Ada 2005 (AI-231) + + if Null_Exclusion_Present (Node) then + Write_Str_With_Col_Check ("not null "); + end if; + + Sprint_Node (Object_Definition (Node)); + + if Present (Expression (Node)) then + Write_Str (" := "); + Sprint_Node (Expression (Node)); + end if; + + Write_Char (';'); + + -- Handle implicit importation and implicit exportation of + -- object declarations: + -- $pragma import (Convention_Id, Def_Id, "..."); + -- $pragma export (Convention_Id, Def_Id, "..."); + + if Is_Internal (Def_Id) + and then Present (Interface_Name (Def_Id)) + then + Write_Indent_Str_Sloc ("$pragma "); + + if Is_Imported (Def_Id) then + Write_Str ("import ("); + + else pragma Assert (Is_Exported (Def_Id)); + Write_Str ("export ("); + end if; + + declare + Prefix : constant String := "Convention_"; + S : constant String := Convention (Def_Id)'Img; + + begin + Name_Len := S'Last - Prefix'Last; + Name_Buffer (1 .. Name_Len) := + S (Prefix'Last + 1 .. S'Last); + Set_Casing (All_Lower_Case); + Write_Str (Name_Buffer (1 .. Name_Len)); + end; + + Write_Str (", "); + Write_Id (Def_Id); + Write_Str (", "); + Write_String_Table_Entry + (Strval (Interface_Name (Def_Id))); + Write_Str (");"); + end if; + end; + end if; + + when N_Object_Renaming_Declaration => + Write_Indent; + Set_Debug_Sloc; + Sprint_Node (Defining_Identifier (Node)); + Write_Str (" : "); + + -- Ada 2005 (AI-230): Access renamings + + if Present (Access_Definition (Node)) then + Sprint_Node (Access_Definition (Node)); + + elsif Present (Subtype_Mark (Node)) then + + -- Ada 2005 (AI-423): Object renaming with a null exclusion + + if Null_Exclusion_Present (Node) then + Write_Str ("not null "); + end if; + + Sprint_Node (Subtype_Mark (Node)); + + else + Write_Str (" ??? "); + end if; + + Write_Str_With_Col_Check (" renames "); + Sprint_Node (Name (Node)); + Write_Char (';'); + + when N_Op_Abs => + Write_Operator (Node, "abs "); + Sprint_Right_Opnd (Node); + + when N_Op_Add => + Sprint_Left_Opnd (Node); + Write_Operator (Node, " + "); + Sprint_Right_Opnd (Node); + + when N_Op_And => + Sprint_Left_Opnd (Node); + Write_Operator (Node, " and "); + Sprint_Right_Opnd (Node); + + when N_Op_Concat => + Sprint_Left_Opnd (Node); + Write_Operator (Node, " & "); + Sprint_Right_Opnd (Node); + + when N_Op_Divide => + Sprint_Left_Opnd (Node); + Write_Char (' '); + Process_TFAI_RR_Flags (Node); + Write_Operator (Node, "/ "); + Sprint_Right_Opnd (Node); + + when N_Op_Eq => + Sprint_Left_Opnd (Node); + Write_Operator (Node, " = "); + Sprint_Right_Opnd (Node); + + when N_Op_Expon => + Sprint_Left_Opnd (Node); + Write_Operator (Node, " ** "); + Sprint_Right_Opnd (Node); + + when N_Op_Ge => + Sprint_Left_Opnd (Node); + Write_Operator (Node, " >= "); + Sprint_Right_Opnd (Node); + + when N_Op_Gt => + Sprint_Left_Opnd (Node); + Write_Operator (Node, " > "); + Sprint_Right_Opnd (Node); + + when N_Op_Le => + Sprint_Left_Opnd (Node); + Write_Operator (Node, " <= "); + Sprint_Right_Opnd (Node); + + when N_Op_Lt => + Sprint_Left_Opnd (Node); + Write_Operator (Node, " < "); + Sprint_Right_Opnd (Node); + + when N_Op_Minus => + Write_Operator (Node, "-"); + Sprint_Right_Opnd (Node); + + when N_Op_Mod => + Sprint_Left_Opnd (Node); + + if Treat_Fixed_As_Integer (Node) then + Write_Str (" #"); + end if; + + Write_Operator (Node, " mod "); + Sprint_Right_Opnd (Node); + + when N_Op_Multiply => + Sprint_Left_Opnd (Node); + Write_Char (' '); + Process_TFAI_RR_Flags (Node); + Write_Operator (Node, "* "); + Sprint_Right_Opnd (Node); + + when N_Op_Ne => + Sprint_Left_Opnd (Node); + Write_Operator (Node, " /= "); + Sprint_Right_Opnd (Node); + + when N_Op_Not => + Write_Operator (Node, "not "); + Sprint_Right_Opnd (Node); + + when N_Op_Or => + Sprint_Left_Opnd (Node); + Write_Operator (Node, " or "); + Sprint_Right_Opnd (Node); + + when N_Op_Plus => + Write_Operator (Node, "+"); + Sprint_Right_Opnd (Node); + + when N_Op_Rem => + Sprint_Left_Opnd (Node); + + if Treat_Fixed_As_Integer (Node) then + Write_Str (" #"); + end if; + + Write_Operator (Node, " rem "); + Sprint_Right_Opnd (Node); + + when N_Op_Shift => + Set_Debug_Sloc; + Write_Id (Node); + Write_Char ('!'); + Write_Str_With_Col_Check ("("); + Sprint_Node (Left_Opnd (Node)); + Write_Str (", "); + Sprint_Node (Right_Opnd (Node)); + Write_Char (')'); + + when N_Op_Subtract => + Sprint_Left_Opnd (Node); + Write_Operator (Node, " - "); + Sprint_Right_Opnd (Node); + + when N_Op_Xor => + Sprint_Left_Opnd (Node); + Write_Operator (Node, " xor "); + Sprint_Right_Opnd (Node); + + when N_Operator_Symbol => + Write_Name_With_Col_Check_Sloc (Chars (Node)); + + when N_Ordinary_Fixed_Point_Definition => + Write_Str_With_Col_Check_Sloc ("delta "); + Sprint_Node (Delta_Expression (Node)); + Sprint_Opt_Node (Real_Range_Specification (Node)); + + when N_Or_Else => + Sprint_Left_Opnd (Node); + Write_Str_Sloc (" or else "); + Sprint_Right_Opnd (Node); + + when N_Others_Choice => + if All_Others (Node) then + Write_Str_With_Col_Check ("all "); + end if; + + Write_Str_With_Col_Check_Sloc ("others"); + + when N_Package_Body => + Extra_Blank_Line; + Write_Indent_Str_Sloc ("package body "); + Sprint_Node (Defining_Unit_Name (Node)); + Write_Str (" is"); + Sprint_Indented_List (Declarations (Node)); + + if Present (Handled_Statement_Sequence (Node)) then + Write_Indent_Str ("begin"); + Sprint_Node (Handled_Statement_Sequence (Node)); + end if; + + Write_Indent_Str ("end "); + Sprint_End_Label + (Handled_Statement_Sequence (Node), Defining_Unit_Name (Node)); + Write_Char (';'); + + when N_Package_Body_Stub => + Write_Indent_Str_Sloc ("package body "); + Sprint_Node (Defining_Identifier (Node)); + Write_Str_With_Col_Check (" is separate;"); + + when N_Package_Declaration => + Extra_Blank_Line; + Write_Indent; + Sprint_Node_Sloc (Specification (Node)); + Write_Char (';'); + + when N_Package_Instantiation => + Extra_Blank_Line; + Write_Indent_Str_Sloc ("package "); + Sprint_Node (Defining_Unit_Name (Node)); + Write_Str (" is new "); + Sprint_Node (Name (Node)); + Sprint_Opt_Paren_Comma_List (Generic_Associations (Node)); + Write_Char (';'); + + when N_Package_Renaming_Declaration => + Write_Indent_Str_Sloc ("package "); + Sprint_Node (Defining_Unit_Name (Node)); + Write_Str_With_Col_Check (" renames "); + Sprint_Node (Name (Node)); + Write_Char (';'); + + when N_Package_Specification => + Write_Str_With_Col_Check_Sloc ("package "); + Sprint_Node (Defining_Unit_Name (Node)); + Write_Str (" is"); + Sprint_Indented_List (Visible_Declarations (Node)); + + if Present (Private_Declarations (Node)) then + Write_Indent_Str ("private"); + Sprint_Indented_List (Private_Declarations (Node)); + end if; + + Write_Indent_Str ("end "); + Sprint_Node (Defining_Unit_Name (Node)); + + when N_Parameter_Association => + Sprint_Node_Sloc (Selector_Name (Node)); + Write_Str (" => "); + Sprint_Node (Explicit_Actual_Parameter (Node)); + + when N_Parameter_Specification => + Set_Debug_Sloc; + + if Write_Identifiers (Node) then + Write_Str (" : "); + + if In_Present (Node) then + Write_Str_With_Col_Check ("in "); + end if; + + if Out_Present (Node) then + Write_Str_With_Col_Check ("out "); + end if; + + -- Ada 2005 (AI-231): Parameter specification may carry null + -- exclusion. Do not print it now if this is an access formal, + -- it is emitted when the access definition is displayed. + + if Null_Exclusion_Present (Node) + and then Nkind (Parameter_Type (Node)) + /= N_Access_Definition + then + Write_Str ("not null "); + end if; + + Sprint_Node (Parameter_Type (Node)); + + if Present (Expression (Node)) then + Write_Str (" := "); + Sprint_Node (Expression (Node)); + end if; + else + Write_Str (", "); + end if; + + when N_Parameterized_Expression => + Write_Indent; + Sprint_Node_Sloc (Specification (Node)); + + Write_Str (" is"); + Indent_Begin; + Write_Indent; + Sprint_Node (Expression (Node)); + Write_Char (';'); + Indent_End; + + when N_Pop_Constraint_Error_Label => + Write_Indent_Str ("%pop_constraint_error_label"); + + when N_Pop_Program_Error_Label => + Write_Indent_Str ("%pop_program_error_label"); + + when N_Pop_Storage_Error_Label => + Write_Indent_Str ("%pop_storage_error_label"); + + when N_Private_Extension_Declaration => + Write_Indent_Str_Sloc ("type "); + Write_Id (Defining_Identifier (Node)); + + if Present (Discriminant_Specifications (Node)) then + Write_Discr_Specs (Node); + elsif Unknown_Discriminants_Present (Node) then + Write_Str_With_Col_Check ("(<>)"); + end if; + + Write_Str_With_Col_Check (" is new "); + Sprint_Node (Subtype_Indication (Node)); + + if Present (Interface_List (Node)) then + Write_Str_With_Col_Check (" and "); + Sprint_And_List (Interface_List (Node)); + end if; + + Write_Str_With_Col_Check (" with private;"); + + when N_Private_Type_Declaration => + Write_Indent_Str_Sloc ("type "); + Write_Id (Defining_Identifier (Node)); + + if Present (Discriminant_Specifications (Node)) then + Write_Discr_Specs (Node); + elsif Unknown_Discriminants_Present (Node) then + Write_Str_With_Col_Check ("(<>)"); + end if; + + Write_Str (" is "); + + if Tagged_Present (Node) then + Write_Str_With_Col_Check ("tagged "); + end if; + + if Limited_Present (Node) then + Write_Str_With_Col_Check ("limited "); + end if; + + Write_Str_With_Col_Check ("private;"); + + when N_Push_Constraint_Error_Label => + Write_Indent_Str ("%push_constraint_error_label ("); + + if Present (Exception_Label (Node)) then + Write_Name_With_Col_Check (Chars (Exception_Label (Node))); + end if; + + Write_Str (")"); + + when N_Push_Program_Error_Label => + Write_Indent_Str ("%push_program_error_label ("); + + if Present (Exception_Label (Node)) then + Write_Name_With_Col_Check (Chars (Exception_Label (Node))); + end if; + + Write_Str (")"); + + when N_Push_Storage_Error_Label => + Write_Indent_Str ("%push_storage_error_label ("); + + if Present (Exception_Label (Node)) then + Write_Name_With_Col_Check (Chars (Exception_Label (Node))); + end if; + + Write_Str (")"); + + when N_Pragma => + Write_Indent_Str_Sloc ("pragma "); + Write_Name_With_Col_Check (Pragma_Name (Node)); + + if Present (Pragma_Argument_Associations (Node)) then + Sprint_Opt_Paren_Comma_List + (Pragma_Argument_Associations (Node)); + end if; + + Write_Char (';'); + + when N_Pragma_Argument_Association => + Set_Debug_Sloc; + + if Chars (Node) /= No_Name then + Write_Name_With_Col_Check (Chars (Node)); + Write_Str (" => "); + end if; + + Sprint_Node (Expression (Node)); + + when N_Procedure_Call_Statement => + Write_Indent; + Set_Debug_Sloc; + Write_Subprogram_Name (Name (Node)); + Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node)); + Write_Char (';'); + + when N_Procedure_Instantiation => + Write_Indent_Str_Sloc ("procedure "); + Sprint_Node (Defining_Unit_Name (Node)); + Write_Str_With_Col_Check (" is new "); + Sprint_Node (Name (Node)); + Sprint_Opt_Paren_Comma_List (Generic_Associations (Node)); + Write_Char (';'); + + when N_Procedure_Specification => + Write_Str_With_Col_Check_Sloc ("procedure "); + Sprint_Node (Defining_Unit_Name (Node)); + Write_Param_Specs (Node); + + when N_Protected_Body => + Write_Indent_Str_Sloc ("protected body "); + Write_Id (Defining_Identifier (Node)); + Write_Str (" is"); + Sprint_Indented_List (Declarations (Node)); + Write_Indent_Str ("end "); + Write_Id (Defining_Identifier (Node)); + Write_Char (';'); + + when N_Protected_Body_Stub => + Write_Indent_Str_Sloc ("protected body "); + Write_Id (Defining_Identifier (Node)); + Write_Str_With_Col_Check (" is separate;"); + + when N_Protected_Definition => + Set_Debug_Sloc; + Sprint_Indented_List (Visible_Declarations (Node)); + + if Present (Private_Declarations (Node)) then + Write_Indent_Str ("private"); + Sprint_Indented_List (Private_Declarations (Node)); + end if; + + Write_Indent_Str ("end "); + + when N_Protected_Type_Declaration => + Write_Indent_Str_Sloc ("protected type "); + Sprint_Node (Defining_Identifier (Node)); + Write_Discr_Specs (Node); + + if Present (Interface_List (Node)) then + Write_Str (" is new "); + Sprint_And_List (Interface_List (Node)); + Write_Str (" with "); + else + Write_Str (" is"); + end if; + + Sprint_Node (Protected_Definition (Node)); + Write_Id (Defining_Identifier (Node)); + Write_Char (';'); + + when N_Qualified_Expression => + Sprint_Node (Subtype_Mark (Node)); + Write_Char_Sloc ('''); + + -- Print expression, make sure we have at least one level of + -- parentheses around the expression. For cases of qualified + -- expressions in the source, this is always the case, but + -- for generated qualifications, there may be no explicit + -- parentheses present. + + if Paren_Count (Expression (Node)) /= 0 then + Sprint_Node (Expression (Node)); + else + Write_Char ('('); + Sprint_Node (Expression (Node)); + Write_Char (')'); + end if; + + when N_Quantified_Expression => + Write_Str (" for"); + + if All_Present (Node) then + Write_Str (" all "); + else + Write_Str (" some "); + end if; + + Sprint_Node (Loop_Parameter_Specification (Node)); + Write_Str (" => "); + Sprint_Node (Condition (Node)); + + when N_Raise_Constraint_Error => + + -- This node can be used either as a subexpression or as a + -- statement form. The following test is a reasonably reliable + -- way to distinguish the two cases. + + if Is_List_Member (Node) + and then Nkind (Parent (Node)) not in N_Subexpr + then + Write_Indent; + end if; + + Write_Str_With_Col_Check_Sloc ("[constraint_error"); + Write_Condition_And_Reason (Node); + + when N_Raise_Program_Error => + + -- This node can be used either as a subexpression or as a + -- statement form. The following test is a reasonably reliable + -- way to distinguish the two cases. + + if Is_List_Member (Node) + and then Nkind (Parent (Node)) not in N_Subexpr + then + Write_Indent; + end if; + + Write_Str_With_Col_Check_Sloc ("[program_error"); + Write_Condition_And_Reason (Node); + + when N_Raise_Storage_Error => + + -- This node can be used either as a subexpression or as a + -- statement form. The following test is a reasonably reliable + -- way to distinguish the two cases. + + if Is_List_Member (Node) + and then Nkind (Parent (Node)) not in N_Subexpr + then + Write_Indent; + end if; + + Write_Str_With_Col_Check_Sloc ("[storage_error"); + Write_Condition_And_Reason (Node); + + when N_Raise_Statement => + Write_Indent_Str_Sloc ("raise "); + Sprint_Node (Name (Node)); + Write_Char (';'); + + when N_Range => + Sprint_Node (Low_Bound (Node)); + Write_Str_Sloc (" .. "); + Sprint_Node (High_Bound (Node)); + Update_Itype (Node); + + when N_Range_Constraint => + Write_Str_With_Col_Check_Sloc ("range "); + Sprint_Node (Range_Expression (Node)); + + when N_Real_Literal => + Write_Ureal_With_Col_Check_Sloc (Realval (Node)); + + when N_Real_Range_Specification => + Write_Str_With_Col_Check_Sloc ("range "); + Sprint_Node (Low_Bound (Node)); + Write_Str (" .. "); + Sprint_Node (High_Bound (Node)); + + when N_Record_Definition => + if Abstract_Present (Node) then + Write_Str_With_Col_Check ("abstract "); + end if; + + if Tagged_Present (Node) then + Write_Str_With_Col_Check ("tagged "); + end if; + + if Limited_Present (Node) then + Write_Str_With_Col_Check ("limited "); + end if; + + if Null_Present (Node) then + Write_Str_With_Col_Check_Sloc ("null record"); + + else + Write_Str_With_Col_Check_Sloc ("record"); + Sprint_Node (Component_List (Node)); + Write_Indent_Str ("end record"); + end if; + + when N_Record_Representation_Clause => + Write_Indent_Str_Sloc ("for "); + Sprint_Node (Identifier (Node)); + Write_Str_With_Col_Check (" use record "); + + if Present (Mod_Clause (Node)) then + Sprint_Node (Mod_Clause (Node)); + end if; + + Sprint_Indented_List (Component_Clauses (Node)); + Write_Indent_Str ("end record;"); + + when N_Reference => + Sprint_Node (Prefix (Node)); + Write_Str_With_Col_Check_Sloc ("'reference"); + + when N_Requeue_Statement => + Write_Indent_Str_Sloc ("requeue "); + Sprint_Node (Name (Node)); + + if Abort_Present (Node) then + Write_Str_With_Col_Check (" with abort"); + end if; + + Write_Char (';'); + + -- Don't we want to print more detail??? + + -- Doc of this extended syntax belongs in sinfo.ads and/or + -- sprint.ads ??? + + when N_SCIL_Dispatch_Table_Tag_Init => + Write_Indent_Str ("[N_SCIL_Dispatch_Table_Tag_Init]"); + + when N_SCIL_Dispatching_Call => + Write_Indent_Str ("[N_SCIL_Dispatching_Node]"); + + when N_SCIL_Membership_Test => + Write_Indent_Str ("[N_SCIL_Membership_Test]"); + + when N_Simple_Return_Statement => + if Present (Expression (Node)) then + Write_Indent_Str_Sloc ("return "); + Sprint_Node (Expression (Node)); + Write_Char (';'); + else + Write_Indent_Str_Sloc ("return;"); + end if; + + when N_Selective_Accept => + Write_Indent_Str_Sloc ("select"); + + declare + Alt_Node : Node_Id; + begin + Alt_Node := First (Select_Alternatives (Node)); + loop + Indent_Begin; + Sprint_Node (Alt_Node); + Indent_End; + Next (Alt_Node); + exit when No (Alt_Node); + Write_Indent_Str ("or"); + end loop; + end; + + if Present (Else_Statements (Node)) then + Write_Indent_Str ("else"); + Sprint_Indented_List (Else_Statements (Node)); + end if; + + Write_Indent_Str ("end select;"); + + when N_Signed_Integer_Type_Definition => + Write_Str_With_Col_Check_Sloc ("range "); + Sprint_Node (Low_Bound (Node)); + Write_Str (" .. "); + Sprint_Node (High_Bound (Node)); + + when N_Single_Protected_Declaration => + Write_Indent_Str_Sloc ("protected "); + Write_Id (Defining_Identifier (Node)); + Write_Str (" is"); + Sprint_Node (Protected_Definition (Node)); + Write_Id (Defining_Identifier (Node)); + Write_Char (';'); + + when N_Single_Task_Declaration => + Write_Indent_Str_Sloc ("task "); + Sprint_Node (Defining_Identifier (Node)); + + if Present (Task_Definition (Node)) then + Write_Str (" is"); + Sprint_Node (Task_Definition (Node)); + end if; + + Write_Char (';'); + + when N_Selected_Component => + Sprint_Node (Prefix (Node)); + Write_Char_Sloc ('.'); + Sprint_Node (Selector_Name (Node)); + + when N_Slice => + Set_Debug_Sloc; + Sprint_Node (Prefix (Node)); + Write_Str_With_Col_Check (" ("); + Sprint_Node (Discrete_Range (Node)); + Write_Char (')'); + + when N_String_Literal => + if String_Length (Strval (Node)) + Column > Sprint_Line_Limit then + Write_Indent_Str (" "); + end if; + + Set_Debug_Sloc; + Write_String_Table_Entry (Strval (Node)); + + when N_Subprogram_Body => + + -- Output extra blank line unless we are in freeze actions + + if Freeze_Indent = 0 then + Extra_Blank_Line; + end if; + + Write_Indent; + + if Present (Corresponding_Spec (Node)) then + Sprint_Node_Sloc (Parent (Corresponding_Spec (Node))); + else + Sprint_Node_Sloc (Specification (Node)); + end if; + + Write_Str (" is"); + + Sprint_Indented_List (Declarations (Node)); + Write_Indent_Str ("begin"); + Sprint_Node (Handled_Statement_Sequence (Node)); + + Write_Indent_Str ("end "); + + Sprint_End_Label + (Handled_Statement_Sequence (Node), + Defining_Unit_Name (Specification (Node))); + Write_Char (';'); + + if Is_List_Member (Node) + and then Present (Next (Node)) + and then Nkind (Next (Node)) /= N_Subprogram_Body + then + Write_Indent; + end if; + + when N_Subprogram_Body_Stub => + Write_Indent; + Sprint_Node_Sloc (Specification (Node)); + Write_Str_With_Col_Check (" is separate;"); + + when N_Subprogram_Declaration => + Write_Indent; + Sprint_Node_Sloc (Specification (Node)); + + if Nkind (Specification (Node)) = N_Procedure_Specification + and then Null_Present (Specification (Node)) + then + Write_Str_With_Col_Check (" is null"); + end if; + + Write_Char (';'); + + when N_Subprogram_Info => + Sprint_Node (Identifier (Node)); + Write_Str_With_Col_Check_Sloc ("'subprogram_info"); + + when N_Subprogram_Renaming_Declaration => + Write_Indent; + Sprint_Node (Specification (Node)); + Write_Str_With_Col_Check_Sloc (" renames "); + Sprint_Node (Name (Node)); + Write_Char (';'); + + when N_Subtype_Declaration => + Write_Indent_Str_Sloc ("subtype "); + Sprint_Node (Defining_Identifier (Node)); + Write_Str (" is "); + + -- Ada 2005 (AI-231) + + if Null_Exclusion_Present (Node) then + Write_Str ("not null "); + end if; + + Sprint_Node (Subtype_Indication (Node)); + Write_Char (';'); + + when N_Subtype_Indication => + Sprint_Node_Sloc (Subtype_Mark (Node)); + Write_Char (' '); + Sprint_Node (Constraint (Node)); + + when N_Subunit => + Write_Indent_Str_Sloc ("separate ("); + Sprint_Node (Name (Node)); + Write_Char (')'); + Extra_Blank_Line; + Sprint_Node (Proper_Body (Node)); + + when N_Task_Body => + Write_Indent_Str_Sloc ("task body "); + Write_Id (Defining_Identifier (Node)); + Write_Str (" is"); + Sprint_Indented_List (Declarations (Node)); + Write_Indent_Str ("begin"); + Sprint_Node (Handled_Statement_Sequence (Node)); + Write_Indent_Str ("end "); + Sprint_End_Label + (Handled_Statement_Sequence (Node), Defining_Identifier (Node)); + Write_Char (';'); + + when N_Task_Body_Stub => + Write_Indent_Str_Sloc ("task body "); + Write_Id (Defining_Identifier (Node)); + Write_Str_With_Col_Check (" is separate;"); + + when N_Task_Definition => + Set_Debug_Sloc; + Sprint_Indented_List (Visible_Declarations (Node)); + + if Present (Private_Declarations (Node)) then + Write_Indent_Str ("private"); + Sprint_Indented_List (Private_Declarations (Node)); + end if; + + Write_Indent_Str ("end "); + Sprint_End_Label (Node, Defining_Identifier (Parent (Node))); + + when N_Task_Type_Declaration => + Write_Indent_Str_Sloc ("task type "); + Sprint_Node (Defining_Identifier (Node)); + Write_Discr_Specs (Node); + + if Present (Interface_List (Node)) then + Write_Str (" is new "); + Sprint_And_List (Interface_List (Node)); + end if; + + if Present (Task_Definition (Node)) then + if No (Interface_List (Node)) then + Write_Str (" is"); + else + Write_Str (" with "); + end if; + + Sprint_Node (Task_Definition (Node)); + end if; + + Write_Char (';'); + + when N_Terminate_Alternative => + Sprint_Node_List (Pragmas_Before (Node)); + Write_Indent; + + if Present (Condition (Node)) then + Write_Str_With_Col_Check ("when "); + Sprint_Node (Condition (Node)); + Write_Str (" => "); + end if; + + Write_Str_With_Col_Check_Sloc ("terminate;"); + Sprint_Node_List (Pragmas_After (Node)); + + when N_Timed_Entry_Call => + Write_Indent_Str_Sloc ("select"); + Indent_Begin; + Sprint_Node (Entry_Call_Alternative (Node)); + Indent_End; + Write_Indent_Str ("or"); + Indent_Begin; + Sprint_Node (Delay_Alternative (Node)); + Indent_End; + Write_Indent_Str ("end select;"); + + when N_Triggering_Alternative => + Sprint_Node_List (Pragmas_Before (Node)); + Sprint_Node_Sloc (Triggering_Statement (Node)); + Sprint_Node_List (Statements (Node)); + + when N_Type_Conversion => + Set_Debug_Sloc; + Sprint_Node (Subtype_Mark (Node)); + Col_Check (4); + + if Conversion_OK (Node) then + Write_Char ('?'); + end if; + + if Float_Truncate (Node) then + Write_Char ('^'); + end if; + + if Rounded_Result (Node) then + Write_Char ('@'); + end if; + + Write_Char ('('); + Sprint_Node (Expression (Node)); + Write_Char (')'); + + when N_Unchecked_Expression => + Col_Check (10); + Write_Str ("`("); + Sprint_Node_Sloc (Expression (Node)); + Write_Char (')'); + + when N_Unchecked_Type_Conversion => + Sprint_Node (Subtype_Mark (Node)); + Write_Char ('!'); + Write_Str_With_Col_Check ("("); + Sprint_Node_Sloc (Expression (Node)); + Write_Char (')'); + + when N_Unconstrained_Array_Definition => + Write_Str_With_Col_Check_Sloc ("array ("); + + declare + Node1 : Node_Id; + begin + Node1 := First (Subtype_Marks (Node)); + loop + Sprint_Node (Node1); + Write_Str_With_Col_Check (" range <>"); + Next (Node1); + exit when Node1 = Empty; + Write_Str (", "); + end loop; + end; + + Write_Str (") of "); + Sprint_Node (Component_Definition (Node)); + + when N_Unused_At_Start | N_Unused_At_End => + Write_Indent_Str ("***** Error, unused node encountered *****"); + Write_Eol; + + when N_Use_Package_Clause => + Write_Indent_Str_Sloc ("use "); + Sprint_Comma_List (Names (Node)); + Write_Char (';'); + + when N_Use_Type_Clause => + Write_Indent_Str_Sloc ("use type "); + Sprint_Comma_List (Subtype_Marks (Node)); + Write_Char (';'); + + when N_Validate_Unchecked_Conversion => + Write_Indent_Str_Sloc ("validate unchecked_conversion ("); + Sprint_Node (Source_Type (Node)); + Write_Str (", "); + Sprint_Node (Target_Type (Node)); + Write_Str (");"); + + when N_Variant => + Write_Indent_Str_Sloc ("when "); + Sprint_Bar_List (Discrete_Choices (Node)); + Write_Str (" => "); + Sprint_Node (Component_List (Node)); + + when N_Variant_Part => + Indent_Begin; + Write_Indent_Str_Sloc ("case "); + Sprint_Node (Name (Node)); + Write_Str (" is "); + Sprint_Indented_List (Variants (Node)); + Write_Indent_Str ("end case"); + Indent_End; + + when N_With_Clause => + + -- Special test, if we are dumping the original tree only, + -- then we want to eliminate the bogus with clauses that + -- correspond to the non-existent children of Text_IO. + + if Dump_Original_Only + and then Is_Text_IO_Kludge_Unit (Name (Node)) + then + null; + + -- Normal case, output the with clause + + else + if First_Name (Node) or else not Dump_Original_Only then + + -- Ada 2005 (AI-50217): Print limited with_clauses + + if Private_Present (Node) and Limited_Present (Node) then + Write_Indent_Str ("limited private with "); + + elsif Private_Present (Node) then + Write_Indent_Str ("private with "); + + elsif Limited_Present (Node) then + Write_Indent_Str ("limited with "); + + else + Write_Indent_Str ("with "); + end if; + + else + Write_Str (", "); + end if; + + Sprint_Node_Sloc (Name (Node)); + + if Last_Name (Node) or else not Dump_Original_Only then + Write_Char (';'); + end if; + end if; + end case; + + if Has_Aspects (Node) then + Sprint_Aspect_Specifications (Node); + end if; + + if Nkind (Node) in N_Subexpr + and then Do_Range_Check (Node) + then + Write_Str ("}"); + end if; + + for J in 1 .. Paren_Count (Node) loop + Write_Char (')'); + end loop; + + Dump_Node := Save_Dump_Node; + end Sprint_Node_Actual; + + ---------------------- + -- Sprint_Node_List -- + ---------------------- + + procedure Sprint_Node_List (List : List_Id) is + Node : Node_Id; + + begin + if Is_Non_Empty_List (List) then + Node := First (List); + + loop + Sprint_Node (Node); + Next (Node); + exit when Node = Empty; + end loop; + end if; + end Sprint_Node_List; + + ---------------------- + -- Sprint_Node_Sloc -- + ---------------------- + + procedure Sprint_Node_Sloc (Node : Node_Id) is + begin + Sprint_Node (Node); + + if Debug_Generated_Code and then Present (Dump_Node) then + Set_Sloc (Dump_Node, Sloc (Node)); + Dump_Node := Empty; + end if; + end Sprint_Node_Sloc; + + --------------------- + -- Sprint_Opt_Node -- + --------------------- + + procedure Sprint_Opt_Node (Node : Node_Id) is + begin + if Present (Node) then + Write_Char (' '); + Sprint_Node (Node); + end if; + end Sprint_Opt_Node; + + -------------------------- + -- Sprint_Opt_Node_List -- + -------------------------- + + procedure Sprint_Opt_Node_List (List : List_Id) is + begin + if Present (List) then + Sprint_Node_List (List); + end if; + end Sprint_Opt_Node_List; + + --------------------------------- + -- Sprint_Opt_Paren_Comma_List -- + --------------------------------- + + procedure Sprint_Opt_Paren_Comma_List (List : List_Id) is + begin + if Is_Non_Empty_List (List) then + Write_Char (' '); + Sprint_Paren_Comma_List (List); + end if; + end Sprint_Opt_Paren_Comma_List; + + ----------------------------- + -- Sprint_Paren_Comma_List -- + ----------------------------- + + procedure Sprint_Paren_Comma_List (List : List_Id) is + N : Node_Id; + Node_Exists : Boolean := False; + + begin + + if Is_Non_Empty_List (List) then + + if Dump_Original_Only then + N := First (List); + while Present (N) loop + if not Is_Rewrite_Insertion (N) then + Node_Exists := True; + exit; + end if; + + Next (N); + end loop; + + if not Node_Exists then + return; + end if; + end if; + + Write_Str_With_Col_Check ("("); + Sprint_Comma_List (List); + Write_Char (')'); + end if; + end Sprint_Paren_Comma_List; + + ---------------------- + -- Sprint_Right_Opnd -- + ---------------------- + + procedure Sprint_Right_Opnd (N : Node_Id) is + Opnd : constant Node_Id := Right_Opnd (N); + + begin + if Paren_Count (Opnd) /= 0 + or else Op_Prec (Nkind (Opnd)) > Op_Prec (Nkind (N)) + then + Sprint_Node (Opnd); + + else + Write_Char ('('); + Sprint_Node (Opnd); + Write_Char (')'); + end if; + end Sprint_Right_Opnd; + + ------------------ + -- Update_Itype -- + ------------------ + + procedure Update_Itype (Node : Node_Id) is + begin + if Present (Etype (Node)) + and then Is_Itype (Etype (Node)) + and then Debug_Generated_Code + then + Set_Sloc (Etype (Node), Sloc (Node)); + end if; + end Update_Itype; + + --------------------- + -- Write_Char_Sloc -- + --------------------- + + procedure Write_Char_Sloc (C : Character) is + begin + if Debug_Generated_Code and then C /= ' ' then + Set_Debug_Sloc; + end if; + + Write_Char (C); + end Write_Char_Sloc; + + -------------------------------- + -- Write_Condition_And_Reason -- + -------------------------------- + + procedure Write_Condition_And_Reason (Node : Node_Id) is + Cond : constant Node_Id := Condition (Node); + Image : constant String := RT_Exception_Code'Image + (RT_Exception_Code'Val + (UI_To_Int (Reason (Node)))); + + begin + if Present (Cond) then + + -- If condition is a single entity, or NOT with a single entity, + -- output all on one line, since it will likely fit just fine. + + if Is_Entity_Name (Cond) + or else (Nkind (Cond) = N_Op_Not + and then Is_Entity_Name (Right_Opnd (Cond))) + then + Write_Str_With_Col_Check (" when "); + Sprint_Node (Cond); + Write_Char (' '); + + -- Otherwise for more complex condition, multiple lines + + else + Write_Str_With_Col_Check (" when"); + Indent := Indent + 2; + Write_Indent; + Sprint_Node (Cond); + Write_Indent; + Indent := Indent - 2; + end if; + + -- If no condition, just need a space (all on one line) + + else + Write_Char (' '); + end if; + + -- Write the reason + + Write_Char ('"'); + + for J in 4 .. Image'Last loop + if Image (J) = '_' then + Write_Char (' '); + else + Write_Char (Fold_Lower (Image (J))); + end if; + end loop; + + Write_Str ("""]"); + end Write_Condition_And_Reason; + + -------------------------------- + -- Write_Corresponding_Source -- + -------------------------------- + + procedure Write_Corresponding_Source (S : String) is + Loc : Source_Ptr; + Src : Source_Buffer_Ptr; + + begin + -- Ignore if not in dump source text mode, or if in freeze actions + + if Dump_Source_Text and then Freeze_Indent = 0 then + + -- Ignore null string + + if S = "" then + return; + end if; + + -- Ignore space or semicolon at end of given string + + if S (S'Last) = ' ' or else S (S'Last) = ';' then + Write_Corresponding_Source (S (S'First .. S'Last - 1)); + return; + end if; + + -- Loop to look at next lines not yet printed in source file + + for L in + Last_Line_Printed + 1 .. Last_Source_Line (Current_Source_File) + loop + Src := Source_Text (Current_Source_File); + Loc := Line_Start (L, Current_Source_File); + + -- If comment, keep looking + + if Src (Loc .. Loc + 1) = "--" then + null; + + -- Search to first non-blank + + else + while Src (Loc) not in Line_Terminator loop + + -- Non-blank found + + if Src (Loc) /= ' ' and then Src (Loc) /= ASCII.HT then + + -- Loop through characters in string to see if we match + + for J in S'Range loop + + -- If mismatch, then not the case we are looking for + + if Src (Loc) /= S (J) then + return; + end if; + + Loc := Loc + 1; + end loop; + + -- If we fall through, string matched, if white space or + -- semicolon after the matched string, this is the case + -- we are looking for. + + if Src (Loc) in Line_Terminator + or else Src (Loc) = ' ' + or else Src (Loc) = ASCII.HT + or else Src (Loc) = ';' + then + -- So output source lines up to and including this one + + Write_Source_Lines (L); + return; + end if; + end if; + + Loc := Loc + 1; + end loop; + end if; + + -- Line was all blanks, or a comment line, keep looking + + end loop; + end if; + end Write_Corresponding_Source; + + ----------------------- + -- Write_Discr_Specs -- + ----------------------- + + procedure Write_Discr_Specs (N : Node_Id) is + Specs : List_Id; + Spec : Node_Id; + + begin + Specs := Discriminant_Specifications (N); + + if Present (Specs) then + Write_Str_With_Col_Check (" ("); + Spec := First (Specs); + + loop + Sprint_Node (Spec); + Next (Spec); + exit when Spec = Empty; + + -- Add semicolon, unless we are printing original tree and the + -- next specification is part of a list (but not the first + -- element of that list) + + if not Dump_Original_Only or else not Prev_Ids (Spec) then + Write_Str ("; "); + end if; + end loop; + + Write_Char (')'); + end if; + end Write_Discr_Specs; + + ----------------- + -- Write_Ekind -- + ----------------- + + procedure Write_Ekind (E : Entity_Id) is + S : constant String := Entity_Kind'Image (Ekind (E)); + + begin + Name_Len := S'Length; + Name_Buffer (1 .. Name_Len) := S; + Set_Casing (Mixed_Case); + Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len)); + end Write_Ekind; + + -------------- + -- Write_Id -- + -------------- + + procedure Write_Id (N : Node_Id) is + begin + -- Deal with outputting Itype + + -- Note: if we are printing the full tree with -gnatds, then we may + -- end up picking up the Associated_Node link from a generic template + -- here which overlaps the Entity field, but as documented, Write_Itype + -- is defended against junk calls. + + if Nkind (N) in N_Entity then + Write_Itype (N); + elsif Nkind (N) in N_Has_Entity then + Write_Itype (Entity (N)); + end if; + + -- Case of a defining identifier + + if Nkind (N) = N_Defining_Identifier then + + -- If defining identifier has an interface name (and no + -- address clause), then we output the interface name. + + if (Is_Imported (N) or else Is_Exported (N)) + and then Present (Interface_Name (N)) + and then No (Address_Clause (N)) + then + String_To_Name_Buffer (Strval (Interface_Name (N))); + Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len)); + + -- If no interface name (or inactive because there was + -- an address clause), then just output the Chars name. + + else + Write_Name_With_Col_Check (Chars (N)); + end if; + + -- Case of selector of an expanded name where the expanded name + -- has an associated entity, output this entity. Check that the + -- entity or associated node is of the right kind, see above. + + elsif Nkind (Parent (N)) = N_Expanded_Name + and then Selector_Name (Parent (N)) = N + and then Present (Entity_Or_Associated_Node (Parent (N))) + and then Nkind (Entity (Parent (N))) in N_Entity + then + Write_Id (Entity (Parent (N))); + + -- For any other node with an associated entity, output it + + elsif Nkind (N) in N_Has_Entity + and then Present (Entity_Or_Associated_Node (N)) + and then Nkind (Entity_Or_Associated_Node (N)) in N_Entity + then + Write_Id (Entity (N)); + + -- All other cases, we just print the Chars field + + else + Write_Name_With_Col_Check (Chars (N)); + end if; + end Write_Id; + + ----------------------- + -- Write_Identifiers -- + ----------------------- + + function Write_Identifiers (Node : Node_Id) return Boolean is + begin + Sprint_Node (Defining_Identifier (Node)); + Update_Itype (Defining_Identifier (Node)); + + -- The remainder of the declaration must be printed unless we are + -- printing the original tree and this is not the last identifier + + return + not Dump_Original_Only or else not More_Ids (Node); + + end Write_Identifiers; + + ------------------------ + -- Write_Implicit_Def -- + ------------------------ + + procedure Write_Implicit_Def (E : Entity_Id) is + Ind : Node_Id; + + begin + case Ekind (E) is + when E_Array_Subtype => + Write_Str_With_Col_Check ("subtype "); + Write_Id (E); + Write_Str_With_Col_Check (" is "); + Write_Id (Base_Type (E)); + Write_Str_With_Col_Check (" ("); + + Ind := First_Index (E); + while Present (Ind) loop + Sprint_Node (Ind); + Next_Index (Ind); + + if Present (Ind) then + Write_Str (", "); + end if; + end loop; + + Write_Str (");"); + + when E_Signed_Integer_Subtype | E_Enumeration_Subtype => + Write_Str_With_Col_Check ("subtype "); + Write_Id (E); + Write_Str (" is "); + Write_Id (Etype (E)); + Write_Str_With_Col_Check (" range "); + Sprint_Node (Scalar_Range (E)); + Write_Str (";"); + + when others => + Write_Str_With_Col_Check ("type "); + Write_Id (E); + Write_Str_With_Col_Check (" is <"); + Write_Ekind (E); + Write_Str (">;"); + end case; + + end Write_Implicit_Def; + + ------------------ + -- Write_Indent -- + ------------------ + + procedure Write_Indent is + Loc : constant Source_Ptr := Sloc (Dump_Node); + + begin + if Indent_Annull_Flag then + Indent_Annull_Flag := False; + else + -- Deal with Dump_Source_Text output. Note that we ignore implicit + -- label declarations, since they typically have the sloc of the + -- corresponding label, which really messes up the -gnatL output. + + if Dump_Source_Text + and then Loc > No_Location + and then Nkind (Dump_Node) /= N_Implicit_Label_Declaration + then + if Get_Source_File_Index (Loc) = Current_Source_File then + Write_Source_Lines + (Get_Physical_Line_Number (Sloc (Dump_Node))); + end if; + end if; + + Write_Eol; + + for J in 1 .. Indent loop + Write_Char (' '); + end loop; + end if; + end Write_Indent; + + ------------------------------ + -- Write_Indent_Identifiers -- + ------------------------------ + + function Write_Indent_Identifiers (Node : Node_Id) return Boolean is + begin + -- We need to start a new line for every node, except in the case + -- where we are printing the original tree and this is not the first + -- defining identifier in the list. + + if not Dump_Original_Only or else not Prev_Ids (Node) then + Write_Indent; + + -- If printing original tree and this is not the first defining + -- identifier in the list, then the previous call to this procedure + -- printed only the name, and we add a comma to separate the names. + + else + Write_Str (", "); + end if; + + Sprint_Node (Defining_Identifier (Node)); + + -- The remainder of the declaration must be printed unless we are + -- printing the original tree and this is not the last identifier + + return + not Dump_Original_Only or else not More_Ids (Node); + end Write_Indent_Identifiers; + + ----------------------------------- + -- Write_Indent_Identifiers_Sloc -- + ----------------------------------- + + function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean is + begin + -- We need to start a new line for every node, except in the case + -- where we are printing the original tree and this is not the first + -- defining identifier in the list. + + if not Dump_Original_Only or else not Prev_Ids (Node) then + Write_Indent; + + -- If printing original tree and this is not the first defining + -- identifier in the list, then the previous call to this procedure + -- printed only the name, and we add a comma to separate the names. + + else + Write_Str (", "); + end if; + + Set_Debug_Sloc; + Sprint_Node (Defining_Identifier (Node)); + + -- The remainder of the declaration must be printed unless we are + -- printing the original tree and this is not the last identifier + + return not Dump_Original_Only or else not More_Ids (Node); + end Write_Indent_Identifiers_Sloc; + + ---------------------- + -- Write_Indent_Str -- + ---------------------- + + procedure Write_Indent_Str (S : String) is + begin + Write_Corresponding_Source (S); + Write_Indent; + Write_Str (S); + end Write_Indent_Str; + + --------------------------- + -- Write_Indent_Str_Sloc -- + --------------------------- + + procedure Write_Indent_Str_Sloc (S : String) is + begin + Write_Corresponding_Source (S); + Write_Indent; + Write_Str_Sloc (S); + end Write_Indent_Str_Sloc; + + ----------------- + -- Write_Itype -- + ----------------- + + procedure Write_Itype (Typ : Entity_Id) is + + procedure Write_Header (T : Boolean := True); + -- Write type if T is True, subtype if T is false + + ------------------ + -- Write_Header -- + ------------------ + + procedure Write_Header (T : Boolean := True) is + begin + if T then + Write_Str ("[type "); + else + Write_Str ("[subtype "); + end if; + + Write_Name_With_Col_Check (Chars (Typ)); + Write_Str (" is "); + end Write_Header; + + -- Start of processing for Write_Itype + + begin + if Nkind (Typ) in N_Entity + and then Is_Itype (Typ) + and then not Itype_Printed (Typ) + then + -- Itype to be printed + + declare + B : constant Node_Id := Etype (Typ); + X : Node_Id; + P : constant Node_Id := Parent (Typ); + + S : constant Saved_Output_Buffer := Save_Output_Buffer; + -- Save current output buffer + + Old_Sloc : Source_Ptr; + -- Save sloc of related node, so it is not modified when + -- printing with -gnatD. + + begin + -- Write indentation at start of line + + for J in 1 .. Indent loop + Write_Char (' '); + end loop; + + -- If we have a constructed declaration for the itype, print it + + if Present (P) + and then Nkind (P) in N_Declaration + and then Defining_Entity (P) = Typ + then + -- We must set Itype_Printed true before the recursive call to + -- print the node, otherwise we get an infinite recursion! + + Set_Itype_Printed (Typ, True); + + -- Write the declaration enclosed in [], avoiding new line + -- at start of declaration, and semicolon at end. + + -- Note: The itype may be imported from another unit, in which + -- case we do not want to modify the Sloc of the declaration. + -- Otherwise the itype may appear to be in the current unit, + -- and the back-end will reject a reference out of scope. + + Write_Char ('['); + Indent_Annull_Flag := True; + Old_Sloc := Sloc (P); + Sprint_Node (P); + Set_Sloc (P, Old_Sloc); + Write_Erase_Char (';'); + + -- If no constructed declaration, then we have to concoct the + -- source corresponding to the type entity that we have at hand. + + else + case Ekind (Typ) is + + -- Access types and subtypes + + when Access_Kind => + Write_Header (Ekind (Typ) = E_Access_Type); + + if Can_Never_Be_Null (Typ) then + Write_Str ("not null "); + end if; + + Write_Str ("access "); + + if Is_Access_Constant (Typ) then + Write_Str ("constant "); + end if; + + Write_Id (Directly_Designated_Type (Typ)); + + -- Array types and string types + + when E_Array_Type | E_String_Type => + Write_Header; + Write_Str ("array ("); + + X := First_Index (Typ); + loop + Sprint_Node (X); + + if not Is_Constrained (Typ) then + Write_Str (" range <>"); + end if; + + Next_Index (X); + exit when No (X); + Write_Str (", "); + end loop; + + Write_Str (") of "); + X := Component_Type (Typ); + + -- Preserve sloc of component type, which is defined + -- elsewhere than the itype (see comment above). + + Old_Sloc := Sloc (X); + Sprint_Node (X); + Set_Sloc (X, Old_Sloc); + + -- Array subtypes and string subtypes. + -- Preserve Sloc of index subtypes, as above. + + when E_Array_Subtype | E_String_Subtype => + Write_Header (False); + Write_Id (Etype (Typ)); + Write_Str (" ("); + + X := First_Index (Typ); + loop + Old_Sloc := Sloc (X); + Sprint_Node (X); + Set_Sloc (X, Old_Sloc); + Next_Index (X); + exit when No (X); + Write_Str (", "); + end loop; + + Write_Char (')'); + + -- Signed integer types, and modular integer subtypes, + -- and also enumeration subtypes. + + when E_Signed_Integer_Type | + E_Signed_Integer_Subtype | + E_Modular_Integer_Subtype | + E_Enumeration_Subtype => + + Write_Header (Ekind (Typ) = E_Signed_Integer_Type); + + if Ekind (Typ) = E_Signed_Integer_Type then + Write_Str ("new "); + end if; + + Write_Id (B); + + -- Print bounds if different from base type + + declare + L : constant Node_Id := Type_Low_Bound (Typ); + H : constant Node_Id := Type_High_Bound (Typ); + LE : Node_Id; + HE : Node_Id; + + begin + -- B can either be a scalar type, in which case the + -- declaration of Typ may constrain it with different + -- bounds, or a private type, in which case we know + -- that the declaration of Typ cannot have a scalar + -- constraint. + + if Is_Scalar_Type (B) then + LE := Type_Low_Bound (B); + HE := Type_High_Bound (B); + else + LE := Empty; + HE := Empty; + end if; + + if No (LE) + or else (True + and then Nkind (L) = N_Integer_Literal + and then Nkind (H) = N_Integer_Literal + and then Nkind (LE) = N_Integer_Literal + and then Nkind (HE) = N_Integer_Literal + and then UI_Eq (Intval (L), Intval (LE)) + and then UI_Eq (Intval (H), Intval (HE))) + then + null; + + else + Write_Str (" range "); + Sprint_Node (Type_Low_Bound (Typ)); + Write_Str (" .. "); + Sprint_Node (Type_High_Bound (Typ)); + end if; + end; + + -- Modular integer types + + when E_Modular_Integer_Type => + Write_Header; + Write_Str (" mod "); + Write_Uint_With_Col_Check (Modulus (Typ), Auto); + + -- Floating point types and subtypes + + when E_Floating_Point_Type | + E_Floating_Point_Subtype => + + Write_Header (Ekind (Typ) = E_Floating_Point_Type); + + if Ekind (Typ) = E_Floating_Point_Type then + Write_Str ("new "); + end if; + + Write_Id (Etype (Typ)); + + if Digits_Value (Typ) /= Digits_Value (Etype (Typ)) then + Write_Str (" digits "); + Write_Uint_With_Col_Check + (Digits_Value (Typ), Decimal); + end if; + + -- Print bounds if not different from base type + + declare + L : constant Node_Id := Type_Low_Bound (Typ); + H : constant Node_Id := Type_High_Bound (Typ); + LE : constant Node_Id := Type_Low_Bound (B); + HE : constant Node_Id := Type_High_Bound (B); + + begin + if Nkind (L) = N_Real_Literal + and then Nkind (H) = N_Real_Literal + and then Nkind (LE) = N_Real_Literal + and then Nkind (HE) = N_Real_Literal + and then UR_Eq (Realval (L), Realval (LE)) + and then UR_Eq (Realval (H), Realval (HE)) + then + null; + + else + Write_Str (" range "); + Sprint_Node (Type_Low_Bound (Typ)); + Write_Str (" .. "); + Sprint_Node (Type_High_Bound (Typ)); + end if; + end; + + -- Record subtypes + + when E_Record_Subtype => + Write_Header (False); + Write_Str ("record"); + Indent_Begin; + + declare + C : Entity_Id; + begin + C := First_Entity (Typ); + while Present (C) loop + Write_Indent; + Write_Id (C); + Write_Str (" : "); + Write_Id (Etype (C)); + Next_Entity (C); + end loop; + end; + + Indent_End; + Write_Indent_Str (" end record"); + + -- Class-Wide types + + when E_Class_Wide_Type | + E_Class_Wide_Subtype => + Write_Header; + Write_Name_With_Col_Check (Chars (Etype (Typ))); + Write_Str ("'Class"); + + -- Subprogram types + + when E_Subprogram_Type => + Write_Header; + + if Etype (Typ) = Standard_Void_Type then + Write_Str ("procedure"); + else + Write_Str ("function"); + end if; + + if Present (First_Entity (Typ)) then + Write_Str (" ("); + + declare + Param : Entity_Id; + + begin + Param := First_Entity (Typ); + loop + Write_Id (Param); + Write_Str (" : "); + + if Ekind (Param) = E_In_Out_Parameter then + Write_Str ("in out "); + elsif Ekind (Param) = E_Out_Parameter then + Write_Str ("out "); + end if; + + Write_Id (Etype (Param)); + Next_Entity (Param); + exit when No (Param); + Write_Str (", "); + end loop; + + Write_Char (')'); + end; + end if; + + if Etype (Typ) /= Standard_Void_Type then + Write_Str (" return "); + Write_Id (Etype (Typ)); + end if; + + when E_String_Literal_Subtype => + declare + LB : constant Uint := + Expr_Value (String_Literal_Low_Bound (Typ)); + Len : constant Uint := + String_Literal_Length (Typ); + begin + Write_Str ("String ("); + Write_Int (UI_To_Int (LB)); + Write_Str (" .. "); + Write_Int (UI_To_Int (LB + Len) - 1); + Write_Str (");"); + end; + + -- For all other Itypes, print ??? (fill in later) + + when others => + Write_Header (True); + Write_Str ("???"); + + end case; + end if; + + -- Add terminating bracket and restore output buffer + + Write_Char (']'); + Write_Eol; + Restore_Output_Buffer (S); + end; + + Set_Itype_Printed (Typ); + end if; + end Write_Itype; + + ------------------------------- + -- Write_Name_With_Col_Check -- + ------------------------------- + + procedure Write_Name_With_Col_Check (N : Name_Id) is + J : Natural; + K : Natural; + L : Natural; + + begin + Get_Name_String (N); + + -- Deal with -gnatdI which replaces any sequence Cnnnb where C is an + -- upper case letter, nnn is one or more digits and b is a lower case + -- letter by C...b, so that listings do not depend on serial numbers. + + if Debug_Flag_II then + J := 1; + while J < Name_Len - 1 loop + if Name_Buffer (J) in 'A' .. 'Z' + and then Name_Buffer (J + 1) in '0' .. '9' + then + K := J + 1; + while K < Name_Len loop + exit when Name_Buffer (K) not in '0' .. '9'; + K := K + 1; + end loop; + + if Name_Buffer (K) in 'a' .. 'z' then + L := Name_Len - K + 1; + + Name_Buffer (J + 4 .. J + L + 3) := + Name_Buffer (K .. Name_Len); + Name_Buffer (J + 1 .. J + 3) := "..."; + Name_Len := J + L + 3; + J := J + 5; + + else + J := K; + end if; + + else + J := J + 1; + end if; + end loop; + end if; + + -- Fall through for normal case + + Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len)); + end Write_Name_With_Col_Check; + + ------------------------------------ + -- Write_Name_With_Col_Check_Sloc -- + ------------------------------------ + + procedure Write_Name_With_Col_Check_Sloc (N : Name_Id) is + begin + Get_Name_String (N); + Write_Str_With_Col_Check_Sloc (Name_Buffer (1 .. Name_Len)); + end Write_Name_With_Col_Check_Sloc; + + -------------------- + -- Write_Operator -- + -------------------- + + procedure Write_Operator (N : Node_Id; S : String) is + F : Natural := S'First; + T : Natural := S'Last; + + begin + -- If no overflow check, just write string out, and we are done + + if not Do_Overflow_Check (N) then + Write_Str_Sloc (S); + + -- If overflow check, we want to surround the operator with curly + -- brackets, but not include spaces within the brackets. + + else + if S (F) = ' ' then + Write_Char (' '); + F := F + 1; + end if; + + if S (T) = ' ' then + T := T - 1; + end if; + + Write_Char ('{'); + Write_Str_Sloc (S (F .. T)); + Write_Char ('}'); + + if S (S'Last) = ' ' then + Write_Char (' '); + end if; + end if; + end Write_Operator; + + ----------------------- + -- Write_Param_Specs -- + ----------------------- + + procedure Write_Param_Specs (N : Node_Id) is + Specs : List_Id; + Spec : Node_Id; + Formal : Node_Id; + + begin + Specs := Parameter_Specifications (N); + + if Is_Non_Empty_List (Specs) then + Write_Str_With_Col_Check (" ("); + Spec := First (Specs); + + loop + Sprint_Node (Spec); + Formal := Defining_Identifier (Spec); + Next (Spec); + exit when Spec = Empty; + + -- Add semicolon, unless we are printing original tree and the + -- next specification is part of a list (but not the first element + -- of that list). + + if not Dump_Original_Only or else not Prev_Ids (Spec) then + Write_Str ("; "); + end if; + end loop; + + -- Write out any extra formals + + while Present (Extra_Formal (Formal)) loop + Formal := Extra_Formal (Formal); + Write_Str ("; "); + Write_Name_With_Col_Check (Chars (Formal)); + Write_Str (" : "); + Write_Name_With_Col_Check (Chars (Etype (Formal))); + end loop; + + Write_Char (')'); + end if; + end Write_Param_Specs; + + ----------------------- + -- Write_Rewrite_Str -- + ----------------------- + + procedure Write_Rewrite_Str (S : String) is + begin + if not Dump_Generated_Only then + if S'Length = 3 and then S = ">>>" then + Write_Str (">>>"); + else + Write_Str_With_Col_Check (S); + end if; + end if; + end Write_Rewrite_Str; + + ----------------------- + -- Write_Source_Line -- + ----------------------- + + procedure Write_Source_Line (L : Physical_Line_Number) is + Loc : Source_Ptr; + Src : Source_Buffer_Ptr; + Scn : Source_Ptr; + + begin + if Dump_Source_Text then + Src := Source_Text (Current_Source_File); + Loc := Line_Start (L, Current_Source_File); + Write_Eol; + + -- See if line is a comment line, if not, and if not line one, + -- precede with blank line. + + Scn := Loc; + while Src (Scn) = ' ' or else Src (Scn) = ASCII.HT loop + Scn := Scn + 1; + end loop; + + if (Src (Scn) in Line_Terminator + or else Src (Scn .. Scn + 1) /= "--") + and then L /= 1 + then + Write_Eol; + end if; + + -- Now write the source text of the line + + Write_Str ("-- "); + Write_Int (Int (L)); + Write_Str (": "); + + while Src (Loc) not in Line_Terminator loop + Write_Char (Src (Loc)); + Loc := Loc + 1; + end loop; + end if; + end Write_Source_Line; + + ------------------------ + -- Write_Source_Lines -- + ------------------------ + + procedure Write_Source_Lines (L : Physical_Line_Number) is + begin + while Last_Line_Printed < L loop + Last_Line_Printed := Last_Line_Printed + 1; + Write_Source_Line (Last_Line_Printed); + end loop; + end Write_Source_Lines; + + -------------------- + -- Write_Str_Sloc -- + -------------------- + + procedure Write_Str_Sloc (S : String) is + begin + for J in S'Range loop + Write_Char_Sloc (S (J)); + end loop; + end Write_Str_Sloc; + + ------------------------------ + -- Write_Str_With_Col_Check -- + ------------------------------ + + procedure Write_Str_With_Col_Check (S : String) is + begin + if Int (S'Last) + Column > Sprint_Line_Limit then + Write_Indent_Str (" "); + + if S (S'First) = ' ' then + Write_Str (S (S'First + 1 .. S'Last)); + else + Write_Str (S); + end if; + + else + Write_Str (S); + end if; + end Write_Str_With_Col_Check; + + ----------------------------------- + -- Write_Str_With_Col_Check_Sloc -- + ----------------------------------- + + procedure Write_Str_With_Col_Check_Sloc (S : String) is + begin + if Int (S'Last) + Column > Sprint_Line_Limit then + Write_Indent_Str (" "); + + if S (S'First) = ' ' then + Write_Str_Sloc (S (S'First + 1 .. S'Last)); + else + Write_Str_Sloc (S); + end if; + + else + Write_Str_Sloc (S); + end if; + end Write_Str_With_Col_Check_Sloc; + + --------------------------- + -- Write_Subprogram_Name -- + --------------------------- + + procedure Write_Subprogram_Name (N : Node_Id) is + begin + if not Comes_From_Source (N) + and then Is_Entity_Name (N) + then + declare + Ent : constant Entity_Id := Entity (N); + begin + if not In_Extended_Main_Source_Unit (Ent) + and then + Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Ent))) + then + -- Run-time routine name, output name with a preceding dollar + -- making sure that we do not get a line split between them. + + Col_Check (Length_Of_Name (Chars (Ent)) + 1); + Write_Char ('$'); + Write_Name (Chars (Ent)); + return; + end if; + end; + end if; + + -- Normal case, not a run-time routine name + + Sprint_Node (N); + end Write_Subprogram_Name; + + ------------------------------- + -- Write_Uint_With_Col_Check -- + ------------------------------- + + procedure Write_Uint_With_Col_Check (U : Uint; Format : UI_Format) is + begin + Col_Check (UI_Decimal_Digits_Hi (U)); + UI_Write (U, Format); + end Write_Uint_With_Col_Check; + + ------------------------------------ + -- Write_Uint_With_Col_Check_Sloc -- + ------------------------------------ + + procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format) is + begin + Col_Check (UI_Decimal_Digits_Hi (U)); + Set_Debug_Sloc; + UI_Write (U, Format); + end Write_Uint_With_Col_Check_Sloc; + + ------------------------------------- + -- Write_Ureal_With_Col_Check_Sloc -- + ------------------------------------- + + procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal) is + D : constant Uint := Denominator (U); + N : constant Uint := Numerator (U); + begin + Col_Check (UI_Decimal_Digits_Hi (D) + UI_Decimal_Digits_Hi (N) + 4); + Set_Debug_Sloc; + UR_Write (U, Brackets => True); + end Write_Ureal_With_Col_Check_Sloc; + +end Sprint; diff --git a/gcc/ada/sprint.ads b/gcc/ada/sprint.ads new file mode 100644 index 000000000..ffbe20886 --- /dev/null +++ b/gcc/ada/sprint.ads @@ -0,0 +1,161 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S P R I N T -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package (source print) contains routines for printing the source +-- program corresponding to a specified syntax tree. These routines are +-- intended for debugging use in the compiler (not as a user level pretty +-- print tool). Only information present in the tree is output (e.g. no +-- comments are present in the output), and as far as possible we avoid +-- making any assumptions about the correctness of the tree, so a bad +-- tree may either blow up on a debugging check, or list incorrect source. + +with Types; use Types; + +package Sprint is + + ----------------------- + -- Syntax Extensions -- + ----------------------- + + -- When the generated tree is printed, it contains constructs that are not + -- pure Ada. For convenience, syntactic extensions to Ada have been defined + -- purely for the purposes of this printout (they are not recognized by the + -- parser) + + -- Could use more documentation for all of these ??? + + -- Allocator new xxx [storage_pool = xxx] + -- Cleanup action at end procedure name; + -- Conditional expression (if expr then expr else expr) + -- Conversion wi Float_Truncate target^(source) + -- Convert wi Conversion_OK target?(source) + -- Convert wi Rounded_Result target@(source) + -- Divide wi Treat_Fixed_As_Integer x #/ y + -- Divide wi Rounded_Result x @/ y + -- Expression with actions do action; .. action; in expr end + -- Expression with range check {expression} + -- Free statement free expr [storage_pool = xxx] + -- Freeze entity with freeze actions freeze entityname [ actions ] + -- Implicit call to run time routine $routine-name + -- Implicit exportation $pragma import (...) + -- Implicit importation $pragma export (...) + -- Interpretation interpretation type [, entity] + -- Intrinsic calls function-name!(arg, arg, arg) + -- Itype declaration [(sub)type declaration without ;] + -- Itype reference reference itype + -- Label declaration labelname : label + -- Mod wi Treat_Fixed_As_Integer x #mod y + -- Multiple concatenation expr && expr && expr ... && expr + -- Multiply wi Treat_Fixed_As_Integer x #* y + -- Multiply wi Rounded_Result x @* y + -- Operator with range check {operator} (e.g. {+}) + -- Others choice for cleanup when all others + -- Pop exception label %pop_xxx_exception_label + -- Push exception label %push_xxx_exception_label (label) + -- Raise xxx error [xxx_error [when cond]] + -- Raise xxx error with msg [xxx_error [when cond], "msg"] + -- Rational literal [expression] + -- Rem wi Treat_Fixed_As_Integer x #rem y + -- Reference expression'reference + -- Shift nodes shift_name!(expr, count) + -- Static declaration name : static xxx + -- Subprogram_Info subprog'Subprogram_Info + -- Unchecked conversion target_type!(source_expression) + -- Unchecked expression `(expression) + -- Validate_Unchecked_Conversion validate unchecked_conversion + -- (src-type, target-typ); + + -- Note: the storage_pool parameters for allocators and the free node are + -- omitted if the Storage_Pool field is Empty, indicating use of the + -- standard default pool. + + ----------------- + -- Subprograms -- + ----------------- + + procedure Source_Dump; + -- This routine is called from the GNAT main program to dump source as + -- requested by debug options. The relevant debug options are: + -- -ds print source from tree, both original and generated code + -- -dg print source from tree, including only the generated code + -- -do print source from tree, including only the original code + -- -df modify the above to include all units, not just the main unit + -- -sz print source from tree for package Standard + + procedure Sprint_Comma_List (List : List_Id); + -- Prints the nodes in a list, with separating commas. If the list is empty + -- then no output is generated. + + procedure Sprint_Paren_Comma_List (List : List_Id); + -- Prints the nodes in a list, surrounded by parentheses, and separated by + -- commas. If the list is empty, then no output is generated. A blank is + -- output before the initial left parenthesis. + + procedure Sprint_Opt_Paren_Comma_List (List : List_Id); + -- Same as normal Sprint_Paren_Comma_List procedure, except that an extra + -- blank is output if List is non-empty, and nothing at all is printed it + -- the argument is No_List. + + procedure Sprint_Node_List (List : List_Id); + -- Prints the nodes in a list with no separating characters. This is used + -- in the case of lists of items which are printed on separate lines using + -- the current indentation amount. Note that Sprint_Node_List itself + -- does not generate any New_Line calls. + + procedure Sprint_Opt_Node_List (List : List_Id); + -- Like Sprint_Node_List, but prints nothing if List = No_List + + procedure Sprint_Indented_List (List : List_Id); + -- Like Sprint_Line_List, except that the indentation level is increased + -- before outputting the list of items, and then decremented (back to its + -- original level) before returning to the caller. + + procedure Sprint_Node (Node : Node_Id); + -- Prints a single node. No new lines are output, except as required for + -- splitting lines that are too long to fit on a single physical line. + -- No output is generated at all if Node is Empty. No trailing or leading + -- blank characters are generated. + + procedure Sprint_Opt_Node (Node : Node_Id); + -- Same as normal Sprint_Node procedure, except that one leading blank is + -- output before the node if it is non-empty. + + procedure pg (Arg : Union_Id); + pragma Export (Ada, pg); + -- Print generated source for argument N (like -gnatdg output). Intended + -- only for use from gdb for debugging purposes. Currently, Arg may be a + -- List_Id or a Node_Id (anything else outputs a blank line). + + procedure po (Arg : Union_Id); + pragma Export (Ada, po); + -- Like pg, but prints original source for the argument (like -gnatdo + -- output). Intended only for use from gdb for debugging purposes. + + procedure ps (Arg : Union_Id); + pragma Export (Ada, ps); + -- Like pg, but prints generated and original source for the argument (like + -- -gnatds output). Intended only for use from gdb for debugging purposes. + +end Sprint; diff --git a/gcc/ada/stand.adb b/gcc/ada/stand.adb new file mode 100644 index 000000000..ab703fbb7 --- /dev/null +++ b/gcc/ada/stand.adb @@ -0,0 +1,127 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S T A N D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992,1993,1994,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. -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; +with Tree_IO; use Tree_IO; + +package body Stand is + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + begin + Tree_Read_Data (Standard_Entity'Address, + Standard_Entity_Array_Type'Size / Storage_Unit); + + Tree_Read_Int (Int (Standard_Package_Node)); + Tree_Read_Int (Int (Last_Standard_Node_Id)); + Tree_Read_Int (Int (Last_Standard_List_Id)); + Tree_Read_Int (Int (Standard_Void_Type)); + Tree_Read_Int (Int (Standard_Exception_Type)); + Tree_Read_Int (Int (Standard_A_String)); + Tree_Read_Int (Int (Any_Id)); + Tree_Read_Int (Int (Any_Type)); + Tree_Read_Int (Int (Any_Access)); + Tree_Read_Int (Int (Any_Array)); + Tree_Read_Int (Int (Any_Boolean)); + Tree_Read_Int (Int (Any_Character)); + Tree_Read_Int (Int (Any_Composite)); + Tree_Read_Int (Int (Any_Discrete)); + Tree_Read_Int (Int (Any_Fixed)); + Tree_Read_Int (Int (Any_Integer)); + Tree_Read_Int (Int (Any_Numeric)); + Tree_Read_Int (Int (Any_Real)); + Tree_Read_Int (Int (Any_Scalar)); + Tree_Read_Int (Int (Any_String)); + Tree_Read_Int (Int (Universal_Integer)); + Tree_Read_Int (Int (Universal_Real)); + Tree_Read_Int (Int (Universal_Fixed)); + Tree_Read_Int (Int (Standard_Integer_8)); + Tree_Read_Int (Int (Standard_Integer_16)); + Tree_Read_Int (Int (Standard_Integer_32)); + Tree_Read_Int (Int (Standard_Integer_64)); + Tree_Read_Int (Int (Abort_Signal)); + Tree_Read_Int (Int (Standard_Op_Rotate_Left)); + Tree_Read_Int (Int (Standard_Op_Rotate_Right)); + Tree_Read_Int (Int (Standard_Op_Shift_Left)); + Tree_Read_Int (Int (Standard_Op_Shift_Right)); + Tree_Read_Int (Int (Standard_Op_Shift_Right_Arithmetic)); + + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + begin + Tree_Write_Data (Standard_Entity'Address, + Standard_Entity_Array_Type'Size / Storage_Unit); + + Tree_Write_Int (Int (Standard_Package_Node)); + Tree_Write_Int (Int (Last_Standard_Node_Id)); + Tree_Write_Int (Int (Last_Standard_List_Id)); + Tree_Write_Int (Int (Standard_Void_Type)); + Tree_Write_Int (Int (Standard_Exception_Type)); + Tree_Write_Int (Int (Standard_A_String)); + Tree_Write_Int (Int (Any_Id)); + Tree_Write_Int (Int (Any_Type)); + Tree_Write_Int (Int (Any_Access)); + Tree_Write_Int (Int (Any_Array)); + Tree_Write_Int (Int (Any_Boolean)); + Tree_Write_Int (Int (Any_Character)); + Tree_Write_Int (Int (Any_Composite)); + Tree_Write_Int (Int (Any_Discrete)); + Tree_Write_Int (Int (Any_Fixed)); + Tree_Write_Int (Int (Any_Integer)); + Tree_Write_Int (Int (Any_Numeric)); + Tree_Write_Int (Int (Any_Real)); + Tree_Write_Int (Int (Any_Scalar)); + Tree_Write_Int (Int (Any_String)); + Tree_Write_Int (Int (Universal_Integer)); + Tree_Write_Int (Int (Universal_Real)); + Tree_Write_Int (Int (Universal_Fixed)); + Tree_Write_Int (Int (Standard_Integer_8)); + Tree_Write_Int (Int (Standard_Integer_16)); + Tree_Write_Int (Int (Standard_Integer_32)); + Tree_Write_Int (Int (Standard_Integer_64)); + Tree_Write_Int (Int (Abort_Signal)); + Tree_Write_Int (Int (Standard_Op_Rotate_Left)); + Tree_Write_Int (Int (Standard_Op_Rotate_Right)); + Tree_Write_Int (Int (Standard_Op_Shift_Left)); + Tree_Write_Int (Int (Standard_Op_Shift_Right)); + Tree_Write_Int (Int (Standard_Op_Shift_Right_Arithmetic)); + + end Tree_Write; + +end Stand; diff --git a/gcc/ada/stand.ads b/gcc/ada/stand.ads new file mode 100644 index 000000000..46bbe4cb8 --- /dev/null +++ b/gcc/ada/stand.ads @@ -0,0 +1,463 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S T A N D -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the declarations of entities in package Standard, +-- These values are initialized either by calling CStand.Create_Standard, +-- or by calling Stand.Tree_Read. + +with Types; use Types; + +package Stand is + + type Standard_Entity_Type is ( + -- This enumeration type contains an entry for each name in Standard + + -- Package names + + S_Standard, + S_ASCII, + + -- Types and subtypes defined in package Standard (in the order in which + -- they appear in the RM, so that the declarations are in the right + -- order for the purposes of ASIS traversals + + S_Boolean, + + S_Short_Short_Integer, + S_Short_Integer, + S_Integer, + S_Long_Integer, + S_Long_Long_Integer, + + S_Natural, + S_Positive, + + S_Short_Float, + S_Float, + S_Long_Float, + S_Long_Long_Float, + + S_Character, + S_Wide_Character, + S_Wide_Wide_Character, + + S_String, + S_Wide_String, + S_Wide_Wide_String, + + S_Duration, + + -- Enumeration literals for type Boolean + + S_False, + S_True, + + -- Exceptions declared in package Standard + + S_Constraint_Error, + S_Numeric_Error, + S_Program_Error, + S_Storage_Error, + S_Tasking_Error, + + -- Binary Operators declared in package Standard + + S_Op_Add, + S_Op_And, + S_Op_Concat, + S_Op_Concatw, + S_Op_Concatww, + S_Op_Divide, + S_Op_Eq, + S_Op_Expon, + S_Op_Ge, + S_Op_Gt, + S_Op_Le, + S_Op_Lt, + S_Op_Mod, + S_Op_Multiply, + S_Op_Ne, + S_Op_Or, + S_Op_Rem, + S_Op_Subtract, + S_Op_Xor, + + -- Unary operators declared in package Standard + + S_Op_Abs, + S_Op_Minus, + S_Op_Not, + S_Op_Plus, + + -- Constants defined in package ASCII (with value in hex). + -- First the thirty-two C0 control characters) + + S_NUL, -- 16#00# + S_SOH, -- 16#01# + S_STX, -- 16#02# + S_ETX, -- 16#03# + S_EOT, -- 16#04# + S_ENQ, -- 16#05# + S_ACK, -- 16#06# + S_BEL, -- 16#07# + S_BS, -- 16#08# + S_HT, -- 16#09# + S_LF, -- 16#0A# + S_VT, -- 16#0B# + S_FF, -- 16#0C# + S_CR, -- 16#0D# + S_SO, -- 16#0E# + S_SI, -- 16#0F# + S_DLE, -- 16#10# + S_DC1, -- 16#11# + S_DC2, -- 16#12# + S_DC3, -- 16#13# + S_DC4, -- 16#14# + S_NAK, -- 16#15# + S_SYN, -- 16#16# + S_ETB, -- 16#17# + S_CAN, -- 16#18# + S_EM, -- 16#19# + S_SUB, -- 16#1A# + S_ESC, -- 16#1B# + S_FS, -- 16#1C# + S_GS, -- 16#1D# + S_RS, -- 16#1E# + S_US, -- 16#1F# + + -- Here are the ones for Colonel Whitaker's O26 keypunch! + + S_Exclam, -- 16#21# + S_Quotation, -- 16#22# + S_Sharp, -- 16#23# + S_Dollar, -- 16#24# + S_Percent, -- 16#25# + S_Ampersand, -- 16#26# + + S_Colon, -- 16#3A# + S_Semicolon, -- 16#3B# + + S_Query, -- 16#3F# + S_At_Sign, -- 16#40# + + S_L_Bracket, -- 16#5B# + S_Back_Slash, -- 16#5C# + S_R_Bracket, -- 16#5D# + S_Circumflex, -- 16#5E# + S_Underline, -- 16#5F# + S_Grave, -- 16#60# + + S_LC_A, -- 16#61# + S_LC_B, -- 16#62# + S_LC_C, -- 16#63# + S_LC_D, -- 16#64# + S_LC_E, -- 16#65# + S_LC_F, -- 16#66# + S_LC_G, -- 16#67# + S_LC_H, -- 16#68# + S_LC_I, -- 16#69# + S_LC_J, -- 16#6A# + S_LC_K, -- 16#6B# + S_LC_L, -- 16#6C# + S_LC_M, -- 16#6D# + S_LC_N, -- 16#6E# + S_LC_O, -- 16#6F# + S_LC_P, -- 16#70# + S_LC_Q, -- 16#71# + S_LC_R, -- 16#72# + S_LC_S, -- 16#73# + S_LC_T, -- 16#74# + S_LC_U, -- 16#75# + S_LC_V, -- 16#76# + S_LC_W, -- 16#77# + S_LC_X, -- 16#78# + S_LC_Y, -- 16#79# + S_LC_Z, -- 16#7A# + + S_L_BRACE, -- 16#7B# + S_BAR, -- 16#7C# + S_R_BRACE, -- 16#7D# + S_TILDE, -- 16#7E# + + -- And one more control character, all on its own + + S_DEL); -- 16#7F# + + subtype S_Types is + Standard_Entity_Type range S_Boolean .. S_Duration; + + subtype S_Exceptions is + Standard_Entity_Type range S_Constraint_Error .. S_Tasking_Error; + + subtype S_ASCII_Names is + Standard_Entity_Type range S_NUL .. S_DEL; + + subtype S_Binary_Ops is + Standard_Entity_Type range S_Op_Add .. S_Op_Xor; + + subtype S_Unary_Ops is + Standard_Entity_Type range S_Op_Abs .. S_Op_Plus; + + type Standard_Entity_Array_Type is array (Standard_Entity_Type) of Node_Id; + + Standard_Entity : Standard_Entity_Array_Type; + -- This array contains pointers to the Defining Identifier nodes + -- for each of the entities defined in Standard_Entities_Type. It + -- is initialized by the Create_Standard procedure. + + Standard_Package_Node : Node_Id; + -- Points to the N_Package_Declaration node for standard. Also + -- initialized by the Create_Standard procedure. + + -- The following Entities are the pointers to the Defining Identifier + -- nodes for some visible entities defined in Standard_Entities_Type. + + SE : Standard_Entity_Array_Type renames Standard_Entity; + + Standard_Standard : Entity_Id renames SE (S_Standard); + + Standard_ASCII : Entity_Id renames SE (S_ASCII); + Standard_Character : Entity_Id renames SE (S_Character); + Standard_Wide_Character : Entity_Id renames SE (S_Wide_Character); + Standard_Wide_Wide_Character : Entity_Id renames SE (S_Wide_Wide_Character); + Standard_String : Entity_Id renames SE (S_String); + Standard_Wide_String : Entity_Id renames SE (S_Wide_String); + Standard_Wide_Wide_String : Entity_Id renames SE (S_Wide_Wide_String); + + Standard_Boolean : Entity_Id renames SE (S_Boolean); + Standard_False : Entity_Id renames SE (S_False); + Standard_True : Entity_Id renames SE (S_True); + + Standard_Duration : Entity_Id renames SE (S_Duration); + + Standard_Natural : Entity_Id renames SE (S_Natural); + Standard_Positive : Entity_Id renames SE (S_Positive); + + Standard_Constraint_Error : Entity_Id renames SE (S_Constraint_Error); + Standard_Numeric_Error : Entity_Id renames SE (S_Numeric_Error); + Standard_Program_Error : Entity_Id renames SE (S_Program_Error); + Standard_Storage_Error : Entity_Id renames SE (S_Storage_Error); + Standard_Tasking_Error : Entity_Id renames SE (S_Tasking_Error); + + Standard_Short_Float : Entity_Id renames SE (S_Short_Float); + Standard_Float : Entity_Id renames SE (S_Float); + Standard_Long_Float : Entity_Id renames SE (S_Long_Float); + Standard_Long_Long_Float : Entity_Id renames SE (S_Long_Long_Float); + + Standard_Short_Short_Integer : Entity_Id renames SE (S_Short_Short_Integer); + Standard_Short_Integer : Entity_Id renames SE (S_Short_Integer); + Standard_Integer : Entity_Id renames SE (S_Integer); + Standard_Long_Integer : Entity_Id renames SE (S_Long_Integer); + Standard_Long_Long_Integer : Entity_Id renames SE (S_Long_Long_Integer); + + Standard_Op_Add : Entity_Id renames SE (S_Op_Add); + Standard_Op_And : Entity_Id renames SE (S_Op_And); + Standard_Op_Concat : Entity_Id renames SE (S_Op_Concat); + Standard_Op_Concatw : Entity_Id renames SE (S_Op_Concatw); + Standard_Op_Concatww : Entity_Id renames SE (S_Op_Concatww); + Standard_Op_Divide : Entity_Id renames SE (S_Op_Divide); + Standard_Op_Eq : Entity_Id renames SE (S_Op_Eq); + Standard_Op_Expon : Entity_Id renames SE (S_Op_Expon); + Standard_Op_Ge : Entity_Id renames SE (S_Op_Ge); + Standard_Op_Gt : Entity_Id renames SE (S_Op_Gt); + Standard_Op_Le : Entity_Id renames SE (S_Op_Le); + Standard_Op_Lt : Entity_Id renames SE (S_Op_Lt); + Standard_Op_Mod : Entity_Id renames SE (S_Op_Mod); + Standard_Op_Multiply : Entity_Id renames SE (S_Op_Multiply); + Standard_Op_Ne : Entity_Id renames SE (S_Op_Ne); + Standard_Op_Or : Entity_Id renames SE (S_Op_Or); + Standard_Op_Rem : Entity_Id renames SE (S_Op_Rem); + Standard_Op_Subtract : Entity_Id renames SE (S_Op_Subtract); + Standard_Op_Xor : Entity_Id renames SE (S_Op_Xor); + + Standard_Op_Abs : Entity_Id renames SE (S_Op_Abs); + Standard_Op_Minus : Entity_Id renames SE (S_Op_Minus); + Standard_Op_Not : Entity_Id renames SE (S_Op_Not); + Standard_Op_Plus : Entity_Id renames SE (S_Op_Plus); + + Last_Standard_Node_Id : Node_Id; + -- Highest Node_Id value used by Standard + + Last_Standard_List_Id : List_Id; + -- Highest List_Id value used by Standard (including those used by + -- normal list headers, element list headers, and list elements) + + Boolean_Literals : array (Boolean) of Entity_Id; + -- Entities for the two boolean literals, used by the expander + + ------------------------------------- + -- Semantic Phase Special Entities -- + ------------------------------------- + + -- The semantic phase needs a number of entities for internal processing + -- that are logically at the level of Standard, and hence defined in this + -- package. However, they are never visible to a program, and are not + -- chained on to the Decls list of Standard. The names of all these + -- types are relevant only in certain debugging and error message + -- situations. They have names that are suitable for use in such + -- error messages (see body for actual names used). + + Standard_Void_Type : Entity_Id; + -- This is a type used to represent the return type of procedures + + Standard_Exception_Type : Entity_Id; + -- This is a type used to represent the Etype of exceptions + + Standard_A_String : Entity_Id; + -- An access to String type used for building elements of tables + -- carrying the enumeration literal names. + + Standard_A_Char : Entity_Id; + -- Access to character, used as a component of the exception type to + -- denote a thin pointer component. + + Standard_Debug_Renaming_Type : Entity_Id; + -- A zero-size subtype of Integer, used as the type of variables used + -- to provide the debugger with name encodings for renaming declarations. + + -- The entities labeled Any_xxx are used in situations where the full + -- characteristics of an entity are not yet known, e.g. Any_Character + -- is used to label a character literal before resolution is complete. + -- These entities are also used to construct appropriate references in + -- error messages ("expecting an integer type"). + + Any_Id : Entity_Id; + -- Used to represent some unknown identifier. Used to label undefined + -- identifier references to prevent cascaded errors. + + Any_Type : Entity_Id; + -- Used to represent some unknown type. Plays an important role in + -- avoiding cascaded errors, since any node that remains labeled with + -- this type corresponds to an already issued error message. Any_Type + -- is propagated to avoid cascaded errors from a single type error. + + Any_Access : Entity_Id; + -- Used to resolve the overloaded literal NULL + + Any_Array : Entity_Id; + -- Used to represent some unknown array type + + Any_Boolean : Entity_Id; + -- The context type of conditions in IF and WHILE statements + + Any_Character : Entity_Id; + -- Any_Character is used to label character literals, which in general + -- will not have an explicit declaration (this is true of the predefined + -- character types). + + Any_Composite : Entity_Id; + -- The type Any_Composite is used for aggregates before type resolution. + -- It is compatible with any array or non-limited record type. + + Any_Discrete : Entity_Id; + -- Used to represent some unknown discrete type + + Any_Fixed : Entity_Id; + -- Used to represent some unknown fixed-point type + + Any_Integer : Entity_Id; + -- Used to represent some unknown integer type + + Any_Modular : Entity_Id; + -- Used to represent the result type of a boolean operation on an + -- integer literal. The result is not Universal_Integer, because it is + -- only legal in a modular context. + + Any_Numeric : Entity_Id; + -- Used to represent some unknown numeric type + + Any_Real : Entity_Id; + -- Used to represent some unknown real type + + Any_Scalar : Entity_Id; + -- Used to represent some unknown scalar type + + Any_String : Entity_Id; + -- The type Any_String is used for string literals before type + -- resolution. It corresponds to array (Positive range <>) of character + -- where the component type is compatible with any character type, + -- not just Standard_Character. + + Universal_Integer : Entity_Id; + -- Entity for universal integer type. The bounds of this type correspond + -- to the largest supported integer type (i.e. Long_Long_Integer). It is + -- the type used for runtime calculations in type universal integer. + + Universal_Real : Entity_Id; + -- Entity for universal real type. The bounds of this type correspond to + -- to the largest supported real type (i.e. Long_Long_Float). It is the + -- type used for runtime calculations in type universal real. Note that + -- this type is always IEEE format, even if Long_Long_Float is Vax_Float + -- (and in that case the bounds don't correspond exactly). + + Universal_Fixed : Entity_Id; + -- Entity for universal fixed type. This is a type with arbitrary + -- precision that can only appear in a context with a specific type. + -- Universal_Fixed labels the result of multiplication or division of + -- two fixed point numbers, and has no specified bounds (since, unlike + -- universal integer and universal real, it is never used for runtime + -- calculations). + + Standard_Integer_8 : Entity_Id; + Standard_Integer_16 : Entity_Id; + Standard_Integer_32 : Entity_Id; + Standard_Integer_64 : Entity_Id; + -- These are signed integer types with the indicated sizes, They are + -- used for the underlying implementation types for fixed-point and + -- enumeration types. + + Standard_Unsigned : Entity_Id; + -- An unsigned type of the same size as Standard_Integer + + Abort_Signal : Entity_Id; + -- Entity for abort signal exception + + Standard_Op_Rotate_Left : Entity_Id; + Standard_Op_Rotate_Right : Entity_Id; + Standard_Op_Shift_Left : Entity_Id; + Standard_Op_Shift_Right : Entity_Id; + Standard_Op_Shift_Right_Arithmetic : Entity_Id; + -- These entities are used for shift operators generated by the expander + + ----------------- + -- Subprograms -- + ----------------- + + procedure Tree_Read; + -- Initializes entity values in this package from the current tree + -- file using Osint.Tree_Read. Note that Tree_Read includes all the + -- initialization that is carried out by Create_Standard. + + procedure Tree_Write; + -- Writes out the entity values in this package to the current + -- tree file using Osint.Tree_Write. + +end Stand; diff --git a/gcc/ada/stringt.adb b/gcc/ada/stringt.adb new file mode 100644 index 000000000..89dfe6e27 --- /dev/null +++ b/gcc/ada/stringt.adb @@ -0,0 +1,449 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S T R I N G 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. -- +-- -- +------------------------------------------------------------------------------ + +with Alloc; +with Namet; use Namet; +with Output; use Output; +with Table; + +package body Stringt is + + -- The following table stores the sequence of character codes for the + -- stored string constants. The entries are referenced from the + -- separate Strings table. + + package String_Chars is new Table.Table ( + Table_Component_Type => Char_Code, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.String_Chars_Initial, + Table_Increment => Alloc.String_Chars_Increment, + Table_Name => "String_Chars"); + + -- The String_Id values reference entries in the Strings table, which + -- contains String_Entry records that record the length of each stored + -- string and its starting location in the String_Chars table. + + type String_Entry is record + String_Index : Int; + Length : Nat; + end record; + + package Strings is new Table.Table ( + Table_Component_Type => String_Entry, + Table_Index_Type => String_Id'Base, + Table_Low_Bound => First_String_Id, + Table_Initial => Alloc.Strings_Initial, + Table_Increment => Alloc.Strings_Increment, + Table_Name => "Strings"); + + -- Note: it is possible that two entries in the Strings table can share + -- string data in the String_Chars table, and in particular this happens + -- when Start_String is called with a parameter that is the last string + -- currently allocated in the table. + + ------------------------------- + -- Add_String_To_Name_Buffer -- + ------------------------------- + + procedure Add_String_To_Name_Buffer (S : String_Id) is + Len : constant Natural := Natural (String_Length (S)); + + begin + for J in 1 .. Len loop + Name_Buffer (Name_Len + J) := + Get_Character (Get_String_Char (S, Int (J))); + end loop; + + Name_Len := Name_Len + Len; + end Add_String_To_Name_Buffer; + + ---------------- + -- End_String -- + ---------------- + + function End_String return String_Id is + begin + return Strings.Last; + end End_String; + + --------------------- + -- Get_String_Char -- + --------------------- + + function Get_String_Char (Id : String_Id; Index : Int) return Char_Code is + begin + pragma Assert (Id in First_String_Id .. Strings.Last + and then Index in 1 .. Strings.Table (Id).Length); + + return String_Chars.Table (Strings.Table (Id).String_Index + Index - 1); + end Get_String_Char; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + String_Chars.Init; + Strings.Init; + end Initialize; + + ---------- + -- Lock -- + ---------- + + procedure Lock is + begin + String_Chars.Locked := True; + Strings.Locked := True; + String_Chars.Release; + Strings.Release; + end Lock; + + ------------------ + -- Start_String -- + ------------------ + + -- Version to start completely new string + + procedure Start_String is + begin + Strings.Append ((String_Index => String_Chars.Last + 1, Length => 0)); + end Start_String; + + -- Version to start from initially stored string + + procedure Start_String (S : String_Id) is + begin + Strings.Increment_Last; + + -- Case of initial string value is at the end of the string characters + -- table, so it does not need copying, instead it can be shared. + + if Strings.Table (S).String_Index + Strings.Table (S).Length = + String_Chars.Last + 1 + then + Strings.Table (Strings.Last).String_Index := + Strings.Table (S).String_Index; + + -- Case of initial string value must be copied to new string + + else + Strings.Table (Strings.Last).String_Index := + String_Chars.Last + 1; + + for J in 1 .. Strings.Table (S).Length loop + String_Chars.Append + (String_Chars.Table (Strings.Table (S).String_Index + (J - 1))); + end loop; + end if; + + -- In either case the result string length is copied from the argument + + Strings.Table (Strings.Last).Length := Strings.Table (S).Length; + end Start_String; + + ----------------------- + -- Store_String_Char -- + ----------------------- + + procedure Store_String_Char (C : Char_Code) is + begin + String_Chars.Append (C); + Strings.Table (Strings.Last).Length := + Strings.Table (Strings.Last).Length + 1; + end Store_String_Char; + + procedure Store_String_Char (C : Character) is + begin + Store_String_Char (Get_Char_Code (C)); + end Store_String_Char; + + ------------------------ + -- Store_String_Chars -- + ------------------------ + + procedure Store_String_Chars (S : String) is + begin + for J in S'First .. S'Last loop + Store_String_Char (Get_Char_Code (S (J))); + end loop; + end Store_String_Chars; + + procedure Store_String_Chars (S : String_Id) is + + -- We are essentially doing this: + + -- for J in 1 .. String_Length (S) loop + -- Store_String_Char (Get_String_Char (S, J)); + -- end loop; + + -- but when the string is long it's more efficient to grow the + -- String_Chars table all at once. + + S_First : constant Int := Strings.Table (S).String_Index; + S_Len : constant Int := String_Length (S); + Old_Last : constant Int := String_Chars.Last; + New_Last : constant Int := Old_Last + S_Len; + + begin + String_Chars.Set_Last (New_Last); + String_Chars.Table (Old_Last + 1 .. New_Last) := + String_Chars.Table (S_First .. S_First + S_Len - 1); + Strings.Table (Strings.Last).Length := + Strings.Table (Strings.Last).Length + S_Len; + end Store_String_Chars; + + ---------------------- + -- Store_String_Int -- + ---------------------- + + procedure Store_String_Int (N : Int) is + begin + if N < 0 then + Store_String_Char ('-'); + Store_String_Int (-N); + + else + if N > 9 then + Store_String_Int (N / 10); + end if; + + Store_String_Char (Character'Val (Character'Pos ('0') + N mod 10)); + end if; + end Store_String_Int; + + -------------------------- + -- String_Chars_Address -- + -------------------------- + + function String_Chars_Address return System.Address is + begin + return String_Chars.Table (0)'Address; + end String_Chars_Address; + + ------------------ + -- String_Equal -- + ------------------ + + function String_Equal (L, R : String_Id) return Boolean is + Len : constant Nat := Strings.Table (L).Length; + + begin + if Len /= Strings.Table (R).Length then + return False; + else + for J in 1 .. Len loop + if Get_String_Char (L, J) /= Get_String_Char (R, J) then + return False; + end if; + end loop; + + return True; + end if; + end String_Equal; + + ----------------------------- + -- String_From_Name_Buffer -- + ----------------------------- + + function String_From_Name_Buffer return String_Id is + begin + Start_String; + + for J in 1 .. Name_Len loop + Store_String_Char (Get_Char_Code (Name_Buffer (J))); + end loop; + + return End_String; + end String_From_Name_Buffer; + + ------------------- + -- String_Length -- + ------------------- + + function String_Length (Id : String_Id) return Nat is + begin + return Strings.Table (Id).Length; + end String_Length; + + --------------------------- + -- String_To_Name_Buffer -- + --------------------------- + + procedure String_To_Name_Buffer (S : String_Id) is + begin + Name_Len := Natural (String_Length (S)); + + for J in 1 .. Name_Len loop + Name_Buffer (J) := + Get_Character (Get_String_Char (S, Int (J))); + end loop; + end String_To_Name_Buffer; + + --------------------- + -- Strings_Address -- + --------------------- + + function Strings_Address return System.Address is + begin + return Strings.Table (First_String_Id)'Address; + end Strings_Address; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + begin + String_Chars.Tree_Read; + Strings.Tree_Read; + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + begin + String_Chars.Tree_Write; + Strings.Tree_Write; + end Tree_Write; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock is + begin + String_Chars.Locked := False; + Strings.Locked := False; + end Unlock; + + ------------------------- + -- Unstore_String_Char -- + ------------------------- + + procedure Unstore_String_Char is + begin + String_Chars.Decrement_Last; + Strings.Table (Strings.Last).Length := + Strings.Table (Strings.Last).Length - 1; + end Unstore_String_Char; + + --------------------- + -- Write_Char_Code -- + --------------------- + + procedure Write_Char_Code (Code : Char_Code) is + + procedure Write_Hex_Byte (J : Char_Code); + -- Write single hex byte (value in range 0 .. 255) as two digits + + -------------------- + -- Write_Hex_Byte -- + -------------------- + + procedure Write_Hex_Byte (J : Char_Code) is + Hexd : constant array (Char_Code range 0 .. 15) of Character := + "0123456789abcdef"; + begin + Write_Char (Hexd (J / 16)); + Write_Char (Hexd (J mod 16)); + end Write_Hex_Byte; + + -- Start of processing for Write_Char_Code + + begin + if Code in 16#20# .. 16#7E# then + Write_Char (Character'Val (Code)); + + else + Write_Char ('['); + Write_Char ('"'); + + if Code > 16#FF_FFFF# then + Write_Hex_Byte (Code / 2 ** 24); + end if; + + if Code > 16#FFFF# then + Write_Hex_Byte ((Code / 2 ** 16) mod 256); + end if; + + if Code > 16#FF# then + Write_Hex_Byte ((Code / 256) mod 256); + end if; + + Write_Hex_Byte (Code mod 256); + Write_Char ('"'); + Write_Char (']'); + end if; + end Write_Char_Code; + + ------------------------------ + -- Write_String_Table_Entry -- + ------------------------------ + + procedure Write_String_Table_Entry (Id : String_Id) is + C : Char_Code; + + begin + if Id = No_String then + Write_Str ("no string"); + + else + Write_Char ('"'); + + for J in 1 .. String_Length (Id) loop + C := Get_String_Char (Id, J); + + if C = Character'Pos ('"') then + Write_Str (""""""); + else + Write_Char_Code (C); + end if; + + -- If string is very long, quit + + if J >= 1000 then -- arbitrary limit + Write_Str ("""...etc (length = "); + Write_Int (String_Length (Id)); + Write_Str (")"); + return; + end if; + end loop; + + Write_Char ('"'); + end if; + end Write_String_Table_Entry; + +end Stringt; diff --git a/gcc/ada/stringt.ads b/gcc/ada/stringt.ads new file mode 100644 index 000000000..7a84a324b --- /dev/null +++ b/gcc/ada/stringt.ads @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S T R I N G 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. -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; +with Types; use Types; + +package Stringt is + +-- This package contains routines for handling the strings table which is +-- used to store string constants encountered in the source, and also those +-- additional string constants generated by compile time concatenation and +-- other similar processing. + +-- A string constant in this table consists of a series of Char_Code values, +-- so that 16-bit character codes can be properly handled if this feature +-- is implemented in the scanner. + +-- There is no guarantee that hashing is used in the implementation, although +-- it maybe. This means that the caller cannot count on having the same Id +-- value for two identical strings stored separately and also cannot count on +-- the two Id values being different. + + -------------------------------------- + -- String Table Access Subprograms -- + -------------------------------------- + + procedure Initialize; + -- Initializes the strings table for a new compilation. Note that + -- Initialize must not be called if Tree_Read is used. + + procedure Lock; + -- Lock internal tables before calling back end + + procedure Unlock; + -- Unlock internal tables, in case back end needs to modify them + + procedure Start_String; + -- Sets up for storing a new string in the table. To store a string, a + -- call is first made to Start_String, then successive calls are + -- made to Store_String_Character to store the characters of the string. + -- Finally, a call to End_String terminates the entry and returns it Id. + + procedure Start_String (S : String_Id); + -- Like Start_String with no parameter, except that the contents of the + -- new string is initialized to be a copy of the given string. A test is + -- made to see if S is the last created string, and if so it is shared, + -- rather than copied, this can be particularly helpful for the case of + -- a continued concatenation of string constants. + + procedure Store_String_Char (C : Char_Code); + procedure Store_String_Char (C : Character); + -- Store next character of string, see description above for Start_String + + procedure Store_String_Chars (S : String); + procedure Store_String_Chars (S : String_Id); + -- Store character codes of given string in sequence + + procedure Store_String_Int (N : Int); + -- Stored decimal representation of integer with possible leading minus + + procedure Unstore_String_Char; + -- Undoes effect of previous Store_String_Char call, used in some error + -- situations of unterminated string constants. + + function End_String return String_Id; + -- Terminates current string and returns its Id + + function String_Length (Id : String_Id) return Nat; + -- Returns length of previously stored string + + function Get_String_Char (Id : String_Id; Index : Int) return Char_Code; + pragma Inline (Get_String_Char); + -- Obtains the specified character from a stored string. The lower bound + -- of stored strings is always 1, so the range is 1 .. String_Length (Id). + + function String_Equal (L, R : String_Id) return Boolean; + -- Determines if two string literals represent the same string + + procedure String_To_Name_Buffer (S : String_Id); + -- Place characters of given string in Name_Buffer, setting Name_Len. + -- Error if any characters are out of Character range. Does not attempt + -- to do any encoding of any characters. + + procedure Add_String_To_Name_Buffer (S : String_Id); + -- Append characters of given string to Name_Buffer, updating Name_Len. + -- Error if any characters are out of Character range. Does not attempt + -- to do any encoding of any characters. + + function String_Chars_Address return System.Address; + -- Return address of String_Chars table (used by Back_End call to Gigi) + + function String_From_Name_Buffer return String_Id; + -- Given a name stored in Namet.Name_Buffer (length in Namet.Name_Len), + -- returns a string of the corresponding value. The value in Name_Buffer + -- is unchanged, and the cases of letters are unchanged. + + function Strings_Address return System.Address; + -- Return address of Strings table (used by Back_End call to Gigi) + + procedure Tree_Read; + -- Initializes internal tables from current tree file using the relevant + -- Table.Tree_Read routines. Note that Initialize should not be called if + -- Tree_Read is used. Tree_Read includes all necessary initialization. + + procedure Tree_Write; + -- Writes out internal tables to current tree file using the relevant + -- Table.Tree_Write routines. + + procedure Write_Char_Code (Code : Char_Code); + -- Procedure to write a character code value, used for debugging purposes + -- for writing character codes. If the character code is in the range + -- 16#20# .. 16#7E#, then the single graphic character corresponding to + -- the code is output. For any other codes in the range 16#00# .. 16#FF#, + -- the code is output as ["hh"] where hh is the two digit hex value for + -- the code. Codes greater than 16#FF# are output as ["hhhh"] where hhhh + -- is the four digit hex representation of the code value (high order + -- byte first). Hex letters are always in lower case. + + procedure Write_String_Table_Entry (Id : String_Id); + -- Writes a string value with enclosing quotes to the current file using + -- routines in package Output. Does not write an end of line character. + -- This procedure is used for debug output purposes, and also for output + -- of strings specified by pragma Linker Option to the ali file. 7-bit + -- ASCII graphics (except for double quote) are output literally. + -- The double quote appears as two successive double quotes. + -- All other codes, are output as described for Write_Char_Code. For + -- example, the string created by folding "A" & ASCII.HT & "Hello" will + -- print as "A["09"]Hello". A No_String value prints simply as "no string" + -- without surrounding quote marks. + +private + pragma Inline (End_String); + pragma Inline (String_Length); + +end Stringt; diff --git a/gcc/ada/stringt.h b/gcc/ada/stringt.h new file mode 100644 index 000000000..66ca4fb0f --- /dev/null +++ b/gcc/ada/stringt.h @@ -0,0 +1,86 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * S T R I N G T * + * * + * C Header File * + * * + * Copyright (C) 1992-2007, Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING3. If not, go to * + * http://www.gnu.org/licenses for a complete copy of the license. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* This file is the C file that corresponds to the Ada package spec + Stringt. It was created manually from stringt.ads and stringt.adb + + Note: only the access functions are provided, since the tree transformer + is not allowed to modify the tree or its auxiliary structures. + + This package contains routines for handling the strings table which is + used to store string constants encountered in the source, and also those + additional string constants generated by compile time concatenation and + other similar processing. + + A string constant in this table consists of a series of Char_Code values, + so that 16-bit character codes can be properly handled if this feature is + implemented in the scanner. + + There is no guarantee that hashing is used in the implementation. This + means that the caller cannot count on having the same Id value for two + identical strings stored separately. + + The String_Id values reference entries in the Strings table, which + contains String_Entry records that record the length of each stored string + and its starting location in the String_Chars table. */ + +struct String_Entry +{ + Int String_Index; + Int Length; +}; + +/* Pointer to string entry vector. This pointer is passed to the tree + transformer and stored in a global location. */ +extern struct String_Entry *Strings_Ptr; + +/* Pointer to name characters table. This pointer is passed to the tree + transformer and stored in a global location for access from here. The + String_Index values are subscripts into this array. */ +extern Char_Code *String_Chars_Ptr; + + +/* String_Length returns the length of the specified string. */ +INLINE Int String_Length (String_Id); + +INLINE Int +String_Length (String_Id Id) +{ + return Strings_Ptr[Id - First_String_Id].Length; +} + + +/* Get_String_Char obtains the specified character from a stored string. The + lower bound of stored strings is always 1, so the range of values is 1 to + String_Length (Id). */ +INLINE Char_Code Get_String_Char (String_Id, Int); + +INLINE Char_Code +Get_String_Char (String_Id Id, Int Index) +{ + return + String_Chars_Ptr + [Strings_Ptr[Id - First_String_Id].String_Index + Index - 1]; +} diff --git a/gcc/ada/style.adb b/gcc/ada/style.adb new file mode 100644 index 000000000..0f0ab300c --- /dev/null +++ b/gcc/ada/style.adb @@ -0,0 +1,266 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S T Y L E -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Casing; use Casing; +with Csets; use Csets; +with Einfo; use Einfo; +with Errout; use Errout; +with Namet; use Namet; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Stand; use Stand; +with Stylesw; use Stylesw; + +package body Style is + + ----------------------- + -- Body_With_No_Spec -- + ----------------------- + + -- If the check specs mode (-gnatys) is set, then all subprograms must + -- have specs unless they are parameterless procedures that are not child + -- units at the library level (i.e. they are possible main programs). + + procedure Body_With_No_Spec (N : Node_Id) is + begin + if Style_Check_Specs then + if Nkind (Parent (N)) = N_Compilation_Unit then + declare + Spec : constant Node_Id := Specification (N); + Defnm : constant Node_Id := Defining_Unit_Name (Spec); + + begin + if Nkind (Spec) = N_Procedure_Specification + and then Nkind (Defnm) = N_Defining_Identifier + and then No (First_Formal (Defnm)) + then + return; + end if; + end; + end if; + + Error_Msg_N ("(style) subprogram body has no previous spec", N); + end if; + end Body_With_No_Spec; + + --------------------------------- + -- Check_Array_Attribute_Index -- + --------------------------------- + + procedure Check_Array_Attribute_Index + (N : Node_Id; + E1 : Node_Id; + D : Int) + is + begin + if Style_Check_Array_Attribute_Index then + if D = 1 and then Present (E1) then + Error_Msg_N -- CODEFIX + ("(style) index number not allowed for one dimensional array", + E1); + elsif D > 1 and then No (E1) then + Error_Msg_N -- CODEFIX + ("(style) index number required for multi-dimensional array", + N); + end if; + end if; + end Check_Array_Attribute_Index; + + ---------------------- + -- Check_Identifier -- + ---------------------- + + -- In check references mode (-gnatyr), identifier uses must be cased + -- the same way as the corresponding identifier declaration. + + procedure Check_Identifier + (Ref : Node_Or_Entity_Id; + Def : Node_Or_Entity_Id) + is + Sref : Source_Ptr := Sloc (Ref); + Sdef : Source_Ptr := Sloc (Def); + Tref : Source_Buffer_Ptr; + Tdef : Source_Buffer_Ptr; + Nlen : Nat; + Cas : Casing_Type; + + begin + -- If reference does not come from source, nothing to check + + if not Comes_From_Source (Ref) then + return; + + -- If previous error on either node/entity, ignore + + elsif Error_Posted (Ref) or else Error_Posted (Def) then + return; + + -- Case of definition comes from source + + elsif Comes_From_Source (Def) then + + -- Check same casing if we are checking references + + if Style_Check_References then + Tref := Source_Text (Get_Source_File_Index (Sref)); + Tdef := Source_Text (Get_Source_File_Index (Sdef)); + + -- Ignore operator name case completely. This also catches the + -- case of where one is an operator and the other is not. This + -- is a phenomenon from rewriting of operators as functions, + -- and is to be ignored. + + if Tref (Sref) = '"' or else Tdef (Sdef) = '"' then + return; + + else + while Tref (Sref) = Tdef (Sdef) loop + + -- If end of identifier, all done + + if not Identifier_Char (Tref (Sref)) then + return; + + -- Otherwise loop continues + + else + Sref := Sref + 1; + Sdef := Sdef + 1; + end if; + end loop; + + -- Fall through loop when mismatch between identifiers + -- If either identifier is not terminated, error. + + if Identifier_Char (Tref (Sref)) + or else + Identifier_Char (Tdef (Sdef)) + then + Error_Msg_Node_1 := Def; + Error_Msg_Sloc := Sloc (Def); + Error_Msg -- CODEFIX + ("(style) bad casing of & declared#", Sref); + return; + + -- Else end of identifiers, and they match + + else + return; + end if; + end if; + end if; + + -- Case of definition in package Standard + + elsif Sdef = Standard_Location + or else + Sdef = Standard_ASCII_Location + then + -- Check case of identifiers in Standard + + if Style_Check_Standard then + Tref := Source_Text (Get_Source_File_Index (Sref)); + + -- Ignore operators + + if Tref (Sref) = '"' then + null; + + -- Otherwise determine required casing of Standard entity + + else + -- ASCII is all upper case + + if Entity (Ref) = Standard_ASCII then + Cas := All_Upper_Case; + + -- Special names in ASCII are also all upper case + + elsif Sdef = Standard_ASCII_Location then + Cas := All_Upper_Case; + + -- All other entities are in mixed case + + else + Cas := Mixed_Case; + end if; + + Nlen := Length_Of_Name (Chars (Ref)); + + -- Now check if we have the right casing + + if Determine_Casing + (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1)) = Cas + then + null; + else + Name_Len := Integer (Nlen); + Name_Buffer (1 .. Name_Len) := + String (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1)); + Set_Casing (Cas); + Error_Msg_Name_1 := Name_Enter; + Error_Msg_N -- CODEFIX + ("(style) bad casing of %% declared in Standard", Ref); + end if; + end if; + end if; + end if; + end Check_Identifier; + + ------------------------ + -- Missing_Overriding -- + ------------------------ + + procedure Missing_Overriding (N : Node_Id; E : Entity_Id) is + begin + -- Note that Error_Msg_NE, which would be more natural to use here, + -- is not visible from this generic unit ??? + + Error_Msg_Name_1 := Chars (E); + + if Style_Check_Missing_Overriding and then Comes_From_Source (N) then + if Nkind (N) = N_Subprogram_Body then + Error_Msg_N -- CODEFIX + ("(style) missing OVERRIDING indicator in body of%", N); + else + Error_Msg_N -- CODEFIX + ("(style) missing OVERRIDING indicator in declaration of%", N); + end if; + end if; + end Missing_Overriding; + + ----------------------------------- + -- Subprogram_Not_In_Alpha_Order -- + ----------------------------------- + + procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id) is + begin + if Style_Check_Order_Subprograms then + Error_Msg_N -- CODEFIX + ("(style) subprogram body& not in alphabetical order", Name); + end if; + end Subprogram_Not_In_Alpha_Order; +end Style; diff --git a/gcc/ada/style.ads b/gcc/ada/style.ads new file mode 100644 index 000000000..9f9f32a93 --- /dev/null +++ b/gcc/ada/style.ads @@ -0,0 +1,217 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S T Y L E -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package collects all the routines used for style checking in the +-- compiler, as activated by the relevant command line option. These are +-- gathered in a separate package so that they can more easily be customized. +-- Calls to these subprograms are only made if Opt.Style_Check is set True. + +with Errout; +with Styleg; +with Types; use Types; + +package Style is + + procedure Body_With_No_Spec (N : Node_Id); + -- Called where N is a subprogram body node for a subprogram body + -- for which no spec was given, i.e. a body acting as its own spec. + + procedure Check_Array_Attribute_Index + (N : Node_Id; + E1 : Node_Id; + D : Int); + -- Called for an array attribute specifying an index number. N is the + -- node for the attribute, and E1 is the index expression (Empty if none + -- present). If E1 is present, it is known to be a static integer. D is + -- the number of dimensions of the array. + + procedure Check_Identifier + (Ref : Node_Or_Entity_Id; + Def : Node_Or_Entity_Id); + -- Check style of identifier occurrence. Ref is an N_Identifier node whose + -- spelling is to be checked against the Chars spelling in identifier node + -- Def (which may be either an N_Identifier, or N_Defining_Identifier node) + + procedure Missing_Overriding (N : Node_Id; E : Entity_Id); + -- Called where N is the declaration or body of an overriding operation, + -- and the node does not have an overriding_indicator. + + procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id); + -- Called if Name is the name of a subprogram body in a package body + -- that is not in alphabetical order. + + -- Remaining style routines come from instantiation of Styleg + + package Style_Inst is new Styleg + (Errout.Error_Msg, + Errout.Error_Msg_S, + Errout.Error_Msg_SC, + Errout.Error_Msg_SP); + -- Instantiation of Styleg for compiler use + + procedure Check_Abs_Not + renames Style_Inst.Check_Abs_Not; + -- Called after scanning an ABS or NOT operator to check spacing + + procedure Check_Apostrophe + renames Style_Inst.Check_Apostrophe; + -- Called after scanning an apostrophe to check spacing + + procedure Check_Arrow + renames Style_Inst.Check_Arrow; + -- Called after scanning out an arrow to check spacing + + procedure Check_Attribute_Name (Reserved : Boolean) + renames Style_Inst.Check_Attribute_Name; + -- The current token is an attribute designator. Check that it is + -- capitalized in an appropriate manner. Reserved is set if the attribute + -- designator is a reserved word (access, digits, delta or range) to allow + -- differing rules for the two cases. + + procedure Check_Boolean_Operator (Node : Node_Id) + renames Style_Inst.Check_Boolean_Operator; + -- Called after resolving AND or OR node to check short circuit rules + + procedure Check_Box + renames Style_Inst.Check_Box; + -- Called after scanning out a box to check spacing + + procedure Check_Binary_Operator + renames Style_Inst.Check_Binary_Operator; + -- Called after scanning out a binary operator other than a plus, minus + -- or exponentiation operator. Intended for checking spacing rules. + + procedure Check_Exponentiation_Operator + renames Style_Inst.Check_Exponentiation_Operator; + -- Called after scanning out an exponentiation operator. Intended for + -- checking spacing rules. + + procedure Check_Colon + renames Style_Inst.Check_Colon; + -- Called after scanning out colon to check spacing + + procedure Check_Colon_Equal + renames Style_Inst.Check_Colon_Equal; + -- Called after scanning out colon equal to check spacing + + procedure Check_Comma + renames Style_Inst.Check_Comma; + -- Called after scanning out comma to check spacing + + procedure Check_Comment + renames Style_Inst.Check_Comment; + -- Called with Scan_Ptr pointing to the first minus sign of a comment. + -- Intended for checking any specific rules for comment placement/format. + + procedure Check_Dot_Dot + renames Style_Inst.Check_Dot_Dot; + -- Called after scanning out dot dot to check spacing + + procedure Check_EOF + renames Style_Inst.Check_EOF; + -- Called after scanning out end of file mark + + procedure Check_HT + renames Style_Inst.Check_HT; + -- Called with Scan_Ptr pointing to a horizontal tab character + + procedure Check_Indentation + renames Style_Inst.Check_Indentation; + -- Called at the start of a new statement or declaration, with Token_Ptr + -- pointing to the first token of the statement or declaration. The check + -- is that the starting column is appropriate to the indentation rules if + -- Token_Ptr is the first token on the line. + + procedure Check_Left_Paren + renames Style_Inst.Check_Left_Paren; + -- Called after scanning out a left parenthesis to check spacing + + procedure Check_Line_Terminator (Len : Int) + renames Style_Inst.Check_Line_Terminator; + -- Called with Scan_Ptr pointing to the first line terminator terminating + -- the current line, used to check for appropriate line terminator and to + -- check the line length (Len is the length of the current line). Note that + -- the terminator may be the EOF character. + + procedure Check_Pragma_Name + renames Style_Inst.Check_Pragma_Name; + -- The current token is a pragma identifier. Check that it is spelled + -- properly (i.e. with an appropriate casing convention). + + procedure Check_Right_Paren + renames Style_Inst.Check_Right_Paren; + -- Called after scanning out a right parenthesis to check spacing + + procedure Check_Semicolon + renames Style_Inst.Check_Semicolon; + -- Called after scanning out a semicolon to check spacing + + procedure Check_Then (If_Loc : Source_Ptr) + renames Style_Inst.Check_Then; + -- Called to check that THEN and IF keywords are appropriately positioned. + -- The parameters show the first characters of the two keywords. This + -- procedure is called only if THEN appears at the start of a line with + -- Token_Ptr pointing to the THEN keyword. + + procedure Check_Unary_Plus_Or_Minus + renames Style_Inst.Check_Unary_Plus_Or_Minus; + -- Called after scanning a unary plus or minus to check spacing + + procedure Check_Vertical_Bar + renames Style_Inst.Check_Vertical_Bar; + -- Called after scanning a vertical bar to check spacing + + procedure Check_Xtra_Parens (Loc : Source_Ptr) + renames Style_Inst.Check_Xtra_Parens; + -- Called after scanning a conditional expression that has at least one + -- level of parentheses around the entire expression. + + function Mode_In_Check return Boolean + renames Style_Inst.Mode_In_Check; + -- Determines whether style checking is active and the Mode_In_Check is + -- set, forbidding the explicit use of mode IN. + + procedure No_End_Name (Name : Node_Id) + renames Style_Inst.No_End_Name; + -- Called if an END is encountered where a name is allowed but not present. + -- The parameter is the node whose name is the name that is permitted in + -- the END line, and the scan pointer is positioned so that if an error + -- message is to be generated in this situation, it should be generated + -- using Error_Msg_SP. + + procedure No_Exit_Name (Name : Node_Id) + renames Style_Inst.No_Exit_Name; + -- Called when exiting a named loop, but a name is not present on the EXIT. + -- The parameter is the node whose name should have followed EXIT, and the + -- scan pointer is positioned so that if an error message is to be + -- generated, it should be generated using Error_Msg_SP. + + procedure Non_Lower_Case_Keyword + renames Style_Inst.Non_Lower_Case_Keyword; + -- Called if a reserved keyword is scanned which is not spelled in all + -- lower case letters. On entry Token_Ptr points to the keyword token. + -- This is not used for keywords appearing as attribute designators, + -- where instead Check_Attribute_Name (True) is called. +end Style; diff --git a/gcc/ada/styleg.adb b/gcc/ada/styleg.adb new file mode 100644 index 000000000..fd6cbae7e --- /dev/null +++ b/gcc/ada/styleg.adb @@ -0,0 +1,1114 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S T Y L E G -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 Style package implements the standard GNAT style +-- checking rules. For documentation of these rules, see comments on the +-- individual procedures. + +with Atree; use Atree; +with Casing; use Casing; +with Csets; use Csets; +with Einfo; use Einfo; +with Err_Vars; use Err_Vars; +with Opt; use Opt; +with Scans; use Scans; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Stylesw; use Stylesw; + +package body Styleg is + + use ASCII; + + Blank_Lines : Nat := 0; + -- Counts number of empty lines seen. Reset to zero if a non-empty line + -- is encountered. Used to check for trailing blank lines in Check_EOF, + -- and for multiple blank lines. + + Blank_Line_Location : Source_Ptr; + -- Remembers location of first blank line in a series. Used to issue an + -- appropriate diagnostic if subsequent blank lines or the end of file + -- is encountered. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Check_No_Space_After; + -- Checks that there is a non-white space character after the current + -- token, or white space followed by a comment, or the end of line. + -- Issue error message if not. + + procedure Check_No_Space_Before; + -- Check that token is first token on line, or else is not preceded + -- by white space. Signal error of space not allowed if not. + + procedure Check_Separate_Stmt_Lines_Cont; + -- Non-inlined continuation of Check_Separate_Stmt_Lines + + function Determine_Token_Casing return Casing_Type; + -- Determine casing of current token + + procedure Error_Space_Not_Allowed (S : Source_Ptr); + -- Posts an error message indicating that a space is not allowed + -- at the given source location. + + procedure Error_Space_Required (S : Source_Ptr); + -- Posts an error message indicating that a space is required at + -- the given source location. + + function Is_White_Space (C : Character) return Boolean; + pragma Inline (Is_White_Space); + -- Returns True for space, HT, VT or FF, False otherwise + + procedure Require_Following_Space; + pragma Inline (Require_Following_Space); + -- Require token to be followed by white space. Used only if in GNAT + -- style checking mode. + + procedure Require_Preceding_Space; + pragma Inline (Require_Preceding_Space); + -- Require token to be preceded by white space. Used only if in GNAT + -- style checking mode. + + ---------------------- + -- Check_Abs_Or_Not -- + ---------------------- + + -- In check tokens mode (-gnatyt), ABS/NOT must be followed by a space + + procedure Check_Abs_Not is + begin + if Style_Check_Tokens then + if Source (Scan_Ptr) > ' ' then + Error_Space_Required (Scan_Ptr); + end if; + end if; + end Check_Abs_Not; + + ---------------------- + -- Check_Apostrophe -- + ---------------------- + + -- Do not allow space before or after apostrophe + + procedure Check_Apostrophe is + begin + if Style_Check_Tokens then + Check_No_Space_After; + end if; + end Check_Apostrophe; + + ----------------- + -- Check_Arrow -- + ----------------- + + -- In check tokens mode (-gnatys), arrow must be surrounded by spaces + + procedure Check_Arrow is + begin + if Style_Check_Tokens then + Require_Preceding_Space; + Require_Following_Space; + end if; + end Check_Arrow; + + -------------------------- + -- Check_Attribute_Name -- + -------------------------- + + -- In check attribute casing mode (-gnatya), attribute names must be + -- mixed case, i.e. start with an upper case letter, and otherwise + -- lower case, except after an underline character. + + procedure Check_Attribute_Name (Reserved : Boolean) is + pragma Warnings (Off, Reserved); + begin + if Style_Check_Attribute_Casing then + if Determine_Token_Casing /= Mixed_Case then + Error_Msg_SC -- CODEFIX + ("(style) bad capitalization, mixed case required"); + end if; + end if; + end Check_Attribute_Name; + + --------------------------- + -- Check_Binary_Operator -- + --------------------------- + + -- In check token mode (-gnatyt), binary operators other than the special + -- case of exponentiation require surrounding space characters. + + procedure Check_Binary_Operator is + begin + if Style_Check_Tokens then + Require_Preceding_Space; + Require_Following_Space; + end if; + end Check_Binary_Operator; + + ---------------------------- + -- Check_Boolean_Operator -- + ---------------------------- + + procedure Check_Boolean_Operator (Node : Node_Id) is + + function OK_Boolean_Operand (N : Node_Id) return Boolean; + -- Returns True for simple variable, or "not X1" or "X1 and X2" or + -- "X1 or X2" where X1, X2 are recursively OK_Boolean_Operand's. + + ------------------------ + -- OK_Boolean_Operand -- + ------------------------ + + function OK_Boolean_Operand (N : Node_Id) return Boolean is + begin + if Nkind_In (N, N_Identifier, N_Expanded_Name) then + return True; + + elsif Nkind (N) = N_Op_Not then + return OK_Boolean_Operand (Original_Node (Right_Opnd (N))); + + elsif Nkind_In (N, N_Op_And, N_Op_Or) then + return OK_Boolean_Operand (Original_Node (Left_Opnd (N))) + and then + OK_Boolean_Operand (Original_Node (Right_Opnd (N))); + + else + return False; + end if; + end OK_Boolean_Operand; + + -- Start of processing for Check_Boolean_Operator + + begin + if Style_Check_Boolean_And_Or + and then Comes_From_Source (Node) + then + declare + Orig : constant Node_Id := Original_Node (Node); + + begin + if Nkind_In (Orig, N_Op_And, N_Op_Or) then + declare + L : constant Node_Id := Original_Node (Left_Opnd (Orig)); + R : constant Node_Id := Original_Node (Right_Opnd (Orig)); + + begin + -- First OK case, simple boolean constants/identifiers + + if OK_Boolean_Operand (L) + and then + OK_Boolean_Operand (R) + then + return; + + -- Second OK case, modular types + + elsif Is_Modular_Integer_Type (Etype (Node)) then + return; + + -- Third OK case, array types + + elsif Is_Array_Type (Etype (Node)) then + return; + + -- Otherwise we have an error + + elsif Nkind (Orig) = N_Op_And then + Error_Msg -- CODEFIX + ("(style) `AND THEN` required", Sloc (Orig)); + else + Error_Msg -- CODEFIX + ("(style) `OR ELSE` required", Sloc (Orig)); + end if; + end; + end if; + end; + end if; + end Check_Boolean_Operator; + + --------------- + -- Check_Box -- + --------------- + + -- In check token mode (-gnatyt), box must be preceded by a space or by + -- a left parenthesis. Spacing checking on the surrounding tokens takes + -- care of the remaining checks. + + procedure Check_Box is + begin + if Style_Check_Tokens then + if Prev_Token /= Tok_Left_Paren then + Require_Preceding_Space; + end if; + end if; + end Check_Box; + + ----------------- + -- Check_Colon -- + ----------------- + + -- In check token mode (-gnatyt), colon must be surrounded by spaces + + procedure Check_Colon is + begin + if Style_Check_Tokens then + Require_Preceding_Space; + Require_Following_Space; + end if; + end Check_Colon; + + ----------------------- + -- Check_Colon_Equal -- + ----------------------- + + -- In check token mode (-gnatyt), := must be surrounded by spaces + + procedure Check_Colon_Equal is + begin + if Style_Check_Tokens then + Require_Preceding_Space; + Require_Following_Space; + end if; + end Check_Colon_Equal; + + ----------------- + -- Check_Comma -- + ----------------- + + -- In check token mode (-gnatyt), comma must be either the first + -- token on a line, or be preceded by a non-blank character. + -- It must also always be followed by a blank. + + procedure Check_Comma is + begin + if Style_Check_Tokens then + Check_No_Space_Before; + + if Source (Scan_Ptr) > ' ' then + Error_Space_Required (Scan_Ptr); + end if; + end if; + end Check_Comma; + + ------------------- + -- Check_Comment -- + ------------------- + + -- In check comment mode (-gnatyc) there are several requirements on the + -- format of comments. The following are permissible comment formats: + + -- 1. Any comment that is not at the start of a line, i.e. where the + -- initial minuses are not the first non-blank characters on the + -- line must have at least one blank after the second minus or a + -- special character as defined in rule 5. + + -- 2. A row of all minuses of any length is permitted (see procedure + -- box above in the source of this routine). + + -- 3. A comment line starting with two minuses and a space, and ending + -- with a space and two minuses. Again see the procedure title box + -- immediately above in the source. + + -- 4. A full line comment where two spaces follow the two minus signs. + -- This is the normal comment format in GNAT style, as typified by + -- the comments you are reading now. + + -- 5. A full line comment where the first character after the second + -- minus is a special character, i.e. a character in the ASCII + -- range 16#21#..16#2F# or 16#3A#..16#3F#. This allows special + -- comments, such as those generated by gnatprep, or those that + -- appear in the SPARK annotation language to be accepted. + + -- Note: for GNAT internal files (-gnatg switch set on for the + -- compilation), the only special sequence recognized and allowed + -- is --! as generated by gnatprep. + + -- 6. In addition, the comment must be properly indented if comment + -- indentation checking is active (Style_Check_Indentation non-zero). + -- Either the start column must be a multiple of this indentation, + -- or the indentation must match that of the next non-blank line. + + procedure Check_Comment is + S : Source_Ptr; + C : Character; + + function Is_Box_Comment return Boolean; + -- Returns True if the last two characters on the line are -- which + -- characterizes a box comment (as for example follows this spec). + + function Is_Special_Character (C : Character) return Boolean; + -- Determines if C is a special character (see rule 5 above) + + function Same_Column_As_Next_Non_Blank_Line return Boolean; + -- Called for a full line comment. If the indentation of this comment + -- matches that of the next non-blank line in the source, then True is + -- returned, otherwise False. + + -------------------- + -- Is_Box_Comment -- + -------------------- + + function Is_Box_Comment return Boolean is + S : Source_Ptr; + + begin + -- Do we need to worry about UTF_32 line terminators here ??? + + S := Scan_Ptr + 3; + while Source (S) not in Line_Terminator loop + S := S + 1; + end loop; + + return Source (S - 1) = '-' and then Source (S - 2) = '-'; + end Is_Box_Comment; + + -------------------------- + -- Is_Special_Character -- + -------------------------- + + function Is_Special_Character (C : Character) return Boolean is + begin + if GNAT_Mode then + return C = '!'; + else + return + Character'Pos (C) in 16#21# .. 16#2F# + or else + Character'Pos (C) in 16#3A# .. 16#3F#; + end if; + end Is_Special_Character; + + ---------------------------------------- + -- Same_Column_As_Next_Non_Blank_Line -- + ---------------------------------------- + + function Same_Column_As_Next_Non_Blank_Line return Boolean is + P : Source_Ptr; + + begin + -- Step to end of line + + P := Scan_Ptr + 2; + while Source (P) not in Line_Terminator loop + P := P + 1; + end loop; + + -- Step past blanks, and line terminators (UTF_32 case???) + + while Source (P) <= ' ' and then Source (P) /= EOF loop + P := P + 1; + end loop; + + -- Compare columns + + return Get_Column_Number (Scan_Ptr) = Get_Column_Number (P); + end Same_Column_As_Next_Non_Blank_Line; + + -- Start of processing for Check_Comment + + begin + -- Can never have a non-blank character preceding the first minus + + if Style_Check_Comments then + if Scan_Ptr > Source_First (Current_Source_File) + and then Source (Scan_Ptr - 1) > ' ' + then + Error_Msg_S -- CODEFIX + ("(style) space required"); + end if; + end if; + + -- For a comment that is not at the start of the line, the only + -- requirement is that we cannot have a non-blank character after + -- the second minus sign or a special character. + + if Scan_Ptr /= First_Non_Blank_Location then + if Style_Check_Comments then + if Source (Scan_Ptr + 2) > ' ' + and then not Is_Special_Character (Source (Scan_Ptr + 2)) + then + Error_Msg -- CODEFIX + ("(style) space required", Scan_Ptr + 2); + end if; + end if; + + return; + + -- Case of a comment that is at the start of a line + + else + -- First check, must be in appropriately indented column + + if Style_Check_Indentation /= 0 then + if Start_Column rem Style_Check_Indentation /= 0 then + if not Same_Column_As_Next_Non_Blank_Line then + Error_Msg_S -- CODEFIX + ("(style) bad column"); + end if; + + return; + end if; + end if; + + -- If we are not checking comments, nothing more to do + + if not Style_Check_Comments then + return; + end if; + + -- Case of not followed by a blank. Usually wrong, but there are + -- some exceptions that we permit. + + if Source (Scan_Ptr + 2) /= ' ' then + C := Source (Scan_Ptr + 2); + + -- Case of -- all on its own on a line is OK + + if C < ' ' then + return; + end if; + + -- Case of --x, x special character is OK (gnatprep/SPARK/etc.) + -- This is not permitted in internal GNAT implementation units + -- except for the case of --! as used by gnatprep output. + + if Is_Special_Character (C) then + return; + end if; + + -- The only other case in which we allow a character after + -- the -- other than a space is when we have a row of minus + -- signs (case of header lines for a box comment for example). + + S := Scan_Ptr + 2; + while Source (S) >= ' ' loop + if Source (S) /= '-' then + if Is_Box_Comment then + Error_Space_Required (Scan_Ptr + 2); + else + Error_Msg -- CODEFIX + ("(style) two spaces required", Scan_Ptr + 2); + end if; + + return; + end if; + + S := S + 1; + end loop; + + -- If we are followed by a blank, then the comment is OK if the + -- character following this blank is another blank or a format + -- effector. + + elsif Source (Scan_Ptr + 3) <= ' ' then + return; + + -- Here is the case where we only have one blank after the two + -- minus signs, which is an error unless the line ends with two + -- minus signs, the case of a box comment. + + elsif not Is_Box_Comment then + Error_Space_Required (Scan_Ptr + 3); + end if; + end if; + end Check_Comment; + + ------------------- + -- Check_Dot_Dot -- + ------------------- + + -- In check token mode (-gnatyt), colon must be surrounded by spaces + + procedure Check_Dot_Dot is + begin + if Style_Check_Tokens then + Require_Preceding_Space; + Require_Following_Space; + end if; + end Check_Dot_Dot; + + --------------- + -- Check_EOF -- + --------------- + + -- In check blanks at end mode, check no blank lines precede the EOF + + procedure Check_EOF is + begin + if Style_Check_Blank_Lines then + + -- We expect one blank line, from the EOF, but no more than one + + if Blank_Lines = 2 then + Error_Msg -- CODEFIX + ("(style) blank line not allowed at end of file", + Blank_Line_Location); + + elsif Blank_Lines >= 3 then + Error_Msg -- CODEFIX + ("(style) blank lines not allowed at end of file", + Blank_Line_Location); + end if; + end if; + end Check_EOF; + + ----------------------------------- + -- Check_Exponentiation_Operator -- + ----------------------------------- + + -- No spaces are required for the ** operator in GNAT style check mode + + procedure Check_Exponentiation_Operator is + begin + null; + end Check_Exponentiation_Operator; + + -------------- + -- Check_HT -- + -------------- + + -- In check horizontal tab mode (-gnatyh), tab characters are not allowed + + procedure Check_HT is + begin + if Style_Check_Horizontal_Tabs then + Error_Msg_S -- CODEFIX + ("(style) horizontal tab not allowed"); + end if; + end Check_HT; + + ----------------------- + -- Check_Indentation -- + ----------------------- + + -- In check indentation mode (-gnatyn for n a digit), a new statement or + -- declaration is required to start in a column that is a multiple of the + -- indentation amount. + + procedure Check_Indentation is + begin + if Style_Check_Indentation /= 0 then + if Token_Ptr = First_Non_Blank_Location + and then Start_Column rem Style_Check_Indentation /= 0 + then + Error_Msg_SC -- CODEFIX + ("(style) bad indentation"); + end if; + end if; + end Check_Indentation; + + ---------------------- + -- Check_Left_Paren -- + ---------------------- + + -- In tone check mode (-gnatyt), left paren must not be preceded by an + -- identifier character or digit (a separating space is required) and + -- may never be followed by a space. + + procedure Check_Left_Paren is + begin + if Style_Check_Tokens then + if Token_Ptr > Source_First (Current_Source_File) + and then Identifier_Char (Source (Token_Ptr - 1)) + then + Error_Space_Required (Token_Ptr); + end if; + + Check_No_Space_After; + end if; + end Check_Left_Paren; + + --------------------------- + -- Check_Line_Max_Length -- + --------------------------- + + -- In check max line length mode (-gnatym), the line length must + -- not exceed the permitted maximum value. + + procedure Check_Line_Max_Length (Len : Int) is + begin + if Style_Check_Max_Line_Length then + if Len > Style_Max_Line_Length then + Error_Msg + ("(style) this line is too long", + Current_Line_Start + Source_Ptr (Style_Max_Line_Length)); + end if; + end if; + end Check_Line_Max_Length; + + --------------------------- + -- Check_Line_Terminator -- + --------------------------- + + -- In check blanks at end mode (-gnatyb), lines may not end with a + -- trailing space. + + -- In check form feeds mode (-gnatyf), the line terminator may not + -- be either of the characters FF or VT. + + -- In check DOS line terminators node (-gnatyd), the line terminator + -- must be a single LF, without a following CR. + + procedure Check_Line_Terminator (Len : Int) is + S : Source_Ptr; + + L : Int := Len; + -- Length of line (adjusted down for blanks at end of line) + + begin + -- Reset count of blank lines if first line + + if Get_Logical_Line_Number (Scan_Ptr) = 1 then + Blank_Lines := 0; + end if; + + -- Check FF/VT terminators + + if Style_Check_Form_Feeds then + if Source (Scan_Ptr) = ASCII.FF then + Error_Msg_S -- CODEFIX + ("(style) form feed not allowed"); + elsif Source (Scan_Ptr) = ASCII.VT then + Error_Msg_S -- CODEFIX + ("(style) vertical tab not allowed"); + end if; + end if; + + -- Check DOS line terminator + + if Style_Check_DOS_Line_Terminator then + + -- Ignore EOF, since we only get called with an EOF if it is the last + -- character in the buffer (and was therefore not in the source file), + -- since the terminating EOF is added to stop the scan. + + if Source (Scan_Ptr) = EOF then + null; + + -- Bad terminator if we don't have an LF + + elsif Source (Scan_Ptr) /= LF then + Error_Msg_S ("(style) incorrect line terminator"); + end if; + end if; + + -- Remove trailing spaces + + S := Scan_Ptr; + while L > 0 and then Is_White_Space (Source (S - 1)) loop + S := S - 1; + L := L - 1; + end loop; + + -- Issue message for blanks at end of line if option enabled + + if Style_Check_Blanks_At_End and then L < Len then + Error_Msg -- CODEFIX + ("(style) trailing spaces not permitted", S); + end if; + + -- Deal with empty (blank) line + + if L = 0 then + + -- Increment blank line count + + Blank_Lines := Blank_Lines + 1; + + -- If first blank line, record location for later error message + + if Blank_Lines = 1 then + Blank_Line_Location := Scan_Ptr; + end if; + + -- Non-blank line, check for previous multiple blank lines + + else + if Style_Check_Blank_Lines and then Blank_Lines > 1 then + Error_Msg -- CODEFIX + ("(style) multiple blank lines", Blank_Line_Location); + end if; + + -- And reset blank line count + + Blank_Lines := 0; + end if; + end Check_Line_Terminator; + + -------------------------- + -- Check_No_Space_After -- + -------------------------- + + procedure Check_No_Space_After is + S : Source_Ptr; + + begin + if Is_White_Space (Source (Scan_Ptr)) then + + -- Allow one or more spaces if followed by comment + + S := Scan_Ptr + 1; + loop + if Source (S) = '-' and then Source (S + 1) = '-' then + return; + + elsif Is_White_Space (Source (S)) then + S := S + 1; + + else + exit; + end if; + end loop; + + Error_Space_Not_Allowed (Scan_Ptr); + end if; + end Check_No_Space_After; + + --------------------------- + -- Check_No_Space_Before -- + --------------------------- + + procedure Check_No_Space_Before is + begin + if Token_Ptr > First_Non_Blank_Location + and then Source (Token_Ptr - 1) <= ' ' + then + Error_Space_Not_Allowed (Token_Ptr - 1); + end if; + end Check_No_Space_Before; + + ----------------------- + -- Check_Pragma_Name -- + ----------------------- + + -- In check pragma casing mode (-gnatyp), pragma names must be mixed + -- case, i.e. start with an upper case letter, and otherwise lower case, + -- except after an underline character. + + procedure Check_Pragma_Name is + begin + if Style_Check_Pragma_Casing then + if Determine_Token_Casing /= Mixed_Case then + Error_Msg_SC -- CODEFIX + ("(style) bad capitalization, mixed case required"); + end if; + end if; + end Check_Pragma_Name; + + ----------------------- + -- Check_Right_Paren -- + ----------------------- + + -- In check tokens mode (-gnatyt), right paren must not be immediately + -- followed by an identifier character, and must never be preceded by + -- a space unless it is the initial non-blank character on the line. + + procedure Check_Right_Paren is + begin + if Style_Check_Tokens then + if Identifier_Char (Source (Token_Ptr + 1)) then + Error_Space_Required (Token_Ptr + 1); + end if; + + Check_No_Space_Before; + end if; + end Check_Right_Paren; + + --------------------- + -- Check_Semicolon -- + --------------------- + + -- In check tokens mode (-gnatyt), semicolon does not permit a preceding + -- space and a following space is required. + + procedure Check_Semicolon is + begin + if Style_Check_Tokens then + Check_No_Space_Before; + + if Source (Scan_Ptr) > ' ' then + Error_Space_Required (Scan_Ptr); + end if; + end if; + end Check_Semicolon; + + ------------------------------- + -- Check_Separate_Stmt_Lines -- + ------------------------------- + + procedure Check_Separate_Stmt_Lines is + begin + if Style_Check_Separate_Stmt_Lines then + Check_Separate_Stmt_Lines_Cont; + end if; + end Check_Separate_Stmt_Lines; + + ------------------------------------ + -- Check_Separate_Stmt_Lines_Cont -- + ------------------------------------ + + procedure Check_Separate_Stmt_Lines_Cont is + S : Source_Ptr; + + begin + -- Skip past white space + + S := Scan_Ptr; + while Is_White_Space (Source (S)) loop + S := S + 1; + end loop; + + -- Line terminator is OK + + if Source (S) in Line_Terminator then + return; + + -- Comment is OK + + elsif Source (S) = '-' and then Source (S + 1) = '-' then + return; + + -- ABORT keyword is OK after THEN (THEN ABORT case) + + elsif Token = Tok_Then + and then (Source (S + 0) = 'a' or else Source (S + 0) = 'A') + and then (Source (S + 1) = 'b' or else Source (S + 1) = 'B') + and then (Source (S + 2) = 'o' or else Source (S + 2) = 'O') + and then (Source (S + 3) = 'r' or else Source (S + 3) = 'R') + and then (Source (S + 4) = 't' or else Source (S + 4) = 'T') + and then (Source (S + 5) in Line_Terminator + or else Is_White_Space (Source (S + 5))) + then + return; + + -- PRAGMA keyword is OK after ELSE + + elsif Token = Tok_Else + and then (Source (S + 0) = 'p' or else Source (S + 0) = 'P') + and then (Source (S + 1) = 'r' or else Source (S + 1) = 'R') + and then (Source (S + 2) = 'a' or else Source (S + 2) = 'A') + and then (Source (S + 3) = 'g' or else Source (S + 3) = 'G') + and then (Source (S + 4) = 'm' or else Source (S + 4) = 'M') + and then (Source (S + 5) = 'a' or else Source (S + 5) = 'A') + and then (Source (S + 6) in Line_Terminator + or else Is_White_Space (Source (S + 6))) + then + return; + + -- Otherwise we have the style violation we are looking for + + else + if Token = Tok_Then then + Error_Msg -- CODEFIX + ("(style) no statements may follow THEN on same line", S); + else + Error_Msg + ("(style) no statements may follow ELSE on same line", S); + end if; + end if; + end Check_Separate_Stmt_Lines_Cont; + + ---------------- + -- Check_Then -- + ---------------- + + -- In check if then layout mode (-gnatyi), we expect a THEN keyword + -- to appear either on the same line as the IF, or on a separate line + -- after multiple conditions. In any case, it may not appear on the + -- line immediately following the line with the IF. + + procedure Check_Then (If_Loc : Source_Ptr) is + begin + if Style_Check_If_Then_Layout then + if Get_Physical_Line_Number (Token_Ptr) = + Get_Physical_Line_Number (If_Loc) + 1 + then + Error_Msg_SC ("(style) misplaced THEN"); + end if; + end if; + end Check_Then; + + ------------------------------- + -- Check_Unary_Plus_Or_Minus -- + ------------------------------- + + -- In check token mode (-gnatyt), unary plus or minus must not be + -- followed by a space. + + procedure Check_Unary_Plus_Or_Minus is + begin + if Style_Check_Tokens then + Check_No_Space_After; + end if; + end Check_Unary_Plus_Or_Minus; + + ------------------------ + -- Check_Vertical_Bar -- + ------------------------ + + -- In check token mode (-gnatyt), vertical bar must be surrounded by spaces + + procedure Check_Vertical_Bar is + begin + if Style_Check_Tokens then + Require_Preceding_Space; + Require_Following_Space; + end if; + end Check_Vertical_Bar; + + ----------------------- + -- Check_Xtra_Parens -- + ----------------------- + + procedure Check_Xtra_Parens (Loc : Source_Ptr) is + begin + if Style_Check_Xtra_Parens then + Error_Msg -- CODEFIX + ("redundant parentheses?", Loc); + end if; + end Check_Xtra_Parens; + + ---------------------------- + -- Determine_Token_Casing -- + ---------------------------- + + function Determine_Token_Casing return Casing_Type is + begin + return Determine_Casing (Source (Token_Ptr .. Scan_Ptr - 1)); + end Determine_Token_Casing; + + ----------------------------- + -- Error_Space_Not_Allowed -- + ----------------------------- + + procedure Error_Space_Not_Allowed (S : Source_Ptr) is + begin + Error_Msg -- CODEFIX + ("(style) space not allowed", S); + end Error_Space_Not_Allowed; + + -------------------------- + -- Error_Space_Required -- + -------------------------- + + procedure Error_Space_Required (S : Source_Ptr) is + begin + Error_Msg -- CODEFIX + ("(style) space required", S); + end Error_Space_Required; + + -------------------- + -- Is_White_Space -- + -------------------- + + function Is_White_Space (C : Character) return Boolean is + begin + return C = ' ' or else C = HT; + end Is_White_Space; + + ------------------- + -- Mode_In_Check -- + ------------------- + + function Mode_In_Check return Boolean is + begin + return Style_Check and Style_Check_Mode_In; + end Mode_In_Check; + + ----------------- + -- No_End_Name -- + ----------------- + + -- In check end/exit labels mode (-gnatye), always require the name of + -- a subprogram or package to be present on the END, so this is an error. + + procedure No_End_Name (Name : Node_Id) is + begin + if Style_Check_End_Labels then + Error_Msg_Node_1 := Name; + Error_Msg_SP -- CODEFIX + ("(style) `END &` required"); + end if; + end No_End_Name; + + ------------------ + -- No_Exit_Name -- + ------------------ + + -- In check end/exit labels mode (-gnatye), always require the name of + -- the loop to be present on the EXIT when exiting a named loop. + + procedure No_Exit_Name (Name : Node_Id) is + begin + if Style_Check_End_Labels then + Error_Msg_Node_1 := Name; + Error_Msg_SP -- CODEFIX + ("(style) `EXIT &` required"); + end if; + end No_Exit_Name; + + ---------------------------- + -- Non_Lower_Case_Keyword -- + ---------------------------- + + -- In check casing mode (-gnatyk), reserved keywords must be spelled + -- in all lower case (excluding keywords range, access, delta and digits + -- used as attribute designators). + + procedure Non_Lower_Case_Keyword is + begin + if Style_Check_Keyword_Casing then + Error_Msg_SC -- CODEFIX + ("(style) reserved words must be all lower case"); + end if; + end Non_Lower_Case_Keyword; + + ----------------------------- + -- Require_Following_Space -- + ----------------------------- + + procedure Require_Following_Space is + begin + if Source (Scan_Ptr) > ' ' then + Error_Space_Required (Scan_Ptr); + end if; + end Require_Following_Space; + + ----------------------------- + -- Require_Preceding_Space -- + ----------------------------- + + procedure Require_Preceding_Space is + begin + if Token_Ptr > Source_First (Current_Source_File) + and then Source (Token_Ptr - 1) > ' ' + then + Error_Space_Required (Token_Ptr); + end if; + end Require_Preceding_Space; + +end Styleg; diff --git a/gcc/ada/styleg.ads b/gcc/ada/styleg.ads new file mode 100644 index 000000000..954a03359 --- /dev/null +++ b/gcc/ada/styleg.ads @@ -0,0 +1,177 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S T Y L E G -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This generic package collects the routines used for style checking, as +-- activated by the relevant command line option. These are gathered in +-- a separate package so that they can more easily be customized. Calls +-- to these subprograms are only made if Opt.Style_Check is set True. +-- Styleg does not depends on the GNAT tree (Atree, Sinfo, ...). + +with Types; use Types; + +generic + with procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr); + -- Output a message at specified location + + with procedure Error_Msg_S (Msg : String); + -- Output a message at current scan pointer location + + with procedure Error_Msg_SC (Msg : String); + -- Output a message at the start of the current token + + with procedure Error_Msg_SP (Msg : String); + -- Output a message at the start of the previous token + +package Styleg is + + procedure Check_Abs_Not; + -- Called after scanning an ABS or NOT operator to check spacing + + procedure Check_Apostrophe; + -- Called after scanning an apostrophe to check spacing + + procedure Check_Arrow; + -- Called after scanning out an arrow to check spacing + + procedure Check_Attribute_Name (Reserved : Boolean); + -- The current token is an attribute designator. Check that it + -- is capitalized in an appropriate manner. Reserved is set if + -- the attribute designator is a reserved word (access, digits, + -- delta or range) to allow differing rules for the two cases. + + procedure Check_Boolean_Operator (Node : Node_Id); + -- Node is a node for an AND or OR operator. Check that the usage meets + -- the style rules. + + procedure Check_Box; + -- Called after scanning out a box to check spacing + + procedure Check_Binary_Operator; + -- Called after scanning out a binary operator other than a plus, minus + -- or exponentiation operator. Intended for checking spacing rules. + + procedure Check_Exponentiation_Operator; + -- Called after scanning out an exponentiation operator. Intended for + -- checking spacing rules. + + procedure Check_Colon; + -- Called after scanning out colon to check spacing + + procedure Check_Colon_Equal; + -- Called after scanning out colon equal to check spacing + + procedure Check_Comma; + -- Called after scanning out comma to check spacing + + procedure Check_Comment; + -- Called with Scan_Ptr pointing to the first minus sign of a comment. + -- Intended for checking any specific rules for comment placement/format. + + procedure Check_Dot_Dot; + -- Called after scanning out dot dot to check spacing + + procedure Check_EOF; + -- Called after scanning out EOF mark + + procedure Check_HT; + -- Called with Scan_Ptr pointing to a horizontal tab character + + procedure Check_Indentation; + -- Called at the start of a new statement or declaration, with Token_Ptr + -- pointing to the first token of the statement or declaration. The check + -- is that the starting column is appropriate to the indentation rules if + -- Token_Ptr is the first token on the line. + + procedure Check_Left_Paren; + -- Called after scanning out a left parenthesis to check spacing + + procedure Check_Line_Max_Length (Len : Int); + -- Called with Scan_Ptr pointing to the first line terminator character + -- terminating the current line. Used to check for appropriate line length. + -- The parameter Len is the length of the current line. + + procedure Check_Line_Terminator (Len : Int); + -- Called with Scan_Ptr pointing to the first line terminator terminating + -- the current line, used to check for appropriate line terminator usage. + -- The parameter Len is the length of the current line. + + procedure Check_Pragma_Name; + -- The current token is a pragma identifier. Check that it is spelled + -- properly (i.e. with an appropriate casing convention). + + procedure Check_Right_Paren; + -- Called after scanning out a right parenthesis to check spacing + + procedure Check_Semicolon; + -- Called after scanning out a semicolon to check spacing + + procedure Check_Then (If_Loc : Source_Ptr); + -- Called to check that THEN and IF keywords are appropriately positioned. + -- The parameters show the first characters of the two keywords. This + -- procedure is called only if THEN appears at the start of a line with + -- Token_Ptr pointing to the THEN keyword. + + procedure Check_Separate_Stmt_Lines; + pragma Inline (Check_Separate_Stmt_Lines); + -- Called after scanning THEN (not preceded by AND) or ELSE (not preceded + -- by OR). Used to check that no tokens follow on the same line (which + -- would interfere with coverage testing). Handles case of THEN ABORT as + -- an exception, as well as PRAGMA after ELSE. + + procedure Check_Unary_Plus_Or_Minus; + -- Called after scanning a unary plus or minus to check spacing + + procedure Check_Vertical_Bar; + -- Called after scanning a vertical bar to check spacing + + procedure Check_Xtra_Parens (Loc : Source_Ptr); + -- Called after scanning a conditional expression that has at least one + -- level of parentheses around the entire expression. + + function Mode_In_Check return Boolean; + pragma Inline (Mode_In_Check); + -- Determines whether style checking is active and the Mode_In_Check is + -- set, forbidding the explicit use of mode IN. + + procedure No_End_Name (Name : Node_Id); + -- Called if an END is encountered where a name is allowed but not present. + -- The parameter is the node whose name is the name that is permitted in + -- the END line, and the scan pointer is positioned so that if an error + -- message is to be generated in this situation, it should be generated + -- using Error_Msg_SP. + + procedure No_Exit_Name (Name : Node_Id); + -- Called when exiting a named loop, but a name is not present on the EXIT. + -- The parameter is the node whose name should have followed EXIT, and the + -- scan pointer is positioned so that if an error message is to be + -- generated, it should be generated using Error_Msg_SP. + + procedure Non_Lower_Case_Keyword; + -- Called if a reserved keyword is scanned which is not spelled in all + -- lower case letters. On entry Token_Ptr points to the keyword token. + -- This is not used for keywords appearing as attribute designators, + -- where instead Check_Attribute_Name (True) is called. + +end Styleg; diff --git a/gcc/ada/stylesw.adb b/gcc/ada/stylesw.adb new file mode 100644 index 000000000..9a5999655 --- /dev/null +++ b/gcc/ada/stylesw.adb @@ -0,0 +1,570 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S T Y L E S W -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Hostparm; use Hostparm; +with Opt; use Opt; + +package body Stylesw is + + -- The following constant defines the default style options for -gnaty + + Default_Style : constant String := + "3" & -- indentation level is 3 + "a" & -- check attribute casing + "A" & -- check array attribute indexes + "b" & -- check no blanks at end of lines + "c" & -- check comment formats + "e" & -- check end/exit labels present + "f" & -- check no form/feeds vertical tabs in source + "h" & -- check no horizontal tabs in source + "i" & -- check if-then layout + "k" & -- check casing rules for keywords + "l" & -- check reference manual layout + "m" & -- check line length <= 79 characters + "n" & -- check casing of package Standard idents + "p" & -- check pragma casing + "r" & -- check casing for identifier references + "s" & -- check separate subprogram specs present + "t"; -- check token separation rules + + -- The following constant defines the GNAT style options, showing them + -- as additions to the standard default style check options. + + GNAT_Style : constant String := Default_Style & + "d" & -- check no DOS line terminators + "I" & -- check mode IN + "S" & -- check separate lines after THEN or ELSE + "u" & -- check no unnecessary blank lines + "x"; -- check extra parentheses around conditionals + + -- Note: we intend GNAT_Style to also include the following, but we do + -- not yet have the whole tool suite clean with respect to this. + + -- "B" & -- check boolean operators + + ------------------------------- + -- Reset_Style_Check_Options -- + ------------------------------- + + procedure Reset_Style_Check_Options is + begin + Style_Check_Indentation := 0; + Style_Check_Array_Attribute_Index := False; + Style_Check_Attribute_Casing := False; + Style_Check_Blanks_At_End := False; + Style_Check_Blank_Lines := False; + Style_Check_Boolean_And_Or := False; + Style_Check_Comments := False; + Style_Check_DOS_Line_Terminator := False; + Style_Check_End_Labels := False; + Style_Check_Form_Feeds := False; + Style_Check_Horizontal_Tabs := False; + Style_Check_If_Then_Layout := False; + Style_Check_Keyword_Casing := False; + Style_Check_Layout := False; + Style_Check_Max_Line_Length := False; + Style_Check_Max_Nesting_Level := False; + Style_Check_Missing_Overriding := False; + Style_Check_Mode_In := False; + Style_Check_Order_Subprograms := False; + Style_Check_Pragma_Casing := False; + Style_Check_References := False; + Style_Check_Separate_Stmt_Lines := False; + Style_Check_Specs := False; + Style_Check_Standard := False; + Style_Check_Tokens := False; + Style_Check_Xtra_Parens := False; + end Reset_Style_Check_Options; + + --------------------- + -- RM_Column_Check -- + --------------------- + + function RM_Column_Check return Boolean is + begin + return Style_Check and Style_Check_Layout; + end RM_Column_Check; + + ------------------------------ + -- Save_Style_Check_Options -- + ------------------------------ + + procedure Save_Style_Check_Options (Options : out Style_Check_Options) is + P : Natural := 0; + + procedure Add (C : Character; S : Boolean); + -- Add given character C to string if switch S is true + + procedure Add_Nat (N : Nat); + -- Add given natural number to string + + --------- + -- Add -- + --------- + + procedure Add (C : Character; S : Boolean) is + begin + if S then + P := P + 1; + Options (P) := C; + end if; + end Add; + + ------------- + -- Add_Nat -- + ------------- + + procedure Add_Nat (N : Nat) is + begin + if N > 9 then + Add_Nat (N / 10); + end if; + + P := P + 1; + Options (P) := Character'Val (Character'Pos ('0') + N mod 10); + end Add_Nat; + + -- Start of processing for Save_Style_Check_Options + + begin + for K in Options'Range loop + Options (K) := ' '; + end loop; + + Add (Character'Val (Style_Check_Indentation + Character'Pos ('0')), + Style_Check_Indentation /= 0); + + Add ('a', Style_Check_Attribute_Casing); + Add ('A', Style_Check_Array_Attribute_Index); + Add ('b', Style_Check_Blanks_At_End); + Add ('B', Style_Check_Boolean_And_Or); + Add ('c', Style_Check_Comments); + Add ('d', Style_Check_DOS_Line_Terminator); + Add ('e', Style_Check_End_Labels); + Add ('f', Style_Check_Form_Feeds); + Add ('h', Style_Check_Horizontal_Tabs); + Add ('i', Style_Check_If_Then_Layout); + Add ('I', Style_Check_Mode_In); + Add ('k', Style_Check_Keyword_Casing); + Add ('l', Style_Check_Layout); + Add ('n', Style_Check_Standard); + Add ('o', Style_Check_Order_Subprograms); + Add ('O', Style_Check_Missing_Overriding); + Add ('p', Style_Check_Pragma_Casing); + Add ('r', Style_Check_References); + Add ('s', Style_Check_Specs); + Add ('S', Style_Check_Separate_Stmt_Lines); + Add ('t', Style_Check_Tokens); + Add ('u', Style_Check_Blank_Lines); + Add ('x', Style_Check_Xtra_Parens); + + if Style_Check_Max_Line_Length then + P := P + 1; + Options (P) := 'M'; + Add_Nat (Style_Max_Line_Length); + end if; + + if Style_Check_Max_Nesting_Level then + P := P + 1; + Options (P) := 'L'; + Add_Nat (Style_Max_Nesting_Level); + end if; + + pragma Assert (P <= Options'Last); + + while P < Options'Last loop + P := P + 1; + Options (P) := ' '; + end loop; + end Save_Style_Check_Options; + + ------------------------------------- + -- Set_Default_Style_Check_Options -- + ------------------------------------- + + procedure Set_Default_Style_Check_Options is + begin + Reset_Style_Check_Options; + Set_Style_Check_Options (Default_Style); + end Set_Default_Style_Check_Options; + + ---------------------------------- + -- Set_GNAT_Style_Check_Options -- + ---------------------------------- + + procedure Set_GNAT_Style_Check_Options is + begin + Reset_Style_Check_Options; + Set_Style_Check_Options (GNAT_Style); + end Set_GNAT_Style_Check_Options; + + ----------------------------- + -- Set_Style_Check_Options -- + ----------------------------- + + -- Version used when no error checking is required + + procedure Set_Style_Check_Options (Options : String) is + OK : Boolean; + EC : Natural; + pragma Warnings (Off, EC); + begin + Set_Style_Check_Options (Options, OK, EC); + pragma Assert (OK); + end Set_Style_Check_Options; + + -- Normal version with error checking + + procedure Set_Style_Check_Options + (Options : String; + OK : out Boolean; + Err_Col : out Natural) + is + C : Character; + + On : Boolean := True; + -- Set to False if minus encountered + -- Set to True if plus encountered + + Last_Option : Character := ' '; + -- Set to last character encountered + + procedure Add_Img (N : Natural); + -- Concatenates image of N at end of Style_Msg_Buf + + procedure Bad_Style_Switch (Msg : String); + -- Called if bad style switch found. Msg is set in Style_Msg_Buf and + -- Style_Msg_Len. OK is set False. + + ------------- + -- Add_Img -- + ------------- + + procedure Add_Img (N : Natural) is + begin + if N >= 10 then + Add_Img (N / 10); + end if; + + Style_Msg_Len := Style_Msg_Len + 1; + Style_Msg_Buf (Style_Msg_Len) := + Character'Val (N mod 10 + Character'Pos ('0')); + end Add_Img; + + ---------------------- + -- Bad_Style_Switch -- + ---------------------- + + procedure Bad_Style_Switch (Msg : String) is + begin + OK := False; + Style_Msg_Len := Msg'Length; + Style_Msg_Buf (1 .. Style_Msg_Len) := Msg; + end Bad_Style_Switch; + + -- Start of processing for Set_Style_Check_Options + + begin + Err_Col := Options'First; + while Err_Col <= Options'Last loop + C := Options (Err_Col); + Last_Option := C; + Err_Col := Err_Col + 1; + + -- Turning switches on + + if On then + case C is + + when '+' => + null; + + when '-' => + On := False; + + when '0' .. '9' => + Style_Check_Indentation := + Character'Pos (C) - Character'Pos ('0'); + + when 'a' => + Style_Check_Attribute_Casing := True; + + when 'A' => + Style_Check_Array_Attribute_Index := True; + + when 'b' => + Style_Check_Blanks_At_End := True; + + when 'B' => + Style_Check_Boolean_And_Or := True; + + when 'c' => + Style_Check_Comments := True; + + when 'd' => + Style_Check_DOS_Line_Terminator := True; + + when 'e' => + Style_Check_End_Labels := True; + + when 'f' => + Style_Check_Form_Feeds := True; + + when 'g' => + Set_GNAT_Style_Check_Options; + + when 'h' => + Style_Check_Horizontal_Tabs := True; + + when 'i' => + Style_Check_If_Then_Layout := True; + + when 'I' => + Style_Check_Mode_In := True; + + when 'k' => + Style_Check_Keyword_Casing := True; + + when 'l' => + Style_Check_Layout := True; + + when 'L' => + Style_Max_Nesting_Level := 0; + + if Err_Col > Options'Last + or else Options (Err_Col) not in '0' .. '9' + then + Bad_Style_Switch ("invalid nesting level"); + return; + end if; + + loop + Style_Max_Nesting_Level := + Style_Max_Nesting_Level * 10 + + Character'Pos (Options (Err_Col)) - Character'Pos ('0'); + + if Style_Max_Nesting_Level > 999 then + Bad_Style_Switch + ("max nesting level (999) exceeded in style check"); + return; + end if; + + Err_Col := Err_Col + 1; + exit when Err_Col > Options'Last + or else Options (Err_Col) not in '0' .. '9'; + end loop; + + Style_Check_Max_Nesting_Level := Style_Max_Nesting_Level /= 0; + + when 'm' => + Style_Check_Max_Line_Length := True; + Style_Max_Line_Length := 79; + + when 'M' => + Style_Max_Line_Length := 0; + + if Err_Col > Options'Last + or else Options (Err_Col) not in '0' .. '9' + then + Bad_Style_Switch + ("invalid line length in style check"); + return; + end if; + + loop + Style_Max_Line_Length := + Style_Max_Line_Length * 10 + + Character'Pos (Options (Err_Col)) - Character'Pos ('0'); + + if Style_Max_Line_Length > Int (Max_Line_Length) then + OK := False; + Style_Msg_Buf (1 .. 27) := "max line length allowed is "; + Style_Msg_Len := 27; + Add_Img (Natural (Max_Line_Length)); + return; + end if; + + Err_Col := Err_Col + 1; + exit when Err_Col > Options'Last + or else Options (Err_Col) not in '0' .. '9'; + end loop; + + Style_Check_Max_Line_Length := Style_Max_Line_Length /= 0; + + when 'n' => + Style_Check_Standard := True; + + when 'N' => + Reset_Style_Check_Options; + + when 'o' => + Style_Check_Order_Subprograms := True; + + when 'O' => + Style_Check_Missing_Overriding := True; + + when 'p' => + Style_Check_Pragma_Casing := True; + + when 'r' => + Style_Check_References := True; + + when 's' => + Style_Check_Specs := True; + + when 'S' => + Style_Check_Separate_Stmt_Lines := True; + + when 't' => + Style_Check_Tokens := True; + + when 'u' => + Style_Check_Blank_Lines := True; + + when 'x' => + Style_Check_Xtra_Parens := True; + + when 'y' => + Set_Default_Style_Check_Options; + + when ' ' => + null; + + when others => + Err_Col := Err_Col - 1; + Bad_Style_Switch ("invalid style switch: " & C); + return; + end case; + + -- Turning switches off + + else + case C is + + when '+' => + On := True; + + when '-' => + null; + + when '0' .. '9' => + Style_Check_Indentation := 0; + + when 'a' => + Style_Check_Attribute_Casing := False; + + when 'A' => + Style_Check_Array_Attribute_Index := False; + + when 'b' => + Style_Check_Blanks_At_End := False; + + when 'B' => + Style_Check_Boolean_And_Or := False; + + when 'c' => + Style_Check_Comments := False; + + when 'd' => + Style_Check_DOS_Line_Terminator := False; + + when 'e' => + Style_Check_End_Labels := False; + + when 'f' => + Style_Check_Form_Feeds := False; + + when 'g' => + Reset_Style_Check_Options; + + when 'h' => + Style_Check_Horizontal_Tabs := False; + + when 'i' => + Style_Check_If_Then_Layout := False; + + when 'I' => + Style_Check_Mode_In := False; + + when 'k' => + Style_Check_Keyword_Casing := False; + + when 'l' => + Style_Check_Layout := False; + + when 'L' => + Style_Max_Nesting_Level := 0; + + when 'm' => + Style_Check_Max_Line_Length := False; + + when 'M' => + Style_Max_Line_Length := 0; + Style_Check_Max_Line_Length := False; + + when 'n' => + Style_Check_Standard := False; + + when 'o' => + Style_Check_Order_Subprograms := False; + + when 'p' => + Style_Check_Pragma_Casing := False; + + when 'r' => + Style_Check_References := False; + + when 's' => + Style_Check_Specs := False; + + when 'S' => + Style_Check_Separate_Stmt_Lines := False; + + when 't' => + Style_Check_Tokens := False; + + when 'u' => + Style_Check_Blank_Lines := False; + + when 'x' => + Style_Check_Xtra_Parens := False; + + when ' ' => + null; + + when others => + Err_Col := Err_Col - 1; + Bad_Style_Switch ("invalid style switch: " & C); + return; + end case; + end if; + end loop; + + -- Turn on style checking if other than N at end of string + + Style_Check := (Last_Option /= 'N'); + OK := True; + end Set_Style_Check_Options; +end Stylesw; diff --git a/gcc/ada/stylesw.ads b/gcc/ada/stylesw.ads new file mode 100644 index 000000000..f7d45b6d6 --- /dev/null +++ b/gcc/ada/stylesw.ads @@ -0,0 +1,332 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S T Y L E S W -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 style switches used for setting style options. +-- The only clients of this package are the body of Style and the body of +-- Switches. All other style checking issues are handled using the public +-- interfaces in the spec of Style. + +with Types; use Types; + +package Stylesw is + + -------------------------- + -- Style Check Switches -- + -------------------------- + + -- These flags are used to control the details of the style checking + -- options. The default values shown here correspond to no style checking. + + -- If any of these values is set to a non-default value, then + -- Opt.Style_Check is set True to active calls to this package. + + -- The actual mechanism for setting these switches to other than default + -- values is via the Set_Style_Check_Option procedure or through a call to + -- Set_Default_Style_Check_Options. They should not be set directly in any + -- other manner. + + Style_Check_Array_Attribute_Index : Boolean := False; + -- This can be set True by using the -gnatyA switch. If it is True then + -- index numbers for array attributes (like Length) are required to be + -- absent for one-dimensional arrays and present for multi-dimensional + -- array attribute references. + + Style_Check_Attribute_Casing : Boolean := False; + -- This can be set True by using the -gnatya switch. If it is True, then + -- attribute names (including keywords such as digits used as attribute + -- names) must be in mixed case. + + Style_Check_Blanks_At_End : Boolean := False; + -- This can be set True by using the -gnatyb switch. If it is True, then + -- spaces at the end of lines are not permitted. + + Style_Check_Blank_Lines : Boolean := False; + -- This can be set True by using the -gnatyu switch. If it is True, then + -- multiple blank lines are not permitted, and there may not be a blank + -- line at the end of the file. + + Style_Check_Boolean_And_Or : Boolean := False; + -- This can be set True by using the -gnatyB switch. If it is True, then + -- the use of AND THEN/OR ELSE rather than AND/OR is required except for + -- the following cases: + -- + -- a) Both operands are simple Boolean constants or variables + -- b) Both operands are of a modular type + -- c) Both operands are of an array type + + Style_Check_Comments : Boolean := False; + -- This can be set True by using the -gnatyc switch. If it is True, then + -- comments are style checked as follows: + -- + -- All comments must be at the start of the line, or the first minus must + -- be preceded by at least one space. + -- + -- For a comment that is not at the start of a line, the only requirement + -- is that a space follow the comment characters. + -- + -- For a comment that is at the start of the line, one of the following + -- conditions must hold: + -- + -- The comment characters are the only non-blank characters on the line + -- + -- The comment characters are followed by an exclamation point (the + -- sequence --! is used by gnatprep for marking deleted lines). + -- + -- The comment characters are followed by two space characters + -- + -- The line consists entirely of minus signs + -- + -- The comment characters are followed by a single space, and the last + -- two characters on the line are also comment characters. + -- + -- Note: the reason for the last two conditions is to allow "boxed" + -- comments where only a single space separates the comment characters. + + Style_Check_DOS_Line_Terminator : Boolean := False; + -- This can be set true by using the -gnatyd switch. If it is True, then + -- the line terminator must be a single LF, without an associated CR (e.g. + -- DOS line terminator sequence CR/LF not allowed). + + Style_Check_End_Labels : Boolean := False; + -- This can be set True by using the -gnatye switch. If it is True, then + -- optional END labels must always be present. + + Style_Check_Form_Feeds : Boolean := False; + -- This can be set True by using the -gnatyf switch. If it is True, then + -- form feeds and vertical tabs are not allowed in the source text. + + Style_Check_Horizontal_Tabs : Boolean := False; + -- This can be set True by using the -gnatyh switch. If it is True, then + -- horizontal tabs are not allowed in source text. + + Style_Check_If_Then_Layout : Boolean := False; + -- This can be set True by using the -gnatyi switch. If it is True, then a + -- THEN keyword may not appear on the line that immediately follows the + -- line containing the corresponding IF. + -- + -- This permits one of two styles for IF-THEN layout. Either the IF and + -- THEN keywords are on the same line, where the condition is short enough, + -- or the conditions are continued over to the lines following the IF and + -- the THEN stands on its own. For example: + -- + -- if X > Y then + -- + -- if X > Y + -- and then Y < Z + -- then + -- + -- are allowed, but + -- + -- if X > Y + -- then + -- + -- is not allowed. + + Style_Check_Indentation : Column_Number range 0 .. 9 := 0; + -- This can be set non-zero by using the -gnatyn (n a digit) switch. If + -- it is non-zero it activates indentation checking with the indicated + -- indentation value. A value of zero turns off checking. The requirement + -- is that any new statement, line comment, declaration or keyword such + -- as END, start on a column that is a multiple of the indentation value. + + Style_Check_Keyword_Casing : Boolean := False; + -- This can be set True by using the -gnatyk switch. If it is True, then + -- keywords are required to be in all lower case. This rule does not apply + -- to keywords such as digits appearing as an attribute name. + + Style_Check_Layout : Boolean := False; + -- This can be set True by using the -gnatyl switch. If it is True, it + -- activates checks that constructs are indented as suggested by the + -- examples in the RM syntax, e.g. that the ELSE keyword must line up + -- with the IF keyword. + + Style_Check_Max_Line_Length : Boolean := False; + -- This can be set True by using the -gnatym/M switches. If it is True, it + -- activates checking for a maximum line length of Style_Max_Line_Length + -- characters. + + Style_Check_Max_Nesting_Level : Boolean := False; + -- This can be set True by using -gnatyLnnn with a value other than zero + -- (a value of zero resets it to False). If True, it activates checking + -- the maximum nesting level against Style_Max_Nesting_Level. + + Style_Check_Missing_Overriding : Boolean := False; + -- This can be set True by using the -gnatyO switch. If it is True, then + -- "[not] overriding" is required in subprogram declarations and bodies + -- where appropriate. + + Style_Check_Mode_In : Boolean := False; + -- This can be set True by using -gnatyI. If True, it activates checking + -- that mode IN is not used on its own (since it is the default). + + Style_Check_Order_Subprograms : Boolean := False; + -- This can be set True by using the -gnatyo switch. If it is True, then + -- names of subprogram bodies must be in alphabetical order (not taking + -- casing into account). + + Style_Check_Pragma_Casing : Boolean := False; + -- This can be set True by using the -gnatyp switch. If it is True, then + -- pragma names must use mixed case. + + Style_Check_References : Boolean := False; + -- This can be set True by using the -gnatyr switch. If it is True, then + -- all references to declared identifiers are checked. The requirement + -- is that casing of the reference be the same as the casing of the + -- corresponding declaration. + + Style_Check_Separate_Stmt_Lines : Boolean := False; + -- This can be set True by using the -gnatyS switch. If it is TRUE, + -- then for the case of keywords THEN (not preceded by AND) or ELSE (not + -- preceded by OR) which introduce a conditionally executed statement + -- sequence, there must be no tokens on the same line as the keyword, so + -- that coverage testing can clearly identify execution of the statement + -- sequence. A comment is permitted, as is THEN ABORT or a PRAGMA keyword + -- after ELSE (a common style to specify the condition for the ELSE). + + Style_Check_Specs : Boolean := False; + -- This can be set True by using the -gnatys switches. If it is True, then + -- separate specs are required to be present for all procedures except + -- parameterless library level procedures. The exception means that typical + -- main programs do not require separate specs. + + Style_Check_Standard : Boolean := False; + -- This can be set True by using the -gnatyn switch. If it is True, then + -- any references to names in Standard have to be in mixed case mode (e.g. + -- Integer, Boolean). + + Style_Check_Tokens : Boolean := False; + -- This can be set True by using the -gnatyt switch. If it is True, then + -- the style check that requires canonical spacing between various + -- punctuation tokens as follows: + -- + -- ABS and NOT must be followed by a space + -- + -- => must be surrounded by spaces + -- + -- <> must be preceded by a space or left paren + -- + -- Binary operators other than ** must be surrounded by spaces. + -- + -- There is no restriction on the layout of the ** binary operator. + -- + -- Colon must be surrounded by spaces + -- + -- Colon-equal (assignment) must be surrounded by spaces + -- + -- Comma must be the first non-blank character on the line, or be + -- immediately preceded by a non-blank character, and must be followed + -- by a blank. + -- + -- A space must precede a left paren following a digit or letter, and a + -- right paren must not be followed by a space (it can be at the end of + -- the line). + -- + -- A right paren must either be the first non-blank character on a line, + -- or it must be preceded by a non-blank character. + -- + -- A semicolon must not be preceded by a blank, and must not be followed + -- by a non-blank character. + -- + -- A unary plus or minus may not be followed by a space + -- + -- A vertical bar must be surrounded by spaces + -- + -- Note that a requirement that a token be preceded by a space is met by + -- placing the token at the start of the line, and similarly a requirement + -- that a token be followed by a space is met by placing the token at + -- the end of the line. Note that in the case where horizontal tabs are + -- permitted, a horizontal tab is acceptable for meeting the requirement + -- for a space. + + Style_Check_Xtra_Parens : Boolean := False; + -- This can be set True by using the -gnatyx switch. If true, then it is + -- not allowed to enclose entire conditional expressions in parentheses + -- (C style). + + Style_Max_Line_Length : Int := 0; + -- Value used to check maximum line length. Gets reset as a result of + -- use of -gnatym or -gnatyMnnn switches. This value is only read if + -- Style_Check_Max_Line_Length is True. + + Style_Max_Nesting_Level : Int := 0; + -- Value used to check maximum nesting level. Gets reset as a result + -- of use of the -gnatyLnnn switch. This value is only read if + -- Style_Check_Max_Nesting_Level is True. + + ----------------- + -- Subprograms -- + ----------------- + + function RM_Column_Check return Boolean; + -- Determines whether style checking is active and the RM column check + -- mode is set requiring checking of RM format layout. + + procedure Set_Default_Style_Check_Options; + -- This procedure is called to set the default style checking options in + -- response to a -gnaty switch with no suboptions or from -gnatyy. + + procedure Set_GNAT_Style_Check_Options; + -- This procedure is called to set the default style checking options for + -- GNAT units (as set by -gnatg or -gnatyg). + + Style_Msg_Buf : String (1 .. 80); + Style_Msg_Len : Natural; + -- Used to return + + procedure Set_Style_Check_Options + (Options : String; + OK : out Boolean; + Err_Col : out Natural); + -- This procedure is called to set the style check options that correspond + -- to the characters in the given Options string. If all options are valid, + -- they are set in an additive manner: any previous options are retained + -- unless overridden, unless a minus is encountered, and then subsequent + -- style switches are subtracted from the current set. + -- + -- If all options given are valid, then OK is True, Err_Col is set to + -- Options'Last + 1, and Style_Msg_Buf/Style_Msg_Len are unchanged. + -- + -- If an invalid character is found, then OK is False on exit, and Err_Col + -- is the index in options of the bad character. In this case Style_Msg_Len + -- is set and Style_Msg_Buf (1 .. Style_Msg_Len) has a detailed message + -- describing the error. + + procedure Set_Style_Check_Options (Options : String); + -- Like the above procedure, but used when the Options string is known to + -- be valid. This is for example appropriate for calls where the string == + -- was obtained by Save_Style_Check_Options. + + procedure Reset_Style_Check_Options; + -- Sets all style check options to off + + subtype Style_Check_Options is String (1 .. 64); + -- Long enough string to hold all options from Save call below + + procedure Save_Style_Check_Options (Options : out Style_Check_Options); + -- Sets Options to represent current selection of options. This set can be + -- restored by first calling Reset_Style_Check_Options, and then calling + -- Set_Style_Check_Options with the Options string. + +end Stylesw; diff --git a/gcc/ada/switch-b.adb b/gcc/ada/switch-b.adb new file mode 100644 index 000000000..b41296b2c --- /dev/null +++ b/gcc/ada/switch-b.adb @@ -0,0 +1,589 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S W I T C H - B -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Debug; use Debug; +with Osint; use Osint; +with Opt; use Opt; +with Output; use Output; + +with System.WCh_Con; use System.WCh_Con; + +package body Switch.B is + + -------------------------- + -- Scan_Binder_Switches -- + -------------------------- + + procedure Scan_Binder_Switches (Switch_Chars : String) is + Max : constant Integer := Switch_Chars'Last; + Ptr : Integer := Switch_Chars'First; + C : Character := ' '; + + function Get_Optional_Filename return String_Ptr; + -- If current character is '=', return a newly allocated string that + -- contains the remainder of the current switch (after the '='), else + -- return null. + + function Get_Stack_Size (S : Character) return Int; + -- Used for -d and -D to scan stack size including handling k/m. S is + -- set to 'd' or 'D' to indicate the switch being scanned. + + --------------------------- + -- Get_Optional_Filename -- + --------------------------- + + function Get_Optional_Filename return String_Ptr is + Result : String_Ptr; + + begin + if Ptr <= Max and then Switch_Chars (Ptr) = '=' then + if Ptr = Max then + Bad_Switch (Switch_Chars); + else + Result := new String'(Switch_Chars (Ptr + 1 .. Max)); + Ptr := Max + 1; + return Result; + end if; + end if; + + return null; + end Get_Optional_Filename; + + -------------------- + -- Get_Stack_Size -- + -------------------- + + function Get_Stack_Size (S : Character) return Int is + Result : Int; + + begin + Scan_Pos (Switch_Chars, Max, Ptr, Result, S); + + -- In the following code, we enable overflow checking since the + -- multiplication by K or M may cause overflow, which is an error. + + declare + pragma Unsuppress (Overflow_Check); + + begin + -- Check for additional character 'k' (for kilobytes) or 'm' (for + -- Megabytes), but only if we have not reached the end of the + -- switch string. Note that if this appears before the end of the + -- string we will get an error when we test to make sure that the + -- string is exhausted (at the end of the case). + + if Ptr <= Max then + if Switch_Chars (Ptr) = 'k' then + Result := Result * 1024; + Ptr := Ptr + 1; + + elsif Switch_Chars (Ptr) = 'm' then + Result := Result * (1024 * 1024); + Ptr := Ptr + 1; + end if; + end if; + + exception + when Constraint_Error => + Osint.Fail ("numeric value out of range for switch: " & S); + end; + + return Result; + end Get_Stack_Size; + + -- Start of processing for Scan_Binder_Switches + + begin + -- Skip past the initial character (must be the switch character) + + if Ptr = Max then + Bad_Switch (Switch_Chars); + else + Ptr := Ptr + 1; + end if; + + -- A little check, "gnat" at the start of a switch is not allowed except + -- for the compiler + + if Switch_Chars'Last >= Ptr + 3 + and then Switch_Chars (Ptr .. Ptr + 3) = "gnat" + then + Osint.Fail ("invalid switch: """ & Switch_Chars & """" + & " (gnat not needed here)"); + end if; + + -- Loop to scan through switches given in switch string + + Check_Switch : begin + C := Switch_Chars (Ptr); + + case C is + + -- Processing for a switch + + when 'a' => + Ptr := Ptr + 1; + Use_Pragma_Linker_Constructor := True; + + -- Processing for A switch + + when 'A' => + Ptr := Ptr + 1; + Output_ALI_List := True; + ALI_List_Filename := Get_Optional_Filename; + + -- Processing for b switch + + when 'b' => + Ptr := Ptr + 1; + Brief_Output := True; + + -- Processing for c switch + + when 'c' => + Ptr := Ptr + 1; + Check_Only := True; + + -- Processing for C switch + + when 'C' => + Ptr := Ptr + 1; + Ada_Bind_File := False; + + Write_Line ("warning: gnatbind switch -C is obsolescent"); + + -- Processing for d switch + + when 'd' => + + if Ptr = Max then + Bad_Switch (Switch_Chars); + end if; + + Ptr := Ptr + 1; + C := Switch_Chars (Ptr); + + -- Case where character after -d is a digit (default stack size) + + if C in '0' .. '9' then + + -- In this case, we process the default primary stack size + + Default_Stack_Size := Get_Stack_Size ('d'); + + -- Case where character after -d is not digit (debug flags) + + else + -- Note: for the debug switch, the remaining characters in this + -- switch field must all be debug flags, since all valid switch + -- characters are also valid debug characters. This switch is + -- not documented on purpose because it is only used by the + -- implementors. + + -- Loop to scan out debug flags + + loop + C := Switch_Chars (Ptr); + + if C in 'a' .. 'z' or else C in 'A' .. 'Z' then + Set_Debug_Flag (C); + else + Bad_Switch (Switch_Chars); + end if; + + Ptr := Ptr + 1; + exit when Ptr > Max; + end loop; + end if; + + -- Processing for D switch + + when 'D' => + if Ptr = Max then + Bad_Switch (Switch_Chars); + end if; + + Ptr := Ptr + 1; + Default_Sec_Stack_Size := Get_Stack_Size ('D'); + + -- Processing for e switch + + when 'e' => + Ptr := Ptr + 1; + Elab_Dependency_Output := True; + + -- Processing for E switch + + when 'E' => + Ptr := Ptr + 1; + Exception_Tracebacks := True; + + -- Processing for F switch + + when 'F' => + Ptr := Ptr + 1; + Force_Checking_Of_Elaboration_Flags := True; + + -- Processing for g switch + + when 'g' => + Ptr := Ptr + 1; + + if Ptr <= Max then + C := Switch_Chars (Ptr); + + if C in '0' .. '3' then + Debugger_Level := + Character'Pos + (Switch_Chars (Ptr)) - Character'Pos ('0'); + Ptr := Ptr + 1; + end if; + + else + Debugger_Level := 2; + end if; + + -- Processing for h switch + + when 'h' => + Ptr := Ptr + 1; + Usage_Requested := True; + + -- Processing for H switch + + when 'H' => + if Ptr = Max then + Bad_Switch (Switch_Chars); + end if; + + Ptr := Ptr + 1; + Scan_Nat (Switch_Chars, Max, Ptr, Heap_Size, C); + + if Heap_Size /= 32 and then Heap_Size /= 64 then + Bad_Switch (Switch_Chars); + end if; + + -- Processing for i switch + + when 'i' => + if Ptr = Max then + Bad_Switch (Switch_Chars); + end if; + + Ptr := Ptr + 1; + C := Switch_Chars (Ptr); + + if C in '1' .. '5' + or else C = '8' + or else C = 'p' + or else C = 'f' + or else C = 'n' + or else C = 'w' + then + Identifier_Character_Set := C; + Ptr := Ptr + 1; + else + Bad_Switch (Switch_Chars); + end if; + + -- Processing for K switch + + when 'K' => + Ptr := Ptr + 1; + Output_Linker_Option_List := True; + + -- Processing for l switch + + when 'l' => + Ptr := Ptr + 1; + Elab_Order_Output := True; + + -- Processing for m switch + + when 'm' => + if Ptr = Max then + Bad_Switch (Switch_Chars); + end if; + + Ptr := Ptr + 1; + Scan_Pos (Switch_Chars, Max, Ptr, Maximum_Messages, C); + + -- Processing for n switch + + when 'n' => + Ptr := Ptr + 1; + Bind_Main_Program := False; + + -- Note: The -L option of the binder also implies -n, so + -- any change here must also be reflected in the processing + -- for -L that is found in Gnatbind.Scan_Bind_Arg. + + -- Processing for o switch + + when 'o' => + Ptr := Ptr + 1; + + if Output_File_Name_Present then + Osint.Fail ("duplicate -o switch"); + else + Output_File_Name_Present := True; + end if; + + -- Processing for O switch + + when 'O' => + Ptr := Ptr + 1; + Output_Object_List := True; + Object_List_Filename := Get_Optional_Filename; + + -- Processing for p switch + + when 'p' => + Ptr := Ptr + 1; + Pessimistic_Elab_Order := True; + + -- Processing for q switch + + when 'q' => + Ptr := Ptr + 1; + Quiet_Output := True; + + -- Processing for r switch + + when 'r' => + Ptr := Ptr + 1; + List_Restrictions := True; + + -- Processing for R switch + + when 'R' => + Ptr := Ptr + 1; + List_Closure := True; + + -- Processing for s switch + + when 's' => + Ptr := Ptr + 1; + All_Sources := True; + Check_Source_Files := True; + + -- Processing for t switch + + when 't' => + Ptr := Ptr + 1; + Tolerate_Consistency_Errors := True; + + -- Processing for T switch + + when 'T' => + if Ptr = Max then + Bad_Switch (Switch_Chars); + end if; + + Ptr := Ptr + 1; + Time_Slice_Set := True; + Scan_Nat (Switch_Chars, Max, Ptr, Time_Slice_Value, C); + Time_Slice_Value := Time_Slice_Value * 1_000; + + -- Processing for u switch + + when 'u' => + if Ptr = Max then + Bad_Switch (Switch_Chars); + end if; + + Ptr := Ptr + 1; + Dynamic_Stack_Measurement := True; + Scan_Nat + (Switch_Chars, + Max, + Ptr, + Dynamic_Stack_Measurement_Array_Size, + C); + + -- Processing for v switch + + when 'v' => + Ptr := Ptr + 1; + Verbose_Mode := True; + + -- Processing for w switch + + when 'w' => + if Ptr = Max then + Bad_Switch (Switch_Chars); + end if; + + -- For the binder we only allow suppress/error cases + + Ptr := Ptr + 1; + + case Switch_Chars (Ptr) is + when 'e' => + Warning_Mode := Treat_As_Error; + + when 's' => + Warning_Mode := Suppress; + + when others => + Bad_Switch (Switch_Chars); + end case; + + Ptr := Ptr + 1; + + -- Processing for W switch + + when 'W' => + Ptr := Ptr + 1; + + if Ptr > Max then + Bad_Switch (Switch_Chars); + end if; + + begin + Wide_Character_Encoding_Method := + Get_WC_Encoding_Method (Switch_Chars (Ptr)); + exception + when Constraint_Error => + Bad_Switch (Switch_Chars); + end; + + Wide_Character_Encoding_Method_Specified := True; + + Upper_Half_Encoding := + Wide_Character_Encoding_Method in WC_Upper_Half_Encoding_Method; + + Ptr := Ptr + 1; + + -- Processing for x switch + + when 'x' => + Ptr := Ptr + 1; + All_Sources := False; + Check_Source_Files := False; + + -- Processing for X switch + + when 'X' => + if Ptr = Max then + Bad_Switch (Switch_Chars); + end if; + + Ptr := Ptr + 1; + Scan_Pos (Switch_Chars, Max, Ptr, Default_Exit_Status, C); + + -- Processing for y switch + + when 'y' => + Ptr := Ptr + 1; + Leap_Seconds_Support := True; + + -- Processing for z switch + + when 'z' => + Ptr := Ptr + 1; + No_Main_Subprogram := True; + + -- Processing for Z switch + + when 'Z' => + Ptr := Ptr + 1; + Zero_Formatting := True; + + -- Processing for --RTS + + when '-' => + + if Ptr + 4 <= Max and then + Switch_Chars (Ptr + 1 .. Ptr + 3) = "RTS" + then + Ptr := Ptr + 4; + + if Switch_Chars (Ptr) /= '=' or else Ptr = Max then + Osint.Fail ("missing path for --RTS"); + + else + -- Valid --RTS switch + + Opt.No_Stdinc := True; + Opt.RTS_Switch := True; + + declare + Src_Path_Name : constant String_Ptr := + Get_RTS_Search_Dir + (Switch_Chars + (Ptr + 1 .. Switch_Chars'Last), + Include); + Lib_Path_Name : constant String_Ptr := + Get_RTS_Search_Dir + (Switch_Chars + (Ptr + 1 .. Switch_Chars'Last), + Objects); + + begin + if Src_Path_Name /= null and then + Lib_Path_Name /= null + then + -- Set the RTS_*_Path_Name variables, so that the + -- correct directories will be set when a subsequent + -- call Osint.Add_Default_Search_Dirs is made. + + RTS_Src_Path_Name := Src_Path_Name; + RTS_Lib_Path_Name := Lib_Path_Name; + + Ptr := Max + 1; + + elsif Src_Path_Name = null + and then Lib_Path_Name = null + then + Osint.Fail ("RTS path not valid: missing " & + "adainclude and adalib directories"); + elsif Src_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adainclude directory"); + elsif Lib_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adalib directory"); + end if; + end; + end if; + + else + Bad_Switch (Switch_Chars); + end if; + + -- Anything else is an error (illegal switch character) + + when others => + Bad_Switch (Switch_Chars); + end case; + + if Ptr <= Max then + Bad_Switch (Switch_Chars); + end if; + end Check_Switch; + end Scan_Binder_Switches; + +end Switch.B; diff --git a/gcc/ada/switch-b.ads b/gcc/ada/switch-b.ads new file mode 100644 index 000000000..9ec918966 --- /dev/null +++ b/gcc/ada/switch-b.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S W I T C H - B -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package scans binder switches. Note that the body of Usage must be +-- coordinated with the switches that are recognized by this package. +-- The Usage package also acts as the official documentation for the +-- switches that are recognized. In addition, package Debug documents +-- the otherwise undocumented debug switches that are also recognized. + +package Switch.B is + + procedure Scan_Binder_Switches (Switch_Chars : String); + -- Procedures to scan out binder switches stored in the given string. + -- The first character is known to be a valid switch character, and there + -- are no blanks or other switch terminator characters in the string, so + -- the entire string should consist of valid switch characters, except that + -- an optional terminating NUL character is allowed. A bad switch causes + -- a fatal error exit and control does not return. The call also sets + -- Usage_Requested to True if a ? switch is encountered. + +end Switch.B; diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb new file mode 100644 index 000000000..a4423dc31 --- /dev/null +++ b/gcc/ada/switch-c.adb @@ -0,0 +1,1179 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S W I T C H - C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Debug; use Debug; +with Lib; use Lib; +with Osint; use Osint; +with Opt; use Opt; +with Prepcomp; use Prepcomp; +with Validsw; use Validsw; +with Sem_Warn; use Sem_Warn; +with Stylesw; use Stylesw; + +with System.Strings; +with System.WCh_Con; use System.WCh_Con; + +package body Switch.C is + + RTS_Specified : String_Access := null; + -- Used to detect multiple use of --RTS= flag + + function Switch_Subsequently_Cancelled + (C : String; + Args : Argument_List; + Arg_Rank : Positive) return Boolean; + -- This function is called from Scan_Front_End_Switches. It determines if + -- the switch currently being scanned is followed by a switch of the form + -- "-gnat-" & C, where C is the argument. If so, then True is returned, + -- and Scan_Front_End_Switches will cancel the effect of the switch. If + -- no such switch is found, False is returned. + + ----------------------------- + -- Scan_Front_End_Switches -- + ----------------------------- + + procedure Scan_Front_End_Switches + (Switch_Chars : String; + Args : Argument_List; + Arg_Rank : Positive) + is + First_Switch : Boolean := True; + -- False for all but first switch + + Max : constant Natural := Switch_Chars'Last; + Ptr : Natural; + C : Character := ' '; + Dot : Boolean; + + Store_Switch : Boolean; + -- For -gnatxx switches, the normal processing, signalled by this flag + -- being set to True, is to store the switch on exit from the case + -- statement, the switch stored is -gnat followed by the characters + -- from First_Char to Ptr-1. For cases like -gnaty, where the switch + -- is stored in separate pieces, this flag is set to False, and the + -- appropriate calls to Store_Compilation_Switch are made from within + -- the case branch. + + First_Char : Positive; + -- Marks start of switch to be stored + + begin + Ptr := Switch_Chars'First; + + -- Skip past the initial character (must be the switch character) + + if Ptr = Max then + Bad_Switch (C); + else + Ptr := Ptr + 1; + end if; + + -- Handle switches that do not start with -gnat + + if Ptr + 3 > Max + or else Switch_Chars (Ptr .. Ptr + 3) /= "gnat" + then + -- There are two front-end switches that do not start with -gnat: + -- -I, --RTS + + if Switch_Chars (Ptr) = 'I' then + + -- Set flag Search_Directory_Present if switch is "-I" only: + -- the directory will be the next argument. + + if Ptr = Max then + Search_Directory_Present := True; + return; + end if; + + Ptr := Ptr + 1; + + -- Find out whether this is a -I- or regular -Ixxx switch + + -- Note: -I switches are not recorded in the ALI file, since the + -- meaning of the program depends on the source files compiled, + -- not where they came from. + + if Ptr = Max and then Switch_Chars (Ptr) = '-' then + Look_In_Primary_Dir := False; + else + Add_Src_Search_Dir (Switch_Chars (Ptr .. Max)); + end if; + + -- Processing of the --RTS switch. --RTS may have been modified by + -- gcc into -fRTS (for GCC targets). + + elsif Ptr + 3 <= Max + and then (Switch_Chars (Ptr .. Ptr + 3) = "fRTS" + or else + Switch_Chars (Ptr .. Ptr + 3) = "-RTS") + then + Ptr := Ptr + 1; + + if Ptr + 4 > Max + or else Switch_Chars (Ptr + 3) /= '=' + then + Osint.Fail ("missing path for --RTS"); + else + -- Check that this is the first time --RTS is specified or if + -- it is not the first time, the same path has been specified. + + if RTS_Specified = null then + RTS_Specified := new String'(Switch_Chars (Ptr + 4 .. Max)); + + elsif + RTS_Specified.all /= Switch_Chars (Ptr + 4 .. Max) + then + Osint.Fail ("--RTS cannot be specified multiple times"); + end if; + + -- Valid --RTS switch + + Opt.No_Stdinc := True; + Opt.RTS_Switch := True; + + RTS_Src_Path_Name := + Get_RTS_Search_Dir + (Switch_Chars (Ptr + 4 .. Max), Include); + + RTS_Lib_Path_Name := + Get_RTS_Search_Dir + (Switch_Chars (Ptr + 4 .. Max), Objects); + + if RTS_Src_Path_Name /= null + and then RTS_Lib_Path_Name /= null + then + -- Store the -fRTS switch (Note: Store_Compilation_Switch + -- changes -fRTS back into --RTS for the actual output). + + Store_Compilation_Switch (Switch_Chars); + + elsif RTS_Src_Path_Name = null + and then RTS_Lib_Path_Name = null + then + Osint.Fail ("RTS path not valid: missing " & + "adainclude and adalib directories"); + + elsif RTS_Src_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adainclude directory"); + + elsif RTS_Lib_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adalib directory"); + end if; + end if; + + -- There are no other switches not starting with -gnat + + else + Bad_Switch (Switch_Chars); + end if; + + -- Case of switch starting with -gnat + + else + Ptr := Ptr + 4; + + -- Loop to scan through switches given in switch string + + while Ptr <= Max loop + First_Char := Ptr; + Store_Switch := True; + + C := Switch_Chars (Ptr); + + case C is + + when 'a' => + Ptr := Ptr + 1; + Assertions_Enabled := True; + Debug_Pragmas_Enabled := True; + + -- Processing for A switch + + when 'A' => + Ptr := Ptr + 1; + Config_File := False; + + -- Processing for b switch + + when 'b' => + Ptr := Ptr + 1; + Brief_Output := True; + + -- Processing for B switch + + when 'B' => + Ptr := Ptr + 1; + Assume_No_Invalid_Values := True; + + -- Processing for c switch + + when 'c' => + if not First_Switch then + Osint.Fail + ("-gnatc must be first if combined with other switches"); + end if; + + Ptr := Ptr + 1; + Operating_Mode := Check_Semantics; + + -- Processing for C switch + + when 'C' => + Ptr := Ptr + 1; + + if not CodePeer_Mode then + CodePeer_Mode := True; + + -- Suppress compiler warnings by default, since what we are + -- interested in here is what CodePeer can find out. Note + -- that if -gnatwxxx is specified after -gnatC on the + -- command line, we do not want to override this setting in + -- Adjust_Global_Switches, and assume that the user wants to + -- get both warnings from GNAT and CodePeer messages. + + Warning_Mode := Suppress; + end if; + + -- Processing for d switch + + when 'd' => + Store_Switch := False; + Dot := False; + + -- Note: for the debug switch, the remaining characters in this + -- switch field must all be debug flags, since all valid switch + -- characters are also valid debug characters. + + -- Loop to scan out debug flags + + while Ptr < Max loop + Ptr := Ptr + 1; + C := Switch_Chars (Ptr); + exit when C = ASCII.NUL or else C = '/' or else C = '-'; + + if C in '1' .. '9' or else + C in 'a' .. 'z' or else + C in 'A' .. 'Z' + then + if Dot then + Set_Dotted_Debug_Flag (C); + Store_Compilation_Switch ("-gnatd." & C); + else + Set_Debug_Flag (C); + Store_Compilation_Switch ("-gnatd" & C); + end if; + + elsif C = '.' then + Dot := True; + + elsif Dot then + Bad_Switch ("-gnatd." & Switch_Chars (Ptr .. Max)); + else + Bad_Switch ("-gnatd" & Switch_Chars (Ptr .. Max)); + end if; + end loop; + + return; + + -- Processing for D switch + + when 'D' => + Ptr := Ptr + 1; + + -- Scan optional integer line limit value + + if Nat_Present (Switch_Chars, Max, Ptr) then + Scan_Nat (Switch_Chars, Max, Ptr, Sprint_Line_Limit, 'D'); + Sprint_Line_Limit := Nat'Max (Sprint_Line_Limit, 40); + end if; + + -- Note: -gnatD also sets -gnatx (to turn off cross-reference + -- generation in the ali file) since otherwise this generation + -- gets confused by the "wrong" Sloc values put in the tree. + + Debug_Generated_Code := True; + Xref_Active := False; + Set_Debug_Flag ('g'); + + -- -gnate? (extended switches) + + when 'e' => + Ptr := Ptr + 1; + + -- The -gnate? switches are all double character switches + -- so we must always have a character after the e. + + if Ptr > Max then + Bad_Switch ("-gnate"); + end if; + + case Switch_Chars (Ptr) is + + -- -gnatea (initial delimiter of explicit switches) + + -- All switches that come before -gnatea have been added by + -- the GCC driver and are not stored in the ALI file. + -- See also -gnatez below. + + when 'a' => + Store_Switch := False; + Enable_Switch_Storing; + Ptr := Ptr + 1; + + -- -gnatec (configuration pragmas) + + when 'c' => + Store_Switch := False; + Ptr := Ptr + 1; + + -- There may be an equal sign between -gnatec and + -- the path name of the config file. + + if Ptr <= Max and then Switch_Chars (Ptr) = '=' then + Ptr := Ptr + 1; + end if; + + if Ptr > Max then + Bad_Switch ("-gnatec"); + end if; + + declare + Config_File_Name : constant String_Access := + new String' + (Switch_Chars (Ptr .. Max)); + + begin + if Config_File_Names = null then + Config_File_Names := + new String_List'(1 => Config_File_Name); + + else + declare + New_Names : constant String_List_Access := + new String_List + (1 .. + Config_File_Names'Length + 1); + + begin + for Index in Config_File_Names'Range loop + New_Names (Index) := + Config_File_Names (Index); + Config_File_Names (Index) := null; + end loop; + + New_Names (New_Names'Last) := Config_File_Name; + Free (Config_File_Names); + Config_File_Names := New_Names; + end; + end if; + end; + + return; + + -- -gnateC switch (CodePeer SCIL generation) + + -- Not enabled for now, keep it for later??? + -- use -gnatd.I only for now + + -- when 'C' => + -- Ptr := Ptr + 1; + -- Generate_SCIL := True; + + -- -gnateD switch (preprocessing symbol definition) + + when 'D' => + Store_Switch := False; + Ptr := Ptr + 1; + + if Ptr > Max then + Bad_Switch ("-gnateD"); + end if; + + Add_Symbol_Definition (Switch_Chars (Ptr .. Max)); + + -- Store the switch + + Store_Compilation_Switch + ("-gnateD" & Switch_Chars (Ptr .. Max)); + Ptr := Max + 1; + + -- -gnateE (extra exception information) + + when 'E' => + Exception_Extra_Info := True; + Ptr := Ptr + 1; + + -- -gnatef (full source path for brief error messages) + + when 'f' => + Store_Switch := False; + Ptr := Ptr + 1; + Full_Path_Name_For_Brief_Errors := True; + + -- -gnateG (save preprocessor output) + + when 'G' => + Generate_Processed_File := True; + Ptr := Ptr + 1; + + -- -gnateI (index of unit in multi-unit source) + + when 'I' => + Ptr := Ptr + 1; + Scan_Pos (Switch_Chars, Max, Ptr, Multiple_Unit_Index, C); + + -- -gnatem (mapping file) + + when 'm' => + Store_Switch := False; + Ptr := Ptr + 1; + + -- There may be an equal sign between -gnatem and + -- the path name of the mapping file. + + if Ptr <= Max and then Switch_Chars (Ptr) = '=' then + Ptr := Ptr + 1; + end if; + + if Ptr > Max then + Bad_Switch ("-gnatem"); + end if; + + Mapping_File_Name := + new String'(Switch_Chars (Ptr .. Max)); + return; + + -- -gnatep (preprocessing data file) + + when 'p' => + Store_Switch := False; + Ptr := Ptr + 1; + + -- There may be an equal sign between -gnatep and + -- the path name of the mapping file. + + if Ptr <= Max and then Switch_Chars (Ptr) = '=' then + Ptr := Ptr + 1; + end if; + + if Ptr > Max then + Bad_Switch ("-gnatep"); + end if; + + Preprocessing_Data_File := + new String'(Switch_Chars (Ptr .. Max)); + + -- Store the switch, normalizing to -gnatep= + + Store_Compilation_Switch + ("-gnatep=" & Preprocessing_Data_File.all); + + Ptr := Max + 1; + + -- -gnateP (Treat pragma Pure/Preelaborate errs as warnings) + + when 'P' => + Treat_Categorization_Errors_As_Warnings := True; + + -- -gnatez (final delimiter of explicit switches) + + -- All switches that come after -gnatez have been added by + -- the GCC driver and are not stored in the ALI file. See + -- also -gnatea above. + + when 'z' => + Store_Switch := False; + Disable_Switch_Storing; + Ptr := Ptr + 1; + + -- -gnateS (generate SCO information) + + -- Include Source Coverage Obligation information in ALI + -- files for the benefit of source coverage analysis tools + -- (xcov). + + when 'S' => + Generate_SCO := True; + Ptr := Ptr + 1; + + -- All other -gnate? switches are unassigned + + when others => + Bad_Switch ("-gnate" & Switch_Chars (Ptr .. Max)); + end case; + + -- -gnatE (dynamic elaboration checks) + + when 'E' => + Ptr := Ptr + 1; + Dynamic_Elaboration_Checks := True; + + -- -gnatf (full error messages) + + when 'f' => + Ptr := Ptr + 1; + All_Errors_Mode := True; + + -- Processing for F switch + + when 'F' => + Ptr := Ptr + 1; + External_Name_Exp_Casing := Uppercase; + External_Name_Imp_Casing := Uppercase; + + -- Processing for g switch + + when 'g' => + Ptr := Ptr + 1; + GNAT_Mode := True; + Identifier_Character_Set := 'n'; + System_Extend_Unit := Empty; + Warning_Mode := Treat_As_Error; + + -- Set Ada 2012 mode explicitly. We don't want to rely on the + -- implicit setting here, since for example, we want + -- Preelaborate_05 treated as Preelaborate + + Ada_Version := Ada_2012; + Ada_Version_Explicit := Ada_Version; + + -- Set default warnings and style checks for -gnatg + + Set_GNAT_Mode_Warnings; + Set_GNAT_Style_Check_Options; + + -- Processing for G switch + + when 'G' => + Ptr := Ptr + 1; + Print_Generated_Code := True; + + -- Scan optional integer line limit value + + if Nat_Present (Switch_Chars, Max, Ptr) then + Scan_Nat (Switch_Chars, Max, Ptr, Sprint_Line_Limit, 'G'); + Sprint_Line_Limit := Nat'Max (Sprint_Line_Limit, 40); + end if; + + -- Processing for h switch + + when 'h' => + Ptr := Ptr + 1; + Usage_Requested := True; + + -- Processing for H switch + + when 'H' => + Ptr := Ptr + 1; + HLO_Active := True; + + -- Processing for i switch + + when 'i' => + if Ptr = Max then + Bad_Switch ("-gnati"); + end if; + + Ptr := Ptr + 1; + C := Switch_Chars (Ptr); + + if C in '1' .. '5' + or else C = '8' + or else C = '9' + or else C = 'p' + or else C = 'f' + or else C = 'n' + or else C = 'w' + then + Identifier_Character_Set := C; + Ptr := Ptr + 1; + + else + Bad_Switch ("-gnati" & Switch_Chars (Ptr .. Max)); + end if; + + -- Processing for I switch + + when 'I' => + Ptr := Ptr + 1; + Ignore_Rep_Clauses := True; + + -- Processing for j switch + + when 'j' => + Ptr := Ptr + 1; + Scan_Nat (Switch_Chars, Max, Ptr, Error_Msg_Line_Length, C); + + -- Processing for k switch + + when 'k' => + Ptr := Ptr + 1; + Scan_Pos + (Switch_Chars, Max, Ptr, Maximum_File_Name_Length, C); + + -- Processing for l switch + + when 'l' => + Ptr := Ptr + 1; + Full_List := True; + + -- There may be an equal sign between -gnatl and a file name + + if Ptr <= Max and then Switch_Chars (Ptr) = '=' then + if Ptr = Max then + Osint.Fail ("file name for -gnatl= is null"); + else + Opt.Full_List_File_Name := + new String'(Switch_Chars (Ptr + 1 .. Max)); + Ptr := Max + 1; + end if; + end if; + + -- Processing for L switch + + when 'L' => + Ptr := Ptr + 1; + Dump_Source_Text := True; + + -- Processing for m switch + + when 'm' => + Ptr := Ptr + 1; + Scan_Nat (Switch_Chars, Max, Ptr, Maximum_Messages, C); + + -- Processing for n switch + + when 'n' => + Ptr := Ptr + 1; + Inline_Active := True; + + -- Processing for N switch + + when 'N' => + Ptr := Ptr + 1; + Inline_Active := True; + Front_End_Inlining := True; + + -- Processing for o switch + + when 'o' => + Ptr := Ptr + 1; + Suppress_Options (Overflow_Check) := False; + Opt.Enable_Overflow_Checks := True; + + -- Processing for O switch + + when 'O' => + Store_Switch := False; + Ptr := Ptr + 1; + Output_File_Name_Present := True; + + -- Processing for p switch + + when 'p' => + Ptr := Ptr + 1; + + -- Skip processing if cancelled by subsequent -gnat-p + + if Switch_Subsequently_Cancelled ("p", Args, Arg_Rank) then + Store_Switch := False; + + else + -- Set all specific options as well as All_Checks in the + -- Suppress_Options array, excluding Elaboration_Check, + -- since this is treated specially because we do not want + -- -gnatp to disable static elaboration processing. + + for J in Suppress_Options'Range loop + if J /= Elaboration_Check then + Suppress_Options (J) := True; + end if; + end loop; + + Validity_Checks_On := False; + Opt.Suppress_Checks := True; + Opt.Enable_Overflow_Checks := False; + end if; + + -- Processing for P switch + + when 'P' => + Ptr := Ptr + 1; + Polling_Required := True; + + -- Processing for q switch + + when 'q' => + Ptr := Ptr + 1; + Try_Semantics := True; + + -- Processing for Q switch + + when 'Q' => + Ptr := Ptr + 1; + Force_ALI_Tree_File := True; + Try_Semantics := True; + + -- Processing for r switch + + when 'r' => + Ptr := Ptr + 1; + Treat_Restrictions_As_Warnings := True; + + -- Processing for R switch + + when 'R' => + Back_Annotate_Rep_Info := True; + List_Representation_Info := 1; + + Ptr := Ptr + 1; + while Ptr <= Max loop + C := Switch_Chars (Ptr); + + if C in '1' .. '3' then + List_Representation_Info := + Character'Pos (C) - Character'Pos ('0'); + + elsif Switch_Chars (Ptr) = 's' then + List_Representation_Info_To_File := True; + + elsif Switch_Chars (Ptr) = 'm' then + List_Representation_Info_Mechanisms := True; + + else + Bad_Switch ("-gnatR" & Switch_Chars (Ptr .. Max)); + end if; + + Ptr := Ptr + 1; + end loop; + + -- Processing for s switch + + when 's' => + if not First_Switch then + Osint.Fail + ("-gnats must be first if combined with other switches"); + end if; + + Ptr := Ptr + 1; + Operating_Mode := Check_Syntax; + + -- Processing for S switch + + when 'S' => + Print_Standard := True; + Ptr := Ptr + 1; + + -- Processing for t switch + + when 't' => + Ptr := Ptr + 1; + Tree_Output := True; + Back_Annotate_Rep_Info := True; + + -- Processing for T switch + + when 'T' => + Ptr := Ptr + 1; + Scan_Pos (Switch_Chars, Max, Ptr, Table_Factor, C); + + -- Processing for u switch + + when 'u' => + Ptr := Ptr + 1; + List_Units := True; + + -- Processing for U switch + + when 'U' => + Ptr := Ptr + 1; + Unique_Error_Tag := True; + + -- Processing for v switch + + when 'v' => + Ptr := Ptr + 1; + Verbose_Mode := True; + + -- Processing for V switch + + when 'V' => + Store_Switch := False; + Ptr := Ptr + 1; + + if Ptr > Max then + Bad_Switch ("-gnatV"); + + else + declare + OK : Boolean; + + begin + Set_Validity_Check_Options + (Switch_Chars (Ptr .. Max), OK, Ptr); + + if not OK then + Bad_Switch ("-gnatV" & Switch_Chars (Ptr .. Max)); + end if; + + for Index in First_Char + 1 .. Max loop + Store_Compilation_Switch + ("-gnatV" & Switch_Chars (Index)); + end loop; + end; + end if; + + Ptr := Max + 1; + + -- Processing for w switch + + when 'w' => + Store_Switch := False; + Ptr := Ptr + 1; + + if Ptr > Max then + Bad_Switch ("-gnatw"); + end if; + + while Ptr <= Max loop + C := Switch_Chars (Ptr); + + -- Case of dot switch + + if C = '.' and then Ptr < Max then + Ptr := Ptr + 1; + C := Switch_Chars (Ptr); + + if Set_Dot_Warning_Switch (C) then + Store_Compilation_Switch ("-gnatw." & C); + else + Bad_Switch ("-gnatw." & Switch_Chars (Ptr .. Max)); + end if; + + -- Normal case, no dot + + else + if Set_Warning_Switch (C) then + Store_Compilation_Switch ("-gnatw" & C); + else + Bad_Switch ("-gnatw" & Switch_Chars (Ptr .. Max)); + end if; + end if; + + Ptr := Ptr + 1; + end loop; + + return; + + -- Processing for W switch + + when 'W' => + Ptr := Ptr + 1; + + if Ptr > Max then + Bad_Switch ("-gnatW"); + end if; + + begin + Wide_Character_Encoding_Method := + Get_WC_Encoding_Method (Switch_Chars (Ptr)); + exception + when Constraint_Error => + Bad_Switch ("-gnatW" & Switch_Chars (Ptr .. Max)); + end; + + Wide_Character_Encoding_Method_Specified := True; + + Upper_Half_Encoding := + Wide_Character_Encoding_Method in + WC_Upper_Half_Encoding_Method; + + Ptr := Ptr + 1; + + -- Processing for x switch + + when 'x' => + Ptr := Ptr + 1; + Xref_Active := False; + + -- Processing for X switch + + when 'X' => + Ptr := Ptr + 1; + Extensions_Allowed := True; + Ada_Version := Ada_Version_Type'Last; + Ada_Version_Explicit := Ada_Version_Type'Last; + + -- Processing for y switch + + when 'y' => + Ptr := Ptr + 1; + + if Ptr > Max then + Set_Default_Style_Check_Options; + + else + Store_Switch := False; + + declare + OK : Boolean; + + begin + Set_Style_Check_Options + (Switch_Chars (Ptr .. Max), OK, Ptr); + + if not OK then + Osint.Fail + ("bad -gnaty switch (" & + Style_Msg_Buf (1 .. Style_Msg_Len) & ')'); + end if; + + Ptr := First_Char + 1; + while Ptr <= Max loop + if Switch_Chars (Ptr) = 'M' then + First_Char := Ptr; + loop + Ptr := Ptr + 1; + exit when Ptr > Max + or else Switch_Chars (Ptr) not in '0' .. '9'; + end loop; + + Store_Compilation_Switch + ("-gnaty" & Switch_Chars (First_Char .. Ptr - 1)); + + else + Store_Compilation_Switch + ("-gnaty" & Switch_Chars (Ptr)); + Ptr := Ptr + 1; + end if; + end loop; + end; + end if; + + -- Processing for z switch + + when 'z' => + + -- -gnatz must be the first and only switch in Switch_Chars, + -- and is a two-letter switch. + + if Ptr /= Switch_Chars'First + 5 + or else (Max - Ptr + 1) > 2 + then + Osint.Fail + ("-gnatz* may not be combined with other switches"); + end if; + + if Ptr = Max then + Bad_Switch ("-gnatz"); + end if; + + Ptr := Ptr + 1; + + -- Only one occurrence of -gnat* is permitted + + if Distribution_Stub_Mode = No_Stubs then + case Switch_Chars (Ptr) is + when 'r' => + Distribution_Stub_Mode := Generate_Receiver_Stub_Body; + + when 'c' => + Distribution_Stub_Mode := Generate_Caller_Stub_Body; + + when others => + Bad_Switch ("-gnatz" & Switch_Chars (Ptr .. Max)); + end case; + + Ptr := Ptr + 1; + + else + Osint.Fail ("only one -gnatz* switch allowed"); + end if; + + -- Processing for Z switch + + when 'Z' => + Ptr := Ptr + 1; + Osint.Fail + ("-gnatZ is no longer supported: consider using --RTS=zcx"); + + -- Processing for 83 switch + + when '8' => + if Ptr = Max then + Bad_Switch ("-gnat8"); + end if; + + Ptr := Ptr + 1; + + if Switch_Chars (Ptr) /= '3' then + Bad_Switch ("-gnat8" & Switch_Chars (Ptr .. Max)); + else + Ptr := Ptr + 1; + Ada_Version := Ada_83; + Ada_Version_Explicit := Ada_Version; + end if; + + -- Processing for 95 switch + + when '9' => + if Ptr = Max then + Bad_Switch ("-gnat9"); + end if; + + Ptr := Ptr + 1; + + if Switch_Chars (Ptr) /= '5' then + Bad_Switch ("-gnat9" & Switch_Chars (Ptr .. Max)); + else + Ptr := Ptr + 1; + Ada_Version := Ada_95; + Ada_Version_Explicit := Ada_Version; + end if; + + -- Processing for 05 switch + + when '0' => + if Ptr = Max then + Bad_Switch ("-gnat0"); + end if; + + Ptr := Ptr + 1; + + if Switch_Chars (Ptr) /= '5' then + Bad_Switch ("-gnat0" & Switch_Chars (Ptr .. Max)); + else + Ptr := Ptr + 1; + Ada_Version := Ada_2005; + Ada_Version_Explicit := Ada_Version; + end if; + + -- Processing for 12 switch + + when '1' => + if Ptr = Max then + Bad_Switch ("-gnat1"); + end if; + + Ptr := Ptr + 1; + + if Switch_Chars (Ptr) /= '2' then + Bad_Switch ("-gnat1" & Switch_Chars (Ptr .. Max)); + else + Ptr := Ptr + 1; + Ada_Version := Ada_2012; + Ada_Version_Explicit := Ada_Version; + end if; + + -- Processing for 2005 and 2012 switches + + when '2' => + if Ptr > Max - 3 then + Bad_Switch ("-gnat" & Switch_Chars (Ptr .. Max)); + + elsif Switch_Chars (Ptr .. Ptr + 3) = "2005" then + Ada_Version := Ada_2005; + + elsif Switch_Chars (Ptr .. Ptr + 3) = "2012" then + Ada_Version := Ada_2012; + + else + Bad_Switch ("-gnat" & Switch_Chars (Ptr .. Ptr + 3)); + end if; + + Ada_Version_Explicit := Ada_Version; + Ptr := Ptr + 4; + + -- Switch cancellation, currently only -gnat-p is allowed. + -- All we do here is the error checking, since the actual + -- processing for switch cancellation is done by calls to + -- Switch_Subsequently_Cancelled at the appropriate point. + + when '-' => + + -- Simple ignore -gnat-p + + if Switch_Chars = "-gnat-p" then + return; + + -- Any other occurrence of minus is ignored. This is for + -- maximum compatibility with previous version which ignored + -- all occurrences of minus. + + else + Store_Switch := False; + Ptr := Ptr + 1; + end if; + + -- We ignore '/' in switches, this is historical, still needed??? + + when '/' => + Store_Switch := False; + + -- Anything else is an error (illegal switch character) + + when others => + Bad_Switch ("-gnat" & Switch_Chars (Ptr .. Max)); + end case; + + if Store_Switch then + Store_Compilation_Switch + ("-gnat" & Switch_Chars (First_Char .. Ptr - 1)); + end if; + + First_Switch := False; + end loop; + end if; + end Scan_Front_End_Switches; + + ----------------------------------- + -- Switch_Subsequently_Cancelled -- + ----------------------------------- + + function Switch_Subsequently_Cancelled + (C : String; + Args : Argument_List; + Arg_Rank : Positive) return Boolean + is + use type System.Strings.String_Access; + + begin + -- Loop through arguments following the current one + + for Arg in Arg_Rank + 1 .. Args'Last loop + if Args (Arg).all = "-gnat-" & C then + return True; + end if; + end loop; + + -- No match found, not cancelled + + return False; + end Switch_Subsequently_Cancelled; + +end Switch.C; diff --git a/gcc/ada/switch-c.ads b/gcc/ada/switch-c.ads new file mode 100644 index 000000000..1595858a2 --- /dev/null +++ b/gcc/ada/switch-c.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S W I T C H - C -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package scans front end switches. Note that the body of Usage must be +-- coordinated with the switches that are recognized by this package. +-- The Usage package also acts as the official documentation for the +-- switches that are recognized. In addition, package Debug documents +-- the otherwise undocumented debug switches that are also recognized. + +with System.OS_Lib; use System.OS_Lib; + +package Switch.C is + + procedure Scan_Front_End_Switches + (Switch_Chars : String; + Args : Argument_List; + Arg_Rank : Positive); + -- Procedures to scan out front end switches stored in the given string. + -- The first character is known to be a valid switch character, and there + -- are no blanks or other switch terminator characters in the string, so + -- the entire string should consist of valid switch characters, except that + -- an optional terminating NUL character is allowed. A bad switch causes + -- a fatal error exit and control does not return. The call also sets + -- Usage_Requested to True if a switch -gnath is encountered. + -- + -- Args is the full list of command line arguments. Arg_Rank is the + -- position of the switch in Args. It is used for certain switches -gnatx + -- to check if a subsequent switch -gnat-x cancels the switch -gnatx. + +end Switch.C; diff --git a/gcc/ada/switch-m.adb b/gcc/ada/switch-m.adb new file mode 100644 index 000000000..ab775b53f --- /dev/null +++ b/gcc/ada/switch-m.adb @@ -0,0 +1,949 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S W I T C H - M -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Debug; use Debug; +with Makeutl; use Makeutl; +with Osint; use Osint; +with Opt; use Opt; +with Prj; use Prj; +with Prj.Env; use Prj.Env; +with Table; + +with System.Multiprocessors; use System.Multiprocessors; + +package body Switch.M is + + package Normalized_Switches is new Table.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Switch.M.Normalized_Switches"); + -- This table is used to keep the normalized switches, so that they may be + -- reused for subsequent invocations of Normalize_Compiler_Switches with + -- similar switches. + + Initial_Number_Of_Switches : constant := 10; + + Global_Switches : Argument_List_Access := null; + -- Used by function Normalize_Compiler_Switches + + --------------------------------- + -- Normalize_Compiler_Switches -- + --------------------------------- + + procedure Normalize_Compiler_Switches + (Switch_Chars : String; + Switches : in out Argument_List_Access; + Last : out Natural) + is + Switch_Starts_With_Gnat : Boolean; + + Ptr : Integer := Switch_Chars'First; + Max : constant Integer := Switch_Chars'Last; + C : Character := ' '; + + Storing : String := Switch_Chars; + First_Stored : Positive := Ptr + 1; + Last_Stored : Positive := First_Stored; + + procedure Add_Switch_Component (S : String); + -- Add a new String_Access component in Switches. If a string equal + -- to S is already stored in the table Normalized_Switches, use it. + -- Otherwise add a new component to the table. + + -------------------------- + -- Add_Switch_Component -- + -------------------------- + + procedure Add_Switch_Component (S : String) is + begin + -- If Switches is null, allocate a new array + + if Switches = null then + Switches := new Argument_List (1 .. Initial_Number_Of_Switches); + + -- Otherwise, if Switches is full, extend it + + elsif Last = Switches'Last then + declare + New_Switches : constant Argument_List_Access := + new Argument_List + (1 .. Switches'Length + Switches'Length); + begin + New_Switches (1 .. Switches'Length) := Switches.all; + Last := Switches'Length; + Switches := New_Switches; + end; + end if; + + -- If this is the first switch, Last designates the first component + + if Last = 0 then + Last := Switches'First; + else + Last := Last + 1; + end if; + + -- Look into the table Normalized_Switches for a similar string. + -- If one is found, put it at the added component, and return. + + for Index in 1 .. Normalized_Switches.Last loop + if S = Normalized_Switches.Table (Index).all then + Switches (Last) := Normalized_Switches.Table (Index); + return; + end if; + end loop; + + -- No string equal to S was found in the table Normalized_Switches. + -- Add a new component in the table. + + Switches (Last) := new String'(S); + Normalized_Switches.Append (Switches (Last)); + end Add_Switch_Component; + + -- Start of processing for Normalize_Compiler_Switches + + begin + Last := 0; + + if Ptr = Max or else Switch_Chars (Ptr) /= '-' then + return; + end if; + + Ptr := Ptr + 1; + + Switch_Starts_With_Gnat := + Ptr + 3 <= Max and then Switch_Chars (Ptr .. Ptr + 3) = "gnat"; + + if Switch_Starts_With_Gnat then + Ptr := Ptr + 4; + First_Stored := Ptr; + end if; + + while Ptr <= Max loop + C := Switch_Chars (Ptr); + + -- Processing for a switch + + case Switch_Starts_With_Gnat is + + when False => + + -- All switches that don't start with -gnat stay as is, + -- except -pg, -Wall, -k8, -w + + if Switch_Chars = "-pg" or else Switch_Chars = "-p" then + + -- The gcc driver converts -pg to -p, so that is what + -- is stored in the ALI file. + + Add_Switch_Component ("-p"); + + elsif Switch_Chars = "-Wall" then + + -- The gcc driver adds -gnatwa when -Wall is used + + Add_Switch_Component ("-gnatwa"); + Add_Switch_Component ("-Wall"); + + elsif Switch_Chars = "-k8" then + + -- The gcc driver transforms -k8 into -gnatk8 + + Add_Switch_Component ("-gnatk8"); + + elsif Switch_Chars = "-w" then + + -- The gcc driver adds -gnatws when -w is used + + Add_Switch_Component ("-gnatws"); + Add_Switch_Component ("-w"); + + elsif Switch_Chars'Length > 6 + and then + Switch_Chars (Switch_Chars'First .. Switch_Chars'First + 5) + = "--RTS=" + then + Add_Switch_Component (Switch_Chars); + + -- When --RTS=mtp is used, the gcc driver adds -mrtp + + if Switch_Chars = "--RTS=mtp" then + Add_Switch_Component ("-mrtp"); + end if; + + -- Take only into account switches that are transmitted to + -- gnat1 by the gcc driver and stored by gnat1 in the ALI file. + + else + case C is + when 'O' | 'W' | 'w' | 'f' | 'd' | 'g' | 'm' => + Add_Switch_Component (Switch_Chars); + + when others => + null; + end case; + end if; + + return; + + when True => + + case C is + + -- One-letter switches + + when 'a' | 'A' | 'b' | 'B' | 'c' | 'C' | 'E' | 'f' | + 'F' | 'g' | 'h' | 'H' | 'I' | 'L' | 'n' | 'N' | + 'o' | 'p' | 'P' | 'q' | 'Q' | 'r' | 's' | 'S' | + 't' | 'u' | 'U' | 'v' | 'x' | 'X' | 'Z' => + Storing (First_Stored) := C; + Add_Switch_Component + (Storing (Storing'First .. First_Stored)); + Ptr := Ptr + 1; + + -- One-letter switches followed by a positive number + + when 'D' | 'G' | 'j' | 'k' | 'm' | 'T' => + Storing (First_Stored) := C; + Last_Stored := First_Stored; + + if Ptr <= Max and then Switch_Chars (Ptr) = '=' then + Ptr := Ptr + 1; + end if; + + loop + Ptr := Ptr + 1; + exit when Ptr > Max + or else Switch_Chars (Ptr) not in '0' .. '9'; + Last_Stored := Last_Stored + 1; + Storing (Last_Stored) := Switch_Chars (Ptr); + end loop; + + Add_Switch_Component + (Storing (Storing'First .. Last_Stored)); + + when 'd' => + Storing (First_Stored) := 'd'; + + while Ptr < Max loop + Ptr := Ptr + 1; + C := Switch_Chars (Ptr); + exit when C = ASCII.NUL or else C = '/' + or else C = '-'; + + if C in '1' .. '9' or else + C in 'a' .. 'z' or else + C in 'A' .. 'Z' + then + Storing (First_Stored + 1) := C; + Add_Switch_Component + (Storing (Storing'First .. First_Stored + 1)); + + else + Last := 0; + return; + end if; + end loop; + + return; + + when 'e' => + + -- Some of the gnate... switches are not stored + + Storing (First_Stored) := 'e'; + Ptr := Ptr + 1; + + if Ptr > Max then + Last := 0; + return; + + else + case Switch_Chars (Ptr) is + + when 'D' => + Storing (First_Stored + 1 .. + First_Stored + Max - Ptr + 1) := + Switch_Chars (Ptr .. Max); + Add_Switch_Component + (Storing (Storing'First .. + First_Stored + Max - Ptr + 1)); + Ptr := Max + 1; + + when 'G' => + Ptr := Ptr + 1; + Add_Switch_Component ("-gnateG"); + + when 'I' => + Ptr := Ptr + 1; + + declare + First : constant Positive := Ptr - 1; + begin + if Ptr <= Max and then + Switch_Chars (Ptr) = '=' + then + Ptr := Ptr + 1; + end if; + + while Ptr <= Max and then + Switch_Chars (Ptr) in '0' .. '9' + loop + Ptr := Ptr + 1; + end loop; + + Storing (First_Stored + 1 .. + First_Stored + Ptr - First) := + Switch_Chars (First .. Ptr - 1); + Add_Switch_Component + (Storing (Storing'First .. + First_Stored + Ptr - First)); + end; + + when 'p' => + Ptr := Ptr + 1; + + if Ptr = Max then + Last := 0; + return; + end if; + + if Switch_Chars (Ptr) = '=' then + Ptr := Ptr + 1; + end if; + + -- To normalize, always put a '=' after + -- -gnatep. Because that could lengthen the + -- switch string, declare a local variable. + + declare + To_Store : String (1 .. Max - Ptr + 9); + begin + To_Store (1 .. 8) := "-gnatep="; + To_Store (9 .. Max - Ptr + 9) := + Switch_Chars (Ptr .. Max); + Add_Switch_Component (To_Store); + end; + + return; + + when 'S' => + Ptr := Ptr + 1; + Add_Switch_Component ("-gnateS"); + + when others => + Last := 0; + return; + end case; + end if; + + when 'i' => + Storing (First_Stored) := 'i'; + + Ptr := Ptr + 1; + + if Ptr > Max then + Last := 0; + return; + end if; + + C := Switch_Chars (Ptr); + + if C in '1' .. '5' + or else C = '8' + or else C = 'p' + or else C = 'f' + or else C = 'n' + or else C = 'w' + then + Storing (First_Stored + 1) := C; + Add_Switch_Component + (Storing (Storing'First .. First_Stored + 1)); + Ptr := Ptr + 1; + + else + Last := 0; + return; + end if; + + -- -gnatl may be -gnatl= + + when 'l' => + Ptr := Ptr + 1; + + if Ptr > Max or else Switch_Chars (Ptr) /= '=' then + Add_Switch_Component ("-gnatl"); + + else + Add_Switch_Component + ("-gnatl" & Switch_Chars (Ptr .. Max)); + return; + end if; + + -- -gnatR may be followed by '0', '1', '2' or '3', + -- then by 's' + + when 'R' => + Last_Stored := First_Stored; + Storing (Last_Stored) := 'R'; + Ptr := Ptr + 1; + + if Ptr <= Max + and then Switch_Chars (Ptr) in '0' .. '9' + then + C := Switch_Chars (Ptr); + + if C in '4' .. '9' then + Last := 0; + return; + + else + Last_Stored := Last_Stored + 1; + Storing (Last_Stored) := C; + Ptr := Ptr + 1; + + if Ptr <= Max + and then Switch_Chars (Ptr) = 's' + then + Last_Stored := Last_Stored + 1; + Storing (Last_Stored) := 's'; + Ptr := Ptr + 1; + end if; + end if; + end if; + + Add_Switch_Component + (Storing (Storing'First .. Last_Stored)); + + -- -gnatWx, x = 'h'. 'u', 's', 'e', '8' or 'b' + + when 'W' => + Storing (First_Stored) := 'W'; + Ptr := Ptr + 1; + + if Ptr <= Max then + case Switch_Chars (Ptr) is + when 'h' | 'u' | 's' | 'e' | '8' | 'b' => + Storing (First_Stored + 1) := Switch_Chars (Ptr); + Add_Switch_Component + (Storing (Storing'First .. First_Stored + 1)); + Ptr := Ptr + 1; + + when others => + Last := 0; + return; + end case; + end if; + + -- Multiple switches + + when 'V' | 'w' | 'y' => + Storing (First_Stored) := C; + Ptr := Ptr + 1; + + if Ptr > Max then + if C = 'y' then + Add_Switch_Component + (Storing (Storing'First .. First_Stored)); + + else + Last := 0; + return; + end if; + end if; + + -- Loop through remaining switch characters in string + + while Ptr <= Max loop + C := Switch_Chars (Ptr); + Ptr := Ptr + 1; + + -- -gnatyMxxx + + if C = 'M' and then Storing (First_Stored) = 'y' then + Last_Stored := First_Stored + 1; + Storing (Last_Stored) := 'M'; + while Ptr <= Max loop + C := Switch_Chars (Ptr); + exit when C not in '0' .. '9'; + Last_Stored := Last_Stored + 1; + Storing (Last_Stored) := C; + Ptr := Ptr + 1; + end loop; + + -- If there is no digit after -gnatyM, + -- the switch is invalid. + + if Last_Stored = First_Stored + 1 then + Last := 0; + return; + + else + Add_Switch_Component + (Storing (Storing'First .. Last_Stored)); + end if; + + -- --gnatx.x + + elsif C = '.' and then Ptr <= Max then + Storing (First_Stored + 1) := '.'; + Storing (First_Stored + 2) := Switch_Chars (Ptr); + Ptr := Ptr + 1; + Add_Switch_Component + (Storing (Storing'First .. First_Stored + 2)); + + -- All other switches are -gnatxx + + else + Storing (First_Stored + 1) := C; + Add_Switch_Component + (Storing (Storing'First .. First_Stored + 1)); + end if; + end loop; + + -- -gnat95 -gnat05 + + when '0' | '9' => + Last_Stored := First_Stored; + Storing (Last_Stored) := C; + Ptr := Ptr + 1; + + if Ptr /= Max or else Switch_Chars (Ptr) /= '5' then + + -- Invalid switch + + Last := 0; + return; + + else + Last_Stored := Last_Stored + 1; + Storing (Last_Stored) := '5'; + Add_Switch_Component + (Storing (Storing'First .. Last_Stored)); + Ptr := Ptr + 1; + end if; + + -- -gnat83 + + when '8' => + Last_Stored := First_Stored; + Storing (Last_Stored) := '8'; + Ptr := Ptr + 1; + + if Ptr /= Max or else Switch_Chars (Ptr) /= '3' then + + -- Invalid switch + + Last := 0; + return; + + else + Last_Stored := Last_Stored + 1; + Storing (Last_Stored) := '3'; + Add_Switch_Component + (Storing (Storing'First .. Last_Stored)); + Ptr := Ptr + 1; + end if; + + -- Not a valid switch + + when others => + Last := 0; + return; + + end case; + + end case; + end loop; + end Normalize_Compiler_Switches; + + function Normalize_Compiler_Switches + (Switch_Chars : String) return Argument_List + is + Last : Natural; + + begin + Normalize_Compiler_Switches (Switch_Chars, Global_Switches, Last); + + if Last = 0 then + return (1 .. 0 => null); + else + return Global_Switches (Global_Switches'First .. Last); + end if; + end Normalize_Compiler_Switches; + + ------------------------ + -- Scan_Make_Switches -- + ------------------------ + + procedure Scan_Make_Switches + (Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref; + Switch_Chars : String; + Success : out Boolean) + is + Ptr : Integer := Switch_Chars'First; + Max : constant Integer := Switch_Chars'Last; + C : Character := ' '; + + begin + -- Assume a good switch + + Success := True; + + -- Skip past the initial character (must be the switch character) + + if Ptr = Max then + Bad_Switch (Switch_Chars); + + else + Ptr := Ptr + 1; + end if; + + -- A little check, "gnat" at the start of a switch is for the compiler + + if Switch_Chars'Length >= Ptr + 3 + and then Switch_Chars (Ptr .. Ptr + 3) = "gnat" + then + Success := False; + return; + end if; + + C := Switch_Chars (Ptr); + + -- Multiple character switches + + if Switch_Chars'Length > 2 then + if Switch_Chars = "--create-missing-dirs" then + Setup_Projects := True; + + elsif Switch_Chars'Length > Subdirs_Option'Length + and then + Switch_Chars + (Switch_Chars'First .. + Switch_Chars'First + Subdirs_Option'Length - 1) = + Subdirs_Option + then + Subdirs := + new String' + (Switch_Chars + (Switch_Chars'First + Subdirs_Option'Length .. + Switch_Chars'Last)); + + elsif Switch_Chars = Makeutl.Unchecked_Shared_Lib_Imports then + Opt.Unchecked_Shared_Lib_Imports := True; + + elsif Switch_Chars = Makeutl.Single_Compile_Per_Obj_Dir_Switch then + Opt.One_Compilation_Per_Obj_Dir := True; + + elsif Switch_Chars (Ptr) = '-' then + Bad_Switch (Switch_Chars); + + elsif Switch_Chars'Length > 3 + and then Switch_Chars (Ptr .. Ptr + 1) = "aP" + then + Add_Directories + (Project_Node_Tree.Project_Path, + Switch_Chars (Ptr + 2 .. Switch_Chars'Last)); + + elsif C = 'v' and then Switch_Chars'Length = 3 then + Ptr := Ptr + 1; + Verbose_Mode := True; + + case Switch_Chars (Ptr) is + when 'l' => + Verbosity_Level := Opt.Low; + + when 'm' => + Verbosity_Level := Opt.Medium; + + when 'h' => + Verbosity_Level := Opt.High; + + when others => + Success := False; + end case; + + elsif C = 'd' then + + -- Note: for the debug switch, the remaining characters in this + -- switch field must all be debug flags, since all valid switch + -- characters are also valid debug characters. This switch is not + -- documented on purpose because it is only used by the + -- implementors. + + -- Loop to scan out debug flags + + while Ptr < Max loop + Ptr := Ptr + 1; + C := Switch_Chars (Ptr); + + if C in 'a' .. 'z' or else C in 'A' .. 'Z' then + Set_Debug_Flag (C); + else + Bad_Switch (Switch_Chars); + end if; + end loop; + + elsif C = 'e' then + Ptr := Ptr + 1; + + case Switch_Chars (Ptr) is + + -- Processing for eI switch + + when 'I' => + Ptr := Ptr + 1; + Scan_Pos (Switch_Chars, Max, Ptr, Main_Index, C); + + if Ptr <= Max then + Bad_Switch (Switch_Chars); + end if; + + -- Processing for eL switch + + when 'L' => + if Ptr /= Max then + Bad_Switch (Switch_Chars); + + else + Follow_Links_For_Files := True; + Follow_Links_For_Dirs := True; + end if; + + -- Processing for eS switch + + when 'S' => + if Ptr /= Max then + Bad_Switch (Switch_Chars); + + else + Commands_To_Stdout := True; + end if; + + when others => + Bad_Switch (Switch_Chars); + end case; + + elsif C = 'j' then + Ptr := Ptr + 1; + + declare + Max_Proc : Nat; + + begin + Scan_Nat (Switch_Chars, Max, Ptr, Max_Proc, C); + + if Ptr <= Max then + Bad_Switch (Switch_Chars); + + else + if Max_Proc = 0 then + Max_Proc := Nat (Number_Of_CPUs); + + if Max_Proc = 0 then + Max_Proc := 1; + end if; + end if; + + Maximum_Processes := Positive (Max_Proc); + end if; + end; + + elsif C = 'w' and then Switch_Chars'Length = 3 then + Ptr := Ptr + 1; + + if Switch_Chars = "-we" then + Warning_Mode := Treat_As_Error; + + elsif Switch_Chars = "-wn" then + Warning_Mode := Normal; + + elsif Switch_Chars = "-ws" then + Warning_Mode := Suppress; + + else + Success := False; + end if; + + else + Success := False; + end if; + + -- Single-character switches + + else + Check_Switch : begin + + case C is + + when 'a' => + Check_Readonly_Files := True; + + -- Processing for b switch + + when 'b' => + Bind_Only := True; + Make_Steps := True; + + -- Processing for B switch + + when 'B' => + Build_Bind_And_Link_Full_Project := True; + + -- Processing for c switch + + when 'c' => + Compile_Only := True; + Make_Steps := True; + + -- Processing for C switch + + when 'C' => + Opt.Create_Mapping_File := True; + + -- Processing for D switch + + when 'D' => + if Object_Directory_Present then + Osint.Fail ("duplicate -D switch"); + + else + Object_Directory_Present := True; + end if; + + -- Processing for f switch + + when 'f' => + Force_Compilations := True; + + -- Processing for F switch + + when 'F' => + Full_Path_Name_For_Brief_Errors := True; + + -- Processing for h switch + + when 'h' => + Usage_Requested := True; + + -- Processing for i switch + + when 'i' => + In_Place_Mode := True; + + -- Processing for j switch + + when 'j' => + -- -j not followed by a number is an error + + Bad_Switch (Switch_Chars); + + -- Processing for k switch + + when 'k' => + Keep_Going := True; + + -- Processing for l switch + + when 'l' => + Link_Only := True; + Make_Steps := True; + + -- Processing for M switch + + when 'M' => + List_Dependencies := True; + + -- Processing for n switch + + when 'n' => + Do_Not_Execute := True; + + -- Processing for o switch + + when 'o' => + if Output_File_Name_Present then + Osint.Fail ("duplicate -o switch"); + else + Output_File_Name_Present := True; + end if; + + -- Processing for p switch + + when 'p' => + Setup_Projects := True; + + -- Processing for q switch + + when 'q' => + Quiet_Output := True; + + -- Processing for R switch + + when 'R' => + Run_Path_Option := False; + + -- Processing for s switch + + when 's' => + Ptr := Ptr + 1; + Check_Switches := True; + + -- Processing for v switch + + when 'v' => + Verbose_Mode := True; + Verbosity_Level := Opt.High; + + -- Processing for x switch + + when 'x' => + External_Unit_Compilation_Allowed := True; + Use_Include_Path_File := True; + + -- Processing for z switch + + when 'z' => + No_Main_Subprogram := True; + + -- Any other small letter is an illegal switch + + when others => + if C in 'a' .. 'z' then + Bad_Switch (Switch_Chars); + + else + Success := False; + end if; + + end case; + end Check_Switch; + end if; + end Scan_Make_Switches; + +end Switch.M; diff --git a/gcc/ada/switch-m.ads b/gcc/ada/switch-m.ads new file mode 100644 index 000000000..de7ccaf5d --- /dev/null +++ b/gcc/ada/switch-m.ads @@ -0,0 +1,81 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S W I T C H - M -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package scans make switches. Note that the body of Usage must be +-- coordinated with the switches that are recognized by this package. +-- The Usage package also acts as the official documentation for the +-- switches that are recognized. In addition, package Debug documents +-- the otherwise undocumented debug switches that are also recognized. + +pragma Warnings (Off); +-- This package is used also by gnatcoll +with System.OS_Lib; use System.OS_Lib; +pragma Warnings (On); + +with Prj.Tree; + +package Switch.M is + + procedure Scan_Make_Switches + (Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref; + Switch_Chars : String; + Success : out Boolean); + -- Scan a gnatmake switch and act accordingly. For switches that are + -- recognized, Success is set to True. A switch that is not recognized and + -- consists of one small letter causes a fatal error exit and control does + -- not return. For all other not recognized switches, Success is set to + -- False, so that the switch may be passed to the compiler. + -- + -- Project_Node_Tree is used to store tree-specific parameters like the + -- project path. + + procedure Normalize_Compiler_Switches + (Switch_Chars : String; + Switches : in out Argument_List_Access; + Last : out Natural); + -- Takes a compiler switch which potentially is equivalent to more + -- that one simple switches and returns the equivalent list of simple + -- switches that are stored in an ALI file. Switches will be extended + -- if initially null or too short. Last indicates the index in Switches + -- of the last simple switch. Last is equal to zero, if it has been + -- determined that Switch_Chars is ill-formed or does not contain any + -- switch that should be stored in an ALI file. Otherwise, the list of + -- simple switches is Switches (Switches'First .. Last). + -- + -- Example: if Switch_Chars is equal to "-gnatAwue", then the list of + -- simple switches will have 3 components: -gnatA, -gnatwu, -gnatwe. + -- + -- The String_Access components of Switches should not be deallocated: + -- they are shallow copies of components in a table in the body. + + function Normalize_Compiler_Switches + (Switch_Chars : String) return Argument_List; + -- Similar to the previous procedure. The return value is the list of + -- simple switches. It may be an empty array if it has been determined + -- that Switch_Chars is ill-formed or does not contain any switch that + -- should be stored in an ALI file. The String_Access components of the + -- returned value should not be deallocated. + +end Switch.M; diff --git a/gcc/ada/switch.adb b/gcc/ada/switch.adb new file mode 100644 index 000000000..cb5c4d11f --- /dev/null +++ b/gcc/ada/switch.adb @@ -0,0 +1,258 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S W I T C H -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Osint; use Osint; +with Output; use Output; + +package body Switch is + + ---------------- + -- Bad_Switch -- + ---------------- + + procedure Bad_Switch (Switch : Character) is + begin + Osint.Fail ("invalid switch: " & Switch); + end Bad_Switch; + + procedure Bad_Switch (Switch : String) is + begin + Osint.Fail ("invalid switch: " & Switch); + end Bad_Switch; + + ------------------------------ + -- Check_Version_And_Help_G -- + ------------------------------ + + procedure Check_Version_And_Help_G + (Tool_Name : String; + Initial_Year : String; + Version_String : String := Gnatvsn.Gnat_Version_String) + is + Version_Switch_Present : Boolean := False; + Help_Switch_Present : Boolean := False; + Next_Arg : Natural; + + begin + -- First check for --version or --help + + Next_Arg := 1; + while Next_Arg < Arg_Count loop + declare + Next_Argv : String (1 .. Len_Arg (Next_Arg)); + begin + Fill_Arg (Next_Argv'Address, Next_Arg); + + if Next_Argv = Version_Switch then + Version_Switch_Present := True; + + elsif Next_Argv = Help_Switch then + Help_Switch_Present := True; + end if; + + Next_Arg := Next_Arg + 1; + end; + end loop; + + -- If --version was used, display version and exit + + if Version_Switch_Present then + Set_Standard_Output; + Display_Version (Tool_Name, Initial_Year, Version_String); + Write_Str (Gnatvsn.Gnat_Free_Software); + Write_Eol; + Write_Eol; + Exit_Program (E_Success); + end if; + + -- If --help was used, display help and exit + + if Help_Switch_Present then + Set_Standard_Output; + Usage; + Write_Eol; + Write_Line ("Report bugs to report@adacore.com"); + Exit_Program (E_Success); + end if; + end Check_Version_And_Help_G; + + --------------------- + -- Display_Version -- + --------------------- + + procedure Display_Version + (Tool_Name : String; + Initial_Year : String; + Version_String : String := Gnatvsn.Gnat_Version_String) + is + begin + Write_Str (Tool_Name); + Write_Char (' '); + Write_Str (Version_String); + Write_Eol; + + Write_Str ("Copyright (C) "); + Write_Str (Initial_Year); + Write_Char ('-'); + Write_Str (Gnatvsn.Current_Year); + Write_Str (", "); + Write_Str (Gnatvsn.Copyright_Holder); + Write_Eol; + end Display_Version; + + ------------------------- + -- Is_Front_End_Switch -- + ------------------------- + + function Is_Front_End_Switch (Switch_Chars : String) return Boolean is + Ptr : constant Positive := Switch_Chars'First; + begin + return Is_Switch (Switch_Chars) + and then + (Switch_Chars (Ptr + 1) = 'I' + or else (Switch_Chars'Length >= 5 + and then Switch_Chars (Ptr + 1 .. Ptr + 4) = "gnat") + or else (Switch_Chars'Length >= 5 + and then Switch_Chars (Ptr + 2 .. Ptr + 4) = "RTS")); + end Is_Front_End_Switch; + + ---------------------------- + -- Is_Internal_GCC_Switch -- + ---------------------------- + + function Is_Internal_GCC_Switch (Switch_Chars : String) return Boolean is + First : constant Natural := Switch_Chars'First + 1; + Last : constant Natural := Switch_Last (Switch_Chars); + begin + return Is_Switch (Switch_Chars) + and then + (Switch_Chars (First .. Last) = "-param" or else + Switch_Chars (First .. Last) = "dumpbase" or else + Switch_Chars (First .. Last) = "auxbase-strip" or else + Switch_Chars (First .. Last) = "auxbase"); + end Is_Internal_GCC_Switch; + + --------------- + -- Is_Switch -- + --------------- + + function Is_Switch (Switch_Chars : String) return Boolean is + begin + return Switch_Chars'Length > 1 + and then Switch_Chars (Switch_Chars'First) = '-'; + end Is_Switch; + + ----------------- + -- Switch_last -- + ----------------- + + function Switch_Last (Switch_Chars : String) return Natural is + Last : constant Natural := Switch_Chars'Last; + begin + if Last >= Switch_Chars'First + and then Switch_Chars (Last) = ASCII.NUL + then + return Last - 1; + else + return Last; + end if; + end Switch_Last; + + ----------------- + -- Nat_Present -- + ----------------- + + function Nat_Present + (Switch_Chars : String; + Max : Integer; + Ptr : Integer) return Boolean + is + begin + return (Ptr <= Max + and then Switch_Chars (Ptr) in '0' .. '9') + or else + (Ptr < Max + and then Switch_Chars (Ptr) = '=' + and then Switch_Chars (Ptr + 1) in '0' .. '9'); + end Nat_Present; + + -------------- + -- Scan_Nat -- + -------------- + + procedure Scan_Nat + (Switch_Chars : String; + Max : Integer; + Ptr : in out Integer; + Result : out Nat; + Switch : Character) + is + begin + Result := 0; + + if not Nat_Present (Switch_Chars, Max, Ptr) then + Osint.Fail ("missing numeric value for switch: " & Switch); + end if; + + if Switch_Chars (Ptr) = '=' then + Ptr := Ptr + 1; + end if; + + while Ptr <= Max and then Switch_Chars (Ptr) in '0' .. '9' loop + Result := + Result * 10 + + Character'Pos (Switch_Chars (Ptr)) - Character'Pos ('0'); + Ptr := Ptr + 1; + + if Result > Switch_Max_Value then + Osint.Fail ("numeric value out of range for switch: " & Switch); + end if; + end loop; + end Scan_Nat; + + -------------- + -- Scan_Pos -- + -------------- + + procedure Scan_Pos + (Switch_Chars : String; + Max : Integer; + Ptr : in out Integer; + Result : out Pos; + Switch : Character) + is + Temp : Nat; + + begin + Scan_Nat (Switch_Chars, Max, Ptr, Temp, Switch); + + if Temp = 0 then + Osint.Fail ("numeric value out of range for switch: " & Switch); + end if; + + Result := Temp; + end Scan_Pos; + +end Switch; diff --git a/gcc/ada/switch.ads b/gcc/ada/switch.ads new file mode 100644 index 000000000..f7c62cba2 --- /dev/null +++ b/gcc/ada/switch.ads @@ -0,0 +1,131 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S W I T C H -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package together with a child package appropriate to the client tool +-- scans switches. Note that the body of the appropriate Usage package must be +-- coordinated with the switches that are recognized by this package. These +-- Usage packages also act as the official documentation for the switches +-- that are recognized. In addition, package Debug documents the otherwise +-- undocumented debug switches that are also recognized. + +with Gnatvsn; +with Types; use Types; + +------------ +-- Switch -- +------------ + +package Switch is + + -- Common switches for GNU tools + + Version_Switch : constant String := "--version"; + Help_Switch : constant String := "--help"; + + ----------------- + -- Subprograms -- + ----------------- + + generic + with procedure Usage; + -- Print tool-specific part of --help message + procedure Check_Version_And_Help_G + (Tool_Name : String; + Initial_Year : String; + Version_String : String := Gnatvsn.Gnat_Version_String); + -- Check if switches --version or --help is used. If one of this switch is + -- used, issue the proper messages and end the process. + + procedure Display_Version + (Tool_Name : String; + Initial_Year : String; + Version_String : String := Gnatvsn.Gnat_Version_String); + -- Display version of a tool when switch --version is used + + function Is_Switch (Switch_Chars : String) return Boolean; + -- Returns True iff Switch_Chars is at least two characters long, and the + -- first character is an hyphen ('-'). + + function Is_Front_End_Switch (Switch_Chars : String) return Boolean; + -- Returns True iff Switch_Chars represents a front-end switch, i.e. it + -- starts with -I, -gnat or -?RTS. + + function Is_Internal_GCC_Switch (Switch_Chars : String) return Boolean; + -- Returns True iff Switch_Chars represents an internal GCC switch to be + -- followed by a single argument, such as -dumpbase, --param or -auxbase. + -- Even though passed by the "gcc" driver, these need not be stored in ALI + -- files and may safely be ignored by non GCC back-ends. + + function Switch_Last (Switch_Chars : String) return Natural; + -- Index in Switch_Chars of the last relevant character for later string + -- comparison purposes. This is typically 'Last, minus one if there is a + -- terminating ASCII.NUL. + +private + -- This section contains some common routines used by the tool dependent + -- child packages (there is one such child package for each tool that uses + -- Switches to scan switches - Compiler/gnatbind/gnatmake/. + + Switch_Max_Value : constant := 999_999; + -- Maximum value permitted in switches that take a value + + function Nat_Present + (Switch_Chars : String; + Max : Integer; + Ptr : Integer) return Boolean; + -- Returns True if an integer is at the current scan location or an equal + -- sign. This is used as a guard for calling Scan_Nat. Switch_Chars is the + -- string containing the switch, and Ptr points just past the switch + -- character. Max is the maximum allowed value of Ptr. + + procedure Scan_Nat + (Switch_Chars : String; + Max : Integer; + Ptr : in out Integer; + Result : out Nat; + Switch : Character); + -- Scan natural integer parameter for switch. On entry, Ptr points just + -- past the switch character, on exit it points past the last digit of the + -- integer value. Max is the maximum allowed value of Ptr, so the scan is + -- restricted to Switch_Chars (Ptr .. Max). It is possible for Ptr to be + -- one greater than Max on return if the entire string is digits. Scan_Nat + -- will skip an optional equal sign if it is present. Nat_Present must be + -- True, or an error will be signalled. + + procedure Scan_Pos + (Switch_Chars : String; + Max : Integer; + Ptr : in out Integer; + Result : out Pos; + Switch : Character); + -- Scan positive integer parameter for switch. On entry, Ptr points just + -- past the switch character, on exit it points past the last digit of the + -- integer value. + + procedure Bad_Switch (Switch : Character); + procedure Bad_Switch (Switch : String); + -- Fail with an appropriate message when a switch is not recognized + +end Switch; diff --git a/gcc/ada/symbols-processing-vms-alpha.adb b/gcc/ada/symbols-processing-vms-alpha.adb new file mode 100644 index 000000000..c33739402 --- /dev/null +++ b/gcc/ada/symbols-processing-vms-alpha.adb @@ -0,0 +1,318 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y M B O L S . P R O C E S S I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VMS Alpha version of this package + +separate (Symbols) +package body Processing is + + type Number is mod 2**16; + -- 16 bits unsigned number for number of characters + + EMH : constant Number := 8; + -- Code for the Module Header section + + GSD : constant Number := 10; + -- Code for the Global Symbol Definition section + + C_SYM : constant Number := 1; + -- Code for a Symbol subsection + + V_DEF_Mask : constant Number := 2 ** 1; + V_NORM_Mask : constant Number := 2 ** 6; + -- Comments ??? + + B : Byte; + + Number_Of_Characters : Natural := 0; + -- The number of characters of each section + + Native_Format : Boolean; + -- True if records are decoded by the system (like on VMS) + + Has_Pad : Boolean; + -- If true, a pad byte must be skipped before reading the next record + + -- The following variables are used by procedure Process when reading an + -- object file. + + Code : Number := 0; + Length : Natural := 0; + + Dummy : Number; + + Nchars : Natural := 0; + Flags : Number := 0; + + Symbol : String (1 .. 255); + LSymb : Natural; + + procedure Get (N : out Number); + -- Read two bytes from the object file LSB first as unsigned 16 bit number + + procedure Get (N : out Natural); + -- Read two bytes from the object file, LSByte first, as a Natural + + --------- + -- Get -- + --------- + + procedure Get (N : out Number) is + C : Byte; + LSByte : Number; + begin + Read (File, C); + LSByte := Byte'Pos (C); + Read (File, C); + N := LSByte + (256 * Byte'Pos (C)); + end Get; + + procedure Get (N : out Natural) is + Result : Number; + begin + Get (Result); + N := Natural (Result); + end Get; + + ------------- + -- Process -- + ------------- + + procedure Process + (Object_File : String; + Success : out Boolean) + is + OK : Boolean := True; + + begin + -- Open the object file with Byte_IO. Return with Success = False if + -- this fails. + + begin + Open (File, In_File, Object_File); + exception + when others => + Put_Line + ("*** Unable to open object file """ & Object_File & """"); + Success := False; + return; + end; + + -- Assume that the object file has a correct format + + Success := True; + + -- Check the file format in case of cross-tool + + Get (Code); + Get (Number_Of_Characters); + Get (Dummy); + + if Code = Dummy and then Number_Of_Characters = Natural (EMH) then + + -- Looks like a cross tool + + Native_Format := False; + Number_Of_Characters := Natural (Dummy) - 4; + Has_Pad := (Number_Of_Characters mod 2) = 1; + + elsif Code = EMH then + Native_Format := True; + Number_Of_Characters := Number_Of_Characters - 6; + Has_Pad := False; + + else + Put_Line ("file """ & Object_File & """ is not an object file"); + Close (File); + Success := False; + return; + end if; + + -- Skip the EMH section + + for J in 1 .. Number_Of_Characters loop + Read (File, B); + end loop; + + -- Get the different sections one by one from the object file + + while not End_Of_File (File) loop + + if not Native_Format then + + -- Skip pad byte if present + + if Has_Pad then + Get (B); + end if; + + -- Skip record length + + Get (Dummy); + end if; + + Get (Code); + Get (Number_Of_Characters); + + if not Native_Format then + if Natural (Dummy) /= Number_Of_Characters then + + -- Format error + + raise Constraint_Error; + end if; + + Has_Pad := (Number_Of_Characters mod 2) = 1; + end if; + + -- The header is 4 bytes length + + Number_Of_Characters := Number_Of_Characters - 4; + + -- If this is not a Global Symbol Definition section, skip to the + -- next section. + + if Code /= GSD then + for J in 1 .. Number_Of_Characters loop + Read (File, B); + end loop; + + else + -- Skip over the next 4 bytes + + Get (Dummy); + Get (Dummy); + Number_Of_Characters := Number_Of_Characters - 4; + + -- Get each subsection in turn + + loop + Get (Code); + Get (Nchars); + Get (Dummy); + Get (Flags); + Number_Of_Characters := Number_Of_Characters - 8; + Nchars := Nchars - 8; + + -- If this is a symbol and the V_DEF flag is set, get symbol + + if Code = C_SYM and then ((Flags and V_DEF_Mask) /= 0) then + + -- First, reach the symbol length + + for J in 1 .. 25 loop + Read (File, B); + Nchars := Nchars - 1; + Number_Of_Characters := Number_Of_Characters - 1; + end loop; + + Length := Byte'Pos (B); + LSymb := 0; + + -- Get the symbol characters + + for J in 1 .. Nchars loop + Read (File, B); + Number_Of_Characters := Number_Of_Characters - 1; + + if Length > 0 then + LSymb := LSymb + 1; + Symbol (LSymb) := B; + Length := Length - 1; + end if; + end loop; + + -- Check if it is a symbol from a generic body + + OK := True; + + for J in 1 .. LSymb - 2 loop + if Symbol (J) = 'G' and then Symbol (J + 1) = 'P' + and then Symbol (J + 2) in '0' .. '9' + then + OK := False; + exit; + end if; + end loop; + + if OK then + + -- Create the new Symbol + + declare + S_Data : Symbol_Data; + + begin + S_Data.Name := new String'(Symbol (1 .. LSymb)); + + -- The symbol kind (Data or Procedure) depends on the + -- V_NORM flag. + + if (Flags and V_NORM_Mask) = 0 then + S_Data.Kind := Data; + else + S_Data.Kind := Proc; + end if; + + -- Put the new symbol in the table + + Symbol_Table.Append (Complete_Symbols, S_Data); + end; + end if; + + else + -- As it is not a symbol subsection, skip to the next + -- subsection. + + for J in 1 .. Nchars loop + Read (File, B); + Number_Of_Characters := Number_Of_Characters - 1; + end loop; + end if; + + -- Exit the GSD section when number of characters reaches zero + + exit when Number_Of_Characters = 0; + end loop; + end if; + end loop; + + -- The object file has been processed, close it + + Close (File); + + exception + -- For any exception, output an error message, close the object file + -- and return with Success = False. + + when X : others => + Put_Line ("unexpected exception raised while processing """ + & Object_File & """"); + Put_Line (Exception_Information (X)); + Close (File); + Success := False; + end Process; + +end Processing; diff --git a/gcc/ada/symbols-processing-vms-ia64.adb b/gcc/ada/symbols-processing-vms-ia64.adb new file mode 100644 index 000000000..beb099e40 --- /dev/null +++ b/gcc/ada/symbols-processing-vms-ia64.adb @@ -0,0 +1,430 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y M B O L S . P R O C E S S I N G -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VMS/IA64 version of this package + +with Ada.IO_Exceptions; + +with Ada.Unchecked_Deallocation; + +separate (Symbols) +package body Processing is + + type String_Array is array (Positive range <>) of String_Access; + type Strings_Ptr is access String_Array; + + procedure Free is + new Ada.Unchecked_Deallocation (String_Array, Strings_Ptr); + + type Section_Header is record + Shname : Integer; + Shtype : Integer; + Shoffset : Integer; + Shsize : Integer; + Shlink : Integer; + end record; + + type Section_Header_Array is array (Natural range <>) of Section_Header; + type Section_Header_Ptr is access Section_Header_Array; + + procedure Free is + new Ada.Unchecked_Deallocation (Section_Header_Array, Section_Header_Ptr); + + ------------- + -- Process -- + ------------- + + procedure Process + (Object_File : String; + Success : out Boolean) + is + B : Byte; + W : Integer; + + Str : String (1 .. 1000) := (others => ' '); + Str_Last : Natural; + + Strings : Strings_Ptr; + + Shoff : Integer; + Shnum : Integer; + Shentsize : Integer; + + Shname : Integer; + Shtype : Integer; + Shoffset : Integer; + Shsize : Integer; + Shlink : Integer; + + Symtab_Index : Natural := 0; + String_Table_Index : Natural := 0; + + End_Symtab : Integer; + + Stname : Integer; + Stinfo : Character; + Stother : Character; + Sttype : Integer; + Stbind : Integer; + Stshndx : Integer; + Stvis : Integer; + + STV_Internal : constant := 1; + STV_Hidden : constant := 2; + + Section_Headers : Section_Header_Ptr; + + Offset : Natural := 0; + OK : Boolean := True; + + procedure Get_Byte (B : out Byte); + -- Read one byte from the object file + + procedure Get_Half (H : out Integer); + -- Read one half work from the object file + + procedure Get_Word (W : out Integer); + -- Read one full word from the object file + + procedure Reset; + -- Restart reading the object file + + procedure Skip_Half; + -- Read and disregard one half word from the object file + + -------------- + -- Get_Byte -- + -------------- + + procedure Get_Byte (B : out Byte) is + begin + Byte_IO.Read (File, B); + Offset := Offset + 1; + end Get_Byte; + + -------------- + -- Get_Half -- + -------------- + + procedure Get_Half (H : out Integer) is + C1, C2 : Character; + begin + Get_Byte (C1); Get_Byte (C2); + H := + Integer'(Character'Pos (C2)) * 256 + Integer'(Character'Pos (C1)); + end Get_Half; + + -------------- + -- Get_Word -- + -------------- + + procedure Get_Word (W : out Integer) is + H1, H2 : Integer; + begin + Get_Half (H1); Get_Half (H2); + W := H2 * 256 * 256 + H1; + end Get_Word; + + ----------- + -- Reset -- + ----------- + + procedure Reset is + begin + Offset := 0; + Byte_IO.Reset (File); + end Reset; + + --------------- + -- Skip_Half -- + --------------- + + procedure Skip_Half is + B : Byte; + pragma Unreferenced (B); + begin + Byte_IO.Read (File, B); + Byte_IO.Read (File, B); + Offset := Offset + 2; + end Skip_Half; + + -- Start of processing for Process + + begin + -- Open the object file with Byte_IO. Return with Success = False if + -- this fails. + + begin + Open (File, In_File, Object_File); + exception + when others => + Put_Line + ("*** Unable to open object file """ & Object_File & """"); + Success := False; + return; + end; + + -- Assume that the object file has a correct format + + Success := True; + + -- Skip ELF identification + + while Offset < 16 loop + Get_Byte (B); + end loop; + + -- Skip e_type + + Skip_Half; + + -- Skip e_machine + + Skip_Half; + + -- Skip e_version + + Get_Word (W); + + -- Skip e_entry + + for J in 1 .. 8 loop + Get_Byte (B); + end loop; + + -- Skip e_phoff + + for J in 1 .. 8 loop + Get_Byte (B); + end loop; + + Get_Word (Shoff); + + -- Skip upper half of Shoff + + for J in 1 .. 4 loop + Get_Byte (B); + end loop; + + -- Skip e_flags + + Get_Word (W); + + -- Skip e_ehsize + + Skip_Half; + + -- Skip e_phentsize + + Skip_Half; + + -- Skip e_phnum + + Skip_Half; + + Get_Half (Shentsize); + + Get_Half (Shnum); + + Section_Headers := new Section_Header_Array (0 .. Shnum - 1); + + -- Go to Section Headers + + while Offset < Shoff loop + Get_Byte (B); + end loop; + + -- Reset Symtab_Index + + Symtab_Index := 0; + + for J in Section_Headers'Range loop + + -- Get the data for each Section Header + + Get_Word (Shname); + Get_Word (Shtype); + + for K in 1 .. 16 loop + Get_Byte (B); + end loop; + + Get_Word (Shoffset); + Get_Word (W); + + Get_Word (Shsize); + Get_Word (W); + + Get_Word (Shlink); + + while (Offset - Shoff) mod Shentsize /= 0 loop + Get_Byte (B); + end loop; + + -- If this is the Symbol Table Section Header, record its index + + if Shtype = 2 then + Symtab_Index := J; + end if; + + Section_Headers (J) := (Shname, Shtype, Shoffset, Shsize, Shlink); + end loop; + + if Symtab_Index = 0 then + Success := False; + return; + end if; + + End_Symtab := + Section_Headers (Symtab_Index).Shoffset + + Section_Headers (Symtab_Index).Shsize; + + String_Table_Index := Section_Headers (Symtab_Index).Shlink; + Strings := + new String_Array (1 .. Section_Headers (String_Table_Index).Shsize); + + -- Go get the String Table section for the Symbol Table + + Reset; + + while Offset < Section_Headers (String_Table_Index).Shoffset loop + Get_Byte (B); + end loop; + + Offset := 0; + + Get_Byte (B); -- zero + + while Offset < Section_Headers (String_Table_Index).Shsize loop + Str_Last := 0; + + loop + Get_Byte (B); + if B /= ASCII.NUL then + Str_Last := Str_Last + 1; + Str (Str_Last) := B; + + else + Strings (Offset - Str_Last - 1) := + new String'(Str (1 .. Str_Last)); + exit; + end if; + end loop; + end loop; + + -- Go get the Symbol Table + + Reset; + + while Offset < Section_Headers (Symtab_Index).Shoffset loop + Get_Byte (B); + end loop; + + while Offset < End_Symtab loop + Get_Word (Stname); + Get_Byte (Stinfo); + Get_Byte (Stother); + Get_Half (Stshndx); + for J in 1 .. 4 loop + Get_Word (W); + end loop; + + Sttype := Integer'(Character'Pos (Stinfo)) mod 16; + Stbind := Integer'(Character'Pos (Stinfo)) / 16; + Stvis := Integer'(Character'Pos (Stother)) mod 4; + + if (Sttype = 1 or else Sttype = 2) + and then Stbind /= 0 + and then Stshndx /= 0 + and then Stvis /= STV_Internal + and then Stvis /= STV_Hidden + then + -- Check if this is a symbol from a generic body + + OK := True; + + for J in Strings (Stname)'First .. Strings (Stname)'Last - 2 loop + if Strings (Stname) (J) = 'G' + and then Strings (Stname) (J + 1) = 'P' + and then Strings (Stname) (J + 2) in '0' .. '9' + then + OK := False; + exit; + end if; + end loop; + + if OK then + declare + S_Data : Symbol_Data; + begin + S_Data.Name := new String'(Strings (Stname).all); + + if Sttype = 1 then + S_Data.Kind := Data; + + else + S_Data.Kind := Proc; + end if; + + -- Put the new symbol in the table + + Symbol_Table.Append (Complete_Symbols, S_Data); + end; + end if; + end if; + end loop; + + -- The object file has been processed, close it + + Close (File); + + -- Free the allocated memory + + Free (Section_Headers); + + for J in Strings'Range loop + if Strings (J) /= null then + Free (Strings (J)); + end if; + end loop; + + Free (Strings); + + exception + -- For any exception, output an error message, close the object file + -- and return with Success = False. + + when Ada.IO_Exceptions.End_Error => + Close (File); + + when X : others => + Put_Line ("unexpected exception raised while processing """ + & Object_File & """"); + Put_Line (Exception_Information (X)); + Close (File); + Success := False; + end Process; + +end Processing; diff --git a/gcc/ada/symbols-vms.adb b/gcc/ada/symbols-vms.adb new file mode 100644 index 000000000..39c9beb32 --- /dev/null +++ b/gcc/ada/symbols-vms.adb @@ -0,0 +1,637 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y M B O L S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VMS version of this package + +with Ada.Exceptions; use Ada.Exceptions; +with Ada.Sequential_IO; +with Ada.Text_IO; use Ada.Text_IO; + +package body Symbols is + + Case_Sensitive : constant String := "case_sensitive="; + Symbol_Vector : constant String := "SYMBOL_VECTOR=("; + Equal_Data : constant String := "=DATA)"; + Equal_Procedure : constant String := "=PROCEDURE)"; + Gsmatch : constant String := "gsmatch="; + Gsmatch_Lequal : constant String := "gsmatch=lequal,"; + + Symbol_File_Name : String_Access := null; + -- Name of the symbol file + + Long_Symbol_Length : constant := 100; + -- Magic length of symbols, over which the lines are split + + Sym_Policy : Policy := Autonomous; + -- The symbol policy. Set by Initialize + + Major_ID : Integer := 1; + -- The Major ID. May be modified by Initialize if Library_Version is + -- specified or if it is read from the reference symbol file. + + Soft_Major_ID : Boolean := True; + -- False if library version is specified in procedure Initialize. + -- When True, Major_ID may be modified if found in the reference symbol + -- file. + + Minor_ID : Natural := 0; + -- The Minor ID. May be modified if read from the reference symbol file + + Soft_Minor_ID : Boolean := True; + -- False if symbol policy is Autonomous, if library version is specified + -- in procedure Initialize and is not the same as the major ID read from + -- the reference symbol file. When True, Minor_ID may be increased in + -- Compliant symbol policy. + + subtype Byte is Character; + -- Object files are stream of bytes, but some of these bytes, those for + -- the names of the symbols, are ASCII characters. + + package Byte_IO is new Ada.Sequential_IO (Byte); + use Byte_IO; + + File : Byte_IO.File_Type; + -- Each object file is read as a stream of bytes (characters) + + function Equal (Left, Right : Symbol_Data) return Boolean; + -- Test for equality of symbols + + function Image (N : Integer) return String; + -- Returns the image of N, without the initial space + + ----------- + -- Equal -- + ----------- + + function Equal (Left, Right : Symbol_Data) return Boolean is + begin + return Left.Name /= null and then + Right.Name /= null and then + Left.Name.all = Right.Name.all and then + Left.Kind = Right.Kind and then + Left.Present = Right.Present; + end Equal; + + ----------- + -- Image -- + ----------- + + function Image (N : Integer) return String is + Result : constant String := N'Img; + begin + if Result (Result'First) = ' ' then + return Result (Result'First + 1 .. Result'Last); + else + return Result; + end if; + end Image; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize + (Symbol_File : String; + Reference : String; + Symbol_Policy : Policy; + Quiet : Boolean; + Version : String; + Success : out Boolean) + is + File : Ada.Text_IO.File_Type; + Line : String (1 .. 2_000); + Last : Natural; + + Offset : Natural; + + begin + -- Record the symbol file name + + Symbol_File_Name := new String'(Symbol_File); + + -- Record the policy + + Sym_Policy := Symbol_Policy; + + -- Record the version (Major ID) + + if Version = "" then + Major_ID := 1; + Soft_Major_ID := True; + + else + begin + Major_ID := Integer'Value (Version); + Soft_Major_ID := False; + + if Major_ID <= 0 then + raise Constraint_Error; + end if; + + exception + when Constraint_Error => + if not Quiet then + Put_Line ("Version """ & Version & """ is illegal."); + Put_Line ("On VMS, version must be a positive number"); + end if; + + Success := False; + return; + end; + end if; + + Minor_ID := 0; + Soft_Minor_ID := Sym_Policy /= Autonomous; + + -- Empty the symbol tables + + Symbol_Table.Set_Last (Original_Symbols, 0); + Symbol_Table.Set_Last (Complete_Symbols, 0); + + -- Assume that everything will be fine + + Success := True; + + -- If policy is Compliant or Controlled, attempt to read the reference + -- file. If policy is Restricted, attempt to read the symbol file. + + if Sym_Policy /= Autonomous then + case Sym_Policy is + when Autonomous | Direct => + null; + + when Compliant | Controlled => + begin + Open (File, In_File, Reference); + + exception + when Ada.Text_IO.Name_Error => + Success := False; + return; + + when X : others => + if not Quiet then + Put_Line ("could not open """ & Reference & """"); + Put_Line (Exception_Message (X)); + end if; + + Success := False; + return; + end; + + when Restricted => + begin + Open (File, In_File, Symbol_File); + + exception + when Ada.Text_IO.Name_Error => + Success := False; + return; + + when X : others => + if not Quiet then + Put_Line ("could not open """ & Symbol_File & """"); + Put_Line (Exception_Message (X)); + end if; + + Success := False; + return; + end; + end case; + + -- Read line by line + + while not End_Of_File (File) loop + Offset := 0; + loop + Get_Line (File, Line (Offset + 1 .. Line'Last), Last); + exit when Line (Last) /= '-'; + + if End_Of_File (File) then + if not Quiet then + Put_Line ("symbol file """ & Reference & + """ is incorrectly formatted:"); + Put_Line ("""" & Line (1 .. Last) & """"); + end if; + + Close (File); + Success := False; + return; + + else + Offset := Last - 1; + end if; + end loop; + + -- Ignore empty lines + + if Last = 0 then + null; + + -- Ignore lines starting with "case_sensitive=" + + elsif Last > Case_Sensitive'Length + and then Line (1 .. Case_Sensitive'Length) = Case_Sensitive + then + null; + + -- Line starting with "SYMBOL_VECTOR=(" + + elsif Last > Symbol_Vector'Length + and then Line (1 .. Symbol_Vector'Length) = Symbol_Vector + then + + -- SYMBOL_VECTOR=(=DATA) + + if Last > Symbol_Vector'Length + Equal_Data'Length and then + Line (Last - Equal_Data'Length + 1 .. Last) = Equal_Data + then + Symbol_Table.Append (Original_Symbols, + (Name => + new String'(Line (Symbol_Vector'Length + 1 .. + Last - Equal_Data'Length)), + Kind => Data, + Present => True)); + + -- SYMBOL_VECTOR=(=PROCEDURE) + + elsif Last > Symbol_Vector'Length + Equal_Procedure'Length + and then + Line (Last - Equal_Procedure'Length + 1 .. Last) = + Equal_Procedure + then + Symbol_Table.Append (Original_Symbols, + (Name => + new String'(Line (Symbol_Vector'Length + 1 .. + Last - Equal_Procedure'Length)), + Kind => Proc, + Present => True)); + + -- Anything else is incorrectly formatted + + else + if not Quiet then + Put_Line ("symbol file """ & Reference & + """ is incorrectly formatted:"); + Put_Line ("""" & Line (1 .. Last) & """"); + end if; + + Close (File); + Success := False; + return; + end if; + + -- Lines with "gsmatch=lequal," or "gsmatch=equal," + + elsif Last > Gsmatch'Length + and then Line (1 .. Gsmatch'Length) = Gsmatch + then + declare + Start : Positive := Gsmatch'Length + 1; + Finish : Positive := Start; + OK : Boolean := True; + ID : Integer; + + begin + -- First, look for the first coma + + loop + if Start >= Last - 1 then + OK := False; + exit; + + elsif Line (Start) = ',' then + Start := Start + 1; + exit; + + else + Start := Start + 1; + end if; + end loop; + + Finish := Start; + + -- If the comma is found, get the Major and the Minor IDs + + if OK then + loop + if Line (Finish) not in '0' .. '9' + or else Finish >= Last - 1 + then + OK := False; + exit; + end if; + + exit when Line (Finish + 1) = ','; + + Finish := Finish + 1; + end loop; + end if; + + if OK then + ID := Integer'Value (Line (Start .. Finish)); + OK := ID /= 0; + + -- If Soft_Major_ID is True, it means that + -- Library_Version was not specified. + + if Soft_Major_ID then + Major_ID := ID; + + -- If the Major ID in the reference file is different + -- from the Library_Version, then the Minor ID will be 0 + -- because there is no point in taking the Minor ID in + -- the reference file, or incrementing it. So, we set + -- Soft_Minor_ID to False, so that we don't modify + -- the Minor_ID later. + + elsif Major_ID /= ID then + Soft_Minor_ID := False; + end if; + + Start := Finish + 2; + Finish := Start; + + loop + if Line (Finish) not in '0' .. '9' then + OK := False; + exit; + end if; + + exit when Finish = Last; + + Finish := Finish + 1; + end loop; + + -- Only set Minor_ID if Soft_Minor_ID is True (see above) + + if OK and then Soft_Minor_ID then + Minor_ID := Integer'Value (Line (Start .. Finish)); + end if; + end if; + + -- If OK is not True, that means the line is not correctly + -- formatted. + + if not OK then + if not Quiet then + Put_Line ("symbol file """ & Reference & + """ is incorrectly formatted"); + Put_Line ("""" & Line (1 .. Last) & """"); + end if; + + Close (File); + Success := False; + return; + end if; + end; + + -- Anything else is incorrectly formatted + + else + if not Quiet then + Put_Line ("unexpected line in symbol file """ & + Reference & """"); + Put_Line ("""" & Line (1 .. Last) & """"); + end if; + + Close (File); + Success := False; + return; + end if; + end loop; + + Close (File); + end if; + end Initialize; + + ---------------- + -- Processing -- + ---------------- + + package body Processing is separate; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize + (Quiet : Boolean; + Success : out Boolean) + is + File : Ada.Text_IO.File_Type; + -- The symbol file + + S_Data : Symbol_Data; + -- A symbol + + Cur : Positive := 1; + -- Most probable index in the Complete_Symbols of the current symbol + -- in Original_Symbol. + + Found : Boolean; + + begin + -- Nothing to be done if Initialize has never been called + + if Symbol_File_Name = null then + Success := False; + + else + + -- First find if the symbols in the reference symbol file are also + -- in the object files. Note that this is not done if the policy is + -- Autonomous, because no reference symbol file has been read. + + -- Expect the first symbol in the symbol file to also be the first + -- in Complete_Symbols. + + Cur := 1; + + for Index_1 in 1 .. Symbol_Table.Last (Original_Symbols) loop + S_Data := Original_Symbols.Table (Index_1); + Found := False; + + First_Object_Loop : + for Index_2 in Cur .. Symbol_Table.Last (Complete_Symbols) loop + if Equal (S_Data, Complete_Symbols.Table (Index_2)) then + Cur := Index_2 + 1; + Complete_Symbols.Table (Index_2).Present := False; + Found := True; + exit First_Object_Loop; + end if; + end loop First_Object_Loop; + + -- If the symbol could not be found between Cur and Last, try + -- before Cur. + + if not Found then + Second_Object_Loop : + for Index_2 in 1 .. Cur - 1 loop + if Equal (S_Data, Complete_Symbols.Table (Index_2)) then + Cur := Index_2 + 1; + Complete_Symbols.Table (Index_2).Present := False; + Found := True; + exit Second_Object_Loop; + end if; + end loop Second_Object_Loop; + end if; + + -- If the symbol is not found, mark it as such in the table + + if not Found then + if (not Quiet) or else Sym_Policy = Controlled then + Put_Line ("symbol """ & S_Data.Name.all & + """ is no longer present in the object files"); + end if; + + if Sym_Policy = Controlled or else Sym_Policy = Restricted then + Success := False; + return; + + -- Any symbol that is undefined in the reference symbol file + -- triggers an increase of the Major ID, because the new + -- version of the library is no longer compatible with + -- existing executables. + + elsif Soft_Major_ID then + Major_ID := Major_ID + 1; + Minor_ID := 0; + Soft_Major_ID := False; + Soft_Minor_ID := False; + end if; + + Original_Symbols.Table (Index_1).Present := False; + Free (Original_Symbols.Table (Index_1).Name); + + if Soft_Minor_ID then + Minor_ID := Minor_ID + 1; + Soft_Minor_ID := False; + end if; + end if; + end loop; + + if Sym_Policy /= Restricted then + + -- Append additional symbols, if any, to the Original_Symbols + -- table. + + for Index in 1 .. Symbol_Table.Last (Complete_Symbols) loop + S_Data := Complete_Symbols.Table (Index); + + if S_Data.Present then + + if Sym_Policy = Controlled then + Put_Line ("symbol """ & S_Data.Name.all & + """ is not in the reference symbol file"); + Success := False; + return; + + elsif Soft_Minor_ID then + Minor_ID := Minor_ID + 1; + Soft_Minor_ID := False; + end if; + + Symbol_Table.Append (Original_Symbols, S_Data); + Complete_Symbols.Table (Index).Present := False; + end if; + end loop; + + -- Create the symbol file + + Create (File, Ada.Text_IO.Out_File, Symbol_File_Name.all); + + Put (File, Case_Sensitive); + Put_Line (File, "yes"); + + -- Put a line in the symbol file for each symbol in symbol table + + for Index in 1 .. Symbol_Table.Last (Original_Symbols) loop + if Original_Symbols.Table (Index).Present then + Put (File, Symbol_Vector); + + -- Split the line if symbol name length is too large + + if Original_Symbols.Table (Index).Name'Length > + Long_Symbol_Length + then + Put_Line (File, "-"); + end if; + + Put (File, Original_Symbols.Table (Index).Name.all); + + if Original_Symbols.Table (Index).Name'Length > + Long_Symbol_Length + then + Put_Line (File, "-"); + end if; + + if Original_Symbols.Table (Index).Kind = Data then + Put_Line (File, Equal_Data); + + else + Put_Line (File, Equal_Procedure); + end if; + + Free (Original_Symbols.Table (Index).Name); + end if; + end loop; + + Put (File, Case_Sensitive); + Put_Line (File, "NO"); + + -- Put the version IDs + + Put (File, Gsmatch_Lequal); + Put (File, Image (Major_ID)); + Put (File, ','); + Put_Line (File, Image (Minor_ID)); + + -- And we are done + + Close (File); + + -- Reset both tables + + Symbol_Table.Set_Last (Original_Symbols, 0); + Symbol_Table.Set_Last (Complete_Symbols, 0); + + -- Clear the symbol file name + + Free (Symbol_File_Name); + end if; + + Success := True; + end if; + + exception + when X : others => + Put_Line ("unexpected exception raised while finalizing """ + & Symbol_File_Name.all & """"); + Put_Line (Exception_Information (X)); + Success := False; + end Finalize; + +end Symbols; diff --git a/gcc/ada/symbols.adb b/gcc/ada/symbols.adb new file mode 100644 index 000000000..53dd56e61 --- /dev/null +++ b/gcc/ada/symbols.adb @@ -0,0 +1,90 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y M B O L S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the default version of this package, used when the creation +-- of symbol files is not supported. + +with Ada.Text_IO; use Ada.Text_IO; + +package body Symbols is + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize + (Symbol_File : String; + Reference : String; + Symbol_Policy : Policy; + Quiet : Boolean; + Version : String; + Success : out Boolean) + is + pragma Unreferenced (Symbol_File); + pragma Unreferenced (Reference); + pragma Unreferenced (Symbol_Policy); + pragma Unreferenced (Quiet); + pragma Unreferenced (Version); + begin + Put_Line + ("creation of symbol files are not supported on this platform"); + Success := False; + end Initialize; + + ---------------- + -- Processing -- + ---------------- + + package body Processing is + + ------------- + -- Process -- + ------------- + + procedure Process + (Object_File : String; + Success : out Boolean) + is + pragma Unreferenced (Object_File); + begin + Success := False; + end Process; + + end Processing; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize + (Quiet : Boolean; + Success : out Boolean) + is + pragma Unreferenced (Quiet); + begin + Success := False; + end Finalize; + +end Symbols; diff --git a/gcc/ada/symbols.ads b/gcc/ada/symbols.ads new file mode 100644 index 000000000..65954dc8b --- /dev/null +++ b/gcc/ada/symbols.ads @@ -0,0 +1,116 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y M B O L S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package allows the creation of symbol files to be used for linking +-- libraries. The format of symbol files depends on the platform, so there is +-- several implementations of the body. + +with GNAT.Dynamic_Tables; + +with System.OS_Lib; use System.OS_Lib; + +package Symbols is + + type Policy is + -- Symbol policy + + (Autonomous, + -- Create a symbol file without considering any reference + + Compliant, + -- Either create a symbol file with the same major and minor IDs if + -- all symbols are already found in the reference file or with an + -- incremented minor ID, if not. + + Controlled, + -- Fail if symbols are not the same as those in the reference file + + Restricted, + -- Restrict the symbols to those in the symbol file. Fail if some + -- symbols in the symbol file are not exported from the object files. + + Direct); + -- The reference symbol file is copied to the symbol file + + type Symbol_Kind is (Data, Proc); + -- To distinguish between the different kinds of symbols + + type Symbol_Data is record + Name : String_Access; + Kind : Symbol_Kind := Data; + Present : Boolean := True; + end record; + -- Data (name and kind) for each of the symbols + + package Symbol_Table is new GNAT.Dynamic_Tables + (Table_Component_Type => Symbol_Data, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 100, + Table_Increment => 100); + -- The symbol tables + + Original_Symbols : Symbol_Table.Instance; + -- The symbols, if any, found in the reference symbol table + + Complete_Symbols : Symbol_Table.Instance; + -- The symbols, if any, found in the objects files + + procedure Initialize + (Symbol_File : String; + Reference : String; + Symbol_Policy : Policy; + Quiet : Boolean; + Version : String; + Success : out Boolean); + -- Initialize a symbol file. This procedure must be called before + -- Processing any object file. Depending on the platforms and the + -- circumstances, additional messages may be issued if Quiet is False. + + package Processing is + + -- This package, containing a single visible procedure Process, exists so + -- that it can be a subunits, for some platforms (such as VMS Alpha and + -- IA64), the body of package Symbols is common, while the subunit + -- Processing is not. + + procedure Process + (Object_File : String; + Success : out Boolean); + -- Get the symbols from an object file. Success is set to True if the + -- object file exists and has the expected format. + + end Processing; + + procedure Finalize + (Quiet : Boolean; + Success : out Boolean); + -- Finalize the symbol file. This procedure should be called after + -- Initialize (once) and Process (one or more times). If Success is + -- True, the symbol file is written and closed, ready to be used for + -- linking the library. Depending on the platforms and the circumstances, + -- additional messages may be issued if Quiet is False. + +end Symbols; diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c new file mode 100644 index 000000000..aee200a8d --- /dev/null +++ b/gcc/ada/sysdep.c @@ -0,0 +1,1014 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * S Y S D E P * + * * + * C Implementation File * + * * + * 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. * + * * + ****************************************************************************/ + +/* This file contains system dependent symbols that are referenced in the + GNAT Run Time Library */ + +#ifdef __vxworks +#include "ioLib.h" +#if ! defined (VTHREADS) +#include "dosFsLib.h" +#endif +#if ! defined (__RTP__) && (! defined (VTHREADS) || defined (__VXWORKSMILS__)) +# include "nfsLib.h" +#endif +#include "selectLib.h" +#include "vxWorks.h" +#endif + +#ifdef IN_RTS +#define POSIX +#include "tconfig.h" +#include "tsystem.h" +#include +#include +#ifdef VMS +#include +#endif +#else +#include "config.h" +#include "system.h" +#endif + +#include +#include + +#if defined (sun) && defined (__SVR4) && !defined (__vxworks) +/* The declaration is present in but conditionalized + on a couple of macros we don't define. */ +extern struct tm *localtime_r(const time_t *, struct tm *); +#endif + +#include "adaint.h" + +/* + mode_read_text + open text file for reading + rt for DOS and Windows NT, r for Unix + + mode_write_text + truncate to zero length or create text file for writing + wt for DOS and Windows NT, w for Unix + + mode_append_text + append; open or create text file for writing at end-of-file + at for DOS and Windows NT, a for Unix + + mode_read_binary + open binary file for reading + rb for DOS and Windows NT, r for Unix + + mode_write_binary + truncate to zero length or create binary file for writing + wb for DOS and Windows NT, w for Unix + + mode_append_binary + append; open or create binary file for writing at end-of-file + ab for DOS and Windows NT, a for Unix + + mode_read_text_plus + open text file for update (reading and writing) + r+t for DOS and Windows NT, r+ for Unix + + mode_write_text_plus + truncate to zero length or create text file for update + w+t for DOS and Windows NT, w+ for Unix + + mode_append_text_plus + append; open or create text file for update, writing at end-of-file + a+t for DOS and Windows NT, a+ for Unix + + mode_read_binary_plus + open binary file for update (reading and writing) + r+b for DOS and Windows NT, r+ for Unix + + mode_write_binary_plus + truncate to zero length or create binary file for update + w+b for DOS and Windows NT, w+ for Unix + + mode_append_binary_plus + append; open or create binary file for update, writing at end-of-file + a+b for DOS and Windows NT, a+ for Unix + + Notes: + + (1) Opening a file with read mode fails if the file does not exist or + cannot be read. + + (2) Opening a file with append mode causes all subsequent writes to the + file to be forced to the then current end-of-file, regardless of + intervening calls to the fseek function. + + (3) When a file is opened with update mode, both input and output may be + performed on the associated stream. However, output may not be directly + followed by input without an intervening call to the fflush function or + to a file positioning function (fseek, fsetpos, or rewind), and input + may not be directly followed by output without an intervening call to a + file positioning function, unless the input operation encounters + end-of-file. + + The other target dependent declarations here are for the two functions + __gnat_set_binary_mode and __gnat_set_text_mode: + + void __gnat_set_binary_mode (int handle); + void __gnat_set_text_mode (int handle); + + These functions have no effect in Unix (or similar systems where there is + no distinction between binary and text files), but in DOS (and similar + systems where text mode does CR/LF translation), these functions allow + the mode of the stream with the given handle (fileno can be used to get + the handle of a stream) to be changed dynamically. The returned result + is 0 if no error occurs and -1 if an error occurs. + + Finally there is a boolean (character) variable + + char __gnat_text_translation_required; + + which is zero (false) in Unix mode, and one (true) in DOS mode, with a + true value indicating that text translation is required on text files + and that fopen supports the trailing t and b modifiers. + +*/ + +#if defined(WINNT) +static const char *mode_read_text = "rt"; +static const char *mode_write_text = "wt"; +static const char *mode_append_text = "at"; +static const char *mode_read_binary = "rb"; +static const char *mode_write_binary = "wb"; +static const char *mode_append_binary = "ab"; +static const char *mode_read_text_plus = "r+t"; +static const char *mode_write_text_plus = "w+t"; +static const char *mode_append_text_plus = "a+t"; +static const char *mode_read_binary_plus = "r+b"; +static const char *mode_write_binary_plus = "w+b"; +static const char *mode_append_binary_plus = "a+b"; +const char __gnat_text_translation_required = 1; + +void +__gnat_set_binary_mode (int handle) +{ + _setmode (handle, O_BINARY); +} + +void +__gnat_set_text_mode (int handle) +{ + _setmode (handle, O_TEXT); +} + +#ifdef __MINGW32__ +#include + +/* Return the name of the tty. Under windows there is no name for + the tty, so this function, if connected to a tty, returns the generic name + "console". */ + +char * +__gnat_ttyname (int filedes) +{ + if (isatty (filedes)) + return "console"; + else + return NULL; +} + +/* This function is needed to fix a bug under Win95/98. Under these platforms + doing : + ch1 = getch(); + ch2 = fgetc (stdin); + + will put the same character into ch1 and ch2. It seem that the character + read by getch() is not correctly removed from the buffer. Even a + fflush(stdin) does not fix the bug. This bug does not appear under Window + NT. So we have two version of this routine below one for 95/98 and one for + NT/2000 version of Windows. There is also a special routine (winflushinit) + that will be called only the first time to check which version of Windows + we are running running on to set the right routine to use. + + This problem occurs when using Text_IO.Get_Line after Text_IO.Get_Immediate + for example. + + Calling FlushConsoleInputBuffer just after getch() fix the bug under + 95/98. */ + +#ifdef RTX + +static void winflush_nt (void); + +/* winflush_function will do nothing since we only have problems with Windows + 95/98 which are not supported by RTX. */ + +static void (*winflush_function) (void) = winflush_nt; + +static void +winflush_nt (void) +{ + /* Does nothing as there is no problem under NT. */ +} + +#else /* !RTX */ + +static void winflush_init (void); + +static void winflush_95 (void); + +static void winflush_nt (void); + +int __gnat_is_windows_xp (void); + +/* winflusfunction is set first to the winflushinit function which will check + the OS version 95/98 or NT/2000 */ + +static void (*winflush_function) (void) = winflush_init; + +/* This function does the runtime check of the OS version and then sets + winflush_function to the appropriate function and then call it. */ + +static void +winflush_init (void) +{ + DWORD dwVersion = GetVersion(); + + if (dwVersion < 0x80000000) /* Windows NT/2000 */ + winflush_function = winflush_nt; + else /* Windows 95/98 */ + winflush_function = winflush_95; + + (*winflush_function)(); /* Perform the 'flush' */ + +} + +static void +winflush_95 (void) +{ + FlushConsoleInputBuffer (GetStdHandle (STD_INPUT_HANDLE)); +} + +static void +winflush_nt (void) +{ + /* Does nothing as there is no problem under NT. */ +} + +int +__gnat_is_windows_xp (void) +{ + static int is_win_xp=0, is_win_xp_checked=0; + + if (!is_win_xp_checked) + { + OSVERSIONINFO version; + + is_win_xp_checked = 1; + + memset (&version, 0, sizeof (version)); + version.dwOSVersionInfoSize = sizeof (version); + + is_win_xp = GetVersionEx (&version) + && version.dwPlatformId == VER_PLATFORM_WIN32_NT + && (version.dwMajorVersion > 5 + || (version.dwMajorVersion == 5 && version.dwMinorVersion >= 1)); + } + return is_win_xp; +} + +#endif /* !RTX */ + +/* Get the bounds of the stack. The stack pointer is supposed to be + initialized to BASE when a thread is created and the stack can be extended + to LIMIT before reaching a guard page. + Note: for the main thread, the system automatically extend the stack, so + LIMIT is only the current limit. */ + +void +__gnat_get_stack_bounds (void **base, void **limit) +{ + NT_TIB *tib; + + /* We know that the first field of the TEB is the TIB. */ + tib = (NT_TIB *)NtCurrentTeb (); + + *base = tib->StackBase; + *limit = tib->StackLimit; +} + +#endif /* !__MINGW32__ */ + +#else + +static const char *mode_read_text = "r"; +static const char *mode_write_text = "w"; +static const char *mode_append_text = "a"; +static const char *mode_read_binary = "r"; +static const char *mode_write_binary = "w"; +static const char *mode_append_binary = "a"; +static const char *mode_read_text_plus = "r+"; +static const char *mode_write_text_plus = "w+"; +static const char *mode_append_text_plus = "a+"; +static const char *mode_read_binary_plus = "r+"; +static const char *mode_write_binary_plus = "w+"; +static const char *mode_append_binary_plus = "a+"; +const char __gnat_text_translation_required = 0; + +/* These functions do nothing in non-DOS systems. */ + +void +__gnat_set_binary_mode (int handle ATTRIBUTE_UNUSED) +{ +} + +void +__gnat_set_text_mode (int handle ATTRIBUTE_UNUSED) +{ +} +char * +__gnat_ttyname (int filedes) +{ +#if defined (__vxworks) || defined (__nucleus) + return ""; +#else + extern char *ttyname (int); + + return ttyname (filedes); +#endif /* defined (__vxworks) || defined (__nucleus) */ +} +#endif + +#if defined (linux) || defined (sun) || defined (sgi) \ + || (defined (__osf__) && ! defined (__alpha_vxworks)) || defined (WINNT) \ + || defined (__MACHTEN__) || defined (__hpux__) || defined (_AIX) \ + || (defined (__svr4__) && defined (i386)) || defined (__Lynx__) \ + || defined (__CYGWIN__) || defined (__FreeBSD__) || defined (__OpenBSD__) \ + || defined (__GLIBC__) || defined (__APPLE__) + +#ifdef __MINGW32__ +#if OLD_MINGW +#include +#else +#include /* for getch(), kbhit() */ +#endif +#else +#include +#endif + +#else +#if defined (VMS) +extern char *decc$ga_stdscr; +static int initted = 0; +#endif +#endif + +/* Implements the common processing for getc_immediate and + getc_immediate_nowait. */ + +extern void getc_immediate (FILE *, int *, int *); +extern void getc_immediate_nowait (FILE *, int *, int *, int *); +extern void getc_immediate_common (FILE *, int *, int *, int *, int); + +/* Called by Get_Immediate (Foo); */ + +void +getc_immediate (FILE *stream, int *ch, int *end_of_file) +{ + int avail; + + getc_immediate_common (stream, ch, end_of_file, &avail, 1); +} + +/* Called by Get_Immediate (Foo, Available); */ + +void +getc_immediate_nowait (FILE *stream, int *ch, int *end_of_file, int *avail) +{ + getc_immediate_common (stream, ch, end_of_file, avail, 0); +} + +/* Called by getc_immediate () and getc_immediate_nowait () */ + +void +getc_immediate_common (FILE *stream, + int *ch, + int *end_of_file, + int *avail, + int waiting) +{ +#if defined (linux) || defined (sun) || defined (sgi) \ + || (defined (__osf__) && ! defined (__alpha_vxworks)) \ + || defined (__CYGWIN32__) || defined (__MACHTEN__) || defined (__hpux__) \ + || defined (_AIX) || (defined (__svr4__) && defined (i386)) \ + || defined (__Lynx__) || defined (__FreeBSD__) || defined (__OpenBSD__) \ + || defined (__GLIBC__) || defined (__APPLE__) + char c; + int nread; + int good_one = 0; + int eof_ch = 4; /* Ctrl-D */ + int fd = fileno (stream); + struct termios otermios_rec, termios_rec; + + if (isatty (fd)) + { + tcgetattr (fd, &termios_rec); + memcpy (&otermios_rec, &termios_rec, sizeof (struct termios)); + + /* Set RAW mode, with no echo */ + termios_rec.c_lflag = termios_rec.c_lflag & ~ICANON & ~ECHO; + +#if defined(linux) || defined (sun) || defined (sgi) \ + || defined (__osf__) || defined (__MACHTEN__) || defined (__hpux__) \ + || defined (_AIX) || (defined (__svr4__) && defined (i386)) \ + || defined (__Lynx__) || defined (__FreeBSD__) || defined (__OpenBSD__) \ + || defined (__GLIBC__) || defined (__APPLE__) + eof_ch = termios_rec.c_cc[VEOF]; + + /* If waiting (i.e. Get_Immediate (Char)), set MIN = 1 and wait for + a character forever. This doesn't seem to effect Ctrl-Z or + Ctrl-C processing. + If not waiting (i.e. Get_Immediate (Char, Available)), + don't wait for anything but timeout immediately. */ + termios_rec.c_cc[VMIN] = waiting; + termios_rec.c_cc[VTIME] = 0; +#endif + tcsetattr (fd, TCSANOW, &termios_rec); + + while (! good_one) + { + /* Read is used here instead of fread, because fread doesn't + work on Solaris5 and Sunos4 in this situation. Maybe because we + are mixing calls that use file descriptors and streams. */ + nread = read (fd, &c, 1); + if (nread > 0) + { + /* On Unix terminals, Ctrl-D (EOT) is an End of File. */ + if (c == eof_ch) + { + *avail = 0; + *end_of_file = 1; + good_one = 1; + } + + /* Everything else is ok */ + else if (c != eof_ch) + { + *avail = 1; + *end_of_file = 0; + good_one = 1; + } + } + + else if (! waiting) + { + *avail = 0; + *end_of_file = 0; + good_one = 1; + } + else + good_one = 0; + } + + tcsetattr (fd, TCSANOW, &otermios_rec); + *ch = c; + } + + else +#elif defined (VMS) + int fd = fileno (stream); + + if (isatty (fd)) + { + if (initted == 0) + { + decc$bsd_initscr (); + initted = 1; + } + + decc$bsd_cbreak (); + *ch = decc$bsd_wgetch (decc$ga_stdscr); + + if (*ch == 4) + *end_of_file = 1; + else + *end_of_file = 0; + + *avail = 1; + decc$bsd_nocbreak (); + } + else +#elif defined (__MINGW32__) + int fd = fileno (stream); + int char_waiting; + int eot_ch = 4; /* Ctrl-D */ + + if (isatty (fd)) + { + if (waiting) + { + *ch = getch (); + (*winflush_function) (); + + if (*ch == eot_ch) + *end_of_file = 1; + else + *end_of_file = 0; + + *avail = 1; + } + else /* ! waiting */ + { + char_waiting = kbhit(); + + if (char_waiting == 1) + { + *avail = 1; + *ch = getch (); + (*winflush_function) (); + + if (*ch == eot_ch) + *end_of_file = 1; + else + *end_of_file = 0; + } + else + { + *avail = 0; + *end_of_file = 0; + } + } + } + else +#elif defined (__vxworks) + /* Bit masks of file descriptors to read from. */ + struct fd_set readFds; + /* Timeout before select returns if nothing can be read. */ + struct timeval timeOut; + char c; + int fd = fileno (stream); + int nread; + int option; + int readable; + int status; + int width; + + if (isatty (fd)) + { + /* If we do not want to wait, we have to set up fd in RAW mode. This + should be done outside this function as setting fd in RAW mode under + vxWorks flushes the buffer of fd. If the RAW mode was set here, the + buffer would be empty and we would always return that no character + is available */ + if (! waiting) + { + /* Initialization of timeOut for its use with select. */ + timeOut.tv_sec = 0; + timeOut.tv_usec = 0; + + /* Initialization of readFds for its use with select; + FD is the only file descriptor to be monitored */ + FD_ZERO (&readFds); + FD_SET (fd, &readFds); + width = 2; + + /* We do all this processing to emulate a non blocking read. */ + readable = select (width, &readFds, NULL, NULL, &timeOut); + if (readable == ERROR) + *avail = -1, *end_of_file = -1; + /* No character available in input. */ + else if (readable == 0) + *avail = 0, *end_of_file = 0; + else + { + nread = read (fd, &c, 1); + if (nread > 0) + *avail = 1, *end_of_file = 0; + /* End Of File. */ + else if (nread == 0) + *avail = 0, *end_of_file = 1; + /* Error. */ + else + *avail = -1, *end_of_file = -1; + } + } + + /* We have to wait until we get a character */ + else + { + *avail = -1; + *end_of_file = -1; + + /* Save the current mode of FD. */ + option = ioctl (fd, FIOGETOPTIONS, 0); + + /* Set FD in RAW mode. */ + status = ioctl (fd, FIOSETOPTIONS, OPT_RAW); + if (status != -1) + { + nread = read (fd, &c, 1); + if (nread > 0) + *avail = 1, *end_of_file = 0; + /* End of file. */ + else if (nread == 0) + *avail = 0, *end_of_file = 1; + /* Else there is an ERROR. */ + } + + /* Revert FD to its previous mode. */ + status = ioctl (fd, FIOSETOPTIONS, option); + } + + *ch = c; + } + else +#endif + { + /* If we're not on a terminal, then we don't need any fancy processing. + Also this is the only thing that's left if we're not on one of the + supported systems; which means that for non supported systems, + get_immediate may wait for a carriage return on terminals. */ + *ch = fgetc (stream); + if (feof (stream)) + { + *end_of_file = 1; + *avail = 0; + } + else + { + *end_of_file = 0; + *avail = 1; + } + } +} + +/* The following definitions are provided in NT to support Windows based + Ada programs. */ + +#ifdef WINNT +#include + +/* Provide functions to echo the values passed to WinMain (windows bindings + will want to import these). We use the same names as the routines used + by AdaMagic for compatibility. */ + +char *rts_get_hInstance (void); +char *rts_get_hPrevInstance (void); +char *rts_get_lpCommandLine (void); +int rts_get_nShowCmd (void); + +char * +rts_get_hInstance (void) +{ + return (char *)GetModuleHandleA (0); +} + +char * +rts_get_hPrevInstance (void) +{ + return 0; +} + +char * +rts_get_lpCommandLine (void) +{ + return GetCommandLineA (); +} + +int +rts_get_nShowCmd (void) +{ + return 1; +} + +#endif /* WINNT */ +#ifdef VMS + +/* This gets around a problem with using the old threads library on VMS 7.0. */ + +extern long get_gmtoff (void); + +long +get_gmtoff (void) +{ + time_t t; + struct tm *ts; + + t = time ((time_t) 0); + ts = localtime (&t); + return ts->tm_gmtoff; +} +#endif + +/* This value is returned as the time zone offset when a valid value + cannot be determined. It is simply a bizarre value that will never + occur. It is 3 days plus 73 seconds (offset is in seconds). */ + +long __gnat_invalid_tzoff = 259273; + +/* Definition of __gnat_localtime_r used by a-calend.adb */ + +#if defined (__MINGW32__) + +#ifdef CERT + +/* For the Cert run times on native Windows we use dummy functions + for locking and unlocking tasks since we do not support multiple + threads on this configuration (Cert run time on native Windows). */ + +void dummy (void) {} + +void (*Lock_Task) () = &dummy; +void (*Unlock_Task) () = &dummy; + +#else + +#define Lock_Task system__soft_links__lock_task +extern void (*Lock_Task) (void); + +#define Unlock_Task system__soft_links__unlock_task +extern void (*Unlock_Task) (void); + +#endif + +/* Reentrant localtime for Windows. */ + +extern void +__gnat_localtime_tzoff (const time_t *, long *); + +static const unsigned long long w32_epoch_offset = 11644473600ULL; +void +__gnat_localtime_tzoff (const time_t *timer, long *off) +{ + union + { + FILETIME ft_time; + unsigned long long ull_time; + } utc_time, local_time; + + SYSTEMTIME utc_sys_time, local_sys_time; + TIME_ZONE_INFORMATION tzi; + + BOOL status = 1; + DWORD tzi_status; + + (*Lock_Task) (); + +#ifdef RTX + + tzi_status = GetTimeZoneInformation (&tzi); + *off = tzi.Bias; + if (tzi_status == TIME_ZONE_ID_STANDARD) + /* The system is operating in the range covered by the StandardDate + member. */ + *off = *off + tzi.StandardBias; + else if (tzi_status == TIME_ZONE_ID_DAYLIGHT) + /* The system is operating in the range covered by the DaylightDate + member. */ + *off = *off + tzi.DaylightBias; + *off = *off * -60; + +#else + + /* First convert unix time_t structure to windows FILETIME format. */ + utc_time.ull_time = ((unsigned long long) *timer + w32_epoch_offset) + * 10000000ULL; + + tzi_status = GetTimeZoneInformation (&tzi); + + /* If GetTimeZoneInformation does not return a value between 0 and 2 then + it means that we were not able to retrieve timezone informations. + Note that we cannot use here FileTimeToLocalFileTime as Windows will use + in always in this case the current timezone setting. As suggested on + MSDN we use the following three system calls to get the right information. + Note also that starting with Windows Vista new functions are provided to + get timezone settings that depend on the year. We cannot use them as we + still support Windows XP and Windows 2003. */ + status = (tzi_status >= 0 && tzi_status <= 2) + && FileTimeToSystemTime (&utc_time.ft_time, &utc_sys_time) + && SystemTimeToTzSpecificLocalTime (&tzi, &utc_sys_time, &local_sys_time) + && SystemTimeToFileTime (&local_sys_time, &local_time.ft_time); + + if (!status) + /* An error occurs so return invalid_tzoff. */ + *off = __gnat_invalid_tzoff; + else + if (local_time.ull_time > utc_time.ull_time) + *off = (long) ((local_time.ull_time - utc_time.ull_time) / 10000000ULL); + else + *off = - (long) ((utc_time.ull_time - local_time.ull_time) / 10000000ULL); + +#endif + + (*Unlock_Task) (); +} + +#else + +/* On Lynx, all time values are treated in GMT */ + +#if defined (__Lynx__) + +/* As of LynxOS 3.1.0a patch level 040, LynuxWorks changes the + prototype to the C library function localtime_r from the POSIX.4 + Draft 9 to the POSIX 1.c version. Before this change the following + spec is required. Only use when ___THREADS_POSIX4ad4__ is defined, + the Lynx convention when building against the legacy API. */ + +extern void +__gnat_localtime_tzoff (const time_t *, long *); + +void +__gnat_localtime_tzoff (const time_t *timer, long *off) +{ + *off = 0; +} + +#else + +/* VMS does not need __gnat_localtime_tzoff */ + +#if defined (VMS) + +/* Other targets except Lynx, VMS and Windows provide a standard localtime_r */ + +#else + +#define Lock_Task system__soft_links__lock_task +extern void (*Lock_Task) (void); + +#define Unlock_Task system__soft_links__unlock_task +extern void (*Unlock_Task) (void); + +extern void +__gnat_localtime_tzoff (const time_t *, long *); + +void +__gnat_localtime_tzoff (const time_t *timer, long *off) +{ + struct tm tp; + +/* AIX, HPUX, SGI Irix, Sun Solaris */ +#if defined (_AIX) || defined (__hpux__) || defined (sgi) || defined (sun) +{ + (*Lock_Task) (); + + localtime_r (timer, &tp); + *off = (long) -timezone; + + (*Unlock_Task) (); + + /* Correct the offset if Daylight Saving Time is in effect */ + + if (tp.tm_isdst > 0) + *off = *off + 3600; +} + +/* VxWorks */ +#elif defined (__vxworks) +#include +{ + (*Lock_Task) (); + + localtime_r (timer, &tp); + + /* Try to read the environment variable TIMEZONE. The variable may not have + been initialize, in that case return an offset of zero (0) for UTC. */ + + char *tz_str = getenv ("TIMEZONE"); + + if ((tz_str == NULL) || (*tz_str == '\0')) + *off = 0; + else + { + char *tz_start, *tz_end; + + /* The format of the data contained in TIMEZONE is N::U:S:E where N is the + name of the time zone, U are the minutes difference from UTC, S is the + start of DST in mmddhh and E is the end of DST in mmddhh. Extracting + the value of U involves setting two pointers, one at the beginning and + one at the end of the value. The end pointer is then set to null in + order to delimit a string slice for atol to process. */ + + tz_start = index (tz_str, ':') + 2; + tz_end = index (tz_start, ':'); + tz_end = '\0'; + + /* The Ada layer expects an offset in seconds. Note that we must reverse + the sign of the result since west is positive and east is negative on + VxWorks targets. */ + + *off = -atol (tz_start) * 60; + + /* Correct the offset if Daylight Saving Time is in effect */ + + if (tp.tm_isdst > 0) + *off = *off + 3600; + } + + (*Unlock_Task) (); +} + +/* Darwin, Free BSD, Linux, Tru64, where component tm_gmtoff is present in + struct tm */ + +#elif defined (__APPLE__) || defined (__FreeBSD__) || defined (linux) ||\ + (defined (__alpha__) && defined (__osf__)) || defined (__GLIBC__) +{ + localtime_r (timer, &tp); + *off = tp.tm_gmtoff; +} + +/* Default: treat all time values in GMT */ + +#else + *off = 0; + +#endif +} + +#endif +#endif +#endif + +#ifdef __vxworks + +#include + +/* __gnat_get_task_options is used by s-taprop.adb only for VxWorks. This + function returns the options to be set when creating a new task. It fetches + the options assigned to the current task (parent), so offering some user + level control over the options for a task hierarchy. It forces VX_FP_TASK + because it is almost always required. On processors with the SPE + category, VX_SPE_TASK is needed to enable the SPE. */ +extern int __gnat_get_task_options (void); + +int +__gnat_get_task_options (void) +{ + int options; + + /* Get the options for the task creator */ + taskOptionsGet (taskIdSelf (), &options); + + /* Force VX_FP_TASK because it is almost always required */ + options |= VX_FP_TASK; +#if defined (__SPE__) && (! defined (__VXWORKSMILS__)) + options |= VX_SPE_TASK; +#endif + + /* Mask those bits that are not under user control */ +#ifdef VX_USR_TASK_OPTIONS + return options & VX_USR_TASK_OPTIONS; +#else + return options; +#endif +} + +#endif + +int +__gnat_is_file_not_found_error (int errno_val) { + switch (errno_val) { + case ENOENT: +#ifdef __vxworks + /* In the case of VxWorks, we also have to take into account various + * filesystem-specific variants of this error. + */ +#if ! defined (VTHREADS) + case S_dosFsLib_FILE_NOT_FOUND: +#endif +#if ! defined (__RTP__) && (! defined (VTHREADS) || defined (__VXWORKSMILS__)) + case S_nfsLib_NFSERR_NOENT: +#endif +#endif + return 1; + + default: + return 0; + } +} diff --git a/gcc/ada/system-aix.ads b/gcc/ada/system-aix.ads new file mode 100644 index 000000000..f76edfa2a --- /dev/null +++ b/gcc/ada/system-aix.ads @@ -0,0 +1,155 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (AIX/PPC Version) -- +-- -- +-- 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 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). + + 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) + + -- 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := True; -- Post GCC 4 only + +end System; diff --git a/gcc/ada/system-aix64.ads b/gcc/ada/system-aix64.ads new file mode 100644 index 000000000..c32125281 --- /dev/null +++ b/gcc/ada/system-aix64.ads @@ -0,0 +1,155 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (PPC/AIX64 Version) -- +-- -- +-- Copyright (C) 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 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). + + 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) + + -- 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := True; -- Post GCC 4 only + +end System; diff --git a/gcc/ada/system-darwin-ppc.ads b/gcc/ada/system-darwin-ppc.ads new file mode 100644 index 000000000..0c9c32d5d --- /dev/null +++ b/gcc/ada/system-darwin-ppc.ads @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (Darwin/PPC Version) -- +-- -- +-- 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 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). + + 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) + + -- 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-darwin-ppc64.ads b/gcc/ada/system-darwin-ppc64.ads new file mode 100644 index 000000000..c4d3c1440 --- /dev/null +++ b/gcc/ada/system-darwin-ppc64.ads @@ -0,0 +1,149 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (Darwin/PPC64 Version) -- +-- -- +-- 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 -- +-- . -- +-- -- +-- 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). + + 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) + + -- The values defined here are copied from the ppc version. + + 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-darwin-x86.ads b/gcc/ada/system-darwin-x86.ads new file mode 100644 index 000000000..a4d5fbf25 --- /dev/null +++ b/gcc/ada/system-darwin-x86.ads @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (Darwin/x86 Version) -- +-- -- +-- 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 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). + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.01; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-darwin-x86_64.ads b/gcc/ada/system-darwin-x86_64.ads new file mode 100644 index 000000000..4211f347c --- /dev/null +++ b/gcc/ada/system-darwin-x86_64.ads @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (Darwin/x86_64 Version) -- +-- -- +-- 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 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). + + 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) + + -- 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-freebsd-x86.ads b/gcc/ada/system-freebsd-x86.ads new file mode 100644 index 000000000..ffec2c11d --- /dev/null +++ b/gcc/ada/system-freebsd-x86.ads @@ -0,0 +1,145 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (FreeBSD/x86 Version) -- +-- -- +-- 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 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). + + 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) + + 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-freebsd-x86_64.ads b/gcc/ada/system-freebsd-x86_64.ads new file mode 100644 index 000000000..b699ef1a9 --- /dev/null +++ b/gcc/ada/system-freebsd-x86_64.ads @@ -0,0 +1,145 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (FreeBSD/x86_64 Version) -- +-- -- +-- 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 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). + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.000_001; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 64; + Memory_Size : constant := 2 ** 64; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-hpux-ia64.ads b/gcc/ada/system-hpux-ia64.ads new file mode 100644 index 000000000..5c03a2490 --- /dev/null +++ b/gcc/ada/system-hpux-ia64.ads @@ -0,0 +1,145 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (HP-UX/ia64 Version) -- +-- -- +-- 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 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). + + 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := False; + +end System; diff --git a/gcc/ada/system-hpux.ads b/gcc/ada/system-hpux.ads new file mode 100644 index 000000000..ec6cd1c2c --- /dev/null +++ b/gcc/ada/system-hpux.ads @@ -0,0 +1,221 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (HP-UX Version) -- +-- -- +-- 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 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). + + 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := 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-irix-n32.ads b/gcc/ada/system-irix-n32.ads new file mode 100644 index 000000000..b26894b52 --- /dev/null +++ b/gcc/ada/system-irix-n32.ads @@ -0,0 +1,160 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (SGI Irix, n32 ABI) -- +-- -- +-- 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 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). + + 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 ** 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) + + -- IRIX priorities as defined by realtime(5): + -- + -- 255 is for system-level interrupts + -- 240 - 254 are suggested for hard real-time threads + -- 200 - 239 are used by system device driver interrupt threads + -- 110 - 199 are suggested for interactive real-time applications + -- 90 - 109 are used by system daemon threads + -- 0 - 89 are suggested for soft real-time applications + -- + -- We don't express the full range of IRIX priorities. For now, we + -- handle only the subset for soft real-time applications. + + Max_Priority : constant Positive := 88; + Max_Interrupt_Priority : constant Positive := 89; + + subtype Any_Priority is Integer range 0 .. 89; + subtype Priority is Any_Priority range 0 .. 88; + subtype Interrupt_Priority is Any_Priority range 89 .. 89; + + Default_Priority : constant Priority := 44; + +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 := False; + 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + + -- Note: Denorm is False because denormals are not supported on the + -- R10000, and we want the code to be valid for this processor. + +end System; diff --git a/gcc/ada/system-irix-n64.ads b/gcc/ada/system-irix-n64.ads new file mode 100644 index 000000000..88555673e --- /dev/null +++ b/gcc/ada/system-irix-n64.ads @@ -0,0 +1,160 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (SGI Irix, n64 ABI) -- +-- -- +-- 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 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). + + 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) + + -- IRIX priorities as defined by realtime(5): + -- + -- 255 is for system-level interrupts + -- 240 - 254 are suggested for hard real-time threads + -- 200 - 239 are used by system device driver interrupt threads + -- 110 - 199 are suggested for interactive real-time applications + -- 90 - 109 are used by system daemon threads + -- 0 - 89 are suggested for soft real-time applications + -- + -- We don't express the full range of IRIX priorities. For now, we + -- handle only the subset for soft real-time applications. + + Max_Priority : constant Positive := 88; + Max_Interrupt_Priority : constant Positive := 89; + + subtype Any_Priority is Integer range 0 .. 89; + subtype Priority is Any_Priority range 0 .. 88; + subtype Interrupt_Priority is Any_Priority range 89 .. 89; + + Default_Priority : constant Priority := 44; + +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 := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := False; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + + -- Note: Denorm is False because denormals are not supported on the + -- R10000, and we want the code to be valid for this processor. + +end System; diff --git a/gcc/ada/system-irix-o32.ads b/gcc/ada/system-irix-o32.ads new file mode 100644 index 000000000..22bbbaac4 --- /dev/null +++ b/gcc/ada/system-irix-o32.ads @@ -0,0 +1,148 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (SGI Irix, o32 ABI) -- +-- -- +-- 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 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). + + 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 := False; + 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + + -- Note: Denorm is False because denormals are not supported on the + -- R10000, and we want the code to be valid for this processor. + +end System; diff --git a/gcc/ada/system-linux-alpha.ads b/gcc/ada/system-linux-alpha.ads new file mode 100644 index 000000000..721247553 --- /dev/null +++ b/gcc/ada/system-linux-alpha.ads @@ -0,0 +1,143 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/alpha Version) -- +-- -- +-- 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 System is +pragma Pure (System); +-- Note that we take advantage of the implementation permission to +-- make this unit Pure instead of Preelaborable, see RM 13.7(36) + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := Integer'Last; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 1.0 / 1024.0; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 64; + Memory_Size : constant := 2 ** 64; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-linux-armeb.ads b/gcc/ada/system-linux-armeb.ads new file mode 100644 index 000000000..aa57af87b --- /dev/null +++ b/gcc/ada/system-linux-armeb.ads @@ -0,0 +1,153 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/ARMEB Version) -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +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). + + 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) + + -- 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 := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := False; + +end System; diff --git a/gcc/ada/system-linux-armel.ads b/gcc/ada/system-linux-armel.ads new file mode 100644 index 000000000..64a82f1de --- /dev/null +++ b/gcc/ada/system-linux-armel.ads @@ -0,0 +1,153 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/ARMEL Version) -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +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). + + 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 := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := False; + +end System; diff --git a/gcc/ada/system-linux-hppa.ads b/gcc/ada/system-linux-hppa.ads new file mode 100644 index 000000000..97900432a --- /dev/null +++ b/gcc/ada/system-linux-hppa.ads @@ -0,0 +1,145 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU/Linux-HPPA Version) -- +-- -- +-- 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 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). + + 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-linux-ia64.ads b/gcc/ada/system-linux-ia64.ads new file mode 100644 index 000000000..cb0746f12 --- /dev/null +++ b/gcc/ada/system-linux-ia64.ads @@ -0,0 +1,153 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/ia64 Version) -- +-- -- +-- 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 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). + + 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-linux-mips.ads b/gcc/ada/system-linux-mips.ads new file mode 100644 index 000000000..dada13fb9 --- /dev/null +++ b/gcc/ada/system-linux-mips.ads @@ -0,0 +1,144 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/MIPS Version) -- +-- -- +-- 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 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). + + 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; + 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 := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-linux-mips64el.ads b/gcc/ada/system-linux-mips64el.ads new file mode 100644 index 000000000..c60d1095a --- /dev/null +++ b/gcc/ada/system-linux-mips64el.ads @@ -0,0 +1,144 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/MIPS64EL Version) -- +-- -- +-- 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 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). + + 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; + 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 := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-linux-mipsel.ads b/gcc/ada/system-linux-mipsel.ads new file mode 100644 index 000000000..60b8811b8 --- /dev/null +++ b/gcc/ada/system-linux-mipsel.ads @@ -0,0 +1,144 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/MIPSEL Version) -- +-- -- +-- 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 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). + + 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; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-linux-ppc.ads b/gcc/ada/system-linux-ppc.ads new file mode 100644 index 000000000..6433e0610 --- /dev/null +++ b/gcc/ada/system-linux-ppc.ads @@ -0,0 +1,153 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/PPC Version) -- +-- -- +-- 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 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). + + 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) + + -- 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-linux-ppc64.ads b/gcc/ada/system-linux-ppc64.ads new file mode 100644 index 000000000..0ea68dd72 --- /dev/null +++ b/gcc/ada/system-linux-ppc64.ads @@ -0,0 +1,153 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/PPC64 Version) -- +-- -- +-- 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 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). + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.000_001; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 64; + Memory_Size : constant := 2 ** 64; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_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 := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-linux-s390.ads b/gcc/ada/system-linux-s390.ads new file mode 100644 index 000000000..3ca842b25 --- /dev/null +++ b/gcc/ada/system-linux-s390.ads @@ -0,0 +1,143 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/s390 Version) -- +-- -- +-- 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 System is +pragma Pure (System); +-- Note that we take advantage of the implementation permission to +-- make this unit Pure instead of Preelaborable, see RM 13.7(36) + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := Integer'Last; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.000_001; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + 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 := False; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-linux-s390x.ads b/gcc/ada/system-linux-s390x.ads new file mode 100644 index 000000000..5631b539f --- /dev/null +++ b/gcc/ada/system-linux-s390x.ads @@ -0,0 +1,143 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/s390x Version) -- +-- -- +-- 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 System is +pragma Pure (System); +-- Note that we take advantage of the implementation permission to +-- make this unit Pure instead of Preelaborable, see RM 13.7(36) + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := Integer'Last; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.000_001; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 64; + Memory_Size : constant := 2 ** 64; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := 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 := False; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-linux-sh4.ads b/gcc/ada/system-linux-sh4.ads new file mode 100644 index 000000000..311367710 --- /dev/null +++ b/gcc/ada/system-linux-sh4.ads @@ -0,0 +1,153 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/sh4 Version) -- +-- -- +-- 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 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). + + 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-linux-sparc.ads b/gcc/ada/system-linux-sparc.ads new file mode 100644 index 000000000..69ac9f25b --- /dev/null +++ b/gcc/ada/system-linux-sparc.ads @@ -0,0 +1,143 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU/Linux-SPARC Version) -- +-- -- +-- 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 System is +pragma Pure (System); +-- Note that we take advantage of the implementation permission to +-- make this unit Pure instead of Preelaborable, see RM 13.7(36) + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := Integer'Last; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.000_001; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-linux-sparcv9.ads b/gcc/ada/system-linux-sparcv9.ads new file mode 100644 index 000000000..9a42b3d4a --- /dev/null +++ b/gcc/ada/system-linux-sparcv9.ads @@ -0,0 +1,143 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU/Linux-SPARCV9 Version) -- +-- -- +-- 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 System is +pragma Pure (System); +-- Note that we take advantage of the implementation permission to +-- make this unit Pure instead of Preelaborable, see RM 13.7(36) + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := Integer'Last; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.000_001; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 64; + Memory_Size : constant := 2 ** 64; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := 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 := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-linux-x86.ads b/gcc/ada/system-linux-x86.ads new file mode 100644 index 000000000..f17f2ef74 --- /dev/null +++ b/gcc/ada/system-linux-x86.ads @@ -0,0 +1,153 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/x86 Version) -- +-- -- +-- 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 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). + + 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 := True; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-linux-x86_64.ads b/gcc/ada/system-linux-x86_64.ads new file mode 100644 index 000000000..94ef86f4f --- /dev/null +++ b/gcc/ada/system-linux-x86_64.ads @@ -0,0 +1,153 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/x86-64 Version) -- +-- -- +-- 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 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). + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.000_001; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 64; + Memory_Size : constant := 2 ** 64; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-lynxos-ppc.ads b/gcc/ada/system-lynxos-ppc.ads new file mode 100644 index 000000000..76df7e70c --- /dev/null +++ b/gcc/ada/system-lynxos-ppc.ads @@ -0,0 +1,159 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (LynxOS PPC Version) -- +-- -- +-- 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 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). + + 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) + + -- 17 is the system determined default priority for user applications + -- running on LynxOS. + + -- The standard (Rm 13.7) requires that Default_Priority has the value: + + -- (Priority'First + Priority'Last) / 2 + + -- To allow an appropriate value for Default_Priority and expose a useful + -- range of priorities to the user, we use a range of 0 .. 34 for subtype + -- Priority. + + -- The rest of the range allowed by the system from 35 to 255 is made + -- available here in Interrupt_Priority. + + Max_Priority : constant Positive := 34; + Max_Interrupt_Priority : constant Positive := 255; + + subtype Any_Priority is Integer range 0 .. 255; + subtype Priority is Any_Priority range 0 .. 34; + subtype Interrupt_Priority is Any_Priority range 35 .. 255; + + Default_Priority : constant Priority := 17; + +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 := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := False; + +end System; diff --git a/gcc/ada/system-lynxos-x86.ads b/gcc/ada/system-lynxos-x86.ads new file mode 100644 index 000000000..ad14bfe3f --- /dev/null +++ b/gcc/ada/system-lynxos-x86.ads @@ -0,0 +1,159 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (LynxOS x86 Version) -- +-- -- +-- 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 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). + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.01; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- 17 is the system determined default priority for user applications + -- running on LynxOS. + + -- The standard (Rm 13.7) requires that Default_Priority has the value: + + -- (Priority'First + Priority'Last) / 2 + + -- To allow an appropriate value for Default_Priority and expose a useful + -- range of priorities to the user, we use a range of 0 .. 34 for subtype + -- Priority. + + -- The rest of the range allowed by the system from 35 to 255 is made + -- available here in Interrupt_Priority. + + Max_Priority : constant Positive := 34; + Max_Interrupt_Priority : constant Positive := 255; + + subtype Any_Priority is Integer range 0 .. 255; + subtype Priority is Any_Priority range 0 .. 34; + subtype Interrupt_Priority is Any_Priority range 35 .. 255; + + Default_Priority : constant Priority := 17; + +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 := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := False; + +end System; diff --git a/gcc/ada/system-mingw-x86_64.ads b/gcc/ada/system-mingw-x86_64.ads new file mode 100644 index 000000000..587fd2116 --- /dev/null +++ b/gcc/ada/system-mingw-x86_64.ads @@ -0,0 +1,197 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (Windows Version) -- +-- -- +-- 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 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). + + 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) + + 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := 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-mingw.ads b/gcc/ada/system-mingw.ads new file mode 100644 index 000000000..6a9131a30 --- /dev/null +++ b/gcc/ada/system-mingw.ads @@ -0,0 +1,197 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (Windows Version) -- +-- -- +-- 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 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). + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.01; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := True; + + --------------------------- + -- Underlying Priorities -- + --------------------------- + + -- Important note: this section of the file must come AFTER the + -- definition of the system implementation parameters to ensure + -- that the value of these parameters is available for analysis + -- of the declarations here (using Rtsfind at compile time). + + -- The underlying priorities table provides a generalized mechanism + -- for mapping from Ada priorities to system priorities. In some + -- cases a 1-1 mapping is not the convenient or optimal choice. + + type Priorities_Mapping is array (Any_Priority) of Integer; + pragma Suppress_Initialization (Priorities_Mapping); + -- Suppress initialization in case gnat.adc specifies Normalize_Scalars + + Underlying_Priorities : constant Priorities_Mapping := + (Priority'First .. + Default_Priority - 8 => -15, + Default_Priority - 7 => -7, + Default_Priority - 6 => -6, + Default_Priority - 5 => -5, + Default_Priority - 4 => -4, + Default_Priority - 3 => -3, + Default_Priority - 2 => -2, + Default_Priority - 1 => -1, + Default_Priority => 0, + Default_Priority + 1 => 1, + Default_Priority + 2 => 2, + Default_Priority + 3 => 3, + Default_Priority + 4 => 4, + Default_Priority + 5 => 5, + Default_Priority + 6 .. + Priority'Last => 6, + Interrupt_Priority => 15); + -- The default mapping preserves the standard 31 priorities of the Ada + -- model, but maps them using compression onto the 7 priority levels + -- available in NT and on the 16 priority levels available in 2000/XP. + + -- To replace the default values of the Underlying_Priorities mapping, + -- copy this source file into your build directory, edit the file to + -- reflect your desired behavior, and recompile using Makefile.adalib + -- which can be found under the adalib directory of your gnat installation + + pragma Linker_Options ("-Wl,--stack=0x2000000"); + -- This is used to change the default stack (32 MB) size for non tasking + -- programs. We change this value for GNAT on Windows here because the + -- binutils on this platform have switched to a too low value for Ada + -- programs. Note that we also set the stack size for tasking programs in + -- System.Task_Primitives.Operations. + +end System; diff --git a/gcc/ada/system-rtems.ads b/gcc/ada/system-rtems.ads new file mode 100644 index 000000000..b4157f333 --- /dev/null +++ b/gcc/ada/system-rtems.ads @@ -0,0 +1,164 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (Compiler Version) -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This version of System is a RTEMS version that is used in building +-- the compiler. This is based as closely as possible on the generic +-- version with the following exceptions: +-- + priority definitions + +package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := Integer'Last; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.01; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := Standard'Storage_Unit; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Standard'Address_Size; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := + Bit_Order'Val (Standard'Default_Bit_Order); + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- RTEMS POSIX threads support 256 priority levels with 255 being + -- logically the most important. Levels 0 and 255 are reserved. + -- + -- 255 is reserved for RTEMS system tasks + -- 247 - 254 correspond to hardware interrupt levels 0 .. 7 + -- 246 is a catchall default "interrupt" priority for signals, + -- allowing higher priority than normal tasks, but lower than + -- hardware priority levels. Protected Object ceilings can + -- override these values. + -- 245 is used by the Interrupt_Manager task + -- 0 is reserved for the RTEMS IDLE task and really should not + -- be accessible from Ada but GNAT initializes + -- Current_Priority to 0 so it must be valid + + Max_Priority : constant Positive := 244; + Max_Interrupt_Priority : constant Positive := 254; + + subtype Any_Priority is Integer range 0 .. 254; + subtype Priority is Any_Priority range 0 .. 244; + subtype Interrupt_Priority is Any_Priority range 245 .. 254; + + Default_Priority : constant Priority := 122; + +private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-solaris-sparc.ads b/gcc/ada/system-solaris-sparc.ads new file mode 100644 index 000000000..bc00976c5 --- /dev/null +++ b/gcc/ada/system-solaris-sparc.ads @@ -0,0 +1,145 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (SUN Solaris Version) -- +-- -- +-- 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 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). + + 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-solaris-sparcv9.ads b/gcc/ada/system-solaris-sparcv9.ads new file mode 100644 index 000000000..96686f526 --- /dev/null +++ b/gcc/ada/system-solaris-sparcv9.ads @@ -0,0 +1,145 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (Solaris Sparcv9 Version) -- +-- -- +-- 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 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). + + 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-solaris-x86.ads b/gcc/ada/system-solaris-x86.ads new file mode 100644 index 000000000..57aeb8d8b --- /dev/null +++ b/gcc/ada/system-solaris-x86.ads @@ -0,0 +1,145 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (x86 Solaris Version) -- +-- -- +-- 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 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). + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.01; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-solaris-x86_64.ads b/gcc/ada/system-solaris-x86_64.ads new file mode 100644 index 000000000..f146264ae --- /dev/null +++ b/gcc/ada/system-solaris-x86_64.ads @@ -0,0 +1,145 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (x86-64 Solaris Version) -- +-- -- +-- 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 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). + + 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) + + 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 := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-tru64.ads b/gcc/ada/system-tru64.ads new file mode 100644 index 000000000..e56ae5955 --- /dev/null +++ b/gcc/ada/system-tru64.ads @@ -0,0 +1,216 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (DEC Unix Version) -- +-- -- +-- 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 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). + + 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 / 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 := 60; + Max_Interrupt_Priority : constant Positive := 63; + + subtype Any_Priority is Integer range 0 .. 63; + subtype Priority is Any_Priority range 0 .. 60; + subtype Interrupt_Priority is Any_Priority range 61 .. 63; + + Default_Priority : constant Priority := 30; + +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 := False; + 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 := True; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + + -- Note: Denorm is False because denormals are only handled properly + -- if the -mieee switch is set, and we do not require this usage. + + --------------------------- + -- 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 Dec Unix 4.0d, we use a default 1-to-1 mapping that provides + -- the full range of 64 priorities available from the operating system. + + -- On DU prior to 4.0d, less than 64 priorities are available so there + -- are two possibilities: + + -- Limit your range of priorities to the range provided by the + -- OS (e.g 16 .. 32 on 4.0b) + + -- Replace the standard table as described below + + -- 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 -O3 -gnatpgn system.ads + + -- then recompile the run-time parts that depend on this package: + + -- $ gnatmake -a -gnatn -O3 + + -- 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 => 0, + + 1 => 1, 2 => 2, 3 => 3, 4 => 4, 5 => 5, + 6 => 6, 7 => 7, 8 => 8, 9 => 9, 10 => 10, + 11 => 11, 12 => 12, 13 => 13, 14 => 14, 15 => 15, + 16 => 16, 17 => 17, 18 => 18, 19 => 19, 20 => 20, + 21 => 21, 22 => 22, 23 => 23, 24 => 24, 25 => 25, + 26 => 26, 27 => 27, 28 => 28, 29 => 29, + + Default_Priority => 30, + + 31 => 31, 32 => 32, 33 => 33, 34 => 34, 35 => 35, + 36 => 36, 37 => 37, 38 => 38, 39 => 39, 40 => 40, + 41 => 41, 42 => 42, 43 => 43, 44 => 44, 45 => 45, + 46 => 46, 47 => 47, 48 => 48, 49 => 49, 50 => 50, + 51 => 51, 52 => 52, 53 => 53, 54 => 54, 55 => 55, + 56 => 56, 57 => 57, 58 => 58, 59 => 59, + + Priority'Last => 60, + + 61 => 61, 62 => 62, + + Interrupt_Priority'Last => 63); + +end System; diff --git a/gcc/ada/system-vms-ia64.ads b/gcc/ada/system-vms-ia64.ads new file mode 100644 index 000000000..f5d806ddf --- /dev/null +++ b/gcc/ada/system-vms-ia64.ads @@ -0,0 +1,257 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (OpenVMS 64bit Itanium GCC_ZCX DEC Threads Version) -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +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). + + 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 new Long_Integer; + Null_Address : constant Address; + -- Although this is declared as an integer type, no arithmetic operations + -- are available (see abstract declarations below), and furthermore there + -- is special processing in the compiler that prevents the use of integer + -- literals with this type (use To_Address to convert integer literals). + -- + -- Conversion to and from Short_Address is however freely permitted, and + -- is indeed the reason that Address is declared as an integer type. + + 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, "="); + + -- Abstract declarations for arithmetic operations on type address. + -- These declarations are needed when Address is non-private. They + -- avoid excessive visibility of arithmetic operations on address + -- which are typically available elsewhere (e.g. Storage_Elements) + -- and which would cause excessive ambiguities in application code. + + function "+" (Left, Right : Address) return Address is abstract; + function "-" (Left, Right : Address) return Address is abstract; + function "/" (Left, Right : Address) return Address is abstract; + function "*" (Left, Right : Address) return Address is abstract; + function "mod" (Left, Right : Address) return Address is abstract; + + -- 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 + + 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; + OpenVMS : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := True; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := 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 DEC Threads OpenVMS, 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 OpenVMS. + + -- 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 -O3 -gnatpgn system.ads + + -- then recompile the run-time parts that depend on this package: + + -- $ gnatmake -a -gnatn -O3 + + -- 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); + + ---------------------------- + -- Special VMS Interfaces -- + ---------------------------- + + procedure Lib_Stop (Cond_Value : Integer); + pragma Interface (C, Lib_Stop); + pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); + -- Interface to VMS condition handling. Used by RTSfind and pragma + -- {Import,Export}_Exception. Put here because this is the only + -- VMS specific package that doesn't drag in tasking. + + ADA_GNAT : constant Boolean := True; + pragma Export_Object (ADA_GNAT, "ADA$GNAT"); + -- Ubiquitous global symbol identifying a GNAT compiled image to VMS Debug. + -- Do not remove! + + pragma Ident ("GNAT"); -- Gnat_Static_Version_String + -- Default ident for all VMS images. + +end System; diff --git a/gcc/ada/system-vms_64.ads b/gcc/ada/system-vms_64.ads new file mode 100644 index 000000000..293469942 --- /dev/null +++ b/gcc/ada/system-vms_64.ads @@ -0,0 +1,257 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (OpenVMS 64bit GCC_ZCX DEC Threads Version) -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +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). + + 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 new Long_Integer; + Null_Address : constant Address; + -- Although this is declared as an integer type, no arithmetic operations + -- are available (see abstract declarations below), and furthermore there + -- is special processing in the compiler that prevents the use of integer + -- literals with this type (use To_Address to convert integer literals). + -- + -- Conversion to and from Short_Address is however freely permitted, and + -- is indeed the reason that Address is declared as an integer type. + + 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, "="); + + -- Abstract declarations for arithmetic operations on type address. + -- These declarations are needed when Address is non-private. They + -- avoid excessive visibility of arithmetic operations on address + -- which are typically available elsewhere (e.g. Storage_Elements) + -- and which would cause excessive ambiguities in application code. + + function "+" (Left, Right : Address) return Address is abstract; + function "-" (Left, Right : Address) return Address is abstract; + function "/" (Left, Right : Address) return Address is abstract; + function "*" (Left, Right : Address) return Address is abstract; + function "mod" (Left, Right : Address) return Address is abstract; + + -- 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 + + 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 := False; + 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; + OpenVMS : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := True; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := 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 DEC Threads OpenVMS, 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 OpenVMS. + + -- 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 -O3 -gnatpgn system.ads + + -- then recompile the run-time parts that depend on this package: + + -- $ gnatmake -a -gnatn -O3 + + -- 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); + + ---------------------------- + -- Special VMS Interfaces -- + ---------------------------- + + procedure Lib_Stop (Cond_Value : Integer); + pragma Interface (C, Lib_Stop); + pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); + -- Interface to VMS condition handling. Used by RTSfind and pragma + -- {Import,Export}_Exception. Put here because this is the only + -- VMS specific package that doesn't drag in tasking. + + ADA_GNAT : constant Boolean := True; + pragma Export_Object (ADA_GNAT, "ADA$GNAT"); + -- Ubiquitous global symbol identifying a GNAT compiled image to VMS Debug. + -- Do not remove! + + pragma Ident ("GNAT"); -- Gnat_Static_Version_String + -- Default ident for all VMS images. + +end System; diff --git a/gcc/ada/system-vxworks-arm.ads b/gcc/ada/system-vxworks-arm.ads new file mode 100644 index 000000000..2c144afb6 --- /dev/null +++ b/gcc/ada/system-vxworks-arm.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks Version ARM) -- +-- -- +-- 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 System is +pragma Pure (System); +-- Note that we take advantage of the implementation permission to make this +-- unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada 2005, this is +-- Pure in any case (AI-362). + + 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 := False; + Stack_Check_Limits : constant Boolean := True; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := False; + +end System; diff --git a/gcc/ada/system-vxworks-m68k.ads b/gcc/ada/system-vxworks-m68k.ads new file mode 100644 index 000000000..83bb9656b --- /dev/null +++ b/gcc/ada/system-vxworks-m68k.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks version M68K) -- +-- -- +-- 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 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). + + 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 := False; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Stack_Check_Limits : constant Boolean := True; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := False; + +end System; diff --git a/gcc/ada/system-vxworks-mips.ads b/gcc/ada/system-vxworks-mips.ads new file mode 100644 index 000000000..035e542cb --- /dev/null +++ b/gcc/ada/system-vxworks-mips.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks Version Mips) -- +-- -- +-- 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 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). + + 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 := False; + 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := False; + +end System; diff --git a/gcc/ada/system-vxworks-ppc.ads b/gcc/ada/system-vxworks-ppc.ads new file mode 100644 index 000000000..38a9def0f --- /dev/null +++ b/gcc/ada/system-vxworks-ppc.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks 5 and MILS Version PPC) -- +-- -- +-- 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 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). + + 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 := False; + Stack_Check_Limits : constant Boolean := True; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-vxworks-sparcv9.ads b/gcc/ada/system-vxworks-sparcv9.ads new file mode 100644 index 000000000..5d15daa50 --- /dev/null +++ b/gcc/ada/system-vxworks-sparcv9.ads @@ -0,0 +1,160 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks Version Sparc/64) -- +-- -- +-- Copyright (C) 1992-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 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). + + 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 + + -- VxWorks for UltraSparc uses 64bit words but 32bit pointers + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 64; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + 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 := False; + Stack_Check_Limits : constant Boolean := True; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := False; + +end System; diff --git a/gcc/ada/system-vxworks-x86.ads b/gcc/ada/system-vxworks-x86.ads new file mode 100644 index 000000000..d028ca910 --- /dev/null +++ b/gcc/ada/system-vxworks-x86.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks 5 Version x86) -- +-- -- +-- 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 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). + + 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 := False; + Stack_Check_Limits : constant Boolean := True; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := False; + +end System; diff --git a/gcc/ada/system.ads b/gcc/ada/system.ads new file mode 100644 index 000000000..90b328787 --- /dev/null +++ b/gcc/ada/system.ads @@ -0,0 +1,175 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (Compiler Version) -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This version of System is a generic version that is used in building the +-- compiler. Right now, we have a host/target problem if we try to use the +-- "proper" System, and since the compiler itself does not care about most +-- System parameters, this generic version works fine. + +pragma Restrictions (No_Implicit_Dynamic_Code); +-- We want to avoid trampolines in the compiler, so it can be used in systems +-- which prevent execution of code on the stack, e.g. in windows environments +-- with DEP (Data Execution Protection) enabled. + +package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.01; + + -- Storage-related Declarations + + type Address is private; + -- Note that we do NOT add pragma Preelaborable_Initialization in this + -- version of System, since it is used for the compiler only, and typical + -- earlier bootstrap compilers don't support this pragma. We don't need + -- it in this context, so there is no problem in omitting it. + Null_Address : constant Address; + + Storage_Unit : constant := Standard'Storage_Unit; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Standard'Address_Size; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := + Bit_Order'Val (Standard'Default_Bit_Order); + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + -- This version of system.ads is used only for building the compiler. + -- We really ought to use the proper target system (i.e. the one that + -- corresponds to the host for the compiler), but that causes as yet + -- unsolved makefile problems. For the most part the setting of these + -- parameters is not too critical for the compiler version (e.g. we + -- do not use floating-point anyway in the compiler). + + AAMP : constant Boolean := False; + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + OpenVMS : constant Boolean := False; + 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_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := False; + + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + Front_End_ZCX_Support : constant Boolean := False; + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := True; + Functions_Return_By_DSP : constant Boolean := False; + +end System; diff --git a/gcc/ada/table.adb b/gcc/ada/table.adb new file mode 100644 index 000000000..3bf4eb69c --- /dev/null +++ b/gcc/ada/table.adb @@ -0,0 +1,420 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T A B L 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 Debug; use Debug; +with Opt; use Opt; +with Output; use Output; +with System; use System; +with Tree_IO; use Tree_IO; + +with System.Memory; use System.Memory; + +with Unchecked_Conversion; + +pragma Elaborate_All (Output); + +package body Table is + package body Table is + + Min : constant Int := Int (Table_Low_Bound); + -- Subscript of the minimum entry in the currently allocated table + + Length : Int := 0; + -- Number of entries in currently allocated table. The value of zero + -- ensures that we initially allocate the table. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Reallocate; + -- Reallocate the existing table according to the current value stored + -- in Max. Works correctly to do an initial allocation if the table + -- is currently null. + + function Tree_Get_Table_Address return Address; + -- Return Null_Address if the table length is zero, + -- Table (First)'Address if not. + + pragma Warnings (Off); + -- Turn off warnings. The following unchecked conversions are only used + -- internally in this package, and cannot never result in any instances + -- of improperly aliased pointers for the client of the package. + + function To_Address is new Unchecked_Conversion (Table_Ptr, Address); + function To_Pointer is new Unchecked_Conversion (Address, Table_Ptr); + + pragma Warnings (On); + + ------------ + -- Append -- + ------------ + + procedure Append (New_Val : Table_Component_Type) is + begin + Set_Item (Table_Index_Type (Last_Val + 1), New_Val); + end Append; + + ---------------- + -- Append_All -- + ---------------- + + procedure Append_All (New_Vals : Table_Type) is + begin + for J in New_Vals'Range loop + Append (New_Vals (J)); + end loop; + end Append_All; + + -------------------- + -- Decrement_Last -- + -------------------- + + procedure Decrement_Last is + begin + Last_Val := Last_Val - 1; + end Decrement_Last; + + ---------- + -- Free -- + ---------- + + procedure Free is + begin + Free (To_Address (Table)); + Table := null; + Length := 0; + end Free; + + -------------------- + -- Increment_Last -- + -------------------- + + procedure Increment_Last is + begin + Last_Val := Last_Val + 1; + + if Last_Val > Max then + Reallocate; + end if; + end Increment_Last; + + ---------- + -- Init -- + ---------- + + procedure Init is + Old_Length : constant Int := Length; + + begin + Locked := False; + Last_Val := Min - 1; + Max := Min + (Table_Initial * Table_Factor) - 1; + Length := Max - Min + 1; + + -- If table is same size as before (happens when table is never + -- expanded which is a common case), then simply reuse it. Note + -- that this also means that an explicit Init call right after + -- the implicit one in the package body is harmless. + + if Old_Length = Length then + return; + + -- Otherwise we can use Reallocate to get a table of the right size. + -- Note that Reallocate works fine to allocate a table of the right + -- initial size when it is first allocated. + + else + Reallocate; + end if; + end Init; + + ---------- + -- Last -- + ---------- + + function Last return Table_Index_Type is + begin + return Table_Index_Type (Last_Val); + end Last; + + ---------------- + -- Reallocate -- + ---------------- + + procedure Reallocate is + New_Size : Memory.size_t; + + begin + if Max < Last_Val then + pragma Assert (not Locked); + + -- Make sure that we have at least the initial allocation. This + -- is needed in cases where a zero length table is written out. + + Length := Int'Max (Length, Table_Initial); + + -- Now increment table length until it is sufficiently large. Use + -- the increment value or 10, which ever is larger (the reason + -- for the use of 10 here is to ensure that the table does really + -- increase in size (which would not be the case for a table of + -- length 10 increased by 3% for instance). + + while Max < Last_Val loop + Length := Int'Max (Length * (100 + Table_Increment) / 100, + Length + 10); + Max := Min + Length - 1; + end loop; + + if Debug_Flag_D then + Write_Str ("--> Allocating new "); + Write_Str (Table_Name); + Write_Str (" table, size = "); + Write_Int (Max - Min + 1); + Write_Eol; + end if; + end if; + + New_Size := + Memory.size_t ((Max - Min + 1) * + (Table_Type'Component_Size / Storage_Unit)); + + if Table = null then + Table := To_Pointer (Alloc (New_Size)); + + elsif New_Size > 0 then + Table := + To_Pointer (Realloc (Ptr => To_Address (Table), + Size => New_Size)); + end if; + + if Length /= 0 and then Table = null then + Set_Standard_Error; + Write_Str ("available memory exhausted"); + Write_Eol; + Set_Standard_Output; + raise Unrecoverable_Error; + end if; + + end Reallocate; + + ------------- + -- Release -- + ------------- + + procedure Release is + begin + Length := Last_Val - Int (Table_Low_Bound) + 1; + Max := Last_Val; + Reallocate; + end Release; + + ------------- + -- Restore -- + ------------- + + procedure Restore (T : Saved_Table) is + begin + Free (To_Address (Table)); + Last_Val := T.Last_Val; + Max := T.Max; + Table := T.Table; + Length := Max - Min + 1; + end Restore; + + ---------- + -- Save -- + ---------- + + function Save return Saved_Table is + Res : Saved_Table; + + begin + Res.Last_Val := Last_Val; + Res.Max := Max; + Res.Table := Table; + + Table := null; + Length := 0; + Init; + return Res; + end Save; + + -------------- + -- Set_Item -- + -------------- + + procedure Set_Item + (Index : Table_Index_Type; + Item : Table_Component_Type) + is + -- If Item is a value within the current allocation, and we are going + -- to reallocate, then we must preserve an intermediate copy here + -- before calling Increment_Last. Otherwise, if Table_Component_Type + -- is passed by reference, we are going to end up copying from + -- storage that might have been deallocated from Increment_Last + -- calling Reallocate. + + subtype Allocated_Table_T is + Table_Type (Table'First .. Table_Index_Type (Max + 1)); + -- A constrained table subtype one element larger than the currently + -- allocated table. + + Allocated_Table_Address : constant System.Address := + Table.all'Address; + -- Used for address clause below (we can't use non-static expression + -- Table.all'Address directly in the clause because some older + -- versions of the compiler do not allow it). + + Allocated_Table : Allocated_Table_T; + pragma Import (Ada, Allocated_Table); + pragma Suppress (Range_Check, On => Allocated_Table); + for Allocated_Table'Address use Allocated_Table_Address; + -- Allocated_Table represents the currently allocated array, plus one + -- element (the supplementary element is used to have a convenient + -- way of computing the address just past the end of the current + -- allocation). Range checks are suppressed because this unit + -- uses direct calls to System.Memory for allocation, and this can + -- yield misaligned storage (and we cannot rely on the bootstrap + -- compiler supporting specifically disabling alignment checks, so we + -- need to suppress all range checks). It is safe to suppress this + -- check here because we know that a (possibly misaligned) object + -- of that type does actually exist at that address. + -- ??? We should really improve the allocation circuitry here to + -- guarantee proper alignment. + + Need_Realloc : constant Boolean := Int (Index) > Max; + -- True if this operation requires storage reallocation (which may + -- involve moving table contents around). + + begin + -- If we're going to reallocate, check whether Item references an + -- element of the currently allocated table. + + if Need_Realloc + and then Allocated_Table'Address <= Item'Address + and then Item'Address < + Allocated_Table (Table_Index_Type (Max + 1))'Address + then + -- If so, save a copy on the stack because Increment_Last will + -- reallocate storage and might deallocate the current table. + + declare + Item_Copy : constant Table_Component_Type := Item; + begin + Set_Last (Index); + Table (Index) := Item_Copy; + end; + + else + -- Here we know that either we won't reallocate (case of Index < + -- Max) or that Item is not in the currently allocated table. + + if Int (Index) > Last_Val then + Set_Last (Index); + end if; + + Table (Index) := Item; + end if; + end Set_Item; + + -------------- + -- Set_Last -- + -------------- + + procedure Set_Last (New_Val : Table_Index_Type) is + begin + if Int (New_Val) < Last_Val then + Last_Val := Int (New_Val); + + else + Last_Val := Int (New_Val); + + if Last_Val > Max then + Reallocate; + end if; + end if; + end Set_Last; + + ---------------------------- + -- Tree_Get_Table_Address -- + ---------------------------- + + function Tree_Get_Table_Address return Address is + begin + if Length = 0 then + return Null_Address; + else + return Table (First)'Address; + end if; + end Tree_Get_Table_Address; + + --------------- + -- Tree_Read -- + --------------- + + -- Note: we allocate only the space required to accommodate the data + -- actually written, which means that a Tree_Write/Tree_Read sequence + -- does an implicit Release. + + procedure Tree_Read is + begin + Tree_Read_Int (Max); + Last_Val := Max; + Length := Max - Min + 1; + Reallocate; + + Tree_Read_Data + (Tree_Get_Table_Address, + (Last_Val - Int (First) + 1) * + Table_Type'Component_Size / Storage_Unit); + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + -- Note: we write out only the currently valid data, not the entire + -- contents of the allocated array. See note above on Tree_Read. + + procedure Tree_Write is + begin + Tree_Write_Int (Int (Last)); + Tree_Write_Data + (Tree_Get_Table_Address, + (Last_Val - Int (First) + 1) * + Table_Type'Component_Size / Storage_Unit); + end Tree_Write; + + begin + Init; + end Table; +end Table; diff --git a/gcc/ada/table.ads b/gcc/ada/table.ads new file mode 100644 index 000000000..2b398d762 --- /dev/null +++ b/gcc/ada/table.ads @@ -0,0 +1,238 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T A B L E -- +-- -- +-- 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 implementation of dynamically resizable one +-- dimensional arrays. The idea is to mimic the normal Ada semantics for +-- arrays as closely as possible with the one additional capability of +-- dynamically modifying the value of the Last attribute. + +-- Note that this interface should remain synchronized with those in +-- GNAT.Table and GNAT.Dynamic_Tables to keep coherency between these +-- three related units. + +with Types; use Types; + +package Table is + pragma Elaborate_Body; + + generic + type Table_Component_Type is private; + type Table_Index_Type is range <>; + + Table_Low_Bound : Table_Index_Type; + Table_Initial : Pos; + Table_Increment : Nat; + Table_Name : String; + + package Table is + + -- Table_Component_Type and Table_Index_Type specify the type of the + -- array, Table_Low_Bound is the lower bound. Index_type must be an + -- integer type. The effect is roughly to declare: + + -- Table : array (Table_Index_Type range Table_Low_Bound .. <>) + -- of Table_Component_Type; + + -- Note: since the upper bound can be one less than the lower + -- bound for an empty array, the table index type must be able + -- to cover this range, e.g. if the lower bound is 1, then the + -- Table_Index_Type should be Natural rather than Positive. + + -- Table_Component_Type may be any Ada type, except that controlled + -- types are not supported. Note however that default initialization + -- will NOT occur for array components. + + -- The Table_Initial values controls the allocation of the table when + -- it is first allocated, either by default, or by an explicit Init + -- call. The value used is Opt.Table_Factor * Table_Initial. + + -- The Table_Increment value controls the amount of increase, if the + -- table has to be increased in size. The value given is a percentage + -- value (e.g. 100 = increase table size by 100%, i.e. double it). + + -- The Table_Name parameter is simply use in debug output messages it + -- has no other usage, and is not referenced in non-debugging mode. + + -- The Last and Set_Last subprograms provide control over the current + -- logical allocation. They are quite efficient, so they can be used + -- freely (expensive reallocation occurs only at major granularity + -- chunks controlled by the allocation parameters). + + -- Note: We do not make the table components aliased, since this would + -- restrict the use of table for discriminated types. If it is necessary + -- to take the access of a table element, use Unrestricted_Access. + + -- WARNING: On HPPA, the virtual addressing approach used in this unit + -- is incompatible with the indexing instructions on the HPPA. So when + -- using this unit, compile your application with -mdisable-indexing. + + -- WARNING: If the table is reallocated, then the address of all its + -- components will change. So do not capture the address of an element + -- and then use the address later after the table may be reallocated. + -- One tricky case of this is passing an element of the table to a + -- subprogram by reference where the table gets reallocated during + -- the execution of the subprogram. The best rule to follow is never + -- to pass a table element as a parameter except for the case of IN + -- mode parameters with scalar values. + + type Table_Type is + array (Table_Index_Type range <>) of Table_Component_Type; + + subtype Big_Table_Type is + Table_Type (Table_Low_Bound .. Table_Index_Type'Last); + -- We work with pointers to a bogus array type that is constrained + -- with the maximum possible range bound. This means that the pointer + -- is a thin pointer, which is more efficient. Since subscript checks + -- in any case must be on the logical, rather than physical bounds, + -- safety is not compromised by this approach. + + type Table_Ptr is access all Big_Table_Type; + for Table_Ptr'Storage_Size use 0; + -- The table is actually represented as a pointer to allow reallocation + + Table : aliased Table_Ptr := null; + -- The table itself. The lower bound is the value of Low_Bound. + -- Logically the upper bound is the current value of Last (although + -- the actual size of the allocated table may be larger than this). + -- The program may only access and modify Table entries in the range + -- First .. Last. + + Locked : Boolean := False; + -- Table expansion is permitted only if this switch is set to False. A + -- client may set Locked to True, in which case any attempt to expand + -- the table will cause an assertion failure. Note that while a table + -- is locked, its address in memory remains fixed and unchanging. This + -- feature is used to control table expansion during Gigi processing. + -- Gigi assumes that tables other than the Uint and Ureal tables do + -- not move during processing, which means that they cannot be expanded. + -- The Locked flag is used to enforce this restriction. + + procedure Init; + -- This procedure allocates a new table of size Initial (freeing any + -- previously allocated larger table). It is not necessary to call + -- Init when a table is first instantiated (since the instantiation does + -- the same initialization steps). However, it is harmless to do so, and + -- Init is convenient in reestablishing a table for new use. + + function Last return Table_Index_Type; + pragma Inline (Last); + -- Returns the current value of the last used entry in the table, which + -- can then be used as a subscript for Table. Note that the only way to + -- modify Last is to call the Set_Last procedure. Last must always be + -- used to determine the logically last entry. + + procedure Release; + -- Storage is allocated in chunks according to the values given in the + -- Initial and Increment parameters. A call to Release releases all + -- storage that is allocated, but is not logically part of the current + -- array value. Current array values are not affected by this call. + + procedure Free; + -- Free all allocated memory for the table. A call to init is required + -- before any use of this table after calling Free. + + First : constant Table_Index_Type := Table_Low_Bound; + -- Export First as synonym for Low_Bound (parallel with use of Last) + + procedure Set_Last (New_Val : Table_Index_Type); + pragma Inline (Set_Last); + -- This procedure sets Last to the indicated value. If necessary the + -- table is reallocated to accommodate the new value (i.e. on return + -- the allocated table has an upper bound of at least Last). If Set_Last + -- reduces the size of the table, then logically entries are removed + -- from the table. If Set_Last increases the size of the table, then + -- new entries are logically added to the table. + + procedure Increment_Last; + pragma Inline (Increment_Last); + -- Adds 1 to Last (same as Set_Last (Last + 1) + + procedure Decrement_Last; + pragma Inline (Decrement_Last); + -- Subtracts 1 from Last (same as Set_Last (Last - 1) + + procedure Append (New_Val : Table_Component_Type); + pragma Inline (Append); + -- Equivalent to: + -- x.Increment_Last; + -- x.Table (x.Last) := New_Val; + -- i.e. the table size is increased by one, and the given new item + -- stored in the newly created table element. + + procedure Append_All (New_Vals : Table_Type); + -- Appends all components of New_Vals + + procedure Set_Item + (Index : Table_Index_Type; + Item : Table_Component_Type); + pragma Inline (Set_Item); + -- Put Item in the table at position Index. The table is expanded if + -- current table length is less than Index and in that case Last is set + -- to Index. Item will replace any value already present in the table + -- at this position. + + type Saved_Table is private; + -- Type used for Save/Restore subprograms + + function Save return Saved_Table; + -- Resets table to empty, but saves old contents of table in returned + -- value, for possible later restoration by a call to Restore. + + procedure Restore (T : Saved_Table); + -- Given a Saved_Table value returned by a prior call to Save, restores + -- the table to the state it was in at the time of the Save call. + + procedure Tree_Write; + -- Writes out contents of table using Tree_IO + + procedure Tree_Read; + -- Initializes table by reading contents previously written + -- with the Tree_Write call (also using Tree_IO) + + private + + Last_Val : Int; + -- Current value of Last. Note that we declare this in the private part + -- because we don't want the client to modify Last except through one of + -- the official interfaces (since a modification to Last may require a + -- reallocation of the table). + + Max : Int; + -- Subscript of the maximum entry in the currently allocated table + + type Saved_Table is record + Last_Val : Int; + Max : Int; + Table : Table_Ptr; + end record; + + end Table; +end Table; diff --git a/gcc/ada/targext.c b/gcc/ada/targext.c new file mode 100644 index 000000000..b37cc28c6 --- /dev/null +++ b/gcc/ada/targext.c @@ -0,0 +1,56 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * T A R G E X T * + * * + * C Implementation File * + * * + * Copyright (C) 2005-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 file contains target-specific parameters describing the file */ +/* extension for object and executable files. It is used by the compiler, */ +/* binder and tools. */ + +#ifdef IN_RTS +#include "tconfig.h" +#include "tsystem.h" +#else +#include "config.h" +#include "system.h" +#endif +#include "coretypes.h" +#include "tm.h" + +#ifndef TARGET_OBJECT_SUFFIX +#define TARGET_OBJECT_SUFFIX ".o" +#endif + +#ifndef TARGET_EXECUTABLE_SUFFIX +#define TARGET_EXECUTABLE_SUFFIX "" +#endif + +const char *__gnat_target_object_extension = TARGET_OBJECT_SUFFIX; +const char *__gnat_target_executable_extension = TARGET_EXECUTABLE_SUFFIX; +const char *__gnat_target_debuggable_extension = TARGET_EXECUTABLE_SUFFIX; diff --git a/gcc/ada/targparm.adb b/gcc/ada/targparm.adb new file mode 100644 index 000000000..b8cc154c8 --- /dev/null +++ b/gcc/ada/targparm.adb @@ -0,0 +1,662 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- T A R G P A R M -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Csets; use Csets; +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; + +package body Targparm is + use ASCII; + + Parameters_Obtained : Boolean := False; + -- Set True after first call to Get_Target_Parameters. Used to avoid + -- reading system.ads more than once, since it cannot change. + + -- The following array defines a tag name for each entry + + type Targparm_Tags is + (AAM, -- AAMP + ACR, -- Always_Compatible_Rep + BDC, -- Backend_Divide_Checks + BOC, -- Backend_Overflow_Checks + CLA, -- Command_Line_Args + CLI, -- CLI (.NET) + CRT, -- Configurable_Run_Times + D32, -- Duration_32_Bits + DEN, -- Denorm + EXS, -- Exit_Status_Supported + FEL, -- Frontend_Layout + FFO, -- Fractional_Fixed_Ops + JVM, -- JVM + MOV, -- Machine_Overflows + MRN, -- Machine_Rounds + PAS, -- Preallocated_Stacks + RTX, -- RTX_RTSS_Kernel_Module + S64, -- Support_64_Bit_Divides + SAG, -- Support_Aggregates + SCA, -- Support_Composite_Assign + SCC, -- Support_Composite_Compare + SCD, -- Stack_Check_Default + SCL, -- Stack_Check_Limits + SCP, -- Stack_Check_Probes + SLS, -- Support_Long_Shifts + SNZ, -- Signed_Zeros + SSL, -- Suppress_Standard_Library + UAM, -- Use_Ada_Main_Program_Name + VMS, -- OpenVMS + ZCD, -- ZCX_By_Default + ZCG); -- GCC_ZCX_Support + + Targparm_Flags : array (Targparm_Tags) of Boolean := (others => False); + -- Flag is set True if corresponding parameter is scanned + + -- The following list of string constants gives the parameter names + + AAM_Str : aliased constant Source_Buffer := "AAMP"; + ACR_Str : aliased constant Source_Buffer := "Always_Compatible_Rep"; + BDC_Str : aliased constant Source_Buffer := "Backend_Divide_Checks"; + BOC_Str : aliased constant Source_Buffer := "Backend_Overflow_Checks"; + CLA_Str : aliased constant Source_Buffer := "Command_Line_Args"; + CLI_Str : aliased constant Source_Buffer := "CLI"; + CRT_Str : aliased constant Source_Buffer := "Configurable_Run_Time"; + D32_Str : aliased constant Source_Buffer := "Duration_32_Bits"; + DEN_Str : aliased constant Source_Buffer := "Denorm"; + EXS_Str : aliased constant Source_Buffer := "Exit_Status_Supported"; + FEL_Str : aliased constant Source_Buffer := "Frontend_Layout"; + FFO_Str : aliased constant Source_Buffer := "Fractional_Fixed_Ops"; + JVM_Str : aliased constant Source_Buffer := "JVM"; + MOV_Str : aliased constant Source_Buffer := "Machine_Overflows"; + MRN_Str : aliased constant Source_Buffer := "Machine_Rounds"; + PAS_Str : aliased constant Source_Buffer := "Preallocated_Stacks"; + RTX_Str : aliased constant Source_Buffer := "RTX_RTSS_Kernel_Module"; + S64_Str : aliased constant Source_Buffer := "Support_64_Bit_Divides"; + SAG_Str : aliased constant Source_Buffer := "Support_Aggregates"; + SCA_Str : aliased constant Source_Buffer := "Support_Composite_Assign"; + SCC_Str : aliased constant Source_Buffer := "Support_Composite_Compare"; + SCD_Str : aliased constant Source_Buffer := "Stack_Check_Default"; + SCL_Str : aliased constant Source_Buffer := "Stack_Check_Limits"; + SCP_Str : aliased constant Source_Buffer := "Stack_Check_Probes"; + SLS_Str : aliased constant Source_Buffer := "Support_Long_Shifts"; + SNZ_Str : aliased constant Source_Buffer := "Signed_Zeros"; + SSL_Str : aliased constant Source_Buffer := "Suppress_Standard_Library"; + UAM_Str : aliased constant Source_Buffer := "Use_Ada_Main_Program_Name"; + VMS_Str : aliased constant Source_Buffer := "OpenVMS"; + ZCD_Str : aliased constant Source_Buffer := "ZCX_By_Default"; + ZCG_Str : aliased constant Source_Buffer := "GCC_ZCX_Support"; + + -- The following defines a set of pointers to the above strings, + -- indexed by the tag values. + + type Buffer_Ptr is access constant Source_Buffer; + Targparm_Str : constant array (Targparm_Tags) of Buffer_Ptr := + (AAM_Str'Access, + ACR_Str'Access, + BDC_Str'Access, + BOC_Str'Access, + CLA_Str'Access, + CLI_Str'Access, + CRT_Str'Access, + D32_Str'Access, + DEN_Str'Access, + EXS_Str'Access, + FEL_Str'Access, + FFO_Str'Access, + JVM_Str'Access, + MOV_Str'Access, + MRN_Str'Access, + PAS_Str'Access, + RTX_Str'Access, + S64_Str'Access, + SAG_Str'Access, + SCA_Str'Access, + SCC_Str'Access, + SCD_Str'Access, + SCL_Str'Access, + SCP_Str'Access, + SLS_Str'Access, + SNZ_Str'Access, + SSL_Str'Access, + UAM_Str'Access, + VMS_Str'Access, + ZCD_Str'Access, + ZCG_Str'Access); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Set_Profile_Restrictions (P : Profile_Name); + -- Set Restrictions_On_Target for the given profile + + --------------------------- + -- Get_Target_Parameters -- + --------------------------- + + -- Version which reads in system.ads + + procedure Get_Target_Parameters is + Text : Source_Buffer_Ptr; + Hi : Source_Ptr; + + begin + if Parameters_Obtained then + return; + end if; + + Name_Buffer (1 .. 10) := "system.ads"; + Name_Len := 10; + + Read_Source_File (Name_Find, Lo => 0, Hi => Hi, Src => Text); + + if Text = null then + Write_Line ("fatal error, run-time library not installed correctly"); + Write_Line ("cannot locate file system.ads"); + raise Unrecoverable_Error; + end if; + + Get_Target_Parameters + (System_Text => Text, + Source_First => 0, + Source_Last => Hi); + end Get_Target_Parameters; + + -- Version where caller supplies system.ads text + + procedure Get_Target_Parameters + (System_Text : Source_Buffer_Ptr; + Source_First : Source_Ptr; + Source_Last : Source_Ptr) + is + P : Source_Ptr; + -- Scans source buffer containing source of system.ads + + Fatal : Boolean := False; + -- Set True if a fatal error is detected + + Result : Boolean; + -- Records boolean from system line + + begin + if Parameters_Obtained then + return; + else + Parameters_Obtained := True; + end if; + + Opt.Address_Is_Private := False; + + P := Source_First; + Line_Loop : while System_Text (P .. P + 10) /= "end System;" loop + + -- Skip comments quickly + + if System_Text (P) = '-' then + goto Line_Loop_Continue; + + -- Test for type Address is private + + elsif System_Text (P .. P + 26) = " type Address is private;" then + Opt.Address_Is_Private := True; + P := P + 26; + goto Line_Loop_Continue; + + -- Test for pragma Profile (Ravenscar); + + elsif System_Text (P .. P + 26) = + "pragma Profile (Ravenscar);" + then + Set_Profile_Restrictions (Ravenscar); + Opt.Task_Dispatching_Policy := 'F'; + Opt.Locking_Policy := 'C'; + P := P + 27; + goto Line_Loop_Continue; + + -- Test for pragma Profile (Restricted); + + elsif System_Text (P .. P + 27) = + "pragma Profile (Restricted);" + then + Set_Profile_Restrictions (Restricted); + P := P + 28; + goto Line_Loop_Continue; + + -- Test for pragma Restrictions + + elsif System_Text (P .. P + 20) = "pragma Restrictions (" then + P := P + 21; + + Rloop : for K in All_Boolean_Restrictions loop + declare + Rname : constant String := Restriction_Id'Image (K); + + begin + for J in Rname'Range loop + if Fold_Upper (System_Text (P + Source_Ptr (J - 1))) + /= Rname (J) + then + goto Rloop_Continue; + end if; + end loop; + + if System_Text (P + Rname'Length) = ')' then + Restrictions_On_Target.Set (K) := True; + goto Line_Loop_Continue; + end if; + end; + + <> + null; + end loop Rloop; + + Ploop : for K in All_Parameter_Restrictions loop + declare + Rname : constant String := + All_Parameter_Restrictions'Image (K); + + V : Natural; + -- Accumulates value + + begin + for J in Rname'Range loop + if Fold_Upper (System_Text (P + Source_Ptr (J - 1))) + /= Rname (J) + then + goto Ploop_Continue; + end if; + end loop; + + if System_Text (P + Rname'Length .. P + Rname'Length + 3) = + " => " + then + P := P + Rname'Length + 4; + + V := 0; + loop + if System_Text (P) in '0' .. '9' then + declare + pragma Unsuppress (Overflow_Check); + + begin + -- Accumulate next digit + + V := 10 * V + + Character'Pos (System_Text (P)) - + Character'Pos ('0'); + + exception + -- On overflow, we just ignore the pragma since + -- that is the standard handling in this case. + + when Constraint_Error => + goto Line_Loop_Continue; + end; + + elsif System_Text (P) = '_' then + null; + + elsif System_Text (P) = ')' then + Restrictions_On_Target.Value (K) := V; + Restrictions_On_Target.Set (K) := True; + goto Line_Loop_Continue; + + else + exit Ploop; + end if; + + P := P + 1; + end loop; + + else + exit Ploop; + end if; + end; + + <> + null; + end loop Ploop; + + Set_Standard_Error; + Write_Line + ("fatal error: system.ads is incorrectly formatted"); + Write_Str ("unrecognized or incorrect restrictions pragma: "); + + while System_Text (P) /= ')' + and then + System_Text (P) /= ASCII.LF + loop + Write_Char (System_Text (P)); + P := P + 1; + end loop; + + Write_Eol; + Fatal := True; + Set_Standard_Output; + + -- Test for pragma Detect_Blocking; + + elsif System_Text (P .. P + 22) = "pragma Detect_Blocking;" then + P := P + 23; + Opt.Detect_Blocking := True; + goto Line_Loop_Continue; + + -- Discard_Names + + elsif System_Text (P .. P + 20) = "pragma Discard_Names;" then + P := P + 21; + Opt.Global_Discard_Names := True; + goto Line_Loop_Continue; + + -- Locking Policy + + elsif System_Text (P .. P + 22) = "pragma Locking_Policy (" then + P := P + 23; + Opt.Locking_Policy := System_Text (P); + Opt.Locking_Policy_Sloc := System_Location; + goto Line_Loop_Continue; + + -- Normalize_Scalars + + elsif System_Text (P .. P + 24) = "pragma Normalize_Scalars;" then + P := P + 25; + Opt.Normalize_Scalars := True; + Opt.Init_Or_Norm_Scalars := True; + goto Line_Loop_Continue; + + -- Polling (On) + + elsif System_Text (P .. P + 19) = "pragma Polling (On);" then + P := P + 20; + Opt.Polling_Required := True; + goto Line_Loop_Continue; + + -- Ignore pragma Pure (System) + + elsif System_Text (P .. P + 20) = "pragma Pure (System);" then + P := P + 21; + goto Line_Loop_Continue; + + -- Queuing Policy + + elsif System_Text (P .. P + 22) = "pragma Queuing_Policy (" then + P := P + 23; + Opt.Queuing_Policy := System_Text (P); + Opt.Queuing_Policy_Sloc := System_Location; + goto Line_Loop_Continue; + + -- Suppress_Exception_Locations + + elsif System_Text (P .. P + 35) = + "pragma Suppress_Exception_Locations;" + then + P := P + 36; + Opt.Exception_Locations_Suppressed := True; + goto Line_Loop_Continue; + + -- Task_Dispatching Policy + + elsif System_Text (P .. P + 31) = + "pragma Task_Dispatching_Policy (" + then + P := P + 32; + Opt.Task_Dispatching_Policy := System_Text (P); + Opt.Task_Dispatching_Policy_Sloc := System_Location; + goto Line_Loop_Continue; + + -- No other pragmas are permitted + + elsif System_Text (P .. P + 6) = "pragma " then + Set_Standard_Error; + Write_Line ("unrecognized line in system.ads: "); + + while System_Text (P) /= ')' + and then System_Text (P) /= ASCII.LF + loop + Write_Char (System_Text (P)); + P := P + 1; + end loop; + + Write_Eol; + Set_Standard_Output; + Fatal := True; + + -- See if we have a Run_Time_Name + + elsif System_Text (P .. P + 38) = + " Run_Time_Name : constant String := """ + then + P := P + 39; + + Name_Len := 0; + while System_Text (P) in 'A' .. 'Z' + or else + System_Text (P) in 'a' .. 'z' + or else + System_Text (P) in '0' .. '9' + or else + System_Text (P) = ' ' + or else + System_Text (P) = '_' + loop + Add_Char_To_Name_Buffer (System_Text (P)); + P := P + 1; + end loop; + + if System_Text (P) /= '"' + or else System_Text (P + 1) /= ';' + or else (System_Text (P + 2) /= ASCII.LF + and then + System_Text (P + 2) /= ASCII.CR) + then + Set_Standard_Error; + Write_Line + ("incorrectly formatted Run_Time_Name in system.ads"); + Set_Standard_Output; + Fatal := True; + + else + Run_Time_Name_On_Target := Name_Enter; + end if; + + goto Line_Loop_Continue; + + -- See if we have an Executable_Extension + + elsif System_Text (P .. P + 45) = + " Executable_Extension : constant String := """ + then + P := P + 46; + + Name_Len := 0; + while System_Text (P) /= '"' + and then System_Text (P) /= ASCII.LF + loop + Add_Char_To_Name_Buffer (System_Text (P)); + P := P + 1; + end loop; + + if System_Text (P) /= '"' or else System_Text (P + 1) /= ';' then + Set_Standard_Error; + Write_Line + ("incorrectly formatted Executable_Extension in system.ads"); + Set_Standard_Output; + Fatal := True; + + else + Executable_Extension_On_Target := Name_Enter; + end if; + + goto Line_Loop_Continue; + + -- Next see if we have a configuration parameter + + else + Config_Param_Loop : for K in Targparm_Tags loop + if System_Text (P + 3 .. P + 2 + Targparm_Str (K)'Length) = + Targparm_Str (K).all + then + P := P + 3 + Targparm_Str (K)'Length; + + if Targparm_Flags (K) then + Set_Standard_Error; + Write_Line + ("fatal error: system.ads is incorrectly formatted"); + Write_Str ("duplicate line for parameter: "); + + for J in Targparm_Str (K)'Range loop + Write_Char (Targparm_Str (K).all (J)); + end loop; + + Write_Eol; + Set_Standard_Output; + Fatal := True; + + else + Targparm_Flags (K) := True; + end if; + + while System_Text (P) /= ':' + or else System_Text (P + 1) /= '=' + loop + P := P + 1; + end loop; + + P := P + 2; + + while System_Text (P) = ' ' loop + P := P + 1; + end loop; + + Result := (System_Text (P) = 'T'); + + case K is + when AAM => AAMP_On_Target := Result; + when ACR => Always_Compatible_Rep_On_Target := Result; + when BDC => Backend_Divide_Checks_On_Target := Result; + when BOC => Backend_Overflow_Checks_On_Target := Result; + when CLA => Command_Line_Args_On_Target := Result; + when CLI => + if Result then + VM_Target := CLI_Target; + Tagged_Type_Expansion := False; + end if; + + when CRT => Configurable_Run_Time_On_Target := Result; + when D32 => Duration_32_Bits_On_Target := Result; + when DEN => Denorm_On_Target := Result; + when EXS => Exit_Status_Supported_On_Target := Result; + when FEL => Frontend_Layout_On_Target := Result; + when FFO => Fractional_Fixed_Ops_On_Target := Result; + when JVM => + if Result then + VM_Target := JVM_Target; + Tagged_Type_Expansion := False; + end if; + + when MOV => Machine_Overflows_On_Target := Result; + when MRN => Machine_Rounds_On_Target := Result; + when PAS => Preallocated_Stacks_On_Target := Result; + when RTX => RTX_RTSS_Kernel_Module_On_Target := Result; + when S64 => Support_64_Bit_Divides_On_Target := Result; + when SAG => Support_Aggregates_On_Target := Result; + when SCA => Support_Composite_Assign_On_Target := Result; + when SCC => Support_Composite_Compare_On_Target := Result; + when SCD => Stack_Check_Default_On_Target := Result; + when SCL => Stack_Check_Limits_On_Target := Result; + when SCP => Stack_Check_Probes_On_Target := Result; + when SLS => Support_Long_Shifts_On_Target := Result; + when SSL => Suppress_Standard_Library_On_Target := Result; + when SNZ => Signed_Zeros_On_Target := Result; + when UAM => Use_Ada_Main_Program_Name_On_Target := Result; + when VMS => OpenVMS_On_Target := Result; + when ZCD => ZCX_By_Default_On_Target := Result; + when ZCG => GCC_ZCX_Support_On_Target := Result; + + goto Line_Loop_Continue; + end case; + + -- Here we are seeing a parameter we do not understand. We + -- simply ignore this (will happen when an old compiler is + -- used to compile a newer version of GNAT which does not + -- support the parameter). + end if; + end loop Config_Param_Loop; + end if; + + -- Here after processing one line of System spec + + <> + + while System_Text (P) /= CR and then System_Text (P) /= LF loop + P := P + 1; + exit when P >= Source_Last; + end loop; + + while System_Text (P) = CR or else System_Text (P) = LF loop + P := P + 1; + exit when P >= Source_Last; + end loop; + + if P >= Source_Last then + Set_Standard_Error; + Write_Line ("fatal error, system.ads not formatted correctly"); + Write_Line ("unexpected end of file"); + Set_Standard_Output; + raise Unrecoverable_Error; + end if; + end loop Line_Loop; + + -- Now that OpenVMS_On_Target has been given its definitive value, + -- change the multi-unit index character from '~' to '$' for OpenVMS. + + if OpenVMS_On_Target then + Multi_Unit_Index_Character := '$'; + end if; + + if Fatal then + raise Unrecoverable_Error; + end if; + end Get_Target_Parameters; + + ------------------------------ + -- Set_Profile_Restrictions -- + ------------------------------ + + procedure Set_Profile_Restrictions (P : Profile_Name) is + R : Restriction_Flags renames Profile_Info (P).Set; + V : Restriction_Values renames Profile_Info (P).Value; + begin + for J in R'Range loop + if R (J) then + Restrictions_On_Target.Set (J) := True; + + if J in All_Parameter_Restrictions then + Restrictions_On_Target.Value (J) := V (J); + end if; + end if; + end loop; + end Set_Profile_Restrictions; + +end Targparm; diff --git a/gcc/ada/targparm.ads b/gcc/ada/targparm.ads new file mode 100644 index 000000000..726e30550 --- /dev/null +++ b/gcc/ada/targparm.ads @@ -0,0 +1,621 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- T A R G P A R M -- +-- -- +-- 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 obtains parameters from the target runtime version of System, +-- to indicate parameters relevant to the target environment. + +-- Is it right for this to be modified GPL??? + +-- Conceptually, these parameters could be obtained using rtsfind, but +-- we do not do this for four reasons: + +-- 1. Compiling System for every compilation wastes time + +-- 2. This compilation impedes debugging by adding extra compile steps + +-- 3. There are recursion problems coming from compiling System itself +-- or any of its children. + +-- 4. The binder also needs the parameters, and we do not want to have +-- to drag a lot of front end stuff into the binder. + +-- For all these reasons, we read in the source of System, and then scan +-- it at the text level to extract the parameter values. + +-- Note however, that later on, when the ali file is written, we make sure +-- that the System file is at least parsed, so that the checksum is properly +-- computed and set in the ali file. This partially negates points 1 and 2 +-- above although just parsing is quick and does not impact debugging much. + +-- The parameters acquired by this routine from system.ads fall into four +-- categories: + +-- 1. Configuration pragmas, that must appear at the start of the file. +-- Any such pragmas automatically apply to any unit compiled in the +-- presence of this system file. Only a limited set of such pragmas +-- may appear as documented in the corresponding section below, + +-- 2. Target parameters. These are boolean constants that are defined +-- in the private part of the package giving fixed information +-- about the target architecture, and the capabilities of the +-- code generator and run-time library. + +-- 3. Identification information. This is an optional string constant +-- that gives the name of the run-time library configuration. This +-- line may be omitted for a version of system.ads to be used with +-- the full Ada 95 run time. + +-- 4. Other characteristics of package System. At the current time the +-- only item in this category is whether type Address is private. + +with Rident; use Rident; +with Namet; use Namet; +with Types; use Types; + +package Targparm is + + --------------------------- + -- Configuration Pragmas -- + --------------------------- + + -- The following switches get set if the corresponding configuration + -- pragma is scanned from the source of system.ads. No other pragmas + -- are permitted to appear at the start of the system.ads source file. + + -- If a pragma Discard_Names appears, then Opt.Global_Discard_Names is + -- set to True to indicate that all units must be compiled in this mode. + + -- If a pragma Locking_Policy appears, then Opt.Locking_Policy is set + -- to the first character of the policy name, and Opt.Locking_Policy_Sloc + -- is set to System_Location. + + -- If a pragma Normalize_Scalars appears, then Opt.Normalize_Scalars + -- is set True, as well as Opt.Init_Or_Norm_Scalars. + + -- If a pragma Queuing_Policy appears, then Opt.Queuing_Policy is set + -- to the first character of the policy name, and Opt.Queuing_Policy_Sloc + -- is set to System_Location. + + -- If a pragma Task_Dispatching_Policy appears, then the flag + -- Opt.Task_Dispatching_Policy is set to the first character of the + -- policy name, and Opt.Task_Dispatching_Policy_Sloc is set to + -- System_Location. + + -- If a pragma Polling (On) appears, then the flag Opt.Polling_Required + -- is set to True. + + -- If a pragma Detect_Blocking appears, then the flag Opt.Detect_Blocking + -- is set to True. + + -- if a pragma Suppress_Exception_Locations appears, then the flag + -- Opt.Exception_Locations_Suppressed is set to True. + + -- If a pragma Profile with a valid profile argument appears, then + -- the appropriate restrictions and policy flags are set. + + -- The only other pragma allowed is a pragma Restrictions that specifies + -- a restriction that will be imposed on all units in the partition. Note + -- that in this context, only one restriction can be specified in a single + -- pragma, and the pragma must appear on its own on a single source line. + + -- If package System contains exactly the line "type Address is private;" + -- then the flag Opt.Address_Is_Private is set True, otherwise this flag + -- is set False. + + Restrictions_On_Target : Restrictions_Info := No_Restrictions; + -- Records restrictions specified by system.ads. Only the Set and Value + -- members are modified. The Violated and Count fields are never modified. + -- Note that entries can be set either by a pragma Restrictions or by + -- a pragma Profile. + + ------------------- + -- Run Time Name -- + ------------------- + + -- This parameter should be regarded as read only by all clients of + -- of package. The only way they get modified is by calling the + -- Get_Target_Parameters routine which reads the values from a provided + -- text buffer containing the source of the system package. + + -- The corresponding string constant is placed immediately at the start + -- of the private part of system.ads if is present, e.g. in the form: + + -- Run_Time_Name : constant String := "Zero Footprint Run Time"; + + -- the corresponding messages will look something like + + -- xxx not supported (Zero Footprint Run Time) + + Run_Time_Name_On_Target : Name_Id := No_Name; + -- Set to appropriate names table entry Id value if a Run_Time_Name + -- string constant is defined in system.ads. This name is used only + -- for the configurable run-time case, and is used to parameterize + -- messages that complain about non-supported run-time features. + -- The name should contain only letters A-Z, digits 1-9, spaces, + -- and underscores. + + -------------------------- + -- Executable Extension -- + -------------------------- + + Executable_Extension_On_Target : Name_Id := No_Name; + -- Executable extension on the target. This name is useful for setting + -- the executable extension in a dynamic way, e.g. depending on the + -- run time used, rather than using a configure-time macro as done by + -- Get_Target_Executable_Suffix. If not set (No_Name), instead use + -- System.OS_Lib.Get_Target_Executable_Suffix. + + ----------------------- + -- Target Parameters -- + ----------------------- + + -- The following parameters correspond to the variables defined in the + -- private part of System (without the terminating _On_Target). Note + -- that it is required that all parameters defined here be specified + -- in the target specific version of system.ads. Thus, to add a new + -- parameter, add it to all system*.ads files. (There is a defaulting + -- mechanism, but we don't normally take advantage of it, as explained + -- below.) + + -- The default values here are used if no value is found in system.ads. + -- This should normally happen if the special version of system.ads used + -- by the compiler itself is in use or if the value is only relevant to + -- a particular target (e.g. OpenVMS, AAMP). The default values are + -- suitable for use in normal environments. This approach allows the + -- possibility of new versions of the compiler (possibly with new system + -- parameters added) being used to compile older versions of the compiler + -- sources, as well as avoiding duplicating values in all system-*.ads + -- files for flags that are used on a few platforms only. + + -- All these parameters should be regarded as read only by all clients + -- of the package. The only way they get modified is by calling the + -- Get_Target_Parameters routine which reads the values from a provided + -- text buffer containing the source of the system package. + + ---------------------------- + -- Special Target Control -- + ---------------------------- + + -- The great majority of GNAT ports are based on GCC. The switches in + -- This section indicate the use of some non-standard target back end + -- or other special targetting requirements. + + AAMP_On_Target : Boolean := False; + -- Set to True if target is AAMP + + OpenVMS_On_Target : Boolean := False; + -- Set to True if target is OpenVMS + + RTX_RTSS_Kernel_Module_On_Target : Boolean := False; + -- Set to True if target is RTSS module for RTX + + type Virtual_Machine_Kind is (No_VM, JVM_Target, CLI_Target); + VM_Target : Virtual_Machine_Kind := No_VM; + -- Kind of virtual machine targetted + -- No_VM: no virtual machine, default case of a standard processor + -- JVM_Target: Java Virtual Machine + -- CLI_Target: CLI/.NET Virtual Machine + + ------------------------------- + -- Backend Arithmetic Checks -- + ------------------------------- + + -- Divide and overflow checks are either done in the front end or + -- back end. The front end will generate checks when required unless + -- the corresponding parameter here is set to indicate that the back + -- end will generate the required checks (or that the checks are + -- automatically performed by the hardware in an appropriate form). + + Backend_Divide_Checks_On_Target : Boolean := False; + -- Set True if the back end generates divide checks, or if the hardware + -- checks automatically. Set False if the front end must generate the + -- required tests using explicit expanded code. + + Backend_Overflow_Checks_On_Target : Boolean := False; + -- Set True if the back end generates arithmetic overflow checks, or if + -- the hardware checks automatically. Set False if the front end must + -- generate the required tests using explicit expanded code. + + ----------------------------------- + -- Control of Exception Handling -- + ----------------------------------- + + -- GNAT implements three methods of implementing exceptions: + + -- Front-End Longjmp/Setjmp Exceptions + + -- This approach uses longjmp/setjmp to handle exceptions. It + -- uses less storage, and can often propagate exceptions faster, + -- at the expense of (sometimes considerable) overhead in setting + -- up an exception handler. This approach is available on all + -- targets, and is the default where it is the only approach. + + -- The generation of the setjmp and longjmp calls is handled by + -- the front end of the compiler (this includes gigi in the case + -- of the standard GCC back end). It does not use any back end + -- support (such as the GCC3 exception handling mechanism). When + -- this approach is used, the compiler generates special exception + -- handlers for handling cleanups when an exception is raised. + + -- Front-End Zero Cost Exceptions + + -- This approach uses separate exception tables. These use extra + -- storage, and exception propagation can be quite slow, but there + -- is no overhead in setting up an exception handler (it is to this + -- latter operation that the phrase zero-cost refers). This approach + -- is only available on some targets, and is the default where it is + -- available. + + -- The generation of the exception tables is handled by the front + -- end of the compiler. It does not use any back end support (such + -- as the GCC3 exception handling mechanism). When this approach + -- is used, the compiler generates special exception handlers for + -- handling cleanups when an exception is raised. + + -- Back-End Zero Cost Exceptions + + -- With this approach, the back end handles the generation and + -- handling of exceptions. For example, the GCC3 exception handling + -- mechanisms are used in this mode. The front end simply generates + -- code for explicit exception handlers, and AT END cleanup handlers + -- are simply passed unchanged to the backend for generating cleanups + -- both in the exceptional and non-exceptional cases. + + -- As the name implies, this approach generally uses a zero-cost + -- mechanism with tables, but the tables are generated by the back + -- end. However, since the back-end is entirely responsible for the + -- handling of exceptions, another mechanism might be used. In the + -- case of GCC3 for instance, it might be the case that the compiler + -- is configured for setjmp/longjmp handling, then everything will + -- work correctly. However, it is definitely preferred that the + -- back end provide zero cost exception handling. + + -- Controlling the selection of methods + + -- On most implementations, back-end zero-cost exceptions are used. + -- Otherwise, Front-End Longjmp/Setjmp approach is used. + -- Note that there is a requirement that all Ada units in a partition + -- be compiled with the same exception model. + + -- Control of Available Methods and Defaults + + -- The following switches specify whether ZCX is available, and + -- whether it is enabled by default. + + ZCX_By_Default_On_Target : Boolean := False; + -- Indicates if zero cost exceptions are active by default. If this + -- variable is False, then the only possible exception method is the + -- front-end setjmp/longjmp approach, and this is the default. If + -- this variable is True, then GCC ZCX is used. + + GCC_ZCX_Support_On_Target : Boolean := False; + -- Indicates that the target supports GCC Exceptions + + ------------------------------------ + -- Run-Time Library Configuration -- + ------------------------------------ + + -- In configurable run-time mode, the system run-time may not support + -- the full Ada language. The effect of setting this switch is to let + -- the compiler know that it is not surprising (i.e. the system is not + -- misconfigured) if run-time library units or entities within units are + -- not present in the run-time. + + Configurable_Run_Time_On_Target : Boolean := False; + -- Indicates that the system.ads file is for a configurable run-time + -- + -- This has some specific effects as follows + -- + -- The binder generates the gnat_argc/argv/envp variables in the + -- binder file instead of being imported from the run-time library. + -- If Command_Line_Args_On_Target is set to False, then the + -- generation of these variables is suppressed completely. + -- + -- The binder generates the gnat_exit_status variable in the binder + -- file instead of being imported from the run-time library. If + -- Exit_Status_Supported_On_Target is set to False, then the + -- generation of this variable is suppressed entirely. + -- + -- The routine __gnat_break_start is defined within the binder file + -- instead of being imported from the run-time library. + -- + -- The variable __gnat_exit_status is generated within the binder file + -- instead of being imported from the run-time library. + + Suppress_Standard_Library_On_Target : Boolean := False; + -- If this flag is True, then the standard library is not included by + -- default in the executable (see unit System.Standard_Library in file + -- s-stalib.ads for details of what this includes). This is for example + -- set True for the zero foot print case, where these files should not + -- be included by default. + -- + -- This flag has some other related effects: + -- + -- The generation of global variables in the bind file is suppressed, + -- with the exception of the priority of the environment task, which + -- is needed by the Ravenscar run-time. + -- + -- The calls to __gnat_initialize and __gnat_finalize are omitted + -- + -- All finalization and initialization (controlled types) is omitted + -- + -- The routine __gnat_handler_installed is not imported + + Preallocated_Stacks_On_Target : Boolean := False; + -- If this flag is True, then the expander preallocates all task stacks + -- at compile time. If the flag is False, then task stacks are not pre- + -- allocated, and task stack allocation is the responsibility of the + -- run-time (which typically delegates the task to the underlying + -- operating system environment). + + --------------------- + -- Duration Format -- + --------------------- + + -- By default, type Duration is a 64-bit fixed-point type with a delta + -- and small of 10**(-9) (i.e. it is a count in nanoseconds. This flag + -- allows that standard format to be modified. + + Duration_32_Bits_On_Target : Boolean := False; + -- If True, then Duration is represented in 32 bits and the delta and + -- small values are set to 20.0*(10**(-3)) (i.e. it is a count in units + -- of 20 milliseconds. + + ------------------------------------ + -- Back-End Code Generation Flags -- + ------------------------------------ + + -- These flags indicate possible limitations in what the code generator + -- can handle. They will all be True for a full run-time, but one or more + -- of these may be false for a configurable run-time, and if a feature is + -- used at the source level, and the corresponding flag is false, then an + -- error message will be issued saying the feature is not supported. + + Support_64_Bit_Divides_On_Target : Boolean := True; + -- If True, the back end supports 64-bit divide operations. If False, then + -- the source program may not contain 64-bit divide operations. This is + -- specifically useful in the zero foot-print case, where the issue is + -- whether there is a hardware divide instruction for 64-bits so that + -- no run-time support is required. It should always be set True if the + -- necessary run-time support is present. + + Support_Aggregates_On_Target : Boolean := True; + -- In the general case, the use of aggregates may generate calls + -- to run-time routines in the C library, including memset, memcpy, + -- memmove, and bcopy. This flag is set to True if these routines + -- are available. If any of these routines is not available, then + -- this flag is False, and the use of aggregates is not permitted. + + Support_Composite_Assign_On_Target : Boolean := True; + -- The assignment of composite objects other than small records and + -- arrays whose size is 64-bits or less and is set by an explicit + -- size clause may generate calls to memcpy, memmove, and bcopy. + -- If versions of all these routines are available, then this flag + -- is set to True. If any of these routines is not available, then + -- the flag is set False, and composite assignments are not allowed. + + Support_Composite_Compare_On_Target : Boolean := True; + -- If this flag is True, then the back end supports bit-wise comparison + -- of composite objects for equality, either generating inline code or + -- calling appropriate (and available) run-time routines. If this flag + -- is False, then the back end does not provide this support, and the + -- front end uses component by component comparison for composites. + + Support_Long_Shifts_On_Target : Boolean := True; + -- If True, the back end supports 64-bit shift operations. If False, then + -- the source program may not contain explicit 64-bit shifts. In addition, + -- the code generated for packed arrays will avoid the use of long shifts. + + -------------------- + -- Indirect Calls -- + -------------------- + + Always_Compatible_Rep_On_Target : Boolean := True; + -- If True, the Can_Use_Internal_Rep flag (see Einfo) is set to False in + -- all cases. This corresponds to the traditional code generation + -- strategy. False allows the front end to choose a policy that partly or + -- entirely eliminates dynamically generated trampolines. + + ------------------------------- + -- Control of Stack Checking -- + ------------------------------- + + -- GNAT provides three methods of implementing exceptions: + + -- GCC Probing Mechanism + + -- This approach uses the standard GCC mechanism for + -- stack checking. The method assumes that accessing + -- storage immediately beyond the end of the stack + -- will result in a trap that is converted to a storage + -- error by the runtime system. This mechanism has + -- minimal overhead, but requires complex hardware, + -- operating system and run-time support. Probing is + -- the default method where it is available. The stack + -- size for the environment task depends on the operating + -- system and cannot be set in a system-independent way. + + -- GCC Stack-limit Mechanism + + -- This approach uses the GCC stack limits mechanism. + -- It relies on comparing the stack pointer with the + -- values of a global symbol. If the check fails, a + -- trap is explicitly generated. The advantage is + -- that the mechanism requires no memory protection, + -- but operating system and run-time support are + -- needed to manage the per-task values of the symbol. + -- This is the default method after probing where it + -- is available. + + -- GNAT Stack-limit Checking + + -- This method relies on comparing the stack pointer + -- with per-task stack limits. If the check fails, an + -- exception is explicitly raised. The advantage is + -- that the method requires no extra system dependent + -- runtime support and can be used on systems without + -- memory protection as well, but at the cost of more + -- overhead for doing the check. This is the fallback + -- method if the above two are not supported. + + Stack_Check_Probes_On_Target : Boolean := False; + -- Indicates if the GCC probing mechanism is used + + Stack_Check_Limits_On_Target : Boolean := False; + -- Indicates if the GCC stack-limit mechanism is used + + -- Both flags cannot be simultaneously set to True. If neither + -- is, the target independent fallback method is used. + + Stack_Check_Default_On_Target : Boolean := False; + -- Indicates if stack checking is on by default + + ---------------------------- + -- Command Line Arguments -- + ---------------------------- + + -- For most ports of GNAT, command line arguments are supported. The + -- following flag is set to False for targets that do not support + -- command line arguments (VxWorks and AAMP). Note that support of + -- command line arguments is not required on such targets (RM A.15(13)). + + Command_Line_Args_On_Target : Boolean := True; + -- Set False if no command line arguments on target. Note that if this + -- is False in with Configurable_Run_Time_On_Target set to True, then + -- this causes suppression of generation of the argv/argc variables + -- used to record command line arguments. + + -- Similarly, most ports support the use of an exit status, but AAMP + -- is an exception (as allowed by RM A.15(18-20)) + + Exit_Status_Supported_On_Target : Boolean := True; + -- Set False if returning of an exit status is not supported on target. + -- Note that if this False in with Configurable_Run_Time_On_Target + -- set to True, then this causes suppression of the gnat_exit_status + -- variable used to record the exit status. + + ----------------------- + -- Main Program Name -- + ----------------------- + + -- When the binder generates the main program to be used to create the + -- executable, the main program name is main by default (to match the + -- usual Unix practice). If this parameter is set to True, then the + -- name is instead by default taken from the actual Ada main program + -- name (just the name of the child if the main program is a child unit). + -- In either case, this value can be overridden using -M name. + + Use_Ada_Main_Program_Name_On_Target : Boolean := False; + -- Set True to use the Ada main program name as the main name + + ---------------------------------------------- + -- Boolean-Valued Floating-Point Attributes -- + ---------------------------------------------- + + -- The constants below give the values for representation oriented + -- floating-point attributes that are the same for all float types + -- on the target. These are all boolean values. + + -- A value is only True if the target reliably supports the corresponding + -- feature. Reliably here means that support is guaranteed for all + -- possible settings of the relevant compiler switches (like -mieee), + -- since we cannot control the user setting of those switches. + + -- The attributes cannot dependent on the current setting of compiler + -- switches, since the values must be static and consistent throughout + -- the partition. We probably should add such consistency checks in future, + -- but for now we don't do this. + + -- Note: the compiler itself does not use floating-point, so the + -- settings of the defaults here are not really relevant. + + -- Note: in some cases, proper support of some of these floating point + -- features may require a specific switch (e.g. -mieee on the Alpha) + -- to be used to obtain full RM compliant support. + + Denorm_On_Target : Boolean := False; + -- Set to False on targets that do not reliably support denormals + + Machine_Rounds_On_Target : Boolean := True; + -- Set to False for targets where S'Machine_Rounds is False + + Machine_Overflows_On_Target : Boolean := False; + -- Set to True for targets where S'Machine_Overflows is True + + Signed_Zeros_On_Target : Boolean := True; + -- Set to False on targets that do not reliably support signed zeros + + ------------------------------------------- + -- Boolean-Valued Fixed-Point Attributes -- + ------------------------------------------- + + Fractional_Fixed_Ops_On_Target : Boolean := False; + -- Set to True for targets that support fixed-by-fixed multiplication + -- and division for fixed-point types with a small value equal to + -- 2 ** (-(T'Object_Size - 1)) and whose values have an absolute + -- value less than 1.0. + + ----------------- + -- Data Layout -- + ----------------- + + -- Normally when using the GCC backend, Gigi and GCC perform much of the + -- data layout using the standard layout capabilities of GCC. If the + -- parameter Backend_Layout is set to False, then the front end must + -- perform all data layout. For further details see the package Layout. + + Frontend_Layout_On_Target : Boolean := False; + -- Set True if front end does layout + + ----------------- + -- Subprograms -- + ----------------- + + -- These subprograms are used to initialize the target parameter values + -- from the system.ads file. Note that this is only done once, so if more + -- than one call is made to either routine, the second and subsequent + -- calls are ignored. + + procedure Get_Target_Parameters + (System_Text : Source_Buffer_Ptr; + Source_First : Source_Ptr; + Source_Last : Source_Ptr); + -- Called at the start of execution to obtain target parameters from + -- the source of package System. The parameters provide the source + -- text to be scanned (in System_Text (Source_First .. Source_Last)). + + procedure Get_Target_Parameters; + -- This version reads in system.ads using Osint. The idea is that the + -- caller uses the first version if they have to read system.ads anyway + -- (e.g. the compiler) and uses this simpler interface if system.ads is + -- not otherwise needed. + +end Targparm; diff --git a/gcc/ada/tb-alvms.c b/gcc/ada/tb-alvms.c new file mode 100644 index 000000000..d69128b92 --- /dev/null +++ b/gcc/ada/tb-alvms.c @@ -0,0 +1,396 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * T R A C E B A C K - A l p h a / V M S * + * * + * C Implementation File * + * * + * Copyright (C) 2003-2007, AdaCore * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 2, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING. If not, write * + * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * + * Boston, MA 02110-1301, USA. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion does not however invalidate any other reasons why the executable * + * file might be covered by the GNU Public License. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + + +/* Alpha VMS requires a special treatment due to the complexity of the ABI. + What is here is along the lines of what the MD_FALLBACK_FRAME_STATE_FOR + macro does for frame unwinding during exception propagation. This file is + #included within tracebak.c in the appropriate case. + + Most of the contents is directed by the OpenVMS/Alpha Conventions (ABI) + document, sections of which we will refer to as ABI-. */ + +#include +#include +#include +#include + +/* A couple of items missing from the header file included above. */ +extern void * SYS$GL_CALL_HANDL; +#define PDSC$M_BASE_FRAME (1 << 10) + +/* Registers are 64bit wide and addresses are 32bit wide on alpha-vms. */ +typedef void * ADDR; +typedef unsigned long long REG; + +#define REG_AT(addr) (*(REG *)(addr)) + +#define AS_REG(addr) ((REG)(unsigned long)(addr)) +#define AS_ADDR(reg) ((ADDR)(unsigned long)(reg)) +#define ADDR_IN(reg) (AS_ADDR(reg)) + +/* The following structure defines the state maintained during the + unwinding process. */ +typedef struct +{ + ADDR pc; /* Address of the call insn involved in the chain. */ + ADDR sp; /* Stack Pointer at the time of this call. */ + ADDR fp; /* Frame Pointer at the time of this call. */ + + /* The values above are fetched as saved REGisters on the stack. They are + typed ADDR because this is what the values in those registers are. */ + + /* Values of the registers saved by the functions in the chain, + incrementally updated through consecutive calls to the "unwind" function + below. */ + REG saved_regs [32]; +} frame_state_t; + +/* Shortcuts for saved_regs of specific interest: + + Frame Pointer is r29, + Stack Pointer is r30, + Return Address is r26, + Procedure Value is r27. + + This is from ABI-3.1.1 [Integer Registers]. */ + +#define saved_fpr saved_regs[29] +#define saved_spr saved_regs[30] +#define saved_rar saved_regs[26] +#define saved_pvr saved_regs[27] + +/* Special values for saved_rar, used to control the overall unwinding + process. */ +#define RA_UNKNOWN ((REG)~0) +#define RA_STOP ((REG)0) + +/* We still use a number of macros similar to the ones for the generic + __gnat_backtrace implementation. */ +#define PC_ADJUST 4 +#define STOP_FRAME (frame_state.saved_rar == RA_STOP) + +/* Compute Procedure Value from Frame Pointer value. This follows the rules + in ABI-3.6.1 [Current Procedure]. */ +#define PV_FOR(FP) \ + (((FP) != 0) \ + ? (((REG_AT (FP) & 0x7) == 0) ? *(PDSCDEF **)(FP) : (PDSCDEF *)(FP)) : 0) + + +/********** + * unwind * + **********/ + +/* Helper for __gnat_backtrace. + + FS represents some call frame, identified by a pc and associated frame + pointer in FS->pc and FS->fp. FS->saved_regs contains the state of the + general registers upon entry in this frame. Of most interest in this set + are the saved return address and frame pointer registers, which actually + allow identifying the caller's frame. + + This routine "unwinds" the input frame state by adjusting it to eventually + represent its caller's frame. The basic principle is to shift the fp and pc + saved values into the current state, and then compute the corresponding new + saved registers set. + + If the call chain goes through a signal handler, special processing is + required when we process the kernel frame which has called the handler, to + switch it to the interrupted context frame. */ + +#define K_HANDLER_FRAME(fs) (PV_FOR ((fs)->fp) == SYS$GL_CALL_HANDL) + +static void unwind_regular_code (frame_state_t * fs); +static void unwind_kernel_handler (frame_state_t * fs); + +void +unwind (frame_state_t * fs) +{ + /* Don't do anything if requested so. */ + if (fs->saved_rar == RA_STOP) + return; + + /* Retrieve the values of interest computed during the previous + call. PC_ADJUST gets us from the return address to the call insn + address. */ + fs->pc = ADDR_IN (fs->saved_rar) - PC_ADJUST; + fs->sp = ADDR_IN (fs->saved_spr); + fs->fp = ADDR_IN (fs->saved_fpr); + + /* Unless we are able to determine otherwise, set the frame state's + saved return address such that the unwinding process will stop. */ + fs->saved_rar = RA_STOP; + + /* Now we want to update fs->saved_regs to reflect the state of the caller + of the procedure described by pc/fp. + + The condition to check for a special kernel frame which has called a + signal handler is stated in ABI-6.7.1 [Signaler's Registers] : "The frame + of the call to the handler can be identified by the return address of + SYS$CALL_HANDL+4". We use the equivalent procedure value identification + here because SYS$CALL_HANDL appears to be undefined. */ + + if (K_HANDLER_FRAME (fs)) + unwind_kernel_handler (fs); + else + unwind_regular_code (fs); +} + +/*********************** + * unwind_regular_code * + ***********************/ + +/* Helper for unwind, for the case of unwinding through regular code which + is not a signal handler. */ + +static void +unwind_regular_code (frame_state_t * fs) +{ + PDSCDEF * pv = PV_FOR (fs->fp); + + ADDR frame_base; + + /* Use the procedure value to unwind, in a way depending on the kind of + procedure at hand. See ABI-3.3 [Procedure Representation] and ABI-3.4 + [Procedure Types]. */ + + if (pv == 0 + || pv->pdsc$w_flags & PDSC$M_BASE_FRAME) + return; + + frame_base + = (pv->pdsc$w_flags & PDSC$M_BASE_REG_IS_FP) ? fs->fp : fs->sp; + + switch (pv->pdsc$w_flags & 0xf) + { + case PDSC$K_KIND_FP_STACK: + /* Stack Frame Procedure (ABI-3.4.1). Retrieve the necessary registers + from the Register Save Area in the frame. */ + { + ADDR rsa_base = frame_base + pv->pdsc$w_rsa_offset; + int i, j; + + fs->saved_rar = REG_AT (rsa_base); + fs->saved_pvr = REG_AT (frame_base); + + for (i = 0, j = 0; i < 32; i++) + if (pv->pdsc$l_ireg_mask & (1 << i)) + fs->saved_regs[i] = REG_AT (rsa_base + 8 * ++j); + + /* Note that the loop above is guaranteed to set fs->saved_fpr, + because "The preserved register set must always include R29(FP) + since it will always be used." (ABI-3.4.3.4 [Register Save Area for + All Stack Frames]). + + Also note that we need to run through all the registers to ensure + that unwinding through register procedures (see below) gets the + right values out of the saved_regs array. */ + } + break; + + case PDSC$K_KIND_FP_REGISTER: + /* Register Procedure (ABI-3.4.4). Retrieve the necessary registers from + the registers where they have been saved. */ + { + fs->saved_rar = fs->saved_regs[pv->pdsc$b_save_ra]; + fs->saved_fpr = fs->saved_regs[pv->pdsc$b_save_fp]; + } + break; + + default: + /* ??? Are we supposed to ever get here ? Don't think so. */ + break; + } + + /* SP is actually never part of the saved registers area, so we use the + corresponding entry in the saved_regs array to manually keep track of + it's evolution. */ + fs->saved_spr = AS_REG (frame_base) + pv->pdsc$l_size; +} + +/************************* + * unwind_kernel_handler * + *************************/ + +/* Helper for unwind, for the specific case of unwinding through a signal + handler. + + The input frame state describes the kernel frame which has called a signal + handler. We fill the corresponding saved_regs to have it's "caller" frame + represented as the interrupted context. */ + +static void +unwind_kernel_handler (frame_state_t * fs) +{ + PDSCDEF * pv = PV_FOR (fs->fp); + + CHFDEF1 *sigargs; + CHFDEF2 *mechargs; + + /* Retrieve the arguments passed to the handler, by way of a VMS service + providing the corresponding "Invocation Context Block". */ + { + long handler_ivhandle; + INVO_CONTEXT_BLK handler_ivcb; + + CHFCTX *chfctx; + + handler_ivcb.libicb$q_ireg [29] = AS_REG (fs->fp); + handler_ivcb.libicb$q_ireg [30] = 0; + + handler_ivhandle = LIB$GET_INVO_HANDLE (&handler_ivcb); + + if ((LIB$GET_INVO_CONTEXT (handler_ivhandle, &handler_ivcb) & 1) != 1) + return; + + chfctx = (CHFCTX *) AS_ADDR (handler_ivcb.libicb$ph_chfctx_addr); + + sigargs = (CHFDEF1 *) AS_ADDR (chfctx->chfctx$q_sigarglst); + mechargs = (CHFDEF2 *) AS_ADDR (chfctx->chfctx$q_mcharglst); + } + + /* Compute the saved return address as the PC of the instruction causing the + condition, accounting for the fact that it will be adjusted by the next + call to "unwind" as if it was an actual call return address. */ + { + /* ABI-6.5.1.1 [Signal Argument Vector]: The signal occurrence address + is available from the sigargs argument to the handler, designed to + support both 32 and 64 bit addresses. The initial reference we get + is a pointer to the 32bit form, from which one may extract a pointer + to the 64bit version if need be. We work directly from the 32bit + form here. */ + + /* The sigargs vector structure for 32bits addresses is: + + <......32bit......> + +-----------------+ + | Vsize | :chf$is_sig_args + +-----------------+ -+- + | Condition Value | : [0] + +-----------------+ : + | ... | : + +-----------------+ : vector of Vsize entries + | Signal PC | : + +-----------------+ : + | PS | : [Vsize - 1] + +-----------------+ -+- + + */ + + unsigned long * sigargs_vector + = ((unsigned long *) (&sigargs->chf$is_sig_args)) + 1; + + long sigargs_vsize + = sigargs->chf$is_sig_args; + + fs->saved_rar = (REG) sigargs_vector [sigargs_vsize - 2] + PC_ADJUST; + } + + fs->saved_spr = RA_UNKNOWN; + fs->saved_fpr = (REG) mechargs->chf$q_mch_frame; + fs->saved_pvr = (REG) mechargs->chf$q_mch_savr27; + + fs->saved_regs[16] = (REG) mechargs->chf$q_mch_savr16; + fs->saved_regs[17] = (REG) mechargs->chf$q_mch_savr17; + fs->saved_regs[18] = (REG) mechargs->chf$q_mch_savr18; + fs->saved_regs[19] = (REG) mechargs->chf$q_mch_savr19; + fs->saved_regs[20] = (REG) mechargs->chf$q_mch_savr20; +} + +/* Structure representing a traceback entry in the tracebacks array to be + filled by __gnat_backtrace below. + + !! This should match what is in System.Traceback_Entries, so beware of + !! the REG/ADDR difference here. + + The use of a structure is motivated by the potential necessity of having + several fields to fill for each entry, for instance if later calls to VMS + system functions need more than just a mere PC to compute info on a frame + (e.g. for non-symbolic->symbolic translation purposes). */ +typedef struct { + ADDR pc; /* Program Counter. */ + ADDR pv; /* Procedure Value. */ +} tb_entry_t; + +/******************** + * __gnat_backtrace * + ********************/ + +int +__gnat_backtrace (void **array, int size, + void *exclude_min, void *exclude_max, int skip_frames) +{ + int cnt; + + tb_entry_t * tbe = (tb_entry_t *)&array [0]; + + frame_state_t frame_state; + + /* Setup the frame state before initiating the unwinding sequence. */ + register REG this_FP __asm__("$29"); + register REG this_SP __asm__("$30"); + + frame_state.saved_fpr = this_FP; + frame_state.saved_spr = this_SP; + frame_state.saved_rar = RA_UNKNOWN; + + unwind (&frame_state); + + /* At this point frame_state describes this very function. Skip the + requested number of calls. */ + for (cnt = 0; cnt < skip_frames; cnt ++) + unwind (&frame_state); + + /* Now consider each frame as a potential candidate for insertion inside + the provided array. */ + cnt = 0; + while (cnt < size) + { + /* Stop if either the frame contents or the unwinder say so. */ + if (STOP_FRAME) + break; + + if (! K_HANDLER_FRAME (&frame_state) + && (frame_state.pc < exclude_min || frame_state.pc > exclude_max)) + { + tbe->pc = (ADDR) frame_state.pc; + tbe->pv = (ADDR) PV_FOR (frame_state.fp); + + cnt ++; + tbe ++; + } + + unwind (&frame_state); + } + + return cnt; +} diff --git a/gcc/ada/tb-alvxw.c b/gcc/ada/tb-alvxw.c new file mode 100644 index 000000000..381c9b040 --- /dev/null +++ b/gcc/ada/tb-alvxw.c @@ -0,0 +1,941 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * T R A C E B A C K - A l p h a / V x W o r k s * + * * + * C Implementation File * + * * + * Copyright (C) 2000-2006, AdaCore * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 2, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING. If not, write * + * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * + * Boston, MA 02110-1301, USA. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion does not however invalidate any other reasons why the executable * + * file might be covered by the GNU Public License. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* Alpha vxWorks requires a special, complex treatment that is extracted + from GDB. This file is #included within tracebak.c in the appropriate + case. */ + +#include +#include +#include +#include + +extern void kerTaskEntry(void); + +/* We still use a number of macros similar to the ones for the generic + __gnat_backtrace implementation. */ +#define SKIP_FRAME 1 +#define PC_ADJUST -4 + +#define STOP_FRAME \ + (current == NULL \ + || ((CORE_ADDR) &kerTaskEntry >= PROC_LOW_ADDR (current->proc_desc) \ + && current->pc >= (CORE_ADDR) &kerTaskEntry)) + +/* Register numbers of various important registers. + Note that most of these values are "real" register numbers, + and correspond to the general registers of the machine, + and FP_REGNUM is a "phony" register number which is too large + to be an actual register number as far as the user is concerned + but serves to get the desired value when passed to read_register. */ + +#define T7_REGNUM 8 /* Return address register for OSF/1 __add* */ +#define GCC_FP_REGNUM 15 /* Used by gcc as frame register */ +#define T9_REGNUM 23 /* Return address register for OSF/1 __div* */ +#define SP_REGNUM 30 /* Contains address of top of stack */ +#define RA_REGNUM 26 /* Contains return address value */ +#define FP0_REGNUM 32 /* Floating point register 0 */ +#define PC_REGNUM 64 /* Contains program counter */ +#define NUM_REGS 66 + +#define VM_MIN_ADDRESS (CORE_ADDR)0x120000000 + +#define SIZEOF_FRAME_SAVED_REGS (sizeof (CORE_ADDR) * (NUM_REGS)) +#define INIT_EXTRA_FRAME_INFO(fromleaf, fci) init_extra_frame_info(fci) + +#define FRAME_CHAIN(thisframe) (CORE_ADDR) alpha_frame_chain (thisframe) + +#define FRAME_CHAIN_VALID(CHAIN, THISFRAME) \ + ((CHAIN) != 0 \ + && !inside_entry_file (FRAME_SAVED_PC (THISFRAME))) + +#define FRAME_SAVED_PC(FRAME) (alpha_frame_saved_pc (FRAME)) + +#define FRAME_CHAIN_COMBINE(CHAIN, THISFRAME) (CHAIN) + +#define INIT_FRAME_PC(FROMLEAF, PREV) + +#define INIT_FRAME_PC_FIRST(FROMLEAF, PREV) \ + (PREV)->pc = ((FROMLEAF) ? SAVED_PC_AFTER_CALL ((PREV)->next) \ + : (PREV)->next ? FRAME_SAVED_PC ((PREV)->next) : read_pc ()); + +#define SAVED_PC_AFTER_CALL(FRAME) alpha_saved_pc_after_call (FRAME) + +typedef unsigned long long int bfd_vma; + +typedef bfd_vma CORE_ADDR; + +typedef struct pdr +{ + bfd_vma adr; /* memory address of start of procedure */ + long isym; /* start of local symbol entries */ + long iline; /* start of line number entries*/ + long regmask; /* save register mask */ + long regoffset; /* save register offset */ + long iopt; /* start of optimization symbol entries*/ + long fregmask; /* save floating point register mask */ + long fregoffset; /* save floating point register offset */ + long frameoffset; /* frame size */ + short framereg; /* frame pointer register */ + short pcreg; /* offset or reg of return pc */ + long lnLow; /* lowest line in the procedure */ + long lnHigh; /* highest line in the procedure */ + bfd_vma cbLineOffset; /* byte offset for this procedure from the fd base */ + /* These fields are new for 64 bit ECOFF. */ + unsigned gp_prologue : 8; /* byte size of GP prologue */ + unsigned gp_used : 1; /* true if the procedure uses GP */ + unsigned reg_frame : 1; /* true if register frame procedure */ + unsigned prof : 1; /* true if compiled with -pg */ + unsigned reserved : 13; /* reserved: must be zero */ + unsigned localoff : 8; /* offset of local variables from vfp */ +} PDR; + +typedef struct alpha_extra_func_info +{ + long numargs; /* number of args to procedure (was iopt) */ + PDR pdr; /* Procedure descriptor record */ +} +*alpha_extra_func_info_t; + +struct frame_info +{ + /* Nominal address of the frame described. See comments at FRAME_FP + about what this means outside the *FRAME* macros; in the *FRAME* + macros, it can mean whatever makes most sense for this machine. */ + CORE_ADDR frame; + + /* Address at which execution is occurring in this frame. For the + innermost frame, it's the current pc. For other frames, it is a + pc saved in the next frame. */ + CORE_ADDR pc; + + /* For each register, address of where it was saved on entry to the + frame, or zero if it was not saved on entry to this frame. This + includes special registers such as pc and fp saved in special + ways in the stack frame. The SP_REGNUM is even more special, the + address here is the sp for the next frame, not the address where + the sp was saved. Allocated by frame_saved_regs_zalloc () which + is called and initialized by FRAME_INIT_SAVED_REGS. */ + CORE_ADDR *saved_regs; /*NUM_REGS */ + + int localoff; + int pc_reg; + alpha_extra_func_info_t proc_desc; + + /* Pointers to the next and previous frame_info's in the frame cache. */ + struct frame_info *next, *prev; +}; + +struct frame_saved_regs +{ + /* For each register R (except the SP), regs[R] is the address at + which it was saved on entry to the frame, or zero if it was not + saved on entry to this frame. This includes special registers + such as pc and fp saved in special ways in the stack frame. + + regs[SP_REGNUM] is different. It holds the actual SP, not the + address at which it was saved. */ + + CORE_ADDR regs[NUM_REGS]; +}; + +static CORE_ADDR theRegisters[32]; + +/* Prototypes for local functions. */ + +static CORE_ADDR read_next_frame_reg (struct frame_info *, int); +static CORE_ADDR heuristic_proc_start (CORE_ADDR); +static int alpha_about_to_return (CORE_ADDR pc); +static void init_extra_frame_info (struct frame_info *); +static CORE_ADDR alpha_frame_chain (struct frame_info *); +static CORE_ADDR alpha_frame_saved_pc (struct frame_info *frame); +static void *trace_alloc (unsigned int); +static struct frame_info *create_new_frame (CORE_ADDR, CORE_ADDR); + +static alpha_extra_func_info_t +heuristic_proc_desc (CORE_ADDR, CORE_ADDR, struct frame_info *, + struct frame_saved_regs *); + +static alpha_extra_func_info_t +find_proc_desc (CORE_ADDR, struct frame_info *, struct frame_saved_regs *); + +/* Heuristic_proc_start may hunt through the text section for a long + time across a 2400 baud serial line. Allows the user to limit this + search. */ +static unsigned int heuristic_fence_post = 1<<16; + +/* Layout of a stack frame on the alpha: + + | | + pdr members: | 7th ... nth arg, | + | `pushed' by caller. | + | | +----------------|-------------------------------|<-- old_sp == vfp + ^ ^ ^ ^ | | + | | | | | | + | |localoff | Copies of 1st .. 6th | + | | | | | argument if necessary. | + | | | v | | + | | | --- |-------------------------------|<-- FRAME_LOCALS_ADDRESS + | | | | | + | | | | Locals and temporaries. | + | | | | | + | | | |-------------------------------| + | | | | | + |-fregoffset | Saved float registers. | + | | | | F9 | + | | | | . | + | | | | . | + | | | | F2 | + | | v | | + | | -------|-------------------------------| + | | | | + | | | Saved registers. | + | | | S6 | + |-regoffset | . | + | | | . | + | | | S0 | + | | | pdr.pcreg | + | v | | + | ----------|-------------------------------| + | | | + frameoffset | Argument build area, gets | + | | 7th ... nth arg for any | + | | called procedure. | + v | | + -------------|-------------------------------|<-- sp + | | */ + +#define PROC_LOW_ADDR(PROC) ((PROC)->pdr.adr) /* least address */ +#define PROC_HIGH_ADDR(PROC) ((PROC)->pdr.iline) /* upper address bound */ +#define PROC_DUMMY_FRAME(PROC) ((PROC)->pdr.cbLineOffset) /*CALL_DUMMY frame */ +#define PROC_FRAME_OFFSET(PROC) ((PROC)->pdr.frameoffset) +#define PROC_FRAME_REG(PROC) ((PROC)->pdr.framereg) +#define PROC_REG_MASK(PROC) ((PROC)->pdr.regmask) +#define PROC_FREG_MASK(PROC) ((PROC)->pdr.fregmask) +#define PROC_REG_OFFSET(PROC) ((PROC)->pdr.regoffset) +#define PROC_FREG_OFFSET(PROC) ((PROC)->pdr.fregoffset) +#define PROC_PC_REG(PROC) ((PROC)->pdr.pcreg) +#define PROC_LOCALOFF(PROC) ((PROC)->pdr.localoff) + +/* Local storage allocation/deallocation functions. trace_alloc does + a malloc, but also chains allocated blocks on trace_alloc_chain, so + they may all be freed on exit from __gnat_backtrace. */ + +struct alloc_chain +{ + struct alloc_chain *next; + double x[0]; +}; +struct alloc_chain *trace_alloc_chain; + +static void * +trace_alloc (unsigned int n) +{ + struct alloc_chain * result = malloc (n + sizeof(struct alloc_chain)); + + result->next = trace_alloc_chain; + trace_alloc_chain = result; + return (void*) result->x; +} + +static void +free_trace_alloc (void) +{ + while (trace_alloc_chain != 0) + { + struct alloc_chain *old = trace_alloc_chain; + + trace_alloc_chain = trace_alloc_chain->next; + free (old); + } +} + +/* Read value at ADDR into *DEST, returning 0 if this is valid, != 0 + otherwise. */ + +static int +read_memory_safe4 (CORE_ADDR addr, unsigned int *dest) +{ + *dest = *((unsigned int*) addr); + return 0; +} + +/* Read value at ADDR into *DEST, returning 0 if this is valid, != 0 + otherwise. */ + +static int +read_memory_safe8 (CORE_ADDR addr, CORE_ADDR *dest) +{ + *dest = *((CORE_ADDR*) addr); + return 0; +} + +static CORE_ADDR +read_register (int regno) +{ + if (regno >= 0 && regno < 31) + return theRegisters[regno]; + + return (CORE_ADDR) 0; +} + +static void +frame_saved_regs_zalloc (struct frame_info *fi) +{ + fi->saved_regs = (CORE_ADDR *) trace_alloc (SIZEOF_FRAME_SAVED_REGS); + memset (fi->saved_regs, 0, SIZEOF_FRAME_SAVED_REGS); +} + +static void * +frame_obstack_alloc (unsigned long size) +{ + return (void *) trace_alloc (size); +} + +static int +inside_entry_file (CORE_ADDR addr) +{ + if (addr == 0) + return 1; + else + return 0; +} + +static CORE_ADDR +alpha_saved_pc_after_call (struct frame_info *frame) +{ + CORE_ADDR pc = frame->pc; + alpha_extra_func_info_t proc_desc; + int pcreg; + + proc_desc = find_proc_desc (pc, frame->next, NULL); + pcreg = proc_desc ? PROC_PC_REG (proc_desc) : RA_REGNUM; + + return read_register (pcreg); +} + +/* Guaranteed to set frame->saved_regs to some values (it never leaves it + NULL). */ + +static void +alpha_find_saved_regs (struct frame_info *frame) +{ + int ireg; + CORE_ADDR reg_position; + unsigned long mask; + alpha_extra_func_info_t proc_desc; + int returnreg; + + frame_saved_regs_zalloc (frame); + + /* If it is the frame for __sigtramp, the saved registers are located in a + sigcontext structure somewhere on the stack. __sigtramp passes a pointer + to the sigcontext structure on the stack. If the stack layout for + __sigtramp changes, or if sigcontext offsets change, we might have to + update this code. */ + +#ifndef SIGFRAME_PC_OFF +#define SIGFRAME_PC_OFF (2 * 8) +#define SIGFRAME_REGSAVE_OFF (4 * 8) +#define SIGFRAME_FPREGSAVE_OFF (SIGFRAME_REGSAVE_OFF + 32 * 8 + 8) +#endif + + proc_desc = frame->proc_desc; + if (proc_desc == NULL) + /* I'm not sure how/whether this can happen. Normally when we can't + find a proc_desc, we "synthesize" one using heuristic_proc_desc + and set the saved_regs right away. */ + return; + + /* Fill in the offsets for the registers which gen_mask says + were saved. */ + + reg_position = frame->frame + PROC_REG_OFFSET (proc_desc); + mask = PROC_REG_MASK (proc_desc); + + returnreg = PROC_PC_REG (proc_desc); + + /* Note that RA is always saved first, regardless of its actual + register number. */ + if (mask & (1 << returnreg)) + { + frame->saved_regs[returnreg] = reg_position; + reg_position += 8; + mask &= ~(1 << returnreg); /* Clear bit for RA so we + don't save again later. */ + } + + for (ireg = 0; ireg <= 31; ireg++) + if (mask & (1 << ireg)) + { + frame->saved_regs[ireg] = reg_position; + reg_position += 8; + } + + /* Fill in the offsets for the registers which float_mask says + were saved. */ + + reg_position = frame->frame + PROC_FREG_OFFSET (proc_desc); + mask = PROC_FREG_MASK (proc_desc); + + for (ireg = 0; ireg <= 31; ireg++) + if (mask & (1 << ireg)) + { + frame->saved_regs[FP0_REGNUM + ireg] = reg_position; + reg_position += 8; + } + + frame->saved_regs[PC_REGNUM] = frame->saved_regs[returnreg]; +} + +static CORE_ADDR +read_next_frame_reg (struct frame_info *fi, int regno) +{ + CORE_ADDR result; + for (; fi; fi = fi->next) + { + /* We have to get the saved sp from the sigcontext + if it is a signal handler frame. */ + if (regno == SP_REGNUM) + return fi->frame; + else + { + if (fi->saved_regs == 0) + alpha_find_saved_regs (fi); + + if (fi->saved_regs[regno]) + { + if (read_memory_safe8 (fi->saved_regs[regno], &result) == 0) + return result; + else + return 0; + } + } + } + + return read_register (regno); +} + +static CORE_ADDR +alpha_frame_saved_pc (struct frame_info *frame) +{ + return read_next_frame_reg (frame, frame->pc_reg); +} + +static struct alpha_extra_func_info temp_proc_desc; + +/* Nonzero if instruction at PC is a return instruction. "ret + $zero,($ra),1" on alpha. */ + +static int +alpha_about_to_return (CORE_ADDR pc) +{ + int inst; + + read_memory_safe4 (pc, &inst); + return inst == 0x6bfa8001; +} + +/* A heuristically computed start address for the subprogram + containing address PC. Returns 0 if none detected. */ + +static CORE_ADDR +heuristic_proc_start (CORE_ADDR pc) +{ + CORE_ADDR start_pc = pc; + CORE_ADDR fence = start_pc - heuristic_fence_post; + + if (start_pc == 0) + return 0; + + if (heuristic_fence_post == UINT_MAX + || fence < VM_MIN_ADDRESS) + fence = VM_MIN_ADDRESS; + + /* search back for previous return */ + for (start_pc -= 4; ; start_pc -= 4) + { + if (start_pc < fence) + return 0; + else if (alpha_about_to_return (start_pc)) + break; + } + + start_pc += 4; /* skip return */ + return start_pc; +} + +static alpha_extra_func_info_t +heuristic_proc_desc (CORE_ADDR start_pc, + CORE_ADDR limit_pc, + struct frame_info *next_frame, + struct frame_saved_regs *saved_regs_p) +{ + CORE_ADDR sp = read_next_frame_reg (next_frame, SP_REGNUM); + CORE_ADDR cur_pc; + int frame_size; + int has_frame_reg = 0; + unsigned long reg_mask = 0; + int pcreg = -1; + + if (start_pc == 0) + return 0; + + memset (&temp_proc_desc, '\0', sizeof (temp_proc_desc)); + if (saved_regs_p != 0) + memset (saved_regs_p, '\0', sizeof (struct frame_saved_regs)); + + PROC_LOW_ADDR (&temp_proc_desc) = start_pc; + + if (start_pc + 200 < limit_pc) + limit_pc = start_pc + 200; + + frame_size = 0; + for (cur_pc = start_pc; cur_pc < limit_pc; cur_pc += 4) + { + unsigned int word; + int status; + + status = read_memory_safe4 (cur_pc, &word); + if (status) + return 0; + + if ((word & 0xffff0000) == 0x23de0000) /* lda $sp,n($sp) */ + { + if (word & 0x8000) + frame_size += (-word) & 0xffff; + else + /* Exit loop if a positive stack adjustment is found, which + usually means that the stack cleanup code in the function + epilogue is reached. */ + break; + } + else if ((word & 0xfc1f0000) == 0xb41e0000 /* stq reg,n($sp) */ + && (word & 0xffff0000) != 0xb7fe0000) /* reg != $zero */ + { + int reg = (word & 0x03e00000) >> 21; + + reg_mask |= 1 << reg; + if (saved_regs_p != 0) + saved_regs_p->regs[reg] = sp + (short) word; + + /* Starting with OSF/1-3.2C, the system libraries are shipped + without local symbols, but they still contain procedure + descriptors without a symbol reference. GDB is currently + unable to find these procedure descriptors and uses + heuristic_proc_desc instead. + As some low level compiler support routines (__div*, __add*) + use a non-standard return address register, we have to + add some heuristics to determine the return address register, + or stepping over these routines will fail. + Usually the return address register is the first register + saved on the stack, but assembler optimization might + rearrange the register saves. + So we recognize only a few registers (t7, t9, ra) within + the procedure prologue as valid return address registers. + If we encounter a return instruction, we extract the + return address register from it. + + FIXME: Rewriting GDB to access the procedure descriptors, + e.g. via the minimal symbol table, might obviate this hack. */ + if (pcreg == -1 + && cur_pc < (start_pc + 80) + && (reg == T7_REGNUM || reg == T9_REGNUM || reg == RA_REGNUM)) + pcreg = reg; + } + else if ((word & 0xffe0ffff) == 0x6be08001) /* ret zero,reg,1 */ + pcreg = (word >> 16) & 0x1f; + else if (word == 0x47de040f) /* bis sp,sp fp */ + has_frame_reg = 1; + } + + if (pcreg == -1) + { + /* If we haven't found a valid return address register yet, + keep searching in the procedure prologue. */ + while (cur_pc < (limit_pc + 80) && cur_pc < (start_pc + 80)) + { + unsigned int word; + + if (read_memory_safe4 (cur_pc, &word)) + break; + cur_pc += 4; + + if ((word & 0xfc1f0000) == 0xb41e0000 /* stq reg,n($sp) */ + && (word & 0xffff0000) != 0xb7fe0000) /* reg != $zero */ + { + int reg = (word & 0x03e00000) >> 21; + + if (reg == T7_REGNUM || reg == T9_REGNUM || reg == RA_REGNUM) + { + pcreg = reg; + break; + } + } + else if ((word & 0xffe0ffff) == 0x6be08001) /* ret zero,reg,1 */ + { + pcreg = (word >> 16) & 0x1f; + break; + } + } + } + + if (has_frame_reg) + PROC_FRAME_REG (&temp_proc_desc) = GCC_FP_REGNUM; + else + PROC_FRAME_REG (&temp_proc_desc) = SP_REGNUM; + + PROC_FRAME_OFFSET (&temp_proc_desc) = frame_size; + PROC_REG_MASK (&temp_proc_desc) = reg_mask; + PROC_PC_REG (&temp_proc_desc) = (pcreg == -1) ? RA_REGNUM : pcreg; + PROC_LOCALOFF (&temp_proc_desc) = 0; /* XXX - bogus */ + + return &temp_proc_desc; +} + +static alpha_extra_func_info_t +find_proc_desc (CORE_ADDR pc, + struct frame_info *next_frame, + struct frame_saved_regs *saved_regs) +{ + CORE_ADDR startaddr; + + /* If heuristic_fence_post is nonzero, determine the procedure + start address by examining the instructions. + This allows us to find the start address of static functions which + have no symbolic information, as startaddr would have been set to + the preceding global function start address by the + find_pc_partial_function call above. */ + startaddr = heuristic_proc_start (pc); + + return heuristic_proc_desc (startaddr, pc, next_frame, saved_regs); +} + +static CORE_ADDR +alpha_frame_chain (struct frame_info *frame) +{ + alpha_extra_func_info_t proc_desc; + CORE_ADDR saved_pc = FRAME_SAVED_PC (frame); + + if (saved_pc == 0 || inside_entry_file (saved_pc)) + return 0; + + proc_desc = find_proc_desc (saved_pc, frame, NULL); + if (!proc_desc) + return 0; + + /* If no frame pointer and frame size is zero, we must be at end + of stack (or otherwise hosed). If we don't check frame size, + we loop forever if we see a zero size frame. */ + if (PROC_FRAME_REG (proc_desc) == SP_REGNUM + && PROC_FRAME_OFFSET (proc_desc) == 0) + return 0; + else + return read_next_frame_reg (frame, PROC_FRAME_REG (proc_desc)) + + PROC_FRAME_OFFSET (proc_desc); +} + +static void +init_extra_frame_info (struct frame_info *frame) +{ + struct frame_saved_regs temp_saved_regs; + alpha_extra_func_info_t proc_desc = + find_proc_desc (frame->pc, frame->next, &temp_saved_regs); + + frame->saved_regs = NULL; + frame->localoff = 0; + frame->pc_reg = RA_REGNUM; + frame->proc_desc = proc_desc; + + if (proc_desc) + { + /* Get the locals offset and the saved pc register from the + procedure descriptor, they are valid even if we are in the + middle of the prologue. */ + frame->localoff = PROC_LOCALOFF (proc_desc); + frame->pc_reg = PROC_PC_REG (proc_desc); + + /* Fixup frame-pointer - only needed for top frame */ + + /* This may not be quite right, if proc has a real frame register. + Get the value of the frame relative sp, procedure might have been + interrupted by a signal at it's very start. */ + if (frame->pc == PROC_LOW_ADDR (proc_desc)) + frame->frame = read_next_frame_reg (frame->next, SP_REGNUM); + else + frame->frame + = (read_next_frame_reg (frame->next, PROC_FRAME_REG (proc_desc)) + + PROC_FRAME_OFFSET (proc_desc)); + + frame->saved_regs + = (CORE_ADDR *) frame_obstack_alloc (SIZEOF_FRAME_SAVED_REGS); + memcpy + (frame->saved_regs, temp_saved_regs.regs, SIZEOF_FRAME_SAVED_REGS); + frame->saved_regs[PC_REGNUM] = frame->saved_regs[RA_REGNUM]; + } +} + +/* Create an arbitrary (i.e. address specified by user) or innermost frame. + Always returns a non-NULL value. */ + +static struct frame_info * +create_new_frame (CORE_ADDR addr, CORE_ADDR pc) +{ + struct frame_info *fi; + + fi = (struct frame_info *) + trace_alloc (sizeof (struct frame_info)); + + /* Arbitrary frame */ + fi->next = NULL; + fi->prev = NULL; + fi->frame = addr; + fi->pc = pc; + +#ifdef INIT_EXTRA_FRAME_INFO + INIT_EXTRA_FRAME_INFO (0, fi); +#endif + + return fi; +} + +static CORE_ADDR current_pc; + +static void +set_current_pc (void) +{ + current_pc = (CORE_ADDR) __builtin_return_address (0); +} + +static CORE_ADDR +read_pc (void) +{ + return current_pc; +} + +static struct frame_info * +get_current_frame (void) +{ + return create_new_frame (0, read_pc ()); +} + +/* Return the frame that called FI. + If FI is the original frame (it has no caller), return 0. */ + +static struct frame_info * +get_prev_frame (struct frame_info *next_frame) +{ + CORE_ADDR address = 0; + struct frame_info *prev; + int fromleaf = 0; + + /* If we have the prev one, return it */ + if (next_frame->prev) + return next_frame->prev; + + /* On some machines it is possible to call a function without + setting up a stack frame for it. On these machines, we + define this macro to take two args; a frameinfo pointer + identifying a frame and a variable to set or clear if it is + or isn't leafless. */ + + /* Two macros defined in tm.h specify the machine-dependent + actions to be performed here. + + First, get the frame's chain-pointer. If that is zero, the frame + is the outermost frame or a leaf called by the outermost frame. + This means that if start calls main without a frame, we'll return + 0 (which is fine anyway). + + Nope; there's a problem. This also returns when the current + routine is a leaf of main. This is unacceptable. We move + this to after the ffi test; I'd rather have backtraces from + start go curfluy than have an abort called from main not show + main. */ + + address = FRAME_CHAIN (next_frame); + if (!FRAME_CHAIN_VALID (address, next_frame)) + return 0; + address = FRAME_CHAIN_COMBINE (address, next_frame); + + if (address == 0) + return 0; + + prev = (struct frame_info *) trace_alloc (sizeof (struct frame_info)); + + prev->saved_regs = NULL; + if (next_frame) + next_frame->prev = prev; + + prev->next = next_frame; + prev->prev = (struct frame_info *) 0; + prev->frame = address; + + /* This change should not be needed, FIXME! We should + determine whether any targets *need* INIT_FRAME_PC to happen + after INIT_EXTRA_FRAME_INFO and come up with a simple way to + express what goes on here. + + INIT_EXTRA_FRAME_INFO is called from two places: create_new_frame + (where the PC is already set up) and here (where it isn't). + INIT_FRAME_PC is only called from here, always after + INIT_EXTRA_FRAME_INFO. + + The catch is the MIPS, where INIT_EXTRA_FRAME_INFO requires the PC + value (which hasn't been set yet). Some other machines appear to + require INIT_EXTRA_FRAME_INFO before they can do INIT_FRAME_PC. Phoo. + + We shouldn't need INIT_FRAME_PC_FIRST to add more complication to + an already overcomplicated part of GDB. gnu@cygnus.com, 15Sep92. + + Assuming that some machines need INIT_FRAME_PC after + INIT_EXTRA_FRAME_INFO, one possible scheme: + + SETUP_INNERMOST_FRAME() + Default version is just create_new_frame (read_fp ()), + read_pc ()). Machines with extra frame info would do that (or the + local equivalent) and then set the extra fields. + INIT_PREV_FRAME(fromleaf, prev) + Replace INIT_EXTRA_FRAME_INFO and INIT_FRAME_PC. This should + also return a flag saying whether to keep the new frame, or + whether to discard it, because on some machines (e.g. mips) it + is really awkward to have FRAME_CHAIN_VALID called *before* + INIT_EXTRA_FRAME_INFO (there is no good way to get information + deduced in FRAME_CHAIN_VALID into the extra fields of the new frame). + std_frame_pc(fromleaf, prev) + This is the default setting for INIT_PREV_FRAME. It just does what + the default INIT_FRAME_PC does. Some machines will call it from + INIT_PREV_FRAME (either at the beginning, the end, or in the middle). + Some machines won't use it. + kingdon@cygnus.com, 13Apr93, 31Jan94, 14Dec94. */ + +#ifdef INIT_FRAME_PC_FIRST + INIT_FRAME_PC_FIRST (fromleaf, prev); +#endif + +#ifdef INIT_EXTRA_FRAME_INFO + INIT_EXTRA_FRAME_INFO (fromleaf, prev); +#endif + + /* This entry is in the frame queue now, which is good since + FRAME_SAVED_PC may use that queue to figure out its value + (see tm-sparc.h). We want the pc saved in the inferior frame. */ + INIT_FRAME_PC (fromleaf, prev); + + /* If ->frame and ->pc are unchanged, we are in the process of getting + ourselves into an infinite backtrace. Some architectures check this + in FRAME_CHAIN or thereabouts, but it seems like there is no reason + this can't be an architecture-independent check. */ + if (next_frame != NULL) + { + if (prev->frame == next_frame->frame + && prev->pc == next_frame->pc) + { + next_frame->prev = NULL; + free (prev); + return NULL; + } + } + + return prev; +} + +#define SAVE(regno,disp) \ + "stq $" #regno ", " #disp "(%0)\n" + +int +__gnat_backtrace (void **array, + int size, + void *exclude_min, + void *exclude_max, + int skip_frames) +{ + struct frame_info* top; + struct frame_info* current; + int cnt; + + /* This function is not thread safe, protect it */ + (*Lock_Task) (); + asm volatile ( + SAVE (9,72) + SAVE (10,80) + SAVE (11,88) + SAVE (12,96) + SAVE (13,104) + SAVE (14,112) + SAVE (15,120) + SAVE (16,128) + SAVE (17,136) + SAVE (18,144) + SAVE (19,152) + SAVE (20,160) + SAVE (21,168) + SAVE (22,176) + SAVE (23,184) + SAVE (24,192) + SAVE (25,200) + SAVE (26,208) + SAVE (27,216) + SAVE (28,224) + SAVE (29,232) + SAVE (30,240) + : : "r" (&theRegisters)); + + trace_alloc_chain = NULL; + set_current_pc (); + + top = current = get_current_frame (); + cnt = 0; + + for (cnt = 0; cnt < skip_frames; cnt += 1) { + current = get_prev_frame (current); + } + + cnt = 0; + while (cnt < size) + { + if (STOP_FRAME) + break; + + if (current->pc < (CORE_ADDR) exclude_min + || current->pc > (CORE_ADDR) exclude_max) + array[cnt++] = (void*) (current->pc + PC_ADJUST); + + current = get_prev_frame (current); + } + + free_trace_alloc (); + (*Unlock_Task) (); + + return cnt; +} diff --git a/gcc/ada/tb-gcc.c b/gcc/ada/tb-gcc.c new file mode 100644 index 000000000..22432b4e6 --- /dev/null +++ b/gcc/ada/tb-gcc.c @@ -0,0 +1,126 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * T R A C E B A C K - G C C t a b l e s * + * * + * C Implementation File * + * * + * 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 2, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING. If not, write * + * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * + * Boston, MA 02110-1301, USA. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion does not however invalidate any other reasons why the executable * + * file might be covered by the GNU Public License. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* This is an implementation of the __gnat_backtrace routine using the + underlying GCC unwinding support associated with the exception handling + infrastructure. This will only work for ZCX based applications. */ + +#include + +/* The implementation boils down to a call to _Unwind_Backtrace with a + tailored callback and carried-on data structure to keep track of the + input parameters we got as well as of the basic processing state. */ + +/****************** + * trace_callback * + ******************/ + +#if !defined (__USING_SJLJ_EXCEPTIONS__) + +typedef struct { + void ** traceback; + int max_len; + void * exclude_min; + void * exclude_max; + int n_frames_to_skip; + int n_frames_skipped; + int n_entries_filled; +} uw_data_t; + +#if defined (__ia64__) && defined (__hpux__) +#include +#endif + +static _Unwind_Reason_Code +trace_callback (struct _Unwind_Context * uw_context, uw_data_t * uw_data) +{ + char * pc; + +#if defined (__ia64__) && defined (__hpux__) + /* Work around problem with _Unwind_GetIP on ia64 HP-UX. */ + uwx_get_reg ((struct uwx_env *) uw_context, UWX_REG_IP, (uint64_t *) &pc); +#else + pc = (char *) _Unwind_GetIP (uw_context); +#endif + + if (uw_data->n_frames_skipped < uw_data->n_frames_to_skip) + { + uw_data->n_frames_skipped ++; + return _URC_NO_REASON; + } + + if (uw_data->n_entries_filled >= uw_data->max_len) + return _URC_NORMAL_STOP; + + if (pc < (char *)uw_data->exclude_min || pc > (char *)uw_data->exclude_max) + uw_data->traceback [uw_data->n_entries_filled ++] = pc + PC_ADJUST; + + return _URC_NO_REASON; +} + +#endif + +/******************** + * __gnat_backtrace * + ********************/ + +int +__gnat_backtrace (void ** traceback __attribute__((unused)), + int max_len __attribute__((unused)), + void * exclude_min __attribute__((unused)), + void * exclude_max __attribute__((unused)), + int skip_frames __attribute__((unused))) +{ +#if defined (__USING_SJLJ_EXCEPTIONS__) + /* We have no unwind material (tables) at hand with sjlj eh, and no + way to retrieve complete and accurate call chain information from + the context stack we maintain. */ + return 0; +#else + uw_data_t uw_data; + /* State carried over during the whole unwinding process. */ + + uw_data.traceback = traceback; + uw_data.max_len = max_len; + uw_data.exclude_min = exclude_min; + uw_data.exclude_max = exclude_max; + + uw_data.n_frames_to_skip = skip_frames; + + uw_data.n_frames_skipped = 0; + uw_data.n_entries_filled = 0; + + _Unwind_Backtrace ((_Unwind_Trace_Fn)trace_callback, &uw_data); + + return uw_data.n_entries_filled; +#endif +} diff --git a/gcc/ada/tb-ivms.c b/gcc/ada/tb-ivms.c new file mode 100644 index 000000000..24afdb54e --- /dev/null +++ b/gcc/ada/tb-ivms.c @@ -0,0 +1,89 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * T R A C E B A C K - I t a n i u m / V M S * + * * + * C Implementation File * + * * + * Copyright (C) 2007, AdaCore * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 2, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING. If not, write * + * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * + * Boston, MA 02110-1301, USA. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion does not however invalidate any other reasons why the executable * + * file might be covered by the GNU Public License. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* Itanium Open/VMS implementation of backtrace. Use ICB (Invocation + Context Block) routines. */ +#include +#include + +/* Declare libicb routines. */ +extern INVO_CONTEXT_BLK *LIB$I64_CREATE_INVO_CONTEXT (void *(*)(size_t), + void (*)(void *), + int); +extern void LIB$I64_FREE_INVO_CONTEXT (INVO_CONTEXT_BLK *); +extern int LIB$I64_GET_CURR_INVO_CONTEXT(INVO_CONTEXT_BLK *); +extern int LIB$I64_GET_PREV_INVO_CONTEXT(INVO_CONTEXT_BLK *); + +/* Gcc internal headers poison malloc. So use xmalloc() when building the + compiler. */ +#ifdef IN_RTS +#define BT_MALLOC malloc +#else +#define BT_MALLOC xmalloc +#endif + +int +__gnat_backtrace (void **array, int size, + void *exclude_min, void *exclude_max, int skip_frames) +{ + INVO_CONTEXT_BLK *ctxt; + int res = 0; + int n = 0; + + /* Create the context. */ + ctxt = LIB$I64_CREATE_INVO_CONTEXT (BT_MALLOC, free, 0); + if (ctxt == NULL) + return 0; + + LIB$I64_GET_CURR_INVO_CONTEXT (ctxt); + + while (1) + { + void *pc = (void *)ctxt->libicb$ih_pc; + if (pc == (void *)0) + break; + if (ctxt->libicb$v_bottom_of_stack) + break; + if (n >= skip_frames && (pc < exclude_min || pc > exclude_max)) + { + array[res++] = (void *)(ctxt->libicb$ih_pc); + if (res == size) + break; + } + n++; + LIB$I64_GET_PREV_INVO_CONTEXT (ctxt); + } + + /* Free the context. */ + LIB$I64_FREE_INVO_CONTEXT (ctxt); + return res; +} diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb new file mode 100644 index 000000000..3edb41e6e --- /dev/null +++ b/gcc/ada/tbuild.adb @@ -0,0 +1,810 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T B U I L D -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Elists; use Elists; +with Lib; use Lib; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Sem_Aux; use Sem_Aux; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Urealp; use Urealp; + +package body Tbuild is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Add_Unique_Serial_Number; + -- Add a unique serialization to the string in the Name_Buffer. This + -- consists of a unit specific serial number, and b/s for body/spec. + + ------------------------------ + -- Add_Unique_Serial_Number -- + ------------------------------ + + Config_Serial_Number : Nat := 0; + -- Counter for use in config pragmas, see comment below + + procedure Add_Unique_Serial_Number is + begin + -- If we are analyzing configuration pragmas, Cunit (Main_Unit) will + -- not be set yet. This happens for example when analyzing static + -- string expressions in configuration pragmas. For this case, we + -- just maintain a local counter, defined above and we do not need + -- to add a b or s indication in this case. + + if No (Cunit (Current_Sem_Unit)) then + Config_Serial_Number := Config_Serial_Number + 1; + Add_Nat_To_Name_Buffer (Config_Serial_Number); + return; + + -- Normal case, within a unit + + else + declare + Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit)); + + begin + Add_Nat_To_Name_Buffer (Increment_Serial_Number); + + -- Add either b or s, depending on whether current unit is a spec + -- or a body. This is needed because we may generate the same name + -- in a spec and a body otherwise. + + Name_Len := Name_Len + 1; + + if Nkind (Unit_Node) = N_Package_Declaration + or else Nkind (Unit_Node) = N_Subprogram_Declaration + or else Nkind (Unit_Node) in N_Generic_Declaration + then + Name_Buffer (Name_Len) := 's'; + else + Name_Buffer (Name_Len) := 'b'; + end if; + end; + end if; + end Add_Unique_Serial_Number; + + ---------------- + -- Checks_Off -- + ---------------- + + function Checks_Off (N : Node_Id) return Node_Id is + begin + return + Make_Unchecked_Expression (Sloc (N), + Expression => N); + end Checks_Off; + + ---------------- + -- Convert_To -- + ---------------- + + function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is + Result : Node_Id; + + begin + if Present (Etype (Expr)) + and then (Etype (Expr)) = Typ + then + return Relocate_Node (Expr); + else + Result := + Make_Type_Conversion (Sloc (Expr), + Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)), + Expression => Relocate_Node (Expr)); + + Set_Etype (Result, Typ); + return Result; + end if; + end Convert_To; + + ------------------ + -- Discard_List -- + ------------------ + + procedure Discard_List (L : List_Id) is + pragma Warnings (Off, L); + begin + null; + end Discard_List; + + ------------------ + -- Discard_Node -- + ------------------ + + procedure Discard_Node (N : Node_Or_Entity_Id) is + pragma Warnings (Off, N); + begin + null; + end Discard_Node; + + ------------------------------------------- + -- Make_Byte_Aligned_Attribute_Reference -- + ------------------------------------------- + + function Make_Byte_Aligned_Attribute_Reference + (Sloc : Source_Ptr; + Prefix : Node_Id; + Attribute_Name : Name_Id) + return Node_Id + is + N : constant Node_Id := + Make_Attribute_Reference (Sloc, + Prefix => Prefix, + Attribute_Name => Attribute_Name); + + begin + pragma Assert (Attribute_Name = Name_Address + or else + Attribute_Name = Name_Unrestricted_Access); + Set_Must_Be_Byte_Aligned (N, True); + return N; + end Make_Byte_Aligned_Attribute_Reference; + + -------------------- + -- Make_DT_Access -- + -------------------- + + function Make_DT_Access + (Loc : Source_Ptr; + Rec : Node_Id; + Typ : Entity_Id) return Node_Id + is + Full_Type : Entity_Id := Typ; + + begin + if Is_Private_Type (Typ) then + Full_Type := Underlying_Type (Typ); + end if; + + return + Unchecked_Convert_To ( + New_Occurrence_Of + (Etype (Node (First_Elmt (Access_Disp_Table (Full_Type)))), Loc), + Make_Selected_Component (Loc, + Prefix => New_Copy (Rec), + Selector_Name => + New_Reference_To (First_Tag_Component (Full_Type), Loc))); + end Make_DT_Access; + + ------------------------ + -- Make_Float_Literal -- + ------------------------ + + function Make_Float_Literal + (Loc : Source_Ptr; + Radix : Uint; + Significand : Uint; + Exponent : Uint) return Node_Id + is + begin + if Radix = 2 and then abs Significand /= 1 then + return + Make_Float_Literal + (Loc, Uint_16, + Significand * Radix**(Exponent mod 4), + Exponent / 4); + + else + declare + N : constant Node_Id := New_Node (N_Real_Literal, Loc); + + begin + Set_Realval (N, + UR_From_Components + (Num => abs Significand, + Den => -Exponent, + Rbase => UI_To_Int (Radix), + Negative => Significand < 0)); + return N; + end; + end if; + end Make_Float_Literal; + + ------------------------------------- + -- Make_Implicit_Exception_Handler -- + ------------------------------------- + + function Make_Implicit_Exception_Handler + (Sloc : Source_Ptr; + Choice_Parameter : Node_Id := Empty; + Exception_Choices : List_Id; + Statements : List_Id) return Node_Id + is + Handler : Node_Id; + Loc : Source_Ptr; + + begin + -- Set the source location only when debugging the expanded code + + -- When debugging the source code directly, we do not want the compiler + -- to associate this implicit exception handler with any specific source + -- line, because it can potentially confuse the debugger. The most + -- damaging situation would arise when the debugger tries to insert a + -- breakpoint at a certain line. If the code of the associated implicit + -- exception handler is generated before the code of that line, then the + -- debugger will end up inserting the breakpoint inside the exception + -- handler, rather than the code the user intended to break on. As a + -- result, it is likely that the program will not hit the breakpoint + -- as expected. + + if Debug_Generated_Code then + Loc := Sloc; + else + Loc := No_Location; + end if; + + Handler := + Make_Exception_Handler + (Loc, Choice_Parameter, Exception_Choices, Statements); + Set_Local_Raise_Statements (Handler, No_Elist); + return Handler; + end Make_Implicit_Exception_Handler; + + -------------------------------- + -- Make_Implicit_If_Statement -- + -------------------------------- + + function Make_Implicit_If_Statement + (Node : Node_Id; + Condition : Node_Id; + Then_Statements : List_Id; + Elsif_Parts : List_Id := No_List; + Else_Statements : List_Id := No_List) return Node_Id + is + begin + Check_Restriction (No_Implicit_Conditionals, Node); + + return Make_If_Statement (Sloc (Node), + Condition, + Then_Statements, + Elsif_Parts, + Else_Statements); + end Make_Implicit_If_Statement; + + ------------------------------------- + -- Make_Implicit_Label_Declaration -- + ------------------------------------- + + function Make_Implicit_Label_Declaration + (Loc : Source_Ptr; + Defining_Identifier : Node_Id; + Label_Construct : Node_Id) return Node_Id + is + N : constant Node_Id := + Make_Implicit_Label_Declaration (Loc, Defining_Identifier); + begin + Set_Label_Construct (N, Label_Construct); + return N; + end Make_Implicit_Label_Declaration; + + ---------------------------------- + -- Make_Implicit_Loop_Statement -- + ---------------------------------- + + function Make_Implicit_Loop_Statement + (Node : Node_Id; + Statements : List_Id; + Identifier : Node_Id := Empty; + Iteration_Scheme : Node_Id := Empty; + Has_Created_Identifier : Boolean := False; + End_Label : Node_Id := Empty) return Node_Id + is + begin + Check_Restriction (No_Implicit_Loops, Node); + + if Present (Iteration_Scheme) + and then Present (Condition (Iteration_Scheme)) + then + Check_Restriction (No_Implicit_Conditionals, Node); + end if; + + return Make_Loop_Statement (Sloc (Node), + Identifier => Identifier, + Iteration_Scheme => Iteration_Scheme, + Statements => Statements, + Has_Created_Identifier => Has_Created_Identifier, + End_Label => End_Label); + end Make_Implicit_Loop_Statement; + + -------------------------- + -- Make_Integer_Literal -- + --------------------------- + + function Make_Integer_Literal + (Loc : Source_Ptr; + Intval : Int) return Node_Id + is + begin + return Make_Integer_Literal (Loc, UI_From_Int (Intval)); + end Make_Integer_Literal; + + -------------------------------- + -- Make_Linker_Section_Pragma -- + -------------------------------- + + function Make_Linker_Section_Pragma + (Ent : Entity_Id; + Loc : Source_Ptr; + Sec : String) return Node_Id + is + LS : Node_Id; + + begin + LS := + Make_Pragma + (Loc, + Name_Linker_Section, + New_List + (Make_Pragma_Argument_Association + (Sloc => Loc, + Expression => New_Occurrence_Of (Ent, Loc)), + Make_Pragma_Argument_Association + (Sloc => Loc, + Expression => + Make_String_Literal + (Sloc => Loc, + Strval => Sec)))); + + Set_Has_Gigi_Rep_Item (Ent); + return LS; + end Make_Linker_Section_Pragma; + + ----------------- + -- Make_Pragma -- + ----------------- + + function Make_Pragma + (Sloc : Source_Ptr; + Chars : Name_Id; + Pragma_Argument_Associations : List_Id := No_List; + Debug_Statement : Node_Id := Empty) return Node_Id + is + begin + return + Make_Pragma (Sloc, + Pragma_Argument_Associations => Pragma_Argument_Associations, + Debug_Statement => Debug_Statement, + Pragma_Identifier => Make_Identifier (Sloc, Chars)); + end Make_Pragma; + + --------------------------------- + -- Make_Raise_Constraint_Error -- + --------------------------------- + + function Make_Raise_Constraint_Error + (Sloc : Source_Ptr; + Condition : Node_Id := Empty; + Reason : RT_Exception_Code) return Node_Id + is + begin + pragma Assert (Reason in RT_CE_Exceptions); + return + Make_Raise_Constraint_Error (Sloc, + Condition => Condition, + Reason => + UI_From_Int (RT_Exception_Code'Pos (Reason))); + end Make_Raise_Constraint_Error; + + ------------------------------ + -- Make_Raise_Program_Error -- + ------------------------------ + + function Make_Raise_Program_Error + (Sloc : Source_Ptr; + Condition : Node_Id := Empty; + Reason : RT_Exception_Code) return Node_Id + is + begin + pragma Assert (Reason in RT_PE_Exceptions); + return + Make_Raise_Program_Error (Sloc, + Condition => Condition, + Reason => + UI_From_Int (RT_Exception_Code'Pos (Reason))); + end Make_Raise_Program_Error; + + ------------------------------ + -- Make_Raise_Storage_Error -- + ------------------------------ + + function Make_Raise_Storage_Error + (Sloc : Source_Ptr; + Condition : Node_Id := Empty; + Reason : RT_Exception_Code) return Node_Id + is + begin + pragma Assert (Reason in RT_SE_Exceptions); + return + Make_Raise_Storage_Error (Sloc, + Condition => Condition, + Reason => + UI_From_Int (RT_Exception_Code'Pos (Reason))); + end Make_Raise_Storage_Error; + + ------------------------- + -- Make_String_Literal -- + ------------------------- + + function Make_String_Literal + (Sloc : Source_Ptr; + Strval : String) return Node_Id + is + begin + Start_String; + Store_String_Chars (Strval); + return + Make_String_Literal (Sloc, + Strval => End_String); + end Make_String_Literal; + + -------------------- + -- Make_Temporary -- + -------------------- + + function Make_Temporary + (Loc : Source_Ptr; + Id : Character; + Related_Node : Node_Id := Empty) return Entity_Id + is + Temp : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name (Id)); + begin + Set_Related_Expression (Temp, Related_Node); + return Temp; + end Make_Temporary; + + --------------------------- + -- Make_Unsuppress_Block -- + --------------------------- + + -- Generates the following expansion: + + -- declare + -- pragma Suppress (); + -- begin + -- + -- end; + + function Make_Unsuppress_Block + (Loc : Source_Ptr; + Check : Name_Id; + Stmts : List_Id) return Node_Id + is + begin + return + Make_Block_Statement (Loc, + Declarations => New_List ( + Make_Pragma (Loc, + Chars => Name_Suppress, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Check))))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + end Make_Unsuppress_Block; + + -------------------------- + -- New_Constraint_Error -- + -------------------------- + + function New_Constraint_Error (Loc : Source_Ptr) return Node_Id is + Ident_Node : Node_Id; + Raise_Node : Node_Id; + + begin + Ident_Node := New_Node (N_Identifier, Loc); + Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error))); + Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error)); + Raise_Node := New_Node (N_Raise_Statement, Loc); + Set_Name (Raise_Node, Ident_Node); + return Raise_Node; + end New_Constraint_Error; + + ----------------------- + -- New_External_Name -- + ----------------------- + + function New_External_Name + (Related_Id : Name_Id; + Suffix : Character := ' '; + Suffix_Index : Int := 0; + Prefix : Character := ' ') return Name_Id + is + begin + Get_Name_String (Related_Id); + + if Prefix /= ' ' then + pragma Assert (Is_OK_Internal_Letter (Prefix) or else Prefix = '_'); + + for J in reverse 1 .. Name_Len loop + Name_Buffer (J + 1) := Name_Buffer (J); + end loop; + + Name_Len := Name_Len + 1; + Name_Buffer (1) := Prefix; + end if; + + if Suffix /= ' ' then + pragma Assert (Is_OK_Internal_Letter (Suffix)); + Add_Char_To_Name_Buffer (Suffix); + end if; + + if Suffix_Index /= 0 then + if Suffix_Index < 0 then + Add_Unique_Serial_Number; + else + Add_Nat_To_Name_Buffer (Suffix_Index); + end if; + end if; + + return Name_Find; + end New_External_Name; + + function New_External_Name + (Related_Id : Name_Id; + Suffix : String; + Suffix_Index : Int := 0; + Prefix : Character := ' ') return Name_Id + is + begin + Get_Name_String (Related_Id); + + if Prefix /= ' ' then + pragma Assert (Is_OK_Internal_Letter (Prefix)); + + for J in reverse 1 .. Name_Len loop + Name_Buffer (J + 1) := Name_Buffer (J); + end loop; + + Name_Len := Name_Len + 1; + Name_Buffer (1) := Prefix; + end if; + + if Suffix /= "" then + Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix; + Name_Len := Name_Len + Suffix'Length; + end if; + + if Suffix_Index /= 0 then + if Suffix_Index < 0 then + Add_Unique_Serial_Number; + else + Add_Nat_To_Name_Buffer (Suffix_Index); + end if; + end if; + + return Name_Find; + end New_External_Name; + + function New_External_Name + (Suffix : Character; + Suffix_Index : Nat) return Name_Id + is + begin + Name_Buffer (1) := Suffix; + Name_Len := 1; + Add_Nat_To_Name_Buffer (Suffix_Index); + return Name_Find; + end New_External_Name; + + ----------------------- + -- New_Internal_Name -- + ----------------------- + + function New_Internal_Name (Id_Char : Character) return Name_Id is + begin + pragma Assert (Is_OK_Internal_Letter (Id_Char)); + Name_Buffer (1) := Id_Char; + Name_Len := 1; + Add_Unique_Serial_Number; + return Name_Enter; + end New_Internal_Name; + + ----------------------- + -- New_Occurrence_Of -- + ----------------------- + + function New_Occurrence_Of + (Def_Id : Entity_Id; + Loc : Source_Ptr) return Node_Id + is + Occurrence : Node_Id; + + begin + Occurrence := New_Node (N_Identifier, Loc); + Set_Chars (Occurrence, Chars (Def_Id)); + Set_Entity (Occurrence, Def_Id); + + if Is_Type (Def_Id) then + Set_Etype (Occurrence, Def_Id); + else + Set_Etype (Occurrence, Etype (Def_Id)); + end if; + + return Occurrence; + end New_Occurrence_Of; + + ----------------- + -- New_Op_Node -- + ----------------- + + function New_Op_Node + (New_Node_Kind : Node_Kind; + New_Sloc : Source_Ptr) return Node_Id + is + type Name_Of_Type is array (N_Op) of Name_Id; + Name_Of : constant Name_Of_Type := Name_Of_Type'( + N_Op_And => Name_Op_And, + N_Op_Or => Name_Op_Or, + N_Op_Xor => Name_Op_Xor, + N_Op_Eq => Name_Op_Eq, + N_Op_Ne => Name_Op_Ne, + N_Op_Lt => Name_Op_Lt, + N_Op_Le => Name_Op_Le, + N_Op_Gt => Name_Op_Gt, + N_Op_Ge => Name_Op_Ge, + N_Op_Add => Name_Op_Add, + N_Op_Subtract => Name_Op_Subtract, + N_Op_Concat => Name_Op_Concat, + N_Op_Multiply => Name_Op_Multiply, + N_Op_Divide => Name_Op_Divide, + N_Op_Mod => Name_Op_Mod, + N_Op_Rem => Name_Op_Rem, + N_Op_Expon => Name_Op_Expon, + N_Op_Plus => Name_Op_Add, + N_Op_Minus => Name_Op_Subtract, + N_Op_Abs => Name_Op_Abs, + N_Op_Not => Name_Op_Not, + + -- We don't really need these shift operators, since they never + -- appear as operators in the source, but the path of least + -- resistance is to put them in (the aggregate must be complete). + + N_Op_Rotate_Left => Name_Rotate_Left, + N_Op_Rotate_Right => Name_Rotate_Right, + N_Op_Shift_Left => Name_Shift_Left, + N_Op_Shift_Right => Name_Shift_Right, + N_Op_Shift_Right_Arithmetic => Name_Shift_Right_Arithmetic); + + Nod : constant Node_Id := New_Node (New_Node_Kind, New_Sloc); + + begin + if New_Node_Kind in Name_Of'Range then + Set_Chars (Nod, Name_Of (New_Node_Kind)); + end if; + + return Nod; + end New_Op_Node; + + ---------------------- + -- New_Reference_To -- + ---------------------- + + function New_Reference_To + (Def_Id : Entity_Id; + Loc : Source_Ptr) return Node_Id + is + Occurrence : Node_Id; + begin + Occurrence := New_Node (N_Identifier, Loc); + Set_Chars (Occurrence, Chars (Def_Id)); + Set_Entity (Occurrence, Def_Id); + return Occurrence; + end New_Reference_To; + + ----------------------- + -- New_Suffixed_Name -- + ----------------------- + + function New_Suffixed_Name + (Related_Id : Name_Id; + Suffix : String) return Name_Id + is + begin + Get_Name_String (Related_Id); + Add_Char_To_Name_Buffer ('_'); + Add_Str_To_Name_Buffer (Suffix); + return Name_Find; + end New_Suffixed_Name; + + ------------------- + -- OK_Convert_To -- + ------------------- + + function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is + Result : Node_Id; + begin + Result := + Make_Type_Conversion (Sloc (Expr), + Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)), + Expression => Relocate_Node (Expr)); + Set_Conversion_OK (Result, True); + Set_Etype (Result, Typ); + return Result; + end OK_Convert_To; + + -------------------------- + -- Unchecked_Convert_To -- + -------------------------- + + function Unchecked_Convert_To + (Typ : Entity_Id; + Expr : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Expr); + Result : Node_Id; + + begin + -- If the expression is already of the correct type, then nothing + -- to do, except for relocating the node in case this is required. + + if Present (Etype (Expr)) + and then (Base_Type (Etype (Expr)) = Typ + or else Etype (Expr) = Typ) + then + return Relocate_Node (Expr); + + -- Cases where the inner expression is itself an unchecked conversion + -- to the same type, and we can thus eliminate the outer conversion. + + elsif Nkind (Expr) = N_Unchecked_Type_Conversion + and then Entity (Subtype_Mark (Expr)) = Typ + then + Result := Relocate_Node (Expr); + + elsif Nkind (Expr) = N_Null + and then Is_Access_Type (Typ) + then + -- No need for a conversion + + Result := Relocate_Node (Expr); + + -- All other cases + + else + Result := + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (Expr)); + end if; + + Set_Etype (Result, Typ); + return Result; + end Unchecked_Convert_To; + +end Tbuild; diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads new file mode 100644 index 000000000..9ba042705 --- /dev/null +++ b/gcc/ada/tbuild.ads @@ -0,0 +1,328 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T B U I L D -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains various utility procedures to assist in building +-- specific types of tree nodes. + +with Namet; use Namet; +with Sinfo; use Sinfo; +with Types; use Types; +with Uintp; use Uintp; + +package Tbuild is + + function Checks_Off (N : Node_Id) return Node_Id; + pragma Inline (Checks_Off); + -- Returns an N_Unchecked_Expression node whose expression is the given + -- argument. The results is a subexpression identical to the argument, + -- except that it will be analyzed and resolved with checks off. + + function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id; + -- Returns an expression that represents the result of a checked convert + -- of expression Exp to type T. If the base type of Exp is T, then no + -- conversion is required, and Exp is returned unchanged. Otherwise an + -- N_Type_Conversion node is constructed to convert the expression. + -- If an N_Type_Conversion node is required, Relocate_Node is used on + -- Exp. This means that it is safe to replace a node by a Convert_To + -- of itself to some other type. + + procedure Discard_Node (N : Node_Or_Entity_Id); + pragma Inline (Discard_Node); + -- This is a dummy procedure that simply returns and does nothing. It is + -- used when a function returning a Node_Id value is called for its side + -- effect (e.g. a call to Make to construct a node) but the Node_Id value + -- is not required. + + procedure Discard_List (L : List_Id); + pragma Inline (Discard_List); + -- This is a dummy procedure that simply returns and does nothing. It is + -- used when a function returning a Node_Id value is called for its side + -- effect (e.g. a call to the parser to parse a list of compilation + -- units), but the List_Id value is not required. + + function Make_Byte_Aligned_Attribute_Reference + (Sloc : Source_Ptr; + Prefix : Node_Id; + Attribute_Name : Name_Id) return Node_Id; + pragma Inline (Make_Byte_Aligned_Attribute_Reference); + -- Like the standard Make_Attribute_Reference but the special flag + -- Must_Be_Byte_Aligned is set in the attribute reference node. The + -- Attribute_Name must be Name_Address or Name_Unrestricted_Access. + + function Make_DT_Access + (Loc : Source_Ptr; Rec : Node_Id; Typ : Entity_Id) return Node_Id; + -- Create an access to the Dispatch Table by using the Tag field of a + -- tagged record : Acc_Dt (Rec.tag).all + + function Make_Float_Literal + (Loc : Source_Ptr; + Radix : Uint; + Significand : Uint; + Exponent : Uint) return Node_Id; + -- Create a real literal for the floating point expression value + -- Significand * Radix ** Exponent. Radix must be greater than 1. + + function Make_Implicit_Exception_Handler + (Sloc : Source_Ptr; + Choice_Parameter : Node_Id := Empty; + Exception_Choices : List_Id; + Statements : List_Id) return Node_Id; + pragma Inline (Make_Implicit_Exception_Handler); + -- This is just like Make_Exception_Handler, except that it also sets the + -- Local_Raise_Statements field to No_Elist, ensuring that it is properly + -- initialized. This should always be used when creating implicit exception + -- handlers during expansion (i.e. handlers that do not correspond to user + -- source program exception handlers). + + function Make_Implicit_If_Statement + (Node : Node_Id; + Condition : Node_Id; + Then_Statements : List_Id; + Elsif_Parts : List_Id := No_List; + Else_Statements : List_Id := No_List) return Node_Id; + pragma Inline (Make_Implicit_If_Statement); + -- This function makes an N_If_Statement node whose fields are filled + -- in with the indicated values (see Sinfo), and whose Sloc field is + -- is set to Sloc (Node). The effect is identical to calling function + -- Nmake.Make_If_Statement except that there is a check for restriction + -- No_Implicit_Conditionals, and if this restriction is being violated, + -- an error message is posted on Node. + + function Make_Implicit_Label_Declaration + (Loc : Source_Ptr; + Defining_Identifier : Node_Id; + Label_Construct : Node_Id) return Node_Id; + -- Used to construct an implicit label declaration node, including setting + -- the proper Label_Construct field (since Label_Construct is a semantic + -- field, the normal call to Make_Implicit_Label_Declaration does not + -- set this field). + + function Make_Implicit_Loop_Statement + (Node : Node_Id; + Statements : List_Id; + Identifier : Node_Id := Empty; + Iteration_Scheme : Node_Id := Empty; + Has_Created_Identifier : Boolean := False; + End_Label : Node_Id := Empty) return Node_Id; + -- This function makes an N_Loop_Statement node whose fields are filled + -- in with the indicated values (see Sinfo), and whose Sloc field is + -- is set to Sloc (Node). The effect is identical to calling function + -- Nmake.Make_Loop_Statement except that there is a check for restrictions + -- No_Implicit_Loops and No_Implicit_Conditionals (the first applying in + -- all cases, and the second only for while loops), and if one of these + -- restrictions is being violated, an error message is posted on Node. + + function Make_Integer_Literal + (Loc : Source_Ptr; + Intval : Int) return Node_Id; + pragma Inline (Make_Integer_Literal); + -- A convenient form of Make_Integer_Literal taking Int instead of Uint + + function Make_Linker_Section_Pragma + (Ent : Entity_Id; + Loc : Source_Ptr; + Sec : String) return Node_Id; + -- Construct a Linker_Section pragma for entity Ent, using string Sec as + -- the section name. Loc is the Sloc value to use in building the pragma. + + function Make_Pragma + (Sloc : Source_Ptr; + Chars : Name_Id; + Pragma_Argument_Associations : List_Id := No_List; + Debug_Statement : Node_Id := Empty) return Node_Id; + -- A convenient form of Make_Pragma not requiring a Pragma_Identifier + -- argument (this argument is built from the value given for Chars). + + function Make_Raise_Constraint_Error + (Sloc : Source_Ptr; + Condition : Node_Id := Empty; + Reason : RT_Exception_Code) return Node_Id; + pragma Inline (Make_Raise_Constraint_Error); + -- A convenient form of Make_Raise_Constraint_Error where the Reason + -- is given simply as an enumeration value, rather than a Uint code. + + function Make_Raise_Program_Error + (Sloc : Source_Ptr; + Condition : Node_Id := Empty; + Reason : RT_Exception_Code) return Node_Id; + pragma Inline (Make_Raise_Program_Error); + -- A convenient form of Make_Raise_Program_Error where the Reason + -- is given simply as an enumeration value, rather than a Uint code. + + function Make_Raise_Storage_Error + (Sloc : Source_Ptr; + Condition : Node_Id := Empty; + Reason : RT_Exception_Code) return Node_Id; + pragma Inline (Make_Raise_Storage_Error); + -- A convenient form of Make_Raise_Storage_Error where the Reason is given + -- simply as an enumeration value, rather than a Uint code. + + function Make_String_Literal + (Sloc : Source_Ptr; + Strval : String) return Node_Id; + -- A convenient form of Make_String_Literal, where the string value is + -- given as a normal string instead of a String_Id value. + + function Make_Temporary + (Loc : Source_Ptr; + Id : Character; + Related_Node : Node_Id := Empty) return Entity_Id; + -- This function should be used for all cases where a defining identifier + -- is to be built with a name to be obtained by New_Internal_Name (here Id + -- is the character passed as the argument to New_Internal_Name). Loc is + -- the location for the Sloc value of the resulting Entity. Note that this + -- can be used for all kinds of temporary defining identifiers used in + -- expansion (objects, subtypes, functions etc). + -- + -- Related_Node is used when the defining identifier is for an object that + -- captures the value of an expression (e.g. an aggregate). It should be + -- set whenever possible to point to the expression that is being captured. + -- This is provided to get better error messages, e.g. from CodePeer. + -- + -- Make_Temp_Id would probably be a better name for this function??? + + function Make_Unsuppress_Block + (Loc : Source_Ptr; + Check : Name_Id; + Stmts : List_Id) return Node_Id; + -- Build a block with a pragma Suppress on 'Check'. Stmts is the statements + -- list that needs protection against the check + + function New_Constraint_Error (Loc : Source_Ptr) return Node_Id; + -- This function builds a tree corresponding to the Ada statement + -- "raise Constraint_Error" and returns the root of this tree, + -- the N_Raise_Statement node. + + function New_Op_Node + (New_Node_Kind : Node_Kind; + New_Sloc : Source_Ptr) return Node_Id; + -- Create node using New_Node and, if its kind is in N_Op, set its Chars + -- field accordingly. + + function New_External_Name + (Related_Id : Name_Id; + Suffix : Character := ' '; + Suffix_Index : Int := 0; + Prefix : Character := ' ') return Name_Id; + function New_External_Name + (Related_Id : Name_Id; + Suffix : String; + Suffix_Index : Int := 0; + Prefix : Character := ' ') return Name_Id; + -- Builds a new entry in the names table of the form: + -- + -- [Prefix &] Related_Id [& Suffix] [& Suffix_Index] + -- + -- Prefix is prepended only if Prefix is non-blank (in which case it + -- must be an upper case letter other than O,Q,U,W (which are used for + -- identifier encoding, see Namet), or an underscore, and T is reserved for + -- use by implicit types, and X is reserved for use by debug type encoding + -- (see package Exp_Dbug). Note: the reason that Prefix is last is that it + -- is almost always omitted. The notable case of Prefix being non-null is + -- when it is 'T' for an implicit type. + + -- Suffix_Index'Image is appended only if the value of Suffix_Index is + -- positive, or if Suffix_Index is negative 1, then a unique serialized + -- suffix is added. If Suffix_Index is zero, then no index is appended. + + -- Suffix is also a single upper case letter other than O,Q,U,W,X and is a + -- required parameter (T is permitted). The constructed name is stored + -- using Name_Find so that it can be located using a subsequent Name_Find + -- operation (i.e. it is properly hashed into the names table). The upper + -- case letter given as the Suffix argument ensures that the name does + -- not clash with any Ada identifier name. These generated names are + -- permitted, but not required, to be made public by setting the flag + -- Is_Public in the associated entity. + + function New_External_Name + (Suffix : Character; + Suffix_Index : Nat) return Name_Id; + -- Builds a new entry in the names table of the form + -- Suffix & Suffix_Index'Image + -- where Suffix is a single upper case letter other than O,Q,U,W,X and is + -- a required parameter (T is permitted). The constructed name is stored + -- using Name_Find so that it can be located using a subsequent Name_Find + -- operation (i.e. it is properly hashed into the names table). The upper + -- case letter given as the Suffix argument ensures that the name does + -- not clash with any Ada identifier name. These generated names are + -- permitted, but not required, to be made public by setting the flag + -- Is_Public in the associated entity. + + function New_Internal_Name (Id_Char : Character) return Name_Id; + -- Id_Char is an upper case letter other than O,Q,U,W (which are reserved + -- for identifier encoding (see Namet package for details) and X which is + -- used for debug encoding (see Exp_Dbug). The letter T is permitted, but + -- is reserved by convention for the case of internally generated types. + -- The result of the call is a new generated unique name of the form XyyyU + -- where X is Id_Char, yyy is a unique serial number, and U is either a + -- lower case s or b indicating if the current unit is a spec or a body. + -- + -- The name is entered into the names table using Name_Enter rather than + -- Name_Find, because there can never be a need to locate the entry using + -- the Name_Find procedure later on. Names created by New_Internal_Name + -- are guaranteed to be consistent from one compilation to another (i.e. + -- if the identical unit is compiled with a semantically consistent set + -- of sources, the numbers will be consistent. This means that it is fine + -- to use these as public symbols. + -- + -- Note: Nearly all uses of this function are via calls to Make_Temporary, + -- but there are just a few cases where it is called directly. + + function New_Occurrence_Of + (Def_Id : Entity_Id; + Loc : Source_Ptr) return Node_Id; + -- New_Occurrence_Of creates an N_Identifier node which is an occurrence + -- of the defining identifier which is passed as its argument. The Entity + -- and Etype of the result are set from the given defining identifier as + -- follows: Entity is simply a copy of Def_Id. Etype is a copy of Def_Id + -- for types, and a copy of the Etype of Def_Id for other entities. + + function New_Reference_To + (Def_Id : Entity_Id; + Loc : Source_Ptr) return Node_Id; + -- This is like New_Occurrence_Of, but it does not set the Etype field. It + -- is used from the expander, where Etype fields are generally not set, + -- since they are set when the expanded tree is reanalyzed. + + function New_Suffixed_Name + (Related_Id : Name_Id; + Suffix : String) return Name_Id; + -- This function is used to create special suffixed names used by the + -- debugger. Suffix is a string of upper case letters, used to construct + -- the required name. For instance, the special type used to record the + -- fixed-point small is called typ_SMALL where typ is the name of the + -- fixed-point type (as passed in Related_Id), and Suffix is "SMALL". + + function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id; + -- Like Convert_To, except that a conversion node is always generated, and + -- the Conversion_OK flag is set on this conversion node. + + function Unchecked_Convert_To + (Typ : Entity_Id; + Expr : Node_Id) return Node_Id; + -- Like Convert_To, but if a conversion is actually needed, constructs an + -- N_Unchecked_Type_Conversion node to do the required conversion. + +end Tbuild; diff --git a/gcc/ada/tempdir.adb b/gcc/ada/tempdir.adb new file mode 100644 index 000000000..b44330750 --- /dev/null +++ b/gcc/ada/tempdir.adb @@ -0,0 +1,146 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T E M P D I R -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.Directory_Operations; use GNAT.Directory_Operations; + +with Hostparm; use Hostparm; +with Opt; use Opt; +with Output; use Output; + +package body Tempdir is + + Tmpdir_Needs_To_Be_Displayed : Boolean := True; + + Tmpdir : constant String := "TMPDIR"; + Gnutmpdir : constant String := "GNUTMPDIR"; + No_Dir : aliased String := ""; + Temp_Dir : String_Access := No_Dir'Access; + + ---------------------- + -- Create_Temp_File -- + ---------------------- + + procedure Create_Temp_File + (FD : out File_Descriptor; + Name : out Path_Name_Type) + is + File_Name : String_Access; + Current_Dir : constant String := Get_Current_Dir; + + function Directory return String; + -- Returns Temp_Dir.all if not empty, else return current directory + + --------------- + -- Directory -- + --------------- + + function Directory return String is + begin + if Temp_Dir'Length /= 0 then + return Temp_Dir.all; + + else + return Current_Dir; + end if; + end Directory; + + -- Start of processing Tempdir + + begin + if Temp_Dir'Length /= 0 then + + -- In verbose mode, display once the value of TMPDIR, so that + -- if temp files cannot be created, it is easier to understand + -- where temp files are supposed to be created. + + if Verbose_Mode and then Tmpdir_Needs_To_Be_Displayed then + Write_Str ("TMPDIR = """); + Write_Str (Temp_Dir.all); + Write_Line (""""); + Tmpdir_Needs_To_Be_Displayed := False; + end if; + + -- Change directory to TMPDIR before creating the temp file, + -- then change back immediately to the previous directory. + + Change_Dir (Temp_Dir.all); + Create_Temp_File (FD, File_Name); + Change_Dir (Current_Dir); + + else + Create_Temp_File (FD, File_Name); + end if; + + if FD = Invalid_FD then + Write_Line ("could not create temporary file in " & Directory); + Name := No_Path; + + else + declare + Path_Name : constant String := + Normalize_Pathname + (Directory & Directory_Separator & File_Name.all); + + begin + Name_Len := Path_Name'Length; + Name_Buffer (1 .. Name_Len) := Path_Name; + Name := Name_Find; + Free (File_Name); + end; + end if; + end Create_Temp_File; + +-- Start of elaboration for package Tempdir + +begin + declare + Dir : String_Access; + + begin + -- On VMS, if GNUTMPDIR is defined, use it + + if OpenVMS then + Dir := Getenv (Gnutmpdir); + + -- Otherwise, if GNUTMPDIR is not defined, try TMPDIR + + if Dir'Length = 0 then + Dir := Getenv (Tmpdir); + end if; + + else + Dir := Getenv (Tmpdir); + end if; + + if Dir'Length > 0 and then + Is_Absolute_Path (Dir.all) and then + Is_Directory (Dir.all) + then + Temp_Dir := new String'(Normalize_Pathname (Dir.all)); + end if; + + Free (Dir); + end; +end Tempdir; diff --git a/gcc/ada/tempdir.ads b/gcc/ada/tempdir.ads new file mode 100644 index 000000000..7ab1b5aff --- /dev/null +++ b/gcc/ada/tempdir.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T E M P D I R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2003-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 by gnatmake and by the Project Manager to create +-- temporary files. If environment variable TMPDIR is defined and +-- designates an absolute path, temporary files are create in this directory. +-- Otherwise, temporary files are created in the current working directory. + +with Namet; use Namet; + +with GNAT.OS_Lib; use GNAT.OS_Lib; + +package Tempdir is + + procedure Create_Temp_File + (FD : out File_Descriptor; + Name : out Path_Name_Type); + -- Create a temporary text file and return its file descriptor and + -- its path name as a Name_Id. If environment variable TMPDIR is defined + -- and its value is an absolute path, the temp file is created in the + -- directory designated by TMPDIR, otherwise, it is created in the current + -- directory. If temporary file cannot be created, FD gets the value + -- Invalid_FD and Name gets the value No_Name. + +end Tempdir; diff --git a/gcc/ada/text_io.ads b/gcc/ada/text_io.ads new file mode 100644 index 000000000..9c213e9a4 --- /dev/null +++ b/gcc/ada/text_io.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2005; +-- Explicit setting of Ada 2005 mode is required here, since we want to with a +-- child unit (not possible in Ada 83 mode), and Text_IO is not considered to +-- be an internal unit that is automatically compiled in Ada 2005 mode (since +-- a user is allowed to redeclare Text_IO). + +with Ada.Text_IO; + +package Text_IO renames Ada.Text_IO; diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c new file mode 100644 index 000000000..d1f74b4f4 --- /dev/null +++ b/gcc/ada/tracebak.c @@ -0,0 +1,529 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * T R A C E B A C K * + * * + * C Implementation File * + * * + * 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 2, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING. If not, write * + * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * + * Boston, MA 02110-1301, USA. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion does not however invalidate any other reasons why the executable * + * file might be covered by the GNU Public License. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* This file contains low level support for stack unwinding using GCC intrinsic + functions. + It has been tested on the following configurations: + PowerPC/AiX + PowerPC/Darwin + PowerPC/VxWorks + SPARC/Solaris + i386/GNU/Linux + i386/Solaris + i386/NT + i386/OS2 + i386/LynxOS + Alpha/VxWorks + Alpha/VMS +*/ + +#ifdef __alpha_vxworks +#include "vxWorks.h" +#endif + +#ifdef IN_RTS +#define POSIX +#include "tconfig.h" +#include "tsystem.h" +#else +#include "config.h" +#include "system.h" +/* We don't want fancy_abort here. */ +#undef abort +#endif + +extern int __gnat_backtrace (void **, int, void *, void *, int); + +/* The point is to provide an implementation of the __gnat_backtrace function + above, called by the default implementation of the System.Traceback package. + + We first have a series of target specific implementations, each included + from a separate C file for readability purposes. + + Then come two flavors of a generic implementation: one relying on static + assumptions about the frame layout, and the other one using the GCC EH + infrastructure. The former uses a whole set of macros and structures which + may be tailored on a per target basis, and is activated as soon as + USE_GENERIC_UNWINDER is defined. The latter uses a small subset of the + macro definitions and is activated when USE_GCC_UNWINDER is defined. It is + only available post GCC 3.3. + + Finally, there is a default dummy implementation, necessary to make the + linker happy on platforms where the feature is not supported, but where the + function is still referenced by the default System.Traceback. */ + +#define Lock_Task system__soft_links__lock_task +extern void (*Lock_Task) (void); + +#define Unlock_Task system__soft_links__unlock_task +extern void (*Unlock_Task) (void); + +/*-------------------------------------* + *-- Target specific implementations --* + *-------------------------------------*/ + +#if defined (__alpha_vxworks) + +#include "tb-alvxw.c" + +#elif defined (__ALPHA) && defined (__VMS__) + +#include "tb-alvms.c" + +#elif defined (__ia64__) && defined (__VMS__) + +#include "tb-ivms.c" + +#else + +/* No target specific implementation. */ + +/*----------------------------------------------------------------* + *-- Target specific definitions for the generic implementation --* + *----------------------------------------------------------------*/ + +/* The stack layout is specified by the target ABI. The "generic" scheme is + based on the following assumption: + + The stack layout from some frame pointer is such that the information + required to compute the backtrace is available at static offsets. + + For a given frame, the information we are interested in is the saved return + address (somewhere after the call instruction in the caller) and a pointer + to the caller's frame. The former is the base of the call chain information + we store in the tracebacks array. The latter allows us to loop over the + successive frames in the chain. + + To initiate the process, we retrieve an initial frame address using the + appropriate GCC builtin (__builtin_frame_address). + + This scheme is unfortunately not applicable on every target because the + stack layout is not necessarily regular (static) enough. On targets where + this scheme applies, the implementation relies on the following items: + + o struct layout, describing the expected stack data layout relevant to the + information we are interested in, + + o FRAME_OFFSET, the offset, from a given frame address or frame pointer + value, at which this layout will be found, + + o FRAME_LEVEL, controls how many frames up we get at to start with, + from the initial frame pointer we compute by way of the GCC builtin, + + 0 is most often the appropriate value. 1 may be necessary on targets + where return addresses are saved by a function in it's caller's frame + (e.g. PPC). + + o PC_ADJUST, to account for the difference between a call point (address + of a call instruction), which is what we want in the output array, and + the associated return address, which is what we retrieve from the stack. + + o STOP_FRAME, to decide whether we reached the top of the call chain, and + thus if the process shall stop. + + : + : stack + | +----------------+ + | +-------->| : | + | | | (FRAME_OFFSET) | + | | | : | (PC_ADJUST) + | | layout:| return_address ----------------+ + | | | .... | | + +--------------- next_frame | | + | | .... | | + | | | | + | +----------------+ | +-----+ + | | : |<- Base fp | | : | + | | (FRAME_OFFSET) | (FRAME_LEVEL) | | : | + | | : | +---> | [1] + | layout:| return_address --------------------> | [0] + | | ... | (PC_ADJUST) +-----+ + +---------- next_frame | traceback[] + | ... | + | | + +----------------+ + + o BASE_SKIP, + + Since we inherently deal with return addresses, there is an implicit shift + by at least one for the initial point we are able to observe in the chain. + + On some targets (e.g. sparc-solaris), the first return address we can + easily get without special code is even our caller's return address, so + there is a initial shift of two. + + BASE_SKIP represents this initial shift, which is the minimal "skip_frames" + value we support. We could add special code for the skip_frames < BASE_SKIP + cases. This is not done currently because there is virtually no situation + in which this would be useful. + + Finally, to account for some ABI specificities, a target may (but does + not have to) define: + + o FORCE_CALL, to force a call to a dummy function at the very beginning + of the computation. See the PPC AIX target for an example where this + is useful. + + o FETCH_UP_FRAME, to force an invocation of __builtin_frame_address with a + positive argument right after a possibly forced call even if FRAME_LEVEL + is 0. See the SPARC Solaris case for an example where this is useful. + + */ + +/*--------------------------- Darwin 8 or newer ----------------------------*/ +#if defined (__APPLE__) \ + && defined (__ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__) \ + && __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ >= 1040 + +#define USE_GCC_UNWINDER + +#if defined (__i386__) || defined (__x86_64__) +#define PC_ADJUST -2 +#elif defined (__ppc__) || defined (__ppc64__) +#define PC_ADJUST -4 +#else +#error Unhandled darwin architecture. +#endif + +/*------------------------ PPC AIX/Older Darwin -------------------------*/ +#elif ((defined (_POWER) && defined (_AIX)) \ + || (defined (__APPLE__) && defined (__ppc__))) + +#define USE_GENERIC_UNWINDER + +struct layout +{ + struct layout *next; + void *pad; + void *return_address; +}; + +#define FRAME_OFFSET(FP) 0 +#define PC_ADJUST -4 +#define STOP_FRAME(CURRENT, TOP_STACK) ((void *) (CURRENT) < (TOP_STACK)) + +/* The PPC ABI has an interesting specificity: the return address saved by a + function is located in it's caller's frame, and the save operation only + takes place if the function performs a call. + + To have __gnat_backtrace retrieve its own return address, we then + define ... */ + +#define FORCE_CALL 1 +#define FRAME_LEVEL 1 + +#define BASE_SKIP 1 + +/*-------------------- PPC ELF (GNU/Linux & VxWorks) ---------------------*/ + +#elif (defined (_ARCH_PPC) && defined (__vxworks)) || \ + (defined (linux) && defined (__powerpc__)) + +#define USE_GENERIC_UNWINDER + +struct layout +{ + struct layout *next; + void *return_address; +}; + +#define FORCE_CALL 1 +#define FRAME_LEVEL 1 +/* See the PPC AIX case for an explanation of these values. */ + +#define FRAME_OFFSET(FP) 0 +#define PC_ADJUST -4 +#define STOP_FRAME(CURRENT, TOP_STACK) ((CURRENT)->next == 0) + +#define BASE_SKIP 1 + +/*-------------------------- SPARC Solaris -----------------------------*/ + +#elif defined (sun) && defined (sparc) + +#define USE_GENERIC_UNWINDER + +/* These definitions are inspired from the Appendix D (Software + Considerations) of the SPARC V8 architecture manual. */ + +struct layout +{ + struct layout *next; + void *return_address; +}; + +#ifdef __arch64__ +#define STACK_BIAS 2047 /* V9 ABI */ +#else +#define STACK_BIAS 0 /* V8 ABI */ +#endif + +#define FRAME_LEVEL 0 +#define FRAME_OFFSET(FP) (14 * sizeof (void*) + (FP ? STACK_BIAS : 0)) +#define PC_ADJUST 0 +#define STOP_FRAME(CURRENT, TOP_STACK) \ + ((CURRENT)->return_address == 0|| (CURRENT)->next == 0 \ + || (void *) (CURRENT) < (TOP_STACK)) + +/* The SPARC register windows need to be flushed before we may access them + from the stack. This is achieved by way of builtin_frame_address only + when the "count" argument is positive, so force at least one such call. */ +#define FETCH_UP_FRAME_ADDRESS + +#define BASE_SKIP 2 +/* From the frame pointer of frame N, we are accessing the flushed register + window of frame N-1 (positive offset from fp), in which we retrieve the + saved return address. We then end up with our caller's return address. */ + +/*------------------------------- x86 ----------------------------------*/ + +#elif defined (i386) + +#if defined (__WIN32) +#include +#define IS_BAD_PTR(ptr) (IsBadCodePtr((void *)ptr)) +#elif defined (sun) +#define IS_BAD_PTR(ptr) ((unsigned long)ptr == -1UL) +#else +#define IS_BAD_PTR(ptr) 0 +#endif + +/* Starting with GCC 4.6, -fomit-frame-pointer is turned on by default for + 32-bit x86/Linux as well and DWARF 2 unwind tables are emitted instead. + See the x86-64 case below for the drawbacks with this approach. */ +#if defined (linux) && (__GNUC__ * 10 + __GNUC_MINOR__ > 45) +#define USE_GCC_UNWINDER +#else +#define USE_GENERIC_UNWINDER +#endif + +struct layout +{ + struct layout *next; + void *return_address; +}; + +#define FRAME_LEVEL 1 +/* builtin_frame_address (1) is expected to work on this target, and (0) might + return the soft stack pointer, which does not designate a location where a + backchain and a return address might be found. */ + +#define FRAME_OFFSET(FP) 0 +#define PC_ADJUST -2 +#define STOP_FRAME(CURRENT, TOP_STACK) \ + (IS_BAD_PTR((long)(CURRENT)) \ + || IS_BAD_PTR((long)(CURRENT)->return_address) \ + || (CURRENT)->return_address == 0|| (CURRENT)->next == 0 \ + || (void *) (CURRENT) < (TOP_STACK)) + +#define BASE_SKIP (1+FRAME_LEVEL) + +/* On i386 architecture we check that at the call point we really have a call + insn. Possible call instructions are: + + call addr16 E8 xx xx xx xx + call reg FF Dx + call off(reg) FF xx xx + lcall addr seg 9A xx xx xx xx xx xx + + This check will not catch all cases but it will increase the backtrace + reliability on this architecture. +*/ + +#define VALID_STACK_FRAME(ptr) \ + (!IS_BAD_PTR(ptr) \ + && (((*((ptr) - 3) & 0xff) == 0xe8) \ + || ((*((ptr) - 5) & 0xff) == 0x9a) \ + || ((*((ptr) - 1) & 0xff) == 0xff) \ + || (((*(ptr) & 0xd0ff) == 0xd0ff)))) + +/*----------------------------- x86_64 ---------------------------------*/ + +#elif defined (__x86_64__) + +#define USE_GCC_UNWINDER +/* The generic unwinder is not used for this target because it is based + on frame layout assumptions that are not reliable on this target (the + rbp register is very likely used for something else than storing the + frame pointer in optimized code). Hence, we use the GCC unwinder + based on DWARF 2 call frame information, although it has the drawback + of not being able to unwind through frames compiled without DWARF 2 + information. +*/ + +#define PC_ADJUST -2 +/* The minimum size of call instructions on this architecture is 2 bytes */ + +/*----------------------------- ia64 ---------------------------------*/ + +#elif defined (__ia64__) && (defined (linux) || defined (__hpux__)) + +#define USE_GCC_UNWINDER +/* Use _Unwind_Backtrace driven exceptions on ia64 HP-UX and ia64 + GNU/Linux, where _Unwind_Backtrace is provided by the system unwind + library. On HP-UX 11.23 this requires patch PHSS_33352, which adds + _Unwind_Backtrace to the system unwind library. */ + +#define PC_ADJUST -4 + + +#endif + +/*---------------------------------------------------------------------* + *-- The post GCC 3.3 infrastructure based implementation --* + *---------------------------------------------------------------------*/ + +#if defined (USE_GCC_UNWINDER) && (__GNUC__ * 10 + __GNUC_MINOR__ > 33) + +/* Conditioning the inclusion on the GCC version is useful to avoid bootstrap + path problems, since the included file refers to post 3.3 functions in + libgcc, and the stage1 compiler is unlikely to be linked against a post 3.3 + library. It actually disables the support for backtraces in this compiler + for targets defining USE_GCC_UNWINDER, which is OK since we don't use the + traceback capability in the compiler anyway. + + The condition is expressed the way above because we cannot reliably rely on + any other macro from the base compiler when compiling stage1. */ + +#include "tb-gcc.c" + +/*------------------------------------------------------------------* + *-- The generic implementation based on frame layout assumptions --* + *------------------------------------------------------------------*/ + +#elif defined (USE_GENERIC_UNWINDER) + +#ifndef CURRENT_STACK_FRAME +# define CURRENT_STACK_FRAME ({ char __csf; &__csf; }) +#endif + +#ifndef VALID_STACK_FRAME +#define VALID_STACK_FRAME(ptr) 1 +#endif + +#ifndef MAX +#define MAX(x,y) ((x) > (y) ? (x) : (y)) +#endif + +#ifndef FORCE_CALL +#define FORCE_CALL 0 +#endif + +/* Make sure the function is not inlined. */ +static void forced_callee (void) __attribute__ ((noinline)); + +static void forced_callee (void) +{ + /* Make sure the function is not pure. */ + volatile int i __attribute__ ((unused)) = 0; +} + +int +__gnat_backtrace (void **array, + int size, + void *exclude_min, + void *exclude_max, + int skip_frames) +{ + struct layout *current; + void *top_frame; + void *top_stack ATTRIBUTE_UNUSED; + int cnt = 0; + + if (FORCE_CALL) + forced_callee (); + + /* Force a call to builtin_frame_address with a positive argument + if required. This is necessary e.g. on SPARC to have the register + windows flushed before we attempt to access them on the stack. */ +#if defined (FETCH_UP_FRAME_ADDRESS) && (FRAME_LEVEL == 0) + __builtin_frame_address (1); +#endif + + top_frame = __builtin_frame_address (FRAME_LEVEL); + top_stack = CURRENT_STACK_FRAME; + current = (struct layout *) ((size_t) top_frame + FRAME_OFFSET (0)); + + /* Skip the number of calls we have been requested to skip, accounting for + the BASE_SKIP parameter. + + FRAME_LEVEL is meaningless for the count adjustment. It impacts where we + start retrieving data from, but how many frames "up" we start at is in + BASE_SKIP by definition. */ + + skip_frames = MAX (0, skip_frames - BASE_SKIP); + + while (cnt < skip_frames) + { + current = (struct layout *) ((size_t) current->next + FRAME_OFFSET (1)); + cnt++; + } + + cnt = 0; + while (cnt < size) + { + if (STOP_FRAME (current, top_stack) || + !VALID_STACK_FRAME((char *)(current->return_address + PC_ADJUST))) + break; + + if (current->return_address < exclude_min + || current->return_address > exclude_max) + array[cnt++] = current->return_address + PC_ADJUST; + + current = (struct layout *) ((size_t) current->next + FRAME_OFFSET (1)); + } + + return cnt; +} + +#else + +/* No target specific implementation and neither USE_GCC_UNWINDER nor + USE_GENERIC_UNWINDER defined. */ + +/*------------------------------* + *-- The dummy implementation --* + *------------------------------*/ + +int +__gnat_backtrace (void **array ATTRIBUTE_UNUSED, + int size ATTRIBUTE_UNUSED, + void *exclude_min ATTRIBUTE_UNUSED, + void *exclude_max ATTRIBUTE_UNUSED, + int skip_frames ATTRIBUTE_UNUSED) +{ + return 0; +} + +#endif + +#endif diff --git a/gcc/ada/tree_gen.adb b/gcc/ada/tree_gen.adb new file mode 100644 index 000000000..67f588d2b --- /dev/null +++ b/gcc/ada/tree_gen.adb @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T R E E _ G E N -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Aspects; +with Atree; +with Debug; +with Elists; +with Fname; +with Lib; +with Namet; +with Nlists; +with Opt; +with Osint.C; +with Repinfo; +with Sem_Aux; +with Sinput; +with Stand; +with Stringt; +with Uintp; +with Urealp; + +with Tree_In; +pragma Warnings (Off, Tree_In); +-- We do not use Tree_In in the compiler, but it is small, and worth including +-- so that we get the proper license check for Tree_In when the compiler is +-- built. This will avoid adding bad dependencies to Tree_In and blowing ASIS. + +procedure Tree_Gen is +begin + if Opt.Tree_Output then + Osint.C.Tree_Create; + Opt.Tree_Write; + + -- For now, only write aspect specifications hash table if -gnatd.A set + + if Debug.Debug_Flag_Dot_AA then + Aspects.Tree_Write; + end if; + + Atree.Tree_Write; + Elists.Tree_Write; + Fname.Tree_Write; + Lib.Tree_Write; + Namet.Tree_Write; + Nlists.Tree_Write; + Sem_Aux.Tree_Write; + Sinput.Tree_Write; + Stand.Tree_Write; + Stringt.Tree_Write; + Uintp.Tree_Write; + Urealp.Tree_Write; + Repinfo.Tree_Write; + Osint.C.Tree_Close; + end if; +end Tree_Gen; diff --git a/gcc/ada/tree_gen.ads b/gcc/ada/tree_gen.ads new file mode 100644 index 000000000..e12e091b7 --- /dev/null +++ b/gcc/ada/tree_gen.ads @@ -0,0 +1,28 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T R E E _ G E N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This procedure is used to write out the tree if the option is set + +procedure Tree_Gen; diff --git a/gcc/ada/tree_in.adb b/gcc/ada/tree_in.adb new file mode 100644 index 000000000..200c566fb --- /dev/null +++ b/gcc/ada/tree_in.adb @@ -0,0 +1,76 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T R E E _ I N -- +-- -- +-- 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 Aspects; +with Atree; +with Csets; +with Debug; +with Elists; +with Fname; +with Lib; +with Namet; +with Nlists; +with Opt; +with Repinfo; +with Sem_Aux; +with Sinput; +with Stand; +with Stringt; +with Tree_IO; +with Uintp; +with Urealp; + +procedure Tree_In (Desc : File_Descriptor) is +begin + Tree_IO.Tree_Read_Initialize (Desc); + Opt.Tree_Read; + + -- For now, only read aspect specifications hash table if -gnatd.A is set + + if Debug.Debug_Flag_Dot_AA then + Aspects.Tree_Read; + end if; + + Atree.Tree_Read; + Elists.Tree_Read; + Fname.Tree_Read; + Lib.Tree_Read; + Namet.Tree_Read; + Nlists.Tree_Read; + Sem_Aux.Tree_Read; + Sinput.Tree_Read; + Stand.Tree_Read; + Stringt.Tree_Read; + Uintp.Tree_Read; + Urealp.Tree_Read; + Repinfo.Tree_Read; + Csets.Initialize; +end Tree_In; diff --git a/gcc/ada/tree_in.ads b/gcc/ada/tree_in.ads new file mode 100644 index 000000000..66c590aca --- /dev/null +++ b/gcc/ada/tree_in.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T R E E _ I N -- +-- -- +-- 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 procedure is used to read in a tree if the option is set. Note that +-- it is not part of the compiler proper, but rather the interface from +-- tools that need to read the tree to the tree reading routines, and is +-- thus bound as part of such tools. + +with System.OS_Lib; use System.OS_Lib; + +procedure Tree_In (Desc : File_Descriptor); +-- Desc is the file descriptor for the file containing the tree, as written +-- by the compiler in a previous compilation using Tree_Gen. On return the +-- global data structures are appropriately initialized. diff --git a/gcc/ada/tree_io.adb b/gcc/ada/tree_io.adb new file mode 100644 index 000000000..6f5647823 --- /dev/null +++ b/gcc/ada/tree_io.adb @@ -0,0 +1,661 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T R E 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 Debug; use Debug; +with Output; use Output; +with Unchecked_Conversion; + +package body Tree_IO is + Debug_Flag_Tree : Boolean := False; + -- Debug flag for debug output from tree read/write + + ------------------------------------------- + -- Compression Scheme Used for Tree File -- + ------------------------------------------- + + -- We don't just write the data directly, but instead do a mild form + -- of compression, since we expect lots of compressible zeroes and + -- blanks. The compression scheme is as follows: + + -- 00nnnnnn followed by nnnnnn bytes (non compressed data) + -- 01nnnnnn indicates nnnnnn binary zero bytes + -- 10nnnnnn indicates nnnnnn ASCII space bytes + -- 11nnnnnn bbbbbbbb indicates nnnnnnnn occurrences of byte bbbbbbbb + + -- Since we expect many zeroes in trees, and many spaces in sources, + -- this compression should be reasonably efficient. We can put in + -- something better later on. + + -- Note that this compression applies to the Write_Tree_Data and + -- Read_Tree_Data calls, not to the calls to read and write single + -- scalar values, which are written in memory format without any + -- compression. + + C_Noncomp : constant := 2#00_000000#; + C_Zeros : constant := 2#01_000000#; + C_Spaces : constant := 2#10_000000#; + C_Repeat : constant := 2#11_000000#; + -- Codes for compression sequences + + Max_Count : constant := 63; + -- Maximum data length for one compression sequence + + -- The above compression scheme applies only to data written with the + -- Tree_Write routine and read with Tree_Read. Data written using the + -- Tree_Write_Char or Tree_Write_Int routines and read using the + -- corresponding input routines is not compressed. + + type Int_Bytes is array (1 .. 4) of Byte; + for Int_Bytes'Size use 32; + + function To_Int_Bytes is new Unchecked_Conversion (Int, Int_Bytes); + function To_Int is new Unchecked_Conversion (Int_Bytes, Int); + + ---------------------- + -- Global Variables -- + ---------------------- + + Tree_FD : File_Descriptor; + -- File descriptor for tree + + Buflen : constant Int := 8_192; + -- Length of buffer for read and write file data + + Buf : array (Pos range 1 .. Buflen) of Byte; + -- Read/write file data buffer + + Bufn : Nat; + -- Number of bytes read/written from/to buffer + + Buft : Nat; + -- Total number of bytes in input buffer containing valid data. Used only + -- for input operations. There is data left to be processed in the buffer + -- if Buft > Bufn. A value of zero for Buft means that the buffer is empty. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Read_Buffer; + -- Reads data into buffer, setting Bufn appropriately + + function Read_Byte return Byte; + pragma Inline (Read_Byte); + -- Returns next byte from input file, raises Tree_Format_Error if none left + + procedure Write_Buffer; + -- Writes out current buffer contents + + procedure Write_Byte (B : Byte); + pragma Inline (Write_Byte); + -- Write one byte to output buffer, checking for buffer-full condition + + ----------------- + -- Read_Buffer -- + ----------------- + + procedure Read_Buffer is + begin + Buft := Int (Read (Tree_FD, Buf (1)'Address, Integer (Buflen))); + + if Buft = 0 then + raise Tree_Format_Error; + else + Bufn := 0; + end if; + end Read_Buffer; + + --------------- + -- Read_Byte -- + --------------- + + function Read_Byte return Byte is + begin + if Bufn = Buft then + Read_Buffer; + end if; + + Bufn := Bufn + 1; + return Buf (Bufn); + end Read_Byte; + + -------------------- + -- Tree_Read_Bool -- + -------------------- + + procedure Tree_Read_Bool (B : out Boolean) is + begin + B := Boolean'Val (Read_Byte); + + if Debug_Flag_Tree then + if B then + Write_Str ("True"); + else + Write_Str ("False"); + end if; + + Write_Eol; + end if; + end Tree_Read_Bool; + + -------------------- + -- Tree_Read_Char -- + -------------------- + + procedure Tree_Read_Char (C : out Character) is + begin + C := Character'Val (Read_Byte); + + if Debug_Flag_Tree then + Write_Str ("==> transmitting Character = "); + Write_Char (C); + Write_Eol; + end if; + end Tree_Read_Char; + + -------------------- + -- Tree_Read_Data -- + -------------------- + + procedure Tree_Read_Data (Addr : Address; Length : Int) is + + type S is array (Pos) of Byte; + -- This is a big array, for which we have to suppress the warning + + type SP is access all S; + + function To_SP is new Unchecked_Conversion (Address, SP); + + Data : constant SP := To_SP (Addr); + -- Data buffer to be read as an indexable array of bytes + + OP : Pos := 1; + -- Pointer to next byte of data buffer to be read into + + B : Byte; + C : Byte; + L : Int; + + begin + if Debug_Flag_Tree then + Write_Str ("==> transmitting "); + Write_Int (Length); + Write_Str (" data bytes"); + Write_Eol; + end if; + + -- Verify data length + + Tree_Read_Int (L); + + if L /= Length then + Write_Str ("==> transmitting, expected "); + Write_Int (Length); + Write_Str (" bytes, found length = "); + Write_Int (L); + Write_Eol; + raise Tree_Format_Error; + end if; + + -- Loop to read data + + while OP <= Length loop + + -- Get compression control character + + B := Read_Byte; + C := B and 2#00_111111#; + B := B and 2#11_000000#; + + -- Non-repeat case + + if B = C_Noncomp then + if Debug_Flag_Tree then + Write_Str ("==> uncompressed: "); + Write_Int (Int (C)); + Write_Str (", starting at "); + Write_Int (OP); + Write_Eol; + end if; + + for J in 1 .. C loop + Data (OP) := Read_Byte; + OP := OP + 1; + end loop; + + -- Repeated zeroes + + elsif B = C_Zeros then + if Debug_Flag_Tree then + Write_Str ("==> zeroes: "); + Write_Int (Int (C)); + Write_Str (", starting at "); + Write_Int (OP); + Write_Eol; + end if; + + for J in 1 .. C loop + Data (OP) := 0; + OP := OP + 1; + end loop; + + -- Repeated spaces + + elsif B = C_Spaces then + if Debug_Flag_Tree then + Write_Str ("==> spaces: "); + Write_Int (Int (C)); + Write_Str (", starting at "); + Write_Int (OP); + Write_Eol; + end if; + + for J in 1 .. C loop + Data (OP) := Character'Pos (' '); + OP := OP + 1; + end loop; + + -- Specified repeated character + + else -- B = C_Repeat + B := Read_Byte; + + if Debug_Flag_Tree then + Write_Str ("==> other char: "); + Write_Int (Int (C)); + Write_Str (" ("); + Write_Int (Int (B)); + Write_Char (')'); + Write_Str (", starting at "); + Write_Int (OP); + Write_Eol; + end if; + + for J in 1 .. C loop + Data (OP) := B; + OP := OP + 1; + end loop; + end if; + end loop; + + -- At end of loop, data item must be exactly filled + + if OP /= Length + 1 then + raise Tree_Format_Error; + end if; + + end Tree_Read_Data; + + -------------------------- + -- Tree_Read_Initialize -- + -------------------------- + + procedure Tree_Read_Initialize (Desc : File_Descriptor) is + begin + Buft := 0; + Bufn := 0; + Tree_FD := Desc; + Debug_Flag_Tree := Debug_Flag_5; + end Tree_Read_Initialize; + + ------------------- + -- Tree_Read_Int -- + ------------------- + + procedure Tree_Read_Int (N : out Int) is + N_Bytes : Int_Bytes; + + begin + for J in 1 .. 4 loop + N_Bytes (J) := Read_Byte; + end loop; + + N := To_Int (N_Bytes); + + if Debug_Flag_Tree then + Write_Str ("==> transmitting Int = "); + Write_Int (N); + Write_Eol; + end if; + end Tree_Read_Int; + + ------------------- + -- Tree_Read_Str -- + ------------------- + + procedure Tree_Read_Str (S : out String_Ptr) is + N : Nat; + + begin + Tree_Read_Int (N); + S := new String (1 .. Natural (N)); + Tree_Read_Data (S.all (1)'Address, N); + end Tree_Read_Str; + + ------------------------- + -- Tree_Read_Terminate -- + ------------------------- + + procedure Tree_Read_Terminate is + begin + -- Must be at end of input buffer, so we should get Tree_Format_Error + -- if we try to read one more byte, if not, we have a format error. + + declare + B : Byte; + pragma Warnings (Off, B); + + begin + B := Read_Byte; + + exception + when Tree_Format_Error => return; + end; + + raise Tree_Format_Error; + end Tree_Read_Terminate; + + --------------------- + -- Tree_Write_Bool -- + --------------------- + + procedure Tree_Write_Bool (B : Boolean) is + begin + if Debug_Flag_Tree then + Write_Str ("==> transmitting Boolean = "); + + if B then + Write_Str ("True"); + else + Write_Str ("False"); + end if; + + Write_Eol; + end if; + + Write_Byte (Boolean'Pos (B)); + end Tree_Write_Bool; + + --------------------- + -- Tree_Write_Char -- + --------------------- + + procedure Tree_Write_Char (C : Character) is + begin + if Debug_Flag_Tree then + Write_Str ("==> transmitting Character = "); + Write_Char (C); + Write_Eol; + end if; + + Write_Byte (Character'Pos (C)); + end Tree_Write_Char; + + --------------------- + -- Tree_Write_Data -- + --------------------- + + procedure Tree_Write_Data (Addr : Address; Length : Int) is + + type S is array (Pos) of Byte; + -- This is a big array, for which we have to suppress the warning + + type SP is access all S; + + function To_SP is new Unchecked_Conversion (Address, SP); + + Data : constant SP := To_SP (Addr); + -- Pointer to data to be written, converted to array type + + IP : Pos := 1; + -- Input buffer pointer, next byte to be processed + + NC : Nat range 0 .. Max_Count := 0; + -- Number of bytes of non-compressible sequence + + C : Byte; + + procedure Write_Non_Compressed_Sequence; + -- Output currently collected sequence of non-compressible data + + ----------------------------------- + -- Write_Non_Compressed_Sequence -- + ----------------------------------- + + procedure Write_Non_Compressed_Sequence is + begin + if NC > 0 then + Write_Byte (C_Noncomp + Byte (NC)); + + if Debug_Flag_Tree then + Write_Str ("==> uncompressed: "); + Write_Int (NC); + Write_Str (", starting at "); + Write_Int (IP - NC); + Write_Eol; + end if; + + for J in reverse 1 .. NC loop + Write_Byte (Data (IP - J)); + end loop; + + NC := 0; + end if; + end Write_Non_Compressed_Sequence; + + -- Start of processing for Tree_Write_Data + + begin + if Debug_Flag_Tree then + Write_Str ("==> transmitting "); + Write_Int (Length); + Write_Str (" data bytes"); + Write_Eol; + end if; + + -- We write the count at the start, so that we can check it on + -- the corresponding read to make sure that reads and writes match + + Tree_Write_Int (Length); + + -- Conversion loop + -- IP is index of next input character + -- NC is number of non-compressible bytes saved up + + loop + -- If input is completely processed, then we are all done + + if IP > Length then + Write_Non_Compressed_Sequence; + return; + end if; + + -- Test for compressible sequence, must be at least three identical + -- bytes in a row to be worthwhile compressing. + + if IP + 2 <= Length + and then Data (IP) = Data (IP + 1) + and then Data (IP) = Data (IP + 2) + then + Write_Non_Compressed_Sequence; + + -- Count length of new compression sequence + + C := 3; + IP := IP + 3; + + while IP < Length + and then Data (IP) = Data (IP - 1) + and then C < Max_Count + loop + C := C + 1; + IP := IP + 1; + end loop; + + -- Output compression sequence + + if Data (IP - 1) = 0 then + if Debug_Flag_Tree then + Write_Str ("==> zeroes: "); + Write_Int (Int (C)); + Write_Str (", starting at "); + Write_Int (IP - Int (C)); + Write_Eol; + end if; + + Write_Byte (C_Zeros + C); + + elsif Data (IP - 1) = Character'Pos (' ') then + if Debug_Flag_Tree then + Write_Str ("==> spaces: "); + Write_Int (Int (C)); + Write_Str (", starting at "); + Write_Int (IP - Int (C)); + Write_Eol; + end if; + + Write_Byte (C_Spaces + C); + + else + if Debug_Flag_Tree then + Write_Str ("==> other char: "); + Write_Int (Int (C)); + Write_Str (" ("); + Write_Int (Int (Data (IP - 1))); + Write_Char (')'); + Write_Str (", starting at "); + Write_Int (IP - Int (C)); + Write_Eol; + end if; + + Write_Byte (C_Repeat + C); + Write_Byte (Data (IP - 1)); + end if; + + -- No compression possible here + + else + -- Output non-compressed sequence if at maximum length + + if NC = Max_Count then + Write_Non_Compressed_Sequence; + end if; + + NC := NC + 1; + IP := IP + 1; + end if; + end loop; + + end Tree_Write_Data; + + --------------------------- + -- Tree_Write_Initialize -- + --------------------------- + + procedure Tree_Write_Initialize (Desc : File_Descriptor) is + begin + Bufn := 0; + Tree_FD := Desc; + Set_Standard_Error; + Debug_Flag_Tree := Debug_Flag_5; + end Tree_Write_Initialize; + + -------------------- + -- Tree_Write_Int -- + -------------------- + + procedure Tree_Write_Int (N : Int) is + N_Bytes : constant Int_Bytes := To_Int_Bytes (N); + + begin + if Debug_Flag_Tree then + Write_Str ("==> transmitting Int = "); + Write_Int (N); + Write_Eol; + end if; + + for J in 1 .. 4 loop + Write_Byte (N_Bytes (J)); + end loop; + end Tree_Write_Int; + + -------------------- + -- Tree_Write_Str -- + -------------------- + + procedure Tree_Write_Str (S : String_Ptr) is + begin + Tree_Write_Int (S'Length); + Tree_Write_Data (S (1)'Address, S'Length); + end Tree_Write_Str; + + -------------------------- + -- Tree_Write_Terminate -- + -------------------------- + + procedure Tree_Write_Terminate is + begin + if Bufn > 0 then + Write_Buffer; + end if; + end Tree_Write_Terminate; + + ------------------ + -- Write_Buffer -- + ------------------ + + procedure Write_Buffer is + begin + if Integer (Bufn) = Write (Tree_FD, Buf'Address, Integer (Bufn)) then + Bufn := 0; + + else + Set_Standard_Error; + Write_Str ("fatal error: disk full"); + OS_Exit (2); + end if; + end Write_Buffer; + + ---------------- + -- Write_Byte -- + ---------------- + + procedure Write_Byte (B : Byte) is + begin + Bufn := Bufn + 1; + Buf (Bufn) := B; + + if Bufn = Buflen then + Write_Buffer; + end if; + end Write_Byte; + +end Tree_IO; diff --git a/gcc/ada/tree_io.ads b/gcc/ada/tree_io.ads new file mode 100644 index 000000000..0cb17fed2 --- /dev/null +++ b/gcc/ada/tree_io.ads @@ -0,0 +1,114 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T R E E _ I O -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines used to read and write the tree files +-- used by ASIS. Only the actual read and write routines are here. The open, +-- create and close routines are elsewhere (in Osint in the compiler, and in +-- the tree read driver for the tree read interface). + +with Types; use Types; +with System; use System; + +pragma Warnings (Off); +-- This package is used also by gnatcoll +with System.OS_Lib; use System.OS_Lib; +pragma Warnings (On); + +package Tree_IO is + + Tree_Format_Error : exception; + -- Raised if a format error is detected in the input file + + ASIS_Version_Number : constant := 23; + -- ASIS Version. This is used to check for consistency between the compiler + -- used to generate trees and an ASIS application that is reading the + -- trees. It must be incremented whenever a change is made to the tree + -- format that would result in the compiler being incompatible with an + -- older version of ASIS. + + procedure Tree_Read_Initialize (Desc : File_Descriptor); + -- Called to initialize reading of a tree file. This call must be made + -- before calls to Tree_Read_xx. No calls to Tree_Write_xx are permitted + -- after this call. + + procedure Tree_Read_Data (Addr : Address; Length : Int); + -- Checks that the Length provided is the same as what has been provided + -- to the corresponding Tree_Write_Data from the current tree file, + -- Tree_Format_Error is raised if it is not the case. If Length is + -- correct and non zero, reads Length bytes of information into memory + -- starting at Addr from the current tree file. + + procedure Tree_Read_Bool (B : out Boolean); + -- Reads a single boolean value. The boolean value must have been written + -- with a call to the Tree_Write_Bool procedure. + + procedure Tree_Read_Char (C : out Character); + -- Reads a single character. The character must have been written with a + -- call to the Tree_Write_Char procedure. + + procedure Tree_Read_Int (N : out Int); + -- Reads a single integer value. The integer must have been written with + -- a call to the Tree_Write_Int procedure. + + procedure Tree_Read_Str (S : out String_Ptr); + -- Read string, allocate on heap, and return pointer to allocated string + -- which always has a lower bound of 1. + + procedure Tree_Read_Terminate; + -- Called after reading all data, checks that the buffer pointers is at + -- the end of file, raising Tree_Format_Error if not. + + procedure Tree_Write_Initialize (Desc : File_Descriptor); + -- Called to initialize writing of a tree file. This call must be made + -- before calls to Tree_Write_xx. No calls to Tree_Read_xx are permitted + -- after this call. + + procedure Tree_Write_Data (Addr : Address; Length : Int); + -- Writes Length then, if Length is not null, Length bytes of data + -- starting at Addr to current tree file + + procedure Tree_Write_Bool (B : Boolean); + -- Writes a single boolean value to the current tree file + + procedure Tree_Write_Char (C : Character); + -- Writes a single character to the current tree file + + procedure Tree_Write_Int (N : Int); + -- Writes a single integer value to the current tree file + + procedure Tree_Write_Str (S : String_Ptr); + -- Write out string value referenced by S (low bound of S must be 1) + + procedure Tree_Write_Terminate; + -- Terminates writing of the file (flushing the buffer), but does not + -- close the file (the caller is responsible for closing the file). + +end Tree_IO; diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb new file mode 100644 index 000000000..fb31f38b0 --- /dev/null +++ b/gcc/ada/treepr.adb @@ -0,0 +1,2008 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T R E E P 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Aspects; use Aspects; +with Atree; use Atree; +with Csets; use Csets; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Output; use Output; +with Sem_Mech; use Sem_Mech; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Sinput; use Sinput; +with Stand; use Stand; +with Stringt; use Stringt; +with SCIL_LL; use SCIL_LL; +with Treeprs; use Treeprs; +with Uintp; use Uintp; +with Urealp; use Urealp; +with Uname; use Uname; +with Unchecked_Deallocation; + +package body Treepr is + + use Atree.Unchecked_Access; + -- This module uses the unchecked access functions in package Atree + -- since it does an untyped traversal of the tree (we do not want to + -- count on the structure of the tree being correct in this routine!) + + ---------------------------------- + -- Approach Used for Tree Print -- + ---------------------------------- + + -- When a complete subtree is being printed, a trace phase first marks + -- the nodes and lists to be printed. This trace phase allocates logical + -- numbers corresponding to the order in which the nodes and lists will + -- be printed. The Node_Id, List_Id and Elist_Id values are mapped to + -- logical node numbers using a hash table. Output is done using a set + -- of Print_xxx routines, which are similar to the Write_xxx routines + -- with the same name, except that they do not generate any output in + -- the marking phase. This allows identical logic to be used in the + -- two phases. + + -- Note that the hash table not only holds the serial numbers, but also + -- acts as a record of which nodes have already been visited. In the + -- marking phase, a node has been visited if it is already in the hash + -- table, and in the printing phase, we can tell whether a node has + -- already been printed by looking at the value of the serial number. + + ---------------------- + -- Global Variables -- + ---------------------- + + type Hash_Record is record + Serial : Nat; + -- Serial number for hash table entry. A value of zero means that + -- the entry is currently unused. + + Id : Int; + -- If serial number field is non-zero, contains corresponding Id value + end record; + + type Hash_Table_Type is array (Nat range <>) of Hash_Record; + type Access_Hash_Table_Type is access Hash_Table_Type; + Hash_Table : Access_Hash_Table_Type; + -- The hash table itself, see Serial_Number function for details of use + + Hash_Table_Len : Nat; + -- Range of Hash_Table is from 0 .. Hash_Table_Len - 1 so that dividing + -- by Hash_Table_Len gives a remainder that is in Hash_Table'Range. + + Next_Serial_Number : Nat; + -- Number of last visited node or list. Used during the marking phase to + -- set proper node numbers in the hash table, and during the printing + -- phase to make sure that a given node is not printed more than once. + -- (nodes are printed in order during the printing phase, that's the + -- point of numbering them in the first place!) + + Printing_Descendants : Boolean; + -- True if descendants are being printed, False if not. In the false case, + -- only node Id's are printed. In the true case, node numbers as well as + -- node Id's are printed, as described above. + + type Phase_Type is (Marking, Printing); + -- Type for Phase variable + + Phase : Phase_Type; + -- When an entire tree is being printed, the traversal operates in two + -- phases. The first phase marks the nodes in use by installing node + -- numbers in the node number table. The second phase prints the nodes. + -- This variable indicates the current phase. + + ---------------------- + -- Local Procedures -- + ---------------------- + + procedure Print_End_Span (N : Node_Id); + -- Special routine to print contents of End_Span field of node N. + -- The format includes the implicit source location as well as the + -- value of the field. + + procedure Print_Init; + -- Initialize for printing of tree with descendents + + procedure Print_Term; + -- Clean up after printing of tree with descendents + + procedure Print_Char (C : Character); + -- Print character C if currently in print phase, noop if in marking phase + + procedure Print_Name (N : Name_Id); + -- Print name from names table if currently in print phase, noop if in + -- marking phase. Note that the name is output in mixed case mode. + + procedure Print_Node_Kind (N : Node_Id); + -- Print node kind name in mixed case if in print phase, noop if in + -- marking phase. + + procedure Print_Str (S : String); + -- Print string S if currently in print phase, noop if in marking phase + + procedure Print_Str_Mixed_Case (S : String); + -- Like Print_Str, except that the string is printed in mixed case mode + + procedure Print_Int (I : Int); + -- Print integer I if currently in print phase, noop if in marking phase + + procedure Print_Eol; + -- Print end of line if currently in print phase, noop if in marking phase + + procedure Print_Node_Ref (N : Node_Id); + -- Print "", "" or "Node #nnn" with additional information + -- in the latter case, including the Id and the Nkind of the node. + + procedure Print_List_Ref (L : List_Id); + -- Print "", or "" or "Node list #nnn" + + procedure Print_Elist_Ref (E : Elist_Id); + -- Print "", or "" or "Element list #nnn" + + procedure Print_Entity_Info (Ent : Entity_Id; Prefix : String); + -- Called if the node being printed is an entity. Prints fields from the + -- extension, using routines in Einfo to get the field names and flags. + + procedure Print_Field (Val : Union_Id; Format : UI_Format := Auto); + -- Print representation of Field value (name, tree, string, uint, charcode) + -- The format parameter controls the format of printing in the case of an + -- integer value (see UI_Write for details). + + procedure Print_Flag (F : Boolean); + -- Print True or False + + procedure Print_Node + (N : Node_Id; + Prefix_Str : String; + Prefix_Char : Character); + -- This is the internal routine used to print a single node. Each line of + -- output is preceded by Prefix_Str (which is used to set the indentation + -- level and the bars used to link list elements). In addition, for lines + -- other than the first, an additional character Prefix_Char is output. + + function Serial_Number (Id : Int) return Nat; + -- Given a Node_Id, List_Id or Elist_Id, returns the previously assigned + -- serial number, or zero if no serial number has yet been assigned. + + procedure Set_Serial_Number; + -- Can be called only immediately following a call to Serial_Number that + -- returned a value of zero. Causes the value of Next_Serial_Number to be + -- placed in the hash table (corresponding to the Id argument used in the + -- Serial_Number call), and increments Next_Serial_Number. + + procedure Visit_Node + (N : Node_Id; + Prefix_Str : String; + Prefix_Char : Character); + -- Called to process a single node in the case where descendents are to + -- be printed before every line, and Prefix_Char added to all lines + -- except the header line for the node. + + procedure Visit_List (L : List_Id; Prefix_Str : String); + -- Visit_List is called to process a list in the case where descendents + -- are to be printed. Prefix_Str is to be added to all printed lines. + + procedure Visit_Elist (E : Elist_Id; Prefix_Str : String); + -- Visit_Elist is called to process an element list in the case where + -- descendents are to be printed. Prefix_Str is to be added to all + -- printed lines. + + -------- + -- pe -- + -------- + + procedure pe (E : Elist_Id) is + begin + Print_Tree_Elist (E); + end pe; + + -------- + -- pl -- + -------- + + procedure pl (L : Int) is + Lid : Int; + + begin + if L < 0 then + Lid := L; + + -- This is the case where we transform e.g. +36 to -99999936 + + else + if L <= 9 then + Lid := -(99999990 + L); + elsif L <= 99 then + Lid := -(99999900 + L); + elsif L <= 999 then + Lid := -(99999000 + L); + elsif L <= 9999 then + Lid := -(99990000 + L); + elsif L <= 99999 then + Lid := -(99900000 + L); + elsif L <= 999999 then + Lid := -(99000000 + L); + elsif L <= 9999999 then + Lid := -(90000000 + L); + else + Lid := -L; + end if; + end if; + + -- Now output the list + + Print_Tree_List (List_Id (Lid)); + end pl; + + -------- + -- pn -- + -------- + + procedure pn (N : Node_Id) is + begin + Print_Tree_Node (N); + end pn; + + ---------------- + -- Print_Char -- + ---------------- + + procedure Print_Char (C : Character) is + begin + if Phase = Printing then + Write_Char (C); + end if; + end Print_Char; + + --------------------- + -- Print_Elist_Ref -- + --------------------- + + procedure Print_Elist_Ref (E : Elist_Id) is + begin + if Phase /= Printing then + return; + end if; + + if E = No_Elist then + Write_Str (""); + + elsif Is_Empty_Elmt_List (E) then + Write_Str ("Empty elist, (Elist_Id="); + Write_Int (Int (E)); + Write_Char (')'); + + else + Write_Str ("(Elist_Id="); + Write_Int (Int (E)); + Write_Char (')'); + + if Printing_Descendants then + Write_Str (" #"); + Write_Int (Serial_Number (Int (E))); + end if; + end if; + end Print_Elist_Ref; + + ------------------------- + -- Print_Elist_Subtree -- + ------------------------- + + procedure Print_Elist_Subtree (E : Elist_Id) is + begin + Print_Init; + + Next_Serial_Number := 1; + Phase := Marking; + Visit_Elist (E, ""); + + Next_Serial_Number := 1; + Phase := Printing; + Visit_Elist (E, ""); + + Print_Term; + end Print_Elist_Subtree; + + -------------------- + -- Print_End_Span -- + -------------------- + + procedure Print_End_Span (N : Node_Id) is + Val : constant Uint := End_Span (N); + + begin + UI_Write (Val); + Write_Str (" (Uint = "); + Write_Int (Int (Field5 (N))); + Write_Str (") "); + + if Val /= No_Uint then + Write_Location (End_Location (N)); + end if; + end Print_End_Span; + + ----------------------- + -- Print_Entity_Info -- + ----------------------- + + procedure Print_Entity_Info (Ent : Entity_Id; Prefix : String) is + function Field_Present (U : Union_Id) return Boolean; + -- Returns False unless the value U represents a missing value + -- (Empty, No_Uint, No_Ureal or No_String) + + function Field_Present (U : Union_Id) return Boolean is + begin + return + U /= Union_Id (Empty) and then + U /= To_Union (No_Uint) and then + U /= To_Union (No_Ureal) and then + U /= Union_Id (No_String); + end Field_Present; + + -- Start of processing for Print_Entity_Info + + begin + Print_Str (Prefix); + Print_Str ("Ekind = "); + Print_Str_Mixed_Case (Entity_Kind'Image (Ekind (Ent))); + Print_Eol; + + Print_Str (Prefix); + Print_Str ("Etype = "); + Print_Node_Ref (Etype (Ent)); + Print_Eol; + + if Convention (Ent) /= Convention_Ada then + Print_Str (Prefix); + Print_Str ("Convention = "); + + -- Print convention name skipping the Convention_ at the start + + declare + S : constant String := Convention_Id'Image (Convention (Ent)); + + begin + Print_Str_Mixed_Case (S (12 .. S'Last)); + Print_Eol; + end; + end if; + + if Field_Present (Field6 (Ent)) then + Print_Str (Prefix); + Write_Field6_Name (Ent); + Write_Str (" = "); + Print_Field (Field6 (Ent)); + Print_Eol; + end if; + + if Field_Present (Field7 (Ent)) then + Print_Str (Prefix); + Write_Field7_Name (Ent); + Write_Str (" = "); + Print_Field (Field7 (Ent)); + Print_Eol; + end if; + + if Field_Present (Field8 (Ent)) then + Print_Str (Prefix); + Write_Field8_Name (Ent); + Write_Str (" = "); + Print_Field (Field8 (Ent)); + Print_Eol; + end if; + + if Field_Present (Field9 (Ent)) then + Print_Str (Prefix); + Write_Field9_Name (Ent); + Write_Str (" = "); + Print_Field (Field9 (Ent)); + Print_Eol; + end if; + + if Field_Present (Field10 (Ent)) then + Print_Str (Prefix); + Write_Field10_Name (Ent); + Write_Str (" = "); + Print_Field (Field10 (Ent)); + Print_Eol; + end if; + + if Field_Present (Field11 (Ent)) then + Print_Str (Prefix); + Write_Field11_Name (Ent); + Write_Str (" = "); + Print_Field (Field11 (Ent)); + Print_Eol; + end if; + + if Field_Present (Field12 (Ent)) then + Print_Str (Prefix); + Write_Field12_Name (Ent); + Write_Str (" = "); + Print_Field (Field12 (Ent)); + Print_Eol; + end if; + + if Field_Present (Field13 (Ent)) then + Print_Str (Prefix); + Write_Field13_Name (Ent); + Write_Str (" = "); + Print_Field (Field13 (Ent)); + Print_Eol; + end if; + + if Field_Present (Field14 (Ent)) then + Print_Str (Prefix); + Write_Field14_Name (Ent); + Write_Str (" = "); + Print_Field (Field14 (Ent)); + Print_Eol; + end if; + + if Field_Present (Field15 (Ent)) then + Print_Str (Prefix); + Write_Field15_Name (Ent); + Write_Str (" = "); + Print_Field (Field15 (Ent)); + Print_Eol; + end if; + + if Field_Present (Field16 (Ent)) then + Print_Str (Prefix); + Write_Field16_Name (Ent); + Write_Str (" = "); + Print_Field (Field16 (Ent)); + Print_Eol; + end if; + + if Field_Present (Field17 (Ent)) then + Print_Str (Prefix); + Write_Field17_Name (Ent); + Write_Str (" = "); + Print_Field (Field17 (Ent)); + Print_Eol; + end if; + + if Field_Present (Field18 (Ent)) then + Print_Str (Prefix); + Write_Field18_Name (Ent); + Write_Str (" = "); + Print_Field (Field18 (Ent)); + Print_Eol; + end if; + + if Field_Present (Field19 (Ent)) then + Print_Str (Prefix); + Write_Field19_Name (Ent); + Write_Str (" = "); + Print_Field (Field19 (Ent)); + Print_Eol; + end if; + + if Field_Present (Field20 (Ent)) then + Print_Str (Prefix); + Write_Field20_Name (Ent); + Write_Str (" = "); + Print_Field (Field20 (Ent)); + Print_Eol; + end if; + + if Field_Present (Field21 (Ent)) then + Print_Str (Prefix); + Write_Field21_Name (Ent); + Write_Str (" = "); + Print_Field (Field21 (Ent)); + Print_Eol; + end if; + + if Field_Present (Field22 (Ent)) then + Print_Str (Prefix); + Write_Field22_Name (Ent); + Write_Str (" = "); + + -- Mechanism case has to be handled specially + + if Ekind (Ent) = E_Function or else Is_Formal (Ent) then + declare + M : constant Mechanism_Type := Mechanism (Ent); + + begin + case M is + when Default_Mechanism + => Write_Str ("Default"); + when By_Copy + => Write_Str ("By_Copy"); + when By_Reference + => Write_Str ("By_Reference"); + when By_Descriptor + => Write_Str ("By_Descriptor"); + when By_Descriptor_UBS + => Write_Str ("By_Descriptor_UBS"); + when By_Descriptor_UBSB + => Write_Str ("By_Descriptor_UBSB"); + when By_Descriptor_UBA + => Write_Str ("By_Descriptor_UBA"); + when By_Descriptor_S + => Write_Str ("By_Descriptor_S"); + when By_Descriptor_SB + => Write_Str ("By_Descriptor_SB"); + when By_Descriptor_A + => Write_Str ("By_Descriptor_A"); + when By_Descriptor_NCA + => Write_Str ("By_Descriptor_NCA"); + when By_Short_Descriptor + => Write_Str ("By_Short_Descriptor"); + when By_Short_Descriptor_UBS + => Write_Str ("By_Short_Descriptor_UBS"); + when By_Short_Descriptor_UBSB + => Write_Str ("By_Short_Descriptor_UBSB"); + when By_Short_Descriptor_UBA + => Write_Str ("By_Short_Descriptor_UBA"); + when By_Short_Descriptor_S + => Write_Str ("By_Short_Descriptor_S"); + when By_Short_Descriptor_SB + => Write_Str ("By_Short_Descriptor_SB"); + when By_Short_Descriptor_A + => Write_Str ("By_Short_Descriptor_A"); + when By_Short_Descriptor_NCA + => Write_Str ("By_Short_Descriptor_NCA"); + + when 1 .. Mechanism_Type'Last => + Write_Str ("By_Copy if size <= "); + Write_Int (Int (M)); + + end case; + end; + + -- Normal case (not Mechanism) + + else + Print_Field (Field22 (Ent)); + end if; + + Print_Eol; + end if; + + if Field_Present (Field23 (Ent)) then + Print_Str (Prefix); + Write_Field23_Name (Ent); + Write_Str (" = "); + Print_Field (Field23 (Ent)); + Print_Eol; + end if; + + if Field_Present (Field24 (Ent)) then + Print_Str (Prefix); + Write_Field24_Name (Ent); + Write_Str (" = "); + Print_Field (Field24 (Ent)); + Print_Eol; + end if; + + if Field_Present (Field25 (Ent)) then + Print_Str (Prefix); + Write_Field25_Name (Ent); + Write_Str (" = "); + Print_Field (Field25 (Ent)); + Print_Eol; + end if; + + if Field_Present (Field26 (Ent)) then + Print_Str (Prefix); + Write_Field26_Name (Ent); + Write_Str (" = "); + Print_Field (Field26 (Ent)); + Print_Eol; + end if; + + if Field_Present (Field27 (Ent)) then + Print_Str (Prefix); + Write_Field27_Name (Ent); + Write_Str (" = "); + Print_Field (Field27 (Ent)); + Print_Eol; + end if; + + if Field_Present (Field28 (Ent)) then + Print_Str (Prefix); + Write_Field28_Name (Ent); + Write_Str (" = "); + Print_Field (Field28 (Ent)); + Print_Eol; + end if; + + if Field_Present (Field29 (Ent)) then + Print_Str (Prefix); + Write_Field29_Name (Ent); + Write_Str (" = "); + Print_Field (Field29 (Ent)); + Print_Eol; + end if; + + Write_Entity_Flags (Ent, Prefix); + end Print_Entity_Info; + + --------------- + -- Print_Eol -- + --------------- + + procedure Print_Eol is + begin + if Phase = Printing then + Write_Eol; + end if; + end Print_Eol; + + ----------------- + -- Print_Field -- + ----------------- + + procedure Print_Field (Val : Union_Id; Format : UI_Format := Auto) is + begin + if Phase /= Printing then + return; + end if; + + if Val in Node_Range then + Print_Node_Ref (Node_Id (Val)); + + elsif Val in List_Range then + Print_List_Ref (List_Id (Val)); + + elsif Val in Elist_Range then + Print_Elist_Ref (Elist_Id (Val)); + + elsif Val in Names_Range then + Print_Name (Name_Id (Val)); + Write_Str (" (Name_Id="); + Write_Int (Int (Val)); + Write_Char (')'); + + elsif Val in Strings_Range then + Write_String_Table_Entry (String_Id (Val)); + Write_Str (" (String_Id="); + Write_Int (Int (Val)); + Write_Char (')'); + + elsif Val in Uint_Range then + UI_Write (From_Union (Val), Format); + Write_Str (" (Uint = "); + Write_Int (Int (Val)); + Write_Char (')'); + + elsif Val in Ureal_Range then + UR_Write (From_Union (Val)); + Write_Str (" (Ureal = "); + Write_Int (Int (Val)); + Write_Char (')'); + + else + Print_Str ("****** Incorrect value = "); + Print_Int (Int (Val)); + end if; + end Print_Field; + + ---------------- + -- Print_Flag -- + ---------------- + + procedure Print_Flag (F : Boolean) is + begin + if F then + Print_Str ("True"); + else + Print_Str ("False"); + end if; + end Print_Flag; + + ---------------- + -- Print_Init -- + ---------------- + + procedure Print_Init is + begin + Printing_Descendants := True; + Write_Eol; + + -- Allocate and clear serial number hash table. The size is 150% of + -- the maximum possible number of entries, so that the hash table + -- cannot get significantly overloaded. + + Hash_Table_Len := (150 * (Num_Nodes + Num_Lists + Num_Elists)) / 100; + Hash_Table := new Hash_Table_Type (0 .. Hash_Table_Len - 1); + + for J in Hash_Table'Range loop + Hash_Table (J).Serial := 0; + end loop; + + end Print_Init; + + --------------- + -- Print_Int -- + --------------- + + procedure Print_Int (I : Int) is + begin + if Phase = Printing then + Write_Int (I); + end if; + end Print_Int; + + -------------------- + -- Print_List_Ref -- + -------------------- + + procedure Print_List_Ref (L : List_Id) is + begin + if Phase /= Printing then + return; + end if; + + if No (L) then + Write_Str (""); + + elsif Is_Empty_List (L) then + Write_Str (" (List_Id="); + Write_Int (Int (L)); + Write_Char (')'); + + else + Write_Str ("List"); + + if Printing_Descendants then + Write_Str (" #"); + Write_Int (Serial_Number (Int (L))); + end if; + + Write_Str (" (List_Id="); + Write_Int (Int (L)); + Write_Char (')'); + end if; + end Print_List_Ref; + + ------------------------ + -- Print_List_Subtree -- + ------------------------ + + procedure Print_List_Subtree (L : List_Id) is + begin + Print_Init; + + Next_Serial_Number := 1; + Phase := Marking; + Visit_List (L, ""); + + Next_Serial_Number := 1; + Phase := Printing; + Visit_List (L, ""); + + Print_Term; + end Print_List_Subtree; + + ---------------- + -- Print_Name -- + ---------------- + + procedure Print_Name (N : Name_Id) is + begin + if Phase = Printing then + if N = No_Name then + Print_Str (""); + + elsif N = Error_Name then + Print_Str (""); + + elsif Is_Valid_Name (N) then + Get_Name_String (N); + Print_Char ('"'); + Write_Name (N); + Print_Char ('"'); + + else + Print_Str (""); + end if; + end if; + end Print_Name; + + ---------------- + -- Print_Node -- + ---------------- + + procedure Print_Node + (N : Node_Id; + Prefix_Str : String; + Prefix_Char : Character) + is + F : Fchar; + P : Natural := Pchar_Pos (Nkind (N)); + + Field_To_Be_Printed : Boolean; + Prefix_Str_Char : String (Prefix_Str'First .. Prefix_Str'Last + 1); + + Sfile : Source_File_Index; + Notes : Boolean; + Fmt : UI_Format; + + begin + if Phase /= Printing then + return; + end if; + + if Nkind (N) = N_Integer_Literal and then Print_In_Hex (N) then + Fmt := Hex; + else + Fmt := Auto; + end if; + + Prefix_Str_Char (Prefix_Str'Range) := Prefix_Str; + Prefix_Str_Char (Prefix_Str'Last + 1) := Prefix_Char; + + -- Print header line + + Print_Str (Prefix_Str); + Print_Node_Ref (N); + + Notes := False; + + if N > Atree_Private_Part.Nodes.Last then + Print_Str (" (no such node)"); + Print_Eol; + return; + end if; + + if Comes_From_Source (N) then + Notes := True; + Print_Str (" (source"); + end if; + + if Analyzed (N) then + if not Notes then + Notes := True; + Print_Str (" ("); + else + Print_Str (","); + end if; + + Print_Str ("analyzed"); + end if; + + if Error_Posted (N) then + if not Notes then + Notes := True; + Print_Str (" ("); + else + Print_Str (","); + end if; + + Print_Str ("posted"); + end if; + + if Notes then + Print_Char (')'); + end if; + + Print_Eol; + + if Is_Rewrite_Substitution (N) then + Print_Str (Prefix_Str); + Print_Str (" Rewritten: original node = "); + Print_Node_Ref (Original_Node (N)); + Print_Eol; + end if; + + if N = Empty then + return; + end if; + + if not Is_List_Member (N) then + Print_Str (Prefix_Str); + Print_Str (" Parent = "); + Print_Node_Ref (Parent (N)); + Print_Eol; + end if; + + -- Print Sloc field if it is set + + if Sloc (N) /= No_Location then + Print_Str (Prefix_Str_Char); + Print_Str ("Sloc = "); + + if Sloc (N) = Standard_Location then + Print_Str ("Standard_Location"); + + elsif Sloc (N) = Standard_ASCII_Location then + Print_Str ("Standard_ASCII_Location"); + + else + Sfile := Get_Source_File_Index (Sloc (N)); + Print_Int (Int (Sloc (N)) - Int (Source_Text (Sfile)'First)); + Write_Str (" "); + Write_Location (Sloc (N)); + end if; + + Print_Eol; + end if; + + -- Print Chars field if present + + if Nkind (N) in N_Has_Chars and then Chars (N) /= No_Name then + Print_Str (Prefix_Str_Char); + Print_Str ("Chars = "); + Print_Name (Chars (N)); + Write_Str (" (Name_Id="); + Write_Int (Int (Chars (N))); + Write_Char (')'); + Print_Eol; + end if; + + -- Special field print operations for non-entity nodes + + if Nkind (N) not in N_Entity then + + -- Deal with Left_Opnd and Right_Opnd fields + + if Nkind (N) in N_Op + or else Nkind (N) in N_Short_Circuit + or else Nkind (N) in N_Membership_Test + then + -- Print Left_Opnd if present + + if Nkind (N) not in N_Unary_Op then + Print_Str (Prefix_Str_Char); + Print_Str ("Left_Opnd = "); + Print_Node_Ref (Left_Opnd (N)); + Print_Eol; + end if; + + -- Print Right_Opnd + + Print_Str (Prefix_Str_Char); + Print_Str ("Right_Opnd = "); + Print_Node_Ref (Right_Opnd (N)); + Print_Eol; + end if; + + -- Print Entity field if operator (other cases of Entity + -- are in the table, so are handled in the normal circuit) + + if Nkind (N) in N_Op and then Present (Entity (N)) then + Print_Str (Prefix_Str_Char); + Print_Str ("Entity = "); + Print_Node_Ref (Entity (N)); + Print_Eol; + end if; + + -- Print special fields if we have a subexpression + + if Nkind (N) in N_Subexpr then + + if Assignment_OK (N) then + Print_Str (Prefix_Str_Char); + Print_Str ("Assignment_OK = True"); + Print_Eol; + end if; + + if Do_Range_Check (N) then + Print_Str (Prefix_Str_Char); + Print_Str ("Do_Range_Check = True"); + Print_Eol; + end if; + + if Has_Dynamic_Length_Check (N) then + Print_Str (Prefix_Str_Char); + Print_Str ("Has_Dynamic_Length_Check = True"); + Print_Eol; + end if; + + if Has_Aspects (N) then + Print_Str (Prefix_Str_Char); + Print_Str ("Has_Aspects = True"); + Print_Eol; + end if; + + if Has_Dynamic_Range_Check (N) then + Print_Str (Prefix_Str_Char); + Print_Str ("Has_Dynamic_Range_Check = True"); + Print_Eol; + end if; + + if Is_Controlling_Actual (N) then + Print_Str (Prefix_Str_Char); + Print_Str ("Is_Controlling_Actual = True"); + Print_Eol; + end if; + + if Is_Overloaded (N) then + Print_Str (Prefix_Str_Char); + Print_Str ("Is_Overloaded = True"); + Print_Eol; + end if; + + if Is_Static_Expression (N) then + Print_Str (Prefix_Str_Char); + Print_Str ("Is_Static_Expression = True"); + Print_Eol; + end if; + + if Must_Not_Freeze (N) then + Print_Str (Prefix_Str_Char); + Print_Str ("Must_Not_Freeze = True"); + Print_Eol; + end if; + + if Paren_Count (N) /= 0 then + Print_Str (Prefix_Str_Char); + Print_Str ("Paren_Count = "); + Print_Int (Int (Paren_Count (N))); + Print_Eol; + end if; + + if Raises_Constraint_Error (N) then + Print_Str (Prefix_Str_Char); + Print_Str ("Raise_Constraint_Error = True"); + Print_Eol; + end if; + + end if; + + -- Print Do_Overflow_Check field if present + + if Nkind (N) in N_Op and then Do_Overflow_Check (N) then + Print_Str (Prefix_Str_Char); + Print_Str ("Do_Overflow_Check = True"); + Print_Eol; + end if; + + -- Print Etype field if present (printing of this field for entities + -- is handled by the Print_Entity_Info procedure). + + if Nkind (N) in N_Has_Etype and then Present (Etype (N)) then + Print_Str (Prefix_Str_Char); + Print_Str ("Etype = "); + Print_Node_Ref (Etype (N)); + Print_Eol; + end if; + end if; + + -- Loop to print fields included in Pchars array + + while P < Pchar_Pos (Node_Kind'Succ (Nkind (N))) loop + F := Pchars (P); + P := P + 1; + + -- Check for case of False flag, which we never print, or + -- an Empty field, which is also never printed + + case F is + when F_Field1 => + Field_To_Be_Printed := Field1 (N) /= Union_Id (Empty); + + when F_Field2 => + Field_To_Be_Printed := Field2 (N) /= Union_Id (Empty); + + when F_Field3 => + Field_To_Be_Printed := Field3 (N) /= Union_Id (Empty); + + when F_Field4 => + Field_To_Be_Printed := Field4 (N) /= Union_Id (Empty); + + when F_Field5 => + Field_To_Be_Printed := Field5 (N) /= Union_Id (Empty); + + -- Flag3 is obsolete, so this probably gets removed ??? + + when F_Flag3 => Field_To_Be_Printed := Has_Aspects (N); + + when F_Flag4 => Field_To_Be_Printed := Flag4 (N); + when F_Flag5 => Field_To_Be_Printed := Flag5 (N); + when F_Flag6 => Field_To_Be_Printed := Flag6 (N); + when F_Flag7 => Field_To_Be_Printed := Flag7 (N); + when F_Flag8 => Field_To_Be_Printed := Flag8 (N); + when F_Flag9 => Field_To_Be_Printed := Flag9 (N); + when F_Flag10 => Field_To_Be_Printed := Flag10 (N); + when F_Flag11 => Field_To_Be_Printed := Flag11 (N); + when F_Flag12 => Field_To_Be_Printed := Flag12 (N); + when F_Flag13 => Field_To_Be_Printed := Flag13 (N); + when F_Flag14 => Field_To_Be_Printed := Flag14 (N); + when F_Flag15 => Field_To_Be_Printed := Flag15 (N); + when F_Flag16 => Field_To_Be_Printed := Flag16 (N); + when F_Flag17 => Field_To_Be_Printed := Flag17 (N); + when F_Flag18 => Field_To_Be_Printed := Flag18 (N); + + -- Flag1,2 are no longer used + + when F_Flag1 => raise Program_Error; + when F_Flag2 => raise Program_Error; + end case; + + -- Print field if it is to be printed + + if Field_To_Be_Printed then + Print_Str (Prefix_Str_Char); + + while P < Pchar_Pos (Node_Kind'Succ (Nkind (N))) + and then Pchars (P) not in Fchar + loop + Print_Char (Pchars (P)); + P := P + 1; + end loop; + + Print_Str (" = "); + + case F is + when F_Field1 => Print_Field (Field1 (N), Fmt); + when F_Field2 => Print_Field (Field2 (N), Fmt); + when F_Field3 => Print_Field (Field3 (N), Fmt); + when F_Field4 => Print_Field (Field4 (N), Fmt); + + -- Special case End_Span = Uint5 + + when F_Field5 => + if Nkind (N) = N_Case_Statement + or else Nkind (N) = N_If_Statement + then + Print_End_Span (N); + else + Print_Field (Field5 (N), Fmt); + end if; + + when F_Flag4 => Print_Flag (Flag4 (N)); + when F_Flag5 => Print_Flag (Flag5 (N)); + when F_Flag6 => Print_Flag (Flag6 (N)); + when F_Flag7 => Print_Flag (Flag7 (N)); + when F_Flag8 => Print_Flag (Flag8 (N)); + when F_Flag9 => Print_Flag (Flag9 (N)); + when F_Flag10 => Print_Flag (Flag10 (N)); + when F_Flag11 => Print_Flag (Flag11 (N)); + when F_Flag12 => Print_Flag (Flag12 (N)); + when F_Flag13 => Print_Flag (Flag13 (N)); + when F_Flag14 => Print_Flag (Flag14 (N)); + when F_Flag15 => Print_Flag (Flag15 (N)); + when F_Flag16 => Print_Flag (Flag16 (N)); + when F_Flag17 => Print_Flag (Flag17 (N)); + when F_Flag18 => Print_Flag (Flag18 (N)); + + -- Flag1,2 are no longer used + + when F_Flag1 => raise Program_Error; + when F_Flag2 => raise Program_Error; + + -- Not clear why we need the following ??? + + when F_Flag3 => Print_Flag (Has_Aspects (N)); + end case; + + Print_Eol; + + -- Field is not to be printed (False flag field) + + else + while P < Pchar_Pos (Node_Kind'Succ (Nkind (N))) + and then Pchars (P) not in Fchar + loop + P := P + 1; + end loop; + end if; + end loop; + + -- Print aspects if present + + if Has_Aspects (N) then + Print_Str (Prefix_Str_Char); + Print_Str ("Aspect_Specifications = "); + Print_Field (Union_Id (Aspect_Specifications (N))); + Print_Eol; + end if; + + -- Print entity information for entities + + if Nkind (N) in N_Entity then + Print_Entity_Info (N, Prefix_Str_Char); + end if; + + -- Print the SCIL node (if available) + + if Present (Get_SCIL_Node (N)) then + Print_Str (Prefix_Str_Char); + Print_Str ("SCIL_Node = "); + Print_Node_Ref (Get_SCIL_Node (N)); + Print_Eol; + end if; + end Print_Node; + + --------------------- + -- Print_Node_Kind -- + --------------------- + + procedure Print_Node_Kind (N : Node_Id) is + Ucase : Boolean; + S : constant String := Node_Kind'Image (Nkind (N)); + + begin + if Phase = Printing then + Ucase := True; + + -- Note: the call to Fold_Upper in this loop is to get past the GNAT + -- bug of 'Image returning lower case instead of upper case. + + for J in S'Range loop + if Ucase then + Write_Char (Fold_Upper (S (J))); + else + Write_Char (Fold_Lower (S (J))); + end if; + + Ucase := (S (J) = '_'); + end loop; + end if; + end Print_Node_Kind; + + -------------------- + -- Print_Node_Ref -- + -------------------- + + procedure Print_Node_Ref (N : Node_Id) is + S : Nat; + + begin + if Phase /= Printing then + return; + end if; + + if N = Empty then + Write_Str (""); + + elsif N = Error then + Write_Str (""); + + else + if Printing_Descendants then + S := Serial_Number (Int (N)); + + if S /= 0 then + Write_Str ("Node"); + Write_Str (" #"); + Write_Int (S); + Write_Char (' '); + end if; + end if; + + Print_Node_Kind (N); + + if Nkind (N) in N_Has_Chars then + Write_Char (' '); + Print_Name (Chars (N)); + end if; + + if Nkind (N) in N_Entity then + Write_Str (" (Entity_Id="); + else + Write_Str (" (Node_Id="); + end if; + + Write_Int (Int (N)); + + if Sloc (N) <= Standard_Location then + Write_Char ('s'); + end if; + + Write_Char (')'); + + end if; + end Print_Node_Ref; + + ------------------------ + -- Print_Node_Subtree -- + ------------------------ + + procedure Print_Node_Subtree (N : Node_Id) is + begin + Print_Init; + + Next_Serial_Number := 1; + Phase := Marking; + Visit_Node (N, "", ' '); + + Next_Serial_Number := 1; + Phase := Printing; + Visit_Node (N, "", ' '); + + Print_Term; + end Print_Node_Subtree; + + --------------- + -- Print_Str -- + --------------- + + procedure Print_Str (S : String) is + begin + if Phase = Printing then + Write_Str (S); + end if; + end Print_Str; + + -------------------------- + -- Print_Str_Mixed_Case -- + -------------------------- + + procedure Print_Str_Mixed_Case (S : String) is + Ucase : Boolean; + + begin + if Phase = Printing then + Ucase := True; + + for J in S'Range loop + if Ucase then + Write_Char (S (J)); + else + Write_Char (Fold_Lower (S (J))); + end if; + + Ucase := (S (J) = '_'); + end loop; + end if; + end Print_Str_Mixed_Case; + + ---------------- + -- Print_Term -- + ---------------- + + procedure Print_Term is + procedure Free is new Unchecked_Deallocation + (Hash_Table_Type, Access_Hash_Table_Type); + + begin + Free (Hash_Table); + end Print_Term; + + --------------------- + -- Print_Tree_Elist -- + --------------------- + + procedure Print_Tree_Elist (E : Elist_Id) is + M : Elmt_Id; + + begin + Printing_Descendants := False; + Phase := Printing; + + Print_Elist_Ref (E); + Print_Eol; + + M := First_Elmt (E); + + if No (M) then + Print_Str (""); + Print_Eol; + + else + loop + Print_Char ('|'); + Print_Eol; + exit when No (Next_Elmt (M)); + Print_Node (Node (M), "", '|'); + Next_Elmt (M); + end loop; + + Print_Node (Node (M), "", ' '); + Print_Eol; + end if; + end Print_Tree_Elist; + + --------------------- + -- Print_Tree_List -- + --------------------- + + procedure Print_Tree_List (L : List_Id) is + N : Node_Id; + + begin + Printing_Descendants := False; + Phase := Printing; + + Print_List_Ref (L); + Print_Str (" List_Id="); + Print_Int (Int (L)); + Print_Eol; + + N := First (L); + + if N = Empty then + Print_Str (""); + Print_Eol; + + else + loop + Print_Char ('|'); + Print_Eol; + exit when Next (N) = Empty; + Print_Node (N, "", '|'); + Next (N); + end loop; + + Print_Node (N, "", ' '); + Print_Eol; + end if; + end Print_Tree_List; + + --------------------- + -- Print_Tree_Node -- + --------------------- + + procedure Print_Tree_Node (N : Node_Id; Label : String := "") is + begin + Printing_Descendants := False; + Phase := Printing; + Print_Node (N, Label, ' '); + end Print_Tree_Node; + + -------- + -- pt -- + -------- + + procedure pt (N : Node_Id) is + begin + Print_Node_Subtree (N); + end pt; + + ------------------- + -- Serial_Number -- + ------------------- + + -- The hashing algorithm is to use the remainder of the ID value divided + -- by the hash table length as the starting point in the table, and then + -- handle collisions by serial searching wrapping at the end of the table. + + Hash_Slot : Nat; + -- Set by an unsuccessful call to Serial_Number (one which returns zero) + -- to save the slot that should be used if Set_Serial_Number is called. + + function Serial_Number (Id : Int) return Nat is + H : Int := Id mod Hash_Table_Len; + + begin + while Hash_Table (H).Serial /= 0 loop + + if Id = Hash_Table (H).Id then + return Hash_Table (H).Serial; + end if; + + H := H + 1; + + if H > Hash_Table'Last then + H := 0; + end if; + end loop; + + -- Entry was not found, save slot number for possible subsequent call + -- to Set_Serial_Number, and unconditionally save the Id in this slot + -- in case of such a call (the Id field is never read if the serial + -- number of the slot is zero, so this is harmless in the case where + -- Set_Serial_Number is not subsequently called). + + Hash_Slot := H; + Hash_Table (H).Id := Id; + return 0; + + end Serial_Number; + + ----------------------- + -- Set_Serial_Number -- + ----------------------- + + procedure Set_Serial_Number is + begin + Hash_Table (Hash_Slot).Serial := Next_Serial_Number; + Next_Serial_Number := Next_Serial_Number + 1; + end Set_Serial_Number; + + --------------- + -- Tree_Dump -- + --------------- + + procedure Tree_Dump is + procedure Underline; + -- Put underline under string we just printed + + procedure Underline is + Col : constant Int := Column; + + begin + Write_Eol; + + while Col > Column loop + Write_Char ('-'); + end loop; + + Write_Eol; + end Underline; + + -- Start of processing for Tree_Dump. Note that we turn off the tree dump + -- flags immediately, before starting the dump. This avoids generating two + -- copies of the dump if an abort occurs after printing the dump, and more + -- importantly, avoids an infinite loop if an abort occurs during the dump. + + -- Note: unlike in the source print case (in Sprint), we do not output + -- separate trees for each unit. Instead the -df debug switch causes the + -- tree that is output from the main unit to trace references into other + -- units (normally such references are not traced). Since all other units + -- are linked to the main unit by at least one reference, this causes all + -- tree nodes to be included in the output tree. + + begin + if Debug_Flag_Y then + Debug_Flag_Y := False; + Write_Eol; + Write_Str ("Tree created for Standard (spec) "); + Underline; + Print_Node_Subtree (Standard_Package_Node); + Write_Eol; + end if; + + if Debug_Flag_T then + Debug_Flag_T := False; + + Write_Eol; + Write_Str ("Tree created for "); + Write_Unit_Name (Unit_Name (Main_Unit)); + Underline; + Print_Node_Subtree (Cunit (Main_Unit)); + Write_Eol; + end if; + + end Tree_Dump; + + ----------------- + -- Visit_Elist -- + ----------------- + + procedure Visit_Elist (E : Elist_Id; Prefix_Str : String) is + M : Elmt_Id; + N : Node_Id; + S : constant Nat := Serial_Number (Int (E)); + + begin + -- In marking phase, return if already marked, otherwise set next + -- serial number in hash table for later reference. + + if Phase = Marking then + if S /= 0 then + return; -- already visited + else + Set_Serial_Number; + end if; + + -- In printing phase, if already printed, then return, otherwise we + -- are printing the next item, so increment the serial number. + + else + if S < Next_Serial_Number then + return; -- already printed + else + Next_Serial_Number := Next_Serial_Number + 1; + end if; + end if; + + -- Now process the list (Print calls have no effect in marking phase) + + Print_Str (Prefix_Str); + Print_Elist_Ref (E); + Print_Eol; + + if Is_Empty_Elmt_List (E) then + Print_Str (Prefix_Str); + Print_Str ("(Empty element list)"); + Print_Eol; + Print_Eol; + + else + if Phase = Printing then + M := First_Elmt (E); + while Present (M) loop + N := Node (M); + Print_Str (Prefix_Str); + Print_Str (" "); + Print_Node_Ref (N); + Print_Eol; + Next_Elmt (M); + end loop; + + Print_Str (Prefix_Str); + Print_Eol; + end if; + + M := First_Elmt (E); + while Present (M) loop + Visit_Node (Node (M), Prefix_Str, ' '); + Next_Elmt (M); + end loop; + end if; + end Visit_Elist; + + ---------------- + -- Visit_List -- + ---------------- + + procedure Visit_List (L : List_Id; Prefix_Str : String) is + N : Node_Id; + S : constant Nat := Serial_Number (Int (L)); + + begin + -- In marking phase, return if already marked, otherwise set next + -- serial number in hash table for later reference. + + if Phase = Marking then + if S /= 0 then + return; + else + Set_Serial_Number; + end if; + + -- In printing phase, if already printed, then return, otherwise we + -- are printing the next item, so increment the serial number. + + else + if S < Next_Serial_Number then + return; -- already printed + else + Next_Serial_Number := Next_Serial_Number + 1; + end if; + end if; + + -- Now process the list (Print calls have no effect in marking phase) + + Print_Str (Prefix_Str); + Print_List_Ref (L); + Print_Eol; + + Print_Str (Prefix_Str); + Print_Str ("|Parent = "); + Print_Node_Ref (Parent (L)); + Print_Eol; + + N := First (L); + + if N = Empty then + Print_Str (Prefix_Str); + Print_Str ("(Empty list)"); + Print_Eol; + Print_Eol; + + else + Print_Str (Prefix_Str); + Print_Char ('|'); + Print_Eol; + + while Next (N) /= Empty loop + Visit_Node (N, Prefix_Str, '|'); + Next (N); + end loop; + end if; + + Visit_Node (N, Prefix_Str, ' '); + end Visit_List; + + ---------------- + -- Visit_Node -- + ---------------- + + procedure Visit_Node + (N : Node_Id; + Prefix_Str : String; + Prefix_Char : Character) + is + New_Prefix : String (Prefix_Str'First .. Prefix_Str'Last + 2); + -- Prefix string for printing referenced fields + + procedure Visit_Descendent + (D : Union_Id; + No_Indent : Boolean := False); + -- This procedure tests the given value of one of the Fields referenced + -- by the current node to determine whether to visit it recursively. + -- Normally No_Indent is false, which means that the visited node will + -- be indented using New_Prefix. If No_Indent is set to True, then + -- this indentation is skipped, and Prefix_Str is used for the call + -- to print the descendent. No_Indent is effective only if the + -- referenced descendent is a node. + + ---------------------- + -- Visit_Descendent -- + ---------------------- + + procedure Visit_Descendent + (D : Union_Id; + No_Indent : Boolean := False) + is + begin + -- Case of descendent is a node + + if D in Node_Range then + + -- Don't bother about Empty or Error descendents + + if D <= Union_Id (Empty_Or_Error) then + return; + end if; + + declare + Nod : constant Node_Or_Entity_Id := Node_Or_Entity_Id (D); + + begin + -- Descendents in one of the standardly compiled internal + -- packages are normally ignored, unless the parent is also + -- in such a package (happens when Standard itself is output) + -- or if the -df switch is set which causes all links to be + -- followed, even into package standard. + + if Sloc (Nod) <= Standard_Location then + if Sloc (N) > Standard_Location + and then not Debug_Flag_F + then + return; + end if; + + -- Don't bother about a descendent in a different unit than + -- the node we came from unless the -df switch is set. Note + -- that we know at this point that Sloc (D) > Standard_Location + + -- Note: the tests for No_Location here just make sure that we + -- don't blow up on a node which is missing an Sloc value. This + -- should not normally happen. + + else + if (Sloc (N) <= Standard_Location + or else Sloc (N) = No_Location + or else Sloc (Nod) = No_Location + or else not In_Same_Source_Unit (Nod, N)) + and then not Debug_Flag_F + then + return; + end if; + end if; + + -- Don't bother visiting a source node that has a parent which + -- is not the node we came from. We prefer to trace such nodes + -- from their real parents. This causes the tree to be printed + -- in a more coherent order, e.g. a defining identifier listed + -- next to its corresponding declaration, instead of next to + -- some semantic reference. + + -- This test is skipped for nodes in standard packages unless + -- the -dy option is set (which outputs the tree for standard) + + -- Also, always follow pointers to Is_Itype entities, + -- since we want to list these when they are first referenced. + + if Parent (Nod) /= Empty + and then Comes_From_Source (Nod) + and then Parent (Nod) /= N + and then (Sloc (N) > Standard_Location or else Debug_Flag_Y) + then + return; + end if; + + -- If we successfully fall through all the above tests (which + -- execute a return if the node is not to be visited), we can + -- go ahead and visit the node! + + if No_Indent then + Visit_Node (Nod, Prefix_Str, Prefix_Char); + else + Visit_Node (Nod, New_Prefix, ' '); + end if; + end; + + -- Case of descendent is a list + + elsif D in List_Range then + + -- Don't bother with a missing list, empty list or error list + + if D = Union_Id (No_List) + or else D = Union_Id (Error_List) + or else Is_Empty_List (List_Id (D)) + then + return; + + -- Otherwise we can visit the list. Note that we don't bother + -- to do the parent test that we did for the node case, because + -- it just does not happen that lists are referenced more than + -- one place in the tree. We aren't counting on this being the + -- case to generate valid output, it is just that we don't need + -- in practice to worry about listing the list at a place that + -- is inconvenient. + + else + Visit_List (List_Id (D), New_Prefix); + end if; + + -- Case of descendent is an element list + + elsif D in Elist_Range then + + -- Don't bother with a missing list, or an empty list + + if D = Union_Id (No_Elist) + or else Is_Empty_Elmt_List (Elist_Id (D)) + then + return; + + -- Otherwise, visit the referenced element list + + else + Visit_Elist (Elist_Id (D), New_Prefix); + end if; + + -- For all other kinds of descendents (strings, names, uints etc), + -- there is nothing to visit (the contents of the field will be + -- printed when we print the containing node, but what concerns + -- us now is looking for descendents in the tree. + + else + null; + end if; + end Visit_Descendent; + + -- Start of processing for Visit_Node + + begin + if N = Empty then + return; + end if; + + -- Set fatal error node in case we get a blow up during the trace + + Current_Error_Node := N; + + New_Prefix (Prefix_Str'Range) := Prefix_Str; + New_Prefix (Prefix_Str'Last + 1) := Prefix_Char; + New_Prefix (Prefix_Str'Last + 2) := ' '; + + -- In the marking phase, all we do is to set the serial number + + if Phase = Marking then + if Serial_Number (Int (N)) /= 0 then + return; -- already visited + else + Set_Serial_Number; + end if; + + -- In the printing phase, we print the node + + else + if Serial_Number (Int (N)) < Next_Serial_Number then + + -- Here we have already visited the node, but if it is in + -- a list, we still want to print the reference, so that + -- it is clear that it belongs to the list. + + if Is_List_Member (N) then + Print_Str (Prefix_Str); + Print_Node_Ref (N); + Print_Eol; + Print_Str (Prefix_Str); + Print_Char (Prefix_Char); + Print_Str ("(already output)"); + Print_Eol; + Print_Str (Prefix_Str); + Print_Char (Prefix_Char); + Print_Eol; + end if; + + return; + + else + Print_Node (N, Prefix_Str, Prefix_Char); + Print_Str (Prefix_Str); + Print_Char (Prefix_Char); + Print_Eol; + Next_Serial_Number := Next_Serial_Number + 1; + end if; + end if; + + -- Visit all descendents of this node + + if Nkind (N) not in N_Entity then + Visit_Descendent (Field1 (N)); + Visit_Descendent (Field2 (N)); + Visit_Descendent (Field3 (N)); + Visit_Descendent (Field4 (N)); + Visit_Descendent (Field5 (N)); + + if Has_Aspects (N) then + Visit_Descendent (Union_Id (Aspect_Specifications (N))); + end if; + + -- Entity case + + else + Visit_Descendent (Field1 (N)); + Visit_Descendent (Field3 (N)); + Visit_Descendent (Field4 (N)); + Visit_Descendent (Field5 (N)); + Visit_Descendent (Field6 (N)); + Visit_Descendent (Field7 (N)); + Visit_Descendent (Field8 (N)); + Visit_Descendent (Field9 (N)); + Visit_Descendent (Field10 (N)); + Visit_Descendent (Field11 (N)); + Visit_Descendent (Field12 (N)); + Visit_Descendent (Field13 (N)); + Visit_Descendent (Field14 (N)); + Visit_Descendent (Field15 (N)); + Visit_Descendent (Field16 (N)); + Visit_Descendent (Field17 (N)); + Visit_Descendent (Field18 (N)); + Visit_Descendent (Field19 (N)); + Visit_Descendent (Field20 (N)); + Visit_Descendent (Field21 (N)); + Visit_Descendent (Field22 (N)); + Visit_Descendent (Field23 (N)); + + -- Now an interesting kludge. Normally parents are always printed + -- since we traverse the tree in a downwards direction. There is + -- however an exception to this rule, which is the case where a + -- parent is constructed by the compiler and is not referenced + -- elsewhere in the tree. The following catches this case + + if not Comes_From_Source (N) then + Visit_Descendent (Union_Id (Parent (N))); + end if; + + -- You may be wondering why we omitted Field2 above. The answer + -- is that this is the Next_Entity field, and we want to treat + -- it rather specially. Why? Because a Next_Entity link does not + -- correspond to a level deeper in the tree, and we do not want + -- the tree to march off to the right of the page due to bogus + -- indentations coming from this effect. + + -- To prevent this, what we do is to control references via + -- Next_Entity only from the first entity on a given scope + -- chain, and we keep them all at the same level. Of course + -- if an entity has already been referenced it is not printed. + + if Present (Next_Entity (N)) + and then Present (Scope (N)) + and then First_Entity (Scope (N)) = N + then + declare + Nod : Node_Id; + + begin + Nod := N; + while Present (Nod) loop + Visit_Descendent (Union_Id (Next_Entity (Nod))); + Nod := Next_Entity (Nod); + end loop; + end; + end if; + end if; + end Visit_Node; + +end Treepr; diff --git a/gcc/ada/treepr.ads b/gcc/ada/treepr.ads new file mode 100644 index 000000000..3d05748fd --- /dev/null +++ b/gcc/ada/treepr.ads @@ -0,0 +1,81 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T R E E P R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Types; use Types; +package Treepr is + +-- This package provides printing routines for the abstract syntax tree +-- These routines are intended only for debugging use. + + procedure Tree_Dump; + -- This routine is called from the GNAT main program to dump trees as + -- requested by debug options (including tree of Standard if requested). + + procedure Print_Tree_Node (N : Node_Id; Label : String := ""); + -- Prints a single tree node, without printing descendants. The Label + -- string is used to preface each line of the printed output. + + procedure Print_Tree_List (L : List_Id); + -- Prints a single node list, without printing the descendants of any + -- of the nodes in the list + + procedure Print_Tree_Elist (E : Elist_Id); + -- Prints a single node list, without printing the descendants of any + -- of the nodes in the list + + procedure Print_Node_Subtree (N : Node_Id); + -- Prints the subtree routed at a specified tree node, including all + -- referenced descendants. + + procedure Print_List_Subtree (L : List_Id); + -- Prints the subtree consisting of the given node list and all its + -- referenced descendants. + + procedure Print_Elist_Subtree (E : Elist_Id); + -- Prints the subtree consisting of the given element list and all its + -- referenced descendants. + + procedure pe (E : Elist_Id); + pragma Export (Ada, pe); + -- Debugging procedure (to be called within gdb), same as Print_Tree_Elist + + procedure pl (L : Int); + pragma Export (Ada, pl); + -- Debugging procedure (to be called within gdb), same as Print_Tree_List, + -- except that you can use e.g. 66 instead of -99999966. In other words + -- for the positive case we fill out to 8 digits on the left and add a + -- minus sign. This just saves some typing in the debugger. + + procedure pn (N : Node_Id); + pragma Export (Ada, pn); + -- Debugging procedure (to be called within gdb) + -- same as Print_Tree_Node with Label = "" + + procedure pt (N : Node_Id); + pragma Export (Ada, pt); + -- Debugging procedure (to be called within gdb) + -- same as Print_Node_Subtree + +end Treepr; diff --git a/gcc/ada/treeprs.adt b/gcc/ada/treeprs.adt new file mode 100644 index 000000000..8543fba70 --- /dev/null +++ b/gcc/ada/treeprs.adt @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T R E E P R S -- +-- -- +-- T e m p l a t e -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ +-- This file is a template used as input to the utility program XTreeprs, +-- which reads this template, and the spec of Sinfo (sinfo.ads) and generates +-- the spec for the Treeprs package (file treeprs.ads) + +-- This package contains the declaration of the string used by the Tree_Print +-- package. It must be updated whenever the arrangements of the field names +-- in package Sinfo is changed. The utility program XTREEPRS is used to +-- do this update correctly using the template treeprs.adt as input. + +with Sinfo; use Sinfo; + +package Treeprs is + + -------------------------------- + -- String Data for Node Print -- + -------------------------------- + + -- String data for print out. The Pchars array is a long string with the + -- the entry for each node type consisting of a single blank, followed by + -- a series of entries, one for each Op or Flag field used for the node. + -- Each entry has a single character which identifies the field, followed + -- by the synonym name. The starting location for a given node type is + -- found from the corresponding entry in the Pchars_Pos_Array. + + -- The following characters identify the field. These are characters which + -- could never occur in a field name, so they also mark the end of the + -- previous name. + + subtype Fchar is Character range '#' .. '9'; + + F_Field1 : constant Fchar := '#'; -- Character'Val (16#23#) + F_Field2 : constant Fchar := '$'; -- Character'Val (16#24#) + F_Field3 : constant Fchar := '%'; -- Character'Val (16#25#) + F_Field4 : constant Fchar := '&'; -- Character'Val (16#26#) + F_Field5 : constant Fchar := '''; -- Character'Val (16#27#) + F_Flag1 : constant Fchar := '('; -- Character'Val (16#28#) + F_Flag2 : constant Fchar := ')'; -- Character'Val (16#29#) + F_Flag3 : constant Fchar := '*'; -- Character'Val (16#2A#) + F_Flag4 : constant Fchar := '+'; -- Character'Val (16#2B#) + F_Flag5 : constant Fchar := ','; -- Character'Val (16#2C#) + F_Flag6 : constant Fchar := '-'; -- Character'Val (16#2D#) + F_Flag7 : constant Fchar := '.'; -- Character'Val (16#2E#) + F_Flag8 : constant Fchar := '/'; -- Character'Val (16#2F#) + F_Flag9 : constant Fchar := '0'; -- Character'Val (16#30#) + F_Flag10 : constant Fchar := '1'; -- Character'Val (16#31#) + F_Flag11 : constant Fchar := '2'; -- Character'Val (16#32#) + F_Flag12 : constant Fchar := '3'; -- Character'Val (16#33#) + F_Flag13 : constant Fchar := '4'; -- Character'Val (16#34#) + F_Flag14 : constant Fchar := '5'; -- Character'Val (16#35#) + F_Flag15 : constant Fchar := '6'; -- Character'Val (16#36#) + F_Flag16 : constant Fchar := '7'; -- Character'Val (16#37#) + F_Flag17 : constant Fchar := '8'; -- Character'Val (16#38#) + F_Flag18 : constant Fchar := '9'; -- Character'Val (16#39#) + + -- Note this table does not include entity field and flags whose access + -- functions are in Einfo (these are handled by the Print_Entity_Info + -- procedure in Treepr, which uses the routines in Einfo to get the proper + -- symbolic information). In addition, the following fields are handled by + -- Treepr, and do not appear in the Pchars array: + + -- Analyzed + -- Cannot_Be_Constant + -- Chars + -- Comes_From_Source + -- Error_Posted + -- Etype + -- Is_Controlling_Actual + -- Is_Overloaded + -- Is_Static_Expression + -- Left_Opnd + -- Must_Check_Expr + -- Must_Not_Freeze + -- No_Overflow_Expr + -- Paren_Count + -- Raises_Constraint_Error + -- Right_Opnd + +!!TEMPLATE INSERTION POINT + +end Treeprs; diff --git a/gcc/ada/ttypes.ads b/gcc/ada/ttypes.ads new file mode 100644 index 000000000..8b7749a50 --- /dev/null +++ b/gcc/ada/ttypes.ads @@ -0,0 +1,218 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T T Y P E 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains constants describing target properties + +with Types; use Types; +with Get_Targ; use Get_Targ; + +package Ttypes is + + ------------------------------ + -- Host/Target Dependencies -- + ------------------------------ + + -- It is vital to maintain a clear distinction between properties of + -- types on the host and types on the target, since in the general + -- case of a cross-compiler these will be different. + + -- This package and its companion Ttypef provide definitions of values + -- that describe the properties of the target types. All instances of + -- target dependencies, including the definitions of such packages as + -- Standard and System depend directly or indirectly on the definitions + -- in the Ttypes and Ttypef packages. + + -- In the source of the compiler, references to attributes such as + -- Integer'Size will give information regarding the host types (i.e. + -- the types within the compiler itself). Such references are therefore + -- almost always suspicious (it is hard for example to see that the + -- code in the compiler should even be using type Integer very much, + -- and certainly this code should not depend on the size of Integer). + + -- On the other hand, it is perfectly reasonable for the compiler to + -- require access to the size of type Integer for the target machine, + -- e.g. in constructing the internal representation of package Standard. + -- For this purpose, instead of referencing the attribute Integer'Size, + -- a reference to Ttypes.Standard_Integer_Size will provide the needed + -- value for the target type. + + -- Two approaches are used for handling target dependent values in the + -- standard library packages. Package Standard is handled specially, + -- being constructed internally (by package Stand). Target dependent + -- values needed in Stand are obtained by direct reference to Ttypes + -- and Ttypef. + + -- For package System, the required constant values are obtained by + -- referencing appropriate attributes. Ada 95 already defines most of + -- the required attributes, and GNAT specific attributes have been + -- defined to cover the remaining cases (such as Storage_Unit). The + -- evaluation of these attributes obtains the required target dependent + -- values from Ttypes and Ttypef. The additional attributes that have + -- been added to GNAT (Address_Size, Storage_Unit, Word_Size, Max_Priority, + -- and Max_Interrupt_Priority) are for almost all purposes redundant with + -- respect to the corresponding references to System constants. For example + -- in a program, System.Address_Size and Standard'Address_Size yield the + -- same value. The critical use of the attribute is in writing the System + -- declaration of Address_Size which of course cannot refer to itself. By + -- this means we achieve complete target independence in the source code + -- of package System, i.e. there is only one copy of the source of System + -- for all targets. + + -- Note that during compilation there are two versions of package System + -- around. The version that is directly with'ed by compiler packages + -- contains host-dependent definitions, which is what is needed in that + -- case (for example, System.Storage_Unit referenced in the source of the + -- compiler refers to the storage unit of the host, not the target). This + -- means that, like attribute references, any references to constants in + -- package System in the compiler code are suspicious, since it is strange + -- for the compiler to have such host dependencies. If the compiler needs + -- to access the target dependent values of such quantities as Storage_Unit + -- then it should reference the constants in this package (Ttypes), rather + -- than referencing System.Storage_Unit, or Standard'Storage_Unit, both of + -- which would yield the host value. + + --------------------------------------------------- + -- Target-Dependent Values for Types in Standard -- + --------------------------------------------------- + + -- Note: GNAT always supplies all the following integer and float types, + -- but depending on the machine, some of the types may be identical. For + -- example, on some machines, Short_Float may be the same as Float, and + -- Long_Long_Float may be the same as Long_Float. + + Standard_Short_Short_Integer_Size : constant Pos := Get_Char_Size; + Standard_Short_Short_Integer_Width : constant Pos := + Width_From_Size (Standard_Short_Short_Integer_Size); + + Standard_Short_Integer_Size : constant Pos := Get_Short_Size; + Standard_Short_Integer_Width : constant Pos := + Width_From_Size (Standard_Short_Integer_Size); + + Standard_Integer_Size : constant Pos := Get_Int_Size; + Standard_Integer_Width : constant Pos := + Width_From_Size (Standard_Integer_Size); + + Standard_Long_Integer_Size : constant Pos := Get_Long_Size; + Standard_Long_Integer_Width : constant Pos := + Width_From_Size (Standard_Long_Integer_Size); + + Standard_Long_Long_Integer_Size : constant Pos := Get_Long_Long_Size; + Standard_Long_Long_Integer_Width : constant Pos := + Width_From_Size (Standard_Long_Long_Integer_Size); + + Standard_Short_Float_Size : constant Pos := Get_Float_Size; + Standard_Short_Float_Digits : constant Pos := + Digits_From_Size (Standard_Short_Float_Size); + + Standard_Float_Size : constant Pos := Get_Float_Size; + Standard_Float_Digits : constant Pos := + Digits_From_Size (Standard_Float_Size); + + Standard_Long_Float_Size : constant Pos := Get_Double_Size; + Standard_Long_Float_Digits : constant Pos := + Digits_From_Size (Standard_Long_Float_Size); + + Standard_Long_Long_Float_Size : constant Pos := Get_Long_Double_Size; + Standard_Long_Long_Float_Digits : constant Pos := + Digits_From_Size (Standard_Long_Long_Float_Size); + + Standard_Character_Size : constant Pos := Get_Char_Size; + + Standard_Wide_Character_Size : constant Pos := 16; + Standard_Wide_Wide_Character_Size : constant Pos := 32; + -- Standard wide character sizes + + -- Note: there is no specific control over the representation of + -- enumeration types. The convention used is that if an enumeration + -- type has fewer than 2**(Character'Size) elements, then the size + -- used is Character'Size, otherwise Integer'Size is used. + + -- Similarly, the size of fixed-point types depends on the size of the + -- corresponding integer type, which is the smallest predefined integer + -- type capable of representing the required range of values. + + ------------------------------------------------- + -- Target-Dependent Values for Types in System -- + ------------------------------------------------- + + System_Address_Size : constant Pos := Get_Pointer_Size; + -- System.Address'Size (also size of all thin pointers) + + System_Max_Binary_Modulus_Power : constant Pos := + Standard_Long_Long_Integer_Size; + + System_Max_Nonbinary_Modulus_Power : constant Pos := Standard_Integer_Size; + + System_Storage_Unit : constant Pos := Get_Bits_Per_Unit; + System_Word_Size : constant Pos := Get_Bits_Per_Word; + + System_Tick_Nanoseconds : constant Pos := 1_000_000_000; + -- Value of System.Tick in nanoseconds. At the moment, this is a fixed + -- constant (with value of 1.0 seconds), but later we should add this + -- value to the GCC configuration file so that its value can be made + -- configuration dependent. + + ----------------------------------------------------- + -- Target-Dependent Values for Types in Interfaces -- + ----------------------------------------------------- + + Interfaces_Wchar_T_Size : constant Pos := Get_Wchar_T_Size; + + ---------------------------------------- + -- Other Target-Dependent Definitions -- + ---------------------------------------- + + Maximum_Alignment : constant Pos := Get_Maximum_Alignment; + -- The maximum alignment, in storage units, that an object or + -- type may require on the target machine. + + Max_Unaligned_Field : constant Pos := Get_Max_Unaligned_Field; + -- The maximum supported size in bits for a field that is not aligned + -- on a storage unit boundary. + + Bytes_Big_Endian : Boolean := Get_Bytes_BE /= 0; + -- Important note: for Ada purposes, the important setting is the bytes + -- endianness (Bytes_Big_Endian), not the bits value (Bits_Big_Endian). + -- This is because Ada bit addressing must be compatible with the byte + -- ordering (otherwise we would end up with non-contiguous fields). It + -- is rare for the two to be different, but if they are, Bits_Big_Endian + -- is relevant only for the generation of instructions with bit numbers, + -- and thus relevant only to the back end. Note that this is a variable + -- rather than a constant, since it can be modified (flipped) by -gnatd8. + + Target_Strict_Alignment : Boolean := Get_Strict_Alignment /= 0; + -- True if instructions will fail if data is misaligned + + Target_Double_Float_Alignment : Nat := Get_Double_Float_Alignment; + -- The default alignment of "double" floating-point types, i.e. floating + -- point types whose size is equal to 64 bits, or 0 if this alignment is + -- not specifically capped. + + Target_Double_Scalar_Alignment : Nat := Get_Double_Scalar_Alignment; + -- The default alignment of "double" or larger scalar types, i.e. scalar + -- types whose size is greater or equal to 64 bits, or 0 if this alignment + -- is not specifically capped. + +end Ttypes; diff --git a/gcc/ada/types.adb b/gcc/ada/types.adb new file mode 100644 index 000000000..bcb1922ad --- /dev/null +++ b/gcc/ada/types.adb @@ -0,0 +1,249 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T Y P 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. -- +-- -- +------------------------------------------------------------------------------ + +package body Types is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function V (T : Time_Stamp_Type; X : Time_Stamp_Index) return Nat; + -- Extract two decimal digit value from time stamp + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Time_Stamp_Type) return Boolean is + begin + return not (Left = Right) and then String (Left) < String (Right); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" (Left, Right : Time_Stamp_Type) return Boolean is + begin + return not (Left > Right); + end "<="; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Time_Stamp_Type) return Boolean is + Sleft : Nat; + Sright : Nat; + + begin + if String (Left) = String (Right) then + return True; + + elsif Left (1) = ' ' or else Right (1) = ' ' then + return False; + end if; + + -- In the following code we check for a difference of 2 seconds or less + + -- Recall that the time stamp format is: + + -- Y Y Y Y M M D D H H M M S S + -- 01 02 03 04 05 06 07 08 09 10 11 12 13 14 + + -- Note that we do not bother to worry about shifts in the day. + -- It seems unlikely that such shifts could ever occur in practice + -- and even if they do we err on the safe side, i.e., we say that the + -- time stamps are different. + + Sright := V (Right, 13) + 60 * (V (Right, 11) + 60 * V (Right, 09)); + Sleft := V (Left, 13) + 60 * (V (Left, 11) + 60 * V (Left, 09)); + + -- So the check is: dates must be the same, times differ 2 sec at most + + return abs (Sleft - Sright) <= 2 + and then String (Left (1 .. 8)) = String (Right (1 .. 8)); + end "="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Time_Stamp_Type) return Boolean is + begin + return not (Left = Right) and then String (Left) > String (Right); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" (Left, Right : Time_Stamp_Type) return Boolean is + begin + return not (Left < Right); + end ">="; + + ------------------- + -- Get_Char_Code -- + ------------------- + + function Get_Char_Code (C : Character) return Char_Code is + begin + return Char_Code'Val (Character'Pos (C)); + end Get_Char_Code; + + ------------------- + -- Get_Character -- + ------------------- + + function Get_Character (C : Char_Code) return Character is + begin + pragma Assert (C <= 255); + return Character'Val (C); + end Get_Character; + + -------------------- + -- Get_Hex_String -- + -------------------- + + subtype Wordh is Word range 0 .. 15; + Hex : constant array (Wordh) of Character := "0123456789abcdef"; + + function Get_Hex_String (W : Word) return Word_Hex_String is + X : Word := W; + WS : Word_Hex_String; + + begin + for J in reverse 1 .. 8 loop + WS (J) := Hex (X mod 16); + X := X / 16; + end loop; + + return WS; + end Get_Hex_String; + + ------------------------ + -- Get_Wide_Character -- + ------------------------ + + function Get_Wide_Character (C : Char_Code) return Wide_Character is + begin + pragma Assert (C <= 65535); + return Wide_Character'Val (C); + end Get_Wide_Character; + + ------------------------ + -- In_Character_Range -- + ------------------------ + + function In_Character_Range (C : Char_Code) return Boolean is + begin + return (C <= 255); + end In_Character_Range; + + ----------------------------- + -- In_Wide_Character_Range -- + ----------------------------- + + function In_Wide_Character_Range (C : Char_Code) return Boolean is + begin + return (C <= 65535); + end In_Wide_Character_Range; + + --------------------- + -- Make_Time_Stamp -- + --------------------- + + procedure Make_Time_Stamp + (Year : Nat; + Month : Nat; + Day : Nat; + Hour : Nat; + Minutes : Nat; + Seconds : Nat; + TS : out Time_Stamp_Type) + is + Z : constant := Character'Pos ('0'); + + begin + TS (01) := Character'Val (Z + Year / 1000); + TS (02) := Character'Val (Z + (Year / 100) mod 10); + TS (03) := Character'Val (Z + (Year / 10) mod 10); + TS (04) := Character'Val (Z + Year mod 10); + TS (05) := Character'Val (Z + Month / 10); + TS (06) := Character'Val (Z + Month mod 10); + TS (07) := Character'Val (Z + Day / 10); + TS (08) := Character'Val (Z + Day mod 10); + TS (09) := Character'Val (Z + Hour / 10); + TS (10) := Character'Val (Z + Hour mod 10); + TS (11) := Character'Val (Z + Minutes / 10); + TS (12) := Character'Val (Z + Minutes mod 10); + TS (13) := Character'Val (Z + Seconds / 10); + TS (14) := Character'Val (Z + Seconds mod 10); + end Make_Time_Stamp; + + ---------------------- + -- Split_Time_Stamp -- + ---------------------- + + procedure Split_Time_Stamp + (TS : Time_Stamp_Type; + Year : out Nat; + Month : out Nat; + Day : out Nat; + Hour : out Nat; + Minutes : out Nat; + Seconds : out Nat) + is + + begin + -- Y Y Y Y M M D D H H M M S S + -- 01 02 03 04 05 06 07 08 09 10 11 12 13 14 + + Year := 100 * V (TS, 01) + V (TS, 03); + Month := V (TS, 05); + Day := V (TS, 07); + Hour := V (TS, 09); + Minutes := V (TS, 11); + Seconds := V (TS, 13); + end Split_Time_Stamp; + + ------- + -- V -- + ------- + + function V (T : Time_Stamp_Type; X : Time_Stamp_Index) return Nat is + begin + return 10 * (Character'Pos (T (X)) - Character'Pos ('0')) + + Character'Pos (T (X + 1)) - Character'Pos ('0'); + end V; + +end Types; diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads new file mode 100644 index 000000000..ee2966c86 --- /dev/null +++ b/gcc/ada/types.ads @@ -0,0 +1,823 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T Y P E S -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains host independent type definitions which are used +-- in more than one unit in the compiler. They are gathered here for easy +-- reference, although in some cases the full description is found in the +-- relevant module which implements the definition. The main reason that they +-- are not in their "natural" specs is that this would cause a lot of inter- +-- spec dependencies, and in particular some awkward circular dependencies +-- would have to be dealt with. + +-- WARNING: There is a C version of this package. Any changes to this source +-- file must be properly reflected in the C header file types.h declarations. + +-- Note: the declarations in this package reflect an expectation that the host +-- machine has an efficient integer base type with a range at least 32 bits +-- 2s-complement. If there are any machines for which this is not a correct +-- assumption, a significant number of changes will be required! + +with System; +with Unchecked_Conversion; +with Unchecked_Deallocation; + +package Types is + pragma Preelaborate; + + ------------------------------- + -- General Use Integer Types -- + ------------------------------- + + type Int is range -2 ** 31 .. +2 ** 31 - 1; + -- Signed 32-bit integer + + subtype Nat is Int range 0 .. Int'Last; + -- Non-negative Int values + + subtype Pos is Int range 1 .. Int'Last; + -- Positive Int values + + type Word is mod 2 ** 32; + -- Unsigned 32-bit integer + + type Short is range -32768 .. +32767; + for Short'Size use 16; + -- 16-bit signed integer + + type Byte is mod 2 ** 8; + for Byte'Size use 8; + -- 8-bit unsigned integer + + type size_t is mod 2 ** Standard'Address_Size; + -- Memory size value, for use in calls to C routines + + -------------------------------------- + -- 8-Bit Character and String Types -- + -------------------------------------- + + -- We use Standard.Character and Standard.String freely, since we are + -- compiling ourselves, and we properly implement the required 8-bit + -- character code as required in Ada 95. This section defines a few + -- general use constants and subtypes. + + EOF : constant Character := ASCII.SUB; + -- The character SUB (16#1A#) is used in DOS and other systems derived + -- from DOS (XP, NT etc) to signal the end of a text file. Internally + -- all source files are ended by an EOF character, even on Unix systems. + -- An EOF character acts as the end of file only as the last character + -- of a source buffer, in any other position, it is treated as a blank + -- if it appears between tokens, and as an illegal character otherwise. + -- This makes life easier dealing with files that originated from DOS, + -- including concatenated files with interspersed EOF characters. + + subtype Graphic_Character is Character range ' ' .. '~'; + -- Graphic characters, as defined in ARM + + subtype Line_Terminator is Character range ASCII.LF .. ASCII.CR; + -- Line terminator characters (LF, VT, FF, CR) + -- + -- This definition is dubious now that we have two more wide character + -- sequences that constitute a line terminator. Every reference to this + -- subtype needs checking to make sure the wide character case is handled + -- appropriately. ??? + + subtype Upper_Half_Character is + Character range Character'Val (16#80#) .. Character'Val (16#FF#); + -- Characters with the upper bit set + + type Character_Ptr is access all Character; + type String_Ptr is access all String; + -- Standard character and string pointers + + procedure Free is new Unchecked_Deallocation (String, String_Ptr); + -- Procedure for freeing dynamically allocated String values + + subtype Big_String is String (Positive); + type Big_String_Ptr is access all Big_String; + -- Virtual type for handling imported big strings. Note that we should + -- never have any allocators for this type, but we don't give a storage + -- size of zero, since there are legitimate deallocations going on. + + function To_Big_String_Ptr is + new Unchecked_Conversion (System.Address, Big_String_Ptr); + -- Used to obtain Big_String_Ptr values from external addresses + + subtype Word_Hex_String is String (1 .. 8); + -- Type used to represent Word value as 8 hex digits, with lower case + -- letters for the alphabetic cases. + + function Get_Hex_String (W : Word) return Word_Hex_String; + -- Convert word value to 8-character hex string + + ----------------------------------------- + -- Types Used for Text Buffer Handling -- + ----------------------------------------- + + -- We can not use type String for text buffers, since we must use the + -- standard 32-bit integer as an index value, since we count on all index + -- values being the same size. + + type Text_Ptr is new Int; + -- Type used for subscripts in text buffer + + type Text_Buffer is array (Text_Ptr range <>) of Character; + -- Text buffer used to hold source file or library information file + + type Text_Buffer_Ptr is access all Text_Buffer; + -- Text buffers for input files are allocated dynamically and this type + -- is used to reference these text buffers. + + procedure Free is new Unchecked_Deallocation (Text_Buffer, Text_Buffer_Ptr); + -- Procedure for freeing dynamically allocated text buffers + + ------------------------------------------ + -- Types Used for Source Input Handling -- + ------------------------------------------ + + type Logical_Line_Number is range 0 .. Int'Last; + for Logical_Line_Number'Size use 32; + -- Line number type, used for storing logical line numbers (i.e. line + -- numbers that include effects of any Source_Reference pragmas in the + -- source file). The value zero indicates a line containing a source + -- reference pragma. + + No_Line_Number : constant Logical_Line_Number := 0; + -- Special value used to indicate no line number + + type Physical_Line_Number is range 1 .. Int'Last; + for Physical_Line_Number'Size use 32; + -- Line number type, used for storing physical line numbers (i.e. line + -- numbers in the physical file being compiled, unaffected by the presence + -- of source reference pragmas. + + type Column_Number is range 0 .. 32767; + for Column_Number'Size use 16; + -- Column number (assume that 2**15 - 1 is large enough). The range for + -- this type is used to compute Hostparm.Max_Line_Length. See also the + -- processing for -gnatyM in Stylesw). + + No_Column_Number : constant Column_Number := 0; + -- Special value used to indicate no column number + + subtype Source_Buffer is Text_Buffer; + -- Type used to store text of a source file . The buffer for the main + -- source (the source specified on the command line) has a lower bound + -- starting at zero. Subsequent subsidiary sources have lower bounds + -- which are one greater than the previous upper bound. + + subtype Big_Source_Buffer is Text_Buffer (0 .. Text_Ptr'Last); + -- This is a virtual type used as the designated type of the access type + -- Source_Buffer_Ptr, see Osint.Read_Source_File for details. + + type Source_Buffer_Ptr is access all Big_Source_Buffer; + -- Pointer to source buffer. We use virtual origin addressing for source + -- buffers, with thin pointers. The pointer points to a virtual instance + -- of type Big_Source_Buffer, where the actual type is in fact of type + -- Source_Buffer. The address is adjusted so that the virtual origin + -- addressing works correctly. See Osint.Read_Source_Buffer for further + -- details. Again, as for Big_String_Ptr, we should never allocate using + -- this type, but we don't give a storage size clause of zero, since we + -- may end up doing deallocations of instances allocated manually. + + subtype Source_Ptr is Text_Ptr; + -- Type used to represent a source location, which is a subscript of a + -- character in the source buffer. As noted above, different source buffers + -- have different ranges, so it is possible to tell from a Source_Ptr value + -- which source it refers to. Note that negative numbers are allowed to + -- accommodate the following special values. + + No_Location : constant Source_Ptr := -1; + -- Value used to indicate no source position set in a node. A test for a + -- Source_Ptr value being > No_Location is the approved way to test for a + -- standard value that does not include No_Location or any of the following + -- special definitions. One important use of No_Location is to label + -- generated nodes that we don't want the debugger to see in normal mode + -- (very often we conditionalize so that we set No_Location in normal mode + -- and the corresponding source line in -gnatD mode). + + Standard_Location : constant Source_Ptr := -2; + -- Used for all nodes in the representation of package Standard other than + -- nodes representing the contents of Standard.ASCII. Note that testing for + -- a value being <= Standard_Location tests for both Standard_Location and + -- for Standard_ASCII_Location. + + Standard_ASCII_Location : constant Source_Ptr := -3; + -- Used for all nodes in the presentation of package Standard.ASCII + + System_Location : constant Source_Ptr := -4; + -- Used to identify locations of pragmas scanned by Targparm, where we know + -- the location is in System, but we don't know exactly what line. + + First_Source_Ptr : constant Source_Ptr := 0; + -- Starting source pointer index value for first source program + + ------------------------------------- + -- Range Definitions for Tree Data -- + ------------------------------------- + + -- The tree has fields that can hold any of the following types: + + -- Pointers to other tree nodes (type Node_Id) + -- List pointers (type List_Id) + -- Element list pointers (type Elist_Id) + -- Names (type Name_Id) + -- Strings (type String_Id) + -- Universal integers (type Uint) + -- Universal reals (type Ureal) + + -- In most contexts, the strongly typed interface determines which of these + -- types is present. However, there are some situations (involving untyped + -- traversals of the tree), where it is convenient to be easily able to + -- distinguish these values. The underlying representation in all cases is + -- an integer type Union_Id, and we ensure that the range of the various + -- possible values for each of the above types is disjoint so that this + -- distinction is possible. + + type Union_Id is new Int; + -- The type in the tree for a union of possible ID values + + -- Note: it is also helpful for debugging purposes to make these ranges + -- distinct. If a bug leads to misidentification of a value, then it will + -- typically result in an out of range value and a Constraint_Error. + + List_Low_Bound : constant := -100_000_000; + -- The List_Id values are subscripts into an array of list headers which + -- has List_Low_Bound as its lower bound. This value is chosen so that all + -- List_Id values are negative, and the value zero is in the range of both + -- List_Id and Node_Id values (see further description below). + + List_High_Bound : constant := 0; + -- Maximum List_Id subscript value. This allows up to 100 million list Id + -- values, which is in practice infinite, and there is no need to check the + -- range. The range overlaps the node range by one element (with value + -- zero), which is used both for the Empty node, and for indicating no + -- list. The fact that the same value is used is convenient because it + -- means that the default value of Empty applies to both nodes and lists, + -- and also is more efficient to test for. + + Node_Low_Bound : constant := 0; + -- The tree Id values start at zero, because we use zero for Empty (to + -- allow a zero test for Empty). Actual tree node subscripts start at 0 + -- since Empty is a legitimate node value. + + Node_High_Bound : constant := 099_999_999; + -- Maximum number of nodes that can be allocated is 100 million, which + -- is in practice infinite, and there is no need to check the range. + + Elist_Low_Bound : constant := 100_000_000; + -- The Elist_Id values are subscripts into an array of elist headers which + -- has Elist_Low_Bound as its lower bound. + + Elist_High_Bound : constant := 199_999_999; + -- Maximum Elist_Id subscript value. This allows up to 100 million Elists, + -- which is in practice infinite and there is no need to check the range. + + Elmt_Low_Bound : constant := 200_000_000; + -- Low bound of element Id values. The use of these values is internal to + -- the Elists package, but the definition of the range is included here + -- since it must be disjoint from other Id values. The Elmt_Id values are + -- subscripts into an array of list elements which has this as lower bound. + + Elmt_High_Bound : constant := 299_999_999; + -- Upper bound of Elmt_Id values. This allows up to 100 million element + -- list members, which is in practice infinite (no range check needed). + + Names_Low_Bound : constant := 300_000_000; + -- Low bound for name Id values + + Names_High_Bound : constant := 399_999_999; + -- Maximum number of names that can be allocated is 100 million, which is + -- in practice infinite and there is no need to check the range. + + Strings_Low_Bound : constant := 400_000_000; + -- Low bound for string Id values + + Strings_High_Bound : constant := 499_999_999; + -- Maximum number of strings that can be allocated is 100 million, which + -- is in practice infinite and there is no need to check the range. + + Ureal_Low_Bound : constant := 500_000_000; + -- Low bound for Ureal values + + Ureal_High_Bound : constant := 599_999_999; + -- Maximum number of Ureal values stored is 100_000_000 which is in + -- practice infinite so that no check is required. + + Uint_Low_Bound : constant := 600_000_000; + -- Low bound for Uint values + + Uint_Table_Start : constant := 2_000_000_000; + -- Location where table entries for universal integers start (see + -- Uintp spec for details of the representation of Uint values). + + Uint_High_Bound : constant := 2_099_999_999; + -- The range of Uint values is very large, since a substantial part + -- of this range is used to store direct values, see Uintp for details. + + -- The following subtype definitions are used to provide convenient names + -- for membership tests on Int values to see what data type range they + -- lie in. Such tests appear only in the lowest level packages. + + subtype List_Range is Union_Id + range List_Low_Bound .. List_High_Bound; + + subtype Node_Range is Union_Id + range Node_Low_Bound .. Node_High_Bound; + + subtype Elist_Range is Union_Id + range Elist_Low_Bound .. Elist_High_Bound; + + subtype Elmt_Range is Union_Id + range Elmt_Low_Bound .. Elmt_High_Bound; + + subtype Names_Range is Union_Id + range Names_Low_Bound .. Names_High_Bound; + + subtype Strings_Range is Union_Id + range Strings_Low_Bound .. Strings_High_Bound; + + subtype Uint_Range is Union_Id + range Uint_Low_Bound .. Uint_High_Bound; + + subtype Ureal_Range is Union_Id + range Ureal_Low_Bound .. Ureal_High_Bound; + + ----------------------------- + -- Types for Atree Package -- + ----------------------------- + + -- Node_Id values are used to identify nodes in the tree. They are + -- subscripts into the Nodes table declared in package Atree. Note that + -- the special values Empty and Error are subscripts into this table. + -- See package Atree for further details. + + type Node_Id is range Node_Low_Bound .. Node_High_Bound; + -- Type used to identify nodes in the tree + + subtype Entity_Id is Node_Id; + -- A synonym for node types, used in the Einfo package to refer to nodes + -- that are entities (i.e. nodes with an Nkind of N_Defining_xxx). All such + -- nodes are extended nodes and these are the only extended nodes, so that + -- in practice entity and extended nodes are synonymous. + + subtype Node_Or_Entity_Id is Node_Id; + -- A synonym for node types, used in cases where a given value may be used + -- to represent either a node or an entity. We like to minimize such uses + -- for obvious reasons of logical type consistency, but where such uses + -- occur, they should be documented by use of this type. + + Empty : constant Node_Id := Node_Low_Bound; + -- Used to indicate null node. A node is actually allocated with this + -- Id value, so that Nkind (Empty) = N_Empty. Note that Node_Low_Bound + -- is zero, so Empty = No_List = zero. + + Empty_List_Or_Node : constant := 0; + -- This constant is used in situations (e.g. initializing empty fields) + -- where the value set will be used to represent either an empty node or + -- a non-existent list, depending on the context. + + Error : constant Node_Id := Node_Low_Bound + 1; + -- Used to indicate an error in the source program. A node is actually + -- allocated with this Id value, so that Nkind (Error) = N_Error. + + Empty_Or_Error : constant Node_Id := Error; + -- Since Empty and Error are the first two Node_Id values, the test for + -- N <= Empty_Or_Error tests to see if N is Empty or Error. This definition + -- provides convenient self-documentation for such tests. + + First_Node_Id : constant Node_Id := Node_Low_Bound; + -- Subscript of first allocated node. Note that Empty and Error are both + -- allocated nodes, whose Nkind fields can be accessed without error. + + ------------------------------ + -- Types for Nlists Package -- + ------------------------------ + + -- List_Id values are used to identify node lists stored in the tree, so + -- that each node can be on at most one such list (see package Nlists for + -- further details). Note that the special value Error_List is a subscript + -- in this table, but the value No_List is *not* a valid subscript, and any + -- attempt to apply list operations to No_List will cause a (detected) + -- error. + + type List_Id is range List_Low_Bound .. List_High_Bound; + -- Type used to identify a node list + + No_List : constant List_Id := List_High_Bound; + -- Used to indicate absence of a list. Note that the value is zero, which + -- is the same as Empty, which is helpful in initializing nodes where a + -- value of zero can represent either an empty node or an empty list. + + Error_List : constant List_Id := List_Low_Bound; + -- Used to indicate that there was an error in the source program in a + -- context which would normally require a list. This node appears to be + -- an empty list to the list operations (a null list is actually allocated + -- which has this Id value). + + First_List_Id : constant List_Id := Error_List; + -- Subscript of first allocated list header + + ------------------------------ + -- Types for Elists Package -- + ------------------------------ + + -- Element list Id values are used to identify element lists stored outside + -- of the tree, allowing nodes to be members of more than one such list + -- (see package Elists for further details). + + type Elist_Id is range Elist_Low_Bound .. Elist_High_Bound; + -- Type used to identify an element list (Elist header table subscript) + + No_Elist : constant Elist_Id := Elist_Low_Bound; + -- Used to indicate absence of an element list. Note that this is not an + -- actual Elist header, so element list operations on this value are not + -- valid. + + First_Elist_Id : constant Elist_Id := No_Elist + 1; + -- Subscript of first allocated Elist header + + -- Element Id values are used to identify individual elements of an element + -- list (see package Elists for further details). + + type Elmt_Id is range Elmt_Low_Bound .. Elmt_High_Bound; + -- Type used to identify an element list + + No_Elmt : constant Elmt_Id := Elmt_Low_Bound; + -- Used to represent empty element + + First_Elmt_Id : constant Elmt_Id := No_Elmt + 1; + -- Subscript of first allocated Elmt table entry + + ------------------------------- + -- Types for Stringt Package -- + ------------------------------- + + -- String_Id values are used to identify entries in the strings table. They + -- are subscripts into the Strings table defined in package Stringt. + + -- Note that with only a few exceptions, which are clearly documented, the + -- type String_Id should be regarded as a private type. In particular it is + -- never appropriate to perform arithmetic operations using this type. + -- Doesn't this also apply to all other *_Id types??? + + type String_Id is range Strings_Low_Bound .. Strings_High_Bound; + -- Type used to identify entries in the strings table + + No_String : constant String_Id := Strings_Low_Bound; + -- Used to indicate missing string Id. Note that the value zero is used + -- to indicate a missing data value for all the Int types in this section. + + First_String_Id : constant String_Id := No_String + 1; + -- First subscript allocated in string table + + ------------------------- + -- Character Code Type -- + ------------------------- + + -- The type Char is used for character data internally in the compiler, but + -- character codes in the source are represented by the Char_Code type. + -- Each character literal in the source is interpreted as being one of the + -- 16#7FFF_FFFF# possible Wide_Wide_Character codes, and a unique Integer + -- value is assigned, corresponding to the UTF-32 value, which also + -- corresponds to the Pos value in the Wide_Wide_Character type, and also + -- corresponds to the Pos value in the Wide_Character and Character types + -- for values that are in appropriate range. String literals are similarly + -- interpreted as a sequence of such codes. + + type Char_Code_Base is mod 2 ** 32; + for Char_Code_Base'Size use 32; + + subtype Char_Code is Char_Code_Base range 0 .. 16#7FFF_FFFF#; + for Char_Code'Value_Size use 32; + for Char_Code'Object_Size use 32; + + function Get_Char_Code (C : Character) return Char_Code; + pragma Inline (Get_Char_Code); + -- Function to obtain internal character code from source character. For + -- the moment, the internal character code is simply the Pos value of the + -- input source character, but we provide this interface for possible + -- later support of alternative character sets. + + function In_Character_Range (C : Char_Code) return Boolean; + pragma Inline (In_Character_Range); + -- Determines if the given character code is in range of type Character, + -- and if so, returns True. If not, returns False. + + function In_Wide_Character_Range (C : Char_Code) return Boolean; + pragma Inline (In_Wide_Character_Range); + -- Determines if the given character code is in range of the type + -- Wide_Character, and if so, returns True. If not, returns False. + + function Get_Character (C : Char_Code) return Character; + pragma Inline (Get_Character); + -- For a character C that is in Character range (see above function), this + -- function returns the corresponding Character value. It is an error to + -- call Get_Character if C is not in Character range. + + function Get_Wide_Character (C : Char_Code) return Wide_Character; + -- For a character C that is in Wide_Character range (see above function), + -- this function returns the corresponding Wide_Character value. It is an + -- error to call Get_Wide_Character if C is not in Wide_Character range. + + --------------------------------------- + -- Types used for Library Management -- + --------------------------------------- + + type Unit_Number_Type is new Int; + -- Unit number. The main source is unit 0, and subsidiary sources have + -- non-zero numbers starting with 1. Unit numbers are used to index the + -- Units table in package Lib. + + Main_Unit : constant Unit_Number_Type := 0; + -- Unit number value for main unit + + No_Unit : constant Unit_Number_Type := -1; + -- Special value used to signal no unit + + type Source_File_Index is new Int range -1 .. Int'Last; + -- Type used to index the source file table (see package Sinput) + + Internal_Source_File : constant Source_File_Index := + Source_File_Index'First; + -- Value used to indicate the buffer for the source-code-like strings + -- internally created withing the compiler (see package Sinput) + + No_Source_File : constant Source_File_Index := 0; + -- Value used to indicate no source file present + + ----------------------------------- + -- Representation of Time Stamps -- + ----------------------------------- + + -- All compiled units are marked with a time stamp which is derived from + -- the source file (we assume that the host system has the concept of a + -- file time stamp which is modified when a file is modified). These + -- time stamps are used to ensure consistency of the set of units that + -- constitutes a library. Time stamps are 12 character strings with + -- with the following format: + + -- YYYYMMDDHHMMSS + + -- YYYY year + -- MM month (2 digits 01-12) + -- DD day (2 digits 01-31) + -- HH hour (2 digits 00-23) + -- MM minutes (2 digits 00-59) + -- SS seconds (2 digits 00-59) + + -- In the case of Unix systems (and other systems which keep the time in + -- GMT), the time stamp is the GMT time of the file, not the local time. + -- This solves problems in using libraries across networks with clients + -- spread across multiple time-zones. + + Time_Stamp_Length : constant := 14; + -- Length of time stamp value + + subtype Time_Stamp_Index is Natural range 1 .. Time_Stamp_Length; + type Time_Stamp_Type is new String (Time_Stamp_Index); + -- Type used to represent time stamp + + Empty_Time_Stamp : constant Time_Stamp_Type := (others => ' '); + -- Value representing an empty or missing time stamp. Looks less than any + -- real time stamp if two time stamps are compared. Note that although this + -- is not private, clients should not rely on the exact way in which this + -- string is represented, and instead should use the subprograms below. + + Dummy_Time_Stamp : constant Time_Stamp_Type := (others => '0'); + -- This is used for dummy time stamp values used in the D lines for + -- non-existent files, and is intended to be an impossible value. + + function "=" (Left, Right : Time_Stamp_Type) return Boolean; + function "<=" (Left, Right : Time_Stamp_Type) return Boolean; + function ">=" (Left, Right : Time_Stamp_Type) return Boolean; + function "<" (Left, Right : Time_Stamp_Type) return Boolean; + function ">" (Left, Right : Time_Stamp_Type) return Boolean; + -- Comparison functions on time stamps. Note that two time stamps are + -- defined as being equal if they have the same day/month/year and the + -- hour/minutes/seconds values are within 2 seconds of one another. This + -- deals with rounding effects in library file time stamps caused by + -- copying operations during installation. We have particularly noticed + -- that WinNT seems susceptible to such changes. + -- + -- Note : the Empty_Time_Stamp value looks equal to itself, and less than + -- any non-empty time stamp value. + + procedure Split_Time_Stamp + (TS : Time_Stamp_Type; + Year : out Nat; + Month : out Nat; + Day : out Nat; + Hour : out Nat; + Minutes : out Nat; + Seconds : out Nat); + -- Given a time stamp, decompose it into its components + + procedure Make_Time_Stamp + (Year : Nat; + Month : Nat; + Day : Nat; + Hour : Nat; + Minutes : Nat; + Seconds : Nat; + TS : out Time_Stamp_Type); + -- Given the components of a time stamp, initialize the value + + ----------------------------------------------- + -- Types used for Pragma Suppress Management -- + ----------------------------------------------- + + type Check_Id is new Nat; + -- Type used to represent a check id + + No_Check_Id : constant := 0; + -- Check_Id value used to indicate no check + + Access_Check : constant := 1; + Accessibility_Check : constant := 2; + Alignment_Check : constant := 3; + Discriminant_Check : constant := 4; + Division_Check : constant := 5; + Elaboration_Check : constant := 6; + Index_Check : constant := 7; + Length_Check : constant := 8; + Overflow_Check : constant := 9; + Range_Check : constant := 10; + Storage_Check : constant := 11; + Tag_Check : constant := 12; + Validity_Check : constant := 13; + -- Values used to represent individual predefined checks + + All_Checks : constant := 14; + -- Value used to represent All_Checks value + + subtype Predefined_Check_Id is Check_Id range 1 .. All_Checks; + -- Subtype for predefined checks, including All_Checks + + -- The following array contains an entry for each recognized check name + -- for pragma Suppress. It is used to represent current settings of scope + -- based suppress actions from pragma Suppress or command line settings. + + -- Note: when Suppress_Array (All_Checks) is True, then generally all other + -- specific check entries are set True, except for the Elaboration_Check + -- entry which is set only if an explicit Suppress for this check is given. + -- The reason for this non-uniformity is that we do not want All_Checks to + -- suppress elaboration checking when using the static elaboration model. + -- We recognize only an explicit suppress of Elaboration_Check as a signal + -- that the static elaboration checking should skip a compile time check. + + type Suppress_Array is array (Predefined_Check_Id) of Boolean; + pragma Pack (Suppress_Array); + + -- To add a new check type to GNAT, the following steps are required: + + -- 1. Add an entry to Snames spec and body for the new name + -- 2. Add an entry to the definition of Check_Id above + -- 3. Add a new function to Checks to handle the new check test + -- 4. Add a new Do_xxx_Check flag to Sinfo (if required) + -- 5. Add appropriate checks for the new test + + ----------------------------------- + -- Global Exception Declarations -- + ----------------------------------- + + -- This section contains declarations of exceptions that are used + -- throughout the compiler or in other GNAT tools. + + Unrecoverable_Error : exception; + -- This exception is raised to immediately terminate the compilation of the + -- current source program. Used in situations where things are bad enough + -- that it doesn't seem worth continuing (e.g. max errors reached, or a + -- required file is not found). Also raised when the compiler finds itself + -- in trouble after an error (see Comperr). + + Terminate_Program : exception; + -- This exception is raised to immediately terminate the tool being + -- executed. Each tool where this exception may be raised must have a + -- single exception handler that contains only a null statement and that is + -- the last statement of the program. If needed, procedure Set_Exit_Status + -- is called with the appropriate exit status before raising + -- Terminate_Program. + + --------------------------------- + -- Parameter Mechanism Control -- + --------------------------------- + + -- Function and parameter entities have a field that records the passing + -- mechanism. See specification of Sem_Mech for full details. The following + -- subtype is used to represent values of this type: + + subtype Mechanism_Type is Int range -18 .. Int'Last; + -- Type used to represent a mechanism value. This is a subtype rather than + -- a type to avoid some annoying processing problems with certain routines + -- in Einfo (processing them to create the corresponding C). + + ------------------------------ + -- Run-Time Exception Codes -- + ------------------------------ + + -- When the code generator generates a run-time exception, it provides a + -- reason code which is one of the following. This reason code is used to + -- select the appropriate run-time routine to be called, determining both + -- the exception to be raised, and the message text to be added. + + -- The prefix CE/PE/SE indicates the exception to be raised + -- CE = Constraint_Error + -- PE = Program_Error + -- SE = Storage_Error + + -- The remaining part of the name indicates the message text to be added, + -- where all letters are lower case, and underscores are converted to + -- spaces (for example CE_Invalid_Data adds the text "invalid data"). + + -- To add a new code, you need to do the following: + + -- 1. Modify the type and subtype declarations below appropriately, + -- keeping things in alphabetical order. + + -- 2. Modify the corresponding definitions in types.h, including the + -- definition of last_reason_code. + + -- 3. Add a new routine in Ada.Exceptions with the appropriate call and + -- static string constant. Note that there is more than one version + -- of a-except.adb which must be modified. + + type RT_Exception_Code is + (CE_Access_Check_Failed, -- 00 + CE_Access_Parameter_Is_Null, -- 01 + CE_Discriminant_Check_Failed, -- 02 + CE_Divide_By_Zero, -- 03 + CE_Explicit_Raise, -- 04 + CE_Index_Check_Failed, -- 05 + CE_Invalid_Data, -- 06 + CE_Length_Check_Failed, -- 07 + CE_Null_Exception_Id, -- 08 + CE_Null_Not_Allowed, -- 09 + CE_Overflow_Check_Failed, -- 10 + CE_Partition_Check_Failed, -- 11 + CE_Range_Check_Failed, -- 12 + CE_Tag_Check_Failed, -- 13 + + PE_Access_Before_Elaboration, -- 14 + PE_Accessibility_Check_Failed, -- 15 + PE_Address_Of_Intrinsic, -- 16 + PE_All_Guards_Closed, -- 17 + PE_Bad_Predicated_Generic_Type, -- 18 + PE_Current_Task_In_Entry_Body, -- 19 + PE_Duplicated_Entry_Address, -- 20 + PE_Explicit_Raise, -- 21 + PE_Finalize_Raised_Exception, -- 22 + PE_Implicit_Return, -- 23 + PE_Misaligned_Address_Value, -- 24 + PE_Missing_Return, -- 25 + PE_Overlaid_Controlled_Object, -- 26 + PE_Potentially_Blocking_Operation, -- 27 + PE_Stubbed_Subprogram_Called, -- 28 + PE_Unchecked_Union_Restriction, -- 29 + PE_Non_Transportable_Actual, -- 30 + + SE_Empty_Storage_Pool, -- 31 + SE_Explicit_Raise, -- 32 + SE_Infinite_Recursion, -- 33 + SE_Object_Too_Large); -- 34 + + subtype RT_CE_Exceptions is RT_Exception_Code range + CE_Access_Check_Failed .. + CE_Tag_Check_Failed; + + subtype RT_PE_Exceptions is RT_Exception_Code range + PE_Access_Before_Elaboration .. + PE_Non_Transportable_Actual; + + subtype RT_SE_Exceptions is RT_Exception_Code range + SE_Empty_Storage_Pool .. + SE_Object_Too_Large; + +end Types; diff --git a/gcc/ada/types.h b/gcc/ada/types.h new file mode 100644 index 000000000..5877f32d3 --- /dev/null +++ b/gcc/ada/types.h @@ -0,0 +1,383 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * T Y P E S * + * * + * C Header File * + * * + * 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. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING3. If not, go to * + * http://www.gnu.org/licenses for a complete copy of the license. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* This is the C file that corresponds to the Ada package spec Types. It was + created manually from the files types.ads and types.adb. + + This package contains host independent type definitions which are used + throughout the compiler modules. The comments in the C version are brief + reminders of the purpose of each declaration. For complete documentation, + see the Ada version of these definitions. */ + +/* Boolean Types: */ + +/* Boolean type (cannot use enum, because of bit field restriction on some + compilers). */ +typedef unsigned char Boolean; +#define False 0 +#define True 1 + +/* General Use Integer Types */ + +/* Signed 32/bit integer */ +typedef int Int; + +/* Signed 16 bit integer */ +typedef short Short; + +/* Non/negative Int values */ +typedef Int Nat; + +/* Positive Int values */ +typedef Int Pos; + +/* 8/bit unsigned integer */ +typedef char Byte; + +/* 8/Bit Character and String Types: */ + +/* 8/bit character type */ +typedef char Char; + +/* Graphic characters, as defined in ARM */ +typedef Char Graphic_Character; + +/* Line terminator characters (LF, VT, FF, CR) */ +typedef Char Line_Terminator; + +/* Characters with the upper bit set */ +typedef Char Upper_Half_Character; + +/* String type built on Char (note that zero is an OK index) */ +typedef Char *Str; + +/* Pointer to string of Chars */ +typedef Char *Str_Ptr; + +/* Types for the fat pointer used for strings and the template it + points to. */ +typedef struct {int Low_Bound, High_Bound; } String_Template; +typedef struct {const char *Array; String_Template *Bounds; } + __attribute ((aligned (sizeof (char *) * 2))) Fat_Pointer; + +/* Types for Node/Entity Kinds: */ + +/* The reason that these are defined here in the C version, rather than in the + corresponding packages is that the requirement for putting bodies of + inlined stuff IN the C header changes the dependencies. Both sinfo.h + and einfo.h now reference routines defined in tree.h. + + Note: these types would more naturally be defined as unsigned char, but + once again, the annoying restriction on bit fields for some compilers + bites us! */ + +typedef unsigned int Node_Kind; +typedef unsigned int Entity_Kind; + +/* Types used for Text Buffer Handling: */ + +/* Type used for subscripts in text buffer. */ +typedef Int Text_Ptr; + +/* Text buffer used to hold source file or library information file. */ +typedef Char *Text_Buffer; + +/* Pointer to text buffer. */ +typedef Char *Text_Buffer_Ptr; + +/* Types used for Source Input Handling: */ + +/* Line number type, used for storing all line numbers. */ +typedef Int Line_Number_Type; + +/* Column number type, used for storing all column numbers. */ +typedef Int Column_Number_Type; + +/* Type used to store text of a source file. */ +typedef Text_Buffer Source_Buffer; + +/* Pointer to source buffer. */ +typedef Text_Buffer_Ptr Source_Buffer_Ptr; + +/* Type used for source location. */ +typedef Text_Ptr Source_Ptr; + +/* Value used to indicate no source position set. */ +#define No_Location -1 + +/* Used for Sloc in all nodes in the representation of package Standard. */ +#define Standard_Location -2 + +/* Type used for union of all possible ID values covering all ranges */ +typedef int Union_Id; + +/* Range definitions for Tree Data: */ + +#define List_Low_Bound -100000000 +#define List_High_Bound 0 + +#define Node_Low_Bound 0 +#define Node_High_Bound 99999999 + +#define Elist_Low_Bound 100000000 +#define Elist_High_Bound 199999999 + +#define Elmt_Low_Bound 200000000 +#define Elmt_High_Bound 299999999 + +#define Names_Low_Bound 300000000 +#define Names_High_Bound 399999999 + +#define Strings_Low_Bound 400000000 +#define Strings_High_Bound 499999999 + +#define Ureal_Low_Bound 500000000 +#define Ureal_High_Bound 599999999 + +#define Uint_Low_Bound 600000000 +#define Uint_Table_Start 2000000000 +#define Uint_High_Bound 2099999999 + +SUBTYPE (List_Range, Int, List_Low_Bound, List_High_Bound) +SUBTYPE (Node_Range, Int, Node_Low_Bound, Node_High_Bound) +SUBTYPE (Elist_Range, Int, Elist_Low_Bound, Elist_High_Bound) +SUBTYPE (Elmt_Range, Int, Elmt_Low_Bound, Elmt_High_Bound) +SUBTYPE (Names_Range, Int, Names_Low_Bound, Names_High_Bound) +SUBTYPE (Strings_Range, Int, Strings_Low_Bound, Strings_High_Bound) +SUBTYPE (Uint_Range, Int, Uint_Low_Bound, Uint_High_Bound) +SUBTYPE (Ureal_Range, Int, Ureal_Low_Bound, Ureal_High_Bound) + +/* Types for Names_Table Package: */ + +typedef Int Name_Id; + +/* Name_Id value for no name present. */ +#define No_Name Names_Low_Bound + +/* Name_Id value for bad name. */ +#define Error_Name (Names_Low_Bound + 1) + +/* First subscript of names table. */ +#define First_Name_Id (Names_Low_Bound + 2) + +/* Types for Tree Package: */ + +/* Subscript of nodes table entry. */ +typedef Int Node_Id; + +/* Used in semantics for Node_Id value referencing an entity. */ +typedef Node_Id Entity_Id; + +/* Null node. */ +#define Empty 0 + +/* Error node. */ +#define Error 1 + +/* Subscript of first allocated node. */ +#define First_Node_Id Empty + +/* Subscript of entry in lists table. */ +typedef Int List_Id; + +/* Indicates absence of a list. */ +#define No_List 0 + +/* Error list. */ +#define Error_List List_Low_Bound + +/* Subscript of first allocated list header. */ +#define First_List_Id Error_List + +/* Element list Id, subscript value of entry in lists table. */ +typedef Int Elist_Id; + +/* Used to indicate absence of an element list. */ +#define No_Elist Elist_Low_Bound + +/* Subscript of first allocated elist header */ +#define First_Elist_Id (No_Elist + 1) + +/* Element Id, subscript value of entry in elements table. */ +typedef Int Elmt_Id; + +/* Used to indicate absence of a list element. */ +#define No_Elmt Elmt_Low_Bound + +/* Subscript of first allocated element */ +#define First_Elmt_Id (No_Elmt + 1) + +/* Types for String_Table Package: */ + +/* Subscript of strings table entry. */ +typedef Int String_Id; + +/* Used to indicate missing string Id. */ +#define No_String Strings_Low_Bound + +/* Subscript of first entry in strings table. */ +#define First_String_Id (No_String + 1) + +/* Types for Uint_Support Package: */ + +/* Type used for representation of universal integers. */ +typedef Int Uint; + +/* Used to indicate missing Uint value. */ +#define No_Uint Uint_Low_Bound + +/* Base value used to represent Uint values. */ +#define Base 32768 + +/* Minimum and maximum integers directly representable as Uint values */ +#define Min_Direct (-(Base - 1)) +#define Max_Direct ((Base - 1) * (Base - 1)) + +#define Uint_Direct_Bias (Uint_Low_Bound + Base) +#define Uint_Direct_First (Uint_Direct_Bias + Min_Direct) +#define Uint_Direct_Last (Uint_Direct_Bias + Max_Direct) + +/* Define range of direct biased values */ +SUBTYPE (Uint_Direct, Uint, Uint_Direct_First, Uint_Direct_Last) + +/* Constants in Uint format. */ +#define Uint_0 (Uint_Direct_Bias + 0) +#define Uint_1 (Uint_Direct_Bias + 1) +#define Uint_2 (Uint_Direct_Bias + 2) +#define Uint_10 (Uint_Direct_Bias + 10) +#define Uint_16 (Uint_Direct_Bias + 16) + +/* Types for Ureal_Support Package: */ + +/* Type used for representation of universal reals. */ +typedef Int Ureal; + +/* Used to indicate missing Uint value. */ +#define No_Ureal Ureal_Low_Bound + +/* Subscript of first entry in Ureal table. */ +#define Ureal_First_Entry (No_Ureal + 1) + +/* Character Code Type: */ + +/* Character code value, intended to be 32 bits. */ +typedef unsigned Char_Code; + +/* Types Used for Library Management: */ + +/* Unit number. */ +typedef Int Unit_Number_Type; + +/* Unit number value for main unit. */ +#define Main_Unit 0 + +/* Type used for lines table. */ +typedef Source_Ptr *Lines_Table_Type; + +/* Type used for pointer to lines table. */ +typedef Source_Ptr *Lines_Table_Ptr; + +/* Length of time stamp value. */ +#define Time_Stamp_Length 22 + +/* Type used to represent time stamp. */ +typedef Char *Time_Stamp_Type; + +/* Name_Id synonym used for file names. */ +typedef Name_Id File_Name_Type; + +/* Constant used to indicate no file found. */ +#define No_File No_Name + +/* Name_Id synonym used for unit names. */ +typedef Name_Id Unit_Name_Type; + +/* Definitions for mechanism type and values */ +typedef Int Mechanism_Type; +#define Default 0 +#define By_Copy (-1) +#define By_Reference (-2) +#define By_Descriptor (-3) +#define By_Descriptor_UBS (-4) +#define By_Descriptor_UBSB (-5) +#define By_Descriptor_UBA (-6) +#define By_Descriptor_S (-7) +#define By_Descriptor_SB (-8) +#define By_Descriptor_A (-9) +#define By_Descriptor_NCA (-10) +#define By_Descriptor_Last (-10) +#define By_Short_Descriptor (-11) +#define By_Short_Descriptor_UBS (-12) +#define By_Short_Descriptor_UBSB (-13) +#define By_Short_Descriptor_UBA (-14) +#define By_Short_Descriptor_S (-15) +#define By_Short_Descriptor_SB (-16) +#define By_Short_Descriptor_A (-17) +#define By_Short_Descriptor_NCA (-18) +#define By_Short_Descriptor_Last (-18) + +/* Internal to Gigi. */ +#define By_Copy_Return (-128) + +/* Definitions of Reason codes for Raise_xxx_Error nodes */ +#define CE_Access_Check_Failed 0 +#define CE_Access_Parameter_Is_Null 1 +#define CE_Discriminant_Check_Failed 2 +#define CE_Divide_By_Zero 3 +#define CE_Explicit_Raise 4 +#define CE_Index_Check_Failed 5 +#define CE_Invalid_Data 6 +#define CE_Length_Check_Failed 7 +#define CE_Null_Exception_Id 8 +#define CE_Null_Not_Allowed 9 +#define CE_Overflow_Check_Failed 10 +#define CE_Partition_Check_Failed 11 +#define CE_Range_Check_Failed 12 +#define CE_Tag_Check_Failed 13 + +#define PE_Access_Before_Elaboration 14 +#define PE_Accessibility_Check_Failed 15 +#define PE_Address_Of_Intrinsic 16 +#define PE_All_Guards_Closed 17 +#define PE_Bad_Attribute_For_Predicate 18 +#define PE_Current_Task_In_Entry_Body 19 +#define PE_Duplicated_Entry_Address 20 +#define PE_Explicit_Raise 21 +#define PE_Finalize_Raised_Exception 22 +#define PE_Implicit_Return 23 +#define PE_Misaligned_Address_Value 24 +#define PE_Missing_Return 25 +#define PE_Overlaid_Controlled_Object 26 +#define PE_Potentially_Blocking_Operation 27 +#define PE_Stubbed_Subprogram_Called 28 +#define PE_Unchecked_Union_Restriction 29 +#define PE_Non_Transportable_Actual 30 + +#define SE_Empty_Storage_Pool 31 +#define SE_Explicit_Raise 32 +#define SE_Infinite_Recursion 33 +#define SE_Object_Too_Large 34 + +#define LAST_REASON_CODE 34 diff --git a/gcc/ada/ug_words b/gcc/ada/ug_words new file mode 100644 index 000000000..aedfc0fe8 --- /dev/null +++ b/gcc/ada/ug_words @@ -0,0 +1,230 @@ +b_ ^ B_ +b~ ^ B__ +cc1 ^ CC1 +Cc1 ^ CC1 +emacs ^ EMACS +Emacs ^ EMACS +gdb ^ GDB +Gdb ^ GDB +gnat1 ^ GNAT1 +Gnat1 ^ GNAT1 +gnatbind ^ GNAT BIND +Gnatbind ^ GNAT BIND +gnatcheck ^ GNAT CHECK +Gnatcheck ^ GNAT CHECK +gnatchop ^ GNAT CHOP +Gnatchop ^ GNAT CHOP +gnatclean ^ GNAT CLEAN +Gnatclean ^ GNAT CLEAN +gnatelim ^ GNAT ELIM +Gnatelim ^ GNAT ELIM +gnatf ^ GNAT XREF +Gnatf ^ GNAT XREF +gnatfind ^ GNAT FIND +Gnatfind ^ GNAT FIND +gnatkr ^ GNAT KRUNCH +Gnatkr ^ GNAT KRUNCH +gnatlink ^ GNAT LINK +Gnatlink ^ GNAT LINK +gnatls ^ GNAT LIST +Gnatls ^ GNAT LIST +gnatmake ^ GNAT MAKE +Gnatmake ^ GNAT MAKE +gnatmetric ^ GNAT METRIC +Gnatmetric ^ GNAT METRIC +gnatname ^ GNAT NAME +Gnatname ^ GNAT NAME +gnatpp ^ GNAT PRETTY +Gnatpp ^ GNAT PRETTY +gnatprep ^ GNAT PREPROCESS +Gnatprep ^ GNAT PREPROCESS +gnatstub ^ GNAT STUB +Gnatstub ^ GNAT STUB +gnatxref ^ GNAT XREF +Gnatxref ^ GNAT XREF +gcc ^ GNAT COMPILE +gcc -c ^ GNAT COMPILE +-fno-inline ^ /INLINE=SUPPRESS +-fstack-check ^ /CHECKS=STACK +-fno-strict-aliasing ^ /OPTIMIZE=NO_STRICT_ALIASING +-gnata ^ /CHECKS=ASSERTIONS +-gnatA ^ /NO_GNAT_ADC +-gnatb ^ /REPORT_ERRORS=BRIEF +-gnatB ^ /ASSUME_VALID +-gnatc ^ /NOLOAD +-gnatct ^ /NOLOAD /TREE_OUTPUT +-gnatdc ^ /TRACE_UNITS +-gnatdO ^ /REPORT_ERRORS=IMMEDIATE +-gnatC ^ /COMPRESS_NAMES +-gnatDG ^ /XDEBUG /EXPAND_SOURCEA +-gnatD ^ /XDEBUG +-gnatec ^ /CONFIGURATION_PRAGMAS_FILE +-gnateE ^ /EXTRA_EXCEPTION_INFORMATION +-gnateD ^ /SYMBOL_PREPROCESSING +-gnatef ^ /FULL_PATH_IN_BRIEF_MESSAGES +-gnateG ^ /GENERATE_PROCESSED_SOURCE +-gnatem ^ /MAPPING_FILE +-gnatep ^ /DATA_PREPROCESSING +-gnateS ^ /SCO_OUTPUT +-gnatE ^ /CHECKS=ELABORATION +-gnatf ^ /REPORT_ERRORS=FULL +-gnatF ^ /UPPERCASE_EXTERNALS +-gnatg ^ /STYLE_CHECKS=GNAT +-gnatG ^ /EXPAND_SOURCE +-gnatk ^ /FILE_NAME_MAX_LENGTH +-gnatl ^ /LIST +-gnatL ^ /LONGJMP_SETJMP +-gnatj ^ /JUSTIFY_MESSAGES +-gnatj0 ^ /NO_JUSTIFY_MESSAGES +-gnatjnn ^ /JUSTIFY_MESSAGES=nn +-gnatL ^ /INTERSPERSE_SOURCE +-gnatm ^ /ERROR_LIMIT +-gnatm2 ^ /ERROR_LIMIT=2 +-gnatn ^ /INLINE=PRAGMA +-gnatN ^ /INLINE=FULL +-gnato ^ /CHECKS=OVERFLOW +-gnatp ^ /CHECKS=SUPPRESS_ALL +-gnat-p ^ /CHECKS=UNSUPPRESS_ALL +-gnatP ^ /POLLING +-gnatR ^ /REPRESENTATION_INFO +-gnatR0 ^ /REPRESENTATION_INFO=NONE +-gnatR1 ^ /REPRESENTATION_INFO=ARRAYS +-gnatR2 ^ /REPRESENTATION_INFO=OBJECTS +-gnatR3 ^ /REPRESENTATION_INFO=SYMBOLIC +-gnatq ^ /TRY_SEMANTICS +-gnatQ ^ /FORCE_ALI +-gnatr ^ /TREAT_RESTRICTIONS_AS_WARNINGS +-gnats ^ /SYNTAX_ONLY +-gnatS ^ /PRINT_STANDARD +-gnatt ^ /TREE_OUTPUT +-gnatu ^ /UNITS_LIST +-gnatU ^ /UNIQUE_ERROR_TAG +-gnatv ^ /REPORT_ERRORS=VERBOSE +-gnatV ^ /VALIDITY_CHECKING +-gnatVa ^ /VALIDITY_CHECKING=ALL +-gnatVc ^ /VALIDITY_CHECKING=COPIES +-gnatVd ^ /VALIDITY_CHECKING=DEFAULT +-gnatVE ^ /VALIDITY_CHECKING=NOCOMPONENTS +-gnatVe ^ /VALIDITY_CHECKING=COMPONENTS +-gnatVD ^ /VALIDITY_CHECKING=NODEFAULT +-gnatVf ^ /VALIDITY_CHECKING=FLOATS +-gnatVi ^ /VALIDITY_CHECKING=IN_PARAMS +-gnatVm ^ /VALIDITY_CHECKING=MOD_PARAMS +-gnatVn ^ /VALIDITY_CHECKING=NONE +-gnatVo ^ /VALIDITY_CHECKING=OPERANDS +-gnatVp ^ /VALIDITY_CHECKING=PARAMETERS +-gnatVr ^ /VALIDITY_CHECKING=RETURNS +-gnatVs ^ /VALIDITY_CHECKING=SUBSCRIPTS +-gnatVt ^ /VALIDITY_CHECKING=TESTS +-gnatw ^ /WARNINGS +-gnatwa ^ /WARNINGS=OPTIONAL +-gnatwA ^ /WARNINGS=NOOPTIONAL +-gnatw.a ^ /WARNINGS=FAILING_ASSERTIONS +-gnatw.A ^ /WARNINGS=NO_FAILING_ASSERTIONS +-gnatwb ^ /WARNINGS=BAD_FIXED_VALUES +-gnatwB ^ /WARNINGS=NO_BAD_FIXED_VALUES +-gnatw.b ^ /WARNINGS=BIASED_REPRESENTATION +-gnatw.B ^ /WARNINGS=NO_BIASED_REPRESENTATION +-gnatwc ^ /WARNINGS=CONDITIONALS +-gnatwC ^ /WARNINGS=NOCONDITIONALS +-gnatw.c ^ /WARNINGS=MISSING_COMPONENT_CLAUSES +-gnatw.C ^ /WARNINGS=NOMISSING_COMPONENT_CLAUSES +-gnatwd ^ /WARNINGS=IMPLICIT_DEREFERENCE +-gnatwD ^ /WARNINGS=NOIMPLICIT_DEREFERENCE +-gnatwe ^ /WARNINGS=ERRORS +-gnatw.e ^ /WARNINGS=EVERY +-gnatwf ^ /WARNINGS=UNREFERENCED_FORMALS +-gnatwF ^ /WARNINGS=NOUNREFERENCED_FORMALS +-gnatwg ^ /WARNINGS=UNRECOGNIZED_PRAGMAS +-gnatwG ^ /WARNINGS=NOUNRECOGNIZED_PRAGMAS +-gnatwh ^ /WARNINGS=HIDING +-gnatwH ^ /WARNINGS=NOHIDING +-gnatw.h ^ /WARNINGS=AVOIDGAPS +-gnatw.H ^ /WARNINGS=NOAVOIDGAPS +-gnatwi ^ /WARNINGS=IMPLEMENTATION +-gnatwI ^ /WARNINGS=NOIMPLEMENTATION +-gnatwj ^ /WARNINGS=OBSOLESCENT +-gnatwJ ^ /WARNINGS=NOOBSOLESCENT +-gnatwk ^ /WARNINGS=CONSTANT_VARIABLES +-gnatwK ^ /WARNINGS=NOCONSTANT_VARIABLES +-gnatwl ^ /WARNINGS=ELABORATION +-gnatwL ^ /WARNINGS=NOELABORATION +-gnatwm ^ /WARNINGS=MODIFIED_UNREF +-gnatwM ^ /WARNINGS=NOMODIFIED_UNREF +-gnatw.m ^ /WARNINGS=SUSPICIOUS_MODULUES +-gnatw.M ^ /WARNINGS=NOSUSPICIOUS_MODULUES +-gnatwn ^ /WARNINGS=NORMAL +-gnatwo ^ /WARNINGS=OVERLAYS +-gnatwO ^ /WARNINGS=NOOVERLAYS +-gnatw.o ^ /WARNINGS=OUT_PARAM_UNREF +-gnatw.O ^ /WARNINGS=NOOUT_PARAM_UNREF +-gnatwp ^ /WARNINGS=INEFFECTIVE_INLINE +-gnatwP ^ /WARNINGS=NOINEFFECTIVE_INLINE +-gnatw.p ^ /WARNINGS=PARAMETER_ORDER +-gnatw.P ^ /WARNINGS=NO_PARAMETER_ORDER +-gnatw.h ^ /WARNINGS=OVERRIDING_SIZE +-gnatw.H ^ /WARNINGS=NOOVERRIDING_SIZE +-gnatwq ^ /WARNINGS=MISSING_PARENS +-gnatwQ ^ /WARNINGS=NOMISSING_PARENS +-gnatwr ^ /WARNINGS=REDUNDANT +-gnatwR ^ /WARNINGS=NOREDUNDANT +-gnatws ^ /WARNINGS=SUPPRESS +-gnatwt ^ /WARNINGS=DELETED_CODE +-gnatwT ^ /WARNINGS=NODELETED_CODE +-gnatwu ^ /WARNINGS=UNUSED +-gnatwU ^ /WARNINGS=NOUNUSED +-gnatw.u ^ /WARNINGS=UNORDERED_ENUMERATIONS +-gnatw.U ^ /WARNINGS=NOUNORDERED_ENUMERATIONS +-gnatwv ^ /WARNINGS=VARIABLES_UNINITIALIZED +-gnatwV ^ /WARNINGS=NOVARIABLES_UNINITIALIZED +-gnatww ^ /WARNINGS=LOWBOUND_ASSUMED +-gnatwW ^ /WARNINGS=NOLOWBOUND_ASSUMED +-gnatw.w ^ /WARNINGS=WARNINGS_OFF_PRAGMAS +-gnatw.W ^ /WARNINGS=NOWARNINGS_OFF_PRAGMAS +-gnatwx ^ /WARNINGS=IMPORT_EXPORT_PRAGMAS +-gnatwX ^ /WARNINGS=NOIMPORT_EXPORT_PRAGMAS +-gnatw.x ^ /WARNINGS=LOCAL_RAISE_HANDLING +-gnatw.X ^ /WARNINGS=NOLOCAL_RAISE_HANDLING +-gnatwy ^ /WARNINGS=ADA_2005_COMPATIBILITY +-gnatwY ^ /WARNINGS=NOADA_2005_COMPATIBILITY +-gnatwz ^ /WARNINGS=UNCHECKED_CONVERSIONS +-gnatwZ ^ /WARNINGS=NOUNCHECKED_CONVERSIONS +-gnatW8 ^ /WIDE_CHARACTER_ENCODING=UTF8 +-gnatW? ^ /WIDE_CHARACTER_ENCODING=? +-gnaty ^ /STYLE_CHECKS +-gnatyO ^ /STYLE_CHECKS=OVERRIDING_INDICATORS +-gnatyy ^ /STYLE_CHECKS=ALL_BUILTIN +-gnatZ ^ /ZERO_COST_EXCEPTIONS +-gnatzc ^ /DISTRIBUTION_STUBS=CALLER +-gnatzr ^ /DISTRIBUTION_STUBS=RECEIVER +-gnat83 ^ /83 +-gnat95 ^ /95 +-gnat05 ^ /05 +-gnat2005 ^ /2005 +-gnat12 ^ /12 +-gnat2012 ^ /2012 +-gnatx ^ /XREF=SUPPRESS +-gnatX ^ /EXTENSIONS_ALLOWED +--RTS ^ /RUNTIME_SYSTEM +switch ^ qualifier +switches ^ qualifiers +Switch ^ Qualifier +Switches ^ Qualifiers +stdout ^ SYS$OUTPUT +stderr ^ SYS$ERROR +-bargs ^ /BINDER_QUALIFIERS +-cargs ^ /COMPILER_QUALIFIERS +-largs ^ /LINKER_QUALIFIERS +-margs ^ /MAKE_QUALIFIERS +-aIDIR ^ /SOURCE_SEARCH=direc +-aODIR ^ /OBJECT_SEARCH=direc +-IDIR ^ /SEARCH=direc +-nostdinc ^ /NOSTD_INCLUDES +-nostdlib ^ /NOSTD_LIBRARIES +-pFILE ^ /PROJECT=file +-O0 ^ /OPTIMIZE=NONE +-O1 ^ /OPTIMIZE=SOME +-O2 ^ /OPTIMIZE=ALL +-O3 ^ /OPTIMIZE=INLINING +-H32 ^ /32_MALLOC +-H64 ^ /64_MALLOC diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb new file mode 100644 index 000000000..713e0b15d --- /dev/null +++ b/gcc/ada/uintp.adb @@ -0,0 +1,2716 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- U I N T P -- +-- -- +-- 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 Output; use Output; +with Tree_IO; use Tree_IO; + +with GNAT.HTable; use GNAT.HTable; + +package body Uintp is + + ------------------------ + -- Local Declarations -- + ------------------------ + + Uint_Int_First : Uint := Uint_0; + -- Uint value containing Int'First value, set by Initialize. The initial + -- value of Uint_0 is used for an assertion check that ensures that this + -- value is not used before it is initialized. This value is used in the + -- UI_Is_In_Int_Range predicate, and it is right that this is a host value, + -- since the issue is host representation of integer values. + + Uint_Int_Last : Uint; + -- Uint value containing Int'Last value set by Initialize + + UI_Power_2 : array (Int range 0 .. 64) of Uint; + -- This table is used to memoize exponentiations by powers of 2. The Nth + -- entry, if set, contains the Uint value 2 ** N. Initially UI_Power_2_Set + -- is zero and only the 0'th entry is set, the invariant being that all + -- entries in the range 0 .. UI_Power_2_Set are initialized. + + UI_Power_2_Set : Nat; + -- Number of entries set in UI_Power_2; + + UI_Power_10 : array (Int range 0 .. 64) of Uint; + -- This table is used to memoize exponentiations by powers of 10 in the + -- same manner as described above for UI_Power_2. + + UI_Power_10_Set : Nat; + -- Number of entries set in UI_Power_10; + + Uints_Min : Uint; + Udigits_Min : Int; + -- These values are used to make sure that the mark/release mechanism does + -- not destroy values saved in the U_Power tables or in the hash table used + -- by UI_From_Int. Whenever an entry is made in either of these tables, + -- Uints_Min and Udigits_Min are updated to protect the entry, and Release + -- never cuts back beyond these minimum values. + + Int_0 : constant Int := 0; + Int_1 : constant Int := 1; + Int_2 : constant Int := 2; + -- These values are used in some cases where the use of numeric literals + -- would cause ambiguities (integer vs Uint). + + ---------------------------- + -- UI_From_Int Hash Table -- + ---------------------------- + + -- UI_From_Int uses a hash table to avoid duplicating entries and wasting + -- storage. This is particularly important for complex cases of back + -- annotation. + + subtype Hnum is Nat range 0 .. 1022; + + function Hash_Num (F : Int) return Hnum; + -- Hashing function + + package UI_Ints is new Simple_HTable ( + Header_Num => Hnum, + Element => Uint, + No_Element => No_Uint, + Key => Int, + Hash => Hash_Num, + Equal => "="); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Direct (U : Uint) return Boolean; + pragma Inline (Direct); + -- Returns True if U is represented directly + + function Direct_Val (U : Uint) return Int; + -- U is a Uint for is represented directly. The returned result is the + -- value represented. + + function GCD (Jin, Kin : Int) return Int; + -- Compute GCD of two integers. Assumes that Jin >= Kin >= 0 + + procedure Image_Out + (Input : Uint; + To_Buffer : Boolean; + Format : UI_Format); + -- Common processing for UI_Image and UI_Write, To_Buffer is set True for + -- UI_Image, and false for UI_Write, and Format is copied from the Format + -- parameter to UI_Image or UI_Write. + + procedure Init_Operand (UI : Uint; Vec : out UI_Vector); + pragma Inline (Init_Operand); + -- This procedure puts the value of UI into the vector in canonical + -- multiple precision format. The parameter should be of the correct size + -- as determined by a previous call to N_Digits (UI). The first digit of + -- Vec contains the sign, all other digits are always non-negative. Note + -- that the input may be directly represented, and in this case Vec will + -- contain the corresponding one or two digit value. The low bound of Vec + -- is always 1. + + function Least_Sig_Digit (Arg : Uint) return Int; + pragma Inline (Least_Sig_Digit); + -- Returns the Least Significant Digit of Arg quickly. When the given Uint + -- is less than 2**15, the value returned is the input value, in this case + -- the result may be negative. It is expected that any use will mask off + -- unnecessary bits. This is used for finding Arg mod B where B is a power + -- of two. Hence the actual base is irrelevant as long as it is a power of + -- two. + + procedure Most_Sig_2_Digits + (Left : Uint; + Right : Uint; + Left_Hat : out Int; + Right_Hat : out Int); + -- Returns leading two significant digits from the given pair of Uint's. + -- Mathematically: returns Left / (Base ** K) and Right / (Base ** K) where + -- K is as small as possible S.T. Right_Hat < Base * Base. It is required + -- that Left > Right for the algorithm to work. + + function N_Digits (Input : Uint) return Int; + pragma Inline (N_Digits); + -- Returns number of "digits" in a Uint + + function Sum_Digits (Left : Uint; Sign : Int) return Int; + -- If Sign = 1 return the sum of the "digits" of Abs (Left). If the total + -- has more then one digit then return Sum_Digits of total. + + function Sum_Double_Digits (Left : Uint; Sign : Int) return Int; + -- Same as above but work in New_Base = Base * Base + + procedure UI_Div_Rem + (Left, Right : Uint; + Quotient : out Uint; + Remainder : out Uint; + Discard_Quotient : Boolean := False; + Discard_Remainder : Boolean := False); + -- Compute Euclidean division of Left by Right. If Discard_Quotient is + -- False then the quotient is returned in Quotient (otherwise Quotient is + -- set to No_Uint). If Discard_Remainder is False, then the remainder is + -- returned in Remainder (otherwise Remainder is set to No_Uint). + -- + -- If Discard_Quotient is True, Quotient is set to No_Uint + -- If Discard_Remainder is True, Remainder is set to No_Uint + + function Vector_To_Uint + (In_Vec : UI_Vector; + Negative : Boolean) return Uint; + -- Functions that calculate values in UI_Vectors, call this function to + -- create and return the Uint value. In_Vec contains the multiple precision + -- (Base) representation of a non-negative value. Leading zeroes are + -- permitted. Negative is set if the desired result is the negative of the + -- given value. The result will be either the appropriate directly + -- represented value, or a table entry in the proper canonical format is + -- created and returned. + -- + -- Note that Init_Operand puts a signed value in the result vector, but + -- Vector_To_Uint is always presented with a non-negative value. The + -- processing of signs is something that is done by the caller before + -- calling Vector_To_Uint. + + ------------ + -- Direct -- + ------------ + + function Direct (U : Uint) return Boolean is + begin + return Int (U) <= Int (Uint_Direct_Last); + end Direct; + + ---------------- + -- Direct_Val -- + ---------------- + + function Direct_Val (U : Uint) return Int is + begin + pragma Assert (Direct (U)); + return Int (U) - Int (Uint_Direct_Bias); + end Direct_Val; + + --------- + -- GCD -- + --------- + + function GCD (Jin, Kin : Int) return Int is + J, K, Tmp : Int; + + begin + pragma Assert (Jin >= Kin); + pragma Assert (Kin >= Int_0); + + J := Jin; + K := Kin; + while K /= Uint_0 loop + Tmp := J mod K; + J := K; + K := Tmp; + end loop; + + return J; + end GCD; + + -------------- + -- Hash_Num -- + -------------- + + function Hash_Num (F : Int) return Hnum is + begin + return Types."mod" (F, Hnum'Range_Length); + end Hash_Num; + + --------------- + -- Image_Out -- + --------------- + + procedure Image_Out + (Input : Uint; + To_Buffer : Boolean; + Format : UI_Format) + is + Marks : constant Uintp.Save_Mark := Uintp.Mark; + Base : Uint; + Ainput : Uint; + + Digs_Output : Natural := 0; + -- Counts digits output. In hex mode, but not in decimal mode, we + -- put an underline after every four hex digits that are output. + + Exponent : Natural := 0; + -- If the number is too long to fit in the buffer, we switch to an + -- approximate output format with an exponent. This variable records + -- the exponent value. + + function Better_In_Hex return Boolean; + -- Determines if it is better to generate digits in base 16 (result + -- is true) or base 10 (result is false). The choice is purely a + -- matter of convenience and aesthetics, so it does not matter which + -- value is returned from a correctness point of view. + + procedure Image_Char (C : Character); + -- Internal procedure to output one character + + procedure Image_Exponent (N : Natural); + -- Output non-zero exponent. Note that we only use the exponent form in + -- the buffer case, so we know that To_Buffer is true. + + procedure Image_Uint (U : Uint); + -- Internal procedure to output characters of non-negative Uint + + ------------------- + -- Better_In_Hex -- + ------------------- + + function Better_In_Hex return Boolean is + T16 : constant Uint := Uint_2 ** Int'(16); + A : Uint; + + begin + A := UI_Abs (Input); + + -- Small values up to 2**16 can always be in decimal + + if A < T16 then + return False; + end if; + + -- Otherwise, see if we are a power of 2 or one less than a power + -- of 2. For the moment these are the only cases printed in hex. + + if A mod Uint_2 = Uint_1 then + A := A + Uint_1; + end if; + + loop + if A mod T16 /= Uint_0 then + return False; + + else + A := A / T16; + end if; + + exit when A < T16; + end loop; + + while A > Uint_2 loop + if A mod Uint_2 /= Uint_0 then + return False; + + else + A := A / Uint_2; + end if; + end loop; + + return True; + end Better_In_Hex; + + ---------------- + -- Image_Char -- + ---------------- + + procedure Image_Char (C : Character) is + begin + if To_Buffer then + if UI_Image_Length + 6 > UI_Image_Max then + Exponent := Exponent + 1; + else + UI_Image_Length := UI_Image_Length + 1; + UI_Image_Buffer (UI_Image_Length) := C; + end if; + else + Write_Char (C); + end if; + end Image_Char; + + -------------------- + -- Image_Exponent -- + -------------------- + + procedure Image_Exponent (N : Natural) is + begin + if N >= 10 then + Image_Exponent (N / 10); + end if; + + UI_Image_Length := UI_Image_Length + 1; + UI_Image_Buffer (UI_Image_Length) := + Character'Val (Character'Pos ('0') + N mod 10); + end Image_Exponent; + + ---------------- + -- Image_Uint -- + ---------------- + + procedure Image_Uint (U : Uint) is + H : constant array (Int range 0 .. 15) of Character := + "0123456789ABCDEF"; + + begin + if U >= Base then + Image_Uint (U / Base); + end if; + + if Digs_Output = 4 and then Base = Uint_16 then + Image_Char ('_'); + Digs_Output := 0; + end if; + + Image_Char (H (UI_To_Int (U rem Base))); + + Digs_Output := Digs_Output + 1; + end Image_Uint; + + -- Start of processing for Image_Out + + begin + if Input = No_Uint then + Image_Char ('?'); + return; + end if; + + UI_Image_Length := 0; + + if Input < Uint_0 then + Image_Char ('-'); + Ainput := -Input; + else + Ainput := Input; + end if; + + if Format = Hex + or else (Format = Auto and then Better_In_Hex) + then + Base := Uint_16; + Image_Char ('1'); + Image_Char ('6'); + Image_Char ('#'); + Image_Uint (Ainput); + Image_Char ('#'); + + else + Base := Uint_10; + Image_Uint (Ainput); + end if; + + if Exponent /= 0 then + UI_Image_Length := UI_Image_Length + 1; + UI_Image_Buffer (UI_Image_Length) := 'E'; + Image_Exponent (Exponent); + end if; + + Uintp.Release (Marks); + end Image_Out; + + ------------------- + -- Init_Operand -- + ------------------- + + procedure Init_Operand (UI : Uint; Vec : out UI_Vector) is + Loc : Int; + + pragma Assert (Vec'First = Int'(1)); + + begin + if Direct (UI) then + Vec (1) := Direct_Val (UI); + + if Vec (1) >= Base then + Vec (2) := Vec (1) rem Base; + Vec (1) := Vec (1) / Base; + end if; + + else + Loc := Uints.Table (UI).Loc; + + for J in 1 .. Uints.Table (UI).Length loop + Vec (J) := Udigits.Table (Loc + J - 1); + end loop; + end if; + end Init_Operand; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Uints.Init; + Udigits.Init; + + Uint_Int_First := UI_From_Int (Int'First); + Uint_Int_Last := UI_From_Int (Int'Last); + + UI_Power_2 (0) := Uint_1; + UI_Power_2_Set := 0; + + UI_Power_10 (0) := Uint_1; + UI_Power_10_Set := 0; + + Uints_Min := Uints.Last; + Udigits_Min := Udigits.Last; + + UI_Ints.Reset; + end Initialize; + + --------------------- + -- Least_Sig_Digit -- + --------------------- + + function Least_Sig_Digit (Arg : Uint) return Int is + V : Int; + + begin + if Direct (Arg) then + V := Direct_Val (Arg); + + if V >= Base then + V := V mod Base; + end if; + + -- Note that this result may be negative + + return V; + + else + return + Udigits.Table + (Uints.Table (Arg).Loc + Uints.Table (Arg).Length - 1); + end if; + end Least_Sig_Digit; + + ---------- + -- Mark -- + ---------- + + function Mark return Save_Mark is + begin + return (Save_Uint => Uints.Last, Save_Udigit => Udigits.Last); + end Mark; + + ----------------------- + -- Most_Sig_2_Digits -- + ----------------------- + + procedure Most_Sig_2_Digits + (Left : Uint; + Right : Uint; + Left_Hat : out Int; + Right_Hat : out Int) + is + begin + pragma Assert (Left >= Right); + + if Direct (Left) then + Left_Hat := Direct_Val (Left); + Right_Hat := Direct_Val (Right); + return; + + else + declare + L1 : constant Int := + Udigits.Table (Uints.Table (Left).Loc); + L2 : constant Int := + Udigits.Table (Uints.Table (Left).Loc + 1); + + begin + -- It is not so clear what to return when Arg is negative??? + + Left_Hat := abs (L1) * Base + L2; + end; + end if; + + declare + Length_L : constant Int := Uints.Table (Left).Length; + Length_R : Int; + R1 : Int; + R2 : Int; + T : Int; + + begin + if Direct (Right) then + T := Direct_Val (Left); + R1 := abs (T / Base); + R2 := T rem Base; + Length_R := 2; + + else + R1 := abs (Udigits.Table (Uints.Table (Right).Loc)); + R2 := Udigits.Table (Uints.Table (Right).Loc + 1); + Length_R := Uints.Table (Right).Length; + end if; + + if Length_L = Length_R then + Right_Hat := R1 * Base + R2; + elsif Length_L = Length_R + Int_1 then + Right_Hat := R1; + else + Right_Hat := 0; + end if; + end; + end Most_Sig_2_Digits; + + --------------- + -- N_Digits -- + --------------- + + -- Note: N_Digits returns 1 for No_Uint + + function N_Digits (Input : Uint) return Int is + begin + if Direct (Input) then + if Direct_Val (Input) >= Base then + return 2; + else + return 1; + end if; + + else + return Uints.Table (Input).Length; + end if; + end N_Digits; + + -------------- + -- Num_Bits -- + -------------- + + function Num_Bits (Input : Uint) return Nat is + Bits : Nat; + Num : Nat; + + begin + -- Largest negative number has to be handled specially, since it is in + -- Int_Range, but we cannot take the absolute value. + + if Input = Uint_Int_First then + return Int'Size; + + -- For any other number in Int_Range, get absolute value of number + + elsif UI_Is_In_Int_Range (Input) then + Num := abs (UI_To_Int (Input)); + Bits := 0; + + -- If not in Int_Range then initialize bit count for all low order + -- words, and set number to high order digit. + + else + Bits := Base_Bits * (Uints.Table (Input).Length - 1); + Num := abs (Udigits.Table (Uints.Table (Input).Loc)); + end if; + + -- Increase bit count for remaining value in Num + + while Types.">" (Num, 0) loop + Num := Num / 2; + Bits := Bits + 1; + end loop; + + return Bits; + end Num_Bits; + + --------- + -- pid -- + --------- + + procedure pid (Input : Uint) is + begin + UI_Write (Input, Decimal); + Write_Eol; + end pid; + + --------- + -- pih -- + --------- + + procedure pih (Input : Uint) is + begin + UI_Write (Input, Hex); + Write_Eol; + end pih; + + ------------- + -- Release -- + ------------- + + procedure Release (M : Save_Mark) is + begin + Uints.Set_Last (Uint'Max (M.Save_Uint, Uints_Min)); + Udigits.Set_Last (Int'Max (M.Save_Udigit, Udigits_Min)); + end Release; + + ---------------------- + -- Release_And_Save -- + ---------------------- + + procedure Release_And_Save (M : Save_Mark; UI : in out Uint) is + begin + if Direct (UI) then + Release (M); + + else + declare + UE_Len : constant Pos := Uints.Table (UI).Length; + UE_Loc : constant Int := Uints.Table (UI).Loc; + + UD : constant Udigits.Table_Type (1 .. UE_Len) := + Udigits.Table (UE_Loc .. UE_Loc + UE_Len - 1); + + begin + Release (M); + + Uints.Append ((Length => UE_Len, Loc => Udigits.Last + 1)); + UI := Uints.Last; + + for J in 1 .. UE_Len loop + Udigits.Append (UD (J)); + end loop; + end; + end if; + end Release_And_Save; + + procedure Release_And_Save (M : Save_Mark; UI1, UI2 : in out Uint) is + begin + if Direct (UI1) then + Release_And_Save (M, UI2); + + elsif Direct (UI2) then + Release_And_Save (M, UI1); + + else + declare + UE1_Len : constant Pos := Uints.Table (UI1).Length; + UE1_Loc : constant Int := Uints.Table (UI1).Loc; + + UD1 : constant Udigits.Table_Type (1 .. UE1_Len) := + Udigits.Table (UE1_Loc .. UE1_Loc + UE1_Len - 1); + + UE2_Len : constant Pos := Uints.Table (UI2).Length; + UE2_Loc : constant Int := Uints.Table (UI2).Loc; + + UD2 : constant Udigits.Table_Type (1 .. UE2_Len) := + Udigits.Table (UE2_Loc .. UE2_Loc + UE2_Len - 1); + + begin + Release (M); + + Uints.Append ((Length => UE1_Len, Loc => Udigits.Last + 1)); + UI1 := Uints.Last; + + for J in 1 .. UE1_Len loop + Udigits.Append (UD1 (J)); + end loop; + + Uints.Append ((Length => UE2_Len, Loc => Udigits.Last + 1)); + UI2 := Uints.Last; + + for J in 1 .. UE2_Len loop + Udigits.Append (UD2 (J)); + end loop; + end; + end if; + end Release_And_Save; + + ---------------- + -- Sum_Digits -- + ---------------- + + -- This is done in one pass + + -- Mathematically: assume base congruent to 1 and compute an equivalent + -- integer to Left. + + -- If Sign = -1 return the alternating sum of the "digits" + + -- D1 - D2 + D3 - D4 + D5 ... + + -- (where D1 is Least Significant Digit) + + -- Mathematically: assume base congruent to -1 and compute an equivalent + -- integer to Left. + + -- This is used in Rem and Base is assumed to be 2 ** 15 + + -- Note: The next two functions are very similar, any style changes made + -- to one should be reflected in both. These would be simpler if we + -- worked base 2 ** 32. + + function Sum_Digits (Left : Uint; Sign : Int) return Int is + begin + pragma Assert (Sign = Int_1 or else Sign = Int (-1)); + + -- First try simple case; + + if Direct (Left) then + declare + Tmp_Int : Int := Direct_Val (Left); + + begin + if Tmp_Int >= Base then + Tmp_Int := (Tmp_Int / Base) + + Sign * (Tmp_Int rem Base); + + -- Now Tmp_Int is in [-(Base - 1) .. 2 * (Base - 1)] + + if Tmp_Int >= Base then + + -- Sign must be 1 + + Tmp_Int := (Tmp_Int / Base) + 1; + + end if; + + -- Now Tmp_Int is in [-(Base - 1) .. (Base - 1)] + + end if; + + return Tmp_Int; + end; + + -- Otherwise full circuit is needed + + else + declare + L_Length : constant Int := N_Digits (Left); + L_Vec : UI_Vector (1 .. L_Length); + Tmp_Int : Int; + Carry : Int; + Alt : Int; + + begin + Init_Operand (Left, L_Vec); + L_Vec (1) := abs L_Vec (1); + Tmp_Int := 0; + Carry := 0; + Alt := 1; + + for J in reverse 1 .. L_Length loop + Tmp_Int := Tmp_Int + Alt * (L_Vec (J) + Carry); + + -- Tmp_Int is now between [-2 * Base + 1 .. 2 * Base - 1], + -- since old Tmp_Int is between [-(Base - 1) .. Base - 1] + -- and L_Vec is in [0 .. Base - 1] and Carry in [-1 .. 1] + + if Tmp_Int >= Base then + Tmp_Int := Tmp_Int - Base; + Carry := 1; + + elsif Tmp_Int <= -Base then + Tmp_Int := Tmp_Int + Base; + Carry := -1; + + else + Carry := 0; + end if; + + -- Tmp_Int is now between [-Base + 1 .. Base - 1] + + Alt := Alt * Sign; + end loop; + + Tmp_Int := Tmp_Int + Alt * Carry; + + -- Tmp_Int is now between [-Base .. Base] + + if Tmp_Int >= Base then + Tmp_Int := Tmp_Int - Base + Alt * Sign * 1; + + elsif Tmp_Int <= -Base then + Tmp_Int := Tmp_Int + Base + Alt * Sign * (-1); + end if; + + -- Now Tmp_Int is in [-(Base - 1) .. (Base - 1)] + + return Tmp_Int; + end; + end if; + end Sum_Digits; + + ----------------------- + -- Sum_Double_Digits -- + ----------------------- + + -- Note: This is used in Rem, Base is assumed to be 2 ** 15 + + function Sum_Double_Digits (Left : Uint; Sign : Int) return Int is + begin + -- First try simple case; + + pragma Assert (Sign = Int_1 or else Sign = Int (-1)); + + if Direct (Left) then + return Direct_Val (Left); + + -- Otherwise full circuit is needed + + else + declare + L_Length : constant Int := N_Digits (Left); + L_Vec : UI_Vector (1 .. L_Length); + Most_Sig_Int : Int; + Least_Sig_Int : Int; + Carry : Int; + J : Int; + Alt : Int; + + begin + Init_Operand (Left, L_Vec); + L_Vec (1) := abs L_Vec (1); + Most_Sig_Int := 0; + Least_Sig_Int := 0; + Carry := 0; + Alt := 1; + J := L_Length; + + while J > Int_1 loop + Least_Sig_Int := Least_Sig_Int + Alt * (L_Vec (J) + Carry); + + -- Least is in [-2 Base + 1 .. 2 * Base - 1] + -- Since L_Vec in [0 .. Base - 1] and Carry in [-1 .. 1] + -- and old Least in [-Base + 1 .. Base - 1] + + if Least_Sig_Int >= Base then + Least_Sig_Int := Least_Sig_Int - Base; + Carry := 1; + + elsif Least_Sig_Int <= -Base then + Least_Sig_Int := Least_Sig_Int + Base; + Carry := -1; + + else + Carry := 0; + end if; + + -- Least is now in [-Base + 1 .. Base - 1] + + Most_Sig_Int := Most_Sig_Int + Alt * (L_Vec (J - 1) + Carry); + + -- Most is in [-2 Base + 1 .. 2 * Base - 1] + -- Since L_Vec in [0 .. Base - 1] and Carry in [-1 .. 1] + -- and old Most in [-Base + 1 .. Base - 1] + + if Most_Sig_Int >= Base then + Most_Sig_Int := Most_Sig_Int - Base; + Carry := 1; + + elsif Most_Sig_Int <= -Base then + Most_Sig_Int := Most_Sig_Int + Base; + Carry := -1; + else + Carry := 0; + end if; + + -- Most is now in [-Base + 1 .. Base - 1] + + J := J - 2; + Alt := Alt * Sign; + end loop; + + if J = Int_1 then + Least_Sig_Int := Least_Sig_Int + Alt * (L_Vec (J) + Carry); + else + Least_Sig_Int := Least_Sig_Int + Alt * Carry; + end if; + + if Least_Sig_Int >= Base then + Least_Sig_Int := Least_Sig_Int - Base; + Most_Sig_Int := Most_Sig_Int + Alt * 1; + + elsif Least_Sig_Int <= -Base then + Least_Sig_Int := Least_Sig_Int + Base; + Most_Sig_Int := Most_Sig_Int + Alt * (-1); + end if; + + if Most_Sig_Int >= Base then + Most_Sig_Int := Most_Sig_Int - Base; + Alt := Alt * Sign; + Least_Sig_Int := + Least_Sig_Int + Alt * 1; -- cannot overflow again + + elsif Most_Sig_Int <= -Base then + Most_Sig_Int := Most_Sig_Int + Base; + Alt := Alt * Sign; + Least_Sig_Int := + Least_Sig_Int + Alt * (-1); -- cannot overflow again. + end if; + + return Most_Sig_Int * Base + Least_Sig_Int; + end; + end if; + end Sum_Double_Digits; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + begin + Uints.Tree_Read; + Udigits.Tree_Read; + + Tree_Read_Int (Int (Uint_Int_First)); + Tree_Read_Int (Int (Uint_Int_Last)); + Tree_Read_Int (UI_Power_2_Set); + Tree_Read_Int (UI_Power_10_Set); + Tree_Read_Int (Int (Uints_Min)); + Tree_Read_Int (Udigits_Min); + + for J in 0 .. UI_Power_2_Set loop + Tree_Read_Int (Int (UI_Power_2 (J))); + end loop; + + for J in 0 .. UI_Power_10_Set loop + Tree_Read_Int (Int (UI_Power_10 (J))); + end loop; + + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + begin + Uints.Tree_Write; + Udigits.Tree_Write; + + Tree_Write_Int (Int (Uint_Int_First)); + Tree_Write_Int (Int (Uint_Int_Last)); + Tree_Write_Int (UI_Power_2_Set); + Tree_Write_Int (UI_Power_10_Set); + Tree_Write_Int (Int (Uints_Min)); + Tree_Write_Int (Udigits_Min); + + for J in 0 .. UI_Power_2_Set loop + Tree_Write_Int (Int (UI_Power_2 (J))); + end loop; + + for J in 0 .. UI_Power_10_Set loop + Tree_Write_Int (Int (UI_Power_10 (J))); + end loop; + + end Tree_Write; + + ------------- + -- UI_Abs -- + ------------- + + function UI_Abs (Right : Uint) return Uint is + begin + if Right < Uint_0 then + return -Right; + else + return Right; + end if; + end UI_Abs; + + ------------- + -- UI_Add -- + ------------- + + function UI_Add (Left : Int; Right : Uint) return Uint is + begin + return UI_Add (UI_From_Int (Left), Right); + end UI_Add; + + function UI_Add (Left : Uint; Right : Int) return Uint is + begin + return UI_Add (Left, UI_From_Int (Right)); + end UI_Add; + + function UI_Add (Left : Uint; Right : Uint) return Uint is + begin + -- Simple cases of direct operands and addition of zero + + if Direct (Left) then + if Direct (Right) then + return UI_From_Int (Direct_Val (Left) + Direct_Val (Right)); + + elsif Int (Left) = Int (Uint_0) then + return Right; + end if; + + elsif Direct (Right) and then Int (Right) = Int (Uint_0) then + return Left; + end if; + + -- Otherwise full circuit is needed + + declare + L_Length : constant Int := N_Digits (Left); + R_Length : constant Int := N_Digits (Right); + L_Vec : UI_Vector (1 .. L_Length); + R_Vec : UI_Vector (1 .. R_Length); + Sum_Length : Int; + Tmp_Int : Int; + Carry : Int; + Borrow : Int; + X_Bigger : Boolean := False; + Y_Bigger : Boolean := False; + Result_Neg : Boolean := False; + + begin + Init_Operand (Left, L_Vec); + Init_Operand (Right, R_Vec); + + -- At least one of the two operands is in multi-digit form. + -- Calculate the number of digits sufficient to hold result. + + if L_Length > R_Length then + Sum_Length := L_Length + 1; + X_Bigger := True; + else + Sum_Length := R_Length + 1; + + if R_Length > L_Length then + Y_Bigger := True; + end if; + end if; + + -- Make copies of the absolute values of L_Vec and R_Vec into X and Y + -- both with lengths equal to the maximum possibly needed. This makes + -- looping over the digits much simpler. + + declare + X : UI_Vector (1 .. Sum_Length); + Y : UI_Vector (1 .. Sum_Length); + Tmp_UI : UI_Vector (1 .. Sum_Length); + + begin + for J in 1 .. Sum_Length - L_Length loop + X (J) := 0; + end loop; + + X (Sum_Length - L_Length + 1) := abs L_Vec (1); + + for J in 2 .. L_Length loop + X (J + (Sum_Length - L_Length)) := L_Vec (J); + end loop; + + for J in 1 .. Sum_Length - R_Length loop + Y (J) := 0; + end loop; + + Y (Sum_Length - R_Length + 1) := abs R_Vec (1); + + for J in 2 .. R_Length loop + Y (J + (Sum_Length - R_Length)) := R_Vec (J); + end loop; + + if (L_Vec (1) < Int_0) = (R_Vec (1) < Int_0) then + + -- Same sign so just add + + Carry := 0; + for J in reverse 1 .. Sum_Length loop + Tmp_Int := X (J) + Y (J) + Carry; + + if Tmp_Int >= Base then + Tmp_Int := Tmp_Int - Base; + Carry := 1; + else + Carry := 0; + end if; + + X (J) := Tmp_Int; + end loop; + + return Vector_To_Uint (X, L_Vec (1) < Int_0); + + else + -- Find which one has bigger magnitude + + if not (X_Bigger or Y_Bigger) then + for J in L_Vec'Range loop + if abs L_Vec (J) > abs R_Vec (J) then + X_Bigger := True; + exit; + elsif abs R_Vec (J) > abs L_Vec (J) then + Y_Bigger := True; + exit; + end if; + end loop; + end if; + + -- If they have identical magnitude, just return 0, else swap + -- if necessary so that X had the bigger magnitude. Determine + -- if result is negative at this time. + + Result_Neg := False; + + if not (X_Bigger or Y_Bigger) then + return Uint_0; + + elsif Y_Bigger then + if R_Vec (1) < Int_0 then + Result_Neg := True; + end if; + + Tmp_UI := X; + X := Y; + Y := Tmp_UI; + + else + if L_Vec (1) < Int_0 then + Result_Neg := True; + end if; + end if; + + -- Subtract Y from the bigger X + + Borrow := 0; + + for J in reverse 1 .. Sum_Length loop + Tmp_Int := X (J) - Y (J) + Borrow; + + if Tmp_Int < Int_0 then + Tmp_Int := Tmp_Int + Base; + Borrow := -1; + else + Borrow := 0; + end if; + + X (J) := Tmp_Int; + end loop; + + return Vector_To_Uint (X, Result_Neg); + + end if; + end; + end; + end UI_Add; + + -------------------------- + -- UI_Decimal_Digits_Hi -- + -------------------------- + + function UI_Decimal_Digits_Hi (U : Uint) return Nat is + begin + -- The maximum value of a "digit" is 32767, which is 5 decimal digits, + -- so an N_Digit number could take up to 5 times this number of digits. + -- This is certainly too high for large numbers but it is not worth + -- worrying about. + + return 5 * N_Digits (U); + end UI_Decimal_Digits_Hi; + + -------------------------- + -- UI_Decimal_Digits_Lo -- + -------------------------- + + function UI_Decimal_Digits_Lo (U : Uint) return Nat is + begin + -- The maximum value of a "digit" is 32767, which is more than four + -- decimal digits, but not a full five digits. The easily computed + -- minimum number of decimal digits is thus 1 + 4 * the number of + -- digits. This is certainly too low for large numbers but it is not + -- worth worrying about. + + return 1 + 4 * (N_Digits (U) - 1); + end UI_Decimal_Digits_Lo; + + ------------ + -- UI_Div -- + ------------ + + function UI_Div (Left : Int; Right : Uint) return Uint is + begin + return UI_Div (UI_From_Int (Left), Right); + end UI_Div; + + function UI_Div (Left : Uint; Right : Int) return Uint is + begin + return UI_Div (Left, UI_From_Int (Right)); + end UI_Div; + + function UI_Div (Left, Right : Uint) return Uint is + Quotient : Uint; + Remainder : Uint; + pragma Warnings (Off, Remainder); + begin + UI_Div_Rem + (Left, Right, + Quotient, Remainder, + Discard_Remainder => True); + return Quotient; + end UI_Div; + + ---------------- + -- UI_Div_Rem -- + ---------------- + + procedure UI_Div_Rem + (Left, Right : Uint; + Quotient : out Uint; + Remainder : out Uint; + Discard_Quotient : Boolean := False; + Discard_Remainder : Boolean := False) + is + pragma Warnings (Off, Quotient); + pragma Warnings (Off, Remainder); + begin + pragma Assert (Right /= Uint_0); + + Quotient := No_Uint; + Remainder := No_Uint; + + -- Cases where both operands are represented directly + + if Direct (Left) and then Direct (Right) then + declare + DV_Left : constant Int := Direct_Val (Left); + DV_Right : constant Int := Direct_Val (Right); + + begin + if not Discard_Quotient then + Quotient := UI_From_Int (DV_Left / DV_Right); + end if; + + if not Discard_Remainder then + Remainder := UI_From_Int (DV_Left rem DV_Right); + end if; + + return; + end; + end if; + + declare + L_Length : constant Int := N_Digits (Left); + R_Length : constant Int := N_Digits (Right); + Q_Length : constant Int := L_Length - R_Length + 1; + L_Vec : UI_Vector (1 .. L_Length); + R_Vec : UI_Vector (1 .. R_Length); + D : Int; + Remainder_I : Int; + Tmp_Divisor : Int; + Carry : Int; + Tmp_Int : Int; + Tmp_Dig : Int; + + procedure UI_Div_Vector + (L_Vec : UI_Vector; + R_Int : Int; + Quotient : out UI_Vector; + Remainder : out Int); + pragma Inline (UI_Div_Vector); + -- Specialised variant for case where the divisor is a single digit + + procedure UI_Div_Vector + (L_Vec : UI_Vector; + R_Int : Int; + Quotient : out UI_Vector; + Remainder : out Int) + is + Tmp_Int : Int; + + begin + Remainder := 0; + for J in L_Vec'Range loop + Tmp_Int := Remainder * Base + abs L_Vec (J); + Quotient (Quotient'First + J - L_Vec'First) := Tmp_Int / R_Int; + Remainder := Tmp_Int rem R_Int; + end loop; + + if L_Vec (L_Vec'First) < Int_0 then + Remainder := -Remainder; + end if; + end UI_Div_Vector; + + -- Start of processing for UI_Div_Rem + + begin + -- Result is zero if left operand is shorter than right + + if L_Length < R_Length then + if not Discard_Quotient then + Quotient := Uint_0; + end if; + + if not Discard_Remainder then + Remainder := Left; + end if; + + return; + end if; + + Init_Operand (Left, L_Vec); + Init_Operand (Right, R_Vec); + + -- Case of right operand is single digit. Here we can simply divide + -- each digit of the left operand by the divisor, from most to least + -- significant, carrying the remainder to the next digit (just like + -- ordinary long division by hand). + + if R_Length = Int_1 then + Tmp_Divisor := abs R_Vec (1); + + declare + Quotient_V : UI_Vector (1 .. L_Length); + + begin + UI_Div_Vector (L_Vec, Tmp_Divisor, Quotient_V, Remainder_I); + + if not Discard_Quotient then + Quotient := + Vector_To_Uint + (Quotient_V, (L_Vec (1) < Int_0 xor R_Vec (1) < Int_0)); + end if; + + if not Discard_Remainder then + Remainder := UI_From_Int (Remainder_I); + end if; + + return; + end; + end if; + + -- The possible simple cases have been exhausted. Now turn to the + -- algorithm D from the section of Knuth mentioned at the top of + -- this package. + + Algorithm_D : declare + Dividend : UI_Vector (1 .. L_Length + 1); + Divisor : UI_Vector (1 .. R_Length); + Quotient_V : UI_Vector (1 .. Q_Length); + Divisor_Dig1 : Int; + Divisor_Dig2 : Int; + Q_Guess : Int; + + begin + -- [ NORMALIZE ] (step D1 in the algorithm). First calculate the + -- scale d, and then multiply Left and Right (u and v in the book) + -- by d to get the dividend and divisor to work with. + + D := Base / (abs R_Vec (1) + 1); + + Dividend (1) := 0; + Dividend (2) := abs L_Vec (1); + + for J in 3 .. L_Length + Int_1 loop + Dividend (J) := L_Vec (J - 1); + end loop; + + Divisor (1) := abs R_Vec (1); + + for J in Int_2 .. R_Length loop + Divisor (J) := R_Vec (J); + end loop; + + if D > Int_1 then + + -- Multiply Dividend by D + + Carry := 0; + for J in reverse Dividend'Range loop + Tmp_Int := Dividend (J) * D + Carry; + Dividend (J) := Tmp_Int rem Base; + Carry := Tmp_Int / Base; + end loop; + + -- Multiply Divisor by d + + Carry := 0; + for J in reverse Divisor'Range loop + Tmp_Int := Divisor (J) * D + Carry; + Divisor (J) := Tmp_Int rem Base; + Carry := Tmp_Int / Base; + end loop; + end if; + + -- Main loop of long division algorithm + + Divisor_Dig1 := Divisor (1); + Divisor_Dig2 := Divisor (2); + + for J in Quotient_V'Range loop + + -- [ CALCULATE Q (hat) ] (step D3 in the algorithm) + + Tmp_Int := Dividend (J) * Base + Dividend (J + 1); + + -- Initial guess + + if Dividend (J) = Divisor_Dig1 then + Q_Guess := Base - 1; + else + Q_Guess := Tmp_Int / Divisor_Dig1; + end if; + + -- Refine the guess + + while Divisor_Dig2 * Q_Guess > + (Tmp_Int - Q_Guess * Divisor_Dig1) * Base + + Dividend (J + 2) + loop + Q_Guess := Q_Guess - 1; + end loop; + + -- [ MULTIPLY & SUBTRACT ] (step D4). Q_Guess * Divisor is + -- subtracted from the remaining dividend. + + Carry := 0; + for K in reverse Divisor'Range loop + Tmp_Int := Dividend (J + K) - Q_Guess * Divisor (K) + Carry; + Tmp_Dig := Tmp_Int rem Base; + Carry := Tmp_Int / Base; + + if Tmp_Dig < Int_0 then + Tmp_Dig := Tmp_Dig + Base; + Carry := Carry - 1; + end if; + + Dividend (J + K) := Tmp_Dig; + end loop; + + Dividend (J) := Dividend (J) + Carry; + + -- [ TEST REMAINDER ] & [ ADD BACK ] (steps D5 and D6) + + -- Here there is a slight difference from the book: the last + -- carry is always added in above and below (cancelling each + -- other). In fact the dividend going negative is used as + -- the test. + + -- If the Dividend went negative, then Q_Guess was off by + -- one, so it is decremented, and the divisor is added back + -- into the relevant portion of the dividend. + + if Dividend (J) < Int_0 then + Q_Guess := Q_Guess - 1; + + Carry := 0; + for K in reverse Divisor'Range loop + Tmp_Int := Dividend (J + K) + Divisor (K) + Carry; + + if Tmp_Int >= Base then + Tmp_Int := Tmp_Int - Base; + Carry := 1; + else + Carry := 0; + end if; + + Dividend (J + K) := Tmp_Int; + end loop; + + Dividend (J) := Dividend (J) + Carry; + end if; + + -- Finally we can get the next quotient digit + + Quotient_V (J) := Q_Guess; + end loop; + + -- [ UNNORMALIZE ] (step D8) + + if not Discard_Quotient then + Quotient := Vector_To_Uint + (Quotient_V, (L_Vec (1) < Int_0 xor R_Vec (1) < Int_0)); + end if; + + if not Discard_Remainder then + declare + Remainder_V : UI_Vector (1 .. R_Length); + Discard_Int : Int; + pragma Warnings (Off, Discard_Int); + begin + UI_Div_Vector + (Dividend (Dividend'Last - R_Length + 1 .. Dividend'Last), + D, + Remainder_V, Discard_Int); + Remainder := Vector_To_Uint (Remainder_V, L_Vec (1) < Int_0); + end; + end if; + end Algorithm_D; + end; + end UI_Div_Rem; + + ------------ + -- UI_Eq -- + ------------ + + function UI_Eq (Left : Int; Right : Uint) return Boolean is + begin + return not UI_Ne (UI_From_Int (Left), Right); + end UI_Eq; + + function UI_Eq (Left : Uint; Right : Int) return Boolean is + begin + return not UI_Ne (Left, UI_From_Int (Right)); + end UI_Eq; + + function UI_Eq (Left : Uint; Right : Uint) return Boolean is + begin + return not UI_Ne (Left, Right); + end UI_Eq; + + -------------- + -- UI_Expon -- + -------------- + + function UI_Expon (Left : Int; Right : Uint) return Uint is + begin + return UI_Expon (UI_From_Int (Left), Right); + end UI_Expon; + + function UI_Expon (Left : Uint; Right : Int) return Uint is + begin + return UI_Expon (Left, UI_From_Int (Right)); + end UI_Expon; + + function UI_Expon (Left : Int; Right : Int) return Uint is + begin + return UI_Expon (UI_From_Int (Left), UI_From_Int (Right)); + end UI_Expon; + + function UI_Expon (Left : Uint; Right : Uint) return Uint is + begin + pragma Assert (Right >= Uint_0); + + -- Any value raised to power of 0 is 1 + + if Right = Uint_0 then + return Uint_1; + + -- 0 to any positive power is 0 + + elsif Left = Uint_0 then + return Uint_0; + + -- 1 to any power is 1 + + elsif Left = Uint_1 then + return Uint_1; + + -- Any value raised to power of 1 is that value + + elsif Right = Uint_1 then + return Left; + + -- Cases which can be done by table lookup + + elsif Right <= Uint_64 then + + -- 2 ** N for N in 2 .. 64 + + if Left = Uint_2 then + declare + Right_Int : constant Int := Direct_Val (Right); + + begin + if Right_Int > UI_Power_2_Set then + for J in UI_Power_2_Set + Int_1 .. Right_Int loop + UI_Power_2 (J) := UI_Power_2 (J - Int_1) * Int_2; + Uints_Min := Uints.Last; + Udigits_Min := Udigits.Last; + end loop; + + UI_Power_2_Set := Right_Int; + end if; + + return UI_Power_2 (Right_Int); + end; + + -- 10 ** N for N in 2 .. 64 + + elsif Left = Uint_10 then + declare + Right_Int : constant Int := Direct_Val (Right); + + begin + if Right_Int > UI_Power_10_Set then + for J in UI_Power_10_Set + Int_1 .. Right_Int loop + UI_Power_10 (J) := UI_Power_10 (J - Int_1) * Int (10); + Uints_Min := Uints.Last; + Udigits_Min := Udigits.Last; + end loop; + + UI_Power_10_Set := Right_Int; + end if; + + return UI_Power_10 (Right_Int); + end; + end if; + end if; + + -- If we fall through, then we have the general case (see Knuth 4.6.3) + + declare + N : Uint := Right; + Squares : Uint := Left; + Result : Uint := Uint_1; + M : constant Uintp.Save_Mark := Uintp.Mark; + + begin + loop + if (Least_Sig_Digit (N) mod Int_2) = Int_1 then + Result := Result * Squares; + end if; + + N := N / Uint_2; + exit when N = Uint_0; + Squares := Squares * Squares; + end loop; + + Uintp.Release_And_Save (M, Result); + return Result; + end; + end UI_Expon; + + ---------------- + -- UI_From_CC -- + ---------------- + + function UI_From_CC (Input : Char_Code) return Uint is + begin + return UI_From_Int (Int (Input)); + end UI_From_CC; + + ----------------- + -- UI_From_Int -- + ----------------- + + function UI_From_Int (Input : Int) return Uint is + U : Uint; + + begin + if Min_Direct <= Input and then Input <= Max_Direct then + return Uint (Int (Uint_Direct_Bias) + Input); + end if; + + -- If already in the hash table, return entry + + U := UI_Ints.Get (Input); + + if U /= No_Uint then + return U; + end if; + + -- For values of larger magnitude, compute digits into a vector and call + -- Vector_To_Uint. + + declare + Max_For_Int : constant := 3; + -- Base is defined so that 3 Uint digits is sufficient to hold the + -- largest possible Int value. + + V : UI_Vector (1 .. Max_For_Int); + + Temp_Integer : Int := Input; + + begin + for J in reverse V'Range loop + V (J) := abs (Temp_Integer rem Base); + Temp_Integer := Temp_Integer / Base; + end loop; + + U := Vector_To_Uint (V, Input < Int_0); + UI_Ints.Set (Input, U); + Uints_Min := Uints.Last; + Udigits_Min := Udigits.Last; + return U; + end; + end UI_From_Int; + + ------------ + -- UI_GCD -- + ------------ + + -- Lehmer's algorithm for GCD + + -- The idea is to avoid using multiple precision arithmetic wherever + -- possible, substituting Int arithmetic instead. See Knuth volume II, + -- Algorithm L (page 329). + + -- We use the same notation as Knuth (U_Hat standing for the obvious!) + + function UI_GCD (Uin, Vin : Uint) return Uint is + U, V : Uint; + -- Copies of Uin and Vin + + U_Hat, V_Hat : Int; + -- The most Significant digits of U,V + + A, B, C, D, T, Q, Den1, Den2 : Int; + + Tmp_UI : Uint; + Marks : constant Uintp.Save_Mark := Uintp.Mark; + Iterations : Integer := 0; + + begin + pragma Assert (Uin >= Vin); + pragma Assert (Vin >= Uint_0); + + U := Uin; + V := Vin; + + loop + Iterations := Iterations + 1; + + if Direct (V) then + if V = Uint_0 then + return U; + else + return + UI_From_Int (GCD (Direct_Val (V), UI_To_Int (U rem V))); + end if; + end if; + + Most_Sig_2_Digits (U, V, U_Hat, V_Hat); + A := 1; + B := 0; + C := 0; + D := 1; + + loop + -- We might overflow and get division by zero here. This just + -- means we cannot take the single precision step + + Den1 := V_Hat + C; + Den2 := V_Hat + D; + exit when Den1 = Int_0 or else Den2 = Int_0; + + -- Compute Q, the trial quotient + + Q := (U_Hat + A) / Den1; + + exit when Q /= ((U_Hat + B) / Den2); + + -- A single precision step Euclid step will give same answer as a + -- multiprecision one. + + T := A - (Q * C); + A := C; + C := T; + + T := B - (Q * D); + B := D; + D := T; + + T := U_Hat - (Q * V_Hat); + U_Hat := V_Hat; + V_Hat := T; + + end loop; + + -- Take a multiprecision Euclid step + + if B = Int_0 then + + -- No single precision steps take a regular Euclid step + + Tmp_UI := U rem V; + U := V; + V := Tmp_UI; + + else + -- Use prior single precision steps to compute this Euclid step + + -- For constructs such as: + -- sqrt_2: constant := 1.41421_35623_73095_04880_16887_24209_698; + -- sqrt_eps: constant long_float := long_float( 1.0 / sqrt_2) + -- ** long_float'machine_mantissa; + -- + -- we spend 80% of our time working on this step. Perhaps we need + -- a special case Int / Uint dot product to speed things up. ??? + + -- Alternatively we could increase the single precision iterations + -- to handle Uint's of some small size ( <5 digits?). Then we + -- would have more iterations on small Uint. On the code above, we + -- only get 5 (on average) single precision iterations per large + -- iteration. ??? + + Tmp_UI := (UI_From_Int (A) * U) + (UI_From_Int (B) * V); + V := (UI_From_Int (C) * U) + (UI_From_Int (D) * V); + U := Tmp_UI; + end if; + + -- If the operands are very different in magnitude, the loop will + -- generate large amounts of short-lived data, which it is worth + -- removing periodically. + + if Iterations > 100 then + Release_And_Save (Marks, U, V); + Iterations := 0; + end if; + end loop; + end UI_GCD; + + ------------ + -- UI_Ge -- + ------------ + + function UI_Ge (Left : Int; Right : Uint) return Boolean is + begin + return not UI_Lt (UI_From_Int (Left), Right); + end UI_Ge; + + function UI_Ge (Left : Uint; Right : Int) return Boolean is + begin + return not UI_Lt (Left, UI_From_Int (Right)); + end UI_Ge; + + function UI_Ge (Left : Uint; Right : Uint) return Boolean is + begin + return not UI_Lt (Left, Right); + end UI_Ge; + + ------------ + -- UI_Gt -- + ------------ + + function UI_Gt (Left : Int; Right : Uint) return Boolean is + begin + return UI_Lt (Right, UI_From_Int (Left)); + end UI_Gt; + + function UI_Gt (Left : Uint; Right : Int) return Boolean is + begin + return UI_Lt (UI_From_Int (Right), Left); + end UI_Gt; + + function UI_Gt (Left : Uint; Right : Uint) return Boolean is + begin + return UI_Lt (Left => Right, Right => Left); + end UI_Gt; + + --------------- + -- UI_Image -- + --------------- + + procedure UI_Image (Input : Uint; Format : UI_Format := Auto) is + begin + Image_Out (Input, True, Format); + end UI_Image; + + ------------------------- + -- UI_Is_In_Int_Range -- + ------------------------- + + function UI_Is_In_Int_Range (Input : Uint) return Boolean is + begin + -- Make sure we don't get called before Initialize + + pragma Assert (Uint_Int_First /= Uint_0); + + if Direct (Input) then + return True; + else + return Input >= Uint_Int_First + and then Input <= Uint_Int_Last; + end if; + end UI_Is_In_Int_Range; + + ------------ + -- UI_Le -- + ------------ + + function UI_Le (Left : Int; Right : Uint) return Boolean is + begin + return not UI_Lt (Right, UI_From_Int (Left)); + end UI_Le; + + function UI_Le (Left : Uint; Right : Int) return Boolean is + begin + return not UI_Lt (UI_From_Int (Right), Left); + end UI_Le; + + function UI_Le (Left : Uint; Right : Uint) return Boolean is + begin + return not UI_Lt (Left => Right, Right => Left); + end UI_Le; + + ------------ + -- UI_Lt -- + ------------ + + function UI_Lt (Left : Int; Right : Uint) return Boolean is + begin + return UI_Lt (UI_From_Int (Left), Right); + end UI_Lt; + + function UI_Lt (Left : Uint; Right : Int) return Boolean is + begin + return UI_Lt (Left, UI_From_Int (Right)); + end UI_Lt; + + function UI_Lt (Left : Uint; Right : Uint) return Boolean is + begin + -- Quick processing for identical arguments + + if Int (Left) = Int (Right) then + return False; + + -- Quick processing for both arguments directly represented + + elsif Direct (Left) and then Direct (Right) then + return Int (Left) < Int (Right); + + -- At least one argument is more than one digit long + + else + declare + L_Length : constant Int := N_Digits (Left); + R_Length : constant Int := N_Digits (Right); + + L_Vec : UI_Vector (1 .. L_Length); + R_Vec : UI_Vector (1 .. R_Length); + + begin + Init_Operand (Left, L_Vec); + Init_Operand (Right, R_Vec); + + if L_Vec (1) < Int_0 then + + -- First argument negative, second argument non-negative + + if R_Vec (1) >= Int_0 then + return True; + + -- Both arguments negative + + else + if L_Length /= R_Length then + return L_Length > R_Length; + + elsif L_Vec (1) /= R_Vec (1) then + return L_Vec (1) < R_Vec (1); + + else + for J in 2 .. L_Vec'Last loop + if L_Vec (J) /= R_Vec (J) then + return L_Vec (J) > R_Vec (J); + end if; + end loop; + + return False; + end if; + end if; + + else + -- First argument non-negative, second argument negative + + if R_Vec (1) < Int_0 then + return False; + + -- Both arguments non-negative + + else + if L_Length /= R_Length then + return L_Length < R_Length; + else + for J in L_Vec'Range loop + if L_Vec (J) /= R_Vec (J) then + return L_Vec (J) < R_Vec (J); + end if; + end loop; + + return False; + end if; + end if; + end if; + end; + end if; + end UI_Lt; + + ------------ + -- UI_Max -- + ------------ + + function UI_Max (Left : Int; Right : Uint) return Uint is + begin + return UI_Max (UI_From_Int (Left), Right); + end UI_Max; + + function UI_Max (Left : Uint; Right : Int) return Uint is + begin + return UI_Max (Left, UI_From_Int (Right)); + end UI_Max; + + function UI_Max (Left : Uint; Right : Uint) return Uint is + begin + if Left >= Right then + return Left; + else + return Right; + end if; + end UI_Max; + + ------------ + -- UI_Min -- + ------------ + + function UI_Min (Left : Int; Right : Uint) return Uint is + begin + return UI_Min (UI_From_Int (Left), Right); + end UI_Min; + + function UI_Min (Left : Uint; Right : Int) return Uint is + begin + return UI_Min (Left, UI_From_Int (Right)); + end UI_Min; + + function UI_Min (Left : Uint; Right : Uint) return Uint is + begin + if Left <= Right then + return Left; + else + return Right; + end if; + end UI_Min; + + ------------- + -- UI_Mod -- + ------------- + + function UI_Mod (Left : Int; Right : Uint) return Uint is + begin + return UI_Mod (UI_From_Int (Left), Right); + end UI_Mod; + + function UI_Mod (Left : Uint; Right : Int) return Uint is + begin + return UI_Mod (Left, UI_From_Int (Right)); + end UI_Mod; + + function UI_Mod (Left : Uint; Right : Uint) return Uint is + Urem : constant Uint := Left rem Right; + + begin + if (Left < Uint_0) = (Right < Uint_0) + or else Urem = Uint_0 + then + return Urem; + else + return Right + Urem; + end if; + end UI_Mod; + + ------------------------------- + -- UI_Modular_Exponentiation -- + ------------------------------- + + function UI_Modular_Exponentiation + (B : Uint; + E : Uint; + Modulo : Uint) return Uint + is + M : constant Save_Mark := Mark; + + Result : Uint := Uint_1; + Base : Uint := B; + Exponent : Uint := E; + + begin + while Exponent /= Uint_0 loop + if Least_Sig_Digit (Exponent) rem Int'(2) = Int'(1) then + Result := (Result * Base) rem Modulo; + end if; + + Exponent := Exponent / Uint_2; + Base := (Base * Base) rem Modulo; + end loop; + + Release_And_Save (M, Result); + return Result; + end UI_Modular_Exponentiation; + + ------------------------ + -- UI_Modular_Inverse -- + ------------------------ + + function UI_Modular_Inverse (N : Uint; Modulo : Uint) return Uint is + M : constant Save_Mark := Mark; + U : Uint; + V : Uint; + Q : Uint; + R : Uint; + X : Uint; + Y : Uint; + T : Uint; + S : Int := 1; + + begin + U := Modulo; + V := N; + + X := Uint_1; + Y := Uint_0; + + loop + UI_Div_Rem (U, V, Quotient => Q, Remainder => R); + + U := V; + V := R; + + T := X; + X := Y + Q * X; + Y := T; + S := -S; + + exit when R = Uint_1; + end loop; + + if S = Int'(-1) then + X := Modulo - X; + end if; + + Release_And_Save (M, X); + return X; + end UI_Modular_Inverse; + + ------------ + -- UI_Mul -- + ------------ + + function UI_Mul (Left : Int; Right : Uint) return Uint is + begin + return UI_Mul (UI_From_Int (Left), Right); + end UI_Mul; + + function UI_Mul (Left : Uint; Right : Int) return Uint is + begin + return UI_Mul (Left, UI_From_Int (Right)); + end UI_Mul; + + function UI_Mul (Left : Uint; Right : Uint) return Uint is + begin + -- Case where product fits in the range of a 32-bit integer + + if Int (Left) <= Int (Uint_Max_Simple_Mul) + and then + Int (Right) <= Int (Uint_Max_Simple_Mul) + then + return UI_From_Int (Direct_Val (Left) * Direct_Val (Right)); + end if; + + -- Otherwise we have the general case (Algorithm M in Knuth) + + declare + L_Length : constant Int := N_Digits (Left); + R_Length : constant Int := N_Digits (Right); + L_Vec : UI_Vector (1 .. L_Length); + R_Vec : UI_Vector (1 .. R_Length); + Neg : Boolean; + + begin + Init_Operand (Left, L_Vec); + Init_Operand (Right, R_Vec); + Neg := (L_Vec (1) < Int_0) xor (R_Vec (1) < Int_0); + L_Vec (1) := abs (L_Vec (1)); + R_Vec (1) := abs (R_Vec (1)); + + Algorithm_M : declare + Product : UI_Vector (1 .. L_Length + R_Length); + Tmp_Sum : Int; + Carry : Int; + + begin + for J in Product'Range loop + Product (J) := 0; + end loop; + + for J in reverse R_Vec'Range loop + Carry := 0; + for K in reverse L_Vec'Range loop + Tmp_Sum := + L_Vec (K) * R_Vec (J) + Product (J + K) + Carry; + Product (J + K) := Tmp_Sum rem Base; + Carry := Tmp_Sum / Base; + end loop; + + Product (J) := Carry; + end loop; + + return Vector_To_Uint (Product, Neg); + end Algorithm_M; + end; + end UI_Mul; + + ------------ + -- UI_Ne -- + ------------ + + function UI_Ne (Left : Int; Right : Uint) return Boolean is + begin + return UI_Ne (UI_From_Int (Left), Right); + end UI_Ne; + + function UI_Ne (Left : Uint; Right : Int) return Boolean is + begin + return UI_Ne (Left, UI_From_Int (Right)); + end UI_Ne; + + function UI_Ne (Left : Uint; Right : Uint) return Boolean is + begin + -- Quick processing for identical arguments. Note that this takes + -- care of the case of two No_Uint arguments. + + if Int (Left) = Int (Right) then + return False; + end if; + + -- See if left operand directly represented + + if Direct (Left) then + + -- If right operand directly represented then compare + + if Direct (Right) then + return Int (Left) /= Int (Right); + + -- Left operand directly represented, right not, must be unequal + + else + return True; + end if; + + -- Right operand directly represented, left not, must be unequal + + elsif Direct (Right) then + return True; + end if; + + -- Otherwise both multi-word, do comparison + + declare + Size : constant Int := N_Digits (Left); + Left_Loc : Int; + Right_Loc : Int; + + begin + if Size /= N_Digits (Right) then + return True; + end if; + + Left_Loc := Uints.Table (Left).Loc; + Right_Loc := Uints.Table (Right).Loc; + + for J in Int_0 .. Size - Int_1 loop + if Udigits.Table (Left_Loc + J) /= + Udigits.Table (Right_Loc + J) + then + return True; + end if; + end loop; + + return False; + end; + end UI_Ne; + + ---------------- + -- UI_Negate -- + ---------------- + + function UI_Negate (Right : Uint) return Uint is + begin + -- Case where input is directly represented. Note that since the range + -- of Direct values is non-symmetrical, the result may not be directly + -- represented, this is taken care of in UI_From_Int. + + if Direct (Right) then + return UI_From_Int (-Direct_Val (Right)); + + -- Full processing for multi-digit case. Note that we cannot just copy + -- the value to the end of the table negating the first digit, since the + -- range of Direct values is non-symmetrical, so we can have a negative + -- value that is not Direct whose negation can be represented directly. + + else + declare + R_Length : constant Int := N_Digits (Right); + R_Vec : UI_Vector (1 .. R_Length); + Neg : Boolean; + + begin + Init_Operand (Right, R_Vec); + Neg := R_Vec (1) > Int_0; + R_Vec (1) := abs R_Vec (1); + return Vector_To_Uint (R_Vec, Neg); + end; + end if; + end UI_Negate; + + ------------- + -- UI_Rem -- + ------------- + + function UI_Rem (Left : Int; Right : Uint) return Uint is + begin + return UI_Rem (UI_From_Int (Left), Right); + end UI_Rem; + + function UI_Rem (Left : Uint; Right : Int) return Uint is + begin + return UI_Rem (Left, UI_From_Int (Right)); + end UI_Rem; + + function UI_Rem (Left, Right : Uint) return Uint is + Sign : Int; + Tmp : Int; + + subtype Int1_12 is Integer range 1 .. 12; + + begin + pragma Assert (Right /= Uint_0); + + if Direct (Right) then + if Direct (Left) then + return UI_From_Int (Direct_Val (Left) rem Direct_Val (Right)); + + else + + -- Special cases when Right is less than 13 and Left is larger + -- larger than one digit. All of these algorithms depend on the + -- base being 2 ** 15 We work with Abs (Left) and Abs(Right) + -- then multiply result by Sign (Left) + + if (Right <= Uint_12) and then (Right >= Uint_Minus_12) then + + if Left < Uint_0 then + Sign := -1; + else + Sign := 1; + end if; + + -- All cases are listed, grouped by mathematical method It is + -- not inefficient to do have this case list out of order since + -- GCC sorts the cases we list. + + case Int1_12 (abs (Direct_Val (Right))) is + + when 1 => + return Uint_0; + + -- Powers of two are simple AND's with LS Left Digit GCC + -- will recognise these constants as powers of 2 and replace + -- the rem with simpler operations where possible. + + -- Least_Sig_Digit might return Negative numbers + + when 2 => + return UI_From_Int ( + Sign * (Least_Sig_Digit (Left) mod 2)); + + when 4 => + return UI_From_Int ( + Sign * (Least_Sig_Digit (Left) mod 4)); + + when 8 => + return UI_From_Int ( + Sign * (Least_Sig_Digit (Left) mod 8)); + + -- Some number theoretical tricks: + + -- If B Rem Right = 1 then + -- Left Rem Right = Sum_Of_Digits_Base_B (Left) Rem Right + + -- Note: 2^32 mod 3 = 1 + + when 3 => + return UI_From_Int ( + Sign * (Sum_Double_Digits (Left, 1) rem Int (3))); + + -- Note: 2^15 mod 7 = 1 + + when 7 => + return UI_From_Int ( + Sign * (Sum_Digits (Left, 1) rem Int (7))); + + -- Note: 2^32 mod 5 = -1 + + -- Alternating sums might be negative, but rem is always + -- positive hence we must use mod here. + + when 5 => + Tmp := Sum_Double_Digits (Left, -1) mod Int (5); + return UI_From_Int (Sign * Tmp); + + -- Note: 2^15 mod 9 = -1 + + -- Alternating sums might be negative, but rem is always + -- positive hence we must use mod here. + + when 9 => + Tmp := Sum_Digits (Left, -1) mod Int (9); + return UI_From_Int (Sign * Tmp); + + -- Note: 2^15 mod 11 = -1 + + -- Alternating sums might be negative, but rem is always + -- positive hence we must use mod here. + + when 11 => + Tmp := Sum_Digits (Left, -1) mod Int (11); + return UI_From_Int (Sign * Tmp); + + -- Now resort to Chinese Remainder theorem to reduce 6, 10, + -- 12 to previous special cases + + -- There is no reason we could not add more cases like these + -- if it proves useful. + + -- Perhaps we should go up to 16, however we have no "trick" + -- for 13. + + -- To find u mod m we: + + -- Pick m1, m2 S.T. + -- GCD(m1, m2) = 1 AND m = (m1 * m2). + + -- Next we pick (Basis) M1, M2 small S.T. + -- (M1 mod m1) = (M2 mod m2) = 1 AND + -- (M1 mod m2) = (M2 mod m1) = 0 + + -- So u mod m = (u1 * M1 + u2 * M2) mod m Where u1 = (u mod + -- m1) AND u2 = (u mod m2); Under typical circumstances the + -- last mod m can be done with a (possible) single + -- subtraction. + + -- m1 = 2; m2 = 3; M1 = 3; M2 = 4; + + when 6 => + Tmp := 3 * (Least_Sig_Digit (Left) rem 2) + + 4 * (Sum_Double_Digits (Left, 1) rem 3); + return UI_From_Int (Sign * (Tmp rem 6)); + + -- m1 = 2; m2 = 5; M1 = 5; M2 = 6; + + when 10 => + Tmp := 5 * (Least_Sig_Digit (Left) rem 2) + + 6 * (Sum_Double_Digits (Left, -1) mod 5); + return UI_From_Int (Sign * (Tmp rem 10)); + + -- m1 = 3; m2 = 4; M1 = 4; M2 = 9; + + when 12 => + Tmp := 4 * (Sum_Double_Digits (Left, 1) rem 3) + + 9 * (Least_Sig_Digit (Left) rem 4); + return UI_From_Int (Sign * (Tmp rem 12)); + end case; + + end if; + + -- Else fall through to general case + + -- The special case Length (Left) = Length (Right) = 1 in Div + -- looks slow. It uses UI_To_Int when Int should suffice. ??? + end if; + end if; + + declare + Remainder : Uint; + Quotient : Uint; + pragma Warnings (Off, Quotient); + begin + UI_Div_Rem + (Left, Right, Quotient, Remainder, Discard_Quotient => True); + return Remainder; + end; + end UI_Rem; + + ------------ + -- UI_Sub -- + ------------ + + function UI_Sub (Left : Int; Right : Uint) return Uint is + begin + return UI_Add (Left, -Right); + end UI_Sub; + + function UI_Sub (Left : Uint; Right : Int) return Uint is + begin + return UI_Add (Left, -Right); + end UI_Sub; + + function UI_Sub (Left : Uint; Right : Uint) return Uint is + begin + if Direct (Left) and then Direct (Right) then + return UI_From_Int (Direct_Val (Left) - Direct_Val (Right)); + else + return UI_Add (Left, -Right); + end if; + end UI_Sub; + + -------------- + -- UI_To_CC -- + -------------- + + function UI_To_CC (Input : Uint) return Char_Code is + begin + if Direct (Input) then + return Char_Code (Direct_Val (Input)); + + -- Case of input is more than one digit + + else + declare + In_Length : constant Int := N_Digits (Input); + In_Vec : UI_Vector (1 .. In_Length); + Ret_CC : Char_Code; + + begin + Init_Operand (Input, In_Vec); + + -- We assume value is positive + + Ret_CC := 0; + for Idx in In_Vec'Range loop + Ret_CC := Ret_CC * Char_Code (Base) + + Char_Code (abs In_Vec (Idx)); + end loop; + + return Ret_CC; + end; + end if; + end UI_To_CC; + + ---------------- + -- UI_To_Int -- + ---------------- + + function UI_To_Int (Input : Uint) return Int is + begin + if Direct (Input) then + return Direct_Val (Input); + + -- Case of input is more than one digit + + else + declare + In_Length : constant Int := N_Digits (Input); + In_Vec : UI_Vector (1 .. In_Length); + Ret_Int : Int; + + begin + -- Uints of more than one digit could be outside the range for + -- Ints. Caller should have checked for this if not certain. + -- Fatal error to attempt to convert from value outside Int'Range. + + pragma Assert (UI_Is_In_Int_Range (Input)); + + -- Otherwise, proceed ahead, we are OK + + Init_Operand (Input, In_Vec); + Ret_Int := 0; + + -- Calculate -|Input| and then negates if value is positive. This + -- handles our current definition of Int (based on 2s complement). + -- Is it secure enough??? + + for Idx in In_Vec'Range loop + Ret_Int := Ret_Int * Base - abs In_Vec (Idx); + end loop; + + if In_Vec (1) < Int_0 then + return Ret_Int; + else + return -Ret_Int; + end if; + end; + end if; + end UI_To_Int; + + -------------- + -- UI_Write -- + -------------- + + procedure UI_Write (Input : Uint; Format : UI_Format := Auto) is + begin + Image_Out (Input, False, Format); + end UI_Write; + + --------------------- + -- Vector_To_Uint -- + --------------------- + + function Vector_To_Uint + (In_Vec : UI_Vector; + Negative : Boolean) + return Uint + is + Size : Int; + Val : Int; + + begin + -- The vector can contain leading zeros. These are not stored in the + -- table, so loop through the vector looking for first non-zero digit + + for J in In_Vec'Range loop + if In_Vec (J) /= Int_0 then + + -- The length of the value is the length of the rest of the vector + + Size := In_Vec'Last - J + 1; + + -- One digit value can always be represented directly + + if Size = Int_1 then + if Negative then + return Uint (Int (Uint_Direct_Bias) - In_Vec (J)); + else + return Uint (Int (Uint_Direct_Bias) + In_Vec (J)); + end if; + + -- Positive two digit values may be in direct representation range + + elsif Size = Int_2 and then not Negative then + Val := In_Vec (J) * Base + In_Vec (J + 1); + + if Val <= Max_Direct then + return Uint (Int (Uint_Direct_Bias) + Val); + end if; + end if; + + -- The value is outside the direct representation range and must + -- therefore be stored in the table. Expand the table to contain + -- the count and digits. The index of the new table entry will be + -- returned as the result. + + Uints.Append ((Length => Size, Loc => Udigits.Last + 1)); + + if Negative then + Val := -In_Vec (J); + else + Val := +In_Vec (J); + end if; + + Udigits.Append (Val); + + for K in 2 .. Size loop + Udigits.Append (In_Vec (J + K - 1)); + end loop; + + return Uints.Last; + end if; + end loop; + + -- Dropped through loop only if vector contained all zeros + + return Uint_0; + end Vector_To_Uint; + +end Uintp; diff --git a/gcc/ada/uintp.ads b/gcc/ada/uintp.ads new file mode 100644 index 000000000..388637167 --- /dev/null +++ b/gcc/ada/uintp.ads @@ -0,0 +1,540 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- U I N T P -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Support for universal integer arithmetic + +-- WARNING: There is a C version of this package. Any changes to this +-- source file must be properly reflected in the C header file sinfo.h + +with Alloc; +with Table; +pragma Elaborate_All (Table); +with Types; use Types; + +package Uintp is + + ------------------------------------------------- + -- Basic Types and Constants for Uintp Package -- + ------------------------------------------------- + + type Uint is private; + -- The basic universal integer type + + No_Uint : constant Uint; + -- A constant value indicating a missing or unset Uint value + + Uint_0 : constant Uint; + Uint_1 : constant Uint; + Uint_2 : constant Uint; + Uint_3 : constant Uint; + Uint_4 : constant Uint; + Uint_5 : constant Uint; + Uint_6 : constant Uint; + Uint_7 : constant Uint; + Uint_8 : constant Uint; + Uint_9 : constant Uint; + Uint_10 : constant Uint; + Uint_11 : constant Uint; + Uint_12 : constant Uint; + Uint_13 : constant Uint; + Uint_14 : constant Uint; + Uint_15 : constant Uint; + Uint_16 : constant Uint; + Uint_24 : constant Uint; + Uint_32 : constant Uint; + Uint_63 : constant Uint; + Uint_64 : constant Uint; + Uint_80 : constant Uint; + Uint_128 : constant Uint; + + Uint_Minus_1 : constant Uint; + Uint_Minus_2 : constant Uint; + Uint_Minus_3 : constant Uint; + Uint_Minus_4 : constant Uint; + Uint_Minus_5 : constant Uint; + Uint_Minus_6 : constant Uint; + Uint_Minus_7 : constant Uint; + Uint_Minus_8 : constant Uint; + Uint_Minus_9 : constant Uint; + Uint_Minus_12 : constant Uint; + Uint_Minus_36 : constant Uint; + Uint_Minus_63 : constant Uint; + Uint_Minus_80 : constant Uint; + Uint_Minus_128 : constant Uint; + + ----------------- + -- Subprograms -- + ----------------- + + procedure Initialize; + -- Initialize Uint tables. Note that Initialize must not be called if + -- Tree_Read is used. Note also that there is no lock routine in this + -- unit, these are among the few tables that can be expanded during + -- gigi processing. + + procedure Tree_Read; + -- Initializes internal tables from current tree file using the relevant + -- Table.Tree_Read routines. Note that Initialize should not be called if + -- Tree_Read is used. Tree_Read includes all necessary initialization. + + procedure Tree_Write; + -- Writes out internal tables to current tree file using the relevant + -- Table.Tree_Write routines. + + function UI_Abs (Right : Uint) return Uint; + pragma Inline (UI_Abs); + -- Returns abs function of universal integer + + function UI_Add (Left : Uint; Right : Uint) return Uint; + function UI_Add (Left : Int; Right : Uint) return Uint; + function UI_Add (Left : Uint; Right : Int) return Uint; + -- Returns sum of two integer values + + function UI_Decimal_Digits_Hi (U : Uint) return Nat; + -- Returns an estimate of the number of decimal digits required to + -- represent the absolute value of U. This estimate is correct or high, + -- i.e. it never returns a value that is too low. The accuracy of the + -- estimate affects only the effectiveness of comparison optimizations + -- in Urealp. + + function UI_Decimal_Digits_Lo (U : Uint) return Nat; + -- Returns an estimate of the number of decimal digits required to + -- represent the absolute value of U. This estimate is correct or low, + -- i.e. it never returns a value that is too high. The accuracy of the + -- estimate affects only the effectiveness of comparison optimizations + -- in Urealp. + + function UI_Div (Left : Uint; Right : Uint) return Uint; + function UI_Div (Left : Int; Right : Uint) return Uint; + function UI_Div (Left : Uint; Right : Int) return Uint; + -- Returns quotient of two integer values. Fatal error if Right = 0 + + function UI_Eq (Left : Uint; Right : Uint) return Boolean; + function UI_Eq (Left : Int; Right : Uint) return Boolean; + function UI_Eq (Left : Uint; Right : Int) return Boolean; + pragma Inline (UI_Eq); + -- Compares integer values for equality + + function UI_Expon (Left : Uint; Right : Uint) return Uint; + function UI_Expon (Left : Int; Right : Uint) return Uint; + function UI_Expon (Left : Uint; Right : Int) return Uint; + function UI_Expon (Left : Int; Right : Int) return Uint; + -- Returns result of exponentiating two integer values. + -- Fatal error if Right is negative. + + function UI_GCD (Uin, Vin : Uint) return Uint; + -- Computes GCD of input values. Assumes Uin >= Vin >= 0 + + function UI_Ge (Left : Uint; Right : Uint) return Boolean; + function UI_Ge (Left : Int; Right : Uint) return Boolean; + function UI_Ge (Left : Uint; Right : Int) return Boolean; + pragma Inline (UI_Ge); + -- Compares integer values for greater than or equal + + function UI_Gt (Left : Uint; Right : Uint) return Boolean; + function UI_Gt (Left : Int; Right : Uint) return Boolean; + function UI_Gt (Left : Uint; Right : Int) return Boolean; + pragma Inline (UI_Gt); + -- Compares integer values for greater than + + function UI_Is_In_Int_Range (Input : Uint) return Boolean; + pragma Inline (UI_Is_In_Int_Range); + -- Determines if universal integer is in Int range + + function UI_Le (Left : Uint; Right : Uint) return Boolean; + function UI_Le (Left : Int; Right : Uint) return Boolean; + function UI_Le (Left : Uint; Right : Int) return Boolean; + pragma Inline (UI_Le); + -- Compares integer values for less than or equal + + function UI_Lt (Left : Uint; Right : Uint) return Boolean; + function UI_Lt (Left : Int; Right : Uint) return Boolean; + function UI_Lt (Left : Uint; Right : Int) return Boolean; + -- Compares integer values for less than + + function UI_Max (Left : Uint; Right : Uint) return Uint; + function UI_Max (Left : Int; Right : Uint) return Uint; + function UI_Max (Left : Uint; Right : Int) return Uint; + -- Returns maximum of two integer values + + function UI_Min (Left : Uint; Right : Uint) return Uint; + function UI_Min (Left : Int; Right : Uint) return Uint; + function UI_Min (Left : Uint; Right : Int) return Uint; + -- Returns minimum of two integer values + + function UI_Mod (Left : Uint; Right : Uint) return Uint; + function UI_Mod (Left : Int; Right : Uint) return Uint; + function UI_Mod (Left : Uint; Right : Int) return Uint; + pragma Inline (UI_Mod); + -- Returns mod function of two integer values + + function UI_Mul (Left : Uint; Right : Uint) return Uint; + function UI_Mul (Left : Int; Right : Uint) return Uint; + function UI_Mul (Left : Uint; Right : Int) return Uint; + -- Returns product of two integer values + + function UI_Ne (Left : Uint; Right : Uint) return Boolean; + function UI_Ne (Left : Int; Right : Uint) return Boolean; + function UI_Ne (Left : Uint; Right : Int) return Boolean; + pragma Inline (UI_Ne); + -- Compares integer values for inequality + + function UI_Negate (Right : Uint) return Uint; + pragma Inline (UI_Negate); + -- Returns negative of universal integer + + function UI_Rem (Left : Uint; Right : Uint) return Uint; + function UI_Rem (Left : Int; Right : Uint) return Uint; + function UI_Rem (Left : Uint; Right : Int) return Uint; + -- Returns rem of two integer values + + function UI_Sub (Left : Uint; Right : Uint) return Uint; + function UI_Sub (Left : Int; Right : Uint) return Uint; + function UI_Sub (Left : Uint; Right : Int) return Uint; + pragma Inline (UI_Sub); + -- Returns difference of two integer values + + function UI_Modular_Exponentiation + (B : Uint; + E : Uint; + Modulo : Uint) return Uint; + -- Efficiently compute (B ** E) rem Modulo + + function UI_Modular_Inverse (N : Uint; Modulo : Uint) return Uint; + -- Compute the multiplicative inverse of N in modular arithmetics with the + -- given Modulo (uses Euclid's algorithm). Note: the call is considered + -- to be erroneous (and the behavior is undefined) if n is not invertible. + + function UI_From_Int (Input : Int) return Uint; + -- Converts Int value to universal integer form + + function UI_From_CC (Input : Char_Code) return Uint; + -- Converts Char_Code value to universal integer form + + function UI_To_Int (Input : Uint) return Int; + -- Converts universal integer value to Int. Fatal error if value is not in + -- appropriate range. + + function UI_To_CC (Input : Uint) return Char_Code; + -- Converts universal integer value to Char_Code. Fatal error if value is + -- not in Char_Code range. + + function Num_Bits (Input : Uint) return Nat; + -- Approximate number of binary bits in given universal integer. + -- This function is used for capacity checks, and it can be one + -- bit off without affecting its usage. + + --------------------- + -- Output Routines -- + --------------------- + + type UI_Format is (Hex, Decimal, Auto); + -- Used to determine whether UI_Image/UI_Write output is in hexadecimal + -- or decimal format. Auto, the default setting, lets the routine make + -- a decision based on the value. + + UI_Image_Max : constant := 48; -- Enough for a 128-bit number + UI_Image_Buffer : String (1 .. UI_Image_Max); + UI_Image_Length : Natural; + -- Buffer used for UI_Image as described below + + procedure UI_Image (Input : Uint; Format : UI_Format := Auto); + -- Places a representation of Uint, consisting of a possible minus sign, + -- followed by the value in UI_Image_Buffer. The form of the value is an + -- integer literal in either decimal (no base) or hexadecimal (base 16) + -- format. If Hex is True on entry, then hex mode is forced, otherwise + -- UI_Image makes a guess at which output format is more convenient. The + -- value must fit in UI_Image_Buffer. If necessary, the result is an + -- approximation of the proper value, using an exponential format. The + -- image of No_Uint is output as a single question mark. + + procedure UI_Write (Input : Uint; Format : UI_Format := Auto); + -- Writes a representation of Uint, consisting of a possible minus sign, + -- followed by the value to the output file. The form of the value is an + -- integer literal in either decimal (no base) or hexadecimal (base 16) + -- format as appropriate. UI_Format shows which format to use. Auto, + -- the default, asks UI_Write to make a guess at which output format + -- will be more convenient to read. + + procedure pid (Input : Uint); + pragma Export (Ada, pid); + -- Writes representation of Uint in decimal with a terminating line + -- return. This is intended for use from the debugger. + + procedure pih (Input : Uint); + pragma Export (Ada, pih); + -- Writes representation of Uint in hex with a terminating line return. + -- This is intended for use from the debugger. + + ------------------------ + -- Operator Renamings -- + ------------------------ + + function "+" (Left : Uint; Right : Uint) return Uint renames UI_Add; + function "+" (Left : Int; Right : Uint) return Uint renames UI_Add; + function "+" (Left : Uint; Right : Int) return Uint renames UI_Add; + + function "/" (Left : Uint; Right : Uint) return Uint renames UI_Div; + function "/" (Left : Int; Right : Uint) return Uint renames UI_Div; + function "/" (Left : Uint; Right : Int) return Uint renames UI_Div; + + function "*" (Left : Uint; Right : Uint) return Uint renames UI_Mul; + function "*" (Left : Int; Right : Uint) return Uint renames UI_Mul; + function "*" (Left : Uint; Right : Int) return Uint renames UI_Mul; + + function "-" (Left : Uint; Right : Uint) return Uint renames UI_Sub; + function "-" (Left : Int; Right : Uint) return Uint renames UI_Sub; + function "-" (Left : Uint; Right : Int) return Uint renames UI_Sub; + + function "**" (Left : Uint; Right : Uint) return Uint renames UI_Expon; + function "**" (Left : Uint; Right : Int) return Uint renames UI_Expon; + function "**" (Left : Int; Right : Uint) return Uint renames UI_Expon; + function "**" (Left : Int; Right : Int) return Uint renames UI_Expon; + + function "abs" (Real : Uint) return Uint renames UI_Abs; + + function "mod" (Left : Uint; Right : Uint) return Uint renames UI_Mod; + function "mod" (Left : Int; Right : Uint) return Uint renames UI_Mod; + function "mod" (Left : Uint; Right : Int) return Uint renames UI_Mod; + + function "rem" (Left : Uint; Right : Uint) return Uint renames UI_Rem; + function "rem" (Left : Int; Right : Uint) return Uint renames UI_Rem; + function "rem" (Left : Uint; Right : Int) return Uint renames UI_Rem; + + function "-" (Real : Uint) return Uint renames UI_Negate; + + function "=" (Left : Uint; Right : Uint) return Boolean renames UI_Eq; + function "=" (Left : Int; Right : Uint) return Boolean renames UI_Eq; + function "=" (Left : Uint; Right : Int) return Boolean renames UI_Eq; + + function ">=" (Left : Uint; Right : Uint) return Boolean renames UI_Ge; + function ">=" (Left : Int; Right : Uint) return Boolean renames UI_Ge; + function ">=" (Left : Uint; Right : Int) return Boolean renames UI_Ge; + + function ">" (Left : Uint; Right : Uint) return Boolean renames UI_Gt; + function ">" (Left : Int; Right : Uint) return Boolean renames UI_Gt; + function ">" (Left : Uint; Right : Int) return Boolean renames UI_Gt; + + function "<=" (Left : Uint; Right : Uint) return Boolean renames UI_Le; + function "<=" (Left : Int; Right : Uint) return Boolean renames UI_Le; + function "<=" (Left : Uint; Right : Int) return Boolean renames UI_Le; + + function "<" (Left : Uint; Right : Uint) return Boolean renames UI_Lt; + function "<" (Left : Int; Right : Uint) return Boolean renames UI_Lt; + function "<" (Left : Uint; Right : Int) return Boolean renames UI_Lt; + + ----------------------------- + -- Mark/Release Processing -- + ----------------------------- + + -- The space used by Uint data is not automatically reclaimed. However, + -- a mark-release regime is implemented which allows storage to be + -- released back to a previously noted mark. This is used for example + -- when doing comparisons, where only intermediate results get stored + -- that do not need to be saved for future use. + + type Save_Mark is private; + + function Mark return Save_Mark; + -- Note mark point for future release + + procedure Release (M : Save_Mark); + -- Release storage allocated since mark was noted + + procedure Release_And_Save (M : Save_Mark; UI : in out Uint); + -- Like Release, except that the given Uint value (which is typically + -- among the data being released) is recopied after the release, so + -- that it is the most recent item, and UI is updated to point to + -- its copied location. + + procedure Release_And_Save (M : Save_Mark; UI1, UI2 : in out Uint); + -- Like Release, except that the given Uint values (which are typically + -- among the data being released) are recopied after the release, so + -- that they are the most recent items, and UI1 and UI2 are updated if + -- necessary to point to the copied locations. This routine is careful + -- to do things in the right order, so that the values do not clobber + -- one another. + + ----------------------------------- + -- Representation of Uint Values -- + ----------------------------------- + +private + + type Uint is new Int range Uint_Low_Bound .. Uint_High_Bound; + for Uint'Size use 32; + + No_Uint : constant Uint := Uint (Uint_Low_Bound); + + -- Uint values are represented as multiple precision integers stored in + -- a multi-digit format using Base as the base. This value is chosen so + -- that the product Base*Base is within the range of allowed Int values. + + -- Base is defined to allow efficient execution of the primitive operations + -- (a0, b0, c0) defined in the section "The Classical Algorithms" + -- (sec. 4.3.1) of Donald Knuth's "The Art of Computer Programming", + -- Vol. 2. These algorithms are used in this package. In particular, + -- the product of two single digits in this base fits in a 32-bit integer. + + Base_Bits : constant := 15; + -- Number of bits in base value + + Base : constant Int := 2 ** Base_Bits; + + -- Values in the range -(Base+1) .. Max_Direct are encoded directly as + -- Uint values by adding a bias value. The value of Max_Direct is chosen + -- so that a directly represented number always fits in two digits when + -- represented in base format. + + Min_Direct : constant Int := -(Base - 1); + Max_Direct : constant Int := (Base - 1) * (Base - 1); + + -- The following values define the bias used to store Uint values which + -- are in this range, as well as the biased values for the first and last + -- values in this range. We use a new derived type for these constants to + -- avoid accidental use of Uint arithmetic on these values, which is never + -- correct. + + type Ctrl is range Int'First .. Int'Last; + + Uint_Direct_Bias : constant Ctrl := Ctrl (Uint_Low_Bound) + Ctrl (Base); + Uint_Direct_First : constant Ctrl := Uint_Direct_Bias + Ctrl (Min_Direct); + Uint_Direct_Last : constant Ctrl := Uint_Direct_Bias + Ctrl (Max_Direct); + + Uint_0 : constant Uint := Uint (Uint_Direct_Bias); + Uint_1 : constant Uint := Uint (Uint_Direct_Bias + 1); + Uint_2 : constant Uint := Uint (Uint_Direct_Bias + 2); + Uint_3 : constant Uint := Uint (Uint_Direct_Bias + 3); + Uint_4 : constant Uint := Uint (Uint_Direct_Bias + 4); + Uint_5 : constant Uint := Uint (Uint_Direct_Bias + 5); + Uint_6 : constant Uint := Uint (Uint_Direct_Bias + 6); + Uint_7 : constant Uint := Uint (Uint_Direct_Bias + 7); + Uint_8 : constant Uint := Uint (Uint_Direct_Bias + 8); + Uint_9 : constant Uint := Uint (Uint_Direct_Bias + 9); + Uint_10 : constant Uint := Uint (Uint_Direct_Bias + 10); + Uint_11 : constant Uint := Uint (Uint_Direct_Bias + 11); + Uint_12 : constant Uint := Uint (Uint_Direct_Bias + 12); + Uint_13 : constant Uint := Uint (Uint_Direct_Bias + 13); + Uint_14 : constant Uint := Uint (Uint_Direct_Bias + 14); + Uint_15 : constant Uint := Uint (Uint_Direct_Bias + 15); + Uint_16 : constant Uint := Uint (Uint_Direct_Bias + 16); + Uint_24 : constant Uint := Uint (Uint_Direct_Bias + 24); + Uint_32 : constant Uint := Uint (Uint_Direct_Bias + 32); + Uint_63 : constant Uint := Uint (Uint_Direct_Bias + 63); + Uint_64 : constant Uint := Uint (Uint_Direct_Bias + 64); + Uint_80 : constant Uint := Uint (Uint_Direct_Bias + 80); + Uint_128 : constant Uint := Uint (Uint_Direct_Bias + 128); + + Uint_Minus_1 : constant Uint := Uint (Uint_Direct_Bias - 1); + Uint_Minus_2 : constant Uint := Uint (Uint_Direct_Bias - 2); + Uint_Minus_3 : constant Uint := Uint (Uint_Direct_Bias - 3); + Uint_Minus_4 : constant Uint := Uint (Uint_Direct_Bias - 4); + Uint_Minus_5 : constant Uint := Uint (Uint_Direct_Bias - 5); + Uint_Minus_6 : constant Uint := Uint (Uint_Direct_Bias - 6); + Uint_Minus_7 : constant Uint := Uint (Uint_Direct_Bias - 7); + Uint_Minus_8 : constant Uint := Uint (Uint_Direct_Bias - 8); + Uint_Minus_9 : constant Uint := Uint (Uint_Direct_Bias - 9); + Uint_Minus_12 : constant Uint := Uint (Uint_Direct_Bias - 12); + Uint_Minus_36 : constant Uint := Uint (Uint_Direct_Bias - 36); + Uint_Minus_63 : constant Uint := Uint (Uint_Direct_Bias - 63); + Uint_Minus_80 : constant Uint := Uint (Uint_Direct_Bias - 80); + Uint_Minus_128 : constant Uint := Uint (Uint_Direct_Bias - 128); + + Uint_Max_Simple_Mul : constant := Uint_Direct_Bias + 2 ** 15; + -- If two values are directly represented and less than or equal to this + -- value, then we know the product fits in a 32-bit integer. This allows + -- UI_Mul to efficiently compute the product in this case. + + type Save_Mark is record + Save_Uint : Uint; + Save_Udigit : Int; + end record; + + -- Values outside the range that is represented directly are stored using + -- two tables. The secondary table Udigits contains sequences of Int values + -- consisting of the digits of the number in a radix Base system. The + -- digits are stored from most significant to least significant with the + -- first digit only carrying the sign. + + -- There is one entry in the primary Uints table for each distinct Uint + -- value. This table entry contains the length (number of digits) and + -- a starting offset of the value in the Udigits table. + + Uint_First_Entry : constant Uint := Uint (Uint_Table_Start); + + -- Some subprograms defined in this package manipulate the Udigits table + -- directly, while for others it is more convenient to work with locally + -- defined arrays of the digits of the Universal Integers. The type + -- UI_Vector is defined for this purpose and some internal subprograms + -- used for converting from one to the other are defined. + + type UI_Vector is array (Pos range <>) of Int; + -- Vector containing the integer values of a Uint value + + -- Note: An earlier version of this package used pointers of arrays + -- of Ints (dynamically allocated) for the Uint type. The change + -- leads to a few less natural idioms used throughout this code, but + -- eliminates all uses of the heap except for the table package itself. + -- For example, Uint parameters are often converted to UI_Vectors for + -- internal manipulation. This is done by creating the local UI_Vector + -- using the function N_Digits on the Uint to find the size needed for + -- the vector, and then calling Init_Operand to copy the values out + -- of the table into the vector. + + type Uint_Entry is record + Length : Pos; + -- Length of entry in Udigits table in digits (i.e. in words) + + Loc : Int; + -- Starting location in Udigits table of this Uint value + end record; + + package Uints is new Table.Table ( + Table_Component_Type => Uint_Entry, + Table_Index_Type => Uint'Base, + Table_Low_Bound => Uint_First_Entry, + Table_Initial => Alloc.Uints_Initial, + Table_Increment => Alloc.Uints_Increment, + Table_Name => "Uints"); + + package Udigits is new Table.Table ( + Table_Component_Type => Int, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.Udigits_Initial, + Table_Increment => Alloc.Udigits_Increment, + Table_Name => "Udigits"); + + -- Note: the reason these tables are defined here in the private part of + -- the spec, rather than in the body, is that they are referenced directly + -- by gigi. + +end Uintp; diff --git a/gcc/ada/uintp.h b/gcc/ada/uintp.h new file mode 100644 index 000000000..630fcd18e --- /dev/null +++ b/gcc/ada/uintp.h @@ -0,0 +1,96 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * U I N T P * + * * + * C Header File * + * * + * 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. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING3. If not, go to * + * http://www.gnu.org/licenses for a complete copy of the license. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* This file corresponds to the Ada package specification Uintp. It was + created manually from the files uintp.ads and uintp.adb */ + +/* Support for universal integer arithmetic */ + +struct Uint_Entry +{ + Pos Length; + Int Loc; +}; + +/* See if a Uint is within the range of an integer. */ +#define UI_Is_In_Int_Range uintp__ui_is_in_int_range +extern Boolean UI_Is_In_Int_Range (Uint); + +/* Obtain Char_Code value from Uint input. Value must be in range. */ +#define UI_To_CC uintp__ui_to_cc +extern Char_Code UI_To_CC (Uint); + +/* Convert a Char_Code into a Uint. */ +#define UI_From_CC uintp__ui_from_cc +extern Uint UI_From_CC (Char_Code); + +/* Obtain Int value from Uint input. Abort if the result is out of range. */ +#define UI_To_Int uintp__ui_to_int +extern Int UI_To_Int (Uint); + +/* Similarly, but return a GCC INTEGER_CST. */ +extern tree UI_To_gnu (Uint, tree); + +/* Convert an Int into a Uint. */ +#define UI_From_Int uintp__ui_from_int +extern Uint UI_From_Int (int); + +/* Similarly, but take a GCC INTEGER_CST. */ +extern Uint UI_From_gnu (tree); + +/* Uint values are represented as multiple precision integers stored in a + multi-digit format using UI_Base as the base. This value is chosen so + that the product UI_Base*UI_Base is within the range of Int values. */ +#define UI_Base uintp__base +extern const int UI_Base; + +/* Types for the fat pointer of Int vectors and the template it points to. */ +typedef struct {int Low_Bound, High_Bound; } Vector_Template; +typedef struct {const int *Array; Vector_Template *Bounds; } + __attribute ((aligned (sizeof (char *) * 2))) Int_Vector; + +/* Create and return the Uint value from the Int vector. */ +#define Vector_To_Uint uintp__vector_to_uint +extern Uint Vector_To_Uint (Int_Vector, Boolean); + +/* Compare integer values for less than. */ +#define UI_Lt uintp__ui_lt +extern Boolean UI_Lt (Uint, Uint); + +/* Universal integers are represented by the Uint type which is an index into + the Uints_Ptr table containing Uint_Entry values. A Uint_Entry contains an + index and length for getting the "digits" of the universal integer from the + Udigits_Ptr table. + + For efficiency, this method is used only for integer values larger than the + constant Uint_Bias. If a Uint is less than this constant, then it contains + the integer value itself. The origin of the Uints_Ptr table is adjusted so + that a Uint value of Uint_Bias indexes the first element. */ + +#define Uints_Ptr (uintp__uints__table - Uint_Table_Start) +extern struct Uint_Entry *uintp__uints__table; + +#define Udigits_Ptr uintp__udigits__table +extern int *uintp__udigits__table; diff --git a/gcc/ada/uname.adb b/gcc/ada/uname.adb new file mode 100644 index 000000000..9628867ae --- /dev/null +++ b/gcc/ada/uname.adb @@ -0,0 +1,658 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- U N A M E -- +-- -- +-- 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 Atree; use Atree; +with Casing; use Casing; +with Einfo; use Einfo; +with Hostparm; +with Lib; use Lib; +with Nlists; use Nlists; +with Output; use Output; +with Sinfo; use Sinfo; +with Sinput; use Sinput; + +package body Uname is + + ------------------- + -- Get_Body_Name -- + ------------------- + + function Get_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is + begin + Get_Name_String (N); + + pragma Assert (Name_Len > 2 + and then Name_Buffer (Name_Len - 1) = '%' + and then Name_Buffer (Name_Len) = 's'); + + Name_Buffer (Name_Len) := 'b'; + return Name_Find; + end Get_Body_Name; + + ----------------------------------- + -- Get_External_Unit_Name_String -- + ----------------------------------- + + procedure Get_External_Unit_Name_String (N : Unit_Name_Type) is + Pcount : Natural; + Newlen : Natural; + + begin + -- Get unit name and eliminate trailing %s or %b + + Get_Name_String (N); + Name_Len := Name_Len - 2; + + -- Find number of components + + Pcount := 0; + for J in 1 .. Name_Len loop + if Name_Buffer (J) = '.' then + Pcount := Pcount + 1; + end if; + end loop; + + -- If simple name, nothing to do + + if Pcount = 0 then + return; + end if; + + -- If name has multiple components, replace dots by double underscore + + Newlen := Name_Len + Pcount; + + for J in reverse 1 .. Name_Len loop + if Name_Buffer (J) = '.' then + Name_Buffer (Newlen) := '_'; + Name_Buffer (Newlen - 1) := '_'; + Newlen := Newlen - 2; + + else + Name_Buffer (Newlen) := Name_Buffer (J); + Newlen := Newlen - 1; + end if; + end loop; + + Name_Len := Name_Len + Pcount; + end Get_External_Unit_Name_String; + + -------------------------- + -- Get_Parent_Body_Name -- + -------------------------- + + function Get_Parent_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is + begin + Get_Name_String (N); + + while Name_Buffer (Name_Len) /= '.' loop + pragma Assert (Name_Len > 1); -- not a child or subunit name + Name_Len := Name_Len - 1; + end loop; + + Name_Buffer (Name_Len) := '%'; + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := 'b'; + return Name_Find; + + end Get_Parent_Body_Name; + + -------------------------- + -- Get_Parent_Spec_Name -- + -------------------------- + + function Get_Parent_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is + begin + Get_Name_String (N); + + while Name_Buffer (Name_Len) /= '.' loop + if Name_Len = 1 then + return No_Unit_Name; + else + Name_Len := Name_Len - 1; + end if; + end loop; + + Name_Buffer (Name_Len) := '%'; + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := 's'; + return Name_Find; + + end Get_Parent_Spec_Name; + + ------------------- + -- Get_Spec_Name -- + ------------------- + + function Get_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is + begin + Get_Name_String (N); + + pragma Assert (Name_Len > 2 + and then Name_Buffer (Name_Len - 1) = '%' + and then Name_Buffer (Name_Len) = 'b'); + + Name_Buffer (Name_Len) := 's'; + return Name_Find; + end Get_Spec_Name; + + ------------------- + -- Get_Unit_Name -- + ------------------- + + function Get_Unit_Name (N : Node_Id) return Unit_Name_Type is + + Unit_Name_Buffer : String (1 .. Hostparm.Max_Name_Length); + -- Buffer used to build name of unit. Note that we cannot use the + -- Name_Buffer in package Name_Table because we use it to read + -- component names. + + Unit_Name_Length : Natural := 0; + -- Length of name stored in Unit_Name_Buffer + + Node : Node_Id; + -- Program unit node + + procedure Add_Char (C : Character); + -- Add a single character to stored unit name + + procedure Add_Name (Name : Name_Id); + -- Add the characters of a names table entry to stored unit name + + procedure Add_Node_Name (Node : Node_Id); + -- Recursive procedure adds characters associated with Node + + function Get_Parent (Node : Node_Id) return Node_Id; + -- Get parent compilation unit of a stub + + -------------- + -- Add_Char -- + -------------- + + procedure Add_Char (C : Character) is + begin + -- Should really check for max length exceeded here??? + Unit_Name_Length := Unit_Name_Length + 1; + Unit_Name_Buffer (Unit_Name_Length) := C; + end Add_Char; + + -------------- + -- Add_Name -- + -------------- + + procedure Add_Name (Name : Name_Id) is + begin + Get_Name_String (Name); + + for J in 1 .. Name_Len loop + Add_Char (Name_Buffer (J)); + end loop; + end Add_Name; + + ------------------- + -- Add_Node_Name -- + ------------------- + + procedure Add_Node_Name (Node : Node_Id) is + Kind : constant Node_Kind := Nkind (Node); + + begin + -- Just ignore an error node (someone else will give a message) + + if Node = Error then + return; + + -- Otherwise see what kind of node we have + + else + case Kind is + + when N_Identifier | + N_Defining_Identifier | + N_Defining_Operator_Symbol => + + -- Note: it is of course an error to have a defining + -- operator symbol at this point, but this is not where + -- the error is signalled, so we handle it nicely here! + + Add_Name (Chars (Node)); + + when N_Defining_Program_Unit_Name => + Add_Node_Name (Name (Node)); + Add_Char ('.'); + Add_Node_Name (Defining_Identifier (Node)); + + when N_Selected_Component | + N_Expanded_Name => + Add_Node_Name (Prefix (Node)); + Add_Char ('.'); + Add_Node_Name (Selector_Name (Node)); + + when N_Subprogram_Specification | + N_Package_Specification => + Add_Node_Name (Defining_Unit_Name (Node)); + + when N_Subprogram_Body | + N_Subprogram_Declaration | + N_Package_Declaration | + N_Generic_Declaration => + Add_Node_Name (Specification (Node)); + + when N_Generic_Instantiation => + Add_Node_Name (Defining_Unit_Name (Node)); + + when N_Package_Body => + Add_Node_Name (Defining_Unit_Name (Node)); + + when N_Task_Body | + N_Protected_Body => + Add_Node_Name (Defining_Identifier (Node)); + + when N_Package_Renaming_Declaration => + Add_Node_Name (Defining_Unit_Name (Node)); + + when N_Subprogram_Renaming_Declaration => + Add_Node_Name (Specification (Node)); + + when N_Generic_Renaming_Declaration => + Add_Node_Name (Defining_Unit_Name (Node)); + + when N_Subprogram_Body_Stub => + Add_Node_Name (Get_Parent (Node)); + Add_Char ('.'); + Add_Node_Name (Specification (Node)); + + when N_Compilation_Unit => + Add_Node_Name (Unit (Node)); + + when N_Package_Body_Stub => + Add_Node_Name (Get_Parent (Node)); + Add_Char ('.'); + Add_Node_Name (Defining_Identifier (Node)); + + when N_Task_Body_Stub | + N_Protected_Body_Stub => + Add_Node_Name (Get_Parent (Node)); + Add_Char ('.'); + Add_Node_Name (Defining_Identifier (Node)); + + when N_Subunit => + Add_Node_Name (Name (Node)); + Add_Char ('.'); + Add_Node_Name (Proper_Body (Node)); + + when N_With_Clause => + Add_Node_Name (Name (Node)); + + when N_Pragma => + Add_Node_Name (Expression (First + (Pragma_Argument_Associations (Node)))); + + -- Tasks and protected stuff appear only in an error context, + -- but the error has been posted elsewhere, so we deal nicely + -- with these error situations here, and produce a reasonable + -- unit name using the defining identifier. + + when N_Task_Type_Declaration | + N_Single_Task_Declaration | + N_Protected_Type_Declaration | + N_Single_Protected_Declaration => + Add_Node_Name (Defining_Identifier (Node)); + + when others => + raise Program_Error; + + end case; + end if; + end Add_Node_Name; + + ---------------- + -- Get_Parent -- + ---------------- + + function Get_Parent (Node : Node_Id) return Node_Id is + N : Node_Id := Node; + + begin + while Nkind (N) /= N_Compilation_Unit loop + N := Parent (N); + end loop; + + return N; + end Get_Parent; + + ------------------------------------------- + -- Start of Processing for Get_Unit_Name -- + ------------------------------------------- + + begin + Node := N; + + -- If we have Defining_Identifier, find the associated unit node + + if Nkind (Node) = N_Defining_Identifier then + Node := Declaration_Node (Node); + + -- If an expanded name, it is an already analyzed child unit, find + -- unit node. + + elsif Nkind (Node) = N_Expanded_Name then + Node := Declaration_Node (Entity (Node)); + end if; + + if Nkind (Node) = N_Package_Specification + or else Nkind (Node) in N_Subprogram_Specification + then + Node := Parent (Node); + end if; + + -- Node points to the unit, so get its name and add proper suffix + + Add_Node_Name (Node); + Add_Char ('%'); + + case Nkind (Node) is + when N_Generic_Declaration | + N_Subprogram_Declaration | + N_Package_Declaration | + N_With_Clause | + N_Pragma | + N_Generic_Instantiation | + N_Package_Renaming_Declaration | + N_Subprogram_Renaming_Declaration | + N_Generic_Renaming_Declaration | + N_Single_Task_Declaration | + N_Single_Protected_Declaration | + N_Task_Type_Declaration | + N_Protected_Type_Declaration => + + Add_Char ('s'); + + when N_Subprogram_Body | + N_Package_Body | + N_Subunit | + N_Body_Stub | + N_Task_Body | + N_Protected_Body | + N_Identifier | + N_Selected_Component => + + Add_Char ('b'); + + when others => + raise Program_Error; + end case; + + Name_Buffer (1 .. Unit_Name_Length) := + Unit_Name_Buffer (1 .. Unit_Name_Length); + Name_Len := Unit_Name_Length; + return Name_Find; + + end Get_Unit_Name; + + -------------------------- + -- Get_Unit_Name_String -- + -------------------------- + + procedure Get_Unit_Name_String + (N : Unit_Name_Type; + Suffix : Boolean := True) + is + Unit_Is_Body : Boolean; + + begin + Get_Decoded_Name_String (N); + Unit_Is_Body := Name_Buffer (Name_Len) = 'b'; + Set_Casing (Identifier_Casing (Source_Index (Main_Unit)), Mixed_Case); + + -- A special fudge, normally we don't have operator symbols present, + -- since it is always an error to do so. However, if we do, at this + -- stage it has the form: + + -- "and" + + -- and the %s or %b has already been eliminated so put 2 chars back + + if Name_Buffer (1) = '"' then + Name_Len := Name_Len + 2; + end if; + + -- Now adjust the %s or %b to (spec) or (body) + + if Suffix then + if Unit_Is_Body then + Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (body)"; + else + Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (spec)"; + end if; + end if; + + for J in 1 .. Name_Len loop + if Name_Buffer (J) = '-' then + Name_Buffer (J) := '.'; + end if; + end loop; + + -- Adjust Name_Len + + if Suffix then + Name_Len := Name_Len + (7 - 2); + else + Name_Len := Name_Len - 2; + end if; + end Get_Unit_Name_String; + + ------------------ + -- Is_Body_Name -- + ------------------ + + function Is_Body_Name (N : Unit_Name_Type) return Boolean is + begin + Get_Name_String (N); + return Name_Len > 2 + and then Name_Buffer (Name_Len - 1) = '%' + and then Name_Buffer (Name_Len) = 'b'; + end Is_Body_Name; + + ------------------- + -- Is_Child_Name -- + ------------------- + + function Is_Child_Name (N : Unit_Name_Type) return Boolean is + J : Natural; + + begin + Get_Name_String (N); + J := Name_Len; + + while Name_Buffer (J) /= '.' loop + if J = 1 then + return False; -- not a child or subunit name + else + J := J - 1; + end if; + end loop; + + return True; + end Is_Child_Name; + + ------------------ + -- Is_Spec_Name -- + ------------------ + + function Is_Spec_Name (N : Unit_Name_Type) return Boolean is + begin + Get_Name_String (N); + return Name_Len > 2 + and then Name_Buffer (Name_Len - 1) = '%' + and then Name_Buffer (Name_Len) = 's'; + end Is_Spec_Name; + + ----------------------- + -- Name_To_Unit_Name -- + ----------------------- + + function Name_To_Unit_Name (N : Name_Id) return Unit_Name_Type is + begin + Get_Name_String (N); + Name_Buffer (Name_Len + 1) := '%'; + Name_Buffer (Name_Len + 2) := 's'; + Name_Len := Name_Len + 2; + return Name_Find; + end Name_To_Unit_Name; + + --------------- + -- New_Child -- + --------------- + + function New_Child + (Old : Unit_Name_Type; + Newp : Unit_Name_Type) return Unit_Name_Type + is + P : Natural; + + begin + Get_Name_String (Old); + + declare + Child : constant String := Name_Buffer (1 .. Name_Len); + + begin + Get_Name_String (Newp); + Name_Len := Name_Len - 2; + + P := Child'Last; + while Child (P) /= '.' loop + P := P - 1; + end loop; + + while P <= Child'Last loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Child (P); + P := P + 1; + end loop; + + return Name_Find; + end; + end New_Child; + + -------------- + -- Uname_Ge -- + -------------- + + function Uname_Ge (Left, Right : Unit_Name_Type) return Boolean is + begin + return Left = Right or else Uname_Gt (Left, Right); + end Uname_Ge; + + -------------- + -- Uname_Gt -- + -------------- + + function Uname_Gt (Left, Right : Unit_Name_Type) return Boolean is + begin + return Left /= Right and then not Uname_Lt (Left, Right); + end Uname_Gt; + + -------------- + -- Uname_Le -- + -------------- + + function Uname_Le (Left, Right : Unit_Name_Type) return Boolean is + begin + return Left = Right or else Uname_Lt (Left, Right); + end Uname_Le; + + -------------- + -- Uname_Lt -- + -------------- + + function Uname_Lt (Left, Right : Unit_Name_Type) return Boolean is + Left_Name : String (1 .. Hostparm.Max_Name_Length); + Left_Length : Natural; + Right_Name : String renames Name_Buffer; + Right_Length : Natural renames Name_Len; + J : Natural; + + begin + pragma Warnings (Off, Right_Length); + -- Suppress warnings on Right_Length, used in pragma Assert + + if Left = Right then + return False; + end if; + + Get_Name_String (Left); + Left_Name (1 .. Name_Len + 1) := Name_Buffer (1 .. Name_Len + 1); + Left_Length := Name_Len; + Get_Name_String (Right); + J := 1; + + loop + exit when Left_Name (J) = '%'; + + if Right_Name (J) = '%' then + return False; -- left name is longer + end if; + + pragma Assert (J <= Left_Length and then J <= Right_Length); + + if Left_Name (J) /= Right_Name (J) then + return Left_Name (J) < Right_Name (J); -- parent names different + end if; + + J := J + 1; + end loop; + + -- Come here pointing to % in left name + + if Right_Name (J) /= '%' then + return True; -- right name is longer + end if; + + -- Here the parent names are the same and specs sort low. If neither is + -- a spec, then we are comparing the same name and we want a result of + -- False in any case. + + return Left_Name (J + 1) = 's'; + end Uname_Lt; + + --------------------- + -- Write_Unit_Name -- + --------------------- + + procedure Write_Unit_Name (N : Unit_Name_Type) is + begin + Get_Unit_Name_String (N); + Write_Str (Name_Buffer (1 .. Name_Len)); + end Write_Unit_Name; + +end Uname; diff --git a/gcc/ada/uname.ads b/gcc/ada/uname.ads new file mode 100644 index 000000000..c1b59b6cb --- /dev/null +++ b/gcc/ada/uname.ads @@ -0,0 +1,176 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- U N A M E -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with Namet; use Namet; +with Types; use Types; + +package Uname is + + --------------------------- + -- Unit Name Conventions -- + --------------------------- + + -- Units are associated with a unique ASCII name as follows. First we have + -- the fully expanded name of the unit, with lower case letters (except + -- for the use of upper case letters for encoding upper half and wide + -- characters, as described in Namet), and periods. Following this is one + -- of the following suffixes: + + -- %s for package/subprogram/generic declarations (specs) + -- %b for package/subprogram/generic bodies and subunits + + -- Unit names are stored in the names table, and referred to by the + -- corresponding Name_Id values. The type Unit_Name_Type, derived from + -- Name_Id, is used to indicate that a Name_Id value that holds a unit name + -- (as defined above) is expected. + + -- Note: as far as possible the conventions for unit names are encapsulated + -- in this package. The one exception is that package Fname, which provides + -- conversion routines from unit names to file names must be aware of the + -- precise conventions that are used. + + ------------------- + -- Display Names -- + ------------------- + + -- For display purposes, unit names are printed out with the suffix + -- " (body)" for a body and " (spec)" for a spec. These formats are + -- used for the Write_Unit_Name and Get_Unit_Name_String subprograms. + + ----------------- + -- Subprograms -- + ----------------- + + function Get_Body_Name (N : Unit_Name_Type) return Unit_Name_Type; + -- Given the name of a spec, this function returns the name of the + -- corresponding body, i.e. characters %s replaced by %b + + function Get_Parent_Body_Name (N : Unit_Name_Type) return Unit_Name_Type; + -- Given the name of a subunit, returns the name of the parent body + + function Get_Parent_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type; + -- Given the name of a child unit spec or body, returns the unit name + -- of the parent spec. Returns No_Name if the given name is not the name + -- of a child unit. + + procedure Get_External_Unit_Name_String (N : Unit_Name_Type); + -- Given the name of a body or spec unit, this procedure places in + -- Name_Buffer the name of the unit with periods replaced by double + -- underscores. The spec/body indication is eliminated. The length + -- of the stored name is placed in Name_Len. All letters are lower + -- case, corresponding to the string used in external names. + + function Get_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type; + -- Given the name of a body, this function returns the name of the + -- corresponding spec, i.e. characters %b replaced by %s + + function Get_Unit_Name (N : Node_Id) return Unit_Name_Type; + -- This procedure returns the unit name that corresponds to the given node, + -- which is one of the following: + -- + -- N_Subprogram_Declaration (spec) cases + -- N_Package_Declaration + -- N_Generic_Declaration + -- N_With_Clause + -- N_Function_Instantiation + -- N_Package_Instantiation + -- N_Procedure_Instantiation + -- N_Pragma (Elaborate case) + -- + -- N_Package_Body (body) cases + -- N_Subprogram_Body + -- N_Identifier + -- N_Selected_Component + -- + -- N_Subprogram_Body_Stub (subunit) cases + -- N_Package_Body_Stub + -- N_Task_Body_Stub + -- N_Protected_Body_Stub + -- N_Subunit + + procedure Get_Unit_Name_String + (N : Unit_Name_Type; + Suffix : Boolean := True); + -- Places the display name of the unit in Name_Buffer and sets Name_Len to + -- the length of the stored name, i.e. it uses the same interface as the + -- Get_Name_String routine in the Namet package. The name is decoded and + -- contains an indication of spec or body if Boolean parameter Suffix is + -- True. + + function Is_Body_Name (N : Unit_Name_Type) return Boolean; + -- Returns True iff the given name is the unit name of a body (i.e. if + -- it ends with the characters %b). + + function Is_Child_Name (N : Unit_Name_Type) return Boolean; + -- Returns True iff the given name is a child unit name (of either a + -- body or a spec). + + function Is_Spec_Name (N : Unit_Name_Type) return Boolean; + -- Returns True iff the given name is the unit name of a specification + -- (i.e. if it ends with the characters %s). + + function Name_To_Unit_Name (N : Name_Id) return Unit_Name_Type; + -- Given the Id of the Ada name of a unit, this function returns the + -- corresponding unit name of the spec (by appending %s to the name). + + function New_Child + (Old : Unit_Name_Type; + Newp : Unit_Name_Type) return Unit_Name_Type; + -- Old is a child unit name (for either a body or spec). Newp is the unit + -- name of the actual parent (this may be different from the parent in + -- old). The returned unit name is formed by taking the parent name from + -- Newp and the child unit name from Old, with the result being a body or + -- spec depending on Old. For example: + -- + -- Old = A.B.C (body) + -- Newp = A.R (spec) + -- result = A.R.C (body) + -- + -- See spec of Load_Unit for extensive discussion of why this routine + -- needs to be used (the call in the body of Load_Unit is the only one). + + function Uname_Ge (Left, Right : Unit_Name_Type) return Boolean; + function Uname_Gt (Left, Right : Unit_Name_Type) return Boolean; + function Uname_Le (Left, Right : Unit_Name_Type) return Boolean; + function Uname_Lt (Left, Right : Unit_Name_Type) return Boolean; + -- These functions perform lexicographic ordering of unit names. The + -- ordering is suitable for printing, and is not quite a straightforward + -- comparison of the names, since the convention is that specs appear + -- before bodies. Note that the standard = and /= operators work fine + -- because all unit names are hashed into the name table, so if two names + -- are the same, they always have the same Name_Id value. + + procedure Write_Unit_Name (N : Unit_Name_Type); + -- Given a unit name, this procedure writes the display name to the + -- standard output file. Name_Buffer and Name_Len are set as described + -- above for the Get_Unit_Name_String call on return. + +end Uname; diff --git a/gcc/ada/unchconv.ads b/gcc/ada/unchconv.ads new file mode 100644 index 000000000..793702087 --- /dev/null +++ b/gcc/ada/unchconv.ads @@ -0,0 +1,22 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- U N C H E C K E D _ C O N V E R S I O N -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Source (<>) is limited private; + type Target (<>) is limited private; + +function Unchecked_Conversion (S : Source) return Target; +pragma Import (Intrinsic, Unchecked_Conversion); +pragma Pure (Unchecked_Conversion); diff --git a/gcc/ada/unchdeal.ads b/gcc/ada/unchdeal.ads new file mode 100644 index 000000000..4735a5207 --- /dev/null +++ b/gcc/ada/unchdeal.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- U N C H E C K E D _ D E A L L O C A T I O N -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Object (<>) is limited private; + type Name is access Object; + +procedure Unchecked_Deallocation (X : in out Name); +pragma Import (Intrinsic, Unchecked_Deallocation); diff --git a/gcc/ada/urealp.adb b/gcc/ada/urealp.adb new file mode 100644 index 000000000..e28ee59f1 --- /dev/null +++ b/gcc/ada/urealp.adb @@ -0,0 +1,1635 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- U R E A L P -- +-- -- +-- 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 Alloc; +with Output; use Output; +with Table; +with Tree_IO; use Tree_IO; + +package body Urealp is + + Ureal_First_Entry : constant Ureal := Ureal'Succ (No_Ureal); + -- First subscript allocated in Ureal table (note that we can't just + -- add 1 to No_Ureal, since "+" means something different for Ureals! + + type Ureal_Entry is record + Num : Uint; + -- Numerator (always non-negative) + + Den : Uint; + -- Denominator (always non-zero, always positive if base is zero) + + Rbase : Nat; + -- Base value. If Rbase is zero, then the value is simply Num / Den. + -- If Rbase is non-zero, then the value is Num / (Rbase ** Den) + + Negative : Boolean; + -- Flag set if value is negative + end record; + + -- The following representation clause ensures that the above record + -- has no holes. We do this so that when instances of this record are + -- written by Tree_Gen, we do not write uninitialized values to the file. + + for Ureal_Entry use record + Num at 0 range 0 .. 31; + Den at 4 range 0 .. 31; + Rbase at 8 range 0 .. 31; + Negative at 12 range 0 .. 31; + end record; + + for Ureal_Entry'Size use 16 * 8; + -- This ensures that we did not leave out any fields + + package Ureals is new Table.Table ( + Table_Component_Type => Ureal_Entry, + Table_Index_Type => Ureal'Base, + Table_Low_Bound => Ureal_First_Entry, + Table_Initial => Alloc.Ureals_Initial, + Table_Increment => Alloc.Ureals_Increment, + Table_Name => "Ureals"); + + -- The following universal reals are the values returned by the constant + -- functions. They are initialized by the initialization procedure. + + UR_0 : Ureal; + UR_M_0 : Ureal; + UR_Tenth : Ureal; + UR_Half : Ureal; + UR_1 : Ureal; + UR_2 : Ureal; + UR_10 : Ureal; + UR_10_36 : Ureal; + UR_M_10_36 : Ureal; + UR_100 : Ureal; + UR_2_128 : Ureal; + UR_2_80 : Ureal; + UR_2_M_128 : Ureal; + UR_2_M_80 : Ureal; + + Num_Ureal_Constants : constant := 10; + -- This is used for an assertion check in Tree_Read and Tree_Write to + -- help remember to add values to these routines when we add to the list. + + Normalized_Real : Ureal := No_Ureal; + -- Used to memoize Norm_Num and Norm_Den, if either of these functions + -- is called, this value is set and Normalized_Entry contains the result + -- of the normalization. On subsequent calls, this is used to avoid the + -- call to Normalize if it has already been made. + + Normalized_Entry : Ureal_Entry; + -- Entry built by most recent call to Normalize + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Decimal_Exponent_Hi (V : Ureal) return Int; + -- Returns an estimate of the exponent of Val represented as a normalized + -- decimal number (non-zero digit before decimal point), The estimate is + -- either correct, or high, but never low. The accuracy of the estimate + -- affects only the efficiency of the comparison routines. + + function Decimal_Exponent_Lo (V : Ureal) return Int; + -- Returns an estimate of the exponent of Val represented as a normalized + -- decimal number (non-zero digit before decimal point), The estimate is + -- either correct, or low, but never high. The accuracy of the estimate + -- affects only the efficiency of the comparison routines. + + function Equivalent_Decimal_Exponent (U : Ureal_Entry) return Int; + -- U is a Ureal entry for which the base value is non-zero, the value + -- returned is the equivalent decimal exponent value, i.e. the value of + -- Den, adjusted as though the base were base 10. The value is rounded + -- to the nearest integer, and so can be one off. + + function Is_Integer (Num, Den : Uint) return Boolean; + -- Return true if the real quotient of Num / Den is an integer value + + function Normalize (Val : Ureal_Entry) return Ureal_Entry; + -- Normalizes the Ureal_Entry by reducing it to lowest terms (with a base + -- value of 0). + + function Same (U1, U2 : Ureal) return Boolean; + pragma Inline (Same); + -- Determines if U1 and U2 are the same Ureal. Note that we cannot use + -- the equals operator for this test, since that tests for equality, not + -- identity. + + function Store_Ureal (Val : Ureal_Entry) return Ureal; + -- This store a new entry in the universal reals table and return its index + -- in the table. + + function Store_Ureal_Normalized (Val : Ureal_Entry) return Ureal; + pragma Inline (Store_Ureal_Normalized); + -- Like Store_Ureal, but normalizes its operand first. + + ------------------------- + -- Decimal_Exponent_Hi -- + ------------------------- + + function Decimal_Exponent_Hi (V : Ureal) return Int is + Val : constant Ureal_Entry := Ureals.Table (V); + + begin + -- Zero always returns zero + + if UR_Is_Zero (V) then + return 0; + + -- For numbers in rational form, get the maximum number of digits in the + -- numerator and the minimum number of digits in the denominator, and + -- subtract. For example: + + -- 1000 / 99 = 1.010E+1 + -- 9999 / 10 = 9.999E+2 + + -- This estimate may of course be high, but that is acceptable + + elsif Val.Rbase = 0 then + return UI_Decimal_Digits_Hi (Val.Num) - + UI_Decimal_Digits_Lo (Val.Den); + + -- For based numbers, just subtract the decimal exponent from the + -- high estimate of the number of digits in the numerator and add + -- one to accommodate possible round off errors for non-decimal + -- bases. For example: + + -- 1_500_000 / 10**4 = 1.50E-2 + + else -- Val.Rbase /= 0 + return UI_Decimal_Digits_Hi (Val.Num) - + Equivalent_Decimal_Exponent (Val) + 1; + end if; + end Decimal_Exponent_Hi; + + ------------------------- + -- Decimal_Exponent_Lo -- + ------------------------- + + function Decimal_Exponent_Lo (V : Ureal) return Int is + Val : constant Ureal_Entry := Ureals.Table (V); + + begin + -- Zero always returns zero + + if UR_Is_Zero (V) then + return 0; + + -- For numbers in rational form, get min digits in numerator, max digits + -- in denominator, and subtract and subtract one more for possible loss + -- during the division. For example: + + -- 1000 / 99 = 1.010E+1 + -- 9999 / 10 = 9.999E+2 + + -- This estimate may of course be low, but that is acceptable + + elsif Val.Rbase = 0 then + return UI_Decimal_Digits_Lo (Val.Num) - + UI_Decimal_Digits_Hi (Val.Den) - 1; + + -- For based numbers, just subtract the decimal exponent from the + -- low estimate of the number of digits in the numerator and subtract + -- one to accommodate possible round off errors for non-decimal + -- bases. For example: + + -- 1_500_000 / 10**4 = 1.50E-2 + + else -- Val.Rbase /= 0 + return UI_Decimal_Digits_Lo (Val.Num) - + Equivalent_Decimal_Exponent (Val) - 1; + end if; + end Decimal_Exponent_Lo; + + ----------------- + -- Denominator -- + ----------------- + + function Denominator (Real : Ureal) return Uint is + begin + return Ureals.Table (Real).Den; + end Denominator; + + --------------------------------- + -- Equivalent_Decimal_Exponent -- + --------------------------------- + + function Equivalent_Decimal_Exponent (U : Ureal_Entry) return Int is + + -- The following table is a table of logs to the base 10 + + Logs : constant array (Nat range 1 .. 16) of Long_Float := ( + 1 => 0.000000000000000, + 2 => 0.301029995663981, + 3 => 0.477121254719662, + 4 => 0.602059991327962, + 5 => 0.698970004336019, + 6 => 0.778151250383644, + 7 => 0.845098040014257, + 8 => 0.903089986991944, + 9 => 0.954242509439325, + 10 => 1.000000000000000, + 11 => 1.041392685158230, + 12 => 1.079181246047620, + 13 => 1.113943352306840, + 14 => 1.146128035678240, + 15 => 1.176091259055680, + 16 => 1.204119982655920); + + begin + pragma Assert (U.Rbase /= 0); + return Int (Long_Float (UI_To_Int (U.Den)) * Logs (U.Rbase)); + end Equivalent_Decimal_Exponent; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Ureals.Init; + UR_0 := UR_From_Components (Uint_0, Uint_1, 0, False); + UR_M_0 := UR_From_Components (Uint_0, Uint_1, 0, True); + UR_Half := UR_From_Components (Uint_1, Uint_1, 2, False); + UR_Tenth := UR_From_Components (Uint_1, Uint_1, 10, False); + UR_1 := UR_From_Components (Uint_1, Uint_1, 0, False); + UR_2 := UR_From_Components (Uint_1, Uint_Minus_1, 2, False); + UR_10 := UR_From_Components (Uint_1, Uint_Minus_1, 10, False); + UR_10_36 := UR_From_Components (Uint_1, Uint_Minus_36, 10, False); + UR_M_10_36 := UR_From_Components (Uint_1, Uint_Minus_36, 10, True); + UR_100 := UR_From_Components (Uint_1, Uint_Minus_2, 10, False); + UR_2_128 := UR_From_Components (Uint_1, Uint_Minus_128, 2, False); + UR_2_M_128 := UR_From_Components (Uint_1, Uint_128, 2, False); + UR_2_80 := UR_From_Components (Uint_1, Uint_Minus_80, 2, False); + UR_2_M_80 := UR_From_Components (Uint_1, Uint_80, 2, False); + end Initialize; + + ---------------- + -- Is_Integer -- + ---------------- + + function Is_Integer (Num, Den : Uint) return Boolean is + begin + return (Num / Den) * Den = Num; + end Is_Integer; + + ---------- + -- Mark -- + ---------- + + function Mark return Save_Mark is + begin + return Save_Mark (Ureals.Last); + end Mark; + + -------------- + -- Norm_Den -- + -------------- + + function Norm_Den (Real : Ureal) return Uint is + begin + if not Same (Real, Normalized_Real) then + Normalized_Real := Real; + Normalized_Entry := Normalize (Ureals.Table (Real)); + end if; + + return Normalized_Entry.Den; + end Norm_Den; + + -------------- + -- Norm_Num -- + -------------- + + function Norm_Num (Real : Ureal) return Uint is + begin + if not Same (Real, Normalized_Real) then + Normalized_Real := Real; + Normalized_Entry := Normalize (Ureals.Table (Real)); + end if; + + return Normalized_Entry.Num; + end Norm_Num; + + --------------- + -- Normalize -- + --------------- + + function Normalize (Val : Ureal_Entry) return Ureal_Entry is + J : Uint; + K : Uint; + Tmp : Uint; + Num : Uint; + Den : Uint; + M : constant Uintp.Save_Mark := Uintp.Mark; + + begin + -- Start by setting J to the greatest of the absolute values of the + -- numerator and the denominator (taking into account the base value), + -- and K to the lesser of the two absolute values. The gcd of Num and + -- Den is the gcd of J and K. + + if Val.Rbase = 0 then + J := Val.Num; + K := Val.Den; + + elsif Val.Den < 0 then + J := Val.Num * Val.Rbase ** (-Val.Den); + K := Uint_1; + + else + J := Val.Num; + K := Val.Rbase ** Val.Den; + end if; + + Num := J; + Den := K; + + if K > J then + Tmp := J; + J := K; + K := Tmp; + end if; + + J := UI_GCD (J, K); + Num := Num / J; + Den := Den / J; + Uintp.Release_And_Save (M, Num, Den); + + -- Divide numerator and denominator by gcd and return result + + return (Num => Num, + Den => Den, + Rbase => 0, + Negative => Val.Negative); + end Normalize; + + --------------- + -- Numerator -- + --------------- + + function Numerator (Real : Ureal) return Uint is + begin + return Ureals.Table (Real).Num; + end Numerator; + + -------- + -- pr -- + -------- + + procedure pr (Real : Ureal) is + begin + UR_Write (Real); + Write_Eol; + end pr; + + ----------- + -- Rbase -- + ----------- + + function Rbase (Real : Ureal) return Nat is + begin + return Ureals.Table (Real).Rbase; + end Rbase; + + ------------- + -- Release -- + ------------- + + procedure Release (M : Save_Mark) is + begin + Ureals.Set_Last (Ureal (M)); + end Release; + + ---------- + -- Same -- + ---------- + + function Same (U1, U2 : Ureal) return Boolean is + begin + return Int (U1) = Int (U2); + end Same; + + ----------------- + -- Store_Ureal -- + ----------------- + + function Store_Ureal (Val : Ureal_Entry) return Ureal is + begin + Ureals.Append (Val); + + -- Normalize representation of signed values + + if Val.Num < 0 then + Ureals.Table (Ureals.Last).Negative := True; + Ureals.Table (Ureals.Last).Num := -Val.Num; + end if; + + return Ureals.Last; + end Store_Ureal; + + ---------------------------- + -- Store_Ureal_Normalized -- + ---------------------------- + + function Store_Ureal_Normalized (Val : Ureal_Entry) return Ureal is + begin + return Store_Ureal (Normalize (Val)); + end Store_Ureal_Normalized; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + begin + pragma Assert (Num_Ureal_Constants = 10); + + Ureals.Tree_Read; + Tree_Read_Int (Int (UR_0)); + Tree_Read_Int (Int (UR_M_0)); + Tree_Read_Int (Int (UR_Tenth)); + Tree_Read_Int (Int (UR_Half)); + Tree_Read_Int (Int (UR_1)); + Tree_Read_Int (Int (UR_2)); + Tree_Read_Int (Int (UR_10)); + Tree_Read_Int (Int (UR_100)); + Tree_Read_Int (Int (UR_2_128)); + Tree_Read_Int (Int (UR_2_M_128)); + + -- Clear the normalization cache + + Normalized_Real := No_Ureal; + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + begin + pragma Assert (Num_Ureal_Constants = 10); + + Ureals.Tree_Write; + Tree_Write_Int (Int (UR_0)); + Tree_Write_Int (Int (UR_M_0)); + Tree_Write_Int (Int (UR_Tenth)); + Tree_Write_Int (Int (UR_Half)); + Tree_Write_Int (Int (UR_1)); + Tree_Write_Int (Int (UR_2)); + Tree_Write_Int (Int (UR_10)); + Tree_Write_Int (Int (UR_100)); + Tree_Write_Int (Int (UR_2_128)); + Tree_Write_Int (Int (UR_2_M_128)); + end Tree_Write; + + ------------ + -- UR_Abs -- + ------------ + + function UR_Abs (Real : Ureal) return Ureal is + Val : constant Ureal_Entry := Ureals.Table (Real); + + begin + return Store_Ureal + ((Num => Val.Num, + Den => Val.Den, + Rbase => Val.Rbase, + Negative => False)); + end UR_Abs; + + ------------ + -- UR_Add -- + ------------ + + function UR_Add (Left : Uint; Right : Ureal) return Ureal is + begin + return UR_From_Uint (Left) + Right; + end UR_Add; + + function UR_Add (Left : Ureal; Right : Uint) return Ureal is + begin + return Left + UR_From_Uint (Right); + end UR_Add; + + function UR_Add (Left : Ureal; Right : Ureal) return Ureal is + Lval : Ureal_Entry := Ureals.Table (Left); + Rval : Ureal_Entry := Ureals.Table (Right); + Num : Uint; + + begin + -- Note, in the temporary Ureal_Entry values used in this procedure, + -- we store the sign as the sign of the numerator (i.e. xxx.Num may + -- be negative, even though in stored entries this can never be so) + + if Lval.Rbase /= 0 and then Lval.Rbase = Rval.Rbase then + declare + Opd_Min, Opd_Max : Ureal_Entry; + Exp_Min, Exp_Max : Uint; + + begin + if Lval.Negative then + Lval.Num := (-Lval.Num); + end if; + + if Rval.Negative then + Rval.Num := (-Rval.Num); + end if; + + if Lval.Den < Rval.Den then + Exp_Min := Lval.Den; + Exp_Max := Rval.Den; + Opd_Min := Lval; + Opd_Max := Rval; + else + Exp_Min := Rval.Den; + Exp_Max := Lval.Den; + Opd_Min := Rval; + Opd_Max := Lval; + end if; + + Num := + Opd_Min.Num * Lval.Rbase ** (Exp_Max - Exp_Min) + Opd_Max.Num; + + if Num = 0 then + return Store_Ureal + ((Num => Uint_0, + Den => Uint_1, + Rbase => 0, + Negative => Lval.Negative)); + + else + return Store_Ureal + ((Num => abs Num, + Den => Exp_Max, + Rbase => Lval.Rbase, + Negative => (Num < 0))); + end if; + end; + + else + declare + Ln : Ureal_Entry := Normalize (Lval); + Rn : Ureal_Entry := Normalize (Rval); + + begin + if Ln.Negative then + Ln.Num := (-Ln.Num); + end if; + + if Rn.Negative then + Rn.Num := (-Rn.Num); + end if; + + Num := (Ln.Num * Rn.Den) + (Rn.Num * Ln.Den); + + if Num = 0 then + return Store_Ureal + ((Num => Uint_0, + Den => Uint_1, + Rbase => 0, + Negative => Lval.Negative)); + + else + return Store_Ureal_Normalized + ((Num => abs Num, + Den => Ln.Den * Rn.Den, + Rbase => 0, + Negative => (Num < 0))); + end if; + end; + end if; + end UR_Add; + + ---------------- + -- UR_Ceiling -- + ---------------- + + function UR_Ceiling (Real : Ureal) return Uint is + Val : constant Ureal_Entry := Normalize (Ureals.Table (Real)); + begin + if Val.Negative then + return UI_Negate (Val.Num / Val.Den); + else + return (Val.Num + Val.Den - 1) / Val.Den; + end if; + end UR_Ceiling; + + ------------ + -- UR_Div -- + ------------ + + function UR_Div (Left : Uint; Right : Ureal) return Ureal is + begin + return UR_From_Uint (Left) / Right; + end UR_Div; + + function UR_Div (Left : Ureal; Right : Uint) return Ureal is + begin + return Left / UR_From_Uint (Right); + end UR_Div; + + function UR_Div (Left, Right : Ureal) return Ureal is + Lval : constant Ureal_Entry := Ureals.Table (Left); + Rval : constant Ureal_Entry := Ureals.Table (Right); + Rneg : constant Boolean := Rval.Negative xor Lval.Negative; + + begin + pragma Assert (Rval.Num /= Uint_0); + + if Lval.Rbase = 0 then + if Rval.Rbase = 0 then + return Store_Ureal_Normalized + ((Num => Lval.Num * Rval.Den, + Den => Lval.Den * Rval.Num, + Rbase => 0, + Negative => Rneg)); + + elsif Is_Integer (Lval.Num, Rval.Num * Lval.Den) then + return Store_Ureal + ((Num => Lval.Num / (Rval.Num * Lval.Den), + Den => (-Rval.Den), + Rbase => Rval.Rbase, + Negative => Rneg)); + + elsif Rval.Den < 0 then + return Store_Ureal_Normalized + ((Num => Lval.Num, + Den => Rval.Rbase ** (-Rval.Den) * + Rval.Num * + Lval.Den, + Rbase => 0, + Negative => Rneg)); + + else + return Store_Ureal_Normalized + ((Num => Lval.Num * Rval.Rbase ** Rval.Den, + Den => Rval.Num * Lval.Den, + Rbase => 0, + Negative => Rneg)); + end if; + + elsif Is_Integer (Lval.Num, Rval.Num) then + if Rval.Rbase = Lval.Rbase then + return Store_Ureal + ((Num => Lval.Num / Rval.Num, + Den => Lval.Den - Rval.Den, + Rbase => Lval.Rbase, + Negative => Rneg)); + + elsif Rval.Rbase = 0 then + return Store_Ureal + ((Num => (Lval.Num / Rval.Num) * Rval.Den, + Den => Lval.Den, + Rbase => Lval.Rbase, + Negative => Rneg)); + + elsif Rval.Den < 0 then + declare + Num, Den : Uint; + + begin + if Lval.Den < 0 then + Num := (Lval.Num / Rval.Num) * (Lval.Rbase ** (-Lval.Den)); + Den := Rval.Rbase ** (-Rval.Den); + else + Num := Lval.Num / Rval.Num; + Den := (Lval.Rbase ** Lval.Den) * + (Rval.Rbase ** (-Rval.Den)); + end if; + + return Store_Ureal + ((Num => Num, + Den => Den, + Rbase => 0, + Negative => Rneg)); + end; + + else + return Store_Ureal + ((Num => (Lval.Num / Rval.Num) * + (Rval.Rbase ** Rval.Den), + Den => Lval.Den, + Rbase => Lval.Rbase, + Negative => Rneg)); + end if; + + else + declare + Num, Den : Uint; + + begin + if Lval.Den < 0 then + Num := Lval.Num * (Lval.Rbase ** (-Lval.Den)); + Den := Rval.Num; + else + Num := Lval.Num; + Den := Rval.Num * (Lval.Rbase ** Lval.Den); + end if; + + if Rval.Rbase /= 0 then + if Rval.Den < 0 then + Den := Den * (Rval.Rbase ** (-Rval.Den)); + else + Num := Num * (Rval.Rbase ** Rval.Den); + end if; + + else + Num := Num * Rval.Den; + end if; + + return Store_Ureal_Normalized + ((Num => Num, + Den => Den, + Rbase => 0, + Negative => Rneg)); + end; + end if; + end UR_Div; + + ----------- + -- UR_Eq -- + ----------- + + function UR_Eq (Left, Right : Ureal) return Boolean is + begin + return not UR_Ne (Left, Right); + end UR_Eq; + + --------------------- + -- UR_Exponentiate -- + --------------------- + + function UR_Exponentiate (Real : Ureal; N : Uint) return Ureal is + X : constant Uint := abs N; + Bas : Ureal; + Val : Ureal_Entry; + Neg : Boolean; + IBas : Uint; + + begin + -- If base is negative, then the resulting sign depends on whether + -- the exponent is even or odd (even => positive, odd = negative) + + if UR_Is_Negative (Real) then + Neg := (N mod 2) /= 0; + Bas := UR_Negate (Real); + else + Neg := False; + Bas := Real; + end if; + + Val := Ureals.Table (Bas); + + -- If the base is a small integer, then we can return the result in + -- exponential form, which can save a lot of time for junk exponents. + + IBas := UR_Trunc (Bas); + + if IBas <= 16 + and then UR_From_Uint (IBas) = Bas + then + return Store_Ureal + ((Num => Uint_1, + Den => -N, + Rbase => UI_To_Int (UR_Trunc (Bas)), + Negative => Neg)); + + -- If the exponent is negative then we raise the numerator and the + -- denominator (after normalization) to the absolute value of the + -- exponent and we return the reciprocal. An assert error will happen + -- if the numerator is zero. + + elsif N < 0 then + pragma Assert (Val.Num /= 0); + Val := Normalize (Val); + + return Store_Ureal + ((Num => Val.Den ** X, + Den => Val.Num ** X, + Rbase => 0, + Negative => Neg)); + + -- If positive, we distinguish the case when the base is not zero, in + -- which case the new denominator is just the product of the old one + -- with the exponent, + + else + if Val.Rbase /= 0 then + + return Store_Ureal + ((Num => Val.Num ** X, + Den => Val.Den * X, + Rbase => Val.Rbase, + Negative => Neg)); + + -- And when the base is zero, in which case we exponentiate + -- the old denominator. + + else + return Store_Ureal + ((Num => Val.Num ** X, + Den => Val.Den ** X, + Rbase => 0, + Negative => Neg)); + end if; + end if; + end UR_Exponentiate; + + -------------- + -- UR_Floor -- + -------------- + + function UR_Floor (Real : Ureal) return Uint is + Val : constant Ureal_Entry := Normalize (Ureals.Table (Real)); + begin + if Val.Negative then + return UI_Negate ((Val.Num + Val.Den - 1) / Val.Den); + else + return Val.Num / Val.Den; + end if; + end UR_Floor; + + ------------------------ + -- UR_From_Components -- + ------------------------ + + function UR_From_Components + (Num : Uint; + Den : Uint; + Rbase : Nat := 0; + Negative : Boolean := False) + return Ureal + is + begin + return Store_Ureal + ((Num => Num, + Den => Den, + Rbase => Rbase, + Negative => Negative)); + end UR_From_Components; + + ------------------ + -- UR_From_Uint -- + ------------------ + + function UR_From_Uint (UI : Uint) return Ureal is + begin + return UR_From_Components + (abs UI, Uint_1, Negative => (UI < 0)); + end UR_From_Uint; + + ----------- + -- UR_Ge -- + ----------- + + function UR_Ge (Left, Right : Ureal) return Boolean is + begin + return not (Left < Right); + end UR_Ge; + + ----------- + -- UR_Gt -- + ----------- + + function UR_Gt (Left, Right : Ureal) return Boolean is + begin + return (Right < Left); + end UR_Gt; + + -------------------- + -- UR_Is_Negative -- + -------------------- + + function UR_Is_Negative (Real : Ureal) return Boolean is + begin + return Ureals.Table (Real).Negative; + end UR_Is_Negative; + + -------------------- + -- UR_Is_Positive -- + -------------------- + + function UR_Is_Positive (Real : Ureal) return Boolean is + begin + return not Ureals.Table (Real).Negative + and then Ureals.Table (Real).Num /= 0; + end UR_Is_Positive; + + ---------------- + -- UR_Is_Zero -- + ---------------- + + function UR_Is_Zero (Real : Ureal) return Boolean is + begin + return Ureals.Table (Real).Num = 0; + end UR_Is_Zero; + + ----------- + -- UR_Le -- + ----------- + + function UR_Le (Left, Right : Ureal) return Boolean is + begin + return not (Right < Left); + end UR_Le; + + ----------- + -- UR_Lt -- + ----------- + + function UR_Lt (Left, Right : Ureal) return Boolean is + begin + -- An operand is not less than itself + + if Same (Left, Right) then + return False; + + -- Deal with zero cases + + elsif UR_Is_Zero (Left) then + return UR_Is_Positive (Right); + + elsif UR_Is_Zero (Right) then + return Ureals.Table (Left).Negative; + + -- Different signs are decisive (note we dealt with zero cases) + + elsif Ureals.Table (Left).Negative + and then not Ureals.Table (Right).Negative + then + return True; + + elsif not Ureals.Table (Left).Negative + and then Ureals.Table (Right).Negative + then + return False; + + -- Signs are same, do rapid check based on worst case estimates of + -- decimal exponent, which will often be decisive. Precise test + -- depends on whether operands are positive or negative. + + elsif Decimal_Exponent_Hi (Left) < Decimal_Exponent_Lo (Right) then + return UR_Is_Positive (Left); + + elsif Decimal_Exponent_Lo (Left) > Decimal_Exponent_Hi (Right) then + return UR_Is_Negative (Left); + + -- If we fall through, full gruesome test is required. This happens + -- if the numbers are close together, or in some weird (/=10) base. + + else + declare + Imrk : constant Uintp.Save_Mark := Mark; + Rmrk : constant Urealp.Save_Mark := Mark; + Lval : Ureal_Entry; + Rval : Ureal_Entry; + Result : Boolean; + + begin + Lval := Ureals.Table (Left); + Rval := Ureals.Table (Right); + + -- An optimization. If both numbers are based, then subtract + -- common value of base to avoid unnecessarily giant numbers + + if Lval.Rbase = Rval.Rbase and then Lval.Rbase /= 0 then + if Lval.Den < Rval.Den then + Rval.Den := Rval.Den - Lval.Den; + Lval.Den := Uint_0; + else + Lval.Den := Lval.Den - Rval.Den; + Rval.Den := Uint_0; + end if; + end if; + + Lval := Normalize (Lval); + Rval := Normalize (Rval); + + if Lval.Negative then + Result := (Lval.Num * Rval.Den) > (Rval.Num * Lval.Den); + else + Result := (Lval.Num * Rval.Den) < (Rval.Num * Lval.Den); + end if; + + Release (Imrk); + Release (Rmrk); + return Result; + end; + end if; + end UR_Lt; + + ------------ + -- UR_Max -- + ------------ + + function UR_Max (Left, Right : Ureal) return Ureal is + begin + if Left >= Right then + return Left; + else + return Right; + end if; + end UR_Max; + + ------------ + -- UR_Min -- + ------------ + + function UR_Min (Left, Right : Ureal) return Ureal is + begin + if Left <= Right then + return Left; + else + return Right; + end if; + end UR_Min; + + ------------ + -- UR_Mul -- + ------------ + + function UR_Mul (Left : Uint; Right : Ureal) return Ureal is + begin + return UR_From_Uint (Left) * Right; + end UR_Mul; + + function UR_Mul (Left : Ureal; Right : Uint) return Ureal is + begin + return Left * UR_From_Uint (Right); + end UR_Mul; + + function UR_Mul (Left, Right : Ureal) return Ureal is + Lval : constant Ureal_Entry := Ureals.Table (Left); + Rval : constant Ureal_Entry := Ureals.Table (Right); + Num : Uint := Lval.Num * Rval.Num; + Den : Uint; + Rneg : constant Boolean := Lval.Negative xor Rval.Negative; + + begin + if Lval.Rbase = 0 then + if Rval.Rbase = 0 then + return Store_Ureal_Normalized + ((Num => Num, + Den => Lval.Den * Rval.Den, + Rbase => 0, + Negative => Rneg)); + + elsif Is_Integer (Num, Lval.Den) then + return Store_Ureal + ((Num => Num / Lval.Den, + Den => Rval.Den, + Rbase => Rval.Rbase, + Negative => Rneg)); + + elsif Rval.Den < 0 then + return Store_Ureal_Normalized + ((Num => Num * (Rval.Rbase ** (-Rval.Den)), + Den => Lval.Den, + Rbase => 0, + Negative => Rneg)); + + else + return Store_Ureal_Normalized + ((Num => Num, + Den => Lval.Den * (Rval.Rbase ** Rval.Den), + Rbase => 0, + Negative => Rneg)); + end if; + + elsif Lval.Rbase = Rval.Rbase then + return Store_Ureal + ((Num => Num, + Den => Lval.Den + Rval.Den, + Rbase => Lval.Rbase, + Negative => Rneg)); + + elsif Rval.Rbase = 0 then + if Is_Integer (Num, Rval.Den) then + return Store_Ureal + ((Num => Num / Rval.Den, + Den => Lval.Den, + Rbase => Lval.Rbase, + Negative => Rneg)); + + elsif Lval.Den < 0 then + return Store_Ureal_Normalized + ((Num => Num * (Lval.Rbase ** (-Lval.Den)), + Den => Rval.Den, + Rbase => 0, + Negative => Rneg)); + + else + return Store_Ureal_Normalized + ((Num => Num, + Den => Rval.Den * (Lval.Rbase ** Lval.Den), + Rbase => 0, + Negative => Rneg)); + end if; + + else + Den := Uint_1; + + if Lval.Den < 0 then + Num := Num * (Lval.Rbase ** (-Lval.Den)); + else + Den := Den * (Lval.Rbase ** Lval.Den); + end if; + + if Rval.Den < 0 then + Num := Num * (Rval.Rbase ** (-Rval.Den)); + else + Den := Den * (Rval.Rbase ** Rval.Den); + end if; + + return Store_Ureal_Normalized + ((Num => Num, + Den => Den, + Rbase => 0, + Negative => Rneg)); + end if; + end UR_Mul; + + ----------- + -- UR_Ne -- + ----------- + + function UR_Ne (Left, Right : Ureal) return Boolean is + begin + -- Quick processing for case of identical Ureal values (note that + -- this also deals with comparing two No_Ureal values). + + if Same (Left, Right) then + return False; + + -- Deal with case of one or other operand is No_Ureal, but not both + + elsif Same (Left, No_Ureal) or else Same (Right, No_Ureal) then + return True; + + -- Do quick check based on number of decimal digits + + elsif Decimal_Exponent_Hi (Left) < Decimal_Exponent_Lo (Right) or else + Decimal_Exponent_Lo (Left) > Decimal_Exponent_Hi (Right) + then + return True; + + -- Otherwise full comparison is required + + else + declare + Imrk : constant Uintp.Save_Mark := Mark; + Rmrk : constant Urealp.Save_Mark := Mark; + Lval : constant Ureal_Entry := Normalize (Ureals.Table (Left)); + Rval : constant Ureal_Entry := Normalize (Ureals.Table (Right)); + Result : Boolean; + + begin + if UR_Is_Zero (Left) then + return not UR_Is_Zero (Right); + + elsif UR_Is_Zero (Right) then + return not UR_Is_Zero (Left); + + -- Both operands are non-zero + + else + Result := + Rval.Negative /= Lval.Negative + or else Rval.Num /= Lval.Num + or else Rval.Den /= Lval.Den; + Release (Imrk); + Release (Rmrk); + return Result; + end if; + end; + end if; + end UR_Ne; + + --------------- + -- UR_Negate -- + --------------- + + function UR_Negate (Real : Ureal) return Ureal is + begin + return Store_Ureal + ((Num => Ureals.Table (Real).Num, + Den => Ureals.Table (Real).Den, + Rbase => Ureals.Table (Real).Rbase, + Negative => not Ureals.Table (Real).Negative)); + end UR_Negate; + + ------------ + -- UR_Sub -- + ------------ + + function UR_Sub (Left : Uint; Right : Ureal) return Ureal is + begin + return UR_From_Uint (Left) + UR_Negate (Right); + end UR_Sub; + + function UR_Sub (Left : Ureal; Right : Uint) return Ureal is + begin + return Left + UR_From_Uint (-Right); + end UR_Sub; + + function UR_Sub (Left, Right : Ureal) return Ureal is + begin + return Left + UR_Negate (Right); + end UR_Sub; + + ---------------- + -- UR_To_Uint -- + ---------------- + + function UR_To_Uint (Real : Ureal) return Uint is + Val : constant Ureal_Entry := Normalize (Ureals.Table (Real)); + Res : Uint; + + begin + Res := (Val.Num + (Val.Den / 2)) / Val.Den; + + if Val.Negative then + return UI_Negate (Res); + else + return Res; + end if; + end UR_To_Uint; + + -------------- + -- UR_Trunc -- + -------------- + + function UR_Trunc (Real : Ureal) return Uint is + Val : constant Ureal_Entry := Normalize (Ureals.Table (Real)); + begin + if Val.Negative then + return -(Val.Num / Val.Den); + else + return Val.Num / Val.Den; + end if; + end UR_Trunc; + + -------------- + -- UR_Write -- + -------------- + + procedure UR_Write (Real : Ureal; Brackets : Boolean := False) is + Val : constant Ureal_Entry := Ureals.Table (Real); + T : Uint; + + begin + -- If value is negative, we precede the constant by a minus sign + + if Val.Negative then + Write_Char ('-'); + end if; + + -- Zero is zero + + if Val.Num = 0 then + Write_Str ("0.0"); + + -- For constants with a denominator of zero, the value is simply the + -- numerator value, since we are dividing by base**0, which is 1. + + elsif Val.Den = 0 then + UI_Write (Val.Num, Decimal); + Write_Str (".0"); + + -- Small powers of 2 get written in decimal fixed-point format + + elsif Val.Rbase = 2 + and then Val.Den <= 3 + and then Val.Den >= -16 + then + if Val.Den = 1 then + T := Val.Num * (10/2); + UI_Write (T / 10, Decimal); + Write_Char ('.'); + UI_Write (T mod 10, Decimal); + + elsif Val.Den = 2 then + T := Val.Num * (100/4); + UI_Write (T / 100, Decimal); + Write_Char ('.'); + UI_Write (T mod 100 / 10, Decimal); + + if T mod 10 /= 0 then + UI_Write (T mod 10, Decimal); + end if; + + elsif Val.Den = 3 then + T := Val.Num * (1000 / 8); + UI_Write (T / 1000, Decimal); + Write_Char ('.'); + UI_Write (T mod 1000 / 100, Decimal); + + if T mod 100 /= 0 then + UI_Write (T mod 100 / 10, Decimal); + + if T mod 10 /= 0 then + UI_Write (T mod 10, Decimal); + end if; + end if; + + else + UI_Write (Val.Num * (Uint_2 ** (-Val.Den)), Decimal); + Write_Str (".0"); + end if; + + -- Constants in base 10 or 16 can be written in normal Ada literal + -- style, as long as they fit in the UI_Image_Buffer. Using hexadecimal + -- notation, 4 bytes are required for the 16# # part, and every fifth + -- character is an underscore. So, a buffer of size N has room for + -- ((N - 4) - (N - 4) / 5) * 4 bits, + -- or at least + -- N * 16 / 5 - 12 bits. + + elsif (Val.Rbase = 10 or else Val.Rbase = 16) + and then Num_Bits (Val.Num) < UI_Image_Buffer'Length * 16 / 5 - 12 + then + pragma Assert (Val.Den /= 0); + + -- Use fixed-point format for small scaling values + + if (Val.Rbase = 10 and then Val.Den < 0 and then Val.Den > -3) + or else (Val.Rbase = 16 and then Val.Den = -1) + then + UI_Write (Val.Num * Val.Rbase**(-Val.Den), Decimal); + Write_Str (".0"); + + -- Write hexadecimal constants in exponential notation with a zero + -- unit digit. This matches the Ada canonical form for floating point + -- numbers, and also ensures that the underscores end up in the + -- correct place. + + elsif Val.Rbase = 16 then + UI_Image (Val.Num, Hex); + pragma Assert (Val.Rbase = 16); + + Write_Str ("16#0."); + Write_Str (UI_Image_Buffer (4 .. UI_Image_Length)); + + -- For exponent, exclude 16# # and underscores from length + + UI_Image_Length := UI_Image_Length - 4; + UI_Image_Length := UI_Image_Length - UI_Image_Length / 5; + + Write_Char ('E'); + UI_Write (Int (UI_Image_Length) - Val.Den, Decimal); + + elsif Val.Den = 1 then + UI_Write (Val.Num / 10, Decimal); + Write_Char ('.'); + UI_Write (Val.Num mod 10, Decimal); + + elsif Val.Den = 2 then + UI_Write (Val.Num / 100, Decimal); + Write_Char ('.'); + UI_Write (Val.Num / 10 mod 10, Decimal); + UI_Write (Val.Num mod 10, Decimal); + + -- Else use decimal exponential format + + else + -- Write decimal constants with a non-zero unit digit. This + -- matches usual scientific notation. + + UI_Image (Val.Num, Decimal); + Write_Char (UI_Image_Buffer (1)); + Write_Char ('.'); + + if UI_Image_Length = 1 then + Write_Char ('0'); + else + Write_Str (UI_Image_Buffer (2 .. UI_Image_Length)); + end if; + + Write_Char ('E'); + UI_Write (Int (UI_Image_Length - 1) - Val.Den, Decimal); + end if; + + -- Constants in a base other than 10 can still be easily written in + -- normal Ada literal style if the numerator is one. + + elsif Val.Rbase /= 0 and then Val.Num = 1 then + Write_Int (Val.Rbase); + Write_Str ("#1.0#E"); + UI_Write (-Val.Den); + + -- Other constants with a base other than 10 are written using one + -- of the following forms, depending on the sign of the number + -- and the sign of the exponent (= minus denominator value) + + -- numerator.0*base**exponent + -- numerator.0*base**-exponent + + -- And of course an exponent of 0 can be omitted + + elsif Val.Rbase /= 0 then + if Brackets then + Write_Char ('['); + end if; + + UI_Write (Val.Num, Decimal); + Write_Str (".0"); + + if Val.Den /= 0 then + Write_Char ('*'); + Write_Int (Val.Rbase); + Write_Str ("**"); + + if Val.Den <= 0 then + UI_Write (-Val.Den, Decimal); + else + Write_Str ("(-"); + UI_Write (Val.Den, Decimal); + Write_Char (')'); + end if; + end if; + + if Brackets then + Write_Char (']'); + end if; + + -- Rationals where numerator is divisible by denominator can be output + -- as literals after we do the division. This includes the common case + -- where the denominator is 1. + + elsif Val.Num mod Val.Den = 0 then + UI_Write (Val.Num / Val.Den, Decimal); + Write_Str (".0"); + + -- Other non-based (rational) constants are written in num/den style + + else + if Brackets then + Write_Char ('['); + end if; + + UI_Write (Val.Num, Decimal); + Write_Str (".0/"); + UI_Write (Val.Den, Decimal); + Write_Str (".0"); + + if Brackets then + Write_Char (']'); + end if; + end if; + end UR_Write; + + ------------- + -- Ureal_0 -- + ------------- + + function Ureal_0 return Ureal is + begin + return UR_0; + end Ureal_0; + + ------------- + -- Ureal_1 -- + ------------- + + function Ureal_1 return Ureal is + begin + return UR_1; + end Ureal_1; + + ------------- + -- Ureal_2 -- + ------------- + + function Ureal_2 return Ureal is + begin + return UR_2; + end Ureal_2; + + -------------- + -- Ureal_10 -- + -------------- + + function Ureal_10 return Ureal is + begin + return UR_10; + end Ureal_10; + + --------------- + -- Ureal_100 -- + --------------- + + function Ureal_100 return Ureal is + begin + return UR_100; + end Ureal_100; + + ----------------- + -- Ureal_10_36 -- + ----------------- + + function Ureal_10_36 return Ureal is + begin + return UR_10_36; + end Ureal_10_36; + + ---------------- + -- Ureal_2_80 -- + ---------------- + + function Ureal_2_80 return Ureal is + begin + return UR_2_80; + end Ureal_2_80; + + ----------------- + -- Ureal_2_128 -- + ----------------- + + function Ureal_2_128 return Ureal is + begin + return UR_2_128; + end Ureal_2_128; + + ------------------- + -- Ureal_2_M_80 -- + ------------------- + + function Ureal_2_M_80 return Ureal is + begin + return UR_2_M_80; + end Ureal_2_M_80; + + ------------------- + -- Ureal_2_M_128 -- + ------------------- + + function Ureal_2_M_128 return Ureal is + begin + return UR_2_M_128; + end Ureal_2_M_128; + + ---------------- + -- Ureal_Half -- + ---------------- + + function Ureal_Half return Ureal is + begin + return UR_Half; + end Ureal_Half; + + --------------- + -- Ureal_M_0 -- + --------------- + + function Ureal_M_0 return Ureal is + begin + return UR_M_0; + end Ureal_M_0; + + ------------------- + -- Ureal_M_10_36 -- + ------------------- + + function Ureal_M_10_36 return Ureal is + begin + return UR_M_10_36; + end Ureal_M_10_36; + + ----------------- + -- Ureal_Tenth -- + ----------------- + + function Ureal_Tenth return Ureal is + begin + return UR_Tenth; + end Ureal_Tenth; + +end Urealp; diff --git a/gcc/ada/urealp.ads b/gcc/ada/urealp.ads new file mode 100644 index 000000000..ca90ac4a0 --- /dev/null +++ b/gcc/ada/urealp.ads @@ -0,0 +1,368 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- U R E A L P -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Support for universal real arithmetic + +with Types; use Types; +with Uintp; use Uintp; + +package Urealp is + + --------------------------------------- + -- Representation of Universal Reals -- + --------------------------------------- + + -- A universal real value is represented by a single value (which is + -- an index into an internal table). These values are not hashed, so + -- the equality operator should not be used on Ureal values (instead + -- use the UR_Eq function). + + -- A Ureal value represents an arbitrary precision universal real value, + -- stored internally using four components + + -- the numerator (Uint, always non-negative) + -- the denominator (Uint, always non-zero, always positive if base = 0) + -- a real base (Nat, either zero, or in the range 2 .. 16) + -- a sign flag (Boolean), set if negative + + -- If the base is zero, then the absolute value of the Ureal is simply + -- numerator/denominator. If the base is non-zero, then the absolute + -- value is num / (rbase ** den). + + -- Negative numbers are represented by the sign of the numerator being + -- negative. The denominator is always positive. + + -- A normalized Ureal value has base = 0, and numerator/denominator + -- reduced to lowest terms, with zero itself being represented as 0/1. + -- This is a canonical format, so that for normalized Ureal values it + -- is the case that two equal values always have the same denominator + -- and numerator values. + + -- Note: a value of minus zero is legitimate, and the operations in + -- Urealp preserve the handling of signed zeroes in accordance with + -- the rules of IEEE P754 ("IEEE floating point"). + + ------------------------------ + -- Types for Urealp Package -- + ------------------------------ + + type Ureal is private; + -- Type used for representation of universal reals + + No_Ureal : constant Ureal; + -- Constant used to indicate missing or unset Ureal value + + --------------------- + -- Ureal Constants -- + --------------------- + + function Ureal_0 return Ureal; + -- Returns value 0.0 + + function Ureal_M_0 return Ureal; + -- Returns value -0.0 + + function Ureal_Tenth return Ureal; + -- Returns value 0.1 + + function Ureal_Half return Ureal; + -- Returns value 0.5 + + function Ureal_1 return Ureal; + -- Returns value 1.0 + + function Ureal_2 return Ureal; + -- Returns value 2.0 + + function Ureal_10 return Ureal; + -- Returns value 10.0 + + function Ureal_100 return Ureal; + -- Returns value 100.0 + + function Ureal_2_80 return Ureal; + -- Returns value 2.0 ** 80 + + function Ureal_2_M_80 return Ureal; + -- Returns value 2.0 ** (-80) + + function Ureal_2_128 return Ureal; + -- Returns value 2.0 ** 128 + + function Ureal_2_M_128 return Ureal; + -- Returns value 2.0 ** (-128) + + function Ureal_10_36 return Ureal; + -- Returns value 10.0 ** 36 + + function Ureal_M_10_36 return Ureal; + -- Returns value -(10.0 + + ----------------- + -- Subprograms -- + ----------------- + + procedure Initialize; + -- Initialize Ureal tables. Note that Initialize must not be called if + -- Tree_Read is used. Note also that there is no Lock routine in this + -- unit. These tables are among the few tables that can be expanded + -- during Gigi processing. + + procedure Tree_Read; + -- Initializes internal tables from current tree file using the relevant + -- Table.Tree_Read routines. Note that Initialize should not be called if + -- Tree_Read is used. Tree_Read includes all necessary initialization. + + procedure Tree_Write; + -- Writes out internal tables to current tree file using the relevant + -- Table.Tree_Write routines. + + function Rbase (Real : Ureal) return Nat; + -- Return the base of the universal real + + function Denominator (Real : Ureal) return Uint; + -- Return the denominator of the universal real + + function Numerator (Real : Ureal) return Uint; + -- Return the numerator of the universal real + + function Norm_Den (Real : Ureal) return Uint; + -- Return the denominator of the universal real after a normalization + + function Norm_Num (Real : Ureal) return Uint; + -- Return the numerator of the universal real after a normalization + + function UR_From_Uint (UI : Uint) return Ureal; + -- Returns real corresponding to universal integer value + + function UR_To_Uint (Real : Ureal) return Uint; + -- Return integer value obtained by accurate rounding of real value. + -- The rounding of values half way between two integers is away from + -- zero, as required by normal Ada 95 rounding semantics. + + function UR_Trunc (Real : Ureal) return Uint; + -- Return integer value obtained by a truncation of real towards zero + + function UR_Ceiling (Real : Ureal) return Uint; + -- Return value of smallest integer not less than the given value + + function UR_Floor (Real : Ureal) return Uint; + -- Return value of smallest integer not greater than the given value + + -- Conversion table for above four functions + + -- Input To_Uint Trunc Ceiling Floor + -- 1.0 1 1 1 1 + -- 1.2 1 1 2 1 + -- 1.5 2 1 2 1 + -- 1.7 2 1 2 1 + -- 2.0 2 2 2 2 + -- -1.0 -1 -1 -1 -1 + -- -1.2 -1 -1 -1 -2 + -- -1.5 -2 -1 -1 -2 + -- -1.7 -2 -1 -1 -2 + -- -2.0 -2 -2 -2 -2 + + function UR_From_Components + (Num : Uint; + Den : Uint; + Rbase : Nat := 0; + Negative : Boolean := False) + return Ureal; + -- Builds real value from given numerator, denominator and base. The + -- value is negative if Negative is set to true, and otherwise is + -- non-negative. + + function UR_Add (Left : Ureal; Right : Ureal) return Ureal; + function UR_Add (Left : Ureal; Right : Uint) return Ureal; + function UR_Add (Left : Uint; Right : Ureal) return Ureal; + -- Returns real sum of operands + + function UR_Div (Left : Ureal; Right : Ureal) return Ureal; + function UR_Div (Left : Uint; Right : Ureal) return Ureal; + function UR_Div (Left : Ureal; Right : Uint) return Ureal; + -- Returns real quotient of operands. Fatal error if Right is zero + + function UR_Mul (Left : Ureal; Right : Ureal) return Ureal; + function UR_Mul (Left : Uint; Right : Ureal) return Ureal; + function UR_Mul (Left : Ureal; Right : Uint) return Ureal; + -- Returns real product of operands + + function UR_Sub (Left : Ureal; Right : Ureal) return Ureal; + function UR_Sub (Left : Uint; Right : Ureal) return Ureal; + function UR_Sub (Left : Ureal; Right : Uint) return Ureal; + -- Returns real difference of operands + + function UR_Exponentiate (Real : Ureal; N : Uint) return Ureal; + -- Returns result of raising Ureal to Uint power. + -- Fatal error if Left is 0 and Right is negative. + + function UR_Abs (Real : Ureal) return Ureal; + -- Returns abs function of real + + function UR_Negate (Real : Ureal) return Ureal; + -- Returns negative of real + + function UR_Eq (Left, Right : Ureal) return Boolean; + -- Compares reals for equality + + function UR_Max (Left, Right : Ureal) return Ureal; + -- Returns the maximum of two reals + + function UR_Min (Left, Right : Ureal) return Ureal; + -- Returns the minimum of two reals + + function UR_Ne (Left, Right : Ureal) return Boolean; + -- Compares reals for inequality + + function UR_Lt (Left, Right : Ureal) return Boolean; + -- Compares reals for less than + + function UR_Le (Left, Right : Ureal) return Boolean; + -- Compares reals for less than or equal + + function UR_Gt (Left, Right : Ureal) return Boolean; + -- Compares reals for greater than + + function UR_Ge (Left, Right : Ureal) return Boolean; + -- Compares reals for greater than or equal + + function UR_Is_Zero (Real : Ureal) return Boolean; + -- Tests if real value is zero + + function UR_Is_Negative (Real : Ureal) return Boolean; + -- Tests if real value is negative, note that negative zero gives true + + function UR_Is_Positive (Real : Ureal) return Boolean; + -- Test if real value is greater than zero + + procedure UR_Write (Real : Ureal; Brackets : Boolean := False); + -- Writes value of Real to standard output. Used for debugging and + -- tree/source output, and also for -gnatR representation output. If the + -- result is easily representable as a standard Ada literal, it will be + -- given that way, but as a result of evaluation of static expressions, it + -- is possible to generate constants (e.g. 1/13) which have no such + -- representation. In such cases (and in cases where it is too much work to + -- figure out the Ada literal), the string that is output is of the form + -- of some expression such as integer/integer, or integer*integer**integer. + -- In the case where an expression is output, if Brackets is set to True, + -- the expression is surrounded by square brackets. + + procedure pr (Real : Ureal); + pragma Export (Ada, pr); + -- Writes value of Real to standard output with a terminating line return, + -- using UR_Write as described above. This is for use from the debugger. + + ------------------------ + -- Operator Renamings -- + ------------------------ + + function "+" (Left : Ureal; Right : Ureal) return Ureal renames UR_Add; + function "+" (Left : Uint; Right : Ureal) return Ureal renames UR_Add; + function "+" (Left : Ureal; Right : Uint) return Ureal renames UR_Add; + + function "/" (Left : Ureal; Right : Ureal) return Ureal renames UR_Div; + function "/" (Left : Uint; Right : Ureal) return Ureal renames UR_Div; + function "/" (Left : Ureal; Right : Uint) return Ureal renames UR_Div; + + function "*" (Left : Ureal; Right : Ureal) return Ureal renames UR_Mul; + function "*" (Left : Uint; Right : Ureal) return Ureal renames UR_Mul; + function "*" (Left : Ureal; Right : Uint) return Ureal renames UR_Mul; + + function "-" (Left : Ureal; Right : Ureal) return Ureal renames UR_Sub; + function "-" (Left : Uint; Right : Ureal) return Ureal renames UR_Sub; + function "-" (Left : Ureal; Right : Uint) return Ureal renames UR_Sub; + + function "**" (Real : Ureal; N : Uint) return Ureal + renames UR_Exponentiate; + + function "abs" (Real : Ureal) return Ureal renames UR_Abs; + + function "-" (Real : Ureal) return Ureal renames UR_Negate; + + function "=" (Left, Right : Ureal) return Boolean renames UR_Eq; + + function "<" (Left, Right : Ureal) return Boolean renames UR_Lt; + + function "<=" (Left, Right : Ureal) return Boolean renames UR_Le; + + function ">=" (Left, Right : Ureal) return Boolean renames UR_Ge; + + function ">" (Left, Right : Ureal) return Boolean renames UR_Gt; + + ----------------------------- + -- Mark/Release Processing -- + ----------------------------- + + -- The space used by Ureal data is not automatically reclaimed. However, + -- a mark-release regime is implemented which allows storage to be + -- released back to a previously noted mark. This is used for example + -- when doing comparisons, where only intermediate results get stored + -- that do not need to be saved for future use. + + type Save_Mark is private; + + function Mark return Save_Mark; + -- Note mark point for future release + + procedure Release (M : Save_Mark); + -- Release storage allocated since mark was noted + + ------------------------------------ + -- Representation of Ureal Values -- + ------------------------------------ + +private + + type Ureal is new Int range Ureal_Low_Bound .. Ureal_High_Bound; + for Ureal'Size use 32; + + No_Ureal : constant Ureal := Ureal'First; + + type Save_Mark is new Int; + + pragma Inline (Denominator); + pragma Inline (Mark); + pragma Inline (Norm_Num); + pragma Inline (Norm_Den); + pragma Inline (Numerator); + pragma Inline (Rbase); + pragma Inline (Release); + pragma Inline (Ureal_0); + pragma Inline (Ureal_M_0); + pragma Inline (Ureal_Tenth); + pragma Inline (Ureal_Half); + pragma Inline (Ureal_1); + pragma Inline (Ureal_2); + pragma Inline (Ureal_10); + pragma Inline (UR_From_Components); + +end Urealp; diff --git a/gcc/ada/urealp.h b/gcc/ada/urealp.h new file mode 100644 index 000000000..90e5d7c65 --- /dev/null +++ b/gcc/ada/urealp.h @@ -0,0 +1,50 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * U R E A L P * + * * + * C Header File * + * * + * Copyright (C) 1992-2007, Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING3. If not, go to * + * http://www.gnu.org/licenses for a complete copy of the license. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* This file corresponds to the Ada package specification Urealp. It was + created manually from the files urealp.ads and urealp.adb */ + +/* Support for universal real arithmetic. */ + +#define Numerator urealp__numerator +extern Uint Numerator (Ureal); + +#define Denominator urealp__denominator +extern Uint Denominator (Ureal); + +#define Rbase urealp__rbase +extern Nat Rbase (Ureal); + +#define UR_Is_Negative urealp__ur_is_negative +extern Boolean UR_Is_Negative (Ureal); + +#define UR_Is_Zero urealp__ur_is_zero +extern Boolean UR_Is_Zero (Ureal); + +enum Rounding_Mode {Floor = 0, Ceiling = 1, Round = 2, Round_Even = 3}; + +#define Machine eval_fat__machine +extern Ureal Machine (Entity_Id, Ureal, enum Rounding_Mode, + Node_Id); diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb new file mode 100644 index 000000000..4d395b4dc --- /dev/null +++ b/gcc/ada/usage.adb @@ -0,0 +1,634 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- U S A G E -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Warning: the output of this usage for warnings is duplicated in the GNAT +-- reference manual. Be sure to update that if you change the warning list. + +with Targparm; use Targparm; +with Namet; use Namet; +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; + +with System.WCh_Con; use System.WCh_Con; + +procedure Usage is + + procedure Write_Switch_Char (Sw : String; Prefix : String := "gnat"); + -- Output two spaces followed by the switch character minus followed + -- Prefix, followed by the string given as the argument, and then enough + -- blanks to tab to column 13, i.e. assuming Sw is not longer than 5 + -- characters, the maximum allowed, Write_Switch_Char will always output + -- exactly 12 characters. + + ----------------------- + -- Write_Switch_Char -- + ----------------------- + + procedure Write_Switch_Char (Sw : String; Prefix : String := "gnat") is + begin + Write_Str (" -"); + Write_Str (Prefix); + Write_Str (Sw); + + for J in 1 .. 12 - 3 - Prefix'Length - Sw'Length loop + Write_Char (' '); + end loop; + end Write_Switch_Char; + +-- Start of processing for Usage + +begin + Find_Program_Name; + + -- For gnatmake, we are appending this information to the end of + -- the normal gnatmake output, so generate appropriate header + + if Name_Len >= 8 + and then (Name_Buffer (Name_Len - 7 .. Name_Len) = "gnatmake" + or else + Name_Buffer (Name_Len - 7 .. Name_Len) = "GNATMAKE") + then + Write_Eol; + Write_Line ("Compiler switches (passed to the compiler by gnatmake):"); + + else + -- Usage line + + Write_Str ("Usage: "); + Write_Program_Name; + Write_Char (' '); + Write_Str ("switches sfile"); + Write_Eol; + Write_Eol; + + -- Line for sfile + + Write_Line (" sfile Source file name"); + end if; + + Write_Eol; + + -- Common GCC switches not available for JVM, .NET, and AAMP targets + + if VM_Target = No_VM and then not AAMP_On_Target then + Write_Switch_Char ("fstack-check ", ""); + Write_Line ("Generate stack checking code"); + + Write_Switch_Char ("fno-inline ", ""); + Write_Line ("Inhibit all inlining (makes executable smaller)"); + + Write_Switch_Char ("fpreserve-control-flow ", ""); + Write_Line ("Preserve control flow for coverage analysis"); + end if; + + -- Common switches available to both GCC and JGNAT + + Write_Switch_Char ("g ", ""); + Write_Line ("Generate debugging information"); + + Write_Switch_Char ("Idir ", ""); + Write_Line ("Specify source files search path"); + + Write_Switch_Char ("I- ", ""); + Write_Line ("Do not look for sources in current directory"); + + Write_Switch_Char ("O[0123] ", ""); + Write_Line ("Control the optimization level"); + + Write_Eol; + + -- Individual lines for switches. Write_Switch_Char outputs fourteen + -- characters, so the remaining message is allowed to be a maximum + -- of 65 characters to be comfortable on an 80 character device. + -- If the Write_Str fits on one line, it is short enough! + + -- Line for -gnata switch + + Write_Switch_Char ("a"); + Write_Line ("Assertions enabled. Pragma Assert/Debug to be activated"); + + -- Line for -gnatA switch + + Write_Switch_Char ("A"); + Write_Line ("Avoid processing gnat.adc, if present file will be ignored"); + + -- Line for -gnatb switch + + Write_Switch_Char ("b"); + Write_Line ("Generate brief messages to stderr even if verbose mode set"); + + -- Line for -gnatB switch + + Write_Switch_Char ("B"); + Write_Line ("Assume no bad (invalid) values except in 'Valid attribute"); + + -- Line for -gnatc switch + + Write_Switch_Char ("c"); + Write_Line ("Check syntax and semantics only (no code generation)"); + + -- Line for -gnatC switch + + Write_Switch_Char ("C"); + Write_Line ("Generate CodePeer information (no code generation)"); + + -- Line for -gnatd switch + + Write_Switch_Char ("d?"); + Write_Line ("Compiler debug option ? ([.]a-z,A-Z,0-9), see debug.adb"); + + -- Line for -gnatD switch + + Write_Switch_Char ("D"); + Write_Line ("Debug expanded generated code (max line length = 72)"); + Write_Switch_Char ("Dnn"); + Write_Line ("Debug expanded generated code (max line length = nn)"); + + -- Line for -gnatec switch + + Write_Switch_Char ("ec=?"); + Write_Line ("Specify configuration pragmas file, e.g. -gnatec=/x/f.adc"); + + -- Line for -gnateD switch + + Write_Switch_Char ("eD?"); + Write_Line ("Define or redefine preprocessing symbol, e.g. -gnateDsym=val"); + + -- Line for -gnateE switch + + Write_Switch_Char ("eE"); + Write_Line ("Generate extra information in exception messages"); + + -- Line for -gnatef switch + + Write_Switch_Char ("ef"); + Write_Line ("Full source path in brief error messages"); + + -- Line for -gnateG switch + + Write_Switch_Char ("eG"); + Write_Line ("Generate preprocessed source"); + + -- Line for -gnateI switch + + Write_Switch_Char ("eInn"); + Write_Line ("Index in multi-unit source, e.g. -gnateI2"); + + -- Line for -gnatem switch + + Write_Switch_Char ("em=?"); + Write_Line ("Specify mapping file, e.g. -gnatem=mapping"); + + -- Line for -gnatep switch + + Write_Switch_Char ("ep=?"); + Write_Line ("Specify preprocessing data file, e.g. -gnatep=prep.data"); + + -- Line for -gnateP switch + + Write_Switch_Char ("eP"); + Write_Line ("Pure/Prelaborate errors generate warnings rather than errors"); + + -- Line for -gnateS switch + + Write_Switch_Char ("eS"); + Write_Line ("Generate SCO (Source Coverage Obligation) information"); + + -- Line for -gnatE switch + + Write_Switch_Char ("E"); + Write_Line ("Dynamic elaboration checking mode enabled"); + + -- Line for -gnatf switch + + Write_Switch_Char ("f"); + Write_Line ("Full errors. Verbose details, all undefined references"); + + -- Line for -gnatF switch + + Write_Switch_Char ("F"); + Write_Line ("Force all import/export external names to all uppercase"); + + -- Line for -gnatg switch + + Write_Switch_Char ("g"); + Write_Line ("GNAT implementation mode (used for compiling GNAT units)"); + + -- Lines for -gnatG switch + + Write_Switch_Char ("G"); + Write_Line ("Output generated expanded code (max line length = 72)"); + Write_Switch_Char ("Gnn"); + Write_Line ("Output generated expanded code (max line length = nn)"); + + -- Line for -gnath switch + + Write_Switch_Char ("h"); + Write_Line ("Output this usage (help) information"); + + -- Line for -gnati switch + + Write_Switch_Char ("i?"); + Write_Line ("Identifier char set (?=1/2/3/4/5/8/9/p/f/n/w)"); + + -- Line for -gnatI switch + + Write_Switch_Char ("I"); + Write_Line ("Ignore all representation clauses"); + + -- Line for -gnatj switch + + Write_Switch_Char ("jnn"); + Write_Line ("Format error and warning messages to fit nn character lines"); + + -- Line for -gnatk switch + + Write_Switch_Char ("k"); + Write_Line ("Limit file names to nn characters (k = krunch)"); + + -- Lines for -gnatl switch + + Write_Switch_Char ("l"); + Write_Line ("Output full source listing with embedded error messages"); + Write_Switch_Char ("l=f"); + Write_Line ("Output full source listing to specified file"); + + -- Line for -gnatL switch + + Write_Switch_Char ("L"); + Write_Line ("List corresponding source text in -gnatG or -gnatD output"); + + -- Line for -gnatm switch + + Write_Switch_Char ("mnn"); + Write_Line ("Limit number of detected errors/warnings to nn (1-999999)"); + + -- Line for -gnatn switch + + Write_Switch_Char ("n"); + Write_Line ("Enable pragma Inline (both within and across units)"); + + -- Line for -gnatN switch + + Write_Switch_Char ("N"); + Write_Line ("Full (frontend) inlining of subprograms"); + + -- Line for -gnato switch + + Write_Switch_Char ("o"); + Write_Line ("Enable overflow checking (off by default)"); + + -- Line for -gnatO switch + + Write_Switch_Char ("O nm "); + Write_Line ("Set name of output ali file (internal switch)"); + + -- Line for -gnatp switch + + Write_Switch_Char ("p"); + Write_Line ("Suppress all checks"); + + -- Line for -gnatP switch + + Write_Switch_Char ("P"); + Write_Line ("Generate periodic calls to System.Polling.Poll"); + + -- Line for -gnatq switch + + Write_Switch_Char ("q"); + Write_Line ("Don't quit, try semantics, even if parse errors"); + + -- Line for -gnatQ switch + + Write_Switch_Char ("Q"); + Write_Line ("Don't quit, write ali/tree file even if compile errors"); + + -- Line for -gnatr switch + + Write_Switch_Char ("r"); + Write_Line ("Treat pragma Restrictions as Restriction_Warnings"); + + -- Lines for -gnatR switch + + Write_Switch_Char ("R?"); + Write_Line ("List rep info (?=0/1/2/3 for none/types/all/variable)"); + Write_Switch_Char ("R?s"); + Write_Line ("List rep info to file.rep instead of standard output"); + + -- Lines for -gnats switch + + Write_Switch_Char ("s"); + Write_Line ("Syntax check only"); + + -- Lines for -gnatS switch + + Write_Switch_Char ("S"); + Write_Line ("Print listing of package Standard"); + + -- Lines for -gnatt switch + + Write_Switch_Char ("t"); + Write_Line ("Tree output file to be generated"); + + -- Line for -gnatT switch + + Write_Switch_Char ("Tnn"); + Write_Line ("All compiler tables start at nn times usual starting size"); + + -- Line for -gnatu switch + + Write_Switch_Char ("u"); + Write_Line ("List units for this compilation"); + + -- Line for -gnatU switch + + Write_Switch_Char ("U"); + Write_Line ("Enable unique tag for error messages"); + + -- Line for -gnatv switch + + Write_Switch_Char ("v"); + Write_Line ("Verbose mode. Full error output with source lines to stdout"); + + -- Line for -gnatV switch + + Write_Switch_Char ("Vxx"); + Write_Line + ("Enable selected validity checking mode, xx = list of parameters:"); + Write_Line (" a turn on all validity checking options"); + Write_Line (" c turn on checking for copies"); + Write_Line (" C turn off checking for copies"); + Write_Line (" d turn on default (RM) checking"); + Write_Line (" D turn off default (RM) checking"); + Write_Line (" e turn on checking for elementary components"); + Write_Line (" E turn off checking for elementary components"); + Write_Line (" f turn on checking for floating-point"); + Write_Line (" F turn off checking for floating-point"); + Write_Line (" i turn on checking for in params"); + Write_Line (" I turn off checking for in params"); + Write_Line (" m turn on checking for in out params"); + Write_Line (" M turn off checking for in out params"); + Write_Line (" o turn on checking for operators/attributes"); + Write_Line (" O turn off checking for operators/attributes"); + Write_Line (" p turn on checking for parameters"); + Write_Line (" P turn off checking for parameters"); + Write_Line (" r turn on checking for returns"); + Write_Line (" R turn off checking for returns"); + Write_Line (" s turn on checking for subscripts"); + Write_Line (" S turn off checking for subscripts"); + Write_Line (" t turn on checking for tests"); + Write_Line (" T turn off checking for tests"); + Write_Line (" n turn off all validity checks (including RM)"); + + -- Lines for -gnatw switch + + Write_Switch_Char ("wxx"); + Write_Line ("Enable selected warning modes, xx = list of parameters:"); + Write_Line (" a turn on all info/warnings marked below with +"); + Write_Line (" A turn off all optional info/warnings"); + Write_Line (" .a*+ turn on warnings for failing assertion"); + Write_Line (" .A turn off warnings for failing assertion"); + Write_Line (" b+ turn on warnings for bad fixed value " & + "(not multiple of small)"); + Write_Line (" B* turn off warnings for bad fixed value " & + "(not multiple of small)"); + Write_Line (" .b*+ turn on warnings for biased representation"); + Write_Line (" .B turn off warnings for biased representation"); + Write_Line (" c+ turn on warnings for constant conditional"); + Write_Line (" C* turn off warnings for constant conditional"); + Write_Line (" .c+ turn on warnings for unrepped components"); + Write_Line (" .C* turn off warnings for unrepped components"); + Write_Line (" d turn on warnings for implicit dereference"); + Write_Line (" D* turn off warnings for implicit dereference"); + Write_Line (" e treat all warnings (but not info) as errors"); + Write_Line (" .e turn on every optional info/warning " & + "(no exceptions)"); + Write_Line (" f+ turn on warnings for unreferenced formal"); + Write_Line (" F* turn off warnings for unreferenced formal"); + Write_Line (" g*+ turn on warnings for unrecognized pragma"); + Write_Line (" G turn off warnings for unrecognized pragma"); + Write_Line (" h turn on warnings for hiding declarations"); + Write_Line (" H* turn off warnings for hiding declarations"); + Write_Line (" .h turn on warnings for holes in records"); + Write_Line (" .H* turn off warnings for holes in records"); + Write_Line (" i*+ turn on warnings for implementation unit"); + Write_Line (" I turn off warnings for implementation unit"); + Write_Line (" .i turn on warnings for overlapping actuals"); + Write_Line (" .I* turn off warnings for overlapping actuals"); + Write_Line (" j+ turn on warnings for obsolescent " & + "(annex J) feature"); + Write_Line (" J* turn off warnings for obsolescent " & + "(annex J) feature"); + Write_Line (" k+ turn on warnings on constant variable"); + Write_Line (" K* turn off warnings on constant variable"); + Write_Line (" l turn on warnings for missing " & + "elaboration pragma"); + Write_Line (" L* turn off warnings for missing " & + "elaboration pragma"); + Write_Line (" .l* turn on info messages for inherited aspects"); + Write_Line (" .L turn off info messages for inherited aspects"); + Write_Line (" m+ turn on warnings for variable assigned " & + "but not read"); + Write_Line (" M* turn off warnings for variable assigned " & + "but not read"); + Write_Line (" .m* turn on warnings for suspicious modulus value"); + Write_Line (" .M turn off warnings for suspicious modulus value"); + Write_Line (" n* normal warning mode (cancels -gnatws/-gnatwe)"); + Write_Line (" o* turn on warnings for address clause overlay"); + Write_Line (" O turn off warnings for address clause overlay"); + Write_Line (" .o turn on warnings for out parameters assigned " & + "but not read"); + Write_Line (" .O* turn off warnings for out parameters assigned " & + "but not read"); + Write_Line (" p+ turn on warnings for ineffective pragma " & + "Inline in frontend"); + Write_Line (" P* turn off warnings for ineffective pragma " & + "Inline in frontend"); + Write_Line (" .p+ turn on warnings for suspicious parameter " & + "order"); + Write_Line (" .P* turn off warnings for suspicious parameter " & + "order"); + Write_Line (" q*+ turn on warnings for questionable " & + "missing parenthesis"); + Write_Line (" Q turn off warnings for questionable " & + "missing parenthesis"); + Write_Line (" r+ turn on warnings for redundant construct"); + Write_Line (" R* turn off warnings for redundant construct"); + Write_Line (" .r+ turn on warnings for object renaming function"); + Write_Line (" .R* turn off warnings for object renaming function"); + Write_Line (" s suppress all info/warnings"); + Write_Line (" .s turn on warnings for overridden size clause"); + Write_Line (" .S* turn off warnings for overridden size clause"); + Write_Line (" t turn on warnings for tracking deleted code"); + Write_Line (" T* turn off warnings for tracking deleted code"); + Write_Line (" u+ turn on warnings for unused entity"); + Write_Line (" U* turn off warnings for unused entity"); + Write_Line (" .u turn on warnings for unordered enumeration"); + Write_Line (" .U* turn off warnings for unordered enumeration"); + Write_Line (" v*+ turn on warnings for unassigned variable"); + Write_Line (" V turn off warnings for unassigned variable"); + Write_Line (" .v*+ turn on info messages for reverse bit order"); + Write_Line (" .V turn off info messages for reverse bit order"); + Write_Line (" w*+ turn on warnings for wrong low bound assumption"); + Write_Line (" W turn off warnings for wrong low bound " & + "assumption"); + Write_Line (" .w turn on warnings on pragma Warnings Off"); + Write_Line (" .W* turn off warnings on pragma Warnings Off"); + Write_Line (" x*+ turn on warnings for export/import"); + Write_Line (" X turn off warnings for export/import"); + Write_Line (" .x+ turn on warnings for non-local exception"); + Write_Line (" .X* turn off warnings for non-local exception"); + Write_Line (" y*+ turn on warnings for Ada 2005 incompatibility"); + Write_Line (" Y turn off warnings for Ada 2005 incompatibility"); + Write_Line (" z*+ turn on warnings for suspicious " & + "unchecked conversion"); + Write_Line (" Z turn off warnings for suspicious " & + "unchecked conversion"); + Write_Line (" * indicates default in above list"); + Write_Line (" + indicates warning flag included in -gnatwa"); + + -- Line for -gnatW switch + + Write_Switch_Char ("W"); + Write_Str ("Wide character encoding method ("); + + for J in WC_Encoding_Method loop + Write_Char (WC_Encoding_Letters (J)); + + if J = WC_Encoding_Method'Last then + Write_Char (')'); + else + Write_Char ('/'); + end if; + end loop; + + Write_Eol; + + -- Line for -gnatx switch + + Write_Switch_Char ("x"); + Write_Line ("Suppress output of cross-reference information"); + + -- Line for -gnatX switch + + Write_Switch_Char ("X"); + Write_Line ("Language extensions permitted"); + + -- Lines for -gnaty switch + + Write_Switch_Char ("y"); + Write_Line ("Enable default style checks (same as -gnaty3abcefhiklmnprst)"); + Write_Switch_Char ("yxx"); + Write_Line ("Enable selected style checks xx = list of parameters:"); + Write_Line (" 1-9 check indentation"); + Write_Line (" a check attribute casing"); + Write_Line (" A check array attribute indexes"); + Write_Line (" b check no blanks at end of lines"); + Write_Line (" B check no use of AND/OR for boolean expressions"); + Write_Line (" c check comment format"); + Write_Line (" d check no DOS line terminators"); + Write_Line (" e check end/exit labels present"); + Write_Line (" f check no form feeds/vertical tabs in source"); + Write_Line (" g check standard GNAT style rules"); + Write_Line (" h check no horizontal tabs in source"); + Write_Line (" i check if-then layout"); + Write_Line (" I check mode in"); + Write_Line (" k check casing rules for keywords"); + Write_Line (" l check reference manual layout"); + Write_Line (" Lnn check max nest level < nn "); + Write_Line (" m check line length <= 79 characters"); + Write_Line (" n check casing of package Standard identifiers"); + Write_Line (" Mnn check line length <= nn characters"); + Write_Line (" N turn off all checks"); + Write_Line (" o check subprogram bodies in alphabetical order"); + Write_Line (" O check overriding indicators"); + Write_Line (" p check pragma casing"); + Write_Line (" r check casing for identifier references"); + Write_Line (" s check separate subprogram specs present"); + Write_Line (" S check separate lines after THEN or ELSE"); + Write_Line (" t check token separation rules"); + Write_Line (" u check no unnecessary blank lines"); + Write_Line (" x check extra parentheses around conditionals"); + Write_Line (" y turn on default style checks"); + Write_Line (" - subtract (turn off) subsequent checks"); + Write_Line (" + add (turn on) subsequent checks"); + + -- Lines for -gnatyN switch + + Write_Switch_Char ("yN"); + Write_Line ("Cancel all previously set style checks"); + + -- Lines for -gnatzc switch + + Write_Switch_Char ("zc"); + Write_Line ("Distribution stub generation for caller stubs"); + + -- Lines for -gnatzr switch + + Write_Switch_Char ("zr"); + Write_Line ("Distribution stub generation for receiver stubs"); + + -- Line for -gnat83 switch + + Write_Switch_Char ("83"); + Write_Line ("Enforce Ada 83 restrictions"); + + -- Line for -gnat95 switch + + Write_Switch_Char ("95"); + + if Ada_Version_Default = Ada_95 then + Write_Line ("Ada 95 mode (default)"); + else + Write_Line ("Enforce Ada 95 restrictions"); + end if; + + -- Line for -gnat05 switch + + Write_Switch_Char ("05"); + + if Ada_Version_Default = Ada_2005 then + Write_Line ("Ada 2005 mode (default)"); + else + Write_Line ("Enforce Ada 2005 restrictions"); + end if; + + -- Line for -gnat12 switch + + Write_Switch_Char ("12"); + + if Ada_Version_Default = Ada_2012 then + Write_Line ("Ada 2012 mode (default)"); + else + Write_Line ("Allow Ada 2012 extensions"); + end if; + + -- Line for -gnat-p switch + + Write_Switch_Char ("-p"); + Write_Line ("Cancel effect of previous -gnatp switch"); + +end Usage; diff --git a/gcc/ada/usage.ads b/gcc/ada/usage.ads new file mode 100644 index 000000000..5e009fe82 --- /dev/null +++ b/gcc/ada/usage.ads @@ -0,0 +1,28 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- U S A G E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Procedure to generate screen of usage information if no file name present + +procedure Usage; diff --git a/gcc/ada/validsw.adb b/gcc/ada/validsw.adb new file mode 100644 index 000000000..1c7d5cfc6 --- /dev/null +++ b/gcc/ada/validsw.adb @@ -0,0 +1,242 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V A L I D S W -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Opt; use Opt; + +package body Validsw is + + ---------------------------------- + -- Reset_Validity_Check_Options -- + ---------------------------------- + + procedure Reset_Validity_Check_Options is + begin + Validity_Check_Components := False; + Validity_Check_Copies := False; + Validity_Check_Default := True; + Validity_Check_Floating_Point := False; + Validity_Check_In_Out_Params := False; + Validity_Check_In_Params := False; + Validity_Check_Operands := False; + Validity_Check_Returns := False; + Validity_Check_Subscripts := False; + Validity_Check_Tests := False; + end Reset_Validity_Check_Options; + + --------------------------------- + -- Save_Validity_Check_Options -- + --------------------------------- + + procedure Save_Validity_Check_Options + (Options : out Validity_Check_Options) + is + P : Natural := 0; + + procedure Add (C : Character; S : Boolean); + -- Add given character C to string if switch S is true + + procedure Add (C : Character; S : Boolean) is + begin + if S then + P := P + 1; + Options (P) := C; + end if; + end Add; + + -- Start of processing for Save_Validity_Check_Options + + begin + for K in Options'Range loop + Options (K) := ' '; + end loop; + + Add ('n', not Validity_Check_Default); + + Add ('c', Validity_Check_Copies); + Add ('e', Validity_Check_Components); + Add ('f', Validity_Check_Floating_Point); + Add ('i', Validity_Check_In_Params); + Add ('m', Validity_Check_In_Out_Params); + Add ('o', Validity_Check_Operands); + Add ('r', Validity_Check_Returns); + Add ('s', Validity_Check_Subscripts); + Add ('t', Validity_Check_Tests); + end Save_Validity_Check_Options; + + ---------------------------------------- + -- Set_Default_Validity_Check_Options -- + ---------------------------------------- + + procedure Set_Default_Validity_Check_Options is + begin + Reset_Validity_Check_Options; + Set_Validity_Check_Options ("d"); + end Set_Default_Validity_Check_Options; + + -------------------------------- + -- Set_Validity_Check_Options -- + -------------------------------- + + -- Version used when no error checking is required + + procedure Set_Validity_Check_Options (Options : String) is + OK : Boolean; + EC : Natural; + pragma Warnings (Off, OK); + pragma Warnings (Off, EC); + begin + Set_Validity_Check_Options (Options, OK, EC); + end Set_Validity_Check_Options; + + -- Normal version with error checking + + procedure Set_Validity_Check_Options + (Options : String; + OK : out Boolean; + Err_Col : out Natural) + is + J : Natural; + C : Character; + + begin + J := Options'First; + while J <= Options'Last loop + C := Options (J); + J := J + 1; + + -- Turn on validity checking (gets turned off by Vn) + + Validity_Checks_On := True; + + case C is + + when 'c' => + Validity_Check_Copies := True; + + when 'd' => + Validity_Check_Default := True; + + when 'e' => + Validity_Check_Components := True; + + when 'f' => + Validity_Check_Floating_Point := True; + + when 'i' => + Validity_Check_In_Params := True; + + when 'm' => + Validity_Check_In_Out_Params := True; + + when 'o' => + Validity_Check_Operands := True; + + when 'p' => + Validity_Check_Parameters := True; + + when 'r' => + Validity_Check_Returns := True; + + when 's' => + Validity_Check_Subscripts := True; + + when 't' => + Validity_Check_Tests := True; + + when 'C' => + Validity_Check_Copies := False; + + when 'D' => + Validity_Check_Default := False; + + when 'E' => + Validity_Check_Components := False; + + when 'I' => + Validity_Check_In_Params := False; + + when 'F' => + Validity_Check_Floating_Point := False; + + when 'M' => + Validity_Check_In_Out_Params := False; + + when 'O' => + Validity_Check_Operands := False; + + when 'P' => + Validity_Check_Parameters := False; + + when 'R' => + Validity_Check_Returns := False; + + when 'S' => + Validity_Check_Subscripts := False; + + when 'T' => + Validity_Check_Tests := False; + + when 'a' => + Validity_Check_Components := True; + Validity_Check_Copies := True; + Validity_Check_Default := True; + Validity_Check_Floating_Point := True; + Validity_Check_In_Out_Params := True; + Validity_Check_In_Params := True; + Validity_Check_Operands := True; + Validity_Check_Parameters := True; + Validity_Check_Returns := True; + Validity_Check_Subscripts := True; + Validity_Check_Tests := True; + + when 'n' => + Validity_Check_Components := False; + Validity_Check_Copies := False; + Validity_Check_Default := False; + Validity_Check_Floating_Point := False; + Validity_Check_In_Out_Params := False; + Validity_Check_In_Params := False; + Validity_Check_Operands := False; + Validity_Check_Parameters := False; + Validity_Check_Returns := False; + Validity_Check_Subscripts := False; + Validity_Check_Tests := False; + Validity_Checks_On := False; + + when ' ' => + null; + + when others => + OK := False; + Err_Col := J - 1; + return; + end case; + end loop; + + OK := True; + Err_Col := Options'Last + 1; + end Set_Validity_Check_Options; + +end Validsw; diff --git a/gcc/ada/validsw.ads b/gcc/ada/validsw.ads new file mode 100644 index 000000000..f24bc8782 --- /dev/null +++ b/gcc/ada/validsw.ads @@ -0,0 +1,164 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V A L I D S W -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit contains the routines used to handle setting of validity +-- checking options. + +package Validsw is + + ----------------------------- + -- Validity Check Switches -- + ----------------------------- + + -- The following flags determine the specific set of validity checks + -- to be made if validity checking is active (Validity_Checks_On = True) + + -- See GNAT users guide for an exact description of each option. The letter + -- given in the comment is the letter used in the -gnatV compiler switch + -- or in the argument of a Validity_Checks pragma to activate the option. + -- The corresponding upper case letter deactivates the option. + + Validity_Check_Copies : Boolean := False; + -- Controls the validity checking of copies. If this switch is set to + -- true using -gnatVc, or a 'c' in the argument of a Validity_Checks + -- pragma, then the right side of assignments and also initializing + -- expressions in object declarations are checked for validity. + + Validity_Check_Components : Boolean := False; + -- Controls validity checking for assignment to elementary components of + -- records. If this switch is set true using -gnatVe, or an 'e' in the + -- argument of Validity_Checks pragma, then the right hand of an assignment + -- to such a component is checked for validity. + + Validity_Check_Default : Boolean := True; + -- Controls default (reference manual) validity checking. If this switch is + -- set to True using -gnatVd or a 'd' in the argument of a Validity_ Checks + -- pragma (or the initial default value is used, set True), then left side + -- subscripts and case statement arguments are checked for validity. This + -- switch is also set by default if no -gnatV switch is used and no + -- Validity_Checks pragma is processed. + + Validity_Check_Floating_Point : Boolean := False; + -- Normally validity checking applies only to discrete values (integer + -- and enumeration types). If this switch is set to True using -gnatVf + -- or an 'f' in the argument of a Validity_Checks pragma, then floating- + -- point values are also checked. The context in which such checks + -- occur depends on other flags, e.g. if Validity_Check_Copies is also + -- set then floating-point values on the right side of an assignment + -- will be validity checked. + + Validity_Check_In_Out_Params : Boolean := False; + -- Controls the validity checking of IN OUT parameters. If this switch + -- is set to True using -gnatVm or a 'm' in the argument of a pragma + -- Validity_Checks, then the initial value of all IN OUT parameters + -- will be checked at the point of call of a procedure. Note that the + -- character 'm' here stands for modified (parameters). + + Validity_Check_In_Params : Boolean := False; + -- Controls the validity checking of IN parameters. If this switch is + -- set to True using -gnatVm or an 'i' in the argument of a pragma + -- Validity_Checks, then the initial value of all IN parameters + -- will be checked at the point of call of a procedure or function. + + Validity_Check_Operands : Boolean := False; + -- Controls validity checking of operands. If this switch is set to + -- True using -gnatVo or an 'o' in the argument of a Validity_Checks + -- pragma, then operands of all predefined operators and attributes + -- will be validity checked. + + Validity_Check_Parameters : Boolean := False; + -- This controls validity treatment for parameters within a subprogram. + -- Normally if validity checking is enabled for parameters on a call + -- (Validity_Check_In[_Out]_Params) then an assumption is made that the + -- parameter values are valid on entry and not checked again within a + -- procedure. Setting Validity_Check_Parameters removes this assumption + -- and ensures that no assumptions are made about parameters, so that + -- they will always be checked. + + Validity_Check_Returns : Boolean := False; + -- Controls validity checking of returned values. If this switch is set + -- to True using -gnatVr, or an 'r' in the argument of a Validity_Checks + -- pragma, then the expression in a RETURN statement is validity checked. + + Validity_Check_Subscripts : Boolean := False; + -- Controls validity checking of subscripts. If this switch is set to + -- True using -gnatVs, or an 's' in the argument of a Validity_Checks + -- pragma, then all subscripts are checked for validity. Note that left + -- side subscript checking is controlled also by Validity_Check_Default. + -- If Validity_Check_Subscripts is True, then all subscripts are checked, + -- otherwise if Validity_Check_Default is True, then left side subscripts + -- are checked, otherwise no subscripts are checked. + + Validity_Check_Tests : Boolean := False; + -- Controls validity checking of tests that occur in conditions (i.e. the + -- tests in IF, WHILE, and EXIT statements, and in entry guards). If this + -- switch is set to True using -gnatVt, or a 't' in the argument of a + -- Validity_Checks pragma, then all such conditions are validity checked. + + Force_Validity_Checks : Boolean := False; + -- Normally, operands that do not come from source (i.e. cases of expander + -- generated code) are not checked, if this flag is set True, then checking + -- of such operands is forced (if Validity_Check_Operands is set). + + ----------------- + -- Subprograms -- + ----------------- + + procedure Set_Default_Validity_Check_Options; + -- This procedure is called to set the default validity checking options + -- that apply if no Validity_Check switches or pragma is given. + + procedure Set_Validity_Check_Options + (Options : String; + OK : out Boolean; + Err_Col : out Natural); + -- This procedure is called to set the validity check options that + -- correspond to the characters in the given Options string. If + -- all options are valid, then Set_Default_Validity_Check_Options + -- is first called to set the defaults, and then the options in the + -- given string are set in an additive manner. If any invalid character + -- is found, then OK is False on exit, and Err_Col is the index in + -- in options of the bad character. If all options are valid, then + -- OK is True on return, and Err_Col is set to options'Last + 1. + + procedure Set_Validity_Check_Options (Options : String); + -- Like the above procedure, except that the call is simply ignored if + -- there are any error conditions, this is for example appropriate for + -- calls where the string is known to be valid, e.g. because it was + -- obtained by Save_Validity_Check_Options. + + procedure Reset_Validity_Check_Options; + -- Sets all validity check options to off + + subtype Validity_Check_Options is String (1 .. 16); + -- Long enough string to hold all options from Save call below + + procedure Save_Validity_Check_Options + (Options : out Validity_Check_Options); + -- Sets Options to represent current selection of options. This + -- set can be restored by first calling Reset_Validity_Check_Options, + -- and then calling Set_Validity_Check_Options with the Options string. + +end Validsw; diff --git a/gcc/ada/vms_cmds.ads b/gcc/ada/vms_cmds.ads new file mode 100644 index 000000000..66c401506 --- /dev/null +++ b/gcc/ada/vms_cmds.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V M S _ C M D S -- +-- -- +-- S p e c -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 GNAT driver. It contains the declaration of +-- Command_Type which list all the commands supported by the gnat driver. + +package VMS_Cmds is + type Command_Type is + (Bind, + Chop, + Clean, + Compile, + Check, + Sync, + Elim, + Find, + Krunch, + Link, + List, + Make, + Metric, + Name, + Preprocess, + Pretty, + Shared, + Stack, + Stub, + Xref, + Undefined); +end VMS_Cmds; diff --git a/gcc/ada/vms_conv.adb b/gcc/ada/vms_conv.adb new file mode 100644 index 000000000..b80605314 --- /dev/null +++ b/gcc/ada/vms_conv.adb @@ -0,0 +1,2340 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V M S _ C O N V -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1996-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Gnatvsn; use Gnatvsn; +with Hostparm; +with Opt; +with Osint; use Osint; +with Targparm; use Targparm; + +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Text_IO; use Ada.Text_IO; + +package body VMS_Conv is + + ------------------------- + -- Internal Structures -- + ------------------------- + + -- The switches and commands are defined by strings in the previous + -- section so that they are easy to modify, but internally, they are + -- kept in a more conveniently accessible form described in this + -- section. + + -- Commands, command qualifiers and options have a similar common format + -- so that searching for matching names can be done in a common manner. + + type Item_Id is (Id_Command, Id_Switch, Id_Option); + + type Translation_Type is + ( + T_Direct, + -- A qualifier with no options. + -- Example: GNAT MAKE /VERBOSE + + T_Directories, + -- A qualifier followed by a list of directories + -- Example: GNAT COMPILE /SEARCH=([], [.FOO], [.BAR]) + + T_Directory, + -- A qualifier followed by one directory + -- Example: GNAT LIBRARY /SET=[.VAXFLOATLIB] + + T_File, + -- A qualifier followed by a filename + -- Example: GNAT LINK /EXECUTABLE=FOO.EXE + + T_No_Space_File, + -- A qualifier followed by a filename + -- Example: GNAT MAKE /PROJECT_FILE=PRJ.GPR + + T_Numeric, + -- A qualifier followed by a numeric value. + -- Example: GNAT CHOP /FILE_NAME_MAX_LENGTH=39 + + T_String, + -- A qualifier followed by a quoted string. Only used by + -- /IDENTIFICATION qualifier. + -- Example: GNAT LINK /IDENTIFICATION="3.14a1 version" + + T_Options, + -- A qualifier followed by a list of options. + -- Example: GNAT COMPILE /REPRESENTATION_INFO=(ARRAYS,OBJECTS) + + T_Commands, + -- A qualifier followed by a list. Only used for + -- MAKE /COMPILER_QUALIFIERS /BINDER_QUALIFIERS /LINKER_QUALIFIERS + -- (gnatmake -cargs -bargs -largs ) + -- Example: GNAT MAKE ... /LINKER_QUALIFIERS /VERBOSE FOOBAR.OBJ + + T_Other, + -- A qualifier passed directly to the linker. Only used + -- for LINK and SHARED if no other match is found. + -- Example: GNAT LINK FOO.ALI /SYSSHR + + T_Alphanumplus + -- A qualifier followed by a legal linker symbol prefix. Only used + -- for BIND /BUILD_LIBRARY (gnatbind -Lxyz). + -- Example: GNAT BIND /BUILD_LIBRARY=foobar + ); + + type Item (Id : Item_Id); + type Item_Ptr is access all Item; + + type Item (Id : Item_Id) is record + Name : String_Ptr; + -- Name of the command, switch (with slash) or option + + Next : Item_Ptr; + -- Pointer to next item on list, always has the same Id value + + Command : Command_Type := Undefined; + + Unix_String : String_Ptr := null; + -- Corresponding Unix string. For a command, this is the unix command + -- name and possible default switches. For a switch or option it is + -- the unix switch string. + + case Id is + + when Id_Command => + + Switches : Item_Ptr; + -- Pointer to list of switch items for the command, linked + -- through the Next fields with null terminating the list. + + Usage : String_Ptr; + -- Usage information, used only for errors and the default + -- list of commands output. + + Params : Parameter_Ref; + -- Array of parameters + + Defext : String (1 .. 3); + -- Default extension. If non-blank, then this extension is + -- supplied by default as the extension for any file parameter + -- which does not have an extension already. + + when Id_Switch => + + Translation : Translation_Type; + -- Type of switch translation. For all cases, except Options, + -- this is the only field needed, since the Unix translation + -- is found in Unix_String. + + Options : Item_Ptr; + -- For the Options case, this field is set to point to a list + -- of options item (for this case Unix_String is null in the + -- main switch item). The end of the list is marked by null. + + when Id_Option => + + null; + -- No special fields needed, since Name and Unix_String are + -- sufficient to completely described an option. + + end case; + end record; + + subtype Command_Item is Item (Id_Command); + subtype Switch_Item is Item (Id_Switch); + subtype Option_Item is Item (Id_Option); + + Keep_Temps_Option : constant Item_Ptr := + new Item' + (Id => Id_Option, + Name => + new String'("/KEEP_TEMPORARY_FILES"), + Next => null, + Command => Undefined, + Unix_String => null); + + Param_Count : Natural := 0; + -- Number of parameter arguments so far + + Arg_Num : Natural; + -- Argument number + + Arg_File : Ada.Text_IO.File_Type; + -- A file where arguments are read from + + Commands : Item_Ptr; + -- Pointer to head of list of command items, one for each command, with + -- the end of the list marked by a null pointer. + + Last_Command : Item_Ptr; + -- Pointer to last item in Commands list + + Command : Item_Ptr; + -- Pointer to command item for current command + + Make_Commands_Active : Item_Ptr := null; + -- Set to point to Command entry for COMPILE, BIND, or LINK as appropriate + -- if a COMMANDS_TRANSLATION switch has been encountered while processing + -- a MAKE Command. + + Output_File_Expected : Boolean := False; + -- True for GNAT LINK after -o switch, so that the ".ali" extension is + -- not added to the executable file name. + + package Buffer is new Table.Table + (Table_Component_Type => Character, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 4096, + Table_Increment => 100, + Table_Name => "Buffer"); + -- Table to store the command to be used + + package Cargs_Buffer is new Table.Table + (Table_Component_Type => Character, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 4096, + Table_Increment => 100, + Table_Name => "Cargs_Buffer"); + -- Table to store the compiler switches for GNAT COMPILE + + Cargs : Boolean := False; + -- When True, commands should go to Cargs_Buffer instead of Buffer table + + function Init_Object_Dirs return Argument_List; + -- Get the list of the object directories + + function Invert_Sense (S : String) return VMS_Data.String_Ptr; + -- Given a unix switch string S, computes the inverse (adding or + -- removing ! characters as required), and returns a pointer to + -- the allocated result on the heap. + + function Is_Extensionless (F : String) return Boolean; + -- Returns true if the filename has no extension + + function Match (S1, S2 : String) return Boolean; + -- Determines whether S1 and S2 match (this is a case insensitive match) + + function Match_Prefix (S1, S2 : String) return Boolean; + -- Determines whether S1 matches a prefix of S2. This is also a case + -- insensitive match (for example Match ("AB","abc") is True). + + function Matching_Name + (S : String; + Itm : Item_Ptr; + Quiet : Boolean := False) return Item_Ptr; + -- Determines if the item list headed by Itm and threaded through the + -- Next fields (with null marking the end of the list), contains an + -- entry that uniquely matches the given string. The match is case + -- insensitive and permits unique abbreviation. If the match succeeds, + -- then a pointer to the matching item is returned. Otherwise, an + -- appropriate error message is written. Note that the discriminant + -- of Itm is used to determine the appropriate form of this message. + -- Quiet is normally False as shown, if it is set to True, then no + -- error message is generated in a not found situation (null is still + -- returned to indicate the not-found situation). + + function OK_Alphanumerplus (S : String) return Boolean; + -- Checks that S is a string of alphanumeric characters, + -- returning True if all alphanumeric characters, + -- False if empty or a non-alphanumeric character is present. + + function OK_Integer (S : String) return Boolean; + -- Checks that S is a string of digits, returning True if all digits, + -- False if empty or a non-digit is present. + + procedure Place (C : Character); + -- Place a single character in the buffer, updating Ptr + + procedure Place (S : String); + -- Place a string character in the buffer, updating Ptr + + procedure Place_Lower (S : String); + -- Place string in buffer, forcing letters to lower case, updating Ptr + + procedure Place_Unix_Switches (S : VMS_Data.String_Ptr); + -- Given a unix switch string, place corresponding switches in Buffer, + -- updating Ptr appropriately. Note that in the case of use of ! the + -- result may be to remove a previously placed switch. + + procedure Preprocess_Command_Data; + -- Preprocess the string form of the command and options list into the + -- internal form. + + procedure Process_Argument (The_Command : in out Command_Type); + -- Process one argument from the command line, or one line from + -- from a command line file. For the first call, set The_Command. + + procedure Process_Buffer (S : String); + -- Process the characters in the Buffer table or the Cargs_Buffer table + -- to convert these into arguments. + + procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr); + -- Check that N is a valid command or option name, i.e. that it is of the + -- form of an Ada identifier with upper case letters and underscores. + + procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr); + -- Check that S is a valid switch string as described in the syntax for + -- the switch table item UNIX_SWITCH or else begins with a backquote. + + ---------------------- + -- Init_Object_Dirs -- + ---------------------- + + function Init_Object_Dirs return Argument_List is + Object_Dirs : Integer; + Object_Dir : Argument_List (1 .. 256); + Object_Dir_Name : String_Access; + + begin + Object_Dirs := 0; + Object_Dir_Name := new String'(Object_Dir_Default_Prefix); + Get_Next_Dir_In_Path_Init (Object_Dir_Name); + + loop + declare + Dir : constant String_Access := + Get_Next_Dir_In_Path (Object_Dir_Name); + begin + exit when Dir = null; + Object_Dirs := Object_Dirs + 1; + Object_Dir (Object_Dirs) := + new String'("-L" & + To_Canonical_Dir_Spec + (To_Host_Dir_Spec + (Normalize_Directory_Name (Dir.all).all, + True).all, True).all); + end; + end loop; + + Object_Dirs := Object_Dirs + 1; + Object_Dir (Object_Dirs) := new String'("-lgnat"); + + if OpenVMS_On_Target then + Object_Dirs := Object_Dirs + 1; + Object_Dir (Object_Dirs) := new String'("-ldecgnat"); + end if; + + return Object_Dir (1 .. Object_Dirs); + end Init_Object_Dirs; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Command_List := + (Bind => + (Cname => new S'("BIND"), + Usage => new S'("GNAT BIND file[.ali] /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatbind"), + Unixsws => null, + Switches => Bind_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => "ali"), + + Chop => + (Cname => new S'("CHOP"), + Usage => new S'("GNAT CHOP file [directory] /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatchop"), + Unixsws => null, + Switches => Chop_Switches'Access, + Params => new Parameter_Array'(1 => File, 2 => Optional_File), + Defext => " "), + + Clean => + (Cname => new S'("CLEAN"), + Usage => new S'("GNAT CLEAN /qualifiers files"), + VMS_Only => False, + Unixcmd => new S'("gnatclean"), + Unixsws => null, + Switches => Clean_Switches'Access, + Params => new Parameter_Array'(1 => File), + Defext => " "), + + Compile => + (Cname => new S'("COMPILE"), + Usage => new S'("GNAT COMPILE filespec[,...] /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatmake"), + Unixsws => new Argument_List'(1 => new String'("-f"), + 2 => new String'("-u"), + 3 => new String'("-c")), + Switches => GCC_Switches'Access, + Params => new Parameter_Array'(1 => Files_Or_Wildcard), + Defext => " "), + + Check => + (Cname => new S'("CHECK"), + Usage => new S'("GNAT CHECK name /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatcheck"), + Unixsws => null, + Switches => Check_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => " "), + + Sync => + (Cname => new S'("SYNC"), + Usage => new S'("GNAT SYNC name /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatsync"), + Unixsws => null, + Switches => Sync_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => " "), + + Elim => + (Cname => new S'("ELIM"), + Usage => new S'("GNAT ELIM name /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatelim"), + Unixsws => null, + Switches => Elim_Switches'Access, + Params => new Parameter_Array'(1 => Other_As_Is), + Defext => "ali"), + + Find => + (Cname => new S'("FIND"), + Usage => new S'("GNAT FIND pattern[:sourcefile[:line" + & "[:column]]] filespec[,...] /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatfind"), + Unixsws => null, + Switches => Find_Switches'Access, + Params => new Parameter_Array'(1 => Other_As_Is, + 2 => Files_Or_Wildcard), + Defext => "ali"), + + Krunch => + (Cname => new S'("KRUNCH"), + Usage => new S'("GNAT KRUNCH file [/COUNT=nnn]"), + VMS_Only => False, + Unixcmd => new S'("gnatkr"), + Unixsws => null, + Switches => Krunch_Switches'Access, + Params => new Parameter_Array'(1 => File), + Defext => " "), + + Link => + (Cname => new S'("LINK"), + Usage => new S'("GNAT LINK file[.ali]" + & " [extra obj_&_lib_&_exe_&_opt files]" + & " /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatlink"), + Unixsws => null, + Switches => Link_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => "ali"), + + List => + (Cname => new S'("LIST"), + Usage => new S'("GNAT LIST /qualifiers object_or_ali_file"), + VMS_Only => False, + Unixcmd => new S'("gnatls"), + Unixsws => null, + Switches => List_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => "ali"), + + Make => + (Cname => new S'("MAKE"), + Usage => new S'("GNAT MAKE file(s) /qualifiers (includes " + & "COMPILE /qualifiers)"), + VMS_Only => False, + Unixcmd => new S'("gnatmake"), + Unixsws => null, + Switches => Make_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => " "), + + Metric => + (Cname => new S'("METRIC"), + Usage => new S'("GNAT METRIC /qualifiers source_file"), + VMS_Only => False, + Unixcmd => new S'("gnatmetric"), + Unixsws => null, + Switches => Metric_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => " "), + + Name => + (Cname => new S'("NAME"), + Usage => new S'("GNAT NAME /qualifiers naming-pattern " + & "[naming-patterns]"), + VMS_Only => False, + Unixcmd => new S'("gnatname"), + Unixsws => null, + Switches => Name_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_As_Is), + Defext => " "), + + Preprocess => + (Cname => new S'("PREPROCESS"), + Usage => + new S'("GNAT PREPROCESS ifile ofile dfile /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatprep"), + Unixsws => null, + Switches => Prep_Switches'Access, + Params => new Parameter_Array'(1 .. 3 => File), + Defext => " "), + + Pretty => + (Cname => new S'("PRETTY"), + Usage => new S'("GNAT PRETTY /qualifiers source_file"), + VMS_Only => False, + Unixcmd => new S'("gnatpp"), + Unixsws => null, + Switches => Pretty_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => " "), + + Shared => + (Cname => new S'("SHARED"), + Usage => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt" + & "files] /qualifiers"), + VMS_Only => True, + Unixcmd => new S'("gcc"), + Unixsws => + new Argument_List'(new String'("-shared") & Init_Object_Dirs), + Switches => Shared_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => " "), + + Stack => + (Cname => new S'("STACK"), + Usage => new S'("GNAT STACK /qualifiers ci_files"), + VMS_Only => False, + Unixcmd => new S'("gnatstack"), + Unixsws => null, + Switches => Stack_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => "ci" & ASCII.NUL), + + Stub => + (Cname => new S'("STUB"), + Usage => new S'("GNAT STUB file [directory]/qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatstub"), + Unixsws => null, + Switches => Stub_Switches'Access, + Params => new Parameter_Array'(1 => File, 2 => Optional_File), + Defext => " "), + + Xref => + (Cname => new S'("XREF"), + Usage => new S'("GNAT XREF filespec[,...] /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatxref"), + Unixsws => null, + Switches => Xref_Switches'Access, + Params => new Parameter_Array'(1 => Files_Or_Wildcard), + Defext => "ali") + ); + end Initialize; + + ------------------ + -- Invert_Sense -- + ------------------ + + function Invert_Sense (S : String) return VMS_Data.String_Ptr is + Sinv : String (1 .. S'Length * 2); + -- Result (for sure long enough) + + Sinvp : Natural := 0; + -- Pointer to output string + + begin + for Sp in S'Range loop + if Sp = S'First or else S (Sp - 1) = ',' then + if S (Sp) = '!' then + null; + else + Sinv (Sinvp + 1) := '!'; + Sinv (Sinvp + 2) := S (Sp); + Sinvp := Sinvp + 2; + end if; + + else + Sinv (Sinvp + 1) := S (Sp); + Sinvp := Sinvp + 1; + end if; + end loop; + + return new String'(Sinv (1 .. Sinvp)); + end Invert_Sense; + + ---------------------- + -- Is_Extensionless -- + ---------------------- + + function Is_Extensionless (F : String) return Boolean is + begin + for J in reverse F'Range loop + if F (J) = '.' then + return False; + elsif F (J) = '/' or else F (J) = ']' or else F (J) = ':' then + return True; + end if; + end loop; + + return True; + end Is_Extensionless; + + ----------- + -- Match -- + ----------- + + function Match (S1, S2 : String) return Boolean is + Dif : constant Integer := S2'First - S1'First; + + begin + + if S1'Length /= S2'Length then + return False; + + else + for J in S1'Range loop + if To_Lower (S1 (J)) /= To_Lower (S2 (J + Dif)) then + return False; + end if; + end loop; + + return True; + end if; + end Match; + + ------------------ + -- Match_Prefix -- + ------------------ + + function Match_Prefix (S1, S2 : String) return Boolean is + begin + if S1'Length > S2'Length then + return False; + else + return Match (S1, S2 (S2'First .. S2'First + S1'Length - 1)); + end if; + end Match_Prefix; + + ------------------- + -- Matching_Name -- + ------------------- + + function Matching_Name + (S : String; + Itm : Item_Ptr; + Quiet : Boolean := False) return Item_Ptr + is + P1, P2 : Item_Ptr; + + procedure Err; + -- Little procedure to output command/qualifier/option as appropriate + -- and bump error count. + + --------- + -- Err -- + --------- + + procedure Err is + begin + if Quiet then + return; + end if; + + Errors := Errors + 1; + + if Itm /= null then + case Itm.Id is + when Id_Command => + Put (Standard_Error, "command"); + + when Id_Switch => + if Hostparm.OpenVMS then + Put (Standard_Error, "qualifier"); + else + Put (Standard_Error, "switch"); + end if; + + when Id_Option => + Put (Standard_Error, "option"); + + end case; + else + Put (Standard_Error, "input"); + + end if; + + Put (Standard_Error, ": "); + Put (Standard_Error, S); + end Err; + + -- Start of processing for Matching_Name + + begin + -- If exact match, that's the one we want + + P1 := Itm; + while P1 /= null loop + if Match (S, P1.Name.all) then + return P1; + else + P1 := P1.Next; + end if; + end loop; + + -- Now check for prefix matches + + P1 := Itm; + while P1 /= null loop + if P1.Name.all = "/" then + return P1; + + elsif not Match_Prefix (S, P1.Name.all) then + P1 := P1.Next; + + else + -- Here we have found one matching prefix, so see if there is + -- another one (which is an ambiguity) + + P2 := P1.Next; + while P2 /= null loop + if Match_Prefix (S, P2.Name.all) then + if not Quiet then + Put (Standard_Error, "ambiguous "); + Err; + Put (Standard_Error, " (matches "); + Put (Standard_Error, P1.Name.all); + + while P2 /= null loop + if Match_Prefix (S, P2.Name.all) then + Put (Standard_Error, ','); + Put (Standard_Error, P2.Name.all); + end if; + + P2 := P2.Next; + end loop; + + Put_Line (Standard_Error, ")"); + end if; + + return null; + end if; + + P2 := P2.Next; + end loop; + + -- If we fall through that loop, then there was only one match + + return P1; + end if; + end loop; + + -- If we fall through outer loop, there was no match + + if not Quiet then + Put (Standard_Error, "unrecognized "); + Err; + New_Line (Standard_Error); + end if; + + return null; + end Matching_Name; + + ----------------------- + -- OK_Alphanumerplus -- + ----------------------- + + function OK_Alphanumerplus (S : String) return Boolean is + begin + if S'Length = 0 then + return False; + + else + for J in S'Range loop + if not (Is_Alphanumeric (S (J)) or else + S (J) = '_' or else S (J) = '$') + then + return False; + end if; + end loop; + + return True; + end if; + end OK_Alphanumerplus; + + ---------------- + -- OK_Integer -- + ---------------- + + function OK_Integer (S : String) return Boolean is + begin + if S'Length = 0 then + return False; + + else + for J in S'Range loop + if not Is_Digit (S (J)) then + return False; + end if; + end loop; + + return True; + end if; + end OK_Integer; + + -------------------- + -- Output_Version -- + -------------------- + + procedure Output_Version is + begin + if AAMP_On_Target then + Put ("GNAAMP "); + else + Put ("GNAT "); + end if; + + Put_Line (Gnatvsn.Gnat_Version_String); + Put_Line ("Copyright 1996-" & + Current_Year & + ", Free Software Foundation, Inc."); + end Output_Version; + + ----------- + -- Place -- + ----------- + + procedure Place (C : Character) is + begin + if Cargs then + Cargs_Buffer.Append (C); + else + Buffer.Append (C); + end if; + end Place; + + procedure Place (S : String) is + begin + for J in S'Range loop + Place (S (J)); + end loop; + end Place; + + ----------------- + -- Place_Lower -- + ----------------- + + procedure Place_Lower (S : String) is + begin + for J in S'Range loop + Place (To_Lower (S (J))); + end loop; + end Place_Lower; + + ------------------------- + -- Place_Unix_Switches -- + ------------------------- + + procedure Place_Unix_Switches (S : VMS_Data.String_Ptr) is + P1, P2, P3 : Natural; + Remove : Boolean; + Slen, Sln2 : Natural; + Wild_Card : Boolean := False; + + begin + P1 := S'First; + while P1 <= S'Last loop + if S (P1) = '!' then + P1 := P1 + 1; + Remove := True; + else + Remove := False; + end if; + + P2 := P1; + pragma Assert (S (P1) = '-' or else S (P1) = '`'); + + while P2 < S'Last and then S (P2 + 1) /= ',' loop + P2 := P2 + 1; + end loop; + + -- Switch is now in S (P1 .. P2) + + Slen := P2 - P1 + 1; + + if Remove then + Wild_Card := S (P2) = '*'; + + if Wild_Card then + Slen := Slen - 1; + P2 := P2 - 1; + end if; + + P3 := 1; + while P3 <= Buffer.Last - Slen loop + if Buffer.Table (P3) = ' ' + and then String (Buffer.Table (P3 + 1 .. P3 + Slen)) = + S (P1 .. P2) + and then (Wild_Card + or else + P3 + Slen = Buffer.Last + or else + Buffer.Table (P3 + Slen + 1) = ' ') + then + Sln2 := Slen; + + if Wild_Card then + while P3 + Sln2 /= Buffer.Last + and then Buffer.Table (P3 + Sln2 + 1) /= ' ' + loop + Sln2 := Sln2 + 1; + end loop; + end if; + + Buffer.Table (P3 .. Buffer.Last - Sln2 - 1) := + Buffer.Table (P3 + Sln2 + 1 .. Buffer.Last); + Buffer.Set_Last (Buffer.Last - Sln2 - 1); + + else + P3 := P3 + 1; + end if; + end loop; + + if Wild_Card then + P2 := P2 + 1; + end if; + + else + pragma Assert (S (P2) /= '*'); + Place (' '); + + if S (P1) = '`' then + P1 := P1 + 1; + end if; + + Place (S (P1 .. P2)); + end if; + + P1 := P2 + 2; + end loop; + end Place_Unix_Switches; + + ----------------------------- + -- Preprocess_Command_Data -- + ----------------------------- + + procedure Preprocess_Command_Data is + begin + for C in Real_Command_Type loop + declare + Command : constant Item_Ptr := new Command_Item; + + Last_Switch : Item_Ptr; + -- Last switch in list + + begin + -- Link new command item into list of commands + + if Last_Command = null then + Commands := Command; + else + Last_Command.Next := Command; + end if; + + Last_Command := Command; + + -- Fill in fields of new command item + + Command.Name := Command_List (C).Cname; + Command.Usage := Command_List (C).Usage; + Command.Command := C; + + if Command_List (C).Unixsws = null then + Command.Unix_String := Command_List (C).Unixcmd; + else + declare + Cmd : String (1 .. 5_000); + Last : Natural := 0; + Sws : constant Argument_List_Access := + Command_List (C).Unixsws; + + begin + Cmd (1 .. Command_List (C).Unixcmd'Length) := + Command_List (C).Unixcmd.all; + Last := Command_List (C).Unixcmd'Length; + + for J in Sws'Range loop + Last := Last + 1; + Cmd (Last) := ' '; + Cmd (Last + 1 .. Last + Sws (J)'Length) := + Sws (J).all; + Last := Last + Sws (J)'Length; + end loop; + + Command.Unix_String := new String'(Cmd (1 .. Last)); + end; + end if; + + Command.Params := Command_List (C).Params; + Command.Defext := Command_List (C).Defext; + + Validate_Command_Or_Option (Command.Name); + + -- Process the switch list + + for S in Command_List (C).Switches'Range loop + declare + SS : constant VMS_Data.String_Ptr := + Command_List (C).Switches (S); + P : Natural := SS'First; + Sw : Item_Ptr := new Switch_Item; + + Last_Opt : Item_Ptr; + -- Pointer to last option + + begin + -- Link new switch item into list of switches + + if Last_Switch = null then + Command.Switches := Sw; + else + Last_Switch.Next := Sw; + end if; + + Last_Switch := Sw; + + -- Process switch string, first get name + + while SS (P) /= ' ' and then SS (P) /= '=' loop + P := P + 1; + end loop; + + Sw.Name := new String'(SS (SS'First .. P - 1)); + + -- Direct translation case + + if SS (P) = ' ' then + Sw.Translation := T_Direct; + Sw.Unix_String := new String'(SS (P + 1 .. SS'Last)); + Validate_Unix_Switch (Sw.Unix_String); + + if SS (P - 1) = '>' then + Sw.Translation := T_Other; + + elsif SS (P + 1) = '`' then + null; + + -- Create the inverted case (/NO ..) + + elsif SS (SS'First + 1 .. SS'First + 2) /= "NO" then + Sw := new Switch_Item; + Last_Switch.Next := Sw; + Last_Switch := Sw; + + Sw.Name := + new String'("/NO" & SS (SS'First + 1 .. P - 1)); + Sw.Translation := T_Direct; + Sw.Unix_String := Invert_Sense (SS (P + 1 .. SS'Last)); + Validate_Unix_Switch (Sw.Unix_String); + end if; + + -- Directories translation case + + elsif SS (P + 1) = '*' then + pragma Assert (SS (SS'Last) = '*'); + Sw.Translation := T_Directories; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); + + -- Directory translation case + + elsif SS (P + 1) = '%' then + pragma Assert (SS (SS'Last) = '%'); + Sw.Translation := T_Directory; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); + + -- File translation case + + elsif SS (P + 1) = '@' then + pragma Assert (SS (SS'Last) = '@'); + Sw.Translation := T_File; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); + + -- No space file translation case + + elsif SS (P + 1) = '<' then + pragma Assert (SS (SS'Last) = '>'); + Sw.Translation := T_No_Space_File; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); + + -- Numeric translation case + + elsif SS (P + 1) = '#' then + pragma Assert (SS (SS'Last) = '#'); + Sw.Translation := T_Numeric; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); + + -- Alphanumerplus translation case + + elsif SS (P + 1) = '|' then + pragma Assert (SS (SS'Last) = '|'); + Sw.Translation := T_Alphanumplus; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); + + -- String translation case + + elsif SS (P + 1) = '"' then + pragma Assert (SS (SS'Last) = '"'); + Sw.Translation := T_String; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); + + -- Commands translation case + + elsif SS (P + 1) = '?' then + Sw.Translation := T_Commands; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last)); + + -- Options translation case + + else + Sw.Translation := T_Options; + Sw.Unix_String := new String'(""); + + P := P + 1; -- bump past = + while P <= SS'Last loop + declare + Opt : constant Item_Ptr := new Option_Item; + Q : Natural; + + begin + -- Link new option item into options list + + if Last_Opt = null then + Sw.Options := Opt; + else + Last_Opt.Next := Opt; + end if; + + Last_Opt := Opt; + + -- Fill in fields of new option item + + Q := P; + while SS (Q) /= ' ' loop + Q := Q + 1; + end loop; + + Opt.Name := new String'(SS (P .. Q - 1)); + Validate_Command_Or_Option (Opt.Name); + + P := Q + 1; + Q := P; + + while Q <= SS'Last and then SS (Q) /= ' ' loop + Q := Q + 1; + end loop; + + Opt.Unix_String := new String'(SS (P .. Q - 1)); + Validate_Unix_Switch (Opt.Unix_String); + P := Q + 1; + end; + end loop; + end if; + end; + end loop; + end; + end loop; + end Preprocess_Command_Data; + + ---------------------- + -- Process_Argument -- + ---------------------- + + procedure Process_Argument (The_Command : in out Command_Type) is + Argv : String_Access; + Arg_Idx : Integer; + + function Get_Arg_End + (Argv : String; + Arg_Idx : Integer) return Integer; + -- Begins looking at Arg_Idx + 1 and returns the index of the + -- last character before a slash or else the index of the last + -- character in the string Argv. + + ----------------- + -- Get_Arg_End -- + ----------------- + + function Get_Arg_End + (Argv : String; + Arg_Idx : Integer) return Integer + is + begin + for J in Arg_Idx + 1 .. Argv'Last loop + if Argv (J) = '/' then + return J - 1; + end if; + end loop; + + return Argv'Last; + end Get_Arg_End; + + -- Start of processing for Process_Argument + + begin + Cargs := False; + + -- If an argument file is open, read the next non empty line + + if Is_Open (Arg_File) then + declare + Line : String (1 .. 256); + Last : Natural; + begin + loop + Get_Line (Arg_File, Line, Last); + exit when Last /= 0 or else End_Of_File (Arg_File); + end loop; + + -- If the end of the argument file has been reached, close it + + if End_Of_File (Arg_File) then + Close (Arg_File); + + -- If the last line was empty, return after increasing Arg_Num + -- to go to the next argument on the comment line. + + if Last = 0 then + Arg_Num := Arg_Num + 1; + return; + end if; + end if; + + Argv := new String'(Line (1 .. Last)); + Arg_Idx := 1; + + if Argv (1) = '@' then + Put_Line (Standard_Error, "argument file cannot contain @cmd"); + raise Error_Exit; + end if; + end; + + else + -- No argument file is open, get the argument on the command line + + Argv := new String'(Argument (Arg_Num)); + Arg_Idx := Argv'First; + + -- Check if this is the specification of an argument file + + if Argv (Arg_Idx) = '@' then + -- The first argument on the command line cannot be an argument + -- file. + + if Arg_Num = 1 then + Put_Line + (Standard_Error, + "Cannot specify argument line before command"); + raise Error_Exit; + end if; + + -- Open the file, after conversion of the name to canonical form. + -- Fail if file is not found. + + declare + Canonical_File_Name : String_Access := + To_Canonical_File_Spec (Argv (Arg_Idx + 1 .. Argv'Last)); + begin + Open (Arg_File, In_File, Canonical_File_Name.all); + Free (Canonical_File_Name); + return; + + exception + when others => + Put (Standard_Error, "Cannot open argument file """); + Put (Standard_Error, Argv (Arg_Idx + 1 .. Argv'Last)); + Put_Line (Standard_Error, """"); + raise Error_Exit; + end; + end if; + end if; + + <> + loop + declare + Next_Arg_Idx : Integer; + Arg : String_Access; + + begin + Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); + Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx)); + + -- The first one must be a command name + + if Arg_Num = 1 and then Arg_Idx = Argv'First then + Command := Matching_Name (Arg.all, Commands); + + if Command = null then + raise Error_Exit; + end if; + + The_Command := Command.Command; + Output_File_Expected := False; + + -- Give usage information if only command given + + if Argument_Count = 1 + and then Next_Arg_Idx = Argv'Last + then + Output_Version; + New_Line; + Put_Line + ("List of available qualifiers and options"); + New_Line; + + Put (Command.Usage.all); + Set_Col (53); + Put_Line (Command.Unix_String.all); + + declare + Sw : Item_Ptr := Command.Switches; + + begin + while Sw /= null loop + Put (" "); + Put (Sw.Name.all); + + case Sw.Translation is + + when T_Other => + Set_Col (53); + Put_Line (Sw.Unix_String.all & + "/"); + + when T_Direct => + Set_Col (53); + Put_Line (Sw.Unix_String.all); + + when T_Directories => + Put ("=(direc,direc,..direc)"); + Set_Col (53); + Put (Sw.Unix_String.all); + Put (" direc "); + Put (Sw.Unix_String.all); + Put_Line (" direc ..."); + + when T_Directory => + Put ("=directory"); + Set_Col (53); + Put (Sw.Unix_String.all); + + if Sw.Unix_String (Sw.Unix_String'Last) + /= '=' + then + Put (' '); + end if; + + Put_Line ("directory "); + + when T_File | T_No_Space_File => + Put ("=file"); + Set_Col (53); + Put (Sw.Unix_String.all); + + if Sw.Translation = T_File + and then Sw.Unix_String + (Sw.Unix_String'Last) /= '=' + then + Put (' '); + end if; + + Put_Line ("file "); + + when T_Numeric => + Put ("=nnn"); + Set_Col (53); + + if Sw.Unix_String + (Sw.Unix_String'First) = '`' + then + Put (Sw.Unix_String + (Sw.Unix_String'First + 1 + .. Sw.Unix_String'Last)); + else + Put (Sw.Unix_String.all); + end if; + + Put_Line ("nnn"); + + when T_Alphanumplus => + Put ("=xyz"); + Set_Col (53); + + if Sw.Unix_String + (Sw.Unix_String'First) = '`' + then + Put (Sw.Unix_String + (Sw.Unix_String'First + 1 + .. Sw.Unix_String'Last)); + else + Put (Sw.Unix_String.all); + end if; + + Put_Line ("xyz"); + + when T_String => + Put ("="); + Put ('"'); + Put (""); + Put ('"'); + Set_Col (53); + + Put (Sw.Unix_String.all); + + if Sw.Unix_String + (Sw.Unix_String'Last) /= '=' + then + Put (' '); + end if; + + Put (""); + New_Line; + + when T_Commands => + Put (" (switches for "); + Put (Sw.Unix_String + (Sw.Unix_String'First + 7 + .. Sw.Unix_String'Last)); + Put (')'); + Set_Col (53); + Put (Sw.Unix_String + (Sw.Unix_String'First + .. Sw.Unix_String'First + 5)); + Put_Line (" switches"); + + when T_Options => + declare + Opt : Item_Ptr := Sw.Options; + + begin + Put_Line ("=(option,option..)"); + + while Opt /= null loop + Put (" "); + Put (Opt.Name.all); + + if Opt = Sw.Options then + Put (" (D)"); + end if; + + Set_Col (53); + Put_Line (Opt.Unix_String.all); + Opt := Opt.Next; + end loop; + end; + + end case; + + Sw := Sw.Next; + end loop; + end; + + raise Normal_Exit; + end if; + + -- Special handling for internal debugging switch /? + + elsif Arg.all = "/?" then + Display_Command := True; + Output_File_Expected := False; + + -- Special handling of internal option /KEEP_TEMPORARY_FILES + + elsif Arg'Length >= 7 + and then Matching_Name + (Arg.all, Keep_Temps_Option, True) /= null + then + Opt.Keep_Temporary_Files := True; + + -- Copy -switch unchanged, as well as +rule + + elsif Arg (Arg'First) = '-' or else Arg (Arg'First) = '+' then + Place (' '); + Place (Arg.all); + + -- Set Output_File_Expected for the next argument + + Output_File_Expected := + Arg.all = "-o" and then The_Command = Link; + + -- Copy quoted switch with quotes stripped + + elsif Arg (Arg'First) = '"' then + if Arg (Arg'Last) /= '"' then + Put (Standard_Error, "misquoted argument: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + + else + Place (' '); + Place (Arg (Arg'First + 1 .. Arg'Last - 1)); + end if; + + Output_File_Expected := False; + + -- Parameter Argument + + elsif Arg (Arg'First) /= '/' + and then Make_Commands_Active = null + then + Param_Count := Param_Count + 1; + + if Param_Count <= Command.Params'Length then + + case Command.Params (Param_Count) is + + when File | Optional_File => + declare + Normal_File : constant String_Access := + To_Canonical_File_Spec + (Arg.all); + + begin + Place (' '); + Place_Lower (Normal_File.all); + + if Is_Extensionless (Normal_File.all) + and then Command.Defext /= " " + then + Place ('.'); + Place (Command.Defext); + end if; + end; + + when Unlimited_Files => + declare + Normal_File : constant String_Access := + To_Canonical_File_Spec + (Arg.all); + + File_Is_Wild : Boolean := False; + File_List : String_Access_List_Access; + + begin + for J in Arg'Range loop + if Arg (J) = '*' + or else Arg (J) = '%' + then + File_Is_Wild := True; + end if; + end loop; + + if File_Is_Wild then + File_List := To_Canonical_File_List + (Arg.all, False); + + for J in File_List.all'Range loop + Place (' '); + Place_Lower (File_List.all (J).all); + end loop; + + else + Place (' '); + Place_Lower (Normal_File.all); + + -- Add extension if not present, except after + -- switch -o. + + if Is_Extensionless (Normal_File.all) + and then Command.Defext /= " " + and then not Output_File_Expected + then + Place ('.'); + Place (Command.Defext); + end if; + end if; + + Param_Count := Param_Count - 1; + end; + + when Other_As_Is => + Place (' '); + Place (Arg.all); + + when Unlimited_As_Is => + Place (' '); + Place (Arg.all); + Param_Count := Param_Count - 1; + + when Files_Or_Wildcard => + + -- Remove spaces from a comma separated list + -- of file names and adjust control variables + -- accordingly. + + while Arg_Num < Argument_Count and then + (Argv (Argv'Last) = ',' xor + Argument (Arg_Num + 1) + (Argument (Arg_Num + 1)'First) = ',') + loop + Argv := new String' + (Argv.all & Argument (Arg_Num + 1)); + Arg_Num := Arg_Num + 1; + Arg_Idx := Argv'First; + Next_Arg_Idx := + Get_Arg_End (Argv.all, Arg_Idx); + Arg := new String' + (Argv (Arg_Idx .. Next_Arg_Idx)); + end loop; + + -- Parse the comma separated list of VMS + -- filenames and place them on the command + -- line as space separated Unix style + -- filenames. Lower case and add default + -- extension as appropriate. + + declare + Arg1_Idx : Integer := Arg'First; + + function Get_Arg1_End + (Arg : String; + Arg_Idx : Integer) return Integer; + -- Begins looking at Arg_Idx + 1 and + -- returns the index of the last character + -- before a comma or else the index of the + -- last character in the string Arg. + + ------------------ + -- Get_Arg1_End -- + ------------------ + + function Get_Arg1_End + (Arg : String; + Arg_Idx : Integer) return Integer + is + begin + for J in Arg_Idx + 1 .. Arg'Last loop + if Arg (J) = ',' then + return J - 1; + end if; + end loop; + + return Arg'Last; + end Get_Arg1_End; + + begin + loop + declare + Next_Arg1_Idx : + constant Integer := + Get_Arg1_End (Arg.all, Arg1_Idx); + + Arg1 : + constant String := + Arg (Arg1_Idx .. Next_Arg1_Idx); + + Normal_File : + constant String_Access := + To_Canonical_File_Spec (Arg1); + + begin + Place (' '); + Place_Lower (Normal_File.all); + + if Is_Extensionless (Normal_File.all) + and then Command.Defext /= " " + then + Place ('.'); + Place (Command.Defext); + end if; + + Arg1_Idx := Next_Arg1_Idx + 1; + end; + + exit when Arg1_Idx > Arg'Last; + + -- Don't allow two or more commas in + -- a row + + if Arg (Arg1_Idx) = ',' then + Arg1_Idx := Arg1_Idx + 1; + if Arg1_Idx > Arg'Last or else + Arg (Arg1_Idx) = ',' + then + Put_Line + (Standard_Error, + "Malformed Parameter: " & + Arg.all); + Put (Standard_Error, "usage: "); + Put_Line (Standard_Error, + Command.Usage.all); + raise Error_Exit; + end if; + end if; + + end loop; + end; + end case; + end if; + + -- Reset Output_File_Expected, in case it was True + + Output_File_Expected := False; + + -- Qualifier argument + + else + Output_File_Expected := False; + + Cargs := Command.Name.all = "COMPILE"; + + -- This code is too heavily nested, should be + -- separated out as separate subprogram ??? + + declare + Sw : Item_Ptr; + SwP : Natural; + P2 : Natural; + Endp : Natural := 0; -- avoid warning! + Opt : Item_Ptr; + + begin + SwP := Arg'First; + while SwP < Arg'Last + and then Arg (SwP + 1) /= '=' + loop + SwP := SwP + 1; + end loop; + + -- At this point, the switch name is in + -- Arg (Arg'First..SwP) and if that is not the + -- whole switch, then there is an equal sign at + -- Arg (SwP + 1) and the rest of Arg is what comes + -- after the equal sign. + + -- If make commands are active, see if we have + -- another COMMANDS_TRANSLATION switch belonging + -- to gnatmake. + + if Make_Commands_Active /= null then + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Command.Switches, + Quiet => True); + + if Sw /= null + and then Sw.Translation = T_Commands + then + null; + + else + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Make_Commands_Active.Switches, + Quiet => False); + end if; + + -- For case of GNAT MAKE or CHOP, if we cannot + -- find the switch, then see if it is a + -- recognized compiler switch instead, and if + -- so process the compiler switch. + + elsif Command.Name.all = "MAKE" + or else Command.Name.all = "CHOP" then + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Command.Switches, + Quiet => True); + + if Sw = null then + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Matching_Name + ("COMPILE", Commands).Switches, + Quiet => False); + end if; + + -- For all other cases, just search the relevant + -- command. + + else + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Command.Switches, + Quiet => False); + end if; + + if Sw /= null then + if Cargs + and then Sw.Name /= null + and then + (Sw.Name.all = "/PROJECT_FILE" or else + Sw.Name.all = "/MESSAGES_PROJECT_FILE" or else + Sw.Name.all = "/EXTERNAL_REFERENCE") + then + Cargs := False; + end if; + + case Sw.Translation is + when T_Direct => + Place_Unix_Switches (Sw.Unix_String); + if SwP < Arg'Last + and then Arg (SwP + 1) = '=' + then + Put (Standard_Error, + "qualifier options ignored: "); + Put_Line (Standard_Error, Arg.all); + end if; + + when T_Directories => + if SwP + 1 > Arg'Last then + Put (Standard_Error, + "missing directories for: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + + elsif Arg (SwP + 2) /= '(' then + SwP := SwP + 2; + Endp := Arg'Last; + + elsif Arg (Arg'Last) /= ')' then + + -- Remove spaces from a comma separated + -- list of file names and adjust + -- control variables accordingly. + + if Arg_Num < Argument_Count and then + (Argv (Argv'Last) = ',' xor + Argument (Arg_Num + 1) + (Argument (Arg_Num + 1)'First) = ',') + then + Argv := + new String'(Argv.all + & Argument + (Arg_Num + 1)); + Arg_Num := Arg_Num + 1; + Arg_Idx := Argv'First; + Next_Arg_Idx := + Get_Arg_End (Argv.all, Arg_Idx); + Arg := new String' + (Argv (Arg_Idx .. Next_Arg_Idx)); + goto Tryagain_After_Coalesce; + end if; + + Put (Standard_Error, + "incorrectly parenthesized " & + "or malformed argument: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + + else + SwP := SwP + 3; + Endp := Arg'Last - 1; + end if; + + while SwP <= Endp loop + declare + Dir_Is_Wild : Boolean := False; + Dir_Maybe_Is_Wild : Boolean := False; + + Dir_List : String_Access_List_Access; + + begin + P2 := SwP; + + while P2 < Endp + and then Arg (P2 + 1) /= ',' + loop + -- A wildcard directory spec on + -- VMS will contain either * or + -- % or ... + + if Arg (P2) = '*' then + Dir_Is_Wild := True; + + elsif Arg (P2) = '%' then + Dir_Is_Wild := True; + + elsif Dir_Maybe_Is_Wild + and then Arg (P2) = '.' + and then Arg (P2 + 1) = '.' + then + Dir_Is_Wild := True; + Dir_Maybe_Is_Wild := False; + + elsif Dir_Maybe_Is_Wild then + Dir_Maybe_Is_Wild := False; + + elsif Arg (P2) = '.' + and then Arg (P2 + 1) = '.' + then + Dir_Maybe_Is_Wild := True; + + end if; + + P2 := P2 + 1; + end loop; + + if Dir_Is_Wild then + Dir_List := + To_Canonical_File_List + (Arg (SwP .. P2), True); + + for J in Dir_List.all'Range loop + Place_Unix_Switches + (Sw.Unix_String); + Place_Lower + (Dir_List.all (J).all); + end loop; + + else + Place_Unix_Switches + (Sw.Unix_String); + Place_Lower + (To_Canonical_Dir_Spec + (Arg (SwP .. P2), False).all); + end if; + + SwP := P2 + 2; + end; + end loop; + + when T_Directory => + if SwP + 1 > Arg'Last then + Put (Standard_Error, + "missing directory for: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + + else + Place_Unix_Switches (Sw.Unix_String); + + -- Some switches end in "=". No space + -- here + + if Sw.Unix_String + (Sw.Unix_String'Last) /= '=' + then + Place (' '); + end if; + + Place_Lower + (To_Canonical_Dir_Spec + (Arg (SwP + 2 .. Arg'Last), + False).all); + end if; + + when T_File | T_No_Space_File => + if SwP + 1 > Arg'Last then + Put (Standard_Error, + "missing file for: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + + else + Place_Unix_Switches (Sw.Unix_String); + + -- Some switches end in "=". No space + -- here. + + if Sw.Translation = T_File + and then Sw.Unix_String + (Sw.Unix_String'Last) /= '=' + then + Place (' '); + end if; + + Place_Lower + (To_Canonical_File_Spec + (Arg (SwP + 2 .. Arg'Last)).all); + end if; + + when T_Numeric => + if OK_Integer (Arg (SwP + 2 .. Arg'Last)) then + Place_Unix_Switches (Sw.Unix_String); + Place (Arg (SwP + 2 .. Arg'Last)); + + else + Put (Standard_Error, "argument for "); + Put (Standard_Error, Sw.Name.all); + Put_Line + (Standard_Error, " must be numeric"); + Errors := Errors + 1; + end if; + + when T_Alphanumplus => + if OK_Alphanumerplus + (Arg (SwP + 2 .. Arg'Last)) + then + Place_Unix_Switches (Sw.Unix_String); + Place (Arg (SwP + 2 .. Arg'Last)); + + else + Put (Standard_Error, "argument for "); + Put (Standard_Error, Sw.Name.all); + Put_Line (Standard_Error, + " must be alphanumeric"); + Errors := Errors + 1; + end if; + + when T_String => + + -- A String value must be extended to the + -- end of the Argv, otherwise strings like + -- "foo/bar" get split at the slash. + + -- The beginning and ending of the string + -- are flagged with embedded nulls which + -- are removed when building the Spawn + -- call. Nulls are use because they won't + -- show up in a /? output. Quotes aren't + -- used because that would make it + -- difficult to embed them. + + Place_Unix_Switches (Sw.Unix_String); + + if Next_Arg_Idx /= Argv'Last then + Next_Arg_Idx := Argv'Last; + Arg := new String' + (Argv (Arg_Idx .. Next_Arg_Idx)); + + SwP := Arg'First; + while SwP < Arg'Last and then + Arg (SwP + 1) /= '=' loop + SwP := SwP + 1; + end loop; + end if; + + Place (ASCII.NUL); + Place (Arg (SwP + 2 .. Arg'Last)); + Place (ASCII.NUL); + + when T_Commands => + + -- Output -largs/-bargs/-cargs + + Place (' '); + Place (Sw.Unix_String + (Sw.Unix_String'First .. + Sw.Unix_String'First + 5)); + + if Sw.Unix_String + (Sw.Unix_String'First + 7 .. + Sw.Unix_String'Last) = "MAKE" + then + Make_Commands_Active := null; + + else + -- Set source of new commands, also + -- setting this non-null indicates that + -- we are in the special commands mode + -- for processing the -xargs case. + + Make_Commands_Active := + Matching_Name + (Sw.Unix_String + (Sw.Unix_String'First + 7 .. + Sw.Unix_String'Last), + Commands); + end if; + + when T_Options => + if SwP + 1 > Arg'Last then + Place_Unix_Switches + (Sw.Options.Unix_String); + SwP := Endp + 1; + + elsif Arg (SwP + 2) /= '(' then + SwP := SwP + 2; + Endp := Arg'Last; + + elsif Arg (Arg'Last) /= ')' then + Put (Standard_Error, + "incorrectly parenthesized argument: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + SwP := Endp + 1; + + else + SwP := SwP + 3; + Endp := Arg'Last - 1; + end if; + + while SwP <= Endp loop + P2 := SwP; + + while P2 < Endp + and then Arg (P2 + 1) /= ',' + loop + P2 := P2 + 1; + end loop; + + -- Option name is in Arg (SwP .. P2) + + Opt := Matching_Name (Arg (SwP .. P2), + Sw.Options); + + if Opt /= null then + Place_Unix_Switches + (Opt.Unix_String); + end if; + + SwP := P2 + 2; + end loop; + + when T_Other => + Place_Unix_Switches + (new String'(Sw.Unix_String.all & + Arg.all)); + + end case; + end if; + end; + end if; + + Arg_Idx := Next_Arg_Idx + 1; + end; + + exit when Arg_Idx > Argv'Last; + + end loop; + + if not Is_Open (Arg_File) then + Arg_Num := Arg_Num + 1; + end if; + end Process_Argument; + + -------------------- + -- Process_Buffer -- + -------------------- + + procedure Process_Buffer (S : String) is + P1, P2 : Natural; + Inside_Nul : Boolean := False; + Arg : String (1 .. 1024); + Arg_Ctr : Natural; + + begin + P1 := 1; + while P1 <= S'Last and then S (P1) = ' ' loop + P1 := P1 + 1; + end loop; + + Arg_Ctr := 1; + Arg (Arg_Ctr) := S (P1); + + while P1 <= S'Last loop + if S (P1) = ASCII.NUL then + if Inside_Nul then + Inside_Nul := False; + else + Inside_Nul := True; + end if; + end if; + + if S (P1) = ' ' and then not Inside_Nul then + P1 := P1 + 1; + Arg_Ctr := Arg_Ctr + 1; + Arg (Arg_Ctr) := S (P1); + + else + Last_Switches.Increment_Last; + P2 := P1; + + while P2 < S'Last + and then (S (P2 + 1) /= ' ' or else + Inside_Nul) + loop + P2 := P2 + 1; + Arg_Ctr := Arg_Ctr + 1; + Arg (Arg_Ctr) := S (P2); + if S (P2) = ASCII.NUL then + Arg_Ctr := Arg_Ctr - 1; + + if Inside_Nul then + Inside_Nul := False; + else + Inside_Nul := True; + end if; + end if; + end loop; + + Last_Switches.Table (Last_Switches.Last) := + new String'(String (Arg (1 .. Arg_Ctr))); + P1 := P2 + 2; + + exit when P1 > S'Last; + + Arg_Ctr := 1; + Arg (Arg_Ctr) := S (P1); + end if; + end loop; + end Process_Buffer; + + -------------------------------- + -- Validate_Command_Or_Option -- + -------------------------------- + + procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr) is + begin + pragma Assert (N'Length > 0); + + for J in N'Range loop + if N (J) = '_' then + pragma Assert (N (J - 1) /= '_'); + null; + else + pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J))); + null; + end if; + end loop; + end Validate_Command_Or_Option; + + -------------------------- + -- Validate_Unix_Switch -- + -------------------------- + + procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr) is + begin + if S (S'First) = '`' then + return; + end if; + + pragma Assert (S (S'First) = '-' or else S (S'First) = '!'); + + for J in S'First + 1 .. S'Last loop + pragma Assert (S (J) /= ' '); + + if S (J) = '!' then + pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-'); + null; + end if; + end loop; + end Validate_Unix_Switch; + + -------------------- + -- VMS_Conversion -- + -------------------- + + procedure VMS_Conversion (The_Command : out Command_Type) is + Result : Command_Type := Undefined; + Result_Set : Boolean := False; + + begin + Buffer.Init; + + -- First we must preprocess the string form of the command and options + -- list into the internal form that we use. + + Preprocess_Command_Data; + + -- If no parameters, give complete list of commands + + if Argument_Count = 0 then + Output_Version; + New_Line; + Put_Line ("List of available commands"); + New_Line; + + while Commands /= null loop + + -- No usage for GNAT SYNC + + if Commands.Command /= Sync then + Put (Commands.Usage.all); + Set_Col (53); + Put_Line (Commands.Unix_String.all); + end if; + + Commands := Commands.Next; + end loop; + + raise Normal_Exit; + end if; + + -- Loop through arguments + + Arg_Num := 1; + while Arg_Num <= Argument_Count loop + Process_Argument (Result); + + if not Result_Set then + The_Command := Result; + Result_Set := True; + end if; + end loop; + + -- Gross error checking that the number of parameters is correct. + -- Not applicable to Unlimited_Files parameters. + + if (Param_Count = Command.Params'Length - 1 + and then Command.Params (Param_Count + 1) = Unlimited_Files) + or else Param_Count <= Command.Params'Length + then + null; + + else + Put_Line (Standard_Error, + "Parameter count of " + & Integer'Image (Param_Count) + & " not equal to expected " + & Integer'Image (Command.Params'Length)); + Put (Standard_Error, "usage: "); + Put_Line (Standard_Error, Command.Usage.all); + Errors := Errors + 1; + end if; + + if Errors > 0 then + raise Error_Exit; + else + -- Prepare arguments for a call to spawn, filtering out + -- embedded nulls place there to delineate strings. + + Process_Buffer (String (Buffer.Table (1 .. Buffer.Last))); + + if Cargs_Buffer.Last > 1 then + Last_Switches.Append (new String'("-cargs")); + Process_Buffer + (String (Cargs_Buffer.Table (1 .. Cargs_Buffer.Last))); + end if; + end if; + end VMS_Conversion; + +end VMS_Conv; diff --git a/gcc/ada/vms_conv.ads b/gcc/ada/vms_conv.ads new file mode 100644 index 000000000..7e2127f10 --- /dev/null +++ b/gcc/ada/vms_conv.ads @@ -0,0 +1,161 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V M S _ C O N V -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2003-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- 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 GNAT driver. It contains the procedure +-- VMS_Conversion to convert a VMS command line to the equivalent command +-- line with switches for the GNAT tools that the GNAT driver will invoke. +-- The qualifier declarations are contained in package VMS_Data. + +with Table; +with VMS_Data; use VMS_Data; +with VMS_Cmds; use VMS_Cmds; + +with GNAT.OS_Lib; use GNAT.OS_Lib; + +package VMS_Conv is + + -- A table to keep the switches on the command line + + package Last_Switches is new Table.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Gnatcmd.Last_Switches"); + + Normal_Exit : exception; + -- Raise this exception for normal program termination + + Error_Exit : exception; + -- Raise this exception if error detected + + Errors : Natural := 0; + -- Count errors detected + + Display_Command : Boolean := False; + -- Set true if /? switch causes display of generated command (on VMS) + + ------------------- + -- Command Table -- + ------------------- + + -- The command table contains an entry for each command recognized by + -- GNATCmd. The entries are represented by an array of records. + + type Parameter_Type is + -- A parameter is defined as a whitespace bounded string, not beginning + -- with a slash. (But see note under FILES_OR_WILDCARD). + (File, + -- A required file or directory parameter + + Optional_File, + -- An optional file or directory parameter + + Other_As_Is, + -- A parameter that's passed through as is (not canonicalized) + + Unlimited_Files, + -- An unlimited number of whitespace separate file or directory + -- parameters including wildcard specifications. + + Unlimited_As_Is, + -- An unlimited number of whitespace separated parameters that are + -- passed through as is (not canonicalized). + + Files_Or_Wildcard); + -- A comma separated list of files and/or wildcard file specifications. + -- A comma preceded by or followed by whitespace is considered as a + -- single comma character w/o whitespace. + + type Parameter_Array is array (Natural range <>) of Parameter_Type; + type Parameter_Ref is access all Parameter_Array; + + type Alternate_Command is (Comp, Ls, Kr, Pp, Prep); + -- Alternate command label for non VMS system use + + Corresponding_To : constant array (Alternate_Command) of Command_Type := + (Comp => Compile, + Ls => List, + Kr => Krunch, + Prep => Preprocess, + Pp => Pretty); + -- Mapping of alternate commands to commands + + subtype Real_Command_Type is Command_Type range Bind .. Xref; + + type Command_Entry is record + Cname : String_Ptr; + -- Command name for GNAT xxx command + + Usage : String_Ptr; + -- A usage string, used for error messages + + Unixcmd : String_Ptr; + -- Corresponding Unix command + + Unixsws : Argument_List_Access; + -- Switches for the Unix command + + VMS_Only : Boolean; + -- When True, the command can only be used on VMS + + Switches : Switches_Ptr; + -- Pointer to array of switch strings + + Params : Parameter_Ref; + -- Describes the allowable types of parameters. + -- Params (1) is the type of the first parameter, etc. + -- An empty parameter array means this command takes no parameters. + + Defext : String (1 .. 3); + -- Default extension. If non-blank, then this extension is supplied by + -- default as the extension for any file parameter which does not have + -- an extension already. + end record; + + ------------------- + -- Switch Tables -- + ------------------- + + -- The switch tables contain an entry for each switch recognized by the + -- command processor. It is initialized by procedure Initialize. + + Command_List : array (Real_Command_Type) of Command_Entry; + + ---------------- + -- Procedures -- + ---------------- + + procedure Initialize; + -- Initialized the switch table Command_List + + procedure Output_Version; + -- Output the version of this program + + procedure VMS_Conversion (The_Command : out Command_Type); + -- Converts VMS command line to equivalent Unix command line + +end VMS_Conv; diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads new file mode 100644 index 000000000..7b482827f --- /dev/null +++ b/gcc/ada/vms_data.ads @@ -0,0 +1,7230 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V M S _ D A T A -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1996-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains, for each of the command of the GNAT driver, one +-- constant array; each component of this array is a string that defines, +-- in coded form as explained below, the conversion of a VMS qualifier of the +-- command to the corresponding switch of the GNAT tool corresponding to the +-- command. + +-- This package is used by the GNAT driver to invokes the GNAT tools with the +-- switches corresponding to the VMS qualifier and by the Project Manager to +-- convert VMS qualifiers in project files to their corresponding switch +-- values. + +-- This package is also an input to the tool that generates the VMS GNAT +-- help information automatically. + +-- NOTE: the format of this package must follow the following rules, so that +-- the VMS GNAT help tool works properly: + +-- - Each command zone (where the eventual qualifiers are declared) must +-- begin with a boxed comment of the form: + +-- --------------------------------- +-- -- Switches for GNAT -- +-- --------------------------------- + +-- where is the name of a GNAT command in capital letters, for +-- example BIND, COMPILE, XREF, ... + +-- - each qualifier declaration must be followed either by +-- - a comment starting with "-- NODOC", to indicate that there is +-- no documentation for this qualifier, or +-- - a contiguous sequence of comments that constitute the +-- documentation of the qualifier. + +-- - each command zone ends with the declaration of the constant array +-- for the command, of the form: + +-- __Switches : aliased constant Switches := + +package VMS_Data is + + ---------------- + -- QUALIFIERS -- + ---------------- + + -- The syntax of a qualifier declaration is as follows: + + -- SWITCH_STRING ::= "/ command-qualifier-name TRANSLATION" + + -- TRANSLATION ::= + -- DIRECT_TRANSLATION + -- | DIRECTORIES_TRANSLATION + -- | FILE_TRANSLATION + -- | NO_SPACE_FILE_TRANSL + -- | NUMERIC_TRANSLATION + -- | STRING_TRANSLATION + -- | OPTIONS_TRANSLATION + -- | COMMANDS_TRANSLATION + -- | ALPHANUMPLUS_TRANSLATION + -- | OTHER_TRANSLATION + + -- DIRECT_TRANSLATION ::= space UNIX_SWITCHES + -- DIRECTORIES_TRANSLATION ::= =* UNIX_SWITCH * + -- DIRECTORY_TRANSLATION ::= =% UNIX_SWITCH % + -- FILE_TRANSLATION ::= =@ UNIX_SWITCH @ + -- NO_SPACE_FILE_TRANSL ::= =< UNIX_SWITCH > + -- NUMERIC_TRANSLATION ::= =# UNIX_SWITCH # | # number # + -- STRING_TRANSLATION ::= =" UNIX_SWITCH " + -- OPTIONS_TRANSLATION ::= =OPTION {space OPTION} + -- COMMANDS_TRANSLATION ::= =? ARGS space command-name + -- ALPHANUMPLUS_TRANSLATION ::= =| UNIX_SWITCH | + + -- UNIX_SWITCHES ::= UNIX_SWITCH {, UNIX_SWITCH} + + -- UNIX_SWITCH ::= unix-switch-string | !unix-switch-string | `string' + + -- OPTION ::= option-name space UNIX_SWITCHES + + -- ARGS ::= -cargs | -bargs | -largs + + -- Here command-qual is the name of the switch recognized by the GNATCmd. + -- This is always given in upper case in the templates, although in the + -- actual commands, either upper or lower case is allowed. + + -- The unix-switch-string always starts with a minus, and has no commas + -- or spaces in it. Case is significant in the unix switch string. If a + -- unix switch string is preceded by the not sign (!) it means that the + -- effect of the corresponding command qualifier is to remove any previous + -- occurrence of the given switch in the command line. + + -- The DIRECTORIES_TRANSLATION format is used where a list of directories + -- is given. This possible corresponding formats recognized by GNATCmd are + -- as shown by the following example for the case of PATH + + -- PATH=direc + -- PATH=(direc,direc,direc,direc) + + -- When more than one directory is present for the DIRECTORIES case, then + -- multiple instances of the corresponding unix switch are generated, + -- with the file name being substituted for the occurrence of *. + + -- The FILE_TRANSLATION format is similar except that only a single + -- file is allowed, not a list of files, and only one unix switch is + -- generated as a result. + + -- the NO_SPACE_FILE_TRANSL is similar to FILE_TRANSLATION, except that + -- no space is inserted between the switch and the file name. + + -- The NUMERIC_TRANSLATION format is similar to the FILE_TRANSLATION case + -- except that the parameter is a decimal integer in the range 0 to 999999. + + -- For the OPTIONS_TRANSLATION case, GNATCmd similarly permits one or + -- more options to appear (although only in some cases does the use of + -- multiple options make logical sense). For example, taking the + -- case of ERRORS for GCC, the following are all allowed: + + -- /ERRORS=BRIEF + -- /ERRORS=(FULL,VERBOSE) + -- /ERRORS=(BRIEF IMMEDIATE) + + -- If no option is provided (e.g. just /ERRORS is written), then the + -- first option in the list is the default option. For /ERRORS this + -- is NORMAL, so /ERRORS with no option is equivalent to /ERRORS=NORMAL. + + -- The COMMANDS_TRANSLATION case is only used for gnatmake, to correspond + -- to the use of -cargs, -bargs and -largs (the ARGS string as indicated + -- is one of these three possibilities). The name given by COMMAND is the + -- corresponding command name to be used to interpret the switches to be + -- passed on. Switches of this type set modes, e.g. /COMPILER_QUALIFIERS + -- sets the mode so that all subsequent switches, up to another switch + -- with COMMANDS_TRANSLATION apply to the corresponding commands issued + -- by the make utility. For example + + -- /COMPILER_QUALIFIERS /LIST /BINDER_QUALIFIERS /MAIN + -- /COMPILER_QUALIFIERS /NOLIST /COMPILE_CHECKS=SYNTAX + + -- Clearly these switches must come at the end of the list of switches + -- since all subsequent switches apply to an issued command. + + -- For the DIRECT_TRANSLATION case, an implicit additional qualifier + -- declaration is created by prepending NO to the name of the qualifier, + -- and then inverting the sense of the UNIX_SWITCHES string. For example, + -- given the qualifier definition: + + -- "/LIST -gnatl" + + -- An implicit qualifier definition is created: + + -- "/NOLIST !-gnatl" + + -- In the case where, a ! is already present, inverting the sense of the + -- switch means removing it. + + subtype S is String; + -- A synonym to shorten the table + + type String_Ptr is access constant String; + -- String pointer type used throughout + + type Switches is array (Natural range <>) of String_Ptr; + -- Type used for array of switches + + type Switches_Ptr is access constant Switches; + + ---------------------------- + -- Switches for GNAT BIND -- + ---------------------------- + + S_Bind_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & + "-aP*"; + -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) + -- + -- Add directories to the project search path. + + S_Bind_ALI : aliased constant S := "/ALI_LIST " & + "-A"; + -- /NOALI_LIST (D) + -- /ALI_LIST + -- + -- Output full names of all the ALI files in the partition. The output is + -- written to SYS$OUTPUT. + + S_Bind_Bind : aliased constant S := "/BIND_FILE=" & + "ADA " & + "-A " & + "C " & + "-C"; + -- /BIND_FILE[=bind-file-option] + -- + -- Specifies the language of the binder generated file. + -- + -- ADA (D) Binder file is Ada. + -- + -- C Binder file is 'C'. + + S_Bind_Build : aliased constant S := "/BUILD_LIBRARY=|" & + "-L|"; + -- /BUILD_LIBRARY=xxx + -- + -- Binds the units for library building. In this case the adainit and + -- adafinal procedures are rename to xxxinit and xxxfinal. Implies + -- /NOMAIN. + + S_Bind_Current : aliased constant S := "/CURRENT_DIRECTORY " & + "!-I-"; + -- /CURRENT_DIRECTORY (D) + -- /NOCURRENT_DIRECTORY + -- + -- Look for source, library or object files in the default directory. + + S_Bind_Debug : aliased constant S := "/DEBUG=" & + "TRACEBACK " & + "-g2 " & + "ALL " & + "-g3 " & + "NONE " & + "-g0 " & + "SYMBOLS " & + "-g1 " & + "NOSYMBOLS " & + "!-g1 " & + "LINK " & + "-g3 " & + "NOTRACEBACK " & + "!-g2"; + -- /DEBUG[=debug-level] + -- /NODEBUG + -- + -- Specify level of debugging information generated for the elaboration + -- routine. See corresponding qualifier for GNAT COMPILE. + + S_Bind_DebugX : aliased constant S := "/NODEBUG " & + "!-g"; + -- NODOC (see /DEBUG) + + S_Bind_Elab : aliased constant S := "/ELABORATION_DEPENDENCIES " & + "-e"; + -- /ELABORATION_DEPENDENCIES + -- /NOELABORATION_DEPENDENCIES (D) + -- + -- Output complete list of elaboration-order dependencies, showing the + -- reason for each dependency. This output can be rather extensive but may + -- be useful in diagnosing problems with elaboration order. The output is + -- written to SYS$OUTPUT. + + S_Bind_Error : aliased constant S := "/ERROR_LIMIT=#" & + "-m#"; + -- /ERROR_LIMIT=nnn + -- + -- Limit number of detected errors to nnn (1-999999). + + S_Bind_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & + "-X" & '"'; + -- /EXTERNAL_REFERENCE="name=val" + -- + -- Specifies an external reference to the project manager. Useful only if + -- /PROJECT_FILE is used. + -- + -- Example: + -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + + S_Bind_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + + S_Bind_Force : aliased constant S := "/FORCE_ELAB_FLAGS " & + "-F"; + -- /NOFORCE_ELAB_FLAGS (D) + -- /FORCE_ELAB_FLAGS + -- + -- Force checking of elaboration Flags + + S_Bind_Help : aliased constant S := "/HELP " & + "-h"; + -- /HELP + -- + -- Output usage information. + + S_Bind_Init : aliased constant S := "/INITIALIZE_SCALARS=" & + "INVALID " & + "-Sin " & + "LOW " & + "-Slo " & + "HIGH " & + "-Shi"; + -- /INITIALIZE_SCALARS[=scalar-option] + -- + -- Indicate how uninitialized scalar values for which a pragma + -- Initialize_Scalars applies should be initialized. + -- scalar-option may be one of the following: + -- + -- INVALID (D) Initialize with an invalid value. + -- LOW Initialize with the lowest valid value of the subtype. + -- HIGH Initialize with the highest valid value of the subtype. + + S_Bind_Leap : aliased constant S := "/ENABLE_LEAP_SECONDS " & + "-y"; + -- /ENABLE_LEAP_SECONDS + -- /NOENABLE_LEAP_SECONDS (D) + -- + -- Enable leap seconds support in Ada.Calendar and its children. + + S_Bind_Library : aliased constant S := "/LIBRARY_SEARCH=*" & + "-aO*"; + -- /LIBRARY_SEARCH=(direc[,...]) + -- + -- When looking for library and object files look also in directories + -- specified. + + S_Bind_Linker : aliased constant S := "/LINKER_OPTION_LIST " & + "-K"; + -- /NOLINKER_OPTION_LIST (D) + -- /LINKER_OPTION_LIST + -- + -- Output linker options to SYS$OUTPUT. Includes library search + -- paths, contents of pragmas Ident and Linker_Options, and + -- libraries added by GNAT BIND. + + S_Bind_Main : aliased constant S := "/MAIN " & + "!-n"; + -- /MAIN (D) + -- + -- The main program is in Ada. + -- + -- /NOMAIN + -- + -- The main program is not in Ada. + + S_Bind_Alloc32 : aliased constant S := "/32_MALLOC " & + "-H32"; + -- /32_MALLOC + -- + -- Use 32-bit allocations for `__gnat_malloc' (and thus for + -- access types). + + S_Bind_Alloc64 : aliased constant S := "/64_MALLOC " & + "-H64"; + -- /64_MALLOC + -- + -- Use 64-bit allocations for `__gnat_malloc' (and thus for + -- access types). + + S_Bind_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & + "DEFAULT " & + "-vP0 " & + "MEDIUM " & + "-vP1 " & + "HIGH " & + "-vP2"; + -- /MESSAGES_PROJECT_FILE[=messages-option] + -- + -- Specifies the "verbosity" of the parsing of project files. + -- messages-option may be one of the following: + -- + -- DEFAULT (D) No messages are output if there is no error or warning. + -- + -- MEDIUM A small number of messages are output. + -- + -- HIGH A great number of messages are output, most of them not + -- being useful for the user. + + S_Bind_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & + "-nostdinc"; + -- /NOSTD_INCLUDES + -- + -- Do not look for sources the in the system default directory. + + S_Bind_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " & + "-nostdlib"; + -- /NOSTD_LIBRARIES + -- + -- Do not look for library files in the system default directory. + + S_Bind_No_Time : aliased constant S := "/NO_TIME_STAMP_CHECK " & + "-t"; + -- NODOC (see /TIME_STAMP_CHECK) + + S_Bind_Object : aliased constant S := "/OBJECT_LIST " & + "-O"; + -- /NOOBJECT_LIST (D) + -- /OBJECT_LIST + -- + -- Output full names of all the object files that must be linked to + -- provide the Ada component of the program. The output is written to + -- SYS$OUTPUT. + + S_Bind_Order : aliased constant S := "/ORDER_OF_ELABORATION " & + "-l"; + -- /NOORDER_OF_ELABORATION (D) + -- /ORDER_OF_ELABORATION + -- + -- Output chosen elaboration order. The output is written to SYS$OUTPUT. + + S_Bind_Output : aliased constant S := "/OUTPUT=@" & + "-o@"; + -- /OUTPUT=filename + -- + -- File name to use for the program containing the elaboration code. + + S_Bind_OutputX : aliased constant S := "/NOOUTPUT " & + "-c"; + -- /NOOUTPUT + -- + -- Check only. Do not generate the binder output file. + -- + -- In this mode the binder performs all error checks but does not generate + -- an output file. + + S_Bind_Pess : aliased constant S := "/PESSIMISTIC_ELABORATION " & + "-p"; + -- /PESSIMISTIC_ELABORATION + -- + -- Causes the binder to choose a "pessimistic" elaboration order, i.e. one + -- which is most likely to cause elaboration order problems. This can be + -- useful in testing portable code to make sure that there are no missing + -- elaborate pragmas. + + S_Bind_Project : aliased constant S := "/PROJECT_FILE=<" & + "-P>"; + -- /PROJECT_FILE=filename + -- + -- Specifies the main project file to be used. The project files rooted + -- at the main project file will be parsed before the invocation of the + -- binder. The source and object directories to be searched will be + -- communicated to the binder through logical names ADA_PRJ_INCLUDE_FILE + -- and ADA_PRJ_OBJECTS_FILE. + + S_Bind_Read : aliased constant S := "/READ_SOURCES=" & + "ALL " & + "-s " & + "NONE " & + "-x " & + "AVAILABLE " & + "!-x,!-s"; + -- /READ_SOURCES[=(keyword[,...])] + -- /NOREAD_SOURCES + -- + -- The following keyword are accepted: + -- + -- ALL (D) Require source files to be present. In this mode, the + -- binder insists on being able to locate all source files + -- that are referenced and checks their consistency. In + -- normal mode, if a source file cannot be located it is + -- simply ignored. If you specify the ALL keyword, a + -- missing source file is an error. + -- + -- NONE Exclude source files. In this mode, the binder only + -- checks that ALI files are consistent with one another. + -- source files are not accessed. The binder runs faster + -- in this mode, and there is still a guarantee that the + -- resulting program is self-consistent. + -- + -- If a source file has been edited since it was last + -- compiled and you specify the NONE keyword, the binder + -- will not detect that the object file is out of date + -- with the source file. + -- + -- This is the same as specifying /NOREAD_SOURCES. + -- + -- AVAILABLE Check that object files are consistent with one + -- another and are consistent with any source files that + -- can be located. + + S_Bind_ReadX : aliased constant S := "/NOREAD_SOURCES " & + "-x"; + -- NODOC (see /READ_SOURCES) + + S_Bind_Rename : aliased constant S := "/RENAME_MAIN=<" & + "-M>"; + -- /RENAME_MAIN=xxx + -- + -- Renames the generated main program from main to xxx. + -- This is useful in the case of some cross-building environments, where + -- the actual main program is separate from the one generated + -- by GNAT BIND. + + S_Bind_Report : aliased constant S := "/REPORT_ERRORS=" & + "VERBOSE " & + "-v " & + "BRIEF " & + "-b " & + "DEFAULT " & + "!-b,!-v"; + -- /REPORT_ERRORS[=(keyword[,...])] + -- VERBOSE (D) + -- BRIEF + -- DEFAULT + -- /NOREPORT_ERRORS + -- + -- With the DEFAULT keyword (which is not the default when the binder is + -- run from GNAT BIND) or the /NOREPORT_ERRORS qualifier, brief error + -- messages are generated to SYS$ERROR. If the VERBOSE keyword is + -- present, a header is written to SYS$OUTPUT and any error messages are + -- directed to SYS$OUTPUT All that is written to SYS$ERROR is a brief + -- summary message. + -- + -- If the BRIEF keyword is specified, the binder will generate brief error + -- messages to SYS$ERROR even if verbose mode is specified. This is + -- relevant only when used together with the VERBOSE keyword or /VERBOSE + -- qualifier. + + S_Bind_ReportX : aliased constant S := "/NOREPORT_ERRORS " & + "!-b,!-v"; + -- NODOC (see /REPORT_ERRORS) + + S_Bind_Restr : aliased constant S := "/RESTRICTION_LIST " & + "-r"; + -- /NORESTRICTION_LIST (D) + -- /RESTRICTION_LIST + -- + -- Generate list of pragma Restrictions that could be applied to the + -- current unit. This is useful for code audit purposes, and also may be + -- used to improve code generation in some cases. + + S_Bind_Return : aliased constant S := "/RETURN_CODES=" & + "POSIX " & + "!-X1 " & + "VMS " & + "-X1"; + -- /RETURN_CODES=POSIX (D) + -- /RETURN_CODES=VMS + -- + -- Specifies the style of default exit code returned. Must be used in + -- conjunction with and match the Link qualifier with same name. + -- + -- POSIX (D) Return Posix success (0) by default. + -- + -- VMS Return VMS success (1) by default. + + S_Bind_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" & + "--RTS=|"; + -- /RUNTIME_SYSTEM=xxx + -- + -- Binds against an alternate runtime system named xxx or RTS-xxx. + + S_Bind_Search : aliased constant S := "/SEARCH=*" & + "-I*"; + -- /SEARCH=(directory[,...]) + -- + -- When looking for source or object files also look in directories + -- specified. + -- + -- This is the same as specifying both /LIBRARY_SEARCH and /SOURCE_SEARCH + -- for a directory. + + S_Bind_Shared : aliased constant S := "/SHARED " & + "-shared,!-static"; + -- /SHARED + -- /NOSHARED + -- + -- Link against a shared GNAT run time when available. + + S_Bind_Slice : aliased constant S := "/TIME_SLICE=#" & + "-T#"; + -- /TIME_SLICE=nnn + -- + -- Set the time slice value to nnn milliseconds. A value of zero means no + -- time slicing and also indicates to the tasking run time to match as + -- close as possible to the annex D requirements of the RM. + + S_Bind_Source : aliased constant S := "/SOURCE_SEARCH=*" & + "-aI*"; + -- /SOURCE_SEARCH=(directory[,...]) + -- + -- When looking for source files also look in directories specified. + + S_Bind_Static : aliased constant S := "/STATIC " & + "-static,!-shared"; + -- /STATIC + -- /NOSTATIC + -- + -- Link against a static GNAT run time. + + S_Bind_Store : aliased constant S := "/STORE_TRACEBACKS " & + "-E"; + -- /STORE_TRACEBACKS (D) + -- /NOSTORE_TRACEBACKS + -- + -- Store tracebacks in exception occurrences. + -- This is the default on VMS, with the zero-cost exception mechanism. + -- This qualifier has no impact, except when using the setjmp/longjmp + -- exception mechanism, with the GNAT COMPILE qualifier /LONGJMP_SETJMP. + + S_Bind_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + + S_Bind_Time : aliased constant S := "/TIME_STAMP_CHECK " & + "!-t"; + -- /TIME_STAMP_CHECK (D) + -- + -- Time stamp errors will be treated as errors. + -- + -- /NOTIME_STAMP_CHECK + -- + -- Ignore time stamp errors. Any time stamp error messages are treated as + -- warning messages. This switch essentially disconnects the normal + -- consistency checking, and the resulting program may have undefined + -- semantics if inconsistent units are present. + -- + -- This means that /NOTIME_STAMP_CHECK should be used only in unusual + -- situations, with extreme care. + + S_Bind_Verbose : aliased constant S := "/VERBOSE " & + "-v"; + -- /VERBOSE (D) + -- /NOVERBOSE + -- + -- Equivalent to /REPORT_ERRORS=VERBOSE. + + S_Bind_Warn : aliased constant S := "/WARNINGS=" & + "NORMAL " & + "!-ws,!-we " & + "SUPPRESS " & + "-ws " & + "ERROR " & + "-we"; + -- /WARNINGS[=(keyword[,...])] + -- /NOWARNINGS + -- + -- The following keywords are supported: + -- + -- NORMAL (D) Print warning messages and treat them as warning. + -- SUPPRESS Suppress all warning messages (same as /NOWARNINGS). + -- ERROR Treat any warning messages as fatal errors + + S_Bind_WarnX : aliased constant S := "/NOWARNINGS " & + "-ws"; + -- NODOC (see /WARNINGS) + + S_Bind_Wide : aliased constant S := "/WIDE_CHARACTER_ENCODING=" & + "BRACKETS " & + "-gnatWb " & + "HEX " & + "-gnatWh " & + "UPPER " & + "-gnatWu " & + "SHIFT_JIS " & + "-gnatWs " & + "UTF8 " & + "-gnatW8 " & + "EUC " & + "-gnatWe"; + -- /NOWIDE_CHARACTER_ENCODING (D) + -- /WIDE_CHARACTER_ENCODING[=encode-type] + -- + -- Specifies the mechanism used to encode wide characters, overriding + -- the default as set by the /WIDE_CHARACTER_ENCODING option for the + -- compilation of the main program. + + S_Bind_Zero : aliased constant S := "/ZERO_MAIN " & + "-z"; + -- /NOZERO_MAIN (D) + -- /ZERO_MAIN + -- + -- Normally the binder checks that the unit name given on the command line + -- corresponds to a suitable main subprogram. When /ZERO_MAIN is used, + -- a list of ALI files can be given, and the execution of the program + -- consists of elaboration of these units in an appropriate order. + + Bind_Switches : aliased constant Switches := + (S_Bind_Add 'Access, + S_Bind_ALI 'Access, + S_Bind_Bind 'Access, + S_Bind_Build 'Access, + S_Bind_Current 'Access, + S_Bind_Debug 'Access, + S_Bind_DebugX 'Access, + S_Bind_Elab 'Access, + S_Bind_Error 'Access, + S_Bind_Ext 'Access, + S_Bind_Follow 'Access, + S_Bind_Force 'Access, + S_Bind_Help 'Access, + S_Bind_Init 'Access, + S_Bind_Leap 'Access, + S_Bind_Library 'Access, + S_Bind_Linker 'Access, + S_Bind_Main 'Access, + S_Bind_Alloc32 'Access, + S_Bind_Alloc64 'Access, + S_Bind_Mess 'Access, + S_Bind_Nostinc 'Access, + S_Bind_Nostlib 'Access, + S_Bind_No_Time 'Access, + S_Bind_Object 'Access, + S_Bind_Order 'Access, + S_Bind_Output 'Access, + S_Bind_OutputX 'Access, + S_Bind_Pess 'Access, + S_Bind_Project 'Access, + S_Bind_Read 'Access, + S_Bind_ReadX 'Access, + S_Bind_Rename 'Access, + S_Bind_Report 'Access, + S_Bind_ReportX 'Access, + S_Bind_Restr 'Access, + S_Bind_Return 'Access, + S_Bind_RTS 'Access, + S_Bind_Search 'Access, + S_Bind_Shared 'Access, + S_Bind_Slice 'Access, + S_Bind_Source 'Access, + S_Bind_Static 'Access, + S_Bind_Store 'Access, + S_Bind_Subdirs 'Access, + S_Bind_Time 'Access, + S_Bind_Verbose 'Access, + S_Bind_Warn 'Access, + S_Bind_WarnX 'Access, + S_Bind_Wide 'Access, + S_Bind_Zero 'Access); + + ----------------------------- + -- Switches for GNAT CHECK -- + ----------------------------- + + S_Check_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & + "-aP*"; + -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) + -- + -- Add directories to the project search path. + + S_Check_All : aliased constant S := "/ALL " & + "-a"; + -- /NOALL (D) + -- /ALL + -- + -- Also check the components of the GNAT run time and process the needed + -- components of the GNAT RTL when building and analyzing the global + -- structure for checking the global rules. + + S_Check_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & + "-X" & '"'; + -- /EXTERNAL_REFERENCE="name=val" + -- + -- Specifies an external reference to the project manager. Useful only if + -- /PROJECT_FILE is used. + -- + -- Example: + -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + + S_Check_Files : aliased constant S := "/FILES=@" & + "-files=@"; + -- /FILES=filename + -- + -- Take as arguments the files that are listed in the specified + -- text file. + + S_Check_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + + S_Check_Help : aliased constant S := "/HELP " & + "-h"; + -- /NOHELP (D) + -- /HELP + -- + -- Print information about currently implemented checks. + + S_Check_Locs : aliased constant S := "/LOCS " & + "-l"; + -- /NOLOCS (D) + -- /LOCS + -- + -- Use full source locations references in the report file. + + S_Diagnosis : aliased constant S := "/DIAGNOSTIC_LIMIT=#" & + "-m#"; + -- /DIAGNOSTIC_LIMIT=500 (D) + -- /DIAGNOSTIC_LIMIT=nnn + -- + -- NNN is a decimal integer in the range of 1 to 1000 and limits the + -- number of diagnostic messages to be generated into Stdout to that + -- number. Once that number has been reached, gnatcheck stops + -- to print out diagnoses into Stderr. If NNN is equal to 0, this means + -- that there is no limit on the number of diagnoses in Stdout. + + S_Check_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & + "DEFAULT " & + "-vP0 " & + "MEDIUM " & + "-vP1 " & + "HIGH " & + "-vP2"; + -- /MESSAGES_PROJECT_FILE[=messages-option] + -- + -- Specifies the "verbosity" of the parsing of project files. + -- messages-option may be one of the following: + -- + -- DEFAULT (D) No messages are output if there is no error or warning. + -- + -- MEDIUM A small number of messages are output. + -- + -- HIGH A great number of messages are output, most of them not + -- being useful for the user. + + S_Check_Project : aliased constant S := "/PROJECT_FILE=<" & + "-P>"; + -- /PROJECT_FILE=filename + -- + -- Specifies the main project file to be used. The project files rooted + -- at the main project file will be parsed before the invocation of the + -- gnatcheck. The source directories to be searched will be communicated + -- to gnatcheck through logical name ADA_PRJ_INCLUDE_FILE. + + S_Check_Quiet : aliased constant S := "/QUIET " & + "-q"; + -- /NOQUIET (D) + -- /QUIET + -- + -- Work quietly, only output warnings and errors. + + S_Check_Time : aliased constant S := "/TIME " & + "-t"; + -- /NOTIME (D) + -- /TIME + -- + -- Print out execution time + + S_Check_Log : aliased constant S := "/LOG " & + "-log"; + -- /NOLOG (D) + -- /LOG + -- + -- Duplicate all the output sent to Stderr into a log file. + + S_Check_Short : aliased constant S := "/SHORT " & + "-s"; + -- /NOSHORT (D) + -- /SHORT + -- + -- Generate a short form of the report file. + + S_Check_Include : aliased constant S := "/INCLUDE_FILE=@" & + "--include-file=@"; + + -- /INCLUDE_FILE=filename + -- + -- Add the content of the specified text file to the generated report + -- file. + + S_Check_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + + S_Check_Verb : aliased constant S := "/VERBOSE " & + "-v"; + -- /NOVERBOSE (D) + -- /VERBOSE + -- + -- The version number and copyright notice are output, as well as exact + -- copies of the gnat1 commands spawned to obtain the chop control + -- information. + + S_Check_Out : aliased constant S := "/OUTPUT=@" & + "-o@"; + -- /OUTPUT=filename + -- + -- Specify the name of the output file. + + Check_Switches : aliased constant Switches := + (S_Check_Add 'Access, + S_Check_All 'Access, + S_Diagnosis 'Access, + S_Check_Ext 'Access, + S_Check_Files 'Access, + S_Check_Follow 'Access, + S_Check_Help 'Access, + S_Check_Locs 'Access, + S_Check_Mess 'Access, + S_Check_Project'Access, + S_Check_Quiet 'Access, + S_Check_Time 'Access, + S_Check_Log 'Access, + S_Check_Short 'Access, + S_Check_Include'Access, + S_Check_Subdirs'Access, + S_Check_Verb 'Access, + S_Check_Out 'Access); + + ---------------------------- + -- Switches for GNAT CHOP -- + ---------------------------- + + S_Chop_Comp : aliased constant S := "/COMPILATION " & + "-c"; + -- /NOCOMPILATION (D) + -- /COMPILATION + -- + -- Compilation mode, handle configuration pragmas strictly according to + -- RM rules. + + S_Chop_File : aliased constant S := "/FILE_NAME_MAX_LENGTH=#" & + "-k#"; + -- /FILE_NAME_MAX_LENGTH[=nnn] + -- + -- Limit generated file names to NNN (default of 8) characters. This is + -- useful if the resulting set of files is required to be interoperable + -- with systems like MS-DOS which limit the length of file names. + + S_Chop_Help : aliased constant S := "/HELP " & + "-h"; + -- /NOHELP (D) + -- /HELP + -- + -- Print usage information. + + S_Chop_Over : aliased constant S := "/OVERWRITE " & + "-w"; + -- /NOOVERWRITE (D) + -- /OVERWRITE + -- + -- Overwrite existing file names. Normally GNAT CHOP regards it as a + -- fatal error situation if there is already a file with the same name as + -- a file it would otherwise output. The /OVERWRITE qualifier bypasses + -- this check, and any such existing files will be silently overwritten. + + S_Chop_Pres : aliased constant S := "/PRESERVE " & + "-p"; + -- /NOPRESERVE (D) + -- /PRESERVE + -- + -- Causes the file modification time stamp of the input file to be + -- preserved and used for the time stamp of the output file(s). This may + -- be useful for preserving coherency of time stamps in an environment + -- where gnatchop is used as part of a standard build process. + + S_Chop_Quiet : aliased constant S := "/QUIET " & + "-q"; + -- /NOQUIET (D) + -- /QUIET + -- + -- Work quietly, only output warnings and errors. + + S_Chop_Ref : aliased constant S := "/REFERENCE " & + "-r"; + -- /NOREFERENCE (D) + -- /REFERENCE + -- + -- Generate "Source_Reference" pragmas. Use this qualifier if the output + -- files are regarded as temporary and development is to be done in terms + -- of the original unchopped file. The /REFERENCE qualifier causes + -- "Source_Reference" pragmas to be inserted into each of the generated + -- files to refers back to the original file name and line number. The + -- result is that all error messages refer back to the original unchopped + -- file. + -- + -- In addition, the debugging information placed into the object file + -- (when the /DEBUG qualifier of GNAT COMPILE or GNAT MAKE is specified) + -- also refers back to this original file so that tools like profilers + -- and debuggers will give information in terms of the original unchopped + -- file. + + S_Chop_Verb : aliased constant S := "/VERBOSE " & + "-v"; + -- /NOVERBOSE (D) + -- /VERBOSE + -- + -- The version number and copyright notice are output, as well as exact + -- copies of the gnat1 commands spawned to obtain the chop control + -- information. + + Chop_Switches : aliased constant Switches := + (S_Chop_Comp 'Access, + S_Chop_File 'Access, + S_Chop_Help 'Access, + S_Chop_Over 'Access, + S_Chop_Pres 'Access, + S_Chop_Quiet 'Access, + S_Chop_Ref 'Access, + S_Chop_Verb 'Access); + + ----------------------------- + -- Switches for GNAT CLEAN -- + ----------------------------- + + S_Clean_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & + "-aP*"; + -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) + -- + -- Add directories to the project search path. + + S_Clean_Compil : aliased constant S := "/COMPILER_FILES_ONLY " & + "-c"; + -- /NOCOMPILER_FILES_ONLY (D) + -- /COMPILER_FILES_ONLY + -- + -- Only attempt to delete the files produced by the compiler, not those + -- produced by the binder or the linker. The files that are not to be + -- deleted are library files, interface copy files, binder generated files + -- and executable files. + + S_Clean_Current : aliased constant S := "/CURRENT_DIRECTORY " & + "!-I-"; + -- /CURRENT_DIRECTORY (D) + -- + -- Look for ALI or object files in the directory where GNAT CLEAN was + -- invoked. + -- + -- /NOCURRENT_DIRECTORY + -- + -- Do not look for ALI or object files in the directory where GNAT CLEAN + -- was invoked. + + S_Clean_Delete : aliased constant S := "/DELETE " & + "!-n"; + -- /DELETE (D) + -- + -- Delete the files that are not read-only. + -- + -- /NODELETE + -- + -- Informative-only mode. Do not delete any files. Output the list of the + -- files that would have been deleted if this switch was not specified. + + S_Clean_Dirobj : aliased constant S := "/DIRECTORY_OBJECTS=@" & + "-D@"; + -- /DIRECTORY_OBJECTS= + -- + -- Find the object files and .ALI files in . + -- This qualifier is not compatible with /PROJECT_FILE. + + S_Clean_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & + "-X" & '"'; + -- /EXTERNAL_REFERENCE="name=val" + -- + -- Specifies an external reference to the project manager. Useful only if + -- /PROJECT_FILE is used. + -- + -- Example: + -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + + S_Clean_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + + S_Clean_Full : aliased constant S := "/FULL_PATH_IN_BRIEF_MESSAGES " & + "-F"; + -- /NOFULL_PATH_IN_BRIEF_MESSAGES (D) + -- /FULL_PATH_IN_BRIEF_MESSAGES + -- + -- When using project files, if some errors or warnings are detected + -- during parsing and verbose mode is not in effect (no use of qualifier + -- /VERBOSE), then error lines start with the full path name of the + -- project file, rather than its simple file name. + + S_Clean_Help : aliased constant S := "/HELP " & + "-h"; + -- /NOHELP (D) + -- /HELP + -- + -- Output a message explaining the usage of gnatclean. + + S_Clean_Index : aliased constant S := "/SOURCE_INDEX=#" & + "-i#"; + -- /SOURCE_INDEX=nnn + -- + -- Specifies the index of the units in the source file + -- By default, source files are mono-unit and there is no index + + S_Clean_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & + "DEFAULT " & + "-vP0 " & + "MEDIUM " & + "-vP1 " & + "HIGH " & + "-vP2"; + -- /MESSAGES_PROJECT_FILE[=messages-option] + -- + -- Specifies the "verbosity" of the parsing of project files. + -- messages-option may be one of the following: + -- + -- DEFAULT (D) No messages are output if there is no error or warning. + -- + -- MEDIUM A small number of messages are output. + -- + -- HIGH A great number of messages are output, most of them not + -- being useful for the user. + + S_Clean_Object : aliased constant S := "/OBJECT_SEARCH=*" & + "-aO*"; + -- /OBJECT_SEARCH=(directory,...) + -- + -- When searching for library and object files, look in the specified + -- directories. The order in which library files are searched is the same + -- as for MAKE. + + S_Clean_Project : aliased constant S := "/PROJECT_FILE=<" & + "-P>"; + -- /PROJECT_FILE=filename + -- + -- Specifies the main project file to be used. The project files rooted + -- at the main project file will be parsed before the invocation of the + -- compiler. The source and object directories to be searched will be + -- communicated to gnatclean through logical names ADA_PRJ_INCLUDE_FILE + -- and ADA_PRJ_OBJECTS_FILE. + + S_Clean_Quiet : aliased constant S := "/QUIET " & + "-q"; + -- /NOQUIET (D) + -- /QUIET + -- + -- Quiet output. If there are no error, do not output anything, except in + -- verbose mode (qualifier /VERBOSE) or in informative-only mode + -- (qualifier /NODELETE). + + S_Clean_Recurs : aliased constant S := "/RECURSIVE " & + "-r"; + -- /NORECURSIVE (D) + -- /RECURSIVE + -- + -- When a project file is specified (using switch -P), clean all imported + -- and extended project files, recursively. If this qualifier is not + -- specified, only the files related to the main project file are to be + -- deleted. This qualifier has no effect if no project file is specified. + + S_Clean_Search : aliased constant S := "/SEARCH=*" & + "-I*"; + -- /SEARCH=(directory,...) + -- + -- Equivalent to /OBJECT_SEARCH=(directory,...). + + S_Clean_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + + S_Clean_USL : aliased constant S := "/UNCHECKED_SHARED_LIB_IMPORTS " & + "--unchecked-shared-lib-imports"; + -- /NOUNCHECKED_SHARED_LIB_IMPORTS (D) + -- /UNCHECKED_SHARED_LIB_IMPORTS + -- + -- Allow shared library projects to import static library projects + + S_Clean_Verbose : aliased constant S := "/VERBOSE " & + "-v"; + -- /NOVERBOSE (D) + -- /VERBOSE + -- + -- Verbose mode. + + Clean_Switches : aliased constant Switches := + (S_Clean_Add 'Access, + S_Clean_Compil 'Access, + S_Clean_Current'Access, + S_Clean_Delete 'Access, + S_Clean_Dirobj 'Access, + S_Clean_Ext 'Access, + S_Clean_Follow 'Access, + S_Clean_Full 'Access, + S_Clean_Help 'Access, + S_Clean_Index 'Access, + S_Clean_Mess 'Access, + S_Clean_Object 'Access, + S_Clean_Project'Access, + S_Clean_Quiet 'Access, + S_Clean_Recurs 'Access, + S_Clean_Search 'Access, + S_Clean_Subdirs'Access, + S_Clean_Verbose'Access, + S_Clean_USL 'Access); + + ------------------------------- + -- Switches for GNAT COMPILE -- + ------------------------------- + + S_GCC_Ada_83 : aliased constant S := "/83 " & + "-gnat83"; + -- /NO83 (D) + -- /83 + -- + -- Although GNAT is primarily an Ada 95 compiler, it accepts this + -- qualifier to specify that an Ada 83 mode program is being compiled. If + -- you specify this qualifier, GNAT rejects Ada 95 extensions and applies + -- Ada 83 semantics. It is not possible to guarantee this qualifier does + -- a perfect job; for example, some subtle tests of pathological cases, + -- such as are found in ACVC tests that have been removed from the ACVC + -- suite for Ada 95, may not compile correctly. However for practical + -- purposes, using this qualifier should ensure that programs that + -- compile correctly under the /83 qualifier can be ported reasonably + -- easily to an Ada 83 compiler. This is the main use of this qualifier. + -- + -- With few exceptions (most notably the need to use "<>" on + -- unconstrained generic formal parameters), it is not necessary to use + -- this qualifier switch when compiling Ada 83 programs, because, with + -- rare and obscure exceptions, Ada 95 is upwardly compatible with Ada + -- 83. This means that a correct Ada 83 program is usually also a correct + -- Ada 95 program. + + S_GCC_Ada_95 : aliased constant S := "/95 " & + "-gnat95"; + -- /95 (D) + -- + -- Allows GNAT to recognize the full range of Ada 95 constructs. + -- This is the normal default for GNAT Pro. + + S_GCC_Ada_05 : aliased constant S := "/05 " & + "-gnat05"; + -- /05 (D) + -- + -- Allows GNAT to recognize the full range of Ada 2005 constructs. + + S_GCC_Ada_2005 : aliased constant S := "/2005 " & + "-gnat2005"; + -- /05 (D) + -- + -- Allows GNAT to recognize the full range of Ada 2005 constructs. + -- Equivalent to /05 (/2005 is the preferred usage). + + S_GCC_Ada_12 : aliased constant S := "/12 " & + "-gnat12"; + -- /05 (D) + -- + -- Allows GNAT to recognize all implemented proposed Ada 2012 + -- extensions. See features file for list of implemented features. + + S_GCC_Ada_2012 : aliased constant S := "/2012 " & + "-gnat2012"; + -- /05 (D) + -- + -- Allows GNAT to recognize all implemented proposed Ada 2012 + -- extensions. See features file for list of implemented features. + -- Equivalent to /12 (/2012 is the preferred usage). + + S_GCC_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & + "-aP*"; + -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) + -- + -- Add directories to the project search path. + + S_GCC_Asm : aliased constant S := "/ASM " & + "-S,!-c"; + -- /NOASM (D) + -- /ASM + -- + -- Use to cause the assembler source file to be generated, using S as the + -- filetype, instead of the object file. This may be useful if you need + -- to examine the generated assembly code. + + S_GCC_AValid : aliased constant S := "/ASSUME_VALID " & + "-gnatB"; + -- /NO_ASSUME_VALID (D) + -- /ASSUME_VALID + -- + -- Use to tell the compiler to assume that all objects have valid values + -- except those occurring as prefixes to 'Valid attributes. In the default + -- mode, the compiler assumes that values may be invalid unless it can + -- be sure that they are valid, and code is generated to allow for this + -- possibility. The use of /ASSUME_VALID will improve the code. + + S_GCC_Checks : aliased constant S := "/CHECKS=" & + "FULL " & + "-gnato,!-gnatE,!-gnatp " & + "OVERFLOW " & + "-gnato " & + "ELABORATION " & + "-gnatE " & + "ASSERTIONS " & + "-gnata " & + "DEFAULT " & + "!-gnato,!-gnatp " & + "STACK " & + "-fstack-check " & + "SUPPRESS_ALL " & + "-gnatp " & + "UNSUPPRESS_ALL " & + "-gnat-p"; + -- /NOCHECKS + -- /CHECKS[=(keyword[,...])] + -- + -- If you compile with the default options, GNAT will insert many runtime + -- checks into the compiled code, including code that performs range + -- checking against constraints, but not arithmetic overflow checking for + -- integer operations (including division by zero) or checks for access + -- before elaboration on subprogram calls. All other runtime checks, as + -- required by the Ada 95 Reference Manual, are generated by default. + -- + -- You may specify one or more of the following keywords to the /CHECKS + -- qualifier to modify this behavior: + -- + -- DEFAULT The behavior described above. This is the default + -- if the /CHECKS qualifier is not present on the + -- command line. Same as /NOCHECKS. + -- + -- OVERFLOW Enables overflow checking for integer operations and + -- checks for access before elaboration on subprogram + -- calls. This causes GNAT to generate slower and larger + -- executable programs by adding code to check for both + -- overflow and division by zero (resulting in raising + -- "Constraint_Error" as required by Ada semantics). + -- Similarly, GNAT does not generate elaboration check + -- by default, and you must specify this keyword to + -- enable them. + -- + -- Note that this keyword does not affect the code + -- generated for any floating-point operations; it + -- applies only to integer operations. For the case of + -- floating-point, GNAT has the "Machine_Overflows" + -- attribute set to "False" and the normal mode of + -- operation is to generate IEEE NaN and infinite values + -- on overflow or invalid operations (such as dividing + -- 0.0 by 0.0). + -- + -- ELABORATION Enables dynamic checks for access-before-elaboration + -- on subprogram calls and generic instantiations. + -- + -- ASSERTIONS The pragmas "Assert" and "Debug" normally have no + -- effect and are ignored. This keyword causes "Assert" + -- and "Debug" pragmas to be activated, as well as + -- "Check", "Precondition" and "Postcondition" pragmas. + -- + -- SUPPRESS_ALL Suppress all runtime checks as though you have + -- "pragma Suppress (all_checks)" in your source. Use + -- this switch to improve the performance of the code at + -- the expense of safety in the presence of invalid data + -- or program bugs. + -- + -- UNSUPPRESS_ALL Cancels effect of previous SUPPRESS_ALL. + -- + -- DEFAULT Suppress the effect of any option OVERFLOW or + -- ASSERTIONS. + -- + -- FULL (D) Similar to OVERFLOW, but suppress the effect of any + -- option ELABORATION or SUPPRESS_ALL. + -- + -- These keywords only control the default setting of the checks. You + -- may modify them using either "Suppress" (to remove checks) or + -- "Unsuppress" (to add back suppressed checks) pragmas in your program + -- source. + + S_GCC_ChecksX : aliased constant S := "/NOCHECKS " & + "-gnatp,!-gnato,!-gnatE"; + -- NODOC (see /CHECKS) + + S_GCC_Compres : aliased constant S := "/COMPRESS_NAMES " & + "-gnatC"; + -- /NOCOMPRESS_NAMES (D) + -- /COMPRESS_NAMES + -- + -- Compress debug information and external symbol name table entries. + -- In the generated debugging information, and also in the case of long + -- external names, the compiler uses a compression mechanism if the name + -- is very long. This compression method uses a checksum, and avoids + -- trouble on some operating systems which have difficulty with very long + -- names. + + S_GCC_Config : aliased constant S := "/CONFIGURATION_PRAGMAS_FILE=<" & + "-gnatec>"; + -- /CONFIGURATION_PRAGMAS_FILE=file + -- + -- Specify a configuration pragmas file that need to be taken into account + + S_GCC_Current : aliased constant S := "/CURRENT_DIRECTORY " & + "!-I-"; + -- /CURRENT_DIRECTORY (D) + -- /NOCURRENT_DIRECTORY + -- + -- Look for source files in the default directory. + + S_GCC_Data : aliased constant S := "/DATA_PREPROCESSING=<" & + "-gnatep>"; + -- /DATA_PREPROCESSING=file_name + -- + -- This qualifier indicates to the compiler the file name (without + -- directory information) of the preprocessor data file to use. + -- The preprocessor data file should be found in the source directories. + -- + -- A preprocessing data file is a text file with significant lines + -- indicating how should be preprocessed either a specific source or all + -- sources not mentioned in other lines. A significant line is a non + -- empty, non comment line. Comments are similar to Ada comments. + -- + -- Each significant line starts with either a literal string or the + -- character '*'. A literal string is the file name (without directory + -- information) of the source to preprocess. A character '*' indicates the + -- preprocessing for all the sources that are not specified explicitly on + -- other lines. It is an error to have two lines with the same file name + -- or two lines starting with the character '*'. + -- + -- After the file name or the character '*', another optional literal + -- string indicating the file name of the definition file to be used for + -- preprocessing. (see 15.3 Form of Definitions File. The definition files + -- are found by the compiler in one of the source directories. In some + -- cases, when compiling a source in a directory other than the current + -- directory, if the definition file is in the current directory, it may + -- be necessary to add the current directory as a source directory through + -- qualifier "/SEARCH=[]", otherwise the compiler would not find the + -- definition file. + -- + -- Then, optionally, switches similar to those of gnatprep may be found. + -- Those switches are: + -- + -- -b Causes both preprocessor lines and the lines deleted by + -- preprocessing to be replaced by blank lines, preserving + -- the line number. This switch is always implied; + -- however, if specified after `-c' it cancels the effect + -- of `-c'. + -- + -- -c Causes both preprocessor lines and the lines deleted by + -- preprocessing to be retained as comments marked with + -- the special string "--! ". + -- + -- -Dsymbol=value Define or redefine a symbol, associated with value. + -- A symbol is an Ada identifier, or an Ada reserved word, + -- with the exception of "if", "else", "elsif", "end", + -- "and", "or" and "then". value is either a literal + -- string, an Ada identifier or any Ada reserved word. + -- A symbol declared with this switch replaces a symbol + -- with the same name defined in a definition file. + -- + -- -s Causes a sorted list of symbol names and values to be + -- listed on the standard output file. + -- + -- -u Causes undefined symbols to be treated as having the + -- value FALSE in the context of a preprocessor test. + -- In the absence of this option, an undefined symbol + -- in a #if or #elsif test will be treated as an error. + -- + -- Examples of valid lines in a preprocessor data file: + -- + -- "toto.adb" "prep.def" -u + -- -- preprocess "toto.adb", using definition file "prep.def", + -- -- undefined symbol are False. + -- + -- * -c -DVERSION=V101 + -- -- preprocess all other sources without a definition file; + -- -- suppressed lined are commented; symbol VERSION has the value + -- -- V101. + -- + -- "titi.adb" "prep2.def" -s + -- -- preprocess "titi.adb", using definition file "prep2.def"; + -- -- list all symbols with their values. + + S_GCC_Debug : aliased constant S := "/DEBUG=" & + "SYMBOLS " & + "-g2 " & + "NOSYMBOLS " & + "!-g2 " & + "TRACEBACK " & + "-g1 " & + "ALL " & + "-g3 " & + "NONE " & + "-g0 " & + "NOTRACEBACK " & + "-g0"; + -- /DEBUG[=debug-level] + -- /NODEBUG + -- + -- Specifies how much debugging information is to be included in + -- the resulting object fie. + -- + -- 'debug-level' is one of the following: + -- + -- SYMBOLS (D) Include both debugger symbol records and traceback + -- in the object file. + -- + -- ALL Include debugger symbol records, traceback plus + -- extra debug information in the object file. + -- + -- NONE Excludes both debugger symbol records and traceback + -- from the object file. Same as /NODEBUG. + -- + -- TRACEBACK Includes only traceback records in the object + -- file. This is the default when /DEBUG is not used. + + S_GCC_DebugX : aliased constant S := "/NODEBUG " & + "!-g"; + -- NODOC (see /Debug) + + S_GCC_Dist : aliased constant S := "/DISTRIBUTION_STUBS=" & + "RECEIVER " & + "-gnatzr " & + "CALLER " & + "-gnatzc"; + -- /NODISTRIBUTION_STUBS (D) + -- /DISTRIBUTION_STUBS[=dist-opt] + -- + -- 'dist-opt' is either RECEIVER (the default) or SENDER and indicates + -- that stubs for use in distributed programs (see the Distributed + -- Systems Annex of the Ada RM) should be generated. + + S_GCC_DistX : aliased constant S := "/NODISTRIBUTION_STUBS " & + "!-gnatzr,!-gnatzc"; + -- NODOC (see /DISTRIBUTION_STUBS) + + S_GCC_Error : aliased constant S := "/ERROR_LIMIT=#" & + "-gnatm#"; + -- /NOERROR_LIMIT (D) + -- /ERROR_LIMIT=nnn + -- + -- NNN is a decimal integer in the range of 1 to 999999 and limits the + -- number of error messages to be generated to that number. Once that + -- number has been reached, the compilation is abandoned. + -- Specifying 999999 is equivalent to /NOERROR_LIMIT. + + S_GCC_ErrorX : aliased constant S := "/NOERROR_LIMIT " & + "-gnatm999999"; + -- NODOC (see /ERROR_LIMIT) + + S_GCC_Except : aliased constant S := "/EXTRA_EXCEPTION_INFORMATION " & + "-gnateE"; + -- /EXTRA_EXCEPTION_INFORMATION + -- + -- Generate extra information in exception messages, in particular + -- display extra column information and the value and range associated + -- with index and range check failures, and extra column information for + -- access checks. + + S_GCC_Expand : aliased constant S := "/EXPAND_SOURCE " & + "-gnatG"; + -- /NOEXPAND_SOURCE (D) + -- /EXPAND_SOURCE + -- + -- Produces a listing of the expanded code in Ada source form. For + -- example, all tasking constructs are reduced to appropriate run-time + -- library calls. The maximum line length for the listing 72. + + S_GCC_Lexpand : aliased constant S := "/LEXPAND_SOURCE=#" & + "-gnatG#"; + -- /LEXPAND_SOURCE=nnn + -- + -- Produces a listing of the expanded code in Ada source form. For + -- example, all tasking constructs are reduced to appropriate run-time + -- library calls. The parameter is the maximum line length for the + -- listing. + + S_GCC_Extend : aliased constant S := "/EXTENSIONS_ALLOWED " & + "-gnatX"; + -- /NOEXTENSIONS_ALLOWED (D) + -- /EXTENSIONS_ALLOWED + -- + -- GNAT specific language extensions allowed. + + S_GCC_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & + "-X" & '"'; + -- /EXTERNAL_REFERENCE="name=val" + -- + -- Specifies an external reference to the project manager. Useful only if + -- /PROJECT_FILE is used. + -- + -- Example: + -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + + S_GCC_File : aliased constant S := "/FILE_NAME_MAX_LENGTH=#" & + "-gnatk#"; + -- /FILE_NAME_MAX_LENGTH=nnn + -- + -- Activates file name "krunching". NNN, a decimal integer in the range + -- 1-999, indicates the maximum allowable length of a file name (not + -- including the ADS or ADB filetype. The default is not to enable file + -- name krunching. + + S_GCC_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + + S_GCC_Force : aliased constant S := "/FORCE_ALI " & + "-gnatQ"; + -- /NOFORCE_ALI (D) + -- /FORCE_ALI + -- + -- In normal operation mode, the .ALI file is not generated if any + -- illegalities are detected in the program. The use of this qualifier + -- forces generation of the .ALI file. This file is marked as being + -- in error, so it cannot be used for binding purposes, but it does + -- contain reasonably complete cross-reference information, and thus may + -- be useful for use by tools (e.g. semantic browsing tools or integrated + -- development environments) that are driven from the .ALI file. + + S_GCC_Full : aliased constant S := "/FULL_PATH_IN_BRIEF_MESSAGES " & + "-gnatef"; + -- /NOFULL_PATH_IN_BRIEF_MESSAGES (D) + -- /FULL_PATH_IN_BRIEF_MESSAGES + -- + -- When using project files, if some errors or warnings are detected + -- during parsing and verbose mode is not in effect (no use of qualifier + -- /VERBOSE), then error lines start with the full path name of the + -- project file, rather than its simple file name. + + S_GCC_Generate : aliased constant S := "/GENERATE_PROCESSED_SOURCE " & + "-gnateG"; + -- /NOGENERATE_PROCESSED_SOURCE (D) + -- /GENERATE_PROCESSED_SOURCE + -- + -- Generate a file _prep if the integrated preprocessing + -- is modifying the source text. + + S_GCC_GNAT : aliased constant S := "/GNAT_INTERNAL " & + "-gnatg"; + -- /NOGNAT_INTERNAL (D) + -- /GNAT_INTERNAL + -- + -- Internal GNAT implementation mode. This should not be used for + -- applications programs, it is intended only for use by the compiler + -- and its run-time library. For documentation, see the GNAT sources. + -- Note that it implies /WARNINGS=ALL,ERRORS and /STYLE_CHECKS=GNAT + -- so that all standard warnings and all standard style options are + -- turned on. All warnings and style error messages are treated as + -- errors. + + S_GCC_Help : aliased constant S := "/HELP " & + "-gnath"; + -- /NOHELP (D) + -- /HELP + -- + -- Output usage information. + + S_GCC_Ident : aliased constant S := "/IDENTIFIER_CHARACTER_SET=" & + "DEFAULT " & + "-gnati1 " & + "1 " & + "-gnati1 " & + "2 " & + "-gnati2 " & + "3 " & + "-gnati3 " & + "4 " & + "-gnati4 " & + "5 " & + "-gnati5 " & + "PC " & + "-gnatip " & + "PC850 " & + "-gnati8 " & + "FULL_UPPER " & + "-gnatif " & + "NO_UPPER " & + "-gnatin " & + "WIDE " & + "-gnatiw"; + -- /NOIDENTIFIER_CHARACTER_SET (D) + -- /IDENTIFIER_CHARACTER_SET=char-set + -- + -- Normally GNAT recognizes the Latin-1 character set in source program + -- identifiers, as described in the reference manual. This qualifier + -- causes GNAT to recognize alternate character sets in identifiers. + -- 'char-set' is one of the following strings indicating the character + -- set: + -- + -- DEFAULT (D) Equivalent to 1, below. Also equivalent to + -- /NOIDENTIFIER_CHARACTER_SET. + -- + -- 1 The basic character set is Latin-1. This character + -- set is defined by ISO standard 8859, part 1. The lower + -- half (character codes 16#00# ... 16#7F#) is identical + -- to standard ASCII coding, but the upper half is used + -- to represent additional characters. This includes + -- extended letters used by European languages, such as + -- the umlaut used in German. + -- + -- You may use any of these extended characters freely + -- in character or string literals. In addition, the + -- extended characters that represent letters can be + -- used in identifiers. + -- + -- 2 Latin-2 letters allowed in identifiers, with uppercase + -- and lowercase equivalence. + -- + -- 3 Latin-3 letters allowed in identifiers, with uppercase + -- and lower case equivalence. + -- + -- 4 Latin-4 letters allowed in identifiers, with uppercase + -- and lower case equivalence. + -- + -- PC IBM PC code page 437. This code page is the normal + -- default for PCs in the U.S. It corresponds to the + -- original IBM PC character set. This set has some, but + -- not all, of the extended Latin-1 letters, but these + -- letters do not have the same encoding as Latin-1. In + -- this mode, these letters are allowed in identifiers + -- with uppercase and lowercase equivalence. + -- + -- PC850 This code page (850) is a modification of 437 extended + -- to include all the Latin-1 letters, but still not with + -- the usual Latin-1 encoding. In this mode, all these + -- letters are allowed in identifiers with uppercase and + -- lower case equivalence. + -- + -- FULL_UPPER Any character in the range 80-FF allowed in + -- identifiers, and all are considered distinct. In + -- other words, there are no uppercase and lower case + -- equivalences in this range. + -- + -- NO_UPPER No upper-half characters in the range 80-FF are + -- allowed in identifiers. This gives Ada 95 + -- compatibility for identifier names. + -- + -- WIDE GNAT allows wide character codes to appear in + -- character and string literals, and also optionally + -- in identifiers. See the /WIDE_CHARACTER_ENCODING + -- qualifier for information on encoding formats. + + S_GCC_IdentX : aliased constant S := "/NOIDENTIFIER_CHARACTER_SET " & + "-gnati1"; + -- NODOC (see /IDENTIFIER_CHARACTER_SET) + + S_GCC_Ignore : aliased constant S := "/IGNORE_REP_CLAUSES " & + "-gnatI"; + -- /IGNORE_REP_CLAUSES + -- + -- Causes all representation clauses to be ignored and treated as + -- comments. Useful when compiling foreign code (for example when ASIS + -- is used to analyze such code). + + S_GCC_Immed : aliased constant S := "/IMMEDIATE_ERRORS " & + "-gnatdO"; + -- /NOIMMEDIATE_ERRORS (D) + -- /IMMEDIATE_ERRORS + -- + -- Causes errors to be displayed as soon as they are encountered, rather + -- than after compilation is terminated. If GNAT terminates prematurely + -- or goes into an infinite loop, the last error message displayed may + -- help to pinpoint the culprit. + + S_GCC_Inline : aliased constant S := "/INLINE=" & + "PRAGMA " & + "-gnatn " & + "FULL " & + "-gnatN " & + "SUPPRESS " & + "-fno-inline"; + -- /NOINLINE (D) + -- /INLINE[=keyword] + -- + -- Selects the level of inlining for your program. In the absence of this + -- qualifier, GNAT does not attempt inlining across units and does not + -- need to access the bodies of subprograms for which "pragma Inline" is + -- specified if they are not in the current unit. + -- + -- The supported keywords are as follows: + -- + -- PRAGMA (D) Recognize and process "Inline" pragmas. However, + -- for the inlining to actually occur, optimization + -- must be enabled. This enables inlining across unit + -- boundaries, that is, inlining a call in one unit of + -- a subprogram declared in a with'ed unit. The compiler + -- will access these bodies, creating an extra source + -- dependency for the resulting object file, and where + -- possible, the call will be inlined. + -- + -- This qualifier also turns on full optimization and + -- requests GNAT to try to attempt automatic inlining + -- of small subprograms within a unit. + -- + -- Specifying /OPTIMIZE=NONE will disable the main effect + -- of this qualifier, but you may specify other + -- optimization options, to get either lower + -- (/OPTIMIZE=SOME) or higher (/OPTIMIZE=UNROLL_LOOPS) + -- levels of optimization. + -- + -- FULL Front end inlining. The front end inlining activated + -- by this switch is generally more extensive, and quite + -- often more effective than the standard PRAGMA inlining + -- mode. It will also generate additional dependencies. + -- + -- SUPPRESS Suppresses all inlining, even if other optimization + -- or inlining switches are set. + + S_GCC_InlineX : aliased constant S := "/NOINLINE " & + "!-gnatn,!-gnatN"; + -- NODOC (see /INLINE) + + S_GCC_Intsrc : aliased constant S := "/INTERSPERSE_SOURCE " & + "-gnatL"; + + -- /NO_INTERSPERSE_SOURCE (D) + -- /INTERSPERSE_SOURCE + -- + -- Causes output from /XDEBUG or /EXPAND_SOURCE to be interspersed with + -- lines from the original source file, output as comment lines with the + -- associated line number. + + S_GCC_Just : aliased constant S := "/JUSTIFY_MESSAGES=#" & + "-gnatj#"; + + -- /NO_JUSTIFY_MESSAGES (D) + -- /JUSTIFY_MESSAGES=nnn + -- + -- Causes error messages to be reformatted so that a message and all its + -- continuation lines count as one warning or error in the statistics on + -- total errors, and the message is broken down into lines (justified) so + -- that no line is longer than nnn characters. The default message + -- behavior (each message counted separately and not reformatted to fit + -- a particular line length) can be obtained using /NO_JUSTIFY_MESSAGES. + + S_GCC_JustX : aliased constant S := "/NO_JUSTIFY_MESSAGES " & + "-gnatj0"; + + -- NODOC (see /JUSTIFY_MESSAGES) + + S_GCC_Length : aliased constant S := "/MAX_LINE_LENGTH=#" & + "-gnatyM#"; + -- /MAX_LINE_LENGTH=nnn + -- + -- Set maximum line length. + -- The length of lines must not exceed the given value nnn. + + S_GCC_List : aliased constant S := "/LIST " & + "-gnatl"; + -- /NOLIST (D) + -- /LIST + -- + -- Cause a full listing of the file to be generated. In the case where + -- a body is compiled, the corresponding spec is also listed, along + -- with any subunits. + + S_GCC_Machine : aliased constant S := "/MACHINE_CODE_LISTING " & + "-source-listing"; + -- /NOMACHINE_CODE_LISTING (D) + -- /MACHINE_CODE_LISTING + -- + -- Cause a full machine code listing of the file to be generated to + -- .lis. Interspersed source is included if the /DEBUG + -- qualifier is also present. + + S_GCC_Mapping : aliased constant S := "/MAPPING_FILE=<" & + "-gnatem>"; + -- /MAPPING_FILE=file_name + -- + -- Use mapping file file_name + -- + -- A mapping file is a way to communicate to the compiler two mappings: + -- from unit names to file names (without any directory information) and + -- from file names to path names (with full directory information). + -- These mappings are used by the compiler to short-circuit the path + -- search. + -- + -- The use of mapping files is not required for correct operation of the + -- compiler, but mapping files can improve efficiency, particularly when + -- sources are read over a slow network connection. In normal operation, + -- you need not be concerned with the format or use of mapping files, + -- and /MAPPING_FILE is not a qualifier that you would use explicitly. + -- It is intended only for use by automatic tools such as GNAT MAKE + -- running under the project file facility. The description here of the + -- format of mapping files is provided for completeness and for possible + -- use by other tools. + -- + -- A mapping file is a sequence of sets of three lines. In each set, the + -- first line is the unit name, in lower case, with "%s" appended for + -- specifications and "%b" appended for bodies; the second line is the + -- file name; and the third line is the path name. + -- + -- Example: + -- + -- main%b + -- main.2_ada + -- /gnat/project1/sources/main.2_ada + -- + -- When qualifier ?MAPPING_FILE is specified, the compiler will create in + -- memory the two mappings from the specified file. If there is any + -- problem (non existent file, truncated file or duplicate entries), + -- no mapping will be created. + -- + -- Several /MAPPING_FILE qualifiers may be specified; however, only the + -- last one on the command line will be taken into account. + -- + -- When using a project file, GNAT MAKE creates a temporary mapping file + -- and communicates it to the compiler using this switch. + + S_GCC_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & + "DEFAULT " & + "-vP0 " & + "MEDIUM " & + "-vP1 " & + "HIGH " & + "-vP2"; + -- /MESSAGES_PROJECT_FILE[=messages-option] + -- + -- Specifies the "verbosity" of the parsing of project files. + -- messages-option may be one of the following: + -- + -- DEFAULT (D) No messages are output if there is no error or warning. + -- + -- MEDIUM A small number of messages are output. + -- + -- HIGH A great number of messages are output, most of them not + -- being useful for the user. + + S_GCC_Nesting : aliased constant S := "/MAX_NESTING=#" & + "-gnatyL#"; + -- /MAX_NESTING=nnn + -- + -- Set maximum level of nesting of constructs (including subprograms, + -- loops, blocks, packages, and conditionals). + -- The level of nesting must not exceed the given value nnn. + -- A value of zero disable this style check (not enabled by default). + + S_GCC_Noadc : aliased constant S := "/NO_GNAT_ADC " & + "-gnatA"; + -- /NO_GNAT_ADC + -- + -- Cause the compiler to ignore any configuration pragmas file GNAT.ADC + -- in the default directory. Implied by qualifier /PROJECT_FILE. + -- Often used in conjunction with qualifier /CONFIGURATION_PRAGMAS_FILE. + + S_GCC_Noload : aliased constant S := "/NOLOAD " & + "-gnatc"; + -- /NOLOAD + -- + -- Cause the compiler to operate in semantic check mode with full + -- checking for all illegalities specified in the reference manual, but + -- without generation of any source code (no object or ALI file + -- generated). + -- + -- Since dependent files must be accessed, you must follow the GNAT + -- semantic restrictions on file structuring to operate in this mode: + -- + -- o The needed source files must be accessible. + -- o Each file must contain only one compilation unit. + -- o The file name and unit name must match. + -- + -- The output consists of error messages as appropriate. No object file + -- or ALI file is generated. The checking corresponds exactly to the + -- notion of legality in the Ada reference manual. + -- + -- Any unit can be compiled in semantics-checking-only mode, including + -- units that would not normally be compiled (generic library units, + -- subunits, and specifications where a separate body is present). + + S_GCC_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & + "-nostdinc"; + -- /NOSTD_INCLUDES + -- + -- Do not look in the default directory for source files of the runtime. + + S_GCC_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " & + "-nostdlib"; + -- /NOSTD_LIBRARIES + -- + -- Do not look for library files in the system default directory. + + S_GCC_NoWarnP : aliased constant S := "/NOWARNING_PRAGMAS " & + "-gnatd.i"; + -- /NOWARNING_PRAGMAS + -- + -- Causes all Warnings pragmas to be ignored. Useful to check if the + -- program has obsolete warnings pragmas that are hiding problems. + + S_GCC_Opt : aliased constant S := "/OPTIMIZE=" & + "ALL " & + "-O2,!-O0,!-O1,!-O3 " & + "NONE " & + "-O0,!-O1,!-O2,!-O3 " & + "SOME " & + "-O1,!-O0,!-O2,!-O3 " & + "SPACE " & + "-Os,!-O0,!-O1,!-O2,!-O3 " & + "DEVELOPMENT " & + "-O1,!-O0,!-O2,!-O3 " & + "UNROLL_LOOPS " & + "-funroll-loops " & + "NO_STRICT_ALIASING " & + "-fno-strict-aliasing " & + "INLINING " & + "-O3,!-O0,!-O1,!-O2"; + -- /NOOPTIMIZE (D) + -- /OPTIMIZE[=(keyword[,...])] + -- + -- Selects the level of optimization for your program. The supported + -- keywords are as follows: + -- + -- ALL (D) Perform most optimizations, including those that + -- may be expensive. + -- + -- NONE Do not do any optimizations. Same as /NOOPTIMIZE. + -- + -- SOME Perform some optimizations, but omit ones that + -- are costly in compilation time. + -- + -- SPACE Optimize space usage + -- + -- DEVELOPMENT Same as SOME. + -- + -- INLINING Full optimization, and also attempt automatic inlining + -- of small subprograms within a unit + -- + -- UNROLL_LOOPS Try to unroll loops. This keyword may be specified + -- with any keyword above other than NONE. Loop + -- unrolling usually, but not always, improves the + -- performance of programs. + -- + -- NO_STRICT_ALIASING + -- Suppress aliasing analysis. When optimization is + -- enabled (ALL or SOME above), the compiler assumes + -- that pointers do in fact point to legitimate values + -- of the pointer type (allocated from the proper pool). + -- If this assumption is violated, e.g. by the use of + -- unchecked conversion, then it may be necessary to + -- suppress this assumption using this keyword (which + -- may be specified only in conjunction with any + -- keyword above, other than NONE). + + S_GCC_OptX : aliased constant S := "/NOOPTIMIZE " & + "-O0,!-O1,!-O2,!-O3"; + -- NODOC (see /OPTIMIZE) + + S_GCC_Output : aliased constant S := "/OUTPUT_FILE=<" & + "-gnatl=>"; + -- /OUTPUT_FILE=fname + -- + -- This has the same effect as /LIST except that the output is written + -- to a file instead of to standard output. If the given fname + -- does not start with a period, then it is the full name of the file + -- to be written. If fname starts with a period, the name of the file + -- is the concatenation of to the name of the file being compiled with + -- fname where the period is replace by an underline. For example, if + -- file xyz.adb is compiled with -gnatl=.lst, then the output is written + -- to file xyz.adb_lst. + + S_GCC_Pointer : aliased constant S := "/POINTER_SIZE=" & + "64 " & + "-mmalloc64 " & + "LONG " & + "-mmalloc64 " & + "32 " & + "-mno-malloc64 " & + "SHORT " & + "-mno-malloc64"; + -- /POINTER_SIZE=64 (D) + -- /POINTER_SIZE[=(keyword[,...])] + -- + -- Change how pointers and descriptors are allocated. The following + -- keywords are supported: + -- + -- 64 (D) Allocate heap pointers in 64bit space except as + -- constrained by a 32bit size clause or by + -- Convention_C and generate 64bit descriptors for + -- Descriptor mechanisms for calling imported + -- subprograms and accept both 64bit and 32bit + -- descriptors for calls to exported subprograms. + -- + -- LONG Equivalent to option 64. + -- + -- 32 Allocate all heap pointers in 32bit space and + -- generate 32bit descriptors for Descriptor + -- mechanisms for calling imported subprograms. + -- + -- SHORT Equivalent to option 32. + + S_GCC_Polling : aliased constant S := "/POLLING " & + "-gnatP"; + -- /NOPOLLING (D) + -- /POLLING + -- + -- Enable polling. See the description of pragma Polling in the GNAT + -- Reference Manual for full details. + + S_GCC_Project : aliased constant S := "/PROJECT_FILE=<" & + "-P>"; + -- /PROJECT_FILE=filename + -- + -- Specifies the main project file to be used. The project files rooted + -- at the main project file will be parsed before the invocation of the + -- compiler. The source and object directories to be searched will be + -- communicated to the compiler through logical names + -- ADA_PRJ_INCLUDE_FILE and ADA_PRJ_OBJECTS_FILE. + + S_GCC_Psta : aliased constant S := "/PRINT_STANDARD " & + "-gnatS"; + -- /PRINT_STANDARD + -- + -- cause the compiler to output a representation of package Standard + -- in a form very close to standard Ada. It is not quite possible to + -- do this and remain entirely Standard (since new numeric base types + -- cannot be created in standard Ada), but the output is easily + -- readable to any Ada programmer, and is useful to determine the + -- characteristics of target dependent types in package Standard. + + S_GCC_Reswarn : aliased constant S := "/TREAT_RESTRICTIONS_AS_WARNINGS " & + "-gnatr"; + + -- /NO_TREAT_RESTRICTIONS_AS_WARNINGS (D) + -- /TREAT_RESTRICTIONS_AS_WARNINGS + -- + -- Causes all restrictions to be treated as warnings (pragma Restriction + -- treated as Restriction_Warnings, pragma Profile as Profile_Warnings, + -- and pragma Ravenscar sets restriction warnings instead of restrictions) + + S_GCC_Report : aliased constant S := "/REPORT_ERRORS=" & + "VERBOSE " & + "-gnatv " & + "BRIEF " & + "-gnatb " & + "FULL " & + "-gnatf " & + "IMMEDIATE " & + "-gnatdO " & + "DEFAULT " & + "!-gnatb,!-gnatv"; + -- /NOREPORT_ERRORS (D) + -- /REPORT_ERRORS[=(keyword[,...])] + -- + -- Change the way errors are reported. The following keywords are + -- supported: + -- + -- VERBOSE (D) Verbose mode. Full error output with source lines + -- to SYS$OUTPUT. + -- + -- BRIEF Generate the brief format error messages to + -- SYS$OUTPUT as well as the verbose format message or + -- full listing. + -- + -- FULL Normally, the compiler suppresses error messages that + -- are likely to be redundant. This keyword causes all + -- error messages to be generated. One particular effect + -- is for the case of references to undefined variables. + -- If a given variable is referenced several times, the + -- normal format of messages produces one error. With + -- FULL, each undefined reference produces a separate + -- error message. + -- + -- IMMEDIATE Normally, the compiler saves up error messages and + -- generates them at the end of compilation in proper + -- sequence. This keyword causes error messages to be + -- generated as soon as they are detected. The use of + -- IMMEDIATE usually causes error messages to be + -- generated out of sequence. Use it when the compiler + -- blows up due to an internal error. In this case, the + -- error messages may be lost. Sometimes blowups are + -- the result of mishandled error messages, so you may + -- want to run with this keyword to determine whether + -- any error messages were generated. + -- + -- DEFAULT Turn off VERBOSE and BRIEF. Same as /NOREPORT_ERRORS. + + S_GCC_ReportX : aliased constant S := "/NOREPORT_ERRORS " & + "!-gnatb,!-gnatv"; + -- NODOC (see /REPORT_ERRORS) + + S_GCC_Repinfo : aliased constant S := "/REPRESENTATION_INFO=" & + "DEFAULT " & + "-gnatR " & + "NONE " & + "-gnatR0 " & + "ARRAYS " & + "-gnatR1 " & + "ARRAYS_FILE " & + "-gnatR1s " & + "OBJECTS " & + "-gnatR2 " & + "OBJECTS_FILE " & + "-gnatR2s " & + "SYMBOLIC " & + "-gnatR3 " & + "SYMBOLIC_FILE " & + "-gnatR3s"; + -- /NOREPRESENTATION_INFO (D) + -- /REPRESENTATION_INFO[=(keyword[,...])] + -- + -- This qualifier controls output from the compiler of a listing showing + -- representation information for declared types and objects. + -- + -- ARRAYS (D) Size and alignment information is listed for + -- declared array and record types. + -- + -- ARRAYS_FILE Similar to ARRAYS, but the output is to a file + -- with the name 'file_rep' where 'file' is the name + -- of the corresponding source file. + -- + -- NONE no information is output (equivalent to omitting + -- the /REPRESENTATION_INFO qualifiers). + -- + -- OBJECTS Size and alignment information is listed for all + -- declared types and objects. + -- + -- OBJECTS_FILE Similar to OBJECTS, but the output is to a file + -- with the name 'file_rep' where 'file' is the name + -- of the corresponding source file. + -- + -- SYMBOLIC Symbolic expression information for values that + -- are computed at run time for variant records. + -- + -- SYMBOLIC_FILE Similar to SYMBOLIC, but the output is to a file + -- with the name 'file_rep' where 'file' is the name + -- of the corresponding source file. + -- + -- DEFAULT Equivalent to ARRAYS. + + S_GCC_RepinfX : aliased constant S := "/NOREPRESENTATION_INFO " & + "!-gnatR"; + -- NODOC (see /REPRESENTATION_INFO) + + S_GCC_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" & + "--RTS=|"; + -- /RUNTIME_SYSTEM=xxx + -- + -- Build against an alternate runtime system named xxx or RTS-xxx. + + S_GCC_SCO : aliased constant S := "/SCO_OUTPUT " & + "-gnateS"; + -- /NOSCO_OUTPUT (D) + -- /SCO_OUTPUT + -- + -- Controls the output of SCO (Source Coverage Obligation) information + -- in the generated ALI file. This information is used by advanced source + -- coverage tools. For a full description of the SCO format, see unit + -- SCOs in the compiler sources (sco.ads/sco.adb). + + S_GCC_Search : aliased constant S := "/SEARCH=*" & + "-I*"; + -- /SEARCH=(directory[,...]) + -- + -- When looking for source files also look in directories specified. + + S_GCC_Src_Info : aliased constant S := "/SRC_INFO=<" & + "--source-info=>"; + -- /SRC_INFO=source-info-file + -- + -- Specify a source info file to be read or written by the Project + -- Manager when project files are used. + + S_GCC_Style : aliased constant S := "/STYLE_CHECKS=" & + "ALL_BUILTIN " & + "-gnatyy " & + "0 " & + "-gnaty0 " & + "1 " & + "-gnaty1 " & + "2 " & + "-gnaty2 " & + "3 " & + "-gnaty3 " & + "4 " & + "-gnaty4 " & + "5 " & + "-gnaty5 " & + "6 " & + "-gnaty6 " & + "7 " & + "-gnaty7 " & + "8 " & + "-gnaty8 " & + "9 " & + "-gnaty9 " & + "ATTRIBUTE " & + "-gnatya " & + "NOATTRIBUTE " & + "-gnaty-a " & + "ARRAY_INDEXES " & + "-gnatyA " & + "NOARRAY_INDEXES " & + "-gnaty-A " & + "BLANKS " & + "-gnatyb " & + "NOBLANKS " & + "-gnaty-b " & + "BOOLEAN_OPERATORS " & + "-gnatyB " & + "NOBOOLEAN_OPERATORS " & + "-gnaty-B " & + "COMMENTS " & + "-gnatyc " & + "NOCOMMENTS " & + "-gnaty-c " & + "DOS_LINE_ENDINGS " & + "-gnatyd " & + "NODOS_LINE_ENDINGS " & + "-gnaty-d " & + "END " & + "-gnatye " & + "NOEND " & + "-gnaty-e " & + "VTABS " & + "-gnatyf " & + "NOVTABS " & + "-gnaty-f " & + "GNAT " & + "-gnatyg " & + "HTABS " & + "-gnatyh " & + "NOHTABS " & + "-gnaty-h " & + "IF_THEN " & + "-gnatyi " & + "NOIF_THEN " & + "-gnaty-i " & + "KEYWORD " & + "-gnatyk " & + "NOKEYWORD " & + "-gnaty-k " & + "LAYOUT " & + "-gnatyl " & + "NOLAYOUT " & + "-gnaty-l " & + "LINE_LENGTH " & + "-gnatym " & + "NOLINE_LENGTH " & + "-gnaty-m " & + "MODE_IN " & + "-gnatyI " & + "NOMODE_IN " & + "-gnaty-I " & + "NONE " & + "-gnatyN " & + "STANDARD_CASING " & + "-gnatyn " & + "NOSTANDARD_CASING " & + "-gnaty-n " & + "ORDERED_SUBPROGRAMS " & + "-gnatyo " & + "NOORDERED_SUBPROGRAMS " & + "-gnaty-o " & + "OVERRIDING_INDICATORS " & + "-gnatyO " & + "NOOVERRIDING_INDICATORS " & + "-gnaty-O " & + "PRAGMA " & + "-gnatyp " & + "NOPRAGMA " & + "-gnaty-p " & + "REFERENCES " & + "-gnatyr " & + "NOREFERENCES " & + "-gnaty-r " & + "SPECS " & + "-gnatys " & + "NOSPECS " & + "-gnaty-s " & + "STATEMENTS_AFTER_THEN_ELSE " & + "-gnatyS " & + "NOSTATEMENTS_AFTER_THEN_ELSE " & + "-gnaty-S " & + "TOKEN " & + "-gnatyt " & + "NOTOKEN " & + "-gnaty-t " & + "UNNECESSARY_BLANK_LINES " & + "-gnatyu " & + "NOUNNECESSARY_BLANK_LINES " & + "-gnaty-u " & + "XTRA_PARENS " & + "-gnaty-x " & + "NOXTRA_PARENS " & + "-gnaty-x "; + -- /NOSTYLE_CHECKS (D) + -- /STYLE_CHECKS[=(keyword,[...])] + -- + -- Normally, GNAT permits any code layout consistent with the reference + -- manual requirements. This qualifier imposes style checking on the + -- input source code. The following keywords are supported: + -- + -- ALL_BUILTIN (D) Equivalent to the following list of options: + -- 3, ATTRIBUTE, BLANKS, COMMENTS, END, VTABS, + -- HTABS, IF_THEN, KEYWORD, LAYOUT, LINE_LENGTH, + -- PRAGMA, REFERENCES, SPECS, TOKEN. + -- + -- 1 .. 9 Specify indentation level from 1 to 9. + -- The general style of required indentation is as + -- specified by the examples in the Ada Reference + -- Manual. Full line comments must be aligned with + -- the -- starting on a column that is a multiple + -- of the alignment level. + -- + -- ATTRIBUTE Check attribute casing. + -- Attribute names, including the case of keywords + -- such as digits used as attributes names, + -- must be written in mixed case, that is, + -- the initial letter and any letter following an + -- underscore must be uppercase. + -- All other letters must be lowercase. + -- + -- ARRAY_INDEXES Check indexes of array attributes. + -- For array attributes First, Last, Range, + -- or Length, the index number must be omitted + -- for one-dimensional arrays and is required + -- for multi-dimensional arrays. + -- + -- BLANKS Blanks not allowed at statement end. + -- Trailing blanks are not allowed at the end of + -- statements. The purpose of this rule, together + -- with option HTABS (no horizontal tabs), is to + -- enforce a canonical format for the use of + -- blanks to separate source tokens. + -- + -- COMMENTS Check comments. + -- Comments must meet the following set of rules: + -- + -- * The "--" that starts the column must either + -- start in column one, or else at least one + -- blank must precede this sequence. + -- + -- * Comments that follow other tokens on a line + -- must have at least one blank following the + -- "--" at the start of the comment. + -- + -- * Full line comments must have two blanks + -- following the "--" that starts the comment, + -- with the following exceptions. + -- + -- * A line consisting only of the "--" + -- characters, possibly preceded by blanks is + -- permitted. + -- + -- * A comment starting with "--x" where x is + -- a special character is permitted. This + -- allows proper processing of the output + -- generated by specialized tools including + -- gnatprep (where --! is used) and the SPARK + -- annotation language (where --# is used). + -- For the purposes of this rule, a special + -- character is defined as being in one of the + -- ASCII ranges 16#21#..16#2F# or + -- 16#3A#..16#3F#. + -- + -- * A line consisting entirely of minus signs, + -- possibly preceded by blanks, is permitted. + -- This allows the construction of box + -- comments where lines of minus signs are + -- used to form the top and bottom of the box. + -- + -- * If a comment starts and ends with "--" is + -- permitted as long as at least one blank + -- follows the initial "--". Together with + -- the preceding rule, this allows the + -- construction of box comments, as shown in + -- the following example: + -- + -- --------------------------- + -- -- This is a box comment -- + -- --------------------------- + -- + -- DOS_LINE_ENDINGS Check that no DOS line terminators are present + -- All lines must be terminated by a single + -- ASCII.LF character. In particular the DOS line + -- terminator sequence CR / LF is not allowed). + -- + -- END Check end/exit labels. + -- Optional labels on end statements ending + -- subprograms and on exit statements exiting + -- named loops, are required to be present. + -- + -- GNAT Enforces a set of style conventions that + -- match the style used in the GNAT source code. + -- This maybe useful when developing code that + -- is eventually intended to be incorporated into + -- GNAT. For further details, see GNAT sources. + -- + -- HTABS No horizontal tabs. + -- Horizontal tab characters are not permitted in + -- the source text. Together with the BLANKS + -- (no blanks at end of line) option, this + -- enforces a canonical form for the use of blanks + -- to separate source tokens. + -- + -- IF_THEN Check if-then layout. + -- The keyword then must appear either on the + -- same line as the corresponding if, or on a line + -- on its own, lined up under the if with at least + -- one non-blank line in between containing all or + -- part of the condition to be tested. + -- + -- KEYWORD Check keyword casing. + -- All keywords must be in lower case (with the + -- exception of keywords such as digits used as + -- attribute names to which this check does not + -- apply). + -- + -- LAYOUT Check layout. + -- Layout of statement and declaration constructs + -- must follow the recommendations in the Ada + -- Reference Manual, as indicated by the form of + -- the syntax rules. For example an else keyword + -- must be lined up with the corresponding if + -- keyword. + -- + -- There are two respects in which the style rule + -- enforced by this check option are more liberal + -- than those in the Ada Reference Manual. + -- First in the case of record declarations, + -- it is permissible to put the record keyword on + -- the same line as the type keyword, and then + -- the end in end record must line up under type. + -- For example, either of the following two + -- layouts is acceptable: + -- + -- type q is record + -- a : integer; + -- b : integer; + -- end record; + -- + -- type q is + -- record + -- a : integer; + -- b : integer; + -- end record; + -- + -- Second, in the case of a block statement, + -- a permitted alternative is to put the block + -- label on the same line as the declare or begin + -- keyword, and then line the end keyword up under + -- the block label. For example both the following + -- are permitted: + -- + -- + -- + -- Block : declare + -- A : Integer := 3; + -- begin + -- Proc (A, A); + -- end Block; + -- + -- Block : + -- declare + -- A : Integer := 3; + -- begin + -- Proc (A, A); + -- end Block; + -- + -- The same alternative format is allowed for + -- loops. For example, both of the following are + -- permitted: + -- + -- + -- + -- Clear : while J < 10 loop + -- A (J) := 0; + -- end loop Clear; + -- + -- Clear : + -- while J < 10 loop + -- A (J) := 0; + -- end loop Clear; + -- + -- + -- + -- LINE_LENGTH Check maximum line length. + -- The length of source lines must not exceed 79 + -- characters, including any trailing blanks + -- The value of 79 allows convenient display on + -- an 80 character wide device or window, allowing + -- for possible special treatment of 80 character + -- lines. + -- + -- NONE Clear any previously set style checks. + -- + -- ORDERED_SUBPROGRAMS Check order of subprogram bodies. + -- All subprogram bodies in a given scope (e.g. + -- a package body) must be in alphabetical order. + -- The ordering rule uses normal Ada rules for + -- comparing strings, ignoring casing of letters, + -- except that if there is a trailing numeric + -- suffix, then the value of this suffix is used + -- in the ordering (e.g. Junk2 comes before + -- Junk10). + -- + -- OVERRIDING_INDICATORS Check that overriding subprograms are + -- explicitly marked as such. The declaration of + -- a primitive operation of a type extension that + -- overrides an inherited operation must carry + -- an overriding indicator. + -- + -- PRAGMA Check pragma casing. + -- Pragma names must be written in mixed case, + -- that is, the initial letter and any letter + -- following an underscore must be uppercase. + -- All other letters must be lowercase. + -- + -- REFERENCES Check references. + -- All identifier references must be cased in the + -- same way as the corresponding declaration. + -- No specific casing style is imposed on + -- identifiers. The only requirement is for + -- consistency of references with declarations. + -- + -- SPECS Check separate specs. + -- Separate declarations ("specs") are required + -- for subprograms (a body is not allowed to serve + -- as its own declaration). The only exception is + -- that parameterless library level procedures are + -- not required to have a separate declaration. + -- This exception covers the most frequent form of + -- main program procedures. + -- + -- STANDARD_CASING Check casing of entities in Standard. + -- Any identifier from Standard must be cased to + -- match the presentation in the Ada Reference + -- Manual (for example, Integer and ASCII.NUL). + -- + -- TOKEN Check token spacing. + -- The following token spacing rules are enforced: + -- + -- * The keywords abs and not must be followed + -- by a space. + -- + -- * The token => must be surrounded by spaces. + -- + -- * The token <> must be preceded by a space or + -- a left parenthesis. + -- + -- * Binary operators other than ** must be + -- surrounded by spaces. There is no + -- restriction on the layout of the ** binary + -- operator. + -- + -- * Colon must be surrounded by spaces. + -- + -- * Colon-equal (assignment) must be surrounded + -- by spaces. + -- + -- * Comma must be the first non-blank character + -- on the line, or be immediately preceded by + -- a non-blank character, and must be followed + -- by a space. + -- + -- * If the token preceding a left paren ends + -- with a letter or digit, then a space must + -- separate the two tokens. + -- + -- * A right parenthesis must either be the + -- first non-blank character on a line, or it + -- must be preceded by a non-blank character. + -- + -- * A semicolon must not be preceded by + -- a space, and must not be followed by + -- a non-blank character. + -- + -- * A unary plus or minus may not be followed + -- by a space. + -- + -- * A vertical bar must be surrounded by + -- spaces. + -- + -- In the above rules, appearing in column one is + -- always permitted, that is, counts as meeting + -- either a requirement for a required preceding + -- space, or as meeting a requirement for no + -- preceding space. + -- + -- Appearing at the end of a line is also always + -- permitted, that is, counts as meeting either + -- a requirement for a following space, + -- or as meeting a requirement for no following + -- space. + -- + -- UNNECESSARY_BLANK_LINES + -- Check for unnecessary blank lines. + -- A blank line is considered unnecessary if it + -- appears at the end of the file, or if more + -- than one blank line occurs in sequence. + -- + -- VTABS No form feeds or vertical tabs. + -- Form feeds or vertical tab characters are not + -- permitted in the source text. + -- + -- XTRA_PARENS Check for the use of an unnecessary extra + -- level of parentheses (C - style) around + -- conditions in if statements, while statements + -- and exit statements. + + S_GCC_StyleX : aliased constant S := "/NOSTYLE_CHECKS " & + "!-gnatg,!-gnaty*"; + -- NODOC (see /STYLE_CHECKS) + + S_GCC_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + + S_GCC_Symbol : aliased constant S := "/SYMBOL_PREPROCESSING=" & '"' & + "-gnateD" & '"'; + -- /SYMBOL_PREPROCESSING="symbol=value" + -- + -- Define or redefine a preprocessing symbol, associated with value. + -- If "=value" is not specified, then the value of the symbol is True. + -- A symbol is an identifier, following normal Ada (case-insensitive) + -- rules for its syntax, and value is any sequence (including an empty + -- sequence) of characters from the set (letters, digits, period, + -- underline). Ada reserved words may be used as symbols, with the + -- exceptions of "if", "else", "elsif", "end", "and", "or" and "then". + -- + -- A symbol declared with this qualifier on the command line replaces + -- a symbol with the same name either in a definition file or specified + -- with a switch -D in the preprocessor data file. + -- + -- This qualifier is similar to qualifier /ASSOCIATE of + -- GNAT PREPROCESSING. + + S_GCC_Syntax : aliased constant S := "/SYNTAX_ONLY " & + "-gnats"; + -- /NOSYNTAX_ONLY (D) + -- /SYNTAX_ONLY + -- + -- Run GNAT in syntax checking only mode. You can check a series of + -- files in a single command, and can use wild cards to specify such a + -- group of files. + -- + -- You may use other qualifiers in conjunction with this qualifier. In + -- particular, /LIST and /REPORT_ERRORS=VERBOSE are useful to control the + -- format of any generated error messages. + -- + -- The output is simply the error messages, if any. No object file or ALI + -- file is generated by a syntax-only compilation. Also, no units other + -- than the one specified are accessed. For example, if a unit "X" with's + -- a unit "Y", compiling unit "X" in syntax check only mode does not + -- access the source file containing unit "Y". + -- + -- Normally, GNAT allows only a single unit in a source file. However, + -- this restriction does not apply in syntax-check-only mode, and it is + -- possible to check a file containing multiple compilation units + -- concatenated together. This is primarily used by the GNAT CHOP + -- command. + + S_GCC_Table : aliased constant S := "/TABLE_MULTIPLIER=#" & + "-gnatT#"; + -- /TABLE_MULTIPLIER=nnn + -- + -- All compiler tables start at nnn times usual starting size. + + S_GCC_Trace : aliased constant S := "/TRACE_UNITS " & + "-gnatdc"; + -- /TRACE_UNITS + -- /NOTRACE_UNITS + -- + -- This switch that does for the frontend what /VERBOSE does for the + -- backend. The system prints the name of each unit, either a compilation + -- unit or nested unit, as it is being analyzed. + + S_GCC_Tree : aliased constant S := "/TREE_OUTPUT " & + "-gnatt"; + -- /TREE_OUTPUT + -- /NOTREE_OUTPUT + -- + -- Cause GNAT to write the internal tree for a unit to a file (with the + -- filetype ATB for a body or ATS for a spec). This is not normally + -- required, but is used by separate analysis tools. Typically these + -- tools do the necessary compilations automatically, so you should never + -- have to specify this switch in normal operation. + + S_GCC_Trys : aliased constant S := "/TRY_SEMANTICS " & + "-gnatq"; + -- /TRY_SEMANTICS + -- /NOTRY_SEMANTICS + -- + -- In normal operation mode the compiler first parses the program and + -- determines if there are any syntax errors. If there are, appropriate + -- error messages are generated and compilation is immediately + -- terminated. This qualifier tells GNAT to continue with semantic + -- analysis even if syntax errors have been found. This may enable the + -- detection of more errors in a single run. On the other hand, the + -- semantic analyzer is more likely to encounter some internal fatal + -- error when given a syntactically invalid tree. + + S_GCC_USL : aliased constant S := "/UNCHECKED_SHARED_LIB_IMPORTS " & + "--unchecked-shared-lib-imports"; + -- /NOUNCHECKED_SHARED_LIB_IMPORTS (D) + -- /UNCHECKED_SHARED_LIB_IMPORTS + -- + -- Allow shared library projects to import static library projects + + S_GCC_Units : aliased constant S := "/UNITS_LIST " & + "-gnatu"; + -- /NOUNITS_LIST (D) + -- /UNITS_LIST + -- + -- Print a list of units required by this compilation on SYS$OUTPUT. The + -- listing includes all units on which the unit being compiled depends + -- either directly or indirectly. + + S_GCC_Unique : aliased constant S := "/UNIQUE_ERROR_TAG " & + "-gnatU"; + -- /NOUNIQUE_ERROR_TAG (D) + -- /UNIQUE_ERROR_TAG + -- + -- Tag compiler error messages with the string "error: ". + + S_GCC_Upcase : aliased constant S := "/UPPERCASE_EXTERNALS " & + "-gnatF"; + -- /NOUPPERCASE_EXTERNALS (D) + -- /UPPERCASE_EXTERNALS + -- + -- Fold default and explicit external names in pragmas Import and Export + -- to uppercase for compatibility with the default behavior of DEC C. + + S_GCC_Valid : aliased constant S := "/VALIDITY_CHECKING=" & + "DEFAULT " & + "-gnatVd " & + "NODEFAULT " & + "-gnatVD " & + "COPIES " & + "-gnatVc " & + "NOCOPIES " & + "-gnatVC " & + "COMPONENTS " & + "-gnatVe " & + "NOCOMPONENTS " & + "-gnatVE " & + "FLOATS " & + "-gnatVf " & + "NOFLOATS " & + "-gnatVF " & + "IN_PARAMS " & + "-gnatVi " & + "NOIN_PARAMS " & + "-gnatVI " & + "MOD_PARAMS " & + "-gnatVm " & + "NOMOD_PARAMS " & + "-gnatVM " & + "OPERANDS " & + "-gnatVo " & + "NOOPERANDS " & + "-gnatVO " & + "PARAMETERS " & + "-gnatVp " & + "NOPARAMETERS " & + "-gnatVP " & + "RETURNS " & + "-gnatVr " & + "NORETURNS " & + "-gnatVR " & + "SUBSCRIPTS " & + "-gnatVs " & + "NOSUBSCRIPTS " & + "-gnatVS " & + "TESTS " & + "-gnatVt " & + "NOTESTS " & + "-gnatVT " & + "ALL " & + "-gnatVa " & + "NONE " & + "-gnatVn"; + -- /VALIDITY_CHECKING[=(keyword,[...])] + -- + -- Control level of validity checking. + -- + -- DEFAULT (D) In this mode checks are made to prevent + -- erroneous behavior in accordance with the RM. + -- Notably extra checks may be needed for case + -- statements and subscripted array assignments. + -- + -- NONE No special checks for invalid values are + -- performed. This means that references to + -- uninitialized variables can cause erroneous + -- behavior from constructs like case statements + -- and subscripted array assignments. In this + -- mode, invalid values can lead to erroneous + -- behavior. + -- + -- FULL Every assignment is checked for validity, so + -- that it is impossible to assign invalid values. + -- The RM specifically allows such assignments, + -- but in this mode, invalid values can never be + -- assigned, and an attempt to perform such an + -- assignment immediately raises Constraint_Error. + -- This behavior is allowed (but not required) by + -- the RM. This mode is intended as a debugging aid, + -- and may be useful in helping to track down + -- uninitialized variables. It may be useful to + -- use this in conjunction with the Normalize_Scalars + -- pragma which attempts to initialize with invalid + -- values where possible. + + S_GCC_Verbose : aliased constant S := "/VERBOSE " & + "-v"; + -- /VERBOSE + -- /NOVERBOSE + -- + -- Show commands generated by the GCC driver. Normally used only for + -- debugging purposes or if you need to be sure what version of the + -- compiler you are executing. + + S_GCC_Verb_Asm : aliased constant S := "/VERBOSE_ASM " & + "-S,-verbose_asm,!-c"; + -- /NOASM (D) + -- /ASM + -- + -- Use to cause the assembler source file to be generated, using S as the + -- filetype, instead of the object file. This may be useful if you need + -- to examine the generated assembly code. + + S_GCC_Warn : aliased constant S := "/WARNINGS=" & + "DEFAULT " & + "!-gnatws,!-gnatwe " & + "ALL " & + "-gnatwa " & + "EVERY " & + "-gnatw.e " & + "OPTIONAL " & + "-gnatwa " & + "NOOPTIONAL " & + "-gnatwA " & + "NOALL " & + "-gnatwA " & + "ALL_GCC " & + "-Wall " & + "FAILING_ASSERTIONS " & + "-gnatw.a " & + "NO_FAILING_ASSERTIONS " & + "-gnatw.A " & + "BAD_FIXED_VALUES " & + "-gnatwb " & + "NO_BAD_FIXED_VALUES " & + "-gnatwB " & + "BIASED_REPRESENTATION " & + "-gnatw.b " & + "NO_BIASED_REPRESENTATION " & + "-gnatw.B " & + "CONDITIONALS " & + "-gnatwc " & + "NOCONDITIONALS " & + "-gnatwC " & + "MISSING_COMPONENT_CLAUSES " & + "-gnatw.c " & + "NOMISSING_COMPONENT_CLAUSES " & + "-gnatw.C " & + "IMPLICIT_DEREFERENCE " & + "-gnatwd " & + "NO_IMPLICIT_DEREFERENCE " & + "-gnatwD " & + "ERRORS " & + "-gnatwe " & + "UNREFERENCED_FORMALS " & + "-gnatwf " & + "NOUNREFERENCED_FORMALS " & + "-gnatwF " & + "UNRECOGNIZED_PRAGMAS " & + "-gnatwg " & + "NOUNRECOGNIZED_PRAGMAS " & + "-gnatwG " & + "HIDING " & + "-gnatwh " & + "NOHIDING " & + "-gnatwH " & + "AVOIDGAPS " & + "-gnatw.h " & + "NOAVOIDGAPS " & + "-gnatw.H " & + "IMPLEMENTATION " & + "-gnatwi " & + "NOIMPLEMENTATION " & + "-gnatwI " & + "OBSOLESCENT " & + "-gnatwj " & + "NOOBSOLESCENT " & + "-gnatwJ " & + "CONSTANT_VARIABLES " & + "-gnatwk " & + "NOCONSTANT_VARIABLES " & + "-gnatwK " & + "ELABORATION " & + "-gnatwl " & + "NOELABORATION " & + "-gnatwL " & + "MODIFIED_UNREF " & + "-gnatwm " & + "NOMODIFIED_UNREF " & + "-gnatwM " & + "SUSPICIOUS_MODULUS " & + "-gnatw.m " & + "NOSUSPICIOUS_MODULUS " & + "-gnatw.M " & + "NORMAL " & + "-gnatwn " & + "OVERLAYS " & + "-gnatwo " & + "NOOVERLAYS " & + "-gnatwO " & + "OUT_PARAM_UNREF " & + "-gnatw.o " & + "NOOUT_PARAM_UNREF " & + "-gnatw.O " & + "INEFFECTIVE_INLINE " & + "-gnatwp " & + "NOINEFFECTIVE_INLINE " & + "-gnatwP " & + "MISSING_PARENS " & + "-gnatwq " & + "PARAMETER_ORDER " & + "-gnatw.p " & + "NOPARAMETER_ORDER " & + "-gnatw.P " & + "NOMISSING_PARENS " & + "-gnatwQ " & + "REDUNDANT " & + "-gnatwr " & + "NOREDUNDANT " & + "-gnatwR " & + "OBJECT_RENAMES " & + "-gnatw.r " & + "NOOBJECT_RENAMES " & + "-gnatw.R " & + "SUPPRESS " & + "-gnatws " & + "OVERRIDING_SIZE " & + "-gnatw.s " & + "NOOVERRIDING_SIZE " & + "-gnatw.S " & + "DELETED_CODE " & + "-gnatwt " & + "NODELETED_CODE " & + "-gnatwT " & + "UNINITIALIZED " & + "-Wuninitialized " & + "UNUSED " & + "-gnatwu " & + "NOUNUSED " & + "-gnatwU " & + "UNORDERED_ENUMERATIONS " & + "-gnatw.u " & + "NOUNORDERED_ENUMERATIONS " & + "-gnatw.U " & + "VARIABLES_UNINITIALIZED " & + "-gnatwv " & + "NOVARIABLES_UNINITIALIZED " & + "-gnatwV " & + "REVERSE_BIT_ORDER " & + "-gnatw.v " & + "NOREVERSE_BIT_ORDER " & + "-gnatw.V " & + "LOWBOUND_ASSUMED " & + "-gnatww " & + "NOLOWBOUND_ASSUMED " & + "-gnatwW " & + "WARNINGS_OFF_PRAGMAS " & + "-gnatw.w " & + "NO_WARNINGS_OFF_PRAGMAS " & + "-gnatw.W " & + "IMPORT_EXPORT_PRAGMAS " & + "-gnatwx " & + "NOIMPORT_EXPORT_PRAGMAS " & + "-gnatwX " & + "LOCAL_RAISE_HANDLING " & + "-gnatw.x " & + "NOLOCAL_RAISE_HANDLING " & + "-gnatw.X " & + "ADA_2005_COMPATIBILITY " & + "-gnatwy " & + "NOADA_2005_COMPATIBILITY " & + "-gnatwY " & + "UNCHECKED_CONVERSIONS " & + "-gnatwz " & + "NOUNCHECKED_CONVERSIONS " & + "-gnatwZ"; + -- /NOWARNINGS + -- + -- Suppress the output of all warning messages from the GNAT front end. + -- Note that it does not suppress warnings from the gcc back end. + -- + -- /WARNINGS[=(keyword[,...])] + -- + -- In addition to error messages, corresponding to illegalities as + -- defined in the reference manual, the compiler detects two kinds of + -- warning situations. First, the compiler considers some constructs + -- suspicious and generates a warning message to alert you to a possible + -- error. Second, if the compiler detects a situation that is sure to + -- raise an exception at runtime, it generates a warning message. + -- + -- You may specify the following keywords to change this behavior: + -- + -- DEFAULT (D) The default behavior above. + -- + -- ALL Activate all optional warnings. + -- Activates most optional warning messages, + -- see remaining list in this section for + -- details on optional warning messages that + -- can be individually controlled. + -- The warnings that are not turned on by + -- this option are BIASED_ROUNDING, + -- IMPLICIT_DEREFERENCE, HIDING and + -- ELABORATION. All other optional Ada + -- warnings are turned on. + -- + -- EVERY Activate every optional warning. + -- Activates all optional warnings, including + -- those listed above as exceptions for ALL. + -- + -- NOALL Suppress all optional errors. + -- Suppresses all optional warning messages + -- that can be activated by option ALL. + -- + -- ALL_GCC Request additional messages from the GCC + -- backend. Most of these are not relevant + -- to Ada. + -- + -- CONDITIONALS Activate warnings for conditional + -- Expressions used in tests that are known + -- to be True or False at compile time. The + -- default is that such warnings are not + -- generated. + -- + -- NOCONDITIONALS Suppress warnings for conditional + -- expressions used in tests that are known + -- to be True or False at compile time. + -- + -- IMPLICIT_DEREFERENCE Activate warnings on implicit dereferencing. + -- The use of a prefix of an access type in an + -- indexed component, slice, or selected component + -- without an explicit .all will generate + -- a warning. With this warning enabled, access + -- checks occur only at points where an explicit + -- .all appears in the source code (assuming no + -- warnings are generated as a result of this + -- option). The default is that such warnings are + -- not generated. Note that /WARNINGS=ALL does not + -- affect the setting of this warning option. + -- + -- NOIMPLICIT_DEREFERENCE Suppress warnings on implicit dereferencing. + -- in indexed components, slices, and selected + -- components. + -- + -- ELABORATION Activate warnings on missing pragma + -- Elaborate_All statements. The default is + -- that such warnings are not generated. + -- + -- NOELABORATION Suppress warnings on missing pragma + -- Elaborate_All statements. + -- + -- ERRORS Warning messages are to be treated as errors. + -- The warning string still appears, but the + -- warning messages are counted as errors, and + -- prevent the generation of an object file. + -- + -- HIDING Activate warnings on hiding declarations. + -- A declaration is considered hiding if it is + -- for a non-overloadable entity, and it declares + -- an entity with the same name as some other + -- entity that is directly or use-visible. The + -- default is that such warnings are not + -- generated. + -- + -- NOHIDING Suppress warnings on hiding declarations. + -- + -- IMPLEMENTATION Activate warnings for a with of an internal + -- GNAT implementation unit, defined as any unit + -- from the Ada, Interfaces, GNAT, DEC or + -- System hierarchies that is not documented in + -- either the Ada Reference Manual or the GNAT + -- Programmer's Reference Manual. Such units are + -- intended only for internal implementation + -- purposes and should not be with'ed by user + -- programs. The default is that such warnings + -- are generated. + -- + -- NOIMPLEMENTATION Disables warnings for a with of an internal + -- GNAT implementation unit. + -- + -- INEFFECTIVE_INLINE Activate warnings on ineffective pragma Inlines + -- Activates warnings for failure of front end + -- inlining (activated by /INLINE=FULL) to inline + -- a particular call. There are many reasons for + -- not being able to inline a call, including most + -- commonly that the call is too complex to + -- inline. This warning can also be turned on + -- using /INLINE=FULL. + -- + -- NOINEFFECTIVE_INLINE Suppress warnings on ineffective pragma Inlines + -- Suppresses warnings on ineffective pragma + -- Inlines. If the inlining mechanism cannot + -- inline a call, it will simply ignore the + -- request silently. + -- + -- MISSING_COMPONENT_CLAUSES + -- Activate warnings for cases when there are + -- component clauses for a record type, but not + -- for every component of the record. + -- + -- NOMISSING_COMPONENT_CLAUSES + -- Suppress warnings for cases when there are + -- missing component clauses for a record type. + -- + -- MISSING_PARENS + -- Activate warnings for cases where parentheses + -- are not used and the result is potential + -- ambiguity from a reader's point of view. + -- For example (not a > b) when a and b are + -- modular means (not (a) > b) and very likely + -- the programmer intended (not (a > b)). + -- + -- NOMISSING_PARENS + -- Suppress warnings for cases where parentheses + -- are not used and the result is potential + -- ambiguity from a reader's point of view. + -- + -- MODIFIED_UNREF Activates warnings for variables that are + -- assigned (using an initialization value or with + -- one or more assignment statements) but whose + -- value is never read. The warning is suppressed + -- for volatile variables and also for variables + -- that are renamings of other variables or for + -- which an address clause is given. This warning + -- can also be turned on using /WARNINGS/OPTIONAL. + -- + -- NOMODIFIED_UNREF Disables warnings for variables that are + -- assigned or initialized, but never read. + -- + -- NORMAL Sets normal warning mode, in which enabled + -- warnings are issued and treated as warnings + -- rather than errors. This is the default mode. + -- It can be used to cancel the effect of an + -- explicit /WARNINGS=SUPPRESS or + -- /WARNINGS=ERRORS. It also cancels the effect + -- of the implicit /WARNINGS=ERRORS that is + -- activated by the use of /STYLE=GNAT. + -- + -- OBSOLESCENT Activates warnings for calls to subprograms + -- marked with pragma Obsolescent and for use of + -- features in Annex J of the Ada Reference + -- Manual. In the case of Annex J, not all + -- features are flagged. In particular use of the + -- renamed packages (like Text_IO), use of package + -- ASCII and use of the attribute 'Constrained are + -- not flagged, since these are very common and + -- would generate many annoying positive warnings. + -- The default is that such warnings are not + -- generated. + -- + -- NOOBSOLESCENT Disables warnings on use of obsolescent + -- features. + -- + -- OBJECT_RENAME Activate warnings for non limited objects + -- renaming parameterless functions. + -- + -- NOOBJECT_RENAME Suppress warnings for non limited objects + -- renaming parameterless functions. + -- + -- OPTIONAL Equivalent to ALL. + -- + -- NOOPTIONAL Equivalent to NOALL. + -- + -- OVERLAYS Activate warnings for possibly unintended + -- initialization effects of defining address + -- clauses that cause one variable to overlap + -- another. The default is that such warnings + -- are generated. + -- + -- NOOVERLAYS Suppress warnings on possibly unintended + -- initialization effects of defining address + -- clauses that cause one variable to overlap + -- another. + -- + -- REDUNDANT Activate warnings for redundant constructs. + -- In particular assignments of a variable to + -- itself, and a type conversion that converts + -- an object to its own type. The default + -- is that such warnings are not generated. + -- + -- NOREDUNDANT Suppress warnings for redundant constructs. + -- + -- SUPPRESS Completely suppress the output of all warning + -- messages. Same as /NOWARNINGS. + -- + -- UNCHECKED_CONVERSIONS Activates warnings on unchecked conversions. + -- Causes warnings to be generated for + -- unchecked conversions when the two types are + -- known at compile time to have different sizes. + -- The default is that such warnings are + -- generated. + -- + -- NOUNCHECKED_CONVERSIONS Suppress warnings for unchecked conversions. + -- + -- UNINITIALIZED Generate warnings for uninitialized variables. + -- This is a GCC option, not an Ada option. + -- You must also specify the /OPTIMIZE qualifier + -- with a value other than NONE (in other words, + -- this keyword works only if optimization is + -- turned on). + -- + -- UNREFERENCED_FORMALS Activate warnings on unreferenced formals. + -- Causes a warning to be generated if a formal + -- parameter is not referenced in the body of + -- the subprogram. This warning can also be turned + -- on using option ALL or UNUSED. + -- + -- NOUNREFERENCED_FORMALS Suppress warnings on unreferenced formals. + -- Suppresses warnings for unreferenced formal + -- parameters. Note that the combination UNUSED + -- followed by NOUNREFERENCED_FORMALS has the + -- effect of warning on unreferenced entities + -- other than subprogram formals. + -- + -- UNUSED Activates warnings to be generated for entities + -- that are defined but not referenced, and for + -- units that are with'ed and not referenced. In + -- the case of packages, a warning is also + -- generated if no entities in the package are + -- referenced. This means that if the package + -- is referenced but the only references are in + -- use clauses or renames declarations, a warning + -- is still generated. A warning is also generated + -- for a generic package that is with'ed but never + -- instantiated. In the case where a package or + -- subprogram body is compiled, and there is a + -- with on the corresponding spec that is only + -- referenced in the body, a warning is also + -- generated, noting that the with can be moved + -- to the body. The default is that such warnings + -- are not generated. + -- + -- NOUNUSED Suppress warnings for unused entities and + -- packages. + -- + -- VARIABLES_UNINITIALIZED Activates warnings on unassigned variables. + -- Causes warnings to be generated when a variable + -- is accessed which may not be properly + -- uninitialized. + -- The default is that such warnings are + -- generated. + -- + -- NOVARIABLES_UNINITIALIZED Suppress warnings for uninitialized + -- variables. + + S_GCC_WarnX : aliased constant S := "/NOWARNINGS " & + "-gnatws"; + -- NODOC (see /WARNINGS) + + S_GCC_No_Back : aliased constant S := "/NO_BACK_END_WARNINGS " & + "-w"; + -- /NO_BACK_END_WARNINGS + -- + -- Inhibit all warning messages of the GCC back-end. + + S_GCC_All_Back : aliased constant S := "/ALL_BACK_END_WARNINGS " & + "-Wall"; + -- /ALL_BACK_END_WARNINGS + -- + -- Activate all warning messages of the GCC back-end. + + S_GCC_Wide : aliased constant S := "/WIDE_CHARACTER_ENCODING=" & + "BRACKETS " & + "-gnatWb " & + "HEX " & + "-gnatWh " & + "UPPER " & + "-gnatWu " & + "SHIFT_JIS " & + "-gnatWs " & + "UTF8 " & + "-gnatW8 " & + "EUC " & + "-gnatWe"; + -- /NOWIDE_CHARACTER_ENCODING (D) + -- /WIDE_CHARACTER_ENCODING[=encode-type] + -- + -- Specifies the mechanism used to encode wide characters. 'encode-type' + -- is one of the following: + -- + -- BRACKETS (D) A wide character is encoded as ["xxxx"] where XXXX + -- are four hexadecimal digits representing the coding + -- ('Pos value) of the character in type + -- Wide_Character. The hexadecimal digits may use upper + -- or lower case letters. + -- + -- This notation can also be used for upper half + -- Character values using the format ["xx"] where XX is + -- two hexadecimal digits representing the coding ('Pos + -- value) of the character in type Character (or + -- Wide_Character). The hexadecimal digits may use upper + -- of lower case. + -- + -- NONE No wide characters are allowed. Same + -- as /NOWIDE_CHARACTER_ENCODING. + -- + -- HEX In this encoding, a wide character is represented by + -- the following five character sequence: ESC a b c d + -- Where 'a', 'b', 'c', and 'd' are the four hexadecimal + -- characters (using uppercase letters) of the wide + -- character code. For example, ESC A345 is used to + -- represent the wide character with code 16#A345#. This + -- scheme is compatible with use of the full + -- Wide_Character set. + -- + -- UPPER The wide character with encoding 16#abcd# where the + -- upper bit is on (in other words, "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. + -- + -- SHIFT_JIS 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. Only characters defined in the + -- JIS code set table can be used with this encoding + -- method. + -- + -- UTF8 A wide character is represented using + -- UCS Transformation Format 8 (UTF-8) as defined in Annex + -- R of ISO 10646-1/Am.2. Depending on the character + -- value, the representation is a one, two, or three byte + -- sequence: + -- + -- 16#0000#-16#007f#: 2#0xxxxxxx# + -- 16#0080#-16#07ff#: 2#110xxxxx# 2#10xxxxxx# + -- 16#0800#-16#ffff#: 2#1110xxxx# 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 (The full + -- UTF-8 scheme allows for encoding 31-bit characters as + -- 6-byte sequences, but in this implementation, all UTF-8 + -- sequences of four or more bytes length will be treated + -- as illegal). + -- + -- EUC A wide character is represented by a two-character + -- sequence 16#ab# and 16#cd#, with both characters being + -- in the upper half. The internal character code is the + -- corresponding JIS character according to the EUC + -- encoding algorithm. Only characters defined in the JIS + -- code set table can be used with this encoding method. + + S_GCC_WideX : aliased constant S := "/NOWIDE_CHARACTER_ENCODING " & + "-gnatWn"; + -- NODOC (see /WIDE_CHARACTER_ENCODING) + + S_GCC_Xdebug : aliased constant S := "/XDEBUG " & + "-gnatD"; + -- /NOXDEBUG (D) + -- /XDEBUG + -- + -- Output expanded source files for source level debugging. + -- The expanded source (see /EXPAND_SOURCE) is written to files + -- with names formed by appending "_DG" to the input file name, + -- The debugging information generated by the /DEBUG qualifier will then + -- refer to the generated file. This allows source level debugging using + -- the generated code which is sometimes useful for complex code, for + -- example to find out exactly which part of a complex construction + -- raised an exception. The maximum line length for the output is 72. + + S_GCC_Lxdebug : aliased constant S := "/LXDEBUG=#" & + "-gnatD=#"; + -- /LXDEBUG=nnn + -- + -- Output expanded source files for source level debugging. + -- The expanded source (see /EXPAND_SOURCE) is written to files + -- with names formed by appending "_DG" to the input file name, + -- The debugging information generated by the /DEBUG qualifier will then + -- refer to the generated file. This allows source level debugging using + -- the generated code which is sometimes useful for complex code, for + -- example to find out exactly which part of a complex construction + -- raised an exception. The parameter is the maximum line length for + -- the output. + + S_GCC_Xref : aliased constant S := "/XREF=" & + "GENERATE " & + "!-gnatx " & + "SUPPRESS " & + "-gnatx"; + -- /XREF[=keyword] + -- + -- Normally the compiler generates full cross-referencing information in + -- the .ALI file. This information is used by a number of tools, + -- including GNAT FIND and GNAT XREF. + -- + -- GENERATE (D) Generate cross-referencing information. + -- + -- SUPPRESS Suppress cross-referencing information. + -- This saves some space and may slightly + -- speed up compilation, but means that some + -- tools cannot be used. + + GCC_Switches : aliased constant Switches := + (S_GCC_Ada_83 'Access, + S_GCC_Ada_95 'Access, + S_GCC_Ada_05 'Access, + S_GCC_Ada_2005'Access, + S_GCC_Ada_12 'Access, + S_GCC_Ada_2012'Access, + S_GCC_Add 'Access, + S_GCC_Asm 'Access, + S_GCC_AValid 'Access, + S_GCC_Checks 'Access, + S_GCC_ChecksX 'Access, + S_GCC_Compres 'Access, + S_GCC_Config 'Access, + S_GCC_Current 'Access, + S_GCC_Debug 'Access, + S_GCC_DebugX 'Access, + S_GCC_Data 'Access, + S_GCC_Dist 'Access, + S_GCC_DistX 'Access, + S_GCC_Error 'Access, + S_GCC_ErrorX 'Access, + S_GCC_Expand 'Access, + S_GCC_Lexpand 'Access, + S_GCC_Except 'Access, + S_GCC_Extend 'Access, + S_GCC_Ext 'Access, + S_GCC_File 'Access, + S_GCC_Follow 'Access, + S_GCC_Force 'Access, + S_GCC_Full 'Access, + S_GCC_Generate'Access, + S_GCC_GNAT 'Access, + S_GCC_Help 'Access, + S_GCC_Ident 'Access, + S_GCC_IdentX 'Access, + S_GCC_Ignore 'Access, + S_GCC_Immed 'Access, + S_GCC_Inline 'Access, + S_GCC_InlineX 'Access, + S_GCC_Intsrc 'Access, + S_GCC_Just 'Access, + S_GCC_JustX 'Access, + S_GCC_Length 'Access, + S_GCC_List 'Access, + S_GCC_Output 'Access, + S_GCC_Machine 'Access, + S_GCC_Mapping 'Access, + S_GCC_Mess 'Access, + S_GCC_Nesting 'Access, + S_GCC_Noadc 'Access, + S_GCC_Noload 'Access, + S_GCC_Nostinc 'Access, + S_GCC_Nostlib 'Access, + S_GCC_NoWarnP 'Access, + S_GCC_Opt 'Access, + S_GCC_OptX 'Access, + S_GCC_Pointer 'Access, + S_GCC_Polling 'Access, + S_GCC_Project 'Access, + S_GCC_Psta 'Access, + S_GCC_Report 'Access, + S_GCC_ReportX 'Access, + S_GCC_Repinfo 'Access, + S_GCC_RepinfX 'Access, + S_GCC_RTS 'Access, + S_GCC_SCO 'Access, + S_GCC_Search 'Access, + S_GCC_Src_Info'Access, + S_GCC_Style 'Access, + S_GCC_StyleX 'Access, + S_GCC_Subdirs 'Access, + S_GCC_Symbol 'Access, + S_GCC_Syntax 'Access, + S_GCC_Table 'Access, + S_GCC_Trace 'Access, + S_GCC_Tree 'Access, + S_GCC_Trys 'Access, + S_GCC_USL 'Access, + S_GCC_Units 'Access, + S_GCC_Unique 'Access, + S_GCC_Upcase 'Access, + S_GCC_Valid 'Access, + S_GCC_Verbose 'Access, + S_GCC_Verb_Asm'Access, + S_GCC_Warn 'Access, + S_GCC_WarnX 'Access, + S_GCC_Wide 'Access, + S_GCC_WideX 'Access, + S_GCC_No_Back 'Access, + S_GCC_All_Back'Access, + S_GCC_Xdebug 'Access, + S_GCC_Lxdebug 'Access, + S_GCC_Xref 'Access); + + ---------------------------- + -- Switches for GNAT ELIM -- + ---------------------------- + + S_Elim_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & + "-aP*"; + -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) + -- + -- Add directories to the project search path. + + S_Elim_All : aliased constant S := "/ALL " & + "-a"; + -- /NOALL (D) + -- /ALL + -- + -- Also look for subprograms from the GNAT run time that can be + -- eliminated. Note that when 'gnat.adc' is produced using this switch, + -- the entire program must be recompiled with qualifier /ALL_FILES of + -- GNAT MAKE. + + S_Elim_Bind : aliased constant S := "/BIND_FILE=<" & + "-b>"; + -- /BIND_FILE=file_name + -- + -- Specifies file_name as the bind file to process. If this qualifier is + -- not used, the name of the bind file is computed from the full expanded + -- Ada name of a main subprogram. + + S_Elim_Comp : aliased constant S := "/COMPILER=@" & + "--GCC=@"; + -- /COMPILER=path_name + -- + -- Instructs GNAT ELIM to use a specific gcc compiler instead of one + -- available on the path. + + S_Elim_Config : aliased constant S := "/CONFIGURATION_PRAGMAS=<" & + "-C>"; + -- /CONFIGURATION_PRAGMAS=path_name + -- + -- Specifies a file that contains configuration pragmas. + -- The file must be specified with absolute path. + + S_Elim_Current : aliased constant S := "/CURRENT_DIRECTORY " & + "!-I-"; + -- /CURRENT_DIRECTORY (D) + -- /NOCURRENT_DIRECTORY + -- + -- Look for source files in the default directory. + + S_Elim_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & + "-X" & '"'; + -- /EXTERNAL_REFERENCE="name=val" + -- + -- Specifies an external reference to the project manager. Useful only if + -- /PROJECT_FILE is used. + -- + -- Example: + -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + + S_Elim_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + + S_Elim_GNATMAKE : aliased constant S := "/GNATMAKE=@" & + "--GNATMAKE=@"; + -- /GNATMAKE=path_name + -- + -- Instructs GNAT MAKE to use a specific gnatmake instead of one available + -- on the path. + + S_Elim_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & + "DEFAULT " & + "-vP0 " & + "MEDIUM " & + "-vP1 " & + "HIGH " & + "-vP2"; + -- /MESSAGES_PROJECT_FILE[=messages-option] + -- + -- Specifies the "verbosity" of the parsing of project files. + -- messages-option may be one of the following: + -- + -- DEFAULT (D) No messages are output if there is no error or warning. + -- + -- MEDIUM A small number of messages are output. + -- + -- HIGH A great number of messages are output, most of them not + -- being useful for the user. + + S_Elim_Nodisp : aliased constant S := "/NO_DISPATCH " & + "--no-elim-dispatch"; + -- /NONO_DISPATCH (D) + -- /NO_DISPATCH + -- + -- Do not generate pragmas for dispatching operations. + + S_Elim_Ignore : aliased constant S := "/IGNORE=@" & + "--ignore=@"; + -- /IGNORE=filename + -- + -- Do not generate pragmas for subprograms declared in the sources + -- listed in a specified file + + S_Elim_Project : aliased constant S := "/PROJECT_FILE=<" & + "-P>"; + -- /PROJECT_FILE=filename + -- + -- Specifies the main project file to be used. The project files rooted + -- at the main project file will be parsed before the invocation of the + -- gnatelim. The source directories to be searched will be communicated + -- to gnatelim through logical name ADA_PRJ_INCLUDE_FILE. + + S_Elim_Quiet : aliased constant S := "/QUIET " & + "-q"; + -- /NOQUIET (D) + -- /QUIET + -- + -- Quiet mode: by default GNAT ELIM outputs to the standard error stream + -- the number of program units left to be processed. This option turns + -- this trace off. + + S_Elim_Files : aliased constant S := "/FILES=@" & + "-files=@"; + + -- /FILES=filename + -- + -- Take as arguments the files that are listed in the specified + -- text file. + + S_Elim_Log : aliased constant S := "/LOG " & + "-l"; + -- /NOLOG (D) + -- /LOG + -- + -- Duplicate all the output sent to Stderr into a default log file. + + S_Elim_Logfile : aliased constant S := "/LOGFILE=@" & + "-l@"; + + -- /LOGFILE=logfilename + -- + -- Duplicate all the output sent to Stderr into a specified log file. + + S_Elim_Main : aliased constant S := "/MAIN=@" & + "-main=@"; + + -- /MAIN=filename + -- + -- Specify the main subprogram of the partition to analyse. + + S_Elim_Out : aliased constant S := "/OUTPUT=@" & + "-o@"; + -- /OUTPUT=filename + -- + -- Specify the name of the output file. + + S_Elim_Time : aliased constant S := "/TIME " & + "-t"; + -- /NOTIME (D) + -- /TIME + -- + -- Print out execution time + + S_Elim_Search : aliased constant S := "/SEARCH=*" & + "-I*"; + -- /SEARCH=(directory, ...) + -- + -- When looking for source files also look in the specified directories. + + S_Elim_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + + S_Elim_Verb : aliased constant S := "/VERBOSE " & + "-v"; + -- /NOVERBOSE (D) + -- /VERBOSE + -- + -- Verbose mode: GNAT ELIM version information is output as Ada comments + -- to the standard output stream. Also, in addition to the number of + -- program units left, GNAT ELIM will output the name of the current unit + -- being processed. + + S_Elim_Warn : aliased constant S := "/WARNINGS=" & + "NORMAL " & + "-wn " & + "QUIET " & + "-ws"; + + -- /WARNINGS[=(keyword[,...])] + -- + -- The following keywords are supported: + -- + -- NORMAL (D) Print warning all the messages. + -- QUIET Some warning messages are suppressed + + Elim_Switches : aliased constant Switches := + (S_Elim_Add 'Access, + S_Elim_All 'Access, + S_Elim_Bind 'Access, + S_Elim_Comp 'Access, + S_Elim_Config 'Access, + S_Elim_Current 'Access, + S_Elim_Ext 'Access, + S_Elim_Files 'Access, + S_Elim_Follow 'Access, + S_Elim_GNATMAKE'Access, + S_Elim_Log 'Access, + S_Elim_Logfile 'Access, + S_Elim_Main 'Access, + S_Elim_Mess 'Access, + S_Elim_Nodisp 'Access, + S_Elim_Out 'Access, + S_Elim_Project 'Access, + S_Elim_Quiet 'Access, + S_Elim_Search 'Access, + S_Elim_Subdirs 'Access, + S_Elim_Time 'Access, + S_Elim_Verb 'Access, + S_Elim_Warn 'Access); + + ---------------------------- + -- Switches for GNAT FIND -- + ---------------------------- + + S_Find_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & + "-aP*"; + -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) + -- + -- Add directories to the project search path. + + S_Find_All : aliased constant S := "/ALL_FILES " & + "-a"; + -- /NOALL_FILES (D) + -- /ALL_FILES + -- + -- If this switch is present, FIND and XREF will parse the read-only + -- files found in the library search path. Otherwise, these files will + -- be ignored. This option can be used to protect Gnat sources or your + -- own libraries from being parsed, thus making FIND and XREF much + -- faster, and their output much smaller. + + S_Find_Deriv : aliased constant S := "/DERIVED_TYPE_INFORMATION " & + "-d"; + -- /NODERIVED_TYPE_INFORMATION (D) + -- /DERIVED_TYPE_INFORMATION + -- + -- Output the parent type reference for each matching derived types. + + S_Find_Expr : aliased constant S := "/EXPRESSIONS " & + "-e"; + -- /NOEXPRESSIONS (D) + -- /EXPRESSIONS + -- + -- By default, FIND accepts the simple regular expression set for pattern. + -- If this switch is set, then the pattern will be considered as a full + -- Unix-style regular expression. + + S_Find_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & + "-X" & '"'; + -- /EXTERNAL_REFERENCE="name=val" + -- + -- Specifies an external reference to the project manager. Useful only if + -- /PROJECT_FILE is used. + -- + -- Example: + -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + + S_Find_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + + S_Find_Full : aliased constant S := "/FULL_PATHNAME " & + "-f"; + -- /NOFULL_PATHNAME (D) + -- /FULL_PATHNAME + -- + -- If this switch is set, the output file names will be preceded by their + -- directory (if the file was found in the search path). If this switch + -- is not set, the directory will not be printed. + + S_Find_Ignore : aliased constant S := "/IGNORE_LOCALS " & + "-g"; + -- /NOIGNORE_LOCALS (D) + -- /IGNORE_LOCALS + -- + -- If this switch is set, information is output only for library-level + -- entities, ignoring local entities. The use of this switch may + -- accelerate FIND and XREF. + + S_Find_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & + "DEFAULT " & + "-vP0 " & + "MEDIUM " & + "-vP1 " & + "HIGH " & + "-vP2"; + -- /MESSAGES_PROJECT_FILE[=messages-option] + -- + -- Specifies the "verbosity" of the parsing of project files. + -- messages-option may be one of the following: + -- + -- DEFAULT (D) No messages are output if there is no error or warning. + -- + -- MEDIUM A small number of messages are output. + -- + -- HIGH A great number of messages are output, most of them not + -- being useful for the user. + + S_Find_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & + "-nostdinc"; + -- /NOSTD_INCLUDES + -- + -- Do not look for sources in the system default directory. + + S_Find_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " & + "-nostdlib"; + -- /NOSTD_LIBRARIES + -- + -- Do not look for library files in the system default directory. + + S_Find_Object : aliased constant S := "/OBJECT_SEARCH=*" & + "-aO*"; + -- /OBJECT_SEARCH=(directory,...) + -- + -- When searching for library and object files, look in the specified + -- directories. The order in which library files are searched is the same + -- as for MAKE. + + S_Find_Print : aliased constant S := "/PRINT_LINES " & + "-s"; + -- /NOPRINT_LINES (D) + -- /PRINT_LINES + -- + -- Output the content of the Ada source file lines were the entity was + -- found. + + S_Find_Project : aliased constant S := "/PROJECT=@" & + "-p@"; + -- /PROJECT=file + -- + -- Specify a project file to use. By default, FIND and XREF will try to + -- locate a project file in the current directory. + -- + -- If a project file is either specified or found by the tools, then the + -- content of the source directory and object directory lines are added + -- as if they had been specified respectively by /SOURCE_SEARCH and + -- /OBJECT_SEARCH. + -- + -- This qualifier is not compatible with /PROJECT_FILE + + S_Find_Prj : aliased constant S := "/PROJECT_FILE=<" & + "-P>"; + -- /PROJECT_FILE=filename + -- + -- Specifies the main project file to be used. The project files rooted + -- at the main project file will be parsed before looking for sources. + -- The source and object directories to be searched will be communicated + -- to gnatfind through logical names ADA_PRJ_INCLUDE_FILE and + -- ADA_PRJ_OBJECTS_FILE. + + S_Find_Ref : aliased constant S := "/REFERENCES " & + "-r"; + -- /NOREFERENCES (D) + -- /REFERENCES + -- + -- By default, FIND will output only the information about the + -- declaration, body or type completion of the entities. If this switch + -- is set, the FIND will locate every reference to the entities in the + -- files specified on the command line (or in every file in the search + -- path if no file is given on the command line). + + S_Find_Search : aliased constant S := "/SEARCH=*" & + "-I*"; + -- /SEARCH=(directory,...) + -- + -- Equivalent to: + -- /OBJECT_SEARCH=(directory,...) /SOURCE_SEARCH=(directory,...) + + S_Find_Source : aliased constant S := "/SOURCE_SEARCH=*" & + "-aI*"; + -- /SOURCE_SEARCH=(directory,...) + -- + -- When looking for source files also look in the specified directories. + -- The order in which source file search is undertaken is the same as for + -- MAKE. + + S_Find_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + + S_Find_Types : aliased constant S := "/TYPE_HIERARCHY " & + "-t"; + -- /NOTYPE_HIERARCHY (D) + -- /TYPE_HIERARCHY + -- + -- Output the type hierarchy for the specified type. It acts like the + -- /DERIVED_TYPE_INFORMATION qualifier, but recursively from parent type + -- to parent type. When this qualifier is specified it is not possible to + -- specify more than one file. + + Find_Switches : aliased constant Switches := + (S_Find_Add 'Access, + S_Find_All 'Access, + S_Find_Deriv 'Access, + S_Find_Expr 'Access, + S_Find_Ext 'Access, + S_Find_Follow 'Access, + S_Find_Full 'Access, + S_Find_Ignore 'Access, + S_Find_Mess 'Access, + S_Find_Nostinc 'Access, + S_Find_Nostlib 'Access, + S_Find_Object 'Access, + S_Find_Print 'Access, + S_Find_Project 'Access, + S_Find_Prj 'Access, + S_Find_Ref 'Access, + S_Find_Search 'Access, + S_Find_Source 'Access, + S_Find_Subdirs 'Access, + S_Find_Types 'Access); + + ------------------------------ + -- Switches for GNAT KRUNCH -- + ------------------------------ + + S_Krunch_Count : aliased constant S := "/COUNT=#" & + "`#"; + -- /COUNT=39 (D) + -- /COUNT=nnn + -- + -- Limit file names to nnn characters (where nnn is a decimal + -- integer). The maximum file name length is 39, but if you want to + -- generate a set of files that would be usable if ported to a system + -- with some different maximum file length, then a different value can + -- be specified. + + Krunch_Switches : aliased constant Switches := + (1 .. 1 => S_Krunch_Count 'Access); + + ---------------------------- + -- Switches for GNAT LINK -- + ---------------------------- + + S_Link_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & + "-aP*"; + -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) + -- + -- Add directories to the project search path. + + S_Link_Bind : aliased constant S := "/BIND_FILE=" & + "ADA " & + "-A " & + "C " & + "-C"; + -- /BIND_FILE=[bind-file-option] + -- + -- Specifies the language of the binder generated file. + -- + -- ADA (D) Binder file is Ada. + -- + -- C Binder file is 'C'. + + S_Link_Debug : aliased constant S := "/DEBUG=" & + "ALL " & + "-g3 " & + "NONE " & + "-g0 " & + "TRACEBACK " & + "-g1 " & + "NOTRACEBACK " & + "-g0"; + -- /NODEBUG (D) + -- /DEBUG[=debug-option] + -- + -- Specifies the amount of debugging information included. 'debug-option' + -- is one of the following: + -- + -- ALL (D) Include full debugging information. + -- + -- NONE Provide no debugging information. Same as /NODEBUG. + -- + -- TRACEBACK Provide sufficient debug information for a traceback. + -- + -- NOTRACEBACK Same as NONE. + + S_Link_Nodebug : aliased constant S := "/NODEBUG " & + "-g0"; + -- NODOC (see /DEBUG) + + S_Link_Execut : aliased constant S := "/EXECUTABLE=@" & + "-o@"; + -- /EXECUTABLE=exec-name + -- + -- 'exec-name' specifies an alternative name for the generated executable + -- program. If this qualifier switch is omitted, the executable is called + -- the name of the main unit. So "$ GNAT LINK TRY.ALI" creates an + -- executable called TRY.EXE. + + S_Link_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & + "-X" & '"'; + -- /EXTERNAL_REFERENCE="name=val" + -- + -- Specifies an external reference to the project manager. Useful only if + -- /PROJECT_FILE is used. + -- + -- Example: + -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + + S_Link_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + + S_Link_Forlink : aliased constant S := "/FOR_LINKER=" & '"' & + "--for-linker=" & '"'; + -- /FOR_LINKER= + -- + -- Transmit the option to the underlying linker. + + S_Link_Force : aliased constant S := "/FORCE_OBJECT_FILE_LIST " & + "-f"; + -- /NOFORCE_OBJECT_FILE_LIST (D) + -- /FORCE_OBJECT_FILE_LIST + -- + -- Forces the generation of a file that contains commands for the linker. + -- This is useful in some cases to deal with special situations where the + -- command line length is exceeded. + + S_Link_Ident : aliased constant S := "/IDENTIFICATION=" & '"' & + "--for-linker=IDENT=" & + '"'; + -- /IDENTIFICATION="" + -- + -- "" specifies the string to be stored in the image file ident- + -- ification field in the image header. It overrides any pragma Ident + -- specified string. + + S_Link_Libdir : aliased constant S := "/LIBDIR=*" & + "-L*"; + -- /LIBDIR=(directory, ...) + -- + -- Look for libraries in the specified directories. + + S_Link_Library : aliased constant S := "/LIBRARY=|" & + "-l|"; + -- /LIBRARY=xyz + -- + -- Link with library named "xyz". + + S_Link_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & + "DEFAULT " & + "-vP0 " & + "MEDIUM " & + "-vP1 " & + "HIGH " & + "-vP2"; + -- /MESSAGES_PROJECT_FILE[=messages-option] + -- + -- Specifies the "verbosity" of the parsing of project files. + -- messages-option may be one of the following: + -- + -- DEFAULT (D) No messages are output if there is no error or warning. + -- + -- MEDIUM A small number of messages are output. + -- + -- HIGH A great number of messages are output, most of them not + -- being useful for the user. + + S_Link_Nocomp : aliased constant S := "/NOCOMPILE " & + "-n"; + -- /NOCOMPILE + -- + -- Do not compile the file generated by the binder. + -- This may be used when a link is rerun with different options, + -- but there is no need to recompile the binder generated file. + + S_Link_Noinhib : aliased constant S := "/NOINHIBIT-EXEC " & + "--for-linker=--noinhibit-exec"; + -- /NOINHIBIT-EXEC + -- + -- Delete executable if there are errors or warnings. + + S_Link_Nofiles : aliased constant S := "/NOSTART_FILES " & + "-nostartfiles"; + -- /NOSTART_FILES + -- + -- Link in default image initialization and startup functions. + + S_Link_Project : aliased constant S := "/PROJECT_FILE=<" & + "-P>"; + -- /PROJECT_FILE=filename + -- + -- Specifies the main project file to be used. The project files rooted + -- at the main project file will be parsed before the invocation of the + -- linker. + -- The source and object directories to be searched will be communicated + -- to the linker through logical names ADA_PRJ_INCLUDE_FILE and + -- ADA_PRJ_OBJECTS_FILE. + + S_Link_Return : aliased constant S := "/RETURN_CODES=" & + "POSIX " & + "!-mvms-return-codes " & + "VMS " & + "-mvms-return-codes"; + -- /RETURN_CODES=POSIX (D) + -- /RETURN_CODES=VMS + -- + -- Specifies the style of codes returned by + -- Ada.Command_Line.Set_Exit_Status. Must be used in conjunction with + -- and match the Bind qualifier with the same name. + -- + -- POSIX (D) Return Posix compatible exit codes. + -- + -- VMS Return VMS compatible exit codes. The value returned + -- is identically equal to the Set_Exit_Status parameter. + + S_Link_Static : aliased constant S := "/STATIC " & + "--for-linker=-static"; + -- /NOSTATIC (D) + -- /STATIC + -- + -- Indicate to the linker that the link is static. + + S_Link_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + + S_Link_Verb : aliased constant S := "/VERBOSE " & + "-v"; + -- /NOVERBOSE (D) + -- /VERBOSE + -- + -- Causes additional information to be output, including a full list of + -- the included object files. This switch option is most useful when you + -- want to see what set of object files are being used in the link step. + + S_Link_ZZZZZ : aliased constant S := "/ " & + "--for-linker="; + -- / + -- + -- Any other switch that will be transmitted to the underlying linker. + + Link_Switches : aliased constant Switches := + (S_Link_Add 'Access, + S_Link_Bind 'Access, + S_Link_Debug 'Access, + S_Link_Nodebug 'Access, + S_Link_Execut 'Access, + S_Link_Ext 'Access, + S_Link_Follow 'Access, + S_Link_Forlink 'Access, + S_Link_Force 'Access, + S_Link_Ident 'Access, + S_Link_Libdir 'Access, + S_Link_Library 'Access, + S_Link_Mess 'Access, + S_Link_Nocomp 'Access, + S_Link_Nofiles 'Access, + S_Link_Noinhib 'Access, + S_Link_Project 'Access, + S_Link_Return 'Access, + S_Link_Static 'Access, + S_Link_Subdirs 'Access, + S_Link_Verb 'Access, + S_Link_ZZZZZ 'Access); + + ---------------------------- + -- Switches for GNAT LIST -- + ---------------------------- + + S_List_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & + "-aP*"; + -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) + -- + -- Add directories to the project search path. + + S_List_All : aliased constant S := "/ALL_UNITS " & + "-a"; + -- /NOALL_UNITS (D) + -- /ALL_UNITS + -- + -- Consider all units, including those of the predefined Ada library. + -- Especially useful with /DEPENDENCIES. + + S_List_Allproj : aliased constant S := "/ALL_PROJECTS " & + "-U"; + -- /NOALL_PROJECTS (D) + -- /ALL_PROJECTS + -- + -- When used with a project file and no file specified, indicate + -- that gnatls should be called for all sources of all projects in + -- the project tree. + + S_List_Current : aliased constant S := "/CURRENT_DIRECTORY " & + "!-I-"; + -- /CURRENT_DIRECTORY (D) + -- /NOCURRENT_DIRECTORY + -- + -- Look for source, library or object files in the default directory. + + S_List_Depend : aliased constant S := "/DEPENDENCIES " & + "-d"; + -- /NODEPENDENCIES (D) + -- /DEPENDENCIES + + S_List_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & + "-X" & '"'; + -- /EXTERNAL_REFERENCE="name=val" + -- + -- Specifies an external reference to the project manager. Useful only if + -- /PROJECT_FILE is used. + -- + -- Example: + -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + + S_List_Files : aliased constant S := "/FILES=@" & + "-files=@"; + -- /FILES=filename + -- + -- Take as arguments the files that are listed in the specified + -- text file. + + S_List_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + + S_List_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & + "DEFAULT " & + "-vP0 " & + "MEDIUM " & + "-vP1 " & + "HIGH " & + "-vP2"; + -- /MESSAGES_PROJECT_FILE[=messages-option] + -- + -- Specifies the "verbosity" of the parsing of project files. + -- messages-option may be one of the following: + -- + -- DEFAULT (D) No messages are output if there is no error or warning. + -- + -- MEDIUM A small number of messages are output. + -- + -- HIGH A great number of messages are output, most of them not + -- being useful for the user. + + S_List_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & + "-nostdinc"; + -- /NOSTD_INCLUDES + -- + -- Do not look for sources of the run time in the standard directory. + + S_List_Object : aliased constant S := "/OBJECT_SEARCH=*" & + "-aO*"; + -- /OBJECT_SEARCH=(directory,...) + -- + -- When looking for library and object files look also in the specified + -- directories. + + S_List_Output : aliased constant S := "/OUTPUT=" & + "SOURCES " & + "-s " & + "DEPEND " & + "-d " & + "OBJECTS " & + "-o " & + "UNITS " & + "-u " & + "OPTIONS " & + "-h " & + "VERBOSE " & + "-v "; + -- /OUTPUT=(option,option,...) + -- + -- SOURCES (D) Only output information about source files. + -- + -- DEPEND List sources from which specified units depend on. + -- + -- OBJECTS Only output information about object files. + -- + -- UNITS Only output information about compilation units. + -- + -- OPTIONS Output the list of options. + -- + -- VERBOSE Output the complete source and object paths. + -- Do not use the default column layout but instead + -- use long format giving as much as information + -- possible on each requested units, including + -- special characteristics. + + S_List_Project : aliased constant S := "/PROJECT_FILE=<" & + "-P>"; + -- /PROJECT_FILE=filename + -- + -- Specifies the main project file to be used. The project files rooted + -- at the main project file will be parsed before doing any listing. + -- The source and object directories to be searched will be communicated + -- to gnatlist through logical names ADA_PRJ_INCLUDE_FILE and + -- ADA_PRJ_OBJECTS_FILE. + + S_List_Search : aliased constant S := "/SEARCH=*" & + "-I*"; + -- /SEARCH=(directory,...) + -- + -- Search the specified directories for both source and object files. + + S_List_Source : aliased constant S := "/SOURCE_SEARCH=*" & + "-aI*"; + -- /SOURCE_SEARCH=(directory,...) + -- + -- When looking for source files also look in the specified directories. + + S_List_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + + List_Switches : aliased constant Switches := + (S_List_Add 'Access, + S_List_All 'Access, + S_List_Allproj 'Access, + S_List_Current 'Access, + S_List_Depend 'Access, + S_List_Ext 'Access, + S_List_Files 'Access, + S_List_Follow 'Access, + S_List_Mess 'Access, + S_List_Nostinc 'Access, + S_List_Object 'Access, + S_List_Output 'Access, + S_List_Project 'Access, + S_List_Search 'Access, + S_List_Source 'Access, + S_List_Subdirs 'Access); + + ---------------------------- + -- Switches for GNAT MAKE -- + ---------------------------- + + S_Make_Actions : aliased constant S := "/ACTIONS=" & + "COMPILE " & + "-c " & + "BIND " & + "-b " & + "LINK " & + "-l "; + -- /ACTIONS=(keyword[,...]) + -- + -- GNAT MAKE default behavior is to check if the sources are up to date, + -- compile those sources that are not up to date, bind the main source, + -- then link the executable. + -- + -- With the /ACTIONS qualifier, GNAT MAKE may be restricted to one or + -- two of these three steps: + -- + -- o Compile + -- o Bind + -- o Link + -- + -- + -- You may specify one or more of the following keywords to the /ACTIONS + -- qualifier: + -- + -- BIND Bind only. Can be combined with /ACTIONS=COMPILE + -- to do compilation and binding, but no linking. + -- Can be combined with /ACTIONS=LINK to do binding and + -- linking. When not combined with /ACTIONS=COMPILE, + -- all the units in the closure of the main program must + -- have been previously compiled and must be up to date. + -- + -- COMPILE Compile only. Do not perform binding, except when + -- /ACTIONS=BIND is also specified. Do not perform + -- linking, except if both /ACTIONS=BIND and /ACTIONS=LINK + -- are also specified. + -- + -- LINK Link only. Can be combined with /ACTIONS=BIND to do + -- binding and linking. Linking will not be performed + -- if combined with /ACTIONS=COMPILE but not with + -- /ACTIONS=BIND\. When not combined with /ACTIONS=BIND + -- all the units in the closure of the main program must + -- have been previously compiled and must be up to date, + -- and the main program need to have been bound. + + S_Make_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & + "-aP*"; + -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) + -- + -- Add directories to the project search path. + + S_Make_All : aliased constant S := "/ALL_FILES " & + "-a"; + -- /NOALL_FILES (D) + -- /ALL_FILES + -- + -- Consider all files in the make process, even the GNAT internal system + -- files (for example, the predefined Ada library files). By default, + -- GNAT MAKE does not check these files (however, if there is an + -- installation problem, it will be caught when GNAT MAKE binds your + -- program). You may have to specify this qualifier if you are working on + -- GNAT itself. The vast majority of GNAT MAKE users never need to + -- specify this switch. All GNAT internal files with will be compiled + -- with /STYLE_CHECK=GNAT. + + S_Make_Allproj : aliased constant S := "/ALL_PROJECTS " & + "-U"; + -- /NOALL_PROJECTS (D) + -- /ALL_PROJECTS + -- + -- Implies /Unique. + -- When used without project files, it is equivalent to /UNIQUE. + -- When used with a project file with no main (neither on the command + -- line nor in the attribute Main) check every source of every project, + -- recompile all sources that are not up to date and rebuild libraries + -- if necessary. + + S_Make_Bind : aliased constant S := "/BINDER_QUALIFIERS=?" & + "-bargs BIND"; + -- /BINDER_QUALIFIERS + -- + -- Any qualifiers specified after this qualifier other than + -- /COMPILER_QUALIFIERS, /LINKER_QUALIFIERS and /MAKE_QUALIFIERS will be + -- passed to any GNAT BIND commands generated by GNAT MAKE. + + S_Make_Bindprj : aliased constant S := "/BND_LNK_FULL_PROJECT " & + "-B"; + -- /BND_LNK_FULL_PROJECT + -- + -- Bind and link all sources of a project, without any consideration + -- to attribute Main, if there is one. This qualifier need to be + -- used in conjunction with the /PROJECT_FILE= qualifier and cannot + -- be used with a main subprogram on the command line or for + -- a library project file. As the binder is invoked with the option + -- meaning "No Ada main subprogram", the user must ensure that the + -- proper options are specified to the linker. This qualifier is + -- normally used when the main subprogram is in a foreign language + -- such as C. + + S_Make_Comp : aliased constant S := "/COMPILER_QUALIFIERS=?" & + "-cargs COMPILE"; + -- /COMPILER_QUALIFIERS + -- + -- Any qualifiers specified after this qualifier other than + -- /BINDER_QUALIFIERS, /LINKER_QUALIFIERS and /MAKE_QUALIFIERS will be + -- passed to any GNAT COMPILE commands generated by GNAT MAKE. + + S_Make_Cond : aliased constant S := "/CONDITIONAL_SOURCE_SEARCH=*" & + "-A*"; + -- /CONDITIONAL_SOURCE_SEARCH=dir + -- + -- Equivalent to "/SOURCE_SEARCH=dir /SKIP_MISSING=dir". + + S_Make_Cont : aliased constant S := "/CONTINUE_ON_ERROR " & + "-k"; + -- /NOCONTINUE_ON_ERROR (D) + -- /CONTINUE_ON_ERROR + -- + -- Keep going. Continue as much as possible after a compilation error. + -- To ease the programmer's task in case of compilation errors, the list + -- of sources for which the compile fails is given when GNAT MAKE + -- terminates. + + S_Make_Current : aliased constant S := "/CURRENT_DIRECTORY " & + "!-I-"; + -- /CURRENT_DIRECTORY (D) + -- /NOCURRENT_DIRECTORY + -- + -- Look for source, library or object files in the default directory. + + S_Make_Dep : aliased constant S := "/DEPENDENCIES_LIST " & + "-M"; + -- /NODEPENDENCIES_LIST (D) + -- /DEPENDENCIES_LIST + -- + -- Check if all objects are up to date. If they are, output the object + -- dependences to SYS$OUTPUT in a form that can be directly exploited in + -- a Unix-style Makefile. By default, each source file is prefixed with + -- its (relative or absolute) directory name. This name is whatever you + -- specified in the various /SOURCE_SEARCH and /SEARCH qualifiers. If + -- you also specify the /QUIET qualifier, only the source file names, + -- without relative paths, are output. If you just specify the + -- /DEPENDENCY_LIST qualifier, dependencies of the GNAT internal system + -- files are omitted. This is typically what you want. If you also + -- specify the /ALL_FILES qualifier, dependencies of the GNAT internal + -- files are also listed. Note that dependencies of the objects in + -- external Ada libraries (see the /SKIP_MISSING qualifier) are never + -- reported. + + S_Make_Dirobj : aliased constant S := "/DIRECTORY_OBJECTS=@" & + "-D@"; + -- /DIRECTORY_OBJECTS= + -- + -- Put all object files and .ALI files in . + -- This qualifier is not compatible with /PROJECT_FILE. + + S_Make_Disprog : aliased constant S := "/DISPLAY_PROGRESS " & + "-d"; + -- /NOPLAY_PROGRESS (D) + -- /DISPLAY_PROGRESS + -- + -- Display progress for each source, up to date or not, as a single line + -- completed x out of y (zz%) + -- If the file needs to be compiled this is displayed after the + -- invocation of the compiler. These lines are displayed even in quiet + -- output mode (/QUIET). + + S_Make_Doobj : aliased constant S := "/DO_OBJECT_CHECK " & + "-n"; + -- /NODO_OBJECT_CHECK (D) + -- /DO_OBJECT_CHECK + -- + -- Don't compile, bind, or link. Output a single command that will + -- recompile an out of date unit, if any. Repeated use of this option, + -- followed by carrying out the indicated compilation, will eventually + -- result in recompiling all required units. + -- + -- If any ALI is missing during the process, GNAT MAKE halts and + -- displays an error message. + + S_Make_Execut : aliased constant S := "/EXECUTABLE=@" & + "-o@"; + -- /EXECUTABLE=exec-name + -- + -- The name of the final executable program will be 'exec_name'. If this + -- qualifier is omitted the default name for the executable will be the + -- name of the input file with an EXE filetype. You may prefix + -- 'exec_name' with a relative or absolute directory path. + + S_Make_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & + "-X" & '"'; + -- /EXTERNAL_REFERENCE="name=val" + -- + -- Specifies an external reference to the project manager. Useful only if + -- /PROJECT_FILE is used. + -- + -- Example: + -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + + S_Make_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + + S_Make_Force : aliased constant S := "/FORCE_COMPILE " & + "-f"; + -- /NOFORCE_COMPILE (D) + -- /FORCE_COMPILE + -- + -- Force recompilations. Recompile all sources, even though some object + -- files may be up to date, but don't recompile predefined or GNAT + -- internal files unless the /ALL_FILES qualifier is also specified. + + S_Make_Full : aliased constant S := "/FULL_PATH_IN_BRIEF_MESSAGES " & + "-F"; + -- /NOFULL_PATH_IN_BRIEF_MESSAGES (D) + -- /FULL_PATH_IN_BRIEF_MESSAGES + -- + -- When using project files, if some errors or warnings are detected + -- during parsing and verbose mode is not in effect (no use of qualifier + -- /VERBOSE), then error lines start with the full path name of the + -- project file, rather than its simple file name. + + S_Make_Hi_Verb : aliased constant S := "/HIGH_VERBOSITY " & + "-vh"; + -- /NOHIGH_VERBOSITY (D) + -- /HIGH_VERBOSITY + -- + -- Displays the reason for all recompilations GNAT MAKE decides are + -- necessary, in high verbosity. Equivalent to /VERBOSE. + + S_Make_Inplace : aliased constant S := "/IN_PLACE " & + "-i"; + -- /NOIN_PLACE (D) + -- /IN_PLACE + -- + -- In normal mode, GNAT MAKE compiles all object files and ALI files + -- into the current directory. If the /IN_PLACE switch is used, + -- then instead object files and ALI files that already exist are over- + -- written in place. This means that once a large project is organized + -- into separate directories in the desired manner, then GNAT MAKE will + -- automatically maintain and update this organization. If no ALI files + -- are found on the Ada object path, the new object and ALI files are + -- created in the directory containing the source being compiled. + + S_Make_Index : aliased constant S := "/SOURCE_INDEX=#" & + "-eI#"; + -- /SOURCE_INDEX=nnn + -- + -- Specifies the index of the units in the source file + -- By default, source files are mono-unit and there is no index + -- When /SOURCE_INDEX=nnn is specified, only one main may be specified + -- on the command line. + + S_Make_Library : aliased constant S := "/LIBRARY_SEARCH=*" & + "-L*"; + -- /LIBRARY_SEARCH=(directory[,...]) + -- + -- Add the specified directories to the list of directories in which the + -- linker will search for libraries. + + S_Make_Link : aliased constant S := "/LINKER_QUALIFIERS=?" & + "-largs LINK"; + -- /LINKER_QUALIFIERS + -- + -- Any qualifiers specified after this qualifier other than + -- /COMPILER_QUALIFIERS, /BINDER_QUALIFIERS and /MAKE_QUALIFIERS will be + -- passed to any GNAT LINK commands generated by GNAT LINK. + + S_Make_Low_Verb : aliased constant S := "/LOW_VERBOSITY " & + "-vl"; + -- /NOLOW_VERBOSITY (D) + -- /LOW_VERBOSITY + -- + -- Displays the reason for all recompilations GNAT MAKE decides are + -- necessary, in low verbosity, that is with less output than + -- /MEDIUM_VERBOSITY, /HIGH_VERBOSITY or /VERBOSE. + + S_Make_Make : aliased constant S := "/MAKE_QUALIFIERS=?" & + "-margs MAKE"; + -- /MAKE_QUALIFIERS + -- + -- Any qualifiers specified after this qualifier other than + -- /COMPILER_QUALIFIERS, /BINDER_QUALIFIERS and /LINKER_QUALIFIERS + -- are for the benefit of GNAT MAKE itself. + + S_Make_Mapping : aliased constant S := "/MAPPING " & + "-C"; + -- /NOMAPPING (D) + -- /MAPPING + -- + -- Use a mapping file. A mapping file is a way to communicate to the + -- compiler two mappings: from unit names to file names (without any + -- directory information) and from file names to path names (with full + -- directory information). These mappings are used by the compiler to + -- short-circuit the path search. When GNAT MAKE is invoked with this + -- qualifier, it will create a mapping file, initially populated by the + -- project manager, if /PROJECT_File= is used, otherwise initially empty. + -- Each invocation of the compiler will add the newly accessed sources to + -- the mapping file. This will improve the source search during the next + -- invocations of the compiler + + S_Make_Med_Verb : aliased constant S := "/MEDIUM_VERBOSITY " & + "-vm"; + -- /NOMEDIUM_VERBOSITY (D) + -- /MEDIUM_VERBOSITY + -- + -- Displays the reason for all recompilations GNAT MAKE decides are + -- necessary, in medium verbosity, that is with potentially less output + -- than /HIGH_VERBOSITY or /VERBOSE. + + S_Make_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & + "DEFAULT " & + "-vP0 " & + "MEDIUM " & + "-vP1 " & + "HIGH " & + "-vP2"; + -- /MESSAGES_PROJECT_FILE[=messages-option] + -- + -- Specifies the "verbosity" of the parsing of project files. + -- messages-option may be one of the following: + -- + -- DEFAULT (D) No messages are output if there is no error or warning. + -- + -- MEDIUM A small number of messages are output. + -- + -- HIGH A great number of messages are output, most of them not + -- being useful for the user. + + S_Make_Minimal : aliased constant S := "/MINIMAL_RECOMPILATION " & + "-m"; + -- /NOMINIMAL_RECOMPILATION (D) + -- /MINIMAL_RECOMPILATION + -- + -- Specifies that the minimum necessary amount of recompilation + -- be performed. In this mode GNAT MAKE ignores time stamp differences + -- when the only modifications to a source file consist in + -- adding/removing comments, empty lines, spaces or tabs. + + S_Make_Missing : aliased constant S := "/CREATE_MISSING_DIRS " & + "-p"; + -- /NOCREATE_MISSING_DIRS (D) + -- /CREATE_MISSING_DIRS + -- + -- When an object directory, a library directory or an exec directory + -- in missing, attempt to create the directory. + + S_Make_Nolink : aliased constant S := "/NOLINK " & + "-c"; + -- /NOLINK + -- + -- Compile only. Do not perform binding and linking. If the root unit is + -- not a main unit, this is the default. Otherwise GNAT MAKE will + -- attempt binding and linking unless all objects are up to date and the + -- executable is more recent than the objects. + -- This is equivalent to /ACTIONS=COMPILE + + S_Make_Nomain : aliased constant S := "/NOMAIN " & + "-z"; + -- /NOMAIN + -- + -- No main subprogram. Bind and link the program even if the unit name + -- given on the command line is a package name. The resulting executable + -- will execute the elaboration routines of the package and its closure, + -- then the finalization routines. + + S_Make_Nonpro : aliased constant S := "/NON_PROJECT_UNIT_COMPILATION " & + "-x"; + -- /NON_PROJECT_UNIT_COMPILATION + -- + -- Normally, when using project files, a unit that is not part of any + -- project file, cannot be compile. These units may be compile, when + -- needed, if this qualifier is specified. + + S_Make_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & + "-nostdinc"; + -- /NOSTD_INCLUDES + -- + -- Do not look for sources the in the system default directory. + + S_Make_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " & + "-nostdlib"; + -- /NOSTD_LIBRARIES + -- + -- Do not look for library files in the system default directory. + + S_Make_Object : aliased constant S := "/OBJECT_SEARCH=*" & + "-aO*"; + -- /OBJECT_SEARCH=(directory[,...]) + -- + -- When looking for library and object files look also in the specified + -- directories. + + S_Make_Proc : aliased constant S := "/PROCESSES=#" & + "-j#"; + -- /NOPROCESSES (D) + -- /PROCESSES=NNN + -- + -- Use NNN processes to carry out the (re)compilations. If you have a + -- multiprocessor machine, compilations will occur in parallel. In the + -- event of compilation errors, messages from various compilations might + -- get interspersed (but GNAT MAKE will give you the full ordered list of + -- failing compiles at the end). This can at times be annoying. To get a + -- clean list of error messages don't use this qualifier. + + S_Make_Nojobs : aliased constant S := "/NOPROCESSES " & + "-j1"; + -- NODOC (see /PROCESS) + + S_Make_Project : aliased constant S := "/PROJECT_FILE=<" & + "-P>"; + -- /PROJECT_FILE=filename + -- + -- Specifies the main project file to be used. The project files rooted + -- at the main project file will be parsed before any other processing to + -- set the building environment. + + S_Make_Quiet : aliased constant S := "/QUIET " & + "-q"; + -- /NOQUIET (D) + -- /QUIET + -- + -- When this qualifiers is specified, the commands carried out by GNAT + -- MAKE are not displayed. + + S_Make_Reason : aliased constant S := "/REASONS " & + "-v"; + -- /NOREASONS (D) + -- /REASONS + -- + -- Displays the reason for all recompilations GNAT MAKE decides are + -- necessary. + + S_Make_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" & + "--RTS=|"; + -- /RUNTIME_SYSTEM=xxx + -- + -- Build against an alternate runtime system named xxx or RTS-xxx. + + S_Make_Search : aliased constant S := "/SEARCH=*" & + "-I*"; + -- /SEARCH=(directory[,...]) + -- + -- Search the specified directories for both source and object files. + + S_Make_Single : aliased constant S := "/SINGLE_COMPILE_PER_OBJ_DIR " & + "--single-compile-per-obj-dir"; + -- /NOSINGLE_COMPILE_PER_OBJ_DIR (D) + -- /SINGLE_COMPILE_PER_OBJ_DIR + -- + -- When project files are used, do not allow simultaneous compilations + -- for the same object directory. + + S_Make_Skip : aliased constant S := "/SKIP_MISSING=*" & + "-aL*"; + -- /SKIP_MISSING=(directory[,...]) + -- + -- Skip missing library sources if ALI in 'directory'. + + S_Make_Source : aliased constant S := "/SOURCE_SEARCH=*" & + "-aI*"; + -- /SOURCE_SEARCH=(directory[,...]) + -- + -- When looking for source files also look in the specified directories. + + S_Make_Src_Info : aliased constant S := "/SRC_INFO=<" & + "--source-info=>"; + -- /SRC_INFO=source-info-file + -- + -- Specify a source info file to be read or written by the Project + -- Manager when project files are used. + + S_Make_Stand : aliased constant S := "/STANDARD_OUTPUT_FOR_COMMANDS " & + "-eS"; + -- /NOSTANDARD_OUTPUT_FOR_COMMANDS (D) + -- /STANDARD_OUTPUT_FOR_COMMANDS + -- + -- Output the commands for the compiler, the binder and the linker + -- on SYS$OUTPUT, instead of SYS$ERROR. + + S_Make_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + + S_Make_Switch : aliased constant S := "/SWITCH_CHECK " & + "-s"; + -- /NOSWITCH_CHECK (D) + -- /SWITCH_CHECK + -- + -- Recompile if compiler switches have changed since last compilation. + -- All compiler switches but -I and -o are taken into account in the + -- following way: orders between different "first letter" switches are + -- ignored, but orders between same switches are taken into account. + -- For example, -O -O2 is different than -O2 -O, but -g -O is equivalent + -- to -O -g. + + S_Make_USL : aliased constant S := "/UNCHECKED_SHARED_LIB_IMPORTS " & + "--unchecked-shared-lib-imports"; + -- /NOUNCHECKED_SHARED_LIB_IMPORTS (D) + -- /UNCHECKED_SHARED_LIB_IMPORTS + -- + -- Allow shared library projects to import static library projects + + S_Make_Unique : aliased constant S := "/UNIQUE " & + "-u"; + -- /NOUNIQUE (D) + -- /UNIQUE + -- + -- Recompile at most the main file. It implies /ACTIONS=COMPILE. + -- Combined with /FORCE_COMPILE, it is equivalent to calling the compiler + -- directly. + + S_Make_Use_Map : aliased constant S := "/USE_MAPPING_File=@" & + "-C=@"; + -- /USE_MAPPING_FILE=file_name + -- + -- Use a specific mapping file. The file 'file_name', specified as a path + -- name (absolute or relative) by this qualifier, should already exist, + -- otherwise the qualifier is ineffective. The specified mapping file + -- will be communicated to the compiler. This switch is not compatible + -- with a project file (/PROJECT_FILE=) or with multiple compiling + -- processes (/PROCESSES=nnn, when nnn is greater than 1). + + S_Make_Verbose : aliased constant S := "/VERBOSE " & + "-v"; + -- /NOVERBOSE (D) + -- /VERBOSE + -- + -- Displays the reason for all recompilations GNAT MAKE decides are + -- necessary. + + Make_Switches : aliased constant Switches := + (S_Make_Add 'Access, + S_Make_Actions 'Access, + S_Make_All 'Access, + S_Make_Allproj 'Access, + S_Make_Bind 'Access, + S_Make_Comp 'Access, + S_Make_Cond 'Access, + S_Make_Cont 'Access, + S_Make_Current 'Access, + S_Make_Dep 'Access, + S_Make_Dirobj 'Access, + S_Make_Disprog 'Access, + S_Make_Doobj 'Access, + S_Make_Execut 'Access, + S_Make_Ext 'Access, + S_Make_Follow 'Access, + S_Make_Force 'Access, + S_Make_Full 'Access, + S_Make_Hi_Verb 'Access, + S_Make_Inplace 'Access, + S_Make_Index 'Access, + S_Make_Library 'Access, + S_Make_Link 'Access, + S_Make_Low_Verb'Access, + S_Make_Make 'Access, + S_Make_Mapping 'Access, + S_Make_Med_Verb'Access, + S_Make_Mess 'Access, + S_Make_Minimal 'Access, + S_Make_Missing 'Access, + S_Make_Nolink 'Access, + S_Make_Nomain 'Access, + S_Make_Nonpro 'Access, + S_Make_Nostinc 'Access, + S_Make_Nostlib 'Access, + S_Make_Object 'Access, + S_Make_Proc 'Access, + S_Make_Nojobs 'Access, + S_Make_Project 'Access, + S_Make_Quiet 'Access, + S_Make_Reason 'Access, + S_Make_RTS 'Access, + S_Make_Search 'Access, + S_Make_Single 'Access, + S_Make_Skip 'Access, + S_Make_Source 'Access, + S_Make_Src_Info'Access, + S_Make_Stand 'Access, + S_Make_Subdirs 'Access, + S_Make_Switch 'Access, + S_Make_USL 'Access, + S_Make_Unique 'Access, + S_Make_Use_Map 'Access, + S_Make_Verbose 'Access); + + ------------------------------ + -- Switches for GNAT METRIC -- + ------------------------------ + + S_Metric_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & + "-aP*"; + -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) + -- + -- Add directories to the project search path. + + S_Metric_All_Prjs : aliased constant S := "/ALL_PROJECTS " & + "-U"; + -- /NOALL_PROJECTS (D) + -- /ALL_PROJECTS + -- When GNAT METRIC is used with a Project File and no source is + -- specified, the underlying tool gnatmetric is called for all the + -- sources of all the Project Files in the project tree. + + S_Metric_Debug : aliased constant S := "/DEBUG_OUTPUT " & + "-dv"; + -- /DEBUG_OUTPUT + -- + -- Generate the debug information + + S_Metric_Direct : aliased constant S := "/DIRECTORY=@" & + "-d=@"; + -- /DIRECTORY=pathname + -- + -- Put the files with detailed metric information into the specified + -- directory + + S_Metric_Element : aliased constant S := "/ELEMENT_METRICS=" & + "ALL " & + "!-ed,!-es,!-enl,!-eps," & + "!-eas,!-ept,!-eat,!-enu," & + "!-ec " & + "DECLARATION_TOTAL " & + "-ed " & + "STATEMENT_TOTAL " & + "-es " & + "LOOP_NESTING_MAX " & + "-enl " & + "INT_SUBPROGRAMS " & + "-eps " & + "SUBPROGRAMS_ALL " & + "-eas " & + "INT_TYPES " & + "-ept " & + "TYPES_ALL " & + "-eat " & + "PROGRAM_NESTING_MAX " & + "-enu " & + "CONSTRUCT_NESTING_MAX " & + "-ec"; + -- NODOC (see /SYNTAX_METRICS) + + S_Metric_Syntax : aliased constant S := "/SYNTAX_METRICS=" & + "ALL " & + "--syntax-all " & + "NONE " & + "--no-syntax-all " & + "DECLARATIONS " & + "--declarations " & + "NODECLARATIONS " & + "--no-declarations " & + "STATEMENTS " & + "--statements " & + "NOSTATEMENTS " & + "--no-statements " & + "PUBLIC_SUBPROGRAMS " & + "--public-subprograms " & + "NOPUBLIC_SUBPROGRAMS " & + "--no-public-subprograms " & + "ALL_SUBPROGRAMS " & + "--all-subprograms " & + "NOALL_SUBPROGRAMS " & + "--no-all-subprograms " & + "PUBLIC_TYPES " & + "--public-types " & + "NOPUBLIC_TYPES " & + "--no-public-types " & + "ALL_TYPES " & + "--all-types " & + "NOALL_TYPES " & + "--no-all-types " & + "UNIT_NESTING " & + "--unit-nesting " & + "NOUNIT_NESTING " & + "--no-unit-nesting " & + "CONSTRUCT_NESTING " & + "--construct-nesting " & + "NOCONSTRUCT_NESTING " & + "--no-construct-nesting"; + -- /SYNTAX_METRICS(option, option ...) + -- + -- Specifies the syntax element metrics to be computed (if at least one + -- positive syntax element metric, line metric, complexity or coupling + -- metric is specified then only explicitly specified syntax element + -- metrics are computed and reported) + -- + -- option may be one of the following: + -- + -- ALL (D) All the syntax element metrics are computed + -- NONE None of syntax element metrics is computed + -- DECLARATIONS Compute the total number of declarations + -- NODECLARATIONS Do not compute the total number of declarations + -- STATEMENTS Compute the total number of statements + -- NOSTATEMENTS Do not compute the total number of statements + -- PUBLIC_SUBPROGRAMS Compute the number of public subprograms + -- NOPUBLIC_SUBPROGRAMS Do not compute the number of public subprograms + -- ALL_SUBPROGRAMS Compute the number of all the subprograms + -- NOALL_SUBPROGRAMS Do not compute the number of all the + -- subprograms + -- PUBLIC_TYPES Compute the number of public types + -- NOPUBLIC_TYPES Do not compute the number of public types + -- ALL_TYPES Compute the number of all the types + -- NOALL_TYPES Do not compute the number of all the types + -- UNIT_NESTING Compute the maximal program unit nesting + -- level + -- NOUNIT_NESTING Do not compute the maximal program unit + -- nesting level + -- CONSTRUCT_NESTING Compute the maximal construct nesting level + -- NOCONSTRUCT_NESTING Do not compute the maximal construct nesting + -- level + -- + -- All combinations of syntax element metrics options are allowed. + + S_Metric_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & + "-X" & '"'; + -- /EXTERNAL_REFERENCE="name=val" + -- + -- Specifies an external reference to the project manager. Useful only if + -- /PROJECT_FILE is used. + -- + -- Example: + -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + + S_Metric_Files : aliased constant S := "/FILES=@" & + "-files=@"; + -- /FILES=filename + -- + -- Take as arguments the files that are listed in the specified + -- text file. + + S_Metric_Format : aliased constant S := "/FORMAT_OUTPUT=" & + "DEFAULT " & + "!-x,!-nt,!-sfn " & + "XML " & + "-x " & + "XSD " & + "-xs " & + "NO_TEXT " & + "-nt " & + "SHORT_SOURCE_FILE_NAME " & + "-sfn"; + -- /FORMAT_OUTPUT=(option, option ...) + -- + -- Specifies the details of the tool output + -- + -- option may be one of the following: + -- + -- DEFAULT (D) Generate the text output only, use full + -- argument source names in global information + -- XML Generate the output in XML format + -- XSD Generate the output in XML format, and + -- generate an XML schema file that describes + -- the structure of XML metrics report + -- NO_TEXT Do not generate the text output (implies XML) + -- SHORT_SOURCE_FILE_NAME Use short argument source names in output + + S_Metric_Globout : aliased constant S := "/GLOBAL_OUTPUT=@" & + "-og@"; + -- /GLOBAL_OUTPUT=filename + -- + -- Put the textual global metric information into the specified file + + S_Metric_Line : aliased constant S := "/LINE_METRICS=" & + "ALL " & + "!-la,!-lcode,!-lcomm," & + "!-leol,!-lb " & + "LINES_ALL " & + "-la " & + "CODE_LINES " & + "-lcode " & + "COMENT_LINES " & + "-lcomm " & + "MIXED_CODE_COMMENTS " & + "-leol " & + "COMMENT_PERCENTAGE " & + "-lratio " & + "BLANK_LINES " & + "-lb " & + "AVERAGE_LINES_IN_BODIES " & + "-lav "; + -- NODOC (see /LINE_COUNT_METRICS) + + S_Metric_Lines : aliased constant S := "/LINE_COUNT_METRICS=" & + "ALL " & + "--lines-all " & + "NONE " & + "--no-lines-all " & + "ALL_LINES " & + "--lines " & + "NOALL_LINES " & + "--no-lines " & + "CODE_LINES " & + "--lines-code " & + "NOCODE_LINES " & + "--no-lines-code " & + "COMMENT_LINES " & + "--lines-comment " & + "NOCOMMENT_LINES " & + "--no-lines-comment " & + "CODE_COMMENT_LINES " & + "--lines-eol-comment " & + "NOCODE_COMMENT_LINES " & + "--no-lines-eol-comment " & + "COMMENT_PERCENTAGE " & + "--lines-ratio " & + "NOCOMMENT_PERCENTAGE " & + "--no-lines-ratio " & + "BLANK_LINES " & + "--lines-blank " & + "NOBLANK_LINES " & + "--no-lines-blank " & + "AVERAGE_BODY_LINES " & + "--lines-average " & + "NOAVERAGE_BODY_LINES " & + "--no-lines-average"; + -- /LINE_COUNT_METRICS=(option, option ...) + + -- Specifies the line metrics to be computed (if at least one positive + -- syntax element metric, line metric, complexity or coupling metric is + -- specified then only explicitly specified line metrics are computed + -- and reported) + -- + -- option may be one of the following: + -- + -- ALL (D) All the line metrics are computed + -- NONE None of line metrics is computed + -- ALL_LINES All lines are computed + -- NOALL_LINES All lines are not computed + -- CODE_LINES Lines with Ada code are computed + -- NOCODE_LINES Lines with Ada code are not computed + -- COMMENT_LINES Comment lines are computed + -- NOCOMMENT_LINES Comment lines are not computed + -- CODE_COMMENT_LINES Lines containing both code and comment parts + -- are computed + -- NOCODE_COMMENT_LINES Lines containing both code and comment parts + -- are not computed + -- COMMENT_PERCENTAGE Ratio between comment lines and all the lines + -- containing comments and program code is + -- computed + -- NOCOMMENT_PERCENTAGE Ratio between comment lines and all the lines + -- containing comments and program code is not + -- computed + -- BLANK_LINES Blank lines are computed + -- NOBLANK_LINES Blank lines are not computed + -- AVERAGE_BODY_LINES Average number of code lines in subprogram, + -- task and entry bodies and statement sequences + -- of package bodies is computed + -- NOAVERAGE_BODY_LINES Average number of code lines in subprogram, + -- task and entry bodies and statement sequences + -- of package bodies is not computed + -- + -- All combinations of line metrics options are allowed. + + S_Metric_Complexity : aliased constant S := "/COMPLEXITY_METRICS=" & + "ALL " & + "--complexity-all " & + "NONE " & + "--no-complexity-all " & + "CYCLOMATIC " & + "--complexity-cyclomatic " & + "NOCYCLOMATIC " & + "--no-complexity-cyclomatic "& + "ESSENTIAL " & + "--complexity-essential " & + "NOESSENTIAL " & + "--no-complexity-essential " & + "LOOP_NESTING " & + "--loop-nesting " & + "NOLOOP_NESTING " & + "--no-loop-nesting " & + "AVERAGE_COMPLEXITY " & + "--complexity-average " & + "NOAVERAGE_COMPLEXITY " & + "--no-complexity-average " & + "EXTRA_EXIT_POINTS " & + "--extra-exit-points " & + "NOEXTRA_EXIT_POINTS " & + "--no-extra-exit-points"; + -- /COMPLEXITY_METRICS=(option, option ...) + + -- Specifies the complexity metrics to be computed (if at least one + -- positive syntax element metric, line metric, complexity or coupling + -- metric is specified then only explicitly specified complexity metrics + -- are computed and reported) + -- + -- option may be one of the following: + -- + -- ALL (D) All the complexity metrics are computed + -- NONE None of complexity metrics is computed + -- CYCLOMATIC Compute the McCabe Cyclomatic Complexity + -- NOCYCLOMATIC Do not compute the McCabe Cyclomatic Complexity + -- ESSENTIAL Compute the Essential Complexity + -- NOESSENTIAL Do not compute the Essential Complexity + -- LOOP_NESTING Compute the maximal loop nesting + -- NOLOOP_NESTING Do not compute the maximal loop nesting + -- AVERAGE_COMPLEXITY Compute the average complexity for executable + -- bodies + -- NOAVERAGE_COMPLEXITY Do not compute the average complexity for + -- executable bodies + -- EXTRA_EXIT_POINTS Compute extra exit points metric + -- NOEXTRA_EXIT_POINTS Do not compute extra exit points metric + -- + -- All combinations of line metrics options are allowed. + + S_Metric_Coupling : aliased constant S := "/COUPLING_METRICS=" & + "ALL " & + "--coupling-all " & + "NONE " & + "--no-coupling-all " & + "PACKAGE_EFFERENT " & + "--package-efferent-coupling " & + "NOPACKAGE_EFFERENT " & + "--no-package-efferent-coupling " & + "PACKAGE_AFFERENT " & + "--package-afferent-coupling " & + "NOPACKAGE_AFFERENT " & + "--no-package-afferent-coupling " & + "CATEGORY_EFFERENT " & + "--category-efferent-coupling " & + "NOCATEGORY_EFFERENT " & + "--no-category-efferent-coupling " & + "CATEGORY_AFFERENT " & + "--category-afferent-coupling " & + "NOCATEGORY_AFFERENT " & + "--no-category-afferent-coupling"; + + -- /COUPLING_METRICS=(option, option ...) + + -- Specifies the coupling metrics to be computed. + -- + -- option may be one of the following: + -- + -- ALL All the coupling metrics are computed + -- NONE (D) None of coupling metrics is computed + -- PACKAGE_EFFERENT Compute package efferent coupling + -- NOPACKAGE_EFFERENT Do not compute package efferent coupling + -- PACKAGE_AFFERENT Compute package afferent coupling + -- NOPACKAGE_AFFERENT Do not compute package afferent coupling + -- CATEGORY_EFFERENT Compute category efferent coupling + -- NOCATEGORY_EFFERENT Do not compute category efferent coupling + -- CATEGORY_AFFERENT Compute category afferent coupling + -- NOCATEGORY_AFFERENT Do not compute category afferent coupling + -- + -- All combinations of coupling metrics options are allowed. + + S_Metric_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + + S_Metric_No_Local : aliased constant S := "/NO_LOCAL_DETAILS " & + "-nolocal"; + -- /LOCAL_DETAILS (D) + -- /NO_LOCAL_DETAILS + -- + -- Do not compute the detailed metrics for local program units. + + S_Metric_No_Exits_As_Gotos : aliased constant S := "/NO_EXITS_AS_GOTOS " & + "-ne"; + -- /EXITS_AS_GOTOS (D) + -- /NO_EXITS_AS_GOTOS + -- + -- Do not count EXIT statements as GOTOs when computing the Essential + -- Complexity. + + S_Metric_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & + "DEFAULT " & + "-vP0 " & + "MEDIUM " & + "-vP1 " & + "HIGH " & + "-vP2"; + -- /MESSAGES_PROJECT_FILE[=messages-option] + -- + -- Specifies the "verbosity" of the parsing of project files. + -- messages-option may be one of the following: + -- + -- DEFAULT (D) No messages are output if there is no error or warning. + -- + -- MEDIUM A small number of messages are output. + -- + -- HIGH A great number of messages are output, most of them not + -- being useful for the user. + + S_Metric_Project : aliased constant S := "/PROJECT_FILE=<" & + "-P>"; + -- /PROJECT_FILE=filename + -- + -- Specifies the main project file to be used. The project files rooted + -- at the main project file will be parsed before the invocation of the + -- binder. + + S_Metric_Quiet : aliased constant S := "/QUIET " & + "-q"; + -- /NOQUIET (D) + -- /QUIET + -- + -- Quiet mode: by default GNAT METRIC outputs to the standard error stream + -- the number of program units left to be processed. This option turns + -- this trace off. + + S_Metric_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + + S_Metric_Suffix : aliased constant S := "/SUFFIX_DETAILS=" & '"' & + "-o" & '"'; + -- /SUFFIX_DETAILS=suffix + -- + -- Use the given suffix as the suffix for the name of the file to place + -- the detailed metrics into. + + S_Metric_Suppress : aliased constant S := "/SUPPRESS=" & + "NOTHING " & + "!-nocc,!-noec,!-nonl," & + "!-ne,!-nolocal " & + "CYCLOMATIC_COMPLEXITY " & + "-nocc " & + "ESSENTIAL_COMPLEXITY " & + "-noec " & + "MAXIMAL_LOOP_NESTING " & + "-nonl " & + "EXITS_AS_GOTOS " & + "-ne " & + "LOCAL_DETAILS " & + "-nolocal "; + -- NODOC (see /COMPLEXITY_METRICS /NO_LOCAL_DETAILS /NO_EXITS_AS_GOTOS) + + S_Metric_Verbose : aliased constant S := "/VERBOSE " & + "-v"; + -- /NOVERBOSE (D) + -- /VERBOSE + -- + -- Verbose mode. + + S_Metric_XMLout : aliased constant S := "/XML_OUTPUT=@" & + "-ox@"; + -- /XML_OUTPUT=filename + -- + -- Place the XML output into the specified file + + Metric_Switches : aliased constant Switches := + (S_Metric_Add 'Access, + S_Metric_All_Prjs 'Access, + S_Metric_Complexity 'Access, + S_Metric_Coupling 'Access, + S_Metric_Debug 'Access, + S_Metric_Direct 'Access, + S_Metric_Element 'Access, + S_Metric_Ext 'Access, + S_Metric_Files 'Access, + S_Metric_Follow 'Access, + S_Metric_Format 'Access, + S_Metric_Globout 'Access, + S_Metric_Line 'Access, + S_Metric_Lines 'Access, + S_Metric_Mess 'Access, + S_Metric_No_Exits_As_Gotos'Access, + S_Metric_No_Local 'Access, + S_Metric_Project 'Access, + S_Metric_Quiet 'Access, + S_Metric_Suffix 'Access, + S_Metric_Subdirs 'Access, + S_Metric_Syntax 'Access, + S_Metric_Suppress 'Access, + S_Metric_Verbose 'Access, + S_Metric_XMLout 'Access); + + ---------------------------- + -- Switches for GNAT NAME -- + ---------------------------- + + S_Name_Conf : aliased constant S := "/CONFIG_FILE=<" & + "-c>"; + -- /CONFIG_FILE=path_name + -- + -- Create a configuration pragmas file 'path_name' (instead of the default + -- 'gnat.adc'). 'path_name' may include directory information. 'path_name' + -- must be writable. There may be only one qualifier /CONFIG_FILE. + -- This qualifier is not compatible with qualifier /PROJECT_FILE. + + S_Name_Dirs : aliased constant S := "/SOURCE_DIRS=*" & + "-d*"; + -- /SOURCE_DIRS=(directory, ...) + -- + -- Look for source files in the specified directories. When this qualifier + -- is specified, the current working directory will not be searched for + -- source files, unless it is explicitly specified with a qualifier + -- /SOURCE_DIRS or /DIRS_FILE. Several qualifiers /SOURCE_DIRS may be + -- specified. If a directory is specified as a relative path, it is + -- relative to the directory of the configuration pragmas file specified + -- with qualifier /CONFIG_FILE, or to the directory of the project file + -- specified with qualifier /PROJECT_FILE or, if neither qualifier + -- /CONFIG_FILE nor qualifier /PROJECT_FILE are specified, it is relative + -- to the current working directory. The directories specified with + -- qualifiers /SOURCE_DIRS must exist and be readable. + + S_Name_Dfile : aliased constant S := "/DIRS_FILE=<" & + "-D>"; + -- /DIRS_FILE=file_name + -- + -- Look for source files in all directories listed in text file + -- 'file_name'. 'file_name' must be an existing, readable text file. + -- Each non empty line in the specified file must be a directory. + -- Specifying qualifier /DIRS_FILE is equivalent to specifying as many + -- qualifiers /SOURCE_DIRS as there are non empty lines in the specified + -- text file. + + S_Name_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + + S_Name_Frng : aliased constant S := "/FOREIGN_PATTERN=" & '"' & + "-f" & '"'; + -- /FOREIGN_PATTERN= + -- + -- Specify a foreign pattern. + -- Using this qualifier, it is possible to add sources of languages other + -- than Ada to the list of sources of a project file. It is only useful + -- if a qualifier /PROJECT_FILE is used. For example, + -- + -- GNAT NAME /PROJECT_FILE=PRJ /FOREIGN_PATTERN="*.C" "*.ADA" + -- + -- will look for Ada units in all files with the '.ADA' extension, and + -- will add to the list of file for project PRJ.GPR the C files with + -- extension ".C". + + S_Name_Help : aliased constant S := "/HELP " & + "-h"; + -- /NOHELP (D) + -- /HELP + -- + -- Output usage information to the standard output stream. + + S_Name_Proj : aliased constant S := "/PROJECT_FILE=<" & + "-P>"; + -- /PROJECT_FILE=file_name + -- + -- Create or update a project file. 'file_name' may include directory + -- information. The specified file must be writable. There may be only + -- one qualifier /PROJECT_FILE. When a qualifier /PROJECT_FILE is + -- specified, no qualifier /CONFIG_FILE may be specified. + + S_Name_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + + S_Name_Verbose : aliased constant S := "/VERBOSE " & + "-v"; + -- /NOVERBOSE (D) + -- /VERBOSE + -- + -- Verbose mode. Output detailed explanation of behavior to the standard + -- output stream. This includes name of the file written, the name of the + -- directories to search and, for each file in those directories whose + -- name matches at least one of the Naming Patterns, an indication of + -- whether the file contains a unit, and if so the name of the unit. + + S_Name_Excl : aliased constant S := "/EXCLUDED_PATTERN=" & '"' & + "-x" & '"'; + -- /EXCLUDED_PATTERN= + -- + -- Specify an excluded pattern. + -- Using this qualifier, it is possible to exclude some files that would + -- match the Naming patterns. For example, + -- + -- GNAT NAME /EXCLUDED_PATTERN="*_NT.ADA" "*.ADA" + -- + -- will look for Ada units in all files with the '.ADA' extension, except + -- those whose names end with '_NT.ADA'. + + Name_Switches : aliased constant Switches := + (S_Name_Conf 'Access, + S_Name_Dirs 'Access, + S_Name_Dfile 'Access, + S_Name_Follow 'Access, + S_Name_Frng 'Access, + S_Name_Help 'Access, + S_Name_Proj 'Access, + S_Name_Subdirs 'Access, + S_Name_Verbose 'Access, + S_Name_Excl 'Access); + + ---------------------------------- + -- Switches for GNAT PREPROCESS -- + ---------------------------------- + + S_Prep_Assoc : aliased constant S := "/ASSOCIATE=" & '"' & + "-D" & '"'; + -- /ASSOCIATE="name=val" + -- + -- Defines a new symbol, associated with value. If no value is given + -- on the command line, then symbol is considered to be True. + -- This qualifier can be used in place of a definition file. + + S_Prep_Blank : aliased constant S := "/BLANK_LINES " & + "-b"; + -- /NOBLANK_LINES (D) + -- /BLANK_LINES + -- + -- Causes both preprocessor lines and the lines deleted by preprocessing + -- to be replaced by blank lines in the output source file, thus + -- preserving line numbers in the output file. + + S_Prep_Com : aliased constant S := "/COMMENTS " & + "-c"; + -- /NOCOMMENTS (D) + -- /COMMENTS + -- + -- /COMMENTS causes both preprocessor lines and the lines deleted + -- by preprocessing to be retained in the output source as comments marked + -- with the special string "--! ". This option will result in line numbers + -- being preserved in the output file. + -- + -- /NOCOMMENTS causes both preprocessor lines and the lines deleted by + -- preprocessing to be replaced by blank lines in the output source file, + -- thus preserving line numbers in the output file. + + S_Prep_Ref : aliased constant S := "/REFERENCE " & + "-r"; + -- /NOREFERENCE (D) + -- /REFERENCE + -- + -- Causes a "Source_Reference" pragma to be generated that references the + -- original input file, so that error messages will use the file name of + -- this original file. Also implies /BLANK_LINES if /COMMENTS is not + -- specified. + + S_Prep_Remove : aliased constant S := "/REMOVE " & + "!-b,!-c"; + -- /REMOVE (D) + -- /NOREMOVE + -- + -- Preprocessor lines and deleted lines are completely removed from the + -- output. + + S_Prep_Replace : aliased constant S := "/REPLACE_IN_COMMENTS " & + "-C"; + -- /NOREPLACE_IN_COMMENTS (D) + -- /REPLACE_IN_COMMENTS + -- + -- Causes preprocessor to scan comments and perform replacements on + -- any $symbol occurrences within the comment text. + + S_Prep_Symbols : aliased constant S := "/SYMBOLS " & + "-s"; + -- /NOSYMBOLS (D) + -- /SYMBOLS + -- + -- Causes a sorted list of symbol names and values to be listed on + -- SYS$OUTPUT. + + S_Prep_Undef : aliased constant S := "/UNDEFINED " & + "-u"; + -- /NOUNDEFINED (D) + -- /UNDEFINED + + Prep_Switches : aliased constant Switches := + (S_Prep_Assoc 'Access, + S_Prep_Blank 'Access, + S_Prep_Com 'Access, + S_Prep_Ref 'Access, + S_Prep_Remove 'Access, + S_Prep_Replace 'Access, + S_Prep_Symbols 'Access, + S_Prep_Undef 'Access); + + ------------------------------ + -- Switches for GNAT PRETTY -- + ------------------------------ + + S_Pretty_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & + "-aP*"; + -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) + -- + -- Add directories to the project search path. + + S_Pretty_Align : aliased constant S := "/ALIGN=" & + "DEFAULT " & + "-A12345 " & + "OFF " & + "-A0 " & + "COLONS " & + "-A1 " & + "DECLARATIONS " & + "-A2 " & + "STATEMENTS " & + "-A3 " & + "ARROWS " & + "-A4 " & + "COMPONENT_CLAUSES " & + "-A5"; + -- /ALIGN[=align-option, align-option, ...] + -- + -- Set alignments. By default, all alignments (colons in declarations, + -- initialisations in declarations, assignments and arrow delimiters) are + -- ON. + -- + -- align-option may be one of the following: + -- + -- OFF (D) Set all alignments to OFF + -- COLONS Set alignments of colons in declarations to ON + -- DECLARATIONS Set alignments of initialisations in declarations + -- to ON + -- STATEMENTS Set alignments of assignments statements to ON + -- ARROWS Set alignments of arrow delimiters to ON. + -- COMPONENT_CLAUSES Set alignments of AT keywords in component + -- clauses ON + -- + -- Specifying one of the ON options without first specifying the OFF + -- option has no effect, because by default all alignments are set to ON. + + S_Pretty_All_Prjs : aliased constant S := "/ALL_PROJECTS " & + "-U"; + -- /NOALL_PROJECTS (D) + -- /ALL_PROJECTS + -- When GNAT PRETTY is used with a Project File and no source is + -- specified, the underlying tool gnatpp is called for all the + -- sources of all the Project Files in the project tree. + + S_Pretty_Attrib : aliased constant S := "/ATTRIBUTE_CASING=" & + "MIXED_CASE " & + "-aM " & + "LOWER_CASE " & + "-aL " & + "UPPER_CASE " & + "-aU"; + -- /ATTRIBUTE_CASING[=casing-option] + -- + -- Set the case of the attributes. By default the attributes are in mixed + -- case. + -- casing-option may be one of the following: + -- + -- MIXED_CASE (D) + -- LOWER_CASE + -- UPPER_CASE + + S_Pretty_Comments : aliased constant S := "/COMMENTS_LAYOUT=" & + "UNTOUCHED " & + "-c0 " & + "DEFAULT " & + "-c1 " & + "STANDARD_INDENT " & + "-c2 " & + "GNAT_BEGINNING " & + "-c3 " & + "REFORMAT " & + "-c4 " & + "KEEP_SPECIAL " & + "-c5"; + -- /COMMENTS_LAYOUT[=layout-option, layout-option, ...] + -- + -- Set the comment layout. By default, comments use the GNAT style + -- comment line indentation. + -- + -- layout-option may be one of the following: + -- + -- UNTOUCHED All the comments remain unchanged + -- DEFAULT (D) GNAT style comment line indentation + -- STANDARD_INDENT Standard comment line indentation + -- GNAT_BEGINNING GNAT style comment beginning + -- REFORMAT Reformat comment blocks + -- KEEP_SPECIAL Keep unchanged special form comments + -- + -- All combinations of layout options are allowed, except for DEFAULT + -- and STANDARD_INDENT which are mutually exclusive, and also if + -- UNTOUCHED is specified, this must be the only option. + -- + -- The difference between "GNAT style comment line indentation" and + -- "standard comment line indentation" is the following: for standard + -- comment indentation, any comment line is indented as if it were + -- a declaration or statement at the same place. + -- For GNAT style comment indentation, comment lines which are + -- immediately followed by if or case statement alternative, record + -- variant or 'begin' keyword are indented as the keyword that follows + -- them.: + -- + -- Standard indentation: + -- + -- if A then + -- null; + -- -- some comment + -- else + -- null; + -- end if; + -- + -- GNAT style indentation: + -- + -- if A then + -- null; + -- -- some comment + -- else + -- null; + -- end if; + -- + -- Option "GNAT style comment beginning" means that for each comment + -- which is not considered as non-formattable separator (that is, the + -- comment line contains only dashes, or a comment line ends with two + -- dashes), there will be at least two spaces between starting "--" and + -- the first non-blank character of the comment. + + S_Pretty_Config : aliased constant S := "/CONFIGURATION_PRAGMAS_FILE=<" & + "-gnatec>"; + -- /CONFIGURATION_PRAGMAS_FILE=file + -- + -- Specify a configuration pragmas file that need to be passed to the + -- compiler. + + S_Pretty_Constr : aliased constant S := "/CONSTRUCT_LAYOUT=" & + "GNAT " & + "-l1 " & + "COMPACT " & + "-l2 " & + "UNCOMPACT " & + "-l3"; + -- /CONSTRUCT_LAYOUT[=construct-option] + -- + -- Set construct layout. Default is GNAT style layout. + -- construct-option may be one of the following: + -- + -- GNAT (D) + -- COMPACT + -- UNCOMPACT + -- + -- The difference between GNAT style and Compact layout on one hand + -- and Uncompact layout on the other hand can be illustrated by the + -- following examples: + -- + -- GNAT style and Uncompact layout + -- Compact layout + -- + -- type q is record type q is + -- a : integer; record + -- b : integer; a : integer; + -- end record; b : integer; + -- end record; + -- + -- + -- Block : declare Block : + -- A : Integer := 3; declare + -- begin A : Integer := 3; + -- Proc (A, A); begin + -- end Block; Proc (A, A); + -- end Block; + -- + -- Clear : for J in 1 .. 10 loop Clear : + -- A (J) := 0; for J in 1 .. 10 loop + -- end loop Clear; A (J) := 0; + -- end loop Clear; + -- + -- + -- A further difference between GNAT style layout and compact layout is + -- that in GNAT style layout compound statements, return statements and + -- bodies are always separated by empty lines. + + S_Pretty_Comind : aliased constant S := "/CONTINUATION_INDENT=#" & + "-cl#"; + -- /CONTINUATION_INDENT=nnn + -- + -- Indentation level for continuation lines, nnn from 1 .. 9. + -- The default value is one less then the (normal) indentation level, + -- unless the indentation is set to 1: in that case the default value for + -- continuation line indentation is also 1. + + S_Pretty_Compact_Is : aliased constant S := "/NO_SEPARATE_IS " & + "--no-separate-is"; + -- /NO_SEPARATE_IS + -- + -- Do not place the IS keyword on a separate line in a subprogram body in + -- case if the specification occupies more then one line. + + S_Pretty_Sep_Label : aliased constant S := "/SEPARATE_LABEL " & + "--separate-label"; + -- /SEPARATE_LABEL + -- + -- Place statement label(s) and the statement itself on separate lines. + + S_Pretty_Sep_Loop_Then : aliased constant S := "/SEPARATE_LOOP_THEN " & + "--separate-loop-then"; + -- /SEPARATE_LOOP_THEN + -- + -- Place the THEN keyword in IF statement and the LOOP keyword in for- + -- and while-loops on a separate line. + + S_Pretty_N_Sep_Loop_Then : aliased constant S := "/NO_SEPARATE_LOOP_THEN " & + "--no-separate-loop-then"; + -- /NO_SEPARATE_LOOP_THEN + -- + -- Do not place the THEN keyword in IF statement and the LOOP keyword in + -- for- and while-loops on a separate line. + + S_Pretty_Use_On_New_Line : aliased constant S := "/USE_ON_NEW_LINE " & + "--use-on-new-line"; + -- /USE_ON_NEW_LINE + -- + -- Start any USE clause that is a part of a context clause from a + -- separate line. + + S_Pretty_Stnm_On_Nw_Line : aliased constant S := "/STMT_NAME_ON_NEW_LINE " & + "--separate-stmt-name"; + -- /STMT_NAME_ON_NEW_LINE + -- + -- For named block and loop statements use a separate line for the + -- statement name, but do not use an extra indentation level for the + -- statement itself. + + S_Pretty_Eol : aliased constant S := "/END_OF_LINE=" & + "DOS " & + "--eol=dos " & + "UNIX " & + "--eol=unix " & + "CRLF " & + "--eol=crlf " & + "LF " & + "--eol=lf"; + -- /END_OF_LINE=[option] + -- + -- Specifies the form of the line terminators in the produced source. + -- By default, the form of the line terminator depends on the platforms. + -- On Unix and VMS, it is a Line Feed (LF) character. On Windows (DOS), + -- It is a Carriage Return (CR) followed by a Line Feed. + -- The Options DOS and CRLF are equivalent. The options UNIX and LF are + -- also equivalent. + + S_Pretty_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & + "-X" & '"'; + -- /EXTERNAL_REFERENCE="name=val" + -- + -- Specifies an external reference to the project manager. Useful only if + -- /PROJECT_FILE is used. + -- + -- Example: + -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + + S_Pretty_Current : aliased constant S := "/CURRENT_DIRECTORY " & + "!-I-"; + -- /CURRENT_DIRECTORY (D) + -- + -- Look for source files in the current working directory. + -- + -- /NOCURRENT_DIRECTORY + -- Do not look for source files in the current working directory. + + S_Pretty_Dico : aliased constant S := "/DICTIONARY=*" & + "-D*"; + -- /DICTIONARY=(file_name, ...) + -- + -- Use each specified file as a dictionary file that defines the casing + -- for a set of specified names, thereby overriding the effect on these + -- names by any explicit or implicit /NAME_CASING qualifier. + -- + -- GNAT PRETTY implicitly uses a default dictionary file to define the + -- casing for the Ada predefined names and the names declared in the GNAT + -- libraries. + -- + -- The structure of a dictionary file, and details on the conventions + -- used in the default dictionary file, are defined in the GNAT User's + -- Guide. + + S_Pretty_Encoding : aliased constant S := "/RESULT_ENCODING=" & + "BRACKETS " & + "-Wb " & + "HEX " & + "-Wh " & + "UPPER " & + "-Wu " & + "SHIFT_JIS " & + "-Ws " & + "EUC " & + "-We " & + "UTF8 " & + "-W8"; + -- /RESULT_ENCODING[=encoding-type] + -- + -- Specify the wide character encoding method used when writing the + -- reformatted code in the result file. 'encoding-type' is one of the + -- following: + -- + -- BRACKETS (D) Brackets encoding. + -- + -- HEX Hex ESC encoding. + -- + -- UPPER Upper half encoding. + -- + -- SHIFT_JIS Shift-JIS encoding. + -- + -- EUC EUC Encoding. + -- + -- UTF8 UTF-8 encoding. + -- + -- See 'HELP GNAT COMPILE /WIDE_CHARACTER_ENCODING' for an explanation + -- about the different character encoding methods. + + S_Pretty_Files : aliased constant S := "/FILES=@" & + "-files=@"; + -- /FILES=filename + -- + -- Take as arguments the files that are listed in the specified + -- text file. + + S_Pretty_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + + S_Pretty_Forced : aliased constant S := "/FORCED_OUTPUT=@" & + "-of@"; + -- /FORCED_OUTPUT=file + -- + -- Write the output into the specified file, overriding any possibly + -- existing file. + + S_Pretty_Formfeed : aliased constant S := "/FORM_FEED_AFTER_PRAGMA_PAGE " & + "-ff"; + -- /FORM_FEED_AFTER_PRAGMA_PAGE + -- + -- When there is a pragma Page in the source, insert a Form Feed + -- character immediately after the semicolon that follows the pragma + -- Page. + + S_Pretty_Indent : aliased constant S := "/INDENTATION_LEVEL=#" & + "-i#"; + -- /INDENTATION_LEVEL=nnn + -- + -- Specify the number of spaces to add for each indentation level. + -- nnn must be between 1 and 9. The default is 3. + + S_Pretty_Keyword : aliased constant S := "/KEYWORD_CASING=" & + "LOWER_CASE " & + "-kL " & + "UPPER_CASE " & + "-kU"; + -- /KEYWORD_CASING[=keyword-option] + -- + -- Specify the case of Ada keywords. The default is keywords in lower + -- case. + -- + -- keyword-option may be one of the following: + -- + -- LOWER_CASE (D) + -- UPPER_CASE + + S_Pretty_Maxlen : aliased constant S := "/LINE_LENGTH_MAX=#" & + "-M#"; + -- /LINE_LENGTH_MAX=nnn + -- + -- Set the maximum line length, nnn from 32 ..256. The default is 79. + + S_Pretty_Maxind : aliased constant S := "/MAX_INDENT=#" & + "-T#"; + -- /MAX_INDENT=nnn + -- + -- Do not use an additional indentation level for case alternatives + -- and variants if their number is nnn or more. The default is 10. + -- If nnn is zero, an additional indentation level is used for any + -- number of case alternatives and variants. + + S_Pretty_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & + "DEFAULT " & + "-vP0 " & + "MEDIUM " & + "-vP1 " & + "HIGH " & + "-vP2"; + -- /MESSAGES_PROJECT_FILE[=messages-option] + -- + -- Specifies the "verbosity" of the parsing of project files. + -- messages-option may be one of the following: + -- + -- DEFAULT (D) No messages are output if there is no error or warning. + -- + -- MEDIUM A small number of messages are output. + -- + -- HIGH A great number of messages are output, most of them not + -- being useful for the user. + + S_Pretty_Names : aliased constant S := "/NAME_CASING=" & + "AS_DECLARED " & + "-nD " & + "LOWER_CASE " & + "-nL " & + "UPPER_CASE " & + "-nU " & + "MIXED_CASE " & + "-nM"; + -- /NAME_CASING[=name-option] + -- + -- Specify the casing of names. + -- 'name-option' may be one of: + -- + -- AS_DECLARED (D) Name casing for defining occurrences are as they + -- appear in the source file. + -- + -- LOWER_CASE Names are in lower case. + -- + -- UPPER_CASE Names are in upper case. + -- + -- MIXED_CASE Names are in mixed case. + + S_Pretty_Replace_No_Backup : aliased constant S := "/REPLACE_NO_BACKUP " & + "-rnb"; + -- /REPLACE_NO_BACKUP + -- + -- Replace the argument source with the pretty-printed source without + -- creating any backup copy of the argument source. + + S_Pretty_No_Labels : aliased constant S := "/NO_MISSED_LABELS " & + "-e"; + -- /NO_MISSED_LABELS + -- + -- Do not insert missing end/exit labels. The end label is the name of + -- a construct that may optionally appear at the end of the construct. + -- This includes the names of packages and subprograms. + -- Similarly, the exit label is the name of a loop that may appear as the + -- argument of an exit statement within the loop. By default, GNAT PRETTY + -- inserts these end/exit labels when they are absent in the original + -- source. This qualifier /NO_MISSED_LABELS suppresses this insertion, + -- so that the formatted source reflects the original. + + S_Pretty_Notabs : aliased constant S := "/NOTABS " & + "-notabs"; + -- /NOTABS + -- + -- Replace all tabulations in comments with spaces. + + S_Pretty_Output : aliased constant S := "/OUTPUT=@" & + "-o@"; + -- /OUTPUT=file + -- + -- Write the output to the specified file. If the file already exists, + -- an error is reported. + + S_Pretty_Override : aliased constant S := "/OVERRIDING_REPLACE " & + "-rf"; + -- /NOOVERRIDING_REPLACE (D) + -- /OVERRIDING_REPLACE + -- + -- Replace the argument source with the pretty-printed source and copy the + -- argument source into filename.NPP, overriding any existing file if + -- needed. + + S_Pretty_Pragma : aliased constant S := "/PRAGMA_CASING=" & + "MIXED_CASE " & + "-pM " & + "LOWER_CASE " & + "-pL " & + "UPPER_CASE " & + "-pU"; + -- /PRAGMA_CASING[=pragma-option] + -- + -- Set the case of pragma identifiers. The default is Mixed case. + -- pragma-option may be one of the following: + -- + -- MIXED_CASE (D) + -- LOWER_CASE + -- UPPER_CASE + + S_Pretty_Project : aliased constant S := "/PROJECT_FILE=<" & + "-P>"; + -- /PROJECT_FILE=filename + -- + -- Specifies the main project file to be used. The project files rooted + -- at the main project file will be parsed before any other processing to + -- set the building environment. + + S_Pretty_Replace : aliased constant S := "/REPLACE " & + "-r"; + -- /NOREPLACE (D) + -- /REPLACE + -- + -- Replace the argument source with the pretty-printed source and copy the + -- argument source into filename.NPP. If filename.NPP already exists, + -- report an error and exit. + + S_Pretty_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" & + "--RTS=|"; + -- /RUNTIME_SYSTEM=xxx + -- + -- Compile against an alternate runtime system named xxx or RTS-xxx. + + S_Pretty_Search : aliased constant S := "/SEARCH=*" & + "-I*"; + -- /SEARCH=(directory[,...]) + -- + -- When looking for source files also look in directories specified. + + S_Pretty_Specific : aliased constant S := "/SPECIFIC_CASING " & + "-D-"; + -- /SPECIFIC_CASING + -- + -- Do not use the default dictionary file; instead, use the casing + -- defined by a qualifier /NAME_CASING and/or any explicit dictionary + -- file specified by a qualifier /DICTIONARY. + + S_Pretty_Standard : aliased constant S := "/STANDARD_OUTPUT " & + "-pipe"; + -- /NOSTANDARD_OUTPUT (D) + -- /STANDARD_OUTPUT + -- + -- Redirect the output to the standard output. + + S_Pretty_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + + S_Pretty_Verbose : aliased constant S := "/VERBOSE " & + "-v"; + -- /NOVERBOSE (D) + -- /VERBOSE + -- + -- Verbose mode; GNAT PRETTY generates version information and then a + -- trace of the actions it takes to produce or obtain the ASIS tree. + + S_Pretty_Warnings : aliased constant S := "/WARNINGS " & + "-w"; + -- /NOWARNINGS (D) + -- /WARNINGS + -- + -- Issue a warning to the standard error stream if it is not possible + -- to provide the required layout in the result source. + -- By default such warnings are not activated. + + Pretty_Switches : aliased constant Switches := + (S_Pretty_Add 'Access, + S_Pretty_Align 'Access, + S_Pretty_All_Prjs 'Access, + S_Pretty_Attrib 'Access, + S_Pretty_Comments 'Access, + S_Pretty_Compact_Is 'Access, + S_Pretty_Config 'Access, + S_Pretty_Constr 'Access, + S_Pretty_Comind 'Access, + S_Pretty_Current 'Access, + S_Pretty_Dico 'Access, + S_Pretty_Eol 'Access, + S_Pretty_Ext 'Access, + S_Pretty_Encoding 'Access, + S_Pretty_Files 'Access, + S_Pretty_Follow 'Access, + S_Pretty_Forced 'Access, + S_Pretty_Formfeed 'Access, + S_Pretty_Indent 'Access, + S_Pretty_Keyword 'Access, + S_Pretty_Maxlen 'Access, + S_Pretty_Maxind 'Access, + S_Pretty_Mess 'Access, + S_Pretty_Names 'Access, + S_Pretty_No_Labels 'Access, + S_Pretty_Notabs 'Access, + S_Pretty_Output 'Access, + S_Pretty_Override 'Access, + S_Pretty_Pragma 'Access, + S_Pretty_Replace 'Access, + S_Pretty_Replace_No_Backup'Access, + S_Pretty_Project 'Access, + S_Pretty_RTS 'Access, + S_Pretty_Search 'Access, + S_Pretty_Sep_Label 'Access, + S_Pretty_Sep_Loop_Then 'Access, + S_Pretty_N_Sep_Loop_Then 'Access, + S_Pretty_Subdirs 'Access, + S_Pretty_Use_On_New_Line 'Access, + S_Pretty_Stnm_On_Nw_Line 'Access, + S_Pretty_Specific 'Access, + S_Pretty_Standard 'Access, + S_Pretty_Verbose 'Access, + S_Pretty_Warnings 'Access); + + ------------------------------ + -- Switches for GNAT SHARED -- + ------------------------------ + + S_Shared_Debug : aliased constant S := "/DEBUG=" & + "ALL " & + "-g3 " & + "NONE " & + "-g0 " & + "TRACEBACK " & + "-g1 " & + "NOTRACEBACK " & + "-g0"; + -- /DEBUG[=debug-option] + -- /NODEBUG + -- + -- Specifies the amount of debugging information included. 'debug-option' + -- is one of the following: + -- + -- ALL (D) Include full debugging information. + -- + -- NONE Provide no debugging information. Same as /NODEBUG. + -- + -- TRACEBACK Provide sufficient debug information for a traceback. + -- + -- NOTRACEBACK Same as NONE. + + S_Shared_Image : aliased constant S := "/IMAGE=@" & + "-o@"; + -- /IMAGE=image-name + -- + -- 'image-name' specifies the name for the generated shared library. + + S_Shared_Ident : aliased constant S := "/IDENTIFICATION=" & '"' & + "--for-linker=IDENT=" & + '"'; + -- /IDENTIFICATION="" + -- + -- "" specifies the string to be stored in the image file ident- + -- ification field in the image header. It overrides any pragma Ident + -- specified string. + + S_Shared_Nofiles : aliased constant S := "/NOSTART_FILES " & + "-nostartfiles"; + -- /NOSTART_FILES + -- + -- Link in default image initialization and startup functions. + + S_Shared_Noinhib : aliased constant S := "/NOINHIBIT-IMAGE " & + "--for-linker=--noinhibit-exec"; + -- /NOINHIBIT-IMAGE + -- + -- Delete image if there are errors or warnings. + + S_Shared_Verb : aliased constant S := "/VERBOSE " & + "-v"; + -- /NOVERBOSE (D) + -- /VERBOSE + -- + -- Causes additional information to be output, including a full list of + -- the included object files. This switch option is most useful when you + -- want to see what set of object files are being used in the link step. + + S_Shared_ZZZZZ : aliased constant S := "/ " & + "--for-linker="; + -- / + -- + -- Any other switch transmitted to the underlying linker. + + Shared_Switches : aliased constant Switches := + (S_Shared_Debug 'Access, + S_Shared_Image 'Access, + S_Shared_Ident 'Access, + S_Shared_Nofiles 'Access, + S_Shared_Noinhib 'Access, + S_Shared_Verb 'Access, + S_Shared_ZZZZZ 'Access); + + ----------------------------- + -- Switches for GNAT STACK -- + ----------------------------- + + S_Stack_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & + "-aP*"; + -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) + -- + -- Add directories to the project search path. + + S_Stack_All : aliased constant S := "/ALL_SUBPROGRAMS " & + "-a"; + -- /NOALL_SUBPROGRAMS (D) + -- /ALL_SUBPROGRAMS + -- + -- Consider all subprograms as entry points. + + S_Stack_All_Cycles : aliased constant S := "/ALL_CYCLES " & + "-ca"; + -- /NOALL_CYCLES (D) + -- /ALL_CYCLES + -- + -- Extract all possible cycles in the call graph. + + S_Stack_All_Prjs : aliased constant S := "/ALL_PROJECTS " & + "-U"; + -- /NOALL_PROJECTS (D) + -- /ALL_PROJECTS + -- + -- When GNAT STACK is used with a Project File and no source is + -- specified, the underlying tool gnatstack is called for all the + -- units of all the Project Files in the project tree. + + S_Stack_Debug : aliased constant S := "/DEBUG " & + "-g"; + -- /NODEBUG (D) + -- /DEBUG + -- + -- Generate internal debug information. + + S_Stack_Directory : aliased constant S := "/DIRECTORY=*" & + "-aO*"; + -- /DIRECTORY=(direc[,...]) + -- + -- When looking for .ci files look also in directories specified. + + S_Stack_Entries : aliased constant S := "/ENTRIES=*" & + "-e*"; + -- + -- /ENTRY=(entry_point[,...]) + -- + -- Name of symbol to be used as entry point for the analysis. + + S_Stack_Files : aliased constant S := "/FILES=@" & + "-files=@"; + -- /FILES=filename + -- + -- Take as arguments the files that are listed in the specified + -- text file. + + S_Stack_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + + S_Stack_Help : aliased constant S := "/HELP " & + "-h"; + -- /NOHELP (D) + -- /HELP + -- + -- Output a message explaining the usage of gnatstack. + + S_Stack_List : aliased constant S := "/LIST=#" & + "-l#"; + -- /LIST=nnn + -- + -- Print the nnn subprograms requiring the biggest local stack usage. By + -- default none will be displayed. + + S_Stack_Order : aliased constant S := "/ORDER=" & + "STACK " & + "-os " & + "ALPHABETICAL " & + "-oa"; + -- /ORDER[=order-option] + -- + -- Specifies the order for displaying the different call graphs. + -- order-option may be one of the following: + -- + -- STACK (D) Select stack usage order + -- + -- ALPHABETICAL Select alphabetical order + + S_Stack_Path : aliased constant S := "/PATH " & + "-p"; + -- /NOPATH (D) + -- /PATH + -- + -- Print all the subprograms that make up the worst-case path for every + -- entry point. + + S_Stack_Project : aliased constant S := "/PROJECT_FILE=<" & + "-P>"; + -- /PROJECT_FILE=filename + -- + -- Specifies the main project file to be used. The project files rooted + -- at the main project file will be parsed before the invocation of + -- gnatstack. + + S_Stack_Output : aliased constant S := "/OUTPUT=@" & + "-f@"; + -- /OUTPUT=filename + -- + -- Name of the file containing the generated graph (VCG format). + + S_Stack_Regexp : aliased constant S := "/EXPRESSION=|" & + "-r|"; + -- + -- /EXPRESSION=regular-expression + -- + -- Any symbol matching the regular expression will be considered as a + -- potential entry point for the analysis. + + S_Stack_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + + S_Stack_Unbounded : aliased constant S := "/UNBOUNDED=#" & + "-d#"; + -- /UNBOUNDED=nnn + -- + -- Default stack size to be used for unbounded (dynamic) frames. + + S_Stack_Unknown : aliased constant S := "/UNKNOWN=#" & + "-u#"; + -- /UNKNOWN=nnn + -- + -- Default stack size to be used for unknown (external) calls. + + S_Stack_Verbose : aliased constant S := "/VERBOSE " & + "-v"; + -- /NOVERBOSE (D) + -- /VERBOSE + -- + -- Specifies the amount of information to be displayed about the + -- different subprograms. In verbose mode the full location of the + -- subprogram will be part of the output, as well as detailed information + -- about inaccurate data. + + S_Stack_Warnings : aliased constant S := "/WARNINGS=" & + "ALL " & + "-Wa " & + "CYCLES " & + "-Wc " & + "UNBOUNDED " & + "-Wu " & + "EXTERNAL " & + "-We " & + "INDIRECT " & + "-Wi"; + -- /WARNINGS[=(keyword[,...])] + -- + -- The following keywords are supported: + -- + -- ALL Turn on all optional warnings + -- + -- CYCLES Turn on warnings for cycles + -- + -- UNBOUNDED Turn on warnings for unbounded frames + -- + -- EXTERNAL Turn on warnings for external calls + -- + -- INDIRECT Turn on warnings for indirect calls + + Stack_Switches : aliased constant Switches := + (S_Stack_Add 'Access, + S_Stack_All 'Access, + S_Stack_All_Cycles 'Access, + S_Stack_All_Prjs 'Access, + S_Stack_Debug 'Access, + S_Stack_Directory 'Access, + S_Stack_Entries 'Access, + S_Stack_Files 'Access, + S_Stack_Follow 'Access, + S_Stack_Help 'Access, + S_Stack_List 'Access, + S_Stack_Order 'Access, + S_Stack_Path 'Access, + S_Stack_Project 'Access, + S_Stack_Output 'Access, + S_Stack_Regexp 'Access, + S_Stack_Subdirs 'Access, + S_Stack_Unbounded 'Access, + S_Stack_Unknown 'Access, + S_Stack_Verbose 'Access, + S_Stack_Warnings 'Access); + + ---------------------------- + -- Switches for GNAT STUB -- + ---------------------------- + + S_Stub_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & + "-aP*"; + -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) + -- + -- Add directories to the project search path. + + S_Stub_Config : aliased constant S := "/CONFIGURATION_PRAGMAS_FILE=<" & + "-gnatec>"; + -- /CONFIGURATION_PRAGMAS_FILE=filespec + -- + -- Specifies a configuration pragmas file that must be taken into account + -- when compiling. + + S_Stub_Current : aliased constant S := "/CURRENT_DIRECTORY " & + "!-I-"; + -- /CURRENT_DIRECTORY (D) + -- /NOCURRENT_DIRECTORY + -- + -- Look for source, library or object files in the default directory. + + S_Stub_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & + "-X" & '"'; + -- /EXTERNAL_REFERENCE="name=val" + -- + -- Specifies an external reference to the project manager. Useful only if + -- /PROJECT_FILE is used. + -- + -- Example: + -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + + S_Stub_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + + S_Stub_Full : aliased constant S := "/FULL " & + "-f"; + -- /NOFULL (D) + -- /FULL + -- + -- If the destination directory already contains a file with the name of + -- the body file for the argument file spec, replace it with the generated + -- body stub. If /FULL is not used and there is already a body file, this + -- existing body file is not replaced. + + S_Stub_Header : aliased constant S := "/HEADER=" & + "GENERAL " & + "-hg " & + "SPEC " & + "-hs"; + -- /HEADER[=header-option] + -- + -- Specifies the form of the comment header above the generated body stub. + -- If no /HEADER qualifier is specified, there is no comment header. + -- header-option is one of the following: + -- + -- + -- GENERAL (D) Put a sample comment header into the body stub. + -- + -- SPEC Put the comment header (i.e., all the comments + -- preceding the compilation unit) from the source of the + -- library unit declaration into the body stub. + + S_Stub_Header_File : aliased constant S := "/FROM_HEADER_FILE=<" & + "--header-file=>"; + + -- /FROM_HEADER_FILE==filename + -- + -- Use the content of the file as the comment header for a generated body + -- stub. + + S_Stub_Indent : aliased constant S := "/INDENTATION=#" & + "-i#"; + -- /INDENTATION=nnn + -- + -- (nnn is a non-negative integer). Set the indentation level in the + -- generated body stub to nnn. nnn=0 means "no indentation". + -- Default indentation is 3. + + S_Stub_Keep : aliased constant S := "/KEEP " & + "-k"; + -- /NOKEEP (D) + -- /KEEP + -- + -- Do not delete the tree file (i.e., the snapshot of the compiler + -- internal structures used by gnatstub) after creating the body stub. + + S_Stub_Length : aliased constant S := "/LINE_LENGTH=#" & + "-l#"; + -- /LINE_LENGTH=nnn + -- + -- (n is a non-negative integer). Set the maximum line length in the body + -- stub to nnn. Default is 78. + + S_Stub_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & + "DEFAULT " & + "-vP0 " & + "MEDIUM " & + "-vP1 " & + "HIGH " & + "-vP2"; + -- /MESSAGES_PROJECT_FILE[=messages-option] + -- + -- Specifies the "verbosity" of the parsing of project files. + -- messages-option may be one of the following: + -- + -- DEFAULT (D) No messages are output if there is no error or warning. + -- + -- MEDIUM A small number of messages are output. + -- + -- HIGH A great number of messages are output, most of them not + -- being useful for the user. + + S_Stub_No_Exc : aliased constant S := "/NO_EXCEPTION " & + "--no-exception"; + -- /NONO_EXCEPTION (D) + -- /NO_EXCEPTION + -- + -- Avoid raising PROGRAM_ERROR in the generated program unit stubs. + + S_Stub_No_Head : aliased constant S := "/NO_LOCAL_HEADER " & + "--no-local-header"; + -- /NONO_LOCAL_HEADER (D) + -- /NO_LOCAL_HEADER + -- + -- Do not put local comment header before body stub for local program unit. + + S_Stub_Output : aliased constant S := "/OUTPUT=@" & + "-o@"; + -- /OUTPUT=filespec + -- + -- Body file name. This should be set if the argument file name does not + -- follow the GNAT file naming conventions. If this switch is omitted, + -- the default name for the body will be obtained from the argument file + -- name according to the GNAT file naming conventions. + + S_Stub_Project : aliased constant S := "/PROJECT_FILE=<" & + "-P>"; + -- /PROJECT_FILE=filename + -- + -- Specifies the main project file to be used. The project files rooted + -- at the main project file will be parsed before any other processing. + -- The source and object directories to be searched will be communicated + -- to gnatstub through logical names ADA_PRJ_INCLUDE_FILE and + -- ADA_PRJ_OBJECTS_FILE. + + S_Stub_Quiet : aliased constant S := "/QUIET " & + "-q"; + -- /NOQUIET (D) + -- /QUIET + -- + -- Quiet mode: do not generate a confirmation when a body is successfully + -- created, and do not generate a message when a body is not required for + -- an argument unit. + + S_Stub_Search : aliased constant S := "/SEARCH=*" & + "-I*"; + -- /SEARCH=(directory[,...]) + -- + -- When looking for source files also look in directories specified. + + S_Stub_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + + S_Stub_Tree : aliased constant S := "/TREE_FILE=" & + "OVERWRITE " & + "-t " & + "SAVE " & + "-k " & + "REUSE " & + "-r"; + -- /TREE_FILE[=treefile-option] + -- + -- Specify what to do with the tree file. + -- treefile-option is one of the following: + -- + -- OVERWRITE (D) Overwrite the existing tree file. If the current + -- directory already contains the file which, according + -- to the GNAT file naming rules should be considered + -- as a tree file for the argument source file, gnatstub + -- will refuse to create the tree file needed to create + -- a sample body unless this option is chosen. + -- + -- SAVE Do not remove the tree file (i.e., the snapshot + -- of the compiler internal structures used by gnatstub) + -- after creating the body stub. + -- + -- REUSE Reuse the tree file (if it exists) instead of + -- creating it. + -- Instead of creating the tree file for the library + -- unit declaration, gnatstub tries to find it in the + -- current directory and use it for creating a body. + -- If the tree file is not found, no body is created. + -- This option also implies `SAVE', whether or not the + -- latter is set explicitly. + + S_Stub_Verbose : aliased constant S := "/VERBOSE " & + "-v"; + -- /NOVERBOSE (D) + -- /VERBOSE + -- + -- Verbose mode: generate version information. + + Stub_Switches : aliased constant Switches := + (S_Stub_Add 'Access, + S_Stub_Config 'Access, + S_Stub_Current 'Access, + S_Stub_Ext 'Access, + S_Stub_Follow 'Access, + S_Stub_Full 'Access, + S_Stub_Header 'Access, + S_Stub_Header_File'Access, + S_Stub_Indent 'Access, + S_Stub_Keep 'Access, + S_Stub_Length 'Access, + S_Stub_Mess 'Access, + S_Stub_Output 'Access, + S_Stub_Project 'Access, + S_Stub_No_Exc 'Access, + S_Stub_No_Head 'Access, + S_Stub_Quiet 'Access, + S_Stub_Search 'Access, + S_Stub_Subdirs 'Access, + S_Stub_Tree 'Access, + S_Stub_Verbose 'Access); + + ---------------------------- + -- Switches for GNAT SYNC -- + ---------------------------- + + S_Sync_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & + "-aP*"; + -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) + -- + -- Add directories to the project search path. + + S_Sync_All : aliased constant S := "/ALL " & + "-a"; + -- /NOALL (D) + -- /ALL + -- + -- Also check the components of the GNAT run time and process the needed + -- components of the GNAT RTL when building and analyzing the global + -- structure for checking the global rules. + + S_Sync_Allproj : aliased constant S := "/ALL_PROJECTS " & + "-U"; + -- /NOALL_PROJECTS (D) + -- /ALL_PROJECTS + -- + -- When GNAT SYNC is used with a Project File and no source is + -- specified, the underlying tool gnatsync is called for all the + -- sources of all the Project Files in the project tree. + + S_Sync_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & + "-X" & '"'; + -- /EXTERNAL_REFERENCE="name=val" + -- + -- Specifies an external reference to the project manager. Useful only if + -- /PROJECT_FILE is used. + -- + -- Example: + -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + + S_Sync_Files : aliased constant S := "/FILES=@" & + "-files=@"; + -- /FILES=filename + -- + -- Take as arguments the files that are listed in the specified + -- text file. + + S_Sync_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + + S_Sync_Main : aliased constant S := "/MAIN_SUBPROGRAM=@" & + "-main=@"; + -- /MAIN_SUBPROGRAM=filename + -- + -- Specify the name of the file containing the main subprogram + + S_Sync_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & + "DEFAULT " & + "-vP0 " & + "MEDIUM " & + "-vP1 " & + "HIGH " & + "-vP2"; + -- /MESSAGES_PROJECT_FILE[=messages-option] + -- + -- Specifies the "verbosity" of the parsing of project files. + -- messages-option may be one of the following: + -- + -- DEFAULT (D) No messages are output if there is no error or warning. + -- + -- MEDIUM A small number of messages are output. + -- + -- HIGH A great number of messages are output, most of them not + -- being useful for the user. + + S_Sync_Project : aliased constant S := "/PROJECT_FILE=<" & + "-P>"; + -- /PROJECT_FILE=filename + -- + -- Specifies the main project file to be used. The project files rooted + -- at the main project file will be parsed before the invocation of the + -- gnatcheck. The source directories to be searched will be communicated + -- to gnatcheck through logical name ADA_PRJ_INCLUDE_FILE. + + S_Sync_Quiet : aliased constant S := "/QUIET " & + "-q"; + -- /NOQUIET (D) + -- /QUIET + -- + -- Work quietly, only output warnings and errors. + + S_Sync_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + + S_Sync_Verb : aliased constant S := "/VERBOSE " & + "-v"; + -- /NOVERBOSE (D) + -- /VERBOSE + -- + -- The version number and copyright notice are output, as well as exact + -- copies of the gnat1 commands spawned to obtain the chop control + -- information. + + S_Sync_Exec : aliased constant S := "/EXECUTION_TIME " & + "-t"; + -- /NOEXECUTION_TIME (D) + -- /EXECUTION_TIME + -- + -- Output the execution time + + S_Sync_Details : aliased constant S := "/DETAILS=" & + "MEDIUM " & + "-om " & + "SHORT " & + "-os " & + "FULL " & + "-of"; + -- /DETAILS[=options] + -- + -- Specifies the details of the output. + -- Options may be one of the following: + -- + -- MEDIUM (D) + -- SHORT + -- FULL + + S_Sync_Warnoff : aliased constant S := "/WARNINGS_OFF " & + "-wq"; + -- + -- /WARNINGS_OFF + -- + -- Turn warnings off + + S_Sync_Output : aliased constant S := "/OUTPUT_FILE=<" & + "-out_file=>"; + -- + -- /OUTPUT_FILE=filename + -- + -- Redirect output to a text file + + Sync_Switches : aliased constant Switches := + (S_Sync_Add 'Access, + S_Sync_All 'Access, + S_Sync_Allproj 'Access, + S_Sync_Ext 'Access, + S_Sync_Follow 'Access, + S_Sync_Files 'Access, + S_Sync_Main 'Access, + S_Sync_Mess 'Access, + S_Sync_Project 'Access, + S_Sync_Quiet 'Access, + S_Sync_Subdirs 'Access, + S_Sync_Verb 'Access, + S_Sync_Exec 'Access, + S_Sync_Details 'Access, + S_Sync_Warnoff 'Access, + S_Sync_Output 'Access); + + ---------------------------- + -- Switches for GNAT XREF -- + ---------------------------- + + S_Xref_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & + "-aP*"; + -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) + -- + -- Add directories to the project search path. + + S_Xref_All : aliased constant S := "/ALL_FILES " & + "-a"; + -- /NOALL_FILES (D) + -- /ALL_FILES + -- + -- If this switch is present, FIND and XREF will parse the read-only + -- files found in the library search path. Otherwise, these files will + -- be ignored. This option can be used to protect Gnat sources or your + -- own libraries from being parsed, thus making FIND and XREF much + -- faster, and their output much smaller. + + S_Xref_Deriv : aliased constant S := "/DERIVED_TYPES " & + "-d"; + -- /NODERIVED_TYPES (D) + -- /DERIVED_TYPES + -- + -- Output the parent type reference for each matching derived types. + + S_Xref_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & + "-X" & '"'; + -- /EXTERNAL_REFERENCE="name=val" + -- + -- Specifies an external reference to the project manager. Useful only if + -- /PROJECT_FILE is used. + -- + -- Example: + -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + + S_Xref_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + + S_Xref_Full : aliased constant S := "/FULL_PATHNAME " & + "-f"; + -- /NOFULL_PATHNAME (D) + -- /FULL_PATHNAME + -- + -- If this switch is set, the output file names will be preceded by their + -- directory (if the file was found in the search path). If this switch + -- is not set, the directory will not be printed. + + S_Xref_Global : aliased constant S := "/IGNORE_LOCALS " & + "-g"; + -- /NOIGNORE_LOCALS (D) + -- /IGNORE_LOCALS + -- + -- If this switch is set, information is output only for library-level + -- entities, ignoring local entities. The use of this switch may + -- accelerate FIND and XREF. + + S_Xref_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & + "DEFAULT " & + "-vP0 " & + "MEDIUM " & + "-vP1 " & + "HIGH " & + "-vP2"; + -- /MESSAGES_PROJECT_FILE[=messages-option] + -- + -- Specifies the "verbosity" of the parsing of project files. + -- messages-option may be one of the following: + -- + -- DEFAULT (D) No messages are output if there is no error or warning. + -- + -- MEDIUM A small number of messages are output. + -- + -- HIGH A great number of messages are output, most of them not + -- being useful for the user. + + S_Xref_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & + "-nostdinc"; + -- /NOSTD_INCLUDES + -- + -- Do not look for sources in the system default directory. + + S_Xref_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " & + "-nostdlib"; + -- /NOSTD_LIBRARIES + -- + -- Do not look for library files in the system default directory. + + S_Xref_Object : aliased constant S := "/OBJECT_SEARCH=*" & + "-aO*"; + -- /OBJECT_SEARCH=(directory,...) + -- + -- When searching for library and object files, look in the specified + -- directories. The order in which library files are searched is the same + -- as for MAKE. + + S_Xref_Project : aliased constant S := "/PROJECT=@" & + "-p@"; + -- /PROJECT=file + -- + -- Specify a project file to use. By default, FIND and XREF will try to + -- locate a project file in the current directory. + -- + -- If a project file is either specified or found by the tools, then the + -- content of the source directory and object directory lines are added + -- as if they had been specified respectively by /SOURCE_SEARCH and + -- /OBJECT_SEARCH. + + S_Xref_Prj : aliased constant S := "/PROJECT_FILE=<" & + "-P>"; + -- /PROJECT_FILE=filename + -- + -- Specifies the main project file to be used. The project files rooted + -- at the main project file will be parsed before doing any processing. + -- The source and object directories to be searched will be communicated + -- to gnatxref through logical names ADA_PRJ_INCLUDE_FILE and + -- ADA_PRJ_OBJECTS_FILE. + + S_Xref_Search : aliased constant S := "/SEARCH=*" & + "-I*"; + -- /SEARCH=(directory,...) + -- + -- Equivalent to: + -- /OBJECT_SEARCH=(directory,...) /SOURCE_SEARCH=(directory,...) + + S_Xref_Source : aliased constant S := "/SOURCE_SEARCH=*" & + "-aI*"; + -- /SOURCE_SEARCH=(directory,...) + -- + -- When looking for source files also look in the specified directories. + -- The order in which source file search is undertaken is the same as for + -- MAKE. + + S_Xref_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + + S_Xref_Output : aliased constant S := "/UNUSED " & + "-u"; + -- /SOURCE_SEARCH=(directory,...) + -- + -- When looking for source files also look in the specified directories. + -- The order in which source file search is undertaken is the same as for + -- MAKE. + + S_Xref_Tags : aliased constant S := "/TAGS " & + "-v"; + -- /NOTAGS (D) + -- /TAGS + -- + -- Print a 'tags' file for vi. + + Xref_Switches : aliased constant Switches := + (S_Xref_Add 'Access, + S_Xref_All 'Access, + S_Xref_Deriv 'Access, + S_Xref_Ext 'Access, + S_Xref_Follow 'Access, + S_Xref_Full 'Access, + S_Xref_Global 'Access, + S_Xref_Mess 'Access, + S_Xref_Nostinc 'Access, + S_Xref_Nostlib 'Access, + S_Xref_Object 'Access, + S_Xref_Project 'Access, + S_Xref_Prj 'Access, + S_Xref_Search 'Access, + S_Xref_Source 'Access, + S_Xref_Subdirs 'Access, + S_Xref_Output 'Access, + S_Xref_Tags 'Access); + +end VMS_Data; diff --git a/gcc/ada/vx_stack_info.c b/gcc/ada/vx_stack_info.c new file mode 100644 index 000000000..a62589250 --- /dev/null +++ b/gcc/ada/vx_stack_info.c @@ -0,0 +1,61 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * V X _ S T A C K _ I N F O * + * * + * C Implementation File * + * * + * Copyright (C) 2007-2009 Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. * + * * + * As a special exception under Section 7 of GPL version 3, you are granted * + * additional permissions described in the GCC Runtime Library Exception, * + * version 3.1, as published by the Free Software Foundation. * + * * + * You should have received a copy of the GNU General Public License and * + * a copy of the GCC Runtime Library Exception along with this program; * + * see the files COPYING3 and COPYING.RUNTIME respectively. 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-specific file to have access to task-specific data and be able + to extract the stack boundaries for stack checking. */ + +#include + +typedef struct +{ + int size; + char *base; + char *end; +} stack_info; + +/* __gnat_get_stack_info is used by s-stchop.adb only for VxWorks. This + procedure fills the stack information associated to the currently + executing task. */ +extern void __gnat_get_stack_info (stack_info *vxworks_stack_info); + +void +__gnat_get_stack_info (stack_info *vxworks_stack_info) +{ + TASK_DESC descriptor; + + /* Ask the VxWorks kernel about stack values */ + taskInfoGet (taskIdSelf (), &descriptor); + + /* Fill the stack data with the information provided by the kernel */ + vxworks_stack_info->size = descriptor.td_stackSize; + vxworks_stack_info->base = descriptor.td_pStackBase; + vxworks_stack_info->end = descriptor.td_pStackEnd; +} diff --git a/gcc/ada/vxaddr2line.adb b/gcc/ada/vxaddr2line.adb new file mode 100644 index 000000000..f1bb48a74 --- /dev/null +++ b/gcc/ada/vxaddr2line.adb @@ -0,0 +1,481 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V X A D D R 2 L I N E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This program is meant to be used with vxworks to compute symbolic +-- backtraces on the host from non-symbolic backtraces obtained on the target. + +-- The basic idea is to automate the computation of the necessary address +-- adjustments prior to calling addr2line when the application has only been +-- partially linked on the host. + +-- Variants for various targets are supported, and the command line should +-- be like : + +-- -addr2line [-a ] +-- + +-- Where: +-- : +-- selects the target architecture. In the absence of this parameter the +-- default variant is chosen based on the Detect_Arch result. Generally, +-- this parameter will only be used if vxaddr2line is recompiled manually. +-- Otherwise, the command name will always be of the form +-- -vxaddr2line where there is no ambiguity on the target's +-- architecture. + +-- : +-- The name of the partially linked binary file for the application. + +-- : +-- Runtime address (on the target) of a reference symbol you choose, +-- which name shall match the value of the Ref_Symbol variable declared +-- below. A symbol with a small offset from the beginning of the text +-- segment is better, so "adainit" is a good choice. + +-- : +-- The call chain addresses you obtained at run time on the target and +-- for which you want a symbolic association. + +-- TO ADD A NEW ARCHITECTURE add an appropriate value to Architecture type +-- (in a format _), and then an appropriate value to Config_List +-- array + +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Strings.Fixed; use Ada.Strings.Fixed; +with Interfaces; use Interfaces; + +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.Expect; use GNAT.Expect; +with GNAT.Regpat; use GNAT.Regpat; + +procedure VxAddr2Line is + + package Unsigned_32_IO is new Modular_IO (Unsigned_32); + -- Instantiate Modular_IO to have Put + + Ref_Symbol : constant String := "adainit"; + -- This is the name of the reference symbol which runtime address shall + -- be provided as the argument. + + -- All supported architectures + type Architecture is + (SOLARIS_I586, + WINDOWS_POWERPC, + WINDOWS_I586, + WINDOWS_M68K, + SOLARIS_POWERPC, + DEC_ALPHA); + + type Arch_Record is record + Addr2line_Binary : String_Access; + -- Name of the addr2line utility to use + + Nm_Binary : String_Access; + -- Name of the host nm utility, which will be used to find out the + -- offset of the reference symbol in the text segment of the partially + -- linked executable. + + Addr_Digits_To_Skip : Integer; + -- When addresses such as 0xfffffc0001dfed50 are provided, for instance + -- on ALPHA, indicate the number of leading digits that can be ignored, + -- which will avoid computational overflows. Typically only useful when + -- 64bit addresses are provided. + + Bt_Offset_From_Call : Unsigned_32; + -- Offset from a backtrace address to the address of the corresponding + -- call instruction. This should always be 0, except on platforms where + -- the backtrace addresses actually correspond to return and not call + -- points. In such cases, a negative value is most likely. + end record; + + -- Configuration for each of the architectures + Arch_List : array (Architecture'Range) of Arch_Record := + (WINDOWS_POWERPC => + (Addr2line_Binary => null, + Nm_Binary => null, + Addr_Digits_To_Skip => 0, + Bt_Offset_From_Call => -4), + WINDOWS_M68K => + (Addr2line_Binary => null, + Nm_Binary => null, + Addr_Digits_To_Skip => 0, + Bt_Offset_From_Call => -4), + WINDOWS_I586 => + (Addr2line_Binary => null, + Nm_Binary => null, + Addr_Digits_To_Skip => 0, + Bt_Offset_From_Call => -2), + SOLARIS_POWERPC => + (Addr2line_Binary => null, + Nm_Binary => null, + Addr_Digits_To_Skip => 0, + Bt_Offset_From_Call => 0), + SOLARIS_I586 => + (Addr2line_Binary => null, + Nm_Binary => null, + Addr_Digits_To_Skip => 0, + Bt_Offset_From_Call => -2), + DEC_ALPHA => + (Addr2line_Binary => null, + Nm_Binary => null, + Addr_Digits_To_Skip => 8, + Bt_Offset_From_Call => 0) + ); + + -- Current architecture + Cur_Arch : Architecture; + + -- State of architecture detection + Detect_Success : Boolean := False; + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Error (Msg : String); + pragma No_Return (Error); + -- Prints the message and then terminates the program + + procedure Usage; + -- Displays the short help message and then terminates the program + + function Get_Reference_Offset return Unsigned_32; + -- Computes the static offset of the reference symbol by calling nm + + function Get_Value_From_Hex_Arg (Arg : Natural) return Unsigned_32; + -- Threats the argument number Arg as a C-style hexadecimal literal + -- and returns its integer value + + function Hex_Image (Value : Unsigned_32) return String_Access; + -- Returns access to a string that contains hexadecimal image of Value + + -- Separate functions that provide build-time customization: + + procedure Detect_Arch; + -- Saves in Cur_Arch the current architecture, based on the name of + -- vxaddr2line instance and properties of the host. Detect_Success is False + -- if detection fails + + ----------------- + -- Detect_Arch -- + ----------------- + + procedure Detect_Arch is + Name : constant String := Base_Name (Command_Name); + Proc : constant String := + Name (Name'First .. Index (Name, "-") - 1); + Target : constant String := + Name (Name'First .. Index (Name, "vxaddr2line") - 1); + + begin + Detect_Success := False; + + if Proc = "" then + return; + end if; + + if Proc = "alpha" then + Cur_Arch := DEC_ALPHA; + else + -- Let's detect the host. + -- ??? A naive implementation that can't distinguish between Unixes + if Directory_Separator = '/' then + Cur_Arch := Architecture'Value ("solaris_" & Proc); + else + Cur_Arch := Architecture'Value ("windows_" & Proc); + end if; + end if; + + if Arch_List (Cur_Arch).Addr2line_Binary = null then + Arch_List (Cur_Arch).Addr2line_Binary := new String' + (Target & "addr2line"); + end if; + if Arch_List (Cur_Arch).Nm_Binary = null then + Arch_List (Cur_Arch).Nm_Binary := new String' + (Target & "nm"); + end if; + + Detect_Success := True; + + exception + when others => + return; + end Detect_Arch; + + ----------- + -- Error -- + ----------- + + procedure Error (Msg : String) is + begin + Put_Line (Msg); + OS_Exit (1); + raise Program_Error; + end Error; + + -------------------------- + -- Get_Reference_Offset -- + -------------------------- + + function Get_Reference_Offset return Unsigned_32 is + Nm_Cmd : constant String_Access := + Locate_Exec_On_Path (Arch_List (Cur_Arch).Nm_Binary.all); + + Nm_Args : constant Argument_List := + (new String'("-P"), + new String'(Argument (1))); + + Forever : aliased String := "^@@@@"; + Reference : aliased String := Ref_Symbol & "\s+\S\s+([\da-fA-F]+)"; + + Pd : Process_Descriptor; + Result : Expect_Match; + + begin + -- If Nm is not found, abort + + if Nm_Cmd = null then + Error ("Couldn't find " & Arch_List (Cur_Arch).Nm_Binary.all); + end if; + + Non_Blocking_Spawn + (Pd, Nm_Cmd.all, Nm_Args, Buffer_Size => 0, Err_To_Out => True); + + -- Expect a string containing the reference symbol + + Expect (Pd, Result, + Regexp_Array'(1 => Reference'Unchecked_Access), + Timeout => -1); + + -- If we are here, the pattern was matched successfully + + declare + Match_String : constant String := Expect_Out_Match (Pd); + Matches : Match_Array (0 .. 1); + Value : Unsigned_32; + + begin + Match (Reference, Match_String, Matches); + Value := Unsigned_32'Value + ("16#" + & Match_String (Matches (1).First .. Matches (1).Last) & "#"); + + -- Expect a string that will never be emitted, so that the + -- process can be correctly terminated (with Process_Died) + + Expect (Pd, Result, + Regexp_Array'(1 => Forever'Unchecked_Access), + Timeout => -1); + + exception + when Process_Died => + return Value; + end; + + -- We cannot get here + + raise Program_Error; + + exception + when Invalid_Process => + Error ("Could not spawn a process " & Nm_Cmd.all); + + when others => + + -- The process died without matching the reference symbol or the + -- format wasn't recognized. + + Error ("Unexpected output from " & Nm_Cmd.all); + end Get_Reference_Offset; + + ---------------------------- + -- Get_Value_From_Hex_Arg -- + ---------------------------- + + function Get_Value_From_Hex_Arg (Arg : Natural) return Unsigned_32 is + Cur_Arg : constant String := Argument (Arg); + Offset : Natural; + + begin + -- Skip "0x" prefix if present + + if Cur_Arg'Length > 2 and then Cur_Arg (1 .. 2) = "0x" then + Offset := 3; + else + Offset := 1; + end if; + + -- Add architecture-specific offset + + Offset := Offset + Arch_List (Cur_Arch).Addr_Digits_To_Skip; + + -- Convert to value + + return Unsigned_32'Value + ("16#" & Cur_Arg (Offset .. Cur_Arg'Last) & "#"); + + exception + when Constraint_Error => + + Error ("Can't parse backtrace address '" & Cur_Arg & "'"); + raise; + end Get_Value_From_Hex_Arg; + + --------------- + -- Hex_Image -- + --------------- + + function Hex_Image (Value : Unsigned_32) return String_Access is + Result : String (1 .. 20); + Start_Pos : Natural; + + begin + Unsigned_32_IO.Put (Result, Value, 16); + Start_Pos := Index (Result, "16#") + 3; + return new String'(Result (Start_Pos .. Result'Last - 1)); + end Hex_Image; + + ----------- + -- Usage -- + ----------- + + procedure Usage is + begin + Put_Line ("Usage : " & Base_Name (Command_Name) + & " <" + & Ref_Symbol & " offset on target> ..."); + + OS_Exit (1); + end Usage; + + Ref_Static_Offset, Ref_Runtime_Address, Bt_Address : Unsigned_32; + + Addr2line_Cmd : String_Access; + + Addr2line_Args : Argument_List (1 .. 501); + -- We expect that there won't be more than 500 backtrace frames + + Addr2line_Args_Count : Natural; + + Success : Boolean; + +-- Start of processing for VxAddr2Line + +begin + + Detect_Arch; + + -- There should be at least two arguments + + if Argument_Count < 2 then + Usage; + end if; + + -- ??? HARD LIMIT! There should be at most 501 arguments + + if Argument_Count > 501 then + Error ("Too many backtrace frames"); + end if; + + -- Do we have a valid architecture? + + if not Detect_Success then + Put_Line ("Couldn't detect the architecture"); + return; + end if; + + Addr2line_Cmd := + Locate_Exec_On_Path (Arch_List (Cur_Arch).Addr2line_Binary.all); + + -- If Addr2line is not found, abort + + if Addr2line_Cmd = null then + Error ("Couldn't find " & Arch_List (Cur_Arch).Addr2line_Binary.all); + end if; + + -- The first argument specifies the image file. Check if it exists + + if not Is_Regular_File (Argument (1)) then + Error ("Couldn't find the executable " & Argument (1)); + end if; + + -- The second argument specifies the reference symbol runtime address. + -- Let's parse and store it + + Ref_Runtime_Address := Get_Value_From_Hex_Arg (2); + + -- Run nm command to get the reference symbol static offset + + Ref_Static_Offset := Get_Reference_Offset; + + -- Build addr2line parameters. First, the standard part + + Addr2line_Args (1) := new String'("--exe=" & Argument (1)); + Addr2line_Args_Count := 1; + + -- Now, append to this the adjusted backtraces in arguments 4 and further + + for J in 3 .. Argument_Count loop + + -- Basically, for each address in the runtime backtrace ... + + -- o We compute its offset relatively to the runtime address of the + -- reference symbol, + + -- and then ... + + -- o We add this offset to the static one for the reference symbol in + -- the executable to find the executable offset corresponding to the + -- backtrace address. + + Bt_Address := Get_Value_From_Hex_Arg (J); + + Bt_Address := + Bt_Address - Ref_Runtime_Address + + Ref_Static_Offset + + Arch_List (Cur_Arch).Bt_Offset_From_Call; + + Addr2line_Args_Count := Addr2line_Args_Count + 1; + Addr2line_Args (Addr2line_Args_Count) := Hex_Image (Bt_Address); + end loop; + + -- Run the resulting command + + Spawn (Addr2line_Cmd.all, + Addr2line_Args (1 .. Addr2line_Args_Count), Success); + + if not Success then + Error ("Couldn't spawn " & Addr2line_Cmd.all); + end if; + +exception + when others => + + -- Mask all exceptions + + return; +end VxAddr2Line; diff --git a/gcc/ada/widechar.adb b/gcc/ada/widechar.adb new file mode 100644 index 000000000..25d2ef7a2 --- /dev/null +++ b/gcc/ada/widechar.adb @@ -0,0 +1,241 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- W I D E 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: this package uses the generic subprograms in System.Wch_Cnv, which +-- completely encapsulate the set of wide character encoding methods, so no +-- modifications are required when adding new encoding methods. + +with Opt; use Opt; + +with System.WCh_Cnv; use System.WCh_Cnv; +with System.WCh_Con; use System.WCh_Con; + +package body Widechar is + + --------------------------- + -- Is_Start_Of_Wide_Char -- + --------------------------- + + function Is_Start_Of_Wide_Char + (S : Source_Buffer_Ptr; + P : Source_Ptr) return Boolean + is + begin + case Wide_Character_Encoding_Method is + + -- For Hex mode, just test for an ESC character. The ESC character + -- cannot appear in any other context in a legal Ada program. + + when WCEM_Hex => + return S (P) = ASCII.ESC; + + -- For brackets, just test ["x where x is a hex character. This is + -- sufficient test, since this sequence cannot otherwise appear in a + -- legal Ada program. + + when WCEM_Brackets => + return P <= S'Last - 2 + and then S (P) = '[' + and then S (P + 1) = '"' + and then (S (P + 2) in '0' .. '9' + or else + S (P + 2) in 'a' .. 'f' + or else + S (P + 2) in 'A' .. 'F'); + + -- All other encoding methods use the upper bit set in the first + -- character to uniquely represent a wide character. + + when WCEM_Upper | + WCEM_Shift_JIS | + WCEM_EUC | + WCEM_UTF8 => + return S (P) >= Character'Val (16#80#); + end case; + end Is_Start_Of_Wide_Char; + + ----------------- + -- Length_Wide -- + ----------------- + + function Length_Wide return Nat is + begin + return WC_Longest_Sequence; + end Length_Wide; + + --------------- + -- Scan_Wide -- + --------------- + + procedure Scan_Wide + (S : Source_Buffer_Ptr; + P : in out Source_Ptr; + C : out Char_Code; + Err : out Boolean) + is + P_Init : constant Source_Ptr := P; + Chr : Character; + + function In_Char return Character; + -- Function to obtain characters of wide character escape sequence + + ------------- + -- In_Char -- + ------------- + + function In_Char return Character is + begin + P := P + 1; + return S (P - 1); + end In_Char; + + function WC_In is new Char_Sequence_To_UTF_32 (In_Char); + + -- Start of processing for Scan_Wide + + begin + Chr := In_Char; + + -- Scan out the wide character. If the first character is a bracket, + -- we allow brackets encoding regardless of the standard encoding + -- method being used, but otherwise we use this standard method. + + if Chr = '[' then + C := Char_Code (WC_In (Chr, WCEM_Brackets)); + else + C := Char_Code (WC_In (Chr, Wide_Character_Encoding_Method)); + end if; + + Err := False; + Wide_Char_Byte_Count := Wide_Char_Byte_Count + Nat (P - P_Init - 1); + + exception + when Constraint_Error => + C := Char_Code (0); + P := P - 1; + Err := True; + end Scan_Wide; + + -------------- + -- Set_Wide -- + -------------- + + procedure Set_Wide + (C : Char_Code; + S : in out String; + P : in out Natural) + is + procedure Out_Char (C : Character); + -- Procedure to store one character of wide character sequence + + -------------- + -- Out_Char -- + -------------- + + procedure Out_Char (C : Character) is + begin + P := P + 1; + S (P) := C; + end Out_Char; + + procedure WC_Out is new UTF_32_To_Char_Sequence (Out_Char); + + -- Start of processing for Set_Wide + + begin + WC_Out (UTF_32_Code (C), Wide_Character_Encoding_Method); + end Set_Wide; + + --------------- + -- Skip_Wide -- + --------------- + + procedure Skip_Wide (S : String; P : in out Natural) is + P_Init : constant Natural := P; + + function Skip_Char return Character; + -- Function to skip one character of wide character escape sequence + + --------------- + -- Skip_Char -- + --------------- + + function Skip_Char return Character is + begin + P := P + 1; + return S (P - 1); + end Skip_Char; + + function WC_Skip is new Char_Sequence_To_UTF_32 (Skip_Char); + + Discard : UTF_32_Code; + pragma Warnings (Off, Discard); + + -- Start of processing for Skip_Wide + + begin + Discard := WC_Skip (Skip_Char, Wide_Character_Encoding_Method); + Wide_Char_Byte_Count := Wide_Char_Byte_Count + Nat (P - P_Init - 1); + end Skip_Wide; + + --------------- + -- Skip_Wide -- + --------------- + + procedure Skip_Wide (S : Source_Buffer_Ptr; P : in out Source_Ptr) is + P_Init : constant Source_Ptr := P; + + function Skip_Char return Character; + -- Function to skip one character of wide character escape sequence + + --------------- + -- Skip_Char -- + --------------- + + function Skip_Char return Character is + begin + P := P + 1; + return S (P - 1); + end Skip_Char; + + function WC_Skip is new Char_Sequence_To_UTF_32 (Skip_Char); + + Discard : UTF_32_Code; + pragma Warnings (Off, Discard); + + -- Start of processing for Skip_Wide + + begin + Discard := WC_Skip (Skip_Char, Wide_Character_Encoding_Method); + Wide_Char_Byte_Count := Wide_Char_Byte_Count + Nat (P - P_Init - 1); + end Skip_Wide; + +end Widechar; diff --git a/gcc/ada/widechar.ads b/gcc/ada/widechar.ads new file mode 100644 index 000000000..7db577add --- /dev/null +++ b/gcc/ada/widechar.ads @@ -0,0 +1,98 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- W I D E 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Subprograms for manipulation of wide character sequences. Note that in +-- this package, wide character and wide wide character are not distinguished +-- since this package is basically concerned with syntactic notions, and it +-- deals with Char_Code values, rather than values of actual Ada types. + +with Types; use Types; + +package Widechar is + + Wide_Char_Byte_Count : Nat := 0; + -- This value is incremented whenever Scan_Wide or Skip_Wide is called. + -- The amount added is the length of the wide character sequence minus + -- one. This means that the count that accumulates here represents the + -- difference between the length in characters and the length in bytes. + -- This is used for checking the line length in characters. + + function Length_Wide return Nat; + -- Returns the maximum length in characters for the escape sequence that + -- is used to encode wide character literals outside the ASCII range. Used + -- only in the implementation of the attribute Width for Wide_Character + -- and Wide_Wide_Character. + + procedure Scan_Wide + (S : Source_Buffer_Ptr; + P : in out Source_Ptr; + C : out Char_Code; + Err : out Boolean); + -- On entry S (P) points to the first character in the source text for + -- a wide character (i.e. to an ESC character, a left bracket, or an + -- upper half character, depending on the representation method). A + -- single wide character is scanned. If no error is found, the value + -- stored in C is the code for this wide character, P is updated past + -- the sequence and Err is set to False. If an error is found, then + -- P points to the improper character, C is undefined, and Err is + -- set to True. + + procedure Set_Wide + (C : Char_Code; + S : in out String; + P : in out Natural); + -- The escape sequence (including any leading ESC character) for the + -- given character code is stored starting at S (P + 1), and on return + -- P points to the last stored character (i.e. P is the count of stored + -- characters on entry and exit, and the escape sequence is appended to + -- the end of the stored string). The character code C represents a code + -- originally constructed by Scan_Wide, so it is known to be in a range + -- that is appropriate for the encoding method in use. + + procedure Skip_Wide (S : String; P : in out Natural); + -- On entry, S (P) points to an ESC character for a wide character escape + -- sequence or to an upper half character if the encoding method uses the + -- upper bit, or to a left bracket if the brackets encoding method is in + -- use. On exit, P is bumped past the wide character sequence. No error + -- checking is done, since this is only used on escape sequences generated + -- by Set_Wide, which are known to be correct. + + procedure Skip_Wide (S : Source_Buffer_Ptr; P : in out Source_Ptr); + -- Similar to the above procedure, but operates on a source buffer + -- instead of a string, with P being a Source_Ptr referencing the + -- contents of the source buffer. + + function Is_Start_Of_Wide_Char + (S : Source_Buffer_Ptr; + P : Source_Ptr) return Boolean; + -- Determines if S (P) is the start of a wide character sequence + +end Widechar; diff --git a/gcc/ada/xeinfo.adb b/gcc/ada/xeinfo.adb new file mode 100644 index 000000000..ba9ded9d5 --- /dev/null +++ b/gcc/ada/xeinfo.adb @@ -0,0 +1,512 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT SYSTEM UTILITIES -- +-- -- +-- X E I N F O -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Program to construct C header file a-einfo.h (C version of einfo.ads spec) +-- for use by Gigi. This header file contains all definitions and access +-- functions, but does not contain set procedures, since Gigi is not allowed +-- to modify the GNAT tree) + +-- Input files: + +-- einfo.ads spec of Einfo package +-- einfo.adb body of Einfo package + +-- Output files: + +-- a-einfo.h Corresponding c header file + +-- Note: It is assumed that the input files have been compiled without errors + +-- An optional argument allows the specification of an output file name to +-- override the default a-einfo.h file name for the generated output file. + +-- Most, but not all of the functions in Einfo can be inlined in the C header. +-- They are the functions identified by pragma Inline in the spec. Functions +-- that cannot be inlined are simply defined in the header. + +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; +with Ada.Strings.Maps; use Ada.Strings.Maps; +with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.Spitbol; use GNAT.Spitbol; +with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; +with GNAT.Spitbol.Table_Boolean; use GNAT.Spitbol.Table_Boolean; + +with CEinfo; + +procedure XEinfo is + + package TB renames GNAT.Spitbol.Table_Boolean; + + Err : exception; + + A : VString := Nul; + B : VString := Nul; + C : VString := Nul; + Expr : VString := Nul; + Filler : VString := Nul; + Fline : VString := Nul; + Formal : VString := Nul; + Formaltyp : VString := Nul; + FN : VString := Nul; + Line : VString := Nul; + N : VString := Nul; + N1 : VString := Nul; + N2 : VString := Nul; + N3 : VString := Nul; + Nam : VString := Nul; + Name : VString := Nul; + NewS : VString := Nul; + Nextlin : VString := Nul; + OldS : VString := Nul; + Rtn : VString := Nul; + Term : VString := Nul; + + InB : File_Type; + -- Used to read initial header from body + + InF : File_Type; + -- Used to read full text of both spec and body + + Ofile : File_Type; + -- Used to write output file + + wsp : constant Pattern := NSpan (' ' & ASCII.HT); + Comment : constant Pattern := wsp & "--"; + For_Rep : constant Pattern := wsp & "for"; + Get_Func : constant Pattern := wsp * A & "function" & wsp + & Break (' ') * Name; + Inline : constant Pattern := wsp & "pragma Inline (" & Break (')') * Name; + Get_Pack : constant Pattern := wsp & "package "; + Get_Enam : constant Pattern := wsp & Break (',') * N & ','; + Find_Fun : constant Pattern := wsp & "function"; + F_Subtyp : constant Pattern := wsp * A & "subtype " & Break (' ') * N; + G_Subtyp : constant Pattern := wsp & "subtype" & wsp & Break (' ') * NewS + & wsp & "is" & wsp & Break (" ;") * OldS + & wsp & ';' & wsp & Rtab (0); + F_Typ : constant Pattern := wsp * A & "type " & Break (' ') * N & + " is ("; + Get_Nam : constant Pattern := wsp * A & Break (",)") * Nam + & Len (1) * Term; + Get_Styp : constant Pattern := wsp * A & "subtype " & Break (' ') * N; + Get_N1 : constant Pattern := wsp & Break (' ') * N1; + Get_N2 : constant Pattern := wsp & "-- " & Rest * N2; + Get_N3 : constant Pattern := wsp & Break (';') * N3; + Get_FN : constant Pattern := wsp * C & "function" & wsp + & Break (" (") * FN; + Is_Rturn : constant Pattern := BreakX ('r') & "return"; + Is_Begin : constant Pattern := wsp & "begin"; + Get_Asrt : constant Pattern := wsp & "pragma Assert"; + Semicoln : constant Pattern := BreakX (';'); + Get_Cmnt : constant Pattern := BreakX ('-') * A & "--"; + Get_Expr : constant Pattern := wsp & "return " & Break (';') * Expr; + Chek_End : constant Pattern := wsp & "end" & BreakX (';') & ';'; + Get_B1 : constant Pattern := BreakX (' ') * A & " in " & Rest * B; + Get_B2 : constant Pattern := BreakX (' ') * A & " = " & Rest * B; + Get_B3 : constant Pattern := BreakX (' ') * A & " /= " & Rest * B; + To_Paren : constant Pattern := wsp * Filler & '('; + Get_Fml : constant Pattern := Break (" :") * Formal & wsp & ':' & wsp + & BreakX (" );") * Formaltyp; + Nxt_Fml : constant Pattern := wsp & "; "; + Get_Rtn : constant Pattern := wsp & "return" & wsp & BreakX (" ;") * Rtn; + Rem_Prn : constant Pattern := wsp & ')'; + + M : Match_Result; + + Lineno : Natural := 0; + -- Line number in spec + + V : Natural; + Ctr : Natural; + + Inlined : TB.Table (200); + -- Inlined = True for inlined function, False otherwise + + Lastinlined : Boolean; + + procedure Badfunc; + -- Signal bad function in body + + function Getlin return VString; + -- Get non-comment line (comment lines skipped, also skips FOR rep clauses) + -- Fatal error (raises End_Error exception) if end of file encountered + + procedure Must (B : Boolean); + -- Raises Err if the argument (a Match) call, returns False + + procedure Sethead (Line : in out VString; Term : String); + -- Process function header into C + + ------------- + -- Badfunc -- + ------------- + + procedure Badfunc is + begin + Put_Line + (Standard_Error, + "Body for function " & FN & " does not meet requirements"); + raise Err; + end Badfunc; + + ------------- + -- Getlin -- + ------------- + + function Getlin return VString is + Lin : VString; + + begin + loop + Lin := Get_Line (InF); + Lineno := Lineno + 1; + + if Lin /= "" + and then not Match (Lin, Comment) + and then not Match (Lin, For_Rep) + then + return Lin; + end if; + end loop; + end Getlin; + + ---------- + -- Must -- + ---------- + + procedure Must (B : Boolean) is + begin + if not B then + raise Err; + end if; + end Must; + + ------------- + -- Sethead -- + ------------- + + procedure Sethead (Line : in out VString; Term : String) is + Args : VString; + + begin + Must (Match (Line, Get_Func, "")); + Args := Nul; + + if Match (Line, To_Paren, "") then + Args := Filler & '('; + + loop + Must (Match (Line, Get_Fml, "")); + Append (Args, Formaltyp & ' ' & Formal); + exit when not Match (Line, Nxt_Fml); + Append (Args, ","); + end loop; + + Match (Line, Rem_Prn, ""); + Append (Args, ')'); + end if; + + Must (Match (Line, Get_Rtn)); + + if Present (Inlined, Name) then + Put_Line (Ofile, A & "INLINE " & Rtn & ' ' & Name & Args & Term); + else + Put_Line (Ofile, A & Rtn & ' ' & Name & Args & Term); + end if; + end Sethead; + +-- Start of processing for XEinfo + +begin + -- First run CEinfo to check for errors. Note that CEinfo is also a + -- stand-alone program that can be run separately. + + CEinfo; + + Anchored_Mode := True; + + if Argument_Count > 0 then + Create (Ofile, Out_File, Argument (1)); + else + Create (Ofile, Out_File, "a-einfo.h"); + end if; + + Open (InB, In_File, "einfo.adb"); + Open (InF, In_File, "einfo.ads"); + + Lineno := 0; + loop + Line := Get_Line (InF); + Lineno := Lineno + 1; + exit when Line = ""; + + Match (Line, + "-- S p e c ", + "-- C Header File "); + Match (Line, "--", "/*"); + Match (Line, Rtab (2) * A & "--", M); + Replace (M, A & "*/"); + Put_Line (Ofile, Line); + end loop; + + Put_Line (Ofile, ""); + + -- Find and record pragma Inlines + + loop + Line := Get_Line (InF); + exit when Match (Line, " -- END XEINFO INLINES"); + + if Match (Line, Inline) then + Set (Inlined, Name, True); + end if; + end loop; + + -- Skip to package line + + Reset (InF, In_File); + Lineno := 0; + + loop + Line := Getlin; + exit when Match (Line, Get_Pack); + end loop; + + V := 0; + Line := Getlin; + Must (Match (Line, wsp & "type Entity_Kind")); + + -- Process entity kind code definitions + + loop + Line := Getlin; + exit when not Match (Line, Get_Enam); + Put_Line (Ofile, " #define " & Rpad (N, 32) & " " & V); + V := V + 1; + end loop; + + Must (Match (Line, wsp & Rest * N)); + Put_Line (Ofile, " #define " & Rpad (N, 32) & ' ' & V); + Line := Getlin; + + Must (Match (Line, wsp & ");")); + Put_Line (Ofile, ""); + + -- Loop through subtype and type declarations + + loop + Line := Getlin; + exit when Match (Line, Find_Fun); + + -- Case of a subtype declaration + + if Match (Line, F_Subtyp) then + + -- Case of a subtype declaration that is an abbreviation of the + -- form subtype x is y, and if so generate the appropriate typedef + + if Match (Line, G_Subtyp) then + Put_Line (Ofile, A & "typedef " & OldS & ' ' & NewS & ';'); + + -- Otherwise the subtype must be declaring a subrange of Entity_Id + + else + Must (Match (Line, Get_Styp)); + Line := Getlin; + Must (Match (Line, Get_N1)); + + loop + Line := Get_Line (InF); + Lineno := Lineno + 1; + exit when not Match (Line, Get_N2); + end loop; + + Must (Match (Line, Get_N3)); + Put_Line (Ofile, A & "SUBTYPE (" & N & ", Entity_Kind, "); + Put_Line (Ofile, A & " " & N1 & ", " & N3 & ')'); + Put_Line (Ofile, ""); + end if; + + -- Case of type declaration + + elsif Match (Line, F_Typ) then + + -- Process type declaration (must be enumeration type) + + Ctr := 0; + Put_Line (Ofile, A & "typedef char " & N & ';'); + + loop + Line := Getlin; + Must (Match (Line, Get_Nam)); + Put_Line (Ofile, A & "#define " & Rpad (Nam, 25) & Ctr); + Ctr := Ctr + 1; + exit when Term /= ","; + end loop; + + Put_Line (Ofile, ""); + + -- Neither subtype nor type declaration + + else + raise Err; + end if; + end loop; + + -- Process function declarations + + -- Note: Lastinlined used to control blank lines + + Put_Line (Ofile, ""); + Lastinlined := True; + + -- Loop through function declarations + + while Match (Line, Get_FN) loop + + -- Non-inlined function + + if not Present (Inlined, FN) then + Put_Line (Ofile, ""); + Put_Line + (Ofile, + " #define " & FN & " einfo__" & Translate (FN, Lower_Case_Map)); + + -- Inlined function + + else + if not Lastinlined then + Put_Line (Ofile, ""); + end if; + end if; + + -- Merge here to output spec + + Sethead (Line, ";"); + Lastinlined := Get (Inlined, FN); + Line := Getlin; + end loop; + + Put_Line (Ofile, ""); + + -- Read body to find inlined functions + + Close (InB); + Close (InF); + Open (InF, In_File, "einfo.adb"); + Lineno := 0; + + -- Loop through input lines to find bodies of inlined functions + + while not End_Of_File (InF) loop + Fline := Get_Line (InF); + + if Match (Fline, Get_FN) + and then Get (Inlined, FN) + then + -- Here we have an inlined function + + if not Match (Fline, Is_Rturn) then + Line := Fline; + Badfunc; + end if; + + Line := Getlin; + + if not Match (Line, Is_Begin) then + Badfunc; + end if; + + -- Skip past pragma Asserts + + loop + Line := Getlin; + exit when not Match (Line, Get_Asrt); + + -- Pragma assert found, get its continuation lines + + loop + exit when Match (Line, Semicoln); + Line := Getlin; + end loop; + end loop; + + -- Process return statement + + Match (Line, Get_Cmnt, M); + Replace (M, A); + + -- Get continuations of return statement + + while not Match (Line, Semicoln) loop + Nextlin := Getlin; + Match (Nextlin, wsp, " "); + Append (Line, Nextlin); + end loop; + + if not Match (Line, Get_Expr) then + Badfunc; + end if; + + Line := Getlin; + + if not Match (Line, Chek_End) then + Badfunc; + end if; + + Match (Expr, Get_B1, M); + Replace (M, "IN (" & A & ", " & B & ')'); + Match (Expr, Get_B2, M); + Replace (M, A & " == " & B); + Match (Expr, Get_B3, M); + Replace (M, A & " != " & B); + Put_Line (Ofile, ""); + Sethead (Fline, ""); + Put_Line (Ofile, C & " { return " & Expr & "; }"); + end if; + end loop; + + Put_Line (Ofile, ""); + Put_Line + (Ofile, + "/* End of einfo.h (C version of Einfo package specification) */"); + + Close (InF); + Close (Ofile); + +exception + when Err => + Put_Line (Standard_Error, Lineno & ". " & Line); + Put_Line (Standard_Error, "**** fatal error ****"); + Set_Exit_Status (1); + + when End_Error => + Put_Line (Standard_Error, "unexpected end of file"); + Put_Line (Standard_Error, "**** fatal error ****"); + +end XEinfo; diff --git a/gcc/ada/xgnatugn.adb b/gcc/ada/xgnatugn.adb new file mode 100644 index 000000000..ab168170f --- /dev/null +++ b/gcc/ada/xgnatugn.adb @@ -0,0 +1,1423 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT SYSTEM UTILITIES -- +-- -- +-- X G N A T U G N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +------------------------------------------------------------------------------ + +-- This utility is used to process the source of gnat_ugn.texi to make a +-- version suitable for running through standard Texinfo processor. It is +-- invoked as follows: + +-- xgnatugn [ [ ] ] + +-- 1. is the target type of the manual, which is one of: + +-- unw Unix and Windows platforms +-- vms OpenVMS + +-- 2. is the file name of the Texinfo file to be +-- preprocessed. + +-- 3. is the name of the word list file. This file is used for +-- rewriting the VMS edition. Each line contains a word mapping: The source +-- word in the first column, the target word in the second column. The +-- columns are separated by a '^' character. When preprocessing for VMS, the +-- first word is replaced with the second. (Words consist of letters, +-- digits, and the four characters "?-_~". A sequence of multiple words can +-- be replaced if they are listed in the first column, separated by a single +-- space character. If multiple words are to be replaced, there must be a +-- replacement for each prefix.) + +-- 4. (optional) is the name of the output file. It defaults to +-- gnat_ugn_unw.texi or gnat_ugn_vms.texi, depending on the target. + +-- 5. (optional, and allowed only if is explicit) +-- can be any string. If present, it indicates that warning messages are +-- to be output to Standard_Error. If absent, no warning messages are +-- generated. + +-- The following steps are performed: + +-- In VMS mode + +-- Any occurrences of ^alpha^beta^ are replaced by beta. The sequence +-- must fit on a single line, and there can only be one occurrence on a +-- line. + +-- Any occurrences of a word in the Ug_Words list are replaced by the +-- appropriate vms equivalents. Note that replacements do not occur +-- within ^alpha^beta^ sequences. + +-- Any occurrence of [filename].extension, where extension one of the +-- following: + +-- "o", "ads", "adb", "ali", "ada", "atb", "ats", "adc", "c" + +-- replaced by the appropriate VMS names (all upper case with .o +-- replaced .OBJ). Note that replacements do not occur within +-- ^alpha^beta^ sequences. + +-- In UNW mode + +-- Any occurrences of ^alpha^beta^ are replaced by alpha. The sequence +-- must fit on a single line. + +-- In both modes + +-- The sequence ^^^ is replaced by a single ^. This escape sequence +-- must be used if the literal character ^ is to appear in the +-- output. A line containing this escape sequence may not also contain +-- a ^alpha^beta^ sequence. + +-- Process @ifset and @ifclear for the target flags (unw, vms); +-- this is because we have menu problems if we let makeinfo handle +-- these ifset/ifclear pairs. +-- Note: @ifset/@ifclear commands for the edition flags (FSFEDITION, +-- PROEDITION, GPLEDITION) are passed through unchanged + +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Strings; use Ada.Strings; +with Ada.Strings.Fixed; use Ada.Strings.Fixed; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Strings.Maps; use Ada.Strings.Maps; +with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; +with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.Spitbol; use GNAT.Spitbol; +with GNAT.Spitbol.Table_VString; use GNAT.Spitbol.Table_VString; + +procedure Xgnatugn is + + procedure Usage; + -- Print usage information. Invoked if an invalid command line is + -- encountered. + + subtype Sfile is Ada.Streams.Stream_IO.File_Type; + + Output_File : Sfile; + -- The preprocessed output is written to this file + + type Input_File is record + Name : VString; + Data : Ada.Text_IO.File_Type; + Line : Natural := 0; + end record; + -- Records information on an input file. Name and Line are used + -- in error messages, Line is updated automatically by Get_Line. + + function Get_Line (Input : access Input_File) return String; + -- Returns a line from Input and performs the necessary + -- line-oriented checks (length, character set, trailing spaces). + + procedure Put_Line (F : Sfile; S : String); + -- Local version of Put_Line ensures Unix style line endings + + Number_Of_Warnings : Natural := 0; + Number_Of_Errors : Natural := 0; + Warnings_Enabled : Boolean; + + procedure Error + (Input : Input_File; + At_Character : Natural; + Message : String); + procedure Error + (Input : Input_File; + Message : String); + -- Prints a message reporting an error on line Input.Line. If + -- At_Character is not 0, indicate the exact character at which + -- the error occurs. + + procedure Warning + (Input : Input_File; + At_Character : Natural; + Message : String); + procedure Warning + (Input : Input_File; + Message : String); + -- Like Error, but just print a warning message + + Dictionary_File : aliased Input_File; + procedure Read_Dictionary_File; + -- Dictionary_File is opened using the name given on the command + -- line. It contains the replacements for the Ug_Words list. + -- Read_Dictionary_File reads Dictionary_File and fills the + -- Ug_Words table. + + Source_File : aliased Input_File; + procedure Process_Source_File; + -- Source_File is opened using the name given on the command line. + -- It contains the Texinfo source code. Process_Source_File + -- performs the necessary replacements. + + type Flag_Type is (UNW, VMS, FSFEDITION, PROEDITION, GPLEDITION); + -- The flags permitted in @ifset or @ifclear commands: + -- + -- Targets for preprocessing + -- UNW (Unix and Windows) or VMS + -- + -- Editions of the manual + -- FSFEDITION, PROEDITION, or GPLEDITION + -- + -- Conditional commands for target are processed by xgnatugn + -- + -- Conditional commands for edition are passed through unchanged + + subtype Target_Type is Flag_Type range UNW .. VMS; + subtype Edition_Type is Flag_Type range FSFEDITION .. GPLEDITION; + + Target : Target_Type; + -- The Target variable is initialized using the command line + + Valid_Characters : constant Character_Set := + To_Set (Span => (' ', '~')); + -- This array controls which characters are permitted in the input + -- file (after line breaks have been removed). Valid characters + -- are all printable ASCII characters and the space character. + + Word_Characters : constant Character_Set := + (To_Set (Ranges => + (('0', '9'), ('a', 'z'), ('A', 'Z'))) + or To_Set ("?-_~")); + -- The characters which are permitted in words. Other (valid) + -- characters are assumed to be delimiters between words. Note that + -- this set has to include all characters of the source words of the + -- Ug_Words dictionary. + + Reject_Trailing_Spaces : constant Boolean := True; + -- Controls whether Xgnatug rejects superfluous space characters + -- at the end of lines. + + Maximum_Line_Length : constant Positive := 79; + Fatal_Line_Length_Limit : constant Positive := 5000; + Fatal_Line_Length : exception; + -- If Maximum_Line_Length is exceeded in an input file, an error + -- message is printed. If Fatal_Line_Length is exceeded, + -- execution terminates with a Fatal_Line_Length exception. + + VMS_Escape_Character : constant Character := '^'; + -- The character used to mark VMS alternatives (^alpha^beta^) + + Extensions : GNAT.Spitbol.Table_VString.Table (20); + procedure Initialize_Extensions; + -- This table records extensions and their replacement for + -- rewriting filenames in the VMS version of the manual. + + function Is_Extension (Extension : String) return Boolean; + function Get_Replacement_Extension (Extension : String) return String; + -- These functions query the replacement table. Is_Extension + -- checks if the given string is a known extension. + -- Get_Replacement returns the replacement extension. + + Ug_Words : GNAT.Spitbol.Table_VString.Table (200); + function Is_Known_Word (Word : String) return Boolean; + function Get_Replacement_Word (Word : String) return String; + -- The Ug_Words table lists replacement words for the VMS version + -- of the manual. Is_Known_Word and Get_Replacement_Word query + -- this table. The table is filled using Read_Dictionary_File. + + function Rewrite_Source_Line (Line : String) return String; + -- This subprogram takes a line and rewrites it according to Target. + -- It relies on information in Source_File to generate error messages. + + type Conditional is (Set, Clear); + procedure Push_Conditional (Cond : Conditional; Flag : Target_Type); + procedure Pop_Conditional (Cond : Conditional); + -- These subprograms deal with conditional processing (@ifset/@ifclear). + -- They rely on information in Source_File to generate error messages. + + function Currently_Excluding return Boolean; + -- Returns true if conditional processing directives imply that the + -- current line should not be included in the output. + + function VMS_Context_Determined return Boolean; + -- Returns true if, in the current conditional preprocessing context, we + -- always have a VMS or a non-VMS version, regardless of the value of + -- Target. + + function In_VMS_Section return Boolean; + -- Returns True if in an "@ifset vms" section + + procedure Check_No_Pending_Conditional; + -- Checks that all preprocessing directives have been properly matched by + -- their @end counterpart. If this is not the case, print an error + -- message. + + -- The following definitions implement a stack to track the conditional + -- preprocessing context. + + type Conditional_Context is record + Starting_Line : Positive; + Cond : Conditional; + Flag : Flag_Type; + Excluding : Boolean; + end record; + + Conditional_Stack_Depth : constant := 3; + + Conditional_Stack : + array (1 .. Conditional_Stack_Depth) of Conditional_Context; + + Conditional_TOS : Natural := 0; + -- Pointer to the Top Of Stack for Conditional_Stack + + ----------- + -- Usage -- + ----------- + + procedure Usage is + begin + Put_Line (Standard_Error, + "usage: xgnatugn TARGET SOURCE DICTIONARY [OUTFILE [WARNINGS]]"); + New_Line; + Put_Line (Standard_Error, "TARGET is one of:"); + + for T in Target_Type'Range loop + Put_Line (Standard_Error, " " & Target_Type'Image (T)); + end loop; + + New_Line; + Put_Line (Standard_Error, "SOURCE is the source file to process."); + New_Line; + Put_Line (Standard_Error, "DICTIONARY is the name of a file " + & "that contains word replacements"); + Put_Line (Standard_Error, "for the VMS version."); + New_Line; + Put_Line (Standard_Error, + "OUT-FILE, if present, is the output file to be created;"); + Put_Line (Standard_Error, + "If OUT-FILE is absent, the output file is either " & + "gnat_ugn_unw.texi, "); + Put_Line (Standard_Error, + "or gnat_ugn_vms.texi, depending on TARGET."); + New_Line; + Put_Line (Standard_Error, + "WARNINGS, if present, is any string;"); + Put_Line (Standard_Error, + "it will result in warning messages (e.g., line too long))"); + Put_Line (Standard_Error, + "being output to Standard_Error."); + end Usage; + + -------------- + -- Get_Line -- + -------------- + + function Get_Line (Input : access Input_File) return String is + Line_Buffer : String (1 .. Fatal_Line_Length_Limit); + Last : Natural; + + begin + Input.Line := Input.Line + 1; + Get_Line (Input.Data, Line_Buffer, Last); + + if Last = Line_Buffer'Last then + Error (Input.all, "line exceeds fatal line length limit"); + raise Fatal_Line_Length; + end if; + + declare + Line : String renames Line_Buffer (Line_Buffer'First .. Last); + + begin + for J in Line'Range loop + if not Is_In (Line (J), Valid_Characters) then + Error (Input.all, J, "invalid character"); + exit; + end if; + end loop; + + if Line'Length > Maximum_Line_Length then + Warning (Input.all, Maximum_Line_Length + 1, "line too long"); + end if; + + if Reject_Trailing_Spaces + and then Line'Length > 0 + and then Line (Line'Last) = ' ' + then + Error (Input.all, Line'Last, "trailing space character"); + end if; + + return Trim (Line, Right); + end; + end Get_Line; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (F : Sfile; S : String) is + begin + String'Write (Stream (F), S); + Character'Write (Stream (F), ASCII.LF); + end Put_Line; + + ----------- + -- Error -- + ----------- + + procedure Error + (Input : Input_File; + Message : String) + is + begin + Error (Input, 0, Message); + end Error; + + procedure Error + (Input : Input_File; + At_Character : Natural; + Message : String) + is + Line_Image : constant String := Integer'Image (Input.Line); + At_Character_Image : constant String := Integer'Image (At_Character); + -- These variables are required because we have to drop the leading + -- space character. + + begin + Number_Of_Errors := Number_Of_Errors + 1; + + if At_Character > 0 then + Put_Line (Standard_Error, + S (Input.Name) & ':' + & Line_Image (Line_Image'First + 1 .. Line_Image'Last) & ':' + & At_Character_Image (At_Character_Image'First + 1 + .. At_Character_Image'Last) + & ": " + & Message); + else + Put_Line (Standard_Error, + S (Input.Name) & ':' + & Line_Image (Line_Image'First + 1 .. Line_Image'Last) + & ": " + & Message); + end if; + end Error; + + ------------- + -- Warning -- + ------------- + + procedure Warning + (Input : Input_File; + Message : String) + is + begin + if Warnings_Enabled then + Warning (Input, 0, Message); + end if; + end Warning; + + procedure Warning + (Input : Input_File; + At_Character : Natural; + Message : String) + is + Line_Image : constant String := Integer'Image (Input.Line); + At_Character_Image : constant String := Integer'Image (At_Character); + -- These variables are required because we have to drop the leading + -- space character. + + begin + if not Warnings_Enabled then + return; + end if; + + Number_Of_Warnings := Number_Of_Warnings + 1; + + if At_Character > 0 then + Put_Line (Standard_Error, + S (Input.Name) & ':' + & Line_Image (Line_Image'First + 1 .. Line_Image'Last) & ':' + & At_Character_Image (At_Character_Image'First + 1 + .. At_Character_Image'Last) + & ": warning: " + & Message); + else + Put_Line (Standard_Error, + S (Input.Name) & ':' + & Line_Image (Line_Image'First + 1 .. Line_Image'Last) + & ": warning: " + & Message); + end if; + end Warning; + + -------------------------- + -- Read_Dictionary_File -- + -------------------------- + + procedure Read_Dictionary_File is + begin + while not End_Of_File (Dictionary_File.Data) loop + declare + Line : constant String := + Get_Line (Dictionary_File'Access); + Split : constant Natural := + Index (Line, (1 => VMS_Escape_Character)); + + begin + if Line'Length = 0 then + Error (Dictionary_File, "empty line in dictionary file"); + + elsif Line (Line'First) = ' ' then + Error (Dictionary_File, 1, "line starts with space character"); + + elsif Split = 0 then + Error (Dictionary_File, "line does not contain " + & VMS_Escape_Character & " character"); + else + declare + Source : constant String := + Trim (Line (1 .. Split - 1), Both); + Target : constant String := + Trim (Line (Split + 1 .. Line'Last), Both); + Two_Spaces : constant Natural := + Index (Source, " "); + Non_Word_Character : constant Natural := + Index (Source, + Word_Characters or + To_Set (" ."), + Outside); + + begin + if Two_Spaces /= 0 then + Error (Dictionary_File, Two_Spaces, + "multiple space characters in source word"); + end if; + + if Non_Word_Character /= 0 then + Error (Dictionary_File, Non_Word_Character, + "illegal character in source word"); + end if; + + if Source'Length = 0 then + Error (Dictionary_File, "source is empty"); + + elsif Target'Length = 0 then + Error (Dictionary_File, "target is empty"); + + else + Set (Ug_Words, Source, V (Target)); + + -- Ensure that if Source is a sequence of words + -- "WORD1 WORD2 ...", we already have a mapping for + -- "WORD1". + + for J in Source'Range loop + if Source (J) = ' ' then + declare + Prefix : String renames + Source (Source'First .. J - 1); + + begin + if not Is_Known_Word (Prefix) then + Error (Dictionary_File, + "prefix '" & Prefix + & "' not known at this point"); + end if; + end; + end if; + end loop; + end if; + end; + end if; + end; + end loop; + end Read_Dictionary_File; + + ------------------------- + -- Rewrite_Source_Line -- + ------------------------- + + function Rewrite_Source_Line (Line : String) return String is + + -- We use a simple lexer to split the line into tokens: + + -- Word consisting entirely of Word_Characters + -- VMS_Alternative ^alpha^beta^ replacement (but not ^^^) + -- Space a space character + -- Other everything else (sequence of non-word characters) + -- VMS_Error incomplete VMS alternative + -- End_Of_Line no more characters on this line + + -- A sequence of three VMS_Escape_Characters is automatically + -- collapsed to an Other token. + + type Token_Span is record + First, Last : Positive; + end record; + -- The character range covered by a token in Line + + type Token_Kind is (End_Of_Line, Word, Other, + VMS_Alternative, VMS_Error); + type Token_Record (Kind : Token_Kind := End_Of_Line) is record + First : Positive; + case Kind is + when Word | Other => + Span : Token_Span; + when VMS_Alternative => + Non_VMS, VMS : Token_Span; + when VMS_Error | End_Of_Line => + null; + end case; + end record; + + Input_Position : Positive := Line'First; + Token : Token_Record; + -- The position of the next character to be processed by Next_Token + + procedure Next_Token; + -- Returns the next token in Line, starting at Input_Position + + Rewritten_Line : VString; + -- Collects the line as it is rewritten + + procedure Rewrite_Word; + -- The current token is assumed to be a Word. When processing the VMS + -- version of the manual, additional tokens are gathered to check if + -- we have a file name or a sequence of known words. + + procedure Maybe_Rewrite_Extension; + -- The current token is assumed to be Other. When processing the VMS + -- version of the manual and the token represents a single dot ".", + -- the following word is rewritten according to the rules for + -- extensions. + + VMS_Token_Seen : Boolean := False; + -- This is set to true if a VMS_Alternative has been encountered, or a + -- ^^^ token. + + ---------------- + -- Next_Token -- + ---------------- + + procedure Next_Token is + Remaining_Line : String renames Line (Input_Position .. Line'Last); + Last_Character : Natural; + + begin + if Remaining_Line'Length = 0 then + Token := (End_Of_Line, Remaining_Line'First); + return; + end if; + + -- ^alpha^beta^, the VMS_Alternative case + + if Remaining_Line (Remaining_Line'First) = VMS_Escape_Character then + declare + VMS_Second_Character, VMS_Third_Character : Natural; + + begin + if VMS_Token_Seen then + Error (Source_File, Remaining_Line'First, + "multiple " & VMS_Escape_Character + & " characters on a single line"); + else + VMS_Token_Seen := True; + end if; + + -- Find the second and third escape character. If one of + -- them is not present, generate an error token. + + VMS_Second_Character := + Index (Remaining_Line (Remaining_Line'First + 1 + .. Remaining_Line'Last), + (1 => VMS_Escape_Character)); + + if VMS_Second_Character = 0 then + Input_Position := Remaining_Line'Last + 1; + Token := (VMS_Error, Remaining_Line'First); + return; + end if; + + VMS_Third_Character := + Index (Remaining_Line (VMS_Second_Character + 1 + .. Remaining_Line'Last), + (1 => VMS_Escape_Character)); + + if VMS_Third_Character = 0 then + Input_Position := Remaining_Line'Last + 1; + Token := (VMS_Error, Remaining_Line'First); + return; + end if; + + -- Consume all the characters we are about to include in + -- the token. + + Input_Position := VMS_Third_Character + 1; + + -- Check if we are in a ^^^ situation, and return an Other + -- token in this case. + + if Remaining_Line'First + 1 = VMS_Second_Character + and then Remaining_Line'First + 2 = VMS_Third_Character + then + Token := (Other, Remaining_Line'First, + (Remaining_Line'First, Remaining_Line'First)); + return; + end if; + + Token := (VMS_Alternative, Remaining_Line'First, + (Remaining_Line'First + 1, VMS_Second_Character - 1), + (VMS_Second_Character + 1, VMS_Third_Character - 1)); + return; + end; + end if; -- VMS_Alternative + + -- The Word case. Search for characters not in Word_Characters. + -- We have found a word if the first non-word character is not + -- the first character in Remaining_Line, i.e. if Remaining_Line + -- starts with a word character. + + Last_Character := Index (Remaining_Line, Word_Characters, Outside); + if Last_Character /= Remaining_Line'First then + + -- If we haven't found a character which is not in + -- Word_Characters, all remaining characters are part of the + -- current Word token. + + if Last_Character = 0 then + Last_Character := Remaining_Line'Last + 1; + end if; + + Input_Position := Last_Character; + Token := (Word, Remaining_Line'First, + (Remaining_Line'First, Last_Character - 1)); + return; + end if; + + -- Remaining characters are in the Other category. To speed + -- up processing, we collect them together if there are several + -- of them. + + Input_Position := Last_Character + 1; + Token := (Other, + Remaining_Line'First, + (Remaining_Line'First, Last_Character)); + end Next_Token; + + ------------------ + -- Rewrite_Word -- + ------------------ + + procedure Rewrite_Word is + First_Word : String + renames Line (Token.Span.First .. Token.Span.Last); + + begin + -- We do not perform any error checking below, so we can just skip + -- all processing for the non-VMS version. + + if Target /= VMS then + Append (Rewritten_Line, First_Word); + Next_Token; + return; + end if; + + if Is_Known_Word (First_Word) then + + -- If we have a word from the dictionary, we look for the + -- longest possible sequence we can rewrite. + + declare + Seq : Token_Span := Token.Span; + Lost_Space : Boolean := False; + + begin + Next_Token; + loop + if Token.Kind = Other + and then Line (Token.Span.First .. Token.Span.Last) = " " + then + Next_Token; + if Token.Kind /= Word + or else not Is_Known_Word (Line (Seq.First + .. Token.Span.Last)) + then + -- When we reach this point, the following + -- conditions are true: + -- + -- Seq is a known word. + -- The previous token was a space character. + -- Seq extended to the current token is not a + -- known word. + + Lost_Space := True; + exit; + + else + + -- Extend Seq to cover the current (known) word + + Seq.Last := Token.Span.Last; + Next_Token; + end if; + + else + -- When we reach this point, the following conditions + -- are true: + -- + -- Seq is a known word. + -- The previous token was a word. + -- The current token is not a space character. + + exit; + end if; + end loop; + + -- Rewrite Seq, and add the lost space if necessary + + Append (Rewritten_Line, + Get_Replacement_Word (Line (Seq.First .. Seq.Last))); + if Lost_Space then + Append (Rewritten_Line, ' '); + end if; + + -- The unknown token will be processed during the + -- next iteration of the main loop. + return; + end; + end if; + + Next_Token; + + if Token.Kind = Other + and then Line (Token.Span.First .. Token.Span.Last) = "." + then + -- Deal with extensions + + Next_Token; + if Token.Kind = Word + and then Is_Extension (Line (Token.Span.First + .. Token.Span.Last)) + then + -- We have discovered a file extension. Convert the file + -- name to upper case. + + Append (Rewritten_Line, + Translate (First_Word, Upper_Case_Map) & '.'); + Append (Rewritten_Line, + Get_Replacement_Extension + (Line (Token.Span.First .. Token.Span.Last))); + Next_Token; + else + -- We already have: Word ".", followed by an unknown token + + Append (Rewritten_Line, First_Word & '.'); + + -- The unknown token will be processed during the next + -- iteration of the main loop. + end if; + + else + -- We have an unknown Word, followed by an unknown token. + -- The unknown token will be processed by the outer loop. + + Append (Rewritten_Line, First_Word); + end if; + end Rewrite_Word; + + ----------------------------- + -- Maybe_Rewrite_Extension -- + ----------------------------- + + procedure Maybe_Rewrite_Extension is + begin + -- Again, we need no special processing in the non-VMS case + + if Target = VMS + and then Line (Token.Span.First .. Token.Span.Last) = "." + then + -- This extension is not preceded by a word, otherwise + -- Rewrite_Word would have handled it. + + Next_Token; + if Token.Kind = Word + and then Is_Extension (Line (Token.Span.First + .. Token.Span.Last)) + then + Append (Rewritten_Line, '.' & Get_Replacement_Extension + (Line (Token.Span.First .. Token.Span.Last))); + Next_Token; + else + Append (Rewritten_Line, '.'); + end if; + else + Append (Rewritten_Line, Line (Token.Span.First + .. Token.Span.Last)); + Next_Token; + end if; + end Maybe_Rewrite_Extension; + + -- Start of processing for Process_Source_Line + + begin + -- The following parser recognizes the following special token + -- sequences: + + -- Word "." Word rewrite as file name if second word is extension + -- Word " " Word rewrite as a single word using Ug_Words table + + Next_Token; + loop + case Token.Kind is + when End_Of_Line => + exit; + + when Word => + Rewrite_Word; + + when Other => + Maybe_Rewrite_Extension; + + when VMS_Alternative => + if VMS_Context_Determined then + if (not In_VMS_Section) + or else + Line (Token.VMS.First .. Token.VMS.Last) /= + Line (Token.Non_VMS.First .. Token.Non_VMS.Last) + then + Warning (Source_File, Token.First, + "VMS alternative already determined " + & "by conditionals"); + end if; + end if; + if Target = VMS then + Append (Rewritten_Line, Line (Token.VMS.First + .. Token.VMS.Last)); + else + Append (Rewritten_Line, Line (Token.Non_VMS.First + .. Token.Non_VMS.Last)); + end if; + Next_Token; + + when VMS_Error => + Error (Source_File, Token.First, "invalid VMS alternative"); + Next_Token; + end case; + end loop; + + return S (Rewritten_Line); + end Rewrite_Source_Line; + + ------------------------- + -- Process_Source_File -- + ------------------------- + + procedure Process_Source_File is + Ifset : constant String := "@ifset "; + Ifclear : constant String := "@ifclear "; + Endsetclear : constant String := "@end "; + -- Strings to be recognized for conditional processing + + begin + while not End_Of_File (Source_File.Data) loop + declare + Line : constant String := Get_Line (Source_File'Access); + Rewritten : constant String := Rewrite_Source_Line (Line); + -- We unconditionally rewrite the line so that we can check the + -- syntax of all lines, and not only those which are actually + -- included in the output. + + Have_Conditional : Boolean := False; + -- True if we have encountered a conditional preprocessing + -- directive. + + Cond : Conditional; + -- The kind of the directive + + Flag : Flag_Type; + -- Its flag + + begin + -- If the line starts with @ifset or @ifclear, we try to convert + -- the following flag to one of our flag types. If we fail, + -- Have_Conditional remains False. + + if Line'Length >= Ifset'Length + and then Line (1 .. Ifset'Length) = Ifset + then + Cond := Set; + + declare + Arg : constant String := + Trim (Line (Ifset'Length + 1 .. Line'Last), Both); + + begin + Flag := Flag_Type'Value (Arg); + Have_Conditional := True; + + case Flag is + when Target_Type => + if Translate (Target_Type'Image (Flag), + Lower_Case_Map) + /= Arg + then + Error (Source_File, "flag has to be lowercase"); + end if; + + when Edition_Type => + null; + end case; + exception + when Constraint_Error => + Error (Source_File, "unknown flag for '@ifset'"); + end; + + elsif Line'Length >= Ifclear'Length + and then Line (1 .. Ifclear'Length) = Ifclear + then + Cond := Clear; + + declare + Arg : constant String := + Trim (Line (Ifclear'Length + 1 .. Line'Last), Both); + + begin + Flag := Flag_Type'Value (Arg); + Have_Conditional := True; + + case Flag is + when Target_Type => + if Translate (Target_Type'Image (Flag), + Lower_Case_Map) + /= Arg + then + Error (Source_File, "flag has to be lowercase"); + end if; + + when Edition_Type => + null; + end case; + exception + when Constraint_Error => + Error (Source_File, "unknown flag for '@ifclear'"); + end; + end if; + + if Have_Conditional and (Flag in Target_Type) then + + -- We create a new conditional context and suppress the + -- directive in the output. + + Push_Conditional (Cond, Flag); + + elsif Line'Length >= Endsetclear'Length + and then Line (1 .. Endsetclear'Length) = Endsetclear + and then (Flag in Target_Type) + then + -- The '@end ifset'/'@end ifclear' case is handled here. We + -- have to pop the conditional context. + + declare + First, Last : Natural; + + begin + Find_Token (Source => Line (Endsetclear'Length + 1 + .. Line'Length), + Set => Letter_Set, + Test => Inside, + First => First, + Last => Last); + + if Last = 0 then + Error (Source_File, "'@end' without argument"); + else + if Line (First .. Last) = "ifset" then + Have_Conditional := True; + Cond := Set; + elsif Line (First .. Last) = "ifclear" then + Have_Conditional := True; + Cond := Clear; + end if; + + if Have_Conditional then + Pop_Conditional (Cond); + end if; + + -- We fall through to the ordinary case for other @end + -- directives. + + end if; -- @end without argument + end; + end if; -- Have_Conditional + + if (not Have_Conditional) or (Flag in Edition_Type) then + + -- The ordinary case + + if not Currently_Excluding then + Put_Line (Output_File, Rewritten); + end if; + end if; + end; + end loop; + + Check_No_Pending_Conditional; + end Process_Source_File; + + --------------------------- + -- Initialize_Extensions -- + --------------------------- + + procedure Initialize_Extensions is + + procedure Add (Extension : String); + -- Adds an extension which is replaced with itself (in upper + -- case). + + procedure Add (Extension, Replacement : String); + -- Adds an extension with a custom replacement + + --------- + -- Add -- + --------- + + procedure Add (Extension : String) is + begin + Add (Extension, Translate (Extension, Upper_Case_Map)); + end Add; + + procedure Add (Extension, Replacement : String) is + begin + Set (Extensions, Extension, V (Replacement)); + end Add; + + -- Start of processing for Initialize_Extensions + + begin + -- To avoid performance degradation, increase the constant in the + -- definition of Extensions above if you add more extensions here. + + Add ("o", "OBJ"); + Add ("ads"); + Add ("adb"); + Add ("ali"); + Add ("ada"); + Add ("atb"); + Add ("ats"); + Add ("adc"); + Add ("c"); + end Initialize_Extensions; + + ------------------ + -- Is_Extension -- + ------------------ + + function Is_Extension (Extension : String) return Boolean is + begin + return Present (Extensions, Extension); + end Is_Extension; + + ------------------------------- + -- Get_Replacement_Extension -- + ------------------------------- + + function Get_Replacement_Extension (Extension : String) return String is + begin + return S (Get (Extensions, Extension)); + end Get_Replacement_Extension; + + ------------------- + -- Is_Known_Word -- + ------------------- + + function Is_Known_Word (Word : String) return Boolean is + begin + return Present (Ug_Words, Word); + end Is_Known_Word; + + -------------------------- + -- Get_Replacement_Word -- + -------------------------- + + function Get_Replacement_Word (Word : String) return String is + begin + return S (Get (Ug_Words, Word)); + end Get_Replacement_Word; + + ---------------------- + -- Push_Conditional -- + ---------------------- + + procedure Push_Conditional (Cond : Conditional; Flag : Target_Type) is + Will_Exclude : Boolean; + + begin + -- If we are already in an excluding context, inherit this property, + -- otherwise calculate it from scratch. + + if Conditional_TOS > 0 + and then Conditional_Stack (Conditional_TOS).Excluding + then + Will_Exclude := True; + else + case Cond is + when Set => + Will_Exclude := Flag /= Target; + when Clear => + Will_Exclude := Flag = Target; + end case; + end if; + + -- Check if the current directive is pointless because of a previous, + -- enclosing directive. + + for J in 1 .. Conditional_TOS loop + if Conditional_Stack (J).Flag = Flag then + Warning (Source_File, "directive without effect because of line" + & Integer'Image (Conditional_Stack (J).Starting_Line)); + end if; + end loop; + + Conditional_TOS := Conditional_TOS + 1; + Conditional_Stack (Conditional_TOS) := + (Starting_Line => Source_File.Line, + Cond => Cond, + Flag => Flag, + Excluding => Will_Exclude); + end Push_Conditional; + + --------------------- + -- Pop_Conditional -- + --------------------- + + procedure Pop_Conditional (Cond : Conditional) is + begin + if Conditional_TOS > 0 then + case Cond is + when Set => + if Conditional_Stack (Conditional_TOS).Cond /= Set then + Error (Source_File, + "'@end ifset' does not match '@ifclear' at line" + & Integer'Image (Conditional_Stack + (Conditional_TOS).Starting_Line)); + end if; + + when Clear => + if Conditional_Stack (Conditional_TOS).Cond /= Clear then + Error (Source_File, + "'@end ifclear' does not match '@ifset' at line" + & Integer'Image (Conditional_Stack + (Conditional_TOS).Starting_Line)); + end if; + end case; + + Conditional_TOS := Conditional_TOS - 1; + + else + case Cond is + when Set => + Error (Source_File, + "'@end ifset' without corresponding '@ifset'"); + + when Clear => + Error (Source_File, + "'@end ifclear' without corresponding '@ifclear'"); + end case; + end if; + end Pop_Conditional; + + ------------------------- + -- Currently_Excluding -- + ------------------------- + + function Currently_Excluding return Boolean is + begin + return Conditional_TOS > 0 + and then Conditional_Stack (Conditional_TOS).Excluding; + end Currently_Excluding; + + ---------------------------- + -- VMS_Context_Determined -- + ---------------------------- + + function VMS_Context_Determined return Boolean is + begin + for J in 1 .. Conditional_TOS loop + if Conditional_Stack (J).Flag = VMS then + return True; + end if; + end loop; + + return False; + end VMS_Context_Determined; + + -------------------- + -- In_VMS_Section -- + -------------------- + + function In_VMS_Section return Boolean is + begin + for J in 1 .. Conditional_TOS loop + if Conditional_Stack (J).Flag = VMS then + return Conditional_Stack (J).Cond = Set; + end if; + end loop; + + return False; + end In_VMS_Section; + + ---------------------------------- + -- Check_No_Pending_Conditional -- + ---------------------------------- + + procedure Check_No_Pending_Conditional is + begin + for J in 1 .. Conditional_TOS loop + case Conditional_Stack (J).Cond is + when Set => + Error (Source_File, "Missing '@end ifset' for '@ifset' at line" + & Integer'Image (Conditional_Stack (J).Starting_Line)); + + when Clear => + Error (Source_File, + "Missing '@end ifclear' for '@ifclear' at line" + & Integer'Image (Conditional_Stack (J).Starting_Line)); + end case; + end loop; + end Check_No_Pending_Conditional; + +-- Start of processing for Xgnatugn + + Valid_Command_Line : Boolean; + Output_File_Name : VString; + +begin + Initialize_Extensions; + Valid_Command_Line := Argument_Count in 3 .. 5; + + -- First argument: Target + + if Valid_Command_Line then + begin + Target := Flag_Type'Value (Argument (1)); + + if not Target'Valid then + Valid_Command_Line := False; + end if; + + exception + when Constraint_Error => + Valid_Command_Line := False; + end; + end if; + + -- Second argument: Source_File + + if Valid_Command_Line then + begin + Source_File.Name := V (Argument (2)); + Open (Source_File.Data, In_File, Argument (2)); + + exception + when Ada.Text_IO.Name_Error => + Valid_Command_Line := False; + end; + end if; + + -- Third argument: Dictionary_File + + if Valid_Command_Line then + begin + Dictionary_File.Name := V (Argument (3)); + Open (Dictionary_File.Data, In_File, Argument (3)); + + exception + when Ada.Text_IO.Name_Error => + Valid_Command_Line := False; + end; + end if; + + -- Fourth argument: Output_File + + if Valid_Command_Line then + if Argument_Count in 4 .. 5 then + Output_File_Name := V (Argument (4)); + else + case Target is + when UNW => + Output_File_Name := V ("gnat_ugn_unw.texi"); + when VMS => + Output_File_Name := V ("gnat_ugn_vms.texi"); + end case; + end if; + + Warnings_Enabled := Argument_Count = 5; + + begin + Create (Output_File, Out_File, S (Output_File_Name)); + + exception + when Ada.Text_IO.Name_Error | Ada.Text_IO.Use_Error => + Valid_Command_Line := False; + end; + end if; + + if not Valid_Command_Line then + Usage; + Set_Exit_Status (Failure); + + else + Read_Dictionary_File; + Close (Dictionary_File.Data); + + -- Main processing starts here + + Process_Source_File; + Close (Output_File); + Close (Source_File.Data); + + New_Line (Standard_Error); + + if Number_Of_Warnings = 0 then + Put_Line (Standard_Error, " NO Warnings"); + + else + Put (Standard_Error, Integer'Image (Number_Of_Warnings)); + Put (Standard_Error, " Warning"); + + if Number_Of_Warnings > 1 then + Put (Standard_Error, "s"); + end if; + + New_Line (Standard_Error); + end if; + + if Number_Of_Errors = 0 then + Put_Line (Standard_Error, " NO Errors"); + + else + Put (Standard_Error, Integer'Image (Number_Of_Errors)); + Put (Standard_Error, " Error"); + + if Number_Of_Errors > 1 then + Put (Standard_Error, "s"); + end if; + + New_Line (Standard_Error); + end if; + + if Number_Of_Errors /= 0 then + Set_Exit_Status (Failure); + else + Set_Exit_Status (Success); + end if; + end if; +end Xgnatugn; diff --git a/gcc/ada/xnmake.adb b/gcc/ada/xnmake.adb new file mode 100644 index 000000000..e218d6747 --- /dev/null +++ b/gcc/ada/xnmake.adb @@ -0,0 +1,467 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT SYSTEM UTILITIES -- +-- -- +-- X N M A K E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Program to construct the spec and body of the Nmake package + +-- Input files: + +-- sinfo.ads Spec of Sinfo package +-- nmake.adt Template for Nmake package + +-- Output files: + +-- nmake.ads Spec of Nmake package +-- nmake.adb Body of Nmake package + +-- Note: this program assumes that sinfo.ads has passed the error checks that +-- are carried out by the csinfo utility, so it does not duplicate these +-- checks and assumes that sinfo.ads has the correct form. + +-- In the absence of any switches, both the ads and adb files are output. +-- The switch -s or /s indicates that only the ads file is to be output. +-- The switch -b or /b indicates that only the adb file is to be output. + +-- If a file name argument is given, then the output is written to this file +-- rather than to nmake.ads or nmake.adb. A file name can only be given if +-- exactly one of the -s or -b options is present. + +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; +with Ada.Strings.Maps; use Ada.Strings.Maps; +with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; +with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.Spitbol; use GNAT.Spitbol; +with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; + +with XUtil; + +procedure XNmake is + + Err : exception; + -- Raised to terminate execution + + A : VString := Nul; + Arg : VString := Nul; + Arg_List : VString := Nul; + Comment : VString := Nul; + Default : VString := Nul; + Field : VString := Nul; + Line : VString := Nul; + Node : VString := Nul; + Op_Name : VString := Nul; + Prevl : VString := Nul; + Synonym : VString := Nul; + X : VString := Nul; + + NWidth : Natural; + + FileS : VString := V ("nmake.ads"); + FileB : VString := V ("nmake.adb"); + -- Set to null if corresponding file not to be generated + + Given_File : VString := Nul; + -- File name given by command line argument + + subtype Sfile is Ada.Streams.Stream_IO.File_Type; + + InS, InT : Ada.Text_IO.File_Type; + OutS, OutB : Sfile; + + wsp : constant Pattern := Span (' ' & ASCII.HT); + + Body_Only : constant Pattern := BreakX (' ') * X + & Span (' ') & "-- body only"; + Spec_Only : constant Pattern := BreakX (' ') * X + & Span (' ') & "-- spec only"; + + Node_Hdr : constant Pattern := wsp & "-- N_" & Rest * Node; + Punc : constant Pattern := BreakX (" .,"); + + Binop : constant Pattern := wsp + & "-- plus fields for binary operator"; + Unop : constant Pattern := wsp + & "-- plus fields for unary operator"; + Syn : constant Pattern := wsp & "-- " & Break (' ') * Synonym + & " (" & Break (')') * Field + & Rest * Comment; + + Templ : constant Pattern := BreakX ('T') * A & "T e m p l a t e"; + Spec : constant Pattern := BreakX ('S') * A & "S p e c"; + + Sem_Field : constant Pattern := BreakX ('-') & "-Sem"; + Lib_Field : constant Pattern := BreakX ('-') & "-Lib"; + + Get_Field : constant Pattern := BreakX (Decimal_Digit_Set) * Field; + + Get_Dflt : constant Pattern := BreakX ('(') & "(set to " + & Break (" ") * Default & " if"; + + Next_Arg : constant Pattern := Break (',') * Arg & ','; + + Op_Node : constant Pattern := "Op_" & Rest * Op_Name; + + Shft_Rot : constant Pattern := "Shift_" or "Rotate_"; + + No_Ent : constant Pattern := "Or_Else" or "And_Then" + or "In" or "Not_In"; + + M : Match_Result; + + V_String_Id : constant VString := V ("String_Id"); + V_Node_Id : constant VString := V ("Node_Id"); + V_Name_Id : constant VString := V ("Name_Id"); + V_List_Id : constant VString := V ("List_Id"); + V_Elist_Id : constant VString := V ("Elist_Id"); + V_Boolean : constant VString := V ("Boolean"); + + procedure Put_Line (F : Sfile; S : String) renames XUtil.Put_Line; + procedure Put_Line (F : Sfile; S : VString) renames XUtil.Put_Line; + -- Local version of Put_Line ensures Unix style line endings + + procedure WriteS (S : String); + procedure WriteB (S : String); + procedure WriteBS (S : String); + procedure WriteS (S : VString); + procedure WriteB (S : VString); + procedure WriteBS (S : VString); + -- Write given line to spec or body file or both if active + + procedure WriteB (S : String) is + begin + if FileB /= Nul then + Put_Line (OutB, S); + end if; + end WriteB; + + procedure WriteB (S : VString) is + begin + if FileB /= Nul then + Put_Line (OutB, S); + end if; + end WriteB; + + procedure WriteBS (S : String) is + begin + if FileB /= Nul then + Put_Line (OutB, S); + end if; + + if FileS /= Nul then + Put_Line (OutS, S); + end if; + end WriteBS; + + procedure WriteBS (S : VString) is + begin + if FileB /= Nul then + Put_Line (OutB, S); + end if; + + if FileS /= Nul then + Put_Line (OutS, S); + end if; + end WriteBS; + + procedure WriteS (S : String) is + begin + if FileS /= Nul then + Put_Line (OutS, S); + end if; + end WriteS; + + procedure WriteS (S : VString) is + begin + if FileS /= Nul then + Put_Line (OutS, S); + end if; + end WriteS; + +-- Start of processing for XNmake + +begin + NWidth := 28; + Anchored_Mode := True; + + for ArgN in 1 .. Argument_Count loop + declare + Arg : constant String := Argument (ArgN); + + begin + if Arg (1) = '-' then + if Arg'Length = 2 + and then (Arg (2) = 'b' or else Arg (2) = 'B') + then + FileS := Nul; + + elsif Arg'Length = 2 + and then (Arg (2) = 's' or else Arg (2) = 'S') + then + FileB := Nul; + + else + raise Err; + end if; + + else + if Given_File /= Nul then + raise Err; + else + Given_File := V (Arg); + end if; + end if; + end; + end loop; + + if FileS = Nul and then FileB = Nul then + raise Err; + + elsif Given_File /= Nul then + if FileB = Nul then + FileS := Given_File; + + elsif FileS = Nul then + FileB := Given_File; + + else + raise Err; + end if; + end if; + + Open (InS, In_File, "sinfo.ads"); + Open (InT, In_File, "nmake.adt"); + + if FileS /= Nul then + Create (OutS, Out_File, S (FileS)); + end if; + + if FileB /= Nul then + Create (OutB, Out_File, S (FileB)); + end if; + + Anchored_Mode := True; + + -- Copy initial part of template to spec and body + + loop + Line := Get_Line (InT); + + -- Skip lines describing the template + + if Match (Line, "-- This file is a template") then + loop + Line := Get_Line (InT); + exit when Line = ""; + end loop; + end if; + + -- Loop keeps going until "package" keyword written + + exit when Match (Line, "package"); + + -- Deal with WITH lines, writing to body or spec as appropriate + + if Match (Line, Body_Only, M) then + Replace (M, X); + WriteB (Line); + + elsif Match (Line, Spec_Only, M) then + Replace (M, X); + WriteS (Line); + + -- Change header from Template to Spec and write to spec file + + else + if Match (Line, Templ, M) then + Replace (M, A & " S p e c "); + end if; + + WriteS (Line); + + -- Write header line to body file + + if Match (Line, Spec, M) then + Replace (M, A & "B o d y"); + end if; + + WriteB (Line); + end if; + end loop; + + -- Package line reached + + WriteS ("package Nmake is"); + WriteB ("package body Nmake is"); + WriteB (""); + + -- Copy rest of lines up to template insert point to spec only + + loop + Line := Get_Line (InT); + exit when Match (Line, "!!TEMPLATE INSERTION POINT"); + WriteS (Line); + end loop; + + -- Here we are doing the actual insertions, loop through node types + + loop + Line := Get_Line (InS); + + if Match (Line, Node_Hdr) + and then not Match (Node, Punc) + and then Node /= "Unused" + then + exit when Node = "Empty"; + Prevl := " function Make_" & Node & " (Sloc : Source_Ptr"; + Arg_List := Nul; + + -- Loop through fields of one node + + loop + Line := Get_Line (InS); + exit when Line = ""; + + if Match (Line, Binop) then + WriteBS (Prevl & ';'); + Append (Arg_List, "Left_Opnd,Right_Opnd,"); + WriteBS ( + " " & Rpad ("Left_Opnd", NWidth) & " : Node_Id;"); + Prevl := + " " & Rpad ("Right_Opnd", NWidth) & " : Node_Id"; + + elsif Match (Line, Unop) then + WriteBS (Prevl & ';'); + Append (Arg_List, "Right_Opnd,"); + Prevl := " " & Rpad ("Right_Opnd", NWidth) & " : Node_Id"; + + elsif Match (Line, Syn) then + if Synonym /= "Prev_Ids" + and then Synonym /= "More_Ids" + and then Synonym /= "Comes_From_Source" + and then Synonym /= "Paren_Count" + and then not Match (Field, Sem_Field) + and then not Match (Field, Lib_Field) + then + Match (Field, Get_Field); + + if Field = "Str" then + Field := V_String_Id; + elsif Field = "Node" then + Field := V_Node_Id; + elsif Field = "Name" then + Field := V_Name_Id; + elsif Field = "List" then + Field := V_List_Id; + elsif Field = "Elist" then + Field := V_Elist_Id; + elsif Field = "Flag" then + Field := V_Boolean; + end if; + + if Field = "Boolean" then + Default := V ("False"); + else + Default := Nul; + end if; + + Match (Comment, Get_Dflt); + + WriteBS (Prevl & ';'); + Append (Arg_List, Synonym & ','); + Rpad (Synonym, NWidth); + + if Default = "" then + Prevl := " " & Synonym & " : " & Field; + else + Prevl := + " " & Synonym & " : " & Field & " := " & Default; + end if; + end if; + end if; + end loop; + + WriteBS (Prevl & ')'); + WriteS (" return Node_Id;"); + WriteS (" pragma Inline (Make_" & Node & ");"); + WriteB (" return Node_Id"); + WriteB (" is"); + WriteB (" N : constant Node_Id :="); + + if Match (Node, "Defining_Identifier") or else + Match (Node, "Defining_Character") or else + Match (Node, "Defining_Operator") + then + WriteB (" New_Entity (N_" & Node & ", Sloc);"); + else + WriteB (" New_Node (N_" & Node & ", Sloc);"); + end if; + + WriteB (" begin"); + + while Match (Arg_List, Next_Arg, "") loop + if Length (Arg) < NWidth then + WriteB (" Set_" & Arg & " (N, " & Arg & ");"); + else + WriteB (" Set_" & Arg); + WriteB (" (N, " & Arg & ");"); + end if; + end loop; + + if Match (Node, Op_Node) then + if Node = "Op_Plus" then + WriteB (" Set_Chars (N, Name_Op_Add);"); + + elsif Node = "Op_Minus" then + WriteB (" Set_Chars (N, Name_Op_Subtract);"); + + elsif Match (Op_Name, Shft_Rot) then + WriteB (" Set_Chars (N, Name_" & Op_Name & ");"); + + else + WriteB (" Set_Chars (N, Name_" & Node & ");"); + end if; + + if not Match (Op_Name, No_Ent) then + WriteB (" Set_Entity (N, Standard_" & Node & ");"); + end if; + end if; + + WriteB (" return N;"); + WriteB (" end Make_" & Node & ';'); + WriteBS (""); + end if; + end loop; + + WriteBS ("end Nmake;"); + +exception + + when Err => + Put_Line (Standard_Error, "usage: xnmake [-b] [-s] [filename]"); + Set_Exit_Status (1); + +end XNmake; diff --git a/gcc/ada/xoscons.adb b/gcc/ada/xoscons.adb new file mode 100644 index 000000000..56ea8a877 --- /dev/null +++ b/gcc/ada/xoscons.adb @@ -0,0 +1,494 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT SYSTEM UTILITIES -- +-- -- +-- X O S C O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2008-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This program generates the spec of System.OS_Constants (s-oscons.ads) + +-- It works in conjunction with a C template file which must be pre-processed +-- and compiled using the cross compiler. Two input files are used: +-- - the preprocessed C file: s-oscons-tmplt.i +-- - the generated assembly file: s-oscons-tmplt.s + +-- The contents of s-oscons.ads is written on standard output + +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Exceptions; use Ada.Exceptions; +with Ada.Strings.Fixed; use Ada.Strings.Fixed; +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; + +pragma Warnings (Off); +-- System.Unsigned_Types is an internal GNAT unit +with System.Unsigned_Types; use System.Unsigned_Types; +pragma Warnings (On); + +with GNAT.Table; + +with XUtil; use XUtil; + +procedure XOSCons is + + use ASCII; + use Ada.Strings; + + Unit_Name : constant String := "s-oscons"; + Tmpl_Name : constant String := Unit_Name & "-tmplt"; + + ------------------------------------------------- + -- Information retrieved from assembly listing -- + ------------------------------------------------- + + type String_Access is access all String; + -- Note: we can't use GNAT.Strings for this definition, since that unit + -- is not available in older base compilers. + + -- We need to deal with integer values that can be signed or unsigned, so + -- we need to accommodate the maximum range of both cases. + + type Int_Value_Type is record + Positive : Boolean; + Abs_Value : Long_Unsigned := 0; + end record; + + type Asm_Info_Kind is + (CND, -- Named number (decimal) + CNS, -- Named number (freeform text) + C, -- Constant object + TXT); -- Literal text + -- Recognized markers found in assembly file. These markers are produced by + -- the same-named macros from the C template. + + subtype Named_Number is Asm_Info_Kind range CND .. CNS; + + type Asm_Info (Kind : Asm_Info_Kind := TXT) is record + Line_Number : Integer; + -- Line number in C source file + + Constant_Name : String_Access; + -- Name of constant to be defined + + Constant_Type : String_Access; + -- Type of constant (case of Kind = C) + + Value_Len : Natural := 0; + -- Length of text representation of constant's value + + Text_Value : String_Access; + -- Value for CNS / C constant + + Int_Value : Int_Value_Type; + -- Value for CND constant + + Comment : String_Access; + -- Additional descriptive comment for constant, or free-form text (TXT) + end record; + + package Asm_Infos is new GNAT.Table + (Table_Component_Type => Asm_Info, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 100, + Table_Increment => 10); + + Max_Constant_Name_Len : Natural := 0; + Max_Constant_Value_Len : Natural := 0; + Max_Constant_Type_Len : Natural := 0; + -- Lengths of longest name and longest value + + type Language is (Lang_Ada, Lang_C); + + procedure Output_Info + (Lang : Language; + OFile : Sfile; + Info_Index : Integer); + -- Output information from the indicated asm info line + + procedure Parse_Asm_Line (Line : String); + -- Parse one information line from the assembly source + + function Contains_Template_Name (S : String) return Boolean; + -- True if S contains Tmpl_Name, possibly with different casing + + function Spaces (Count : Integer) return String; + -- If Count is positive, return a string of Count spaces, else return an + -- empty string. + + ---------------------------- + -- Contains_Template_Name -- + ---------------------------- + + function Contains_Template_Name (S : String) return Boolean is + begin + if Index (Source => To_Lower (S), Pattern => Tmpl_Name) > 0 then + return True; + else + return False; + end if; + end Contains_Template_Name; + + ----------------- + -- Output_Info -- + ----------------- + + procedure Output_Info + (Lang : Language; + OFile : Sfile; + Info_Index : Integer) + is + Info : Asm_Info renames Asm_Infos.Table (Info_Index); + + procedure Put (S : String); + -- Write S to OFile + + --------- + -- Put -- + --------- + + procedure Put (S : String) is + begin + Put (OFile, S); + end Put; + + begin + if Info.Kind /= TXT then + -- TXT case is handled by the common code below + + case Lang is + when Lang_Ada => + Put (" " & Info.Constant_Name.all); + Put (Spaces (Max_Constant_Name_Len + - Info.Constant_Name'Length)); + + if Info.Kind in Named_Number then + Put (" : constant := "); + else + Put (" : constant " & Info.Constant_Type.all); + Put (Spaces (Max_Constant_Type_Len + - Info.Constant_Type'Length)); + Put (" := "); + end if; + + when Lang_C => + Put ("#define " & Info.Constant_Name.all & " "); + Put (Spaces (Max_Constant_Name_Len + - Info.Constant_Name'Length)); + end case; + + if Info.Kind = CND then + if not Info.Int_Value.Positive then + Put ("-"); + end if; + Put (Trim (Info.Int_Value.Abs_Value'Img, Side => Left)); + else + declare + Is_String : constant Boolean := + Info.Kind = C + and then Info.Constant_Type.all = "String"; + begin + if Is_String then + Put (""""); + end if; + Put (Info.Text_Value.all); + if Is_String then + Put (""""); + end if; + end; + end if; + + if Lang = Lang_Ada then + Put (";"); + + if Info.Comment'Length > 0 then + Put (Spaces (Max_Constant_Value_Len - Info.Value_Len)); + Put (" -- "); + end if; + end if; + end if; + + if Lang = Lang_Ada then + Put (Info.Comment.all); + end if; + + New_Line (OFile); + end Output_Info; + + -------------------- + -- Parse_Asm_Line -- + -------------------- + + procedure Parse_Asm_Line (Line : String) is + Index1, Index2 : Integer := Line'First; + + function Field_Alloc return String_Access; + -- Allocate and return a copy of Line (Index1 .. Index2 - 1) + + procedure Find_Colon (Index : in out Integer); + -- Increment Index until the next colon in Line + + function Parse_Int (S : String) return Int_Value_Type; + -- Parse a decimal number, preceded by an optional '$' or '#' character, + -- and return its value. + + ----------------- + -- Field_Alloc -- + ----------------- + + function Field_Alloc return String_Access is + begin + return new String'(Line (Index1 .. Index2 - 1)); + end Field_Alloc; + + ---------------- + -- Find_Colon -- + ---------------- + + procedure Find_Colon (Index : in out Integer) is + begin + loop + Index := Index + 1; + exit when Index > Line'Last or else Line (Index) = ':'; + end loop; + end Find_Colon; + + --------------- + -- Parse_Int -- + --------------- + + function Parse_Int (S : String) return Int_Value_Type is + First : Integer := S'First; + Positive : Boolean; + begin + -- On some platforms, immediate integer values are prefixed with + -- a $ or # character in assembly output. + + if S (First) = '$' or else S (First) = '#' then + First := First + 1; + end if; + + if S (First) = '-' then + Positive := False; + First := First + 1; + else + Positive := True; + end if; + + return (Positive => Positive, + Abs_Value => Long_Unsigned'Value (S (First .. S'Last))); + + exception + when E : others => + Put_Line (Standard_Error, "can't parse decimal value: " & S); + raise; + end Parse_Int; + + -- Start of processing for Parse_Asm_Line + + begin + Find_Colon (Index2); + + declare + Info : Asm_Info (Kind => Asm_Info_Kind'Value + (Line (Line'First .. Index2 - 1))); + begin + Index1 := Index2 + 1; + Find_Colon (Index2); + + Info.Line_Number := + Integer (Parse_Int (Line (Index1 .. Index2 - 1)).Abs_Value); + + case Info.Kind is + when CND | CNS | C => + Index1 := Index2 + 1; + Find_Colon (Index2); + + Info.Constant_Name := Field_Alloc; + if Info.Constant_Name'Length > Max_Constant_Name_Len then + Max_Constant_Name_Len := Info.Constant_Name'Length; + end if; + + Index1 := Index2 + 1; + Find_Colon (Index2); + + if Info.Kind = C then + Info.Constant_Type := Field_Alloc; + if Info.Constant_Type'Length > Max_Constant_Type_Len then + Max_Constant_Type_Len := Info.Constant_Type'Length; + end if; + + Index1 := Index2 + 1; + Find_Colon (Index2); + end if; + + if Info.Kind = CND then + Info.Int_Value := Parse_Int (Line (Index1 .. Index2 - 1)); + Info.Value_Len := Index2 - Index1 - 1; + + else + Info.Text_Value := Field_Alloc; + Info.Value_Len := Info.Text_Value'Length; + end if; + + when others => + null; + end case; + + Index1 := Index2 + 1; + Index2 := Line'Last + 1; + Info.Comment := Field_Alloc; + + if Info.Kind = TXT then + Info.Text_Value := Info.Comment; + + -- Update Max_Constant_Value_Len, but only if this constant has a + -- comment (else the value is allowed to be longer). + + elsif Info.Comment'Length > 0 then + if Info.Value_Len > Max_Constant_Value_Len then + Max_Constant_Value_Len := Info.Value_Len; + end if; + end if; + + Asm_Infos.Append (Info); + end; + exception + when E : others => + Put_Line (Standard_Error, + "can't parse " & Line); + Put_Line (Standard_Error, + "exception raised: " & Exception_Information (E)); + end Parse_Asm_Line; + + ------------ + -- Spaces -- + ------------ + + function Spaces (Count : Integer) return String is + begin + if Count <= 0 then + return ""; + else + return (1 .. Count => ' '); + end if; + end Spaces; + + -- Local declarations + + -- Input files + + Tmpl_File_Name : constant String := Tmpl_Name & ".i"; + Asm_File_Name : constant String := Tmpl_Name & ".s"; + + -- Output files + + Ada_File_Name : constant String := Unit_Name & ".ads"; + C_File_Name : constant String := Unit_Name & ".h"; + + Asm_File : Ada.Text_IO.File_Type; + Tmpl_File : Ada.Text_IO.File_Type; + Ada_OFile : Sfile; + C_OFile : Sfile; + + Line : String (1 .. 256); + Last : Integer; + -- Line being processed + + Current_Line : Integer; + Current_Info : Integer; + In_Comment : Boolean; + In_Template : Boolean; + +-- Start of processing for XOSCons + +begin + -- Load values from assembly file + + Open (Asm_File, In_File, Asm_File_Name); + + while not End_Of_File (Asm_File) loop + Get_Line (Asm_File, Line, Last); + if Last > 2 and then Line (1 .. 2) = "->" then + Parse_Asm_Line (Line (3 .. Last)); + end if; + end loop; + + Close (Asm_File); + + -- Load C template and output definitions + + Open (Tmpl_File, In_File, Tmpl_File_Name); + Create (Ada_OFile, Out_File, Ada_File_Name); + Create (C_OFile, Out_File, C_File_Name); + + Current_Line := 0; + Current_Info := Asm_Infos.First; + In_Comment := False; + + while not End_Of_File (Tmpl_File) loop + <> + Get_Line (Tmpl_File, Line, Last); + + if Last >= 2 and then Line (1 .. 2) = "# " then + declare + Index : Integer := 3; + begin + while Index <= Last and then Line (Index) in '0' .. '9' loop + Index := Index + 1; + end loop; + + if Contains_Template_Name (Line (Index + 1 .. Last)) then + Current_Line := Integer'Value (Line (3 .. Index - 1)); + In_Template := True; + goto Get_One_Line; + else + In_Template := False; + end if; + end; + + elsif In_Template then + if In_Comment then + if Line (1 .. Last) = "*/" then + Put_Line (C_OFile, Line (1 .. Last)); + In_Comment := False; + else + Put_Line (Ada_OFile, Line (1 .. Last)); + Put_Line (C_OFile, Line (1 .. Last)); + end if; + + elsif Line (1 .. Last) = "/*" then + Put_Line (C_OFile, Line (1 .. Last)); + In_Comment := True; + + elsif Asm_Infos.Table (Current_Info).Line_Number = Current_Line then + Output_Info (Lang_Ada, Ada_OFile, Current_Info); + Output_Info (Lang_C, C_OFile, Current_Info); + Current_Info := Current_Info + 1; + end if; + + Current_Line := Current_Line + 1; + end if; + end loop; + + Close (Tmpl_File); + +end XOSCons; diff --git a/gcc/ada/xr_tabls.adb b/gcc/ada/xr_tabls.adb new file mode 100644 index 000000000..eea7fcbc9 --- /dev/null +++ b/gcc/ada/xr_tabls.adb @@ -0,0 +1,1634 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- X R _ T A B L S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Types; use Types; +with Osint; +with Hostparm; + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with Ada.Strings.Fixed; +with Ada.Strings; +with Ada.Text_IO; +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; + +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.HTable; use GNAT.HTable; +with GNAT.Heap_Sort_G; + +package body Xr_Tabls is + + type HTable_Headers is range 1 .. 10000; + + procedure Set_Next (E : File_Reference; Next : File_Reference); + function Next (E : File_Reference) return File_Reference; + function Get_Key (E : File_Reference) return Cst_String_Access; + function Hash (F : Cst_String_Access) return HTable_Headers; + function Equal (F1, F2 : Cst_String_Access) return Boolean; + -- The five subprograms above are used to instantiate the static + -- htable to store the files that should be processed. + + package File_HTable is new GNAT.HTable.Static_HTable + (Header_Num => HTable_Headers, + Element => File_Record, + Elmt_Ptr => File_Reference, + Null_Ptr => null, + Set_Next => Set_Next, + Next => Next, + Key => Cst_String_Access, + Get_Key => Get_Key, + Hash => Hash, + Equal => Equal); + -- A hash table to store all the files referenced in the + -- application. The keys in this htable are the name of the files + -- themselves, therefore it is assumed that the source path + -- doesn't contain twice the same source or ALI file name + + type Unvisited_Files_Record; + type Unvisited_Files_Access is access Unvisited_Files_Record; + type Unvisited_Files_Record is record + File : File_Reference; + Next : Unvisited_Files_Access; + end record; + -- A special list, in addition to File_HTable, that only stores + -- the files that haven't been visited so far. Note that the File + -- list points to some data in File_HTable, and thus should never be freed. + + function Next (E : Declaration_Reference) return Declaration_Reference; + procedure Set_Next (E, Next : Declaration_Reference); + function Get_Key (E : Declaration_Reference) return Cst_String_Access; + -- The subprograms above are used to instantiate the static + -- htable to store the entities that have been found in the application + + package Entities_HTable is new GNAT.HTable.Static_HTable + (Header_Num => HTable_Headers, + Element => Declaration_Record, + Elmt_Ptr => Declaration_Reference, + Null_Ptr => null, + Set_Next => Set_Next, + Next => Next, + Key => Cst_String_Access, + Get_Key => Get_Key, + Hash => Hash, + Equal => Equal); + -- A hash table to store all the entities defined in the + -- application. For each entity, we store a list of its reference + -- locations as well. + -- The keys in this htable should be created with Key_From_Ref, + -- and are the file, line and column of the declaration, which are + -- unique for every entity. + + Entities_Count : Natural := 0; + -- Number of entities in Entities_HTable. This is used in the end + -- when sorting the table. + + Longest_File_Name_In_Table : Natural := 0; + Unvisited_Files : Unvisited_Files_Access := null; + Directories : Project_File_Ptr; + Default_Match : Boolean := False; + -- The above need commenting ??? + + function Parse_Gnatls_Src return String; + -- Return the standard source directories (taking into account the + -- ADA_INCLUDE_PATH environment variable, if Osint.Add_Default_Search_Dirs + -- was called first). + + function Parse_Gnatls_Obj return String; + -- Return the standard object directories (taking into account the + -- ADA_OBJECTS_PATH environment variable). + + function Key_From_Ref + (File_Ref : File_Reference; + Line : Natural; + Column : Natural) + return String; + -- Return a key for the symbol declared at File_Ref, Line, + -- Column. This key should be used for lookup in Entity_HTable + + function Is_Less_Than (Decl1, Decl2 : Declaration_Reference) return Boolean; + -- Compare two declarations (the comparison is case-insensitive) + + function Is_Less_Than (Ref1, Ref2 : Reference) return Boolean; + -- Compare two references + + procedure Store_References + (Decl : Declaration_Reference; + Get_Writes : Boolean := False; + Get_Reads : Boolean := False; + Get_Bodies : Boolean := False; + Get_Declaration : Boolean := False; + Arr : in out Reference_Array; + Index : in out Natural); + -- Store in Arr, starting at Index, all the references to Decl. The Get_* + -- parameters can be used to indicate which references should be stored. + -- Constraint_Error will be raised if Arr is not big enough. + + procedure Sort (Arr : in out Reference_Array); + -- Sort an array of references (Arr'First must be 1) + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (E : File_Reference; Next : File_Reference) is + begin + E.Next := Next; + end Set_Next; + + procedure Set_Next + (E : Declaration_Reference; Next : Declaration_Reference) is + begin + E.Next := Next; + end Set_Next; + + ------------- + -- Get_Key -- + ------------- + + function Get_Key (E : File_Reference) return Cst_String_Access is + begin + return E.File; + end Get_Key; + + function Get_Key (E : Declaration_Reference) return Cst_String_Access is + begin + return E.Key; + end Get_Key; + + ---------- + -- Hash -- + ---------- + + function Hash (F : Cst_String_Access) return HTable_Headers is + function H is new GNAT.HTable.Hash (HTable_Headers); + + begin + return H (F.all); + end Hash; + + ----------- + -- Equal -- + ----------- + + function Equal (F1, F2 : Cst_String_Access) return Boolean is + begin + return F1.all = F2.all; + end Equal; + + ------------------ + -- Key_From_Ref -- + ------------------ + + function Key_From_Ref + (File_Ref : File_Reference; + Line : Natural; + Column : Natural) + return String + is + begin + return File_Ref.File.all & Natural'Image (Line) & Natural'Image (Column); + end Key_From_Ref; + + --------------------- + -- Add_Declaration -- + --------------------- + + function Add_Declaration + (File_Ref : File_Reference; + Symbol : String; + Line : Natural; + Column : Natural; + Decl_Type : Character; + Remove_Only : Boolean := False; + Symbol_Match : Boolean := True) + return Declaration_Reference + is + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Declaration_Record, Declaration_Reference); + + Key : aliased constant String := Key_From_Ref (File_Ref, Line, Column); + + New_Decl : Declaration_Reference := + Entities_HTable.Get (Key'Unchecked_Access); + + Is_Parameter : Boolean := False; + + begin + -- Insert the Declaration in the table. There might already be a + -- declaration in the table if the entity is a parameter, so we + -- need to check that first. + + if New_Decl /= null and then New_Decl.Symbol_Length = 0 then + Is_Parameter := New_Decl.Is_Parameter; + Entities_HTable.Remove (Key'Unrestricted_Access); + Entities_Count := Entities_Count - 1; + Free (New_Decl.Key); + Unchecked_Free (New_Decl); + New_Decl := null; + end if; + + -- The declaration might also already be there for parent types. In + -- this case, we should keep the entry, since some other entries are + -- pointing to it. + + if New_Decl = null + and then not Remove_Only + then + New_Decl := + new Declaration_Record' + (Symbol_Length => Symbol'Length, + Symbol => Symbol, + Key => new String'(Key), + Decl => new Reference_Record' + (File => File_Ref, + Line => Line, + Column => Column, + Source_Line => null, + Next => null), + Is_Parameter => Is_Parameter, + Decl_Type => Decl_Type, + Body_Ref => null, + Ref_Ref => null, + Modif_Ref => null, + Match => Symbol_Match + and then + (Default_Match + or else Match (File_Ref, Line, Column)), + Par_Symbol => null, + Next => null); + + Entities_HTable.Set (New_Decl); + Entities_Count := Entities_Count + 1; + + if New_Decl.Match then + Longest_File_Name_In_Table := + Natural'Max (File_Ref.File'Length, Longest_File_Name_In_Table); + end if; + + elsif New_Decl /= null + and then not New_Decl.Match + then + New_Decl.Match := Default_Match + or else Match (File_Ref, Line, Column); + end if; + + return New_Decl; + end Add_Declaration; + + ---------------------- + -- Add_To_Xref_File -- + ---------------------- + + function Add_To_Xref_File + (File_Name : String; + Visited : Boolean := True; + Emit_Warning : Boolean := False; + Gnatchop_File : String := ""; + Gnatchop_Offset : Integer := 0) return File_Reference + is + Base : aliased constant String := Base_Name (File_Name); + Dir : constant String := Dir_Name (File_Name); + Dir_Acc : GNAT.OS_Lib.String_Access := null; + Ref : File_Reference; + + begin + -- Do we have a directory name as well? + + if File_Name /= Base then + Dir_Acc := new String'(Dir); + end if; + + Ref := File_HTable.Get (Base'Unchecked_Access); + if Ref = null then + Ref := new File_Record' + (File => new String'(Base), + Dir => Dir_Acc, + Lines => null, + Visited => Visited, + Emit_Warning => Emit_Warning, + Gnatchop_File => new String'(Gnatchop_File), + Gnatchop_Offset => Gnatchop_Offset, + Next => null); + File_HTable.Set (Ref); + + if not Visited then + + -- Keep a separate list for faster access + + Set_Unvisited (Ref); + end if; + end if; + return Ref; + end Add_To_Xref_File; + + -------------- + -- Add_Line -- + -------------- + + procedure Add_Line + (File : File_Reference; + Line : Natural; + Column : Natural) + is + begin + File.Lines := new Ref_In_File'(Line => Line, + Column => Column, + Next => File.Lines); + end Add_Line; + + ---------------- + -- Add_Parent -- + ---------------- + + procedure Add_Parent + (Declaration : in out Declaration_Reference; + Symbol : String; + Line : Natural; + Column : Natural; + File_Ref : File_Reference) + is + begin + Declaration.Par_Symbol := + Add_Declaration + (File_Ref, Symbol, Line, Column, + Decl_Type => ' ', + Symbol_Match => False); + end Add_Parent; + + ------------------- + -- Add_Reference -- + ------------------- + + procedure Add_Reference + (Declaration : Declaration_Reference; + File_Ref : File_Reference; + Line : Natural; + Column : Natural; + Ref_Type : Character; + Labels_As_Ref : Boolean) + is + New_Ref : Reference; + + begin + case Ref_Type is + when 'b' | 'c' | 'H' | 'm' | 'o' | 'r' | 'R' | + 's' | 'i' | ' ' | 'x' => + null; + + when 'l' | 'w' => + if not Labels_As_Ref then + return; + end if; + + when '=' | '<' | '>' | '^' => + + -- Create a dummy declaration in the table to report it as a + -- parameter. Note that the current declaration for the subprogram + -- comes before the declaration of the parameter. + + declare + Key : constant String := + Key_From_Ref (File_Ref, Line, Column); + New_Decl : Declaration_Reference; + + begin + New_Decl := new Declaration_Record' + (Symbol_Length => 0, + Symbol => "", + Key => new String'(Key), + Decl => new Reference_Record' + (File => File_Ref, + Line => Line, + Column => Column, + Source_Line => null, + Next => null), + Is_Parameter => True, + Decl_Type => ' ', + Body_Ref => null, + Ref_Ref => null, + Modif_Ref => null, + Match => False, + Par_Symbol => null, + Next => null); + Entities_HTable.Set (New_Decl); + Entities_Count := Entities_Count + 1; + end; + + when 'e' | 'z' | 't' | 'p' | 'P' | 'k' | 'd' => + return; + + when others => + Ada.Text_IO.Put_Line ("Unknown reference type: " & Ref_Type); + return; + end case; + + New_Ref := new Reference_Record' + (File => File_Ref, + Line => Line, + Column => Column, + Source_Line => null, + Next => null); + + -- We can insert the reference into the list directly, since all the + -- references will appear only once in the ALI file corresponding to the + -- file where they are referenced. This saves a lot of time compared to + -- checking the list to check if it exists. + + case Ref_Type is + when 'b' | 'c' => + New_Ref.Next := Declaration.Body_Ref; + Declaration.Body_Ref := New_Ref; + + when 'r' | 'R' | 's' | 'H' | 'i' | 'l' | 'o' | ' ' | 'x' | 'w' => + New_Ref.Next := Declaration.Ref_Ref; + Declaration.Ref_Ref := New_Ref; + + when 'm' => + New_Ref.Next := Declaration.Modif_Ref; + Declaration.Modif_Ref := New_Ref; + + when others => + null; + end case; + + if not Declaration.Match then + Declaration.Match := Match (File_Ref, Line, Column); + end if; + + if Declaration.Match then + Longest_File_Name_In_Table := + Natural'Max (File_Ref.File'Length, Longest_File_Name_In_Table); + end if; + end Add_Reference; + + ------------------- + -- ALI_File_Name -- + ------------------- + + function ALI_File_Name (Ada_File_Name : String) return String is + + -- ??? Should ideally be based on the naming scheme defined in + -- project files. + + Index : constant Natural := + Ada.Strings.Fixed.Index + (Ada_File_Name, ".", Going => Ada.Strings.Backward); + + begin + if Index /= 0 then + return Ada_File_Name (Ada_File_Name'First .. Index) + & Osint.ALI_Suffix.all; + else + return Ada_File_Name & "." & Osint.ALI_Suffix.all; + end if; + end ALI_File_Name; + + ------------------ + -- Is_Less_Than -- + ------------------ + + function Is_Less_Than (Ref1, Ref2 : Reference) return Boolean is + begin + if Ref1 = null then + return False; + elsif Ref2 = null then + return True; + end if; + + if Ref1.File.File.all < Ref2.File.File.all then + return True; + + elsif Ref1.File.File.all = Ref2.File.File.all then + return (Ref1.Line < Ref2.Line + or else (Ref1.Line = Ref2.Line + and then Ref1.Column < Ref2.Column)); + end if; + + return False; + end Is_Less_Than; + + ------------------ + -- Is_Less_Than -- + ------------------ + + function Is_Less_Than (Decl1, Decl2 : Declaration_Reference) return Boolean + is + -- We cannot store the data case-insensitive in the table, + -- since we wouldn't be able to find the right casing for the + -- display later on. + + S1 : constant String := To_Lower (Decl1.Symbol); + S2 : constant String := To_Lower (Decl2.Symbol); + + begin + if S1 < S2 then + return True; + elsif S1 > S2 then + return False; + end if; + + return Decl1.Key.all < Decl2.Key.all; + end Is_Less_Than; + + ------------------------- + -- Create_Project_File -- + ------------------------- + + procedure Create_Project_File (Name : String) is + Obj_Dir : Unbounded_String := Null_Unbounded_String; + Src_Dir : Unbounded_String := Null_Unbounded_String; + Build_Dir : GNAT.OS_Lib.String_Access := new String'(""); + + F : File_Descriptor; + Len : Positive; + File_Name : aliased String := Name & ASCII.NUL; + + begin + -- Read the size of the file + + F := Open_Read (File_Name'Address, Text); + + -- Project file not found + + if F /= Invalid_FD then + Len := Positive (File_Length (F)); + + declare + Buffer : String (1 .. Len); + Index : Positive := Buffer'First; + Last : Positive; + + begin + Len := Read (F, Buffer'Address, Len); + Close (F); + + -- First, look for Build_Dir, since all the source and object + -- path are relative to it. + + while Index <= Buffer'Last loop + + -- Find the end of line + + Last := Index; + while Last <= Buffer'Last + and then Buffer (Last) /= ASCII.LF + and then Buffer (Last) /= ASCII.CR + loop + Last := Last + 1; + end loop; + + if Index <= Buffer'Last - 9 + and then Buffer (Index .. Index + 9) = "build_dir=" + then + Index := Index + 10; + while Index <= Last + and then (Buffer (Index) = ' ' + or else Buffer (Index) = ASCII.HT) + loop + Index := Index + 1; + end loop; + + Free (Build_Dir); + Build_Dir := new String'(Buffer (Index .. Last - 1)); + end if; + + Index := Last + 1; + + -- In case we had a ASCII.CR/ASCII.LF end of line, skip the + -- remaining symbol + + if Index <= Buffer'Last + and then Buffer (Index) = ASCII.LF + then + Index := Index + 1; + end if; + end loop; + + -- Now parse the source and object paths + + Index := Buffer'First; + while Index <= Buffer'Last loop + + -- Find the end of line + + Last := Index; + while Last <= Buffer'Last + and then Buffer (Last) /= ASCII.LF + and then Buffer (Last) /= ASCII.CR + loop + Last := Last + 1; + end loop; + + if Index <= Buffer'Last - 7 + and then Buffer (Index .. Index + 7) = "src_dir=" + then + Append (Src_Dir, Normalize_Pathname + (Name => Ada.Strings.Fixed.Trim + (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both), + Directory => Build_Dir.all) & Path_Separator); + + elsif Index <= Buffer'Last - 7 + and then Buffer (Index .. Index + 7) = "obj_dir=" + then + Append (Obj_Dir, Normalize_Pathname + (Name => Ada.Strings.Fixed.Trim + (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both), + Directory => Build_Dir.all) & Path_Separator); + end if; + + -- In case we had a ASCII.CR/ASCII.LF end of line, skip the + -- remaining symbol + Index := Last + 1; + + if Index <= Buffer'Last + and then Buffer (Index) = ASCII.LF + then + Index := Index + 1; + end if; + end loop; + end; + end if; + + Osint.Add_Default_Search_Dirs; + + declare + Src : constant String := Parse_Gnatls_Src; + Obj : constant String := Parse_Gnatls_Obj; + + begin + Directories := new Project_File' + (Src_Dir_Length => Length (Src_Dir) + Src'Length, + Obj_Dir_Length => Length (Obj_Dir) + Obj'Length, + Src_Dir => To_String (Src_Dir) & Src, + Obj_Dir => To_String (Obj_Dir) & Obj, + Src_Dir_Index => 1, + Obj_Dir_Index => 1, + Last_Obj_Dir_Start => 0); + end; + + Free (Build_Dir); + end Create_Project_File; + + --------------------- + -- Current_Obj_Dir -- + --------------------- + + function Current_Obj_Dir return String is + begin + return Directories.Obj_Dir + (Directories.Last_Obj_Dir_Start .. Directories.Obj_Dir_Index - 2); + end Current_Obj_Dir; + + ---------------- + -- Get_Column -- + ---------------- + + function Get_Column (Decl : Declaration_Reference) return String is + begin + return Ada.Strings.Fixed.Trim (Natural'Image (Decl.Decl.Column), + Ada.Strings.Left); + end Get_Column; + + function Get_Column (Ref : Reference) return String is + begin + return Ada.Strings.Fixed.Trim (Natural'Image (Ref.Column), + Ada.Strings.Left); + end Get_Column; + + --------------------- + -- Get_Declaration -- + --------------------- + + function Get_Declaration + (File_Ref : File_Reference; + Line : Natural; + Column : Natural) + return Declaration_Reference + is + Key : aliased constant String := Key_From_Ref (File_Ref, Line, Column); + + begin + return Entities_HTable.Get (Key'Unchecked_Access); + end Get_Declaration; + + ---------------------- + -- Get_Emit_Warning -- + ---------------------- + + function Get_Emit_Warning (File : File_Reference) return Boolean is + begin + return File.Emit_Warning; + end Get_Emit_Warning; + + -------------- + -- Get_File -- + -------------- + + function Get_File + (Decl : Declaration_Reference; + With_Dir : Boolean := False) return String + is + begin + return Get_File (Decl.Decl.File, With_Dir); + end Get_File; + + function Get_File + (Ref : Reference; + With_Dir : Boolean := False) return String + is + begin + return Get_File (Ref.File, With_Dir); + end Get_File; + + function Get_File + (File : File_Reference; + With_Dir : Boolean := False; + Strip : Natural := 0) return String + is + Tmp : GNAT.OS_Lib.String_Access; + + function Internal_Strip (Full_Name : String) return String; + -- Internal function to process the Strip parameter + + -------------------- + -- Internal_Strip -- + -------------------- + + function Internal_Strip (Full_Name : String) return String is + Unit_End : Natural; + Extension_Start : Natural; + S : Natural; + + begin + if Strip = 0 then + return Full_Name; + end if; + + -- Isolate the file extension + + Extension_Start := Full_Name'Last; + while Extension_Start >= Full_Name'First + and then Full_Name (Extension_Start) /= '.' + loop + Extension_Start := Extension_Start - 1; + end loop; + + -- Strip the right number of subunit_names + + S := Strip; + Unit_End := Extension_Start - 1; + while Unit_End >= Full_Name'First + and then S > 0 + loop + if Full_Name (Unit_End) = '-' then + S := S - 1; + end if; + + Unit_End := Unit_End - 1; + end loop; + + if Unit_End < Full_Name'First then + return ""; + else + return Full_Name (Full_Name'First .. Unit_End) + & Full_Name (Extension_Start .. Full_Name'Last); + end if; + end Internal_Strip; + + -- Start of processing for Get_File; + + begin + -- If we do not want the full path name + + if not With_Dir then + return Internal_Strip (File.File.all); + end if; + + if File.Dir = null then + if Ada.Strings.Fixed.Tail (File.File.all, 3) = + Osint.ALI_Suffix.all + then + Tmp := Locate_Regular_File + (Internal_Strip (File.File.all), Directories.Obj_Dir); + else + Tmp := Locate_Regular_File + (File.File.all, Directories.Src_Dir); + end if; + + if Tmp = null then + File.Dir := new String'(""); + else + File.Dir := new String'(Dir_Name (Tmp.all)); + Free (Tmp); + end if; + end if; + + return Internal_Strip (File.Dir.all & File.File.all); + end Get_File; + + ------------------ + -- Get_File_Ref -- + ------------------ + + function Get_File_Ref (Ref : Reference) return File_Reference is + begin + return Ref.File; + end Get_File_Ref; + + ----------------------- + -- Get_Gnatchop_File -- + ----------------------- + + function Get_Gnatchop_File + (File : File_Reference; + With_Dir : Boolean := False) + return String + is + begin + if File.Gnatchop_File.all = "" then + return Get_File (File, With_Dir); + else + return File.Gnatchop_File.all; + end if; + end Get_Gnatchop_File; + + function Get_Gnatchop_File + (Ref : Reference; + With_Dir : Boolean := False) + return String + is + begin + return Get_Gnatchop_File (Ref.File, With_Dir); + end Get_Gnatchop_File; + + function Get_Gnatchop_File + (Decl : Declaration_Reference; + With_Dir : Boolean := False) + return String + is + begin + return Get_Gnatchop_File (Decl.Decl.File, With_Dir); + end Get_Gnatchop_File; + + -------------- + -- Get_Line -- + -------------- + + function Get_Line (Decl : Declaration_Reference) return String is + begin + return Ada.Strings.Fixed.Trim (Natural'Image (Decl.Decl.Line), + Ada.Strings.Left); + end Get_Line; + + function Get_Line (Ref : Reference) return String is + begin + return Ada.Strings.Fixed.Trim (Natural'Image (Ref.Line), + Ada.Strings.Left); + end Get_Line; + + ---------------- + -- Get_Parent -- + ---------------- + + function Get_Parent + (Decl : Declaration_Reference) + return Declaration_Reference + is + begin + return Decl.Par_Symbol; + end Get_Parent; + + --------------------- + -- Get_Source_Line -- + --------------------- + + function Get_Source_Line (Ref : Reference) return String is + begin + if Ref.Source_Line /= null then + return Ref.Source_Line.all; + else + return ""; + end if; + end Get_Source_Line; + + function Get_Source_Line (Decl : Declaration_Reference) return String is + begin + if Decl.Decl.Source_Line /= null then + return Decl.Decl.Source_Line.all; + else + return ""; + end if; + end Get_Source_Line; + + ---------------- + -- Get_Symbol -- + ---------------- + + function Get_Symbol (Decl : Declaration_Reference) return String is + begin + return Decl.Symbol; + end Get_Symbol; + + -------------- + -- Get_Type -- + -------------- + + function Get_Type (Decl : Declaration_Reference) return Character is + begin + return Decl.Decl_Type; + end Get_Type; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Arr : in out Reference_Array) is + Tmp : Reference; + + function Lt (Op1, Op2 : Natural) return Boolean; + procedure Move (From, To : Natural); + -- See GNAT.Heap_Sort_G + + -------- + -- Lt -- + -------- + + function Lt (Op1, Op2 : Natural) return Boolean is + begin + if Op1 = 0 then + return Is_Less_Than (Tmp, Arr (Op2)); + elsif Op2 = 0 then + return Is_Less_Than (Arr (Op1), Tmp); + else + return Is_Less_Than (Arr (Op1), Arr (Op2)); + end if; + end Lt; + + ---------- + -- Move -- + ---------- + + procedure Move (From, To : Natural) is + begin + if To = 0 then + Tmp := Arr (From); + elsif From = 0 then + Arr (To) := Tmp; + else + Arr (To) := Arr (From); + end if; + end Move; + + package Ref_Sort is new GNAT.Heap_Sort_G (Move, Lt); + + -- Start of processing for Sort + + begin + Ref_Sort.Sort (Arr'Last); + end Sort; + + ----------------------- + -- Grep_Source_Files -- + ----------------------- + + procedure Grep_Source_Files is + Length : Natural := 0; + Decl : Declaration_Reference := Entities_HTable.Get_First; + Arr : Reference_Array_Access; + Index : Natural; + End_Index : Natural; + Current_File : File_Reference; + Current_Line : Cst_String_Access; + Buffer : GNAT.OS_Lib.String_Access; + Ref : Reference; + Line : Natural; + + begin + -- Create a temporary array, where all references will be + -- sorted by files. This way, we only have to read the source + -- files once. + + while Decl /= null loop + + -- Add 1 for the declaration itself + + Length := Length + References_Count (Decl, True, True, True) + 1; + Decl := Entities_HTable.Get_Next; + end loop; + + Arr := new Reference_Array (1 .. Length); + Index := Arr'First; + + Decl := Entities_HTable.Get_First; + while Decl /= null loop + Store_References (Decl, True, True, True, True, Arr.all, Index); + Decl := Entities_HTable.Get_Next; + end loop; + + Sort (Arr.all); + + -- Now traverse the whole array and find the appropriate source + -- lines. + + for R in Arr'Range loop + Ref := Arr (R); + + if Ref.File /= Current_File then + Free (Buffer); + begin + Read_File (Get_File (Ref.File, With_Dir => True), Buffer); + End_Index := Buffer'First - 1; + Line := 0; + exception + when Ada.Text_IO.Name_Error | Ada.Text_IO.End_Error => + Line := Natural'Last; + end; + Current_File := Ref.File; + end if; + + if Ref.Line > Line then + + -- Do not free Current_Line, it is referenced by the last + -- Ref we processed. + + loop + Index := End_Index + 1; + + loop + End_Index := End_Index + 1; + exit when End_Index > Buffer'Last + or else Buffer (End_Index) = ASCII.LF; + end loop; + + -- Skip spaces at beginning of line + + while Index < End_Index and then + (Buffer (Index) = ' ' or else Buffer (Index) = ASCII.HT) + loop + Index := Index + 1; + end loop; + + Line := Line + 1; + exit when Ref.Line = Line; + end loop; + + Current_Line := new String'(Buffer (Index .. End_Index - 1)); + end if; + + Ref.Source_Line := Current_Line; + end loop; + + Free (Buffer); + Free (Arr); + end Grep_Source_Files; + + --------------- + -- Read_File -- + --------------- + + procedure Read_File + (File_Name : String; + Contents : out GNAT.OS_Lib.String_Access) + is + Name_0 : constant String := File_Name & ASCII.NUL; + FD : constant File_Descriptor := Open_Read (Name_0'Address, Binary); + Length : Natural; + + begin + if FD = Invalid_FD then + raise Ada.Text_IO.Name_Error; + end if; + + -- Include room for EOF char + + Length := Natural (File_Length (FD)); + + declare + Buffer : String (1 .. Length + 1); + This_Read : Integer; + Read_Ptr : Natural := 1; + + begin + loop + This_Read := Read (FD, + A => Buffer (Read_Ptr)'Address, + N => Length + 1 - Read_Ptr); + Read_Ptr := Read_Ptr + Integer'Max (This_Read, 0); + exit when This_Read <= 0; + end loop; + + Buffer (Read_Ptr) := EOF; + Contents := new String'(Buffer (1 .. Read_Ptr)); + + -- Things are not simple on VMS due to the plethora of file types + -- and organizations. It seems clear that there shouldn't be more + -- bytes read than are contained in the file though. + + if (Hostparm.OpenVMS and then Read_Ptr > Length + 1) + or else (not Hostparm.OpenVMS and then Read_Ptr /= Length + 1) + then + raise Ada.Text_IO.End_Error; + end if; + + Close (FD); + end; + end Read_File; + + ----------------------- + -- Longest_File_Name -- + ----------------------- + + function Longest_File_Name return Natural is + begin + return Longest_File_Name_In_Table; + end Longest_File_Name; + + ----------- + -- Match -- + ----------- + + function Match + (File : File_Reference; + Line : Natural; + Column : Natural) + return Boolean + is + Ref : Ref_In_File_Ptr := File.Lines; + + begin + while Ref /= null loop + if (Ref.Line = 0 or else Ref.Line = Line) + and then (Ref.Column = 0 or else Ref.Column = Column) + then + return True; + end if; + + Ref := Ref.Next; + end loop; + + return False; + end Match; + + ----------- + -- Match -- + ----------- + + function Match (Decl : Declaration_Reference) return Boolean is + begin + return Decl.Match; + end Match; + + ---------- + -- Next -- + ---------- + + function Next (E : File_Reference) return File_Reference is + begin + return E.Next; + end Next; + + function Next (E : Declaration_Reference) return Declaration_Reference is + begin + return E.Next; + end Next; + + ------------------ + -- Next_Obj_Dir -- + ------------------ + + function Next_Obj_Dir return String is + First : constant Integer := Directories.Obj_Dir_Index; + Last : Integer; + + begin + Last := Directories.Obj_Dir_Index; + + if Last > Directories.Obj_Dir_Length then + return String'(1 .. 0 => ' '); + end if; + + while Directories.Obj_Dir (Last) /= Path_Separator loop + Last := Last + 1; + end loop; + + Directories.Obj_Dir_Index := Last + 1; + Directories.Last_Obj_Dir_Start := First; + return Directories.Obj_Dir (First .. Last - 1); + end Next_Obj_Dir; + + ------------------------- + -- Next_Unvisited_File -- + ------------------------- + + function Next_Unvisited_File return File_Reference is + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Unvisited_Files_Record, Unvisited_Files_Access); + + Ref : File_Reference; + Tmp : Unvisited_Files_Access; + + begin + if Unvisited_Files = null then + return Empty_File; + else + Tmp := Unvisited_Files; + Ref := Unvisited_Files.File; + Unvisited_Files := Unvisited_Files.Next; + Unchecked_Free (Tmp); + return Ref; + end if; + end Next_Unvisited_File; + + ---------------------- + -- Parse_Gnatls_Src -- + ---------------------- + + function Parse_Gnatls_Src return String is + Length : Natural; + + begin + Length := 0; + for J in 1 .. Osint.Nb_Dir_In_Src_Search_Path loop + if Osint.Dir_In_Src_Search_Path (J)'Length = 0 then + Length := Length + 2; + else + Length := Length + Osint.Dir_In_Src_Search_Path (J)'Length + 1; + end if; + end loop; + + declare + Result : String (1 .. Length); + L : Natural; + + begin + L := Result'First; + for J in 1 .. Osint.Nb_Dir_In_Src_Search_Path loop + if Osint.Dir_In_Src_Search_Path (J)'Length = 0 then + Result (L .. L + 1) := "." & Path_Separator; + L := L + 2; + + else + Result (L .. L + Osint.Dir_In_Src_Search_Path (J)'Length - 1) := + Osint.Dir_In_Src_Search_Path (J).all; + L := L + Osint.Dir_In_Src_Search_Path (J)'Length; + Result (L) := Path_Separator; + L := L + 1; + end if; + end loop; + + return Result; + end; + end Parse_Gnatls_Src; + + ---------------------- + -- Parse_Gnatls_Obj -- + ---------------------- + + function Parse_Gnatls_Obj return String is + Length : Natural; + + begin + Length := 0; + for J in 1 .. Osint.Nb_Dir_In_Obj_Search_Path loop + if Osint.Dir_In_Obj_Search_Path (J)'Length = 0 then + Length := Length + 2; + else + Length := Length + Osint.Dir_In_Obj_Search_Path (J)'Length + 1; + end if; + end loop; + + declare + Result : String (1 .. Length); + L : Natural; + + begin + L := Result'First; + for J in 1 .. Osint.Nb_Dir_In_Obj_Search_Path loop + if Osint.Dir_In_Obj_Search_Path (J)'Length = 0 then + Result (L .. L + 1) := "." & Path_Separator; + L := L + 2; + else + Result (L .. L + Osint.Dir_In_Obj_Search_Path (J)'Length - 1) := + Osint.Dir_In_Obj_Search_Path (J).all; + L := L + Osint.Dir_In_Obj_Search_Path (J)'Length; + Result (L) := Path_Separator; + L := L + 1; + end if; + end loop; + + return Result; + end; + end Parse_Gnatls_Obj; + + ------------------- + -- Reset_Obj_Dir -- + ------------------- + + procedure Reset_Obj_Dir is + begin + Directories.Obj_Dir_Index := 1; + end Reset_Obj_Dir; + + ----------------------- + -- Set_Default_Match -- + ----------------------- + + procedure Set_Default_Match (Value : Boolean) is + begin + Default_Match := Value; + end Set_Default_Match; + + ---------- + -- Free -- + ---------- + + procedure Free (Str : in out Cst_String_Access) is + function Convert is new Ada.Unchecked_Conversion + (Cst_String_Access, GNAT.OS_Lib.String_Access); + + S : GNAT.OS_Lib.String_Access := Convert (Str); + + begin + Free (S); + Str := null; + end Free; + + --------------------- + -- Reset_Directory -- + --------------------- + + procedure Reset_Directory (File : File_Reference) is + begin + Free (File.Dir); + end Reset_Directory; + + ------------------- + -- Set_Unvisited -- + ------------------- + + procedure Set_Unvisited (File_Ref : File_Reference) is + F : constant String := Get_File (File_Ref, With_Dir => False); + + begin + File_Ref.Visited := False; + + -- ??? Do not add a source file to the list. This is true at + -- least for gnatxref, and probably for gnatfind as well + + if F'Length > 4 + and then F (F'Last - 3 .. F'Last) = "." & Osint.ALI_Suffix.all + then + Unvisited_Files := new Unvisited_Files_Record' + (File => File_Ref, + Next => Unvisited_Files); + end if; + end Set_Unvisited; + + ---------------------- + -- Get_Declarations -- + ---------------------- + + function Get_Declarations + (Sorted : Boolean := True) + return Declaration_Array_Access + is + Arr : constant Declaration_Array_Access := + new Declaration_Array (1 .. Entities_Count); + Decl : Declaration_Reference := Entities_HTable.Get_First; + Index : Natural := Arr'First; + Tmp : Declaration_Reference; + + procedure Move (From : Natural; To : Natural); + function Lt (Op1, Op2 : Natural) return Boolean; + -- See GNAT.Heap_Sort_G + + -------- + -- Lt -- + -------- + + function Lt (Op1, Op2 : Natural) return Boolean is + begin + if Op1 = 0 then + return Is_Less_Than (Tmp, Arr (Op2)); + elsif Op2 = 0 then + return Is_Less_Than (Arr (Op1), Tmp); + else + return Is_Less_Than (Arr (Op1), Arr (Op2)); + end if; + end Lt; + + ---------- + -- Move -- + ---------- + + procedure Move (From : Natural; To : Natural) is + begin + if To = 0 then + Tmp := Arr (From); + elsif From = 0 then + Arr (To) := Tmp; + else + Arr (To) := Arr (From); + end if; + end Move; + + package Decl_Sort is new GNAT.Heap_Sort_G (Move, Lt); + + -- Start of processing for Get_Declarations + + begin + while Decl /= null loop + Arr (Index) := Decl; + Index := Index + 1; + Decl := Entities_HTable.Get_Next; + end loop; + + if Sorted and then Arr'Length /= 0 then + Decl_Sort.Sort (Entities_Count); + end if; + + return Arr; + end Get_Declarations; + + ---------------------- + -- References_Count -- + ---------------------- + + function References_Count + (Decl : Declaration_Reference; + Get_Reads : Boolean := False; + Get_Writes : Boolean := False; + Get_Bodies : Boolean := False) + return Natural + is + function List_Length (E : Reference) return Natural; + -- Return the number of references in E + + ----------------- + -- List_Length -- + ----------------- + + function List_Length (E : Reference) return Natural is + L : Natural := 0; + E1 : Reference := E; + + begin + while E1 /= null loop + L := L + 1; + E1 := E1.Next; + end loop; + + return L; + end List_Length; + + Length : Natural := 0; + + -- Start of processing for References_Count + + begin + if Get_Reads then + Length := List_Length (Decl.Ref_Ref); + end if; + + if Get_Writes then + Length := Length + List_Length (Decl.Modif_Ref); + end if; + + if Get_Bodies then + Length := Length + List_Length (Decl.Body_Ref); + end if; + + return Length; + end References_Count; + + ---------------------- + -- Store_References -- + ---------------------- + + procedure Store_References + (Decl : Declaration_Reference; + Get_Writes : Boolean := False; + Get_Reads : Boolean := False; + Get_Bodies : Boolean := False; + Get_Declaration : Boolean := False; + Arr : in out Reference_Array; + Index : in out Natural) + is + procedure Add (List : Reference); + -- Add all the references in List to Arr + + --------- + -- Add -- + --------- + + procedure Add (List : Reference) is + E : Reference := List; + begin + while E /= null loop + Arr (Index) := E; + Index := Index + 1; + E := E.Next; + end loop; + end Add; + + -- Start of processing for Store_References + + begin + if Get_Declaration then + Add (Decl.Decl); + end if; + + if Get_Reads then + Add (Decl.Ref_Ref); + end if; + + if Get_Writes then + Add (Decl.Modif_Ref); + end if; + + if Get_Bodies then + Add (Decl.Body_Ref); + end if; + end Store_References; + + -------------------- + -- Get_References -- + -------------------- + + function Get_References + (Decl : Declaration_Reference; + Get_Reads : Boolean := False; + Get_Writes : Boolean := False; + Get_Bodies : Boolean := False) + return Reference_Array_Access + is + Length : constant Natural := + References_Count (Decl, Get_Reads, Get_Writes, Get_Bodies); + + Arr : constant Reference_Array_Access := + new Reference_Array (1 .. Length); + + Index : Natural := Arr'First; + + begin + Store_References + (Decl => Decl, + Get_Writes => Get_Writes, + Get_Reads => Get_Reads, + Get_Bodies => Get_Bodies, + Get_Declaration => False, + Arr => Arr.all, + Index => Index); + + if Arr'Length /= 0 then + Sort (Arr.all); + end if; + + return Arr; + end Get_References; + + ---------- + -- Free -- + ---------- + + procedure Free (Arr : in out Reference_Array_Access) is + procedure Internal is new Ada.Unchecked_Deallocation + (Reference_Array, Reference_Array_Access); + begin + Internal (Arr); + end Free; + + ------------------ + -- Is_Parameter -- + ------------------ + + function Is_Parameter (Decl : Declaration_Reference) return Boolean is + begin + return Decl.Is_Parameter; + end Is_Parameter; + +end Xr_Tabls; diff --git a/gcc/ada/xr_tabls.ads b/gcc/ada/xr_tabls.ads new file mode 100644 index 000000000..d5e9c5ee6 --- /dev/null +++ b/gcc/ada/xr_tabls.ads @@ -0,0 +1,389 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- X R _ T A B L S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- We need comment here saying what this package is??? + +with GNAT.OS_Lib; + +package Xr_Tabls is + + ------------------- + -- Project files -- + ------------------- + + function ALI_File_Name (Ada_File_Name : String) return String; + -- Returns the ali file name corresponding to Ada_File_Name + + procedure Create_Project_File (Name : String); + -- Open and parse a new project file. If the file Name could not be + -- opened or is not a valid project file, then a project file associated + -- with the standard default directories is returned + + function Next_Obj_Dir return String; + -- Returns the next directory to visit to find related ali files + -- If there are no more such directories, returns a null string. + + function Current_Obj_Dir return String; + -- Returns the obj_dir which was returned by the last Next_Obj_Dir call + + procedure Reset_Obj_Dir; + -- Reset the iterator for Obj_Dir + + ------------ + -- Tables -- + ------------ + + type Declaration_Reference is private; + Empty_Declaration : constant Declaration_Reference; + + type Declaration_Array is array (Natural range <>) of Declaration_Reference; + type Declaration_Array_Access is access Declaration_Array; + + type File_Reference is private; + Empty_File : constant File_Reference; + + type Reference is private; + Empty_Reference : constant Reference; + + type Reference_Array is array (Natural range <>) of Reference; + type Reference_Array_Access is access Reference_Array; + + procedure Free (Arr : in out Reference_Array_Access); + + function Add_Declaration + (File_Ref : File_Reference; + Symbol : String; + Line : Natural; + Column : Natural; + Decl_Type : Character; + Remove_Only : Boolean := False; + Symbol_Match : Boolean := True) + return Declaration_Reference; + -- Add a new declaration in the table and return the index to it. Decl_Type + -- is the type of the entity Any previous instance of this entity in the + -- htable is removed. If Remove_Only is True, then any previous instance is + -- removed, but the new entity is never inserted. Symbol_Match should be + -- set to False if the name of the symbol doesn't match the pattern from + -- the command line. In that case, the entity will not be output by + -- gnatfind. If Symbol_Match is True, the entity will only be output if the + -- file name itself matches. + + procedure Add_Parent + (Declaration : in out Declaration_Reference; + Symbol : String; + Line : Natural; + Column : Natural; + File_Ref : File_Reference); + -- The parent declaration (Symbol in file File_Ref at position Line and + -- Column) information is added to Declaration. + + function Add_To_Xref_File + (File_Name : String; + Visited : Boolean := True; + Emit_Warning : Boolean := False; + Gnatchop_File : String := ""; + Gnatchop_Offset : Integer := 0) + return File_Reference; + -- Add a new reference to a file in the table. Ref is used to return the + -- index in the table where this file is stored. Visited is the value which + -- will be used in the table (if True, the file will not be returned by + -- Next_Unvisited_File). If Emit_Warning is True and the ali file does + -- not exist or does not have cross-referencing information, then a + -- warning will be emitted. Gnatchop_File is the name of the file that + -- File_Name was extracted from through a call to "gnatchop -r" (using + -- pragma Source_Reference). Gnatchop_Offset should be the index of the + -- first line of File_Name within the Gnatchop_File. + + procedure Add_Line + (File : File_Reference; + Line : Natural; + Column : Natural); + -- Add a new reference in a file, which the user has provided on the + -- command line. This is used for an optimized matching algorithm. + + procedure Add_Reference + (Declaration : Declaration_Reference; + File_Ref : File_Reference; + Line : Natural; + Column : Natural; + Ref_Type : Character; + Labels_As_Ref : Boolean); + -- Add a new reference (Ref_Type = 'r'), body (Ref_Type = 'b') or + -- modification (Ref_Type = 'm') to an entity. If Labels_As_Ref is True, + -- then the references to the entity after the end statements ("end Foo") + -- are counted as actual references. This means that the entity will never + -- be reported as unreferenced (for instance in the case of gnatxref -u). + + function Get_Declarations + (Sorted : Boolean := True) + return Declaration_Array_Access; + -- Return a sorted list of all the declarations in the application. + -- Freeing this array is the responsibility of the caller, however it + -- shouldn't free the actual contents of the array, which are pointers + -- to internal data + + function References_Count + (Decl : Declaration_Reference; + Get_Reads : Boolean := False; + Get_Writes : Boolean := False; + Get_Bodies : Boolean := False) + return Natural; + -- Return the number of references in Decl for the categories specified + -- by the Get_* parameters (read-only accesses, write accesses and bodies) + + function Get_References + (Decl : Declaration_Reference; + Get_Reads : Boolean := False; + Get_Writes : Boolean := False; + Get_Bodies : Boolean := False) + return Reference_Array_Access; + -- Return a sorted list of all references to the entity in decl. The + -- parameters Get_* are used to specify what kind of references should be + -- merged and returned (read-only accesses, write accesses and bodies). + + function Get_Column (Decl : Declaration_Reference) return String; + function Get_Column (Ref : Reference) return String; + + function Get_Declaration + (File_Ref : File_Reference; + Line : Natural; + Column : Natural) + return Declaration_Reference; + -- Returns reference to the declaration found in file File_Ref at the + -- given Line and Column + + function Get_Parent + (Decl : Declaration_Reference) + return Declaration_Reference; + -- Returns reference to Decl's parent declaration + + function Get_Emit_Warning (File : File_Reference) return Boolean; + -- Returns the Emit_Warning field of the structure + + function Get_Gnatchop_File + (File : File_Reference; + With_Dir : Boolean := False) + return String; + function Get_Gnatchop_File + (Ref : Reference; + With_Dir : Boolean := False) + return String; + function Get_Gnatchop_File + (Decl : Declaration_Reference; + With_Dir : Boolean := False) + return String; + -- Return the name of the file that File was extracted from through a + -- call to "gnatchop -r". The file name for File is returned if File + -- was not extracted from such a file. The directory will be given only + -- if With_Dir is True. + + function Get_File + (Decl : Declaration_Reference; + With_Dir : Boolean := False) return String; + pragma Inline (Get_File); + -- Extract column number or file name from reference + + function Get_File + (Ref : Reference; + With_Dir : Boolean := False) return String; + pragma Inline (Get_File); + + function Get_File + (File : File_Reference; + With_Dir : Boolean := False; + Strip : Natural := 0) return String; + -- Returns the file name (and its directory if With_Dir is True or the user + -- has used the -f switch on the command line. If Strip is not 0, then the + -- last Strip-th "-..." substrings are removed first. For instance, with + -- Strip=2, a file name "parent-child1-child2-child3.ali" would be returned + -- as "parent-child1.ali". This is used when looking for the ALI file to + -- use for a package, since for separates with have to use the parent's + -- ALI. The null string is returned if there is no such parent unit. + -- + -- Note that this version of Get_File is not inlined + + function Get_File_Ref (Ref : Reference) return File_Reference; + function Get_Line (Decl : Declaration_Reference) return String; + function Get_Line (Ref : Reference) return String; + function Get_Symbol (Decl : Declaration_Reference) return String; + function Get_Type (Decl : Declaration_Reference) return Character; + function Is_Parameter (Decl : Declaration_Reference) return Boolean; + -- Functions that return the contents of a declaration + + function Get_Source_Line (Ref : Reference) return String; + function Get_Source_Line (Decl : Declaration_Reference) return String; + -- Return the source line associated with the reference + + procedure Grep_Source_Files; + -- Parse all the source files which have at least one reference, and grep + -- the appropriate source lines so that we'll be able to display them. This + -- function should be called once all the .ali files have been parsed, and + -- only if the appropriate user switch + -- has been used (gnatfind -s). + -- + -- Note: To save memory, the strings for the source lines are shared. Thus + -- it is no longer possible to free the references, or we would free the + -- same chunk multiple times. It doesn't matter, though, since this is only + -- called once, prior to exiting gnatfind. + + function Longest_File_Name return Natural; + -- Returns the longest file name found + + function Match (Decl : Declaration_Reference) return Boolean; + -- Return True if the declaration matches + + function Match + (File : File_Reference; + Line : Natural; + Column : Natural) + return Boolean; + -- Returns True if File:Line:Column was given on the command line + -- by the user + + function Next_Unvisited_File return File_Reference; + -- Returns the next unvisited library file in the list If there is no more + -- unvisited file, return Empty_File. Two calls to this subprogram will + -- return different files. + + procedure Set_Default_Match (Value : Boolean); + -- Set the default value for match in declarations. + -- This is used so that if no file was provided in the + -- command line, then every file match + + procedure Reset_Directory (File : File_Reference); + -- Reset the cached directory for file. Next time Get_File is called, the + -- directory will be recomputed. + + procedure Set_Unvisited (File_Ref : File_Reference); + -- Set File_Ref as unvisited. So Next_Unvisited_File will return it + + procedure Read_File + (File_Name : String; + Contents : out GNAT.OS_Lib.String_Access); + -- Reads File_Name into the newly allocated string Contents. Types.EOF + -- character will be added to the returned Contents to simplify parsing. + -- Name_Error is raised if the file was not found. End_Error is raised if + -- the file could not be read correctly. For most systems correct reading + -- means that the number of bytes read is equal to the file size. The + -- exception is OpenVMS where correct reading means that the number of + -- bytes read is less than or equal to the file size. + +private + type Project_File (Src_Dir_Length, Obj_Dir_Length : Natural) is record + Src_Dir : String (1 .. Src_Dir_Length); + Src_Dir_Index : Integer; + + Obj_Dir : String (1 .. Obj_Dir_Length); + Obj_Dir_Index : Integer; + Last_Obj_Dir_Start : Natural; + end record; + + type Project_File_Ptr is access all Project_File; + -- This is actually a list of all the directories to be searched, + -- either for source files or for library files + + type Ref_In_File; + type Ref_In_File_Ptr is access all Ref_In_File; + + type Ref_In_File is record + Line : Natural; + Column : Natural; + Next : Ref_In_File_Ptr := null; + end record; + + type File_Record; + type File_Reference is access all File_Record; + + Empty_File : constant File_Reference := null; + type Cst_String_Access is access constant String; + + procedure Free (Str : in out Cst_String_Access); + + type File_Record is record + File : Cst_String_Access; + Dir : GNAT.OS_Lib.String_Access; + Lines : Ref_In_File_Ptr := null; + Visited : Boolean := False; + Emit_Warning : Boolean := False; + Gnatchop_File : GNAT.OS_Lib.String_Access := null; + Gnatchop_Offset : Integer := 0; + Next : File_Reference := null; + end record; + -- Holds a reference to a source file, that was referenced in at least one + -- ALI file. Gnatchop_File will contain the name of the file that File was + -- extracted From. Gnatchop_Offset contains the index of the first line of + -- File within Gnatchop_File. These two fields are used to properly support + -- gnatchop files and pragma Source_Reference. + -- + -- Lines is used for files that were given on the command line, to + -- memorize the lines and columns that the user specified. + + type Reference_Record; + type Reference is access all Reference_Record; + + Empty_Reference : constant Reference := null; + + type Reference_Record is record + File : File_Reference; + Line : Natural; + Column : Natural; + Source_Line : Cst_String_Access; + Next : Reference := null; + end record; + -- File is a reference to the Ada source file + -- Source_Line is the Line as it appears in the source file. This + -- field is only used when the switch is set on the command line of + -- gnatfind. + + type Declaration_Record; + type Declaration_Reference is access all Declaration_Record; + + Empty_Declaration : constant Declaration_Reference := null; + + type Declaration_Record (Symbol_Length : Natural) is record + Key : Cst_String_Access; + Symbol : String (1 .. Symbol_Length); + Decl : Reference; + Is_Parameter : Boolean := False; -- True if entity is subprog param + Decl_Type : Character; + Body_Ref : Reference := null; + Ref_Ref : Reference := null; + Modif_Ref : Reference := null; + Match : Boolean := False; + Par_Symbol : Declaration_Reference := null; + Next : Declaration_Reference := null; + end record; + -- The lists of referenced (Body_Ref, Ref_Ref and Modif_Ref) are + -- kept unsorted until the results needs to be printed. This saves + -- lots of time while the internal tables are created. + + pragma Inline (Get_Column); + pragma Inline (Get_Emit_Warning); + pragma Inline (Get_File_Ref); + pragma Inline (Get_Line); + pragma Inline (Get_Symbol); + pragma Inline (Get_Type); + pragma Inline (Longest_File_Name); +end Xr_Tabls; diff --git a/gcc/ada/xref_lib.adb b/gcc/ada/xref_lib.adb new file mode 100644 index 000000000..1a0d2c4b5 --- /dev/null +++ b/gcc/ada/xref_lib.adb @@ -0,0 +1,1835 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- X R E F _ L I B -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Osint; +with Output; use Output; +with Types; use Types; + +with Unchecked_Deallocation; + +with Ada.Strings.Fixed; use Ada.Strings.Fixed; +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.Command_Line; use GNAT.Command_Line; +with GNAT.IO_Aux; use GNAT.IO_Aux; + +package body Xref_Lib is + + Type_Position : constant := 50; + -- Column for label identifying type of entity + + --------------------- + -- Local Variables -- + --------------------- + + Pipe : constant Character := '|'; + -- First character on xref lines in the .ali file + + No_Xref_Information : exception; + -- Exception raised when there is no cross-referencing information in + -- the .ali files. + + procedure Parse_EOL + (Source : not null access String; + Ptr : in out Positive; + Skip_Continuation_Line : Boolean := False); + -- On return Source (Ptr) is the first character of the next line + -- or EOF. Source.all must be terminated by EOF. + -- + -- If Skip_Continuation_Line is True, this subprogram skips as many + -- lines as required when the second or more lines starts with '.' + -- (continuation lines in ALI files). + + function Current_Xref_File (File : ALI_File) return File_Reference; + -- Return the file matching the last 'X' line we found while parsing + -- the ALI file. + + function File_Name (File : ALI_File; Num : Positive) return File_Reference; + -- Returns the dependency file name number Num + + function Get_Full_Type (Decl : Declaration_Reference) return String; + -- Returns the full type corresponding to a type letter as found in + -- the .ali files. + + procedure Open + (Name : String; + File : out ALI_File; + Dependencies : Boolean := False); + -- Open a new ALI file. If Dependencies is True, the insert every library + -- file 'with'ed in the files database (used for gnatxref) + + procedure Parse_Identifier_Info + (Pattern : Search_Pattern; + File : in out ALI_File; + Local_Symbols : Boolean; + Der_Info : Boolean := False; + Type_Tree : Boolean := False; + Wide_Search : Boolean := True; + Labels_As_Ref : Boolean := True); + -- Output the file and the line where the identifier was referenced, + -- If Local_Symbols is False then only the publicly visible symbols + -- will be processed. + -- + -- If Labels_As_Ref is true, then the references to the entities after + -- the end statements ("end Foo") will be counted as actual references. + -- The entity will never be reported as unreferenced by gnatxref -u + + procedure Parse_Token + (Source : not null access String; + Ptr : in out Positive; + Token_Ptr : out Positive); + -- Skips any separators and stores the start of the token in Token_Ptr. + -- Then stores the position of the next separator in Ptr. On return + -- Source (Token_Ptr .. Ptr - 1) is the token. Separators are space + -- and ASCII.HT. Parse_Token will never skip to the next line. + + procedure Parse_Number + (Source : not null access String; + Ptr : in out Positive; + Number : out Natural); + -- Skips any separators and parses Source up to the first character that + -- is not a decimal digit. Returns value of parsed digits or 0 if none. + + procedure Parse_X_Filename (File : in out ALI_File); + -- Reads and processes "X..." lines in the ALI file + -- and updates the File.X_File information. + + procedure Skip_To_First_X_Line + (File : in out ALI_File; + D_Lines : Boolean; + W_Lines : Boolean); + -- Skip the lines in the ALI file until the first cross-reference line + -- (^X...) is found. Search is started from the beginning of the file. + -- If not such line is found, No_Xref_Information is raised. + -- If W_Lines is false, then the lines "^W" are not parsed. + -- If D_Lines is false, then the lines "^D" are not parsed. + + ---------------- + -- Add_Entity -- + ---------------- + + procedure Add_Entity + (Pattern : in out Search_Pattern; + Entity : String; + Glob : Boolean := False) + is + File_Start : Natural; + Line_Start : Natural; + Col_Start : Natural; + Line_Num : Natural := 0; + Col_Num : Natural := 0; + + File_Ref : File_Reference := Empty_File; + pragma Warnings (Off, File_Ref); + + begin + -- Find the end of the first item in Entity (pattern or file?) + -- If there is no ':', we only have a pattern + + File_Start := Index (Entity, ":"); + + -- If the regular expression is invalid, just consider it as a string + + if File_Start = 0 then + begin + Pattern.Entity := Compile (Entity, Glob, False); + Pattern.Initialized := True; + + exception + when Error_In_Regexp => + + -- The basic idea is to insert a \ before every character + + declare + Tmp_Regexp : String (1 .. 2 * Entity'Length); + Index : Positive := 1; + + begin + for J in Entity'Range loop + Tmp_Regexp (Index) := '\'; + Tmp_Regexp (Index + 1) := Entity (J); + Index := Index + 2; + end loop; + + Pattern.Entity := Compile (Tmp_Regexp, True, False); + Pattern.Initialized := True; + end; + end; + + Set_Default_Match (True); + return; + end if; + + -- If there is a dot in the pattern, then it is a file name + + if (Glob and then + Index (Entity (Entity'First .. File_Start - 1), ".") /= 0) + or else + (not Glob + and then Index (Entity (Entity'First .. File_Start - 1), + "\.") /= 0) + then + Pattern.Entity := Compile (".*", False); + Pattern.Initialized := True; + File_Start := Entity'First; + + else + -- If the regular expression is invalid, just consider it as a string + + begin + Pattern.Entity := + Compile (Entity (Entity'First .. File_Start - 1), Glob, False); + Pattern.Initialized := True; + + exception + when Error_In_Regexp => + + -- The basic idea is to insert a \ before every character + + declare + Tmp_Regexp : String (1 .. 2 * (File_Start - Entity'First)); + Index : Positive := 1; + + begin + for J in Entity'First .. File_Start - 1 loop + Tmp_Regexp (Index) := '\'; + Tmp_Regexp (Index + 1) := Entity (J); + Index := Index + 2; + end loop; + + Pattern.Entity := Compile (Tmp_Regexp, True, False); + Pattern.Initialized := True; + end; + end; + + File_Start := File_Start + 1; + end if; + + -- Parse the file name + + Line_Start := Index (Entity (File_Start .. Entity'Last), ":"); + + -- Check if it was a disk:\directory item (for Windows) + + if File_Start = Line_Start - 1 + and then Line_Start < Entity'Last + and then Entity (Line_Start + 1) = '\' + then + Line_Start := Index (Entity (Line_Start + 1 .. Entity'Last), ":"); + end if; + + if Line_Start = 0 then + Line_Start := Entity'Length + 1; + + elsif Line_Start /= Entity'Last then + Col_Start := Index (Entity (Line_Start + 1 .. Entity'Last), ":"); + + if Col_Start = 0 then + Col_Start := Entity'Last + 1; + end if; + + if Col_Start > Line_Start + 1 then + begin + Line_Num := Natural'Value + (Entity (Line_Start + 1 .. Col_Start - 1)); + + exception + when Constraint_Error => + raise Invalid_Argument; + end; + end if; + + if Col_Start < Entity'Last then + begin + Col_Num := Natural'Value (Entity + (Col_Start + 1 .. Entity'Last)); + + exception + when Constraint_Error => raise Invalid_Argument; + end; + end if; + end if; + + File_Ref := + Add_To_Xref_File + (Entity (File_Start .. Line_Start - 1), Visited => True); + Pattern.File_Ref := File_Ref; + + Add_Line (Pattern.File_Ref, Line_Num, Col_Num); + + File_Ref := + Add_To_Xref_File + (ALI_File_Name (Entity (File_Start .. Line_Start - 1)), + Visited => False, + Emit_Warning => True); + end Add_Entity; + + ------------------- + -- Add_Xref_File -- + ------------------- + + procedure Add_Xref_File (File : String) is + File_Ref : File_Reference := Empty_File; + pragma Unreferenced (File_Ref); + + Iterator : Expansion_Iterator; + + procedure Add_Xref_File_Internal (File : String); + -- Do the actual addition of the file + + ---------------------------- + -- Add_Xref_File_Internal -- + ---------------------------- + + procedure Add_Xref_File_Internal (File : String) is + begin + -- Case where we have an ALI file, accept it even though this is + -- not official usage, since the intention is obvious + + if Tail (File, 4) = "." & Osint.ALI_Suffix.all then + File_Ref := Add_To_Xref_File + (File, Visited => False, Emit_Warning => True); + + -- Normal non-ali file case + + else + File_Ref := Add_To_Xref_File (File, Visited => True); + + File_Ref := Add_To_Xref_File + (ALI_File_Name (File), + Visited => False, Emit_Warning => True); + end if; + end Add_Xref_File_Internal; + + -- Start of processing for Add_Xref_File + + begin + -- Check if we need to do the expansion + + if Ada.Strings.Fixed.Index (File, "*") /= 0 + or else Ada.Strings.Fixed.Index (File, "?") /= 0 + then + Start_Expansion (Iterator, File); + + loop + declare + S : constant String := Expansion (Iterator); + + begin + exit when S'Length = 0; + Add_Xref_File_Internal (S); + end; + end loop; + + else + Add_Xref_File_Internal (File); + end if; + end Add_Xref_File; + + ----------------------- + -- Current_Xref_File -- + ----------------------- + + function Current_Xref_File (File : ALI_File) return File_Reference is + begin + return File.X_File; + end Current_Xref_File; + + -------------------------- + -- Default_Project_File -- + -------------------------- + + function Default_Project_File (Dir_Name : String) return String is + My_Dir : Dir_Type; + Dir_Ent : File_Name_String; + Last : Natural; + + begin + Open (My_Dir, Dir_Name); + + loop + Read (My_Dir, Dir_Ent, Last); + exit when Last = 0; + + if Tail (Dir_Ent (1 .. Last), 4) = ".adp" then + + -- The first project file found is the good one + + Close (My_Dir); + return Dir_Ent (1 .. Last); + end if; + end loop; + + Close (My_Dir); + return String'(1 .. 0 => ' '); + + exception + when Directory_Error => return String'(1 .. 0 => ' '); + end Default_Project_File; + + --------------- + -- File_Name -- + --------------- + + function File_Name + (File : ALI_File; + Num : Positive) return File_Reference + is + begin + return File.Dep.Table (Num); + end File_Name; + + -------------------- + -- Find_ALI_Files -- + -------------------- + + procedure Find_ALI_Files is + My_Dir : Rec_DIR; + Dir_Ent : File_Name_String; + Last : Natural; + + File_Ref : File_Reference; + pragma Unreferenced (File_Ref); + + function Open_Next_Dir return Boolean; + -- Tries to open the next object directory, and return False if + -- the directory cannot be opened. + + ------------------- + -- Open_Next_Dir -- + ------------------- + + function Open_Next_Dir return Boolean is + begin + -- Until we are able to open a new directory + + loop + declare + Obj_Dir : constant String := Next_Obj_Dir; + + begin + -- Case of no more Obj_Dir lines + + if Obj_Dir'Length = 0 then + return False; + end if; + + Open (My_Dir.Dir, Obj_Dir); + exit; + + exception + + -- Could not open the directory + + when Directory_Error => null; + end; + end loop; + + return True; + end Open_Next_Dir; + + -- Start of processing for Find_ALI_Files + + begin + Reset_Obj_Dir; + + if Open_Next_Dir then + loop + Read (My_Dir.Dir, Dir_Ent, Last); + + if Last = 0 then + Close (My_Dir.Dir); + + if not Open_Next_Dir then + return; + end if; + + elsif Last > 4 + and then Dir_Ent (Last - 3 .. Last) = "." & Osint.ALI_Suffix.all + then + File_Ref := + Add_To_Xref_File (Dir_Ent (1 .. Last), Visited => False); + end if; + end loop; + end if; + end Find_ALI_Files; + + ------------------- + -- Get_Full_Type -- + ------------------- + + function Get_Full_Type (Decl : Declaration_Reference) return String is + + function Param_String return String; + -- Return the string to display depending on whether Decl is a parameter + + ------------------ + -- Param_String -- + ------------------ + + function Param_String return String is + begin + if Is_Parameter (Decl) then + return "parameter "; + else + return ""; + end if; + end Param_String; + + -- Start of processing for Get_Full_Type + + begin + case Get_Type (Decl) is + when 'A' => return "array type"; + when 'B' => return "boolean type"; + when 'C' => return "class-wide type"; + when 'D' => return "decimal type"; + when 'E' => return "enumeration type"; + when 'F' => return "float type"; + when 'H' => return "abstract type"; + when 'I' => return "integer type"; + when 'M' => return "modular type"; + when 'O' => return "fixed type"; + when 'P' => return "access type"; + when 'R' => return "record type"; + when 'S' => return "string type"; + when 'T' => return "task type"; + when 'W' => return "protected type"; + + when 'a' => return Param_String & "array object"; + when 'b' => return Param_String & "boolean object"; + when 'c' => return Param_String & "class-wide object"; + when 'd' => return Param_String & "decimal object"; + when 'e' => return Param_String & "enumeration object"; + when 'f' => return Param_String & "float object"; + when 'i' => return Param_String & "integer object"; + when 'j' => return Param_String & "class object"; + when 'm' => return Param_String & "modular object"; + when 'o' => return Param_String & "fixed object"; + when 'p' => return Param_String & "access object"; + when 'r' => return Param_String & "record object"; + when 's' => return Param_String & "string object"; + when 't' => return Param_String & "task object"; + when 'w' => return Param_String & "protected object"; + when 'x' => return Param_String & "abstract procedure"; + when 'y' => return Param_String & "abstract function"; + + when 'h' => return "interface"; + when 'g' => return "macro"; + when 'J' => return "class"; + when 'K' => return "package"; + when 'k' => return "generic package"; + when 'L' => return "statement label"; + when 'l' => return "loop label"; + when 'N' => return "named number"; + when 'n' => return "enumeration literal"; + when 'q' => return "block label"; + when 'Q' => return "include file"; + when 'U' => return "procedure"; + when 'u' => return "generic procedure"; + when 'V' => return "function"; + when 'v' => return "generic function"; + when 'X' => return "exception"; + when 'Y' => return "entry"; + + when '+' => return "private type"; + when '*' => return "private variable"; + + -- The above should be the only possibilities, but for this kind + -- of informational output, we don't want to bomb if we find + -- something else, so just return three question marks when we + -- have an unknown Abbrev value + + when others => + if Is_Parameter (Decl) then + return "parameter"; + else + return "??? (" & Get_Type (Decl) & ")"; + end if; + end case; + end Get_Full_Type; + + -------------------------- + -- Skip_To_First_X_Line -- + -------------------------- + + procedure Skip_To_First_X_Line + (File : in out ALI_File; + D_Lines : Boolean; + W_Lines : Boolean) + is + Ali : String_Access renames File.Buffer; + Token : Positive; + Ptr : Positive := Ali'First; + Num_Dependencies : Natural := 0; + File_Start : Positive; + File_End : Positive; + Gnatchop_Offset : Integer; + Gnatchop_Name : Positive; + + File_Ref : File_Reference; + pragma Unreferenced (File_Ref); + + begin + -- Read all the lines possibly processing with-clauses and dependency + -- information and exit on finding the first Xref line. + -- A fall-through of the loop means that there is no xref information + -- which is an error condition. + + while Ali (Ptr) /= EOF loop + if D_Lines and then Ali (Ptr) = 'D' then + + -- Found dependency information. Format looks like: + -- D src-nam time-stmp checksum [subunit-name] [line:file-name] + + -- Skip the D and parse the filenam + + Ptr := Ptr + 1; + Parse_Token (Ali, Ptr, Token); + File_Start := Token; + File_End := Ptr - 1; + + Num_Dependencies := Num_Dependencies + 1; + Set_Last (File.Dep, Num_Dependencies); + + Parse_Token (Ali, Ptr, Token); -- Skip time-stamp + Parse_Token (Ali, Ptr, Token); -- Skip checksum + Parse_Token (Ali, Ptr, Token); -- Read next entity on the line + + if not (Ali (Token) in '0' .. '9') then + Parse_Token (Ali, Ptr, Token); -- Was a subunit name + end if; + + -- Did we have a gnatchop-ed file with a pragma Source_Reference ? + + Gnatchop_Offset := 0; + + if Ali (Token) in '0' .. '9' then + Gnatchop_Name := Token; + while Ali (Gnatchop_Name) /= ':' loop + Gnatchop_Name := Gnatchop_Name + 1; + end loop; + + Gnatchop_Offset := + 2 - Natural'Value (Ali (Token .. Gnatchop_Name - 1)); + Token := Gnatchop_Name + 1; + end if; + + File.Dep.Table (Num_Dependencies) := Add_To_Xref_File + (Ali (File_Start .. File_End), + Gnatchop_File => Ali (Token .. Ptr - 1), + Gnatchop_Offset => Gnatchop_Offset); + + elsif W_Lines and then Ali (Ptr) = 'W' then + + -- Found with-clause information. Format looks like: + -- "W debug%s debug.adb debug.ali" + + -- Skip the W and parse the .ali filename (3rd token) + + Parse_Token (Ali, Ptr, Token); + Parse_Token (Ali, Ptr, Token); + Parse_Token (Ali, Ptr, Token); + + File_Ref := + Add_To_Xref_File (Ali (Token .. Ptr - 1), Visited => False); + + elsif Ali (Ptr) = 'X' then + + -- Found a cross-referencing line - stop processing + + File.Current_Line := Ptr; + File.Xref_Line := Ptr; + return; + end if; + + Parse_EOL (Ali, Ptr); + end loop; + + raise No_Xref_Information; + end Skip_To_First_X_Line; + + ---------- + -- Open -- + ---------- + + procedure Open + (Name : String; + File : out ALI_File; + Dependencies : Boolean := False) + is + Ali : String_Access renames File.Buffer; + pragma Warnings (Off, Ali); + + begin + if File.Buffer /= null then + Free (File.Buffer); + end if; + + Init (File.Dep); + + begin + Read_File (Name, Ali); + + exception + when Ada.Text_IO.Name_Error | Ada.Text_IO.End_Error => + raise No_Xref_Information; + end; + + Skip_To_First_X_Line (File, D_Lines => True, W_Lines => Dependencies); + end Open; + + --------------- + -- Parse_EOL -- + --------------- + + procedure Parse_EOL + (Source : not null access String; + Ptr : in out Positive; + Skip_Continuation_Line : Boolean := False) + is + begin + loop + -- Skip to end of line + + while Source (Ptr) /= ASCII.CR and then Source (Ptr) /= ASCII.LF + and then Source (Ptr) /= EOF + loop + Ptr := Ptr + 1; + end loop; + + -- Skip CR or LF if not at end of file + + if Source (Ptr) /= EOF then + Ptr := Ptr + 1; + end if; + + -- Skip past CR/LF or LF/CR combination + + if (Source (Ptr) = ASCII.CR or else Source (Ptr) = ASCII.LF) + and then Source (Ptr) /= Source (Ptr - 1) + then + Ptr := Ptr + 1; + end if; + + exit when not Skip_Continuation_Line or else Source (Ptr) /= '.'; + end loop; + end Parse_EOL; + + --------------------------- + -- Parse_Identifier_Info -- + --------------------------- + + procedure Parse_Identifier_Info + (Pattern : Search_Pattern; + File : in out ALI_File; + Local_Symbols : Boolean; + Der_Info : Boolean := False; + Type_Tree : Boolean := False; + Wide_Search : Boolean := True; + Labels_As_Ref : Boolean := True) + is + Ptr : Positive renames File.Current_Line; + Ali : String_Access renames File.Buffer; + + E_Line : Natural; -- Line number of current entity + E_Col : Natural; -- Column number of current entity + E_Type : Character; -- Type of current entity + E_Name : Positive; -- Pointer to begin of entity name + E_Global : Boolean; -- True iff entity is global + + R_Line : Natural; -- Line number of current reference + R_Col : Natural; -- Column number of current reference + R_Type : Character; -- Type of current reference + + Decl_Ref : Declaration_Reference; + File_Ref : File_Reference := Current_Xref_File (File); + + function Get_Symbol_Name (Eun, Line, Col : Natural) return String; + -- Returns the symbol name for the entity defined at the specified + -- line and column in the dependent unit number Eun. For this we need + -- to parse the ali file again because the parent entity is not in + -- the declaration table if it did not match the search pattern. + + procedure Skip_To_Matching_Closing_Bracket; + -- When Ptr points to an opening square bracket, moves it to the + -- character following the matching closing bracket + + --------------------- + -- Get_Symbol_Name -- + --------------------- + + function Get_Symbol_Name (Eun, Line, Col : Natural) return String is + Ptr : Positive := 1; + E_Eun : Positive; -- Unit number of current entity + E_Line : Natural; -- Line number of current entity + E_Col : Natural; -- Column number of current entity + E_Name : Positive; -- Pointer to begin of entity name + + begin + -- Look for the X lines corresponding to unit Eun + + loop + if Ali (Ptr) = 'X' then + Ptr := Ptr + 1; + Parse_Number (Ali, Ptr, E_Eun); + exit when E_Eun = Eun; + end if; + + Parse_EOL (Ali, Ptr, Skip_Continuation_Line => True); + end loop; + + -- Here we are in the right Ali section, we now look for the entity + -- declared at position (Line, Col). + + loop + Parse_Number (Ali, Ptr, E_Line); + exit when Ali (Ptr) = EOF; + Ptr := Ptr + 1; + Parse_Number (Ali, Ptr, E_Col); + exit when Ali (Ptr) = EOF; + Ptr := Ptr + 1; + + if Line = E_Line and then Col = E_Col then + Parse_Token (Ali, Ptr, E_Name); + return Ali (E_Name .. Ptr - 1); + end if; + + Parse_EOL (Ali, Ptr, Skip_Continuation_Line => True); + exit when Ali (Ptr) = EOF; + end loop; + + -- We were not able to find the symbol, this should not happen but + -- since we don't want to stop here we return a string of three + -- question marks as the symbol name. + + return "???"; + end Get_Symbol_Name; + + -------------------------------------- + -- Skip_To_Matching_Closing_Bracket -- + -------------------------------------- + + procedure Skip_To_Matching_Closing_Bracket is + Num_Brackets : Natural; + + begin + Num_Brackets := 1; + while Num_Brackets /= 0 loop + Ptr := Ptr + 1; + if Ali (Ptr) = '[' then + Num_Brackets := Num_Brackets + 1; + elsif Ali (Ptr) = ']' then + Num_Brackets := Num_Brackets - 1; + end if; + end loop; + + Ptr := Ptr + 1; + end Skip_To_Matching_Closing_Bracket; + + -- Start of processing for Parse_Identifier_Info + + begin + -- The identifier info looks like: + -- "38U9*Debug 12|36r6 36r19" + + -- Extract the line, column and entity name information + + Parse_Number (Ali, Ptr, E_Line); + + if Ali (Ptr) > ' ' then + E_Type := Ali (Ptr); + Ptr := Ptr + 1; + end if; + + -- Ignore some of the entities (labels,...) + + case E_Type is + when 'l' | 'L' | 'q' => + Parse_EOL (Ali, Ptr, Skip_Continuation_Line => True); + return; + + when others => + null; + end case; + + Parse_Number (Ali, Ptr, E_Col); + + E_Global := False; + if Ali (Ptr) >= ' ' then + E_Global := (Ali (Ptr) = '*'); + Ptr := Ptr + 1; + end if; + + Parse_Token (Ali, Ptr, E_Name); + + -- Exit if the symbol does not match + -- or if we have a local symbol and we do not want it + + if (not Local_Symbols and not E_Global) + or else (Pattern.Initialized + and then not Match (Ali (E_Name .. Ptr - 1), Pattern.Entity)) + or else (E_Name >= Ptr) + then + Decl_Ref := Add_Declaration + (File.X_File, Ali (E_Name .. Ptr - 1), E_Line, E_Col, E_Type, + Remove_Only => True); + Parse_EOL (Ali, Ptr, Skip_Continuation_Line => True); + return; + end if; + + -- Insert the declaration in the table + + Decl_Ref := Add_Declaration + (File.X_File, Ali (E_Name .. Ptr - 1), E_Line, E_Col, E_Type); + + if Ali (Ptr) = '[' then + Skip_To_Matching_Closing_Bracket; + end if; + + -- Skip any renaming indication + + if Ali (Ptr) = '=' then + declare + P_Line, P_Column : Natural; + pragma Warnings (Off, P_Line); + pragma Warnings (Off, P_Column); + begin + Ptr := Ptr + 1; + Parse_Number (Ali, Ptr, P_Line); + Ptr := Ptr + 1; + Parse_Number (Ali, Ptr, P_Column); + end; + end if; + + if Ali (Ptr) = '<' + or else Ali (Ptr) = '(' + or else Ali (Ptr) = '{' + then + -- Here we have a type derivation information. The format is + -- <3|12I45> which means that the current entity is derived from the + -- type defined in unit number 3, line 12 column 45. The pipe and + -- unit number is optional. It is specified only if the parent type + -- is not defined in the current unit. + + -- We also have the format for generic instantiations, as in + -- 7a5*Uid(3|5I8[4|2]) 2|4r74 + + -- We could also have something like + -- 16I9*I + -- that indicates that I derives from the predefined type integer. + + Ptr := Ptr + 1; + + if Ali (Ptr) in '0' .. '9' then + Parse_Derived_Info : declare + P_Line : Natural; -- parent entity line + P_Column : Natural; -- parent entity column + P_Eun : Positive; -- parent entity file number + + begin + Parse_Number (Ali, Ptr, P_Line); + + -- If we have a pipe then the first number was the unit number + + if Ali (Ptr) = '|' then + P_Eun := P_Line; + Ptr := Ptr + 1; + + -- Now we have the line number + + Parse_Number (Ali, Ptr, P_Line); + + else + -- We don't have a unit number specified, so we set P_Eun to + -- the current unit. + + for K in Dependencies_Tables.First .. Last (File.Dep) loop + P_Eun := K; + exit when File.Dep.Table (K) = File_Ref; + end loop; + end if; + + -- Then parse the type and column number + + Ptr := Ptr + 1; + Parse_Number (Ali, Ptr, P_Column); + + -- Skip the information for generics instantiations + + if Ali (Ptr) = '[' then + Skip_To_Matching_Closing_Bracket; + end if; + + -- Skip '>', or ')' or '>' + + Ptr := Ptr + 1; + + -- The derived info is needed only is the derived info mode is + -- on or if we want to output the type hierarchy + + if Der_Info or else Type_Tree then + declare + Symbol : constant String := + Get_Symbol_Name (P_Eun, P_Line, P_Column); + begin + if Symbol /= "???" then + Add_Parent + (Decl_Ref, + Symbol, + P_Line, + P_Column, + File.Dep.Table (P_Eun)); + end if; + end; + end if; + + if Type_Tree + and then (Pattern.File_Ref = Empty_File + or else + Pattern.File_Ref = Current_Xref_File (File)) + then + Search_Parent_Tree : declare + Pattern : Search_Pattern; -- Parent type pattern + File_Pos_Backup : Positive; + + begin + Add_Entity + (Pattern, + Get_Symbol_Name (P_Eun, P_Line, P_Column) + & ':' & Get_Gnatchop_File (File.Dep.Table (P_Eun)) + & ':' & Get_Line (Get_Parent (Decl_Ref)) + & ':' & Get_Column (Get_Parent (Decl_Ref)), + False); + + -- No default match is needed to look for the parent type + -- since we are using the fully qualified symbol name: + -- symbol:file:line:column + + Set_Default_Match (False); + + -- The parent hierarchy is defined in the same unit as + -- the derived type. So we want to revisit the unit. + + File_Pos_Backup := File.Current_Line; + + Skip_To_First_X_Line + (File, D_Lines => False, W_Lines => False); + + while File.Buffer (File.Current_Line) /= EOF loop + Parse_X_Filename (File); + Parse_Identifier_Info + (Pattern => Pattern, + File => File, + Local_Symbols => False, + Der_Info => Der_Info, + Type_Tree => True, + Wide_Search => False, + Labels_As_Ref => Labels_As_Ref); + end loop; + + File.Current_Line := File_Pos_Backup; + end Search_Parent_Tree; + end if; + end Parse_Derived_Info; + + else + while Ali (Ptr) /= '>' + and then Ali (Ptr) /= ')' + and then Ali (Ptr) /= '}' + loop + Ptr := Ptr + 1; + end loop; + Ptr := Ptr + 1; + end if; + end if; + + -- To find the body, we will have to parse the file too + + if Wide_Search then + declare + File_Ref : File_Reference; + pragma Unreferenced (File_Ref); + File_Name : constant String := Get_Gnatchop_File (File.X_File); + begin + File_Ref := Add_To_Xref_File (ALI_File_Name (File_Name), False); + end; + end if; + + -- Parse references to this entity. + -- Ptr points to next reference with leading blanks + + loop + -- Process references on current line + + while Ali (Ptr) = ' ' or else Ali (Ptr) = ASCII.HT loop + + -- For every reference read the line, type and column, + -- optionally preceded by a file number and a pipe symbol. + + Parse_Number (Ali, Ptr, R_Line); + + if Ali (Ptr) = Pipe then + Ptr := Ptr + 1; + File_Ref := File_Name (File, R_Line); + + Parse_Number (Ali, Ptr, R_Line); + end if; + + if Ali (Ptr) > ' ' then + R_Type := Ali (Ptr); + Ptr := Ptr + 1; + end if; + + -- Imported entities might special indication as to their external + -- name: + -- 5U14*Foo2 5>20 6b22 + + if R_Type = 'b' + and then Ali (Ptr) = '<' + then + while Ptr <= Ali'Last + and then Ali (Ptr) /= '>' + loop + Ptr := Ptr + 1; + end loop; + Ptr := Ptr + 1; + end if; + + Parse_Number (Ali, Ptr, R_Col); + + -- Insert the reference or body in the table + + Add_Reference + (Decl_Ref, File_Ref, R_Line, R_Col, R_Type, Labels_As_Ref); + + -- Skip generic information, if any + + if Ali (Ptr) = '[' then + declare + Num_Nested : Integer := 1; + + begin + Ptr := Ptr + 1; + while Num_Nested /= 0 loop + if Ali (Ptr) = ']' then + Num_Nested := Num_Nested - 1; + elsif Ali (Ptr) = '[' then + Num_Nested := Num_Nested + 1; + end if; + + Ptr := Ptr + 1; + end loop; + end; + end if; + + end loop; + + Parse_EOL (Ali, Ptr); + + -- Loop until new line is no continuation line + + exit when Ali (Ptr) /= '.'; + Ptr := Ptr + 1; + end loop; + end Parse_Identifier_Info; + + ------------------ + -- Parse_Number -- + ------------------ + + procedure Parse_Number + (Source : not null access String; + Ptr : in out Positive; + Number : out Natural) + is + begin + -- Skip separators + + while Source (Ptr) = ' ' or else Source (Ptr) = ASCII.HT loop + Ptr := Ptr + 1; + end loop; + + Number := 0; + while Source (Ptr) in '0' .. '9' loop + Number := + 10 * Number + (Character'Pos (Source (Ptr)) - Character'Pos ('0')); + Ptr := Ptr + 1; + end loop; + end Parse_Number; + + ----------------- + -- Parse_Token -- + ----------------- + + procedure Parse_Token + (Source : not null access String; + Ptr : in out Positive; + Token_Ptr : out Positive) + is + In_Quotes : Character := ASCII.NUL; + + begin + -- Skip separators + + while Source (Ptr) = ' ' or else Source (Ptr) = ASCII.HT loop + Ptr := Ptr + 1; + end loop; + + Token_Ptr := Ptr; + + -- Find end-of-token + + while (In_Quotes /= ASCII.NUL or else + not (Source (Ptr) = ' ' + or else Source (Ptr) = ASCII.HT + or else Source (Ptr) = '<' + or else Source (Ptr) = '{' + or else Source (Ptr) = '[' + or else Source (Ptr) = '=' + or else Source (Ptr) = '(')) + and then Source (Ptr) >= ' ' + loop + -- Double-quotes are used for operators + -- Simple-quotes are used for character constants, for instance when + -- they are found in an enumeration type "type A is ('+', '-');" + + case Source (Ptr) is + when '"' | ''' => + if In_Quotes = Source (Ptr) then + In_Quotes := ASCII.NUL; + elsif In_Quotes = ASCII.NUL then + In_Quotes := Source (Ptr); + end if; + + when others => + null; + end case; + + Ptr := Ptr + 1; + end loop; + end Parse_Token; + + ---------------------- + -- Parse_X_Filename -- + ---------------------- + + procedure Parse_X_Filename (File : in out ALI_File) is + Ali : String_Access renames File.Buffer; + Ptr : Positive renames File.Current_Line; + File_Nr : Natural; + + begin + while Ali (Ptr) = 'X' loop + + -- The current line is the start of a new Xref file section, + -- whose format looks like: + + -- " X 1 debug.ads" + + -- Skip the X and read the file number for the new X_File + + Ptr := Ptr + 1; + Parse_Number (Ali, Ptr, File_Nr); + + if File_Nr > 0 then + File.X_File := File.Dep.Table (File_Nr); + end if; + + Parse_EOL (Ali, Ptr); + end loop; + end Parse_X_Filename; + + -------------------- + -- Print_Gnatfind -- + -------------------- + + procedure Print_Gnatfind + (References : Boolean; + Full_Path_Name : Boolean) + is + Decls : constant Declaration_Array_Access := Get_Declarations; + Decl : Declaration_Reference; + Arr : Reference_Array_Access; + + procedure Print_Ref + (Ref : Reference; + Msg : String := " "); + -- Print a reference, according to the extended tag of the output + + --------------- + -- Print_Ref -- + --------------- + + procedure Print_Ref + (Ref : Reference; + Msg : String := " ") + is + F : String_Access := + Osint.To_Host_File_Spec + (Get_Gnatchop_File (Ref, Full_Path_Name)); + + Buffer : constant String := + F.all & + ":" & Get_Line (Ref) & + ":" & Get_Column (Ref) & + ": "; + + Num_Blanks : Integer := Longest_File_Name + 10 - Buffer'Length; + + begin + Free (F); + Num_Blanks := Integer'Max (0, Num_Blanks); + Write_Line + (Buffer + & String'(1 .. Num_Blanks => ' ') + & Msg & " " & Get_Symbol (Decl)); + + if Get_Source_Line (Ref)'Length /= 0 then + Write_Line (" " & Get_Source_Line (Ref)); + end if; + end Print_Ref; + + -- Start of processing for Print_Gnatfind + + begin + for D in Decls'Range loop + Decl := Decls (D); + + if Match (Decl) then + + -- Output the declaration + + declare + Parent : constant Declaration_Reference := Get_Parent (Decl); + + F : String_Access := + Osint.To_Host_File_Spec + (Get_Gnatchop_File (Decl, Full_Path_Name)); + + Buffer : constant String := + F.all & + ":" & Get_Line (Decl) & + ":" & Get_Column (Decl) & + ": "; + + Num_Blanks : Integer := Longest_File_Name + 10 - Buffer'Length; + + begin + Free (F); + Num_Blanks := Integer'Max (0, Num_Blanks); + Write_Line + (Buffer & String'(1 .. Num_Blanks => ' ') + & "(spec) " & Get_Symbol (Decl)); + + if Parent /= Empty_Declaration then + F := Osint.To_Host_File_Spec (Get_Gnatchop_File (Parent)); + Write_Line + (Buffer & String'(1 .. Num_Blanks => ' ') + & " derived from " & Get_Symbol (Parent) + & " (" + & F.all + & ':' & Get_Line (Parent) + & ':' & Get_Column (Parent) & ')'); + Free (F); + end if; + end; + + if Get_Source_Line (Decl)'Length /= 0 then + Write_Line (" " & Get_Source_Line (Decl)); + end if; + + -- Output the body (sorted) + + Arr := Get_References (Decl, Get_Bodies => True); + + for R in Arr'Range loop + Print_Ref (Arr (R), "(body)"); + end loop; + + Free (Arr); + + if References then + Arr := Get_References + (Decl, Get_Writes => True, Get_Reads => True); + + for R in Arr'Range loop + Print_Ref (Arr (R)); + end loop; + + Free (Arr); + end if; + end if; + end loop; + end Print_Gnatfind; + + ------------------ + -- Print_Unused -- + ------------------ + + procedure Print_Unused (Full_Path_Name : Boolean) is + Decls : constant Declaration_Array_Access := Get_Declarations; + Decl : Declaration_Reference; + Arr : Reference_Array_Access; + F : String_Access; + + begin + for D in Decls'Range loop + Decl := Decls (D); + + if References_Count + (Decl, Get_Reads => True, Get_Writes => True) = 0 + then + F := Osint.To_Host_File_Spec + (Get_Gnatchop_File (Decl, Full_Path_Name)); + Write_Str (Get_Symbol (Decl) + & " (" + & Get_Full_Type (Decl) + & ") " + & F.all + & ':' + & Get_Line (Decl) + & ':' + & Get_Column (Decl)); + Free (F); + + -- Print the body if any + + Arr := Get_References (Decl, Get_Bodies => True); + + for R in Arr'Range loop + F := Osint.To_Host_File_Spec + (Get_Gnatchop_File (Arr (R), Full_Path_Name)); + Write_Str (' ' + & F.all + & ':' & Get_Line (Arr (R)) + & ':' & Get_Column (Arr (R))); + Free (F); + end loop; + + Write_Eol; + Free (Arr); + end if; + end loop; + end Print_Unused; + + -------------- + -- Print_Vi -- + -------------- + + procedure Print_Vi (Full_Path_Name : Boolean) is + Tab : constant Character := ASCII.HT; + Decls : constant Declaration_Array_Access := + Get_Declarations (Sorted => False); + Decl : Declaration_Reference; + Arr : Reference_Array_Access; + F : String_Access; + + begin + for D in Decls'Range loop + Decl := Decls (D); + + F := Osint.To_Host_File_Spec (Get_File (Decl, Full_Path_Name)); + Write_Line (Get_Symbol (Decl) & Tab & F.all & Tab & Get_Line (Decl)); + Free (F); + + -- Print the body if any + + Arr := Get_References (Decl, Get_Bodies => True); + + for R in Arr'Range loop + F := Osint.To_Host_File_Spec (Get_File (Arr (R), Full_Path_Name)); + Write_Line + (Get_Symbol (Decl) & Tab & F.all & Tab & Get_Line (Arr (R))); + Free (F); + end loop; + + Free (Arr); + + -- Print the modifications + + Arr := Get_References (Decl, Get_Writes => True, Get_Reads => True); + + for R in Arr'Range loop + F := Osint.To_Host_File_Spec (Get_File (Arr (R), Full_Path_Name)); + Write_Line + (Get_Symbol (Decl) & Tab & F.all & Tab & Get_Line (Arr (R))); + Free (F); + end loop; + + Free (Arr); + end loop; + end Print_Vi; + + ---------------- + -- Print_Xref -- + ---------------- + + procedure Print_Xref (Full_Path_Name : Boolean) is + Decls : constant Declaration_Array_Access := Get_Declarations; + Decl : Declaration_Reference; + + Margin : constant := 10; + -- Column where file names start + + procedure New_Line80; + -- Go to start of new line + + procedure Print80 (S : String); + -- Print the text, respecting the 80 columns rule + + procedure Print_Ref (Line, Column : String); + -- The beginning of the output is aligned on a column multiple of 9 + + procedure Print_List + (Decl : Declaration_Reference; + Msg : String; + Get_Reads : Boolean := False; + Get_Writes : Boolean := False; + Get_Bodies : Boolean := False); + -- Print a list of references. If the list is not empty, Msg will + -- be printed prior to the list. + + ---------------- + -- New_Line80 -- + ---------------- + + procedure New_Line80 is + begin + Write_Eol; + Write_Str (String'(1 .. Margin - 1 => ' ')); + end New_Line80; + + ------------- + -- Print80 -- + ------------- + + procedure Print80 (S : String) is + Align : Natural := Margin - (Integer (Column) mod Margin); + + begin + if Align = Margin then + Align := 0; + end if; + + Write_Str (String'(1 .. Align => ' ') & S); + end Print80; + + --------------- + -- Print_Ref -- + --------------- + + procedure Print_Ref (Line, Column : String) is + Line_Align : constant Integer := 4 - Line'Length; + + S : constant String := String'(1 .. Line_Align => ' ') + & Line & ':' & Column; + + Align : Natural := Margin - (Integer (Output.Column) mod Margin); + + begin + if Align = Margin then + Align := 0; + end if; + + if Integer (Output.Column) + Align + S'Length > 79 then + New_Line80; + Align := 0; + end if; + + Write_Str (String'(1 .. Align => ' ') & S); + end Print_Ref; + + ---------------- + -- Print_List -- + ---------------- + + procedure Print_List + (Decl : Declaration_Reference; + Msg : String; + Get_Reads : Boolean := False; + Get_Writes : Boolean := False; + Get_Bodies : Boolean := False) + is + Arr : Reference_Array_Access := + Get_References + (Decl, + Get_Writes => Get_Writes, + Get_Reads => Get_Reads, + Get_Bodies => Get_Bodies); + File : File_Reference := Empty_File; + F : String_Access; + + begin + if Arr'Length /= 0 then + Write_Eol; + Write_Str (Msg); + end if; + + for R in Arr'Range loop + if Get_File_Ref (Arr (R)) /= File then + if File /= Empty_File then + New_Line80; + end if; + + File := Get_File_Ref (Arr (R)); + F := Osint.To_Host_File_Spec + (Get_Gnatchop_File (Arr (R), Full_Path_Name)); + + if F = null then + Write_Str (" "); + else + Write_Str (F.all & ' '); + Free (F); + end if; + end if; + + Print_Ref (Get_Line (Arr (R)), Get_Column (Arr (R))); + end loop; + + Free (Arr); + end Print_List; + + F : String_Access; + + -- Start of processing for Print_Xref + + begin + for D in Decls'Range loop + Decl := Decls (D); + + Write_Str (Get_Symbol (Decl)); + + -- Put the declaration type in column Type_Position, but if the + -- declaration name is too long, put at least one space between its + -- name and its type. + + while Column < Type_Position - 1 loop + Write_Char (' '); + end loop; + + Write_Char (' '); + + Write_Line (Get_Full_Type (Decl)); + + Write_Parent_Info : declare + Parent : constant Declaration_Reference := Get_Parent (Decl); + + begin + if Parent /= Empty_Declaration then + Write_Str (" Ptype: "); + F := Osint.To_Host_File_Spec (Get_Gnatchop_File (Parent)); + Print80 (F.all); + Free (F); + Print_Ref (Get_Line (Parent), Get_Column (Parent)); + Print80 (" " & Get_Symbol (Parent)); + Write_Eol; + end if; + end Write_Parent_Info; + + Write_Str (" Decl: "); + F := Osint.To_Host_File_Spec + (Get_Gnatchop_File (Decl, Full_Path_Name)); + + if F = null then + Print80 (" "); + else + Print80 (F.all & ' '); + Free (F); + end if; + + Print_Ref (Get_Line (Decl), Get_Column (Decl)); + + Print_List + (Decl, " Body: ", Get_Bodies => True); + Print_List + (Decl, " Modi: ", Get_Writes => True); + Print_List + (Decl, " Ref: ", Get_Reads => True); + Write_Eol; + end loop; + end Print_Xref; + + ------------ + -- Search -- + ------------ + + procedure Search + (Pattern : Search_Pattern; + Local_Symbols : Boolean; + Wide_Search : Boolean; + Read_Only : Boolean; + Der_Info : Boolean; + Type_Tree : Boolean) + is + type String_Access is access String; + procedure Free is new Unchecked_Deallocation (String, String_Access); + + ALIfile : ALI_File; + File_Ref : File_Reference; + Strip_Num : Natural := 0; + Ali_Name : String_Access; + + begin + -- If we want all the .ali files, then find them + + if Wide_Search then + Find_ALI_Files; + end if; + + loop + -- Get the next unread ali file + + File_Ref := Next_Unvisited_File; + + exit when File_Ref = Empty_File; + + -- Find the ALI file to use. Most of the time, it will be the unit + -- name, with a different extension. However, when dealing with + -- separates the ALI file is in fact the parent's ALI file (and this + -- is recursive, in case the parent itself is a separate). + + Strip_Num := 0; + loop + Free (Ali_Name); + Ali_Name := new String' + (Get_File (File_Ref, With_Dir => True, Strip => Strip_Num)); + + -- Stripped too many things... + + if Ali_Name.all = "" then + if Get_Emit_Warning (File_Ref) then + Set_Standard_Error; + Write_Line + ("warning : file " & Get_File (File_Ref, With_Dir => True) + & " not found"); + Set_Standard_Output; + end if; + Free (Ali_Name); + exit; + + -- If not found, try the parent's ALI file (this is needed for + -- separate units and subprograms). + + -- Reset the cached directory first, in case the separate's + -- ALI file is not in the same directory. + + elsif not File_Exists (Ali_Name.all) then + Strip_Num := Strip_Num + 1; + Reset_Directory (File_Ref); + + -- Else we finally found it + + else + exit; + end if; + end loop; + + -- If we had to get the parent's ALI, insert it in the list as usual. + -- This is to avoid parsing it twice in case it has already been + -- parsed. + + if Ali_Name /= null and then Strip_Num /= 0 then + File_Ref := Add_To_Xref_File + (File_Name => Ali_Name.all, + Visited => False); + + -- Now that we have a file name, parse it to find any reference to + -- the entity. + + elsif Ali_Name /= null + and then (Read_Only or else Is_Writable_File (Ali_Name.all)) + then + begin + Open (Ali_Name.all, ALIfile); + while ALIfile.Buffer (ALIfile.Current_Line) /= EOF loop + Parse_X_Filename (ALIfile); + Parse_Identifier_Info + (Pattern, ALIfile, Local_Symbols, + Der_Info, Type_Tree, Wide_Search, Labels_As_Ref => True); + end loop; + + exception + when No_Xref_Information => + if Get_Emit_Warning (File_Ref) then + Set_Standard_Error; + Write_Line + ("warning : No cross-referencing information in " + & Ali_Name.all); + Set_Standard_Output; + end if; + end; + end if; + end loop; + + Free (Ali_Name); + end Search; + + ----------------- + -- Search_Xref -- + ----------------- + + procedure Search_Xref + (Local_Symbols : Boolean; + Read_Only : Boolean; + Der_Info : Boolean) + is + ALIfile : ALI_File; + File_Ref : File_Reference; + Null_Pattern : Search_Pattern; + + begin + Null_Pattern.Initialized := False; + + loop + -- Find the next unvisited file + + File_Ref := Next_Unvisited_File; + exit when File_Ref = Empty_File; + + -- Search the object directories for the .ali file + + declare + F : constant String := Get_File (File_Ref, With_Dir => True); + + begin + if Read_Only or else Is_Writable_File (F) then + Open (F, ALIfile, True); + + while ALIfile.Buffer (ALIfile.Current_Line) /= EOF loop + Parse_X_Filename (ALIfile); + Parse_Identifier_Info + (Null_Pattern, ALIfile, Local_Symbols, Der_Info, + Labels_As_Ref => False); + end loop; + end if; + + exception + when No_Xref_Information => null; + end; + end loop; + end Search_Xref; + +end Xref_Lib; diff --git a/gcc/ada/xref_lib.ads b/gcc/ada/xref_lib.ads new file mode 100644 index 000000000..e0db3fdb7 --- /dev/null +++ b/gcc/ada/xref_lib.ads @@ -0,0 +1,179 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- X R E F _ L I B -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Miscellaneous utilities for the cross-referencing tool + +with Hostparm; +with Xr_Tabls; use Xr_Tabls; + +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Dynamic_Tables; +with GNAT.Regexp; use GNAT.Regexp; + +package Xref_Lib is + + subtype File_Name_String is String (1 .. Hostparm.Max_Name_Length); + subtype Line_String is String (1 .. Hostparm.Max_Line_Length); + + type ALI_File is limited private; + + --------------------- + -- Directory Input -- + --------------------- + + type Rec_DIR is limited private; + -- This one is used for recursive search of .ali files + + procedure Find_ALI_Files; + -- Find all the ali files that we will have to parse, and have them to + -- the file list + + --------------------- + -- Search patterns -- + --------------------- + + type Search_Pattern is private; + type Search_Pattern_Ptr is access all Search_Pattern; + + procedure Add_Entity + (Pattern : in out Search_Pattern; + Entity : String; + Glob : Boolean := False); + -- Add a new entity to the search pattern (the entity should have the + -- form pattern[:file[:line[:column]]], and it is parsed entirely in + -- this procedure. Glob indicates if we should use the 'globbing + -- patterns' (True) or the full regular expressions (False) + + procedure Add_Xref_File (File : String); + -- Add a new file in the list of files to search for references. File + -- is interpreted as a globbing regular expression, which is expanded. + + Invalid_Argument : exception; + -- Exception raised when there is a syntax error in the command line + + ----------------------- + -- Output Algorithms -- + ----------------------- + + procedure Print_Gnatfind + (References : Boolean; + Full_Path_Name : Boolean); + procedure Print_Unused (Full_Path_Name : Boolean); + procedure Print_Vi (Full_Path_Name : Boolean); + procedure Print_Xref (Full_Path_Name : Boolean); + -- The actual print procedures. These functions step through the symbol + -- table and print all the symbols if they match the files given on the + -- command line (they already match the entities if they are in the + -- symbol table) + + ------------------------ + -- General Algorithms -- + ------------------------ + + function Default_Project_File (Dir_Name : String) return String; + -- Returns the default Project file name for the directory Dir_Name + + procedure Search + (Pattern : Search_Pattern; + Local_Symbols : Boolean; + Wide_Search : Boolean; + Read_Only : Boolean; + Der_Info : Boolean; + Type_Tree : Boolean); + -- Search every ALI file for entities matching Pattern, and add + -- these entities to the internal symbol tables. + -- + -- If Wide_Search is True, all ALI files found in the object path + -- are searched. + -- + -- If Read_Only is True, read-only ALI files will also be parsed, + -- similar to gnatmake -a. + -- + -- If Der_Info is true, then the derived type information will be + -- processed. + -- + -- If Type_Tree is true, then the type hierarchy will be searched + -- going from the pattern to the parent type. + + procedure Search_Xref + (Local_Symbols : Boolean; + Read_Only : Boolean; + Der_Info : Boolean); + -- Search every ali file given in the command line and all their + -- dependencies. If Read_Only is True, we parse the read-only ali + -- files too. If Der_Mode is true then the derived type information will + -- be processed + +private + type Rec_DIR is limited record + Dir : GNAT.Directory_Operations.Dir_Type; + end record; + + package Dependencies_Tables is new GNAT.Dynamic_Tables + (Table_Component_Type => Xr_Tabls.File_Reference, + Table_Index_Type => Positive, + Table_Low_Bound => 1, + Table_Initial => 400, + Table_Increment => 100); + use Dependencies_Tables; + + type Dependencies is new Dependencies_Tables.Instance; + + type ALI_File is limited record + Buffer : String_Access := null; + -- Buffer used to read the whole file at once + + Current_Line : Positive; + -- Start of the current line in Buffer + + Xref_Line : Positive; + -- Start of the xref lines in Buffer + + X_File : Xr_Tabls.File_Reference; + -- Stores the cross-referencing file-name ("X..." lines), as an + -- index into the dependencies table + + Dep : Dependencies; + -- Store file name associated with each number ("D..." lines) + end record; + + -- The following record type stores all the patterns that are searched for + + type Search_Pattern is record + Entity : GNAT.Regexp.Regexp; + -- A regular expression matching the entities we are looking for. + -- File is a list of the places where the declaration of the entities + -- has to be. When the user enters a file:line:column on the command + -- line, it is stored as "Entity_Name Declaration_File:line:column" + + File_Ref : Xr_Tabls.File_Reference; + -- A reference to the source file, if any + + Initialized : Boolean := False; + -- Set to True when Entity has been initialized + end record; + +end Xref_Lib; diff --git a/gcc/ada/xsinfo.adb b/gcc/ada/xsinfo.adb new file mode 100644 index 000000000..3bf6011ff --- /dev/null +++ b/gcc/ada/xsinfo.adb @@ -0,0 +1,254 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT SYSTEM UTILITIES -- +-- -- +-- X S I N F O -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Program to construct C header file sinfo.h (C version of sinfo.ads spec, +-- for use by Gigi, contains all definitions and access functions, but does +-- not contain set procedures, since Gigi never modifies the GNAT tree) + +-- Input files: + +-- sinfo.ads Spec of Sinfo package + +-- Output files: + +-- sinfo.h Corresponding c header file + +-- An optional argument allows the specification of an output file name to +-- override the default sinfo.h file name for the generated output file. + +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.Spitbol; use GNAT.Spitbol; +with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; + +with CSinfo; + +procedure XSinfo is + + Done : exception; + Err : exception; + + A : VString := Nul; + Arg : VString := Nul; + Comment : VString := Nul; + Line : VString := Nul; + N : VString := Nul; + N1, N2 : VString := Nul; + Nam : VString := Nul; + Rtn : VString := Nul; + Term : VString := Nul; + + InS : File_Type; + Ofile : File_Type; + + wsp : constant Pattern := Span (' ' & ASCII.HT); + Wsp_For : constant Pattern := wsp & "for"; + Is_Cmnt : constant Pattern := wsp & "--"; + Typ_Nod : constant Pattern := wsp * A & "type Node_Kind is"; + Get_Nam : constant Pattern := wsp * A & "N_" & Break (",)") * Nam + & Len (1) * Term; + Sub_Typ : constant Pattern := wsp * A & "subtype " & Break (' ') * N; + No_Cont : constant Pattern := wsp & Break (' ') * N1 + & " .. " & Break (';') * N2; + Cont_N1 : constant Pattern := wsp & Break (' ') * N1 & " .." & Rpos (0); + Cont_N2 : constant Pattern := Span (' ') & Break (';') * N2; + Is_Func : constant Pattern := wsp * A & "function " & Rest * Nam; + Get_Arg : constant Pattern := wsp & "(N : " & Break (')') * Arg + & ") return " & Break (';') * Rtn + & ';' & wsp & "--" & wsp & Rest * Comment; + + NKV : Natural; + + M : Match_Result; + + procedure Getline; + -- Get non-comment, non-blank line. Also skips "for " rep clauses + + ------------- + -- Getline -- + ------------- + + procedure Getline is + begin + loop + Line := Get_Line (InS); + + if Line /= "" + and then not Match (Line, Wsp_For) + and then not Match (Line, Is_Cmnt) + then + return; + + elsif Match (Line, " -- End functions (note") then + raise Done; + end if; + end loop; + end Getline; + +-- Start of processing for XSinfo + +begin + -- First run CSinfo to check for errors. Note that CSinfo is also a + -- stand-alone program that can be run separately. + + CSinfo; + + Set_Exit_Status (1); + Anchored_Mode := True; + + if Argument_Count > 0 then + Create (Ofile, Out_File, Argument (1)); + else + Create (Ofile, Out_File, "sinfo.h"); + end if; + + Open (InS, In_File, "sinfo.ads"); + + -- Write header to output file + + loop + Line := Get_Line (InS); + exit when Line = ""; + + Match + (Line, + "-- S p e c ", + "-- C Header File "); + + Match (Line, "--", "/*"); + Match (Line, Rtab (2) * A & "--", M); + Replace (M, A & "*/"); + Put_Line (Ofile, Line); + end loop; + + -- Skip to package line + + loop + Getline; + exit when Match (Line, "package"); + end loop; + + -- Skip to first node kind line + + loop + Getline; + exit when Match (Line, Typ_Nod); + Put_Line (Ofile, Line); + end loop; + + Put_Line (Ofile, ""); + NKV := 0; + + -- Loop through node kind codes + + loop + Getline; + + if Match (Line, Get_Nam) then + Put_Line (Ofile, A & "#define N_" & Nam & ' ' & NKV); + NKV := NKV + 1; + exit when not Match (Term, ","); + + else + Put_Line (Ofile, Line); + end if; + end loop; + + Put_Line (Ofile, ""); + Put_Line (Ofile, A & "#define Number_Node_Kinds " & NKV); + + -- Loop through subtype declarations + + loop + Getline; + + if not Match (Line, Sub_Typ) then + exit when Match (Line, " function"); + Put_Line (Ofile, Line); + + else + Put_Line (Ofile, A & "SUBTYPE (" & N & ", Node_Kind, "); + Getline; + + -- Normal case + + if Match (Line, No_Cont) then + Put_Line (Ofile, A & " " & N1 & ", " & N2 & ')'); + + -- Continuation case + + else + if not Match (Line, Cont_N1) then + raise Err; + end if; + + Getline; + + if not Match (Line, Cont_N2) then + raise Err; + end if; + + Put_Line (Ofile, A & " " & N1 & ','); + Put_Line (Ofile, A & " " & N2 & ')'); + end if; + end if; + end loop; + + -- Loop through functions. Note that this loop is terminated by + -- the call to Getfile encountering the end of functions sentinel + + loop + if Match (Line, Is_Func) then + Getline; + if not Match (Line, Get_Arg) then + raise Err; + end if; + Put_Line + (Ofile, + A & "INLINE " & Rpad (Rtn, 9) + & ' ' & Rpad (Nam, 30) & " (" & Arg & " N)"); + + Put_Line (Ofile, A & " { return " & Comment & " (N); }"); + + else + Put_Line (Ofile, Line); + end if; + + Getline; + end loop; + + -- Can't get here since above loop only left via raise + +exception + when Done => + Close (InS); + Put_Line (Ofile, ""); + Close (Ofile); + Set_Exit_Status (0); + +end XSinfo; diff --git a/gcc/ada/xsnamest.adb b/gcc/ada/xsnamest.adb new file mode 100644 index 000000000..7dd3ca298 --- /dev/null +++ b/gcc/ada/xsnamest.adb @@ -0,0 +1,277 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT SYSTEM UTILITIES -- +-- -- +-- X S N A M E S 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This utility is used to make a new version of the Snames package when new +-- names are added. This version reads a template file from snames.ads-tmpl in +-- which the numbers are all written as $, and generates a new version of the +-- spec file snames.ads (written to snames.ns). It also reads snames.adb-tmpl +-- and generates an updated body (written to snames.nb), and snames.h-tmpl and +-- generates an updated C header file (written to snames.nh). + +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; +with Ada.Strings.Maps; use Ada.Strings.Maps; +with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; + +with GNAT.Spitbol; use GNAT.Spitbol; +with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; + +with XUtil; use XUtil; + +procedure XSnamesT is + + subtype VString is GNAT.Spitbol.VString; + + InS : Ada.Text_IO.File_Type; + InB : Ada.Text_IO.File_Type; + InH : Ada.Text_IO.File_Type; + + OutS : Ada.Streams.Stream_IO.File_Type; + OutB : Ada.Streams.Stream_IO.File_Type; + OutH : Ada.Streams.Stream_IO.File_Type; + + A, B : VString := Nul; + Line : VString := Nul; + Name0 : VString := Nul; + Name1 : VString := Nul; + Oval : VString := Nul; + Restl : VString := Nul; + + Name_Ref : constant Pattern := Span (' ') * A & Break (' ') * Name0 + & Span (' ') * B + & ": constant Name_Id := N + $;" + & Rest * Restl; + + Get_Name : constant Pattern := "Name_" & Rest * Name1; + Chk_Low : constant Pattern := Pos (0) & Any (Lower_Set) & Rest & Pos (1); + Findu : constant Pattern := Span ('u') * A; + + Val : Natural; + + Xlate_U_Und : constant Character_Mapping := To_Mapping ("u", "_"); + + M : Match_Result; + + type Header_Symbol is (None, Name, Attr, Conv, Prag); + -- A symbol in the header file + + procedure Output_Header_Line (S : Header_Symbol); + -- Output header line + + Header_Name : aliased String := "Name"; + Header_Attr : aliased String := "Attr"; + Header_Conv : aliased String := "Convention"; + Header_Prag : aliased String := "Pragma"; + -- Prefixes used in the header file + + type String_Ptr is access all String; + Header_Prefix : constant array (Header_Symbol) of String_Ptr := + (null, + Header_Name'Access, + Header_Attr'Access, + Header_Conv'Access, + Header_Prag'Access); + + -- Patterns used in the spec file + + Get_Attr : constant Pattern := Span (' ') & "Attribute_" + & Break (",)") * Name1; + Get_Conv : constant Pattern := Span (' ') & "Convention_" + & Break (",)") * Name1; + Get_Prag : constant Pattern := Span (' ') & "Pragma_" + & Break (",)") * Name1; + + type Header_Symbol_Counter is array (Header_Symbol) of Natural; + Header_Counter : Header_Symbol_Counter := (0, 0, 0, 0, 0); + + Header_Current_Symbol : Header_Symbol := None; + Header_Pending_Line : VString := Nul; + + ------------------------ + -- Output_Header_Line -- + ------------------------ + + procedure Output_Header_Line (S : Header_Symbol) is + function Make_Value (V : Integer) return String; + -- Build the definition for the current macro (Names are integers + -- offset to N, while other items are enumeration values). + + function Make_Value (V : Integer) return String is + begin + if S = Name then + return "(First_Name_Id + 256 + " & V & ")"; + else + return "" & V; + end if; + end Make_Value; + + begin + -- Skip all the #define for S-prefixed symbols in the header. + -- Of course we are making implicit assumptions: + -- (1) No newline between symbols with the same prefix. + -- (2) Prefix order is the same as in snames.ads. + + if Header_Current_Symbol /= S then + declare + Name2 : VString; + Pat : constant Pattern := "#define " + & Header_Prefix (S).all + & Break (' ') * Name2; + In_Pat : Boolean := False; + + begin + if Header_Current_Symbol /= None then + Put_Line (OutH, Header_Pending_Line); + end if; + + loop + Line := Get_Line (InH); + + if Match (Line, Pat) then + In_Pat := True; + elsif In_Pat then + Header_Pending_Line := Line; + exit; + else + Put_Line (OutH, Line); + end if; + end loop; + + Header_Current_Symbol := S; + end; + end if; + + -- Now output the line + + -- Note that we must ensure at least one space between macro name and + -- parens, otherwise the parenthesized value gets treated as an argument + -- specification. + + Put_Line (OutH, "#define " & Header_Prefix (S).all + & "_" & Name1 + & (30 - Natural'Min (29, Length (Name1))) * ' ' + & Make_Value (Header_Counter (S))); + Header_Counter (S) := Header_Counter (S) + 1; + end Output_Header_Line; + +-- Start of processing for XSnames + +begin + Open (InS, In_File, "snames.ads-tmpl"); + Open (InB, In_File, "snames.adb-tmpl"); + Open (InH, In_File, "snames.h-tmpl"); + + -- Note that we do not generate snames.{ads,adb,h} directly. Instead + -- we output them to snames.n{s,b,h} so that Makefiles can use + -- move-if-change to not touch previously generated files if the + -- new ones are identical. + + Create (OutS, Out_File, "snames.ns"); + Create (OutB, Out_File, "snames.nb"); + Create (OutH, Out_File, "snames.nh"); + + Anchored_Mode := True; + Val := 0; + + loop + Line := Get_Line (InB); + exit when Match (Line, " Preset_Names"); + Put_Line (OutB, Line); + end loop; + + Put_Line (OutB, Line); + + LoopN : while not End_Of_File (InS) loop + Line := Get_Line (InS); + + if not Match (Line, Name_Ref) then + Put_Line (OutS, Line); + + if Match (Line, Get_Attr) then + Output_Header_Line (Attr); + elsif Match (Line, Get_Conv) then + Output_Header_Line (Conv); + elsif Match (Line, Get_Prag) then + Output_Header_Line (Prag); + end if; + else + Oval := Lpad (V (Val), 3, '0'); + + if Match (Name0, "Last_") then + Oval := Lpad (V (Val - 1), 3, '0'); + end if; + + Put_Line + (OutS, A & Name0 & B & ": constant Name_Id := N + " + & Oval & ';' & Restl); + + if Match (Name0, Get_Name) then + Name0 := Name1; + Val := Val + 1; + + if Match (Name0, Findu, M) then + Replace (M, Translate (A, Xlate_U_Und)); + Translate (Name0, Lower_Case_Map); + + elsif not Match (Name0, "Op_", "") then + Translate (Name0, Lower_Case_Map); + + else + Name0 := 'O' & Translate (Name0, Lower_Case_Map); + end if; + + if Name0 = "error" then + Name0 := V (""); + end if; + + if not Match (Name0, Chk_Low) then + Put_Line (OutB, " """ & Name0 & "#"" &"); + end if; + + Output_Header_Line (Name); + end if; + end if; + end loop LoopN; + + loop + Line := Get_Line (InB); + exit when Match (Line, " ""#"";"); + end loop; + + Put_Line (OutB, Line); + + while not End_Of_File (InB) loop + Line := Get_Line (InB); + Put_Line (OutB, Line); + end loop; + + Put_Line (OutH, Header_Pending_Line); + while not End_Of_File (InH) loop + Line := Get_Line (InH); + Put_Line (OutH, Line); + end loop; +end XSnamesT; diff --git a/gcc/ada/xtreeprs.adb b/gcc/ada/xtreeprs.adb new file mode 100644 index 000000000..416e5cbba --- /dev/null +++ b/gcc/ada/xtreeprs.adb @@ -0,0 +1,357 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT SYSTEM UTILITIES -- +-- -- +-- X T R E E P R 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Program to construct the spec of the Treeprs package + +-- Input files: + +-- sinfo.ads Spec of Sinfo package +-- treeprs.adt Template for Treeprs package + +-- Output files: + +-- treeprs.ads Spec of Treeprs package + +-- Note: this program assumes that sinfo.ads has passed the error checks which +-- are carried out by the CSinfo utility so it does not duplicate these checks + +-- An optional argument allows the specification of an output file name to +-- override the default treeprs.ads file name for the generated output file. + +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; + +with GNAT.Spitbol; use GNAT.Spitbol; +with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; +with GNAT.Spitbol.Table_Boolean; use GNAT.Spitbol.Table_Boolean; +with GNAT.Spitbol.Table_VString; use GNAT.Spitbol.Table_VString; + +procedure XTreeprs is + + package TB renames GNAT.Spitbol.Table_Boolean; + package TV renames GNAT.Spitbol.Table_VString; + + Err : exception; + -- Raised on fatal error + + A : VString := Nul; + Ffield : VString := Nul; + Field : VString := Nul; + Fieldno : VString := Nul; + Flagno : VString := Nul; + Line : VString := Nul; + Name : VString := Nul; + Node : VString := Nul; + Outstring : VString := Nul; + Prefix : VString := Nul; + S : VString := Nul; + S1 : VString := Nul; + Syn : VString := Nul; + Synonym : VString := Nul; + Term : VString := Nul; + + subtype Sfile is Ada.Streams.Stream_IO.File_Type; + + OutS : Sfile; + -- Output file + + InS : Ada.Text_IO.File_Type; + -- Read sinfo.ads + + InT : Ada.Text_IO.File_Type; + -- Read treeprs.adt + + Special : TB.Table (20); + -- Table of special fields. These fields are not included in the table + -- constructed by Xtreeprs, since they are specially handled in treeprs. + -- This means these field definitions are completely ignored. + + Names : array (1 .. 500) of VString; + -- Table of names of synonyms + + Positions : array (1 .. 500) of Natural; + -- Table of starting positions in Pchars string for synonyms + + Strings : TV.Table (300); + -- Contribution of each synonym to Pchars string, indexed by name + + Count : Natural := 0; + -- Number of synonyms processed so far + + Curpos : Natural := 1; + -- Number of characters generated in Pchars string so far + + Lineno : Natural := 0; + -- Line number in sinfo.ads + + Field_Base : constant := Character'Pos ('#'); + -- Fields 1-5 are represented by the characters #$%&' (i.e. by five + -- contiguous characters starting at # (16#23#)). + + Flag_Base : constant := Character'Pos ('('); + -- Flags 1-18 are represented by the characters ()*+,-./0123456789 + -- (i.e. by 18 contiguous characters starting at (16#28#)). + + Fieldch : Character; + -- Field character, as per above tables + + Sp : aliased Natural; + -- Space left on line for Pchars output + + wsp : constant Pattern := Span (' ' & ASCII.HT); + Is_Temp : constant Pattern := BreakX ('T') * A & "T e m p l a t e"; + Get_Node : constant Pattern := wsp & "-- N_" & Rest * Node; + Tst_Punc : constant Pattern := Break (" ,."); + Get_Syn : constant Pattern := Span (' ') & "-- " & Break (' ') * Synonym + & " (" & Break (')') * Field; + Brk_Min : constant Pattern := Break ('-') * Ffield; + Is_Flag : constant Pattern := "Flag" & Rest * Flagno; + Is_Field : constant Pattern := Rtab (1) & Len (1) * Fieldno; + Is_Syn : constant Pattern := wsp & "N_" & Break (",)") * Syn + & Len (1) * Term; + Brk_Node : constant Pattern := Break (' ') * Node & ' '; + Chop_SP : constant Pattern := Len (Sp'Unrestricted_Access) * S1; + + M : Match_Result; + + procedure Put_Line (F : Sfile; S : String); + procedure Put_Line (F : Sfile; S : VString); + -- Local version of Put_Line ensures Unix style line endings + + procedure Put_Line (F : Sfile; S : String) is + begin + String'Write (Stream (F), S); + Character'Write (Stream (F), ASCII.LF); + end Put_Line; + + procedure Put_Line (F : Sfile; S : VString) is + begin + Put_Line (F, To_String (S)); + end Put_Line; + +-- Start of processing for XTreeprs + +begin + Anchored_Mode := True; + + if Argument_Count > 0 then + Create (OutS, Out_File, Argument (1)); + else + Create (OutS, Out_File, "treeprs.ads"); + end if; + + Open (InS, In_File, "sinfo.ads"); + Open (InT, In_File, "treeprs.adt"); + + -- Initialize special fields table + + Set (Special, "Analyzed", True); + Set (Special, "Cannot_Be_Constant", True); + Set (Special, "Chars", True); + Set (Special, "Comes_From_Source", True); + Set (Special, "Error_Posted", True); + Set (Special, "Etype", True); + Set (Special, "Has_No_Side_Effects", True); + Set (Special, "Is_Controlling_Actual", True); + Set (Special, "Is_Overloaded", True); + Set (Special, "Is_Static_Expression", True); + Set (Special, "Left_Opnd", True); + Set (Special, "Must_Check_Expr", True); + Set (Special, "No_Overflow_Expr", True); + Set (Special, "Paren_Count", True); + Set (Special, "Raises_Constraint_Error", True); + Set (Special, "Right_Opnd", True); + + -- Read template header and generate new header + + loop + Line := Get_Line (InT); + + -- Skip lines describing the template + + if Match (Line, "-- This file is a template") then + loop + Line := Get_Line (InT); + exit when Line = ""; + end loop; + end if; + + exit when Match (Line, "package"); + + if Match (Line, Is_Temp, M) then + Replace (M, A & " S p e c "); + end if; + + Put_Line (OutS, Line); + end loop; + + Put_Line (OutS, Line); + + -- Copy rest of comments up to template insert point to spec + + loop + Line := Get_Line (InT); + exit when Match (Line, "!!TEMPLATE INSERTION POINT"); + Put_Line (OutS, Line); + end loop; + + -- Here we are doing the actual insertions + + Put_Line (OutS, " Pchars : constant String :="); + + -- Loop through comments describing nodes, picking up fields + + loop + Line := Get_Line (InS); + Lineno := Lineno + 1; + exit when Match (Line, " type Node_Kind"); + + if Match (Line, Get_Node) + and then not Match (Node, Tst_Punc) + then + Outstring := Node & ' '; + + loop + Line := Get_Line (InS); + exit when Line = ""; + + if Match (Line, Get_Syn) + and then not Match (Synonym, "plus") + and then not Present (Special, Synonym) + then + -- Convert this field into the character used to + -- represent the field according to the table: + + -- Field1 '#' + -- Field2 '$' + -- Field3 '%' + -- Field4 '&' + -- Field5 "'" + -- Flag4 '+' + -- Flag5 ',' + -- Flag6 '-' + -- Flag7 '.' + -- Flag8 '/' + -- Flag9 '0' + -- Flag10 '1' + -- Flag11 '2' + -- Flag12 '3' + -- Flag13 '4' + -- Flag14 '5' + -- Flag15 '6' + -- Flag16 '7' + -- Flag17 '8' + -- Flag18 '9' + + if Match (Field, Brk_Min) then + Field := Ffield; + end if; + + if Match (Field, Is_Flag) then + Fieldch := Char (Flag_Base - 1 + N (Flagno)); + + elsif Match (Field, Is_Field) then + Fieldch := Char (Field_Base - 1 + N (Fieldno)); + + else + Put_Line + (Standard_Error, + "*** Line " & + Lineno & + " has unrecognized field name " & + Field); + raise Err; + end if; + + Append (Outstring, Fieldch & Synonym); + end if; + end loop; + + Set (Strings, Node, Outstring); + end if; + end loop; + + -- Loop through actual definitions of node kind enumeration literals + + loop + loop + Line := Get_Line (InS); + Lineno := Lineno + 1; + exit when Match (Line, Is_Syn); + end loop; + + S := Get (Strings, Syn); + Match (S, Brk_Node, ""); + Count := Count + 1; + Names (Count) := Syn; + Positions (Count) := Curpos; + Curpos := Curpos + Length (S); + Put_Line (OutS, " -- " & Node); + Prefix := V (" "); + exit when Term = ")"; + + -- Loop to output the string literal for Pchars + + loop + Sp := 79 - 4 - Length (Prefix); + exit when Size (S) <= Sp; + Match (S, Chop_SP, ""); + Put_Line (OutS, Prefix & '"' & S1 & """ &"); + Prefix := V (" "); + end loop; + + Put_Line (OutS, Prefix & '"' & S & """ &"); + end loop; + + Put_Line (OutS, " """";"); + Put_Line (OutS, ""); + Put_Line + (OutS, " type Pchar_Pos_Array is array (Node_Kind) of Positive;"); + Put_Line + (OutS, + " Pchar_Pos : constant Pchar_Pos_Array := Pchar_Pos_Array'("); + + -- Output lines for Pchar_Pos_Array values + + for M in 1 .. Count - 1 loop + Name := Rpad ("N_" & Names (M), 40); + Put_Line (OutS, " " & Name & " => " & Positions (M) & ','); + end loop; + + Name := Rpad ("N_" & Names (Count), 40); + Put_Line (OutS, " " & Name & " => " & Positions (Count) & ");"); + + Put_Line (OutS, ""); + Put_Line (OutS, "end Treeprs;"); + +exception + when Err => + Put_Line (Standard_Error, "*** fatal error"); + Set_Exit_Status (1); + +end XTreeprs; diff --git a/gcc/ada/xutil.adb b/gcc/ada/xutil.adb new file mode 100644 index 000000000..fbc755c09 --- /dev/null +++ b/gcc/ada/xutil.adb @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT SYSTEM UTILITIES -- +-- -- +-- X U T I L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body XUtil is + + use Ada.Strings.Unbounded; + use Ada.Streams.Stream_IO; + + -------------- + -- New_Line -- + -------------- + + procedure New_Line (F : Sfile) is + begin + Character'Write (Stream (F), ASCII.LF); + end New_Line; + + --------- + -- Put -- + --------- + + procedure Put (F : Sfile; S : String) is + begin + String'Write (Stream (F), S); + end Put; + + --------- + -- Put -- + --------- + + procedure Put (F : Sfile; S : VString) is + begin + Put (F, To_String (S)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (F : Sfile; S : String) is + begin + Put (F, S); + New_Line (F); + end Put_Line; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (F : Sfile; S : VString) is + begin + Put_Line (F, To_String (S)); + end Put_Line; + +end XUtil; diff --git a/gcc/ada/xutil.ads b/gcc/ada/xutil.ads new file mode 100644 index 000000000..b99ca0db0 --- /dev/null +++ b/gcc/ada/xutil.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT SYSTEM UTILITIES -- +-- -- +-- X U T I L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Shared routines for the build-time code generation utilities + +with Ada.Streams.Stream_IO; +with Ada.Strings.Unbounded; + +package XUtil is + + subtype VString is Ada.Strings.Unbounded.Unbounded_String; + subtype Sfile is Ada.Streams.Stream_IO.File_Type; + + procedure Put (F : Sfile; S : String); + procedure Put (F : Sfile; S : VString); + procedure Put_Line (F : Sfile; S : String); + procedure Put_Line (F : Sfile; S : VString); + procedure New_Line (F : Sfile); + -- Similar to the same-named Ada.Text_IO routines, but ensure UNIX line + -- ending on all platforms. + +end XUtil; -- cgit v1.2.3